!AColorSelectorMorph commentStamp: ''!
ColorComponentSelector showing an alpha gradient over a hatched background.!
!AColorSelectorMorph methodsFor: 'accessing' stamp: ''!
color: aColor
	"Set the gradient colors."
	
	super color: aColor beOpaque. 
	self fillStyle: self defaultFillStyle! !

!AColorSelectorMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Draw a hatch pattern first."

	aCanvas
		fillRectangle: self innerBounds
		fillStyle: (InfiniteForm with: self hatchForm).
	super drawOn: aCanvas! !

!AColorSelectorMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		value: 1.0;
		color: Color black! !

!AColorSelectorMorph methodsFor: 'private' stamp: ''!
hatchForm
	"Answer a form showing a grid hatch pattern."

	^ColorPresenterMorph hatchForm! !

!AColorSelectorMorph methodsFor: 'protocol' stamp: ''!
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: ''!
fillStyle: fillStyle
	"If it is a color then override with gradient."
	
	fillStyle isColor
		ifTrue: [self color: fillStyle]
		ifFalse: [super fillStyle: fillStyle]! !

!AColorSelectorMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	anAthensCanvas setPaint: (InfiniteForm with: self hatchForm).
	anAthensCanvas drawShape: self innerBounds.
	super drawOnAthensCanvas: anAthensCanvas! !

!ASTCache commentStamp: ''!
I am a simple cache for AST nodes corresponding to CompiledMethods in the image. The cache is emptied when the image is saved.

The cached #ast is for one interesting for speed (that is, in situations where you ask for it often).

The other use-case is if you want to annotate the AST and keep that annotation around (till the next image save, but you can subscribe to ASTCacheReset and re-install the AST in the cache after cleaning. (This is used by MetaLinks to make sure they survive image restart).

The last thing that it provides is that we do have a quite powerful mapping between bytecode/text/context and the AST. Regardless of how you navigate, you get the same object.

e.g. even this one works:

    [ 1+2 ] sourceNode == thisContext method ast blockNodes first

**NOTE** due to the cached AST, Modification of the AST can be a problem.
Code that wants to modify the AST without making sure the compiledMethod is in sync later should use #parseTree. 
!
!ASTCache methodsFor: 'accessing' stamp: ''!
at: aCompiledMethod
	"for doit methods, the ast is stored in the method propery"
	^ aCompiledMethod propertyAt: #ast ifAbsent: [ 
		  self
			  at: aCompiledMethod
			  ifAbsentPut: [ 
			  self class cacheMissStrategy getASTFor: aCompiledMethod ] ]! !

!ASTCache methodsFor: 'initialization' stamp: ''!
reset
	self removeAll! !

!ASTCache class methodsFor: 'accessing' stamp: ''!
cacheMissStrategy: aCacheMissStrategy
	^ CacheMissStrategy := aCacheMissStrategy! !

!ASTCache class methodsFor: 'system startup' stamp: ''!
shutDown	
	self reset! !

!ASTCache class methodsFor: 'accessing' stamp: ''!
at: aCompiledMethod
	^ self default at: aCompiledMethod! !

!ASTCache class methodsFor: 'accessing' stamp: ''!
cacheMissStrategy
	^ CacheMissStrategy
		ifNil: [ CacheMissStrategy := ASTCacheMissStrategy new ]! !

!ASTCache class methodsFor: 'accessing' stamp: ''!
default
	^ default ifNil: [ 
		SessionManager default registerSystemClassNamed: self name.
		default := self new ]! !

!ASTCache class methodsFor: 'private - announcements' stamp: ''!
announceCacheReset

	SystemAnnouncer uniqueInstance announce: ASTCacheReset new! !

!ASTCache class methodsFor: 'accessing' stamp: ''!
default: anASTCache
	default := anASTCache! !

!ASTCache class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	self default reset.
	self announceCacheReset! !

!ASTCacheMissStrategy commentStamp: ''!
The ASTCache is queried when we request the ast (via #ast) of a CompiledMethod.
If the AST has already been requested before, the cache will return it.

To create the AST for a method the first time, the cache uses a strategy pattern. 
This class is the simple strategy: call #parseTree, so semantic analysis. 

If Reflectivity is loaded, the RFReflectivityASTCacheStrategy is used instead which
will take the AST from the ReflectiveMethod, should it have been created.!
!ASTCacheMissStrategy methodsFor: 'accessing' stamp: ''!
getASTFor: aCompiledMethod
	^ aCompiledMethod parseTree doSemanticAnalysisIn: aCompiledMethod methodClass! !

!ASTCacheReset commentStamp: ''!
An Announcement signalled to tell that the default AST Cache has been reset.
Tools that want persistent AST annotations can subscribe to this announcement to reinstall annotations.!
!ASTCacheResetTest methodsFor: 'running' stamp: ''!
tearDown
	ASTCache default: cache.
	node removeLink: link.
	super tearDown! !

!ASTCacheResetTest methodsFor: 'tests - material' stamp: ''!
annotatedMethod
	^ 42! !

!ASTCacheResetTest methodsFor: 'tests' stamp: ''!
testCacheResetPreserveLinks
	self annotatedMethod.
	self assert: counter equals: 1.
	ASTCache reset.
	self assert: (self class >> #annotatedMethod) ast statements last value links anyOne identicalTo: link.
	self annotatedMethod.
	self assert: counter equals: 2! !

!ASTCacheResetTest methodsFor: 'tests - material' stamp: ''!
increment
	counter := counter + 1! !

!ASTCacheResetTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	cache := ASTCache default copy.
	counter := 0.
	link := MetaLink new
		metaObject: self;
		selector: #increment.
	node := (self class >> #annotatedMethod) ast statements last value.
	node link: link! !

!ASTClassBuilderTest commentStamp: ''!
I am testing the creation of Classes from an AST!
!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateNormalClassWithSharedPools

	| ast class resTest |
	ast := self parserClass parse: 'Class subclass: #TestSubClass
															poolDictionaries: ''TestSharedPool ShTestSharedPool'''.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	resTest := OrderedCollection new.
	resTest add: 'TestSharedPool' asSymbol.
	resTest add: 'ShTestSharedPool' asSymbol.
	self assert: class sharedPoolNames equals: resTest! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateWeakClassNamed

	| ast class |
	ast := self parserClass parse: 'Class weakSubclass: #TestSubClass'.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.

	self assert: class isWeak.
	self assert: class name equals: #TestSubClass! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateImmediateClassWithAll

	| ast class |
	ast := self parserClass parse:
		       'Class immediateSubclass: #TestSubClass
															uses:   TAddForUniquenessTest + TIncludesWithIdentityCheckTest
															instanceVariableNames: ''cat env''
															classVariableNames: ''var classVar pouet''
															poolDictionaries: ''TestSharedPool ShTestSharedPool''
															package: ''Kernel-Classes'''.

	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class isImmediateClass.
	self assert: class name equals: #TestSubClass.
	self assert: class instanceVariablesString equals: ''.
	self assert: class classVarNames equals: #( #classVar #pouet #var )! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateVariableWordClassWithAll

	| ast class |
	ast := self parserClass parse:
		       'Object variableWordSubclass: #TestSubClass
															uses:   TAddForUniquenessTest + TIncludesWithIdentityCheckTest
															instanceVariableNames: ''cat env''
															classVariableNames: ''var classVar pouet''
															poolDictionaries: ''TestSharedPool ShTestSharedPool''
															package: ''Kernel-Classes'''.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class name equals: #TestSubClass.
	self assert: class instanceVariablesString equals: ''.
	self assert: class classVarNames equals: #( #classVar #pouet #var ).
	self assert: class classLayout class equals: WordLayout.! !

!ASTClassBuilderTest methodsFor: 'environmentSetUp' stamp: ''!
environment
	^ ShSmalltalkGlobalsEnvironment new.! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateWeakClassWithAll

	| ast class |
	ast := self parserClass parse: 'Class weakSubclass: #TestSubClass
															uses:   TAddForUniquenessTest + TIncludesWithIdentityCheckTest
															instanceVariableNames: ''cat env''
															classVariableNames: ''var classVar pouet''
															poolDictionaries: ''TestSharedPool ShTestSharedPool''
															package: ''Kernel-Classes'''.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.

	self assert: class isWeak.
	self assert: class name equals: #TestSubClass.
	self assert: class instanceVariablesString equals: 'cat env'! !

!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateNormalClassWithPackage

	| ast class |
	ast := self parserClass parse: 'Class subclass: #TestSubClass
															package: ''Kernel-Classes'''.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class category equals: #Unclassified! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateVariableClassWithAll

	| ast class |
	ast := self parserClass parse:
		       'Class variableSubclass: #TestSubClass
															uses:   TAddForUniquenessTest + TIncludesWithIdentityCheckTest
															instanceVariableNames: ''cat env''
															classVariableNames: ''var classVar pouet''
															poolDictionaries: ''TestSharedPool ShTestSharedPool''
															package: ''Kernel-Classes'''.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class isVariable.
	self assert: class name equals: #TestSubClass.
	self assert: class instanceVariablesString equals: 'cat env'.
	self assert: class classVarNames equals: #( #classVar #pouet #var )! !

!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateTraitUsingAnotherSingleTrait

	| ast class |
	ast := self parserClass parse: 'Trait named: #TTestTrait
															uses: TOccurrencesTest'.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: (class isComposedBy: TOccurrencesTest)! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
parserClass

	^ CDClassDefinitionParser! !

!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateTraitUsingAnotherTraitComposition

	| ast class |
	ast := self parserClass parse: 'Trait named: #TTestTrait
															uses: TOccurrencesTest + TAddForUniquenessTest'.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: (class isComposedBy: TOccurrencesTest).
	self assert: (class isComposedBy: TAddForUniquenessTest)! !

!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateTraitWithoutOtherTraits

	| ast class |
	ast := self parserClass parse: 'Trait named: #TTestTrait
															uses: {}'.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class traits isEmpty! !

!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateNormalClassWithIV

	| ast class |
	ast := self parserClass parse: 'Class subclass: #TestSubClass
															instanceVariableNames: '''''.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class instanceVariablesString equals: ''! !

!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateNormalClassWithTrait

	| ast class |
	ast := self parserClass parse: 'Class subclass: #TestSubClass
															uses: TOccurrencesTest'.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: (class isComposedBy: TOccurrencesTest)! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateVariableWordClassNamed

	| ast class |
	ast := self parserClass parse:
		       'Object variableWordSubclass: #TestSubClass'.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class isWords.
	self assert: class name equals: #TestSubClass! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateEphemeronClassWithAll

	| ast class |
	ast := self parserClass parse:
		       'Class ephemeronSubclass: #TestSubClass
															uses:   TAddForUniquenessTest + TIncludesWithIdentityCheckTest
															instanceVariableNames: ''cat env''
															classVariableNames: ''var classVar pouet''
															poolDictionaries: ''TestSharedPool ShTestSharedPool''
															package: ''Kernel-Classes'''.

	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.

	self assert: class isEphemeronClass.
	self assert: class name equals: #TestSubClass.
	self assert: class instanceVariablesString equals: 'cat env'.
	self assert: class classVarNames equals: #( #classVar #pouet #var )! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateImmediateClassNamed

	| ast class |
	ast := self parserClass parse: 'Class immediateSubclass: #TestSubClass'.

	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.

	self assert: class isImmediateClass.
	self assert: class name equals: #TestSubClass! !

!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateNormalClassSuperClass

	| ast class |
	ast := self parserClass parse: 'Xcrd subclass: #TestSubClass'.
	class := ShiftClassBuilder new
		         useUndefinedClass;
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.

	self
		assert: class superclass
		equals: (self environment classNamed: 'Xcrd')! !

!ASTClassBuilderTest methodsFor: 'resolveSuperclass' stamp: ''!
testDefaultResolve

	| ast |
	ast := self parserClass parse: 'cdfgdf subclass: #TestSubClass
															uses: TOccurrencesTest'.
	self
		should: [ 
			ShiftClassBuilder new
				buildEnvironment: self environment;
				buildFromAST: ast;
				build ]
		raise: Error! !

!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateNormalClassNamed

	| ast class |
	ast := self parserClass parse: 'Object subclass: #TestClass'.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class name equals: #TestClass! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateVariableByteClassNamed

	| ast class |
	ast := self parserClass parse:
		       'Object variableByteSubclass: #TestSubClass'.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class isBytes.
	self assert: class name equals: #TestSubClass! !

!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateNormalClassWithClassVariable

	| ast class |
	ast := self parserClass parse: 'Class subclass: #TestSubClass
															classVariableNames: ''var classVar pouet'' '.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.

	self assert: class classVarNames equals: #( #classVar #pouet #var )! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateVariableClassNamed

	| ast class |
	ast := self parserClass parse:
		       'Class variableSubclass: #TestSubClass'.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class isVariable.
	self assert: class name equals: #TestSubClass! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateVariableByteClassWithAll

	| ast class |
	ast := self parserClass parse:
		       'Object variableByteSubclass: #TestSubClass
															uses:   TAddForUniquenessTest + TIncludesWithIdentityCheckTest
															instanceVariableNames: ''cat env''
															classVariableNames: ''var classVar pouet''
															poolDictionaries: ''TestSharedPool ShTestSharedPool''
															package: ''Kernel-Classes'''.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: class name equals: #TestSubClass.
	self assert: class instanceVariablesString equals: ''.
	self assert: class classVarNames equals: #( #classVar #pouet #var )! !

!ASTClassBuilderTest methodsFor: 'running' stamp: ''!
testCreateEphemeronClassNamed

	| ast class |
	ast := self parserClass parse:
		       'Class ephemeronSubclass: #TestSubClass'.

	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.

	self assert: class isEphemeronClass.
	self assert: class name equals: #TestSubClass! !

!ASTClassBuilderTest methodsFor: 'tests' stamp: ''!
testCreateNormalClassWithTraitComposition

	| ast class |
	ast := self parserClass parse: 'Class subclass: #TestSubClass
															uses:   TAddForUniquenessTest + TIncludesWithIdentityCheckTest + TCloneTest + TCopyTest + TRemoveTest + TGrowableTest + TStructuralEqualityTest + TPrintTest + TAsStringCommaAndDelimiterTest + TConvertTest + TConvertAsSortedTest + TConcatenationEqualElementsRemovedTest + TOccurrencesTest + (TCreationWithTest - {#testOfSize. #collectionClass}) + (TSetArithmetic - {#collectionClass})'.
	class := ShiftClassBuilder new
		         buildEnvironment: self environment;
		         buildFromAST: ast;
		         build.
	self assert: (class isComposedBy: TAddForUniquenessTest).
	self assert: (class isComposedBy: TIncludesWithIdentityCheckTest)! !

!ASTClassBuilderTest methodsFor: 'resolveSuperclass' stamp: ''!
testUseUndefinedClass

	| ast |
	ast := self parserClass parse: 'PoPouet subclass: #TestClass'.
	ShiftClassInstaller new make: [ :builder | 
		builder
			useUndefinedClass;
			buildEnvironment: self environment;
			buildFromAST: ast ].
	self assert: [ 
		(ShSmalltalkGlobalsEnvironment new classNamed: #PoPouet) isUndefined ]! !

!ASTEvaluationTest commentStamp: ''!
I am testing AST evaluation !
!ASTEvaluationTest methodsFor: 'tests' stamp: ''!
testEvaluateForContext
	| varForTesting node |
	varForTesting := 4@5.

	"first we test if we can read the temp varForTesting"
	node := thisContext method variableNodes first.
	self assert: (node evaluateForContext: thisContext) equals: varForTesting.

	"lets check self, super"
	node := RBVariableNode selfNode.
	self assert: (node evaluateForContext: thisContext) equals: thisContext receiver.
	node := RBVariableNode superNode.
	self assert: (node evaluateForContext: thisContext) equals: thisContext receiver.

	"thisContext is not the thisContext of this method though... it is the context of the evaluating doit"
	node := RBVariableNode thisContextNode.
	self deny: (node evaluateForContext: thisContext) equals: thisContext.	

	"reading ivars works, too"
	node := RBVariableNode named: 'testSelector'.
	self assert: (node evaluateForContext: thisContext) equals: #testEvaluateForContext.! !

!ASTEvaluationTest methodsFor: 'tests' stamp: ''!
testEvaluate
	self assert: (RBLiteralNode value: 5) evaluate equals: 5.
	self assert: (RBMessageNode receiver: 5 asLiteralNode selector: #class ) evaluate equals: 5 class! !

!ASTEvaluationTest methodsFor: 'tests' stamp: ''!
testEvaluateForReceiver
	| receiver node |
	receiver := 4@5.
	node := (receiver class>>#x) variableNodes first.
	self assert: (node evaluateForReceiver: receiver) equals: 4.
	node := RBVariableNode selfNode.
	self assert: (node evaluateForReceiver: receiver) equals: receiver.
	node := RBVariableNode superNode.
	self assert: (node evaluateForReceiver: receiver) equals: receiver.! !

!ASTPluginMeaningOfLife commentStamp: ''!
A simple example for a AST transforming compiler plugin.

I replace 42 with a  'meaning of life'.!
!ASTPluginMeaningOfLife methodsFor: 'transformation' stamp: ''!
transform
	| rule |
	"copy the AST as we modify it"
	ast := ast copy. 
	"we use the RBParseTreeRewriter to do the change, anothe option is to do it directly using
	e.g #replaceWith:"
	rule := RBParseTreeRewriter replaceLiteral: 42 with: 'meaning of life'.
	rule executeTree: ast.
	^ast! !

!ASTPluginMeaningOfLife class methodsFor: 'accessing' stamp: ''!
priority
	^ 0! !

!ASTTransformExamplePluginActive commentStamp: ''!
This class changes the default compiler used to compile itself to include the AST transforming plugin ASTPluginMeaningOfLife.

#example42 does not mean what you think it means (see bytecode)!
!ASTTransformExamplePluginActive methodsFor: 'examples' stamp: ''!
example42
	<sampleInstance>
	^42! !

!ASTTransformExamplePluginActive class methodsFor: 'compiler' stamp: ''!
compiler
	"the example plugin is active for this class"
	^super compiler addPlugin: ASTPluginMeaningOfLife.! !

!ASTTransformationPluginTest methodsFor: 'tests' stamp: ''!
testTransform
	| ast |
	ast := (OCOpalExamples >> #exampleReturn42) ast copy.
	self assert: ast body statements first value value equals: 42.
	ast := ASTPluginMeaningOfLife transform: ast.
	self assert: ast body statements first value value equals: 'meaning of life'! !

!ASTTransformationPluginTest methodsFor: 'tests' stamp: ''!
testClassWithPluginEnabled
	self assert: ASTTransformExamplePluginActive new example42 equals: 'meaning of life'! !

!Abort commentStamp: ''!
Notify to abort a task!
!AboutDialogWindow commentStamp: ''!
Default superclass for application about dialogs.!
!AboutDialogWindow methodsFor: 'defaults' stamp: ''!
defaultLabel
	"Answer the default label for the receiver."

	^'About' translated! !

!AboutDialogWindow class methodsFor: 'instance creation' stamp: ''!
openForPharo
	<script>
	| text dialog width |
	text := Smalltalk systemInformationString withCRs.
	width := 0.
	text
		linesDo: [ :l | 
			width := width
				max: (self theme textFont widthOfStringOrText: l) ].
	dialog := self new entryText: text.
	dialog iconMorph image: (self iconNamed: #pharoIcon).
	dialog title: 'About Pharo'.
	dialog open.
	dialog textMorph
		minWidth: 20;
		minHeight: 20.
	dialog width: (width + 120 min: Display width - 50).
	dialog position: 25 @ 25! !

!AboutDialogWindow class methodsFor: 'instance creation' stamp: ''!
open 
	<script>
	
	^(self new) 
		open;
		yourself! !

!AbsolutePath commentStamp: ''!
I represent an absolute path (a position starting from Path root)!
!AbsolutePath methodsFor: 'printing' stamp: ''!
printPathOn: aStream delimiter: aCharacter
	"Print the path elements of the receiver, without the 'Path *' part"

	aStream nextPut: aCharacter.
	super printPathOn: aStream delimiter: aCharacter! !

!AbsolutePath methodsFor: '*Zinc-Resource-Meta-FileSystem' stamp: ''!
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: ''!
withParents
	| root |
	root := Path root.
	^ super withParents
		remove: root ifAbsent: [ "In case it's absent we do not care." ];
		addFirst: root;
		yourself! !

!AbsolutePath methodsFor: '*System-Settings-Core' stamp: ''!
acceptSettings: aVisitor
	^ aVisitor visitAbsolutePath: self! !

!AbsolutePath methodsFor: 'testing' stamp: ''!
isRoot
	^ self size = 0! !

!AbsolutePath methodsFor: 'testing' stamp: ''!
isAbsolute
	^ true! !

!AbsolutePath methodsFor: '*Zinc-Resource-Meta-FileSystem' stamp: ''!
asUrl
	"Convert the receiver in a file:// ZnUrl"

	^ self asZnUrl! !

!AbsolutePath methodsFor: 'printing' stamp: ''!
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 class methodsFor: 'private' stamp: ''!
addEmptyElementTo: result! !

!AbsolutePath class methodsFor: 'instance creation' stamp: ''!
from: aString delimiter: aDelimiterCharater
	aString = '/'
		ifTrue: [ ^ self root ].
		
	^ super from: aString delimiter: aDelimiterCharater! !

!AbsolutePathStoredSetting commentStamp: ''!
I am responsible for storing information about AbsolutePath objects.!
!AbsolutePathStoredSetting methodsFor: 'accessing' stamp: ''!
realValue
	^ (AbsolutePath withAll: realValue) asFileReference! !

!AbstractAdapter commentStamp: ''!
I am an abstract class.

I'm the superclass of all the adapters used to link a Spec widget presenter to a framework specific widget (by example ButtonPresenter <-> PluggableButtonMorph).

The current implementation installs my instances as dependent of the presenter and my changed: method propagates updates to the widget I create (via my buildWidget method). This implementation is not optimal. 

In the future my instances should just be responsible to create a widget and install all the communication between the presenter and the widget. I should not be a middle man. !
!AbstractAdapter methodsFor: 'protocol' stamp: ''!
hSpaceFill

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'updating' stamp: ''!
update: aSymbol with: anArray

	self perform: aSymbol withArguments: anArray! !

!AbstractAdapter methodsFor: 'private' stamp: ''!
widgetDo: aBlock

	^ self widget ifNotNil: aBlock! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
add: aWidget

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
layout: aLayout

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
vShrinkWrap

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ self subclassResponsibility! !

!AbstractAdapter methodsFor: 'updating' stamp: ''!
update: aSymbol

	self changed: aSymbol! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
vSpaceFill

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
hRigid

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
vRigid

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
useProportionalLayout

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
removeSubWidgets

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!AbstractAdapter methodsFor: 'testing' stamp: ''!
isSpecAdapter

	^ true! !

!AbstractAdapter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
isMorphicAdapter

	^ false! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
hShrinkWrap

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'accessing' stamp: ''!
selector
	
	^ selector! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
asWidget

	^ self widget! !

!AbstractAdapter methodsFor: 'accessing' stamp: ''!
selector: anObject
	
	selector := anObject! !

!AbstractAdapter methodsFor: 'initialization' stamp: ''!
adapt: aComposablePresenter

	model := aComposablePresenter.
	aComposablePresenter addDependent: self.

	widget := self buildWidget.! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
takeKeyboardFocus
	
	self widget ifNotNil: [:w | w takeKeyboardFocus ]! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
when: anAnnouncement do: aBlock

	self subclassResponsibility! !

!AbstractAdapter methodsFor: 'accessing' stamp: ''!
widget
	^ widget! !

!AbstractAdapter methodsFor: 'protocol' stamp: ''!
isRedrawable
	"This must be overriden in the adapter representing your container"
	
	^ false! !

!AbstractAdapter class methodsFor: 'instance creation' stamp: ''!
adapt: aComposablePresenter
	
	^ self new
		adapt: aComposablePresenter;
		yourself! !

!AbstractBinaryFileStream commentStamp: ''!
Provides a simple, platform-independent, file stream. I am 
- binary
- not buffered
- provide no encoding/conversions

### Examples of usage
```
"Creating a file"
stream := (File named: 'asd.txt' asFileReference fullName) readStream.

"Accessing the stream properties"
stream position.
stream atEnd.

"Writing"
stream nextPut: 17.
stream nextPutAll: 'sdd'.

"Reading"
stream next.
stream next: 2.

"Skipping"
stream skip: 2. 

"reading up to something"
stream upTo: 23.
stream upToAnyOf: #[ 13 30 ].

"peeking"
stream peek.
```!
!AbstractBinaryFileStream methodsFor: 'character writing' stamp: 'nil'!
cr
	
	self nextPut: Character cr asInteger! !

!AbstractBinaryFileStream methodsFor: 'positioning' stamp: 'nil'!
position

	^ File getPosition: handle! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
nextInto: aBuffer
	"Return a string with the next n characters of the filestream in it."

	^ self next: aBuffer size into: aBuffer! !

!AbstractBinaryFileStream methodsFor: 'character writing' stamp: 'nil'!
lf

	self nextPut: Character lf asInteger! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
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 subclassResponsibility! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
next: n
	"Return a string with the next n characters of the filestream in it."

	^ self next: n into: (ByteArray new: n)! !

!AbstractBinaryFileStream methodsFor: 'positioning' stamp: 'nil'!
position: aPosition
	
	File setPosition: handle to: aPosition! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
upToEnd
	"Answer a subcollection from the current access position through the last element of the receiver."

	^ByteArray streamContents: [ :newStream |
		| next |
		[ (next := self next) isNil ] whileFalse: [
			newStream nextPut: next ] ]! !

!AbstractBinaryFileStream methodsFor: 'reading' stamp: 'nil'!
next: n into: aString startingAt: startIndex
	"Read n bytes into the given string.
	Return aString or a partial copy if less than
	n elements have been read."
	|read|
	read := (self readInto: aString startingAt: startIndex count: n).
	^read = n 
		ifTrue: [ aString ]
		ifFalse: [ aString copyFrom: 1 to: startIndex + read - 1 ]! !

!AbstractBinaryFileStream methodsFor: 'testing' stamp: 'nil'!
isBinary
	^ true! !

!AbstractBinaryFileStream methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	"Put a printed version of the receiver onto aStream."

	aStream
		nextPutAll: self class name;
		nextPutAll: ': ';
		print: file name! !

!AbstractBinaryFileStream methodsFor: 'reading' stamp: 'nil'!
waitForData
	
	"Waits for data on a semaphore.
	This message is useful for using on streams and pipes. 
	
	This message uses a primitive that needs to be available to work.
	Also, it uses an external semaphore, so after ending its use please send the message #releaseSemaphores
	
	Ex: [[Stdio stdin atEnd] 
			whileFalse: [Stdio stdin waitForData.
			(Stdio stdin next: 100) printString traceCr]] fork.
	In Windows, it is better to use something like:
	
	[[Stdio stdin waitForData.
			(Stdio stdin next: 100) printString traceCr] repeat] fork

	"

	semaphore ifNil: [ semaphore := Semaphore new].
	semaphoreIndex ifNil: [ semaphoreIndex := Smalltalk registerExternalObject: semaphore].

	File primitiveWaitForDataOn: handle signalling: semaphoreIndex.
	semaphore wait.! !

!AbstractBinaryFileStream methodsFor: 'writing' stamp: 'nil'!
nextPut: anInteger

	^ self nextPutAll: (ByteArray with: anInteger asInteger)! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
file
	^ file! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
contents
	"Answer the contents of the receiver while leaving the position unchanged.
	Fail if the receiver doesn't support positioning.
	#upToEnd provides an alternative that doesn't rely on stream positioning."

	| savedPosition contents |

	savedPosition := self position.
	self position: 0.
	contents := self upToEnd.
	self position: savedPosition.
	^contents! !

!AbstractBinaryFileStream methodsFor: 'flushing' stamp: 'nil'!
flush
	"When writing, this flushes the write buffer the stream uses to reduce
	the number of write() system calls it makes. This should generally be
	used before #sync, but on Windows they do the same thing."
	
	File flush: handle! !

!AbstractBinaryFileStream methodsFor: 'testing' stamp: 'nil'!
atEnd

	^ File atEnd: handle! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
next: n into: aBuffer
	"Return a string with the next n characters of the filestream in it."
	| readBuffer read |
	readBuffer := aBuffer.
	read := File read: handle into: readBuffer startingAt: 1 count: n.
	^read = n 
		ifTrue: [ readBuffer ]
		ifFalse: [ readBuffer copyFrom: 1 to: read ]! !

!AbstractBinaryFileStream methodsFor: 'reading' stamp: 'nil'!
releaseSemaphores

	"To wait for data to arrival in an stream, it is required to keep a semaphore and this one should be registered in the VM. As this is a constrained resource, the user of wait data should relelease the semaphore when it is not used anymore"

	semaphore ifNotNil: [ 
		Smalltalk unregisterExternalObject: semaphore].
	
	semaphoreIndex := nil.	
	semaphore := nil.! !

!AbstractBinaryFileStream methodsFor: 'writing' stamp: 'nil'!
next: amount putAll: aByteArray
	forWrite
		ifFalse: [ ^ self error: 'Cannot write a read-only file' ].
	[ File
		write: handle
		from: aByteArray
		startingAt: 1
		count: amount ]
		on: PrimitiveFailed
		do: [ (FileWriteError fileName: self name)
				signal:
					(self closed
						ifTrue: [ 'File ' , self name , ' is closed' ]
						ifFalse: [ 'File ' , self name , ' write failed' ]) ].
	^ aByteArray! !

!AbstractBinaryFileStream methodsFor: 'initialization' stamp: 'nil'!
reset
	self position: 0! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
next
	"Answer the next byte from this file, or nil if at the end of the file."

	^ (self next: 1) ifEmpty: [ nil ] ifNotEmpty: [ :col | col first ]! !

!AbstractBinaryFileStream methodsFor: 'endianess' stamp: 'nil'!
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 byteAt: i)].
	self nextPutAll: bytes! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
upToAnyOf: delimiters

	^ ByteArray new: 1000 streamContents: [ :stream | | ch |
		[ (ch := self next) isNil or: [ delimiters includes: ch] ] 
			whileFalse: [ stream nextPut: ch ] ]! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
file: aFile 
	
	file := aFile! !

!AbstractBinaryFileStream methodsFor: 'endianess' stamp: 'nil'!
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! !

!AbstractBinaryFileStream methodsFor: 'initialization' stamp: 'nil'!
handle: aCollection file: aFile forWrite: aBoolean
	
	handle := aCollection.
	file := aFile.
	forWrite := aBoolean! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
size

	^ File sizeOf: handle! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
name

	^ file name! !

!AbstractBinaryFileStream methodsFor: 'positioning' stamp: 'nil'!
skip: n
	"Set the character position to n characters from the current position.
	Error if not enough characters left in the file.
	By default we read n characters and we avoid reading the output"
	self next: n! !

!AbstractBinaryFileStream methodsFor: 'flushing' stamp: 'nil'!
sync	
	"When writing, this syncs any written/flushed data still in the kernel
	file system buffers to disk. This should generally be used after #flush,
	but on Windows they do the same thing."

	File sync: handle! !

!AbstractBinaryFileStream methodsFor: 'reading' stamp: 'nil'!
readInto: readBuffer startingAt: startIndex count: count

	^ File read: handle into: readBuffer startingAt: startIndex count: count! !

!AbstractBinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
upTo: delim

	^ self upToAnyOf: (ByteArray with: delim)! !

!AbstractBinaryFileStream methodsFor: '*Fuel-Core' stamp: ''!
fuelNextWordsInto: aWordObject
	"This method is the same as nextWordsInto: but the restoreEndianness is only done if needed"
	self next: aWordObject basicSize into: aWordObject.
	^ aWordObject! !

!AbstractBinaryFileStream methodsFor: 'character writing' stamp: 'nil'!
crlf
	
	self nextPutAll: String crlf! !

!AbstractBinaryFileStream methodsFor: 'writing' stamp: 'nil'!
nextPutAll: aByteArray
	self next: aByteArray basicSize putAll: aByteArray! !

!AbstractBinaryFileStream methodsFor: 'positioning' stamp: 'nil'!
setToEnd
	
	self position: self size! !

!AbstractBinaryFileStream class methodsFor: 'instance creation' stamp: 'nil'!
handle: aCollection file: aFile forWrite: aTrue
	
	^ self basicNew
		handle: aCollection file: aFile forWrite: aTrue;
		yourself! !

!AbstractCache commentStamp: ''!
I am Cache.
I am an abstract class.

I am a limited cache holding onto key/value pairs.

My primary interface is #at:ifAbsentPut: which takes two arguments: a key and a block. Either the key is found (cache hit) and its value is returned, or the key is not found (cache miss). If the latter case, block should compute a new value to cache. Because block takes the key as optional argument, you can specify a factory style argument as well. With an explicit factory specified, you can also use #at: to access me.

For each addition to the cache, a weight is computed by #computeWeight (a selector or block) and added to #totalWeight. When #totalWeight is no longer below #maximumWeight, the least recently used item of the cache is evicted (removed) to make room. 

The default #computeWeight returns 1 for each value, effectively counting the number of entries. The default #maximumWeight is 16.

I count hits and misses and can return my #hitRatio.

Optionally, but not by default, I can be configured so that it is safe to access me from different threads/processes during my important operations. See #beThreadSafe.!
!AbstractCache methodsFor: 'initialize' stamp: ''!
maximumWeight: limit
	"Set my maximum allowed total weight of all cached values to limit.
	If the total weight is no longer below limit,
	the least recently used key/value pair will be removed.
	The default maximum weight limit is 16."
	
	weight maximum: limit! !

!AbstractCache methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	weight := CacheWeight new.
	statistics := CacheStatistics new! !

!AbstractCache methodsFor: 'printing' stamp: ''!
printElementsOn: stream
	stream nextPut: $#; print: self size.
	stream space; print: weight total; nextPut: $/; print: weight maximum.
	stream space; print: weight compute.
	factory ifNotNil: [ stream space; print: factory ].
	stream space; print: (self hitRatio * 100.0) rounded ; nextPut: $%! !

!AbstractCache methodsFor: 'initialize' stamp: ''!
computeWeight: valuable
	"Set the way to compute the weight of each cached value.
	This can be either a Symbol or one argument block.
	When the total weight is no longer below the maximum weight,
	the least recently used key/value pair will be removed.
	The default way to compute the weight returns 1 for each value,
	effectively counting the number of cached values."
	
	weight compute: valuable! !

!AbstractCache methodsFor: 'accessing' stamp: ''!
at: key put: value
	"Populate me by storing value for key. Return value. 
	This is neither a hit nor a miss. Statistics remain unchanged.
	Overwrite if already present without promotion. 
	This could result in the least recently used key/value pair 
	being removed when the specified maximum cache weight is exceeded."
	
	self subclassResponsibility! !

!AbstractCache methodsFor: 'initialize' stamp: ''!
beThreadSafe
	"Configure me so that I can be safely used from multiple threads/processes
	during important operations. Note that this slows down these operations."
	
	access := Monitor new! !

!AbstractCache methodsFor: 'accessing - statistics' stamp: ''!
hitRatio
	"Return the ratio of hits against total calls I received.
	This will be a number between 0 and 1.
	When I am empty, return 0."
	
	^ statistics hitRatio! !

!AbstractCache methodsFor: 'accessing - statistics' stamp: ''!
hits
	"Return how many hits, requests for keys present I received."

	^ statistics hits! !

!AbstractCache methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(.
	self printElementsOn: stream.
	stream nextPut: $)! !

!AbstractCache methodsFor: 'removing' stamp: ''!
removeAll
	"Remove all key/value pairs that I currently hold,
	effectiley resetting me, but not my statistics."

	self subclassResponsibility ! !

!AbstractCache methodsFor: 'removing' stamp: ''!
removeKey: key
	"If I currently cache key, remove the entry.
	Signal a KeyNotFound when I currently do not cache key.
	Return the removed value."
	
	^ self 
		removeKey: key 
		ifAbsent: [ KeyNotFound signalFor: key in: self ]! !

!AbstractCache methodsFor: 'accessing' stamp: ''!
at: key
	"If key is present in the cache, return the associated value.
	This is a hit and makes that key/value pair the most recently used.
	If key is absent, use the factory to compute a new value and cache it.
	This is a miss and will create a new key/value pair entry.
	Furthermore this could result in the least recently used key/value pair 
	being removed when the specified maximum cache weight is exceeded.
	If there is no factory and the key is not present, signal a KeyNotFound exception."
	
	^ self 
		at: key 
		ifAbsentPut: (factory ifNil: [ [ :k | KeyNotFound signalFor: k in: self ] ])! !

!AbstractCache methodsFor: 'accessing - statistics' stamp: ''!
size
	"Return the count of items currently present."
	
	self subclassResponsibility ! !

!AbstractCache methodsFor: 'enumerating' stamp: ''!
keysAndValuesDo: block
	"Execute block with each key and value present in me.
	This will be from least to most recently used."
	
	self subclassResponsibility ! !

!AbstractCache methodsFor: 'accessing' stamp: ''!
at: key ifAbsentPut: block
	"If key is present in the cache, return the associated value.
	This is a hit and makes that key/value pair the most recently used.
	If key is absent, use block to compute a new value and cache it.
	Block can optionally take one argument, the key. 
	This is a miss and will create a new key/value pair entry.
	Furthermore this could result in the least recently used key/value pair 
	being removed when the specified maximum cache weight is exceeded."

	self subclassResponsibility ! !

!AbstractCache methodsFor: 'accessing - statistics' stamp: ''!
totalWeight
	"Return the total weight of all cached values currently present."
	
	^ weight total! !

!AbstractCache methodsFor: 'accessing' stamp: ''!
addAll: keyedCollection
	"Populate me with all key/value pairs from keyedCollection.
	Does not affect statistics."
	
	keyedCollection keysAndValuesDo: [ :key :value | 
		self at: key put: value ]! !

!AbstractCache methodsFor: 'private' stamp: ''!
critical: block
	^ access
		ifNil: block
		ifNotNil: [ access critical: block ]! !

!AbstractCache methodsFor: 'accessing - statistics' stamp: ''!
misses
	"Return how many misses, requests for keys not present I received."
	
	^ statistics misses! !

!AbstractCache methodsFor: 'initialize' stamp: ''!
factory: block
	"Set the factory to compute values from keys to block.
	The factory will be evaluated for each key not present.
	Only my #at: message will use the factory."
	
	factory := block! !

!AbstractCache methodsFor: 'removing' stamp: ''!
removeKey: key ifAbsent: block
	"If I currently cache key, remove the entry.
	Execute block when key is currently absent.
	Return the removed value."
	
	self subclassResponsibility ! !

!AbstractCompletionEngine commentStamp: ''!
I am an abstract class defining the main interface of a completion engine.

- A completion engine is subscribed to a widget and receives events to provide completion.
- Then, when the completion engine decides to accept an element of the completion, the completion engine knows how to modify the underlying text widget.

I'm also used by the NECPreferences to detect the available engines in the system by checking my subclasses. It is important that I'm here, so there are no circular dependencies between the Morphic specific Completion engine and the abstract backend.!
!AbstractCompletionEngine methodsFor: 'testing' stamp: ''!
hasCompletionContext

	self subclassResponsibility! !

!AbstractCompletionEngine class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == AbstractCompletionEngine! !

!AbstractDebugger commentStamp: ''!
I am an abstract class to define the minimal API of the Debugger.

My subclasses can be registred like this:

	NoDebugger beCurrent!
!AbstractDebugger class methodsFor: 'query' stamp: ''!
beCurrent
	self isAbstract ifTrue: [ self error: 'Cannot register an abstract debugger' ]! !

!AbstractDebugger class methodsFor: 'opening api' stamp: ''!
openOn: aDebugSession withFullView: aBool andNotification: aString
	self subclassResponsibility! !

!AbstractDebugger class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = AbstractDebugger! !

!AbstractDelayTicker commentStamp: ''!
I represent the interface to the VM time-base primitives for tick generation and signalling.
This facilitates the DelaySchedulerXXX implementations to be independent of any particular time-based. 
I supply /nextTick/ to the VM and wait for /timingSemaphore/ to be signalled.

I read time-base specific ticks from the VM, and scale ticks around snapshot pauses.!
!AbstractDelayTicker methodsFor: 'api-system' stamp: ''!
saveResumptionTimes: delaysOrNils
	"Private!! Called only from the timing-priority process.
    Not performance critical."

	|oldBaseTick|
	
	"Record the resumption ticks of delays relative to a base tick of zero."
	oldBaseTick := self nowTick.
	delaysOrNils do: [ :delay |
		delay ifNotNil: [delay resumptionTickAdjustFrom: oldBaseTick to: 0 ]].! !

!AbstractDelayTicker methodsFor: 'api-system' stamp: ''!
tickAfterMilliseconds: milliseconds
	self subclassResponsibility! !

!AbstractDelayTicker methodsFor: 'api-system' stamp: ''!
millisecondsUntilTick: delay
	self subclassResponsibility! !

!AbstractDelayTicker methodsFor: 'api-system' stamp: ''!
nowTick
	self subclassResponsibility! !

!AbstractDelayTicker methodsFor: 'api-system' stamp: ''!
restoreResumptionTimes: delaysOrNils
	"Private!! Called only from the timing-priority process.
    Not performance critical."

	|newBaseTick|
		
	"Restore resumption ticks of delays relative to a base tick of zero."
	newBaseTick := self nowTick.
	delaysOrNils do: [ :delay |
		delay ifNotNil: [delay resumptionTickAdjustFrom: 0 to: newBaseTick ]].! !

!AbstractDelayTicker methodsFor: 'api-system' stamp: ''!
waitForUserSignalled: timingSemaphore orExpired: activeDelay
	self subclassResponsibility! !

!AbstractDelayTicker class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == AbstractDelayTicker! !

!AbstractDrTestsPresenter commentStamp: ''!
Abstract superclass for UI's of Dr Test!
!AbstractDrTestsPresenter methodsFor: 'api - locking' stamp: ''!
locked: aBoolean
	"Lock or unlock widgets returned by #subwidgetsToLock depending on aBoolean."
	
	self subwidgetsToLock
		do: [ :subwidget | subwidget enabled: aBoolean ]! !

!AbstractDrTestsPresenter methodsFor: 'accessing' stamp: ''!
pluginResult

	^ pluginResult! !

!AbstractDrTestsPresenter methodsFor: 'accessing' stamp: ''!
testsConfiguration

	^ testsConfiguration! !

!AbstractDrTestsPresenter methodsFor: 'accessing' stamp: ''!
pluginResult: anObject

	pluginResult := anObject! !

!AbstractDrTestsPresenter methodsFor: 'private - initialization' stamp: ''!
initializeButtons

	switchButton := self newButton.
	switchButton
		icon: (self iconNamed: #smallRemoteOpen)! !

!AbstractDrTestsPresenter methodsFor: 'api - locking' stamp: ''!
subwidgetsToLock

	^ { self startButton }! !

!AbstractDrTestsPresenter methodsFor: 'api - subwidgets configuration' stamp: ''!
switchButtonAction: aBlock

	self switchButton action: aBlock! !

!AbstractDrTestsPresenter methodsFor: 'accessing' stamp: ''!
switchButton

	^ switchButton! !

!AbstractDrTestsPresenter methodsFor: 'accessing' stamp: ''!
currentPlugin: anObject
	"If a plugin was set before, unsubscribe first."

	currentPlugin ifNotNil: [ currentPlugin unconfigureUI: self ].
	currentPlugin := anObject.
	
	currentPlugin announcer
		when: DTStatusUpdate
		send: #handlePluginStatusUpdate:
		to: self.

	currentPlugin announcer
		when: DTUpdateResults
		send: #handlePluginResultUpdate:
		to: self.! !

!AbstractDrTestsPresenter methodsFor: 'actions' stamp: ''!
switchUI

	self withWindowDo: [ :window | window close ]! !

!AbstractDrTestsPresenter methodsFor: 'announcement handling' stamp: ''!
handlePluginStatusUpdate: aDTStatusUpdate

	self updateStatus: aDTStatusUpdate message! !

!AbstractDrTestsPresenter methodsFor: 'updating' stamp: ''!
updateWithPluginResult: aPluginResult

	aPluginResult ifNotNil: [ self updateWithResults: aPluginResult ]! !

!AbstractDrTestsPresenter methodsFor: 'api - locking' stamp: ''!
unlock
	"Unlock the UI, once this method is called, the user is able to click on buttons or lists and to launch analysis."
	
	self locked: true! !

!AbstractDrTestsPresenter methodsFor: 'accessing' stamp: ''!
currentPlugin

	^ currentPlugin! !

!AbstractDrTestsPresenter methodsFor: 'updating' stamp: ''!
updateStatus: aString
	"Does nothing on purpose."! !

!AbstractDrTestsPresenter methodsFor: 'running' stamp: ''!
runPlugin

	self runPluginFor: self testsConfiguration! !

!AbstractDrTestsPresenter methodsFor: 'updating' stamp: ''!
updateWithResults: results

	self subclassResponsibility! !

!AbstractDrTestsPresenter methodsFor: 'accessing' stamp: ''!
testsConfiguration: anObject

	testsConfiguration := anObject! !

!AbstractDrTestsPresenter methodsFor: 'updating' stamp: ''!
updateUI

	self withWindowDo: [ :window | window title: self title ]! !

!AbstractDrTestsPresenter methodsFor: 'events' stamp: ''!
handlePluginResultUpdate: resultsAnnouncement 

	self updateWithPluginResult: resultsAnnouncement results! !

!AbstractDrTestsPresenter methodsFor: 'api - locking' stamp: ''!
lock
	"Lock the UI, once this method is called, the user is not able to click on buttons or lists anymore."
	
	self locked: false! !

!AbstractDrTestsPresenter methodsFor: 'running' stamp: ''!
runPluginFor: aTestsConfiguration

	[ self
			lock;
			updateStatus: 'Tests started.';
			updateWithResults: (self currentPlugin runForConfiguration: aTestsConfiguration);
			updateStatus: 'Tests finished.' ] ensure: [ self unlock ]! !

!AbstractDrTestsPresenter methodsFor: 'accessing' stamp: ''!
switchButton: anObject

	switchButton := anObject! !

!AbstractDrTestsPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self initializeButtons! !

!AbstractDrTestsPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter

	self switchButton action: [ self switchUI ]! !

!AbstractDrTestsPresenter class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self name = #AbstractDrTestsPresenter! !

!AbstractEnumerationVisitor commentStamp: ''!
I'm an abstract superclass for enumeration operations on directory entries. !
!AbstractEnumerationVisitor methodsFor: 'initialization' stamp: ''!
initializeWithBlock: aBlock
	self initialize.
	block := aBlock! !

!AbstractEnumerationVisitor methodsFor: 'visiting' stamp: ''!
preorder: aReference
	^ self visit: aReference with: (PreorderGuide for: self)! !

!AbstractEnumerationVisitor methodsFor: 'visiting' stamp: ''!
breadthFirst: aReference
	^ self visit: aReference with: (BreadthFirstGuide for: self)! !

!AbstractEnumerationVisitor methodsFor: 'visiting' stamp: ''!
visit: aReference with: aGuide
	out := (Array new: 10) writeStream.
	aGuide show: aReference.
	^ out contents! !

!AbstractEnumerationVisitor methodsFor: 'visiting' stamp: ''!
visitReference: anEntry
	self subclassResponsibility! !

!AbstractEnumerationVisitor methodsFor: 'visiting' stamp: ''!
postorder: aReference
	^ self visit: aReference with: (PostorderGuide for: self)! !

!AbstractEnumerationVisitorTest commentStamp: ''!
SUnit tests for AbstractEnumerationVisitor!
!AbstractEnumerationVisitorTest methodsFor: 'utilities' stamp: ''!
assertEntries: references are: expected
	| strings |
	self assert: references isArray.
	references do: [ :ea | self assert: ea class equals: MemoryDirectoryEntry ].
	strings := references collect: [ :ea | ea reference pathString ].
	self assert: strings equals: expected! !

!AbstractEnumerationVisitorTest methodsFor: 'accessing' stamp: ''!
root
	^ filesystem / 'alpha'! !

!AbstractEnumerationVisitorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self setUpGreek! !

!AbstractEnumerationVisitorTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #AbstractEnumerationVisitorTest! !

!AbstractEnvironmentTestCase methodsFor: 'accessing' stamp: ''!
environmentOfTest
	^ testingEnvironment! !

!AbstractEnvironmentTestCase methodsFor: 'accessing' stamp: ''!
testingEnvironment: anObject
	testingEnvironment := anObject! !

!AbstractEnvironmentTestCase methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	testingEnvironment := Smalltalk globals.! !

!AbstractEnvironmentTestCase class methodsFor: 'testing' stamp: ''!
isAbstract

	^self = AbstractEnvironmentTestCase ! !

!AbstractFileReference commentStamp: ''!
I am an abstract superclass for FileLocator and FileReference. By implementing most of the methods on myself most code duplucation between the locator and the reference can be avoided!
!AbstractFileReference methodsFor: 'streams' stamp: ''!
readStreamEncoded: anEncoding

	^ ZnCharacterReadStream
		on: self binaryReadStream
		encoding: anEncoding! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
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: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionFuel
	<inspectorPresentationOrder: 40 title: 'Fuel Header'>
	
	^ SpTablePresenter new
		items: (FLMaterializer materializeHeaderFromFileNamed: self fullName) stFuelMetaData;
		addColumn: (SpStringTableColumn title: 'Property' evaluated: [ :assoc | assoc key ]);
		addColumn: (SpStringTableColumn title: 'Value' evaluated: [ :assoc | assoc value ]);	
		yourself! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isReadable
	^ self resolve isReadable! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
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: 'accessing' stamp: ''!
permissions
	"Return the FileSystemPermission for this node"
	^ self resolve permissions! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
fullPath
	"Returns the absolute path, better use absolutePath"
	
	^ self subclassResponsibility! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
humanReadableSize
	^ self size humanReadableSIByteSize! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionContents
	<inspectorPresentationOrder: 0 title: 'Contents'> 
	| maxBytes buffer atEnd stringContents displayStream displayString |
	
	maxBytes := 10000.
	
	self binaryReadStreamDo: [ :stream | 
		buffer := stream next: maxBytes.
		atEnd := stream atEnd ].
				
	displayString := [ 
			stringContents := ZnCharacterEncoder utf8 decodeBytes: buffer.
			atEnd 
				ifTrue: [ stringContents ]
				ifFalse: [ stringContents, '  ... truncated ...' ] ]
		on: Error 
		do: [ 
			displayStream := (String new: maxBytes * 5) writeStream.
			buffer hexDumpOn: displayStream max: maxBytes.
			displayString := displayStream contents ].
	
	^ SpCodePresenter new
		withoutSyntaxHighlight;
		text: displayString;
		whenSubmitDo: [ :text | 
			self writeStreamDo: [ :s | s nextPutAll: text string ] ];
		yourself! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
isImagePng

	^ self isFile 
		and: [ self mimeTypes notNil 
		and: [ self mimeTypes first matches: ZnMimeType imagePng ] ]! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
ensureCreateDirectory
	"Verifies that the directory does not exist and only creates if necessary. Do not remove files contained if they exist. Creates the parents if needed"
	self resolve ensureCreateDirectory! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
copyAllTo: aResolvable
	"Performs a deep copy of the receiver, to a location specified by the argument. If the receiver is a file, the file will be copied; if a directory, the directory and its contents will be copied recursively. The argument must be a reference that doesn't exist; it will be created by the copy."
	
	CopyVisitor copy: self resolve asAbsolute to: aResolvable resolve! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
targetPath
	^ self resolve targetPath! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
renameTo: newBasename
	self subclassResponsibility! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
readStreamDo: doBlock ifAbsent: absentBlock
	^ self isFile 
		ifTrue: [ self readStreamDo: doBlock ]
		ifFalse: absentBlock! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
binaryReadStreamDo: aBlock
	| stream |
	stream := self binaryReadStream.
	^ [ aBlock value: stream ] 
		ensure: [ stream close ]! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
contents
	self readStreamDo: [ :stream |
		^ stream contents ]! !

!AbstractFileReference methodsFor: '*Zinc-Resource-Meta-Core' stamp: 'nil'!
mimeTypes
	^ self resolve mimeTypes! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isRelative 
	self subclassResponsibility! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
uid
	^ self resolve uid! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
isBlock
	^ self resolve isBlock! !

!AbstractFileReference methodsFor: 'private' stamp: ''!
childGeneratorBlock: doBlock matching: patterns
	"
	FileSystem workingDirectory filesMatching: '*'
	FileSystem workingDirectory filesMatching: '*.image;*.changes'
	"
	
	| files reference|
	files := Set new.
	reference := self resolve.
	
	(patterns findTokens: ';', String crlf) do: [ :pattern | 
		doBlock value: reference value: [ :basename|
			(pattern match: basename)
				ifTrue: [ files add: (self / basename) ]]].
	
	^files asOrderedCollection! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isDirectory
	^ self resolve isDirectory! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
childNames
	^ self children collect: [:each | each basename]! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
ifAbsent: aBlock
	"Return self, or evaluate the block if I do not exist"

	^ self exists ifTrue: [ self ] ifFalse: [ aBlock cull: self ]! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
delete
	"Delete the receiver, does raise an error if it is not present."
	
	^ self resolve delete! !

!AbstractFileReference methodsFor: 'ToDeprecate' stamp: ''!
fileIn

	self readStreamDo: [ :stream | 
		CodeImporter evaluateFileStream: stream ]! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
fullNameWithIndicator
	"Returns the basename with the indicator appended, i.e. /foo/gloops.taz basenameWithIndicator is '/foo/gloops.taz', whereras /foo basenameWithIndicator is '/foo/'" 
	^ self fullName, self indicator! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
pathString
	^ self resolve pathString! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
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: 'enumerating' stamp: ''!
allDirectories
	"Return all the directories recursively nested in the receiver."
	^ (SelectVisitor breadthFirst: self resolve select: [:entry | entry isDirectory ])
		collect: [ :each| each reference ]! !

!AbstractFileReference methodsFor: 'navigating' stamp: ''!
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: 'testing' stamp: ''!
isSocket
	^ self resolve isSocket! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
gid
	^ self resolve gid! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
uri
	"Convert my path into a file:// type url. For odd characters use %20 notation."

	^ self asUrl! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
readStreamDo: aBlock
	| stream |
	stream := self readStream.
	^ [ aBlock value: stream ] 
		ensure: [ stream close ]! !

!AbstractFileReference methodsFor: 'navigating' stamp: ''!
resolve
	^ self subclassResponsibility! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
parentUpTo: aParentDirName
	^ self withPath: (self path parentUpTo: aParentDirName)! !

!AbstractFileReference methodsFor: 'converting' stamp: ''!
asAbsolute 
	self subclassResponsibility! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
size
	"Return the size of the file in bytes."
	
	^ self resolve size! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isExecutable
	^ self resolve isExecutable! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
copyTo: aReference
	^ self resolve copyTo: aReference resolve! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
moveTo: aReference
	"Move the receiver in the location passed as argument.
	
	(FileSystem disk workingDirectory / 'paf' ) ensureCreateFile.
	(FileSystem disk workingDirectory / 'fooFolder') ensureCreateDirectory. 
	(FileSystem disk workingDirectory / 'paf' ) moveTo: (FileSystem disk workingDirectory / 'fooFolder' / 'paf')
	
	Note that the receiver is modified to point to the new location."

	^ self resolve moveTo: aReference! !

!AbstractFileReference methodsFor: 'utilities' stamp: ''!
nextVersion
	^ self resolve nextVersion! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
writeStreamEncoded: anEncoding

	^ ZnCharacterWriteStream
		on: self binaryWriteStream
		encoding: anEncoding! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionCompressedItems
	<inspectorPresentationOrder: 0 title: 'Compressed Items'>
	| items children root |

	root := (FileSystem zip: self) open workingDirectory.
	children := root directories, root files.
	items := self isRoot 
		ifTrue: [ children ]
		ifFalse: [ 
			children asOrderedCollection 
				addFirst: self parent;
				yourself ].

	^ SpTablePresenter new
		items: items;
		addColumn: (SpCompositeTableColumn new
			title: 'Name';
			addColumn: (SpImageTableColumn evaluated: [ :each | 
				self iconNamed: (each isDirectory 
					ifTrue: [ #glamorousFolder ] 
					ifFalse: [ #glamorousBrowse ]) ]);
			addColumn: (SpStringTableColumn evaluated: [ :each | 
					self parent = each 
						ifTrue: [ '..' ] 
						ifFalse: [ each basename ] ]));
		addColumn: (SpStringTableColumn 
			title: 'Size' 
			evaluated: [ :each | each humanReadableSize ]);
		addColumn: (SpStringTableColumn 
			title: 'Creation' 
			evaluated: [ :each | 
				String streamContents: [ :stream | 
					each creationTime printYMDOn: stream.
					stream nextPut: Character space.
					each creationTime printHMSOn: stream ] ])! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionFuelContext: aContext 
	
	aContext active: self isFuel! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionPng
	<inspectorPresentationOrder: 0 title: 'Picture'>
	
	^ SpImagePresenter new
		image: (self binaryReadStreamDo: [ :stream | PNGReadWriter formFromStream: stream ]);
		yourself! !

!AbstractFileReference methodsFor: 'navigating' stamp: ''!
makeRelative: anObject
	^ anObject relativeToReference: self resolve! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
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: 'navigating' stamp: ''!
relativeToPath: landmarkPath 
	
	^ self fullPath relativeTo: landmarkPath! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
deleteAll
	"Delete this directory and all children of it, raise an error if the file does not exist.
	Don't follow symbolic links (so files outside the receiver's tree will not be deleted)."
	DeleteVisitor delete: self resolve! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
writeStreamDo: doBlock ifPresent: presentBlock
	^ self isFile
		ifTrue: presentBlock
		ifFalse: [ self writeStreamDo: doBlock ]! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
binaryWriteStreamDo: doBlock ifPresent: presentBlock
	^ self isFile
		ifTrue: presentBlock
		ifFalse: [ self binaryWriteStreamDo: doBlock ]! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionGifContext: aContext 
	
	aContext active: self isImageGif! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
modificationTime
	^ self resolve modificationTime! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
deleteIfAbsent: aBlock
	"Delete the receiver, when it does not exist evaluate the block"
	self resolve deleteIfAbsent: aBlock! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionJpeg
	<inspectorPresentationOrder: 0 title: 'Picture'>
	
	^ SpImagePresenter new
		image: (self binaryReadStreamDo: [ :stream | ImageReadWriter formFromStream: stream ]);
		yourself! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionStScriptContext: aContext 
	
	aContext active: self isScript! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
hasDirectories
	^self resolve hasDirectories! !

!AbstractFileReference methodsFor: 'navigating' stamp: ''!
resolve: anObject
	^ anObject asResolvedBy: self! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
isCompressedFile

	^ #('zip' 'jar' 'ear' 'war' 'mcz') includes: self extension! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
isImageGif

	^ self isFile 
		and: [ self mimeTypes notNil 
		and: [ self mimeTypes first matches: ZnMimeType imageGif ] ]! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
creationTime
	^ self resolve creationTime! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
deviceId
	^ self resolve deviceId! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
createFile
	"Create if necessary a file for the receiver. If the parent does not exist return an exception"
	self parent exists ifFalse:[DirectoryDoesNotExist signalWith: self parent path].
	self writeStream close.! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
openWritable: aBoolean
	^ self resolve openWritable: aBoolean! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
canonicalize
	"Answer the receiver with references to the current folder (.) and parent folder (..) removed"

	^ self withPath: self path canonicalize! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionGif
	<inspectorPresentationOrder: 0 title: 'Picture'>
	
	^ SpImagePresenter new
		image: (self binaryReadStreamDo: [ :stream | GIFReadWriter formFromStream: stream ]);
		yourself! !

!AbstractFileReference methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
isZipFile

	^ self isFile and: [ #('zip' 'jar' 'ear' 'war') includes: self extension ]! !

!AbstractFileReference methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForDirectoriesFor: aStep
	<stSpotterOrder: 10>
	
	^ self isDirectory ifTrue: [
		aStep listProcessor
			allCandidates: [ self directories ];
			title: 'Directories';
			candidatesLimit: Float infinity;
			itemName: #basename;
			itemIcon: [ self iconNamed: #glamorousFolder ];
			filter: StFilterSubstring ]! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
parent
	^ self withPath: self resolve path parent! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionItemsContext: aContext 
	
	aContext active: self isDirectory! !

!AbstractFileReference methodsFor: 'navigating' stamp: ''!
withPath: newPath
	^ self path == newPath
		ifTrue: [ self ]
		ifFalse: [ self copyWithPath: newPath ]! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
allChildrenMatching: aPattern
    "Return all the files and folders recursively nested in the receiver and matching the pattern, aPattern"
    
    ^ self allChildren select: [ :each |  aPattern match: each basename ]! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
binaryWriteStream
	"Answer a binary write stream on the receiver"

	^ self subclassResponsibility! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
writeStreamDo: aBlock
	| stream |
	stream := self writeStream.
	^ [ aBlock value: stream ]
		ensure: [ stream close ]! !

!AbstractFileReference methodsFor: 'copying' stamp: ''!
copyWithPath: newPath
	self subclassResponsibility! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
inode
	^ self resolve inode! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
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: 'navigating' stamp: ''!
relativeToReference: landmarkReference
	"Return the path of the receiver relative to landmarkReference."
	
	^ self fullPath relativeTo: landmarkReference path! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionContentsContext: aContext 
	
	aContext active: self isFile! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
binaryReadStream
	^ self subclassResponsibility! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
extension
	
	^ self fullPath extension.! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionPngContext: aContext 
	
	aContext active: self isImagePng! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
isImageJpeg

	^ self isFile 
		and: [ self mimeTypes notNil 
		and: [ self mimeTypes first matches: ZnMimeType imageJpeg ] ]! !

!AbstractFileReference methodsFor: '*Zinc-Resource-Meta-FileSystem' stamp: ''!
asUrl
	"Convert the receiver in a file:// ZnUrl.
	Only an absolute path can be represented as a file:// URL"
	
	^ self asZnUrl! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionJpegContext: aContext
	
	aContext active: self isImageJpeg! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isFIFO
	^ self resolve isFIFO! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
ensureDeleteAll
	"Delete this directory and all children of it, and does not raise an error if the file does not exist."

	self ifAbsent: [ ^ self ].
	self deleteAll! !

!AbstractFileReference methodsFor: 'navigating' stamp: ''!
withExtension: aString
	^ self withPath: (self path withExtension: aString)! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
writeStreamEncoded: anEncoding do: aBlock
	| stream |
	stream := self writeStreamEncoded: anEncoding.
	^ [ aBlock value: stream ]
		ensure: [ stream close ]! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
base
	"Returns the base of the basename, i.e. /foo/gloops.taz base is 'gloops'"
	^ self fullPath base! !

!AbstractFileReference methodsFor: 'converting' stamp: ''!
asPath
	"Answer the receiver's path"

	self subclassResponsibility! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
deleteAllChildren
	"Delete all children of the receiver, raise an error if the receiver does not exist.
	Don't follow symbolic links (so files outside the receiver's tree will not be deleted)."
	
	self children do: [:aReference | aReference deleteAll ]! !

!AbstractFileReference methodsFor: 'copying' stamp: ''!
, extension
	^ self resolve, extension! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isChildOf: anObject
	^ self parent = anObject! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
item
	^ self! !

!AbstractFileReference methodsFor: 'navigating' stamp: ''!
resolvePath: aPath
	^ self withPath: (self path resolvePath: aPath)! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
binaryReadStreamDo: doBlock ifAbsent: absentBlock
	^ self isFile 
		ifTrue: [ self binaryReadStreamDo: doBlock ]
		ifFalse: absentBlock! !

!AbstractFileReference methodsFor: 'comparing' stamp: ''!
<= other
	^ self path <= other path! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
binaryReadStreamIfAbsent: absentBlock
	^ self isFile
		ifTrue: [ self binaryReadStream ]
		ifFalse: absentBlock! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
ifFile: fBlock ifDirectory: dBlock ifAbsent: aBlock
	^ self isFile
		ifTrue: fBlock
		ifFalse: [
			self isDirectory
				ifTrue: dBlock
				ifFalse: aBlock ]! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
readStreamIfAbsent: absentBlock
	^ self isFile
		ifTrue: [ self readStream ]
		ifFalse: absentBlock! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
ensureDelete
	"Delete the file and does not raise exception if it does not exist contrary to delete.
	However if it is a directory and it has children an error is signaled. If it is required to 
	delete even with children, use #ensureDeleteAll."
	
	self deleteIfAbsent: [].! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
isCharacter
	^ self resolve isCharacter! !

!AbstractFileReference methodsFor: 'comparing' stamp: ''!
hash
	"Hash is reimplemented because #= is reimplemented"
	^ self path  hash! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
hasFiles
	^self resolve hasFiles! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionStScript
	<inspectorPresentationOrder: 0 title: 'Script'>
	
	^ SpCodePresenter new 
		text: (self readStreamDo: #contents);
		whenSubmitDo: [ :text | 
			self writeStreamDo: [ :s | s nextPutAll: text string ] ];
		yourself! !

!AbstractFileReference methodsFor: 'navigating' stamp: ''!
/ aString
	"aString is either a file or path.  If aString is relative, it is appended to the receiver, if it is absolute, an instance of the receiver with the path is answered"

	^ self withPath: (self path resolvePath: (self fileSystem pathFromString: aString))! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isRoot
	^ self resolve isRoot! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
basename
	"Returns the basename, i.e. /foo/gloops.taz basename is 'gloops.taz'"
	^ self fullPath basename! !

!AbstractFileReference methodsFor: 'resolving' stamp: ''!
asResolvedBy: anObject
	^ anObject resolveReference: self! !

!AbstractFileReference methodsFor: 'navigating' stamp: ''!
resolveString: aString 
	self subclassResponsibility! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
allDirectoriesMatching: aPattern
    "Return all the directories recursively nested in the receiver."
    ^ (SelectVisitor 
			breadthFirst: self resolve 
			select: [:entry | entry isDirectory and: [ aPattern match: entry basename ] ])
        collect: [ :each | each reference ]! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
allChildren
	"Return all the files and folders recursively nested in the receiver"
	
	^ CollectVisitor breadthFirst: self resolve collect: [:entry | entry reference]! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
entry
	^ self resolve entry! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
path
	^ path! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
isScript
	
	^ self isFile and: [ self extension = 'st' ]! !

!AbstractFileReference methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForZipDirectoriesFor: aStep
	<stSpotterOrder: 10>
	| zipFileSystem |
	self isZipFile ifFalse: [ ^ self ].
	aStep listProcessor
			allCandidates: [ 
				zipFileSystem := (FileSystem zip: self) open.
				zipFileSystem workingDirectory directories ];
			title: 'Directories';
			candidatesLimit: Float infinity;
			itemName: #basename;
			itemIcon: [ self iconNamed: #glamorousFolder ];
			filter: StFilterSubstring! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isFile
	^ self resolve isFile! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
exists
	"Return true if the file reference exist (e.g., if there is a file on the hard disk pointed by the file reference)
	
	E.g., (if you are on Unix or OSX)
	'/tmp/' asFileReference exists => true
	'/tmp/zorkbar' asFileReference exists => false
	"
	^ self resolve exists! !

!AbstractFileReference methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForZipFilesFor: aStep
	<stSpotterOrder: 10>
	| zipFileSystem |
	
	self isZipFile ifFalse: [ ^ self ].
	aStep listProcessor
			allCandidates: [ 
				zipFileSystem := (FileSystem zip: self) open.
				zipFileSystem workingDirectory files ];
			title: 'Files';
			candidatesLimit: Float infinity;
			itemName: #basename;
			itemIcon: [ self iconNamed: #glamorousBrowse ];
			filter: StFilterSubstring
	! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
changeTime
	^ self resolve changeTime! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
accessTime
	^ self resolve accessTime! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
fileSystem
	^ self resolve fileSystem! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
writeStream
	self subclassResponsibility! !

!AbstractFileReference methodsFor: '*System-Settings-Core' stamp: ''!
acceptSettings: aVisitor
	^ aVisitor visitAbstractFileReference: self! !

!AbstractFileReference methodsFor: '*Native-Browser' stamp: ''!
openInOSFileBrowser
	^ NativeBrowserOpenVisitor openOn: self! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isAbsolute 
	self subclassResponsibility! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
directoryNames
	^ self directories collect: [:each | each basename]! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
allEntries
	^ CollectVisitor breadthFirst: self resolve! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionItems
	<inspectorPresentationOrder: 0 title: 'Items'>
	| items |
	
	items := 	self directories, self files.
	self isRoot ifFalse: [ 
		items := items copyWithFirst: self parent ]. 

	^ SpTablePresenter new 
		beResizable;
		items: items;
		addColumn: (SpCompositeTableColumn new 
			title: 'Name';
			width: 300;
			addColumn: (SpImageTableColumn evaluated: [ :each |
				each isDirectory 
					ifTrue: [ self iconNamed: #glamorousFolder ] 
					ifFalse: [ self iconNamed: #glamorousBrowse ] ]) 
				beNotExpandable;
			addColumn: (SpStringTableColumn evaluated: [ :each | 
				(self isChildOf: each) 
					ifTrue: [ '..' ] 
					ifFalse: [ each basename ] ]);
			yourself);
		addColumn: (SpStringTableColumn new 
			title: 'Size';
			width: 100;
			evaluated: [ :each | 
				[ each humanReadableSize ]
					on: Error 
					do: [ 'N/A' translated ] ]);
		addColumn: (SpStringTableColumn 
			title: 'Creation'
			evaluated: [ :each | 
				[ String streamContents: [ :s | 
					each creationTime printYMDOn: s.
					s nextPut: Character space.
					each creationTime printHMSOn: s ] ]
				on: Error 
				do: [ 'N/A' translated  ] ]);
		yourself! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
ifExists: aBlock
	"Evaluate the block, unless I do not exist. If the receiver exists, pass it as argument to the block."

	^ self exists ifTrue: [ aBlock cull: self ] ifFalse: [ self ]! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
ifExists: aBlock ifAbsent: anotherBlock
	"If the receiver exists, pass it as argument to aBlock. Else execute anotherBlock "

	^ self exists ifTrue: [ aBlock cull: self ] ifFalse: [ anotherBlock cull: self ]! !

!AbstractFileReference methodsFor: 'comparing' stamp: ''!
isContainedBy: anObject
	"DoubleDispatch helper for #contains:"
	^ anObject containsReference: self resolve! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
writeStreamIfPresent: presentBlock
	^ self isFile 
		ifTrue: presentBlock
		ifFalse: [ self writeStream ]! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
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: ''!
glob: aBlock
	^ SelectVisitor breadthFirst: self resolve select: aBlock! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
numberOfHardLinks
	^ self resolve numberOfHardLinks! !

!AbstractFileReference methodsFor: 'comparing' stamp: ''!
contains: anObject
	"Return true if anObject is in a subfolder of me"
	^ anObject isContainedBy: self resolve! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
asPathWith: anObject
	^ self resolve asPathWith: anObject! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
pathSegments
	^ self fullPath segments! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
readStreamEncoded: anEncoding do: aBlock
	| stream |
	stream := self readStreamEncoded: anEncoding.
	^ [ aBlock value: stream ] 
		ensure: [ stream close ]! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
basenameWithoutExtension: anExtension
	"Returns the basename without specified extension (if any)
	('/foo/gloops.taz' asFileReference basenameWithoutExtension: 'taz') = 'gloops'
	"
	^ self fullPath basenameWithoutExtension: anExtension! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
ensureCreateFile
	"Create if necessary a file for the receiver. If the parent does not exist creates it"
	self parent ensureCreateDirectory.
	self writeStream close.! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
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: ''!
fileNames
	^ self files collect: [:each | each basename]! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
hasChildren
	^self resolve hasChildren! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
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: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionCompressedItemsContext: aContext 
	
	aContext active: self isCompressedFile! !

!AbstractFileReference methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
isFuel

	^ self isFile and: [ self extension = 'fuel' ]! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
createDirectory
	"Verifies that the directory does not exist and only creates if necessary. Do not remove files contained if they exist.If the parents does not exist return an exception"
	self parent exists ifFalse:[DirectoryDoesNotExist signalWith: self parent path].
	^ self resolve ensureCreateDirectory! !

!AbstractFileReference methodsFor: 'delegated' stamp: ''!
fullName

	^ self resolve fullName! !

!AbstractFileReference methodsFor: 'streams' stamp: ''!
readStream
	self subclassResponsibility! !

!AbstractFileReference methodsFor: 'navigating' stamp: ''!
resolveReference: aReference
	^ aReference isAbsolute
		ifTrue: [ aReference ]
		ifFalse: [ self withPath: aReference path ]! !

!AbstractFileReference methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForFilesFor: aStep
	<stSpotterOrder: 20>
	^ self isDirectory ifTrue: [
		aStep listProcessor
			allCandidates: [ self files ];
			title: 'Files';
			candidatesLimit: Float infinity;
			itemName: #basename;
			itemIcon: [ self iconNamed: #glamorousBrowse ];
			filter: StFilterSubstring ]! !

!AbstractFileReference methodsFor: 'copying' stamp: ''!
withoutExtension
  "Returns the new reference based on receiver with fullname without its extension"

  ^  (self parent / self basenameWithoutExtension)! !

!AbstractFileReference methodsFor: 'converting' stamp: ''!
asFileReference 
	self subclassResponsibility! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isSymlink
	^ self resolve isSymlink! !

!AbstractFileReference methodsFor: 'accessing' stamp: ''!
absolutePath
	"Returns the absolute path"
	
	^ self subclassResponsibility! !

!AbstractFileReference methodsFor: 'comparing' stamp: ''!
containsPath: aPath
	^ self fullPath containsPath: aPath! !

!AbstractFileReference methodsFor: 'printing' stamp: ''!
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: 'streams' stamp: ''!
streamWritable: writable do: aBlock
	^ writable 
		ifTrue: [ self writeStreamDo: aBlock ]
		ifFalse: [ self readStreamDo: aBlock ]! !

!AbstractFileReference methodsFor: '*Zinc-Resource-Meta-FileSystem' stamp: ''!
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: 'streams' stamp: ''!
binaryWriteStreamDo: aBlock
	"Pass a binary write stream on the receiver to the supplied block, and ensure that the stream is closed after evaluation."

	| stream |

	stream := self binaryWriteStream.
	^ [ aBlock value: stream ] 
		ensure: [ stream close ]! !

!AbstractFileReference methodsFor: 'operations' stamp: ''!
ensureDeleteAllChildren
	"delete all children of the receiver and does not raise an error if the receiver does not exist"

	self ifAbsent: [ ^ self ].
	self deleteAllChildren! !

!AbstractFileReference methodsFor: 'testing' stamp: ''!
isWritable
	^ self resolve isWritable! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
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: 'accessing' stamp: ''!
basenameWithoutExtension
	"Returns the basename, i.e. /foo/gloops.taz basenameWithoutExtension is 'gloops'"
	^ self fullPath basenameWithoutExtension! !

!AbstractFileReference methodsFor: 'enumerating' stamp: ''!
entries
	^ self resolve entries! !

!AbstractFont commentStamp: ''!
The abstract class AbstractFont defines the generic interface that all fonts need to implement.!
!AbstractFont methodsFor: '*FreeType-addition' stamp: ''!
widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray
	"Set the first element of aTwoElementArray to the width of leftCharacter and 
	the second element to the width of left character when kerned with
	rightCharacterOrNil. Answer aTwoElementArray"
	| w k |
	w := self widthOf: leftCharacter.
	rightCharacterOrNil 
		ifNil: [
			aTwoElementArray 
				at: 1 put: w; 
				at: 2 put: w]
		ifNotNil: [
			k := self kerningLeft: leftCharacter right: rightCharacterOrNil.
			aTwoElementArray 
				at: 1 put: w; 
				at: 2 put: w+k].
	^ aTwoElementArray! !

!AbstractFont methodsFor: 'testing' stamp: ''!
isTTCFont

	^ false! !

!AbstractFont methodsFor: 'displaying' stamp: ''!
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: '*FreeType-addition' stamp: ''!
displayStrikeoutOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint
	"display the strikeout if appropriate for the receiver"! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
ascent

	self subclassResponsibility.! !

!AbstractFont methodsFor: 'displaying' stamp: ''!
displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) display context."
	^self subclassResponsibility! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
textStyleName
	"Answer the name to be used as a key in the TextConstants dictionary."
	^self familyName! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
descent

	self subclassResponsibility! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
ascentOf: aCharacter

	^ self ascent.! !

!AbstractFont methodsFor: 'metrics' stamp: ''!
underlineThickness
	^ 0! !

!AbstractFont methodsFor: '*Athens-Text' stamp: ''!
getPreciseHeight

	^ self height! !

!AbstractFont methodsFor: 'testing' stamp: ''!
isFontSet

	^ false! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
pixelSize
	"Make sure that we don't return a Fraction"
	^ TextStyle pointsToPixels: self pointSize! !

!AbstractFont methodsFor: '*FreeType-addition' stamp: ''!
linearWidthOf: aCharacter
	"This is the scaled, unrounded advance width."
	^self widthOf: aCharacter! !

!AbstractFont methodsFor: '*Athens-Text' stamp: ''!
getPreciseDescent

	^ self descent! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
basicDescentOf: aCharacter

	^ self descent.! !

!AbstractFont methodsFor: '*FreeType-addition' stamp: ''!
hasGlyphsForAll: asciiString
	"Answer true if the receiver has glyphs for all the characters
	in asciiString, false otherwise.
	The default behaviour is to answer true, but subclasses may reimplement"
	
	^true! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
height
	"Answer the height of the receiver, total of maximum extents of 
	characters above and below the baseline."

	^self subclassResponsibility! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
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: ''!
xTable
	"Return the xTable for the font. The xTable defines the left x-value for each individual glyph in the receiver. If such a table is not provided, the character scanner will ask the font directly for the appropriate width of each individual character."
	
	^nil! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
basicAscentOf: aCharacter

	^ self ascent.! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
isRegular

	^ false! !

!AbstractFont methodsFor: 'measuring' stamp: ''!
widthOfString: aString
	"
		TextStyle default defaultFont widthOfString: 'zort' 21
	"
	aString ifNil: [^0].
	^self widthOfString: aString from: 1 to: aString size.! !

!AbstractFont methodsFor: '*FreeType-addition' stamp: ''!
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: 'accessing' stamp: ''!
derivativeFonts
	^#()! !

!AbstractFont methodsFor: '*FreeType-addition' stamp: ''!
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: 'accessing' stamp: ''!
textStyle
	^ TextStyle actualTextStyles detect:
		[:aStyle | aStyle fontArray includes: self] ifNone: [ TextStyle fontArray: { self } ]! !

!AbstractFont methodsFor: 'displaying' stamp: ''!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
	"Install the receiver on the given DisplayContext (either BitBlt or Canvas) for further drawing operations."

	^ self subclassResponsibility! !

!AbstractFont methodsFor: '*FreeType-addition' stamp: ''!
isSymbolFont
	"Answer true if the receiver is a Symbol font, false otherwise.
	The default is to answer false, subclasses can reimplement"
	
	^false! !

!AbstractFont methodsFor: 'measuring' stamp: ''!
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: '*FreeType-addition' stamp: ''!
emphasisString
	"Answer a translated string that represents the receiver's emphasis."
	
	^self emphasisStringFor: self emphasis! !

!AbstractFont methodsFor: 'glyph lookup' stamp: ''!
characterRenderingOptimizedFormAt: aCharacter
	"This method returns a version of the character form which is optimized for rendering
	through an accelerated alpha blending equation in the style of the OpenGL glBlendFuncSeparate."

	^ (self characterFormAt: aCharacter) 
			ifNotNil: [:form | form invertedAndAlphaMultiplied]! !

!AbstractFont methodsFor: '*Text-Scanning' stamp: ''!
scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX
	"scan a multibyte character string"
	^aCharacterScanner scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString rightX: rightX ! !

!AbstractFont methodsFor: 'measuring' stamp: ''!
widthOfStringOrText: aStringOrText

    aStringOrText ifNil: [ ^0 ].
    ^aStringOrText isText
        ifTrue:[ self approxWidthOfText: aStringOrText ]
        ifFalse:[ self widthOfString: aStringOrText ]! !

!AbstractFont methodsFor: 'testing' stamp: ''!
hasSubPixelAntiAliasing

	^ false! !

!AbstractFont methodsFor: 'caching' stamp: ''!
releaseCachedState! !

!AbstractFont methodsFor: '*FreeType-addition' stamp: ''!
displayUnderlineOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint
	"display the underline if appropriate for the receiver"! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
lineGrid
	"Answer the relative space between lines"

	^self subclassResponsibility! !

!AbstractFont methodsFor: 'metrics' stamp: ''!
underlineTop
	^ 0! !

!AbstractFont methodsFor: '*Text-Scanning' stamp: ''!
scanByteCharactersFrom: startIndex to: stopIndex in: aByteString with: aCharacterScanner rightX: rightX
	"scan a single byte character string"
	^aCharacterScanner scanByteCharactersFrom: startIndex to: stopIndex in: aByteString rightX: rightX! !

!AbstractFont methodsFor: 'metrics' stamp: ''!
strikeoutThickness
	^ 0! !

!AbstractFont methodsFor: 'development support' stamp: ''!
validate
	"Concrete classes should override this to provide validation"! !

!AbstractFont methodsFor: 'metrics' stamp: ''!
strikeoutTop
	^ 0! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
descentOf: aCharacter

	^ self descent! !

!AbstractFont methodsFor: '*FreeType-addition' stamp: ''!
emphasisStringFor: emphasisCode
	"Answer a translated string that represents the attributes given in emphasisCode."
	
	^self class emphasisStringFor: emphasisCode! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
baseKern
	^0! !

!AbstractFont methodsFor: 'notifications' stamp: ''!
pixelsPerInchChanged
	"The definition of TextStyle class>>pixelsPerInch has changed. Do whatever is necessary."! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
familyName
	"Answer the name to be used as a key in the TextConstants dictionary."
	
	^self subclassResponsibility! !

!AbstractFont methodsFor: 'glyph lookup' stamp: ''!
characterFormAt: aCharacter
	^ nil! !

!AbstractFont methodsFor: 'measuring' stamp: ''!
approxWidthOfText: aText 
	"Return the width of aText -- quickly, and a little bit dirty. Used by lists morphs containing Text objects to get a quick, fairly accurate measure of the width of a list item."
	| w |
	(aText isNil or: [ aText size = 0 ]) ifTrue: [ ^ 0 ].
	w := self widthOfString: aText asString.

	"If the text has no emphasis, just return the string size.  If it is empasized, 
    just approximate the width by adding about 20% to the width"
	((aText runLengthFor: 1) = aText size and: [ (aText emphasisAt: 1) = 0 ]) 
		ifTrue: [ ^ w ]
		ifFalse: [ ^ w * 6 // 5 ]! !

!AbstractFont methodsFor: 'accessing' stamp: ''!
pointSize
	self subclassResponsibility! !

!AbstractFont methodsFor: 'measuring' stamp: ''!
widthOf: aCharacter
	"Return the width of the given character"
	^self subclassResponsibility! !

!AbstractFont methodsFor: '*FreeType-addition' stamp: ''!
kerningLeft: leftChar right: rightChar
	^0! !

!AbstractFont class methodsFor: 'class initialization' stamp: ''!
initialize

	TextStyle addDependent: self! !

!AbstractFont class methodsFor: 'updating' stamp: ''!
update: anAspect

	anAspect == #textDPIChanged ifTrue: [
		AbstractFont allSubInstancesDo: [ :font | font pixelsPerInchChanged ]].! !

!AbstractFont class methodsFor: 'emphasis' stamp: ''!
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: 'testing' stamp: ''!
isAbstract 

	^self == AbstractFont! !

!AbstractFont class methodsFor: '*System-Settings-Browser' stamp: ''!
settingInputWidgetForNode: aSettingNode
	^ aSettingNode inputWidgetForFont! !

!AbstractFontFamily commentStamp: ''!
Abstract font family!
!AbstractFontFamily methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		print: self class name;
		nextPut: $ ;
		print: self familyName! !

!AbstractFontFamily methodsFor: 'accessing' stamp: ''!
members
	"Answer the value of members"

	^ members! !

!AbstractFontFamily methodsFor: 'accessing' stamp: ''!
familyName: anObject
	"Set the value of familyName"

	familyName := anObject! !

!AbstractFontFamily methodsFor: 'accessing' stamp: ''!
familyName
	"Answer the value of familyName"

	^ familyName! !

!AbstractFontFamily methodsFor: 'member lookup' stamp: ''!
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! !

!AbstractFontFamily class methodsFor: 'testing' stamp: ''!
isAbstract

	 ^self name = #AbstractFontFamily! !

!AbstractFontFamilyMember commentStamp: ''!
Abstract member for a font family!
!AbstractFontFamilyMember methodsFor: 'testing' stamp: ''!
isSimulatedStyle
	"Return false by default, subclasses can override when they simulate the style"
	
	 ^false! !

!AbstractFontFamilyMember methodsFor: 'comparing' stamp: ''!
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! !

!AbstractFontFamilyMember methodsFor: 'accessing' stamp: ''!
weightValue
	self subclassResponsibility! !

!AbstractFontFamilyMember methodsFor: 'comparing' stamp: ''!
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) }! !

!AbstractFontFamilyMember methodsFor: 'comparing' stamp: ''!
closenessVector

	^ self
		  closenessVectorForStretch: self stretchValue
		  slant: self slantValue
		  weight: self weightValue! !

!AbstractFontFamilyMember methodsFor: 'accessing' stamp: ''!
family

	^ family! !

!AbstractFontFamilyMember methodsFor: 'converting' stamp: ''!
asLogicalFontOfPointSize: pointSize

	^LogicalFont
		familyName: self family familyName 
		pointSize: pointSize 
		stretchValue: self stretchValue
		weightValue: self weightValue
		slantValue: self slantValue! !

!AbstractFontFamilyMember methodsFor: 'accessing' stamp: ''!
styleName: anObject
	"Set the value of styleName"

	styleName := anObject! !

!AbstractFontFamilyMember methodsFor: 'accessing' stamp: ''!
stretchValue
	self subclassResponsibility! !

!AbstractFontFamilyMember methodsFor: 'accessing' stamp: ''!
family: aFontFamily

	family := aFontFamily! !

!AbstractFontFamilyMember methodsFor: 'accessing' stamp: ''!
slantValue
	self subclassResponsibility! !

!AbstractFontFamilyMember methodsFor: 'accessing' stamp: ''!
styleName
	"Answer the value of styleName"

	^ styleName! !

!AbstractFontFamilyMember class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self name = #AbstractFontFamilyMember! !

!AbstractFontFamilyMemberTest commentStamp: ''!
This class contains tests for class `AbstractFontFamilyMember`!
!AbstractFontFamilyMemberTest methodsFor: 'tests' stamp: ''!
testIsAbstractClass

	self 
		assert: AbstractFontFamilyMember isAbstract;
		assert: AbstractFontFamilyMember hasSubclasses! !

!AbstractFontFamilyTest commentStamp: ''!
This class contains tests for class `AbstractFontFamily`!
!AbstractFontFamilyTest methodsFor: 'tests' stamp: ''!
testIsAbstractClass

	self 
		assert: AbstractFontFamily isAbstract;
		assert: AbstractFontFamily hasSubclasses! !

!AbstractFontProvider commentStamp: ''!
Abstract superClass for fontProviders
	examples of possible fontProviders are 
		StrikeFontProvider
		FreeTypeFontProvider
		Win32NativeFontProvider
		!
!AbstractFontProvider methodsFor: 'accessing' stamp: ''!
families

	self subclassResponsibility! !

!AbstractFontProvider class methodsFor: 'testing' stamp: ''!
isAbstract

	 ^self name = #AbstractFontProvider! !

!AbstractFontProviderTest commentStamp: ''!
This class contains tests for class `AbstractFontProvider`!
!AbstractFontProviderTest methodsFor: 'tests' stamp: ''!
testIsAbstractClass

	self 
		assert: AbstractFontProvider isAbstract;
		assert: AbstractFontProvider hasSubclasses! !

!AbstractFontSelectorDialogWindow commentStamp: ''!
Dialog based font chooser with preview.!
!AbstractFontSelectorDialogWindow methodsFor: 'font description' stamp: ''!
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: 'actions' stamp: ''!
newContentMorph
	"Answer a new content morph."

	self textPreviewMorph: self newTextPreviewMorph.
	^(self newColumn: {
		(self newRow: {
			self newGroupbox: 'Family' translated for:
				self newFontFamilyMorph.
			(self newColumn: {
				(self newGroupbox: 'Style' translated for: 
					self newFontStyleButtonRowMorph)
					vResizing: #shrinkWrap.
				self newGroupbox: 'Point size' translated for:
					self newFontSizeMorph})
				hResizing: #shrinkWrap})
			vResizing: #spaceFill.
		(self newGroupbox: 'Preview' translated for:
			self textPreviewMorph)
			vResizing: #shrinkWrap})
		minWidth: 350;
		minHeight: 400! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
textPreviewMorph
	"Answer the value of textPreviewMorph"

	^ textPreviewMorph! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
fontSizeIndex
	"Answer the value of fontSizeIndex"

	^ fontSizeIndex! !

!AbstractFontSelectorDialogWindow methodsFor: 'instance creation' stamp: ''!
newItalicButtonMorph
	"Answer a button for the italic emphasis of the font."

	^ self
		newButtonFor: self
		getState: #isItalic
		action: #toggleItalic
		arguments: nil
		getEnabled: nil
		labelForm: (self iconNamed: #smallItalicIcon)
		help: 'Toggle italic font' translated! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
isUnderlined
	"Answer the value of isUnderlined"

	^ isUnderlined! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
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: 'defaults' stamp: ''!
defaultPreviewText
	"Answer the default text to use for the preview of the font."

	^(33 to: 127) asByteArray asString! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
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: 'instance creation' stamp: ''!
newFontSizeMorph
	"Answer a list for the font size of the font."

	^self
		newListFor: self
		list: #fontSizes
		selected: #fontSizeIndex
		changeSelected: #fontSizeIndex:
		help: nil! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
isUnderlined: anObject
	"Set the value of isUnderlined"

	isUnderlined := anObject.
	self changed: #isUnderlined! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
fontFamilyIndex
	"Answer the value of fontFamilyIndex"

	^ fontFamilyIndex! !

!AbstractFontSelectorDialogWindow methodsFor: 'instance creation' stamp: ''!
newUnderlinedButtonMorph
	"Answer a button for the italic emphasis of the font."

	^ self
		newButtonFor: self
		getState: #isUnderlined
		action: #toggleUnderlined
		arguments: nil
		getEnabled: nil
		labelForm: (self iconNamed: #smallUnderlineIcon)
		help: 'Toggle underlined font' translated! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
matchingFont
	"Answer the font that matches the selections."

	self subclassResponsibility! !

!AbstractFontSelectorDialogWindow methodsFor: 'actions' stamp: ''!
toggleStruckOut
	"Toggle the font struck out emphasis."

	self isStruckOut: self isStruckOut not.
	self updateSelectedFont! !

!AbstractFontSelectorDialogWindow methodsFor: 'updating' stamp: ''!
updateSelectedFont
	"Update the selected font to reflect the choices."

	self selectedFont: self matchingFont! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
isItalic
	"Answer the value of isItalic"

	^ isItalic! !

!AbstractFontSelectorDialogWindow methodsFor: 'instance creation' stamp: ''!
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: 'instance creation' stamp: ''!
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 iconNamed: #smallStrikeOutIcon)
		help: 'Toggle struck-out font' translated! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
selectedFont
	"Answer the value of selectedFont"

	^ selectedFont! !

!AbstractFontSelectorDialogWindow methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	self
		isBold: false;
		isItalic: false;
		isUnderlined: false;
		isStruckOut: false;
		previewText: self defaultPreviewText;
		fontFamilyIndex: 0;
		fontSizeIndex: 0.
	super initialize! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
isBold: anObject
	"Set the value of isBold"

	isBold := anObject.
	self changed: #isBold! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
isStruckOut: anObject
	"Set the value of isStruckOut"

	isStruckOut := anObject.
	self changed: #isStruckOut! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
isStruckOut
	"Answer the value of isStruckOut"

	^ isStruckOut! !

!AbstractFontSelectorDialogWindow methodsFor: 'instance creation' stamp: ''!
newFontStyleButtonRowMorph
	"Answer a new font style button row morph."

	^self newRow: {
		self newBoldButtonMorph.
		self newItalicButtonMorph.
		self newUnderlinedButtonMorph.
		self newStruckOutButtonMorph}! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
previewText
	"Answer the value of previewText"

	^previewText asText addAttribute: (TextEmphasis new emphasisCode: self textEmphasisCode)! !

!AbstractFontSelectorDialogWindow methodsFor: 'actions' stamp: ''!
toggleItalic
	"Toggle the font italic emphasis."

	self isItalic: self isItalic not.
	self updateSelectedFont! !

!AbstractFontSelectorDialogWindow methodsFor: 'actions' stamp: ''!
toggleUnderlined
	"Toggle the font underlined emphasis."

	self isUnderlined: self isUnderlined not.
	self updateSelectedFont! !

!AbstractFontSelectorDialogWindow methodsFor: 'updating' stamp: ''!
updateFromSelectedFont
	"Update our state based on the selected font."

	self subclassResponsibility! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
fontSizes
	"Answer the set of available fonts sizes that are supported."

	^#(6 7 8 9 10 11 12 13 14 15 16 18 20 21 22 24 26 28 32 36 48)! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
isItalic: anObject
	"Set the value of isItalic"

	isItalic := anObject.
	self changed: #isItalic! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
fontSizeIndex: anObject
	"Set the value of fontSizeIndex"

	fontSizeIndex := anObject.
	self updateSelectedFont! !

!AbstractFontSelectorDialogWindow methodsFor: 'instance creation' stamp: ''!
newBoldButtonMorph
	"Answer a button for the boldness of the font."

	^ self
		newButtonFor: self
		getState: #isBold
		action: #toggleBold
		arguments: nil
		getEnabled: nil
		labelForm: (self iconNamed: #smallBoldIcon)
		help: 'Toggle bold font' translated! !

!AbstractFontSelectorDialogWindow methodsFor: 'instance creation' stamp: ''!
newTextPreviewMorph
	"Answer a text entry morph for the preview of the font."

	^(self
		newTextEditorFor: self
		getText: #previewText 
		setText: nil
		getEnabled: nil)
		vResizing: #rigid;
		enabled: false;
		extent: 20@90! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
fontFamilyIndex: anObject
	"Set the value of fontFamilyIndex"

	fontFamilyIndex := anObject.
	self updateSelectedFont! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
familyName
	"Answer the selected family name or nil if none."

	(self fontFamilyIndex between: 1 and: self fontFamilies size)
		ifFalse: [^nil].
	^(self fontFamilies at: self fontFamilyIndex) asString! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
previewText: anObject
	"Set the value of previewText"

	previewText := anObject.
	self changed: #previewText! !

!AbstractFontSelectorDialogWindow methodsFor: 'defaults' stamp: ''!
defaultFontFamilies
	"Answer the set of available fonts families that are supported in the font that they represent."
	
	self subclassResponsibility! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
isBold
	"Answer the value of isBold"

	^ isBold! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
selectedFont: anObject
	"Set the value of selectedFont"

	selectedFont := anObject ifNil: [TextStyle defaultFont].
	self updateFromSelectedFont! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
fontFamilies: anObject
	"Set the value of fontFamilies"

	fontFamilies := anObject! !

!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
textPreviewMorph: anObject
	"Set the value of textPreviewMorph"

	textPreviewMorph := anObject! !

!AbstractFontSelectorDialogWindow methodsFor: 'actions' stamp: ''!
toggleBold
	"Toggle the font bold emphasis."

	self isBold: self isBold not.
	self updateSelectedFont! !

!AbstractFontSelectorDialogWindow class methodsFor: 'testing' stamp: ''!
isAbstract

	^self == AbstractFontSelectorDialogWindow! !

!AbstractFontSelectorDialogWindow class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^ #smallFontsIcon! !

!AbstractFontStoredSetting commentStamp: ''!
I am an abstract class and my subclasses are responsible for storing information about a font object. !
!AbstractFontStoredSetting methodsFor: 'accessing' stamp: ''!
emphasized
	^ emphasized! !

!AbstractFontStoredSetting methodsFor: 'accessing' stamp: ''!
pointSize: anObject
	pointSize := anObject! !

!AbstractFontStoredSetting methodsFor: 'accessing' stamp: ''!
fontClassName
	^ fontClassName! !

!AbstractFontStoredSetting methodsFor: 'accessing' stamp: ''!
familyName: anObject
	familyName := anObject! !

!AbstractFontStoredSetting methodsFor: 'accessing' stamp: ''!
emphasized: anObject
	emphasized := anObject! !

!AbstractFontStoredSetting methodsFor: 'accessing' stamp: ''!
familyName
	^ familyName! !

!AbstractFontStoredSetting methodsFor: 'accessing' stamp: ''!
pointSize
	^ pointSize! !

!AbstractFontStoredSetting methodsFor: 'accessing' stamp: ''!
fontClassName: anObject
	fontClassName := anObject! !

!AbstractFontStoredSetting class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == AbstractFontStoredSetting! !

!AbstractFormButtonPresenter commentStamp: ''!
AbstractFormButtonPresenter is an abstract class for button of form (like radiobuttons or checkbox).
See AbstractWidgetPresenter

self example

I provide the following variables and their accessors
- activationAction and desactivationAction are actions to perform when I am activated / deactivated.
- label is the text displayed near the box.
- state is a boolean representing if I am activated, it is false by default

I provide the following methods
- click to simulate a click on me.
- toggleState to reverse my state.
!
!AbstractFormButtonPresenter methodsFor: 'api - events' stamp: ''!
whenActivatedDo: aBlock
	"This method is used to propagate the event that I have been activated" 
	
	stateHolder whenChangedDo: [:bool | bool ifTrue: aBlock ]! !

!AbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
activationAction: aBlock
	"<api: #block getter: #activationAction registration: #whenActivationActionChanged:>"
	"This method is used to set the action to perform when I am activated"
	
	actionWhenActivatedHolder value: aBlock! !

!AbstractFormButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	actionWhenActivatedHolder := [] asValueHolder.
	actionWhenDeactivatedHolder := [] asValueHolder.
	enabledHolder := true asValueHolder.
	stateHolder := false asValueHolder.
	labelClickableHolder := true asValueHolder. 
	labelHolder := '' asValueHolder.
	stateHolder whenChangedDo: [:bool |
		bool
			ifTrue: actionWhenActivatedHolder value
			ifFalse: actionWhenDeactivatedHolder value.
		self changed: #state ].
	
	labelClickableHolder whenChangedDo: [:aBoolean | self changed: { #labelClickable: . aBoolean } ].
	labelHolder whenChangedDo: [:label | self changed: { #label: . label } ].! !

!AbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
label: aString
	"<api: #string getter: #label>"
	"Set the label of the checkbox"

	labelHolder value: aString! !

!AbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
toggleState
	"<api: #do>"
	"Toggle the current state of the checkbox"

	self state: self state not! !

!AbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
state: aBoolean
	"Set if the checkbox is activated or not"
	"<api: #boolean getter: #state>"
	stateHolder value: aBoolean! !

!AbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
click
	"<api: #do>"
	"Simulate a click on the checkbox
	Used when the checkboc is a list item"

	self toggleState! !

!AbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
labelClickable: aBoolean
	"<api: #boolean getter: #labelClickable registration: #whenLabelClickableChanged:>"
	"Set if the label can be clicked to select the checkbox"
	
	labelClickableHolder value: aBoolean! !

!AbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
labelClickable
"	<api: #inspect>"
	"Return true if the label can be clicked to select the checkbox"

	^ labelClickableHolder value! !

!AbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
state
	"<api: #inspect>"

	"Return the current state of the form button"

	^ stateHolder value! !

!AbstractFormButtonPresenter methodsFor: 'api - events' stamp: ''!
whenChangedDo: aBlock
	"This method is used to propagate the event that I have changed"
	
	stateHolder whenChangedDo: aBlock! !

!AbstractFormButtonPresenter methodsFor: 'legacy' stamp: ''!
whenDeactivationActionChanged: aBlock
	"A block performed when the deactivation action changed"
	actionWhenDeactivatedHolder whenChangedDo:  aBlock ! !

!AbstractFormButtonPresenter methodsFor: 'api - valueHolder' stamp: ''!
labelHolder

	^ labelHolder! !

!AbstractFormButtonPresenter methodsFor: 'legacy' stamp: ''!
deactivationAction: aBlock
	"<api: #block getter: #desactivationAction registration: #whenDeactivationActionChanged:>"
	"This method is used to set the action to perform when I am deactivated"
	
	actionWhenDeactivatedHolder value: aBlock! !

!AbstractFormButtonPresenter methodsFor: 'legacy' stamp: ''!
whenDeactivatedDo: aBlock
	"This method is used to propagate the event that I have been deactivated"
	
	stateHolder whenChangedDo: [:bool | bool ifFalse: aBlock ]! !

!AbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
label
	"<api: #inspect>"
	^ labelHolder value! !

!AbstractFormButtonPresenter methodsFor: 'api - events' stamp: ''!
whenActivationActionChanged: aBlock
	"A block performed when the activation action changed"
	actionWhenActivatedHolder whenChangedDo: aBlock ! !

!AbstractFormButtonPresenter methodsFor: 'api - events' stamp: ''!
whenLabelClickableChanged: aBlock
	"A block performed when the label click is activated or descativated"
	
	labelClickableHolder whenChangedDo:  aBlock ! !

!AbstractInitializedClassVariable commentStamp: ''!
Intialized Class Variables define a default value as part of their definition.

The default parameter can be literal or a block.

There are two subclasses: setting the default value on class creation and lazy initialization on read.!
!AbstractInitializedClassVariable methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		store: self name;
		nextPutAll: ' => ';
		nextPutAll: self class name;
		nextPutAll: ' default: '.
	default printOn: aStream! !

!AbstractInitializedClassVariable methodsFor: 'accessing' stamp: ''!
default: anObject
	default := anObject! !

!AbstractInitializedClassVariable class methodsFor: 'testing' stamp: ''!
isAbstract

	^self == AbstractInitializedClassVariable! !

!AbstractInitializedSlot commentStamp: ''!
Intialized Slots define a default value as part of their definition.

the default parameter can be literal or a block (which is evaluated on init). If the block has a parameter this will be set to the instance.

There are two subclasses: setting the default value on instantion and lazy initialization on read.!
!AbstractInitializedSlot methodsFor: 'comparing' stamp: ''!
= other
	^ super = other and: [default = other default]! !

!AbstractInitializedSlot methodsFor: 'comparing' stamp: ''!
hash
	^super hash bitXor: default hash! !

!AbstractInitializedSlot methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		store: self name;
		nextPutAll: ' => ';
		nextPutAll: self class name;
		nextPutAll: ' default: '.
	default printOn: aStream! !

!AbstractInitializedSlot methodsFor: 'accessing' stamp: ''!
default: anObject
	default := anObject! !

!AbstractInitializedSlot class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == AbstractInitializedSlot! !

!AbstractKeymappingTest commentStamp: ''!
This is an abstract class for test cases for the Keymapping project. 

It includes some utility methods to make it simpler to test different key events.

When tests are run this class will ensure that the current Keymap global repository is swiched out with a dummy one to not interfer with the running system.  (see #setUp/#tearDown).


!
!AbstractKeymappingTest methodsFor: 'utilities' stamp: ''!
eventKey: character alt: aBoolean
	^ self eventKey: character
		alt: aBoolean
		ctrl: false
		command: false
		shift: false! !

!AbstractKeymappingTest methodsFor: 'running' stamp: ''!
tearDown
	KMRepository default: default.
	default := nil.
	super tearDown! !

!AbstractKeymappingTest methodsFor: 'utilities' stamp: ''!
eventKey: character ctrl: aBoolean
	^ self eventKey: character
		alt: false
		ctrl: aBoolean
		command: false
		shift: false! !

!AbstractKeymappingTest methodsFor: 'utilities' stamp: ''!
eventKey: character command: aBoolean
	^ self eventKey: character
		alt: false
		ctrl: false
		command: aBoolean
		shift: false! !

!AbstractKeymappingTest methodsFor: 'utilities' stamp: ''!
eventKey: character shift: aBoolean
	^ self eventKey: character
		alt: false
		ctrl: false
		command: false
		shift: aBoolean! !

!AbstractKeymappingTest methodsFor: 'utilities' stamp: ''!
eventKey: character 
	^ self eventKey: character
		alt: false
		ctrl: false
		command: false
		shift: false! !

!AbstractKeymappingTest methodsFor: 'utilities' stamp: ''!
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 key: (KeyboardKey fromCharacter: character).
	^ event! !

!AbstractKeymappingTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	default := KMRepository default.
	KMRepository default: KMRepository new! !

!AbstractKeymappingTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^self name = #AbstractKeymappingTest! !

!AbstractLayout commentStamp: ''!
I'm a container for slots.
!
!AbstractLayout methodsFor: 'api' stamp: ''!
hasSlotNamed: aString
	"Return true whether the receiver defines an instance variable named aString.
	this includs non-visible slots"
	^self allSlots anySatisfy: [:slot | slot name = aString  ]! !

!AbstractLayout methodsFor: 'comparing' stamp: ''!
= other
	^ self class = other class! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
extendDoubleByte
	^ self subclassResponsibility! !

!AbstractLayout methodsFor: 'comparing' stamp: ''!
hash
	^ self class hash! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
fieldSize
	^ 0! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
allVisibleSlots
	^ {}! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
extendDoubleWord
	^ self subclassResponsibility! !

!AbstractLayout methodsFor: 'validation' stamp: ''!
checkSanity
	host ifNil: [ self error: 'Host should not be nil' ].! !

!AbstractLayout methodsFor: 'testing' stamp: ''!
hasBindingThatBeginsWith: aString
	"Answer true if there is a Slot that begins with aString, false otherwise"
	^false! !

!AbstractLayout methodsFor: 'testing' stamp: ''!
isWeak
	^ false! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
extendVariable: arg1 
	^ self subclassResponsibility! !

!AbstractLayout methodsFor: 'api' stamp: ''!
definesSlot: aSlot 
	^self slots identityIncludes: aSlot! !

!AbstractLayout methodsFor: 'api' stamp: ''!
resolveSlot: aName ifFound: foundBlock ifNone: exceptionBlock
	^exceptionBlock value! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
visibleSlots
	^self slots select: [:slot | slot isVisible]! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
allSlots
	^ {}! !

!AbstractLayout methodsFor: 'enumerating' stamp: ''!
allSlotsDo: aBlock
	self slotScope allSlotsDo: aBlock! !

!AbstractLayout methodsFor: 'testing' stamp: ''!
isFixedLayout
	^false! !

!AbstractLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	self subclassResponsibility ! !

!AbstractLayout methodsFor: 'validation' stamp: ''!
checkIntegrity
	self checkSanity! !

!AbstractLayout methodsFor: 'testing' stamp: ''!
isBits
	^ false! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
extend: arg1 
	^ self subclassResponsibility! !

!AbstractLayout methodsFor: 'testing' stamp: ''!
hasSlots
	^ false! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
slots
	^ {}! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
host
	^ host! !

!AbstractLayout methodsFor: 'testing' stamp: ''!
hasFields
	^ false! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
slotScope
	^ LayoutEmptyScope instance! !

!AbstractLayout methodsFor: 'api' stamp: ''!
hasSlot: aSlot
	^ self allSlots identityIncludes: aSlot! !

!AbstractLayout methodsFor: 'testing' stamp: ''!
isVariable
	^ false! !

!AbstractLayout methodsFor: 'extending' stamp: ''!
extendImmediate
	^ ImmediateLayout new! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
extendByte
	^ self subclassResponsibility! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
instVarNames
	^ {}! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
extendWord
	^ self subclassResponsibility! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
host: aClass
	host := aClass! !

!AbstractLayout methodsFor: 'accessing' stamp: ''!
resolveSlot: aName
	^SlotNotFound signalForName: aName! !

!AbstractLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == AbstractLayout! !

!AbstractLayoutScope commentStamp: ''!
Layout scopes reify how classes extend the layout of their superclass.!
!AbstractLayoutScope methodsFor: 'extending' stamp: ''!
extend: someSlots
	^ self extend: someSlots as: LayoutClassScope! !

!AbstractLayoutScope methodsFor: 'testing' stamp: ''!
hasSlots
	self subclassResponsibility! !

!AbstractLayoutScope methodsFor: 'comparing' stamp: ''!
= other
	^ self class = other class! !

!AbstractLayoutScope methodsFor: 'enumerating' stamp: ''!
indexOf: anElement
	"Answer the index of the first occurrence of anElement within the  
	receiver. If the receiver does not contain anElement, answer 0."

	^ self indexOf: anElement ifAbsent: 0! !

!AbstractLayoutScope methodsFor: 'comparing' stamp: ''!
hash
	^ self class hash! !

!AbstractLayoutScope methodsFor: 'accessing' stamp: ''!
fieldSize
	self subclassResponsibility! !

!AbstractLayoutScope methodsFor: 'extending' stamp: ''!
extend
	^ self extend: { }! !

!AbstractLayoutScope methodsFor: 'extending' stamp: ''!
extend: someSlots as: type
	| scope fieldIndex  |
	scope := type new: someSlots size.
	fieldIndex := self firstFieldIndex.
	scope parentScope: self.
	
	someSlots withIndexDo: [ :slot :slotIndex | |realSlot|
		realSlot := slot asSlot.
		realSlot scope: scope.
		realSlot isVirtual ifFalse: [realSlot index: fieldIndex].
		fieldIndex := fieldIndex + realSlot size.
		scope at: slotIndex put: realSlot ].
	^ scope! !

!AbstractLayoutScope methodsFor: 'accessing' stamp: ''!
ownFieldSize
	self subclassResponsibility! !

!AbstractLayoutScope methodsFor: 'accessing' stamp: ''!
allVisibleSlots
	^ self subclassResponsibility! !

!AbstractLayoutScope methodsFor: 'testing' stamp: ''!
hasFields
	self subclassResponsibility! !

!AbstractLayoutScope methodsFor: 'accessing' stamp: ''!
hasBindingThatBeginsWith: arg1 
	^ self subclassResponsibility! !

!AbstractLayoutScope methodsFor: 'flattening' stamp: ''!
flatten
	self subclassResponsibility! !

!AbstractLayoutScope methodsFor: 'enumerating' stamp: ''!
indexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of the first occurrence of anElement within the  
	receiver. If the receiver does not contain anElement, answer the 
	result of evaluating the argument, exceptionBlock."

	1 to: self size do:
		[:index |
		(self at: index) = anElement ifTrue: [^ index]].
	^ exceptionBlock value! !

!AbstractLayoutScope methodsFor: 'accessing' stamp: ''!
resolveSlot: aName ifFound: foundBlock ifNone: exceptionBlock
	self allSlotsDo: [ :slot | 
		slot name == aName ifTrue: [ ^ foundBlock cull: slot ]].
	^ exceptionBlock value! !

!AbstractLayoutScope methodsFor: 'accessing' stamp: ''!
visibleSlotNames
	^self visibleSlots collect: [:each | each name ]! !

!AbstractLayoutScope methodsFor: 'accessing' stamp: ''!
visibleSlots
	self subclassResponsibility! !

!AbstractLayoutScope methodsFor: 'enumerating' stamp: ''!
allSlotsDo: aBlock
	self subclassResponsibility! !

!AbstractLayoutScope methodsFor: 'accessing' stamp: ''!
resolveSlot: aName
	^ self 
		resolveSlot: aName 
		ifFound: [:slot | slot ] 
		ifNone: [ SlotNotFound signalForName: aName ].! !

!AbstractLayoutScope methodsFor: 'accessing' stamp: ''!
firstFieldIndex
	^ self fieldSize + 1! !

!AbstractLayoutScope methodsFor: 'testing' stamp: ''!
ifNotEmpty: aBlock
	self subclassResponsibility! !

!AbstractLayoutScope class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == AbstractLayoutScope! !

!AbstractMessageCentricBrowser commentStamp: ''!
I am an abstract class for browsers centered around messages such as class `MessageBrowser` or class `VersionBrowser`.!
!AbstractMessageCentricBrowser methodsFor: 'private - factory' stamp: ''!
newTextConverter

	^ DiffSourceMethodConverter new! !

!AbstractMessageCentricBrowser methodsFor: 'initialization' stamp: ''!
initialize

	textConverter := self newTextConverter.
	super initialize
	! !

!AbstractMessageCentricBrowser methodsFor: 'accessing' stamp: ''!
textConverter
	^ textConverter! !

!AbstractMessageCentricBrowser methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	| winExtent |
	
	winExtent := RealEstateAgent standardWindowExtent.
	aWindowPresenter initialExtent: (900 min: winExtent x) @ (550 min: winExtent y)! !

!AbstractMessageCentricBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	messageList := self instantiate: MessageList.
	toolbarPresenter := self instantiate: SpMethodToolbarPresenter! !

!AbstractMessageCentricBrowser methodsFor: 'private - testing' stamp: ''!
isMethodDefinition: anItem
	"an item can be nil, a compiled method, or a ring object. Whereas a ring object can be a ring method or comment definition.
	 Some operations are only valid for compiled methods or ring object that are a method definitions"

	anItem ifNil: [ ^ false ].
	
	"assume it is a compiled method or ring method definition"
	^ (anItem isRingObject and: [ anItem isMethod and: [ anItem compiledMethod isNotNil ] ])
		or: [  anItem isCompiledMethod ]! !

!AbstractMessageCentricBrowser methodsFor: 'api' stamp: ''!
selectedMessage
	^ messageList selectedMessage! !

!AbstractMessageCentricBrowser methodsFor: 'accessing' stamp: ''!
textConverter: aTextConverter
	textConverter := aTextConverter method: self textConverter method! !

!AbstractMessageCentricBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ self subclassResponsibility! !

!AbstractMessageCentricBrowser class methodsFor: 'testing' stamp: ''!
isAbstract 
	 ^self name = #AbstractMessageCentricBrowser! !

!AbstractMethodConverter commentStamp: ''!
An AbstractMessageConverter is a wrapper used to switch which information to retrieve from a method.

This way, you can avoid switch case, you just have to use set the correct filter!
!AbstractMethodConverter methodsFor: 'accessing' stamp: ''!
method

	^ method! !

!AbstractMethodConverter methodsFor: 'private' stamp: ''!
internalGetText

	^ self subclassResponsibility! !

!AbstractMethodConverter methodsFor: 'accessing' stamp: ''!
method: aMessage

	method := aMessage! !

!AbstractMethodConverter methodsFor: 'initialization' stamp: ''!
shouldShout

	^ false! !

!AbstractMethodConverter methodsFor: 'protocol' stamp: ''!
getTextFor: aMethod

	method := aMethod.
	method ifNil: [ ^ '' ].
	
	^ self internalGetText! !

!AbstractMethodConverter methodsFor: 'protocol' stamp: ''!
getText

	method ifNil: [ ^ '' ].	
	^ self internalGetText! !

!AbstractMethodConverter class methodsFor: 'instance creation' stamp: ''!
method: aMessage

	^ self new
		method: aMessage;
		yourself! !

!AbstractMethodReferenceConverter commentStamp: ''!
Abstract wrapper for method references!
!AbstractMethodReferenceConverter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	referencesList := #()! !

!AbstractMethodReferenceConverter methodsFor: 'private' stamp: ''!
versionOfAMethod: aMethodReference
	| tempList |
	
	tempList := referencesList select: [:each | 
		(each className = aMethodReference className) & 
		(each name = aMethodReference name)].
	tempList := tempList sort: [:m1 :m2 | m1 timeStamp < m2 timeStamp].
	^ tempList identityIndexOf: aMethodReference ifAbsent: [0]! !

!AbstractMethodReferenceConverter methodsFor: 'private' stamp: ''!
priorVersionOfAMethod: aMethodReference
	| tempList |
	
	tempList := referencesList select:[:each | 
		(each className = aMethodReference className) & 
		(each name = aMethodReference name)].
	^ tempList detect: [:each | (self versionOfAMethod: each) = ((self versionOfAMethod: aMethodReference) -1)] ifNone: [aMethodReference].! !

!AbstractMethodReferenceConverter methodsFor: 'accessing' stamp: ''!
referencesList: aListOfReferences

	referencesList := aListOfReferences! !

!AbstractMethodReferenceConverter class methodsFor: 'instance creation' stamp: ''!
methodReference: aMessage referencesList: aListOfReferences
	^ (self method: aMessage)
		referencesList: aListOfReferences;
		yourself! !

!AbstractMorphicAdapter commentStamp: ''!
I am an abstract class providing all the properties shared amongst all the morphic specific adapters!
!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
color: color

	self widgetDo: [ :w | w color: color ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
hSpaceFill
	
	self widgetDo: [ :w | w hResizing: #spaceFill ]! !

!AbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: ''!
transferFor: passenger from: source
	^ (self transferBlock cull: passenger cull: self model) buildWithSpec! !

!AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
dragTransformationBlock

	^ self model dragTransformationBlock! !

!AbstractMorphicAdapter methodsFor: 'protocol - shortcuts' stamp: ''!
removeMenuKeyCombination: aShortcut

	self widget ifNotNil: [ :w | w removeKeyCombination: aShortcut ]! !

!AbstractMorphicAdapter methodsFor: 'dispatch' stamp: ''!
treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph
	"Specify how this object as a list item should be drawn"

	self widget ifNil: [ self buildWithSpec ].
	self widget treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
borderColor: color

	self widget ifNotNil: [ :w | w borderColor: color ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
hRigid
	
	self widgetDo: [ :w | w hResizing: #rigid ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
useProportionalLayout

	self widgetDo: [ :w | w changeProportionalLayout ]! !

!AbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: ''!
dragPassengersFor: item inMorph: dragSource 
	
	^ { self dragTransformationBlock cull: item cull: dragSource }! !

!AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
dragEnabled

	^ self model dragEnabled! !

!AbstractMorphicAdapter methodsFor: 'dispatch' stamp: ''!
heightToDisplayInList: aList
	"Return the width of my representation as a list item"
	
	self model extent ifNotNil: [:ex | ^ ex y ].
	self model initialExtent ifNotNil: [:ex | ^ ex y ].
	
	self widget ifNil: [ self buildWithSpec ].
	self widget 
		vResizing: #rigid;
		hResizing: #rigid.
		
	^ self widget heightToDisplayInList: aList! !

!AbstractMorphicAdapter methodsFor: 'protocol - shortcuts' stamp: ''!
bindMenuKeyCombination: aShortcut toAction: aBlock

	self widget ifNotNil: [ :w | w bindKeyCombination: aShortcut toAction: aBlock ]! !

!AbstractMorphicAdapter methodsFor: 'protocol - shortcuts' stamp: ''!
removeKeyCombination: aShortcut

	self widget ifNotNil: [ :w | w removeKeyCombination: aShortcut ]! !

!AbstractMorphicAdapter methodsFor: 'spec protocol' stamp: ''!
delete
	
	self widgetDo: [ :w | w delete ]! !

!AbstractMorphicAdapter methodsFor: 'testing' stamp: ''!
isMorphicAdapter

	^ true! !

!AbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: ''!
acceptDroppingMorph: draggedMorph event: event inMorph: source

	^ self acceptDropBlock cull: draggedMorph model model cull: event cull: source model model! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
borderWidth: width

	self widget ifNotNil: [ :w | w borderWidth: width ]! !

!AbstractMorphicAdapter methodsFor: 'spec protocol' stamp: ''!
setModal: aWindow 

	self widgetDo: [ :w | w setModal: aWindow ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
enable

	self model enabled: true! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
extent

	^ self widget extent! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
enabled
	
	^ self model enabled! !

!AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
dragEnabled: aBoolean

	self widget ifNotNil: [ :w | w dragEnabled: aBoolean ]! !

!AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
acceptDropBlock

	^ self model acceptDropBlock! !

!AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
wantDropBlock

	^ self model wantDropBlock! !

!AbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: ''!
wantsDroppedMorph: draggedMorph event: anEvent inMorph: source

	^ self wantDropBlock cull: draggedMorph cull: anEvent cull:source! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
color

	^ self model color! !

!AbstractMorphicAdapter methodsFor: 'spec protocol' stamp: ''!
changed

	^ self widgetDo: [ :w | w changed ]! !

!AbstractMorphicAdapter methodsFor: 'protocol - shortcuts' stamp: ''!
bindKeyCombination: aShortcut toAction: aBlock

	self widget ifNotNil: [ :w | w bindKeyCombination: aShortcut toAction: aBlock ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
add: aWidget
	
	self widgetDo: [ :w | w ensureLayoutAndAddMorph: aWidget asWidget ]! !

!AbstractMorphicAdapter methodsFor: 'dispatch' stamp: ''!
heightToDisplayInTree: aTree
	"Return the width of my representation as a list item"
	
	self extent ifNotNil: [:ex | ^ ex y ].
	self initialExtent ifNotNil: [:ex | ^ ex y ].
	
	self widget ifNil: [ self buildWithSpec ].
	^ self widget heightToDisplayInTree: aTree! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
layout: aLayout
	| layout |
	
	layout := aLayout asMorphicLayout.

	self widgetDo: [ :w | w layoutFrame: layout ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
borderWidth

	^ self model borderWidth! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
vShrinkWrap
	
	self widgetDo: [ :w | w vResizing: #shrinkWrap ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
vSpaceFill
	
	self widgetDo: [ :w | w vResizing: #spaceFill ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
vRigid
	
	self widgetDo: [ :w | w vResizing: #rigid ]! !

!AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
dropEnabled

	^ self model dropEnabled! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
enabled: aBoolean

	self widget ifNotNil: [ :w | w enabled: aBoolean ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
removeSubWidgets
	
	self widgetDo: [ :w | w removeAllMorphs ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
setBalloonText: aString

	self widget ifNotNil: [ :w | w setBalloonText: aString ]! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
borderColor

	^ self model borderColor! !

!AbstractMorphicAdapter methodsFor: 'dispatch' stamp: ''!
beginsWith: aString fromList: aMorph
	"This method is used bu the list for the search of elements when you are typing directly in the list"
	
	^ false! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
help

	^ self model help! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
hShrinkWrap
	
	self widgetDo: [ :w | w hResizing: #shrinkWrap ]! !

!AbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: ''!
dragPassengerFor: item inMorph: dragSource 
	
	^ self dragTransformationBlock cull: item cull: dragSource! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
disable
	
	self model enabled: false! !

!AbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
when: anAnnouncement do: aBlock

	self widgetDo: [ :w | w announcer
		when: anAnnouncement do: aBlock ]! !

!AbstractMorphicAdapter methodsFor: 'dispatch' stamp: ''!
listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph
	"Specify how this object as a list item should be drawn"

	self widget ifNil: [ self buildWithSpec ].
	self widget 
		vResizing: #rigid;
		hResizing: #rigid.
		
	self widget
		listRenderOn: aCanvas
		atRow: aRow
		bounds: drawBounds
		color: drawColor
		backgroundColor: backgroundColor
		from: aMorph! !

!AbstractMorphicAdapter methodsFor: 'dispatch' stamp: ''!
widthToDisplayInList: aList
	"Return the width of my representation as a list item"
	
	self model extent ifNotNil: [:ex | ^ ex x ].
	self model initialExtent ifNotNil: [:ex | ^ ex x ].

	self widget ifNil: [ self buildWithSpec ].
	self widget 
		vResizing: #rigid;
		hResizing: #rigid.
		
	^ self widget widthToDisplayInList: aList! !

!AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
dropEnabled: aBoolean

	self widget ifNotNil: [ :w | w dropEnabled: aBoolean ]! !

!AbstractMorphicAdapter methodsFor: 'dispatch' stamp: ''!
widthToDisplayInTree: aTree
	"Return the width of my representation as a list item"
	
	self extent ifNotNil: [:ex | ^ ex x ].
	self initialExtent ifNotNil: [:ex | ^ ex x ].
	
	self widget ifNil: [ self buildWithSpec ].
	^ self widget widthToDisplayInTree: aTree! !

!AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
transferBlock

	^ self model transferBlock! !

!AbstractMorphicAdapter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpecLayout composed! !

!AbstractObjectsAsMethod commentStamp: ''!
This class shows the API that an object needs to implement if it is supposed to be used as a method.

The vm calls run:with:in:, see the subclass for a simple example.!
!AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: ''!
flushCache! !

!AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: ''!
methodClass: aMethodClass! !

!AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: ''!
selector: aSymbol! !

!AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: ''!
origin
	^self class! !

!AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: ''!
cachePragmas! !

!AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: ''!
package
	^self class package! !

!AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: ''!
pragmas
	^#()! !

!AbstractResizerMorph commentStamp: ''!
I am the superclass of a hierarchy of morph specialized in allowing the user to resize or rearrange windows and panes.!
!AbstractResizerMorph methodsFor: 'actions' stamp: ''!
dotColor

	^ dotColor ifNil: [self setDefaultColors. dotColor]! !

!AbstractResizerMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self color: Color transparent! !

!AbstractResizerMorph methodsFor: 'event handling' stamp: ''!
mouseEnter: anEvent

	self isCursorOverHandle ifTrue:
		[self setInverseColors.
		self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation"
		anEvent hand showTemporaryCursor: self resizeCursor]! !

!AbstractResizerMorph methodsFor: 'testing' stamp: ''!
shouldDraw
	"Answer whether the resizer should be drawn."
	
	^self fillStyle isTransparent not! !

!AbstractResizerMorph methodsFor: 'testing' stamp: ''!
isCursorOverHandle

	^ true! !

!AbstractResizerMorph methodsFor: 'event handling' stamp: ''!
mouseDown: anEvent

	lastMouse := anEvent cursorPoint! !

!AbstractResizerMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: anEvent

	anEvent hand showTemporaryCursor: nil.
	self setDefaultColors.
	self shouldInvalidateOnMouseTransition ifTrue: [self changed]. 
	"avoid unnecessary invalidation"! !

!AbstractResizerMorph methodsFor: 'actions' stamp: ''!
resizeCursor

	self subclassResponsibility! !

!AbstractResizerMorph methodsFor: 'actions' stamp: ''!
adoptPaneColor: paneColor
	"Just get the resizer fill style for the theme."
	
	paneColor ifNil: [^super adoptPaneColor: paneColor].
	self fillStyle: (self theme resizerGripNormalFillStyleFor: self)! !

!AbstractResizerMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: anEvent

	^ true! !

!AbstractResizerMorph methodsFor: 'event handling' stamp: ''!
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: 'event handling' stamp: ''!
handlesMouseDown: anEvent

	^ true! !

!AbstractResizerMorph methodsFor: 'actions' stamp: ''!
setInverseColors

	handleColor := Color lightGray.
	dotColor := Color white! !

!AbstractResizerMorph methodsFor: 'actions' stamp: ''!
setDefaultColors

	handleColor := Color lightGray lighter lighter.
	dotColor := Color gray lighter! !

!AbstractResizerMorph methodsFor: 'testing' stamp: ''!
shouldInvalidateOnMouseTransition
	"Answer whether the resizer should be invalidated
	when the mouse enters or leaves."
	
	^false! !

!AbstractResizerMorph methodsFor: 'actions' stamp: ''!
handleColor

	^ handleColor ifNil: [self setDefaultColors. handleColor]! !

!AbstractSessionHandler commentStamp: ''!
API  to manage startup and shutdown of a session.
On startup, isImageStarting indicates whether the image is starting or just resuming from a save.
On shutdown, isQuitting indicates if we save and quit the image  or if we just save  the image.  !
!AbstractSessionHandler methodsFor: 'handlers' stamp: ''!
startup: isImageStarting
	self subclassResponsibility! !

!AbstractSessionHandler methodsFor: 'accessing' stamp: ''!
handledId
	self subclassResponsibility! !

!AbstractSessionHandler methodsFor: 'handlers' stamp: ''!
shutdown: isImageQuitting
	self subclassResponsibility! !

!AbstractSessionHandler methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream 
		nextPut: $(;
		nextPutAll: self handledId;
		nextPut: $)! !

!AbstractSessionHandler class methodsFor: 'testing' stamp: ''!
isAbstract 
	
	^self == AbstractSessionHandler! !

!AbstractSpecLayoutAction commentStamp: ''!
AbstractSpecLayoutAction is an abstract class representing a spec layout action.!
!AbstractSpecLayoutAction methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!AbstractSpecLayoutAction methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!AbstractSpecLayoutAction methodsFor: 'accessing' stamp: ''!
arguments: anObject
	arguments := anObject! !

!AbstractSpecLayoutAction methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!AbstractSpecLayoutAction methodsFor: 'protocol' stamp: ''!
generateArguments

	! !

!AbstractSpecLayoutAction methodsFor: 'protocol' stamp: ''!
asSpecElements

	self subclassResponsibility ! !

!AbstractStoredSetting commentStamp: ''!
I am an abstract class of all stored settings. My subclasses are responsible for keeping SettingNode identifier and its real value that is supposed to store or has been loaded. There are some objects that cannot by directly stored into a file, e.g. fonts, because they includes too much information for storing. For that reason SettingNode objects are converted into objects of my subclasses that keeps storing simple. 

Collaborators: StoredSettingsFactory, SystemSettingsPersistence

Public API and Key Messages

- realValue
- settingNodeIdentifier 
- settingNodeIdentifier:
- isForSettingNode:
- StoredSettingsFactory creates instances of me.

Internal Representation and Key Implementation Points.

    Instance Variables
	settingNodeIdentifier:		<Symbol>
!
!AbstractStoredSetting methodsFor: 'accessing' stamp: ''!
hasDefaultValue
	^ hasDefaultValue ifNil: [ ^ false ]! !

!AbstractStoredSetting methodsFor: 'accessing' stamp: ''!
hasDefaultValue: aBoolean 
	
	hasDefaultValue := aBoolean! !

!AbstractStoredSetting methodsFor: 'comparing' stamp: ''!
= aStoredSetting
	^ self class = aStoredSetting class and: [ 
		self settingNodeIdentifier = aStoredSetting settingNodeIdentifier ]! !

!AbstractStoredSetting methodsFor: 'comparing' stamp: ''!
hash
	^ self class hash bitXor: self settingNodeIdentifier hash! !

!AbstractStoredSetting methodsFor: 'testing' stamp: ''!
isForSettingNode: aSettingNode 
	^ self settingNodeIdentifier = aSettingNode settingNodeIdentifier! !

!AbstractStoredSetting methodsFor: 'loading' stamp: ''!
updateSettingNode: aSettingNode 
	| value |
	[ value := self realValue ] on: Error do: [ :exception | "ignore and leave" 
		self inform: 'Cannot read stored value of ', self settingNodeIdentifier, '. Exception: ', exception printString.
		^ self ].
	[ aSettingNode realValue: value ] on: Error do: [ :exception | "inform and ignore"
		self inform: 'Cannot update ', self settingNodeIdentifier, '. Exception: ', exception printString ]! !

!AbstractStoredSetting methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		print: self settingNodeIdentifier;
		nextPut: $)! !

!AbstractStoredSetting methodsFor: 'accessing' stamp: ''!
settingNodeIdentifier
	^ settingNodeIdentifier! !

!AbstractStoredSetting methodsFor: 'accessing' stamp: ''!
realValue
	^ self subclassResponsibility ! !

!AbstractStoredSetting methodsFor: 'accessing' stamp: ''!
settingNodeIdentifier: aString
	settingNodeIdentifier := aString! !

!AbstractStoredSetting class methodsFor: 'ston-core' stamp: ''!
stonAllInstVarNames

	^ self allInstVarNames copyWithout: #hasDefaultValue! !

!AbstractStoredSettingTest commentStamp: ''!
An AbstractStoredSettingTest is a test class for testing the behavior of AbstractStoredSetting!
!AbstractStoredSettingTest methodsFor: 'tests' stamp: ''!
testEqual
	AbstractStoredSetting allSubclassesDo: [ :aClass |
		self assert: aClass new equals: aClass new ]! !

!AbstractStoredSettingTest methodsFor: 'tests' stamp: ''!
testPrintOn2
	AbstractStoredSetting allSubclassesDo: [ :aClass | | aString |
		aString := String streamContents: [ :aStream | | anInstance |
			anInstance := aClass new.
			anInstance settingNodeIdentifier: #'print-on-identifier'.
			anInstance printOn: aStream ].
		self assert: (aString includesSubstring: #'print-on-identifier') ]! !

!AbstractStoredSettingTest methodsFor: 'tests' stamp: ''!
testHash
	AbstractStoredSetting allSubclassesDo: [ :aClass |
		self assert: aClass new hash equals: aClass new hash ]! !

!AbstractStoredSettingTest methodsFor: 'tests' stamp: ''!
testPrintOn
	AbstractStoredSetting allSubclassesDo: [ :aClass |
		String streamContents: [ :aStream | aClass new printOn: aStream ] ]! !

!AbstractTimeZone commentStamp: ''!
I am an abstract superclass for timezones.
See my subclasses for specific implementations.

Timezones are used to encapsulate the offset from the Coordinated Univeral Time (UTC) used for proper Date and Time display and manipulations.!
!AbstractTimeZone methodsFor: 'accessing' stamp: ''!
abbreviation
	^ self subclassResponsibility! !

!AbstractTimeZone methodsFor: 'accessing' stamp: ''!
name
	^ self subclassResponsibility! !

!AbstractTimeZone methodsFor: 'accessing' stamp: ''!
offset
	"Return a duration representing the offset from UTC for this timezone"
	self subclassResponsibility! !

!AbstractTimeZone methodsFor: 'printing' stamp: ''!
printOn: aStream
 
 	super printOn: aStream.
 	aStream
 		nextPut: $(;
 		nextPutAll: self abbreviation;
 		nextPut: $).! !

!AbstractTonelTest methodsFor: 'utils' stamp: ' 1/5/2022 21:01:26'!
classWithTraits

	^ classWithTraits ifNil: [
			classWithTraits := Object 
				subclass: #SomeObject 
				uses: self trait1 + self trait2
				slots:  #()
				classVariables: ''  
				poolDictionaries: '' 
				package: #'MonticelloTonel-Tests'.
			classesAndTraits add: classWithTraits.
			classWithTraits ]
		
	! !

!AbstractTonelTest methodsFor: 'running' stamp: ' 1/5/2022 21:01:26'!
tearDown 
	
	classesAndTraits reverse do: [ :aClassOrTrait | aClassOrTrait removeFromSystem ].
	super tearDown.! !

!AbstractTonelTest methodsFor: 'utils' stamp: ' 1/5/2022 21:01:26'!
classWithTraitsWithClassComposition

	^ classWithTraitsWithClassComposition ifNil: [
			classWithTraitsWithClassComposition := Object 
				subclass: #SomeObject2 
				uses: self trait1 + self trait2
				slots:  #()
				classVariables: ''  
				poolDictionaries: '' 
				package: #'MonticelloTonel-Tests'.
			classesAndTraits add: classWithTraitsWithClassComposition.
			classWithTraitsWithClassComposition class traitComposition: self trait1 classTrait + self trait2 classTrait - #m1.
			classWithTraitsWithClassComposition ]
		
	! !

!AbstractTonelTest methodsFor: 'utils' stamp: ' 1/5/2022 21:01:26'!
trait2
	
	^ trait2 ifNil: [ 
		trait2 := Trait named: #T2 uses: #() package: #'MonticelloTonel-Tests'.
		classesAndTraits add: trait2.
		trait2 ]! !

!AbstractTonelTest methodsFor: 'utils' stamp: ' 1/5/2022 21:01:26'!
trait1
	
	^ trait1 ifNil: [ 
		trait1 := Trait named: #T1 uses: #() package: #'MonticelloTonel-Tests'.
		classesAndTraits add: trait1.
		trait1 ]! !

!AbstractTonelTest methodsFor: 'running' stamp: ' 1/5/2022 21:01:26'!
setUp 
	
	super setUp.
	classesAndTraits := OrderedCollection new! !

!AbstractTool commentStamp: ''!
I'm an abstract class grouping generic methods for managing packages/classes/groups/methods from a browser!
!AbstractTool methodsFor: 'class' stamp: ''!
removeClasses: aCollection
	"Remove the selected classes from the system.  Check that the user really wants to do this, since it is not reversible.  Answer true if removal actually happened."

	| classNames classesToRemove result |
	aCollection isEmptyOrNil
		ifTrue: [ ^ false ].
	classesToRemove := aCollection collect: [:each | each instanceSide].
	classNames := (classesToRemove collect: [:each | each name]) joinUsing: ', '.
	(result := self confirm: (self removeClassesMessageFor: classNames))
		ifTrue: [ 
			classesToRemove
				do: [ :classToRemove | 
					classToRemove subclasses notEmpty
						ifTrue: [ 
							(self confirm: (self removedClassHasSubclassesMessageFor: classToRemove name))
								ifTrue: [ classToRemove removeFromSystem ] ]
						ifFalse: [ classToRemove removeFromSystem ] ] ].
	^ result! !

!AbstractTool methodsFor: 'class' stamp: ''!
removedClassHasSubclassesMessageFor: className

	^ className, ' has subclasses.
Do you really want to REMOVE it from the system ?'! !

!AbstractTool methodsFor: 'class' stamp: ''!
removeClassesMessageFor: classNames
	^ 'Are you certain that you
want to REMOVE the classes ' , classNames
		,
			'
from the system?'! !

!AbstractTool methodsFor: 'class' stamp: ''!
browseClassRefsOf: aClass

	| class |
	aClass ifNil: [ ^self ].
	class := aClass instanceSide ifNil: [^self].
	class isTrait 
		ifTrue: [self systemNavigation browseAllUsersOfTrait: class]
		ifFalse: [self systemNavigation browseAllCallsOnClass: class]
! !

!AbstractTool methodsFor: 'method' stamp: ''!
browseMessagesFrom: aSelector
	" badly named, it browses implementors "

	self getSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation with: {} selector: aSelector! !

!AbstractTool methodsFor: 'class' stamp: ''!
renameClass: aClass
	| oldName newName obs |

	aClass ifNil: [ ^ self ].
	
	oldName := aClass name.
	newName := UIManager default  request: 'Please type new class name' initialAnswer: oldName.
	newName isEmptyOrNil ifTrue: [ ^ self ].	"Cancel returns"
	newName := newName asSymbol.
	newName = oldName ifTrue: [ ^ self ].
	(self class environment includesKey: newName)
		ifTrue: [ ^ self error: newName , ' already exists' ].
	aClass rename: newName.

	obs := self systemNavigation allReferencesTo: (aClass environment associationAt: newName).
	obs isEmpty
		ifFalse: [ self systemNavigation browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName ].
	^ newName! !

!AbstractTool methodsFor: 'method' stamp: ''!
browseSendersOfMessagesFrom: aSelector
	"Present a menu of the currently selected message, as well as all messages sent by it.  Open a message set browser of all senders of the selector chosen."

	self getSelectorAndSendQuery: #browseAllSendersOf: to: self systemNavigation with: {} selector: aSelector! !

!AbstractTool methodsFor: 'method' stamp: ''!
browseVersionsFrom: aMethod
	"Create and schedule a Versions Browser, showing all versions of the 
	currently selected message. Answer the browser or nil."

	aMethod selector
		ifNil: [ self inform: 'Sorry, only actual methods have retrievable versions.'. ^nil ]
		ifNotNil: [:selector |
			Smalltalk tools versionBrowser browseVersionsForMethod: aMethod ]
				! !

!AbstractTool methodsFor: 'method' stamp: ''!
removeMethod: aMethod inClass: aClass
	"If a message is selected, create a Confirmer so the user can verify that  
	the currently selected message should be removed from the system. If 
	so, remove it. "
	| messageName confirmation |
	
	aMethod ifNil: [^ false].
	messageName := aMethod selector.
	confirmation := self systemNavigation confirmRemovalOf: messageName on: aClass.
	confirmation = 3
		ifTrue: [^ false].
	(aClass includesLocalSelector: messageName)
		ifTrue: [ aClass removeSelector: messageName ]
		ifFalse: [ self removeNonLocalSelector: messageName ].

	"In case organization not cached"
	confirmation = 2
		ifTrue: [self systemNavigation browseAllSendersOf: messageName].
		
	self removeEmptyUnclassifiedCategoryFrom: aClass.
	^ true! !

!AbstractTool methodsFor: 'class' stamp: ''!
removeClassMessageFor: className
	^ 'Are you certain that you
want to REMOVE the class ' , className
		,
			'
from the system?'! !

!AbstractTool methodsFor: 'method' stamp: ''!
browseAllStoresInto: aVariableName from: aClass 
	^self systemNavigation browseAllStoresInto: aVariableName from: aClass ! !

!AbstractTool methodsFor: 'method' stamp: ''!
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: ''!
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: 'class' stamp: ''!
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 |
	aClass ifNil: [ ^ false ].
	classToRemove := aClass instanceSide.
	className := classToRemove name.
	message := self removeClassMessageFor: className.
	(result := self confirm: message)
		ifTrue: [ 
			classToRemove subclasses notEmpty
				ifTrue: [ 
					(self confirm: 'class has subclasses: ' , message)
						ifFalse: [ ^ false ] ].
			classToRemove removeFromSystem ].
	^ result! !

!AbstractTool class methodsFor: '*Refactoring-Changes' stamp: ''!
undoLastRefactoring
	| manager |
	manager := RBRefactoryChangeManager instance.
	manager undoPointers ifNotEmpty: [
	[ |limit list| 
	list := OrderedCollection new.
	limit := manager lastUndoPointer .
	1 to: limit do:[ :i | list add: manager undoChange ].
	list do: [ :e | e execute ]
	 ] asJob
		title: 'Refactoring';
		run]
	ifEmpty: [ self inform: 'There aren''t refactorings to undo.'  ]! !

!AbstractTool class methodsFor: 'private' stamp: ''!
protocolSuggestionsFor: aClass

	| allExistingProtocols interestingProtocols reject |
	reject := Set new.
	reject
		addAll: aClass organization allCategories;
		add: AllProtocol defaultName;
		add: Protocol nullCategory;
		add: Protocol unclassified.
	allExistingProtocols := SystemNavigation default allExistingProtocolsFor: aClass isMeta not.
	
	interestingProtocols := allExistingProtocols reject: [ :e | reject includes: e ].
	^ interestingProtocols asOrderedCollection sort: [ :a :b | a asLowercase < b asLowercase ].! !

!AbstractTool class methodsFor: '*Refactoring-Changes' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #'Undo last refactoring')
				action: [self undoLastRefactoring];
				parent: #Refactoring;
				help: 'Undo last refactoring';
				order: 10;
				iconName: #smallUndo.! !

!AbstractTreeFilter commentStamp: ''!
I am an abstract class for tree filters.
My children should propose a filter for tree nodes!
!AbstractTreeFilter methodsFor: 'filtering' stamp: ''!
keepTreeNode: aNode

	^ false! !

!AbstractTutorial commentStamp: ''!
Parent class of all Pharo tutorials.

To create your own tutorial:
- subclass AbstractTutorial
- implement a few methods which returns a Lesson instance
- implement the method #tutorial which returns a collection of selectors that when executed create related lessons.

For example, see MockTutorial (minimalist) and PharoySntaxTutorial (default PharoTutorial one).

See the PharoTutorial class comment to execute your own tutorial.!
!AbstractTutorial methodsFor: 'tutorial' stamp: ''!
indexOfLesson: aSelector
	^self tutorial indexOf: aSelector.! !

!AbstractTutorial methodsFor: 'tutorial' stamp: ''!
tutorial
	"Should return an Array of selectors which returns Lesson instances.
	See SmalltalkSyntaxTutorial."
	^ self shouldBeImplemented.! !

!AbstractTutorial methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		nextPutAll: 'a Pharo Tutorial (';
		nextPutAll: self class title;
		nextPutAll: ')'.! !

!AbstractTutorial methodsFor: 'accessing' stamp: ''!
size
	^ self tutorial size! !

!AbstractTutorial methodsFor: 'accessing' stamp: ''!
lessons
	^ self tutorial collect: [:aSelector| self perform: aSelector]! !

!AbstractTutorial methodsFor: 'tutorial' stamp: ''!
lessonAt: anInteger
	| lessonSelector |
	lessonSelector := self tutorial at: anInteger.
	^ self perform: lessonSelector.! !

!AbstractTutorial class methodsFor: 'tutorial metainfo' stamp: ''!
contentsOfTutorials
	^ String
		streamContents: [ :aStream | 
			self tutorials
				do: [ :aTutorial | 
					aStream
						nextPutAll: aTutorial title;
						cr;
						tab;
						nextPutAll: 'ProfStef goOn: ';
						nextPutAll: aTutorial name;
						cr;
						cr ] ]! !

!AbstractTutorial class methodsFor: 'tutorial metainfo' stamp: ''!
tutorials
	^ (self subclasses sort: [ :a :b | a name < b name ])
		reject: [ :aTutorial | aTutorial package name = 'ProfStef-Tests' ]! !

!AbstractTutorial class methodsFor: 'tutorial metainfo' stamp: ''!
title	
	"Return the title of the tutorial by parsing the class name 	
	like a Wiki link and interspersing whitespaces between the tokens"	
	| className separators groups |	
			
	className := self name.	
	separators := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'.	
	groups := className findTokens: separators keep: separators.	
	^' ' join: (groups pairsCollect: [ :sep :rest | sep , rest ]).! !

!AbstractTutorialTest commentStamp: ''!
SUnit tests for AbstractTutorial!
!AbstractTutorialTest methodsFor: 'tests' stamp: ''!
testTutorialRaisesShouldBeImplemented
	| tutorial |
	tutorial := AbstractTutorial new.
	self 
		should: [tutorial tutorial]
		raise: Error
		withExceptionDo: [:anException | 
			self 
				assert:  ShouldBeImplemented 
				equals: anException class
		].! !

!AbstractTutorialTest methodsFor: 'tests' stamp: ''!
testTitleHumanizeClassName
	self assert: 'How To Make Your Own Tutorial' equals: HowToMakeYourOwnTutorial title.
	self assert: 'Pharo Syntax Tutorial' equals: PharoSyntaxTutorial title.! !

!AbstractTutorialTest methodsFor: 'tests' stamp: ''!
testTutorialsReturnsAllButMockTutorial
	| tutorials |
	tutorials := AbstractTutorial tutorials.
	self assert: (tutorials includes: PharoSyntaxTutorial).
	self assert: (tutorials includes: HowToMakeYourOwnTutorial).
	self deny: (tutorials includes: MockTutorial).! !

!AbstractTutorialTest methodsFor: 'tests' stamp: ''!
testLessonsReturnsAllLessonInstances
	| lessons |
	lessons := MockTutorial new lessons.
	self assert: 3 equals:lessons size.
	self assert: 'first' equals: lessons first title.
	self assert: 'second' equals: (lessons at:2 ) title.
	self assert: 'third' equals: lessons last title! !

!AbstractTwoButtons commentStamp: ''!
I am an abstract Spec widget managing two ButtonPresenter.

I provide shortcuts to set easier the buttons
-  firstIcon:secondIcon: that take two name of icon and set the buttons with the corresponding icons.
- firstLabel:secondLabel: to set labels.
- firstAction:secondAction: to set blocks to perform.

I provide two layout on my class side, vertical and horizontal.!
!AbstractTwoButtons methodsFor: 'accessing' stamp: ''!
secondButton
	^ secondButton! !

!AbstractTwoButtons methodsFor: 'accessing' stamp: ''!
firstButton
	^ firstButton! !

!AbstractTwoButtons methodsFor: 'initialization' stamp: ''!
initializeWidgets
	firstButton := self instantiate: ButtonPresenter.
	secondButton := self instantiate: ButtonPresenter.
	self initializeButtons.
	self focusOrder
		add: firstButton;
		add: secondButton! !

!AbstractTwoButtons methodsFor: 'api' stamp: ''!
firstLabel: firstLabel secondLabel: secondLabel
	self firstButton label: firstLabel.
	self secondButton label: secondLabel! !

!AbstractTwoButtons methodsFor: 'initialization' stamp: ''!
initializeButtons
self subclassResponsibility! !

!AbstractTwoButtons methodsFor: 'api' stamp: ''!
firstIcon: firstIconName secondIcon: secondIconName
	self firstButton icon: (self iconNamed: firstIconName).
	self secondButton icon: (self iconNamed: secondIconName)! !

!AbstractTwoButtons methodsFor: 'api' stamp: ''!
firstAction: firstActionBlock secondAction: secondActionBlock
	self firstButton action: firstActionBlock.
	self secondButton action: secondActionBlock! !

!AbstractTwoButtons class methodsFor: 'specs' stamp: ''!
vertical
	<spec: #default>
	^ SpecLayout composed
		newColumn: [ :column | 
			column
				add: #firstButton;
				add: #secondButton ];
		yourself! !

!AbstractTwoButtons class methodsFor: 'specs' stamp: ''!
horizontal
	<spec>
	^ SpecLayout composed
		newRow: [ :row | 
			row
				add: #firstButton;
				add: #secondButton ];
		yourself! !

!AbstractTwoButtons class methodsFor: 'examples' stamp: ''!
abstractExample
	| example |
	example := self new.
	example
		title: self name asString , ' example';
		extent: 100 @ 100.
	^ example! !

!AbstractUITestCase commentStamp: ''!
This is an abstract superclass for all tests requiring a user interface (UI). These tests are skipped when Pharo runs in headless mode!
!AbstractUITestCase methodsFor: 'running' stamp: ''!
runCase
	| result |
	"Skip the test if we're in headless mode"
	self flag: 'Use skip feature once it is ready'.
	Smalltalk isHeadless
		ifTrue: [ ^ self skip ].
	SystemProgressMorph allInstances do: [  :spm | spm hide ].
	self currentWorld activeHand resetClickState.
	result := super runCase .
	SystemProgressMorph allInstances do: [  :spm | spm show ].
	^ result! !

!AbstractUITestCase class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self == AbstractUITestCase! !

!AbstractWidgetPresenter commentStamp: ''!
AbstractBasicWidget is an abstract class for basic widgets

I collaborate with
- ValueHolder to managed some of my variables.
- ComposablePresenter to manage me with other elements.

I provide the following variables and their accessors
- enabled is a boolean representing if I am usable or not, it is true by default. It  have also shortcut enable and disable.
- help is the text displayed in the tooltip.
- borderWidth, its default value is 0, it must be called after have displayed the widget. 
- borderColor, its default value is transparent, it must be called after have displayed the widget. 

For the two methods borderWidth and borderColor, notice that some of my subclasses don't display my border

Me and my subclasses provide shortcut hook for my valueHolder, they are named "when" followed of the event.

My drag and drop system don't work well.

todo
- defaultColor
- color
- eventKeyStrokesForNextFocus
!
!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
color: aColor

	^ color value: aColor! !

!AbstractWidgetPresenter methodsFor: 'api - events' stamp: ''!
whenBorderColorChanged: aBlock
	"Set a block to be performed when the brder width changed"
	
	borderColor whenChangedDo: aBlock! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
transferFor: passenger from: source

	^ transferBlock value value: passenger value: source! !

!AbstractWidgetPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets 
	"ignore this method since there is no composition in basic widgets"! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
borderWidth
	"<api: #inspect>"
	"Return the border width"
	
	^ borderWidth value! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
defaultTransferFor: passenger from: source

	^ TransferPresenter new
		transfer: passenger;
		from: source;
		yourself! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
dragTransformationBlock

	^ dragTransformationBlock value! !

!AbstractWidgetPresenter methodsFor: '*Commander-SpecSupport' stamp: ''!
enableCommanderDragBy: presenterWithCommands

	self dragEnabled: true.
	self transferBlock: [ :items :source  | 
		self createDragTransferOf: items from: source withCommandsFrom: presenterWithCommands ].! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
borderColor: aColor
	"<api: #color getter:#borderColor registration: #whenBorderColorChanged:>"
	"Set the border width"
	
	borderColor value: aColor ! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
enabledHolder
	
	^ enabledHolder! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
dragEnabled

	^ dragEnabled value! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
dropEnabled

	^ dropEnabled value! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
enabled: aBoolean
	"<api: #boolean getter: #enabled registration: #whenEnabledChanged:>"
	"Set if the button is enabled (clickable)"
	
	enabledHolder value: aBoolean! !

!AbstractWidgetPresenter methodsFor: 'api - focus' stamp: ''!
eventKeyStrokesForNextFocus
	"String describing the keystroke to perform to jump to the next widget"
	
	^ { Character arrowRight asKeyCombination. Character tab asKeyCombination}! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
borderColor
	"<api: #inspect>"
	"Return the border color"
	
	^ borderColor value! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
wantDropBlock: aBlock

	wantDropBlock value: aBlock! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
help
	"<api: #inspect>"
	"Return the ballon text"
	
	^ helpHolder value! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
dragTransformationBlock: aBlock

	dragTransformationBlock value: aBlock! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
acceptDroppingMorph: draggedMorph event: event inMorph: source

	^ self acceptDropBlock cull: draggedMorph model model cull: event cull: source cull: source model 
! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
borderWidth: anInteger
	"<api: #integer min:0 max: 5 getter:#borderWidth registration: #whenBorderWidthChanged:>"
	"Set the border width"
	
	borderWidth value: anInteger! !

!AbstractWidgetPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	helpHolder := nil asValueHolder.
	borderWidth := 0 asValueHolder.
	borderColor := Color transparent asValueHolder.
	enabledHolder := true asValueHolder.
	dragEnabled := false asValueHolder.
	dropEnabled := false asValueHolder.
	dragTransformationBlock := [ :item :source | item ] asValueHolder.
	wantDropBlock := [ :draggedItem :event :source | self dropEnabled ] asValueHolder.
	acceptDropBlock := [ :draggedItem :event :source | ] asValueHolder.
	transferBlock := [:passenger :source | self defaultTransferFor: passenger from: source ] asValueHolder.
	color := self defaultColor asValueHolder.
	
	helpHolder whenChangedDo: [:string | 
		self widget ifNotNil: [:w | w update: #setBalloonText: with: { string } ] ].
	
	borderWidth whenChangedDo: [:int | 
		self widget ifNotNil: [:w | w update: #borderWidth: with: { int } ] ].
	
	borderColor whenChangedDo: [:newColor | 
		self widget ifNotNil: [:w | w update: #borderColor: with: { newColor } ] ].
	
	color whenChangedDo: [:newColor | 
		self widget ifNotNil: [:w | w update: #color: with: { newColor } ] ].
	
	enabledHolder whenChangedDo: [:b |
		self widget ifNotNil: [:w | w update: #enabled: with: { b } ] ].
	
	dragEnabled whenChangedDo: [:b |
		self widget ifNotNil: [:w | w update: #dragEnabled: with: { b } ] ].
	
	dropEnabled whenChangedDo: [:b |
		self widget ifNotNil: [:w | w update: #dropEnabled: with: { b } ] ].! !

!AbstractWidgetPresenter methodsFor: 'api - events' stamp: ''!
whenEnabledChanged: aBlock
	"Set a block to performed when the widget is enabled or disabled"
	
	enabledHolder whenChangedDo: aBlock! !

!AbstractWidgetPresenter methodsFor: '*Commander-SpecSupport' stamp: ''!
createDragTransferOf: items from: source withCommandsFrom: presenterWithCommands

	| commandPassenger itemPassenger |
	commandPassenger := CmdDragAndDropActivation 
		createDragPassengerInContext: presenterWithCommands createCommandContext.
	itemPassenger := CmdSpecDragPassenger from: source model on: commandPassenger with: items.
	^self defaultTransferFor: itemPassenger from: source! !

!AbstractWidgetPresenter methodsFor: '*Commander-SpecSupport' stamp: ''!
enableCommanderDragAndDropBy: presenterWithCommands

	self enableCommanderDragBy: presenterWithCommands.
	self enableCommanderDropBy: presenterWithCommands! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
disable
	"<api: #do>"
	"Disable the label"
	
	self enabled: false! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
help: aString
	"<api: #string getter:#help registration: #whenHelpChanged:>"
	"Set the help string"
	
	helpHolder value: aString! !

!AbstractWidgetPresenter methodsFor: 'api - events' stamp: ''!
whenBorderWidthChanged: aBlock
	"Set a block to be performed when the brder width changed"
	
	borderWidth whenChangedDo: aBlock! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
enable
	"<api: #do>"
	"Enable the label"
	
	self enabled: true! !

!AbstractWidgetPresenter methodsFor: '*Commander-SpecSupport' stamp: ''!
enableCommanderDropBy: aPresenter

	self dropEnabled: true.
	self wantDropBlock: [ :draggedItem :event :source | 
		draggedItem canBeDroppedInContext: aPresenter createCommandContext ].
	self acceptDropBlock: [ :transfer :event :receiverMorph :receiverPresenter  | 
		transfer passenger dropInContext: (receiverMorph createCommandContextBy: aPresenter forDropAt: event)].! !

!AbstractWidgetPresenter methodsFor: 'api - events' stamp: ''!
whenHelpChanged: aBlock
	"Set a block to be performed when the help changed"
	
	helpHolder whenChangedDo: aBlock! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
dropEnabled: aBoolean

	dropEnabled value: aBoolean! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
enabled
	"<api: #inspect>"
	^ enabledHolder value! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
dragEnabled: anObject

	dragEnabled value: anObject! !

!AbstractWidgetPresenter methodsFor: 'api - focus' stamp: ''!
eventKeyStrokesForPreviousFocus
	"String describing the keystroke to perform to jump to the next widget"
	
	^ { Character arrowLeft asKeyCombination. Character tab shift asKeyCombination}! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
acceptDropBlock

	^ acceptDropBlock value! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
transferBlock: aBlock

	transferBlock value: aBlock! !

!AbstractWidgetPresenter methodsFor: 'initialization' stamp: ''!
defaultColor
	^ self theme backgroundColor! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
acceptDropBlock: aBlock

	acceptDropBlock value: aBlock! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
wantDropBlock

	^ wantDropBlock value! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
transferBlock

	^ transferBlock value! !

!AbstractWidgetPresenter methodsFor: 'api' stamp: ''!
color

	^ color value! !

!AbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
wantsDroppedMorph: draggedMorph event: anEvent inMorph: source
	draggedMorph isTransferable ifFalse: [ ^false ].
	
	^wantDropBlock value cull: draggedMorph passenger cull: anEvent cull:source! !

!AbstractWidgetPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ { self adapterName. #adapt:. #model }! !

!AbstractWidgetPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ self subclassResponsibility! !

!AbstractWorldRenderer commentStamp: ''!
I implement the logic to render a world.
I have different implementations to start the world.!
!AbstractWorldRenderer methodsFor: 'rendering' stamp: ''!
updateDamage: rectangles

	self subclassResponsibility! !

!AbstractWorldRenderer methodsFor: 'testing' stamp: ''!
isProfilingRenderingTime
	^ self class isProfilingRenderingTime! !

!AbstractWorldRenderer methodsFor: 'events' stamp: ''!
checkForNewScreenSize

	self subclassResponsibility! !

!AbstractWorldRenderer methodsFor: 'accessing' stamp: ''!
world
	^ world! !

!AbstractWorldRenderer methodsFor: 'activation' stamp: ''!
activate

	alreadyActivated ifTrue: [ 
		"Maybe I need to change the title of the window after saving the image"
		^ self updateWindowTitle ].

	self doActivate.
	alreadyActivated := true! !

!AbstractWorldRenderer methodsFor: 'accessing' stamp: ''!
icon: aForm 

	self subclassResponsibility! !

!AbstractWorldRenderer methodsFor: 'operations' stamp: ''!
deferUpdates: aBoolean

	^ false! !

!AbstractWorldRenderer methodsFor: 'activation' stamp: ''!
updateWindowTitle

	"I do nothing... maybe my subclasses extend it"! !

!AbstractWorldRenderer methodsFor: 'rendering' stamp: ''!
deferUpdatesDuring: aBlock

	^ aBlock value! !

!AbstractWorldRenderer methodsFor: 'initialization' stamp: ''!
initialize

	alreadyActivated := false! !

!AbstractWorldRenderer methodsFor: 'activation' stamp: ''!
doActivate

	self subclassResponsibility! !

!AbstractWorldRenderer methodsFor: 'operations' stamp: ''!
restoreMorphicDisplay 

	world
		extent: self actualScreenSize;
		viewBox: self viewBox;
		handsDo: [:h | h visible: true; showTemporaryCursor: nil];
		resizeBackgroundMorph;
		submorphsDo: [ :each | each displayExtentChanged ];
		fullRepaintNeeded.
		
	world defer: [Cursor normal show].
		
	world layoutChanged.! !

!AbstractWorldRenderer methodsFor: 'rendering' stamp: ''!
drawDuring: aBlock

	self subclassResponsibility! !

!AbstractWorldRenderer methodsFor: 'display box access' stamp: ''!
viewBox 

	^ 0@0 corner: self actualScreenSize! !

!AbstractWorldRenderer methodsFor: 'accessing' stamp: ''!
usableArea

	^ self viewBox! !

!AbstractWorldRenderer methodsFor: 'profiling' stamp: ''!
logRenderingTimeMeasurements: measurements
	self class logRenderingTimeMeasurements: measurements! !

!AbstractWorldRenderer methodsFor: 'utilities' stamp: ''!
convertWindowMouseEventPosition: aPosition

	self subclassResponsibility! !

!AbstractWorldRenderer methodsFor: 'accessing' stamp: ''!
world: anObject
	world := anObject! !

!AbstractWorldRenderer methodsFor: 'activation' stamp: ''!
actualScreenSize

	self subclassResponsibility! !

!AbstractWorldRenderer methodsFor: 'rendering' stamp: ''!
invalidate
	"Invalidate the entire render"
	"Each subclass should define me properly"! !

!AbstractWorldRenderer methodsFor: 'accessing' stamp: ''!
windowTitle: aString

	self subclassResponsibility! !

!AbstractWorldRenderer methodsFor: 'profiling' stamp: ''!
formatRenderingTimeMeasurement: measurement

	^ '[{1}]{2}: {3} ms' format: { 
			  self class name.
			  measurement key.
			  (measurement value printPaddedWith: Character space to: 5) }! !

!AbstractWorldRenderer methodsFor: 'events' stamp: ''!
updateToNewResolution

	self subclassResponsibility! !

!AbstractWorldRenderer methodsFor: 'rendering' stamp: ''!
displayWorldState: aWorldState ofWorld: aWorld
	"Update this world's display."

	| submorphs |
	submorphs := aWorld submorphs.

	"force re-layout if needed"
	submorphs do: [ :m | m fullBounds ].

	"display is already up-to-date"
	aWorldState checkIfUpdateNeeded
		ifFalse: [ ^ self ].

	self deferUpdatesDuring: [
		self drawDuring: [ :aMorphicCanvas | | worldDamageRects handDamageRects allDamage handsToDraw |
			worldDamageRects := aWorldState drawWorld: aWorld submorphs: submorphs invalidAreasOn: aMorphicCanvas.

			"repair world's damage on canvas"
			handsToDraw := aWorldState selectHandsToDrawForDamage: worldDamageRects.
			handDamageRects := handsToDraw collect: [:h | h savePatchFrom: aMorphicCanvas].
			allDamage := worldDamageRects, handDamageRects.

			"draw hands onto world canvas"
			handsToDraw reverseDo: [:h | aMorphicCanvas fullDrawMorph: h].

			"*make this true to flash damaged areas for testing*"
			WorldState debugShowDamage ifTrue: [aWorld flashRects: allDamage color: Color black].

			aMorphicCanvas finish.
			self updateDamage: allDamage.

			"restore world canvas under hands"
	 		handsToDraw do: [:h | h restoreSavedPatchOn: aMorphicCanvas ].
		] ]! !

!AbstractWorldRenderer methodsFor: 'activation' stamp: ''!
deactivate

	self subclassResponsibility! !

!AbstractWorldRenderer class methodsFor: 'testing' stamp: ''!
isApplicableFor: aWorld

	^ self subclassResponsibility! !

!AbstractWorldRenderer class methodsFor: 'class initialization' stamp: ''!
initialize

	SessionManager default registerSystemClassNamed: self name! !

!AbstractWorldRenderer class methodsFor: 'system startup' stamp: ''!
shutDown: quitting

	quitting ifFalse: [ ^ self ].

	[ MainWorldRenderer ifNotNil: [ :e | e deactivate ] ] ensure: [ 
		MainWorldRenderer := nil ]! !

!AbstractWorldRenderer class methodsFor: 'profiling - testing' stamp: ''!
isLoggingRenderingProfileToFile: aBoolean

	IsLoggingRenderingProfileToFile := aBoolean.
	IsLoggingRenderingProfileToFile ifFalse: [ self closeRenderingProfileLogFile ]! !

!AbstractWorldRenderer class methodsFor: 'instance creation' stamp: ''!
forWorld: aWorld

	^ self new
		  world: aWorld;
		  yourself! !

!AbstractWorldRenderer class methodsFor: 'profiling' stamp: ''!
closeRenderingProfileLogFile

	RenderingProfilingLogOutput ifNotNil: [ 
		RenderingProfilingLogOutput close.
		RenderingProfilingLogOutput := nil ]! !

!AbstractWorldRenderer class methodsFor: 'accessing' stamp: ''!
detectCorrectOneForWorld: aWorld

	| aRenderer |
	MainWorldRenderer ifNotNil: [ ^ MainWorldRenderer ].

	(self allSubclasses sorted: [ :a :b | a priority > b priority ])
		detect: [ :aClass | aClass isApplicableFor: aWorld ]
		ifFound: [ :aClass | aRenderer := aClass forWorld: aWorld ].

	^ MainWorldRenderer := aRenderer! !

!AbstractWorldRenderer class methodsFor: 'profiling - testing' stamp: ''!
isProfilingRenderingTime: aBoolean
	"
	self isProfilingRenderingTime: true.
	self isProfilingRenderingTime: false.
	"

	IsProfilingRenderingTime := aBoolean.
	IsProfilingRenderingTime ifFalse: [ self closeRenderingProfileLogFile ]! !

!AbstractWorldRenderer class methodsFor: 'profiling - testing' stamp: ''!
isProfilingRenderingTime

	^ IsProfilingRenderingTime ifNil: [ IsProfilingRenderingTime := false ]! !

!AbstractWorldRenderer class methodsFor: 'profiling' stamp: ''!
logRenderingTimeMeasurements: measurements
	self isLoggingRenderingProfileToFile ifFalse: [ ^ self ].
	RenderingProfilingLogOutput ifNil: [
		RenderingProfilingLogOutput := (FileSystem workingDirectory / 'rendering-profile-log.csv') writeStream.
		RenderingProfilingLogOutput truncate.
		RenderingProfilingLogOutput nextPutAll: 'Class,Measurement,Time'; lf.
	].
	measurements do: [ :each |
		RenderingProfilingLogOutput nextPutAll: self name asString;
			nextPut: $,; nextPutAll: each key asString;
			nextPut: $,; nextPutAll: each value asString;
			lf
	]! !

!AbstractWorldRenderer class methodsFor: 'accessing' stamp: ''!
priority 

	^ 0! !

!AbstractWorldRenderer class methodsFor: 'profiling' stamp: ''!
startProfilingRenderingTime
	<script>
	
	self isProfilingRenderingTime: true! !

!AbstractWorldRenderer class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self == AbstractWorldRenderer! !

!AbstractWorldRenderer class methodsFor: 'profiling' stamp: ''!
stopProfilingRenderingTime
	<script>
	
	self isProfilingRenderingTime: false! !

!AbstractWorldRenderer class methodsFor: 'accessing' stamp: ''!
mainWorldRenderer

	^ MainWorldRenderer! !

!AbstractWorldRenderer class methodsFor: 'system startup' stamp: ''!
startUp: isANewSession

	isANewSession ifTrue: [ MainWorldRenderer := nil ]! !

!AbstractWorldRenderer class methodsFor: 'profiling' stamp: ''!
enableRenderingProfileLogFile
	<script>
	
	self isLoggingRenderingProfileToFile: true! !

!AbstractWorldRenderer class methodsFor: 'profiling - testing' stamp: ''!
isLoggingRenderingProfileToFile

	^ IsLoggingRenderingProfileToFile ifNil: [ IsLoggingRenderingProfileToFile := false ]! !

!AbstractWorldRenderer class methodsFor: 'profiling' stamp: ''!
disableRenderingProfileLogFile
	<script>
	
	self isLoggingRenderingProfileToFile: false! !

!AccessorInstanceVariableSlot commentStamp: ''!
NOTE: this is an example of what can be done with Slots. It is *not* an example of what *should* be done with Slots.

I am a slot that compiles accessor methods in the Class that it is installed in.

This example shows how Slots can change the class that they are part of.!
!AccessorInstanceVariableSlot methodsFor: 'class building' stamp: ''!
installingIn: aClass
	| reader writer | 
	
	reader := String streamContents: [ :str |
		str 
			nextPutAll: self name;
			cr;tab;
			nextPutAll: ' ^';
			nextPutAll: self name.
		 ].
	writer := String streamContents: [ :str |
		str 
			nextPutAll: self name;
			nextPutAll: ': anObject';
			cr;tab;
			nextPutAll: self name;
			nextPutAll: ':= anObject.'.
		].
	aClass compile: reader classified: 'accessing'.
	aClass compile: writer classified: 'accessing'.! !

!AccessorInstanceVariableSlotTest commentStamp: ''!
This class is the place for tests related to the Slot examples. 
(some examples have their own test class, the rest is here)!
!AccessorInstanceVariableSlotTest methodsFor: 'tests' stamp: ''!
testAccessorInstanceVariableSlot
	| slot object |
	aClass := self
		make:
			[ :builder | builder slots: {(#slot1 => AccessorInstanceVariableSlot)} ].
	self assert: (aClass hasSlotNamed: #slot1).

	"test reflective write and read"
	slot := aClass slotNamed: #slot1.
	object := aClass new.
	slot write: 5 to: object.
	self assert: (slot read: object) equals: 5.
	object slot1: 10.
	self assert: object slot1 equals: 10.
	
	"did we create accessors?"
	self assert: (aClass includesSelector: #slot1).
	self assert: (aClass includesSelector: #slot1:)! !

!ActiveClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testIncludeOnlyInstancesWhichAreActiveForGivenUser

	| actual annotationUser expected |
	annotationUser := AnnotationUserExample new.
	annotationUser isSimulatedActiveAnnotation: true. 
	
	actual := ContextualClassAnnotationExample1 activeInstancesInContext: annotationUser.
	
	expected := ContextualClassAnnotationExample1 visibleInstancesInContext: annotationUser.	
	self assert: actual asSet equals: expected asSet! !

!ActiveClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testNotIncludeInstancesWithoutContext

	| annotations annotationUser |
	annotationUser := AnnotationUserExample new.
	annotations := ClassAnnotationExample1 activeInstancesInContext: annotationUser.
	
	self assert: annotations isEmpty! !

!ActiveClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testNotIncludeInstancesWhichAreNotActiveForGivenUser

	| actual annotationUser |
	annotationUser := AnnotationUserExample new.
	annotationUser isSimulatedActiveAnnotation: false. 
	
	actual := ContextualClassAnnotationExample1 activeInstancesInContext: annotationUser.
	
	self assert: actual isEmpty! !

!ActiveClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testCanBeEnumeratedForGivenUser

	| annotationUser actual expected |
	annotationUser := AnnotationUserExample new.
	actual := OrderedCollection new.
	ContextualClassAnnotationExample1 activeInstancesInContext: annotationUser do: [:each | 
		actual add: each].
	expected := ContextualClassAnnotationExample1 activeInstancesInContext: annotationUser.

	self assert: actual asSet equals: expected asSet.! !

!ActiveClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testCanBeEnumeratedForGivenClassAndUser

	| annotationUser actual expected |
	annotationUser := AnnotationUserExample new.
	actual := OrderedCollection new.
	ContextualClassAnnotationExample1 
		activeInstancesFor: ClassWithAnnotationsDefinedForUserClass inContext: annotationUser 
		do: [:each | actual add: each].
	expected := ContextualClassAnnotationExample1 activeInstancesInContext: annotationUser.

	self assert: actual asSet equals: expected asSet! !

!ActiveMetaContext commentStamp: ''!
I am a process local variable that stores the currently active meta level !
!AdditionalBinding commentStamp: ''!
When handing over a dictionary with additonal binding to the compiler:

	 Smalltalk compiler
        bindings: {(#test -> Point)} asDictionary;
        evaluate: 'test := 42'.

all associations are changed to be AdditionaBinding.

AddionalBinding is used, too, by both Slots and Reflectivity to reference directly objects from generated code.!
!AdditionalBinding methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder

	methodBuilder storeIntoLiteralVariable: self.! !

!AdditionalBinding methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder

	methodBuilder pushLiteralVariable: self! !

!AdditionalBinding methodsFor: 'testing' stamp: ''!
isReferenced
	^ false! !

!AdditionalMethodState commentStamp: ''!
I am class holding state for compiled methods. All my instance variables should be actually part of the CompiledMethod itself, but the current implementation of the VM doesn't allow this.  Currently I hold the selector and any pragmas or properties the compiled method has.  Pragmas and properties are stored in indexable fields; pragmas as instances of Pragma, properties as instances of Association.
I am a reimplementation of much of MethodProperties, but eliminating the explicit properties and pragmas dictionaries.  Hence I answer true to isMethodProperties.!
!AdditionalMethodState methodsFor: 'properties' stamp: ''!
propertyAt: aKey
	"Answer the property value associated with aKey."
	
	^ self propertyAt: aKey ifAbsent: [ self error: 'Property not found' ].! !

!AdditionalMethodState methodsFor: 'testing' stamp: ''!
isEmpty
	^self basicSize = 0! !

!AdditionalMethodState methodsFor: 'testing' stamp: ''!
includes: aPropertyOrPragma "<Association|Pragma>"
	"Test if the property or pragma is present."

	1 to: self basicSize do:
		[:i |
		(self basicAt: i) = aPropertyOrPragma ifTrue:
			[^true]].
	^false! !

!AdditionalMethodState methodsFor: 'properties' stamp: ''!
includesProperty: aKey
	"Test if the property aKey is present."

	1 to: self basicSize do: [:i |
		| propertyOrPragma "<Association|Pragma>" |
		propertyOrPragma := self basicAt: i.
		(propertyOrPragma isAssociation
		 and: [propertyOrPragma key == aKey]) ifTrue:
			[^true]].
	^false! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
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: 'copying' stamp: ''!
copyWithout: aPropertyOrPragma "<Association|Pragma>"
	"Answer a copy of the receiver which no longer includes aPropertyOrPragma"
	| bs copy offset |
	"no need to initialize here; we're copying all inst vars"
	copy := self class basicNew: (bs := self basicSize) - ((self includes: aPropertyOrPragma)
															ifTrue: [1]
															ifFalse: [0]).
	offset := 0.
	1 to: bs do:
		[:i|
		(self basicAt: i) = aPropertyOrPragma
			ifTrue: [offset := 1]
			ifFalse: [copy basicAt: i - offset put: (self basicAt: i) shallowCopy]].
	1 to: self class instSize do:
		[:i| copy instVarAt: i put: (self instVarAt: i)].
	^copy! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
setMethod: aMethod
	method := aMethod.
	1 to: self basicSize do: [ :i | 
		| propertyOrPragma	"<Association|Pragma>" |
		(propertyOrPragma := self basicAt: i) isAssociation
			ifFalse: [ propertyOrPragma method: aMethod ] ]! !

!AdditionalMethodState methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream space; nextPut: $(; print: self identityHash; nextPut: $)! !

!AdditionalMethodState methodsFor: 'testing' stamp: ''!
analogousCodeTo: aMethodProperties
	| bs |
	self class == aMethodProperties class ifFalse:
		[^false].
	(bs := self basicSize) = aMethodProperties basicSize ifFalse:
		[^false].
	1 to: bs do:
		[:i|
		((self basicAt: i) analogousCodeTo: (aMethodProperties basicAt: i)) ifFalse:
			[^false]].
	^true! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
at: aKey
	"Answer the property value or pragma associated with aKey."
	
	^self at: aKey ifAbsent: [self error: 'not found']! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
keysAndValuesDo: aBlock
	"Enumerate the receiver with all the keys and values."

	1 to: self basicSize do: [:i |
		| propertyOrPragma "<Association|Pragma>" |
		(propertyOrPragma := self basicAt: i) isAssociation
			ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value]
			ifFalse: [aBlock value: propertyOrPragma selector value: propertyOrPragma]]! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
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 "<Association|Pragma>" |
		(propertyOrPragma := self basicAt: i) key == aKey ifTrue:
			[^propertyOrPragma isAssociation
				ifTrue: [propertyOrPragma value]
				ifFalse: [propertyOrPragma]]].
	^aBlock value! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
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 "<Association|Pragma>" |
		(propertyOrPragma := self basicAt: i) key == aKey ifTrue:
			[^propertyOrPragma isAssociation
				ifTrue: [propertyOrPragma value]
				ifFalse: [propertyOrPragma]]].
	^method propertyAt: aKey put: aBlock value! !

!AdditionalMethodState methodsFor: 'properties' stamp: ''!
propertyAt: 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 "<Association|Pragma>" |
		propertyOrPragma := self basicAt: i.
		(propertyOrPragma isAssociation
		 and: [propertyOrPragma key == aKey]) ifTrue:
			[^propertyOrPragma value]].
	^aBlock value! !

!AdditionalMethodState methodsFor: 'properties-compatibility' stamp: ''!
propertyValueAt: aKey ifAbsent: aBlock
	"use the version without ..Value, this methid is retained for compatibility"
	^self propertyAt: aKey ifAbsent: aBlock! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
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 "<Association|Pragma>" |
		propertyOrPragma := self basicAt: i.
		(propertyOrPragma isAssociation
				ifTrue: [propertyOrPragma key]
				ifFalse: [propertyOrPragma selector])
			== aKey ifTrue:
			[^method removeProperty: aKey]].
	^aBlock value! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
method

	^method.! !

!AdditionalMethodState methodsFor: 'properties' stamp: ''!
propertyKeysAndValuesDo: aBlock
	"Enumerate the receiver with all the keys and values."

	1 to: self basicSize do: [:i |
		| propertyOrPragma "<Association|Pragma>" |
		(propertyOrPragma := self basicAt: i) isAssociation ifTrue:
			[aBlock value: propertyOrPragma key value: propertyOrPragma value]]! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
selector
	^selector! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
at: aKey put: aValue
       "Replace the property value or pragma associated with aKey."
       | keyAlreadyExists |
       keyAlreadyExists := false.

       1 to: self basicSize do:
               [:i |
               | propertyOrPragma "<Association|Pragma>" |
               (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [
                       keyAlreadyExists := true.
                       propertyOrPragma isAssociation
                               ifTrue: [propertyOrPragma value: aValue]
                               ifFalse: [self basicAt: i put: aValue]]].

       keyAlreadyExists ifFalse: [
               method propertyAt: aKey put: aValue ].

       ^ aValue! !

!AdditionalMethodState methodsFor: 'copying' stamp: ''!
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: '*Reflectivity' stamp: ''!
metaLinkOptions
	^{
	#selector -> #( + optionCompileOnLinkInstallation).
	#isMethodProperties -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!AdditionalMethodState methodsFor: 'properties-compatibility' stamp: ''!
propertyValueAt: aKey
	"use the version without ..Value, this methid is retained for compatibility"
	
	^ self propertyAt: aKey! !

!AdditionalMethodState methodsFor: 'enumerating' stamp: ''!
pragmasDo: aBlock
	
	1 to: self basicSize do: [ :i | 
		| propertyOrPragma	"<Association|Pragma>" |
		propertyOrPragma := self basicAt: i.
		propertyOrPragma isAssociation
			ifFalse: [ aBlock value: propertyOrPragma ] ]! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
selector: aSymbol
	selector := aSymbol! !

!AdditionalMethodState methodsFor: 'copying' stamp: ''!
copyWith: aPropertyOrPragma "<Association|Pragma>"
	"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: 'properties' stamp: ''!
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: 'accessing' stamp: ''!
properties

	| propertyStream |
	propertyStream := WriteStream on: (Array new: self basicSize * 2).
	1 to: self basicSize do: [:i |
		| propertyOrPragma "<Association|Pragma>" |
		(propertyOrPragma := self basicAt: i) isAssociation ifTrue:
			[propertyStream nextPut: propertyOrPragma key; nextPut: propertyOrPragma value]].
	^IdentityDictionary newFromPairs: propertyStream contents! !

!AdditionalMethodState methodsFor: 'decompiling' stamp: ''!
method: aMethodNodeOrNil
	"For decompilation"
	method := aMethodNodeOrNil! !

!AdditionalMethodState methodsFor: 'testing' stamp: ''!
notEmpty
	^self basicSize > 0! !

!AdditionalMethodState methodsFor: 'accessing' stamp: ''!
pragmas
	"Return the Pragma objects. Properties are stored as Associations"
	^ Array new: self basicSize streamContents: [ :pragmaStream | 
		  1 to: self basicSize do: [ :i | 
			  | propertyOrPragma "<Association|Pragma>" |
			  (propertyOrPragma := self basicAt: i) isAssociation ifFalse: [ 
				  pragmaStream nextPut: propertyOrPragma ] ] ]! !

!AdditionalMethodState methodsFor: 'testing' stamp: ''!
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: ''!
isMethodProperties
	^true! !

!AdditionalMethodState class methodsFor: 'instance creation' stamp: ''!
forSelector: aSelector
	^(self new: 0)
		selector: aSelector;
		yourself! !

!AdditionalMethodState class methodsFor: 'instance creation' stamp: ''!
new
	^ self new: 0! !

!AdditionalMethodState class methodsFor: 'instance creation' stamp: ''!
selector: aSelector with: aPropertyOrPragma
	^(self new: 1)
		selector: aSelector;
		basicAt: 1 put: aPropertyOrPragma;
		yourself! !

!AdditionalMethodState class methodsFor: 'instance creation' stamp: ''!
forMethod: aMethod selector: aSelector
	^(self new: 0)
		selector: aSelector;
		setMethod: aMethod;
		yourself! !

!AdditionalMethodStateTest commentStamp: ''!
SUnit tests for AdditionalMethodState!
!AdditionalMethodStateTest methodsFor: 'tests' stamp: ''!
testAnalogousCodeTo
	"create a fake traitSource association property"
	| state |
	state := AdditionalMethodState new: 1.
	state 
		basicAt: 1
		put: #traitSource -> TSortable.
		
	self 
		shouldnt: [ state analogousCodeTo: state ]
		raise: MessageNotUnderstood! !

!AdditionalMethodStateTest methodsFor: 'tests' stamp: ''!
testCopy
	| copy |
	copy := amState copy.

	self deny: amState identicalTo: copy.
	self assert: amState method identicalTo: copy method.
	self assert: amState selector identicalTo: copy selector.

	self assert: amState pragmas equals: copy pragmas.
	self assert: amState properties equals: copy properties.

	amState pragmas withIndexDo: [ :el :index | self deny: el identicalTo: (copy pragmas at: index) ]! !

!AdditionalMethodStateTest methodsFor: 'running' stamp: ''!
setUp

	| pragma |
	super setUp.
	pragma := (Object compiledMethodAt: #at:) penultimateLiteral at: #primitive:.
	
	amState := AdditionalMethodState selector: #at: with: pragma copy.! !

!Adler32 commentStamp: ''!
The Adler32 checksum algorithm was developed by Mark Adler for his ZLib algorithm. It is defined in IETF RFC 1950: http://tools.ietf.org/html/rfc1950#page-10.

The purpose of this class is mainly grouping as the ZipPlugin already implements Adler32. See also the comment in #update:from:to:in:

Note that Adler32 is not a CRC, strictly speaking.!
!Adler32 class methodsFor: 'primitives' stamp: ''!
update: adler from: start to: stop in: aCollection
	"Update crc using the Adler32 checksum technique from RFC1950"
"
        unsigned long s1 = adler & 0xffff;
        unsigned long s2 = (adler >> 16) & 0xffff;
        int n;

        for (n = 0; n < len; n++) {
          s1 = (s1 + buf[n]) % BASE;
          s2 = (s2 + s1)     % BASE;
        }
        return (s2 << 16) + s1;
"
	<primitive: 'primitiveUpdateAdler32' module: 'ZipPlugin'>
	
	| s1 s2 |
	s1 := adler bitAnd: 16rFFFF.
	s2 := (adler bitShift: -16) bitAnd: 16rFFFF.
	start to: stop do: [ :n | | b |
		b := aCollection byteAt: n.
		s1 := (s1 + b) \\ 65521.
		s2 := (s2 + s1) \\ 65521. ].
	^(s2 bitShift: 16) + s1! !

!AdvancedHelpBrowserDummy commentStamp: ''!
This is a dummy for a custom Help browser that can be registered as a replacement for the HelpBrowser class.

Instance Variables
	rootTopic:		<HelpTopic>

rootTopic
	- The root help topic
!
!AdvancedHelpBrowserDummy methodsFor: 'initialization' stamp: ''!
initialize
	isOpen := false! !

!AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: ''!
open
	isOpen := true! !

!AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: ''!
rootTopic
	^rootTopic! !

!AdvancedHelpBrowserDummy methodsFor: 'testing' stamp: ''!
isOpen
	^isOpen! !

!AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: ''!
rootTopic: aTopic
	rootTopic := aTopic! !

!AlertDialogWindow commentStamp: ''!
Message dialog with a warning icon.!
!AlertDialogWindow methodsFor: 'visual properties' stamp: ''!
icon
	"Answer an icon for the receiver."

	^ self iconNamed: #warningIcon! !

!AlertDialogWindow class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^ #smallWarningIcon! !

!AlignmentMorph commentStamp: ''!
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: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!AlignmentMorph methodsFor: 'adding' stamp: ''!
addARowCentered: aCollectionOfMorphs

	^(self addARow: aCollectionOfMorphs)
		hResizing: #shrinkWrap;
		wrapCentering: #center;
		cellPositioning: #leftCenter! !

!AlignmentMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!AlignmentMorph methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	self
		layoutPolicy: TableLayout new;
		listDirection: #leftToRight;
	 	wrapCentering: #topLeft;
	 	hResizing: #spaceFill;
	 	vResizing: #spaceFill;
	 	layoutInset: 2;
	 	rubberBandCells: true! !

!AlignmentMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!AlignmentMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!AlignmentMorph methodsFor: 'adding' stamp: ''!
addAColumn: aCollectionOfMorphs

	| col |
	col := self class inAColumn: aCollectionOfMorphs.
	self addMorphBack: col.
	^col! !

!AlignmentMorph methodsFor: 'visual properties' stamp: ''!
setAsSpacer: aColor

	self hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 0;
		extent: 1@1;
		color: aColor.! !

!AlignmentMorph methodsFor: 'visual properties' stamp: ''!
setAsRow

	self
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		borderWidth: 0! !

!AlignmentMorph methodsFor: 'adding' stamp: ''!
addARow: aCollectionOfMorphs

	| row |
	row := self class inARow: aCollectionOfMorphs.
	self addMorphBack: row.
	^row! !

!AlignmentMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	"answer the default border width for the receiver"
	
	^ 0! !

!AlignmentMorph methodsFor: 'opening' stamp: ''!
openInWindowLabeled: aString inWorld: aWorld

	self layoutInset: 0.
	^super openInWindowLabeled: aString inWorld: aWorld.! !

!AlignmentMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!AlignmentMorph methodsFor: 'visual properties' stamp: ''!
setAsColumn

	self 
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		extent: 1@1;
		vResizing: #spaceFill! !

!AlignmentMorph methodsFor: 'visual properties' stamp: ''!
inARow: aCollectionOfMorphs 

	 self setAsRow 
				color: Color transparent;
				vResizing: #shrinkWrap;
				hResizing: #shrinkWrap;
				layoutInset: 1;
				wrapCentering: #center;
				cellPositioning: #leftCenter.
	aCollectionOfMorphs
		do: [ :each | self addMorphBack: each].! !

!AlignmentMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!AlignmentMorph methodsFor: 'visual properties' stamp: ''!
inAColumn: aCollectionOfMorphs

	self setAsColumn
			color: Color transparent;
			vResizing: #shrinkWrap;
			hResizing: #shrinkWrap;
			layoutInset: 1;
			wrapCentering: #center;
			cellPositioning: #topCenter.
	aCollectionOfMorphs do: [ :each | self addMorphBack: each ].
	^ self! !

!AlignmentMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	
	^ Color
		r: 0.8
		g: 1.0
		b: 0.8! !

!AlignmentMorph methodsFor: 'visual properties' stamp: ''!
inARightColumn: aCollectionOfMorphs 
	
	self setAsColumn 
				 vResizing: #shrinkWrap;
				 layoutInset: 1;
				 wrapCentering: #bottomRight;
				 cellPositioning: #topCenter.
	aCollectionOfMorphs
		do: [ :each | self addMorphBack: each ].! !

!AlignmentMorph methodsFor: 'adding' stamp: ''!
addARowCentered: aCollectionOfMorphs cellInset: cellInsetInteger

	^(self addARow: aCollectionOfMorphs)
		hResizing: #shrinkWrap;
		wrapCentering: #center;
		cellPositioning: #leftCenter;
		cellInset: cellInsetInteger! !

!AlignmentMorph methodsFor: 'event handling' stamp: ''!
wantsKeyboardFocusFor: aSubmorph
	aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true].
	^ super wantsKeyboardFocusFor: aSubmorph! !

!AlignmentMorph methodsFor: 'testing' stamp: ''!
isAlignmentMorph

	^ true! !

!AlignmentMorph methodsFor: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!AlignmentMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AlignmentMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AlignmentMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AlignmentMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: ''!
newRow

	^ self new setAsRow! !

!AlignmentMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AlignmentMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AlignmentMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AlignmentMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AlignmentMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AlignmentMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AlignmentMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AlignmentMorph class methodsFor: 'examples' stamp: ''!
rowPrototype
	"Answer a prototypical row"
	"self rowPrototype openInHand"

	| 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!!'.
	aRow color: Color veryVeryLightGray.
	^ aRow! !

!AlignmentMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AlignmentMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AlignmentMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AlignmentMorph class methodsFor: 'examples' stamp: ''!
columnPrototype
	"Answer a prototypical column"
	"self columnPrototype openInHand"
	
	| 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!!'.
	^ aColumn! !

!AlignmentMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AlignmentMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AlignmentMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AlignmentMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AlignmentMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AlignmentMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AlignmentMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AlignmentMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AlignmentMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: ''!
newSpacer: aColor
	"Answer a space-filling instance of me of the given color."

	^ self new setAsSpacer: aColor! !

!AlignmentMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AlignmentMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: ''!
newColumn

	^ self new setAsColumn! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: ''!
newVariableTransparentSpacer
	"Answer a space-filling instance of me of the given color."

	^ self new setAsSpacer: Color transparent! !

!AlignmentMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AlignmentMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AlignmentMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: ''!
inARow: aCollectionOfMorphs
	"Answer a row-oriented AlignmentMorph holding the given collection"

	^ self new inARow: aCollectionOfMorphs! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: ''!
inAColumn: aCollectionOfMorphs
	"Answer a columnar AlignmentMorph holding the given collection"

	^ self new inAColumn: aCollectionOfMorphs! !

!AlignmentMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AllProtocol commentStamp: ''!
An AllProtocol is a special protocol to hanlde the "all" case!
!AllProtocol methodsFor: 'accessing' stamp: ''!
name
	^ (self isEmpty and: [ protocolOrganizer protocols isEmpty ])
		ifTrue: [ self class nullCategory ]
		ifFalse: [ name ]! !

!AllProtocol methodsFor: 'accessing' stamp: ''!
name: aString 
	self error: 'You cannot change my name'.! !

!AllProtocol methodsFor: 'testing' stamp: ''!
canBeRenamed
	^ false! !

!AllProtocol methodsFor: 'accessing' stamp: ''!
protocolOrganizer: anObject
	
	protocolOrganizer := anObject.! !

!AllProtocol methodsFor: 'testing' stamp: ''!
canBeRemoved
	^ false! !

!AllProtocol methodsFor: 'accessing' stamp: ''!
methodSelectors
	^ self protocolOrganizer allMethodSelectors! !

!AllProtocol methodsFor: 'accessing' stamp: ''!
protocolOrganizer
	
	^ protocolOrganizer! !

!AllProtocol methodsFor: 'testing' stamp: ''!
isVirtualProtocol 
	^ true! !

!AllProtocol class methodsFor: 'data' stamp: ''!
defaultName

	^ #'-- all --'! !

!AllProtocol class methodsFor: 'instance creation' stamp: ''!
protocolOrganizer: protocolOrganizer

	^ self new
		protocolOrganizer: protocolOrganizer;
		yourself! !

!AllocationTest commentStamp: ''!
Test originally from Andreas Raab!
!AllocationTest methodsFor: 'testing' stamp: ''!
testOneGBAllocation
	"Documentating a weird bug in the allocator"
	
	| sz array failed |
	failed := false.
	sz := 1024*1024*1024.
	array := [ByteArray new: sz] on: OutOfMemory do: [:ex| failed := true].
	self assert: (failed or:[array size = sz]).! !

!AllocationTest methodsFor: 'testing' stamp: ''!
testOneMWordAllocation
	"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: ''!
testOneGWordAllocation
	"Documentating a weird bug in the allocator"
	
	| sz array failed |
	"This takes too much time to run"
	self timeLimit: 3 minutes.
	
	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: ''!
testOneMBAllocation
	"Documentating a weird bug in the allocator"
	
	| sz array failed |
	failed := false.
	sz := 1024*1024.
	array := [ByteArray new: sz] on: OutOfMemory do: [:ex| failed := true].
	self assert: (failed or:[array size = sz]).! !

!AlphaBlendingCanvas commentStamp: ''!
see ColorMappingCanvas comment.!
!AlphaBlendingCanvas methodsFor: 'initialization' stamp: ''!
on: aCanvas
	myCanvas := aCanvas.
	alpha := 1.0.! !

!AlphaBlendingCanvas methodsFor: 'private' stamp: ''!
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)! !

!AlphaBlendingCanvas methodsFor: 'drawing - images' stamp: ''!
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: 'accessing' stamp: ''!
alpha: newAlpha
	alpha := newAlpha.! !

!AlphaBlendingCanvas methodsFor: 'accessing' stamp: ''!
alpha
	^alpha! !

!AlphaImageMorph commentStamp: ''!
Displays an image with the specified alpha value (translucency) and optional scale and layout (scaled, top-right etc.).


!
!AlphaImageMorph methodsFor: 'drawing' stamp: ''!
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: ''!
layoutPosition
	"Answer the position that the cached form should be drawn
	based on the layout"
	
	self layout == #topCenter ifTrue: [^self innerBounds topCenter - (self cachedForm width // 2 @ 0)].
	self layout == #topRight ifTrue: [^self innerBounds topRight - (self cachedForm width @ 0)].
	self layout == #rightCenter ifTrue: [^self innerBounds rightCenter - (self cachedForm width @ (self cachedForm height // 2))].
	self layout == #bottomRight ifTrue: [^self innerBounds bottomRight - self cachedForm extent].
	self layout == #bottomCenter ifTrue: [^self innerBounds bottomCenter - (self cachedForm width // 2 @ self cachedForm height)].
	self layout == #bottomLeft ifTrue: [^self innerBounds bottomLeft - (0 @ self cachedForm height)].
	self layout == #leftCenter ifTrue: [^self innerBounds leftCenter - (0 @ (self cachedForm height // 2))].
	(self layout == #center or: [self layout == #scaledAspect]) ifTrue: [^self innerBounds center - (self cachedForm extent // 2)].
	^self innerBounds topLeft! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
image: anImage 
	"Clear the cached form."
	
	^self image: anImage size: anImage extent! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
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: ''!
imageExtent
	"Answer the extent of the original form."

	^self form extent! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
autoSize: anObject
	"Set the value of autoSize"

	autoSize := anObject! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
scaledImage
	"Answer the image scaled as required."
	
	|i|
	i := self form.
	i boundingBox area = 0 ifTrue: [^i].
	(self layout == #scaled and: [self extent ~= i extent]) ifTrue: [
		^i magnify: i boundingBox by: (self extent / i extent) smoothing: 2].
	(self layout == #scaledAspect and: [self extent ~= i extent]) ifTrue: [
		^self width / i width > (self height / i height)
			ifTrue: [i magnify: i boundingBox by: (self height / i height) smoothing: 2]
			ifFalse: [i magnify: i boundingBox by: (self width / i width) smoothing: 2]].
	self scale ~= 1 ifTrue: [
		^i magnify: i boundingBox by: self scale smoothing: 2].
	^i! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
update: aSymbol
	"Update the image if changed."
	
	super update: aSymbol.
	aSymbol = self getImageSelector ifTrue: [
		self updateImage]! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
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: ''!
autoSize
	"Answer the value of autoSize"

	^ autoSize! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
scale
	"Answer the value of scale"

	^ scale! !

!AlphaImageMorph methodsFor: 'geometry' stamp: ''!
imageRectangleFromDisplayRectangle: aRectangle
	"Answer a rectangle in (original) image coordinates that
	corresponds to the given rectangle (in relative display coordinates)."

	|db|
	db := self displayBounds .
	db area = 0 ifTrue: [^db].
	self layout == #scaledAspect ifTrue: [
		^((aRectangle translateBy: self layoutPosition negated)
			scaleBy: self form width / db width) rounded].
	self layout == #scaled ifTrue: [
		^((aRectangle translateBy: self layoutPosition negated)
			scaleBy: (self form width / db width) @ (self form height / db height)) rounded].
	^self scale = 1
		ifTrue: [aRectangle translateBy: self layoutPosition negated]
		ifFalse: [((aRectangle translateBy: self layoutPosition negated)
					scaleBy: 1 / self scale) rounded]! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
enabled: anObject
	"Set the value of enabled"

	enabled := anObject.
	self
		cachedForm: nil;
		changed! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
alpha: anObject
	"Set the value of alpha"

	alpha := anObject.
	self
		cachedForm: nil;
		changed;
		changed: #alpha! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!AlphaImageMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	"Allow as normal."
	
	self basicExtent: aPoint.
	
	(self layout = #scaled or: [self layout = #scaledAspect]) ifTrue: [self cachedForm: nil]! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
alpha
	"Answer the value of alpha"

	^ alpha! !

!AlphaImageMorph methodsFor: 'geometry' stamp: ''!
displayBounds
	"Answer a rectangle in display coordinates that
	bounds the image (may be larger/smaller than visible area).
	Just one rep for the tiled case."

	^self layoutPosition extent: self cachedForm extent! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
layout
	"Answer the value of layout"

	^ layout! !

!AlphaImageMorph methodsFor: 'initialization' stamp: ''!
defaultImage
	"Answer the default image for the receiver."

	^DefaultImage ifNil: [DefaultImage := DefaultForm asFormOfDepth: 32]! !

!AlphaImageMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver.
	Use the 32 bit depth default image to avoid
	unnecessary conversions."

	enabled := true.
	autoSize := true.
	scale := 1.0.
	layout := #topLeft.
	alpha := 1.0.
	super initialize! !

!AlphaImageMorph methodsFor: 'geometry' stamp: ''!
optimalExtent
	"Answer the optimal extent for the receiver."
	
	^self form extent * self scale + (self borderWidth * 2)! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
getImageSelector: anObject

	getImageSelector := anObject! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
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: ''!
updateImage
	"Get the image from the model."
	
	(self model notNil and: [self getImageSelector notNil]) ifTrue: [
		(self model perform: self getImageSelector) ifNotNil: [:i | self image: i]]! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
cachedForm: anObject
	"Set the value of cachedForm"

	cachedForm := anObject! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
enabled
	"Answer the value of enabled"

	^enabled! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
getImageSelector

	^ getImageSelector! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
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: ''!
scale: aNumber
	"Set the value of scale"

	scale = aNumber ifTrue: [^self].
	scale := aNumber.
	self
		cachedForm: nil;
		changed;
		changed: #scale! !

!AlphaImageMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"Answer the default color for the receiver."

	^Color transparent! !

!AlphaImageMorph methodsFor: 'accessing' stamp: ''!
layoutSymbols
	"Answer the available layout options."

	^#(#center #tiled #scaled #scaledAspect
		#topLeft #topCenter #topRight #rightCenter
		#bottomRight #bottomCenter #bottomLeft #leftCenter)! !

!AlphaImageMorph class methodsFor: 'instance creation' stamp: ''!
defaultImage: aForm
	"Set the default image used for new instances of the receiver."

	DefaultImage := aForm! !

!AlphaInfiniteForm commentStamp: ''!
Alpha aware InfiniteForm.!
!AlphaInfiniteForm methodsFor: 'accessing' stamp: ''!
direction: aPoint
	"Ignore"! !

!AlphaInfiniteForm methodsFor: 'displaying' stamp: ''!
displayOnPort: aPort offsetBy: offset

	| targetBox patternBox savedMap top left |

	aPort destForm depth < 32 ifTrue: [^super displayOnPort: aPort offsetBy: offset].
	"this version tries to get the form aligned where the user wants it and not just aligned with the cliprect"

	(patternForm isForm) ifFalse: [
		"patternForm is a Pattern or Color; just use it as a mask for BitBlt"
		^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over].

	"do it iteratively"
	targetBox := aPort clipRect.
	patternBox := patternForm boundingBox.
	savedMap := aPort colorMap.
	aPort sourceForm: patternForm;
		fillColor: nil;
		combinationRule: Form blend;
		sourceRect: (0@0 extent: patternBox extent);
		colorMap: (patternForm colormapIfNeededFor: aPort destForm).
	top := (targetBox top truncateTo: patternBox height) + offset y.
	left :=  (targetBox left truncateTo: patternBox width) + offset x.

	left to: (targetBox right - 1) by: patternBox width do:
		[:x | top to: (targetBox bottom - 1) by: patternBox height do:
			[:y | aPort destOrigin: x@y; copyBits]].
	aPort colorMap: savedMap.! !

!AlphaInfiniteForm methodsFor: '*Athens-Morphic' stamp: ''!
asAthensPaintOn: canvas
	^ (canvas surface createFormPaint: self asForm)
		repeat;
		origin: self origin;
		direction: self direction;
		extent: self extent;
		yourself! !

!AlphaInfiniteForm methodsFor: 'accessing' stamp: ''!
origin
	"Answer the origin."
	
	^origin ifNil: [0@0]! !

!AlphaInfiniteForm methodsFor: 'accessing' stamp: ''!
extent
	"Answer the extent of the repeating area."

	^extent ifNil: [SmallInteger maxVal @ SmallInteger maxVal]! !

!AlphaInfiniteForm methodsFor: 'accessing' stamp: ''!
origin: aPoint
	"Set the origin."

	origin := aPoint! !

!AlphaInfiniteForm methodsFor: 'displaying' stamp: ''!
computeBoundingBox 
	"Refer to the comment in DisplayObject|computeBoundingBox."

	^self origin extent: self extent! !

!AlphaInfiniteForm methodsFor: 'accessing' stamp: ''!
extent: anObject
	"Set the value of extent"

	extent := anObject! !

!AlphabeticSorter commentStamp: ''!
Aplhabetical sorting!
!AlphabeticSorter methodsFor: 'sorting' stamp: ''!
sortCompletionList: anOrderedCollection
	
	^ anOrderedCollection sort! !

!AlphabeticSorter class methodsFor: 'description' stamp: ''!
kind

	^ 'alphabetical'! !

!AndreasSystemProfiler commentStamp: ''!
AndreasSystemProfiler uses sub-msec VM supported PC sampling.

	In Memory of Andreas Raab.  Author, Friend, Colleague. 	http://forum.world.st/In-Memory-of-Andreas-Raab-td4663424.html
	Released by Ron, Julie and David

Example:
AndreasSystemProfiler spyOn: [ 10000 timesRepeat: [ 3.14159 printString ] ]

-=-=-=-=-=-=-=
Apparently, the time taken to run the provided block is as twice as long as run without the profiler.

-=-=-=-=-=-=-=
Both AndreasSystemProfiler and MessageTally are periodic sampling profilers.  The essential difference between AndreasSystemProfiler and MessageTally is in how the current method is sampled.

MessageTally is driven from a high-priority process in a loop waiting on a delay.  When the delay fires the lower-priority process being profiled is interrupted, its stack is walked to determine the methods along the call chain, and that data is recorded.  But since the sampling occurs when the high-priority process preempts the lower-priority process, a sample is only taken at a preemption point.  In particular, primitives are *not* profiled because they are not suspension points.  A process can only be suspended on method activation (a non-primitive method activation, or primitive failure) or on backward branch.  The cost of primitives is charged to a caller and is inferred by subtracting the cost of children of the caller from the caller itself (subtracting the number of samples in children of the caller form the number of samples in the caller itself).  

Another problem is that using the clock that underlies Delay, which is typically the clock used by processes being profiled, causes sampling errors due to the sampling and sampled processes cohering.  Delays are limited in resolution (at best 1 millisecond) so if the profiled process waits on a delay it'll fire immediately after the profiling process (because the profiling process is at higher priority) and so the sampling process may only ever see the sampled process in a wait state.

If MessageTally is used to profile multiple processes then a third problem is that if a primitive causes a process switch then its cost will end up being charged to the process switched-to, not switched from.  This is again because sampling can only occur after a primitive has completed (successfully or not).

AndreasSystemProfiler is driven from a high-priority process in a loop waiting on a Semaphore known to the VM.  The profiling process uses a primitive to schedule a sample some number of ticks of the VM's high-performance clock in the future.  When the time is reached the VM samples the current method and the current process, *before any process preemption takes place*, and independently of the standard clock, and signals the semaphore.  The profiling process then collects the method,process pair via primitives.  So AndreasSystemProfiler provides much more accurate results.

That said there are still limitations with primitives and Cog.  Currently Cog only samples "interpreter" primitives.  Those primitives it implements in machine code (integer and float arithmetic, closure evaluation, at:, identityHash) are not sampled and won't show up; they will be charged to the calling method.  This is fixable, since Cog actually compiles the sampling direct into interpreter primitive invocation when profiling is in effect and not at other times, but sampling could be a significant cost in these simple and performance-critical primitives.!
!AndreasSystemProfiler methodsFor: 'reporting' stamp: ''!
report
	"Answer a report, with cutoff percentage of each element of the tree"
	^String streamContents: [ :s | self report: s ]! !

!AndreasSystemProfiler methodsFor: 'reporting' stamp: ''!
doReport
	"Report the results of this profiler run"
	UIManager default edit: self report label: 'Spy Results'.! !

!AndreasSystemProfiler methodsFor: 'profiling' stamp: ''!
spyOn: aBlock
	"Profile system activity during execution of aBlock. 
	The argument is the desired samples per *milli* second.
	Mostly for polymorphism with MessageTally."
	self startProfiling.
	aBlock ensure: [ self stopProfiling ]
! !

!AndreasSystemProfiler methodsFor: 'reporting' stamp: ''!
reportProcessStatsOn: str
	| totalSwitches pageOverflows pageDivorces actualSwitches |
	vmStats size >= 61 ifFalse: [ ^ self ]. "don't try this on the closure VM"
	totalSwitches := vmStats at: 56.
	actualSwitches := totalSwitches - (2*totalTally). "exclude to/from profiler"
	pageOverflows := vmStats at: 60.
	pageDivorces := vmStats at: 61.

	str cr.
	str nextPutAll: '**Processes**'; cr.
	str tab; nextPutAll: 'Total process switches: ', totalSwitches printString; cr.
	str tab; nextPutAll: 'Without Profiler: ', actualSwitches printString; cr.
	str tab; nextPutAll: 'Stack page overflows: ', pageOverflows printString; cr.
	str tab; nextPutAll: 'Stack page divorces: ', pageDivorces printString; cr.
! !

!AndreasSystemProfiler methodsFor: 'reporting' stamp: ''!
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: ''!
report: strm cutoff: threshold 
	tallyRoot ifNil: [ strm nextPutAll: 'The profiler has not been run'. ^ self ].
	
	tallyRoot tally isZero
		ifTrue: [ strm nextPutAll: ' - no tallies obtained' ] 
		ifFalse: [
			strm nextPutAll: 'Reporting - ', totalTally asStringWithCommas,' tallies, ',
							 totalTime asStringWithCommas, ' msec.'; cr; cr.
			tallyRoot fullPrintOn: strm tallyExact: false orThreshold: threshold time: totalTime.
	].

	totalTime isZero ifFalse: [
		self reportGCStatsOn: strm.
		self reportProcessStatsOn: strm.
	].! !

!AndreasSystemProfiler methodsFor: 'reporting' stamp: ''!
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: 'profiling' stamp: ''!
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: ''!
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: ''!
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 class methodsFor: 'spying' stamp: ''!
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.
		MorphicRenderLoop new doOneCycleWhile: [Time totalSeconds < deadline] ].! !

!AndreasSystemProfiler class methodsFor: 'spying' stamp: ''!
spyFor: seconds
	"Run the system profiler for the specified number of seconds"

	^self spyOn: [ (Delay forSeconds: seconds) wait ].! !

!AndreasSystemProfiler class methodsFor: 'examples' stamp: ''!
exampleSpyOnWorld

	self spyOnWorldFor: 5! !

!AndreasSystemProfiler class methodsFor: 'examples' stamp: ''!
exampleSpyForSeconds

	self spyFor: 5! !

!AndreasSystemProfiler class methodsFor: 'examples' stamp: ''!
exampleSpyOnBlock

	self spyOn: [ 10000 timesRepeat: [ 3.14159 printString ] ]! !

!AndreasSystemProfiler class methodsFor: 'spying' stamp: ''!
spyOn: aBlock
	"The main method for profiling and showing the report "

	| profiler |
	profiler := self new.
	^ [ profiler spyOn: aBlock ]
		ensure: [ profiler doReport ]! !

!AndreasSystemProfiler class methodsFor: 'LICENSE' stamp: ''!
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: ''!
default
	^self new! !

!AndreasSystemProfilerTest commentStamp: ''!
SUnit tests for AndreasSystemProfiler!
!AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: ''!
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 assertEmpty: stream contents! !

!AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: ''!
testGetNewTab
	| tabs |
	
	self assert: (tally getNewTabsFor: #()) equals: #().
	self assert: (tally getNewTabsFor: #(' ')) equals:  #(' ').
	
	tabs := OrderedCollection new.
	tabs add: '['.
	(tally maxTabs + 1) timesRepeat: [ tabs add: ' ' ].
	self assert: (tally getNewTabsFor: tabs) asArray equals: #('[' '[')! !

!AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: ''!
testPrintingTallyUninitialized
	
	self assert: QSystemTally new printString equals: 'nil>>nil -- nil'! !

!AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: ''!
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 equals: ' 0 AndreasSystemProfilerTest  testPrintingTally
'! !

!AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: ''!
testPrintingTally

	self assert: tally printString equals: 'AndreasSystemProfilerTest>>#testPrintingTally -- 0'! !

!AndreasSystemProfilerTest methodsFor: 'tests profiler' stamp: ''!
testSimpleReport

	AndreasSystemProfiler new report! !

!AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: ''!
testFullPrintOn
	| stream |
	stream := WriteStream on: String new.
	tally fullPrintOn: stream tallyExact: false orThreshold: 0 time: 10.
	
	self assert: stream contents equals: '**Tree**

**Leaves**
'! !

!AndreasSystemProfilerTest methodsFor: 'tests profiler' stamp: ''!
testSimple

	AndreasSystemProfiler new spyOn: [ 200 timesRepeat: [ 1.23 printString ]]! !

!AndreasSystemProfilerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	tally := QSystemTally new.
	tally class: self class method: self class >> #testPrintingTally	
	"tally class: Object method: Object >> #printString."! !

!AnimatedImageFrame commentStamp: ''!
I am a single frame in a sequence of frames that comprise an animated image. I am designed for use by classes like AnimatedImageMorph and am created during the reading of some image files such as GIFs (see GIFReadWriter).

I contain a Form describing my image, a delay time in milliseconds that describes how long I should be displayed in a sequence of animated frames, and a disposal symbol that implementors can use when compositing myself in a sequence of frames. 

See AnimatedImageMorph for examples of how I am used.!
!AnimatedImageFrame methodsFor: 'accessing' stamp: ''!
delay
	^ delay! !

!AnimatedImageFrame methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	offset := 0 @ 0.
	delay := self defaultDelay.
	disposal := #otherDisposal! !

!AnimatedImageFrame methodsFor: 'accessing' stamp: ''!
disposal
	^ disposal! !

!AnimatedImageFrame methodsFor: 'accessing' stamp: ''!
offset: aPoint
	"This represents the frame form's offset in the
	parent image canvas"
	offset := aPoint! !

!AnimatedImageFrame methodsFor: 'accessing' stamp: ''!
delay: aNumber
	delay := aNumber! !

!AnimatedImageFrame methodsFor: 'accessing' stamp: ''!
form
	^ form! !

!AnimatedImageFrame methodsFor: 'accessing' stamp: ''!
disposal: aSymbol
	"Disposal must be one of:
		#restoreBackground
		#leaveCurrent
		#restorePreviousState"
	"({ #restoreBackground.
		#leaveCurrent.
		#restorePreviousState } includes: aSymbol) ifTrue: [ 
			disposal := aSymbol ]."
	disposal := aSymbol! !

!AnimatedImageFrame methodsFor: 'accessing' stamp: ''!
form: aForm
	form := aForm! !

!AnimatedImageFrame methodsFor: 'accessing' stamp: ''!
offset
	^ offset! !

!AnimatedImageFrame methodsFor: 'defaults' stamp: ''!
defaultDelay
	^ 66! !

!AnimatedImageMorph commentStamp: ''!
I am a Morph that displays a sequence of Forms order, each as represented by AnimatedImageFrame objects.

To set or access the AnimatedImageFrame objects that I should display, use #frames and #frames: with a collection of frames.

For convenience, the #forms message will respond with a collection of the Forms inside of each AnimatedImageFrame.

Unlike ImageMorph (from whom I do not subclass), my extent must be explicitly set since each frame's form can have different dimensions and offsets.!
!AnimatedImageMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"currentFrame ifNil: [ ^ self ]."
	aCanvas
		translucentImage: activeForm
		at: self bounds origin.! !

!AnimatedImageMorph methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ self color! !

!AnimatedImageMorph methodsFor: 'accessing' stamp: ''!
backgroundColor: aColor
	self color: aColor.! !

!AnimatedImageMorph methodsFor: 'accessing' stamp: ''!
currentFrame
	^ currentFrame! !

!AnimatedImageMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self color: Color transparent.
	frames := OrderedCollection new.
	currentDisposal := #restoreBackground.
	activeForm := Form extent: self extent.! !

!AnimatedImageMorph methodsFor: 'stepping' stamp: ''!
step
	frameStream ifNil: [ ^ self ].
	frameStream atEnd ifTrue: [ 
		frameStream reset.
		prevFrame := nil.
		currentFrame := frameStream next.
		currentDisposal := #restoreBackground.
		self
			updateActiveForm
			changed.
		^ self ].
	(frameStream position = 0) ifTrue: [ 
		prevFrame := nil.
		currentDisposal := #restoreBackground  ]
	ifFalse: [ 
		prevFrame := frameStream peekBack.
		currentDisposal := prevFrame disposal ].
	currentFrame := frameStream next.
	self updateActiveForm.
	self changed.! !

!AnimatedImageMorph methodsFor: 'accessing' stamp: ''!
frames: aCollection
	"A collection of AnimagedImageFrame instances"
	frames := aCollection.
	frameStream := ReadStream on: frames.! !

!AnimatedImageMorph methodsFor: 'accessing' stamp: ''!
forms
	^ frames collect: [ :frame | frame form ].! !

!AnimatedImageMorph methodsFor: 'accessing' stamp: ''!
frames
	^ frames! !

!AnimatedImageMorph methodsFor: 'drawing' stamp: ''!
leaveCurrent
	"Update the activeForm using the #leaveCurrent
	disposal method"
	| canvas |
	canvas := activeForm getCanvas.
	canvas
		translucentImage: currentFrame form
		at: currentFrame offset.
	
	activeForm := canvas form.! !

!AnimatedImageMorph methodsFor: 'drawing' stamp: ''!
restoreBackground
	"Update the activeForm using the #restoreBackground
	disposal method"
	| canvas r |
	canvas := activeForm getCanvas.
	r := (prevFrame offset extent: (prevFrame form extent)).
	
	"We restore the area of the previous frame to the backgroundColor.
	 Usually this is transparent"
	canvas
		clipBy: r
		during: [ :c |
			c fillColor: self backgroundColor ].
	
	"Draw the current frame's form atop the current canvas form"
	canvas
		translucentImage: currentFrame form
		at: currentFrame offset.

	activeForm := canvas form.! !

!AnimatedImageMorph methodsFor: 'accessing' stamp: ''!
prevFrame
	^ prevFrame! !

!AnimatedImageMorph methodsFor: 'drawing' stamp: ''!
updateActiveForm

	"Update the activeForm of the receiver based upon the
	disposal rules of the current and previous frames."

	| canvas |

	prevFrame
		ifNil: [ canvas := FormCanvas extent: self bounds extent.
			canvas translucentImage: currentFrame form at: currentFrame offset.
			activeForm := canvas form.
			^ self
			].
	prevFrame disposal = #leaveCurrent
		ifTrue: [ ^ self leaveCurrent ].	"Otherwise we assume a restore background"
	^ self restoreBackground! !

!AnimatedImageMorph methodsFor: 'defaults' stamp: ''!
defaultDelay
	^ 100! !

!AnimatedImageMorph methodsFor: 'accessing' stamp: ''!
frameStream
	^ frameStream! !

!AnimatedImageMorph methodsFor: 'stepping' stamp: ''!
stepTime
	frameStream ifNil: [ ^ self defaultDelay ].
	^ currentFrame delay.! !

!AnimatedImageMorph class methodsFor: 'instance creation' stamp: ''!
fromGIFReader: aGIFReader
	"Respond with an instance of the receiver
	configured from a GIFReader instance"
	^ self new
		frames: aGIFReader frames;
		extent: (aGIFReader canvasWidth)@(aGIFReader canvasHeight);
		color: aGIFReader backgroundColor! !

!AnimationSettings commentStamp: ''!
Animation settings!
!AnimationSettings methodsFor: 'accessing' stamp: ''!
useAnimation
	^ useAnimation ifNil: [ useAnimation := false ]! !

!AnimationSettings methodsFor: 'accessing' stamp: ''!
delay
	^ delay ifNil: [delay := 8]! !

!AnimationSettings methodsFor: 'accessing' stamp: ''!
numberOfSteps
	^ numberOfSteps ifNil: [numberOfSteps := 20]! !

!AnimationSettings methodsFor: 'accessing' stamp: ''!
useAnimation: aBoolean
	useAnimation := aBoolean! !

!AnimationSettings methodsFor: 'accessing' stamp: ''!
animateClosing: aBoolean
	animateClosing := aBoolean! !

!AnimationSettings methodsFor: 'accessing' stamp: ''!
delay: anInteger
	delay := anInteger! !

!AnimationSettings methodsFor: 'accessing' stamp: ''!
numberOfSteps: anInteger
	numberOfSteps := anInteger! !

!AnimationSettings methodsFor: 'accessing' stamp: ''!
animateClosing
	^ animateClosing ifNil: [animateClosing := false]! !

!AnnotationContext commentStamp: ''!
My subclasses describe users of annotations.
They should implement single method #describes: with user as argument. User can be any object. It is provided applications during annotation lookup.

By default annotations has NullAnnotationContext which do not describe any possible user. So when you query annotations for given user annotations without specified contexts will be skipped.

For simplicity there is one simple context implementation the SimpleAnnotationContext which represents the hierarchy of user classes. It is hidden from users and created when class is specified for annotation context:
	MyClassAnnotation for: MyUser
Look at subclasses comments for details.!
!AnnotationContext methodsFor: 'converting' stamp: ''!
asAnnotationContext
	^self! !

!AnnotationContext methodsFor: 'converting' stamp: ''!
, anAnnotationContext
	^ CompositeAnnotationContext with: { self. anAnnotationContext asAnnotationContext}! !

!AnnotationContext methodsFor: 'testing' stamp: ''!
describes: anAnnotationUser
	"The annotation context describes users of annotation.
	Subclasses should decide if given anAnnotationUser is appropriate annotation user.
	anAnnotationUser can be any object"
	self subclassResponsibility! !

!AnnotationUserExample methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	isSimulatedActiveAnnotation := true! !

!AnnotationUserExample methodsFor: 'accessing' stamp: ''!
isSimulatedActiveAnnotation
	^ isSimulatedActiveAnnotation! !

!AnnotationUserExample methodsFor: 'accessing' stamp: ''!
isSimulatedActiveAnnotation: anObject
	isSimulatedActiveAnnotation := anObject! !

!Announcement commentStamp: ''!
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.

See in the help browser for more documentation. Just do:

HelpBrowser openOn: AnnouncementsHelp
!
!Announcement methodsFor: 'converting' stamp: ''!
asAnnouncement
	^ self! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsMethodsDefinedInClass: aClass
	^ false! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsClassExtension
	^false! !

!Announcement methodsFor: '*Calypso-SystemPlugins-Critic-Queries' stamp: ''!
affectsCritiques
	"Critiques are very abstract concept. Any change can affect critique of arbitrary object"
	^true! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsVariablesOf: aClass
	^false! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsClassesDefinedInPackage: aPackage
	^false! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsClassesExtendedInPackage: aPackage
	^false! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsMethodsTaggedWith: tagName
	^false! !

!Announcement methodsFor: 'initialization' stamp: ''!
prepareForDelivery
	"This method will be executed once before subscriptions delivery.
	If nobody subscribed on me this method will not be called.
	It allows to put some heavy initialization logic here. It will be executed only 
	if there is interest on me"! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsMethodTagIn: aClass
	^false! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsClass: aClass
	^false! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsMethodsDefinedInPackage: aPackage
	^false! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsClasses
	^false! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsPackage: aPackage
	^aPackage includesClassesAffectedBy: self
! !

!Announcement methodsFor: '*Beacon-Core-Core' stamp: ''!
emit
	"Convert the receiver as a beacon signal to the main signal dispatcher so that registered loggers get a chance to act on signal reception."
	
	Beacon announce: self asBeaconSignal! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsMethod: aMethod
	^false! !

!Announcement methodsFor: '*Calypso-NavigationModel' stamp: ''!
shouldBeConsideredByCalypsoEnvironment
	^true! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsPackages
	^false! !

!Announcement methodsFor: '*System-Announcements' stamp: ''!
affectsMethods
	^false! !

!Announcement methodsFor: '*Calypso-SystemQueries' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery
	^false! !

!Announcement class methodsFor: 'converting' stamp: ''!
asAnnouncement
	^ self new! !

!Announcement class methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
systemIconName

	^ #announcementIcon! !

!Announcement class methodsFor: 'public' stamp: ''!
, anAnnouncementClass
	^ AnnouncementSet with: self with: anAnnouncementClass! !

!Announcement class methodsFor: 'testing' stamp: ''!
handlesAnnouncement: anAnnouncement
	"The receiver acts as a filter to determine whether subscribers who used the receiver as signaling tag (event identifier class or symbol) should receive incoming announcement. In particular, registering to a superclass will receive the announcements from all subclasses."

	^ anAnnouncement class includesBehavior: self! !

!Announcement class methodsFor: 'public' stamp: ''!
- anotherAnnouncement
	"Create an announcement set containing the receiver 
	and anotherAnnouncement as exclusion."

	^ AnnouncementSetWithExclusions new
		add: self;
		addExclusion: anotherAnnouncement;
		yourself! !

!Announcement class methodsFor: 'converting' stamp: ''!
where: instancesFilterBlock

	^AnnouncementDeliveryCondition for: self where: instancesFilterBlock! !

!AnnouncementDeliveryCondition commentStamp: ''!
I represent condition which should be satisfied on given announcement to be delivered to subscription.
I am used to implement instance specific subscription on announcements. 

To create me send message #where to announcement class with condition block:

	Announcement where: [ :ann | ann param = #expected ]

I can be used directly in announcer subscription API in place of announcement class:

	announcer when:  (ValueChanged where: [:change | change oldValue = 100])

Be carefull with me because blocks in subscriptions produce references to outer contexts (recever and all senders)
 
Internal Representation and Key Implementation Points.

    Instance Variables
	announcementClass:		<Announcement class>
	conditionBlock:		<BlockClosure>!
!AnnouncementDeliveryCondition methodsFor: 'accessing' stamp: ''!
announcementClass
	^ announcementClass! !

!AnnouncementDeliveryCondition methodsFor: 'accessing' stamp: ''!
announcementClass: anObject
	announcementClass := anObject! !

!AnnouncementDeliveryCondition methodsFor: 'testing' stamp: ''!
handlesAnnouncement: anAnnouncement

	^(announcementClass handlesAnnouncement: anAnnouncement)
		and: [conditionBlock value: anAnnouncement ]! !

!AnnouncementDeliveryCondition methodsFor: 'accessing' stamp: ''!
conditionBlock
	^ conditionBlock! !

!AnnouncementDeliveryCondition methodsFor: 'accessing' stamp: ''!
conditionBlock: anObject
	conditionBlock := anObject! !

!AnnouncementDeliveryCondition class methodsFor: 'instance creation' stamp: ''!
for: anAnnouncementClass where: aBlock

	^self new 
		announcementClass: anAnnouncementClass;
		conditionBlock: aBlock! !

!AnnouncementLogger commentStamp: ''!
Use me to debug and log to the Transcript announcements.

AnnouncementLogger new subscribeTo: SystemAnnouncer announcer

to unsubscribe

AnnouncementLogger  allInstancesDo: [:each | SystemAnnouncer announcer unsubscribe: each ]!
!AnnouncementLogger methodsFor: 'logging' stamp: ''!
logAnnouncement: ann
	ann traceCr! !

!AnnouncementLogger methodsFor: 'subscription' stamp: ''!
subscribeTo: anAnnouncer

	anAnnouncer "weak" 
		when: Announcement send: #logAnnouncement: to: self! !

!AnnouncementMockA commentStamp: ''!
This is a simple test mock.!
!AnnouncementMockB commentStamp: ''!
This is a simple test mock!
!AnnouncementMockB methodsFor: 'accessing' stamp: ''!
parameter: anObject
	parameter := anObject! !

!AnnouncementMockB methodsFor: 'accessing' stamp: ''!
parameter
	^ parameter! !

!AnnouncementMockB class methodsFor: 'instance creation' stamp: ''!
with: anObject
	^self new 
		parameter: anObject! !

!AnnouncementMockC commentStamp: ''!
This is a simple test mock!
!AnnouncementMockC methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	announcingCounter := 0! !

!AnnouncementMockC methodsFor: 'initialization' stamp: ''!
prepareForDelivery

	announcingCounter := announcingCounter + 1! !

!AnnouncementMockC methodsFor: 'accessing' stamp: ''!
announcingCounter
	^ announcingCounter! !

!AnnouncementSet commentStamp: ''!
If you want to register the same action for multiple events, simply create an AnnouncementSet using a comma: 

	Parent>>initialize 
	    super initialize. 
	    self session announcer on: AddChild, RemoveChild do: [:it | self changeChild: it child]
	
Motivation example: Often the UI is built after/independently from the model. You want to have the model raise fine-grained announcements to enable the layers on top, but sometimes it is easier in the UI to refresh everything whenever something happens.!
!AnnouncementSet methodsFor: 'exclusion' stamp: ''!
- anotherAnnouncement
	"Create an announcement set containnig the receiver
	and anotherAnnouncement as an exclusion."

	^ AnnouncementSetWithExclusions new
		add: self;
		addExclusion: anotherAnnouncement;
		yourself! !

!AnnouncementSet methodsFor: 'copying' stamp: ''!
, anAnnouncementClass
	self add: anAnnouncementClass! !

!AnnouncementSet methodsFor: 'testing' stamp: ''!
handlesAnnouncement: anAnnouncement
	"If any of the set handles the announcements, subscribers should receive it."
	^ self anySatisfy: [ :each | each handlesAnnouncement: anAnnouncement ]! !

!AnnouncementSetTest commentStamp: ''!
SUnit tests for announcement sets!
!AnnouncementSetTest methodsFor: 'tests' stamp: ''!
testIncludeOnlyOnce
	| set |
	set := AnnouncementMockA , AnnouncementMockB , AnnouncementMockA.
	self assert: set size equals: 2! !

!AnnouncementSetTest methodsFor: 'tests' stamp: ''!
testInstanceCreation
	| set |
	set := AnnouncementMockA , AnnouncementMockB.
	self assert: set size equals: 2! !

!AnnouncementSetWithExclusions commentStamp: ''!
I am an AnnouncementSet that explicitely does not handle a number of exclusion Announcements.

You could define me by #- message:

	announcer when: Announcement - ValueChanged do: [...].
	announcer when: Announcement - ValueChanged - ValueAdded do: [...].
	announcer when: ValueAdded, ValueRemoved - ValueAdded
 
Internal Representation and Key Implementation Points.

    Instance Variables
	exclusions:		<OrderedCollection>!
!AnnouncementSetWithExclusions methodsFor: 'private' stamp: ''!
addExclusion: anAnnouncement
	"Add anAnnouncement as an exclusion to me.
	I will explicitly not handle my exclusion announcements."
	
	^ exclusions add: anAnnouncement! !

!AnnouncementSetWithExclusions methodsFor: 'testing' stamp: ''!
handlesAnnouncement: anAnnouncement
	"Return true when I will handle anAnnouncement.
	I extend my superclass behavior by explicitly 
	not handling the exclusions."

	^ (super handlesAnnouncement: anAnnouncement) 
			and: [ exclusions noneSatisfy: [ :each | each handlesAnnouncement: anAnnouncement ] ]! !

!AnnouncementSetWithExclusions methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	exclusions := OrderedCollection new! !

!AnnouncementSetWithExclusions methodsFor: 'initialization' stamp: ''!
initialize: aNumber

	super initialize: aNumber.
	exclusions := OrderedCollection new! !

!AnnouncementSubscription commentStamp: ''!
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: ''!
action: anObject

	action := anObject! !

!AnnouncementSubscription methodsFor: 'announcing' stamp: ''!
deliver: anAnnouncement
	" deliver an announcement to receiver. In case of failure, it will be handled in separate process"

	^ (self handlesAnnouncement: anAnnouncement ) ifTrue: [
		[action cull: anAnnouncement cull: announcer] 
			on: UnhandledError fork: [:ex | ex pass ]]! !

!AnnouncementSubscription methodsFor: 'accessing' stamp: ''!
action

	^ action! !

!AnnouncementSubscription methodsFor: 'accessing' stamp: ''!
subscriber
	^ subscriber! !

!AnnouncementSubscription methodsFor: 'accessing' stamp: ''!
valuable: aValuable
	"Used when subscriber should be extracted from valuable object"
	self action:  aValuable.
	self subscriber: aValuable receiver.! !

!AnnouncementSubscription methodsFor: 'accessing' stamp: ''!
announcementClass

	^ announcementClass! !

!AnnouncementSubscription methodsFor: 'accessing' stamp: ''!
announcementClass: anObject

	announcementClass := anObject! !

!AnnouncementSubscription methodsFor: 'accessing' stamp: ''!
announcer: anAnnouncer
	announcer := anAnnouncer! !

!AnnouncementSubscription methodsFor: 'converting' stamp: ''!
makeStrong
	" i am already strong. Do nothing "! !

!AnnouncementSubscription methodsFor: 'converting' stamp: ''!
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: ''!
handlesAnnouncement: anAnnouncement

	^ announcementClass handlesAnnouncement: anAnnouncement! !

!AnnouncementSubscription methodsFor: 'accessing' stamp: ''!
subscriber: aSubscriber
	subscriber := aSubscriber! !

!AnnouncementSubscription methodsFor: 'accessing' stamp: ''!
announcer

	^ announcer! !

!AnnouncementsAPIDocumentation commentStamp: ''!
This is a custom help book providing the API documentation for the announcements framework.
!
!AnnouncementsAPIDocumentation class methodsFor: 'accessing' stamp: ''!
bookName
	^'API Documentation'! !

!AnnouncementsAPIDocumentation class methodsFor: 'accessing' stamp: ''!
helpPackages
	^#('Announcements-Core' 'Announcements-View' 'Announcements-Core-Tests')! !

!AnnouncementsAPIDocumentation class methodsFor: 'defaults' stamp: ''!
builder
	^PackageAPIHelpBuilder! !

!AnnouncementsHelp commentStamp: ''!
This is a custom help book for the announcements framework.
!
!AnnouncementsHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#(introduction AnnouncementsTutorial AnnouncementsAPIDocumentation)! !

!AnnouncementsHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^'Announcements framework'! !

!AnnouncementsHelp class methodsFor: 'pages' stamp: ''!
introduction
	"This method was automatically generated. Edit it using:"
	"AnnouncementsHelp edit: #introduction"
	^HelpTopic
		title: 'Introduction'
		contents: 
'The announcement framwork is an event notification framework. Compared to "traditional" Smalltalk event systems in this new framework, an event is a real object rather than a symbol.

An event someone might want to announce, such as a button click or an attribute change, is defined as a subclass of the abstract superclass Announcement. The subclass can have instance variables for additional information to pass along, such as a timestamp, or mouse coordinates at the time of the event, or the old value of the parameter that has changed. To signal the actual occurrence of an event, the "announcer" creates and configures an instance of an appropriate announcement, then broadcasts that instance. Objects subscribed to receive such broadcasts from the announcer receive a broadcast notification together with the instance. They can talk to the instance to find out any additional information about the event that has occurred.!!'! !

!AnnouncementsTutorial commentStamp: ''!
This is a custom help book providing a tutorial for the announcements framework.
!
!AnnouncementsTutorial class methodsFor: 'accessing' stamp: ''!
pages
	^#(step1 step2 step3)! !

!AnnouncementsTutorial class methodsFor: 'accessing' stamp: ''!
bookName
	^'Tutorial'! !

!AnnouncementsTutorial class methodsFor: 'pages' stamp: ''!
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: ''!
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 when: MyInterestingAnnouncement send: #open to: Browser.     
	announcer when: 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 when: MyInterestingAnnouncement send: #open to: Browser.    
	announcer when: MyInterestingAnnouncement send: #inspect to: Smalltalk.    	
	announcer announce: MyInterestingAnnouncement new	

Note that the subscribers are decoupled from the original 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: ''!
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:

	World announcer 
		when: 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.
	
	World announcer 
		when: WindowOpened 
		send: #value 
		to: [ Transcript show: ''A new window was opened'';cr].
!!' readStream nextChunkText! !

!Announcer commentStamp: ''!
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.!
!Announcer methodsFor: 'private' stamp: ''!
basicSubscribe: subscription
	^ registry add: subscription! !

!Announcer methodsFor: 'subscription' stamp: ''!
when: anAnnouncementClass do: aValuable for: aSubscriber
	"Declare that when anAnnouncementClass is raised, aValuable is executed and define the subscriber."
	
    ^ (self when: anAnnouncementClass do: aValuable) subscriber: aSubscriber; yourself! !

!Announcer methodsFor: 'registration api' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject
	"Declare that when anAnnouncementClass is raised, anObject should receive the message aSelector.
    When the message expects one argument (eg #fooAnnouncement:) the announcement is passed as argument.
    When the message expects two arguments (eg #fooAnnouncement:announcer:) both the announcement and 
    the announcer are passed as argument"

	^ self
		when: anAnnouncementClass
		do: (MessageSend receiver: anObject selector: aSelector)! !

!Announcer methodsFor: 'testing' stamp: ''!
hasSubscriber: anObject

	registry subscriptionsOf: anObject do: [:each | ^ true].
	^ false! !

!Announcer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	registry := SubscriptionRegistry new.! !

!Announcer methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
hasSubscriptions
	
	^ self numberOfSubscriptions isZero not! !

!Announcer methodsFor: 'accessing' stamp: ''!
subscriptionsForClass: subscriberClass
	"Return the list of subscription for a given class"
	^ self subscriptions subscriptionsForClass: subscriberClass! !

!Announcer methodsFor: 'weak' stamp: ''!
weak
	"announcer weak subscribe: foo"
	^ WeakSubscriptionBuilder on: self! !

!Announcer methodsFor: 'statistics' stamp: ''!
numberOfSubscriptions
	^ registry numberOfSubscriptions! !

!Announcer methodsFor: 'subscription' stamp: ''!
unsubscribe: anObject
	"Unsubscribe all subscriptions of anObject from the receiver"
	
	registry removeSubscriber: anObject! !

!Announcer methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionSubscriptionsContext: aContext 
	
	aContext active: self hasSubscriptions! !

!Announcer methodsFor: 'registration api' stamp: ''!
when: anAnnouncementClass do: aValuable
	"Declare that when anAnnouncementClass is raised, aValuable is executed.  Pay attention that such method as well as #when:do: should not be used on weak announcer since the block holds the receiver and more strongly."
	
	^ registry add: (
		AnnouncementSubscription new 
			announcer: self;
			announcementClass: anAnnouncementClass;
			valuable: aValuable)! !

!Announcer methodsFor: '*Roassal3' stamp: ''!
handleEventClass: eventClass
	"Return true if the receiver has a callback subscripbed for the event class"
	^ self subscriptions handleEventClass: eventClass! !

!Announcer methodsFor: 'private' stamp: ''!
replace: subscription with: newOne
	^ registry replace: subscription with: newOne! !

!Announcer methodsFor: 'announce' stamp: ''!
announce: anAnnouncement

	| announcement |
	announcement := anAnnouncement asAnnouncement.	
	registry ifNotNil: [
		registry deliver: announcement
		].
	^ announcement! !

!Announcer methodsFor: 'subscription' stamp: ''!
removeSubscription: subscription
	"Remove the given subscription from the receiver"
	
	^ registry remove: subscription! !

!Announcer methodsFor: 'testing' stamp: ''!
handleSubscriberClass: eventClass
	^ self subscriptions 
		ifNil: [ false ]
		ifNotNil: [:subscriptions | subscriptions handleSubscriberClass: eventClass]! !

!Announcer methodsFor: 'accessing' stamp: ''!
subscriptions

	^ registry! !

!Announcer methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionSubscriptions
	<inspectorPresentationOrder: 0 title: 'Subscriptions'>
	| table |
	
	^ (table := SpTablePresenter new)
		items: registry subscriptions asOrderedCollection;
		beMultipleSelection;
		addColumn: (SpStringTableColumn 
			title: 'Subscriber' 
			evaluated: [ :each | each subscriber asString ]);
		addColumn: (SpStringTableColumn 
			title: 'Announcement' 
			evaluated: [ :each | each announcementClass printString ]);
		addColumn: (SpStringTableColumn 
			title: 'Kind' 
			evaluated: [ :each | each className ]);
		"addAction: (GLMGenericAction new
				action: [ :table | self subscriptions reset. table update ]; 
				iconName: #glamorousCancel;
				title: 'Reset All(!!)' translated;
				shouldShowTitle: true);"
		contextMenu: (SpMenuPresenter new 
			addItem: [ :item | item
				name: 'Reset subscription(s)';
				action: [ 
					table selectedItems do: [ :each | self removeSubscription: each ].
					table refresh ] ];
			yourself);
		yourself! !

!AnnouncerSubscriberMockA commentStamp: ''!
I am a mock class for testing in announcers!
!AnnouncerSubscriberMockA methodsFor: 'accessing' stamp: ''!
announcer: anAnnouncer
	announcer := anAnnouncer! !

!AnnouncerSubscriberMockA methodsFor: 'events' stamp: ''!
registerEvents
	self announcer when: AnnouncementMockA do: [ :evt | " something" ].! !

!AnnouncerSubscriberMockA methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer! !

!AnnouncerSubscriberMockB commentStamp: ''!
I am a mock class for testing in announcers!
!AnnouncerTest commentStamp: ''!
An AnnouncerTest is a test class used to test Announcer.

Instance Variables
	announcer:		<Announcer>  the announcer to test

announcer
	- the announcer that is tested
!
!AnnouncerTest methodsFor: 'tests - subscribers' stamp: ''!
testAccessingSubscribers
	| subscribers |
	subscribers := announcer subscriptionsForClass: self class.
	self assert: subscribers size equals: 0.
	
	announcer when: AnnouncementMockA do: [  ]."1"
	announcer when: AnnouncementMockB do: [  ]."2"
	subscribers := announcer subscriptionsForClass: self class.
	self assert: subscribers size equals: 2.
	
	subscribers do: [ :subscriber |	announcer unsubscribe: subscriber ].
	
	subscribers := announcer subscriptionsForClass: self class.
	self assert: subscribers size equals: 0.! !

!AnnouncerTest methodsFor: 'tests - subscribing' stamp: ''!
testSubscribeSetWithExclusionOfSetItem
	| announcement instance |
	announcer
		when: (AnnouncementMockA , AnnouncementMockC) - AnnouncementMockA
		do: [ :ann | announcement := ann ].
	announcement := nil.
	instance := announcer announce: AnnouncementMockA.
	self assert: announcement isNil.
	announcement := nil.
	instance := announcer announce: AnnouncementMockC.
	self assert: announcement equals: instance! !

!AnnouncerTest methodsFor: 'tests - subscribing' stamp: ''!
testSubscribeSet
	| announcement instance |
	announcer
		when: AnnouncementMockA , AnnouncementMockC
		do: [ :ann | announcement := ann ].
	announcement := nil.
	instance := announcer announce: AnnouncementMockA.
	self assert: announcement equals: instance.
	announcement := nil.
	instance := announcer announce: AnnouncementMockB.
	self assert: announcement isNil.
	announcement := nil.
	instance := announcer announce: AnnouncementMockC.
	self assert: announcement equals: instance! !

!AnnouncerTest methodsFor: 'tests - subscribing' stamp: ''!
testAnnounceWorkWithinExceptionHandlerBlocks
	|  found |
	
	announcer when: Announcement do: [ found := true ].
	
	[ NotFound signal ]
		on: NotFound
		do: [ announcer announce: Announcement new ].
		
	self assert: found! !

!AnnouncerTest methodsFor: 'private' stamp: ''!
newAnnouncer
	^ Announcer new! !

!AnnouncerTest methodsFor: 'tests - subscribing' stamp: ''!
testSubscribeClassWithExclusion
	| announcement instance |
	announcer
		when: AnnouncementMockB - AnnouncementMockC
		do: [ :ann | announcement := ann ].
	announcement := nil.
	instance := announcer announce: AnnouncementMockB.
	self assert: announcement equals: instance.
	announcement := nil.
	instance := announcer announce: AnnouncementMockC.
	self assert: announcement isNil! !

!AnnouncerTest methodsFor: 'tests - subscribers' stamp: ''!
testSubscribersForClass
	| subscribers mockA mockB |
	self assert: announcer numberOfSubscriptions equals: 0.
	
	mockA := AnnouncerSubscriberMockA new.
	mockA announcer: announcer.
	mockB := AnnouncerSubscriberMockB new.
	mockB announcer: announcer.
	mockA registerEvents.
	mockB registerEvents.
	
	self assert: announcer numberOfSubscriptions > 0.
	subscribers := announcer subscriptionsForClass: AnnouncerSubscriberMockA.
	self assert: subscribers size equals: 2.
	"AnnouncerSubscriberMockB inherits AnnouncerSubscriberMockA"
	subscribers := announcer subscriptionsForClass: AnnouncerSubscriberMockB.
	self assert: subscribers size equals: 1.
	subscribers := announcer subscriptionsForClass: self class.
	self assert: subscribers size equals: 0.! !

!AnnouncerTest methodsFor: 'tests - unsubscribing' stamp: ''!
testUnsubscribeSet
	| announcement |
	announcer
		when: 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: 'tests' stamp: ''!
testPreparationAnnouncementDeliveryWhenNoSubscriptions

	| instance |
	announcer when: AnnouncementMockA send: #value: to: [ :ann | ].
		
	instance := announcer announce: AnnouncementMockC.
	
	self assert: instance announcingCounter equals: 0! !

!AnnouncerTest methodsFor: 'tests - subscribing' stamp: ''!
testSubscribeBlock
	| announcement instance |
	announcer when: AnnouncementMockA do: [ :ann | announcement := ann ].
	announcement := nil.
	instance := announcer announce: AnnouncementMockA.
	self assert: announcement equals: instance.
	announcement := nil.
	instance := announcer announce: AnnouncementMockB.
	self assert: announcement isNil! !

!AnnouncerTest methodsFor: 'tests - subscribers' stamp: ''!
testHandleSubscriberClass
	announcer when: AnnouncementMockA do: [  ].
	self assert: (announcer handleSubscriberClass: self class).
	self deny: (announcer handleSubscriberClass: AnnouncementMockA).! !

!AnnouncerTest methodsFor: 'tests' stamp: ''!
testNoArgBlock
	"we are supposed to accept zero-argument blocks as actions "

	| counter |
	counter := nil.
	announcer when: AnnouncementMockA do: [ counter := 1 ].
	announcer announce: AnnouncementMockA new.
	self assert: counter equals: 1! !

!AnnouncerTest methodsFor: 'tests - subscribing' stamp: ''!
testSubscribeSetWithExclusion
	| announcement instance |
	announcer
		when: (AnnouncementMockA , AnnouncementMockB) - AnnouncementMockC
		do: [ :ann | announcement := ann ].
	announcement := nil.
	instance := announcer announce: AnnouncementMockA.
	self assert: announcement equals: instance.
	announcement := nil.
	instance := announcer announce: AnnouncementMockB.
	self assert: announcement equals: instance.
	announcement := nil.
	instance := announcer announce: AnnouncementMockC.
	self assert: announcement isNil! !

!AnnouncerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	announcer := self newAnnouncer! !

!AnnouncerTest methodsFor: 'tests' stamp: ''!
testTwoArgBlock
	"we are supposed to accept two-argument blocks as actions "

	| flag |
	flag := false.
	announcer
		when: AnnouncementMockA
		do: [ :ann :announcer2 | flag := announcer2 == announcer ].
	announcer announce: AnnouncementMockA new.
	self assert: flag! !

!AnnouncerTest methodsFor: 'tests - unsubscribing' stamp: ''!
testUnsubscribeSend
	| announcement receiver |
	announcer when: AnnouncementMockA send: #value: to: (receiver := [ :ann | announcement := ann ]).
	announcer unsubscribe: receiver.

	announcement := nil.
	announcer announce: AnnouncementMockA new.
	self assert: announcement isNil! !

!AnnouncerTest methodsFor: 'tests - subscribing' stamp: ''!
testSubscribeOnSpecificAnnouncer
	| announcement instance |
	announcer
		when: (AnnouncementMockB where: [ :ann | ann parameter = #expectedParam ])
		do: [ :ann | announcement := ann ].
	announcement := nil.
	instance := announcer announce: AnnouncementMockA.
	self assert: announcement equals: nil.
	announcement := nil.
	instance := announcer announce: AnnouncementMockB.
	self assert: announcement equals: nil.
	announcement := nil.
	instance := announcer announce: (AnnouncementMockB with: #wrongParam).
	self assert: announcement equals: nil.
	announcement := nil.
	instance := announcer
		announce: (AnnouncementMockB with: #expectedParam).
	self assert: announcement equals: instance.
	announcement := nil.
	instance := announcer
		announce: (AnnouncementMockC with: #expectedParam).
	self assert: announcement equals: instance! !

!AnnouncerTest methodsFor: 'tests - subscribing' stamp: ''!
testSubscribeSend
	| announcement instance |
	announcer when: AnnouncementMockA send: #value: to: [ :ann | announcement := ann ].
		
	announcement := nil.
	instance := announcer announce: AnnouncementMockA.
	self assert: announcement equals: instance.
	
	announcement := nil.
	instance := announcer announce: AnnouncementMockB new.
	self assert: announcement isNil! !

!AnnouncerTest methodsFor: 'tests' stamp: ''!
testSymbolIdentifier
	| passed |
	passed := false.
	
	[announcer 
		when: #FOO send: #bar to: nil;
		announce: #FOO ] 
		on: MessageNotUnderstood 
		do: [ :ex | passed := (ex message selector = #bar). ].
		
	self assert: passed! !

!AnnouncerTest methodsFor: 'tests' stamp: ''!
testAnnouncingReentrant
	"Test that it is safe to announce when handling announcement,
	so announcer are reentrant"
 
	| bool ok |

	ok := bool := false.
	announcer when: 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: 'tests' stamp: ''!
testPreparationAnnouncementDelivery
	| announcement |
	
	announcer when: AnnouncementMockC send: #value: to: [ :ann | #firstBlock ].
	announcer when: AnnouncementMockC send: #value: to: [ :ann | #lastBlock ].	
		
	announcement := AnnouncementMockC new.
	announcer announce: announcement.
	self assert: announcement announcingCounter equals: 1.
	announcer announce: announcement.
	self assert: announcement announcingCounter equals: 2.
	announcement := announcer announce: AnnouncementMockC.
	self assert: announcement announcingCounter equals: 1! !

!AnnouncerTest methodsFor: 'tests' stamp: ''!
testAnnounceInstance
	| instance |
	instance := AnnouncementMockA new.
	self assert: (announcer announce: instance) equals: instance! !

!AnnouncerTest methodsFor: 'tests - subscribing' stamp: ''!
testSubscribeSetWithExclusionOfMultipleAnnouncements
	| announcement instance |
	announcer
		when:
			(AnnouncementMockA , AnnouncementMockB) - AnnouncementMockC
				- AnnouncementMockA
		do: [ :ann | announcement := ann ].
	announcement := nil.
	instance := announcer announce: AnnouncementMockA.
	self assert: announcement isNil.
	announcement := nil.
	instance := announcer announce: AnnouncementMockB.
	self assert: announcement equals: instance.
	announcement := nil.
	instance := announcer announce: AnnouncementMockC.
	self assert: announcement isNil! !

!AnnouncerTest methodsFor: 'tests - subscribing' stamp: ''!
testSubscribeSubclass
	| announcement instance |
	announcer when: AnnouncementMockB do: [ :ann | announcement := ann ].
	announcement := nil.
	instance := announcer announce: AnnouncementMockA.
	self assert: announcement isNil.
	announcement := nil.
	instance := announcer announce: AnnouncementMockB.
	self assert: announcement equals: instance.
	announcement := nil.
	instance := announcer announce: AnnouncementMockC.
	self assert: announcement equals: instance! !

!AnnouncerTest methodsFor: 'tests - unsubscribing' stamp: ''!
testUnsubscribeBlock
	| announcement |
	announcer when: AnnouncementMockA do: [ :ann | announcement := ann ].
	announcer unsubscribe: self.
	announcement := nil.
	announcer announce: AnnouncementMockA new.
	self assert: announcement isNil! !

!AnnouncerTest methodsFor: 'tests' stamp: ''!
testAnnounceClass
	self assert: (announcer announce: AnnouncementMockA) class equals: AnnouncementMockA! !

!AnnouncerTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!ArchitecturalCritique commentStamp: ''!
A TrivialCritique with and extended actions to open a dependency browser for ArchitecturalRule!
!ArchitecturalCritique methodsFor: 'actions' stamp: ''!
actions
	^ super actions copyWith: 
		(RePropertyAction new
			icon: (self iconNamed: #smallWindow);
			description: 'Open dependency analyzer';
			action: [ :crit :package |
				self openDependencyAnalyzerOn: package ];
			yourself)! !

!ArchitecturalCritique methodsFor: 'actions' stamp: ''!
openDependencyAnalyzerOn: package

	^ (DAPackageAnalyzerPackageDependenciesWindow
			onPackagesNamed: {package packageName}) open! !

!Archive commentStamp: ''!
This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.!
!Archive methodsFor: 'archive operations' stamp: 'nil'!
numberOfMembers
	^members size! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
extractMemberWithoutPath: aMemberOrName
	self 
		extractMemberWithoutPath: aMemberOrName
		inDirectory: FileSystem workingDirectory.! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
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: 'nil'!
addFile: aFileReference
	^self addFile: aFileReference as: aFileReference path pathString! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
removeMember: aMemberOrName
	| member |
	member := self member: aMemberOrName.
	member ifNotNil: [ members remove: member ].
	^member! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
contentsOf: aMemberOrName
	| member |
	member := self member: aMemberOrName.
	member ifNil: [ ^nil ].
	^member contents! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
extractMember: aMemberOrName toFileNamed: aFileName
	| member |
	member := self member: aMemberOrName.
	member ifNil: [ ^nil ].
	member extractToFileNamed: aFileName! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
members
	^members! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
addTree: aFileReference relativeTo: relativePath match: aBlock
	| matches |
	matches := aFileReference  entries select: [ :entry | aBlock value: entry ].
	matches
		do: [ :entry | | newMember archiveFilePath |
			archiveFilePath := entry asFileReference relativeTo: relativePath.
			newMember := entry addArchiveMemberAs: archiveFilePath pathString in: self.  			
			entry isDirectory 
				ifTrue: [ self addTree: entry asFileReference relativeTo: relativePath match: aBlock ].
	]! !

!Archive methodsFor: 'private' stamp: 'nil'!
member: aMemberOrName
	^(members includes: aMemberOrName)
		ifTrue: [ aMemberOrName ]
		ifFalse: [ self memberNamed: aMemberOrName ].! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
extractMember: aMemberOrName
	| member |
	member := self member: aMemberOrName.
	member ifNil: [ ^ nil ].
	member
		extractToFileNamed: member localFileName
		inDirectory: FileSystem workingDirectory
		overwrite: true! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
addMember: aMember
	^members addLast: aMember! !

!Archive methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	members := OrderedCollection new.! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
addDirectory: aFileReference as: anotherFileName
	| newMember |
	newMember := self memberClass newFromDirectory: aFileReference localName: anotherFileName.
	self addMember: newMember.
	newMember localFileName: anotherFileName.
	^newMember! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
addString: aString as: aFileName
	| newMember |
	newMember := self memberClass newFromString: aString named: aFileName.
	self addMember: newMember.
	newMember localFileName: aFileName.
	^newMember! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
extractMemberWithoutPath: aMemberOrName inDirectory: dir
	| member |
	member := self member: aMemberOrName.
	member ifNil: [ ^ nil ].
	member extractToFileNamed: member asFileReference basename inDirectory: dir overwrite: true! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
writeTo: aStream
	self subclassResponsibility! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
addFile: aFileReference as: anotherFileName
	| newMember |
	newMember := self memberClass newFromFile: aFileReference.
	newMember localFileName: anotherFileName.
	self addMember: newMember.
	^newMember! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
canWriteToFile: aFileReferenceOrFileName
	"Catch attempts to overwrite existing zip file"
	^(members anySatisfy: [ :each | each usesFile: aFileReferenceOrFileName ]) not.! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
replaceMember: aMemberOrName with: newMember
	| member |
	member := self member: aMemberOrName.
	member ifNotNil: [ members replaceAll: member with: newMember ].
	^member! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
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: 'nil'!
addDirectory: aFileReference
	^self addDirectory: aFileReference as: aFileReference path pathString! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
membersMatching: aString
	^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
memberNames
	^members collect: [ :ea | ea fileName ]! !

!Archive methodsFor: 'archive operations' stamp: 'nil'!
writeToFile: aFileReferenceOrFileName

	"Catch attempts to overwrite existing zip file"
	(self canWriteToFile: aFileReferenceOrFileName)
		ifFalse: [ ^self error: (aFileReferenceOrFileName asString, ' is needed by one or more members in this archive') ].
	
	aFileReferenceOrFileName asFileReference
		binaryWriteStreamDo: [ :stream | self writeTo: stream ]! !

!Archive methodsFor: 'private' stamp: 'nil'!
memberClass
	self subclassResponsibility! !

!ArchiveMember commentStamp: ''!
This is the abstract superclass for archive members, which are files or directories stored in archives.!
!ArchiveMember methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	fileName := ''.
	isCorrupt := false! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nil'!
localFileName: aString
	"Set my internal filename.
	Returns the (possibly new) filename"

	^ fileName := aString
		copyReplaceAll: FileSystem disk delimiter asString
		with: UnixStore delimiter asString! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nil'!
isCorrupt: aBoolean
	"Mark this member as being corrupt."
	isCorrupt := aBoolean! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nil'!
isCorrupt
	^isCorrupt ifNil: [ isCorrupt := false ]! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nil'!
fileName
	^fileName! !

!ArchiveMember methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self fileName;
		nextPut: $)! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nil'!
fileName: aName
	fileName := aName! !

!ArchiveMember methodsFor: 'initialization' stamp: 'nil'!
close! !

!ArchiveMember methodsFor: 'testing' stamp: 'nil'!
usesFile: aFileReferenceOrFileName
	"Do I require aFileName? That is, do I care if it's clobbered?"
	^false! !

!ArchiveMember class methodsFor: 'instance creation' stamp: 'nil'!
newFromFile: aFileName
	self subclassResponsibility! !

!ArchiveMember class methodsFor: 'instance creation' stamp: 'nil'!
newFromString: aString
	self subclassResponsibility! !

!ArchiveMember class methodsFor: 'instance creation' stamp: 'nil'!
newDirectoryNamed: aString
	self subclassResponsibility! !

!ArgumentNamesTest commentStamp: ''!
SUnit tests for generating argument names!
!ArgumentNamesTest methodsFor: 'asserting' stamp: ''!
argumentNameForInstanceOf: aClass shouldBe: aString 
	
	self assert: aClass canonicalArgumentName equals: aString.! !

!ArgumentNamesTest methodsFor: 'asserting' stamp: ''!
argumentNameFor: anObject shouldBe: aString 

	self assert: anObject class canonicalArgumentName equals: aString.! !

!ArgumentNamesTest methodsFor: 'tests' stamp: ''!
testDefault

	self argumentNameForInstanceOf: Object shouldBe: 'anObject'.! !

!ArgumentNamesTest methodsFor: 'tests' stamp: ''!
testInteger

	self argumentNameForInstanceOf: Integer shouldBe: 'anInteger'.! !

!ArgumentNamesTest methodsFor: 'tests' stamp: ''!
testString

	self argumentNameForInstanceOf: String shouldBe: 'aString'.
	self argumentNameForInstanceOf: ByteString shouldBe: 'aString'.! !

!ArgumentNamesTest methodsFor: 'tests' stamp: ''!
testCollection

	self argumentNameForInstanceOf: Collection shouldBe: 'aCollection'.! !

!ArgumentNamesTest methodsFor: 'tests' stamp: ''!
testClass

	self argumentNameForInstanceOf: Class shouldBe: 'aClass'.
	self argumentNameFor: Integer shouldBe: 'aClass'.
	self argumentNameFor: Collection shouldBe: 'aClass'.! !

!ArgumentNamesTest methodsFor: 'tests' stamp: ''!
testAnPrefixForClassNameStartingWithVowel

	self testInteger.! !

!ArgumentNamesTest methodsFor: 'tests' stamp: ''!
testNumber

	self argumentNameForInstanceOf: Number shouldBe: 'aNumber'.
	self argumentNameForInstanceOf: Float shouldBe: 'aNumber'.! !

!ArgumentNamesTest methodsFor: 'tests' stamp: ''!
testAPrefixForClassNameStartingWithConsonant

	self testCollection.! !

!ArgumentVariable commentStamp: ''!
I model argument variables. By definition, an argument variable is always initialized, and can't be written to.!
!ArgumentVariable methodsFor: '*NewTools-Debugger' stamp: ''!
variableTag
	^ 'arg'! !

!ArgumentVariable methodsFor: 'testing' stamp: ''!
isArgumentVariable
	^ true! !

!ArgumentVariable methodsFor: 'debugging' stamp: ''!
writeFromContext: aContext scope: contextScope value: aValue
	self error: 'Arguments are read only'! !

!ArgumentVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitArgumentVariableNode: aNode! !

!ArgumentVariable methodsFor: 'testing' stamp: ''!
isUninitialized

	^ false! !

!ArgumentVariable methodsFor: 'queries' stamp: ''!
definingNode
	^ scope node arguments detect: [ :each | each name = name ]! !

!ArgumentVariable methodsFor: 'testing' stamp: ''!
isWritable

	^ false! !

!ArgumentVariable methodsFor: '*NewTools-Debugger' stamp: ''!
debuggerColor
	^(SHRBTextStyler new attributesFor: #true) first color! !

!ArgumentVariableTest methodsFor: 'tests' stamp: ''!
testUsingMethods

	| method |
	method := Integer >> #+.
	self
		assert: method temporaryVariables first usingMethods first
		equals: method! !

!ArgumentVariableTest methodsFor: 'tests' stamp: ''!
testDeclaringNode
	| method declaringNode declaringNodeViaVariable|
	
	method := OrderedCollection >> #do:.
	declaringNode := method ast arguments first.
	declaringNodeViaVariable := method ast variableReadNodes third variable definingNode.
	self assert: declaringNodeViaVariable equals: declaringNode.
	
	"check block argument"
	declaringNode := method blockNodes first arguments first.
	declaringNodeViaVariable := method ast variableReadNodes fifth variable definingNode.
	self assert: declaringNodeViaVariable equals: declaringNode.! !

!ArgumentsCountMismatch commentStamp: ''!
I am an error that is signalled in a case when a block is invoked with arguments count that does not match the count of arguments of the block.
!
!ArgumentsCountMismatch methodsFor: 'accessing' stamp: ''!
expectedArgumentsCount: anObject
	expectedArgumentsCount := anObject! !

!ArgumentsCountMismatch methodsFor: 'accessing' stamp: ''!
expectedArgumentsCount
	^ expectedArgumentsCount! !

!ArgumentsCountMismatch methodsFor: 'accessing' stamp: ''!
printArgumentsCount: aNumber
			
	^ aNumber printString, ' argument', (aNumber = 1 ifTrue: [''] ifFalse:['s'])! !

!ArgumentsCountMismatch methodsFor: 'accessing' stamp: ''!
calledArgumentsCount
	^ calledArgumentsCount! !

!ArgumentsCountMismatch methodsFor: 'accessing' stamp: ''!
calledArgumentsCount: anObject
	calledArgumentsCount := anObject! !

!ArgumentsCountMismatch methodsFor: 'accessing' stamp: ''!
messageText

	^ 'This block accepts ', (self printArgumentsCount: expectedArgumentsCount),  
			', but was called with ', (self printArgumentsCount: calledArgumentsCount), '.'! !

!ArgumentsCountMismatch class methodsFor: 'signalling' stamp: ''!
signalExpectedArgumentsCount: expected calledArgumentsCount: called 

	self new 
		expectedArgumentsCount: expected;
		calledArgumentsCount: called;
		signal! !

!ArithmeticError commentStamp: ''!
I am ArithmeticError, the superclass of all exceptions related to arithmetic.!
!Array commentStamp: ''!
Array is a fixed-sized collection of elements accessed by integer indices. Contrary to the C convention, the first element of a Pharo array is at position 1 and not 0. The main protocol to access array elements is the method `at:` and `at:put:`. 

- `at: anInteger` returns the element at index anInteger. 
- `at: anInteger put: anObject` puts `anObject` at index `anInteger`. 

Arrays are fixed-size collections therefore we cannot add or remove elements at the end of an array. 

The following code creates an array of size 5, puts values in the first 3 locations and returns the first element.

``` 
| anArray |
anArray := Array new: 5. 
anArray at: 1 put: 4. 
anArray at: 2 put: 3/2. 
anArray at: 3 put: 'ssss'. 
anArray at: 1			
>>> 4
```

`#()` creates literal arrays with static (or “literal”) elements that have to be known when the expression is compiled, and not when it is executed. 

The following code creates an array of size 2 where the first element is the (literal) number 1 and the second the (literal) string 'here'.

``` 
#(1 'here') size 
> 2
```

`{ }` is a way to create arrays in a more dynamic manner.

``` 
| array |
array := (Array new: 2). 
array
	at: 1 put: (Point x: 10 y: 20);
	at: 2 put: (Point x: 10 y: 20). 
	array			
```

is equivalent to 

```
{(10@20) . (10@20)}
{Point x: 10 y: 20 . Point x: 10 y: 20}
```
!
!Array methodsFor: '*Collections-arithmetic' stamp: ''!
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: 'converting' stamp: 'nil'!
elementsForwardIdentityTo: otherArray
	"This primitive performs a bulk mutation, causing all pointers to the elements of the
	 receiver 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."
	<primitive: 72 error: ec>
	self primitiveFailed! !

!Array methodsFor: 'comparing' stamp: 'nil'!
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: '*Collections-arithmetic' stamp: ''!
preMultiplyByMatrix: m
	"Answer m+*self where m is a Matrix."

	m numberOfColumns = self size ifFalse: [self error: 'dimensions do not conform'].
	^ (1 to: m numberOfRows) 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-Core' stamp: ''!
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: 'converting' stamp: 'nil'!
asArray
	"Answer with the receiver itself."

	^ self! !

!Array methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	self shouldBePrintedAsLiteral ifTrue: [self printAsLiteralFormOn: aStream. ^ self].
	self isSelfEvaluating ifTrue: [self printAsSelfEvaluatingFormOn: aStream. ^ self].

	super printOn: aStream! !

!Array methodsFor: 'self evaluating' stamp: 'nil'!
isSelfEvaluating
	^ (self allSatisfy: [:each | each isSelfEvaluating]) and: [self class == Array]! !

!Array methodsFor: 'accessing' stamp: 'nil'!
atWrap: index put: anObject
	"Optimized to go through the primitive if possible"
	<primitive: 61>
	^ self at: index - 1 \\ self size + 1 put: anObject! !

!Array methodsFor: '*ParametrizedTests' stamp: ''!
asTestMatrix

	| matrix |
	matrix := ParametrizedTestMatrix new.
	self do: [ :e | matrix addCase: e ].
	^ matrix! !

!Array methodsFor: 'converting' stamp: 'nil'!
elementsExchangeIdentityWith: otherArray
	"This primitive performs a bulk mutation, causing all pointers to the elements of the
	 receiver 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."

	<primitive: 128 error: ec>
	| minimalRequiredSize |
	ec == #'bad receiver' ifTrue:
		[^self error: 'receiver must be of class Array'].
	ec == #'bad argument' ifTrue:
		[^self error: (otherArray class == Array
						ifTrue: ['arg must be of class Array']
						ifFalse: ['receiver and argument must have the same size'])].
	ec == #'inappropriate operation' ifTrue:
		[^self error: 'can''t become immediates such as SmallIntegers or Characters'].
	ec == #'no modification' ifTrue:
		[^self error: 'can''t become immutable objects'].
	ec == #'object is pinned' ifTrue:
		[^self error: 'can''t become pinned objects'].
	ec == #'insufficient object memory' ifTrue:
		[
			minimalRequiredSize := 
				(self sumNumbers: [ :anElement | anElement sizeInMemory ]) 
				+ (otherArray sumNumbers: [ :anElement | anElement sizeInMemory ]).
			
			Smalltalk garbageCollect < minimalRequiredSize ifTrue:
				[ (Smalltalk growMemoryByAtLeast: minimalRequiredSize) < minimalRequiredSize ifTrue:[
					self error: 'Could not allocate enought memory for two way become']].
		
		 ^self elementsExchangeIdentityWith: otherArray].
	self primitiveFailed! !

!Array methodsFor: 'literal testing' stamp: 'nil'!
shouldBePrintedAsLiteral

	^self class == Array and: [ self allSatisfy: [ :each | each shouldBePrintedAsLiteral ] ]! !

!Array methodsFor: '*TraitsV2' stamp: ''!
asTraitComposition
	^ self isEmpty
		ifTrue: [ TaEmptyComposition new ]
		ifFalse: [ TaSequence withAll: (self collect: [:each | each asTraitComposition]) ]! !

!Array methodsFor: '*Spec-Core' stamp: ''!
generateSpec
	| str spec |
	str := self readStream.	
	
	spec :=  OrderedCollection with: #SpecLayoutFrame.
		
	#( leftFraction: topFraction: rightFraction: bottomFraction: leftOffset: topOffset: rightOffset: bottomOffset: ) do: [:sel |
		spec add: sel.
		str next ifNil: [ spec add: 0 ] ifNotNil: [:value | spec add: value ]].
	^ spec asArray! !

!Array methodsFor: 'self evaluating' stamp: 'nil'!
printAsSelfEvaluatingFormOn: aStream

	aStream nextPut: ${.
	self do: [:el | el printOn: aStream] separatedBy: [ aStream nextPutAll: '. '].
	aStream nextPut: $}! !

!Array methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
displayString

	^ super displayString contractTo: 200! !

!Array methodsFor: 'literal testing' stamp: 'nil'!
refersToLiteral: literal
	^ (self literalEqual: literal) 
		or: [ self hasLiteral: literal ]! !

!Array methodsFor: 'testing' stamp: 'nil'!
isLiteral
	^self class == Array and: [self allSatisfy: [:each | each isLiteral]]! !

!Array methodsFor: 'copying' stamp: 'nil'!
copyWithDependent: newElement

	self isEmpty ifTrue: [ ^ DependentsArray with: newElement ].
	^ self copyWith: newElement! !

!Array methodsFor: 'enumerating' stamp: 'nil'!
recursiveDo: aBlock

	"execute the block for my content like do, but then recurse into nested arrays"

	self do: [ :each | 
		aBlock value: each.
		each isArray ifTrue: [ each recursiveDo: aBlock ] ]! !

!Array methodsFor: 'converting' stamp: 'nil'!
elementsForwardIdentityTo: otherArray copyHash: copyHash
	"This primitive performs a bulk mutation, causing all pointers to the elements of the
	 receiver to be replaced by pointers to the corresponding elements of otherArray.
	 If copyHash is true, the identityHashes remain with the pointers rather than with the
	 objects so that the objects in the receiver should still be properly indexed in any
	 existing hashed structures after the mutation.  If copyHash is false, then the hashes
	 of the objects in otherArray remain unchanged.  If you know what you're doing this
	 may indeed be what you want."
	<primitive: 249 error: ec>
	self primitiveFailed! !

!Array methodsFor: 'accessing' stamp: 'nil'!
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."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !

!Array methodsFor: 'literal testing' stamp: 'nil'!
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: 'write barrier' stamp: 'nil'!
beReadOnlyLiteral
	self isLiteral ifFalse: [ ^ self ].
	self beReadOnlyObject.
	self do: [ :each | each beReadOnlyLiteral ]! !

!Array methodsFor: '*Collections-arithmetic' stamp: ''!
+* 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: '*Morphic-Base' stamp: ''!
asLayoutFrame
	 ^ LayoutFrame new fromArray: self! !

!Array methodsFor: '*Fuel-Core' stamp: ''!
fuelReplacement
	^ self == Smalltalk specialObjectsArray
		ifTrue: [ nil ]
		ifFalse: [ self ]! !

!Array methodsFor: '*Roassal3-Shapes' stamp: ''!
asShapeFor: model
	^ RSComposite new 
		model: model;
		shapes: self;
		yourself! !

!Array methodsFor: 'self evaluating' stamp: 'nil'!
printAsLiteralFormOn: aStream
	aStream nextPut: $#.
	self printElementsOn: aStream! !

!Array methodsFor: '*System-Settings-Browser' stamp: ''!
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: '*Roassal3-Shapes' stamp: ''!
asShape
	^ self asShapeFor: nil! !

!Array methodsFor: 'accessing' stamp: 'nil'!
atWrap: index 

    "Answer the index'th element of the receiver.  If index is out of bounds,
    let it wrap around from the end to the beginning until it is in bounds."
    
    "Optimized to go through the primitive if possible"
    
    "(#(11 22 33) atWrap: 3) >>> 33"
    "(#(11 22 33) atWrap: 2) >>> 22"
    "(#(11 22 33) atWrap: 4) >>> 11"
    
    <primitive: 60>
    ^ self at: index - 1 \\ self size + 1! !

!Array methodsFor: 'literal testing' stamp: 'nil'!
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: 'printing' stamp: 'nil'!
storeOn: aStream

	"Use the literal form if possible."

	self shouldBePrintedAsLiteral
		ifTrue: [ 
			aStream
				nextPut: $#;
				nextPut: $(.
			self
				do: [ :element | element storeOn: aStream ]
				separatedBy: [ aStream space ].
			aStream nextPut: $) ]
		ifFalse: [ super storeOn: aStream ]! !

!Array methodsFor: 'testing' stamp: 'nil'!
isArray
	^true! !

!Array class methodsFor: 'instance creation' stamp: 'nil'!
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"

	<primitive: 71>  "This method runs primitively if successful"
	^ self basicNew: sizeRequested  "Exceptional conditions will be handled in basicNew:"! !

!Array class methodsFor: 'instance creation' stamp: 'nil'!
empty
	"A canonicalized empty Array instance."
	^ #()! !

!Array class methodsFor: 'brace support' stamp: 'nil'!
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: 'nil'!
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: 'nil'!
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: 'nil'!
braceWithNone
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	^ self new: 0! !

!Array class methodsFor: 'brace support' stamp: 'nil'!
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: 'nil'!
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! !

!Array2D commentStamp: ''!
I represent a mathematical matrix or a two-dimensional array. I provide methods for creating matrices, operating on them arithmetically and algebraically. 

Structure:
 - numberOfRows : a non-negative integer saying how many rows there are.
 - numberOfColumns : a non-negative integer saying how many columns there are.
 - contents : an Array holding the elements in row-major order.  That is, for a 2x3 array the contents are (11 12 13 21 22 23).  


Element-wise matrix arithmetic works; you can freely mix matrices and numbers but
don't try to mix matrices and arrays (yet).
Matrix multiplication, using the symbol +* (derived from APL's +.x), works between
(Matrix or Array) +* (Matrix or Array).  Don't try to use a number as an argument of +*.
Matrix * Number and Number * Matrix work fine, so you don't need +* with numbers.
!
!Array2D methodsFor: 'removing' stamp: 'nil'!
remove: anObject ifAbsent: anExceptionBlock
	self shouldNotImplement! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asByteArray
	^ contents asByteArray! !

!Array2D methodsFor: 'testing' stamp: 'nil'!
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! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
anyOne
	"Return one element from the receiver"
	^ contents anyOne! !

!Array2D methodsFor: 'testing' stamp: 'nil'!
includes: anObject
	^ contents includes: anObject! !

!Array2D methodsFor: 'accessing - submatrices' stamp: 'nil'!
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! !

!Array2D methodsFor: 'comparing' stamp: 'nil'!
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! !

!Array2D methodsFor: 'testing' stamp: 'nil'!
includesAll: aCollection
	^ contents includesAll: aCollection! !

!Array2D methodsFor: 'testing' stamp: 'nil'!
occurrencesOf: anObject
	^ contents occurrencesOf: anObject! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asBag
	^ contents asBag! !

!Array2D methodsFor: 'arithmetic' stamp: 'nil'!
preMultiplyByMatrix: m
	"Answer m +* self where m is a Matrix."
	|s|
	numberOfRows = m numberOfColumns ifFalse: [self error: 'dimensions do not conform'].
	^ Array2D 
		rows: m numberOfRows 
		columns: numberOfColumns 
		tabulate: [:row :col |
			s := 0.
			1 to: numberOfRows do: [:k | s := (m at: row at: k) * (self at: k at: col) + s].
			s ]! !

!Array2D methodsFor: 'row/column operations' stamp: 'nil'!
atRow: rowNumber
	(rowNumber between: 1 and: numberOfRows)
		ifFalse: [self error: '1st subscript out of range'].
	^ contents 
			copyFrom: (rowNumber - 1) * numberOfColumns + 1 
			to: rowNumber*numberOfColumns! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asCharacterSet
	^ contents asCharacterSet! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
do: aBlock
	"Pass elements to aBlock one at a time in row-major order."
	contents do: aBlock! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
at: rowNumber at: columnNumber ifInvalid: value
	"If rowNumber,columnNumber is a valid index for the receiver, answer the corresponding element. Otherwise, answer value."

	(rowNumber between: 1 and: numberOfRows) ifFalse: [ ^ value ].
	(columnNumber between: 1 and: numberOfColumns) ifFalse: [ ^ value ].
	^contents at: (rowNumber - 1) * numberOfColumns + columnNumber! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
columnCount
	^ numberOfColumns! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
withIndicesDo: aBlock
	
	| i |
	i := 0.
	1 to: numberOfRows do: [:row |
		1 to: numberOfColumns do: [:column |
			aBlock value: (contents at: (i := i+1)) value: row value: column]].! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
collect: aBlock
	"Answer a new matrix with transformed elements; transformations should be independent."

	^self class 
		rows: numberOfRows 
		columns: numberOfColumns 
		contents: (contents collect: aBlock)! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
indicesDo: aBlock
	1 to: numberOfRows do: [ :row |
		1 to: numberOfColumns do: [ :column |
			aBlock value: row value: column]].! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
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)]! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
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. 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]! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asIdentitySet
	^ contents asIdentitySet! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
at: rowNumber at: columnNumber incrementBy: value
	"Add a value to the element available at rowNumber,columNumber."

	^ contents at: (self indexForRow: rowNumber andColumn: columnNumber) incrementBy: value! !

!Array2D methodsFor: 'private' stamp: 'nil'!
indexForRow: row andColumn: column
	(row between: 1 and: numberOfRows)
		ifFalse: [self error: '1st subscript out of range'].
	(column between: 1 and: numberOfColumns)
		ifFalse: [self error: '2nd subscript out of range'].
	^(row-1) * numberOfColumns + column! !

!Array2D methodsFor: 'row/column operations' stamp: 'nil'!
swapRow: anIndex withRow: anotherIndex
	| a b |
	a := self indexForRow: anIndex andColumn: 1.
	b := self indexForRow: anotherIndex andColumn: 1.
	numberOfColumns timesRepeat: [
		contents swap: a with: b.
		a := a + 1.
		b := b + 1].! !

!Array2D methodsFor: 'copying' stamp: 'nil'!
postCopy
	super postCopy.
	contents := contents copy! !

!Array2D methodsFor: 'copying' stamp: 'nil'!
shuffledBy: aRandom
	^self class rows: numberOfRows columns: numberOfColumns contents: (contents copy shuffleBy: aRandom)! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
at: rowNumber at: columnNumber put: value
	"Put value at rowNumber,columnNumber"
	^ contents at: (self indexForRow: rowNumber andColumn: columnNumber) put: value! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asSortedCollection: aBlock
	^ contents asSortedCollection: aBlock! !

!Array2D methodsFor: 'random' stamp: 'nil'!
atRandom: aGenerator
	^ contents atRandom: aGenerator! !

!Array2D methodsFor: 'arithmetic' stamp: 'nil'!
+* 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! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
extent
    "Answer the receiver's dimensions as point."

    ^ self numberOfColumns @ self numberOfRows! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
identityIndexOf: anElement
	
	^ self identityIndexOf: anElement ifAbsent: [ 0@0 ]! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asWordArray
	^ contents asWordArray! !

!Array2D methodsFor: 'removing' stamp: 'nil'!
removeAll

	self shouldNotImplement! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
size
	^ contents size! !

!Array2D methodsFor: 'private' stamp: 'nil'!
rowAndColumnForIndex: index
	|t|

	t := index - 1.
	^(t // numberOfColumns + 1)@(t \\ numberOfColumns + 1)! !

!Array2D methodsFor: 'private' stamp: 'nil'!
privateContents
	"Only used in #, #,, and #= so far.
	 It used to be called #contents, but that clashes with Collection>>contents."

	^ contents! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
rowCount
	^numberOfRows! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
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)].! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
at: rowNumber at: columnNumber
	^ contents at: (self indexForRow: rowNumber andColumn: columnNumber)! !

!Array2D methodsFor: 'arithmetic' stamp: 'nil'!
preMultiplyByArray: a
	"Answer a +* self where a is an Array."

	numberOfRows = 1 ifFalse: [self error: 'dimensions do not conform'].
	^Array2D rows: a size columns: numberOfColumns tabulate: [:row :col |
		(a at: row) * (contents at: col)]! !

!Array2D methodsFor: 'accessing - submatrices' stamp: 'nil'!
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]! !

!Array2D methodsFor: 'comparing' stamp: 'nil'!
= aMatrix
	^ aMatrix class == self class
		and: [ aMatrix numberOfRows = numberOfRows
				and: [ aMatrix numberOfColumns = numberOfColumns 
					and: [ aMatrix privateContents = contents ] ] ]! !

!Array2D methodsFor: 'adding' stamp: 'nil'!
add: newObject
	self shouldNotImplement! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
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)]! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
indicesCollect: aBlock
	
	| r i |
	r := Array new: numberOfRows * numberOfColumns.
	i := 0.
	1 to: numberOfRows do: [:row |
		1 to: numberOfColumns do: [:column |
			r at: (i := i+1) put: (aBlock value: row value: column)]].
	^ self class rows: numberOfRows columns: numberOfColumns contents: r! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
select: aBlock
	self shouldNotImplement! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
withIndicesInject: start into: aBlock
	
	| i current |
	i := 0.
	current := start.
	1 to: numberOfRows do: [ :row |
		1 to: numberOfColumns do: [ :column |
			current := aBlock 
								value: current 
								value: (contents at: (i := i+1)) 
								value: row value: column ] ].
	^ current! !

!Array2D methodsFor: 'copying' stamp: 'nil'!
,, 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."

	[numberOfColumns = aMatrix numberOfColumns] assert.
	^self class 
			rows: numberOfRows + aMatrix numberOfRows 
			columns: numberOfColumns
			contents: contents , aMatrix privateContents! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
indicesInject: start into: aBlock

	|current|
	current := start.
	1 to: numberOfRows do: [ :row |
		1 to: numberOfColumns do: [ :column |
			current := aBlock value: current value: row value: column ] ].
	^ current! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asArray
	^ contents shallowCopy! !

!Array2D methodsFor: 'row/column operations' stamp: 'nil'!
atRow: row put: aCollection
	|p|

	aCollection size = numberOfColumns ifFalse: [self error: 'wrong row size'].
	p := (self indexForRow: row andColumn: 1)-1.
	aCollection do: [:each | contents at: (p := p+1) put: each].
	^aCollection! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
identityIndexOf: anElement ifAbsent: anExceptionBlock
	^self rowAndColumnForIndex:
		 (contents identityIndexOf: anElement ifAbsent: [^anExceptionBlock value])! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
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])! !

!Array2D methodsFor: 'printing' stamp: 'nil'!
printOn: aStream

	aStream nextPutAll: '('.
	(1 to: self numberOfRows) 
		do: [ :r | 
				(self atRow: r) 
					do: [ :each | aStream print: each ] 
					separatedBy: [ aStream space ]]
		separatedBy: [ aStream cr ].
	aStream nextPutAll: ' )'.! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
numberOfRows
	^ numberOfRows! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asFloatArray
	^ contents asFloatArray! !

!Array2D methodsFor: 'copying' stamp: 'nil'!
shuffled
	^self class rows: numberOfRows columns: numberOfColumns contents: (contents shuffled)! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
atAllPut: value
	"Put value as value of all the receiver elements."
	contents atAllPut: value! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
withIndicesCollect: aBlock
	
	|i r|
	i := 0.
	r := contents shallowCopy.
	1 to: numberOfRows do: [ :row |
		1 to: numberOfColumns do: [ :column |
			i := i+1.
			r at: i put: (aBlock value: (r at: i) value: row value: column)]].
	^ self class rows: numberOfRows columns: numberOfColumns contents: r! !

!Array2D methodsFor: 'row/column operations' stamp: 'nil'!
atColumn: column put: aCollection
	| p |
	aCollection size = numberOfRows ifFalse: [ self error: 'wrong column size' ].
	p := (self indexForRow: 1 andColumn: column) - numberOfColumns.
	aCollection do: [ :each | contents at: (p := p + numberOfColumns) put: each ].
	^ aCollection! !

!Array2D methodsFor: 'testing' stamp: 'nil'!
identityIncludes: anObject
	^ contents identityIncludes: anObject! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
reject: aBlock
	self shouldNotImplement! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
readStream
	"Answer a ReadStream that returns all the elements of the receiver in some UNSPECIFIED order."
	^ contents readStream! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
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! !

!Array2D methodsFor: 'row/column operations' stamp: 'nil'!
swapColumn: anIndex withColumn: anotherIndex
	|a b|

	a := self indexForRow: 1 andColumn: anIndex.
	b := self indexForRow: 1 andColumn: anotherIndex.
	numberOfRows timesRepeat: [
		contents swap: a with: b.
		a := a + numberOfColumns.
		b := b + numberOfColumns].! !

!Array2D methodsFor: 'accessing - submatrices' stamp: 'nil'!
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)]! !

!Array2D methodsFor: 'row/column operations' stamp: 'nil'!
transposed
	[numberOfRows = numberOfColumns] assert.
	^ self indicesCollect: [ :row :column | self at: column at: row ]! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
swap: r1 at: c1 with: r2 at: c2
	contents swap: (self indexForRow: r1 andColumn: c1)
			 with: (self indexForRow: r2 andColumn: c2)! !

!Array2D methodsFor: 'accessing - submatrices' stamp: 'nil'!
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]! !

!Array2D methodsFor: 'random' stamp: 'nil'!
atRandom
	"Return the contents of the receiver in a random order."
	^ contents atRandom! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
numberOfColumns: anObject
	numberOfColumns := anObject! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asSet
	^ contents asSet! !

!Array2D methodsFor: 'private' stamp: 'nil'!
rows: rows columns: columns contents: anArray
	[rows isInteger and: [rows >= 0]] assert.
	[columns isInteger and: [columns >= 0]] assert.
	[rows * columns = anArray size] assert.
	numberOfRows := rows.
	numberOfColumns := columns.
	contents := anArray.
	^self! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
numberOfColumns
	^ numberOfColumns! !

!Array2D methodsFor: 'row/column operations' stamp: 'nil'!
atColumn: column

	|p|
	p := (self indexForRow: 1 andColumn: column)-numberOfColumns.
	^(1 to: numberOfRows) collect: [:row | contents at: (p := p+numberOfColumns)]! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
replaceAll: oldObject with: newObject
	"Replace all occurrences of oldObject with newObject in the receiver."
	contents replaceAll: oldObject with: newObject! !

!Array2D methodsFor: 'testing' stamp: 'nil'!
includesAny: aCollection
	^ contents includesAny: aCollection! !

!Array2D methodsFor: 'copying' stamp: 'nil'!
, 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|

	[numberOfRows = aMatrix numberOfRows] assert.
	newCont := Array new: self size + aMatrix size.
	anArray := aMatrix privateContents.
	oldCols := aMatrix numberOfColumns.
	newCols := numberOfColumns + oldCols.
	a := b := c := 1.
	1 to: numberOfRows do: [:r |
		newCont replaceFrom: a to: a + numberOfColumns - 1 with: contents startingAt: b.
		newCont replaceFrom: a+numberOfColumns to: a + newCols - 1 with: anArray startingAt: c.
		a := a + newCols.
		b := b + numberOfColumns.
		c := c + oldCols].
	^self class rows: numberOfRows columns: newCols contents: newCont! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asIntegerArray
	^ contents asIntegerArray! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asOrderedCollection
	^ contents asOrderedCollection! !

!Array2D methodsFor: 'enumerating' stamp: 'nil'!
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! !

!Array2D methodsFor: 'printing' stamp: 'nil'!
storeOn: aStream
	aStream nextPut: $(; nextPutAll: self class name;
		nextPutAll: ' rows: '; store: numberOfRows;
		nextPutAll: ' columns: '; store: numberOfColumns;
		nextPutAll: ' contents: '; store: contents;
		nextPut: $)! !

!Array2D methodsFor: 'accessing' stamp: 'nil'!
numberOfRows: anObject
	numberOfRows := anObject! !

!Array2D methodsFor: 'converting' stamp: 'nil'!
asSortedCollection
	^ contents asSortedCollection! !

!Array2D methodsFor: 'row/column operations' stamp: 'nil'!
diagonal
	"Answer (1 to: (numberOfRows min: numberOfColumns)) collect: [:i | self at: i at: i]"
	|i|
	i := numberOfColumns negated.
	^ (1 to: (numberOfRows min: numberOfColumns)) collect: [:j | contents at: (i := i + numberOfColumns + 1)]! !

!Array2D class methodsFor: 'instance creation' stamp: 'nil'!
new: dimemsion element: element
	"Answer a dimemsion*dimemsion matrix with all elements set to element."

	^ self rows: dimemsion columns: dimemsion element: element! !

!Array2D class methodsFor: 'special instance creation' stamp: 'nil'!
ones: dimension
	"Create a squared matrix of dimension full of 1"
	^ self new: dimension element: 1! !

!Array2D class methodsFor: 'special instance creation' stamp: 'nil'!
zeros: dimension
	"Create a Matrix of dimensionxdimemsion"
	^ self new: dimension element: 0! !

!Array2D class methodsFor: 'instance creation' stamp: 'nil'!
new: dimension
	"Answer a dimension*dimension matrix."
	^ self rows: dimension columns: dimension! !

!Array2D class methodsFor: 'private' stamp: 'nil'!
rows: rowNumber columns: columnNumber contents: contents
	"Private!! Creates a Matrix of the given size with an adequate contents."
	^ self new rows: rowNumber columns: columnNumber contents: contents! !

!Array2D class methodsFor: 'special instance creation' stamp: 'nil'!
rowVector: aCollection
	"Create a matrix of one row having aCollection as contents"

	^self rows: 1 columns: aCollection size contents: aCollection asArray shallowCopy! !

!Array2D class methodsFor: 'special instance creation' stamp: 'nil'!
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! !

!Array2D class methodsFor: 'instance creation' stamp: 'nil'!
rows: rowNumber columns: columnNumber element: element
	"Create a Matrix of rowNumber rows and columnNumber columns filled with element."
	^ self 
		rows: rowNumber 
		columns: columnNumber
		contents: ((Array new: rowNumber * columnNumber) atAllPut: element; yourself)! !

!Array2D class methodsFor: 'special instance creation' stamp: 'nil'!
identity: n
	| r |
	r := self zeros: n.
	1 to: n do: [ :i | r at: i at: i put: 1 ].
	^ r! !

!Array2D class methodsFor: 'instance creation' stamp: 'nil'!
rows: rowNumber columns: columnNumber
	"Create a Matrix of rowNUmber rows and columnNumber columns."
	^ self 
		rows: rowNumber 
		columns: columnNumber 
		contents: (Array new: rowNumber*columnNumber)! !

!Array2D class methodsFor: 'instance creation' stamp: 'nil'!
new: dimension tabulate: aTwoArgumentBlock
	"Answer a dimension*dimension matrix where it at: i at: j is aBlock value: i value: j."
	^ self rows: dimension columns: dimension tabulate: aTwoArgumentBlock! !

!Array2D class methodsFor: 'instance creation' stamp: 'nil'!
rows: rowNumber columns: columnNumber tabulate: aTwoArgumentBlock
	"Answer a new Matrix of the given dimensions where
	 result at: i at: j is aTwoArgumentBlock value: i value: j"
	|a i|
	a := Array new: rowNumber*columnNumber.
	i := 0.
	1 to: rowNumber do: [:row |
		1 to: columnNumber do: [:column |
			a at: (i := i + 1) put: (aTwoArgumentBlock value: row value: column)]].
	^ self rows: rowNumber columns: columnNumber contents: a! !

!Array2D class methodsFor: 'special instance creation' stamp: 'nil'!
columnVector: aCollection
	"Create a matrix of one column having aCollection as contents"

	^ self rows: aCollection size columns: 1 contents: aCollection asArray shallowCopy! !

!Array2DTest commentStamp: ''!
SUnit tests for matrix!
!Array2DTest methodsFor: 'tests - instance creation' stamp: ''!
testDiagonal

	| m m2 | 

	m := Array2D diagonal: #(1 2 3 4 5).

	self assert: m numberOfColumns equals: 5.
	self assert: m numberOfRows equals: 5.
	self assert: (m occurrencesOf: 0) equals: 20.
	1 to: 5 do: [ :i |
		self assert: (m at: i at: i) equals: i.].

	m2 := Array2D diagonal: Array new.

	self assert: m2 numberOfColumns equals: 0.
	self assert: m2 numberOfRows equals: 0.! !

!Array2DTest methodsFor: 'tests - instance creation' stamp: ''!
testIdentity
	| m m2 |
	m := Array2D new: 3 element: 0.
	m at: 1 at: 1 put: 1.
	m at: 2 at: 2 put: 1.
	m at: 3 at: 3 put: 1.
	self assert: (m occurrencesOf: 1) equals: 3.
	m2 := Array2D identity: 3.
	self assert: m2 equals: m! !

!Array2DTest methodsFor: 'tests - instance creation' stamp: ''!
testIdentityOtherTest

	| m | 
	m := Array2D identity: 3.
	self assert: (m at: 1 at:1) equals: 1.
	self assert: (m at: 2 at:2) equals: 1.
	self assert: (m at: 3 at:3) equals: 1.
	self assert: (m occurrencesOf: 1) equals: 3.! !

!Array2DTest methodsFor: 'tests - testing' stamp: ''!
testIncludes
	self assert:
			((1 to: 4)
				allSatisfy: [:i | matrix1 includes: i])! !

!Array2DTest methodsFor: 'tests - arithmetic' stamp: ''!
testMultiply
	| result |
	self should: [ matrix1 preMultiplyByMatrix: (Array2D new: 3) ] raise: Error.

	result := matrix2 preMultiplyByMatrix: matrix1.
	self assert: (result at: 1 at: 1) equals: 15.
	self assert: (result at: 1 at: 2) equals: 31.
	self assert: (result at: 2 at: 1) equals: 22.
	self assert: (result at: 2 at: 2) equals: 46! !

!Array2DTest methodsFor: 'tests - accessing' stamp: ''!
testSquaredWithAllElement

	self assert: ((Array2D new: 3 element: -1) occurrencesOf: -1) equals: 9.! !

!Array2DTest methodsFor: 'tests - instance creation' stamp: ''!
testColumnVector

	| m m2 | 

	m := Array2D columnVector: #(1 2 3 4 5).

	self assert: m numberOfColumns equals: 1.
	self assert: m numberOfRows equals: 5.
	1 to: 5 do: [ :i |
		self assert: (m at: i at: 1) equals: i.].

	m2 := Array2D columnVector: Array new.

	self assert: m2 numberOfColumns equals: 1.
	self assert: m2 numberOfRows equals: 0.! !

!Array2DTest methodsFor: 'tests - testing' stamp: ''!
testTabulateEquals
	| m |
	m := Array2D rows: 3 columns: 2 tabulate: [ :row :column | column * 10 + row ].
	self assert: m equals: matrix23! !

!Array2DTest methodsFor: 'tests - accessing' stamp: ''!
testContentsEncodings

	self assert: matrix23 privateContents equals: #(11 21 12 22 13 23)! !

!Array2DTest methodsFor: 'tests - testing' stamp: ''!
testTabulate
	| m |
	m := Array2D rows: 3 columns: 2 tabulate: [ :row :column | column * 10 + row ].
	self assert: (m at: 1 at: 1) equals: 11.
	self assert: (m at: 1 at: 2) equals: 21.
	self assert: (m at: 2 at: 1) equals: 12.
	self assert: (m at: 2 at: 2) equals: 22.
	self assert: (m at: 3 at: 1) equals: 13.
	self assert: (m at: 3 at: 2) equals: 23.! !

!Array2DTest methodsFor: 'tests - instance creation' stamp: ''!
testRowVector

	| m m2 | 

	m := Array2D rowVector: #(1 2 3 4 5).

	self assert: m numberOfColumns equals: 5.
	self assert: m numberOfRows equals: 1.
	1 to: 5 do: [ :i |
		self assert: (m at: 1 at: i) equals: i.].

	m2 := Array2D rowVector: Array new.

	self assert: m2 numberOfColumns equals: 0.
	self assert: m2 numberOfRows equals: 1.! !

!Array2DTest methodsFor: 'tests - accessing' stamp: ''!
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) equals: 1.
	self assert: (matrix23 at: 1 at: 1) equals: 11.
	self assert: (matrix23 at: 1 at: 2) equals: 21.
	self assert: (matrix23 at: 2 at: 1) equals: 12.
	self assert: (matrix23 at: 2 at: 2) equals: 22.
	self assert: (matrix23 at: 3 at: 1) equals: 13.
	self assert: (matrix23 at: 3 at: 2) equals: 23.! !

!Array2DTest methodsFor: 'tests - accessing' stamp: ''!
testTransposed
	| transposedMatrix |
	transposedMatrix := matrix1 transposed.
	self assert: (transposedMatrix at: 1 at: 1) equals: 1.
	self assert: (transposedMatrix at: 1 at: 2) equals: 2.
	self assert: (transposedMatrix at: 2 at: 1) equals: 3.
	self assert: (transposedMatrix at: 2 at: 2) equals: 4! !

!Array2DTest methodsFor: 'tests - accessing' stamp: ''!
testAtRow

	self assert: (matrix23 atRow: 1) equals: #(11 21).
	self assert: (matrix23 atRow: 2) equals: #(12 22).
	self assert: (matrix23 atRow: 3) equals: #(13 23).! !

!Array2DTest methodsFor: 'tests - instance creation' stamp: ''!
testOnes

	| m m2 | 

	m := Array2D ones: 10.

	self assert: m numberOfColumns equals: 10.
	self assert: m numberOfRows equals: 10.
	self assert: (m occurrencesOf: 1) equals: (10*10).

	m2 := Array2D ones: 0.

	self assert: m2 numberOfColumns equals: 0.
	self assert: m2 numberOfRows equals: 0.
	self assert: (m2 occurrencesOf: 1) equals: 0.! !

!Array2DTest methodsFor: 'tests - accessing' stamp: ''!
testAtColumn

	self assert: (matrix23 atColumn: 1) equals: #(11 12 13).
	self assert: (matrix23 atColumn: 2) equals: #(21 22 23).! !

!Array2DTest methodsFor: 'tests - accessing' stamp: ''!
testCollectCreatesANewMatrix

	| m m2 | 
	m := Array2D new: 3. 
	m atAllPut: -1.
	self assert: (m occurrencesOf: -1) equals: 9.
	m2 := m collect: [ :each | each abs ].
	m2 do: [ :each | self assert: each equals: 1 ].
	self assert: (m2 occurrencesOf: 1) equals: 9! !

!Array2DTest methodsFor: 'tests - instance creation' stamp: ''!
testNewTabulate

	| m m2 | 

	m := Array2D new: 5 tabulate: [ :a :b | a*b ].

	self assert: m numberOfColumns equals: 5.
	self assert: m numberOfRows equals: 5.
	self assert: (m occurrencesOf: 8) equals: 2.
	1 to: 5 do: [ :i |
		self assert: (m at: i at: 1) equals: i.
		self assert: (m at: 1 at: i) equals: i.
		self assert: (m at: i at: i) equals: i*i.].

	m2 := Array2D new: 0 tabulate: [ :a :b | a*b ].
	
	self assert: m2 numberOfColumns equals: 0.
	self assert: m2 numberOfRows equals: 0.
	self assert: (m2 occurrencesOf: 1) equals: 0.! !

!Array2DTest methodsFor: 'tests - accessing' stamp: ''!
testSwap
	matrix1
		swap: 1
		at: 2
		with: 1
		at: 1.
	self assert: (matrix1 at: 1 at: 1) equals: 3.
	self assert: (matrix1 at: 1 at: 2) equals: 1! !

!Array2DTest methodsFor: 'tests - instance creation' stamp: ''!
testzeros	

	| m m2 | 

	m := Array2D zeros: 5.

	self assert: m numberOfColumns equals: 5.
	self assert: m numberOfRows equals: 5.
	self assert: (m occurrencesOf: 0) equals: (25).

	m2 := Array2D ones: 0.

	self assert: m2 numberOfColumns equals: 0.
	self assert: m2 numberOfRows equals: 0.
	self assert: (m2 occurrencesOf: 0) equals: 0.! !

!Array2DTest methodsFor: 'tests - accessing' stamp: ''!
testReplaceAll

	matrix1 replaceAll: 1 with: 10.
	self assert: (matrix1 at: 1 at: 1) equals: 10.
	self assert: (matrix1 at: 2 at: 1) equals: 2.
	self assert: (matrix1 at: 1 at: 2) equals: 3.
	self assert: (matrix1 at: 2 at: 2) equals: 4.! !

!Array2DTest methodsFor: 'tests - accessing' stamp: ''!
testAtAllPut

	| m | 
	m := Array2D new: 3. 
	m do: [ :each | self assert: each equals: nil ].
	m atAllPut: 1.
	m do: [ :each | self assert: each equals: 1 ].! !

!Array2DTest methodsFor: 'tests - copying' stamp: ''!
testCopy
	| copyMatrix |
	copyMatrix := matrix1 copy.
	self assert: matrix1 equals: copyMatrix! !

!Array2DTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	matrix1 := Array2D 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 := Array2D 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.
	
	matrix23 := Array2D rows: 3 columns: 2.
	matrix23 at: 1 at: 1 put: 11.
	matrix23 at: 1 at: 2 put: 21.
	matrix23 at: 2 at: 1 put: 12.
	matrix23 at: 2 at: 2 put: 22.
	matrix23 at: 3 at: 1 put: 13.
	matrix23 at: 3 at: 2 put: 23.! !

!ArrayTest commentStamp: ''!
This is the unit test for the class Array. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- there is a chapter in the PharoByExample book (http://pharobyexample.org/)	
	- the sunit class category!
!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureEmptySequenceableTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!ArrayTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne)! !

!ArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutFirst

	| result |
	result := self nonEmpty copyWithoutFirst.
	
	self assert: result size equals: (self nonEmpty size - 1).
	
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (self nonEmpty at: (i + 1))]! !

!ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtLastPut

	| index |
	index := self indexArray anyOne.	
	self nonEmpty atLast: index put: self aValue.	

	self assert: (self nonEmpty at: (self nonEmpty size + 1 - index)) equals: self aValue! !

!ArrayTest methodsFor: 'tests - equality' stamp: ''!
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 - fixture' stamp: ''!
test0FixtureSequencedConcatenationTest
	self empty.
	self assertEmpty: self empty.
	self firstCollection.
	self secondCollection! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
oldSubCollection
	^oldSubCollection! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementInForElementAccessing
" return an element inculded in 'accessCollection '"
	^ self accessCollection anyOne! !

!ArrayTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAt

	| subcollection index collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 1.
	self assert: index equals: 1.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 2.
	self assert: index equals: 0! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSubcollectionAccessTest

	self moreThan3Elements.
	self assert: self moreThan3Elements size > 2! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirstNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index between bounds of 'nonEmpty'"
	
	^ 2! !

!ArrayTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!ArrayTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessFotMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementInForReplacement
	^ elementInForCopy! !

!ArrayTest methodsFor: 'initialization' stamp: ''!
collection 

	^ collectionWith4Elements! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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: 'requirements' stamp: ''!
moreThan3Elements
	" return a collection including atLeast 3 elements"
	^ example1! !

!ArrayTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!ArrayTest methodsFor: 'tests - sorting' stamp: ''!
testSort
	| result tmp |
	result := self unsortedCollection sort.
	tmp := result at: 1.
	result do:
		[:each | self assert: each>=tmp. tmp:= each. ].! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDoEmpty
	| result |
	result := OrderedCollection new.
	self empty reverseDo: [ :each | result add: each ].

	self assertEmpty: result! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollect
	
	| result firstCollection secondCollection index  |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	result := firstCollection  with: secondCollection collect:
		[:a :b |
		( index := index + 1).
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals:  b.
		b].
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (secondCollection  at: i)].
	self assert: result size = secondCollection size! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
testOFixtureReplacementSequencedTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.

	self elementInForReplacement.
	self assert: (self nonEmpty includes: self elementInForReplacement).

	self newElement.

	self firstIndex.
	self assert: (self firstIndex >= 1 & self firstIndex) <= self nonEmpty size.

	self secondIndex.
	self assert: (self secondIndex >= 1 & self secondIndex) <= self nonEmpty size.

	self assert: self firstIndex <= self secondIndex.

	self replacementCollection.

	self replacementCollectionSameSize.
	self assert: self secondIndex - self firstIndex + 1 equals: self replacementCollectionSameSize size! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementsCopyNonIdenticalWithoutEqualElements
	" return a collection that does niot include equal elements ( classic equality )"
	^ collectionOfCollection! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
moreThan4Elements

" return a collection including at leat 4 elements"
	^ example1! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLastNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!ArrayTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!ArrayTest methodsFor: 'tests - copy' stamp: ''!
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 - as identity set' stamp: ''!
testAsIdentitySetWithoutIdentityEqualsElements

	| result collection |
	collection := self collectionWithCopy.
	result := collection asIdentitySet.
	" no elements should have been removed as no elements are equels with Identity equality"
	self assert: result size = collection size.
	collection do: 
		[ :each | 
		(collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ].
	self assert: result class = IdentitySet! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
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)"
	^ stringCollectionWithSameBeginingAnEnd! !

!ArrayTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!ArrayTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', '.
	
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString withIndexDo: 
		[:el :i |  self assert: el equals: ((self nonEmpty at:i)asString)]! !

!ArrayTest methodsFor: 'tests - enumerating' stamp: ''!
testFlattened

	self assert: self simpleCollection flattened equals: #(1 8 3).
	self assert: self collectionOfCollectionsOfInts flattened equals: #( 1 2 3 4 5 6 ).
	self assert: self collectionWithCharacters flattened equals: #($a $x $d $c $m).
	self assert: self collectionOfCollectionsOfStrings flattened equals: #('foo' 'bar' 'zorg').! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsCollect
	| index result |
	index := 0.

	result := self nonEmptyMoreThan1Element
		pairsCollect: [ :each1 :each2 | 
			self assert: (self nonEmptyMoreThan1Element indexOf: each2) equals: (index := index + 2).
			(self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1) ].

	result do: [ :each | self assert: each ]! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
sizeCollection

	^ self collection! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
smallerIndex
	^ firstIndex -1! !

!ArrayTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOf
	| collection element |
	element := self collectionWithCopyNonIdentical anyOne copy.
	self deny: self collectionWithCopyNonIdentical anyOne identicalTo: element.
	collection := self collectionWithCopyNonIdentical copyWith: element.
	self assert: (collection identityIndexOf: element) equals: collection size! !

!ArrayTest methodsFor: 'tests - iterate' stamp: ''!
speciesClass
	
	^ Array! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtRandom

	| result |
	result := self nonEmpty atRandom.
	self assert: (self nonEmpty includes: result)! !

!ArrayTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
nonEmptyMoreThan1Element
	^nonEmptyMoreThan1Element .! !

!ArrayTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printElementsOn: aStream.
	allElementsAsString:=(result findBetweenSubstrings: ' ').
	allElementsAsString withIndexDo: 
		[:el :i | self assert: el equals: ((self nonEmpty at: i)asString) ]! !

!ArrayTest methodsFor: 'tests - accessing' stamp: ''!
testAtWrap2
	| tabTest |
	tabTest := #(5 6 8).
	self assert: (tabTest atWrap: 2) equals: 6.
	self assert: (tabTest atWrap: 7) equals: 5.
	self assert: (tabTest atWrap: 5) equals: 6.
	self assert: (tabTest atWrap: 0) equals: 8.
	self assert: (tabTest atWrap: 1) equals: 5.
	self assert: (tabTest atWrap: -2) equals: 5! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testBeReadOnlyLiteral
	self assert: Array new beReadOnlyLiteral isReadOnlyObject.
	self assert: (Array with: String new) beReadOnlyLiteral first isReadOnlyObject.
	self deny: (Array with: Object new) first isReadOnlyObject! !

!ArrayTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testLiteralEqual

	self deny: (example1 literalEqual: example1 asIntegerArray)! !

!ArrayTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllIndexesPut
	
	self nonEmpty atAllPut: self aValue.
	self nonEmpty do:[ :each| self assert: each = self aValue].! !

!ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringOne
	
	"self assert: self oneItemCol asCommaString = '1'.
	self assert: self oneItemCol asCommaStringAnd = '1'."

	self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString).
	self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString)! !

!ArrayTest methodsFor: 'tests - arithmetic' stamp: ''!
testSumNumberItemsWithoutBlock
	
	self assert: #() sumNumbers equals: 0.
	
	self assert: #(1 2 3) sumNumbers equals: 6! !

!ArrayTest methodsFor: 'tests - sequence isempty' stamp: ''!
testSequenceIfNotEmpty

	self assert: (self nonEmpty 
					ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithCharacters
	^ withCharacters.! !

!ArrayTest methodsFor: 'tests - copy' stamp: ''!
testCopyNonEmptyWithoutAllNotIncluded! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	^ elementNotInForCopy! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
anotherElementNotIn
	^ elementNotInForCopy! !

!ArrayTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfIfAbsentDuplicate

	| 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 ]) equals: 1! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testFirstSecondThird

	self assert: self moreThan4Elements first equals: (self moreThan4Elements at: 1).
	self assert: self moreThan4Elements second equals: (self moreThan4Elements at: 2).
	self assert: self moreThan4Elements third equals: (self moreThan4Elements at: 3).
	self assert: self moreThan4Elements fourth equals: (self moreThan4Elements at: 4)! !

!ArrayTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterEmpty
	| result |
	result := self empty copyAfter: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfIfAbsentDuplicate

	| 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 ]) equals: collection size! !

!ArrayTest methodsFor: 'tests - creation' stamp: ''!
collectionClass 
	"Return the class to be used to create instances of the class tested"
		
	^ Array! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureBeginsEndsWithTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self assert: self nonEmpty size > 1.
	self empty.
	self assertEmpty: self empty! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementInForOccurrences
	^ elementInForCopy! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
integerCollection
	^example1 .! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
accessCollection

	^ example1! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtIfAbsent

	| 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 - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterLastWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the last occurrence of element :"
	result := collection copyAfterLast: element.

	"Verify content"
	self assertEmpty: result! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementInCollectionOfFloat
	^ collectionOfFloat atRandom! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testMiddle

	self assert: self moreThan4Elements middle equals: (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! !

!ArrayTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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 - converting' stamp: ''!
testAsByteArray

	| res |
	self integerCollectionWithoutEqualElements.
	self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ].
	res := true.
	self integerCollectionWithoutEqualElements
		detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementNotIn
"return an element not included in 'nonEmpty' "

	^ elementNotInForCopy! !

!ArrayTest methodsFor: 'tests - copying same contents' stamp: ''!
testReverse

	| result |
	result := self nonEmpty reversed.	
	"verify content of 'result: '"
	1 to: result size do:
		[:i | self assert: ((result at: i) 
			= (self nonEmpty at: (self nonEmpty size - i + 1)))].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testBeforeIfAbsent

	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: 'requirements' stamp: ''!
firstIndex
	^ firstIndex! !

!ArrayTest methodsFor: 'tests - sorting' stamp: ''!
testIsSorted
	self assert: self sortedInAscendingOrderCollection isSorted.
	self deny: self unsortedCollection isSorted! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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 - subcollections access' stamp: ''!
testLastNElements

	| result |
	result := self moreThan3Elements last: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i + 1) ].
	self assert: result size equals: (self moreThan3Elements size - 1).
	self 
		should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ]
		raise: Error! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testIsLiteral
	"We work with a copy of literalArray, to avoid corrupting the code."
	
	| aLiteralArray |
	aLiteralArray := literalArray copy.
	self assert: aLiteralArray isLiteral.
	aLiteralArray at: 1 put: self class.
	self deny: aLiteralArray isLiteral.
	self deny: (literalArray as: WeakArray) isLiteral description: 'instances of Array subclasses are not literal'.! !

!ArrayTest methodsFor: 'tests - creation' stamp: ''!
testWithAll

	| aCol collection |
	collection := self collectionMoreThan5Elements asOrderedCollection.
	aCol := self collectionClass withAll: collection.
	
	collection do: [ :each | self assert: (aCol occurrencesOf: each ) equals: ( collection occurrencesOf: each ) ].
	
	self assert: aCol size equals: collection size! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
valueArray
" return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty'  at indexes in 'indexArray' "
	| result |
	result := Array new: self indexArray size.
	1 to: result size do:
		[:i |
		result at:i put: (self aValue ).
		].
	^ result.! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithCopyNonIdentical
	" return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)"
	^ collectionOfCollection! !

!ArrayTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printNameOn: aStream.

	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents equals: ('an ',self nonEmpty class name ) ]
		ifFalse:[ self assert: aStream contents equals: ('a ',self nonEmpty class name)].! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutTest
	self aValue.
	self anotherValue.

	self anIndex.
	self nonEmpty isDictionary ifFalse: [ self assert: (self anIndex >= 1 & self anIndex) <= self nonEmpty size ].

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
" return a collection elements that can be sorte ( understanding message ' < '  or ' > ')"
	^ withoutEqualElements! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButFirstDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButFirstDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i +1))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element size-1)! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLastEmpty
	| result |
	result := self empty copyUpToLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!ArrayTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!ArrayTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAtIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self assert: anElementIn equals: false.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self collection.
	self empty.
	self assertEmpty: self empty.
	self collectionOfFloat.
	self collectionOfFloat do: [ :each | self assert: each isFloat ].
	self elementInForIncludesTest.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementInForIncludesTest ] ifNone: [ anElementIn := false ].
	self assert: anElementIn! !

!ArrayTest methodsFor: 'tests - equality' stamp: ''!
testHasEqualElementsOfIdenticalCollectionObjects
	
	self assert: (self empty hasEqualElements: self empty). 
	self assert: (self nonEmpty hasEqualElements: self nonEmpty)! !

!ArrayTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWithManyOccurrence
	| result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff |
	" testing fixture here as this method may be not used for collection that can't contain equals element :"
	self collectionWith2TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection) = 2.	" test :"
	diff := self replacementCollection size - self oldSubCollection size.
	result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection.	"detecting indexes of olSubCollection"
	firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection.	" verifying that replacementCollection has been put in places of oldSubCollections "
	firstIndexesOfOccurrence
		do: [ :each | 
			(firstIndexesOfOccurrence indexOf: each) = 1
				ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ]
				ifFalse: [ each + diff to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ].	" verifying that the 'between' parts correspond to the initial collection : "
	1 to: firstIndexesOfOccurrence size do: [ :i | 
		i = 1
			ifTrue: [ 1 to: (firstIndexesOfOccurrence at: i) - 1 do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ]
			ifFalse: [ 
				resultBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self replacementCollection size.
				collectionBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self oldSubCollection size.
				1 to: (firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | 
					self
						assert:
							(result at: resultBetweenPartIndex + i - 1)
								= (self collectionWith2TimeSubcollection at: collectionBetweenPartIndex + i - 1) ] ]	" specific comportement for the begining of the collection :"	" between parts till the end : " ].	"final part :"
	1 to: self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size) do: [ :i | 
		self
			assert:
				(result at: firstIndexesOfOccurrence last + self replacementCollection size - 1 + i)
					= (self collectionWith2TimeSubcollection at: firstIndexesOfOccurrence last + self oldSubCollection size - 1 + i) ]! !

!ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIdentityIndexOfDuplicate

	| collection element |
	"testing fixture here as this method may not be used by some collections testClass"
	self collectionWithNonIdentitySameAtEndAndBegining.
	collection := self collectionWithNonIdentitySameAtEndAndBegining.
	self assert: collection first equals: collection last.
	self deny: collection first == collection last.
	collection withIndexDo: [:el :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) equals: collection size! !

!ArrayTest methodsFor: 'tests - index access' stamp: ''!
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 - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutOneOrMoreElementsTest
	self aValue.


	self indexArray.
	self indexArray
		do: [ :each | 
			self assert: each class = SmallInteger.
			self assert: (each >= 1 & each) <= self nonEmpty size ].

	self assert: self indexArray size = self valueArray size.

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDoError
	
	self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error! !

!ArrayTest methodsFor: 'tests - enumerating' stamp: ''!
testDifferencePreservesOrder
	| n even odd odd2 |
	n := #(5 3 4).
	even := #(4).
	odd := n difference: even.
	odd2 := n reject: [ :i | i even ].
	self assert: odd equals: odd2! !

!ArrayTest methodsFor: 'tests - shuffling' stamp: ''!
testShuffleModifyTheReceiver

	| array shuffled |
	array := #( 1 2 3 4 5) copy.
	shuffled := array shuffle.
	self assert: array == shuffled.! !

!ArrayTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignForSequenceableCollections

	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' stamp: ''!
testEqualSignIsTrueForEmptyButNonIdenticalCollections
	
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testCombinations
	self assert: #(1 2 3) combinations equals: #(#(1) #(2) #(3) #(1 2) #(1 3) #(2 3) #(1 2 3)).
	self assert: (1 to: 3) combinations equals: #(#(1) #(2) #(3) #(1 2) #(1 3) #(2 3) #(1 2 3))! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testCombinationsTaken

	self
		assertCollection: (#( 1 2 3 ) combinations: 2)
		hasSameElements: #( #( 1 2 ) #( 1 3 ) #( 2 3 ) ).
	self
		assertCollection: ((1 to: 4) combinations: 3)
		hasSameElements: #( #( 1 2 3 ) #( 1 2 4 ) #( 1 3 4 ) #( 2 3 4 ) )! !

!ArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingStartWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty .
	result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ).
	
	"verify content of 'result' : "
	1 to: 2   do:
		[:i | self assert: ( element ) = ( result at:(i) ) ].
	
	3 to: result size do:
		[:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ].

	"verify size of 'result' :"
	self assert: result size = (self nonEmpty size + 2).! !

!ArrayTest methodsFor: 'tests - copy' stamp: ''!
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 - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDoEmpty
	| result |
	result := OrderedCollection new.

	self empty keysAndValuesDo: [ :i :value | result add: value + i ].

	self assertEmpty: result! !

!ArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithSequenceable

	| result index element |
	index := self indexInNonEmpty.
	element := self nonEmpty at: index.
	result := self nonEmpty copyWith: (element ).
	
	self assert: result size equals: (self nonEmpty size + 1).
	self assert: result last equals: element.
	
	1 to: (result size - 1) do:
		[ :i | self assert: (result at: i) equals: ( self nonEmpty at: i)]! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexCollect
	
	| result index collection |
	index := 0.
	collection := self nonEmptyMoreThan1Element .
	result := collection  withIndexCollect: [:each :i | 
		self assert: i equals: (index := index + 1).	
		self assert: i equals: (collection  indexOf: each).
		each ]. 
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (collection at: i)].
	self assert: result size equals: collection size! !

!ArrayTest methodsFor: 'tests - shuffling' stamp: ''!
testShuffleBy

	| base random shuffleByResult |
	base := #(1 2 3 4 5) copy.
	random := (Random seed: 42).
	shuffleByResult := #(2 5 4 3 1) copy.
	
	self assert: ((base shuffleBy: random) hasEqualElements: shuffleByResult).! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
firstEven
	"Returns the first even number of #collection"
	^ -2! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementInForIndexAccessing

	^ withoutEqualElements anyOne! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementNotInForCopy
	^ elementNotInForCopy! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDetectSequenced
	"Testing that detect keep the first element returning true for sequenceable collections"

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element  detect: [:each | each notNil ].
	self assert: result equals: element! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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 - index access' stamp: ''!
testLastIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection last.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: 99! !

!ArrayTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWithInsertion
	| result  indexOfSubcollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: ( indexOfSubcollection - 1 ) with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'' : '"
	
	1 to: (indexOfSubcollection -1) do: 
		[
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i)=(result at: i)
		].
	
	" middle part containing replacementCollection : "
	indexOfSubcollection  to: (indexOfSubcollection  + self replacementCollection size-1) do: 
		[
		:i |
		self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 ))
		].
	
	" end part :"
	(indexOfSubcollection  + self replacementCollection size) to: (result size) do:
		[:i|
		self assert: (result at: i)=(self collectionWith1TimeSubcollection  at: (i-self replacementCollection size))].
	
	" verify size: "	
	self assert: result size=(self collectionWith1TimeSubcollection  size + self replacementCollection size).! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan5Elements
" return a collection including at least 5 elements"
	
	^ collection5Elements! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
secondIndex
	^ secondIndex! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopySameContentsTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWith2TimeSubcollection
	^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst),self oldSubCollection .! !

!ArrayTest methodsFor: 'tests - iterate' stamp: ''!
testDo2
	| res |
	res := OrderedCollection new.
	self collection do: [ :each | res add: each class ].
	self assert: res asArray equals: self result! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLast

	| index |
	self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last.

	index := self moreThan4Elements indexOf: self elementInForElementAccessing.
	self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! !

!ArrayTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
secondCollection
	^example2! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self collection anyOne.! !

!ArrayTest methodsFor: 'tests - arithmetic' stamp: ''!
testPremultiply
	self assert: example1 +* #(2) equals: #(2 4 6 8 10)! !

!ArrayTest methodsFor: 'initialization' stamp: ''!
nonEmpty

	^ example1! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementNotInForIndexAccessing

	^elementNotInForCopy! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testCollectFromTo
	
	| result |
	result:=self nonEmptyMoreThan1Element 
		collect: [ :each | each ]
		from: 1
		to: (self nonEmptyMoreThan1Element size - 1).
		
	1 to: result size
		do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ].
	self assert: result size = (self nonEmptyMoreThan1Element size - 1)! !

!ArrayTest methodsFor: 'tests - copy' stamp: ''!
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 - enumerating' stamp: ''!
testFlatCollectAsWithEmptyCollection

	self 
		assert: (self empty flatCollect: [ :x | { x }, { x } ] as: IdentitySet) 
		equals: self empty asIdentitySet! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
replacementCollectionSameSize
	^replacementCollectionSameSize! !

!ArrayTest methodsFor: 'helpers' stamp: ''!
anotherValue

	^ 66! !

!ArrayTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfIfAbsent

	| collection |
	collection := self collectionMoreThan1NoDuplicates.
	self assert: (collection 
			indexOf: collection first
			ifAbsent: [ 33 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 33 ]) equals: 33! !

!ArrayTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Array! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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: 'requirements' stamp: ''!
collectionOfFloat
	^ collectionOfFloat! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfForMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
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 - copying same contents' stamp: ''!
testReversed

	| result |
	result := self nonEmpty reversed.
	
	"Verify content"
	result withIndexDo:
		[:el :i | self assert: el equals: (self nonEmpty at: (self nonEmpty size - i + 1))].

	"Verify size"
	self assert: result size=self nonEmpty size.! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!ArrayTest methodsFor: 'tests - iterate' stamp: ''!
expectedSizeAfterReject
	^1! !

!ArrayTest methodsFor: 'initialization' stamp: ''!
result
	
	^ collectResult! !

!ArrayTest methodsFor: 'initialization' stamp: ''!
empty

	^ empty! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!ArrayTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty
	| result |
	result := self empty occurrencesOf: self elementInForOccurrences.
	self assert: result equals: 0! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDo
	| result |
	result := OrderedCollection new.
	self nonEmpty reverseDo: [: each | result add: each].
	
	1 to: result size do:
		[:i|
		self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))]! !

!ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWith1TimeSubcollection
	^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst).! !

!ArrayTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	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 - begins ends with' stamp: ''!
testsEndsWith
	
	self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst).
	self assert: (self nonEmpty endsWith: self nonEmpty).
	self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCreationWithTest

	self collectionMoreThan5Elements.
	self assert: self collectionMoreThan5Elements size >= 5! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0TSequencedStructuralEqualityTest

	self nonEmpty at: 1	"Ensures #nonEmpty is sequenceable"! !

!ArrayTest methodsFor: 'tests - sorting' stamp: ''!
testSortedUsingBlock
	| result tmp |
	result := self unsortedCollection sorted:  [:a :b | a>b]..
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementInForIncludesTest

	^ elementInForCopy! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLastEmpty
	| result |
	result := self empty copyAfterLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan1NoDuplicates
	" return a collection of size 5 without equal elements"
	^ withoutEqualElements! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
withEqualElements
	" return a collection of float including equal elements (classic equality)"
	^ collectionOfFloatWithEqualElements! !

!ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfStartingAtDuplicate

	| 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 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 55 ]) equals: 1! !

!ArrayTest methodsFor: 'tests - copy' stamp: ''!
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 - subcollections access' stamp: ''!
testAllButFirstNElements

	| allButFirst collection |
	collection := self moreThan3Elements.
	allButFirst := collection allButFirst: 2.
	allButFirst withIndexDo: 
		 [:el :i | self assert: el equals: (collection at: i + 2) ].
	self assert: allButFirst size + 2 equals: collection size! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementInForCopy
	^ elementInForCopy! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithSameAtEndAndBegining
" return a collection with elements at end and begining equals .
(others elements of the collection are not equal to those elements)"
	^ stringCollectionWithSameBeginingAnEnd! !

!ArrayTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testNewWithSize
	| array |
	array := Array new: 5.
	self assert: array size equals: 5.
	1 to: 5 do: [ :index | self assert: (array at: index) isNil ]! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element

	^ nonEmpty1Element! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithIdentical
	"Return a collection of type: 'self collectionWIithoutEqualsElements class containing two elements equals (with identity equality)."

	| result collection anElement |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := collection first.
	collection add: anElement.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
indexArray
	^ indexArray .! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesForMultiplinessTest
	| cpt |
	self collectionWithEqualElements.
	self collectionWithEqualElements.
	self elementTwiceInForOccurrences.
	self elementTwiceInForOccurrences.
	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 - begins ends with' stamp: ''!
testsBeginsWith
	
	self assert: (self nonEmpty beginsWith: (self nonEmpty copyUpTo: self nonEmpty last)).
	self assert: (self nonEmpty beginsWith: self nonEmpty).
	self deny: (self nonEmpty beginsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!ArrayTest methodsFor: 'tests - sequence isempty' stamp: ''!
testSequenceIfNotEmptyifEmpty

	self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIdentityIndexOfIAbsentDuplicate

	| collection element elementCopy |
	collection := self collectionWithNonIdentitySameAtEndAndBegining.
	element := collection last.
	elementCopy := element copy.
	self deny: element == elementCopy.
	self assert: (collection 
			identityIndexOf: element
			ifAbsent: [ 0 ]) equals: collection size.
	self assert: (collection 
			identityIndexOf: elementCopy
			ifAbsent: [ 55 ]) equals: 55! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
sortedInAscendingOrderCollection
	^sortedInAscendingOrderCollection .! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testIsSelfEvaluating

	self assert: example1 isSelfEvaluating.
	example1 at: 1 put: Bag new.
	self deny: example1 isSelfEvaluating.
	example1 at: 1 put: 1.! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest

	self nonEmpty! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsDo

	| index |
	index:=1.
	
	self nonEmptyMoreThan1Element  pairsDo: 
		[:each1 :each2 | 
		self assert: (self nonEmptyMoreThan1Element at:index) equals: each1.
		self assert: (self nonEmptyMoreThan1Element at:(index+1)) equals: each2.
		index := index + 2 ].
	
	self nonEmptyMoreThan1Element size odd
		ifTrue:[ self assert: index equals: self nonEmptyMoreThan1Element size ]
		ifFalse:[ self assert: index equals: (self nonEmptyMoreThan1Element size+1) ]! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtWrap
	"
	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 - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
indexInForCollectionWithoutDuplicates
	^ 2.! !

!ArrayTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopy

	| result |
	result := self nonEmpty shallowCopy.
	
	"Verfy content"
	self nonEmpty withIndexDo:
		[:el :i | self assert: (result at:i) equals: (self nonEmpty at:i)].
	
	"Verify size"
	self assert: result size equals: self nonEmpty size.! !

!ArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty.
	result := self nonEmpty forceTo: (self nonEmpty size + 2) paddingWith: element.
	
	"Verify content of 'result'"
	self nonEmpty withIndexDo:
		[:el :index | self assert: el equals: (result at: index) ].
	
	(result size - 1) to: result size do:
		[:i | self assert: (result at:i) equals: element ].

	"Verify size of 'result'"
	self assert: result size equals: self nonEmpty size + 2! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!ArrayTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLast

	| abf col |
	col := self moreThan3Elements.
	abf := col allButLast.
	self deny: abf last = col last.
	self assert: abf size + 1 equals: col size! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexDo

	|  indexes elements |
	indexes:= OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:value :i  |
			indexes  add: (i).
			elements add: value ].
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:el :i |
			self assert: (indexes at: i) equals: i.
			self assert: (elements at: i) equals: el ].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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 - shuffling' stamp: ''!
testShuffleChangeOrder

	| array shuffled |
	array := #( 1 2 3 4 5).
	shuffled := array copy shuffle.
	array do: [ :e | self assert: (shuffled includes: e) ]! !

!ArrayTest methodsFor: 'tests - as identity set' stamp: ''!
testAsIdentitySetWithIdentityEqualsElements

	| result |
	result := self collectionWithIdentical asIdentitySet.
	" Only one element should have been removed as two elements are equals with Identity equality"
	self assert: result size = (self collectionWithIdentical size - 1).
	self collectionWithIdentical do: 
		[ :each | 
		(self collectionWithIdentical occurrencesOf: each) > 1 
			ifTrue: 
				[ "the two elements equals only with classic equality shouldn't 'have been removed"
				self assert: (result asOrderedCollection occurrencesOf: each) = 1
				" the other elements are still here" ]
			ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ].
	self assert: result class = IdentitySet! !

!ArrayTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self empty occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!ArrayTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!ArrayTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLastNElements

	| allButLast collection |
	collection := self moreThan3Elements.
	allButLast := collection allButLast: 2.
	allButLast withIndexDo: [:el :i | self assert: el equals: (collection at: i) ].
	self assert: allButLast size + 2 equals: collection size! !

!ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	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 - begins ends with' stamp: ''!
testsBeginsWithEmpty
	
	self deny: (self nonEmpty beginsWith:(self empty)).
	self deny: (self empty beginsWith:(self nonEmpty))! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithOrWithoutSpecificElementsTest

	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self indexInNonEmpty.
	self assert: self indexInNonEmpty > 0.
	self assert: self indexInNonEmpty <= self nonEmpty size! !

!ArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithFirst

	| index element result |
	index:= self indexInNonEmpty .
	element:= self nonEmpty at: index.
	
	result := self nonEmpty copyWithFirst: element.	
	
	self assert: result size = (self nonEmpty size + 1).
	self assert: result first = element .
	
	2 to: result size do:
	[ :i |
	self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testIsArray
	
	self assert: example1 isArray! !

!ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfDuplicate

	| 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) equals: collection size! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpTo

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection   copyUpTo: (collection  at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at:i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllPut
 
	self nonEmpty atAll: self indexArray put: self aValue.
	
	self indexArray do:
		[:i | self assert: (self nonEmpty at: i) equals: self aValue ]! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionOfCollectionsOfStrings
	^ collectionOfCollectionsOfStrings.! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLast

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection copyUpToLast: (collection at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at: i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!ArrayTest methodsFor: 'tests - converting' stamp: ''!
testAsArrayKeepsIdentity
	| x y |
	x := #(1 2 3 4 5).
	y := x asArray.
	self assert: y identityHash equals: x identityHash! !

!ArrayTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!ArrayTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			lastIndexOf: element
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 99 ]) equals: 99! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
	^ collectionNotIncluded.! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToLastWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyUpToLast:' should copy until the last occurrence :"
	result := collection copyUpToLast: (element ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (collection at: i) ].
	
	self assert: result size equals: (collection size - 1)! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0SortingArrayedTest
	| tmp sorted |
	" an unsorted collection of number "
	self unsortedCollection.
	self unsortedCollection do: [ :each | each isNumber ].
	sorted := true.
	self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ].
	self deny: sorted.	" a collection of number sorted in an ascending order"
	self sortedInAscendingOrderCollection.
	self sortedInAscendingOrderCollection do: [ :each | each isNumber ].
	tmp := self sortedInAscendingOrderCollection at: 1.
	self sortedInAscendingOrderCollection
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	firstCollection  with: secondCollection do:
		[:a :b |
		index := index + 1.
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals: b ]! !

!ArrayTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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 - iterate on sequenced reable collections' stamp: ''!
testGroupsOfAtATimeCollect
	| groupsOf2 |
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: [ :x | x ]).
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: #yourself).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 2 atATimeCollect: [ :x | x ].
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 2.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 2 ]).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 3 atATimeCollect: #yourself.
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 3.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 3 ]).! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithReplacementTest
	self replacementCollection.
	self oldSubCollection.
	self collectionWith1TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! !

!ArrayTest methodsFor: 'tests - copying' stamp: ''!
elementToAdd
	^ 55! !

!ArrayTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAtIfAbsent
	| absent subcollection collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ].
	self deny: absent.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ].
	self assert: absent! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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 - converting' stamp: ''!
testAsSet
 	"Test with a collection without equal elements"
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set! !

!ArrayTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWithEmpty
	
	self deny: (self nonEmpty endsWith: self empty).
	self deny: (self empty endsWith: self nonEmpty)! !

!ArrayTest methodsFor: 'parameters' stamp: ''!
valuePutIn
	"the value that we will put in the non empty collection"
	
	^ 2! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
simpleCollection
	^simpleCollection.! !

!ArrayTest methodsFor: 'tests - at put' stamp: ''!
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 - occurrencesOf for multipliness' stamp: ''!
testOccurrencesOfForMultipliness

	| collection elem |
	collection := self collectionWithEqualElements.
	elem := self elementTwiceInForOccurrences.

	self assert: (collection occurrencesOf: elem ) equals: 2.! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLast

	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection copyAfterLast: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!ArrayTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!ArrayTest methodsFor: 'tests - at put' stamp: ''!
testAtPut
	
	self nonEmpty at: self anIndex put: self aValue.
	self assert: (self nonEmpty at: self anIndex) = self aValue.! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
integerCollectionWithoutEqualElements
	^{1. 2. 6. 5.}! !

!ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtWrapPut
	 
	| index |
	index := self indexArray anyOne.
	
	self nonEmpty atWrap: 0 put: self aValue.
	self assert: self nonEmpty last equals: self aValue.
	
	self nonEmpty atWrap: (self nonEmpty size + 1) put: self aValue.
	self assert: self nonEmpty first equals: self aValue.
	
	self nonEmpty atWrap: index put: self aValue.
	self assert: (self nonEmpty at: index) equals: self aValue.
	
	self nonEmpty atWrap: (self nonEmpty size + index) put: self aValue .
	self assert: (self nonEmpty at: index) equals: self aValue.! !

!ArrayTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollect

	self assert: (self simpleCollection flatCollect: [ :x | { x } ]) equals: self simpleCollection.
	self assert: (self simpleCollection flatCollect: [ :x | { x } ]) species = self simpleCollection species.
	
	self 
		assert: (self collectionOfCollectionsOfInts flatCollect: [ :x | { x } ]) 
		equals: self collectionOfCollectionsOfInts.
	self 
		assert: (self collectionWithCharacters flatCollect: [ :x | { x } ]) 
		equals: self collectionWithCharacters.
	self 
		assert: (self collectionOfCollectionsOfStrings flatCollect: [ :x | { x } ]) 
		equals: self collectionOfCollectionsOfStrings! !

!ArrayTest methodsFor: 'tests - creation' stamp: ''!
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 ) equals: (collection occurrencesOf: element1).
	self assert: (aCol occurrencesOf: element2 ) equals: (collection occurrencesOf: element2)! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementNotInForOccurrences
	^ elementNotInForCopy! !

!ArrayTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceAllWith
	| result collection oldElement newElement oldOccurrences |
	collection := self nonEmpty.
	result := collection copy.
	oldElement := self elementInForReplacement.
	newElement := self newElement.
	oldOccurrences := (result occurrencesOf: oldElement) + (result occurrencesOf: newElement).
	result replaceAll: oldElement with: newElement.
	
	self assert: oldOccurrences equals: (result occurrencesOf: newElement)! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
newElement
	^999! !

!ArrayTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceFromToWithStartingAt
	| result repStart collection replacementCollec firstInd secondInd |
	collection := self nonEmpty.
	result := collection copy.
	replacementCollec := self replacementCollectionSameSize.
	firstInd := self firstIndex.
	secondInd := self secondIndex.
	repStart := replacementCollec size - (secondInd - firstInd + 1) + 1.
	result replaceFrom: firstInd to: secondInd with: replacementCollec startingAt: repStart.
	
	"Verify content of 'result'"
	
	"First part of 'result'" 	
	1 to: (firstInd - 1) do: [:i | self assert: (collection at:i) equals: (result at: i) ].
	
	"Middle part containing replacementCollection"	
	firstInd to: (replacementCollec size - repStart +1) do: 
		[:i| self assert: (result at: i) equals: (replacementCollec at: (repStart + (i - firstInd))) ].
	
	"End part"
	(firstInd + replacementCollec size) to: (result size) do:
		[ :i | self assert: (result at: i) equals: (collection at: (secondInd + 1 - (firstInd + replacementCollec size) + i)) ]! !

!ArrayTest methodsFor: 'helpers' stamp: ''!
anIndex

	^ 2! !

!ArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutIndex

	| result index |	
	index := self indexInNonEmpty.
	result := self nonEmpty copyWithoutIndex: index.
	
	"Verify content of result"
	result withIndexDo: 
		[:element :i | 
		 i <  index ifTrue: [ self assert: element equals: (self nonEmpty at: i) ].
		 i >= index ifTrue: [ self assert: element equals: (self nonEmpty at: (i + 1)) ]].
	
	"Verify size of result"
	self assert: result size equals: (self nonEmpty size - 1)! !

!ArrayTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	literalArray := #(1 true 3 #four).
	selfEvaluatingArray := { 1. true. (3/4). String loremIpsum. (2 to: 4) . 5 }.
	nonSEArray1 := { 1 . Set with: 1 }.
	nonSEarray2 := { testingEnvironment associationAt: #Array }.
	example1 := #(1 2 3 4 5) copy.
	indexArray:= {2. 3. 4.}.
	valueArray:={0. 0. 0.}.
	oldSubCollection:= {2. 3. 4.}.
	nonEmptyMoreThan1Element:= example1.
	subCollectionNotIn:= {1. 8. 3.}.
	collectionNotIncluded:= {7. 8. 9.}.
	removedCollection:=  { 2. 4. }.
	
	example2 := {1. 2. 3/4. 4. 5}.
	collectionWith4Elements := #(1 -2 3 1). 
	collectionWithoutNil := #( 1 2 3 4).
	simpleCollection := #( 1 8 3).
	collectionOfCollectionsOfInts := { 1. { 2. 3 }. { 4. { 5. 6} } }.
	collectionOfCollectionsOfStrings:= {{{'foo'}. {'bar'}}. 'zorg'}.
	collectResult := {SmallInteger. SmallInteger. SmallInteger. SmallInteger.}.
	empty := #().
	duplicateElement := 5.2.
	withEqualElements := {1.5. duplicateElement . 6.1. 2.0. duplicateElement .} .
	withoutEqualElements := {1.1. 4.4. 6.5. 2.4. 3.1.}.
	withCharacters := {$a. $x. $d. $c. $m.}.
	unsortedCollection := {1. 2.  8. 5. 6. 7.}.
	sortedInAscendingOrderCollection := {1. 2. 3. 4. 5. 6.}.
	elementInForCopy:= 2.
	elementNotInForCopy:= 9.
	firstIndex:= 2.
	secondIndex:= 4.
	replacementCollection:= {4. 3. 2. 1.}.
	replacementCollectionSameSize := {5. 4. 3.}.	
	nonEmpty1Element:={ 5.}.
	collectionOfCollection:={'a'. 'b'. 'c'.}.
	collectionOfFloat:={1.5. 5.5. 6.5.}.
	collectionOfFloatWithEqualElements:={1.5. 5.5. 6.5. 1.5}.
	stringCollectionWithSameBeginingAnEnd := {'c'. 's'. 'c' copy}.
	collection5Elements := { 1. 2. 5. 3. 4.}.! !

!ArrayTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testSorted
	| result tmp unsorted |
	unsorted := self unsortedCollection.
	result := unsorted sorted.
	self deny: unsorted == result.
	tmp := result at: 1.
	result
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringMore

	"self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'.
	self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3'"

	| result resultAnd index allElementsAsString |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
 
	index := 1.
	(result findBetweenSubstrings: ',' )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 findBetweenSubstrings: ',' ).
	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 - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result:= self empty,self secondCollection .
	
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:i).
		].
	"size : "
	self assert: result size = ( self secondCollection size).! !

!ArrayTest methodsFor: 'tests - sorting' stamp: ''!
testIsSortedBy
	self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]).
	self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]).! !

!ArrayTest methodsFor: 'tests - at put' stamp: ''!
testAtPutOutOfBounds
	
	self should: [self empty at: self anIndex put: self aValue] raise: Error! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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 - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
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 - element accessing' stamp: ''!
testLast

	self assert: self moreThan4Elements last equals: (self moreThan4Elements at: self moreThan4Elements size)! !

!ArrayTest methodsFor: 'tests - find binary' stamp: ''!
testFindBinary
	self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 1 - arg ]) equals: 1.
	self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 23 - arg ]) equals: 23.
	self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 11 - arg ]) equals: 11.
	self should: [ #(1 3 5 7 11 15 23) findBinary: [ :arg | 8 - arg ] ] raise: NotFound! !

!ArrayTest methodsFor: 'tests - creation' stamp: ''!
testWith
	
	| aCol anElement |
	anElement := self collectionMoreThan5Elements anyOne.
	aCol := self collectionClass with: anElement.
	self assert: (aCol includes: anElement).! !

!ArrayTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation
	| result index |
	result:= self firstCollection,self secondCollection .
	"first part : "
	index := 1.
	self firstCollection do: 
		[:each | 
		self assert: (self firstCollection at: index)=each.
		index := index+1.].
	"second part : "
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:index).
		index:=index+1].
	"size : "
	self assert: result size = (self firstCollection size + self secondCollection size).! !

!ArrayTest methodsFor: 'tests - creation' stamp: ''!
testOfSize
	
	| aCol |
	aCol := self collectionClass ofSize: 3.
	self assert: aCol size equals: 3.! !

!ArrayTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContentsSized
	| result |
	result:= self collectionClass new: 1 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.
	
	result:= self collectionClass new: 1000 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
replacementCollection
	^replacementCollection .! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertAsSetForMultiplinessTest
	"a collection ofFloat with equal elements:"

	| res |
	self withEqualElements.
	self withEqualElements do: [ :each | self assert: each isFloat ].
	res := true.
	self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res.	"a collection of Float without equal elements:"
	res := true.
	self elementsCopyNonIdenticalWithoutEqualElements
		detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self deny: res! !

!ArrayTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopyEmpty
	| result |
	result := self empty shallowCopy.
	self assertEmpty: result! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionInForIncluding
	^ self nonEmpty copyWithoutFirst.! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testPrinting
	self assert: literalArray printString equals: '#(1 true 3 #four)'.
	self assert: literalArray equals: (self class compiler evaluate: literalArray printString).
	self assert: selfEvaluatingArray equals: (self class compiler evaluate: selfEvaluatingArray printString).
	self assert: nonSEArray1 printString equals: 'an Array(1 a Set(1))'.
	self assert: nonSEarray2 printString equals: '{#Array->Array}'! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementInForIndexAccess
	^ elementInForCopy! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
howMany: aSubCollection in: collection
" return an integer representing how many time 'subCollection'  appears in 'collection'  "
	| tmp nTime |
	tmp := collection.
	nTime:= 0.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				nTime := nTime + 1.
				1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.]
				]
			ifFalse: [tmp := tmp copyWithoutFirst.]
		 ].
	
	^ nTime.! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateSequencedReadableTest
	| res |
	self nonEmptyMoreThan1Element.
	self assert: self nonEmptyMoreThan1Element size > 1.

	self empty.
	self assertEmpty: self empty.

	res := true.
	self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
firstCollection
	^example1! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
unsortedCollection
	^unsortedCollection .! !

!ArrayTest methodsFor: 'parameters' stamp: ''!
accessValuePutIn
	"return access the element put in the non-empty collection"
	
	^ self perform: self selectorToAccessValuePutIn! !

!ArrayTest methodsFor: 'tests - iterate' stamp: ''!
testDo
	| res |
	res := OrderedCollection new.
	self collection do: [ :each | res add: each class ].
	self assert: res asArray equals: self result! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessTest
	| res |
	self collectionMoreThan1NoDuplicates.
	self assert: self collectionMoreThan1NoDuplicates size > 1.
	res := true.
	self collectionMoreThan1NoDuplicates
		detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self elementInForIndexAccessing.
	self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing).
	self elementNotInForIndexAccessing.
	self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! !

!ArrayTest methodsFor: 'helpers' stamp: ''!
aValue

	^ 33! !

!ArrayTest methodsFor: 'tests - as set tests' stamp: ''!
testAsIdentitySetWithEqualsElements

	| result collection |
	collection := self withEqualElements .
	result := collection asIdentitySet.
	collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = IdentitySet! !

!ArrayTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!ArrayTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
	^ removedCollection! !

!ArrayTest methodsFor: 'tests - copying with replacement' stamp: ''!
firstIndexesOf: aSubCollection in: collection
" return an OrderedCollection with the first indexes of the occurrences of subCollection in  collection "
	| tmp result currentIndex |
	tmp:= collection.
	result:= OrderedCollection new.
	currentIndex := 1.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				result add: currentIndex.
				1 to: aSubCollection size do: 
					[:i | 
					tmp := tmp copyWithoutFirst.
					currentIndex := currentIndex + 1]
				]
			ifFalse: [
				tmp := tmp copyWithoutFirst.
				currentIndex := currentIndex +1.
				]
		 ].
	
	^ result.! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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: 'requirements' stamp: ''!
firstOdd
	"Returns the first odd number of #collection"
	^ 1! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyFromTo
	| result  index collection |
	collection := self collectionWithoutEqualElements .
	index :=self indexInForCollectionWithoutDuplicates .
	result := collection   copyFrom: index  to: collection  size .
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at:i) equals: (collection  at: (i + index - 1))].
	
	"Verify size"
	self assert: result size equals: (collection  size - index + 1)! !

!ArrayTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	allElementsAsString withIndexDo: 
		[:el :i | 
		i=1
			ifTrue:[
				self accessCollection class name first isVowel 
					ifTrue:[self assert: el equals: 'an' ]
					ifFalse:[self assert: el equals: 'a'].].
		i=2
			ifTrue:[self assert: el equals: self accessCollection class name].
		i>2
			ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]]! !

!ArrayTest methodsFor: 'tests - subcollections access' stamp: ''!
testFirstNElements

	| result |
	result := self moreThan3Elements first: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i) ].
	
	self assert: result size equals: (self moreThan3Elements size - 1).
	self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: SubscriptOutOfBounds! !

!ArrayTest methodsFor: 'tests - find binary' stamp: ''!
testFindBinaryIfNone
	self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 11 - arg ] ifNone: [ #none ]) equals: 11.
	self should: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 8 - arg ] ifNone: [ #none ]) = #none! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeWithIdentityTest

	| anElement |
	self collectionWithCopyNonIdentical.
	anElement := self collectionWithCopyNonIdentical anyOne.
	self deny: anElement == anElement copy! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the first occurrence:"
	result := collection   copyAfter: (element ).
	
	"Verifying content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + 1 )) equals: (result at: (i)) ].

	"Verify size"
	self assert: result size equals: (collection size - 1).! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementNotInForElementAccessing
" return an element not included in 'accessCollection' "
	^ elementNotInForCopy! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	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 - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDo
	"| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		result add: (value+i)].
	
	1 to: result size do:
		[:i|
		self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]"
	|  indexes elements |
	indexes := OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		indexes  add: (i).
		elements add: value].
	
	(1 to: self nonEmptyMoreThan1Element size )do:
		[ :i |
		self assert: (indexes at: i) equals: i.
		self assert: (elements at: i) equals: (self nonEmptyMoreThan1Element at: i).	
		].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	^ collectionWithoutNil! !

!ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testFromToPut
	
	| collection index |
	index := self indexArray anyOne.
	collection := self nonEmpty copy.
	collection from: 1 to: index  put: self aValue..
	1 to: index do:
		[:i | self assert: (collection at: i)= self aValue].
	(index +1) to: collection size do:
		[:i | self assert: (collection at:i)= (self nonEmpty at:i)].! !

!ArrayTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString |
	result:=''.
	aStream:= ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ').
	allElementsAsString withIndexDo: 
		[:el :i | 
		i<(allElementsAsString size-1 )
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:i)asString)].
		i=(allElementsAsString size-1)
			ifTrue:[ self deny: (allElementsAsString at:i) equals: ('and')asString].
		i=(allElementsAsString size)
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:(i-1))asString)]]! !

!ArrayTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!ArrayTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!ArrayTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfSequenceableTest
	self collectionWithoutEqualElements.
	self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ].
	self indexInForCollectionWithoutDuplicates.
	self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size.
	self empty.
	self assertEmpty: self empty! !

!ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfStartingAtDuplicate

	| 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 ]) equals: 1.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 55 ]) equals: collection size! !

!ArrayTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result index |
	delim := ', '.
	result := ''.
	multiItemStream := ReadWriteStream on: result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	index:=1.
	(result findBetweenSubstrings: delim)do:
		[:each |
			self assert: each= ((self nonEmpty at:index) asString).
			index:=index+1 ]! !

!ArrayTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsSetForIdentityMultiplinessTest
	"A collection (of elements for which copy is not identical ) without equal elements:"

	| anElement res |
	self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := self elementsCopyNonIdenticalWithoutEqualElements anyOne.
	self deny: anElement copy == anElement.
	res := true.
	self elementsCopyNonIdenticalWithoutEqualElements
		detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfDuplicate

	| 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) equals: 1! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
subCollectionNotIn

	^subCollectionNotIn! !

!ArrayTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContents
	| result |
	result:= self collectionClass streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!ArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedElementAccessTest

	self moreThan4Elements.
	self assert: self moreThan4Elements size >= 4.
	self subCollectionNotIn.
	self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ].
	self elementNotInForElementAccessing.
	self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing).
	self elementInForElementAccessing.
	self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! !

!ArrayTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWith
	| result  indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1.
	lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection  size -1.
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: lastIndexOfOldSubcollection   with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'  "
	
	1 to: (indexOfSubcollection  - 1) do: 
		[ 
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i) = (result at: i)
		].
	
	" middle part containing replacementCollection : "
	
	(indexOfSubcollection ) to: ( lastIndexOfReplacementCollection  ) do: 
		[
		:i |
		self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1))
		].
	
	" end part :"
	1 to: (result size - lastIndexOfReplacementCollection   ) do:
		[ 
		:i |
		self assert: (result at: ( lastIndexOfReplacementCollection  + i  ) ) = (self collectionWith1TimeSubcollection  at: ( lastIndexOfOldSubcollection  + i  ) ).
		].! !

!ArrayTest methodsFor: 'tests - equality' stamp: ''!
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 - sorting' stamp: ''!
testSortUsingSortBlock
	| result tmp |
	result := self unsortedCollection sort: [:a :b | a>b].
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionOfCollectionsOfInts
	^collectionOfCollectionsOfInts.! !

!ArrayTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOfIAbsent
	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) 
	     equals: 1.

	self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) 
		  equals: 55! !

!ArrayTest methodsFor: 'tests - iterate' stamp: ''!
testAnySatisfy

	self assert: ( self collection anySatisfy: [:each | each = -2]).
	self deny: (self collection anySatisfy: [:each | each isString]).! !

!ArrayTest methodsFor: 'tests' stamp: ''!
testComplexIsSelfEvaluating
	| complexArray restoredArray |
	complexArray := {1 . true . false . nil . #a . 'a' . $a . Float pi . Float halfPi . (4 / 5) . Float infinity negated . (1 @ 2) . (0 @ 0 extent: 1 @ 1).
	('hola' -> 0) . Object . Object class}.
	complexArray := complexArray copyWith: complexArray.
	self assert: complexArray isSelfEvaluating.
	restoredArray := self class evaluate: complexArray printString.
	self assert: restoredArray equals: complexArray! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastError

	self 
		should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ]
		raise: Error! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLast

	| element result |
	element := self nonEmptyMoreThan1Element at: self nonEmptyMoreThan1Element size.
	result := self nonEmptyMoreThan1Element findLast: [:each | each =element].
	
	self assert: result equals: self nonEmptyMoreThan1Element size! !

!ArrayTest methodsFor: 'tests - copying same contents' stamp: ''!
testShuffled
	| result |
	result := self nonEmpty shuffled .
	
	"verify content of 'result: '"
	result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size.! !

!ArrayTest methodsFor: 'tests - streaming' stamp: ''!
testNewStreamContentsReturnsCollectionOfCorrectSize
	| result item originalSize |
	originalSize := 10.
	item := self firstCollection first.
	result := self collectionClass
		new: originalSize
		streamContents: [ :stream | 
			1 to: originalSize + 1 do: [ :each | stream nextPut: item ].
			stream position: originalSize ].
	self assert: result size equals: originalSize! !

!ArrayTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceFromToWith
	| result collection replacementCollec firstInd secondInd |
	collection := self nonEmpty .
	replacementCollec := self replacementCollectionSameSize.
	firstInd := self firstIndex.
	secondInd := self secondIndex.
	result := collection copy.
	result replaceFrom: firstInd to: secondInd with: replacementCollec.
	
	"Verify content of 'result'"

	"First part of 'result'"	
	1 to: (firstInd - 1) do: [:i | self assert: (collection at:i) equals: (result at: i) ].
	
	"Middle part containing replacementCollection"	
	firstInd to: (firstInd + replacementCollec size - 1) do: 
		[:i | self assert: (result at: i) equals: (replacementCollec at: (i - firstInd + 1)) ].
	
	"End part"
	(firstInd + replacementCollec size) to: (result size) do:
		[:i|
		self assert: (result at: i) equals: (collection at: (secondInd + 1 - (firstInd + replacementCollec size) + i)) ]! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToEmpty
	| result |
	result := self empty copyUpTo: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!ArrayTest methodsFor: 'asserting' stamp: ''!
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) equals: (result occurrencesOf: each) ].
	self assert: result size equals: aCollection size! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithEqualElements
	^ withEqualElements.! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
elementTwiceInForOccurrences
" return an element included exactly two time in # collectionWithEqualElements"
^ duplicateElement! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButLastDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButLastDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i ))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element  size-1)! !

!ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllPutAll

	| aValueArray |
	aValueArray := self valueArray .
	self nonEmpty atAll: self indexArray putAll: aValueArray  .
	
	self indexArray withIndexDo: [:element :index |
		self assert: (self nonEmpty at: element) equals: (aValueArray  at: index) ]! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollectError

	self should: [ self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error! !

!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := firstCollection size.
	
	firstCollection  reverseWith: secondCollection do:
		[:a :b |
	
		self assert: (firstCollection at: index) equals: a. 
		self assert: (secondCollection at: index) equals: b.
			(index := index - 1)]! !

!ArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtOutOfBounds

	self 
		should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ]
		raise: Error.
	self 
		should: [ self moreThan4Elements at: -1 ]
		raise: Error! !

!ArrayTest methodsFor: 'tests - occurrencesOf' stamp: ''!
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 equals: expected! !

!ArrayTest methodsFor: 'tests - copy' stamp: ''!
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 - fixture' stamp: ''!
test0FixtureOccurrencesTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementInForOccurrences.
	self assert: (self nonEmpty includes: self elementInForOccurrences).
	self elementNotInForOccurrences.
	self deny: (self nonEmpty includes: self elementNotInForOccurrences)! !

!ArrayTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWith1Occurrence
	| 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 part of sequenceable' stamp: ''!
testCopyEmptyMethod
	| result |
	result := self collectionWithoutEqualElements copyEmpty.
	self assertEmpty: result.
	self assert: result class equals: self nonEmpty class! !

!ArrayTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollectAs

	self 
		assert: (self simpleCollection flatCollect: [ :x | { x }, { x } ] as: IdentitySet) 
		equals: self simpleCollection asIdentitySet.
	self
		assert: (#(foo bar baz) flatCollect: #yourself as: String)
		equals: 'foobarbaz'.
	self 
		assert: (#(#(1 2) #(4 3)) flatCollect: #yourself as: Array)
		equals: #(1 2 4 3)! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfter
	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection   copyAfter: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!ArrayTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!ArrayTest methodsFor: 'parameters' stamp: ''!
accessValuePutInOn: s

	"return access the element put in the non-empty collection"
	
	^ s perform: self selectorToAccessValuePutIn! !

!ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!ArrayTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollectAsSet

	self 
		assert: (self simpleCollection flatCollectAsSet: [ :x | { x }, { x } ]) 
		equals: self simpleCollection asSet! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithCopy
	"Return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals (with identity equality)
	but 2 elements only equals with classic equality"
	
	| result collection |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	collection add: collection first copy.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!ArrayTest methodsFor: 'tests - includes' stamp: ''!
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' stamp: ''!
testIdentityIncludes
	" test the comportement in presence of elements 'includes' but not 'identityIncludes' "

	" can not be used by collections that can't include elements for wich copy doesn't return another instance "

	| collection element |
	self collectionWithCopyNonIdentical.
	collection := self collectionWithCopyNonIdentical.
	element := collection anyOne copy.	"self assert: (collection includes: element)."
	self deny: (collection identityIncludes: element)! !

!ArrayTest methodsFor: 'tests - subcollections access' stamp: ''!
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 - iterate on sequenced reable collections' stamp: ''!
testFindFirst

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element findFirst: [:each | each = element].
	
	self assert: result equals: 1! !

!ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
 	 'copyUpTo:' should copy until the first occurrence"
	result := collection copyUpTo: element.

	"Verify content"
	self assertEmpty: result! !

!ArrayTest methodsFor: 'tests - index access' stamp: ''!
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) equals: index! !

!ArrayTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	 
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!ArrayTest methodsFor: 'tests - as set tests' stamp: ''!
testAsSetWithEqualsElements

	| result |
	result := self withEqualElements asSet.
	self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = Set! !

!ArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
	^ withoutEqualElements! !

!ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |
	delim := ', '.
	result := ''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!ArrayTest methodsFor: 'parameters' stamp: ''!
selectorToAccessValuePutIn
	"return the selector of the method that should be invoked to access an element"
	
	^ #second! !

!ArrayedCollection commentStamp: ''!
I am an abstract collection of elements with a fixed range of integers (from 1 to n>=0) as external keys.!
!ArrayedCollection methodsFor: 'private' stamp: ''!
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: 'removing' stamp: ''!
removeAll

	self shouldNotImplement! !

!ArrayedCollection methodsFor: 'accessing' stamp: ''!
size
	"Answer how many elements the receiver contains."

	<primitive: 62>
	^ self basicSize! !

!ArrayedCollection methodsFor: 'private' stamp: ''!
storeElementsFrom: firstIndex to: lastIndex on: aStream

	| noneYet defaultElement arrayElement |
	noneYet := true.
	defaultElement := self defaultElement.
	firstIndex to: lastIndex do: 
		[:index | 
		arrayElement := self at: index.
		arrayElement = defaultElement
			ifFalse: 
				[noneYet
					ifTrue: [noneYet := false]
					ifFalse: [aStream nextPut: $;].
				aStream nextPutAll: ' at: '.
				aStream store: index.
				aStream nextPutAll: ' put: '.
				aStream store: arrayElement]].
	^noneYet! !

!ArrayedCollection methodsFor: 'adding' stamp: ''!
add: newObject
	self shouldNotImplement! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: ''!
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: '*Graphics-Primitives' stamp: ''!
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].
 	EndianDetector isLittleEndian 
 		ifTrue: 
 			[Bitmap 
 				swapBytesIn: self
 				from: 1
 				to: self basicSize]! !

!ArrayedCollection methodsFor: '*Graphics-Primitives' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
byteSize
	^self basicSize * self bytesPerBasicElement! !

!ArrayedCollection methodsFor: 'printing' stamp: ''!
storeOn: aStream

	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new: '.
	aStream store: self size.
	aStream nextPut: $).
	(self storeElementsFrom: 1 to: self size on: aStream)
		ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !

!ArrayedCollection methodsFor: 'private' stamp: ''!
defaultElement

	^nil! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: ''!
new
	"Answer a new instance of me, with size = 0."

	^self new: 0! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: ''!
new: size withAll: value 
	"Answer an instance of me, with number of elements equal to size, each 
	of which refers to the argument, value."

	^(self new: size) atAllPut: value! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: ''!
with: 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: ''!
withAll: aCollection
	"Create a new collection containing all the elements from aCollection."

	^ (self new: aCollection size) replaceFrom: 1 to: aCollection size with: aCollection! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: ''!
with: anObject withAll: aCollection
	"Creates an array with anObject followed by elements contained in aCollection."
	"(Array with: 1 withAll: #(2 3 4)) >>> #(1 2 3 4)"
	
	| newArray |
	newArray := self new: aCollection size + 1.
	newArray at: 1 put: anObject.
	newArray
		replaceFrom: 2
		to: newArray size
		with: aCollection.
	^newArray! !

!ArrayedCollection class methodsFor: 'testing' stamp: ''!
isAbstract

	^self name = #ArrayedCollection! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: ''!
with: firstObject with: secondObject with: thirdObject with: fourthObject 
	"Answer a new instance of me, containing only the three arguments as
	elements."

	| newCollection |
	newCollection := self new: 4.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	newCollection at: 4 put: fourthObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: ''!
with: anObject 
	"Answer a new instance of me, containing only anObject."

	| newCollection |
	newCollection := self new: 1.
	newCollection at: 1 put: anObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: ''!
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: ''!
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: ''!
with: firstObject with: secondObject with: thirdObject 
	"Answer a new instance of me, containing only the three arguments as
	elements."

	| newCollection |
	newCollection := self new: 3.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: ''!
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! !

!AsciiCharset commentStamp: ''!
This class defines the attributes of the ASCII character set.  It's here to be used while boostrapping the image; eventually, it will be replaced by the Unicode character set.

Character objects delegate behaviour to one of the  character sets AsciiCharSet, Latin1, or Unicode. !
!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isSurrogateOther: char 
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isPrivateOther: char
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isClosePunctuation: char
	^ ')]}' includes: char! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isEnclosingMark: char
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isSpacingCombiningMark: char
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isOtherNumber: char
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isParagraphSeparator: char
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isDigit: aCharacter
	^ aCharacter between: $0 and: $9! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isModifierSymbol: char
	^ '^`' includes: char! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isNonspacingMark: char
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isCasedLetter: char
	"There are no ASCII Characters in this Category"
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isUppercase: aCharacter
	^ aCharacter between: $A and: $Z! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isOpenPunctuation: char
	^ '([{' includes: char! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isLetterNumber: char
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isOtherLetter: char 
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isFormatOther: char 
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isMathSymbol: char
	^ '+<=>|~' includes: char! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isLetter: aCharacter
	^ (aCharacter between: $a and: $z)
		or: [ aCharacter between: $A and: $Z ]! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isDecimalDigit: char
	^ self isDigit: char! !

!AsciiCharset class methodsFor: 'sizing' stamp: ''!
maxValue
	"The maximum value of a character in this character set"

	^ 127! !

!AsciiCharset class methodsFor: 'testing' stamp: ''!
canBeGlobalVarInitial: aCharacter 
	
	^ self isUppercase: aCharacter! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isInitialQuote: char
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isConnectorPunctuation: char
	^ char = $_! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isLetterModifier: char 
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isOtherPunctuation: char
	^ '!!"#%&''*,./:;?@\' includes: char! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isCurrencySymbol: char
	^ char = $$! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isOtherSymbol: char
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isFinalQuote: char
	^ false! !

!AsciiCharset class methodsFor: 'casing' stamp: ''!
toLowercase: aCharacter
	"(AsciiCharset toLowercase: $A) >>> $a.
	 (AsciiCharset  toLowercase: $a) >>> $a.
	 (AsciiCharset  toLowercase: $!!) >>> $!!"

	(aCharacter between: $A and: $Z)
		ifFalse: [ ^ aCharacter ].
	^ Character
		value: aCharacter asciiValue + $a asInteger - $A asInteger! !

!AsciiCharset class methodsFor: 'casing' stamp: ''!
toUppercase: aCharacter
	"(AsciiCharset toUppercase: $a) >>> $A.
	(AsciiCharset toUppercase: $A) >>> $A.
	(AsciiCharset toUppercase: $!!) >>> $!!"

	(aCharacter between: $a and: $z)
		ifFalse: [ ^ aCharacter ].
	^ Character
		value: aCharacter asciiValue - $a asInteger + $A asInteger! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isControlOther: char
	char charCode <= 16r1F ifTrue: [ ^ true ].
	^ char = Character delete! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isLowercase: aCharacter
	^ aCharacter between: $a and: $z! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isLineSeparator: char
	^ false! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isDashPunctuation: char
	^ char = $-! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isSpaceSeparator: char
	^ char = Character space! !

!AsciiCharset class methodsFor: 'character classification' stamp: ''!
isTitlecaseLetter: char 
	^ false! !

!AsciiCharsetTest commentStamp: ''!
Tests for the AsciiCharSet class.  The invariant is that AsciiCharSet is  a subset of Unicode, and therefore all of the methods defined there should
have behaviour consisetent with Unicode.!
!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsFinalQuote

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isFinalQuote: ch) equals: (charset isFinalQuote: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsLineSeparator

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isLineSeparator: ch) equals: (charset isLineSeparator: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsPrivateOther
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isPrivateOther: ch)
			equals: (charset isPrivateOther: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsOtherLetter
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isOtherLetter: ch)
			equals: (charset isOtherLetter: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsCasedLetter
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isCasedLetter: ch) equals: (charset isCasedLetter: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsSpaceSeparator
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isSpaceSeparator: ch)
			equals: (charset isSpaceSeparator: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsLetter

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isLetter: ch) equals: (charset isLetter: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsOtherSymbol
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isOtherSymbol: ch)
			equals: (charset isOtherSymbol: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsFormatOther

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isFormatOther: ch) equals: (charset isFormatOther: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsDashPunctuation

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isDashPunctuation: ch) equals: (charset isDashPunctuation: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsInitialQuote

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isInitialQuote: ch) equals: (charset isInitialQuote: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsOtherNumber
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isOtherNumber: ch)
			equals: (charset isOtherNumber: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsMathSymbol

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isMathSymbol: ch) equals: (charset isMathSymbol: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsOtherPunctuation
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isOtherPunctuation: ch)
			equals: (charset isOtherPunctuation: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsSurrogateOther
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isSurrogateOther: ch)
			equals: (charset isSurrogateOther: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsEnclosingMark

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isEnclosingMark: ch) equals: (charset isEnclosingMark: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsOpenPunctuation
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isOpenPunctuation: ch)
			equals: (charset isOpenPunctuation: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsDecimalDigit

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isDecimalDigit: ch) equals: (charset isDecimalDigit: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsClosePunctuation
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isClosePunctuation: ch)
			equals: (charset isClosePunctuation: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsDigit

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isDigit: ch) equals: (charset isDigit: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsModifierSymbol

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isModifierSymbol: ch) equals: (charset isModifierSymbol: ch) ]! !

!AsciiCharsetTest methodsFor: 'helper' stamp: ''!
classUnderTest
	^ AsciiCharset! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsLetterModifier

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isLetterModifier: ch) equals: (charset isLetterModifier: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsNonspacingMark
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isNonspacingMark: ch)
			equals: (charset isNonspacingMark: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsTitlecaseLetter
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isTitlecaseLetter: ch)
			equals: (charset isTitlecaseLetter: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsParagraphSeparator
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isParagraphSeparator: ch)
			equals: (charset isParagraphSeparator: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsCurrencySymbol

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isCurrencySymbol: ch) equals: (charset isCurrencySymbol: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsUppercase
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isUppercase: ch)
			equals: (charset isUppercase: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsLowercase

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isLowercase: ch) equals: (charset isLowercase: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsSpacingCombiningMark
	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self
			assert: (Unicode isSpacingCombiningMark: ch)
			equals: (charset isSpacingCombiningMark: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsConnectorPunctuation

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isConnectorPunctuation: ch) equals: (charset isConnectorPunctuation: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsControlOther

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isControlOther: ch) equals: (charset isControlOther: ch) ]! !

!AsciiCharsetTest methodsFor: 'generated tests' stamp: ''!
testIsLetterNumber

	"Exhaustively check that the charset under test behaves like Unicode"

	| charset |
	charset := self classUnderTest.
	0 to: charset maxValue do: [ :asciiValue | 
		| ch |
		ch := Character value: asciiValue.
		self assert: (Unicode isLetterNumber: ch) equals: (charset isLetterNumber: ch) ]! !

!AssemblyManifest commentStamp: ''!
I store meta-data for a package assembly. I'm the common superclass of all package assemblies.!
!AssemblyManifest class methodsFor: 'accessing' stamp: ''!
parts
	^ #()! !

!AssemblyManifest class methodsFor: 'accessing' stamp: ''!
includes: aPackageName
	^ (self parts collect: [:each | each key]) 
		includes: aPackageName! !

!AssemblyManifest class methodsFor: 'instance creation' stamp: ''!
newNamed: aString category: aCategoryName
	| assemblyClass |
	assemblyClass := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder name: aString asSymbol;
		package: aCategoryName ].

	assemblyClass comment: self manifestClassComment.
	^ assemblyClass! !

!AssemblyManifest class methodsFor: 'accessing' stamp: ''!
description
	^ self name , ' description'! !

!AssemblyManifest class methodsFor: 'compatibility - package manifest' stamp: ''!
ignoredDependencies
	^ #()! !

!AssemblyManifest class methodsFor: 'default' stamp: ''!
manifestClassComment
	^ 'I store metadata for this package assembly.'! !

!AssemblyManifest class methodsFor: 'accessing' stamp: ''!
version
	^ '0.1-dev'! !

!AssemblyManifest class methodsFor: 'accessing' stamp: ''!
packageName
	self shouldBeImplemented! !

!AssertionFailure commentStamp: ''!
AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.!
!AssignmentAndLiteralDebuggerTest methodsFor: 'tests' stamp: ''!
testStepOverLiteral
	session stepOver.
	self assert: context top equals: 4.! !

!AssignmentAndLiteralDebuggerTest methodsFor: 'tests' stamp: ''!
testStepOverAssignment
	session stepOver.
	self assert: (context tempNamed: 'var') equals: 4.! !

!AssignmentAndLiteralDebuggerTest methodsFor: 'tests' stamp: ''!
testNewDebugSession
	self assert: context size equals: 2. "we are in the block"
	self assert: session interruptedContext equals: context.! !

!AssignmentAndLiteralDebuggerTest methodsFor: 'tests' stamp: ''!
testStepIntoLiteral
	session stepInto.
	self assert: context top equals: 4.! !

!AssignmentAndLiteralDebuggerTest methodsFor: 'tests' stamp: ''!
testInterruptedContextEqualsSuspendedContextOfInterruptedProcess
	self assert: session interruptedContext equals: session interruptedProcess suspendedContext.
	session stepInto.
	session stepInto.
	self assert: session interruptedContext equals: session interruptedProcess suspendedContext.! !

!AssignmentAndLiteralDebuggerTest methodsFor: 'tests' stamp: ''!
testStepIntoAssignment
	session stepInto.
	self assert: (session interruptedContext tempNamed: 'var') equals: 4.! !

!AssignmentAndLiteralDebuggerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self settingUpSessionAndProcessAndContextForBlock: [ |var| var:=4].! !

!Association commentStamp: ''!
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: 'accessing' stamp: ''!
value: anObject 
	"Store the argument, anObject, as the value of the receiver."

	value := anObject! !

!Association methodsFor: 'comparing' stamp: ''!
= anAssociation

	^ super = anAssociation and: [value = anAssociation value]! !

!Association methodsFor: 'comparing' stamp: ''!
literalEqual: otherLiteral
	"Answer true if the receiver and otherLiteral represent the same literal.
	Variable bindings are literally equals only if identical.
	This is how variable sharing works, by preserving identity and changing only the value."
	^self == otherLiteral! !

!Association methodsFor: '*Morphic-Base' stamp: ''!
treeNodeHead

	^ (key isKindOf: Association)
		ifTrue: [ key treeNodeHead ]
		ifFalse: [ key ]! !

!Association methodsFor: 'variables-toclean' stamp: ''!
isAssociation
	^ true! !

!Association methodsFor: '*ParametrizedTests' stamp: ''!
asTestParameter

	^ ParametrizedTestExpandedParameter new
		selector: self key;
		valuable: self value;
		yourself! !

!Association methodsFor: 'accessing' stamp: ''!
key: aKey value: anObject 
	"Store the arguments as the variables of the receiver."

	key := aKey.
	value := anObject! !

!Association methodsFor: '*System-Settings-Browser' stamp: ''!
settingFixedDomainValueNodeFrom: aSettingNode 
	^ aSettingNode fixedDomainValueNodeForAssociation: self! !

!Association methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '->'.
	value printOn: aStream! !

!Association methodsFor: 'testing' stamp: ''!
analogousCodeTo: anAssociation
	^ self = anAssociation! !

!Association methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating
	^ self class == Association and: [self key isSelfEvaluating and: [self value isSelfEvaluating]]! !

!Association methodsFor: 'evaluating' stamp: ''!
value
	"Answer the value of the receiver."

	^value! !

!Association methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	self class == STON associationClass
		ifTrue: [ stonWriter writeAssociation: self ]
		ifFalse: [ super stonOn: stonWriter ]
	! !

!Association methodsFor: 'testing' stamp: ''!
hasLiteral: aLiteral
	^false! !

!Association methodsFor: '*Morphic-Base' stamp: ''!
treeNodeTail

	^ (key isKindOf: Association)
		ifTrue: [ key treeNodeTail -> value ]
		ifFalse: [ value ]! !

!Association methodsFor: 'printing' stamp: ''!
storeOn: aStream
	"Store in the format (key->value)"
	aStream nextPut: $(.
	key storeOn: aStream.
	aStream nextPutAll: '->'.
	value storeOn: aStream.
	aStream nextPut: $)! !

!Association methodsFor: 'variables-toclean' stamp: ''!
isVariableBinding
	"Can be removed as soon as all bindings are instances of LiteralVariable"
	^true! !

!Association class methodsFor: 'instance creation' stamp: ''!
key: newKey value: newValue
	"Answer an instance of me with the arguments as the key and value of 
	the association."

	^self basicNew key: newKey value: newValue! !

!AssociationTest commentStamp: ''!
SUnit tests for Associations!
!AssociationTest methodsFor: 'tests' stamp: ''!
testComparison

	self assert: ((#a -> 'foo') < (#b -> 'zork'))! !

!AssociationTest methodsFor: 'tests' stamp: ''!
testEquality
	self
		assert: a key equals: b key;
		deny: a value equals: b value;
		deny: a equals: b! !

!AssociationTest methodsFor: 'tests' stamp: ''!
testStoreOnNegativeInteger
	| association storeString |
	association := 'a'-> -1.
	
	storeString := String streamContents: [ :s | association storeOn: s ].
	
	self assert: storeString equals: '(''a''-> -1)'! !

!AssociationTest methodsFor: 'tests' stamp: ''!
testIsSelfEvaluating
	| anotherAssociation |
	self assert: a isSelfEvaluating.
	
	self assert: a printString equals: '1->''one'''.
	
	anotherAssociation := Object new -> Object new.
	anotherAssociation isSelfEvaluating 
		ifTrue: [ self assert: (self class compiler evaluate: anotherAssociation printString) = anotherAssociation
							description: 'a self evaluating should evaluate as self' ]! !

!AssociationTest methodsFor: 'tests' stamp: ''!
testStoreOnPositiveInteger
	| association storeString |
	association := 'a'-> 1.
	storeString := String streamContents: [ :s | association storeOn: s ].
	
	self assert: storeString equals: '(''a''->1)'! !

!AssociationTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testStoreOnNegativeIntegerRoundtrip
	| association storeString evaluated |
	association := 'a'-> -1.
	
	storeString := String streamContents: [ :s | association storeOn: s ].
	
	evaluated := Smalltalk compiler evaluate: storeString.
	
	self assert: association equals: evaluated! !

!AssociationTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Association! !

!AssociationTest methodsFor: 'tests' stamp: ''!
testHash

	self 
		assert: a hash equals: a copy hash;
		assert: a hash equals: b hash! !

!AssociationTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testStoreOnPositiveIntegerRoundtrip
	| association storeString evaluated |
	association := 'a'-> 1.
	storeString := String streamContents: [ :s | association storeOn: s ].
	
	evaluated := Smalltalk compiler evaluate: storeString.
	
	self assert: association equals: evaluated! !

!AssociationTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	a := 1 -> 'one'.
	b := 1 -> 'een'! !

!AsyncFile commentStamp: ''!
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: 'tests' stamp: 'nil'!
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: 'write and read' stamp: 'nil'!
waitForCompletion

	semaphore wait! !

!AsyncFile methodsFor: 'accessing' stamp: 'nil'!
fileHandle

	^ fileHandle! !

!AsyncFile methodsFor: 'write and read' stamp: 'nil'!
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: 'nil'!
primReadStart: fHandle fPosition: fPosition count: count
	"Start a read operation of count bytes starting at the given offset in the given file."

	<primitive: 'primitiveAsyncFileReadStart' module: 'AsynchFilePlugin'>	
	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 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: 'nil'!
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."

	<primitive: 'primitiveAsyncFileWriteStart' module: 'AsynchFilePlugin'>
	writeable ifFalse: [^ self error: 'attempt to write a file opened read-only'].
	self primitiveFailed! !

!AsyncFile methodsFor: 'open/close' stamp: 'nil'!
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: 'primitives' stamp: 'nil'!
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"

	<primitive: 'primitiveAsyncFileWriteResult' module: 'AsynchFilePlugin'>
	self primitiveFailed! !

!AsyncFile methodsFor: 'write and read' stamp: 'nil'!
readByteCount: byteCount fromFilePosition: fPosition onCompletionDo: aBlock
	"Start a read operation to read byteCount's from the given position in this file. and fork a process to await its completion. When the operation completes, evaluate the given block. Note that, since the completion block may run asynchronous, the client may need to use a SharedQueue or a semaphore for synchronization."

	| buffer |
	buffer := String new: byteCount.
	self primReadStart: fileHandle fPosition: fPosition count: byteCount.
	"here's the process that awaits the results:"
	[| n |
		[	semaphore wait.
		  	n := self primReadResult: fileHandle intoBuffer: buffer at: 1 count: byteCount.
		  	n = Busy.
		] whileTrue.  "loop while busy in case the semaphore had excess signals"
		n = ErrorCode ifTrue: [^ self error: 'asynchronous read operation failed'].
		aBlock value: buffer.
	] forkAt: Processor userInterruptPriority.! !

!AsyncFile methodsFor: 'primitives' stamp: 'nil'!
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."

	<primitive: 'primitiveAsyncFileOpen' module: 'AsynchFilePlugin'>
	^ nil! !

!AsyncFile methodsFor: 'primitives' stamp: 'nil'!
primClose: fHandle
	"Close this file. Do nothing if primitive fails."

	<primitive: 'primitiveAsyncFileClose' module: 'AsynchFilePlugin'>! !

!AsyncFile methodsFor: 'open/close' stamp: 'nil'!
close

	fileHandle ifNil: [ ^ self ]. "already closed"
	self primClose: fileHandle.
	Smalltalk unregisterExternalObject: semaphore.
	semaphore := nil.
	fileHandle := nil! !

!AsyncFile methodsFor: 'primitives' stamp: 'nil'!
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"

	<primitive: 'primitiveAsyncFileReadResult' module: 'AsynchFilePlugin'>
	self primitiveFailed! !

!AsyncFile class methodsFor: 'class initialization' stamp: 'nil'!
initialize
	"Possible abnormal I/O completion results."

	Busy := -1.
	ErrorCode := -2! !

!AthensAbstractMeshPaintPatch commentStamp: ''!
I am a patch in a mesh gradient.!
!AthensAbstractMeshPaintPatch methodsFor: 'accessing' stamp: ''!
controlPoints: anObject
	controlPoints := anObject! !

!AthensAbstractMeshPaintPatch methodsFor: 'accessing' stamp: ''!
colors: anObject
	colors := anObject! !

!AthensAbstractMeshPaintPatch methodsFor: '*Athens-Cairo' stamp: ''!
addToCairoMeshGradientPaint: meshGradientPaint
	self subclassResponsibility! !

!AthensAbstractMeshPaintPatch methodsFor: 'accessing' stamp: ''!
colors
	^ colors! !

!AthensAbstractMeshPaintPatch methodsFor: 'accessing' stamp: ''!
controlPoints
	^ controlPoints! !

!AthensAbstractMeshPaintPatch class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == AthensAbstractMeshPaintPatch! !

!AthensAbstractMeshPaintPatch class methodsFor: 'constructor' stamp: ''!
controlPoints: controlPoints colors: colors
	^ self new controlPoints: controlPoints; colors: colors; yourself! !

!AthensAbstractPaint commentStamp: ''!
I am an abstract paint, which should be converted before it can be used by Athens.
I am backend agnostic, as opposed to concrete paint(s).
Also, any other object can play the role of paint, as long as it implements the conversion method, #asAthensPaintOn:

See other implementors of #asAthensPaintOn:, such as Color and Form.!
!AthensAbstractPaint methodsFor: 'converting' stamp: ''!
asAthensPaintOn: aCanvas	
	^ self! !

!AthensAbstractPaint class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == AthensAbstractPaint! !

!AthensAbstractShape commentStamp: ''!
In Athens, any object can play role of a shape.

I demonstrating the minimal protocol which should be supported
by "shape" role, to be used with Athens canvas.
See my methods comments for more details.
!
!AthensAbstractShape methodsFor: 'converting' stamp: ''!
asAthensShapeOn: canvas
	"Note: The answered object of this message should conform with AthensShape protocol.	"
	self subclassResponsibility! !

!AthensAbstractShape class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == AthensAbstractShape! !

!AthensAffineTransform commentStamp: ''!
I support the same protocol than AthensTransform,
but in addition I store a plain 2x3 matrix with state accessible at any moment.

This is different to AthensTransform because it does not expose its internal storage, because it can be backend specific.!
!AthensAffineTransform methodsFor: 'private' stamp: ''!
inverseTransformHalfPi: aPoint
	"Assume sx,sy = 0
		
	px := y0*shx + x.
	py := x0*shy + y.
	
	we doing inverse one, trying to find x0,y0 for rest of given variables (px,py,x,y,sx,sy,shx,shy)"
	| px py y0 x0 |
	
	px := aPoint x.
	py := aPoint y.

	x0 := py - y  / shy.
	y0 := px - x  / shx.

	^ x0@y0! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
rotateByRadians: angle

	"Multiply receiver by rotation matrix

| sx   shx   x   |       | cos -sin  0  |        | (sx*cos)+(shx*sin)   (-sx*sin+shx*cos)  x |
| shy   sy   y   |   *   | sin   cos 0  |   ===> | (shy*cos)+(sy*sin)   (-shy*sin)+sy*cos) y |
|  0     0   1   |       | 0     0   1  |        |        0                   0            1 |

"
	| cos sin newSx newSy |
	
	cos := angle cos.
	sin := angle sin.
	
	
	newSx := sx*cos + (shx*sin).
	newSy := sy*cos - (shy*sin).
	
	shx := shx*cos - (sx*sin).
	shy := shy*cos + (sy*sin).

	sx := newSx.
	sy := newSy.! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
shy
	^ shy! !

!AthensAffineTransform methodsFor: 'vector - transform' stamp: ''!
transformX: px Y: py
	"Transform x and y coordinates by receiver. Answer a Point"
	^ Point 
		x: (sx*px +(shx*py) + x)
		y: (shy*px + (sy*py) + y)! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
clearTranslation
	"Reset a translation from matrix, leaving only scale and rotation"
	
	x := y := 0.0! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
translateX: px Y: py
	"Multiply receiver by translation matrix :

| sx    shx   x   |       | 1  0  px |        |	sx  shx  (sx*px + shx*py + x)  |
| shy   sy    y   |   *   | 0  1  py |   ===> | shy   sy  (shy*px + sy*py + y)  |
|  0    0     1   |       | 0  0  1  |        |  0     0    1                   |

"
	x := (sx*px) + (shx*py) + x.
	y := (shy*px) + (sy*py) + y! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
shx
	^ shx! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
translation
	^ x@y! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
translateBy: aPoint

	^ self translateX: aPoint x Y: aPoint y! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
shy: number
	shy := number! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
translation: aPoint
	x := aPoint x.
	y := aPoint y! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
x
	^ x! !

!AthensAffineTransform methodsFor: 'testing' stamp: ''!
isAffineTransform
	^ true! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
x: number
	x := number! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
inverted
	"Answer an inverse transformation of receiver"
	| det |
	det := sx * sy - (shx * shy).
	^ self class new
		sx: sy / det;
		sy: sy / det;
		shx: shx * -1 / det;
		shy: shy * -1 / det;
		x: shx * y - (x * sy) / det;
		y: shy * x - (sx * y) / det;
		yourself! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
y: number
	y := number! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
y
	^ y! !

!AthensAffineTransform methodsFor: '*Roassal3' stamp: ''!
floatValues
	"convert all the values to float"
	x := x asFloat.
	y := y asFloat.
	sx := sx asFloat.
	sy := sy asFloat.
	shx := shx asFloat.
	shy := shy asFloat.
	
	! !

!AthensAffineTransform methodsFor: '*Roassal3' stamp: ''!
printOn: stream
	stream << 'x: '. x printOn: stream.
	stream << ' y: '. y printOn: stream.
	stream << ' sx: '. sx printOn: stream.
	stream << ' sy: '. sy printOn: stream.
	stream << ' shx: '. shx printOn: stream.
	stream << ' shy: '. shy printOn: stream.! !

!AthensAffineTransform methodsFor: 'testing' stamp: ''!
isIdentity
	^ sx = 1 and: [ shx = 0 and: [ x = 0 and: [
	shy = 0 and: [ sy = 1 and: [ y = 0]]]]]! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
loadIdentity
	"Initialize with identity transform"
	sx := sy := 1.0.
	shx := shy := x := y := 0.0! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
scale
	^ sx@sy! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
translateX: px y: py
	"Multiply receiver by translation matrix :

| sx   shx     x   |       | 1  0  px |        |	sx  shx  (sx*px + shx*py + x)  |
| shy   sy     y   |   *   | 0  1  py |   ===> | shy  sy  (shy*px + sy*py + y)  |
|  0     0     1   |       | 0  0   1 |        |  0     0    1                  |

"
	x := (sx*px) + (shx*py) + x.
	y := (shy*px) + (sy*py) + y! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
multiplyBy: m
	"Multiply receiver by given affine matrix"
"
| sx   shx   x   |        | sx'   shx'   x'   | 
| shy  sy    y   |   *    | shy'  sy'    y'   |
|  0   0     1   |        | 0  	0   	 1	   |       

"	
	
	| nsx nshx nx nshy nsy ny |
	
	nsx := sx * m sx + (shx  * m shy).
	nshx := sx * m shx + (shx * m sy).
	nx := sx * m x + (shx * m y) + x.
	
	nshy := shy * m sx + (sy * m shy).
	nsy := shy * m shx  + (sy * m sy).
	ny := shy* m x + (sy * m y) + y.
	
	sx := nsx.
	sy := nsy.
	shx := nshx.
	shy := nshy.
	x := nx.
	y := ny.! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
restoreAfter: aBlock
	|previous|
	previous := self copy.
	aBlock ensure: [ 	self loadAffineTransform: previous ]! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
rotateByDegrees: angle

	^ self rotateByRadians: angle degreesToRadians! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
transposed
	
	| s |
	s := shx.
	shx := shy.
	shy := s! !

!AthensAffineTransform methodsFor: 'initialization' stamp: ''!
initialize
	self loadIdentity! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
scaleBy: factor

	"multiply receiver by uniform scale matrix

| sx   shx   x   |       | (f x) 0 0  |             | sx*(f x)    shx*(f y)  x |
| shy sy     y   |   *   | 0 (f y) 0  |    ===> | shy*(f x)     sy*(f y)    y |
|  0     0     1  |        | 0 0     1  |                |  0      0              1  |

"	
	factor isPoint 
		ifTrue: [
			sx := sx*factor x.
			shx := shx*factor y.
			sy := sy*factor y.
			shy := shy*factor x ] 
		ifFalse: [
			sx := sx*factor.
			shx := shx*factor.
			sy := sy*factor.
			shy := shy*factor ]! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
sy: number
	sy := number! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
sy
	^ sy! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
shx: number
	shx := number! !

!AthensAffineTransform methodsFor: '*Roassal3-Shapes' stamp: ''!
rsInverseTransform: aPoint 
	"We assume matrix is never degenerated"
	| px py y0 x0 epsilon |
	epsilon := 0.000001.
	px := aPoint x.
	py := aPoint y.
	"for rotations around +/- half pi"
	((sx closeTo: 0 precision: epsilon) 
		and:[ sy closeTo: 0 precision: epsilon ]) ifTrue:[
		^ self inverseTransformHalfPi: aPoint.
		].
	"for rotations around +/- pi or 0"
	((shx closeTo: 0 precision: epsilon) 
		and:[ shy closeTo: 0 precision: epsilon ]) ifTrue:[
		^ self inverseTransformPiOrZero: aPoint.
		].
    "otherwise:
     Given straight transformation formulae:
		
	px := x0*sx + y0*shx + x.
	py := x0*shy + y0*sy + y.
	
	we doing inverse one, trying to find x0,y0 for rest of given variables (px,py,x,y,sx,sy,shx,shy).
	
	x0 := px - x - (shx*y0) / sx.
	y0 := py - y - (shy*x0) / sy.
	
	y0 := py - y - (shy*(px - x - (shx*y0) / sx)) / sy.

	sy * y0  == py - y - (shy*(px - x - (shx*y0) / sx)).

	sx * sy * y0  == (sx*(py - y)) - (shy*(px - x - (shx*y0))).

	sx * sy * y0  == sx*py - (sx*y) - (shy*px) + (shy*x) + (shy*shx*y0).

	(sx * sy * y0) - (shy*shx*y0)  == sx*py - (sx*y) - (shy*px) + (shy*x) .
	
	y0* ((sx * sy) - (shy*shx))  == sx*py - (sx*y) - (shy*px) + (shy*x) .

"
	y0  := sx*py - (sx*y) - (shy*px) + (shy*x) / ((sx * sy) - (shy*shx)).
	x0 := px - x - (shx*y0) / sx.

	^ x0@y0
	! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
sx
	^ sx! !

!AthensAffineTransform methodsFor: 'vector - transform' stamp: ''!
inverseTransform: aPoint 
	"We assume matrix is never degenerated"
	| px py y0 x0 |
	
	px := aPoint x.
	py := aPoint y.
	"for rotations around +/- half pi"
	(sx = 0 and:[ sy = 0]) ifTrue:[
		^ self inverseTransformHalfPi: aPoint.
		].
	"for rotations around +/- pi or 0"
	(shx = 0 and:[ shy = 0]) ifTrue:[
		^ self inverseTransformPiOrZero: aPoint.
		].
    "otherwise:
     Given straight transformation formulae:
		
	px := x0*sx + y0*shx + x.
	py := x0*shy + y0*sy + y.
	
	we doing inverse one, trying to find x0,y0 for rest of given variables (px,py,x,y,sx,sy,shx,shy).
	
	x0 := px - x - (shx*y0) / sx.
	y0 := py - y - (shy*x0) / sy.
	
	y0 := py - y - (shy*(px - x - (shx*y0) / sx)) / sy.

	sy * y0  == py - y - (shy*(px - x - (shx*y0) / sx)).

	sx * sy * y0  == (sx*(py - y)) - (shy*(px - x - (shx*y0))).

	sx * sy * y0  == sx*py - (sx*y) - (shy*px) + (shy*x) + (shy*shx*y0).

	(sx * sy * y0) - (shy*shx*y0)  == sx*py - (sx*y) - (shy*px) + (shy*x) .
	
	y0* ((sx * sy) - (shy*shx))  == sx*py - (sx*y) - (shy*px) + (shy*x) .

"
	y0  := sx*py - (sx*y) - (shy*px) + (shy*x) / ((sx * sy) - (shy*shx)).
	x0 := px - x - (shx*y0) / sx.

	^ x0@y0! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
invert
	"
	Affine matrix can be seen as TM X -> (TM)^-1 = M^1 T^-1
	"

	"Invert the 2x2 part"
	| det isx ishx ishy isy nx ny ix iy |
	det := (sx*sy) - (shy*shx).
	self assert: (det closeTo: 0) not.
	
	"Prefer direct division to improve floating point precision".
	isx := sy / det. ishx := shx negated / det.
	ishy := shy negated / det. isy := sx / det.
	nx := x negated.
	ny := y negated.

	ix := (isx*nx) + (ishx*ny).
	iy := (ishy*nx) + (isy*ny).

	"Set the result."
	sx := isx. shx := ishx. x := ix.
	shy := ishy. sy := isy. y := iy.! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
loadAffineTransform: m

	x := m x.
	y := m y.
	sx := m sx.
	sy := m sy.
	shx := m shx.
	shy := m shy! !

!AthensAffineTransform methodsFor: 'accessing' stamp: ''!
sx: number
	sx := number! !

!AthensAffineTransform methodsFor: 'private' stamp: ''!
inverseTransformPiOrZero: aPoint
	"Assume shx,shy = 0
		
	px := x0*sx + x.
	py := y0*sy + y.
	we doing inverse one, trying to find x0,y0 for rest of given variables (px,py,x,y,sx,sy,shx,shy)"
	
	| px py y0 x0 |
	
	px := aPoint x.
	py := aPoint y.

	x0 := px - x / sx.
	y0 := py - y / sy.

	^ x0@y0! !

!AthensAffineTransform methodsFor: 'transformations' stamp: ''!
scaleX: fx Y: fy

	"multiply receiver by scale matrix

| sx   shx   x   |       | fx 0 0  |         | sx*fx   shx*fy  x |
| shy   sy   y   |   *   | 0 fy 0  |    ===> | shy*fx  sy*fy   y |
|  0    0    1   |       | 0 0  1  |         |  0        0     1 |

"
	sx := sx*fx.
	shx := shx*fy.
	sy := sy*fy.
	shy := shy*fx.! !

!AthensAffineTransform methodsFor: 'vector - transform' stamp: ''!
transform: aPoint 
	| px py |
	
	px := aPoint x.
	py := aPoint y.
	^ Point 
		x: (sx*px +(shx*py) + x)
		y: (shy*px + (sy*py) + y)! !

!AthensAffineTransform methodsFor: '*Roassal3' stamp: ''!
asFloatTransform
	^ self copy floatValues; yourself	! !

!AthensAffineTransformTest commentStamp: ''!
An AthensAffineTransformTest is a test class for testing the behavior of AthensAffineTransform!
!AthensAffineTransformTest methodsFor: 'tests' stamp: ''!
transformClass
	^ AthensAffineTransform! !

!AthensArcSegment commentStamp: ''!
i am abstract class , representing an arc segment!
!AthensArcSegment methodsFor: 'accessing' stamp: ''!
angle
	^ angle! !

!AthensArcSegment methodsFor: 'accessing' stamp: ''!
endPoint: pt angle: a

	endPoint := pt.
	angle := a! !

!AthensArcSegment methodsFor: 'accessing' stamp: ''!
endPoint
	^ endPoint! !

!AthensBackgroundChange commentStamp: ''!
Text display command for changing the background color!
!AthensBackgroundChange methodsFor: 'accessing' stamp: ''!
color: anObject

	color := anObject! !

!AthensBackgroundChange methodsFor: 'accessing' stamp: ''!
width: anObject

	width := anObject! !

!AthensBackgroundChange methodsFor: 'accessing' stamp: ''!
width

	^ width! !

!AthensBackgroundChange methodsFor: 'initialization' stamp: ''!
initialize
	width :=0.
	color := Color transparent.! !

!AthensBackgroundChange methodsFor: 'adding' stamp: ''!
addWidth: aWidth
	width := width + aWidth! !

!AthensBackgroundChange methodsFor: 'rendering' stamp: ''!
renderOn: renderer
	color isTransparent ifFalse: [
		renderer renderBackground: self
	]! !

!AthensBackgroundChange methodsFor: 'accessing' stamp: ''!
start
	^ start! !

!AthensBackgroundChange methodsFor: 'accessing' stamp: ''!
start: aStart
	start := aStart! !

!AthensBackgroundChange methodsFor: 'accessing' stamp: ''!
color

	^ color! !

!AthensBalloonEngine commentStamp: ''!
- balloon engine using only first 4 variables of receiver instance:

 - work buffer
 - span
 - bitBlt (Bitblt object)
 - forms

!
!AthensBalloonEngine methodsFor: 'registering fills' stamp: ''!
registerFormFill: form origin: orig direction: dir normal: norm tileFlag: tileFlag

	forms := forms copyWith: form.
	form unhibernate.
	currentFill := self primAddBitmapFill: form
			colormap: (form colormapIfNeededForDepth: 32)
			tile: tileFlag
			from: orig
			along: dir
			normal: norm
			xIndex: forms size! !

!AthensBalloonEngine methodsFor: 'copying' stamp: ''!
copyBits

	(bitBlt notNil and: [ bitBlt destForm notNil ]) ifTrue: [ 
		bitBlt destForm unhibernate ].
	self copyLoopFastest! !

!AthensBalloonEngine methodsFor: 'private' stamp: ''!
fastReset

	workBuffer ifNil: [ ^ self reset ].

	workBuffer 
		at: (1+GWState) put: GEStateUnlocked;
		at: (1+GWObjUsed) put: 4;
		at: (1+GWNeedsFlush) put: 0;
		at: (1+GWCurrentZ) put: 0;
		at: (1+GWGETStart) put: 0";

		at: (1+GWGETUsed) put: 0;
		at: (1+GWAETStart) put: 0;
		at: (1+GWAETUsed) put: 0".
	
	self primSetEdgeTransform: edgeTransform.
	self primSetClipRect: clipRect.
	self primSetColorTransform: colorTransform.
	self primSetDepth: self primGetDepth + 1. 

	postFlushNeeded := false.
	forms := #()

"	
-	self magicNumberPut: GWMagicNumber.
- 	self wbSizePut: size.
+	self wbTopPut: size.
+	self statePut: GEStateUnlocked.
-	self objStartPut: GWHeaderSize.
+	self objUsedPut: 4.	
-	self objectTypeOf: 0 put: GEPrimitiveFill.
-	self objectLengthOf: 0 put: 4.
-	self objectIndexOf: 0 put: 0.

	self getStartPut: 0.
	self getUsedPut: 0.
	self aetStartPut: 0.
	self aetUsedPut: 0.
	self stopReasonPut: 0.

+	self needsFlushPut: 0.
-	self clipMinXPut: 0.
-	self clipMaxXPut: 0.
-	self clipMinYPut: 0.
-	self clipMaxYPut: 0.
+	self currentZPut: 0.
	self resetGraphicsEngineStats.
	self initEdgeTransform.
	self initColorTransform.
"! !

!AthensBalloonEngine methodsFor: 'paints' stamp: ''!
registerRadialGradient: colorRamp center: aCenter direction: dir normal: n

	| pixelRamp |
	pixelRamp := GradientFillStyle pixelRampCache at: colorRamp.

	currentFill := self
		               primAddGradientFill: pixelRamp
		               from: aCenter
		               along: dir
		               normal: n
		               radial: true! !

!AthensBalloonEngine methodsFor: 'drawing' stamp: ''!
strokeRectangle: rect borderWidth: width

	currentFill = 0 ifTrue: [ ^ self ]. "no fill "
	self primAddRectFrom: rect origin 
			to: rect corner
			fillIndex: 0
			borderWidth: width
			borderColor: currentFill.

	self copyBits! !

!AthensBalloonEngine methodsFor: 'accessing' stamp: ''!
setFill: aFill

	currentFill := aFill! !

!AthensBalloonEngine methodsFor: 'registering fills' stamp: ''!
registerColorFill: aColor 

	currentFill := aColor scaledPixelValue32! !

!AthensBalloonEngine methodsFor: 'registering fills' stamp: ''!
registerFormFill: form origin: orig direction: dir normal: norm

	self
		registerFormFill: form
		origin: orig
		direction: dir
		normal: norm
		tileFlag: true! !

!AthensBalloonEngine methodsFor: 'drawing' stamp: ''!
fillRectangle: rect 

	currentFill = 0 ifTrue: [ ^ self ]. "no fill "
	self primAddRectFrom: rect origin 
			to: rect corner
			fillIndex: currentFill
			borderWidth: 0
			borderColor: 0.

	self copyBits! !

!AthensBalloonEngine methodsFor: 'private' stamp: ''!
prepareForRendering

	self fastReset! !

!AthensBalloonEngine methodsFor: 'paints' stamp: ''!
registerRadialGradient: colorRamp center: aCenter radius: r

	| pixelRamp |
	pixelRamp := GradientFillStyle pixelRampCache at: colorRamp.

	currentFill := self
		               primAddGradientFill: pixelRamp
		               from: aCenter
		               along: aCenter x + r @ aCenter y
		               normal: aCenter x @ aCenter y - r
		               radial: true! !

!AthensBalloonEngine methodsFor: 'drawing' stamp: ''!
drawImage: aForm transform: m 
	| orig dir normal tr rect |

	rect := aForm boundingBox.
	orig := 0@0. 
	dir := aForm width @ 0.
	normal := 0 @ aForm height.
	
	tr := edgeTransform.
	edgeTransform := m.

	self prepareForRendering.
	self registerFormFill: aForm
		origin: orig
		direction: dir
		normal: normal.
	self fillRectangle: rect.

	edgeTransform := tr.! !

!AthensBalloonEngine methodsFor: 'paints' stamp: ''!
registerLinearGradient: colorRamp origin: origin corner: corner

	| pixelRamp direction normal |
	pixelRamp := GradientFillStyle pixelRampCache at: colorRamp.
	direction := corner - origin.
	normal := direction y negated @ direction x.

	currentFill := self
		               primAddGradientFill: pixelRamp
		               from: origin
		               along: direction
		               normal: normal
		               radial: false! !

!AthensBalloonEngine methodsFor: 'drawing' stamp: ''!
fillBezierShape: contours

	contours do:[ :points |
		self primAddBezierShape: points
			segments: (points size // 3)
			fill: currentFill
			lineWidth: 0
			lineFill: 0.
			
		"Note: To avoid premature flushing of the pipeline we need to reset the flush bit within the engine."
		self primFlushNeeded: false.
	].

	self copyBits! !

!AthensBalloonEngine methodsFor: 'private' stamp: ''!
strokeBezierShape: contours width: aWidth

	contours do:[ :points |
		self primAddBezierShape: points
			segments: (points size // 3)
			fill: 0
			lineWidth: aWidth
			lineFill: currentFill.
			
		"Note: To avoid premature flushing of the pipeline we need to reset the flush bit within the engine."
		self primFlushNeeded: false.
	].

	self copyBits! !

!AthensBalloonEngine methodsFor: 'initialization' stamp: ''!
reset

	workBuffer ifNil:[workBuffer := self class allocateOrRecycleBuffer: 10000].

	self 
		primInitializeBuffer: workBuffer;
		primSetAALevel: 4;
		primSetOffset: 0@0;
		primSetClipRect: clipRect;
		primSetEdgeTransform: edgeTransform;
		primSetColorTransform: colorTransform.
		
	forms := #()! !

!AthensBalloonEngine methodsFor: 'drawing' stamp: ''!
strokeRectangle: rect width: aWidth

	currentFill = 0 ifTrue: [ ^ self ]. "no fill "
	self primAddRectFrom: rect origin 
			to: rect corner
			fillIndex: 0
			borderWidth: aWidth asInteger
			borderColor: currentFill.

	self copyBits! !

!AthensBalloonGradientPaint commentStamp: ''!
my subclasses used internally in balloon backend for Athens to represenet gradient paints.!
!AthensBalloonGradientPaint methodsFor: 'rendering' stamp: ''!
strokeRect: aRectangle on: anAthensCanvas stroke: anAthensBalloonStrokePaint

	self shouldBeImplemented! !

!AthensBalloonGradientPaint methodsFor: 'accessing' stamp: ''!
colorRamp: anObject

	colorRamp := anObject! !

!AthensBalloonGradientPaint methodsFor: 'rendering' stamp: ''!
strokeRect: aRectangle on: anAthensCanvas strokeWidth: strokeWidth

	self shouldBeImplemented! !

!AthensBalloonGradientPaint methodsFor: 'accessing' stamp: ''!
colorRamp

	^ colorRamp! !

!AthensBalloonImagePaint commentStamp: ''!
i representing an image (form) paint  !
!AthensBalloonImagePaint methodsFor: 'accessing' stamp: ''!
direction: anObject

	direction := anObject! !

!AthensBalloonImagePaint methodsFor: 'rendering' stamp: ''!
athensFillPath: aPath on: anAthensCanvas

	anAthensCanvas surface engine
		prepareForRendering;
		registerFormFill: form origin: origin direction: direction normal: self normal;
		fillBezierShape: aPath contoursForFilling! !

!AthensBalloonImagePaint methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	direction := 0 @ 0.
	origin := 0 @ 0.
	tileFlag := false! !

!AthensBalloonImagePaint methodsFor: 'accessing' stamp: ''!
origin

	^ origin! !

!AthensBalloonImagePaint methodsFor: 'accessing' stamp: ''!
direction

	^ direction! !

!AthensBalloonImagePaint methodsFor: 'accessing' stamp: ''!
form

	^ form! !

!AthensBalloonImagePaint methodsFor: 'accessing' stamp: ''!
normal

	^ (direction y negated @ direction x * form height / form width) rounded! !

!AthensBalloonImagePaint methodsFor: 'accessing' stamp: ''!
origin: anObject

	origin := anObject! !

!AthensBalloonImagePaint methodsFor: 'accessing' stamp: ''!
repeat

	tileFlag := true! !

!AthensBalloonImagePaint methodsFor: 'rendering' stamp: ''!
athensFillRectangle: aRect on: anAthensCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	|rotation normal|
	rotation := anAthensCanvas surface paintTransform transform: direction.
	normal := anAthensCanvas surface paintTransform transform:self normal.
	

	anAthensCanvas surface engine reset
		prepareForRendering;
		registerFormFill: form origin: origin direction: rotation normal: normal tileFlag: tileFlag;
		fillRectangle: aRect! !

!AthensBalloonImagePaint methodsFor: 'accessing' stamp: ''!
form: anObject

	form := anObject.
	origin := 0@0.
	direction := form extent x @0! !

!AthensBalloonLinearGradient commentStamp: ''!
i represent a linear gradient paint in balloon backend.!
!AthensBalloonLinearGradient methodsFor: 'accessing' stamp: ''!
corner

	^ corner! !

!AthensBalloonLinearGradient methodsFor: 'rendering' stamp: ''!
athensFillPath: aPath on: anAthensCanvas

	| torigin tcorner |

	"A gradient fill coordinates are first transformed by paintTransform matrix, then 
	 by pathTransform matrix"
		
	torigin := anAthensCanvas paintTransform transform: origin.
	tcorner :=  anAthensCanvas paintTransform transform: corner.

	^ anAthensCanvas surface engine
		prepareForRendering;
		registerLinearGradient: colorRamp origin: torigin corner: tcorner;
		fillBezierShape: aPath contoursForFilling! !

!AthensBalloonLinearGradient methodsFor: 'rendering' stamp: ''!
strokeRect: rect on: canvas stroke: strokePaint

	| torigin tcorner |

	"A gradient fill coordinates are first transformed by 
	paintTransform matrix,
	then
	by pathTransform matrix"
		
	torigin := canvas paintTransform transform: origin.
	tcorner :=  canvas paintTransform transform: corner.

	^ canvas surface engine
		prepareForRendering;
		registerLinearGradient: colorRamp origin: torigin corner: tcorner;
		strokeRectangle: rect width: strokePaint width! !

!AthensBalloonLinearGradient methodsFor: 'rendering' stamp: ''!
strokeRect: rect on: canvas strokeWidth: strokeWidth

	| torigin tcorner |

	"A gradient fill coordinates are first transformed by 
	paintTransform matrix,
	then
	by pathTransform matrix"
		
	torigin := canvas paintTransform transform: origin.
	tcorner :=  canvas paintTransform transform: corner.

	^ canvas surface engine
		prepareForRendering;
		registerLinearGradient: colorRamp origin: torigin corner: tcorner;
		strokeRectangle: rect width: strokeWidth! !

!AthensBalloonLinearGradient methodsFor: 'accessing' stamp: ''!
origin

	^ origin! !

!AthensBalloonLinearGradient methodsFor: 'accessing' stamp: ''!
origin: anObject

	origin := anObject! !

!AthensBalloonLinearGradient methodsFor: 'accessing' stamp: ''!
corner: anObject

	corner := anObject! !

!AthensBalloonLinearGradient methodsFor: 'rendering' stamp: ''!
athensFillRectangle: aRect on: anAthensCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	
	| torigin tcorner |

	"A gradient fill coordinates are first transformed by paintTransform matrix, then
	 by pathTransform matrix"
		
	torigin := anAthensCanvas paintTransform transform: origin.
	tcorner :=  anAthensCanvas paintTransform transform: corner.

	^ anAthensCanvas surface engine
		prepareForRendering;
		registerLinearGradient: colorRamp origin: torigin corner: tcorner;
		fillRectangle: aRect! !

!AthensBalloonPaint commentStamp: ''!
i am an abstract root of many balloon-specific paints!
!AthensBalloonPaint methodsFor: 'converting' stamp: ''!
asAthensPaintOn: surf

	^ self! !

!AthensBalloonPaint methodsFor: 'converting' stamp: ''!
asStrokePaintOn: aCanvas

	^ AthensBalloonStrokePaint new fillPaint: self! !

!AthensBalloonPath commentStamp: ''!
i represent a path shape in balloon backend!
!AthensBalloonPath methodsFor: 'converting' stamp: ''!
contoursForFilling
	"Answer a collection of contours, ready for filling by balloon engine"

	^ contours collect: [ :contour | 
		  contour last = contour first
			  ifTrue: [ contour asArray ]
			  ifFalse: [ 
				  contour , { 
					  contour last.
					  contour last.
					  contour first } ] ]! !

!AthensBalloonPath methodsFor: 'accessing' stamp: ''!
contours
	
	^ contours! !

!AthensBalloonPath methodsFor: 'converting' stamp: ''!
contoursForStroke
	"Answer a collection of contours, ready for stroking by balloon engine"

	^ contours collect: [ :contour | contour asArray ]! !

!AthensBalloonPath methodsFor: 'converting' stamp: ''!
visitCloseSegment: closeSegment
	"See if its already closed"

	contours last last = contours last first ifFalse: [ 
		contours last
			add: contours last last;
			add: closeSegment endPoint;
			add: closeSegment endPoint ]! !

!AthensBalloonPath methodsFor: 'converting' stamp: ''!
visitMoveSegment: seg

	contours ifNil: [ contours := OrderedCollection new ].

	contours add: OrderedCollection new.
	contours last add: seg endPoint! !

!AthensBalloonPath methodsFor: 'converting' stamp: ''!
convertFromBuilder: aBuilder

	| segment cContours |
	segment := aBuilder pathStart.

	[ segment notNil ] whileTrue: [ 
		segment visitWith: self.
		segment := segment next ].

	"Finally make all OrderedColllections ==> Array "
	cContours := Array new: contours size.
	1 to: cContours size do: [ :i | cContours at: i put: (contours at: i) asArray ].
	contours := cContours! !

!AthensBalloonPath methodsFor: 'converting' stamp: ''!
visitQuadSegment: quadSegment

	self duplicateLastPoint.

	contours last
		add: quadSegment via;
		add: quadSegment to! !

!AthensBalloonPath methodsFor: 'private' stamp: ''!
duplicateLastPoint

	contours last size < 2 ifFalse: [ 
		"Duplicate last contour point" 
		contours last add: contours last last ]! !

!AthensBalloonPath methodsFor: 'accessing' stamp: ''!
numContours

	^ contours size! !

!AthensBalloonPath methodsFor: 'converting' stamp: ''!
visitLineSegment: line

	self duplicateLastPoint.
	contours last
		add: line endPoint;
		add: line endPoint! !

!AthensBalloonPath methodsFor: 'drawing' stamp: ''!
paintFillsUsing: aPaint on: anAthensCanvas 	
	"This method is a part of rendering dispatch  Canvas->receiver->paint"
	
	^ aPaint athensFillPath: self on: anAthensCanvas! !

!AthensBalloonRadialGradient commentStamp: ''!
i represent a radial gradient paint in balloon backend.!
!AthensBalloonRadialGradient methodsFor: 'rendering' stamp: ''!
athensFillPath: aPath on: anAthensCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	
	| c |

	c := anAthensCanvas paintTransform transform: center.

	^ anAthensCanvas surface engine
		prepareForRendering;
		registerRadialGradient: colorRamp center: c radius: radius;
		fillBezierShape: aPath contoursForFilling! !

!AthensBalloonRadialGradient methodsFor: 'accessing' stamp: ''!
center

	^ center! !

!AthensBalloonRadialGradient methodsFor: 'accessing' stamp: ''!
center: anObject

	center := anObject! !

!AthensBalloonRadialGradient methodsFor: 'accessing' stamp: ''!
radius

	^ radius! !

!AthensBalloonRadialGradient methodsFor: 'rendering' stamp: ''!
athensFillRectangle: aRect on: anAthensCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	
	| c dir n |

	c := anAthensCanvas paintTransform transform: center.
	dir :=  (radius@0).
	n := (0@radius).
	
	^ anAthensCanvas surface engine
		prepareForRendering;
		registerRadialGradient: colorRamp center: c direction: dir normal: n;
		fillRectangle: aRect! !

!AthensBalloonRadialGradient methodsFor: 'accessing' stamp: ''!
radius: anObject

	radius := anObject! !

!AthensBalloonSolidColorPaint commentStamp: ''!
maybe Color could act as a AthensPaint by itself by implementing a corresponding protocol!
!AthensBalloonSolidColorPaint methodsFor: 'accessing' stamp: ''!
color: anObject

	color := anObject! !

!AthensBalloonSolidColorPaint methodsFor: 'rendering' stamp: ''!
athensFillPath: athensBalloonPath on: anAthensCanvas 

	^ anAthensCanvas surface 
		fillBezierShape: athensBalloonPath contoursForFilling  
		color: color! !

!AthensBalloonSolidColorPaint methodsFor: 'rendering' stamp: ''!
strokeRect: rect on: canvas stroke: strokePaint

	^ canvas surface strokeRectangle: rect color: color width: strokePaint width! !

!AthensBalloonSolidColorPaint methodsFor: 'rendering' stamp: ''!
strokeRect: rect on: canvas strokeWidth: strokeWidth

	^ canvas surface strokeRectangle: rect color: color width: strokeWidth! !

!AthensBalloonSolidColorPaint methodsFor: 'rendering' stamp: ''!
strokePath: aPath on: anAthensCanvas strokeWidth: strokeWidth
	
	 anAthensCanvas surface 
		strokeBezierShape: aPath contoursForStroke
		color: color
		width: strokeWidth! !

!AthensBalloonSolidColorPaint methodsFor: 'rendering' stamp: ''!
athensFillRectangle: aRect on: canvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	
	^ canvas surface fillRectangle: aRect color: color! !

!AthensBalloonSolidColorPaint methodsFor: 'rendering' stamp: ''!
strokePath: aPath on: anAthensCanvas stroke: strokePaint 
	
	 anAthensCanvas surface 
		strokeBezierShape: aPath contoursForStroke
		color: color
		width: strokePaint width! !

!AthensBalloonSolidColorPaint methodsFor: 'accessing' stamp: ''!
color

	^ color! !

!AthensBalloonStrokePaint commentStamp: ''!
i represent stroke paint for balloon backend!
!AthensBalloonStrokePaint methodsFor: 'setting - cap styles' stamp: ''!
capSquare
	self flag: #pharoTodo! !

!AthensBalloonStrokePaint methodsFor: 'rendering' stamp: ''!
athensFillPath: aPath on: aCanvas

	^ fillPaint strokePath: aPath on: aCanvas strokeWidth: width! !

!AthensBalloonStrokePaint methodsFor: 'setting - cap styles' stamp: ''!
capRound
	self flag: #pharoTodo! !

!AthensBalloonStrokePaint methodsFor: 'setting - join styles' stamp: ''!
joinBevel
	self flag: #pharoTodo! !

!AthensBalloonStrokePaint methodsFor: 'setting - join styles' stamp: ''!
joinMiter
	self flag: #pharoTodo! !

!AthensBalloonStrokePaint methodsFor: 'rendering' stamp: ''!
athensFillRectangle: aRect on: aCanvas

	^ fillPaint strokeRect: aRect on: aCanvas strokeWidth: width! !

!AthensBalloonStrokePaint methodsFor: 'setting - cap styles' stamp: ''!
capButt
	self flag: #pharoTodo! !

!AthensBalloonStrokePaint methodsFor: 'setting - join styles' stamp: ''!
joinRound
	self flag: #pharoTodo! !

!AthensBalloonSurface commentStamp: ''!
I am concrete implementation of Athens surface which using balloon engine for rendering. !
!AthensBalloonSurface methodsFor: 'accessing - matrices' stamp: ''!
strokeTransform

	^ strokeTransform! !

!AthensBalloonSurface methodsFor: 'accessing - matrices' stamp: ''!
pathTransform

	^ pathTransform! !

!AthensBalloonSurface methodsFor: 'accessing' stamp: ''!
engine

	^ engine! !

!AthensBalloonSurface methodsFor: 'clipping' stamp: ''!
clipBy: aRectangle during: aBlock

	| oldRect transformedClip|
	transformedClip := (pathTransform transform:aRectangle origin) corner: (pathTransform transform:aRectangle corner).
	oldRect := engine clipRect.
	engine clipRect: (oldRect intersect: transformedClip).

	aBlock ensure: [ engine clipRect: oldRect ]! !

!AthensBalloonSurface methodsFor: 'accessing' stamp: ''!
paintTransform

	^ paintTransform! !

!AthensBalloonSurface methodsFor: 'drawing' stamp: ''!
strokeRectangle: rect color: aColor width: aWidth
	 
	engine
		prepareForRendering;
		registerColorFill: aColor;
		strokeRectangle: rect width: aWidth! !

!AthensBalloonSurface methodsFor: 'accessing - matrices' stamp: ''!
fillTransform

	^ fillTransform! !

!AthensBalloonSurface methodsFor: 'accessing' stamp: ''!
form

	^ form! !

!AthensBalloonSurface methodsFor: 'masking' stamp: ''!
maskEnabled

	^ maskEnabled! !

!AthensBalloonSurface methodsFor: 'masking' stamp: ''!
enableMask

	maskEnabled := true! !

!AthensBalloonSurface methodsFor: 'drawing' stamp: ''!
strokeBezierShape: contours color: aColor width: aWidth 
	
	engine
		prepareForRendering;
		registerColorFill: aColor;
		strokeBezierShape: contours width: aWidth! !

!AthensBalloonSurface methodsFor: 'drawing' stamp: ''!
fillBezierShape: anArray color: aColor width: aSmallInteger

	self shouldBeImplemented! !

!AthensBalloonSurface methodsFor: 'accessing - matrices' stamp: ''!
fillTransform: anObject

	fillTransform := anObject! !

!AthensBalloonSurface methodsFor: 'drawing' stamp: ''!
drawImage: aForm 

	engine drawImage: aForm transform: imageTransform! !

!AthensBalloonSurface methodsFor: 'masking' stamp: ''!
disableMask

	maskEnabled := false! !

!AthensBalloonSurface methodsFor: 'paints' stamp: ''!
createStrokePaintFor: aPaint

	^ AthensBalloonStrokePaint new fillPaint: aPaint! !

!AthensBalloonSurface methodsFor: 'accessing - matrices' stamp: ''!
imageTransform

	^ imageTransform! !

!AthensBalloonSurface methodsFor: 'accessing - matrices' stamp: ''!
pathTransform: anObject

	pathTransform := anObject copy.
	engine edgeTransform: pathTransform! !

!AthensBalloonSurface methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	pathTransform := AthensAffineTransform new.
	paintTransform := AthensAffineTransform new.
	
	imageTransform := AthensAffineTransform new " AthensGenericTransform new".
	fillTransform := AthensAffineTransform new.
	strokeTransform := AthensAffineTransform new.
	maskEnabled := false! !

!AthensBalloonSurface methodsFor: 'accessing' stamp: ''!
clipRect

	^ engine clipRect! !

!AthensBalloonSurface methodsFor: 'paints' stamp: ''!
createLinearGradient: colorRamp start: pt1 stop: pt2
 
	^ AthensBalloonLinearGradient new
		colorRamp: colorRamp;
		origin: pt1;
		corner: pt2;
		yourself! !

!AthensBalloonSurface methodsFor: 'paints' stamp: ''!
createFormPaint: aForm

	^ AthensBalloonImagePaint new form: aForm! !

!AthensBalloonSurface methodsFor: 'paths' stamp: ''!
createPath: aPathCreatingBlock
	"Create a path from provided path builder instance"
	
	| builder |
	builder := AthensSimplePathBuilder new.
	aPathCreatingBlock value: builder.

	^ AthensBalloonPath new convertFromBuilder: builder! !

!AthensBalloonSurface methodsFor: 'converting' stamp: ''!
asAthensPaintOn: aCanvas

	^ AthensBalloonImagePaint new
		  form: self asForm;
		  yourself! !

!AthensBalloonSurface methodsFor: 'paints' stamp: ''!
createCircularGradient: colorRamp center: aCenter radius: aRadius

	^ AthensBalloonRadialGradient new
		colorRamp: colorRamp;
		center: aCenter;
		radius: aRadius;
		yourself! !

!AthensBalloonSurface methodsFor: 'paints' stamp: ''!
createRadialGradient: colorRamp center: aCenter radius: aRadius focalPoint: fp

	^ self createCircularGradient: colorRamp center: aCenter radius: aRadius! !

!AthensBalloonSurface methodsFor: 'rendering dispatch' stamp: ''!
fillPath: aPath withSolidColor: aColor

	self fillBezierShape: aPath contoursForFilling color: aColor! !

!AthensBalloonSurface methodsFor: 'drawing' stamp: ''!
fillRectangle: rect color: aColor

	engine
		prepareForRendering;
		registerColorFill: aColor;
		fillRectangle: rect! !

!AthensBalloonSurface methodsFor: 'rendering dispatch' stamp: ''!
fillRectangle: aRectangle withSolidColor: aColor

	self fillRectangle: aRectangle color: aColor! !

!AthensBalloonSurface methodsFor: '*Athens-Morphic' stamp: ''!
displayOnMorphicCanvas: canvas at: aPoint
	"Display receiver on morphic canvas"

	canvas
		image: self asForm
		at: aPoint
		sourceRect: (0 @ 0 extent: self asForm extent)
		rule: 34! !

!AthensBalloonSurface methodsFor: 'testing' stamp: ''!
clearForm

	form bits: ( Bitmap new: form bits size)! !

!AthensBalloonSurface methodsFor: 'accessing' stamp: ''!
form: aForm

	form := aForm.
	mask := Form extent: form extent depth: 1.

	engine := AthensBalloonEngine new.
	engine 
		bitBlt: (GrafPort toForm: form);
		clipRect: (0 @ 0 extent: form extent);
		edgeTransform: pathTransform;
		destOffset: 0 @ 0;
		reset! !

!AthensBalloonSurface methodsFor: 'public' stamp: ''!
clear

	^ self clearForm! !

!AthensBalloonSurface methodsFor: 'accessing - matrices' stamp: ''!
strokeTransform: anObject

	strokeTransform := anObject! !

!AthensBalloonSurface methodsFor: 'fonts' stamp: ''!
getFreetypeFontRendererFor: aFreeTypeFont

	^ FT2GlyphRenderer forFont: aFreeTypeFont surface: self! !

!AthensBalloonSurface methodsFor: 'drawing' stamp: ''!
fillBezierShape: contours color: aColor 

	engine
		prepareForRendering;
		registerColorFill: aColor;
		fillBezierShape: contours! !

!AthensBalloonSurface methodsFor: 'converting' stamp: ''!
asForm

	^ form! !

!AthensBalloonSurface methodsFor: 'paints' stamp: ''!
createSolidColorPaint: aColor

	^ AthensBalloonSolidColorPaint new color: aColor! !

!AthensBalloonSurface class methodsFor: 'instance creation' stamp: ''!
extent: aPoint
	"Create a new surface with given extent."
	
	^ self new form: (Form extent: aPoint depth: 32)! !

!AthensBalloonSurfaceExamples commentStamp: ''!
Athens example using Ballon as surface

 !
!AthensBalloonSurfaceExamples class methodsFor: 'utilities' stamp: ''!
newSurface: extent
	
	^ AthensBalloonSurface extent: extent! !

!AthensBezier3Scene commentStamp: ''!
I just a helper class used to debug & visualize rendering of bezier segment. This class is subject of changes or complete removal!
!AthensBezier3Scene methodsFor: 'initialization' stamp: ''!
initFromArray: aControlPointsArray
	
		pt1 := aControlPointsArray at: 1.
		pt2 := aControlPointsArray at: 2.
		pt3 := aControlPointsArray at: 3.
		pt4 := aControlPointsArray at: 4! !

!AthensBezier3Scene methodsFor: 'rendering' stamp: ''!
renderOn: canvas

	| path pathBlock |
	
	canvas surface clear:  Color black.
	pathBlock :=  [ :builder |
		builder 
			absolute;
			moveTo: pt1;
			curveVia: pt2 and: pt3 to: pt4
	 ].
	

	"First , we draw the curve using Cairo"	
	(canvas setStrokePaint: Color green).
	canvas drawShape: (canvas createPath: pathBlock).
		
	"draw a polygon, connecting control points"
	(canvas setStrokePaint: Color blue) width: 0.5.
	canvas drawShape: (canvas createPath: [ :builder |
		builder 
			absolute;
			moveTo: pt1;
			lineTo: pt2;
			lineTo: pt3;
			lineTo: pt4
		 ]).
	
		
	
	canvas setPaint: Color red.
	
	path := AthensSimplePathBuilder createPath: pathBlock.
"	polygonizedPath := path asPolygon: canvas pathTransform. "
	
	canvas drawShape: (
		canvas createPath: [ :builder | | flattener |
			builder absolute.
	
		flattener := AthensCurveFlattener new dest: builder.
		flattener transform: (canvas pathTransform). 
		flattener convert:path. 
	])! !

!AthensBezier3Scene methodsFor: 'accessing' stamp: ''!
curvePathBlock
	^ [ :builder |
		builder 
			absolute;
			moveTo: pt1;
			curveVia: pt2 and: pt3 to: pt4
	 ]! !

!AthensBezier3Scene class methodsFor: 'instance creation' stamp: ''!
on: anControlPointArray

	^ self basicNew
		initFromArray: anControlPointArray! !

!AthensBezier3Scene class methodsFor: '*Athens-Morphic' stamp: ''!
openViewOn: aControlPointsArray
	
	^ AthensSceneView new
		scene: 	(self on: aControlPointsArray );
		openInWindow! !

!AthensBezierConverter commentStamp: ''!
I converting all bezier segments to a sequence of line segments, by approximating the curve along its path.

This classs is used for generating strokes.!
!AthensBezierConverter methodsFor: 'helpers' stamp: ''!
recursiveBezier2_x1: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3

	"recursively subdive bezier curve as long as #isFlatBezier2.. answers false "

	(self isFlatBezier2_x1: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3) ifTrue: [
		
		dest 
			lineTo: x2 @ y2;
			lineTo: x3 @ y3
	] ifFalse: [
		| x12 y12 x23 y23 x123 y123 |	
	"calculate midpoints of line segments "
		x12 := (x1 + x2) * 0.5.
		y12 := (y1 + y2) * 0.5 .

		x23 := (x2 + x3) * 0.5 .
		y23 := (y2 + y3) * 0.5 .

		x123 := (x12 + x23) * 0.5.
		y123 := (y12 + y23) * 0.5.
		
		self recursiveBezier2_x1: x1 y1: y1 
			x2: x12 
			y2: y12 
			x3: x123 
			y3: y123.
			
		self recursiveBezier2_x1: x123 
			y1: y123
			x2: x23
			y2: y23 
			x3: x3 
			y3: y3.
	]! !

!AthensBezierConverter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	distanceTolerance := 0.5.
	angleTolerance := 0.1! !

!AthensBezierConverter methodsFor: 'converting path commands' stamp: ''!
curveVia: pt1 to: pt2

	self recursiveBezier2_x1: endPoint x y1: endPoint y
		x2: pt1 x y2: pt1 y
		x3: pt2 x y3: pt2 y! !

!AthensBezierConverter methodsFor: 'helpers' stamp: ''!
angleBetween: p1 and: p2 ifDegenerate: aBlock
	"Calculate an angle (in radians) between two vectors. 
	 Evaluate a block, in case if calculation not possible because one of the vectors has zero length"

	| x1 y1 x2 y2 dot2 n2 |
	x1 := p1 x.
	y1 := p1 y.
	x2 := p2 x.
	y2 := p2 y.
	
	dot2 := x1 * x2 + (y1 * y2).
	dot2 := dot2 * dot2.
	
	n2 := (x1*x1 + (y1*y1)) * (x2*x2 + (y2*y2)).
	
	n2 = 0 ifTrue: [ ^ aBlock value ].
	
	^ (dot2 / n2) arcCos! !

!AthensBezierConverter methodsFor: 'testing' stamp: ''!
isFlatBezier2_x1: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3

	| dx dy d da angle |
	
	dx := x3-x1.
	dy := y3-y1.
	
 	d := (((x2 - x3) * dy) - ((y2 - y3) * dx)) abs.

	d > CollinearityEps ifTrue: [
		
		"regular case"

		d*d <= (distanceTolerance * ( dx*dx + (dy*dy))) ifTrue: [
			
			angleTolerance < CurveAngleTolerance ifTrue: [ ^ true ].
			
			angle := self angleBetween: x2-x1 @ (y2-y1) and: x3-x2 @ (y3-y2)
				ifDegenerate: [ 0.0 ].
			
			"parallel. no need to proceed further"
			angle <= angleTolerance ifTrue: [ ^ true ]					
		]
	]
	ifFalse: [ 
		"collinear"
		da := dx*dx + (dy*dy).
		
		da = 0 
			ifTrue: [ d := (x1-x2) squared + (y1-y2) squared ]
			ifFalse: [
				d = ((x2 - x1)*dx + ((y2 - y1)*dy)) / da.

				(d > 0.0 and: [ d < 1.0 ] ) ifTrue: [ 
					"Simple collinear case, 1---2---3" 
					^ true
     				].
				d <= 0.0 
					ifTrue: [ d := (x1-x2) squared + (y1-y2) squared ]
					ifFalse: [
						d >= 1.0 
							ifTrue: [ d:= (x2-x3) squared + (y2-y3) squared ]
							ifFalse: [ d:= (x2 - x1 - (d*dx)) squared + (y2 - y1 - (d*dy)) squared ]
					].
			].

			d < self distanceToleranceSquared ifTrue: [ ^ true ]		
	].

	^ false! !

!AthensBezierConverter class methodsFor: 'class initialization' stamp: ''!
initialize

	CollinearityEps := 1e-30.
	DistanceEps := 1e-30.
	CurveAngleTolerance := 0.01.! !

!AthensBorderStrokePaint commentStamp: ''!
i am used to convert 
ComplexBorder (raised/inset) into paint, used in Morphic.!
!AthensBorderStrokePaint methodsFor: 'private' stamp: ''!
pathForBottomRightBorderOf: aRectangle on: anAthensCanvas
	^ anAthensCanvas
		createPath: [ :builder | 
			builder
				absolute;
				moveToX: aRectangle left Y: aRectangle bottom;
				lineToX: aRectangle right Y: aRectangle bottom;
				lineToX: aRectangle right Y: aRectangle top;
				lineToX: aRectangle right - width Y: aRectangle top + width;
				lineToX: aRectangle right - width Y: aRectangle bottom - width;
				lineToX: aRectangle left + width Y: aRectangle bottom - width;
				close ]! !

!AthensBorderStrokePaint methodsFor: 'accessing' stamp: ''!
width: aWidth
	width:= aWidth! !

!AthensBorderStrokePaint methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!AthensBorderStrokePaint methodsFor: 'accessing' stamp: ''!
bottomRightPaint: anAthensPaint
	bottomRightPaint := anAthensPaint! !

!AthensBorderStrokePaint methodsFor: 'accessing' stamp: ''!
topLeftPaint: anAthensPaint
	topLeftPaint := anAthensPaint! !

!AthensBorderStrokePaint methodsFor: 'private' stamp: ''!
pathForTopLeftBorderOf: aRectangle on: anAthensCanvas
	^ anAthensCanvas
		createPath: [ :builder | 
			builder
				absolute;
				moveToX: aRectangle left Y: aRectangle bottom;
				lineToX: aRectangle left Y: aRectangle top;
				lineToX: aRectangle right Y: aRectangle top;
				lineToX: aRectangle right - width Y: aRectangle top + width;
				lineToX: aRectangle left + width Y: aRectangle top + width;
				lineToX: aRectangle left + width Y: aRectangle bottom - width;
				close ]! !

!AthensBorderStrokePaint methodsFor: 'drawing' stamp: ''!
asStrokePaintOn: aCanvas
	"receiver is stroke paint already"
	^ self! !

!AthensBorderStrokePaint methodsFor: 'drawing' stamp: ''!
athensFillRectangle: aRect on: anAthensCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "

	topLeftPaint
		athensFillPath: (self pathForTopLeftBorderOf: (aRect expandBy: width/2.0) on: anAthensCanvas)
		on: anAthensCanvas.
	bottomRightPaint
		athensFillPath: (self pathForBottomRightBorderOf: (aRect expandBy: width/2.0) on: anAthensCanvas)
		on: anAthensCanvas! !

!AthensBorderStrokePaint class methodsFor: 'instance creation' stamp: ''!
topLeftColor: aColor1 bottomRightColor: aColor2 width: aNumber on: anAthensCanvas
	^ self new
		topLeftPaint: (aColor1 asAthensPaintOn: anAthensCanvas);
		bottomRightPaint: (aColor2 asAthensPaintOn: anAthensCanvas);
		width: aNumber;
		yourself! !

!AthensCCWArcSegment commentStamp: ''!
i represent a circular arc, connecting  
previous segment endpoint and my endpoing
of given angle, passing in counter-clockwise direction.!
!AthensCCWArcSegment methodsFor: 'visitor' stamp: ''!
sendCommandTo: aBuilder
	^ aBuilder ccwArcTo: endPoint angle: angle! !

!AthensCCWArcSegment methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor ccwArcSegment: self! !

!AthensCWArcSegment commentStamp: ''!
i represent a circular arc, connecting  
previous segment endpoint and my endpoing
of given angle, passing in clockwise direction.!
!AthensCWArcSegment methodsFor: 'visitor' stamp: ''!
sendCommandTo: aBuilder
	^ aBuilder cwArcTo: endPoint angle: angle! !

!AthensCWArcSegment methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor cwArcSegment: self! !

!AthensCairoCanvas commentStamp: ''!
my instances representing a low-level cairo context and mapped to cairo_t * C type!
!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primClip
	^ self ffiCall: #(void cairo_clip (self))! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
resetClip
	^ self ffiCall: #(void cairo_reset_clip (self))! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primSetLineJoin: joinStyle
	^ self ffiCall: #(void cairo_set_line_join ( self, cairo_line_join_t joinStyle) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primGetCurrentPointX: x Y: y
	^ self ffiCall: #( void cairo_get_current_point (self, double * x, double * y))! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
getCurrentPoint

	| x y |
	"since we use pointers to floats we must create a copy of original values to not scratch them"
	x := ByteArray new: 8.
	y := ByteArray new: 8.
	self primGetCurrentPointX: x Y: y.
	^ (x doubleAt: 1)@ (y doubleAt: 1)! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primSetFontSize: aSize
	"
	void                cairo_set_font_size                 (cairo_t *cr,
                                                         double size);
	"
	^ self ffiCall: #( void cairo_set_font_size (self , double aSize ))! !

!AthensCairoCanvas methodsFor: 'path segments visitor' stamp: ''!
visitQuadSegment: anAthensCubicSegment
	| destination controlPoint |
	destination := anAthensCubicSegment to.
	controlPoint := anAthensCubicSegment via.
	self
		curveToX: destination x Y: destination y
		viaX: controlPoint x Y: controlPoint y! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
showGlyphs: glyphs size: numGlyphs
	"A drawing operator that generates the shape from a string of UTF-8 characters, rendered according to the current font_face, font_size (font_matrix), and font_options. "
	^ self ffiCall: #(
	
		void cairo_show_glyphs ( self ,
			void * glyphs,
			int numGlyphs) )! !

!AthensCairoCanvas methodsFor: 'initialization' stamp: ''!
setFillRule: aCairoFillRule
	^ self ffiCall: #( void cairo_set_fill_rule ( self, cairo_fill_rule_t aCairoFillRule ) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
showPage
	self ffiCall: #( void cairo_show_page (self) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
setClipRect: aRectOrNil
	aRectOrNil 
		ifNil: [ self resetClip ]
		ifNotNil: [ self pushClipRect: aRectOrNil ]! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primRestoreState
	^ self ffiCall: #(void cairo_restore (self))! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
setAA: antiAlias

	"cairo_set_antialias ()

void                cairo_set_antialias                 (cairo_t *cr,
                                                         cairo_antialias_t antialias);

Set the antialiasing mode of the rasterizer used for drawing shapes. This value is a hint, and a particular backend may or may not support a particular value. At the current time, no backend supports CAIRO_ANTIALIAS_SUBPIXEL when drawing shapes.

Note that this option does not affect text rendering, instead see cairo_font_options_set_antialias().

"
	^ self ffiCall: #(void cairo_set_antialias (self, uint antiAlias))! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
loadPath: aPath
	^ self ffiCall: #( void cairo_append_path (self , AthensCairoPath aPath))! !

!AthensCairoCanvas methodsFor: 'accessing' stamp: ''!
fillRule
	^ self ffiCall: #( cairo_fill_rule_t cairo_get_fill_rule ( self ) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
pushClipRect: aRectangle
	self newPath;
		rectangleX: aRectangle left
		y: aRectangle top
		width: aRectangle width
		height: aRectangle height;
		primClip! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primSetSourceR: red g: green b: blue a: alpha
	^ self ffiCall: #( 
		void cairo_set_source_rgba ( self ,
			double red,
			double green,
			double blue,
			double alpha) )! !

!AthensCairoCanvas methodsFor: 'accessing' stamp: ''!
fillRuleWinding
	self setFillRule: CAIRO_FILL_RULE_WINDING! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
getScaledFont
	"Returns the current scaled font. This object is owned by cairo. To keep a reference to it, you must call cairo_scaled_font_reference().
 "
	^ self ffiCall: #( CairoScaledFont cairo_get_scaled_font ( self ))! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
showText: anUTF8String
	"A drawing operator that generates the shape from a string of UTF-8 characters, rendered according to the current font_face, font_size (font_matrix), and font_options. "
	^ self ffiCall: #(void cairo_show_text (self, char * anUTF8String ))! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primDrawWithAlpha: alpha
	^ self ffiCall: #( 
		void cairo_paint_with_alpha ( self , double alpha)
	)! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
setPathMatrix
	^ self ffiCall: #(void cairo_set_matrix (self,
			AthensCairoMatrix * pathTransform) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
fill
	^ self ffiCall: #(void cairo_fill (self))! !

!AthensCairoCanvas methodsFor: 'drawing' stamp: ''!
drawWithAlpha: alpha
	^ self primDrawWithAlpha: alpha asFloat! !

!AthensCairoCanvas methodsFor: '*Athens-Morphic' stamp: ''!
transformBy: aDisplayTransform withClip: aClipRectangle in: aSubRectangle during: aDrawBlock
	self
		clipBy: currentClipRect
		during: [ 
			| subClip oldClip |
			subClip := aDisplayTransform globalBoundsToLocal: aClipRectangle.
			oldClip := currentClipRect.
			currentClipRect := aDisplayTransform globalBoundsToLocal: self clipRect.
			pathTransform
				restoreAfter: [ 
					pathTransform translateBy: aDisplayTransform offset negated.
					pathTransform rotateByRadians: aDisplayTransform angle negated.
					pathTransform scaleBy: aDisplayTransform scale.
					self clipBy: subClip during: [ aDrawBlock value: self ] ].
			currentClipRect := oldClip ]! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
copyPage
	self ffiCall: #( void cairo_copy_page (self) )! !

!AthensCairoCanvas methodsFor: 'path segments visitor' stamp: ''!
visitCubicSegment: anAthensCubicSegment
	|  destination controlPoint controlPoint2 |
	destination := anAthensCubicSegment to.
	controlPoint := anAthensCubicSegment via1.
	controlPoint2 := anAthensCubicSegment via2.
	self
		curveToX: destination x Y: destination y
		viaX: controlPoint x Y: controlPoint y
		andX: controlPoint2 x Y: controlPoint2 y! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primSetLineWidth: width
	^ self ffiCall: #(void cairo_set_line_width (self, double width) )! !

!AthensCairoCanvas methodsFor: 'accessing' stamp: ''!
pathTransform
	^ pathTransform! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
stroke
	^ self ffiCall: #(void cairo_stroke (self))! !

!AthensCairoCanvas methodsFor: 'path segments visitor' stamp: ''!
visitCloseSegment: closeSegment
	self closePath! !

!AthensCairoCanvas methodsFor: 'clipping' stamp: ''!
clipBy: aRectangle during: aBlock
	| oldClip transformedClipRectangle newClip |

	oldClip := currentClipRect.
	transformedClipRectangle := pathTransform transformRectangle: aRectangle.
	newClip := oldClip
		ifNil: [ transformedClipRectangle ]
		ifNotNil: [ oldClip intersect: transformedClipRectangle ifNone:[^ self] ]. 
	
	self
		setPathMatrix;
		primSaveState;
		pushClipRect: aRectangle.
	
	currentClipRect := newClip.

	[aBlock value] ensure: [
		self primRestoreState.
		currentClipRect := oldClip
	].! !

!AthensCairoCanvas methodsFor: 'accessing' stamp: ''!
paintTransform
	^ paintTransform! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
setSourceR: red g: green b: blue a: alpha

	^ self
		  primSetSourceR: red asFloat
		  g: green asFloat
		  b: blue asFloat
		  a: alpha asFloat! !

!AthensCairoCanvas methodsFor: 'path segments visitor' stamp: ''!
visitMoveSegment: mov 
	^ self moveToX: mov endPoint x Y: mov endPoint y! !

!AthensCairoCanvas methodsFor: 'accessing' stamp: ''!
handle
	^ handle value! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
setScaledFont: aFont
	"Replaces the current font face, font matrix, and font options in the cairo_t with those of the cairo_scaled_font_t. Except for some translation, the current CTM of the cairo_t should be the same as that of the cairo_scaled_font_t, which can be accessed using cairo_scaled_font_get_ctm().
 "
	^ self ffiCall: #( void cairo_set_scaled_font (self , CairoScaledFont aFont))! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primMoveToX: x Y: y
	" move command always starts a new contour "
	^ self ffiCall: #(void cairo_move_to (self, double x, double y ) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primResetDashes: anOffset
"	void                cairo_set_dash                      (cairo_t *cr,
                                                         double *dashes,
                                                         int num_dashes,
                                                         double offset);"
	^ self ffiCall: #(void cairo_set_dash (
				self,
				0,
				0,
				double anOffset) )! !

!AthensCairoCanvas methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoCanvas methodsFor: 'drawing' stamp: ''!
fillPreserve
	^ self ffiCall: #(#void #cairo_fill_preserve #(#self))! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
destroy
	^ self ffiCall: #( 	void cairo_destroy (self) )! !

!AthensCairoCanvas methodsFor: 'accessing' stamp: ''!
surface: aCairoSurface
	
	"initialize for given surface"
	surface := aCairoSurface.
	
	pathTransform := AthensCairoMatrix new.
	paintTransform := AthensCairoMatrix new.
	paintMode := AthensCairoPaintMode new canvas: self.
	
	self setAA: CAIRO_ANTIALIAS_GOOD.! !

!AthensCairoCanvas methodsFor: 'initialize-release' stamp: ''!
initializeWithSurface: anAthensSurface	
	super initializeWithSurface: anAthensSurface.
	self paintMode default.! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primRectangleX: x y: y width: aWidth height: aHeight
	^ self ffiCall: #(void cairo_rectangle (self,
		 double x, double y,
		 double aWidth, double aHeight) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
rectangleX: x y: y width: aWidth height: aHeight

	^ self
		  primRectangleX: x asFloat
		  y: y asFloat
		  width: aWidth asFloat
		  height: aHeight asFloat! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
text: utf8String extents: extentsObj 
"cairo_text_extents ()

void                cairo_text_extents                  (cairo_t *cr,
                                                         const char *utf8,
                                                         cairo_text_extents_t *extents);
"
	^ self ffiCall: #( void cairo_text_extents (self, char *utf8String, cairo_text_extents_t *extentsObj) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
resetDash
	self primResetDashes: 0.0! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primSetLineCap: capStyle
	^ self ffiCall: #(void cairo_set_line_cap ( self, cairo_line_cap_t capStyle ) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primGetSource
	^ self ffiCall: #( cairo_pattern_t cairo_get_source ( self ) )! !

!AthensCairoCanvas methodsFor: 'accessing' stamp: ''!
clipRect
   ^ currentClipRect
        ifNil: [ pathTransform
                ifNotNil: [ (pathTransform inverted transform: 0 @ 0) extent: self surface extent ]
                ifNil: (0 @ 0 extent: self surface extent) ]! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primSetDashesLengths: dashesLengths count: dashesCount offset: anOffset
	^ self ffiCall: #(void cairo_set_dash (self,
			double * dashesLengths,
			int dashesCount,
			double anOffset ) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primSetSource: aPattern
	^ self ffiCall: #(void cairo_set_source ( self, AthensCairoPatternPaint aPattern))! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
setPathMatrix: aMatrix
	^ self ffiCall: #(void cairo_set_matrix (self,
			AthensCairoMatrix * aMatrix) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
setFontSize: aSize
	
	^ self primSetFontSize: aSize asFloat! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
newPath
	^ self ffiCall: #( void cairo_new_path ( self ) )! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
setFontMatrix: aMatrix
	"
void                cairo_set_font_matrix               (cairo_t *cr,
                                                         const cairo_matrix_t *matrix);
	"
	^ self ffiCall: #( void cairo_set_font_matrix (self , AthensCairoMatrix  * aMatrix ))! !

!AthensCairoCanvas methodsFor: 'drawing' stamp: ''!
textPath: anUTF8EncodedString
	"A drawing operator that generates the shape from a string of UTF-8 characters, rendered according to the current font_face, font_size (font_matrix), and font_options. "
	
	^ self ffiCall: #(void cairo_text_path (self, void* anUTF8EncodedString ))! !

!AthensCairoCanvas methodsFor: 'drawing' stamp: ''!
fillRuleEvenOdd
	self setFillRule: CAIRO_FILL_RULE_EVEN_ODD! !

!AthensCairoCanvas methodsFor: 'path segments visitor' stamp: ''!
visitLineSegment: line

	^ self lineToX: line endPoint x Y: line endPoint y! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primSaveState
	^ self ffiCall: #(void cairo_save (self))! !

!AthensCairoCanvas methodsFor: 'drawing' stamp: ''!
draw
	"Fill the shape (anObject) using currently selected paint
	an object should implement double-dispatch to currently selected paint"
	
	"set the trasformation matrix"
	self setPathMatrix.
	
	^ shape paintFillsUsing: paint on: self! !

!AthensCairoCanvas methodsFor: 'private' stamp: ''!
primPaint
	"A drawing operator that paints the current source everywhere within the current clip region."
	^ self ffiCall: #(void cairo_paint (self))! !

!AthensCairoCanvas methodsFor: 'drawing' stamp: ''!
moveToX: x Y: y
	" move command always starts a new contour "
	^ self primMoveToX: x asFloat Y: y asFloat! !

!AthensCairoCanvas class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoCanvas class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoCanvas class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoCanvas class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoCanvas class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoCanvas class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoCanvas class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoCanvas class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoCanvas class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoCanvas class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoCanvas class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoCanvas class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoCanvas class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoCanvas class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoCanvas class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoCanvas class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoCanvas class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoCanvas class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoCanvas class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoCanvas class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoCanvas class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoCanvas class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoCanvas class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoCanvas class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoCanvas class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoCanvas class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoCanvas class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator
	"use handle ivar to hold my instance (cairo_t)"
	^ FFIExternalObjectType objectClass: self! !

!AthensCairoCanvas class methodsFor: 'private' stamp: ''!
on: cairoSurface

	^ (self primCreate: cairoSurface) surface: cairoSurface! !

!AthensCairoCanvas class methodsFor: 'primitives' stamp: ''!
primCreate: cairoSurface
	^ self ffiCall: #( 
		AthensCairoCanvas cairo_create (AthensCairoSurface cairoSurface) )! !

!AthensCairoCanvas class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoCanvas class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoCanvas class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoCanvas class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCairoCanvasTest methodsFor: 'tests' stamp: ''!
testTextExtentsAnswerValidData
	"This works almost as a smoke test since the objective is validate image does not 
	 crash, but it will try to valid it also answers something reasonable"
	| surface cairoExtents |

	surface := AthensCairoSurface extent: 100@100.
	surface drawDuring: [ :aCanvas | 
		cairoExtents := CairoFontExtents new.
		self assert: cairoExtents width equals: 0.
		aCanvas text: 'Test' extents: cairoExtents.
		self deny: cairoExtents width equals: 0	]! !

!AthensCairoDefinitions commentStamp: ''!
I hold a lot of different constants needed to work with cairo library!
!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_line_cap_t 
	"typedef enum _cairo_line_cap { "
    CAIRO_LINE_CAP_BUTT := 0.
    CAIRO_LINE_CAP_ROUND := 1.
    CAIRO_LINE_CAP_SQUARE := 2.! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_status_t
"	typedef enum _cairo_status {"
    CAIRO_STATUS_SUCCESS := 0.

    CAIRO_STATUS_NO_MEMORY:=1.
    CAIRO_STATUS_INVALID_RESTORE:=2.
    CAIRO_STATUS_INVALID_POP_GROUP:=3.
    CAIRO_STATUS_NO_CURRENT_POINT:=4.
    CAIRO_STATUS_INVALID_MATRIX:=5.
    CAIRO_STATUS_INVALID_STATUS:=6.
    CAIRO_STATUS_NULL_POINTER:=7.
    CAIRO_STATUS_INVALID_STRING:=8.
    CAIRO_STATUS_INVALID_PATH_DATA:=9.
    CAIRO_STATUS_READ_ERROR:= 10.
    CAIRO_STATUS_WRITE_ERROR:=11.
    CAIRO_STATUS_SURFACE_FINISHED:=12.
    CAIRO_STATUS_SURFACE_TYPE_MISMATCH:=13.
    CAIRO_STATUS_PATTERN_TYPE_MISMATCH:=14.
    CAIRO_STATUS_INVALID_CONTENT:=15.
    CAIRO_STATUS_INVALID_FORMAT:=16.
    CAIRO_STATUS_INVALID_VISUAL:=17.
    CAIRO_STATUS_FILE_NOT_FOUND:=18.
    CAIRO_STATUS_INVALID_DASH:=19.
    CAIRO_STATUS_INVALID_DSC_COMMENT:=20.
    CAIRO_STATUS_INVALID_INDEX:=21.
    CAIRO_STATUS_CLIP_NOT_REPRESENTABLE:=22.
    CAIRO_STATUS_TEMP_FILE_ERROR:=23.
    CAIRO_STATUS_INVALID_STRIDE:=24.
    CAIRO_STATUS_FONT_TYPE_MISMATCH:=25.
    CAIRO_STATUS_USER_FONT_IMMUTABLE:=26.
    CAIRO_STATUS_USER_FONT_ERROR:=27.
    CAIRO_STATUS_NEGATIVE_COUNT:=28.
    CAIRO_STATUS_INVALID_CLUSTERS:=29.
    CAIRO_STATUS_INVALID_SLANT:=30.
    CAIRO_STATUS_INVALID_WEIGHT:=31.
    CAIRO_STATUS_INVALID_SIZE:=32.
    CAIRO_STATUS_USER_FONT_NOT_IMPLEMENTED:=33.
    CAIRO_STATUS_DEVICE_TYPE_MISMATCH:=34.
    CAIRO_STATUS_DEVICE_ERROR:=35.! !

!AthensCairoDefinitions class methodsFor: 'class initialization' stamp: ''!
initialize

	"
	self initialize
	"

	self
		initialize_types; 
		initialize_cairo_format_t;
		initialize_cairo_font_slant_t;
		initialize_cairo_font_weight_t;
		initialize_cairo_font_type_t ;
		initialize_cairo_operator_t ;
		initialize_cairo_line_cap_t ;
		initialize_cairo_line_join_t;
		initialize_cairo_status_t;
		initialize_cairo_extend_t;
		initialize_cairo_hint_style_t;
		initialize_cairo_antialias_t;
		init_cairo_subpixel_order_t;
		initialize_cairo_hint_metrics_t;
		initialize_cairo_fill_rule_t.! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_antialias_t

"typedef enum {"
    CAIRO_ANTIALIAS_DEFAULT := 0.

    " method "
    CAIRO_ANTIALIAS_NONE := 1.
    CAIRO_ANTIALIAS_GRAY := 2.
    CAIRO_ANTIALIAS_SUBPIXEL := 3.

    " hints "
    CAIRO_ANTIALIAS_FAST := 4.
    CAIRO_ANTIALIAS_GOOD := 5.
    CAIRO_ANTIALIAS_BEST := 6.
"} cairo_antialias_t; "! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_line_join_t
"	typedef enum _cairo_line_join {"
    CAIRO_LINE_JOIN_MITER := 0.
    CAIRO_LINE_JOIN_ROUND := 1.
    CAIRO_LINE_JOIN_BEVEL := 2.! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_font_slant_t

	"typedef enum _cairo_font_slant {"
    CAIRO_FONT_SLANT_NORMAL := 0.
    CAIRO_FONT_SLANT_ITALIC := 1.
    CAIRO_FONT_SLANT_OBLIQUE := 2! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_font_type_t 
	"typedef enum _cairo_font_type {"
    CAIRO_FONT_TYPE_TOY := 0.
    CAIRO_FONT_TYPE_FT := 1.
    CAIRO_FONT_TYPE_WIN32 := 2.
    CAIRO_FONT_TYPE_QUARTZ := 3.
    CAIRO_FONT_TYPE_USER := 4.! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
init_cairo_subpixel_order_t

"typedef enum {"
    CAIRO_SUBPIXEL_ORDER_DEFAULT := 0.
    CAIRO_SUBPIXEL_ORDER_RGB := 1.
    CAIRO_SUBPIXEL_ORDER_BGR := 2.
    CAIRO_SUBPIXEL_ORDER_VRGB := 3.
    CAIRO_SUBPIXEL_ORDER_VBGR := 4.
"} cairo_subpixel_order_t;"! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_fill_rule_t
"	typedef enum _cairo_status {"
   CAIRO_FILL_RULE_WINDING := 0.
	CAIRO_FILL_RULE_EVEN_ODD := 1.! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_font_weight_t

	"typedef enum _cairo_font_weight {"
    CAIRO_FONT_WEIGHT_NORMAL := 0.
    CAIRO_FONT_WEIGHT_BOLD := 1.! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_extend_t
"typedef enum {"
    CAIRO_EXTEND_NONE := 0 .
    CAIRO_EXTEND_REPEAT := 1.
    CAIRO_EXTEND_REFLECT :=2.
    CAIRO_EXTEND_PAD := 3.
"} cairo_extend_t"! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_hint_metrics_t
"typedef enum {"
    CAIRO_HINT_METRICS_DEFAULT := 0.
    CAIRO_HINT_METRICS_OFF := 1.
    CAIRO_HINT_METRICS_ON := 2.! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_hint_style_t

"typedef enum { "
    CAIRO_HINT_STYLE_DEFAULT := 0.
    CAIRO_HINT_STYLE_NONE := 1.
    CAIRO_HINT_STYLE_SLIGHT := 2.
    CAIRO_HINT_STYLE_MEDIUM := 3.
    CAIRO_HINT_STYLE_FULL := 4.
"} cairo_hint_style_t; "! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_operator_t 
"	typedef enum _cairo_operator {"
    CAIRO_OPERATOR_CLEAR := 0.

    CAIRO_OPERATOR_SOURCE:= 1.
    CAIRO_OPERATOR_OVER:= 2.
    CAIRO_OPERATOR_IN:= 3.
    CAIRO_OPERATOR_OUT:= 4.
    CAIRO_OPERATOR_ATOP:= 5.

    CAIRO_OPERATOR_DEST:= 6.
    CAIRO_OPERATOR_DEST_OVER:= 7.
    CAIRO_OPERATOR_DEST_IN:= 8.
    CAIRO_OPERATOR_DEST_OUT:= 9.
    CAIRO_OPERATOR_DEST_ATOP:= 10.

    CAIRO_OPERATOR_XOR:= 11.
    CAIRO_OPERATOR_ADD:= 12.
    CAIRO_OPERATOR_SATURATE:= 13.

    CAIRO_OPERATOR_MULTIPLY:= 14.
    CAIRO_OPERATOR_SCREEN:= 15.
    CAIRO_OPERATOR_OVERLAY:= 16.
    CAIRO_OPERATOR_DARKEN := 17.
    CAIRO_OPERATOR_LIGHTEN := 18.
    CAIRO_OPERATOR_COLOR_DODGE := 19.
    CAIRO_OPERATOR_COLOR_BURN := 20.
    CAIRO_OPERATOR_HARD_LIGHT := 21.
    CAIRO_OPERATOR_SOFT_LIGHT := 22.
    CAIRO_OPERATOR_DIFFERENCE := 23.
    CAIRO_OPERATOR_EXCLUSION := 24.
    CAIRO_OPERATOR_HSL_HUE := 25.
    CAIRO_OPERATOR_HSL_SATURATION := 26.
    CAIRO_OPERATOR_HSL_COLOR := 27.
    CAIRO_OPERATOR_HSL_LUMINOSITY := 28.
"} cairo_operator_t;"! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_cairo_format_t

	"enum cairo_format_t"
	CAIRO_FORMAT_INVALID :=  -1.
	CAIRO_FORMAT_ARGB32 :=  0.
	CAIRO_FORMAT_RGB24 := 1.
	CAIRO_FORMAT_A8 := 2.
	CAIRO_FORMAT_A1 := 3.
	CAIRO_FORMAT_RGB16_565 := 4! !

!AthensCairoDefinitions class methodsFor: 'private - initialization' stamp: ''!
initialize_types
	
	cairo_status_t := cairo_font_type_t :=  cairo_line_join_t  := cairo_line_cap_t := cairo_status_t := cairo_font_slant_t := cairo_font_weight_t := cairo_operator_t  := cairo_fill_rule_t := #int.
	
	cairo_pattern_t := #AthensCairoPatternPaint.
	
	cairo_t := #AthensCairoCanvas.
	
	cairo_surface_t := #AthensCairoSurface .
	cairo_text_extents_t := #CairoTextExtents.! !

!AthensCairoExportSurface commentStamp: ''!
I represent the common behavior of special Athens surfaces that render to a file using the cairo graphics library.

The main difference between my subclasses is given by the function that creates the external surface via FFI. See implementors of #createExportingTo:width:height:.

Use me like a AthensCairoSurface with these differences:
1. On instance creation, the caller specifies (a) output filename as String and (b) the extent in points (1 point == 1/72.0 inch).
2. When drawing is done, the caller should send #close to write the file trailer into the library buffer and then flush to disk.

Note 1: Before #close, the file may already exist in disk with 0 bytes.
Note 2: If the garbage collector finalizes the instance before #close, the exported file may have an invalid format.

References:
* http://zetcode.com/gfx/cairo/cairobackends/
* http://www.ie.u-ryukyu.ac.jp/~e085739/c.cairo.3.html
* https://cairographics.org/manual/cairo-PDF-Surfaces.html
* https://cairographics.org/manual/cairo-SVG-Surfaces.html
!
!AthensCairoExportSurface methodsFor: 'accessing' stamp: ''!
width
	^ extent x! !

!AthensCairoExportSurface methodsFor: 'finalization' stamp: ''!
finalizeResourceData
	"Finalize my external state. Read comment on #finalizeResourceData: on class-side."

	self class finalizeResourceData: self resourceData! !

!AthensCairoExportSurface methodsFor: 'accessing' stamp: ''!
extent
	^ extent! !

!AthensCairoExportSurface methodsFor: 'accessing' stamp: ''!
height
	^ extent y! !

!AthensCairoExportSurface methodsFor: 'initialization' stamp: ''!
initializeWith: anExtent
	self initialize.
	
	"We keep the extent to override related accessors because superclass uses cairo_image_surface_get_width and similar for height which don't give the right answer."
	extent := anExtent! !

!AthensCairoExportSurface methodsFor: 'initialization' stamp: ''!
resourceData
	"See #finalizeResourceData: at class-side."

	^ { handle. context handle }! !

!AthensCairoExportSurface methodsFor: 'finalization' stamp: ''!
close
	"Finish and flush to file the external surface. It is a required step when drawing is done and file should be written to disk."

	self
		finish; "Make the cairo library to write the file trailer into its buffer"
		finalizeResourceData "Destroy surface (and canvas) and flush buffer to disk"! !

!AthensCairoExportSurface class methodsFor: 'finalize resources' stamp: ''!
finalizeResourceData: data
	"Finalize external state. I override super behavior for two reasons:
	* Export surfaces do not register to the SurfacePlugin, so there is less state to finalize.
	* Support too be executed more than once. This was required because user finalizes the external object when drawing is done and also the Garbage Collector finalizes."

	| surfaceHandle contextHandleValue |
	surfaceHandle := data first.
	contextHandleValue := data second.

	surfaceHandle isNull ifTrue: [ ^self ].
	self destroySurfaceHandle: surfaceHandle value.
	self destroyContextHandle: contextHandleValue.
	surfaceHandle beNull.! !

!AthensCairoExportSurface class methodsFor: 'instance creation' stamp: ''!
extent: anExtent fileName: fileName
	^ (self createExportingTo: fileName width: anExtent x asFloat height: anExtent y asFloat)
		initializeWith: anExtent;
		yourself! !

!AthensCairoExportSurface class methodsFor: 'private' stamp: ''!
registerSurface: surface
	"Do not register my instances with SurfacePlugin since I only write to file."! !

!AthensCairoExportSurface class methodsFor: 'private' stamp: ''!
createExportingTo: fileName width: width height: height
	^ self subclassResponsibility! !

!AthensCairoExportSurfaceTest methodsFor: 'tests' stamp: ''!
testHeight
	surface := self athensSurfaceClass
		extent: 100@50
		fileName: self fileName.
	self assert: surface height equals: 50! !

!AthensCairoExportSurfaceTest methodsFor: 'running' stamp: ''!
tearDown
	surface close.
	self fileReference ensureDelete.
	super tearDown.! !

!AthensCairoExportSurfaceTest methodsFor: 'tests' stamp: ''!
testWidth
	surface := self athensSurfaceClass
		extent: 100@50
		fileName: self fileName.
	self assert: surface width equals: 100! !

!AthensCairoExportSurfaceTest methodsFor: 'running' stamp: ''!
fileName
	^ self className asString! !

!AthensCairoExportSurfaceTest methodsFor: 'tests' stamp: ''!
testExportBoxes
	| path |
	surface := self athensSurfaceClass
		extent: 100@100
		fileName: self fileName.
	path := surface createRectanglePath: (0@0 corner: 20@20).

	surface drawDuring: [:canvas |
		surface clear.
		canvas pathTransform loadIdentity.

		canvas setPaint: Color red.
		canvas pathTransform translateX: 5 Y: 5.
		canvas drawShape: path.

		canvas setPaint: Color blue.
		canvas pathTransform translateX: 5 Y: 5.
		canvas drawShape: path ].

	"Make cairo write and close the file."
	surface close.

	self assert: self fileReference exists.
	self assert: self fileReference size > 400.! !

!AthensCairoExportSurfaceTest methodsFor: 'running' stamp: ''!
fileReference
	^ self fileName asFileReference! !

!AthensCairoExportSurfaceTest methodsFor: 'tests' stamp: ''!
testExtent
	surface := self athensSurfaceClass
		extent: 100@50
		fileName: self fileName.
	self assert: surface extent equals: 100@50! !

!AthensCairoExportSurfaceTest methodsFor: 'tests' stamp: ''!
athensSurfaceClass
	^ self subclassResponsibility! !

!AthensCairoExportSurfaceTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self fileReference ensureDelete! !

!AthensCairoExportSurfaceTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = AthensCairoExportSurfaceTest! !

!AthensCairoGradientPaint commentStamp: ''!
i used to represent gradient paints (both radial and linear)  in cairo backend!
!AthensCairoGradientPaint methodsFor: 'primitives' stamp: ''!
primAddColorStopOffset: offset R: red G: green B: blue A: alpha 
	^ self ffiCall:#( void cairo_pattern_add_color_stop_rgba ( cairo_pattern_t  self,
					double offset,
					double red,
					double green,
					double blue,
					double alpha ))! !

!AthensCairoGradientPaint methodsFor: 'initialization' stamp: ''!
defaultExtend
"The default extend mode is CAIRO_EXTEND_NONE for surface patterns and CAIRO_EXTEND_PAD for gradient patterns.
"
	^  CAIRO_EXTEND_PAD! !

!AthensCairoGradientPaint methodsFor: 'private' stamp: ''!
addColorStopAt: anOffset colored: aColor

	self
		primAddColorStopOffset: anOffset asFloat
		R: aColor red asFloat
		G: aColor green asFloat
		B: aColor blue asFloat
		A: aColor alpha asFloat! !

!AthensCairoGradientPaint methodsFor: 'initialization' stamp: ''!
initializeRadialBetween: origin
			extending: innerRadius
			and: outerOrigin
			extending: outerRadius
			withColorRamp: aRamp
			
	self initialize.		
	aRamp do:[:each|
		self
			addColorStopAt: each key
			colored: each value ]! !

!AthensCairoGradientPaint methodsFor: 'private' stamp: ''!
populateRamp: aRamp
	aRamp do: [ :each |
		self
			addColorStopAt: each key
			colored: each value ]! !

!AthensCairoGradientPaint class methodsFor: 'primitives' stamp: ''!
primCreateRadialXo: xo yo: yo radiuso: radiuso x1: x1 y1: y1 radius1: radius1
	^ self ffiCall: #(AthensCairoGradientPaint cairo_pattern_create_radial (
		double xo,
		double yo,
		double radiuso,
		double x1,
		double y1,
		double radius1 ) )! !

!AthensCairoGradientPaint class methodsFor: 'primitives' stamp: ''!
primCreateLinearX0: x0 y0: y0 x1: x1 y1: y1
	^ self ffiCall: #(AthensCairoGradientPaint cairo_pattern_create_linear (
		double x0,
		double y0,
		double x1,
		double y1 ) )! !

!AthensCairoGradientPaint class methodsFor: 'paints' stamp: ''!
createLinearGradient: aColorRamp start: aStartPoint stop: aStopPoint
	| paint |
	paint := self
		primCreateLinearX0: aStartPoint x asFloat
		y0: aStartPoint y asFloat
		x1: aStopPoint x asFloat
		y1: aStopPoint y asFloat.
	
	"note, we do #initialize here because instance was created by primitive"
	paint initialize; populateRamp: aColorRamp.
	^ paint! !

!AthensCairoGradientPaint class methodsFor: 'private' stamp: ''!
radialBetween: origin
	extending: innerRadius
	and: outerOrigin
	extending: outerRadius
	withColorRamp: colorRamp
	| paint |

	paint := self
		primCreateRadialXo: origin x 
		yo: origin y 
		radiuso: innerRadius 
		x1: outerOrigin x
		y1: outerOrigin y 
		radius1: outerRadius.
	paint
		initializeRadialBetween: origin
			extending: innerRadius
			and: outerOrigin
			extending: outerRadius
			withColorRamp: colorRamp.
	^ paint.! !

!AthensCairoMatrix commentStamp: ''!
I implement an AthensAffineTransform interface.!
!AthensCairoMatrix methodsFor: 'private' stamp: ''!
primTransformX: x Y: y
	^ self ffiCall: #( void cairo_matrix_transform_point (AthensCairoMatrix *  self, double * x, double * y))! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
rotateByRadians: angle

	^ self primRotateByRadians: angle asFloat.! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
shy
	"This method was automatically generated"
	^handle doubleAt: OFFSET_SHY! !

!AthensCairoMatrix methodsFor: 'private' stamp: ''!
initx: x y: y sx: sx sy: sy shx: shx shy: shy
	^ self ffiCall: #(
		void cairo_matrix_init (AthensCairoMatrix * self,
			double sx,
			double shy,
			double shx,
			double sy,
			double x,
			double y))! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
clearTranslation
	"reset a translation from matrix, leaving only scale and rotation"
	
	self x: 0.
	self y: 0.! !

!AthensCairoMatrix methodsFor: 'private' stamp: ''!
primRotateByRadians: angle
	^ self ffiCall: #(
		void cairo_matrix_rotate (AthensCairoMatrix *  self,
                                                         double angle))! !

!AthensCairoMatrix methodsFor: 'private' stamp: ''!
primSetRotationInRadians: radians
	^ self ffiCall: #( void cairo_matrix_init_rotate (AthensCairoMatrix * self, double  radians))! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
transformX: xValue Y: yValue
	| x y |
	x := ByteArray new: 8.
	y := ByteArray new: 8.
	x doubleAt: 1 put: xValue.
	y doubleAt: 1 put: yValue.
	self primTransformX: x Y: y.
	^ (x doubleAt: 1) @ (y doubleAt: 1)! !

!AthensCairoMatrix methodsFor: 'private' stamp: ''!
copyFromMatrix: m
	self assert: [ m getHandle ~= self getHandle ].
	LibC memCopy: m getHandle to: self getHandle size: self class byteSize! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle doubleAt: OFFSET_X! !

!AthensCairoMatrix methodsFor: 'private' stamp: ''!
primLoadIdentity
	"initialize with identity transform"
	^ self ffiCall: #( void cairo_matrix_init_identity (AthensCairoMatrix * self ) )! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_Y put: anObject! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
inverted
 	| m |
	m := self copy.
	m invert.
	^ m! !

!AthensCairoMatrix methodsFor: 'testing' stamp: ''!
isIdentity
	^ self sx = 1 and: [ self shx = 0 and: [ self x = 0 and: [
	self shy = 0 and: [ self sy = 1 and: [ self y = 0]]]]]! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
setRotationInRadians: radians

	^ self primSetRotationInRadians: radians asFloat! !

!AthensCairoMatrix methodsFor: 'private' stamp: ''!
primSetTranslateX: x Y: y
	^ self ffiCall: #( void cairo_matrix_init_translate (AthensCairoMatrix * self, double  x, double  y))! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
setScaleX: x Y: y
	
	^ self primSetScaleX: x asFloat Y: y asFloat! !

!AthensCairoMatrix methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self loadIdentity! !

!AthensCairoMatrix methodsFor: 'copying' stamp: ''!
postCopy
	self setHandle: self getHandle copy.! !

!AthensCairoMatrix methodsFor: 'accessing' stamp: ''!
getMatrix
	
	"Shall we answer an AthensAffineMatrix instead?
	
	^ AthensAffineMatrix new loadAffineTransform: self
	 "

	^ self copy! !

!AthensCairoMatrix methodsFor: 'copying' stamp: ''!
copy
	^ self class new loadAffineTransform: self! !

!AthensCairoMatrix methodsFor: 'private' stamp: ''!
primSetScaleX: x Y: y
	^ self ffiCall: #( void cairo_matrix_init_scale (AthensCairoMatrix * self, double  x, double  y))! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
setTranslateX: x Y: y

	^ self primSetTranslateX: x asFloat Y: y asFloat! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
sy
	"This method was automatically generated"
	^handle doubleAt: OFFSET_SY! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
sy: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_SY put: anObject! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
inverseTransform: aPoint 

	^ self inverted transform: aPoint! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
transform: aPoint
	| x y |
	x := ByteArray new: 8.
	y := ByteArray new: 8.
	x doubleAt: 1 put: aPoint x.
	y doubleAt: 1 put: aPoint y.
	self primTransformX: x Y: y.
	^ (x doubleAt: 1) @ (y doubleAt: 1)! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
loadAffineTransform: m
	self 
		initx: m x 
		y: m y 
		sx: m sx 
		sy: m sy 
		shx: m shx 
		shy: m shy! !

!AthensCairoMatrix methodsFor: 'private' stamp: ''!
primMultiplyBy: m
	^ self ffiCall: #(void   cairo_matrix_multiply
		(AthensCairoMatrix * self,
		AthensCairoMatrix * m ,
		AthensCairoMatrix * self ) )! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
translateX: px Y: py

	^ self primTranslateX: px asFloat Y: py asFloat.! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
shx
	"This method was automatically generated"
	^handle doubleAt: OFFSET_SHX! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
translateBy: aPoint
	self translateX: aPoint x Y: aPoint y! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
shy: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_SHY put: anObject! !

!AthensCairoMatrix methodsFor: 'private' stamp: ''!
primTranslateX: px Y: py
	^ self ffiCall: #(
		void cairo_matrix_translate (AthensCairoMatrix * self,
                                                         double px,
                                                         double py))! !

!AthensCairoMatrix methodsFor: 'testing' stamp: ''!
isAffineTransform
	^ true! !

!AthensCairoMatrix methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_X put: anObject! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle doubleAt: OFFSET_Y! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
loadIdentity
	"initialize with identity transform"
	
	self primLoadIdentity! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
transformRectangle: aRectangle
	^ Rectangle encompassing: {
		self transform: aRectangle bottomLeft.
		self transform: aRectangle bottomRight.
		self transform: aRectangle topLeft.
		self transform: aRectangle topRight.
	}! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
multiplyBy: anAthensAffineTransform
	
	self primMultiplyBy: (
		self class new loadAffineTransform: anAthensAffineTransform)! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
restoreAfter: aBlock
	|previous|
	previous := self copy.
	aBlock ensure: [ 
		"self copyFromMatrix: previous. 
		"self loadAffineTransform: previous ]! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
rotateByDegrees: angle


	^ self rotateByRadians: angle degreesToRadians! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
scaleBy: factor

	"if factor is number, do a uniform scale, 
	if not, then factor is assument to be an instance of Point containing non-uniform scale for each axis"
	factor isPoint 
		ifTrue: [ self scaleX: factor x asFloat Y: factor y asFloat ] 
		ifFalse: [ self scaleX: factor asFloat Y: factor asFloat ]! !

!AthensCairoMatrix methodsFor: 'private' stamp: ''!
primScaleX: fx Y: fy
	^ self ffiCall: #(
		void cairo_matrix_scale (AthensCairoMatrix * self,
                                                         double fx,
                                                         double fy))! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
shx: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_SHX put: anObject! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
sx
	"This method was automatically generated"
	^handle doubleAt: OFFSET_SX! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
invert
	^self ffiCall: #( cairo_status_t cairo_matrix_invert (AthensCairoMatrix *  self))! !

!AthensCairoMatrix methodsFor: 'accessing - structure variables' stamp: ''!
sx: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_SX put: anObject! !

!AthensCairoMatrix methodsFor: 'transformations' stamp: ''!
scaleX: fx Y: fy
	
	^ self primScaleX: fx asFloat Y: fy asFloat! !

!AthensCairoMatrix class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoMatrix class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoMatrix class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoMatrix class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoMatrix class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoMatrix class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoMatrix class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoMatrix class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoMatrix class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoMatrix class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoMatrix class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoMatrix class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoMatrix class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoMatrix class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoMatrix class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoMatrix class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoMatrix class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoMatrix class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoMatrix class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoMatrix class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoMatrix class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoMatrix class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoMatrix class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoMatrix class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoMatrix class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoMatrix class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoMatrix class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
   double sx; double shx;
   double shy; double sy;
   double x; double y;
	)! !

!AthensCairoMatrix class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoMatrix class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoMatrix class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoMatrix class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCairoMatrixTest commentStamp: ''!
A test for AthensCairoMatrix!
!AthensCairoMatrixTest methodsFor: 'tests' stamp: ''!
transformClass
	^ AthensCairoMatrix! !

!AthensCairoMatrixTest methodsFor: 'tests' stamp: ''!
testInverted

	| m |
	m := AthensCairoMatrix new.
	self assert: m getHandle ~~ m inverted getHandle! !

!AthensCairoMatrixTest methodsFor: 'tests' stamp: ''!
testCopy

	| m |
	m := AthensCairoMatrix new.
	self assert: m getHandle equals: m copy getHandle.
	self assert: m getHandle ~~ m copy getHandle! !

!AthensCairoMeshGradientPaint commentStamp: ''!
I represent a mesh gradient in the Cairo backend.!
!AthensCairoMeshGradientPaint methodsFor: 'mesh pattern commands' stamp: ''!
curveViaX: x1 Y: y1 viaX: x2 Y: y2 toX: x3 Y: y3
	^ self ffiCall: #(void cairo_mesh_pattern_curve_to(cairo_pattern_t self,
                                                         double x1,
                                                         double y1,
                                                         double x2,
                                                         double y2,
                                                         double x3,
                                                         double y3))! !

!AthensCairoMeshGradientPaint methodsFor: 'mesh pattern commands' stamp: ''!
beginPatch
	^ self ffiCall:#( void cairo_mesh_pattern_begin_patch ( cairo_pattern_t  self ))! !

!AthensCairoMeshGradientPaint methodsFor: 'mesh pattern commands' stamp: ''!
endPatch
	^ self ffiCall:#( void cairo_mesh_pattern_end_patch ( cairo_pattern_t  self ))! !

!AthensCairoMeshGradientPaint methodsFor: 'mesh pattern commands' stamp: ''!
lineToX: x Y: y
	^ self ffiCall:#( void cairo_mesh_pattern_line_to ( cairo_pattern_t self, double x, double y ))! !

!AthensCairoMeshGradientPaint methodsFor: 'mesh pattern commands' stamp: ''!
curveVia: pt1 and: lastControlPoint to: endPoint
	self curveViaX: pt1 x Y: pt1 y viaX: lastControlPoint x Y: lastControlPoint y toX: endPoint x Y: endPoint y! !

!AthensCairoMeshGradientPaint methodsFor: 'mesh pattern commands' stamp: ''!
moveTo: aPoint
	self moveToX: aPoint x asFloat Y: aPoint y asFloat! !

!AthensCairoMeshGradientPaint methodsFor: 'mesh pattern commands' stamp: ''!
setCorner: corner_num r: red g: green b: blue a: alpha
	^ self ffiCall:#( void cairo_mesh_pattern_set_corner_color_rgba ( cairo_pattern_t self, uint corner_num, 	double red, double green, double blue, double alpha ))! !

!AthensCairoMeshGradientPaint methodsFor: 'accessing' stamp: ''!
colors: aSequenceOfColors
	aSequenceOfColors doWithIndex: [ :color :index |
		self setCorner: index - 1 color: color
	]! !

!AthensCairoMeshGradientPaint methodsFor: 'mesh pattern commands' stamp: ''!
lineTo: aPoint
	self lineToX: aPoint x asFloat Y: aPoint y asFloat! !

!AthensCairoMeshGradientPaint methodsFor: 'private' stamp: ''!
populatePatches: aListOfMeshPatches
	aListOfMeshPatches do: [ :each | each addToCairoMeshGradientPaint: self ]! !

!AthensCairoMeshGradientPaint methodsFor: 'mesh pattern commands' stamp: ''!
setCorner: corner_num color: color
	self setCorner: corner_num r: color red g: color green b: color blue a: color alpha! !

!AthensCairoMeshGradientPaint methodsFor: 'mesh pattern commands' stamp: ''!
moveToX: x Y: y
	^ self ffiCall:#( void cairo_mesh_pattern_move_to ( cairo_pattern_t self, double x, double y ))! !

!AthensCairoMeshGradientPaint class methodsFor: 'paints' stamp: ''!
primCreateMesh
	^ self ffiCall: #(AthensCairoMeshGradientPaint cairo_pattern_create_mesh () )! !

!AthensCairoMeshGradientPaint class methodsFor: 'paints' stamp: ''!
createMeshGradientWithPatches: aListOfMeshPatches
	| paint |
	paint := self primCreateMesh.

	"note, we do #initialize here because instance was created by primitive"
	paint initialize; populatePatches: aListOfMeshPatches.
	^ paint! !

!AthensCairoPDFSurface commentStamp: ''!
I represent an Athens surface that renders into a PDF file using the cairo graphics library.

For more information, please read the comment of my superclass, which implements behavior that is shared with other surfaces that write to file using the cairo graphics library.

Reference: https://cairographics.org/manual/cairo-PDF-Surfaces.html
!
!AthensCairoPDFSurface class methodsFor: 'private' stamp: ''!
createExportingTo: fileName width: width height: height
	^ self ffiCall: #(AthensCairoPDFSurface cairo_pdf_surface_create(
			String fileName,
			double width, 
			double height) )! !

!AthensCairoPDFSurfaceTest methodsFor: 'accessing' stamp: ''!
athensSurfaceClass
	^ AthensCairoPDFSurface! !

!AthensCairoPaintMode commentStamp: ''!
I control the paint modes supported by Cairo backend.

for the list and description of paint modes supported by Cairo library, see
http://cairographics.org/operators/!
!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
softLight
	
	^ self setOperator: CAIRO_OPERATOR_SOFT_LIGHT! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
dest
	"Set 'dest' drawing mode.
	
	Drawing under this mode will ignore the source, as if nothing drawn"
		
	^ self setOperator: CAIRO_OPERATOR_DEST! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
hardLight
	
	^ self setOperator: CAIRO_OPERATOR_HARD_LIGHT! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
in
	
	^ self setOperator: CAIRO_OPERATOR_IN! !

!AthensCairoPaintMode methodsFor: 'initialization' stamp: ''!
canvas: aCanvas
	canvas := aCanvas! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
colorDodge
	
	^ self setOperator: CAIRO_OPERATOR_COLOR_DODGE! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
hslHue
	
	^ self setOperator: CAIRO_OPERATOR_HSL_HUE! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
saturate
	
	^ self setOperator: CAIRO_OPERATOR_SATURATE! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
xor
	
	^ self setOperator: CAIRO_OPERATOR_XOR! !

!AthensCairoPaintMode methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
lighten
	
	^ self setOperator: CAIRO_OPERATOR_LIGHTEN! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
destOut
	
	^ self setOperator: CAIRO_OPERATOR_DEST_OUT! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
source
	"Set 'source' drawing mode.
	
	Drawing under this mode will replace the content with incoming source under the shape boundaries"
	
	^ self setOperator: CAIRO_OPERATOR_SOURCE! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
add
	
	^ self setOperator: CAIRO_OPERATOR_ADD! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
hslLuminosity
	
	^ self setOperator: CAIRO_OPERATOR_HSL_LUMINOSITY! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
destOver
	
	^ self setOperator: CAIRO_OPERATOR_DEST_OVER! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
over
	"Set 'over' drawing mode. This is default paint mode.
	
	Drawing under this mode will blend source with destination color using source alpha component"
			
	^ self setOperator: CAIRO_OPERATOR_OVER! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
destAtop
	
	^ self setOperator: CAIRO_OPERATOR_DEST_ATOP! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
exclusion
	
	^ self setOperator: CAIRO_OPERATOR_EXCLUSION! !

!AthensCairoPaintMode methodsFor: 'convenience' stamp: ''!
restoreAfter: aBlock
	| op |
	op := self getOperator.
	
	aBlock ensure: [ self setOperator: op ]! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
darken
	
	^ self setOperator: CAIRO_OPERATOR_DARKEN! !

!AthensCairoPaintMode methodsFor: 'capabilities' stamp: ''!
availableModes

	^ #(
		clear
		source
		over
		in
		out 
		atop
		dest
		destOver
		destIn
		destOut
		destAtop
		xor
		add
		saturate
		multiply
		screen
		overlay
		darken
		lighten
		colorDodge
		colorBurn
		hardLight
		softLight
		difference
		exclusion
		hslHue
		hslSaturation
		hslColor
		hslLuminosity
	)! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
destIn
	
	^ self setOperator: CAIRO_OPERATOR_DEST_IN! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
screen
	
	^ self setOperator: CAIRO_OPERATOR_SCREEN! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
multiply
	
	^ self setOperator: CAIRO_OPERATOR_MULTIPLY! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
colorBurn
	
	^ self setOperator: CAIRO_OPERATOR_COLOR_BURN! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
hslSaturation
	
	^ self setOperator: CAIRO_OPERATOR_HSL_SATURATION! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
out
	
	^ self setOperator: CAIRO_OPERATOR_OUT! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
atop
	
	^ self setOperator: CAIRO_OPERATOR_ATOP! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
difference
	
	^ self setOperator: CAIRO_OPERATOR_DIFFERENCE! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
hslColor
	
	^ self setOperator: CAIRO_OPERATOR_HSL_COLOR! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
clear
	"Set 'clear' drawing mode.
	
	Drawing under this mode will clear the surface under the shape boundaries"
	
	^ self setOperator: CAIRO_OPERATOR_CLEAR! !

!AthensCairoPaintMode methodsFor: 'private' stamp: ''!
getOperator
	^ self ffiCall: #(
		cairo_operator_t cairo_get_operator (AthensCairoCanvas canvas) )! !

!AthensCairoPaintMode methodsFor: 'private' stamp: ''!
setOperator: aCairoOperatorT
	^ self ffiCall: #(void cairo_set_operator (AthensCairoCanvas canvas, cairo_operator_t aCairoOperatorT) )! !

!AthensCairoPaintMode methodsFor: 'modes' stamp: ''!
overlay
	
	^ self setOperator: CAIRO_OPERATOR_OVERLAY! !

!AthensCairoPaintMode class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoPaintMode class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoPaintMode class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoPaintMode class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoPaintMode class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoPaintMode class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoPaintMode class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoPaintMode class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoPaintMode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoPaintMode class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoPaintMode class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoPaintMode class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoPaintMode class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoPaintMode class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoPaintMode class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoPaintMode class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoPaintMode class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoPaintMode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoPaintMode class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoPaintMode class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoPaintMode class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoPaintMode class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoPaintMode class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoPaintMode class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoPaintMode class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoPaintMode class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoPaintMode class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoPaintMode class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoPaintMode class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoPaintMode class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCairoPath commentStamp: ''!
i used to hold shapes built by path builder in cairo backend!
!AthensCairoPath methodsFor: 'initialization' stamp: ''!
initialize 
	handle value = 0 ifTrue: [ 
		self error: 'Error creating new path' ].
	FFIExternalResourceManager addResource: self data: handle! !

!AthensCairoPath methodsFor: 'instance creation' stamp: ''!
primDestroyPath: aHandle
	^ self ffiCall: #(void cairo_path_destroy ( ulong aHandle ))! !

!AthensCairoPath methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoPath methodsFor: 'converting' stamp: ''!
asAthensShapeOn: anAthensCanvas 
	
	^ self! !

!AthensCairoPath methodsFor: 'drawing' stamp: ''!
paintFillsUsing: aPaint on: anAthensCanvas 
	
	"This method is a part of rendering dispatch  Canvas->receiver->paint"
	
	^ aPaint athensFillPath: self on: anAthensCanvas! !

!AthensCairoPath class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoPath class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoPath class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoPath class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoPath class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoPath class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoPath class methodsFor: 'instance creation' stamp: ''!
finalizeResourceData: aHandle

	self primDestroyPath: aHandle! !

!AthensCairoPath class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoPath class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoPath class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoPath class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoPath class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoPath class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoPath class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoPath class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoPath class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoPath class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoPath class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoPath class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoPath class methodsFor: 'instance creation' stamp: ''!
primDestroyPath: aHandle
	^ self ffiCall: #(void cairo_path_destroy ( void* aHandle ))! !

!AthensCairoPath class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoPath class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoPath class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoPath class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoPath class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoPath class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoPath class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoPath class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoPath class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoPath class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoPath class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoPath class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCairoPathBuilder commentStamp: ''!
i implement cairo-specific path builder. see my superclass for more details.!
!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
arcNegativeCenterX: xc centerY: yc radius: radius startAngle: angle1 endAngle: angle2 
	^ self ffiCall: #(void cairo_arc_negative (AthensCairoCanvas context,
				double xc,
				double yc,
				double radius,
				double angle1,
				double angle2) )! !

!AthensCairoPathBuilder methodsFor: '*Roassal3' stamp: ''!
arcCos: num
	| temp |
	temp := num.
	num < -1.0 ifTrue: [ temp := -1.0 ].
	num > 1.0 ifTrue: [ temp := 1.0 ].
	
	^ temp arcCos! !

!AthensCairoPathBuilder methodsFor: '*Roassal3' stamp: ''!
arcAround: aCenterPoint radius: aRadius startAngle: aStartAngle endAngle: anEndAngle cw: aBool
	aBool ifTrue: [ 
		self
		arcNegativeCenterX: aCenterPoint x
		centerY: aCenterPoint y
		radius: aRadius
		startAngle: aStartAngle
		endAngle: anEndAngle ]
	ifFalse: [ self
		arcCenterX: aCenterPoint x
		centerY: aCenterPoint y
		radius: aRadius
		startAngle: aStartAngle
		endAngle: anEndAngle ]
	! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
getCurrentPoint
	^ context getCurrentPoint! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
toAbsolute: aPoint

	^ absolute ifTrue: [ aPoint ] ifFalse: [ endPoint + aPoint ]! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
curveVia: p1 and: p2 to: aPoint
	|  pt1 |

	pt1 := self toAbsolute: p1.
	lastControlPoint := self toAbsolute: p2.
	endPoint := self toAbsolute: aPoint.

	self curveViaX: pt1 x Y: pt1 y viaX: lastControlPoint x Y: lastControlPoint y toX: endPoint x Y: endPoint y! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
absolute
	absolute := true! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
angleOfVector: v

	| n acos |
	
	n := v normalized.
	acos := n x arcCos.
	
	^ v y < 0 ifTrue: [ Float pi * 2 - acos ] ifFalse: [ acos ]! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
closePath
	^ self ffiCall: #(void cairo_close_path (AthensCairoCanvas context))! !

!AthensCairoPathBuilder methodsFor: 'accessing' stamp: ''!
context: anObject

	context := anObject! !

!AthensCairoPathBuilder methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
relative
	absolute := false! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
calcCenter: start end: end angle: angle

	| v center radius len m |	

	v := end - start.
	
	m := AthensAffineTransform new rotateByRadians: (Float pi - angle   /2).

	v := m transform: v.		
	len := v r.
	radius := len / 2 / (angle /2) sin.
	
	center := v * (radius/len) + start.

	^ center! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
hLineTo: x
	^ self lineTo: (absolute ifTrue: [ x @ endPoint y] ifFalse: [ x @ 0 ])! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
close

	self closePath.
	
	endPoint := self getCurrentPoint.
	lastControlPoint := nil! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
primCurveViaX: x1 Y: y1 viaX: x2 Y: y2 toX: x3 Y: y3
	^ self ffiCall: #(void cairo_curve_to(AthensCairoCanvas context,
                                                         double x1,
                                                         double y1,
                                                         double x2,
                                                         double y2,
                                                         double x3,
                                                         double y3))! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
lineTo: aPoint

	endPoint := self toAbsolute: aPoint.
	lastControlPoint := nil.
	^ self lineToX: endPoint x asFloat Y: endPoint y asFloat! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
ccwArcTo: newEndPoint angle: angle
	" Add a counter-clockwise arc segment, starting from current path endpoint and
	ending at andPt. Angle should be specified in radians 
	"
	^ self arcTo: newEndPoint angle: angle cw: false! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
curveViaX: x1 Y: y1 viaX: x2 Y: y2 toX: x3 Y: y3

	^ self
		  primCurveViaX: x1 asFloat
		  Y: y1 asFloat
		  viaX: x2 asFloat
		  Y: y2 asFloat
		  toX: x3 asFloat
		  Y: y3 asFloat! !

!AthensCairoPathBuilder methodsFor: '*Roassal3' stamp: ''!
arcAround: aCenterPoint radius: aRadius startAngle: aStartAngle endAngle: anEndAngle
	self 
		arcCenterX: aCenterPoint x
		centerY: aCenterPoint y
		radius: aRadius 
		startAngle: aStartAngle 
		endAngle: anEndAngle ! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
lineToX: x Y: y
	^ self ffiCall: #(void cairo_line_to (AthensCairoCanvas context,
		 double x, double y ) )! !

!AthensCairoPathBuilder methodsFor: 'accessing' stamp: ''!
createPath: aBlock
	
	self newPath.
	"set default to relative"
	absolute := false.
	endPoint := ZeroPoint.
	
	"set the implicit path origin"
	self moveToX: 0.0 Y: 0.0.
		
	aBlock value: self.
	
	^ self copyPath initialize! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
curveVia: p1 to: aPoint
	| pt0 pt1 cp1 cp2 twoThirds |
	"Quad bezier curve"

	pt0 := endPoint.
	pt1 := self toAbsolute: p1.
	endPoint := self toAbsolute: aPoint.
	lastControlPoint := nil.
	
"Any quadratic spline can be expressed as a cubic (where the cubic term is zero). The end points of the cubic will be the same as the quadratic's.

	CP0 = QP0
	CP3 = QP2

The two control points for the cubic are:

	CP1 = QP0 + 2/3 *(QP1-QP0)
	CP2 = QP2 + 2/3 *(QP1-QP2)"

	twoThirds := (2/3) asFloat.

	cp1 := pt1 - pt0 * twoThirds + pt0.
	cp2 := pt1 - endPoint * twoThirds + endPoint.
	
	self curveViaX: cp1 x Y: cp1 y viaX: cp2 x Y: cp2 y toX: endPoint x Y: endPoint y! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
arcTo: newEndPoint angle: angle cw: aBool

	" Add a clockwise arc segment, starting from current path endpoint and
	ending at andPt. Angle should be specified in radians 
	"

	| start end center v radius startAngle endAngle cwAngle |	
	lastControlPoint := nil.
	angle isZero ifTrue: [ ^ self lineTo: newEndPoint ].
	 
	start := endPoint.
	endPoint := end := self toAbsolute: newEndPoint.
	
	start = end ifTrue: [ ^ self ].

	"we have to transform the input. because Cario expects 
	the center , radius, starting and ending angle,
	and we have the starting point, the ending point , and the angle.
	"
	aBool ifTrue: [cwAngle := angle] ifFalse: [cwAngle := angle negated].
	center := self calcCenter: start end: end  angle: cwAngle.
	v := (start - center).
	radius := v r.
	startAngle := self angleOfVector: v.
	endAngle := self angleOfVector: (end-center).
	aBool ifTrue: [ self arcCenterX: center x centerY: center y  radius: radius  startAngle: startAngle endAngle: endAngle ]
		ifFalse: [ self arcNegativeCenterX: center x centerY: center y  radius: radius  startAngle: startAngle  endAngle: endAngle ]! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
moveTo: aPoint
	
	endPoint := self toAbsolute: aPoint.
	lastControlPoint := nil.
	
	^ self moveToX: endPoint x asFloat Y: endPoint y asFloat! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
string: aString font: aFont
	"Adds closed paths for the string to the current path. The generated path if filled, achieves an effect similar to that of cairo_show_glyphs()."
	|glyphs metricsProvider|
	metricsProvider := CairoFontMetricsProvider new
		font: aFont.
	glyphs := metricsProvider glyphsOf: aString.
	context setScaledFont: metricsProvider cairoFont.
	self glyphPath: glyphs getHandle size: glyphs size! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
arcCenterX: xc centerY: yc radius: radius startAngle: angle1 endAngle: angle2 
	^ self ffiCall: #(void cairo_arc (AthensCairoCanvas context,
				double xc,
				double yc,
				double radius,
				double angle1,
				double angle2) )! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
reflectedCurveVia: p2 to: aPoint
	|  pt1 |

	pt1 := lastControlPoint
		ifNil: [ endPoint ]
		ifNotNil: [ endPoint * 2 - lastControlPoint].
	lastControlPoint := self toAbsolute: p2.
	endPoint := self toAbsolute: aPoint.

	self curveViaX: pt1 x Y: pt1 y viaX: lastControlPoint x Y: lastControlPoint y toX: endPoint x Y: endPoint y! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
glyphPath: glyphs size: numGlyphs
	"void cairo_glyph_path (cairo_t *cr,
                  const cairo_glyph_t *glyphs,
                  int num_glyphs);"
	^ self ffiCall: #(
	
		void cairo_glyph_path ( AthensCairoCanvas context ,
			void * glyphs,
			int numGlyphs) )! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
newPath
 ^ self ffiCall: #( void cairo_new_path ( AthensCairoCanvas context ) )! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
vLineTo: y
	^ self lineTo: (absolute ifTrue: [ endPoint x @ y] ifFalse: [ 0 @ y ])! !

!AthensCairoPathBuilder methodsFor: '*Roassal3' stamp: ''!
ellipticalArc2: radii xrot: rotationAxis large: largeFlag sweep: sweepFlag to: aPoint

	"raddi Point, rotationAxis Number, largeFlag Number, sweepFlag Number, aPoint Point"
	"implentation based on the svg specification"
	| ep x0 y0 x y dx2 dy2 theta x1 y1 tcos tsin rx ry prx pry px1 py1 d sign coef cx1 cy1 sx2 sy2 cx cy ux uy vx vy n p angleStart angleExtent pi2 |
	self flag: 'Not yet for real elliptic arcs'.
	pi2 := Float pi * 2.
	(radii x = 0 or: [ radii y = 0 ]) ifTrue: [ 
		^ self lineTo: aPoint ].
	ep := self getCurrentPoint.
	x0 := ep x.
	y0 := ep y.
	x := aPoint x.
	y := aPoint y.
	dx2 := (x0 - x)/2.0.
	dy2 := (y0 - y)/2.0.
	theta := rotationAxis degreesToRadians.
	tcos := theta cos.
	tsin := theta sin.
	x1 := (tcos * dx2) + (tsin * dy2).
	y1 := (tsin negated* dx2) + (tcos * dy2).
	rx := radii x abs.
	ry := radii y abs.
	prx := rx * rx.
	pry := ry * ry.
	px1 := x1 * x1.
	py1 := y1 * y1.
	d := (px1 / prx) + (py1 / pry).
	d > 1 ifTrue: [ 
		rx := rx * d sqrt.
		ry := ry * d sqrt.
		prx := rx * rx.
		pry := ry * ry ].
	
	sign := largeFlag = sweepFlag ifTrue: [ -1 ] ifFalse: [ 1 ].
	coef := sign * (( (prx * pry) - (prx * py1) - (pry * px1) )/( (prx * py1) + (pry * px1) ) max: 0) sqrt.
	
	cx1 := coef * rx * y1 / ry.
	cy1 := coef * (ry * x1 / rx) negated.
	
	sx2 := (x0 + x)/2.
	sy2 := (y0 + y)/2.
	cx := sx2 + ((tcos * cx1) - (tsin * cy1)).
	cy := sy2 + ((tsin * cx1) + (tcos * cy1)).
	
	ux := (x1 - cx1)/rx.
	uy := (y1 - cy1)/ry.
	vx := (x1 + cx1) negated /rx.
	vy := (y1 + cy1) negated /ry.
	"Angle start"
	n := ((ux * ux) + (uy * uy)) sqrt.
	p := ux.
	sign := uy < 0 ifTrue: [ -1 ] ifFalse: [ 1 ].
	angleStart := sign * (self arcCos: p / n).
	"angle extent"
	n := (((ux * ux) + (uy * uy)) * ((vx * vx) + (vy * vy))) sqrt.
	p := (ux * vx) + (uy * vy).
	sign := ((ux * vy) - (uy * vx)) < 0 ifTrue: [ -1 ] ifFalse: [ 1 ].
	angleExtent := sign * (self arcCos: p / n).
	(sweepFlag = 0 and: [ angleExtent > 0]) ifTrue: [ 
		angleExtent := angleExtent - pi2.
	 ] ifFalse: [ (sweepFlag = 1 and: [ angleExtent < 0 ]) ifTrue: [ 
		angleExtent := angleExtent + pi2.
		 ] ].
	angleExtent := angleExtent % pi2.
	angleStart := angleStart % pi2.
	self
		arcAround: (cx asFloat)@ (cy asFloat)
		radius: rx asFloat
		startAngle: angleStart asFloat
		endAngle: angleExtent asFloat + angleStart
		cw: sweepFlag = 0.
! !

!AthensCairoPathBuilder methodsFor: 'path commands' stamp: ''!
cwArcTo: newEndPoint angle: angle
	" Add a clockwise arc segment, starting from current path endpoint and
	ending at andPt. Angle should be specified in radians 
	"
	^ self arcTo: newEndPoint angle: angle cw: true! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
copyPath 
	^ self ffiCall: #( AthensCairoPath cairo_copy_path (AthensCairoCanvas context) )! !

!AthensCairoPathBuilder methodsFor: 'private' stamp: ''!
moveToX: x Y: y
	" move command always starts a new contour "
	^ self ffiCall: #(void cairo_move_to (AthensCairoCanvas context,
		 double x, double y ) )! !

!AthensCairoPathBuilder class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoPathBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoPathBuilder class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoPathBuilder class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoPathBuilder class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoPathBuilder class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoPathBuilder class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoPathBuilder class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoPathBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoPathBuilder class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoPathBuilder class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoPathBuilder class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoPathBuilder class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoPathBuilder class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoPathBuilder class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoPathBuilder class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoPathBuilder class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoPathBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoPathBuilder class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoPathBuilder class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoPathBuilder class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoPathBuilder class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoPathBuilder class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoPathBuilder class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoPathBuilder class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoPathBuilder class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoPathBuilder class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoPathBuilder class methodsFor: 'utilities' stamp: ''!
buildPathFrom:  aPathCreatingBlock! !

!AthensCairoPathBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoPathBuilder class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoPathBuilder class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCairoPatternPaint commentStamp: ''!
i am abstract class for different kinds of paints in cairo backend.!
!AthensCairoPatternPaint methodsFor: 'accessing' stamp: ''!
noRepeat
	self primSetExtend: CAIRO_EXTEND_NONE.! !

!AthensCairoPatternPaint methodsFor: 'drawing' stamp: ''!
maskOn: anAthensCanvas
"
A drawing operator that paints the current source using the alpha channel of pattern as a mask. (Opaque areas of pattern are painted with the source, transparent areas are not painted.)
"
	^ self ffiCall: #(void cairo_mask(cairo_t anAthensCanvas, self))! !

!AthensCairoPatternPaint methodsFor: 'drawing' stamp: ''!
athensFillPath: path on: aCanvas 

	aCanvas
		newPath;
		loadPath: path.
	self setMatrix: aCanvas paintTransform inverted.
	self loadOnCairoCanvas: aCanvas.
	
	aCanvas fill.! !

!AthensCairoPatternPaint methodsFor: 'accessing' stamp: ''!
setExtend: aSymbol
	"
	typedef enum {
    CAIRO_EXTEND_NONE,
    CAIRO_EXTEND_REPEAT,
    CAIRO_EXTEND_REFLECT,
    CAIRO_EXTEND_PAD
} cairo_extend_t;
	"
	| enum |
	enum := self defaultExtend.
	aSymbol = #None ifTrue: [ enum := CAIRO_EXTEND_NONE ].
	aSymbol = #Repeat ifTrue: [ enum := CAIRO_EXTEND_REPEAT ].
	aSymbol = #Reflect ifTrue: [ enum := CAIRO_EXTEND_REFLECT ].
	aSymbol = #Pad ifTrue: [ enum := CAIRO_EXTEND_PAD ].
	self primSetExtend: enum.! !

!AthensCairoPatternPaint methodsFor: 'initialization' stamp: ''!
initialize
	handle value = 0 
		ifTrue: [ self error: 'Error creating new paint' ].
	"register to be finalized"
	FFIExternalResourceManager addResource: self data: handle.! !

!AthensCairoPatternPaint methodsFor: 'accessing' stamp: ''!
setMatrix: m
	^ self ffiCall: #( 
		void
			cairo_pattern_set_matrix ( self, AthensCairoMatrix * m)
		)! !

!AthensCairoPatternPaint methodsFor: 'converting' stamp: ''!
asAthensPaintOn: anAthensCanvas	
	^ self! !

!AthensCairoPatternPaint methodsFor: 'accessing' stamp: ''!
repeat
	self primSetExtend: CAIRO_EXTEND_REPEAT.! !

!AthensCairoPatternPaint methodsFor: 'initialization' stamp: ''!
defaultExtend
"The default extend mode is CAIRO_EXTEND_NONE for surface patterns and CAIRO_EXTEND_PAD for gradient patterns.
"
	
	^  CAIRO_EXTEND_NONE! !

!AthensCairoPatternPaint methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoPatternPaint methodsFor: 'converting' stamp: ''!
asStrokePaintOn: aCanvas
	^ aCanvas surface createStrokePaintFor: self! !

!AthensCairoPatternPaint methodsFor: 'drawing' stamp: ''!
athensFillRectangle: aRectangle on: aCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "

	aCanvas
		rectangleX: aRectangle left
		y: aRectangle top
		width: aRectangle width
		height: aRectangle height.
	
	self setMatrix: aCanvas paintTransform inverted.
	self loadOnCairoCanvas: aCanvas.
	aCanvas fill! !

!AthensCairoPatternPaint methodsFor: 'testing' stamp: ''!
isSuccess
	^ self status  =	CAIRO_STATUS_SUCCESS! !

!AthensCairoPatternPaint methodsFor: 'primitives' stamp: ''!
primSetExtend: extend
	^ self ffiCall:#(
		void cairo_pattern_set_extend ( self , ulong extend) )! !

!AthensCairoPatternPaint methodsFor: 'accessing' stamp: ''!
status
	^ self ffiCall: #(int cairo_pattern_status (cairo_pattern_t  self))! !

!AthensCairoPatternPaint methodsFor: 'primitives' stamp: ''!
primSetSourceOn: aCanvas
	^ self ffiCall: #(void cairo_set_source ( cairo_t  aCanvas,  self))! !

!AthensCairoPatternPaint methodsFor: 'drawing' stamp: ''!
athensLoadOn: anAthensCanvas 
	"
	Note: The pattern's transformation matrix will be locked to the user space in effect at the time of cairo_set_source(). This means that further modifications of the current transformation matrix will not affect the source pattern. See cairo_pattern_set_matrix().
	"

	self isSuccess
		ifTrue:[ anAthensCanvas primSetSource: self ]
		ifFalse:[ anAthensCanvas setSourceR: 1.0 g: 0.0 b: 0.0 a: 1.0].! !

!AthensCairoPatternPaint methodsFor: 'accessing' stamp: ''!
reflect
	self primSetExtend: CAIRO_EXTEND_REFLECT.! !

!AthensCairoPatternPaint methodsFor: 'testing' stamp: ''!
isPatternTypeMismatch
	^ self status = CAIRO_STATUS_PATTERN_TYPE_MISMATCH.! !

!AthensCairoPatternPaint methodsFor: 'drawing' stamp: ''!
loadOnCairoCanvas: aCanvas
	"
	Note: The pattern's transformation matrix will be locked to the user space in effect at the time of cairo_set_source(). This means that further modifications of the current transformation matrix will not affect the source pattern. See cairo_pattern_set_matrix().
	"

	self isSuccess
		ifTrue:[ aCanvas primSetSource: self ]
		ifFalse:[ aCanvas setSourceR: 1.0 g: 0.0 b: 0.0 a: 1.0].! !

!AthensCairoPatternPaint class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoPatternPaint class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoPatternPaint class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoPatternPaint class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoPatternPaint class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoPatternPaint class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoPatternPaint class methodsFor: 'private' stamp: ''!
finalizeResourceData: handle

	self primDestroyPattern: handle value! !

!AthensCairoPatternPaint class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoPatternPaint class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoPatternPaint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoPatternPaint class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoPatternPaint class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoPatternPaint class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoPatternPaint class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoPatternPaint class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoPatternPaint class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoPatternPaint class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoPatternPaint class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoPatternPaint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoPatternPaint class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoPatternPaint class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoPatternPaint class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoPatternPaint class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoPatternPaint class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoPatternPaint class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoPatternPaint class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoPatternPaint class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoPatternPaint class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoPatternPaint class methodsFor: 'private' stamp: ''!
primDestroyPattern: aHandle
	^ self ffiCall: #(void cairo_pattern_destroy (ulong aHandle) )! !

!AthensCairoPatternPaint class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoPatternPaint class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoPatternPaint class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCairoPatternSurfacePaint commentStamp: ''!
i represent texture/image/form/surface paints in cairo backend.!
!AthensCairoPatternSurfacePaint methodsFor: 'initialization' stamp: ''!
initializeFor: anAthensCairoSurface 
	self initialize.
	surface := anAthensCairoSurface .! !

!AthensCairoPatternSurfacePaint methodsFor: 'accessing' stamp: ''!
setMatrix: aMatrix

	aMatrix restoreAfter: [
		origin ifNotNil: [ aMatrix translateBy: origin negated ].
		super setMatrix: aMatrix.
	]! !

!AthensCairoPatternSurfacePaint methodsFor: 'private' stamp: ''!
setRect: aRectangle forFillOn: aCanvas
	aCanvas
		rectangleX: aRectangle left
		y: aRectangle top
		width: aRectangle width
		height: aRectangle height! !

!AthensCairoPatternSurfacePaint methodsFor: 'accessing' stamp: ''!
extent
	^ extent ifNil:[surface extent]! !

!AthensCairoPatternSurfacePaint methodsFor: 'accessing' stamp: ''!
origin: aPoint 
	origin := aPoint.! !

!AthensCairoPatternSurfacePaint methodsFor: 'drawing' stamp: ''!
athensFillRectangle: aRectangle on: aCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "

	extent
		ifNotNil: [ self setRect: (origin extent: extent) forFillOn: aCanvas ]
		ifNil: [ self setRect: aRectangle forFillOn: aCanvas ].
		
	self setMatrix: aCanvas paintTransform inverted.
	self loadOnCairoCanvas: aCanvas.
	aCanvas fill! !

!AthensCairoPatternSurfacePaint methodsFor: 'accessing' stamp: ''!
extent: aPatternExtent
	extent:= aPatternExtent! !

!AthensCairoPatternSurfacePaint class methodsFor: 'instance creation' stamp: ''!
createForSurface: anAthensCairoSurface
	|pat|
	pat := self primCreateForSurface: anAthensCairoSurface .
	pat initializeFor: anAthensCairoSurface  .
	^ pat! !

!AthensCairoPatternSurfacePaint class methodsFor: 'primitives' stamp: ''!
primCreateForSurface: anAthensCairoSurface
	
"	pattern = cairo_pattern_create_for_surface (image);"
	
	^ self ffiCall: #(AthensCairoPatternSurfacePaint cairo_pattern_create_for_surface(
		cairo_surface_t  anAthensCairoSurface ) )! !

!AthensCairoSVGSurface commentStamp: ''!
I represent an Athens surface that renders into a SVG file using the cairo graphics library.

For more information, please read the comment of my superclass, which implements behavior that is shared with other surfaces that write to file using the cairo graphics library.

Reference: https://cairographics.org/manual/cairo-SVG-Surfaces.html
!
!AthensCairoSVGSurface class methodsFor: 'private' stamp: ''!
createExportingTo: fileName width: width height: height
	^ self ffiCall: #(AthensCairoSVGSurface cairo_svg_surface_create (
				String fileName,
				double width,
				double height) )! !

!AthensCairoSVGSurfaceTest methodsFor: 'accessing' stamp: ''!
athensSurfaceClass
	^ AthensCairoSVGSurface! !

!AthensCairoSolidPaint commentStamp: ''!
i represent solid color paint in cairo backend!
!AthensCairoSolidPaint methodsFor: 'accessing' stamp: ''!
color: aColor
	r := aColor red.
	g := aColor green.
	b := aColor blue.
	a := aColor alpha.! !

!AthensCairoSolidPaint methodsFor: 'drawing' stamp: ''!
athensFillPath: path on: aCanvas 

	aCanvas
		setSourceR: r g: g b: b a: a; 
		newPath;
		loadPath: path;
		fill.! !

!AthensCairoSolidPaint methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoSolidPaint methodsFor: 'accessing' stamp: ''!
origin: aPoint
	origin := aPoint! !

!AthensCairoSolidPaint methodsFor: 'drawing' stamp: ''!
athensFillRectangle: aRect on: aCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	|o e toFillRect|
	o := origin ifNil:[aRect origin] ifNotNil:[origin].
	e := extent ifNil:[aRect extent] ifNotNil:[extent].
	toFillRect := o extent:e.
	
	aCanvas
		setSourceR: r g: g b: b a: a; 
		newPath;
		rectangleX: toFillRect left y: toFillRect top width: toFillRect width height: toFillRect height;
		fill.! !

!AthensCairoSolidPaint methodsFor: 'accessing' stamp: ''!
extent: anExtent
	extent := anExtent! !

!AthensCairoSolidPaint methodsFor: 'drawing' stamp: ''!
loadOnCairoCanvas: aCanvas
	aCanvas
		setSourceR: r g: g b: b a: a! !

!AthensCairoSolidPaint class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoSolidPaint class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoSolidPaint class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoSolidPaint class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoSolidPaint class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoSolidPaint class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoSolidPaint class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoSolidPaint class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoSolidPaint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoSolidPaint class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoSolidPaint class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoSolidPaint class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoSolidPaint class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoSolidPaint class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoSolidPaint class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoSolidPaint class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoSolidPaint class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoSolidPaint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoSolidPaint class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoSolidPaint class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoSolidPaint class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoSolidPaint class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoSolidPaint class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoSolidPaint class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoSolidPaint class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoSolidPaint class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoSolidPaint class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoSolidPaint class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoSolidPaint class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoSolidPaint class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCairoStrokePaint commentStamp: ''!
i represent stroke paint in cairo backend!
!AthensCairoStrokePaint methodsFor: 'setting - cap styles' stamp: ''!
capSquare
	capStyle := CAIRO_LINE_CAP_SQUARE! !

!AthensCairoStrokePaint methodsFor: 'drawing' stamp: ''!
athensFillPath: aPath on: aCanvas
	
	self prepareForDrawingOn: aCanvas.
	
	aCanvas 
		newPath; 
		loadPath: aPath;
		stroke! !

!AthensCairoStrokePaint methodsFor: 'private' stamp: ''!
prepareForDrawingOn: aCanvas
	
	fillPaint 
		loadOnCairoCanvas: aCanvas.
	
	aCanvas
		primSetLineWidth: width asFloat;
		primSetLineJoin: joinStyle;
		primSetLineCap: capStyle.
	
	dashLenghts 
		ifNil: [ aCanvas resetDash ] 
		ifNotNil: [ self setDashesOn: aCanvas ].! !

!AthensCairoStrokePaint methodsFor: 'setting - cap styles' stamp: ''!
capRound
	capStyle := CAIRO_LINE_CAP_ROUND! !

!AthensCairoStrokePaint methodsFor: 'setting - join styles' stamp: ''!
joinBevel
	joinStyle := CAIRO_LINE_JOIN_BEVEL! !

!AthensCairoStrokePaint methodsFor: 'private' stamp: ''!
primSetLineWidthOn: aCanvas
	^ self ffiCall: #(void cairo_set_line_width (
				AthensCairoCanvas aCanvas,
				double width) )! !

!AthensCairoStrokePaint methodsFor: 'private' stamp: ''!
primSetDashesOn: aCanvas lengths: dashesLengths count: dashesCount offset: anOffset
"	void                cairo_set_dash                      (cairo_t *cr,
                                                         double *dashes,
                                                         int num_dashes,
                                                         double offset);"
	
	^ self ffiCall: #(void cairo_set_dash (
				AthensCairoCanvas aCanvas,
				double* dashesLengths,
				int dashesCount,
				double anOffset) )! !

!AthensCairoStrokePaint methodsFor: 'setting - dashes' stamp: ''!
dashes: anAlternateCollectionOfLenghts offset: anOffset
	dashLenghts := anAlternateCollectionOfLenghts.
	dashOffset := anOffset asFloat.! !

!AthensCairoStrokePaint methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoStrokePaint methodsFor: 'private' stamp: ''!
setDashesOn: aCanvas 
	| buf |
	
	buf := ByteArray new: 8*dashLenghts size.
	
	dashLenghts withIndexDo: [:len :i |
		
		buf doubleAt: (i-1)*8 + 1 put: len asFloat
		].

	aCanvas
		primSetDashesLengths: buf
		count: dashLenghts size
		offset: dashOffset! !

!AthensCairoStrokePaint methodsFor: 'setting - join styles' stamp: ''!
joinMiter
	joinStyle := CAIRO_LINE_JOIN_MITER! !

!AthensCairoStrokePaint methodsFor: 'private' stamp: ''!
primSetLineCapOn: aCanvas
	^ self ffiCall: #(void cairo_set_line_cap (
			AthensCairoCanvas aCanvas,
			cairo_line_cap_t capStyle) )! !

!AthensCairoStrokePaint methodsFor: 'private' stamp: ''!
primSetLineJoinOn: aCanvas
	^ self ffiCall: #(void cairo_set_line_join (
			AthensCairoCanvas aCanvas,
			cairo_line_join_t joinStyle) )! !

!AthensCairoStrokePaint methodsFor: 'drawing' stamp: ''!
athensFillRectangle: aRect on: aCanvas

	self prepareForDrawingOn: aCanvas.
	
	aCanvas 
		newPath;
		rectangleX: aRect left
		y: aRect top 
		width: aRect width
		height: aRect height;
		stroke.! !

!AthensCairoStrokePaint methodsFor: 'setting - cap styles' stamp: ''!
capButt
	capStyle := CAIRO_LINE_CAP_BUTT.! !

!AthensCairoStrokePaint methodsFor: 'setting - join styles' stamp: ''!
joinRound
	joinStyle := CAIRO_LINE_JOIN_ROUND! !

!AthensCairoStrokePaint class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoStrokePaint class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoStrokePaint class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoStrokePaint class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoStrokePaint class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoStrokePaint class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoStrokePaint class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoStrokePaint class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoStrokePaint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoStrokePaint class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoStrokePaint class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoStrokePaint class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoStrokePaint class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoStrokePaint class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoStrokePaint class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoStrokePaint class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoStrokePaint class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoStrokePaint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoStrokePaint class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoStrokePaint class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoStrokePaint class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoStrokePaint class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoStrokePaint class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoStrokePaint class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoStrokePaint class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoStrokePaint class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoStrokePaint class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoStrokePaint class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoStrokePaint class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoStrokePaint class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCairoSurface commentStamp: ''!
I am a concrete implementation of Athens surface which using cairo graphics library for rendering.

Cairo library, by itself can have multiple surface types.
This class uses image surface (a bitmap located in system memory) and maps to cairo_image_surface_t* C type.

**NOTE**
As a workaround of a bug in bitblt, the Cairo surfaces are created internally with 1 extra pixel higher than requested. However, this is hidden for users.!
!AthensCairoSurface methodsFor: 'caching' stamp: ''!
cacheAt: anObject ifAbsentPut: aBlock
	"Answer an object from surface's cache identified by anObject,
	if there is no cached object under such identifier, evaluate a block
	and put it into cache. Then answer the result of evaluation.
	A surface using identity comparison for object identifiers.
	"
	^ CairoBackendCache soleInstance at: anObject ifAbsentPut: aBlock! !

!AthensCairoSurface methodsFor: 'private' stamp: ''!
privateHeight
	^ self ffiCall: #(
		int cairo_image_surface_get_height ( self ) )! !

!AthensCairoSurface methodsFor: 'private' stamp: ''!
newCanvas
	"Answer a preinitialized instance of AthensCanvas.
	Private to receiver and its subclasses, override seldom"
	
	^ self primCreateCanvas surface: self! !

!AthensCairoSurface methodsFor: '*Athens-Morphic' stamp: ''!
displayOnMorphicCanvas: canvas at: aPoint
	
	canvas
		image: self asForm
		at: aPoint
		sourceRect: (0@0 extent: self extent )
		rule: 34.! !

!AthensCairoSurface methodsFor: 'private' stamp: ''!
markDirty
	^ self ffiCall: #( void cairo_surface_mark_dirty (self) )! !

!AthensCairoSurface methodsFor: 'accessing' stamp: ''!
handle
	^ handle value! !

!AthensCairoSurface methodsFor: 'private' stamp: ''!
statusToString: aCairoStatusT
	^ self ffiCall: #(String   cairo_status_to_string  (cairo_status_t aCairoStatusT))! !

!AthensCairoSurface methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoSurface methodsFor: 'accessing' stamp: ''!
stride
	^ self ffiCall: #(
		int cairo_image_surface_get_stride ( self ) )! !

!AthensCairoSurface methodsFor: 'converting' stamp: ''!
writeToPng: aFileName
	^ self ffiCall: #(void cairo_surface_write_to_png (self, String aFileName) )! !

!AthensCairoSurface methodsFor: 'private' stamp: ''!
showPage
	^ self ffiCall: #( void cairo_surface_show_page (self) )! !

!AthensCairoSurface methodsFor: 'accessing' stamp: ''!
status
	^ self ffiCall: #(int cairo_surface_status (self) )! !

!AthensCairoSurface methodsFor: 'private' stamp: ''!
flush
	^ self ffiCall: #( void cairo_surface_flush (self) )! !

!AthensCairoSurface methodsFor: '*Roassal3' stamp: ''!
hasBeenFreed
	"Return true if the external resource has been freed"
	^ handle isNull! !

!AthensCairoSurface methodsFor: 'paints' stamp: ''!
createStrokePaintFor: aPaint

	^ AthensCairoStrokePaint new fillPaint: aPaint! !

!AthensCairoSurface methodsFor: 'private' stamp: ''!
primCreateCanvas
	^ self ffiCall: #( AthensCairoCanvas cairo_create (self) )! !

!AthensCairoSurface methodsFor: 'drawing' stamp: ''!
attemptToRecurseDrawing
	^ self! !

!AthensCairoSurface methodsFor: 'accessing' stamp: ''!
getDataPtr
	"get a pointer to surface bitmap data"
	
	^ self ffiCall: #(
		void* cairo_image_surface_get_data ( self ) )! !

!AthensCairoSurface methodsFor: 'accessing' stamp: ''!
getHandle
	
	^ handle! !

!AthensCairoSurface methodsFor: 'initialization' stamp: ''!
initialize
	"the handle should be set already since we using an NB callout to create an instance"
	handle value = 0 ifTrue: [ 
		self error: 'Error creating new surface' ].
	
	session := Smalltalk session.
	
	id := self class registerSurface: self.
		
	context := self newCanvas.
	builder := AthensCairoPathBuilder new.
	builder context: context.
	ftFontRenderer := CairoFreetypeFontRenderer new
		canvas: context. 
	
	FFIExternalResourceManager addResource: self.! !

!AthensCairoSurface methodsFor: 'text support' stamp: ''!
getStrikeFontRendererFor: aStrikeFont 
	"answer the same instance, just reset it's font and advance"
	
	^ AthensStrikeFontRenderer on: context  forFont: aStrikeFont.! !

!AthensCairoSurface methodsFor: 'paints' stamp: ''!
createLinearGradient: aColorRamp start: aStartPoint stop: aStopPoint
	^ AthensCairoGradientPaint 
		createLinearGradient: aColorRamp 
		start: aStartPoint 
		stop: aStopPoint! !

!AthensCairoSurface methodsFor: 'creation' stamp: ''!
createPath: aPathCreatingBlock
	^ builder createPath:  aPathCreatingBlock! !

!AthensCairoSurface methodsFor: 'paints' stamp: ''!
createFormPaint: aForm 
	"here we should convert form to cairo surface"
	
	| newSurface |

	newSurface := self class fromForm: (aForm asFormOfDepth: 32).
	
	^ newSurface asAthensPaintOn: context! !

!AthensCairoSurface methodsFor: 'paints' stamp: ''!
createRadialGradient: colorRamp center: aCenter radius: aRadius focalPoint: fp
	^AthensCairoGradientPaint	
		radialBetween: fp
		extending: 0
		and: aCenter
		extending: aRadius
		withColorRamp: colorRamp! !

!AthensCairoSurface methodsFor: 'converting' stamp: ''!
asAthensPaintOn: aCanvas
	^ AthensCairoPatternSurfacePaint createForSurface: self.! !

!AthensCairoSurface methodsFor: 'drawing' stamp: ''!
drawDuring: aBlock

	"You may draw on receiver only when inside a block and only using provided canvas object.
	This ensures releasing system resources used after finishing drawing"

	self checkSession.
	
	currentCanvas ifNotNil: [ self attemptToRecurseDrawing ].
	[
		currentCanvas := context.
		self privSetDefaults.
		aBlock value: currentCanvas.
		self flush.
	] ensure: [
		currentCanvas := nil.
	].! !

!AthensCairoSurface methodsFor: 'accessing' stamp: ''!
extent
	^ self width @ self height! !

!AthensCairoSurface methodsFor: 'accessing' stamp: ''!
clear: clearPaint
	currentCanvas pathTransform restoreAfter: [
		currentCanvas pathTransform loadIdentity.
		currentCanvas paintMode restoreAfter: [
			currentCanvas paintMode source.
			currentCanvas 
				setPaint: clearPaint;
				drawShape: (0@0 extent: self extent).
				
        ]].! !

!AthensCairoSurface methodsFor: 'rendering dispatch' stamp: ''!
fillPath: aPath withSolidColor: aColor 

	self loadSolidColor: aColor.
	
	currentCanvas 
		newPath;
		loadPath: aPath;
		fill! !

!AthensCairoSurface methodsFor: 'rendering dispatch' stamp: ''!
fillRectangle: aRectangle withSolidColor: aColor

	self loadSolidColor: aColor.

	currentCanvas
		newPath;
		rectangleX: aRectangle left asFloat
		y: aRectangle top asFloat
		width: aRectangle width asFloat
		height: aRectangle height asFloat;
		fill! !

!AthensCairoSurface methodsFor: 'accessing' stamp: ''!
height
	
	^self privateHeight - 1! !

!AthensCairoSurface methodsFor: 'paints' stamp: ''!
createMeshGradientWithPatches: aListOfMeshPatches
	^ AthensCairoMeshGradientPaint createMeshGradientWithPatches: aListOfMeshPatches! !

!AthensCairoSurface methodsFor: 'private' stamp: ''!
finish
	^ self ffiCall: #( void cairo_surface_finish (self) )! !

!AthensCairoSurface methodsFor: 'testing' stamp: ''!
isSuccess
	^ self status  =	CAIRO_STATUS_SUCCESS! !

!AthensCairoSurface methodsFor: 'private' stamp: ''!
checkSession
	session == Smalltalk session ifFalse: [ 
		self error: 'Attempt to use invalid external resource (left from previous session)' ]! !

!AthensCairoSurface methodsFor: 'accessing' stamp: ''!
clear
	^ self clear: Color transparent! !

!AthensCairoSurface methodsFor: 'rendering dispatch' stamp: ''!
loadSolidColor: aColor
	currentCanvas setSourceR: aColor red g: aColor green b: aColor blue a: aColor alpha; resetDash! !

!AthensCairoSurface methodsFor: 'private' stamp: ''!
privSetDefaults
	"reset matrices"
	currentCanvas pathTransform loadIdentity.
	currentCanvas paintTransform loadIdentity.
	currentCanvas paintMode over.! !

!AthensCairoSurface methodsFor: 'text support' stamp: ''!
getFreetypeFontRendererFor: aFreetypeFont 
	"answer the same instance, just reset it's font and advance"
	
	^ ftFontRenderer font: aFreetypeFont; advance: 0@0; yourself! !

!AthensCairoSurface methodsFor: 'initialization' stamp: ''!
resourceData
	^ { handle value. id. context handle }! !

!AthensCairoSurface methodsFor: 'caching' stamp: ''!
flushCacheAt: anObject

	"Flush (delete) any cached value(s) identified by given object, anObject.
	Do nothing if there's no cached values stored for given object.
	Answer receiver.

	A surface using identity comparison for object identifiers.
	"
	CairoBackendCache soleInstance removeAt: anObject! !

!AthensCairoSurface methodsFor: 'converting' stamp: ''!
asForm
	"create a form and copy an image data there"
	self checkSession.
	self flush.
 	^ (AthensCairoSurfaceForm extent: (self width@(self height)) depth: 32 bits: id)
		surface: self;
		yourself! !

!AthensCairoSurface methodsFor: 'accessing' stamp: ''!
width
	^ self ffiCall: #(
		int cairo_image_surface_get_width ( self ) )! !

!AthensCairoSurface methodsFor: 'paints' stamp: ''!
createSolidColorPaint: aColor 

	^ AthensCairoSolidPaint new color: aColor! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
primFindSurface: id handle: handlePtr
		"Find the surface with the given ID, and, optionally,
		the given set of surface functions. The registered handle
		is returned in surfaceHandle. Return true if successful
		(e.g., the surface has been found), false otherwise."

	<primitive: 'primitiveFindSurface' module: 'SurfacePlugin'>! !

!AthensCairoSurface class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''!
createUnlockSurfaceFn
	"
		int unlockSurface(sqIntptr_t handle, int x, int y, int w, int h);
		Unlock the bits of a (possibly modified) surface after BitBlt completed.
		The return value is ignored.

		The arguments provided specify the dirty region of the surface. If the
		surface is unmodified all arguments are set to zero.

	"
	^ nil
	"^ FFICallback 
		signature: #(int (void *handle, int x, int y, int w, int h))
		block: [ :handle :x :y :w :h | 0 ""Do nothing"" ]"! !

!AthensCairoSurface class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoSurface class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''!
get_width: surface
	^ self ffiCall: #(int cairo_image_surface_get_width (void *surface))! !

!AthensCairoSurface class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
unregisterSurfaceWithId: anAthensCairoSurfaceId

	self primUnregisterSurface: anAthensCairoSurfaceId! !

!AthensCairoSurface class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoSurface class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
primWidth: aWidth height: aHeight
	^ self ffiCall: #( AthensCairoSurface cairo_image_surface_create (
						CAIRO_FORMAT_ARGB32,
						int aWidth,
						int aHeight) )! !

!AthensCairoSurface class methodsFor: 'finalize resources' stamp: ''!
finalizeResourceData: data
	"Finalize external state"

	| handle id contextHandle |
	handle := data first.
	id := data second.
	contextHandle := data third.
	
	(self findSurface: id) = handle value ifFalse: [ 
		"self error: 'surface is not registered with surface plugin'."
		^ self ].
	
	self unregisterSurfaceWithId: id.
	self destroyContextHandle: contextHandle value. 
	self destroySurfaceHandle: handle value! !

!AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''!
createLockSurfaceFn
	"
	int lockSurface(sqIntptr_t handle, int *pitch, int x, int y, int w, int h);
		Lock the bits of the surface.
		Return a pointer to the actual surface bits, or NULL on failure.
		If successful, store the pitch of the surface (e.g., the bytes
		per scan line).

		For equal source/dest handles only one locking operation is performed.
		This is to prevent locking of overlapping areas which does not work with
		certain APIs (e.g., DirectDraw prevents locking of overlapping areas). 
		A special case for non-overlapping but equal source/dest handle would 
		be possible but we would have to transfer this information over to 
		unlockSurfaces somehow (currently, only one unlock operation is 
		performed for equal source and dest handles). Also, this would require
		a change in the notion of ioLockSurface() which is right now interpreted
		as a hint and not as a requirement to lock only the specific portion of
		the surface.

		The arguments in ioLockSurface() provide the implementation with
		an explicit hint what area is affected. It can be very useful to
		know the max. affected area beforehand if getting the bits requires expensive
		copy operations (e.g., like a roundtrip to the X server or a glReadPixel op).
		However, the returned pointer *MUST* point to the virtual origin of the surface
		and not to the beginning of the rectangle. The promise made by BitBlt
		is to never access data outside the given rectangle (aligned to 4byte boundaries!!)
		so it is okay to return a pointer to the virtual origin that is actually outside
		the valid memory area.

		The area provided in ioLockSurface() is already clipped (e.g., it will always
		be inside the source and dest boundingBox) but it is not aligned to word boundaries
		yet. It is up to the support code to compute accurate alignment if necessary.
	"

	^ FFICallback 
		signature: #(void * (void *handle, int *pitch, int x, int y, int w, int h))
		block: [ :handle :pitch :x :y :w :h |
			pitch signedLongAt: 1 put: (self get_stride: handle).
			self get_data: handle ]! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
primUnregisterSurface: aCairoSurfaceId
"
	ioUnregisterSurface:
	Unregister the surface with the given id.
	Returns true if successful, false otherwise. 

"
	<primitive: 'primitiveUnregisterSurface' module: 'SurfacePlugin'>! !

!AthensCairoSurface class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
primRegisterSurface: aCairoSurfaceHandle dispatch: sqSurfaceDispatchPtr surfaceId: idHolder
"
	Register a new surface with the given handle and
	the set of surface functions. The new ID is returned
	in surfaceID. Returns true if successful, false 
	otherwise."

	<primitive: 'primitiveRegisterSurface' module: 'SurfacePlugin'>
	^false! !

!AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''!
get_stride: surface
	^ self ffiCall: #(int cairo_image_surface_get_stride (void *surface))! !

!AthensCairoSurface class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoSurface class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoSurface class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoSurface class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''!
get_height: surface
	^ self ffiCall: #(int cairo_image_surface_get_height (void *surface))! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
primImage: aFormat width: aWidth height: aHeight
	^ self ffiCall: #(AthensCairoSurface cairo_image_surface_create (int aFormat,
                                                         int aWidth,
                                                         int aHeight) )! !

!AthensCairoSurface class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoSurface class methodsFor: 'session management' stamp: ''!
initializeForNewSession
	session := Smalltalk session.
	"create a dispatch structure"
	dispatchStruct := SQSurfaceDispatch externalNew.
	dispatchStruct 
		getSurfaceFormatFn: self createGetSurfaceFormatFn;
		lockSurfaceFn: self createLockSurfaceFn;
		unlockSurfaceFn: self createUnlockSurfaceFn;
		showSurfaceFn: self createShowSurfaceFn.
	"assign the pointer"
	dispatch := dispatchStruct getHandle.! !

!AthensCairoSurface class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoSurface class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoSurface class methodsFor: 'instance creation' stamp: ''!
extent: anExtent format: aFormat
	^ ( self primImage: aFormat width: anExtent x height: anExtent y + 1) initialize! !

!AthensCairoSurface class methodsFor: 'instance creation' stamp: ''!
fromForm: aForm
	| form surface newBits |
	form := aForm unhibernate; asFormOfDepth: 32.
	surface := self extent: aForm extent.
	"we should convert form bits with premultiplied alpha"
	newBits := form bits collect: [:pixel |
		| alpha r g b|
		alpha := (pixel >> 24) / 255.
		r := ( (pixel bitAnd: 255) * alpha ) asInteger.
		g := ( (pixel >>8 bitAnd: 255) * alpha ) asInteger.
		b := ( (pixel >>16 bitAnd: 255) * alpha ) asInteger.
		(pixel bitAnd: 16rFF000000) + (b<<16) + (g<<8) + r
		].
	LibC memCopy: newBits to: surface getDataPtr getHandle size: (form width * form height *4).
	surface markDirty.
	^ surface.! !

!AthensCairoSurface class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoSurface class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoSurface class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
registerSurface: anAthensCairoSurface
	"register the cairo surface with surface plugin,
	so, it can be used directly by bitblt operations.
	Answer an id and unique session object"
	| id address |

	self checkSession.

	id := ByteArray new: 4.
	address := anAthensCairoSurface getHandle.
	(self primRegisterSurface: address dispatch: dispatch surfaceId: id)
		ifFalse: [ self error: 'Unable to register surface with SurfacePlugin' ].
	id := id signedLongAt: 1.
	
	^ id! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
destroySurfaceHandle: handle
	^ self ffiCall: #( void cairo_surface_destroy ( ulong handle ) )! !

!AthensCairoSurface class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
destroyContextHandle: aHandle
	^ self ffiCall: #( 	void cairo_destroy (size_t aHandle) )! !

!AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''!
createGetSurfaceFormatFn
	"
		int getSurfaceFormat(sqIntptr_t handle, int* width, int* height, int* depth, int* isMSB);

		Return general information about the OS drawing surface.
		Return true if successful, false otherwise.

		The returned values describe the basic properties such as
		width, height, depth and LSB vs. MSB pixels.
	"
	^ FFICallback 
		signature: #(int (void *handle, int* width, int* height, int* depth, int* isMSB))
		block: [ :handle :width :height :depth :isMSB |
			[width signedLongAt: 1 put: (self get_width: handle).
			 height signedLongAt: 1 put: (self get_height: handle).
			 depth signedLongAt: 1 put: 32.
			 isMSB signedLongAt: 1 put: 0. 
			 1 "Everything ok"] 
			on: Error do: [ :e | 0 "Error happened" ]]! !

!AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''!
get_data: surface
	^ self ffiCall: #(void *cairo_image_surface_get_data (void *surface))! !

!AthensCairoSurface class methodsFor: 'instance creation' stamp: ''!
width: aWidth height: aHeight
	^ (self primWidth: aWidth height: aHeight+1) initialize! !

!AthensCairoSurface class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoSurface class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoSurface class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoSurface class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
primImageFromData: data width: width height: height pitch: stride
	
	"CAIRO_FORMAT_ARGB32 -> 0"
	
	^ self ffiCall: #(AthensCairoSurface cairo_image_surface_create_for_data (
		void *data,
		0,
		int width,
		int height,
		int stride) )! !

!AthensCairoSurface class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
findSurface: surfaceId
	| buf |
	buf := ByteArray new: 4.  "sizeof(int)"
	
	
	(self primFindSurface: surfaceId handle: buf) ifTrue: [
		^ buf unsignedLongAt: 1
		].
	
	^ nil.! !

!AthensCairoSurface class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoSurface class methodsFor: 'instance creation' stamp: ''!
extent: anExtent
	^ self extent: anExtent format: CAIRO_FORMAT_ARGB32! !

!AthensCairoSurface class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoSurface class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''!
createShowSurfaceFn
	"
	int showSurface(sqIntptr_t handle, int x, int y, int w, int h);
		Display the contents of the surface on the actual screen.

		If ioShowSurface() is called the surface in question represents a DisplayScreen.

	"
	^ nil
	"^ FFICallback 
		signature: #(int (void *handle, int x, int y, int w, int h))
		block: [ :handle :x :y :w :h | 0 ""Do nothing"" ]"! !

!AthensCairoSurface class methodsFor: 'private' stamp: ''!
primCreateFromFile: aFileName
	^ self ffiCall: #(AthensCairoSurface cairo_image_surface_create_from_png (char* aFileName))! !

!AthensCairoSurface class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator 
	"use handle ivar to hold my instance (cairo_surface_t)"
	^ FFIExternalObjectType objectClass: self! !

!AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''!
dispatchStruct
	self checkSession.
	^ dispatchStruct! !

!AthensCairoSurface class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoSurface class methodsFor: 'instance creation' stamp: ''!
createFromFile: aFileName ifFailed: aBlock
	"Right now, this protocol is Cairo backend only. "
	
 	| surface cstring |
	cstring := aFileName , (Character value: 0) asString.
	surface :=  self primCreateFromFile: cstring.
	surface isSuccess not
		ifTrue: [ 
			self destroySurfaceHandle: surface handle asInteger.
			^ aBlock cull: surface status ]
		ifFalse: [ surface initialize ].
	^ surface .! !

!AthensCairoSurface class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoSurface class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoSurface class methodsFor: 'session management' stamp: ''!
checkSession
	session == Smalltalk session 
		ifFalse: [ self initializeForNewSession ]! !

!AthensCairoSurface class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCairoSurfaceExamples commentStamp: ''!
I show examples of rendering in a AthensCairoSurface.

My class-side has example methods, and I also inherit many examples from my superclass.!
!AthensCairoSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleInterop

"
self exampleInterop

Test the interoperability with bitblt.
A cairo image surface bits are exposed to bitblt operations via surface plugin.
"
	| surf |
	
	surf := self newSurface: 100@100.

	surf asForm getCanvas fillRectangle: (0@0 corner: 50@50) color: Color red.
	surf markDirty. 
	
	surf drawDuring: [:can |
		can pathTransform loadIdentity.
		can pathTransform translateX: 30 Y: 30.
		can pathTransform rotateByDegrees: 35.
		can setPaint: (Color red).
		
		can setShape: (-20@ -20 corner: 20@ 20).
		2 timesRepeat: [ can draw. can setPaint: (Color green alpha:0.5)]
	].

	surf asMorph openInWindow! !

!AthensCairoSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleAnimatedTigerInMorphicWindow
	^ AthensTigerWindow openAnimated! !

!AthensCairoSurfaceExamples class methodsFor: 'utilities' stamp: ''!
exampleExportTigerOn: anAthensSurface
	(AthensTiger on: anAthensSurface) 
		position: 300 @ -200;
		draw.
	anAthensSurface finish. "Required to end the file"! !

!AthensCairoSurfaceExamples class methodsFor: 'utilities' stamp: ''!
newSurface: extent
	
	^ AthensCairoSurface extent: extent! !

!AthensCairoSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleFlake
	AthensFlakeDemo open! !

!AthensCairoSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleDrawTextPath
 
	| surf  font |
	font := LogicalFont familyName: 'Source Sans Pro' pointSize: 40.

	surf := self newSurface: 500@100.
	
	surf drawDuring: [:can |
		| f |
		"clear background"
		surf clear: Color white.
		
		f := CairoScaledFont fromFreetypeFont: font realFont. 
		"Set text position"
		can pathTransform translateX: 10 Y: (font getPreciseAscent)+10.
		"new path to draw the string"
		can newPath.
		
		f lock.
		"set font properties"
		can 
			setPathMatrix;
			setScaledFont: f.
		(Color red asAthensPaintOn: can)
			loadOnCairoCanvas: can.
		"creates a path text"
		can textPath: 'Text with border :V'.
		"It fills and preserve the last path"
		can fillPreserve.
		
		(can setStrokePaint: Color black)
			width: 2;
			dashes: #(10 1) offset: 0;
			"in order to use the path of cairo"
			prepareForDrawingOn: can.
		can stroke.
		f unlock.
	].
	
	surf asMorph openInWindow! !

!AthensCairoSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleExportTigerToSVG

	| surface |
	surface := AthensCairoSVGSurface
		extent: 500 asPoint
		fileName: Time microsecondClockValue asString, '.svg'.

	self exampleExportTigerOn: surface.! !

!AthensCairoSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleExportTigerToPDF

	| surface |
	surface := AthensCairoPDFSurface
		extent: 500 asPoint
		fileName: Time microsecondClockValue asString, '.pdf'.

	self exampleExportTigerOn: surface.! !

!AthensCairoSurfaceForm commentStamp: ''!
I'm a form that keeps a surface with the only purpose of prevent GC when is still being used to copy data.

I'm used at AthensCairoSurface>>#asForm!
!AthensCairoSurfaceForm methodsFor: 'accessing' stamp: ''!
surface
	^ surface! !

!AthensCairoSurfaceForm methodsFor: 'accessing' stamp: ''!
surface: anObject
	surface := anObject! !

!AthensCairoText commentStamp: ''!
do not use this class. this is subject of change or removal!
!AthensCairoText methodsFor: 'font description' stamp: ''!
fontSize

	^ fontSize! !

!AthensCairoText methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	self loadOn: aCanvas.
	self showOn: aCanvas! !

!AthensCairoText methodsFor: 'drawing' stamp: ''!
showOn: aCanvas
	| utf8String |
	aCanvas setPathMatrix.
	utf8String := self convertTextUtf8: self asString.
	self primShowText: utf8String on: aCanvas! !

!AthensCairoText methodsFor: 'private' stamp: ''!
primShowText: aString on: aCanvas
	^ self ffiCall: #(void cairo_show_text (
			cairo_t aCanvas,
			char * aString) )! !

!AthensCairoText methodsFor: 'private' stamp: ''!
primSelectFont: aFontFamily
		slant: aFontSlant
		weight: aFontWeight 
		on: aCanvas
	^ self ffiCall: #(void cairo_select_font_face (
			cairo_t aCanvas,
   			char * aFontFamily,
      		cairo_font_slant_t aFontSlant,
        	cairo_font_weight_t aFontWeight) )! !

!AthensCairoText methodsFor: 'private' stamp: ''!
slantFrom: aSymbol
	^ aSymbol caseOf: {
		[#normal]->[ CAIRO_FONT_SLANT_NORMAL ].
 		[#italic]->[   CAIRO_FONT_SLANT_ITALIC ].
		[#oblique]->[ CAIRO_FONT_SLANT_OBLIQUE ] }! !

!AthensCairoText methodsFor: 'private' stamp: ''!
weightFrom: aSymbol
	^ aSymbol caseOf: {
		[#normal]->[ CAIRO_FONT_WEIGHT_NORMAL  ].
 		[#bold]->[    CAIRO_FONT_WEIGHT_BOLD ] }! !

!AthensCairoText methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoText methodsFor: 'private' stamp: ''!
convertTextUtf8: aString
	| encoder buffer |
	buffer := ByteArray new: (aString size + 2) * 4.
	encoder := ZnUTF8Encoder new.
	encoder
		next: aString size
		putAll: aString
		startingAt: 1
		toStream: buffer writeStream.
	^ buffer! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
fontSlant

	^ fontSlant! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
readFrom: aFontDescription
	self fontFamily: aFontDescription fontFamily.
	self fontSlant: aFontDescription fontSlant.
	self fontWeight:  aFontDescription fontWeight.
	self fontSize: aFontDescription fontSize.! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
fontSlant: anObject
	anObject isSymbol
		ifTrue:[ fontSlant := self slantFrom: anObject ]
		ifFalse:[ fontSlant := anObject ]! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
fontWeight: anObject
	anObject isSymbol
		ifTrue:[ fontWeight := self weightFrom: anObject ]
		ifFalse:[ fontWeight :=  anObject ]! !

!AthensCairoText methodsFor: 'drawing' stamp: ''!
loadOn: aCanvas
	
	fontFamily ifNotNil:[
		self 
			primSelectFont:  fontFamily
			slant:  fontSlant
			weight:  fontWeight 
			on: aCanvas ].
	
	fontSize ifNotNil: [
		self primSetFontSize: (CairoScaledFont pointsToPixels: fontSize) on: aCanvas ]! !

!AthensCairoText methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	self beNormal; beSlantNormal.
	 fontSize := 10.! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
beSlantNormal
	self fontSlant: CAIRO_FONT_SLANT_NORMAL! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
fontFamily: anObject
	"CSS2 generic family names: serif, sans-serif, cursive, fantasy, monospace"
	fontFamily := anObject! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
beNormal
	self fontWeight: CAIRO_FONT_WEIGHT_NORMAL! !

!AthensCairoText methodsFor: 'accessing' stamp: ''!
text: anObject

	text := anObject! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
beBold
	self fontWeight: CAIRO_FONT_WEIGHT_BOLD! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
fontWeight

	^ fontWeight! !

!AthensCairoText methodsFor: 'accessing' stamp: ''!
asString
	^ text asString! !

!AthensCairoText methodsFor: 'private' stamp: ''!
primSetFontSize: aFontSize on: aCanvas
	^ self ffiCall: #(void cairo_set_font_size (
			cairo_t aCanvas,
			double aFontSize) )! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
fontFamily

	^ fontFamily! !

!AthensCairoText methodsFor: 'font description' stamp: ''!
fontSize: anObject

	fontSize := anObject! !

!AthensCairoText methodsFor: 'accessing' stamp: ''!
text

	^ text! !

!AthensCairoText class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoText class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoText class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoText class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoText class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoText class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoText class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoText class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoText class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoText class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoText class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoText class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoText class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoText class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoText class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoText class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoText class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoText class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoText class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoText class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoText class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoText class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoText class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoText class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoText class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoText class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoText class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoText class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoText class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoText class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCairoTransform commentStamp: ''!
i implement AthensTransform protocol using cairo-specific functions.!
!AthensCairoTransform methodsFor: 'primitives' stamp: ''!
restore
	^ self ffiCall: #(void cairo_restore(AthensCairoCanvas canvas))! !

!AthensCairoTransform methodsFor: 'transformations' stamp: ''!
rotateByDegrees: angle

	^ self rotateByRadians: angle degreesToRadians! !

!AthensCairoTransform methodsFor: 'primitives' stamp: ''!
primTransformX: x Y: y
	^ self ffiCall: #(
		void cairo_user_to_device (AthensCairoCanvas canvas,
                                                         NBFloatPtr x,
                                                         NBFloatPtr y) )! !

!AthensCairoTransform methodsFor: 'primitives' stamp: ''!
rotateByRadians: angle

	^ self primRotateByRadians: angle asFloat! !

!AthensCairoTransform methodsFor: 'primitives' stamp: ''!
save
	^ self ffiCall: #(void cairo_save (AthensCairoCanvas canvas))! !

!AthensCairoTransform methodsFor: 'transformations' stamp: ''!
scaleBy: aScalarOrPoint
	| double |
	aScalarOrPoint isPoint
		ifTrue:[
			self
				scaleX: aScalarOrPoint x asFloat
				Y: aScalarOrPoint y asFloat ]
		ifFalse:[ 
			double := aScalarOrPoint asFloat.
			self scaleX: double Y: double ].! !

!AthensCairoTransform methodsFor: 'primitives' stamp: ''!
primRotateByRadians: angle
	^ self ffiCall: #(
		void cairo_rotate (AthensCairoCanvas canvas,
                                                         double angle))! !

!AthensCairoTransform methodsFor: 'primitives' stamp: ''!
translateX: px Y: py

	^ self primTranslateX: px asFloat Y: py asFloat! !

!AthensCairoTransform methodsFor: 'initializing' stamp: ''!
canvas: aCairoCanvas
	canvas := aCairoCanvas! !

!AthensCairoTransform methodsFor: 'primitives' stamp: ''!
primScaleX: fx Y: fy
	^ self ffiCall: #(
		void cairo_scale (AthensCairoCanvas canvas,
                                                         double fx,
                                                         double fy))! !

!AthensCairoTransform methodsFor: 'transformations' stamp: ''!
moveTo: aPoint
	self moveToX: aPoint x asFloat Y: aPoint y asFloat! !

!AthensCairoTransform methodsFor: 'primitives' stamp: ''!
primTranslateX: px Y: py
	
	^ self ffiCall: #(
		void cairo_translate (AthensCairoCanvas canvas,
                                                         double px,
                                                         double py))! !

!AthensCairoTransform methodsFor: 'transformations' stamp: ''!
translateBy: aPoint
	self translateX: aPoint x Y: aPoint y! !

!AthensCairoTransform methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!AthensCairoTransform methodsFor: 'primitives' stamp: ''!
loadIdentity
	^ self ffiCall: #(
		void cairo_identity_matrix (AthensCairoCanvas canvas) )! !

!AthensCairoTransform methodsFor: 'vector - transform' stamp: ''!
transform: aPoint
	| x y |
	x := ByteArray new: 8.
	y := ByteArray new: 8.
	x doubleAt: 1 put: aPoint x.
	y doubleAt: 1 put: aPoint y.
	self primTransformX: x Y: y.
	^ (x doubleAt: 1) @ (y doubleAt: 1)! !

!AthensCairoTransform methodsFor: 'transformation' stamp: ''!
scaleX: fx Y: fy
	
	^ self primScaleX: fx asFloat Y: fy asFloat! !

!AthensCairoTransform methodsFor: 'primitives' stamp: ''!
moveToX: px Y: py
	^ self ffiCall: #(
		void cairo_move_to (AthensCairoCanvas canvas,
                                                         double px,
                                                         double py))! !

!AthensCairoTransform methodsFor: 'transformations' stamp: ''!
restoreAfter: aBlock
	self save.
	aBlock ensure:  [ self restore ].! !

!AthensCairoTransform class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!AthensCairoTransform class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!AthensCairoTransform class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!AthensCairoTransform class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!AthensCairoTransform class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!AthensCairoTransform class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!AthensCairoTransform class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!AthensCairoTransform class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!AthensCairoTransform class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoTransform class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!AthensCairoTransform class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!AthensCairoTransform class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!AthensCairoTransform class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!AthensCairoTransform class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!AthensCairoTransform class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!AthensCairoTransform class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!AthensCairoTransform class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!AthensCairoTransform class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!AthensCairoTransform class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!AthensCairoTransform class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!AthensCairoTransform class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!AthensCairoTransform class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!AthensCairoTransform class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!AthensCairoTransform class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!AthensCairoTransform class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!AthensCairoTransform class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!AthensCairoTransform class methodsFor: 'instance creation' stamp: ''!
for: cairoCanvas
	^ self new canvas: cairoCanvas! !

!AthensCairoTransform class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!AthensCairoTransform class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!AthensCairoTransform class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!AthensCairoTransform class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!AthensCanvas commentStamp: ''!
`AthensCanvas` instance is a central object which is used to perform drawings on a surface.
Please note, that Athens does not allow you to instantiate canvas directly, instead you obtain a ready to use instance as an argument in `#drawDuring:` message, sent to athens surface:

```
surface drawDuring: [:canvas | .... ]
```

Using canvas outside a `#drawDuring:` method is highly discouraged. Doing so may lead to unpredicted behavior/data corruption/image crash.!
!AthensCanvas methodsFor: 'caching' stamp: ''!
cacheAt: anObject ifAbsentPut: aBlock

	^ surface cacheAt: anObject ifAbsentPut: aBlock! !

!AthensCanvas methodsFor: 'transformation matrices' stamp: ''!
pathTransform
	"Answer the path transformation matrix controller.
	The answered object should conform to AthensTransform public protocol."
	^ surface pathTransform! !

!AthensCanvas methodsFor: 'accessing' stamp: ''!
setShape: anObject
	"Set the current shape of receiver"
	shape := anObject asAthensShapeOn: self! !

!AthensCanvas methodsFor: 'paint' stamp: ''!
setPaint: aPaint
	"set the current paint of receiver"
	paint = aPaint ifTrue:[ ^ paint ].
	paint := self paintCache at: aPaint ifAbsentPut: [ aPaint asAthensPaintOn: self ].
	^ paint! !

!AthensCanvas methodsFor: 'clipping' stamp: ''!
clipBy: aRectangle during: aBlock	
	"Set a clipping rectangle during drawing operations performed in aBlock.
	Note that the clipping rectangle is intersected with the currently active clipping rectangle"
	
	 ^surface clipBy: aRectangle during: aBlock! !

!AthensCanvas methodsFor: 'transformation matrices' stamp: ''!
paintTransform
	"Answer the paint transformation matrix controller.
	The answered object should conform to AthensTransform public protocol."

	^ surface paintTransform! !

!AthensCanvas methodsFor: '*Athens-Morphic' stamp: ''!
morphicDrawString: string in: rect font: aFont color: aColor
	self
		clipBy: rect
		during: [ 
			self pathTransform
				restoreAfter: [ 
					self pathTransform translateX: rect left Y: rect top.
					self setFont: aFont.
					self pathTransform translateX: 0 Y: aFont getPreciseAscent.
					self
						setPaint: aColor;
						drawString: string ] ]! !

!AthensCanvas methodsFor: 'drawing text' stamp: ''!
drawString: aString from: start to: end
	"Draw a portion of string using currently selected font.
	Answer a total advance of rendered portion"
	^ fontRenderer renderCharacters: aString from: start to: end! !

!AthensCanvas methodsFor: 'drawing' stamp: ''!
draw: anObject
	"A generic dispatch method to draw anObject on receiver. 
	the object should understand #drawOnAthensCanvas: message"
	^ anObject drawOnAthensCanvas: self! !

!AthensCanvas methodsFor: '*Athens-Morphic' stamp: ''!
morphicDrawString: string at: position font: aFont color: aColor

	self pathTransform restoreAfter: [
		self pathTransform translateX: position x Y: position y + aFont getPreciseAscent.
		self 
			setFont: aFont;
			setPaint: aColor;
			drawString: string.
	]! !

!AthensCanvas methodsFor: 'accessing' stamp: ''!
surface
	"Answer an Athens surface, to which receiver is bound to"
	^ surface! !

!AthensCanvas methodsFor: 'paths' stamp: ''!
createRectanglePath: aRectangle 
	^ surface createRectanglePath: aRectangle! !

!AthensCanvas methodsFor: 'masking' stamp: ''!
enableMask
	^ surface enableMask! !

!AthensCanvas methodsFor: 'accessing' stamp: ''!
paint
	^ paint! !

!AthensCanvas methodsFor: 'masking' stamp: ''!
disableMask
	^ surface disableMask! !

!AthensCanvas methodsFor: 'initialization' stamp: ''!
initializeWithSurface: anAthensSurface	
	surface := anAthensSurface! !

!AthensCanvas methodsFor: '*Athens-Morphic' stamp: ''!
fullDrawMorph: aMorph

"Hook method for potential other canvases. In the core, this method looks supefluous but PostscriptCanvases and other canvases can specialized it for Morph rendering. Therefore it should not be merged with fullDraw:."

	aMorph fullDrawOnAthensCanvas: self! !

!AthensCanvas methodsFor: 'clipping' stamp: ''!
isVisible: aRectangle 
	"Check if rectangle are not fully clipped by current clipping coordinates"
	
	^ true! !

!AthensCanvas methodsFor: 'drawing' stamp: ''!
drawShape: anObject
	"A convenience method, which sets the current shape to anObject and then fills it
	with currently selected paint" 
	self 
		setShape: anObject;
		draw! !

!AthensCanvas methodsFor: '*Athens-Morphic' stamp: ''!
asCanvasWrapper

	^AthensCanvasWrapper on: self! !

!AthensCanvas methodsFor: 'accessing' stamp: ''!
paintMode
	"Answer the current paint mode controller.
	The answered object should conform to AthensPaintMode public protocol."

	^ paintMode! !

!AthensCanvas methodsFor: 'paths' stamp: ''!
createPath: aPathCreatingBlock
	"Create new path. A path creating block should be a monadic block,
	which will get a path builder instance as argument. See AthensPathBuilder
	for available protocol.
	The resulting path object can be later used for drawing.
	" 
	^ surface createPath: aPathCreatingBlock! !

!AthensCanvas methodsFor: 'paint' stamp: ''!
setStrokePaint: aPaint
	"use paint as stroke paint, note conversion to #asStrokePaintOn:"
	paint := (aPaint asAthensPaintOn: self) asStrokePaintOn: self.
	^ paint! !

!AthensCanvas methodsFor: 'paint' stamp: ''!
paintCache 

	^ paintCache ifNil: [ 
		paintCache := LRUCache new maximumWeight: 100 ].! !

!AthensCanvas methodsFor: 'drawing text' stamp: ''!
drawString: aString
	"Draw a string using currently selected font.
	Answer a total advance of rendered string "
	^ fontRenderer renderCharacters: aString from: 1 to: aString size! !

!AthensCanvas methodsFor: 'drawing' stamp: ''!
draw
	"Fill the currently selected shape with currently selected paint"
	
	^ shape paintFillsUsing: paint on: self! !

!AthensCanvas methodsFor: 'caching' stamp: ''!
flushCacheAt: anObject
	"Flush (delete) any cached value(s) identified by given object, anObject.
	A surface using identity comparison for object identifiers.

	Answer receiver.
	"

	surface flushCacheAt: anObject! !

!AthensCanvas methodsFor: 'drawing text' stamp: ''!
setFont: aFont
	"Set the current font of receiver. Font object should answer a glyph renderer instance,
	compatible with glyph renderer protocol" 
	^ fontRenderer := aFont glyphRendererOn: surface.! !

!AthensCanvas class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'An AthensCanvas are created with on:'! !

!AthensCanvas class methodsFor: 'private' stamp: ''!
on: aSurface
	^ self basicNew initializeWithSurface: aSurface! !

!AthensCanvasWrapper commentStamp: ''!
I am a wrapper for a (Form-)Canvas that implements the Canvas API on top of an AthensCanvas.!
!AthensCanvasWrapper methodsFor: 'canvas drawing - rectangles' stamp: ''!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
	self fillRectangle: r fillStyle: fillColor.
	topLeftColor = bottomRightColor
		ifTrue: [ self frameRectangle: r width: borderWidth color: bottomRightColor ]! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - rectangles' stamp: ''!
frameRectangle: aRectangle width: width colors: colors dashes: dashes
	| stroke |
	stroke := self canvas setStrokePaint: colors first.
	stroke width: width.
	stroke dashes: dashes offset: 0.
	self canvas drawShape: aRectangle.
	colors allButFirst
		ifNotEmpty: [ :e | 
			stroke fillPaint: e first.
			stroke dashes: dashes reverse offset: dashes first.
			self canvas drawShape: aRectangle ]! !

!AthensCanvasWrapper methodsFor: 'accessing' stamp: ''!
allocateForm: extentPoint
	^ Form extent: extentPoint depth:32! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - general' stamp: ''!
fullDraw: anObject
	^anObject fullDrawOn: self! !

!AthensCanvasWrapper methodsFor: 'formcanvas copying' stamp: ''!
rubParagraph: para bounds: bounds color: c
	self paragraph: para bounds: bounds color: c! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - general' stamp: ''!
draw: anObject
	^anObject drawOn: self! !

!AthensCanvasWrapper methodsFor: 'canvas accessing' stamp: ''!
depth
	^ 32! !

!AthensCanvasWrapper methodsFor: 'accessing' stamp: ''!
form
	^ self canvas surface asForm! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - support' stamp: ''!
translateBy: offset clippingTo: aRect during: aBlock
	self
		canvasClipBy: aRect
		during: [ 
			self canvas pathTransform
				restoreAfter: [ 
					self canvas pathTransform translateBy: offset.
					aBlock value: self ] ]! !

!AthensCanvasWrapper methodsFor: 'private - clip transform' stamp: ''!
clipWrapperAndAthensTransformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
"the clipTransform methods are just trial and error attemps on getting this right"
	| rect |
	rect := aDisplayTransform globalBoundsToLocal: aClipRect.
	self
		clipBy: rect
		during: [ :c | 
			c canvas pathTransform
				restoreAfter: [ 
					"c canvas morphicClipBy: rect during: [ "
					c canvas pathTransform translateBy: aDisplayTransform offset negated.
					c canvas pathTransform rotateByRadians: aDisplayTransform angle negated.
					c  canvas pathTransform scaleBy: aDisplayTransform scale.
					aBlock value: self ] ]	"]"! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - rectangles' stamp: ''!
frameAndFillRectangle: aRectangle fillColor: aFillColor borderWidth: aBorderWidth borderColor: aBorderColor
	self
		canvasClipBy: self clipRect
		during: [ 
			self canvas setPaint: aFillColor.
			self canvas drawShape: aRectangle.
			(self canvas setStrokePaint: aBorderColor) width: aBorderWidth.
			self canvas drawShape: aRectangle ]! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - ovals' stamp: ''!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: aBorderWidth borderColor: aBorderColor
	self canvas setPaint: aFillStyle.
	self canvas pathTransform
		restoreAfter: [ 
			| path t |
			path := self createClosedEllipsePathIn: aRectangle.
			t := self canvas pathTransform.
			t translateBy: aRectangle origin.
			t scaleBy: 1 @ (aRectangle height / aRectangle width).
			self canvas setShape: path.
			self canvas draw.
			(self canvas setStrokePaint: aBorderColor) width: aBorderWidth.
			self canvas draw ]! !

!AthensCanvasWrapper methodsFor: 'private' stamp: ''!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"This implementation may be wrong. If you have a bug it might be a good idea to dig a little here."

	self canvas pathTransform
		restoreAfter: [ self canvas pathTransform translateBy: aPoint.
			self canvas setPaint: aForm.
			self canvas drawShape: (0 @ 0 extent: sourceRect extent) ]! !

!AthensCanvasWrapper methodsFor: 'private' stamp: ''!
createClosedPolygonPathFrom: aPointsArray
	^ self canvas
		createPath: [ :builder | 
			aPointsArray ifEmpty: [ builder ].
			builder absolute.
			builder moveTo: aPointsArray first.
			aPointsArray allButFirstDo: [ :p | builder lineTo: p ].
			builder close.
			builder ]! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - general' stamp: ''!
roundCornersOf: aMorph in: bounds during: aBlock
	^ aBlock value! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - rectangles' stamp: ''!
fillRectangle: aRectangle fillStyle: aFillStyle borderStyle: aBorderStyle
	self
		canvasClipBy: self clipRect
		during: [ 
			self canvas setPaint: aFillStyle.
			self canvas drawShape: (aRectangle insetBy: aBorderStyle width).
			self canvas setStrokePaint: aBorderStyle.
			self canvas drawShape: (aRectangle insetBy: aBorderStyle width / 2 asFloat) ]! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - text' stamp: ''!
drawString: s in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc
	^ self
		drawString: s asString
		from: 1
		to: s size
		in: boundsRect
		font: fontOrNil
		color: c
		underline: underline
		underlineColor: uc
		strikethrough: strikethrough
		strikethroughColor: sc! !

!AthensCanvasWrapper methodsFor: 'private' stamp: ''!
createClosedEllipsePathIn: aRectangle
	| radius width |
	aRectangle area > 0
		ifFalse: [ ^ self ].
	width := aRectangle width.
	radius := width / 2.
	^ self canvas
		createPath: [ :builder | 
			builder
				absolute;
				moveTo: width @ radius;
				cwArcTo: 0 @ radius angle: Float pi;
				cwArcTo: width @ radius angle: Float pi ]! !

!AthensCanvasWrapper methodsFor: 'formcanvas copying' stamp: ''!
copyOrigin: aPoint clipRect: aRectangle
	^ self copy
		setOrigin: aPoint
		clipRect: (self clipRect intersect: aRectangle ifNone: [0@0 corner: 0@0])! !

!AthensCanvasWrapper methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	origin := 0 @ 0! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - polygons' stamp: ''!
drawPolygon: vertices fillStyle: aFillStyle borderWidth: aBorderWidth borderColor: aBorderColor
	self drawPolygon: vertices color:  aFillStyle borderWidth:  aBorderWidth borderColor: aBorderColor! !

!AthensCanvasWrapper methodsFor: 'canvas drawing' stamp: ''!
line: pt1 to: pt2 color: c
	self
		line: pt1
		to: pt2
		width: 1
		color: c! !

!AthensCanvasWrapper methodsFor: 'canvas drawing' stamp: ''!
line: pt1 to: pt2 width: w color: c
	| path |
	path := self createClosedPolygonPathFrom: {pt1 . pt2}.
		
	(self canvas setStrokePaint: c) width:w.
	self canvas drawShape: path.! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - rectangles' stamp: ''!
fillRectangle: aRectangle fillStyle: aFillStyle
	self fillRectangle: aRectangle color: aFillStyle! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - rectangles' stamp: ''!
fillRectangle: aRectangle color: aColor
	self canvas setPaint: aColor.
	self canvas drawShape: aRectangle! !

!AthensCanvasWrapper methodsFor: 'private - clip transform' stamp: ''!
canvasClipBy: aClipRect during: aBlock
	| oldRect |
	oldRect := self clipRect.
	currentClipRect := aClipRect.
	[ self canvas clipBy: currentClipRect during:[ aBlock value ]]
		ensure: [ currentClipRect := oldRect ]! !

!AthensCanvasWrapper methodsFor: 'canvas accessing' stamp: ''!
extent
	^ self canvas surface extent! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - support' stamp: ''!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
	self canvas
		transformBy: aDisplayTransform
		withClip: aClipRect
		in: aClipRect
		during: [ :v | aBlock value: self ]! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - text' stamp: ''!
drawString: aString from: firstIndex to: lastIndex in: bounds font: aFontOrNil color: aColor underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc
	| font |
	font := aFontOrNil ifNil: [ TextStyle defaultFont ].
	self canvasClipBy: (bounds intersect: self canvas clipRect) during:[ 
			self canvas pathTransform restoreAfter:[ | advance |
			self canvas pathTransform translateBy: bounds origin.
			self canvas pathTransform translateX: 0 Y: font getPreciseAscent.
			self flag: #pharoTodo. "scaled, so that FT-Plugin and Athens don't mix cached faces"
			self canvas pathTransform scaleBy: 1.0000001 @ 1.0000001.
			self canvas setPaint: aColor.
			self canvas setFont: font.
			advance := self canvas drawString: aString asString from: 1 to: aString size.
			underline ifTrue:[
				self canvas setPaint: uc.
				self canvas drawShape:(0@1 extent: advance x @1).
			]]].! !

!AthensCanvasWrapper methodsFor: 'initialization' stamp: ''!
finish
	self flush! !

!AthensCanvasWrapper methodsFor: 'canvas drawing' stamp: ''!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	|mask|
	mask := stencilForm asFormOfDepth: 32.
	mask mapColor:Color white to: Color transparent.
	mask:= mask asAthensPaintOn: self canvas.
	self canvas pathTransform restoreAfter:[
		self canvas pathTransform translateBy: aPoint.
		self canvas setPaint: aColor.
		self canvas draw.
		mask maskOn: self canvas.
		].! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - rectangles' stamp: ''!
frameRectangle: aRectangle width: aBorderWidth color: aColor
	(self canvas setStrokePaint: aColor) width: aBorderWidth.
	self canvas drawShape: aRectangle! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - general' stamp: ''!
drawMorph: aMorph
	(self isVisible: aMorph fullBounds)
		ifFalse: [ ^ self ].
	self draw: aMorph! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - support' stamp: ''!
clipBy: aRectangle during: aBlock
	self canvasClipBy: aRectangle during: [ aBlock value: self ]! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - rectangles' stamp: ''!
frameRectangle: aRectangle color: aColor
	self frameRectangle: aRectangle width: 1 color: aColor! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - polygons' stamp: ''!
drawPolygon: vertices color: aColor borderWidth: aBorderWidth borderColor: aBorderColor
	| path |
	self canvas pathTransform
		restoreAfter: [ 
			self canvas pathTransform.
			path := self createClosedPolygonPathFrom: vertices ].
	self canvas setPaint: aColor.
	self canvas drawShape: path.
	(self canvas setStrokePaint: aBorderColor) width: aBorderWidth.
	self canvas drawShape: path! !

!AthensCanvasWrapper methodsFor: 'accessing' stamp: ''!
canvas: anAthensCanvas
	athensCanvas := anAthensCanvas! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - text' stamp: ''!
drawString: aString in: bounds font: aFontOrNil color: aColor
	| font |
	font := aFontOrNil ifNil: [ TextStyle defaultFont ].
	self canvasClipBy: (bounds intersect: self canvas clipRect) during:[
			self canvas pathTransform restoreAfter:[ 
			self canvas pathTransform translateBy: bounds origin.
			self canvas pathTransform translateX: 0 Y: font getPreciseAscent.
			self flag: #pharoTodo. "scaled, so that FT-Plugin and Athens don't mix cached faces"
			self canvas pathTransform scaleBy: 1.0000001 @ 1.0000001.
			self canvas setPaint: aColor.
			self canvas setFont: font.
			self canvas drawString: aString from: 1 to: aString size ] ]! !

!AthensCanvasWrapper methodsFor: 'canvas accessing' stamp: ''!
origin
	^ origin! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - images' stamp: ''!
translucentImage: aForm at: aPoint sourceRect: sourceRect
	self canvas paintMode over.
	self imagePaint: aForm at: aPoint sourceRect: sourceRect! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - polygons' stamp: ''!
drawPolygon: vertices fillStyle: aFillStyle
	| path |
	self canvas pathTransform
		restoreAfter: [ 
			self canvas pathTransform.
			path := self createClosedPolygonPathFrom: vertices ].
	self canvas setPaint: aFillStyle.
	self canvas drawShape: path! !

!AthensCanvasWrapper methodsFor: 'private' stamp: ''!
imagePaint: aForm at: aPoint sourceRect: sourceRect
	self canvas pathTransform
		restoreAfter: [ 
			self canvas setPaint: aForm.
			self canvas pathTransform translateBy: aPoint.
			self canvas drawShape: sourceRect]! !

!AthensCanvasWrapper methodsFor: 'private - clip transform' stamp: ''!
clipWrapperTransformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
"the clipTransform methods are just trial and error attemps on getting this right"
	| rect |
	rect := aDisplayTransform globalBoundsToLocal: aClipRect.
	self canvas pathTransform
		restoreAfter: [ 
			self canvas pathTransform translateBy: aDisplayTransform offset negated.
			self canvas pathTransform rotateByRadians: aDisplayTransform angle negated.
			self canvas pathTransform scaleBy: aDisplayTransform scale.
			self clipBy: rect during: [ :c | aBlock value: c ]]! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - images' stamp: ''!
translucentImage: aForm at: aPoint
	self translucentImage: aForm at: aPoint sourceRect: aForm boundingBox! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - support' stamp: ''!
flush
	^ self canvas surface flush.! !

!AthensCanvasWrapper methodsFor: 'canvas converting' stamp: ''!
asShadowDrawingCanvas
	"this may not work, but it 
	doesn't hurt yet and HandMorph relies on this"

	^ (ShadowDrawingCanvas on: self) shadowColor: (Color orange alpha: 0.2)! !

!AthensCanvasWrapper methodsFor: 'private' stamp: ''!
canvas
	^ athensCanvas! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - general' stamp: ''!
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! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - images' stamp: ''!
drawImage: aForm at: aPoint sourceRect: sourceRect
	"Draw the given form."

	^self image: aForm
		at: aPoint
		sourceRect: sourceRect
		rule: Form over! !

!AthensCanvasWrapper methodsFor: 'canvas testing' stamp: ''!
isVisible: aRectangle
	"Return true if the given rectangle is (partially) visible"

	^ self clipRect intersects: aRectangle.! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - general' stamp: ''!
roundCornersOf: aMorph during: aBlock
	^ self roundCornersOf: aMorph in: aMorph bounds during: aBlock! !

!AthensCanvasWrapper methodsFor: 'canvas accessing' stamp: ''!
contentsOfArea: aRectangle into: aForm
	"this may conflict with current pathtransformations, but up to now"
	"it works"
	| bb |
	self flush.
	bb := BitBlt toForm: aForm.
	bb
		sourceForm: self form;
		combinationRule: Form over;
		sourceX: aRectangle left + origin x;
		sourceY: aRectangle top + origin y;
		width: aRectangle width;
		height: aRectangle height;
		copyBits.
	^ aForm! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - ovals' stamp: ''!
fillOval: aRectangle color: aColor borderWidth: aBorderWidth borderColor: aBorderColor
	self
		fillOval: aRectangle
		fillStyle: aColor
		borderWidth: aBorderWidth
		borderColor: aBorderColor! !

!AthensCanvasWrapper methodsFor: 'canvas accessing' stamp: ''!
clipRect
	^ self canvas clipRect! !

!AthensCanvasWrapper methodsFor: 'formcanvas copying' stamp: ''!
copyClipRect: aRectangle
"dont know why this exists, all calls with a different cliprect should go through"
"clipBy:during: and I don't know if this properly works with athens canvases because"
"we can not handle to different clipstates for the same canvas."
	^ self copyOrigin: origin clipRect: aRectangle! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - text' stamp: ''!
drawString: aString in: bounds
	self drawString: aString in: bounds font:nil color: Color black! !

!AthensCanvasWrapper methodsFor: 'private' stamp: ''!
origin: aPoint
	origin := aPoint! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - images' stamp: ''!
paintImage: aForm at: aPoint sourceRect: sourceRect
	self canvas paintMode over.
	self imagePaint: aForm at: aPoint sourceRect: sourceRect! !

!AthensCanvasWrapper methodsFor: 'formcanvas copying' stamp: ''!
setOrigin: aPoint clipRect: aRectangle
	origin := aPoint.
	currentClipRect := aRectangle! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - support' stamp: ''!
translateBy: offset during: aBlock
	^ self copyOrigin: origin + offset clipRect: self clipRect! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - ovals' stamp: ''!
fillOval: aRectangle fillStyle: aFillStyle
	^self fillOval: aRectangle fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - text' stamp: ''!
drawString: aString at: aPoint font: aFontOrNil color: aColor
	self
		drawString: aString
		in: (origin + aPoint extent: self clipRect extent)
		font: aFontOrNil
		color: aColor! !

!AthensCanvasWrapper methodsFor: 'canvas drawing' stamp: ''!
paragraph: aParagraph bounds: aRectangle color: aColor
	aParagraph drawOnAthensCanvas: self canvas bounds: aRectangle color: aColor! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - images' stamp: ''!
paintImage: aForm at: aPoint
	self paintImage: aForm at: aPoint sourceRect: aForm boundingBox! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - images' stamp: ''!
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! !

!AthensCanvasWrapper methodsFor: 'canvas drawing - ovals' stamp: ''!
fillOval: r color: c

	self fillOval: r color: c borderWidth: 0 borderColor: Color transparent.! !

!AthensCanvasWrapper class methodsFor: 'instance creation' stamp: ''!
on: anAthensCanvas
	^ self new
		canvas: anAthensCanvas;
		yourself! !

!AthensCharacterSpan commentStamp: ''!
A text command to render a character span containing the range of characters for with same attributes!
!AthensCharacterSpan methodsFor: 'accessing' stamp: ''!
stop

	^ stop! !

!AthensCharacterSpan methodsFor: 'accessing' stamp: ''!
splitAt: position
	| newSpan |
	"split receiver on two character spans "
	" position points to first character which should be included in newly created span "
	
	position == start ifTrue: [ ^ self ].
	(position < start or: [ position > stop ]) ifTrue: [ self error: 'invalid position' ].

	newSpan := self class new
		start: position;
		stop: stop.

	stop := position - 1.
	self insert: newSpan.! !

!AthensCharacterSpan methodsFor: 'accessing' stamp: ''!
stop: anObject

	stop := anObject! !

!AthensCharacterSpan methodsFor: 'rendering' stamp: ''!
renderOn: renderer
	renderer renderCharactersFrom: start to: stop! !

!AthensCharacterSpan methodsFor: 'accessing' stamp: ''!
start

	^ start! !

!AthensCharacterSpan methodsFor: 'accessing' stamp: ''!
start: anObject

	start := anObject! !

!AthensCloseSegment commentStamp: ''!
i represent close segment (when user issuing #close command to path builder)!
!AthensCloseSegment methodsFor: 'visitor' stamp: ''!
sendCommandTo: aBuilder
	^ aBuilder close! !

!AthensCloseSegment methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor closeSegment: self! !

!AthensColorChange commentStamp: ''!
A command to change the current font color!
!AthensColorChange methodsFor: 'accessing' stamp: ''!
color: anObject

	color := anObject! !

!AthensColorChange methodsFor: 'rendering' stamp: ''!
renderOn: renderer
	renderer setCurrentColor: color! !

!AthensColorChange methodsFor: 'accessing' stamp: ''!
color

	^ color! !

!AthensCompositePaint commentStamp: ''!
i am used to convert CompositeFillStyle into paint, used in Morphic.!
!AthensCompositePaint methodsFor: 'drawing' stamp: ''!
athensFillPath: athensPath on: anAthensCanvas 

	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "

	paints do: [:paint | 
				paint athensFillPath: athensPath on: anAthensCanvas ]! !

!AthensCompositePaint methodsFor: 'drawing' stamp: ''!
athensFillRectangle: aRect on: anAthensCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	

	paints do: [:paint | 
				paint athensFillRectangle: aRect on: anAthensCanvas ]! !

!AthensCompositePaint methodsFor: 'initialization' stamp: ''!
fromFillStyles: fillStyles on: aCanvas

	paints := fillStyles collect: [:each | each asAthensPaintOn: aCanvas ]! !

!AthensCompositeStrokePaint commentStamp: ''!
I am used to convert `CompositeBorderStyle` into paint, used in Morphic. The "withInset" attribute defines whether each sub stroke  outlines a smaller rectangle. If not, all strokes draw the same rectangle (useful for multi-color-dashes)!
!AthensCompositeStrokePaint methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	withInset := true! !

!AthensCompositeStrokePaint methodsFor: 'private' stamp: ''!
fromBorderStyles: borders on: anAthensCanvas
	strokePaints := borders collect: [:each | (each asAthensPaintOn: anAthensCanvas) asStrokePaintOn: anAthensCanvas]! !

!AthensCompositeStrokePaint methodsFor: 'converting' stamp: ''!
asStrokePaintOn: aCanvas
	"receiver is stroke paint already"
	^ self! !

!AthensCompositeStrokePaint methodsFor: 'drawing' stamp: ''!
athensFillRectangle: aRect on: anAthensCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "

	| r |
	r := aRect.
	strokePaints
		do: [ :paint | 
			paint athensFillRectangle: r on: anAthensCanvas.
			withInset ifTrue:[r := r insetBy: paint width ]]! !

!AthensCompositeStrokePaint methodsFor: 'private' stamp: ''!
fromDashedBorderStyle: border on: anAthensCanvas
	| allDashLength offset width |
	width := border width.
	allDashLength := border dashLengths sum: #yourself.
	offset := 0.
	strokePaints := border dashColors
		collectWithIndex: [ :c :i | 
			| stroke dashLength |
			dashLength := border dashLengths at: i.
			stroke := c asStrokePaintOn: anAthensCanvas.
			stroke width: width.
			stroke capButt.
			stroke
				dashes:
					{(dashLength * width).
					((allDashLength - dashLength) * width)}
				offset: (allDashLength - offset) * width.
			offset := offset + dashLength.
			stroke ].
	self withInset: false! !

!AthensCompositeStrokePaint methodsFor: 'accessing' stamp: ''!
withInset: aBoolean
	withInset := aBoolean! !

!AthensCubicBezier commentStamp: ''!
Cubic bezier with 4 control points encapsulation.

Main purpose of this class is to keep subdivision logic in clean and separate place!
!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
x4
	
	^ x4! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
y4: anObject
	
	y4 := anObject! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
y1
	
	^ y1! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
y2: anObject
	
	y2 := anObject! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
x4: anObject
	
	x4 := anObject! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
x1: anObject
	
	x1 := anObject! !

!AthensCubicBezier methodsFor: 'subdivision' stamp: ''!
recursiveSubDiv: flattener level: level

	| dx dy d2 d3 da1 da2 k f1 f2 |
	
	
	" Try to approximate the full cubic curve by a single straight line "
	level > flattener subdivisionLimit ifTrue: [  ^ self ].
	
	dx := x4-x1.
	dy := y4-y1.

	d2 := ((x2 - x4) * dy - ((y2 - y4) * dx)) abs.
	d3 := ((x3 - x4) * dy - ((y3 - y4) * dx)) abs.

	f1 := d2 > flattener curveCollinearityEpsilon.
	f2 := d3 > flattener curveCollinearityEpsilon.
	

	f1 ifTrue: [ 
		f2 ifTrue: [
			" Regular case "
			
			(d2 + d3) squared <= (flattener distanceToleranceSquared * (dx squared + dy squared)) ifTrue: [ 
				"If the curvature doesn't exceed the distance_tolerance value
				we tend to finish subdivisions."
			"	flattener accountForAngleTolerance ifFalse: [
					^ flattener lineToX: (x2 interpolateTo: x3 at: 0.5) y: (y2 interpolateTo: y3 at: 0.5)
					].
			"
				"Angle & Cusp Condition"

				k := (y3-y2) arcTan: (x3 - x2).
				da1 := (k - ((y2-y1) arcTan: (x2-x1))) abs.
				da2 := ((y4-y3 arcTan: x4-x3) - k) abs.

				da1 >= Float pi ifTrue: [  da1 := Float pi*2 - da1 ].
				da2 >= Float pi ifTrue: [  da2 := Float pi*2 - da2 ].
			
				(da1 + da2) < flattener angleTolerance ifTrue: [ 
					" Finally we can stop the recursion "
					^ flattener lineToX: (x2 interpolateTo: x3 at: 0.5) y: (y2 interpolateTo: y3 at: 0.5)
					 ].
		 
				(flattener overCuspLimit: da1) ifTrue: [ ^ flattener lineToX: x2 y: y2 ].
            	   	(flattener overCuspLimit: da2) ifTrue: [ ^ flattener lineToX: x3 y: y3 ].
			]
			
		] ifFalse: [ 
			
			"p1,p3,p4 are collinear, p2 is significant"

			(d2 squared <= (flattener distanceToleranceSquared * (dx squared + dy squared) )  )
				ifTrue: [
					flattener accountForAngleTolerance ifFalse: [ 
						^ flattener lineToX: (x2 interpolateTo: x3 at: 0.5)  y: (y2 interpolateTo: y3 at: 0.5) ].

					"Angle Condition"
					da1 := ((y3-y2 arcTan: (x3-x2)) - (y2-y1 arcTan:(x2-x1))) abs.
					da1 >= Float pi ifTrue: [  da1 := Float pi * 2 - da1 ].
					
					da1 < flattener angleTolerance ifTrue: [ 
						^ flattener 
							lineToX: x2 y: y2;
							lineToX: x3 y: y3 ].
						
					(flattener overCuspLimit: da1) ifTrue: [ ^ flattener lineToX: x2 y: y2 ]
				]			
			 ]
	] ifFalse: [
		f2 ifTrue: [
		"p1,p2,p4 are collinear, p3 is significant "
			
			(d3 squared <= (flattener distanceToleranceSquared * (dx squared + dy squared) )  )
				ifTrue: [
					flattener accountForAngleTolerance ifFalse: [ 
						^ flattener lineToX: (x2 interpolateTo: x3 at: 0.5)  y: (y2 interpolateTo: y3 at: 0.5) ].

					"Angle Condition"
					da1 := ((y4-y3 arcTan: (x4-x3)) - (y3-y2 arcTan:(x3-x2))) abs.
					da1 >= Float pi ifTrue: [  da1 := Float pi * 2 - da1 ].
					
					da1 < flattener angleTolerance ifTrue: [ 
						^ flattener 
							lineToX: x2 y: y2;
							lineToX: x3 y: y3 ].
						
					(flattener overCuspLimit: da1) ifTrue: [ ^ flattener lineToX: x3 y: y3 ]
				]			
			  ] ifFalse: [
		"All collinear OR p1==p4 "
			k := dx*dx + (dy*dy).
			
			(k = 0.0) ifTrue: [
				d2 := (x1-x2) squared + (y1-y2) squared.
				d3 := (x3-x4) squared + (y3-y4) squared ] 
			ifFalse: [ 

				k := 1 / k.
				da1 := x2 - x1.
				da2 := y2 - y1.
				d2  := k * (da1*dx + (da2*dy)).
				da1 := x3 - x1.
				da2 := y3 - y1.
				d3  := k * (da1*dx + (da2*dy)).
				
				(d2 > 0.0 and: [ d2 < 1.0 and: [d3>0.0 and: [d3 < 1.0]]]) ifTrue: [ 
						" Simple collinear case, 1---2---3---4  We can leave just two endpoints"
							^ self ].
				d2 <= 0.0 
					ifTrue: [ d2 := (x1-x2) squared + (y1-y2) squared ]
					ifFalse: [  
						d2 >= 1.0 
							ifTrue: [ d2 := (x2-x4) squared + (y2-y4) squared ]
							ifFalse: [ d2 := (x2 - x1 - (d2*dx)) squared + (y2 - y1 - (d2*dy)) squared ]].

				d3 <= 0.0 
					ifTrue: [  d3 := (x3-x1) squared + (y3-y1) squared ]
					ifFalse: [ 
						d3 >= 1.0 
							ifTrue: [ d3 := (x3-x4) squared + (y3-y4) squared   ]
							ifFalse: [ d3 := (x3 - x1 - (d3*dx)) squared + (y3-y1- (d3*dy)) squared ]].
			].

			(d2 > d3) ifTrue: [
				(d2 < flattener distanceToleranceSquared)
					ifTrue: [ ^ flattener lineToX: x2 y: y2 ]
				]
			ifFalse: [ 
				(d3 < flattener distanceToleranceSquared )
					ifTrue: [  ^ flattener lineToX: x3 y: y3 ]
				 ].
		]
	].
	self subdivideAt: 0.5 do:  [  :b1 :b2 |
		b1 recursiveSubDiv: flattener level: level +1.	
		b2 recursiveSubDiv: flattener level: level +1.	
	]! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
x1
	
	^ x1! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
y1: anObject
	
	y1 := anObject! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
y3
	
	^ y3! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
y3: anObject
	
	y3 := anObject! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
x3
	
	^ x3! !

!AthensCubicBezier methodsFor: 'subdivision' stamp: ''!
subdivideAt: t do: aBinaryBlock
	| x12 y12 x23 y23 x34 y34 x1223 y1223 x2334 y2334 xsplit ysplit |
	
	x12 := x1 interpolateTo: x2 at: t.
	y12 := y1 interpolateTo: y2 at: t.
	x23 := x2 interpolateTo: x3 at: t.
	y23 := y2 interpolateTo: y3 at: t.
	x34 := x3 interpolateTo: x4 at: t.
	y34 := y3 interpolateTo: y4 at: t.

	x1223 := x12 interpolateTo: x23 at: t.
	x2334 := x23 interpolateTo: x34 at: t.
	y1223 := y12 interpolateTo: y23 at: t.
	y2334 := y23 interpolateTo: y34 at: t.
	
	xsplit := x1223 interpolateTo: x2334 at: t.
	ysplit := y1223 interpolateTo: y2334 at: t.
	
	^ aBinaryBlock 
		value: 
		"p1 - p12 - p1223 - psplit"
		(self copy 
			x2: x12;
			y2: y12;
			x3: x1223;
			y3: y1223;
			x4: xsplit;
			y4: ysplit )
		value:
		"psplit - p2334 - p34 - p4" 
		(self copy 
			x1: xsplit;
			y1: ysplit;
			x2: x2334;
			y2: y2334;
			x3: x34;
			y3: y34
		)! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
y2
	
	^ y2! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
x2: anObject
	
	x2 := anObject! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
x3: anObject
	
	x3 := anObject! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
y4
	
	^ y4! !

!AthensCubicBezier methodsFor: 'accessing' stamp: ''!
x2
	
	^ x2! !

!AthensCubicSegment commentStamp: ''!
i represent a cubic Bezier path segment!
!AthensCubicSegment methodsFor: 'accessing' stamp: ''!
to

	^ to! !

!AthensCubicSegment methodsFor: 'accessing' stamp: ''!
via1
	^ via1! !

!AthensCubicSegment methodsFor: 'accessing' stamp: ''!
via2
	^ via2! !

!AthensCubicSegment methodsFor: 'visitor' stamp: ''!
sendCommandTo: aBuilder
	^ aBuilder curveVia: via1 and: via2  to: to! !

!AthensCubicSegment methodsFor: 'accessing' stamp: ''!
endPoint
	^ to! !

!AthensCubicSegment methodsFor: 'accessing' stamp: ''!
via2reflected
	^self endPoint * 2 - via2! !

!AthensCubicSegment methodsFor: 'testing' stamp: ''!
isCubic
	^true! !

!AthensCubicSegment methodsFor: 'accessing' stamp: ''!
from: origin
	via: controlPoint
	and: secondControlPoint
	to: destination
	
	
	via1:= controlPoint.
	via2 := secondControlPoint.
	to := destination! !

!AthensCubicSegment methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor cubicBezierSegment: self! !

!AthensCurveFlattener commentStamp: ''!
This converter flattens all curves by converting them to series of lines.
This means that path can be rendered using simple polygon rendering technique
and nothing else.!
!AthensCurveFlattener methodsFor: 'accessing' stamp: ''!
lengthTolerance

	^ lengthTolerance! !

!AthensCurveFlattener methodsFor: 'helpers' stamp: ''!
flattenCubicBezier: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3 x4: x4 y4: y4! !

!AthensCurveFlattener methodsFor: 'visiting' stamp: ''!
quadricBezierSegment: segment
	| pt1 pt2 pt3 |
	
	pt1 := transform transform: endPoint.
	pt2 := transform transform: segment via.
	pt3 := transform transform: segment endPoint.
	
	endPoint := segment endPoint.

	self flattenQuadBezier: pt1 x y1: pt1 y x2: pt2 x y2: pt2 y x3: pt3 x y3: pt3 y.! !

!AthensCurveFlattener methodsFor: 'accessing' stamp: ''!
transform: aTransform 
	"
	- transform is an Affine matrix, used to map path geometry to screen,
	and therefore used to calculate the error tolerance for path subdivisions
	
	
	- a tolerance multiplier is a number .. which
		if = 1 , the default error tolerance is used,
		if > 1 you will get more coarse approximation
		if < 1 you will get more finer approximation
	
	"
	
	transform := aTransform.! !

!AthensCurveFlattener methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	transform := AthensAffineTransform new. "identity"
	self toleranceMultiplier: self defaultTolerance! !

!AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: ''!
subdivisionLimit
	"max number of recursive subdivisions for single curve"
	^ SubdivisionLimit! !

!AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: ''!
accountForAngleTolerance
	" It's important only when we want to draw an equidistant curve, that is, a stroke of considerable width. If we don't need to draw a stroke or the stroke width is one pixel or less, the distance criterion works quite well. "
	^ false.! !

!AthensCurveFlattener methodsFor: 'path commands' stamp: ''!
curveVia: via1 and: via2 to: end 
	| pt1 pt2 pt3 pt4 curve |
	
	pt1 := transform transform: endPoint.
	pt2 := transform transform: via1.
	pt3 := transform transform: via2.
	pt4 := transform transform: end.
	
	endPoint := end.

	curve := AthensCubicBezier new
		x1: pt1 x;
		y1: pt1 y;
		x2: pt2 x;
		y2: pt2 y;
		x3: pt3 x;
		y3: pt3 y;
		x4: pt4 x;
		y4: pt4 y.
		
	curve recursiveSubDiv: self level: 0.
	self lineTo: endPoint.! !

!AthensCurveFlattener methodsFor: 'path commands' stamp: ''!
curveVia: via to: end 
	| pt1 pt2 pt3 |
	
	pt1 := transform transform: endPoint.
	pt2 := transform transform: via.
	pt3 := transform transform: end.
	
	endPoint := end.

	self flattenQuadBezier: pt1 x y1: pt1 y x2: pt2 x y2: pt2 y x3: pt3 x y3: pt3 y.! !

!AthensCurveFlattener methodsFor: 'path commands' stamp: ''!
moveTo: aPoint 

	contourStartPt := endPoint := aPoint.
	
	^ dest moveTo: aPoint! !

!AthensCurveFlattener methodsFor: 'accessing' stamp: ''!
toleranceMultiplier: aToleranceMultiplier

	"	
	A tolerance multiplier is a number .. which
		if = 1 , the default error tolerance is used,
		if > 1 you will get more coarse approximation
		if < 1 you will get more finer approximation
	
	"
	
	lengthTolerance := aToleranceMultiplier.
	lengthToleranceSquared := lengthTolerance squared.! !

!AthensCurveFlattener methodsFor: 'accessing' stamp: ''!
lengthToleranceSquared

	^ lengthToleranceSquared! !

!AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: ''!
angleTolerance
	^ CurveAngleToleranceEpsilon! !

!AthensCurveFlattener methodsFor: 'public API' stamp: ''!
flattenPath: aPath transform: aTransform toleranceMultiplier: aToleranceMultiplier

	"This is an entry point for flattening path (converting all curves into line segments by approximating them).
	
	- transform is an Affine matrix, used to map path geometry to screen,
	and therefore used to calculate the error tolerance for path subdivisions
	
	
	- a tolerance multiplier is a number .. which
		if = 1 , the default error tolerance is used,
		if > 1 you will get more coarse approximation
		if < 1 you will get more finer approximation
	
	"
	
	transform := aTransform.
	lengthTolerance := aToleranceMultiplier.
	lengthToleranceSquared := lengthTolerance squared.! !

!AthensCurveFlattener methodsFor: 'public API' stamp: ''!
flattenPath: aPath transform: aTransformation

	"This is an entry point for flattening path.
	An additional argument, transform is an Affine matrix, used to map path geometry to screen,
	and therefore used to calculate the error tolerance for path subdivisions"
	
	^ self flattenPath: aPath transform: aTransformation toleranceMultiplier: 1! !

!AthensCurveFlattener methodsFor: 'helpers' stamp: ''!
inverseTransform: aPoint 
	^ transform inverseTransform: aPoint! !

!AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: ''!
distanceToleranceSquared
	^ self lengthToleranceSquared! !

!AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: ''!
lineToX: trX y: trY

	^ dest lineTo: (self inverseTransform: trX @ trY)! !

!AthensCurveFlattener methodsFor: 'path commands' stamp: ''!
lineTo: aPoint 

	endPoint := aPoint.
	
	^ dest lineTo: aPoint! !

!AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: ''!
overCuspLimit: angleInRadians
	 "if(m_cusp_limit !!= 0.0)
                {
                    if(da1 > m_cusp_limit)
                    {
	
	^ angleInRadians > 1.01"
	^ false.! !

!AthensCurveFlattener methodsFor: 'accessing' stamp: ''!
defaultTolerance
	^ 1! !

!AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: ''!
curveCollinearityEpsilon

	^ CurveCollinearityEpsilon! !

!AthensCurveFlattener methodsFor: 'helpers' stamp: ''!
flattenQuadBezier: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3

	"Recursively subdive quadric bezier curve as long as #isFlatBezier.. answers false "

	"The points here is unboxed intentionally to avoid generating extra garbage
	(which contributes to performance loss)"

	(self isFlatQuadBezier: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3) ifTrue: [
		| midx midy |
		midx := (x2 + x1 + x2+x3) * 0.25 .  "mid ( mid(pt1,pt2), mid(pt2,pt3)) "
		midy := (y2 + y1 + y2+y3) * 0.25 . 

		dest 
			lineTo: (self inverseTransform: midx @ midy);
			lineTo: (self inverseTransform: x3 @ y3)
			
	"	dest 
			lineTo: (self inverseTransform: x2 @ y2);
			lineTo: (self inverseTransform: x3 @ y3)
	"
	
	] ifFalse: [
		| x12 y12 x23 y23 x123 y123 |	
	"calculate midpoints of line segments "
		x12 := (x1 + x2) * 0.5.
		y12 := (y1 + y2) * 0.5 .

		x23 := (x2 + x3) * 0.5 .
		y23 := (y2 + y3) * 0.5 .

		x123 := (x12 + x23) * 0.5.
		y123 := (y12 + y23) * 0.5.
		
		self flattenQuadBezier: x1 y1: y1 
			x2: x12 
			y2: y12 
			x3: x123 
			y3: y123.
			
		self flattenQuadBezier: x123 
			y1: y123
			x2: x23
			y2: y23 
			x3: x3 
			y3: y3.
	]! !

!AthensCurveFlattener methodsFor: 'helpers' stamp: ''!
isFlatQuadBezier: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3

	| dx dy d da |
	
	dx := x3-x1.
	dy := y3-y1.
	
	"This is the area of triangle enclosing curve * 2"
 	d := (((x2 - x3) * dy) - ((y2 - y3) * dx)) abs.

	d > (self lengthToleranceSquared ) ifTrue: [
		
		"Non-collinear case (regular one)"
		| dot |

		"if dot product is close to zero, that means we having flat curve"			
		dot := ( (x2-x1)*(x2-x3) + ((y1-y2)*(y2-y3)) ) abs.
		dot < (self lengthToleranceSquared * 0.5 ) ifTrue: [  ^ true ].
	]
	ifFalse: [ 
		"collinear"
		da := dx*dx + (dy*dy).
		
		da = 0 "end points coincide"
			ifTrue: [ d := (x1-x2) squared + (y1-y2) squared  "pointy case" ]
			ifFalse: [
				"the control point lies on line between endpoints?"
				d := ((x2 - x1)*dx + ((y2 - y1)*dy)) / da.

				(d > 0.0 and: [ d < 1.0 ] ) ifTrue: [ 
					"Simple collinear case, 1---2---3" 
					^ true
     				].
				d <= 0.0 
					ifTrue: [ d := (x1-x2) squared + (y1-y2) squared ]
					ifFalse: [
						d >= 1.0 
							ifTrue: [ d:= (x2-x3) squared + (y2-y3) squared ]
							ifFalse: [ d:= (x2 - x1 - (d*dx)) squared + (y2 - y1 - (d*dy)) squared ]
					].
			].

			d < (self lengthToleranceSquared) ifTrue: [ ^ true ]		
	].

	^ false! !

!AthensCurveFlattener class methodsFor: 'class initialization' stamp: ''!
initialize
	CurveCollinearityEpsilon := 1e-30 asFloat.
	CurveDistanceEpsilon := 1e-30 asFloat.
	CurveAngleToleranceEpsilon := 0.01.
	SubdivisionLimit := 10.! !

!AthensDemoMorph commentStamp: ''!
Demos for Athens, just run:

	AthensDemoPresenter open

You can find an implementation of each figure in
corresponding #figure<#>: method!
!AthensDemoMorph methodsFor: 'drawing' stamp: ''!
drawBackgroundOn: aCanvas
	aCanvas
		setPaint: Color veryLightGray;
		drawShape: (0 @ 0 extent: 1 @ 1)! !

!AthensDemoMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas

	self render.

	aCanvas
		drawImage: surface asForm at: self bounds origin! !

!AthensDemoMorph methodsFor: 'figures' stamp: ''!
figure9: aCanvas
	| ellipsePath patternPaint |
	ellipsePath := aCanvas createPath: [ :builder |
		builder
			moveTo: 10@200;
			cwArcTo: 360@0  angle: Float pi ;
			lineTo: -100@180;
			lineTo: -150@ -0;
			lineTo: -110@ -180].

	aCanvas setPaint: Color black.
	aCanvas drawShape: ellipsePath.

	aCanvas paintTransform loadIdentity.
	aCanvas paintTransform scaleBy: ((frame/200) sin abs)*3.
	
	
	patternPaint := aCanvas setPaint: esugBallon .
	patternPaint setExtend: #None.
	aCanvas draw! !

!AthensDemoMorph methodsFor: 'accessing' stamp: ''!
nextFigure

	current := current + 1.
	
	current > self figures size ifTrue: [ current := 1 ].! !

!AthensDemoMorph methodsFor: 'accessing' stamp: ''!
prevFigure

	current := current - 1.
	
	current < 1 ifTrue: [ current := self figures size ].! !

!AthensDemoMorph methodsFor: 'stepping' stamp: ''!
step
	frame := frame + 1.
	self changed! !

!AthensDemoMorph methodsFor: 'accessing' stamp: ''!
figures
	^ #(
	figure1:
	figure2:
	figure3:
	figure4:
	figure5:
	figure6:
	figure7:
	figure8:
	figure9:
	figure10:
	)! !

!AthensDemoMorph methodsFor: 'figures' stamp: ''!
figure1: aCanvas
	aCanvas
		setPaint: self carColor;
		drawShape: (50@100 extent: 300@200)! !

!AthensDemoMorph methodsFor: 'accessing' stamp: ''!
defaultExtent
	^ 400@400! !

!AthensDemoMorph methodsFor: 'figures' stamp: ''!
figure7: aCanvas
	| pt |

	self drawBackgroundOn: aCanvas.

	pt := aCanvas pathTransform.

	pt restoreAfter:[
		pt scaleBy: self extent .
		self drawCarOn: aCanvas.

		pt scaleBy: 0.25@0.25. 
		self drawCarOn: aCanvas.
	
		pt  translateBy: 2@0; rotateByDegrees: 35.
		self drawCarOn: aCanvas ]! !

!AthensDemoMorph methodsFor: 'figures' stamp: ''!
figure6: aCanvas
	| linearGradient |
	
	self figure5: aCanvas.
	
	linearGradient := 
		aCanvas surface createLinearGradient: {
			0 -> self coloredCarColor .
			0.25 -> self coloredCarColor muchLighter.
			0.5 -> Color white.
			0.75 -> (self coloredCarColor muchLighter ).
			1 -> (self coloredCarColor alpha: 0)	
		}
		start:  0@100  
		stop: 0@300.
	
	aCanvas setShape: (self class roundedRectanglePathOn: aCanvas).
	
	aCanvas setPaint: linearGradient.
	
	aCanvas draw! !

!AthensDemoMorph methodsFor: 'figures' stamp: ''!
figure5: aCanvas
	| wheels |
	self figure4: aCanvas.

	wheels := aCanvas createPath: [:builder |
		builder
			moveTo:  100@100;		
			cwArcTo: 60@0 angle: 90 degreesToRadians;
			moveTo:  80@0;				
			cwArcTo: 60@0 angle: 90 degreesToRadians;
			moveTo:  0.0@200;
			cwArcTo: -60@0 angle: 90 degreesToRadians;
			moveTo:  -80@0; 
			cwArcTo: -60@0 angle: 90 degreesToRadians ].

	aCanvas	
		setPaint: self wheelColor;
		drawShape: wheels! !

!AthensDemoMorph methodsFor: 'figures' stamp: ''!
figure3: aCanvas
	| path |	
	path := aCanvas createPath: [:builder |
		builder
			relative;
			moveTo: 0.3@0.3 ;
			lineTo: 0.4@0;
			curveVia: 0.1@0 to: 0.1@0.1;
			lineTo: 0@0.2;
			curveVia: 0@0.1 to: -0.1@0.1;
			lineTo: -0.4@0;
			curveVia: -0.1@0 to: (-0.1@ -0.1);
			lineTo: 0@ -0.2  ;
			curveVia: 0@ -0.1 to: 0.1@ -0.1 ].

	aCanvas pathTransform scaleBy: self extent.
	aCanvas
		setPaint: self carColor;
		drawShape: path! !

!AthensDemoMorph methodsFor: 'figures' stamp: ''!
figure8: aCanvas
	| pt |
	pt := aCanvas pathTransform.
	pt restoreAfter:[	
		pt scaleBy: self extent.
		self drawBackgroundOn: aCanvas.

		pt scaleBy: (frame/100) sin abs.
		self drawCarOn: aCanvas.
		pt scaleBy: 0.25@0.2.5. 
		self drawCarOn: aCanvas.
	
		pt  translateBy: 2@0; rotateByDegrees: 35.
		self drawCarOn: aCanvas ]! !

!AthensDemoMorph methodsFor: 'figures' stamp: ''!
figure4: aCanvas
	| path stroke |
	
	path := self class roundedRectanglePathOn: aCanvas.
	
	aCanvas setShape: path.
	
	aCanvas setPaint: self carColor.
	aCanvas draw.
	
	stroke := aCanvas setStrokePaint: Color black.
	stroke width: 3.
	
	aCanvas draw! !

!AthensDemoMorph methodsFor: 'accessing' stamp: ''!
chasisLineColor
	^ Color white! !

!AthensDemoMorph methodsFor: 'stepping' stamp: ''!
stepTime
	^ 0! !

!AthensDemoMorph methodsFor: 'initialization' stamp: ''!
initialize
	| ref loadFileFailBlock |
	super initialize.
	self extent: self defaultExtent.
	self color: self backColor.
	surface := AthensCairoSurface extent: self extent.
	current := 1.
	frame := 0.
	loadFileFailBlock := AthensCairoSurface fromForm: (Form fromDisplay: (0 @ 0 extent: 300 @ 150)).
	ref := 'Pharo.png' asFileReference.
	pharoLogo := AthensCairoSurface createFromFile: ref fullName ifFailed: [ loadFileFailBlock ].

	ref := 'esug-balloon.png' asFileReference.
	esugBallon := AthensCairoSurface createFromFile: ref fullName ifFailed: [ loadFileFailBlock ].

	self startStepping! !

!AthensDemoMorph methodsFor: 'figures' stamp: ''!
figure10: aCanvas
	| ellipsePath patternPaint rectangle |
	ellipsePath := aCanvas createPath: [ :builder |
		builder
			moveTo: 0@200;
			cwArcTo:  240@0 angle: Float pi;
			cwArcTo: -240@0 angle: Float pi ].
	aCanvas setPaint: Color black.
	aCanvas drawShape: ellipsePath.
	rectangle := 250@40 extent: 140@300.
	aCanvas drawShape: rectangle.

	aCanvas paintTransform loadIdentity.
	aCanvas paintTransform scaleBy: ((frame/100) sin abs) * 5.
	aCanvas paintTransform rotateByDegrees: (frame/100) sin * 360.
	
	patternPaint := aCanvas setPaint: pharoLogo.
	patternPaint setExtend: #Repeat.
	aCanvas drawShape: ellipsePath.
	
	aCanvas setPaint: patternPaint.
	patternPaint setExtend: #Reflect.
	aCanvas drawShape: rectangle! !

!AthensDemoMorph methodsFor: 'drawing' stamp: ''!
render 

	surface drawDuring: [:canvas | 
		surface clear.
		canvas pathTransform loadIdentity.
		canvas setPaint: Color lightGray;
		drawShape: (0@0 corner: self extent).
		self perform: (self figures at: current)  with: canvas
	].! !

!AthensDemoMorph methodsFor: 'accessing' stamp: ''!
carColor
	^ Color veryVeryLightGray! !

!AthensDemoMorph methodsFor: 'drawing' stamp: ''!
wheelColor
	^ Color brown darker! !

!AthensDemoMorph methodsFor: 'accessing' stamp: ''!
coloredCarColor
	^ Color red! !

!AthensDemoMorph methodsFor: 'accessing' stamp: ''!
backColor
	^ Color white! !

!AthensDemoMorph methodsFor: 'figures' stamp: ''!
figure2: aCanvas
	| path |	
	path := aCanvas createPath: [:builder |
		builder
			absolute;
			moveTo: 70@100;
			lineTo: 330@100;
			cwArcTo: 350@120 angle: 90 degreesToRadians;
			lineTo: 350@280;
			cwArcTo: 330@300 angle: 90 degreesToRadians;
			lineTo: 70@300;
			cwArcTo: 50@280 angle: 90 degreesToRadians;
			lineTo: 50@120;
			cwArcTo: 70@100 angle: 90 degreesToRadians ].

	aCanvas
		setPaint: self carColor;
		drawShape: path! !

!AthensDemoMorph methodsFor: 'accessing' stamp: ''!
chasisDecoratorColor
	^ Color black! !

!AthensDemoMorph methodsFor: 'drawing' stamp: ''!
drawCarOn: aCanvas

	| p stroke wheel decorator |
	"chasis"
	p := aCanvas createPath: [:b |		
			b 
				moveTo: 0.3@0.3 ;
				lineTo: 0.4@0;
				curveVia: 0.1@0 to: 0.1@0.1;
				lineTo: 0@0.2;
				curveVia: 0@0.1 to: -0.1@0.1;
				lineTo: -0.4@0;
				curveVia: -0.1@0 to: (0.1@0.1) negated;
				lineTo: 0@0.2 negated ;
				curveVia: 0@0.1 negated to: 0.1@0.1 negated ].
		aCanvas	
			setPaint: self coloredCarColor;
			drawShape: p.
		stroke := aCanvas setStrokePaint: self wheelColor.
		stroke width: 0.01.
		aCanvas draw.
		
		"wheels"
		wheel := aCanvas createPath:[:b|
			b
				moveTo: 	0.3@0.3;		
				cwArcTo: 0.15@0 angle: Float halfPi ;
				moveTo: 	0.1@0;				
				cwArcTo: 0.15@0 angle: Float halfPi ;					
				moveTo: 	0.0@0.4;				
				cwArcTo: 0.15 negated@0 angle: Float halfPi; 
				moveTo: 	-0.1@0; 
				cwArcTo: 0.15 negated@0 angle: Float halfPi 	].
		aCanvas	
			setPaint: self wheelColor;
			drawShape: wheel.
		
		"chasis decorator"
		decorator  := aCanvas createPath:[:b|
			b
				moveTo: 	0.2@0.45;	
				lineTo: 0.225@0 ;		
				cwArcTo: 0.15@0 angle: Float halfPi ;
				lineTo: 	0.225@0;				
				lineTo: 0@0.1 ;
				lineTo: -0.225@ 0;
				cwArcTo: -0.15@0 angle: Float halfPi ;
				lineTo: -0.225@ 0	;
				lineTo: 0@0.1 negated].
		stroke := aCanvas setStrokePaint: self chasisDecoratorColor.
		stroke width: 0.01.	
		aCanvas drawShape: decorator.
		aCanvas setPaint: self chasisLineColor.
		aCanvas draw! !

!AthensDemoMorph class methodsFor: 'utilities' stamp: ''!
roundedRectanglePathOn: aCanvas

	^ aCanvas createPath: [:builder |
		builder
			absolute;
			moveTo: 70@100;
			lineTo: 330@100;
			cwArcTo: 350@120 angle: 90 degreesToRadians;
			lineTo: 350@280;
			cwArcTo: 330@300 angle: 90 degreesToRadians;
			lineTo: 70@300;
			cwArcTo: 50@280 angle: 90 degreesToRadians;
			lineTo: 50@120;
			cwArcTo: 70@100 angle: 90 degreesToRadians ]! !

!AthensDemoPresenter commentStamp: ''!
I am a simple presenter to display the Athens demo.

I'll open an Athens demo morph and will display two buttons to navigate the different demos.

Examples
-------------

	self open!
!AthensDemoPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	backButton := self newButton.
	forwardButton := self newButton.
	demo := self newMorph.

	demo morph: AthensDemoMorph new.

	backButton
		label: 'Previous Figure';
		action: [ demo morph prevFigure ].
	forwardButton
		label: 'Next Figure';
		action: [ demo morph nextFigure ].

	self focusOrder
		add: backButton;
		add: forwardButton! !

!AthensDemoPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	aWindowPresenter
		title: 'Athens demos';
		initialExtent: demo morph extent + (0 @ 100)! !

!AthensDemoPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #demo;
		add:
			(SpBoxLayout newLeftToRight
				add: #backButton;
				add: #forwardButton;
				yourself)
			withConstraints: [ :constraints | constraints height: self toolbarHeight ];
		yourself! !

!AthensDemoPresenter class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	self new openWithSpec! !

!AthensDisplayScanner commentStamp: ''!
An AthensDisplayScanner displays the paragraphs text on an AthensCanvas.!
!AthensDisplayScanner methodsFor: 'displaying' stamp: ''!
displayString: string from: startIndex to: stopIndex at: aPoint
	canvas pathTransform
		restoreAfter: [ 
			canvas pathTransform translateBy: aPoint + (0@font ascent).
			canvas drawString: string from: startIndex to: stopIndex ]! !

!AthensDisplayScanner methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.! !

!AthensDisplayScanner methodsFor: 'displaying' stamp: ''!
fillTextBackground
	backgroundColor ifNotNil: [ canvas drawShape: (line left @ lineY extent: line width @ line lineHeight) ]! !

!AthensDisplayScanner methodsFor: 'initialization' stamp: ''!
initWithParagraph: aParagraph andCanvas: anAthensCanvas
	self text: aParagraph text textStyle: aParagraph textStyle.
	canvas := anAthensCanvas! !

!AthensDisplayScanner methodsFor: 'displaying' stamp: ''!
setFont
	super setFont.
	canvas setFont:font.
	canvas setPaint: foregroundColor! !

!AthensDisplayScanner class methodsFor: 'instance creation' stamp: ''!
on: anAthensCanvas
	^ self new initWith: anAthensCanvas; yourself! !

!AthensDisplayScanner class methodsFor: 'instance creation' stamp: ''!
for: aParagraph on: anAthensCanvas
	^ self new initWithParagraph: aParagraph andCanvas: anAthensCanvas; yourself! !

!AthensEllipticalArcSegment commentStamp: ''!
I representing an elliptical arc, using endpoint parametrization:

- initial endpoint (x0,y0), which comes from previous segment
- final endpoint (x1,y1)

- rh, rv , the radii of unrotated ellipse

- Large arc flag: true if more than 180 degrees of the arc is to be traversed (as measured on the unscaled circle), false otherwise

- Sweep flag: true if the arc is to be traversed in the counter-clockwise direction, false otherwise

(not functional yet)!
!AthensEllipticalArcSegment methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor ellipticalArcSegment: self! !

!AthensFT2Constants commentStamp: ''!
The various flags from the Freetype/2 header.

The LoadXXXX flags can be used with `primitiveLoadGlyph:flags:` or with the Cairo `primCairoFtFontCreateForFtFace:flags:scale:` primitives.

#### `FT_LOAD_DEFAULT`
  Corresponding to 0, this value is used a default glyph load.  In this
  case, the following will happen:
                                                                        
1. FreeType looks for a bitmap for the glyph corresponding to the
   face's current size.  If one is found, the function returns.  The
   bitmap data can be accessed from the glyph slot (see note below).
                                                                        
2. If no embedded bitmap is searched or found, FreeType looks for a
   scalable outline.  If one is found, it is loaded from the font
   file, scaled to device pixels, then "hinted" to the pixel grid in
   order to optimize it.  The outline data can be accessed from the
   glyph slot (see note below).
                                                                        
Note that by default, the glyph loader doesn't render outlines into
bitmaps. The following flags are used to modify this default
behaviour to more specific and useful cases.
                                                                        
#### `FT_LOAD_NO_SCALE`
  Don't scale the vector outline being loaded to 26.6 fractional
  pixels, but kept in font units.  Note that this also disables
  hinting and the loading of embedded bitmaps.  You should only use it
  when you want to retrieve the original glyph outlines in font units.
                                                                        
#### `FT_LOAD_NO_HINTING`
  Don't hint glyph outlines after their scaling to device pixels.
  This generally generates "blurrier" glyphs in anti-aliased modes.
                                                                        
  This flag is ignored if `FT_LOAD_NO_SCALE` is set.
                                                                        
#### `FT_LOAD_RENDER` 
  Render the glyph outline immediately into a bitmap before the glyph
  loader returns.  By default, the glyph is rendered for the
  `FT_RENDER_MODE_NORMAL` mode, which corresponds to 8-bit anti-aliased
  bitmaps using 256 opacity levels.  You can use either
  `FT_LOAD_TARGET_MONO` or `FT_LOAD_MONOCHROME` to render 1-bit
  monochrome bitmaps.
                                                                        
  This flag is ignored if `FT_LOAD_NO_SCALE` is set.
                                                                        
####`FT_LOAD_NO_BITMAP`
  Don't look for bitmaps when loading the glyph.  Only scalable
  outlines will be loaded when available, and scaled, hinted, or
  rendered depending on other bit flags.
                                                                        
  This does not prevent you from rendering outlines to bitmaps
  with `FT_LOAD_RENDER`, however.
                                                                        
####`FT_LOAD_VERTICAL_LAYOUT`
  Prepare the glyph image for vertical text layout.  This basically
  means that `face.glyph.advance` will correspond to the vertical
  advance height (instead of the default horizontal advance width),
  and that the glyph image will be translated to match the vertical
  bearings positions.
                                                                        
####`FT_LOAD_FORCE_AUTOHINT`
  Force the use of the FreeType auto-hinter when a glyph outline is
  loaded.  You shouldn't need this in a typical application, since it
  is mostly used to experiment with its algorithm.
                                                                        
####`FT_LOAD_CROP_BITMAP`
  Indicates that the glyph loader should try to crop the bitmap (i.e.,
  remove all space around its black bits) when loading it.  This is
  only useful when loading embedded bitmaps in certain fonts, since
  bitmaps rendered with `FT_LOAD_RENDER` are always cropped by default.
                                                                        
####`FT_LOAD_PEDANTIC`
  Indicates that the glyph loader should perform pedantic
  verifications during glyph loading, rejecting invalid fonts.  This
  is mostly used to detect broken glyphs in fonts.  By default,
  FreeType tries to handle broken fonts also.
                                                                        
#### `FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH`
  Indicates that the glyph loader should ignore the global advance
  width defined in the font.  As far as we know, this is only used by
  the X-TrueType font server, in order to deal correctly with the
  incorrect metrics contained in DynaLab's TrueType CJK fonts.
                                                                        
####`FT_LOAD_NO_RECURSE`
  This flag is only used internally.  It merely indicates that the
  glyph loader should not load composite glyphs recursively.  Instead,
  it should set the `num_subglyph` and `subglyphs` values of the glyph
  slot accordingly, and set "glyph->format" to `FT_GLYPH_FORMAT_COMPOSITE`.
                                                                        
  The description of sub-glyphs is not available to client
  applications for now.
                                                                        
####`FT_LOAD_IGNORE_TRANSFORM`
  Indicates that the glyph loader should not try to transform the
  loaded glyph image.  This doesn't prevent scaling, hinting, or
  rendering.
                                                                        
####`FT_LOAD_MONOCHROME`
  This flag is used with `FT_LOAD_RENDER` to indicate that you want
  to render a 1-bit monochrome glyph bitmap from a vectorial outline.
                                                                        
  Note that this has no effect on the hinting algorithm used by the
  glyph loader.  You should better use `FT_LOAD_TARGET_MONO` if you
  want to render monochrome-optimized glyph images instead.
                                                                        
####`FT_LOAD_LINEAR_DESIGN`
  Return the linearly scaled metrics expressed in original font units
  instead of the default 16.16 pixel values.
                                                                        
####`FT_LOAD_NO_AUTOHINT`
  Indicates that the auto-hinter should never be used to hint glyph
  outlines.  This doesn't prevent native format-specific hinters from
  being used.  This can be important for certain fonts where unhinted
  output is better than auto-hinted one.

One of following flags (as LoadTargetXXX) can be used to further specify the result.

####`FT_RENDER_MODE_NORMAL`                                          
     This is the default render mode; it corresponds to 8-bit        
     anti-aliased bitmaps, using 256 levels of opacity.              
                                                                     
####`FT_RENDER_MODE_LIGHT`                                           
     This is similar to `FT_RENDER_MODE_NORMAL`, except that this     
     changes the hinting to prevent stem width quantization.  This   
     results in glyph shapes that are more similar to the original,  
     while being a bit more fuzzy ("better shapes", instead of       
     "better contrast" if you want :-).                              
                                                                     
####`FT_RENDER_MODE_MONO`                                            
     This mode corresponds to 1-bit bitmaps.                         
                                                                     
####`FT_RENDER_MODE_LCD`                                             
     This mode corresponds to horizontal RGB/BGR sub-pixel displays, 
     like LCD-screens.  It produces 8-bit bitmaps that are 3 times   
     the width of the original glyph outline in pixels, and which use
     the `FT_PIXEL_MODE_LCD` mode.                                    
                                                                     
####`FT_RENDER_MODE_LCD_V`                                         
     This mode corresponds to vertical RGB/BGR sub-pixel displays    
     (like PDA screens, rotated LCD displays, etc.).  It produces    
     8-bit bitmaps that are 3 times the height of the original       
     glyph outline in pixels and use the `FT_PIXEL_MODE_LCD_V` mode.  
                                                                     
####Note                                                              
  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.                                                 

!
!AthensFT2Constants class methodsFor: 'class initialization' stamp: ''!
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.! !

!AthensFlakeDemo commentStamp: ''!
AthensFlakeDemo new openInWindow
!
!AthensFlakeDemo methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas

	self render.
	surface displayOnMorphicCanvas: aCanvas at: bounds origin.! !

!AthensFlakeDemo methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	self extent: self defaultExtent.

	surface := AthensCairoSurface extent: self extent.

	circle := surface createPath: [:builder |
		builder
			absolute;
			moveTo: -1 @ 0 ; 
			ccwArcTo: 0@ 1 angle: 90 degreesToRadians ;
			ccwArcTo: 1@0 angle: 90 degreesToRadians ;
			ccwArcTo: 0@ -1 angle: 90 degreesToRadians ;
			ccwArcTo: -1@0 angle:  90 degreesToRadians 
	].

	spike := surface createPath: [:builder |
		
		builder
			absolute;
			moveTo:  -0.1 @ 0;
			lineTo: -0.05 @ 1;
			lineTo: 0.05 @ 1;
			lineTo: 0.1 @ 0		
		].

	frame := 1.
	self startStepping.! !

!AthensFlakeDemo methodsFor: 'drawing' stamp: ''!
drawCircles: canvas

	canvas pathTransform restoreAfter: [
		
		canvas pathTransform scaleBy: 0.5 .
		
		canvas 
			setPaint: Color black;
			setShape: self circle;
			draw.

		canvas
			pathTransform scaleBy: 0.8.
		canvas
			setPaint: Color white;
			draw.
		canvas 
			pathTransform scaleBy: 0.8.
		canvas
			setPaint: Color black;
			draw
	]! !

!AthensFlakeDemo methodsFor: 'rendering' stamp: ''!
render 

	surface drawDuring: [:canvas | 
		canvas pathTransform loadIdentity.
		surface clear. 
		
"		canvas 
			setPaint: Color white;
			drawShape: (0@0 corner: self extent ).
"
		canvas pathTransform
			 translateX: self extent x *0.5  Y:  self extent y * 0.5;
			scaleBy: 160. 
			
		canvas pathTransform  rotateByDegrees:  (frame * 0.5 + ((frame *0.1 + 1.7) cos * 5)).
		1 to: 3 do:[ :i |
			canvas pathTransform  rotateByDegrees: 120.
			self drawSpike: canvas.
		].
		 self drawCircles: canvas
	].! !

!AthensFlakeDemo methodsFor: 'stepping' stamp: ''!
step
	frame := Time millisecondClockValue / 100.
	
	self changed! !

!AthensFlakeDemo methodsFor: 'accessing' stamp: ''!
circle
	^ circle! !

!AthensFlakeDemo methodsFor: 'defaults' stamp: ''!
defaultExtent
	^ 800@800! !

!AthensFlakeDemo methodsFor: 'drawing' stamp: ''!
drawSpike: canvas


	|  dist |
	
	
	dist := (canvas pathTransform transform: 1@0) - (canvas pathTransform transform: 0@0).
  	dist r < 2 ifTrue: [ ^ self ].
	
	canvas
		setPaint: (Color black alpha: 0.5);
		drawShape: spike.
		
	canvas pathTransform restoreAfter: [
 		canvas pathTransform translateX: 0 Y: 	1;
			scaleBy: 0.5 + ((frame *0.1) sin * 0.1 ).
			
		canvas pathTransform  rotateByDegrees: -180.
		1 to: 2 do:[ :i |
				canvas pathTransform  rotateByDegrees: 120 + ((frame * 0.1) cos * 20).
			canvas pathTransform  restoreAfter:  [
				self drawSpike: canvas.
			]
		].

			
		self drawCircles: canvas
	]! !

!AthensFlakeDemo methodsFor: 'stepping' stamp: ''!
stepTime
	^ 0! !

!AthensFlakeDemo class methodsFor: 'instance creation' stamp: ''!
open
	<example>
	self new openInWindow! !

!AthensFontChange commentStamp: ''!
A command to change the currently selected font!
!AthensFontChange methodsFor: 'accessing' stamp: ''!
font
	^ font! !

!AthensFontChange methodsFor: 'accessing' stamp: ''!
font: aFont
	font := aFont! !

!AthensFontChange methodsFor: 'rendering' stamp: ''!
renderOn: anAthensTextRenderer 
	anAthensTextRenderer setCurrentFont: font.! !

!AthensFontChange class methodsFor: 'instance creation' stamp: ''!
font: aFont 
	^ self new font: aFont! !

!AthensFontDescription commentStamp: ''!
Creates a new font description from a string representation in the form 
"[FAMILY-LIST] [STYLE-OPTIONS] [SIZE]", 

1)FAMILY-LIST is a comma separated list of families optionally terminated by a comma,

2)STYLE_OPTIONS is a whitespace separated list of words where each WORD describes one of style, variant, weight, stretch, or gravity. If STYLE-OPTIONS is missing, then all style options will be set to the default values

3)SIZE is a decimal number (size in points) or optionally followed by the unit modifier "px" for absolute size. 

!
!AthensFontDescription methodsFor: 'cairo - options' stamp: ''!
fontSize
	^ size! !

!AthensFontDescription methodsFor: 'pango-options' stamp: ''!
fontStretch
	^ options at: #stretch! !

!AthensFontDescription methodsFor: 'pango-options' stamp: ''!
fontVariant
	^ options at: #variant! !

!AthensFontDescription methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	family := 'monospace'.
	options := Dictionary new.
	options
		at:#weight put: #normal; 
		at:#slant put: #normal.
	size := 14.! !

!AthensFontDescription methodsFor: 'cairo - options' stamp: ''!
slant: aNumber
	options at: #slant put: aNumber.! !

!AthensFontDescription methodsFor: 'accessing' stamp: ''!
beItalic
	self slant: #italic! !

!AthensFontDescription methodsFor: 'accessing' stamp: ''!
beNormal
	self slant: #normal ; weight: #normal.! !

!AthensFontDescription methodsFor: 'pango-options' stamp: ''!
gravity: aNumber
	options at: #gravity put: aNumber.! !

!AthensFontDescription methodsFor: 'accessing' stamp: ''!
beOblique
	self slant: #oblique! !

!AthensFontDescription methodsFor: 'pango-options' stamp: ''!
variant: aNumber
	options at: #variant put: aNumber.! !

!AthensFontDescription methodsFor: 'accessing' stamp: ''!
beBold
	self weight: #bold! !

!AthensFontDescription methodsFor: 'pango-options' stamp: ''!
fontGravity
	^ options at: #gravity! !

!AthensFontDescription methodsFor: 'cairo - options' stamp: ''!
fontWeight
	^ options at: #weight! !

!AthensFontDescription methodsFor: 'accessing' stamp: ''!
asString
	"[FAMILY-LIST] [STYLE-OPTIONS] [SIZE]"
	| str |
	str := '' writeStream.
	str nextPutAll:  family; space.
	"	
2)STYLE_OPTIONS is a whitespace separated list of words where each WORD describes one of style, variant, weight, stretch, or gravity. If STYLE-OPTIONS is missing, then all style options will be set to the default values
"
	#(slant. variant. weight. stretch. gravity) do:[:each|
		|val|
		val := options at: each ifAbsent: nil.
		val notNil ifTrue:[str nextPutAll: val ; space ]].
	
	self fontSize notNil ifTrue:[
		str
			space;
			nextPutAll: self fontSize asString ].
	^ str contents! !

!AthensFontDescription methodsFor: 'cairo - options' stamp: ''!
weight: aNumber
	options at: #weight put: aNumber.! !

!AthensFontDescription methodsFor: 'cairo - options' stamp: ''!
family: aFamilyName
	"CSS2 generic family names: serif, sans-serif, cursive, fantasy, monospace"
	family := aFamilyName.! !

!AthensFontDescription methodsFor: 'cairo - options' stamp: ''!
fontFamily
	^ family! !

!AthensFontDescription methodsFor: 'cairo - options' stamp: ''!
fontSize: aPointSize
	size := aPointSize! !

!AthensFontDescription methodsFor: 'cairo - options' stamp: ''!
fontSlant
	^ options at: #slant! !

!AthensFontDescription methodsFor: 'pango-options' stamp: ''!
stretch: aNumber
	options at: #stretch put: aNumber.! !

!AthensFontDescription class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| fDesc |
	fDesc := AthensFontDescription new. 
	fDesc
		family: 'monospace';
		fontSize: 22.
	^ fDesc! !

!AthensGradientPaint commentStamp: ''!
I am used to convert gradient fill style(s) to appropriate paint(s) in Athens.!
!AthensGradientPaint methodsFor: 'accessing' stamp: ''!
gradient: aGradient

	gradient := aGradient! !

!AthensGradientPaint methodsFor: 'rendering' stamp: ''!
athensFillPath: aPath on: canvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	
	| fill |
	fill := self convertGradientToPaintOn: canvas.
	fill athensFillPath: aPath on: canvas! !

!AthensGradientPaint methodsFor: 'private' stamp: ''!
convertGradientToPaintOn: aCanvas

	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "

	^ gradient radial
		  ifTrue: [ 
			  aCanvas surface
				  createRadialGradient: gradient colorRamp
				  center:
				  (aCanvas pathTransform inverseTransform: gradient origin)
				  radius: gradient direction y ]
		  ifFalse: [ 
			  aCanvas surface
				  createLinearGradient: gradient colorRamp
				  start: (aCanvas pathTransform inverseTransform: gradient origin)
				  stop: (aCanvas pathTransform inverseTransform:
						   gradient origin + gradient direction) ]! !

!AthensGradientPaint methodsFor: 'rendering' stamp: ''!
athensFillRectangle: aRect on: canvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	
	| fill |
	fill := self convertGradientToPaintOn: canvas.
	fill athensFillRectangle: aRect on: canvas! !

!AthensInteractiveScene commentStamp: ''!
I am like my superclass, can display any scene (object which understands `#renderOn:`  message)
and support free-form pan and zoom. But in addition, I'm expecting that scene object understands following:

`scene handleEvent: event in: sceneView at: position`
 
This method should answer true if scene object wants to handle event by itself, preventing default handling of view (pan & zoom).
The point is coordinates of event in scene coordinate space (not screen coordinate space). The event is MorphicEvent (currently limited only to mouse move&button events).

Note that if scene view enters zooming or panning state, no events will be passed to scene object as long as state is active. 
!
!AthensInteractiveScene methodsFor: 'event handling' stamp: ''!
eventPositionInScene: evt
	| pt | 
	
	pt := evt position - self topLeft.
	
	^ transform transform: pt! !

!AthensInteractiveScene methodsFor: 'event handling' stamp: ''!
mouseDown: evt

	((self inState: #panning) or: [ self inState:#zooming ]) 
		ifFalse: [
			(self eventHandledByScene: evt) ifTrue: [ ^ self ]. 	
		].

	^ super mouseDown: evt! !

!AthensInteractiveScene methodsFor: 'event handling' stamp: ''!
mouseUp: evt

	((self inState: #panning) or: [ self inState:#zooming ]) 
		ifFalse: [
			(self eventHandledByScene: evt) ifTrue: [ ^ self ]. 	
		].
		
	^ super mouseUp:evt! !

!AthensInteractiveScene methodsFor: 'event handling' stamp: ''!
mouseMove: evt

	((self inState: #panning) or: [ self inState:#zooming ]) 
		ifFalse: [
			(self eventHandledByScene: evt) ifTrue: [ ^ self ]. 	
		].
	^ super mouseMove: evt! !

!AthensInteractiveScene methodsFor: 'event handling' stamp: ''!
eventHandledByScene: evt

	^  true == (scene handleEvent: evt in: self at: (self eventPositionInScene:evt))! !

!AthensLineSegment commentStamp: ''!
i represent a line segment,
created using 
	#lineTo: 
command of AthensPathBuilder!
!AthensLineSegment methodsFor: 'accessing' stamp: ''!
point

	^ point! !

!AthensLineSegment methodsFor: 'accessing' stamp: ''!
point: anObject

	point := anObject! !

!AthensLineSegment methodsFor: 'visitor' stamp: ''!
visitWith: visitor

	visitor visitLineSegment:  self! !

!AthensLineSegment methodsFor: 'visitor' stamp: ''!
sendCommandTo: aBuilder
	^ aBuilder lineTo: point! !

!AthensLineSegment methodsFor: 'accessing' stamp: ''!
endPoint
	^ point! !

!AthensLineSegment methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor lineSegment: self! !

!AthensMorphScene commentStamp: ''!
Allows to render a morph as a scene in athens!
!AthensMorphScene methodsFor: 'accessing' stamp: ''!
morph
	
	^ morph! !

!AthensMorphScene methodsFor: 'accessing' stamp: ''!
morph: anObject
	
	morph := anObject! !

!AthensMorphScene methodsFor: 'rendering' stamp: ''!
renderOn:aCanvas
	morph fullDrawOnAthensCanvas: aCanvas! !

!AthensMoveSegment commentStamp: ''!
Move segment always indicates starting of a new contour.
If contour ends with close command, then my insntance will have 'closed' flag set to true.

See AthensPathBuilder , which is responsible for building paths.!
!AthensMoveSegment methodsFor: 'testing' stamp: ''!
isClosed
	^ closed == true! !

!AthensMoveSegment methodsFor: 'testing' stamp: ''!
isMove
	^ true! !

!AthensMoveSegment methodsFor: 'visitor' stamp: ''!
visitWith: visitor

	visitor visitMoveSegment: self! !

!AthensMoveSegment methodsFor: 'visitor' stamp: ''!
sendCommandTo: aBuilder
	^ aBuilder moveTo: point! !

!AthensMoveSegment methodsFor: 'accessing' stamp: ''!
closed: aBoolean
	closed := aBoolean! !

!AthensMoveSegment methodsFor: 'accessing' stamp: ''!
reopen: aBoolean
	closed := aBoolean! !

!AthensMoveSegment methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor moveSegment: self! !

!AthensPaint commentStamp: ''!
I am a base class, which defines a paint.

My subclasses represent a concreate paint by implementing my protocol,  that actually draws a specific shapes with me. My subclasses usually backend-specific, but as long as you implement my protocol, any object can be treated as paint:

 - athensFillPath: aPath on: aCanvas
 - athensFillRectangle: aRectangle on: aCanvas
 - asStrokePaint





!
!AthensPaint methodsFor: 'rendering' stamp: ''!
athensFillPath: aPath on: aCanvas 

	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	
	self subclassResponsibility! !

!AthensPaint methodsFor: 'converting' stamp: ''!
asStrokePaintOn: aCanvas
	"default implementation"
	^ aCanvas surface createStrokePaintFor: self! !

!AthensPaint methodsFor: 'rendering' stamp: ''!
athensFillRectangle: aRectangle on: aCanvas
	"This is a terminal method in rendering dispatch scheme
	canvas->shape->paint. See AthensCanvas>>fillShape: "
	
	self subclassResponsibility! !

!AthensPaintMode commentStamp: ''!
A paint mode controls how the incoming color (source) will be transferred to surface (destination).

To set a paint mode for canvas, send a message with corresponding mode name to my instance.
My instance(s) is available via canvas protocol, i.e. 'canvas paintMode'.

For example, to set an 'over' paint mode, use following:

	canvas paintMode over.

If you want to restore original paint mode after performing drawing operations, which may change it, use #restoreAfter: method , i.e. 

	canvas paintMode restoreAfter: [
		.. perform any drawing operations here..
		].

Since different backends may support different set of paint modes, the default implementation in AthensPaintMode for 
all mode setters is to signal an error.
To query a set of available paint modes, supported by backend, use #availableModes message.

!
!AthensPaintMode methodsFor: 'errors' stamp: ''!
notAvailable
	^ self error: 'A requested paint mode is not supported by backend'! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
softLight
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
dest
	"Set 'dest' drawing mode.
	
	Drawing under this mode will ignore the source, as if nothing drawn"
	
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
hardLight
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
in
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
colorDodge
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
hslHue
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
saturate
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
xor
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
lighten
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
source
	"Set 'source' drawing mode.
	
	Drawing under this mode will replace the content with incoming source under the shape boundaries"
	
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
destOut
	
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
add
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
hslLuminosity
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
destOver
	
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
over
	"Set 'over' drawing mode. This is default paint mode.
	
	Drawing under this mode will blend source with destination color using source alpha component"
	
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
destAtop
	
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
exclusion
	self notAvailable! !

!AthensPaintMode methodsFor: 'convenience' stamp: ''!
restoreAfter: aBlock
	"Restore current paint mode after evaluating a block"
	
	self subclassResponsibility! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
darken
	self notAvailable! !

!AthensPaintMode methodsFor: 'capabilities' stamp: ''!
availableModes
	"Answer a collection of paint mode names, currently supported by backend. 
	Different backends may support different sets of paint modes.
	
	You may need to structure your code depending on modes available"
	
	^ #()! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
destIn
	
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
screen
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
multiply
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
colorBurn
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
hslSaturation
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
out
	"Set 'out' painting mode "
	
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
atop
	"Set 'atop' painting mode "
	
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
difference
	self notAvailable! !

!AthensPaintMode methodsFor: 'default mode' stamp: ''!
default
	"Set the default paint mode. The default paint mode in Athens, is 'over' "
	^ self over! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
clear
	"Set 'clear' drawing mode.
	
	Drawing under this mode will clear the surface under the shape boundaries"
	
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
hslColor
	self notAvailable! !

!AthensPaintMode methodsFor: 'modes' stamp: ''!
overlay
	self notAvailable! !

!AthensParagraph commentStamp: ''!
this class is subject of changes/removal. do not use it.!
!AthensParagraph methodsFor: 'selection' stamp: ''!
characterBlockForIndex: index 

	^ self defaultCharacterBlock! !

!AthensParagraph methodsFor: 'selection' stamp: ''!
selectionRects
	^ #()! !

!AthensParagraph methodsFor: 'selection' stamp: ''!
selectionColor: anUndefinedObject 
	self shouldBeImplemented! !

!AthensParagraph methodsFor: 'selection' stamp: ''!
findReplaceSelectionRegex: aRegex
	"	findReplaceSelectionRegex := aRegex. "

	self flag: #pharoToRemove	"This method is only needed for TextMorphForEditView. This class is planned for removal with PluggableTextMorph. When it will be removed, this class can probably be cleaned."! !

!AthensParagraph methodsFor: 'accessing' stamp: ''!
showCaret: abool! !

!AthensParagraph methodsFor: 'accessing' stamp: ''!
focused 
	^ false! !

!AthensParagraph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: canvas bounds: aRectangle 

	| renderer |
	"self halt."
"	canvas
		clipBy: aRectangle 
		during: [  
"			renderer := AthensTextRenderer new.
			renderer render: text lines: lines on: canvas.
"		].
"! !

!AthensParagraph methodsFor: 'selection' stamp: ''!
selectionStart: startBlock selectionStop: stopBlock
	selectionStart := startBlock.
	selectionStop := stopBlock! !

!AthensParagraph methodsFor: 'accessing' stamp: ''!
extent
	^ containerRect width @ lines last bottom! !

!AthensParagraph methodsFor: 'selection' stamp: ''!
defaultCharacterBlock
	^ (CharacterBlock new stringIndex: 1 text: text
			topLeft: 0@0 extent: 0 @ 0)
		textLine: lines first! !

!AthensParagraph methodsFor: 'accessing' stamp: ''!
showCaret! !

!AthensParagraph methodsFor: 'accessing' stamp: ''!
textOwner: anUndefinedObject 
	self shouldBeImplemented! !

!AthensParagraph methodsFor: 'composition' stamp: ''!
compose: aText style: aTextStyle from: startingIndex in: aRectangle 
	text := aText.
	textStyle := aTextStyle
	
	self shouldBeImplemented! !

!AthensParagraph methodsFor: 'private' stamp: ''!
compose: aText style: aTextStyle in: rect 

	text := aText.
	textStyle := aTextStyle.
	containerRect := rect.
	lines := (AthensTextComposer scan: aText for: AthensTextScanner new) lines! !

!AthensParagraph methodsFor: 'selection' stamp: ''!
extraSelectionChanged
	"
	refreshExtraSelection := true
"

	self flag: #pharoToRemove	"This method is only needed for TextMorphForEditView. This class is planned for removal with PluggableTextMorph. When it will be removed, this class can probably be cleaned."! !

!AthensParagraph methodsFor: 'accessing' stamp: ''!
caretRect 

	^ (0@0 corner: 0@0)! !

!AthensParagraph methodsFor: 'selection' stamp: ''!
positionWhenComposed: pos
	positionWhenComposed := pos! !

!AthensParagraph methodsFor: 'accessing' stamp: ''!
focused: bool

	"why we should care?"
	
	"self flag: #ooo"! !

!AthensParagraph methodsFor: 'selection' stamp: ''!
secondarySelection: aSubstring
	"	secondarySelection := aSubstring."

	self flag: #pharoToRemove	"This method is only needed for TextMorphForEditView. This class is planned for removal with PluggableTextMorph. When it will be removed, this class can probably be cleaned."! !

!AthensParagraph methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!AthensPath commentStamp: ''!
This class represents an interface, which should be supported by all paths (special kind of shape) used for drawing with Athens framework.

Path data organization is up to surface where it built,
therefore paths are not interchangeable between different surfaces.

!
!AthensPathBuilder commentStamp: ''!
i am abstract path builder, to specify an interface protocol which is available for building paths,
by using  canvas or surface #createPath: method.!
!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
ccwArcTo: endPt angle: rot
	"Add a counter-clockwise arc segment, starting from current path endpoint and
	ending at andPt. Angle should be specified in radians "
	
	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'creating path' stamp: ''!
createPath:	aBlock
	"aBlock value: self ...."	
	
	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
curveVia: cp1 and: cp2 to: aPoint
	"Add a cubic bezier curve,
	starting from current path endpoint, using control points cp1, cp2
	and ending at aPoint "
	
	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
absolute
	"Next commands will use absolute coordinates for all segment points"
	
	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
curveVia: cp1 to: aPoint
	"Add a quadric bezier curve,
	starting from current path endpoint, using control point cp1, 
	and ending at aPoint "
	
	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
moveTo: aPoint
	"Move command always starts a new contour "
	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
relative
	"Next commands will use relative coordinates for all segment points"
	
	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
reflectedCurveVia: cp2 to: aPoint
	"Add a reflected cubic bezier curve, starting from current path endpoint and ending at aPoint.
	The first control point is calculated as a reflection from the current point, if the last command was also a cubic bezier curve.
	Otherwise, the first control point is the current point. The second control point is cp2."
	
	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
string: aString font: aFont
	"Adds closed paths for the string to the current path"
	
	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
close
	"Close the current path controur"
	
	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
cwArcTo: endPt angle: rot
	"Add a clockwise arc segment, starting from current path endpoint and
	ending at andPt. Angle should be specified in radians "
	

	self subclassResponsibility! !

!AthensPathBuilder methodsFor: 'path commands' stamp: ''!
lineTo: aPoint
	"Add a line segment, starting from current path endpoint to aPoint"
	
	self subclassResponsibility! !

!AthensPathBuilder class methodsFor: 'class initialization' stamp: ''!
initialize
	ZeroPoint := 0@0! !

!AthensPathBuilder class methodsFor: 'instance creation' stamp: ''!
createPath: aBlock

	^ self new createPath: aBlock! !

!AthensPathConverter commentStamp: ''!
i am a base class for path conversion. 
i take a path as input and producing a path commands as output.

My default implementation just passing all path commands without changes to destination without any conversion

Example of use:

 
converter := AthensXYZConverter dest: (AthensPolygonPath new).
convertedPath := converter convert: sourcePath.

You can chain multiple converters:

basicConverter := AthensZYXConv dest: AthensPolygonPath new. 
compoundConverter := AthensABCConverter dest: basicConverter.

compoundConverter convert: somePath

in this case, an initial conversion is performed by instance of AthensABCConverter, and then conversion results are passed down to AthensZYXConv,
and then finally to instance of AthensPolygonPath.
!
!AthensPathConverter methodsFor: 'actions' stamp: ''!
convert: aSourcePath
	
	" iterate over segments and do conversion "
	
	| segment |
	
	segment := aSourcePath.
	
	[ segment notNil ] whileTrue: [
		segment convertWith: self.
		endPoint := segment endPoint.
		segment := segment next.
	].

	^ dest finish! !

!AthensPathConverter methodsFor: 'converting path commands' stamp: ''!
close: aPoint 
	^ dest close: aPoint! !

!AthensPathConverter methodsFor: 'accessing' stamp: ''!
source: aSource dest: aDest

	sourcePath := aSource.
	dest := aDest! !

!AthensPathConverter methodsFor: 'converting path commands' stamp: ''!
curveVia: pt1 to: pt2

	^ dest curveVia: pt1 to: pt2! !

!AthensPathConverter methodsFor: 'converting path commands' stamp: ''!
moveTo: aPoint 
	^ dest moveTo: aPoint! !

!AthensPathConverter methodsFor: 'actions' stamp: ''!
finish
	^ dest finish! !

!AthensPathConverter methodsFor: 'accessing' stamp: ''!
dest: anObject
	dest := anObject! !

!AthensPathConverter methodsFor: 'converting path commands' stamp: ''!
lineTo: aPoint 
	^ dest lineTo: aPoint! !

!AthensPathConverter class methodsFor: 'instance creation' stamp: ''!
source: aSource dest: aDest
	" answer a converted path from source to dest, using my instance as a converter"
	
	^ self new source: aSource dest: aDest! !

!AthensPathConverter class methodsFor: 'instance creation' stamp: ''!
dest: aDest

	^ self new dest: aDest! !

!AthensPathSegment commentStamp: ''!
The path segment is path building block.
Path is formed from list of connected path segments. At building stage, there is no container nor separately defined "path" object, just a linked list of segments.
Later the segments are accumulated in backend-specific path object, and the way how it is organized may vary.

My (sub)instances usually are not created directly by user, but instead by instance
of AthensPathBuilder.
Therefore, all my subclasses are considered private and implementation detail.!
!AthensPathSegment methodsFor: 'accessing' stamp: ''!
next

	^ next! !

!AthensPathSegment methodsFor: 'accessing' stamp: ''!
next: anObject

	next := anObject! !

!AthensPathSegment methodsFor: 'testing' stamp: ''!
isMove
	^ false! !

!AthensPathSegment methodsFor: 'visitor' stamp: ''!
visitWith: visitor

	self subclassResponsibility! !

!AthensPathSegment methodsFor: 'accessing' stamp: ''!
size
	"Answer 1 + the number of segments next to receiver"
	
	| segment count |
	segment := self.
	count := 0.
	[ segment notNil ] whileTrue: [  count := count + 1. segment := segment next ].

	^ count! !

!AthensPathSegment methodsFor: 'iterating' stamp: ''!
do: aBlock
	| segment |
	segment := self.
	
	[ aBlock value: segment. 
	  segment := segment next. 
	  segment notNil ] whileTrue! !

!AthensPathSegment methodsFor: 'visitor' stamp: ''!
convertWith: anObject
	self subclassResponsibility! !

!AthensPathSegment methodsFor: 'testing' stamp: ''!
isCubic
	^ false! !

!AthensPathSegment methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	self subclassResponsibility! !

!AthensPathSegment methodsFor: 'iterating' stamp: ''!
sendCommandsTo: aBuilder

	self do: [ :segment |
		segment sendCommandTo: aBuilder
	]! !

!AthensPathSegmentConverter commentStamp: ''!
this class is subject of changes/removal. do not use it.!
!AthensPathSegmentConverter methodsFor: 'converting' stamp: ''!
convert: aPath
	"pipe the path segments to destination, converting
	segments on the way"
	
	contourStartPt := endPoint := 0@0.
	
	aPath sendCommandsTo: self.! !

!AthensPathSegmentConverter methodsFor: 'accessing' stamp: ''!
dest: aDest
	dest := aDest! !

!AthensPolygon commentStamp: ''!
i am special kind of shape which using only straight line segments, unlike from more generic paths.!
!AthensPolygon methodsFor: 'converting' stamp: ''!
newContour
	contours ifNil: [ contours := OrderedCollection new ].
	
	currentContour := contours add: OrderedCollection new.! !

!AthensPolygon methodsFor: 'converting' stamp: ''!
moveTo: aPoint 
	" create a new contour "
	
	self newContour.
	currentContour add: aPoint.! !

!AthensPolygon methodsFor: 'converting' stamp: ''!
finish
	"Finally convert contours to arrays"
	
	contours := contours collect: [:ea | ea asArray ]! !

!AthensPolygon methodsFor: 'converting' stamp: ''!
lineTo: aPoint 
	currentContour add: aPoint! !

!AthensPolygon methodsFor: 'drawing' stamp: ''!
paintFillsUsing: aPaint on: anAthensCanvas 
	
	"This method is a part of rendering dispatch  Canvas->receiver->paint"
	
	^ aPaint fillPolygon: self on: anAthensCanvas! !

!AthensPolygonTester commentStamp: ''!
I implementing a simple and efficient algorithm to test whether given point
lies withing a polygon or not.

A polygon is a collection of points 1...size.!
!AthensPolygonTester methodsFor: 'testing' stamp: ''!
includesPoint: aPoint
"
Thanks to Google and Randolph Franklin i don't have to reinvent this very simple algorithm.
See [ 1 ] for details, copyrights etc.

[1] http://www.ecse.rpi.edu/Homepages/wrf/Research/Short_Notes/pnpoly.html

"
	| inside testX testY i j size |
	
	inside := false.
	
	i := 1.
	size := polygon size.
	j := size.
	testX := aPoint x.
	testY := aPoint y.
	
	[ i <= size ] whileTrue: [  | pi pj |
		pi := polygon at: i.
		pj := polygon at: j. 
	
		(((pi y > testY) ~= (pj y > testY)) and: [ 
			testX < 
			(
				pj x - pi x
				* (testY - pi y) 
				/ ( pj y - pi y )
				+ pi x 
			)
			 ]) ifTrue: [ inside := inside not ].
	
		j := i.
		i := i + 1.
	 ].
	^ inside! !

!AthensPolygonTester methodsFor: 'accessing' stamp: ''!
polygon: poly

	polygon := poly! !

!AthensProjectiveTransform commentStamp: ''!
I am an extended version of my supeclass, that represents 2D projective transforms in homogeneous coordinates by using a 3x3 matrix.

<Currently I have no use>!
!AthensProjectiveTransform methodsFor: 'transformations' stamp: ''!
transformX: px Y: py
	"Transform x and y coordinates by receiver, and perform perspective division to answer a 2D point."
	| tx ty tw |
	tx := (sx*px +(shx*py) + x).
	ty := (shy*px + (sy*py) + y).
	tw := (w0*px) + (w1*py) + w2.
	^ Point x: tx / tw y: ty / tw! !

!AthensProjectiveTransform methodsFor: 'accessing' stamp: ''!
w1: anObject
	^ w1 := anObject! !

!AthensProjectiveTransform methodsFor: 'accessing' stamp: ''!
w2
	^ w2! !

!AthensProjectiveTransform methodsFor: 'accessing' stamp: ''!
w2: anObject
	w2 := anObject! !

!AthensProjectiveTransform methodsFor: 'accessing' stamp: ''!
w0
	^ w0! !

!AthensProjectiveTransform methodsFor: 'testing' stamp: ''!
isAffineTransform
	^ w0 = 0 and: [ w1 = 0 and: [ w2 = 1 ] ]! !

!AthensProjectiveTransform methodsFor: 'accessing' stamp: ''!
w1
	^ w1! !

!AthensProjectiveTransform methodsFor: 'accessing' stamp: ''!
w0: anObject
	w0 := anObject! !

!AthensProjectiveTransform methodsFor: 'transformations' stamp: ''!
loadIdentity
	"initialize with identity transform"
	super loadIdentity.
	w0 := w1 := 0.0.
	w2 := 1.0! !

!AthensProjectiveTransform methodsFor: 'transformations' stamp: ''!
transform: aPoint
	| px py tx ty tw |
	
	px := aPoint x.
	py := aPoint y.
	"Transform x and y coordinates by receiver, and perform perspective division to answer a 2D point."
	tx := (sx*px +(shx*py) + x).
	ty := (shy*px + (sy*py) + y).
	tw := (w0*px) + (w1*py) + w2.
	^ Point x: tx / tw y: ty / tw! !

!AthensProjectiveTransform methodsFor: 'testing' stamp: ''!
invert
	self isAffineTransform ifTrue: [ ^ super invert ].
	self shouldBeImplemented! !

!AthensProjectiveTransformTest methodsFor: 'tests' stamp: ''!
transformClass
	^ AthensProjectiveTransform! !

!AthensQuadSegment commentStamp: ''!
i represent a quadric Bezier path segment.

Any quadratic spline can be expressed as a cubic (where the cubic term is zero). The end points of the cubic will be the same as the quadratic's.

    CP0 = QP0
    CP3 = QP2 

The two control points for the cubic are:

    CP1 = QP0 + 2/3 *(QP1-QP0)
    CP2 = QP2 + 2/3 *(QP1-QP2) !
!AthensQuadSegment methodsFor: 'accessing' stamp: ''!
to

	^ to! !

!AthensQuadSegment methodsFor: 'visitor' stamp: ''!
visitWith: visitor

	visitor visitQuadSegment: self! !

!AthensQuadSegment methodsFor: 'visitor' stamp: ''!
sendCommandTo: aBuilder
	^ aBuilder curveVia: via to: to! !

!AthensQuadSegment methodsFor: 'accessing' stamp: ''!
endPoint
	^ to! !

!AthensQuadSegment methodsFor: 'initialization' stamp: ''!
from: pt0 via: pt1 to: p

	via := pt1.
	to := p.! !

!AthensQuadSegment methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor quadricBezierSegment: self! !

!AthensQuadSegment methodsFor: 'accessing' stamp: ''!
via

	^ via! !

!AthensQuartzSurface commentStamp: ''!
The Quartz surface is used to render cairo graphics targeting the Apple OS X Quartz rendering system.
!
!AthensQuartzSurface class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: data
	| handle contextHandle |
	handle := data first.
	"	id := data second.  - id is not used "
	contextHandle := data third.
	
	self destroyContextHandle: contextHandle value. 
	self destroySurfaceHandle: handle value! !

!AthensQuartzSurface class methodsFor: 'primitives' stamp: ''!
primImage: aFormat width: aWidth height: aHeight
"Creates a Quartz surface backed by a CGBitmap. The surface is created using the Device RGB (or Device Gray, for A8) color space. All Cairo operations, including those that require software rendering, will succeed on this surface. "
	^ self ffiCall: #(AthensQuartzSurface  cairo_quartz_surface_create (int aFormat,
                                                         int aWidth,
                                                         int aHeight) )! !

!AthensQuartzSurface class methodsFor: 'private' stamp: ''!
registerSurface: quartzSurface
	"we cannot use SurfacePlugin for quartz surfaces"
	
	^ nil! !

!AthensSceneView commentStamp: ''!
i am simple morph for representing some scene.

The scene is any object which implements #renderOn: method,
or a block with single argument.
(an argument passed is an Athens canvas).

I implement a simple view panning and zooming with mouse drag and mouse-wheel (correspondigly).

Example1: open scene view, by passing a simple rendering block.

```
| view |
view  := AthensSceneView new.

view scene: [:canvas |
	canvas surface clear:  Color black.
	canvas setPaint: Color red.
	canvas drawShape: (0@0 corner:120@100)
].
view openInWindow.
```

Example2: open scene view on imported SVG file (note you need 'Athens-SVG' package loaded):

```
| view |
view  := AthensSceneView new.
view scene: (AthensSVGConverter fromFile: 'lion.svg').

view openInWindow.
```!
!AthensSceneView methodsFor: 'zoom animation' stamp: ''!
startZooming: zoom center: center
	| start end |

		
	start := Time millisecondClockValue.
	end := start + 250.

	self setState: #zooming value: {  center. transform copy. zoom. start. end}.

	self startStepping! !

!AthensSceneView methodsFor: 'drawing' stamp: ''!
drawOn: canvas
	| px py |
	canvas fillRectangle: bounds color: self backgroundColor.
	self renderScene.

	surface displayOnMorphicCanvas: canvas at: bounds origin.

"	 translucentImage: surface asForm at: bounds origin."
	
	self showDebugInfo
		ifTrue: [ 
			px := transform x printShowingDecimalPlaces: 3.
			py := transform y printShowingDecimalPlaces: 3.
			canvas
				drawString: 'zoom: ' , (transform sx printShowingDecimalPlaces: 3) , ' pan: ' , px , ' @ ' , py
				at: bounds origin
				font: nil
				color: Color white ]! !

!AthensSceneView methodsFor: 'colors' stamp: ''!
backgroundColor
	^ Color gray! !

!AthensSceneView methodsFor: 'stepping' stamp: ''!
step

	self inState: #zooming do: [ :zoomState |
		| now start end center targetZoom factor |
		now := Time millisecondClockValue.
		start := zoomState at: 4.
		end := zoomState at: 5.
		
		(now between: start and:end) ifFalse: [ now := end.
			self resetState: #zooming.
			self stopStepping ].
		
		transform := (zoomState at: 2) copy.
		center := zoomState at: 1.
		
		factor :=  (now-start)/(end - start ).
		targetZoom := zoomState at: 3.
		targetZoom := 1* (1-factor) + (targetZoom * factor).
		
		transform
			translateBy: center;
			scaleBy:targetZoom;
			translateBy: center negated.
		
	].
	self changed.! !

!AthensSceneView methodsFor: 'state tracking' stamp: ''!
inState: stateName do: aBlock


	^ (state at: stateName ifAbsent: nil) ifNotNil: aBlock! !

!AthensSceneView methodsFor: 'session management' stamp: ''!
createSurface
	| extent |
	extent := self extent asIntegerPoint.
	surface := (scene respondsTo: #createSurface:) 
		ifTrue: [ scene createSurface: extent ] 
		ifFalse: [ AthensCairoSurface extent: extent].! !

!AthensSceneView methodsFor: 'event handling' stamp: ''!
mouseWheel: event


	"Handle a mouseWheel event."
	
	| center zoom  |
	
	center := transform inverseTransform: (event cursorPoint - bounds origin).

	zoom := 1.
	
	event isUp ifTrue: [ zoom := 1.25 ].
	event isDown ifTrue: [ zoom := 1/1.25 ].
	
	
	(self inState: #zooming) ifTrue: [   
		self updateZoom: zoom cursor: event cursorPoint.
	] ifFalse: [
		self startZooming: zoom center: center.
	]! !

!AthensSceneView methodsFor: 'state tracking' stamp: ''!
inState: stateName


	^ (state at: stateName ifAbsent: nil) notNil! !

!AthensSceneView methodsFor: 'event handling' stamp: ''!
mouseLeave: evt
	self 
		resetState: #mouseIn;
		resetState: #panning.! !

!AthensSceneView methodsFor: 'drawing' stamp: ''!
showDebugInfo
	^ true! !

!AthensSceneView methodsFor: 'state tracking' stamp: ''!
setState: stateName value: aValue

	state at: stateName put: aValue.

	"receiver's state changed"
	
	self changed.! !

!AthensSceneView methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt
	^ true! !

!AthensSceneView methodsFor: 'layout' stamp: ''!
layoutChanged 
	"react on morph resize"
	super layoutChanged.
	surface ifNotNil: [  
		self extent asIntegerPoint ~= surface extent ifTrue: [ 
			self createSurface ]
	].! !

!AthensSceneView methodsFor: 'accessing' stamp: ''!
keepRefreshing: aBoolean
	keepRefreshing := aBoolean.
	
	keepRefreshing ifTrue: [  self startStepping ].! !

!AthensSceneView methodsFor: 'event handling' stamp: ''!
mouseMove: evt

	self inState: #panning do: [ :startPanAndPos |
		| delta |
		delta := startPanAndPos first + ( evt cursorPoint - startPanAndPos second ).
		
		transform 
			x: delta x;
			y: delta y.
		self changed.
	]! !

!AthensSceneView methodsFor: 'stepping' stamp: ''!
stepTime
	^ 0! !

!AthensSceneView methodsFor: 'event handling' stamp: ''!
handlesMouseWheel: event
	^ true! !

!AthensSceneView methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	keepRefreshing := false.
	transform := AthensAffineTransform new.
	
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
	color := Color transparent.
	state := Dictionary new.
	self extent: self minimumExtent.! !

!AthensSceneView methodsFor: 'event handling' stamp: ''!
mouseEnter: evt

	self setState: #mouseIn! !

!AthensSceneView methodsFor: 'accessing' stamp: ''!
scene
	^ scene! !

!AthensSceneView methodsFor: 'accessing' stamp: ''!
scene: aScene
	
	scene := aScene.
	
	self changed.! !

!AthensSceneView methodsFor: 'initialization' stamp: ''!
minimumExtent
	^ 300@300! !

!AthensSceneView methodsFor: 'session management' stamp: ''!
initializeForNewSession
	self createSurface.
	session := Smalltalk session.! !

!AthensSceneView methodsFor: 'event handling' stamp: ''!
mouseDown: evt

	| pos |
	
	pos := evt cursorPoint.
	
	"left button"
	evt redButtonPressed ifTrue: [ 
		self setState: #panning value: { transform x@transform y. pos }
		 ].! !

!AthensSceneView methodsFor: 'drawing' stamp: ''!
renderScene

	self checkSession.

	scene ifNotNil: [ 
		surface drawDuring: [ :acanvas | 
			surface clear.
			acanvas pathTransform loadAffineTransform: transform.
			scene isBlock
				ifTrue: [ scene cull: acanvas cull: self ]
				ifFalse: [ scene renderOn: acanvas ] ] ]! !

!AthensSceneView methodsFor: 'zoom animation' stamp: ''!
updateZoom: zoom cursor: cursorPoint

	| zoomState targetZoom start end now fraction newCenter |
	zoomState := state at:#zooming.
		
	"change the target zoom and increase time a bit"
	targetZoom := zoomState at: 3.
	
	start := zoomState at: 4.
	end := zoomState at: 5.
		
	now := Time millisecondClockValue.
	
	(now > end) ifTrue: [  now := end ].
	
	 "interpolate linearly the target zoom factor over time start ... end"
	fraction := (now - start) / (end - start).
	
	"zoom goes from 1..target zoom"
	targetZoom := 1*(1-fraction) + (targetZoom * fraction).

	self step. "to update transform"
	zoomState at: 3 put: targetZoom * zoom.
	newCenter :=   transform inverseTransform: (cursorPoint - bounds origin).
	zoomState at: 1 put: newCenter.
	zoomState at: 2 put: transform copy.
	zoomState at: 4 put: now.
	zoomState at: 5 put: now + 250 .! !

!AthensSceneView methodsFor: 'session management' stamp: ''!
checkSession
	session == Smalltalk session ifFalse: [ 
		self initializeForNewSession ]! !

!AthensSceneView methodsFor: 'stepping' stamp: ''!
stopStepping
	keepRefreshing ifFalse: [
			^ super stopStepping ]! !

!AthensSceneView methodsFor: 'event handling' stamp: ''!
mouseUp: evt

	"self halt."
	
	self resetState: #panning! !

!AthensSceneView methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^ true! !

!AthensSceneView methodsFor: 'state tracking' stamp: ''!
resetState: stateName

	state at: stateName put: nil.

	"receiver's state changed"
	
	self changed.! !

!AthensSceneView methodsFor: 'state tracking' stamp: ''!
setState: stateName

	state at: stateName put: true.

	"receiver's state changed"
	
	self changed.! !

!AthensShadowPaint commentStamp: ''!
I representing a shadow paint object used by Athens.
My subclasses provide backend-specific implementation.
I am more serving to define the common protocols and
requirements for all backends (such as defaults).


IMPORTANT NOTE: a shadow paint object provides a protocol 
only for setting shadow properties, but not retrieving them back.
This is intentionally, because the way how these properties is
managed are highly backend-specific. 

The shadow paint has following properties:
 - color. A shadow color defined in RGBA color space.

	Default: Color black alpha: 0.5

 - shadow width. Can be set using #width:

	Default: if width is not set explicitly for shadow paint,
		it is assumed to be equal to 2.0.
		
 - shadow offset. Defines how far shadow is located.
	Shadow offset is a point where x component defines ofset on x-asix and y component on y-axis.
	
	Default: if offset is not set  explicitely it is assumed to be equal 2@2.
			
 - shadow blur. Defines how smooth shadow is.
	Blur is a point with x component defining bluring along x-axis and y component along y axis
	
	Default: if blur is not set explicitely it is assumed to be equal 4@4
!
!AthensShadowPaint methodsFor: 'accessing' stamp: ''!
color: aColor
	color := aColor! !

!AthensShadowPaint methodsFor: 'accessing' stamp: ''!
width: aNumber
	"Set shadow width"
	width := aNumber! !

!AthensShadowPaint methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!AthensShadowPaint methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.	
	self setDefaults! !

!AthensShadowPaint methodsFor: 'accessing' stamp: ''!
offset: aPoint
	"Set shadow offset"
	offset := aPoint! !

!AthensShadowPaint methodsFor: 'accessing' stamp: ''!
blur: aPoint
	"Set shadpw blur"
	blur := aPoint! !

!AthensShadowPaint methodsFor: 'converting' stamp: ''!
asStrokePaintOn: aCanvas
	"receiver can be converted to stroke paint
	presering color and width"
	^ (aCanvas surface createStrokePaintFor: self color)
		width: self width! !

!AthensShadowPaint methodsFor: 'initialization' stamp: ''!
setDefaults

	"Set the default values for shadows"
	self
		color: (Color black alpha: 0.5);
		width: 2;
		offset: 2@2; 
		blur: 4@4! !

!AthensShadowPaint methodsFor: 'accessing' stamp: ''!
offset
	^ offset! !

!AthensShadowPaint methodsFor: 'accessing' stamp: ''!
blur
	^ blur! !

!AthensShadowPaint methodsFor: 'accessing' stamp: ''!
color
	^ color! !

!AthensShape commentStamp: ''!
This class represents an interface, which should be supported by all shapes used for drawing with Athens framework.

Shapes do not have to inherit directly from me, for example Rectangle implements my protocol (via extensions), and as result can be used as a valid shape for drawing with Athens.!
!AthensShape methodsFor: 'converting' stamp: ''!
asAthensShapeOn: canvas
	"Receiver is a shape, no conversion is needed."
	^ self! !

!AthensShape methodsFor: 'drawing' stamp: ''!
paintFillsUsing: aPaint on: anAthensCanvas 
	"This method is a part of rendering dispatch  Canvas->receiver->paint"
	
	self subclassResponsibility! !

!AthensSimplePathBuilder commentStamp: ''!
i building path containing from AthensPathSegment. 
the resulting path is backend neutral (while different backend may implement own builder which is more efficient)!
!AthensSimplePathBuilder methodsFor: 'path commands' stamp: ''!
ccwArcTo: endPt angle: rot
	" angle should be specified in radians "
	^ self addSegment: (AthensCCWArcSegment new endPoint: (self toAbsolute: endPt) angle: rot)! !

!AthensSimplePathBuilder methodsFor: 'initialization' stamp: ''!
initialize
	"A new path always starts from implicit (moveTo:0@0) segment.
	If next segment is moveTo: , the point of already existing move segment will be changed,
	avoiding creating extra move segments.
	
	"
	super initialize.
	absolute := false.
	contourStartPt := ZeroPoint.
	pathStart := lastSegment := (AthensMoveSegment new  point: ZeroPoint).! !

!AthensSimplePathBuilder methodsFor: 'accessing' stamp: ''!
pathBounds
	^ xMin@yMin corner: xMax@yMax! !

!AthensSimplePathBuilder methodsFor: 'private' stamp: ''!
toAbsolute: aPoint
	| pt |
	pt := absolute 
		ifTrue: [ aPoint ]
		ifFalse: [ lastSegment endPoint + aPoint ].

	"note the coordinate to calculate the path's bounding box"
	xMin ifNil: [
		xMin := xMax := pt x.
		yMin := yMax := pt y.	
		] 
	ifNotNil: [
		xMin := pt x min: xMin.
		yMin := pt y min: yMin.
		xMax := pt x max: xMax.
		yMax := pt y max: yMax.	
	].
	^ pt! !

!AthensSimplePathBuilder methodsFor: 'creating path' stamp: ''!
createPath:	aBlock
	"aBlock value: self ...."	
	aBlock value: self.
	
	^ pathStart! !

!AthensSimplePathBuilder methodsFor: 'private' stamp: ''!
addSegment: aSegment
	lastSegment next: aSegment.
	lastSegment := aSegment! !

!AthensSimplePathBuilder methodsFor: 'path commands' stamp: ''!
absolute
	absolute := true! !

!AthensSimplePathBuilder methodsFor: 'path commands' stamp: ''!
curveVia: cp1 and: cp2 to: aPoint
	"Cubic bezier curve"
	
	| pt1 pt2 pt3 |
	"Quad bezier curve"

	pt1 := self toAbsolute: cp1.
	pt2 := self toAbsolute: cp2.
	pt3 := self toAbsolute: aPoint.
	^ self addSegment: (
		AthensCubicSegment new 
			from: lastSegment endPoint 
			via: pt1
			and: pt2
			to: pt3)! !

!AthensSimplePathBuilder methodsFor: 'path commands' stamp: ''!
curveVia: cp1 to: aPoint
	| pt1 pt2 |
	"Quad bezier curve"

	pt1 := self toAbsolute: cp1.
	pt2 := self toAbsolute: aPoint.
	^ self addSegment: (
		AthensQuadSegment new 
			from: lastSegment endPoint 
			via: pt1 
			to: pt2)! !

!AthensSimplePathBuilder methodsFor: 'path commands' stamp: ''!
moveTo: aPoint
	"Move command always starts a new contour "
	contourStartPt := self toAbsolute: aPoint.
	
	"Collapse multiple moves to a single one"
	lastSegment isMove ifTrue: [
		lastSegment point: contourStartPt.
		^ self
	].

	self addSegment: (AthensMoveSegment new point: contourStartPt; reopen: open).
	open := true! !

!AthensSimplePathBuilder methodsFor: 'path commands' stamp: ''!
reflectedCurveVia: cp2 to: aPoint
	"Reflected cubic bezier curve"
	
	| pt1 pt2 pt3 |

	pt2 := self toAbsolute: cp2.
	pt1 := lastSegment isCubic
		ifTrue: [ lastSegment via2reflected ]
		ifFalse: [ lastSegment endPoint ].
	pt3 := self toAbsolute: aPoint.
	^ self addSegment: (
		AthensCubicSegment new 
			from: lastSegment endPoint 
			via: pt1
			and: pt2
			to: pt3)! !

!AthensSimplePathBuilder methodsFor: 'path commands' stamp: ''!
relative
	absolute := false! !

!AthensSimplePathBuilder methodsFor: 'path commands' stamp: ''!
close
	"Close the current contour"	
	self addSegment: (AthensCloseSegment new point: contourStartPt).

	contourStartPt := nil.
	open := false! !

!AthensSimplePathBuilder methodsFor: 'path commands' stamp: ''!
cwArcTo: endPt angle: rot
	"Angle should be specified in radians"
	^ self addSegment: (AthensCWArcSegment new endPoint: (self toAbsolute: endPt) angle: rot).! !

!AthensSimplePathBuilder methodsFor: 'path commands' stamp: ''!
lineTo: aPoint

	^ self addSegment: (AthensLineSegment new point: (self toAbsolute: aPoint)).! !

!AthensSimplePathBuilder methodsFor: 'accessing' stamp: ''!
pathStart
	^ pathStart! !

!AthensSimpleTreeNode commentStamp: ''!
A node in an AthensTreeView!
!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
color: aColor
	color := aColor! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
midTop
	^ originX +(extent x *0.5) @ originY! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
width
	
	^ extent x! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
originY
	^ originY! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
box: anObject
	
	box := anObject! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
originX
	^ originX! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
children
	^ children! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
subject: anObject
	
	subject := anObject! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
extent
	
	^ extent! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
originY: aNumber
	originY := aNumber! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
subject
	
	^ subject! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
height
	
	^ extent y! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
children: aCollection

	children := aCollection! !

!AthensSimpleTreeNode methodsFor: 'private' stamp: ''!
layoutHorizontally: center
	| pos |
	"position ourselves in the middle X"
	originX := center - (self width * 0.5).
	
	"childs"
	pos := center - (self layoutWidth *0.5).
	
	children do: [ :each |
		each layoutHorizontally: pos + (each layoutWidth *0.5).
		pos := pos + each layoutWidth + self spacingBetweenChilds. 
	]! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
midBottom
	^ originX +(extent x *0.5) @ (originY + extent y)! !

!AthensSimpleTreeNode methodsFor: 'rendering' stamp: ''!
renderOn: aCanvas

	aCanvas setPaint: color.
	aCanvas drawShape: (originX @ originY extent: extent).
"	children do: [ :each |
		each renderOn: aCanvas
	].
	[  ^ self ] value.
	"
	children do: [ :each | | path |
		
		"we cache the path connecting each child and its parent, to not recreate it each time"
		path := aCanvas cacheAt: each ifAbsentPut: [ 
			| midTop midBot |
			
			midTop := self midBottom.
			midBot := each midTop.
			
			aCanvas createPath: [:builder | 
				builder 
					absolute;
					moveTo: self midBottom;
					curveVia: midTop x@midBot y and: midBot x@ midTop y to: midBot
					"lineTo: each midTop"
			]].

		aCanvas setStrokePaint: (Color red alpha:0.5).
		aCanvas drawShape: path. 
		
		each renderOn: aCanvas
	]! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
layoutWidth 

	^ layoutWidth ifNil: [  
		| childWidth |

		childWidth := 0.
		children isEmpty ifFalse: [  
			children do: [ :each | childWidth := childWidth + each layoutWidth  ].
			childWidth := childWidth + (self spacingBetweenChilds * (children size-1)).
		].

		layoutWidth := self width max: childWidth.
	].! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
box
	
	^ box! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
extent: anObject
	
	extent := anObject! !

!AthensSimpleTreeNode methodsFor: 'accessing' stamp: ''!
color
	^ color! !

!AthensSimpleTreeNode methodsFor: 'defaults' stamp: ''!
spacingBetweenChilds
	^ 10! !

!AthensStrikeFontRenderer commentStamp: ''!
I am used to render font with cairo "toy" text api if no freetype
font is used.


AthensCairoSurfaceExamples exampleDrawText!
!AthensStrikeFontRenderer methodsFor: 'rendering' stamp: ''!
renderCharacters: aString from: start to: end
	| cairoText |
	aString isEmpty
		ifTrue: [ ^ self ].
	cairoText := self createCairoText: (aString copyFrom: start to: end).
	canvas paint loadOnCairoCanvas: canvas.
	canvas newPath.
	cairoText drawOn: canvas! !

!AthensStrikeFontRenderer methodsFor: 'accessing' stamp: ''!
canvas: aCanvas
	canvas := aCanvas! !

!AthensStrikeFontRenderer methodsFor: 'accessing' stamp: ''!
font
	
	^ font! !

!AthensStrikeFontRenderer methodsFor: 'accessing' stamp: ''!
font: anObject
	
	font := anObject! !

!AthensStrikeFontRenderer methodsFor: 'private' stamp: ''!
createCairoText: aString
	| fdesc at |
	at := AthensCairoText new.
	at text: aString.
	fdesc := font asAthensFontDescription.
	at readFrom: fdesc.
	^ at! !

!AthensStrikeFontRenderer class methodsFor: 'instance creation' stamp: ''!
on: aCanvas forFont: aFont
	^ self new canvas: aCanvas; font: aFont; yourself! !

!AthensStrokePaint commentStamp: ''!
I representing a stroke paint object used by Athens.
My subclasses provide backend-specific implementation.
I am more serving to define the common protocols and
requirements for all backends (such as defaults).


IMPORTANT NOTE: a stroke paint object provides a protocol 
only for setting stroke properties, but not retrieving them back.
This is intentionally, because the way how these properties is
managed are highly backend-specific. 

The stroke paint has following properties:
 - fill paint. A paint to use for filling strokes.
	Can be any athens basic paint, except from stroke one.

 - stroke width. Can be set using #width:

	Default: if width is not set explicitly for stroke paint,
		it is assumed to be equal to 1.0.
		
 - join style. 
		Currently there are 3 kinds of joins supported:
			bevel
			miter
			round
		To set join style for paint, use 
			#joinBevel, #joinMiter or #joinRound methods.

	Default: if join style is not explicitly set for stroke paint,
		it will use bevel join style.

 - cap style
		supported: butt, round and square.
		To set cap style, use
			#capButt, #capRound or #capSquare methods.

	Default: if cap style is not explicitly set for stroke paint,
		it will use butt cap style.

 - miter limit, set with #miterLimit: accessor.
	(default and meaning of limit is not yet determined)

Dashes: 
	stroke can use dashing. 
	Dash is special kind of stroke which won't draw a continuous
	stroke connecting path segments, but instead stroke with
	alternating fill-gap style , defined by provided input.
	
	Protocol:
	
	paint 
		dashes: dashPattern 
		offset: anOffset.
		
	The dash pattern is a simple 
	collection of alternating lengths, like: 
	#("fill" 50 "gap" 50) 
	
	in this example , first 50 length units of path
	will be filled with stroke, and next 50 will be skipped,
	forming a gap, then again filled and again skipped,
	and so on until path ends.
	The dash pattern can contain as many length elements
	as needed. Just remember that each odd element represents
	length to fill with stroke, and each even element, length to skip,
	while traversing along the path.
	
	The offset controls the shift in length units, 
	relative to path start.
	
	Default: if dash is not explicitly set for stroke paint,
		it will fill the path using continuous stroke (no gaps). !
!AthensStrokePaint methodsFor: 'accessing' stamp: ''!
width: anObject
	"set the stroke width"
	width := anObject! !

!AthensStrokePaint methodsFor: 'setting - cap styles' stamp: ''!
capSquare
	"Set this paint to use square cap style"
	self subclassResponsibility! !

!AthensStrokePaint methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!AthensStrokePaint methodsFor: 'setting - cap styles' stamp: ''!
capRound
	"Set this paint to use round cap style"
	self subclassResponsibility! !

!AthensStrokePaint methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self setDefaults! !

!AthensStrokePaint methodsFor: 'setting - join styles' stamp: ''!
joinBevel
	"Set receiver to use bevel join style"
	self subclassResponsibility! !

!AthensStrokePaint methodsFor: 'setting - dashes' stamp: ''!
dashes: anAlternateCollectionOfLenghts offset: anOffset
	
	'self dashes: #( "fill" 20  "gap" 10 "fill" 35 "gap" 30) offset: 0. '.
	
	self subclassResponsibility! !

!AthensStrokePaint methodsFor: 'accessing' stamp: ''!
fillPaint: anObject

	fillPaint := anObject! !

!AthensStrokePaint methodsFor: 'converting' stamp: ''!
asStrokePaintOn: aCanvas
	"receiver is stroke paint already"
	^ self! !

!AthensStrokePaint methodsFor: 'setting - join styles' stamp: ''!
joinMiter
	"Set receiver to use miter join style"
	self subclassResponsibility! !

!AthensStrokePaint methodsFor: 'initialization' stamp: ''!
setDefaults

	"Set the default values for strokes"
	width := 1.
	self 
		capButt; 
		joinBevel;
		miterLimit: 4.0! !

!AthensStrokePaint methodsFor: 'accessing' stamp: ''!
miterLimit: anObject

	miterLimit := anObject! !

!AthensStrokePaint methodsFor: 'setting - cap styles' stamp: ''!
capButt
	"Set this paint to use butt cap style"
	self subclassResponsibility! !

!AthensStrokePaint methodsFor: 'setting - join styles' stamp: ''!
joinRound
	"Set receiver to use round join style"
	self subclassResponsibility! !

!AthensSurface commentStamp: ''!
I representing a surface, where all drawing operations will happen.

I also having a number of factory methods to create paints, paths and other objects involved in drawing.

AthensSurface is an abstract, while subclasses implement a specific kind of surface for one or another backend.

The primary role of AthensSurface class is to define a public protocol for all Athens surfaces, which can be used by applications which using Athens framework.

To get a new surface, use:

<one of my subclasses> extent: x@y

for surfaces which don't need to have dimensions specified,
it would just #new.!
!AthensSurface methodsFor: 'caching' stamp: ''!
cacheAt: anObject ifAbsentPut: aBlock
	"Answer an object from surface's cache identified by anObject,
	if there is no cached object under such identifier, evaluate a block
	and put it into cache. Then answer the result of evaluation.
	A surface using identity comparison for object identifiers.
	"

	self subclassResponsibility! !

!AthensSurface methodsFor: 'private' stamp: ''!
newCanvas
	"Answer a preinitialized instance of AthensCanvas.
	Private to receiver and its subclasses, override seldom"
	^ AthensCanvas on: self! !

!AthensSurface methodsFor: 'clipping' stamp: ''!
clipBy: aRectangle during: aBlockClosure 
	self subclassResponsibility.! !

!AthensSurface methodsFor: 'paints' stamp: ''!
createRadialGradient: colorRamp center: aCenter radius: aRadius
	"by default, focal point coincede with center"
	^ self createRadialGradient: colorRamp center: aCenter radius: aRadius focalPoint: aCenter! !

!AthensSurface methodsFor: 'masking' stamp: ''!
maskEnabled
	self subclassResponsibility! !

!AthensSurface methodsFor: 'paths' stamp: ''!
createRectanglePath: aRectangle 
	^ aRectangle! !

!AthensSurface methodsFor: 'masking' stamp: ''!
enableMask
	self subclassResponsibility! !

!AthensSurface methodsFor: 'masking' stamp: ''!
disableMask
	self subclassResponsibility! !

!AthensSurface methodsFor: 'private' stamp: ''!
releaseCanvas
	currentCanvas := nil! !

!AthensSurface methodsFor: 'paints' stamp: ''!
createStrokePaintFor: aPaint
	 "Answer an instance of AthensPaint, valid for use as stroke paint on receiver,
	using an argument, paint for fills"
	
	self subclassResponsibility! !

!AthensSurface methodsFor: 'converting' stamp: ''!
asMorph
	"Answer a Morph, given this Athens surface"
	^ self asForm asMorph! !

!AthensSurface methodsFor: 'paints' stamp: ''!
createShadowPaint: aColor 
	 "Answer an instance of AthensPaint, valid for use with given surface"
	
	self subclassResponsibility! !

!AthensSurface methodsFor: 'paints' stamp: ''!
createLinearGradient: colorRamp start: pt1 stop: pt2
 
	"This protocol is deprecated. Use #createLinearGradient: start:stop: instead"
	
	
	self shouldNotImplement! !

!AthensSurface methodsFor: 'paths' stamp: ''!
createPath: aPathBuilder
	"Create a path from provided path builder instance"
	self subclassResponsibility! !

!AthensSurface methodsFor: 'paints' stamp: ''!
createFormPaint: aForm 
	self subclassResponsibility.! !

!AthensSurface methodsFor: 'paints' stamp: ''!
createRadialGradient: colorRamp center: aCenter radius: aRadius focalPoint: fp
 
	self subclassResponsibility! !

!AthensSurface methodsFor: 'public' stamp: ''!
drawDuring: aBlock

	"You may draw on receiver only when inside a block and only using provided canvas object.
	This ensures releasing system resources used after finishing drawing"


	currentCanvas ifNotNil: [ self attemptToRecurseDrawing ].
	
	[
		currentCanvas := self newCanvas.
		aBlock value: currentCanvas.
	] ensure: [
		self releaseCanvas.
		currentCanvas := nil.
	].! !

!AthensSurface methodsFor: 'rendering dispatch' stamp: ''!
fillPath: aPath withSolidColor: aColor 

	self subclassResponsibility! !

!AthensSurface methodsFor: '*Athens-Morphic' stamp: ''!
displayOnMorphicCanvas: canvas at: aPoint
	"display receiver on morphic canvas"
	self subclassResponsibility! !

!AthensSurface methodsFor: 'public' stamp: ''!
clear: clearColor
	"clear the surface"
	
	self subclassResponsibility! !

!AthensSurface methodsFor: 'rendering dispatch' stamp: ''!
fillRectangle: aRectangle withSolidColor: aColor

	self subclassResponsibility! !

!AthensSurface methodsFor: 'paints' stamp: ''!
createMeshGradientWithPatches: aListOfMeshPatches 
	self subclassResponsibility.! !

!AthensSurface methodsFor: 'public' stamp: ''!
clear
	"clear the surface"
	
	self subclassResponsibility! !

!AthensSurface methodsFor: 'caching' stamp: ''!
flushCacheAt: anObject

	"Flush (delete) any cached value(s) identified by given object, anObject.
	A surface using identity comparison for object identifiers.

	Answer receiver.
	"

	self subclassResponsibility! !

!AthensSurface methodsFor: 'converting' stamp: ''!
asForm
	"Answer a Form , which contains a bits, converted from surface "
	self subclassResponsibility! !

!AthensSurface methodsFor: 'paints' stamp: ''!
createSolidColorPaint: aColor 
	 "Answer an instance of AthensPaint, valid for use with given surface"
	
	self subclassResponsibility! !

!AthensSurface class methodsFor: 'instance creation' stamp: ''!
extent: aPoint
	"Create a new surface with given extent. 
	Note that some surfaces may not support this method, since they may represent an infinite surface."
	
	self subclassResponsibility! !

!AthensSurfaceExamples commentStamp: ''!
See examples on the class side and on class side of subclasses!
!AthensSurfaceExamples methodsFor: 'surface management' stamp: ''!
createSurface: anExtent
	^ self class newSurface: anExtent! !

!AthensSurfaceExamples methodsFor: 'accessing' stamp: ''!
renderBlock
	
	^ renderBlock! !

!AthensSurfaceExamples methodsFor: 'rendering' stamp: ''!
renderOn: aCanvas
	renderBlock value: aCanvas! !

!AthensSurfaceExamples methodsFor: 'accessing' stamp: ''!
renderBlock: anObject
	
	renderBlock := anObject! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleCoonsPatch2
	| surface meshPaint |
	surface := AthensCairoSurface extent: 300@300.
	meshPaint := MeshGradientPaint new
		buildPatchWith: [ :patchBuilder |
			patchBuilder
				moveTo: 0@0;
				curveVia: 30@ -30 and: 60@30 to: 100@0;
				curveVia: 60@  30 and: 130@60 to: 100@100;
				curveVia: 60@  70 and: 30@130 to: 0@100;
				curveVia: 30@  70 and: -30@30 to: 0@0;
				colors: { Color red . Color green . Color blue . Color yellow}
		].
			
	surface drawDuring: [ :canvas |
		canvas surface clear: Color white.
		canvas pathTransform translateBy: 100@100.
		
		canvas
			setPaint: meshPaint;
			setShape: (-100 @ -100 extent: 300@300);
			draw
	].

	surface asForm asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleNestedClip

	| surf |
	surf := self newSurface: 100@100.
	
	surf drawDuring: [:can |
		surf clear.
		can pathTransform loadIdentity.
		can setPaint: (Color blue).
		can drawShape: (0@0 corner: 100@ 100).

		can pathTransform translateX: -20 Y: -20.
		can clipBy: (20@20 corner: 80@80) during: [
			can pathTransform
				translateX: 20 Y: 20;
				rotateByDegrees: -20.
			can setPaint: (Color red).
			can drawShape: (0@0 corner: 100@ 100).

			can clipBy: (20@20 corner: 80@80) during: [
				can pathTransform translateX: 20 Y: 20.
				can setPaint: (Color green).
				can drawShape: (0@0 corner: 100@ 100).
			]
		]
	].

	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example1

	self openViewOn: [ :can |
		can pathTransform restoreAfter: [ 

			can pathTransform translateX: 30 Y: 30.
			can pathTransform rotateByDegrees: 35.
			can setPaint: (Color red).
			
			can setShape: (-20@ -20 corner: 20@ 20).
			2 timesRepeat: [ can draw. can setPaint: (Color green alpha:0.5)].
			].
	].! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleConicalGradient
	| surface meshGradient center radius sliceCount sliceSize colorAngleOffset |
	surface := AthensCairoSurface extent: 512@512.
	colorAngleOffset := -90.0.
	sliceCount := 16.
	sliceSize := Float twoPi / sliceCount.
	center := 256@256.
	radius := 256.
	
	meshGradient := MeshGradientPaint new.
	0 to: sliceCount - 1 do: [ :sliceIndex |
		| sliceStartAngle sliceEndAngle sliceStartCenterColor sliceStartRadiusColor sliceEndCenterColor sliceEndRadiusColor |
		sliceStartAngle := sliceIndex * sliceSize.
		sliceEndAngle := (sliceIndex + 1) * sliceSize.
		
		sliceStartCenterColor := Color h: sliceStartAngle radiansToDegrees + colorAngleOffset s: 0.0 v: 1.0.
		sliceStartRadiusColor := Color h: sliceStartAngle radiansToDegrees + colorAngleOffset s: 1.0 v: 1.0.
		sliceEndCenterColor := Color h: sliceEndAngle radiansToDegrees + colorAngleOffset s: 0.0 v: 1.0.
		sliceEndRadiusColor := Color h: sliceEndAngle radiansToDegrees + colorAngleOffset s: 1.0 v: 1.0.
		
		meshGradient addCircleSliceCenter: center radius: radius startAngle: sliceStartAngle endAngle: sliceEndAngle colors: {
			sliceStartCenterColor . sliceStartRadiusColor.
			sliceEndRadiusColor . sliceEndCenterColor.
		}
	].
			
	surface drawDuring: [ :canvas |
		canvas surface clear: Color white.
		
		canvas
			setPaint: meshGradient;
			setShape: (0@0 extent: 512@512);
			draw
	].

	surface asForm asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example6stroke
	"Draw two rectangles, stoked by linear gradient. 

	 Note that it should produce same rectangles with exact same fills, because gradient paint 
	 coordinates are affected by pathTransform matrix."
	
	| surf paint |	
	surf := self newSurface: 100@100.
	
	paint := surf 
		createLinearGradient: { 0->Color red. 1->Color green } 
		start: 0@0 
		stop: 50@50.
	
	surf drawDuring: [:can | | stroke |
		surf clear.
		
		stroke := can setStrokePaint: paint.
		stroke width: 4.
		can drawShape: (0@0 corner: 50@50).
		
		can pathTransform translateX: 50 Y: 50.
		can drawShape: (0@0 corner: 50@50) ].

	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleGouraudTriangle
	| surface meshPaint |
	surface := AthensCairoSurface extent: 512@512.
	meshPaint := MeshGradientPaint new
		addTriangleWithPoints: { 256@50 . 450@450 . 50@450 }
			colors: { Color red . Color green . Color blue}.
			
	surface drawDuring: [ :canvas |
		canvas surface clear: Color white.
		
		canvas
			setPaint: meshPaint;
			setShape: (50@50 extent: 400@400);
			draw
	].

	surface asForm asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example5
	"Draw a hollow rectangle (frame) using lineTo/moveTo commands,
 	 with path, consisting of two contours: outer and inner one.

	 Note how #moveTo: command implicitly starts new contour
	 when inssued in the middle of command chain."
	
	| surf |	
	surf := self newSurface: 100@100.
	
	surf drawDuring: [:can |
		surf clear.
		
		can setPaint: Color blue.
		
		can drawShape: (
			can createPath: [:path |
				path 
					absolute;
					lineTo: 50@0;
					lineTo: 50@50;
					lineTo: 0@50;
					moveTo: 10@10;
					lineTo: 10@40;
					lineTo: 40@40;
					lineTo: 40@10
			])
	].

	surf asMorph openInWindow.! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example4
	" 
	This example demostrates that same path could be reused multiple times when drawing.
	First, we creating a path, and later we can use it in #drawShape: command."

	| surf path |
	
	surf := self newSurface: 100@100.
	
	path :=  surf createRectanglePath: (0@ 0 corner: 20@ 20).
	
	surf drawDuring: [:can |
		surf clear.
		can pathTransform loadIdentity.
		can setPaint: (Color red).
		can pathTransform translateX: 5 Y: 5.
		can drawShape: path.
		can setPaint: (Color blue).
		can pathTransform translateX: 5 Y: 5.
		can drawShape: path.
	].

	surf asMorph openInWindow.! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example3
	"Draw simple filled path, changing the transformation and colors to get some animated effects."
	
	| surf |	
	surf := self newSurface: 800@800.
	
	surf drawDuring: [:can | | path |	
		can setPaint: Color blue.

		can pathTransform translateX: 200 Y: 200.	
		can pathTransform scaleBy: 6.

		path := can createPath: [:pathbuilder |
			pathbuilder 
				absolute;
				moveTo: -25 @ -25;
				curveVia: 25@ -25 to: 25@25;
				curveVia: -25@25 to: -25@ -25
		].
		
		1 to: 1000 do: [:i |
			can setPaint: Color random.

			can pathTransform restoreAfter: [
				can pathTransform rotateByDegrees: i*5.
				can pathTransform scaleBy: (1 - (i/2000)).
				can drawShape: path ].			
		]	
	].

	surf asMorph openInWindow.! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleDrawText
 
	| surf  font |
	font := LogicalFont familyName: 'Arial' pointSize: 20.

	surf := self newSurface: 300@100.
	
	surf drawDuring: [:can |
		"clear background"
		surf clear: Color white.

		"set font and color"
		can setFont: font.
		can setPaint: Color black.
		
		"translate an origin by font's ascent, otherwise 
		we will see only things below baseline"
		can pathTransform translateX: 0 Y: (font getPreciseAscent).
		can drawString: 'Hello Athens!!' ].
	
	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example8
	"Draw a rectangle filled by radial gradient."
	| surf paint |
	
	surf := self newSurface: 200@200.	
	paint := surf 
		createRadialGradient: { 0->Color red. 1->Color green } 
		center: 100@100
		radius: 100.
	
	surf drawDuring: [:can |
			surf clear.

			can pathTransform loadIdentity.
			can setPaint: paint.

			can drawShape: (0@0 corner: 200@200)].

	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example2
	"Draw a path on surface."
	
	self openViewOn: [ :can |
		can setPaint: Color blue.
		
		can drawShape: (
			can createPath: [:path |
				path 
					absolute;
					lineTo: 50@0;
					lineTo: 50@50;
					lineTo: 0@100
			])	
	]! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example3stroke
	"Draw simple stroke  path, changing the transformation and colors to get some animated effects."

	| surf |
	surf := self newSurface: 400@400.
	
	surf drawDuring: [:can | |  path |
		(can setStrokePaint: Color blue) width: 1.

		can pathTransform translateX: 200 Y: 200.	
		can pathTransform scaleBy: 5.

		path := can createPath: [:pathbuilder |
				pathbuilder 
					absolute;
					moveTo: -25 @ -25;
					curveVia: 25@ -25 to: 25@25;
					curveVia: -25@25 to: -25@ -25 ].
		
		1 to: 1000 do: [:i |
			(can setStrokePaint: Color random) width: 1.
			can pathTransform restoreAfter: [
				can pathTransform rotateByDegrees: i*5.
				can pathTransform scaleBy: (1- ( i/2000)).
				can drawShape: path.
			]
		]	
	].

	surf asMorph openInWindow.! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleDrawForm
 
	| surf surf2   |
	surf2 := self newSurface: 100@100.
	surf2 drawDuring: [:c |
		c setPaint: (Color red alpha: 0.5) .
		c drawShape: (0@0 corner: 100@100).
		].
	
	surf := self newSurface: 300@300.
	
	surf drawDuring: [:can |
		surf clear.
		can pathTransform loadIdentity.

		can setShape: (0@0 corner: 300@300).
		can setPaint: Color black.
		can draw.
		can pathTransform translateX: 30 Y: 30. 
		can setPaint: surf2.
		can draw.

		can pathTransform translateX: 30 Y: 30. 
		can draw ].
	
	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleDrawForm2
 
	| surf  |		
	surf := self newSurface: 300@300.
		
	surf drawDuring: [:can |
		surf clear.
		can pathTransform loadIdentity.

		can setShape: (0@0 corner: 300@300).
		can setPaint: Color black.
		can draw.
		can pathTransform scaleBy: 0.5;
		 translateX: 60 Y: 60. 
		(can setPaint: (self iconNamed: #helpIcon)) repeat.
		can paintTransform scaleBy: 3; rotateByDegrees: 30.
		can draw ].
	
	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example7
	"Draw two rectangles, filled by linear gradient. 
	 Rotate the gradient in a loop.

	 Note that it should produce same rectangles with exact same fills, because gradient paint 
	 coordinates are affected by pathTransform matrix."

	| surf paint |	
	surf := self newSurface: 100@100.
	
	paint := surf 
		createLinearGradient: { 0->Color red. 1->Color green } 
		start: 0@0 
		stop: 50@50.
	
	surf drawDuring: [:can |

		1 to: 10000 do: [:i |

			can pathTransform loadIdentity.

			can paintTransform loadIdentity translateX: 15 Y: 15; rotateByDegrees: (i/10000 * 360).		
			can setPaint: paint.

			can drawShape: (0@0 corner: 50@50).
		
			can pathTransform translateX: 50 Y: 50.
			can drawShape: (0@0 corner: 50@50).
			
		].		
	].
	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleClip

	| surf |
	surf := self newSurface: 100@100.
	
	surf drawDuring: [:can |
		surf clear.
		can pathTransform loadIdentity.
		can setPaint: (Color blue).
		can drawShape: (0@0 corner: 100@ 100).

		can pathTransform translateX: -20 Y: -20.
		can clipBy: (20@20 corner: 80@80) during: [
			can pathTransform translateX: 20 Y: 20.
			can setPaint: (Color red).
			can drawShape: (0@0 corner: 100@ 100).
		]
	].

	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
draw2Strings
 	<example>
	| surf font1 font2 ascent advance |
	
	font1 := LogicalFont familyName: 'Arial' pointSize: 10.
	font2 := LogicalFont familyName: 'Tahoma' pointSize: 20.

	ascent := font1 getPreciseAscent max: font2 getPreciseAscent.
	
	surf := self newSurface: 600@200.
	
	surf drawDuring: [:can |
		surf clear: Color white.
		can pathTransform loadIdentity.

		can pathTransform translateX: 30 Y: 30;
		scaleBy: 1.9.

		can setPaint: (Color black).
		can setFont: font1.
		can pathTransform translateX: 0 Y: ascent.

		advance := can drawString: 'Keep '.
		can setFont: font2.

		"The #drawString: method answers a cumulative advance of rendered string,
		so by translating origin with advance, we can draw another string on 'same' line "
		can pathTransform translateBy: advance.
		
		advance := can drawString: 'IT'.
		can setFont: font1.
		can pathTransform translateBy: advance.
		can drawString: 'in mind.'].
	
	surf asMorph openInWindow.! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example6
	"Draw two rectangles, filled by linear gradient. 
	 
	 Note that it should produce same rectangles with exact same fills, because gradient paint 
	 coordinates are affected by pathTransform matrix."

	| surf paint |
	surf := self newSurface: 100@200.
	
	paint := surf 
		createLinearGradient: { 0->Color red. 1->Color green } 
		start: 0@0 
		stop: 50@50.
	
	surf drawDuring: [:can |
		surf clear.
		
		can setPaint: paint.

		can drawShape: (0@0 corner: 50@50).
		
		can pathTransform translateX: 50 Y: 50; rotateByDegrees: 30.
		can drawShape: (0@0 corner: 50@50) ].

		surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example6point1
	"Draw two rectangles, filled by linear gradient. 

	Note that it should produce same rectangles with exact same fills, because gradient paint 
	coordinates are affected by pathTransform matrix."

	| surf paint |
	surf := self newSurface: 100@200.
	
	paint := surf 
		createLinearGradient: { 0->Color red. 1->Color green } 
		start: 0@0 
		stop: 30@30.
	
	surf drawDuring: [:can |
		surf clear.
		
		can setPaint: paint.

		can drawShape: (0@0 corner: 50@50) ].

	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleGouraudTriangle2
	| surface meshPaint |
	surface := AthensCairoSurface extent: 512@512.
	meshPaint := MeshGradientPaint new
		buildPatchWith: [ :patchBuilder |
			patchBuilder
				moveTo: 256@50;
				lineTo: 450@450;
				lineTo: 50@450;
				colors: { Color red . Color green . Color blue}
		].
			
	surface drawDuring: [ :canvas |
		canvas surface clear: Color white.
		
		canvas
			setPaint: meshPaint;
			setShape: (50@50 extent: 400@400);
			draw
	].

	surface asForm asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleCoonsPatch
	| surface meshPaint |
	surface := AthensCairoSurface extent: 300@300.
	meshPaint := MeshGradientPaint new
		addCoonsPatchWithPoints: {
			0@0.
			30@ -30.  60@30. 100@0.
			60@  30. 130@60. 100@100.
			60@  70.  30@130.   0@100.
			30@  70. -30@30
		} colors: { Color red . Color green . Color blue . Color yellow}.
			
	surface drawDuring: [ :canvas |
		canvas surface clear: Color white.
		canvas pathTransform translateBy: 100@100.
		
		canvas
			setPaint: meshPaint;
			setShape: (-100 @ -100 extent: 300@300);
			draw
	].

	surface asForm asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'utilities' stamp: ''!
newSurface:  extent
	^ AthensCairoSurfaceExamples newSurface: extent! !

!AthensSurfaceExamples class methodsFor: 'opening view' stamp: ''!
openViewOn: aBlock

	^ AthensSceneView new
		scene: (self newAsSceneFrom:aBlock);
		openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
drawFontMetrics
 	<example>
	| font |
	font := LogicalFont familyName: 'Arial' pointSize: 10.
	self openViewOn: [ :can |

		can pathTransform restoreAfter: [

		can pathTransform translateX: 30 Y: 30;
		scaleBy: 20.

		can setPaint: (Color r:1 g:0.9 b:0.9);
			drawShape: (0@0 corner: 400@ (font getPreciseHeight)).		

		can setPaint: (Color r: 0.9 g: 0.9 b: 1);
			drawShape: (0@0 corner: 400@ (font getPreciseAscent+font getPreciseDescent)).		

		(can setStrokePaint: Color green) width: 0.05.
		can drawShape: (can createPath: [:builder |
			builder 
				moveTo: 0@0;
				lineTo: 0@font getPreciseAscent
			 ] ).

		(can setStrokePaint: Color red) width: 0.05.
		can drawShape: (can createPath: [:builder |
			builder 
				moveTo: 0@font getPreciseAscent;
				lineTo: 0@font getPreciseDescent
			 ] ).

		(can setStrokePaint: Color blue) width: 0.05.
		can drawShape: (can createPath: [:builder |
			builder 
				moveTo: 0@font getPreciseAscent;
				lineTo: 400@0
			 ]).
				
		can setFont: font.
		can setPaint: (Color black).
		can pathTransform translateX: 0 Y: (font getPreciseAscent).
		can drawString: 'yh'.
		]]! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example10 
	"Draw a rounded rectangle, using the arc segments"

	| surf |	
	surf := self newSurface: 440@440.
	
	surf drawDuring: [:can |
		| p |
		surf clear.
		can pathTransform
			scaleBy: 3;
			translateX: 10 Y: 10.
		p:= can createPath: [:path | |halfPi |
				halfPi := Float pi /2.
				path 
					relative;
					moveTo: 10@0;
					lineTo: 40@0;
					ccwArcTo: 10@10 angle: halfPi;
					lineTo: 0@40;
					cwArcTo: -10@10 angle: halfPi;
					lineTo: -40@0;
					cwArcTo: -10@ -10 angle: halfPi;
					lineTo: 0@ -40;
					ccwArcTo: 10@ -10 angle: halfPi].
				
		can setShape: p.
		can setPaint: Color white.
		can draw.
		can setStrokePaint: Color red.
		can draw ].
		
	surf asMorph openInWindow.! !

!AthensSurfaceExamples class methodsFor: 'instance creation' stamp: ''!
newAsSceneFrom: aBlock
	^ self new
		renderBlock: aBlock;
		yourself! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleStrokeRect
	"Draw a frame rectangle, rotate & transform it in a loop"

	| surf |
	surf := self newSurface: 500@500.	
	surf drawDuring: [:can | 	
		can pathTransform translateX: 200 Y: 200.	
		can pathTransform scaleBy: 8.
		
		1 to: 1000 do: [:i |
			(can setStrokePaint: Color random) width: 1.
			can pathTransform restoreAfter: [
				can pathTransform rotateByDegrees: i*5.
				can pathTransform scaleBy: (1- ( i/2000)).
				can drawShape: (0@0 corner: 25@25). ].
		]	
	].

	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
exampleUseForm

	| surf  form |
	form := Form extent: 100@100 depth: 32.
	form getCanvas fillRectangle: (0@0 corner: 30@30)  color: (Color red).
	form getCanvas fillRectangle: (10@10 corner: 40@40)  color: (Color green).
	form getCanvas fillRectangle: (20@20 corner: 50@50)  color: (Color blue).
	
	surf := AthensCairoSurface fromForm: form.
	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
example9
	"Fill the rectangle using image paint."
	
	| surf paint f  |	
	surf := self newSurface: 200@200.	
	surf asForm getCanvas fillRectangle: surf asForm boundingBox color: Color white.
	
	f := Form extent: 10@10 depth: 32.
	f getCanvas fillRectangle: (0@0 corner: 5@5) color: (Color red alpha: 0.1).
	f getCanvas fillRectangle: (5@5 corner: 10@10) color: (Color green alpha: 0.1).

	paint := surf createFormPaint: f.
	
	surf drawDuring: [:can |
		can 
			setPaint: paint;
			drawShape: (0@0 corner: 100@200)].

	surf asMorph openInWindow! !

!AthensSurfaceExamples class methodsFor: 'examples' stamp: ''!
drawSetFillRule
 	<example>
	self openViewOn: [ :canvas |
		| path |	
		canvas pathTransform
			translateBy: 100 asPoint.
		"donut"
		canvas fillRuleEvenOdd.
		path := canvas createPath: [ :builder |  
			builder
				absolute;
				moveTo: 50@0;
				arcCenterX: 0
					centerY: 0
					radius: 50
					startAngle: 0 
					endAngle: Float pi * 2;
				moveTo: 30@0;
				arcCenterX: 0
					centerY: 0
					radius: 30
					startAngle: 0
					endAngle: Float pi * 2;
				close.
			 ].
		"CAIRO_FILL_RULE_WINDING := 0.
		CAIRO_FILL_RULE_EVEN_ODD := 1.
		self assert: canvas fillRule = 1"
		canvas setPaint: Color blue.
		canvas drawShape: path.
		canvas setStrokePaint: Color red.
		canvas drawShape: path.
		canvas pathTransform
			translateBy: 100 asPoint.
		canvas fillRuleWinding.
		canvas setPaint: Color red.
		canvas drawShape: path.
		canvas setStrokePaint: Color blue.
		canvas drawShape: path.
	]! !

!AthensTextBackground commentStamp: ''!
Athens text background !
!AthensTextBackground methodsFor: 'accessing' stamp: ''!
color: anObject

	color := anObject! !

!AthensTextBackground methodsFor: 'comparing' stamp: ''!
hash
	^ color hash! !

!AthensTextBackground methodsFor: 'scanning' stamp: ''!
emphasizeScanner: scanner
	"Set the emphasis for text display"
	scanner textBackground: color! !

!AthensTextBackground methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' code: '; print: color! !

!AthensTextBackground methodsFor: 'scanning' stamp: ''!
dominates: other
	^ other class == self class! !

!AthensTextBackground methodsFor: 'accessing' stamp: ''!
color

	^ color! !

!AthensTextComposer commentStamp: ''!
Compose text!
!AthensTextComposer methodsFor: 'private - scanning' stamp: ''!
scan: aText for: scanner
	" scan text from starting index,
	answer the index of first character for potential next line"
	| top |	

	text := aText.
	scanner text: text.

	"edge case, text is empty "
	text isEmpty ifTrue: [ ^ scanner ].
	
	scanner newLine: 1.

	text runs withStartStopAndValueDo: [:start :stop :values |
		
		scanner setAttributes: values.
		start to: stop do: [:i |  | ch |
			ch := text at: i.
			ch = Character cr 
				ifTrue: [ 
					scanner endLine: i - 1.
					scanner newLine: i + 1 ]
				ifFalse: [
					scanner addCharacter: i.
				]
			]
	].
	scanner endLine: (text size).

	lines := scanner lines.

	"set the lines top offset"
	top := 0.
	lines do: [:line |
		line top: top.
		top := top + line height ].! !

!AthensTextComposer methodsFor: 'rendering' stamp: ''!
renderOn: aCanvas

	| renderer |
	
	renderer := AthensTextRenderer new.
	renderer render: text lines: lines on: aCanvas.! !

!AthensTextComposer methodsFor: 'accessing' stamp: ''!
lines
	^ lines! !

!AthensTextComposer class methodsFor: 'instance creation' stamp: ''!
scan: aText for: scanner
	^ self new scan: aText for: scanner! !

!AthensTextDisplayCommand commentStamp: ''!
An abstract base class for all text rendering commands.

A text rendered takes a stream (or list) of my (sub)instances and in that way it renders the text!
!AthensTextDisplayCommand methodsFor: 'accessing' stamp: ''!
next

	^ next! !

!AthensTextDisplayCommand methodsFor: 'accessing' stamp: ''!
next: anObject
	
	next := anObject! !

!AthensTextDisplayCommand methodsFor: 'copying' stamp: ''!
postCopy
	"unlink the copy by default"

	next := nil! !

!AthensTextDisplayCommand methodsFor: 'accessing' stamp: ''!
tail

	| nn |
	nn := self.
	[ nn next notNil ] whileTrue: [ nn := nn next ].
	^ nn! !

!AthensTextDisplayCommand methodsFor: 'accessing' stamp: ''!
do: aBlock

	| nn |
	nn := self.

	[ nn isNil ] whileFalse: [ 
		aBlock value: nn.
		nn := nn next ]! !

!AthensTextDisplayCommand methodsFor: 'rendering' stamp: ''!
renderOn: renderer

	self shouldBeImplemented! !

!AthensTextDisplayCommand methodsFor: 'accessing' stamp: ''!
insert: aCommands

	| nn |
	nn := next.
	next := aCommands.
	next tail next: nn! !

!AthensTextDisplayCommand methodsFor: 'accessing' stamp: ''!
addLast: aCommand

	self tail next: aCommand! !

!AthensTextDisplayCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == AthensTextDisplayCommand! !

!AthensTextLine commentStamp: ''!
I representing a single line of text!
!AthensTextLine methodsFor: 'accessing' stamp: ''!
text

	^ text! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
maxAscent
	^ maxAscent! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
heightAndDescent

	^ height + maxDescent! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
maxDescent
	^ maxDescent! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
commands

	^ commands! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
top: aTop
	top := aTop! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
addWidth: aNumber
	width := width + aNumber.! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
commands: anObject

	commands := anObject! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
maxAscent: mascent
	maxAscent := mascent max: maxAscent! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
addCommand: aCommand

	commands 
		ifNil: [ tail := commands := aCommand. ]
		ifNotNil: [ tail next: aCommand ].
	tail := tail tail.! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
startIndex

	^ startIndex! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
maxDescent: mascent

	maxDescent := mascent max: maxDescent! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
width: anObject

	width := anObject! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
bottom
	^ top + self heightAndDescent! !

!AthensTextLine methodsFor: 'initialization' stamp: ''!
initialize
	width := height := maxAscent := maxDescent := 0! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
startIndex: index
	startIndex := index! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
text: aText 
	text := aText! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
endIndex

	^ endIndex! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
maxHeight: aHeight
	height := height max: aHeight! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
height
	^ height! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
height: anObject

	height := anObject! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
top
	^ top! !

!AthensTextLine methodsFor: 'rendering' stamp: ''!
renderOn: aTextRenderer
	
	commands ifNil: [ ^ self ]. 
	commands do: [ :cmd |
		cmd renderOn: aTextRenderer
	].! !

!AthensTextLine methodsFor: 'accessing' stamp: ''!
endIndex: anObject

	endIndex := anObject! !

!AthensTextLine methodsFor: 'rendering' stamp: ''!
renderOn: anAthensTextRenderer x: aSmallInteger y: aSmallInteger3 
	self shouldBeImplemented! !

!AthensTextRenderExamples commentStamp: ''!
Visual tests for correct rendering of text using Athens!
!AthensTextRenderExamples class methodsFor: 'tests' stamp: ''!
test4
	<example>
	
	| t  c surf |
	t := 'Unfortunately this class has not been documented yet.' asText.
	t addAttribute: (TextFontReference toFont: (LogicalFont familyName: 'Tahoma' pointSize: 10)).
	t addAttribute: (TextColor new color: Color red) from: 3 to: 10.
	c := AthensTextComposer scan: t for: AthensTextScanner new.
	surf := self surfaceClass extent: 500@500.
	surf drawDuring: [ :canvas | 
		canvas setPaint: (Color yellow alpha: 0.5).
		canvas drawShape: (0@0 corner: 300@300).
		canvas pathTransform scaleBy: 1.
		1 to: 20 do: [:i |
			c renderOn: canvas.
			canvas pathTransform translateBy: 0.1@10.
		]
	].
	surf asMorph openInWindow! !

!AthensTextRenderExamples class methodsFor: 'tests' stamp: ''!
testBlitting
	<example>
	
	| fnt form blt dstForm |
	fnt := LogicalFont familyName: 'Source Sans Pro' pointSize: 50.

	form := fnt realFont
		glyphOf: $W
				destDepth: 8
				colorValue: 1
				subpixelPosition: 0.

	dstForm := Form extent: 300@300 depth: 32.
	blt := BitBlt toForm: dstForm.
	
	blt 
		sourceForm: form;
		destOrigin: 0@0;
		sourceOrigin: 0@0;
		halftoneForm: nil;
		combinationRule: 41;
		width: form width;
		height: form height;		
		copyBitsColor: 0
		alpha: 255
		gammaTable:  FreeTypeSettings current gammaTable
		ungammaTable: FreeTypeSettings current gammaInverseTable.
	
	dstForm asMorph openInWindow! !

!AthensTextRenderExamples class methodsFor: 'tests' stamp: ''!
test3
	<example>
	
	| t  c surf |
	t := 'qW' asText.
	t addAttribute: (TextFontReference toFont: (LogicalFont familyName: 'Arial' pointSize: 8)).
	c := AthensTextComposer scan: t for: AthensTextScanner new.
	surf := self surfaceClass extent: 500@500.
	surf drawDuring: [ :canvas | 
		canvas setPaint: (Color yellow alpha: 0.5).
		canvas drawShape: (0@0 corner: 300@300).
		canvas pathTransform translateBy: 200@200.
		canvas pathTransform scaleBy: 4.
		1 to: 10 do: [:i |
			canvas setPaint: (Color blue alpha: 0.5).
			canvas drawShape: (0@0 corner: 100@10).
			c renderOn: canvas.
			canvas pathTransform rotateByDegrees: 5. 
			canvas pathTransform translateBy: 0 @11.
		].
	].
	surf asMorph openInWindow! !

!AthensTextRenderExamples class methodsFor: 'tests' stamp: ''!
test5
	<example>
	
	| t  c surf |
	t := 'U' asText.
	t addAttribute: (TextFontReference toFont: (LogicalFont familyName: 'Tahoma' pointSize: 10)).
	c := AthensTextComposer scan: t for: AthensTextScanner new.
	surf := self surfaceClass extent: 500@500.
	surf drawDuring: [ :canvas | 
		canvas setPaint: (Color yellow alpha: 0.5).
		canvas drawShape: (0@0 corner: 300@300).
		canvas pathTransform scaleBy: 1.
		1 to: 20 do: [:i |
			c renderOn: canvas.
			canvas pathTransform translateBy: 10@0.1.
		]
	].
	surf asMorph openInWindow! !

!AthensTextRenderExamples class methodsFor: 'utilities' stamp: ''!
surfaceClass
	^ AthensCairoSurface! !

!AthensTextRenderExamples class methodsFor: 'tests' stamp: ''!
test1
	<example>
	
	|  t  c  |
	t := '
AthensTextRenderTest test1

leftFlush
p := MultiNewParagraph new.

p compose: t
	style: TextStyle default
	from: 1
	in: (0@0 corner: 100@100).
p

MultiNewParagraph
TextStyle default alignment


globalBounds:  toLocal: 
' asText.

	t addAttribute: (TextColor new color: Color red) from: 3 to: 10.
	t addAttribute: (TextEmphasis italic) from: 5 to: 13.
	c := AthensTextComposer scan: t for: AthensTextScanner new.
	AthensSceneView new
		scene:  [:canvas |
			canvas pathTransform scaleBy: 0.8.
			c renderOn: canvas ];
	openInWindow! !

!AthensTextRenderExamples class methodsFor: 'tests' stamp: ''!
testText
	
	|  t  |
	t := 'The safety constraint is that the garbage collector 
MUST NOT collect any storage that then becomes needed to continue correct execution of the program. Should weak references 
be added, then garbage collection decisions become observable. 
Based on a suggestion from Cameron McCormack, we state the 
safety constraint as follows: So long as operational semantics of 
the remainder of the program execution includes the possibility that 
a reference to an object X may be dereferenced, then X MUST NOT 
be collected. Thus, the garbage collector is allowed to ignore any 
references that remain present in the semantic state, but which it 
can ascertain will never be dereferenced in any possible execution. 
This sets an upper bound on what state MAY be collected. Put 
another way, if the garbage collector ever reports that X has been 
collected, such as by nullifying a weak reference to X, if operational 
semantics of remaining execution requires the traversal of a strong 
(non-weak) reference to X, then the previous report demonstrates a 
safety violation. 
' asText.
	t addAttribute: (TextFontReference toFont: (LogicalFont familyName: 'Arial' pointSize: 8)).
	t addAttribute: (TextEmphasis italic) from: 5 to: 100.
	t addAttribute: (TextColor new color: (Color red)) from: 10 to: 60.
	t addAttribute: (TextEmphasis italic) from: 100 to: 200.
	t addAttribute: (TextColor new color: Color green) from: 230 to: 360.
	t addAttribute: (TextFontReference toFont: ( LogicalFont familyName: 'Tahoma'  pointSize: 14)) from: 88 to: 200.
	^ t! !

!AthensTextRenderExamples class methodsFor: 'tests' stamp: ''!
test2
	<example>
	
	| t c surf |
	t := self testText. 
	t addAttribute: (AthensTextBackground new color: (Color green alpha: 0.3 )) from: 1 to: 267.
	c := AthensTextComposer scan: t for: AthensTextScanner new.
	surf := self surfaceClass extent: 500@300.
	surf drawDuring: [ :canvas | 
		canvas setPaint: (Color white).
		canvas drawShape: (0@0 corner: 500@300).
		canvas pathTransform scaleBy: 1.
		canvas pathTransform translateX: 0 Y: 0.
		canvas setPaint: Color yellow.
		canvas pathTransform rotateByDegrees: 0.
		c renderOn: canvas
	].

	surf asMorph openInWindow! !

!AthensTextRenderSpecExamples commentStamp: ''!
Examples rendering text and displaying the result in a Spec Presenter.!
!AthensTextRenderSpecExamples class methodsFor: 'tests' stamp: ''!
testSpecWindow
	<example>
	| presenter window |
	presenter := SpTextPresenter new
		text: self testText;
		yourself.
	window := presenter openWithSpec.

	presenter withWindowDo: [ :w | w title: 'A fancy looking title text' ].

	^ window window! !

!AthensTextRenderSpecExamples class methodsFor: 'tests' stamp: ''!
testWindowRender
	<example>
	
	| surf win |
	win := self testSpecWindow.
	surf := self surfaceClass extent: win extent.
	win position: 0@0.

	surf drawDuring: [ :canvas | 
		canvas pathTransform scaleBy: 1.
		canvas fullDrawMorph: win.
	].

	surf asMorph openInWindow! !

!AthensTextRenderer commentStamp: ''!
This is a text renderer, which pipelining a text command(s), produced by `AthensTextComposer`
into a concrete calls to canvas.

It is using a glyph renderer instance(s) to draw separate font glyphs on a surface in a most suitable/efficient manner for given Athens surface.
!
!AthensTextRenderer methodsFor: 'rendering' stamp: ''!
renderBackground: bkObj
"self halt."
	canvas setPaint: bkObj color.
	canvas drawShape: ( bkObj start@0 corner: bkObj start + bkObj width @ currentLine heightAndDescent)! !

!AthensTextRenderer methodsFor: 'accessing' stamp: ''!
setCurrentFont: aFont
	font := aFont.
	glyphRenderer := font glyphRendererOn: canvas surface.
	glyphRenderer 
		advance: advance;
		setColor: color.! !

!AthensTextRenderer methodsFor: 'initialization' stamp: ''!
initialize
	color := Color black.! !

!AthensTextRenderer methodsFor: 'rendering' stamp: ''!
renderCharactersFrom: start to: stop

	" accumulate advance while rendering spans"
	"canvas drawShape: (advance x @ advance y extent: 2 @ 2)."
	glyphRenderer advance: advance.
	advance := advance + (glyphRenderer renderCharacters: text asString from: start to: stop).! !

!AthensTextRenderer methodsFor: 'rendering' stamp: ''!
renderBackground: aColor width: w
"self halt."
	canvas setPaint: aColor.
	canvas drawShape: ( advance x@0 corner: advance x + w +1@ currentLine heightAndDescent)! !

!AthensTextRenderer methodsFor: 'accessing' stamp: ''!
setCurrentColor: aColor
	color = aColor ifTrue: [ ^ self ].
	color := aColor.
"	canvas setPaint: aColor."
	glyphRenderer ifNotNil:  [ glyphRenderer setColor: aColor ].! !

!AthensTextRenderer methodsFor: 'rendering' stamp: ''!
render: aText lines: lines on: aCanvas
	text := aText.
	canvas := aCanvas.
	canvas pathTransform restoreAfter: [ 
		lines do: [ :line | 
			currentLine := line.
			maxAscent := line maxAscent.
			"set the origin to font's baseline position"
			canvas pathTransform translateX: 0 Y: maxAscent.
			"reset advance"
			advance := 0 @ 0.
			line renderOn: self.
			"line is rendered, advance vertically by line height"
			canvas pathTransform translateX: 0 Y: line height * 1.2 - maxAscent ] ]! !

!AthensTextRenderer class methodsFor: 'documentation' stamp: ''!
textGoryDetails

"
Took from: http://www.freetype.org/freetype2/docs/tutorial/step2.html

(Font face metrics)
In this case, you can access the global design metrics as:

units_per_EM 	

This is the size of the EM square for the font face. It is used by scalable formats to scale design coordinates to device pixels, as described in the last chapter of this section. Its value usually is 2048 (for TrueType) or 1000 (for Type 1), but others are possible too. It is set to 1 for fixed-size formats like FNT/FON/PCF/BDF.

bbox 	

The global bounding box is defined as the largest rectangle that can enclose all the glyphs in a font face.

ascender 	

The ascender is the vertical distance from the horizontal baseline to the highest ‘character’ coordinate in a font face. Unfortunately, font formats define the ascender differently. For some, it represents the ascent of all capital latin characters (without accents), for others it is the ascent of the highest accented character, and finally, other formats define it as being equal to bbox.yMax.

descender 	

The descender is the vertical distance from the horizontal baseline to the lowest ‘character’ coordinate in a font face. Unfortunately, font formats define the descender differently. For some, it represents the descent of all capital latin characters (without accents), for others it is the ascent of the lowest accented character, and finally, other formats define it as being equal to bbox.yMin. This field is negative for values below the baseline.

height 	

This field is simply used to compute a default line spacing (i.e., the baseline-to-baseline distance) when writing text with this font. Note that it usually is larger than the sum of the ascender and descender taken as absolute values. There is also no guarantee that no glyphs extend above or below subsequent baselines when using this distance.

max_advance_width 	

This field gives the maximum horizontal cursor advance for all glyphs in the font. It can be used to quickly compute the maximum advance width of a string of text. It doesn't correspond to the maximum glyph image width!!

max_advance_height 	

Same as max_advance_width but for vertical text layout.

underline_position 	

When displaying or rendering underlined text, this value corresponds to the vertical position, relative to the baseline, of the underline bar's center. It is negative if it is below the baseline.

underline_thickness 	

When displaying or rendering underlined text, this value corresponds to the vertical thickness of the underline.


"! !

!AthensTextScanner commentStamp: ''!
I responsible for scanning the Text and transforming it into a list of AthensTextLine, where each line is a list of AthensTextDisplayCommand (sub)instances!
!AthensTextScanner methodsFor: 'text attributes' stamp: ''!
setFont: fontNumber

	self setActualFont: (self textStyle fontAt: fontNumber).! !

!AthensTextScanner methodsFor: 'initialization' stamp: ''!
initialize
	lines := OrderedCollection new.
	currentAttributes := #().! !

!AthensTextScanner methodsFor: 'text attributes' stamp: ''!
textColor: aColor

	currentColor ifNil: [
		currentColor := AthensColorChange new color: aColor.
		self addCommand: currentColor.
		^ self 
	].

	currentColor color = aColor ifFalse: [
		currentColor := AthensColorChange new color: aColor.
		self addCommand: currentColor.	
	].! !

!AthensTextScanner methodsFor: 'accessing' stamp: ''!
text: aText 
	text := aText! !

!AthensTextScanner methodsFor: 'accessing' stamp: ''!
endLine: index

	currentLine endIndex: index! !

!AthensTextScanner methodsFor: 'defaults' stamp: ''!
defaultFont

	^ self textStyle defaultFont! !

!AthensTextScanner methodsFor: 'accessing' stamp: ''!
newLine: startingIndex 

	currentLine := lines add: (AthensTextLine new text: text;
		startIndex: startingIndex; yourself).

"	currentStrip ifNotNil: [
		
		currentLine addCommand: currentFont copy.
		currentLine addCommand: currentColor copy.

		currentBackground ifNotNil: [
			currentBackground := currentBackground copy start: 0; width: 0. 
			currentLine addCommand: currentBackground ].
	].
"
"reset everything, to make sure all attributes will be reapplied for new line"
	
	currentColor := currentBackground := currentFont := currentStrip := nil.! !

!AthensTextScanner methodsFor: 'accessing' stamp: ''!
resetBackground
	self textBackground: Color transparent! !

!AthensTextScanner methodsFor: 'accessing' stamp: ''!
textStyle
	^ textStyle ifNil: [ textStyle := self defaultTextStyle ]! !

!AthensTextScanner methodsFor: 'defaults' stamp: ''!
defaultTextStyle

	^ TextStyle default! !

!AthensTextScanner methodsFor: 'accessing' stamp: ''!
setAttributes: anArray 
	currentBackground := nil.
	currentAttributes := anArray.
	
	"we should reset character string here"
	currentStrip := nil! !

!AthensTextScanner methodsFor: 'text attributes' stamp: ''!
textBackground: aColor

	"background is transparent by default "
	
	(currentBackground notNil and: [ currentBackground color = aColor ])
		ifTrue: [ ^ self].
		
	currentBackground ifNil: [ aColor isTransparent ifTrue: [ ^ self ] ].
	
	currentBackground := AthensBackgroundChange new color: aColor.
	currentBackground start: currentLine width.
	currentLine addCommand: currentBackground.! !

!AthensTextScanner methodsFor: 'accessing' stamp: ''!
addCommand: aCommand
	currentLine addCommand: aCommand! !

!AthensTextScanner methodsFor: 'text attributes' stamp: ''!
setActualFont: aFont

	currentFont ifNil: [
		
		currentFont := AthensFontChange new font: aFont.
		self addCommand: currentFont.
		^ self 
	].

	aFont = currentFont font ifFalse: [
		currentFont := AthensFontChange new font: aFont.
		self addCommand: currentFont.
	].! !

!AthensTextScanner methodsFor: 'defaults' stamp: ''!
defaultColor
	^ Color black! !

!AthensTextScanner methodsFor: 'accessing' stamp: ''!
lines
	^ lines! !

!AthensTextScanner methodsFor: 'text attributes' stamp: ''!
addEmphasis: emphasis
	| fnt |
	
	fnt := currentFont ifNil: [ self defaultFont ] ifNotNil: [ currentFont font ].
	
	self setActualFont: (fnt emphasized: emphasis)! !

!AthensTextScanner methodsFor: 'accessing' stamp: ''!
addCharacter: position
	| charWidth fnt |

	currentStrip ifNil: [

		self applyAttributes.
		
		fnt := currentFont font.
		currentLine maxAscent: fnt getPreciseAscent.
		currentLine maxDescent: fnt getPreciseDescent.
		currentLine maxHeight: fnt getPreciseHeight.
		
		currentStrip := AthensCharacterSpan new.
		currentLine addCommand: currentStrip.
		currentStrip start: position.
	].
	
	charWidth := currentFont font getGlyphWidth: (text at: position).
	currentLine addWidth: charWidth.
	currentBackground ifNotNil: [
		currentBackground addWidth: charWidth ].
	
	currentStrip stop: position! !

!AthensTextScanner methodsFor: 'accessing' stamp: ''!
applyAttributes
	currentAttributes do: [:attr |
		attr emphasizeScanner: self ]. 
	
	currentFont ifNil: [ self setActualFont: self defaultFont ].
	currentColor ifNil: [ self textColor: self defaultColor ]! !

!AthensTiger commentStamp: ''!
I am a tiger in a Athens canvas.

I know how draw the tiger with the collaboration of AthensParts.
I also know how to decode such AthensParts from strings in my class-side.!
!AthensTiger methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!AthensTiger methodsFor: 'accessing' stamp: ''!
rotation
	^ rotation! !

!AthensTiger methodsFor: 'accessing' stamp: ''!
rotation: aNumber
	rotation := aNumber! !

!AthensTiger methodsFor: 'accessing' stamp: ''!
zoom: aNumber
	zoom := aNumber! !

!AthensTiger methodsFor: 'accessing' stamp: ''!
position: anObject
	position := anObject! !

!AthensTiger methodsFor: 'accessing' stamp: ''!
zoom
	^ zoom! !

!AthensTiger methodsFor: 'initialization' stamp: ''!
initializeWith: anAthensSurface

	self initialize.
	surface := anAthensSurface.
	parts := self readParts.
	rotation := 180.0.
	scale := 0.5.
	zoom := 1.0.
	position := 0@0.! !

!AthensTiger methodsFor: 'accessing' stamp: ''!
scale
	^ scale! !

!AthensTiger methodsFor: 'accessing' stamp: ''!
scale: aNumber
	scale := aNumber! !

!AthensTiger methodsFor: 'run' stamp: ''!
draw
	surface drawDuring: [ :canvas | 
		canvas pathTransform loadIdentity.
		canvas
			setPaint: Color white;
			drawShape: (0@0 corner: surface extent).
			
		canvas pathTransform
			translateX: 0.5 * (surface extent x - (self class tigerMaxX * scale * zoom))
				Y: surface extent y / -12.0;
			scaleBy: scale * zoom;
			translateBy: self class tigerCenter;
			scaleBy: 0.8;
			rotateByDegrees: rotation;
			translateBy: (self class tigerCenter * -1);
			translateBy: position.

		parts do: [ :each | each renderOn: canvas ] ].! !

!AthensTiger methodsFor: 'converting' stamp: ''!
readParts

	| results currentPart commandStream pointStream fillBlocks strokeBlocks capBlocks joinBlocks cmdBlocks |
	
	results := OrderedCollection new.
	commandStream := self class commands readStream.
	pointStream := self class tigerPoints readStream.
	currentPart := nil.
	
	fillBlocks := { 
		"N" [].
		"F" [ currentPart addFill ].
		"E" [ currentPart addFill; fillRule: #VGEVENODD ] }.

	strokeBlocks := {
		"N" [].
		"S" [ currentPart addStroke ] }.
	
	capBlocks := {
		"B" [ currentPart capStyle: #VGCAPBUTT ].
		"R" [ currentPart capStyle: #VGCAPROUND ].
		"S" [ currentPart capStyle: #VGCAPSQUARE ]	}.
	
	joinBlocks := {
		"M" [ currentPart joinStyle: #VGJOINMITER ].
		"R" [ currentPart joinStyle: #VGJOINROUND ].
		"B" [ currentPart joinStyle: #VGJOINBEVEL ] }.
		
	cmdBlocks := {		
		"M"[:s | s moveToX: pointStream next Y: pointStream next ].
		"L" [:s | s lineToX: pointStream next Y: pointStream next ].
		"C"	[:s | s  
			curveVia: (pointStream next @ pointStream next)
			and: (pointStream next @ pointStream next)
			to: (pointStream next @ pointStream next) ].
		"E"	[:s | s close ] }.

	[		
		currentPart := AthensTigerPart new.

		fillBlocks := { 
			"N" [].
			"F" [ currentPart addFill; fillRule: #VGNONZERO.  ].
			"E" [ currentPart addFill; fillRule: #VGEVENODD ] }.

		strokeBlocks := {
			"N" [].
			"S" [ currentPart addStroke ] }.
		
		" fill type "
		currentPart fillRule: #VGNONZERO.
		(fillBlocks at: ('NFE' indexOf: commandStream next)) value.

		" stroke type "	
		(strokeBlocks at: ('NS' indexOf: commandStream next)) value.

		" line cap "
		(capBlocks at: ('BRS' indexOf: commandStream next)) value.
	
		" line join "
		(joinBlocks at: ('MRB' indexOf: commandStream next)) value.
	
		" the rest of stroke attributes "
		currentPart miterLimit: pointStream next.
		currentPart strokeWidth: pointStream next.

		" paints "
		currentPart strokePaint: ((Color r: pointStream next g: pointStream next b: pointStream next )).
		
		currentPart fillPaint: ((Color r: pointStream next g: pointStream next b: pointStream next )).
		
		currentPart setPath: (
			surface createPath: [:builder |
				builder absolute.
				(pointStream next asInteger) timesRepeat: [
					(cmdBlocks at: ('MLCE' indexOf: commandStream next) ) value: builder.
				] ] ).

		results add: currentPart.
		commandStream atEnd
	] whileFalse.

	results do: [:ea |
		self assert: ea fillRule = #VGNONZERO.	
		ea prepareFor: surface ].
	
	self assert: pointStream atEnd.
	
	^ results! !

!AthensTiger class methodsFor: 'accessing' stamp: ''!
tigerCenter
	^ self tigerExtent / 2! !

!AthensTiger class methodsFor: 'private' stamp: ''!
tigerMinX 
	^ 0.0! !

!AthensTiger class methodsFor: 'instance creation' stamp: ''!
on: anAthensSurface
	^ self basicNew
		initializeWith: anAthensSurface;
		yourself! !

!AthensTiger class methodsFor: 'private' stamp: ''!
commands
	| pt str |
	
	pt := 1.
	
	str := String new: self tigerCommandCount.
	
	"merge everything into a single string"
	self tigerCommands do: [:sub |

		0 to: sub size-1 do: [:i |
			str at: pt+i put: (sub at: i+1).
			].
		pt := pt + sub size.	
	].

	^ str! !

!AthensTiger class methodsFor: 'private' stamp: ''!
tigerMaxY 
	^ 792.0! !

!AthensTiger class methodsFor: 'private' stamp: ''!
tigerMinY 
	^ 0.0! !

!AthensTiger class methodsFor: 'private' stamp: ''!
checkDataSizes
	<script>
	self assert: (self commands size = self tigerCommandCount).
	self assert: (self tigerPointsCount = self tigerPoints size).! !

!AthensTiger class methodsFor: 'accessing' stamp: ''!
tigerExtent
	^ self tigerMaxX @ self tigerMaxY! !

!AthensTiger class methodsFor: 'private' stamp: ''!
tigerPointsCount 
	^ 16988! !

!AthensTiger class methodsFor: 'private' stamp: ''!
tigerMaxX 
	^ 612.0! !

!AthensTiger class methodsFor: 'private' stamp: ''!
tigerCommandCount 
	^ 4142! !

!AthensTiger class methodsFor: 'huge data' stamp: ''!
tigerPoints

	^ #(10 0 1
1 1 1 1 1 5 85.25 487.75 85.25 487.75
85.5742 485.199 84.25 484.746 83.7617 485.242 65.6641 538.125 43.2461 535.746
43.2422 535.746 62.6445 543.746 85.25 487.75 10 0.1892 0 0
0 0 0 0 5 85.25 487.75 85.25 487.75 85.5742
485.199 84.25 484.746 83.7617 485.242 65.6641 538.125 43.2461 535.746 43.2422
535.746 62.6445 543.746 85.25 487.75 10 0 1 1 1
1 1 1 5 89.2461 490.75 89.2461 490.75 88.7422 488.613
88.2461 488.746 87.0508 489.27 88.0234 545.156 66.2461 550.746 66.2461 550.742
87.0977 551.469 89.2461 490.75 10 0.1892 0 0 0 0
0 0 5 89.2461 490.75 89.2461 490.75 88.7422 488.613 88.2461
488.746 87.0508 489.27 88.0234 545.156 66.2461 550.746 66.2461 550.742 87.0977
551.469 89.2461 490.75 10 0 1 1 1 1 1
1 5 119.25 443.75 119.25 443.75 121.387 442.992 121.246 442.746
120.352 441.504 66.2578 455.586 56.25 435.75 56.25 435.75 59.9062 456.168
119.25 443.75 10 0.1892 0 0 0 0 0 0
5 119.25 443.75 119.25 443.75 121.387 442.992 121.246 442.746 120.352
441.504 66.2578 455.586 56.25 435.75 56.25 435.75 59.9062 456.168 119.25
443.75 10 0 1 1 1 1 1 1 5
116.246 432.75 116.246 432.75 118.539 432.383 118.25 431.746 118.023 430.641
62.25 426.965 58.25 404.75 58.25 404.75 56.0391 425.516 116.246 432.75
10 0.1892 0 0 0 0 0 0 5 116.246
432.75 116.246 432.75 118.539 432.383 118.25 431.746 118.023 430.641 62.25
426.965 58.25 404.75 58.25 404.75 56.0391 425.516 116.246 432.75 10
0 1 1 1 1 1 1 5 112.25 438.746
112.25 438.742 113.82 438.164 113.25 437.75 113.059 436.52 57.3437 441.016
50.2461 419.75 50.2461 419.75 50.9883 440.492 112.25 438.746 10 0.1892
0 0 0 0 0 0 5 112.25 438.746 112.25
438.742 113.82 438.164 113.25 437.75 113.059 436.52 57.3437 441.016 50.2461
419.75 50.2461 419.75 50.9883 440.492 112.25 438.746 10 0 1
1 1 1 1 1 5 100.246 458.746 100.246 458.746
101.527 457.406 101.25 456.746 100.121 456.262 52.0039 484.699 36.25 467.746
36.25 467.746 46.0586 487.012 100.246 458.746 10 0.1892 0 0
0 0 0 0 5 100.246 458.746 100.246 458.746 101.527
457.406 101.25 456.746 100.121 456.262 52.0039 484.699 36.25 467.746 36.25
467.746 46.0586 487.012 100.246 458.746 10 0 1 1 1
1 1 1 5 92.2461 454.75 92.2422 454.75 93.3906 452.969
93.2461 452.75 92.125 451.672 41.0976 474.484 27.25 456.746 27.25 456.746
34.9258 476.105 92.2461 454.75 10 0.1892 0 0 0 0
0 0 5 92.2461 454.75 92.2422 454.75 93.3906 452.969 93.2461
452.75 92.125 451.672 41.0976 474.484 27.25 456.746 27.25 456.746 34.9258
476.105 92.2461 454.75 10 0 1 1 1 1 1
1 5 89.2461 449.746 89.2461 449.742 90.6992 448.723 90.25 447.746
89.6211 447.262 35.9609 462.906 25.25 442.746 25.25 442.742 29.625 463.676
89.2461 449.746 10 0.1892 0 0 0 0 0 0
5 89.2461 449.746 89.2461 449.742 90.6992 448.723 90.25 447.746 89.6211
447.262 35.9609 462.906 25.25 442.746 25.25 442.742 29.625 463.676 89.2461
449.746 10 0 1 1 1 1 1 1 5
100.246 448.75 100.246 448.75 101.969 447.469 101.25 446.75 100.43 446.512
56.3516 480.887 39.2461 466.746 39.2461 466.742 50.75 483.941 100.246 448.75
10 0.1892 0 0 0 0 0 0 5 100.246
448.75 100.246 448.75 101.969 447.469 101.25 446.75 100.43 446.512 56.3516
480.887 39.2461 466.746 39.2461 466.742 50.75 483.941 100.246 448.75 10
0 1 1 1 1 1 1 5 79.25 480.746
79.25 480.746 79.6367 479.02 79.25 478.746 77.8789 478.578 46.418 524.777
25.25 516.75 25.25 516.75 42.0195 529.398 79.25 480.746 10 0.1892
0 0 0 0 0 0 5 79.25 480.746 79.25
480.746 79.6367 479.02 79.25 478.746 77.8789 478.578 46.418 524.777 25.25
516.75 25.25 516.75 42.0195 529.398 79.25 480.746 10 0 1
1 1 1 1 1 5 79.25 473.746 79.25 473.742
80.8164 471.527 80.25 470.75 79.1914 470.723 38.5078 509.051 19.25 496.75
19.25 496.75 33.2148 512.609 79.25 473.746 10 0.1892 0 0
0 0 0 0 5 79.25 473.746 79.25 473.742 80.8164
471.527 80.25 470.75 79.1914 470.723 38.5078 509.051 19.25 496.75 19.25
496.75 33.2148 512.609 79.25 473.746 10 0 1 1 1
1 1 1 5 79.25 468.75 79.25 468.75 80.8516 466.828
80.25 466.746 79.3086 465.875 35.2305 500.246 17.25 485.75 17.25 485.75
29.6289 503.301 79.25 468.75 10 0.1892 0 0 0 0
0 0 5 79.25 468.75 79.25 468.75 80.8516 466.828 80.25
466.746 79.3086 465.875 35.2305 500.246 17.25 485.75 17.25 485.75 29.6289
503.301 79.25 468.75 10 0 1 1 1 1 1
1 88 77.2461 466.746 77.7383 459.973 78.8242 452.746 80.25 449.746
80.25 449.742 76.7773 435.676 86.25 420.746 86.25 420.742 86.0195 413.238
88.2461 409.746 88.2461 409.742 92.1797 400.477 97.25 399.75 101.73 398.887
111.324 395.508 122.246 393.75 122.246 393.75 141.02 378.477 137.246 364.75
137.242 364.75 137.059 346.355 133.246 344.75 133.246 344.75 145.859 356.918
135.25 338.75 130.25 317.746 130.25 317.742 158.617 341.516 141.25 321.746
130.25 292.75 130.25 292.75 152.02 312.918 144.246 303.75 140.25 293.746
140.25 293.746 188.098 323.918 154.246 291.746 154.242 291.746 163.02 295.316
168.25 291.746 168.25 291.746 175.34 293.559 174.25 291.746 174.25 291.746
151.578 280.355 147.25 259.746 147.25 259.746 156.859 271.117 153.246 258.746
154.246 246.746 154.242 246.746 158.18 270.238 157.25 228.746 157.25 228.742
178.859 248.676 166.246 225.746 166.246 207.75 166.246 207.75 182.816 225.355
176.246 211.75 176.246 211.75 186.777 220.957 182.25 203.746 182.25 203.746
181.5 192.797 186.25 204.746 186.25 204.746 203.938 238.777 197.25 209.75
197.25 209.75 196.457 188.836 201.246 204.746 201.246 204.746 202.18 193.676
212.246 185.75 212.246 185.75 210.977 241.637 225.25 201.746 229.25 183.746
229.25 183.742 232.539 194.117 232.246 199.75 232.246 199.75 248.379 217.879
241.25 190.746 241.25 190.746 257.617 216.117 254.246 201.746 254.246 201.746
245.738 183.996 247.246 178.75 247.242 178.75 265.977 216.996 267.246 218.75
267.246 218.75 265.098 172.117 277.246 211.75 277.246 211.75 283.137 198.516
280.246 193.746 280.242 193.746 288.859 202.477 288.246 205.746 288.246 205.742
293.039 215.016 296.25 199.75 296.25 199.75 298.098 189.719 300.246 192.746
300.246 192.746 304.258 166.836 305.25 191.746 305.25 191.746 307.34 206.879
299.246 219.75 299.246 219.75 300.297 223.156 297.246 227.746 297.246 227.742
312.18 203.797 304.25 235.746 304.25 235.746 316.578 226.676 318.25 226.746
318.25 226.746 302.937 252.195 312.246 246.746 312.242 246.746 306.898 258.355
326.25 244.75 326.25 244.75 309.098 262.758 328.25 251.75 328.25 251.75
337.258 245.156 329.25 255.75 329.25 255.75 313.059 273.758 337.25 253.75
337.25 253.75 350.02 235.918 351.25 232.75 351.25 232.75 339.898 264.957
335.246 267.75 335.242 267.75 344.301 308.078 389.246 290.75 389.246 290.75
397.098 271.996 402.246 291.746 402.242 291.746 416.02 299.277 428.25 268.75
428.25 268.75 432.738 283.879 432.246 286.746 432.246 286.742 439.34 285.637
438.25 286.746 438.25 286.742 452.98 282.117 454.246 282.746 454.246 282.746
461.777 275.516 462.246 279.75 462.242 279.75 472.34 276.398 470.25 280.746
470.25 280.746 479.82 263.195 480.246 258.746 483.25 274.75 485.25 271.746
485.25 271.746 486.859 279.918 486.25 280.746 485.098 282.559 507.98 273.758
513.246 250.746 515.246 241.75 515.242 241.75 522.059 257.918 520.246 262.75
520.246 262.75 526.02 261.438 526.246 256.746 526.242 256.746 530.859 282.117
525.25 288.746 525.25 288.742 530.418 289.598 531.246 285.75 531.246 293.746
531.246 293.746 539.66 292.676 539.246 295.746 539.242 295.742 544.5 299.719
546.246 294.75 546.242 294.75 533.059 333.156 553.246 311.75 553.246 311.75
561.219 300.156 557.246 320.75 553.301 341.516 548.898 343.277 554.25 343.746
554.25 343.742 555.059 347.676 553.246 349.75 550.66 351.195 554.25 349.75
554.25 349.75 554.25 349.75 559.461 345.035 553.246 368.746 553.246 368.746
560.777 367.477 547.25 399.75 547.25 399.75 550.66 402.238 546.246 411.746
546.242 411.742 555.059 406.637 558.25 408.75 558.25 408.75 557.699 410.156
554.25 414.746 554.25 414.746 530.418 474.84 553.246 450.75 553.246 450.75
565.895 435.73 559.246 460.746 559.242 460.742 548.832 487.223 549.25 491.746
77.2461 466.746 10 1.1 0 0 0 0 0 0
88 77.2461 466.746 77.7383 459.973 78.8242 452.746 80.25 449.746 80.25
449.742 76.7773 435.676 86.25 420.746 86.25 420.742 86.0195 413.238 88.2461
409.746 88.2461 409.742 92.1797 400.477 97.25 399.75 101.73 398.887 111.324
395.508 122.246 393.75 122.246 393.75 141.02 378.477 137.246 364.75 137.242
364.75 137.059 346.355 133.246 344.75 133.246 344.75 145.859 356.918 135.25
338.75 130.25 317.746 130.25 317.742 158.617 341.516 141.25 321.746 130.25
292.75 130.25 292.75 152.02 312.918 144.246 303.75 140.25 293.746 140.25
293.746 188.098 323.918 154.246 291.746 154.242 291.746 163.02 295.316 168.25
291.746 168.25 291.746 175.34 293.559 174.25 291.746 174.25 291.746 151.578
280.355 147.25 259.746 147.25 259.746 156.859 271.117 153.246 258.746 154.246
246.746 154.242 246.746 158.18 270.238 157.25 228.746 157.25 228.742 178.859
248.676 166.246 225.746 166.246 207.75 166.246 207.75 182.816 225.355 176.246
211.75 176.246 211.75 186.777 220.957 182.25 203.746 182.25 203.746 181.5
192.797 186.25 204.746 186.25 204.746 203.938 238.777 197.25 209.75 197.25
209.75 196.457 188.836 201.246 204.746 201.246 204.746 202.18 193.676 212.246
185.75 212.246 185.75 210.977 241.637 225.25 201.746 229.25 183.746 229.25
183.742 232.539 194.117 232.246 199.75 232.246 199.75 248.379 217.879 241.25
190.746 241.25 190.746 257.617 216.117 254.246 201.746 254.246 201.746 245.738
183.996 247.246 178.75 247.242 178.75 265.977 216.996 267.246 218.75 267.246
218.75 265.098 172.117 277.246 211.75 277.246 211.75 283.137 198.516 280.246
193.746 280.242 193.746 288.859 202.477 288.246 205.746 288.246 205.742 293.039
215.016 296.25 199.75 296.25 199.75 298.098 189.719 300.246 192.746 300.246
192.746 304.258 166.836 305.25 191.746 305.25 191.746 307.34 206.879 299.246
219.75 299.246 219.75 300.297 223.156 297.246 227.746 297.246 227.742 312.18
203.797 304.25 235.746 304.25 235.746 316.578 226.676 318.25 226.746 318.25
226.746 302.937 252.195 312.246 246.746 312.242 246.746 306.898 258.355 326.25
244.75 326.25 244.75 309.098 262.758 328.25 251.75 328.25 251.75 337.258
245.156 329.25 255.75 329.25 255.75 313.059 273.758 337.25 253.75 337.25
253.75 350.02 235.918 351.25 232.75 351.25 232.75 339.898 264.957 335.246
267.75 335.242 267.75 344.301 308.078 389.246 290.75 389.246 290.75 397.098
271.996 402.246 291.746 402.242 291.746 416.02 299.277 428.25 268.75 428.25
268.75 432.738 283.879 432.246 286.746 432.246 286.742 439.34 285.637 438.25
286.746 438.25 286.742 452.98 282.117 454.246 282.746 454.246 282.746 461.777
275.516 462.246 279.75 462.242 279.75 472.34 276.398 470.25 280.746 470.25
280.746 479.82 263.195 480.246 258.746 483.25 274.75 485.25 271.746 485.25
271.746 486.859 279.918 486.25 280.746 485.098 282.559 507.98 273.758 513.246
250.746 515.246 241.75 515.242 241.75 522.059 257.918 520.246 262.75 520.246
262.75 526.02 261.438 526.246 256.746 526.242 256.746 530.859 282.117 525.25
288.746 525.25 288.742 530.418 289.598 531.246 285.75 531.246 293.746 531.246
293.746 539.66 292.676 539.246 295.746 539.242 295.742 544.5 299.719 546.246
294.75 546.242 294.75 533.059 333.156 553.246 311.75 553.246 311.75 561.219
300.156 557.246 320.75 553.301 341.516 548.898 343.277 554.25 343.746 554.25
343.742 555.059 347.676 553.246 349.75 550.66 351.195 554.25 349.75 554.25
349.75 554.25 349.75 559.461 345.035 553.246 368.746 553.246 368.746 560.777
367.477 547.25 399.75 547.25 399.75 550.66 402.238 546.246 411.746 546.242
411.742 555.059 406.637 558.25 408.75 558.25 408.75 557.699 410.156 554.25
414.746 554.25 414.746 530.418 474.84 553.246 450.75 553.246 450.75 565.895
435.73 559.246 460.746 559.242 460.742 548.832 487.223 549.25 491.746 77.2461
466.746 10 0 0.8 0.45 0.15 0.8 0.45 0.15 44
549.25 491.746 550.379 491.531 552.805 490.293 554.25 488.746 554.25 488.742
561.66 476.598 556.25 496.75 556.25 496.75 545.82 528.52 555.246 515.746
555.246 515.742 562.098 508.277 558.25 522.746 554.328 541.309 551.25 548.746
551.25 548.746 551.25 548.746 564.301 543.039 535.246 586.75 544.246 582.75
544.246 582.75 522.938 626.199 499.25 631.746 490.25 638.746 490.25 638.742
532.621 680.316 518.25 720.75 518.25 720.75 511.059 726.52 500.246 716.75
500.246 716.75 493.461 711.117 487.246 712.75 487.246 712.75 452.98 711.559
451.25 711.746 448.578 711.559 410.301 752.477 338.25 732.746 338.25 732.742
332.418 730.918 327.25 731.75 327.25 731.75 307.34 749.84 253.246 724.746
253.246 724.746 242.656 722.559 241.25 722.746 239.137 722.559 236.059 722.559
227.25 715.746 218.457 708.477 218.02 707.598 216.25 705.75 216.25 705.75
197.777 693.52 192.25 692.75 192.25 692.75 179.738 685.598 175.25 674.75
171.246 673.746 171.246 673.742 169.18 665.359 168.25 663.75 168.25 663.75
163.457 660.078 162.25 653.746 162.25 653.742 152.898 647.316 153.246 642.746
153.242 642.742 151.578 636.758 150.246 631.746 150.246 631.742 142.777 626.199
143.246 622.75 143.242 622.75 135.297 607.719 136.25 599.75 136.25 599.75
129.578 600.68 126.246 597.75 126.242 597.75 125.617 592.758 124.25 592.746
124.25 592.746 120.777 591 123.25 586.75 123.25 586.75 121.656 583.52
121.246 581.746 121.246 581.746 122.098 578.68 117.25 572.746 117.25 572.742
110.219 551.84 112.25 545.75 112.25 545.75 112.859 540.84 110.246 538.75
110.246 538.75 105.816 539.52 115.246 526.746 115.242 526.742 115.938 525
112.25 522.746 112.25 522.746 93.5 518.398 91.25 500.746 91.25 500.746
75.8984 484.078 76.2461 478.746 75.8984 475.824 76.1953 472.359 77.2461 467.746
77.2461 467.746 76.3398 458.117 106.25 456.746 137.059 456.355 549.25 491.746
549.25 491.746 10 1.1 0 0 0 0 0 0
44 549.25 491.746 550.379 491.531 552.805 490.293 554.25 488.746 554.25
488.742 561.66 476.598 556.25 496.75 556.25 496.75 545.82 528.52 555.246
515.746 555.246 515.742 562.098 508.277 558.25 522.746 554.328 541.309 551.25
548.746 551.25 548.746 551.25 548.746 564.301 543.039 535.246 586.75 544.246
582.75 544.246 582.75 522.938 626.199 499.25 631.746 490.25 638.746 490.25
638.742 532.621 680.316 518.25 720.75 518.25 720.75 511.059 726.52 500.246
716.75 500.246 716.75 493.461 711.117 487.246 712.75 487.246 712.75 452.98
711.559 451.25 711.746 448.578 711.559 410.301 752.477 338.25 732.746 338.25
732.742 332.418 730.918 327.25 731.75 327.25 731.75 307.34 749.84 253.246
724.746 253.246 724.746 242.656 722.559 241.25 722.746 239.137 722.559 236.059
722.559 227.25 715.746 218.457 708.477 218.02 707.598 216.25 705.75 216.25
705.75 197.777 693.52 192.25 692.75 192.25 692.75 179.738 685.598 175.25
674.75 171.246 673.746 171.246 673.742 169.18 665.359 168.25 663.75 168.25
663.75 163.457 660.078 162.25 653.746 162.25 653.742 152.898 647.316 153.246
642.746 153.242 642.742 151.578 636.758 150.246 631.746 150.246 631.742 142.777
626.199 143.246 622.75 143.242 622.75 135.297 607.719 136.25 599.75 136.25
599.75 129.578 600.68 126.246 597.75 126.242 597.75 125.617 592.758 124.25
592.746 124.25 592.746 120.777 591 123.25 586.75 123.25 586.75 121.656
583.52 121.246 581.746 121.246 581.746 122.098 578.68 117.25 572.746 117.25
572.742 110.219 551.84 112.25 545.75 112.25 545.75 112.859 540.84 110.246
538.75 110.246 538.75 105.816 539.52 115.246 526.746 115.242 526.742 115.938
525 112.25 522.746 112.25 522.746 93.5 518.398 91.25 500.746 91.25
500.746 75.8984 484.078 76.2461 478.746 75.8984 475.824 76.1953 472.359 77.2461
467.746 77.2461 467.746 76.3398 458.117 106.25 456.746 137.059 456.355 549.25
491.746 549.25 491.746 10 0 0.8 0.45 0.15 0.8 0.45
0.15 18 93.2461 466.746 65.3398 510.477 81.2461 448.75 81.2461 448.75
90.8594 410.598 233.246 451.746 233.246 451.746 233.246 451.742 419.098 485.398
431.246 489.746 443.738 494.199 548.246 486.746 548.246 486.746 542.246 505.75
471.02 556.68 449.898 531.156 435.246 535.746 419.98 539.957 422.621 529.398
419.246 528.746 415.578 527.637 372.461 554.918 365.246 553.75 358.379 553.156
330.504 579.285 347.25 544.746 364.539 506.957 282.699 501.238 264.246 513.746
245.738 525.879 272.25 493.746 272.25 493.746 292.379 471.316 254.246 489.746
254.246 489.746 216.699 503.879 190.297 475.719 187.246 474.75 183.258 473.957
177.977 470.438 177.246 477.746 176.219 484.52 167.957 502.891 133.246 473.746
111.098 455.695 96.25 479.75 96.25 479.75 93.2461 466.746 10 0
0.91 0.5 0.228 0.91 0.5 0.228 19 367.246 551.75 359.82
551.238 331.914 577.352 348.25 542.75 366.641 503.719 284.141 499.316 265.246
511.746 247.18 523.957 273.25 491.746 273.25 491.746 293.82 469.398 256.246
487.75 256.246 487.75 218.137 501.957 191.738 473.797 188.246 472.75 184.699
472.039 179.418 468.516 178.246 475.746 177.656 482.598 169.543 500.785 134.25
471.746 111.18 452.957 96.25 476.75 96.25 476.75 93.2461 465.75 65.3164
509.219 82.2461 444.746 82.2461 444.746 91.5781 407.238 235.246 449.746 235.246
449.746 235.242 449.742 420.539 483.477 433.246 487.75 445.18 492.277 549.25
485.75 549.25 485.75 543.25 504.746 471.578 555.398 451.34 529.238 436.25
533.746 421.418 538.039 424.059 527.477 420.246 526.746 417.02 525.719 373.898
552.996 367.246 551.75 10 0 0.919 0.55 0.305 0.919 0.55
0.305 19 368.246 549.75 361.258 549.316 334.051 575.75 350.25 540.75
367.641 500.695 285.578 497.398 267.246 509.75 248.617 522.035 275.246 489.746
275.246 489.746 295.258 467.477 257.246 485.75 257.246 485.75 219.578 500.035
193.18 471.875 189.246 470.75 186.137 470.117 180.859 466.598 180.246 473.746
179.098 480.676 171.125 498.68 136.25 469.746 111.258 450.215 97.25 472.75
97.25 472.75 93.2461 463.75 66.6172 506.637 82.2461 441.75 82.2461 441.75
92.2969 403.879 236.25 447.746 236.25 447.746 236.25 447.746 421.98 481.559
434.246 485.75 446.617 490.355 549.25 483.75 549.25 483.75 543.25 502.746
472.141 554.117 452.777 527.316 438.25 531.75 422.859 536.117 425.5 525.559
422.246 524.746 418.457 523.797 375.34 551.078 368.246 549.75 10 0
0.928 0.6 0.382 0.928 0.6 0.382 19 369.25 548.746 362.699
547.398 335.496 573.832 351.25 538.75 369.738 497.285 286.43 495.867 268.246
507.75 250.059 520.117 276.246 487.75 276.246 487.75 296.699 465.559 259.25
483.75 259.25 483.75 221.02 498.117 194.617 469.957 191.246 468.75 187.578
468.199 182.301 464.676 181.25 471.746 180.539 478.758 172.711 496.574 137.246
467.746 111.336 447.477 97.25 469.746 97.25 469.746 93.2461 461.75 68.7969
502.516 83.2461 438.746 83.2461 438.746 93.0195 400.516 237.25 445.746 237.25
445.746 237.25 445.746 423.418 479.637 435.246 483.75 448.059 488.438 550.246
481.75 550.246 481.75 544.246 501.75 472.699 552.84 454.219 525.398 439.25
529.75 424.301 534.199 426.938 523.637 423.246 522.746 419.898 521.879 376.777
549.156 369.25 548.746 10 0 0.937 0.65 0.46 0.937 0.65
0.46 19 371.25 546.746 364.141 545.477 337.492 572.156 352.25 536.75
371.18 493.559 288.457 493.559 270.25 505.75 251.5 518.195 278.246 485.75
278.246 485.75 298.141 463.637 260.25 481.75 260.25 481.75 222.457 496.195
196.059 468.035 192.25 466.746 189.02 466.277 183.738 462.758 183.25 469.746
181.98 476.836 174.297 494.473 139.246 466.746 111.418 444.738 97.25 466.746
97.25 466.746 93.2461 460.746 70.9766 498.617 84.25 434.746 84.25 434.746
93.7383 397.156 239.25 444.746 239.25 444.746 239.25 444.742 424.859 477.715
437.25 481.75 449.5 486.516 550.246 479.75 550.246 479.75 544.246 500.746
473.262 551.559 455.66 523.477 440.25 527.75 425.738 532.277 428.379 521.715
425.25 520.75 421.34 519.957 378.219 547.238 371.25 546.746 10 0
0.946 0.7 0.537 0.946 0.7 0.537 19 372.25 544.746 365.578
543.559 337.02 569.352 354.246 534.75 375.258 492.078 289.898 491.637 271.25
503.75 252.938 516.277 279.246 483.75 279.246 483.75 299.578 461.719 261.25
479.75 261.25 479.75 223.898 494.277 197.5 466.117 194.25 464.746 190.457
464.355 185.18 460.836 184.25 467.746 183.418 474.918 175.879 492.367 140.25
464.746 111.5 441.996 98.2461 462.746 98.2461 462.746 92.2461 458.746 72.9375
495.156 85.25 431.746 85.25 431.746 94.457 393.797 240.25 442.746 240.25
442.746 240.25 442.742 426.301 475.797 438.25 479.75 450.941 484.598 551.25
477.746 551.25 477.746 545.25 498.75 473.82 550.277 457.102 521.559 442.246
525.75 427.18 530.355 429.82 519.797 426.25 518.75 422.781 518.039 379.66
545.316 372.25 544.746 10 0 0.955 0.75 0.614 0.955 0.75
0.614 19 374.25 542.75 367.02 541.637 338.043 567.223 355.246 532.746
378.02 488.836 291.34 489.715 273.25 501.75 254.379 514.355 281.25 481.75
281.25 481.75 301.02 459.797 263.25 478.746 263.25 478.746 225.34 492.355
198.938 464.195 195.25 463.75 191.898 462.438 186.617 458.918 185.25 465.75
184.859 472.996 177.465 490.262 141.25 462.746 111.578 439.258 98.2461 459.75
98.2461 459.75 92.2461 456.746 75.1172 490.156 85.25 428.75 85.25 428.75
95.1797 390.438 242.246 440.746 242.246 440.746 242.246 440.742 427.738 473.875
440.25 478.746 452.379 482.676 551.25 475.746 551.25 475.746 545.25 497.746
474.379 548.996 458.539 519.637 443.246 523.75 428.621 528.438 431.258 517.875
427.25 516.75 424.219 516.117 381.102 543.398 374.25 542.75 10 0
0.964 0.8 0.691 0.964 0.8 0.691 19 375.246 540.75 368.461
539.719 338.273 564.66 357.246 530.746 381.219 487.355 292.777 487.797 274.25
499.746 255.82 512.438 282.25 479.75 282.25 479.75 302.457 457.879 264.246
476.75 264.246 476.75 226.777 490.438 200.379 462.277 197.25 461.75 193.34
460.516 188.059 456.996 187.246 463.75 186.297 471.078 179.047 488.156 143.246
460.746 111.656 436.516 99.2461 456.746 99.2461 456.746 92.2461 454.75 76.8555
486.477 86.25 424.75 86.25 424.75 95.8984 387.074 243.246 438.746 243.246
438.746 243.246 438.742 429.18 471.957 441.246 476.75 453.82 480.758 552.25
474.75 552.25 474.75 546.246 496.75 474.941 547.719 459.98 517.719 445.246
521.746 430.059 526.516 432.699 515.957 429.25 514.75 425.66 514.195 382.539
541.477 375.246 540.75 10 0 0.973 0.85 0.769 0.973 0.85
0.769 19 377.246 538.75 369.898 537.797 339.715 562.738 358.25 528.746
382.66 485.437 294.219 485.875 275.246 497.746 257.258 510.516 283.25 477.746
283.25 477.746 303.898 455.957 266.246 474.75 266.246 474.75 228.219 488.516
201.816 460.355 198.246 459.75 194.777 458.598 189.5 455.078 188.246 461.75
187.738 469.156 180.633 486.051 144.246 458.746 111.738 433.777 99.2461 452.75
99.2461 452.75 92.2461 453.746 77.7188 482.578 87.2461 421.75 87.2461 421.75
96.6172 383.715 245.246 436.746 245.246 436.746 245.246 436.746 430.621 470.035
443.246 474.75 455.258 478.836 552.25 472.75 552.25 472.75 547.25 495.746
475.5 546.438 461.418 515.797 446.246 519.746 431.5 524.598 434.141 514.035
430.246 512.75 427.098 512.277 383.98 539.555 377.246 538.75 10 0
0.982 0.9 0.846 0.982 0.9 0.846 19 378.246 536.75 371.34
535.879 341.578 561.055 360.25 526.746 384.098 482.195 295.66 483.957 277.246
496.75 258.699 508.598 285.25 475.746 285.25 475.746 305.34 454.035 267.246
472.75 267.246 472.75 229.66 486.598 203.258 458.438 199.246 457.75 196.219
456.676 190.937 453.156 190.246 459.75 189.18 467.238 182.219 483.949 146.25
456.746 111.82 431.035 99.2461 449.746 99.2461 449.746 92.2461 451.746 78.3594
478.238 87.2461 417.75 87.2461 417.75 97.3399 380.355 246.246 434.746 246.246
434.746 246.242 434.746 432.059 468.117 444.246 472.75 456.699 476.918 553.246
470.75 553.246 470.75 547.25 493.746 476.059 545.156 462.859 513.879 448.25
518.75 432.938 522.676 435.578 512.117 432.246 510.746 428.539 510.355 385.418
537.637 378.246 536.75 10 0 0.991 0.95 0.923 0.991 0.95
0.923 19 380.25 534.75 372.777 533.957 344.207 559.746 361.25 524.746
384.66 478.078 297.098 482.035 278.246 494.75 260.141 506.676 286.246 473.746
286.246 473.746 306.777 452.117 269.246 470.75 269.246 470.75 231.098 484.676
204.699 456.516 201.246 455.746 197.66 454.758 192.379 451.238 191.246 458.746
190.621 465.316 183.801 481.844 147.25 454.75 111.898 428.297 100.246 446.75
100.246 446.75 92.2461 449.746 78.5586 475.656 88.2461 414.746 88.2461 414.746
98.0586 376.996 248.25 432.75 248.25 432.75 248.25 432.75 433.5 466.195
446.246 470.75 458.141 474.996 553.246 468.75 553.246 468.75 548.246 492.75
476.621 543.879 464.301 511.957 449.25 516.75 434.379 520.758 437.02 510.195
433.246 509.75 429.98 508.438 386.859 535.719 380.25 534.75 10 0
1 1 1 1 1 1 18 92.2461 448.75 78.5391
472.637 89.2461 411.746 89.2461 411.746 98.7773 373.637 249.25 430.75 249.25
430.75 249.25 430.75 434.938 464.277 447.25 468.75 459.578 473.078 553.246
466.746 553.246 466.746 548.246 491.746 477.18 542.598 465.738 510.039 451.25
514.75 435.82 518.84 438.461 508.277 435.246 507.75 431.418 506.52 388.301
533.797 381.25 532.746 374.219 532.039 346.477 558.227 363.25 522.746 387.23
470.762 295.941 481.848 280.246 492.75 261.578 504.758 288.246 471.746 288.246
471.746 308.219 450.195 270.25 468.75 270.25 468.75 232.539 482.758 206.137
454.598 202.246 453.746 199.098 452.836 193.816 449.316 193.25 456.746 192.059
463.398 185.387 479.738 149.246 452.75 111.977 425.559 100.246 442.746 100.246
442.746 92.2461 448.75 10 0 0 0 0 0 0
0 7 138.246 415.75 138.246 415.75 130.457 402.676 153.246 387.746
153.242 387.742 154.879 386.617 135.25 390.746 135.25 390.746 128.258 393.438
126.246 404.75 126.242 404.75 121.219 409.719 116.246 415.75 110.656 422.035
138.246 415.75 138.246 415.75 10 0 0.8 0.8 0.8 0.8
0.8 0.8 8 292.25 467.746 292.25 467.746 311.848 438.297 311.246
432.75 309.758 421.598 309.539 411.035 313.246 406.75 316.578 402.238 326.25
365.746 326.25 365.746 326.25 365.742 325.82 364.398 339.25 405.746 339.25
405.742 352.219 423.797 330.25 443.75 330.25 443.75 291.5 475.719 292.25
467.746 10 0 0 0 0 0 0 0 15
160.246 385.746 160.246 385.742 172.699 378.035 157.25 343.746 164.246 346.746
164.242 346.746 163.02 334.035 159.246 331.75 167.25 334.75 167.25 334.75
172.699 326.117 168.25 320.75 168.25 320.75 186.777 312.035 186.25 304.746
186.25 304.746 192.938 313.797 188.246 320.75 184.137 327.879 176.219 323.477
177.246 343.746 167.25 339.746 167.25 339.742 173.578 349.879 173.25 356.75
165.246 354.746 165.242 354.742 181.793 383.512 170.246 384.75 163.457 385.957
160.246 385.746 160.246 385.746 10 0 0.8 0.8 0.8 0.8
0.8 0.8 5 196.25 367.75 196.25 367.75 199.098 372.316 196.25
371.75 192.938 370.559 158.617 354.277 152.25 343.746 152.25 343.742 189.859
370.559 196.25 367.75 10 0 0.8 0.8 0.8 0.8 0.8
0.8 5 207.25 358.75 207.25 358.75 210.539 363.516 207.25 362.75
204.379 361.758 170.059 345.477 163.25 334.75 163.25 334.75 201.297 361.758
207.25 358.75 10 0 0.8 0.8 0.8 0.8 0.8 0.8
5 222.246 375.75 222.246 375.75 225.059 380.238 222.246 379.746 218.898
378.477 184.578 362.195 178.246 351.75 178.246 351.75 215.816 378.477 222.246
375.75 10 0 0.8 0.8 0.8 0.8 0.8 0.8 5
196.25 327.75 196.25 327.75 196.457 334.035 193.25 332.746 190.297 332.277
150.699 312.918 144.246 302.746 144.246 302.746 190.297 330.516 196.25 327.75
10 0 0.8 0.8 0.8 0.8 0.8 0.8 5 198.246
339.746 198.246 339.742 199.098 344.598 196.25 343.746 193.816 343.719 164.777
330.957 158.25 320.75 158.25 320.75 190.738 344.156 198.246 339.746 10
0 0.8 0.8 0.8 0.8 0.8 0.8 24 182.25 286.746
171.246 278.75 171.246 278.75 182.379 286.957 186.25 285.75 186.25 285.75
178.859 273.316 178.246 267.75 178.246 267.75 189.418 281.676 195.25 280.746
195.25 280.746 203.938 280.797 204.25 268.75 204.25 268.75 210.098 280.355
213.246 279.75 213.242 279.75 214.938 272.879 213.246 265.75 213.242 265.75
218.02 273.758 222.246 271.746 222.246 271.746 229.457 274.195 228.25 261.746
228.25 261.742 228.578 249.996 227.25 246.746 227.25 246.746 233.859 275.957
236.25 276.75 236.25 276.75 245.297 277.719 250.25 267.75 250.25 267.75
246.18 276.398 251.25 273.746 251.25 273.742 263.34 272.438 267.246 264.746
267.246 264.742 259.379 278.156 265.246 274.75 265.246 274.75 273.02 274.637
274.25 267.75 274.25 267.75 283.578 244.277 286.246 242.75 286.246 242.75
277.418 266.277 279.246 266.746 279.242 266.742 276.977 279.477 282.25 262.75
282.25 262.75 279.18 278.598 285.25 277.746 291.5 276.836 296.34 265.836
305.25 268.75 305.25 268.75 316.141 262.316 318.25 338.75 182.25 286.746
10 0 0 0 0 0 0 0 15 187.246
388.75 187.246 388.75 203.5 395.637 247.246 388.75 247.242 388.75 255.418
388.598 263.25 398.746 270.379 407.957 299.859 415.879 307.25 413.75 317.25
406.75 318.25 405.746 318.25 405.742 331.98 393.879 332.246 385.746 332.859
377.156 316.578 324.355 306.25 306.746 295.457 289.156 284.898 275.516 264.246
277.746 264.246 277.742 240.898 282.559 212.246 277.746 212.246 277.742 180.617
279.918 177.246 288.746 174.457 297.516 190.246 313.746 190.246 313.746 190.246
313.746 194.699 323.477 193.25 339.746 192.059 355.156 192.5 385.957 187.246
388.75 10 0 0.9 0.4 0.55 0.9 0.4 0.55 8
211.246 386.75 220.656 366.598 188.246 294.75 188.246 294.75 185.898 293.117
202.023 286.469 213.246 288.746 225.219 292.059 269.246 287.75 269.246 287.75
295.457 304.559 309.246 353.75 309.246 353.75 309.246 353.75 320.98 379.797
301.246 383.746 282.258 386.836 211.246 386.75 211.246 386.75 10 0
0.7 0.2 0.35 0.7 0.2 0.35 6 209.246 352.746 212.844
366.922 214.586 379.902 211.246 386.75 211.246 386.75 280.059 379.797 292.25
402.75 297.043 411.34 313.277 377.598 313.246 366.75 313.242 366.75 243.539
351.195 227.25 363.746 209.246 352.746 10 0 0.65 0.15 0.3
0.65 0.15 0.3 13 214.25 334.75 214.25 334.75 216.258 326.996
213.246 322.75 213.242 322.75 211.859 321.719 210.246 321.746 210.246 321.742
211.859 317.316 218.25 315.746 218.25 315.746 220.656 310.719 223.246 310.746
225.938 309.836 231.219 303.676 235.246 304.746 240.02 306.316 252.25 310.746
252.25 310.746 252.25 310.742 258.5 314.238 268.246 310.746 268.242 310.742
270.789 311.16 271.25 315.746 271.809 320.727 275.219 324.797 277.246 326.746
279.617 329.195 290.18 343.277 289.246 343.746 287.539 344.156 214.25 334.75
214.25 334.75 10 0 1 0.45 0.5 1 0.45 0.5
12 209.246 387.746 209.246 387.742 206.137 363.516 209.246 354.746 213.18
345.035 212.297 342.836 211.246 338.75 210.539 334.035 215.379 323.035 221.246
316.75 234.246 314.75 234.246 314.75 251.457 318.637 261.25 315.746 261.25
315.746 271.473 314.078 275.246 330.746 275.246 330.742 280.5 337.559 288.246
340.75 296.34 343.719 304.258 389.477 300.246 398.746 295.457 407.078 279.617
411.918 262.25 394.746 244.418 377.598 242.219 396.078 209.246 387.746 10
1.1 0 0 0 0 0 0 12 209.246 387.746
209.246 387.742 206.137 363.516 209.246 354.746 213.18 345.035 212.297 342.836
211.246 338.75 210.539 334.035 215.379 323.035 221.246 316.75 234.246 314.75
234.246 314.75 251.457 318.637 261.25 315.746 261.25 315.746 271.473 314.078
275.246 330.746 275.246 330.742 280.5 337.559 288.246 340.75 296.34 343.719
304.258 389.477 300.246 398.746 295.457 407.078 279.617 411.918 262.25 394.746
244.418 377.598 242.219 396.078 209.246 387.746 10 0 1 1
0.8 1 1 0.8 7 211.246 305.75 211.246 305.75 210.098
308.078 205.25 308.746 205.25 308.742 180.617 312.477 171.246 325.75 171.246
325.75 163.898 332.277 168.25 319.746 168.25 319.742 180.18 297.078 187.246
293.746 187.246 293.746 205.699 289.598 211.246 305.75 10 0.55 0
0 0 0 0 0 7 211.246 305.75 211.246 305.75
210.098 308.078 205.25 308.746 205.25 308.742 180.617 312.477 171.246 325.75
171.246 325.75 163.898 332.277 168.25 319.746 168.25 319.742 180.18 297.078
187.246 293.746 187.246 293.746 205.699 289.598 211.246 305.75 10 0
0.8 0.25 0.3 0.8 0.25 0.3 9 299.246 375.75 299.641
384.941 301.789 394.418 300.246 398.746 292.766 412.461 274.098 406.535 262.25
394.746 244.418 377.598 242.219 396.078 209.246 387.746 209.246 387.742 207.297
372.797 208.25 361.746 208.25 361.742 249.258 374.516 250.25 368.746 250.25
368.746 251.898 371.879 262.25 371.75 272.137 371.879 297.152 373.168 299.246
375.75 10 2.2 0.65 0.1 0.15 0.65 0.1 0.15 3
251.25 387.746 251.25 387.742 256.738 381.996 253.246 371.75 253.246 371.75
236.938 353.836 239.25 338.75 10 0 1 1 0.8 1
1 0.8 5 198.246 293.746 198.246 293.746 193.816 308.078 203.25
300.75 203.25 300.75 208.777 298.398 207.25 296.75 206.137 294.879 199.977
290.477 198.246 293.746 10 0.55 0 0 0 0 0
0 5 198.246 293.746 198.246 293.746 193.816 308.078 203.25 300.75
203.25 300.75 208.777 298.398 207.25 296.75 206.137 294.879 199.977 290.477
198.246 293.746 10 0 1 1 0.8 1 1 0.8
5 204.25 292.75 204.25 292.75 200.328 303.941 208.25 297.746 208.25
297.742 212.937 295.266 211.246 294.75 206.227 293.383 211.242 290.566 204.25
292.75 10 0.55 0 0 0 0 0 0 5
204.25 292.75 204.25 292.75 200.328 303.941 208.25 297.746 208.25 297.742
212.937 295.266 211.246 294.75 206.227 293.383 211.242 290.566 204.25 292.75
10 0 1 1 0.8 1 1 0.8 5 209.246
292.75 209.246 292.75 205.609 303.941 213.246 297.746 213.242 297.742 218.168
295.414 216.25 294.75 212.824 293.383 216.523 290.566 209.246 292.75 10
0.55 0 0 0 0 0 0 5 209.246 292.75
209.246 292.75 205.609 303.941 213.246 297.746 213.242 297.742 218.168 295.414
216.25 294.75 212.824 293.383 216.523 290.566 209.246 292.75 10 0
1 1 0.8 1 1 0.8 5 216.25 292.75 216.25
292.75 212.871 303.723 220.246 297.746 220.246 297.742 225.434 295.172 224.246
294.75 220.527 293.383 223.781 290.344 216.25 292.75 10 0.55 0
0 0 0 0 0 5 216.25 292.75 216.25 292.75
212.871 303.723 220.246 297.746 220.246 297.742 225.434 295.172 224.246 294.75
220.527 293.383 223.781 290.344 216.25 292.75 10 0 1 1
0.8 1 1 0.8 5 224.246 292.75 224.242 292.75 220
303.809 227.25 297.746 227.25 297.742 231.969 296.066 231.246 294.75 229.855
293.25 230.91 290.434 224.246 292.75 10 0.55 0 0 0
0 0 0 5 224.246 292.75 224.242 292.75 220 303.809
227.25 297.746 227.25 297.742 231.969 296.066 231.246 294.75 229.855 293.25
230.91 290.434 224.246 292.75 10 0 1 1 0.8 1
1 0.8 5 231.246 291.746 231.246 291.746 225.938 305.438 236.25
298.75 236.25 298.75 241.34 296.195 240.25 294.75 238.699 292.676 240.02
289.156 231.246 291.746 10 0.55 0 0 0 0 0
0 5 231.246 291.746 231.246 291.746 225.938 305.438 236.25 298.75
236.25 298.75 241.34 296.195 240.25 294.75 238.699 292.676 240.02 289.156
231.246 291.746 10 2.2 0.65 0.15 0.3 0.65 0.15 0.3
4 200.246 310.746 200.246 310.742 214.5 313.797 221.246 310.746 221.246
310.742 227.699 308.957 229.25 309.75 230.34 309.836 234.246 310.746 234.246
310.746 10 2.2 0.65 0.15 0.3 0.65 0.15 0.3 4
237.25 300.75 237.25 300.75 250.578 315.996 264.246 310.746 271.496 308.328
270.379 312.035 271.25 314.75 272.137 318.195 272.359 322.816 278.246 325.75
10 0 1 1 0.8 1 1 0.8 7 256.246
318.75 256.246 318.75 251.898 330.516 249.25 316.75 245.738 302.355 242.219
298.398 240.25 295.746 240.25 295.742 240.457 289.598 249.25 289.75 249.25
289.75 261.578 290.477 262.25 293.746 262.457 296.637 260.699 309.398 256.246
318.75 10 0.55 0 0 0 0 0 0 7
256.246 318.75 256.246 318.75 251.898 330.516 249.25 316.75 245.738 302.355
242.219 298.398 240.25 295.746 240.25 295.742 240.457 289.598 249.25 289.75
249.25 289.75 261.578 290.477 262.25 293.746 262.457 296.637 260.699 309.398
256.246 318.75 10 2.2 0.65 0.15 0.3 0.65 0.15 0.3
2 271.25 310.746 271.25 310.742 275.656 313.355 278.246 311.75 10
2.2 0.65 0.15 0.3 0.65 0.15 0.3 2 279.246 328.746
279.242 328.742 282.039 334.148 287.246 334.75 10 0 0.7 0.7
0.7 0.7 0.7 0.7 6 191.246 288.746 191.242 288.742 211.418
284.758 216.25 286.746 216.25 286.742 225.938 286.516 216.25 284.746 216.25
284.742 202.617 284.316 194.25 285.75 194.25 285.75 181.059 291.797 191.246
288.746 10 0 1 1 0.8 1 1 0.8 7
207.25 390.746 207.25 390.746 226.379 390.797 228.25 389.75 228.25 389.75
236.5 356.035 232.246 347.75 232.246 347.75 231.219 344.598 228.25 350.746
228.25 350.742 207.898 386.836 204.25 388.75 200.859 391.238 205.699 390.797
207.25 390.746 10 0.55 0 0 0 0 0 0
7 207.25 390.746 207.25 390.746 226.379 390.797 228.25 389.75 228.25
389.75 236.5 356.035 232.246 347.75 232.246 347.75 231.219 344.598 228.25
350.746 228.25 350.742 207.898 386.836 204.25 388.75 200.859 391.238 205.699
390.797 207.25 390.746 10 0 1 1 0.8 1 1
0.8 7 122.246 393.75 122.246 393.75 132 391.898 146.25 388.75
146.25 388.75 151.137 364.398 154.246 358.75 158.18 353.836 154.219 353.836
150.246 356.75 146.297 359.996 130.02 375.398 128.25 379.746 125.617 385.078
122.246 393.75 122.246 393.75 10 0.55 0 0 0 0
0 0 7 122.246 393.75 122.246 393.75 132 391.898 146.25
388.75 146.25 388.75 151.137 364.398 154.246 358.75 158.18 353.836 154.219
353.836 150.246 356.75 146.297 359.996 130.02 375.398 128.25 379.746 125.617
385.078 122.246 393.75 122.246 393.75 10 0 1 1 0.8
1 1 0.8 6 146.25 388.75 146.25 388.75 152.637 387.094
153.246 384.75 154.855 382.223 152.25 378.75 152.25 378.75 152.25 378.75
151.324 374.961 150.246 377.75 148.68 379.719 145.52 388.145 146.25 388.75
10 0.55 0 0 0 0 0 0 6 146.25
388.75 146.25 388.75 152.637 387.094 153.246 384.75 154.855 382.223 152.25
378.75 152.25 378.75 152.25 378.75 151.324 374.961 150.246 377.75 148.68
379.719 145.52 388.145 146.25 388.75 10 0 0 0 0
0 0 0 10 146.25 388.75 146.25 388.75 150.258 383.316
154.246 383.746 158.18 383.316 158.598 383.77 161.246 382.75 166.758 381.996
166.316 384.195 173.25 382.75 176.48 382.348 179.297 383.316 182.25 381.746
185.457 380.676 188.977 381.559 190.246 383.746 191.617 385.957 197.25 390.746
197.25 390.746 197.25 390.746 182.816 388.598 179.246 387.746 179.246 387.742
155.098 386.398 146.25 388.75 10 0 1 1 0.8 1
1 0.8 6 195.25 388.75 195.25 388.75 188.262 384.969 188.246
382.75 187.383 379.688 193.25 375.75 193.25 375.75 193.25 375.75 196.625
370.559 197.25 372.746 197.941 375.836 196.238 388.379 195.25 388.75 10
0.55 0 0 0 0 0 0 6 195.25 388.75
195.25 388.75 188.262 384.969 188.246 382.75 187.383 379.688 193.25 375.75
193.25 375.75 193.25 375.75 196.625 370.559 197.25 372.746 197.941 375.836
196.238 388.379 195.25 388.75 10 0 1 1 0.8 1
1 0.8 5 154.246 382.75 154.242 382.75 161.832 370.5 162.25
382.75 162.25 382.75 162.684 384.215 160.246 383.746 154.066 384.324 155.738
388.836 154.246 382.75 10 0.55 0 0 0 0 0
0 5 154.246 382.75 154.242 382.75 161.832 370.5 162.25 382.75
162.25 382.75 162.684 384.215 160.246 383.746 154.066 384.324 155.738 388.836
154.246 382.75 10 0 1 1 0.8 1 1 0.8
5 162.25 382.75 162.25 382.75 170.734 370.227 170.246 382.75 170.242
382.75 170.043 383 168.25 382.75 162.891 383.625 163.27 388.594 162.25
382.75 10 0.55 0 0 0 0 0 0 5
162.25 382.75 162.25 382.75 170.734 370.227 170.246 382.75 170.242 382.75
170.043 383 168.25 382.75 162.891 383.625 163.27 388.594 162.25 382.75
10 0 1 1 0.8 1 1 0.8 5 170.246
382.75 170.242 382.75 178.711 370.832 178.246 381.746 178.246 381.746 178.105
382.82 176.246 382.75 172.004 383.93 171.773 387.504 170.246 382.75 10
0.55 0 0 0 0 0 0 5 170.246 382.75
170.242 382.75 178.711 370.832 178.246 381.746 178.246 381.746 178.105 382.82
176.246 382.75 172.004 383.93 171.773 387.504 170.246 382.75 10 0
1 1 0.8 1 1 0.8 5 177.246 382.75 177.246
382.75 186.207 369.719 186.25 380.75 186.25 380.75 188.398 381.992 186.25
381.746 180.078 383.051 180.957 387.953 177.246 382.75 10 0.55 0
0 0 0 0 0 5 177.246 382.75 177.246 382.75
186.207 369.719 186.25 380.75 186.25 380.75 188.398 381.992 186.25 381.746
180.078 383.051 180.957 387.953 177.246 382.75 10 0 0.9 0.9
0.7 0.9 0.9 0.7 6 137.246 378.75 129.25 379.746 126.441
385.738 124.25 392.746 124.25 392.746 124.25 392.746 131.117 391.402 145.25
388.75 145.25 388.75 145.832 384.672 147.25 378.75 137.246 378.75 10
0 0.9 0.9 0.7 0.9 0.9 0.7 7 209.246 383.746
207.469 386.437 206.02 388.371 205.25 388.75 201.992 390.891 206.547 390.477
208.25 390.746 208.25 390.746 226.02 390.477 228.25 389.75 228.25 389.75
228.668 387.18 229.25 383.746 229.25 383.742 218.32 385.66 209.246 383.746
10 0 0.8 0.45 0.15 0.8 0.45 0.15 10 268.246
535.746 298.758 531.289 326.832 570.492 329.25 580.75 330.703 591.789 319.25
604.75 319.25 604.75 321.023 608.246 315.699 623.734 310.246 633.75 304.082
644.063 286.594 642.992 267.246 643.75 249.875 645.031 229.547 619.379 228.25
617.75 226.641 615.508 233.418 573.398 235.246 566.75 236.32 560.813 233.246
531.75 233.246 531.75 271.082 541.781 237.773 540 268.246 535.746 10
0 0.92 0.56 0.32 0.92 0.56 0.32 10 229.25 616.746
227.469 614.828 234.121 573.484 235.246 567.75 236.973 561.129 234.246 532.746
234.246 532.746 270.063 542.387 238.398 540.695 268.246 536.75 298.273 532.141
325.836 570.633 327.25 580.75 329.637 591.543 318.25 604.75 318.25 604.75
320.133 607.699 314.906 622.906 309.246 632.75 303.504 642.867 286.332 641.813
267.246 642.746 250.277 643.816 230.32 618.629 229.25 616.746 10 0
0.94 0.67 0.49 0.94 0.67 0.49 10 229.25 615.75 228.297
614.152 234.824 573.574 236.25 567.75 237.625 561.445 235.246 533.746 235.246
533.746 269.371 543.539 239.023 541.391 268.246 536.75 297.793 532.996 324.844
570.773 326.25 580.75 328.574 591.297 318.25 603.746 318.25 603.746 319.246
607.156 314.113 622.078 308.246 631.746 302.922 641.668 286.066 640.637 267.246
641.75 250.684 642.602 231.094 617.883 229.25 615.75 10 0 0.96
0.78 0.66 0.96 0.78 0.66 10 230.25 615.75 229.125 613.473
235.531 573.66 237.25 567.75 238.277 561.762 235.246 534.75 235.246 534.75
267.91 544.25 239.648 542.086 268.246 537.746 297.309 533.852 323.848 570.914
325.25 580.75 327.508 591.051 317.25 603.746 317.25 603.746 318.355 606.609
313.324 621.254 308.246 630.75 302.34 640.473 285.805 639.457 267.246 640.746
251.09 641.387 231.871 617.133 230.25 615.75 10 0 0.98 0.89
0.83 0.98 0.89 0.83 10 231.246 614.746 229.949 612.797 236.234
573.75 237.25 567.75 238.926 562.082 236.25 534.75 236.25 534.75 266.891
544.965 240.273 542.781 268.246 538.75 296.824 534.703 322.855 571.055 324.246
580.75 326.445 590.805 316.25 602.75 316.25 602.75 317.469 606.063 312.531
620.426 307.25 629.746 301.762 639.273 285.543 638.281 267.246 639.75 251.492
640.172 232.645 616.387 231.246 614.746 10 0 1 1 1
1 1 1 10 268.246 539.746 296.34 535.559 321.859 571.199
323.246 580.75 325.379 590.559 315.25 602.75 315.25 602.75 316.578 605.52
311.738 619.598 306.25 628.75 301.18 638.078 285.277 637.102 267.246 637.75
251.898 638.957 233.418 615.637 232.246 613.75 230.777 612.117 236.938 573.84
238.25 567.75 239.578 562.398 237.25 535.746 237.25 535.746 264.988 545.457
240.898 543.477 268.246 539.746 10 0 0.8 0.8 0.8 0.8
0.8 0.8 6 319.25 576.746 319.25 576.742 289.078 568.559 276.246
570.746 276.246 570.746 258.937 577.578 249.25 553.75 249.25 553.75 245.297
545.68 243.246 543.746 240.898 541.277 319.25 576.746 319.25 576.746 10
0 0 0 0 0 0 0 11 324.246 579.746
324.242 579.746 291.937 565.918 281.25 566.75 281.25 566.75 262.898 571.418
253.246 555.75 253.246 555.75 244.418 545.238 241.25 543.746 241.25 543.742
240.457 541.719 247.246 545.75 259.25 540.75 259.25 540.75 275.219 529.84
286.246 547.75 286.246 547.75 290.18 559.758 290.246 561.746 290.18 564.156
313.5 570.316 315.25 570.746 317.02 571.199 324.277 575.816 324.246 579.746
10 0 0.6 0.8 0.2 0.6 0.8 0.2 6 271.25
539.746 264.141 539.832 254.93 544.086 255.246 550.746 254.93 557.832 264.141
564.723 271.25 564.75 279.258 564.723 285.387 559.152 285.25 552.746 285.387
545.402 279.258 539.832 271.25 539.746 10 0 0.4 0.6 0
0.4 0.6 0 6 267.246 557.746 262.383 557.391 256.785 555.738
257.246 555.75 258.559 561.055 265.555 564.723 271.25 564.75 276.422 564.723
280.59 562.547 283.25 558.75 283.25 558.75 277.203 559.598 267.246 557.746
10 0 1 1 1 1 1 1 4 281.25
558.75 281.25 558.75 276.098 561.957 276.246 559.746 276.246 559.746 280.059
554.699 281.25 558.75 10 0 0 0 0 0 0
0 6 270.25 549.75 267.187 549.5 264.961 551.727 265.246 554.746
264.961 557.227 267.187 559.457 270.25 559.746 272.687 559.457 274.918 557.227
275.246 554.746 274.918 551.727 272.687 549.5 270.25 549.75 10 0
0.8 0.45 0.15 0.8 0.45 0.15 15 155.246 563.746 155.246
563.742 152.02 587.477 154.246 592.746 154.242 592.746 166.539 603.316 166.246
607.746 166.246 607.742 165.656 627.078 164.246 627.746 163.02 628.84 154.656
635.438 148.246 628.75 148.242 628.75 136.617 608.598 137.246 601.746 137.246
599.75 137.242 599.75 129.137 599.797 127.246 597.75 127.246 597.75 126.059
591.879 124.25 591.75 124.25 591.75 121.656 588.797 124.25 585.746 124.25
585.742 121.656 583.078 122.246 578.75 130.25 574.746 130.25 574.742 132.656
558.438 144.246 552.746 149.859 550.156 153.34 557.559 155.246 563.746 10
0 1 1 1 1 1 1 15 154.246 565.746
154.242 565.742 151.27 587.172 153.246 591.75 153.242 591.75 164.34 601.426
164.246 604.75 164.242 604.75 163.547 622.809 162.25 623.746 161.172 624.395
153.645 630.336 147.25 623.746 147.25 623.746 137.41 606.18 138.246 599.75
138.246 597.75 138.246 597.75 130.68 598.258 129.25 596.746 129.25 596.742
127.906 591.129 126.246 590.746 126.242 590.746 123.945 588.359 126.246 585.746
126.242 585.742 123.945 583.211 124.25 579.746 132.246 575.75 132.246 575.75
133.848 561.035 144.246 555.75 149.324 553.582 152.457 560.242 154.246 565.746
10 0 0.925 0.588 0.363 0.925 0.588 0.363 15 164.246
626.75 162.645 627.816 154.406 634.16 148.246 627.746 148.242 627.742 136.816
607.992 137.246 600.75 137.246 598.746 137.242 598.742 129.523 599.414 128.25
597.75 128.25 597.75 126.52 591.691 125.25 591.75 125.25 591.75 122.23
588.688 124.25 585.746 124.25 585.742 122.23 583.109 122.246 578.75 131.246
574.746 131.242 574.742 132.953 559.086 144.246 553.75 149.723 551.012 153.117
558.23 155.246 564.75 155.246 564.75 151.832 587.402 154.246 591.75 154.242
591.75 165.988 602.844 165.246 606.75 165.242 606.75 165.129 626.012 164.246
626.75 10 0 0.95 0.725 0.575 0.95 0.725 0.575 15
163.25 625.746 162.27 626.793 154.152 632.887 148.246 625.746 148.242 625.746
137.016 607.387 138.246 600.75 138.246 598.746 138.246 598.742 129.906 599.027
128.25 596.746 128.25 596.742 126.98 591.504 125.25 590.746 125.25 590.746
122.801 588.578 125.25 585.746 125.25 585.742 122.801 583.145 123.25 578.75
131.246 574.746 131.242 574.742 133.254 559.734 144.246 554.746 149.59 551.867
152.898 558.898 155.246 564.75 155.246 564.75 151.645 587.324 154.246 591.75
154.242 591.75 165.438 602.371 165.246 605.746 165.242 605.742 164.602 624.945
163.25 625.746 10 0 0.975 0.863 0.788 0.975 0.863 0.788
15 163.25 624.75 161.895 625.77 153.898 631.609 148.246 624.75 148.242
624.75 137.211 606.781 138.246 600.75 138.246 597.75 138.246 597.75 130.293
598.645 128.25 596.746 128.25 596.742 127.445 591.316 126.246 590.746 126.242
590.746 123.375 588.469 125.25 585.746 125.25 585.742 123.375 583.176 124.25
578.75 131.246 574.746 131.242 574.742 133.551 560.387 144.246 554.746 149.457
552.727 152.68 559.57 154.246 565.746 154.242 565.742 151.457 587.246 154.246
591.75 154.242 591.75 164.887 601.898 164.246 605.746 164.242 605.742 164.074
623.879 163.25 624.75 10 0 1 1 1 1 1
1 15 154.246 566.75 154.242 566.75 151.27 587.172 153.246 591.75
153.242 591.75 164.34 601.426 164.246 604.75 164.242 604.75 163.547 622.809
162.25 623.746 161.523 624.746 153.645 630.336 147.25 623.746 147.25 623.746
137.41 606.18 138.246 599.75 138.246 597.75 138.246 597.75 130.68 598.258
129.25 596.746 129.25 596.742 127.906 591.129 126.246 590.746 126.242 590.746
123.945 588.359 126.246 585.746 126.242 585.742 123.945 583.211 124.25 579.746
132.246 575.75 132.246 575.75 133.848 561.035 144.246 555.75 149.324 553.582
152.457 560.352 154.246 566.75 10 0 0.8 0.8 0.8 0.8
0.8 0.8 5 151.25 572.746 151.25 572.742 127.27 584.398 126.246
585.746 126.242 585.742 136.289 576.258 137.246 576.746 138.047 576.258 151.25
572.746 151.25 572.746 10 0 0 0 0 0 0
0 5 132.246 579.746 132.246 579.746 152.457 576.039 152.25 570.746
152.457 567.996 152.191 553.234 146.25 554.746 137.059 557.559 141.02 573.398
132.246 579.746 10 0 0.6 0.8 0.2 0.6 0.8 0.2
5 141.25 575.75 141.25 575.75 151.332 574.195 152.25 570.746 153.117
569.438 153.848 560.301 148.246 558.75 142.832 558.098 140.379 569.34 141.25
575.75 10 0 0 0 0 0 0 0 44
236.25 528.746 235.504 530.93 236.949 530.785 239.25 531.75 241.117 532.039
254.539 536.219 255.246 538.75 256.297 541.938 271.25 536.75 271.25 536.75
272.797 536.219 277.246 533.746 277.246 533.746 282.918 532.039 290.246 531.75
290.246 531.75 292.816 530.5 296.25 527.75 296.25 527.75 312.617 516.199
326.25 523.75 326.25 523.75 348.258 531.379 341.25 550.746 341.25 550.746
338.359 560.199 342.246 563.746 342.246 563.746 342.098 568.117 350.25 560.75
350.25 560.75 352.879 556.457 354.246 550.746 354.246 550.746 362.559 538.637
359.25 557.746 359.25 557.746 359.039 559.316 355.961 563.277 356.246 564.75
355.961 565.918 354.246 569.75 354.246 569.75 350.68 573.398 353.246 580.75
353.246 580.75 355.301 596.277 353.246 594.746 353.246 594.746 351.559 596.277
341.25 585.746 341.25 585.746 339.02 581.539 332.246 579.746 332.246 579.746
329.34 577.797 325.25 579.746 325.25 579.746 322.738 579.777 316.25 571.75
316.25 571.75 319.66 572.297 322.301 567.457 325.25 566.75 327.578 567.02
329.559 569.879 331.246 570.746 333.078 571.199 336.25 564.75 336.25 564.75
336.598 561.957 330.25 556.75 330.25 556.75 330 551.617 328.25 553.75
328.25 553.75 324.938 554.039 323.621 549.859 322.246 544.746 321.418 539.738
317.25 539.746 317.25 539.746 315.039 531.156 313.246 534.75 313.246 534.75
313.5 540.617 307.25 533.746 307.25 533.746 305.578 532.039 300.246 534.75
300.246 534.75 293.039 536.656 295.25 538.75 295.25 538.75 297.656 541.277
310.246 538.75 310.246 538.75 312.398 540.617 303.25 544.746 303.25 544.746
302.937 547 304.25 551.75 304.25 551.75 305.359 555.359 313.246 561.746
313.246 561.746 323.18 562.84 320.246 564.75 320.246 564.75 313.277 570.316
307.25 561.746 307.25 561.746 304.477 555.137 285.25 538.75 285.25 538.75
280.059 534.898 282.918 542.379 278.246 538.75 274.117 534.898 251.25 544.746
251.25 544.746 238.738 546.109 235.734 528.793 232.246 531.75 232.246 531.75
237.813 522.855 236.25 528.746 10 0 0 0 0 0
0 0 12 450.25 711.746 450.25 711.746 422.18 703.199 419.246
682.746 419.246 682.742 416.461 657.438 439.25 637.75 439.25 637.75 439.34
631.039 441.246 627.746 441.246 627.742 439.777 622.238 460.246 630.75 490.25
639.75 490.25 639.75 497.418 642.477 503.25 651.746 508.859 661.84 525.578
682.52 521.25 709.75 521.25 709.75 522.938 722.559 516.25 722.746 516.25
722.746 507.098 724.758 499.25 716.75 499.25 716.75 491.699 712.879 489.246
713.746 450.25 711.746 10 0 0 0 0 0 0
0 8 510.25 712.75 510.25 712.75 512.73 722.91 507.25 717.746
507.25 717.742 499.664 711.293 491.246 711.746 491.242 711.746 475.465 708.875
470.25 694.75 470.25 694.75 466.266 664.828 475.25 658.746 475.25 658.746
480.305 650.309 488.25 657.75 495.793 664.828 512.844 698.082 510.25 712.75
10 0 0.2 0.2 0.2 0.2 0.2 0.2 8 510.25
712.75 510.25 712.75 512.309 722.313 507.25 716.75 507.25 716.75 499.48
710.906 491.246 710.746 491.242 710.742 475.719 708.531 471.246 694.75 471.242
694.75 466.691 665.289 475.25 658.746 475.25 658.746 480.469 651.031 488.25
657.75 495.68 665.289 512.387 697.961 510.25 712.75 10 0 0.4
0.4 0.4 0.4 0.4 0.4 8 509.246 712.75 509.246 712.75
511.887 721.715 507.25 716.75 507.25 716.75 499.293 710.52 491.246 710.746
491.242 710.742 475.973 708.188 471.246 693.746 471.242 693.742 467.113 665.746
475.25 659.75 475.25 659.75 480.637 651.754 488.25 658.746 495.563 665.746
511.93 697.84 509.246 712.75 10 0 0.6 0.6 0.6 0.6
0.6 0.6 8 509.246 711.746 509.246 711.746 511.465 721.113 506.246
715.746 506.242 715.742 499.109 710.133 491.246 709.75 491.242 709.75 476.23
707.844 471.246 693.746 471.242 693.742 467.535 666.203 476.246 660.746 476.246
660.742 480.805 652.477 488.25 659.75 495.449 666.203 511.477 697.719 509.246
711.746 10 0 0.8 0.8 0.8 0.8 0.8 0.8 8
509.246 711.746 509.246 711.746 511.043 720.516 506.246 715.746 506.242 715.742
498.926 709.746 491.246 709.75 491.242 709.75 476.484 707.5 472.25 693.746
472.25 693.742 467.957 666.66 476.246 660.746 476.246 660.742 480.973 653.195
488.25 659.75 495.332 666.66 511.02 697.598 509.246 711.746 10 0
1 1 1 1 1 1 8 508.25 710.746 508.25
710.742 510.621 719.918 506.246 714.75 506.242 714.75 498.738 709.359 491.246
709.75 491.242 709.75 476.738 707.156 472.25 693.746 472.25 693.742 468.379
667.117 476.246 661.75 476.246 661.75 481.141 653.918 488.25 660.746 495.219
667.117 510.563 697.477 508.25 710.746 10 0 0.6 0.15 0
0.6 0.15 0 24 275.246 487.75 275.246 487.75 253.219 508.719
244.246 509.75 244.246 509.75 206.578 514 190.246 493.746 190.246 493.742
209.656 516.637 240.25 510.746 240.25 510.742 216.258 515.316 202.246 511.746
202.242 511.746 184.137 511.797 173.25 496.75 170.246 490.75 170.242 490.75
174.898 507.398 195.25 513.746 195.25 513.746 220.219 519.277 232.246 513.746
232.246 513.746 208.34 521.477 197.25 519.746 197.25 519.742 163.898 521.918
150.246 492.75 150.246 492.75 154.219 508.719 170.246 516.75 170.242 516.75
185.457 526.316 208.25 522.746 208.25 522.746 223.738 519.719 229.25 516.75
235.18 514.438 233.859 517.52 224.246 522.746 224.242 522.746 218.457 533.797
203.25 533.746 203.25 533.746 155.977 529.398 144.246 515.746 144.246 515.742
159.5 528.52 171.246 531.75 171.246 531.75 195.578 540.398 205.25 539.746
205.25 539.742 232.098 538.418 240.25 542.75 240.25 542.75 228.137 537.316
231.246 533.746 235.18 530.277 242.656 521.918 242.246 520.75 242.656 519.277
269.277 494.969 273.25 489.746 275.246 487.75 10 0 0.8 0.8
0.8 0.8 0.8 0.8 5 428.25 273.746 428.25 273.742 410.848
314.348 397.246 324.746 397.246 324.746 425.699 307.199 429.25 287.75 429.25
287.75 429.547 276.398 428.25 273.746 10 0 0.8 0.8 0.8
0.8 0.8 0.8 7 479.25 265.75 479.25 265.75 450.449 326.449
430.246 352.746 430.246 352.742 477.949 311.598 483.25 282.746 484.246 276.75
480.246 278.75 480.242 278.75 480.148 269.25 479.25 265.75 10 0
0.8 0.8 0.8 0.8 0.8 0.8 5 542.246 319.746 542.246
319.742 473 384.75 471.246 387.746 471.242 387.742 537.898 314.898 541.25
306.746 541.25 306.742 539 316.547 542.246 319.746 10 0 0.8
0.8 0.8 0.8 0.8 0.8 6 334.246 271.746 334.246 271.746
355.848 328.648 377.246 303.75 377.246 303.75 393.25 292.898 392.25 289.75
392.25 289.75 388.297 296.75 368.246 295.746 368.242 295.742 347.598 299.5
334.246 271.746 10 0 0.8 0.8 0.8 0.8 0.8 0.8
5 544.246 411.746 544.246 411.742 494.449 443.047 486.25 444.746 473.211
447.297 540.648 412.797 546.246 400.75 546.242 400.75 548.348 404 544.246
411.746 10 0 0 0 0 0 0 0 63
378.246 294.75 378.246 294.75 400.621 296.637 408.246 303.75 413.246 299.746
432.246 342.75 436.25 336.75 436.25 336.75 452.098 352.957 451.25 361.746
450.34 370.559 465.246 354.746 465.246 354.746 465.246 354.742 464.418 367.918
472.25 360.75 472.25 360.75 469.699 377.598 479.25 368.746 479.25 368.746
467.348 401.969 492.25 373.75 498.301 366.598 493.246 373.75 493.246 373.75
493.242 373.75 464.859 426.879 488.25 410.75 488.25 410.75 490.82 436.117
489.246 440.746 488.18 445.797 485.98 470.438 480.246 475.746 475.418 481.879
481.141 483.637 487.246 477.746 487.246 477.742 474.98 504.316 489.246 490.75
489.246 490.75 485.539 507.84 480.246 510.746 480.242 510.742 474.539 529.84
491.246 517.746 491.242 517.742 486.418 531.598 483.25 534.75 483.25 534.75
470.141 565.477 478.246 559.746 483.25 555.75 483.25 555.75 475.418 571.637
482.246 566.75 489.5 561.957 489.246 562.75 489.246 562.75 489.246 562.75
466.18 598.918 488.25 579.746 488.25 579.746 479.645 594.867 476.246 602.75
476.246 602.75 455.18 624.879 471.246 617.75 476.246 615.75 476.246 615.75
466.621 627.078 458.246 628.75 449.02 630.598 460.461 637.637 467.246 635.75
474.539 633.238 491.246 624.75 491.246 624.75 491.242 624.75 505.777 604.199
510.25 603.746 510.25 603.746 488.18 612.117 495.246 603.746 495.242 603.746
510.621 587.918 502.246 588.75 502.242 588.75 496.098 580.438 501.25 570.746
501.25 570.746 481.074 590.988 497.25 562.75 505.25 544.746 505.25 544.746
478.059 572.078 490.25 547.75 490.25 547.75 509.301 521.918 511.246 521.746
513.699 521.039 518.25 511.746 518.25 511.746 513.246 513.746 519.25 503.75
519.25 503.75 507.098 517.078 513.246 502.746 520.246 486.746 520.246 486.742
497.418 510.918 512.25 478.746 512.25 478.746 494.34 484.078 504.246 464.746
504.242 464.742 502.258 447.559 502.246 441.75 503.141 436.117 504.461 404.879
499.25 395.75 494.777 387.277 506.219 366.156 508.25 361.746 510.621 357.355
514.578 345.477 505.25 355.75 495.219 365.719 500.059 359.559 502.246 349.75
504.461 340.195 511.059 323.035 510.25 316.75 510.25 316.75 508.859 315.559
505.25 319.746 505.25 319.742 489.059 344.598 491.246 328.746 491.242 328.742
489.5 319.957 486.25 310.746 486.25 310.742 482.461 298.398 482.246 307.75
482.242 307.75 478.938 326.559 476.246 317.746 472.777 309.836 468.82 303.238
465.246 300.75 462.66 297.957 456.938 323.035 455.25 311.75 455.25 311.75
442.418 325.238 437.25 306.746 424.246 288.746 424.242 288.742 423.938 302.797
422.246 295.746 422.246 295.742 389.621 289.598 378.246 294.75 10 0
0 0 0 0 0 0 34 340.25 686.746 340.25
686.742 327.578 695.719 323.246 695.746 318.777 694.84 353.539 704.957 399.246
674.75 399.246 674.75 404.141 671.52 408.246 671.746 408.246 671.742 411.621
669.316 408.246 665.75 408.246 665.75 398.859 654.797 411.246 642.746 411.246
642.742 431.418 635 425.25 644.75 425.25 644.75 437.141 640.277 440.25
635.75 442.418 631.477 441.246 635.75 441.246 635.75 441.246 635.75 434.059
643.797 427.25 649.746 427.25 649.742 421.738 651.719 418.25 660.746 415.578
670.199 412.938 681.199 418.25 684.746 418.25 684.742 413.379 679.879 414.25
684.746 415.141 688.68 419.098 692.637 421.246 692.75 422.621 693.52 440.66
710.898 448.25 711.746 448.25 711.746 438.02 709.797 434.246 710.746 431.418
712 402.16 724.539 395.25 725.75 395.25 725.75 377.078 733.117 390.246
730.746 390.242 730.742 429.66 726.738 449.25 711.746 449.25 711.746 441.758
721.457 421.246 728.746 421.246 728.742 397.098 743.02 358.25 737.746 358.25
737.742 338.801 734 330.25 731.75 330.25 731.75 327.359 732.68 326.25
732.746 326.039 733.559 313.059 743.457 282.25 735.746 282.25 735.746 264
730.699 254.246 725.75 254.246 725.75 237.816 724.098 234.246 720.75 234.246
720.75 213.398 704.52 211.246 703.75 209 702.758 196.457 694.398 195.25
693.746 195.25 693.742 222.637 701.219 225.25 703.75 227.918 706.5 247.059
709.359 249.25 707.75 252.34 706.277 261.578 706.938 251.25 706.746 251.25
706.742 334.18 690 335.246 687.75 335.938 685.598 340.25 686.746 340.25
686.746 10 0 0.8 0.45 0.15 0.8 0.45 0.15 13
419.246 696.75 419.246 696.75 407.66 705.18 405.25 704.746 403.258 705.18
389.621 716.398 385.25 715.746 380.379 715.52 366.961 726.52 337.25 717.746
337.25 717.742 336.16 719.699 340.25 720.75 340.25 720.75 347.16 723
347.25 723.75 347.25 723.75 369.82 728.277 377.246 724.746 377.246 724.746
387.859 721.457 394.25 714.75 394.25 714.75 407 711.117 410.246 711.746
410.246 711.746 420.199 709.797 420.246 707.75 420.246 707.75 427.02 704.52
425.25 701.75 425.25 701.75 425.48 699.898 419.246 696.75 10 0
0.8 0.45 0.15 0.8 0.45 0.15 38 405.25 699.746 406.047
698.664 407.168 698.555 408.246 697.746 408.094 697.32 407.773 696.961 407.25
696.75 406.281 696.504 405.121 697.133 404.25 696.75 403.422 696.258 402.715
696.457 402.246 696.75 400.313 697.105 398.301 697.137 396.25 696.75 394.254
697.621 391.66 696.977 389.246 697.746 389.309 698.109 389.063 697.727 389.246
697.746 385.629 699.016 381.512 698.707 379.246 700.746 376.168 701.672 373.574
702.18 371.25 702.746 368.906 703.488 367.355 704.574 365.246 705.75 364.059
706.27 362.457 706.844 361.25 707.75 358.719 707.75 356.703 707.625 354.246
707.75 354.52 708.227 354.309 707.848 354.246 707.75 353.863 707.996 353.543
708.637 353.246 708.746 351.508 708.004 349.871 709.074 348.25 708.746 346.742
710.043 344.844 709.773 343.246 710.746 339.883 711.195 336.414 709.797 333.246
710.746 337.602 712.926 342.758 711.57 347.25 713.746 349.789 715.148 352.715
713.938 355.246 714.75 356.078 714.934 356.84 715.152 357.246 714.75 357.426
714.566 357.625 714.828 357.246 714.75 360.387 713.527 362.934 712.125 365.246
710.746 366.039 710.793 366.621 711.047 367.246 710.746 368.57 709.488 370.711
709.602 372.25 708.746 374.105 708.809 376.078 708.391 378.246 708.746 378.066
709.109 378.324 708.734 378.246 708.746 379.602 709.582 380.875 709.281 382.25
708.746 382.227 708.82 382.957 708.551 383.25 708.746 384.531 708.164 385.473
707.637 387.246 707.75 386.895 707.414 387.098 707.789 387.246 707.75 388.41
707.277 389.559 707.34 390.246 705.75 390.426 706.207 390.609 706.469 390.246
706.746 391.828 706.066 392.543 705.238 394.25 704.746 394.289 704.855 394.961
704.168 395.25 703.75 398.227 703.168 400.254 701.488 402.246 700.746 403.5
700.16 404.465 699.902 405.25 699.746 10 0 0.8 0.45 0.15
0.8 0.45 0.15 23 321.246 714.75 318.094 716.91 315.488 718.125
313.246 719.746 312.605 720.234 312.207 720.051 312.246 719.746 310.879 720.852
309.902 721.492 309.246 722.746 308.227 722.68 307.324 722.664 307.25 722.746
303.969 724.371 301.074 724.984 298.246 726.746 299.066 727 300.301 726.73
301.246 727.75 301.172 727.309 301.434 726.996 302.246 726.746 303.668 728.203
305.703 728.371 307.25 728.746 309.422 728.172 311.313 727.836 313.246 727.75
313.605 727.484 313.824 726.91 314.25 726.746 316.629 726.074 319.258 726.648
321.246 725.75 323.336 725.035 325.066 724.133 326.25 722.746 326.703 722.441
326.348 722.113 326.25 721.746 326.465 722.02 326.766 721.793 327.25 721.746
326.98 721.184 326.98 720.852 327.25 720.75 326.766 720.246 326.457 720.133
326.25 719.746 324.5 719.871 326.449 721.387 325.25 720.75 324.277 720
325.098 718.453 324.246 716.75 323.973 717.27 323.719 717.512 324.246 717.746
324.098 717.363 323.434 717.043 323.246 716.75 322.824 715.898 321.836 714.344
321.246 714.75 10 0 0.8 0.45 0.15 0.8 0.45 0.15
25 285.25 706.746 281.645 707.801 278.293 707.676 275.246 708.746 274.898
709.109 274.656 708.727 274.25 708.746 273.082 709.41 272.07 710.473 271.25
711.746 269.883 712.602 268.059 712.176 266.246 712.75 266.301 712.848 266.078
713.41 266.246 713.746 264.406 713.625 263.387 714.672 262.25 715.746 264.809
716.172 267.461 716.137 270.25 716.75 270.293 716.582 270.453 716.227 270.25
715.746 270.746 716.227 270.891 716.469 271.25 716.75 271.254 716.309 271.586
715.953 272.25 715.746 272.469 716.824 273.082 716.617 273.25 716.75 273.836
716.563 273.973 716.227 274.25 715.746 274.27 716.227 274.41 716.57 274.25
716.75 274.707 716.57 274.852 716.227 275.246 715.746 275.148 716.227 275.289
716.469 275.246 716.75 276.199 715.758 277.172 716.367 278.246 715.746 279.219
715.922 279.512 714.656 280.246 714.75 285.879 712.895 290.43 710.535 295.25
707.75 295.566 708.078 295.801 707.805 295.25 707.75 295.973 707.379 296.316
707.477 296.25 707.75 297.688 706.523 298.832 705.922 299.246 704.746 299.84
704.34 299.477 703.895 299.246 703.75 294.348 705.047 289.941 705.715 285.25
706.746 10 0 0.8 0.45 0.15 0.8 0.45 0.15 10
270.25 658.746 268.117 659.637 267.477 661.871 266.246 663.75 266 664.215
266.301 664.563 266.246 664.746 267.266 664.832 267.863 664.309 268.246 663.75
270.234 663.137 271.922 661.77 274.25 661.75 276.309 659.16 280.992 658.738
281.25 654.75 281 654.074 279.43 655.082 279.246 653.746 276.262 655.242
273.633 655.129 271.25 656.746 270.336 657.16 270.699 657.66 270.25 658.746
10 0 0.8 0.45 0.15 0.8 0.45 0.15 6 239.25
715.746 239.727 716.129 247.461 715.871 247.246 715.746 247.391 715.406 238.891
714.254 238.25 714.75 238.309 714.523 230.047 711.852 230.25 711.746 230.191
712.148 239.285 716.129 239.25 715.746 10 0 0 0 0
0 0 0 80 256.246 705.75 256.246 705.75 240.238 703.418
235.246 701.75 230.559 700.777 210.098 692.418 207.25 689.746 207.25 689.746
192.059 684.277 173.25 662.746 173.25 662.742 181.719 666.02 184.25 668.75
184.25 668.75 199.098 682.957 199.246 679.75 199.246 679.75 212.297 689.559
211.246 686.746 211.246 686.742 238.477 699.457 236.25 695.746 236.25 695.742
260.039 701 259.25 698.75 259.25 698.75 279.617 693.957 276.246 693.746
276.246 693.742 270.156 692.418 277.246 688.746 277.246 688.742 273.457 683.617
267.246 687.75 261.578 692.418 264.879 690 259.25 688.746 259.25 688.742
256.52 688.02 251.25 692.75 251.25 692.75 245.297 697.477 235.246 693.746
235.242 693.742 201.957 679.656 200.246 678.746 200.246 678.746 195.797 675.918
193.25 671.746 193.25 671.742 186.777 667.117 183.25 665.75 183.25 665.75
169.398 652.816 168.25 651.746 168.25 651.742 164.34 645.559 163.25 644.75
163.25 644.75 170.5 649.297 172.25 651.746 172.25 651.742 188.098 662.5
194.25 663.75 194.25 663.75 198.879 666.68 200.246 667.746 200.246 667.746
215.598 678.34 220.246 678.746 220.246 678.746 230.34 672.617 233.246 680.746
233.246 680.746 239.359 682.297 245.246 680.746 245.246 680.746 249.039 683.84
248.25 686.746 248.25 686.742 249.918 688.238 251.25 683.75 251.25 683.75
254.758 680.098 260.25 682.746 260.25 682.742 264.437 682.52 262.25 679.75
262.25 679.75 257.398 675.699 244.246 675.746 244.246 675.742 230.777 674.816
212.246 666.75 212.246 666.75 179.957 655.02 170.246 643.75 170.242 643.75
162.797 633.898 157.25 632.75 157.25 632.75 150.477 631.699 144.246 623.746
144.246 623.746 154.656 629.938 164.246 629.746 164.242 629.742 168.957 632.578
165.246 628.75 165.242 628.75 160.816 620.258 162.25 614.746 162.25 614.746
161.918 608.598 161.246 606.75 161.246 606.75 152.457 592.758 152.25 589.75
152.457 587.477 153.777 576.699 154.246 575.75 154.656 575.379 153.117 577.797
157.25 574.746 161.477 572.52 164.559 570.758 165.246 567.75 166.316 564.598
163.238 573.617 163.25 575.75 162.797 577.578 158.18 585.5 159.246 587.746
159.242 587.742 160.156 587.039 161.246 585.746 161.246 585.742 160.379 586.156
161.246 589.75 161.246 589.75 161.918 595.84 163.25 599.75 165 602.879
167.199 607.059 167.25 607.746 168.078 608.816 168.078 615.199 169.25 612.746
173.25 609.746 173.25 609.742 170.277 612.34 172.25 614.746 172.25 614.746
171.598 620.918 173.25 623.746 173.25 623.746 181.277 633.02 183.25 633.75
184.797 635.219 183.25 634.746 183.25 634.746 183.25 634.746 189.859 639.398
183.25 637.75 183.25 637.75 179.078 635.879 176.246 635.75 176.246 635.75
167.418 633.68 172.25 638.746 176.219 642.918 187.219 648.859 191.246 648.75
192.25 646.75 204.25 649.746 203.25 648.75 203.25 648.75 203.059 648.859
207.25 649.746 212.297 649.738 218.68 648.199 220.246 649.746 221.758 652.156
225.5 653.258 225.25 651.746 224.617 650.18 224.246 647.746 224.246 647.746
224.242 647.746 229.898 654.359 229.25 651.746 228.578 649.52 219.559 643.797
218.25 636.746 229.25 645.746 233.246 649.746 233.246 649.742 237.379 646.879
237.25 648.75 237.816 650.398 242.879 656.777 244.246 656.746 245.52 656.34
247.719 659.418 247.246 656.746 247.277 653.699 255.246 647.746 255.246 647.746
255.246 647.746 259.156 649.738 260.25 647.746 262.238 646.656 267.246 669.746
267.246 669.746 294.25 681.75 342.246 685.75 323.246 692.75 256.246 705.75
10 2.2 0.3 0 0 0.3 0 0 3 276.246
486.746 276.246 486.742 260.039 504.977 251.25 507.75 251.25 507.75 236.059
515.316 209.246 506.746 10 2.2 0.3 0 0 0.3 0
0 3 247.246 509.75 247.242 509.75 219.559 518.18 202.246 513.746
202.242 513.746 182.379 511.359 173.25 495.746 10 2.2 0.3 0
0 0.3 0 0 4 243.246 510.746 243.246 510.742 224.617
518.617 208.25 520.75 208.25 520.75 190.078 523.898 172.25 515.746 172.25
515.742 158.398 509.379 152.25 497.746 10 2.2 0.3 0 0
0.3 0 0 4 244.246 510.746 244.246 510.742 227.477 522.359
226.25 523.75 226.25 523.75 218.68 536 204.25 536.75 204.25 536.75
180.84 535.559 162.25 526.746 10 0 0 0 0 0
0 0 169 243.246 519.746 244.68 518.543 274.25 486.746 274.25
486.746 313.059 446.457 282.25 483.75 282.25 483.75 273.898 489.359 264.246
509.75 264.246 509.75 262.457 513.117 279.246 501.75 279.246 501.75 283.578
501.238 298.246 479.75 298.246 479.75 291.059 482.758 296.25 474.75 296.25
474.75 299.418 472.637 322.246 455.746 322.246 455.746 325.82 451.078 330.25
449.746 330.25 449.746 345.621 455.035 338.25 440.746 338.25 440.746 341.219
433.035 347.25 445.746 347.25 445.746 359.699 464.277 341.25 461.75 341.25
461.75 308.656 458.559 301.246 475.746 301.246 475.746 298.539 478.797 308.246
475.746 308.246 475.746 317.461 473.957 300.246 489.746 300.246 489.746 302.937
489.797 313.246 482.746 313.246 482.746 324.5 472.199 326.25 474.75 326.25
474.75 346.5 484.078 358.25 475.746 358.25 475.746 360.141 473.957 353.98
466.477 355.246 460.746 357.5 455.035 363.25 441.75 363.25 441.75 360.141
439.637 360.25 427.746 360.25 427.746 379.059 402.238 368.246 404.75 368.246
404.75 351.34 404.879 367.246 396.746 367.246 396.746 371.141 394.316 381.25
386.75 381.25 386.75 377.738 387.719 376.246 381.746 376.246 381.746 381.258
377.598 378.246 372.746 378.246 372.746 371.578 370.996 370.25 366.75 370.25
366.75 377.738 357.797 366.246 357.746 366.246 357.746 370.699 352.516 365.246
339.746 365.246 339.746 360.141 339.316 353.246 332.746 353.246 332.746 355.738
327.879 344.246 321.746 344.246 321.746 335.059 319.957 338.25 312.75 338.25
312.75 329.34 305.879 326.25 288.746 326.25 288.746 325.82 276.836 323.18
273.316 329.25 275.746 334.621 277.719 333.246 291.746 333.246 291.746 328.461
308.516 375.246 325.75 375.246 325.75 379.938 327.879 381.25 333.75 381.25
333.75 383.02 333.156 392.25 324.746 392.25 324.746 401.059 312.477 401.246
322.75 401.246 322.75 402.82 326.559 401.246 332.746 401.246 332.746 407.66
356.918 392.25 363.746 392.25 363.746 381.258 400.918 396.25 391.75 396.25
391.75 399.738 385.516 411.246 379.746 411.246 379.746 415.25 382.75 413.82
387.719 423.246 394.746 423.246 394.746 426.141 387.277 432.246 395.75 432.246
395.75 436.699 422.918 450.25 406.75 450.25 406.75 454.738 405.758 456.246
412.746 456.246 412.746 460.02 424.676 456.246 439.75 456.246 439.75 460.02
440.078 470.25 433.746 470.25 433.746 473.66 437.438 463.539 455.918 468.25
453.746 472.34 450.637 477.25 448.75 477.25 448.75 478.059 451.078 467.246
464.746 467.246 464.746 462.219 467.797 456.246 489.746 456.246 489.746 464.418
486.277 453.25 502.746 453.25 502.746 453.418 506.52 460.246 518.75 460.246
518.75 459.141 526.316 460.246 525.75 460.246 525.75 463.098 524.559 471.898
522.797 464.25 529.75 456.938 536.879 465.246 541.746 465.246 541.746 470.141
545.238 455.25 544.746 455.25 544.746 449.461 549.637 450.25 553.75 450.25
553.75 458.699 551.84 442.859 567.68 440.25 571.75 437.578 575.598 448.25
581.746 448.25 581.746 462.66 585.277 450.25 588.75 450.25 588.75 428.34
588.359 440.25 599.75 440.25 599.75 446.82 599.797 445.246 602.75 445.246
602.75 439.34 603.758 429.25 610.75 429.25 610.75 424.379 614.758 428.25
613.75 428.25 613.75 446.82 612.559 415.25 624.75 415.25 624.75 423.938
624.879 404.25 636.746 404.25 636.746 401.938 638.078 398.246 646.75 398.246
646.75 391.82 652.156 386.246 659.75 386.246 659.75 386.098 664.477 381.25
669.746 381.25 669.746 368.059 684.719 362.25 684.746 362.25 684.746 345.621
688.238 340.25 687.75 340.25 687.75 282.25 682.746 252.777 668.438 261.25
645.746 261.25 645.746 268.398 636.098 278.246 640.746 278.246 640.746 283.578
647.098 296.25 644.75 296.25 644.75 318.777 641.156 316.25 644.75 316.25
644.75 313.277 650.18 295.457 657 295.25 657.75 295.02 658.316 285.25
661.75 285.25 661.75 282.039 663.379 277.246 673.746 277.246 673.746 273.68
677.238 291.246 670.75 291.246 670.75 289.738 669.758 298.246 665.75 298.246
665.75 317.02 666.457 328.25 654.75 328.25 654.75 340.559 636.316 341.25
645.746 341.25 645.746 343.859 655.68 331.246 678.746 331.246 678.746 331.32
681.199 340.25 673.746 340.25 673.746 341.879 676.137 343.246 669.746 343.246
669.746 342.98 667.117 347.25 658.746 347.25 658.746 350.238 644.02 354.246
651.746 354.246 651.746 359.25 641.75 360.801 638.957 354.246 630.75 354.246
630.75 353.98 627.52 354.859 627.738 348.25 619.75 342.539 611.02 346.246
605.746 346.246 605.746 344.738 598.918 354.246 599.75 354.246 599.75 357.277
596.938 361.25 596.746 361.25 596.746 363 594.738 365.246 595.75 365.246
595.75 367.398 599.578 374.25 597.75 374.25 597.75 375.758 600.02 385.25
600.75 385.25 600.75 385.879 603.316 386.32 605.078 390.246 605.746 393.801
606.398 366.246 653.746 366.246 653.746 373.777 654.578 365.246 667.746 365.246
667.746 362.34 675.477 374.879 659.418 377.246 657.75 379.719 656.34 380.82
653.918 379.246 653.746 377.301 654.359 375.32 651.938 377.246 651.746 378.398
651.5 392.699 635 396.25 623.746 400.18 612.559 406.777 608.156 413.246
601.746 420.418 594.957 419.246 568.746 419.246 568.746 419.098 558.656 425.25
546.746 425.25 546.746 427.898 542.816 423.246 522.746 423.246 522.746 421.078
520.379 422.246 519.746 422.246 519.746 423.719 518.18 431.246 503.75 431.246
503.75 429.219 503.879 433.246 499.746 433.246 499.746 438.898 493.316 432.246
496.75 432.246 496.75 425.258 498.379 433.246 487.75 433.246 487.75 434.277
485.617 424.246 490.75 424.246 490.75 414.258 491.34 427.25 483.75 427.25
483.75 436.48 475.5 424.246 480.746 424.246 480.746 418.879 482.316 422.246
474.75 422.246 474.75 425.918 473.078 445.246 465.75 445.246 465.75 445.277
461.195 442.246 455.746 442.246 455.746 442.418 451.297 440.25 447.746 440.25
447.746 438.68 438.535 438.25 437.75 438.25 437.75 433.398 437.438 425.25
422.746 425.25 422.746 423.277 419.398 412.246 405.746 412.246 405.746 409.859
398.496 390.246 406.75 390.246 406.75 382.801 402.676 385.25 406.75 385.25
406.75 384.559 408.836 390.246 415.75 390.246 415.75 397.539 418.297 394.25
429.746 394.25 429.746 399.078 431.719 386.758 434.797 387.246 435.75 387.199
437.438 393.25 438.746 393.25 438.746 402.379 441.176 397.246 443.75 397.246
443.75 396.879 448.219 400.246 454.75 400.246 454.75 412.938 455.258 400.246
472.75 400.246 472.75 388.301 481.438 387.246 487.75 387.246 487.75 401.059
496.84 392.039 510.477 392.25 514.75 392.48 518.398 394.25 541.746 394.25
541.746 391.598 548.977 388.246 563.746 388.246 563.746 390.719 569.656 399.246
583.746 399.246 583.746 401.938 588.137 411.621 593.418 409.246 596.746 406.777
600.02 398.246 597.75 398.246 597.75 389.621 599.578 390.246 593.75 390.246
593.75 388.52 592.758 387.246 587.746 387.246 587.746 386.848 578.531 377.246
571.75 377.246 571.75 364.758 564.816 375.246 560.75 375.246 560.75 381.48
553.156 370.25 552.746 370.25 552.746 358.598 554.918 367.246 543.746 367.246
543.746 379.5 529.617 376.246 526.746 376.246 526.746 364.98 525.438 379.246
515.746 379.246 515.746 379.242 515.742 377.961 517.52 378.246 515.746 378.398
513.559 381.699 508.938 382.25 506.746 383.461 504.539 379.246 504.746 379.246
504.746 379.719 493.758 363.25 498.75 363.25 498.75 363.25 498.75 362.777
498.379 361.25 497.746 359.258 497.938 346.938 498.816 340.25 500.746 334.18
503.656 326.25 503.75 326.25 503.75 326.25 503.75 322.301 501.68 314.25
501.75 305.578 502.117 297.246 498.75 297.246 498.75 291.937 499.477 301.398
504.316 301.246 503.75 301.84 503.879 308 510.039 299.246 509.75 275.223
507.578 263.25 518.75 263.25 518.75 261.137 520.379 258.246 523.75 258.246
523.75 247.277 525.656 260.25 509.75 260.25 509.75 261.137 508.277 259.25
506.746 259.25 506.746 258.719 508.938 250.25 514.75 250.25 514.75 247.047
515.949 245.547 517.414 243.246 519.746 10 0 0.3 0 0
0.3 0 0 7 216.25 532.746 216.25 532.742 229.457 526.758
232.246 523.75 235.18 520.598 250.25 507.75 250.25 507.75 250.25 507.75
244.637 510.258 242.246 511.746 238.918 514.219 227.25 522.746 227.25 522.746
227.25 522.746 222.859 529.84 216.25 532.746 10 0 0.6 0.8
0.2 0.6 0.8 0.2 6 153.246 566.75 153.258 567.398 152.684
570.379 152.25 570.746 151.332 573.977 141.25 575.75 141.25 575.75 141.207
574.098 141.148 572.34 141.25 570.746 141.25 570.746 146.621 564.469 153.246
566.75 10 0 0.4 0.6 0 0.4 0.6 0 6
153.246 567.75 152.395 567.281 152.871 570.461 152.25 570.746 151.555 573.977
141.25 575.75 141.25 575.75 141.207 574.207 141.148 572.449 141.25 570.746
141.25 570.746 145.961 565.02 153.246 567.75 10 0 0 0
0 0 0 0 6 148.246 567.75 147.371 567.297 146.812
568.551 147.25 569.75 146.812 571.645 147.371 572.898 148.246 572.746 148.746
572.898 149.305 571.645 149.246 569.75 149.305 568.551 148.746 567.297 148.246
567.75 10 0 0 0 0 0 0 0 17
98.2461 459.75 98.2422 459.75 91.7383 448.438 119.25 454.75 119.25 454.75
134.418 456.355 137.246 458.746 138.379 458.117 147.582 454.891 150.246 453.746
158.18 452.398 167.25 463.75 167.25 463.75 167.25 463.75 172.477 474.949
175.25 474.75 178.637 474.949 175.25 472.75 175.25 472.75 175.25 472.75
167.859 462.078 168.25 460.746 168.25 460.742 162.578 438.316 145.25 437.75
145.25 437.75 127.215 436.391 128.25 429.746 128.25 429.742 138.379 432.598
141.25 429.746 141.25 429.742 152.898 430.398 144.246 423.746 136.25 410.75
136.25 410.75 136.773 406.289 125.25 409.746 114.84 413.898 103.25 427.746
103.25 427.746 103.25 427.742 85.9648 444.094 98.2461 459.75 10 0
0.9 0.6 0.6 0.9 0.6 0.6 14 96.25 454.75 96.25
454.75 94.3789 444.477 135.25 455.746 135.25 455.742 139.699 455.918 142.246
454.75 144.977 454.156 158.18 451.078 160.246 452.75 160.246 452.75 152.457
437.438 139.246 438.746 139.246 438.742 125.18 437.438 125.25 431.746 125.25
431.742 130.02 424.238 135.25 421.75 135.25 421.75 138.379 418.957 138.246
415.75 137.5 411.918 134.418 410.156 132.246 409.746 130.02 408.398 126.5
411.918 124.25 411.746 122.977 411.918 113.738 418.957 109.246 423.746 104.059
429.516 94.8164 442.719 95.25 445.746 95.6992 448.879 96.25 454.75 96.25
454.75 10 0 0.7 0.4 0.4 0.7 0.4 0.4 13
100.246 435.75 102.957 431.496 106.477 426.879 109.246 423.746 113.738 418.957
122.977 411.918 124.25 411.746 126.5 411.918 130.02 408.398 132.246 409.746
134.418 410.156 137.5 411.918 138.246 415.75 138.379 418.957 135.25 421.75
135.25 421.75 131.926 423.285 128.91 427.125 127.246 429.746 127.246 429.742
127.379 426.879 121.246 427.746 115.938 428.637 110.219 431.719 108.25 434.746
106.699 438.758 104.059 441.398 106.25 437.75 107.578 433.477 110.219 429.516
112.25 428.75 113.738 428.637 113.297 427.316 110.246 427.746 108.02 428.195
104.938 428.637 100.246 434.746 10 0 0.6 0.15 0 0.6
0.15 0 20 97.25 458.746 97.25 458.746 99.2187 473.957 100.246
478.746 100.246 478.746 99.6563 485.84 102.25 490.75 104.938 495.078 107.137
501.898 110.246 507.75 113.738 513.777 113.957 518.18 118.25 519.746 122.758
521.699 129.359 531.156 132.246 532.746 135.52 533.359 135.25 532.746 135.25
532.746 135.25 532.742 142.777 548.758 157.25 544.746 157.25 544.746 139.918
547.438 157.25 557.746 157.25 557.746 152.02 556.566 155.246 564.75 158.07
569.402 157.52 561.957 145.25 548.746 145.25 548.746 139.918 539.52 134.25
535.746 128.477 532.918 115.277 525.219 114.25 520.75 112.637 516.859 109.117
510.477 107.25 508.746 104.719 506.957 101.637 502.34 101.25 498.75 101.25
498.75 99.8789 494.199 98.2461 492.75 96.7969 491.559 96.5781 488.039 96.25
485.75 96.5781 483.637 94.3789 480.559 94.2461 477.746 94.2461 477.742 95.4766
457.016 95.25 454.75 97.25 458.746 10 0 1 1 1
1 1 1 6 88.2461 453.746 88.2461 453.742 85.5781 455.477
80.25 448.75 80.25 448.75 88.7695 412.578 89.2461 410.75 89.2461 410.75
89.9766 413.348 88.2461 421.75 87.1172 429.188 86.25 442.746 86.25 442.746
88.2461 453.746 10 0 0.6 0.15 0 0.6 0.15 0
13 111.246 520.75 111.246 520.75 92.1797 517.078 92.2461 484.746 91.25
457.75 91.25 457.75 90.418 485.84 89.2461 487.75 87.7773 489.359 92.1797
501.68 88.2461 494.75 88.2461 494.75 73.2578 479.68 82.2461 456.746 82.2422
456.746 83.707 452.727 80.25 457.75 80.25 457.75 75.3477 471.648 76.2461
478.746 76.2422 478.746 76.7773 481.109 79.25 483.75 79.25 483.75 88.3281
497.059 91.25 499.746 91.25 499.742 93.2773 515.43 110.246 520.75 110.246
520.75 116.488 523.68 111.246 520.75 10 0 0 0 0
0 0 0 28 265.246 593.75 265.605 593.809 265.594 594.875
266.246 594.746 267.496 595.441 267.676 596.617 268.246 597.75 269.207 598.93
269.418 600.617 270.25 602.75 270.359 603.027 270.387 604.078 270.25 604.75
268.754 607.531 267.98 610.227 266.246 612.746 266.098 613.391 265.812 614.262
265.246 614.746 265.082 616.441 263.699 617.535 263.25 618.746 262.434 619.469
263.012 620.488 262.25 620.746 261.238 620.695 259.645 621.332 259.25 619.75
258.742 617.359 259.852 614.586 261.25 611.75 260.059 611.137 260.426 610.125
260.25 609.746 261.375 605.313 260.055 601.625 259.25 597.75 259.191 597.691
259.57 597.473 259.25 597.75 258.195 594.449 256.598 591.762 254.246 588.75
253.762 588.051 252.805 587.043 252.25 585.746 251.852 585.008 251.402 583.945
251.25 582.75 247.898 579.801 245.426 575.57 242.246 571.75 242.043 570.594
242.363 569.262 243.246 568.746 243.863 568.527 244.918 569.656 245.246 570.746
245.859 571.352 246.25 572.066 247.246 572.746 246.937 572.969 246.738 573.43
247.246 573.75 249.785 576.145 251.621 579.375 254.246 581.746 256.465 582.34
258.152 583.438 260.25 584.75 260.414 584.75 260.992 584.477 261.25 584.75
263.238 585.984 263.238 588.223 263.25 590.746 263.41 591.297 263.625 592.746
265.246 593.75 10 0 0 0 0 0 0 0
19 255.246 598.746 255.289 598.414 255.117 598.879 255.246 598.746 255.418
599.477 255.859 599.68 256.246 599.75 256.16 600.277 255.98 600.695 256.246
600.75 258.695 603.543 258.977 606.867 258.246 609.746 258.965 610.82 259.031
612.207 258.246 612.746 257.625 615.012 257.414 617.129 256.246 618.746 255.457
620.223 253.723 621.59 252.25 619.75 251.75 619.719 251.398 618.852 251.25
617.75 251.773 617.887 252.09 617.727 252.25 617.75 251.941 617.281 251.34
617.035 251.25 616.746 251.301 615.09 250.25 613.43 251.25 611.75 251.793
610.176 252.695 608.133 253.246 605.746 252.082 603.852 253.219 601.156 251.25
598.746 251.141 598.93 251.148 598.508 251.25 598.746 251.605 597.75 252.051
597.305 252.25 596.746 252.809 596.848 253.191 596.848 253.246 596.746 254.047
597.383 254.484 597.918 255.246 598.746 10 0 0 0 0
0 0 0 21 324.246 609.746 325.773 607.703 326.094 604.629
324.246 602.75 324.445 599.457 328.129 601.637 330.25 601.746 330.32 602.645
330.57 603.023 331.246 602.75 332.043 603.047 332.789 604.18 334.246 603.746
334.438 605.691 336.238 606.465 337.25 607.746 338.844 612.047 338.195 616.746
335.246 620.746 335.129 620.598 335.371 621.164 335.246 621.75 334.402 623.996
332.125 624.34 330.25 624.75 328.703 629.359 327.977 633.793 326.25 637.75
324.266 638.133 323.496 640.047 322.246 640.746 320.559 641.629 319.934 639.891
320.246 638.746 319.988 638.516 320.484 638.27 320.246 637.75 320.215 637.688
319.926 637.566 320.246 637.75 319.93 637.27 320.172 637.125 320.246 636.746
319.309 636.074 317.742 635.551 317.25 634.746 316.371 630.211 319.199 626.773
321.246 623.746 321.684 622.004 320.875 620.605 320.246 619.75 319.559 618.512
319.676 617.273 320.246 616.746 320.809 613.766 322.559 611.855 324.246 609.746
10 0 0 0 0 0 0 0 73 283.25
589.75 281.734 587.41 277.98 584.586 281.25 582.75 281.402 582.324 281.809
582.32 282.25 582.75 284.223 584.188 286.426 585.18 289.246 585.746 289.242
585.852 289.543 585.34 290.246 585.746 291.727 586.289 293.938 586.227 295.25
587.746 299.383 587.453 303.305 588.68 307.25 589.75 308.309 590.609 309.707
591.227 311.246 591.75 312.543 592.41 313.867 593.434 315.25 594.746 315.234
594.836 315.625 594.738 316.25 594.746 315.875 595.688 316.934 595.828 317.25
596.746 317.305 596.766 317.141 597.203 317.25 597.75 319.641 599.105 320.652
601.328 319.25 603.746 319.051 604.578 318.777 605.258 318.25 605.746 316.961
606.781 315.75 605.844 314.25 605.746 314.422 605.488 313.621 605.676 313.246
605.746 312.25 604.977 310.785 605.621 310.246 604.75 308.344 604.371 306.977
604.188 305.25 603.746 305.07 603.684 304.215 603.789 304.25 602.75 303.891
603.246 303.727 603.504 303.25 603.746 301.512 603.043 300.125 602.809 298.246
600.75 298.582 600.801 298.098 600.996 298.246 600.75 296.867 599.961 296.422
598.602 295.25 597.75 294.992 597.727 294.602 597.914 294.25 597.75 293.68
597.297 293.277 596.59 292.25 595.75 292.207 595.848 291.766 596.207 292.25
596.746 292.07 598.629 292.789 600.594 292.25 602.75 294.441 605.43 297.211
607.574 299.246 610.75 299.215 612.961 299.977 615.32 300.246 617.75 299.84
617.816 299.523 618.625 299.246 618.746 299.043 619.945 300.039 621.117 299.246
621.75 297.566 623.238 296.145 622.273 295.25 620.746 293.215 620.27 290.945
619.508 289.246 620.746 288.102 621.73 287.465 622.727 286.246 623.746 285.504
625.32 285.871 626.898 286.246 628.75 285.953 628.762 285.609 628.91 285.25
628.75 285.609 629.207 285.852 629.352 286.246 629.746 285.223 630.188 284.918
631.352 284.25 631.746 284.133 632.898 283.391 633.871 282.25 633.75 280.238
634.965 278.395 632.859 276.246 632.75 275.746 632.758 275.23 633.902 274.25
634.746 274.043 634.496 273.27 634.531 273.25 633.75 272.113 633.688 271.465
633.559 270.25 633.75 268.852 632.855 267.449 631.652 266.246 630.75 264.188
629.77 263.137 628.188 262.25 626.75 260.914 625.469 260.762 622.813 262.25
622.75 264.352 621.547 265.785 624.523 268.246 623.746 268.293 624.105 268.52
623.766 268.246 623.746 268.824 623.219 269.066 623.469 269.246 623.746 270.223
622.656 271.504 622.285 272.25 621.75 273.602 620.332 275.523 620.793 276.246
619.75 278.32 618.043 277.707 615.094 280.246 613.75 279.195 612.215 278.527
610.809 278.246 608.75 277.848 607.914 278.941 606.598 280.246 606.75 281.656
606.801 281.945 607.633 282.25 608.75 282.773 608.523 283.289 608.199 283.25
607.746 282.738 605.336 281.609 603.141 281.25 600.75 281.043 600.121 280.707
599.898 280.246 599.75 279.762 595.453 275.305 592.82 272.25 589.75 272.063
588.785 272.059 587.414 272.25 586.75 274.051 585.445 276.207 587.145 278.246
587.746 278.313 589.023 279.258 590.063 280.246 589.75 281.004 589.988 281.262
590.586 281.25 590.746 282 590.879 282.555 590.633 283.25 590.746 284.77
592.164 286.32 593.383 288.246 594.746 288.441 594.832 288.82 594.66 289.246
594.746 289.414 594.957 289.621 595.383 290.246 595.75 290.359 595.805 290.625
595.484 291.246 594.746 290.129 594.793 290.125 593.742 289.246 593.75 288.629
593.223 288.012 592.66 287.246 591.75 286.949 591.957 286.227 592.23 286.246
591.75 285.453 590.902 284.152 590.418 283.25 589.75 10 0 0
0 0 0 0 0 30 222.246 643.75 222.246 643.75
212.258 646.957 200.246 618.746 200.246 618.742 197.34 613 194.25 610.75
192.059 608.598 179.738 604.637 177.246 599.75 166.246 582.75 166.246 582.75
182.379 600.238 186.25 602.75 186.25 602.75 194.699 612.117 191.246 604.75
191.242 604.75 175.777 592.758 177.246 582.75 177.246 582.75 170.938 566.797
170.246 564.75 170.242 564.75 187.656 599.797 190.246 600.75 192.938 602.438
194.258 602.438 193.25 598.746 191.617 594.52 191.18 576.477 188.246 574.746
188.246 574.742 196.898 596.719 196.25 599.75 196.25 599.75 199.539 604.199
202.246 598.746 201.246 580.75 205.25 567.75 205.25 567.75 203.059 580
205.25 596.746 205.25 596.742 202.617 608.598 207.25 602.75 211.418 596.277
221.977 589.68 222.246 584.75 222.246 584.75 216.258 603.758 206.25 608.75
201.246 602.75 200.246 604.75 200.246 604.75 196.457 605.52 201.246 612.746
206.137 620.477 205.25 621.75 205.25 621.75 205.25 621.75 212.738 613.438
214.25 613.75 214.25 613.75 229.02 621.797 230.25 594.746 230.25 594.742
237.816 610.797 227.25 618.746 227.25 618.742 211.418 620.477 212.246 625.746
220.246 639.75 224.617 645.559 223.246 642.746 223.246 642.746 10 0
0 0 0 0 0 0 6 200.246 625.746 200.246
625.746 186.34 625.758 183.25 619.75 175.25 609.746 175.25 609.742 193.816
620.477 198.246 621.75 202.617 623.117 200.246 625.746 200.246 625.746 10
0 0 0 0 0 0 0 7 156.25 618.746
156.25 618.742 154.219 617.398 154.246 614.746 153.34 611.238 150.699 610.797
151.25 607.746 152.457 604.637 154.656 602 154.246 606.75 154.656 610.797
156.418 613 157.25 614.746 158.18 615.637 159.938 620.477 156.25 618.746
10 0 0 0 0 0 0 0 10 146.25
551.75 146.25 551.75 137.5 555.797 134.25 559.746 130.457 563.719 130.957
558.035 125.25 558.75 119.187 558.922 120.246 576.746 120.246 576.746 116.246
567.75 116.246 567.75 114.617 552.277 123.25 554.746 127.715 556.207 129.137
554.477 127.246 553.75 125.617 552.719 133.539 552.277 130.25 550.746 127.379
548.758 143.219 554.477 140.25 542.75 146.25 551.75 10 0 0
0 0 0 0 0 8 133.246 535.746 133.246 535.746
115.938 530.719 112.25 541.746 112.25 541.742 106.699 538.637 109.246 535.746
111.539 532.039 113.25 531.75 113.25 531.75 113.25 531.75 118.797 530.277
118.25 529.75 117.477 528.52 115.246 524.746 115.246 524.746 115.242 524.746
126.059 531.379 133.246 535.746 10 0 1 1 1 1
1 1 24 384.25 449.746 383.648 447.191 381.813 446.309 379.246
445.746 377.609 446.629 374.754 450.047 372.25 447.746 372.156 448.305 371.301
448.371 371.25 448.75 370.41 450.086 370.711 451.238 370.25 451.746 369.734
453.516 368.953 455.016 369.25 456.746 371.145 457.359 371.801 459.457 371.25
461.75 371.203 461.68 370.73 461.895 371.25 462.746 371.156 462.633 371.504
462.883 372.25 462.746 371.652 463.031 371.492 462.773 371.25 462.746 370.699
462.91 370.836 463.613 371.25 463.75 371.621 465.957 373.836 466.25 375.246
464.746 375.602 465.559 376.16 465.348 376.246 465.75 376.586 466.016 377.031
466.594 377.246 466.746 377.82 468.266 379.613 467.047 380.25 467.746 381.672
468.629 382.844 469.398 384.25 468.75 386.02 467.621 387.898 466.285 389.246
464.746 389.848 463.453 390.113 462.047 390.246 460.746 390.008 460.281 388.488
460.668 388.246 459.75 387.402 457.723 389.414 457.152 390.246 455.746 390.465
455.297 390.176 454.961 390.246 454.75 389.375 454.711 388.516 454.922 388.246
454.75 389.734 450.91 386.703 450.164 384.25 449.746 10 0 1
1 1 1 1 1 11 373.25 427.746 373.551 429.891
371.789 431.82 373.25 433.746 373.27 433.551 373.41 433.305 373.25 433.746
373.707 433.305 373.852 433.551 374.25 433.746 375.645 431.258 379.66 430.238
379.246 426.75 379.48 426.617 378.285 425.605 379.246 424.75 377.285 423.414
377.223 420.809 376.246 418.746 374.836 419.051 373.504 419.449 372.25 419.75
372.625 421.691 372.496 423.543 373.25 424.75 373.879 425.766 373.563 426.949
373.25 427.746 10 0 0.8 0.8 0.8 0.8 0.8 0.8
15 190.246 437.75 190.246 437.75 172.195 426.727 187.246 443.75 197.34
454.156 208.25 460.746 208.25 460.746 208.25 460.742 219.777 465.156 223.246
466.746 227.699 467.797 244.418 473.52 248.25 473.746 251.457 474.398 262.02
478.797 269.246 474.75 276.977 470 286.246 464.746 286.246 464.746 286.246
464.742 267.738 474.398 264.246 471.746 259.816 469.117 251.898 469.559 245.246
465.75 245.246 465.75 229.02 461.195 225.25 458.746 221.977 456.797 210.539
444.035 209.246 444.746 207.02 445.797 209.219 446.238 210.246 449.746 211.859
452.398 209.656 454.156 201.246 446.75 192.059 440.078 190.246 437.75 190.246
437.75 10 0 0 0 0 0 0 0 11
199.246 444.746 199.246 444.742 200.434 458.785 210.246 456.746 210.246 456.746
218.809 461.539 222.246 463.75 222.246 463.75 230.758 465.578 232.246 466.746
252.523 475.824 268.715 470.855 269.246 471.746 269.918 473.316 291.504 465.488
295.25 460.746 295.906 460.508 284.219 467.152 273.25 468.75 264.453 471.008
240.691 468.961 228.25 462.746 225.422 461.211 215.582 454.848 213.246 454.75
210.016 455.094 199.246 444.746 199.246 444.746 10 0 0.8 0.8
0.8 0.8 0.8 0.8 11 194.25 416.746 194.25 416.742 177.977
418.957 196.25 420.746 196.25 420.742 216.258 422.918 220.246 428.75 220.246
428.75 235.617 438.758 238.25 438.746 241.777 439.637 274.777 447.559 275.246
449.746 275.656 452.836 281.816 452.836 283.25 451.746 285.34 451.078 284.457
449.758 281.25 448.75 278.297 447.996 243.977 429.957 237.25 428.75 229.898
427.316 217.137 418.957 212.246 417.75 206.578 416.316 194.25 416.746 194.25
416.746 10 0 0 0 0 0 0 0 11
216.25 424.75 216.25 424.75 206.73 425.367 216.25 426.75 216.25 426.75
225.887 430.035 228.25 432.75 228.25 432.75 235.801 438.145 237.25 438.746
238.957 438.594 254.313 442.652 254.246 443.75 254.762 445.355 292.234 459.191
297.246 455.746 300.301 453.371 289.406 455.219 279.246 450.75 277.32 449.684
240.082 433.637 236.25 432.75 232.871 432.285 226.34 428.008 223.246 427.746
220.934 426.656 216.25 424.75 216.25 424.75 10 0 0 0
0 0 0 0 4 207.25 421.75 207.25 421.75 213.18
422.477 212.246 420.746 210.539 418.957 208.25 419.75 208.25 419.75 207.25
421.75 10 0 0 0 0 0 0 0 4
199.246 420.746 199.246 420.742 205.258 420.719 204.25 418.746 202.617 417.195
200.246 417.75 200.246 417.75 199.246 420.746 10 0 0 0
0 0 0 0 4 188.246 418.746 188.246 418.742 193.816
418.957 192.25 416.746 191.18 415.438 188.246 416.746 188.246 416.746 188.246
418.746 10 0 0 0 0 0 0 0 4
179.246 417.75 179.246 417.75 185.457 418.078 184.25 416.746 182.816 414.559
180.246 415.75 180.246 415.75 179.246 417.75 10 0 0 0
0 0 0 0 4 222.246 460.746 222.246 460.742 226.816
461.195 225.25 459.75 224.18 457.676 220.246 457.75 220.246 457.75 222.246
460.746 10 0 0 0 0 0 0 0 4
211.246 454.75 211.246 454.75 218.133 457.391 215.25 453.746 214.059 451.957
211.246 452.75 211.246 452.75 211.246 454.75 10 0 0 0
0 0 0 0 4 198.246 449.746 198.246 449.742 204.379
450.195 203.25 448.75 201.738 446.676 199.246 447.746 199.246 447.746 198.246
449.746 10 0 0 0 0 0 0 0 4
190.246 442.746 190.246 442.742 196.02 443.598 194.25 441.75 193.379 440.078
190.246 440.746 190.246 440.746 190.246 442.746 10 0 0 0
0 0 0 0 4 183.25 437.75 183.25 437.75 188.539
438.316 187.246 436.746 185.898 434.797 183.25 435.75 183.25 435.75 183.25
437.75 10 0 0 0 0 0 0 0 4
226.25 430.75 226.25 430.75 233.422 431.426 231.246 428.75 229.906 426.742
226.25 427.746 226.25 427.746 226.25 430.75 10 0 0 0
0 0 0 0 4 237.25 435.75 237.25 435.75 244.863
436.707 243.246 434.746 241.348 432.02 238.25 432.75 238.25 432.75 237.25
435.75 10 0 0 0 0 0 0 0 4
249.25 440.746 249.25 440.742 256.742 441.547 255.246 438.746 253.227 436.859
249.25 437.75 249.25 437.75 249.25 440.746 10 0 0 0
0 0 0 0 4 260.25 445.746 260.25 445.746 268.18
446.824 266.246 444.746 264.668 442.141 261.25 443.75 261.25 443.75 260.25
445.746 10 0 0 0 0 0 0 0 4
230.25 465.75 230.25 465.75 237.82 466.625 236.25 464.746 234.309 461.941
230.25 461.75 230.25 461.75 230.25 465.75 10 0 0 0
0 0 0 0 4 241.25 469.746 241.25 469.746 248.82
470.145 247.246 467.746 245.309 465.461 240.25 465.75 240.25 465.75 241.25
469.746 10 0 0 0 0 0 0 0 4
216.25 425.746 216.25 425.746 221.977 425.996 220.246 423.746 219.34 422.477
216.25 423.746 216.25 423.746 216.25 425.746 10 0 0.6 0.15
0 0.6 0.15 0 5 135.25 534.75 135.25 534.75 130.898
525 130.25 521.746 130.25 521.742 131.34 531.156 132.246 533.746 133.977
535.559 135.25 534.75 135.25 534.75 10 0 0.6 0.15 0
0.6 0.15 0 5 115.246 519.746 115.242 519.742 111.977 503.438
112.25 500.746 112.25 500.746 111.098 513.117 111.246 514.75 111.977 515.758
115.246 519.746 115.246 519.746 10 0 0.8 0.8 0.8 0.8
0.8 0.8 6 138.246 601.746 138.246 597.75 135.25 597.75 135.25
597.75 151.359 583.738 152.25 575.75 152.25 575.75 152.898 584.398 138.246
601.746 10 0 0 0 0 0 0 0 28
143.246 599.75 142.285 600.402 142.527 601.223 142.246 601.746 141.188 602.078
143.508 602.141 143.246 602.75 142.836 604.254 143.039 604.277 143.246 605.746
142.844 606.34 143.488 608.031 144.246 608.75 145.504 610.332 144.047 613.559
146.25 615.75 146.188 615.582 146.598 616.191 147.25 616.746 147.637 617.711
148.941 618.246 150.246 618.746 150.336 619.461 150.113 620.371 150.246 620.746
151.523 620.141 152.891 620.285 153.246 619.75 152.715 617.027 151.254 615.137
150.246 613.75 150.344 612.527 149.84 611.828 149.246 610.75 148.059 608.336
148.266 605.207 148.246 601.746 148.07 601.992 147.73 601.906 147.25 601.746
148.129 599.277 148.77 596.859 149.246 594.746 150.141 593.387 150.66 592.402
151.25 591.75 150.945 590.625 151.059 589.711 150.246 588.75 152.848 585.754
151.41 582.84 152.25 578.75 152.922 578.27 154.785 576.164 154.246 576.746
151.512 577.297 151.387 577.734 151.25 578.75 151.031 579.25 150.668 580.762
150.246 581.746 150.336 581.605 150.148 583.68 150.246 583.746 148.398 586.434
149.895 586.238 148.246 588.75 146.816 589.582 145.754 590.797 144.246 591.75
144.301 592.297 145.559 593.094 145.25 593.75 144.156 594.746 142.887 595.59
143.246 596.746 143.43 597.992 143.578 599.156 143.246 599.75 10 0
0 0 0 0 0 0 11 139.246 597.75 139.246
597.75 139.258 590.559 142.246 588.75 144.539 587.039 143.219 587.918 139.246
588.75 136.18 590.559 137.246 591.75 137.246 591.75 137.242 591.75 134.418
591 137.246 588.75 139.699 586.598 143.656 583.957 142.246 583.746 140.137
583.957 131.777 588.359 132.246 591.75 131.777 594.52 130.25 598.746 130.25
598.746 130.25 598.742 131.887 599.906 137.246 599.75 137.242 599.75 138.707
599.027 139.246 597.75 10 0 1 1 1 1 1
1 5 138.246 577.75 138.246 577.75 128.566 580.648 108.25 576.746
108.25 576.742 118.172 579.203 139.246 576.746 150.148 575.324 138.246 577.75
138.246 577.75 10 0.11 0 0 0 0 0 0
5 138.246 577.75 138.246 577.75 128.566 580.648 108.25 576.746 108.25
576.742 118.172 579.203 139.246 576.746 150.148 575.324 138.246 577.75 138.246
577.75 10 0 1 1 1 1 1 1 5
140.25 577.75 140.25 577.75 131.176 581.527 110.246 579.746 110.246 579.746
120.695 580.984 141.25 576.746 152.215 574.355 140.25 577.75 140.25 577.75
10 0.11 0 0 0 0 0 0 5 140.25
577.75 140.25 577.75 131.176 581.527 110.246 579.746 110.246 579.746 120.695
580.984 141.25 576.746 152.215 574.355 140.25 577.75 140.25 577.75 10
0 1 1 1 1 1 1 5 142.246 577.75
142.242 577.75 133.453 582.086 113.25 581.746 113.25 581.746 122.965 582.328
143.246 576.746 153.902 573.371 142.246 577.75 142.246 577.75 10 0.11
0 0 0 0 0 0 5 142.246 577.75 142.242
577.75 133.453 582.086 113.25 581.746 113.25 581.746 122.965 582.328 143.246
576.746 153.902 573.371 142.246 577.75 142.246 577.75 10 0 1
1 1 1 1 1 5 143.246 577.75 143.242 577.75
136.102 582.047 117.25 583.746 117.25 583.742 126.715 583.066 144.246 576.746
153.77 572.66 143.246 577.75 143.246 577.75 10 0.11 0 0
0 0 0 0 5 143.246 577.75 143.242 577.75 136.102
582.047 117.25 583.746 117.25 583.742 126.715 583.066 144.246 576.746 153.77
572.66 143.246 577.75 143.246 577.75 10 0 1 1 1
1 1 1 5 270.25 565.746 270.25 565.742 269.398 565.031
269.246 566.75 269.871 567.629 300.898 582.117 305.25 581.746 305.25 581.746
271.602 567.316 270.25 565.746 10 0.11 0 0 0 0
0 0 5 270.25 565.746 270.25 565.742 269.398 565.031 269.246
566.75 269.871 567.629 300.898 582.117 305.25 581.746 305.25 581.746 271.602
567.316 270.25 565.746 10 0 1 1 1 1 1
1 5 266.246 564.75 266.246 564.75 265.727 564.25 266.246 565.746
265.992 566.879 295.785 583.758 300.246 583.746 300.246 583.742 267.742 566.699
266.246 564.75 10 0.11 0 0 0 0 0 0
5 266.246 564.75 266.246 564.75 265.727 564.25 266.246 565.746 265.992
566.879 295.785 583.758 300.246 583.746 300.246 583.742 267.742 566.699 266.246
564.75 10 0 1 1 1 1 1 1 5
263.25 563.746 263.25 563.742 262.164 562.676 262.25 563.746 262.254 565.316
284.055 582.363 295.25 584.75 295.25 584.75 275.016 575.484 263.25 563.746
10 0.11 0 0 0 0 0 0 5 263.25
563.746 263.25 563.742 262.164 562.676 262.25 563.746 262.254 565.316 284.055
582.363 295.25 584.75 295.25 584.75 275.016 575.484 263.25 563.746 10
0 1 1 1 1 1 1 5 260.25 561.746
260.25 561.742 259.09 560.711 259.25 561.746 259.176 563.086 278.793 578.43
288.246 580.75 288.246 580.75 270.656 572.238 260.25 561.746 10 0.11
0 0 0 0 0 0 5 260.25 561.746 260.25
561.742 259.09 560.711 259.25 561.746 259.176 563.086 278.793 578.43 288.246
580.75 288.246 580.75 270.656 572.238 260.25 561.746 10 0 0.8
0.8 0.8 0.8 0.8 0.8 11 225.25 398.746 225.25 398.742
208.34 401.355 227.25 402.75 227.25 402.75 246.617 405.316 251.25 410.75
251.25 410.75 265.977 421.156 269.246 421.75 272.137 422.035 290.18 425.996
290.246 428.75 291.059 431.277 297.656 433.918 299.246 432.75 301.18 432.156
301.18 422.035 298.246 420.746 295.02 420.277 274.34 412.355 267.246 410.75
260.258 409.719 247.5 401.355 242.246 399.75 236.938 398.719 225.25 398.746
225.25 398.746 10 0 0 0 0 0 0 0
11 305.25 439.75 305.25 439.75 302.059 438.098 300.246 434.746 300.246
434.746 293.699 423.578 278.246 419.75 278.246 419.75 252.777 410.156 244.246
407.746 244.246 407.742 229.457 402.457 221.246 403.746 221.246 403.746 213.617
403.117 220.246 401.746 220.246 401.746 242.656 403.559 246.246 405.746 246.242
405.742 263.559 411.258 267.246 413.75 270.156 416.977 290.18 422.477 292.25
424.75 295.02 426.879 305.797 436.117 305.25 439.75 10 0 0
0 0 0 0 0 4 241.25 404.75 241.25 404.75
246.52 405.445 245.246 403.746 243.984 402.035 241.25 402.75 241.25 402.75
241.25 404.75 10 0 0 0 0 0 0 0
4 233.246 403.746 233.246 403.746 238.598 403.957 237.25 402.75 236.063
400.547 233.246 401.746 233.246 401.746 233.246 403.746 10 0 0
0 0 0 0 0 4 221.246 402.75 221.246 402.75
227.125 402.586 226.25 400.75 224.59 399.176 222.246 399.75 222.246 399.75
221.246 402.75 10 0 0 0 0 0 0 0
4 213.246 401.746 213.242 401.746 218.73 401.984 217.25 400.75 216.191
398.578 213.246 399.75 213.246 399.75 213.246 401.746 10 0 0
0 0 0 0 0 4 259.25 413.75 259.25 413.75
266.609 413.664 265.246 411.746 263.234 409.129 259.25 410.75 259.25 410.75
259.25 413.75 10 0 0 0 0 0 0 0
4 270.25 417.75 270.25 417.75 276.855 421.832 276.246 416.746 275.973
413.453 271.25 415.75 271.25 415.75 270.25 417.75 10 0 0
0 0 0 0 0 4 280.246 421.75 280.242 421.75
288.223 425.367 286.246 419.75 285.457 416.664 281.25 418.746 281.25 418.746
280.246 421.75 10 0 0 0 0 0 0 0
4 291.246 426.75 291.242 426.75 295.605 431.996 297.246 424.75 297.227
421.875 291.246 423.746 291.246 423.746 291.246 426.75 10 0 0
0 0 0 0 0 4 249.25 408.75 249.25 408.75
255.266 408.652 254.246 406.75 252.73 405.242 250.25 405.746 250.25 405.746
249.25 408.75 10 0 1 1 1 1 1 1
5 288.246 541.746 288.246 541.742 287.875 541.203 288.246 542.75 287.875
543.559 307.109 558.148 317.25 559.746 317.25 559.746 299.125 552.27 288.246
541.746 10 0.11 0 0 0 0 0 0 5
288.246 541.746 288.246 541.742 287.875 541.203 288.246 542.75 287.875 543.559
307.109 558.148 317.25 559.746 317.25 559.746 299.125 552.27 288.246 541.746
10 0 0 0 0 0 0 0 10 292.25
471.746 292.25 471.742 316.141 447.117 326.25 442.746 326.25 442.742 336.379
430.836 332.246 401.746 332.246 401.746 328.461 393.879 325.25 416.746 325.25
416.742 328.461 444.477 316.25 426.75 316.25 426.75 306.898 437.766 314.25
437.75 314.25 437.75 317.461 435.238 318.25 436.746 318.34 438.758 309.539
453.719 290.246 469.746 271.699 485.398 292.25 471.746 292.25 471.746 10
0 1 1 1 1 1 1 5 227.25 428.75
227.25 428.75 227.477 431.059 229.25 429.746 231.438 429.297 335.059 422.477
370.25 395.75 370.25 395.75 320.098 421.598 227.25 428.75 10 0.11
0 0 0 0 0 0 5 227.25 428.75 227.25
428.75 227.477 431.059 229.25 429.746 231.438 429.297 335.059 422.477 370.25
395.75 370.25 395.75 320.098 421.598 227.25 428.75 10 0 1
1 1 1 1 1 5 239.25 433.746 239.25 433.742
238.918 435.898 241.25 434.746 242.879 434.137 393.141 435.238 419.246 399.75
419.246 399.75 394.898 427.316 239.25 433.746 10 0.11 0 0
0 0 0 0 5 239.25 433.746 239.25 433.742 238.918
435.898 241.25 434.746 242.879 434.137 393.141 435.238 419.246 399.75 419.246
399.75 394.898 427.316 239.25 433.746 10 0 1 1 1
1 1 1 5 252.25 438.746 252.25 438.742 251.68 440.297
253.246 439.75 255.637 438.535 446.379 452.836 472.25 416.746 472.25 416.742
461.777 445.355 252.25 438.746 10 0.11 0 0 0 0
0 0 5 252.25 438.746 252.25 438.742 251.68 440.297 253.246
439.75 255.637 438.535 446.379 452.836 472.25 416.746 472.25 416.742 461.777
445.355 252.25 438.746 10 0 1 1 1 1 1
1 5 263.25 443.75 263.25 443.75 262.68 445.578 264.246 444.746
266.637 443.816 401.059 486.277 427.25 450.75 427.25 450.75 412.277 477.699
263.25 443.75 10 0.11 0 0 0 0 0 0
5 263.25 443.75 263.25 443.75 262.68 445.578 264.246 444.746 266.637
443.816 401.059 486.277 427.25 450.75 427.25 450.75 412.277 477.699 263.25
443.75 10 0 1 1 1 1 1 1 5
199.246 418.746 199.246 418.742 198.879 420.496 201.246 419.75 202.84 418.738
222.418 416.316 224.246 373.75 224.242 373.75 216.699 419.836 199.246 418.746
10 0.11 0 0 0 0 0 0 5 199.246
418.746 199.246 418.742 198.879 420.496 201.246 419.75 202.84 418.738 222.418
416.316 224.246 373.75 224.242 373.75 216.699 419.836 199.246 418.746 10
0 1 1 1 1 1 1 5 189.246 416.746
189.246 416.742 189.199 418.738 191.246 417.75 193.156 416.977 208.777 422.035
205.25 379.746 205.25 379.746 207.02 418.078 189.246 416.746 10 0.11
0 0 0 0 0 0 5 189.246 416.746 189.246
416.742 189.199 418.738 191.246 417.75 193.156 416.977 208.777 422.035 205.25
379.746 205.25 379.746 207.02 418.078 189.246 416.746 10 0 1
1 1 1 1 1 5 180.246 416.746 180.242 416.742
180.398 418.297 182.25 417.75 184.359 416.535 201.297 415.879 187.246 390.746
187.246 390.746 198.219 417.637 180.246 416.746 10 0.11 0 0
0 0 0 0 5 180.246 416.746 180.242 416.742 180.398
418.297 182.25 417.75 184.359 416.535 201.297 415.879 187.246 390.746 187.246
390.746 198.219 417.637 180.246 416.746 10 0 1 1 1
1 1 1 5 232.246 464.746 232.246 464.742 232.187 462.887
234.246 463.75 251.566 478.113 287.254 542.906 348.25 548.746 348.25 548.746
306.367 562.426 232.246 464.746 10 0.11 0 0 0 0
0 0 5 232.246 464.746 232.246 464.742 232.187 462.887 234.246
463.75 251.566 478.113 287.254 542.906 348.25 548.746 348.25 548.746 306.367
562.426 232.246 464.746 10 0 1 1 1 1 1
1 5 245.246 466.746 245.246 466.742 243.496 468.379 245.246 468.75
247.605 469.754 371.293 549.508 414.25 540.75 414.25 540.75 384.688 549.004
245.246 466.746 10 0.11 0 0 0 0 0 0
5 245.246 466.746 245.246 466.742 243.496 468.379 245.246 468.75 247.605
469.754 371.293 549.508 414.25 540.75 414.25 540.75 384.688 549.004 245.246
466.746 10 0 1 1 1 1 1 1 5
222.246 460.746 222.246 460.742 221.512 458.594 223.246 459.75 233.266 465.301
237.242 528.234 285.25 529.75 285.25 529.75 249.523 545.801 222.246 460.746
10 0.11 0 0 0 0 0 0 5 222.246
460.746 222.246 460.742 221.512 458.594 223.246 459.75 233.266 465.301 237.242
528.234 285.25 529.75 285.25 529.75 249.523 545.801 222.246 460.746 10
0 1 1 1 1 1 1 5 200.246 447.746
200.246 447.746 198.973 446.812 201.246 446.75 212.391 448.555 235.937 493.953
285.25 488.746 285.25 488.742 249.656 504.148 200.246 447.746 10 0.11
0 0 0 0 0 0 5 200.246 447.746 200.246
447.746 198.973 446.812 201.246 446.75 212.391 448.555 235.937 493.953 285.25
488.746 285.25 488.742 249.656 504.148 200.246 447.746 10 0 1
1 1 1 1 1 5 212.246 454.75 212.246 454.75
211.625 453.348 213.246 453.746 224.461 457.637 238.852 506.711 288.246 510.746
288.246 510.742 250.363 519.348 212.246 454.75 10 0.11 0 0
0 0 0 0 5 212.246 454.75 212.246 454.75 211.625
453.348 213.246 453.746 224.461 457.637 238.852 506.711 288.246 510.746 288.246
510.742 250.363 519.348 212.246 454.75 10 0 1 1 1
1 1 1 5 192.25 442.746 192.25 442.742 191.453 441.449
193.25 441.75 202.32 442.863 221.395 479.633 261.25 474.75 261.25 474.75
232.508 487.891 192.25 442.746 10 0.11 0 0 0 0
0 0 5 192.25 442.746 192.25 442.742 191.453 441.449 193.25
441.75 202.32 442.863 221.395 479.633 261.25 474.75 261.25 474.75 232.508
487.891 192.25 442.746 10 0 1 1 1 1 1
1 5 184.25 435.75 184.25 435.75 182.949 434.945 184.25 434.746
189.281 435.414 222.984 471.801 243.246 454.75 243.246 454.75 230.082 475.344
184.25 435.75 10 0.11 0 0 0 0 0 0
5 184.25 435.75 184.25 435.75 182.949 434.945 184.25 434.746 189.281
435.414 222.984 471.801 243.246 454.75 243.246 454.75 230.082 475.344 184.25
435.75 10 0 1 1 1 1 1 1 5
260.25 470.75 260.25 470.75 259.219 472.699 261.25 472.75 263.469 473.547
396.242 537.031 438.25 522.746 438.25 522.746 409.465 534.84 260.25 470.75
10 0.11 0 0 0 0 0 0 5 260.25
470.75 260.25 470.75 259.219 472.699 261.25 472.75 263.469 473.547 396.242
537.031 438.25 522.746 438.25 522.746 409.465 534.84 260.25 470.75 10
0 1 1 1 1 1 1 5 223.246 400.75
223.246 400.75 223.52 402.457 225.25 401.746 227.477 400.695 244.418 400.035
231.246 375.75 231.246 375.75 241.34 401.797 223.246 400.75 10 0.11
0 0 0 0 0 0 5 223.246 400.75 223.246
400.75 223.52 402.457 225.25 401.746 227.477 400.695 244.418 400.035 231.246
375.75 231.246 375.75 241.34 401.797 223.246 400.75 10 0 1
1 1 1 1 1 5 235.246 401.746 235.242 401.746
234.957 404.219 237.25 403.746 238.918 402.457 258.5 400.035 260.25 357.746
260.25 357.746 252.777 403.559 235.246 401.746 10 0.11 0 0
0 0 0 0 5 235.246 401.746 235.242 401.746 234.957
404.219 237.25 403.746 238.918 402.457 258.5 400.035 260.25 357.746 260.25
357.746 252.777 403.559 235.246 401.746 10 0 1 1 1
1 1 1 5 242.246 403.746 242.246 403.746 242.437 405.977
244.246 404.75 246.398 404.219 273.457 400.477 299.246 364.75 299.246 364.75
260.258 405.316 242.246 403.746 10 0.11 0 0 0 0
0 0 5 242.246 403.746 242.246 403.746 242.437 405.977 244.246
404.75 246.398 404.219 273.457 400.477 299.246 364.75 299.246 364.75 260.258
405.316 242.246 403.746 10 0 1 1 1 1 1
1 5 251.25 405.746 251.25 405.742 250.566 408.164 252.25 407.746
254.723 406.945 277.199 409.031 319.25 371.75 319.25 371.75 268.316 409.875
251.25 405.746 10 0.11 0 0 0 0 0 0
5 251.25 405.746 251.25 405.742 250.566 408.164 252.25 407.746 254.723
406.945 277.199 409.031 319.25 371.75 319.25 371.75 268.316 409.875 251.25
405.746 10 0 1 1 1 1 1 1 5
262.25 410.75 262.25 410.75 262.004 413.004 264.246 412.746 266.164 411.785
304.48 406.832 361.25 368.746 361.25 368.746 279.754 414.715 262.25 410.75
10 0.11 0 0 0 0 0 0 5 262.25
410.75 262.25 410.75 262.004 413.004 264.246 412.746 266.164 411.785 304.48
406.832 361.25 368.746 361.25 368.746 279.754 414.715 262.25 410.75 10
0 1 1 1 1 1 1 5 218.25 423.746
218.25 423.746 217.797 425.777 220.246 424.75 221.758 424.016 280.5 421.156
314.25 391.75 314.25 391.75 275.547 418.93 218.25 423.746 10 0.11
0 0 0 0 0 0 5 218.25 423.746 218.25
423.746 217.797 425.777 220.246 424.75 221.758 424.016 280.5 421.156 314.25
391.75 314.25 391.75 275.547 418.93 218.25 423.746 10 0 1
1 1 1 1 1 5 207.25 419.75 207.25 419.75
206.797 421.379 209.246 420.746 210.758 419.617 237.816 415.879 264.246 379.746
264.246 379.746 224.617 420.719 207.25 419.75 10 0.11 0 0
0 0 0 0 5 207.25 419.75 207.25 419.75 206.797
421.379 209.246 420.746 210.758 419.617 237.816 415.879 264.246 379.746 264.246
379.746 224.617 420.719 207.25 419.75 10 0 1 1 1
1 1 1 5 274.25 415.75 274.25 415.75 273.828 418.031
276.246 417.75 278.066 417.125 316.645 414.992 376.246 380.75 376.246 380.75
290.746 418.625 274.25 415.75 10 0.11 0 0 0 0
0 0 5 274.25 415.75 274.25 415.75 273.828 418.031 276.246
417.75 278.066 417.125 316.645 414.992 376.246 380.75 376.246 380.75 290.746
418.625 274.25 415.75 10 0 1 1 1 1 1
1 5 283.25 418.746 283.25 418.742 283.07 420.672 285.25 419.75
287.309 419.762 325.883 417.633 385.25 383.746 385.25 383.742 300.648 421.703
283.25 418.746 10 0.11 0 0 0 0 0 0
5 283.25 418.746 283.25 418.742 283.07 420.672 285.25 419.75 287.309
419.762 325.883 417.633 385.25 383.746 385.25 383.742 300.648 421.703 283.25
418.746 10 0 1 1 1 1 1 1 5
294.25 424.75 294.25 424.75 293.629 426.172 296.25 425.746 297.867 425.262
345.242 420.492 444.246 382.75 444.246 382.75 311.207 427.203 294.25 424.75
10 0.11 0 0 0 0 0 0 5 294.25
424.75 294.25 424.75 293.629 426.172 296.25 425.746 297.867 425.262 345.242
420.492 444.246 382.75 444.246 382.75 311.207 427.203 294.25 424.75 10
0 0 0 0 0 0 0 4 172.25 416.746
172.25 416.742 177.539 417.195 176.246 415.75 174.898 413.676 172.25 414.746
172.25 414.746 172.25 416.746 10 0 0 0 0 0
0 0 4 205.25 401.746 205.25 401.746 211.418 401.797 210.246
399.75 208.777 398.277 206.25 398.746 206.25 398.746 205.25 401.746 10
0 0 0 0 0 0 0 4 196.25 401.746
196.25 401.746 201.738 402.238 200.246 400.75 199.098 398.719 196.25 399.75
196.25 399.75 196.25 401.746 10 0 0 0 0 0
0 0 4 91.25 414.746 91.25 414.746 96.6602 413.344 95.25
411.746 93.0156 410.879 91.25 412.746 91.25 412.746 91.25 414.746 10
0 0 0 0 0 0 0 4 93.2461 425.746
93.2422 425.746 98.8633 423.902 97.25 422.746 95.2148 421.441 93.2461 422.746
93.2461 422.746 93.2461 425.746 10 0 0 0 0 0
0 0 4 85.25 429.746 85.25 429.742 90.9414 428.742 89.2461
427.746 87.2969 426.281 85.25 427.746 85.25 427.746 85.25 429.746 10
0 0.8 0.8 0.8 0.8 0.8 0.8 5 173.25 347.75
173.25 347.75 171.379 347.676 167.25 345.75 164.777 345.477 152.457 341.516
146.25 330.746 146.25 330.742 159.938 341.078 173.25 347.75 10 0
0.8 0.8 0.8 0.8 0.8 0.8 9 269.246 245.746 269.781
245.484 269.84 245.02 270.25 244.75 270.887 244.957 272.242 244.625 272.25
245.746 271.172 250.063 270.211 255.492 265.246 257.746 264.961 257.789 263.375
257.332 263.25 256.746 263.156 254.684 263.027 253.203 263.25 251.75 263.695
250.027 266.07 250.016 267.246 251.75 268.109 249.699 268.582 247.672 269.246
245.746 10 0 0.8 0.8 0.8 0.8 0.8 0.8 9
257.246 240.75 258.262 239.004 258.121 236.961 259.25 236.746 260.492 236.016
262.527 237.09 262.25 238.746 261.188 240.539 260.758 243 259.25 244.75
259.012 245.281 259.277 245.867 259.25 245.746 258.445 247.57 257.188 248.379
255.246 247.746 254.41 245.594 255.676 243.25 257.246 241.75 257.5 241.203
257.316 240.793 257.246 240.75 10 0 0.8 0.8 0.8 0.8
0.8 0.8 11 214.25 246.746 213.758 246.684 213.719 247.191 214.25
247.746 214.484 248.68 215.355 249.914 215.25 250.746 214.602 252.203 213.375
252 212.246 251.75 211.41 250.281 211.355 248.273 210.246 246.746 210.379
246.355 210.438 245.723 210.246 245.746 209.43 244.832 208.945 243.152 209.246
242.75 209.109 242.18 208.91 231.281 209.246 231.75 209.836 232.379 213.188
243.086 213.246 243.75 213.328 244.871 214.133 245.383 214.25 246.746 10
0 0.8 0.8 0.8 0.8 0.8 0.8 7 185.25 253.75
188.574 256.488 191.641 259.746 191.246 263.75 191.027 264.902 189.074 264.32
189.246 263.75 187.988 259.402 185.746 256.477 183.25 253.75 180.504 251.594
178.457 244.617 178.246 243.75 182.266 249.84 184.746 252.859 185.25 253.75
10 0 0.8 0.8 0.8 0.8 0.8 0.8 10 170.246
260.746 171.32 260.707 170.988 261.246 171.246 261.746 172.273 263.215 173.707
264.586 173.25 266.746 173.73 266.805 173.313 267.145 173.25 266.746 172.641
266.695 172.262 266.551 172.25 266.746 169.91 263.715 168.371 260.777 167.25
257.746 166.582 257.289 165.324 252.352 165.246 251.75 165.934 252.133 167.824
256.734 168.25 256.746 169.445 257.613 169.457 259.391 170.246 260.746 10
0 0.8 0.8 0.8 0.8 0.8 0.8 6 189.246 238.746
189.641 239.758 191.371 241.078 191.246 241.75 191.117 243.078 191.633 244.664
190.246 243.75 189.246 242.867 185.453 241.383 185.25 234.746 185.129 234.363
188.398 237.328 189.246 238.746 10 0 0.8 0.8 0.8 0.8
0.8 0.8 19 205.25 257.746 205.477 258.434 206.258 257.91 207.25
257.746 207.473 258.609 208.148 259.223 208.25 259.746 209.535 262.301 211.48
264.305 211.246 266.746 209.996 268.484 209.25 266.238 208.25 264.746 207.102
266.988 206.004 264.926 204.25 264.746 204.496 264.324 204.262 264.707 204.25
264.746 202.887 264.195 202.137 263.004 201.246 261.746 200.852 261.996 200.406
262.195 200.246 261.746 199.527 261.383 198.457 261.027 198.246 260.746 196.93
257.297 193.473 254.992 191.246 246.746 191.816 245.695 196.359 254.004 197.25
254.75 197.816 256.086 197.945 252.945 199.246 253.75 199.406 253.707 199.609
253.445 200.246 253.75 199.973 253.605 200.211 253.855 200.246 253.75 200.637
254.176 200.492 254.789 200.246 254.75 202.074 256.039 201.98 257.215 203.25
258.746 203.344 257.711 204.508 258.5 205.25 257.746 10 0 0.8
0.8 0.8 0.8 0.8 0.8 6 271.25 197.75 271.25 197.75
278.957 220.297 274.25 232.75 274.25 232.75 286.656 208.855 281.25 196.75
281.25 196.75 281.156 207.977 277.246 213.746 277.246 213.746 272.359 199.398
271.25 197.75 10 0 0.8 0.8 0.8 0.8 0.8 0.8
5 254.246 200.75 254.246 200.75 260.477 210.398 251.25 230.75 251.25
230.75 250.797 208.195 243.246 195.746 243.246 195.742 258.937 218.316 254.246
200.75 10 0 0.8 0.8 0.8 0.8 0.8 0.8 5
243.246 202.746 243.246 202.746 243.316 224.918 244.246 227.746 244.246 227.742
239.578 209.957 228.25 199.75 228.25 199.75 244.199 212.598 243.246 202.746
10 0 0.8 0.8 0.8 0.8 0.8 0.8 5 233.246
237.746 233.246 237.746 239.578 223.156 228.25 202.746 228.25 202.746 235.617
216.336 230.25 223.746 230.25 223.746 233.199 227.777 233.246 237.746 10
0 0.8 0.8 0.8 0.8 0.8 0.8 8 212.246 203.746
212.246 203.746 210.758 220.516 212.246 222.75 212.246 222.75 212.957 229.977
212.246 230.75 212.246 230.75 216.918 237.898 217.25 229.75 217.25 229.75
218.68 221.176 222.246 215.746 222.246 215.746 225.719 210.176 225.25 202.746
225.25 202.746 214.5 236.355 212.246 203.746 10 0 0.8 0.8
0.8 0.8 0.8 0.8 5 208.25 233.75 208.25 233.75 200.637
221.836 198.246 200.75 198.246 200.75 197.117 207.758 201.246 223.746 201.246
223.746 205.918 240.535 208.25 233.75 10 0 0.8 0.8 0.8
0.8 0.8 0.8 6 184.25 211.75 184.25 211.75 189.418 217.879
191.246 223.746 191.242 223.746 194.918 240.758 188.246 231.75 188.246 231.75
188.098 222.496 179.246 214.746 179.246 214.746 184.359 216.996 184.25 211.75
10 0 0.8 0.8 0.8 0.8 0.8 0.8 6 177.246
217.746 177.246 217.742 181.277 236.578 182.25 237.746 182.25 237.746 184.137
241.195 181.25 237.746 181.25 237.746 171.379 216.559 167.25 209.75 167.25
209.75 175.777 219.418 177.246 217.746 10 0 0.8 0.8 0.8
0.8 0.8 0.8 4 171.246 235.746 171.246 235.746 183.918 260.336
160.246 231.75 160.246 231.75 172.039 242.738 171.246 235.746 10 0
0.8 0.8 0.8 0.8 0.8 0.8 6 154.246 251.75 154.242
251.75 159.5 272.438 162.25 271.746 162.25 271.746 171.379 282.117 164.246
270.75 164.242 270.75 157.52 259.898 158.25 248.746 158.25 248.746 157.52
259.676 154.246 251.75 10 0 0.8 0.8 0.8 0.8 0.8
0.8 5 517.246 264.746 517.242 264.742 504.348 275.297 501.25 278.75
501.25 278.75 516.449 258.797 516.25 250.746 516.25 250.742 519.199 259.348
517.246 264.746 10 0 0.8 0.8 0.8 0.8 0.8 0.8
5 523.25 288.746 523.25 288.742 500.5 305 496.25 312.75 496.25
312.75 525.797 280.797 526.246 275.746 526.242 275.742 526.348 285.75 523.25
288.746 10 0 0.8 0.8 0.8 0.8 0.8 0.8 5
542.246 457.75 542.246 457.75 529.098 466.699 527.25 464.746 527.25 464.742
539 457.348 542.246 447.746 542.246 447.746 540.098 457.898 542.246 457.75
10 0 0.8 0.8 0.8 0.8 0.8 0.8 4 551.25
369.75 532.25 382.75 532.25 382.75 553.297 363.848 554.25 359.746 551.25
369.75 10 1.1 0 0 0 0 0 0 2
122.246 393.75 146.25 388.75 10 1.1 0 0 0 0
0 0 2 177.246 215.746 177.246 215.746 176.547 219.75 166.246
207.75 10 1.1 0 0 0 0 0 0 2
183.25 210.75 183.25 210.75 185.348 217.547 178.246 212.746 10 1.1
0 0 0 0 0 0 2 242.246 200.75 242.246
200.75 244.199 213.148 231.246 198.75
)! !

!AthensTiger class methodsFor: 'huge data' stamp: ''!
tigerCommands

	^ #(
'FNBMMCCCENS'
'BMMCCCEFNBMMCCCENSBM'
'MCCCEFNBMMCCCENSBMMC'
'CCEFNBMMCCCENSBMMCCC'
'EFNBMMCCCENSBMMCCCEF'
'NBMMCCCENSBMMCCCEFNB'
'MMCCCENSBMMCCCEFNBMM'
'CCCENSBMMCCCEFNBMMCC'
'CENSBMMCCCEFNBMMCCCE'
'NSBMMCCCEFNBMMCCCENS'
'BMMCCCEFNBMMCCCENSBM'
'MCCCEFNBMMCCCCCCCCLC'
'LCLCCCCCLCCLCCCCCCCL'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCCCCLLCCLCCCC'
'LCCCCCCCCCCCCCCCLNSB'
'MMCCCCCCCCLCLCLCCCCC'
'LCCLCCCCCCCLCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCLLCCLCCCCLCCCCCCC'
'CCCCCCCCLFNBMMCCCCCC'
'LCLCCCCCCCCCCCCLCCCC'
'CCCCCCCCCCCCCCCCENSB'
'MMCCCCCCLCLCCCCCCCCC'
'CCCLCCCCCCCCCCCCCCCC'
'CCCCEFNBMMCCCCLCCCCC'
'CCCCCCLFNBMMCCCCCCCC'
'LCCCCLCCCEFNBMMCCCCC'
'CCCLCCCCLCCCEFNBMMCC'
'CCCCCCLCCCCLCCCEFNBM'
'MCCCCCCCCLCCCCLCCCEF'
'NBMMCCCCCCCCLCCCCLCC'
'CEFNBMMCCCCCCCCLCCCC'
'LCCCEFNBMMCCCCCCCCLC'
'CCCLCCCEFNBMMCCCCCCC'
'CLCCCCLCCCEFNBMMCCCC'
'CCCCLCCCCLCCCEFNBMMC'
'CCCCCCCLCCCCLCCCEFNB'
'MMCCCCLCCCCCCCCCCCLF'
'NBMMCCCCCEFNBMMCCCCC'
'CEFNRMMCLCLCCCCLCLCC'
'EFNRMMCCCEFNRMMCCCEF'
'NRMMCCCEFNRMMCCCEFNR'
'MMCCCEFNRMMLCCCCCCCC'
'CCCCCCCCCCCCCLFNBMMC'
'CCLLCCCCCCCCEFNBMMCC'
'CCCCEFNBMMCCCCLFNBMM'
'CCCCCCCCCCCEFNBMMCCC'
'LCCCCCCENSBMMCCCLCCC'
'CCCEFNBMMCCCCCENSBMM'
'CCCCCEFNBMMCCCCCCCEN'
'SBMMCCFNBMMCCCENSBMM'
'CCCEFNBMMCCCENSBMMCC'
'CEFNBMMCCCENSBMMCCCE'
'FNBMMCCCENSBMMCCCEFN'
'BMMCCCENSBMMCCCEFNBM'
'MCCCENSBMMCCCENSBMMC'
'CCNSBMMCCCFNBMMCCCCC'
'ENSBMMCCCCCENSBMMCNS'
'BMMCFNBMMCCCCEFNBMMC'
'CCCCENSBMMCCCCCEFNBM'
'MCCCCCENSBMMCCCCCEFN'
'BMMCCCCENSBMMCCCCEFN'
'BMMCCCCCCCCEFNBMMCCC'
'CENSBMMCCCCEFNBMMCCC'
'ENSBMMCCCEFNBMMCCCEN'
'SBMMCCCEFNBMMCCCENSB'
'MMCCCEFNBMMCCCENSBMM'
'CCCEFNBMMLCCCLFNBMMC'
'CCCCEFNBMMCCCCCCCCEF'
'NBMMCCCCCCCCEFNBMMCC'
'CCCCCCEFNBMMCCCCCCCC'
'EFNBMMCCCCCCCCEFNBMM'
'CCCCCCCCEFNBMMCCCCEF'
'NBMMCCCCLCCCCEFNBMMC'
'CCCEFNBMMCCCCEFNBMMC'
'CEFNBMMCCCCEFNBMMCCC'
'CCLCCCCLCCEFNBMMCCCC'
'CLCCCCLCCEFNBMMCCLCC'
'CCLCCCCCEFNBMMCCLCCC'
'CLCCCCCEFNBMMCCLCCCC'
'LCCCCCEFNBMMCCCCCLCC'
'CCLCCEFNBMMCCCEFNBMM'
'CCCEFNBMMCCCEFNBMMCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'EFNBMMCCCCLCCCCCLFNB'
'MMCCCCCCEFNBMMCCCCCC'
'EFNBMMCCCCCCEFNBMMCC'
'CCCCEFNBMMCCCCCCEFNB'
'MMCCCCCCEFNBMMCCCCCL'
'CCCCCCCCCCCCCCCCLFNR'
'MMCCCEFNRMMCCLLCEFNR'
'MMCCCEFNRMMCCCCEFNRM'
'MCCCEFNBMMCLLLCCCCCC'
'CCCCCCCCCLCCCCCLCCCC'
'CCCCLCCCLLCLCCCCCCCC'
'CCCCCCCCLCCEFNBMMCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCCEFNBMMCCCCC'
'CCCCCCEFNBMMCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCEFNBMMCCCCCC'
'CCCCCCCCCCCCCCCEFNBM'
'MCCCCCCCCCCCCCCCCCCC'
'CCCCEFNBMMCCCCCCCCEF'
'NBMMCCCCEFNBMMCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCLCCCCCCCCLLLCCCCC'
'CLLCCCCCCLLLLNSRMMCC'
'NSRMMCCNSRMMCCCNSRMM'
'CCCFNBMMCCCCCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCCCLCCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCLCCCCCCCCCCCCCCCCL'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCCCCCCCCEFNRM'
'MCCCCCEFNBMMCCCCEFNB'
'MMCCCCEFNBMMCCCCEFNB'
'MMCCCCCCCCCCCLCCCEFN'
'BMMCCCCCCCCCCCCEFNBM'
'MCCCCCCCCCCCCFNBMMCC'
'CCCCCCCCCCCCCCCCLFNB'
'MMCCCCLFNBMMCLCCCCCC'
'CCCEFNBMMCCCCCCCCCCC'
'CCCCCCCCCCCCCCCEFNBM'
'MCCCCCCCCCCCCCCCCCEF'
'NBMMCCCCCCCCCCCCCCCC'
'CCCEFNBMMCCCCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'CCCCCCCCCCCCCCCCCCCC'
'EFNBMMCCCLCCCCCCCCCL'
'LCCCCLLCCCCCCLCFNBMM'
'CLCCEFNBMMCCCCCEFNBM'
'MCCCLCCCCLFNBMMCCCCC'
'CEFNBMMCCCCCCCCCCCCC'
'CCCCCCCCCEFNBMMCCCCC'
'CCCCEFNBMMCCCCCCCCCC'
'CCCEFNBMMCCCCCCCCCEF'
'NBMMCCCCCCCCCEFNBMMC'
'CCCCCCCCEFNBMMCCLFNB'
'MMCCLFNBMMCCLFNBMMCC'
'LFNBMMCCLFNBMMCCLFNB'
'MMCCLFNBMMCCLFNBMMCC'
'LFNBMMCCLFNBMMCCLFNB'
'MMCCLFNBMMCCLFNBMMCC'
'LFNBMMCCLFNBMMCCLFNB'
'MMCCCEFNBMMCCCEFNBMM'
'LLCCEFNBMMCCCCCCCCCC'
'CCCCCCCCCCCCCCCCEFNB'
'MMCCCCCCCCCEFNRMMCCC'
'ENSRMMCCCEFNRMMCCCEN'
'SRMMCCCEFNRMMCCCENSR'
'MMCCCEFNRMMCCCENSRMM'
'CCCEFNRMMCCCENSRMMCC'
'CEFNRMMCCCENSRMMCCCE'
'FNRMMCCCENSRMMCCCEFN'
'RMMCCCENSRMMCCCEFNBM'
'MCCCCCCCCCEFNBMMCCCC'
'CCCCCEFNBMMCCLFNBMMC'
'CLFNBMMCCLFNBMMCCLFN'
'BMMCCLFNBMMCCLFNBMMC'
'CLFNBMMCCLFNBMMCCLFN'
'RMMCCCENSRMMCCCEFNBM'
'MCCCCCCCCEFNRMMCCCEN'
'SRMMCCCEFNRMMCCCENSR'
'MMCCCEFNRMMCCCENSRMM'
'CCCEFNRMMCCCENSRMMCC'
'CEFNRMMCCCENSRMMCCCE'
'FNRMMCCCENSRMMCCCEFN'
'RMMCCCENSRMMCCCEFNRM'
'MCCCENSRMMCCCEFNRMMC'
'CCENSRMMCCCEFNRMMCCC'
'ENSRMMCCCEFNRMMCCCEN'
'SRMMCCCEFNRMMCCCENSR'
'MMCCCEFNRMMCCCENSRMM'
'CCCEFNRMMCCCENSRMMCC'
'CEFNRMMCCCENSRMMCCCE'
'FNRMMCCCENSRMMCCCEFN'
'RMMCCCENSRMMCCCEFNRM'
'MCCCENSRMMCCCEFNRMMC'
'CCENSRMMCCCEFNRMMCCC'
'ENSRMMCCCEFNRMMCCCEN'
'SRMMCCCEFNRMMCCCENSR'
'MMCCCEFNRMMCCCENSRMM'
'CCCEFNRMMCCCENSRMMCC'
'CEFNRMMCCCENSRMMCCCE'
'FNBMMCCLFNBMMCCLFNBM'
'MCCLFNBMMCCLFNBMMCCL'
'FNBMMCCLFNRMMCCCEFNR'
'MMCCCCCCCEFNRMMCCCCC'
'CCEFNRMMCCCCCCCCCEFN'
'RMMCCCCCEFNRMMCCCCCC'
'CCEFNRMMCCCCEFNRMMCC'
'CCCCCCCCCCCCCCCEFNRM'
'MCCCCEFNRMMCCCEFNRMM'
'CCCEFNRMMCCCEFNRMMCC'
'CCCCEFNRMMCCCEFNRMMC'
'CCCEFNRMMCCCCEFNRMMC'
'CEFNRMMCCCCEFNRMMCCC'
'EFNRMMCCCEFNRMMCCCEF'
'NRMMLCLNSRMMLNSRMMCN'
'SRMMCNSRMMC' )! !

!AthensTigerPart commentStamp: ''!
I'm a visual part of the AthensTiger.!
!AthensTigerPart methodsFor: 'accessing' stamp: ''!
strokeWidth: w
	strokeWidth := w! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
fillRule
	^ fillRule! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
setPath: anAthensCairoPath
		path := anAthensCairoPath! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
strokeWidth
	^strokeWidth! !

!AthensTigerPart methodsFor: 'initialization' stamp: ''!
initialize 
	fill := stroke := false.! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
capStyle
	^capStyle! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
strokePaint: aColor 
	strokePaint := aColor! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
fillPaint: aColor 
	fillPaint := aColor! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
addStroke
	stroke := true.! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
capStyle: cap
	capStyle := cap.! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
fillRule: rule 
	fillRule := rule.! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
miterLimit
	^miterLimit! !

!AthensTigerPart methodsFor: 'rendering' stamp: ''!
prepareFor: surface
	fill ifTrue: [
		fillPaint := surface createSolidColorPaint: fillPaint.
	].

	stroke ifTrue: [
		strokePaint := 
			surface createStrokePaintFor: (surface createSolidColorPaint: strokePaint).
	].! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
miterLimit: lim
	miterLimit := lim.! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
joinStyle: join
	joinStyle := join.! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
addFill
	fill := true.! !

!AthensTigerPart methodsFor: 'accessing' stamp: ''!
joinStyle
	^joinStyle! !

!AthensTigerPart methodsFor: 'rendering' stamp: ''!
renderOn: can

	fill ifTrue: [ 
		can setPaint: fillPaint.
		can drawShape: path.	
	].

	stroke ifTrue: [
		can setStrokePaint: strokePaint.	
		can drawShape: path.	
	]! !

!AthensTigerWindow commentStamp: ''!
I'm an example that shows a tiger that moves via rotation, translation and zoom in a Morph window.!
!AthensTigerWindow methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas

	super drawOn: aCanvas.
	aCanvas drawImage: surface asForm at: self layoutBounds origin.! !

!AthensTigerWindow methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	surface := AthensCairoSurface extent: self class surfaceExtent.
	example := AthensTiger on: surface.
	scale := surface extent x / AthensTiger tigerMaxY.
	rotation := 0.
	frames := 0.! !

!AthensTigerWindow methodsFor: 'stepping and presenter' stamp: ''!
step 
	| zoom |
	rotation := rotation + self rotationSpeed.
	frames := frames + 1.
	zoom := (frames / 100) sin abs.
	
	example
		rotation: rotation;
		zoom: zoom;
		scale: scale;
		draw.

	self changed! !

!AthensTigerWindow methodsFor: 'stepping' stamp: ''!
rotationSpeed
	^1! !

!AthensTigerWindow methodsFor: 'stepping' stamp: ''!
stepTime
	^ 50! !

!AthensTigerWindow class methodsFor: 'accessing' stamp: ''!
surfaceExtent
	^ 400 @ 400! !

!AthensTigerWindow class methodsFor: 'running' stamp: ''!
openAnimated
	<script>

	^ self new
		open;
		extent: self surfaceExtent + (50@50);
		title: 'Athens Tiger Demo';
		startStepping! !

!AthensTransform commentStamp: ''!
My instances represent an interface for coordinate system transformation defined by 3x3 matrix of following kind:

| sx   shx   x   |
| shy sy     y   |
|  w0  w1  w2 |

sx and sy define scaling in the x and y directions, respectively;
shx and shy define shearing in the x and y directions, respectively;
tx and ty define translation in the x and y directions, respectively.

AthensSurface are responsible for providing specific implementation 
of me, which is most appropriate for backend its using.

My internal representation isnt available for manipulation, for example dont assume i'm a matrix. In short, do not copy my state or modify it directly, instead use methods such as #loadAffineTransformation:, and talk to my surface.

My subclasses should implement a common protocol for applying generic types of affine transformations
on coordinate system:
- translate
- rotate
- shear
- scale
- matrix multiply
- matrix load

Surface must support 4 kinds of transformations of coordinate system(s):
- path-to-surface (#pathTransform) to transform path coordinates to surface space
- image-to-surface (#imageTransform) to transform between user coordinates and surface pixels

- fill-paint-to-user (#fillTransform)
- stroke-paint-to-user (#strokeTransform)

Given a (fill or stroke) paint-to-user transformation Tp and user-to-surface transformation Tu, the paint color and alpha of a pixel to be drawn with surface coordinates (x, y) is defined by mapping its center point (x + 1/2, y + 1/2) through the inverse transformation (Tu * Tp)^-1 , resulting in a sample point in the paint coordinate space.

All transformations, except image-to-surface , ignoring w0 , w1 and w2 values and always assume them set to { 0 , 0 , 1 } respectively.

For accessing a particular kind of transformation, send message to canvas, i.e.:

canvas pathTransform translateBy: 10@10.

It is safe to store transformation in temporary variable, as long as canvas is valid.
!
!AthensTransform methodsFor: 'transformations' stamp: ''!
rotateByDegrees: angle

	self subclassResponsibility! !

!AthensTransform methodsFor: 'transformations' stamp: ''!
rotateByRadians: angle

	self subclassResponsibility! !

!AthensTransform methodsFor: 'vector - transform' stamp: ''!
transformX: px Y: py 
	self subclassResponsibility! !

!AthensTransform methodsFor: 'transformations' stamp: ''!
scaleBy: factor

	self subclassResponsibility! !

!AthensTransform methodsFor: 'transformations' stamp: ''!
translateX: px Y: py

	self subclassResponsibility! !

!AthensTransform methodsFor: 'transformations' stamp: ''!
translateBy: aPoint

	self subclassResponsibility! !

!AthensTransform methodsFor: 'accessing' stamp: ''!
getMatrix
	"Answer an affine transformation matrix currently used by receiver.
	Note, that resulting matrix should be copied from receiver's data, i.e.
	no future modifications of receiver should affect the answered object.
	
	The default implementation is to answer a copy of receiver"
	
	^ self copy! !

!AthensTransform methodsFor: 'testing' stamp: ''!
isAffineTransform
	^ self subclassResponsibility! !

!AthensTransform methodsFor: 'testing' stamp: ''!
isIdentity
	^ self subclassResponsibility! !

!AthensTransform methodsFor: 'transformations' stamp: ''!
loadIdentity
	"Load the identity matrix into receiver"
	self subclassResponsibility! !

!AthensTransform methodsFor: 'vector - transform' stamp: ''!
transform: aPoint 
	self subclassResponsibility! !

!AthensTransform methodsFor: 'transformations' stamp: ''!
invert
	"I should invert"
	self subclassResponsibility! !

!AthensTransform methodsFor: 'transformations' stamp: ''!
loadAffineTransform: anAthenTransform
	self subclassResponsibility! !

!AthensTransform methodsFor: 'transformations' stamp: ''!
transformRectangle: aRectangle
	^ Rectangle encompassing: {
		self transform: aRectangle bottomLeft.
		self transform: aRectangle bottomRight.
		self transform: aRectangle topLeft.
		self transform: aRectangle topRight.
	}! !

!AthensTransform methodsFor: 'transformations' stamp: ''!
scaleX: fx Y: fy

	self subclassResponsibility! !

!AthensTransform methodsFor: 'transformations' stamp: ''!
restoreAfter: aBlock
	"I should save the current transform state, evaluate the block, and then restore the saved transform state"
	self subclassResponsibility! !

!AthensTransformTest commentStamp: ''!
An AthensTransformTest is a test class for testing the behavior of AthensTransform!
!AthensTransformTest methodsFor: 'instance creation' stamp: ''!
newTransform
	^ self transformClass new! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testTransformXY
	| transform |
	transform := self newTransform.
	transform
		translateX: 1 Y: 9;
		rotateByDegrees: 90;
		scaleX: 3 Y: 5.
	self assert: transform isAffineTransform.
	self assert: (transform transformX: 0 Y: 0) closeTo: 1@9.
	self assert: (transform transformX: 1 Y: 2) closeTo: -9@12.
	self assert: (transform transformX: -3 Y: -4) closeTo: 21 @ 0.
	self assert: (transform transformX: 1 Y: -2) closeTo: 11 @ 12.
	self assert: (transform transformX: -2 Y: -5) closeTo: 26 @ 3.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testLoadAffineTransform
	| transform affineTransform |
	transform := self newTransform.
	affineTransform := AthensAffineTransform new.
	affineTransform
		translateX: 1 Y: 9;
		rotateByDegrees: 90;
		scaleX: 3 Y: 5.
	transform loadAffineTransform: affineTransform.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) closeTo: 1@9.
	self assert: (transform transform: 1@2) closeTo: -9@12.
	self assert: (transform transform: -3 @ -4) closeTo: 21 @ 0.
	self assert: (transform transform: 1 @ -2) closeTo: 11 @ 12.
	self assert: (transform transform: -2 @ -5) closeTo: 26 @ 3.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testLoadIdentity
	| transform |
	transform := self newTransform.
	transform translateX: 5 Y: 0; rotateByDegrees: 45; scaleX: 5 Y: 42.
	transform loadIdentity.

	self assert: transform isIdentity.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 1@2.
	self assert: (transform transform: -3 @ -4) equals: -3 @ -4.
	self assert: (transform transform: 1 @ -2) equals: 1 @ -2.
	self assert: (transform transform: -2 @ -5) equals: -2 	@ -5.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testInvert
	| transform |
	transform := self newTransform.
	transform
		translateX: 1 Y: 9;
		rotateByDegrees: 90;
		scaleX: 3 Y: 5;
		invert.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 1 @ 9) closeTo: 0 @ 0.
	self assert: (transform transform: 0@0) closeTo: -3@0.2.
	self assert: (transform transform: 10@3) closeTo: -2 @ -1.8.
	self assert: (transform transform: -3 @ -6) closeTo: -5 @ 0.8.
	self assert: (transform transform: 1 @ -18) closeTo: -9 @ 0.
	self assert: (transform transform: -2 @ -3) closeTo: -4 @ 0.6! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testTranslateBy
	| transform |
	transform := self newTransform.
	transform translateBy: 0 @ 0.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 1@2.
	self assert: (transform transform: -3 @ -4) equals: -3 @ -4.
	self assert: (transform transform: 1 @ -2) equals: 1 @ -2.
	self assert: (transform transform: -2 @ -5) equals: -2 	@ -5.

	transform translateBy: 4 @ -3.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 4 @ -3.
	self assert: (transform transform: 1@2) equals: 5 @ -1.
	self assert: (transform transform: -3 @ -4) equals: 1 @ -7.
	self assert: (transform transform: 1 @ -2) equals: 5 @ -5.
	self assert: (transform transform: -2 @ -5) equals: 2 @ -8.
		
	transform translateBy: -3 @ 5.
	"Translation: (4 @ -3) + (-3 @ 5) = 1@2 "
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 1@2.
	self assert: (transform transform: 1@2) equals: 2@4.
	self assert: (transform transform: -3 @ -4) equals: -2 @ -2.
	self assert: (transform transform: 1 @ -2) equals: 2 @ 0.
	self assert: (transform transform: -2 @ -5) equals: -1 	@ -3.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testTranslate
	| transform |
	transform := self newTransform.
	transform translateBy: 0 @ 0.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 1@2.
	self assert: (transform transform: -3 @ -4) equals: -3 @ -4.
	self assert: (transform transform: 1 @ -2) equals: 1 @ -2.
	self assert: (transform transform: -2 @ -5) equals: -2 	@ -5.

	transform translateBy: 4 @ -3.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 4 @ -3.
	self assert: (transform transform: 1@2) equals: 5 @ -1.
	self assert: (transform transform: -3 @ -4) equals: 1 @ -7.
	self assert: (transform transform: 1 @ -2) equals: 5 @ -5.
	self assert: (transform transform: -2 @ -5) equals: 2 @ -8.
		
	transform translateBy: -3 @ 5.
	"Translation: (4 @ -3) + (-3 @ 5) = 1@2 "
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 1@2.
	self assert: (transform transform: 1@2) equals: 2@4.
	self assert: (transform transform: -3 @ -4) equals: -2 @ -2.
	self assert: (transform transform: 1 @ -2) equals: 2 @ 0.
	self assert: (transform transform: -2 @ -5) equals: -1 	@ -3.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testScaleBy
	| transform |
	transform := self newTransform.
	transform scaleBy: 1.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 1@2.
	self assert: (transform transform: -3 @ -4) equals: -3 @ -4.
	self assert: (transform transform: 1 @ -2) equals: 1 @ -2.
	self assert: (transform transform: -2 @ -5) equals: -2 	@ -5.

	transform scaleBy: 3.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 3@6.
	self assert: (transform transform: -3 @ -4) equals: -9 @ -12.
	self assert: (transform transform: 1 @ -2) equals: 3 @ -6.
	self assert: (transform transform: -2 @ -5) equals: -6 	@ -15.
		
	transform scaleBy: -0.5.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) closeTo: 0@0.
	self assert: (transform transform: 1@2) closeTo: -1.5 @ -3.
	self assert: (transform transform: -3 @ -4) closeTo: 4.5 @ 6.
	self assert: (transform transform: 1 @ -2) closeTo: -1.5 @ 3.
	self assert: (transform transform: -2 @ -5) closeTo: 3 @ 7.5.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testTransform
	| transform |
	transform := self newTransform.
	transform
		translateX: 1 Y: 9;
		rotateByDegrees: 90;
		scaleX: 3 Y: 5.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) closeTo: 1@9.
	self assert: (transform transform: 1@2) closeTo: -9@12.
	self assert: (transform transform: -3 @ -4) closeTo: 21 @ 0.
	self assert: (transform transform: 1 @ -2) closeTo: 11 @ 12.
	self assert: (transform transform: -2 @ -5) closeTo: 26 @ 3.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testTranslateXY
	| transform |
	transform := self newTransform.
	transform translateX: 0 Y: 0.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 1@2.
	self assert: (transform transform: -3 @ -4) equals: -3 @ -4.
	self assert: (transform transform: 1 @ -2) equals: 1 @ -2.
	self assert: (transform transform: -2 @ -5) equals: -2 	@ -5.

	transform translateX: 4 Y: -3.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 4 @ -3.
	self assert: (transform transform: 1@2) equals: 5 @ -1.
	self assert: (transform transform: -3 @ -4) equals: 1 @ -7.
	self assert: (transform transform: 1 @ -2) equals: 5 @ -5.
	self assert: (transform transform: -2 @ -5) equals: 2 @ -8.
		
	transform translateX: -3 Y: 5.
	"Translation: (4 @ -3) + (-3 @ 5) = 1@2 "
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 1@2.
	self assert: (transform transform: 1@2) equals: 2@4.
	self assert: (transform transform: -3 @ -4) equals: -2 @ -2.
	self assert: (transform transform: 1 @ -2) equals: 2 @ 0.
	self assert: (transform transform: -2 @ -5) equals: -1 	@ -3.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testScaleXY
	| transform |
	transform := self newTransform.
	transform scaleX: 1 Y: 1.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 1@2.
	self assert: (transform transform: -3 @ -4) equals: -3 @ -4.
	self assert: (transform transform: 1 @ -2) equals: 1 @ -2.
	self assert: (transform transform: -2 @ -5) equals: -2 	@ -5.

	transform scaleX: 3 Y: -3.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 3@ -6.
	self assert: (transform transform: -3 @ -4) equals: -9 @ 12.
	self assert: (transform transform: 1 @ -2) equals: 3 @ 6.
	self assert: (transform transform: -2 @ -5) equals: -6 	@ 15.
		
	transform scaleX: -0.5 Y: 0.5.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) closeTo: 0@0.
	self assert: (transform transform: 1@2) closeTo: -1.5 @ -3.
	self assert: (transform transform: -3 @ -4) closeTo: 4.5 @ 6.
	self assert: (transform transform: 1 @ -2) closeTo: -1.5 @ 3.
	self assert: (transform transform: -2 @ -5) closeTo: 3 @ 7.5.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testTransformRectangle
	| transform |
	transform := self newTransform.
	self assert: transform isAffineTransform.
	self assert: (transform transformRectangle: (0@0 extent: 10@20)) closeTo: (0@0 extent: 10@20).

	transform translateX: 5 Y: 3.
	self assert: (transform transformRectangle: (0@0 extent: 10@20)) closeTo: (5@3 extent: 10@20).
	
	transform scaleX: 4 Y: 3.
	self assert: (transform transformRectangle: (0@0 extent: 10@20)) closeTo: (5@3 extent: 40@60).
	
	transform rotateByDegrees: 90.
	self assert: (transform transformRectangle: (0@0 extent: 10@20)) closeTo: (-75@3 extent: 80@30).! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testRestoreAfter
	| transform |
	transform := self newTransform.
	transform
		translateX: 1 Y: 9;
		rotateByDegrees: 90;
		scaleX: 3 Y: 5.
		
	transform restoreAfter: [ 
		transform
			loadIdentity;
			translateBy: 4 @ -3.
		self assert: transform isAffineTransform.
		self assert: (transform transform: 0@0) equals: 4 @ -3.
		self assert: (transform transform: 1@2) equals: 5 @ -1.
		self assert: (transform transform: -3 @ -4) equals: 1 @ -7.
		self assert: (transform transform: 1 @ -2) equals: 5 @ -5.
		self assert: (transform transform: -2 @ -5) equals: 2 @ -8.
	].

	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) closeTo: 1@9.
	self assert: (transform transform: 1@2) closeTo: -9@12.
	self assert: (transform transform: -3 @ -4) closeTo: 21 @ 0.
	self assert: (transform transform: 1 @ -2) closeTo: 11 @ 12.
	self assert: (transform transform: -2 @ -5) closeTo: 26 @ 3.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
transformClass
	self subclassResponsibility! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testRotateByDegrees
	| transform |
	transform := self newTransform.
	transform rotateByDegrees: 0.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 1@2.
	self assert: (transform transform: -3 @ -4) equals: -3 @ -4.
	self assert: (transform transform: 1 @ -2) equals: 1 @ -2.
	self assert: (transform transform: -2 @ -5) equals: -2 	@ -5.

	transform rotateByDegrees: 180.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) closeTo: 0@0.
	self assert: (transform transform: 1@2) closeTo: -1 @ -2.
	self assert: (transform transform: -3 @ -4) closeTo: 3 @ 4.
	self assert: (transform transform: 1 @ -2) closeTo: -1 @ 2.
	self assert: (transform transform: -2 @ -5) closeTo: 2 @ 5.
		
	transform rotateByDegrees: -90.
	"Rotation: 180 - 90 = 90"
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) closeTo: 0@0.
	self assert: (transform transform: 1@2) closeTo: -2@1.
	self assert: (transform transform: -3 @ -4) closeTo: 4 @ -3.
	self assert: (transform transform: 1 @ -2) closeTo: 2 @ 1.
	self assert: (transform transform: -2 @ -5) closeTo: 5 @ -2.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testRotateByRadians
	| transform |
	transform := self newTransform.
	transform rotateByRadians: 0.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 1@2.
	self assert: (transform transform: -3 @ -4) equals: -3 @ -4.
	self assert: (transform transform: 1 @ -2) equals: 1 @ -2.
	self assert: (transform transform: -2 @ -5) equals: -2 	@ -5.

	transform rotateByRadians: Float pi.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) closeTo: 0@0.
	self assert: (transform transform: 1@2) closeTo: -1 @ -2.
	self assert: (transform transform: -3 @ -4) closeTo: 3 @ 4.
	self assert: (transform transform: 1 @ -2) closeTo: -1 @ 2.
	self assert: (transform transform: -2 @ -5) closeTo: 2 @ 5.
		
	transform rotateByRadians: Float halfPi negated.
	"Rotation: pi - pi/2 = pi/2"
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) closeTo: 0@0.
	self assert: (transform transform: 1@2) closeTo: -2@1.
	self assert: (transform transform: -3 @ -4) closeTo: 4 @ -3.
	self assert: (transform transform: 1 @ -2) closeTo: 2 @ 1.
	self assert: (transform transform: -2 @ -5) closeTo: 5 @ -2.! !

!AthensTransformTest methodsFor: 'tests' stamp: ''!
testIdentity
	| transform |
	transform := self newTransform.
	self assert: transform isIdentity.
	self assert: transform isAffineTransform.
	self assert: (transform transform: 0@0) equals: 0@0.
	self assert: (transform transform: 1@2) equals: 1@2.
	self assert: (transform transform: -3 @ -4) equals: -3 @ -4.
	self assert: (transform transform: 1 @ -2) equals: 1 @ -2.
	self assert: (transform transform: -2 @ -5) equals: -2 	@ -5.! !

!AthensTransformTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == AthensTransformTest! !

!AthensTreeDemo commentStamp: ''!
A tree visualization using Athens for display!
!AthensTreeDemo methodsFor: 'private' stamp: ''!
buildSubtreeFor: aNodeObject level: aLevel
	| node childs |
	node := AthensSimpleTreeNode new.
	node 
		subject: aNodeObject;
		extent: (nodeExtentBlock value: aNodeObject).
	childs := (nodeChildsBlock value: aNodeObject) collect:  [ :each | self buildSubtreeFor: each level: aLevel+1 ].
	node children: childs.
	(self rowAt: aLevel) add: node.
	^ node! !

!AthensTreeDemo methodsFor: 'private' stamp: ''!
layOutGeometry

	"first do a vertical layout"
	
	| origin |
	
	origin := 0.
	
	
	rows do: [:row |  | rowHeight color |
		
		rowHeight := 0.
		color := Color random.
		
		row do: [ :node |
			node originY: origin.
			node color: color.
			rowHeight := rowHeight max: node height.
		].
	
		origin := origin + rowHeight + self spacingBetweenRows.
	].

	"now do a horizontal one"
	
	root layoutHorizontally: 0.! !

!AthensTreeDemo methodsFor: 'accessing' stamp: ''!
spacingBetweenRows
	^ 30! !

!AthensTreeDemo methodsFor: 'private - initialization' stamp: ''!
root: aRootObject extentBlock: extBlock childsBlock: childsBlock

	nodeExtentBlock := extBlock.
	nodeChildsBlock := childsBlock.

	root := self buildSubtreeFor: aRootObject level: 1.
	
	self layOutGeometry! !

!AthensTreeDemo methodsFor: 'accessing' stamp: ''!
rowAt: aLevel
	rows ifNil: [  rows := OrderedCollection new ].
	
	[ aLevel > rows size ] whileTrue: [  rows add: OrderedCollection new ].

	^ rows at: aLevel! !

!AthensTreeDemo methodsFor: 'accessing' stamp: ''!
root: aRootObject

	root := self buildSubtreeFor: aRootObject level: 1.
	
	self layOutGeometry! !

!AthensTreeDemo methodsFor: 'rendering' stamp: ''!
renderOn: aCanvas
	aCanvas surface clear: Color white.
	root renderOn: aCanvas! !

!AthensTreeDemo class methodsFor: 'examples' stamp: ''!
example1
	<script>
	self
		openOn: Collection
		extentBlock: [ :each | (5 + each slots size) @ (5 + each methods size) ]
		childsBlock: [ :el | el subclasses ]! !

!AthensTreeDemo class methodsFor: 'instance creation' stamp: ''!
openOn: root extentBlock: extBlock childsBlock: childsBlock

	| scene |
	
	scene := self new root: root extentBlock: extBlock childsBlock: childsBlock.
		
	^ AthensSceneView new
		scene: scene;
		openInWindow! !

!AthensWorldMorph commentStamp: ''!
An AthensWorldMorph is a special version of a WorldMorph.
It is within a real Morph in a real morphic world. The Morph it is in defines the DisplayScreen dimension. (see AthensWrappedWorldDisplay)!
!AthensWorldMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	worldState := AthensWorldState new! !

!AthensWorldMorph methodsFor: 'world state' stamp: ''!
display
	worldState display! !

!AthensWorldMorph methodsFor: 'world state' stamp: ''!
restoreMorphicDisplay
"overwritten for using its own display dimension"
	DisplayScreen startUp.

	self
		extent: self display extent;
		viewBox: self display boundingBox;
		handsDo: [:h | h visible: true; showTemporaryCursor: nil];
		resizeBackgroundMorph;
		submorphsDo: [ :each | each displayExtentChanged ];
		fullRepaintNeeded.
		
	self defer: [Cursor normal show].
		
	self layoutChanged.! !

!AthensWorldMorph methodsFor: 'world state' stamp: ''!
display: aWrappedDisplay
	worldState display: aWrappedDisplay! !

!AthensWorldState commentStamp: ''!
An AthensWorldState is a subclass of WorldState, that uses a special (fake) Display based on a real Morph. This is used to simulate a WorldMorph that actually resides in another Morph. This display adapts the owner dimensions as the "DisplayScreen"-Dimension.

!
!AthensWorldState methodsFor: 'accessing' stamp: ''!
display
	^ display! !

!AthensWorldState methodsFor: 'accessing' stamp: ''!
display: aDisplay
	display := aDisplay! !

!AthensWorldState methodsFor: 'update cycle' stamp: ''!
doDeferredUpdatingFor: aWorld
	"overwritten from WorldState to use ower own display"

	(self display deferUpdates: true) ifNil: [ ^ false ].
	(canvas notNil and: [ canvas form == Display ])
		ifFalse: [ 
			aWorld viewBox: self display boundingBox.	"do first since it may clear canvas"
			self canvas: (self display getCanvas copyClipRect: self display boundingBox) ].
	^ true! !

!AthensWrapMorph commentStamp: ''!
I make sure that all my submorphs will be drawn using Athens, not Balloon. For that I use a separate surface.!
!AthensWrapMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas

	"do nothing"! !

!AthensWrapMorph methodsFor: 'drawing' stamp: ''!
fullDrawOnAthensCanvas: anAthensCanvas 
	"Draw the full Morphic structure on the given Canvas"

	self visible ifFalse: [^ self].
	(anAthensCanvas isVisible: self fullBounds) ifFalse: [^self].
	(self hasProperty: #errorOnDraw) ifTrue: [^self "drawErrorOn: aCanvas" ].

	(anAthensCanvas isVisible: self bounds) ifTrue: [ anAthensCanvas draw: self ].
	
	submorphs reverseDo: [:m | anAthensCanvas fullDrawMorph: m ]! !

!AthensWrapMorph methodsFor: 'drawing' stamp: ''!
render
	surface drawDuring: [ :canvas |
		surface clear.
		canvas pathTransform restoreAfter: [ 
			"before rendering transform from a global coordinates (Morphic) to relative coordinates (Athens)"
			canvas pathTransform translateBy: self bounds origin negated.
			self fullDrawOnAthensCanvas: canvas.
		].
	].! !

!AthensWrapMorph methodsFor: 'surface management' stamp: ''!
createSurface
	| extent |
	extent := bounds extent asIntegerPoint.
	surface := AthensCairoSurface extent: extent.! !

!AthensWrapMorph methodsFor: 'surface management' stamp: ''!
checkSurface

	session == Smalltalk session ifFalse: [ 
		self initializeForNewSession
		 ].
	
	bounds extent ~= surface extent ifTrue: [ 
		"recreate a surface if dimensions are changed"	
		self createSurface
	 ]! !

!AthensWrapMorph methodsFor: 'drawing' stamp: ''!
fullDrawOn: aCanvas

	"Draw the full Morphic structure on the given Canvas"

	self visible ifFalse: [^ self].
	(aCanvas isVisible: self fullBounds) ifFalse:[^self].
	(self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas].
	
	self checkSurface.

	[
		self render.
		surface displayOnMorphicCanvas: aCanvas at: bounds origin.
	
	] on: Error do: [:err |
		self setProperty: #errorOnDraw toValue: true.
		self setProperty: #drawError toValue: err freeze.
		^ self drawErrorOn: aCanvas
	]! !

!AthensWrapMorph methodsFor: 'surface management' stamp: ''!
initializeForNewSession
	self createSurface.
	session := Smalltalk session.! !

!AthensWrapMorph methodsFor: 'accessing' stamp: ''!
athensSurface
	self checkSurface.
	
	^ surface! !

!AthensWrapMorph methodsFor: 'events handling' stamp: ''!
handlesMouseDown: evt
	^ true! !

!AthensWrapMorph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: aCanvas

	"do nothing"! !

!AthensWrapWorldMorph commentStamp: ''!
An AthensWrapWorldMorph is a AthensWrapMorph holding a specialized Athens WorldMorph. This Athens WorldMorph draws the submorphs with an AthensCanvas.

Instance Variables
	worldmorph:		the Athens WorldMorph
	wrappedWorldDisplay:		a display wrapper
!
!AthensWrapWorldMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self extent: self defaultExtent.
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
	wrappedWorldDisplay := AthensWrappedWorldDisplay on: self.
	worldmorph := AthensWorldMorph new.
	worldmorph color: Color orange.
	worldmorph addHand: HandMorph new.
	worldmorph display: wrappedWorldDisplay.
	self addMorph: worldmorph! !

!AthensWrapWorldMorph methodsFor: 'stepping' stamp: ''!
step
	self changed! !

!AthensWrapWorldMorph methodsFor: 'initialization' stamp: ''!
defaultExtent
	^ 400 @ 400! !

!AthensWrapWorldMorph methodsFor: 'layout' stamp: ''!
layoutChanged
	super layoutChanged.
	worldmorph ifNotNil:[:w |  w extent: self extent].! !

!AthensWrapWorldMorph methodsFor: 'stepping' stamp: ''!
stepTime
	^ 50! !

!AthensWrappedWorldDisplay commentStamp: ''!
An AthensWrappedWorldDisplay acts as a DisplayScreen
for a wrapped WorldMorph.

Instance Variables
	realDisplay:		the realdisplay
	wrapMorph:	the wrapped world
!
!AthensWrappedWorldDisplay methodsFor: 'display protocol' stamp: ''!
doesNotUnderstand: aMessage
	"delegate all not implemented methods to the real display"

	^ (realDisplay respondsTo: aMessage selector)
		ifTrue: [ realDisplay perform: aMessage selector withEnoughArguments: aMessage arguments ]
		ifFalse: [ super doesNotUnderstand: aMessage ]! !

!AthensWrappedWorldDisplay methodsFor: 'accessing' stamp: ''!
wrapMorph
	^ wrapMorph! !

!AthensWrappedWorldDisplay methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	realDisplay := Display! !

!AthensWrappedWorldDisplay methodsFor: 'display protocol' stamp: ''!
extent
	^ wrapMorph ifNotNil: [ wrapMorph extent ] ifNil: [ 0 @ 0 ]! !

!AthensWrappedWorldDisplay methodsFor: 'display protocol' stamp: ''!
boundingBox
	^ wrapMorph ifNotNil: [ wrapMorph fullBounds ] ifNil: [ 0 @ 0 extent: 0 @ 0 ]! !

!AthensWrappedWorldDisplay methodsFor: 'accessing' stamp: ''!
wrapMorph: anObject
	wrapMorph := anObject! !

!AthensWrappedWorldDisplay class methodsFor: 'instance creation' stamp: ''!
on: aWorldWrapMorph
	^ self new wrapMorph:aWorldWrapMorph! !

!AtomicCollection commentStamp: ''!
I am just a base abstract class, containing common behavior for various queue types!
!AtomicCollection methodsFor: 'signaling' stamp: ''!
signalAddedNewItem
	"Optional, override in subclass(es) to signal that new item available in queue.
	Default implementation does nothing"! !

!AtomicCollection methodsFor: 'copying' stamp: ''!
deepCopy
	^ self errorDontCopy! !

!AtomicCollection methodsFor: 'copying' stamp: ''!
copy
	^ self errorDontCopy! !

!AtomicCollection methodsFor: 'copying' stamp: ''!
errorDontCopy
	"copying a structure, involved in concurrent operations is a bad idea"
	^ self error: 'Copying not available'! !

!AtomicCollection methodsFor: 'debug support' stamp: ''!
interrupt
	"simulate interrupt , for debugging purposes only"
	Processor yield! !

!AtomicCollection methodsFor: 'yielding' stamp: ''!
yield
	"Yield the current process.
	Used internally by spin loops, once detected that 
	current process can't make any progress
	without some external event to happen"
	Processor yield! !

!AtomicCollection methodsFor: 'signaling' stamp: ''!
signalNoMoreItems
	"Optional, override in subclass(es) to signal that queue is currently empty.
	Default implementation does nothing"! !

!AtomicCollection methodsFor: 'signaling' stamp: ''!
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: 'utilities' stamp: ''!
newItem
	"override in subclass, if you need to instantiate queue items of different class or initialize them in some specific way"
	^ AtomicQueueItem new! !

!AtomicQueueItem commentStamp: ''!
I am a queue item, used by atomic queues.
All my new instances are circular i.e. next = self!
!AtomicQueueItem methodsFor: 'testing' stamp: ''!
isCircular
	^ next == self! !

!AtomicQueueItem methodsFor: 'initialization' stamp: ''!
initialize
	"make circular"
	super initialize.
	next := self.! !

!AtomicQueueItem methodsFor: 'accessing' stamp: ''!
next
	"Answer the value of next"

	^ next! !

!AtomicQueueItem methodsFor: 'accessing' stamp: ''!
next: anObject
	"Set the value of next"

	next := anObject! !

!AtomicQueueItem methodsFor: 'testing' stamp: ''!
isZombie
	"Answer a boolean indicating that the receiver doesn't have a real object.
	This should really check that the object is the queue's dummy, but since the item doesn't know which queue it is part of, use the object class instead."

	^object class = self class! !

!AtomicQueueItem methodsFor: 'accessing' stamp: ''!
object: anObject
	"Set the value of object"

	object := anObject! !

!AtomicQueueItem methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream << '('.
	self isZombie ifTrue: 
		[ aStream << '<zombie>' ]
	ifFalse:
		[ object printOn: aStream ].
	self isCircular ifTrue: 
		[ aStream << ', Circular' ].
	aStream
		<< ')'! !

!AtomicQueueItem methodsFor: 'accessing' stamp: ''!
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: ''!
object
	"Answer the value of object"

	^ object! !

!AtomicSharedQueue commentStamp: ''!
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: 'signaling' stamp: ''!
signalAddedNewItem
	availSema signal! !

!AtomicSharedQueue methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	availSema := Semaphore new.! !

!AtomicSharedQueue methodsFor: 'accessing' stamp: ''!
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: 'signaling' stamp: ''!
signalNoMoreItems
	"queue is empty, reset sema signals"
	availSema consumeAllSignals! !

!AtomicSharedQueue methodsFor: 'signaling' stamp: ''!
waitForNewItems
	availSema wait! !

!Author commentStamp: ''!
I am responsible for the full name used to identify the current code author.!
!Author methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	fullName := ''! !

!Author methodsFor: 'accessing' stamp: ''!
checkAndSetFullNameWith: aString 
	
	fullName := 
	aString select: [ :character |
		character charCode < 128 and: [ character isAlphaNumeric ]
	].
	
	(fullName = aString and: [ fullName isNotEmpty ]) ifFalse: [ self requestFullName ]
	
	
	! !

!Author methodsFor: 'ui - requests' stamp: ''!
requestFullName
	| initialAnswer |
	
	initialAnswer := fullName isEmptyOrNil
				ifTrue: ['FirstnameLastname']
				ifFalse: [fullName].
				
	(AuthorNameRequest new initialAnswer: initialAnswer) signal 
		ifNotNil: [ :newName | self checkAndSetFullNameWith: newName ] 
		"nil means that the dialog was cancelled "! !

!Author methodsFor: 'accessing' stamp: ''!
fullName: aString
	fullName := aString.	
! !

!Author methodsFor: 'accessing' stamp: ''!
fullName
	"Answer the full name to be used to identify the current code author."

	[fullName isEmptyOrNil] whileTrue: [
		self requestFullName.
		(fullName isEmptyOrNil or:[ fullName = 'FirstnameLastname' ]) 
				ifTrue: [fullName := nil. ^'Anonymous']
	].
	^ fullName! !

!Author methodsFor: 'compatibility' stamp: ''!
ifUnknownAuthorUse: aString during: aBlock
	"If no author is set use the name aString while executing aBlock."
	"for compatibility with 1.0"
	
	fullName isEmptyOrNil ifFalse: [ ^ aBlock value ].
	fullName := aString.
	^ aBlock ensure: [ self reset ]! !

!Author methodsFor: 'initialization' stamp: ''!
reset
	fullName := ''! !

!Author methodsFor: 'testing - support' stamp: ''!
useAuthor: aString during: aBlock
	| previous |
	previous := fullName.
	fullName := aString.
	^ aBlock ensure: [ fullName := previous ]! !

!Author methodsFor: 'accessing' stamp: ''!
fullNamePerSe
	"Answer the currently-prevailing author full name, such as it is, empty or not"
	^ fullName! !

!Author class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Author is a singleton -- send uniqueInstance instead'! !

!Author class methodsFor: 'utilities' stamp: ''!
fixStamp: changeStamp 
	| parts |
	parts := changeStamp findTokens: ' '.
	(parts notEmpty and: [parts last first isLetter]) ifTrue:
		["Put initials first in all time stamps..."
		^ String streamContents:
				[:s | s nextPutAll: parts last.
				parts allButLast do: [:p | s space; nextPutAll: p]]].
	^ changeStamp! !

!Author class methodsFor: 'utilities' stamp: ''!
changeStampPerSe
	"Answer a string to be pasted into source code to mark who changed it and when."

	^ (self fullNamePerSe ifNil: ['.']) , ' ' , Date today mmddyyyy, ' ',
		((String streamContents: [:s | Time now print24: true on: s]) 
			copyFrom: 1 to: 5)! !

!Author class methodsFor: 'testing - support' stamp: ''!
useAuthor: aString during: aBlock
	^ self uniqueInstance useAuthor: aString during: aBlock! !

!Author class methodsFor: 'utilities' stamp: ''!
changeStamp 
	"Answer a string to be pasted into source code to mark who changed it and when."
	^ self fullName , ' ' , Date today mmddyyyy, ' ',
		((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! !

!Author class methodsFor: 'instance creation' stamp: ''!
uniqueInstance
	^ uniqueInstance ifNil: [ uniqueInstance := super new ]! !

!Author class methodsFor: 'convenience' stamp: ''!
requestFullName
	^ self uniqueInstance requestFullName! !

!Author class methodsFor: 'convenience' stamp: ''!
fullName: aString 
	^ self uniqueInstance checkAndSetFullNameWith: aString! !

!Author class methodsFor: 'settings' stamp: ''!
authorSettingOn: aBuilder
	<systemsettings>
	(aBuilder setting: #authorFullName)
		order: -100000;
		parent: #pharoSystem;
		label: 'Author identification';
		target: self uniqueInstance;
		getSelector: #fullNamePerSe;
		setSelector: #fullName:;
		notInStyle;
		default: '';
		ghostHelp: 'VincentVanGogh';
		description: AuthorNameRequest messagePrompt
! !

!Author class methodsFor: 'convenience' stamp: ''!
fullName
	^ self uniqueInstance fullName! !

!Author class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	^ self uniqueInstance reset! !

!Author class methodsFor: 'convenience' stamp: ''!
fullNamePerSe
	^ self uniqueInstance fullNamePerSe ! !

!AuthorNameRequest commentStamp: ''!
I am used to request a new author name.!
!AuthorNameRequest methodsFor: 'accessing' stamp: ''!
initialAnswer
	
	^ initialAnswer! !

!AuthorNameRequest methodsFor: 'accessing' stamp: ''!
initialAnswer: anObject
	
	initialAnswer := anObject! !

!AuthorNameRequest methodsFor: 'ui-requests' stamp: ''!
messagePrompt
	^ self class messagePrompt! !

!AuthorNameRequest methodsFor: 'exception handling' stamp: ''!
defaultAction
	^ UIManager default
			request: self messagePrompt
			initialAnswer: initialAnswer
			title: 'Author identification'! !

!AuthorNameRequest class methodsFor: 'accessing' stamp: ''!
messagePrompt
	^
'Please type your full name. 
It will be used to sign the changes you make to the image.
Spaces, accents, dashes, underscore and similar characters are not allowed
'! !

!AuthorTest commentStamp: ''!
SUnit tests for Author!
!AuthorTest methodsFor: 'tests' stamp: ''!
testUniqueness
	self should: [ Author new ] raise: Error! !

!BMPReadWriter commentStamp: ''!
I am BMPReadWriter.
I am a concrete ImageReadWriter.

I read and write the BMP image file format.

	https://en.wikipedia.org/wiki/BMP_file_format

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: ''!
readHeader
 
	bfType := self nextLittleEndianNumber: 2.
	bfSize := self nextLittleEndianNumber: 4.
	self nextLittleEndianNumber: 4. "reserved, do nothing with it"
	bfOffBits := self nextLittleEndianNumber: 4.
	biSize := self nextLittleEndianNumber: 4.
	biWidth := self nextLittleEndianNumber: 4.
	biHeight := self nextLittleEndianNumber: 4.
	biPlanes := self nextLittleEndianNumber: 2.
	biBitCount := self nextLittleEndianNumber: 2.
	biCompression := self nextLittleEndianNumber: 4.
	biSizeImage := self nextLittleEndianNumber: 4.
	biXPelsPerMeter := self nextLittleEndianNumber: 4.
	biYPelsPerMeter := self nextLittleEndianNumber: 4.
	biClrUsed := self nextLittleEndianNumber: 4.
	biClrImportant := self nextLittleEndianNumber: 4! !

!BMPReadWriter methodsFor: 'reading' stamp: ''!
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."
	<primitive: 'primitiveRead24BmpLine' module:'BMPReadWriterPlugin'>
	
	| 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: ''!
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: 'writing' stamp: ''!
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"
	self nextLittleEndianNumber: 2 put: 19778.  "bfType = BM"
	self nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage.  "Entire file size in bytes"
	self nextLittleEndianNumber: 4 put: 0.  "bfReserved"
	self nextLittleEndianNumber: 4 put: bfOffBits.  "Offset of bitmap data from start of hdr (and file)"

	"Write the bitmap info header"
	self nextLittleEndianNumber: 4 put: biSize.  "info header size in bytes"
	self nextLittleEndianNumber: 4 put: image width.  "biWidth"
	self nextLittleEndianNumber: 4 put: image height.  "biHeight"
	self nextLittleEndianNumber: 2 put: 1.  "biPlanes"
	self nextLittleEndianNumber: 2 put: (depth min: 24).  "biBitCount"
	self nextLittleEndianNumber: 4 put: 0.  "biCompression"
	self nextLittleEndianNumber: 4 put: biSizeImage.  "size of image section in bytes"
	self nextLittleEndianNumber: 4 put: 2800.  "biXPelsPerMeter"
	self nextLittleEndianNumber: 4 put: 2800.  "biYPelsPerMeter"
	self nextLittleEndianNumber: 4 put: biClrUsed.
	self 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.
		].
	]! !

!BMPReadWriter methodsFor: 'reading' stamp: ''!
nextImage
	| colors |
	self readHeader.
	biBitCount = 24 ifTrue:[^self read24BmpFile].
	"read the color map"
	colors := self readColorMap.
	^self readIndexedBmpFile: colors! !

!BMPReadWriter methodsFor: 'writing' stamp: ''!
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."
	<primitive: 'primitiveWrite24BmpLine' module:'BMPReadWriterPlugin'>

	| pixIndex rgb bitsIndex |	
	pixIndex := 0. "pre-increment"
	bitsIndex := formBitsIndex-1. "pre-increment"
	1 to: width do: [:j |
		rgb := (formBits at: (bitsIndex := bitsIndex+1)) bitAnd: 16rFFFFFF.
		pixelLine at: (pixIndex := pixIndex+1) put: (rgb bitAnd: 255).
		pixelLine at: (pixIndex := pixIndex+1) put: ((rgb bitShift: -8) bitAnd: 255).
		pixelLine at: (pixIndex := pixIndex+1) put: ((rgb bitShift: -16) bitAnd: 255).
	].! !

!BMPReadWriter methodsFor: 'reading' stamp: ''!
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: 'testing' stamp: ''!
understandsImageFormat
	self readHeader.
	bfType = 19778 "BM" ifFalse:[^false].
	biSize = 40 ifFalse:[^false].
	biPlanes = 1 ifFalse:[^false].
	biCompression = 0 ifFalse:[^false].
	^true! !

!BMPReadWriter methodsFor: 'reading' stamp: ''!
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 class methodsFor: 'testing' stamp: ''!
readAllFrom: fd
	"MessageTally spyOn:[BMPReadWriter readAllFrom: FileDirectory default]"
	fd fileNames do:[:fName|
		(fName endsWith: '.bmp') ifTrue:[
			[Form fromBinaryStream: (fd readOnlyFileNamed: fName)] on: Error do:[:nix].
		].
	].
	fd directoryNames do:[:fdName|
		self readAllFrom: (fd / fdName)
	].! !

!BMPReadWriter class methodsFor: 'testing' stamp: ''!
displayAllFrom: fd
	"BMPReadWriter displayAllFrom: FileDirectory default"
	fd fileNames do:[:fName|
		(fName endsWith: '.bmp') ifTrue:[
			[(Form fromBinaryStream: (fd readOnlyFileNamed: fName)) display ] on: Error do:[:nix|].
		].
	].
	fd directoryNames do:[:fdName|
		self displayAllFrom: (fd / fdName)
	].! !

!BMPReadWriter class methodsFor: 'image reading/writing' stamp: ''!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('bmp')! !

!BMPReadWriterTest commentStamp: ''!
SUnit tests for class BMPReadWriter!
!BMPReadWriterTest methodsFor: 'data' stamp: ''!
bmpData4bit
	"Created via:
		'bmptest4.bmp' asFileReference binaryReadStream upToEnd base64Encoded.
	"
	^ '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=' base64Decoded! !

!BMPReadWriterTest methodsFor: 'data' stamp: ''!
bmpData32bit
	"Created via:
		'bmptest32b.bmp'asFileReference binaryReadStream upToEnd base64Encoded 
	"
	^ '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' base64Decoded! !

!BMPReadWriterTest methodsFor: 'tests - reading' stamp: ''!
testBmp8Bit
	| reader form |
	reader := BMPReadWriter new on: self bmpData8bit readStream.
	form := reader nextImage.
	self assert: (form colorAt: 1 @ 1) equals: Color black.
	self assert: (form colorAt: 7 @ 1) equals: Color red.
	self assert: (form colorAt: 1 @ 7) equals: Color green.
	self assert: (form colorAt: 7 @ 7) equals: Color blue.
	self assert: (form colorAt: 4 @ 4) equals: Color white! !

!BMPReadWriterTest methodsFor: 'tests - reading' stamp: ''!
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) equals: Color red.
	self assert: (form colorAt: 1 @ 7) equals: Color green.
	self assert: (form colorAt: 7 @ 7) equals: Color blue.
	self assert: (form colorAt: 4 @ 4) equals: Color white.
	self assert: (form pixelValueAt: 1 @ 1) equals: 32768! !

!BMPReadWriterTest methodsFor: 'tests - reading' stamp: ''!
testBmp32Bit
	| reader form |
	reader := BMPReadWriter new on: self bmpData32bit readStream.
	form := reader nextImage.
	self assert: (form colorAt: 7 @ 1) equals: Color red.
	self assert: (form colorAt: 1 @ 7) equals: Color green.
	self assert: (form colorAt: 7 @ 7) equals: Color blue.
	self assert: (form colorAt: 4 @ 4) equals: Color white.
	self assert: (form pixelValueAt: 1 @ 1) equals: 4278190080! !

!BMPReadWriterTest methodsFor: 'tests - reading' stamp: ''!
testBmp24Bit
	| reader form |
	reader := BMPReadWriter new on: (ReadStream on: self bmpData24bit).
	form := reader nextImage.
	self assert: (form colorAt: 7 @ 1) equals: Color red.
	self assert: (form colorAt: 1 @ 7) equals: Color green.
	self assert: (form colorAt: 7 @ 7) equals: Color blue.
	self assert: (form colorAt: 4 @ 4) equals: Color white.
	self assert: (form pixelValueAt: 1 @ 1) equals: 16rFF000001! !

!BMPReadWriterTest methodsFor: 'data' stamp: ''!
bmpData8bit
	"Created via:
		 'bmptest8.bmp' asFileReference binaryReadStream upToEnd base64Encoded 
	"
	^ '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=' base64Decoded! !

!BMPReadWriterTest methodsFor: 'data' stamp: ''!
bmpDataR5G6B5
	"This is a BMP file based on BitmapV4Header which is currently unsupported."
	"Created via:
		 'bmptest16-R5G6B5.bmp' asFileReference binaryReadStream upToEnd base64Encoded 
	"
	^ 'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA
APgAAOAHAAAfAAAAAAAAAOAH4AfgB+AHHwAfAB8AHwDgB+AH4AfgBx8AHwAfAB8A4AfgB///
////////HwAfAOAH4Af//////////x8AHwAAAAAA//////////8A+AD4AAAAAP//////////
APgA+AAAAAAAAAAAAPgA+AD4APgAAAAAAAAAAAD4APgA+AD4AAA=' base64Decoded! !

!BMPReadWriterTest methodsFor: 'tests - reading' stamp: ''!
testBmp4Bit
	| reader form |
	reader := BMPReadWriter new on: self bmpData4bit readStream.
	form := reader nextImage.
	self assert: (form colorAt: 1 @ 1) equals: Color black.
	self assert: (form colorAt: 7 @ 1) equals: Color red.
	self assert: (form colorAt: 1 @ 7) equals: Color green.
	self assert: (form colorAt: 7 @ 7) equals: Color blue.
	self assert: (form colorAt: 4 @ 4) equals: Color white! !

!BMPReadWriterTest methodsFor: 'data' stamp: ''!
bmpDataX4R4G4B4
	"This is a BMP file based on BitmapV4Header which is currently unsupported."
	"Created via:
		'bmptest16-X4R4G4B4.bmp' asFileReference binaryReadStream upToEnd base64Encoded 
	"
	^ 'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA
AA8AAPAAAAAPAAAAAAAAAPAA8ADwAPAADwAPAA8ADwDwAPAA8ADwAA8ADwAPAA8A8ADwAP8P
/w//D/8PDwAPAPAA8AD/D/8P/w//Dw8ADwAAAAAA/w//D/8P/w8ADwAPAAAAAP8P/w//D/8P
AA8ADwAAAAAAAAAAAA8ADwAPAA8AAAAAAAAAAAAPAA8ADwAPAAA=' base64Decoded! !

!BMPReadWriterTest methodsFor: 'data' stamp: ''!
bmpDataX8R8G8B8
	"This is a BMP file based on BitmapV4Header which is currently unsupported."
	"Created via:
		'bmptest32-X8R8G8B8.bmp' asFileReference binaryReadStream upToEnd base64Encoded 
	"
	^ '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==' base64Decoded! !

!BMPReadWriterTest methodsFor: 'data' stamp: ''!
bmpData24bit
	"Created via:
		 'bmptest24.bmp' asFileReference binaryReadStream upToEnd base64Encoded 
	"
	^ '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/' base64Decoded! !

!BMPReadWriterTest methodsFor: 'data' stamp: ''!
bmpData16bit
	"Created via:
		'bmptest16b.bmp' asFileReference binaryReadStream upToEnd base64Encoded 
	"
	^ 'Qk24AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABAAAAAAAIIAAADDDgAAww4AAAAAAAAAAAAA
4APgA+AD4AMfAB8AHwAfAOAD4APgA+ADHwAfAB8AHwDgA+AD/3//f/9//38fAB8A4APgA/9/
/3//f/9/HwAfAAAAAAD/f/9//3//fwB8AHwAAAAA/3//f/9//38AfAB8AAAAAAAAAAAAfAB8
AHwAfAAAAAAAAAAAAHwAfAB8AHwAAA==' base64Decoded! !

!BadEqualer commentStamp: ''!
I am an object that doesn't always report #= correctly.  Used for testing the EqualityTester.!
!BadEqualer methodsFor: 'comparing' stamp: ''!
= other 
	self class = other class
		ifFalse: [^ false].
	^ 100 atRandom < 30 ! !

!BadHasher commentStamp: ''!
I am an object that doesn't always hash correctly.  I am used for testing the HashTester.!
!BadHasher methodsFor: 'comparing' stamp: ''!
hash
	"Answer with a different hash some of the time"

	self class randomValue! !

!BadHasher class methodsFor: 'accessing' stamp: ''!
randomValue

	"For every call return different value. Not really random but we do not want to create
	dependency on random number generators."

	| randomNumbers |
	
	randomNumbers := #(2 2 1 2 2 1 2 2 2 2 1 2 1 2 2 2 2 2 1 2). 

	lastRandomIndex ifNil: [ lastRandomIndex := randomNumbers size ].
	
	lastRandomIndex := lastRandomIndex + 1.	
	lastRandomIndex > randomNumbers size 
		ifTrue: [ lastRandomIndex := 1 ].
	
	^ randomNumbers at: lastRandomIndex.! !

!Bag commentStamp: ''!
I represent an unordered collection of possibly duplicate elements.
	
I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.!
!Bag methodsFor: 'math functions' stamp: ''!
sum
	"Return the sum (+) of the elements held in the receiver."
	"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)."
	
	"#(1 2 2 3 1 1 1) sum >>> 11"
	
	| 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: 'enumerating' stamp: ''!
associationsDo: aBlock
	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations).  Provided for compatibility with Dictionaries"

	contents associationsDo: aBlock! !

!Bag methodsFor: 'comparing' stamp: ''!
= 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: 'adding' stamp: ''!
add: newObject 
	"Include newObject as one of the receiver's elements. Answer newObject."

	^ self add: newObject withOccurrences: 1! !

!Bag methodsFor: 'testing' stamp: ''!
includes: anObject 
	"Answer whether anObject is one of the receiver's elements."

	"(#(1 2 2 3 1 1 1) includes: 5) >>> false"
	"(#(1 2 2 3 1 1 1) includes: 1) >>> true"
	
	^ contents includesKey: anObject! !

!Bag methodsFor: 'testing' stamp: ''!
occurrencesOf: anObject 
	"Answer how many of the receiver's elements are equal to anObject."
	
	"(#(1 2 2 3 1 1 1) asBag occurrencesOf: 1) >>> 4"
	
	^ (self includes: anObject)
		ifTrue: [ contents at: anObject]
		ifFalse: [ 0 ]! !

!Bag methodsFor: 'enumerating' stamp: ''!
doWithOccurrences: aTwoArgBlock 
    "Iterate over the receiver and apply a two argument block on the element and its occurrences."
        
    contents associationsDo: [:assoc | aTwoArgBlock value: assoc key value: assoc value ]! !

!Bag methodsFor: 'accessing' stamp: ''!
sortedElements
	"Answer with a collection of elements with counts, sorted by element."
	
	"#(1 2 2 3 1 1 1) asBag sortedElements >>> {1->4. 2->2. 3->1}"
	
	^contents associations
 		sort;
 		yourself! !

!Bag methodsFor: 'converting' stamp: ''!
asBag
	^ self! !

!Bag methodsFor: 'converting' stamp: ''!
asSet
	"Answer a set with the elements of the receiver."
	"#(1 2 2 3 1 1 1) asBag asSet >>> #(1 2 2 3 1 1 1) asSet"
	
	^ contents keys asSet! !

!Bag methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	contents := contents copy! !

!Bag methodsFor: '*Random-Core' stamp: ''!
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."

	| index |
 	self emptyCheck.
 	index := aGenerator nextInteger: self size.
 	"overwritten to use a faster enumeration"
 	self doWithOccurrences: [ :key :count | 
 		(index := index - count) <= 0 ifTrue: [ ^key ] ]! !

!Bag methodsFor: 'accessing' stamp: ''!
valuesAndCounts

	^ contents! !

!Bag methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionItems: aBuilder
	<inspectorPresentationOrder: 0 title: 'Items'> 

	^ aBuilder newTable		
		addColumn: (SpStringTableColumn new 
			title: 'Items';
			evaluated: [ :each | StObjectPrinter asTruncatedTextFrom: each key ];
			beNotExpandable;
			yourself);
		addColumn: (SpStringTableColumn new  
			title: 'Occurences'; 
			evaluated: [ :each | StObjectPrinter asTruncatedTextFrom: (self occurrencesOf: each key) ];
			yourself);
		items: contents associations;
		yourself! !

!Bag methodsFor: 'accessing' stamp: ''!
cumulativeCounts
	"Answer with a collection of cumulative percents covered by elements so far."
	
	"#(1 2 2 3 1 1 1) asBag cumulativeCounts >>> {57.1->1 . 85.7->2 . 100.0->3}"
	
	| 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: 'removing' stamp: ''!
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: 'accessing' stamp: ''!
size
	"Answer how many elements the receiver contains."

	"#(1 2 2 3 1 1 1) asBag size >>> 7"
	
	| tally |
	tally := 0.
	contents do: [:each | tally := tally + each].
	^ tally! !

!Bag methodsFor: 'private' stamp: ''!
setContents: aDictionary
	contents := aDictionary! !

!Bag methodsFor: 'enumerating' stamp: ''!
do: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument."

	contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! !

!Bag methodsFor: 'enumerating' stamp: ''!
keysAndValuesDo: aTwoArgBlock 
    "Iterate over the receiver and apply a two argument block on the element and its occurrences."
     
    contents associationsDo: [:assoc | aTwoArgBlock value: assoc key value: assoc value ]! !

!Bag methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"Use a map with element-occurrences pairs as representation"

	stonWriter 
		writeObject: self 
		do: [ stonWriter encodeMap: contents ]! !

!Bag methodsFor: 'accessing' stamp: ''!
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: 'adding' stamp: ''!
add: newObject withOccurrences: anInteger 
	"Add newObject anInteger times to the receiver. Answer newObject."

	contents at: newObject put: (contents at: newObject ifAbsent: [0]) + anInteger.
	^ newObject! !

!Bag methodsFor: 'removing' stamp: ''!
remove: oldObject ifAbsent: exceptionBlock 
	"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."

	| count |
	count := contents at: oldObject ifAbsent: [^ exceptionBlock value].
	count = 1
		ifTrue: [contents removeKey: oldObject]
		ifFalse: [contents at: oldObject put: count - 1].
	^ oldObject! !

!Bag class methodsFor: 'instance creation' stamp: ''!
new
	^ self new: 4! !

!Bag class methodsFor: 'instance creation' stamp: ''!
new: nElements
	^ super new setContents: (self contentsClass new: nElements)! !

!Bag class methodsFor: 'instance creation' stamp: ''!
contentsClass
	^Dictionary! !

!Bag class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Read a map representation containing element/occurrences pairs"
	
	| bag |
	bag := self new.
	stonReader parseMapDo: [ :key :value |
		bag add: key withOccurrences: value ].
	^ bag! !

!Bag class methodsFor: 'instance creation' stamp: ''!
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
"! !

!BagTest commentStamp: ''!
SUnit tests for bags!
!BagTest methodsFor: 'setup' stamp: ''!
collection

	^ nonEmpty.! !

!BagTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne)! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!BagTest methodsFor: 'setup' stamp: ''!
sizeCollection
	^ otherCollectionWithoutEqualElements! !

!BagTest methodsFor: 'basic tests' stamp: ''!
testAddWithOccurrences
	| aBag |
	aBag := Bag new.
	aBag add: 'a' withOccurrences: 3.
	self assert: aBag size equals: 3! !

!BagTest methodsFor: 'tests' stamp: ''!
testCreation
	| bag |
	bag := Bag new.
	self assert: bag size equals: 0.
	self assertEmpty: bag! !

!BagTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!BagTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithElementAlreadyIn

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	oldSize := collection size.
	anElement := self element.
	self assert: (collection includes: anElement).
	
	added := collection addIfNotPresent: anElement.
	
	self assert: added == anElement .	"test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: oldSize! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!BagTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!BagTest methodsFor: 'basic tests' stamp: ''!
testAsBag
	| aBag |
	aBag := Bag new.

	self assert: aBag asBag equals: aBag! !

!BagTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString tmp |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	tmp := self nonEmpty collect: [:each | each asString].
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	tmp do:[:each |
		self assert: (tmp occurrencesOf: each) = (allElementsAsString occurrencesOf: each)].
	self assert: ((allElementsAsString at: (allElementsAsString size - 1))=('and'))! !

!BagTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllSuchThat

	| 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 - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!BagTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!BagTest methodsFor: 'requirements' stamp: ''!
elementsCopyNonIdenticalWithoutEqualElements
	" return a collection that does niot incllude equal elements ( classic equality )
	all elements included are elements for which copy is not identical to the element  "
	^ collectionOfString! !

!BagTest methodsFor: 'tests - adding' stamp: ''!
testTAddWithOccurrences
	| 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 equals: (oldSize + 5)! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!BagTest methodsFor: 'tests - copy' stamp: ''!
testCopySameClass
	"A copy of a collection should always be of the same class as the instance it copies"
	
	| copy | 
	copy := self empty copy.
	self assert: copy class == self empty class! !

!BagTest methodsFor: 'requirements' stamp: ''!
otherCollection
	^ otherCollectionWithoutEqualElements! !

!BagTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!BagTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementReallyRemovesElement
 
	| size |
	size := self nonEmptyWithoutEqualElements size.
	self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne.
	self assert: size - 1 = self nonEmptyWithoutEqualElements size! !

!BagTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter
	
	| result allElementsAsString tmp |
	
	result := String streamContents: [ :aStream |
		tmp := OrderedCollection new.
		self nonEmpty do: [:each | tmp add: each asString].
		self nonEmpty printOn: aStream delimiter: ', ' ].
	
	allElementsAsString := (result findBetweenSubstrings: ', ').
	
	1 to: allElementsAsString size do:
		[:i | 
		self assert: (tmp occurrencesOf:(allElementsAsString at:i)) equals: (allElementsAsString  occurrencesOf:(allElementsAsString at:i)) ].! !

!BagTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!BagTest methodsFor: 'tests - adding' stamp: ''!
testTAddAll

	| added collection toBeAdded |
	collection := self collectionWithElement.
	toBeAdded := self otherCollection.
	added := collection addAll: toBeAdded.
	self assert: added == toBeAdded .	"test for identiy because #addAll: has not reason to copy its parameter."
	self assert: (collection includesAll: toBeAdded )! !

!BagTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
	^ collectionNotIn! !

!BagTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!BagTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printElementsOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	1 to: allElementsAsString size do:
		[:i | 
		self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString  occurrencesOf:(allElementsAsString at:i)).
			].! !

!BagTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithDuplicate


| collection1 collection2 result |
collection1 := self firstCollection .
collection2 := self firstCollection .
result := collection1 , collection2.

result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ].
self assert: result size = (collection1 size * 2)! !

!BagTest methodsFor: 'basic tests' stamp: ''!
testAdd

	| aBag |
	aBag := Bag new.
	aBag add: 'a'.
	aBag add: 'b'.
	
	self assert: aBag size equals: 2.
	aBag add: 'a'.
	self assert: aBag size equals: 3.
	self assert: (aBag occurrencesOf: 'a') equals: 2! !

!BagTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!BagTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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 - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty
	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringOne
	
	self nonEmpty1Element do: 
		[:each | 
		self assert: each asString =self nonEmpty1Element  asCommaString.
		self assert: each asString=self nonEmpty1Element  asCommaStringAnd.].! !

!BagTest methodsFor: 'tests - copying' stamp: ''!
elementToAdd
	^ 42! !

!BagTest methodsFor: 'requirements' stamp: ''!
collectionWithCharacters
	^ collectionWithCharacters .! !

!BagTest methodsFor: 'tests - copy' stamp: ''!
testCopyNonEmptyWithoutAllNotIncluded! !

!BagTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	^ elementNotIn! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRequirementsOfTAddTest

	self collectionWithElement.
	self otherCollection.
	self element.
	self assert: (self collectionWithElement includes: self element).
	self deny: (self otherCollection includes: self element)! !

!BagTest methodsFor: 'tests - includes' stamp: ''!
anotherElementNotIn
	^ 42! !

!BagTest methodsFor: 'basic tests' stamp: ''!
testAsSet
	| aBag aSet |
	aBag := Bag new.
	aBag add: 'a' withOccurrences: 4.
	aBag add: 'b' withOccurrences: 2.
	aSet := aBag asSet.
	self assert: aSet size equals: 2.
	self assert: (aSet occurrencesOf: 'a') equals: 1! !

!BagTest methodsFor: 'basic tests' stamp: ''!
testAsDictionary
	| aBag aDictonary |
	aBag := Bag new.
	aBag add: 'a' withOccurrences: 4.
	aBag add: 'b' withOccurrences: 2.
	aDictonary := aBag asDictionary.
	self assert: aDictonary size equals: 2.
	self assert: (aBag as: Dictionary) equals: aDictonary.
	self assert: (aDictonary at: 'a') equals: 4.
	self assert: aBag asDictionary equals: aBag valuesAndCounts.
	self deny: aBag asDictionary identicalTo: aBag valuesAndCounts! !

!BagTest methodsFor: 'tests - remove' stamp: ''!
testRemoveIfAbsent
	| res |
	res := self nonEmptyWithoutEqualElements remove: self elementNotIn ifAbsent: [ 33 ].
	self assert: res equals: 33! !

!BagTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!BagTest methodsFor: 'tests' stamp: ''!
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 equals: 3.
	self assert: cumulativeCounts first equals: (50 -> '1').
	self assert: cumulativeCounts second equals: (90 -> '2').
	self assert: cumulativeCounts third equals: (100 -> '3')! !

!BagTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''!
testOccurrencesOfForMultipliness

	| collection elem |
	collection := self collectionWithEqualElements.
	elem := self elementTwiceInForOccurrences.

	self assert: (collection occurrencesOf: elem ) equals: 2.! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!BagTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!BagTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExistsTwice
	| size |
	size := self nonEmpty size.
	self assert: (self nonEmpty includes: self elementTwiceIn).
	self nonEmpty remove: self elementTwiceIn.
	self assert: size - 1 equals: self nonEmpty size! !

!BagTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
collectionClass
	"Return the class to be used to create instances of the class tested"
	
	^ Bag! !

!BagTest methodsFor: 'requirements' stamp: ''!
integerCollectionWithoutEqualElements
	^ otherCollectionWithoutEqualElements! !

!BagTest methodsFor: 'requirements' stamp: ''!
elementInForOccurrences
" return an element included in nonEmpty"
	^self nonEmpty anyOne.! !

!BagTest methodsFor: 'requirements' stamp: ''!
collectionWithElement
	"Returns a collection that already includes what is returned by #element."
	^ collectionWithElement! !

!BagTest methodsFor: 'tests - creation' stamp: ''!
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 ) equals: (collection occurrencesOf: element1).
	self assert: (aCol occurrencesOf: element2 ) equals: (collection occurrencesOf: element2)! !

!BagTest methodsFor: 'tests' stamp: ''!
testEqual
	| bag1 bag2 |
	bag1 := Bag new.
	bag2 := Bag new.
	self assert: bag1 equals: bag2.
	bag1
		add: #a;
		add: #b.
	bag2
		add: #a;
		add: #a.
	self deny: bag1 equals: bag2.
	self assert: bag1 equals: bag1.
	bag1 add: #a.
	bag2 add: #b.
	self assert: bag1 equals: bag2.
	bag1 add: #c.
	self deny: bag1 equals: bag2.
	bag2 add: #c.
	self assert: bag1 equals: bag2! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!BagTest methodsFor: 'tests - adding' stamp: ''!
testTAdd
	| added collection |
	collection := self otherCollection.
	added := collection add: self element.
	
	self assert: added == self element.	"test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection includes: self element)	.
	self assert: (self collectionWithElement includes: self element).! !

!BagTest methodsFor: 'setup' stamp: ''!
emptyButAllocatedWith20 
	
		^ emptyButAllocatedWith20! !

!BagTest methodsFor: 'tests' stamp: ''!
testFlatCollect
	| bag |
	bag := Bag new.
	bag add: {1 . 2 . 3}.
	bag add: {4 . 5 . 6}.

	self assert: (bag flatCollect: [ :x | x ]) equals: #(1 2 3 4 5 6) asBag.
	self assert: (bag flatCollect: [ :x | x ]) class identicalTo: Bag.
	self assertEmpty: (#() asBag flatCollect: [ :x | 1 to: 4 ])! !

!BagTest methodsFor: 'tests - includes' stamp: ''!
elementNotInForOccurrences
	^ 666! !

!BagTest methodsFor: 'tests - iterate' stamp: ''!
doWithoutNumber

	^ 4! !

!BagTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!BagTest methodsFor: 'tests - converting' stamp: ''!
testAsByteArray

	| res |
	self integerCollectionWithoutEqualElements.
	self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ].
	res := true.
	self integerCollectionWithoutEqualElements
		detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! !

!BagTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!BagTest methodsFor: 'running' stamp: ''!
setUp
	super 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: 'a';
		add: 'b';
		add: 'c';
		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: 'requirements' stamp: ''!
elementNotIn

	^elementNotIn! !

!BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringMore

	| result resultAnd allElementsAsString tmp |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
	tmp :=OrderedCollection new. 
	self nonEmpty do: [ :each | tmp add: each asString].

	"verifying result  :"
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString do:
		[:each |
		self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each).
		].
	
	"verifying esultAnd :"
	allElementsAsString:=(resultAnd findBetweenSubstrings: ', ' ).
	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 - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTRemoveTest
	| duplicate |
	self empty.
	self nonEmptyWithoutEqualElements.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	duplicate := true.
	self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ].
	self assert: duplicate = false.
	self elementNotIn.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! !

!BagTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result := self firstCollection , self empty.
	self assert: result = self firstCollection! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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 - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!BagTest methodsFor: 'tests - creation' stamp: ''!
testWithAll

	| aCol collection |
	collection := self collectionMoreThan5Elements asOrderedCollection.
	aCol := self collectionClass withAll: collection.
	
	collection do: [ :each | self assert: (aCol occurrencesOf: each ) equals: ( collection occurrencesOf: each ) ].
	
	self assert: aCol size equals: collection size! !

!BagTest methodsFor: 'tests - creation' stamp: ''!
testWith
	
	| aCol anElement |
	anElement := self collectionMoreThan5Elements anyOne.
	aCol := self collectionClass with: anElement.
	self assert: (aCol includes: anElement).! !

!BagTest methodsFor: 'requirements' stamp: ''!
collectionWithCopyNonIdentical
	" return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)"
	^ collectionOfString! !

!BagTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result:=''.
	aStream:= ReadWriteStream on: result.
	self nonEmpty printNameOn: aStream.
	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ]
		ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!BagTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
" return a collection elements that can be sorte ( understanding message ' < '  or ' > ')"
	^ nonEmpty! !

!BagTest methodsFor: 'tests' stamp: ''!
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 equals: 0.
	self assert: c2 size = s2 description: 'the copy has not been modified'! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertAsSetForMultiplinessTest
	"a collection  with equal elements:"

	| res |
	self withEqualElements.
	res := true.
	self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res = true! !

!BagTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation

"| collection1 collection2 result |
collection1 := self firstCollection .
collection2 := self secondCollection .
result := collection1 , collection2.

collection1 do:[ :each | self assert: (result includes: each)].
collection2 do:[ :each | self assert: (result includes: each)]."

| collection1 collection2 result |
collection1 := self firstCollection .
collection2 := self secondCollection .
result := collection1 , collection2.

result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ].
self assert: result size = (collection1 size + collection2 size)! !

!BagTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!BagTest methodsFor: 'requirements' stamp: ''!
collectionInForIncluding
	 ^ collectionIn! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!BagTest methodsFor: 'tests' stamp: ''!
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 equals: 3.
	
	self assert: sortedElements first equals: ('1'->10).
	self assert: sortedElements second equals: ('2'->1).
	self assert: sortedElements third equals: ('3'->5)! !

!BagTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!BagTest methodsFor: 'requirements' stamp: ''!
firstCollection
" return a collection that will be the first part of the concatenation"
	^ nonEmpty! !

!BagTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExists
 
	| el res |
	el := self nonEmptyWithoutEqualElements anyOne.
	res := self nonEmptyWithoutEqualElements remove: el.
	self assert: res == el! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!BagTest methodsFor: 'tests - as set tests' stamp: ''!
testAsIdentitySetWithEqualsElements
	| result collection |
	collection := self withEqualElements .
	result := collection asIdentitySet.
	collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = IdentitySet.! !

!BagTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithNewElement

	| added oldSize collection elem |
	collection := self otherCollection.
	oldSize := collection size.
	elem := self element.
	self deny: (collection includes: elem ).
	
	added := collection  addIfNotPresent: elem .
	self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: (oldSize + 1).! !

!BagTest methodsFor: 'tests - copy' stamp: ''!
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 - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!BagTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!BagTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
	^ collectionIn! !

!BagTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllError
	| el aSubCollection |
	el := self elementNotIn.
	aSubCollection := self nonEmptyWithoutEqualElements copyWith: el.
	self should: [ self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! !

!BagTest methodsFor: 'tests' stamp: ''!
testRemove
	| bag item |
	item := 'test item'.
	bag := Bag new.

	bag add: item.
	self assert: bag size equals: 1.
	bag remove: item.
	self assertEmpty: bag.

	bag add: item withOccurrences: 2.
	bag remove: item.
	bag remove: item.
	self assert: bag size equals: 0.

	self should: [ bag remove: item ] raise: Error! !

!BagTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan5Elements
" return a collection including at least 5 elements"
	
	^ collectionWithoutNilMoreThan5! !

!BagTest methodsFor: 'basic tests' stamp: ''!
testCopy
	
	| aBag newBag |
	aBag := Bag new.
	aBag add:'a' withOccurrences: 4.
	aBag add:'b' withOccurrences: 2.
	newBag := aBag copy.
	self assert: newBag equals: newBag.
	self assert: newBag asSet size equals: 2! !

!BagTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn
	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	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 - fixture' stamp: ''!
test0FixtureIncludeWithIdentityTest

	| anElement |
	self collectionWithCopyNonIdentical.
	anElement := self collectionWithCopyNonIdentical anyOne.
	self deny: anElement == anElement copy! !

!BagTest methodsFor: 'requirements' stamp: ''!
elementTwiceIn
	^ super elementTwiceIn! !

!BagTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!BagTest methodsFor: 'requirements' stamp: ''!
selectedNumber
	^ 4! !

!BagTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self collection anyOne! !

!BagTest methodsFor: 'requirements' stamp: ''!
secondCollection
" return a collection that will be the second part of the concatenation"
	^ collectionWithCharacters! !

!BagTest methodsFor: 'setup' stamp: ''!
nonEmpty

	^ nonEmpty! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	difference := self collectionWithoutEqualElements difference: self empty.
	self assert: difference size = self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each) ]! !

!BagTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithoutEqualElements
" return a collection without equal elements "
	^ otherCollectionWithoutEqualElements! !

!BagTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllFoundIn
	| el aSubCollection |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn.
	self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection.
	self assert: self nonEmptyWithoutEqualElements size = 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! !

!BagTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
collectionWithoutNilElements
	" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	^ collectionWithoutNilMoreThan5! !

!BagTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ' ).
	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 - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''.! !

!BagTest methodsFor: 'tests - adding' stamp: ''!
testTAddTwice

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	anElement := self element.
	oldSize := collection size.
	added := collection 
		add: anElement;
		add: anElement.
	self assert: added == anElement.	"test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection includes: anElement).
	self assert: collection size equals: (oldSize + 2)! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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 - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result allElementsAsString tmp |
	
	
	delim := ', '.
	result:=''.
	tmp:= self nonEmpty collect:[:each | each asString].
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	allElementsAsString := (result findBetweenSubstrings: delim ).
	tmp do:
		[:each |
		self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each).
		].! !

!BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty
	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!BagTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Bag! !

!BagTest methodsFor: 'requirements' stamp: ''!
collectionOfFloat
	^ collectionOfString! !

!BagTest methodsFor: 'tests - iterating' stamp: ''!
testAnySastify

	self assert: ( self collection anySatisfy: [:each | each = self element]).
	self deny: (self collection anySatisfy: [:each | each isString]).! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!BagTest methodsFor: 'tests - iterate' stamp: ''!
expectedSizeAfterReject
	^ 2! !

!BagTest methodsFor: 'setup' stamp: ''!
result

	^ collectResult.! !

!BagTest methodsFor: 'setup' stamp: ''!
empty

	^ empty! !

!BagTest methodsFor: 'requirements' stamp: ''!
element
	^ super element! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |
	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream  do:
		[:each1 |
		self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ]
		 ].! !

!BagTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty

	| result |
	result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne).
	self assert: result equals: 0! !

!BagTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	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 - fixture' stamp: ''!
test0FixtureCreationWithTest

	self collectionMoreThan5Elements.
	self assert: self collectionMoreThan5Elements size >= 5! !

!BagTest methodsFor: 'requirements' stamp: ''!
elementInForIncludesTest

	^ self element! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConcatenationTest
	self firstCollection.
	self denyEmpty: self firstCollection.
	self firstCollection.
	self denyEmpty: self firstCollection.
	self empty.
	self assertEmpty: self empty! !

!BagTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementFromEmpty
	 
	self 
		should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ]
		raise: Error! !

!BagTest methodsFor: 'requirements' stamp: ''!
withEqualElements
	" return a collection  including equal elements (classic equality)"
	^ nonEmpty .! !

!BagTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!BagTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
collectionWithEqualElements
	^ nonEmpty! !

!BagTest methodsFor: 'requirements' stamp: ''!
elementTwiceInForOccurrences
" return an element included exactly two time in # collectionWithEqualElements"
^ self elementTwiceIn! !

!BagTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!BagTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element

	^ self speciesClass  new add: self element ;yourself.! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!BagTest methodsFor: 'tests - copy' stamp: ''!
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: 'basic tests' stamp: ''!
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') equals: 3.
	self assert: (aBag occurrencesOf: 'b') equals: 4.
	self assert: (aBag occurrencesOf: 'c') equals: 0.
	self assert: (aBag occurrencesOf: nil) equals: 0.
	aBag add: nil.
	self assert: (aBag occurrencesOf: nil) equals: 1.! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesForMultiplinessTest
	| cpt |
	self collectionWithEqualElements.
	self collectionWithEqualElements.
	self elementTwiceInForOccurrences.
	self elementTwiceInForOccurrences.
	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' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!BagTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!BagTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!BagTest methodsFor: 'requirements' stamp: ''!
speciesClass
	
	^ Bag! !

!BagTest methodsFor: 'tests - includes' stamp: ''!
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' stamp: ''!
testIdentityIncludes
	" test the comportement in presence of elements 'includes' but not 'identityIncludes' "

	" can not be used by collections that can't include elements for wich copy doesn't return another instance "

	| collection anElement |
	self collectionWithCopyNonIdentical.
	collection := self collectionWithCopyNonIdentical.
	anElement := collection anyOne copy.	"self assert: (collection includes: element)."
	self deny: (collection identityIncludes: anElement)! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest
	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!BagTest methodsFor: 'tests' stamp: ''!
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 equals: 3.
	
	self assert: sortedCounts first equals: (10->'1').
	self assert: sortedCounts second equals: (5->'3').
	self assert: sortedCounts third equals: (1->'2')! !

!BagTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!BagTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	 
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!BagTest methodsFor: 'tests - as set tests' stamp: ''!
testAsSetWithEqualsElements
	| result |
	result := self withEqualElements asSet.
	self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = Set! !

!BagTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!BagTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
	^ otherCollectionWithoutEqualElements! !

!BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |

	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream  do:
		[:each1 |
		self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ]
		 ].! !

!BalloonBuffer commentStamp: ''!
BalloonBuffer is a repository for primitive data used by the BalloonEngine.!
!BalloonBuffer methodsFor: 'accessing' stamp: ''!
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: ''!
floatAt: index put: value
	"For simulation only"
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	value isFloat 
		ifTrue:[self basicAt: index put: value asIEEE32BitWord]
		ifFalse:[self at: index put: value asFloat].
	^value! !

!BalloonBuffer methodsFor: 'accessing' stamp: ''!
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: ''!
floatAt: index
	"For simulation only"
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!BalloonBuffer class methodsFor: 'instance creation' stamp: ''!
new
	^self new: 256.! !

!BalloonEdgeData commentStamp: ''!
BalloonEdgeData defines an entry in the internal edge table of the Balloon engine.

Instance Variables:
	index	<Integer>	The index into the external objects array of the associated graphics engine
	xValue	<Integer>	The computed x-value of the requested operation
	yValue	<Integer>	The y-value for the requested operation
	height	<Integer>	The (remaining) height of the edge
	source	<Object>		The object from the external objects array!
!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
xValue: anInteger
	xValue := anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
lines: anInteger
	^lines := anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
zValue
	^zValue! !

!BalloonEdgeData methodsFor: 'computing' stamp: ''!
stepToFirstScanLine
	source stepToFirstScanLineAt: yValue in: self! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
xValue
	^xValue! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
source
	^source! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
yValue
	^yValue! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
yValue: anInteger
	yValue := anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
zValue: anInteger
	zValue := anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
index: anInteger
	index := anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
lines
	^lines! !

!BalloonEdgeData methodsFor: 'computing' stamp: ''!
stepToNextScanLine
	source stepToNextScanLineAt: yValue in: self! !

!BalloonEdgeData methodsFor: 'accessing' stamp: ''!
index
	^index! !

!BalloonEngine commentStamp: ''!
BalloonEngine is the representative for the Balloon engine inside Squeak. For most purposes it should not be used directly but via BalloonCanvas since this ensures proper initialization and is polymorphic with other canvas uses.!
!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primFlushNeeded: aBoolean
	<primitive: 'primitiveNeedsFlushPut' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'drawing' stamp: ''!
registerFill: aFillStyle
	"Register the given fill style."
	| theForm |
	aFillStyle ifNil:[^0].
	aFillStyle isSolidFill 
		ifTrue:[^aFillStyle scaledPixelValue32].

	aFillStyle isGradientFill ifTrue:[
		^self primAddGradientFill: aFillStyle pixelRamp
			from: aFillStyle origin
			along: aFillStyle direction
			normal: aFillStyle normal
			radial: aFillStyle isRadialFill
		].
	aFillStyle isBitmapFill ifTrue:[
		theForm := aFillStyle form asSourceForm.
		theForm unhibernate.
		forms := forms copyWith: theForm.
		^self primAddBitmapFill: theForm
				colormap: (theForm colormapIfNeededForDepth: 32)
				tile: aFillStyle isTiled
				from: aFillStyle origin
				along: aFillStyle direction
				normal: aFillStyle normal
				xIndex: forms size].
	^0! !

!BalloonEngine methodsFor: 'primitives - adding' stamp: ''!
primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex
	<primitive: 'primitiveAddBitmapFill' module: 'B2DPlugin'>
	(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 - access' stamp: ''!
primGetCounts: statsArray
	<primitive: 'primitiveGetCounts' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - incremental' stamp: ''!
primRenderImage: edge with: fill
	"Start/Proceed rendering the current scan line"
	<primitive: 'primitiveRenderImage' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - adding' stamp: ''!
primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	<primitive: 'primitiveAddBezierShape' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primGetFailureReason
	<primitive: 'primitiveGetFailureReason' module: 'B2DPlugin'>
	^0! !

!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primSetColorTransform: transform
	<primitive: 'primitiveSetColorTransform' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'drawing' stamp: ''!
registerFills: fills

	| fillIndexList index fillIndex |
	((colorTransform notNil and:[colorTransform isAlphaTransform]) or:[
		fills anySatisfy: [:any| any notNil and:[any isTranslucent]]])
			ifTrue:[	self flush.
					self reset.
					postFlushNeeded := true].
	fillIndexList := WordArray new: fills size.
	index := 1.
	[index <= fills size] whileTrue:[
		fillIndex := self registerFill: (fills at: index).
		fillIndex == nil 
			ifTrue:[index := 1] "Need to start over"
			ifFalse:[fillIndexList at: index put: fillIndex.
					index := index+1]
	].
	^fillIndexList! !

!BalloonEngine methodsFor: 'primitives - incremental' stamp: ''!
primRenderScanline: edge with: fill
	"Start/Proceed rendering the current scan line"
	<primitive: 'primitiveRenderScanline' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - misc' stamp: ''!
primCopyBufferFrom: oldBuffer to: newBuffer
	"Copy the contents of oldBuffer into the (larger) newBuffer"
	<primitive: 'primitiveCopyBuffer' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
aaLevel
	^aaLevel ifNil:[1]! !

!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primSetDepth: depth
	<primitive: 'primitiveSetDepth' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - incremental' stamp: ''!
primChangeActiveEdgeTableEntryFrom: edgeEntry
	"Change the entry in the active edge table from edgeEntry"
	<primitive: 'primitiveChangedActiveEdgeEntry' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primSetAALevel: level
	"Set the AA level"
	<primitive: 'primitiveSetAALevel' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
bitBlt
	^bitBlt! !

!BalloonEngine methodsFor: 'drawing' stamp: ''!
registerFill: fill1 and: fill2
	^self registerFills: (Array with: fill1 with: fill2)! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
aaLevel: anInteger
	aaLevel := (anInteger min: 4) max: 1.! !

!BalloonEngine methodsFor: 'copying' stamp: ''!
copyBits
	(bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate].
	self copyLoopFaster.! !

!BalloonEngine methodsFor: 'initialization' stamp: ''!
initialize
	| w |
	super initialize.
	w := Display width > 2048 ifTrue: [ 4096 ] ifFalse: [ 2048 ].
	externals := OrderedCollection new: 100.
	span := Bitmap new: w.
	self
		bitBlt:
			((BitBlt toForm: Display)
				destRect: Display boundingBox;
				yourself).
	forms := #().
	deferred := false! !

!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primGetBezierStats: statsArray
	<primitive: 'primitiveGetBezierStats' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - adding' stamp: ''!
primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	<primitive: 'primitiveAddOval' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primGetTimes: statsArray
	<primitive: 'primitiveGetTimes' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - incremental' stamp: ''!
primMergeFill: fillBitmap from: fill
	"Merge the filled bitmap into the current output buffer."
	<primitive: 'primitiveMergeFillFrom' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'initialize' stamp: ''!
resetIfNeeded
	workBuffer ifNil:[self reset].
	self primSetEdgeTransform: edgeTransform.
	self primSetColorTransform: colorTransform.
	self primSetDepth: self primGetDepth + 1.
	postFlushNeeded := false.! !

!BalloonEngine methodsFor: 'copying' stamp: ''!
copyLoopFaster
	"This is a copy loop drawing one scan line at a time"
	| edge fill reason |
	edge := BalloonEdgeData new.
	fill := BalloonFillData new.
	[self primFinishedProcessing] whileFalse:[
		reason := self primRenderScanline: edge with: fill.
		"reason ~= 0 means there has been a problem"
		reason = 0 ifFalse:[
			self processStopReason: reason edge: edge fill: fill.
		].
	].
	self primGetTimes: Times.
	self primGetCounts: Counts.
	self primGetBezierStats: BezierStats.! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
bitBlt: aBitBlt
	bitBlt := aBitBlt.
	bitBlt ifNil: [^self].
	self class primitiveSetBitBltPlugin: bitBlt getPluginName.
	self clipRect: bitBlt clipRect.
	bitBlt 
		sourceForm: (Form extent: span size @ 1 depth: 32 bits: span);
		sourceRect: (0@0 extent: 1@span size);
		colorMap: (Color colorMapIfNeededFrom: 32 to: bitBlt destForm depth);
		combinationRule: (bitBlt destForm depth >= 8 ifTrue:[34] ifFalse:[Form paint]).! !

!BalloonEngine methodsFor: 'primitives - adding' stamp: ''!
primAddGradientFill: colorRamp from: origin along: direction normal: normal radial: isRadial
	<primitive: 'primitiveAddGradientFill' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddGradientFill: colorRamp 
				from: origin 
				along: direction 
				normal: normal 
				radial: isRadial
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'copying' stamp: ''!
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: 'accessing' stamp: ''!
deferred: aBoolean
	deferred := aBoolean.! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
destOffset: aPoint
	destOffset := aPoint asIntegerPoint.
	bitBlt destX: aPoint x; destY: aPoint y.! !

!BalloonEngine methodsFor: 'primitives - misc' stamp: ''!
primInitializeBuffer: buffer
	<primitive: 'primitiveInitializeBuffer' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
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: 'drawing' stamp: ''!
drawRectangle: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix

	| fills |
	self edgeTransform: aMatrix.
	self resetIfNeeded.
	fills := self registerFill: fillStyle and: borderColor.
	self primAddRectFrom: rect origin 
			to: rect corner
			fillIndex: (fills at: 1)
			borderWidth: borderWidth
			borderColor: (fills at: 2).
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'primitives - adding' stamp: ''!
primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	<primitive: 'primitiveAddRect' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
destOffset
	^destOffset! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
colorTransform: aColorTransform
	colorTransform := aColorTransform! !

!BalloonEngine methodsFor: 'initialize' stamp: ''!
postFlushIfNeeded
	"Force all pending primitives onscreen"
	workBuffer ifNil:[^self].
	(deferred not or:[postFlushNeeded]) ifTrue:[
		self copyBits.
		self release].! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
edgeTransform: aTransform
	edgeTransform := aTransform.! !

!BalloonEngine methodsFor: 'initialize' stamp: ''!
flush
	"Force all pending primitives onscreen"
	workBuffer ifNil:[^self].
	self copyBits.
	self release.! !

!BalloonEngine methodsFor: 'initialization' stamp: ''!
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: 'accessing' stamp: ''!
deferred
	^deferred! !

!BalloonEngine methodsFor: 'drawing' stamp: ''!
drawPolygon: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform
	| fills |
	self edgeTransform: aTransform.
	self resetIfNeeded.
	fills := self registerFill: fillStyle and: borderFill.
	self
		primAddPolygon: points
		segments: points size
		fill: (fills at: 1)
		lineWidth: borderWidth
		lineFill: (fills at: 2).
	self postFlushIfNeeded! !

!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primGetDepth
	<primitive: 'primitiveGetDepth' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primSetClipRect: rect
	<primitive: 'primitiveSetClipRect' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primSetOffset: point
	<primitive: 'primitiveSetOffset' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
clipRect
	^clipRect! !

!BalloonEngine methodsFor: 'primitives - incremental' stamp: ''!
primAddActiveEdgeTableEntryFrom: edgeEntry
	"Add edge entry to the AET."
	<primitive: 'primitiveAddActiveEdgeEntry' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddActiveEdgeTableEntryFrom: edgeEntry
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - incremental' stamp: ''!
primFinishedProcessing
	"Return true if there are no more entries in AET and GET and the last scan line has been displayed"
	<primitive: 'primitiveFinishedProcessing' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'drawing' stamp: ''!
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: 'copying' stamp: ''!
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: 'accessing' stamp: ''!
edgeTransform
	^edgeTransform! !

!BalloonEngine methodsFor: 'copying' stamp: ''!
processStopReason: reason edge: edge fill: fill
	"The engine has stopped because of some reason.
	Try to figure out how to respond and do the necessary actions."
	"Note: The order of operations below can affect the speed"

	"Process unknown fills first"
	reason = GErrorFillEntry ifTrue:[
		fill source: (externals at: fill index).
		"Compute the new fill"
		fill computeFill.
		"And mix it in the out buffer"
		^self primMergeFill: fill destForm bits from: fill].

	"Process unknown steppings in the AET second"
	reason = GErrorAETEntry ifTrue:[
		edge source: (externals at: edge index).
		edge stepToNextScanLine.
		^self primChangeActiveEdgeTableEntryFrom: edge].

	"Process unknown entries in the GET third"
	reason = GErrorGETEntry ifTrue:[
		edge source: (externals at: edge index).
		edge stepToFirstScanLine.
		^self primAddActiveEdgeTableEntryFrom: edge].

	"Process generic problems last"
	(self canProceedAfter: reason) ifTrue:[^self]. "Okay."

	^self error:'Unkown stop reason in graphics engine'! !

!BalloonEngine methodsFor: 'primitives - adding' stamp: ''!
primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	<primitive: 'primitiveAddPolygon' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives - access' stamp: ''!
primSetEdgeTransform: transform
	<primitive: 'primitiveSetEdgeTransform' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'initialize' stamp: ''!
release
	self class recycleBuffer: workBuffer.
	workBuffer := nil.
	self releaseActionMap. "we are not sure if we need it"
	super release.! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
clipRect: aRect
	clipRect := aRect truncated! !

!BalloonEngine methodsFor: 'accessing' stamp: ''!
colorTransform
	^colorTransform! !

!BalloonEngine class methodsFor: 'private' stamp: ''!
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: 'class initialization' stamp: ''!
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: ''!
recycleBuffer: balloonBuffer
	"Try to keep the buffer for later drawing operations."

	CacheProtect critical:[ | buffer |
		buffer := BufferCache at: 1.
		(buffer isNil or:[buffer size < balloonBuffer size] )
			ifTrue:[BufferCache at: 1 put: balloonBuffer].
	].! !

!BalloonEngine class methodsFor: 'profiling' stamp: ''!
printStat: time count: n string: aString on: aStream
	aStream
		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: 'debugging' stamp: ''!
debug: aBoolean
	<script: 'BalloonEngine debug: (UIManager default confirm: ''Debug BalloonEngine?'')'>

	Debug := aBoolean! !

!BalloonEngine class methodsFor: 'profiling' stamp: ''!
resetStats
	<script>
	Times := WordArray new: 10.
	Counts := WordArray new: 10.! !

!BalloonEngine class methodsFor: 'profiling' stamp: ''!
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"
	<primitive: 'primitiveDoProfileStats' module: 'B2DPlugin'>
	^false! !

!BalloonEngine class methodsFor: 'private' stamp: ''!
primitiveSetBitBltPlugin: pluginName
	<primitive: 'primitiveSetBitBltPlugin' module: 'B2DPlugin'>
	^nil! !

!BalloonEngine class methodsFor: 'profiling' stamp: ''!
resetBezierStats
	<script>
	BezierStats := WordArray new: 4.! !

!BalloonEngine class methodsFor: 'profiling' stamp: ''!
printStats
	<script:
		'
	BalloonEngine doProfileStats: true.
	BalloonEngine printStats.
	BalloonEngine resetStats'>
	| string |
	string := String
		streamContents: [ :aStream | 
			aStream
				cr;
				nextPutAll: '/************** BalloonEngine statistics ****************/'.
			self
				printStat: (Times at: 1)
				count: (Counts at: 1)
				string: 'Initialization'
				on: aStream.
			self
				printStat: (Times at: 2)
				count: (Counts at: 2)
				string: 'Finish test'
				on: aStream.
			self
				printStat: (Times at: 3)
				count: (Counts at: 3)
				string: 'Fetching/Adding GET entries'
				on: aStream.
			self
				printStat: (Times at: 4)
				count: (Counts at: 4)
				string: 'Adding AET entries'
				on: aStream.
			self
				printStat: (Times at: 5)
				count: (Counts at: 5)
				string: 'Fetching/Computing fills'
				on: aStream.
			self
				printStat: (Times at: 6)
				count: (Counts at: 6)
				string: 'Merging fills'
				on: aStream.
			self
				printStat: (Times at: 7)
				count: (Counts at: 7)
				string: 'Displaying span buffer'
				on: aStream.
			self
				printStat: (Times at: 8)
				count: (Counts at: 8)
				string: 'Fetching/Updating AET entries'
				on: aStream.
			self
				printStat: (Times at: 9)
				count: (Counts at: 9)
				string: 'Changing AET entries'
				on: aStream.
			aStream
				cr;
				print: Times sum;
				nextPutAll: ' mSecs for all operations'.
			aStream
				cr;
				print: Counts sum;
				nextPutAll: ' overall operations' ].
	self trace: string! !

!BalloonEngine class methodsFor: 'profiling' stamp: ''!
printBezierStats
	<script>
	self
		trace:
			(String
				streamContents: [ :stream | 
					stream
						cr;
						nextPutAll: 'Bezier statistics:';
						cr;
						tab;
						print: (BezierStats at: 1);
						tab;
						nextPutAll: ' non-monoton curves splitted';
						cr;
						tab;
						print: (BezierStats at: 2);
						tab;
						nextPutAll: ' curves splitted for numerical accuracy';
						cr;
						tab;
						print: (BezierStats at: 3);
						tab;
						nextPutAll: ' curves splitted to avoid integer overflow';
						cr;
						tab;
						print: (BezierStats at: 4);
						tab;
						nextPutAll: ' curves internally converted to lines' ])! !

!BalloonEngineConstants commentStamp: ''!
Constants for the baloon engine!
!BalloonEngineConstants class methodsFor: 'class initialization' stamp: ''!
initialize

	self 
		initStateConstants;
		initWorkBufferConstants;
		initPrimitiveConstants;
		initEdgeConstants;
		initFillConstants;
		initializeInstVarNames: BalloonEngine prefixedBy: 'BE';
		initializeInstVarNames: BalloonEdgeData prefixedBy: 'ET';
		initializeInstVarNames: BalloonFillData prefixedBy: 'FT'! !

!BalloonEngineConstants class methodsFor: 'private - initialization' stamp: ''!
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: 'private - initialization' stamp: ''!
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: 'private - initialization' stamp: ''!
initializeInstVarNames: aClass prefixedBy: aString

	| token |
	aClass instVarNames doWithIndex:[:instVarName :index| | value aToken |
		aToken := (aString, instVarName first asUppercase asString, (instVarName copyFrom: 2 to: instVarName size),'Index') asSymbol.
		value := index - 1.
		(self bindingOf: aToken) ifNil:[ self addClassVarNamed: aToken ].
		(self bindingOf: aToken) value: value.
	].
	token := (aString, aClass name,'Size') asSymbol.
	(self bindingOf: token) ifNil: [ self addClassVarNamed: token ].
	(self bindingOf: token) value: aClass instSize! !

!BalloonEngineConstants class methodsFor: 'private - initialization' stamp: ''!
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: 'private - initialization' stamp: ''!
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: 'private - initialization' stamp: ''!
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"! !

!BalloonFillData commentStamp: ''!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!
!BalloonFillData methodsFor: 'computing' stamp: ''!
computeFill
	(destForm isNil or:[destForm width < self width]) ifTrue:[
		destForm := Form extent: (self width + 10) @ 1 depth: 32.
	].
	source computeFillFrom: minX to: maxX at: yValue in: destForm! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
destForm
	^destForm! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
maxX
	^maxX! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
width
	^maxX - minX! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
destForm: aForm
	destForm := aForm! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
minX
	^minX! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
source
	^source! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
yValue
	^yValue! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
yValue: anInteger
	yValue := anInteger! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
maxX: anInteger
	maxX := anInteger! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
index: anInteger
	index := anInteger! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
minX: anInteger
	minX := anInteger! !

!BalloonFillData methodsFor: 'accessing' stamp: ''!
index
	^index! !

!BalloonMorph commentStamp: ''!
A balloon with text used for the display of explanatory information.

Balloon help is integrated into Morphic as follows:
If a Morph has the property #balloonText, then it will respond to #showBalloon by adding a text balloon to the world, and to #deleteBalloon by removing the balloon.

Moreover, if mouseOverEnabled is true (see class msg), then the Hand will arrange to cause display of the balloon after the mouse has lingered over the morph for a while, and removal of the balloon when the mouse leaves the bounds of that morph.  In any case, the Hand will attempt to remove any such balloons before handling mouseDown events, or displaying other balloons.

Balloons should not be duplicated with veryDeepCopy unless their target is also duplicated at the same time.!
!BalloonMorph methodsFor: 'accessing' stamp: ''!
balloonOwner

	^ balloonOwner! !

!BalloonMorph methodsFor: 'accessing' stamp: ''!
balloonColor: aColor

	balloonColor := aColor.
	self color: aColor! !

!BalloonMorph methodsFor: 'accessing' stamp: ''!
balloonColor

	^ balloonColor! !

!BalloonMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the state of the receiver"
	
	balloonColor := self class balloonColor.
	super initialize.
	self beSmoothCurve.
	offsetFromTarget := 0@0! !

!BalloonMorph methodsFor: 'stepping' stamp: ''!
step
	"Move with target."

	target ifNotNil: [ self position: target position + offsetFromTarget ]! !

!BalloonMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	"Answer the default border width for the receiver"
	
	^ 1! !

!BalloonMorph methodsFor: 'private' stamp: ''!
setTarget: aMorph

	(target := aMorph) ifNotNil: [ 
		offsetFromTarget := self position - target position ]! !

!BalloonMorph methodsFor: 'menus' stamp: ''!
adjustedCenter
	"Return the center of the original textMorph box within the balloon."

	^ (self vertices last: 4) average rounded! !

!BalloonMorph methodsFor: 'initialization' stamp: ''!
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: 'initialization' stamp: ''!
defaultBorderColor
	"Answer the default border color/fill style for the receiver"

	^ self defaultColor muchDarker! !

!BalloonMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"Answer the default color/fill style for the receiver"
	
	^ self balloonColor! !

!BalloonMorph methodsFor: 'wiw support' stamp: ''!
morphicLayerNumber
	"Helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front. Balloons are very front-like things"

	^ 5! !

!BalloonMorph methodsFor: 'initialization' stamp: ''!
popUpFor: aMorph hand: aHand
	"Pop up the receiver as balloon help for the given hand"
	
	balloonOwner := aMorph.
	self popUpForHand: aHand! !

!BalloonMorph methodsFor: 'stepping' stamp: ''!
stepTime

	^ 0 "every cycle"! !

!BalloonMorph class methodsFor: 'private' stamp: ''!
defaultBalloonColor

	^ (Color fromArray: #(0.85 0.9 1.0 )) twiceLighter alpha: 0.95! !

!BalloonMorph class methodsFor: 'utilities' stamp: ''!
setBalloonColorTo: aColor

	aColor ifNotNil: [ BalloonColor := aColor ]! !

!BalloonMorph class methodsFor: 'private' stamp: ''!
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: 'utilities' stamp: ''!
balloonFont: aFont
	StandardFonts balloonFont: aFont! !

!BalloonMorph class methodsFor: 'utilities' stamp: ''!
balloonColor
	^ BalloonColor ifNil: [BalloonColor := self defaultBalloonColor]! !

!BalloonMorph class methodsFor: 'class initialization' stamp: ''!
initialize 
 
	self setBalloonColorTo: self defaultBalloonColor.
	self balloonFont: StandardFonts defaultFont! !

!BalloonMorph class methodsFor: 'private' stamp: ''!
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; color: UITheme current balloonTextColor].
	m setToAdhereToEdge: #adjustedCenter.
	^ m! !

!BalloonMorph class methodsFor: 'instance creation' stamp: ''!
string: str for: morph

	^ self string: str for: morph corner: #bottomLeft! !

!BalloonMorph class methodsFor: 'instance creation' stamp: ''!
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;
		  yourself! !

!BalloonMorph class methodsFor: 'private' stamp: ''!
getVertices: bounds
	"Construct vertices for a balloon up and to left of anchor"

	| corners |
	corners := bounds corners atAll: #(1 4 3 2).
	^ (Array
		with: corners first + (0 - bounds width // 2 @ 0)
		with: corners first + (0 - bounds width // 4 @ (bounds height // 2))) , corners! !

!BalloonMorph class methodsFor: 'utilities' stamp: ''!
balloonFont
	^ StandardFonts balloonFont! !

!Base64MimeConverter commentStamp: ''!
This class encodes and decodes data in Base64 format.  This is MIME encoding.  We translate a whole stream at once, taking a Stream as input and giving one as output.  Returns a whole stream for the caller to use.
           0 A            17 R            34 i            51 z
           1 B            18 S            35 j            52 0
           2 C            19 T            36 k            53 1
           3 D            20 U            37 l            54 2
           4 E            21 V            38 m            55 3
           5 F            22 W            39 n            56 4
           6 G            23 X            40 o            57 5
           7 H            24 Y            41 p            58 6
           8 I            25 Z            42 q            59 7
           9 J            26 a            43 r            60 8
          10 K            27 b            44 s            61 9
          11 L            28 c            45 t            62 +
          12 M            29 d            46 u            63 /
          13 N            30 e            47 v
          14 O            31 f            48 w         (pad) =
          15 P            32 g            49 x
          16 Q            33 h            50 y
Outbound: bytes are broken into 6 bit chunks, and the 0-63 value is converted to a character.  3 data bytes go into 4 characters.
Inbound: Characters are translated in to 0-63 values and shifted into 8 bit bytes.

(See: N. Borenstein, Bellcore, N. Freed, Innosoft, Network Working Group, Request for Comments: RFC 1521, September 1993, MIME (Multipurpose Internet Mail Extensions) Part One: Mechanisms for Specifying and Describing the Format of Internet Message Bodies. Sec 6.2)

By Ted Kaehler, based on Tim Olson's Base64Filter.!
!Base64MimeConverter methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
		
	multiLine := true.! !

!Base64MimeConverter methodsFor: 'converting' stamp: ''!
mimeEncode

	| phase1 phase2 raw nib lineLength data |
	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: 252) 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: 1008) bitShift:  -4.
		mimeStream nextPut: (ToCharTable at: nib + 1).
		(raw := dataStream next) ifNil: [ 
			raw := 0.
			phase2 := true ].
		data := ((data bitAnd: 15) bitShift: 8) + raw asInteger.
		nib := (data bitAnd: 4032) bitShift:  -6.
		mimeStream nextPut: (ToCharTable at: nib + 1).
		nib := data bitAnd: 63.
		mimeStream nextPut: (ToCharTable at: nib + 1).
		lineLength := lineLength + 4 ].
	phase1 ifTrue: [ 
		mimeStream
			skip:  -2;
			nextPut: $=;
			nextPut: $=.
		^ mimeStream ].
	phase2 ifFalse: [ ^ self ].
	mimeStream
		skip: -1;
		nextPut: $=.
	^ mimeStream! !

!Base64MimeConverter methodsFor: 'accessing' stamp: ''!
multiLine
	^ multiLine! !

!Base64MimeConverter methodsFor: 'converting' stamp: ''!
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: 'accessing' stamp: ''!
multiLine: anObject
	multiLine := anObject! !

!Base64MimeConverter methodsFor: 'converting' stamp: ''!
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: 'converting' stamp: ''!
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 class methodsFor: 'encoding' stamp: ''!
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! !

!Base64MimeConverter class methodsFor: 'class initialization' stamp: ''!
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: 'encoding' stamp: ''!
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! !

!Base64MimeConverter class methodsFor: 'encoding' stamp: ''!
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: 'encoding' stamp: ''!
decodeInteger: mimeString

	"Decode the MIME string into an integer of any length"

	| bytes sum |

	bytes := mimeString base64Decoded.
	sum := 0.
	bytes reverseDo: [ :by | sum := sum * 256 + by ].
	^ sum! !

!Base64MimeConverter class methodsFor: 'encoding' stamp: ''!
encodeInteger: int
	| strm |
	"Encode an integer of any length and return the MIME string"

	strm := ReadWriteStream on: (ByteArray new: int bytesCount).
	1 to: int bytesCount do: [:ii | strm nextPut: (int byteAt: ii)].
	strm reset.
	^ ((self mimeEncode: strm) contents) copyUpTo: $=	"remove padding"! !

!Base64MimeConverterTest commentStamp: ''!
This is the unit test for the class Base64MimeConverter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- there is a chapter in the PharoByExample book (http://pharobyexample.org/)
	- the sunit class category!
!Base64MimeConverterTest methodsFor: 'tests' stamp: ''!
testBase64Encoded
	
	| encoded |
	encoded := (Base64MimeConverter mimeEncode: message) contents.
	self assert: encoded equals: 'Hi There!!' asByteArray base64Encoded! !

!Base64MimeConverterTest methodsFor: 'tests' stamp: ''!
testDecodeMimeHeader
	"Test MIME decoding from single-byte encoding to Unicode"

	| mimeHeader expected bytes |
	bytes := #[ 16rBE 16rFD 16r5F 16rE1 16r2E 16rC8 ].
	mimeHeader := '=?ISO-8859-2?Q?=BE=FD=5F=E1=2E=C8?=' decodeMimeHeader.

	expected := bytes decodeWith: 'ISO-8859-2'.

	self assert: mimeHeader equals: expected! !

!Base64MimeConverterTest methodsFor: 'tests' stamp: ''!
testMimeEncodeDecode

	| encoded |
	encoded := Base64MimeConverter mimeEncode: message.
	self assert: encoded contents equals: 'SGkgVGhlcmUh'.
	self
		assert: (Base64MimeConverter mimeDecodeToChars: encoded) contents
		equals: message contents.

	"Encoding should proceed from the current stream position."
	message reset.
	message skip: 2.
	encoded := Base64MimeConverter mimeEncode: message.
	self assert: encoded contents equals: 'IFRoZXJlIQ=='! !

!Base64MimeConverterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	message := 'Hi There!!' readStream! !

!Base64Test commentStamp: ''!
Test for user level Base64 access!
!Base64Test methodsFor: 'tests' stamp: ''!
testHelloWorldEncoding
	| bytes base64Encoded |
	bytes := 'Hello World!!' utf8Encoded.
	base64Encoded := bytes base64Encoded.
	self assert: base64Encoded base64Decoded equals: bytes.
	self assert: base64Encoded base64Decoded utf8Decoded equals: 'Hello World!!'! !

!Base64Test methodsFor: 'tests' stamp: ''!
testWikipediaExampleQuote
	"https://en.wikipedia.org/wiki/Base64#Examples"
	
	| in out outAsOneLine |
	in := 'Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure.'.
	out := 'TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz
IHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg
dGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu
dWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo
ZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4='.
	outAsOneLine := '' join: out lines.
	self assert: (ZnNullEncoder new encodeString: in) base64Encoded equals: outAsOneLine.
	self assert: in asByteArray base64Encoded equals: outAsOneLine.
	self assert: (ZnNullEncoder new decodeBytes: out base64Decoded) equals: in.
	self assert: out base64Decoded asString equals: in! !

!Base64Test methodsFor: 'tests' stamp: ''!
testPrimesEncoding
	| bytes base64Encoded |
	bytes := (Integer primesUpTo: 255) asByteArray.
	base64Encoded := bytes base64Encoded.
	self assert: base64Encoded base64Decoded equals: bytes! !

!Base64Test methodsFor: 'tests' stamp: ''!
testRangeEncoding
	| bytes base64Encoded |
	bytes := (0 to: 255) asByteArray.
	base64Encoded := bytes base64Encoded.
	self assert: base64Encoded base64Decoded equals: bytes! !

!BaseSlot commentStamp: ''!
I am a hidden non-virtual slot that the virtual slots BooleanSlot and PropertySlot store into.

They, when a class is created containing it, makes sure that there is one slot of me defined. When the last virtual slot is removed, I am removed.!
!BaseSlot methodsFor: 'comparing' stamp: ''!
= other
	^ super = other and: [default = other default]! !

!BaseSlot methodsFor: 'comparing' stamp: ''!
hash
	^super hash bitXor: default hash! !

!BaseSlot methodsFor: 'meta-object-protocol' stamp: ''!
wantsInitialization
	"we need to call the initialize to set the default value for the base slot"
	^true! !

!BaseSlot methodsFor: 'initalize' stamp: ''!
default
	^ default! !

!BaseSlot methodsFor: 'initalize' stamp: ''!
default: anObject
	default := anObject! !

!BaseSlot methodsFor: 'testing' stamp: ''!
isVisible
	^ false! !

!BaseSlot methodsFor: 'initalize' stamp: ''!
initialize: anObject
	self write: default copy to: anObject! !

!BaselineOf commentStamp: ''!
You should use a *baseline* when you are using a disk-based source
code manager (SCM) like [git][1].

When using a disk-based SCM it is not necessary to use the Metacello
*version* method, because it is intended for use with `.mcz` files. 

With a disk-based SCM you only need a single `baseline:` method. When
you change the structure of your project you can change the baseline and
save everything in a single commit. So multiple `baseline:` methods are
no longer needed.

You may still need a *configuration* when using a *baseline*. The
[Sample project][3] on GitHub has a good example of a configuration used
in conjunction with a *baseline*. See the [**ConfigurationOf** class comment][2] 
for information on creating a *configuration*.

To create a new Metacello baseline:

1. Create a subclass of the **BaselineOf** class. The baseline
   class for your project should be named by appending the name of
   your project to the string `BaselineOf`. The name of the category and
   package should be the same as the name of the class:

    ```Smalltalk
    BaselineOf subclass: #BaselineOfExample
      instanceVariableNames: ''
      classVariableNames: ''
      poolDictionaries: ''
      category: 'BaselineOfExample'
    ```

2. Create a **baseline:** method where you specify the structure of your project:

    ```Smalltalk
    baseline: spec
      <baseline>

      spec for: #common do: [
        spec
          package: 'Example-Core';
          package: 'Example-Tests' with: [
            spec requires: 'Example-Core' ]].
    ```

3. Create a Monticello package for your **BaselineOf** class and save it in the repository where your packages are stored.

4. To load a package from GitHub that contains a baseline evaluate the following:

```Smalltalk
| repositorySpec |
"edit to match your username, repository name and branch"
repositorySpec := 'dalehenrich/metacello-work:master'.
Metacello new
  baseline: 'Sample';
  repository: 'github://', repositorySpec;
  load.
```

For further documentation see For more information on the [github://](MetacelloScriptingAPI.md#github) url specifigation see the [Metacello Scripting API
reference](MetacelloScriptingAPI.md). There more information on [working with GitHub here](GettingStartedWithGitHub.md).

[1]: http://git-scm.com/
[2]: https://github.com/dalehenrich/metacello-work/blob/master/repository/Metacello-Base.package/ConfigurationOf.class/README.md
[3]: https://github.com/dalehenrich/sample/tree/configuration/ConfigurationOfSample.package/ConfigurationOfSample.class
!
!BaselineOf methodsFor: '*Metacello-PharoExtensions' stamp: ''!
packageRepository

	" Tries to determine a repository from which the baseline is being loaded. Useful for 
	refering other baselines in the same repository. "
	
	^ (self class package mcWorkingCopy repositoryGroup repositories reject: [:each | each = MCCacheRepository uniqueInstance]) 
		ifNotEmpty: [ :repositories | repositories anyOne ]
		ifEmpty: [ nil ]! !

!BaselineOf methodsFor: 'accessing' stamp: ''!
versionNumberClass
    ^ MetacelloVersionNumber! !

!BaselineOf methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCBaselineProject! !

!BaselineOf methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionRecord
	<inspectorPresentationOrder: 20 title: 'Record'>
	| specs |
	
	specs := self project version record spec packageSpecsInLoadOrder.
	^ SpTablePresenter new
		addColumn: (SpStringTableColumn 
			title: 'Type' 
			evaluated: [ :aSpec | aSpec type ]) 
			beNotExpandable;
		addColumn: (SpStringTableColumn 
			title: 'Name' 
			evaluated: [ :aSpec | aSpec name ]);
		items: (specs sorted: #type ascending, #name ascending);
		yourself! !

!BaselineOf methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	"subclasses should redefine me"
	
	"Here is a typical package and its tests
	spec for: #'common' do: [
		spec 
			package: #'XXX-Core';
			package: #'XXX-Core-Tests' with: [
				spec requires: #('XXX-Core' ) ].
		spec 
			group: 'Core' with: #('XXX-Core' );
			group: 'CoreTests' with: #('XXX-Core' 'XXX-Core-Tests');
			group: 'default' with: #('Beacon-XXX' 'Beacon-XXX-Tests') ]
	"! !

!BaselineOf methodsFor: '*Metacello-PharoExtensions' stamp: ''!
packageRepositoryURL

	" Tries to determine a repository URL from which the baseline is being loaded. Useful for 
	refering other baselines in the same repository. "

	^ self packageRepository
		ifNotNil: [ :aRepository | aRepository description ]
		ifNil: [ '' ]! !

!BaselineOf methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionProject
	<inspectorPresentationOrder: 10 title: 'Project'>
	| specs |
	
	specs := self project version spec packageSpecsInLoadOrder.
	^ SpTablePresenter new
		addColumn: (SpStringTableColumn 
			title: 'Type' 
			evaluated: [ :aSpec | aSpec type ]) 
			beNotExpandable;
		addColumn: (SpStringTableColumn 
			title: 'Name' 
			evaluated: [ :aSpec | aSpec name ]);
		items: (specs sorted: #type ascending, #name ascending);
		yourself! !

!BaselineOf class methodsFor: '*Metacello-PharoExtensions' stamp: ''!
packagesOfGroupNamed: aName

	^ (self version groups detect: [ :g | g name = aName ]) includes! !

!BaselineOf class methodsFor: '*Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	aBuilder
		header: [ aBuilder text: self name ] withLevel: 1;
		horizontalLine;
		text: 'A baseline is a kind of map to load project.';
		newLine;
		header: [ aBuilder text: 'Description' ] withLevel: 3;
		text: aString;
		newLine;
		header: [ aBuilder text: 'Dependencies' ] withLevel: 3.

	(self instanceSide includesLocalSelector: #baseline:) 
		ifTrue: [ aBuilder 
						codeblockTag: 'pharo'
						withBody: (self instanceSide sourceCodeAt: #baseline:) ]! !

!BaselineOf class methodsFor: 'accessing' stamp: ''!
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"

  <apiDocumentation>
  self ensureMetacello.
  ^ ((self environment at: #'MetacelloToolBox')
    validateBaseline: self
    debug: #()
    recurse: false) inspect! !

!BaselineOf class methodsFor: '*Metacello-PharoExtensions' stamp: ''!
allPackageNames
	
	^ self version packages collect: [:each | each name]! !

!BaselineOf class methodsFor: '*Metacello-PharoExtensions' stamp: ''!
version
	
	^ self project version! !

!BaselineOf class methodsFor: '*Metacello-PharoExtensions' stamp: ''!
deepPackagesOfGroupNamed: aName
	"Traverses the group tree to collect packages"
	| allGroups projects group |

	allGroups := self version groups.
	projects := Array streamContents: [ :stream |
		self version spec
			specListProjectDo: [ :each | stream nextPut: each ] 
			packageDo: [ :each | ] 
			groupDo: [  :each | ] ].
	group := allGroups detect: [ :eachGroup | eachGroup name = aName ].
	^ (group includes
		collect: [ :each | 
			(allGroups anySatisfy: [ :eachGroup | eachGroup name = each ])
				ifTrue: [ self deepPackagesOfGroupNamed: each ]
				ifFalse: [
					(projects noneSatisfy: [ :eachProject | eachProject name = each ]) 
						ifTrue: [ { each } ]
						ifFalse: [ #() ] ] ])
		flattened! !

!BaselineOfAthens commentStamp: ''!
Baseline managing the Athens project for the Pharo bootstrap.

Load type: 
- linear!
!BaselineOfAthens methodsFor: 'accessing' stamp: ''!
repository
	^ self packageRepositoryURL! !

!BaselineOfAthens methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	spec
		for: #common
		do: [ 
			"Inter packages dependencies are now added but it is missing some dependencies on other projects such as Morphic for Athens-Morphic"
			"Dependencies"
			self
				display: spec;
				unifiedFFI: spec.

			"Packages"
			spec
				package: 'Athens-Core' with: [ spec requires: 'Display' ];
				package: 'Athens-Core-Tests' with: [ spec requires: 'Athens-Core' ];
				package: 'Athens-Text' with: [ spec requires: 'Athens-Core' ];
				package: 'Athens-Balloon' with: [ spec requires: #('Athens-Core' 'Athens-Text') ];
				package: 'Athens-Morphic' with: [ spec requires: #('Athens-Core' 'Athens-Text' 'Athens-Balloon' 'Athens-Cairo') ];
				package: 'Athens-Cairo' with: [ spec requires: #('Athens-Core' 'UnifiedFFI') ];
				package: 'Athens-Examples' with: [ spec requires: #('Athens-Morphic' 'Athens-Text' 'Athens-Balloon' 'Athens-Cairo') ];
				package: 'Athens-Cairo-Tests' with: [ spec requires: 'Athens-Cairo' ].

			"Groups"
			spec
				group: 'Core' with: #('Cairo-core' 'Athens-Text' 'Athens-Balloon' 'Athens-Morphic');
				group: 'Cairo-core' with: #('Athens-Core' 'Athens-Cairo');
				group: 'Examples' with: #('Athens-Examples');
				group: 'Tests' with: #('Athens-Cairo-Tests') ]! !

!BaselineOfAthens methodsFor: 'baseline' stamp: ''!
display: spec
	spec baseline: 'Display' with: [ spec repository: self repository ]! !

!BaselineOfAthens methodsFor: 'baseline' stamp: ''!
unifiedFFI: spec
	spec
		baseline: 'UnifiedFFI'
		with: [ spec
				loads: 'minimal';
				repository: self repository ]! !

!BaselineOfBaseLibraries methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	| repository |

	repository := self packageRepositoryURL.

	spec for: #common do: [ 

		spec baseline: 'SUnitCore' with: [ 
			spec 
				loads: 'Core';
				className: 'BaselineOfSUnit';
				repository: repository ].
		spec baseline: 'ParametrizedTests' with: [ spec repository: repository ].

		spec baseline: 'Slot' with: [ 
			spec
				loads: 'core';
				repository: repository ].

		spec baseline: 'Beacon' with: [ 
			spec
				loads: #('CoreTests');
				repository: repository ].

		spec baseline: 'Clap' with: [ 
			spec
				loads: #('core'); 
				repository: repository ].

		spec baseline: 'TaskIt' with: [ 
			spec 
				loads: #('coreTests');
				repository: repository ].
			
		spec baseline: 'ExternalProjectLoader' 
			with: [ spec repository: repository  ] ]! !

!BaselineOfBasicTools commentStamp: ''!
This baseline is used to generate Pharo images from the local clone of pharo-project/pharo repository. 

Depends on:
- BaselineOfUI

Load type: 
- atomic

Installs:
- SUnit UI
- Nautilus
- NECompletion
- ProcessBrowsers
- profillers
- different Metacello repositories
- Monticello GUI
- ProfStef
- Athens
..and some other packages!
!BaselineOfBasicTools methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	| repository |
	repository := self packageRepositoryURL.
	spec for: #common do: [ 
		spec postLoadDoIt: #postload:package:.

		"Load first SUnit core"
		spec baseline: 'SUnitCore' with: [ 
			spec
				loads: 'Core';
				className: 'BaselineOfSUnit';
				repository: repository ].
		spec
			baseline: 'UI' with: [ spec repository: repository ];
			baseline: 'Reflectivity' with: [ spec repository: repository ];
			baseline: 'Athens' with: [ 
				spec
					loads: 'Cairo-core';
					repository: repository ];
			baseline: 'SUnit' with: [ 
			spec
				loads: #( 'UI' 'Help' 'JenkinsSupport' );
				repository: repository ].
		spec package: 'Tool-ExternalBrowser'.
		spec 
			baseline: 'EnlumineurFormatter' with: [ 
				spec
					loads: 'Core';
					repository: repository ].
		
		spec package: 'Tool-ProcessBrowser'.
		spec package: 'Tool-Profilers'.
		spec package: 'NECompletion'.
		spec package: 'NECompletion-Morphic'.
		spec package: 'NECompletion-Preferences'.
		spec package: 'Announcements-Help'.
		spec package: 'Metacello-FileTree'.
		spec package: 'Metacello-Cypress'.
		spec package: 'Metacello-Reference'.
		spec package: 'Metacello-Tutorial'.
		spec package: 'MonticelloGUI'.
		spec package: 'Tests'.
		spec package: 'RPackage-Tests'.
		spec package: 'Monticello-Tests'.
		spec package: 'MonticelloGUI-Tests'.
		spec package: 'Network-Mail'.
		spec package: 'Network-Mail-Tests'.
		spec package: 'Pharo-Help'.
		spec package: 'ProfStef-Core'.
		spec package: 'ProfStef-Help'.
		spec package: 'Refactoring-Changes'.
		spec package: 'Refactoring-Core'.
		spec package: 'Refactoring-Environment'.
		spec package: 'Regex-Help'.
		spec package: 'Monticello-OldDataStreamCompatibility'.
		spec package: 'MonticelloFileServices'.
		
		self specHelp: spec.
		
		spec package: 'Tools-CodeNavigation'.
		spec package: 'Tool-Diff'.
		spec package: 'Tool-FileList'.
		spec package: 'Tool-Finder'.
		spec package: 'Tool-ImageCleaner'.
		spec package: 'Tools' ]! !

!BaselineOfBasicTools methodsFor: 'baseline' stamp: ''!
project
	
	| aProject |
	
	aProject := super project.
	aProject loadType: #atomic.
	^ aProject.
	! !

!BaselineOfBasicTools methodsFor: 'baseline' stamp: ''!
specHelp: spec
	
	spec baseline: 'SpecHelp' with: [
		spec 
			repository: (self class environment at: #BaselineOfPharo) specRepository;
			className: 'BaselineOfSpec2';
			loads: #('Spec2-Help') ]! !

!BaselineOfBasicTools methodsFor: 'actions' stamp: ''!
postload: loader package: packageSpec

	"Ignore pre and post loads if already executed"
	Initialized = true ifTrue: [ ^ self ].
	
	Smalltalk tools register: TestRunner as: #testRunner.
	Smalltalk tools register: MCWorkingCopyBrowser as: #monticelloBrowser.
	
	RBRefactoryChangeManager nuke.
	Smalltalk garbageCollect.
	Smalltalk cleanOutUndeclared. 
	
	CompletionSorter register.
	RubSmalltalkEditor completionEngineClass: CompletionEngine.
	
	Author reset.

	Initialized := true.! !

!BaselineOfBeacon methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>

	spec for: #'common' do: [
		spec 
			package: #'Beacon-Core';
			package: #'Beacon-Core-GT' with: [
				spec requires: #('Beacon-Core' #'Beacon-ExtraSignals'). ];
			package: #'Beacon-Core-Tests' with: [
				spec requires: #('Beacon-Core' ). ];
			package: #'Beacon-SerializingLoggers' with: [ spec requires: #('Beacon-Core') ];
			package: #'Beacon-ExtraSignals' with: [ spec requires: #('Beacon-Core') ];
			package: #'Beacon-Extra-Tests' with: [ spec requires: #('Beacon-SerializingLoggers' 'Beacon-ExtraSignals') ];
			package: #'Beacon-Syslog' with: [ spec requires: #('Beacon-SerializingLoggers') ];
			package: #'Beacon-File' with: [ spec requires: #('Beacon-SerializingLoggers') ];
			package: #'Beacon-Zinc' with: [ spec requires: #(#'Beacon-Core') ].
		spec 
			group: 'Core' with: #('Beacon-Core' );
			group: 'CoreTests' with: #('Beacon-Core' 'Beacon-Core-Tests');
			group: 'default' with: #('Beacon-Core' 'Beacon-Core-Tests' 'Beacon-SerializingLoggers' 'Beacon-Core-GT' 'Beacon-ExtraSignals' 'Beacon-Extra-Tests' 'Beacon-Syslog' 'Beacon-File' 'Beacon-Zinc'). ].
! !

!BaselineOfCalypso methodsFor: 'baselines' stamp: ''!
baseline: spec
   <baseline>

	| repository | 
	repository := self packageRepositoryURL.

	spec for: #'common' do: [
		spec 
			baseline: 'ClassAnnotation' with: [
				spec
					repository: repository;
					loads: 'Core' ];
			project: 'ClassAnnotationTests' copyFrom: 'ClassAnnotation' with: [
				spec loads: 'Tests'];
			baseline: 'Commander' with: [
				spec repository: repository ];
			baseline: 'SystemCommands' with: [
				spec repository: repository ].

		spec 
			package: #'Calypso-NavigationModel';
			package: #'Calypso-NavigationModel-Tests' with: [
				spec requires: #(#'Calypso-NavigationModel' )];
			package: #'Calypso-SystemQueries' with: [
				spec requires: #(#'Calypso-NavigationModel' #'ClassAnnotation' ). ];
			package: #'Calypso-SystemQueries-Tests' with: [
				spec requires: #(#'Calypso-NavigationModel-Tests' #'ClassAnnotationTests' #'Calypso-SystemQueries' #'Calypso-SystemQueries-Tests-PWithSingleClass' #'Calypso-SystemQueries-Tests-PExtendedByP1' #'Calypso-SystemQueries-Tests-P1WithHierarchy' #'Calypso-SystemQueries-Tests-P2WithSubclassFromP1' #'Calypso-SystemQueries-Tests-P3WithSubclassFromP2' #'Calypso-SystemQueries-Tests-PExtendedByP5' #'Calypso-SystemQueries-Tests-P5WithTags' #'Calypso-SystemPlugins-Traits-Queries-Tests-PWithTraits' #'Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait' ). ];
			package: #'Calypso-SystemQueries-Tests-P1WithHierarchy' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests-PExtendedByP1' ). ];
			package: #'Calypso-SystemQueries-Tests-P2WithSubclassFromP1' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests-P1WithHierarchy' ). ];
			package: #'Calypso-SystemQueries-Tests-P3WithSubclassFromP2' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests-P2WithSubclassFromP1' ). ];
			package: #'Calypso-SystemQueries-Tests-P5WithTags' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests-PExtendedByP5' ). ];
			package: #'Calypso-SystemQueries-Tests-PExtendedByP1' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests-PWithSingleClass' ). ];
			package: #'Calypso-SystemQueries-Tests-PExtendedByP5';
			package: #'Calypso-SystemQueries-Tests-PWithSingleClass';
			
			package: #'Calypso-SystemPlugins-Traits-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ). ];
			package: #'Calypso-SystemPlugins-Traits-Queries-Tests-PWithTraits';
			package: #'Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait' with: [
				spec requires: #(#'Calypso-SystemPlugins-Traits-Queries-Tests-PWithTraits' )];			
			package: 'Calypso-SystemPlugins-Traits-Queries-Tests' with: [
				spec requires: #(#'Calypso-SystemPlugins-Traits-Queries' #'Calypso-SystemQueries-Tests' 'Calypso-SystemPlugins-Traits-Queries-Tests-PWithTraits' 'Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait') ];
			package: #'Calypso-SystemPlugins-Traits-Browser' with: [
				spec requires: #(#'Calypso-SystemTools-FullBrowser' #'Calypso-SystemPlugins-Traits-Queries' ). ];
			
			
			package: #'Calypso-ProcessQueries' with: [
				spec requires: #(#'Calypso-SystemQueries')];
			package: #'Calypso-ProcessQueries-Tests' with: [
				spec requires: #(#'Calypso-ProcessQueries')];
			
			package: #'Calypso-SystemPlugins-Critic-Browser' with: [
				spec requires: #(#'Calypso-SystemTools-FullBrowser' #'Calypso-SystemPlugins-Critic-Queries' ). ];
			package: #'Calypso-SystemPlugins-Critic-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ). ];
			package: 'Calypso-SystemPlugins-Critic-Queries-Tests' with: [
				spec requires: #(#'Calypso-SystemPlugins-Critic-Queries' #'Calypso-SystemQueries-Tests' ). ];
			
			package: #'Calypso-SystemPlugins-Deprecation-Browser' with: [
				spec requires: #(#'Calypso-SystemPlugins-Deprecation-Queries' #'Calypso-SystemTools-FullBrowser' ). ];
			package: #'Calypso-SystemPlugins-Deprecation-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ). ];
			package: #'Calypso-SystemPlugins-Deprecation-Queries-Tests' with: [
				spec requires: #(#'Calypso-SystemPlugins-Deprecation-Queries' ). ];
			
			package: #'Calypso-SystemPlugins-FileOut-Browser' with: [
				spec requires: #(#'Calypso-SystemPlugins-FileOut-Queries' #'Calypso-SystemTools-Core' ). ];
			package: #'Calypso-SystemPlugins-FileOut-Queries';
			
			package: 'Calypso-SystemPlugins-InheritanceAnalysis-Browser' with: [
				spec requires: #('Calypso-SystemPlugins-InheritanceAnalysis-Queries' #'Calypso-SystemTools-FullBrowser' ). ];
			package: 'Calypso-SystemPlugins-InheritanceAnalysis-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ). ];
			package: 'Calypso-SystemPlugins-InheritanceAnalysis-Queries-Tests' with: [
				spec requires: #('Calypso-SystemPlugins-InheritanceAnalysis-Queries' ). ];
			
			package: #'Calypso-SystemPlugins-MethodDiffTool' with: [
				spec requires: #(#'Calypso-SystemTools-Core' ). ];
			
			package: #'Calypso-SystemPlugins-Monticello-Browser' with: [
				spec requires: #(#'Calypso-SystemPlugins-Monticello-Queries' #'Calypso-SystemTools-FullBrowser' ). ];
			package: #'Calypso-SystemPlugins-Monticello-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ). ];
				
			package: #'Calypso-SystemPlugins-Reflectivity-Browser' with: [
				spec requires: #(#'Calypso-SystemPlugins-Reflectivity-Queries' #'Calypso-SystemTools-FullBrowser' #'Calypso-SystemTools-QueryBrowser' ) ];
			package: #'Calypso-SystemPlugins-Reflectivity-Browser-Tests' with: [
				spec requires: #(#'Calypso-SystemPlugins-Reflectivity-Browser' ) ];
			package: #'Calypso-SystemPlugins-Reflectivity-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ) ];
			package: #'Calypso-SystemPlugins-Reflectivity-Queries-Tests' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests' #'Calypso-SystemPlugins-Reflectivity-Queries' ) ];
			
			package: #'Calypso-SystemPlugins-SUnit-Browser' with: [
				spec requires: #(#'Calypso-SystemPlugins-SUnit-Queries' #'Calypso-SystemTools-FullBrowser' ) ];
			package: #'Calypso-SystemPlugins-SUnit-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ) ];
			package: #'Calypso-SystemPlugins-SUnit-Queries-Tests' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests' #'Calypso-SystemPlugins-SUnit-Queries' ) ];
			
			package: #'Calypso-SystemPlugins-Undeclared-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ). ];
			package: #'Calypso-SystemPlugins-Undeclared-Queries-Tests' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests' #'Calypso-SystemPlugins-Undeclared-Queries' ). ];
			package: #'Calypso-SystemPlugins-Undeclared-Browser' with: [
				spec requires: #(#'Calypso-SystemPlugins-Undeclared-Queries' #'Calypso-SystemTools-Core' ). ];
			
			package: #'Calypso-SystemPlugins-FFI-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ). ];
			package: #'Calypso-SystemPlugins-FFI-Queries-Tests' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests' #'Calypso-SystemPlugins-FFI-Queries' ). ];
			package: #'Calypso-SystemPlugins-FFI-Browser' with: [
				spec requires: #(#'Calypso-SystemPlugins-FFI-Queries' #'Calypso-SystemTools-Core' ) ];

			package: #'Calypso-SystemPlugins-Flags-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ). ];
			package: #'Calypso-SystemPlugins-Flags-Queries-Tests' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests' #'Calypso-SystemPlugins-Flags-Queries' ) ];
			package: #'Calypso-SystemPlugins-Flags-Browser' with: [
				spec requires: #(#'Calypso-SystemPlugins-Flags-Queries' #'Calypso-SystemTools-Core' ) ];
		
			package: #'Calypso-SystemPlugins-ClassScripts-Queries' with: [
				spec requires: #(#'Calypso-SystemQueries' ). ];
			package: #'Calypso-SystemPlugins-ClassScripts-Queries-Tests' with: [
				spec requires: #(#'Calypso-SystemQueries-Tests' #'Calypso-SystemPlugins-ClassScripts-Queries' ) ];
			package: #'Calypso-SystemPlugins-ClassScripts-Browser' with: [
				spec requires: #(#'Calypso-SystemPlugins-ClassScripts-Queries' #'Calypso-SystemTools-Core' ) ];
			
			package: #'Calypso-SystemPlugins-DependencyAnalyser-Browser' with: [
				spec requires: #(#'Calypso-SystemTools-Core' ) ];			
			
			package: #'Calypso-Browser' with: [
				spec requires: #(#'Calypso-NavigationModel' 'Commander' ). ];

			package: #'Calypso-SystemTools-Core' with: [
				spec requires: #(#'Calypso-SystemQueries' #'Calypso-Browser' 'SystemCommands' ). ];
			package: #'Calypso-SystemTools-Core-Tests' with: [
				spec requires: #(#'Calypso-SystemTools-Core' ). ];
			 
			package: #'Calypso-SystemTools-FullBrowser' with: [
				spec requires: #(#'Calypso-SystemTools-Core' ). ];
			package: #'Calypso-SystemTools-FullBrowser-Tests' with: [
				spec requires: #(#'Calypso-SystemTools-FullBrowser' ). ];
			
			package: #'Calypso-SystemTools-QueryBrowser' with: [
				spec requires: #(#'Calypso-SystemTools-FullBrowser' ). ];
			package: #'Calypso-SystemTools-QueryBrowser-Tests' with: [
				spec requires: #(#'Calypso-SystemTools-QueryBrowser' #'Calypso-SystemTools-FullBrowser-Tests' ). ];		
			
			package: #'Calypso-SystemTools-OldToolCompatibillity' with: [
				spec requires: #(#'Calypso-SystemTools-QueryBrowser' ). ];

			package: #'Calypso-SystemTools-Debugger' with: [
				spec requires: #(#'Calypso-ProcessQueries' #'Calypso-SystemTools-QueryBrowser' ). ];
			
			package: #'Calypso-SystemTools-ProcessBrowser' with: [
				spec requires: #(#'Calypso-ProcessQueries' #'Calypso-SystemTools-Debugger' ). ].


		spec 
			group: 'CoreEnvironment' with: #(#'Calypso-NavigationModel');
			group: 'CoreBrowser' with: #(#'Calypso-Browser');
			
			group: 'MinimalEnvironment' with: #(#'Calypso-SystemQueries' #'Calypso-SystemPlugins-Traits-Queries' #'Calypso-SystemPlugins-Monticello-Queries' #'Calypso-SystemPlugins-SUnit-Queries' 'Calypso-SystemPlugins-InheritanceAnalysis-Queries' #'Calypso-SystemPlugins-FileOut-Queries' #'Calypso-SystemPlugins-Deprecation-Queries' #'Calypso-SystemPlugins-Undeclared-Queries' #'Calypso-SystemPlugins-FFI-Queries' #'Calypso-SystemPlugins-Flags-Queries' #'Calypso-SystemPlugins-ClassScripts-Queries');			
			group: 'FullEnvironment' with: #('MinimalEnvironment' #'Calypso-SystemPlugins-Reflectivity-Queries' #'Calypso-SystemPlugins-Critic-Queries' );
			
			group: 'SystemBrowser' with: #(#'Calypso-SystemTools-FullBrowser' #'Calypso-SystemTools-QueryBrowser' #'Calypso-SystemPlugins-Traits-Browser'  #'Calypso-SystemPlugins-SUnit-Browser' #'Calypso-SystemTools-OldToolCompatibillity' #'Calypso-SystemPlugins-Critic-Browser' 'Calypso-SystemPlugins-InheritanceAnalysis-Browser' #'Calypso-SystemPlugins-FileOut-Browser' #'Calypso-SystemPlugins-MethodDiffTool' #'Calypso-SystemPlugins-Deprecation-Browser' #'Calypso-SystemPlugins-Reflectivity-Browser' #'Calypso-SystemPlugins-Undeclared-Browser' #'Calypso-SystemPlugins-FFI-Browser' #'Calypso-SystemPlugins-Flags-Browser' #'Calypso-SystemPlugins-ClassScripts-Browser' #'Calypso-SystemPlugins-DependencyAnalyser-Browser');

			group: 'IcebergSupport' with: #(#'Calypso-SystemPlugins-Monticello-Browser');
			
			group: 'MinimalEnvironmentTests' with: #(#'Calypso-NavigationModel-Tests' #'Calypso-SystemQueries-Tests' #'Calypso-SystemPlugins-Traits-Queries-Tests' 'Calypso-SystemPlugins-InheritanceAnalysis-Queries-Tests' #'Calypso-SystemPlugins-Deprecation-Queries-Tests' #'Calypso-SystemPlugins-SUnit-Queries-Tests' #'Calypso-SystemPlugins-Undeclared-Queries-Tests' #'Calypso-SystemPlugins-FFI-Queries-Tests' #'Calypso-SystemPlugins-Flags-Queries-Tests' #'Calypso-SystemPlugins-ClassScripts-Queries-Tests');
						
			group: 'Tests' with: #('MinimalEnvironmentTests' #'Calypso-SystemTools-FullBrowser-Tests' #'Calypso-SystemTools-QueryBrowser-Tests' #'Calypso-SystemPlugins-Reflectivity-Queries-Tests' #'Calypso-SystemPlugins-Reflectivity-Browser-Tests' #'Calypso-SystemPlugins-Critic-Queries-Tests');
			
			group: 'ProcessEnvironment' with: #(#'Calypso-ProcessQueries');
			group: 'ProcessBrowser' with: #(#'Calypso-SystemTools-ProcessBrowser');
			group: 'ProcessBrowserTests' with: #(#'Calypso-ProcessQueries-Tests');
			
			group: 'default' with: #('FullEnvironment' 'SystemBrowser' 'Tests' 'ProcessEnvironment' 'ProcessBrowser' 'ProcessBrowserTests' ) ].
! !

!BaselineOfClap methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	spec for: #common do: [ spec
		baseline: 'Okay' with: [ spec repository: 'github://cdlm/okay-st' ];

		package: 'Clap-Core';
		package: 'Clap-CommandLine' with: [ spec requires: #('Clap-Core') ];
		package: 'Clap-Commands-Pharo' with: [ spec requires: #('Clap-CommandLine') ];
		package: 'Clap-Examples' with: [ spec requires: #('Clap-CommandLine') ];
		package: 'Clap-Examples-Booklet' with: [ spec requires: #('Clap-CommandLine') ];
		package: 'Clap-Tests' with: [ spec requires: #('Clap-Core' 'Clap-Examples') ];
		package: 'Clap-Okay-Tests' with: [ spec requires: #('Clap-Core' 'Okay') ];

		group: 'default' with: #(core development);
		group: 'core' with: #('Clap-Core' 'Clap-CommandLine');
		group: 'pharo' with: #('Clap-Commands-Pharo');
		group: 'examples' with: #('Clap-Examples');
		group: 'tests' with: #('Clap-Tests');
		group: 'development' with: #(core pharo examples tests);
		group: 'development-full' with: #(development 'Clap-Examples-Booklet' 'Clap-Okay-Tests') ]! !

!BaselineOfClassAnnotation methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'ClassAnnotation';
			package: 'ClassAnnotation-Tests' with: [spec requires: #(ClassAnnotation)].
		spec 
			group: 'default' with: #('Core' 'Tests');
			group: 'Core' with: #('ClassAnnotation');
			group: 'Tests' with: #('ClassAnnotation-Tests') ]! !

!BaselineOfClassParser methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'ClassParser';
			package: 'ClassParser-Tests' with: [spec requires: #(ClassParser) ];
			package: 'UndefinedClasses';
			package: 'UndefinedClasses-Tests' with: [spec requires: #(UndefinedClasses)].

		spec 
			group: 'Core' with: #('ClassParser' 'UndefinedClasses');
			group: 'Tests' with: #('ClassParser-Tests' 'UndefinedClasses-Tests');
			group: 'default' with: #('Core' 'Tests') ]! !

!BaselineOfCommander methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	| repository | 	
	repository := self packageRepositoryURL.
	
	spec for: #'common' do: [
		spec
			baseline: #ClassAnnotation with: [ 
				spec 
					repository: repository;
					loads: 'Core' ];
			project: #ClassAnnotationTests copyFrom: #ClassAnnotation with: [
				spec loads: 'Tests'];
			package: #'Commander-Core' with: [spec requires: #(ClassAnnotation)];
			package: #'Commander-Core-Tests' with: [
				spec requires: #(#'Commander-Core' #ClassAnnotationTests)];
	
			package: #'Commander-Activators-Shortcut' with: [
				spec requires: #(#'Commander-Core' )];
			package: #'Commander-Activators-ContextMenu' with: [
				spec requires: #(#'Commander-Core' #'Commander-Activators-Shortcut' )];
			package: #'Commander-Activators-DragAndDrop' with: [
				spec requires: #(#'Commander-Core' )];

			package: #'Commander-Activators-WorldMenu' with: [
				spec requires: #(#'Commander-Activators-Shortcut' #'Commander-Activators-ContextMenu' )];
			package: #'Commander-Activators-Mouse' with: [
				spec requires: #(#'Commander-Core' )];
			package: #'Commander-Activators-TextView' with: [
				spec requires: #(#'Commander-Activators-ContextMenu' #'Commander-Activators-Mouse')];
			
			package: #'Commander-SpecSupport';
			package: #'Commander-Spec2-Compatibility' with: [spec requires: #(#'Commander-Core' )];			
			package: #'Commander-Examples' with: [
				spec requires: #(#'Commander-SpecSupport')].
		spec 
			group: 'Core' with: #(#'Commander-Core');
			group: 'AllActivators' with: #(#'Commander-Activators-Shortcut' #'Commander-Activators-ContextMenu' #'Commander-Activators-DragAndDrop' #'Commander-Activators-WorldMenu' #'Commander-Activators-TextView' #'Commander-Activators-Mouse');
			group: 'Tests' with: #(#'Commander-Core-Tests' );
			group: 'default' with: #('Core' 'AllActivators' 'Tests' 'Commander-SpecSupport' 'Commander-Spec2-Compatibility') ]! !

!BaselineOfCommander2 methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #common do: [ 
		spec 
			package: 'Commander2';
			package: 'Commander2-UI' with: [ spec requires: #('Commander2') ];
			package: 'Commander2-Tests' with: [ spec requires: #('Commander2') ];
			package: 'Commander2-UI-Tests' with: [ spec requires: #('Commander2-UI') ];
			package: 'Commander2-V2ReleaseMigrator'.
		spec
			group: 'core' with: #('Commander2');
			group: 'ui' with: #('Commander2-UI');
			group: 'tests' with: #('core' 'ui' 'Commander2-Tests' 'Commander2-UI-Tests');
			group: 'migration' with: #('Commander2-V2ReleaseMigrator');
			group: 'default' with: #('core' 'ui' 'tests'). ]! !

!BaselineOfDependencyAnalyzer methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #'common' do: [
			
		spec 
			package: 'Moose-Algos-Graph';
			package: 'Tool-DependencyAnalyser';
			package: 'Tool-DependencyAnalyser-UI';
			package: 'Moose-Algos-Graph-Tests';
			package: 'Tool-DependencyAnalyser-Tests';
			package: 'Tool-DependencyAnalyser-Tests-Data'.
		spec 
			group: 'Core' with: #('Moose-Algos-Graph' 	'Tool-DependencyAnalyser'
				'Tool-DependencyAnalyser-UI');
			group: 'Tests' with: #('Moose-Algos-Graph-Tests' 	'Tool-DependencyAnalyser-Tests'
				'Tool-DependencyAnalyser-Tests-Data');
			group: 'default' with: #('Core' 'Tests') ]! !

!BaselineOfDisplay commentStamp: ''!
This baseline is used to generate Pharo images from the local clone of pharo-project/pharo repository. 

Depends on:
- BaselineOfSUnit

Load type: 
- linear

Installs:
- Graphics-* packages (Form, Bitmap, GrafPort...)!
!BaselineOfDisplay methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>

	spec for: #common do: [
		spec preLoadDoIt: #'preload:package:'.
		spec postLoadDoIt: #'postload:package:'.
		
		spec 
			package: 'Graphics-Display Objects';
			package: 'Graphics-Primitives' with: [ spec requires: 'Graphics-Display Objects' ];
			package: 'Graphics-Transformations'
		
		 ].		
! !

!BaselineOfDisplay methodsFor: 'actions' stamp: ''!
preload: loader package: packageSpec

	"Ignore pre and post loads if already executed"
	Initialized = true ifTrue: [ ^ self ].

	initializersEnabled := MCMethodDefinition initializersEnabled.
	MCMethodDefinition initializersEnabled: false.
	

	
! !

!BaselineOfDisplay methodsFor: 'actions' stamp: ''!
installBitmap

	"install new Bitmap class to special objects array"

	| array |
	
	array := Smalltalk specialObjectsArray copy.
	array at: 5 put: Bitmap.

	Smalltalk specialObjectsArray becomeForward: array.! !

!BaselineOfDisplay methodsFor: 'actions' stamp: ''!
postload: loader package: packageSpec

	| display |
	
	"Ignore pre and post loads if already executed"
	Initialized = true ifTrue: [ ^ self ].
	
	self installBitmap.

	display := (Smalltalk classNamed: #DisplayScreen) new.
	display setExtent: 0@0 depth: 2.
	Smalltalk globals at: #Display put: display.

	Cursor webLink. "set the webLink cursor shape"
					
	Cursor initialize.
	DisplayScreen initialize.
	BitBlt initialize.
	Form initialize.
	
	MCMethodDefinition initializersEnabled: initializersEnabled.

	Initialized := true.! !

!BaselineOfDrTests methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec
		for: #common
		do: [ spec
				package: 'DrTests';
				package: 'DrTests-TestsRunner' with: [ spec requires: #('DrTests') ];
				package: 'DrTests-TestCoverage' with: [ spec requires: #('DrTests') ];
				package: 'DrTests-TestsProfiling' with: [ spec requires: #('DrTests') ];
				package: 'DrTests-Tests' with: [ spec requires: #('DrTests' 'DrTests-TestsRunner' 'DrTests-TestCoverage-Tests-Mocks') ];
				package: 'DrTests-TestCoverage-Tests' with: [ spec requires: #('DrTests-TestCoverage' 'DrTests-TestCoverage-Tests-Mocks') ];
				package: 'DrTests-TestsProfiling-Tests' with: [ spec requires: #('DrTests-TestsProfiling') ];
				package: 'DrTests-TestCoverage-Tests-Mocks' with: [ spec requires: #('DrTests-TestCoverage') ];
				package: 'DrTests-CommentsToTests' with: [ spec requires: #('DrTests' 'DrTests-TestsRunner') ];
				package: 'DrTests-CommentsToTests-Tests' with: [ spec requires: #('DrTests-CommentsToTests') ] ]! !

!BaselineOfEmergencyDebugger methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline> 
	
	spec for: #common do: [
		spec 
			package: 'EmergencyDebugger';
			package: 'EmergencyDebugger-Tests' with: [ spec requires: #('EmergencyDebugger') ].
			
		spec 
			group: 'default' with: #('Base' 'Tests');
			group: 'Base' with: #('EmergencyDebugger');
			group: 'Tests' with: #('EmergencyDebugger-Tests') ]! !

!BaselineOfEnlumineurFormatter commentStamp: ''!
Metacello new
  baseline: 'EnlumineurFormatter';
  repository: 'github://Ducasse/enlumineur/src';
  load: 'Tests'.!
!BaselineOfEnlumineurFormatter methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>

	spec for: #pharo do: [
		spec 
			package: 'EnlumineurFormatter';
			package: 'EnlumineurFormatter-Tests' with: [ spec requires: #('EnlumineurFormatter') ]";
			package: 'EnlumineurFormatterUI' with: [ spec requires: #('EnlumineurFormatter') ];
			package: 'EnlumineurFormatterUI-Tests' with: [ spec requires: #('EnlumineurFormatterUI') ]". 
		
		spec
			group: 'Core' with: #('EnlumineurFormatter');
			group: 'Tests' with: #('Core' 'EnlumineurFormatter-Tests');
			"group: 'UI' with: #('Core' 'EnlumineurFormatterUI');
			group: 'UI-Tests' with: #('Tests' 'EnlumineurFormatterUI-Tests');"
			group: 'All' with: #('Core' 'Tests' "'UI' 'UI-Tests'")
		
		]! !

!BaselineOfEpicea methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'Ombu';
			package: 'Epicea';
			package: 'Hiedra';
			package: 'Hiedra-Examples';
			package: 'EpiceaBrowsers'. ]! !

!BaselineOfExternalProjectLoader methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	| repository |

	repository := self packageRepositoryURL.

	spec for: #common do: [ 
		spec package: 'ExternalProjectLoader'.
		
		spec group: 'Core' with: #('ExternalProjectLoader').
		spec group: 'default' with: #('Core') ]! !

!BaselineOfFlashback commentStamp: ''!
Baseline managing the Flashback project for the Pharo bootstrap.

Load type: 
- linear!
!BaselineOfFlashback methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	spec
		for: #common
		do: [ 
			"Packages"
			spec package: 'Flashback-Decompiler'.
			spec package: 'Flashback-Decompiler-Tests' with: [ spec requires: 'Flashback-Decompiler' ].

			"Groups"
			spec
				group: 'Core' with: #('Flashback-Decompiler');
				group: 'Tests' with: #('Flashback-Decompiler-Tests') ]! !

!BaselineOfFreeType methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #common do: [ 
		spec package: 'FreeType'.
		spec package: 'FreeType-Graphics' with: [ spec requires: #('FreeType') ].		
		spec package: 'FreeType-Morphic' with: [ spec requires: #('FreeType-Graphics') ].
		spec package: 'FreeType-Tests' with: [ spec requires: #('FreeType') ].
		spec package: 'FreeType-Help' with: [ spec requires: #('FreeType') ].

		spec group: 'core' with: #('FreeType').
		spec group: 'ui' with: #('core' 'FreeType-Graphics' 'FreeType-Morphic').
		spec group: 'tests' with: #('core' 'FreeType-Tests') ]! !

!BaselineOfFreeType methodsFor: 'accessing' stamp: ''!
project
	
	| aProject |
	
	aProject := super project.
	aProject loadType: #atomic.
	^ aProject! !

!BaselineOfFuel commentStamp: ''!
Fuel is a general-purpose object serialization framework.

See more information in our website:
http://rmod.lille.inria.fr/web/pier/software/Fuel/!
!BaselineOfFuel methodsFor: 'baselines-helpers' stamp: ''!
fuelPlatform: spec		
	spec 
		baseline: 'FuelPlatform' 
		with: [ 
			spec
				repository: self packageRepositoryURL;
  				loads: 'default' ]! !

!BaselineOfFuel methodsFor: 'adding' stamp: ''!
addPostloadHacks
	"Simply perform #addHacks again. We've now loaded classes that weren't
	there before and some of those also need extensions" 
	(Smalltalk at: #FLPlatform) current addHacks! !

!BaselineOfFuel methodsFor: 'baselines-helpers' stamp: ''!
groupsForPharoCommon: spec
	spec for: #pharo do: [              
		spec
			package: 'Fuel-Preview' with: [ spec requires: #('Fuel-Debug' 'Roassal') ];
			package: 'Fuel-Metalevel' with: [ spec requires: 'Core' ];
			
			package: 'Fuel-Tests-Metalevel' with: [ spec requires: #('Fuel-Metalevel' 'Tests' ) ].
		
		self roassal: spec.

		spec
			group: 'CoreWithExtras' with: #('Core' 'Fuel-Metalevel' 'Fuel-ProgressUpdate');
			group: 'DevelopmentGroup' with: #(
				'CoreWithExtras'
				'Fuel-Debug'
				'Tests'
				'Fuel-Tests-Metalevel'
				'Fuel-Tests-ProgressUpdate'
				'Fuel-Tests-Debug');
			group: 'Benchmarks' with: #('Core' 'Fuel-Benchmarks');
			group: 'BenchmarksTests' with: #('Benchmarks' 'Fuel-Tests-Benchmarks') ]! !

!BaselineOfFuel methodsFor: 'baselines-helpers' stamp: ''!
roassal: spec		
	spec
		project: 'Roassal' with: [
			spec
				className: 'ConfigurationOfRoassal';
				loads: #('default');
				file: 'ConfigurationOfRoassal';
				repository: 'http://www.squeaksource.com/Roassal' ]! !

!BaselineOfFuel methodsFor: 'baselines-helpers' stamp: ''!
smark: spec		
	spec
		project: 'SMark' with: [
			spec
				className: 'ConfigurationOfSMark';
				versionString: #development;
				file: 'ConfigurationOfSMark';
				repository: 'http://smalltalkhub.com/mc/StefanMarr/SMark/main' ].

	spec
		package: 'SMark-Jenkins' with: [ 
			spec 
				repository: 'http://smalltalkhub.com/mc/ClementBera/classic-bench/main';
				requires: 'SMark' ]
! !

!BaselineOfFuel methodsFor: 'baselines' stamp: ''!
baseline: spec
  <baseline>
  spec
	for: #common
	do: [
		spec postLoadDoIt: #addPostloadHacks.

		self   
			fuelPlatform: spec;
			smark: spec.

		spec
			package: 'Fuel-Core' with: [ spec requires: 'FuelPlatform' ];
			package: 'Fuel-Debug' with: [ spec requires: 'Core' ];
			package: 'Fuel-ProgressUpdate' with: [ spec requires: #('Core') ];
			package: 'Fuel-Benchmarks' with: [ spec requires: #('Core' 'SMark-Jenkins') ];
			
			package: 'Fuel-Tests-Core' with: [ spec requires: 'Core' ];
			package: 'Fuel-Tests-Debug' with: [ spec requires: #('Fuel-Debug' 'Tests') ];
			package: 'Fuel-Tests-ProgressUpdate' with: [ spec requires: #('Fuel-ProgressUpdate' 'Tests') ];
			package: 'Fuel-Tests-Benchmarks' with: [ spec requires: #('Fuel-Benchmarks' 'Tests') ].
					
		spec
			group: 'default' with: #('Core');
			group: 'Core' with: #('Fuel-Core');
			group: 'Tests' with: #('Core' 'Fuel-Tests-Core') ].

	self
		groupsForPharoCommon: spec;
		groupsForSqueakCommon: spec! !

!BaselineOfFuel methodsFor: 'baselines-helpers' stamp: ''!
groupsForSqueakCommon: spec
	spec for: #squeak do: [
		spec
			group: 'CoreWithExtras' with: #('Core' 'Fuel-ProgressUpdate');
			group: 'Benchmarks' with: #('Core' 'Fuel-Benchmarks') ]! !

!BaselineOfFuelPlatform commentStamp: ''!
We use a separate baseline to make it simpler to manage the platform classes. Using a separate baseline also makes it easy to load all the packages at once when we need to update them.!
!BaselineOfFuelPlatform methodsFor: 'adding' stamp: ''!
addPostloadHacks
	| platformClass |
	platformClass := Smalltalk at: #FLPlatform.
	
	"Ensure that on development platforms the current platform is correct,
	e.g. when we add a new platform the loaded one could be FLPharo7Platform
	but we need it to be FLPharo8Platform after loading."
	platformClass reset.
	
	"Simply perform #addHacks again. We've now loaded classes that weren't
	there before and some of those also need extensions" 
	platformClass current addHacks! !

!BaselineOfFuelPlatform methodsFor: 'adding' stamp: ''!
platformAttributes
	(SystemVersion current version beginsWith: 'Pharo10') ifTrue: [ ^ #('pharo10.x') ].
	(SystemVersion current version beginsWith: 'Pharo9') ifTrue: [ ^ #('pharo9.x') ].
	(SystemVersion current version beginsWith: 'Pharo8') ifTrue: [ ^ #('pharo8.x') ].
	(SystemVersion current version beginsWith: 'Pharo7') ifTrue: [ ^ #('pharo7.x') ].
	(SystemVersion current version beginsWith: 'Pharo6') ifTrue: [ ^ #('pharo6.x') ].
	(SystemVersion current version beginsWith: 'Pharo5') ifTrue: [ ^ #('pharo5.x') ].
	(SystemVersion current version beginsWith: 'Pharo4') ifTrue: [ ^ #('pharo4.x') ].
	(SystemVersion current version beginsWith: 'Pharo3') ifTrue: [ ^ #('pharo3.x') ].
	(SystemVersion current version beginsWith: 'Pharo2') ifTrue: [ ^ #('pharo2.x') ].
	(SystemVersion current version beginsWith: 'Pharo6') ifTrue: [ ^ #('pharo6.x') ].
	(SystemVersion current version beginsWith: 'Pharo1.') ifTrue: [ ^ #('pharo1.x') ].
	(#('Pharo1.1' 'Pharo-1.1') anySatisfy: [ :version |
			SystemVersion current version beginsWith: version ]) ifTrue: [ ^ #('pharo1.x') ].
	
	(SystemVersion current version beginsWith: 'Squeak6') ifTrue: [ ^ #('squeak6.x') ].
	(SystemVersion current version beginsWith: 'Squeak5') ifTrue: [ ^ #('squeak5.x') ].
	((SystemVersion current version beginsWith: 'Squeak4.6') or: [
			"See #fixSystemVersion"
			[ (Smalltalk imageName includesSubString: '4.6') ]
				on: MessageNotUnderstood
				do: [ false ] ]) ifTrue: [ ^ #('squeak4.x') ].
	(SystemVersion current version beginsWith: 'Squeak4.') ifTrue: [ ^ #('squeak4.x') ].
	
	
	Warning signal: 'Could not determine image version. Using fallback'.
	^ #('fuel-fallback')! !

!BaselineOfFuelPlatform methodsFor: 'accessing' stamp: ''!
addCustomProjectAttribute: aSymbol
	customProjectAttributes := self customProjectAttributes copyWith: aSymbol! !

!BaselineOfFuelPlatform methodsFor: 'helpers' stamp: ''!
squeakPackagesAndGroups: spec
	spec for: #squeak do: [
		spec package: 'Fuel-Platform-Squeak-Core' with: [ spec requires: 'Fuel-Platform-Core' ] ].
	spec for: #'squeak4.x' do: [
		spec package: 'Fuel-Platform-Squeak-04x' with: [ spec requires: 'Fuel-Platform-Squeak-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Squeak-04x' ].
	spec for: #'squeak5.x' do: [
		spec package: 'Fuel-Platform-Squeak-05' with: [ spec requires: 'Fuel-Platform-Squeak-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Squeak-05' ].
	spec for: #'squeak6.x' do: [
		spec package: 'Fuel-Platform-Squeak-06' with: [ spec requires: 'Fuel-Platform-Squeak-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Squeak-06' ].
	spec for: #'fuel-fallback' do: [
		spec package: 'Fuel-Platform-Squeak-06' with: [ spec requires: 'Fuel-Platform-Squeak-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Squeak-06' ]! !

!BaselineOfFuelPlatform methodsFor: 'helpers' stamp: ''!
pharoPackagesAndGroups: spec
	spec for: #pharo do: [
		spec package: 'Fuel-Platform-Pharo-Core' with: [ spec requires: 'Fuel-Platform-Core' ] ].
	spec for: #'pharo1.x' do: [
		spec package: 'Fuel-Platform-Pharo-01x' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Pharo-01x' ].
	spec for: #'pharo2.x' do: [
		spec package: 'Fuel-Platform-Pharo-02' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Pharo-02' ].
	spec for: #'pharo3.x' do: [
		spec package: 'Fuel-Platform-Pharo-03' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Pharo-03' ].
	spec for: #'pharo4.x' do: [
		spec package: 'Fuel-Platform-Pharo-04' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Pharo-04' ].
	spec for: #'pharo5.x' do: [
		spec package: 'Fuel-Platform-Pharo-05' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Pharo-05' ].
	spec for: #'pharo6.x' do: [
		spec package: 'Fuel-Platform-Pharo-06' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Pharo-06' ].
	spec for: #'pharo7.x' do: [
		spec package: 'Fuel-Platform-Pharo-07' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: 'Fuel-Platform-Pharo-07' ].
	spec for: #'pharo8.x' do: [
		spec package: 'Fuel-Platform-Pharo-08' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: #('Fuel-Platform-Pharo-08') ].
	spec for: #'pharo9.x' do: [
		spec package: 'Fuel-Platform-Pharo-09' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: #('Fuel-Platform-Pharo-09') ].
	spec for: #'pharo10.x' do: [
		spec package: 'Fuel-Platform-Pharo-10' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: #('Fuel-Platform-Pharo-10') ].
	spec for: #'fuel-fallback' do: [
		spec package: 'Fuel-Platform-Pharo-10' with: [ spec requires: 'Fuel-Platform-Pharo-Core' ].
		spec group: 'FuelPlatformCurrentGroup' with: #('Fuel-Platform-Pharo-10') ]! !

!BaselineOfFuelPlatform methodsFor: 'baselines' stamp: ''!
baseline: spec
  <baseline>
  spec
	for: #common
	do: [		
		spec
			postLoadDoIt: #addPostloadHacks;
			package: 'Fuel-Platform-Core'.
			
		spec
			group: 'default'
			with: #('Fuel-Platform-Core' 'FuelPlatformCurrentGroup') ].
	
	self 
		pharoPackagesAndGroups: spec;
		squeakPackagesAndGroups: spec! !

!BaselineOfFuelPlatform methodsFor: 'accessing' stamp: ''!
customProjectAttributes
	^ customProjectAttributes ifNil: [ customProjectAttributes := self platformAttributes ]! !

!BaselineOfFuelPlatform methodsFor: 'accessing' stamp: ''!
loadAll
	#(pharo 'pharo1.x' 'pharo2.x' 'pharo3.x' 'pharo4.x' 'pharo5.x' 'pharo6.x' 'pharo7.x'
		squeak 'squeak4.x' 'squeak5.x' 'squeak6.x') do: [ :attribute |
			self addCustomProjectAttribute: attribute ]! !

!BaselineOfFuzzyMatcher methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'FuzzyMatcher';
			package: 'FuzzyMatcher-Tests'.

		spec 
			group: 'Core' with: #('FuzzyMatcher');
			group: 'Tests' with: #('FuzzyMatcher-Tests');
			group: 'default' with: #('Core' 'Tests') ]! !

!BaselineOfGeneralHelp methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'Announcements-Help';
			package: 'Pharo-Help';
			package: 'Regex-Help' ]! !

!BaselineOfGeneralTests methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	"Needs to be re-sorted"
	
	spec for: #'common' do: [
		spec 
			package: 'Debugging-Utils-Tests';
			package: 'Tests';
			package: 'NumberParser-Tests';
			package: 'AST-Core-Tests';			
			package: 'RPackage-Tests';
			package: 'Monticello-Tests';	"required by MonticelloMocks"
			package: 'System-Installers-Tests' ;
			package: 'MonticelloMocks';
			package: 'Fuel-Tests-Core';
			package: 'FormCanvas-Tests';
			package: 'Collections-DoubleLinkedList-Tests';
			package: 'Collections-Arithmetic-Tests';
			package: 'ConfigurationCommandLineHandler-Tests';
			package: 'MetacelloCommandLineHandler-Tests';
			package: 'Debugger-Model-Tests';
			package: 'Debugger-Oups-Tests';		
			package: 'EmbeddedFreeType-Tests';
			
			package: 'Ombu-Tests';
			package: 'Epicea-Tests';
			package: 'Hiedra-Tests';
			package: 'EpiceaBrowsers-Tests';
			
			package: 'FileSystem-Tests-Memory';
			package: 'Fonts-Infrastructure-Tests';
			
			package: 'Graphics-Tests';
			package: 'HelpSystem-Tests';

			package: 'Morphic-Tests';
			
			package: 'Morphic-Widgets-FastTable-Tests';
			package: 'NECompletion-Tests';
			package: 'NewValueHolder-Tests';
			package: 'ProfStef-Tests';
			package: 'Regex-Core-Tests';
			package: 'Ring-Definitions-Tests-Monticello';
			package: 'Rubric-Tests';
			package: 'ScriptingExtensions-Tests';
			package: 'STON-Tests';
			package: 'System-Caching-Tests';
			package: 'System-Hashing-Tests';
			package: 'System-History-Tests';
			package: 'System-Localization-Tests';
			package: 'System-SessionManager-Tests';
			package: 'System-Settings-Tests';
			package: 'System-Support-Tests';
			package: 'Text-Diff-Tests';
			package: 'Text-Edition-Tests';
			package: 'Tool-ExternalBrowser-Tests';			
			package: 'Tool-FileList-Tests';
			package: 'Tool-Finder-Tests';
			package: 'Tool-Profilers-Tests';
			package: 'Tool-Workspace-Tests';
			package: 'Tools-CodeNavigation-Tests';
			package: 'Tools-Tests';
			package: 'Zinc-Resource-Meta-FileSystem';
			package: 'Zinc-Resource-Meta-Tests';
			package: 'Zinc-HTTP-Examples';
			package: 'Zinc-Tests';	"requires Zinc-Resource-Meta-Tests"
			package: 'System-Identification-Tests'	;	
			package: 'System-DependenciesTests';
			package: 'System-BasicCommandLineHandler-Tests';
			package: 'Transcript-NonInteractive-Tests';
			package: 'PharoDocComment-Tests'	"standalone" ]! !

!BaselineOfGeometry commentStamp: ''!
A baseline for Geometrypackage!
!BaselineOfGeometry methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	spec
		for: #common
		do: [
			"Packages"
			spec
				package: 'Geometry';
				package: 'Geometry-Tests' with: [ spec requires: #('Geometry') ].
				
			"Groups"
			spec
				group: 'Core' with: 'Geometry';
				group: 'Tests' with: #('Geometry-Tests') ]! !

!BaselineOfHeuristicCompletion methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #common do: [ 
		spec package: 'HeuristicCompletion-Model'.
		spec package: 'HeuristicCompletion-Morphic' with: [ 
			spec requires: 'HeuristicCompletion-Model' ].
		spec package: 'HeuristicCompletion-Tests' with: [ 
			spec requires: 'HeuristicCompletion-Model' ] ]! !

!BaselineOfIDE commentStamp: ''!
This baseline is used to generate Pharo images from the local clone of pharo-project/pharo repository. 

Depends on:
- BasicTools
- Traits
- Shift
- Slots
- Athens

Load type: 
- linear

Installs:
- Epicea
- decompiler
- tests
- refactoring
- GT Tools
- Versionner
- TxText
- OSWindow
- QualityAssistant
- some other packages
 !
!BaselineOfIDE methodsFor: 'actions' stamp: ''!
loadExtraTools
	
	Metacello new
		baseline: 'NewToolsDocumentationReader';
		repository: 'github://pharo-spec/NewTools-DocumentationReader:master/src';
		onConflictUseIncoming;
		load.
"
	Metacello new
 	 baseline: 'BeautifulComments';
 	 repository: 'github://pillar-markup/BeautifulComments:master/src';
 	 load.
"! !

!BaselineOfIDE methodsFor: 'actions' stamp: ''!
additionalInitialization

	Smalltalk tools register: ExternalChangesBrowser as: #changeList.
	Smalltalk tools register: FileList as: #fileList.
	Smalltalk tools register: Finder as: #finder.
	Smalltalk tools register: ProcessBrowser as: #processBrowser.
	Smalltalk tools register: SyntaxErrorDebugger as: #syntaxErrorDebugger.
	Smalltalk tools register: TimeProfiler as: #timeProfiler.

	(MorphicCoreUIManager classPool at: #UIProcess) ifNotNil: [ :proc | proc terminate ].
	MorphicCoreUIManager classPool at: #UIProcess put: nil.

	PolymorphSystemSettings desktopColor:  Color veryVeryLightGray lighter.
	SourceCodeFonts setSourceCodeFonts: 10.
	FreeTypeSystemSettings loadFt2Library: true.
	FreeTypeSettings current monitorType: #LCD.
	FreeTypeSettings current glyphContrast: 55.
	
	RealEstateAgent usedStrategy: #cascadeFor:initialExtent:world:.
	GrowlMorph position: #bottomLeft.
	ShortcutReminder enabled: true.

	KMRepository reset.
	Morph shortcutsHandler: KMShortcutHandler new.

	MCSaveVersionDialog previousMessages add: String new.

	RBProgramNode formatterClass: (self class environment at: #EFFormatter ifAbsent: [RBSimpleFormatter]).

	Color flushCache.
	
	RubTextFieldArea defaultFindReplaceServiceClass: SpRubFindReplaceService.
	RubEditingArea defaultFindReplaceServiceClass: SpRubFindReplaceService.

	ASTTransformExamplePluginActive recompile.
	PharoCommandLineHandler recompile.
	SmalltalkImage recompile.
	
	RubCharacterScanner initialize.
	
	RubAbstractTextArea highlightMessageSend: true.
	
	PharoLightTheme beCurrent.
	
	SDL_Event initialize.
	
	HiRulerBuilderTest initialize.
		
	3 timesRepeat: [
		Smalltalk garbageCollect.
		Undeclared removeUnreferencedKeys.].
	
	"Making HeuristicCompletion the default completion engine"
	RubSmalltalkEditor completionEngineClass: CoCompletionEngine.
	
	self loadIceberg.	
	self loadExtraTools.	
	self makeCalypsoDefaultBrowser.! !

!BaselineOfIDE methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	| repository |
	repository := self packageRepositoryURL.
	spec for: #common do: [ 
		spec postLoadDoIt: #postload:package:.
		spec baseline: 'BasicTools' with: [ spec repository: repository ].
		spec baseline: 'Athens' with: [ spec repository: repository ].
		spec baseline: 'Flashback' with: [ spec repository: repository ].
		spec baseline: 'Shift' with: [ 
			spec
				repository: repository;
				loads: 'shift-tests' ].

		spec baseline: 'Traits' with: [ 
			spec
				repository: repository;
				loads: 'traits-tests' ].

		spec baseline: 'Slot' with: [ 
			spec
				repository: repository;
				loads: 'slot-tests' ].

		spec baseline: 'Clap' with: [ 
			spec
				repository: repository;
				loads: 'development' ].

		spec baseline: 'SUnit' with: [ 
			spec
				repository: repository;
				loads: 'Tests' ].				

		spec baseline: 'EnlumineurFormatter' with: [ 
			spec
				repository: repository;
				loads: #( 'Tests' ) ].		
					
		spec baseline: 'Reflectivity' with: [ 
			spec
				repository: repository;
				loads: #( 'tests' ) ].
				
				
		spec package: 'Network-Tests'.
		spec package: 'Network-Mail-Tests'.
		spec package: 'Gofer-Tests'.
		spec package: 'Rubric-SpecFindReplaceDialog'.
		spec baseline: 'Metacello' with: [ 
			spec
				repository: repository;
				loads: #( 'Tests' ) ].
		spec package: 'MonticelloGUI-Tests'.
		"Later we will load the UI of enlumineur probably here 
		"
		spec baseline: 'KernelTests' with: [ spec repository: repository ].
		spec baseline: 'Shout' with: [ spec repository: repository ].
		spec baseline: 'GeneralHelp' with: [ spec repository: repository ].
		spec
			baseline: 'ReflectionMirrors'
			with: [ spec repository: repository ].
		spec baseline: 'FuzzyMatcher' with: [ spec repository: repository ].
		spec baseline: 'QA' with: [ spec repository: repository ].
		spec baseline: 'OSWindow' with: [ spec repository: repository ].
		spec baseline: 'EmergencyDebugger' with: [ spec repository: repository ].
		spec baseline: 'Refactoring' with: [ spec repository: repository ].
		spec baseline: 'Epicea' with: [ spec repository: repository ].
		spec baseline: 'Misc' with: [ spec repository: repository ].
		spec baseline: 'Fuel' with: [ 
			spec
				repository: repository;
				loads: #( 'Tests' ) ].
		spec baseline: 'GeneralTests' with: [ spec repository: repository ].
		spec baseline: 'FreeType' with: [ spec repository: repository; loads: 'tests' ].
		spec baseline: 'Keymapping' with: [ spec repository: repository; loads: 'tests' ].
		spec baseline: 'Zodiac' with: [ spec repository: repository ].
		spec baseline: 'SortFunctions' with: [ spec repository: repository ].
		spec package: 'STON-Extensions'. 
		
		spec package: 'BaselineOfPharoBootstrap'.
		spec package: 'BaselineOfMonticello'.
		spec package: 'BaselineOfMetacello'.
		spec package: 'BaselineOfTelePharoSupport'.
		spec
			baseline: 'ReferenceFinder'
			with: [ spec repository: repository ].
		spec baseline: 'Refactoring2' with: [ spec repository: repository ].
		spec baseline: 'ClassParser' with: [ spec repository: repository ].
		spec baseline: 'Calypso' with: [ 
			spec
				repository: repository;
				loads: #( 'FullEnvironment' 'SystemBrowser' 'Tests' ) ].
		spec baseline: 'Ring' with: [ spec repository: repository ].
		spec baseline: 'HeuristicCompletion' with: [ spec repository: repository ].
		self specCode: spec.
		self newTools: spec.
					
		"spec baseline: 'Microdown' with: [ spec 
				repository: self packageRepositoryURL ]."
	
		spec 
  			baseline: 'Roassal3' 
  			with: [ spec 
				repository: 'github://ObjectProfile/Roassal3:v0.9.9c/src';
    				loads: #( 'Core' 'Tests') ].

		spec 
  			baseline: 'ThreadedFFI' 
  			with: [ spec 
				repository: repository ].

		
		spec package: 'Pharo-WelcomeHelp'.
		spec package: 'Kernel-ExtraUtils' 
		
	]! !

!BaselineOfIDE methodsFor: 'baseline' stamp: ''!
specCode: spec

	spec baseline: 'SpecCode' with: [ 
		spec
			repository: (self class environment at: #BaselineOfPharo) specRepository;
			className: 'BaselineOfSpec2';
			loads: #('Code' 'CodeTests') ]! !

!BaselineOfIDE methodsFor: 'actions' stamp: ''!
loadIceberg
	| pharoPluginClass |
	
	Metacello new
		baseline: 'Iceberg';
		repository: (self class environment at: #BaselineOfPharo) icebergRepository;
		onConflictUseLoaded;
		load.
	(Smalltalk classNamed: #Iceberg) enableMetacelloIntegration: true.
	
	pharoPluginClass := Smalltalk classNamed: #IcePharoPlugin.
	pharoPluginClass  addPharoProjectToIceberg.
	
	(Smalltalk classNamed: #BaselineOfSpec2) ifNotNil: [ :aClass | 
		pharoPluginClass
			addProjectNamed: 'pharo-spec2' 
			commit: (Smalltalk classNamed: #BaselineOfPharo) specReleaseCommit 
			baselines: #(BaselineOfSpec2).
		"Register baselines"
		Metacello new baseline: 'Spec2'; register.
		Metacello new baseline: 'SpecCore'; register ].
		
	(Smalltalk classNamed: #BaselineOfNewTools) ifNotNil: [ :aClass | 
		pharoPluginClass 
			addProjectNamed: 'pharo-newtools' 
			commit: (Smalltalk classNamed: #BaselineOfPharo) newToolsReleaseCommit 
			baselines: #(BaselineOfNewTools).
		"Register baselines"
		Metacello new baseline: 'NewTools'; register ].
		
	pharoPluginClass addIcebergProjectToIceberg.
	"Register baselines"
	Metacello new baseline: 'Tonel'; register.
	Metacello new baseline: 'LibGit'; register.
	Metacello new baseline: 'Iceberg'; register.	! !

!BaselineOfIDE methodsFor: 'actions' stamp: ''!
makeCalypsoDefaultBrowser

	(self class environment at: #ClyBrowserMorph) beAllDefault.! !

!BaselineOfIDE methodsFor: 'baseline' stamp: ''!
newTools: spec 

	spec baseline: 'NewTools' with: [
		spec 
			repository: (self class environment at: #BaselineOfPharo) newToolsRepository;
			loads: #('default') ].
! !

!BaselineOfIDE methodsFor: 'actions' stamp: ''!
postload: loader package: packageSpec

	| initializersEnabled repo gofer |

	"Ignore pre and post loads if already executed"
	Initialized = true ifTrue: [ ^ self ].

	Author fullName: self class name.
	
	"collect and process the standard tools registrations"
	Smalltalk tools initDefaultToolSet.
	
	initializersEnabled := MCMethodDefinition initializersEnabled.

	MCMethodDefinition initializersEnabled: false.
	
	repo := TonelRepository new
		directory: self packageRepository directory;
		yourself.
		
	gofer := Gofer it repository: repo.
	gofer package: #'RPackage-Tests'.
	gofer load.
	
	MCMethodDefinition initializersEnabled: initializersEnabled.
	
	Smalltalk cleanOutUndeclared. 

	Stdio stdout 
		nextPutAll: ' ------------ Obsolete ------------';
		lf;
		nextPutAll: SystemNavigation default obsoleteClasses asString;
		lf;
		nextPutAll: ' ............ Obsolete ............';
		lf.

	Smalltalk fixObsoleteReferences.
	
	EpMonitor current enable.
		
	Author reset.

	MCMethodDefinition initializersEnabled: initializersEnabled.
	
	self additionalInitialization.

	Initialized := true.! !

!BaselineOfIceberg commentStamp: ''!
Baseline for https://github.com/pharo-vcs/iceberg project!
!BaselineOfIceberg methodsFor: 'script' stamp: ''!
postLoad

	self resetKMRepository.
	(Smalltalk at: #Iceberg) bootstrap! !

!BaselineOfIceberg methodsFor: 'baseline' stamp: ''!
libgit: spec
	spec 
		baseline: 'LibGit' 
		with: [ 
			spec
				repository: 'github://pharo-vcs/libgit2-pharo-bindings:v2.2.4';
  				loads: 'default' ].
	spec  
		project: 'LibGit-Tests'
		copyFrom: 'LibGit'
		with: [ spec loads: #('tests') ]! !

!BaselineOfIceberg methodsFor: 'baseline' stamp: ''!
tonel: spec
	spec
		baseline: 'Tonel' 
		with: [ spec repository: 'github://pharo-vcs/tonel:v1.0.17' ]! !

!BaselineOfIceberg methodsFor: 'script' stamp: ''!
postLoadWithDirective: aDirective projectSpec: aSpec
	| repository |
	self resetKMRepository.

	"Getting the repository from metacello..."
	repository := aSpec repositories list first spec createRepository.

	"We only apply the bootstrap only of the repository is a github repository.
	This is because in Iceberg's CI, the repository is cloned before and the code is loaded using filetree, so we have no commit information here..."
	(repository isKindOf: MCGitHubRepository) ifFalse: [ ^ self ].

	(Smalltalk at: #Iceberg)
		bootstrapWithCommitId: repository commitId
		packageList: aSpec packageNames! !

!BaselineOfIceberg methodsFor: 'accessing' stamp: ''!
projectClass
	^ super projectClass 
	"this is breaking the bootstrap. Reverting it for now."
	"[ self class environment at: #MetacelloCypressBaselineProject ]
		on: NotFound
		do: [ super projectClass ]"! !

!BaselineOfIceberg methodsFor: 'script' stamp: ''!
resetKMRepository
	Smalltalk 
		at: #KMRepository 
		ifPresent: [ :class | class reset ]! !

!BaselineOfIceberg methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #common do: [ 
		spec postLoadDoIt: #postLoadWithDirective:projectSpec:.
		
		self tonel: spec.
		self libgit: spec.
		self ring2: spec.
		
		spec
			"iceberg"
			package: 'Iceberg';
			package: 'Iceberg-Plugin' with: [ spec requires: #('Iceberg' 'Iceberg-TipUI') ];
			package: 'Iceberg-Plugin-Metacello' with: [ spec requires: #('Iceberg-Plugin') ];
			package: 'Iceberg-Plugin-GitHub' with: [ spec requires: #('Iceberg-Plugin') ];
			package: 'Iceberg-Plugin-Pharo' with: [ spec requires: #('Iceberg-Plugin') ];
			package: 'Iceberg-Plugin-Migration' with: [ spec requires: #('Iceberg-Plugin') ];
			package: 'Iceberg-Metacello-Integration' with: [ spec requires: #('Iceberg')];
			package: 'Iceberg-TipUI' with: [ spec requires: #('Iceberg') ];
			package: 'Iceberg-Memory' with: [ spec requires: #('Iceberg') ];
			"tests"
			package: 'Iceberg-Tests' with: [ spec requires: #('Iceberg' 'Iceberg-Memory' 'Ring2') ];
			package: 'Iceberg-Tests-MetacelloIntegration' with: [ spec requires: #('Iceberg-Tests') ];
			package: 'Iceberg-UI-Tests' with: [ spec requires: #('Iceberg-TipUI' 'Iceberg-Tests')];
			package: 'Iceberg-Plugin-Migration-Tests' with: [ spec requires: #('Iceberg-Plugin-Migration' 'Iceberg-Tests') ];
			"libgit"
			package: 'Iceberg-Libgit' with: [ spec requires: #('Iceberg' 'LibGit') ];
			package: 'Iceberg-Libgit-Filetree' with: [ spec requires: #('Iceberg' 'Iceberg-Libgit') ];
			package: 'Iceberg-Libgit-Tonel' with: [ spec requires: #('Iceberg' 'Iceberg-Libgit' 'Tonel') ];
			"groups"
			group: 'default' with: #(
				minimal 
				'Iceberg-Metacello-Integration' 
				'Iceberg-TipUI'
				'Iceberg-Plugin' 
				'Iceberg-Plugin-Metacello'
				'Iceberg-Plugin-GitHub'
				'Iceberg-Plugin-Pharo'
				'Iceberg-Plugin-Migration');
			group: 'minimal' with: #(
				'Iceberg'
				'Iceberg-Libgit' 
				'Iceberg-Libgit-Tonel'
				'Iceberg-Libgit-Filetree');
			group: 'allTests' with: #(
				'Iceberg-Tests' 
				'Iceberg-Tests-MetacelloIntegration'
				'LibGit-Tests' 
				'Iceberg-UI-Tests'
				'Iceberg-Plugin-Migration-Tests' );
			group: 'development' with: #(default allTests) ].
! !

!BaselineOfIceberg methodsFor: 'baseline' stamp: ''!
ring2: spec
	spec
		baseline: 'Ring2'
		with: [ spec repository: 'github://guillep/Ring2:v2.0.0/src' ]! !

!BaselineOfIceberg methodsFor: 'accessing' stamp: ''!
customProjectAttributes
	Smalltalk os isMacOS ifTrue: [ ^ #(#MacOS) ].
	Smalltalk os isUnix ifTrue: [ ^ #(#Unix) ].
	Smalltalk os isWindows ifTrue: [ ^ #(#Windows) ]! !

!BaselineOfKernelTests methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 	'CodeImport-Tests'	; 

			package: 	'Collections-Abstract-Tests';					
			package: 	'Collections-Atomic-Tests';
			package:	'Collections-Sequenceable-Tests';
			package: 	'Collections-Stack-Tests';	
			package: 	'Collections-Streams-Tests';		
			package: 	'Collections-Strings-Tests';	
			package: 	'Collections-Support-Tests';								
			package: 	'Collections-Unordered-Tests';
			package: 	'Collections-Weak-Tests' with: [ spec requires: #('Collections-Unordered-Tests') ];					
			package: 	'Collections-Tests' with: [ spec requires: #('Collections-Abstract-Tests' 'Collections-Atomic-Tests' 'Collections-Sequenceable-Tests'  
					   'Collections-Streams-Tests' 'Collections-Strings-Tests' 'Collections-Support-Tests' 'Collections-Stack-Tests' 'Collections-Weak-Tests') ];
			package: 	'Kernel-Tests'; 
			package: 	'Kernel-Tests-Extended' ;
			package: 	'Kernel-Tests-WithCompiler';
			package: 	'Announcements-Core-Tests';
			package: 	'Compression-Tests'; 
			package: 	'FileSystem-Tests-Core' with: [ spec requires: #('Collections-Tests') ];
			package: 	'FileSystem-Tests-Disk';
			package: 	'FileSystem-Tests-Attributes';
			package: 	'Files-Tests' ;
			package: 	'Jobs-Tests' ;
			package: 	'OpalCompiler-Tests'; 
			package: 	'Random-Tests';
			package: 	'Ring-Definitions-Tests-Core';
			package: 	'Ring-Definitions-Tests-Containers'; 
			package: 	'System-Object Events-Tests';
			package: 	'System-OSEnvironments-Tests';
			package: 	'Zinc-Character-Encoding-Tests' ;
			package: 	'System-Platforms-Tests';
			package: 	'Text-Tests' ]! !

!BaselineOfKeymapping methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #common do: [ 
		spec 
			package: 'Keymapping-Core';
			package: 'Keymapping-KeyCombinations';
			package: 'Keymapping-Pragmas';
			package: 'Keymapping-Settings';
			package: 'Keymapping-Tools-Spec';
			package: 'Keymapping-Tests'.
		
		spec 
			group: 'default' with: #('core' 'ui' 'tests'); 
			group: 'core' with: #('Keymapping-Core' 'Keymapping-KeyCombinations' );
			group: 'morphic' with: #('core' 'Keymapping-Pragmas' 'Keymapping-Settings');
			group: 'spec' with: #('core' 'Keymapping-Tools-Spec');
			group: 'ui' with: #('core' 'morphic' 'spec');
			group: 'tests' with: #(
				'core' 
				'Keymapping-Tests') ]! !

!BaselineOfKeymapping methodsFor: 'accessing' stamp: ''!
project
	| aProject |
	
	aProject := super project.
	aProject loadType: #atomic.

	^ aProject! !

!BaselineOfLibGit methodsFor: 'baseline' stamp: ' 1/5/2022 21:01:26'!
baseline: spec
  <baseline>
  spec
    for: #(common)
    do: [ 
      spec
		  postLoadDoIt: #'postload:package:';
    	  package: 'LibGit-FileSystem' with: [ spec requires: 'LibGit-Core' ];    
		  package: 'LibGit-Tests' with: [ spec requires: 'LibGit-Core' ];
        package: 'LibGit-GT' with: [ spec requires: 'LibGit-Core' ];
        package: 'LibGit-Patches' with: [ spec requires: 'LibGit-Core' ];
        package: 'LibGit-Core'.
      spec
        group: 'default'
        with: #('LibGit-Core' 'LibGit-FileSystem').
		spec
			group: 'development'
			with: #('default' 'LibGit-Tests' 'LibGit-Patches' 'LibGit-GT').
		spec
			group: 'tests'
			with: #('LibGit-Tests').

		spec
			for: #'pharo7.x'
			do: [ spec
						package: 'LibGit-Compatibility-Pharo7';
			         group: 'default'
        					with: #('LibGit-Core' 'LibGit-FileSystem' 'LibGit-Compatibility-Pharo7')] ]
! !

!BaselineOfLibGit methodsFor: 'actions' stamp: ' 1/5/2022 21:01:26'!
postload: loader package: packageSpec
	"we need to initialize the FFICompilerPlugin as we added methods with <ffiCalloutTranslator>"
	FFICompilerPlugin initialize! !

!BaselineOfManifest methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #'common' do: [
			
		spec 
			package: 'Manifest-Core';
			package: 'Manifest-Resources-Tests';
			package: 'Manifest-Tests'.
		spec 
			group: 'Core' with: #('Manifest-Core');
			group: 'Tests' with: #('Manifest-Resources-Tests' 'Manifest-Tests');
			group: 'default' with: #('Core' 'Tests') ]! !

!BaselineOfMenuRegistration commentStamp: ''!
Baseline managing the MenuRegistration project for the Pharo bootstrap.

Load type: 
- linear!
!BaselineOfMenuRegistration methodsFor: 'baseline' stamp: ''!
baseline: spec 
	<baseline>
	
	spec for: #common do: [
	
		spec package: 'MenuRegistration'.
		
	].
! !

!BaselineOfMetacello methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>

	spec for: #common do: [
		spec 
			package: 'ScriptingExtensions';
			package: 'System-FileRegistry';
			package: 'FileSystem-Memory';
			package: 'Regex-Core';
			package: 'StartupPreferences';
			package: 'ConfigurationCommandLineHandler-Core';
			package: 'PragmaCollector';
			package: 'System-FileRegistry';
			package: 'MonticelloConfigurations';
			package: 'Gofer-Core';
			package: 'Metacello-Base';
			package: 'Metacello-Core';
			package: 'MonticelloFileTree-Core';
			package: 'Metacello-MC';
			package: 'Metacello-PharoCommonPlatform';
			package: 'MonticelloFileTree-FileSystem-Utilities';
			package: 'STON-Core';
			package: 'Metacello-GitBasedRepository';
			package: 'Metacello-GitHub';
			package: 'Metacello-Gitlab';
			package: 'Metacello-Bitbucket';
			package: 'Metacello-Platform';
			package: 'Metacello-ToolBox';
			package: 'Metacello-PharoExtensions';
			package: 'MetacelloCommandLineHandler-Core'. 

		spec 
			package: 'Metacello-TestsMCResources';
			package: 'Metacello-TestsCore';
			package: 'Metacello-TestsCommonMC';
			package: 'Metacello-TestsMC';	"standalone"
			package: 'Metacello-TestsMCCore';	"standalone"
			package: 'Metacello-TestsPlatform';	"standalone"
			package: 'Metacello-TestsReference';	"standalone"
			package: 'Metacello-Gitlab-Tests'.

		spec 
			group: 'Core' with: #('ScriptingExtensions' 'System-FileRegistry' 'FileSystem-Memory' 'Regex-Core' 'StartupPreferences' 'ConfigurationCommandLineHandler-Core' 'PragmaCollector' 'System-FileRegistry' 'MonticelloConfigurations' 'Gofer-Core' 'Metacello-Base' 'Metacello-Core' 'MonticelloFileTree-Core' 'Metacello-MC' 'Metacello-PharoCommonPlatform' 'MonticelloFileTree-FileSystem-Utilities' 'STON-Core' 'Metacello-GitBasedRepository' 'Metacello-GitHub' 'Metacello-Gitlab' 'Metacello-Bitbucket' 'Metacello-Platform' 'Metacello-ToolBox' 'Metacello-PharoExtensions' 'MetacelloCommandLineHandler-Core');
			group: 'Tests' with: #( 'Metacello-TestsMCResources' 'Metacello-TestsCore' 'Metacello-TestsCommonMC' 'Metacello-TestsMC' 'Metacello-TestsMCCore' 'Metacello-TestsPlatform' 'Metacello-TestsReference' 'Metacello-Gitlab-Tests');
			group: 'default' with: #('Core') ]			
			

! !

!BaselineOfMicrodown commentStamp: ''!
Microdown is a minimal but extensible markup language. It is kind of compatible with githubmarkdown for a core set of feature. 
Read comment of MicroDownParser. !
!BaselineOfMicrodown methodsFor: 'baselines' stamp: ''!
baseline: spec

	<baseline>
	spec for: #common do: [ 
		spec
			package: #Microdown;
			package: #'Microdown-Tests'
				with: [ spec requires: #( #Microdown ) ];
		
			package: #'Microdown-Pharo-Tools'
				with: [ spec requires: #( #Microdown ) ];
				
			package: #'Microdown-MicrodownRichTextComposer'
				with: [ spec requires: #( #Microdown ) ];

			package: #'Microdown-Transformer'
				with: [ spec requires: #( #Microdown ) ];
			package: #'Microdown-Transformer-Tests'
				with: [ spec requires: #( #'Microdown-Transformer' ) ];

			package: #'Microdown-Evaluator'
				with: [ spec requires: #( #'Microdown-Transformer' ) ];
			package: #'Microdown-Evaluator-Tests'
				with: [ spec requires: #( #'Microdown-Evaluator' ) ];
				
			package: #'Microdown-LaTeXExporter'
				with: [ spec requires: #( #Microdown ) ];

			package: #'Microdown-LaTeXExporter-Tests'
				with: [ spec requires: #( #'Microdown-LaTeXExporter' #'Microdown-Tests') ];

			package: #'Microdown-PrettyPrinter'
				with: [ spec requires: #( #Microdown ) ];

			package: #'Microdown-PrettyPrinter-Tests'
				with: [ spec requires: #( #'Microdown-PrettyPrinter' #'Microdown-Tests') ].
	
		"I do not want group without tests for now"
		spec
			group: 'Core' 
			with: #(
				#'Microdown'
				#'Microdown-Tests'
				);
			group: 'RichText' with: #('Core' #'Microdown-MicrodownRichTextComposer' );
			group: 'Extensions' 
			with: #(   
				#'Microdown-Evaluator'
				#'Microdown-Evaluator-Tests'
				#'Microdown-PrettyPrinter'
				#'Microdown-PrettyPrinter-Tests'
				#'Microdown-LaTeXExporter'
				#'Microdown-LaTeXExporter-Tests'
				#'Microdown-Transformer'
				#'Microdown-Transformer-Tests');
			group: 'All' 
			with: #('Core' 'Extensions' #'Microdown-Pharo-Tools' 'RichText')  ]! !

!BaselineOfMisc methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'PharoDocComment';
			package: 'STON-Text support';
			package: 'System-CommandLine-TextSupport';
			package: 'System-Serial Port';
			package: 'PerformMessageCommandLineHandler';
			package: 'Files-Prompt'. ]! !

!BaselineOfMonticello commentStamp: ''!
This baseline is used to store information about Monticello packages. It is not directly used for the packages loading during bootstrap.!
!BaselineOfMonticello methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>

	spec for: #common do: [
		spec 
			package: 'Ring-Definitions-Core';
			package: 'Ring-Definitions-Containers';
			package: 'Ring-OldChunkImporter';
			package: 'Zinc-Resource-Meta-Core';
			package: 'System-Changes';
			package: 'Compression';
			package: 'Monticello';
			package: 'Ring-Definitions-Monticello';
			package: 'System-Model';
			
			package: 'Network-Kernel';
			package: 'Network-MIME';
			package: 'Network-Protocols';
			package: 'MonticelloRemoteRepositories';
			package: 'Zinc-HTTP';
			package: 'Zinc-FileSystem';
			package: 'Zodiac-Core'.
		spec 
			group: 'Core' with: #('Ring-OldChunkImporter' 'Zinc-Resource-Meta-Core' 'System-Changes' 'Ring-Definitions-Core' 'Ring-Definitions-Containers' 'Compression' 'Monticello' 'Ring-Definitions-Monticello' 'System-Model');
			group: 'RemoteRepositories' with: #( 'Network-Kernel' 'Network-MIME' 'Network-Protocols' 'MonticelloRemoteRepositories' 'Zinc-HTTP' 'Zinc-FileSystem' 'Zodiac-Core' );

			group: 'default' with: #('Core' 'RemoteRepositories' ). ].		
! !

!BaselineOfMonticello class methodsFor: 'accessing' stamp: ''!
corePackageNames

	^ self packagesOfGroupNamed: #Core! !

!BaselineOfMonticello class methodsFor: 'accessing' stamp: ''!
remoteRepositoriesPackageNames

	^ self packagesOfGroupNamed: #RemoteRepositories! !

!BaselineOfMorphic commentStamp: ''!
This baseline is used to generate Pharo images from the local clone of pharo-project/pharo repository. 

Depends on:
- BaselineOfMorphicCore

Load type: 
- atomic

Installs:
- Fuel
- Text and fonts support
- Morphic widgets
- Polymorph
- settings
- some other packages!
!BaselineOfMorphic methodsFor: 'fonts' stamp: ''!
loadBitmapFontFamily: familyName sizes: pointSizes
	| fonts fileName directoryReference |
	directoryReference := (Smalltalk os environment
		                       at: 'BOOTSTRAP_REPOSITORY'
		                       ifAbsent: [ FileSystem workingDirectory ])
		                      asFileReference / 'resources' / 'fonts'.
	fonts := pointSizes collect: [ :pointSize | 
		         | regular bold italic boldItalic |
		         fileName := familyName , ' ' , pointSize asString.
		         regular := STON fromStream:
			                    (directoryReference
			                     / (fileName , ' Regular.ston')) readStream.
		         regular setGlyphs: (PNGReadWriter formFromFileNamed:
				          (directoryReference / (fileName , ' Regular.png'))
					          fullName).
		         bold := STON fromStream:
			                 (directoryReference / (fileName , ' Bold.ston'))
				                 readStream.
		         bold setGlyphs: (PNGReadWriter formFromFileNamed:
				          (directoryReference / (fileName , ' Bold.png')) fullName).
		         italic := STON fromStream:
			                   (directoryReference
			                    / (fileName , ' Italic.ston')) readStream.
		         italic setGlyphs: (PNGReadWriter formFromFileNamed:
				          (directoryReference / (fileName , ' Italic.png'))
					          fullName).
		         boldItalic := STON fromStream:
			                       (directoryReference
			                        / (fileName , ' Bold Italic.ston'))
				                       readStream.
		         boldItalic setGlyphs: (PNGReadWriter formFromFileNamed:
				          (directoryReference / (fileName , ' Bold Italic.png'))
					          fullName).
		         regular instVarNamed: #derivativeFonts put: { 
				         bold.
				         italic.
				         boldItalic } , (Array new: 29).
		         bold instVarNamed: #derivativeFonts put: (Array new: 32).
		         italic instVarNamed: #derivativeFonts put: (Array new: 32).
		         boldItalic
			         instVarNamed: #derivativeFonts
			         put: (Array new: 32).
		         regular ].
	^ TextStyle fontArray: fonts! !

!BaselineOfMorphic methodsFor: 'fonts' stamp: ''!
loadBitmapDejaVuSans

	| dejaVu |

	dejaVu := self loadBitmapFontFamily: 'Bitmap DejaVu Sans' sizes: #(7 9 12 14 18 24).

	TextConstants TextSharedInformation at: #'DefaultTextStyle' put: dejaVu.
	TextConstants TextSharedInformation at: #'Bitmap DejaVu Sans' put: dejaVu.
	TextConstants TextSharedInformation at: #'DefaultMultiStyle' put: dejaVu.
	TextConstants TextSharedInformation at: #'DefaultFixedTextStyle' put: dejaVu.
! !

!BaselineOfMorphic methodsFor: 'baseline' stamp: ''!
baseline: spec 
    
	<baseline>
        
	| repository | 
	
	repository := self packageRepositoryURL.

	spec for: #common do: [
		spec preLoadDoIt: #'preload:package:'.
		spec postLoadDoIt: #'postload:package:'.

		spec 
			baseline: 'MorphicCore' with: [spec repository: repository];
			baseline: 'MenuRegistration' with: [spec repository: repository].

		spec baseline: 'Fuel' with: [ 
			spec repository: repository; loads: #('Core') ].

		spec package: 'System-Localization'.
		
		spec package: 'EmbeddedFreeType'.
		spec package: 'FileSystem-Zip'.
		spec package: 'Fonts-Infrastructure'.
		spec baseline: 'FreeType' with: [ 
			spec 
				repository: repository; 
				loads: 'ui' ].

		spec package: 'Graphics-Files'.
		spec package: 'Graphics-Fonts'.
		spec package: 'Graphics-Shapes'.
		spec package: 'Growl'.

		spec baseline: 'Keymapping' with: [ 
			spec 
				repository: repository;
				loads: 'core' ].

		spec package: 'Transcript-Core'.

		spec package: 'Native-Browser'.
		
		spec package: 'Morphic-Base'.
		spec package: 'Morphic-Examples'.
		spec package: 'Morphic-Widgets-Basic'.
		spec package: 'Morphic-Widgets-ColorPicker'.
		spec package: 'Morphic-Widgets-Extra'.
		spec package: 'Morphic-Widgets-List'.
		spec package: 'Morphic-Widgets-Pluggable'.
		spec package: 'Morphic-Widgets-PolyTabs'.
		spec package: 'Morphic-Widgets-Scrolling'.
		spec package: 'Morphic-Widgets-Tabs'.
		spec package: 'Morphic-Widgets-Taskbar'.
		spec package: 'Morphic-Widgets-Menubar'.
		spec package: 'Morphic-Widgets-Tree'.
		spec package: 'Morphic-Widgets-Windows'.
		spec package: 'Morphic-Widgets-FastTable'.
		
		spec package: 'Morphic-Widgets-Taskbar-Tests'.
		
		"Several packages depend on Rubric as a basic Morphic component"
		spec package: 'Rubric'.
		
		spec package: 'NewValueHolder-Core'.

		spec package: 'Polymorph-Widgets'.
		
		spec package: 'Images-Animated'.

		spec package: 'Settings-Graphics'.
		spec package: 'Settings-Polymorph'.
		spec package: 'Settings-System'.

		spec package: 'System-History'.
		spec package: 'System-Installers'.
		spec package: 'System-Settings-Core'.
		spec package: 'System-Settings-Browser'.
		"the following package is listed here to be after Setting core 
		however conceptually it could be placed somewhere else."
		spec package: 'Formatter-Settings'.
		spec package: 'System-Sound'.
		
		spec package: 'Text-Diff'.
		spec package: 'Text-Edition'.
		spec package: 'Text-Scanning'.

		spec package: 'Unicode-Initialization'.

		spec package: 'Morphic-Widgets-TickList'.
		
		spec package: 'System-Changes-FileServices'.

		spec package: 'StartupPreferences'.
		spec package: 'System-Identification'.
		
		"Tool-Base extends and uses morphic, so it depends on it"
		spec package: 'Tool-Base'.

	].
! !

!BaselineOfMorphic methodsFor: 'baseline' stamp: ''!
project
	
	| aProject |
	
	aProject := super project.
	aProject loadType: #atomic.
	^ aProject.
	! !

!BaselineOfMorphic methodsFor: 'actions' stamp: ''!
preload: loader package: packageSpec

	"Ignore pre and post loads if already executed"
	Initialized = true ifTrue: [ ^ self ].

	SystemNotification signal: 'Starting preload action'.
	
	initializersEnabled := MCMethodDefinition initializersEnabled.
	MCMethodDefinition initializersEnabled: false.
	
	Author fullName: self class name! !

!BaselineOfMorphic methodsFor: 'fonts' stamp: ''!
exportBitmapDejaVuSans

	| familyName styleNames pointSizes family font fileName fontCopy style |

	familyName := 'Bitmap DejaVu Sans'.
	styleNames := #('Regular' 'Bold' 'Italic' 'Bold Italic').
	pointSizes := #(7 9 12 14 18 24).

	family := LogicalFontManager current allFamilies detect: [ :f | 
		f familyName = 	familyName ] ifNone: [  ].

	pointSizes do: [ :pointSize | 
		styleNames do: [ :styleName |

			style := family members detect: [ :m | m styleName = styleName ].
			font := style asLogicalFontOfPointSize: pointSize.
			font := font realFont.

			fileName := font familyName, ' ', pointSize asString, ' ', styleName.

			font glyphs writePNGFileNamed: fileName, '.png'.

			fontCopy := font copy.
			fontCopy instVarNamed: #derivativeFonts put: nil.
			fontCopy setGlyphs: fileName.

			STON put: fontCopy onStream: (fileName, '.ston') asFileReference writeStream ]].
! !

!BaselineOfMorphic methodsFor: 'fonts' stamp: ''!
loadBitmapSourcePro

	| sansPro codePro |

	sansPro := self loadBitmapFontFamily: 'Bitmap Source Sans Pro' sizes: #(9 10 11 12 14 18 24).
	TextConstants TextSharedInformation at: #'Bitmap Source Sans Pro' put: sansPro.

	codePro := self loadBitmapFontFamily: 'Bitmap Source Code Pro' sizes: #(9 10 11 12 14 18 24).
	TextConstants TextSharedInformation at: #'Bitmap Source Code Pro' put: codePro.
! !

!BaselineOfMorphic methodsFor: 'actions' stamp: ''!
postload: loader package: packageSpec

	| array |
	
	"Ignore pre and post loads if already executed"
	Initialized = true ifTrue: [ ^ self ].

	SystemNotification signal: 'Starting postload action'.

	Smalltalk cleanOutUndeclared.
	Author fullName: self class name.

	TextConstants initialize.
		
	"Initialize Fuel"
	FLLargeIdentityHashedCollection initialize.
	FLPlatform reset.

	Stdio stdout nextPutAll: 'starting...'; lf.

	Stdio stdout nextPutAll: Smalltalk ui asString; lf.

	SparseLargeTable recompile. 
	
	PNGReadWriter initialize.
	self loadBitmapDejaVuSans.
	self loadBitmapSourcePro.
	
	#(TextStyle) do: [:each | (Smalltalk globals at: each) initialize. ].
	
	Stdio stdout nextPutAll: 'bitmap fonts loaded' asString; lf.

	#(ProgressBarMorph BalloonEngineConstants BalloonEngine 
	CornerRounder  DigitalSignatureAlgorithm DummySoundSystem
	FT2Types FT2FFILibrary
	FreeTypeCacheConstants FreeTypeCache FreeTypeSettings 
	FreeTypeSubPixelAntiAliasedGlyphRenderer FT2Constants FT2Handle 
	GIFReadWriter GlobalIdentifier
	HaloMorph CharacterScanner ImageMorph JPEGHuffmanTable
	JPEGReadStream JPEGReadWriter Locale
	MczInstaller MD5NonPrimitive MenuItemMorph MenuMorph  
	RxMatcher RxParser RxsPredicate
	SHA1 ShortIntegerArray
	SystemProgressMorph SystemWindow TestCase TextContainer TextDiffBuilder
	ThemeIcons ThumbnailMorph TransferMorph UITheme ZnByteEncoder
	ZnConstants ZnMimeType ZnNetworkingUtils ZnServer ZnSingleThreadedServer
	) do: [:each | (Smalltalk globals at: each) initialize. ].

	BalloonMorph setBalloonColorTo: Color yellow.

	UIManager default terminateUIProcess.
	MorphicUIManager new spawnNewProcess.
	Display newDepth: 32.
	
	UIManager default: MorphicUIManager new.
	UIManager default uiProcess resume.
	PharoLightTheme beCurrent.
	self cleanUpAfterMorphicInitialization.

	GraphicFontSettings setFontsToStyleNamed: #small.

	"Install the right UIManager"
	UIManager default: UIManager forCurrentSystemConfiguration.
	Stdio stdout nextPutAll: 'UIManager changed:' ; nextPutAll: UIManager default class name ; lf.

	TextEditor initialize.

	MenubarMorph initialize.	

	PolymorphSystemSettings showDesktopLogo: false.
	PolymorphSystemSettings showDesktopLogo: true.
	PolymorphSystemSettings desktopColor: Color white.

	Smalltalk cleanOutUndeclared.

	#(#AbstractFont #BalloonMorph #Clipboard #EditorFindReplaceDialogWindow #EmbeddedFreeTypeFontInstaller #FLCompiledMethodCluster #FLLargeIdentityHashedCollection #FLPlatform #FreeTypeFontProvider #GradientFillStyle #IconicButtonMorph #KMLog #LogicalFont #LucidaGrandeRegular #OSEnvironment #ScrollBarMorph #StrikeFont #SystemSettingsPersistence #TabMorph #TaskbarMorph #Text #TextAction #TextConstants #TextEditor #TextStyle) do: [:each |
		 (Smalltalk globals at: each) initialize. ].

	LogicalFontManager current addFontProvider: FreeTypeFontProvider current.

	array := Smalltalk specialObjectsArray copy.
	array at: 5 put: Bitmap.
	Smalltalk specialObjectsArray becomeForward: array.

	Author reset.
	MCMethodDefinition initializersEnabled: initializersEnabled.

	UIManager default restoreDisplay.
	
	Initialized := true.! !

!BaselineOfMorphic methodsFor: 'actions' stamp: ''!
cleanUpAfterMorphicInitialization

	Author fullName: self class name.
	MCDataStream initialize.
	GradientFillStyle initPixelRampCache.
	FreeTypeCache clearCurrent.
	ImageMorph classPool at: #DefaultForm put: (Form extent: 1 @ 1 depth: 1).
	Behavior flushObsoleteSubclasses.
	World cleanseOtherworldlySteppers.
	Smalltalk organization removeEmptyCategories.
	MCFileBasedRepository flushAllCaches.
	MCMethodDefinition shutDown.
	ExternalDropHandler resetRegisteredHandlers.
	Undeclared removeUnreferencedKeys.
	Smalltalk globals flushClassNameCache.
	ScrollBarMorph initializeImagesCache.

	3 timesRepeat: [ 
		Smalltalk garbageCollect.
	 	Symbol compactSymbolTable ].
	 	HashedCollection rehashAll.
	  
	  "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.
	ChangeSet removeChangeSetsNamedSuchThat: [ :each | true ].
	ChangeSet resetCurrentToNewUnnamedChangeSet.
	Smalltalk garbageCollect.
	Author reset.! !

!BaselineOfMorphicCore commentStamp: ''!
This baseline is used to generate Pharo images from the local clone of pharo-project/pharo repository. 

Depends on:
- SUnit, Display, UnifiedFFI

Load type: 
- linear

Installs:
- minimal working Morphic subset without fonts support!
!BaselineOfMorphicCore methodsFor: 'baseline' stamp: ''!
baseline: spec 
    
	<baseline>

	| repository | 
	
	repository := self packageRepositoryURL.

	spec for: #common do: [
		spec postLoadDoIt: #'postload:package:'.

		spec baseline: 'Traits' with: [spec repository: repository].
		spec baseline: 'SUnit' with: [spec repository: repository].
		spec baseline: 'Display' with: [spec repository: repository].
		spec baseline: 'UnifiedFFI' with: [spec repository: repository].

		spec package: 'System-Object Events'.
		spec package: 'Collections-DoubleLinkedList'.
		spec package: 'System-Caching'.
		spec package: 'Graphics-Canvas'.
		spec package: 'FormCanvas-Core'.
		spec package: 'Tool-Registry'.
		spec package: 'Fonts-Abstract'.
		spec package: 'Text-Core'.
		spec package: 'Morphic-Core'.
	].! !

!BaselineOfMorphicCore methodsFor: 'actions' stamp: ''!
postload: loader package: packageSpec

	| world hand |

	"Ignore pre and post loads if already executed"
	Initialized = true ifTrue: [ ^ self ].
	
	IdentityTransform initialize.

	RealEstateAgent initialize.
	WorldState initialize.
	Morph initialize.
	HandMorph initialize.
	
	AbstractWorldRenderer initialize.	

	Cursor initTarget.
	EventManager initialize.

	world := WorldMorph new.
	world instVarNamed: #worldState put: WorldState new.
	hand := HandMorph new.
	world addHand: hand.
	world activeHand: hand.

	Smalltalk at: #World put: world.
	Smalltalk at: #ActiveWorld put: world.

	world viewBox: Display boundingBox.
	
	world handsDo: [:h | h initForEvents].
	world borderWidth: 0.
	
	Display newDepth: 32.
	world displayWorldSafely.
	MorphicCoreUIManager new spawnNewProcess.
	
	world cleanseOtherworldlySteppers.
	ExternalDropHandler resetRegisteredHandlers.

	Display newDepth: 32.

	(world instVarNamed: #worldState) invalidate.

	hand instVarNamed: #targetOffset put: 0@0.

	WorldMorph initialize.
	ExternalDropHandler initialize.
	PasteUpMorph initialize.
	DefaultExternalDropHandler initialize.
	
	WorldMorph recompile.

	Initialized := true.! !

!BaselineOfNewTools methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>

	spec for: #common do: [
		spec preLoadDoIt: #'preload:package:'.
		spec postLoadDoIt: #'postload:package:'.

		self sindarin: spec.

		spec
			package: 'NewTools-Core';
			package: 'NewTools-Morphic';
			package: 'NewTools-Gtk';
			"Basic tools (inherited from Spec)"
			package: 'NewTools-MethodBrowsers';
			package: 'NewTools-ChangeSorter';
			package: 'NewTools-KeymapBrowser';
			"inspector"
			package: 'NewTools-Inspector' with: [ spec requires: #('NewTools-Inspector-Extensions') ];
			package: 'NewTools-Inspector-Extensions' with: [ spec requires: #('NewTools-Core') ];
			package: 'NewTools-Inspector-Tests' with: [ spec requires: #('NewTools-Inspector') ];
			"debugger"
			package: 'NewTools-Debugger' with: [ spec requires: #('NewTools-Inspector' 'NewTools-Debugger-Commands' 'NewTools-Debugger-Extensions' 'NewTools-SpTextPresenterDecorators') ];			
			package: 'NewTools-Debugger-Commands';
			package: 'NewTools-Debugger-Extensions';
			package: 'NewTools-Debugger-Tests' with: [ spec requires: #('NewTools-Debugger') ];
			"playground"
			package: 'NewTools-Playground' with: [ spec requires: #('NewTools-Inspector') ];
			package: 'NewTools-Playground-Tests' with: [ spec requires: #('NewTools-Playground') ];
			"browser"
			package: 'NewTools-SystemBrowser' with: [ spec requires: #('NewTools-Inspector') ];
			"system reporter"
			package: 'NewTools-SystemReporter' with: [ spec requires: #('NewTools-Core') ];
			"spotter"
			package: 'NewTools-Spotter-Processors';
			package: 'NewTools-Spotter' with: [ spec requires: #('NewTools-Core' 'NewTools-Spotter-Processors') ];
			package: 'NewTools-Spotter-Extensions' with: [ spec requires: #('NewTools-Spotter') ];
			package: 'NewTools-Spotter-Processors-Tests' with: [ spec requires: #('NewTools-Spotter-Processors') ];
			package: 'NewTools-Spotter-Tests' with: [ spec requires: #('NewTools-Spotter') ];
			package: 'NewTools-Morphic-Spotter' with: [ spec requires: #('NewTools-Morphic') ];
			"extras"
			package: 'HelpCenter' with: [ spec requires: #('NewTools-Core') ];
			package: 'NewTools-FlagBrowser' with: [ spec requires: #('NewTools-Core') ];
			package: 'NewTools-FlagBrowser-Tests' with: [ spec requires: #('NewTools-FlagBrowser') ];
			package: 'NewTools-FileDialog' with: [ spec requires: #('NewTools-Core') ];
			package: 'NewTools-FileDialog-Tests' with: [ spec requires: #('NewTools-FileDialog') ];
			package: 'NewTools-SpTextPresenterDecorators';
			package: 'NewTools-Debugger-Breakpoints-Tools' with: [ spec requires: #('NewTools-Inspector') ];
			package: 'NewTools-ProjectLoader';
			package: 'NewTools-ProjectLoader-Microdown';
			"Object-centric breakpoints"
			package: 'NewTools-ObjectCentricBreakpoints';			
			"Sindarin"
			package: 'NewTools-Sindarin-Commands';
			package: 'NewTools-Sindarin-Commands-Tests' with: [  spec requires: #('NewTools-Sindarin-Commands' 'Sindarin') ];
			package: 'NewTools-Sindarin-Tools' with: [ spec requires: #('NewTools-Sindarin-Commands' 'Sindarin') ];
			"package: 'NewTools-Sindarin-ProcessInspector' with: [ spec requires: #('NewTools-Sindarin-Commands' 'Sindarin') ];"
			"Debugger Selector"
			package: 'NewTools-DebuggerSelector' with: [ spec requires: #('NewTools-SpTextPresenterDecorators') ];
			package: 'NewTools-DebuggerSelector-Tests' with: [ spec requires: #('NewTools-DebuggerSelector') ];
			
			"Fuel"
			package: 'NewTools-Debugger-Fuel';
			package: 'NewTools-Debugger-Fuel-Tests' with: [ spec requires: #('NewTools-Debugger-Fuel') ];
			package: 'NewTools-Fuel'.

		spec
			group: 'Core' with: #('NewTools-Core' 'NewTools-Morphic');
			group: 'Playground' with: #('Core' 'NewTools-Playground' 'NewTools-Playground-Tests');
			group: 'Inspector' with: #('Core' 'NewTools-Inspector' 'NewTools-Inspector-Tests');
			group: 'Debugger' with: #(
				'Core' 
				'Inspector' 
				'NewTools-Debugger-Commands'
				'NewTools-Debugger-Extensions'
				'NewTools-Debugger' 
				'NewTools-ObjectCentricBreakpoints'
				'NewTools-Sindarin-Tools'
				'NewTools-Sindarin-Commands'
				'NewTools-Sindarin-Commands-Tests'
				'NewTools-Debugger-Breakpoints-Tools'
				'NewTools-Debugger-Tests'
				'NewTools-Debugger-Fuel'
				'NewTools-Debugger-Fuel-Tests'
				'NewTools-Fuel');
			group: 'Spotter' with: #(
				'NewTools-Morphic-Spotter' 
				'NewTools-Spotter-Processors' 
				'NewTools-Spotter' 
				'NewTools-Spotter-Extensions'
				'NewTools-Spotter-Tests'
				'NewTools-Spotter-Processors-Tests');
			group: 'SystemReporter' with: #('Core' 'NewTools-SystemReporter');
			group: 'Methods' with: #('Core' 'NewTools-MethodBrowsers');
			"Not in the image for the moment, we need a pass on them"
			group: 'ChangeSorter' with: #('Core' 'NewTools-ChangeSorter');
			group: 'KeymapBrowser' with: #('Core' 'NewTools-KeymapBrowser');
			group: 'FlagBrowser' with: #(
				'Core' 
				'NewTools-FlagBrowser' 
				'NewTools-FlagBrowser-Tests');
			group: #development with: #('default'
				'NewTools-DebuggerSelector' 
				'NewTools-DebuggerSelector-Tests');
			group: #broken with: #(
				'NewTools-FileDialog' 
				'NewTools-FileDialog-Tests');
			group: 'default' with: #(
				'Playground' 
				'Inspector' 
				'Debugger' 
				'SystemReporter'
				'ChangeSorter'
				'Methods'
				'Spotter') ]! !

!BaselineOfNewTools methodsFor: 'external projects' stamp: ''!
sindarin: spec

	spec baseline: 'Sindarin' with: [ 
		spec
			repository: (self packageRepositoryURL 
				ifEmpty: [ 'github://pharo-spec/ScriptableDebugger:Pharo-10' ]);
			loads: 'Core' ]! !

!BaselineOfNewTools methodsFor: 'actions' stamp: ''!
preload: loader package: packageSpec

	initializersEnabled := MCMethodDefinition initializersEnabled.
	MCMethodDefinition initializersEnabled: true! !

!BaselineOfNewTools methodsFor: 'actions' stamp: ''!
postload: loader package: packageSpec

	MCMethodDefinition initializersEnabled: initializersEnabled! !

!BaselineOfNewTools methodsFor: 'external projects' stamp: ''!
packageRepositoryURL
	| url |
	
	url := super packageRepositoryURL.
	url ifEmpty: [ ^ url ].
	"Verify if I am running in CI"
	"travis or github actions"
	((url includesSubstring: 'pharo-spec') 
		or: [ url beginsWith: 'tonel:///home/runner/' ]) ifTrue: [ ^ '' ].
	
	^ url! !

!BaselineOfNewToolsDocumentationReader methodsFor: 'baselines' stamp: ''!
baseline: spec

	<baseline>
	spec for: #common do: [ 
		
		"spec
			baseline: 'Spec'
			with: [
				spec
					repository: 'github://pharo-spec/spec:dev/src' ]."
		spec
			baseline: 'Microdown'
			with: [
				spec
					loads: #('RichText');
					repository: 'github://Pillar-markup/Microdown:master/src' ].
		
		spec
			package: #'NewTools-DocumentationReader'
				with: [ spec requires: #( #'Microdown' ) ];
			package: #'NewTools-DocumentationReader-Tests'
				with: [ spec requires: #( #'NewTools-DocumentationReader') ]].
			
			
	! !

!BaselineOfNumericScales commentStamp: ''!
I am a baseline to load the object profile basic scales!
!BaselineOfNumericScales methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #common do: [
		spec 
			package: #'NumericInterpolator';
			package: #'NumericNoise';
			package: #'NumericInterpolator-Tests'.
		
		spec 
			group: 'Core' with: #(
				'NumericInterpolator'
				NumericNoise);
			group: 'Tests' with: #('Core' 'NumericInterpolator-Tests');
			group: 'default' with: #('Core' 'Tests') ].		
	






! !

!BaselineOfOSWindow methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'OSWindow-Core';
			package: 'OSWindow-SDL2';
			package: 'OSWindow-SDL2-Examples';
			package: 'OSWindow-Tests'.
		spec 
			group: 'Core' with: #('OSWindow-Core' 'OSWindow-SDL2' 'OSWindow-SDL2-Examples');
			group: 'Tests' with: #('OSWindow-Tests');
			group: 'default' with: #('Core' 'Tests') ]! !

!BaselineOfParametrizedTests methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #common do: [ spec package: #ParametrizedTests ]! !

!BaselineOfParametrizedTests class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #stable) load! !

!BaselineOfParametrizedTests class methodsFor: 'private' stamp: ''!
ensureMetacello

	(self baseConfigurationClassIfAbsent: []) ensureMetacello! !

!BaselineOfParametrizedTests class methodsFor: 'metacello tool support' stamp: ''!
isMetacelloConfig
	"Answer true and the Metacello tools will operate on you"
	
	^true! !

!BaselineOfParametrizedTests class methodsFor: 'development support' stamp: ''!
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"

	<apiDocumentation>
	self ensureMetacello.
	^ ((self environment at: #MetacelloToolBox) validateConfiguration: self debug: #() recurse: false) inspect! !

!BaselineOfParametrizedTests class methodsFor: 'development support' stamp: ''!
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."
	<apiDocumentation>
! !

!BaselineOfParametrizedTests class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #bleedingEdge) load! !

!BaselineOfParametrizedTests class methodsFor: 'private' stamp: ''!
ensureMetacelloBaseConfiguration

	self environment
		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 ] ]! !

!BaselineOfParametrizedTests class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #development) load! !

!BaselineOfParametrizedTests class methodsFor: 'private' stamp: ''!
baseConfigurationClassIfAbsent: aBlock

	^self environment
		at: #MetacelloBaseConfiguration
		ifAbsent: [ 
			self ensureMetacelloBaseConfiguration.
			self environment at: #MetacelloBaseConfiguration ifAbsent: aBlock ].
! !

!BaselineOfPharo methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	| repository |
	repository := self packageRepositoryURL.

	spec for: #common do: [
		spec postLoadDoIt: #'postload:package:'.
		spec baseline: 'BaseLibraries' with: [spec repository: repository].
		
		spec baseline: 'IDE' with: [spec repository: repository].
		spec baseline: 'Calypso' with: [ 
			spec repository: repository; loads: #('IcebergSupport'). ].

		spec package: 'Deprecated90'.
		spec package: 'Deprecated10'.
		
		spec package: 'FluidClassBuilder'.
		spec package: 'FluidClassBuilder-Tests' with: [ spec requires: 'FluidClassBuilder' ].
	]! !

!BaselineOfPharo methodsFor: 'baseline' stamp: ''!
postload: loader package: packageSpec

	WelcomeHelp openForRelease! !

!BaselineOfPharo class methodsFor: 'versions' stamp: ''!
newToolsVersion

	^ 'Pharo10'! !

!BaselineOfPharo class methodsFor: 'repository urls' stamp: ''!
specRepository

	^ 'github://pharo-spec/Spec:{1}/src' format: { self specVersion }! !

!BaselineOfPharo class methodsFor: 'versions' stamp: ''!
specReleaseCommit
	"The commit corresponding to current release (to be used on bootstrap process)"

	"Pharo10- fix paginator in presence of fast dragging"
	^ '8fe65f1d49f090bb739ae6ef5113a05b4e89109f'! !

!BaselineOfPharo class methodsFor: 'repository urls' stamp: ''!
icebergRepository

	^ 'github://pharo-vcs/iceberg:{1}' format: { self icebergVersion }! !

!BaselineOfPharo class methodsFor: 'versions' stamp: ''!
newToolsReleaseCommit
	"The commit corresponding to current release (to be used on bootstrap process)"

	"Pharo10"
	^ '0a30d62222168b54ba9c12608bd10a7c1cfed6a1'! !

!BaselineOfPharo class methodsFor: 'versions' stamp: ''!
specVersion

	^ 'Pharo10'! !

!BaselineOfPharo class methodsFor: 'versions' stamp: ''!
icebergVersion

	^ 'dev-2.0'! !

!BaselineOfPharo class methodsFor: 'repository urls' stamp: ''!
newToolsRepository

	^ 'github://pharo-spec/NewTools:{1}/src' format: { self newToolsVersion }! !

!BaselineOfPharoBootstrap commentStamp: ''!
This baseline describes packages included in the bootstrapped Pharo image. 

It is not supposed to be part of bootstrapped image because it is dependent on Metacello.

This baseline includes several utility methods required to prepare data for the bootstrapping and initial image initialization.!
!BaselineOfPharoBootstrap methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>

	spec for: #common do: [
		spec package: 'AST-Core'.
		spec package: 'Announcements-Core'.
		spec package: 'Colors'.
		spec package: 'Collections-Abstract'.
		spec package: 'Collections-Arithmetic'.
		spec package: 'Collections-Atomic'.
		spec package: 'Collections-Native'.
		spec package: 'Collections-Sequenceable'.
		spec package: 'Collections-Stack'.
		spec package: 'Collections-Streams'.
		spec package: 'Collections-Strings'.
		spec package: 'Collections-Support'.
		spec package: 'Collections-Unordered'.
		spec package: 'Collections-Weak'.
		spec package: 'Debugging-Core'.
		spec package: 'Files'.
		spec package: 'FileSystem-Path'.
		spec package: 'Hermes'.
		spec package: 'Hermes-Extensions'.

		spec package: 'Jobs'.
		spec package: 'Kernel'.
		spec package: 'Kernel-BytecodeEncoders'.
		spec package: 'Kernel-Chronology-Extras'.
		spec package: 'NumberParser'.

		spec package: 'Math-Operations-Extensions'.

		spec package: 'Multilingual-Encodings'.

		spec package: 'Network-UUID'.
		
		spec package: 'Transcript-NonInteractive'.
		spec package: 'PharoBootstrap-Initialization'.
		spec package: 'RPackage-Core'.
		spec package: 'Random-Core'.
		spec package: 'ReflectionMirrors-Primitives'.
		spec package: 'Shift-Changes'.
		spec package: 'Shift-ClassBuilder'.
		spec package: 'Shift-ClassInstaller'.
		spec package: 'Slot-Core'.
		spec package: 'System-Announcements'.
		spec package: 'System-BasicCommandLineHandler'.
		spec package: 'System-CommandLine'.
		spec package: 'System-CommandLineHandler'.
		spec package: 'System-Finalization'.
		spec package: 'System-Hashing'.
		spec package: 'System-Platforms'.
		spec package: 'System-SessionManager'.
		spec package: 'System-Sources'.
		spec package: 'System-SourcesCondenser'.
		spec package: 'System-Support'.

		spec package: 'UIManager'.
		spec package: 'Zinc-Character-Encoding-Core'.
		
		spec package: 'FFI-Kernel'.
				
		spec package: 'CodeExport'.
		spec package: 'CodeImport'.
		
		spec package: 'CodeImportCommandLineHandlers'.
		
		spec package: 'OpalCompiler-Core'.
		
		spec package: 'FileSystem-Core'.
		spec package: 'FileSystem-Disk'.

		spec package: 'SUnit-Core'.
		spec package: 'SUnit-Tests'.
		spec package: 'Kernel-Tests'.
		spec package: 'JenkinsTools-Core'.
		spec package: 'InitializePackagesCommandLineHandler'.
		

		spec group: 'KernelGroup' with: {
			'FFI-Kernel'.
			'Announcements-Core'.
			'Colors'.
			'Collections-Abstract'.
			'Collections-Native'.
			'Collections-Sequenceable'.
			'Collections-Stack'.
			'Collections-Streams'.
			'Collections-Strings'.
			'Collections-Support'.
			'Collections-Unordered'.
			'Collections-Weak'.
			'Files'.
			'FileSystem-Path'.
			'Hermes'.
			'Kernel'.
			'Kernel-BytecodeEncoders'.
			'Network-UUID'.
			'Transcript-NonInteractive'.
			'PharoBootstrap-Initialization'.
			'RPackage-Core'.
			'Random-Core'.
			'Shift-Changes'.
			'Shift-ClassBuilder'.
			'Shift-ClassInstaller'.
			'Slot-Core'.
			'System-Announcements'.
			'System-BasicCommandLineHandler'.
			'System-CommandLine'.
			'System-CommandLineHandler'.
			'System-Finalization'.
			'System-Hashing'.
			'System-Platforms'.
			'System-SessionManager'.
			'System-Sources'.
			'System-Support'.
			'NumberParser'.

			'UIManager'.
			'Zinc-Character-Encoding-Core' }.

		"These packages are added using hermes after bootstrap"

		spec group: 'AdditionalPackages' with: {
			'ReflectionMirrors-Primitives'.
			'InitializePackagesCommandLineHandler'.
			'Kernel-Chronology-Extras'.
			'Math-Operations-Extensions'.
			'Debugging-Core'.
		}.

		spec group: 'MultilingualGroup' with: {
			'Multilingual-Encodings' }.

		spec group: 'CompilerGroup' with: {
			'AST-Core'.
			'Collections-Arithmetic'.
			'Collections-Atomic'.
			'CodeExport'.
			'CodeImport'.
			'CodeImportCommandLineHandlers'.
			'Jobs'.
			'System-SourcesCondenser'.
			'OpalCompiler-Core'}.
		
		spec group: 'FileSystemGroup' with: {
			'FileSystem-Core'.
			'FileSystem-Disk'}.

		spec group: 'ToLoadByHermes' with: {
			'AdditionalPackages'.
			'MultilingualGroup'.
			'CompilerGroup'.
			'FileSystemGroup'.
			'Hermes-Extensions'.
			'SUnitGroup'.
		}.

		spec group: 'SUnitGroup' with: {
			'SUnit-Core'.
			'SUnit-Tests'.
			'Kernel-Tests'.
			'JenkinsTools-Core'}.

	]
! !

!BaselineOfPharoBootstrap class methodsFor: 'accessing' stamp: ''!
kernelPackageNames

	^ self packagesOfGroupNamed: #KernelGroup! !

!BaselineOfPharoBootstrap class methodsFor: 'traversing' stamp: ''!
packagesRecursiveIn: aGroupName

	| allMembers allPackagesInBaseline packages groups |
	allMembers := self version groups detect: [ :g | g name = aGroupName ].
	allPackagesInBaseline := self version packages collect: [ :each | each name ].
	packages := allMembers includes select: [ :aName | allPackagesInBaseline includes: aName ].
	groups := allMembers includes reject: [ :aName | allPackagesInBaseline includes: aName ].		
	^ packages , (groups flatCollect: [ :aInnerGroupName | self packagesRecursiveIn: aInnerGroupName ]).
! !

!BaselineOfPharoBootstrap class methodsFor: 'accessing' stamp: ''!
multilingualPackageNames

	^ self packagesOfGroupNamed: #MultilingualGroup! !

!BaselineOfPharoBootstrap class methodsFor: 'accessing' stamp: ''!
packagesToExportWithHermes

	^ self packagesRecursiveIn: 'ToLoadByHermes'! !

!BaselineOfPharoBootstrap class methodsFor: 'accessing' stamp: ''!
kernelAdditionalPackagesNames

	^ self packagesOfGroupNamed: #AdditionalPackages! !

!BaselineOfPharoBootstrap class methodsFor: 'accessing' stamp: ''!
sUnitPackageNames

	^ self packagesOfGroupNamed: #SUnitGroup! !

!BaselineOfPharoBootstrap class methodsFor: 'accessing' stamp: ''!
compilerPackageNames

	^ self packagesOfGroupNamed: #CompilerGroup! !

!BaselineOfPharoBootstrap class methodsFor: 'accessing' stamp: ''!
fileSystemPackageNames

	^ self packagesOfGroupNamed: #FileSystemGroup! !

!BaselineOfQA methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	| repository | 
	
	repository := self packageRepositoryURL.	
	
		spec for: #'common' do: [
			spec package: 'NautilusRefactoring'.
				
			spec package: 'Refactoring-Critics'.
			spec baseline: 'Manifest' with: [ spec repository: repository ].
			
			spec baseline: 'QualityAssistant' with: [ spec repository: repository ].
			spec baseline: 'DependencyAnalyzer' with: [ spec repository: repository ].

			spec 
				package: 'GeneralRules';
				package: 'GeneralRules-Tests';
				package: 'Kernel-Rules';
				package: 'ReleaseTests';
				package: 'NautilusRefactoring-Tests'.
			
			spec baseline: 'Reflectivity' with: [ 
				spec
					repository: repository;
					loads: #( 'tools' ) ]
			]! !

!BaselineOfQualityAssistant methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #'common' do: [
			
		spec 
			package: 'Tool-CriticBrowser';
			package: 'Renraku';
			package: 'Renraku-Tests';
			package: 'Renraku-Help'.
		spec 
			group: 'Core' with: #('Renraku' 'Tool-CriticBrowser');
			group: 'Tests' with: #('Renraku-Tests');
			group: 'Help' with: #('Renraku-Help');
			group: 'default' with: #('Core' 'Help' 'Tests') ]! !

!BaselineOfRefactoring methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'SUnit-Rules';
			package: 'Kernel-Tests-Rules';
			package: 'Polymorph-Widgets-Rules';
			package: 'System-Settings-Rules';
			package: 'GeneralRules';
			package: 'Rubric-Rules';

			package: 'Refactoring-Tests-Core';
			package: 'Refactoring-Tests-Changes';
			package: 'Refactoring-Tests-Critics';
			package: 'Refactoring-Tests-Environment';

			package: 'Refactoring-Help'.
		spec 
			group: 'Rules' with: #('SUnit-Rules' 'Kernel-Tests-Rules' 'Polymorph-Widgets-Rules' 'System-Settings-Rules' 'GeneralRules' 'Rubric-Rules');
			group: 'Tests' with: #('Refactoring-Tests-Core' 'Refactoring-Tests-Changes' 'Refactoring-Tests-Critics' 'Refactoring-Tests-Environment');
			group: 'Help' with: #('Refactoring-Help');
			group: 'default' with: #('Rules' 'Tests' 'Help') ]! !

!BaselineOfRefactoring2 methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'Refactoring2-Core';
			package: 'Refactoring2-Transformations';
			package: 'Refactoring2-Transformations-Tests'.
		spec 
			group: 'Core' with: #('Refactoring2-Core' 'Refactoring2-Transformations');
			group: 'Tests' with: #('Refactoring2-Transformations-Tests');
			group: 'default' with: #('Core' 'Tests') ]! !

!BaselineOfReferenceFinder methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'ReferenceFinder-Core'.
		spec 
			group: 'default' with: #('ReferenceFinder-Core') ]! !

!BaselineOfReflectionMirrors methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'ReflectionMirrors-Primitives-Tests' ]! !

!BaselineOfReflectivity methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec
		for: #common
		do: [ 
			spec postLoadDoIt: #'postload:package:'.
			
			spec
				package: 'Reflectivity';
				package: 'Reflectivity-Tools' with: [ spec requires: 'Reflectivity' ];
				package: 'Reflectivity-Tools-Tests' with: [ spec requires: 'Reflectivity-Tools' ];
				package: 'Reflectivity-Examples' with: [ spec requires: 'Reflectivity' ];
				package: 'Reflectivity-Tests' with: [ spec requires: #(Reflectivity 'Reflectivity-Tools') ].
		
		spec
				group: 'default' with: #('Reflectivity');
				group: 'tools' with: #('Reflectivity-Tools' 'Reflectivity-Tools-Tests');
				group: 'tests' with: #('default' 'tools' 'Reflectivity-Tests' 'Reflectivity-Examples') ]
		
	! !

!BaselineOfReflectivity methodsFor: 'baselines' stamp: ''!
postload: loader package: packageSpec
	ASTCache cacheMissStrategy: RFReflectivityASTCacheStrategy new.! !

!BaselineOfRing methodsFor: 'accessing' stamp: ''!
repository
	^ self packageRepositoryURL! !

!BaselineOfRing methodsFor: 'accessing' stamp: ''!
baseline: spec
	<baseline>
	spec for: #common
		do: [ 
	
			spec 
				package: 'Ring-Core';
				package: 'Ring-Monticello';
				package: 'Ring-ChunkImporter';
				package: 'Ring-Tests-Core';
				package: 'Ring-Tests-Monticello';
				package: 'Ring-Tests-ChunkImporter';
				package: 'Ring-TraitsV2Support';
				package: 'Ring-RuntimeSupport';
				package: 'Calypso-Ring' ]! !

!BaselineOfRoassal3 commentStamp: ''!
Baseline for https://github.com/ObjectProfile/Roassal3!
!BaselineOfRoassal3 methodsFor: 'baselines' stamp: ''!
dependencies: spec
	spec baseline: 'AthensSVG' with: [
		spec repository: 'github://pharo-contributions/Athens-SVG/src' ].
	spec package: 'Athens-SVG-PathConverter' with: [
		spec repository: 'github://pharo-contributions/Athens-SVG/src' ].
	spec baseline: 'Geometry' with: [ 
		spec repository: 'github://pharo-contributions/Geometry/src' ].
	spec baseline: 'NumericScales'with: [ 
		spec repository: 'github://ObjectProfile/NumericScales:v1.0/src' ].
	spec 
		baseline: 'OSSubprocess'
		with: [ spec repository: 'github://pharo-contributions/OSSubprocess/repository' ].! !

!BaselineOfRoassal3 methodsFor: 'API-packages' stamp: ''!
extraPackagesNames
	^ #(
	'Roassal3-Mondrian'
	'Roassal3-Experimental')! !

!BaselineOfRoassal3 methodsFor: 'baselines' stamp: ''!
baselineForPharo8: spec
	"https://github.com/ObjectProfile/Roassal3"
	self dependencies: spec.
	self registerPackages: spec.
	spec package: #'Roassal3-Pharo8'.
	self roassalGroups: spec 
		core: self corePackagesNames, #('Roassal3-Pharo8')
		examples: self examplePackagesNames
		tests: self testPackagesNames.! !

!BaselineOfRoassal3 methodsFor: 'API-packages' stamp: ''!
corePackagesNames
	^ #(
	'Roassal3-Event'
	'Roassal3-Builders'
	'Roassal3-Shapes'
	'Roassal3-Animation'
	'Roassal3-Interaction'
	'Roassal3-Layouts-Util'
	'Roassal3-Layouts'
	'Roassal3-Colors'
	'Roassal3-Legend'
	'Roassal3-UML'
	'Roassal3-Sunburst'
	'Roassal3-Pie'
	'Roassal3-Inspector'
	'Roassal3-Chart'
	'Roassal3-Menu'
	'Roassal3-Spec'
	'Roassal3-Spec-Morphic'
	'Roassal3-Spec-Obsolete'
	)! !

!BaselineOfRoassal3 methodsFor: 'baselines' stamp: ''!
baselineForCommon: spec
	"https://github.com/ObjectProfile/Roassal3"
	self dependencies: spec.
	self registerPackages: spec.
	self roassalGroups: spec 
		core: self corePackagesNames
		examples: self examplePackagesNames
		tests: self testPackagesNames.! !

!BaselineOfRoassal3 methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	"https://github.com/ObjectProfile/Roassal3"
	"pharo7 not supported"
	spec for: #'pharo8.x' do: [ self baselineForPharo8: spec ].
	spec for: #'pharo9.x' do: [ self baselineForPharo9: spec ].! !

!BaselineOfRoassal3 methodsFor: 'API-packages' stamp: ''!
examplePackagesNames
	^ #(
	'Roassal3-Examples'
	'Roassal3-Legend-Examples'
	'Roassal3-Chart-Examples'
	'Roassal3-Pie-Examples'
	'Roassal3-Sunburst-Examples'
	'Roassal3-UML-Examples'
	'Roassal3-Spec-Examples')! !

!BaselineOfRoassal3 methodsFor: 'baselines' stamp: ''!
baselineForPharo9: spec
	self baselineForCommon: spec! !

!BaselineOfRoassal3 methodsFor: 'baselines' stamp: ''!
roassalGroups: spec core: arr1 examples: arr2 tests: arr3
	| core |
	core := #('Core').
	spec 
		group: 'Core' with: #('Roassal3'), arr1;
		group: 'Examples' with: core, arr2;
		group: 'Tests' with: core, arr3;
		group: 'SVG' with: #('Core' 'Roassal3-SVG');
		group: 'SVGTests' with: #('SVG' 'Tests' 'Roassal3-SVG-Tests');
		group: 'SVGExamples' with: #('SVG' 'Examples' 'Roassal3-SVG-Examples');
		group: 'SVGImporter' with: #('SVG' 'SVGExamples' 'SVGTests' 'Roassal3-SVG-Importer');
		group: 'Gtk' with: #('Roassal3-Gtk' 'Roassal3-Spec-Gtk');
		
		group: 'Mini' with: #('SVGTests' 'SVGExamples');
		group: 'Full' with: #('Mini'), self extraPackagesNames;
		group: 'GraphViz' with: #('Full' 'Roassal3-GraphViz');
		group: 'Graphviz' with: #('Full' 'Roassal3-GraphViz');
		group: 'default' with: #('Core' 'Mini')









! !

!BaselineOfRoassal3 methodsFor: 'baselines' stamp: ''!
registerPackages: spec
	"The packages to use, but not load"
	spec package: #'Roassal3' with: [ spec requires: #('Geometry' 'NumericScales') ].
	self corePackagesNames, 
	self examplePackagesNames, 
	self testPackagesNames, 
	self extraPackagesNames do: [ :name | spec package: name ].
	
	spec		
		package: #'Roassal3-SVG' with: [ spec requires: #('Athens-SVG-PathConverter') ];
		package: #'Roassal3-SVG-Tests';
		package: #'Roassal3-SVG-Examples';
		package: #'Roassal3-SVG-Importer' with: [ spec requires: #('AthensSVG') ].
		
	spec package: #'Roassal3-GraphViz' with: [ spec requires: #('OSSubprocess') ].
	
	spec package: #'Roassal3-Gtk'.
	spec package: #'Roassal3-Spec-Gtk'.







! !

!BaselineOfRoassal3 methodsFor: 'API-packages' stamp: ''!
testPackagesNames
	^ #(
	'Roassal3-Global-Tests' 
	'Roassal3-Animation-Tests'
	'Roassal3-Shapes-Tests'
	'Roassal3-Interaction-Tests'
	'Roassal3-Layouts-Tests'
	'Roassal3-Chart-Tests'
	'Roassal3-UML-Tests'
	'Roassal3-Spec-Tests'
	'Roassal3-Inspector-Tests')! !

!BaselineOfSUnit commentStamp: ''!
This baseline is used to generate Pharo images from the local clone of pharo-project/pharo repository. 

Depends on:
- minimal Pharo image

Load type: 
- linear

Installs:
- SUnit without GUI!
!BaselineOfSUnit methodsFor: 'accessing' stamp: ''!
repository
	^ self packageRepositoryURL! !

!BaselineOfSUnit methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	spec for: #common
		do: [ 
	
			spec baseline: 'Traits' with: [
				spec loads: 'core'. 
				spec repository: self repository
			].
			
			spec
				package: 'SUnit-Core';
				package: 'SUnit-Core-Traits' with: [ spec requires: 'Traits' ];
				package: 'SUnit-Tests';
				package: 'SUnit-Visitor' with: [ spec requires: #('SUnit-Core') ];
				package: 'SUnit-Visitor-Tests' with: [ spec requires: #('SUnit-Visitor') ];
				package: 'SUnit-MockObjects' with: [ spec requires: #('SUnit-Core') ];
				package: 'SUnit-UI';
				package: 'SUnit-Support-UITesting-Tests';
				package: 'SUnit-Support-UITesting';
				package: 'SUnit-Help';
				package: 'JenkinsTools-Core';
				package: 'JenkinsTools-ExtraReports'.
			spec
				group: 'Core' with: #('SUnit-Core' 'SUnit-Core-Traits' 'SUnit-Visitor');
				group: 'MockObjects' with: #('SUnit-MockObjects');
				group: 'UI' with: #('SUnit-UI' 'SUnit-Support-UITesting');
				group: 'Tests' with: #('SUnit-Tests' 'SUnit-Support-UITesting-Tests' 'SUnit-Visitor-Tests');
				group: 'Help' with: #('SUnit-Help');
				group: 'JenkinsSupport' with: #('JenkinsTools-Core' 'JenkinsTools-ExtraReports');
				group: 'default' with: #('SUnit-Core' 'SUnit-Core-Traits' 'SUnit-Tests' 'JenkinsTools-Core' 'JenkinsTools-ExtraReports' 'SUnit-MockObjects') ]! !

!BaselineOfSUnit class methodsFor: 'accessing' stamp: ''!
defaultPackageNames

	^ self packagesOfGroupNamed: #default! !

!BaselineOfShift methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	spec
		for: #pharo
		do:
			[ 
			spec project: 'Ficus' with: [
				spec
					className: #ConfigurationOfFicus;
					versionString: #development;
					loads: #FicusMonticello;
					repository: 'http://smalltalkhub.com/mc/MartinDias/Ficus/main' ].
			
			spec package: 'Shift-Changes'.
			spec package: 'Shift-ClassBuilder' with:[spec requires: #('Shift-Changes')].

			spec package: 'Shift-ClassInstaller' with:[spec requires: #('Shift-ClassBuilder')].

			spec package: 'Shift-Changes-Ficus' with:[spec requires: #'Ficus'].

			spec package: 'Shift-ClassBuilder-Tests' with:[spec requires: #'core'].
			spec package: 'Shift-ClassInstaller-Tests' with:[spec requires: #'core'].

			spec package: 'Shift-Changes-Ficus-Tests' with:[spec requires: #('core' 'Shift-Changes-Ficus')].

			spec
				group: 'core' with: #('Shift-Changes' 'Shift-ClassBuilder' 'Shift-ClassInstaller');
				group: 'dev' with: #('core' 'tests');
				group: 'shift-tests' with: #('Shift-ClassBuilder-Tests' 'Shift-ClassInstaller-Tests');
				group: 'shift-ficus-tests' with: #('Shift-Changes-Ficus-Tests'); 
				group: 'tests' with: #('shift-tests' 'shift-ficus-tests');
				group: 'default' with: #('core')
			]! !

!BaselineOfShout methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	| repository |
	repository := self packageRepositoryURL.
	spec for: #'common' do: [
		
		spec baseline: 'Traits' with: [ 
			spec
				loads: #( 'traits-ast' );
				repository: repository ].
					
		spec 
			package: 'Shout';
			package: 'Rubric-Styling';
			package: 'Shout-Tests'.
		spec 
			group: 'Core' with: #('Shout' 'Rubric-Styling');
			group: 'Tests' with: #('Shout-Tests');
			group: 'default' with: #('Core' 'Tests') ]! !

!BaselineOfSindarin methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	spec
		for: #common
		do: [
			spec
				package: 'Sindarin';
				package: 'Sindarin-Tests';
				package: 'Sindarin-Experiments' ].
			
	spec 
		group: 'default' with: #('Core' 'Experiments');
		group: 'Core' with: #('Sindarin' 'Sindarin-Tests');
		group: 'Experiments' with: #('Core' 'Sindarin-Experiments')! !

!BaselineOfSlot methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec
		for: #common
		do: [ spec
				package: 'Slot-Core';
				package: 'Slot-Examples' with: [ spec requires: #('Slot-Core') ];
				package: 'Slot-Tests' with: [ spec requires: #('Slot-Core' 'Slot-Examples') ];
				package: 'VariablesLibrary' with: [ spec requires: #('Slot-Core') ];
				package: 'VariablesLibrary-Tests' with: [ spec requires: #('VariablesLibrary' 'Slot-Tests') ].

			spec
				group: 'core' with: #('Slot-Core' 'VariablesLibrary');
				group: 'slot-tests' with: #('Slot-Tests' 'VariablesLibrary-Tests') ]! !

!BaselineOfSlot class methodsFor: 'baselines' stamp: ''!
corePackages
	| groups |

	groups := self packagesOfGroupNamed: 'core-traits'.
	^ groups flatCollect: [ :e | self packagesOfGroupNamed: e ].! !

!BaselineOfSortFunctions methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'SortFunctions-Core';
			package: 'SortFunctions-Tests'.
		spec 
			group: 'Core' with: #('SortFunctions-Core');
			group: 'Tests' with: #('SortFunctions-Tests');
			group: 'default' with: #('Core' 'Tests') ]! !

!BaselineOfSpec methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	spec
		for: #common
		do: [ spec baseline: 'Morphic' with: [ spec repository: self packageRepositoryURL ].
			spec package: 'Spec-Core'.
			spec package: 'Spec-Layout'.
			spec package: 'Spec-MorphicAdapters'.
			spec package: 'Spec-PolyWidgets'.
			spec package: 'Spec-StubAdapter']! !

!BaselineOfSpec2 methodsFor: 'external projects' stamp: ''!
packageRepository

	" Tries to determine a repository from which the baseline is being loaded. Useful for 
	refering other baselines in the same repository. "
	
	^ (self class package mcWorkingCopy repositoryGroup repositories 
		reject: [:each | each = MCCacheRepository uniqueInstance]) 
		ifNotEmpty: [ :repositories | 
				repositories 
					detect: [ :each | each description beginsWith: 'tonel://' ]
					ifNone: [ repositories anyOne ] ]
		ifEmpty: [ nil ]! !

!BaselineOfSpec2 methodsFor: 'external projects' stamp: ''!
defaultRepositoryURL
		
	^ self class environment 
		at: #BaselineOfPharo
		ifPresent: [ :aClass | aClass specRepository ]
		ifAbsent: [ 'github://pharo-spec/Spec' ]! !

!BaselineOfSpec2 methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #common do: [
		
		self specCore: spec.
		self specCoreCode: spec.
	
		spec
			"Core"
			package: 'Spec2-Adapters-Morphic' with: [ spec requires: #('SpecCore') ];
			package: 'Spec2-Code-Morphic' with: [ spec requires: #('Spec2-Adapters-Morphic') ];
			package: 'Spec2-Code-Diff-Morphic' with: [ spec requires: #('Spec2-Adapters-Morphic') ];
			package: 'Spec2-Morphic' with: [ spec requires: #('Spec2-Adapters-Morphic') ];
			"Tests"
			package: 'Spec2-Morphic-Examples' with: [ spec requires: #('Spec2-Morphic') ];
			package: 'Spec2-Backend-Tests' with: [ spec requires: #('SpecCore' 'Spec2-Adapters-Morphic') ];
			package: 'Spec2-Morphic-Backend-Tests' with: [ spec requires: #('Spec2-Adapters-Morphic' 'Spec2-Backend-Tests') ];
			package: 'Spec2-Adapters-Morphic-Tests' with: [ spec requires: #('Spec2-Backend-Tests') ];
			package: 'Spec2-Morphic-Tests' with: [ spec requires: #('Spec2-Morphic' 'Spec2-Backend-Tests') ];
			package: 'Spec2-Code-Backend-Tests' with: [ spec requires: #('Spec2-Backend-Tests') ];
			"others"
			package: 'Spec2-Microdown' with: [ spec requires: #('SpecCore' 'Spec2-Adapters-Morphic') ];
			package: 'Spec2-Help' ].
	
	spec group: 'Core' with: #('SpecCore' 'Spec2-Microdown' 'Spec2-Morphic' 'Spec2-Adapters-Morphic').
	spec group: 'Code' with: #('Core' 'SpecCoreCode' 'Spec2-Code-Morphic' 'Spec2-Code-Diff-Morphic').
	spec group: 'CodeTests' with: #('Code' 'Spec2-Code-Backend-Tests').
	spec group: 'Support' with: #('Core' 'Spec2-Morphic-Examples').
	spec group: 'Tests' with: #(
		'SpecCore'
		'Core' 
		'Spec2-Morphic-Tests' 
		'Spec2-Morphic-Backend-Tests' 
		'Spec2-Backend-Tests'
		'Spec2-Adapters-Morphic-Tests').
	spec group: 'Base' with: #(
		'SpecCore'
		'Core'
		'Support').

	spec group: 'default' with: #('Base' 'Tests' 'Code' 'CodeTests').! !

!BaselineOfSpec2 methodsFor: 'accessing' stamp: ''!
project
	"Atomic loading is needed for Spec because we are moving classes of package and it breaks their subclasses. 
	
	Here is an explanation I wrote on Discord:
	
«The problem with Obsolete classes is that classes with subclasses were moved from Spec-Core to Spec-Deprecated80. 

When updating Spec it will first load Spec-Core. This will delete the class and its subclasses will be migrated to an obsolete superclass. 
Then Spec-Deprecated80 is loaded but it does not migrate the subclasses of the obsolete class to it. (Apparently there is an intern working on that Pablo told me).»

We need to use atomic loading only during update of existing Spec upgrade"

	^self class environment at: #SpPresenter 
		ifPresent: [
			super project
				loadType: #atomic;
				yourself ] 
		ifAbsent: [ 		
			super project
				loadType: #linear;
				yourself  ]

	 ! !

!BaselineOfSpec2 methodsFor: 'external projects' stamp: ''!
specCore: spec

	spec baseline: 'SpecCore' with: [ 
		spec 
			repository: (self packageRepositoryURL ifEmpty: [ self defaultRepositoryURL ]);
			loads: #('Base' 'Tests') ]! !

!BaselineOfSpec2 methodsFor: 'external projects' stamp: ''!
specCoreCode: spec

	spec baseline: 'SpecCoreCode' with: [ 
		spec 
			repository: (self packageRepositoryURL ifEmpty: [ self defaultRepositoryURL ]);
			className: 'BaselineOfSpecCore';
			loads: #('Code' 'CodeTests') ]! !

!BaselineOfSpecCore methodsFor: 'external projects' stamp: ''!
pillar: spec
	spec
		baseline: 'PillarCore'
		with: [ spec repository: 'github://pillar-markup/pillar:dev-8/src' ]! !

!BaselineOfSpecCore methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #common do: [ 
		self pillar: spec.
		
		spec
			"Core"
			package: 'Spec2-ObservableSlot';
			package: 'Spec2-Layout' with: [ spec requires: #('Spec2-ObservableSlot') ];
			package: 'Spec2-Core' with: [ spec requires: #('Spec2-ObservableSlot' 'Spec2-Layout') ];
			package: 'Spec2-Dialogs' with: [ spec requires: #('Spec2-Core') ];
			package: 'Spec2-CommandLine' with: [ spec requires: #('Spec2-Core') ];
			package: 'Spec2-Commands';
			package: 'Spec2-Transmission' with: [ spec requires: #('Spec2-Core') ];
			package: 'Spec2-Interactions' with: [ spec requires: #('Spec2-Core') ];
			package: 'Spec2-Commander2' with: [ spec requires: #('Spec2-Core' 'Spec2-Interactions') ];
			"Code"
			package: 'Spec2-Code' with: [ spec requires: #('Spec2-Core' 'Spec2-Commands') ];
			package: 'Spec2-Code-Commands' with: [ spec requires: #('Spec2-Core' 'Spec2-Commands') ];
			package: 'Spec2-Code-Diff' with: [ spec requires: #('Spec2-Code') ];
			"Common widgets"
			package: 'Spec2-CommonWidgets' with: [ spec requires: #('Spec2-Core' 'Spec2-Layout') ];
			package: 'Spec2-CommonWidgets-Tests' with: [ spec requires: #('Spec2-CommonWidgets' 'Spec2-Tests') ];
			"Tests"			
			package: 'Spec2-Adapters-Stub' with: [ spec requires: #('Spec2-Core') ];
			package: 'Spec2-Commander2-Tests' with: [ spec requires: #('Spec2-Commander2') ];
			package: 'Spec2-Tests' with: [ spec requires: #('Spec2-Core' 'Spec2-Examples') ];
			package: 'Spec2-Code-Tests' with: [ spec requires: #('Spec2-Tests' 'Spec2-Code') ];
			package: 'Spec2-Code-Diff-Tests' with: [ spec requires: #('Spec2-Tests' 'Spec2-Code-Diff') ];
			"Examples"
			package: 'Spec2-Examples' with: [ spec requires: #('Spec2-CommonWidgets') ];
			package: 'Spec2-Commander2-ContactBook' with: [ spec requires: #('Spec2-Commander2') ];
			package: 'Spec2-Commander2-ContactBook-Extensions' with: [ spec requires: #('Spec2-Commander2-ContactBook') ];
			"RichText -> Pillar"
			package: 'Spec2-Pillar' with: [ spec requires: #('Spec2-Core' 'PillarCore') ] 
	].
	
	spec group: 'Core' with: #(
		'Spec2-ObservableSlot' 
		'Spec2-Layout' 
		'Spec2-Transmission'
		'Spec2-Commands' 
		'Spec2-Core' 
		'Spec2-Dialogs' 
		'Spec2-CommandLine' 
		'Spec2-Adapters-Stub' 
		'Spec2-Interactions' 
		'Spec2-Commander2' ).
	spec group: 'Code' with: #('Core' 'Spec2-Code-Commands' 'Spec2-Code' 'Spec2-Code-Diff').
	spec group: 'CodeTests' with: #('Spec2-Code-Tests' 'Spec2-Code-Diff-Tests').
	spec group: 'Support' with: #('Core' 'Spec2-Examples').
	spec group: 'Tests' with: #('Core' 'Spec2-Tests' 'Spec2-Commander2-Tests').
	spec group: 'SupportTests' with: #('Support').
	spec group: 'Pillar' with: #('Spec2-Pillar' ).
	spec group: 'Base' with: #('Core' 'Support').
	spec group: 'BaseTests' with: #('Spec2-Tests' 'SupportTests').
	
	spec group: 'default' with: #('Base' 'BaseTests' 'Code' 'CodeTests').! !

!BaselineOfSpecCore methodsFor: 'accessing' stamp: ''!
project
	"Atomic loading is needed for Spec because we are moving classes of package and it breaks their subclasses. 
	
	Here is an explanation I wrote on Discord:
	
«The problem with Obsolete classes is that classes with subclasses were moved from Spec-Core to Spec-Deprecated80. 

When updating Spec it will first load Spec-Core. This will delete the class and its subclasses will be migrated to an obsolete superclass. 
Then Spec-Deprecated80 is loaded but it does not migrate the subclasses of the obsolete class to it. (Apparently there is an intern working on that Pablo told me).»

We need to use atomic loading only during update of existing Spec upgrade"

	^self class environment at: #SpPresenter 
		ifPresent: [
			super project
				loadType: #atomic;
				yourself ] 
		ifAbsent: [ 		
			super project
				loadType: #linear;
				yourself  ]

	 ! !

!BaselineOfSystemCommands methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	| repository |
	repository := self packageRepositoryURL.
	spec
		for: #common
		do: [ spec baseline: 'Commander' with: [ spec repository: repository ].
			spec
				package: #'SystemCommands-RefactoringSupport'
					with: [ spec requires: #('Commander') ];
				package: #'SystemCommands-ClassCommands'
					with:
						[ spec requires: #('Commander' #'SystemCommands-RefactoringSupport') ];
				package: #'SystemCommands-ClassCommands-Tests'
					with:
						[ spec requires: #(#'SystemCommands-ClassCommands') ];
				package: #'SystemCommands-MessageCommands'
					with:
						[ spec requires: #('Commander' #'SystemCommands-RefactoringSupport') ];
				package: #'SystemCommands-MethodCommands'
					with:
						[ spec requires: #('Commander' #'SystemCommands-RefactoringSupport') ];
				package: #'SystemCommands-PackageCommands'
					with: [ spec requires: #('Commander') ];
				package: #'SystemCommands-SourceCodeCommands'
					with:
						[ spec requires: #('Commander' #'SystemCommands-RefactoringSupport') ];
				package: #'SystemCommands-VariableCommands'
					with:
						[ spec requires: #('Commander' #'SystemCommands-RefactoringSupport') ];
				package: #'SystemCommands-RefactoringSupport-Tests'
					with: [ spec requires: #(#'SystemCommands-RefactoringSupport') ] ]! !

!BaselineOfTaskIt methodsFor: 'baseline' stamp: ''!
baselineForPharo8: spec

	spec package: #TaskIt.
	self baselineForCommon: spec! !

!BaselineOfTaskIt methodsFor: 'baseline' stamp: ''!
baselineForCommon: spec

	spec
		package: #'TaskIt-Tests' with: [ spec requires: #('TaskIt') ];
		package: #TaskItRetry with: [ spec requires: #('TaskIt') ];
		package: #'TaskItRetry-Tests' with: [ spec requires: #('TaskItRetry') ];
		package: #TaskItProcesses with: [ spec requires: #('TaskIt') ];
		package: #'TaskItProcesses-Tests' with: [ spec requires: #('TaskItProcesses') ];
		package: #TaskItBrowser with: [ spec requires: #('TaskItProcesses') ];
		package: #TaskItDebugger with: [ spec requires: #('TaskItProcesses') ];
		package: #'TaskItDebugger-Tests' with: [ spec requires: #('TaskItDebugger') ].

	spec
		group: 'core' with: #('TaskIt');
		group: 'coreTests' with: #('TaskIt' 'TaskIt-Tests');
		group: 'default' with: #(
			'core' 
			'TaskItProcesses' 
			'TaskItRetry' 
			'TaskItDebugger' 
			'TaskIt-Tests' 
			'TaskItRetry-Tests' 
			'TaskItProcesses-Tests' 
			'TaskItDebugger-Tests');
		group: 'debug' with: #('minimal' 'TaskItDebugger');
		group: 'tests' with: #(
			'default' 
			'TaskIt-Tests' 
			'TaskItRetry-Tests' 
			'TaskItProcesses-Tests' 
			'TaskItDebugger-Tests');
		group: 'development' with: #('default' 'debug' 'tests')! !

!BaselineOfTaskIt methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'pharo7.x' do: [ self baselineForPharo7: spec ].
	spec for: #'pharo8.x' do: [ self baselineForPharo8: spec ].
	spec for: #'pharo9.x' do: [ self baselineForPharo9: spec ].
	spec for: #'pharo6.1.x' do: [ self baselineForPharo6: spec ]! !

!BaselineOfTaskIt methodsFor: 'baseline' stamp: ''!
baselineForPharo6: spec
	spec
		package: #TaskIt;
		package: #'TaskIt-Tests' with: [ spec requires: #( 'TaskIt' ) ];
		package: #TaskItRetry with: [ spec requires: #( 'TaskIt' ) ];
		package: #'TaskItRetry-Tests'
		with: [ spec requires: #( 'TaskItRetry' ) ];
		package: #TaskItProcesses with: [ spec requires: #( 'TaskIt' ) ];
		package: #'TaskItProcesses-Tests'
		with: [ spec requires: #( 'TaskItProcesses' ) ];
		package: #TaskItBrowser
		with: [ spec requires: #( 'TaskItProcesses' ) ];
		package: #TaskItDebugger
		with: [ spec requires: #( 'TaskItProcesses' ) ];
		package: #'TaskItDebugger-Tests'
		with: [ spec requires: #( 'TaskItDebugger' ) ].
	spec
		group: 'minimal' with: #( 'TaskIt' );
		group: 'default'
		with: #( 'minimal' 'TaskItProcesses' 'TaskItRetry' 'TaskItDebugger'
			   'TaskIt-Tests' 'TaskItRetry-Tests' 'TaskItProcesses-Tests'
			   'TaskItDebugger-Tests' );
		group: 'debug' with: #( 'minimal' 'TaskItDebugger' );
		group: 'tests'
		with:
			#( 'default' 'TaskIt-Tests' 'TaskItRetry-Tests' 'TaskItProcesses-Tests'
			   'TaskItDebugger-Tests' );
		group: 'development' with: #( 'default' 'debug' 'tests' )! !

!BaselineOfTaskIt methodsFor: 'baseline' stamp: ''!
baselineForPharo9: spec

	spec package: #TaskIt.
	self baselineForCommon: spec! !

!BaselineOfTaskIt methodsFor: 'baseline' stamp: ''!
baselineForPharo7: spec

	spec 
		baseline: 'ParametrizedTests'
		with: [ spec repository: 'github://tesonep/ParametrizedTests/src' ].
	spec package: #TaskIt with: [ spec requires: #('ParametrizedTests') ].
	self baselineForCommon: spec! !

!BaselineOfTaskIt class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #stable) load! !

!BaselineOfTaskIt class methodsFor: 'catalog' stamp: ''!
catalogKeywords
	^ {'multiprocessing'. 'futures'. 'tasks'. 'services'. }! !

!BaselineOfTaskIt class methodsFor: 'metacello tool support' stamp: ''!
isMetacelloConfig
	"Answer true and the Metacello tools will operate on you"
	
	^true! !

!BaselineOfTaskIt class methodsFor: 'development support' stamp: ''!
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."
	<apiDocumentation>
! !

!BaselineOfTaskIt class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #bleedingEdge) load! !

!BaselineOfTaskIt class methodsFor: 'catalog' stamp: ''!
catalogContactInfo
	^ 'santiagobragagnolo@gmail.com'! !

!BaselineOfTaskIt class methodsFor: 'private' stamp: ''!
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 ] ]! !

!BaselineOfTaskIt class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #development) load! !

!BaselineOfTaskIt class methodsFor: 'catalog' stamp: ''!
catalogDescription
	^ 'Task & Jobs oriented multiprocessing framework. Check for nicely showed documentation at https://github.com/pharo-contributions/taskit/ :)'! !

!BaselineOfTaskIt class methodsFor: 'private' stamp: ''!
baseConfigurationClassIfAbsent: aBlock

	^Smalltalk
		at: #MetacelloBaseConfiguration
		ifAbsent: [ 
			self ensureMetacelloBaseConfiguration.
			Smalltalk at: #MetacelloBaseConfiguration ifAbsent: aBlock ].
! !

!BaselineOfTelePharoSupport commentStamp: ''!
This baseline is used to load the basic support needed for remote image browsing with TelePharo. It is not used during the building of the standard image.

Load this baseline:

./pharo minimal.image eval --save "Metacello new baseline: 'TelePharoSupport';repository: 'github://pharo-project/pharo:Pharo9.0/src'; load"

Load the TelePharo 

./pharo minimal.image eval --save "Metacello new repository: 'github://pharo-ide/TelePharo'; baseline: 'TelePharo'; load: #( 'MinimalServer' )"

For more information and prepared scripts see: 
   https://github.com/noha/pharo-minimal!
!BaselineOfTelePharoSupport methodsFor: 'baseline' stamp: ''!
baseline: spec 
    
	<baseline>

	| repository | 
	
	repository := self packageRepositoryURL.

	spec for: #common do: [
		spec baseline: 'SUnit' with: [spec repository: repository].
		spec baseline: 'Display' with: [spec repository: repository].

		spec package: 'SortFunctions-Core'.
		spec package: 'Tool-Registry'.
	].! !

!BaselineOfTestToLock1 commentStamp: ''!
A baseline to test lock/unlock!
!BaselineOfTestToLock1 methodsFor: 'baselines' stamp: ''!
baseline: spec
    <baseline>

    spec for: #common do: [
		spec package: 'Package1'.
		spec baseline: 'TestToLock2' ]! !

!BaselineOfTestToLock2 commentStamp: ''!
A baseline to test lock/unlock (this one will be nested to `BaselineOfTestToLock1`!
!BaselineOfTestToLock2 methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #common do: [ 
		spec package: 'TestToLockPackage1'.
		spec package: 'TestToLockPackage2' ]! !

!BaselineOfThreadedFFI methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>

	spec for: #common do: [

		spec postLoadDoIt: #reset.

		spec
			"core"
			package: 'ThreadedFFI';
			package: 'ThreadedFFI-Graphics-Extensions' with: [ spec requires: #('ThreadedFFI') ];
			package: 'ThreadedFFI-UFFI' with: [ spec requires: #('ThreadedFFI') ];
			package: 'ThreadedFFI-UFFI-Overrides' with: [ spec requires: #('ThreadedFFI-UFFI') ];
			"tests"
			package: 'ThreadedFFI-Tests' with: [ spec requires: #('ThreadedFFI') ];
			package: 'ThreadedFFI-UFFI-Tests' with: [ spec requires: #('ThreadedFFI-UFFI' 'ThreadedFFI-UFFI-Overrides') ] ].		
	
	spec 
		group: 'Core' with: #('ThreadedFFI' 'ThreadedFFI-UFFI' 'ThreadedFFI-UFFI-Overrides');
		group: 'Graphics' with: #('Core' 'ThreadedFFI-Graphics-Extensions');
		group: 'Tests' with: #('ThreadedFFI-Tests' 'ThreadedFFI-UFFI-Tests');
		group: 'default' with: #('Core' 'Graphics' 'Tests')! !

!BaselineOfThreadedFFI methodsFor: 'doits' stamp: ''!
reset

	Smalltalk globals
		at: #FFIMethodRegistry 
		ifPresent: [ :class | class resetAll ].
		
	Smalltalk globals
		at: #FFIBackend 
		ifPresent: [ :class | class reset ]! !

!BaselineOfThreadedFFI class methodsFor: 'accessing' stamp: ''!
corePackageNames

	^ self packagesOfGroupNamed: #Core! !

!BaselineOfTonel methodsFor: 'baselines' stamp: ' 1/5/2022 20:56:19'!
baseline: spec
	<baseline>
	spec
		for: #common
		do: [ 
			spec
				package: #'MonticelloTonel-Core';
				package: #'MonticelloTonel-FileSystem' with: [ spec requires: #('MonticelloTonel-Core') ];
				package: #'MonticelloTonel-Tests' with: [ spec requires: #('MonticelloTonel-Core') ].
			spec
				group: 'default' with: #('core' 'tests');
				group: 'core' with: #('MonticelloTonel-Core' 'MonticelloTonel-FileSystem');
				group: 'tests' with: #('MonticelloTonel-Tests') ].

	spec for: #(#'pharo4.x' #'pharo5.x' #'pharo6.x' #'pharo7.x') do: [ 
		self ston: spec.
		
		spec 
			package: #'MonticelloTonel-Compatibility';
			package: #'MonticelloTonel-Core' with: [ spec requires: #(#'MonticelloTonel-Compatibility') ] ].
			
	spec for: #(#'pharo1.x' #'pharo2.x' #'pharo3.x' #'pharo4.x') do: [ 
		self ston: spec.
		
		spec 
			package: #'MonticelloTonel-Compatibility';
			package: #'MonticelloTonel-Core' with: [ spec requires: #(#'MonticelloTonel-Compatibility' 'Ston') ] ]! !

!BaselineOfTonel methodsFor: 'dependencies' stamp: ' 1/5/2022 20:56:19'!
ston: spec
	spec
		project: 'Ston'
		with: [ spec
				className: #ConfigurationOfSton;
				versionString: #stable;
				repository: 'http://smalltalkhub.com/mc/SvenVanCaekenberghe/STON/main/' ]! !

!BaselineOfTraits commentStamp: ''!
I am the baseline for loading Traits in a bootstraped image.
Usually  my core is loaded during the bootstrap process by Hermes. 
The other parts are loaded after using Metacello.

However  I have the following groups to describe the dependencies:

- core : is the minimal core implementation of Traits. Loaded by Hermes
- traits-in-kernel : I include all the traits that are part of the bootstraped kernel. Also loaded by Hermes.
- compatibility: I include a compatibility package with the old traits and classes to be used only to accept the extension methods. This will be removed with the time.
- core-traits: Minimum required to use in an image.
- default: I include the tests and all the previous.
- traits-tests: adding the tests for TraitsV2.!
!BaselineOfTraits methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>

	spec for: #common do: [

		spec 
			package: 'TraitsV2';
			
			package: 'Kernel-Traits' with: [ spec requires: #('TraitsV2') ];
			package: 'AST-Core-Traits' with: [ spec requires: #('TraitsV2') ];
			package: 'Collections-Abstract-Traits' with: [ spec requires: #('TraitsV2') ];
			package: 'Transcript-Core-Traits' with: [ spec requires: #('TraitsV2') ];
			package: 'CodeImport-Traits' with: [ spec requires: #('TraitsV2') ];
			package: 'CodeExport-Traits' with: [ spec requires: #('TraitsV2') ];
			package: 'TraitsV2-Tests' with: [ spec requires: #('TraitsV2') ];
			package: 'TraitsV2-Compatibility' with: [ spec requires: #('TraitsV2') ].

		spec group: 'core' with: #('TraitsV2').
					
		spec group: 'traits-in-kernel' with: #(
					'Kernel-Traits'
					'Collections-Abstract-Traits'
					'Transcript-Core-Traits'
					'CodeImport-Traits'
					'CodeExport-Traits' ).

		spec group: 'traits-ast' with: #(
					'AST-Core-Traits' ).
					
		spec group: 'compatibility' with: #('TraitsV2-Compatibility').
		
		spec group: 'core-traits' with: #(core 'traits-in-kernel' 'compatibility').		
		spec group: 'default' with: #('core-traits').
		spec group: 'traits-tests' with: #('default' 'TraitsV2-Tests').		
	 ].		
! !

!BaselineOfTraits class methodsFor: 'baselines' stamp: ''!
packagesToExportWithHermes

	^ self allPackageNames reject: [ :aPackageName | aPackageName = 'TraitsV2-Tests'].! !

!BaselineOfTraits class methodsFor: 'baselines' stamp: ''!
corePackages
	| groups |

	groups := self packagesOfGroupNamed: 'core-traits'.
	^ groups flatCollect: [ :e | self packagesOfGroupNamed: e ].! !

!BaselineOfUI commentStamp: ''!
This baseline is used to generate Pharo images from the local clone of pharo-project/pharo repository. 

Depends on:
- ConfigurationOfMorphic

Load type: 
- atomic

Installs:
- Spec
- Keymappings
- Rubric
- basic tools (old debugger, workspace)
- some other packages!
!BaselineOfUI methodsFor: 'baseline' stamp: ''!
baseline: spec 
    
	<baseline>

	| repository |
	 
	repository := self packageRepositoryURL.
       
	spec for: #common do: [
		spec postLoadDoIt: #'postload:package:'.
		
		"Loading the debugger model and infrastructure before the UI"		
		spec package: 'Debugger-Model'.
		spec package: 'Debugger-Oups'.

		"Load morphic before Spec"
		spec baseline: 'Morphic' with: [ spec repository: repository ].
		spec baseline: 'Commander2' with: [ spec repository: repository ].
		"old spec, to be removed"
		spec baseline: 'Spec' with: [ spec repository: repository ].
		"new spec (base), using external configuration"
		self specBase: spec.		
		
		spec baseline: 'DrTests' with: [ spec repository: repository ].

		spec package: 'StartupPreferences'.		
		
		spec package: 'Debugger-Actions'.

		spec package: 'Fonts-Chooser'.

		spec package: 'Transcript-Tool'.
		spec package: 'Tool-Workspace'.

		spec package: 'Morphic-Widgets-Tree'.

		spec baseline: 'Keymapping' with: [ 
			spec 
				repository: repository;
				loads: 'ui' ].

		spec package: 'WebBrowser-Core'.

		spec package: 'HelpSystem-Core'.
	].! !

!BaselineOfUI methodsFor: 'baseline' stamp: ''!
specBase: spec
	
	spec baseline: 'SpecBase' with: [
		spec 
			repository: (self class environment at: #BaselineOfPharo) specRepository;
			className: 'BaselineOfSpec2';
			loads: #('Base' 'Tests') ]! !

!BaselineOfUI methodsFor: 'actions' stamp: ''!
postload: loader package: packageSpec

	"Ignore pre and post loads if already executed"
	Initialized = true ifTrue: [ ^ self ].

	Smalltalk tools register: Workspace as: #browser.
	Smalltalk tools register: Workspace as: #monticelloBrowser.
	Smalltalk tools register: Workspace as: #fileList.
	Smalltalk tools register: Workspace as: #changeList.	
	
	Smalltalk ui theme settings preferGradientFill: true.
	PharoCommonTools initialize.

	Initialized := true! !

!BaselineOfUnifiedFFI methodsFor: 'baseline' stamp: ''!
baseline: spec
	<baseline>
	
	spec for: #common do: [
		spec preLoadDoIt: #'preload:package:'.
		spec postLoadDoIt: #'postload:package:'.
		spec 
			"unified ffi"
			package: 'UnifiedFFI';
			package: 'UnifiedFFI-Tests' with: [ spec requires: #('UnifiedFFI') ];
			package: 'UnifiedFFI-Legacy' with: [ spec requires: #('UnifiedFFI') ];
			package: 'System-OSEnvironments' with: [ spec requires: #('UnifiedFFI') ].
			
		spec 
			group: 'default' with: #('core' 'legacy');
			group: 'minimal' with: #('UnifiedFFI' 'System-OSEnvironments');
			group: 'core' with: #('minimal' 'UnifiedFFI-Tests');
			group: 'legacy' with: #('UnifiedFFI-Legacy') ]! !

!BaselineOfUnifiedFFI methodsFor: 'actions' stamp: ''!
preload: loader package: packageSpec

	"Ignore pre and post loads if already executed"
	Initialized = true ifTrue: [ ^ self ].

	initializersEnabled := MCMethodDefinition initializersEnabled.
	MCMethodDefinition initializersEnabled: true.
	

	
! !

!BaselineOfUnifiedFFI methodsFor: 'actions' stamp: ''!
postload: loader package: packageSpec

	"Ignore pre and post loads if already executed"
	Initialized = true ifTrue: [ ^ self ].

	MCMethodDefinition initializersEnabled: initializersEnabled.
	
	! !

!BaselineOfZodiac methodsFor: 'baselines' stamp: ''!
baseline: spec
	<baseline>
	spec for: #'common' do: [
		spec 
			package: 'Zinc-Zodiac';
			package: 'Zodiac-Extra';
			package: 'Zodiac-Tests'.

		spec 
			group: 'Core' with: #('Zinc-Zodiac' 'Zodiac-Extra');
			group: 'Tests' with: #('Zodiac-Tests');
			group: 'default' with: #('Core' 'Tests') ]! !

!BasicBehaviorClassMetaclassTest commentStamp: ''!
This class contains some tests regarding the classes 
	Behavior
		ClassDescription
			Class
			Metaclass
 !
!BasicBehaviorClassMetaclassTest methodsFor: 'tests' stamp: ''!
testMetaclassName

	self assert: Dictionary class name equals: 'Dictionary class'.
	self assert: OrderedCollection class name equals: 'OrderedCollection class'! !

!BasicBehaviorClassMetaclassTest methodsFor: 'tests' stamp: ''!
testMetaclassNumberOfInstances

	self assert: Dictionary class allInstances size equals: 1.
	self assert: OrderedCollection class allInstances size equals: 1! !

!BasicBehaviorClassMetaclassTest methodsFor: 'tests' stamp: ''!
testMetaclassPointOfCircularity
	self assert: Metaclass class instanceCount equals: 1.
	self assert: Metaclass class someInstance identicalTo: Metaclass! !

!BasicBehaviorClassMetaclassTest methodsFor: 'tests' stamp: ''!
testMetaclassSuperclass
	self assert: Dictionary class superclass identicalTo: Dictionary superclass class.
	self assert: OrderedCollection class superclass identicalTo: OrderedCollection superclass class! !

!BasicBehaviorClassMetaclassTest methodsFor: 'tests' stamp: ''!
testMetaclass
	self assert: OrderedCollection class class identicalTo: Metaclass.
	self assert: Dictionary class class identicalTo: Metaclass.
	self assert: Object class class identicalTo: Metaclass! !

!BasicBehaviorClassMetaclassTest methodsFor: 'tests' stamp: ''!
testBehaviorClassClassDescriptionMetaclassHierarchy
	self assert: Class superclass identicalTo: ClassDescription.
	self assert: Metaclass superclass identicalTo: ClassDescription.

	self assert: ClassDescription superclass identicalTo: Behavior.
	self assert: Behavior superclass equals: Object.

	self assert: Class class class identicalTo: Metaclass.
	self assert: Metaclass class class identicalTo: Metaclass.
	self assert: ClassDescription class class identicalTo: Metaclass.
	self assert: Behavior class class identicalTo: Metaclass! !

!BasicBehaviorClassMetaclassTest methodsFor: 'tests' stamp: ''!
testSuperclass
	| s b |
	s := OrderedCollection new.
	b := [ :cls | 
	cls
		ifNotNil: [ s add: cls.
			b value: cls superclass ] ].
	b value: OrderedCollection.

	self assert: OrderedCollection allSuperclasses equals: s allButFirst.
	self assert: OrderedCollection withAllSuperclasses equals: s! !

!BasicBehaviorClassMetaclassTest methodsFor: 'tests' stamp: ''!
testMetaclassSuperclassHierarchy
	| s |
	self assert: SequenceableCollection class instanceCount equals: 1.
	self assert: Collection class instanceCount equals: 1.
	self assert: Object class instanceCount equals: 1.
	self assert: ProtoObject class instanceCount equals: 1.
	
	s := (OrderedCollection new)
				add: SequenceableCollection class;
				add: Collection class;
				add: Object class;
				add: ProtoObject class;

				add: Class;
				add: ClassDescription;
				add: Behavior;
				add: Object;
				add: ProtoObject;
				yourself.

	self assert: OrderedCollection class allSuperclasses equals: s! !

!BasicBehaviorClassMetaclassTest methodsFor: 'tests' stamp: ''!
testObjectAllSubclasses
	| n2 |
	n2 := Object allSubclasses size.
	self assert: n2 equals: (Object allSubclasses select: [ :cls | (cls class isKindOf: Metaclass) or: [ cls isKindOf: Metaclass ] ]) size! !

!BasicCommandLineHandler commentStamp: ''!
I'm a command line handler who is not aware of any UI or Tools present in the system.
I'm used as base handler for loading executing stripped images (kernel images, for example). 

My usage is the same as PharoCommandLineHandler, see his comment as better explanation.

I also implement a way to password-protect command lines. 

The password will not be saved as in clear. It will be hash using pepper and iterations.

The pepper of a hash is a fix string happened to a password to increase the difficulty of finding the password. Also, we hash multiple times (iterations) to increase the strength of the protection.

If you wish to define "application" command lines who do not need a password protection, implement the method #requirePasswordInDeployment on the class side to return false.

Examples of password protection
----------------

"Enable password protection"
CommandLinePasswordManager protectCommandLinesByPasswordWith: 'PharoPassword'

"You can also customize the pepper and number of iterations for the hashing of the password."
CommandLinePasswordManager protectCommandLinesByPasswordWith: 'PharoPassword' pepper: 'SomePepper' numberOfHashIterations: 10

"Remove password protection"
CommandLinePasswordManager removePasswordProtection

How to specify the password
----------------

Command line without password:
	Pharo.exe Pharo.image eval "1+1"

Command line with password:
	Pharo.exe Pharo.image eval "1+1" --deploymentPassword=Test!
!BasicCommandLineHandler methodsFor: 'commands' stamp: ''!
readOnlyAccessMode

	"just eat the argument because it was processed with by the SessionAccessModeResolver before"! !

!BasicCommandLineHandler methodsFor: 'activation' stamp: ''!
firstArgument

	^ self arguments
		  ifEmpty: [ '' ]
		  ifNotEmpty: [ :arguments | arguments first ]! !

!BasicCommandLineHandler methodsFor: 'private' stamp: ''!
selectHandlers
	| handlers |
	handlers := (self subCommandsRoot selectHandlersFor: commandLine) copyWithout: self class.
	handlers := handlers sort: [ :a :b | a priority >= b priority ].
	^ handlers! !

!BasicCommandLineHandler methodsFor: 'private' stamp: ''!
subCommandsRoot
	^ CommandLineHandler! !

!BasicCommandLineHandler methodsFor: 'activation' stamp: ''!
handleArgument: aString

	"give priority to subcommands"
	self handleSubcommand == self
		ifFalse: [ ^ self ].

	"check for default options"
	(aString isEmpty and: [ Smalltalk isInteractiveGraphic not]) 
			ifTrue: [ ^ self default ].
	
	aString = '--version'
		ifTrue: [ ^ self version ].
		
	aString = '--help'
		ifTrue: [ ^ self help ].
		
	aString = '--list'
		ifTrue: [ ^ self list ].
		
	aString = '--copyright'
		ifTrue: [ ^ self copyright ].
		
	aString = '--no-quit'
		ifTrue: [ ^ self noQuit ].

	aString = '--readWriteAccessMode'
		ifTrue: [ ^ self readWriteAccessMode ].
	aString = '--readOnlyAccessMode'
		ifTrue: [ ^ self readOnlyAccessMode ].
	aString = '--writeOnlyAccessMode'
		ifTrue: [ ^ self writeOnlyAccessMode ].
	aString = '--disabledAccessMode'
		ifTrue: [ ^ self disabledAccessMode ].

	Smalltalk isInteractiveGraphic
		ifTrue: [ ^ self noQuit ].
	
	"none of the previous options matched hence we output an error message"
	self error.! !

!BasicCommandLineHandler methodsFor: 'commands' stamp: ''!
version
	self stdout 
		nextPutAll: 'Image: '; print: SystemVersion current; cr;
		nextPutAll: 'VM:    '; nextPutAll: Smalltalk vm version; cr.
	self quit.! !

!BasicCommandLineHandler methodsFor: 'commands' stamp: ''!
readWriteAccessMode

	"just eat the argument because it was processed with by the SessionAccessModeResolver before"! !

!BasicCommandLineHandler methodsFor: 'password' stamp: ''!
requirePasswordFor: handler
	"If the password hash is nil, no password is set and we can just ignore it."

	^ handler requireDeploymentPassword
		and: [ self class commandLinePasswordManager hasPasswordSet ]! !

!BasicCommandLineHandler methodsFor: 'activation' stamp: ''!
activateSubCommand: aCommandLinehandler
	[ aCommandLinehandler activateWith: commandLine ] on: Exit do: [ :exit |
		^ self handleExit: exit for: aCommandLinehandler ].
	"the return value of this method is used to check if the subcommand was successful"
	^ aCommandLinehandler! !

!BasicCommandLineHandler methodsFor: 'activation' stamp: ''!
activate

	commandLine := commandLine class withArguments: (commandLine arguments 
					reject: [ :each | each = '--interactive' ]).	

	[ [ self handleArgument: self firstArgument ]
		on: Exit
		do: [ :exit | 
			"If the command line is protected by password, we just exit the image because in non-headless mode the handleExit will let the image open. If the password protection is enabled, it is to avoid to let the access to the image."
			self class commandLinePasswordManager hasPasswordSet
				ifTrue: [ Smalltalk snapshot: false andQuit: true ].
			self handleExit: exit ] ] forkAt: Processor userSchedulingPriority named: 'CommandLine handler process'! !

!BasicCommandLineHandler methodsFor: 'private' stamp: ''!
selectedHandler
	^ self selectHandlers 
		ifEmpty: [ nil ] 
		ifNotEmpty: [ :handlers | handlers first ]! !

!BasicCommandLineHandler methodsFor: 'activation' stamp: ''!
handleExit: exit for: aCommandLinehandler

	(Smalltalk isInteractive or: [ Smalltalk isInteractiveGraphic ])
		ifFalse: [ ^ exit pass ].
		
	exit isSuccess 
		ifFalse: [ ^ Error signal: exit messageText ].
	
	self inform: aCommandLinehandler name, ' successfully finished'.
		
	"for failing subcommands return self which is used to check if the subcommand failed"
	exit isSuccess 
		ifTrue: [ ^ aCommandLinehandler ].! !

!BasicCommandLineHandler methodsFor: 'commands' stamp: ''!
list
	| handlers shortNames maxShortNameSize |
	self stdout 
		nextPutAll: 'Currently installed Command Line Handlers:'; lf.
	handlers := self allHandlers reject: [ :cls | 
			cls includesBehavior: BasicCommandLineHandler ].
	shortNames := handlers collect: [ :each | each commandName ].
	maxShortNameSize := (shortNames detectMax: [ :name|  name size ]) size.
	handlers do: [ :handler|
		self stdout 
			nextPutAll: '    ';
			nextPutAll: (handler commandName padRightTo: maxShortNameSize); 
			nextPutAll: '    ';
			nextPutAll: (handler description ifNil: [ '--']); lf].
	self quit.! !

!BasicCommandLineHandler methodsFor: 'commands' stamp: ''!
writeOnlyAccessMode

	"just eat the argument because it was processed with by the SessionAccessModeResolver before"! !

!BasicCommandLineHandler methodsFor: 'activation' stamp: ''!
handleSubcommand
	"check if there is an active subcommand"

	| handlers |
	handlers := self selectHandlers.

	"If there is no handler, use myself"
	handlers ifEmpty: [ ^ self ].
	
	(self requirePasswordFor: handlers first)
		ifTrue: [ self checkPassword ].
		
	^ self activateSubCommand: handlers first! !

!BasicCommandLineHandler methodsFor: 'activation' stamp: ''!
handleExit: exit 
	^ self handleExit: exit  for: self! !

!BasicCommandLineHandler methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	commandLine := CommandLineArguments new! !

!BasicCommandLineHandler methodsFor: 'password' stamp: ''!
handlePassword: password
	(self class commandLinePasswordManager isMatchingPassword: password) ifTrue: [ ^ self ].
	
	self stderr << 'ERROR: Wrong password.'.
	Smalltalk snapshot: false andQuit: true! !

!BasicCommandLineHandler methodsFor: 'commands' stamp: ''!
error
	self arguments size = 1
		ifTrue:  [
			(self arguments first beginsWith: '-')
				ifTrue:  [ self << 'Invalid option: ']
				ifFalse: [ self << 'Invalid sub command: ']]
		ifFalse: [ self << 'Invalid arguments: "'].
		
	(self << (' ' join: self arguments)) 
		nextPutAll: '"'; cr.
		
	self printHelp.
	
	self exitFailure.! !

!BasicCommandLineHandler methodsFor: 'activation' stamp: ''!
handleEmptyArguments
	Smalltalk isHeadless
		ifFalse: [ ^ self ].
	
	self help.! !

!BasicCommandLineHandler methodsFor: 'private - preferences' stamp: ''!
copySubcommand
	commandLine := commandLine copySubcommand! !

!BasicCommandLineHandler methodsFor: 'commands' stamp: ''!
copyright
	self stdout 
		nextPutAll: Smalltalk licenseString; cr.
	self quit.! !

!BasicCommandLineHandler methodsFor: 'commands' stamp: ''!
noQuit
	"Nothing to be done, unlike the other commands the image continues running"! !

!BasicCommandLineHandler methodsFor: 'commands' stamp: ''!
default

	^ self 
		help;
		exitSuccess! !

!BasicCommandLineHandler methodsFor: 'commands' stamp: ''!
disabledAccessMode

	"just eat the argument because it was processed with by the SessionAccessModeResolver before"! !

!BasicCommandLineHandler methodsFor: 'password' stamp: ''!
checkPassword
	self
		optionAt: 'deploymentPassword'
		ifPresent: [ :password | self handlePassword: password ]
		ifAbsent: [ self stderr << 'This command line is protected by a password'.
			Smalltalk snapshot: false andQuit: true ].
	commandLine := commandLine copyWithoutPassword! !

!BasicCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ ''! !

!BasicCommandLineHandler class methodsFor: 'class initialization' stamp: ''!
initialize 
	SessionManager default 
		registerSystemClassNamed: self name! !

!BasicCommandLineHandler class methodsFor: 'handler selection' stamp: ''!
description
	^ 'basic responsible for the default options and activating other commands'! !

!BasicCommandLineHandler class methodsFor: 'accessing' stamp: ''!
priority 
	"Lowest priority"
	^ Float infinity negated! !

!BasicCommandLineHandler class methodsFor: 'handler selection' stamp: ''!
isResponsibleFor: aCommandLine
	"I do not match ever, because my activation is manual"
	^ false! !

!BasicCommandLineHandler class methodsFor: 'password-protection' stamp: ''!
commandLinePasswordManager
	^ CommandLinePasswordManager current! !

!BasicCommandLineHandler class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting
	"only handle when launching a new image"
	isImageStarting ifFalse: [ ^ self ].

	Smalltalk session 
		addDeferredStartupAction: [ self new activate ]! !

!BasicDatePrinter commentStamp: ''!
I have the simple task of printing a date, time and DateTime.
I do it in the simplest way possible, my subclasses can extend me, and I will use them.

I only print in a single format, does not matter what format the parameter is.

I use ISO 8601 for formatting Date, Time and DateTime

https://en.wikipedia.org/wiki/ISO_8601!
!BasicDatePrinter methodsFor: 'printing' stamp: ''!
printHMS: aTime separatedBy: aSeparator on: aStream
	"Print just hh<aSep>mm<aSep>ss"

	aTime hour printOn: aStream base: 10 length: 2 padded: true.
	aStream nextPut: aSeparator.
	aTime minute printOn: aStream base: 10 length: 2 padded: true.
	aStream nextPut: aSeparator.
	aTime second printOn: aStream base: 10 length: 2 padded: true! !

!BasicDatePrinter methodsFor: 'printing' stamp: ''!
printDateAndTime: aDateTime withLeadingSpace: printLeadingSpaceToo on: aStream
	"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 printYMD: aDateTime withLeadingSpace: printLeadingSpaceToo on: aStream.
	aStream nextPut: $T.

	self printHMS: aDateTime separatedBy: $: on: aStream.

	aDateTime nanoSecond ~= 0
		ifTrue: [ | n len |
			n := aDateTime nanoSecond.
			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:
			(aDateTime offset positive
				ifTrue: [ $+ ]
				ifFalse: [ $- ]).
	aDateTime offset hours abs
		printOn: aStream
		base: 10
		length: 2
		padded: true.
	aStream nextPut: $:.
	aDateTime offset minutes abs
		printOn: aStream
		base: 10
		length: 2
		padded: true.
	aDateTime offset seconds = 0
		ifFalse: [ aStream
				nextPut: $:;
				print: aDateTime offset seconds abs truncated ]! !

!BasicDatePrinter methodsFor: 'printing' stamp: ''!
printDate: aDate format: formatArray on: aStream
	"I print a basic representation of the date in ISO 8601 ex: 	2018-03-08"

	self printYMD: aDate withLeadingSpace: false on: aStream! !

!BasicDatePrinter methodsFor: 'printing' stamp: ''!
printYMD: aDateTime withLeadingSpace: printLeadingSpaceToo on: aStream
	"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 |
	aDateTime 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! !

!BasicDatePrinter class methodsFor: 'accessing' stamp: ''!
default
	" I prefer to use any of my subclasses than myself. 
	I am a really basic implementation."
	self subclassesDo: [ :subClass | subClass isAbstract ifFalse: [ ^ subClass new ]].
	^ self new! !

!Beacon commentStamp: ''!
This is the central and the dummiest class of the Beacon logging system.

It's a singleton class that holds an announcer instance. Its goal is purely to serve as a central beacon through which all signals pass. It works together with `Announcement>>#emit`.

By itself, it does not do anything useful. Other `SignalLogger`s are meant to register to its announcer and link the announcements to something useful.!
!Beacon methodsFor: 'announcing' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject

	self announcer when: anAnnouncementClass send: aSelector to: anObject! !

!Beacon methodsFor: 'accessing' stamp: ''!
loggers

	^ self loggersOf: SignalLogger! !

!Beacon methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	announcer := Announcer new! !

!Beacon methodsFor: 'announcing' stamp: ''!
unsubscribe: aSignalLogger

	self announcer unsubscribe: aSignalLogger! !

!Beacon methodsFor: 'private' stamp: ''!
announce: anAnnouncement

	self announcer announce: anAnnouncement! !

!Beacon methodsFor: 'accessing' stamp: ''!
announcer: anObject

	announcer := anObject! !

!Beacon methodsFor: 'accessing' stamp: ''!
loggersOf: aClass
	"Returns the loggers of a certain class of loggers."

	^ (announcer subscriptions subscriptions
		   collect: [ :each | each subscriber ]
		   as: Set) select: [ :each | each isKindOf: aClass ]! !

!Beacon methodsFor: 'accessing' stamp: ''!
announcer

	^ announcer! !

!Beacon class methodsFor: 'accessing' stamp: ''!
loggers

	^ self instance loggers ! !

!Beacon class methodsFor: 'accessing' stamp: ''!
instance

	^ Instance ifNil: [ Instance := self new ]! !

!Beacon class methodsFor: 'logging' stamp: ''!
announce: anAnnouncement

	self instance announce: anAnnouncement
	! !

!Beacon class methodsFor: 'private - initialization' stamp: ''!
resetInstance

	Instance ifNotNil: [ 
		Instance announcer subscriptions reset ].
	Instance := nil! !

!Beacon class methodsFor: 'accessing' stamp: ''!
loggersOf: aClass

	^ self instance loggersOf: aClass! !

!Beacon class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	
	self resetInstance! !

!BeaconSignal commentStamp: ''!
A `BeaconSignal` is a special kind of announcement that when emitted is passed to a central Beacon to which `SignalLogger`s may register. When registered loggers can then handle emitted signals: they can serialize them, store them in memory, or perform other treatments.

By default a signal records the timestamp of its creation and the processId of its creator. 
It is specifically useful in the context of logging, and it serves as the superclass for custom signals. Users are encouraged to capture custom signals in explicit subclasses.

The class also offers a property instance variable that can be used by custom loggers to capture specific logging parameters. Accessors to the concrete entries are meant to be wrapped in setters and getters.

For example, a ClassicLogger may want to add the notion of a level to a signal. To this end, the ClassicLogger package would define:

```
BeaconSignal >> level
    ^ self properties at: #level ifAbsent: [ LogLevel info ]
```
```
BeaconSignal >> level: aLevel
    ^ self properties at: #level put: aLevel
```	!
!BeaconSignal methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	timestamp := DateAndTime now.
	processId := Processor activeProcess name.
	properties := Dictionary new! !

!BeaconSignal methodsFor: 'accessing' stamp: ''!
processId

	^ processId! !

!BeaconSignal methodsFor: 'printing' stamp: ''!
printOneLineOn: stream

	stream
		nextPutAll: self timestamp asString;
		space;
		nextPutAll: self class name;
		space.

	self printOneLineContentsOn: stream! !

!BeaconSignal methodsFor: 'printing' stamp: ''!
printOn: stream

	self printOneLineOn: stream! !

!BeaconSignal methodsFor: 'accessing' stamp: ''!
asBeaconSignal

	^ self! !

!BeaconSignal methodsFor: 'accessing' stamp: ''!
properties

	^ properties! !

!BeaconSignal methodsFor: 'accessing' stamp: ''!
name

	^ self class name! !

!BeaconSignal methodsFor: 'accessing' stamp: ''!
timestamp

	^ timestamp! !

!BeaconSignal methodsFor: 'printing' stamp: ''!
printOneLineContentsOn: stream
	"Hook to be overriden by subclasses"! !

!BeaconSignal methodsFor: 'printing' stamp: ''!
printOneLineString

	^ String streamContents: [ :stream | self printOneLineOn: stream ]! !

!BecomeTest methodsFor: 'testing' stamp: ''!
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 equals: ha;
		assert: b identityHash equals: ha.! !

!BecomeTest methodsFor: 'testing' stamp: ''!
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 equals: 'cd';
		assert: b equals: 'cd';
		assert: c equals: 'cd';
		assert: d equals: 'cd'.! !

!BecomeTest methodsFor: 'testing' stamp: ''!
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 equals: c identityHash;
		assert: b identityHash equals: d identityHash;
		deny: a identityHash equals: b identityHash.! !

!BecomeTest methodsFor: 'testing' stamp: ''!
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 equals: hb;
		assert: b hash equals: ha;
		assert: c hash equals: hb;
		assert: d hash equals: ha! !

!BecomeTest methodsFor: 'testing' stamp: ''!
testBecomeForwardCopyIdentityHash
	"Check that
		1. the argument to becomeForward: IS modified to have the sender's identity hash.
		2. the sender's identity hash is unchanged."

	| a b identityHashOfA |
	a := 'ab' copy.
	b := 'cd' copy.
	identityHashOfA := a identityHash.

	a becomeForward: b copyHash: true.

	self
		assert: a identicalTo: b;
		assert: a identityHash equals: identityHashOfA;
		assert: b identityHash equals: identityHashOfA! !

!BecomeTest methodsFor: 'testing' stamp: ''!
testBecomeForwardHash

	| a b c hb |

	a := 'ab' copy.
	b := 'cd' copy.
	c := a.
	hb := b hash.

	a becomeForward: b.

	self 
		assert: a hash equals: hb;
		assert: b hash equals: hb;
		assert: c hash equals: hb.! !

!BecomeTest methodsFor: 'testing' stamp: ''!
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 equals: 'cd';
		assert: b equals: 'ab';
		assert: c equals: 'cd';
		assert: d equals: 'ab'.! !

!BecomeTest methodsFor: 'testing' stamp: ''!
testBecomeForwardDontCopyIdentityHash
	"Check that
		1. the argument to becomeForward: is NOT modified to have the receiver's identity hash.
		2. the receiver's identity hash is unchanged."

	| a b identityHashOfB |
	a := 'ab' copy.
	b := 'cd' copy.
	identityHashOfB := b identityHash.

	a becomeForward: b copyHash: false.

	self
		assert: a identicalTo: b;
		assert: a identityHash equals: identityHashOfB;
		assert: b identityHash equals: identityHashOfB! !

!Beeper commentStamp: ''!
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: ''!
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."

	self class environment at: #SoundService ifPresent: [ :soundService |
		soundService default new beep ].! !

!Beeper class methodsFor: 'customize' stamp: ''!
clearDefault
	"Clear the default playable.
	Will be lazily initialized in Beeper class >>default."

	default := nil! !

!Beeper class methodsFor: 'beeping' stamp: ''!
beepPrimitive
	"Make a primitive beep. Only use this if
	you want to force this to be a primitive beep.
	Otherwise use Beeper class>>beep
	since this method bypasses the current
	registered playable entity."

	SoundSystem current soundEnabled
		ifTrue: [self primitiveBeep]! !

!Beeper class methodsFor: 'beeping' stamp: ''!
beep
	"The preferred way of producing an audible feedback.
	The default playable entity (an instance of Beeper)
	also uses the pluggable SoundService
	mechanism, so it will use the primitive beep only
	if there is no other sound mechanism available."
	
	self default 
		ifNil: [self beepPrimitive]
		ifNotNil: [ self default play].
! !

!Beeper class methodsFor: 'private' stamp: ''!
primitiveBeep
	"Make a primitive beep. Not to be called directly.
	It is much better to use Beeper class>>beep
	or Beeper class>>beepPrimitive
	since this method bypasses the current
	registered playable entity and does not
	check SoundSettings class>>soundEnabled."

	<primitive: 140>
	self primitiveFailed! !

!Beeper class methodsFor: 'customize' stamp: ''!
newDefault
	"Subclasses may override me to provide a default beep.
	This base implementation returns an instance of Beeper
	which uses the pluggable sound service."

	^ self new! !

!Beeper class methodsFor: 'customize' stamp: ''!
default
	"When the default is not defined it is
	initialized using #newDefault."

	^ default ifNil: [default := self newDefault ] ! !

!Beeper class methodsFor: 'customize' stamp: ''!
setDefault: aPlayableEntity
	"Set the playable entity used when making a beep.
	The playable entity should implement the message #play."

	default := aPlayableEntity! !

!Behavior commentStamp: ''!
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: 'accessing - properties' stamp: ''!
propertyAt: propName
	^ self
		propertyAt: propName
		ifAbsent: [ nil ]! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
canUnderstand: selector
	"Answer whether the receiver can respond to the message whose selector 
	is the argument."

	^ self
		classAndMethodFor: selector
		do: [ :c :m | true ]
		ifAbsent: [ false ].! !

!Behavior methodsFor: 'accessing - properties' stamp: ''!
removeProperty: propName ifAbsent: aBlock
	| property |
	self properties ifNil: [^aBlock value].
	property := self properties
		removeKey: propName
		ifAbsent: aBlock.
	self removePropertiesIfEmpty.
	^ property! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
canPerform: selector
	"Answer whether the receiver can safely perform to the message whose selector 
	is the argument: it is not an abstract or cancelled method"

	^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! !

!Behavior methodsFor: 'testing' stamp: ''!
isCompiledMethodClass
	"Answer whether the receiver has compiled method instances that mix pointers and bytes."
	^self instSpec >= 24! !

!Behavior methodsFor: 'obsolete subclasses' stamp: ''!
removeAllObsoleteSubclasses
	"Remove all the obsolete subclasses of the receiver"
	self basicObsoleteSubclasses removeKey: self ifAbsent: [].! !

!Behavior methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
basicNewPinned

	<primitive: 598 error: ec>
	
	^ self basicNew
		pinInMemory;
		yourself! !

!Behavior methodsFor: 'testing' stamp: ''!
isWeak
	"Answer whether the receiver has contains weak references."
	^ self instSpec = 4! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
compileAllFrom: oldClass
	"Compile all the methods in the receiver's method dictionary.
	This validates sourceCode and variable references and forces
	all methods to use the current bytecode set"
	oldClass localSelectors do: [:sel | self recompile: sel from: oldClass].! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
users
	^ #()! !

!Behavior methodsFor: 'testing' stamp: ''!
shouldNotBeRedefined
	"Answer if the receiver should not be redefined.
	 The assumption is that classes in Smalltalk specialObjects and 
	 instance-specific Behaviors should not be redefined"

	^(Smalltalk specialObjectsArray
		identityIndexOf: self
		ifAbsent: [(self isKindOf: self) ifTrue: [1] ifFalse: [0]]) ~= 0! !

!Behavior methodsFor: 'instance creation' stamp: ''!
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.
	
	 If the primitive fails because space is low then the scavenger will run
	 before the method is activated.  Check that space was low and retry
	 via handleFailingBasicNew if so."

	<primitive: 70 error: ec>
	ec == #'insufficient object memory' ifTrue:
		[^self handleFailingBasicNew].
	self isVariable ifTrue: [^self basicNew: 0].
	self primitiveFailed! !

!Behavior methodsFor: 'private' stamp: ''!
handleFailingFailingBasicNew
	"This basicNew gets sent after handleFailingBasicNew: has done a full
	 garbage collection and possibly grown memory.  If this basicNew fails
	 then the system really is low on space, so raise the OutOfMemory signal.

	 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."

	<primitive: 70>
	"space must be low"
	OutOfMemory signal.
	^self basicNew  "retry if user proceeds"! !

!Behavior methodsFor: 'private' stamp: ''!
handleFailingBasicNew: sizeRequested
	"handleFailingBasicNew: gets sent after basicNew: has failed and allowed
	 a scavenging garbage collection to occur.  The scavenging collection
	 will have happened as the VM is activating the (failing) basicNew:.  If
	 handleFailingBasicNew: fails then the scavenge failed to reclaim sufficient
	 space and a global garbage collection is required.  Retry after garbage
	 collecting and growing memory if necessary.

	 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."

	<primitive: 71>
	| bytesRequested |
	bytesRequested := self byteSizeOfInstanceOfSize: sizeRequested.
	Smalltalk garbageCollect < bytesRequested ifTrue:
		[Smalltalk growMemoryByAtLeast: bytesRequested].
	"retry after global garbage collect and possible grow"
	^self handleFailingFailingBasicNew: sizeRequested! !

!Behavior methodsFor: 'system startup' stamp: ''!
startUp
	"This message is sent to registered classes when the system is coming up."! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
compiledMethodAt: selector ifPresent: aBlock ifAbsent: anotherBlock
	"Answer the compiled method associated with the argument, selector (a Symbol),
	 a message selector in the receiver's method dictionary.
	 If the selector is in the dictionary, return the value of aBlock.
	 If the selector is not in the dictionary, return the value of anotherBlock.
	"

	^ self methodDict at: selector ifPresent: aBlock ifAbsent: anotherBlock! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
lookupVarForDeclaration: name
	"This is a version of #lookupVar: that skips the OCRequestorScope, from here on it is the same as lookupVar:"
	^ self lookupVar: name! !

!Behavior methodsFor: 'adding/removing methods' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	^ self addSelectorSilently: selector withMethod: compiledMethod! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
includesSelector: aSymbol 
	"Answer whether the message whose selector is the argument is in the 
	method dictionary of the receiver's class."

	^ self methodDict includesKey: aSymbol! !

!Behavior methodsFor: 'queries' stamp: ''!
allMethodsWritingSlot: aSlot
	"return all methods that access aSlot in this class and subclasses"
	^self withAllSubclasses flatCollect: [ :class | class methodsWritingSlot: aSlot ]! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
allSelectorsAbove

	^ self allSelectorsAboveUntil: ProtoObject! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
allInstancesOrNil
	"Answer all instances of the receiver, or nil if the primitive
	 fails, which it may be due to being out of memory."
	<primitive: 177>
	^nil! !

!Behavior methodsFor: 'cleanup' stamp: ''!
cleanUp: aggressive
	"Clean out any caches and other state that should be flushed when trying to get an image into a pristine state. The argument should be used to indicate how aggressive the cleanup should be. Some subclasses may act differently depending on its value - for example, ChangeSet will only delete all unused and reinitialize the current change set if we're asking it to be aggressive."

	^self cleanUp! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
hasTraitComposition
	
	^ false ! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
superclass
	"Answer the receiver's superclass, a Class."

	^superclass! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
methodDictionary
	^self methodDict! !

!Behavior methodsFor: 'testing' stamp: ''!
isPointers
	"Answer whether the receiver contains just pointers (not bits)."

	^self isBits not! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
isDisabledSelector: selector
	^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! !

!Behavior methodsFor: 'initialization' stamp: ''!
originalName
	| obsName |
	obsName := self name.
	self isObsolete ifFalse: [ ^obsName asSymbol].
 	[obsName beginsWith: 'AnObsolete']
 		whileTrue: [obsName := obsName copyFrom: 'AnObsolete' size + 1 to: obsName size].
	^obsName asSymbol! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
selectorsDo: selectorBlock
	"Evaluate selectorBlock for all the message selectors in my method dictionary."

	^ self methodDict keysDo: selectorBlock! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
allInstances
	"Answer all instances of the receiver."
	<primitive: 177>
	"The primitive can fail because memory is low.  If so, fall back on the old
	 enumeration code, which gives the system a chance to GC and/or grow.
	 Because aBlock might change the class of inst (for example, using become:),
	 it is essential to compute next before aBlock value: inst."
	| inst insts next |
	insts := WriteStream on: (Array new: 64).
	inst := self someInstance.
	[inst == nil] whileFalse:
		[next := inst nextInstance.
		 (inst == insts or: [inst == insts originalContents]) ifFalse: [insts nextPut: inst].
		 inst := next].
	^insts contents! !

!Behavior methodsFor: 'queries' stamp: ''!
pragmas
	^ self methods flatCollect: [ :method | method pragmas ]! !

!Behavior methodsFor: 'private' stamp: ''!
spaceUsed
	"Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables."

	| space |
	space := 0.
	self methodsDo: [:method  |
		space := space + 16.  "dict and org'n space"
		space := space + (method size + 6 "hdr + avg pad").
		method literalsDo: [:lit |
			(lit isMemberOf: Array) ifTrue: [space := space + ((lit size + 1) * 4)].
			(lit isMemberOf: Float) ifTrue: [space := space + 12].
			(lit isMemberOf: ByteString) ifTrue: [space := space + (lit size + 6)].
			(lit isMemberOf: LargeNegativeInteger) ifTrue: [space := space + ((lit size + 1) * 4)].
			(lit isMemberOf: LargePositiveInteger) ifTrue: [space := space + ((lit size + 1) * 4)]]].
		^ space! !

!Behavior methodsFor: 'enumerating' stamp: ''!
withAllSuperclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's superclasses."
	aBlock value: self.
	self superclass == nil
		ifFalse: [self superclass withAllSuperclassesDo: aBlock]! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
compiledMethodAt: selector ifAbsent: aBlock
	"Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock"

	^ self methodDict at: selector ifAbsent: aBlock! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
methodsDo: aBlock
	"Evaluate aBlock for all the compiled methods in my method dictionary."

	^ self methodDict valuesDo: aBlock! !

!Behavior methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
basicNewPinned: requestedSize

	<primitive: 599 error: ec>

	^ (self basicNew: requestedSize)
		pinInMemory;
		yourself! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
allInstVarNames
	"Answer an Array of the names of the receiver's instance variables. The 
	Array ordering is the order in which the variables are stored and 
	accessed by the interpreter."

	^ self superclass
		ifNil: [ self instVarNames ]
		ifNotNil: [ :sup | sup allInstVarNames , self instVarNames ]! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
compilerClass
	"Answer a compiler class appropriate for source methods of this class."

	^Smalltalk compilerClass! !

!Behavior methodsFor: '*Polymorph-Widgets' stamp: ''!
systemIconName

	^self isAbstract 
				ifTrue: [ #classAbstract ] 
				ifFalse: [ super systemIconName ]! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
whichClassIncludesSelector: aSymbol 
	"Answer the class on the receiver's superclass chain where the 
	argument, aSymbol (a message selector), will be found. Answer nil if none found."
	"Rectangle whichClassIncludesSelector: #inspect."
	(self includesSelector: aSymbol)
		ifTrue: [^ self].
	self superclass == nil
		ifTrue: [^ nil].
	^ self superclass whichClassIncludesSelector: aSymbol! !

!Behavior methodsFor: '*Refactoring-Environment' stamp: ''!
asEnvironment
	^ RBClassEnvironment class: self! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
isComposedBy: aTrait
	"Answers if this object includes trait aTrait into its composition"
	aTrait isTrait ifFalse: [ ^false].
	^self hasTraitComposition 
		ifTrue: [ self traitComposition includesTrait: aTrait ]
		ifFalse: [ false ]! !

!Behavior methodsFor: 'enumerating' stamp: ''!
allSubInstancesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the current instances of the 
	receiver and all its subclasses."

	self allInstancesDo: aBlock.
	self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]! !

!Behavior methodsFor: 'testing' stamp: ''!
isEphemeronClass
	"Answer whether the receiver has ephemeral instance variables.  The garbage collector will
	 fire (queue for finalization) any ephemeron whose first instance variable is not referenced
	 other than from the transitive closure of references from ephemerons. Hence referring to
	 an object from the first inst var of an ephemeron will cause the ephemeron to fire when
	 the rest of the system does not refer to the object and that object is ready to be collected.
	 Since references from the remaining inst vars of an ephemeron will not prevent the ephemeron
	 from firing, ephemerons may act as the associations in weak dictionaries such that the value
	 (e.g. properties attached to the key) will not prevent firing when the key is no longer referenced
	 other than from ephemerons.  Ephemerons can therefore be used to implement instance-based
	 pre-mortem finalization."
	^self instSpec = 5! !

!Behavior methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod
	"I return the original method for a aMethod.
	When in a normal class it is the same. Enhanced classes (eg. TraitedClasses)
	can do something difference"

	^ aMethod! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
thoroughHasSelectorReferringTo: literal
	"Answer true if any of my methods access the argument as a 
	literal. Dives into the compact literal notation, making it slow but 
	thorough "
	
	| specialIndex |
	"for speed we check the special selectors here once per class"
	specialIndex := Smalltalk specialSelectorIndexOrNil: literal.
	^self methods anySatisfy: [ :method | 
		method hasSelector: literal specialSelectorIndex: specialIndex]! !

!Behavior methodsFor: 'obsolete subclasses' stamp: ''!
addObsoleteSubclass: aClass
	"Weakly remember that aClass was a subclass of the receiver and is now obsolete"
	| obs |

	obs := self basicObsoleteSubclasses at: self ifAbsent:[WeakArray new].
	(obs includes: aClass) ifTrue:[^self].
	obs := obs copyWithout: nil.
	obs := obs copyWith: aClass.
	self basicObsoleteSubclasses at: self put: obs.! !

!Behavior methodsFor: '*Deprecated10' stamp: ''!
typeOfClass

	self
		deprecated: 'Should use mcType instead'
		on: '08 September 2021'
		in: #Pharo10
		transformWith: '`@rec typeOfClass' -> '`@rec mcType'.
	^ self mcType! !

!Behavior methodsFor: 'private' stamp: ''!
becomeUncompact
	"Backward compatibility with the Squeak V3 object format.
	 Spur does not have a distinction between compact and non-compact classes."! !

!Behavior methodsFor: '*AST-Core' stamp: ''!
parseTreeFor: aSymbol	
	^ (self compiledMethodAt: aSymbol) parseTree! !

!Behavior methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterInstanceVariablesFor: aStep
	<stSpotterOrder: 20>
	self isTrait
		ifTrue: [ ^ self ].
	aStep listProcessor
		title: 'Instance variables';
		allCandidates: [ self classLayout allSlots ];
		itemName: [ :each | each name asString ];
		filter: StFilterSubstring! !

!Behavior methodsFor: 'user interface' stamp: ''!
withAllSubAndSuperclassesDo: aBlock

	self withAllSubclassesDo: aBlock.
	self allSuperclassesDo: aBlock.! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
localMethodNamed: selector ifAbsent: aBlock
	"Answer the locally defined 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 or it is not a local one, return the value of aBlock"

	^ self compiledMethodAt: selector ifAbsent: aBlock.! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
outerScope
	^self environment! !

!Behavior methodsFor: 'accessing' stamp: ''!
name
	"Answer a String that is the name of the receiver."
	^'a subclass of ', self superclass name.! !

!Behavior methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toTemporaryNamed: aTempVarName inMethod: aMethodName option: option
	| variable |
	
	variable := (self lookupSelector: aMethodName) lookupVar: aTempVarName.
	aMetaLink
		installOnVariable: variable
		for:  self nonAnonymousClass
		option: option
		instanceSpecific: false! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
lookupVar: aName
	^ self classLayout 
		resolveSlot: aName asSymbol 
		ifFound: [:var | var] 
		ifNone: [self bindingOf: aName]! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
instVarNames
	"Answer an Array of the instance variable names. Behaviors must make 
	up fake local instance variable names because Behaviors have instance 
	variables for the purpose of compiling methods, but these are not named 
	instance variables."

	| mySize superSize |
	mySize := self instSize.
	superSize := self superclass
			ifNil: [0]
			ifNotNil: [self superclass instSize].
	mySize = superSize ifTrue: [^#()].	
	^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! !

!Behavior methodsFor: 'adding/removing methods' stamp: ''!
addSelectorSilently: 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"

	self methodDict at: selector put: compiledMethod.
	compiledMethod methodClass: self.
	compiledMethod selector: selector! !

!Behavior methodsFor: 'testing' stamp: ''!
hasAbstractMethods
	"Tells whether the receiver locally defines an abstract method, i.e., a method sending subclassResponsibility"
	"we do not use #anySatisfy: for speed"
	
	self methodsDo: [:each | each isAbstract ifTrue: [ ^true ]].
	^false! !

!Behavior methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
newPinned

	^ self basicNewPinned initialize
! !

!Behavior methodsFor: 'testing' stamp: ''!
isImmediateClass
	"Answer whether the receiver has immediate instances.  Immediate instances
	 store their value in their object pointer, not in an object body.  Hence immediates
	 take no space and are immutable.  The immediates are distinguished by tag bits
	 in the pointer. They include SmallIntegers and Characters.  Hence in the 32-bit
	 system SmallIntegers are 31-bit signed integers and Characters are 30-bit
	 unsigned character codes."
	^self instSpec = 7! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
instanceCount
	"Answer the number of instances of the receiver that are currently in 
	use."

	| count |
	count := 0.
	self allInstancesDo: [:x | count := count + 1].
	^count! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
includesLocalSelector: aSymbol
	^ self includesSelector: aSymbol! !

!Behavior methodsFor: 'adding/removing methods' stamp: ''!
removeSelectorSilently: selector 
	"Remove selector without sending system change notifications"

	^ SystemAnnouncer uniqueInstance suspendAllWhile: [self removeSelector: selector].! !

!Behavior methodsFor: 'testing' stamp: ''!
isBytes
	"Answer whether the receiver has 8-bit instance variables.
	 Above Cog Spur the class format is
		<5 bits inst spec><16 bits inst size>
	 where the 5-bit inst spec is
			0	= 0 sized objects (UndefinedObject True False et al)
			1	= non-indexable objects with inst vars (Point et al)
			2	= indexable objects with no inst vars (Array et al)
			3	= indexable objects with inst vars (MethodContext AdditionalMethodState et al)
			4	= weak indexable objects with inst vars (WeakArray et al)
			5	= weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
			6	= unused
			7	= immediates (SmallInteger, Character)
			8	= unused
			9	= 64-bit indexable
		10-11	= 32-bit indexable (Bitmap)
		12-15	= 16-bit indexable
		16-23	= 8-bit indexable
		24-31	= compiled methods (CompiledMethod)"
	^self instSpec >= 16! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
subclassInstVarNames
	"Answer a Set of the names of the receiver's subclasses' instance variables."
	^self allSubclasses flatCollectAsSet: [:aSubclass | aSubclass instVarNames]! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
whichSelectorsReferTo: literal
	^ (self whichMethodsReferTo: literal) collect: [ :method | method selector ]! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
withAllSubclasses
	"Answer a Set of the receiver, the receiver's descendent's, and the  
	receiver's descendent's subclasses."

	^ self allSubclasses add: self;
		 yourself! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
recompile
	self compileAll! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
allSelectorsWithout: behaviors
	"Returns all the selectors of the receiver and its superclasses, except the ones define in behaviors"

	| selectors |
	selectors := IdentitySet new.
	self withAllSuperclassesDo: [ :class | 
			(behaviors includes: class)
				ifFalse: [ selectors addAll: class selectors ] ].
	^ selectors! !

!Behavior methodsFor: 'accessing - properties' stamp: ''!
propertyAt: propName put: propValue
	^ self ensureProperties
		at: propName
		ifAbsentPut: propValue! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
hasMethodAccessingVariable: aVariable
	"Answer true if any of my methods access the variable"

	^self methods anySatisfy: [ :method | aVariable isAccessedIn: method ]! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
allSuperclasses
	"Answer an OrderedCollection of the receiver's and the receiver's  
	ancestor's superclasses. The first element is the receiver's immediate  
	superclass, followed by its superclass; the last element is Object."
	| temp |
	^ self superclass == nil
		ifTrue: [ OrderedCollection new]
		ifFalse: [temp := self superclass allSuperclasses.
			temp addFirst: self superclass.
			temp]! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ false! !

!Behavior methodsFor: 'queries' stamp: ''!
methodsAccessingSlot: aSlot
	^self methods select: [ :method | method accessesSlot: aSlot ]! !

!Behavior methodsFor: '*Calypso-SystemQueries' stamp: ''!
metaLevelScope
	^self isInstanceSide ifTrue: [ ClyInstanceSideScope ] ifFalse: [ ClyClassSideScope ]! !

!Behavior methodsFor: 'initialization' stamp: ''!
initializeSlots: anObject 
	self classLayout initializeInstance: anObject! !

!Behavior methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterClassInstanceVariablesFor: aStep
	<stSpotterOrder: 25>
	self isTrait
		ifTrue: [ ^ self ].
	aStep listProcessor
		title: 'Class instance variables';
		allCandidates: [ self class classLayout allSlots ];
		itemName: [ :each | each name asString ];
		filter: StFilterSubstring! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
methodDict: aDictionary
	methodDict := aDictionary! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
selectors
	"Answer a Set of all the message selectors specified in the receiver's 
	method dictionary."

	^ self methodDict keys! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level 
	"Walk the tree of subclasses, giving the class and its level"
	| subclassNames |
	classAndLevelBlock value: self value: level.
	self == Class ifTrue:  [^ self].  "Don't visit all the metaclasses"
	"Visit subclasses in alphabetical order"
	subclassNames := SortedCollection new.
	self subclassesDo: [:subC | subclassNames add: subC name].
	subclassNames do:
		[:name | (self environment at: name)
			allSubclassesWithLevelDo: classAndLevelBlock
			startingLevel: level+1]! !

!Behavior methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self methodDict: self methodDict copy! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
evaluate: aString
	^self compiler evaluate: aString! !

!Behavior methodsFor: 'accessing - properties' stamp: ''!
ensureProperties
	^ ClassProperties at: self ifAbsentPut: WeakKeyDictionary new! !

!Behavior methodsFor: '*PharoDocComment' stamp: ''!
hasDocComment
	^ self methods anySatisfy: [:method | method hasDocComment ]! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
hasSelectorReferringTo: literal
	"Answer true if any of my methods access the argument as a literal"

	^self methods anySatisfy: [ :method | method hasLiteral: literal ]! !

!Behavior methodsFor: '*Tools' stamp: ''!
browse

	^  Smalltalk tools browser openOnClass: self! !

!Behavior methodsFor: 'testing' stamp: ''!
isObsolete
	"Return true if the receiver is obsolete."
	^self instanceCount = 0! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
compile: code 
	"Compile the argument, code, as source code in the context of the 
	receiver. Create an error notification if the code can not be compiled. 
	The argument is either a string or an object that converts to a string or a 
	PositionableStream on an object that converts to a string."

	^self compile: code notifying: nil! !

!Behavior methodsFor: 'initialization' stamp: ''!
nonObsoleteClass
	"Attempt to find and return the current version of this obsolete class"

	^ self environment at: self originalName! !

!Behavior methodsFor: 'adding/removing methods' stamp: ''!
adoptInstance: anInstance
	"Change the class of anInstance to me.
	Primitive (found in Cog and new VMs)  follows the same rules as primitiveChangeClassTo:, but returns the 	class rather than the modified instance"
	<primitive: 160 error: ec>
	anInstance primitiveChangeClassTo: self basicNew.
	^self! !

!Behavior methodsFor: 'accessing' stamp: ''!
realClass

	^ self! !

!Behavior methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterTraitUsersFor: aStep
	<stSpotterOrder: 20>
	self isTrait ifFalse: [ ^ self ].
	aStep listProcessor
			title: 'Users';
			allCandidates: [ self users asArray ];
			itemIcon: #systemIcon;
			filter: StFilterSubstring! !

!Behavior methodsFor: '*UndefinedClasses' stamp: ''!
isUndefined
	
	^ self instanceSide inheritsFrom: UndefinedClass! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
lookupVar: aName declare: aBoolean
	^ self lookupVar: aName! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
withAllSuperAndSubclasses
	"Answer the receiver's class hierarchy"

	^self allSuperclasses, self withAllSubclasses! !

!Behavior methodsFor: '*Calypso-SystemQueries' stamp: ''!
includesMethodsAffectedBy: aSystemAnnouncement
	^aSystemAnnouncement affectsMethodsDefinedInClass: self! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
>> selector 
	"Answer the compiled method associated with the argument, selector (a 
	Symbol), a message selector in the receiver's method dictionary. If the 
	selector is not in the dictionary, create an error notification."

	^self compiledMethodAt: selector! !

!Behavior methodsFor: 'testing' stamp: ''!
isCompact
	"Backward compatibility with the Squeak V3 object format.
	Spur does not have a distinction between compact and non-compact classes."
	^false! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
withAllSuperclasses
	"Answer an OrderedCollection of the receiver and the receiver's superclasses. 
	The first element is the receiver, followed by its superclass; 
	the last element is Object."

	^self allSuperclasses 
		addFirst: self; 
		yourself! !

!Behavior methodsFor: 'queries' stamp: ''!
allMethodsReadingSlot: aSlot
	"return all methods that access aSlot in this class and subclasses"
	^self withAllSubclasses flatCollect: [ :class | class methodsReadingSlot: aSlot]! !

!Behavior methodsFor: 'obsolete subclasses' stamp: ''!
obsoleteSubclasses
	"Return all the weakly remembered obsolete subclasses of the receiver"
	| obs |
	obs := self basicObsoleteSubclasses at: self ifAbsent: [^ #()].
	^ obs copyWithout: nil! !

!Behavior methodsFor: 'testing' stamp: ''!
isUsed
	"the class is used somehow. This is client specific, subclasses can override"

	^ self isReferenced! !

!Behavior methodsFor: 'printing' stamp: ''!
printOn: aStream 
	"Refer to the comment in Object|printOn:." 

	aStream nextPutAll: 'a descendent of '.
	self superclass printOn: aStream! !

!Behavior methodsFor: 'queries' stamp: ''!
whichClassDefinesClassVar: aString 
	Symbol hasInterned: aString ifTrue: [ :aSymbol |
		^self whichSuperclassSatisfies: 
			[:aClass | 
			aClass classVarNames anySatisfy: [:each | each = aSymbol]]].
	^#()! !

!Behavior methodsFor: 'queries' stamp: ''!
whichClassDefinesInstVar: aString 
	^self 
		whichSuperclassSatisfies: [:aClass | aClass instVarNames includes: aString]! !

!Behavior methodsFor: 'testing' stamp: ''!
isAnonymous
	^true! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
classBindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver's class"
	^self bindingOf: varName! !

!Behavior methodsFor: 'obsolete subclasses' stamp: ''!
basicObsoleteSubclasses
	^ObsoleteSubclasses.! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
definedVariables
	"return all the Variables defined"
	^ self slots! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
methods
	
	^ self methodDict values! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ false! !

!Behavior methodsFor: '*Tool-CriticBrowser' stamp: ''!
populateCBMenu: aMenu
	
	super populateCBMenu: aMenu.
	aMenu
		add: 'References to...'
		target: SystemNavigation new
		selector: #browseAllCallsOnClass:
		argument: self! !

!Behavior methodsFor: 'testing' stamp: ''!
instSpec
	"Answer the instance specification part of the format that defines what kind of object
	 an instance of the receiver is.  The formats are
			0	= 0 sized objects (UndefinedObject True False et al)
			1	= non-indexable objects with inst vars (Point et al)
			2	= indexable objects with no inst vars (Array et al)
			3	= indexable objects with inst vars (MethodContext AdditionalMethodState et al)
			4	= weak indexable objects with inst vars (WeakArray et al)
			5	= weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
			6	= unused
			7	= immediates (SmallInteger, Character)
			8	= unused
			9	= 64-bit indexable
		10-11	= 32-bit indexable (Bitmap)
		12-15	= 16-bit indexable
		16-23	= 8-bit indexable
		24-31	= compiled methods (CompiledMethod)"
	^(self format bitShift: -16) bitAnd: 16r1F! !

!Behavior methodsFor: 'testing' stamp: ''!
isReferenced
	"Returns true if the class is referenced from a method."
	^ self binding isReferenced! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
allSelectorsBelow: topClass 
	| coll |
	coll := IdentitySet new.
	self withAllSuperclassesDo: 
			[:aClass | 
			aClass = topClass
				ifTrue: [^ coll ]
				ifFalse: [aClass selectorsDo: [ :sel | coll add: sel ]]].
	^ coll! !

!Behavior methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterUsedSlotsFor: aStep
	<stSpotterOrder: 70>
	aStep listProcessor
			title: 'Full Definition Slots';
			allCandidates: [ self slots select: [ :slot | slot needsFullDefinition ] ];
			itemName: [ :item | item definitionString ];
			filter: StFilterSubstring! !

!Behavior methodsFor: 'accessing' stamp: ''!
slots
	^#()! !

!Behavior methodsFor: 'accessing' stamp: ''!
format
	"Answer an Integer that encodes the kinds and numbers of variables of 
	instances of the receiver."

	^format! !

!Behavior methodsFor: 'cleanup' stamp: ''!
restartMethods
	"Clean up. Long running loops or stored closures can lead to methods that are out if sync with the recompiled code. Subclasses should override this method if they need to restart methods"! !

!Behavior methodsFor: 'memory usage' stamp: ''!
instancesSizeInMemory
	"Answers the number of bytes consumed by all its instances including their object header"
	
	| bytes |
	bytes := 0.
	self allInstancesDo: [:each | bytes := bytes + each sizeInMemory  ].
	^ bytes! !

!Behavior methodsFor: 'instance creation' stamp: ''!
new: sizeRequested 
	"Answer an initialized instance of this class with the number of indexable
	variables specified by the argument, sizeRequested."

	^ (self basicNew: sizeRequested) initialize! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
classVarNames
	"Answer a collection of the receiver's class variable names."

	^#()! !

!Behavior methodsFor: 'testing' stamp: ''!
isPool
	^false! !

!Behavior methodsFor: 'dependencies' stamp: ''!
dependentClasses
	"Return the list of classes used myself"
	
	"Morph dependentClasses"
	| cll | 
	cll := Set new.
	"A class depends on its superclass"
	self superclass ifNotNil: [ cll add: self superclass ].
	
	"We unify a class and its metaclass"
	(self methods, self classSide methods) 
		do: [ :m | m literalsDo: [ :l | 
					"We also check if the method is not an extension"
					(l isVariableBinding 
					and: [ l isGlobalClassNameBinding
					and: [ m category notEmpty 
					and: [ m category first ~= $* ]]])  ifTrue: [ cll add: l value ] ] ] .
	^ cll asArray! !

!Behavior methodsFor: '*FluidClassBuilder' stamp: ''!
<< aString
	"Return a builder of class FluidClassBuilder. To get a class, this builder should be sent build.
This way we can manipulate and test class definition without be forced to get them added to the environment."
	
	^ FluidClassBuilder new
		  superclassToBuild: self;
		  nameToBuild: aString;
		  fillClassSideFromEnvironment: self environment;
		  yourself! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
allClassVarNames
	"Answer the names of the receiver's and the receiver's ancestor's class variables."

	^ self superclass
		ifNil: [ self classVarNames ]
		ifNotNil: [ :sup | sup allClassVarNames , self classVarNames ]! !

!Behavior methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
protocols
	
	^ self organization categories copy! !

!Behavior methodsFor: 'accessing' stamp: ''!
classLayout: aClassLayout
	layout := aClassLayout! !

!Behavior methodsFor: 'user interface' stamp: ''!
unreferencedInstanceVariables
	"Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses."

	^ self slots reject: [:slot | slot isReferenced]! !

!Behavior methodsFor: 'enumerating' stamp: ''!
allSuperclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's superclasses."

	self superclass == nil
		ifFalse: [aBlock value: self superclass.
				self superclass allSuperclassesDo: aBlock]! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock
	"Looks up the selector aSymbol in the class chain. If it is found, binaryBlock is evaluated
	with the class that defines the selector and the associated method. Otherwise
	absentBlock is evaluated."

	
	self withAllSuperclassesDo: [:class | | method |
		method := class compiledMethodAt: aSymbol ifAbsent: [nil].
		method ifNotNil: [^ binaryBlock value: class value: method].
	].
	^ absentBlock value.! !

!Behavior methodsFor: 'private' stamp: ''!
handleFailingFailingBasicNew: sizeRequested
	"This basicNew: gets sent after handleFailingBasicNew: has done a full
	 garbage collection and possibly grown memory.  If this basicNew: fails
	 then the system really is low on space, so raise the OutOfMemory signal.

	 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."

	<primitive: 71>
	"space must be low."
	OutOfMemory signal.
	^self basicNew: sizeRequested  "retry if user proceeds"! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
traitCompositionString
	^ '{}'! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
withAllSubclassesDo: aBlock
	"Evaluate the argument, aBlock, for the receiver and each of its subclasses."
	
	self withAllSubclasses do: aBlock! !

!Behavior methodsFor: '*UndefinedClasses' stamp: ''!
isDefined
	
	^ self isUndefined not! !

!Behavior methodsFor: '*System-Support' stamp: ''!
referencedClasses
	"Return the set of classes that are directly referenced by my methods via global Variables"

	^ self methods flatCollectAsSet: [:each | each referencedClasses]! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
setTraitComposition: aComposition

	^ self subclassResponsibility ! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
selectorsWithArgs: numberOfArgs
	"Return all selectors defined in this class that take this number of arguments"

	^ self selectors select: [:selector | selector numArgs = numberOfArgs]! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
someInstance
	"Primitive. Answer the first instance in the enumeration of all instances 
	of the receiver. Fails if there are none. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 77>
	^nil! !

!Behavior methodsFor: 'instance creation' stamp: ''!
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.
	
	 If the primitive fails because space is low then the scavenger will run before the
	 method is activated.  Check args and retry via handleFailingBasicNew: if they're OK."

	<primitive: 71 error: ec>
	ec == #'insufficient object memory' ifTrue:
		[^self handleFailingBasicNew: sizeRequested].
	self isVariable ifFalse:
		[self error: self printString, ' cannot have variable sized instances'].
	self primitiveFailed! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
compiledMethodAt: selector ifPresent: 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 in the dictionary, return the value of aBlock.
	"

	^ self methodDict at: selector ifPresent: aBlock! !

!Behavior methodsFor: '*Fuel-Core' stamp: ''!
fuelIgnoredInstanceVariableNames
	"Indicates which variables have to be ignored during serialization."

	^#()! !

!Behavior methodsFor: '*System-Support' stamp: ''!
allCallsOn: aSymbol
	"Answer of all the methods that call on aSymbol."

	^self withAllSubclasses flatCollect: [ :cls | cls thoroughWhichMethodsReferTo: aSymbol]
	! !

!Behavior methodsFor: '*System-Support' stamp: ''!
allUnsentMessages
	"Answer an array of all the messages defined by the receiver that are not sent anywhere in the system."

	^ SystemNavigation new allUnsentMessagesIn: self selectors! !

!Behavior methodsFor: 'enumerating' stamp: ''!
allSubclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's subclasses."

	self subclassesDo: 
		[:cl | 
		aBlock value: cl.
		cl allSubclassesDo: aBlock]! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
removeSelector: aSelector
	"Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method."

	self methodDict removeKey: aSelector ifAbsent: []! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
allMethods
	"Return the collection of compiled method I and my superclasses are defining"
	"asArray is used to not bump into a bug when comparing compiled methods."
	
	^ self allSelectors asArray collect: [ :s | self lookupSelector: s ]! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
allSubclasses
	"Answer an orderedCollection of the receiver's and the receiver's descendent's subclasses. "

	| scan scanTop |
	scan := OrderedCollection withAll: self subclasses.
	scanTop := 1.
	[scanTop > scan size]
		whileFalse: [scan addAll: (scan at: scanTop) subclasses.
			scanTop := scanTop + 1].
	^ scan! !

!Behavior methodsFor: '*UnifiedFFI' stamp: ''!
ffiInstVarArgument: argName generator: generator
	"Load the instance variable with given name" 

	(self allInstVarNames includes: argName) ifFalse: [ ^ nil ].
	^ FFIInstVarArgument new 
		argName: argName;
		yourself! !

!Behavior methodsFor: 'queries' stamp: ''!
whichSuperclassSatisfies: aBlock 
	(aBlock value: self) ifTrue: [^self].
	^self superclass ifNotNil: [self superclass whichSuperclassSatisfies: aBlock]! !

!Behavior methodsFor: 'testing' stamp: ''!
isWords
	"Answer true if the receiver is made of 32-bit instance variables."

	^self isBytes not! !

!Behavior methodsFor: 'copying' stamp: ''!
deepCopy
	"Classes should only be shallowCopied or made anew."

	^ self shallowCopy! !

!Behavior methodsFor: 'accessing - properties' stamp: ''!
removePropertiesIfEmpty
	^ ClassProperties at: self ifPresent: [ :dict |
		dict ifEmpty: [ ClassProperties removeKey: self ] ]! !

!Behavior methodsFor: '*Reflectivity' stamp: ''!
metaLinkOptions
	^{
	#methodDict -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!Behavior methodsFor: 'accessing' stamp: ''!
binding
	^ LiteralVariable key: nil value: self! !

!Behavior methodsFor: 'testing' stamp: ''!
isManifest
	^ false! !

!Behavior methodsFor: 'accessing - properties' stamp: ''!
removeProperty: propName
	^ self
		removeProperty: propName
		ifAbsent: [ nil ]! !

!Behavior methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterSuperclassesFor: aStep
	<stSpotterOrder: 40>
	aStep listProcessor
			title: 'All superclasses';
			allCandidates: [ self allSuperclasses ];
			itemIcon: #systemIcon;
			filter: StFilterSubstring! !

!Behavior methodsFor: 'testing' stamp: ''!
isAbstract	
	"By default a class is not abstract.
	Hook to mark your own subclasses as abstract."
	
	^false! !

!Behavior methodsFor: 'testing' stamp: ''!
isVariable
	"Answer whether the receiver has indexable variables.
	 Above Cog Spur the class format is
		<5 bits inst spec><16 bits inst size>
	 where the 5-bit inst spec is
			0	= 0 sized objects (UndefinedObject True False et al)
			1	= non-indexable objects with inst vars (Point et al)
			2	= indexable objects with no inst vars (Array et al)
			3	= indexable objects with inst vars (MethodContext AdditionalMethodState et al)
			4	= weak indexable objects with inst vars (WeakArray et al)
			5	= weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
			6	= unused
			7	= immediates (SmallInteger, Character)
			8	= unused
			9	= 64-bit indexable
		10-11	= 32-bit indexable (Bitmap)
		12-15	= 16-bit indexable
		16-23	= 8-bit indexable
		24-31	= compiled methods (CompiledMethod)"
	| instSpec |
	instSpec := self instSpec.
	^instSpec >= 2 and: [instSpec <= 4 or: [instSpec >= 9]]! !

!Behavior methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterUsedTraitsFor: aStep
	<stSpotterOrder: 60>
	aStep listProcessor
			title: 'Uses Traits';
			allCandidates: [ self traits asArray ];
			itemIcon: #systemIcon;
			filter: StFilterSubstring! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := oldClass compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	self addSelector: selector withRecompiledMethod: newMethod.! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
allSelectors
	"Answer all selectors understood by instances of the receiver"

	^ self allSelectorsBelow: nil! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
methodDictionary: aDictionary
	self methodDict: aDictionary! !

!Behavior methodsFor: 'adding/removing methods' stamp: ''!
addSelector: selector withMethod: compiledMethod 
	^ self addSelectorSilently: selector withMethod: compiledMethod! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
allSharedPools
	"Answer an ordered collection of the shared pools that the receiver and the receiver's ancestors share."

	^self superclass allSharedPools! !

!Behavior methodsFor: 'enumerating' stamp: ''!
withAllSuperAndSubclassesDo: aBlock
	self allSuperclassesDo: aBlock.
	aBlock value: self.
	self allSubclassesDo: aBlock! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
basicSuperclass: aClass
	superclass := aClass! !

!Behavior methodsFor: 'accessing' stamp: ''!
subclassDefinerClass
	"Answer an evaluator class appropriate for evaluating definitions of new 
	subclasses of this class."

	^Smalltalk compilerClass! !

!Behavior methodsFor: 'enumerating' stamp: ''!
allInstancesDo: aBlock
	"Evaluate aBlock with each of the current instances of the receiver."
	| instances inst next |
	instances := self allInstancesOrNil.
	instances ifNotNil:
		[instances do: aBlock.
		 ^self].
	"allInstancesOrNil can fail because memory is low.  If so, fall back on the old
	 enumeration code.  Because aBlock might change the class of inst (for example,
	 using become:), it is essential to compute next before aBlock value: inst."
	inst := self someInstance.
	[inst == nil] whileFalse:
		[next := inst nextInstance.
		 aBlock value: inst.
		 inst := next]! !

!Behavior methodsFor: 'navigation' stamp: ''!
methodsReferencingClasses: aCollectionOfClasses
	^ self methods select: [ :meth | meth referencedClasses includesAny: aCollectionOfClasses ]! !

!Behavior methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
methodNamed: aSelector

	^ self methodDict at: aSelector! !

!Behavior methodsFor: 'accessing - properties' stamp: ''!
propertyAt: propName ifAbsent: aBlock
	self properties ifNil: [^aBlock value].
	^ self properties
		at: propName
		ifAbsent: aBlock! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
elementSize
	"Answer the size in bytes of an element in the receiver.  The formats are
			0	= 0 sized objects (UndefinedObject True False et al)
			1	= non-indexable objects with inst vars (Point et al)
			2	= indexable objects with no inst vars (Array et al)
			3	= indexable objects with inst vars (MethodContext AdditionalMethodState et al)
			4	= weak indexable objects with inst vars (WeakArray et al)
			5	= weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
			6	= unused
			7	= immediates (SmallInteger, Character)
			8	= unused
			9	= 64-bit indexable
		10-11	= 32-bit indexable (Bitmap)
		12-15	= 16-bit indexable
		16-23	= 8-bit indexable
		24-31	= compiled methods (CompiledMethod)"
	| instSpec |
	instSpec := self instSpec.
	instSpec < 9 ifTrue: [^Smalltalk wordSize].
	instSpec >= 16 ifTrue: [^1].
	instSpec >= 12 ifTrue: [^2].
	instSpec >= 10 ifTrue: [^4].
	^8! !

!Behavior methodsFor: 'testing' stamp: ''!
isFixed
	"Answer whether the receiver does not have a variable (indexable) part."

	^self isVariable not! !

!Behavior methodsFor: 'printing' stamp: ''!
longPrintOn: aStream
	"Append to the argument, aStream, the names and values of all of the receiver's instance variables.  But, not useful for a class with a method dictionary."

	aStream nextPutAll: '<<too complex to show>>'; cr.! !

!Behavior methodsFor: '*System-Support' stamp: ''!
allCallsOn
	"Answer all the methods that refer to me by name or as part of an association in a global dict."
	self isAnonymous ifTrue: [ ^#() ].
	^self usingMethods, self name asSymbol senders! !

!Behavior methodsFor: 'accessing' stamp: ''!
methodDict
       "The method dictionary of a class can be nil when we want to use the #cannotInterpret: hook. Indeed when a class dictionary is nil, the VM sends the message cannotInterpret: to the receiver but starting the look up in the superclass of the class whose method dictionary was nil.
	 Now the system relies that when the message methodDict is sent to a class a method dictionary is returned. In order to prevent the complaints of tools and IDE unaware of this feature, we fool them by providing an empty MethodDictionary. This will hopefully work in most cases, but the tools will loose the ability to modify the behaviour of this behavior. The user of #cannotInterpret: should be aware of this."

       ^ methodDict ifNil: [ MethodDictionary new ]! !

!Behavior methodsFor: '*UnifiedFFI' stamp: ''!
ffiBindingOf: aName
	"answer a binding for a type name,
	by default use smalltalk name bindings"
	^ self bindingOf: aName! !

!Behavior methodsFor: 'testing - class hierarchy' stamp: ''!
kindOfSubclass
	"Answer a String that is the keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, see #subclassDefiningSymbol"
	^ self classLayout kindOfSubclass! !

!Behavior methodsFor: 'initialization' stamp: ''!
emptyMethodDictionary

	^ MethodDictionary new! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
sourceCodeAt: selector ifAbsent: aBlock

	^ (self compiledMethodAt: selector ifAbsent: [^ aBlock value]) sourceCode.! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
thoroughWhichMethodsReferTo: literal
	"Answer methods whose methods referes to the argument as a literal. 
	 Dives into the compact literal notation and embedded literal arrays, 
    making it slow but thorough "

	| specialIndex |
	"for speed we check the special selectors here once per class"
	specialIndex := Smalltalk specialSelectorIndexOrNil: literal.
	^ self methods select: [ :method | method hasSelector: literal specialSelectorIndex: specialIndex ]! !

!Behavior methodsFor: 'testing' stamp: ''!
sourceMatchesBytecodeAt: selector
	"Answers true if the source code at the selector compiles to the bytecode at the selector, and false
	otherwise. Implemented to detect an error where Monticello did not recompile sources when the class
	shape changed"

	"This code was copied from #recompile:from:, with few changes. Several methods would benefit from a
	method which turned a selector and class into a CompiledMethod, without  installing it into the 
	methodDictionary"

	| method newMethod |

	method := self compiledMethodAt: selector.
	newMethod := self compiler
			source: (self sourceCodeAt: selector);
			class: self;
			failBlock: [^ false];
			compiledMethodTrailer: method trailer;
			compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!!!'].
	^ newMethod = method! !

!Behavior methodsFor: 'system startup' stamp: ''!
shutDown
	"This message is sent on system shutdown to registered classes"! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
traits
	^ #()! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
recompile: selector
	"Compile the method associated with selector in the receiver's method dictionary."
	^self recompile: selector from: self! !

!Behavior methodsFor: 'testing' stamp: ''!
isMeta
	^ false! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
allSubInstances 
	"Answer a list of all current instances of the receiver and all of its subclasses."
	| aCollection |
	aCollection := OrderedCollection new.
	self allSubInstancesDo:
		[:x | x == aCollection ifFalse: [aCollection add: x]].
	^ aCollection! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
includesMethod: aMethod 
	"Answer whether aMethod is in the method dictionary. Use identityIncludes
	as = of CompiledMethod is too weak (ignores the selector)"

	^ self methodDict identityIncludes: aMethod! !

!Behavior methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterSubclassesFor: aStep
	<stSpotterOrder: 50>
	aStep listProcessor
			title: 'All subclasses';
			allCandidates: [ self allSubclasses ];
			itemIcon: #systemIcon;
			filter: StFilterSubstring! !

!Behavior methodsFor: 'accessing' stamp: ''!
classLayout
	^ layout
		ifNil: [ 
			| superLayout scope |
			superLayout := superclass 
				ifNil: [ FixedLayout new slotScope: LayoutEmptyScope instance] "happened in the bootrap"
				ifNotNil: [:sl | sl classLayout].
			scope := superLayout slotScope extend.
			layout := superLayout class extending: superLayout scope: scope host: self ]! !

!Behavior methodsFor: 'enumerating' stamp: ''!
selectSuperclasses: aBlock 
	"Evaluate the argument, aBlock, with the receiver's superclasses as the 
	argument. Collect into an OrderedCollection only those superclasses for 
	which aBlock evaluates to true. In addition, evaluate aBlock for the 
	superclasses of each of these successful superclasses and collect into the 
	OrderedCollection ones for which aBlock evaluates to true. Answer the 
	resulting OrderedCollection."

	| aSet |
	aSet := Set new.
	self allSuperclasses do: 
		[:aSuperclass | 
		(aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]].
	^aSet! !

!Behavior methodsFor: 'private' stamp: ''!
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: 'accessing - method dictionary' stamp: ''!
allSelectorsAboveUntil: aRootClass

	| coll |
	coll := IdentitySet new.
	(self allSuperclassesIncluding: aRootClass) 
		do: [:aClass | 
				aClass selectorsDo: [ :sel | coll add: sel ]].
	^ coll! !

!Behavior methodsFor: '*Monticello' stamp: 'nil'!
mcType
	"Answer the symbol that Monticello uses internally to encode layouts"
	^self classLayout class mcTypeSymbol! !

!Behavior methodsFor: 'instance creation' stamp: ''!
new
	"Answer a new initialized instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable."

	^ self basicNew initialize! !

!Behavior methodsFor: 'initialization' stamp: ''!
obsolete
	"nothing to be done"! !

!Behavior methodsFor: 'private' stamp: ''!
handleFailingBasicNew
	"handleFailingBasicNew gets sent after basicNew has failed and allowed
	 a scavenging garbage collection to occur.  The scavenging collection
	 will have happened as the VM is activating the (failing) basicNew.  If
	 handleFailingBasicNew fails then the scavenge failed to reclaim sufficient
	 space and a global garbage collection is required.  Retry after garbage
	 collecting and growing memory if necessary.

	 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."

	<primitive: 70>
	Smalltalk garbageCollect < 1048576 ifTrue:
		[Smalltalk growMemoryByAtLeast: 1048576].
	^self handleFailingFailingBasicNew "retry after global garbage collect"! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
sourceCodeAt: selector

	^ (self compiledMethodAt: selector) sourceCode.! !

!Behavior methodsFor: '*Tools' stamp: ''!
inspectSubInstances 
	"Inspect all instances of the receiver and all its subclasses.  CAUTION - don't do this for something as generic as Object!!"

	| all allSize prefix |
	all := self allSubInstances.
	(allSize := all size) isZero ifTrue: [^ self inform: 'There are no 
instances of ', self name, '
or any of its subclasses'].
	prefix := allSize = 1
		ifTrue: 	['The lone instance']
		ifFalse:	['The ', allSize printString, ' instances'].
	
	all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! !

!Behavior methodsFor: 'naming' stamp: ''!
environment
	"Return the environment in which the receiver is visible"
	^Smalltalk globals! !

!Behavior methodsFor: 'navigation' stamp: ''!
methodsReferencingClass: aClass

	^self methodsReferencingClasses: { aClass }! !

!Behavior methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
newPinned: sizeRequested

	^ (self basicNewPinned: sizeRequested) initialize
! !

!Behavior methodsFor: 'reflective operations' stamp: ''!
basicIdentityHash
	"Answer a 22 bits unsigned SmallInteger, whose value is related to the receiver's identity
	 and unique among the behaviors (i.e. 2 different Behaviors cannot have the same identityHash).
	
	 Behavior implements identityHash to allow the VM to use an object representation which
	 does not include a direct reference to an object's class in an object.  If the VM is using
	 this implementation then classes are held in a class table and instances contain the index
	 of their class in the table.  A class's class table index is its identityHash so that an instance
	 can be created without searching the table for a class's index.  The VM uses this primitive
	 to enter the class into the class table, assigning its identityHash with an as yet unused
	 class table index. If this primitive fails it means that the class table is full.  In Spur as of
	 2014 there are 22 bits of classTable index and 22 bits of identityHash per object.

	 Primitive. Essential. Do not override. See Object documentation whatIsAPrimitive."

	<primitive: 175>
	self primitiveFailed! !

!Behavior methodsFor: '*Tools' stamp: ''!
inspectAllInstances 
	"Inspect all instances of the receiver."

	| all allSize prefix |
	all := self allInstances.
	(allSize := all size) isZero ifTrue: [^ self inform: 'There are no 
instances of ', self name].
	prefix := allSize = 1
		ifTrue: 	['The lone instance']
		ifFalse:	['The ', allSize printString, ' instances'].
	
	all asArray inspectWithLabel: (prefix, ' of ', self name)! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
whichMethodsReferTo: aLiteral
	"Answer methods whose methods directly refers to the argument as a literal"

	^ self methods select: [ :method | method hasLiteral: aLiteral ]! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
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
		ifNil: [ self basicSuperclass: aClass.
			Object flushCache.
			^ self
			].	"If the class is not nil it should update the class hierarchy correctly, using the classs builder"
	^ self classInstaller
		update: self
		to: [ :builder | 
			builder
				fillFor: self;
				superclass: aClass
			]! !

!Behavior methodsFor: 'queries' stamp: ''!
methodsReadingSlot: aSlot
	^self methods select: [ :method | method readsSlot: aSlot ]! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
scopeLevel
	"For debugging we print a counter for all scopes, starting from the Method as 1, so we are 0"
	^ 0! !

!Behavior methodsFor: 'testing' stamp: ''!
isBits
	"Answer whether the receiver contains just bits (not pointers).
	 Above Cog Spur the class format is
		<5 bits inst spec><16 bits inst size>
	 where the 5-bit inst spec is
			0	= 0 sized objects (UndefinedObject True False et al)
			1	= non-indexable objects with inst vars (Point et al)
			2	= indexable objects with no inst vars (Array et al)
			3	= indexable objects with inst vars (MethodContext AdditionalMethodState et al)
			4	= weak indexable objects with inst vars (WeakArray et al)
			5	= weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
			6	= unused
			7	= immediates (SmallInteger, Character)
			8	= unused
			9	= 64-bit indexable
		10-11	= 32-bit indexable (Bitmap)
		12-15	= 16-bit indexable
		16-23	= 8-bit indexable
		24-31	= compiled methods (CompiledMethod)"
	^self instSpec >= 7! !

!Behavior methodsFor: 'queries' stamp: ''!
methodsWritingSlot: aSlot
	^self methods select: [ :method | method writesSlot: aSlot ]! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
allTraits
	^ #()! !

!Behavior methodsFor: 'accessing' stamp: ''!
classDepth

	self superclass ifNil: [^ 1].
	^ self superclass classDepth + 1! !

!Behavior methodsFor: 'initialization' stamp: ''!
initialize
	"moved here from the class side's #new"
	super initialize.
	self basicSuperclass: Object.
	"no longer sending any messages, some of them crash the VM"
	self methodDict: self emptyMethodDictionary.
	self setFormat: Object format.! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
lookupSelector: selector
	"Look up the given selector in my methodDictionary.
	Return the corresponding method if found.
	Otherwise chase the superclass chain and try again.
	Return nil if no method is found."
	| lookupClass |
	lookupClass := self.
	[lookupClass == nil]
		whileFalse: [ 
			lookupClass methodDict 
				at: selector
				ifPresent: [ :method | ^ method ].
			lookupClass := lookupClass superclass].
	^ nil! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
compiler
	"Answer a compiler appropriate for source methods of this class."

	^self compilerClass new
		environment: self environment;
		class: self! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
hasMethods
	"Answer whether the receiver has any methods in its method dictionary."

	^ self methodDict notEmpty! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
compiledMethodAt: selector 
	"Answer the compiled method associated with the argument, selector (a 
	Symbol), a message selector in the receiver's method dictionary. If the 
	selector is not in the dictionary, create an error notification."

	^ self methodDict at: selector! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
compileAll
	^ self compileAllFrom: self! !

!Behavior methodsFor: '*Fuel-Core' stamp: ''!
fuelNew
	"Answer an instance of mine in which serialized references will be injected."

	^ self basicNew! !

!Behavior methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterCompositionFor: aStep
	<stSpotterOrder: 25>
	aStep listProcessor
			title: 'Composing traits';
			allCandidates: [ self allTraits ];
			itemIcon: #systemIcon;
			filter: StFilterSubstring! !

!Behavior methodsFor: 'enumerating' stamp: ''!
selectSubclasses: aBlock 
	"Evaluate the argument, aBlock, with each of the receiver's (next level) 
	subclasses as its argument. Collect into a Set only those subclasses for 
	which aBlock evaluates to true. In addition, evaluate aBlock for the 
	subclasses of each of these successful subclasses and collect into the set 
	those for which aBlock evaluates true. Answer the resulting set."

	| aSet |
	aSet := Set new.
	self allSubclasses do: 
		[:aSubclass | 
		(aBlock value: aSubclass) ifTrue: [aSet add: aSubclass]].
	^aSet! !

!Behavior methodsFor: 'accessing - class hierarchy' stamp: ''!
allSuperclassesIncluding: aClass
	"Answer an OrderedCollection of the receiver's and the receiver's  ancestor's superclasses
	up to aClass included. If aClass is not part of the receiver's superclass, returns up to the root."
	| temp |
	self class == ProtoObject class ifTrue: [ ^ OrderedCollection new].
	^ self superclass == aClass
		ifTrue: [ OrderedCollection with: aClass]
		ifFalse: [temp := self superclass allSuperclassesIncluding: aClass.
			temp addFirst: self superclass.
			temp]! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
thoroughWhichSelectorsReferTo: literal
	^ (self thoroughWhichMethodsReferTo: literal) collect: [ :method | method selector ]! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
allTemps
	^#()! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self methods! !

!Behavior methodsFor: 'private' stamp: ''!
flushCache
	"Tell the virtual machine to remove the contents of its method lookup caches, if it has any.  This must be done when the system 	modifies the class hierarchy so that message lookups reflect the revised organization.  c.f. Symbol>>flushCache & 	CompiledMethod>>flushCache.  Essential. See MethodDictionary class comment."

	<primitive: 89>
	self primitiveFailed! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
byteSizeOfInstance
	"Answer the total memory size of an instance of the receiver."

	<primitive: 181 error: ec>
	self isVariable ifTrue:
		[^self byteSizeOfInstanceOfSize: 0].
	self primitiveFailed! !

!Behavior methodsFor: 'testing - class hierarchy' stamp: ''!
inheritsFrom: aClass 
	"Answer whether the argument, aClass, is on the receiver's superclass 
	chain."

	| aSuperclass |
	aSuperclass := self superclass.
	[aSuperclass == nil]
		whileFalse: 
			[aSuperclass == aClass ifTrue: [^true].
			aSuperclass := aSuperclass superclass].
	^false! !

!Behavior methodsFor: 'testing - class hierarchy' stamp: ''!
isRootInEnvironment
	^self superclass isNil! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
bindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver"
	^self superclass bindingOf: varName! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
instSize
	"Answer the number of named instance variables
	(as opposed to indexed variables) of the receiver.
	 Above Cog Spur the class format is
		<5 bits inst spec><16 bits inst size>"
	^format bitAnd: 16rFFFF! !

!Behavior methodsFor: 'testing - class hierarchy' stamp: ''!
includesBehavior: aClass
	
	self isTrait ifTrue: [ ^false ].
	^self == aClass or:[self inheritsFrom: aClass]! !

!Behavior methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the origin of my given method. In a basic class is always self.
	Enhanced classes (eg. TraitedClasses) can do something else"
	^ self! !

!Behavior methodsFor: '*Calypso-SystemQueries' stamp: ''!
calypsoEnvironmentType
	^ClyClass! !

!Behavior methodsFor: 'queries' stamp: ''!
allMethodsAccessingSlot: aSlot
	"return all methods that access aSlot in this class and subclasses"
	^self withAllSubclasses flatCollect: [ :class | class methodsAccessingSlot: aSlot ]! !

!Behavior methodsFor: 'testing - method dictionary' stamp: ''!
thoroughWhichMethodsReferTo: literal specialIndex: specialIndex
	"Answer methods whose methods referes to the argument as a literal. 
	 Dives into the compact literal notation and embedded literal arrays, 
    making it slow but thorough "

	^ self methods select: [ :method | method hasSelector: literal specialSelectorIndex: specialIndex ]! !

!Behavior methodsFor: 'accessing' stamp: ''!
allSlots
	^#()! !

!Behavior methodsFor: 'accessing - properties' stamp: ''!
hasProperty: aKey
	self propertyAt: aKey ifAbsent: [ ^ false ].
	^ true! !

!Behavior methodsFor: 'accessing - method dictionary' stamp: ''!
selectorsAndMethodsDo: selectorAndMethodBlock
	"Evaluate selectorAndMethodBlock with two arguments for each selector/method pair in my method dictionary."

	^ self methodDict keysAndValuesDo: selectorAndMethodBlock! !

!Behavior methodsFor: '*OpalCompiler-Core' stamp: ''!
compile: code notifying: requestor 
	"Compile the argument, code, as source code in the context of the 
	receiver and insEtall the result in the receiver's method dictionary. The 
	second argument, requestor, is to be notified if an error occurs. The 
	argument code is either a string or an object that converts to a string or 
	a PositionableStream. This method also saves the source code."
	
	| method |
	method  := self compiler
		source: code;
		requestor: requestor;
		failBlock: [ ^nil ];
		compile.
		
	method putSource: code
			withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr].
	self addSelector: method selector withMethod: method.
	^ method selector! !

!Behavior methodsFor: 'queries' stamp: ''!
usingMethods
	"all methods that reference me"
	self isAnonymous ifTrue: [ ^#() ].
	^self binding usingMethods! !

!Behavior methodsFor: 'system startup' stamp: ''!
shutDown: quitting
	"This message is sent on system shutdown to registered classes"
	^self shutDown.! !

!Behavior methodsFor: 'initialization' stamp: ''!
superclass: aClass methodDictionary: mDict format: fmt
	"Basic initialization of the receiver.
	Must only be sent to a new instance; else we would need Object flushCache."
	self basicSuperclass: aClass.
	self setFormat: fmt.
	self methodDict: mDict.! !

!Behavior methodsFor: 'queries' stamp: ''!
pragmasDo: aBlock
	self methodsDo: [ :method | method pragmasDo: aBlock ]! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
instanceVariables
	"in older version, this method was returning names, not objects"
	^self slots! !

!Behavior methodsFor: '*Tools' stamp: ''!
browseHierarchy
	self systemNavigation browseHierarchy: self! !

!Behavior methodsFor: 'accessing - properties' stamp: ''!
properties
	^ ClassProperties at: self ifAbsent: nil! !

!Behavior methodsFor: '*TraitsV2' stamp: ''!
localSelectors
	
	^ self methodDict keys! !

!Behavior methodsFor: 'system startup' stamp: ''!
startUp: resuming
	"This message is sent to registered classes when the system is coming up."
	^self startUp! !

!Behavior methodsFor: 'compiling' stamp: ''!
sourceCodeTemplate
	"Answer an expression to be edited and evaluated in order to define 
	methods in this class or trait."

	^ 'methodSelectorAndArgumentNames
	"comment stating purpose of instance-side method"
	"scope: class-variables  &  instance-variables"	
			
	| temporary variable names |
	statements'! !

!Behavior methodsFor: 'testing' stamp: ''!
isBehavior
	"Return true if the receiver is a behavior"
	^true! !

!Behavior methodsFor: 'cleanup' stamp: ''!
cleanUp
	"Clean out any caches and other state that should be flushed when trying to get an image into a pristine state. Subclasses may override #cleanUp: to provide different levels of cleanliness"! !

!Behavior methodsFor: 'accessing - instances and variables' stamp: ''!
byteSizeOfInstanceOfSize: basicSize
	"Answer the total memory size of an instance of the receiver
	 with the given number of indexable instance variables."

	<primitive: 181 error: ec>
	self isVariable
		ifTrue: "If the primitive overflowed answer a close approximation"
			[(basicSize isInteger
			  and: [basicSize >= 16r1000000]) ifTrue:
				[^2 * (self byteSizeOfInstanceOfSize: basicSize + 1 // 2)
				   - (self byteSizeOfInstanceOfSize: 0)]]
		ifFalse:
			[basicSize = 0 ifTrue:
				[^self byteSizeOfInstance]].
	self primitiveFailed! !

!Behavior methodsFor: '*Fuel-Core' stamp: ''!
fuelNew: sizeRequested 
	"Answer an instance of mine in which serialized references will be injected."

	^ self basicNew: sizeRequested! !

!Behavior class methodsFor: 'class initialization' stamp: ''!
initializeClassProperties
	ClassProperties := WeakIdentityKeyDictionary new.! !

!Behavior class methodsFor: 'class initialization' stamp: ''!
initialize
	"Behavior initialize"
	"Never called for real"
	ObsoleteSubclasses
		ifNil: [ self initializeObsoleteSubclasses ]
		ifNotNil: [ | newDict | 
			newDict := WeakKeyToCollectionDictionary newFrom: ObsoleteSubclasses.
			newDict rehash.
			ObsoleteSubclasses := newDict ].
		
	ClassProperties
		ifNil: [ self initializeClassProperties ]
		ifNotNil: [ | newDict | 
			newDict := WeakIdentityKeyDictionary newFrom: ClassProperties.
			newDict rehash.
			ClassProperties := newDict ]! !

!Behavior class methodsFor: 'class initialization' stamp: ''!
flushObsoleteSubclasses
	"Behavior flushObsoleteSubclasses"
	ObsoleteSubclasses finalizeValues.! !

!Behavior class methodsFor: 'class initialization' stamp: ''!
initializeObsoleteSubclasses
	ObsoleteSubclasses := WeakKeyToCollectionDictionary new.! !

!Behavior class methodsFor: '*Collections-Abstract' stamp: ''!
sortBlock
	^ [ :a :b | a name <= b name ]! !

!Behavior class methodsFor: 'cleanup' stamp: ''!
cleanUp
	"Flush the obsolete subclasses."

	self flushObsoleteSubclasses! !

!BehaviorOwnedChunk commentStamp: ''!
I'm an abstract class grouping the behavior of the code declarations that will be installed in a behavior, such as methods, class comments, organizations...!
!BehaviorOwnedChunk methodsFor: 'accessing' stamp: ''!
isMeta: aBoolean

	isMeta := aBoolean! !

!BehaviorOwnedChunk methodsFor: 'accessing' stamp: ''!
targetClass

	| target |
	target := self class environment at: behaviorName.
	^ isMeta
		  ifTrue: [ target classSide ]
		  ifFalse: [ target ]! !

!BehaviorOwnedChunk methodsFor: 'accessing' stamp: ''!
isMeta

	^ isMeta! !

!BehaviorOwnedChunk methodsFor: 'accessing' stamp: ''!
behaviorName

	^ behaviorName! !

!BehaviorOwnedChunk methodsFor: 'testing' stamp: ''!
existsBehavior

	^ self class environment includesKey: behaviorName! !

!BehaviorOwnedChunk methodsFor: 'accessing' stamp: ''!
behaviorName: aBehaviorName

	behaviorName := aBehaviorName! !

!BehaviorOwnedChunk class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == BehaviorOwnedChunk! !

!BehaviorTest commentStamp: ''!
SUnit tests for Behavior!
!BehaviorTest methodsFor: 'tests' stamp: ''!
testBehaviornewnewShouldNotCrash

	Behavior new new.
	"still not working correctly but at least does not crash the image"! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testallSuperclassesIncluding
		
	|cls |
	cls := ArrayedCollection allSuperclassesIncluding: Collection.
	self deny: (cls includes: ArrayedCollection).
	self deny: (cls includes: Object). 
	self assert: (cls includes: Collection). 
	self assert: (cls includes: SequenceableCollection).! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testsourceCodeTemplateFor
	"check for distictive source code templates for class-side and instance-side"
	self assert: ((Object sourceCodeTemplate) includesSubstring: 'instance-side method'). 
	self assert: ((Object class sourceCodeTemplate) includesSubstring: 'class-side method')! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testIncludesMethod
	self assert: (Object includesMethod: Object>>#halt).
	self deny: (Class includesMethod: Object>>#halt).

	self assert: (Point includesMethod: Point>>#x).
	self deny: (LookupKey includesMethod: Point>>#x).! !

!BehaviorTest methodsFor: 'tests - queries' stamp: ''!
testthoroughWhichMethodsReferToSpecialIndex
	| array |
	array := #(thisIsOnlyHereIntestthoroughWhichMethodsReferTo).
	"normal case"
	self assert: (Point thoroughWhichMethodsReferTo: #x specialIndex: ( Smalltalk specialSelectorIndexOrNil: #+)) notEmpty.
	"we understand send bytecodes for special selectors"
	self assert: (Point thoroughWhichMethodsReferTo: #+ specialIndex: ( Smalltalk specialSelectorIndexOrNil: #+)) notEmpty.
	"we dive into literal arrays"
	self assert: (self class thoroughWhichMethodsReferTo: array first specialIndex: nil) notEmpty.
	"and we are false for non existing symbols"
	self assert: (self class thoroughWhichMethodsReferTo: ('this', 'doesNotExist') asSymbol specialIndex: nil) isEmpty.! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
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 - queries' stamp: ''!
testallMethodsAccessingSlot
	| methods |	
	"Check the source code availability to do not fail on images without sources"
	(Point>>#x) hasSourceCode ifFalse: [ ^ self ].


	methods := LookupKey allMethodsAccessingSlot: (LookupKey slotNamed: #key).
	self assert: (methods includes: (Association >>#key:value:))! !

!BehaviorTest methodsFor: 'tests - properties' stamp: ''!
testRemoveProperty
	self class propertyAt: #testKeySelector put: 1.
	self class removeProperty: #testKeySelector.
	self assert: (self class propertyAt: #testKeySelector) equals: nil! !

!BehaviorTest methodsFor: 'tests - properties' stamp: ''!
testHasProperty
	| testValue |
	testValue := Date today.
	self class propertyAt: #testKeySelector put: testValue.
	self assert: (self class hasProperty: #testKeySelector).
	
	self class removeProperty: #testKeySelector.
	self deny: (self class hasProperty: #testKeySelector)! !

!BehaviorTest methodsFor: 'tests - queries' stamp: ''!
testallMethodsWritingSlot
	| methods |	
	"Check the source code availability to do not fail on images without sources"
	(Point>>#x) hasSourceCode ifFalse: [ ^ self ].


	methods := LookupKey allMethodsWritingSlot: (LookupKey slotNamed: #key).
	self assert: (methods includes: (Association >>#key:value:))! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testIsRootInEnvironment
	self assert: ProtoObject isRootInEnvironment.
	self deny: Object isRootInEnvironment! !

!BehaviorTest methodsFor: 'tests - queries' stamp: ''!
testMethodsWritingSlot
	| numberViaSlot numberViaIVar |
	"Check the source code availability to do not fail on images without sources"
	(Point >> #x) hasSourceCode
		ifFalse: [ ^ self ].
	numberViaSlot := (Point methodsWritingSlot: (Point slotNamed: #x))
		size.
	numberViaIVar := (Point whichSelectorsWrite: 'x') size.
	self assert: numberViaSlot equals: numberViaIVar! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
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: ''!
testNonObsoleteClass
	"Does it work on not-obsolete classes?"
	self assert: Object nonObsoleteClass equals: Object.
	"The case for obsolete classes (obtaining the #originalName) is tested 
	in ObsoleteTest>>#testClassObsolete"! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testIsAbstract

	self deny: Behavior isAbstract.	
	self deny: Behavior class isAbstract.
	self deny: ClassDescription isAbstract.
	self deny: ClassDescription class isAbstract.
	
	self deny: Class isAbstract.
	self deny: Class class isAbstract.
	self deny: Object isAbstract.
	self deny: Object class isAbstract.! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testAllSelectors
	self assert: ProtoObject allSelectors asSet equals: ProtoObject selectors asSet.
	self assert: Object allSelectors asSet equals: (Object selectors asSet union: ProtoObject selectors).
	self assert: (Object allSelectorsBelow: ProtoObject) asSet equals: Object selectors asSet! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testOriginalName
	"Does it work on not-obsolete classes?"
	self assert: Object originalName equals: #Object.
	"The case for obsolete classes is tested in ObsoleteTest>>#testClassObsolete"! !

!BehaviorTest methodsFor: 'tests - queries' stamp: ''!
testallMethodsReadingSlot
	| methods |	
	"Check the source code availability to do not fail on images without sources"
	(Point>>#x) hasSourceCode ifFalse: [ ^ self ].

	methods := LookupKey allMethodsReadingSlot: (LookupKey slotNamed: #key).
	self assert: (methods includes: (Ephemeron >>#mourn))! !

!BehaviorTest methodsFor: 'tests - queries' stamp: ''!
testMethodsAccessingSlot
	| numberViaSlot numberViaIVar |
	"Check the source code availability to do not fail on images without sources"
	(Point >> #x) hasSourceCode ifFalse: [ ^ self ].

	numberViaSlot := (Point methodsAccessingSlot: (Point slotNamed: #x)) size.
	numberViaIVar := (Point whichSelectorsAccess: 'x') size.
	self assert: numberViaSlot equals: numberViaIVar! !

!BehaviorTest methodsFor: 'tests - queries' stamp: ''!
testDefinedVariables
	self assert: Behavior new definedVariables isEmpty.
	self assert: Point definedVariables equals: Point instanceVariables.
	self assert: ReservedVariable class definedVariables first name equals: #instance.
	self assert: (SmalltalkImage definedVariables includes: (SmalltalkImage classVariableNamed: #CompilerClass)).! !

!BehaviorTest methodsFor: 'tests - queries' stamp: ''!
testthoroughWhichMethodsReferTo
	| array |
	array := #(thisIsOnlyHereIntestthoroughWhichMethodsReferTo).
	"normal case"
	self assert: (Point thoroughWhichMethodsReferTo: #x) notEmpty.
	"we understand send bytecodes for special selectors"
	self assert: (Point thoroughWhichMethodsReferTo: #+) notEmpty.
	"we dive into literal arrays"
	self assert: (self class thoroughWhichMethodsReferTo: array first) notEmpty.
	"and we are false for non existing symbols"
	self assert: (self class thoroughWhichMethodsReferTo: ('this', 'doesNotExist') asSymbol) isEmpty.! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testBinding
	self assert: Object binding value equals: Object.
	self assert: Object binding key equals: #Object.

	self assert: Object class binding value equals: Object class.

	"returns nil for Metaclasses... like Encoder>>#associationFor:"

	self assert: Object class binding key isNil! !

!BehaviorTest methodsFor: 'metrics' stamp: ''!
testInstSize
	self assert: Object instSize equals: 0.
	self assert: Point instSize equals: 2.
	self assert: Metaclass instSize equals: 6! !

!BehaviorTest methodsFor: 'tests - properties' stamp: ''!
testPropertyValueAtPut
	| testValue |
	testValue := Date today.
	self class propertyAt: #testKeySelector put: testValue.
	self
		assert: (self class propertyAt: #testKeySelector)
		equals: testValue.
	self class removeProperty: #testKeySelector! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testIsUsed
	self assert: Object isUsed.
	self assert: Object class isUsed! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
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: ObjectLayout hasAbstractMethods.
	"ObjectLayout defines methods because its class side contains abstract methods"
	self assert: ObjectLayout class hasAbstractMethods.! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testAllMethods
	| allMethods nonOverridenMethods |
	allMethods := IdentitySet new
		addAll: Object allMethods;
		yourself.
	self assert: (allMethods includesAll: Object methods).	"We fetch all compiled methods that are not redefined in Object"
	nonOverridenMethods := OrderedCollection new.
	ProtoObject
		selectorsAndMethodsDo: [ :sel :method | 
			(Object includesSelector: sel)
				ifFalse: [ nonOverridenMethods add: method ] ].
	self assert: (allMethods includesAll: nonOverridenMethods)! !

!BehaviorTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAllReferencesTo
	| result |
	result := SystemNavigation new allReferencesTo: Point binding.
	result do: [ :each | self assert: (each compiledMethod hasLiteral: Point binding) ].
	self assert: (result anySatisfy: [ :each | each methodClass = self class and: [ each selector = #testAllReferencesTo ] ]).
		
	result := SystemNavigation new allReferencesTo: #printOn:.
	result do: [ :each | self assert: (each compiledMethod refersToLiteral: #printOn:) ].
	self assert: (result anySatisfy: [ :each | each methodClass = self class and: [ each selector = #testAllReferencesTo ] ]).
	
	result := SystemNavigation new allReferencesTo: #+.
	result do: [ :each | self assert: ((each compiledMethod sendsSelector: #+) or: [ each compiledMethod refersToLiteral: #+ ]) ].
	self assert: (result anySatisfy: [ :each | each methodClass = self class and: [ each selector = #testAllReferencesTo ] ])! !

!BehaviorTest methodsFor: 'tests - queries' stamp: ''!
testMethodsReadingSlot
	| numberViaSlot numberViaIVar |
	"Check the source code availability to do not fail on images without sources"
	(Point >> #x) hasSourceCode ifFalse: [ ^ self ].

	numberViaSlot := (Point methodsReadingSlot: (Point slotNamed: #x)) size.
	numberViaIVar := (Point whichSelectorsRead: 'x') size.
	self assert: numberViaSlot equals: numberViaIVar! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
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: 'coverage' stamp: ''!
classToBeTested
	
	^ Behavior! !

!BehaviorTest methodsFor: 'tests' stamp: ''!
testIsReferenced
	self assert: Object isReferenced.
	self deny: Object class isReferenced! !

!BehaviorWithCompilerTest methodsFor: 'tests' stamp: ''!
newClass2

	^ self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: 'MySubclass';
			superclass: c1;
			package: self class category ]! !

!BehaviorWithCompilerTest methodsFor: 'running' stamp: ''!
tearDown 
	
	c2 ifNotNil: [ c2 removeFromSystem ].
	c1 ifNotNil: [ c1 removeFromSystem ].
	
	super tearDown.! !

!BehaviorWithCompilerTest methodsFor: 'tests' stamp: ''!
testCanUnderstand
	
	c1 := self newClass1.
	c1 compile: 'method1 ^self subclassResponsibility'.
	c1 compile: 'method2 ^123'.
	
	self assert: (c1 canUnderstand: #method1).
	self assert: (c1 canUnderstand: #method2).
	self deny: (c1 canUnderstand: #method3).! !

!BehaviorWithCompilerTest methodsFor: 'tests' stamp: ''!
testCompile

	| behavior |

	behavior := Behavior new.
	behavior compile: 'thisIsATest ^2'.
	behavior new thisIsATest! !

!BehaviorWithCompilerTest methodsFor: 'tests' stamp: ''!
testCanPerform
	
	c1 := self newClass1.

	c1 compile: 'method1 ^self subclassResponsibility'.
	c1 compile: 'method2 ^123'.
	
	self deny: (c1 canPerform: #method1).
	self assert: (c1 canPerform: #method2).
	self deny: (c1 canPerform: #method3).! !

!BehaviorWithCompilerTest methodsFor: 'tests' stamp: ''!
newClass1

	^ self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: 'MySuperclass';
			package: self class category ]! !

!BehaviorWithCompilerTest methodsFor: 'tests' stamp: ''!
testCanPerformInSubclass
	
	c1 := self newClass1.
	
	c2 := self newClass2.
	
	c2 compile: 'method1 ^ 3'.
	c2 compile: 'method3 ^5'.
	
	self assert: (c2 canPerform: #method1).
	self assert: (c2 canPerform: #method3).! !

!BehaviorWithCompilerTest methodsFor: 'tests' stamp: ''!
testCanUnderstandInSubclass
	
	c1 := self newClass1.

	c2 := self newClass2.
	c2 compile: 'method1 ^ 3'.
	c2 compile: 'method3 ^5'.
	
	self assert: (c2 canUnderstand: #method1).
	self assert: (c2 canUnderstand: #method3).! !

!BenchSqueakFFIPlugin commentStamp: ''!
I am a simple class to benchmark the old squeak FFI implementation!
!BenchSqueakFFIPlugin methodsFor: 'private' stamp: ''!
doCallWith: aFloat another: aDouble

	^ self ffiCall: #(float sumAFloatAndADouble(float aFloat, double aDouble))! !

!BenchSqueakFFIPlugin methodsFor: 'accessing' stamp: ''!
ffiLibraryName

	^ 'libTestLibrary.dylib'! !

!BenchSqueakFFIPlugin methodsFor: 'running' stamp: ''!
runCall
	<script: 'self new runCall'>
	| return | 

	^ [ return := self doCallWith: 1.0 another: 2.0.
		 self assert: return = 3.0 ] bench! !

!BenchTFFISameThread commentStamp: ''!
I am a simple benchmark class to test the TFFISameThread scheme!
!BenchTFFISameThread methodsFor: 'private' stamp: ''!
doCallWith: aFloat another: aDouble

	^ self ffiCall: #(float sumAFloatAndADouble(float aFloat, double aDouble))! !

!BenchTFFISameThread methodsFor: 'accessing' stamp: ''!
ffiLibrary

	^ TFTestLibraryUsingSameThreadRunner uniqueInstance! !

!BenchTFFISameThread methodsFor: 'running' stamp: ''!
runCall
	<script: 'self new runCall'>
	| return | 

	^ [ return := self doCallWith: 1.0 another: 2.0.
		 self assert: return = 3.0 ] bench! !

!BenchTFFISameThread methodsFor: 'accessing' stamp: ''!
calloutAPIClass 

	^ TFCalloutAPI! !

!BenchTFFIWorker commentStamp: ''!
I am a simple benchmark class to test the TFFIWorker scheme!
!BenchTFFIWorker methodsFor: 'accessing' stamp: ''!
ffiLibrary

	^ TFTestLibraryUsingWorker uniqueInstance! !

!BenchmarkResult commentStamp: ''!
I am BenchmarkResult. 

I know how much iterations where executed in a specific elapsed time duration.

I am the result of running the same piece of code multiple times.

I can compute my average #frequencey (#executionsPerSecond) and #period (#timePerExecution).

I have a human friendly print representation.

BenchmarkResult new
	iterations: 20000;
	elapsedTime: 10 seconds;
	yourself.
!
!BenchmarkResult methodsFor: 'testing' stamp: ''!
isEmpty
	iterations isNil | elapsedTime isNil 
		ifTrue: [ ^ true ].
	iterations isZero | elapsedTime isZero 
		ifTrue: [ ^ true ].
	^ false! !

!BenchmarkResult methodsFor: 'accessing' stamp: ''!
iterations: integer
	"Set the number of iterations that were executed"

	iterations := integer! !

!BenchmarkResult methodsFor: 'accessing' stamp: ''!
iterations
	"Return the number of iterations that were executed"
	
	^ iterations! !

!BenchmarkResult methodsFor: 'printing' stamp: ''!
printFrequenceOn: stream
	self frequency printOn: stream showingDecimalPlaces: 3.
	stream << ' per second'! !

!BenchmarkResult methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(.
	self isEmpty
		ifTrue: [ 
			stream << ' empty' ]
		ifFalse: [ 
			iterations printWithCommasOn: stream.
			stream space; << ('iteration' asPluralBasedOn: iterations).
			stream << ' in '.
			elapsedTime printHumanReadableOn: stream.
			stream << '. '.
			self printFrequenceOn: stream ].
	stream nextPut: $)! !

!BenchmarkResult methodsFor: 'accessing' stamp: ''!
executionsPerSecond
	"Return the average number of executions per second"

	^ self frequency! !

!BenchmarkResult methodsFor: 'accessing' stamp: ''!
period
	"Return the average duration of one iteration"
	
	^ elapsedTime / iterations! !

!BenchmarkResult methodsFor: 'printing' stamp: ''!
shortPrintString
	self isEmpty
		ifTrue: [ ^ self printString ].
	^ String streamContents: [ :out | self printFrequenceOn: out ]! !

!BenchmarkResult methodsFor: 'accessing' stamp: ''!
frequency
	"Return the average number of executions per second"
	
	^ iterations / elapsedTime totalSeconds! !

!BenchmarkResult methodsFor: 'accessing' stamp: ''!
timePerExecution
	"Return the average duration of one iteration"

	^ self period! !

!BenchmarkResult methodsFor: 'accessing' stamp: ''!
elapsedTime: duration
	"Set the duration of the total execution time"
	
	elapsedTime := duration! !

!BenchmarkResult methodsFor: 'accessing' stamp: ''!
elapsedTime
	"Return the duration of the total execution time"
	
	^ elapsedTime! !

!BenchmarkResultTest commentStamp: ''!
Unit test for BenchmarkResult!
!BenchmarkResultTest methodsFor: 'tests' stamp: ''!
testOne
	| benchmarkResult |
	benchmarkResult := BenchmarkResult new.
	benchmarkResult iterations: 1.
	benchmarkResult elapsedTime: 1 second.
	self deny: benchmarkResult isEmpty.
	self assert: benchmarkResult iterations equals: 1.
	self assert: benchmarkResult elapsedTime equals: 1 second.
	self assert: benchmarkResult frequency equals: 1.
	self assert: benchmarkResult executionsPerSecond equals: 1.
	self assert: benchmarkResult period equals: 1 second.
	self assert: benchmarkResult timePerExecution equals: 1 second.
	"cover the code at least"
	self deny: benchmarkResult shortPrintString isEmpty.
	self deny: benchmarkResult printString isEmpty! !

!BenchmarkResultTest methodsFor: 'tests' stamp: ''!
testOneOverTwo
	| benchmarkResult |
	benchmarkResult := BenchmarkResult new.
	benchmarkResult iterations: 1.
	benchmarkResult elapsedTime: 2 second.
	self deny: benchmarkResult isEmpty.
	self assert: benchmarkResult iterations equals: 1.
	self assert: benchmarkResult elapsedTime equals: 2 second.
	self assert: benchmarkResult frequency equals: 0.5.
	self assert: benchmarkResult executionsPerSecond equals: 0.5.
	self assert: benchmarkResult period equals: 2 second.
	self assert: benchmarkResult timePerExecution equals: 2 second.
	"cover the code at least"
	self assert: benchmarkResult shortPrintString equals: '0.500 per second'.
	self deny: benchmarkResult printString isEmpty! !

!BenchmarkResultTest methodsFor: 'tests' stamp: ''!
testEmpty
	| benchmarkResult |
	benchmarkResult := BenchmarkResult new.
	self assert: benchmarkResult isEmpty.
	self assert: benchmarkResult iterations isNil.
	self assert: benchmarkResult elapsedTime isNil.
	"cover the code at least"
	self deny: benchmarkResult shortPrintString isEmpty.
	self deny: benchmarkResult printString isEmpty! !

!BenchmarkResultTest methodsFor: 'tests' stamp: ''!
testSimple
	| benchmarkResult |
	benchmarkResult := BenchmarkResult new.
	benchmarkResult iterations: 100.
	benchmarkResult elapsedTime: 4 seconds.
	self deny: benchmarkResult isEmpty.
	self assert: benchmarkResult iterations equals: 100.
	self assert: benchmarkResult elapsedTime equals: 4 seconds.
	self assert: benchmarkResult frequency equals: 25.
	self assert: benchmarkResult executionsPerSecond equals: 25.
	self assert: benchmarkResult period equals: 40 milliSeconds.
	self assert: benchmarkResult timePerExecution equals: 40 milliSeconds.
	"cover the code at least"
	self assert: benchmarkResult shortPrintString equals: '25.000 per second'.
	self deny: benchmarkResult printString isEmpty! !

!Bezier2Segment commentStamp: ''!
This class represents a quadratic bezier segment between two points

Instance variables:
	via		<Point>	The additional control point (OFF the curve)!
!Bezier2Segment methodsFor: 'accessing' stamp: ''!
bounds
	"Return the bounds containing the receiver"
	^super bounds encompass: via! !

!Bezier2Segment methodsFor: 'testing' stamp: ''!
isBezier2Segment
	"Return true if the receiver is a quadratic bezier segment"
	^true! !

!Bezier2Segment methodsFor: 'converting' stamp: ''!
asBezier2Points: error
	^Array with: start with: via with: end! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
parameterAtExtremeY
	"Note: Only valid for non-monoton receivers"
	^self parameterAtExtreme: 1.0@0.0.! !

!Bezier2Segment methodsFor: 'testing' stamp: ''!
hasZeroLength
	"Return true if the receiver has zero length"
	^start = end and:[start = via]! !

!Bezier2Segment methodsFor: 'printing' stamp: ''!
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: 'accessing' stamp: ''!
degree
	^2! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
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: ''!
parameterAtExtremeX
	"Note: Only valid for non-monoton receivers"
	^self parameterAtExtreme: 0.0@1.0.! !

!Bezier2Segment methodsFor: 'initialize' stamp: ''!
from: startPoint to: endPoint withMidPoint: pointOnCurve
	"Initialize the receiver with the pointOnCurve assumed at the parametric value 0.5"
	start := startPoint.
	end := endPoint.
	"Compute via"
	via := (pointOnCurve * 2) - (start + end * 0.5).! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
length
	"Return the length of the receiver"
	"Note: Overestimates the length"
	^(start distanceTo: via) + (via distanceTo: end)! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
valueAt: parameter
	"Evaluate the receiver at the given parametric value"
	"Return the point at the parametric value t:
		p(t) =	(1-t)^2 * p1 + 
				2*t*(1-t) * p2 + 
				t^2 * p3.
	"
	| t1 t2 t3 |
	t1 := (1.0 - parameter) squared.
	t2 := 2 * parameter * (1.0 - parameter).
	t3 := parameter squared.
	^(start * t1) + (via * t2) + (end * t3)! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
controlPointsDo: aBlock
	aBlock value: start; value: via; value: end! !

!Bezier2Segment methodsFor: 'initialize' stamp: ''!
initializeFrom: controlPoints
	controlPoints size = 3 ifFalse:[self error:'Wrong number of control points'].
	start := controlPoints at: 1.
	via := controlPoints at: 2.
	end := controlPoints at: 3.! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
controlPoints
	^{start. via. end}! !

!Bezier2Segment methodsFor: 'converting' stamp: ''!
asTangentSegment
	^LineSegment from: via-start to: end-via! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
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: ''!
tangentAtEnd
	"Return the tangent for the last point"
	^end - via! !

!Bezier2Segment methodsFor: 'testing' stamp: ''!
isStraight
	"Return true if the receiver represents a straight line"
	^(self tangentAtStart crossProduct: self tangentAtEnd) = 0! !

!Bezier2Segment methodsFor: 'converting' stamp: ''!
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: 'vector functions' stamp: ''!
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: 'converting' stamp: ''!
asBezier2Segment
	"Represent the receiver as quadratic bezier segment"
	^self! !

!Bezier2Segment methodsFor: 'converting' stamp: ''!
asIntegerSegment
	"Convert the receiver into integer representation"
	^self species 
			from: start asIntegerPoint 
			to: end asIntegerPoint 
			via: via asIntegerPoint! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
tangentAtStart
	"Return the tangent for the first point"
	^via - start! !

!Bezier2Segment methodsFor: 'initialize' stamp: ''!
from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter
	"Initialize the receiver with the pointOnCurve at the given parametric value"
	| t1 t2 t3 |
	start := startPoint.
	end := endPoint.
	"Compute via"
	t1 := (1.0 - parameter) squared.
	t2 := 1.0 / (2 * parameter * (1.0 - parameter)).
	t3 := parameter squared.
	via := (pointOnCurve - (start * t1)  - (end * t3)) * t2! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
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: ''!
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: 'bezier clipping' stamp: ''!
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: 'initialize' stamp: ''!
from: startPoint to: endPoint
	"Initialize the receiver as straight line"
	start := startPoint.
	end := endPoint.
	via := (start + end) // 2.! !

!Bezier2Segment methodsFor: 'initialize' stamp: ''!
from: startPoint to: endPoint via: viaPoint
	"Initialize the receiver"
	start := startPoint.
	end := endPoint.
	via := viaPoint.! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
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: ''!
roundTo: quantum
	super roundTo: quantum.
	via := via roundTo: quantum.! !

!Bezier2Segment methodsFor: 'vector functions' stamp: ''!
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: 'accessing' stamp: ''!
via
	"Return the control point"
	^via! !

!Bezier2Segment class methodsFor: 'utilities' stamp: ''!
makeEllipseSegments: aRectangle
	"Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle.
	This method creates eight bezier segments (two for each quadrant) approximating the oval."
	"EXAMPLE: 
	This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval.
		| rect |
		rect := 100@100 extent: 1200@500.
		Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red.
		(Bezier2Segment makeEllipseSegments: rect) do:[:seg|
			seg lineSegmentsDo:[:last :next|
				Display getCanvas line: last to: next width: 1 color: Color black]].
	"
	"EXAMPLE: 
		| minRadius maxRadius |
		maxRadius := 300.
		minRadius := 20.
		maxRadius to: minRadius by: -10 do:[:rad|
			| rect |
			rect := 400@400 - rad corner: 400@400 + rad.
			Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red.
			(Bezier2Segment makeEllipseSegments: rect) do:[:seg|
				seg lineSegmentsDo:[:last :next|
					Display getCanvas line: last to: next width: 1 color: Color black]]].
	"
	| nrm topCenter leftCenter rightCenter bottomCenter dir scale seg1a topRight seg1b seg2a bottomRight seg2b center bottomLeft topLeft seg3a seg3b seg4a seg4b |
	dir := aRectangle width * 0.5.
	nrm := aRectangle height * 0.5.

	"Compute the eight control points on the oval"
	scale := 0.7071067811865475. "45 degreesToRadians cos = 45 degreesToRadians sin = 2 sqrt / 2"
	center := aRectangle origin + aRectangle corner * 0.5.

	topCenter := aRectangle topCenter.
	rightCenter := aRectangle rightCenter.
	leftCenter := aRectangle leftCenter.
	bottomCenter := aRectangle bottomCenter.

	topRight := (center x + (dir * scale)) @ (center y - (nrm * scale)).
	bottomRight := (center x + (dir * scale)) @ (center y + (nrm * scale)).
	bottomLeft := (center x - (dir * scale)) @ (center y + (nrm * scale)).
	topLeft := (center x - (dir * scale)) @ (center y - (nrm * scale)).

	scale := 0.414213562373095. "2 sqrt - 1"

	dir := (dir * scale) @ 0.
	nrm := 0 @ (nrm * scale).
	
	seg1a := self from: topCenter via: topCenter + dir to: topRight.
	seg1b := self from: topRight via: rightCenter - nrm to: rightCenter.

	seg2a := self from: rightCenter via: rightCenter + nrm to: bottomRight.
	seg2b := self from: bottomRight via: bottomCenter + dir to: bottomCenter.

	seg3a := self from: bottomCenter via: bottomCenter - dir to: bottomLeft.
	seg3b := self from: bottomLeft via: leftCenter + nrm to: leftCenter.

	seg4a := self from: leftCenter via: leftCenter - nrm to: topLeft.
	seg4b := self from: topLeft via: topCenter - dir to: topCenter.

	^{seg1a. seg1b. seg2a. seg2b. seg3a. seg3b. seg4a. seg4b}! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: ''!
from: startPoint withMidPoint: pointOnCurve at: parameter to: endPoint 
	^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: ''!
from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter
	^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: ''!
from: startPoint to: endPoint withMidPoint: pointOnCurve
	^self new from: startPoint to: endPoint withMidPoint: pointOnCurve! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: ''!
from: startPoint withMidPoint: pointOnCurve to: endPoint 
	^self new from: startPoint to: endPoint withMidPoint: pointOnCurve! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: ''!
from: startPoint to: endPoint via: viaPoint
	^self new from: startPoint to: endPoint via: viaPoint! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: ''!
from: startPoint via: viaPoint to: endPoint 
	^self new from: startPoint to: endPoint via: viaPoint! !

!Bezier3Segment commentStamp: ''!
This class represents a cubic bezier segment between two points

Instance variables:
	via1, via2	<Point>	The additional control points (OFF the curve)!
!Bezier3Segment methodsFor: 'accessing' stamp: ''!
bounds
	^ ((super bounds encompassing: via1) encompassing: via2)! !

!Bezier3Segment methodsFor: 'converting' stamp: ''!
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: 'accessing' stamp: ''!
via1: aPoint
	via1 := aPoint! !

!Bezier3Segment methodsFor: 'accessing' stamp: ''!
via1
	^via1! !

!Bezier3Segment methodsFor: 'accessing' stamp: ''!
via2
	^via2! !

!Bezier3Segment methodsFor: 'converting' stamp: ''!
asBezier2Segments
	"Demote a cubic bezier to a set of approximating quadratic beziers."
	^self asBezier2Segments: 0.5! !

!Bezier3Segment methodsFor: 'accessing' stamp: ''!
degree
	^3! !

!Bezier3Segment methodsFor: 'accessing' stamp: ''!
length
	"Answer a gross approximation of the length of the receiver"
	^(start distanceTo: via1) + (via1 distanceTo: via2) + (via2 distanceTo: end)! !

!Bezier3Segment methodsFor: 'accessing' stamp: ''!
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: 'vector functions' stamp: ''!
controlPointsDo: aBlock
	aBlock value: start; value: via1; value: via2; value: end! !

!Bezier3Segment methodsFor: 'vector functions' stamp: ''!
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: 'vector functions' stamp: ''!
tangentAtEnd
	^end - via2! !

!Bezier3Segment methodsFor: 'initialization' stamp: ''!
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: ''!
controlPoints
	^{start. via1. via2. end}! !

!Bezier3Segment methodsFor: 'converting' stamp: ''!
asTangentSegment
	^Bezier2Segment 
		from: via1-start 
		via: via2-via1
		to: end-via2! !

!Bezier3Segment methodsFor: 'converting' stamp: ''!
asBezierShape
	"Demote a cubic bezier to a set of approximating quadratic beziers."
	^self asBezierShape: 0.5! !

!Bezier3Segment methodsFor: 'private' stamp: ''!
bezier2SegmentCount
	"Compute the number of quadratic bezier segments needed to approximate
	this cubic with less than a 1-pixel error"
	^ self bezier2SegmentCount: 1.0! !

!Bezier3Segment methodsFor: 'vector functions' stamp: ''!
tangentAtMid
	| tan1 tan2 tan3 |
	tan1 := via1 - start.
	tan2 := via2 - via1.
	tan3 := end - via2.
	^(tan1 + (2*tan2) + tan3) * 0.25! !

!Bezier3Segment methodsFor: 'converting' stamp: ''!
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: 'vector functions' stamp: ''!
tangentAtStart
	^via1 - start! !

!Bezier3Segment methodsFor: 'converting' stamp: ''!
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: 'vector functions' stamp: ''!
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: 'bezier clipping' stamp: ''!
bezierClipHeight: dir
	"Check if the argument overlaps the receiver somewhere 
	along the line from start to end. Optimized for speed."
	| u dirX dirY dx dy uMin uMax |
	dirX := dir x.
	dirY := dir y.
	uMin := 0.0.
	uMax := (dirX * dirX) + (dirY * dirY).

	dx := via1 x - start x.
	dy := via1 y - start y.
	u := (dirX * dx) + (dirY * dy).
	u < uMin ifTrue:[uMin := u].
	u > uMax ifTrue:[uMax := u].

	dx := via2 x - start x.
	dy := via2 y - start y.
	u := (dirX * dx) + (dirY * dy).
	u < uMin ifTrue:[uMin := u].
	u > uMax ifTrue:[uMax := u].

	^uMin@uMax! !

!Bezier3Segment methodsFor: 'vector functions' stamp: ''!
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 distanceTo: newEnd) * 0.3.
	newVia1 := newStart + (tan1 * dist).
	newVia2 := newEnd - (tan2 * dist).
	^self class from: newStart via: newVia1 and: newVia2 to: newEnd.! !

!Bezier3Segment methodsFor: 'converting' stamp: ''!
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: ''!
from: aPoint1 via: aPoint2 and: aPoint3 to: aPoint4
	start := aPoint1.
	via1 := aPoint2.
	via2 := aPoint3.
	end := aPoint4! !

!Bezier3Segment methodsFor: 'vector functions' stamp: ''!
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: 'accessing' stamp: ''!
via2: aPoint
	via2 := aPoint! !

!Bezier3Segment class methodsFor: 'utilities' stamp: ''!
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: ''!
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: ''!
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: ''!
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: ''!
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 distanceTo: pt1).
	length > 0.0 ifTrue:[ scale := scale / length].
	"now sample the cubic bezier (optimized version for coincident control points)"
	cp1 := pt1 + (dir1 * (scale * 0.75)).
	cp2 := pt2 - (dir2 * (scale * 0.75)).
	pt3 := cp1 + cp2 * 0.5.
	"compute the magic constant"
	scale := (pt3 - mid) r / scale.
	magic := 1.0 - length / scale.
	"and finally answer the pie segment"
	^self
		from: pt1
		via: pt1 + (dir1 * magic)
		and: pt2 - (dir2 * magic)
		to: pt2! !

!Bezier3Segment class methodsFor: 'instance creation' stamp: ''!
from: p1 to: p2
	^ self new from: p1 via: (p1 interpolateTo: p2 at: 0.3333) and: (p1
interpolateTo: p2 at: 0.66667) to: p2! !

!Bezier3Segment class methodsFor: 'utilities' stamp: ''!
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: ''!
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: 'instance creation' stamp: ''!
from: p1 via: p2 and: p3 to: p4
	^ self new from: p1 via: p2 and: p3 to: p4! !

!BinaryFileStream commentStamp: ''!
I am a concrete subclass of AbstractBinaryFileStream for normal files. Regardless the position of the file, I will make my operarions on my position and then return the file it's own position.

In addition to my superclass' API I provide the following methods.

stream upToEnd
"reads the full stream up to the end and returns the contents"!
!BinaryFileStream methodsFor: 'positioning' stamp: 'nil'!
truncate: pos
	"Truncate to this position"

	^ File truncate: handle to: pos! !

!BinaryFileStream methodsFor: 'positioning' stamp: 'nil'!
skip: n
	"Set the character position to n characters from the current position."
	self position: self position + n! !

!BinaryFileStream methodsFor: 'positioning' stamp: 'nil'!
truncate

	self truncate: 0! !

!BinaryFileStream methodsFor: 'accessing' stamp: 'nil'!
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 |
	self atEnd ifTrue: [^ nil].
	next := self next.
	self position: self position - 1.
	^ next! !

!BinaryFileStream methodsFor: 'open/close' stamp: 'nil'!
close
	self closed
		ifTrue: [ ^ self ].
	File close: handle.
	self unregister.
	handle := nil! !

!BinaryFileStream methodsFor: 'finalization' stamp: 'nil'!
unregister

	File unregister: self! !

!BinaryFileStream methodsFor: 'testing' stamp: 'nil'!
closed
	^ handle isNil or: [ (File sizeOrNil: handle) isNil ]! !

!BinaryFileStream methodsFor: 'finalization' stamp: 'nil'!
finalize

	^ self close! !

!BinaryFileStream methodsFor: 'finalization' stamp: 'nil'!
register

	File register: self! !

!BinaryFileStreamTest commentStamp: ''!
Unit tests for binary file streams!
!BinaryFileStreamTest methodsFor: 'running' stamp: ''!
tearDown

	self killTestFile.
	"We must ensure that files are collected before running other tests.
	In windows, we cannot open the same file twice."
	3 timesRepeat: [ Smalltalk garbageCollect ].
	super tearDown.! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testFileWithSomeBytesSizeIsNotZero
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	file nextPut: 1.
	self assert: file position equals: 1.
	file nextPutAll: #[1 2 3].
	self assert: file position equals: 4.
	file nextPut: 1.
	self assert: file position equals: 5! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testPeekDoesNotAdvanceTheStream
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	file nextPut: 1.
	file nextPut: 2.
	file nextPut: 3.
	file close.
	
	file := self fileStreamForFileNamed: 'testFile'.
	self assert: file position equals: 0.
	self assert: file peek equals: file peek.
	self assert: file position equals: 0! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testSkipLecture
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	file nextPut: 1.
	file nextPut: 2.
	file nextPut: 3.
	file close.
	
	file := self fileStreamForFileNamed: 'testFile'.
	file skip: 2.
	self assert: file next equals: 3! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testWriteMultipleBytes
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	file nextPutAll: #[1 2].
	file close.

	file := self fileStreamForFileNamed: 'testFile'.
	self assert: file next equals: 1.
	self assert: file next equals: 2! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testReadLessThanAvailableYieldsJustRead
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	file nextPut: 1.
	file nextPut: 2.
	file nextPut: 3.
	file close.
	
	file := self fileStreamForFileNamed: 'testFile'.
	self assert: (file next:2) equals: #[1 2]! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testEmptyFileIsAtEnd
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	self assert: file atEnd! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testReadMoreThanAvailableYieldsOnlyAvailable
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	self assert: (file next:2) equals: #[].
	
	"then we put one element and we close it"
	file nextPut: 1.
	file close.
	
	file := self fileStreamForFileNamed: 'testFile'.
	self assert: (file next:2) equals: #[1]! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testFullFileIsAtEnd
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	file nextPut: 1.
	self assert: file atEnd! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testReadWhenNothingAvailableYieldsNil
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	self assert: file next equals: nil! !

!BinaryFileStreamTest methodsFor: 'private' stamp: ''!
fileStreamForFileNamed: fileName

	^ (File named: fileName) writeStream! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testOpenFile

	self fileStreamForFileNamed: 'testFile'.

	self assert: (File named: 'testFile') exists! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testWriteReadInt
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	file nextPut: 1.
	file close.

	file := self fileStreamForFileNamed: 'testFile'.
	self assert: file next equals: 1! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testWriteToClosedFileFails
	
	| fileStream |
	fileStream := self fileStreamForFileNamed: 'testFile'.
	fileStream close.
	self should: [ fileStream wrappedStream nextPut: 1 ] raise: Error! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testReadFullFileIsAtEnd
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	file nextPut: 1.
	file close.
	
	file := self fileStreamForFileNamed: 'testFile'.
	file next.
	self assert: file atEnd! !

!BinaryFileStreamTest methodsFor: 'private' stamp: ''!
killTestFile

	(File named: 'testFile') exists
		ifTrue: [ (File named: 'testFile') delete ].! !

!BinaryFileStreamTest methodsFor: 'testing' stamp: ''!
testReadMultipleBytes
	
	| file |
	file := self fileStreamForFileNamed: 'testFile'.
	file nextPut: 1.
	file nextPut: 2.
	file close.

	file := self fileStreamForFileNamed: 'testFile'.
	self assert: (file next: 2) equals: #[1 2]! !

!BinaryFileStreamTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	self killTestFile.! !

!BitBlt commentStamp: ''!
I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm.  The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm.  If both are specified, their pixel values are combined with a logical AND function prior to transfer.  In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule.

The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows:
	8:	if source is 0 and destination is 0
	4:	if source is 0 and destination is 1
	2:	if source is 1 and destination is 0
	1:	if source is 1 and destination is 1.
At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions;  if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero.  Forms may be of different depths, see the comment in class Form.

In addition to the original 16 combination rules, this BitBlt supports
	16	fails (to simulate paint bits)
	17	fails (to simulate erase bits)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord.  Sum of color components
	21	rgbSub: sourceWord with: destinationWord.  Difference of color components
	22	OLDrgbDiff: sourceWord with: destinationWord.  Sum of abs of differences in components
	23	OLDtallyIntoMap: destinationWord.  Tallies pixValues into a colorMap
			these old versions don't do bitwise dest clipping.  Use 32 and 33 now.
	24	alphaBlend: sourceWord with: destinationWord.  32-bit source and dest only
	25	pixPaint: sourceWord with: destinationWord.  Wherever the sourceForm is non-zero, it replaces the destination.  Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1.
	26	pixMask: sourceWord with: destinationWord.  Like pixPaint, but fills with 0.
	27	rgbMax: sourceWord with: destinationWord.  Max of each color component.
	28	rgbMin: sourceWord with: destinationWord.  Min of each color component.
	29	rgbMin: sourceWord bitInvert32 with: destinationWord.  Min with (max-source)
	30	alphaBlendConst: sourceWord with: destinationWord.  alpha is an arg. works in 16 bits.
	31	alphaPaintConst: sourceWord with: destinationWord.  alpha is an arg. works in 16 bits.
	32	rgbDiff: sourceWord with: destinationWord.  Sum of abs of differences in components
	33	tallyIntoMap: destinationWord.  Tallies pixValues into a colorMap
	34	alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord.

The color specified by halftoneForm may be either a Color or a Pattern.   A Color is converted to a pixelValue for the depth of the destinationForm.  If a Pattern, BitBlt will simply interpret its bitmap as an array of Color pixelValues.  BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary.  Within each scan line the 32-bit value is repeated from left to right across the form.  If the value repeats on pixels boudaries, the effect will be a constant color;  if not, it will produce a halftone that repeats on 32-bit boundaries.

Any transfer specified is further clipped by the specified rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms.
	To make a small Form repeat and fill a big form, use an InfiniteForm as the source.
	To write on a form and leave with both transparent and opapue areas, use a MaskedForm as the source.

Pixels from a source to a destination whose pixels have a different depth are converted based on the optional colorMap.  If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits.  

The colorMap, if specified, must be a either word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source, or a fully specified ColorMap which may contain a lookup table (ie Bitmap) and/or four separate masks and shifts which are applied to the pixels. For every source pixel, BitBlt will first perform masking and shifting and then index the lookup table, and select the corresponding pixelValue and mask it to the destination pixel size before storing.
	When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation.  This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color.  Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped.  The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1.  Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color).
	Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors.
	Colors can be remapped at the same depth.  Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file.  Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of.  MaskedForm will use the colorMap when copying to the display or another Form. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)!
!BitBlt methodsFor: 'accessing' stamp: ''!
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: 'line drawing' stamp: ''!
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 |
	<primitive: 'primitiveDrawLoop' module: 'BitBltPlugin'>
	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: '*Graphics-Fonts' stamp: ''!
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: 'accessing' stamp: ''!
halftoneForm: aBitmap
	"Sets the receivers half tone form. See class commment."
	
	halftoneForm := aBitmap! !

!BitBlt methodsFor: 'accessing' stamp: ''!
destY: anInteger 
	"Set the top left y coordinate of the receiver's destination form to be the 
	argument, anInteger."
	destY := anInteger! !

!BitBlt methodsFor: 'copying' stamp: ''!
copyForm: srcForm to: destPt rule: rule
	^ self copyForm: srcForm to: destPt rule: rule
		colorMap: (srcForm colormapIfNeededFor: destForm)! !

!BitBlt methodsFor: 'private' stamp: ''!
colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix 
	| srcIndex map mapsForSource mapsForSourceAndDest |
	ColorConvertingMaps class == Array ifFalse: [ ColorConvertingMaps := (1 to: 10) collect: [ :i | Array new: 32 ] ].
	srcIndex := sourceDepth.
	sourceDepth > 8 ifTrue: 
		[ srcIndex := keepSubPix 
			ifTrue: [ 9 ]
			ifFalse: [ 10 ] ].
	mapsForSource := ColorConvertingMaps at: srcIndex.
	(mapsForSourceAndDest := mapsForSource at: destDepth) ifNil: 
		[ mapsForSourceAndDest := mapsForSource 
			at: destDepth
			put: Dictionary new ].
	map := mapsForSourceAndDest 
		at: targetColor
		ifAbsentPut: 
			[ Color 
				computeColorConvertingMap: targetColor
				from: sourceDepth
				to: destDepth
				keepSubPixelAA: keepSubPix ].
	^ map! !

!BitBlt methodsFor: 'copying' stamp: ''!
copyForm: srcForm to: destPt rule: rule fillColor: color 
	sourceForm := srcForm.
	self fillColor: color.	"sets halftoneForm"
	combinationRule := rule.
	destX := destPt x + sourceForm offset x.
	destY := destPt y + sourceForm offset y.
	sourceX := 0.
	sourceY := 0.
	width := sourceForm width.
	height := sourceForm height.
	self copyBits! !

!BitBlt methodsFor: 'private' stamp: ''!
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: 'line drawing' stamp: ''!
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: 'private' stamp: ''!
setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 
	| aPoint |
	destForm := df.
	sourceForm := sf.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule := cr.
	destX := destOrigin x.
	destY := destOrigin y.
	sourceX := sourceOrigin x.
	sourceY := sourceOrigin y.
	width := extent x.
	height := extent y.
	aPoint := clipRect origin.
	clipX := aPoint x.
	clipY := aPoint y.
	aPoint := clipRect corner.
	clipWidth := aPoint x - clipX.
	clipHeight := aPoint y - clipY.
	sourceForm == nil ifFalse: [ colorMap := sourceForm colormapIfNeededFor: destForm ]! !

!BitBlt methodsFor: 'accessing' stamp: ''!
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: ''!
clipY: anInteger 
	"Set the receiver's clipping area top left y coordinate to be the argument, 
	anInteger."
	clipY := anInteger! !

!BitBlt methodsFor: 'copying' stamp: ''!
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."

	<primitive: 'primitiveCopyBits' module: 'BitBltPlugin'>

	"Check for compressed source, destination or halftone forms"
	((sourceForm isForm) and: [sourceForm unhibernate])
		ifTrue: [^ self copyBitsTranslucent: factor].
	((destForm isForm) and: [destForm unhibernate])
		ifTrue: [^ self copyBitsTranslucent: factor].
	((halftoneForm isForm) and: [halftoneForm unhibernate])
		ifTrue: [^ self copyBitsTranslucent: factor].

	self primitiveFailed  "Later do nicer error recovery -- share copyBits recovery"! !

!BitBlt methodsFor: 'accessing' stamp: ''!
clipX
	^clipX! !

!BitBlt methodsFor: 'copying' stamp: ''!
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: 'accessing' stamp: ''!
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: ''!
clipWidth: anInteger 
	"Set the receiver's clipping area width to be the argument, anInteger."
	clipWidth := anInteger! !

!BitBlt methodsFor: 'private' stamp: ''!
copyBitsFrom: x0 to: x1 at: y 
	destX := x0.
	destY := y.
	sourceX := x0.
	width := x1 - x0.
	self copyBits! !

!BitBlt methodsFor: 'accessing' stamp: ''!
clipHeight
	^clipHeight! !

!BitBlt methodsFor: 'copying' stamp: ''!
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: ''!
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"
	<primitive: 'primitiveCopyBits' module: 'BitBltPlugin' error: ec>
	ec == #'object moved' ifTrue:
		[ ^self copyBits ].
	(combinationRule between: 30 and: 31) ifTrue: 
		[ "No alpha specified -- re-run with alpha = 1.0"
		^ self copyBitsTranslucent: 255 ].
	(sourceForm isForm and: [ sourceForm unhibernate ]) ifTrue: [ ^ self copyBits ].
	(destForm isForm and: [ destForm unhibernate ]) ifTrue: [ ^ self copyBits ].
	(halftoneForm isForm and: [ halftoneForm unhibernate ]) ifTrue: [ ^ self copyBits ].

	"Check for unimplmented rules"
	combinationRule = Form oldPaint ifTrue: [ ^ self paintBits ].
	combinationRule = Form oldErase1bitShape ifTrue: [ ^ self eraseBits ].

	"Check if BitBlt doesn't support full color maps"
	(colorMap notNil and: [ colorMap isColormap ]) ifTrue: 
		[ colorMap := colorMap colors.
		^ self copyBits ].
	"Check if clipping gots us way out of range"
	self clipRange ifTrue: 
		[ self roundVariables.
		^ self copyBitsAgain ].
	self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'.
	"Convert all numeric parameters to integers and try again."
	self roundVariables.
	^ self copyBitsAgain! !

!BitBlt methodsFor: 'accessing' stamp: ''!
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: ''!
clipWidth
	^clipWidth! !

!BitBlt methodsFor: 'private' stamp: ''!
copyBitsAgain
	"Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object
	documentation whatIsAPrimitive."

	<primitive: 'primitiveCopyBits' module: 'BitBltPlugin'>
	self primitiveFailed! !

!BitBlt methodsFor: '*Graphics-Fonts' stamp: ''!
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: 'accessing' stamp: ''!
colorMap: map 
	"See last part of BitBlt comment."
	colorMap := map! !

!BitBlt methodsFor: 'accessing' stamp: ''!
sourceForm: aForm 
	"Set the receiver's source form to be the argument, aForm."
	sourceForm := aForm! !

!BitBlt methodsFor: '*Graphics-Fonts' stamp: ''!
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: 'accessing' stamp: ''!
halftoneForm
	"Returns the receivers half tone form. See class commment."
	
	^halftoneForm! !

!BitBlt methodsFor: 'private' stamp: ''!
primDisplayString: aString from: startIndex to: stopIndex map: glyphMap xTable: xTable kern: kernDelta 
	| ascii |
	<primitive:'primitiveDisplayString' module:'BitBltPlugin'>
	startIndex 
		to: stopIndex
		do: 
			[ :charIndex | 
			ascii := (aString at: charIndex) asciiValue.
			glyphMap ifNotNil: [:map | ascii := map at: ascii +1].
			sourceX := xTable at: ascii + 1.
			width := (xTable at: ascii + 2) - sourceX.
			self copyBits.
			destX := destX + width + kernDelta ]! !

!BitBlt methodsFor: 'accessing' stamp: ''!
tallyMap: aBitmap 
	"Install the map used for tallying pixels"
	colorMap := aBitmap! !

!BitBlt methodsFor: 'copying' stamp: ''!
copy: destRectangle from: sourcePt in: srcForm halftoneForm: hf rule: rule 
	| destOrigin |
	sourceForm := srcForm.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule := rule.
	destOrigin := destRectangle origin.
	destX := destOrigin x.
	destY := destOrigin y.
	sourceX := sourcePt x.
	sourceY := sourcePt y.
	width := destRectangle width.
	height := destRectangle height.
	self copyBits! !

!BitBlt methodsFor: 'accessing' stamp: ''!
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: 'copying' stamp: ''!
copyForm: srcForm to: destPt rule: rule colorMap: map 
	sourceForm := srcForm.
	halftoneForm := nil.
	combinationRule := rule.
	destX := destPt x + sourceForm offset x.
	destY := destPt y + sourceForm offset y.
	sourceX := 0.
	sourceY := 0.
	width := sourceForm width.
	height := sourceForm height.
	colorMap := map.
	self copyBits! !

!BitBlt methodsFor: 'accessing' stamp: ''!
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: 'line drawing' stamp: ''!
drawFrom: startPoint to: stopPoint 
	
	 ^ self drawFrom: startPoint to: stopPoint withFirstPoint: true! !

!BitBlt methodsFor: 'accessing' stamp: ''!
destForm
	^ destForm! !

!BitBlt methodsFor: 'accessing' stamp: ''!
colorMap
	^ colorMap! !

!BitBlt methodsFor: '*FreeType-Graphics' stamp: ''!
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."

	<primitive: 'primitiveCopyBits' module: 'BitBltPlugin'>

	"Check for compressed source, destination or halftone forms"
	((sourceForm isForm) and: [sourceForm unhibernate])
		ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray].
	((destForm isForm) and: [destForm unhibernate ])
		ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray].
	((halftoneForm isForm) and: [halftoneForm unhibernate])
		ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray].

	self primitiveFailed  "Later do nicer error recovery -- share copyBits recovery"! !

!BitBlt methodsFor: 'accessing' stamp: ''!
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' stamp: ''!
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: ''!
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: ''!
sourceY: anInteger 
	"Set the receiver's source form top left y to be the argument, anInteger."
	sourceY := anInteger! !

!BitBlt methodsFor: '*Graphics-Fonts' stamp: ''!
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: '*FreeType-Graphics' stamp: ''!
lastFontForegroundColor
	^ nil! !

!BitBlt methodsFor: '*Graphics-Fonts' stamp: ''!
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: '*FreeType-Graphics' stamp: ''!
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 useSubPixelAntiAliasing 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: 'accessing' stamp: ''!
destRect
	"The rectangle we are about to blit to or just blitted to.  "

	^ destX @ destY extent: width @ height! !

!BitBlt methodsFor: 'copying' stamp: ''!
pixelAt: aPoint put: pixelValue 
	"Assumes this BitBlt has been set up specially (see the init message,
	BitBlt bitPokerToForm:.  Overwrites the pixel at aPoint."
	destX := aPoint x.
	destY := aPoint y.
	sourceForm unhibernate.	"before poking"
	sourceForm bits 
		at: 1
		put: pixelValue.
	self copyBits
	"
| bb |
bb := (BitBlt bitPokerToForm: Display).
[Sensor anyButtonPressed] whileFalse:
	[bb pixelAt: Sensor cursorPoint put: 55]
"! !

!BitBlt methodsFor: 'accessing' stamp: ''!
clipX: anInteger 
	"Set the receiver's clipping area top left x coordinate to be the argument, 
	anInteger."
	clipX := anInteger! !

!BitBlt methodsFor: 'copying' stamp: ''!
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: '*Graphics-Fonts' stamp: ''!
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: ''!
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: ''!
sourceX: anInteger 
	"Set the receiver's source form top left x to be the argument, anInteger."
	sourceX := anInteger! !

!BitBlt methodsFor: 'private' stamp: ''!
paintBits
	"Perform the paint operation, which requires two calls to BitBlt."
	| color oldMap saveRule |
	sourceForm depth = 1 ifFalse: 
		[ ^ self error: 'paint operation is only defined for 1-bit deep sourceForms' ].
	saveRule := combinationRule.
	color := halftoneForm.
	halftoneForm := nil.
	oldMap := colorMap.
	"Map 1's to ALL ones, not just one"
	self colorMap: (Bitmap 
			with: 0
			with: 4294967295).
	combinationRule := Form erase.
	self copyBits.	"Erase the dest wherever the source is 1"
	halftoneForm := color.
	combinationRule := Form under.
	self copyBits.	"then OR, with whatever color, into the hole"
	colorMap := oldMap.
	combinationRule := saveRule

	" | dot |
dot := Form dotOfSize: 32.
((BitBlt destForm: Display
		sourceForm: dot
		fillColor: Color lightGray
		combinationRule: Form paint
		destOrigin: Sensor cursorPoint
		sourceOrigin: 0@0
		extent: dot extent
		clipRect: Display boundingBox)
		colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits"! !

!BitBlt methodsFor: 'private' stamp: ''!
setDestForm: df 
	| bb |
	bb := df boundingBox.
	destForm := df.
	clipX := bb left.
	clipY := bb top.
	clipWidth := bb width.
	clipHeight := bb height! !

!BitBlt methodsFor: 'private' stamp: ''!
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: '*Graphics-Fonts' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
fillColor
	^ halftoneForm! !

!BitBlt methodsFor: 'accessing' stamp: ''!
width: anInteger 
	"Set the receiver's destination form width to be the argument, anInteger."
	width := anInteger! !

!BitBlt methodsFor: 'private' stamp: ''!
getPluginName
	"Private. Return the name of the plugin representing BitBlt.
	Used for dynamically switching between different BB representations only."
	^'BitBltPlugin'! !

!BitBlt methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
clipRect
	"Answer the receiver's clipping area rectangle."

	^clipX @ clipY extent: clipWidth @ clipHeight! !

!BitBlt methodsFor: 'copying' stamp: ''!
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: 'accessing' stamp: ''!
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 ifNil: [ halftoneForm := nil. ^ self ].
	destForm ifNil: [ self error: 'Must set destForm first' ].
	halftoneForm := destForm bitPatternFor: aColorOrPattern! !

!BitBlt methodsFor: 'accessing' stamp: ''!
height: anInteger 
	"Set the receiver's destination form height to be the argument, anInteger."
	height := anInteger! !

!BitBlt methodsFor: 'accessing' stamp: ''!
clipRect: aRectangle 
	"Set the receiver's clipping area rectangle to be the argument, aRectangle."
	clipX := aRectangle left truncated.
	clipY := aRectangle top truncated.
	clipWidth := aRectangle right truncated - clipX.
	clipHeight := aRectangle bottom truncated - clipY! !

!BitBlt methodsFor: 'copying' stamp: ''!
copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule 
	"Specify a Color to fill, not a Form."
	| destOrigin |
	sourceForm := srcForm.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule := rule.
	destOrigin := destRectangle origin.
	destX := destOrigin x.
	destY := destOrigin y.
	sourceX := sourcePt x.
	sourceY := sourcePt y.
	width := destRectangle width.
	height := destRectangle height.
	srcForm == nil ifFalse: [ colorMap := srcForm colormapIfNeededFor: destForm ].
	^ self copyBits! !

!BitBlt methodsFor: 'accessing' stamp: ''!
sourceForm

	^ sourceForm! !

!BitBlt methodsFor: '*FreeType-Graphics' stamp: ''!
combinationRule
	"Answer the receiver's combinationRule"
	
	^combinationRule! !

!BitBlt methodsFor: 'accessing' stamp: ''!
clipY
	^clipY! !

!BitBlt methodsFor: 'copying' stamp: ''!
pixelAt: aPoint 
	"Assumes this BitBlt has been set up specially (see the init message,
	BitBlt bitPeekerFromForm:.  Returns the pixel at aPoint."
	sourceX := aPoint x.
	sourceY := aPoint y.
	destForm unhibernate.	"before poking"
	destForm bits 
		at: 1
		put: 0.	"Just to be sure"
	self copyBits.
	^ destForm bits at: 1! !

!BitBlt methodsFor: 'accessing' stamp: ''!
clipHeight: anInteger 
	"Set the receiver's clipping area height to be the argument, anInteger."
	clipHeight := anInteger! !

!BitBlt methodsFor: 'accessing' stamp: ''!
tallyMap
	"Return the map used for tallying pixels"
	^colorMap! !

!BitBlt class methodsFor: 'instance creation' stamp: ''!
destForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 
	"Answer an instance of me with values set according to the arguments."

	^ self new
		setDestForm: df
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: sourceOrigin
		extent: extent
		clipRect: clipRect! !

!BitBlt class methodsFor: 'class initialization' stamp: ''!
initialize
	self recreateColorMaps! !

!BitBlt class methodsFor: 'private' stamp: ''!
recreateColorMaps
	CachedFontColorMaps := ColorConvertingMaps := nil! !

!BitBlt class methodsFor: 'instance creation' stamp: ''!
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: ''!
destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 
	"Answer an instance of me with values set according to the arguments."

	^ self new
		setDestForm: df
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: sourceOrigin
		extent: extent
		clipRect: clipRect! !

!BitBlt class methodsFor: 'instance creation' stamp: ''!
toForm: aForm
	^ self new setDestForm: aForm! !

!BitBlt class methodsFor: 'cleanup' stamp: ''!
cleanUp
	"Flush caches"

	self recreateColorMaps.! !

!BitBlt class methodsFor: 'instance creation' stamp: ''!
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)! !

!BitBltClipBugsTest commentStamp: ''!
SUnit tests for BitBlt clipping bugs
!
!BitBltClipBugsTest methodsFor: 'tests - filling' stamp: ''!
testFillingWayOutside3
	| f1 bb |
	f1 := Form extent: 100 @ 100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb fillColor: Color black.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb
		width: SmallInteger maxVal squared;
		height: SmallInteger maxVal squared.
	bb copyBits! !

!BitBltClipBugsTest methodsFor: 'tests - drawing' stamp: ''!
testDrawingWayOutside3
	| f1 bb f2 |
	f1 := Form extent: 100 @ 100 depth: 1.
	f2 := Form extent: 100 @ 100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb
		width: SmallInteger maxVal squared;
		height: SmallInteger maxVal squared.
	bb copyBits! !

!BitBltClipBugsTest methodsFor: 'tests - drawing' stamp: ''!
testDrawingWayOutside5
	| f1 bb f2 |
	f1 := Form extent: 100 @ 100 depth: 1.
	f2 := Form extent: 100 @ 100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: 0 @ 0.
	bb
		width: SmallInteger maxVal squared;
		height: SmallInteger maxVal squared.
	bb sourceOrigin: SmallInteger maxVal squared asPoint.
	bb copyBits! !

!BitBltClipBugsTest methodsFor: 'tests - drawing' stamp: ''!
testDrawingWayOutside6
	| f1 bb f2 |
	f1 := Form extent: 100 @ 100 depth: 1.
	f2 := Form extent: 100 @ 100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb
		width: SmallInteger maxVal squared;
		height: SmallInteger maxVal squared.
	bb sourceOrigin: SmallInteger maxVal squared asPoint.
	bb copyBits! !

!BitBltClipBugsTest methodsFor: 'tests - drawing' stamp: ''!
testDrawingWayOutside
	| f1 bb f2 |
	f1 := Form extent: 100 @ 100 depth: 1.
	f2 := Form extent: 100 @ 100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb
		width: 100;
		height: 100.
	bb copyBits! !

!BitBltClipBugsTest methodsFor: 'tests - filling' stamp: ''!
testFillingWayOutside2
	| f1 bb |
	f1 := Form extent: 100 @ 100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb fillColor: Color black.
	bb destOrigin: 0 @ 0.
	bb
		width: SmallInteger maxVal squared;
		height: SmallInteger maxVal squared.
	bb copyBits! !

!BitBltClipBugsTest methodsFor: 'tests - drawing' stamp: ''!
testDrawingWayOutside2
	| f1 bb f2 |
	f1 := Form extent: 100 @ 100 depth: 1.
	f2 := Form extent: 100 @ 100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: 0 @ 0.
	bb
		width: SmallInteger maxVal squared;
		height: SmallInteger maxVal squared.
	bb copyBits! !

!BitBltClipBugsTest methodsFor: 'tests - drawing' stamp: ''!
testDrawingWayOutside4
	| f1 bb f2 |
	f1 := Form extent: 100 @ 100 depth: 1.
	f2 := Form extent: 100 @ 100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb
		width: 100;
		height: 100.
	bb sourceOrigin: SmallInteger maxVal squared asPoint.
	bb copyBits! !

!BitBltClipBugsTest methodsFor: 'tests - filling' stamp: ''!
testFillingWayOutside
	| f1 bb |
	f1 := Form extent: 100 @ 100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb fillColor: Color black.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb
		width: 100;
		height: 100.
	bb copyBits! !

!BitBltDisplayScanner commentStamp: ''!
A BitBltDisplayScanner displays characters on Screen or other Form with help of a BitBlt.

Instance Variables
	bitBlt:		<BitBlt>
	fillBlt:		<BitBlt>

bitBlt
	- the object which knows how to copy bits from one Form (the font glyph data) to another (the destination Form)

fillBlt
	- another object for copying form bits, initialized for displaying the background.

!
!BitBltDisplayScanner methodsFor: 'displaying' stamp: ''!
displayEmbeddedForm: aForm

	aForm 
		displayOn: bitBlt destForm 
		at: destX @ (lineY + line baseline - aForm height)
		clippingBox: bitBlt clipRect
		rule: Form blend
		fillColor: Color white! !

!BitBltDisplayScanner methodsFor: 'displaying' stamp: ''!
displayString: string from: startIndex to: stopIndex at: aPoint
    | endPoint top |
   top := aPoint translateBy: 0@ font ascent.
	endPoint := font displayString: string on: bitBlt 
		from: startIndex 
		to: stopIndex 
		at: aPoint kern: kern.
		
    (emphasisCode allMask: 4)
        ifTrue: [ font displayUnderlineOn: bitBlt from: top to: endPoint ].
    (emphasisCode allMask: 16)
        ifTrue: [ font displayStrikeoutOn: bitBlt from: top to: endPoint ]! !

!BitBltDisplayScanner methodsFor: 'displaying' stamp: ''!
fillTextBackground
	fillBlt ifNotNil:
		["Not right"
		fillBlt destX: line left destY: lineY
			width: line width left height: line lineHeight; copyBits].! !

!BitBltDisplayScanner methodsFor: 'private' stamp: ''!
text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode
	text := t.
	textStyle := ts. 
	foregroundColor := defaultTextColor := foreColor.
	(backgroundColor := backColor) isTransparent ifFalse:
		[fillBlt := blt.
		fillBlt fillColor: backgroundColor].
	ignoreColorChanges := shadowMode! !

!BitBltDisplayScanner methodsFor: 'stop conditions' stamp: ''!
plainTab
	| nextDestX |
 	nextDestX := super plainTab.
	fillBlt ifNotNil:
		[fillBlt destX: destX destY: destY width: nextDestX - destX height: font height; copyBits].
	^nextDestX! !

!BitBltDisplayScanner methodsFor: 'private' stamp: ''!
setFont 
	super setFont.  "Sets font and emphasis bits, and maybe foregroundColor"
	font installOn: bitBlt foregroundColor: foregroundColor backgroundColor: Color transparent! !

!BitBltDisplayScanner methodsFor: 'private' stamp: ''!
setDestForm: df
	bitBlt setDestForm: df.! !

!BitBltDisplayScanner methodsFor: 'private' stamp: ''!
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"
! !

!BitBltTest commentStamp: ''!
SUnit tests for class BitBlt !
!BitBltTest methodsFor: 'tests - bugs' stamp: ''!
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 equals: 1.0 ]! !

!BitBltTest methodsFor: 'tests - bugs' stamp: ''!
testAlphaCompositing2Simulated
	testingEnvironment
		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 equals: mixColor alpha ] ]! !

!BitBltTest methodsFor: 'tests - bugs' stamp: ''!
testPeekerUnhibernateBug

	| bitBlt |
	bitBlt := BitBlt bitPeekerFromForm: Display.
	bitBlt destForm hibernate.
	bitBlt pixelAt: 1 @ 1! !

!BitBltTest methodsFor: 'tests - bugs' stamp: ''!
testAlphaCompositingSimulated
	testingEnvironment
		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 equals: 1.0 ] ]! !

!BitBltTest methodsFor: 'tests - bugs' stamp: ''!
testPokerUnhibernateBug

	| bitBlt |
	bitBlt := BitBlt bitPokerToForm: Display.
	bitBlt sourceForm hibernate.
	bitBlt pixelAt: 1 @ 1 put: 0! !

!BitBltTest methodsFor: 'tests - bugs' stamp: ''!
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 equals: mixColor alpha ]! !

!BitBltTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^BitBlt! !

!Bitmap commentStamp: ''!
My instances provide contiguous storage of bits, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions.!
!Bitmap methodsFor: 'accessing' stamp: ''!
copyFromByteArray: byteArray 
	"This method should work with either byte orderings"

	| myHack byteHack |
	myHack := Form new hackBits: self.
	byteHack := Form new hackBits: byteArray.
	EndianDetector isLittleEndian ifTrue: [byteHack swapEndianness].
	byteHack displayOn: myHack! !

!Bitmap methodsFor: 'converting' stamp: ''!
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.
	EndianDetector 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: 'accessing' stamp: ''!
byteAt: byteAddress 
	"Extract a byte from a Bitmap.  Note that this is a byte address and it is one-order.  For repeated use, create an instance of BitBlt and use pixelAt:.  See Form>>#pixelAt:"
	| lowBits |
	lowBits := byteAddress - 1 bitAnd: 3.
	^ ((self at: (byteAddress - 1 - lowBits) // 4 + 1) bitShift: (lowBits - 3) * 8) bitAnd: 255! !

!Bitmap methodsFor: 'filing' stamp: ''!
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 |
	<primitive: 'primitiveDecompressFromByteArray' module: 'MiscPrimitivePlugin'>
	<var: #bm type: 'int *'>
	<var: #ba type: 'unsigned char *'>
	<var: #anInt type: 'unsigned int'> "Force the type, otherwise it is inferred as unsigned char because assigned from ba"
	<var: #data type: 'unsigned int'>
	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: ''!
writeUncompressedOn: aStream 
	"Store the array of bits onto the argument, aStream.
	(leading byte ~= 16r80) identifies this as raw bits (uncompressed)."

	aStream nextInt32Put: self size.
	aStream nextPutAll: self! !

!Bitmap methodsFor: 'filing' stamp: ''!
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: 'converting' stamp: ''!
restoreEndianness
	"nothing to do here?"! !

!Bitmap methodsFor: 'accessing' stamp: ''!
primFill: aPositiveInteger
	"Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays."

	<primitive: 145>
	self errorImproperStore.! !

!Bitmap methodsFor: 'accessing' stamp: ''!
byteSize
	^self size * 4! !

!Bitmap methodsFor: 'printing' stamp: ''!
printOn: aStream
	self printNameOn: aStream.
	aStream nextPutAll: ' of length '; print: self size! !

!Bitmap methodsFor: 'filing' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
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."
	<primitive: 145>
	super atAllPut: value.! !

!Bitmap methodsFor: 'accessing' stamp: ''!
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: '*ThreadedFFI-Graphics-Extensions' stamp: ''!
tfPointerAddress

	self pinInMemory.
	^ PointerUtils oopForObject: self! !

!Bitmap methodsFor: 'filing' stamp: ''!
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: 'accessing' stamp: ''!
integerAt: index 
	"Return the integer at the given index"
	| word |
	<primitive: 165>
	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: ''!
byteAt: byteAddress put: byte 
	"Insert a byte into a Bitmap.  Note that this is a byte address and it is one-order.  For repeated use, create an instance of BitBlt and use pixelAt:put:.  See Form>>#pixelAt:put:"
	| longWord shift lowBits longAddr |
	(byte < 0 or: [ byte > 255 ]) ifTrue: [ ^ self errorImproperStore ].
	lowBits := byteAddress - 1 bitAnd: 3.
	longWord := self at: (longAddr := (byteAddress - 1 - lowBits) // 4 + 1).
	shift := (3 - lowBits) * 8.
	longWord := longWord - (longWord bitAnd: (255 bitShift: shift)) + (byte bitShift: shift).
	self 
		at: longAddr
		put: longWord.
	^ byte! !

!Bitmap methodsFor: 'filing' stamp: ''!
encodeBytesOf: anInt in: ba at: i
	"Copy the integer anInt into byteArray ba at index i, and return the next index"

	<inline: true>
	<var: #ba declareC: 'unsigned char *ba'>
	
	0 to: 3 do:
		[:j | ba at: i+j put: (anInt >> (3-j*8) bitAnd: 16rFF)].
	^ i+4! !

!Bitmap methodsFor: 'accessing' stamp: ''!
integerAt: index put: anInteger 
	"Store the integer at the given index"
	| word |
	<primitive: 166>
	anInteger < 0 
		ifTrue: 
			[ "word := 16r100000000 + anInteger"
			word := (anInteger + 1) negated bitInvert32 ]
		ifFalse: [ word := anInteger ].
	self 
		basicAt: index
		put: word.
	^ anInteger! !

!Bitmap methodsFor: 'accessing' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !

!Bitmap methodsFor: 'filing' stamp: ''!
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: ''!
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"		

	<inline: true>
	<var: #ba declareC: 'unsigned char *ba'>
	
	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: 'testing' stamp: ''!
isColormap
	"Bitmaps were used as color maps for BitBlt.
	This method allows to recognize real color maps."
	^false! !

!Bitmap methodsFor: 'accessing' stamp: ''!
defaultElement
	"Return the default element of the receiver"
	^0! !

!Bitmap methodsFor: 'filing' stamp: ''!
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 |
	<primitive: 'primitiveCompressToByteArray' module: 'MiscPrimitivePlugin'>
	
	<var: #bm declareC: 'int *bm'>
	<var: #ba declareC: 'unsigned char *ba'>
	
	size := bm size.
	i := self 
		encodeInt: size
		in: ba
		at: 1.
	k := 1.
	[ k <= size ] whileTrue: 
		[ word := bm at: k.
		lowByte := word bitAnd: 255.
		eqBytes := (word >> 8 bitAnd: 255) = lowByte and: 
			[ (word >> 16 bitAnd: 255) = lowByte and: [ (word >> 24 bitAnd: 255) = lowByte ] ].
		j := k.
		[ j < size and: [ word = (bm at: j + 1) ]	"scan for = words..." ] whileTrue: [ j := j + 1 ].
		j > k 
			ifTrue: 
				[ "We have two or more = words, ending at j"
				eqBytes 
					ifTrue: 
						[ "Actually words of = bytes"
						i := self 
							encodeInt: (j - k + 1) * 4 + 1
							in: ba
							at: i.
						ba 
							at: i
							put: lowByte.
						i := i + 1 ]
					ifFalse: 
						[ i := self 
							encodeInt: (j - k + 1) * 4 + 2
							in: ba
							at: i.
						i := self 
							encodeBytesOf: word
							in: ba
							at: i ].
				k := j + 1 ]
			ifFalse: 
				[ "Check for word of 4 = bytes"
				eqBytes 
					ifTrue: 
						[ "Note 1 word of 4 = bytes"
						i := self 
							encodeInt: 1 * 4 + 1
							in: ba
							at: i.
						ba 
							at: i
							put: lowByte.
						i := i + 1.
						k := k + 1 ]
					ifFalse: 
						[ "Finally, check for junk"
						[ j < size and: [ (bm at: j) ~= (bm at: j + 1) ]	"scan for ~= words..." ] whileTrue: [ j := j + 1 ].
						j = size ifTrue: [ j := j + 1 ].
						"We have one or more unmatching words, ending at j-1"
						i := self 
							encodeInt: (j - k) * 4 + 3
							in: ba
							at: i.
						k 
							to: j - 1
							do: 
								[ :m | 
								i := self 
									encodeBytesOf: (bm at: m)
									in: ba
									at: i ].
						k := j ] ] ].
	^ i - 1	"number of bytes actually stored"! !

!Bitmap methodsFor: 'initialize' stamp: ''!
fromByteStream: aStream 
	"Initialize the array of bits by reading integers from the argument, 
	aStream."
	aStream nextWordsInto: self! !

!Bitmap methodsFor: 'accessing' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
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: 'class initialization' stamp: ''!
initialize
	Smalltalk specialObjectsArray 
		at: 5
		put: self! !

!Bitmap class methodsFor: 'utilities' stamp: ''!
swapBytesIn: aNonPointerThing from: start to: stop 
	"Perform a bigEndian/littleEndian byte reversal of my words.
	We only intend this for non-pointer arrays.  Do nothing if I contain pointers."
	"The implementation is a hack, but fast for large ranges"
	| hack blt |
	hack := Form new hackBits: aNonPointerThing.
	blt := (BitBlt toForm: hack) sourceForm: hack.
	blt combinationRule: Form reverse.	"XOR"
	blt
		sourceY: start - 1;
		destY: start - 1;
		height: stop - start + 1;
		width: 1.
	blt
		sourceX: 0;
		destX: 3;
		copyBits.	"Exchange bytes 0 and 3"
	blt
		sourceX: 3;
		destX: 0;
		copyBits.
	blt
		sourceX: 0;
		destX: 3;
		copyBits.
	blt
		sourceX: 1;
		destX: 2;
		copyBits.	"Exchange bytes 1 and 2"
	blt
		sourceX: 2;
		destX: 1;
		copyBits.
	blt
		sourceX: 1;
		destX: 2;
		copyBits! !

!Bitmap class methodsFor: 'instance creation' stamp: ''!
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: 'instance creation' stamp: ''!
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! !

!BitmapFillStyle commentStamp: ''!
A BitmapFillStyle fills using any kind of form.

Instance variables:
	form	<Form>	The form to be used as fill.
	tileFlag	<Boolean>	If true, then the form is repeatedly drawn to fill the area.!
!BitmapFillStyle methodsFor: 'accessing' stamp: ''!
tileFlag
	^tileFlag! !

!BitmapFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
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: '*Athens-Balloon' stamp: ''!
asAthensPaintOn: anAthensCanvas
	| paint |
	paint := (anAthensCanvas surface createFormPaint: form)
		origin: origin;
		direction: self direction; yourself.
	self isTiled
		ifTrue: [ paint repeat ].
	^ paint! !

!BitmapFillStyle methodsFor: 'converting' stamp: ''!
asColor
	^form colorAt: 0@0! !

!BitmapFillStyle methodsFor: 'accessing' stamp: ''!
direction

	^direction ifNil: [direction :=( (normal y @ normal x negated) * form width / form height ) rounded]! !

!BitmapFillStyle methodsFor: 'accessing' stamp: ''!
form
	^form! !

!BitmapFillStyle methodsFor: 'accessing' stamp: ''!
normal
	^normal ifNil: [normal := ((direction y negated @ direction x) *  form height / form width ) rounded]! !

!BitmapFillStyle methodsFor: 'accessing' stamp: ''!
tileFlag: aBoolean
	tileFlag := aBoolean! !

!BitmapFillStyle methodsFor: 'accessing' stamp: ''!
form: aForm
	form := aForm! !

!BitmapFillStyle methodsFor: 'testing' stamp: ''!
isBitmapFill
	^true! !

!BitmapFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
newForm: aForm forMorph: aMorph
	self form: aForm.
	self direction: (aForm width @ 0).
	self normal: (0 @ aForm height).
	aMorph changed.! !

!BitmapFillStyle methodsFor: 'testing' stamp: ''!
isTiled
	"Return true if the receiver should be repeated if the fill shape is larger than the form"
	^tileFlag == true! !

!BitmapFillStyle class methodsFor: 'instance creation' stamp: ''!
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! !

!BitmapFillStyle class methodsFor: 'instance creation' stamp: ''!
form: aForm
	^self new form: aForm! !

!BitmapFillStyle class methodsFor: 'instance creation' stamp: ''!
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! !

!BitsLayout commentStamp: ''!
I am a specialized layout which does not hold slots but only raw data (bytes or words).!
!BitsLayout methodsFor: 'accessing' stamp: ''!
bytesPerSlot

	^ 8! !

!BitsLayout methodsFor: 'extending' stamp: ''!
extendDoubleByte
	IncompatibleLayoutConflict new
		layout: self;
		subType: #doubleByte;
		signal! !

!BitsLayout methodsFor: 'testing' stamp: ''!
isBytes
	^ false! !

!BitsLayout methodsFor: 'extending' stamp: ''!
extend
	"Answer a default extension of me."

	^ self species new! !

!BitsLayout methodsFor: 'testing' stamp: ''!
isWords
	^ false! !

!BitsLayout methodsFor: 'extending' stamp: ''!
extendDoubleWord
	IncompatibleLayoutConflict new
		layout: self;
		subType: #doubleWord;
		signal! !

!BitsLayout methodsFor: 'extending' stamp: ''!
extendWeak: aLayoutClassScope 
	IncompatibleLayoutConflict new
		layout: self;
		subType: #weak;
		signal! !

!BitsLayout methodsFor: 'testing' stamp: ''!
isDoubleWords
	^ false! !

!BitsLayout methodsFor: 'testing' stamp: ''!
isVariable
	^ true! !

!BitsLayout methodsFor: 'testing' stamp: ''!
isDoubleBytes
	^ false! !

!BitsLayout methodsFor: 'extending' stamp: ''!
extendByte
	IncompatibleLayoutConflict new
		layout: self;
		subType: #byte;
		signal! !

!BitsLayout methodsFor: 'extending' stamp: ''!
extendWord
	IncompatibleLayoutConflict new
		layout: self;
		subType: #word;
		signal! !

!BitsLayout methodsFor: 'testing' stamp: ''!
isBits
	^ true! !

!BitsLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == BitsLayout! !

!BlockCannotReturn commentStamp: ''!
This exception is thrown when a block tries to return but there is no home context.!
!BlockCannotReturn methodsFor: 'accessing' stamp: ''!
home
	^ home! !

!BlockCannotReturn methodsFor: 'accessing' stamp: ''!
home: anObject
	home := anObject! !

!BlockCannotReturn class methodsFor: 'signalling' stamp: ''!
result: anObject from: homeContext

	^self new 
		result: anObject;
		home: homeContext;
		signal! !

!BlockClosure commentStamp: ''!
I contain a sequence of operations. I am defined by Smalltalk expressions inside square brackets. I permit to defer the enclosed operations until I execute a variant of #value. I can have my own arguments and temporaries as a regular method, but I am also able to use external variables: my enclosing method or block temporaries, arguments and receiver.

examples :
[ 1 + 2 ] value
[ :arg | 
	| temp | 
	temp := arg. 
	temp ] value: 5
[ ^ 5 ] value

My return value corresponds to my final expression. A non local return (^) has the same effect as if I did not exist: it returns from my enclosing method, even if I'm nested in other blocks. 

Implementation:

Instance variables:
	outerContext <Context|nil> context that defined me
	startpc: <SmallInteger> (pc = program counter) offset of my first bytecode instruction in the compiledMethod bytecode  
	numArgs: <SmallInteger> my number of arguments

I am created at runtime through a special bytecode:
closureNumCopied: x numArgs: y bytes z1 to z2
On creation, the currently executed context is set to my outerContext, z1 is set as my startpc and y is set as my numArgs. After my creation, the current execution flow jumps to my last bytecode, z2, to skip the execution of my bytecode which is deferred until I execute a variant of #value.

I am executed when I receive a variant of the message value. This message creates a new context, a block context <MethodContext>, which reference me in its variable closureOrNil. This new context executes my bytecode, which correspond to a subset of the bytecode of my enclosing method, starting at startpc and ending in blockReturn/return bytecode.

Accessing variables of the my enclosing context is different depending on variables because of various optimizations:
- self: I access the receiver of my enclosing method by accessing my context's receiver, which is always set to the enclosing method receiver.
- copied variables: If I read a variable from an outerContext but I don't write into it and the variable is not modified after the BlockClosure creation, then the variable is copied in the blockClosure to be more efficient. 
- full variable: If I access and edit a variable from an outerContext, then the variable is stored in an external heap allocated array (named tempVector). The tempVector is known by the method and the block so they can both read and write these variables.

Optimized block closures: 
Common blocks (2/3 of the blocks) are optimized directly in the compiler and have special behaviors. These blocks are the arguments/receiver of control structures: #ifNil:, #ifNotNil:, #ifTrue:, #ifFalse:, #whileTrue:, #whileFalse:, #to:do:, #to:by:do: .
!
!BlockClosure methodsFor: '*Slot-Core' stamp: ''!
hasTemporaryVariableNamed: aName
	^self tempNames includes: aName! !

!BlockClosure methodsFor: 'controlling' stamp: ''!
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: '*Metacello-Core' stamp: ''!
setDescriptionInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setDescriptionWithBlock: self! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
receiver
	^outerContext receiver! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
startpc
	^ self compiledBlock initialPC! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
endPC
	^ self compiledBlock endPC! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
cull: firstArg cull: secondArg cull: thirdArg
	^numArgs < 3 
		ifTrue: [self cull: firstArg cull: secondArg]
		ifFalse: [self value: firstArg value: secondArg value: thirdArg]! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
numArgs: n
	numArgs := n! !

!BlockClosure methodsFor: 'controlling' stamp: ''!
whileNotNil: aBlock 
	"Unlike #whileTrue/False: this is not compiled inline."
	^ [self value notNil] whileTrue: [aBlock value]! !

!BlockClosure methodsFor: '*Roassal3-Shapes' stamp: ''!
shapeFor: model
	^ self cull: model! !

!BlockClosure methodsFor: '*SortFunctions-Core-converting' stamp: ''!
descending
	"Opposite direction as ascending."

	^self asSortFunction reversed! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
cull: anArg
	"Execute the receiver with one or zero arguments depending on the receiver"
	"([ 12 ] cull: 13)>>> 12 "
	"([:x | x + 12] cull: 3)>>> 15"
	^numArgs = 0 
		ifTrue: [self value]
		ifFalse: [self value: anArg]! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
home
	^ outerContext ifNotNil: [ outerContext home ]! !

!BlockClosure methodsFor: '*TaskIt' stamp: ''!
future

	^ self asTask future! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
isBlock

	^ true! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
numTemps
	^ self compiledBlock numTemps! !

!BlockClosure methodsFor: 'exceptions' stamp: ''!
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 | 
			  | onDoCtx 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 terminateRealActive ] asContext.
			  onDoCtx privSender: bottom.

			  handler := [ handlerAction cull: ex ] asContext.
			  handler privSender: thisContext sender.

			  (Process forContext: handler priority: Processor activePriority) resume.

			  "cut the stack of current process"
			  thisContext privSender: thisCtx.
			  nil ]! !

!BlockClosure methodsFor: '*Metacello-Core' stamp: ''!
setTimestampInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setTimestampWithBlock: self! !

!BlockClosure methodsFor: '*Reflectivity' stamp: ''!
rfvalue
	"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 copied
	 temps. Primitive. Essential."
	<primitive: 207>
	<metaLinkOptions: #( + optionDisabledLink)>
	| newContext |
	numArgs ~= 0 ifTrue:
		[self numArgsError: 0].
	false
		ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
			[newContext := self asContextWithSender: thisContext sender.
			thisContext privSender: newContext]
		ifFalse: [self primitiveFailed]! !

!BlockClosure methodsFor: 'private' stamp: ''!
asMinimalRepresentation
	"Answer the receiver."

	^self! !

!BlockClosure methodsFor: 'scheduling' stamp: ''!
forkAt: priority 
	"Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process."

	^ self newProcess
		priority: priority;
		resume! !

!BlockClosure methodsFor: '*Text-Core' stamp: ''!
asText

	^ self asString asText! !

!BlockClosure methodsFor: '*Roassal3' stamp: ''!
rsValue: value
	^ self cull: value! !

!BlockClosure methodsFor: 'scheduling' stamp: ''!
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."
	<primitive: 19> "Simulation guard"
	^Process
		forContext: 
			[self valueWithArguments: anArray.
			"IMPORTANT: Do not step over next line of code. See method comments for details"
			Processor terminateRealActive] asContext
		priority: Processor activePriority! !

!BlockClosure methodsFor: '*Fuel-Tests-Core' stamp: ''!
assertWellMaterializedInto: aBlockClosure in: aTestCase

	aTestCase assert: self ~~ aBlockClosure.
	aTestCase assert: self class == aBlockClosure class.
	aTestCase assert: self numArgs = aBlockClosure numArgs.
	aTestCase assert: self startpcOrOuterCode = aBlockClosure startpcOrOuterCode.

	outerContext
		ifNil: [ self assert: aBlockClosure outerContext isNil ]
		ifNotNil: [ 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: '*Kernel-Chronology-Extras' stamp: ''!
bench
	"Return how many times the receiver can get executed in 5 seconds. 
	Answer a string with meaningful description.
	See #benchFor: which returns a BenchmarkResult"
	
	"[3.14 printString] bench"
	
	| benchmarkResult |
	benchmarkResult := self benchFor: 5 seconds.
	^ benchmarkResult shortPrintString! !

!BlockClosure methodsFor: 'testing' stamp: ''!
isFullBlock
	^ true! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
valueSuppressingAllMessages

	^ self valueSuppressingMessages: #('*')! !

!BlockClosure methodsFor: '*Tool-Profilers' stamp: ''!
timeProfile
	^Smalltalk tools timeProfiler onBlock: self! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
compiledBlock: aCompiledMethod
	"To be able to inherit from BlockClosure"
	startpc := aCompiledMethod! !

!BlockClosure methodsFor: 'scheduling' stamp: ''!
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: 'accessing' stamp: ''!
compiledBlock
	"To be able to inherit from BlockClosure"
	^ startpc! !

!BlockClosure methodsFor: 'testing' stamp: ''!
isClosure
	^true! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
valueAfterWaiting: aDelay
	"Waits for a delay, then executes the block. Answers the process so you can terminate it"
	
	^ [ aDelay wait. self value ] 
		forkAt: Processor userBackgroundPriority
		named: (String streamContents: [ :s |
				s 
					<< 'After ';
					print: aDelay;
					<<' do: ';
					print: self ] )! !

!BlockClosure methodsFor: '*Metacello-Core' stamp: ''!
setAuthorInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setAuthorWithBlock: self! !

!BlockClosure methodsFor: '*Collections-Abstract-splitjoin' stamp: ''!
split: aSequenceableCollection indicesDo: aBlock
	"Perform an action specified as aBlock (with a start and end argument) to each of the indices of aSequenceableCollection that have been identified by taking the receiver as a splitter." 
	
	"(String streamContents: [:s | [:c | c isSeparator ] split:  'Pharo is cool'  indicesDo: [ :start :end | s << 's:' << start asString << ' ' << 'e:' << end asString << ' ' ]]) >>>  's:1 e:5 s:7 e:8 s:10 e:13 '"
	
	
	| 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: 'evaluating' stamp: ''!
cull: firstArg cull: secondArg cull: thirdArg cull: fourthArg
	"Execute the receiver with four or less arguments. Check cull:cull: for examples"
	
	^numArgs < 4 
		ifTrue: [self cull: firstArg cull: secondArg cull: thirdArg]
		ifFalse: [self value: firstArg value: secondArg value: thirdArg value: fourthArg]! !

!BlockClosure methodsFor: 'exceptions' stamp: ''!
assert

	self value ifFalse: [AssertionFailure signal: 'Assertion failed']! !

!BlockClosure methodsFor: 'testing' stamp: ''!
hasMethodReturn
	"Answer whether the receiver has a method-return ('^') in its code."
	self withAllBlocksDo: [ :each | each hasMethodReturn ifTrue: [ ^true ] ].
	^false! !

!BlockClosure methodsFor: '*Slot-Core' stamp: ''!
temporaryVariables
	^self sourceNode temporaries collect: [ :each | each binding ] 
! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
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: '*Metacello-Core' stamp: ''!
setPackage: aString withInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setPackage: aString withBlock: self! !

!BlockClosure methodsFor: '*Fuel-Core' stamp: ''!
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-Tests-Core' stamp: ''!
fuelValueWithoutNotifications
	SystemAnnouncer uniqueInstance suspendAllWhile: self! !

!BlockClosure methodsFor: '*SortFunctions-Core-converting' stamp: ''!
asSortFunction
	"Return a SortFunction around the receiver. If the receiver is a 2 arg block, it is assumed it will do the collation directly itself, returning -1, 0, or 1. If the receiver is a one arg block, it will be evaluated for each a and b and of the sort input, and the result of sending <=> to those will be used"
	
	self numArgs = 1 ifTrue: [^PropertySortFunction property: self].
	self numArgs = 2 ifTrue: [^CollatorBlockFunction usingBlock: self].

	self error: 'Can not be converted to sort function. It should have one or two args'	! !

!BlockClosure methodsFor: 'controlling' stamp: ''!
repeat
	"Evaluate the receiver repeatedly, ending only if the block explicitly returns."

	[self value. true] whileTrue! !

!BlockClosure methodsFor: '*NewTools-Spotter' stamp: ''!
stIterator
	
	^ StSpotterBlockIterator new 
		onDo: self;
		yourself! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
valueWithPossibleArgs: anArray 
	"Execute the receiver with the correct number of arguments taken from the argument."
	"([:x | x + 1] valueWithPossibleArgs: #( 13 12 15)) >>> 14
	"
	"([:x :y | x + y] valueWithPossibleArgs: #( 13 12 15)) >>> 25
	"
	"([:x :y :z | x + y + z] valueWithPossibleArgs: #( 13 12 15)) >>> 40
	"
	"([:x :y :z | x + y + z] valueWithPossibleArgs: #( 13 12 15)) >>> 40
	"
	^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: '*Fuel-Core' stamp: ''!
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: '*Deprecated10' stamp: ''!
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 |
	
	self deprecated: 'This should not be used. If you want to execute in a different priority use a different process. Maybe you don''t want to do that neither'.
	
	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: '*SortFunctions-Core-converting' stamp: ''!
ascending
	"Return a SortFunction around the receiver. If the receiver is a 2 arg block, it is assumed it will do the collation directly itself, returning -1, 0, or 1. If the receiver is a one arg block, it will be evaluated for each a and b and of the sort input, and the result of sending <=> to those will be used."

	^self asSortFunction! !

!BlockClosure methodsFor: 'exceptions' stamp: ''!
assertWithDescription: aStringOrABlock
	| value |
	self value
		ifTrue: [ ^ self ].
	value := aStringOrABlock value.
	AssertionFailure signal: value! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
durationToRun
	"Answer the duration taken to execute this block."

	^ self timeToRun! !

!BlockClosure methodsFor: 'debugger access' stamp: ''!
sender
	"Answer the context that sent the message that created the receiver."

	^outerContext sender! !

!BlockClosure methodsFor: 'controlling' stamp: ''!
whileNil: aBlock 
	"Unlike #whileTrue/False: this is not compiled inline."
	^ [self value isNil] whileTrue: [aBlock value]! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
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. Essential."
	<primitive: 207>
	| newContext |
	numArgs ~= 3 ifTrue:
		[self numArgsError: 3].
	false
		ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
			[newContext := self asContextWithSender: thisContext sender.
			newContext at: 1 put: firstArg.
			newContext at: 2 put: secondArg.
			newContext at: 3 put: thirdArg.
			thisContext privSender: newContext]
		ifFalse: [self primitiveFailed]! !

!BlockClosure methodsFor: '*SortFunctions-Core-converting' stamp: ''!
collatedBy: aSortFunction
	"Return a SortFunction around the receiver. If the receiver is a 2 arg block, it is assumed it will do the collation directly itself, returning -1, 0, or 1. If the receiver is a one arg block, it will be evaluated for each a and b and of the sort input, and the result of using aSortFunction on those will be used"
	
	self numArgs = 1 ifTrue: [^PropertySortFunction property: self collatedWith: aSortFunction asSortFunction].
	self error: 'Can not be converted to sort function. It should have one arg'	! !

!BlockClosure methodsFor: 'private' stamp: ''!
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: 'testing' stamp: ''!
isDead
	"Has self finished"
	^false! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
cull: firstArg cull: secondArg
	"Execute the receiver with one or two arguments depending on the receiver"
	"([:x | x + 1] cull: 13 cull: 12) >>> 14
	"
	"([:x :y | x + y] cull: 3 cull: 2) >>> 5
	"
	^numArgs < 2 
		ifTrue: [self cull: firstArg]
		ifFalse: [self value: firstArg value: secondArg]! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
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 copied
	 temps. Primitive. Essential."
	<primitive: 207>
	numArgs ~= 0 ifTrue:
		[self numArgsError: 0].
	^self primitiveFailed! !

!BlockClosure methodsFor: '*Metacello-Core' stamp: ''!
setBlessingInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setBlessingWithBlock: self! !

!BlockClosure methodsFor: 'exceptions' stamp: ''!
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: 'private' stamp: ''!
initialStackPointer

	^ self numTemps! !

!BlockClosure methodsFor: '*Slot-Core' stamp: ''!
temporaryVariableNamed: aName
	(self hasTemporaryVariableNamed: aName) ifFalse: [ ^nil ].
	^self sourceNode scope lookupVar: aName! !

!BlockClosure methodsFor: '*Metacello-Core' stamp: ''!
setConfiguration: aString withInMetacelloConfig: aMetacelloConfig
    aMetacelloConfig setConfiguration: aString withBlock: self! !

!BlockClosure methodsFor: '*Jobs' stamp: ''!
asJob

	^ Job block: self! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
value: firstArg
	"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 argument and copied temps. Primitive. Essential."
	<primitive: 207>
	| newContext |
	numArgs ~= 1 ifTrue:
		[self numArgsError: 1].
	false
		ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
			[newContext := self asContextWithSender: thisContext sender.
			newContext at: 1 put: firstArg.
			thisContext privSender: newContext]
		ifFalse: [self primitiveFailed]! !

!BlockClosure methodsFor: 'private' stamp: ''!
asContextWithSender: aContext
	"Inner private support method for evaluation.  Do not use unless you know what you're doing."

	^(Context newForMethod: self compiledBlock)
		setSender: aContext
		receiver: self receiver
		method: self compiledBlock
		closure: self
		startpc: self startpc;
		privRefresh! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
onErrorDo: 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 or one parameter (the error object)."
	"Examples:
		[1 whatsUpDoc] onErrorDo: [:err | 'huh?'].
		[1 / 0] onErrorDo: [:err |
			ZeroDivide = err class
				ifTrue: [Float infinity]
				ifFalse: [self error: err]]
"

	^ self on: Error do: [:ex | errorHandlerBlock cull: ex]! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
numArgs
	"Answer the number of arguments that must be used to evaluate this block"

	^numArgs! !

!BlockClosure methodsFor: '*Metacello-MC' stamp: ''!
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 | 
			| caption |
			caption := notify messageText withSeparatorsCompacted.	"to remove new lines"
			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 ] ] ] ] ] ]
				ifFound: [ :answer | notify resume: answer second ]
				ifNone: [ | outerAnswer |
					outerAnswer := ProvideAnswerNotification
						signal: notify messageText.
					outerAnswer
						ifNil: [ notify resume ]
						ifNotNil: [ notify resume: outerAnswer ] ] ]! !

!BlockClosure methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^ self shouldBeSubstitutedByCleanCopy
		"The 'onRecursionDo:' is just to avoid an infinitive loop for the substitution. The cleanCopy MUST be a clean copy so it can be serialized normally"
		ifTrue: [ aGeneralMapper visitSubstitution: self by: self cleanCopy onRecursionDo: [ aGeneralMapper visitVariableObject: self ]  ]
		ifFalse: [ aGeneralMapper visitVariableObject: self ]! !

!BlockClosure methodsFor: '*Fuel-Tests-Core' stamp: ''!
isEqualRegardlessTrailerTo: anObject
	^ self = anObject! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
argumentNames
	^ self sourceNode argumentNames! !

!BlockClosure methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
benchFor: duration
	"Run me for duration and return a BenchmarkResult"
	
	"[ 100 factorial ] benchFor: 2 seconds"
	
	| count run started |
	count := 0.
	run := true.
	[ duration wait. run := false ] forkAt: Processor timingPriority - 1.
	started := Time millisecondClockValue.
	[ run ] whileTrue: [ self value. count := count + 1 ].
	^ BenchmarkResult new 
		iterations: count; 
		elapsedTime: (Time millisecondsSince: started) milliSeconds; 
		yourself! !

!BlockClosure methodsFor: 'controlling' stamp: ''!
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: 'scheduling' stamp: ''!
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: '*TaskIt' stamp: ''!
asTask

	^ TKTTask valuable: self! !

!BlockClosure methodsFor: '*Metacello-Core' stamp: ''!
setProject: aString withInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setProject: aString withBlock: self! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
outerContext
	^outerContext! !

!BlockClosure methodsFor: 'testing' stamp: ''!
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].

	^ CleanBlockChecker check: self method! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs

	^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each . true}])! !

!BlockClosure methodsFor: 'exceptions' stamp: ''!
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 |
	<primitive: 198>
	returnValue := self valueNoContextSwitch.
	complete ifNil:[
		complete := true.
		aBlock value.
	].
	^ returnValue! !

!BlockClosure methodsFor: 'scheduling' stamp: ''!
asContext
	"Create a MethodContext that is ready to execute self.  Assumes self takes no args (if it does the args will be nil)"

	^self asContextWithSender: nil! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 62>
	^self basicSize! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
valueSupplyingAnswer: anObject
	^ (anObject isCollection and: [anObject isString not])
		ifTrue: [self valueSupplyingAnswers: {anObject}]
		ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
valueWithInterval: aDelay
	"Executes the block every x milliseconds specified in arguments. Answers the process, so you can terminate it"
	
	^ [ [ self value. aDelay wait. ] repeat ] 
		forkAt: Processor userBackgroundPriority 
		named: (String streamContents: [ :s |
				s 
					<< 'every ';
					print: aDelay;
					<<' do: ';
					print: self ] )! !

!BlockClosure methodsFor: '*Fuel-Core' stamp: ''!
shouldBeSubstitutedByCleanCopy
	^ self isClean ! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
valueWithin: aDuration onTimeout: timeoutBlock
	"Evaluate the receiver.
	If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead"
	<debuggerCompleteToSender>
	| 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: '*Metacello-Core' stamp: ''!
execute: projectSpecBlock against: aScriptExecutor
    aScriptExecutor executeBlock: self do: projectSpecBlock! !

!BlockClosure methodsFor: 'controlling' stamp: ''!
whileFalse
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the receiver, as long as its value is false."
 
	self value ifFalse: [ self whileFalse ]! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
valueWithExit

	^ self value: [ ^ nil ]! !

!BlockClosure methodsFor: 'scheduling' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
timeToRun
	"Answer the number of milliseconds taken to execute this block."

	^ Duration milliSeconds: (Time millisecondsToRun: self)! !

!BlockClosure methodsFor: '*Reflectivity' stamp: ''!
valueSelector
	self numArgs = 0 ifTrue: [^#value].
	^(String streamContents: [:stream | 
		stream nextPutAll: 'value:'.
		(self numArgs - 1) timesRepeat: [stream nextPutAll: 'value:']]) asSymbol.! !

!BlockClosure methodsFor: 'printing' stamp: ''!
doPrintOn: aStream
	aStream nextPutAll: self sourceNode sourceCode! !

!BlockClosure methodsFor: '*TaskIt' stamp: ''!
schedule

	^ self asTask schedule! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
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. Essential."
	<primitive: 208>
	numArgs ~= anArray size ifTrue:
		[self numArgsError: anArray size].

	anArray isArray 
		ifTrue: [self primitiveFailed]
		ifFalse: [
			"Retrying with an array as parameter. As the primitive only supports arrays"
			^ self valueWithArguments: anArray asArray ]! !

!BlockClosure methodsFor: '*System-Announcements' stamp: ''!
valueWithoutNotifications 
	^SystemAnnouncer uniqueInstance suspendAllWhile: self! !

!BlockClosure methodsFor: 'scheduling' stamp: ''!
fork
	"Create and schedule a Process running the code in the receiver."

	^ self newProcess resume! !

!BlockClosure methodsFor: '*Reflectivity' stamp: ''!
rfvalueNoContextSwitch
	"same as valueNoContextSwitch, for recursion stopping metalinks"
	<primitive: 209>
	<metaLinkOptions: #( + optionDisabledLink)>
	numArgs ~= 0 ifTrue:
		[self numArgsError: 0].
	self primitiveFailed! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
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."
	<primitive: 209>
	numArgs ~= 1 ifTrue:
		[self numArgsError: 1].
	self primitiveFailed! !

!BlockClosure methodsFor: 'controlling' stamp: ''!
whileTrue
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the receiver, as long as its value is true."
 
	self value ifTrue: [ self whileTrue ]! !

!BlockClosure methodsFor: 'exceptions' stamp: ''!
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 |
	<primitive: 198>
	result := self valueNoContextSwitch.
	complete := true.
	^result! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
argumentCount
	"Answer the number of arguments that must be used to evaluate this block"

	^numArgs! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
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. Essential."
	<primitive: 207>
	| newContext |
	numArgs ~= 2 ifTrue:
		[self numArgsError: 2].
	false
		ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
			[newContext := self asContextWithSender: thisContext sender.
			newContext at: 1 put: firstArg.
			newContext at: 2 put: secondArg.
			thisContext privSender: newContext]
		ifFalse: [self primitiveFailed]! !

!BlockClosure methodsFor: 'private' stamp: ''!
valueUnpreemptively
	"Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!"
	"Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! 
	After you've done all that thinking, go right ahead and use it..."
	| activeProcess oldPriority result semaphore |
	activeProcess := Processor activeProcess.
	oldPriority := activeProcess priority.
	activeProcess priority: Processor highestPriority.
	result := self ensure: [activeProcess priority: oldPriority].
	
	"Yield after restoring priority to give the preempted processes a chance to run.
	We inline the code of Processor yield here, but without the primitive.
	The reason: the yield primitive does not take into account a change of priority as done above" 
	semaphore := Semaphore new.
	[semaphore signal] fork.
	semaphore wait.
	^result! !

!BlockClosure methodsFor: 'printing' stamp: ''!
printOn: aStream
		
	[self doPrintOn: aStream] 
		onErrorDo: [ aStream 
				nextPutAll: '<Error printing blockClosure in: ';
				print: self method;
				nextPutAll: ' >' ]! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
tempNames
	^ self sourceNode temporaryNames! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
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: '*System-Caching' stamp: ''!
memoizedUsing: cache
	"Provide a memoization block using the given cache. So one can tune by
     passing a LRUCache for instance"
  
    ^[ :x | cache at: x ifAbsentPut: [ self value: x ] ]
! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
copiedValueAt: i
	<primitive: 60>
	^self basicAt: i! !

!BlockClosure methodsFor: '*Reflectivity' stamp: ''!
rfEnsure: aBlock
	"same as #esure, carefully written to never have active meta-links as it is called in the code path that checks for recursion"

	<primitive: 198>
	<metaLinkOptions: #( + optionDisabledLink)>
	| returnValue complete |
	returnValue := self rfvalueNoContextSwitch.
	complete ifNil:[
		complete := true.
		aBlock rfvalue.
	].
	^ returnValue! !

!BlockClosure methodsFor: 'private' stamp: ''!
clearTemporariesOn: aContext
 
	(self numArgs + self numCopiedValues + 1) to: self numTemps do: [ :anIndex |  
		aContext tempAt: anIndex put: nil ]! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
outerContext: ctxt
	outerContext := ctxt! !

!BlockClosure methodsFor: '*System-Caching' stamp: ''!
memoized
	"Returns a memoized version of a one argument block (so values that were
	  already calculated will not be computed a second time but returned from a cache)."
	
	^ self memoizedUsing:  Dictionary new.! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
withAllBlocksDo: aBlock
	self compiledBlock withAllBlocksDo: aBlock! !

!BlockClosure methodsFor: 'private' stamp: ''!
reentrant
	"Answer a version of the recever that can be reentered.
	 Closures are reentrant (unlike BlockContect) so simply answer self."
	^self! !

!BlockClosure methodsFor: 'exceptions' stamp: ''!
on: exception fork: handlerAction return: answerAction
	"This is the same as #on:fork: but instead just fork and letting the flow continues, in 
	 case of an error it also evaluates answerAction and returns its result."
		
	^ self on: exception do: [:ex |
		| onDoCtx 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 terminateRealActive ] 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.
		answerAction cull: exception ]
! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
valueSuppressingMessages: aListOfStrings

	^ self
		valueSuppressingMessages: aListOfStrings
		supplyingAnswers: #()! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
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."
	<primitive: 209>
	numArgs ~= 0 ifTrue:
		[self numArgsError: 0].
	self primitiveFailed! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
method
	^ self compiledBlock! !

!BlockClosure methodsFor: '*NewTools-Spotter' stamp: ''!
stHasDynamicItems

	^ self numArgs ~= 0! !

!BlockClosure methodsFor: 'controlling' stamp: ''!
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: 'exceptions' stamp: ''!
on: exception do: handlerAction
	"Evaluate the receiver in the scope of an exception handler.
	The following primitive is just a marker used to find the error handling context. 
	See MethodContext>>#isHandlerOrSignalingContext. "
	<primitive: 199>  
	^ self value! !

!BlockClosure methodsFor: 'error handling' stamp: ''!
numArgsError: numArgsForInvocation

	ArgumentsCountMismatch signalExpectedArgumentsCount: numArgs calledArgumentsCount: numArgsForInvocation! !

!BlockClosure methodsFor: '*OpalCompiler-Core' stamp: ''!
sourceNode
	^ self compiledBlock sourceNodeInOuter! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
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. Essential."
	<primitive: 207>
	| newContext |
	numArgs ~= 4 ifTrue:
		[self numArgsError: 4].
	false
		ifTrue: "Old code to simulate the closure value primitive on VMs that lack it."
			[newContext := self asContextWithSender: thisContext sender.
			newContext at: 1 put: firstArg.
			newContext at: 2 put: secondArg.
			newContext at: 3 put: thirdArg.
			newContext at: 4 put: fourthArg.
			thisContext privSender: newContext]
		ifFalse: [self primitiveFailed]! !

!BlockClosure methodsFor: 'controlling' stamp: ''!
whileTrue: aBlock 
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the argument, aBlock, as long as the value of the receiver is true."

	self value ifTrue: [ aBlock value. self whileTrue: aBlock ].
	^ nil! !

!BlockClosure methodsFor: 'exceptions' stamp: ''!
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: 'private' stamp: ''!
isValid
	"Answer the receiver."

	^true! !

!BlockClosure methodsFor: 'scheduling' stamp: ''!
newProcess
	"Answer a Process running the code in the receiver. The process is not 
	scheduled.
	IMPORTANT!! Debug stepping this deep infrastructure may lock your Image
  	If you are not sure what you are doing, close the debugger now."
	<primitive: 19> "Simulation guard"
	^Process
		forContext: 
			[self value.
			"IMPORTANT: Do not step over next line of code. See method comments for details"
			Processor terminateRealActive] asContext
		priority: Processor activePriority! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
simulateValueWithArguments: anArray caller: aContext
	"Simulate the valueWithArguments: primitive. Fail if anArray is not an array of the right arity."
	| newContext |
	newContext := (Context newForMethod: self compiledBlock)
						setSender: aContext
						receiver: self receiver
						method: self compiledBlock
						closure: self
						startpc: self compiledBlock initialPC.
	((newContext objectClass: anArray) ~~ Array
	 or: [numArgs ~= anArray size]) ifTrue:
		[^Context primitiveFailTokenFor: nil].
	newContext stackp: self compiledBlock numTemps.
	1 to: numArgs do:
		[:i| newContext at: i put: (anArray at: i)].
	1 to: self basicSize do:
		[:i| newContext at: i + numArgs put: (self at: i)].
	^newContext! !

!BlockClosure methodsFor: 'accessing' stamp: ''!
startpcOrOuterCode
	^ startpc! !

!BlockClosure methodsFor: '*Metacello-Core' stamp: ''!
setBaseline: aString withInMetacelloConfig: aMetacelloConfig
    aMetacelloConfig setBaseline: aString withBlock: self! !

!BlockClosure methodsFor: 'evaluating' stamp: ''!
valueSupplyingAnswers: aListOfPairs
	"evaluate the block using a list of questions / answers that might be called upon to
	automatically respond to Object>>confirm: or FillInTheBlank requests"

	^ self
		on: ProvideAnswerNotification
		do: [ :notify | 
			| caption |
			caption := notify messageText withSeparatorsCompacted.	"to remove new lines"
			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 ] ] ] ] ] ]
				ifFound: [ :answer | notify resume: answer second ]
				ifNone: [ | outerAnswer |
					outerAnswer := ProvideAnswerNotification
						signal: notify messageText.
					outerAnswer
						ifNil: [ notify resume ]
						ifNotNil: [ notify resume: outerAnswer ] ] ]! !

!BlockClosure methodsFor: '*Tool-Profilers' stamp: ''!
timeToRunWithoutGC
	"Answer the number of milliseconds taken to execute this block without GC time."
 
	^ Smalltalk vm totalGCTime + self timeToRun asMilliSeconds -  Smalltalk vm totalGCTime
! !

!BlockClosure methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionSourceCode
	<inspectorPresentationOrder: 30 title: 'Source code'>

	^ self sourceNode inspectionSourceCode! !

!BlockClosure methodsFor: 'controlling' stamp: ''!
whileFalse: aBlock 
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the argument, aBlock, as long as the value of the receiver is false."

	self value ifFalse: [ aBlock value. self whileFalse: aBlock ].
	^ nil! !

!BlockClosure methodsFor: '*ThreadedFFI' stamp: ''!
tfPrintString

	^ self printString! !

!BlockClosureTest commentStamp: ''!
SUnit tests for BlockClosure!
!BlockClosureTest methodsFor: 'tests' stamp: ''!
testOneArgument
	| c |
	c := OrderedCollection new.
	c add: 'hello'.
	[ c do: [ 1 + 2 ] ] onErrorDo: [ :err | self assert: err description equals: 'ArgumentsCountMismatch: This block accepts 0 arguments, but was called with 1 argument.' ].
	[ c do: [ :arg1 :arg2 | 1 + 2 ] ] onErrorDo: [ :err | self assert: err description equals: 'ArgumentsCountMismatch: This block accepts 2 arguments, but was called with 1 argument.' ]! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
testValueWithArguments

	self shouldnt: [ aBlockContext valueWithArguments: #() ] raise: ArgumentsCountMismatch.

	self should: [ aBlockContext valueWithArguments: #(1) ] raise: ArgumentsCountMismatch 
		withExceptionDo: [ :err | 
			self assert: err expectedArgumentsCount equals: 0.
			self assert: err calledArgumentsCount equals: 1 ].
		
	self should: [ [ :i | 3 + 4 ] valueWithArguments: #(1 2) ] raise: ArgumentsCountMismatch 
		withExceptionDo: [ :err | 
			self assert: err expectedArgumentsCount equals: 1.
			self assert: err calledArgumentsCount equals: 2 ].! !

!BlockClosureTest methodsFor: '*System-Caching-Tests' stamp: ''!
testMemoizedDictionary

	| cache factorial result |
	cache := Dictionary new.
	factorial := 0. "avoid not-initialized warning when saving method source"
	factorial := [ :n | 
	             n = 1
		             ifTrue: [ 1 ]
		             ifFalse: [ (factorial value: n - 1) * n ] ] 
		             memoizedUsing: cache.
	result := (1 to: 5) collect: factorial.
	self assert: result equals: #( 1 2 6 24 120 ).
	"Compare sets since order of associations in a dictionary is not guaranteed."
	self assert: cache associations asSet equals: { 
			(1 -> 1).
			(2 -> 2).
			(3 -> 6).
			(4 -> 24).
			(5 -> 120) } asSet! !

!BlockClosureTest methodsFor: '*System-Caching-Tests' stamp: ''!
testMemoizedLRUCache
	| cache factorial result |
	cache := LRUCache new maximumWeight: 3.
	factorial := 0. "avoid not-initialized warning when saving method source"
	factorial := [ :n | n = 1 ifTrue: [1] ifFalse: [(factorial value: n - 1) * n] ] memoizedUsing: cache.
	result := (1 to: 5) collect: factorial.
	self assert: result equals: #(1 2 6 24 120).
	self assert: cache testSupportGetCachedAssociations equals: { 3->6.   4->24.   5->120 }
! !

!BlockClosureTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testRunSimulated
	self assert: (Context runSimulated: aBlockContext) class equals: Rectangle! !

!BlockClosureTest methodsFor: 'tests - on-fork' stamp: ''!
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 - printing' stamp: ''!
testPrintOnBlockDefinedInMethodWithoutSourceCode
	| method copy start block |
	"Generating method with source code"
	UndefinedObject compile: 'method ^ [ 1 + 2 ]'.
	method := UndefinedObject >> #method.
	["Removing the source code of method"
		copy := method copyWithTrailerBytes: CompiledMethodTrailer new.
		start := method endPC + 1.
		method replaceFrom: start to: method size with: copy startingAt: start.
		block := nil method.
		
		self deny: method hasSourceCode.
		self assert: (RBParser parseExpression: block printString) equals: (RBParser parseExpression: '[ 1 + 2 ]').
	] ensure: [ method removeFromSystem ]! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
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 equals: contextOfaBlockContext.
	self assert: aBlockContext receiver equals: self.
	"Depending on the closure implementation, it's either a compiled block, a compiled method or nil."
	self assert: (aBlockContext method isNil or: [ aBlockContext method isKindOf: CompiledCode ])! !

!BlockClosureTest methodsFor: 'helpers' stamp: ''!
blockWithNonLocalReturn: resultObject
		
	^[ ^resultObject ]! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
testValueWithArgumentsWithOrderedCollection

	self 
		shouldnt: [ aBlockContext valueWithArguments: #() asOrderedCollection ] 
		raise: ArgumentsCountMismatch.

	self 
		should: [ aBlockContext valueWithArguments: #(1) asOrderedCollection ] 
		raise: ArgumentsCountMismatch 
		withExceptionDo: [ :err | 
			self assert: err expectedArgumentsCount equals: 0.
			self assert: err calledArgumentsCount equals: 1 ].
		
	self 
		should: [ [ :i | 3 + 4 ] valueWithArguments: #(1 2) asOrderedCollection ] 
		raise: ArgumentsCountMismatch 
		withExceptionDo: [ :err | 
			self assert: err expectedArgumentsCount equals: 1.
			self assert: err calledArgumentsCount equals: 2 ].! !

!BlockClosureTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testBenchFor
	| benchmarkResult duration minimumIterations |
	duration := 500 milliSeconds.
	benchmarkResult := [ 100 factorial ] benchFor: duration.
	self deny: benchmarkResult isEmpty.
	self assert: benchmarkResult elapsedTime >= duration.
	"These should pass even on a very slow machine or simulation"
	minimumIterations := 10.
	self assert: benchmarkResult iterations > minimumIterations.
	self assert: benchmarkResult period < (duration / minimumIterations)! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
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 - on-fork' stamp: ''!
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 equals: 2! !

!BlockClosureTest methodsFor: 'tests - on-fork' stamp: ''!
testOnForkErrorTakesLessThanOneSecond
	"Test that if code runs with error, there is fork"

	| sema timeout |
	self
		flag: 'This test is too brittle, failing often on Windows CI';
		skip.

	self flag: 'The following line makes the test pass under headless linux. Everywhere else this test works'.
	Smalltalk os isUnix ifTrue: [ 1 milliSecond wait ].

	sema := Semaphore new.
	[ 1 / 0 ] on: Exception fork: [ sema signal ].

	timeout := sema waitTimeoutSeconds: 1.
	self assert: timeout identicalTo: false! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
testCullCull
	[  ] cull: 1 cull: 2.
	[ :x |  ] cull: 1 cull: 2.
	[ :x :y |  ] cull: 1 cull: 2.
	self should: [ [ :x :y :z |  ] cull: 1 cull: 2 ] raise: Error.
	self should: [ [ :x :y :z :a |  ] cull: 1 cull: 2 ] raise: Error.
	self should: [ [ :x :y :z :a :b |  ] cull: 1 cull: 2 ] raise: Error.
	self assert: ([ 0 ] cull: 1 cull: 2) equals: 0.
	self assert: ([ :x | x ] cull: 1 cull: 2) equals: 1.
	self assert: ([ :x :y | y ] cull: 1 cull: 2) equals: 2! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
testCull
	[  ] cull: 1.
	[ :x |  ] cull: 1.
	self should: [ [ :x :y |  ] cull: 1 ] raise: Error.
	self should: [ [ :x :y :z |  ] cull: 1 ] raise: Error.
	self should: [ [ :x :y :z :a |  ] cull: 1 ] raise: Error.
	self should: [ [ :x :y :z :a :b |  ] cull: 1 ] raise: Error.
	self assert: ([ 0 ] cull: 1) equals: 0.
	self assert: ([ :x | x ] cull: 1) equals: 1! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testSupplyAnswerOfFillInTheBlank
	self
		assert:
			([ UIManager default request: 'Your favorite color?' ]
				valueSupplyingAnswer: #('Your favorite color?' 'blue'))
		equals: 'blue'! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testSupplyAnswerUsingRegexMatchOfQuestion

	(String includesSelector: #matchesRegex:) ifFalse: [^ self].
	
	self should: [true = ([self confirm: 'You like Smalltalk?'] 
		valueSupplyingAnswer: #('.*Smalltalk\?' true))]! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testSuppressInform

	self should: [[nil inform: 'Should not see this message or this test failed!!'] valueSuppressingAllMessages isNil]! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
testCullCullCullCull
	[  ]
		cull: 1
		cull: 2
		cull: 3
		cull: 4.
	[ :x |  ]
		cull: 1
		cull: 2
		cull: 3
		cull: 4.
	[ :x :y |  ]
		cull: 1
		cull: 2
		cull: 3
		cull: 4.
	[ :x :y :z |  ]
		cull: 1
		cull: 2
		cull: 3
		cull: 4.
	[ :x :y :z :a |  ]
		cull: 1
		cull: 2
		cull: 3
		cull: 4.
	self
		should: [ [ :x :y :z :a :b |  ]
				cull: 1
				cull: 2
				cull: 3
				cull: 4 ]
		raise: Error.
	self
		assert:
			([ 0 ]
				cull: 1
				cull: 2
				cull: 3
				cull: 4)
		equals: 0.
	self
		assert:
			([ :x | x ]
				cull: 1
				cull: 2
				cull: 3
				cull: 4)
		equals: 1.
	self
		assert:
			([ :x :y | y ]
				cull: 1
				cull: 2
				cull: 3
				cull: 4)
		equals: 2.
	self
		assert:
			([ :x :y :z | z ]
				cull: 1
				cull: 2
				cull: 3
				cull: 4)
		equals: 3.
	self
		assert:
			([ :x :y :z :a | a ]
				cull: 1
				cull: 2
				cull: 3
				cull: 4)
		equals: 4! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testSupplySpecificAnswerToQuestion

	self should: [false = ([self confirm: 'You like Smalltalk?'] 
		valueSupplyingAnswer: #('You like Smalltalk?' false))]! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
testValueWithPossibleArgs
	| block blockWithArg blockWith2Arg |
	block := [ 1 ].
	blockWithArg := [ :arg | arg ].
	blockWith2Arg := [ :arg1 :arg2 | {arg1 . arg2} ].
	self assert: (block valueWithPossibleArgs: #()) equals: 1.
	self assert: (block valueWithPossibleArgs: #(1)) equals: 1.
	self assert: (blockWithArg valueWithPossibleArgs: #()) isNil.
	self assert: (blockWithArg valueWithPossibleArgs: #(1)) equals: 1.
	self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) equals: 1.
	self assert: (blockWith2Arg valueWithPossibleArgs: #()) equals: {nil . nil}.
	self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) equals: {1 . nil}.
	self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) equals: #(1 2).
	self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) equals: #(1 2)! !

!BlockClosureTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testTallyInstructions
	self assert: (Context tallyInstructions: aBlockContext ) size equals: 26! !

!BlockClosureTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn
	self assert: (RBParser parseExpression: [ 1 + 2 ] printString) equals: (RBParser parseExpression: '[ 1 + 2 ]')! !

!BlockClosureTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	"we reference self to force a full block"
	aBlockContext := [self . 100@100 corner: 200@200].
	contextOfaBlockContext := thisContext.! !

!BlockClosureTest methodsFor: 'tests - testing' stamp: ''!
testIsClean
	| local |
	local := #testIsClean.
	self assert: [] isClean. "closes over nothing at all"
	self assert: [thisContext] isClean. "we can access the context"
	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: [super testIsClean] isClean. "closes over the receiver"
	self deny: [contextOfaBlockContext] isClean. "closes over the receiver (to access the inst var contextOfaBlockContext)"
	self deny: [local] isClean. "closes over local variable of outer context"! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer
	self
		assert:
			([ UIManager default
				request: 'Your favorite color?'
				initialAnswer: 'red' ]
				valueSupplyingAnswer: #('Your favorite color?' #default))
		equals: 'red'! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
testValueWithExitBreak
	| val |
	[ :break | 
	1 to: 10 do: [ :i | 
		val := i.
		i = 4 ifTrue: [ break value ] ] ] valueWithExit.

	self assert: val equals: 4! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testSupplyAnswerThroughNestedBlocks

	self should: [true = ([[self confirm: 'You like Smalltalk?'] 
		valueSupplyingAnswer: #('Blub' false)] valueSupplyingAnswer: #('Smalltalk' true))]! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
testValueWithExit
	self assert: [:exit | 1 ] valueWithExit equals: 1! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testOnErrorDo

	self assert: ([1 foo ] onErrorDo: [:err | 'huh?']) equals: 'huh?'! !

!BlockClosureTest methodsFor: 'tests - on-fork' stamp: ''!
testOnForkErrorOnSeparateProcess
	"Test that if code runs with error, there is fork"

	| forkedProc sema |
	sema := Semaphore new.
	[ 1 / 0 ] on: Exception fork: [ 
		forkedProc := Processor activeProcess.
		sema signal ].

	sema wait.
	self deny: forkedProc identicalTo: Processor activeProcess! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testNoArguments
	| block1 block2 |
	"avoid compile error in GemStone"
	block1 := [ :arg | 1 + 2 ].
	block2 := [ :arg1 :arg2 | 1 + 2 ].
	[ 10 timesRepeat: block1 ] onErrorDo: [ :err | self assert: err description equals: 'ArgumentsCountMismatch: This block accepts 1 argument, but was called with 0 arguments.' ].
	[ 10 timesRepeat: block2 ] onErrorDo: [ :err | self assert: err description equals: 'ArgumentsCountMismatch: This block accepts 2 arguments, but was called with 0 arguments.' ]! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testSupplyAnswerUsingTraditionalMatchOfQuestion

	self should: [true = ([self confirm: 'You like Smalltalk?'] 
		valueSupplyingAnswer: #('*Smalltalk#' true))]! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
testHasMethodReturn

	self assert: [ ^self  ] hasMethodReturn.
	self deny: [ 1 + 2 ] hasMethodReturn.
	self deny: [ self printString ] hasMethodReturn.
	
	"nested blocks"
	self assert: [ 1 > 2 ifTrue: [ ^self ] ] hasMethodReturn.
	self assert: [ #(1) do: [ ^self ] ] hasMethodReturn! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
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 - evaluating' stamp: ''!
testValueWithPossibleArgument
	| block blockWithArg blockWith2Arg |
	block := [ 1 ].
	blockWithArg := [ :arg | arg ].
	blockWith2Arg := [ :arg1 :arg2 | {arg1 . arg2} ].

	self assert: (block valueWithPossibleArgument: 1) equals: 1.

	self assert: (blockWithArg valueWithPossibleArgument: 1) equals: 1.

	self assert: (blockWith2Arg valueWithPossibleArgument: 1) equals: {1 . nil}! !

!BlockClosureTest methodsFor: 'tests - on-fork' stamp: ''!
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 equals: 1.
	self assert: result2 isNil! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
testCannotReturn

	| block p |
	p := [block := self blockWithNonLocalReturn: #result] fork.
	[p isTerminated] whileFalse: [ 10 milliSeconds wait ].
 
	[ block value.	
	self assert: false description: 'BlockCannotReturn should be signaled' ]
		 on: BlockCannotReturn do: [ :err |
			self assert: err result equals: #result.
			self assert: err home equals: block home]! !

!BlockClosureTest methodsFor: 'tests - on-fork' stamp: ''!
testOnForkSplit
	"Test that when forking, the stack are split correctly (there is no any contexts referenced by both processes)"
	
	| sema timeout forkedContexts myContexts c |
	
	self flag: 'This test is too brittle, failing often on CI'; skip.
		
	sema := Semaphore new.
	
	[ 1/0 ] on: Exception fork: [  | ctx |
		forkedContexts := IdentitySet new.
		ctx := thisContext.
		[ ctx notNil ] whileTrue: [ forkedContexts add: ctx. ctx := ctx sender ].
		sema signal ].
	
	timeout := (sema waitTimeoutSeconds: 1).
	self assert: timeout == false description: 'fork lasted more than one second'.

	myContexts := IdentitySet new.
	c := thisContext.
	[ c notNil ] whileTrue: [ myContexts add: c. c := c sender ].

	self assert: (myContexts noneSatisfy: [:b | forkedContexts includes: b ]) description: 'myContexts are not within forkedContexts'.
	self assert: (forkedContexts noneSatisfy: [:b | myContexts includes: b ]) description: 'forkedContexts are not within myContexts'.! !

!BlockClosureTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testSourceNodeOptimized
	| block |
	block := [ :ctx | [ ctx atEnd ] whileTrue: [ 1 + 2 ] ].
	self assert: block sourceNode printString equals: 'RBBlockNode([ :ctx | [ ctx atEnd ] whileTrue: [ 1 + 2 ] ])'! !

!BlockClosureTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testTallyMethods
	self assert: (Context tallyMethods: aBlockContext) size equals: 7! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
testCullCullCull
	[  ] cull: 1 cull: 2 cull: 3.
	[ :x |  ] cull: 1 cull: 2 cull: 3.
	[ :x :y |  ] cull: 1 cull: 2 cull: 3.
	[ :x :y :z |  ] cull: 1 cull: 2 cull: 3.
	self should: [ [ :x :y :z :a |  ] cull: 1 cull: 2 cull: 3 ] raise: Error.
	self should: [ [ :x :y :z :a :b |  ] cull: 1 cull: 2 cull: 3 ] raise: Error.
	self assert: ([ 0 ] cull: 1 cull: 2 cull: 3) equals: 0.
	self assert: ([ :x | x ] cull: 1 cull: 2 cull: 3) equals: 1.
	self assert: ([ :x :y | y ] cull: 1 cull: 2 cull: 3) equals: 2.
	self assert: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3) equals: 3! !

!BlockClosureTest methodsFor: 'tests - evaluating' stamp: ''!
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 equals: 9.
	self assert: last equals: 10! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testNew
	self	should: [Context new: 5] raise: Error.
	[Context new: 5]
		onErrorDo: [:error | self assert: error description equals: 'Error: Contexts must only be created with newForMethod:'].
	[Context new]
		onErrorDo: [:error | self assert: error description equals: 'Error: Contexts must only be created with newForMethod:'].	
	[Context basicNew]
		onErrorDo: [:error | self assert: error description equals: 'Error: Contexts must only be created with newForMethod:'].! !

!BlockClosureTest methodsFor: 'tests' stamp: ''!
testSupplyAnswerUsingOnlySubstringOfQuestion

	self should: [false = ([self confirm: 'You like Smalltalk?'] 
		valueSupplyingAnswer: #('like' false))]! !

!BlockClosuresTestCase commentStamp: ''!
This test case collects examples for block uses that require full block closures.!
!BlockClosuresTestCase methodsFor: 'examples' stamp: ''!
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: 'tests' stamp: ''!
testSharedClosureEnvironment
	| blockArray |
	blockArray := self constructSharedClosureEnvironmentInDeadFrame.
	self assert: (blockArray at: 2) value equals: 10.
	self assert: ((blockArray at: 1) value: 5) equals: 5.
	self assert: (blockArray at: 2) value equals: 5! !

!BlockClosuresTestCase methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testExample1
	self assert: (self example1: 5) equals: 5 factorial! !

!BlockClosuresTestCase methodsFor: 'tests' stamp: ''!
testReentrantBlockOldEnvironment
	| fib |
	fib := self constructFibonacciBlockInDeadFrame.
	self should: [ fib value: 0 ] raise: self classForTestResult error.
	self assert: (fib value: 1) equals: 1.
	self assert: (fib value: 2) equals: 1.
	self assert: (fib value: 3) equals: 2.
	self assert: (fib value: 4) equals: 3.
	self assert: (fib value: 5) equals: 5.
	self assert: (fib value: 6) equals: 8! !

!BlockClosuresTestCase methodsFor: 'examples' stamp: ''!
constructCannotReturnBlockInDeadFrame

	^ [:arg | ^arg].! !

!BlockClosuresTestCase methodsFor: 'examples' stamp: ''!
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: ''!
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: 'jensen device examples' stamp: ''!
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: 'tests' stamp: ''!
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) equals: 1.
	self assert: (fib value: 2) equals: 1.
	self assert: (fib value: 3) equals: 2.
	self assert: (fib value: 4) equals: 3.
	self assert: (fib value: 5) equals: 5.
	self assert: (fib value: 6) equals: 8! !

!BlockClosuresTestCase methodsFor: 'examples' stamp: ''!
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: ''!
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: 'tests' stamp: ''!
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) equals: result! !

!BlockClosuresTestCase methodsFor: 'examples' stamp: ''!
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. "
	<sampleInstance>

    | 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: 'tests' stamp: ''!
testContinuationExample3
	| array |
	array := (1 to: 20) asOrderedCollection.
	self assert: (self continuationExample3: array) equals: (array collect: [ :x | x * x - 10 ])! !

!BlockClosuresTestCase methodsFor: 'tests' stamp: ''!
testReentrantBlockOldEnvironmentWithBlockArguement
	| fib |
	fib := self constructFibonacciBlockWithBlockArgumentInDeadFrame.
	self should: [ fib value: 0 value: fib ] raise: self classForTestResult error.
	self assert: (fib value: 1 value: fib) equals: 1.
	self assert: (fib value: 2 value: fib) equals: 1.
	self assert: (fib value: 3 value: fib) equals: 2.
	self assert: (fib value: 4 value: fib) equals: 3.
	self assert: (fib value: 5 value: fib) equals: 5.
	self assert: (fib value: 6 value: fib) equals: 8! !

!BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: ''!
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: 'tests' stamp: ''!
testGpsExample1
	| result array |
	array := (1 to: 100) asArray.
	result := array inject: 0 into: [ :sum :val | sum + val ].
	self assert: (self gpsExample1: array) equals: result! !

!BlockClosuresTestCase methodsFor: 'tests' stamp: ''!
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) equals: result! !

!BlockClosuresTestCase methodsFor: 'tests' stamp: ''!
testExample2
	self assert: (self example2: 5) equals: (1 to: 5) asOrderedCollection! !

!BlockClosuresTestCase methodsFor: 'examples' stamp: ''!
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: 'tests' stamp: ''!
testContinuationExample1
	| array |
	array := (1 to: 20) asOrderedCollection.
	self assert: (self continuationExample1: array) equals: array! !

!BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: ''!
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: 'tests' stamp: ''!
testCannotReturn

	| blk |
	blk := self constructCannotReturnBlockInDeadFrame.
	self 
		should: [blk value: 1]
		raise: Exception! !

!BlockClosuresTestCase methodsFor: 'tests' stamp: ''!
testContinuationExample2
	| array |
	array := (1 to: 20) asOrderedCollection.
	self assert: (self continuationExample2: array) equals: (array collect: [ :x | x * x ])! !

!BlockClosuresTestCase methodsFor: 'examples' stamp: ''!
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: ''!
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.) "
	<sampleInstance>

    | factorial |

   factorial := [:x | x = 1 ifTrue: [1]
                            ifFalse: [(factorial value: x - 1)* x]].
  ^ factorial value: anInteger! !

!BlockLocalTempCounter commentStamp: ''!
I am a support class for the decompiler that is used to find the number of local temps in a block by finding out what the stack offset is at the end of a block.!
!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
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: ''!
popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
	"Remove Top Of Stack And Store Into Offset of Temp Vector bytecode."
	stackPointer := stackPointer - 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
pushConstant: value
	"Push Constant, value, on Top Of Stack bytecode."
	stackPointer := stackPointer + 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
popIntoLiteralVariable: anAssociation 
	"Remove Top Of Stack And Store Into Literal Variable bytecode."
	stackPointer := stackPointer - 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
send: selector super: supered numArgs: numberArguments
	"Send Message With Selector, selector, bytecode. The argument, 
	supered, indicates whether the receiver of the message is specified with 
	'super' in the source method. The arguments of the message are found in 
	the top numArguments locations on the stack and the receiver just 
	below them."

	stackPointer := stackPointer - numberArguments! !

!BlockLocalTempCounter methodsFor: 'private' stamp: ''!
doJoin
	scanner pc < blockEnd ifTrue:
		[stackPointer := joinOffsets at: scanner pc]! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
pushReceiver
	"Push Active Context's Receiver on Top Of Stack bytecode."
	stackPointer := stackPointer + 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
doPop
	"Remove Top Of Stack bytecode."
	stackPointer := stackPointer - 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
pushNewArrayOfSize: numElements 
	"Push New Array of size numElements bytecode."
	stackPointer := stackPointer + 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
methodReturnConstant: value 
	"Return Constant bytecode."
	self doJoin! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
pushLiteralVariable: anAssociation
	"Push Contents Of anAssociation On Top Of Stack bytecode."
	stackPointer := stackPointer + 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
blockReturnConstant: cst
	"Return Top Of Stack bytecode."
	scanner pc < blockEnd ifTrue:
		[self doJoin]! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
methodReturnTop
	"Return Top Of Stack bytecode."
	stackPointer := stackPointer - 1.
	self doJoin! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
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: ''!
doDup
	"Duplicate Top Of Stack bytecode."
	stackPointer := stackPointer + 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
directedSuperSend: selector numArgs: numArgs
	"Send Message Above Specific Class With Selector, selector, bytecode.
	 Start the lookup above the class that is the value of the association on
	 top of stack. The arguments  of the message are found in the top numArgs
	 stack locations beneath the association, and the receiver just below them."

	stackPointer := stackPointer - (numArgs + 1)! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
pushActiveContext
	"Push Active Context On Top Of Its Own Stack bytecode."
	stackPointer := stackPointer + 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
methodReturnReceiver
	"Return Self bytecode."
	self doJoin! !

!BlockLocalTempCounter methodsFor: 'initialization' stamp: ''!
tempCountForBlockAt: pc in: method
	"Compute the number of local temporaries in a block.
	 If the block begins with a sequence of push: nil bytecodes then some of
	 These could be initializing local temps.  We can only reliably disambuguate
	 them from other uses of nil by parsing the stack and seeing what the offset
	 of the stack pointer is at the end of the block.

	 There are short-cuts.  The ones we take here are
		- if there is no sequence of push nils there can be no local temps
		- we follow forward jumps to shorten the amount of scanning"
	stackPointer := 0.
	scanner := InstructionStream new method: method pc: pc.
	scanner interpretNextInstructionFor: self.
	blockEnd ifNil:
		[self error: 'pc is not that of a block'].
	scanner peekByte = method encoderClass pushNilByte ifTrue: [
		joinOffsets := Dictionary new.
		[scanner pc < blockEnd] whileTrue: [
			scanner interpretNextInstructionFor: self ] ].
	^stackPointer! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
popIntoReceiverVariable: offset 
	"Remove Top Of Stack And Store Into Instance Variable bytecode."
	stackPointer := stackPointer - 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
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: ''!
popIntoTemporaryVariable: offset 
	"Remove Top Of Stack And Store Into Temporary Variable bytecode."
	stackPointer := stackPointer - 1! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
blockReturnTop
	"Return Top Of Stack bytecode."
	stackPointer := stackPointer - 1.
	scanner pc < blockEnd ifTrue:
		[self doJoin]! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
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: ''!
jump: offset
	"Unconditional Jump bytecode."
	offset > 0 ifTrue:
		[joinOffsets at: scanner pc + offset put: stackPointer.
		 self doJoin]! !

!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: ''!
pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
	"Push Contents at Offset in Temp Vector bytecode."
	stackPointer := stackPointer + 1! !

!BlockLocalTempCounter class methodsFor: 'instance creation' stamp: ''!
tempCountForBlockAt: pc in: method
	^self new tempCountForBlockAt: pc in: method! !

!Boolean commentStamp: ''!
Boolean is an abstract class defining the protocol for logic testing operations and conditional control structures for the logical values represented by the instances of its subclasses True and False.

Boolean redefines #new so no instances of Boolean can be created. It also redefines several messages in the 'copying' protocol to ensure that only one instance of each of its subclasses True (the global true, logical assertion) and False (the global false, logical negation) ever exist in the system.!
!Boolean methodsFor: 'copying' stamp: ''!
shallowCopy 
	"Receiver has two concrete subclasses, True and False.
	Only one instance of each should be made, so return self."! !

!Boolean methodsFor: 'logical operations' stamp: ''!
| aBoolean 
	"Evaluating disjunction (OR). Evaluate the argument. Then answer true 
	if either the receiver or the argument is true."
	
	"true | true >>> true"
	"true | false >>> true"
	"false | true >>> true"
	"false | false >>> false"

	self subclassResponsibility! !

!Boolean methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitHookPrimitive: self! !

!Boolean methodsFor: '*SortFunctions-Core' stamp: ''!
threeWayCompareTo: anotherObject
	^ self asBit threeWayCompareTo: anotherObject asBit! !

!Boolean methodsFor: 'controlling' stamp: ''!
ifTrue: alternativeBlock 
	"If the receiver is false (i.e., the condition is false), then the value is the 
	false alternative, which is nil. Otherwise answer the result of evaluating 
	the argument, alternativeBlock. Create an error notification if the 
	receiver is nonBoolean. Execution does not actually reach here because 
	the expression is compiled in-line."
	
	"(true ifTrue: [ 'This statement is true!!' ]) >>> 'This statement is true!!'" 
	"(false ifTrue: [ 'This statement is true!!' ]) >>> nil"

	self subclassResponsibility! !

!Boolean methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating
	^ true! !

!Boolean methodsFor: 'controlling' stamp: ''!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock
	"If the receiver is true (i.e., the condition is true), then answer the value 
	of the argument trueAlternativeBlock. If the receiver is false, answer the 
	result of evaluating the argument falseAlternativeBlock. If the receiver 
	is a nonBoolean then create an error notification. Execution does not 
	actually reach here because the expression is compiled in-line."
	
	"(true ifTrue: [ 'That is true!!' ] ifFalse: [ 'That is false!!' ]) >>> 'That is true!!'"
	"(false ifTrue: [ 'That is true!!' ] ifFalse: [ 'That is false!!' ])  >>> 'That is false!!'"

	self subclassResponsibility! !

!Boolean methodsFor: 'logical operations' stamp: ''!
not
	"Negation. Answer true if the receiver is false, answer false if the 
	receiver is true."
	"true not >>> false"
	"false not >>> true"

	self subclassResponsibility! !

!Boolean methodsFor: 'converting' stamp: ''!
asBit
	"convert myself to an Integer representing 1 for true and 0 for false"
	
	"($b > $c) asBit>>> 0"
	"true asBit >>> 1" 
	"(#(true true false true) inject: 0 into: [ :sum :each | sum + each asBit]) >>> 3"
	
	self subclassResponsibility! !

!Boolean methodsFor: 'controlling' stamp: ''!
or: alternativeBlock 
	"Nonevaluating disjunction. If the receiver is false, answer the value of 
	the argument, alternativeBlock; otherwise answer true without 
	evaluating the argument."
	
	"(true or: [Error signal]) >>> true"
	"(true or: [false]) >>> true"
	"(false or: [true]) >>> true"
	"(false or: [3]) >>> 3"

	self subclassResponsibility! !

!Boolean methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter writeBoolean: self! !

!Boolean methodsFor: '*Fuel-Core' stamp: ''!
serializeOn: anEncoder
	"Do nothing"! !

!Boolean methodsFor: 'controlling' stamp: ''!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 
	"Same as ifTrue:ifFalse:."
	
	"(true ifFalse: [ 'That is false!!' ] ifTrue: [ 'That is true!!' ])  >>> 'That is true!!'"
	"(false ifFalse: [ 'That is false!!' ] ifTrue: [ 'That is true!!' ])  >>> 'That is false!!'"

	self subclassResponsibility! !

!Boolean methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects 
	^ false! !

!Boolean methodsFor: 'logical operations' stamp: ''!
==> 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
	"
	"true ==> [true] >>> true"
	"true ==> [false] >>> false"
	"false ==> [true] >>> true"
	"false ==> [false] >>> true"

	^ self not or: [ aBlock value ]! !

!Boolean methodsFor: 'printing' stamp: ''!
isLiteral 
	^ true! !

!Boolean methodsFor: '*UnifiedFFI' stamp: ''!
asExternalTypeOn: generator 
	^ FFIConst value: self asBit! !

!Boolean methodsFor: 'logical operations' stamp: ''!
& aBoolean 
	"Evaluating conjunction. Evaluate the argument. Then answer true if 
	both the receiver and the argument are true."	
	"true & true >>> true"
	"true & false >>> false"
	"false & true >>> false"
	"false & false >>> false"

	self subclassResponsibility! !

!Boolean methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !

!Boolean methodsFor: 'controlling' stamp: ''!
and: alternativeBlock 
	"Nonevaluating conjunction. If the receiver is true, answer the value of 
	the argument, alternativeBlock; otherwise answer false without 
	evaluating the argument."
	
	"(true and: [true]) >>> true"
	"(true and: [false]) >>> false"
	"(false and: [true]) >>> false"
	"(false and: [Error signal]) >>> false"

	self subclassResponsibility! !

!Boolean methodsFor: 'copying' stamp: ''!
deepCopy 
	"Receiver has two concrete subclasses, True and False.
	Only one instance of each should be made, so return self."! !

!Boolean methodsFor: 'controlling' stamp: ''!
xor: alternativeBlock 
	"Nonevaluating conjunction. If the receiver is true, answer the opposite of the 
	the argument, alternativeBlock; otherwise answer the value of the alternativeBlock."
	
	"(true xor: [true]) >>> false"
	"(true xor: [false]) >>> true"
	"(false xor: [true]) >>> true"
	"(false xor: [false]) >>> false"

	self subclassResponsibility! !

!Boolean methodsFor: '*Reflectivity' stamp: ''!
valueSelector
	^#value! !

!Boolean methodsFor: 'controlling' stamp: ''!
ifFalse: alternativeBlock 
	"If the receiver is true (i.e., the condition is true), then the value is the 
	true alternative, which is nil. Otherwise answer the result of evaluating 
	the argument, alternativeBlock. Create an error notification if the 
	receiver is nonBoolean. Execution does not actually reach here because 
	the expression is compiled in-line."
	
	"(false ifFalse: [ 'This statement is false!!' ]) >>> 'This statement is false!!'" 
	"(true ifFalse: [ 'This statement is false!!' ]) >>> nil"

	self subclassResponsibility! !

!Boolean methodsFor: 'logical operations' stamp: ''!
eqv: aBoolean
	"Answer true if the receiver is equivalent to aBoolean."

	"(false eqv: true) >>> false"
	"((1 == 1) eqv: true) >>> true"
	"(( 1 > 2)  eqv: false) >>> true"

	^ self == aBoolean! !

!Boolean methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	self printOn: aStream! !

!Boolean class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'You may not create any more Booleans - this is two-valued logic'! !

!Boolean class methodsFor: '*UnifiedFFI' stamp: ''!
asExternalTypeOn: generator 
	^ FFIBool asExternalTypeOn: generator! !

!Boolean class methodsFor: '*Debugger-Model' stamp: ''!
canonicalArgumentName
	^ 'aBoolean'! !

!Boolean class methodsFor: '*Tool-Finder' stamp: ''!
approvedSelectorsForMethodFinder
	^ self selectors! !

!Boolean class methodsFor: '*System-Settings-Browser' stamp: ''!
settingInputWidgetForNode: aSettingNode
	^ aSettingNode inputWidgetForBoolean! !

!BooleanSlot commentStamp: ''!
I am a Slot that does not allocate one field for each slot. Instead, all BooleanSlots of the whole hierarchy are allocated in an integer that is stored in an invisible slot.

!
!BooleanSlot methodsFor: 'accessing' stamp: ''!
baseSlotRead: anObject
	^ (baseSlot read: anObject) ifNil: [ 0 ].
	! !

!BooleanSlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	^((self baseSlotRead: anObject) bitAt: offset) == 1! !

!BooleanSlot methodsFor: 'class building' stamp: ''!
installingIn: aClass
	| booleanSlots |
	super installingIn: aClass.
	
	"we reuse a baseSlot if it is already there, if not, we add it"
	"TODO: this does not take into account adding BooleanSlots higher up in the Hierarchy"
	aClass classLayout 
		resolveSlot: #'_booleanBaseSlot'   
		ifFound:  [: slot |  baseSlot := slot ]
		ifNone: [aClass addSlot: (baseSlot := #'_booleanBaseSlot' => BaseSlot default: 0)].
	
	"my offset in the base slot is defined by the order of all BooleanSlots in the Hierarchy"
	booleanSlots := aClass allSlots select: [ :each | each isKindOf: self class ].	
	offset := booleanSlots indexOf: self

	

	! !

!BooleanSlot methodsFor: 'accessing' stamp: ''!
offset
	^offset! !

!BooleanSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
		| newInteger |
		newInteger := (self baseSlotRead: anObject) bitAt: offset put: aValue asBit.
		baseSlot write: newInteger to: anObject.
		^aValue! !

!BooleanSlot methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder
	"generate bytecode for '(<baseSlot> bitAt: offset) == 1'"
	methodBuilder
		pushInstVar: baseSlot index;
		pushLiteral: offset;
		send: #bitAt:;
		pushLiteral: 1;
		send: #==
	
	! !

!BooleanSlot methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder
	"generate bytecode for 'baseSlot bitAt: index put: <stackTop>'"
	| tempName |
	tempName := '0slotTempForStackManipulation'.
	methodBuilder
		send: #asBit;
		addTemp: tempName;
		storeTemp: tempName;
		popTop;
		pushInstVar: baseSlot index;
		pushLiteral: offset;
		pushTemp: tempName;
		send: #bitAt:put:;
		storeInstVar: baseSlot index
	! !

!BooleanSlotTest commentStamp: ''!
Tests for BooleanSlot!
!BooleanSlotTest methodsFor: 'tests' stamp: ''!
testExampleTwoBooleanSlotsRemoveOne
	| object slot1 slot2 |
	slot1 := #slot1 => BooleanSlot.
	slot2 := #slot2 => BooleanSlot.

	aClass := self make: [ :builder | builder slots: {slot1 . slot2} ].

	self assert: (slot1 instVarNamed: 'baseSlot') isNotNil.
	self assert: (slot1 instVarNamed: 'baseSlot') identicalTo: (slot2 instVarNamed: 'baseSlot').

	object := aClass new.
	"test reflective write and read"
	slot1 write: true to: object.
	self assert: (slot1 read: object).

	slot2 write: true to: object.
	self assert: (slot2 read: object).

	slot2 write: true to: object.
	slot1 write: false to: object.
	self assert: (slot2 read: object).
	slot2 write: false to: object.
	self deny: (slot2 read: object).

	aClass removeSlot: slot1! !

!BooleanSlotTest methodsFor: 'tests' stamp: ''!
testExampleBooleanSlot
	| object slot |
	slot := #slot1 => BooleanSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	self assert: (slot instVarNamed: 'baseSlot') isNotNil.

	object := aClass new.
	"test reflective write and read"
	slot write: true to: object.
	self assert: (slot read: object).

	"compiled accessors to test code gen"
	self compileAccessorsFor: slot.

	self assert: object slot1 identicalTo: true.
	object slot1: false.
	self assert: object slot1 identicalTo: false! !

!BooleanSlotTest methodsFor: 'tests' stamp: ''!
testExampleTwoBooleanSlots
	| object slot1 slot2 |
	slot1 := #slot1 => BooleanSlot.
	slot2 := #slot2 => BooleanSlot.

	aClass := self make: [ :builder | builder slots: {slot1 . slot2} ].

	self assert: (slot1 instVarNamed: 'baseSlot') isNotNil.
	self assert: (slot1 instVarNamed: 'baseSlot') identicalTo: (slot2 instVarNamed: 'baseSlot').

	object := aClass new.
	"test reflective write and read"
	slot1 write: true to: object.
	self assert: (slot1 read: object) equals: true.

	slot2 write: true to: object.
	self assert: (slot2 read: object) equals: true.

	slot2 write: true to: object.
	slot1 write: false to: object.
	self assert: (slot2 read: object) equals: true.
	slot2 write: false to: object.
	self assert: (slot2 read: object) equals: false! !

!BooleanTest commentStamp: ''!
This is the unit test for the class Boolean. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- there is a chapter in the PharoByExample book (http://pharobyexample.org/)
	- the sunit class category
!
!BooleanTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Boolean! !

!BooleanTest methodsFor: 'tests - instance creation' stamp: ''!
testNew

	self should: [Boolean new] raise: self defaultTestError! !

!BorderStyle commentStamp: ''!
See BorderedMorph

BorderedMorh new borderStyle: (BorderStyle inset width: 2); openInWorld.!
!BorderStyle methodsFor: 'accessing' stamp: ''!
color: aColor
	"Ignored"! !

!BorderStyle methodsFor: 'drawing' stamp: ''!
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: 'comparing' stamp: ''!
= aBorderStyle
	^self species = aBorderStyle species
		and:[self style == aBorderStyle style
		and:[self width = aBorderStyle width
		and:[self color = aBorderStyle color]]].! !

!BorderStyle methodsFor: 'comparing' stamp: ''!
hash
	"hash is implemented because #= is implemented"
	^self species hash bitXor: (self width hash bitXor: self color hash)! !

!BorderStyle methodsFor: 'drawing' stamp: ''!
drawLineFrom: startPoint to: stopPoint on: aCanvas
	^aCanvas line: startPoint to: stopPoint width: self width color: self color! !

!BorderStyle methodsFor: 'accessing' stamp: ''!
baseColor
	^Color transparent! !

!BorderStyle methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Print a description of the
	receiver on the given stream."

	self storeOn: aStream! !

!BorderStyle methodsFor: 'color tracking' stamp: ''!
trackColorFrom: aMorph
	"If necessary, update our color to reflect a change in aMorphs color"! !

!BorderStyle methodsFor: 'accessing' stamp: ''!
widthForRounding
	^self width! !

!BorderStyle methodsFor: 'testing' stamp: ''!
isComplex
	^false! !

!BorderStyle methodsFor: 'testing' stamp: ''!
isComposite
	"Answer false."

	^false! !

!BorderStyle methodsFor: 'accessing' stamp: ''!
colorsAtCorners
	^Array new: 4 withAll: self color! !

!BorderStyle methodsFor: 'initialize' stamp: ''!
releaseCachedState
	"Release any associated cached state"! !

!BorderStyle methodsFor: 'drawing' stamp: ''!
framePolyline: vertices on: aCanvas 
	"Frame the given rectangle on aCanvas"

	| prev next |
	prev := vertices first.
	2 to: vertices size
		do: 
			[:i | 
			next := vertices at: i.
			self 
				drawLineFrom: prev
				to: next
				on: aCanvas.
			prev := next]! !

!BorderStyle methodsFor: 'testing' stamp: ''!
hasFillStyle
	"Answer false."

	^false! !

!BorderStyle methodsFor: 'accessing' stamp: ''!
width: aNumber
	"Ignored"! !

!BorderStyle methodsFor: 'accessing' stamp: ''!
width
	^0! !

!BorderStyle methodsFor: 'accessing' stamp: ''!
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: ''!
style
	^#none! !

!BorderStyle methodsFor: '*Athens-Morphic' stamp: ''!
asAthensPaintOn: anAthensCanvas
	| stroke |
	stroke := self color asStrokePaintOn: anAthensCanvas.
	stroke width: self width.
	stroke joinMiter.
	^ stroke! !

!BorderStyle methodsFor: 'accessing' stamp: ''!
baseColor: aColor
	"Ignored"! !

!BorderStyle methodsFor: 'testing' stamp: ''!
isBorderStyle
	^true! !

!BorderStyle methodsFor: 'drawing' stamp: ''!
frameOval: aRectangle on: aCanvas
	"Frame the given rectangle on aCanvas"
	aCanvas frameOval: aRectangle width: self width color: self color! !

!BorderStyle methodsFor: 'printing' stamp: ''!
storeOn: aStream
	"Store a reconstructable representation of the
	receiver on the given stream."

	aStream
		nextPutAll: '(';
		nextPutAll: self class name;
		nextPutAll: ' width: ';
		print: self width;
		nextPutAll: ' color: ';
		print: self color;
		nextPutAll: ')'! !

!BorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle: aRectangle on: aCanvas
	"Frame the given rectangle on aCanvas"
	aCanvas frameRectangle: aRectangle width: self width color: self color! !

!BorderStyle methodsFor: 'accessing' stamp: ''!
color
	^Color transparent! !

!BorderStyle class methodsFor: 'instance creation' stamp: ''!
width: aNumber
	^self width: aNumber color: Smalltalk ui theme borderColor! !

!BorderStyle class methodsFor: '*Polymorph-Widgets' stamp: ''!
dashed
	"Answer a dashed border style"

	^DashedBorderStyle new! !

!BorderStyle class methodsFor: 'instance creation' stamp: ''!
color: aColor width: aNumber
	^self width: aNumber color: aColor! !

!BorderStyle class methodsFor: '*Morphic-Base' stamp: ''!
simple
	"Answer a simple border style"

	^ SimpleBorderStyle new! !

!BorderStyle class methodsFor: 'instance creation' stamp: ''!
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: '*Morphic-Base' stamp: ''!
complexAltFramed
	^ComplexBorderStyle style: #complexAltFramed! !

!BorderStyle class methodsFor: 'instance creation' stamp: ''!
borderStyleChoices
	"Answer the superset of all supported borderStyle symbols"

	^ #(simple inset raised complexAltFramed complexAltInset complexAltRaised complexFramed complexInset complexRaised)! !

!BorderStyle class methodsFor: '*Morphic-Base' stamp: ''!
complexAltRaised
	^ComplexBorderStyle style: #complexAltRaised! !

!BorderStyle class methodsFor: '*Morphic-Base' stamp: ''!
raised
	^RaisedBorderStyle new! !

!BorderStyle class methodsFor: '*Morphic-Base' stamp: ''!
complexRaised
	^ComplexBorderStyle style: #complexRaised! !

!BorderStyle class methodsFor: '*Morphic-Base' stamp: ''!
complexAltInset
	^ComplexBorderStyle style: #complexAltInset! !

!BorderStyle class methodsFor: 'instance creation' stamp: ''!
default
	^Default ifNil:[Default := self new]! !

!BorderStyle class methodsFor: '*Morphic-Base' stamp: ''!
inset
	^InsetBorderStyle new! !

!BorderStyle class methodsFor: '*Morphic-Base' stamp: ''!
complexFramed
	^ComplexBorderStyle style: #complexFramed! !

!BorderStyle class methodsFor: '*Morphic-Base' stamp: ''!
width: aNumber color: aColor
	^SimpleBorderStyle new color: aColor; width: aNumber; yourself! !

!BorderStyle class methodsFor: '*Morphic-Base' stamp: ''!
complexInset
	^ComplexBorderStyle style: #complexInset! !

!BorderStyle class methodsFor: 'instance creation' stamp: ''!
thinGray
	^ self width: 1 color: Color gray! !

!BorderedMorph commentStamp: ''!
BorderedMorph introduce borders to morph. Borders have the instanceVariables borderWidth and borderColor.
 
BorderedMorph new borderColor: Color red; borderWidth: 10; openInWorld.

BorderedMorph also have a variety 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: 'accessing' stamp: ''!
useSquareCorners
	self cornerStyle: #square! !

!BorderedMorph methodsFor: '*Morphic-Base' stamp: ''!
changeBorderWidth: evt
	| aHand origin handle newWidth |
	aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand].
	origin := aHand position.
	handle := HandleMorph new
		forEachPointDo:
			[:newPoint | handle removeAllMorphs.
			handle addMorph:
				(LineMorph from: origin to: newPoint color: Color black width: 1).
			newWidth := (newPoint - origin) r asInteger // 5.
			self borderWidth: newWidth]
		lastPointDo:
			[:newPoint | handle deleteBalloon.
			self halo ifNotNil: [:halo | halo addHandles]].
	aHand attachMorph: handle.
	handle showBalloon:
'Move cursor farther from
this point to increase border width.
Click when done.' translated hand: evt hand.
	handle startStepping! !

!BorderedMorph methodsFor: 'accessing' stamp: ''!
borderWidth
	^ borderWidth! !

!BorderedMorph methodsFor: 'accessing' stamp: ''!
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: '*Morphic-Widgets-Windows' stamp: ''!
removeCornerGrips

	| corners |
	corners := self submorphsSatisfying: [:each | each isKindOf: CornerGripMorph].
	corners do: [:each | each delete]! !

!BorderedMorph methodsFor: 'geometry' stamp: ''!
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: 'accessing' stamp: ''!
borderColor: colorOrSymbolOrNil
	self doesBevels ifFalse:[
		colorOrSymbolOrNil isColor ifFalse:[^self]].
	borderColor = colorOrSymbolOrNil ifFalse: [
		borderColor := colorOrSymbolOrNil.
		self changed].! !

!BorderedMorph methodsFor: 'accessing - defaults' stamp: ''!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ self theme borderWidth! !

!BorderedMorph methodsFor: '*Morphic-Base' stamp: ''!
changeBorderColor: evt
	self theme
		chooseColorIn: self
		title: 'Choose Color' translated
		color: self borderStyle color
		for: [ :newColor | self borderColor: newColor ]! !

!BorderedMorph methodsFor: 'accessing' stamp: ''!
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: '*Morphic-Widgets-Windows' stamp: ''!
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: 'accessing' stamp: ''!
colorForInsets
	"Return the color to be used for shading inset borders."
	
	self owner isSystemWindow
		ifTrue: [^self owner colorForInsets].
	^super colorForInsets! !

!BorderedMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
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: 'accessing' stamp: ''!
borderColor
	^ borderColor! !

!BorderedMorph methodsFor: 'accessing' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"Initializes the receiver"
	
	super initialize.
	self initializeBorder! !

!BorderedMorph methodsFor: 'accessing' stamp: ''!
borderWidth: anInteger
	borderColor ifNil: [borderColor := Color black].
	borderWidth := anInteger max: 0.
	self changed! !

!BorderedMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
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: 'menu' stamp: ''!
addBorderStyleMenuItems: aMenu hand: aHandMorph
	"Add border-style menu items"

	| subMenu |
	subMenu := UIManager default newMenuIn: self for: self.
	subMenu 
		add: 'border width...' selector: #changeBorderWidth:;
		add: 'border color...' selector: #changeBorderColor:;
		addLine.
		
	BorderStyle borderStyleChoices do:
		[:sym | (self borderStyleForSymbol: sym)
			ifNotNil:
				[subMenu add: sym target: self selector: #setBorderStyle: argument: sym]].
	aMenu add: 'border style' subMenu: subMenu! !

!BorderedMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
removePaneSplitters
	self splitters do: [:each | each delete]! !

!BorderedMorph methodsFor: 'private - initialization' stamp: ''!
initializeBorder
	"Initialize the receiver state related to border."
	
	borderColor:= self defaultBorderColor.
	borderWidth := self defaultBorderWidth! !

!BorderedMorph methodsFor: 'testing' stamp: ''!
isTranslucentButNotTransparent
	"Answer true if this any of this morph is translucent but not transparent."

	(color isColor and: [color isTranslucentButNotTransparent]) ifTrue: [^ true].
	(borderColor isColor and: [borderColor isTranslucentButNotTransparent]) ifTrue: [^ true].
	^ false! !

!BorderedMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
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: 'accessing' stamp: ''!
borderRaised
	self borderColor: #raised! !

!BorderedMorph methodsFor: 'private' stamp: ''!
basicBorderWidth: aNumber 
	borderWidth := aNumber! !

!BorderedMorph methodsFor: 'accessing' stamp: ''!
borderInset
	self borderColor: #inset! !

!BorderedMorph methodsFor: 'accessing - defaults' stamp: ''!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color black! !

!BorderedMorph methodsFor: 'private' stamp: ''!
basicBorderColor: aColor 
	borderColor := aColor! !

!BorderedMorph methodsFor: 'geometry' stamp: ''!
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: '*Morphic-Widgets-Windows' stamp: ''!
splitters

	^ self submorphsSatisfying: [:each | each isKindOf: ProportionalSplitterMorph]! !

!BorderedMorph class methodsFor: '*Morphic-Base' stamp: ''!
exampleGradient
	
	| morph fs |
	morph := self new.
	fs := GradientFillStyle ramp: {0.0 -> Color red. 1.0 -> Color green}.
	fs 
		origin: morph bounds center;
		direction: (morph bounds width // 2) @ 0;
		radial: true.
	morph 
		fillStyle: fs;
		openInWindow! !

!BottomBorder commentStamp: ''!
Description
--------------------

BottomBorder is a border style that will fill only the bottom of the rectangle.

Public API and Key Messages
--------------------
•	#trimSize:  This option allow to trim the bottom border

Examples
--------------------

BottomBorder new
width: 1;
baseColor: Color white;
trimSize: 2;
yourself

Internal Representation and Key Implementation Points.
--------------------

Instance Variables
trimSize:  <anInteger>  An amount of pixel to trim from both side of the bottom border
!
!BottomBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!BottomBorderStyle commentStamp: ''!
Description
--------------------

BottomBorder is a border style that will fill only the bottom of the rectangle.

Public API and Key Messages
--------------------

- #trimSize: 	This option allow to trim the bottom border

Examples
--------------------

	BottomBorder new
		width: 1;
		baseColor: Color white;
		trimSize: 2;
		yourself	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	trimSize:		<anInteger>		An amount of pixel to trim from both side of the bottom border
!
!BottomBorderStyle methodsFor: 'accessing' stamp: ''!
trimSize: anObject
	trimSize := anObject! !

!BottomBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle: aRectangle on: aCanvas
	self drawLineFrom: aRectangle bottomLeft + (self trimSize @ 0) to: aRectangle bottomRight - (self trimSize @ 0) on: aCanvas! !

!BottomBorderStyle methodsFor: 'accessing' stamp: ''!
trimSize
	^ trimSize ifNil: [ trimSize := 0 ]! !

!BottomLeftGripMorph commentStamp: ''!
I am the handle in the left bottom of windows used for resizing them.!
!BottomLeftGripMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Draw the grip on the given canvas."

	| dotBounds alphaCanvas windowBorderWidth dotBounds2 |
	
	self shouldDraw ifFalse: [^self].

	windowBorderWidth := SystemWindow borderWidth.
	alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7.	
	"alphaCanvas
		frameRectangle: bounds color: Color blue."

	dotBounds := self bounds.
	dotBounds2 := dotBounds right: (dotBounds left + windowBorderWidth).
	dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.
	
	dotBounds2 := dotBounds left: (dotBounds left + windowBorderWidth).
	dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.

	dotBounds2 := dotBounds2 left: (dotBounds2 left + 7).
	dotBounds2 := dotBounds2 right: (dotBounds2 right - 7).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self dotColor.

	dotBounds2 := dotBounds right: (dotBounds left + windowBorderWidth).
	dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.

	dotBounds2 := dotBounds2 top: (dotBounds2 top + 7).
	dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - 7).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self dotColor! !

!BottomLeftGripMorph methodsFor: 'accessing' stamp: ''!
gripLayoutFrame
	^  (0 @ 1 corner: 0 @ 1) asLayoutFrame 
			topOffset: self defaultHeight negated;
			rightOffset: self defaultWidth! !

!BottomLeftGripMorph methodsFor: 'target resize' stamp: ''!
apply: delta 
	| oldBounds |
	oldBounds := target bounds.
	target
		bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner + (0 @ delta y))! !

!BottomLeftGripMorph methodsFor: 'accessing' stamp: ''!
resizeCursor

	^ Cursor resizeForEdge: #bottomLeft! !

!BottomLeftGripMorph methodsFor: 'accessing' stamp: ''!
ptName
	^#bottomLeft! !

!BottomLeftGripMorph methodsFor: 'testing' stamp: ''!
containsPoint: aPoint
	"Answer true only if on edges."
	
	|w|
	^(super containsPoint: aPoint) and: [
		w := SystemWindow borderWidth.
		((self bounds translateBy: w@w negated)
			containsPoint: aPoint) not]! !

!BottomRightGripMorph commentStamp: ''!
I am the handle in the right bottom of windows used for resizing them.!
!BottomRightGripMorph methodsFor: 'drawing' stamp: ''!
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: ''!
gripLayoutFrame
	^ (1 @ 1 corner: 1 @ 1) asLayoutFrame 
		topLeftOffset: (0 - self defaultWidth @ (0 - self defaultHeight))! !

!BottomRightGripMorph methodsFor: 'target resize' stamp: ''!
apply: delta 
	| oldBounds |
	oldBounds := target bounds.
	target
		bounds: (oldBounds origin corner: oldBounds corner + delta)! !

!BottomRightGripMorph methodsFor: 'accessing' stamp: ''!
resizeCursor

	^ Cursor resizeForEdge: #bottomRight! !

!BottomRightGripMorph methodsFor: 'accessing' stamp: ''!
ptName
	^#bottomRight! !

!BottomRightGripMorph methodsFor: 'testing' stamp: ''!
containsPoint: aPoint
	"Answer true only if on edges."
	
	|w|
	^(super containsPoint: aPoint) and: [
		w := SystemWindow borderWidth.
		((self bounds translateBy: (w@w) negated)
			containsPoint: aPoint) not]! !

!BoundedGradientFillStyle commentStamp: ''!
Gradient fillstyle that draws with optional extent.!
!BoundedGradientFillStyle methodsFor: 'comparing' stamp: ''!
= aGradientFillStyle
	"Answer whether equal."

	^super = aGradientFillStyle
		and: [self extent = aGradientFillStyle extent]! !

!BoundedGradientFillStyle methodsFor: 'comparing' stamp: ''!
hash
	"Hash is implemented because #= is implemented."
	
	^super hash bitXor: self extent hash! !

!BoundedGradientFillStyle methodsFor: 'accessing' stamp: ''!
extent
	"Answer the value of extent"

	^ extent! !

!BoundedGradientFillStyle methodsFor: '*Polymorph-Widgets' stamp: ''!
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: 'accessing' stamp: ''!
extent: anObject
	"Set the value of extent"

	extent := anObject! !

!BoxedFloat64 commentStamp: ''!
My instances hold 64-bit Floats in heap objects.  This is the only representation on 32-bit systems.  But on 64-bit systems SmallFloat64 holds a subset of the full 64-bit double-precision range in immediate objects.!
!BoxedFloat64 methodsFor: 'comparing' stamp: ''!
~= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is not equal to the argument. Otherwise return false.
	Fail if the argument is not a Float. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 48>
	^super ~= aNumber! !

!BoxedFloat64 methodsFor: 'comparing' stamp: ''!
< 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."

	<primitive: 43>
	^ aNumber adaptToFloat: self andCompare: #<! !

!BoxedFloat64 methodsFor: '*Math-Operations-Extensions' stamp: ''!
sqrt
	"Answer the square root of the receiver. 
	 Optional. See Object documentation whatIsAPrimitive."

	<primitive: 55>
	| exp guess eps delta |
	self <= 0.0
		ifTrue: [ ^ self = 0.0
				ifTrue: [ 0.0 ]
				ifFalse: [ "v Chg" DomainError signal: 'sqrt undefined for number less than zero.' ] ].
	"Newton-Raphson"
	"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! !

!BoxedFloat64 methodsFor: 'comparing' stamp: ''!
= 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."

	<primitive: 47>
	aNumber isNumber ifFalse: [^ false].
	^ aNumber adaptToFloat: self andCompare: #=! !

!BoxedFloat64 methodsFor: 'arithmetic' stamp: ''!
* aNumber 
	"Primitive. Answer the result of multiplying the receiver by aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 49>
	^ aNumber adaptToFloat: self andSend: #*! !

!BoxedFloat64 methodsFor: 'comparing' stamp: ''!
>= 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. "

	<primitive: 46>
	^ aNumber adaptToFloat: self andCompare: #>=! !

!BoxedFloat64 methodsFor: 'arithmetic' stamp: ''!
/ aNumber 
	"Primitive. Answer the result of dividing receiver by aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 50>
	aNumber = 0.0 ifTrue: [ ^ ZeroDivide signalWithDividend: self].
	^aNumber adaptToFloat: self andSend: #/! !

!BoxedFloat64 methodsFor: 'truncation and round off' stamp: ''!
fractionPart
	"Primitive. Answer a Float whose value is the difference between the 
	receiver and the receiver's asInteger value. Optional. See Object 
	documentation whatIsAPrimitive."

	<primitive: 52>
	^self - self truncated asFloat! !

!BoxedFloat64 methodsFor: '*Math-Operations-Extensions' stamp: ''!
sin
	"Answer the sine of the receiver taken as an angle in radians.
	 Optional. See Object documentation whatIsAPrimitive."

	| sum delta self2 i |
	<primitive: 56>

	"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! !

!BoxedFloat64 methodsFor: 'math functions' stamp: ''!
timesTwoPower: anInteger 
	"Primitive. Answer with the receiver multiplied by 2.0 raised
	to the power of the argument.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 54>

	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)! !

!BoxedFloat64 methodsFor: 'truncation and round off' stamp: ''!
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. "

	<primitive: 51>
	(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"]! !

!BoxedFloat64 methodsFor: 'comparing' stamp: ''!
> 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."

	<primitive: 44>
	^ aNumber adaptToFloat: self andCompare: #>! !

!BoxedFloat64 methodsFor: 'math functions' stamp: ''!
exp
	"Answer E raised to the receiver power.
	 Optional. See Object documentation whatIsAPrimitive." 

	| base fract correction delta div |
	<primitive: 59>

	"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! !

!BoxedFloat64 methodsFor: 'arithmetic' stamp: ''!
exponent
	"Primitive. Consider the receiver to be represented as a power of two
	multiplied by a mantissa (between one and two). Answer with the
	SmallInteger to whose power two is raised. Optional. See Object
	documentation whatIsAPrimitive."

	| positive |
	<primitive: 53>
	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! !

!BoxedFloat64 methodsFor: '*Math-Operations-Extensions' stamp: ''!
arcTan
	"Answer the angle in radians.
	 Optional. See Object documentation whatIsAPrimitive."

	| theta eps step sinTheta cosTheta |
	<primitive: 57>

	"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! !

!BoxedFloat64 methodsFor: 'arithmetic' stamp: ''!
- aNumber 
	"Primitive. Answer the difference between the receiver and aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 42>
	^ aNumber adaptToFloat: self andSend: #-! !

!BoxedFloat64 methodsFor: 'math functions' stamp: ''!
ln
	"Answer the natural logarithm of the receiver.
	 Optional. See Object documentation whatIsAPrimitive."

	| expt n mant x div pow delta sum eps |
	<primitive: 58>

	"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"! !

!BoxedFloat64 methodsFor: 'arithmetic' stamp: ''!
+ aNumber 
	"Primitive. Answer the sum of the receiver and aNumber. Essential.
	Fail if the argument is not a Float. See Object documentation
	whatIsAPrimitive."

	<primitive: 41>
	^ aNumber adaptToFloat: self andSend: #+! !

!BoxedFloat64 methodsFor: 'comparing' stamp: ''!
<= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is less than or equal to the argument. Otherwise return
	false. Fail if the argument is not a Float. Optional. See Object
	documentation whatIsAPrimitive."

	<primitive: 45>
	^ aNumber adaptToFloat: self andCompare: #<=! !

!BoxedFloat64 class methodsFor: 'instance creation' stamp: ''!
basicNew
	^self basicNew: 2! !

!BoxedFloat64 class methodsFor: 'instance creation' stamp: ''!
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."

	<primitive: 71>
	sizeRequested isInteger ifTrue:
		[^sizeRequested = 2
			ifTrue: "arg okay; space must be low."
				[OutOfMemory signal.
				 self basicNew: sizeRequested]  "retry if user proceeds"
			ifFalse:
				[self error: 'a Float shall always have two slots']].
	self primitiveFailed! !

!BracketMorph commentStamp: ''!
Morph displaying opposing arrows.!
!BracketMorph methodsFor: 'geometry' stamp: ''!
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: 'drawing' stamp: ''!
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: ''!
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: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		orientation: #horizontal! !

!BracketMorph methodsFor: 'accessing' stamp: ''!
orientation: anObject
	"Set the value of orientation"

	orientation := anObject.
	self changed! !

!BracketMorph methodsFor: 'accessing' stamp: ''!
orientation
	"Answer the value of orientation"

	^ orientation! !

!BracketMorph methodsFor: 'accessing' stamp: ''!
horizontal: aBoolean
	"Set whether horizontal or vertical."
	
	^self orientation: (aBoolean ifTrue: [#horizontal] ifFalse: [#vertical])! !

!BracketMorph methodsFor: 'accessing' stamp: ''!
horizontal
	"Answer whether horizontal or vertical."
	
	^self orientation == #horizontal! !

!BracketMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"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) ].
	anAthensCanvas setPaint: self borderColor.
	anAthensCanvas drawShape: (self createClosedPolygonPathFrom: 
	(self leftOrTopVertices: self bounds) on: anAthensCanvas).
	
	anAthensCanvas setPaint: self fillStyle.
	anAthensCanvas drawShape: (self createClosedPolygonPathFrom: 
	(self leftOrTopVertices: r) on: anAthensCanvas).
	
	anAthensCanvas setPaint: self borderColor.
	anAthensCanvas drawShape: (self createClosedPolygonPathFrom: 
	(self rightOrBottomVertices: self bounds) on: anAthensCanvas).
	
	anAthensCanvas setPaint: self fillStyle.
	anAthensCanvas drawShape: (self createClosedPolygonPathFrom:
	(self rightOrBottomVertices: r) on: anAthensCanvas)! !

!BracketMorph methodsFor: '*Athens-Morphic' stamp: ''!
createClosedPolygonPathFrom: aPointsArray on: anAthensCanvas
	^ anAthensCanvas
		createPath: [ :builder | 
			aPointsArray ifEmpty: [ builder ].
			builder absolute.
			builder moveTo: aPointsArray first.
			aPointsArray allButFirstDo: [ :p | builder lineTo: p ].
			builder close.
			builder ]! !

!BracketSliderMorph commentStamp: ''!
Abstract superclass for morphs that are used to select a component (R, G, B or A) of a colour.!
!BracketSliderMorph methodsFor: 'initialization' stamp: ''!
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: 'accessing' stamp: ''!
sliderShadowColor
	"Answer the color for the slider shadow."
	
	^Color black alpha: 0.6! !

!BracketSliderMorph methodsFor: 'geometry' stamp: ''!
sliderThickness
	"Answer the thickness of the slider."
	
	^((self bounds isWide
		ifTrue: [self height]
		ifFalse: [self width]) // 2 max: 8) // 2 * 2 + 1! !

!BracketSliderMorph methodsFor: 'geometry' stamp: ''!
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: 'accessing' stamp: ''!
fillStyleToUse
	"Answer the fillStyle that should be used for the receiver."
	
	^self fillStyle! !

!BracketSliderMorph methodsFor: 'layout' stamp: ''!
layoutBounds: aRectangle
	"Set the bounds for laying out children of the receiver.
	Note: written so that #layoutBounds can be changed without touching this method"
	
	super layoutBounds: aRectangle.
	self updateFillStyle.
	slider horizontal: self bounds isWide.
	sliderShadow horizontal: self bounds isWide! !

!BracketSliderMorph methodsFor: 'accessing' stamp: ''!
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: 'protocol' stamp: ''!
defaultFillStyle
	"Answer the defauolt fill style."

	^Color gray! !

!BracketSliderMorph methodsFor: 'initialization' stamp: ''!
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: 'protocol' stamp: ''!
updateFillStyle
	"Update the fill style directions."

	|b fs|
	fs := self fillStyle.
	fs isOrientedFill ifTrue: [
		b := self innerBounds.
		fs origin: b topLeft.
		fs direction: (b isWide
			ifTrue: [b width@0]
			ifFalse: [0@b height])]! !

!BracketSliderMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	"Update the gradient directions."

	super extent: aPoint.
	self updateFillStyle! !

!BracketSliderMorph methodsFor: 'accessing' stamp: ''!
gradient
	"Answer the gradient."

	self subclassResponsibility! !

!BreadthFirstGuide commentStamp: ''!
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: ''!
show: aReference 
	self push: aReference entry.
	self whileNotDoneDo: [ self visitNextEntry: self top ]! !

!BreadthFirstGuide methodsFor: 'showing' stamp: ''!
visitNextEntry: entry
	entry ifAbsent: [ ^ nil ].

	entry isFile ifTrue: [ ^ visitor visitFile: entry ].

	visitor visitDirectory: entry.

	(self shouldVisitChildrenOf: entry) ifTrue: [ self pushAll: entry reference entries ]! !

!BreadthFirstGuideTest commentStamp: ''!
SUnit tests for class BreadthFirstGuide!
!BreadthFirstGuideTest methodsFor: 'tests' stamp: ''!
testAll
	guide := BreadthFirstGuide for: self.
	guide show: (filesystem / 'alpha').
	self assertVisitedIs: #(
			'alpha'
			'beta'
			'epsilon'
			'delta'
			'gamma'
			'zeta'
		)! !

!Break commentStamp: ''!
I am a Breakpoint signal.

use class Breakpoint to insert me reflectively!
!Break class methodsFor: 'break' stamp: ''!
break 
	<debuggerCompleteToSender>
	self signal! !

!Breakpoint commentStamp: ''!
A Breakpoint is an object used for stopping the execution of the program in a determined instruction, normally with debugging purposes. 
There are three types of breakpoints:
-halt once: These are triggered once, and then removed.
-halt always: Once installed, they have to be explicitly removed (by using #remove on the instance side, or #removeAll on class side)
-halt on condition: Before being installed prompts the user for a condition (a block with a boolean expression), and it is only triggered when that condition is met.

Breakpoints are installed via SmartSuggestions menu (available for RBMethodNode, RBMessageNode and RBAssignmentNode), or programmatically:

"(Breakpoint inMethod: (Bar>>#foo2) inNode: ((Bar>>#foo2) ast allChildren at: 9) )
break: #when: withArguments: { [ RFCounter counter isZero ] }
"

!
!Breakpoint methodsFor: '*NewTools-Debugger-Breakpoints-Tools' stamp: ''!
scopeIncludes: anObject

	self isObjectCentric ifTrue: [ ^ targetInstance == anObject ].
	^ self isObjectCentric not and: [ 
		  node methodNode methodClass = anObject class ]! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
node: aNode

	node := aNode! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
targetInstance: anObject

	targetInstance := anObject! !

!Breakpoint methodsFor: 'testing' stamp: ''!
isEnabled

	^ enabled ifNil: [ enabled := true ]! !

!Breakpoint methodsFor: 'install' stamp: ''!
install

	self setAsNodeProperty.
	self isObjectCentric
		ifTrue: [ self targetInstance link: self link toAST: self node.
			self class addBreakpoint: self.
			^ self ].
	self node link: self link.
	self class addBreakpoint: self ! !

!Breakpoint methodsFor: 'api' stamp: ''!
breakInContext: aContext node: aNode
	 <debuggerCompleteToSender>
	
	 self class notifyBreakpointHit: self inContext: aContext node: aNode.
	 self isEnabled ifFalse: [ ^ self ].
	 self oneShot ifTrue: [ self disable ].
	 Break break! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
oneShot

	^ oneShot ifNil: [ oneShot := false ]! !

!Breakpoint methodsFor: 'removing' stamp: ''!
removeFromClass: aClass
	"we just remove this breakpoint from the cache, overridden by VariableBreakpoint to do more"
	self class removeBreakpoint: self! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
level

	^ level! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
node

	^ node! !

!Breakpoint methodsFor: '*NewTools-Debugger-Breakpoints-Tools' stamp: ''!
printTargetForBreakpointInspection
	^node methodNode method printString! !

!Breakpoint methodsFor: 'removing' stamp: ''!
removeFromNodeProperty

	self node removeBreakpoint: self! !

!Breakpoint methodsFor: 'install' stamp: ''!
setAsNodeProperty

	self node addBreakpoint: self! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
targetInstance

	^ targetInstance! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
level: aLevel

	level := aLevel! !

!Breakpoint methodsFor: 'removing' stamp: ''!
removeFromMethod: aMethod
	"we just remove this breakpoint from the cache, overridden by VariableBreakpoint to do more"
	self class removeBreakpoint: self! !

!Breakpoint methodsFor: 'api' stamp: ''!
once

	oneShot := true! !

!Breakpoint methodsFor: 'links' stamp: ''!
breakLinkConditional

	^self breakLink condition: condition arguments: #(context)! !

!Breakpoint methodsFor: 'testing' stamp: ''!
isVariableBreakpoint

	^ false! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
options: anArray

	options := anArray! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
link: aMetaLink

	link := aMetaLink! !

!Breakpoint methodsFor: 'initialization' stamp: ''!
initialize
	
	self class initializeSlots: self.
	options := #(+ optionCompileOnLinkInstallation)! !

!Breakpoint methodsFor: 'api' stamp: ''!
always

	self link: self breakLink

! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
link

	^ link ifNil: [ link := self breakLink ]! !

!Breakpoint methodsFor: 'api' stamp: ''!
scopeTo: anInstance

	self targetInstance: anInstance! !

!Breakpoint methodsFor: '*NewTools-Debugger-Breakpoints-Tools' stamp: ''!
printContentsForBreakpointInspection
	^node methodNode sourceCode! !

!Breakpoint methodsFor: 'links' stamp: ''!
breakLink
	"for now it should just halt in base level"

	^ MetaLink new
		  metaObject: self;
		  selector: #breakInContext:node:;
		  options: options;
		  arguments: #(#context #node)! !

!Breakpoint methodsFor: 'api' stamp: ''!
disable
	enabled := false! !

!Breakpoint methodsFor: 'api' stamp: ''!
enable
	enabled := true! !

!Breakpoint methodsFor: 'api' stamp: ''!
condition: aCondition

	condition := aCondition.
	self link: self breakLinkConditional! !

!Breakpoint methodsFor: 'removing' stamp: ''!
remove

	self removeFromNodeProperty.
	self class removeBreakpoint: self.
	link uninstall! !

!Breakpoint methodsFor: '*NewTools-Debugger-Breakpoints-Tools' stamp: ''!
asBreakpointInspectionItemIn: aStBreakpointInspectionItem 
	^aStBreakpointInspectionItem buildBreakpointItemFor: self! !

!Breakpoint methodsFor: 'testing' stamp: ''!
isObjectCentric

	^ self targetInstance notNil! !

!Breakpoint methodsFor: 'accessing' stamp: ''!
options

	^ options! !

!Breakpoint class methodsFor: 'accessing' stamp: ''!
browseAll
	<script>
	
	| methods |
	methods := self all flatCollect: [ :breakpoint | breakpoint link methods ].
	Smalltalk tools messageList browse: methods! !

!Breakpoint class methodsFor: 'world menu' stamp: ''!
debugWorldMenuOn: aBuilder
	<worldMenu>
	
	(aBuilder item: #'Remove all Breakpoints')
		parent: #Breakpoints;
		order: 2;
		help: 'Remove all the breakpoints of the image.';
		action: [ self removeAll ]! !

!Breakpoint class methodsFor: 'class initialization' stamp: ''!
initialize
	self registerInterestToSystemAnnouncement ! !

!Breakpoint class methodsFor: 'system announcements' stamp: ''!
handleMethodRemoved: anAnnouncement
	self removeFromMethod: anAnnouncement method! !

!Breakpoint class methodsFor: 'observers - experimental' stamp: ''!
notifyBreakpointRemoved: aBreakpoint fromNodes: nodes

	| announcement |
	announcement := BreakpointRemoved
		on: aBreakpoint
		nodes: nodes.
	SystemAnnouncer uniqueInstance announce: announcement! !

!Breakpoint class methodsFor: 'API - object-centric' stamp: ''!
breakOnAST: aNode inObject: anObject

	| breakpoint |
	breakpoint := self new.
	breakpoint node: aNode.
	breakpoint scopeTo: anObject.
	breakpoint install.
	^ breakpoint! !

!Breakpoint class methodsFor: 'accessing' stamp: ''!
removeBreakpoint: aBreakpoint

	| nodes |
	nodes := aBreakpoint link nodes copy.
	self all remove: aBreakpoint.
	self notifyBreakpointRemoved: aBreakpoint fromNodes: nodes! !

!Breakpoint class methodsFor: 'API - object-centric' stamp: ''!
breakOn: aSelector inObject: anObject

	| ast |
	ast := (anObject class lookupSelector: aSelector) ast.
	^ self breakOnAST: ast inObject: anObject! !

!Breakpoint class methodsFor: 'observers - experimental' stamp: ''!
notifyBreakpointAdded: aBreakpoint

	| announcement |
	announcement := BreakpointAdded 
		on: aBreakpoint
		nodes: aBreakpoint link nodes.
	SystemAnnouncer uniqueInstance announce: announcement
	! !

!Breakpoint class methodsFor: 'observers - experimental' stamp: ''!
notifyBreakpointHit: aBreakpoint inContext: aContext node: node

	| announcement |
	announcement := BreakpointHit
		on: aBreakpoint
		nodes: {node}.
	SystemAnnouncer uniqueInstance announce: announcement! !

!Breakpoint class methodsFor: 'system announcements' stamp: ''!
handleMethodModified: anAnnouncement
	self removeFromMethod: anAnnouncement oldMethod! !

!Breakpoint class methodsFor: 'querying' stamp: ''!
isInstalledIn: aMethod

	self all do: [ :breakpoint |
		breakpoint link methods 
			detect: [ :m | m == aMethod ]
			ifFound: [ ^ true ]
	].

	^ false! !

!Breakpoint class methodsFor: 'system announcements' stamp: ''!
handleClassRemoved: anAnnouncement

	self all copy do: [ :breakpoint | 
		breakpoint link methods
			detect: [ :m | m methodClass = anAnnouncement classRemoved ]
			ifFound: [ breakpoint removeFromClass: anAnnouncement classRemoved ] ]! !

!Breakpoint class methodsFor: 'observers - experimental' stamp: ''!
registerObserver: anObject
	"Do not use this method, it is there for compatibility with old users.
	Instead, register your object yourself to 'SystemAnnouncer uniqueInstance' like below, but only for the announcements you need"
	
	SystemAnnouncer uniqueInstance 
		when: BreakpointAdded send: #update: to: anObject;
		when: BreakpointHit send: #update: to: anObject;
		when: BreakpointRemoved send: #update: to: anObject
	! !

!Breakpoint class methodsFor: 'accessing' stamp: ''!
addBreakpoint: aBreakpoint

	self all add: aBreakpoint.
	self notifyBreakpointAdded: aBreakpoint! !

!Breakpoint class methodsFor: 'cleanup' stamp: ''!
removeAll 
	<script>
	
	self all copy do: #remove! !

!Breakpoint class methodsFor: 'class initialization' stamp: ''!
registerInterestToSystemAnnouncement
	<systemEventRegistration>

	SystemAnnouncer uniqueInstance unsubscribe: self.
	SystemAnnouncer uniqueInstance weak when: MethodRemoved send: #handleMethodRemoved: to: self.
	SystemAnnouncer uniqueInstance weak when: MethodModified send: #handleMethodModified: to: self.
	SystemAnnouncer uniqueInstance weak when: ClassRemoved send: #handleClassRemoved: to: self! !

!Breakpoint class methodsFor: 'accessing' stamp: ''!
all

	^ AllBreakpoints ifNil: [ AllBreakpoints := OrderedCollection new ]! !

!Breakpoint class methodsFor: 'testing' stamp: ''!
checkBreakConditionValue: aValue

	(aValue isKindOf: Boolean) ifTrue: [ ^ aValue ].
	Error signal: 'Breakpoint condition returned a non boolean value'.! !

!Breakpoint class methodsFor: 'cleanup' stamp: ''!
removeFromMethod: aMethod

	self all copy do: [ :breakpoint | 
		breakpoint link methods
			detect: [ :m | m == aMethod ]
			ifFound: [ breakpoint removeFromMethod: aMethod ] ]! !

!Breakpoint class methodsFor: 'cleanup' stamp: ''!
removeFrom: aNode

	aNode breakpoints do: [ :breakpoint | breakpoint remove ]! !

!Breakpoint class methodsFor: 'observers - experimental' stamp: ''!
unregisterObserver: anObject
	"Do not use this method, it is there for compatibility with old users.
	Instead, unsubscribe yourself from 'SystemAnnouncer uniqueInstance' directly (like shown below)"
	
	SystemAnnouncer uniqueInstance unsubscribe: anObject! !

!Breakpoint class methodsFor: 'cleanup' stamp: ''!
cleanUp

	self removeAll! !

!BreakpointAnnouncement methodsFor: 'accessing' stamp: ''!
affectsMethodsDefinedInClass: aClass
	^ self link methods
		anySatisfy: [ :each | each methodClass isNotNil and: [ each origin == aClass ] ]! !

!BreakpointAnnouncement methodsFor: 'accessing' stamp: ''!
nodes
	^ nodes! !

!BreakpointAnnouncement methodsFor: 'accessing' stamp: ''!
link
	^ self breakpoint link! !

!BreakpointAnnouncement methodsFor: 'accessing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage
	^ self link methods
		anySatisfy:
			[ :each | each methodClass isNotNil and: [ each package == aPackage ] ]! !

!BreakpointAnnouncement methodsFor: 'accessing' stamp: ''!
nodes: anObject
	nodes := anObject! !

!BreakpointAnnouncement methodsFor: 'accessing' stamp: ''!
breakpoint: anObject
	breakpoint := anObject! !

!BreakpointAnnouncement methodsFor: 'accessing' stamp: ''!
affectsMethod: aMethod

	^ self link methods anySatisfy: [:each | each compiledMethod == aMethod compiledMethod ]! !

!BreakpointAnnouncement methodsFor: 'accessing' stamp: ''!
breakpoint
	^ breakpoint! !

!BreakpointAnnouncement methodsFor: '*Calypso-SystemPlugins-Reflectivity-Queries' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery

	^ self link methods anySatisfy: [:each | 
		aMethodQuery isAffectedByChangedMethod: each ]! !

!BreakpointAnnouncement methodsFor: 'accessing' stamp: ''!
affectsMethods
	^true! !

!BreakpointAnnouncement class methodsFor: 'instance creation' stamp: ''!
on: aBreakpoint nodes: nodes
	^ self new
		breakpoint: aBreakpoint;
		nodes: nodes;
		yourself! !

!BreakpointHit methodsFor: 'accessing' stamp: ''!
valueOrNil: anObject
	valueOrNil := anObject! !

!BreakpointHit methodsFor: 'accessing' stamp: ''!
valueOrNil
	^ valueOrNil! !

!BreakpointIconStyler commentStamp: ''!
I'm in charge to style an ast when there are breakpoints that are enabled!
!BreakpointIconStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	 ^ [ :seg | 
	   aNode breakpoints do: [ :breakpoint | breakpoint remove ].
	   seg delete ]! !

!BreakpointIconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^(Color red alpha: 0.1)! !

!BreakpointIconStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode
	^ 'Breakpoint'! !

!BreakpointIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^aNode hasBreakpoint and: [ aNode breakpoints anySatisfy: [:brkpt | brkpt isEnabled ]]! !

!BreakpointIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #haltIcon ! !

!BreakpointObserverTest methodsFor: 'tests' stamp: ''!
testNotifyBreakpointAdded
	SystemAnnouncer uniqueInstance when: BreakpointAdded send: #update: to: observer.
	breakpoint install.
	self assert: observer tag class equals: BreakpointAdded.
	self assert: observer tag breakpoint identicalTo: breakpoint.
	self assertCollection: observer tag nodes equals: { (cls >> #dummy) ast } asSet! !

!BreakpointObserverTest methodsFor: 'running' stamp: ''!
tearDown
	|pkg|
	cls ifNotNil: [ cls isObsolete ifFalse: [ cls removeFromSystem ] ].
	pkg := 'DummyPackage' asPackageIfAbsent: [ ]. 
	pkg ifNotNil: [ pkg removeFromSystem ].
	Breakpoint removeAll.
	Breakpoint all addAll: previousBreakpoints.
	SystemAnnouncer announcer: oldSystemAnnouncer.
	super tearDown! !

!BreakpointObserverTest methodsFor: 'tests' stamp: ''!
testNotifyBreakpointRemoved	
	breakpoint install.
	SystemAnnouncer uniqueInstance when: BreakpointRemoved send: #update: to: observer.
	breakpoint remove.
	self assert: observer tag class equals: BreakpointRemoved.
	self assert: observer tag breakpoint identicalTo: breakpoint.
	self assertCollection: observer tag nodes equals: { (cls >> #dummy) ast } asSet! !

!BreakpointObserverTest methodsFor: 'helpers' stamp: ''!
newDummyClass

	^ self class classInstaller make: [ :aBuilder | 
		  aBuilder
			  name: #DummyClassForBreakpoint;
			  package: 'DummyPackage' ]! !

!BreakpointObserverTest methodsFor: 'tests' stamp: ''!
testNotifyBreakpointHit
	SystemAnnouncer uniqueInstance when: BreakpointHit send: #update: to: observer.
	breakpoint install.
	self should: [cls new dummy] raise: Break.	
	self assert: observer tag class equals: BreakpointHit.
	self assert: observer tag breakpoint identicalTo: breakpoint.
	self assert: observer tag valueOrNil isNil
	! !

!BreakpointObserverTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."

	super setUp.
	previousBreakpoints := Breakpoint all copy.
	oldSystemAnnouncer := SystemAnnouncer uniqueInstance.
	SystemAnnouncer announcer: nil.
	cls := self newDummyClass.
	breakpoint := Breakpoint new.
	cls compile: 'dummy ^42'.
	breakpoint
		node: (cls >> #dummy) ast;
		once.
	observer := DummyBreakpointObserver new! !

!BreakpointTest commentStamp: ''!
A BreakpointTest is a test class for testing the behavior of Breakpoint!
!BreakpointTest methodsFor: 'tests' stamp: ''!
testRemoveBreakpointWithRemoveFrom
	|bp node |
	cls compile: 'dummy ^42'.
	self assertEmpty: Breakpoint all.
	
	node := (cls >> #dummy) ast.
	bp := (Breakpoint new node: node) install.
	self assertCollection: Breakpoint all includesAll: {bp}.
	Breakpoint removeFrom: node.
	self assertEmpty: Breakpoint all.! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testBreakInContextNode

	|observer breakpoint|
	observer := DummyBreakpointObserver new.
	Breakpoint registerObserver: observer.
	breakpoint := Breakpoint new.	
	self should: [breakpoint breakInContext: self node: #node] raise: Break.
	self assert: observer tag notNil.
	self assert: observer tag breakpoint identicalTo: breakpoint.
	self assertCollection: observer tag nodes equals: #(#node).
	! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testAddRemoveBreakpointKeepTimeStamp

	| bp timeStamp |
	"adding an removing a breakpoint does not change the timestamp of the method"
	Author
		useAuthor: thisContext method selector
		during: [ cls compile: 'dummy ^42' ].

	timeStamp := (cls >> #dummy) timeStamp.

	bp := Breakpoint new.
	bp node: (cls >> #dummy) ast.
	bp install.

	self assert: (cls >> #dummy) timeStamp equals: timeStamp.

	bp remove.
	self assertEmpty: Breakpoint all.

	self assert: (cls >> #dummy) timeStamp equals: timeStamp! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testObjectCentricASTAPI
	|object1 object2 ast|		
	object1 := ReflectivityExamples new.
	object2 := ReflectivityExamples new.
	ast := (ReflectivityExamples >> #exampleAssignment) ast statements first.
	
	Breakpoint breakOnAST: ast inObject: object1.
	
	self should: [object1 exampleAssignment] raise: Break.
	self shouldnt: [object2 exampleAssignment] raise: Break! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testTargetInstanceGarbageCollected
	|bp object|	
	bp := Breakpoint new.
	object := Object new.
	bp scopeTo: object.
	object := nil.
	Smalltalk garbageCollect.
	
	self assert: bp targetInstance isNil.
	self deny: bp isObjectCentric! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testBreakpointInitialization
	|bp|	
	bp := Breakpoint new.
	self assert: bp targetInstance isNil.
	self deny: bp isObjectCentric! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testSetAsBreakpointProperty
	| node breakpoint breakpoint2 |
	node := RBProgramNode new.
	breakpoint := Breakpoint new.
	breakpoint2 := Breakpoint new.
	breakpoint node: node.
	breakpoint2 node: node.
	
	breakpoint setAsNodeProperty.
	breakpoint2 setAsNodeProperty.
	self assert: node hasBreakpoint.
	self assertCollection: node breakpoints equals: { breakpoint. breakpoint2 } asSet.
	
	breakpoint setAsNodeProperty.
	self assertCollection: node breakpoints equals: { breakpoint. breakpoint2 } asSet.
	
	breakpoint removeFromNodeProperty.
	breakpoint2 removeFromNodeProperty.
	self deny: node hasBreakpoint! !

!BreakpointTest methodsFor: 'utilities' stamp: ''!
newDummyClass

	^ self class classInstaller make: [ :aBuilder | 
		  aBuilder
			  name: #DummyClassForBreakpoint;
			  package: 'DummyPackage' ]! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testModifyMethodWithBreakpoint
	cls compile: 'dummy ^42'.
	self assertEmpty: Breakpoint all.
	Breakpoint new
		node: (cls >> #dummy) ast;
		once;
		install.
	self assert: (cls >> #dummy) hasBreakpoint.
	cls compile: 'dummy ^43'.
	self assertEmpty: Breakpoint all! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testObjectCentricAPI
	|object1 object2|		
	object1 := ReflectivityExamples new.
	object2 := ReflectivityExamples new.
	
	Breakpoint breakOn: #exampleAssignment inObject: object1.
	
	self should: [object1 exampleAssignment] raise: Break.
	self shouldnt: [object2 exampleAssignment] raise: Break! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testUpdateMethod
	| bp method |
	"test that, if we install a breakpoint and edit the method, it is removed correctly"
	
	cls compile: 'dummy ^42'.
	method := cls >> #dummy.
	self assertEmpty: Breakpoint all.
	bp := Breakpoint new.
	bp	node: (cls >> #dummy) ast.
	bp install.
	self assertCollection: Breakpoint all includesAll: {bp}.
	"no edit the method"
	cls compile: 'dummy ^nil'.
	"after the new method is installed, the method is different"
	self deny: (cls >> #dummy) bytecode equals: method bytecode.
	"and the breakpoint is not registered anymore"
	self assertEmpty: Breakpoint all! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testBreakLink
	|breakpoint link|
	breakpoint := Breakpoint new.
	link := breakpoint link.
	self assert: link metaObject identicalTo: breakpoint.
	self assert: link selector equals: #breakInContext:node:.
	self assertCollection: link options equals: (MetaLink new parseOptions: breakpoint options) options.
	self assertCollection: link arguments equals: #(#context #node) ! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testObjectCentricObjectAPI
	|object1 object2|		
	object1 := ReflectivityExamples new.
	object2 := ReflectivityExamples new.
	
	object1 haltOnCallTo: #exampleAssignment.
	
	self should: [object1 exampleAssignment] raise: Break.
	self shouldnt: [object2 exampleAssignment] raise: Break! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testDisableEnableBreakpoint
	| breakpoint |
	breakpoint := Breakpoint new.	
	self should: [breakpoint breakInContext: self node: #node] raise: Break.
	breakpoint disable.
	self shouldnt: [breakpoint breakInContext: self node: #node] raise: Break.
	breakpoint enable.
	self should: [breakpoint breakInContext: self node: #node] raise: Break
! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testAddRemoveBreakpoint
	| bp method |
	cls compile: 'dummy ^42'.
	method := cls >> #dummy.
	self assertEmpty: Breakpoint all.
	bp := Breakpoint new.
	bp	node: (cls >> #dummy) ast.
	bp install.
	"after the breakpoint is installed, the method is different"
	self deny: (cls >> #dummy) bytecode equals: method bytecode.
	
	self assertCollection: Breakpoint all includesAll: {bp}.
	bp remove.
	self assertEmpty: Breakpoint all.
	
	"Check that the method is correcty reverted"
	self assert: (cls >> #dummy) bytecode equals: method bytecode! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testBreakpointEnabled
	| breakpoint |
	breakpoint := Breakpoint new.
	self assert: breakpoint isEnabled.
	breakpoint disable.
	self deny: breakpoint isEnabled.
	breakpoint enable.
	self assert: breakpoint isEnabled! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testObjectCentricBreakpoint
	|bp object1 object2 ast|	
	bp := Breakpoint new.
	object1 := ReflectivityExamples new.
	object2 := ReflectivityExamples new.
	ast := (ReflectivityExamples >> #exampleAssignment) ast.
	
	bp node: ast.
	bp scopeTo: object1.
	bp install.
	
	self should: [object1 exampleAssignment] raise: Break.
	self shouldnt: [object2 exampleAssignment] raise: Break.
	
	bp remove.
	self shouldnt: [object1 exampleAssignment] raise: Break.! !

!BreakpointTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	cls := self newDummyClass.
	previousBreakpoints := Breakpoint all copy.
	oldSystemAnnouncer := SystemAnnouncer uniqueInstance.
	SystemAnnouncer announcer: nil.
	Breakpoint registerInterestToSystemAnnouncement.
	Breakpoint all removeAll.! !

!BreakpointTest methodsFor: 'running' stamp: ''!
tearDown
	| pkg |
	Breakpoint removeAll.	
	Breakpoint all addAll: previousBreakpoints.
	SystemAnnouncer announcer: oldSystemAnnouncer.
	cls ifNotNil: [ cls isObsolete ifFalse: [ cls removeFromSystem ] ].
	pkg := 'DummyPackage' asPackageIfAbsent: [ ]. 
	pkg ifNotNil: [ pkg removeFromSystem ].
	super tearDown.! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testBreakpointNodeProperty
	|breakpoint|
	cls compile: 'dummy ^42'.
	breakpoint := Breakpoint new
		node: (cls >> #dummy) ast;
		once.
	breakpoint install.
	self assert: (cls >> #dummy) ast hasBreakpoint.
	self assertCollection: (cls >> #dummy) ast breakpoints equals: {breakpoint} asSet.
	breakpoint remove.
	self deny: (cls >> #dummy) ast hasBreakpoint.! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testBreakLinkOnce
	|breakpoint|
	breakpoint := Breakpoint new.
	self deny: breakpoint oneShot.
	breakpoint once.
	self assert: breakpoint oneShot! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testBreakOnceInContext

	|observer breakpoint|
	observer := DummyBreakpointObserver new.
	Breakpoint registerObserver: observer.
	breakpoint := Breakpoint new once.	
	self assert: breakpoint isEnabled.
	self should: [breakpoint breakInContext: self node: #node] raise: Break.
	self deny: breakpoint isEnabled.
	self shouldnt: [breakpoint breakInContext: self node: #node] raise: Break.! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testScopeTo
	|bp object|	
	bp := Breakpoint new.
	object := Object new.
	bp scopeTo: object.
	
	self assert: bp targetInstance identicalTo: object.
	self assert: bp isObjectCentric! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testUninstallFromGarbageCollectedInstance
	|bp object ast|	
	bp := Breakpoint new.
	object := ReflectivityExamples new.
	ast := (ReflectivityExamples >> #exampleAssignment) ast.
	
	bp node: ast.
	bp scopeTo: object.
	bp install.
	
	object := nil.
	Smalltalk garbageCollect.
	
	self shouldnt: [ bp remove ] raise: Error.! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testRemoveMethodWithBreakpoint
	cls compile: 'dummy ^42'.
	self assertEmpty: Breakpoint all.
	Breakpoint new
		node: (cls >> #dummy) ast;
		once;
		install.
	self assert: (cls >> #dummy) hasBreakpoint.
	cls removeSelector: #dummy.
	self
		assertEmpty: cls methods;
		assertEmpty: Breakpoint all! !

!BreakpointTest methodsFor: 'tests' stamp: ''!
testRemoveClassWithBreakpoint
	cls compile: 'dummy ^42'.
	self assertEmpty: Breakpoint all.
	Breakpoint new
		node: (cls >> #dummy) ast;
		once;
		install.
	self assert: (cls >> #dummy) hasBreakpoint.
	cls removeFromSystem.
	self assertEmpty: Breakpoint all! !

!BrokenClassAnnotation commentStamp: ''!
I represent broken class annotation when declaration method raises error during registry building.

I include description of raisen error in my variable errorString.

To debug broken annotation you can inspect all of them using:
	BrokenClassMetaAnnotation registeredInstances 
Then ask #debug to choosen annotation:
	brokenAnnotation debug.
It perform declaration method which will open debugger.	

My instances are created using mesage #withError:
	BrokenClassAnnotation withError: anError
I only collect description of given error to not keep garbage of failed process.	

Internal Representation and Key Implementation Points.

    Instance Variables
	errorString:		<String>
!
!BrokenClassAnnotation methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	self printDeclarationOn: aStream! !

!BrokenClassAnnotation methodsFor: 'operations' stamp: ''!
debug
	"here we just reevaluate messages which could fail"
	| ann |
	ann := self freshInstance.
	ann isForbidden.
	^ann! !

!BrokenClassAnnotation methodsFor: 'accessing' stamp: ''!
errorString: anObject
	errorString := anObject! !

!BrokenClassAnnotation methodsFor: 'accessing' stamp: ''!
errorString
	^ errorString! !

!BrokenClassAnnotation class methodsFor: 'instance creation' stamp: ''!
withError: anError
	^self new 
		errorString: anError description! !

!BrokenClassAnnotation class methodsFor: 'instance creation' stamp: ''!
forBadMethodReturn
	^self new 
		errorString: 'Annotating method do not return an annotation instance'! !

!BrowseDebugAction commentStamp: ''!
A BrowseDebugAction is a debugging actions sending a unary message to the stack widget.
!
!BrowseDebugAction methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self needsUpdate: false.
	self needsValidation: false.! !

!BrowseDebugAction methodsFor: 'accessing' stamp: ''!
receiver

	^ self debugger stack! !

!BrowseDebugAction class methodsFor: 'actions creation' stamp: ''!
debugActionsFor: aDebugger
	<contextMenuDebuggingAction>
	| initilOrder |
	
	initilOrder := 60.
	^ { 
		self new
			id: #browseSendersOfMessages;
			order: initilOrder;
			keymap: PharoShortcuts current browseSendersShortcut;
			help: 'Browse the senders of the current message.';
			label: 'Senders of...'.
		self new
			id: #browseMessages;
			order: initilOrder + 5;
			keymap: PharoShortcuts current browseImplementorsShortcut;
			help: 'Browse the implementors of the current message.';
			label: 'Implementors of...'.
		self new
			id: #methodHierarchy;
			order: initilOrder + 10;
			keymap: PharoShortcuts new browseMethodHierarchyShortcut;
			help: 'Browser a hierarchy of the implementors of the current mnethod.';
			label: 'Inheritance'.
		self new
			id: #browseVersions;
			order: initilOrder + 15;
			keymap: PharoShortcuts current browseVersionsShortcut;
			help: 'Open the historic of the message.';
			label: 'Versions'.
		self new
			id: #browseInstVarRefs;
			order: initilOrder + 20;
			help: 'Browse the references to the instance variable.';
			label: 'Inst var refs...'.
		self new
			id: #browseClassVarRefs;
			order: initilOrder + 25;
			help: 'Browse the references to the class variable.';
			label: 'Class var refs...'.
		self new
			id: #browseClassVariables;
			order: initilOrder + 30;
			help: 'Browse the class variables.';
			label: 'Class variables';
			withSeparatorAfter.
			
		self new
			id: #browseClassRefs;
			order: initilOrder + 35;
			keymap: PharoShortcuts current browseClassReferencesShortcut;
			help: 'Browse the references to the class.';
			label: 'Class refs'.
		self new
			id: #browseMethodFull;
			order: initilOrder + 40;
			keymap: PharoShortcuts current browseShortcut;
			help: 'Open a system browser on the method sent.';
			label: 'Browse full'.
		self new
			id: #browseReceiver;
			order: initilOrder + 41;
			help: 'Open a system browser on the class of the object receiving the method.';
			"keymap: PharoShortcuts current browseShortcut;"
			label: 'Browse receiver'.
		
		self new
			id: #fileOutMessage;
			order: initilOrder + 45;
			help: 'Export the code of the current method to a file.';
			label: 'File out'.
		self new
			id: #inspectInstances;
			order: initilOrder + 50;
			help: 'Open an inspector on a collection containing all the instances of the receiver class.';
			label: 'Inspect instances'.
		self new
			id: #inspectSubInstances;
			order: initilOrder + 55;
			help: 'Open an inspector on a collection containing all the instances and sub instances of the receiver class.';
			label: 'Inspect sub instances';
			withSeparatorAfter
	 }! !

!BuilderManifestTest commentStamp: ''!
A ManifestBuilderTest is a class to test the behavior of ManifestBuilder!
!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testInstallFalsePositive
	| manifestBuilder |
	manifestBuilder := TheManifestBuilder of: MFClassA. .
	self deny: (manifestBuilder hasFalsePositiveOf: 'test' version: 0).
	manifestBuilder installFalsePositiveOf: 'test' version: 0.
	self assert: (manifestBuilder hasFalsePositiveOf: 'test' version: 0).
	self assert: (manifestBuilder falsePositiveOf: 'test' version: 0) notNil.! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testIsFalsePositive
	
	| manifestBuilder cl mth|
	cl := MFClassA.
	mth := cl >> #method.
	manifestBuilder := TheManifestBuilder of: MFClassA .
	self deny: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ).
	
	manifestBuilder addRejectClass: MFClassA.
	self assert: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ).
	
	manifestBuilder removeRejectClass: MFClassA.	.
	self deny: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ).
	
	manifestBuilder addRejectRule: 'test'.
	self assert: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ).
	
	manifestBuilder removeRejectRule: 'test'.
	self deny: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ).
	
	manifestBuilder installFalsePositiveOf: 'test' version: 0.
	manifestBuilder addFalsePositive:  mth of: 'test' version: 0.
	self assert: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ).! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testIsClassAManifest
		
	self deny: Point isManifest.
	TheManifestBuilder of: MFClassA. 
	self assert: ( (testingEnvironment at: #ManifestManifestResourcesTests) isManifest)! !

!BuilderManifestTest methodsFor: 'running' stamp: ''!
tearDown
	
	| cl |
	cl := testingEnvironment at: #ManifestManifestResourcesTests ifAbsent: [ nil ].
	cl
		ifNotNil: [ 
			cl
				removeFromChanges;
				removeFromSystem ].
	super tearDown.! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testCreationManifest
	| manifestBuilder cl |
	manifestBuilder := TheManifestBuilder new.
  
	cl := testingEnvironment 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: ''!
testAddAllFalsePositive
	| manifestBuilder array |
	array := {MFClassA . MFClassB}.
	manifestBuilder := TheManifestBuilder of: MFClassA.
	manifestBuilder installFalsePositiveOf: 'test' version: 0.

	self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassA ]).
	self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassB ]).

	manifestBuilder addAllFalsePositive: array of: 'test' version: 0.

	self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassA ]).
	self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassB ]).

	manifestBuilder addAllFalsePositive: array of: 'test' version: 0.

	self assert: manifestBuilder manifest ruletestV0FalsePositive size equals: 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: ''!
testDateOfToDo
	
	| manifestBuilder date1 date2 |
	

	manifestBuilder := TheManifestBuilder of: MFClassA .
	manifestBuilder  installToDoOf: 'test' version: 0.
	
	date1 :=  DateAndTime current.
	manifestBuilder addToDo: MFClassA of: 'test' version: 0. 
	date2 :=  DateAndTime current.
	
	self assert: (manifestBuilder dateOfToDo: MFClassA onRule: 'test' version: 0) >= date1 .
	self assert: (manifestBuilder dateOfToDo: MFClassA onRule: 'test' version: 0) <= date2 .! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testCreationManifestOn
	| manifestBuilder cl |
	manifestBuilder := TheManifestBuilder new.

	cl := testingEnvironment at: #ManifestManifestResourcesTests ifAbsent: [ nil ].
	cl
		ifNotNil: [ 
			cl
				removeFromChanges;
				removeFromSystemUnlogged ].
	self assert: (manifestBuilder manifestOf: MFClassA ) isNil.
	self assert: (TheManifestBuilder of: MFClassA) notNil.
	self assert: (manifestBuilder manifestOf: MFClassA) notNil! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testContainsToDo
	
	| manifestBuilder |
	

	manifestBuilder := TheManifestBuilder of: MFClassA .
	manifestBuilder  installToDoOf: 'test' version: 0.
	
	manifestBuilder addToDo: MFClassA of: 'test' version: 0. 
	
	self assert: (manifestBuilder containsToDo: MFClassA onRule: 'test' version: 0).
	self deny: (manifestBuilder containsToDo: MFClassB onRule: 'test' version: 0).! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testAddRule
	
	| manifestBuilder|
	
	manifestBuilder := TheManifestBuilder of: MFClassA .
	
	self deny: ((manifestBuilder rejectRules) anySatisfy: [:each| each = 0]).
	
	manifestBuilder addRejectRule: 0.
	
	self assert: ((manifestBuilder rejectRules) anySatisfy: [:each| each = 0]).

	manifestBuilder removeRejectRule: 0.	

	self deny: ((manifestBuilder rejectRules) anySatisfy: [:each| each = 0]).! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testAddClass
	
	| manifestBuilder|
	
	manifestBuilder := TheManifestBuilder of: MFClassA .
	
	self deny: ((manifestBuilder rejectClasses) anySatisfy: [:each| each = MFClassA]).
	
	manifestBuilder addRejectClass: MFClassA..
	
	self assert: ((manifestBuilder rejectClasses) anySatisfy: [:each| each = MFClassA]).

	manifestBuilder removeRejectClass: MFClassA.	.

	self deny: ((manifestBuilder rejectClasses) anySatisfy: [:each| each = MFClassA]).! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testAddFalsePositive
	
	| manifestBuilder cl mth|
	cl := MFClassA.
	mth := MFClassA >> #method.
	manifestBuilder := TheManifestBuilder of: MFClassA .
	manifestBuilder  installFalsePositiveOf: 'test' version: 0.
	
	self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = cl]).
	self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = mth]).
	
	manifestBuilder addFalsePositive: cl of: 'test' version: 0. 
	manifestBuilder addFalsePositive: mth of: 'test' version: 0. 
	
	self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = cl]).
	self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = mth]).
	
	manifestBuilder removeFalsePositive: cl of: 'test' version: 0. 
	manifestBuilder removeFalsePositive: mth of: 'test' version: 0. 
	
	self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = cl]).
	self deny: ((manifestBuilder falsePositiveOf: 'test'version: 0) anySatisfy: [:each| each = mth]).! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testContainsFalsePositive
	
	| manifestBuilder |
	

	manifestBuilder := TheManifestBuilder of: MFClassA .
	manifestBuilder  installFalsePositiveOf: 'test' version: 0.
	
	manifestBuilder addFalsePositive: MFClassA of: 'test' version: 0. 
	
	self assert: (manifestBuilder containsFalsePositive: MFClassA onRule: 'test' version: 0).
	self deny: (manifestBuilder containsFalsePositive: MFClassB onRule: 'test' version: 0).! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testDateOfFalsePositive
	
	| manifestBuilder date1 date2 |
	

	manifestBuilder := TheManifestBuilder of: MFClassA .
	manifestBuilder  installFalsePositiveOf: 'test' version: 0.
	
	date1 :=  DateAndTime current.
	manifestBuilder addFalsePositive: MFClassA of: 'test' version: 0. 
	date2 :=  DateAndTime current.
	
	self assert: (manifestBuilder dateOfFalsePositive: MFClassA onRule: 'test' version: 0) >= date1 .
	self assert: (manifestBuilder dateOfFalsePositive: MFClassA onRule: 'test' version: 0) <= date2 .! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testAddToDo
	
	| manifestBuilder cl mth|
	cl := MFClassA.
	mth := MFClassA >> #method.
	manifestBuilder := TheManifestBuilder of: MFClassA .
	manifestBuilder  installToDoOf: 'test' version: 0.
	
	self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = cl]).
	self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = mth]).
	
	manifestBuilder addToDo: cl of: 'test' version: 0. 
	manifestBuilder addToDo: mth of: 'test' version: 0. 
	
	self assert: ((manifestBuilder  toDoOf: 'test' version: 0) anySatisfy: [:each| each = cl]).
	self assert: ((manifestBuilder  toDoOf: 'test' version: 0) anySatisfy: [:each| each = mth]).
	
	manifestBuilder removeToDo: cl of: 'test' version: 0. 
	manifestBuilder removeToDo: mth of: 'test' version: 0. 
	
	self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = cl]).
	self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = mth]).! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testResetToDo
	| manifestBuilder array |
	array := {MFClassA . MFClassB}.
	manifestBuilder := TheManifestBuilder of: MFClassA.
	manifestBuilder installToDoOf: 'test' version: 0.

	manifestBuilder addAllToDo: array of: 'test' version: 0.

	self assert: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassA ]).
	self assert: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassB ]).

	manifestBuilder resetToDoOf: 'test' version: 0.

	self assert: manifestBuilder manifest ruletestV0TODO size equals: 0! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testCleanUpTD
	| manifestBuilder |
	manifestBuilder := TheManifestBuilder of: MFClassA.
	MFClassA compile: 'foo'.
	manifestBuilder installToDoOf: 'test' version: 0.
	manifestBuilder addToDo: MFClassA >> #foo of: 'test' version: 0.

	self assert: (manifestBuilder containsToDo: MFClassA >> #foo onRule: 'test' version: 0).

	MFClassA removeSelector: #foo.
	manifestBuilder cleanUp.

	self assert: (manifestBuilder toDoOf: 'test' version: 0) size equals: 0! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testResetFalsePositive
	| manifestBuilder array |
	array := {MFClassA . MFClassB}.
	manifestBuilder := TheManifestBuilder of: MFClassA.
	manifestBuilder installFalsePositiveOf: 'test' version: 0.

	manifestBuilder addAllFalsePositive: array of: 'test' version: 0.

	self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassA ]).
	self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassB ]).

	manifestBuilder resetFalsePositiveOf: 'test' version: 0.

	self assert: manifestBuilder manifest ruletestV0FalsePositive size equals: 0! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testAddAllToDo
	| manifestBuilder array |
	array := {MFClassA . MFClassB}.
	manifestBuilder := TheManifestBuilder of: MFClassA.
	manifestBuilder installToDoOf: 'test' version: 0.

	self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassA ]).
	self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassB ]).

	manifestBuilder addAllToDo: array of: 'test' version: 0.

	self assert: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassA ]).
	self assert: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [ :each | each = MFClassB ]).

	manifestBuilder addAllToDo: array of: 'test' version: 0.

	self assert: manifestBuilder manifest ruletestV0TODO size equals: 2! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testCleanUpFP
	| manifestBuilder |
	manifestBuilder := TheManifestBuilder of: MFClassA.
	MFClassA compile: 'foo'.
	manifestBuilder installFalsePositiveOf: 'test' version: 0.
	manifestBuilder addFalsePositive: MFClassA >> #foo of: 'test' version: 0.

	self assert: (manifestBuilder containsFalsePositive: MFClassA >> #foo onRule: 'test' version: 0).

	MFClassA removeSelector: #foo.
	manifestBuilder cleanUp.

	self assert: (manifestBuilder falsePositiveOf: 'test' version: 0) size equals: 0! !

!BuilderManifestTest methodsFor: 'tests' stamp: ''!
testInstallToDo
	| manifestBuilder |
	
	manifestBuilder := TheManifestBuilder of: MFClassA. .
	self deny: (manifestBuilder hasToDoOf: 'test' version: 0).
	manifestBuilder installToDoOf: 'test' version: 0.
	self assert: (manifestBuilder hasToDoOf: 'test' version: 0).
	self assert: (manifestBuilder toDoOf: 'test' version: 0) notNil.! !

!BuilderManifestTest methodsFor: 'running' stamp: ''!
setUp
	
	| cl |
	super setUp.
	cl := testingEnvironment at: #ManifestManifestResourcesTests ifAbsent: [ nil ].

	cl
		ifNotNil: [ 
			cl
				removeFromChanges;
				removeFromSystem ].! !

!ButtonPresenter commentStamp: ''!
A ButtonPresenter is an applicative presenter which handle a basic button.
See AbstractWidgetPresenter

self example

You can also have a look at CustomerStatisfaction for another example.

I provide the following variables and their accessors
- action is the action performed when I am clicked.
- icon is the icon displayed on me.
- label is the text displayed on me.
- state is a boolean representing if I am highlighted, it is false by default and it is reversed while clicking.

todo
- askBeforeChanging
- font
- menu
- shortcut!
!ButtonPresenter methodsFor: 'api' stamp: ''!
menu: aMenu

	menuHolder value: aMenu! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
iconName: aSymbol

	iconHolder value: (self iconNamed: aSymbol)! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
font

	^ fontHolder value! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
askBeforeChanging: aBoolean

	askBeforeChangingHolder value: aBoolean! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
icon

	^ iconHolder value! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
shortcut

	^ shortcutHolder value! !

!ButtonPresenter methodsFor: 'private' stamp: ''!
registerShortcut: newShortcut
	| receiver |
	receiver := self window.
	(receiver isNil or: [ newShortcut isNil ]) ifTrue: [ ^ self ].

	receiver model
		bindKeyCombination: newShortcut 
		toAction: [ self performAction ]! !

!ButtonPresenter methodsFor: 'api - events' stamp: ''!
whenStateChangedDo: aBlock
	"set a block to perform after that the button has been aclicked, and its action performed"

	stateHolder whenChangedDo: aBlock! !

!ButtonPresenter methodsFor: 'morphic' stamp: ''!
label
	"<api: #inspect>"
	
 	^ self addShortcutTipFor: labelHolder value! !

!ButtonPresenter methodsFor: 'private' stamp: ''!
addShortcutTipFor: aCharacter on: aString
	| index text |
	
	aString isNil ifTrue: [ ^ nil ].
	text := aString asText.
	aCharacter ifNil: [ ^ text ].
	index := aString asLowercase indexOf: aCharacter asLowercase.
	index isZero ifTrue: [ ^ text ].
	
	^ text
		addAttribute: (TextEmphasis underlined) 
		from: index
		to: index;
		yourself! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
icon: anIcon

	iconHolder value: anIcon! !

!ButtonPresenter methodsFor: 'api - events' stamp: ''!
whenLabelChangedDo: aBlock
	"set a block to perform after that the button has been aclicked, and its action performed"

	labelHolder whenChangedDo: aBlock! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
action: aBlock
	"set the block performed when the button is clicked"
	"<api: #block getter: #getAction registration: #whenActionChangedDo:>"

	actionHolder value: aBlock! !

!ButtonPresenter methodsFor: 'morphic' stamp: ''!
performAction

	actionHolder value value.
	" Here I set a dummy value just to make the holder raise an event "
	actionPerformedHolder value: nil.! !

!ButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	actionHolder := [] asValueHolder.
	labelHolder := '' asValueHolder.
	fontHolder := nil asValueHolder.
	iconHolder := nil asValueHolder.
	stateHolder := false asValueHolder.
	actionPerformedHolder := nil asValueHolder.
	askBeforeChangingHolder := false asValueHolder.
	shortcutHolder := nil asValueHolder.
	
	labelHolder whenChangedDo: [ self changed: #label ].
	fontHolder whenChangedDo: [ self changed: #font ].
	iconHolder whenChangedDo: [ self changed: #label ].
	stateHolder whenChangedDo: [ self changed: #state ].
	askBeforeChangingHolder whenChangedDo: [:newValue | self changed: { #askBeforeChanging: . newValue} ].
	shortcutHolder whenChangedDo: [ :newShortcut :oldShortcut |
		self unregisterShortcut: oldShortcut.
		self registerShortcut: newShortcut.
		self changed: #label ].
	
	menuHolder := MenuPresenter new asValueHolder.	
	menuHolder whenChangedDo: [ :aMenuModel :oldMenu | 
		(oldMenu isNil or: [ oldMenu isBlock ]) ifFalse: [ oldMenu neglect: self ].
		(aMenuModel isNil or: [ aMenuModel isBlock ]) ifFalse: [ aMenuModel applyTo: self ] ].
		
	self bindKeyCombination: Character space toAction: [ self action ].
	
	self color: nil.! !

!ButtonPresenter methodsFor: 'private' stamp: ''!
addShortcutTipFor: aString

	^ self 
		addShortcutTipFor: self shortcutCharacter
		on: aString! !

!ButtonPresenter methodsFor: 'private - focus' stamp: ''!
ensureKeyBindingsFor: widget

	super ensureKeyBindingsFor: widget.
	self shortcut ifNotNil: [ :s | self registerShortcut: s ]! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
label: aStringOrImageMorph
	"<api: #string getter: #label registration: #whenLabelChangedDo:>"

	labelHolder value: aStringOrImageMorph! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
shortcut: aShortcut

	shortcutHolder value: aShortcut! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
action
	"<api: #inspect>"
	"get the block performed when the button is clicked"

	^ actionHolder value! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
font: aFont

	fontHolder value: aFont! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
state: aBoolean
	"<api: #boolean getter: #state registration: #whenStateChangedDo:>"
	"set if the button is highlighted"
	
	^ stateHolder value: aBoolean! !

!ButtonPresenter methodsFor: 'api - events' stamp: ''!
whenActionChangedDo: aBlock 

	actionHolder whenChangedDo: aBlock! !

!ButtonPresenter methodsFor: 'api - events' stamp: ''!
whenFontChangedDo: aBlock
	"set a block to perform after that the button has been aclicked, and its action performed"

	fontHolder whenChangedDo: aBlock! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
menu

	^ menuHolder value! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
getAction
	"<api: #inspect>"
	"get the block performed when the button is clicked"

	^ actionHolder value! !

!ButtonPresenter methodsFor: 'morphic' stamp: ''!
state
	"<api: #inspect>"
	^ stateHolder value! !

!ButtonPresenter methodsFor: 'private' stamp: ''!
unregisterShortcut: oldShortcut
	| receiver |
	receiver := self window.
	(receiver isNil or: [ oldShortcut isNil ]) ifTrue: [ ^ self ].

	receiver model
		removeKeyCombination: oldShortcut ! !

!ButtonPresenter methodsFor: 'private' stamp: ''!
shortcutCharacter
	^ self shortcut ifNotNil: [ :s | s currentCharacter ]! !

!ButtonPresenter methodsFor: 'api - events' stamp: ''!
whenActionPerformedDo: aBlock
	"set a block to perform after that the button has been aclicked, and its action performed"

	actionPerformedHolder whenChangedDo: aBlock! !

!ButtonPresenter methodsFor: 'api' stamp: ''!
askBeforeChanging

	^ askBeforeChangingHolder value! !

!ButtonPresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new
		openWithSpec;
		label: 'Click me'! !

!ButtonPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(ButtonAdapter
		adapt: #(model))! !

!ButtonPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ButtonAdapter! !

!ButtonPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Button'! !

!ByteArray commentStamp: ''!
I represent an ArrayedCollection whose elements are integers between 0 and 255.

For further comments read comments of `WordArray`.!
!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbUInt64AtOffset: zeroBasedOffset put: value
	"Store unsigned 64-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order"
	^ self unsignedLongLongAt: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
floatAt: index bigEndian: boolean 
	^ Float
		fromIEEE32Bit: (self unsignedLongAt: index bigEndian: boolean)! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
signedLongAt: byteIndex put: value
	^ self int32AtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
doubleAt: byteIndex put: value
	^ self float64AtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
char16AtOffset: zeroBasedOffset
	<primitive: 611>
	^ (self integerAt: zeroBasedOffset + 1 size: 2 signed: false) asCharacter! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
int16AtOffset: zeroBasedOffset
	<primitive: 604>
	^ self integerAt: zeroBasedOffset + 1 size: 2 signed: true! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
uint64AtOffset: zeroBasedOffset
	<primitive: 607>
	^ self integerAt: zeroBasedOffset + 1 size: 8 signed: false! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
unsignedLongLongAt: byteIndex put: value
	^ self uint64AtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
voidAt: byteOffset put: value
	"no accessors for void"
	^self shouldNotImplement! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbInt32AtOffset: zeroBasedOffset
	"Reads signed 32-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self signedLongAt: zeroBasedOffset + 1! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
boolean8AtOffset: zeroBasedOffset put: value
	<primitive: 615>
	^ self integerAt: zeroBasedOffset + 1 put: (value ifTrue:[1] ifFalse:[0]) size: 1 signed: false! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
shortPointerAt: byteIndex put: value
	"Store a 4-byte pointer object at the given byte address"
	value isExternalAddress ifFalse:
		[^self error:'Only external addresses can be stored'].
	1 to: 4 do:
		[:i|
		self unsignedByteAt: byteIndex+i-1 put: (value basicAt: i)].
	^value! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbUInt32AtOffset: zeroBasedOffset  put: value
	"Store unsigned 32-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self unsignedLongAt: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
signedShortAt: byteIndex
	^ self int16AtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
char8AtOffset: zeroBasedOffset put: value
	<primitive: 625>
	^ self integerAt: zeroBasedOffset + 1 put: value asInteger size: 1 signed: false! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
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: '*UnifiedFFI' stamp: ''!
signedByteAt: byteOffset put: value
	"Store a 8bit signed integer starting at the given byte offset"
	^self integerAt: byteOffset put: value size: 1 signed: true! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
float64AtOffset: zeroBasedOffset
	<primitive: 614>
	
	^ FFIBackend current on: self float64At: zeroBasedOffset + 1! !

!ByteArray methodsFor: '*Network-Kernel' stamp: ''!
asSocketAddress
	^SocketAddress fromOldByteAddress: self! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
shortPointerAt: byteIndex
	"Answer a 4-byte pointer object stored at the given byte address"
	| addr |
	addr := ExternalAddress basicNew: 4.
	1 to: 4 do:
		[:i|
		addr basicAt: i put: (self unsignedByteAt: byteIndex+i-1)].
	^addr! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
pointerAtOffset: zeroBasedOffset put: value
	<primitive: 624>
	"Store a pointer object at the given byte address"
	value isExternalAddress ifFalse:
		[^self error:'Only external addresses can be stored'].
	1 to: ExternalAddress wordSize do:
		[:i|
		self unsignedByteAt: zeroBasedOffset+i put: (value basicAt: i)].
	^value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
unsignedByteAt: byteIndex
	^ self uint8AtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
signedCharAt: byteIndex put: aCharacter
	^ self char8AtOffset: byteIndex - 1 put: aCharacter! !

!ByteArray methodsFor: '*Network-MIME' stamp: ''!
base64Encoded
	"Encode the receiver using Base64, returning a String.
	Base64 encoding is a technique to represent binary data as ASCII text.
	The inverse operation is String>>#base64Decoded"
	
	"(0 to: 255) asByteArray base64Encoded"
	"(Integer primesUpTo: 255) asByteArray base64Encoded"
	"'Hello World!!' utf8Encoded base64Encoded"
	
	^ ZnBase64Encoder new encode: self! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
platformLongAt: byteOffset put: value
	self 
		integerAt: byteOffset
		put: value
		size: FFIArchitecture forCurrentArchitecture longTypeSize
		signed: true! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
pointerAt: byteIndex put: value
	^ self pointerAtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: 'private' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	replacement isString
		ifFalse:
			[super replaceFrom: start to: stop with: replacement startingAt: repStart]
		ifTrue:
			[ "use String>>byteAt: to mimic prim 105"
			| index repOff |
			repOff := repStart - start.
			index := start - 1.
			[(index := index + 1) <= stop]
				whileTrue: [self at: index put: (replacement byteAt: repOff + index)]]! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbUInt8AtOffset: zeroBasedOffset
	"Reads unsigned 8-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self unsignedByteAt: zeroBasedOffset + 1! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
boolean8AtOffset: zeroBasedOffset
	<primitive: 600>
	^ (self integerAt: zeroBasedOffset + 1 size: 1 signed: false) ~= 0! !

!ByteArray methodsFor: '*Zinc-Character-Encoding-Core' stamp: ''!
decodeWith: encoding
	"Produce a String that decodes the receiver, using a specified encoding.
	Encoding is either a ZnCharacterEncoder instance or an identifier for one."
	
	"#[76 101 115 32 195 169 108 195 168 118 101 115 32 102 114 97 110 195 167 97 105 115] decodeWith: #utf8"
	
	^ encoding asZnCharacterEncoder decodeBytes: self! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
doubleAt: byteIndex
	^ self float64AtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
integerAt: byteOffset size: nBytes signed: aBoolean

	^ FFIBackend current
		  integerOfObject: self
		  at: byteOffset
		  size: nBytes
		  signed: aBoolean! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbFloat32AtOffset: zeroBasedOffset put: value
	"Store 32-bit float at ZERO-based index."
	^ self floatAt: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
signedLongAt: byteIndex
	^ self int32AtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbUlongAt: index put: value
	"Store unsigned long at one-based index."
	^ self unsignedLongAt: index put: value	! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
signedShortAt: byteIndex put: value
	^ self int16AtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
uint8AtOffset: zeroBasedOffset
	<primitive: 601>
	^ self integerAt: zeroBasedOffset + 1 size: 1 signed: false! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
int16AtOffset: zeroBasedOffset put: value
	<primitive: 619>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 2 signed: true! !

!ByteArray methodsFor: 'accessing' stamp: ''!
byteAt: index
	<primitive: 60>
	^self at: index! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbInt16AtOffset: zeroBasedOffset
	"Reads signed 16-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self signedShortAt: zeroBasedOffset + 1! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
platformUnsignedLongAt: byteOffset put: value
	self 
		integerAt: byteOffset
		put: value
		size: FFIArchitecture forCurrentArchitecture longTypeSize 
		signed: false! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
float32AtOffset: zeroBasedOffset put: value
	<primitive: 628>
	
	^ FFIBackend current on: self float32At: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
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: '*FFI-Kernel' stamp: ''!
signedLongLongAt: byteIndex
	^ self int64AtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
float64AtOffset: zeroBasedOffset put: value

	<primitive: 629>
	^ FFIBackend current
		  on: self
		  float64At: zeroBasedOffset + 1
		  put: value! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
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: '*FFI-Kernel' stamp: ''!
booleanAt: byteIndex
	"Returns the boolean the byte at index byteOffset of this ByteArray represents in the C convention ( A byte representing the 0 integer corresponds to false, while all other integers corresponds to true)."
	
	"(#[1 2 0 4] booleanAt: 2) >>> true."
	"(#[1 2 0 4] booleanAt: 3) >>> false."
	
	^ self boolean8AtOffset: byteIndex - 1! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
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: '*UnifiedFFI' stamp: ''!
platformUnsignedLongAt: byteOffset
	^ self 
		integerAt: byteOffset 
		size: FFIArchitecture forCurrentArchitecture longTypeSize
		signed: false! !

!ByteArray methodsFor: 'printing' stamp: ''!
hexDumpOn: aStream max: maxBytes
	"Print a hex dump of the receiver on the supplied stream, up to maxBytes long"

	| ch i string remainder |

	i := 0.
	self readStreamDo: [ :stream |
		ch := stream next.
		[ch notNil and: [ i < maxBytes ]] whileTrue: [ 
			remainder := i \\ 16.
			remainder = 0 ifTrue: [ 
				i = 0 ifFalse: [ aStream cr ].
				aStream 
					<< (i printPaddedWith: $0 to: 8 base: 16);
					<< '  '.
				string := String new writeStream ].
			ch printHexByteOn: aStream.
			aStream space.
			(ch between: 32 and: 126) ifTrue: 
				[ string nextPut: (Character value: ch) ]
			ifFalse:
				[ string nextPut: $. ].
			remainder = 15 ifTrue: [ 
				aStream
					<< '  |';
					<< string contents;
					<< '|' ].
			ch := stream next.
			i := i + 1 ].
		remainder := i \\ 16.
		(ch isNil and: [remainder between: 1 and: 15]) ifTrue: [ 
			(16 - remainder) timesRepeat: [ aStream nextPutAll: '   ' ].
			aStream
				<< '  |';
				<< string contents.
			(16 - remainder timesRepeat: [ aStream nextPut: Character space ]).
			aStream
				<< '|' ].
		aStream cr.
		self size > maxBytes ifTrue: 
			[ aStream nextPutAll: '  ... truncated ...'; cr ] ].! !

!ByteArray methodsFor: '*System-Hashing-Core' stamp: ''!
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: 'accessing' stamp: ''!
atAllPut: value
	"Fill the receiver with the given value"

	<primitive: 145>
	super atAllPut: value! !

!ByteArray methodsFor: 'initialization' stamp: ''!
readHexFrom: characterReadStream
	"Initialize the receiver from a hexadecimal representation."
	
	1 to: self size do: [ :offset |
		self at: offset put: (Integer readHexByteFrom: characterReadStream) ]! !

!ByteArray methodsFor: '*System-Hashing-Core' stamp: ''!
destroy
	1 to: self size do: 
		[ : x |
		self at: x put: 0 ]! !

!ByteArray methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"Use a hex representation"
	
	stonWriter writeObject: self listSingleton: self hex! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
unsignedByteAt: byteIndex put: value
	^ self uint8AtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	self pinInMemory.
	^ PointerUtils oopForObject: self
! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
floatAt: byteIndex
	^ self float32AtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects 
	^ false! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
platformBitAt: byteOffset

	^ self 
		integerAt: byteOffset 
		size: FFIArchitecture forCurrentArchitecture bitTypeSize 
		signed: true! !

!ByteArray methodsFor: 'testing' stamp: ''!
isLiteral
	"so that #(1 #[1 2 3] 5) prints itself"
	""
	^ self class == ByteArray! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
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: 'accessing' stamp: ''!
byteAt: index put: value
	<primitive: 61>
	^self at: index put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
uint64AtOffset: zeroBasedOffset put: value
	<primitive: 622>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 8 signed: false! !

!ByteArray methodsFor: 'converting' stamp: ''!
hex
	"Answer a lowercase hexadecimal String representation of the receiver"
		
	^ String
		new: self size * 2
		streamContents: [ :out |
			self do: [ :each | each printLowercaseHexByteOn: out ] ]! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
unpackHandleFromArity: arity
	"This will 'unpack' a long (handle) from a certain arity. See #packToArity: for a better explanation."

	arity > 1 ifTrue: [ ^ self error: 'Use ExternalAddress instead!!' ].
	^ self unsignedLongAt: 1
! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
platformUnsignedBitAt: byteOffset

	^ self 
		integerAt: byteOffset 
		size: FFIArchitecture forCurrentArchitecture bitTypeSize 
		signed: false! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
isNull
	"Answer false since only external addresses can be null"
	^false! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbUInt8AtOffset: zeroBasedOffset put: value
	"Store unsigned 8-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self unsignedByteAt: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbUlongAt: index
	"Read unsigned long at one-based index."
	^ self unsignedLongAt: index! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
floatAt: byteIndex put: value
	^ self float32AtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: 'converting' stamp: ''!
asString
	"Convert to a String with Characters for each byte.
	Fast code uses primitive that avoids character conversion"

	^ (String new: self size) replaceFrom: 1 to: self size with: self! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbLongAt: index put: value
	"Store signed long at one-based index"
	^ self signedLongAt: index put: value! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
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: 'accessing' stamp: ''!
indexOf: anInteger startingAt: start

	(anInteger isInteger and: [ anInteger between: 0 and: 255 ]) ifFalse: [ ^0 ].
	^ByteString indexOfAscii: anInteger inString: self startingAt: start! !

!ByteArray methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream nextPutAll: '#['.
	self
		do: [ :each | each storeOn: aStream ]
		separatedBy: [ aStream nextPut: $ ].
	aStream nextPut: $]! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
char32AtOffset: zeroBasedOffset put: value
	<primitive: 627>
	^ self integerAt: zeroBasedOffset + 1 put: value asInteger size: 4 signed: false! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
uint32AtOffset: zeroBasedOffset
	<primitive: 605>
	^ self integerAt: zeroBasedOffset + 1 size: 4 signed: false! !

!ByteArray methodsFor: 'converting' stamp: ''!
asByteArray
	^ self! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
platformUnsignedBitAt: byteOffset put: value
	
	self 
		integerAt: byteOffset
		put: value
		size: FFIArchitecture forCurrentArchitecture bitTypeSize
		signed: false! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
referenceStructAt: byteOffset length: length
	^ FFIExternalStructureReferenceHandle 
		handle: self 
		offset: byteOffset! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
signedByteAt: byteOffset
    "Return a 8bit signed integer starting at the given byte offset"
    ^self integerAt: byteOffset size: 1 signed: true! !

!ByteArray methodsFor: 'comparing' stamp: ''!
hash
	"#hash is implemented, because #= is implemented"

	^self class
		hashBytes: self
		startingWith: self species hash! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
structAt: byteOffset length: length
	"Return a structure of the given length starting at the indicated byte offset."
	| value |
	value := ByteArray new: length.
	1 to: length do:[:i|
		value unsignedByteAt: i put: (self unsignedByteAt: byteOffset+i-1)].
	^value! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
writeString: aString
	LibC memCopy: aString to: self size: aString size! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
int32AtOffset: zeroBasedOffset
	<primitive: 606>
	^ self integerAt: zeroBasedOffset + 1 size: 4 signed: true! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
packAsDoubleToArity: arity
	"In case I sending a buffer to get the contents I need to understand this message. 
	 See AthensCairoCanvas>>getCurrentPoint as an example."
	^ self packToArity: arity ! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbUInt16AtOffset: zeroBasedOffset put: value
	"Store unsigned 16-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order"
	^ self unsignedShortAt: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: 'accessing' stamp: ''!
byteSize
	^self size! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
structAt: byteOffset put: value length: length
	"Store a structure of the given length starting at the indicated byte offset."
	1 to: length do:[:i|
		self unsignedByteAt: byteOffset+i-1 put: (value unsignedByteAt: i)].
	^value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
unsignedCharAt: byteIndex put: aCharacter
	^ self char8AtOffset: byteIndex - 1 put: aCharacter! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbFloat64AtOffset: zeroBasedOffset
	"Read 64-bit float at ZERO-based index."
	^ self doubleAt: zeroBasedOffset + 1! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbInt16AtOffset: zeroBasedOffset put: value
	"Store signed 16-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self signedShortAt: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
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: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitBytesObject: self! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
unsignedLongLongAt: byteIndex
	^ self uint64AtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
platformBitAt: byteOffset put: value
	
	self 
		integerAt: byteOffset
		put: value
		size: FFIArchitecture forCurrentArchitecture bitTypeSize
		signed: true! !

!ByteArray methodsFor: '*System-Hashing-Core' stamp: ''!
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: '*FFI-Kernel' stamp: ''!
char32AtOffset: zeroBasedOffset
	<primitive: 612>
	^ (self integerAt: zeroBasedOffset + 1 size: 4 signed: false) asCharacter! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
packAsFloatToArity: arity
	"In case I sending a buffer to get the contents I need to understand this message. 
	 See AthensCairoCanvas>>getCurrentPoint as an example."
	^ self packToArity: arity ! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
char16AtOffset: zeroBasedOffset put: value
	<primitive: 626>
	^ self integerAt: zeroBasedOffset + 1 put: value asInteger size: 2 signed: false! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
uint32AtOffset: zeroBasedOffset put: value
	<primitive: 620>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 4 signed: false! !

!ByteArray methodsFor: 'private' stamp: ''!
asByteArrayPointer
	"Return a ByteArray describing a pointer to the contents of the receiver."
	^self shouldNotImplement! !

!ByteArray methodsFor: '*Zinc-Character-Encoding-Core' stamp: ''!
utf8Decoded
	"Produce a String decoding the receiver using UTF-8,
	the recommended encoding for Strings, unless you know what you are doing."

	"#[76 101 115 32 195 169 108 195 168 118 101 115 32 102 114 97 110 195 167 97 105 115] utf8Decoded"
	
	^ self decodeWith: ZnCharacterEncoder utf8! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbInt64AtOffset: zeroBasedOffset put: value
	"Store signed 64-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self signedLongAt: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
float32AtOffset: zeroBasedOffset
	<primitive: 613>

	^ FFIBackend current on: self float32At: zeroBasedOffset + 1! !

!ByteArray methodsFor: '*Compression' stamp: 'nil'!
unzipped
	"Assuming the receiver contains GZIP compressed data, 
	return a ByteArray with the decompressed data."
	
	"#[31 139 8 0 0 0 0 0 0 0 99 100 98 6 0 29 128 188 85 3 0 0 0] unzipped >>> #[1 2 3]"

	^ (GZipReadStream on: self) upToEnd! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbFloat64AtOffset: zeroBasedOffset put: value
	"Store 64-bit float at ZERO-based index."
	^ self doubleAt: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
longPointerAt: byteIndex
	"Answer an 8-byte pointer object stored at the given byte address"
	| addr |
	addr := ExternalAddress basicNew: 8.
	1 to: 8 do:
		[:i|
		addr basicAt: i put: (self unsignedByteAt: byteIndex+i-1)].
	^addr! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
asExternalPointer
	"Convert the receiver assuming that it describes a pointer to an object."
	^ self pointerAt: 1! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
uint16AtOffset: zeroBasedOffset
	<primitive: 603>
	^ self integerAt: zeroBasedOffset + 1 size: 2 signed: false! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
packToArity: arity
	"This is complicated... I assuming this ways of calling a function: 
	 
   arity == 1: 
	-----------
	ByteArray works as pointer buffer of single pointer to something: 
	ex 1)
		buffer := ByteArray new: 4.
		self ffiCall: #( void function (int *buffer) ).
	ex 2)
		buffer := 'Hello, World' asByteArray.
		self ffiCall: #( void function (char *buffer) ).
	
	arity > 1: 
	----------
	ByteArray works as pointer to allocate results:
	ex 1)
		pointer := ByteArray new: (FFIExternalType pointerSize).
		self ffiCall: #( void function ( char **answer )).
	   
	In this case this will not work fine because content of ByteArray needs to be a 
	pointer too, and then it needs to be allocated in the heap... while this could be 
	managed, I'm puting for the moment just an error and a recommendation of using an 
	ExternalAddress.
	"
	arity = 1 ifTrue: [ ^ self ].
	self error: 'Use ExternalAddress instead!!'! !

!ByteArray methodsFor: 'private' stamp: ''!
defaultElement

	^0! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
int8AtOffset: zeroBasedOffset put: value
	<primitive: 617>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 1 signed: true! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
uint16AtOffset: zeroBasedOffset put: value
	<primitive: 618>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 2 signed: false! !

!ByteArray methodsFor: 'printing' stamp: ''!
printHexOn: characterWriteStream
	"Print a hexadecimal representation of the receiver on characterWriteStream
	using exactly 2 characters for each byte"

	self do: [ :each | each printHexByteOn: characterWriteStream ]! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
isExternalAddress
	"Return true if the receiver describes the address of an object in the outside world"
	^false! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
int32AtOffset: zeroBasedOffset put: value
	<primitive: 621>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 4 signed: true! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
signedLongLongAt: byteIndex put: value
	^ self int64AtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
unsignedCharAt: byteIndex
	^ self char8AtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbLongAt: index
	"Read signed long at one-based index"
	^ self signedLongAt: index! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbUInt16AtOffset: zeroBasedOffset
	"Reads unsigned 16-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order"
	^ self unsignedShortAt: zeroBasedOffset + 1! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
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: '*UnifiedFFI-Legacy' stamp: ''!
nbInt8AtOffset: zeroBasedOffset
	"Reads signed 8-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self signedByteAt: zeroBasedOffset + 1! !

!ByteArray methodsFor: 'streaming' stamp: ''!
putOn: aStream
	"Write the receiver onto aStream by iterating over its elements.
	In general we assume aStream accepts the receiver's elements as element type.
	This is an optimisation.
	Return self."

	aStream nextPutAll: self! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
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: '*UnifiedFFI' stamp: ''!
platformSizeTAt: byteOffset put: value
	self 
		integerAt: byteOffset
		put: value
		size: FFIArchitecture forCurrentArchitecture sizeTTypeSize
		signed: false! !

!ByteArray methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: '#['.
	self
		do: [ :each | each printOn: aStream ]
		separatedBy: [ aStream nextPut: $ ].
	aStream nextPut: $]! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
voidAt: byteOffset
	"no accessors for void"
	^self shouldNotImplement! !

!ByteArray methodsFor: '*Compression' stamp: 'nil'!
zipped
	"Return a ByteArray containing a GZIP compressed version of the receiver"
	
	"#[ 1 2 3 ] zipped >>> #[31 139 8 0 0 0 0 0 0 0 99 100 98 6 0 29 128 188 85 3 0 0 0]"

	^ ByteArray streamContents: [ :out | 
		(GZipWriteStream on: out)
			nextPutAll: self;
			close ]! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
signedCharAt: byteOffset
	^ self char8AtOffset: byteOffset - 1! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbUInt32AtOffset: zeroBasedOffset
	"Reads unsigned 32-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self unsignedLongAt: zeroBasedOffset + 1! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbInt8AtOffset: zeroBasedOffset put: value
	"Store signed 8-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order"
	^ self signedByteAt: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: '*Compression' stamp: 'nil'!
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: 'converting' stamp: ''!
asWideString

	^ WideString fromByteArray: self.! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
int64AtOffset: zeroBasedOffset put: value
	<primitive: 623>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 8 signed: true! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
int64AtOffset: zeroBasedOffset
	<primitive: 608>
	^ self integerAt: zeroBasedOffset + 1 size: 8 signed: true! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbInt64AtOffset: zeroBasedOffset
	"Reads signed 64-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self signedLongAt: zeroBasedOffset + 1! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
pointerAt: byteIndex
	^ self pointerAtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbInt32AtOffset: zeroBasedOffset put: value
	"Store signed 32-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self signedLongAt: zeroBasedOffset + 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
booleanAt: byteIndex put: value
	^ self boolean8AtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
pointerAtOffset: zeroBasedOffset
	<primitive: 609>
	"Answer a pointer object stored at the given byte address"
	| addr |
	addr := ExternalAddress new.
	1 to: ExternalAddress wordSize do:
		[:i|
		addr basicAt: i put: (self unsignedByteAt: zeroBasedOffset+i)].
	^addr! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
longPointerAt: byteIndex put: value
	"Store an 8-byte pointer object at the given byte address"
	value isExternalAddress ifFalse:
		[^self error:'Only external addresses can be stored'].
	1 to: 8 do:
		[:i|
		self unsignedByteAt: byteIndex+i-1 put: (value basicAt: i)].
	^value! !

!ByteArray methodsFor: '*System-Hashing-Core' stamp: ''!
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: '*FFI-Kernel' stamp: ''!
unsignedShortAt: byteIndex
	^ self uint16AtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbFloat32AtOffset: zeroBasedOffset
	"Read 32-bit float at ZERO-based index."
	^ self floatAt: zeroBasedOffset + 1! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
unsignedShortAt: byteIndex put: value
	^ self uint16AtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
unsignedLongAt: byteIndex put: value
	^ self uint32AtOffset: byteIndex - 1 put: value! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
readStringUTF8
	^ (ExternalData fromHandle: self type: ExternalType string) readStringUTF8.! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
integerAt: byteOffset put: value size: nBytes signed: aBoolean

	^ FFIBackend current
		  integerOfObject: self
		  at: byteOffset
		  put: value
		  size: nBytes
		  signed: aBoolean! !

!ByteArray methodsFor: 'platform independent access' stamp: ''!
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: '*UnifiedFFI' stamp: ''!
platformLongAt: byteOffset
	^ self 
		integerAt: byteOffset 
		size: FFIArchitecture forCurrentArchitecture longTypeSize 
		signed: true! !

!ByteArray methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
nbUInt64AtOffset: zeroBasedOffset
	"Reads unsigned 64-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order."
	^ self unsignedLongLongAt: zeroBasedOffset + 1! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
platformSizeTAt: byteOffset
	^ self 
		integerAt: byteOffset 
		size: FFIArchitecture forCurrentArchitecture sizeTTypeSize
		signed: false! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
uint8AtOffset: zeroBasedOffset put: value
	<primitive: 616>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 1 signed: false! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
unsignedLongAt: byteIndex
	^ self uint32AtOffset: byteIndex - 1! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
char8AtOffset: zeroBasedOffset
	<primitive: 610>
	^ (self integerAt: zeroBasedOffset + 1 size: 1 signed: false) asCharacter! !

!ByteArray methodsFor: '*UnifiedFFI' stamp: ''!
readString
	^ (ExternalData fromHandle: self type: ExternalType string) readString! !

!ByteArray methodsFor: '*FFI-Kernel' stamp: ''!
int8AtOffset: zeroBasedOffset
	<primitive: 602>
	^ self integerAt: zeroBasedOffset + 1 size: 1 signed: true! !

!ByteArray class methodsFor: 'byte based hash' stamp: ''!
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 |
	<primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'>

	<var: #aHash declareC: 'int speciesHash'>
	<var: #aByteArray declareC: 'unsigned char *aByteArray'>

	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: ''!
readHexFrom: aString
	"Create a byte array from a hexadecimal representation"
	^(self new: aString size // 2) readHexFrom: aString readStream! !

!ByteArray class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Use a hex representation"
	
	^ self readHexFrom: stonReader parseListSingleton! !

!ByteArrayTest commentStamp: ''!
SUnit tests for ByteArray!
!ByteArrayTest methodsFor: 'tests' stamp: ''!
testHex
	self assert: #[122 43 213 7] hex equals: '7a2bd507'.
	self
		assert: #[151 193 242 221 249 32 153 72 179 41 49 154 48 193 99 134] hex
		equals: '97c1f2ddf9209948b329319a30c16386'.
	self
		assert: (ByteArray readHexFrom: '7A2BD507')
		equals: #[122 43 213 7].
	self
		assert: (ByteArray readHexFrom: '7a2bd507')
		equals: #[122 43 213 7]! !

!ByteArrayTest methodsFor: 'tests' stamp: ''!
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: ''!
testindexOfStartingAt
	|array|
	array := #[1 2 3 4 5 6 7 8 9 10 11 1 2 3 4 5 6 7 8 0 0].
	self assert: (array indexOf: 1 startingAt: 10) equals: 12.
	self assert: (array indexOf: 17 startingAt: 10) equals: 0.! !

!ByteArrayTest methodsFor: 'tests' stamp: ''!
testHexDumponmax

	| source display expected |

	source := '01234567890123456789'.
	display := String streamContents: [ :stream |
		source asByteArray hexDumpOn: stream max: 1000 ].
	expected := '00000000  30 31 32 33 34 35 36 37 38 39 30 31 32 33 34 35   |0123456789012345|
00000010  36 37 38 39                                       |6789            |
'.
	self assert: display equals: expected! !

!ByteArrayTest methodsFor: 'tests' stamp: ''!
testFallbackReplaceFromToWithForString
	| testString byteArray stringByteSize |
	testString := 'Test string'.
	stringByteSize := 'Test string' byteSize.
	byteArray := ByteArray new: stringByteSize.
	
	self
		shouldnt: [
			byteArray
				replaceFrom: 1
				to: stringByteSize
				with: testString
				startingAt: 1 ]
		raise: Exception
		description: 'Primitive 105 should be optional for ByteArray'! !

!ByteArrayTest methodsFor: 'tests' stamp: ''!
testFallbackReplaceFromToWithForWideString
	| testString byteArray stringByteSize |
	testString := 'Test string' asWideString.
	stringByteSize := 'Test string' byteSize.
	byteArray := ByteArray new: stringByteSize.
	
	self
		shouldnt: [
			byteArray
				replaceFrom: 1
				to: stringByteSize
				with: testString
				startingAt: 1 ]
		raise: Exception
		description: 'Primitive 105 should be optional for ByteArray'! !

!ByteArrayTest methodsFor: 'tests' stamp: ''!
testFourthByteArraysReturnTheCorrectValues
	
	self assert: (#[16r3F 16r80 0 0]  floatAt:1 bigEndian: true) equals: 1.0.
	self assert: (#[16rC0 0 0 0]  floatAt:1 bigEndian: true) equals: -2.0.! !

!ByteArrayTest methodsFor: 'tests' stamp: ''!
testBooleanAt
	"Checking the result of ByteArray>>#booleanAt on a few instances of ByteArray. It should return false on 0-valued bytes and true on all other bytes (according to the integer to boolean C convention)."

	self deny: (#[0] booleanAt: 1).
	self assert: (#[1] booleanAt: 1).
	self assert: (#[255 2 3] booleanAt: 1).
	self deny: (#[0 25] booleanAt: 1).
	self assert: (#[255] booleanAt: 1).! !

!ByteLayout commentStamp: ''!
I am a raw data layout that holds bytes (8 bits).!
!ByteLayout methodsFor: 'accessing' stamp: ''!
bytesPerSlot
	
	^ 1! !

!ByteLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	^ 16! !

!ByteLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGByteLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)]
! !

!ByteLayout methodsFor: 'testing' stamp: ''!
isBytes
	^ true! !

!ByteLayout methodsFor: 'extending' stamp: ''!
extendByte
	^ ByteLayout new! !

!ByteLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else!!"
	^#variableByteSubclass:! !

!ByteLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass
	^ superLayout extendByte
		host: aClass;
		yourself! !

!ByteLayout class methodsFor: '*Monticello' stamp: 'nil'!
mcTypeSymbol 
	^ #bytes! !

!ByteString commentStamp: ''!
This class represents the array of 8 bit wide characters.
!
!ByteString methodsFor: 'converting' stamp: ''!
asByteArray

	| ba sz |
	sz := self byteSize.
	ba := ByteArray new: sz.
	ba replaceFrom: 1 to: sz with: self startingAt: 1.
	^ba! !

!ByteString methodsFor: 'accessing' stamp: ''!
byteAt: index
	<primitive: 60>
	^(self at: index) asciiValue! !

!ByteString methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
asKeyCombination
	self size > 1 
		ifTrue: [ self error: 'Shortcuts only take a single letter'].
	^ KMSingleKeyCombination from: self first! !

!ByteString methodsFor: 'accessing' stamp: ''!
byteAt: index put: value
	<primitive: 61>
	self at: index put: value asCharacter.
	^value! !

!ByteString methodsFor: '*Text-Scanning' stamp: ''!
scanCharactersFrom: startIndex to: stopIndex with: aCharacterScanner rightX: rightX  font: aFont
	"NB: strongly consider getting almost all these parameters from the scanner"
	"Since I'm a byte char string, I know that we have to scan single-byte characters and don't have to handle encodings etc"
	startIndex > stopIndex
		ifTrue: [^aCharacterScanner handleEndOfRunAt: stopIndex].
	^aFont scanByteCharactersFrom: startIndex to: stopIndex in: self with: aCharacterScanner rightX: rightX! !

!ByteString methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 64>
	aCharacter isCharacter 
		ifFalse:[^self errorImproperStore].
	aCharacter isOctetCharacter ifFalse:[
		"Convert to WideString"
		self becomeForward: (WideString from: self).
		^self at: index put: aCharacter.
	].
	index isInteger
		ifTrue: [ (index between: 1 and: self size)
				ifFalse: [ self errorSubscriptBounds: index ] ]
		ifFalse: [self errorNonIntegerIndex].
	self isReadOnlyObject 
		ifTrue: [ ^ self modificationForbiddenFor: #at:put: index: index value: aCharacter ].! !

!ByteString methodsFor: 'converting' stamp: ''!
asOctetString

	^ self! !

!ByteString methodsFor: 'accessing' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	replacement class == WideString ifTrue: [
		self becomeForward: (WideString from: self).
	]. 

	super replaceFrom: start to: stop with: replacement startingAt: repStart.! !

!ByteString methodsFor: 'accessing' stamp: ''!
byteSize
	^self size! !

!ByteString methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitHookPrimitive: self! !

!ByteString methodsFor: 'testing' stamp: ''!
isAsciiString

	^ (self class
		   findFirstInString: self
		   inSet: NonAsciiMap
		   startingAt: 1) = 0! !

!ByteString methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 63>
	^ Character value: (super at: index)! !

!ByteString methodsFor: 'testing' stamp: ''!
isByteString
	"Answer whether the receiver is a ByteString"

	"'abc' isByteString >>> true"

	^ true! !

!ByteString methodsFor: 'testing' stamp: ''!
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)"

	"'abc' isOctetString >>> true"

	^ true! !

!ByteString methodsFor: 'comparing' stamp: ''!
findSubstring: key in: body startingAt: start matchTable: matchTable
	
	^ key findIn: body startingAt: start matchTable: matchTable.! !

!ByteString methodsFor: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	self pinInMemory.
	^ PointerUtils oopForObject: self
! !

!ByteString methodsFor: 'accessing' stamp: ''!
indexOfAnyOf: aCollection startingAt: start
	"Use double dispatching for speed"
	^aCollection findFirstInByteString: self startingAt: start! !

!ByteString methodsFor: 'testing' stamp: ''!
hasWideCharacterFrom: start to: stop
	"Only WideStrings contain these characters"

	^ false! !

!ByteString methodsFor: '*Fuel-Core' stamp: ''!
serializeOn: anEncoder

	anEncoder encodeString: self! !

!ByteString methodsFor: 'accessing' stamp: ''!
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 class methodsFor: 'class initialization' stamp: ''!
initialize

	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: ''!
translate: aString from: start  to: stop  table: table
	"translate the characters in the string by the given table, in place"
	<primitive: 'primitiveTranslateStringWithTable' module: 'MiscPrimitivePlugin'>
	<var: #table  declareC: 'unsigned char *table'>
	<var: #aString  declareC: 'unsigned char *aString'>

	start to: stop do: [ :i |
		aString at: i put: (table at: (aString basicAt: i) + 1) ]! !

!ByteString class methodsFor: '*Fuel-Core' stamp: ''!
materializeFrom: aDecoder

	^ aDecoder nextEncodedString! !

!ByteString class methodsFor: 'primitives' stamp: ''!
indexOfAscii: anInteger inString: aString startingAt: start

	| stringSize |
	<primitive: 'primitiveIndexOfAsciiInString' module: 'MiscPrimitivePlugin'>
	<var: #aCharacter declareC: 'int anInteger'>
	<var: #aString declareC: 'unsigned char *aString'>

	stringSize := aString size.
	start to: stringSize do: [:pos |
		(aString basicAt: pos) = anInteger ifTrue: [^ pos]].

	^ 0! !

!ByteString class methodsFor: 'primitives' stamp: ''!
findFirstInString: aString  inSet: inclusionMap  startingAt: start

	| i stringSize |
	<primitive: 'primitiveFindFirstInString' module: 'MiscPrimitivePlugin'>
	<var: #aString declareC: 'unsigned char *aString'>
	<var: #inclusionMap  declareC: 'char *inclusionMap'>

	inclusionMap size ~= 256 ifTrue: [ ^0 ].

	i := start.
	stringSize := aString size.
	[ i <= stringSize and: [ (inclusionMap at: (aString basicAt: i) + 1) = 0 ] ] whileTrue: [ 
		i := i + 1 ].

	i > stringSize ifTrue: [ ^0 ].
	^i! !

!ByteString class methodsFor: 'primitives' stamp: ''!
stringHash: aString initialHash: speciesHash

	| stringSize hash low |
	<primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'>

	<var: #aHash declareC: 'int speciesHash'>
	<var: #aString declareC: 'unsigned char *aString'>

	stringSize := aString size.
	hash := speciesHash bitAnd: 16rFFFFFFF.
	1 to: stringSize do: [:pos |
		hash := hash + (aString basicAt: pos).
		"Begin hashMultiply"
		low := hash bitAnd: 16383.
		hash := (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF.
	].
	^ hash! !

!ByteString class methodsFor: 'abstract' stamp: ''!
nonAsciiMap

	^ NonAsciiMap! !

!ByteString class methodsFor: 'primitives' stamp: ''!
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."

	<primitive: 'primitiveCompareString' module: 'MiscPrimitivePlugin'>
	<var: #string1 declareC: 'unsigned char *string1'>
	<var: #string2 declareC: 'unsigned char *string2'>
	<var: #order declareC: 'unsigned char *order'>
	| 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 ]! !

!ByteSymbol commentStamp: ''!
This class represents the symbols containing 8bit characters.!
!ByteSymbol methodsFor: '*Keymapping-Core' stamp: ''!
asKmCategoryIn: aKmRepository
	^aKmRepository categoryForName: self! !

!ByteSymbol methodsFor: 'converting' stamp: ''!
asByteArray
	| ba sz |
	sz := self byteSize.
	ba := ByteArray new: sz.
	ba replaceFrom: 1 to: sz with: self startingAt: 1.
	^ba! !

!ByteSymbol methodsFor: 'accessing' stamp: ''!
byteAt: index
	<primitive: 60>
	^(self at: index) asciiValue! !

!ByteSymbol methodsFor: 'private' stamp: ''!
string: aString
	1 to: aString size do: [:j | 
		self privateAt: j put: (aString at: j)].
	^self! !

!ByteSymbol methodsFor: 'accessing' stamp: ''!
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: ''!
byteAt: anInteger put: anObject 
	"You cannot modify the receiver."
	^ self modificationForbiddenFor: #byteAt:put: index: anInteger value: anObject! !

!ByteSymbol methodsFor: '*Text-Scanning' stamp: ''!
scanCharactersFrom: startIndex to: stopIndex with: aCharacterScanner rightX: rightX  font: aFont
	"NB: strongly consider getting almost all these parameters from the scanner"
	"Since I'm a byte char string, I know that we have to scan single-byte characters and don't have to handle encodings etc"
	startIndex > stopIndex
		ifTrue: [^aCharacterScanner handleEndOfRunAt: stopIndex].
	^aFont scanByteCharactersFrom: startIndex to: stopIndex in: self with: aCharacterScanner rightX: rightX! !

!ByteSymbol methodsFor: 'converting' stamp: ''!
asOctetString
	^ self! !

!ByteSymbol methodsFor: 'accessing' stamp: ''!
species
	"Answer the preferred class for reconstructing the receiver."
	^ByteString! !

!ByteSymbol methodsFor: 'accessing' stamp: ''!
byteSize
	^self size! !

!ByteSymbol methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitHookPrimitive: self! !

!ByteSymbol methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 63>
	^ Character value: (super at: index)! !

!ByteSymbol methodsFor: 'testing' stamp: ''!
isByteString
	"Answer whether the receiver is a ByteString"
	^true! !

!ByteSymbol methodsFor: 'testing' stamp: ''!
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: 'comparing' stamp: ''!
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."
	<primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
	^super findSubstring: key in: body startingAt: start matchTable: matchTable! !

!ByteSymbol methodsFor: 'accessing' stamp: ''!
indexOfAnyOf: aCollection startingAt: start
	"Use double dispatching for speed"
	^aCollection findFirstInByteString: self startingAt: start! !

!ByteSymbol methodsFor: 'testing' stamp: ''!
hasWideCharacterFrom: start to: stop
	"Always false because I only contains byte characters"
	^false! !

!ByteSymbol methodsFor: '*Fuel-Core' stamp: ''!
serializeOn: anEncoder

	anEncoder encodeString: self! !

!ByteSymbol methodsFor: 'private' stamp: ''!
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."

	<primitive: 64>
	aCharacter isCharacter 
		ifFalse:[^self errorImproperStore].
	index isInteger
		ifTrue: [ (index between: 1 and: self size)
				ifFalse: [ self errorSubscriptBounds: index] ]
		ifFalse: [self errorNonIntegerIndex].
	self isReadOnlyObject 
		ifTrue: [ ^ self modificationForbiddenFor: #privateAt:put: index: index value: aCharacter ].! !

!ByteSymbol class methodsFor: 'primitives' stamp: ''!
translate: aString from: start  to: stop  table: table
	^ByteString translate: aString from: start  to: stop  table: table! !

!ByteSymbol class methodsFor: '*Fuel-Core' stamp: ''!
materializeFrom: aDecoder

	^ aDecoder nextEncodedString asSymbol! !

!ByteSymbol class methodsFor: 'primitives' stamp: ''!
indexOfAscii: anInteger inString: aString startingAt: start
	^ByteString indexOfAscii: anInteger inString: aString startingAt: start! !

!ByteSymbol class methodsFor: 'primitives' stamp: ''!
findFirstInString: aString inSet: inclusionMap startingAt: start
	^ByteString findFirstInString: aString  inSet: inclusionMap startingAt: start! !

!ByteSymbol class methodsFor: 'primitives' stamp: ''!
stringHash: aString initialHash: speciesHash
	^ByteString stringHash: aString initialHash: speciesHash! !

!ByteSymbolTest commentStamp: ''!
SUnit tests for byte symbols!
!ByteSymbolTest methodsFor: 'tests - creation' stamp: ''!
testAs
	| tStr |
	tStr := DateAndTime now asString.
	tStr as: ByteSymbol.
	self assert: (Symbol allSymbols select: [ :e | e asString = tStr ]) size equals: 1.
	self assert: (ByteSymbol allInstances select: [ :e | e asString = tStr ]) size equals: 1.
	self assert: (ByteSymbol allInstances select: [ :e | e asString = tStr ]) equals: (Symbol allSymbols select: [ :e | e asString = tStr ]).
	tStr as: ByteSymbol.
	self assert: (Symbol allSymbols select: [ :e | e asString = tStr ]) size equals: 1.
	self assert: (ByteSymbol allInstances select: [ :e | e asString = tStr ]) size equals: 1! !

!ByteSymbolTest methodsFor: 'tests - creation' stamp: ''!
testNewFrom
	| dt |
	dt := DateAndTime now asString.
	ByteSymbol newFrom: dt.
	self assert: (Symbol allSymbols select: [ :e | e asString = dt ]) size equals: 1.
	self assert: (ByteSymbol allInstances select: [ :e | e = dt ]) size equals: 1.
	self assert: (Symbol allSymbols select: [ :e | e asString = dt ]) equals: (ByteSymbol allInstances select: [ :e | e = dt ]).
	ByteSymbol newFrom: dt.
	self assert: (Symbol allSymbols select: [ :e | e asString = dt ]) size equals: 1.
	self assert: (ByteSymbol allInstances select: [ :e | e = dt ]) size equals: 1! !

!ByteSymbolTest methodsFor: 'tests - creation' stamp: ''!
testReadFromString
	| str strWithPound |
	Smalltalk garbageCollect.
	str := 'notYetExisting'.
	self assert: (Symbol allSymbols select: [ :e | e asString = str ]) size equals: 0.
	self assert: (ByteSymbol allInstances select: [ :e | e asString = str ]) size equals: 0.
	strWithPound := '#' , str.
	ByteSymbol readFromString: strWithPound.
	self assert: (Symbol allSymbols select: [ :e | e asString = str ]) size equals: 1.
	self assert: (ByteSymbol allInstances select: [ :e | e = str ]) size equals: 1.
	self assert: (Symbol allSymbols select: [ :e | e asString = str ]) equals: (ByteSymbol allInstances select: [ :e | e = str ]).
	ByteSymbol readFromString: strWithPound.
	self assert: (Symbol allSymbols select: [ :e | e asString = str ]) size equals: 1.
	self assert: (ByteSymbol allInstances select: [ :e | e = str ]) size equals: 1! !

!ByteSymbolTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ ByteSymbol! !

!ByteSymbolTest methodsFor: 'tests - non-creation' stamp: ''!
testNew
	
	self should: [ByteSymbol new: 5 ] raise: self defaultTestError.! !

!ByteTextConverter commentStamp: ''!
A ByteTextConverter is the abstract class for text converters on single byte encodings.!
!ByteTextConverter methodsFor: 'converting' stamp: ''!
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: 'converting' stamp: ''!
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: 'converting' stamp: ''!
unicodeToByte: unicodeChar

	^unicodeChar charCode < 128
		ifTrue: [unicodeChar]
		ifFalse: [self class unicodeToByteTable at: unicodeChar charCode ifAbsent: [0 asCharacter]]! !

!ByteTextConverter methodsFor: 'converting' stamp: ''!
nextPut: unicodeCharacter toStream: aStream
	"Write the unicode character to aStream."

	aStream isBinary
		ifTrue: [aStream basicNextPut: unicodeCharacter charCode]
		ifFalse: [aStream basicNextPut: (self unicodeToByte: unicodeCharacter)]! !

!ByteTextConverter class methodsFor: 'accessing' stamp: ''!
unicodeToByteTable
	"Return the table mapping from unicode to my byte based encoding"
	
	^ unicodeToByte! !

!ByteTextConverter class methodsFor: 'class initialization' stamp: ''!
initialize
	"ByteTextConverter initialize"

	self allSubclassesDo: [:subclass |
		subclass initializeTables]! !

!ByteTextConverter class methodsFor: 'class initialization' stamp: ''!
byteToUnicodeSpec
	"Specify 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: 'accessing' stamp: ''!
byteToUnicodeTable
	"Return the table mapping from my byte based encoding to unicode"
	
	^ byteToUnicode! !

!ByteTextConverter class methodsFor: 'class initialization' stamp: ''!
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 ]! !

!BytecodeEncoder commentStamp: ''!
I am an abstract superclass for different bytecode set encoders.  Subclasses inherit the literal management of Encoder and encapsulate the mapping of opcodes to specific bytecodes.!
!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeJumpLong: distance
	^self sizeOpcodeSelector: #genJumpLong: withArguments: {distance}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushTemp: tempIndex
	^self sizeOpcodeSelector: #genPushTemp: withArguments: {tempIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeTrapIfNotInstanceOf: litIndex 
	^ self sizeOpcodeSelector: #genTrapIfNotInstanceOf: withArguments: {litIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeStorePopInstVar: instVarIndex
	^self sizeOpcodeSelector: #genStorePopInstVar: withArguments: {instVarIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushThisProcess
	^self sizeOpcodeSelector: #genPushThisProcess withArguments: #()! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeStorePopRemoteTemp: tempIndex inVectorAt: tempVectorIndex
	^self sizeOpcodeSelector: #genStorePopRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushReceiver
	^self sizeOpcodeSelector: #genPushReceiver withArguments: #()! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeStoreRemoteTemp: tempIndex inVectorAt: tempVectorIndex
	^self sizeOpcodeSelector: #genStoreRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeStoreLiteralVar: literalIndex
	^self sizeOpcodeSelector: #genStoreLiteralVar: withArguments: {literalIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushRemoteTemp: tempIndex inVectorAt: tempVectorIndex
	^self sizeOpcodeSelector: #genPushRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
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: 'bytecode generation' stamp: ''!
genPushThisProcess
	"only available in Sista BC"! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeSend: selectorLiteralIndex numArgs: nArgs
	^self sizeOpcodeSelector: #genSend:numArgs: withArguments: {selectorLiteralIndex. nArgs}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushInstVar: instVarIndex
	^self sizeOpcodeSelector: #genPushInstVar: withArguments: {instVarIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeOpcodeSelector: genSelector withArguments: args
	stream := self.
	position := 0.
	self perform: genSelector withArguments: args.
	^position! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeReturnSpecialLiteral: specialLiteral
	^self sizeOpcodeSelector: #genReturnSpecialLiteral: withArguments: {specialLiteral}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushLiteral: literalIndex
	^self sizeOpcodeSelector: #genPushLiteral: withArguments: {literalIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeReturnReceiver
	^self sizeOpcodeSelector: #genReturnReceiver withArguments: #()! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeStoreInstVar: instVarIndex
	^self sizeOpcodeSelector: #genStoreInstVar: withArguments: {instVarIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeStorePopTemp: tempIndex
	^self sizeOpcodeSelector: #genStorePopTemp: withArguments: {tempIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeStoreTemp: tempIndex
	^self sizeOpcodeSelector: #genStoreTemp: withArguments: {tempIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushSpecialLiteral: specialLiteral
	^self sizeOpcodeSelector: #genPushSpecialLiteral: withArguments: {specialLiteral}! !

!BytecodeEncoder methodsFor: 'accessing' stamp: ''!
methodStreamPosition
	^stream position! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePop
	^self sizeOpcodeSelector: #genPop withArguments: #()! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushThisContext
	^self sizeOpcodeSelector: #genPushThisContext withArguments: #()! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushLiteralVar: literalIndex
	^self sizeOpcodeSelector: #genPushLiteralVar: withArguments: {literalIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeStorePopLiteralVar: literalIndex
	^self sizeOpcodeSelector: #genStorePopLiteralVar: withArguments: {literalIndex}! !

!BytecodeEncoder methodsFor: 'initialization' stamp: ''!
streamToMethod: aCompiledMethod
	stream := WriteStream with: aCompiledMethod.
	stream position: aCompiledMethod initialPC - 1! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeBranchPopTrue: distance
	^self sizeOpcodeSelector: #genBranchPopTrue: withArguments: {distance}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushConsArray: numElements
	^self sizeOpcodeSelector: #genPushConsArray: withArguments: {numElements}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeDup
	^self sizeOpcodeSelector: #genDup withArguments: #()! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushNewArray: size
	^self sizeOpcodeSelector: #genPushNewArray: withArguments: {size}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeSendSuper: selectorLiteralIndex numArgs: nArgs
	^self sizeOpcodeSelector: #genSendSuper:numArgs: withArguments: {selectorLiteralIndex. nArgs}! !

!BytecodeEncoder methodsFor: 'accessing' stamp: ''!
stream: s
	stream := s! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizePushInstVarLong: instVarIndex
	^self sizeOpcodeSelector: #genPushInstVarLong: withArguments: {instVarIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeJump: distance
	^self sizeOpcodeSelector: #genJump: withArguments: {distance}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeStoreInstVarLong: instVarIndex
	^self sizeOpcodeSelector: #genStoreInstVarLong: withArguments: {instVarIndex}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeStorePopInstVarLong: instVarIndex
	^self sizeOpcodeSelector: #genStorePopInstVarLong: withArguments: {instVarIndex}! !

!BytecodeEncoder methodsFor: 'bytecode generation' stamp: ''!
outOfRangeError: string index: index range: rangeStart to: rangeEnd
	"For now..."
	^self error: thisContext sender compiledCode method selector, ' ', string
				, ' index ', index printString
				, ' is out of range ', rangeStart printString, ' to ', rangeEnd printString! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeBranchPopFalse: distance
	^self sizeOpcodeSelector: #genBranchPopFalse: withArguments: {distance}! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeReturnTopToCaller
	^self sizeOpcodeSelector: #genReturnTopToCaller withArguments: #()! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeCallPrimitive: primitiveIndex
	^self sizeOpcodeSelector: #genCallPrimitive: withArguments: {primitiveIndex}! !

!BytecodeEncoder methodsFor: 'bytecode generation' stamp: ''!
genPushSpecialLiteral: aLiteral

	self subclassResponsibility! !

!BytecodeEncoder methodsFor: 'opcode sizing' stamp: ''!
sizeReturnTop
	^self sizeOpcodeSelector: #genReturnTop withArguments: #()! !

!BytecodeEncoder class methodsFor: 'accessing' stamp: ''!
literalMethodBytecodes
	"A literal method is a method that just answers a literal value. 
	 This is a constant sequence of bytecodes but it changes between enconders"

	^ self subclassResponsibility! !

!BytecodeEncoder class methodsFor: 'instruction stream support' stamp: ''!
isExtension: byte
	"Answer if the bytecode is that of an extension bytecodee (a prefix for other bytecodes to extend their range)."
	^self subclassResponsibility! !

!BytecodeEncoder class methodsFor: 'bytecode decoding' stamp: ''!
nonExtensionBytecodeAt: pc in: method
	"Answer the actual bytecode at pc in method, skipping past any preceeding extensions."
	| thePC bytecode |
	thePC := pc.
	[self isExtension: (bytecode := method at: thePC)] whileTrue:
		[thePC := thePC + (self bytecodeSize: bytecode)].
	^bytecode! !

!BytecodeEncoder class methodsFor: '*Flashback-Decompiler' stamp: ''!
skipTemps: numTemps for: aDecompiler
	numTemps timesRepeat: [ aDecompiler goToNextInstruction ]! !

!BytecodeEncoder class methodsFor: 'instruction stream support' stamp: ''!
extensionsFor: pc in: aCompiledMethod into: trinaryBlock
	"If the bytecode at pc is an extension, or if the bytecode at pc is preceeded by extensions,
	 then evaluate aTrinaryBlock with the values of extA and extB and number of extension *bytes*.
	 If the bytecode at pc is neither an extension or extended then evaluate with 0, 0, 0."
 
	| prevPC |
	"If there is what appears to be an extension bytecode before this bytecode
	 then scan for the previous pc to confirm."
	(pc - 2 >= aCompiledMethod initialPC
	 and: [self isExtension: (aCompiledMethod at: pc - 2)]) ifTrue:
		[prevPC := aCompiledMethod pcPreviousTo: pc.
		 (self nonExtensionPcAt: prevPC in: aCompiledMethod) = pc ifTrue:
			[^self extensionsAt: prevPC in: aCompiledMethod into: trinaryBlock]].
	^self extensionsAt: pc in: aCompiledMethod into: trinaryBlock! !

!BytecodeEncoder class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == BytecodeEncoder! !

!BytecodeEncoder class methodsFor: 'instruction stream support' stamp: ''!
nonExtensionPcAt: pc in: method
	"Answer the pc of the actual bytecode at pc in method, skipping past any preceeding extensions."
	| thePC bytecode |
	thePC := pc.
	[self isExtension: (bytecode := method at: thePC)] whileTrue:
		[thePC := thePC + (self bytecodeSize: bytecode)].
	^thePC! !

!BytecodeEncoder class methodsFor: 'bytecode decoding' stamp: ''!
specialSelectors	
	^ #(#+ #- #< #> #'<=' #'>=' #= #'~=' #* #/ #'\\' #@ #bitShift: #'//' #bitAnd: #bitOr: #at: #at:put: #size #next #nextPut: #atEnd #'==' nil "class" #'~~' #value #value: #do: #new #new: #x #y)! !

!BytecodeEncoder class methodsFor: 'accessing' stamp: ''!
instructionSizeAt: pc of: aMehtod

	self subclassResponsibility! !

!BytecodeEncoder class methodsFor: 'bytecode decoding' stamp: ''!
quickPrimSpecialConstants
	"Note: they are different from the encoder special literals."
	^ #(true false nil -1 0 1 2)! !

!BytecodeEncoder class methodsFor: 'bytecode decoding' stamp: ''!
stackDeltaForPrimitive: primitiveIndex in: method 
	"This is the default implementation. Subclasses with inline primitives
	will need to override."
	^ 0! !

!CDAbstractClassDefinitionParser commentStamp: ''!
I'm a common superclass for class definition parsers. 
!
!CDAbstractClassDefinitionParser methodsFor: 'accessing' stamp: ''!
handlePackage: aNode 
	
	classDefinition packageNameNode: aNode astNode: aNode! !

!CDAbstractClassDefinitionParser methodsFor: 'parsing' stamp: ''!
handleClassName: aNode
	| className classNode |
	className := (aNode isVariable
		ifTrue: [ aNode name ]
		ifFalse: [ aNode value ]) asSymbol.
	classNode := self classNameNodeClass new
		originalNode: aNode;
		className: className.
	classDefinition className: className astNode: classNode! !

!CDAbstractClassDefinitionParser methodsFor: 'parsing' stamp: ''!
handleMetaclassName: aNode
	"we are in situation ClassX class << ClassZ class
				slots: {xxxx} so grab the class"
	
	aNode handleMetaclassName: self		
	"| className classNode node |
	node := aNode receiver arguments first. 
	className := node receiver binding value class name.
	classNode := self classNameNodeClass new
		originalNode: node;
		className: className.
	classDefinition className: node astNode: classNode
	"! !

!CDAbstractClassDefinitionParser methodsFor: 'parsing' stamp: ''!
parse: aString
	| expressionTree |
	expressionTree := self parserClass parseExpression: aString.
	[expressionTree doSemanticAnalysis] 
		on: OCUndeclaredVariableWarning 
		do: [ :ex | ex resume: ex declareUndefined ].
	^ self parseRootNode: expressionTree! !

!CDAbstractClassDefinitionParser methodsFor: 'parsing' stamp: ''!
handleInstanceVariablesFromNode: aNode
	| slots slotNodes instanceVariablesString |
	instanceVariablesString := aNode value.
	slots := instanceVariablesString substrings.
	slotNodes := slots
		collect: [ :slotName | 
			| start |
			start := aNode start
				+ (instanceVariablesString findString: slotName).
			self slotNodeClass
				node: aNode
				name: slotName
				slotClassName: #InstanceVariableSlot
				start: start
				stop: start + slotName size ].
	classDefinition slots: slotNodes! !

!CDAbstractClassDefinitionParser methodsFor: 'private - class factory' stamp: ''!
classNameNodeClass
	^ CDClassNameNode! !

!CDAbstractClassDefinitionParser methodsFor: 'internal' stamp: ''!
beClassSideTraitDefinition
		
	classDefinition := CDClassSideTraitDefinitionNode new! !

!CDAbstractClassDefinitionParser methodsFor: 'parsing' stamp: ''!
handleTraitUsesFromNode: aNode
	
	| traitComposition |
	aNode isDynamicArray and: [aNode allStatements ifEmpty: [ ^ self ]].
 	traitComposition := CDTraitCompositionBuilder new buildFrom: aNode.	
	classDefinition traitDefinition: traitComposition.! !

!CDAbstractClassDefinitionParser methodsFor: 'parsing' stamp: ''!
handleSlotNode: aRBMessageNode
	"what ugly method!! Pay attention start and stop should be tested and probably adjusted!!"

	"when a slot is just 'inst'"
	aRBMessageNode isLiteralNode
		ifTrue: [ | slot |
			slot := self slotNodeClass
				node: aRBMessageNode
				name: aRBMessageNode value
				slotClassName: #InstanceVariableSlot
				initializationMessage: self slotInitializationNodeClass new
				start: aRBMessageNode start
				stop: aRBMessageNode stop.
			classDefinition addSlot: slot.
			^ self ].
	
	aRBMessageNode selector = '=>' 
		ifTrue: [  
		aRBMessageNode arguments first isMessage
		
		ifFalse: [  
			"when a slot is just 'inst' => InstanceVariableSlot."
			aRBMessageNode arguments first isGlobalVariable
				ifTrue: [ | slot |
					slot := self slotNodeClass
						node: aRBMessageNode
						name: aRBMessageNode receiver value
						slotClassName: aRBMessageNode arguments first name
						initializationMessage: self slotInitializationNodeClass new
						start: aRBMessageNode start
						stop: aRBMessageNode stop.
						classDefinition addSlot: slot.
				^ self ].
				"we will have to do something for example if we have 
				#x => 2"
				]
			ifTrue: [  
				
				"when a slot is 'inst' => (InstanceVariableSlot default: 5)."
				| slot slotDefNode |
				slotDefNode := aRBMessageNode.
				slot := self slotNodeClass
					node: aRBMessageNode
					name: slotDefNode receiver value
					slotClassName: slotDefNode arguments first receiver name
					initializationMessage:
						(self slotInitializationNodeClass
							selectorParts: aRBMessageNode arguments first selectorParts
							argumentParts: aRBMessageNode arguments first arguments)
					start: aRBMessageNode start
					stop: aRBMessageNode stop.
				classDefinition addSlot: slot.
				^ self ]
		]! !

!CDAbstractClassDefinitionParser methodsFor: 'private - class factory' stamp: ''!
slotNodeClass
	^ CDSlotNode! !

!CDAbstractClassDefinitionParser methodsFor: 'internal' stamp: ''!
beTraitDefinition
		
	classDefinition := CDTraitDefinitionNode new! !

!CDAbstractClassDefinitionParser methodsFor: 'hooks' stamp: ''!
parserClass
	^ RBParser! !

!CDAbstractClassDefinitionParser methodsFor: 'internal' stamp: ''!
beClassDefinition
		
	classDefinition := CDClassDefinitionNode new! !

!CDAbstractClassDefinitionParser methodsFor: 'private - class factory' stamp: ''!
slotInitializationNodeClass

	^ RBSlotInitializationNode! !

!CDAbstractClassDefinitionParser methodsFor: 'private - class factory' stamp: ''!
sharedPoolNodeClass
	^ CDSharedPoolNode! !

!CDAbstractClassDefinitionParser methodsFor: 'internal' stamp: ''!
beMetaclassDefinition
		
	classDefinition := CDMetaclassDefinitionNode new! !

!CDAbstractClassDefinitionParser methodsFor: 'accessing' stamp: ''!
handleSharedVariableNames: aNode 
	
	| slots slotNodes classVariablesString |
	classVariablesString := aNode value.
	slots := classVariablesString substrings.
	slotNodes := slots
		collect: [ :slotName | | start |
			start := aNode start + (classVariablesString findString: slotName).
			CDSharedVariableNode
				node: aNode
				name: slotName
				slotClassName: 'ClassVariableSlot'
				start: start
				stop: start + slotName size ].
	classDefinition sharedSlots: slotNodes! !

!CDAbstractClassDefinitionParser methodsFor: 'parsing' stamp: ''!
handleSlotsNodesFromArrayNode: aRBArrayNode
	
	aRBArrayNode statements do: [ :slotStatement |
		self handleSlotNode: slotStatement ]! !

!CDAbstractClassDefinitionParser class methodsFor: 'instance creation' stamp: ''!
parse: aString 
	
	^ self new parse: aString! !

!CDAbstractTraitCompositionNode commentStamp: ''!
Traits (unit of methods) can be composed out of other traits using + between traits, - to exclude a method and an alias @ to give another name to a method (this is not a rename just an alias).
I'm the common superclass for all the implied nodes.!
!CDAbstractTraitCompositionNode methodsFor: 'testing' stamp: ''!
isTraitComposition
	
	^ true! !

!CDAbstractTraitCompositionNode methodsFor: 'composing' stamp: ''!
@@ aCollection 
	
	^ CDTraitSlotRenameNode new
		subject: self;
		renames: aCollection! !

!CDAbstractTraitCompositionNode methodsFor: 'composing' stamp: ''!
@ aCollection 
	
	^ CDTraitAliasNode new
		subject: self;
		aliases: aCollection! !

!CDAbstractTraitCompositionNode methodsFor: 'combining' stamp: ''!
- aCollection 
	
	^ CDTraitExclusionNode new
		subject: self;
		exclusions: aCollection! !

!CDAbstractTraitCompositionNode methodsFor: 'testing' stamp: ''!
isTraitNode
	^false! !

!CDAbstractTraitCompositionNode methodsFor: 'composing' stamp: ''!
+ aNode
	
	^ CDTraitCompositionSequenceNode new
		sequence: { self . aNode }! !

!CDAbstractTraitCompositionNode methodsFor: 'composing' stamp: ''!
-- aCollection 
	
	^ CDTraitSlotRemoveNode new
		subject: self;
		removedSlots: aCollection! !

!CDBehaviorDefinitionNode commentStamp: ''!
I contain the methods shared between class and meta class definition.!
!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
className: aName astNode: astNode

	className := aName.
	classNameNode := astNode.
	self addChild: astNode! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
classDefinitionNode
	^self! !

!CDBehaviorDefinitionNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	slotNodes := OrderedCollection new! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
slots

	^ slotNodes! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
selector
	^ self subclassResponsibility! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
slotNodes
	
	^ slotNodes! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
className: aClassName
	className := aClassName! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
existingClassIfAbsent: aBlock

	^self classNameNode existingClassIfAbsent: aBlock! !

!CDBehaviorDefinitionNode methodsFor: 'testing' stamp: ''!
isInstanceSide
	^ self subclassResponsibility! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
addSlot: aCDSlotNode
	
	slotNodes add: aCDSlotNode.
	self addChild: aCDSlotNode! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
classNameNode: aNode astNode: astNode

	classNameNode := aNode.
	self addChild: aNode! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
classNameNode: aClassNameNode
	classNameNode := aClassNameNode! !

!CDBehaviorDefinitionNode methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ traitDefinition isNotNil! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
classNameNode
	
	^ classNameNode! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
layoutClass

	^ layoutClass! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
layoutClass: aClass 
	layoutClass := aClass! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
traitDefinition: aNode

	traitDefinition := aNode.
	self addChild: aNode.! !

!CDBehaviorDefinitionNode methodsFor: 'testing' stamp: ''!
isClassSide
	^ self subclassResponsibility! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
traitDefinition

	^traitDefinition! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
slots: aCollection 
	
	slotNodes := aCollection.
	aCollection do: [ :each | self addChild: each ]! !

!CDBehaviorDefinitionNode methodsFor: 'accessing' stamp: ''!
className

	^ className! !

!CDBehaviorDefinitionNode class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == CDBehaviorDefinitionNode! !

!CDBehaviorParserTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	classDefinition := self parserClass parse: self classDefinitionString! !

!CDBehaviorParserTest methodsFor: 'helpers' stamp: ''!
nodeFor: aString 
	
	^ classDefinition bestNodeFor: (self selectionOf: aString)! !

!CDBehaviorParserTest methodsFor: 'tests' stamp: ''!
testBestNodeForSecondInstanceVariableSelectionShouldBeSecondSlotNode

	| selectedNode selection |
	selection := self selectionOf: self secondInstanceVariableName.
	
	selectedNode := classDefinition bestNodeFor: selection.
	self assert: selectedNode equals: classDefinition slotNodes second! !

!CDBehaviorParserTest methodsFor: 'tests' stamp: ''!
testSlotNodesHaveParentReference

	| slotNode |
	slotNode := classDefinition slotNodes first.
	
	self assert: slotNode parent identicalTo: classDefinition.
	self assert: slotNode classDefinitionNode identicalTo: classDefinition.
	self assert: (classDefinition children includes: slotNode)! !

!CDBehaviorParserTest methodsFor: 'tests' stamp: ''!
testBestNodeForInstanceVariableSelectionShouldBeSlotNode

	| selectedNode selection |	
	selection := self selectionOf: self firstInstanceVariableName.
	
	selectedNode := classDefinition bestNodeFor: selection.
	self assert: selectedNode equals: classDefinition slotNodes first! !

!CDBehaviorParserTest methodsFor: 'tests' stamp: ''!
testClassNameNodeHaveParentReference

	| nameNode |
	nameNode := classDefinition classNameNode.
	
	self assert: nameNode parent identicalTo: classDefinition.
	self assert: nameNode classDefinitionNode identicalTo: classDefinition.
	self assert: (classDefinition children includes: nameNode)! !

!CDBehaviorParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasSlots

	self assert: classDefinition slotNodes first name equals: self firstInstanceVariableName.
	self assert: classDefinition slotNodes second name equals: self secondInstanceVariableName.! !

!CDBehaviorParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasClassName

	self assert: classDefinition className equals: self className! !

!CDBehaviorParserTest methodsFor: 'helpers' stamp: ''!
firstInstanceVariableName

	^ 'first'! !

!CDBehaviorParserTest methodsFor: 'helpers' stamp: ''!
parserClass

	^ CDClassDefinitionParser! !

!CDBehaviorParserTest methodsFor: 'tests' stamp: ''!
testBestNodeForClassNameSelectionShouldBeClassNameNode

	| selectedNode selection |
	selection := self selectionOf: self className.
	selectedNode := classDefinition bestNodeFor: selection.
	self assert: selectedNode equals: classDefinition classNameNode! !

!CDBehaviorParserTest methodsFor: 'helpers' stamp: ''!
secondInstanceVariableName

	^ 'second'! !

!CDBehaviorParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	self subclassResponsibility! !

!CDBehaviorParserTest methodsFor: 'helpers' stamp: ''!
className

	^ 'TheClass'! !

!CDBehaviorParserTest methodsFor: 'helpers' stamp: ''!
selectionOf: aText

	| start |
	start := self classDefinitionString findString: aText.
	^ start to: start! !

!CDBehaviorParserTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == CDBehaviorParserTest! !

!CDClassDefinitionModel commentStamp: ''!
I'm a simple object holding a code piece.

```
| code |
code := Point definition.
CDClassDefinitionModel new
	text: code;
	title: 'Test';
	beForCode;
	behavior: Point;
	aboutToStyle: true;
	owner: (CDClassDefinitionModel new code: code);
	openWithSpec
```!
!CDClassDefinitionModel methodsFor: 'accessing' stamp: ''!
code: aString 
	code := aString! !

!CDClassDefinitionModel methodsFor: 'compatibility' stamp: ''!
selectedMessage
	
	^ CDClassDefinitionParser parse: code! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
superclassNameNode: anObject
	superclassNameNode := anObject! !

!CDClassDefinitionNode methodsFor: 'testing' stamp: ''!
selector

	^ tokens at: 2! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
sharedPools: aCollection 
	sharedPools := aCollection.
	aCollection do: [ :each | self addChild: each ]! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
superclassNameNode
	
	^ superclassNameNode! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
superclassName
	
	^ superclassName! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
sharedSlots: aCollection 
	sharedSlotNodes := aCollection.
	aCollection do: [ :each | self addChild: each ]! !

!CDClassDefinitionNode methodsFor: 'testing' stamp: ''!
isInstanceSide
	^ true! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
binding 
	self trace: '.'.
	^ self class environment associationAt: self className ifAbsent: [LiteralVariable key: nil value: self].! !

!CDClassDefinitionNode methodsFor: 'testing' stamp: ''!
isClassDefinition
	
	^ true! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
sharedSlotNodes
	
	^ sharedSlotNodes! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
tag: aString

	tag := aString! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
sharedSlots
	^ sharedSlotNodes ifNil:[ sharedSlotNodes := Array new ]! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
tag

	^ tag! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
packageName
	
	^ packageNameNode ifNotNil: [packageNameNode value asSymbol ]! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
packageNameNode
	
	^ packageNameNode! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
superclassName: aString
	superclassName := aString! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
sharedPools
	sharedPools ifNil: [ self sharedPools: OrderedCollection new. ].
	^sharedPools! !

!CDClassDefinitionNode methodsFor: 'testing' stamp: ''!
isClassSide
	^ false! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
packageNameNode: aNode astNode: astNode

	packageNameNode := aNode.
	self addChild: aNode.! !

!CDClassDefinitionNode methodsFor: 'accessing' stamp: ''!
superclassName: aName astNode: astNode
	
	superclassName := aName.
	superclassNameNode := astNode.
	self addChild: astNode.! !

!CDClassDefinitionParser commentStamp: ''!
I use the default node representation of classes to parse class definition and  return a dedicated class tree.

The basic idea behing the implementation is to reuse as much as possible as the current parser infrastructure. This is why this class defines a visitMessageNode: method. 

Main public API is 
	- parse: aString!
!CDClassDefinitionParser methodsFor: 'parsing' stamp: ''!
handleSuperclassNode: aSuperclassNode
	| aSuperclassName superclassNode |
	aSuperclassName := (aSuperclassNode isLiteralNode
		ifTrue: [ aSuperclassNode value asString ]
		ifFalse: [ aSuperclassNode name ]) asSymbol.
	superclassNode := self classNameNodeClass new
		originalNode: aSuperclassNode;
		className: aSuperclassName.
	classDefinition
		superclassName: aSuperclassName
		astNode: superclassNode! !

!CDClassDefinitionParser methodsFor: 'parsing' stamp: ''!
handleClassName: aNode withType: aSymbol
	| layoutClass |
	self handleClassName: aNode.
	layoutClass := ObjectLayout layoutForSubclassDefiningSymbol: aSymbol.
	
	"if we get back CompiledMethodLayout or ByteLayout, we need to check the class name"
	(layoutClass = CompiledMethodLayout or: [ layoutClass = ByteLayout ]) ifTrue: [ 
		layoutClass := (classDefinition className = 'CompiledMethod') 
					ifTrue:  [  CompiledMethodLayout ]
					ifFalse: [  ByteLayout ]].
	classDefinition layoutClass: (layoutClass)! !

!CDClassDefinitionParser methodsFor: 'parsing' stamp: ''!
handleSharedPoolsFromNode: aNode
	| shareds sharedPoolNodes sharedPoolString |
	sharedPoolString := aNode value.
	shareds := sharedPoolString substrings.
	sharedPoolNodes := shareds
		collect: [ :slotName | 
			| start |
			start := aNode start + (sharedPoolString findString: slotName).
			self sharedPoolNodeClass
				node: aNode
				name: slotName
				start: start
				stop: start + slotName size ].
	classDefinition sharedPools: sharedPoolNodes! !

!CDClassDefinitionParser methodsFor: 'parsing' stamp: ''!
parseRootNode: expressionTree
	self setAdequateClassDefinitionFrom: expressionTree.
	classDefinition originalNode: expressionTree.
	expressionTree acceptVisitor: self.
	^ classDefinition! !

!CDClassDefinitionParser methodsFor: 'internal' stamp: ''!
setAdequateClassDefinitionFrom: expressionTree
	"set a class or metaclass class definition as class definition object."
	(self isInstanceSideDefinition: expressionTree)
		ifTrue: [ self beClassDefinition ]
		ifFalse: [ self beMetaclassDefinition ]! !

!CDClassDefinitionParser methodsFor: 'parsing' stamp: ''!
handleTraitDefinitionFromNode: aNode
	
	| traitComposition |
	traitComposition := CDTraitCompositionBuilder new buildFrom: aNode.	
	classDefinition traitDefinition: traitComposition.! !

!CDClassDefinitionParser methodsFor: 'testing' stamp: ''!
isInstanceSideDefinition: aRBMessageNode
	"Based on the Point or Point class structure, returns whether the definition is a class or instance side definition."
	^ aRBMessageNode receiver isMessage not! !

!CDClassDefinitionParser methodsFor: 'parsing' stamp: ''!
visitMessageNode: aRBMessageNode

	(self isInstanceSideDefinition: aRBMessageNode)
		ifTrue: [ self handleSuperclassNode: aRBMessageNode receiver ]
		ifFalse: [ self handleClassName: aRBMessageNode receiver receiver ].
	
	aRBMessageNode selectorParts
		with: aRBMessageNode arguments
		do: [ :selectorPart :argument |
			self parseSelectorPart: selectorPart withArgument: argument ]! !

!CDClassDefinitionParser methodsFor: 'parsing' stamp: ''!
parseSelectorPart: aString withArgument: aNode 
	
	"We could do this with reflection, or with a dictionary and closures.
	I chose to use a series of if for readability only."
	
	(ObjectLayout allSubclassDefiningSymbols includes: aString)
		ifTrue: [ ^ self handleClassName: aNode withType: aString  ].
	aString =	 #instanceVariableNames:
		ifTrue: [ ^ self handleInstanceVariablesFromNode: aNode ].
	aString =	 #classVariableNames:
		ifTrue: [ ^ self handleSharedVariableNames: aNode ].
	aString =	 #category:
		ifTrue: [ ^ self handlePackage: aNode ].	
	aString =	 #package:
		ifTrue: [ ^ self handlePackage: aNode ].
	aString =	 #uses:
		ifTrue: [ ^ self handleTraitDefinitionFromNode: aNode ].
	aString =	 #poolDictionaries:
		ifTrue: [ ^ self handleSharedPoolsFromNode: aNode ].
	
	CDUnrecognizedClassPart new
		classDefinition: self; 
		unrecognizedPart: aString;
		signal! !

!CDClassDefinitionParser class methodsFor: 'parsing' stamp: ''!
fromASTNode: aNode 
	
	^ self new parseRootNode: aNode! !

!CDClassDefinitionParserTest methodsFor: 'helpers' stamp: ''!
firstClassVariableIndex

	^ self classDefinitionString findString: self firstClassVariableName! !

!CDClassDefinitionParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasPackageName

	self assert: classDefinition packageName equals: self packageName! !

!CDClassDefinitionParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasSharedSlots

	self assert: classDefinition sharedSlots first name equals: self firstClassVariableName.
	self assert: classDefinition sharedSlots second name equals: self secondClassVariableName.
	
	self assert: classDefinition sharedSlots second isLiteralVariable.
	self deny: classDefinition sharedSlots second isGlobalClassNameBinding.! !

!CDClassDefinitionParserTest methodsFor: 'helpers' stamp: ''!
superclassName

	^ 'TheSuperClass'! !

!CDClassDefinitionParserTest methodsFor: 'helpers' stamp: ''!
secondClassVariableName

	^ 'secondClass'! !

!CDClassDefinitionParserTest methodsFor: 'tests' stamp: ''!
testBestNodeForSuperclassSelectionShouldBeSuperclassNameNode

	| selectedNode selection |
	selection := self selectionOf: self superclassName.

	selectedNode := classDefinition bestNodeFor: selection.
	self assert: selectedNode equals: classDefinition superclassNameNode! !

!CDClassDefinitionParserTest methodsFor: 'tests' stamp: ''!
packageName
	^  #MyPackage! !

!CDClassDefinitionParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasPackageNameNode

	self assert: classDefinition packageNameNode value equals: self packageName! !

!CDClassDefinitionParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasSuperclassName

	self assert: classDefinition superclassName equals: self superclassName.! !

!CDClassDefinitionParserTest methodsFor: 'tests' stamp: ''!
testBestNodeForClassVariableSelectionShouldBeClassSlotNode

	| selectedNode selection |	
	selection := self selectionOf: self firstClassVariableName.
	
	selectedNode := classDefinition bestNodeFor: selection.
	self assert: selectedNode equals: classDefinition sharedSlots first! !

!CDClassDefinitionParserTest methodsFor: 'helpers' stamp: ''!
firstClassVariableName

	^ 'firstClass'! !

!CDClassDefinitionParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasSuperclassNameNode

	self assert: classDefinition superclassNameNode name equals: self superclassName.! !

!CDClassDefinitionParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasClassNameNode

	self assert: classDefinition classNameNode value equals: self className.! !

!CDClassDefinitionParserTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == CDClassDefinitionParserTest! !

!CDClassNameNode methodsFor: 'accessing' stamp: ''!
className: aString 
	
	className := aString! !

!CDClassNameNode methodsFor: 'accessing' stamp: ''!
existingBindingIfAbsent: aBlock

	| binding |
	binding := originalNode methodNode compilationContext environment bindingOf: className.
	^binding ifNil: aBlock! !

!CDClassNameNode methodsFor: 'accessing' stamp: ''!
existingClassIfAbsent: aBlock

	| binding |
	binding := self existingBindingIfAbsent: aBlock.
	^binding value! !

!CDClassNameNode methodsFor: 'accessing' stamp: ''!
binding
	^self existingBindingIfAbsent: [LiteralVariable key: className value: nil]! !

!CDClassNameNode methodsFor: 'testing' stamp: ''!
isTempVariable
	"To be polymorphic to RB method nodes"
	^false! !

!CDClassNameNode methodsFor: 'accessing' stamp: ''!
value
	
	^ className! !

!CDClassNameNode methodsFor: 'accessing' stamp: ''!
name
	
	^ className! !

!CDClassNameNode methodsFor: 'testing' stamp: ''!
isVariable
	"Existing class name is a variable 
	to be polymorphic to method literal nodes which encode class reference"
	
	self existingBindingIfAbsent: [ ^false ].
	^true! !

!CDClassNameNode methodsFor: 'accessing' stamp: ''!
className
	
	^ className! !

!CDClassParserSelectionTest methodsFor: 'running' stamp: ''!
tearDown

	ClassDefinitionPrinter showFluidClassDefinition: slotuse.
	super tearDown! !

!CDClassParserSelectionTest methodsFor: 'tests' stamp: ''!
testParsingANonComplexClassWhenFluidSyntaxOff

	"we do not get a complex class"
 	self deny: self class needsSlotClassDefinition.
	ClassDefinitionPrinter showFluidClassDefinition: false.
	self deny: ClassDefinitionPrinter showFluidClassDefinition.
	
	self 
		assert: (self class definitionString)
		equals: 
	  'TestCase subclass: #CDClassParserSelectionTest
	instanceVariableNames: ''slotuse''
	classVariableNames: ''''
	package: ''ClassParser-Tests'''.
	"ok so far so good"
	
	self assert: self class classDefinitionParserClass equals: CDClassDefinitionParser.
	"here we cannot invoke the definition printer because it is chosen without asking the class so far."! !

!CDClassParserSelectionTest methodsFor: 'tests' stamp: ''!
testParsingAFluidClassShouldSelectTheFluidParserEvenIfFluidIsOff

	"we get a complex class"
	self assert: MockWithComplexSlot needsSlotClassDefinition.
	ClassDefinitionPrinter showFluidClassDefinition: false.
	self deny: 	ClassDefinitionPrinter showFluidClassDefinition.
	self 
		assert: (MockWithComplexSlot definitionString)
		equals: 
	  'Object << #MockWithComplexSlot
	slots: { #aComplexSlot => ObservableSlot };
	tag: ''Fluid'';
	package: ''Kernel-Tests'''.
	"ok so far so good"
	
	self assert: MockWithComplexSlot classDefinitionParserClass equals: CDFluidClassDefinitionParser.
	"here we cannot invoke the definition printer because it is chosen without asking the class so far."! !

!CDClassParserSelectionTest methodsFor: 'tests' stamp: ''!
testParsingAFluidClassShouldSelectTheFluidParser

	"we get a complex class"
	self assert: MockWithComplexSlot needsSlotClassDefinition.
	self 
		assert: (MockWithComplexSlot definitionString)
		equals: 
	  'Object << #MockWithComplexSlot
	slots: { #aComplexSlot => ObservableSlot };
	tag: ''Fluid'';
	package: ''Kernel-Tests'''.
	"ok so far so good"
	
	self assert: MockWithComplexSlot classDefinitionParserClass equals: CDFluidClassDefinitionParser.
	"here we cannot invoke the definition printer because it is chosen without asking the class so far."! !

!CDClassParserSelectionTest methodsFor: 'tests' stamp: ''!
testParsingAClassWhenFluidSyntaxIsOnShouldSelectTheFluidParser

	"we do not get a complex class"
 	self deny: self class needsSlotClassDefinition.
	ClassDefinitionPrinter showFluidClassDefinition: true.
	self assert: ClassDefinitionPrinter showFluidClassDefinition.
	
	self 
		assert: (self class definitionString)
		equals: 
	  'TestCase << #CDClassParserSelectionTest
	slots: { #slotuse };
	package: ''ClassParser-Tests'''.
	"ok so far so good"
	
	self assert: self class classDefinitionParserClass equals: CDFluidClassDefinitionParser.
	"here we cannot invoke the definition printer because it is chosen without asking the class so far."! !

!CDClassParserSelectionTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	slotuse := ClassDefinitionPrinter showFluidClassDefinition.! !

!CDClassTagNode commentStamp: ''!
I'm a simple node to hold a string representing a tag. A tag is a optional string based part to be able to sort class in subpackage folders.

```
Object < #CDClassDefinitionParser
	slots: {#classDefinition . #subclass};
	tag: 'Model';
	package: 'ClassParser'
```

and in old syntax

```
Object subclass: #CDClassDefinitionParser
	instanceVariableNames: 'classDefinition subclass'
	classVariableNames: ''
	package: 'ClassParser-Model'
```!
!CDClassTagNode methodsFor: 'visitor' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	
	aProgramNodeVisitor visitTag: self! !

!CDClassTagNode methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!CDClassTagNode methodsFor: 'accessing' stamp: ''!
name: aString 
	name := aString! !

!CDClassTraitNode commentStamp: ''!
I represent the class side of a Trait. I may dissapear. All trait are instances of MetaclassForTraits.!
!CDClassTraitNode methodsFor: 'testing' stamp: ''!
name
	^ name! !

!CDClassTraitNode methodsFor: 'accessing' stamp: ''!
name: aString 
	name := aString! !

!CDClassTraitNode methodsFor: 'testing' stamp: ''!
isTraitNode

	^ true! !

!CDClassWithFullDefinitionExample methodsFor: 'accessing' stamp: ''!
classVar2
	^ClassVar2! !

!CDClassWithFullDefinitionExample methodsFor: 'accessing' stamp: ''!
classVar1
	^ClassVar1! !

!CDClassWithFullDefinitionExample methodsFor: 'accessing' stamp: ''!
instVar2

	^ instVar2! !

!CDClassWithFullDefinitionExample methodsFor: 'accessing' stamp: ''!
instVar1

	^ instVar1! !

!CDClassWithFullDefinitionExample class methodsFor: 'accessing' stamp: ''!
classSideVar2

	^ classSideVar2! !

!CDClassWithFullDefinitionExample class methodsFor: 'accessing' stamp: ''!
classSideVar1

	^ classSideVar1! !

!CDClassWithPoolDictionaryParserTest methodsFor: 'helpers' stamp: ''!
sharedPoolName
	^ 'TextConstants AnotherSharedPool'! !

!CDClassWithPoolDictionaryParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString
	^ '{superclassName} subclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		poolDictionaries: ''{sharedPoolName}''
		package: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. 
				'sharedPoolName' -> self sharedPoolName } asDictionary! !

!CDClassWithTraitAliasParserTest methodsFor: 'tests' stamp: ''!
testTraitAliasTargetSelectorShouldBeExistingSelector

	self assert: (self traitCompositionNode aliases values includes: self existingSelectorName)! !

!CDClassWithTraitAliasParserTest methodsFor: 'tests' stamp: ''!
testTraitAliasShouldBeFromAliasName

	self assert: (self traitCompositionNode aliases keys includes: self aliasName)! !

!CDClassWithTraitAliasParserTest methodsFor: 'accessing' stamp: ''!
existingSelectorName
	
	^ #existing! !

!CDClassWithTraitAliasParserTest methodsFor: 'helpers' stamp: ''!
aliasName
	
	^ #alias! !

!CDClassWithTraitAliasParserTest methodsFor: 'tests' stamp: ''!
testTraitDefinitionNodeIsTraitAliasNode

	self assert: self traitCompositionNode isTraitAliasNode! !

!CDClassWithTraitAliasParserTest methodsFor: 'helpers' stamp: ''!
traitDefinition

	^ 'MyTrait @ \{#''{aliasName}'' -> #''{existingSelectorName}''\}'
		format: { 
			'aliasName' -> self aliasName.
			'existingSelectorName' -> self existingSelectorName. } asDictionary! !

!CDClassWithTraitCompositionSequenceParserTest methodsFor: 'helpers' stamp: ''!
testTraitDefinitionNodeIsTraitSequenceNode

	self assert: self traitCompositionNode isTraitSequenceNode! !

!CDClassWithTraitCompositionSequenceParserTest methodsFor: 'helpers' stamp: ''!
traitDefinition

	^ 'MyTrait + (AnotherTrait - {#selector} @ {#selector1 -> #selector})'! !

!CDClassWithTraitExclusionParserTest methodsFor: 'helpers' stamp: ''!
testTraitDefinitionNodeIsTraitAliasNode

	self assert: self traitCompositionNode isTraitExclusionNode! !

!CDClassWithTraitExclusionParserTest methodsFor: 'helpers' stamp: ''!
traitDefinition

	^ 'MyTrait - { #selector1 }'! !

!CDClassWithTraitParserTest methodsFor: 'helpers' stamp: ''!
traitDefinition

	^ 'MyTrait'! !

!CDClassWithTraitParserTest methodsFor: 'helpers' stamp: ''!
testTraitDefinitionNodeIsTraitNode

	self assert: self traitCompositionNode isTraitNode! !

!CDCompiledMethodClassParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasSharedSlots
	"no Class Variables in CompileMethod"
	self assert: classDefinition sharedSlotNodes isEmpty! !

!CDCompiledMethodClassParserTest methodsFor: 'accessing' stamp: ''!
superclassName
	^#CompiledCode! !

!CDCompiledMethodClassParserTest methodsFor: 'tests' stamp: ''!
testBestNodeForSecondInstanceVariableSelectionShouldBeSecondSlotNode
	"no slots for CompileMethod"
	self assert: classDefinition slots isEmpty! !

!CDCompiledMethodClassParserTest methodsFor: 'helpers' stamp: ''!
testCompiledMethodClass

	self assert: classDefinition layoutClass equals: CompiledMethodLayout! !

!CDCompiledMethodClassParserTest methodsFor: 'tests' stamp: ''!
testBestNodeForInstanceVariableSelectionShouldBeSlotNode
	"no slots for CompileMethod"
	self assert: classDefinition slots isEmpty! !

!CDCompiledMethodClassParserTest methodsFor: 'tests' stamp: ''!
testSlotNodesHaveParentReference
	"no slots for CompileMethod"
	self assert: classDefinition slots isEmpty! !

!CDCompiledMethodClassParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasSlots
	"no slots for CompileMethod"
	self assert: classDefinition slots isEmpty! !

!CDCompiledMethodClassParserTest methodsFor: 'tests' stamp: ''!
testBestNodeForClassVariableSelectionShouldBeClassSlotNode
	"no Class Variables in CompileMethod"
	self assert: classDefinition sharedSlotNodes isEmpty! !

!CDCompiledMethodClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString
	"we just test the definition as it appears in the image"
	^ 'CompiledCode variableByteSubclass: #CompiledMethod
	instanceVariableNames: ''''
	classVariableNames: ''''
	package: #MyPackage'! !

!CDCompiledMethodClassParserTest methodsFor: 'accessing' stamp: ''!
className
	^#CompiledMethod! !

!CDDoubleByteClassParserTest methodsFor: 'helpers' stamp: ''!
testDoubleByteClass

	self assert: classDefinition layoutClass equals: DoubleByteLayout! !

!CDDoubleByteClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ '{superclassName} variableDoubleByteSubclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		package: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. } asDictionary! !

!CDDoubleWordClassParserTest methodsFor: 'helpers' stamp: ''!
testDoubleWordClass

	self assert: classDefinition layoutClass equals: DoubleWordLayout! !

!CDDoubleWordClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ '{superclassName} variableDoubleWordSubclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		package: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. } asDictionary! !

!CDEphemeronClassParserTest methodsFor: 'helpers' stamp: ''!
testEphemeronClassIsEphemeron

	self assert: classDefinition layoutClass equals: EphemeronLayout! !

!CDEphemeronClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ '{superclassName} ephemeronSubclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		package: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. } asDictionary! !

!CDExistingClassDefinitionTest methodsFor: 'helpers' stamp: ''!
testSharedSlotNodeArePolymorphicToRBVariableNodes
	
	| classVarNode |
	classVarNode := classDefinition sharedSlotNodes first.
	
	self assert: classVarNode isVariable.
	self deny: classVarNode isTempVariable.
	self deny: classVarNode isGlobalVariable.
	self assert: classVarNode isClassVariable.
	self deny: classVarNode isInstanceVariable.
	self assert: classVarNode isLiteralVariable.
	self deny: classVarNode isUndeclaredVariable.! !

!CDExistingClassDefinitionTest methodsFor: 'helpers' stamp: ''!
testSlotNodeArePolymorphicToRBVariableNodes
	
	| slotNode |
	slotNode := classDefinition slotNodes first.
	self assert: slotNode isVariable.
	self deny: slotNode isTempVariable.
	self deny: slotNode isGlobalVariable.
	self deny: slotNode isClassVariable.
	self assert: slotNode isInstanceVariable.
	self deny: slotNode isLiteralVariable.
	self deny: slotNode isUndeclaredVariable.! !

!CDExistingClassDefinitionTest methodsFor: 'helpers' stamp: ''!
testSlotNodeBinding
	
	| slotNode |
	slotNode := classDefinition slotNodes first.
	self assert: slotNode binding identicalTo: slotNode! !

!CDExistingClassDefinitionTest methodsFor: 'helpers' stamp: ''!
testGettingExistingClass
	
	| class |
	class := classDefinition existingClassIfAbsent: [].
	self assert: class equals: CDClassWithFullDefinitionExample! !

!CDExistingClassDefinitionTest methodsFor: 'helpers' stamp: ''!
firstInstanceVariableName
	
	^ 'instVar1'! !

!CDExistingClassDefinitionTest methodsFor: 'helpers' stamp: ''!
secondInstanceVariableName

	^ 'instVar2'! !

!CDExistingClassDefinitionTest methodsFor: 'helpers' stamp: ''!
testClassNameNodeIsPolymorphicToRBVariableNode
	
	| nameNode |
	nameNode := classDefinition classNameNode.
	self assert: nameNode isVariable. "It is polymorphic to class reference nodes in method sources"
	self deny: nameNode isTempVariable! !

!CDExistingClassDefinitionTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ (ClassDefinitionPrinter oldPharo for: CDClassWithFullDefinitionExample) definitionString! !

!CDExistingClassDefinitionTest methodsFor: 'helpers' stamp: ''!
className

	^ CDClassWithFullDefinitionExample name! !

!CDExistingClassDefinitionTest methodsFor: 'helpers' stamp: ''!
testGettingExistingClassNameBinding
	
	| binding |
	binding := classDefinition classNameNode binding.
	
	self assert: binding identicalTo: CDClassWithFullDefinitionExample binding! !

!CDExistingClassSideDefinitionTest methodsFor: 'helpers' stamp: ''!
testGettingExistingClass
	
	| class |
	class := classDefinition existingClassIfAbsent: [].
	self assert: class equals: CDClassWithFullDefinitionExample class! !

!CDExistingClassSideDefinitionTest methodsFor: 'helpers' stamp: ''!
firstInstanceVariableName
	
	^ 'classSideVar1'! !

!CDExistingClassSideDefinitionTest methodsFor: 'helpers' stamp: ''!
secondInstanceVariableName

	^ 'classSideVar2'! !

!CDExistingClassSideDefinitionTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ (ClassDefinitionPrinter oldPharo for: CDClassWithFullDefinitionExample class) definitionString! !

!CDFluidClassDefinitionParser commentStamp: ''!
I'm parser for the new class syntax. 


### The new syntax for class definition (just for the class and not for the methods) is

```
Superclass < #MyObject
	uses: #MyTrait;
	slots: { #a. #b };
	sharedVariables: { #A. #B };
	tags: {'tag2' . 'Core'} ;
	layout: VariableLayout; 
	sharedPools: { #TextConstants } ;
	package: #MyPackage
```
Pay attention all the messages should be keyword-based.

The minimal class definition is the following one: 

```
Superclass < #MyObject
	package: #MyPackage
```

For the implementors, we see that we should either handle a simple message composition or a cascade. 

### Design Concerns 
Note that sending a message to the superclass is close to subclass: and it lets the class selects 
a class definition parser if the syntax should be extended. 
In addition having a binary message makes () unneccessary.

!
!CDFluidClassDefinitionParser methodsFor: 'metaclass' stamp: ''!
handleMetaclassNameFromMessage: aNode 

	| className classNode node |
	node := aNode arguments first receiver. 
	className := node binding value class name.
	classNode := self classNameNodeClass new
		originalNode: node;
		className: className.
	classDefinition className: node astNode: classNode! !

!CDFluidClassDefinitionParser methodsFor: 'handling  nodes' stamp: ''!
handleSuperclassNode: aSuperclassNode
	| aSuperclassName newSuperclassNode |

	aSuperclassName := aSuperclassNode isLiteralNode
		ifTrue: [ nil ]
		ifFalse: [ aSuperclassNode binding value asString asSymbol ].
	newSuperclassNode := self classNameNodeClass new
		originalNode: aSuperclassNode;
		className: aSuperclassName.
	classDefinition
		superclassName: aSuperclassName
		astNode: newSuperclassNode! !

!CDFluidClassDefinitionParser methodsFor: 'handling  nodes' stamp: ''!
handleClassAndSuperclassOf: aNode

	superclassNode ifNotNil: [ self handleSuperclassNode: superclassNode ].
	self handleClassName: classNameNode.! !

!CDFluidClassDefinitionParser methodsFor: 'handling  nodes' stamp: ''!
handleSharedPoolsFromNode: aNode
	| sharedPoolNodes |
	sharedPoolNodes := aNode children
		collect: [ :aPoolNode | 
			self sharedPoolNodeClass
				node: aPoolNode
				name: aPoolNode name
				start: aPoolNode start 
				stop: aPoolNode start + aPoolNode name size
			].
	classDefinition sharedPools: sharedPoolNodes! !

!CDFluidClassDefinitionParser methodsFor: 'handling  nodes' stamp: ''!
handleTag: aNode

	classDefinition tag: (CDClassTagNode new name: aNode value)! !

!CDFluidClassDefinitionParser methodsFor: 'metaclass' stamp: ''!
handleMetaclassNameFromCascade: aRBCascadeNode 

	| className classNode node |
	node := aRBCascadeNode receiver arguments first. 
	className := node receiver binding value class name.
	classNode := self classNameNodeClass new
		originalNode: node;
		className: className.
	classDefinition className: node astNode: classNode! !

!CDFluidClassDefinitionParser methodsFor: 'handling  nodes' stamp: ''!
handleLayout: aNode
	classDefinition layoutClass: aNode binding value! !

!CDFluidClassDefinitionParser methodsFor: 'parsing-internal' stamp: ''!
parseRootNode: expressionTree
	
	| searcher |
	searcher := RBParseTreeSearcher new.
	searcher
		matches: 'Trait << `#name' do: [:aNode :answer | 
			classNameNode := searcher variableNamed: '`#name'.
			self beTraitDefinition ];
		matches: 'Trait << `name classTrait' do: [:aNode :answer | 
			classNameNode := searcher variableNamed: '`name'.
			self beClassSideTraitDefinition ];
		matches: '`superclass << `#name' do: [:aNode :answer | 
			classNameNode := searcher variableNamed: '`#name'.			
			superclassNode := searcher variableNamed: '`superclass'.
			self beClassDefinition ];
		matches: '`superclass class << `name class' do: [:aNode :answer | 
			classNameNode := searcher variableNamed: '`name'.			
			self beMetaclassDefinition ].
		
	searcher executeTree: expressionTree.
	
	classDefinition originalNode: expressionTree.
	expressionTree acceptVisitor: self.
	^ classDefinition! !

!CDFluidClassDefinitionParser methodsFor: 'parsing-internal' stamp: ''!
visitCascadeNode: aRBCascadeNode 
	"See class comment. Here we handle the cascade version of the class definition."
	" 
	Object << #Point
			trait: TraitX;
			slots: { #foo };
			package: ''Kernel-BasicObjects'''
	"
	
	self handleClassAndSuperclassOf: aRBCascadeNode.	
	aRBCascadeNode messages do: 
		[:msg | msg selectorParts
					with: msg arguments
					do: [ :selectorPart :argument |
			self parseSelectorPart: selectorPart withArgument: argument ] ]! !

!CDFluidClassDefinitionParser methodsFor: 'parsing-internal' stamp: ''!
visitMessageNode: aRBMessageNode
	"See class comment. Here we handle the cascade version of the class definition."
	"
	Object << #Point
			package: ''Kernel-BasicObjects'''
	"		

	self handleClassAndSuperclassOf: aRBMessageNode.
	
	aRBMessageNode arguments ifEmpty: [ ^ self ].
	aRBMessageNode selectorParts
		with: aRBMessageNode arguments
		do: [ :selectorPart :argument |
			self parseSelectorPart: selectorPart withArgument: argument ]! !

!CDFluidClassDefinitionParser methodsFor: 'handling  nodes' stamp: ''!
handleSharedVariableNames: aNode 
	
	| slotNodes classVariablesString |
	classVariablesString := aNode sourceCode.
	slotNodes := aNode statements
		collect: [ :literalNode | 		
			| start literalName |
			literalName := literalNode value.
			start := aNode start + (classVariablesString findString: literalName).
			CDSharedVariableNode
				node: aNode
				name: literalName
				slotClassName: 'ClassVariableSlot'
				start: start
				stop: start + literalNode size ].
	classDefinition sharedSlots: slotNodes! !

!CDFluidClassDefinitionParser methodsFor: 'parsing-internal' stamp: ''!
parseSelectorPart: aString withArgument: aNode 
	"We could do this with reflection, or with a dictionary and closures.
	I chose to use a series of if for readability only."
	
	aString =	 #slots:
		ifTrue: [ ^ self handleSlotsNodesFromArrayNode: aNode ].
	aString =	 #sharedVariables: 
		ifTrue: [ ^ self handleSharedVariableNames: aNode ].	
	aString =	 #package:
		ifTrue: [ ^ self handlePackage: aNode ].
	aString = #layout:
		ifTrue: [ ^ self handleLayout: aNode ].	
	aString = #tag: 
		ifTrue: [  ^self handleTag: aNode ].
	aString =	 #traits:
		ifTrue: [ ^ self handleTraitUsesFromNode: aNode ].
	aString =	 #sharedPools:
		ifTrue: [ ^ self handleSharedPoolsFromNode: aNode ].
	
	CDUnrecognizedClassPart new
		classDefinition: self; 
		unrecognizedPart: aString;
		signal! !

!CDFluidClassDefinitionParser class methodsFor: 'parsing' stamp: ''!
fromASTNode: aNode 
	
	^ self new parseRootNode: aNode! !

!CDFluidClassParserTest methodsFor: 'tests - rb xp' stamp: ''!
testWithRB4

	| searcher coll|
	searcher := RBParseTreeSearcher new.
	coll := OrderedCollection new. 
	searcher
		matches: '`@tm := `@val' do: [:aNode :answer | coll add: aNode ];
		matches: '^`@anything' do: [:aNode :answer | coll add: aNode].
	searcher executeTree: (RBParser parseMethod: 'foo 
	| tmp | 
	tmp := 22.
	tmp := 55.
	^ 42').
	self assert: coll size equals: 3! !

!CDFluidClassParserTest methodsFor: 'tests - (r) sharedPools' stamp: ''!
testSharedPools

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
	   sharedPools: {TextConstants};
		package: #MyPackage'.
	
	def := parser parse: defString.
	self assert: def sharedPools first name equals: 'TextConstants'! !

!CDFluidClassParserTest methodsFor: 'tests - (r) kinds' stamp: ''!
testEphemeronSubclass

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		layout: EphemeronLayout;
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def layoutClass equals: EphemeronLayout! !

!CDFluidClassParserTest methodsFor: 'tests - (r) traits' stamp: ''!
testTraitSequence

	| parser defString def |
	parser := self classDefinitionParserClass new.
	defString := 'Object << #MyObject
		traits: MyTrait + (AnotherTrait - {#selector} @ {#selector1 -> #selector});
		package: #MyPackage'.

	def := parser parse: defString.
	self assert: def traitDefinition class equals: CDTraitCompositionSequenceNode. 
	self assert: def traitDefinition sequence size equals: 2.
	self assert: (def traitDefinition sequence second aliases values) equals: #(selector).
	self assert: (def traitDefinition sequence second aliases keys) equals: #(selector1).
	self assert: def traitDefinition sequence first name equals: #MyTrait.! !

!CDFluidClassParserTest methodsFor: 'tests - (r) slots' stamp: ''!
testTypedSlots

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		slots: { #inst => InstanceVariableSlot };
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def slots size equals: 1.
	self assert: def slots first name equals: #inst.! !

!CDFluidClassParserTest methodsFor: 'tests - (r) class side' stamp: ''!
testClassSideEmpty

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object class << AlignmentMorph class
		'.		
	def := parser parse: defString.
	self assert: def class equals: CDMetaclassDefinitionNode.! !

!CDFluidClassParserTest methodsFor: 'tests - rb xp' stamp: ''!
testWithRB7

	| searcher coll|
	searcher := RBParseTreeSearcher new.
	coll := OrderedCollection new. 
	searcher
		matches: '`@tm << `#symb' do: [:aNode :answer | coll add: #instance ];
		matches: '`@tm class << `@symb class' do: [:aNode :answer | coll add: #class ];
		matches: 'Trait << `#traitSymbol' do: [:aNode :answer | coll add: #traitInstance ];
		matches: 'Trait << `@symb classTrait' do: [:aNode :answer | coll add: #traitClass ].
	searcher executeTree: (RBParser parseExpression: '
		Trait << #TPoint classTrait
		  slots: { #x . #y };
			package: ''Foo''
	') .
	self assert: coll first equals: #traitClass.
	self assert: coll size equals: 1.! !

!CDFluidClassParserTest methodsFor: 'tests - (r) kinds' stamp: ''!
testVariableSubclass

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		layout: VariableLayout;
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def layoutClass equals: VariableLayout! !

!CDFluidClassParserTest methodsFor: 'tests - (r) tags' stamp: ''!
testTag

	| parser defString def |
	parser := self classDefinitionParserClass new.
	defString := 'Object << #MyObject
		tag: ''tag1'';
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def tag name equals: 'tag1'! !

!CDFluidClassParserTest methodsFor: 'tests - (r) traits' stamp: ''!
testTraitPlainSimple

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		traits: MyTrait;
		package: #MyPackage'.
		
	def := parser parse: defString.
	self assert: def traitDefinition name equals: #MyTrait.! !

!CDFluidClassParserTest methodsFor: 'tests - (r) simple class definition' stamp: ''!
testSimpleDefinitionPackageIsCorrect
	
	| def |
	def := self classDefinitionParserClass parse: 'Object << #Point
			package: ''Kernel-BasicObjects'''.
	self assert: def packageName equals: 'Kernel-BasicObjects'! !

!CDFluidClassParserTest methodsFor: 'tests - (r) traits' stamp: ''!
testTraitEmpty

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		uses: {};
		package: #MyPackage'.
		
	def := parser parse: defString.
	self assert: def traitDefinition equals: nil! !

!CDFluidClassParserTest methodsFor: 'tests - rb xp' stamp: ''!
testWithRB6

	| searcher coll|
	searcher := RBParseTreeSearcher new.
	coll := OrderedCollection new. 
	searcher
		matches: '`@tm << `#symb' do: [:aNode :answer | coll add: #instance ];
		matches: '`@tm class << `@symb class' do: [:aNode :answer | coll add: #class ];
		matches: 'Trait << `#traitSymbol' do: [:aNode :answer | coll add: #traitInstance ];
		matches: 'Trait << `@symb classTrait' do: [:aNode :answer | coll add: #traitClass ].
	searcher executeTree: (RBParser parseExpression: '
		Object class << #Point class
		  slots: { #x . #y };
			package: ''Foo''
	') .
	self assert: coll first equals: #class.
	self assert: coll size equals: 1.! !

!CDFluidClassParserTest methodsFor: 'tests - rb xp' stamp: ''!
testWithRB8

	| searcher coll|
	searcher := RBParseTreeSearcher new.
	coll := OrderedCollection new. 
	searcher
		matches: 'Trait << `#traitSymbol' do: [:aNode :answer | coll add: #traitInstance ];
		matches: '`@tm << `#symb' do: [:aNode :answer | coll add: #instance ];
		matches: '`@tm class << `@symb class' do: [:aNode :answer | coll add: #class ];
		matches: 'Trait << `@symb classTrait' do: [:aNode :answer | coll add: #traitClass ].
	searcher executeTree: (RBParser parseExpression: '
		Trait << #Point
		  slots: { #x . #y };
			package: ''Foo''
	') .
	self assert: coll size equals: 1.
	self assert: coll first equals: #traitInstance.! !

!CDFluidClassParserTest methodsFor: 'tests - (r) slots' stamp: ''!
testSimpleSlots

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		slots: { #a. #b };
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def slots size equals: 2.
	self assert: def slots first name equals: #a. 
	self assert: def slots second name equals: #b.! !

!CDFluidClassParserTest methodsFor: 'tests - (r) simple class definition' stamp: ''!
testSimpleDefinitionClassNode

	| def |
	def := self classDefinitionParserClass parse: 'Object << #Point
			package: ''Kernel-BasicObjects'''.

	self assert: def classNameNode className equals: #Point.
	
	"The following cannot work 
	
		self assert: def classNameNode binding value equals: Point. 
	
	because binding is defined as 
	
		existingBindingIfAbsent: aBlock

			| binding |
			binding := originalNode methodNode compilationContext environment bindingOf: className.
			^ binding ifNil: aBlock
	
	"! !

!CDFluidClassParserTest methodsFor: 'tests - (r) class variables' stamp: ''!
testClassVariables

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		sharedVariables: { #A . #B };
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def sharedSlots first name equals: #A. 
	self assert: def sharedSlots second name equals: #B.! !

!CDFluidClassParserTest methodsFor: 'tests - rb xp' stamp: ''!
testWithRB

	| dict searcher |
	searcher := RBParseTreeSearcher new.
	searcher 
		matches: '`superklass << `#ClassName
		slots: {};
		sharedVariables: {};
		package: ''''' 
	 	do: [ :aNode :answer |  dict:= searcher context ].
	dict := searcher executeTree: (RBParser parseExpression: 'Object << #MyClass
		slots: {};
		sharedVariables: {};
		package: ''''').! !

!CDFluidClassParserTest methodsFor: 'tests - (r) simple class definition' stamp: ''!
testSimpleDefinition

	| def |
	def := self classDefinitionParserClass parse: 'Object << #Point
			package: ''Kernel-BasicObjects'''.
			
	self assert: def className equals: #Point.! !

!CDFluidClassParserTest methodsFor: 'tests - (r) kinds' stamp: ''!
testWeakSubclass

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		layout: WeakLayout;
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def layoutClass equals: WeakLayout! !

!CDFluidClassParserTest methodsFor: 'tests - (r) simple class definition' stamp: ''!
testInstanceDefinitionIsInstanceSide

	| def |
	def := self classDefinitionParserClass parse: 'Object << #Point
			package: ''Kernel-BasicObjects'''.

	self assert: def isInstanceSide! !

!CDFluidClassParserTest methodsFor: 'running' stamp: ''!
classDefinitionParserClass

	^ CDFluidClassDefinitionParser! !

!CDFluidClassParserTest methodsFor: 'tests - (r) kinds' stamp: ''!
testVariableByteSubclass

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		layout: ByteLayout;
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def layoutClass equals: ByteLayout! !

!CDFluidClassParserTest methodsFor: 'tests - rb xp' stamp: ''!
testWithRB10

	| searcher kind |
	searcher := RBParseTreeSearcher new.
	searcher
		matches: 'Trait << `#traitSymbol' do: [:aNode :answer | kind := #traitInstance ];
		matches: 'Trait << `@symb classTrait' do: [:aNode :answer | kind := #traitClass ];
		matches: '`@tm << `#symb' do: [:aNode :answer | kind := #instance ];
		matches: '`@tm class << `@symb class' do: [:aNode :answer | kind := #class ].
	searcher executeTree: (RBParser parseExpression: '
		Trait << TViewModelMock3 classTrait
	') .
	self assert: kind equals: #traitClass.! !

!CDFluidClassParserTest methodsFor: 'tests - (r) class side' stamp: ''!
testClassSideWithTraits

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object class << AlignmentMorph class
		traits: TableRotate classTrait;
		slots: { #x . #y}'.
		
	def := parser parse: defString.
	self assert: def class equals: CDMetaclassDefinitionNode.
	self assert: def hasTraitComposition.
	self assert: def traitDefinition class equals: CDClassTraitNode.
	self assert: def traitDefinition name equals: #TableRotate.
	self assert: def slots first name equals: #x! !

!CDFluidClassParserTest methodsFor: 'tests - (r) traits' stamp: ''!
testTraitAlias

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		traits: MyTrait @ {#foo -> #bar};
		package: #MyPackage'.
	
	def := parser parse: defString.
	self assert: def traitDefinition class equals: CDTraitAliasNode. 
	self assert: (def traitDefinition aliases values) equals: #(bar).
	self assert: (def traitDefinition aliases keys) equals: #(foo).
	self assert: def traitDefinition subject name equals: #MyTrait.! !

!CDFluidClassParserTest methodsFor: 'tests - rb xp' stamp: ''!
testWithRB3

	| searcher coll|
	searcher := RBParseTreeSearcher new.
	coll := OrderedCollection new. 
	searcher
		matches: '^self' do: [:aNode :answer | coll add: aNode ];
		matches: '^`@anything' do: [:aNode :answer |  coll add: aNode].
	searcher executeTree: (RBParser parseMethod: 'foo 
	|tmp| 
	tmp := 22.
	^ 42').
	self assert: coll size equals: 1! !

!CDFluidClassParserTest methodsFor: 'tests - rb xp' stamp: ''!
testWithRB9

	| searcher coll|
	searcher := RBParseTreeSearcher new.
	coll := OrderedCollection new. 
	searcher
		matches: 'Trait << `#traitSymbol' do: [:aNode :answer | coll add: #traitInstance ];
		matches: '`@tm << `#symb' do: [:aNode :answer | coll add: #instance ];
		matches: '`@tm class << `@symb class' do: [:aNode :answer | coll add: #class ];
		matches: 'Trait << `@symb classTrait' do: [:aNode :answer | coll add: #traitClass ].
	searcher executeTree: (RBParser parseExpression: '
		Object << #MyObject
		sharedVariables: { #A . #B };
		package: ''MyPackage''
	') .
	self assert: coll size equals: 1.
	self assert: coll first equals: #instance.! !

!CDFluidClassParserTest methodsFor: 'tests - (r) simple class definition' stamp: ''!
testClassSideDefinitionIsClassSide

	| def |
	def := self classDefinitionParserClass parse: 'Object class << Point class
			slot: {  }'.

	self assert: def isClassSide! !

!CDFluidClassParserTest methodsFor: 'tests - rb xp' stamp: ''!
testWithRB10WithError

	| searcher kind |
	searcher := RBParseTreeSearcher new.
	searcher
		matches: 'Trait << `#traitSymbol' do: [:aNode :answer | kind := #traitInstance ];
		matches: 'Trait << `@symb classTrait' do: [:aNode :answer | kind := #traitClass ];
		matches: '`@tm << `#symb' do: [:aNode :answer | kind := #instance ];
		matches: '`@tm class << `@symb class' do: [:aNode :answer | kind := #class ].
	searcher executeTree: (RBParser parseExpression: '
		Trait << TViewModelMock3 class
	') .
	self assert: kind isNil.! !

!CDFluidClassParserTest methodsFor: 'tests - rb xp' stamp: ''!
testWithRB5

	| searcher coll|
	searcher := RBParseTreeSearcher new.
	coll := OrderedCollection new. 
	searcher
		matches: '`@tm << `#symb' do: [:aNode :answer | coll add: #instance ];
		matches: '`@tm class << `@symb class' do: [:aNode :answer | coll add: #class ];
		matches: 'Trait << `#traitSymbol' do: [:aNode :answer | coll add: #traitInstance ];
		matches: 'Trait << `@symb classTrait' do: [:aNode :answer | coll add: #traitClass ].
	searcher executeTree: (RBParser parseExpression: '
		Object << #Point
		  slots: { #x . #y };
			package: ''Foo''
	') .
	self assert: coll first equals: #instance.
	self assert: coll size equals: 1.! !

!CDFluidClassParserTest methodsFor: 'tests - (r) kinds' stamp: ''!
testNormalSubclass

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		layout: FixedLayout;
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def layoutClass equals: FixedLayout! !

!CDFluidClassParserTest methodsFor: 'tests - (r) kinds' stamp: ''!
testVariableWordSubclass

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		layout: WordLayout;
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def layoutClass equals: WordLayout! !

!CDFluidClassParserTest methodsFor: 'tests - (r) slots' stamp: ''!
testEmptySlots

	| parser defString def |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		slots: {};
		package: #MyPackage'.
	def := parser parse: defString.
	self assert: def slots isEmpty! !

!CDFluidClassParserTest methodsFor: 'tests - (r) simple class definition' stamp: ''!
testSimpleDefinitionSuperclassName

	| def |
	def := self classDefinitionParserClass parse: 'Object << #Point
			package: ''Kernel-BasicObjects'''.
			
	self assert: def superclassName equals: 'Object'! !

!CDFluidClassParserTest methodsFor: 'tests - (r) slots' stamp: ''!
testComplexSlots

	| parser defString def slot |
	parser := self classDefinitionParserClass new.
	
	defString := 'Object << #MyObject
		slots: { #inst => (InstanceVariableSlot default: 5) };
		package: #MyPackage'.
	def := parser parse: defString.
	slot := def slots first.
	self assert: slot name equals: #inst. 
	self assert: slot initializationMessage selectorParts equals: #(#default:).
	self assert: (slot initializationMessage argumentParts collect: [:each | each value]) equals: #(5) asOrderedCollection! !

!CDImmediateClassParserTest methodsFor: 'helpers' stamp: ''!
testImmediateClassIsImmediate

	self assert: classDefinition layoutClass equals: ImmediateLayout! !

!CDImmediateClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ '{superclassName} immediateSubclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		package: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. } asDictionary! !

!CDMetaclassDefinitionNode methodsFor: 'testing' stamp: ''!
selector 

	^ tokens at: 3! !

!CDMetaclassDefinitionNode methodsFor: 'accessing' stamp: ''!
existingClassIfAbsent: aBlock
	| existingClass |
	existingClass := super existingClassIfAbsent: aBlock.	
	^existingClass classSide! !

!CDMetaclassDefinitionNode methodsFor: 'testing' stamp: ''!
isInstanceSide
	^ false! !

!CDMetaclassDefinitionNode methodsFor: 'testing' stamp: ''!
isClassSide
	^ true! !

!CDMetaclassParserTest methodsFor: 'introspection' stamp: ''!
className
	"Answer a string characterizing the receiver's class, for use in list views for example"

	^ self class name asString! !

!CDMetaclassParserTest methodsFor: 'tests' stamp: ''!
testClassDefFromLegacyStringHasClassNameNode

	self assert: classDefinition classNameNode value equals: self className.! !

!CDMetaclassParserTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ self == CDMetaclassParserTest! !

!CDMetaclassWithTraitParserTest methodsFor: 'helpers' stamp: ''!
classTraitName
	^ 'TApplyingOnClassSide'! !

!CDMetaclassWithTraitParserTest methodsFor: 'helpers' stamp: ''!
traitDefinition

	^ self classTraitName! !

!CDMetaclassWithTraitParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString
	
	^ '{className} class 
		uses: {classTraitName} classTrait
		instanceVariableNames: ''{instvar1} {instvar2}'''
			format: { 
				'className' -> self className.	
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classTraitName' -> self classTraitName
			 } asDictionary! !

!CDMetaclassWithTraitParserTest methodsFor: 'helpers' stamp: ''!
testTraitDefinitionNodeIsTraitNode

	self assert: self traitCompositionNode isTraitNode! !

!CDMetaclassWithTraitParserTest methodsFor: 'helpers' stamp: ''!
traitCompositionNode
	
	^ self nodeFor: self traitDefinition! !

!CDNilSubclassParserTest methodsFor: 'helpers' stamp: ''!
superclassName

	^ 'nil'! !

!CDNode commentStamp: ''!
I'm the common superclass of all the class definition nodes.
A class definition is an object that is built out of the message sent to a class by the class definition parser.

I keep a reference to the original method node (originalNode) I'm created from.

Please note the vocabulary, we use the term class definition and class definition parser to refer to the class definition only and not the class with its methods.!
!CDNode methodsFor: 'selection' stamp: ''!
stop
	
	^ originalNode stop! !

!CDNode methodsFor: 'accessing' stamp: ''!
classDefinitionNode
	^parent classDefinitionNode! !

!CDNode methodsFor: 'accessing' stamp: ''!
originalNodeSource

	^originalNode source.! !

!CDNode methodsFor: 'selection' stamp: ''!
children

	^ children! !

!CDNode methodsFor: 'accessing' stamp: ''!
parent: anObject
	parent := anObject! !

!CDNode methodsFor: 'selection' stamp: ''!
containedBy: anInterval 
	^anInterval first <= self start and: [anInterval last >= self stop]! !

!CDNode methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!CDNode methodsFor: 'selection' stamp: ''!
bestNodeFor: anInterval 
	| selectedChildren |
	(self intersectsInterval: anInterval) ifFalse: [^nil].
	(self containedBy: anInterval) ifTrue: [^self].
	selectedChildren := self children 
				select: [:each | each intersectsInterval: anInterval].
	^selectedChildren size == 1 
		ifTrue: [selectedChildren first bestNodeFor: anInterval]
		ifFalse: [self]! !

!CDNode methodsFor: 'testing' stamp: ''!
isMethod
	"To be polymorphic to RB method nodes"
	^false! !

!CDNode methodsFor: 'compatibility' stamp: ''!
ast

	^ self! !

!CDNode methodsFor: 'selection' stamp: ''!
intersectsInterval: anInterval 
	^(anInterval first between: self start and: self stop) 
		or: [self start between: anInterval first and: anInterval last]! !

!CDNode methodsFor: 'accessing' stamp: ''!
sourceInterval
	^originalNode sourceInterval! !

!CDNode methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	children := OrderedCollection new! !

!CDNode methodsFor: 'visitor' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	
	self subclassResponsibility! !

!CDNode methodsFor: 'compatibility' stamp: ''!
hasBreakpoint
	
	^ false! !

!CDNode methodsFor: 'accessing' stamp: ''!
originalNode

	^originalNode.! !

!CDNode methodsFor: 'compatibility' stamp: ''!
hasExecutionCounter
	
	^ false! !

!CDNode methodsFor: 'accessing' stamp: ''!
originalNode: aNode

	originalNode := aNode! !

!CDNode methodsFor: 'testing' stamp: ''!
isVariable
	"To be polymorphic to RB method nodes"
	^false! !

!CDNode methodsFor: 'compatibility' stamp: ''!
hasWatch
	
	^ false! !

!CDNode methodsFor: 'accessing' stamp: ''!
tokens 
	^ tokens! !

!CDNode methodsFor: 'selection' stamp: ''!
start
	
	^ originalNode start! !

!CDNode methodsFor: 'accessing' stamp: ''!
addChild: aChild

	children add: aChild.
	aChild parent: self! !

!CDNode methodsFor: 'testing' stamp: ''!
isMessage
	"To be polymorphic to RB method nodes"
	^false! !

!CDNode methodsFor: 'accessing' stamp: ''!
tokens: aCollectionOfTokens
	tokens := aCollectionOfTokens! !

!CDNode class methodsFor: 'instance creation' stamp: ''!
on: aRBMessageNode 
	
	^ self new
		originalNode: aRBMessageNode;
		yourself! !

!CDNormalClassCategoryParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ '{superclassName} subclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		category: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. } asDictionary! !

!CDNormalClassParserTest methodsFor: 'helpers' stamp: ''!
testNormalClassHasFixedLayout

	self assert: classDefinition layoutClass equals: FixedLayout! !

!CDNormalClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ '{superclassName} subclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		package: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. } asDictionary! !

!CDNormalMetaclassParserTest methodsFor: 'helpers' stamp: ''!
classTraitName
	^ 'TApplyingOnClassSide'! !

!CDNormalMetaclassParserTest methodsFor: 'helpers' stamp: ''!
traitDefinition

	^ self classTraitName! !

!CDNormalMetaclassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString
	
	^ '{className} class 
		uses: {classTraitName} classTrait
		instanceVariableNames: ''{instvar1} {instvar2}'''
			format: { 
				'className' -> self className.	
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classTraitName' -> self classTraitName
			 } asDictionary! !

!CDNormalMetaclassParserTest methodsFor: 'helpers' stamp: ''!
testTraitDefinitionNodeIsTraitNode

	self assert: self traitCompositionNode isTraitNode! !

!CDNormalMetaclassParserTest methodsFor: 'helpers' stamp: ''!
traitCompositionNode
	
	^ self nodeFor: self traitDefinition! !

!CDPackageNode commentStamp: ''!
I'm a simple node to represent the package part in a class definition.!
!CDPackageNode methodsFor: 'visitor' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	
	aProgramNodeVisitor visitPackage: self! !

!CDPackageNode methodsFor: 'accessing' stamp: ''!
packageName: anObject
	packageName := anObject! !

!CDPackageNode methodsFor: 'accessing' stamp: ''!
value 
	"to be compatible with the default CDClassDefinitionNode definition.
	There a package is just an RBLiteralNode and it may be a PackageNode too."
	
	^ packageName! !

!CDPackageNode methodsFor: 'accessing' stamp: ''!
packageName
	^ packageName! !

!CDPointClassParserTest methodsFor: 'helpers' stamp: ''!
testProperties

	self assert: classDefinition binding equals: Point binding! !

!CDPointClassParserTest methodsFor: 'tests' stamp: ''!
superclassName
	self flag: #Revisit. "because this should be string according to superclasName method."
	^ #Object! !

!CDPointClassParserTest methodsFor: 'tests' stamp: ''!
secondClassVariableName

	^ 'YY'! !

!CDPointClassParserTest methodsFor: 'tests' stamp: ''!
firstInstanceVariableName

	^ 'x'! !

!CDPointClassParserTest methodsFor: 'helpers' stamp: ''!
packageName 
	^ #'Kernel-BasicObjects'! !

!CDPointClassParserTest methodsFor: 'tests' stamp: ''!
firstClassVariableName

	^ 'XX'! !

!CDPointClassParserTest methodsFor: 'tests' stamp: ''!
secondInstanceVariableName

	^ 'y'! !

!CDPointClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ 'Object subclass: #Point
	instanceVariableNames: ''x y''
	classVariableNames: ''XX YY''
	package: ''Kernel-BasicObjects'''! !

!CDPointClassParserTest methodsFor: 'tests' stamp: ''!
className
	self flag: #Revisit. "since it should be a string according to className" 
	^ #Point! !

!CDSharedPoolNode commentStamp: ''!
I represent a shared pool of a class. Shared are objects shared between classes.!
!CDSharedPoolNode methodsFor: 'accessing' stamp: ''!
node: aRBLiteralValueNode 
	originalNode := aRBLiteralValueNode! !

!CDSharedPoolNode methodsFor: 'accessing' stamp: ''!
name
	^name! !

!CDSharedPoolNode methodsFor: 'accessing' stamp: ''!
name: aString 
	name := aString! !

!CDSharedPoolNode methodsFor: 'accessing' stamp: ''!
stop: anInteger 
	stop := anInteger! !

!CDSharedPoolNode methodsFor: 'accessing' stamp: ''!
start: anInteger 
	start := anInteger! !

!CDSharedPoolNode class methodsFor: 'instance creation' stamp: ''!
node: aRBLiteralValueNode name: aString start: anInteger stop: anInteger2
	^ self new
			node: aRBLiteralValueNode;
			name: aString;
			 start: anInteger;
			 stop: anInteger2;
			yourself! !

!CDSharedVariableNode methodsFor: 'testing' stamp: ''!
isClassVariable
	"To be polymorphic to RB method nodes"
	^true! !

!CDSharedVariableNode methodsFor: 'transforming' stamp: ''!
asClassVariable
	^ ClassVariable named: self name.! !

!CDSharedVariableNode methodsFor: 'testing' stamp: ''!
isGlobalClassNameBinding
	"To be polymorphic to RB method nodes"
	^false! !

!CDSharedVariableNode methodsFor: 'testing' stamp: ''!
isVariable
	"To be polymorphic to RB method nodes"
	| existingClass |
	existingClass := self classDefinitionNode existingClassIfAbsent: [
		"Until class will be created the variables does not exist yet"
		^false ].
	^existingClass hasClassVarNamed: name asSymbol! !

!CDSharedVariableNode methodsFor: 'testing' stamp: ''!
isInstanceVariable
	"To be polymorphic to RB method nodes"
	^false! !

!CDSharedVariableNode methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
asCalypsoVariableOf: aClass

	| actualClass classVar |
	actualClass := self classDefinitionNode existingClassIfAbsent: [
		self error: 'Class is not exists yet'].
	classVar := actualClass classVariableNamed: name asSymbol.
	^ClyClassVariable on: classVar definedIn: actualClass! !

!CDSharedVariableNode methodsFor: 'testing' stamp: ''!
isLiteralVariable
	"To be polymorphic to RB method nodes"
	^true! !

!CDSharedVariableNode class methodsFor: 'instance creation' stamp: ''!
slot: aSlot node: aNode 
	
	^ self new
		slot: aSlot;
		node: aNode;
		yourself! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
sourceInterval
	^start to: stop! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
initializationMessage: aMessageNode 
	
	initializationMessage := aMessageNode! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
node: aNode 
	node := aNode! !

!CDSlotNode methodsFor: 'testing' stamp: ''!
isUndeclaredVariable
	"To be polymorphic to RB method nodes"
	^false! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
slotClassName: aSymbol 
	
	slotClassName := aSymbol! !

!CDSlotNode methodsFor: 'selection' stamp: ''!
stop
	^ stop! !

!CDSlotNode methodsFor: 'transforming' stamp: ''!
asSlot
	"for not this only supports instance variable slots. 
	We need to create a slot here using the slot class and initialization message"
	^InstanceVariableSlot named: name! !

!CDSlotNode methodsFor: 'testing' stamp: ''!
isClassVariable
	"To be polymorphic to RB method nodes"
	^false! !

!CDSlotNode methodsFor: 'testing' stamp: ''!
isWorkspaceVariable
	^ false! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
binding
	"To be polymorphic to RB method nodes"
	^self! !

!CDSlotNode methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self class name;
		nextPutAll: '(';
		print: name ;
		nextPutAll: ' => ';
		print: slotClassName;
		nextPutAll: ')'! !

!CDSlotNode methodsFor: 'testing' stamp: ''!
isTempVariable
	"To be polymorphic to RB method nodes"
	^false! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!CDSlotNode methodsFor: 'testing' stamp: ''!
isVariable
	"To be polymorphic to RB method nodes"
	| existingClass |
	existingClass := self classDefinitionNode existingClassIfAbsent: [   
		"Until class will be created the variables does not exist yet" 
		^false ].
	^existingClass 
		slotNamed: name asSymbol 
		ifFound: [true] 
		ifNone: [
			"Until class will be compiled with new slot the new slot does not exist yet"
			false]! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
name: aString

	name := aString! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
stop: anInteger 
	
	stop := anInteger! !

!CDSlotNode methodsFor: 'selection' stamp: ''!
start

	^ start! !

!CDSlotNode methodsFor: 'testing' stamp: ''!
isInstanceVariable
	"To be polymorphic to RB method nodes"
	^true! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
slotClassName
	"Return a symbol representing the class of the slot: i.e., 'x' => InstanceVariableSlot slotClassName returns 
	#InstanceVariableSlot"
	
	^ slotClassName! !

!CDSlotNode methodsFor: 'testing' stamp: ''!
isGlobalVariable
	"To be polymorphic to RB method nodes"
	^false! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
start: anInteger 
	start := anInteger! !

!CDSlotNode methodsFor: 'accessing' stamp: ''!
initializationMessage
	"Return the message node representing the initialization part of a slot."
	
	^ initializationMessage! !

!CDSlotNode methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
asCalypsoVariableOf: aClass 
	
	| actualClass |
	actualClass := self classDefinitionNode existingClassIfAbsent: [
		self error: 'Class is not exists yet'].
	^actualClass 
		slotNamed: name asSymbol 
		ifFound: [:aSlot | 
			^ClyInstanceVariable on: aSlot definedIn: actualClass] 
		ifNone: [self error: 'Slot is not created yet']! !

!CDSlotNode methodsFor: 'testing' stamp: ''!
isLiteralVariable
	"To be polymorphic to RB method nodes"
	^false! !

!CDSlotNode class methodsFor: 'instance creation' stamp: ''!
node: aNode name: aName slotClassName: aSymbol initializationMessage: aMessageNode start: start stop: stop
	
	^ self new
		node: aNode;
		name: aName;
		slotClassName: aSymbol;
		initializationMessage: aMessageNode;
		start: start;
		stop: stop;
		yourself! !

!CDSlotNode class methodsFor: 'instance creation' stamp: ''!
node: aNode name: aName slotClassName: aSymbol start: start stop: stop
	
	^ self new
		node: aNode;
		name: aName;
		slotClassName: aSymbol;
		start: start;
		stop: stop;
		yourself! !

!CDTraitAliasNode commentStamp: ''!
MyTrait @ {#aliasName -> #existingSelectorName}!
!CDTraitAliasNode methodsFor: 'accessing' stamp: ''!
aliases
	^ aliases! !

!CDTraitAliasNode methodsFor: 'testing' stamp: ''!
isTraitAliasNode
	
	^ true! !

!CDTraitAliasNode methodsFor: 'accessing' stamp: ''!
aliasName
	
	^ aliasName! !

!CDTraitAliasNode methodsFor: 'printing' stamp: ''!
toString 
	"should replace aliasName"
	^ subject name, ' -> ', aliasName! !

!CDTraitAliasNode methodsFor: 'accessing' stamp: ''!
aliases: aCollection 
	aliases := aCollection asDictionary! !

!CDTraitCompositionBuilder commentStamp: ''!
I am in charge of building a Trait composition. 

aTraitCompositionNode is composed of TraitNode.!
!CDTraitCompositionBuilder methodsFor: 'visiting' stamp: ''!
visitGlobalVariableNode: aRBGlobalNode 
	
	^self visitVariableNode: aRBGlobalNode! !

!CDTraitCompositionBuilder methodsFor: 'visiting' stamp: ''!
visitLiteralValueNode: aRBLiteralValueNode
	"Redirect the message by default to #visitLiteralNode: for retrocompatibility (pharo 8)"

	^ self visitLiteralNode: aRBLiteralValueNode! !

!CDTraitCompositionBuilder methodsFor: 'visiting' stamp: ''!
visitGlobalNode: aRBGlobalNode 
	
	^self visitVariableNode: aRBGlobalNode! !

!CDTraitCompositionBuilder methodsFor: 'visiting' stamp: ''!
visitLiteralVariableNode: aRBGlobalNode 
	
	^self visitVariableNode: aRBGlobalNode! !

!CDTraitCompositionBuilder methodsFor: 'visiting' stamp: ''!
visitLiteralNode: aRBLiteralValueNode 
	
	^ aRBLiteralValueNode value! !

!CDTraitCompositionBuilder methodsFor: 'visiting' stamp: ''!
visitArrayNode: aRBArrayNode 
	| parent argumentName |
	self flag: #todo. 
	"It needs to be refactored. I do not know how it was supposed to be handle properly.
	Here is workaround to fix issue with empty #uses section"
	parent := aRBArrayNode parent.
	parent isMessage ifTrue: [ 
		argumentName := parent keywords at: (parent arguments indexOf: aRBArrayNode).
		(argumentName = #uses:) | (argumentName = #traits:) ifTrue: [ 
			aRBArrayNode statements 
				ifEmpty: [ 
					^CDTraitCompositionSequenceNode new 
						sequence: #();
						originalNode: aRBArrayNode;
						yourself]
				ifNotEmpty: [ :stm | ^ CDTraitCompositionSequenceNode new 
											sequence: {stm first acceptVisitor: self} ;
											originalNode: aRBArrayNode;
											yourself
									]]].
	
	^aRBArrayNode statements collect: [ :each | 
		each isLiteralNode
			ifTrue: [ each value ]
			ifFalse: [ each receiver value -> each arguments first value ] ]! !

!CDTraitCompositionBuilder methodsFor: 'visiting' stamp: ''!
visitMessageNode: aRBMessageNode 
	
	| node receiver argument |
	
	aRBMessageNode selector = #classTrait
		ifTrue: [ 
			^ CDClassTraitNode new
				originalNode: aRBMessageNode;
				name: aRBMessageNode receiver name;
				yourself  ].
	
	receiver := aRBMessageNode receiver acceptVisitor: self.
	argument := aRBMessageNode arguments first acceptVisitor: self.
	
	node := receiver perform: aRBMessageNode selector with: argument.
	node originalNode: aRBMessageNode.
	^ node! !

!CDTraitCompositionBuilder methodsFor: 'visiting' stamp: ''!
visitVariableNode: aRBVariableNode 
	
	^ CDTraitNode new
		originalNode: aRBVariableNode;
		name: aRBVariableNode name;
		yourself! !

!CDTraitCompositionBuilder methodsFor: 'building' stamp: ''!
buildFrom: aNode
	
	^ aNode acceptVisitor: self! !

!CDTraitCompositionClassParserTest methodsFor: 'tests' stamp: ''!
testBestNodeForTraitCompositionSelectionShouldBeTraitComposition

	| selectedNode start selection |	
	start := self traitDefinitionIndex.
	selection := start to: start.
	
	selectedNode := classDefinition bestNodeFor: selection.
	self assert: selectedNode isTraitComposition! !

!CDTraitCompositionClassParserTest methodsFor: 'helpers' stamp: ''!
traitDefinitionIndex

	^ self classDefinitionString findString: self traitDefinition! !

!CDTraitCompositionClassParserTest methodsFor: 'helpers' stamp: ''!
traitDefinition

	self subclassResponsibility! !

!CDTraitCompositionClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

^ '{superclassName} subclass: #{classname}
		uses: {traitDefinition}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		package: #MyPackage'
			format: {
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName.
				'traitDefinition' -> self traitDefinition } asDictionary! !

!CDTraitCompositionClassParserTest methodsFor: 'helpers' stamp: ''!
traitCompositionNode
	
	^ self nodeFor: self traitDefinition! !

!CDTraitCompositionClassParserTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == CDTraitCompositionClassParserTest! !

!CDTraitCompositionNode commentStamp: ''!
Operations on traits
	- exclusion
	- +
	- alias
	!
!CDTraitCompositionNode methodsFor: 'accessing' stamp: ''!
subject: aNode

	subject := aNode! !

!CDTraitCompositionNode methodsFor: 'accessing' stamp: ''!
subject 
	^subject! !

!CDTraitCompositionSequenceNode commentStamp: ''!
use: T1 + T2!
!CDTraitCompositionSequenceNode methodsFor: 'testing' stamp: ''!
isTraitSequenceNode
	
	^ true! !

!CDTraitCompositionSequenceNode methodsFor: 'accessing' stamp: ''!
sequence: aCollection 
	sequence := aCollection! !

!CDTraitCompositionSequenceNode methodsFor: 'printing' stamp: ''!
toString 
	| res |
	res := (self sequence at: 1) toString, ' + ', (self sequence at: 2) toString.
	^ res! !

!CDTraitCompositionSequenceNode methodsFor: 'precedence' stamp: ''!
withPrecedenceOf: aCDTraitNode

	^ (CDTraitPrecedenceCompositionNode new)
			sequence: sequence;
			preferedTrait: aCDTraitNode;
			yourself! !

!CDTraitCompositionSequenceNode methodsFor: 'accessing' stamp: ''!
sequence
	^sequence! !

!CDTraitDefinitionNode commentStamp: ''!
I represent the definition of a Trait e.g.,

```
Trait named: TBehavior
	uses: Trait2;
	package: 'Kernel'
```!
!CDTraitDefinitionNode methodsFor: 'visitor' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	
	self visitTraitDefinition: self! !

!CDTraitExclusionNode commentStamp: ''!
MyTrait - {#aliasName}!
!CDTraitExclusionNode methodsFor: 'testing' stamp: ''!
isTraitExclusionNode
	
	^ true! !

!CDTraitExclusionNode methodsFor: 'printing' stamp: ''!
toString
	"should replace Exclusions"
	^ subject name ,' - ', exclusions asString.! !

!CDTraitExclusionNode methodsFor: 'accessing' stamp: ''!
exclusions: aCollection 
	exclusions := aCollection! !

!CDTraitNode commentStamp: ''!
I represent a simple Trait. (no composition, alias, exclusion)!
!CDTraitNode methodsFor: 'accessing' stamp: ''!
name
	^name! !

!CDTraitNode methodsFor: 'accessing' stamp: ''!
name: aString 
	name := aString! !

!CDTraitNode methodsFor: 'printing' stamp: ''!
toString 
	^ self name! !

!CDTraitNode methodsFor: 'testing' stamp: ''!
isTraitNode

	^ true! !

!CDTraitParserTest methodsFor: 'running' stamp: ''!
classDefinitionParserClass

	^ CDFluidClassDefinitionParser! !

!CDTraitParserTest methodsFor: 'tests - slots' stamp: ''!
testSimpleDefinitionWithTypedSlots

	| def |
	def := self classDefinitionParserClass parse: 'Trait << #TPoint2
			slots: { #inst => InstanceVariableSlot };
			package: ''Kernel-BasicObjects'''.
	"please rename class name!!!!!! it should be class"
	self assert: def className equals: #TPoint2.
	self assert: def slots first name equals: #inst.
	self assert: def packageName equals:  #'Kernel-BasicObjects'! !

!CDTraitParserTest methodsFor: 'tests - trait users' stamp: ''!
testWithUses

	| def |
	def := self classDefinitionParserClass parse: 'Trait << #TPoint2
			traits: TViewInModel;
			package: ''Kernel-BasicObjects'''.
	"please rename class name!!!!!! it should be class"
	self assert: def className equals: #TPoint2.
	self assert: def traitDefinition name equals: #TViewInModel.
	self assert: def packageName equals:  #'Kernel-BasicObjects'! !

!CDTraitParserTest methodsFor: 'tests - slots' stamp: ''!
testSimpleDefinitionWithEmptySlots

	| def |
	def := self classDefinitionParserClass parse: 'Trait << #TPoint2
			slots: {  };
			package: ''Kernel-BasicObjects'''.
	"please rename class name!!!!!! it should be class"
	self assert: def className equals: #TPoint2.
	self assert: def slots isEmpty.
	self assert: def packageName equals:  #'Kernel-BasicObjects'! !

!CDTraitParserTest methodsFor: 'tests - trait users' stamp: ''!
testClassSideOfATrait
	"MetaclassForTraits allInstances select: [ :each | each hasTraitComposition ]"
	| def |
	def := self classDefinitionParserClass parse: 'Trait << Trait3 classTrait
	traits: {Trait2 classTrait}'.

	self assert: def className equals: #Trait3.
	self assert: def class equals: CDClassSideTraitDefinitionNode.
	self assert: def traitDefinition sequence first name equals: #Trait2.! !

!CDTraitParserTest methodsFor: 'tests - slots' stamp: ''!
testSimpleDefinitionWithSlots

	| def |
	def := self classDefinitionParserClass parse: 'Trait << #TPoint2
			slots: { #x . #y };
			package: ''Kernel-BasicObjects'''.
	"please rename class name!!!!!! it should be class"
	self assert: def className equals: #TPoint2.
	self assert: def slots first name equals: #x. 
	self assert: def slots second name equals: #y. 
	self assert: def packageName equals:  #'Kernel-BasicObjects'! !

!CDTraitParserTest methodsFor: 'tests - trait users' stamp: ''!
testWithEmptyUses

	| def |
	def := self classDefinitionParserClass parse: 'Trait << #TPoint2
			traits: {  };
			package: ''Kernel-BasicObjects'''.
	"please rename class name!!!!!! it should be class"
	self assert: def className equals: #TPoint2.
	self assert: def traitDefinition equals: nil.
	self assert: def packageName equals:  #'Kernel-BasicObjects'! !

!CDTraitParserTest methodsFor: 'tests - simple trait definition' stamp: ''!
testSimpleDefinition

	| def |
	def := self classDefinitionParserClass parse: 'Trait << #TPoint
			package: ''Kernel-BasicObjects'''.
	"please rename class name!!!!!! it should be class"
	self assert: def className equals: #TPoint.
	self assert: def packageName equals:  #'Kernel-BasicObjects'! !

!CDTraitPrecedenceCompositionNode methodsFor: 'accessing' stamp: ''!
preferedTrait
	^ preferedTrait! !

!CDTraitPrecedenceCompositionNode methodsFor: 'accessing' stamp: ''!
preferedTrait: anObject
	preferedTrait := anObject! !

!CDTraitSlotRemoveNode commentStamp: ''!
MyTrait -- {#slotName}!
!CDTraitSlotRemoveNode methodsFor: 'accessing' stamp: ''!
removedSlots: anObject

	removedSlots := anObject! !

!CDTraitSlotRemoveNode methodsFor: 'accessing' stamp: ''!
removedSlots

	^ removedSlots! !

!CDTraitSlotRemoveNode methodsFor: 'printing' stamp: ''!
toString
	^ subject name ,' -- ', removedSlots asString.! !

!CDTraitSlotRenameNode commentStamp: ''!
MyTrait @@ {#ivar -> ivar2 }!
!CDTraitSlotRenameNode methodsFor: 'printing' stamp: ''!
toString
	^ subject name ,' @@ ', renames asString.! !

!CDTraitSlotRenameNode methodsFor: 'accessing' stamp: ''!
renames

	^ renames! !

!CDTraitSlotRenameNode methodsFor: 'accessing' stamp: ''!
renames: anObject

	renames := anObject! !

!CDUnrecognizedClassPart commentStamp: ''!
I'm an error (notification) signaled when a part of a class definition is not recognized. !
!CDUnrecognizedClassPart methodsFor: 'accessing' stamp: ''!
classDefinition: aNode
	classDefinition := aNode! !

!CDUnrecognizedClassPart methodsFor: 'accessing' stamp: ''!
unrecognizedPart: aString 
	unrecognizedPart := aString! !

!CDVariableByteClassParserTest methodsFor: 'helpers' stamp: ''!
testVariableByteClassIsBytes

	self assert: classDefinition layoutClass equals: ByteLayout! !

!CDVariableByteClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ '{superclassName} variableByteSubclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		package: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. } asDictionary! !

!CDVariableClassParserTest methodsFor: 'helpers' stamp: ''!
testVariableClassIsVariable

	self assert: classDefinition layoutClass equals: VariableLayout! !

!CDVariableClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ '{superclassName} variableSubclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		package: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. } asDictionary! !

!CDVariableWordClassParserTest methodsFor: 'helpers' stamp: ''!
testVariableWordClassIsWords

	self assert: classDefinition layoutClass equals: WordLayout! !

!CDVariableWordClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ '{superclassName} variableWordSubclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		package: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. } asDictionary! !

!CDWeakClassParserTest methodsFor: 'helpers' stamp: ''!
testWeakClassIsWeak

	self assert: classDefinition layoutClass equals: WeakLayout! !

!CDWeakClassParserTest methodsFor: 'helpers' stamp: ''!
classDefinitionString

	^ '{superclassName} weakSubclass: #{classname}
		instanceVariableNames: ''{instvar1} {instvar2}''
		classVariableNames: ''{classvar1} {classvar2}''
		package: #MyPackage'
			format: { 
				'classname' -> self className.
				'superclassName' -> self superclassName.
				'instvar1' -> self firstInstanceVariableName.
				'instvar2' -> self secondInstanceVariableName.
				'classvar1' -> self firstClassVariableName.
				'classvar2' -> self secondClassVariableName. } asDictionary! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - cascade' stamp: ''!
testCaretInCascadeFirstMessageShouldMatchFirstMessage

	| cascade |
	self sourceCodeOf: self class >> #methodWithCascade.
	
	cascade := ast statements first value.
	self caretInMiddleOfCascadeMessage: cascade messages first.
	
	self assert: self selectedSelector equals: cascade messages first selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
methodX:a

	! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
messageNodeToTest

	^ self returnNodeToTest value! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - message' stamp: ''!
testCaretAfterNestedMessageReceiverInMiddleOfArgumentName

	self sourceCodeOf: self class >> #methodWithIfTrueIfFalse.
	
	"The argument is a message node, we should match it instead of the parent"
	self caretAfter: self messageNodeToTest receiver.
	
	self assert: self selectedSelector equals: self messageNodeToTest receiver selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - method signature' stamp: ''!
testCaretInHeaderInBeforeArgumentWithoutSpaceName

	self sourceCodeOf: self class >> #methodX:.
	self caretBefore: (ast arguments at: 1).
	
	self assert: self selectedSelector equals: #methodX:! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
caretInMiddleOf: aNode 
	
	self caretAt: aNode start + 1! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
method: a zkx: bsq pn: c

	^ self aMethod: a with: (self something: bsq) x:(self perform: #selector)! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
sourceCodeOf: aMethod 
	
	sourceCode := aMethod sourceCode.
	ast := aMethod ast! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - withOutMessage' stamp: ''!
testCaretAfterALiteralArray
	| selector |
	selector := '#()'.
	sourceCode := selector.
	ast := (RBParser parseFaultyExpression: selector).
	self caretAfter: ast.
	self assert: self selectedSelector equals: #noMethod! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - message' stamp: ''!
testCaretInTheMiddleOfNestedMessageReceiverInMiddleOfArgumentName

	self sourceCodeOf: self class >> #methodWithIfTrueIfFalse.
	
	"The argument is a message node, we should match it instead of the parent"
	self caretInMiddleOf: self messageNodeToTest receiver.
	
	self assert: self selectedSelector equals: self messageNodeToTest receiver selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - blocks' stamp: ''!
testCaretInMessageInBlock

	| firstBlock messageInsideBlock |
	self sourceCodeOf: self class >> #methodWithIfTrueIfFalse.
	firstBlock := ast statements first arguments first.
	messageInsideBlock := firstBlock statements first.
	self caretInMiddleOf: messageInsideBlock.
	
	self assert: self selectedSelector equals: messageInsideBlock selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - message' stamp: ''!
testCaretInMessageInBeforeArgumentName

	self sourceCodeOf: self class >> #method:zkx:pn:.
	self caretBefore: (self messageNodeToTest arguments at: 1).
	
	self assert: self selectedSelector equals: self messageNodeToTest selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - method signature' stamp: ''!
testCaretInHeaderInMiddleOfMessageSelector

	self sourceCodeOf: self class >> #method:zkx:pn:.
	self caretInMiddleOf: self messageNodeToTest.

	self assert: self selectedSelector equals: self messageNodeToTest selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - blocks' stamp: ''!
testCaretBeforeMessageInBlock

	| firstBlock messageInsideBlock |
	self sourceCodeOf: self class >> #methodWithIfTrueIfFalse.
	firstBlock := ast statements first arguments first.
	messageInsideBlock := firstBlock statements first.
	self caretBefore: messageInsideBlock.
	
	self assert: self selectedSelector equals: messageInsideBlock selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - message' stamp: ''!
testCaretInMessageAfterArgumentName

	self sourceCodeOf: self class >> #method:zkx:pn:.
	self caretAfter: (self messageNodeToTest arguments at: 1).
	
	self assert: self selectedSelector equals: self messageNodeToTest selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
methodWithSpacesAtTheEnd
	"Please do not remove the leading spaces"
	^ 1 someMessageFollowedBySpaces  ! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - message' stamp: ''!
testCaretBeforeNestedMessageReceiverInMiddleOfArgumentName

	self sourceCodeOf: self class >> #methodWithIfTrueIfFalse.
	
	"The argument is a message node, we should match it instead of the parent"
	self caretBefore: self messageNodeToTest receiver.
	
	self assert: self selectedSelector equals: self messageNodeToTest receiver selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
caretInMiddleOfCascadeMessage: aRBMessageNode 
	
	self flag: #bug.
	"The start of a selector node should not be an integer array. That will change in the future and this test will break because of that."
	^ self caretAt: aRBMessageNode selectorNode start! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - withOutMessage' stamp: ''!
testCaretAfterADynamicArray
	| selector |
	selector := '{}'.
	sourceCode := selector.
	ast := (RBParser parseFaultyExpression: selector).
	self caretAfter: ast.
	self assert: self selectedSelector equals: #noMethod! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - return' stamp: ''!
testCaretAfterReturnShouldMatchChildCascade

	| cascade |
	self sourceCodeOf: self class >> #methodWithCascade.
	
	"Caret in middle of should put the caret after the ^"
	self caretInMiddleOf: self returnNodeToTest.
	
	cascade := self returnNodeToTest value.
	self assert: self selectedSelector equals: cascade messages first selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
caretAt: aPosition 

	position := aPosition! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - blocks' stamp: ''!
testCaretAfterFirstMessageInBlock

	| firstBlock messageInsideBlock |
	self sourceCodeOf: self class >> #methodWithIfTrueIfFalse.
	firstBlock := ast statements first arguments first.
	messageInsideBlock := firstBlock statements first.
	self caretAfter: messageInsideBlock.
	
	self assert: self selectedSelector equals: messageInsideBlock selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - cascade' stamp: ''!
testCaretInCascadeReceiverShouldMatchFirstMessage

	| cascade |
	self sourceCodeOf: self class >> #methodWithCascade.
	
	cascade := ast statements first value.
	self caretInMiddleOf: cascade receiver.
	
	self assert: self selectedSelector equals: cascade messages first selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
selectedSelector

	^ CNSelectorExtractor new extractSelectorFromAST: ast atPosition: position! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
returnNodeToTest

	^ ast statements first! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - withOutMessage' stamp: ''!
testCaretAfterABlock
	| selector |
	selector := '[]'.
	sourceCode := selector.
	ast := (RBParser parseFaultyExpression: selector).
	self caretAfter: ast.
	self assert: self selectedSelector equals: #noMethod! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - withOutMessage' stamp: ''!
testCaretAfterALiteralArrayWithAnElement
	| selector |
	selector := '#(even)'.
	sourceCode := selector.
	ast := (RBParser parseFaultyExpression: selector).
	self caretAfter: ast.
	self assert: self selectedSelector equals: #noMethod! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - variable' stamp: ''!
testCaretAfterVariableNode

	| selector |
	selector := #even.
	sourceCode := selector.
	ast := (RBParser parseFaultyExpression: selector).
	self caretAfter: ast.
	self assert: self selectedSelector equals: selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - blocks' stamp: ''!
testExtractSelectorWithPositionAtFirstCharacterOfMethod

	self sourceCodeOf: self class >> #methodWithIfTrueIfFalse.
	self caretAt: 1.
	
	self assert: self selectedSelector equals: #methodWithIfTrueIfFalse! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - withOutMessage' stamp: ''!
testCaretAfterABlockWithArgument
	| selector |
	selector := '[:even| ]'.
	sourceCode := selector.
	ast := (RBParser parseFaultyExpression: selector).
	self caretAfter: ast.
	self assert: self selectedSelector equals: #noMethod! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - withOutMessage' stamp: ''!
testCaretWithEmptyString
	| selector |
	selector := ''.
	sourceCode := selector.
	ast := (RBParser parseFaultyExpression: selector).
	self caretAfter: ast.
	self assert: self selectedSelector equals: nil! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - blocks' stamp: ''!
testCaretAfterMessageInBlock

	| firstBlock messageInsideBlock |
	self sourceCodeOf: self class >> #methodWithIfTrueIfFalse.
	firstBlock := ast statements first arguments first.
	messageInsideBlock := firstBlock statements first.
	self caretAfter: messageInsideBlock.
	
	self assert: self selectedSelector equals: messageInsideBlock selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - return' stamp: ''!
testCaretAfterReturnShouldMatchChild

	self sourceCodeOf: self class >> #method:zkx:pn:.
	
	"Caret in middle of should put the caret after the ^"
	self caretInMiddleOf: self returnNodeToTest.
	
	self assert: self selectedSelector equals: self messageNodeToTest selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - message' stamp: ''!
testCaretInNestedMessageInMiddleOfArgumentName

	self sourceCodeOf: self class >> #method:zkx:pn:.
	
	"The argument is a message node, we should match it instead of the parent"
	self caretInMiddleOf: (self messageNodeToTest arguments at: 2).
	
	self assert: self selectedSelector equals: self messageNodeToTest arguments second selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
caretBefore: aNode 

	self caretAt: aNode start! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - method signature' stamp: ''!
testCaretInHeaderInBeforeArgumentName

	self sourceCodeOf: self class >> #method:zkx:pn:.
	self caretBefore: (ast arguments at: 1).
	
	self assert: self selectedSelector equals: #method:zkx:pn:! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - withOutMessage' stamp: ''!
testCaretOnNonValidCode
	"Code has invalid code (no selectors at all)"

	
	sourceCode := 'anObjectdo : 2'.
	ast := (RBParser parseFaultyExpression: sourceCode).
	self caretAfter: ast.
	self assert: self selectedSelector equals: #noMethod.! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - method signature' stamp: ''!
testCaretInHeaderInMiddleOfArgumentName

	self sourceCodeOf: self class >> #method:zkx:pn:.
	self caretInMiddleOf: (ast arguments at: 2).
	
	self assert: self selectedSelector equals: #method:zkx:pn:! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
caretAfter: aNode

	self caretAt: aNode stop + 1! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - cascade' stamp: ''!
testCaretInCascadeSecondMessageShouldMatchSecondMessage

	| cascade |
	self sourceCodeOf: self class >> #methodWithCascade.
	
	cascade := ast statements first value.
	self caretInMiddleOfCascadeMessage: cascade messages second.
	
	self assert: self selectedSelector equals: cascade messages second selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - return' stamp: ''!
testCaretAtEndOfMethodShouldMatchMethodNode

	self sourceCodeOf: self class >> #methodWithSpacesAtTheEnd.
	
	self caretAfter: self returnNodeToTest methodNode.
	
	self assert: self selectedSelector equals: #methodWithSpacesAtTheEnd! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - method signature' stamp: ''!
testCaretInHeaderAfterArgumentName

	self sourceCodeOf: self class >> #method:zkx:pn:.
	self caretAfter: (ast arguments at: 1).
	
	self assert: self selectedSelector equals: #method:zkx:pn:! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - message' stamp: ''!
testCaretInSymbol

	| performSymbolArgumentNode |
	self sourceCodeOf: self class >> #method:zkx:pn:.
	
	"The argument is a message node, we should match it instead of the parent"
	performSymbolArgumentNode := self messageNodeToTest arguments third arguments first.
	self caretInMiddleOf: performSymbolArgumentNode.
	
	self assert: self selectedSelector equals: performSymbolArgumentNode value! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
methodWithCascade

	^ self
		yourself;
		asString! !

!CNSelectorExtractionOnPositionTest methodsFor: 'helpers' stamp: ''!
methodWithIfTrueIfFalse

	self isInteger
		ifTrue: [ 
			#(1 2) first.
			self printString ]
		ifFalse: [ self yourself ]! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - return' stamp: ''!
testCaretBeforeReturnShouldMatchChild

	self sourceCodeOf: self class >> #method:zkx:pn:.
	self caretBefore: self returnNodeToTest.
	
	self assert: self selectedSelector equals: self messageNodeToTest selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - method signature' stamp: ''!
testCaretInHeaderInMiddleOfSelectorHeader

	self sourceCodeOf: self class >> #method:zkx:pn:.
	self caretInMiddleOf: ast.
	
	self assert: self selectedSelector equals: #method:zkx:pn:! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - withOutMessage' stamp: ''!
testCaretAfterADynamicArrayWithAnElement
	| selector |
	selector := '{even}'.
	sourceCode := selector.
	ast := (RBParser parseFaultyExpression: selector).
	self caretAfter: ast.
	self assert: self selectedSelector equals: #noMethod! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - blocks' stamp: ''!
testCaretAfterLastMessageInBlock

	| firstBlock messageInsideBlock |
	self sourceCodeOf: self class >> #methodWithIfTrueIfFalse.
	firstBlock := ast statements first arguments first.
	messageInsideBlock := firstBlock statements last.
	self caretAfter: messageInsideBlock.
	
	self assert: self selectedSelector equals: messageInsideBlock selector! !

!CNSelectorExtractionOnPositionTest methodsFor: 'tests - no selection - message' stamp: ''!
testCaretInNestedPerformMessageInMiddleOfArgumentName

	self sourceCodeOf: self class >> #method:zkx:pn:.
	
	"The argument is a message node, we should match it instead of the parent"
	self caretInMiddleOf: self messageNodeToTest arguments third.
	
	self assert: self selectedSelector equals: self messageNodeToTest arguments third selector! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectKeywordMessageWithBrokenLastArgumentShouldMatchKeywordSelector

	self select: 'a foo: 17 bar: (some message: #toto) fum: [ :will | it b'.
	
	self assert: self selectedSelector equals: #foo:bar:fum:! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectKeywordMessageWithBrokenMiddleArgumentShouldMatchKeywordSelector

	self select: 'a foo: 17 bar: (some message: # fum: [ :will | it break ]'.
	
	self assert: self selectedSelector equals: #foo:bar:! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectKeywordMessageWithoutReceiverShouldMatchKeywordSelector

	self select: 'method: a zkx: bsq pn: c'.

	self assert: self selectedSelector equals: #method:zkx:pn:! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'helpers' stamp: ''!
select: someText 
	
	sourceCode := someText.! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectCascadeFirstMessageWithoutReceiverShouldMatchFirstMessageSelector

	self select: 'bar: 7; fum'.

	self assert: self selectedSelector equals: #bar:! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectInvalidCode

	self select: 'even : 2'.
	
	self assert: self selectedSelector equals: #even! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectKeywordMessageShouldMatchKeywordSelector

	self select: 'a foo: 17 bar: (some message: #toto) fum: [ :will | it break ]'.
	
	self assert: self selectedSelector equals: #foo:bar:fum:! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectTokenShouldMatchToken

	self select: 'foo'.
	
	self assert: self selectedSelector equals: #foo! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectKeywordMessageWithoutReceiverAndComplexArgumentsShouldMatchKeywordSelector

	self select: 'foo: 17 bar: (some message: #toto) fum: [ :will | it break ]'.

	self assert: self selectedSelector equals: #foo:bar:fum:! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectReturnShouldMatchToken

	self select: '^ foo'.
	
	self assert: self selectedSelector equals: #foo! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectCascadeFirstMessageShouldMatchFirstMessageSelector

	self select: 'foo bar: 7; fum'.
	
	self assert: self selectedSelector equals: #bar:! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'helpers' stamp: ''!
selectedSelector

	^ CNSelectorExtractor new extractSelectorFromSelection: sourceCode! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectMultipleStatementsShouldMatchFirstStatement

	self select: 'foo. second statement'.
	
	self assert: self selectedSelector equals: #foo! !

!CNSelectorExtractionOnSelectionTest methodsFor: 'tests - selection' stamp: ''!
testSelectInvalidCodeWithPossibleSelector
	"Code has faulty code"
	self select: 'anObject do : 1 with: 2'.
	self assert: self selectedSelector equals: #do! !

!CNSelectorExtractor commentStamp: ''!
I implement a series of heuristics to extract selectors from source code.

I have two main entry points:

 - `extractSelectorFromSelectedText: aText` receives some text and looks at it in isolation, regarless of the context around it, and tries to find a selector in it
 - `extractSelectorFromAST: anASTNode atPosition: aPositionInTheAST` gets the best node matching the position and extracts a selector from it.

## Heuristics - position

When extracting from a particular position, if the previous character is not a separator, we move the selection one position before.
This heuristic is for the cases where the caret (|) is:
   |self foo  => the caret is before self, do not move
   self foo|  => the caret is before foo, interpret is as if we are in foo.
	self foo | => the caret is before a space, interpret is as if we are in foo.

This heuristic introduces although an ambiguity when code is not nicely formatted:
   self foo:|#bar => Here a user may want foo: or bar.
For now we decided to favor foo: to motivate people to indent code correctly

## Heuristics - cascades

When the best matching node is a message, a strange case may arrive with cascades.
Cascade nodes contain messages and each message contains (duplicated) the receiver.
So we need to deambiguate here: was the selection on the receiver? or on the message itself?
		
For example:
	aVariable
	cascade1;
	cascade2.
			
Selecting both `aVariable` or the message `cascade2` will yield a message node `aVariable cascade2`.
However, in the first case, the cursor is closer to `cascade1`, so we want cascade1 while in the latter case we want cascade2.!
!CNSelectorExtractor methodsFor: 'private' stamp: ''!
extractSelectorFromAST: ast atPosition: aPosition

	| bestNodeAtPosition |
	bestNodeAtPosition := ast bestNodeForPosition: aPosition.
	^ self extractSelectorFromNode: bestNodeAtPosition! !

!CNSelectorExtractor methodsFor: 'public - extraction' stamp: ''!
extractSelectorFromSelection: aString 
   "Extract a selector from the given string in isolation, regardless of the context around it"
	
	| node |
	node := RBParser parseFaultyExpression: aString.
	node
		nodesDo: [ :n |
			n isMessage
				ifTrue: [ ^ n selector ].
			n isVariable
				ifTrue: [ ^ n name ].
			n isLiteralNode
				ifTrue: [ ^ n value ] ].

	"fall back"
	^ aString asSymbol! !

!CNSelectorExtractor methodsFor: 'public - extraction' stamp: ''!
extractSelectorFromSource: aString atPosition: aPosition
	"Receives a string with the source code, and a number which indicates the position (of the caret) where the selectors will be extracted."
	
	| position |
	aString ifNil: [ ^ nil ].
	aString ifEmpty: [ ^ nil ].
	position := (aPosition < 0 or: [ aPosition > aString size ]) 
		ifTrue: [
			(aString size + 1) = aPosition 
				ifTrue: [ aPosition -1 ]
				ifFalse: [ ^ nil ]].
	^ self
		  extractSelectorFromAST: (RBParser parseFaultyExpression: aString)
		  atPosition: aPosition! !

!CNSelectorExtractor methodsFor: 'private' stamp: ''!
extractSelectorFromNode: aNode

	| node originalNode |
	aNode ifNil: [ ^ nil ].
	originalNode := node := aNode.
	node isReturn ifTrue: [ node := node value ].

	node isCascade ifTrue: [ ^ node messages first selector ].

	node isMethod ifFalse: [ 
		(node isValue and: [ node value isSymbol ]) ifTrue: [ ^ node value ].

		[ node isMessage or: [ node isMethod ] ] whileFalse: [ 
			(node := node parent) ifNil: [ ^ nil ] ].

		"This is a strange case with cascades.
		Cascade nodes contain messages.
		And each message contains (duplicated) the receiver.
		So we need to deambiguate here:
		  was the selection on the receiver? or on the message itself?
		
		For example:
		  aVariable
			cascade1;
			cascade2.
			
		Selecting both the receiver or the cascade2 will yield a message node `aVariable cascade2`.
		However, in the first case we want cascade1 and in the latter we want cascade2.
		
		"
		(node ~= originalNode and: [ 
			 node parent notNil and: [ node parent isCascade ] ]) ifTrue: [ 
			node := node parent messages first ] ].
	
	"In the case of doIt methods"
	(node selector = #noMethod and: [ aNode isVariable ])
		ifTrue: [  ^ aNode name ].


	^ node selector! !

!CNSelectorExtractorTest commentStamp: ''!
A CNSelectorExtractorTest is a test class for testing the behavior of CNSelectorExtractor!
!CNSelectorExtractorTest methodsFor: 'initialization' stamp: ''!
initialize
			
	selectorExtractor := CNSelectorExtractor new.! !

!CNSelectorExtractorTest methodsFor: 'tests' stamp: ''!
testExtractSelectorFromSourceAtPositionGeneralCasesExtractsSelector

	"Note that the tested method (#extractSelectorFromSource:atPosition:) uses internally #extractSelectorFromAST:atPosition:"
	"Also uses RBParser >> #parseFaultyExpression: "
	"This means, that by covering only the border cases, there is full code coverage, assumming extractSelectorFromAST:atPosition: and RBParser >> #parseFaultyExpression:  tests are ok."

	| source position |
	"Empty source, invalid position, returns nil"
	source := ''.
	position := -1.
	self assert: (selectorExtractor
			 extractSelectorFromSource: source
			 atPosition: position) isNil.

	"Cascade"
	source := 'foo bar: 7; fum'.
	position := 1.
	self
		assert: (selectorExtractor
				 extractSelectorFromSource: source
				 atPosition: position)
		equals: #bar:.

	position := 12.
	self
		assert: (selectorExtractor
				 extractSelectorFromSource: source
				 atPosition: position)
		equals: #fum.

	"A good case of IfTrue if false. Should select #ifTrue:ifFalse:"
	source := 'self isInteger ifTrue: [ #(1 2) first. self printString ] ifFalse: [ self yourself ]'.
	position := source indexOfSubCollection: 'alse:'.
	self
		assert: (selectorExtractor
				 extractSelectorFromSource: source
				 atPosition: position)
		equals: #ifTrue:ifFalse:.

	"A good case of nesting. Should select #first"
	source := 'self isInteger ifTrue: [ #(1 2) first. self printString ] ifFalse: [ self yourself ]'.
	position := source indexOfSubCollection: 'irst'.
	self
		assert: (selectorExtractor
				 extractSelectorFromSource: source
				 atPosition: position)
		equals: #first! !

!CNSelectorExtractorTest methodsFor: 'tests' stamp: ''!
testExtractSelectorFromSourceAtPositionBorderCasesReturnsNil

   |source position|
	"Border cases first"
	
	"Nil source, returns nil"
	source := nil.
	position := 1.
	self assert: (selectorExtractor extractSelectorFromSource: source atPosition: position) isNil.
	
	"Empty source, returns nil"
	source := ''.
	position := 1.
	self assert: (selectorExtractor extractSelectorFromSource: source atPosition: position) isNil.
	
	"nil source, invalid Position"
	source := nil.
	position := -1.
	self assert: (selectorExtractor extractSelectorFromSource: source atPosition: position) isNil.
	
	"a string source, invalid Position"
	source := 'astring'.
	position := 10000.
	self assert: (selectorExtractor extractSelectorFromSource: source atPosition: position) isNil.
! !

!CPUWatcher commentStamp: ''!
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: 'process operations' stamp: ''!
debugProcess: aProcess
	| uiPriority  |
	uiPriority := Processor activeProcess priority.
	aProcess priority >= uiPriority ifTrue: [
		self processBrowser setProcess: aProcess toPriority: uiPriority - 1
	].
	self processBrowser debugProcess: aProcess.! !

!CPUWatcher methodsFor: 'porcine capture' stamp: ''!
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: 'startup - shutdown' stamp: ''!
monitorProcessPeriod: secs sampleRate: msecs
	self stopMonitoring.

	watcher := [ [ | promise |
		promise := Processor tallyCPUUsageFor: secs every: msecs.
		tally := promise value.
		promise := nil.
		self class pigFinding ifTrue: [
			self findThePig ]
	] repeat ] forkAt: Processor highestPriority.
	Processor yield ! !

!CPUWatcher methodsFor: 'process operations' stamp: ''!
debugProcess: aProcess fromMenu: aMenuMorph
	aMenuMorph delete.
	self debugProcess: aProcess.! !

!CPUWatcher methodsFor: 'accessing' stamp: ''!
tally
	^tally copy! !

!CPUWatcher methodsFor: 'accessing' stamp: ''!
processBrowser
	^ self class processBrowser! !

!CPUWatcher methodsFor: 'startup - shutdown' stamp: ''!
startMonitoring
	self
		monitorProcessPeriod: 20 sampleRate: 100! !

!CPUWatcher methodsFor: 'porcine capture' stamp: ''!
findThePig
	"tally has been updated. Look at it to see if there is a bad process.
	This runs at a very high priority, so make it fast"

	| countAndProcess process |
	countAndProcess := tally sortedCounts first.
	countAndProcess key / tally size > self threshold
		ifFalse: [ ^ self ].
	process := countAndProcess value.
	process == Processor backgroundProcess
		ifTrue: [ ^ self ].	"idle process? OK"
	self catchThePig: process! !

!CPUWatcher methodsFor: 'porcine capture' stamp: ''!
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: 'process operations' stamp: ''!
terminateProcess: aProcess fromMenu: aMenuMorph
	aMenuMorph delete.
	self processBrowser terminateProcess: aProcess.! !

!CPUWatcher methodsFor: 'accessing' stamp: ''!
watcherProcess
	^watcher! !

!CPUWatcher methodsFor: 'accessing' stamp: ''!
isMonitoring
	^watcher notNil! !

!CPUWatcher methodsFor: 'porcine capture' stamp: ''!
openWindowForSuspendedProcess: aProcess

	 UIManager default defer: [ self openMorphicWindowForSuspendedProcess: aProcess ] 
	! !

!CPUWatcher methodsFor: 'accessing' stamp: ''!
threshold
	"What fraction of the time can a process be the active process before we stop it?"
	^threshold! !

!CPUWatcher methodsFor: 'accessing' stamp: ''!
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: 'startup - shutdown' stamp: ''!
stopMonitoring
	watcher ifNotNil: [
		self processBrowser terminateProcess: watcher.
		watcher := nil.
	]! !

!CPUWatcher methodsFor: 'process operations' stamp: ''!
resumeProcess: aProcess fromMenu: aMenuMorph
	aMenuMorph delete.
	self processBrowser resumeProcess: aProcess.! !

!CPUWatcher class methodsFor: 'system startup' stamp: ''!
startUp
	self monitorPreferenceChanged.! !

!CPUWatcher class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default 
		registerToolClassNamed: self name! !

!CPUWatcher class methodsFor: 'accessing' stamp: ''!
current
	^CurrentCPUWatcher
! !

!CPUWatcher class methodsFor: 'accessing' stamp: ''!
processBrowser
	^ Smalltalk tools processBrowser! !

!CPUWatcher class methodsFor: 'setting' stamp: ''!
pigFinding: aBoolean
	PigFinding := aBoolean.
! !

!CPUWatcher class methodsFor: 'startup - shutdown' stamp: ''!
startMonitoring
	"CPUWatcher startMonitoring"

	^self startMonitoringPeriod: 20 rate: 100 threshold: 0.8! !

!CPUWatcher class methodsFor: 'setting' stamp: ''!
cpuWatcherEnabled: aBoolean
	CpuWatcherEnabled = aBoolean ifTrue: [^ self].
	CpuWatcherEnabled := aBoolean.
	self monitorPreferenceChanged
! !

!CPUWatcher class methodsFor: 'setting' stamp: ''!
pigFinding
	^ PigFinding ifNil: [PigFinding := false]! !

!CPUWatcher class methodsFor: 'system startup' stamp: ''!
shutDown
	self stopMonitoring.! !

!CPUWatcher class methodsFor: 'accessing' stamp: ''!
currentWatcherProcess
	^CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher watcherProcess ]
! !

!CPUWatcher class methodsFor: 'monitoring' stamp: ''!
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: 'testing' stamp: ''!
isMonitoring

	^CurrentCPUWatcher notNil and: [ CurrentCPUWatcher isMonitoring ]
! !

!CPUWatcher class methodsFor: 'monitoring' stamp: ''!
dumpTallyOnTranscript
	<script>
	self current ifNotNil: [
		self processBrowser dumpTallyOnTranscript: self current tally
	]! !

!CPUWatcher class methodsFor: 'setting' stamp: ''!
monitorPreferenceChanged
	self cpuWatcherEnabled
		ifTrue: [ self startMonitoring ]
		ifFalse: [ self stopMonitoring ]! !

!CPUWatcher class methodsFor: 'monitoring' stamp: ''!
stopMonitoring
	"CPUWatcher stopMonitoring"

	CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ].
	CurrentCPUWatcher := nil.
! !

!CPUWatcher class methodsFor: 'setting' stamp: ''!
cpuWatcherEnabled
	^ CpuWatcherEnabled ifNil: [CpuWatcherEnabled := false]! !

!CRC commentStamp: ''!
Parameterized implementation of the cyclic redundancy check (CRC) algorithm.

INTRODUCTION
=================
This implementation is based on the (awesome) paper "A Painless Guide to CRC Error Detection Algorithms" by Ross Williams. You should find a copy of the paper here: http://www.ross.net/crc/. In this paper Ross describes a parameterized implementation that enables the different variations of the CRC algorithm to be used in a consistent way, simply by adjusting the parameters. If you don't have a clue about CRC (like me) then I strongly suggest reading the paper. It will also help you to understand how to make the best use of this implementation.

The "CRC RevEng" project on sourceforge implements Williams's "RockSoft" parameterized CRC program (as does this class) and comes with a handy list of parameters for various CRC algorithm: http://reveng.sourceforge.net/crc-catalogue/.

For ease of use and better performance, the two defacto standard variations "CRC16" and "CRC32" have been predefined. The lookup tables for these implementations are included on the class side. For all other variations the lookup table will be generated at runtime before the first run.

If you want to define your own algorithm you can do so by using the methods in the "accessing-parameters" protocol. Note that there are no default values. Here's a short overview:
	#width: 			defines the width of the register (usually 16 or 32)
	#polynome: 		defines the polynome to use for polynome division / lookup table creation
	#registerFill: 		defines the start content of the working register (usually all ones or all zeros)
	#reflectInput: 		if true every byte will be reflected before processing (e.g. 100101 -> 101001)
	#reflectOutpu: 		if true the entire register will be reflected before the final XOR stage
	#finallyXorWith: 	defines the final XOR for the entire register
	#lookupTable: 		the only OPTIONAL parameter. The lookup table will be generated at runtime if none has been supplied
	#message: 			the message to calculate the CRC on 
		

EXAMPLES
=================
The simplest possible snippet uses the class side methods for "CRC16" and "CRC32":
	CRC crc16FromCollection: 'some message'. --> 55709
	CRC crc32FromCollection: 'some message'. --> 191312361

Let's assume, you wanted to use "CRC16 reversed" (neither input nor output reflected). Then you would have to change the parameters like so (the reversed form uses a different polynome and a different start register content):
	crc := CRC new
		beCrc16;
		polynome: 16r1021;
		registerFill: 16rFFFF;
		reflectInput: false;
		reflectOutput: false;
		message: 'some message';
		yourself.
	crc run. --> 46785
	
Using a single instance as in the code above will of course be faster than using the class side methods when performing multiple runs. But if you are really concerned about performance (see PERFORMANCE) you should use the "raw" methods (no checks!! If you forget to set parameters there will be errors....):
	crc := CRC new
		beCrc16;
		message: 'some message';
		yourself.
	crc runRefInRefOut. --> 55709
	
	crc := CRC new
		beCrc16;
		polynome: 16r1021;
		registerFill: 16rFFFF;
		message: 'some message';
		yourself.
	crc runNonRefInNonRefOut. --> 46785
	

PERFORMANCE
=================
The performance of this implementation (tested for crc16) is equal to the performance of String>>crc16 if executed "raw" (see EXAMPLES). For the users sake however, the implementation does a few extra checks to improve ease of use. The cost is a loss of performance of about factor 1.15 (single instance) and 1.42 (one instance per run) (note that although I took an average of 10, the results will vary quite a bit each time you run the code):
	crc := CRC new 
		beCrc16; 
		message: 'this is a test message'; 
		yourself.
	
	"String>>crc16"	
	times := OrderedCollection new.
	10 timesRepeat: [ times add: [ 1000000 timesRepeat: [ 'this is a test message' crc16 ] ] timeToRun ].
	times average floor. --> 530
	
	"raw"
	times := OrderedCollection new.
	10 timesRepeat: [ times add: [ 1000000 timesRepeat: [ crc runRefInRefOut ] ] timeToRun ].
	times average floor. --> 535
	
	"user friendly, one instance"	
	times := OrderedCollection new.
	10 timesRepeat: [ times add: [ 1000000 timesRepeat: [ crc run ] ] timeToRun ].
	times average floor. --> 616
	
	"user friendly, one instance per run"
	times := OrderedCollection new.
	10 timesRepeat: [ times add: [ 1000000 timesRepeat: [ CRC crc16FromCollection: 'this is a test message' ] ] timeToRun ].
	times average floor. --> 759!
!CRC methodsFor: 'accessing - parameters' stamp: ''!
width: anInteger
	"width of the register (on how many bits the CRC is calculated).
	usually 16 or 32"
	width := anInteger! !

!CRC methodsFor: 'private - bit manipulation' stamp: ''!
reflect: anInteger onLowerBits: anotherInteger
	| register test |
	register := anInteger.
	test := anInteger.
	0 to: anotherInteger - 1 do: [ :index |
		register := 
			(test bitAnd: 1) = 1
				ifTrue: [ register bitOr: (self bitMaskAt: anotherInteger - index) ]
				ifFalse: [ register bitAnd: (self invertedBitMaskAt: anotherInteger - index) ].
	test := test bitShift: -1 ].

	^ register! !

!CRC methodsFor: 'accessing - parameters' stamp: ''!
registerFill: anInteger
	"The initial value of the CRC register"
	registerFill := anInteger! !

!CRC methodsFor: 'accessing - parameters' stamp: ''!
message: anObject
	message := anObject asByteArray! !

!CRC methodsFor: 'private - bit manipulation' stamp: ''!
invertedBitMaskAt: anInteger
	anInteger < 1 ifTrue: [ ^ 16rFFFFFFFF ].
	^ 16rFFFFFFFF bitAt: anInteger put: 0! !

!CRC methodsFor: 'private - tables' stamp: ''!
printLookupTableOn: aStream
	| topBit |
	topBit := self bitMaskAt: width.
	0 to: 255 do: [ :index || register indexByte |
		indexByte := index.
		shouldReflectInput ifTrue: [ indexByte := self reflect: indexByte onLowerBits: 8 ].
		register := indexByte << self lowestByteShift.
		1 to: 8 do: [ : byteIndex |
			register :=
				(register bitAnd: topBit) > 0 
					ifTrue: [ (register << 1) bitXor: polynome ]
					ifFalse: [ register << 1 ] ].
		shouldReflectInput ifTrue: [ 
			register := self reflect: register onLowerBits: width ].
		register := (register bitAnd: self widthMask).
		aStream nextPut: register ]! !

!CRC methodsFor: 'private - tables' stamp: ''!
generateLookupTable
	"lookup tables have 256 entries"
	^ Array 
		new: 256
		streamContents: [ :aStream | self printLookupTableOn: aStream ]! !

!CRC methodsFor: 'private - bit manipulation' stamp: ''!
lowestByteShift
	^ lowestByteShift ifNil: [ lowestByteShift := width - 8 ]! !

!CRC methodsFor: 'private - run methods' stamp: ''!
runNonRefInNonRefOut
	theRegister := registerFill.
	1 to: message size do: [ :byteIndex | 
		theRegister := 
			(lookupTable at: (((theRegister bitShift: 0 - self lowestByteShift) bitXor: (message byteAt: byteIndex)) bitAnd: 255) + 1)
			bitXor: ((theRegister bitShift: 8) bitAnd: self widthMask) ].
			
	^ finalXorBytes bitXor: theRegister! !

!CRC methodsFor: 'private - run methods' stamp: ''!
runRefInNonRefOut
	Warning signal: 'unverified implementation'.
	theRegister := registerFill.
	1 to: message size do: [ :byteIndex | 
		theRegister := 
			(lookupTable at: ((theRegister bitXor: (message byteAt: byteIndex)) bitAnd: 255) + 1) 
			bitXor: ((theRegister bitShift: 8) bitAnd: self widthMask) ].
			
	^ finalXorBytes bitXor: theRegister! !

!CRC methodsFor: 'accessing - parameters' stamp: ''!
lookupTable: anArray
	lookupTable := anArray! !

!CRC methodsFor: 'accessing - implementations' stamp: ''!
beCrc16
	self
		width: 16;
		lookupTable: self class crc16Table;
		polynome: 16r8005;
		registerFill: 16r0;
		reflectInput: true;
		reflectOutput: true;
		finallyXorWith: 16r0! !

!CRC methodsFor: 'accessing - implementations' stamp: ''!
beCrc32
	self
		width: 32;
		lookupTable: self class crc32Table;
		polynome: 16r04C11DB7;
		registerFill: 16rFFFFFFFF;
		reflectInput: true;
		reflectOutput: true;
		finallyXorWith: 16rFFFFFFFF! !

!CRC methodsFor: 'private - run methods' stamp: ''!
runRefInRefOut
	theRegister := registerFill.
	1 to: message size do: [ :byteIndex | 
		theRegister := 
			(lookupTable at: ((theRegister bitXor: (message byteAt: byteIndex)) bitAnd: 255) + 1) 
			bitXor: (theRegister bitShift: -8) ].
			
	^ finalXorBytes bitXor: theRegister! !

!CRC methodsFor: 'accessing - parameters' stamp: ''!
reflectOutput: aBoolean
	"Determines if the output is reflected before the final XOR."
	shouldReflectOutput := aBoolean! !

!CRC methodsFor: 'private - bit manipulation' stamp: ''!
bitMaskAt: anInteger
	^ 0 bitAt: anInteger put: 1! !

!CRC methodsFor: 'accessing - parameters' stamp: ''!
finallyXorWith: anInteger
	"The final XOR of the output will be performed with this value"
	finalXorBytes := anInteger! !

!CRC methodsFor: 'public' stamp: ''!
run
	lookupTable ifNil: [ lookupTable := self generateLookupTable ].
	^ self perform: self runMethodSelector! !

!CRC methodsFor: 'private - run methods' stamp: ''!
runMethodSelector
	^ runMethodSelector ifNil: [ 
		runMethodSelector := 
			shouldReflectInput
				ifTrue: [ 
					shouldReflectOutput
						ifTrue: [ #runRefInRefOut ] 
						ifFalse: [ #runRefInNonRefOut ] ]
				ifFalse: [ 
					shouldReflectOutput 
						ifTrue: [ #runNonRefInRefOut ] 
						ifFalse: [ #runNonRefInNonRefOut ] ] ]! !

!CRC methodsFor: 'private - bit manipulation' stamp: ''!
widthMask 	
	"bit mask (all ones)"
	^ widthMask ifNil: [ widthMask := (2 raisedTo: width) - 1 ]! !

!CRC methodsFor: 'private - run methods' stamp: ''!
runNonRefInRefOut
	Warning signal: 'unverified implementation'.
	theRegister := registerFill.
	1 to: message size do: [ :byteIndex | 
		theRegister := 
			(lookupTable at: (((theRegister bitShift: 0 - self lowestByteShift) bitXor: (message byteAt: byteIndex)) bitAnd: 255) + 1)
			bitXor: (theRegister bitShift: -8) ].
			
	^ finalXorBytes bitXor: theRegister! !

!CRC methodsFor: 'accessing - parameters' stamp: ''!
polynome: anInteger
	"The polynome used for polynomial division.
	It should be of the same length as the register width (see #width:)."
	polynome := anInteger! !

!CRC methodsFor: 'accessing - parameters' stamp: ''!
reflectInput: aBoolean
	"Determines if each byte should be reflected before processing.
	If false, bit 7 will be treated as most significant bit.
	If true, each byte will be reflected (bit 0 will be most significant)."
	shouldReflectInput := aBoolean! !

!CRC class methodsFor: 'instance creation' stamp: ''!
crc16FromCollection: aCollection
	| instance |
	instance := 
		self new
			beCrc16;
			message: aCollection;
			yourself.
			
	^ instance runRefInRefOut! !

!CRC class methodsFor: 'primitives' stamp: ''!
update: oldCrc from: start to: stop in: aCollection
	| newCrc |
	<primitive: 'primitiveUpdateGZipCrc32' module: 'ZipPlugin'>
	newCrc := oldCrc.
	start to: stop do: [ :i |
		newCrc := (self crc32Table at: ((newCrc bitXor: (aCollection byteAt: i)) 
				bitAnd: 255) + 1) bitXor: (newCrc bitShift: -8) ].
	^newCrc! !

!CRC class methodsFor: 'accessing - tables' stamp: ''!
crc16Table
	^ #(	16r0000	16rC0C1	16rC181	16r0140	16rC301	16r03C0	16r0280	16rC241
			16rC601	16r06C0	16r0780	16rC741	16r0500	16rC5C1	16rC481	16r0440
			16rCC01	16r0CC0	16r0D80	16rCD41	16r0F00	16rCFC1	16rCE81	16r0E40
			16r0A00	16rCAC1	16rCB81	16r0B40	16rC901	16r09C0	16r0880	16rC841
			16rD801	16r18C0	16r1980	16rD941	16r1B00	16rDBC1	16rDA81	16r1A40
			16r1E00	16rDEC1	16rDF81	16r1F40	16rDD01	16r1DC0	16r1C80	16rDC41
			16r1400	16rD4C1	16rD581	16r1540	16rD701	16r17C0	16r1680	16rD641
			16rD201	16r12C0	16r1380	16rD341	16r1100	16rD1C1	16rD081	16r1040
			16rF001	16r30C0	16r3180	16rF141	16r3300	16rF3C1	16rF281	16r3240
			16r3600	16rF6C1	16rF781	16r3740	16rF501	16r35C0	16r3480	16rF441
			16r3C00	16rFCC1	16rFD81	16r3D40	16rFF01	16r3FC0	16r3E80	16rFE41
			16rFA01	16r3AC0	16r3B80	16rFB41	16r3900	16rF9C1	16rF881	16r3840
			16r2800	16rE8C1	16rE981	16r2940	16rEB01	16r2BC0	16r2A80	16rEA41
			16rEE01	16r2EC0	16r2F80	16rEF41	16r2D00	16rEDC1	16rEC81	16r2C40
			16rE401	16r24C0	16r2580	16rE541	16r2700	16rE7C1	16rE681	16r2640
			16r2200	16rE2C1	16rE381	16r2340	16rE101	16r21C0	16r2080	16rE041
			16rA001	16r60C0	16r6180	16rA141	16r6300	16rA3C1	16rA281	16r6240
			16r6600	16rA6C1	16rA781	16r6740	16rA501	16r65C0	16r6480	16rA441
			16r6C00	16rACC1	16rAD81	16r6D40	16rAF01	16r6FC0	16r6E80	16rAE41
			16rAA01	16r6AC0	16r6B80	16rAB41	16r6900	16rA9C1	16rA881	16r6840
			16r7800	16rB8C1	16rB981	16r7940	16rBB01	16r7BC0	16r7A80	16rBA41
			16rBE01	16r7EC0	16r7F80	16rBF41	16r7D00	16rBDC1	16rBC81	16r7C40
			16rB401	16r74C0	16r7580	16rB541	16r7700	16rB7C1	16rB681	16r7640
			16r7200	16rB2C1	16rB381	16r7340	16rB101	16r71C0	16r7080	16rB041
			16r5000	16r90C1	16r9181	16r5140	16r9301	16r53C0	16r5280	16r9241
			16r9601	16r56C0	16r5780	16r9741	16r5500	16r95C1	16r9481	16r5440
			16r9C01	16r5CC0	16r5D80	16r9D41	16r5F00	16r9FC1	16r9E81	16r5E40
			16r5A00	16r9AC1	16r9B81	16r5B40	16r9901	16r59C0	16r5880	16r9841
			16r8801	16r48C0	16r4980	16r8941	16r4B00	16r8BC1	16r8A81	16r4A40
			16r4E00	16r8EC1	16r8F81	16r4F40	16r8D01	16r4DC0	16r4C80	16r8C41
			16r4400	16r84C1	16r8581	16r4540	16r8701	16r47C0	16r4680	16r8641
			16r8201	16r42C0	16r4380	16r8341	16r4100	16r81C1	16r8081	16r4040)! !

!CRC class methodsFor: 'accessing - tables' stamp: ''!
crc32Table
	^ #(	 16r00000000	 16r77073096	 16rEE0E612C	 16r990951BA	
			 16r076DC419	 16r706AF48F	 16rE963A535	 16r9E6495A3	
			 16r0EDB8832	 16r79DCB8A4	 16rE0D5E91E	 16r97D2D988	
			 16r09B64C2B	 16r7EB17CBD	 16rE7B82D07	 16r90BF1D91	
			 16r1DB71064	 16r6AB020F2	 16rF3B97148	 16r84BE41DE	
			 16r1ADAD47D	 16r6DDDE4EB	 16rF4D4B551	 16r83D385C7	
			 16r136C9856	 16r646BA8C0	 16rFD62F97A	 16r8A65C9EC	
			 16r14015C4F	 16r63066CD9	 16rFA0F3D63	 16r8D080DF5	
			 16r3B6E20C8	 16r4C69105E	 16rD56041E4	 16rA2677172	
			 16r3C03E4D1	 16r4B04D447	 16rD20D85FD	 16rA50AB56B	
			 16r35B5A8FA	 16r42B2986C	 16rDBBBC9D6	 16rACBCF940	
			 16r32D86CE3	 16r45DF5C75	 16rDCD60DCF	 16rABD13D59	
			 16r26D930AC	 16r51DE003A	 16rC8D75180	 16rBFD06116	
			 16r21B4F4B5	 16r56B3C423	 16rCFBA9599	 16rB8BDA50F	
			 16r2802B89E	 16r5F058808	 16rC60CD9B2	 16rB10BE924	
			 16r2F6F7C87	 16r58684C11	 16rC1611DAB	 16rB6662D3D	
			 16r76DC4190	 16r01DB7106	 16r98D220BC	 16rEFD5102A	
			 16r71B18589	 16r06B6B51F	 16r9FBFE4A5	 16rE8B8D433	
			 16r7807C9A2	 16r0F00F934	 16r9609A88E	 16rE10E9818	
			 16r7F6A0DBB	 16r086D3D2D	 16r91646C97	 16rE6635C01	
			 16r6B6B51F4	 16r1C6C6162	 16r856530D8	 16rF262004E	
			 16r6C0695ED	 16r1B01A57B	 16r8208F4C1	 16rF50FC457	
			 16r65B0D9C6	 16r12B7E950	 16r8BBEB8EA	 16rFCB9887C	
			 16r62DD1DDF	 16r15DA2D49	 16r8CD37CF3	 16rFBD44C65	
			 16r4DB26158	 16r3AB551CE	 16rA3BC0074	 16rD4BB30E2	
			 16r4ADFA541	 16r3DD895D7	 16rA4D1C46D	 16rD3D6F4FB	
			 16r4369E96A	 16r346ED9FC	 16rAD678846	 16rDA60B8D0	
			 16r44042D73	 16r33031DE5	 16rAA0A4C5F	 16rDD0D7CC9	
			 16r5005713C	 16r270241AA	 16rBE0B1010	 16rC90C2086	
			 16r5768B525	 16r206F85B3	 16rB966D409	 16rCE61E49F	
			 16r5EDEF90E	 16r29D9C998	 16rB0D09822	 16rC7D7A8B4	
			 16r59B33D17	 16r2EB40D81	 16rB7BD5C3B	 16rC0BA6CAD	
			 16rEDB88320	 16r9ABFB3B6	 16r03B6E20C	 16r74B1D29A	
			 16rEAD54739	 16r9DD277AF	 16r04DB2615	 16r73DC1683	
			 16rE3630B12	 16r94643B84	 16r0D6D6A3E	 16r7A6A5AA8	
			 16rE40ECF0B	 16r9309FF9D	 16r0A00AE27	 16r7D079EB1	
			 16rF00F9344	 16r8708A3D2	 16r1E01F268	 16r6906C2FE	
			 16rF762575D	 16r806567CB	 16r196C3671	 16r6E6B06E7	
			 16rFED41B76	 16r89D32BE0	 16r10DA7A5A	 16r67DD4ACC	
			 16rF9B9DF6F	 16r8EBEEFF9	 16r17B7BE43	 16r60B08ED5	
			 16rD6D6A3E8	 16rA1D1937E	 16r38D8C2C4	 16r4FDFF252	
			 16rD1BB67F1	 16rA6BC5767	 16r3FB506DD	 16r48B2364B	
			 16rD80D2BDA	 16rAF0A1B4C	 16r36034AF6	 16r41047A60	
			 16rDF60EFC3	 16rA867DF55	 16r316E8EEF	 16r4669BE79	
			 16rCB61B38C	 16rBC66831A	 16r256FD2A0	 16r5268E236	
			 16rCC0C7795	 16rBB0B4703	 16r220216B9	 16r5505262F	
			 16rC5BA3BBE	 16rB2BD0B28	 16r2BB45A92	 16r5CB36A04	
			 16rC2D7FFA7	 16rB5D0CF31	 16r2CD99E8B	 16r5BDEAE1D	
			 16r9B64C2B0	 16rEC63F226	 16r756AA39C	 16r026D930A	
			 16r9C0906A9	 16rEB0E363F	 16r72076785	 16r05005713	
			 16r95BF4A82	 16rE2B87A14	 16r7BB12BAE	 16r0CB61B38	
			 16r92D28E9B	 16rE5D5BE0D	 16r7CDCEFB7	 16r0BDBDF21	
			 16r86D3D2D4	 16rF1D4E242	 16r68DDB3F8	 16r1FDA836E	
			 16r81BE16CD	 16rF6B9265B	 16r6FB077E1	 16r18B74777	
			 16r88085AE6	 16rFF0F6A70	 16r66063BCA	 16r11010B5C	
			 16r8F659EFF	 16rF862AE69	 16r616BFFD3	 16r166CCF45	
			 16rA00AE278	 16rD70DD2EE	 16r4E048354	 16r3903B3C2	
			 16rA7672661	 16rD06016F7	 16r4969474D	 16r3E6E77DB	
			 16rAED16A4A	 16rD9D65ADC	 16r40DF0B66	 16r37D83BF0	
			 16rA9BCAE53	 16rDEBB9EC5	 16r47B2CF7F	 16r30B5FFE9	
			 16rBDBDF21C	 16rCABAC28A	 16r53B39330	 16r24B4A3A6	
			 16rBAD03605	 16rCDD70693	 16r54DE5729	 16r23D967BF	
			 16rB3667A2E	 16rC4614AB8	 16r5D681B02	 16r2A6F2B94	
			 16rB40BBE37	 16rC30C8EA1	 16r5A05DF1B	 16r2D02EF8D)! !

!CRC class methodsFor: 'instance creation' stamp: ''!
crc32FromCollection: aCollection
	| instance |
	instance := 
		self new
			beCrc32;
			message: aCollection;
			yourself.
	
	^ instance runRefInRefOut! !

!CRCError commentStamp: ''!
CRC failed!
!CRCError methodsFor: 'testing' stamp: 'nil'!
isResumable
	^true! !

!CacheStatistics commentStamp: ''!
I am CacheStatistics.
I keep track of hits and misses of a cache.!
!CacheStatistics methodsFor: 'accessing' stamp: ''!
addHit
	hits := hits + 1! !

!CacheStatistics methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	hits := misses := 0! !

!CacheStatistics methodsFor: 'accessing' stamp: ''!
hitRatio
	"Return the ratio of hits against total calls I received.
	This will be a number between 0 and 1.
	When I am empty, return 0."
	
	| total |
	total := hits + misses.
	total = 0 ifTrue: [ ^ 0 ].
	^ hits / total! !

!CacheStatistics methodsFor: 'accessing' stamp: ''!
hits
	^ hits! !

!CacheStatistics methodsFor: 'accessing' stamp: ''!
misses
	^ misses! !

!CacheStatistics methodsFor: 'initialization' stamp: ''!
reset
	hits := misses := 0! !

!CacheStatistics methodsFor: 'accessing' stamp: ''!
addMiss
	misses := misses + 1! !

!CacheWeight commentStamp: ''!
I  am CacheWeight.
I keep track of the weight of a cache.

The weight of a cache is the sum of the weight of all values currently present. The simplest and default weight calculation returns a constant 1 for each value, effectively counting the number of values.

The default maximum is 16.

Using compute, a selector or block, applied to a value, different calculation can be made. Consider for example #sizeInMemory.!
!CacheWeight methodsFor: 'accessing' stamp: ''!
add: value
	| weight |
	weight := compute cull: value.
	total := total + weight! !

!CacheWeight methodsFor: 'initialize' stamp: ''!
compute: valuable
	compute := valuable! !

!CacheWeight methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	total := 0.
	maximum := 16.
	compute := [ 1 ]! !

!CacheWeight methodsFor: 'testing' stamp: ''!
isBelowMaximum
	^ total <= maximum ! !

!CacheWeight methodsFor: 'accessing' stamp: ''!
maximum
	^ maximum! !

!CacheWeight methodsFor: 'accessing' stamp: ''!
remove: value
	| weight |
	weight := compute cull: value.
	total := total - weight! !

!CacheWeight methodsFor: 'accessing' stamp: ''!
compute
	^ compute! !

!CacheWeight methodsFor: 'initialization' stamp: ''!
reset
	total := 0! !

!CacheWeight methodsFor: 'initialize' stamp: ''!
maximum: integer
	maximum := integer! !

!CacheWeight methodsFor: 'accessing' stamp: ''!
total
	^ total! !

!CairoBackendCache commentStamp: ''!
I providing a simple [weak]key->value storage used to cache various objects used by Athens for Cairo backend, like fonts/forms etc.

The cache is global (there's only a single instance of me used at a time) and
cache is visible globally by all entities of Cairo backend.

The cached objects is held weakly.
The cache is flushed for a new image session.!
!CairoBackendCache methodsFor: 'initialization' stamp: ''!
initialize

	self flush! !

!CairoBackendCache methodsFor: 'removing' stamp: ''!
removeAt: anObject

	^ cache removeKey: anObject  ifAbsent: nil! !

!CairoBackendCache methodsFor: 'accessing' stamp: ''!
for: anObject at: key ifAbsentPut: aBlock

	| subCache |
	subCache := cache 
		at: anObject
		ifAbsentPut: [ WeakIdentityKeyDictionary new ].

	^ subCache at: key ifAbsentPut: aBlock! !

!CairoBackendCache methodsFor: 'accessing' stamp: ''!
at: anObject 

	^ cache at: anObject  ifAbsent: nil! !

!CairoBackendCache methodsFor: 'accessing' stamp: ''!
at: anObject ifAbsentPut: aBlock

	^ cache at: anObject  ifAbsentPut: aBlock! !

!CairoBackendCache methodsFor: 'accessing' stamp: ''!
flush

	cache := WeakIdentityKeyDictionary new! !

!CairoBackendCache class methodsFor: 'instance creation' stamp: ''!
new 
	self error: 'Use #soleInstance'! !

!CairoBackendCache class methodsFor: 'instance creation' stamp: ''!
soleInstance
	self checkSession.
	^ soleInstance ifNil: [ soleInstance := super new ]! !

!CairoBackendCache class methodsFor: 'session management' stamp: ''!
checkSession
	session == Smalltalk session ifFalse: [ 
		soleInstance := nil.
		session := Smalltalk session ]! !

!CairoBackendCache class methodsFor: 'flushing' stamp: ''!
flush
	self soleInstance flush! !

!CairoFontExtents commentStamp: ''!
I represent the
cairo_font_extents_t structure type

The cairo_font_extents_t structure stores metric information for a font. Values are given in the current user-space coordinate system.

Because font metrics are in user-space coordinates, they are mostly, but not entirely, independent of the current transformation matrix. If you call cairo_scale(cr, 2.0, 2.0), text will be drawn twice as big, but the reported text extents will not be doubled. They will change slightly due to hinting (so you can't assume that metrics are independent of the transformation matrix), but otherwise will remain unchanged.

double ascent;
	the distance that the font extends above the baseline. Note that this is not always exactly equal to the maximum of the extents of all the glyphs in the font, but rather is picked to express the font designer's intent as to how the font should align with elements above it.

double descent;
	the distance that the font extends below the baseline. This value is positive for typical fonts that include portions below the baseline. Note that this is not always exactly equal to the maximum of the extents of all the glyphs in the font, but rather is picked to express the font designer's intent as to how the font should align with elements below it.

double height;
	the recommended vertical distance between baselines when setting consecutive lines of text with the font. This is greater than ascent+descent by a quantity known as the line spacing or external leading. When space is at a premium, most fonts can be set with only a distance of ascent+descent between lines.

double max_x_advance;
	the maximum distance in the X direction that the origin is advanced for any glyph in the font.

double max_y_advance;
	the maximum distance in the Y direction that the origin is advanced for any glyph in the font. This will be zero for normal fonts used for horizontal writing. (The scripts of East Asia are sometimes written vertically.)!
!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
width: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_WIDTH put: anObject! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
ascent: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_ASCENT put: anObject! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
width
	"This method was automatically generated"
	^handle doubleAt: OFFSET_WIDTH! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
max_y_advance
	"This method was automatically generated"
	^handle doubleAt: OFFSET_MAX_Y_ADVANCE! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
ascent
	"This method was automatically generated"
	^handle doubleAt: OFFSET_ASCENT! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
max_y_advance: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_MAX_Y_ADVANCE put: anObject! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
height
	"This method was automatically generated"
	^handle doubleAt: OFFSET_HEIGHT! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
descent
	"This method was automatically generated"
	^handle doubleAt: OFFSET_DESCENT! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
height: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_HEIGHT put: anObject! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
descent: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_DESCENT put: anObject! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
max_x_advance
	"This method was automatically generated"
	^handle doubleAt: OFFSET_MAX_X_ADVANCE! !

!CairoFontExtents methodsFor: 'accessing - structure variables' stamp: ''!
max_x_advance: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_MAX_X_ADVANCE put: anObject! !

!CairoFontExtents class methodsFor: 'field definition' stamp: ''!
fieldsDesc 
	"self rebuildFieldAccessors"
	^ #(
	double ascent;
	double descent;
	double width;
	double height;
	double max_x_advance;
	double max_y_advance;
	)! !

!CairoFontFace commentStamp: ''!
I am a private class, used to represent a 'cairo_font_face_t *' data structure 
of Cairo library.

I am not useful for direct use nor providing any functionality. My only purpose is to keep a strong reference to original FT2Face object
(so it won't be freed before a corresponding instance of mine will release it).

!
!CairoFontFace methodsFor: 'accessing' stamp: ''!
synthesizeBoldAndOblique
	self primSetSynthesizeEmphasis: 3! !

!CairoFontFace methodsFor: 'initialization' stamp: ''!
initialize 
	self autoRelease! !

!CairoFontFace methodsFor: 'accessing' stamp: ''!
synthesizeEmphasis: emphasisCode

	emphasisCode = (self class boldEmphasisCode | self class italicEmphasisCode)
		ifTrue: [ ^ self synthesizeBoldAndOblique ].
	emphasisCode = self class boldEmphasisCode
		ifTrue: [ ^ self synthesizeBold ].
	emphasisCode = self class italicEmphasisCode
		ifTrue: [ ^ self synthesizeOblique ]! !

!CairoFontFace methodsFor: 'initialization' stamp: ''!
initializeWithFreetypeFace: aFace
	FFIExternalResourceManager
		addResource: self
		executor:
			(CairoFontFaceExecutor new
				resourceClass: self class data: self resourceData;
				ftFace: aFace)! !

!CairoFontFace methodsFor: 'private' stamp: ''!
primSetSynthesizeEmphasis: flags
"
void
cairo_ft_font_face_set_synthesize (cairo_font_face_t *font_face,
                                   int synth_flags);
"
	^ self ffiCall: #( void cairo_ft_font_face_set_synthesize(self, int flags ))! !

!CairoFontFace methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!CairoFontFace methodsFor: 'external resource management' stamp: ''!
resourceData 
	^ handle value! !

!CairoFontFace methodsFor: 'accessing' stamp: ''!
status
	^ self ffiCall: #(int cairo_font_face_status (self))! !

!CairoFontFace methodsFor: 'accessing' stamp: ''!
synthesizeOblique
	self primSetSynthesizeEmphasis: 2! !

!CairoFontFace methodsFor: 'accessing' stamp: ''!
synthesizeBold
	self primSetSynthesizeEmphasis: 1! !

!CairoFontFace class methodsFor: 'private' stamp: ''!
boldEmphasisCode

	^ 1! !

!CairoFontFace class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CairoFontFace class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CairoFontFace class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CairoFontFace class methodsFor: 'private' stamp: ''!
italicEmphasisCode

	^ 2! !

!CairoFontFace class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CairoFontFace class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CairoFontFace class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CairoFontFace class methodsFor: 'instance creation' stamp: ''!
fromFreetypeFace: aFace
	| handle cairoFace |
	handle := aFace getHandle.
 	cairoFace := self primFtFace: handle loadFlags: 0.
	
	^ cairoFace initializeWithFreetypeFace: aFace! !

!CairoFontFace class methodsFor: 'finalizing' stamp: ''!
finalizeResourceData: handle

"
void                cairo_font_face_destroy             (cairo_font_face_t *font_face);
"
	^ self ffiCall: #( void cairo_font_face_destroy (size_t handle))! !

!CairoFontFace class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CairoFontFace class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CairoFontFace class methodsFor: 'instance creation' stamp: ''!
primFtFace: aFace loadFlags: flags

"
cairo_font_face_t * cairo_ft_font_face_create_for_ft_face
                                                        (FT_Face face,
                                                         int load_flags);

load_flags: flags to pass to FT_Load_Glyph when loading glyphs from the font. These flags are OR'ed together with the flags derived from the cairo_font_options_t passed to cairo_scaled_font_create(), so only a few values such as FT_LOAD_VERTICAL_LAYOUT, and FT_LOAD_FORCE_AUTOHINT are useful. You should not pass any of the flags affecting the load target, such as FT_LOAD_TARGET_LIGHT.
"
	^ self ffiCall: #( CairoFontFace cairo_ft_font_face_create_for_ft_face(void * aFace , int flags ))! !

!CairoFontFace class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CairoFontFace class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CairoFontFace class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CairoFontFace class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CairoFontFace class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CairoFontFace class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CairoFontFace class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CairoFontFace class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CairoFontFace class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CairoFontFace class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CairoFontFace class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CairoFontFace class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!CairoFontFace class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CairoFontFace class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CairoFontFace class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CairoFontFace class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CairoFontFace class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CairoFontFace class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CairoFontFace class methodsFor: 'finalizing' stamp: ''!
hasSharedResourceData: handle
	"Answer wether the external cairo_font_face resource is shared (referenced) by other external objects."
	^(self countReferences: handle) > 1! !

!CairoFontFace class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CairoFontFace class methodsFor: 'finalizing' stamp: ''!
countReferences: handle
"
unsigned int  cairo_font_face_get_reference_count             (cairo_font_face_t *font_face);
"
	^ self ffiCall: #( uint cairo_font_face_get_reference_count (size_t handle))! !

!CairoFontFace class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CairoFontFace class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CairoFontFace class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CairoFontFaceExecutor commentStamp: ''!
A CairoFontFaceExecutor is reponsible of releasing the external 'cairo_font_face_t *' data structure when a corresponding CairoFontFace instance in Smalltalk object memory has been garbage collected.

The external data structure may still be referenced from other cairo objects in the external heap as explained in cairo online documentation https://www.cairographics.org/manual/cairo-FreeType-Fonts.html .

It is thus vital that we do not release the underlying FreeType face until the number of references drops to 1, meaning that we are the last reference, and that we can safely really finalize the external resource.

In order to prevent the free type face to be garbage collected (and its associated FT_face resource to be released), we use an instance variable just for retaining a string reference to it.

More details on the object graph can be found on Pharo issue tracker at
https://pharo.fogbugz.com/f/cases/20776/Potential-dangling-ref-to-freed-FT_Face
!
!CairoFontFaceExecutor methodsFor: 'finalization' stamp: ''!
reallyFinalize 
	ftFace := nil.
	session = Smalltalk session ifFalse: [ ^ self ].
	resourceClass finalizeResourceData: data! !

!CairoFontFaceExecutor methodsFor: 'accessing' stamp: ''!
ftFace: aFace
	"Retain a strong reference to the FreeType face, until we really release the external cairo_font_face resource."
	ftFace := aFace! !

!CairoFontFaceExecutor methodsFor: 'finalization' stamp: ''!
finalize 
	session = Smalltalk session ifFalse: [ ^ self ].
	(resourceClass hasSharedResourceData: data) ifFalse: [ ^self reallyFinalize].
	
	UIManager default inform: 'Attempt to release a shared cairo_font_face.
Please report this on pharo-dev mailing list'.
	
	[ "Regularly poll for the right moment to release the resource"
	[20 seconds wait.
	session = Smalltalk session and: [ resourceClass hasSharedResourceData: data ] ] whileTrue.
	self reallyFinalize] forkAt: Processor userBackgroundPriority.! !

!CairoFontMetricsProvider commentStamp: ''!
Provide font metrics (Cairo)!
!CairoFontMetricsProvider methodsFor: 'accessing' stamp: ''!
getGlyphWidth: aCharacter
	cairoFont getExtentsOf: (utfConverter convertChar: aCharacter) into: glyphExtents.
	^ glyphExtents x_advance! !

!CairoFontMetricsProvider methodsFor: 'accessing' stamp: ''!
cairoFont
	^ cairoFont! !

!CairoFontMetricsProvider methodsFor: 'private' stamp: ''!
freeGlyphs: glyphs
	^ self ffiCall: #( void cairo_glyph_free (void *glyphs))! !

!CairoFontMetricsProvider methodsFor: 'initialization' stamp: ''!
initialize
	utfConverter := CairoUTF8Converter new.
	glyphExtents := CairoTextExtents new.
	cache := CairoBackendCache soleInstance.! !

!CairoFontMetricsProvider methodsFor: 'private' stamp: ''!
applyKerningOn: aGlyphs of: aString from: start to: end
	|kerning  previous|
	kerning := 0.
	previous := nil.
	aGlyphs doWithIndex: [ :glyph :index | |current|
		current := aString at: start + (index - 1).
		index > 1 ifTrue: [
			kerning := kerning + (font kerningLeft: previous right: current).
			glyph x: glyph x + kerning ].
		previous := current ]! !

!CairoFontMetricsProvider methodsFor: 'accessing' stamp: ''!
extentsOf: aString
	|glyphs|
	glyphs := self glyphsOf: aString.
   cairoFont getExtentsOfGlyphs: glyphs getHandle ofLength: glyphs size into: glyphExtents.
	^ glyphExtents! !

!CairoFontMetricsProvider methodsFor: 'accessing' stamp: ''!
font: aFont
	font := aFont asFreetypeFont.
	cairoFont :=	CairoScaledFont fromFreetypeFont: font.
	extents := cairoFont extents.! !

!CairoFontMetricsProvider methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!CairoFontMetricsProvider methodsFor: 'accessing' stamp: ''!
fontHeight
	^ extents height! !

!CairoFontMetricsProvider methodsFor: 'private' stamp: ''!
glyphsOf: aString from: start to: end
	| len ptr glyphs lenValue glyphsSize utf8Len error |

	len := end-start+1.
	utf8Len := utfConverter convert: aString from: start to: end.

	ptr := ExternalAddress new.
	lenValue := ByteArray new: 4.
	lenValue unsignedLongAt: 1 put: len.
		
	error := self 
		convertString: utfConverter buffer 
		len: utf8Len
		ofFont: cairoFont 
		toGlyphs: ptr
		numGlyphs: lenValue 
		x: 0.0 
		y: 0.0.
		
	error = CAIRO_STATUS_SUCCESS ifFalse: [  ^ CairoGlyphsArray new: 0 ].

	glyphsSize := lenValue unsignedLongAt: 1.
   cairoFont getExtentsOfGlyphs: ptr ofLength: glyphsSize into: glyphExtents.
	
	glyphs := CairoGlyphsArray new: glyphsSize.
	LibC memCopy: ptr to: glyphs getHandle size: (glyphsSize * glyphs typeSize).
	"Apply kerning on glyphs if font supports it"
	font face hasKerning
		ifTrue: [ self applyKerningOn: glyphs of: aString from: start to: end ].
	self freeGlyphs: ptr.
		
	^ glyphs! !

!CairoFontMetricsProvider methodsFor: 'private' stamp: ''!
convertString: utf8String len: strlen ofFont: aScaledFont toGlyphs: glyphs numGlyphs: numGlyphs x: x y: y
"
all of this for using 
http://www.cairographics.org/manual/cairo-User-Fonts.html#cairo-user-scaled-font-text-to-glyphs-func-t

"
	^ self ffiCall: #(
		cairo_status_t cairo_scaled_font_text_to_glyphs (CairoScaledFont aScaledFont,
			double x,
			double y,
			void * utf8String,
			int strlen,
			void ** glyphs,
			int * numGlyphs,
			NULL,
			NULL,
			NULL))! !

!CairoFontMetricsProvider methodsFor: 'private' stamp: ''!
glyphsOf: aString
	^ self glyphsOf: aString from: 1 to: aString size! !

!CairoFontMetricsProvider methodsFor: 'accessing' stamp: ''!
fontAscent
	^ extents ascent! !

!CairoFontMetricsProvider class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CairoFontMetricsProvider class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CairoFontMetricsProvider class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CairoFontMetricsProvider class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CairoFontMetricsProvider class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CairoFontMetricsProvider class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CairoFontMetricsProvider class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CairoFontMetricsProvider class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CairoFontMetricsProvider class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CairoFontMetricsProvider class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CairoFontMetricsProvider class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CairoFontMetricsProvider class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CairoFontMetricsProvider class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CairoFontMetricsProvider class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CairoFontMetricsProvider class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CairoFontMetricsProvider class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CairoFontMetricsProvider class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CairoFontMetricsProvider class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CairoFontMetricsProvider class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CairoFontMetricsProvider class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!CairoFontMetricsProvider class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CairoFontMetricsProvider class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CairoFontMetricsProvider class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CairoFontMetricsProvider class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CairoFontMetricsProvider class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CairoFontMetricsProvider class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CairoFontMetricsProvider class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CairoFontMetricsProvider class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CairoFontMetricsProvider class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CairoFontMetricsProvider class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CairoFontOptions commentStamp: ''!
i represent various font options exposed by cairo library!
!CairoFontOptions methodsFor: 'subpixel order' stamp: ''!
subpixelOrderVBGR
	^ self setSubpixelOrder: CAIRO_SUBPIXEL_ORDER_VBGR! !

!CairoFontOptions methodsFor: 'antialiasing' stamp: ''!
aaFast

	^ self setAA: CAIRO_ANTIALIAS_FAST.! !

!CairoFontOptions methodsFor: 'subpixel order' stamp: ''!
subpixelOrderBGR
	^ self setSubpixelOrder: CAIRO_SUBPIXEL_ORDER_BGR! !

!CairoFontOptions methodsFor: 'hint options' stamp: ''!
setHintStyle: aStyle
	"cairo_font_options_set_hint_style ()

void                cairo_font_options_set_hint_style   (cairo_font_options_t *options,
                                                         cairo_hint_style_t hint_style);

Sets the hint style for font outlines for the font options object. This controls whether to fit font outlines to the pixel grid, and if so, whether to optimize for fidelity or contrast. See the documentation for cairo_hint_style_t for full details. "
	^ self ffiCall: #( 
		void cairo_font_options_set_hint_style (self, uint aStyle))! !

!CairoFontOptions methodsFor: 'antialiasing' stamp: ''!
aaGray

	^ self setAA: CAIRO_ANTIALIAS_GRAY.! !

!CairoFontOptions methodsFor: 'antialiasing' stamp: ''!
aaGood

	^ self setAA: CAIRO_ANTIALIAS_GOOD.! !

!CairoFontOptions methodsFor: 'antialiasing' stamp: ''!
aaBest

	^ self setAA: CAIRO_ANTIALIAS_BEST.! !

!CairoFontOptions methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!CairoFontOptions methodsFor: 'hint options' stamp: ''!
hintMetricsOff
	^ self setHintMetrics: CAIRO_HINT_METRICS_OFF! !

!CairoFontOptions methodsFor: 'antialiasing' stamp: ''!
aaSubpixel

	^ self setAA: CAIRO_ANTIALIAS_SUBPIXEL.! !

!CairoFontOptions methodsFor: 'hint options' stamp: ''!
hintStyleNone
	^ self setHintStyle: CAIRO_HINT_STYLE_NONE! !

!CairoFontOptions methodsFor: 'subpixel order' stamp: ''!
subpixelOrderVRGB
	^ self setSubpixelOrder: CAIRO_SUBPIXEL_ORDER_VRGB! !

!CairoFontOptions methodsFor: 'antialiasing' stamp: ''!
setAA: antialias

"cairo_font_options_set_antialias ()

void                cairo_font_options_set_antialias    (cairo_font_options_t *options,
                                                         cairo_antialias_t antialias);

Sets the antialiasing mode for the font options object. This specifies the type of antialiasing to do when rendering text.

options :
	a cairo_font_options_t

antialias :
	the new antialiasing mode"
	^ self ffiCall: #( 
	void cairo_font_options_set_antialias (self, uint antialias))! !

!CairoFontOptions methodsFor: 'antialiasing' stamp: ''!
aaNone

	^ self setAA: CAIRO_ANTIALIAS_NONE.! !

!CairoFontOptions methodsFor: 'initialization' stamp: ''!
initialize 
	self autoRelease.
	self setDefaults! !

!CairoFontOptions methodsFor: 'antialiasing' stamp: ''!
aaDefault

	^ self setAA: CAIRO_ANTIALIAS_DEFAULT.! !

!CairoFontOptions methodsFor: 'hint options' stamp: ''!
setHintMetrics: hintMetrics
"
	void	cairo_font_options_set_hint_metrics (cairo_font_options_t *options,
		cairo_hint_metrics_t hint_metrics);

 Sets the metrics hinting mode for the font options object. This controls whether metrics are quantized to integer values in device units. See the documentation for cairo_hint_metrics_t for full details.

"
	^ self ffiCall: #(void cairo_font_options_set_hint_metrics (self,  uint hintMetrics))! !

!CairoFontOptions methodsFor: 'hint options' stamp: ''!
hintStyleMedium
	^ self setHintStyle: CAIRO_HINT_STYLE_MEDIUM! !

!CairoFontOptions methodsFor: 'defaults' stamp: ''!
setDefaults

	self hintStyleSlight; hintMetricsOff; subpixelOrderRGB; aaSubpixel! !

!CairoFontOptions methodsFor: 'initialization' stamp: ''!
resourceData

	^ handle value! !

!CairoFontOptions methodsFor: 'subpixel order' stamp: ''!
subpixelOrderRGB
	^ self setSubpixelOrder: CAIRO_SUBPIXEL_ORDER_RGB! !

!CairoFontOptions methodsFor: 'hint options' stamp: ''!
hintStyleSlight
	^ self setHintStyle: CAIRO_HINT_STYLE_SLIGHT! !

!CairoFontOptions methodsFor: 'subpixel order' stamp: ''!
setSubpixelOrder: order
	"void cairo_font_options_set_subpixel_order
		(cairo_font_options_t *options,
		cairo_subpixel_order_t subpixel_order)"
	^ self ffiCall: #(
		void cairo_font_options_set_subpixel_order (self, uint order))! !

!CairoFontOptions methodsFor: 'hint options' stamp: ''!
hintStyleFull
	^ self setHintStyle: CAIRO_HINT_STYLE_FULL! !

!CairoFontOptions methodsFor: 'hint options' stamp: ''!
hintMetricsDefault
	^ self setHintMetrics: CAIRO_HINT_METRICS_DEFAULT! !

!CairoFontOptions methodsFor: 'subpixel order' stamp: ''!
subpixelOrderDefault
	^ self setSubpixelOrder: CAIRO_SUBPIXEL_ORDER_DEFAULT! !

!CairoFontOptions methodsFor: 'hint options' stamp: ''!
hintStyleDefault
	^ self setHintStyle: CAIRO_HINT_STYLE_DEFAULT! !

!CairoFontOptions methodsFor: 'hint options' stamp: ''!
hintMetricsOn
	^ self setHintMetrics: CAIRO_HINT_METRICS_ON! !

!CairoFontOptions class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CairoFontOptions class methodsFor: 'instance creation' stamp: ''!
new
	^ self primCreate initialize! !

!CairoFontOptions class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CairoFontOptions class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CairoFontOptions class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CairoFontOptions class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CairoFontOptions class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CairoFontOptions class methodsFor: 'finalizing' stamp: ''!
finalizeResourceData: aData
	"finalize the external resource data, returned by #resourceData on instance side"
	
	self primDestroy: aData! !

!CairoFontOptions class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CairoFontOptions class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CairoFontOptions class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CairoFontOptions class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CairoFontOptions class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CairoFontOptions class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CairoFontOptions class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CairoFontOptions class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CairoFontOptions class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CairoFontOptions class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CairoFontOptions class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CairoFontOptions class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CairoFontOptions class methodsFor: 'private' stamp: ''!
primCreate
"cairo_font_options_t * cairo_font_options_create        (void);

Allocates a new font options object with all options initialized to default values.

Returns :
	a newly allocated cairo_font_options_t. Free with cairo_font_options_destroy(). This function always returns a valid pointer; if memory cannot be allocated, then a special error object is returned where all operations on the object do nothing. You can check for this with cairo_font_options_status().

"	
	^ self ffiCall: #(CairoFontOptions cairo_font_options_create ())! !

!CairoFontOptions class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CairoFontOptions class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!CairoFontOptions class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CairoFontOptions class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CairoFontOptions class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CairoFontOptions class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CairoFontOptions class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CairoFontOptions class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CairoFontOptions class methodsFor: 'private' stamp: ''!
primDestroy: anOptions
"void                cairo_font_options_destroy          (cairo_font_options_t *options);

Destroys a cairo_font_options_t object created with cairo_font_options_create() or cairo_font_options_copy().

options :
	a cairo_font_options_t"
	^ self ffiCall: #(void cairo_font_options_destroy (size_t anOptions))! !

!CairoFontOptions class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CairoFontOptions class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CairoFontOptions class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CairoFontOptions class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CairoFreetypeFontRenderer commentStamp: ''!
I am used to render freetype font(s) with cairo library.

Before start rendering, you must set:
 - canvas
 - font
!
!CairoFreetypeFontRenderer methodsFor: 'accessing - font metrics' stamp: ''!
getGlyphWidth: aCharacter
	utfConverter convert: aCharacter asString from: 1 to: 1.
	font getExtentsOf: utfConverter buffer into: glyphExtents.
	^ glyphExtents x_advance! !

!CairoFreetypeFontRenderer methodsFor: 'private' stamp: ''!
freeGlyphs: glyphs
	^ self ffiCall: #( void cairo_glyph_free (void *glyphs))! !

!CairoFreetypeFontRenderer methodsFor: 'initialization' stamp: ''!
initialize 
	utfConverter := CairoUTF8Converter new.
	advance := 0@0.
	glyphExtents := CairoTextExtents new.! !

!CairoFreetypeFontRenderer methodsFor: 'accessing' stamp: ''!
advance: aPoint 
	advance := aPoint! !

!CairoFreetypeFontRenderer methodsFor: 'private' stamp: ''!
applyKerningOn: aGlyphs of: aString from: start to: end
	"Apply kerning on a glyphs that represent aString from
	start to end"
	|kerning  previous|
	kerning := 0.
	previous := nil.
	aGlyphs doWithIndex: [ :glyph :index | |current|
		current := aString at: start + (index - 1).
		index > 1 ifTrue: [
			kerning := kerning + (originalFont kerningLeft: previous right: current).
			glyph x: glyph x + kerning ].
		previous := current ]! !

!CairoFreetypeFontRenderer methodsFor: 'rendering' stamp: ''!
render: aString

	^ self renderCharacters: aString from: 1 to: aString size! !

!CairoFreetypeFontRenderer methodsFor: 'rendering' stamp: ''!
renderCharacters: aString from: start to: end
	| glyphs |

	glyphs := self glyphsOf: aString from: start to: end.
	self renderGlyphs: glyphs.
	^ self advance! !

!CairoFreetypeFontRenderer methodsFor: 'accessing' stamp: ''!
canvas: aCairoCanvas
	
	canvas := aCairoCanvas.! !

!CairoFreetypeFontRenderer methodsFor: 'accessing' stamp: ''!
font: aFreetypeFont 

	font := CairoScaledFont fromFreetypeFont: aFreetypeFont.
	fontExtents := font extents.
	originalFont := aFreetypeFont.! !

!CairoFreetypeFontRenderer methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!CairoFreetypeFontRenderer methodsFor: 'accessing - font metrics' stamp: ''!
fontHeight
	^ fontExtents height! !

!CairoFreetypeFontRenderer methodsFor: 'accessing' stamp: ''!
setColor: aColor 
	(canvas setPaint: aColor )! !

!CairoFreetypeFontRenderer methodsFor: 'accessing - font metrics' stamp: ''!
glyphsOf: aString from: start to: end
	| len ptr glyphs lenValue glyphsSize utf8Len error |

	len := end-start+1.
	utf8Len := utfConverter convert: aString from: start to: end.

	ptr := ExternalAddress new.
	lenValue := ByteArray new: 4.
	lenValue unsignedLongAt: 1 put: len.
	
	"somehow scaled font is buggy and calculated glyphs have wrong extents,
	setting font size manually and retrieving 'fixed' scaled font solves the problem"
	canvas
		setScaledFont: font;
		setFontSize: originalFont pixelSize.
	
	error := self 
		convertString: utfConverter buffer 
		len: utf8Len
		ofFont: canvas getScaledFont 
		toGlyphs: ptr
		numGlyphs: lenValue 
		x: 0.0 
		y: 0.0.
		
	error = CAIRO_STATUS_SUCCESS ifFalse: [  ^ CairoGlyphsArray new: 0 ].

	glyphsSize := lenValue unsignedLongAt: 1.
   font getExtentsOfGlyphs: ptr ofLength: glyphsSize into: glyphExtents.
	advance := glyphExtents width @ glyphExtents height.
	
	glyphs := CairoGlyphsArray new: glyphsSize.
	LibC memCopy: ptr to: glyphs getHandle size: (glyphsSize * glyphs typeSize).
	"Apply kerning on glyphs if font supports it"
	originalFont face hasKerning
		ifTrue: [ self applyKerningOn: glyphs of: aString from: start to: end ].
	self freeGlyphs: ptr.
		
	^ glyphs! !

!CairoFreetypeFontRenderer methodsFor: 'rendering' stamp: ''!
renderGlyphs: cairoGlyphs

	font lock.
	canvas 
		setPathMatrix;
		setScaledFont: font.
	canvas paint loadOnCairoCanvas: canvas.

	canvas showGlyphs: cairoGlyphs getHandle size: cairoGlyphs size.
	font unlock.! !

!CairoFreetypeFontRenderer methodsFor: 'private' stamp: ''!
convertString: utf8String len: strlen ofFont: aScaledFont toGlyphs: glyphs numGlyphs: numGlyphs x: x y: y
"
all of this for using 
http://www.cairographics.org/manual/cairo-User-Fonts.html#cairo-user-scaled-font-text-to-glyphs-func-t

"
	^ self ffiCall: #(
		cairo_status_t cairo_scaled_font_text_to_glyphs (CairoScaledFont aScaledFont,
			double x,
			double y,
			void * utf8String,
			int strlen,
			void ** glyphs,
			int * numGlyphs,
			NULL,
			NULL,
			NULL))! !

!CairoFreetypeFontRenderer methodsFor: 'accessing' stamp: ''!
advance
	^ advance! !

!CairoFreetypeFontRenderer methodsFor: 'accessing - font metrics' stamp: ''!
fontAscent
	^ fontExtents ascent! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CairoFreetypeFontRenderer class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CairoFreetypeFontRenderer class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CairoFreetypeFontRenderer class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CairoFreetypeFontRenderer class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CairoFreetypeFontRenderer class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CairoFreetypeFontRenderer class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CairoFreetypeFontRenderer class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CairoFreetypeFontRenderer class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CairoFreetypeFontRenderer class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CairoFreetypeFontRenderer class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CairoFreetypeFontRenderer class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CairoFreetypeFontRenderer class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CairoFreetypeFontRenderer class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CairoFreetypeFontRenderer class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CairoFreetypeFontRenderer class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CairoFreetypeFontRenderer class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CairoFreetypeFontRenderer class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CairoFreetypeFontRenderer class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CairoFreetypeFontRenderer class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CairoGlyph commentStamp: ''!
I correspond to `cairo_glyph_t` structure:

```
typedef struct {
    unsigned long        index;
    double               x;
    double               y;
} cairo_glyph_t;
```!
!CairoGlyph methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_Y put: anObject! !

!CairoGlyph methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle doubleAt: OFFSET_X! !

!CairoGlyph methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_X put: anObject! !

!CairoGlyph methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle doubleAt: OFFSET_Y! !

!CairoGlyph methodsFor: 'accessing - structure variables' stamp: ''!
index: anObject
	"This method was automatically generated"
	^handle platformUnsignedLongAt: OFFSET_INDEX put: anObject! !

!CairoGlyph methodsFor: 'accessing - structure variables' stamp: ''!
index
	"This method was automatically generated"
	^handle platformUnsignedLongAt: OFFSET_INDEX! !

!CairoGlyph class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
	ulong        index;
	double       x;
	double       y;
	)! !

!CairoGlyphsArray commentStamp: ''!
Captain obvious tells this is an array of CairoGlyph(s),
corresponds to cairo_glyph_t structure:

```
typedef struct {
    unsigned long        index;
    double               x;
    double               y;
} cairo_glyph_t;
```!
!CairoGlyphsArray methodsFor: 'accessing' stamp: ''!
allocatedByCairo: aBoolean
	allocatedByCairo := aBoolean! !

!CairoGlyphsArray methodsFor: 'accessing' stamp: ''!
allocatedByCairo
	^ allocatedByCairo! !

!CairoGlyphsArray class methodsFor: 'instance creation' stamp: ''!
new
	^ self new: nil! !

!CairoGlyphsArray class methodsFor: 'instance creation' stamp: ''!
new: size 
	^ self newType: CairoGlyph size: size! !

!CairoGlyphsArray class methodsFor: 'instance creation' stamp: ''!
externalNew: size 
	^ self externalNewType: CairoGlyph size: size! !

!CairoLibrary commentStamp: ''!
I provide access to cairo library. 
Since paths and names can be tricky in different versions, I have methods to solve this in any platforms I want cairo to run.!
!CairoLibrary methodsFor: 'accessing - platform' stamp: ''!
unix32LibraryName
	"On different flavors of linux the path to library may differ
	depending on OS distro or whether system is 32 or 64 bit.
	Packages such as snapcraft can also change the path.
	Look in a number of known locations, or LD_LIBRARY_PATH."

	^ FFIUnix32LibraryFinder findLibrary: 'libcairo.so.2'! !

!CairoLibrary methodsFor: 'accessing - platform' stamp: ''!
win32LibraryName 
	
	^ FFIWindowsLibraryFinder findAnyLibrary: #('libcairo-2.dll')! !

!CairoLibrary methodsFor: 'versions' stamp: ''!
versionString
	"Answer the version in a String, such as '1.16.0'. 
	
	See https://www.cairographics.org/manual/cairo-Version-Information.html#cairo-version-string
	"

	^ self ffiCall: #( String cairo_version_string #() )! !

!CairoLibrary methodsFor: 'accessing - platform' stamp: ''!
unixLibraryName
	"Backward compatibility"
	^ self unix32LibraryName! !

!CairoLibrary methodsFor: 'accessing - platform' stamp: ''!
unix64LibraryName
	"On different flavors of linux the path to library may differ
	depending on OS distro or whether system is 32 or 64 bit.
	Packages such as snapcraft can also change the path.
	Look in a number of known locations, or LD_LIBRARY_PATH."

	^ FFIUnix64LibraryFinder findLibrary: 'libcairo.so.2'! !

!CairoLibrary methodsFor: 'accessing - platform' stamp: ''!
macLibraryName

	^ FFIMacLibraryFinder findLibrary: 'libcairo.2.dylib'! !

!CairoLibraryTest commentStamp: ''!
A CairoLibraryTest is a test class for testing the behavior of CairoLibrary!
!CairoLibraryTest methodsFor: 'tests' stamp: ''!
testVersionString

	self assert:
		(CairoLibrary uniqueInstance versionString beginsWith: '1.')! !

!CairoPNGPaint commentStamp: ''!
I am a surface paint with lazy initialization scheme, that i loading image from .png file
the first time i will be used.

<Do not use me, because i am really Cairo specific>!
!CairoPNGPaint methodsFor: 'converting' stamp: ''!
asAthensPaintOn: anAthensCanvas

	| surface |

	 surface := AthensCairoSurface createFromFile: fileName ifFailed: [ :status | 

		status =  CAIRO_STATUS_READ_ERROR ifTrue: [ 
			self error: 'Cairo couldnt read the file named ', fileName ].
		status = CAIRO_STATUS_FILE_NOT_FOUND ifTrue: [
			self error: 'Cairo cant find the file named ', fileName ].

		^ self error: 'Cannot create surface. Cairo status code: ', status asString 
	].
	
	^ surface asAthensPaintOn: anAthensCanvas.! !

!CairoPNGPaint methodsFor: 'initialization' stamp: ''!
initializeOnFileNamed: aFileName
	fileName := aFileName.! !

!CairoPNGPaint class methodsFor: 'instance creation' stamp: ''!
fileNamed: aFileName
	| image|
	image := self new.
	image initializeOnFileNamed: aFileName.
	^ image! !

!CairoScaledFont commentStamp: ''!
My instances map to `cairo_scaled_font_t *` data type.!
!CairoScaledFont methodsFor: 'accessing' stamp: ''!
getExtentsOf: utf8String into: extentObj 
	"void                cairo_scaled_font_extents           (cairo_scaled_font_t *scaled_font,
                                                         cairo_font_extents_t *extents);
	"
	^ self ffiCall: #(
		void cairo_scaled_font_text_extents (self,
			void *utf8String,
			cairo_text_extents_t * extentObj))! !

!CairoScaledFont methodsFor: 'accessing' stamp: ''!
getFontScaleMatrixInto: cairoFontMatrix
	^ self ffiCall: #(
		void
		cairo_scaled_font_get_scale_matrix (self,
 	                                  AthensCairoMatrix *cairoFontMatrix))! !

!CairoScaledFont methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	self status ~= CAIRO_STATUS_SUCCESS 
		ifTrue: [ self error: 'Something is wrong!!' ].
	self autoRelease! !

!CairoScaledFont methodsFor: 'locking' stamp: ''!
unlock

"
FT_Face             cairo_ft_scaled_font_lock_face      (cairo_scaled_font_t *scaled_font);

"
	^ self ffiCall: #( 
		void cairo_ft_scaled_font_unlock_face  (self))! !

!CairoScaledFont methodsFor: 'accessing' stamp: ''!
getExtents: cairoFontExtents
	"void                cairo_scaled_font_extents           (cairo_scaled_font_t *scaled_font,
                                                         cairo_font_extents_t *extents);
	"
	^ self ffiCall: #(int cairo_scaled_font_extents (self, CairoFontExtents * cairoFontExtents ))! !

!CairoScaledFont methodsFor: 'accessing' stamp: ''!
freeTypeFont: aFreeTypeFont 
	
	freeTypeFont := aFreeTypeFont! !

!CairoScaledFont methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!CairoScaledFont methodsFor: 'accessing' stamp: ''!
getFontMatrixInto: cairoFontMatrix
	^ self ffiCall: #(
		void
		cairo_scaled_font_get_font_matrix (self,
 	                                  AthensCairoMatrix *cairoFontMatrix))! !

!CairoScaledFont methodsFor: 'initialization' stamp: ''!
initWithFace: cairo_face

	face := cairo_face.
	
	self autoRelease.! !

!CairoScaledFont methodsFor: 'external resource management' stamp: ''!
resourceData 
	^ handle value! !

!CairoScaledFont methodsFor: 'locking' stamp: ''!
lock

"
FT_Face             cairo_ft_scaled_font_lock_face      (cairo_scaled_font_t *scaled_font);

"
	^ self ffiCall: #( 
		void cairo_ft_scaled_font_lock_face (self))! !

!CairoScaledFont methodsFor: 'accessing' stamp: ''!
extents
	| extents |
	extents := CairoFontExtents new.

	self getExtents: extents.
	
	^ extents! !

!CairoScaledFont methodsFor: 'accessing' stamp: ''!
status
"cairo_status_t      cairo_scaled_font_status            (cairo_scaled_font_t *scaled_font);"
	^ self ffiCall: #(int cairo_scaled_font_status (self))! !

!CairoScaledFont methodsFor: 'accessing' stamp: ''!
getExtentsOfGlyphs: glyphs ofLength: num into: extents 
	"void
	cairo_scaled_font_glyph_extents (cairo_scaled_font_t *scaled_font,
                                 const cairo_glyph_t *glyphs,
                                 int num_glyphs,
                                 cairo_text_extents_t *extents);"
	^ self ffiCall: #(
		void cairo_scaled_font_glyph_extents (self,
                                            void *glyphs,
                                            int num,
                                            cairo_text_extents_t *extents))! !

!CairoScaledFont class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CairoScaledFont class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CairoScaledFont class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CairoScaledFont class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CairoScaledFont class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CairoScaledFont class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CairoScaledFont class methodsFor: 'instance creation' stamp: ''!
fromFreetypeFont: aFont cairoFace: face

	| options fontMatrix deviceMatrix font |

	options := CairoBackendCache soleInstance 
		at: #AAOptions ifAbsentPut: [ CairoFontOptions new ].
	fontMatrix := AthensCairoMatrix new.
	deviceMatrix := AthensCairoMatrix new.

	fontMatrix scaleBy: (self pointsToPixels: aFont pointSize).
	
	font := self primCreate: face fontMatrix: fontMatrix  userToDeviceMatrix: deviceMatrix options: options. 
	
	"to keep a reference to cairo face in instance"
	^ (font initWithFace: face)
			freeTypeFont: aFont;
			yourself.! !

!CairoScaledFont class methodsFor: 'finalizing' stamp: ''!
finalizeResourceData: handle

"
void                cairo_scaled_font_destroy           (cairo_scaled_font_t *scaled_font);
"
	^ self ffiCall: #( void  cairo_scaled_font_destroy (size_t handle) )! !

!CairoScaledFont class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CairoScaledFont class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CairoScaledFont class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CairoScaledFont class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CairoScaledFont class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CairoScaledFont class methodsFor: 'private' stamp: ''!
primCreate: face fontMatrix: fontMatrix userToDeviceMatrix: ctm options: options
"
cairo_scaled_font_t * cairo_scaled_font_create          (cairo_font_face_t *font_face,
                                                         const cairo_matrix_t *font_matrix,
                                                         const cairo_matrix_t *ctm,
                                                         const cairo_font_options_t *options);


 Creates a cairo_scaled_font_t object from a font face and matrices that describe the size of the font and the environment in which it will be used.

font_face :
	a cairo_font_face_t

font_matrix :
	font space to user space transformation matrix for the font. In the simplest case of a N point font, this matrix is just a scale by N, but it can also be used to shear the font or stretch it unequally along the two axes. See cairo_set_font_matrix().

ctm :
	user to device transformation matrix with which the font will be used.

options :
	options to use when getting metrics for the font and rendering with it.

Returns :
	a newly created cairo_scaled_font_t. Destroy with cairo_scaled_font_destroy()
"
	^ self ffiCall: #( 
		CairoScaledFont cairo_scaled_font_create (
			CairoFontFace face,
			AthensCairoMatrix * fontMatrix,
			AthensCairoMatrix * ctm,
			CairoFontOptions  options ) )! !

!CairoScaledFont class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CairoScaledFont class methodsFor: 'instance creation' stamp: ''!
fromFreetypeFont: aFont
	| ftFace face |
	^ CairoBackendCache soleInstance at: aFont ifAbsentPut: [ | emphasis |
			emphasis := aFont simulatedEmphasis.
			"I will copy it, as it used by cairo"
			ftFace := aFont face copy.
			face := CairoFontFace fromFreetypeFace: ftFace.
			emphasis ifNotNil: [ face synthesizeEmphasis: emphasis ].
			self fromFreetypeFont: aFont cairoFace: face ]! !

!CairoScaledFont class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CairoScaledFont class methodsFor: 'private' stamp: ''!
pixelsPerInch

	self flag: #TODO. "Hardcoded, but it need to come from the right place (which varies depending on 
	the graphics backend)"
	^ 96.0 ! !

!CairoScaledFont class methodsFor: 'accessing' stamp: ''!
pointsToPixels: points

	^ points * self pixelsPerInch / 72.0! !

!CairoScaledFont class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CairoScaledFont class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CairoScaledFont class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CairoScaledFont class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CairoScaledFont class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CairoScaledFont class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CairoScaledFont class methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!CairoScaledFont class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CairoScaledFont class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CairoScaledFont class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CairoScaledFont class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CairoScaledFont class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CairoScaledFont class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CairoScaledFont class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CairoScaledFont class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CairoScaledFont class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CairoScaledFont class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CairoTextExtents commentStamp: ''!
I represent the `cairo_text_extents_t` structure type.

The `cairo_text_extents_t` structure stores the extents of a single glyph or a string of glyphs in user-space coordinates. Because text extents are in user-space coordinates, they are mostly, but not entirely, independent of the current transformation matrix. If you call `cairo_scale(cr, 2.0, 2.0)`, text will be drawn twice as big, but the reported text extents will not be doubled. They will change slightly due to hinting (so you can't assume that metrics are independent of the transformation matrix), but otherwise will remain unchanged.

- `double x_bearing` the horizontal distance from the origin to the leftmost part of the glyphs as drawn. Positive if the glyphs lie entirely to the right of the origin.
- `double y_bearing` the vertical distance from the origin to the topmost part of the glyphs as drawn. Positive only if the glyphs lie completely below the origin; will usually be negative.
- `double width`	width of the glyphs as drawn
- `double height`height of the glyphs as drawn
- `double x_advance` distance to advance in the X direction after drawing these glyphs
- `double y_advance` distance to advance in the Y direction after drawing these glyphs. Will typically be zero except for vertical text layout as found in East-Asian languages.!
!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
width: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_WIDTH put: anObject! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
width
	"This method was automatically generated"
	^handle doubleAt: OFFSET_WIDTH! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
x_advance: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_X_ADVANCE put: anObject! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
x_bearing
	"This method was automatically generated"
	^handle doubleAt: OFFSET_X_BEARING! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
y_advance
	"This method was automatically generated"
	^handle doubleAt: OFFSET_Y_ADVANCE! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
x_advance
	"This method was automatically generated"
	^handle doubleAt: OFFSET_X_ADVANCE! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
height
	"This method was automatically generated"
	^handle doubleAt: OFFSET_HEIGHT! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
y_bearing: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_Y_BEARING put: anObject! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
height: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_HEIGHT put: anObject! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
x_bearing: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_X_BEARING put: anObject! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
y_bearing
	"This method was automatically generated"
	^handle doubleAt: OFFSET_Y_BEARING! !

!CairoTextExtents methodsFor: 'accessing - structure variables' stamp: ''!
y_advance: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_Y_ADVANCE put: anObject! !

!CairoTextExtents class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
	double x_bearing;
	double y_bearing;
	double width;
	double height;
	double x_advance;
	double y_advance;
	)! !

!CairoUTF8Converter commentStamp: ''!
i use persistent buffer to convert strings to utf-8 strings (an input neede by cairo)!
!CairoUTF8Converter methodsFor: 'converting' stamp: ''!
convertChar: aCharacter 

	self checkBufferSpace: 8.

	bs reset.
	encoder nextPut: aCharacter toStream: bs.
	bs nextPut: 0.
	^ buffer! !

!CairoUTF8Converter methodsFor: 'converting' stamp: ''!
checkBufferSpace: minimalSize
	| size |
	
	size := buffer ifNil: [ 0 ] ifNotNil: [ buffer size ].
	
	size < minimalSize ifTrue: [
		buffer := ByteArray new: minimalSize.
		bs := buffer writeStream.
		
		]! !

!CairoUTF8Converter methodsFor: 'initialization' stamp: ''!
initialize
	encoder := ZnUTF8Encoder new.! !

!CairoUTF8Converter methodsFor: 'accessing' stamp: ''!
buffer
	^ buffer! !

!CairoUTF8Converter methodsFor: 'converting' stamp: ''!
convert: aString from: start to: end

	self checkBufferSpace: 4*(end-start + 2).
	bs reset.
	
	encoder next: end-start+1 
		putAll: aString 
		startingAt: start 
		toStream: bs .
		
	"DO NOT NULL-Terminate because its not used"

	^ bs position.! !

!CairoUTF8ConverterTest commentStamp: ''!
A CairoUTF8ConverterTest is a test class for testing the behavior of CairoUTF8Converter!
!CairoUTF8ConverterTest methodsFor: 'tests' stamp: ''!
testUnicodencodingShouldTerminateWithNull
	| buf |
	buf := encoder convertChar: $a.
	self assert: (buf first: 2) equals: #[ 97 0 ]! !

!CairoUTF8ConverterTest methodsFor: 'tests' stamp: ''!
testReusingConverterShouldReplaceOldData
	| buf |
	buf := encoder convertChar: 223 asCharacter.
	self assert: (buf first: 3) equals: #[195 159 0].
	buf := encoder convertChar: $b.
	self assert: (buf first: 2) equals: #[98 0]! !

!CairoUTF8ConverterTest methodsFor: 'tests' stamp: ''!
testEncodingString
	|  pos |
	pos := encoder convert: 'abc' from: 1 to: 3.
	
	self assert: pos equals: 3.
	self assert: (encoder buffer first:3) equals: #[97 98 99]! !

!CairoUTF8ConverterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	encoder := CairoUTF8Converter new! !

!CalendarDayMorph commentStamp: ''!
A CalendarDyaMorph represents a specific day on a monthly calendar.


Instance Variables
	bounds:		<Rectangle>
	date:		<Date>
	highlighted:	<Boolean>
	owner:		<CalendarChooserMorph>

bounds
	- owner-relative bounding box

date
	- the specific date (year/month/day) the CalendarMorph represents

highlighted
	- flag to keep track of when a CalendarMorph has the mouse dragging over it, and is thus highlighted

owner
	- the morph that contains the CalendarMorph, and all its siblings
!
!CalendarDayMorph methodsFor: 'printing' stamp: ''!
debugPrint

	^(WriteStream on: (String new: 10))
		print: self class;
		nextPutAll: ' (';
		print: self date;
		nextPutAll: ' - ';
		print: self bounds;
		nextPut: $);
		contents! !

!CalendarDayMorph methodsFor: 'accessing' stamp: ''!
bounds

	^ bounds! !

!CalendarDayMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self highlighted: false! !

!CalendarDayMorph methodsFor: 'accessing' stamp: ''!
date: aDate

	date := aDate.! !

!CalendarDayMorph methodsFor: 'accessing' stamp: ''!
bounds: aRectangle

	bounds := aRectangle! !

!CalendarDayMorph methodsFor: 'drawing' stamp: ''!
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: 'printing' stamp: ''!
printOn: aStream

	aStream
		print: self class;
		nextPutAll: ' (';
		print: self date;
		nextPut: $)! !

!CalendarDayMorph methodsFor: 'accessing' stamp: ''!
highlighted: aBoolean

	highlighted := aBoolean! !

!CalendarDayMorph methodsFor: 'accessing' stamp: ''!
highlighted

	^highlighted! !

!CalendarDayMorph methodsFor: 'accessing' stamp: ''!
owner: aCalendarChooserMorph

	owner := aCalendarChooserMorph! !

!CalendarDayMorph methodsFor: 'accessing' stamp: ''!
owner

	^ owner! !

!CalendarDayMorph methodsFor: 'accessing' stamp: ''!
date

	^ date! !

!CalendarDayMorph class methodsFor: 'instance creation' stamp: ''!
on: aDate for: aCalendarChooserMorph

	^self new
		date: aDate;
		owner: aCalendarChooserMorph;
		yourself.! !

!CalendarMorph commentStamp: ''!
A CalendarMorph is a standalone morph that represents a selectable monthly calendar.

CalendarMorph openOn: Date today



Instance Variables
	date:		<Date>
	days:		<OrderedCollection of: <CalendarChooserDay>>
	touchPoints:	<Dictionary key: <Rectangle> value: <Symbol>>

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: 'drawing' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
date: aDate

	| recompute |
	recompute := date isNil or: [date month ~= aDate month].
	date := aDate.
	recompute
		ifTrue: [self computeDays]! !

!CalendarMorph methodsFor: 'event handling' stamp: ''!
handleNextMonthTouched

	self date: date onNextMonth.
	self changed.! !

!CalendarMorph methodsFor: 'accessing' stamp: ''!
weekdayFont

	^ LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 9.! !

!CalendarMorph methodsFor: 'private' stamp: ''!
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: 'announcing' stamp: ''!
onChoiceSend: aSymbol to: anObject

	self announcer when: ChoseDate send: aSymbol to: anObject.! !

!CalendarMorph methodsFor: 'event handling' stamp: ''!
handleTodayTouched

	self date: Date today.
	self changed.! !

!CalendarMorph methodsFor: 'event handling' stamp: ''!
handleMonthNameTouched

	| newMonthName dayCount |

	newMonthName := UIManager default
		chooseDropList: 'Choose a month:'
		list:
			#('January' 'February' 'March' 'April' 'May' 'June' 'July' 'August' 'September' 'October' 'November' 'December').

	newMonthName ifNil: [ ^ self ].

	dayCount := ( Month year: date year month: newMonthName ) daysInMonth.
	self date: ( Date year: date year month: newMonthName day: ( date dayOfMonth min: dayCount ) ).
	self changed! !

!CalendarMorph methodsFor: 'accessing' stamp: ''!
date

	^date! !

!CalendarMorph methodsFor: 'accessing' stamp: ''!
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: 'event handling' stamp: ''!
mouseMove: event

	self mouseDown: event! !

!CalendarMorph methodsFor: 'private' stamp: ''!
announcer

	^ announcer ifNil: [ announcer := Announcer new ].! !

!CalendarMorph methodsFor: 'private' stamp: ''!
announceDate

	| announcement |
	announcement := ChoseDate of: self date from: self.
	announcer ifNotNil: [ announcer announce: announcement ].! !

!CalendarMorph methodsFor: 'initialize' stamp: ''!
defaultBounds
	"Answer the default bounds for the receiver."

	^0 @ 0 corner: 200 @ 160! !

!CalendarMorph methodsFor: 'event handling' stamp: ''!
handleYearTouched

	| newYear dayCount |

	newYear := UIManager default
		chooseOrRequestFrom: ( 2000 to: 2020 )
		lines: #()
		title: 'Choose a year:'.

	newYear ifNil: [ ^ self ].

	newYear := newYear asNumber.
	dayCount := ( Month year: newYear month: date monthIndex ) daysInMonth.
	self date: ( Date year: newYear month: date monthIndex day: ( date dayOfMonth min: dayCount ) ).
	self changed! !

!CalendarMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	touchPoints := Dictionary new.! !

!CalendarMorph methodsFor: 'accessing' stamp: ''!
monthNameFont

	| font boldItalic |
	font := LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 12.
	boldItalic := TextEmphasis italic emphasisCode | TextEmphasis bold emphasisCode.
	^ font emphasis: boldItalic.! !

!CalendarMorph methodsFor: 'drawing' stamp: ''!
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: ''!
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: ''!
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: 'drawing' stamp: ''!
drawDaysOn: aCanvas

	days do: [:each |
		each
			drawOn: aCanvas
			offset: self bounds topLeft]! !

!CalendarMorph methodsFor: 'event handling' stamp: ''!
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: 'event handling' stamp: ''!
handlesMouseDown: event

	^true! !

!CalendarMorph methodsFor: 'event handling' stamp: ''!
handlePreviousMonthTouched

	self date: date onPreviousMonth.
	self changed.! !

!CalendarMorph methodsFor: 'private' stamp: ''!
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 methodsFor: 'instance creation' stamp: ''!
openOn: aDate

	^(self on: aDate) openInWorld! !

!CalendarMorph class methodsFor: 'instance creation' stamp: ''!
on: aDate

	^self new
		"extent: 200 @ 160;"
		date: aDate;
		yourself.! !

!CalendarPresenter commentStamp: ''!
I am a composable presenter to show a calendar to the user.

See my example methods on class side.!
!CalendarPresenter methodsFor: 'private - constants' stamp: ''!
dayNames
	^ #('Sun' 'Mon' 'Tue' 'Wed' 'Thu' 'Fri' 'Sat')! !

!CalendarPresenter methodsFor: 'accessing' stamp: ''!
whenDaySelectedBlock: aBlockWith0To2Arguments
	"aBlockWith0To2Arguments provided as argument will be called when a day is clicked by the user.
	 If the block has 0 argument, the block is called as is when the user clicked a day.
	 If the block has 1 argument, the block is called with a Date corresponding to the day clicked.
	 If the block has 2 arguments, the block is called with a Date corresponding to the day clicked and myself as arguments."
	whenDaySelectedBlock := aBlockWith0To2Arguments! !

!CalendarPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		title: 'Calendar' translated;
		whenDaySelectedBlock: [ :aDate | ]! !

!CalendarPresenter methodsFor: 'private - event' stamp: ''!
dayClicked: aDate
	self whenDaySelectedBlock cull: aDate cull: self! !

!CalendarPresenter methodsFor: 'private - constants' stamp: ''!
daysToDisplayCount
	^ self maxNumberOfWeeksToDisplay * self daysInAWeek! !

!CalendarPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	previousMonthButton := self newButton.
	previousMonthButton label: '<'.
	
	nextMonthButton := self newButton.
	nextMonthButton label: '>'.
	
	monthYearLabel := self newLabel.
	monthYearLabel label: '-'.
	
	namesOfDaysLabels := self newNullPresenter.
	
	daysButtons := self newNullPresenter! !

!CalendarPresenter methodsFor: 'private' stamp: ''!
daysAfterMonthOf: aDate
	^ self daysToDisplayCount - aDate month daysInMonth - (self dayBeforeMonthOf: aDate)! !

!CalendarPresenter methodsFor: 'private - constants' stamp: ''!
daysInAWeek
	"The number of days in a week."
	^ self dayNames size! !

!CalendarPresenter methodsFor: 'private - constants' stamp: ''!
maxNumberOfWeeksToDisplay
	"Maximum number of weeks to display in the calendar for it to be always well displayed."
	^ 6! !

!CalendarPresenter methodsFor: 'accessing' stamp: ''!
daysButtons
	^ daysButtons! !

!CalendarPresenter methodsFor: 'accessing' stamp: ''!
monthYearLabel
	^ monthYearLabel! !

!CalendarPresenter methodsFor: 'accessing' stamp: ''!
namesOfDaysLabels
	^ namesOfDaysLabels! !

!CalendarPresenter methodsFor: 'private' stamp: ''!
julianDaysIntervalFor: aDate
	"Returns an interval of integers with the first one being the first day to display in the UI and the last integer the last day.
	 The first and last days might not be in the same month as aDate provided as parameter."

	| start end |
	start := aDate julianDayNumber - aDate dayOfMonth - (self dayBeforeMonthOf: aDate) + 1.
	end := aDate julianDayNumber + (aDate month daysInMonth - aDate dayOfMonth) + (self daysAfterMonthOf: aDate).
	^ start to: end! !

!CalendarPresenter methodsFor: 'accessing' stamp: ''!
nextMonthButton
	^ nextMonthButton! !

!CalendarPresenter methodsFor: 'accessing' stamp: ''!
whenDaySelectedBlock
	^ whenDaySelectedBlock! !

!CalendarPresenter methodsFor: 'accessing' stamp: ''!
namesOfDaysLabels: anObject
	namesOfDaysLabels := anObject! !

!CalendarPresenter methodsFor: 'private' stamp: ''!
datesToDisplayFor: aDate
	"Returns the dates to display in the calendar."
	^ (self julianDaysIntervalFor: aDate)
			collect: [ :julianNumber | Date julianDayNumber: julianNumber ]! !

!CalendarPresenter methodsFor: 'private' stamp: ''!
dayBeforeMonthOf: aDate
	^ aDate month dates first dayOfWeek - 1! !

!CalendarPresenter methodsFor: 'accessing' stamp: ''!
previousMonthButton
	^ previousMonthButton! !

!CalendarPresenter methodsFor: 'private' stamp: ''!
daysButtonsBuilderFrom: aDate
	^ DynamicPresentersListBuilder new
		modelObjects: (self datesToDisplayFor: aDate);
		presenter: ButtonPresenter
		configuredAs: [ :button :date | 
			button
				label: date dayOfMonth asString;
				enabled: aDate monthIndex = date monthIndex;
				action: [ self dayClicked: date ].
			"Add icon next to current date."
			date julianDayNumber = Date today julianDayNumber
				ifTrue: [ button icon: (self iconNamed: #glamorousGrayCircle) ] ];
		layoutBuilder: (DynamicLeftToRightColumnsLayout columns: self daysInAWeek);
		yourself! !

!CalendarPresenter methodsFor: 'adapting' stamp: ''!
adaptToDate: aDate
	self monthYearLabel label: aDate month asString.
	self previousMonthButton
		action: [ self adaptToDate: aDate onPreviousMonth ].
	self nextMonthButton
		action: [ self adaptToDate: aDate onNextMonth ].
	self
		newDynamicPresentersListIn: #namesOfDaysLabels
		usingBuilder: self daysLabelsBuilder.
	self
		newDynamicPresentersListIn: #daysButtons
		usingBuilder: (self daysButtonsBuilderFrom: aDate)! !

!CalendarPresenter methodsFor: 'private' stamp: ''!
daysButtons: anObject
	daysButtons := anObject! !

!CalendarPresenter methodsFor: 'private' stamp: ''!
daysLabelsBuilder
	^ DynamicPresentersListBuilder new
		modelObjects: self dayNames;
		presenter: LabelPresenter
			configuredAs: [ :label :str | label label: str ];
		layoutBuilder: (DynamicLeftToRightColumnsLayout columns: self daysInAWeek);
		yourself! !

!CalendarPresenter class methodsFor: 'examples' stamp: ''!
exampleInspectClickedDateAndClose
	CalendarPresenter new
		adaptToDate: Date today;
		whenDaySelectedBlock: [ :aDate :calendarPresenter | aDate inspect. calendarPresenter window close ];
		openWithSpec! !

!CalendarPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpecLayout composed
		newColumn: [ :mainColumn |
			mainColumn
				newRow: [ :topRow |
					topRow
						newColumn: #previousMonthButton;
						newColumn: #monthYearLabel;
						newColumn: #nextMonthButton ] height: self buttonHeight;
				newRow: #namesOfDaysLabels height: self buttonHeight;
				newRow: [ :daysRow |
					daysRow
						newColumn: #daysButtons ] ]! !

!CalendarPresenter class methodsFor: 'examples' stamp: ''!
exampleInspectClickedDate
	CalendarPresenter new
		adaptToDate: Date today;
		whenDaySelectedBlock: [ :aDate | aDate inspect ];
		openWithSpec! !

!CalendarPresenter class methodsFor: 'examples' stamp: ''!
exampleSimple
	CalendarPresenter new
		adaptToDate: Date today;
		whenDaySelectedBlock: [ UIManager default inform: 'A date was clicked.' ];
		openWithSpec! !

!CannotDecompileNativeBoostCalls commentStamp: ''!
Notify that a method can not be decompiled because of a native boost call!
!CannotDeleteFileException commentStamp: ''!
Notfify when not able to delete!
!CannotIdentifyVersionForCommit commentStamp: ''!
This error is signaled when looking for a version in a commit (and its ancestry) has found two versions and can not decide which of them is the desired one. 

This should not happen if the repository is consistent.!
!CannotReturn commentStamp: ''!
Block and Context cases for CannotReturn need to signal a dedicated exception.
(see subclasses and the related testcases)!
!CannotReturn methodsFor: 'accessing' stamp: ''!
result: r

	result := r! !

!CannotReturn methodsFor: 'testing' stamp: ''!
isResumable

	^true! !

!CannotReturn methodsFor: 'accessing' stamp: ''!
result

	^result! !

!Canvas commentStamp: ''!
A canvas is a two-dimensional medium on which morphs are drawn in a device-independent manner. Canvases keep track of the origin and clipping rectangle, as well as the underlying drawing medium (such as a window, pixmap, or postscript script).

Subclasses must implement (at least) the following methods:
	* Drawing:
		#fillOval:color:borderWidth:borderColor:
		#frameAndFillRectangle:fillColor:borderWidth:borderColor:
		#drawPolygon:color:borderWidth:borderColor:
		#image:at:sourceRect:rule:
		#stencil:at:sourceRect:rule:
		#line:to:width:color:
		#paragraph:bounds:color:
		#text:bounds:font:color:
	* Support
		#clipBy:during:
		#translateBy:during:
		#translateBy:clippingTo:during:
		#transformBy:clippingTo:during:
!
!Canvas methodsFor: 'drawing - rectangles' stamp: ''!
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: ''!
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: ''!
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: 'testing' stamp: ''!
isShadowDrawing
	^false! !

!Canvas methodsFor: 'drawing - support' stamp: ''!
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 - general' stamp: ''!
fullDraw: anObject
	^anObject fullDrawOn: self! !

!Canvas methodsFor: 'drawing - images' stamp: ''!
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: ''!
warpImage: aForm transform: aTransform at: extraOffset
	"Warp the given form using aTransform.
	TODO: Use transform to figure out appropriate cell size"
	^self warpImage: aForm transform: aTransform at: extraOffset sourceRect: aForm boundingBox cellSize: 1! !

!Canvas methodsFor: 'drawing - general' stamp: ''!
draw: anObject
	^anObject drawOn: self! !

!Canvas methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubParagraph: paragraph bounds: bounds color: c
	"Draw the given paragraph"
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing' stamp: ''!
depth

	^ Display depth! !

!Canvas methodsFor: 'drawing - text' stamp: ''!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing' stamp: ''!
form

	^ Display! !

!Canvas methodsFor: 'drawing - general' stamp: ''!
roundShadowCornersOf: aMorph in: bounds during: aBlock
	^aBlock value! !

!Canvas methodsFor: 'other' stamp: ''!
translateBy:aPoint clippingTo:aRect during:aBlock
	^aBlock value:(self copyOffset:aPoint clipRect:aRect).! !

!Canvas methodsFor: 'accessing' stamp: ''!
shadowColor
	"Return the current override color or nil if no such color exists"
	^nil! !

!Canvas methodsFor: 'drawing - rectangles' stamp: ''!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	"Draw the rectangle using the given attributes"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing - ovals' stamp: ''!
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: 'private' stamp: ''!
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: 'drawing - general' stamp: ''!
roundShadowCornersOf: aMorph during: aBlock
	^self roundShadowCornersOf: aMorph in: aMorph bounds during: aBlock! !

!Canvas methodsFor: 'drawing - general' stamp: ''!
roundCornersOf: aMorph in: bounds during: aBlock
	^aBlock value! !

!Canvas methodsFor: 'drawing - rectangles' stamp: ''!
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 - text' stamp: ''!
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: 'drawing' stamp: ''!
line: pt1 to: pt2 color: c

	self line: pt1 to: pt2 width: 1 color: c.! !

!Canvas methodsFor: 'drawing - polygons' stamp: ''!
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: 'other' stamp: ''!
flushDisplay
	"Empty hook method."! !

!Canvas methodsFor: 'drawing' stamp: ''!
line: pt1 to: pt2 width: w color: c
	"Draw a line using the given width and color"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing - rectangles' stamp: ''!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle. Double-dispatched via the fill style."
	
	aFillStyle fillRectangle: aRectangle on: self! !

!Canvas methodsFor: 'drawing - rectangles' stamp: ''!
fillRectangle: r color: c
	"Fill the rectangle using the given color"
	^self 
		frameAndFillRectangle: r
		fillColor: c
		borderWidth: 0
		borderColor: Color transparent! !

!Canvas methodsFor: 'drawing - support' stamp: ''!
preserveStateDuring: aBlock
	"Preserve the full canvas state during the execution of aBlock"
	^aBlock value: self copy! !

!Canvas methodsFor: 'accessing' stamp: ''!
extent
	"Return the physical extent of the output device"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing - support' stamp: ''!
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: ''!
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 - text' stamp: ''!
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: ''!
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: 'initialization' stamp: ''!
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: 'drawing - images' stamp: ''!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing' stamp: ''!
contentsOfArea: aRectangle
	"Return the contents of the given area"
	^self contentsOfArea: aRectangle into: (Form extent: aRectangle extent depth: self depth)! !

!Canvas methodsFor: 'drawing - text' stamp: ''!
drawString: s at: pt

	^ self drawString: s from: 1 to: s size at: pt font: nil color: Color black! !

!Canvas methodsFor: '*Morphic-Base' stamp: ''!
asAlphaBlendingCanvas: alpha
	^(AlphaBlendingCanvas on: self) alpha: alpha! !

!Canvas methodsFor: 'drawing - rectangles' stamp: ''!
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 - images' stamp: ''!
warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize
	"Warp the given using the appropriate transform and offset."
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing - general' stamp: ''!
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 - support' stamp: ''!
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 - rectangles' stamp: ''!
frameRectangle: r color: c

	self frameRectangle: r width: 1 color: c.! !

!Canvas methodsFor: 'drawing - polygons' stamp: ''!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	"Draw the given polygon."
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing - ovals' stamp: ''!
frameOval: r width: w color: c

	self fillOval: r color: Color transparent borderWidth: w borderColor: c.! !

!Canvas methodsFor: 'drawing' stamp: ''!
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 distanceTo: 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 - text' stamp: ''!
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 - support' stamp: ''!
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: 'accessing' stamp: ''!
shadowColor: aColor
	"Set a shadow color. If set this color overrides any client-supplied color."! !

!Canvas methodsFor: 'drawing - ovals' stamp: ''!
frameOval: r color: c

	self fillOval: r color: Color transparent borderWidth: 1 borderColor: c.! !

!Canvas methodsFor: 'private' stamp: ''!
image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha
	"Privately used for blending forms w/ constant alpha. Fall back to simpler case by defaul."
	^self image: aForm at: aPoint sourceRect: sourceRect rule: rule! !

!Canvas methodsFor: 'accessing' stamp: ''!
origin
	"Return the current origin for drawing operations"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing - images' stamp: ''!
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: ''!
warpImage: aForm transform: aTransform
	"Warp the given form using aTransform"
	^self warpImage: aForm transform: aTransform at: 0@0! !

!Canvas methodsFor: 'drawing - text' stamp: ''!
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 - polygons' stamp: ''!
drawPolygon: vertices fillStyle: aFillStyle
	"Fill the given polygon."
	self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! !

!Canvas methodsFor: 'drawing' stamp: ''!
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 distanceTo: 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 distanceTo: 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 - images' stamp: ''!
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: 'converting' stamp: ''!
asShadowDrawingCanvas: aColor
	^(ShadowDrawingCanvas on: self) shadowColor: aColor! !

!Canvas methodsFor: 'initialization' stamp: ''!
flush! !

!Canvas methodsFor: 'testing' stamp: ''!
doesRoundedCorners 

	^ true! !

!Canvas methodsFor: 'converting' stamp: ''!
asShadowDrawingCanvas
	^self asShadowDrawingCanvas: (Color black alpha: 0.5).! !

!Canvas methodsFor: 'drawing - general' stamp: ''!
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 - rectangles' stamp: ''!
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 - images' stamp: ''!
drawImage: aForm at: aPoint sourceRect: sourceRect
	"Draw the given form."

	^self image: aForm
		at: aPoint
		sourceRect: sourceRect
		rule: Form over! !

!Canvas methodsFor: 'testing' stamp: ''!
isVisible: aRectangle
	"Return true if the given rectangle is (partially) visible"
	^self clipRect intersects: aRectangle! !

!Canvas methodsFor: 'drawing' stamp: ''!
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 distanceTo: 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 - general' stamp: ''!
roundCornersOf: aMorph during: aBlock
	^self roundCornersOf: aMorph in: aMorph bounds during: aBlock! !

!Canvas methodsFor: 'accessing' stamp: ''!
contentsOfArea: aRectangle into: aForm
	"Return the contents of the given area"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing - ovals' stamp: ''!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	"Fill the given oval."
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing' stamp: ''!
clipRect
	"Return the currently active clipping rectangle"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing' stamp: ''!
render: anObject
	"Do some 3D operations with the object if possible"! !

!Canvas methodsFor: '*Morphic-Base' stamp: ''!
copyClipRect: newClipRect

	^ ClippingCanvas canvas: self clipRect: newClipRect! !

!Canvas methodsFor: 'drawing - text' stamp: ''!
drawString: s in: boundsRect
	^self drawString: s from: 1 to: s size in: boundsRect font: nil color: Color black! !

!Canvas methodsFor: 'drawing - images' stamp: ''!
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 - support' stamp: ''!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing' stamp: ''!
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 - ovals' stamp: ''!
fillOval: aRectangle fillStyle: aFillStyle
	"Fill the given oval."
	^self fillOval: aRectangle fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! !

!Canvas methodsFor: 'testing' stamp: ''!
seesNothingOutside: aRectangle
	"Return true if this canvas will not touch anything outside aRectangle"
	^ aRectangle containsRect: self clipRect! !

!Canvas methodsFor: 'drawing - text' stamp: ''!
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' stamp: ''!
paragraph: paragraph bounds: bounds color: c
	"Draw the given paragraph"
	^self subclassResponsibility! !

!Canvas methodsFor: 'testing' stamp: ''!
isBalloonCanvas
	^false! !

!Canvas methodsFor: 'drawing - images' stamp: ''!
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: ''!
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 - ovals' stamp: ''!
fillOval: r color: c

	self fillOval: r color: c borderWidth: 0 borderColor: Color transparent.! !

!Categorizer commentStamp: ''!
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:          <SequenceableCollection of: Object>
      categoryStops:          <SequenceableCollection of: Integer>
      elementArray:           <SequenceableCollection of: Object>

categoryArray
       - holds the list of categories.
       A category could be any Object but is generally a String or Symbol.
       Categories should be unique (categoryArray asSet size = categoryArray size)

categoryStops
       - holds the index of last element belonging to each category.
       There should be a category stop for each category (categoryStops size = categoryArray size).
       The categoryStops should be sorted (categoryStops sorted = categoryStops).
       A category stop equal to its predecessor (= 0 for the first category stop) denotes an empty category.

elementArray
      - holds the elements to be classified. The elements are sorted by category.

Class variables
       Default is the default category used to classify yet unclassified methods of a class
       NullCategory is the category to be displayed in a Browser for a class having no method.!
!Categorizer methodsFor: 'accessing' stamp: ''!
allMethodSelectors
	"give a list of all method selectors."

	^ elementArray sorted! !

!Categorizer methodsFor: 'private' stamp: ''!
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: 'queries' stamp: ''!
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: 'operations' stamp: ''!
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 isEmpty
		ifTrue:
			[categoryArray := Array with: Default.
			categoryStops := Array with: 0]

	"ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! !

!Categorizer methodsFor: 'operations' stamp: ''!
classifyAll: aCollection under: heading

	aCollection do:
		[:element | self classify: element under: heading]! !

!Categorizer methodsFor: 'operations' stamp: ''!
removeElement: element 
	^ self basicRemoveElement: element! !

!Categorizer methodsFor: 'private' stamp: ''!
firstIndexOfCategoryNumber: anInteger
	anInteger < 1 ifTrue: [^ nil].
	^ (anInteger > 1
			ifTrue: [(categoryStops at: anInteger - 1) + 1]
			ifFalse: [1]).! !

!Categorizer methodsFor: 'private' stamp: ''!
lastIndexOfCategoryNumber: anInteger
	anInteger > categoryStops size ifTrue: [^ nil].
	^ categoryStops at: anInteger! !

!Categorizer methodsFor: 'operations' stamp: ''!
classify: element under: heading 
	self classify: element under: heading suppressIfDefault: true! !

!Categorizer methodsFor: 'private' stamp: ''!
setDefaultList: aSortedCollection

	categoryArray := Array with: Default.
	categoryStops := Array with: aSortedCollection size.
	elementArray := aSortedCollection asArray! !

!Categorizer methodsFor: 'operations' stamp: ''!
changeFromCategorySpecs: categorySpecs
	"Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment."

	| newCategories newStops temp cc currentStop oldElements newElements |
	oldElements := elementArray asSet.
	newCategories := Array new: categorySpecs size.
	newStops := Array new: categorySpecs size.
	currentStop := 0.
	newElements := (Array new: 16) writeStream.
	1 to: categorySpecs size do: [ :i | 
		| selectors catSpec |
		catSpec := categorySpecs at: i.
		newCategories at: i put: catSpec first asSymbol.
		selectors := catSpec allButFirst
			collect: [ :each | 
				each isSymbol
					ifTrue: [ each ]
					ifFalse: [ each printString asSymbol ] ].
		selectors asSortedCollection
			do: [ :elem | 
				(oldElements remove: elem ifAbsent: [ nil ]) notNil
					ifTrue: [ 
						newElements nextPut: elem.
						currentStop := currentStop + 1 ] ].
		newStops at: i put: currentStop ].	"Ignore extra elements but don't lose any existing elements!!"
	oldElements := oldElements collect: [ :elem | Array with: (self categoryOfElement: elem) with: elem ].
	newElements := newElements contents.
	categoryArray := newCategories.
	(cc := categoryArray asSet) size = categoryArray size
		ifFalse: [ 
			"has duplicate element"
			temp := categoryArray asOrderedCollection.
			temp removeAll: categoryArray asSet.
			temp
				do: [ :dup | 
					| tmp ii |
					tmp := dup.
					ii := categoryArray indexOf: tmp.
					[ 
					tmp := (tmp , ' #2') asSymbol.
					cc includes: tmp ] whileTrue.
					cc add: tmp.
					categoryArray at: ii put: tmp ] ].
	categoryStops := newStops.
	elementArray := newElements.
	oldElements do: [ :pair | self classify: pair last under: pair first ]! !

!Categorizer methodsFor: '*CodeExport' stamp: ''!
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: ''!
assertInvariant
	[elementArray size = categoryStops last] assert! !

!Categorizer methodsFor: 'operations' stamp: ''!
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 isEmpty
		ifTrue:
			[categoryArray := Array with: Default.
			categoryStops := Array with: 0]! !

!Categorizer methodsFor: 'testing' stamp: ''!
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: ''!
categories
	"Answer an Array of categories (names)."
	categoryArray ifNil: [^ nil].
	(categoryArray size = 1 
		and: [categoryArray first = Default & (elementArray isEmpty)])
		ifTrue: [^Array with: NullCategory].
	^categoryArray! !

!Categorizer methodsFor: 'operations' stamp: ''!
sortCategories
	| privateCategories publicCategories newCategories |
	privateCategories := self categories
		select: [ :one | (one findString: 'private' startingAt: 1 caseSensitive: false) = 1 ].
	publicCategories := self categories copyWithoutAll: privateCategories.
	newCategories := publicCategories asSortedCollection asOrderedCollection
		addAll: privateCategories;
		asArray.
	self categories: newCategories! !

!Categorizer methodsFor: '*CodeImport' stamp: ''!
changeFromString: aString 
	"Parse the argument, aString, and make this be the receiver's structure."

	| categorySpecs |
	categorySpecs := aString parseLiterals.
	"If nothing was scanned and I had no elements before, then default me"
	(categorySpecs isEmpty and: [elementArray isEmpty])
		ifTrue: [^ self setDefaultList: Array new].

	^ self changeFromCategorySpecs: categorySpecs! !

!Categorizer methodsFor: 'private' stamp: ''!
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: 'operations' stamp: ''!
addCategory: newCategory
	^ self addCategory: newCategory before: nil! !

!Categorizer methodsFor: 'private' stamp: ''!
numberOfCategoryOfElement: element
	"Answer the index of the category with which the argument, element, is 
	associated."

	| indexOfElementInElementArray |
	indexOfElementInElementArray := elementArray
		                                identityIndexOf: element asSymbol
		                                ifAbsent: [ ^ 0 ].
	^ categoryStops findFirst: [ :stopIndex | 
		  stopIndex >= indexOfElementInElementArray ]! !

!Categorizer methodsFor: 'testing' stamp: ''!
isEmptyCategoryNamed: categoryName
	| i |
	i := categoryArray indexOf: categoryName ifAbsent: [^false].
	^self isEmptyCategoryNumber: i! !

!Categorizer methodsFor: 'operations' stamp: ''!
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: 'operations' stamp: ''!
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: 'operations' stamp: ''!
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: 'queries' stamp: ''!
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: 'private' stamp: ''!
elementCategoryDict
	| dict firstIndex lastIndex |
	elementArray ifNil: [^ nil].
	dict := Dictionary new: elementArray size.
	1to: categoryStops size do: [:cat |
		firstIndex := self firstIndexOfCategoryNumber: cat.
		lastIndex := self lastIndexOfCategoryNumber: cat.
		firstIndex to: lastIndex do: [:el |
			dict at: (elementArray at: el) put: (categoryArray at: cat)].
	].
	^ dict.! !

!Categorizer methodsFor: 'accessing' stamp: ''!
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: 'queries - protocol' stamp: ''!
listAtProtocolNamed: categoryName
	"when the receiver is used to sort methods, it is nicer to use the right vocabulary."
	^ self listAtCategoryNamed: categoryName! !

!Categorizer methodsFor: 'queries - protocol' stamp: ''!
protocolOfElement: element
	"when the receiver is used to sort methods, it is nicer to use the right vocabulary."
	
	^ self categoryOfElement: element! !

!Categorizer class methodsFor: 'class initialization' stamp: ''!
allCategory
	"Return a symbol that represents the virtual all methods category."

	^#'-- all --'! !

!Categorizer class methodsFor: 'class initialization' stamp: ''!
initialize
		
	Default := Protocol unclassified.
	NullCategory := 'no messages' asSymbol.! !

!Categorizer class methodsFor: 'instance creation' stamp: ''!
defaultList: aSortedCollection 
	"Answer an instance of me with initial elements from the argument, 
	aSortedCollection."

	^self new setDefaultList: aSortedCollection! !

!Categorizer class methodsFor: 'class initialization' stamp: ''!
default 
	^ Default! !

!Categorizer class methodsFor: 'documentation' stamp: ''!
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: ''!
sortAllCategories

	self allSubInstances
		do: [:x | x sortCategories]! !

!Categorizer class methodsFor: 'class initialization' stamp: ''!
nullCategory
	^ NullCategory! !

!CategoryAdded commentStamp: ''!
This announcement will be emitted when adding a category using:
=> SystemOrganizer >> addCategory:!
!CategoryAdded methodsFor: 'accessing' stamp: ''!
categoryName: aCategoryName
	categoryName := aCategoryName! !

!CategoryAdded methodsFor: 'accessing' stamp: ''!
categoryName

	^ categoryName! !

!CategoryAdded class methodsFor: 'instance creation' stamp: ''!
categoryName: aCategoryName
	^self new
			categoryName: aCategoryName;
			yourself! !

!CategoryRemoved commentStamp: ''!
This announcement will be emitted when removing a category using:
=> SystemOrganizer >> removeCategory:!
!CategoryRemoved methodsFor: 'accessing' stamp: ''!
categoryName: aCategoryName
	categoryName := aCategoryName! !

!CategoryRemoved methodsFor: 'accessing' stamp: ''!
categoryName
	^categoryName! !

!CategoryRemoved class methodsFor: 'instance creation' stamp: ''!
categoryName: aCategoryName
	^self new
			categoryName: aCategoryName;
			yourself! !

!CategoryRenamed commentStamp: ''!
This announcement will be emitted when renaming a category using:
=> SystemOrganizer >> renameCategory:toBe:!
!CategoryRenamed methodsFor: 'accessing' stamp: ''!
newCategoryName
	^newCategoryName! !

!CategoryRenamed methodsFor: 'accessing' stamp: ''!
oldCategoryName: aCategoryName
	oldCategoryName := aCategoryName! !

!CategoryRenamed methodsFor: 'accessing' stamp: ''!
newCategoryName: aCategoryName
	newCategoryName := aCategoryName! !

!CategoryRenamed methodsFor: 'accessing' stamp: ''!
oldCategoryName
	^oldCategoryName! !

!CategoryRenamed class methodsFor: 'instance creation' stamp: ''!
classCategoryRenamedFrom: anOldCategoryName to: aNewCategoryName
	^self new
			newCategoryName: aNewCategoryName;
			oldCategoryName: anOldCategoryName;
			yourself! !

!ChainedSortFunction commentStamp: ''!
I add to my parent the idea of a "next" function to use when two objects are equal by my primary sort function.

Usage

SortFunctions can be chained together in primary, secondary, tertiary, etc order using the comma method. Consider a sequence of customer objects, where each customer object responds to the messages firstName, lastName, and age. If we want to sort them lastName first, then firstName, and finally oldest first, we would use an expression like:

customers sort: #lastName ascending, #firstName ascending, #age descending

As noted in my super's comment, unary symbols or single arg blocks can be used. One can omit the the ascending methods on arguments (not the receiver), it will default blocks or symbols to be ascending if none is specified. In other words, the above expression could be simplified slightly as

customers sort: #lastName ascending, #firstName, #age descending

(note the missing ascending on the #firstName argument)

Instance Variables
	baseSortFunction	<SortFunction> the primary SortFunction to collate given objects
	next	Function	<SortFunction>	the next SortFunction to evaluate in the event primary collation results are equal values!
!ChainedSortFunction methodsFor: 'accessing' stamp: ''!
nextFunction
	^ nextFunction! !

!ChainedSortFunction methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ baseSortFunction = anObject baseSortFunction
			and: [ nextFunction = anObject nextFunction ]! !

!ChainedSortFunction methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash + nextFunction hash! !

!ChainedSortFunction methodsFor: 'accessing' stamp: ''!
nextFunction: anObject
	nextFunction := anObject! !

!ChainedSortFunction methodsFor: 'evaluating' stamp: ''!
collate: anObject1 with: anObject2
	"If the result of current function is 0, then pass on to the next function to work it out"

	| result |
	result := baseSortFunction collate: anObject1 with: anObject2.
	^result isZero
		ifTrue: [nextFunction collate: anObject1 with: anObject2.]
		ifFalse: [result]! !

!ChainedSortFunction methodsFor: 'converting' stamp: ''!
, aSortFunction

	^self class startWith: baseSortFunction then: nextFunction , aSortFunction! !

!ChainedSortFunction class methodsFor: 'instance creation' stamp: ''!
startWith: aSortFunction then: nextSortFunction
	^self new
		baseSortFunction: aSortFunction;
		nextFunction: nextSortFunction! !

!ChainedSortFunctionTest commentStamp: ''!
Unit test for chained sort functions!
!ChainedSortFunctionTest methodsFor: 'tests' stamp: ''!
testComparisonOfFunctions

	self assert: #name ascending, #surname equals: #name ascending, #surname.
	self assert: (#name ascending, #surname) hash equals: (#name ascending, #surname) hash.

	self deny: #name ascending, #surname equals: #name ascending, #surname2.
	self deny: #name ascending, #surname equals: #name descending, #surname.
	self deny: #name ascending, #surname ascending equals: #name ascending, #surname descending.! !

!ChainedSortFunctionTest methodsFor: 'tests' stamp: ''!
testEvaluation

	| function |
	function := #first ascending , [:a | a at: 2] descending , #last ascending.
	"first different"
	self assert: (function value: #(1 2 3) value: #(2 2 3)).
	self deny: (function value: #(3 2 3) value: #(2 2 3)).
	"first the same"
	self assert: (function value: #(1 2 3) value: #(1 1 3)).
	self assert: (function value: #(1 2 2) value: #(1 1 3)).
	self assert: (function value: #(1 2 3) value: #(1 1 2)).
	self deny: (function value: #(1 2 3) value: #(1 3 3)).
	self deny: (function value: #(1 2 2) value: #(1 3 3)).
	self deny: (function value: #(1 2 3) value: #(1 3 2)).
	"first and second the same"
	self assert: (function value: #(1 2 3) value: #(1 2 3)).
	self assert: (function value: #(1 2 2) value: #(1 2 3)).
	self deny: (function value: #(1 2 4) value: #(1 2 3))! !

!ChangeRecord commentStamp: ''!
A ChangeRecord represents a change recorded on a file in fileOut format.
It includes a type (more needs to be done here), and additional information
for certain types such as method defs which need class and category.!
!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
stamp
	^ stamp! !

!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
position
	^ position! !

!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
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: 'testing' stamp: 'nil'!
isUnchangedMethod

	^ self isMethodDefinedInImage 
		and: [self string withBlanksCondensed 
				= (self methodClass sourceCodeAt: self methodSelector) asString withBlanksCondensed ]! !

!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
timeStamp
	"Answer a TimeStamp that corresponds to my (text) stamp"

	| tokens |
	tokens := self stamp findTokens: Character separators.
	^ tokens size > 2
		ifTrue: [ 
			[ 
			| time date |
			date := Date fromString: (tokens at: tokens size - 1).
			time := Time fromString: tokens last.
			DateAndTime date: date time: time ]
				on: Error
				do: [ :ex | ex return: DateAndTime new ] ]
		ifFalse: [ DateAndTime new ]! !

!ChangeRecord methodsFor: 'testing' stamp: 'nil'!
classIncludesSelector
	
	| aClass | 
	^ (aClass := self methodClass) notNil
			and: [aClass includesSelector: self methodSelector]! !

!ChangeRecord methodsFor: 'testing' stamp: 'nil'!
isMethodDefinedInImage
	"answer whether the method represented by the receiver is present in the image"
	
	^ self type = #method
		and: [self classIncludesSelector]! !

!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
methodSelector
	^ type == #method
		ifTrue: [ (Smalltalk globals at: class ifAbsent: [ Object ]) compiler parseSelector: self string ]! !

!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
fileName
	^file ifNotNil: [ file name ] ifNil: [ '<no file>' ]! !

!ChangeRecord methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
createCommentDefinition
	"Retrieves a RGCommentDefinition object based on the data of the receiver"

	^ (RGCommentDefinition class: self commentClass)
		content: self string;
		stamp: stamp;
		yourself ! !

!ChangeRecord methodsFor: 'printing' stamp: 'nil'!
printOn: aStream

	self type printOn: aStream.
	self stamp ifNotNil: [ :s | s printOn: aStream ].
	! !

!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
string 
	| copy |
	copy := file readOnlyCopy.
	copy position: position.
	[ ^ (ChunkReadStream on: copy) next ]
		ensure: [ copy close ]! !

!ChangeRecord methodsFor: 'initialization' stamp: 'nil'!
file: f position: p type: t
	file := f.
	position := p.
	type := t! !

!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
type
	^ type! !

!ChangeRecord methodsFor: '*Monticello' stamp: 'nil'!
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: 'initialization' stamp: 'nil'!
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."

	UIManager default
		showWaitCursorWhile:			
			[ 
			| methodClass s |
			(methodClass := self methodClass) notNil
				ifTrue:
					[ 
					methodClass
						compile: self text
						classified: category
						withStamp: stamp
						notifying: nil ].
			type == #doIt
				ifTrue:
					[ 
					((s := self string) beginsWith: '----')
						ifFalse: [ self class compiler evaluate: s ] ].
			type == #classComment
				ifTrue:
					[ (Smalltalk globals at: class asSymbol) comment: self text stamp: stamp ] ]! !

!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
isMetaClassChange
	^meta! !

!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
stamp: threePartString

	stamp := threePartString! !

!ChangeRecord methodsFor: 'accessing' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
category
	^category! !

!ChangeRecord methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
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: 'testing' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
methodClassName
	^ meta
		ifTrue: [ class , ' class' ]
		ifFalse: [ class ]! !

!ChangeRecord methodsFor: 'initialization' stamp: 'nil'!
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: '*Ring-Definitions-Core' stamp: 'nil'!
createMethodDefinition
	"Retrieves a RGMethodDefinition object based on the data of the receiver"
	
	^(RGMethodDefinition named: self methodSelector)
		parentName: self methodClassName;
		isMetaSide: meta;  
		sourceCode: self string;
		protocol: category;
		stamp: stamp;
		yourself! !

!ChangeRecord methodsFor: 'testing' stamp: 'nil'!
<= anotherOne

	self stamp ifNil: [ ^ false ].
	anotherOne stamp ifNil: [ ^ true ].
	^ self timeStamp <= anotherOne timeStamp ! !

!ChangeRecord methodsFor: '*Text-Core' stamp: ''!
text
	| text |
	^ file ifNil: ['']
		ifNotNil: [
			file tryOpenReadOnly: true.
			file position: position.
			text := file nextChunk asText.
			file close.
			text]! !

!ChangeSet commentStamp: ''!
ChangeSets keep track of the changes made to a system, so they can be written on a file as source code (a "fileOut"). 

---
preamble and postscript:  two strings that serve as prefix (useful for documentation) and suffix (useful for doits) to the fileout of the changeSet.


changeRecords -  Dictionary {class name -> a ClassChangeRecord}.
These classChangeRecords (qv) remember all of the system changes.!
!ChangeSet methodsFor: 'moving changes' stamp: 'nil'!
editPreamble
	"Edit the receiver's preamble, in a separate window."
	
	self assurePreambleExists.
	UIManager default
		edit: self preamble 
		label: 'Preamble for ChangeSet named ', name
		accept:[:aString| self preamble: aString]! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
classModified: anEvent

	self
		changeClass: anEvent newClassDefinition
		from: anEvent oldClassDefinition! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
fileOutPreambleOn: stream
	"If the receiver has a preamble, put it out onto the stream.  "

	| aString |
	aString := self preambleString.
	(aString notNil and: [ aString notEmpty ])
		ifFalse: [ ^ self ].
	stream nextChunkPut: aString.	"surroundedBySingleQuotes"
	stream
		cr;
		cr! !

!ChangeSet methodsFor: 'accessing' stamp: 'nil'!
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: 'nil'!
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: 'change logging' stamp: 'nil'!
methodAdded: anEvent

	self
		noteNewMethod: anEvent method
		forClass: anEvent methodClass
		selector: anEvent selector
		priorMethod: nil! !

!ChangeSet methodsFor: 'method changes' stamp: 'nil'!
methodChangesAtClass: className
	"Return an old-style dictionary of method change types."

	^ (changeRecords at: className ifAbsent: [ ^ Dictionary new ])
		  methodChangeTypes! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
doItChunkImported: anAnnouncemnet

	self class current = self ifFalse: [ ^ self ].
	
	"Parse preamble and postcript as a do it."
	
	((anAnnouncemnet contents beginsWith: '"Change Set:') and: [ self preambleString isNil ])
		ifTrue: [ self preambleString: anAnnouncemnet contents ].
	((anAnnouncemnet contents beginsWith: '"Postscript:') and: [ self postscriptString isNil ])
		ifTrue: [ self postscriptString: anAnnouncemnet contents ]
! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
preambleString: aString
	"Establish aString as the new contents of the preamble."
	
	self preamble: aString! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
fileOut
	"File out the receiver, to a file whose name is a function of the  
	change-set name and a unique numeric tag."

	| fileReference dir |
	dir := self class promptForDefaultChangeSetDirectoryIfNecessary.
	fileReference := ( dir / self name , 'cs') nextVersion.
	self fileOutBody: fileReference! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
classCommented: anEvent

	self commentClass: anEvent classCommented! !

!ChangeSet methodsFor: 'testing' stamp: 'nil'!
isNumbered
	"Answer whether a change set is numbered"

	^  self name startsWithDigit! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
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:
						[(self hasReportableSlip: method)
							ifTrue: [ slips add: (aClass >> mAssoc key) ]]]]].
	^ slips! !

!ChangeSet methodsFor: 'class changes' stamp: 'nil'!
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: 'method changes' stamp: 'nil'!
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: 'file in/out' stamp: 'nil'!
postscriptString: aString
	"Establish aString as the new contents of the postscript."
	
	self postscript: aString! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
classRecategorized: anEvent

	self
		changeClass: anEvent classRecategorized
		from: anEvent classRecategorized! !

!ChangeSet methodsFor: 'accessing' stamp: 'nil'!
hasPostscript

	^ postscript notNil! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
postscript: aString
	"Answer the string representing the postscript."
	
	postscript := aString! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nil'!
expungeEmptyClassChangeEntries

	changeRecords keysAndValuesRemove: [ :className :classRecord | 
		classRecord hasNoChanges ]! !

!ChangeSet methodsFor: 'initialization' stamp: 'nil'!
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: 'moving changes' stamp: 'nil'!
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: 'private' stamp: 'nil'!
oldNameFor: class

	^ (changeRecords at: class name) priorName! !

!ChangeSet methodsFor: 'accessing' stamp: 'nil'!
classRemoves

	^ changeRecords keys select: [ :className | 
		  (changeRecords at: className) isClassRemoval ]! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
methodRecategorized: anEvent

	self reorganizeClass: anEvent methodClass! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
postscriptString
	"Answer the string representing the postscript."
	
	^ self postscript! !

!ChangeSet methodsFor: 'initialization' stamp: 'nil'!
wither
	"The receiver is to be clobbered. Clear it out."

	self clear.
	name := nil! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nil'!
hasPreamble

	^ preamble notNil! !

!ChangeSet methodsFor: 'testing' stamp: 'nil'!
okayToRemove

	^ self okayToRemoveInforming: true! !

!ChangeSet methodsFor: 'private' stamp: 'nil'!
changeRecorderFor: class

	| cname |
	cname := class isString
		ifTrue: [ class ]
		ifFalse: [ class isBehavior ifTrue: [class name] ifFalse: [ nil printString] ].
	^ changeRecords at: cname ifAbsent: [ ^ changeRecords at: cname put: (ClassChangeRecord new initFor: cname) ]! !

!ChangeSet methodsFor: 'private' stamp: 'nil'!
atSelector: selector class: class

	^ (changeRecords at: class name ifAbsent: [ ^ #none ])
		  atSelector: selector
		  ifAbsent: [ ^ #none ]! !

!ChangeSet methodsFor: 'testing' stamp: 'nil'!
methodsWithoutClassifications
	"Return a collection representing methods in the receiver which have not been categorized"

	| slips notClassified |

	notClassified := {	Protocol unclassified. #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! !

!ChangeSet methodsFor: 'class changes' stamp: 'nil'!
reorganizeClass: class 
	"Include indication that a class was reorganized."

	self atClass: class add: #reorganize! !

!ChangeSet methodsFor: 'initialization' stamp: 'nil'!
clear

	"Reset the receiver to be empty."

	changeRecords := Dictionary new.
	preamble := nil.
	postscript := nil! !

!ChangeSet methodsFor: 'accessing' stamp: 'nil'!
removePostscript

	postscript := nil! !

!ChangeSet methodsFor: 'method changes' stamp: 'nil'!
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: 'class changes' stamp: 'nil'!
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: 'nil'!
changedClassNames
	"Answer a OrderedCollection of the names of changed or edited classes.
	Does include removed classes.  Sort alphabetically."

	^ changeRecords keysSortedSafely ! !

!ChangeSet methodsFor: 'testing' stamp: 'nil'!
isEmpty
	"Answer whether the receiver contains any elements."
	
	^ changeRecords isEmptyOrNil ! !

!ChangeSet methodsFor: 'method changes' stamp: 'nil'!
atSelector: selector class: class put: changeType

	(self changeRecorderFor: class) atSelector: selector put: changeType! !

!ChangeSet methodsFor: 'class changes' stamp: 'nil'!
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: 'class changes' stamp: 'nil'!
containsClass: aClass

	^ self changedClasses includes: aClass! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
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: 'moving changes' stamp: 'nil'!
forgetChangesForClass: className in: otherChangeSet
	"See forgetAllChangesFoundIn:.  Used in culling changeSets."

	(self changeRecorderFor: className) forgetChangesIn:
		(otherChangeSet changeRecorderFor: className)! !

!ChangeSet methodsFor: 'private' stamp: 'nil'!
atClass: class includes: changeType

	^ (changeRecords at: class name ifAbsent: [ ^ false ]) 
		  includesChangeType: changeType! !

!ChangeSet methodsFor: 'private' stamp: 'nil'!
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: 'method changes' stamp: 'nil'!
hasAnyChangeForSelector: aSelector
	"Answer whether the receiver has any change under the given selector, whether it be add, change, or remove, for any class"

	^ changeRecords anySatisfy: [ :aRecord | aRecord changedSelectors includes: aSelector ]! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nil'!
removeClassAndMetaClassChanges: class
	"Remove all memory of changes associated with this class and its metaclass."

	changeRecords 
		removeKey: class name ifAbsent: [];
		removeKey: class class name ifAbsent: []
! !

!ChangeSet methodsFor: 'printing' stamp: 'nil'!
printOn: aStream

	super printOn: aStream.
	aStream
		nextPutAll: ' named ';
		nextPutAll: self name! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
hasReportableSlip: aMethod
	"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."

	aMethod containsHalt ifTrue: [ ^ true ].
	(aMethod sendsSelector: #flag:) ifTrue: [ ^ true ].
	^ aMethod readsRef: (Smalltalk globals associationAt: #Transcript)! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nil'!
absorbClass: className from: otherChangeSet
	"Absorb into the receiver all the changes found in the class in the other change set.
	*** Classes renamed in otherChangeSet may have problems"

	(self changeRecorderFor: className) assimilateAllChangesIn:
		(otherChangeSet changeRecorderFor: className)! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
assurePostscriptExists
	"Make sure there is a StringHolder holding the postscript.  "

	"NOTE: FileIn recognizes the postscript by the line with Postscript: on it"

	postscript ifNil: [ 
			postscript := '"Postscript:
Leave the line above, and replace the rest of this comment by a useful one.
Executable statements should follow this comment, and should
be separated by periods, with no exclamation points (!!).
Be sure to put any further comments in double-quotes, like this one."
' ]! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
defaultChangeSetDirectory

	^ self class defaultChangeSetDirectory! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
classAdded: anEvent

	self addClass: anEvent classAdded! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
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
		ifTrue: [ ^ self ].
	class fileOutChangedMessages: changes on: stream.
	stream cr! !

!ChangeSet methodsFor: 'class changes' stamp: 'nil'!
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: 'private' stamp: 'nil'!
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: class definitionString;
				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)
		ifFalse: [ ^ self ].
	class instanceSide organization
		putCommentOnFile: stream
		forClass: class instanceSide.
	stream cr! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
classRemoved: anEvent

	self noteRemovalOf: anEvent classRemoved! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nil'!
forgetAllChangesFoundIn: otherChangeSet
	"Remove from the receiver all method changes found in aChangeSet. The intention is facilitate the process of factoring a large set of changes into disjoint change sets.  To use:  in a change sorter, copy over all the changes you want into some new change set, then use the subtract-other-side feature to subtract those changes from the larger change set, and continue in this manner."

	otherChangeSet == self ifTrue: [^ self].
	otherChangeSet changedClassNames do:
		[:className | self forgetChangesForClass: className in: otherChangeSet].
	self expungeEmptyClassChangeEntries.
! !

!ChangeSet methodsFor: 'accessing' stamp: 'nil'!
name: anObject

	name := anObject! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
postscript
	"Answer the string representing the postscript.  "

	^ postscript ifNotNil: [ 
		  postscript isString
			  ifTrue: [ postscript ]
			  ifFalse: [ postscript contents asString ] ]! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
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."
	<script: 'ChangeSet current preambleTemplate inspect'>
	
	^ 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: '<your descriptive text goes here>"']! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
classRenamed: anEvent

	self
		renameClass: anEvent classRenamed
		from: anEvent oldName
		to: anEvent newName! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nil'!
removePreamble

	preamble := nil! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
renameClass: class from: oldName to: newName 
	"Include indication that a class has been renamed."

	| recorder oldMetaClassName newMetaClassName |
	(recorder := self changeRecorderFor: oldName)
		noteChangeType: #rename;
		noteNewName: newName asSymbol.
		
	"store under new name (metaclass too)"
	changeRecords at: newName put: recorder.
	changeRecords removeKey: oldName.

	newMetaClassName := newName, ' class'.
	oldMetaClassName := oldName, ' class'.
	recorder := changeRecords at: oldMetaClassName ifAbsent: [^ nil].
	changeRecords at: newMetaClassName put: recorder.
	changeRecords removeKey: oldMetaClassName.
	recorder noteNewName: newMetaClassName! !

!ChangeSet methodsFor: 'class changes' stamp: 'nil'!
classChangeAt: className
	"Return what we know about class changes to this class."

	^ (changeRecords at: className ifAbsent: [ ^ Set new ])
		  allChangeTypes! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nil'!
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: 'private' stamp: 'nil'!
atClass: class add: changeType

	(self changeRecorderFor: class)
		noteChangeType: changeType fromClass: class! !

!ChangeSet methodsFor: 'method changes' stamp: 'nil'!
selectorsInClass: aClassName
	"Used by a ChangeSorter to access the list methods."

	^ (changeRecords at: aClassName ifAbsent: [ ^ #() ])
		  changedSelectors! !

!ChangeSet methodsFor: 'accessing' stamp: 'nil'!
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: 'initialization' stamp: 'nil'!
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: 'file in/out' stamp: 'nil'!
fileOutPostscriptOn: stream
	"If the receiver has a postscript, put it out onto the stream.  "

	| aString |
	aString := self postscriptString.
	(aString notNil and: [ aString notEmpty ])
		ifFalse: [ ^ self ].
	stream nextChunkPut: aString.	"surroundedBySingleQuotes"
	stream
		cr;
		cr! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
fileOutBody: fileReference

	UIManager default
		showWaitCursorWhile:			
			[ 
			| internalStream |
			internalStream := (String new: 10000) writeStream.
			internalStream
				header;
				timeStamp.
			self fileOutPreambleOn: internalStream.
			self fileOutOn: internalStream.
			self fileOutPostscriptOn: internalStream.

			CodeExporter 
				writeSourceCodeFrom: internalStream
				toFileReference: fileReference ]! !

!ChangeSet methodsFor: 'testing' stamp: 'nil'!
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: 'file in/out' stamp: 'nil'!
preamble
	"Answer the string representing the preamble"

	^ preamble ifNotNil: [ 
		  preamble isString
			  ifTrue: [ preamble ]
			  ifFalse: [ preamble contents asString ] ]! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
preambleString
	"Answer the string representing the preamble"

	^self preamble! !

!ChangeSet methodsFor: 'method changes' stamp: 'nil'!
adoptSelector: aSelector forClass: aClass
	"Adopt the given selector/class combination as a change in the receiver"

	self noteNewMethod: (aClass compiledMethodAt: aSelector)
			forClass: aClass selector: aSelector priorMethod: nil! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
preamble: aString
	"Establish aString as the new contents of the preamble.  "

	preamble := aString! !

!ChangeSet methodsFor: 'file in/out' stamp: 'nil'!
fileOutOn: stream 
	"Write out all the changes the receiver knows about"

	| classList traits classes traitList list |
	self isEmpty ifTrue: [self inform: 'Warning: no changes to file out'].

	traits := self changedClasses select: [:each | each isTrait].
	classes := self changedClasses select: [:each | each isBehavior & each isTrait not].
	traitList := self class traitsOrder: traits asOrderedCollection.
	classList := self class classesOrder: classes asOrderedCollection.
	list := OrderedCollection new
		addAll: traitList;
		addAll: classList;
		yourself.
	
	"First put out rename, max classDef and comment changes."
	list do: [:aClass | self fileOutClassDefinition: aClass on: stream].

	"Then put out all the method changes"
	list do: [:aClass | self fileOutChangesFor: aClass on: stream].

	"Finally put out removals, final class defs and reorganization if any"
	list reverseDo: [:aClass | self fileOutPSFor: aClass on: stream].

	self classRemoves asSortedCollection do:
		[:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr]! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
methodModified: anEvent

	self
		noteNewMethod: anEvent newMethod
		forClass: anEvent methodClass
		selector: anEvent selector
		priorMethod: anEvent oldMethod! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nil'!
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>>mAssoc key) hasComment
								ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
	^ slips! !

!ChangeSet methodsFor: 'initialization' stamp: 'nil'!
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: 'change logging' stamp: 'nil'!
classReorganized: anEvent

	self reorganizeClass: anEvent classReorganized! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
methodRemoved: anEvent

	self
		removeSelector: anEvent selector
		class: anEvent methodClass
		priorMethod: anEvent method
		lastMethodInfo: { 
				anEvent method sourcePointer.
				anEvent protocol }! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
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 instanceSide name) includes: #add) 
			ifTrue: [self atClass: class add: #add] 	"When a class is defined, the metaclass
				is not recorded, even though it was added.  A further change is
				really just part of the original add."
			ifFalse: [self atClass: class add: #change]].
	self addCoherency: class name.
	(self changeRecorderFor: class) notePriorDefinition: oldClass! !

!ChangeSet methodsFor: 'accessing' stamp: 'nil'!
name
	"The name of this changeSet. If name is nil, we've got garbage.  Help to identify."

	^ name
		ifNil: [ '<no name -- garbage?>' ]
		ifNotNil: [ name ]! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
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: 'nil'!
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: 'accessing' stamp: 'nil'!
postscriptHasDependents

	^ false! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nil'!
removeClassChanges: class
	"Remove all memory of changes associated with this class"

	| cname |
	cname := class isString
		ifTrue: [ class ]
		ifFalse: [ class name ].
	changeRecords removeKey: cname ifAbsent: [  ]! !

!ChangeSet methodsFor: 'change logging' stamp: 'nil'!
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: 'file in/out' stamp: 'nil'!
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 definitionString) ~= class definitionString ])
		ifTrue: [ 
			stream
				nextChunkPut: currentDef;
				cr ].
	(classRecord includesChangeType: #reorganize)
		ifFalse: [ ^ self ].
	class fileOutOrganizationOn: stream.
	stream cr! !

!ChangeSet class methodsFor: 'file in/out' stamp: 'nil'!
classesOrder: classes
	"Answer a collection with the classes ordered so they can be filed in."

	| listInOrder |
	"SharedPools need to go first"
	listInOrder := Class superclassOrder: (classes select: [ :each | each inheritsFrom: SharedPool ]).
	listInOrder addAll: (Class superclassOrder: (classes reject: [ :each | each inheritsFrom: SharedPool ])).
	^ listInOrder! !

!ChangeSet class methodsFor: 'services' stamp: 'nil'!
reorderChangeSets
	"Change the order of the change sets to something more convenient:
		First come all numbered updates.
		Next come all remaining changesets"
	<script>
	
	| 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: 'enumerating' stamp: 'nil'!
allChangeSetsWithClass: class selector: selector

	class ifNil: [^ #()].
	^ self allChangeSets select: 
		[:cs | (cs atSelector: selector class: class) ~~ #none]! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'nil'!
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: 'instance creation' stamp: 'nil'!
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: self defaultName! !

!ChangeSet class methodsFor: 'current changeset' stamp: 'nil'!
current
	"Return the current changeset assure first that we have a named changeset."

	(current isNil or: [ current isMoribund ]) ifTrue: [ 
		self
			newChanges: (self assuredChangeSetNamed: 'Unnamed')
			withOld: current ].
	^ current! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'nil'!
gatherChangeSets		
	"Collect any change sets created in other projects"
	<script>
	
	| allChangeSets |
	allChangeSets := AllChangeSets asSet.
	self 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: 'nil'!
promoteToTop: aChangeSet
	"Make aChangeSet the first in the list from now on"

	AllChangeSets remove: aChangeSet ifAbsent: [ ^ self ].
	AllChangeSets add: aChangeSet! !

!ChangeSet class methodsFor: 'services' stamp: 'nil'!
countOfChangeSetsWithClass: aClass andSelector: aSelector
	"Answer how many change sets record a change for the given class and selector"

	^ (self allChangeSetsWithClass: aClass selector: aSelector) size! !

!ChangeSet class methodsFor: 'settings' stamp: 'nil'!
mustCheckForSlips

	^ MustCheckForSlips ifNil: [ MustCheckForSlips := true ]! !

!ChangeSet class methodsFor: 'defaults' stamp: 'nil'!
promptForDefaultChangeSetDirectoryIfNecessary
	<script>
	
	| path |
	path := UIManager default 
		chooseDirectory: 'Please select where you want to save your cs' 
		from: FileSystem workingDirectory.
	self defaultChangeSetDirectoryName: path asFileReference.
	^ path asFileReference! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'nil'!
removeChangeSetsNamedSuchThat: nameBlock

	(self changeSetsNamedSuchThat: nameBlock) do: [ :cs | 
		self removeChangeSet: cs ]! !

!ChangeSet class methodsFor: 'file in/out' stamp: 'nil'!
traitsOrder: aCollection 
	"Arrange the traits in the collection, first who don't depend on others."

	| unprocessed |
	unprocessed := aCollection asSet. 
	^ Array new: unprocessed size streamContents: [ :stream |
		unprocessed size timesRepeat: [ 
			| aTrait |
			aTrait := unprocessed detect: [ :each | self hasNoDependenciesFor: each in: unprocessed ].
			stream nextPut: aTrait.
			unprocessed remove: aTrait] ]! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'nil'!
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: '*System-Changes-FileServices' stamp: ''!
fileReaderServicesForFile: fullName suffix: suffix
	<fileService>
	
	^ (#('st' 'cs') includes: suffix)
		ifTrue: [ self services]
		ifFalse: [#()]! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'nil'!
allChangeSets: aCollection
	"Return the list of all current ChangeSets"

	AllChangeSets := aCollection! !

!ChangeSet class methodsFor: '*System-Changes-FileServices' stamp: ''!
services
	^ Array with: self serviceFileIntoNewChangeSet! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'nil'!
allChangeSets
	"Return the list of all current ChangeSets"

	^ AllChangeSets! !

!ChangeSet class methodsFor: 'defaults' stamp: 'nil'!
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: 'enumerating' stamp: 'nil'!
allChangeSetNames

	^ self allChangeSets collect: [:c | c name]! !

!ChangeSet class methodsFor: 'settings' stamp: 'nil'!
defaultChangeSetDirectoryName

	^ DefaultChangeSetDirectoryName ifNil: [ 
		  DefaultChangeSetDirectoryName := FileSystem workingDirectory ]! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'nil'!
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: 'current changeset' stamp: 'nil'!
newChanges: aChangeSet withOld: old
	"Set the system ChangeSet to be the argument, aChangeSet."

	SystemAnnouncer uniqueInstance unsubscribe: old.
	current := aChangeSet.
	
	SystemAnnouncer uniqueInstance private weak
		when: ClassRemoved send: #classRemoved: to: aChangeSet;
		when: ClassAdded send: #classAdded: to: aChangeSet;
		when: ClassCommented send: #classCommented: to: aChangeSet;
		when: ClassRenamed send: #classRenamed: to: aChangeSet;
		when: ClassReorganized send: #classReorganized: to: aChangeSet;
		when: ClassRecategorized send: #classRecategorized: to: aChangeSet;
		when: ClassModifiedClassDefinition send: #classModified: to: aChangeSet.
	
	SystemAnnouncer uniqueInstance private weak
		when: MethodAdded send: #methodAdded: to: aChangeSet;
		when: MethodModified send: #methodModified: to: aChangeSet;
		when: MethodRemoved send: #methodRemoved: to: aChangeSet;
		when: MethodRecategorized send: #methodRecategorized: to: aChangeSet;
		when: DoItChunkImported send: #doItChunkImported: to: aChangeSet.
			
	SystemAnnouncer uniqueInstance announce: (CurrentChangeSetChanged new old: old; new: aChangeSet ; yourself)
	! !

!ChangeSet class methodsFor: 'services' stamp: 'nil'!
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 := self current.
	newName := aName withoutPeriodSuffix.
	newSet := self basicNewChangeSet: newName.
	[
	newSet ifNotNil: [ 
		self newChanges: newSet.
		CodeImporter evaluateReadStream: aStream ]
	] ensure: [ self newChanges: oldChanges ].
	^ newSet! !

!ChangeSet class methodsFor: 'instance creation' stamp: 'nil'!
basicNewNamed: aName

	^ (self basicNew name: aName) initialize! !

!ChangeSet class methodsFor: 'defaults' stamp: 'nil'!
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: 'current changeset' stamp: 'nil'!
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: '*System-Changes-FileServices' stamp: ''!
serviceFileIntoNewChangeSet
	"Answer a service for installing a file into a new change set"

	^ SimpleServiceEntry 
		provider: self 
		label: 'Install into the image'
		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: '*Tests' stamp: ''!
newTestChangeSet

	^ self basicNewChangeSet: self testName! !

!ChangeSet class methodsFor: '*Tests' stamp: ''!
testName
	^ self uniqueNameLike: 'Test'! !

!ChangeSet class methodsFor: 'file in/out' stamp: 'nil'!
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 notEmpty ifTrue:
		[infoString := infoString, '

', notFound size printString, ' change set(s) not found:'.
		notFound do:
			[:aName | infoString := infoString, '
', aName]].
	empty notEmpty ifTrue:
		[infoString := infoString, '
', empty size printString, ' change set(s) were empty:'.
		empty do:
			[:aName | infoString := infoString, '
', aName]].

	self inform: infoString! !

!ChangeSet class methodsFor: 'class initialization' stamp: 'nil'!
initialize

	AllChangeSets ifNil: [ AllChangeSets := OrderedCollection new ].
	self defaultChangeSetDirectoryName: nil.
	self gatherChangeSets! !

!ChangeSet class methodsFor: 'system-events' stamp: 'nil'!
registerInterestToSystemAnnouncer
	<systemEventRegistration>
	
	self newChanges: self current! !

!ChangeSet class methodsFor: 'services' stamp: 'nil'!
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: 'nil'!
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: 'cleanup' stamp: 'nil'!
cleanUp: aggressive
	"Only delete change sets when being aggressive"

	aggressive
		ifFalse: [ ^ self ].
	self removeChangeSetsNamedSuchThat: [ :each | true ].
	self resetCurrentToNewUnnamedChangeSet! !

!ChangeSet class methodsFor: 'scanning' stamp: 'nil'!
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 notEmpty] whileTrue:[
		items add: (ChangeRecord new file: file position: itemPosition type: #method
							class: class category: cat meta: meta stamp: stamp)].
	^ items! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'nil'!
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: 'defaults' stamp: 'nil'!
defaultName

	^ self uniqueNameLike: 'Unnamed'! !

!ChangeSet class methodsFor: '*System-Changes-FileServices' stamp: ''!
fileIntoNewChangeSet: fullName
	"File in all of the contents of the currently selected file, if any, into a new change set." 
	fullName ifNil: [^ self ].
	fullName asFileReference readStreamDo: [ :readStream |
		self newChangesFromStream: readStream named: fullName asFileReference basename ]! !

!ChangeSet class methodsFor: 'services' stamp: 'nil'!
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: self defaultName.
	newName isEmptyOrNil ifTrue:
		[^ nil].
	newSet := self basicNewChangeSet: newName.
	newSet ifNotNil:
		[self  newChanges: newSet].
	^ newSet! !

!ChangeSet class methodsFor: 'file in/out' stamp: 'nil'!
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: 'settings' stamp: 'nil'!
mustCheckForSlips: aBoolean

	MustCheckForSlips := aBoolean! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'nil'!
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: 'current changeset' stamp: 'nil'!
resetCurrentToNewUnnamedChangeSet
 
	current := self new.  
	self newChanges: current ! !

!ChangeSet class methodsFor: 'settings' stamp: 'nil'!
defaultChangeSetDirectoryName: aName

	DefaultChangeSetDirectoryName := aName! !

!ChangeSet class methodsFor: 'services' stamp: 'nil'!
assuredChangeSetNamed: aName
	"Answer a change set of the given name.  If one already exists, answer that, else create a new one and answer it."

	^ (self named: aName)
		ifNotNil: [:existing | existing]
		ifNil: [self basicNewChangeSet: aName]! !

!ChangeSet class methodsFor: 'defaults' stamp: 'nil'!
uniqueNameLike: aString

	| try index |
	(self named: aString)
		ifNil: [ ^ aString ].
	index := 1.
	[ try := aString , index printString.
	  (self named: try)
		ifNil: [ ^ try ].
	  index := index + 1 ] repeat
! !

!ChangeSetClassChangesTest commentStamp: ''!
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: 'tests' stamp: ''!
testAddInstanceVariable

	"Adding an instance variable to the class should result in a change
	record being added to the current change set."

	| class className saveClassDefinition |
	"Define a class and save its definition"
	class := factory newClassWithInstanceVariableNames: 'zzz'.
	className := class name.
	saveClassDefinition := class definitionString.

	self
		assertDefinition: saveClassDefinition
		equivalentTo: class definitionString.
	
	"Redefine the class, adding one instance variable"
	factory redefineClass: class instanceVariableNames: 'zzz aaa'.

	self
		denyDefinition: class definitionString
		equivalentTo: saveClassDefinition.
	
	"Assert that the change has been recorded in the current change set"
	self
		assertDefinition: (ChangeSet current changeRecorderFor: class) priorDefinition
		equivalentTo: saveClassDefinition! !

!ChangeSetClassChangesTest methodsFor: 'running' stamp: ''!
tearDown
	factory cleanUp.
	ChangeSet newChanges: oldChangeSet.
	ChangeSet removeChangeSetsNamedSuchThat: [ :each | each = newChangeSetName ].
	super tearDown! !

!ChangeSetClassChangesTest methodsFor: 'support' stamp: ''!
testRenaming

	| class newMetaclassName renamedName |
	class := factory newClass.
	renamedName := ('Renamed' , class name) asSymbol.
	newMetaclassName := (renamedName , #' class') asSymbol.
	class class compile: 'dummyMeth'.
	class rename: renamedName.
	self assert: class name equals: renamedName.
	self assert: (ChangeSet current changedClassNames includes: renamedName).
	self assert: (ChangeSet current changedClassNames includes: newMetaclassName)! !

!ChangeSetClassChangesTest methodsFor: 'tests' stamp: ''!
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."

	| class |
	class := factory newClassInCategory: 'TestPackage1'.
	
	"Forget about JunkClass in the change set"
	ChangeSet current removeClassChanges: class name. 
	
	"Redefine the class, changing only the class category"
	factory redefineClass: class category: 'TestPackage2'.
	
	self
		assertDefinition: (ChangeSet current changeRecorderFor: class) priorDefinition
		equivalentTo: class definitionString! !

!ChangeSetClassChangesTest methodsFor: 'support' stamp: ''!
denyDefinition: actualString equivalentTo: expectedString 
	"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."

	^ self
		deny: (actualString copyReplaceAll: ' ''' with: '''')
		equals: (expectedString copyReplaceAll: ' ''' with: '''')! !

!ChangeSetClassChangesTest methodsFor: 'tests' stamp: ''!
testAddInstanceVariableAddsNewChangeRecord
	"Changing the class category for a class should result in a change
	record being updated in the current change set."

	| class saveClassDefinition |

	class := factory newClassWithInstanceVariableNames: 'zzz'.
 	saveClassDefinition := class definitionString.
	ChangeSet current removeClassChanges: class name.	
	"Redefine the class, adding one instance variable"
	factory redefineClass: class instanceVariableNames: 'zzz aaa'.

	self
		assertDefinition: (ChangeSet current changeRecorderFor: class name) priorDefinition
		equivalentTo: saveClassDefinition! !

!ChangeSetClassChangesTest methodsFor: 'support' stamp: ''!
assertDefinition: actualString equivalentTo: expectedString 
	"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."

	^ self
		assert: actualString 
		equals: expectedString! !

!ChangeSetClassChangesTest methodsFor: 'tests' stamp: ''!
testChangeClassCategory
	"Changing the class category for a class should result in a change
	record being added to the current change set."

	| class saveClassDefinition |
	"Define a class and save its definition"
	
	class := factory newClassInCategory: 'TestPackage1'.
	saveClassDefinition := class definitionString.
	self 
		assert: saveClassDefinition 
		equals: class definitionString.
	
	"Redefine the class, changing only the class category"
	factory redefineClass: class category: 'TestPackage2'. 
	self 
		denyDefinition: class definitionString
		equivalentTo: saveClassDefinition.
			
	"Assert that the change has been recorded in the current change set"
	self
		assertDefinition: (ChangeSet current changeRecorderFor: class) priorDefinition
		equivalentTo: class definitionString! !

!ChangeSetClassChangesTest methodsFor: 'tests' stamp: ''!
testInitialChangeSet
	"Run this to assure the initial changeset is named. Checks bug found in 3.9 7052."

	self deny: ChangeSet current printString equals: 'a ChangeSet named <no name -- garbage?>'! !

!ChangeSetClassChangesTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	oldChangeSet := ChangeSet current.
	ChangeSet newChanges: (ChangeSet newTestChangeSet).
	newChangeSetName := ChangeSet current name.
	factory := ClassFactoryForTestCase new.! !

!ChangeSorterModel commentStamp: ''!
A ChangeSorterModel is a model used by Change Sorter UIs for computation!
!ChangeSorterModel methodsFor: 'change set' stamp: ''!
removeChangeSet: aChangeSet prompting: doPrompt
	"Completely destroy my change set.  Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first."

	| message aName changeSetNumber msg |
	aName := aChangeSet name.
	aChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project"
	(aChangeSet isEmpty or: [doPrompt not]) ifFalse:
		[message := 'Are you certain that you want to 
remove (destroy) the change set
named  "', aName, '" ?'.
		(self confirm: message) ifFalse: [^ self]].

	doPrompt ifTrue:
		[msg := aChangeSet hasPreamble
			ifTrue:
				[aChangeSet hasPostscript
					ifTrue:
						['a preamble and a postscript']
					ifFalse:
						['a preamble']]
			ifFalse:
				[aChangeSet hasPostscript
					ifTrue:
						['a postscript']
					ifFalse:
						['']].
		msg isEmpty ifFalse:
			[(self confirm: 
'Caution!!  This change set has
', msg, ' which will be
lost if you destroy the change set.
Do you really want to go ahead with this?') ifFalse: [^ self]]].

	"Go ahead and remove the change set"
	changeSetNumber := aChangeSet name initialIntegerOrNil.
	changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber].
	ChangeSet removeChangeSet: aChangeSet.! !

!ChangeSorterModel methodsFor: 'text' stamp: ''!
buildChangeSetDescriptionFor: changeSet
		
	^ changeSet
		ifNil: [ '' ] 
		ifNotNil: [ changeSet preambleString ifNil: ['']]! !

!ChangeSorterModel methodsFor: 'change set' stamp: ''!
rename: aChangeSet
	"Store a new name string into the selected ChangeSet.  reject duplicate name; allow user to back out"

	| newName |
	newName := UIManager default request: 'New name for this change set'
						initialAnswer: aChangeSet name.
						
	(newName = aChangeSet name or: [newName isEmptyOrNil]) ifTrue:
			[ ^ UIManager default inform: 'Please give a new name' ].

	(ChangeSet named: newName) ifNotNil:
			[ ^ UIManager default inform: 'Sorry that name is already used' ].

	aChangeSet name: newName.
	^ aChangeSet! !

!ChangeSorterModel methodsFor: 'environment' stamp: ''!
allChanges

	^ ChangeSet allChangeSets reverse! !

!ChangeSorterModel methodsFor: 'message' stamp: ''!
fileOutSelector: selector from: aClass
	
	aClass fileOutMethod: selector! !

!ChangeSorterModel methodsFor: 'accessing' stamp: ''!
classDescriptionsMap

	^ self class classDescriptionsMap! !

!ChangeSorterModel methodsFor: 'class' stamp: ''!
copyClass: aClass from: source to: destination

	destination absorbClass: aClass name from: source.! !

!ChangeSorterModel methodsFor: 'change set' stamp: ''!
currentChangeSet

	^ ChangeSet current ! !

!ChangeSorterModel methodsFor: 'text' stamp: ''!
buildClassDescriptionFor: changeSet class: class
	^ String streamContents: [ :stream |
			(changeSet classChangeAt: class name)
				do: [ :each | stream nextPutAll: (self classDescriptionsMap at: each) ]
				separatedBy: [ stream cr ] ]! !

!ChangeSorterModel methodsFor: 'text' stamp: ''!
buildSelectorDescriptionFor: changeSet class: class selector: selector

	| changeType code |
	changeType := changeSet atSelector: selector class: class.
	
	changeType == #remove
		ifTrue: [^ 'Method has been removed (see versions)'].
	changeType == #addedThenRemoved
		ifTrue: [^ 'Added then removed (see versions)']. 
	class
		ifNil: [^ 'Method was added, but cannot be found!!'].
	(class includesSelector: selector)
		ifFalse: [^ 'Method was added, but cannot be found!!'].
	code := class sourceCodeAt: selector.
		
	^ code asText! !

!ChangeSorterModel methodsFor: 'change set' stamp: ''!
createNewSet

	^ ChangeSet newChangeSet! !

!ChangeSorterModel methodsFor: 'class' stamp: ''!
fileOutClass: aClass from: aChangeSet
	"this is a hack!!!! makes a new change set, called the class name, adds author initials to try to make a unique change set name, files it out and removes it. kfr 16 june 2000"
	"Method copied from ChangeSorter"
	
	| aSet |
      aSet := ChangeSet newChangeSet: aClass name.
	aSet ifNil:[ ^self ].
	aSet absorbClass: aClass name from: aChangeSet.
	aSet fileOut.
	ChangeSet removeChangeSet: aSet.! !

!ChangeSorterModel methodsFor: 'message' stamp: ''!
forgetSelector: selector inClass: aClass fromChangeSet: aChangeSet

	aChangeSet
			removeSelectorChanges: selector 
			class: aClass! !

!ChangeSorterModel methodsFor: 'change set' stamp: ''!
submerge: source into: destination
	"Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well."
	|   message |
	source == destination
		ifTrue: [ ^ false ].
	source isEmpty
		ifTrue: [ 
			self inform: 'Nothing to copy.  To remove,
simply choose "remove".'.
			^ false ].

	source okayToRemove ifFalse: [^ false].
	message := 'Please confirm:  copy all changes
in "', source name, '" into "', destination name, '"
and then destroy the change set
named "', source name, '"?'.
 
	(self confirm: message) ifFalse: [^ false].

	(source hasPreamble or: [source hasPostscript]) ifTrue:
		[(self confirm: 
'Caution!!  This change set has a preamble or
a postscript or both.  If you submerge it into
the other side, these will be lost.
Do you really want to go ahead with this?') ifFalse: [^ false]].

	self copyAllChangesFrom: source to: destination.
	self removeChangeSet: source prompting: false.
	^ true! !

!ChangeSorterModel methodsFor: 'text' stamp: ''!
setContentsOfChangeSet: changeSet forClass: class andSelector: selector
	"return the source code that shows in the bottom pane"

	class
		ifNil: [
			"Only the change set is currently selected"
			^ self buildChangeSetDescriptionFor: changeSet ].
	selector 
		ifNil: [ 
			"class is selected but not the selector"
			^ self buildClassDescriptionFor: changeSet class: class ]
		ifNotNil: [
			"a class and a selector are selected"
			^ self buildSelectorDescriptionFor: changeSet class: class selector: selector ]! !

!ChangeSorterModel methodsFor: 'change set' stamp: ''!
copyAllChangesFrom: source to: destination

	destination assimilateAllChangesFoundIn: source! !

!ChangeSorterModel methodsFor: 'message' stamp: ''!
copySelector: selector inClass: class from: source to: destination

	destination
		absorbMethod: selector 
		class: class 
		from:source! !

!ChangeSorterModel methodsFor: 'change set' stamp: ''!
subtractFrom: source to: destination

	source forgetAllChangesFoundIn: destination! !

!ChangeSorterModel methodsFor: 'change set' stamp: ''!
removePostscriptFrom: aChange

	(aChange hasPostscript and: [ aChange postscriptHasDependents ]) ifTrue:
		[^ self inform:
'Cannot remove the postscript right
now because there is at least one
window open on that postscript.
Close that window and try again.'].

	aChange removePostscript! !

!ChangeSorterModel methodsFor: 'change set' stamp: ''!
setCurrentChangeSet: aChangeSet

	ChangeSet newChanges: aChangeSet
	! !

!ChangeSorterModel methodsFor: 'change set' stamp: ''!
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: [ : each | each name ].
	candidates := aCollectionOfChangeSets select:
			[:c | (nameList includes: c name) and: 
				[c name includesSubstring: pattern caseSensitive: false]].
	candidates size = 0 ifTrue: [ ^ self inform: 'No matching change sets.' ].
	candidates size = 1 ifTrue: [ ^ candidates first ].
	index := UIManager default chooseFrom: (candidates collect: [:each | each name]).
	index = 0 ifFalse: [ ^ (candidates at: index) ].! !

!ChangeSorterModel methodsFor: 'change set' stamp: ''!
addPreambleTo: aChangeSet

	aChangeSet assurePreambleExists! !

!ChangeSorterModel methodsFor: 'class' stamp: ''!
removeClass: class from: changeSet

	changeSet removeClassChanges: class.! !

!ChangeSorterModel class methodsFor: 'class initialization' stamp: ''!
initialize
	self classDescriptionsMap: self defaultClassDescriptionsMap! !

!ChangeSorterModel class methodsFor: 'accessing' stamp: ''!
classDescriptionsMap
	^ ClassDescriptionsMap! !

!ChangeSorterModel class methodsFor: 'accessing' stamp: ''!
classDescriptionsMap: anObject
	ClassDescriptionsMap := anObject! !

!ChangeSorterModel class methodsFor: 'defaults' stamp: ''!
defaultClassDescriptionsMap
	^ Dictionary new
		at: #remove put: 'Entire class was removed.';
		at: #addedThenRemoved put: 'Class was added then removed.';
		at: #rename put: 'Class name was changed.';
		at: #add put: 'Class definition was added.';
		at: #change put: 'Class definition was changed.';
		at: #reorganize put: 'Class organization was changed.';
		at: #comment put: 'New class comment.';
		yourself! !

!ChangesBrowser commentStamp: ''!
A ChangesBrowser is a browser used to browse a composite change wich gather all the wanted changes!
!ChangesBrowser methodsFor: 'api' stamp: ''!
cancel
	self window delete! !

!ChangesBrowser methodsFor: 'initialization' stamp: ''!
initializePresenter
	changesTree
		whenHighlightedItemChanged:
			[ :item | item ifNotNil: [ textArea text: (self buildDiffFor: item content) ] ]! !

!ChangesBrowser methodsFor: 'initialization' stamp: ''!
setFocus
	self focusOrder
		add: changesTree;
		add: textArea;
		yourself! !

!ChangesBrowser methodsFor: 'initialization' stamp: ''!
initializeWidgets

	changesTree := self newTree.
	textArea := self newCode.
	
	self initializeChangesTree.
	self initializeTextArea.
	self setFocus.
	self
		bindKeyCombination: PharoShortcuts current acceptShortcut toAction: [ self accept ];
		bindKeyCombination: Character escape toAction: [ self cancel ]! !

!ChangesBrowser methodsFor: 'opening' stamp: ''!
open
	^ self openDialogWithSpec
		okAction: [ self accept ];
		cancelAction: [ self cancel ];
		yourself! !

!ChangesBrowser methodsFor: 'accessing' stamp: ''!
changesTree
	^ changesTree! !

!ChangesBrowser methodsFor: 'accessing' stamp: ''!
pickedChanges
	| selectedItems |
	selectedItems := changesTree selectedItems collect: [:each | each content].
	^ changesTree roots select: [ :i | selectedItems includes: i ]! !

!ChangesBrowser methodsFor: 'initialization' stamp: ''!
setShortcuts
	self changesTree attachKeymapCategory: #ChangesBrowserGlobalShortcuts targetting: self! !

!ChangesBrowser methodsFor: '*Epicea-Triggering' stamp: ''!
asEpiceaEvent
	self flag: #pharoTodo.	"This is a workaround for a problem found by RewriteTool"
	(changes allSatisfy: [ :each | each respondsTo: #asEpiceaEvent ]) ifFalse: [ ^ EpCompositeRefactoring withAll: #() ].

	^ changes size > 1 ifTrue: [ EpCompositeRefactoring withAll: changes ] ifFalse: [ changes anyOne asEpiceaEvent ]! !

!ChangesBrowser methodsFor: '*Epicea-Triggering' stamp: ''!
isEpiceaInterestingJobOwner

	^ true! !

!ChangesBrowser methodsFor: 'visiting' stamp: ''!
accept
	self okToChange
		ifFalse: [ ^ self ].
	[ self pickedChanges do: [ :change | RBRefactoryChangeManager instance performChange: change ] ] asJob
		title: 'Refactoring';
		run.
	self window delete! !

!ChangesBrowser methodsFor: 'accessing' stamp: ''!
changes
	^ changes! !

!ChangesBrowser methodsFor: 'accessing' stamp: ''!
changes: aCollection
	changes := aCollection.
	self updateChanges! !

!ChangesBrowser methodsFor: 'accessing' stamp: ''!
textArea
	^ textArea! !

!ChangesBrowser methodsFor: 'private' stamp: ''!
updateChanges
	| aCompositeChange |
	aCompositeChange := RBRefactoryChangeManager changeFactory
		compositeRefactoryChange.
	changes do: [ :each | aCompositeChange addChange: each ].

	"Later we could filter the shown changes depending on the selected scope"

	changesTree roots: (aCompositeChange whatToDisplayIn: self)! !

!ChangesBrowser methodsFor: 'initialization' stamp: ''!
initializeTextArea
	textArea 
		enabled: false;
		"make sure we can cycle over the text field"
		bindKeyCombination: Character tab toAction: [ self giveFocusToNextFrom: textArea ];
		bindKeyCombination: Character tab shift toAction: [ self giveFocusToPreviousFrom: textArea ].! !

!ChangesBrowser methodsFor: 'private' stamp: ''!
buildDiffFor: aChange

	^ aChange
		ifNil: [ '' ]
		ifNotNil: [
			TextDiffBuilder 
				buildDisplayPatchFrom: aChange oldVersionTextToDisplay 
				to: aChange textToDisplay ].! !

!ChangesBrowser methodsFor: 'initialization' stamp: ''!
initializeChangesTree
	changesTree
		beCheckList;
		removeOnlyLastSelected: true;
		autoMultiSelection: true;
		rootNodeHolder: [ :item | 
					TreeNodePresenter new
						content: item;
						hasContentToShow: true;
						children: [ changesTree childrenFor: item ] ];
		displayBlock: [ :item | item nameToDisplay ].
	self whenBuiltDo: [ changesTree selectAll ]! !

!ChangesBrowser class methodsFor: 'shortcuts' stamp: ''!
buildShortcutsOn: aBuilder
	<keymap>

	(aBuilder shortcut: #close)
		category: #ChangesBrowserGlobalShortcuts
		default: PharoShortcuts current cancelShortcut
		do: [ :target | target cancel ]
		description: 'Close this dialog'.
		
	(aBuilder shortcut: #accept)
		category: #ChangesBrowserGlobalShortcuts
		default: PharoShortcuts current acceptShortcut
		do: [ :target | target accept ]
		description: 'Accept the proposed changes'.! !

!ChangesBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	^ SpecLayout composed
		newColumn: [ :column1 | 
			column1
				newColumn: [ :column2 | column2 add: #changesTree ];
				addSplitter;
				add: #textArea ]! !

!ChangesBrowser class methodsFor: 'instance creation' stamp: ''!
changes: aCollection

	^ self new
		changes: aCollection;
		yourself! !

!ChangesBrowser class methodsFor: 'specs' stamp: ''!
title

	^ 'Changes Browser'! !

!ChangesBrowserTest commentStamp: ''!
A ChangesBrowserTest is a test class for testing the behavior of ChangesBrowser!
!ChangesBrowserTest methodsFor: 'tests' stamp: ''!
testBuildDiffFor
	self assert: (browser buildDiffFor: nil) equals: ''! !

!ChangesBrowserTest methodsFor: 'tests' stamp: ''!
testInitializeWidgets
	self assert: browser changesTree isNotNil.
	self assert: browser textArea isNotNil.
	self
		assertCollection: browser focusOrder
		equals:
			{browser changesTree.
			browser textArea} asOrderedCollection! !

!ChangesBrowserTest methodsFor: 'tests' stamp: ''!
testChanges
	| aCollection |
	aCollection := {RBRefactoryChange new}.
	browser changes: aCollection.
	self assert: browser changes equals: aCollection! !

!ChangesBrowserTest methodsFor: 'tests' stamp: ''!
testPickedChanges
	self assertEmpty: browser pickedChanges! !

!ChangesBrowserTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	browser := ChangesBrowser new! !

!ChangesLog commentStamp: ''!
I represent the changes file and give access to him.  If you want to log a change, look at my #logChange: method.

I have a default instance that is hearing SystemAnnouncements and logging the change logs in there.
But you can have your own instance and log whatever you want.!
!ChangesLog methodsFor: 'private' stamp: ''!
assureStartupStampLogged
	"If there is a startup stamp not yet actually logged to disk, do it now."

	startupStamp ifNil: [ ^ self ].

	SourceFiles changesWriteStreamDo: [ :changesFile |
		changesFile
			cr; cr;
			nextChunkPut: startupStamp asString;
			cr.
		startupStamp := nil ].

	SourceFiles forceChangesToDisk! !

!ChangesLog methodsFor: 'event-listening' stamp: ''!
logMethodRemoved: announcement
	announcement methodClass acceptsLoggingOfCompilation ifTrue: [
		self logChange: 
			announcement methodClass name, ' removeSelector: #', announcement selector
	]
	! !

!ChangesLog methodsFor: 'event-listening' stamp: ''!
registerToAnnouncements
	SystemAnnouncer uniqueInstance weak
		when: ClassRemoved 
			send: #logClassRemoved:
			to: self;
		when: ClassRenamed 
			send: #logClassRenamed:
			to: self;
		when: MethodRemoved
			send: #logMethodRemoved:
			to: self;
		when: ExpressionEvaluated 
			send: #logExpressionEvaluated:
			to: self.! !

!ChangesLog methodsFor: 'event-listening' stamp: ''!
logClassRemoved: announcement
	announcement classRemoved acceptsLoggingOfCompilation ifTrue: [
		self logChange: 'Smalltalk globals removeClassNamed: #', announcement classRemoved name	
	].
! !

!ChangesLog methodsFor: 'accessing' stamp: ''!
recordStartupStamp
	
	startupStamp := '----STARTUP----', DateAndTime now printString, ' as ', Smalltalk imagePath.
! !

!ChangesLog methodsFor: 'event-listening' stamp: ''!
logExpressionEvaluated: announcement
	self logChange: announcement expressionEvaluated.! !

!ChangesLog methodsFor: 'logging' stamp: ''!
logChange: aStringOrText
	"Write the argument, aString, onto the changes file."

	| aString |
	(SourceFiles changesFileStream isNil or: [ SourceFiles changesFileStream closed ])
    ifTrue: [ ^ self ].
	
	self assureStartupStampLogged.

	aString := aStringOrText asString.
	(aString findFirst: [ :char | char isSeparator not ]) = 0
		ifTrue: [ ^ self ].	"null doits confuse replay"

	SourceFiles changesWriteStreamDo: [ :changesFile |
		changesFile
			cr; cr.
			
		(ChunkWriteStream on: changesFile)
			nextPut: aString ].

	SourceFiles forceChangesToDisk! !

!ChangesLog methodsFor: 'logging' stamp: ''!
logSnapshot: save andQuit: quit
	"Log into the changes file the fact that the session will be either snapshoted, quit, or both."

	| message |	
	(SourceFiles changesFileStream isNil or: [ SourceFiles changesFileStream closed ])
    ifTrue: [ ^ self ].

	message := String
		streamContents: [ :s | 
			s
				nextPutAll: '----';
				nextPutAll:
						(save
								ifTrue: [ 
									quit
										ifTrue: [ 'QUIT' ]
										ifFalse: [ 'SNAPSHOT' ] ]
								ifFalse: [ 
									quit
										ifTrue: [ 'QUIT/NOSAVE' ]
										ifFalse: [ 'NOP' ] ]);
				nextPutAll: '----';
				print: DateAndTime now;
				space;
				nextPutAll: (Smalltalk imageFile basename);
				nextPutAll: ' priorSource: ';
				print: Smalltalk lastQuitLogPosition ].

	self assureStartupStampLogged.

	save ifTrue: [ 
		Smalltalk lastQuitLogPosition:
			SourceFiles changesFileStream size ].

	self logChange: message! !

!ChangesLog methodsFor: 'event-listening' stamp: ''!
logClassRenamed: announcement
	announcement classRenamed acceptsLoggingOfCompilation ifTrue: [
		self logChange: '(Smalltalk globals at: #', announcement oldName, ') rename: #', announcement newName.	
	].
! !

!ChangesLog class methodsFor: 'accessing' stamp: ''!
default
	^DefaultInstance ifNil: [ 
		DefaultInstance := self new.
		self registerInterestToSystemAnnouncement.
		DefaultInstance.].! !

!ChangesLog class methodsFor: 'accessing' stamp: ''!
registerInterestToSystemAnnouncement
	<systemEventRegistration>
	
	DefaultInstance ifNotNil: [:defaultInstance |
		SystemAnnouncer uniqueInstance unsubscribe: defaultInstance.
		defaultInstance registerToAnnouncements. ].
! !

!ChangesLog class methodsFor: 'class initialization' stamp: ''!
reset
	SystemAnnouncer uniqueInstance unsubscribe: DefaultInstance.
	DefaultInstance := nil.! !

!Character commentStamp: ''!
I represent a character by storing its associated Unicode. The first 256 characters are created uniquely, so that all instances of latin1 characters ($R, for example) are identical.

The code point is based on Unicode. Since Unicode is 21-bit wide character set, we have several bits available for other information.  As the Unicode Standard  states, a Unicode code point doesn't carry the language information.  This is going to be a problem with the languages so called CJK (Chinese, Japanese, Korean.  Or often CJKV including Vietnamese).  Since the characters of those languages are unified and given the same code point, it is impossible to display a bare Unicode code point in an inspector or such tools.  To utilize the extra available bits, we use them for identifying the languages.  Since the old implementation uses the bits to identify the character encoding, the bits are sometimes called "encoding tag" or neutrally "leading char", but the bits rigidly denotes the concept of languages.

The other languages can have the language tag if you like.  This will help to break the large default font (font set) into separately loadable chunk of fonts.  However, it is open to the each native speakers and writers to decide how to define the character equality, since the same Unicode code point may have different language tag thus simple #= comparison may return false.

I represent a character by storing its associated ASCII code (extended to 256 codes). My instances are created uniquely, so that all instances of a character ($R, for example) are identical.!
!Character methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
asKeyCombination
	| lowerCaseCombination |
	self asLowercase = self ifTrue: [^ KMSingleKeyCombination from: self].
	lowerCaseCombination := KMSingleKeyCombination from: self asLowercase.
	^KMModifiedKeyCombination modifier: KMModifier shift character: lowerCaseCombination.! !

!Character methodsFor: 'testing' stamp: ''!
isOtherLetter
^ self characterSet isOtherLetter: self! !

!Character methodsFor: 'testing - kind' stamp: ''!
shouldBePrintedAsLiteral
	^ self asInteger between: 33 and: 255! !

!Character methodsFor: 'accessing' stamp: ''!
asciiValue
	"Answer the receiver's character code.
	 This will be ascii for characters with value <= 127,
	 and Unicode for those with higher values."
	<primitive: 171>
	^self primitiveFailed! !

!Character methodsFor: 'testing' stamp: ''!
isConnectorPunctuation
	"Return whether the receiver is one of these characters:   _"
	"$_ isConnectorPunctuation >>> true"
	"$( isConnectorPunctuation >>> false"
	"$) isConnectorPunctuation >>> false"
	"$> isConnectorPunctuation >>> false"
	"$} isConnectorPunctuation >>> false"
	
	^ self characterSet isConnectorPunctuation: self! !

!Character methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
alt
	^ KMModifier alt + self! !

!Character methodsFor: 'testing' stamp: ''!
isClosePunctuation
	"Return whether the receiver is one of these characters:  )]}"
	"$a isClosePunctuation >>> false"
	"$( isClosePunctuation >>> false"
	"$) isClosePunctuation >>> true"
	"$] isClosePunctuation >>> true"
	"$} isClosePunctuation >>> true"
	
	^ self characterSet isClosePunctuation: self! !

!Character methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
asShortcut
	^ self asKeyCombination! !

!Character methodsFor: '*Fuel-Core' stamp: ''!
serializeOn: anEncoder

	anEncoder encodeUint32: self asInteger! !

!Character methodsFor: 'converting' stamp: ''!
basicPharoToIso
	| tmp1 |
	self asInteger < 128
		ifTrue: [ ^ self ].
	self asInteger > 255
		ifTrue: [ ^ self ].
	tmp1 := #(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: tmp1! !

!Character methodsFor: 'testing' stamp: ''!
isImmediateObject
	"This is needed for the bootstrap"
	^ true! !

!Character methodsFor: '*Text-Core' stamp: ''!
asText
	^ self asString asText! !

!Character methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
control
	^ KMModifier control + self! !

!Character methodsFor: 'testing' stamp: ''!
isTitlecaseLetter
^ self characterSet isTitlecaseLetter: self! !

!Character methodsFor: 'testing' stamp: ''!
canBeGlobalVarInitial
	^ self characterSet canBeGlobalVarInitial: self! !

!Character methodsFor: 'converting' stamp: ''!
asSymbol 
	"Answer a Symbol consisting of the receiver as the only element."

	^Symbol internCharacter: self! !

!Character methodsFor: 'copying' stamp: ''!
deepCopy
	"Answer the receiver, because Characters are unique."
	^self! !

!Character methodsFor: 'testing' stamp: ''!
isPrivateOther
^ self characterSet isPrivateOther: self! !

!Character methodsFor: 'printing' stamp: ''!
printStringHex
	"$A printStringHex >>> '41'"

	^ self asInteger printStringBase: 16! !

!Character methodsFor: 'testing' stamp: ''!
isSpaceSeparator
^ self characterSet isSpaceSeparator: self! !

!Character methodsFor: 'testing' stamp: ''!
isOtherNumber
	^ self characterSet isOtherNumber: self! !

!Character methodsFor: 'converting' stamp: ''!
asUppercase
	"If the receiver is lowercase, answer its matching uppercase Character."
	^ self characterSet toUppercase: self! !

!Character methodsFor: 'comparing' stamp: ''!
= aCharacter 
	"Primitive. Answer if the receiver and the argument are the
	 same object (have the same object pointer). Optional. See
	 Object documentation whatIsAPrimitive."
	<primitive: 110>
	^self == aCharacter! !

!Character methodsFor: 'comparing' stamp: ''!
sameAs: aCharacter 
	"Answer whether the receiver is equal to aCharacter, ignoring case"
	^ (self asLowercase = aCharacter asLowercase)! !

!Character methodsFor: 'converting' stamp: ''!
to: other
	"Answer with a collection in ascii order -- $a to: $z"
	^ (self asciiValue to: other asciiValue) collect:
				[:ascii | Character value: ascii]! !

!Character methodsFor: 'comparing' stamp: ''!
> aCharacter 
	"Answer true if the receiver's value > aCharacter's value."

	^self asciiValue > aCharacter asciiValue! !

!Character methodsFor: 'converting' stamp: ''!
asInteger
	"Answer the receiver's character code."
	<primitive: 171>
	^self primitiveFailed! !

!Character methodsFor: '*Deprecated90' stamp: ''!
unicodeToMacRoman
	"Convert the receiver from Unicode to MacRoman encoding."

	^MacRomanTextConverter new byteToUnicode: self! !

!Character methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter writeObject: self listSingleton: self asString! !

!Character methodsFor: 'accessing' stamp: ''!
characterSet
	^ self class characterSet! !

!Character methodsFor: 'testing' stamp: ''!
isOtherSymbol
^ self characterSet isOtherSymbol: self! !

!Character methodsFor: 'testing' stamp: ''!
isOtherPunctuation
^ self characterSet isOtherPunctuation: self! !

!Character methodsFor: 'testing' stamp: ''!
isVowel
	"Answer whether the receiver is one of the vowels, AEIOU, in upper or 
	lower case."

	^'AEIOU' includes: self asUppercase! !

!Character methodsFor: 'testing' stamp: ''!
isAlphaNumeric
	"Answer whether the receiver is a letter or a digit."
	"$a isAlphaNumeric >>> true"
	"$A isAlphaNumeric >>> true"
	"$' isAlphaNumeric >>> false"
	"$1 isAlphaNumeric >>> true"
	"Character space isAlphaNumeric >>> false"

	^ self isLetter or: [ self isDigit ]! !

!Character methodsFor: 'converting' stamp: ''!
lowercase
	^ self asLowercase! !

!Character methodsFor: 'testing - kind' stamp: ''!
isLiteral

	^ true! !

!Character methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
shift
	^ KMModifier shift + self! !

!Character methodsFor: 'testing' stamp: ''!
isUppercase

	^ self characterSet isUppercase: self! !

!Character methodsFor: '*Deprecated90' stamp: ''!
leadingChar
	^ (self asInteger bitAnd: 1069547520) bitShift: -22! !

!Character methodsFor: 'accessing' stamp: ''!
codePoint
	"Just for ANSI Compliance"	
	^self asciiValue! !

!Character methodsFor: 'printing' stamp: ''!
hex
	"Returns a string representation of the receiver as hex, prefixed with 16r.  
	DO NOT CHANGE THIS!!  The Cog VMMaker depends on this."
	"$A hex >>> '16r41'"	
			
	^ self asInteger hex! !

!Character methodsFor: 'converting' stamp: ''!
asString
	^ String with: self! !

!Character methodsFor: 'testing' stamp: ''!
isSafeForHTTP
	"Return whether a character is 'safe', or needs to be escaped when used, eg, in a URL"
	"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 - unicode' stamp: ''!
isFormatOther
	"Return whether the receiver in this category: https://www.compart.com/en/unicode/category/Cf"
	^ self characterSet isFormatOther: self! !

!Character methodsFor: 'testing' stamp: ''!
isCurrencySymbol
	"Return whether the receiver is one of these characters:   $ and euro"
	"$$ isCurrencySymbol >>> true"
	"Character euro isCurrencySymbol >>> true"
	"$} isControlOther >>> false"
	
	^ self characterSet isCurrencySymbol: self! !

!Character methodsFor: 'printing' stamp: ''!
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: self asInteger; nextPut: $) ] ]! !

!Character methodsFor: 'testing' stamp: ''!
isParagraphSeparator
^ self characterSet isParagraphSeparator: self! !

!Character methodsFor: 'comparing' stamp: ''!
< aCharacter 
	"Answer true if the receiver's value < aCharacter's value."

	^self asciiValue < aCharacter asciiValue! !

!Character methodsFor: 'testing - unicode' stamp: ''!
isLineSeparator
	"Return whether the receiver is https://www.compart.com/en/unicode/category/Zl"
	
	^ self characterSet isLineSeparator: self! !

!Character methodsFor: 'testing - unicode' stamp: ''!
isFinalQuote
	"Return whether the receiver is https://www.compart.com/en/unicode/category/Pf"
	"$' isFinalQuote >>> false"
	
	^ self characterSet isFinalQuote: self! !

!Character methodsFor: 'comparing' stamp: ''!
hash
	"Hash is reimplemented because = is implemented.
	 Answer the receiver's character code."
	<primitive: 171>
	^self primitiveFailed! !

!Character methodsFor: 'testing' stamp: ''!
isCharacter

	^ true! !

!Character methodsFor: 'testing - kind' stamp: ''!
isOctetCharacter
	^ self asInteger < 256! !

!Character methodsFor: 'accessing' stamp: ''!
digitValue
	self asInteger > 255
		ifTrue: [ ^ self characterSet digitValueOf: self ].
	^ DigitValues at: 1 + self asInteger! !

!Character methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitHookPrimitive: self! !

!Character methodsFor: 'converting' stamp: ''!
uppercase
	^ self asUppercase! !

!Character methodsFor: 'comparing' stamp: ''!
basicIdentityHash
	"Answer the receiver's character code.
	 The value answered is unsigned. It can in theory be in the full
	 poisitive SmallInteger range, but based on Unicode, it is fair
	 to assume that the value is in the range [ 0 ; 16r3FFFFF ]"
	<primitive: 171>
	^self primitiveFailed! !

!Character methodsFor: 'testing' stamp: ''!
isDashPunctuation
	"Return whether the receiver is one of these characters:   $-"
	"$- isDashPunctuation >>> true"
	"$_ isDashPunctuation >>> false"
	
	^ self characterSet isDashPunctuation: self! !

!Character methodsFor: 'printing' stamp: ''!
storeBinaryOn: aStream
	self asInteger < 256
		ifTrue: [ aStream basicNextPut: self asInteger ]
		ifFalse: [ aStream nextInt32Put: self asInteger ]! !

!Character methodsFor: 'testing' stamp: ''!
isLetter
	"Return whether the receiver is a letter."
	"$a isLetter >>> true"
	"$é isLetter >>> true"
	"$A isLetter >>> true"

	^ self characterSet isLetter: self! !

!Character methodsFor: 'testing' stamp: ''!
tokenish
	"Answer whether the receiver is a valid token-character -- letter, digit, underscore, or colon."
	"$' tokenish >>> false"
	"$: tokenish >>> true"
	"${ tokenish >>> false"
	"Character space tokenish >>> false"
	
	^ self isLetter or: [ self isDigit or: [ self = $_ or: [ self = $: ] ] ]! !

!Character methodsFor: 'memory scanning' stamp: ''!
nextObject
	"Characters are immediate objects, and, as such, do not have successors in object memory."

	self shouldNotImplement! !

!Character methodsFor: '*NECompletion' stamp: ''!
isCompletionCharacter
	"I defined the logic that completion can only happen with alphanumeric : characters."
	^ self isAlphaNumeric or: [ self = $: ]! !

!Character methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
command
	^ KMModifier command + self! !

!Character methodsFor: '*Collections-Abstract-splitjoin' stamp: ''!
join: aSequenceableCollection
	"Append the elements of the argument, aSequenceableCollection, separating them by the receiver."
	"(Character space join: #('Pharo' 'is' 'cool')) >>> 'Pharo is cool'"
	^ self asString join: aSequenceableCollection! !

!Character methodsFor: 'copying' stamp: ''!
copy
	"Answer the receiver, because Characters are unique."
	^self! !

!Character methodsFor: 'testing' stamp: ''!
isDecimalDigit
	"Return whether the receiver is a digit."
	"$1 isDecimalDigit >>> true"
	"$0 isDecimalDigit >>> true"

	^ self characterSet isDecimalDigit: self! !

!Character methodsFor: 'testing' stamp: ''!
isDoubleQuote
	"Returns whether the receiver is a Double Quote"

	^ self = $"! !

!Character methodsFor: 'converting' stamp: ''!
asUnicode

	^ self asInteger! !

!Character methodsFor: '*Fuel-Core' stamp: ''!
largeIdentityHash

	^ self identityHash! !

!Character methodsFor: 'testing' stamp: ''!
isSeparator
	"Returns whether the receiver is a separator i.e., a space, tab, lf, cr, and newPage"
	"Character space isSeparator >>> true"
	"Character lf isSeparator >>> true"
	"Character cr isSeparator >>> true"
	"Character newPage isSeparator >>> true"
	"Character tab isSeparator >>> true"
	"$' isSeparator >>> false"
	
	| in |
	^ (in := self asInteger) == 32 or: [ in == 13 or: [ in == 9 or: [ in == 10 or: [ in == 12 ] ] ] ]! !

!Character methodsFor: 'testing' stamp: ''!
isOpenPunctuation
^ self characterSet isOpenPunctuation: self! !

!Character methodsFor: 'testing' stamp: ''!
isArrow

	^ { Character arrowUp. Character arrowDown. Character arrowLeft. Character arrowRight } includes: self! !

!Character methodsFor: 'testing - unicode' stamp: ''!
isInitialQuote
	"Return whether the receiver is https://www.compart.com/en/unicode/category/Pi"
	"$' isInitialQuote >>> false"
	
	^ self characterSet isInitialQuote: self! !

!Character methodsFor: 'testing' stamp: ''!
isSpecial
	"Answer whether the receiver is one of the special characters: i.e., +-/\*~<>=@,%|&?!! and a couple of others."

	^ self class specialCharacters includes: self! !

!Character methodsFor: 'copying' stamp: ''!
shallowCopy
	"Answer the receiver, because Characters are unique."
	^self! !

!Character methodsFor: 'testing - unicode' stamp: ''!
isLetterModifier
	"Return whether the receiver is https://www.compart.com/en/unicode/category/Lm"
	
	^ self characterSet isLetterModifier: self! !

!Character methodsFor: 'testing - unicode' stamp: ''!
isEnclosingMark
	"Return whether the receiver is ... one of these https://www.compart.com/en/unicode/category/Me"
	"$' isEnclosingMark >>> false"
	
	
	^ self characterSet isEnclosingMark: self! !

!Character methodsFor: 'accessing' stamp: ''!
hexDigitValue
	"Return the case independent hexadecimal digit value of the receiver.
	$0 to: $9 will return 0 to 9, while $a to $f and $A to $F both will return 10 to 15.
	If the receiver does not represent a hexadecimal digit, return nil.
	Returns an integer between 0 and 15."
	
	| codePoint |
	^ ((codePoint := self asInteger) between: 0 and: 127)
		ifTrue: [ #(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 nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 0 1 2 3 4 5 6 7 8 9 nil nil nil nil nil nil nil 10 11 12 13 14 15 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 10 11 12 13 14 15 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) at: codePoint + 1 ]
		ifFalse: [ nil ]! !

!Character methodsFor: 'testing' stamp: ''!
isSurrogateOther
^ self characterSet isSurrogateOther: self! !

!Character methodsFor: 'printing' stamp: ''!
printOn: aStream
	| name |
	(self asInteger > 32 and: [ self asInteger ~= 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: self asInteger ] ]! !

!Character methodsFor: 'testing' stamp: ''!
isModifierSymbol

	^ self characterSet isModifierSymbol: self! !

!Character methodsFor: 'testing' stamp: ''!
canBeNonGlobalVarInitial
  ^ self characterSet canBeNonGlobalVarInitial: self! !

!Character methodsFor: 'private' stamp: ''!
setValue: newValue
	self error: 'Characters are immutable'! !

!Character methodsFor: 'testing' stamp: ''!
isDigit
	"Return whether the receiver is a digit."
	"$1 isDigit >>> true"
	"$0 isDigit >>> true"
	
	^ self characterSet isDigit: self! !

!Character methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
ctrl
	^ KMModifier ctrl + self! !

!Character methodsFor: 'testing - unicode' stamp: ''!
isLetterNumber
	"Return whether the receiver is part of https://www.compart.com/en/unicode/category/Nl"
	^ self characterSet isLetterNumber: self! !

!Character methodsFor: 'testing' stamp: ''!
isCasedLetter
	"We are sorry but this method is unclear and will probably be removed.
	This method only returning false."
	"$a isCasedLetter >>> false"
	"$A isCasedLetter >>> false"
	
	^ self characterSet isCasedLetter: self! !

!Character methodsFor: 'testing' stamp: ''!
isMathSymbol
	^ self characterSet isMathSymbol: self! !

!Character methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Answer the receiver, because Characters are unique."
	^self! !

!Character methodsFor: 'converting' stamp: ''!
asHTMLString
	"substitute the < & > into HTML compliant elements"
	
	#($< '&lt;' $> '&gt;' $& '&amp;') pairsDo: [:k :v |
		self = k ifTrue: [^ v]].
	^ String with: self! !

!Character methodsFor: 'testing' stamp: ''!
isSpacingCombiningMark
^ self characterSet isSpacingCombiningMark: self! !

!Character methodsFor: 'testing' stamp: ''!
isLowercase

	^ self characterSet isLowercase: self! !

!Character methodsFor: 'accessing' stamp: ''!
charCode
	^ self asInteger bitAnd: 4194303! !

!Character methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
meta
	^ KMModifier meta + self! !

!Character methodsFor: 'converting' stamp: ''!
asCharacter
	"Answer the receiver itself."

	^ self! !

!Character methodsFor: 'testing' stamp: ''!
isNonspacingMark
^ self characterSet isNonspacingMark: self! !

!Character methodsFor: 'converting' stamp: ''!
asLowercase
	"If the receiver is uppercase, answer its matching lowercase Character."
	^ self characterSet toLowercase: self! !

!Character methodsFor: 'testing' stamp: ''!
isControlOther
	"Return whether the receiver is one of these characters: backspace, delete, escape, arrowUp, arrowLeft, arrowDown, arrowRight, pageUp, pageDown, end, home, nbsp, insert"
	"Character delete isControlOther >>> true"
	"Character backspace isControlOther >>> true"
	"Character space isControlOther >>> false"
	"Character home isControlOther >>> true"
	"Character pageUp isControlOther >>> true"
	"Character arrowDown isControlOther >>> true"
	"Character end isControlOther >>> true"
	
	"$) isControlOther >>> false"
	"$> isControlOther >>> false"
	"$} isControlOther >>> false"
	
	^ self characterSet isControlOther: self! !

!Character class methodsFor: 'private' stamp: ''!
constantNames
	"Added the rest of them!!"
	
	^#(backspace cr delete escape lf newPage space tab
		arrowDown arrowLeft arrowRight arrowUp
		enter end home insert nbsp pageDown pageUp null)! !

!Character class methodsFor: 'instance creation' stamp: ''!
value: anInteger
	"Answer the Character whose value is anInteger."
	<primitive: 170>
	^self primitiveFailed! !

!Character class methodsFor: 'instance creation' stamp: ''!
new
	"Creating new characters is not allowed."

	self error: 'cannot create new characters'! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
arrowDown
	^ self value: 31! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
lf
	"Answer the Character representing a linefeed."

	^self value: 10! !

!Character class methodsFor: 'instance creation' stamp: ''!
digitValue: x 
	"Answer the Character whose digit value is x. For example,
	 answer $9 for x=9, $0 for x=0, $A for x=10, $Z for x=35."

	| n |
	n := x asInteger.
	^self value: (n < 10 ifTrue: [n + 48] ifFalse: [n + 55])! !

!Character class methodsFor: 'special characters' stamp: ''!
centeredDot
	^self codePoint: 183! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
pageUp
	^ self value: 11! !

!Character class methodsFor: 'special characters' stamp: ''!
times
	^self codePoint: 215! !

!Character class methodsFor: '*Fuel-Core' stamp: ''!
materializeFrom: aDecoder

	^self value: aDecoder nextEncodedUint32! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
arrowLeft
	^ self value: 28! !

!Character class methodsFor: 'initialization' stamp: ''!
characterSet: aCharSet
	^ CharSet := aCharSet! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
linefeed
	"Answer the Character representing a linefeed."

	^self value: 10! !

!Character class methodsFor: '*Deprecated90' stamp: ''!
leadingChar: leadChar code: code

	code >= 16r400000 ifTrue: [
		self error: 'code is out of range'.
	].
	leadChar >= 256 ifTrue: [
		self error: 'lead is out of range'.
	].
	code < 256 ifTrue: [ ^self value: code ].
	^self value: (leadChar bitShift: 22) + code! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
tab
	"Answer the Character representing a tab."

	^self value: 9! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
arrowUp
	^ self value: 30! !

!Character class methodsFor: 'instance creation' stamp: ''!
allByteCharacters
	"Answer all the characters that can be encoded in a byte"
	
	^ (0 to: 255) collect: [:v | Character value: v] as: String! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
nbsp
	"non-breakable space. Latin1 encoding common usage."

	^ Character value: 160! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
pageDown
	^ self value: 12! !

!Character class methodsFor: 'initialization' stamp: ''!
characterSet
	^ CharSet ifNil: [ AsciiCharset ]! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
home
	^ self value: 1! !

!Character class methodsFor: 'initialization' stamp: ''!
initializeDigitValues
	"Initialize the well known digit value of ascii characters.
	Note that the DigitValues table is 1-based while ascii values are 0-based, thus the offset+1."
	DigitValues := Array new: 256 withAll: -1.
	"the digits"
	0 to: 9 do: [:i | DigitValues at: 48 + i + 1 put: i].
	 "the uppercase letters"
	10 to: 35 do: [:i | DigitValues at: 55 + i + 1 put: i].
	"the lowercase letters"
	10 to: 35 do: [:i | DigitValues at: 87 + i + 1 put: i]! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
escape
	"Answer the ASCII ESC character"

	^self value: 27! !

!Character class methodsFor: 'instance creation' stamp: ''!
allCharacters
	"This name is obsolete since only the characters that will fit in a byte can be queried"
	
	^self allByteCharacters! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
delete
	^ self value: 127! !

!Character class methodsFor: 'queries' stamp: ''!
supportsNonASCII

	^ (self environment includesKey: #Unicode) and: [ 
		((self environment  at: #EncodedCharSet) charsetAt: 255) name = #Unicode ]! !

!Character class methodsFor: 'initialization' stamp: ''!
initialize
	"Create the DigitsValues table."
 
	self initializeDigitValues! !

!Character class methodsFor: 'special characters' stamp: ''!
divide
	^self codePoint: 247! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
null
	^ self value: 0! !

!Character class methodsFor: 'special characters' stamp: ''!
plusOrMinus
	^self codePoint: 177! !

!Character class methodsFor: '*SUnit-Core' stamp: ''!
specialCharacterNames
	^ Dictionary newFrom: { 
		$+ -> 'plus'.
		$- -> 'minus'.
		$/ -> 'slash'.
		$\ -> 'backslash'.
		$* -> 'star'.
		$~ -> 'tilda'.
		$< -> 'less than'.
		$> -> 'greater-than'.
		$= -> 'equals-sign'.
		$@ -> 'at sign'.
		$, -> 'comma'.
		$% -> 'percent sign'.
		$| -> 'pipe'.
		$& -> 'ampersand'.
		$? -> 'question mark'.
		$!! -> 'exclamation mark'.
		self centeredDot -> 'centered dot'.
		self divide -> 'divide'.
		self plusOrMinus -> 'plus-minus'.
		self times -> 'times' }! !

!Character class methodsFor: 'instance creation' stamp: ''!
codePoint: anInteger 
	"Just for ANSI Compliance"	
		
	^self value: anInteger! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
space
	"Answer the Character representing a space."

	^self value: 32! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
newPage
	"Answer the Character representing a form feed."

	^self value: 12! !

!Character class methodsFor: 'private' stamp: ''!
constantNameFor: aCharacter
	^ self constantNames
		detect: [ :each | (self perform: each) = aCharacter ]
		ifNone: [ nil ].! !

!Character class methodsFor: '*Multilingual-Encodings' stamp: ''!
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: ''!
insert
	^ self value: 5! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
arrowRight
	^ self value: 29! !

!Character class methodsFor: 'constants' stamp: ''!
alphabet
	"($a to: $z) as: String"

	^ 'abcdefghijklmnopqrstuvwxyz' copy! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
enter
	"Answer the Character representing enter."

	^self value: 3! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
backspace
	"Answer the Character representing a backspace."

	^self value: 8! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
end
	^ self value: 4! !

!Character class methodsFor: 'constants' stamp: ''!
maxVal
	"Answer the maximum value (code point) for a Character."

	^ (2 ** 30) - 1! !

!Character class methodsFor: 'instance creation' stamp: ''!
separators
	"Answer a collection of the standard ASCII separator characters as string."

	^ #(32 "space"
		 13 "cr"
		  9 "tab"
		 10 "line feed"
		 12 "form feed")
		collect: [:v | Character value: v] as: String! !

!Character class methodsFor: 'special characters' stamp: ''!
specialCharacters
	^ '+-/\*~<>=@,%|&?!!' , (String
		   with: self centeredDot
		   with: self divide
		   with: self plusOrMinus
		   with: self times)! !

!Character class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	^ stonReader parseListSingleton first! !

!Character class methodsFor: 'accessing untypeable characters' stamp: ''!
cr
	"Answer the Character representing a carriage return."

	^self value: 13! !

!CharacterBlock commentStamp: ''!
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: 'comparing' stamp: ''!
max: aCharacterBlock
	aCharacterBlock ifNil:[^self].
	^aCharacterBlock > self
		ifTrue:[ aCharacterBlock]
		ifFalse:[self].! !

!CharacterBlock methodsFor: 'comparing' stamp: ''!
< aCharacterBlock 
	"Answer whether the string index of the receiver precedes that of 
	aCharacterBlock."

	^stringIndex < aCharacterBlock stringIndex! !

!CharacterBlock methodsFor: 'comparing' stamp: ''!
= aCharacterBlock

	^self species = aCharacterBlock species
		ifTrue: [ stringIndex = aCharacterBlock stringIndex]
		ifFalse: [ false]! !

!CharacterBlock methodsFor: 'comparing' stamp: ''!
>= aCharacterBlock 
	"Answer whether the string index of the receiver does not precede that of 
	aCharacterBlock."

	^(self < aCharacterBlock) not! !

!CharacterBlock methodsFor: 'accessing' stamp: ''!
stringIndex
	"Answer the position of the receiver in the string it indexes."

	^stringIndex! !

!CharacterBlock methodsFor: 'private' stamp: ''!
stringIndex: anInteger text: aText topLeft: topLeft extent: extent 
	stringIndex := anInteger.
	text := aText.
	super 
		setPoint: topLeft
		point: topLeft + extent! !

!CharacterBlock methodsFor: 'accessing' stamp: ''!
textLine: aLine 
	textLine := aLine! !

!CharacterBlock methodsFor: 'private' stamp: ''!
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: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: 'a CharacterBlock with index '.
	stringIndex printOn: aStream.
	(text notNil and: [text notEmpty and: [ stringIndex between: 1 and: text size ]])
		ifTrue: [aStream nextPutAll: ' and character '.
				(text at: stringIndex) printOn: aStream].
	aStream nextPutAll: ' and rectangle '.
	super printOn: aStream.
	textLine ifNotNil: [aStream cr; nextPutAll: ' in '.
				textLine printOn: aStream].
! !

!CharacterBlock methodsFor: 'comparing' stamp: ''!
min: aCharacterBlock
	aCharacterBlock ifNil:[^self].
	^aCharacterBlock < self
		ifTrue:[ aCharacterBlock]
		ifFalse:[self].! !

!CharacterBlock methodsFor: 'comparing' stamp: ''!
> aCharacterBlock 
	"Answer whether the string index of the receiver comes after that of 
	aCharacterBlock."

	^aCharacterBlock < self! !

!CharacterBlock methodsFor: 'accessing' stamp: ''!
textLine
	^ textLine! !

!CharacterBlock methodsFor: 'comparing' stamp: ''!
<= aCharacterBlock 
	"Answer whether the string index of the receiver does not come after that 
	of aCharacterBlock."

	^(self > aCharacterBlock) not! !

!CharacterBlockScanner commentStamp: ''!
A CharacterScanner does scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location. The CharacterBlock stores information both about character layout and character index in the text.

This class is essential for selecting text with the mouse or with arrow keys.

Instance Variables
	characterIndex:		<Integer | nil>
	characterPoint:		<Point>
	lastCharacterWidth:		<Number | nil>
	nextLeftMargin:		<Number>
	specialWidth:		<Number | nil>

characterIndex
	- the index of character for which the layout information is searched, or nil when the layout is searched by cursor location

characterPoint
	- the cursor location for which nearest character index and layout are searched.

lastCharacterWidth
	- a number indicating the width of last character being processed.
	Note that this variable is left to nil during the inner scan loop, and only set on stopConditions.

nextLeftMargin
	- a number specifying the distance between left of composition zone and left of first character for the next line.

specialWidth
	- a number holding the width of an embedded object if any, or nil if none.
!
!CharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
paddedSpace
	"When the line is justified, the spaces will not be the same as the font's 
	space character. A padding of extra space must be considered in trying 
	to find which character the cursor is pointing at. Answer whether the 
	scanning has crossed the cursor."

	| pad |
	spaceCount := spaceCount + 1.
	pad := line justifiedPadFor: spaceCount font: font.
	lastCharacterWidth := spaceWidth + pad.
	(destX + lastCharacterWidth)  >= characterPoint x
		ifTrue:
			[^self crossedX].
	lastIndex := lastIndex + 1.
	destX := destX + lastCharacterWidth + kern.
	pendingKernX := 0.
	^ false
! !

!CharacterBlockScanner methodsFor: 'private' stamp: ''!
retrieveLastCharacterWidth
	| lastCharacter |
	lastIndex > text size ifTrue: [^lastCharacterWidth := 0].
	specialWidth ifNotNil: [^lastCharacterWidth := specialWidth].
	lastCharacter := text at: lastIndex.
	(lastCharacter charCode >= 256 or: [(stopConditions at: lastCharacter charCode + 1) isNil])
		ifTrue: [lastCharacterWidth := font widthOf: (text at: lastIndex)].
	"if last character was a stop condition, then the width is already set"
	^lastCharacterWidth! !

!CharacterBlockScanner methodsFor: 'private' stamp: ''!
placeEmbeddedObject: anchoredMorph
	"Workaround: The following should really use #textAnchorType"
	| w |
	anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
	w := anchoredMorph width.
	specialWidth := w.
	(destX + w > characterPoint x) ifTrue: [^false].
	destX := destX + w + kern.
	^ true! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
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: [lastIndex ~= characterIndex])])
		ifTrue:	["We're really at the end of a real run."
				runLength := text runLengthFor: (lastIndex := lastIndex + 1).
				lineStop := characterIndex	"scanning for index"
						ifNil: [line last].		"scanning for point".
				(runStopIndex := lastIndex + (runLength - 1)) > lineStop
					ifTrue: [runStopIndex := lineStop].
				self setStopConditions.
				^false].

	self retrieveLastCharacterWidth.
		
	(characterIndex == nil and: [lastIndex = line last])
		ifTrue: [characterPoint x > (destX + (lastCharacterWidth // 2))
			ifTrue:
				[ "Correct for clicking right half of last character in line
				means selecting AFTER the char"
				lastIndex := lastIndex + 1.
				lastCharacterWidth := 0.
				characterPoint := destX + lastCharacterWidth @ destY.
				^true]].

	characterPoint := destX @ destY.
	characterIndex ~~ nil
		ifTrue:	["If scanning for an index and we've stopped on that index,
				then we back destX off by the width of the character stopped on
				(it will be pointing at the right side of the character) and return"
				runStopIndex = characterIndex
					ifTrue:	[characterPoint := destX - lastCharacterWidth @ destY.
							^true].
				"Otherwise the requested index was greater than the length of the
				string.  Return string size + 1 as index, indicate further that off the
				string by setting character to nil and the extent to 0."
				lastIndex :=  lastIndex + 1.
				lastCharacterWidth := 0.
				^true].

	"Scanning for a point and either off the end of the line or off the end of the string."
	runStopIndex = text size
		ifTrue:	["off end of string"
				lastIndex :=  lastIndex + 1.
				lastCharacterWidth := 0.
				^true].
	"just off end of line without crossing x"
	lastIndex := lastIndex + 1.
	^true! !

!CharacterBlockScanner methodsFor: 'text attributes' stamp: ''!
indentationLevel: anInteger
	super indentationLevel: anInteger.
	nextLeftMargin := leftMargin.
	indentationLevel timesRepeat: [
		nextLeftMargin := textStyle nextTabXFrom: nextLeftMargin
					leftMargin: leftMargin
					rightMargin: rightMargin]! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
tab
	| nextDestX |
	nextDestX := self plainTab.
	lastCharacterWidth := nextDestX - destX max: 0.
	nextDestX >= characterPoint x
		ifTrue: 
			[^ self crossedX].
	destX := nextDestX.
	lastIndex := lastIndex + 1.
	^false! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
setFont
	specialWidth := nil.
	super setFont! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: ''!
characterBlockAtPoint: aPoint index: index in: textLine
	"This method is the Morphic characterBlock finder.  It combines
	MVC's characterBlockAtPoint:, -ForIndex:, and buildCharacterBlockIn:"

	| runLength lineStop stopCondition |
	line := textLine.
	rightMargin := line rightMargin.
	lastIndex := line first.
	self setStopConditions.	"also sets font"
	characterIndex := index.	" == nil means scanning for point"
	characterPoint := aPoint.
	(characterPoint isNil or: [ characterPoint y > line bottom ]) ifTrue: [ characterPoint := line bottomRight ].
	destX := leftMargin := line leftMarginForAlignment: alignment.
	destY := line top.
	(text isEmpty or: [ (characterPoint y < destY or: [ characterPoint x < destX ]) or: [ characterIndex notNil and: [ characterIndex < line first ] ] ])
		ifTrue: [ ^ (CharacterBlock new
				stringIndex: line first
				text: text
				topLeft: destX @ destY
				extent: 0 @ textStyle lineGrid) textLine: line ].
	runLength := text runLengthFor: line first.
	lineStop := characterIndex ifNil: [ line last ].	"scanning for index"	"scanning for point"
	runStopIndex := lastIndex + (runLength - 1) min: lineStop.
	lastCharacterWidth := 0.
	spaceCount := 0.

	[ stopCondition := self
		scanCharactersFrom: lastIndex
		to: runStopIndex
		in: text string
		rightX: characterPoint x.
	"see setStopConditions for stopping conditions for character block operations."
	self perform: stopCondition ] whileFalse.
	^ characterIndex
		ifNil: [ "Result for characterBlockAtPoint: "
			(CharacterBlock new
				stringIndex: lastIndex
				text: text
				topLeft: characterPoint + (font descentKern @ 0)
				extent: lastCharacterWidth @ line lineHeight - (font baseKern @ 0)) textLine: line ]
		ifNotNil: [ "Result for characterBlockForIndex: "
			(CharacterBlock new
				stringIndex: characterIndex
				text: text
				topLeft: characterPoint + ((font descentKern - kern) @ 0)
				extent: lastCharacterWidth @ line lineHeight) textLine: line ]! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
crossedX
	"Text display has wrapping. The scanner just found a character past the x 
	location of the cursor. We know that the cursor is pointing at a character 
	or before one."

	self retrieveLastCharacterWidth.
	
	characterPoint x <= (destX + (lastCharacterWidth // 2))
		ifTrue:	[characterPoint := destX @ destY.
				^true].
	lastIndex >= line last 
		ifTrue:	[characterPoint := destX @ destY.
				^true].

	"Pointing past middle of a character, return the next character."
	lastIndex := lastIndex + 1.
	characterPoint := destX + lastCharacterWidth + kern @ destY.
	^ true! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
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 notNil
		and: [characterIndex > text size])
			or: [(line last = text size)
				and: [(destY + line lineHeight) < characterPoint y]])
		ifTrue:	["When off end of string, give data for next character"
				destY := destY +  line lineHeight.
				characterPoint := (nextLeftMargin ifNil: [leftMargin]) @ destY.
				lastIndex := (lastIndex < text size and: [(text at: lastIndex) = CR and: [(text at: lastIndex+1) = Character lf]])
					ifTrue: [ lastIndex + 2]
					ifFalse: [ lastIndex + 1].
				lastCharacterWidth := 0.
				^ true].
		characterPoint := destX @ destY.
		lastCharacterWidth := rightMargin - destX.
		^true! !

!CharacterKeyCombinationTest methodsFor: 'tests' stamp: ''!
testUppercaseKeyCombination
	| combination |
	combination := $A asKeyCombination.
	self assert: combination key equals: KeyboardKey A.
	self assert: combination modifier equals: KMModifier shift.! !

!CharacterKeyCombinationTest methodsFor: 'tests' stamp: ''!
testLowercaseKeyCombination
	| combination |
	combination := $a asKeyCombination.
	self assert: combination key equals: KeyboardKey A.
	self assert: combination modifier equals: KMNoModifier new.! !

!CharacterScanner commentStamp: ''!
A CharacterScanner holds the state associated with scanning text. Subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.

Instance Variables
	alignment:		<Integer>
	destX:		<Number>
	destY:		<Number>
	emphasisCode:		<Object>
	font:		<AbstractFont>
	indentationLevel:		<Integer>
	kern:		<Number>
	lastIndex:		<Integer>
	leftMargin:		<Number>
	line:		<TextLine>
	map:		<Array>
	pendingKernX:		<Number>
	rightMargin:		<Number>
	runStopIndex:		<Integer>
	spaceCount:		<Integer>
	spaceWidth:		<Number>
	stopConditions:		<Array>
	text:		<Text>
	textStyle:		<TextStyle>
	wantsColumnBreaks:		<Boolean>
	xTable:		<Array>

alignment
	- an Integer encoding the alignment of text

destX
	- horizontal position for next character (distance from left of composition area)

destY
	- vertical position for next character (distance from top of composition area)

emphasisCode
	- an Integer encoding the current text emphasis to use (bold, italic, ...)

font
	- the current font used for measuring/composing/displaying characters

indentationLevel
	- an Integer specifying a number of leading tabs to be inserted at beginning of new lines

kern
	- a Number specifying additional horizontal spacing to place between characters (spacing is reduced when kern is negative)

lastIndex
	- the Integer index of next character to be processed in the text

leftMargin
	- a Number specifying the distance between left of composition zone and left of first character in the line.

line
	- an object holding information about the line currently being displayed (like first and last index in text).
	Note: this is either a TextLine in Morphic, or TextLineInterval for ST80 compatibility

map
	- an array mapping character code to glyph position.
	This is used by primitive 103 only, in case of ByteString.

pendingKernX
	- a Number to be added to horizontal spacing of next char if ever it is in the same font than previous one.
	The inner scan loop is interrupted by a change of text run.
	But some changes won't change the font, so the kerning must be remembered and applied later.

rightMargin
	- a Number specifying the distance between right of composition zone and right of last character in the line.

runStopIndex
	- the Integer index of last character in current text run.

spaceCount
	- the number of spaces encoutered so far in current line. This is useful for adjusting the spacing in cas of Justified alignment.

spaceWidth
	- the width of space character in current font.

stopConditions
	- an Array mapping a table of characters codes for which special actions are to be taken.
	These are typically control characters like carriage return or horizontal tab.

text
	- the text to be measured/composed/displayed

textStyle
	- an object holding a context for the text style (which set of font to use, which margins, etc...)

wantsColumnBreaks
	- a Boolean indicating whether some special handling for multiple columns is requested.
	THIS ONLY MAKES SENSE IN CompositionScanner AND SHOULD BE MOVED TO THE SUBCLASS
	
xTable
	- an array mapping character code to glyph x coordinate in form.
	This is used by primitive 103 only, in case of ByteString.
	
Implementation note: accelerated Character scanning with primitive 103 requires following order for 5 first instance variables, please don't alter:
destX lastIndex xTable map destY
!
!CharacterScanner methodsFor: 'stop conditions' stamp: ''!
handleEndOfRunAt: stopIndex
	" make sure the lastIndex is set to stopIndex and then return the stopCondition for endOfRun; important for  a couple of outside users"

	lastIndex := stopIndex.
	^#endOfRun! !

!CharacterScanner methodsFor: 'scanning' stamp: ''!
basicScanByteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX 
"this is a scanning method for
single byte characters in a ByteString
a font that does not do character-pair kerning"
	| ascii nextDestX char |
	lastIndex := startIndex.
	[lastIndex <= stopIndex]
		whileTrue: [
			"get the character value"
			char := sourceString at: lastIndex.
			ascii := char asciiValue + 1.
			"if there is an entry in 'stops' for this value, return it"
			(stopConditions at: ascii)
				ifNotNil: [^ stopConditions at: ascii].
			"bump nextDestX by the width of the current character"
			nextDestX := destX + (font widthOf: char).
			"if the next x is past the right edge, return crossedX"
			nextDestX > rightX
				ifTrue: [^#crossedX].
			"update destX and incorporate thr kernDelta"
			destX := nextDestX + kern.
			lastIndex := lastIndex + 1].
	^self handleEndOfRunAt: stopIndex

! !

!CharacterScanner methodsFor: 'scanning' stamp: ''!
measureString: aString inFont: aFont from: startIndex to: stopIndex
	"Measure aString width in given font aFont.
	The string shall not include line breaking, tab or other control character."
	destX := destY := lastIndex := 0.
	pendingKernX := 0.
	font := aFont.
	kern := 0 - font baseKern.
	spaceWidth := font widthOf: Space.
	stopConditions := MeasuringStopConditions.
	self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999.
	^destX! !

!CharacterScanner methodsFor: 'private' stamp: ''!
placeEmbeddedObject: anchoredMorph
	"Place the anchoredMorph or return false if it cannot be placed"
	^ true! !

!CharacterScanner methodsFor: 'scanning' stamp: ''!
scanMultibyteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX 
"this is a scanning method for
multibyte characters in a WideString
a font that does not do character-pair kerning"
	| char ascii nextDestX |
	lastIndex := startIndex.
	[lastIndex <= stopIndex] whileTrue: [
		char := sourceString at: lastIndex.
		ascii := char charCode.
		(ascii < 256 and: [(stopConditions at: ascii + 1) ~~ nil])
			ifTrue: [^ stopConditions at: ascii + 1].
		"bump nextDestX by the width of the current character"
		nextDestX := destX + (font widthOf: char).
		nextDestX > rightX ifTrue: [^#crossedX].
		destX := nextDestX + kern .
		lastIndex := lastIndex + 1.
	].
	^self handleEndOfRunAt: stopIndex! !

!CharacterScanner methodsFor: 'private' stamp: ''!
text: t textStyle: ts
	text := t.
	textStyle := ts! !

!CharacterScanner methodsFor: 'scanning' stamp: ''!
scanKernableMultibyteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX 
"this is a scanning method for
multibyte characters in a WideString
a font that does do character-pair kerning via widthAndKernedWidthOfLeft:right:into:"

	| ascii nextDestX floatDestX widthAndKernedWidth nextChar atEndOfRun char |
	lastIndex := startIndex.
	lastIndex > stopIndex ifTrue: [^self handleEndOfRunAt: stopIndex].
	floatDestX := destX.
	widthAndKernedWidth := Array new: 2.
	atEndOfRun := false.
	[lastIndex <= stopIndex] whileTrue: [
		char := sourceString at: lastIndex.
		ascii := char charCode.
		(ascii < 256 and: [(stopConditions at: ascii + 1) ~~ nil])
			ifTrue: [^ stopConditions at: ascii + 1].
		nextChar := (lastIndex + 1 <= stopIndex) 
			ifTrue:[sourceString at: lastIndex + 1]
			ifFalse:[
				atEndOfRun := true.
				"if there is a next char in sourceString, then get the kern 
				and store it in pendingKernX"
				lastIndex + 1 <= sourceString size
					ifTrue:[sourceString at: lastIndex + 1]
					ifFalse:[	nil]].
		font 
			widthAndKernedWidthOfLeft: char 
			right: nextChar
			into: widthAndKernedWidth.
		nextDestX := floatDestX + (widthAndKernedWidth at: 1).
		nextDestX > rightX ifTrue: [^#crossedX].
		floatDestX := floatDestX + kern + (widthAndKernedWidth at: 2).
		atEndOfRun 
			ifTrue:[
				pendingKernX := (widthAndKernedWidth at: 2) - (widthAndKernedWidth at: 1).
				floatDestX := floatDestX - pendingKernX].
		destX := floatDestX .
		lastIndex := lastIndex + 1.
	].
	^self handleEndOfRunAt: stopIndex! !

!CharacterScanner methodsFor: 'scanning' stamp: ''!
scanByteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX 
"this is a scanning method for
single byte characters in a ByteString
a font that does not do character-pair kerning"

	^ self basicScanByteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX.
! !

!CharacterScanner methodsFor: 'stop conditions' stamp: ''!
embeddedObject
	pendingKernX := 0.
	text attributesAt: lastIndex do:[:attr| 
		attr anchoredMorph ifNotNil:[
			"Try to placeEmbeddedObject: - if it answers false, then there's no place left"
			(self placeEmbeddedObject: attr anchoredMorph) ifFalse:[^self crossedX]]].
	"Note: if ever several objects are embedded on same character, only indent lastIndex once"
	lastIndex := lastIndex + 1.
	^false! !

!CharacterScanner methodsFor: 'private' stamp: ''!
plainTab
	"This is the basic method of adjusting destX for a tab.
	Answer the next destX"
	pendingKernX := 0.
	^(alignment = Justified and: [self leadingTab not])
		ifTrue:		"embedded tabs in justified text are weird"
			[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse: 
			[textStyle nextTabXFrom: destX
				leftMargin: leftMargin
				rightMargin: rightMargin].! !

!CharacterScanner methodsFor: 'text attributes' stamp: ''!
setActualFont: aFont
	"Set the basal font to an isolated font reference."

	xTable := aFont xTable.
	map := aFont characterToGlyphMap.
	font := aFont.! !

!CharacterScanner methodsFor: 'private' stamp: ''!
setFont
	| priorFont |
	"Set the font and other emphasis."
	priorFont := font.
	text ifNotNil:[
		emphasisCode := 0.
		kern := 0.
		indentationLevel := 0.
		alignment := textStyle alignment.
		font := nil.
		(text attributesAt: lastIndex forStyle: textStyle)
			do: [:att | att emphasizeScanner: self]].
	font ifNil: [self setFont: textStyle defaultFontIndex].
	self setActualFont: (font emphasized: emphasisCode).
	priorFont 
		ifNotNil: [
			font = priorFont 
				ifTrue:[
					"font is the same, perhaps the color has changed?
					We still want kerning between chars of the same
					font, but of different color. So add any pending kern to destX"
					destX := destX + (pendingKernX ifNil:[0])].
			destX := destX + priorFont descentKern].
	pendingKernX := 0. "clear any pending kern so there is no danger of it being added twice"
	destX := destX - font descentKern.
	"NOTE: next statement should be removed when clipping works"
	leftMargin ifNotNil: [destX := destX max: leftMargin].
	kern := kern - font baseKern.

	"Install various parameters from the font."
	spaceWidth := font widthOf: Space.! !

!CharacterScanner methodsFor: 'scanning' stamp: ''!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 
	^sourceString scanCharactersFrom: startIndex to: stopIndex with: self rightX: rightX font: font! !

!CharacterScanner methodsFor: 'stop conditions' stamp: ''!
columnBreak

	pendingKernX := 0.
	^true! !

!CharacterScanner methodsFor: 'text attributes' stamp: ''!
setAlignment: style
	alignment := style.
	! !

!CharacterScanner methodsFor: 'text attributes' stamp: ''!
addKern: kernDelta
	"Set the current kern amount."
	kern := kern + kernDelta! !

!CharacterScanner methodsFor: 'initialization' stamp: ''!
initialize
	destX := destY := leftMargin := 0.! !

!CharacterScanner methodsFor: 'text attributes' stamp: ''!
textColor: ignored
	"Overridden in DisplayScanner"! !

!CharacterScanner methodsFor: 'private' stamp: ''!
advanceIfFirstCharOfLine
	lastIndex = line first
		ifTrue:
			[destX := destX + pendingKernX + (font widthOf: (text at: line first)).
			lastIndex := lastIndex + 1.
			pendingKernX := 0].! !

!CharacterScanner methodsFor: 'private' stamp: ''!
handleIndentation
	self indentationLevel timesRepeat: [
		destX := self plainTab]! !

!CharacterScanner methodsFor: 'private' stamp: ''!
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: 'private' stamp: ''!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	stopConditions := alignment = Justified
		ifTrue: [PaddedSpaceCondition]
		ifFalse: [DefaultStopConditions]! !

!CharacterScanner methodsFor: 'text attributes' stamp: ''!
indentationLevel: anInteger
	"set the number of tabs to put at the beginning of each line"
	indentationLevel := anInteger! !

!CharacterScanner methodsFor: 'scanning' stamp: ''!
scanKernableByteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX 
"this is a scanning method for
single byte characters in a ByteString
a font that does do character-pair kerning via widthAndKernedWidthOfLeft:right:into:"
	| ascii nextDestX char floatDestX widthAndKernedWidth nextCharOrNil atEndOfRun |
	lastIndex := startIndex.
	floatDestX := destX.
	widthAndKernedWidth := Array new: 2.
	atEndOfRun := false.
	[lastIndex <= stopIndex]
		whileTrue: [
			"get the character value"
			char := sourceString at: lastIndex.
			ascii := char asciiValue + 1.
			"if there is an entry in 'stops' for this value, return it"
			(stopConditions at: ascii)
				ifNotNil: [^ stopConditions at: ascii].
			"get the next character..."
			nextCharOrNil := lastIndex + 1 <= stopIndex
						ifTrue: [sourceString at: lastIndex + 1]
						ifFalse: ["if we're at or past the stopIndex, see if there is anything in the full string"
							atEndOfRun := true.
							lastIndex + 1 <= sourceString size
								ifTrue: [sourceString at: lastIndex + 1]].
			"get the font's kerning info for the pair of current character and next character"
			"for almost all fonts in common use this is a waste of time since they don't support pair kerning and both values are #widthOf: char"
			font
				widthAndKernedWidthOfLeft: char
				right: nextCharOrNil
				into: widthAndKernedWidth.
			"bump nextDestX by the width of the current character"
			nextDestX := floatDestX
						+ (widthAndKernedWidth at: 1).
			"if the next x is past the right edge, return crossedX"
			nextDestX > rightX
				ifTrue: [^ #crossedX].
			"bump floatDestX by the *kerned* width of the current
			character, which is where the *next* char will go"
			floatDestX := floatDestX + kern
						+ (widthAndKernedWidth at: 2).
			"if we are at the end of this run we keep track of the
			character-kern-delta for possible later use and then rather
			insanely remove that character-kern-delta from floatDestX,
			making it equivalent to (old floatDestX) + kernDelta +
			width-of-character - no idea why"
			atEndOfRun
				ifTrue: [pendingKernX := (widthAndKernedWidth at: 2)
								- (widthAndKernedWidth at: 1).
					floatDestX := floatDestX - pendingKernX].
			"save the next x for next time around the loop"
			destX := floatDestX.
			lastIndex := lastIndex + 1].
	^self handleEndOfRunAt: stopIndex
! !

!CharacterScanner methodsFor: 'private' stamp: ''!
indentationLevel
	"return the number of tabs that are currently being placed at the beginning of each line"
	^indentationLevel ifNil:[0]! !

!CharacterScanner methodsFor: 'scanning' stamp: ''!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX 
	^sourceString scanCharactersFrom: startIndex to: stopIndex with: self rightX: rightX font: font! !

!CharacterScanner methodsFor: 'text attributes' stamp: ''!
addEmphasis: code
	"Set the bold-ital-under-strike emphasis."
	emphasisCode := emphasisCode bitOr: code! !

!CharacterScanner methodsFor: 'text attributes' stamp: ''!
setFont: fontNumber
	"Set the font by number from the textStyle."

	self setActualFont: (textStyle fontAt: fontNumber)! !

!CharacterScanner class methodsFor: 'class initialization' stamp: ''!
initialize
"
	CharacterScanner initialize
"
	| a |
	a := Array new: 258.
	a at: 1 + 1 put: #embeddedObject.
	a at: Tab asciiValue + 1 put: #tab.
	a at: CR asciiValue + 1 put: #cr.
	a at: Character lf asciiValue + 1 put: #cr.
	"Note: following two codes are used only by primitive 103 for accelerated Character scanning"
	a at: 257 put: #endOfRun.
	a at: 258 put: #crossedX.
	
	DefaultStopConditions := a copy.

	CompositionStopConditions := a copy.
	CompositionStopConditions at: Space asciiValue + 1 put: #space.
	ColumnBreakStopConditions := CompositionStopConditions copy.
	ColumnBreakStopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak.

	PaddedSpaceCondition := a copy.
	PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace.

	MeasuringStopConditions := (Array new: 258)
		at: 257 put: #endOfRun;
		at: 258 put: #crossedX;
		yourself! !

!CharacterSet commentStamp: ''!
A set of characters: 

- Lookups for inclusion are very fast.
- CharacterSet will automatically convert itself to a WideCharacterSet if a character with value > 255 is added.
- Tests for inclusion can be done on any Character value (up to Character maxVal).

See the package comments for a description of how each of the classes in Collections-Support-CharacterSets is used.!
!CharacterSet methodsFor: 'enumerating' stamp: ''!
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: 'comparing' stamp: ''!
= anObject
	^self species == anObject species and: [
		self byteArrayMap = anObject byteArrayMap ]! !

!CharacterSet methodsFor: 'adding' stamp: ''!
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: 'comparing' stamp: ''!
hash
	^self byteArrayMap hash! !

!CharacterSet methodsFor: 'converting' stamp: ''!
complement
	"return a character set containing precisely the characters the receiver does not"
	
	^CharacterSetComplement of: self copy! !

!CharacterSet methodsFor: 'testing' stamp: ''!
includes: aCharacter
	"Guard against wide characters"
	^aCharacter asciiValue >= 256
		ifTrue: [ false ]
		ifFalse: [ (map at: aCharacter asciiValue + 1) > 0 ]! !

!CharacterSet methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	map := ByteArray new: 256 withAll: 0.! !

!CharacterSet methodsFor: 'testing' stamp: ''!
hasWideCharacters
	^false! !

!CharacterSet methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	map := map copy! !

!CharacterSet methodsFor: 'removing' stamp: ''!
removeAll

	map atAllPut: 0! !

!CharacterSet methodsFor: 'converting' stamp: ''!
asString
	"Convert the receiver into a String"

	^String 
		new: self size 
		streamContents: 
			[ :s | self do: [ :ch | s nextPut: ch]].! !

!CharacterSet methodsFor: 'accessing' stamp: ''!
size
	^map sum! !

!CharacterSet methodsFor: 'private' stamp: ''!
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: 'enumerating' stamp: ''!
do: aBlock
	"evaluate aBlock with each character in the set"

	Character allByteCharacters do: [ :c |
		(self includes: c) ifTrue: [ aBlock value: c ] ]! !

!CharacterSet methodsFor: 'removing' stamp: ''!
remove: aCharacter
	aCharacter asciiValue >= 256
		ifFalse: ["Guard against wide characters"
			map at: aCharacter asciiValue + 1 put: 0].
	^aCharacter! !

!CharacterSet methodsFor: 'converting' stamp: ''!
byteComplement
	"return a character set containing precisely the single byte characters the receiver does not"
	
	| set |
	set := self class allCharacters.
	self do: [ :c | set remove: c ].
	^set! !

!CharacterSet methodsFor: 'private' stamp: ''!
wideCharacterMap
	"used for comparing with WideCharacterSet"
	
	| wide |
	wide := WideCharacterSet new.
	wide addAll: self.
	^wide wideCharacterMap! !

!CharacterSet methodsFor: 'removing' stamp: ''!
remove: aCharacter ifAbsent: aBlock
	(self includes: aCharacter) ifFalse: [^aBlock value].
	^self remove: aCharacter! !

!CharacterSet class methodsFor: 'instance creation' stamp: ''!
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: ''!
newFrom: aCollection
	| newCollection |
	newCollection := self new.
	newCollection addAll: aCollection.
	^newCollection! !

!CharacterSet class methodsFor: 'accessing' stamp: ''!
crlf
	CrLf ifNil: [CrLf := self with: Character cr with: Character lf].
	^CrLf! !

!CharacterSet class methodsFor: 'instance creation' stamp: ''!
nonSeparators
	"return a set containing everything but the whitespace characters"

	^self separators complement! !

!CharacterSet class methodsFor: 'instance creation' stamp: ''!
separators
	"return a set containing just the whitespace characters"

	| set |
	set := self empty.
	set addAll: Character separators.
	^set! !

!CharacterSetComplement commentStamp: ''!
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 for performance

instance variables:
	absent <CharacterSet> contains character that are not in the set (i.e. my complement)
	byteArrayMapCache <ByteArray | nil> cache this information because it has to be used in tight loops where efficiency matters!
!CharacterSetComplement methodsFor: 'initialization' stamp: ''!
complement: aCharacterSet
	"initialize with the complement"
	
	byteArrayMapCache := nil.
	absent := aCharacterSet.! !

!CharacterSetComplement methodsFor: 'enumerating' stamp: ''!
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: 'comparing' stamp: ''!
= 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: 'adding' stamp: ''!
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: 'comparing' stamp: ''!
hash
	^absent hash bitXor: self class hash! !

!CharacterSetComplement methodsFor: 'converting' stamp: ''!
complement
	"return a character set containing precisely the characters the receiver does not"
	
	^absent copy! !

!CharacterSetComplement methodsFor: 'testing' stamp: ''!
includes: aCharacter
	^(absent includes: aCharacter) not! !

!CharacterSetComplement methodsFor: 'enumerating' stamp: ''!
select: aBlock
	"Implementation note: selecting present is rejecting absent"
	
	^(absent reject: aBlock) complement! !

!CharacterSetComplement methodsFor: 'testing' stamp: ''!
hasWideCharacters
	"This is a guess that absent is not holding each and every possible wideCharacter..."
	
	^true! !

!CharacterSetComplement methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	absent := absent copy! !

!CharacterSetComplement methodsFor: 'printing' stamp: ''!
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: 'removing' stamp: ''!
removeAll
	self becomeForward: CharacterSet new! !

!CharacterSetComplement methodsFor: 'accessing' stamp: ''!
size
	"The size is all characters minus those explicitly excluded"

	"Character values include 0, so we need to add 1."
	^Character maxVal + 1 - absent size! !

!CharacterSetComplement methodsFor: 'private' stamp: ''!
byteArrayMap
	"return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't.  Intended for use by primitives only"

	^byteArrayMapCache ifNil: [byteArrayMapCache := absent byteArrayMap collect: [:i | 1 - i]]! !

!CharacterSetComplement methodsFor: 'enumerating' stamp: ''!
do: aBlock
	"evaluate aBlock with each character in the set"

	0 to: self size - 1 do: [ :codePoint | | ch |
		ch := Character value: codePoint.
		(self includes: ch) ifTrue: [ aBlock value: ch ] ]! !

!CharacterSetComplement methodsFor: 'removing' stamp: ''!
remove: aCharacter
	"This means aCharacter is now absent from myself.
	It must be added to my absent."
	
	byteArrayMapCache := nil.
	^absent add: aCharacter! !

!CharacterSetComplement methodsFor: 'enumerating' stamp: ''!
reject: aBlock
	"Implementation note: rejecting present is selecting absent"
	
	^(absent select: aBlock) complement! !

!CharacterSetComplement methodsFor: 'printing' stamp: ''!
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: 'removing' stamp: ''!
remove: aCharacter ifAbsent: aBlock
	(self includes: aCharacter) ifFalse: [^aBlock value].
	^self remove: aCharacter! !

!CharacterSetComplement class methodsFor: 'instance creation' stamp: ''!
of: aCharacterSet
	"answer the complement of aCharacterSet"
	
	^ super new complement: aCharacterSet! !

!CharacterSetTest commentStamp: ''!
CharacterSetTest holds tests for CharacterSet!
!CharacterSetTest methodsFor: 'tests' stamp: ''!
testCopy
    | theOriginal theCopy |
    theOriginal := CharacterSet newFrom: 'abc'.
    theCopy := theOriginal copy.
    theCopy remove: $a.
    ^self should: [theOriginal includes: $a] description: 'Changing the copy should not change the original'.! !

!CharacterTest commentStamp: ''!
This is the unit test for the class Character. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- there is a chapter in the PharoByExample book (http://pharobyexample.org/)
	- the sunit class category!
!CharacterTest methodsFor: 'tests' stamp: ''!
testIsSeparator
    {Character space.
    Character cr.
    Character lf.
    Character newPage.
    Character tab} do: [ :each | self assert: each isSeparator ].
    Character alphabet do: [ :each | self deny: each isSeparator ]! !

!CharacterTest methodsFor: 'tests' stamp: ''!
testHex
	self assert: $a hex equals: '16r61'.
	self assert: Character space hex equals: '16r20'! !

!CharacterTest methodsFor: 'tests - various' stamp: ''!
testCharacterSeparators
	"Regression test"

	| result |
	result := '/' , Character separators.
	self assert: result size equals: Character separators size + 1! !

!CharacterTest methodsFor: 'tests' stamp: ''!
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 equals: value].
	
	'0123456789' with: #(0 1 2 3 4 5 6 7 8 9)
		do: [:char :value | self assert: char digitValue equals: value].! !

!CharacterTest methodsFor: 'tests' stamp: ''!
testPrintStringHex
	self assert: $a printStringHex equals: '61'.
	self assert: Character space printStringHex equals: '20'! !

!CharacterTest methodsFor: 'tests - conversion' stamp: ''!
testAsUppercaseBasicAsciiRange
	| lowercase uppercase |
	lowercase  := 'abcdefghijklmnopqrstuvwxyz123456789'.
	uppercase := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789'.
	lowercase withIndexDo: [ :char :index |
		self assert: char asUppercase equals: (uppercase at: index)]! !

!CharacterTest methodsFor: 'tests' stamp: ''!
testPrintStringAll
	Character allCharacters
		do: [ :each | self assert: (self class compiler evaluate: each printString) equals: each ]! !

!CharacterTest methodsFor: 'tests - instance creation' stamp: ''!
testInstanceCreation
	self should: [ Character value: -1 ] raise: Error.
	Character value: 0.
	Character value: 256! !

!CharacterTest methodsFor: 'tests' stamp: ''!
testCodePoint

	self assert: $A codePoint equals: 65.
	self assert: (Character codePoint: $a codePoint) equals: $a.
	self assert: (Character codePoint: 97) codePoint equals: 97.! !

!CharacterTest methodsFor: 'tests' stamp: ''!
testStoreStringAll
	Character allCharacters
		do: [ :each | self assert: (self class compiler evaluate: each storeString) equals: each ]! !

!CharacterTest methodsFor: 'tests' stamp: ''!
testMaxVal
	"Check that Character class>>maxVal is returning the correct value:
	- A character created with the value has the same code point
	- Attempting to create a character with maxVal+1 fails"

	self assert: (Character value: Character maxVal) codePoint 
			equals: Character maxVal.
	self should: [ Character value: Character maxVal + 1 ]
			raise: PrimitiveFailed! !

!CharacterTest methodsFor: 'tests' stamp: ''!
testStoreString
	self assert: $a storeString equals: '$a'.
	self assert: $5 storeString equals: '$5'.
	self assert: $@ storeString equals: '$@'.

	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: 'coverage' stamp: ''!
classToBeTested
	
	^ Character! !

!CharacterTest methodsFor: 'tests - conversion' stamp: ''!
testAsLowercaseBasicAsciiRange
	| lowercase uppercase |
	lowercase  := 'abcdefghijklmnopqrstuvwxyz123456789'.
	uppercase := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789'.
	uppercase withIndexDo: [ :char :index |
		self assert: char asLowercase equals: (lowercase at: index)]! !

!CharacterTest methodsFor: 'tests' stamp: ''!
testPrintString
	self assert: $a printString equals: '$a'.
	self assert: $5 printString equals: '$5'.
	self assert: $@ printString equals: '$@'.

	self assert: Character cr printString equals: 'Character cr'.
	self assert: Character lf printString equals: 'Character lf'.
	self assert: Character space printString equals: 'Character space'.

	self assert: (Character value: 0) printString equals: 'Character null'.
	self assert: (Character value: 17) printString equals: 'Character value: 17'.! !

!CharacterTest methodsFor: 'tests - instance creation' stamp: ''!
testNew

	self should: [Character new] raise: Error.! !

!CheckBoxPresenter commentStamp: ''!
A CheckBoẍPresenteris a spec presenter for Checkbox.
See AbstractFormButtonPresenter

self example

You can also have a look at CheckBoxExample for a full example of how to use them.

I provide the following methods
todo
- labelOnLeft and labelOnRight
- labelClickable!
!CheckBoxPresenter methodsFor: 'api' stamp: ''!
labelOnRight

	^ self changed: #labelOnRight with: #()! !

!CheckBoxPresenter methodsFor: 'api' stamp: ''!
labelOnLeft

	^ self changed: #labelOnLeft with: #()! !

!CheckBoxPresenter methodsFor: 'api' stamp: ''!
enabled: aBoolean
	"<api: #boolean getter: #enabled registration: #whenEnabledChanged:>"
	"Set if the checkbox is enabled (clickable)"

	super enabled: aBoolean.
	self changed: #enabled.
! !

!CheckBoxPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(CheckBoxAdapter
		adapt: #(model))! !

!CheckBoxPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #CheckBoxAdapter! !

!CheckBoxPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Checkbox Button'! !

!CheckboxButtonMorph commentStamp: ''!
Checkbox/radio - button only.!
!CheckboxButtonMorph methodsFor: 'private' stamp: ''!
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: 'drawing' stamp: ''!
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: 'accessing' stamp: ''!
isRadioButton: anObject
	"Set the value of isRadioButton"

	isRadioButton := anObject! !

!CheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
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: ''!
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: ''!
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: ''!
fillStyleToUse
	"Answer the fillStyle that should be used for the receiver."
	
	^self isRadioButton
		ifTrue: [self radioFillStyleToUse]
		ifFalse: [self checkboxFillStyleToUse]! !

!CheckboxButtonMorph methodsFor: 'protocol' stamp: ''!
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);
		fillStyle: self fillStyleToUse;
		borderStyle: self borderStyleToUse! !

!CheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
borderStyleToUse
	"Answer the borderStyle that should be used for the receiver."
	
	^self isRadioButton
		ifTrue: [self radioBorderStyleToUse]
		ifFalse: [self checkboxBorderStyleToUse]! !

!CheckboxButtonMorph methodsFor: 'protocol' stamp: ''!
beCheckbox
	"Change the images and square the border
	to be a checkbox."

	self
		isRadioButton: false;
		onImage: self theme checkboxMarkerForm;
		cornerStyle: (self theme checkboxCornerStyleFor: self);
		fillStyle: self fillStyleToUse;
		borderStyle: self borderStyleToUse! !

!CheckboxButtonMorph methodsFor: 'private' stamp: ''!
imageFromName: aSymbol
	^ self images
		at: aSymbol
		ifPresent: [:block | block value]
		ifAbsent: []! !

!CheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
selected
	"Answer the state taking account of the intermediate states."

	^self state == #repressed or: [self state == #on]! !

!CheckboxButtonMorph methodsFor: 'private' stamp: ''!
imageToUse
	"Answer the image we should use."

	^ self imageFromName: state! !

!CheckboxButtonMorph methodsFor: 'theme' stamp: ''!
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: 'enablement' stamp: ''!
toggleEnabled
	"Toggle the enabled state."

	self enabled: self enabled not! !

!CheckboxButtonMorph methodsFor: 'private' stamp: ''!
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: 'private' stamp: ''!
radioFillStyleToUse
	"Answer the fillStyle that should be used for the receiver when it is a radio button."
	
	^self selected
		ifTrue: [self enabled
			ifTrue: [self theme radioButtonSelectedFillStyleFor: self]
			ifFalse: [self theme radioButtonSelectedDisabledFillStyleFor: self]]
		ifFalse: [self enabled
			ifTrue: [self theme radioButtonNormalFillStyleFor: self]
			ifFalse: [self theme radioButtonDisabledFillStyleFor: self]]! !

!CheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
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: ''!
enabled: anObject
	"Set the value of enabled"

	enabled = anObject ifTrue: [^self].
	enabled := anObject.
	self changed: #enabled.
	self
		adoptPaneColor: self paneColor;
		changed! !

!CheckboxButtonMorph methodsFor: 'event handling' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"Draw the image for the current state."

	| img |
	anAthensCanvas setPaint: self fillStyle.
	anAthensCanvas drawShape: self bounds.
	anAthensCanvas setPaint: self borderStyle.
	anAthensCanvas drawShape: self bounds.
	img := self imageToUse.
	img
		ifNotNil: [ 
			anAthensCanvas setPaint: img.
			anAthensCanvas drawShape: (self innerBounds center - (img extent // 2) extent: img extent) ].
	((self state == #pressed or: [ self state == #repressed ]) and: [ image isNil ])
		ifTrue: [ 
			anAthensCanvas setPaint: (self paneColor alpha: 0.3).
			anAthensCanvas drawShape: self innerBounds ].
	(self enabled not and: [ self theme fadeCheckboxWhenDisabled ])
		ifTrue: [ 
			anAthensCanvas setPaint: (self paneColor alpha: 0.4).
			anAthensCanvas drawShape: self innerBounds ]! !

!CheckboxButtonMorph methodsFor: 'enablement' stamp: ''!
enabledString
	"Answer the string to be shown in a menu to represent the 'enabled' status"
	
	^ (self enabled) -> 'enabled' translated! !

!CheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
isRadioButton
	"Answer the value of isRadioButton"

	^ isRadioButton! !

!CheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
repressedImage
	"Answer the value of repressedImage"

	^ repressedImage! !

!CheckboxButtonMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		isRadioButton: false;
		enabled: true;
		onImage: self theme checkboxMarkerForm;
		fillStyle: self fillStyleToUse;
		borderStyle: self borderStyleToUse! !

!CheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
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: ''!
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: ''!
state: newState
	"Change the image and invalidate the rect."

	newState == state ifTrue: [^ self].
	state := newState.
	self
		adoptPaneColor: self paneColor;
		changed! !

!CheckboxButtonMorph methodsFor: 'protocol' stamp: ''!
disable
	"Disable the receiver."
	
	self enabled: false! !

!CheckboxButtonMorph methodsFor: 'protocol' stamp: ''!
enable
	"Enable the receiver."
	
	self enabled: true! !

!CheckboxButtonMorph methodsFor: 'menu & halo' stamp: ''!
addToggleItemsToHaloMenu: aCustomMenu 
	"Add toggle-items to the halo menu"
	
	super addToggleItemsToHaloMenu: aCustomMenu.
	aCustomMenu
		addUpdating: #enabledString
		target: self
		selector: #toggleEnabled! !

!CheckboxButtonMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	"Handle the transitions."
	
	self perform: #mouseDown: withArguments: {evt} inSuperclass: Morph.
	self enabled ifFalse: [^self].
	self isOn
		ifTrue: [self state: #repressed]
		ifFalse: [self state: #pressed].
	actWhen == #buttonDown
		ifTrue:
			[self doButtonAction].
	self mouseStillDown: evt.! !

!CheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
state
	"Answer the state."

	^state! !

!CheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
enabled
	"Answer the value of enabled"

	^ enabled! !

!CheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
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: ''!
colorToUse
	"Answer the color we should use."

	^self paneColor! !

!CheckboxButtonMorph methodsFor: 'private' stamp: ''!
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: 'event handling' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
radioButton
	"Answer a button pre-initialized with radio button images."
	
	^self new
		beRadioButton! !

!CheckboxButtonMorph class methodsFor: 'instance creation' stamp: ''!
checkBox
	"Answer a button pre-initialized with checkbox images."
	
	^self new
		beCheckbox! !

!CheckboxMorph commentStamp: ''!
Checkbox with box button and label with enablement support.!
!CheckboxMorph methodsFor: 'accessing' stamp: ''!
labelMorph: aMorph
	"Set the value of labelMorph"

	labelMorph ifNotNil: [labelMorph delete].
	labelMorph := aMorph.
	labelMorph color: (self theme checkboxButtonLabelNormalFillStyleFor: self label: labelMorph).
	self addMorphBack: aMorph.
	self enabled: self enabled.! !

!CheckboxMorph methodsFor: 'event handling' stamp: ''!
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: 'protocol' stamp: ''!
beRadioButton
	"Change the button to be a radio button."
	
	self buttonMorph beRadioButton! !

!CheckboxMorph methodsFor: 'event handling' stamp: ''!
labelClicked

	labelClickable ifTrue: [ self toggleSelected ].
	
	self doAnnounce: (LabelClicked source: self stateChanged: labelClickable).! !

!CheckboxMorph methodsFor: 'updating' stamp: ''!
updateEnabled
	"Update the enablement state."

	self model ifNotNil: [
		self getEnabledSelector ifNotNil: [
			self enabled: (self model perform: self getEnabledSelector)]]! !

!CheckboxMorph methodsFor: 'enablement' stamp: ''!
toggleEnabled
	"Toggle the enabled state."

	self enabled: self enabled not! !

!CheckboxMorph methodsFor: 'event handling' stamp: ''!
buttonMouseDown: evt
	"Sent from the checkbox button to handle focus."

	self wantsKeyboardFocusOnMouseDown ifTrue: [
		self takeKeyboardFocus]! !

!CheckboxMorph methodsFor: 'drawing' stamp: ''!
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: 'protocol' stamp: ''!
toggleSelected
	"Toggle the selection state."

	self takeKeyboardFocus.
	self enabled ifFalse: [^self].
	self model ifNil: [^self].

	(self setStateSelector ifNil: [^self]) numArgs = 0
		ifTrue: [self model perform: self setStateSelector].
	self setStateSelector numArgs = 1
		ifTrue: [	self model perform: self setStateSelector with: self isSelected not].
	self updateSelection.! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
label
	"Answer the contents of the label morph."

	^(self labelMorph ifNil: [^'']) contents! !

!CheckboxMorph methodsFor: 'private' stamp: ''!
newButtonMorph
	"Answer a new button morph"

	^(CheckboxButtonMorph new
		target: self;
		actionSelector: #toggleSelected;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap)
		on: #mouseDown send: #buttonMouseDown: to: self! !

!CheckboxMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	
	labelClickable := true.
	
	self
		borderWidth: 2; "space for focus"
		borderColor: Color transparent;
		enabled: true;
		changeTableLayout;
		listDirection: #leftToRight;
		wrapCentering: #center;
		cellInset: 4;
		labelMorph: self newLabelMorph;
		buttonMorph: self newButtonMorph;
		on: #click send: #updateButton: to: self;
		on: #mouseMove send: #updateButton: to: self;
		on: #mouseUp send: #updateButton: to: self! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
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: ''!
font: aFont
	"Set the label font"

	self labelMorph font: aFont! !

!CheckboxMorph methodsFor: 'updating' stamp: ''!
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: 'focus handling' stamp: ''!
wantsKeyboardFocusOnMouseDown
	"Answer whether the receiver would like keyboard focus
	on a mouse down event. use a property here for apps that want to take keyboard
	focus when the button is pressed (so that other morphs can, e.g. accept on focus change)."

	^self wantsKeyboardFocus and: [self valueOfProperty: #wantsKeyboardFocusOnMouseDown ifAbsent: [false]]! !

!CheckboxMorph methodsFor: 'protocol' stamp: ''!
enable
	"Enable the receiver."
	
	self enabled: true! !

!CheckboxMorph methodsFor: 'event handling' stamp: ''!
keyStroke: event 
	"Process keys navigation and space to toggle."
	event keyCharacter = Character space
		ifTrue: [self toggleSelected]! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
enabled
	"Answer the value of enabled"

	^ enabled! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector: anObject
	"Set the value of getEnabledSelector"

	getEnabledSelector := anObject.
	self updateEnabled! !

!CheckboxMorph methodsFor: 'private' stamp: ''!
newLabel
	"Answer a new label morph"

	^self theme checkboxLabelFor: self! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
font
	"Answer the label font"

	^self labelMorph font! !

!CheckboxMorph methodsFor: 'updating' stamp: ''!
update: aParameter 
	"Refer to the comment in View|update:."

	aParameter == self getStateSelector ifTrue: 
		[self updateSelection.
		^ self].
	aParameter == self getEnabledSelector ifTrue:
		[self updateEnabled.
		^ self].
	aParameter == self getLabelSelector ifTrue:
		[self updateLabel.
		^ self].
	
	aParameter isArray ifFalse: [ ^ self ].
	aParameter size == 2 ifFalse: [ ^ self ].
	
	aParameter first = #labelClickable: ifTrue: [ self labelClickable: aParameter second ].
	aParameter first = #label: ifTrue: [ self label: aParameter second ]! !

!CheckboxMorph methodsFor: 'updating' stamp: ''!
updateButtonDown: evt
	"Check for keyboard focus."

	self wantsKeyboardFocusOnMouseDown ifTrue: [
		self takeKeyboardFocus].
	self updateButton: evt! !

!CheckboxMorph methodsFor: 'private' stamp: ''!
newLabelMorph
	"Answer a new label morph"
	^	(LabelMorph contents: self label)
			on: #mouseDown send: #toggleSelected to: self; yourself! !

!CheckboxMorph methodsFor: 'protocol' stamp: ''!
beCheckbox
	"Change the button to be a checkbox."
	
	self buttonMorph beCheckbox! !

!CheckboxMorph methodsFor: 'protocol' stamp: ''!
labelClickable: aBoolean

	labelClickable := aBoolean.! !

!CheckboxMorph methodsFor: 'updating' stamp: ''!
updateLabel
	"Update the label."

	self model ifNotNil: [
		self getLabelSelector ifNotNil: [
			self label: (self model perform: self getLabelSelector)]]! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
setStateSelector: anObject
	"Set the value of setStateSelector"

	setStateSelector := anObject! !

!CheckboxMorph methodsFor: 'event handling' stamp: ''!
keyDown: event 
	"Process keys navigation and space to toggle."
	
	(self navigationKey: event) ifTrue: [^true].
	^ false! !

!CheckboxMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawSubmorphsOnAthensCanvas: anAthensCanvas
	super 	drawSubmorphsOnAthensCanvas: anAthensCanvas.
	self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOnAthensCanvas: anAthensCanvas].! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
getLabelSelector

	^ getLabelSelector! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	"Set the value of enabled"

	enabled := aBoolean.
	self labelMorph ifNotNil: [:m | m enabled: aBoolean].
	self buttonMorph ifNotNil: [:m | m enabled: aBoolean].
	self changed: #enabled! !

!CheckboxMorph methodsFor: 'enablement' stamp: ''!
enabledString
	"Answer the string to be shown in a menu to represent the 'enabled' status"
	
	^ (self enabled) -> 'enabled' translated! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
labelMorph
	"Answer the value of labelMorph"

	^ labelMorph! !

!CheckboxMorph methodsFor: 'initialization' stamp: ''!
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: 'updating' stamp: ''!
updateSelection
	"Update the selection state."

	self buttonMorph ifNotNil: [:m | m selected: self isSelected].
	self changed: #isSelected! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
getStateSelector
	"Answer the value of getStateSelector"

	^ getStateSelector! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
buttonMorph
	"Answer the value of buttonMorph"

	^ buttonMorph! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
setStateSelector
	"Answer the value of setStateSelector"

	^ setStateSelector! !

!CheckboxMorph methodsFor: 'protocol' stamp: ''!
disable
	"Disable the receiver."
	
	self enabled: false! !

!CheckboxMorph methodsFor: 'protocol' stamp: ''!
isSelected
	"Answer whether the receiver is selected."

	self model ifNil: [^false].
	^self model perform: (self getStateSelector ifNil: [^false])! !

!CheckboxMorph methodsFor: 'menu & halo' stamp: ''!
addToggleItemsToHaloMenu: aCustomMenu 
	"Add toggle-items to the halo menu"
	
	super addToggleItemsToHaloMenu: aCustomMenu.
	aCustomMenu
		addUpdating: #enabledString
		target: self
		selector: #toggleEnabled! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
getStateSelector: anObject
	"Set the value of getStateSelector"

	getStateSelector := anObject.
	self updateSelection! !

!CheckboxMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	"Yes, we do it here."
	
	^true! !

!CheckboxMorph methodsFor: 'drawing' stamp: ''!
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: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher
	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #MorphFocusNavigation! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
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: ''!
getEnabledSelector
	"Answer the value of getEnabledSelector"

	^ getEnabledSelector! !

!CheckboxMorph methodsFor: 'accessing' stamp: ''!
getLabelSelector: anObject

	getLabelSelector := anObject.
	self updateLabel.! !

!CheckboxMorph methodsFor: 'focus handling' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!CheckboxMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CheckboxMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CheckboxMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CheckboxMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CheckboxMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CheckboxMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CheckboxMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CheckboxMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CheckboxMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CheckboxMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CheckboxMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CheckboxMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CheckboxMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CheckboxMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CheckboxMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CheckboxMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CheckboxMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CheckboxMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CheckboxMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CheckboxMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CheckboxMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CheckboxMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CheckboxMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CheckboxMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CheckboxMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CheckboxMorph class methodsFor: 'instance creation' stamp: ''!
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! !

!CheckboxMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CheckboxMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CheckboxMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CheckboxMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!Checksum commentStamp: ''!
I represent the abstract superclass of all checksum algorithms.!
!Checksum class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == Checksum! !

!ChooseDropListDialogWindow commentStamp: ''!
Message dialog containing a drop list for selection of an item.!
!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: ''!
selectionIndex
	"Answer the initial selection index for the list."

	^self list ifEmpty: [0] ifNotEmpty: [1]! !

!ChooseDropListDialogWindow methodsFor: 'building' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	self list: #().
	super initialize! !

!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: ''!
selectedItem
	"Answer the selected list item or nil if cancelled."

	^self cancelled ifFalse: [self listMorph selectedItem]! !

!ChooseDropListDialogWindow methodsFor: 'building' stamp: ''!
newListMorph
	"Answer a new drop-list morph."

	^self
		newDropListFor: self
		list: #list
		getSelected: #selectionIndex
		setSelected: nil
		getEnabled: nil
		help: nil! !

!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: ''!
icon
	"Answer an icon for the receiver."

	^ self iconNamed: #questionIcon! !

!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: ''!
listMorph
	"Answer the value of listMorph"

	^ listMorph! !

!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: ''!
listMorph: anObject
	"Set the value of listMorph"

	listMorph := anObject! !

!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: ''!
list: anObject
	"Set the value of list"

	list := anObject.
	self
		changed: #list;
		changed: #selectionIndex! !

!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: ''!
list
	"Answer the value of list"

	^ list! !

!ChooseDropListDialogWindow class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallQuestionIcon! !

!ChoseDate commentStamp: ''!
A ChoseDate is an announcement raised by the CalendarMorph!
!ChoseDate methodsFor: 'accessing' stamp: ''!
calendar

	^ calendar.! !

!ChoseDate methodsFor: 'private' stamp: ''!
date: aDate 

	date := aDate.! !

!ChoseDate methodsFor: 'private' stamp: ''!
calendar: aCalendarChooserMorph 

	calendar := aCalendarChooserMorph.! !

!ChoseDate methodsFor: 'accessing' stamp: ''!
date

	^ date.! !

!ChoseDate class methodsFor: 'instance creation' stamp: ''!
of: aDate from: aCalendarChooserMorph

	^ self new
		date: aDate;
		calendar: aCalendarChooserMorph.! !

!ChronologyConstants commentStamp: ''!
ChronologyConstants is a SharedPool for the constants used by the Kernel-Chronology classes.!
!ChronologyConstants class methodsFor: 'class initialization' stamp: ''!
initialize
	"ChronologyConstants initialize"
	SqueakEpoch := 2415386. 		"Julian day number of 1 Jan 1901" 
	SecondsInDay := 86400.
	MicrosecondsInDay := SecondsInDay * 1e6.
	SecondsInHour := 3600.
	SecondsInMinute := 60.
	MinutesInHour := 60.
	HoursInDay := 24.
	NanosInSecond := 10 raisedTo: 9.
	NanosInMillisecond := 10 raisedTo: 6.
	DayNames := #(Sunday Monday Tuesday Wednesday Thursday Friday Saturday).
		
	MonthNames := #(January February March April May June July
 			August September October November December).
	DaysInMonth := #(31 28 31 30 31 30 31 31 30 31 30 31).! !

!ChunkFileFormatParser commentStamp: ''!
I represent the chunk file format.  Right now I know how to parse chunks from a readStream, but not how to write them.!
!ChunkFileFormatParser methodsFor: 'class factory' stamp: ''!
methodChunkClass
	^ MethodChunk! !

!ChunkFileFormatParser methodsFor: 'parsing' stamp: ''!
parseNextDeclaration
	| isMetadata nextChunk |
	readStream skipSeparators.
	readStream isNextStyleChunk
		ifTrue:
			[ 
			self addDeclaration: (self styleChunkClass contents: readStream readUpToEndOfStyleChunk).
			^ self ].
	isMetadata := readStream isNextChunkMetaData.
	nextChunk := readStream next.
	isMetadata
		ifFalse: [ self addDeclaration: (self doItChunkClass contents: nextChunk) ]
		ifTrue:
			[ 
			| substrings |
			substrings := nextChunk parseLiterals.
			(substrings includes: self methodsForSelector asString)
				ifTrue: [ ^ self parseMethodDeclarations: substrings ].
			(substrings includes: self commentStampSelector asString)
				ifTrue: [ ^ self parseCommentDeclaration: substrings ].
			(substrings includes: self reorganizeSelector asString)
				ifTrue: [ ^ self parseClassOrganization: substrings ] ]! !

!ChunkFileFormatParser methodsFor: 'class factory' stamp: ''!
styleChunkClass 
	^ StyleChunk! !

!ChunkFileFormatParser methodsFor: 'class factory' stamp: ''!
classCommentChunkClass
	^ ClassCommentChunk! !

!ChunkFileFormatParser methodsFor: 'class factory' stamp: ''!
doItChunkClass 
	^ DoItChunk! !

!ChunkFileFormatParser methodsFor: 'initialization' stamp: ''!
defaultCommentStampSelector
	^ #commentStamp:! !

!ChunkFileFormatParser methodsFor: 'custom points' stamp: ''!
methodsForSelector: anObject
	methodsForSelector := anObject! !

!ChunkFileFormatParser methodsFor: 'custom points' stamp: ''!
classTraitSelector
	^ classTraitSelector! !

!ChunkFileFormatParser methodsFor: 'parsing' stamp: ''!
parseClassOrganization: classOrganizationPreamble
	"The comment preable is an array with the following structure:
	If instance side method:
	#(#CodeImportTestCaseTestClass #reorganize)
	
	if class side:
	
	#(#CodeImportTestCaseTestClass #class #reorganize)
	"

	| behaviorName isMeta |
	behaviorName := classOrganizationPreamble first.
	isMeta := classOrganizationPreamble second ~= self reorganizeSelector.
	self
		addDeclaration:
			(self classOrganisationChunkClass
				contents: readStream next
				behaviorName: behaviorName
				isMeta: isMeta)! !

!ChunkFileFormatParser methodsFor: 'custom points' stamp: ''!
classSelector
	^ classSelector! !

!ChunkFileFormatParser methodsFor: 'initialization' stamp: ''!
defaultClassSelector
	^ #class! !

!ChunkFileFormatParser methodsFor: 'custom points' stamp: ''!
reorganizeSelector
	^ reorganizeSelector! !

!ChunkFileFormatParser methodsFor: 'custom points' stamp: ''!
methodsForSelector
	^ methodsForSelector! !

!ChunkFileFormatParser methodsFor: 'custom points' stamp: ''!
reorganizeSelector: anObject
	reorganizeSelector := anObject! !

!ChunkFileFormatParser methodsFor: 'initialization' stamp: ''!
defaultReorganizeSelector
	^ #reorganize! !

!ChunkFileFormatParser methodsFor: 'parsing' stamp: ''!
parseChunks
	[ readStream atEnd ] whileFalse: [ self parseNextDeclaration ].
	^ parsedDeclarations! !

!ChunkFileFormatParser methodsFor: 'custom points' stamp: ''!
classSelector: anObject
	classSelector := anObject! !

!ChunkFileFormatParser methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	parsedDeclarations := OrderedCollection new.
	classSelector := self defaultClassSelector.
	classTraitSelector := self defaultClassTraitSelector.
	commentStampSelector := self defaultCommentStampSelector.
	methodsForSelector := self defaultMethodsForSelector.
	reorganizeSelector := self defaultReorganizeSelector! !

!ChunkFileFormatParser methodsFor: 'accessing' stamp: ''!
addDeclaration: aDeclaration
	parsedDeclarations	 add: aDeclaration! !

!ChunkFileFormatParser methodsFor: 'class factory' stamp: ''!
classOrganisationChunkClass
	^ ClassOrganizationChunk! !

!ChunkFileFormatParser methodsFor: 'parsing' stamp: ''!
parseCommentDeclaration: commentPreamble
	"The comment preable is an array with the following structure:
	If instance side method:
	#(#CodeImportTestCaseTestClass #commentStamp: '<historical>' #prior: 0)
	
	if class side:
	
	#(#CodeImportTestCaseTestClass #class #commentStamp: '<historical>' #prior: 0)
	allButFirst:
	"

	| behaviorName isMeta stamp |
	self asCollectionElement.
	behaviorName := commentPreamble first asSymbol.
	isMeta := commentPreamble second ~= self commentStampSelector.
	stamp := isMeta
		ifTrue: [ commentPreamble at: 4 ]
		ifFalse: [ commentPreamble at: 3 ].
	self
		addDeclaration:
			(self classCommentChunkClass
				contents: readStream next
				behaviorName: behaviorName
				isMeta: isMeta
				stamp: stamp)! !

!ChunkFileFormatParser methodsFor: 'initialization' stamp: ''!
defaultClassTraitSelector
	^ #classTrait! !

!ChunkFileFormatParser methodsFor: 'custom points' stamp: ''!
commentStampSelector
	^ commentStampSelector! !

!ChunkFileFormatParser methodsFor: 'custom points' stamp: ''!
classTraitSelector: anObject
	classTraitSelector := anObject! !

!ChunkFileFormatParser methodsFor: 'accessing' stamp: ''!
readStream: aReadStream
	readStream := ChunkReadStream on: aReadStream! !

!ChunkFileFormatParser methodsFor: 'parsing' stamp: ''!
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 = self classSelector
		or: [ methodsPreamble second = self classTraitSelector ].
	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 := readStream next.
	methodSource notEmpty ]
		whileTrue:
			[ 
			self
				addDeclaration:
					(self methodChunkClass
						contents: methodSource
						behaviorName: behaviorName asSymbol
						isMeta: isMeta
						category: category
						stamp: stamp) ]! !

!ChunkFileFormatParser methodsFor: 'custom points' stamp: ''!
commentStampSelector: anObject
	commentStampSelector := anObject! !

!ChunkFileFormatParser methodsFor: 'initialization' stamp: ''!
defaultMethodsForSelector
	^ #methodsFor:! !

!ChunkFileFormatParser class methodsFor: 'instance creation' stamp: ''!
for: aReadStream
	^self new
		readStream: aReadStream;
		yourself! !

!ChunkImportTestCase commentStamp: ''!
SUnit test case for import of chunk format!
!ChunkImportTestCase methodsFor: 'importing-code' stamp: ''!
testImportAMethodWithSpacesInItsCategory
	| class |
	SystemAnnouncer uniqueInstance
		suspendAllWhile: [ 
			[ 
			class := self importAClass.
			CodeImporter
				evaluateString:
					('!!{1} methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!someMethod
	^true' format: {(class name asString)}).
			self assert: (class >> #someMethod) category equals: 'some protocol' ]
				ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! !

!ChunkImportTestCase methodsFor: 'importing-code' stamp: ''!
testImportAMethod
	| class |
	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: ''!
testImportAClassCategory
	| class classOrganizationString chunk |
	classOrganizationString := '(#testing testImportAMethod testImportAClass)
(#auxiliar importAClass)'.
	chunk := '!!{1} reorganize!!'.
	SystemAnnouncer uniqueInstance suspendAllWhile: [ [
		class := self importAClass.
		
		"we write the methods we will categorize"
		class compileSilently: 'testImportAClass'.
		class compileSilently: 'testImportAMethod'.
		class compileSilently: 'importAClass'.
		
		CodeImporter evaluateString: (chunk format: { class name asString }), classOrganizationString.
		"we do not care about the order of the output just that all the elements are present"
		self 
			assertCollection: (classOrganizationString trimBoth findTokens: String cr, ' ()') sorted
			equals: (class organization stringForFileOut findTokens: String cr, ' ()') sorted.
	] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! !

!ChunkImportTestCase methodsFor: 'importing-code' stamp: ''!
testExportAMethodWithLangTag
	|  stream chunkWriteStream |
	stream := String new writeStream.
	chunkWriteStream := ChunkWriteStream on: stream.
	chunkWriteStream nextPut:'pangrams
	^ OrderedCollection new
		add: ''English'' -> ''the quick brown fox jumps over the lazy dog'';
		add: ''Bulgarian'' -> ''Под южно дърво, цъфтящо в синьо, бягаше малко пухкаво зайче.'';
		add: ''Czech'' -> ''Příliš žluťoučký kůň úpěl ďábelské ódy.'';
		add: ''Chinese'' -> ''視野無限廣，窗外有藍天
    微風迎客，軟語伴茶'';
		add: ''Danish'' -> ''Quizdeltagerne spiste jordbær med fløde, mens cirkusklovnen Walther spillede på xylofon.'';
		add: ''Dutch'' -> ''Pa''''s wijze lynx bezag vroom het fikse aquaduct'';
		add: ''Esperanto'' -> ''Eĥoŝanĝo ĉiuĵaŭde'';
		add: ''Estonian'' -> ''See väike mölder jõuab rongile hüpata'';
		add: ''Finnish'' -> ''Viekas kettu punaturkki laiskan koiran takaa kurkki'';
		add: ''French'' -> ''Voix ambiguë d''''un cœur qui au zéphyr préfère les jattes de kiwis'';
		add: ''German'' -> ''Zwölf Boxkämpfer jagen Viktor quer über den großen Sylter Deich'';
		add: ''Greek'' -> ''Θέλει αρετή και τόλμη η ελευθερία. (Ανδρέας Κάλβος)'';
		add: ''Hebrew'' -> ''דג סקרן שט לו בים זך אך לפתע פגש חבורה נחמדה שצצה כך'';
		add: ''Hungarian'' -> ''Egy hűtlen vejét fülöncsípő, dühös mexikói úr Wesselényinél mázol Quitóban'';
		add: ''Italian'' -> ''Ma la volpe, col suo balzo, ha raggiunto il quieto Fido.'';
		add: ''Japanese'' -> ''いろはにほへと ちりぬるを わかよたれそ つねならむ うゐのおくやま けふこえて あさきゆめみし ゑひもせす'';
		add: ''Korean'' -> ''다람쥐 헌 쳇바퀴에 타고파'';
		add: ''Latvian'' -> ''Sarkanās jūrascūciņas peld pa jūru.'';
		add: ''Norwegian'' -> ''En god stil må først og fremst være klar. Den må være passende. Aristoteles.'';
		add: ''Portugese'' -> ''A rápida raposa castanha salta por cima do cão lento.'';
		add: ''Brazilian portugese'' -> ''A ligeira raposa marrom ataca o cão preguiçoso'';
		add: ''Polish'' -> ''Pchnąć w tę łódź jeża lub ośm skrzyń fig'';
		add: ''Romanian'' -> ''Agera vulpe maronie sare peste câinele cel leneş'';
		add: ''Russian'' -> ''Съешь ещё этих мягких французских булок да выпей же чаю'';
		add: ''Serbian (cyrillic)'' -> ''Чешће цeђење мрeжастим џаком побољшава фертилизацију генских хибрида.'';
		add: ''Serbian (latin)'' -> ''Češće ceđenje mrežastim džakom poboljšava fertilizaciju genskih hibrida.'';
		add: ''Slovak'' -> ''Kŕdeľ šťastných ďatľov učí pri ústí Váhu mĺkveho koňa obhrýzať kôru a žrať čerstvé mäso.'';
		add: ''Slovene'' -> ''V kožuščku hudobnega fanta stopiclja mizar in kliče 0619872345.'';
		add:
				''Spanish''
						->
							''El veloz murciélago hindú comía feliz cardillo y kiwi. La cigüeña tocaba el saxofón detrás del palenque de paja.'';
		add: ''Swedish'' -> ''Flygande bäckasiner söka hwila på mjuka tuvor'';
		add:
				''Thai''
						->
							''เป็นมนุษย์สุดประเสริฐเลิศคุณค่า
    กว่าบรรดาฝูงสัตว์เดรัจฉาน
    จงฝ่าฟันพัฒนาวิชาการ อย่าล้างผลาญฤๅเข่นฆ่าบีฑาใคร
    ไม่ถือโทษโกรธแช่งซัดฮึดฮัดด่า
    หัดอภัยเหมือนกีฬาอัชฌาสัย
    ปฏิบัติประพฤติกฎกำหนดใจ
    พูดจาให้จ๊ะ ๆ จ๋า ๆ น่าฟังเอยฯ'';
		add: ''Turkish'' -> ''Pijamalı hasta, yağız şoföre çabucak güvendi'';
		yourself'.
	
	self assert: stream contents equals: 'pangrams
	^ OrderedCollection new
		add: ''English'' -> ''the quick brown fox jumps over the lazy dog'';
		add: ''Bulgarian'' -> ''Под южно дърво, цъфтящо в синьо, бягаше малко пухкаво зайче.'';
		add: ''Czech'' -> ''Příliš žluťoučký kůň úpěl ďábelské ódy.'';
		add: ''Chinese'' -> ''視野無限廣，窗外有藍天
    微風迎客，軟語伴茶'';
		add: ''Danish'' -> ''Quizdeltagerne spiste jordbær med fløde, mens cirkusklovnen Walther spillede på xylofon.'';
		add: ''Dutch'' -> ''Pa''''s wijze lynx bezag vroom het fikse aquaduct'';
		add: ''Esperanto'' -> ''Eĥoŝanĝo ĉiuĵaŭde'';
		add: ''Estonian'' -> ''See väike mölder jõuab rongile hüpata'';
		add: ''Finnish'' -> ''Viekas kettu punaturkki laiskan koiran takaa kurkki'';
		add: ''French'' -> ''Voix ambiguë d''''un cœur qui au zéphyr préfère les jattes de kiwis'';
		add: ''German'' -> ''Zwölf Boxkämpfer jagen Viktor quer über den großen Sylter Deich'';
		add: ''Greek'' -> ''Θέλει αρετή και τόλμη η ελευθερία. (Ανδρέας Κάλβος)'';
		add: ''Hebrew'' -> ''דג סקרן שט לו בים זך אך לפתע פגש חבורה נחמדה שצצה כך'';
		add: ''Hungarian'' -> ''Egy hűtlen vejét fülöncsípő, dühös mexikói úr Wesselényinél mázol Quitóban'';
		add: ''Italian'' -> ''Ma la volpe, col suo balzo, ha raggiunto il quieto Fido.'';
		add: ''Japanese'' -> ''いろはにほへと ちりぬるを わかよたれそ つねならむ うゐのおくやま けふこえて あさきゆめみし ゑひもせす'';
		add: ''Korean'' -> ''다람쥐 헌 쳇바퀴에 타고파'';
		add: ''Latvian'' -> ''Sarkanās jūrascūciņas peld pa jūru.'';
		add: ''Norwegian'' -> ''En god stil må først og fremst være klar. Den må være passende. Aristoteles.'';
		add: ''Portugese'' -> ''A rápida raposa castanha salta por cima do cão lento.'';
		add: ''Brazilian portugese'' -> ''A ligeira raposa marrom ataca o cão preguiçoso'';
		add: ''Polish'' -> ''Pchnąć w tę łódź jeża lub ośm skrzyń fig'';
		add: ''Romanian'' -> ''Agera vulpe maronie sare peste câinele cel leneş'';
		add: ''Russian'' -> ''Съешь ещё этих мягких французских булок да выпей же чаю'';
		add: ''Serbian (cyrillic)'' -> ''Чешће цeђење мрeжастим џаком побољшава фертилизацију генских хибрида.'';
		add: ''Serbian (latin)'' -> ''Češće ceđenje mrežastim džakom poboljšava fertilizaciju genskih hibrida.'';
		add: ''Slovak'' -> ''Kŕdeľ šťastných ďatľov učí pri ústí Váhu mĺkveho koňa obhrýzať kôru a žrať čerstvé mäso.'';
		add: ''Slovene'' -> ''V kožuščku hudobnega fanta stopiclja mizar in kliče 0619872345.'';
		add:
				''Spanish''
						->
							''El veloz murciélago hindú comía feliz cardillo y kiwi. La cigüeña tocaba el saxofón detrás del palenque de paja.'';
		add: ''Swedish'' -> ''Flygande bäckasiner söka hwila på mjuka tuvor'';
		add:
				''Thai''
						->
							''เป็นมนุษย์สุดประเสริฐเลิศคุณค่า
    กว่าบรรดาฝูงสัตว์เดรัจฉาน
    จงฝ่าฟันพัฒนาวิชาการ อย่าล้างผลาญฤๅเข่นฆ่าบีฑาใคร
    ไม่ถือโทษโกรธแช่งซัดฮึดฮัดด่า
    หัดอภัยเหมือนกีฬาอัชฌาสัย
    ปฏิบัติประพฤติกฎกำหนดใจ
    พูดจาให้จ๊ะ ๆ จ๋า ๆ น่าฟังเอยฯ'';
		add: ''Turkish'' -> ''Pijamalı hasta, yağız şoföre çabucak güvendi'';
		yourself!!'! !

!ChunkImportTestCase methodsFor: 'importing-code' stamp: ''!
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: 'CodeImport-Tests-Garbage'.
		
	] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! !

!ChunkImportTestCase methodsFor: 'auxiliar' stamp: ''!
importAClass

	^CodeImporter evaluateString: 'Object subclass: #CodeImportTestCaseTestClass
			instanceVariableNames: ''var1 var2 var3''
			classVariableNames: ''''
			poolDictionaries: ''''
			category: ''CodeImport-Tests-Garbage''!!'.! !

!ChunkImportTestCase methodsFor: 'importing-methods' stamp: ''!
testImportFromReadStream
	self assert: 4 equals: (CodeImporter evaluateReadStream: '2+2!!' readStream)! !

!ChunkImportTestCase methodsFor: 'importing-methods' stamp: ''!
testImportString
	self assert: 4 equals: (CodeImporter evaluateString: '2+2!!')! !

!ChunkImportTestCase methodsFor: 'importing-code' stamp: ''!
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: ''<historical>'' prior: 0!!{2}!!' format: { class name asString . commentToWrite }).
		self assert: comment equals: class comment.
	] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! !

!ChunkImportTestCase methodsFor: 'importing-code' stamp: ''!
testImportAClassComment
	| class comment |
	comment := 'I''m a nice comment, treat me well :).'.
	SystemAnnouncer uniqueInstance suspendAllWhile: [[
		class := self importAClass.
		CodeImporter evaluateString: ('!!{1} commentStamp: ''<historical>'' prior: 0!!{2}!!' format: { class name asString . comment }).
		self assert: comment equals: class comment.
	] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! !

!ChunkImportTestCase methodsFor: 'importing-code' stamp: ''!
testImportAMethodWithNoTimestamp
	| class |
	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: ''!
testImportAMethodWithLangTag
	| class |
	SystemAnnouncer uniqueInstance suspendAllWhile: [ [
		class := self importAClass.
		CodeImporter
			evaluateString:
				('!!{1} methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!pangrams
	^ OrderedCollection new
		add: ''English'' -> ''the quick brown fox jumps over the lazy dog'';
		add: ''Bulgarian'' -> ''Под южно дърво, цъфтящо в синьо, бягаше малко пухкаво зайче.'';
		add: ''Czech'' -> ''Příliš žluťoučký kůň úpěl ďábelské ódy.'';
		add: ''Chinese'' -> ''視野無限廣，窗外有藍天
    微風迎客，軟語伴茶'';
		add: ''Danish'' -> ''Quizdeltagerne spiste jordbær med fløde, mens cirkusklovnen Walther spillede på xylofon.'';
		add: ''Dutch'' -> ''Pa''''s wijze lynx bezag vroom het fikse aquaduct'';
		add: ''Esperanto'' -> ''Eĥoŝanĝo ĉiuĵaŭde'';
		add: ''Estonian'' -> ''See väike mölder jõuab rongile hüpata'';
		add: ''Finnish'' -> ''Viekas kettu punaturkki laiskan koiran takaa kurkki'';
		add: ''French'' -> ''Voix ambiguë d''''un cœur qui au zéphyr préfère les jattes de kiwis'';
		add: ''German'' -> ''Zwölf Boxkämpfer jagen Viktor quer über den großen Sylter Deich'';
		add: ''Greek'' -> ''Θέλει αρετή και τόλμη η ελευθερία. (Ανδρέας Κάλβος)'';
		add: ''Hebrew'' -> ''דג סקרן שט לו בים זך אך לפתע פגש חבורה נחמדה שצצה כך'';
		add: ''Hungarian'' -> ''Egy hűtlen vejét fülöncsípő, dühös mexikói úr Wesselényinél mázol Quitóban'';
		add: ''Italian'' -> ''Ma la volpe, col suo balzo, ha raggiunto il quieto Fido.'';
		add: ''Japanese'' -> ''いろはにほへと ちりぬるを わかよたれそ つねならむ うゐのおくやま けふこえて あさきゆめみし ゑひもせす'';
		add: ''Korean'' -> ''다람쥐 헌 쳇바퀴에 타고파'';
		add: ''Latvian'' -> ''Sarkanās jūrascūciņas peld pa jūru.'';
		add: ''Norwegian'' -> ''En god stil må først og fremst være klar. Den må være passende. Aristoteles.'';
		add: ''Portugese'' -> ''A rápida raposa castanha salta por cima do cão lento.'';
		add: ''Brazilian portugese'' -> ''A ligeira raposa marrom ataca o cão preguiçoso'';
		add: ''Polish'' -> ''Pchnąć w tę łódź jeża lub ośm skrzyń fig'';
		add: ''Romanian'' -> ''Agera vulpe maronie sare peste câinele cel leneş'';
		add: ''Russian'' -> ''Съешь ещё этих мягких французских булок да выпей же чаю'';
		add: ''Serbian (cyrillic)'' -> ''Чешће цeђење мрeжастим џаком побољшава фертилизацију генских хибрида.'';
		add: ''Serbian (latin)'' -> ''Češće ceđenje mrežastim džakom poboljšava fertilizaciju genskih hibrida.'';
		add: ''Slovak'' -> ''Kŕdeľ šťastných ďatľov učí pri ústí Váhu mĺkveho koňa obhrýzať kôru a žrať čerstvé mäso.'';
		add: ''Slovene'' -> ''V kožuščku hudobnega fanta stopiclja mizar in kliče 0619872345.'';
		add:
				''Spanish''
						->
							''El veloz murciélago hindú comía feliz cardillo y kiwi. La cigüeña tocaba el saxofón detrás del palenque de paja.'';
		add: ''Swedish'' -> ''Flygande bäckasiner söka hwila på mjuka tuvor'';
		add:
				''Thai''
						->
							''เป็นมนุษย์สุดประเสริฐเลิศคุณค่า
    กว่าบรรดาฝูงสัตว์เดรัจฉาน
    จงฝ่าฟันพัฒนาวิชาการ อย่าล้างผลาญฤๅเข่นฆ่าบีฑาใคร
    ไม่ถือโทษโกรธแช่งซัดฮึดฮัดด่า
    หัดอภัยเหมือนกีฬาอัชฌาสัย
    ปฏิบัติประพฤติกฎกำหนดใจ
    พูดจาให้จ๊ะ ๆ จ๋า ๆ น่าฟังเอยฯ'';
		add: ''Turkish'' -> ''Pijamalı hasta, yağız şoföre çabucak güvendi'';
		yourself!!]lang[(2798)0!! !!' format: {(class name asString)}).
			self assert: class new pangrams first value equals: 'the quick brown fox jumps over the lazy dog']
				ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! !

!ChunkReadStream commentStamp: ''!
I am a read stream that reads and returns chunks of code. That is, pieces of text separated by

!!!!

symbols!
!ChunkReadStream methodsFor: 'decorated' stamp: ''!
position
	
	^ decoratedStream position - (nextChar ifNil: [0] ifNotNil: [1])! !

!ChunkReadStream methodsFor: 'decorated' stamp: ''!
basicNext

	nextChar = self terminatorMark 
		ifTrue: [ decoratedStream next ].
	^ nextChar! !

!ChunkReadStream methodsFor: 'public' stamp: ''!
skipSeparators

	[self atEnd not and: [ self peek isSeparator ]]
		whileTrue: [ decoratedStream next ]! !

!ChunkReadStream methodsFor: 'decorated' stamp: ''!
basicNextChunk
	"Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character."

	| out ch |
	out := (String new: 1000) writeStream.
	self skipSeparators.
	[ (ch := decoratedStream next) isNil ]
		whileFalse: [ 
			ch == self terminatorMark
				ifTrue: [ 
					decoratedStream peek == self terminatorMark
						ifTrue: [ decoratedStream next	"skip doubled terminator" ]
						ifFalse: [ ^ out contents	"terminator is not doubled; we're done!!" ] ].
			out nextPut: ch ].
	^ out contents! !

!ChunkReadStream methodsFor: 'decorated' stamp: ''!
decodeString: string andRuns: runsRaw
	| strm runLength runValues newString index |
	strm := ReadStream on: runsRaw from: 1 to: runsRaw size.
	(strm peekFor: $()
		ifFalse: [ ^ nil ].
	runLength := OrderedCollection new.
	[ 
	strm skipSeparators.
	strm peekFor: $) ] whileFalse: [ runLength add: (Number readFrom: strm) ].
	runValues := OrderedCollection new.
	[ strm atEnd ]
		whileFalse: [ 
			runValues add: (Number readFrom: strm).
			strm next ].
	newString := WideString new: string size.
	index := 1.
	runLength
		with: runValues
		do: [ :length :leadingChar | 
			index to: index + length - 1 do: [ :pos | newString at: pos put: (Character leadingChar: leadingChar code: (string at: pos) charCode) ].
			index := index + length ].
	^ newString! !

!ChunkReadStream methodsFor: 'decorated' stamp: ''!
next

    ^ self parseLangTagFor: self basicNextChunk! !

!ChunkReadStream methodsFor: 'testing' stamp: ''!
isNextStyleChunk
	"Style chunks are between $] and $["
	^ decoratedStream peek == $]! !

!ChunkReadStream methodsFor: 'testing' stamp: ''!
isNextChunkMetaData
	| isMetaData |
	isMetaData := decoratedStream peek = $!!.
	isMetaData ifTrue: [ decoratedStream next ].
	^ isMetaData! !

!ChunkReadStream methodsFor: 'public' stamp: ''!
readUpToEndOfStyleChunk
	"Style chunks are between $] and $["
	^decoratedStream upTo: $[! !

!ChunkReadStream methodsFor: 'initialization' stamp: ''!
reset
	nextChar := nil.
	decoratedStream reset.! !

!ChunkReadStream methodsFor: 'public' stamp: ''!
terminatorMark
	^$!!! !

!ChunkReadStream methodsFor: 'decorated' stamp: ''!
parseLangTagFor: aString

	| string peek runsRaw foundTag |
	string := aString.
	"Test for ]lang[ tag"
	peek := self skipSeparators; peek.
	peek = $] ifFalse: [ ^ string ].  "no tag"
	foundTag := (decoratedStream upTo: $[).
	foundTag = ']lang' ifTrue: [
		runsRaw := self basicNextChunk.
		string := self decodeString: aString andRuns: runsRaw
	] ifFalse: [
		"If we find a ] but not a lang tag, there is something really wrong and we are not ready to parse that"
		^ string , self basicNextChunk
	].
	^ string! !

!ChunkWriteStream commentStamp: ''!
I am a write stream that write chunks of Strings. That is, pieces of text separated by

!!!!

symbols!
!ChunkWriteStream methodsFor: 'writing' stamp: ''!
bang
	
	decoratedStream nextPut: self terminatorMark! !

!ChunkWriteStream methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	"Forward message to decoree"

	^ aMessage sendTo: decoratedStream! !

!ChunkWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: aString
	"Append the argument, aString, to the receiver, doubling embedded !! terminators and adding a extra one"

	| string start bangIndex |
	string := aString asString.
	start := 1.
	[ (bangIndex := string indexOf: self terminatorMark startingAt: start) = 0 ]
		whileFalse: [
			decoratedStream next: bangIndex - start + 1 putAll: string startingAt: start.
			self bang. "double it"
			start := bangIndex + 1 ].
	decoratedStream next: string size - start + 1 putAll: string startingAt: start.
	self bang. "one extra"
	decoratedStream flush
! !

!ChunkWriteStream methodsFor: 'accessing' stamp: ''!
nextChunkPut: aString

	^ self nextPut: aString! !

!ChunkWriteStream methodsFor: 'accessing' stamp: ''!
terminatorMark
	^$!!! !

!CircleMorph commentStamp: ''!
I am a specialization of EllipseMorph that knows enough to remain circular.
!
!CircleMorph methodsFor: 'rotate scale and flex' stamp: ''!
prepareForScaling
	"When scaling from a halo, I can do this without a flex shell"

	^ self! !

!CircleMorph methodsFor: 'initialization' stamp: ''!
defaultBounds

	^0@0 extent: 40@40! !

!CircleMorph methodsFor: 'accessing' stamp: ''!
originalCenter

	^ originalCenter! !

!CircleMorph methodsFor: 'geometry' stamp: ''!
referencePosition
	"Return the current reference position of the receiver"

	^ referencePosition! !

!CircleMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	referencePosition := self center! !

!CircleMorph methodsFor: 'rotate scale and flex' stamp: ''!
rotationDegrees: degrees
	| ref newPos flex origAngle origCenter |
	ref := self referencePosition.
	origAngle := originalAngle ifNil: [ self heading ].
	origCenter := originalCenter ifNil: [ 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.
	referencePosition := ref.
	originalAngle := origAngle.
	originalCenter := origCenter.
	self forwardDirection: degrees.
	self changed! !

!CircleMorph methodsFor: 'rotate scale and flex' stamp: ''!
rotationCenter
	"Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	| refPos |
	refPos := self referencePosition.
	^ (refPos - self bounds origin) / self bounds extent asFloatPoint! !

!CircleMorph methodsFor: 'rotate scale and flex' stamp: ''!
privateMoveBy: delta

	referencePosition := referencePosition + delta.
	originalCenter := (originalCenter ifNil: [ self center ]) + delta.
	super privateMoveBy: delta! !

!CircleMorph methodsFor: 'menus' stamp: ''!
setRotationCenterFrom: aPoint
	"Called by halo rotation code.
	Circles store their referencePosition."

	referencePosition := aPoint.
	originalCenter := self center.
	originalAngle := self heading! !

!CircleMorph methodsFor: 'geometry' stamp: ''!
bounds: aRectangle

	| size |
	size := aRectangle width min: aRectangle height.
	super bounds:
		(Rectangle origin: aRectangle origin extent: size @ size)! !

!CircleMorph methodsFor: 'accessing' stamp: ''!
originalCenter: anObject

	originalCenter := anObject! !

!CircleMorph methodsFor: 'rotate scale and flex' stamp: ''!
rotationDegrees

	^ self forwardDirection! !

!CircleMorph methodsFor: 'geometry' stamp: ''!
transformedBy: aTransform

	aTransform isIdentity ifTrue: [ ^ self ].
	^ self center: (aTransform localPointToGlobal: self center)! !

!CircleMorph methodsFor: 'initialization' stamp: ''!
defaultColor

	^Color green lighter! !

!CircleMorph methodsFor: 'rotate scale and flex' stamp: ''!
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 ifNotNil: [ 
		box := self bounds.
		newRef := box origin + (aPointOrNil * box extent).
		self setRotationCenterFrom: newRef ]! !

!CircleMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint

	| size oldRotationCenter |
	oldRotationCenter := self rotationCenter.
	size := aPoint x min: aPoint y.
	super extent: size @ size.
	self rotationCenter: oldRotationCenter! !

!CircleMorph methodsFor: 'rotate scale and flex' stamp: ''!
prepareForRotating
	"When rotating from a halo, I can do this without a flex shell"

	^ self! !

!CircleMorph class methodsFor: 'examples' stamp: ''!
example

	CircleMorph new
		extent: 50 @ 50;
		position: 100@100;
		color: Color blue;
		openInWorld! !

!CircleMorph class methodsFor: 'examples' stamp: ''!
exampleBadExtent
	"Note: even when vertical vs. horizontal extent is given different it remains a circle"
	
	CircleMorph new
		extent: 100 @ 50;
		color: Color red;
		openInWorld! !

!CircleMorphCounter methodsFor: 'drawing' stamp: ''!
fullDrawOn: aCanvas
	super fullDrawOn: aCanvas.
	counter := self counter + 1! !

!CircleMorphCounter methodsFor: 'accessing' stamp: ''!
counter: anObject

	counter := anObject! !

!CircleMorphCounter methodsFor: 'accessing' stamp: ''!
counter
	counter ifNil: [ counter := 0 ].
	^ counter ! !

!CircleMorphTest commentStamp: ''!
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: 'running' stamp: ''!
setUp
	super setUp.
	morph := CircleMorph new! !

!CircularHierarchyError commentStamp: ''!
I am signaled if a new class introduces a circular class hierarchy.!
!CircularHierarchyError class methodsFor: 'signalling' stamp: ''!
signalFor: aClass
	self signal: aClass name asString, ': Trying to build a circular hierarchy'! !

!CircularMemoryLogger commentStamp: ''!
`CircularMemoryLogger` records the signals that it receives in a circular buffer, default size 5000 entries.

###Example1: Instance usage

```
	(CircularMemoryLogger new 
		runDuring: [ 
			StringSignal emit: 'This is a message' ]	)
				inspect.
```

###Example 2: Global usage

```
	CircularMemoryLogger reset.
	CircularMemoryLogger start.
	StringSignal emit: 'This is a message' .
	CircularMemoryLogger instance recordings inspect.
	CircularMemoryLogger stop.
```!
!CircularMemoryLogger methodsFor: 'initialization' stamp: ''!
initialize 

	entryCount := 5000.
	index := 0.
	super initialize.
! !

!CircularMemoryLogger methodsFor: 'utilities' stamp: ''!
recordings
	"It answers a copy of the recorded collection to not grant
	access to the users to a shared resource that should only be 
	modified via the mutex"

	^ fullBuffer
		  ifTrue: [ 
		  recordings sorted: [ :a :b | a timestamp < b timestamp ] ]
		  ifFalse: [ recordings first: index ]! !

!CircularMemoryLogger methodsFor: 'ston persistence' stamp: ''!
basicIndex: anInteger
	"Set the receiver's index.
	This is normally only used when loading saved instances from file"

	index := anInteger! !

!CircularMemoryLogger methodsFor: 'initialization' stamp: ''!
entryCount: anInteger

	mutex critical: [ 
		entryCount := anInteger.
		self basicReset ]! !

!CircularMemoryLogger methodsFor: 'initialization' stamp: ''!
basicReset
	"It simply removes all recordings without
	affecting the running status of the logger.
	This method must be called from within the mutex."

	recordings := Array new: entryCount.
	fullBuffer := false.
	loopCount := 0.
	index := 0.! !

!CircularMemoryLogger methodsFor: 'utilities' stamp: ''!
nextPut: aSignal

	mutex critical: [ 
		index := index >= entryCount
			         ifTrue: [ 
				         fullBuffer := true.
				         loopCount := loopCount + 1.
				         1 ]
			         ifFalse: [ index + 1 ].
		recordings at: index put: aSignal ].
	
	"The announcement is passed forward so that potential viewers
	can refresh when something changes. we do not create another announcement
	because it is not needed given that the only thing that can happen is
	for a new announcement to be recorded"
	self announcer announce: aSignal! !

!CircularMemoryLogger methodsFor: 'ston persistence' stamp: ''!
basicFullBuffer: aBoolean
	"Set the receiver's fullBuffer.
	This is normally only used when loading saved instances from file"

	fullBuffer := aBoolean! !

!CircularMemoryLogger methodsFor: 'ston persistence' stamp: ''!
basicEntryCount: anInteger
	"Set the receiver's entryCount.
	This is normally only used when loading saved instances from file"

	entryCount := anInteger! !

!CircularMemoryLogger methodsFor: 'ston persistence' stamp: ''!
basicRecordings: aCollection
	"Set the receiver's recordings.
	This is normally only used when loading saved instances from file"

	recordings := aCollection! !

!CircularMemoryLogger methodsFor: 'ston persistence' stamp: ''!
asStonDictionary

	^ Dictionary new
		  at: #name put: name;
		  at: #recordings put: recordings;
		  at: #entryCount put: entryCount;
		  at: #index put: index;
		  at: #fullBuffer put: fullBuffer;
		  at: #loopCount put: loopCount;
		  yourself! !

!CircularMemoryLogger methodsFor: 'ston persistence' stamp: ''!
basicLoopCount: anInteger
	"Set the receiver's fullBuffer.
	This is normally only used when loading saved instances from file"

	loopCount := anInteger! !

!CircularMemoryLogger methodsFor: 'initialization' stamp: ''!
reset
	"it simply removes all recordings without
	affecting the running status of the logger"
	mutex critical: [ self basicReset ]! !

!CircularMemoryLogger class methodsFor: 'instance creation' stamp: ''!
fromSton: stonReader

	| logger |
	logger := self basicNew.
	stonReader parseListDo: [ :each :idx | 
		idx = 1 ifFalse: [ self error: 'Invalid STON' ].
		logger
			name: (each at: #name);
			basicRecordings: (each at: #recordings);
			basicEntryCount: (each at: #entryCount);
			basicIndex: (each at: #index);
			basicFullBuffer: (each at: #fullBuffer);
			basicLoopCount: (each at: #loopCount) ].

	^ logger! !

!ClapApplication commentStamp: ''!
I define basic boilerplate for delegating commandline behavior to the instance side, passing the arguments match.

Declare the main commandline in a class-side method, concluding the main meaning block as follows:

somethingCommandline
	<commandline>
	^ (ClapCommand withName: 'something')
		"... description, parameters, etc"
		meaning: [ :args |
			"... preliminary checks"
			(self with: args) execute ]!
!ClapApplication methodsFor: 'execution' stamp: ''!
outputStreamDo: aBlock
	aBlock value: self context stdout! !

!ClapApplication methodsFor: 'accessing' stamp: ''!
context
	^ arguments context! !

!ClapApplication methodsFor: 'execution' stamp: ''!
execute
	self subclassResponsibility! !

!ClapApplication methodsFor: 'initialization' stamp: ''!
setArguments: args
	arguments := args! !

!ClapApplication class methodsFor: 'instance creation' stamp: ''!
with: arguments
	^ self new
		setArguments: arguments;
		yourself! !

!ClapCodeEvaluator commentStamp: ''!
I evaluate code passed via standard input or as arguments from the command line.!
!ClapCodeEvaluator methodsFor: 'execution' stamp: ''!
execute
	| result |
	result := Smalltalk compiler evaluate: self source.
	
	self context hasSessionChanged "we might be waking up after a #save:andQuit:"
		ifFalse: [ self outputStreamDo: [ :out | out print: result; lf ] ]! !

!ClapCodeEvaluator methodsFor: 'accessing' stamp: ''!
source
	^ (arguments at: #EXPR) value! !

!ClapCodeEvaluator class methodsFor: 'command line' stamp: ''!
evaluate
	<commandline>
	^ (ClapCommand id: #evaluate)
		aliases: #('eval');
		description: 'Print the result of a Pharo expression';
		add: ClapFlag forHelp;
		add: ((ClapFlag id: #save)
			description: 'Save the image after evaluation');
		add: ((ClapFlag id: #keepAlive)
			description: 'Keep image running');
		add:	((ClapPositional id: #EXPR)
			description: 'The expression to evaluate, joining successive arguments with spaces (if omitted, read the expression from stdin)';
			multiple: true;
			meaning: [ :match | "let's copy all the bytes, twice, because the VM assumes some 8-bit encoding…"
				String space join: (match allOccurrencesCollect: #word) ];
			implicitMeaning: [ :match | "in the absence of an explicit argument, read from standard input"
				match context stdin upToEnd ]);
		meaning: [ :args | 
			args	at: #helpFlag ifPresent: [ :help | help value; exitSuccess ].
			(self with: args) execute ]! !

!ClapCodeEvaluatorTest methodsFor: 'tests' stamp: ''!
testEvaluatePipeIn
	context := (ClapCodeEvaluator evaluate activationWith: #('evaluate'))
		setStdio: (ClapPluggableStdio onByteArraysWithInput: 'Object class class class class');
		execute.
	
	self assertSuccess.
	self
		assert: self outputString
		equals: 'Metaclass' , self lineEnding! !

!ClapCodeEvaluatorTest methodsFor: 'tests' stamp: ''!
testEvaluateAliasMultipleArguments
	context := ClapCodeEvaluator evaluate activateWith: #('eval'
		'''(2+3)''' 'class' 'printString' ', String space ,' '(2+3)' 'class' 'printString').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: '''ByteString SmallInteger''' , self lineEnding! !

!ClapCodeEvaluatorTest methodsFor: 'tests' stamp: ''!
testEvaluateAliasSingleArgument
	context := ClapCodeEvaluator evaluate activateWith: #('eval' '1 class').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: 'SmallInteger' , self lineEnding! !

!ClapCommand commentStamp: ''!
I represent a command or subcommand.

Commands are recognized by a keyword, possibly with aliases for convenience. Besides positionals, commands can have flags, as well as nested (sub)commands.

Subcommands work like a trie, to organize and select the various behaviors of a complex program. At each level in a given invocation, at most one subcommand will be recognized, most often as the last parameter of its parent command.


To create a new instance of this class, you must write this:
	ClapCommand withName: <CommandName>
	
And after, if you want to add a flag:
	addFlag: ClapFlag withName: <FlagName>
	
If you want to add a positional:
	addPositional: ClapPositional withName: <PositionalName>
	
If you want to add a subcommand:
	addSubCommand: <subCommand>
	
Example for the eval command: 
	(ClapCommand withName: 'eval')
		addFlag: ClapFlag withName: 'help';
		addPositional: ClapPositionnal withName: 'smalltalk 		expression'.!
!ClapCommand methodsFor: 'adding' stamp: ''!
addTo: parentParameter
	^ parentParameter addSubcommand: self! !

!ClapCommand methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	subcommands := OrderedCollection new.
	flags := OrderedCollection new.! !

!ClapCommand methodsFor: 'documenting' stamp: ''!
synopsisOn: aStream
	aStream nextPutAll: self canonicalName! !

!ClapCommand methodsFor: 'accessing' stamp: ''!
subcommandNamed: specName ifNone: aBlock
	^ subcommands
		detect: [ :cmd | cmd hasAlias: specName ]
		ifNone: aBlock! !

!ClapCommand methodsFor: 'accessing' stamp: ''!
subcommands
	^ subcommands! !

!ClapCommand methodsFor: 'accessing' stamp: ''!
valueFor: aMatch with: arg
	^ aMatch
		matchedSubcommand: [ :sub | sub value: arg ]
		ifNone: [ super valueFor: aMatch with: arg ]! !

!ClapCommand methodsFor: 'enumerating' stamp: ''!
parametersDo: aBlock
	super parametersDo: aBlock.
	self flags do: aBlock.
	self subcommands do: aBlock! !

!ClapCommand methodsFor: 'matching - testing' stamp: ''!
canMatchWith: word
	^ self hasAlias: word! !

!ClapCommand methodsFor: 'adding' stamp: ''!
addSubcommand: aCommand
	subcommands add: aCommand! !

!ClapCommand methodsFor: 'accessing' stamp: ''!
flags
	^ flags! !

!ClapCommand methodsFor: 'adding' stamp: ''!
addFlag: aFlag
	flags add: aFlag! !

!ClapCommand class methodsFor: 'predefined commands' stamp: ''!
forHelp
	^ (self id: #helpCommand)
		description: 'Prints command documentation';
		canonicalName: 'help';

		add: ((ClapPositional id: #topic)
			description: 'The subcommand to document (defaults to the current one)';
			meaning: [ :pos :cmd | cmd subcommandNamed: pos word ifNone: nil ];
			implicitMeaning: [ :pos :cmd | cmd ]);

		meaning: [ :match | | doc parent query topic |
			doc := ClapDocumenter on: match context stdout.
			parent := match parent specification.
			query := match at: #topic.
			topic := query value: parent.
			topic
				ifNil: [ match context exitFailure: 'Unknown subcommand: ' , query word ]
				ifNotNil: [ doc explain: topic ] ]! !

!ClapCommandLineExamples commentStamp: ''!
Examples and demos of Clap commands (see class side, protocol commandline). Each of those methods builds and returns a command specification, which you can then run or just match against an actual invocation (an array of strings, as would be passed by a shell).

Arbitrary command instances can be run as do-its, but pay attention that text printed on the standard output will go nowhere unless the VM was launched from a terminal window:
	`ClapCommandLineExamples hello activateWith: #('hello' 'Pharo').`
	`ClapCommandLineExamples git activateWith: #('git' 'help' 'remote').`

To inspect the matches without activating the commands, replace #activateWith: with #match:
	`ClapCommandLineExamples hello match: #('hello' 'Pharo').`
	`ClapCommandLineExamples git match: #('git' 'help' 'remote').`

Commands registered in the system (returned from a class-side method with the <commandline> pragma) can also be invoked from the host system's command line:
```
	$PHARO_VM $IMAGE clap hello Pharo
```!
!ClapCommandLineExamples methodsFor: 'accessing' stamp: ''!
whispering
	^ self argumentAt: #whisper! !

!ClapCommandLineExamples methodsFor: 'running' stamp: ''!
sayHello
	"arguments validateAll."
	self sayHelloOn: self outStream! !

!ClapCommandLineExamples methodsFor: 'running' stamp: ''!
translationFor: lang from: translations
	^ translations at: self language
		ifAbsent: [ translations at: self defaultLanguage ]! !

!ClapCommandLineExamples methodsFor: 'running' stamp: ''!
voice: aString
	self shouting ifTrue: [ ^ aString asUppercase , '!!' ].
	self whispering ifTrue: [ ^ '(' , aString asLowercase , ')' ].
	^ aString , '.'! !

!ClapCommandLineExamples methodsFor: 'accessing' stamp: ''!
greeting
	^ self
		translationFor: self language
		from: self translatedGreetings! !

!ClapCommandLineExamples methodsFor: 'accessing - private' stamp: ''!
outStream
	^ outStream ifNil: [ outStream := VTermOutputDriver on: arguments context stdout ]! !

!ClapCommandLineExamples methodsFor: 'running' stamp: ''!
translatedRecipients
	^ {
		#de -> 'welt'.
		#en -> 'world'.
		#eo -> 'mondo'.
		#es -> 'mundo'.
		#fr -> 'tout le monde'.
		#uk -> 'svit'.
		#pt -> 'mundo'.
	} asDictionary! !

!ClapCommandLineExamples methodsFor: 'running' stamp: ''!
translatedGreetings
	^ {
		#de -> 'hallo'.
		#en -> 'hello'.
		#eo -> 'saluton'.
		#es -> 'hola'.
		#fr -> 'bonjour'.
		#uk -> 'pryvit'.
		#pt -> 'olá'.
	} asDictionary! !

!ClapCommandLineExamples methodsFor: 'running' stamp: ''!
execute
	self sayHello! !

!ClapCommandLineExamples methodsFor: 'accessing' stamp: ''!
recipients
	^ (arguments at: #who) allOccurrencesCollect: [ :arg | arg value: self ]! !

!ClapCommandLineExamples methodsFor: 'accessing - private' stamp: ''!
argumentAt: identifier
	^ (arguments at: identifier) value: self! !

!ClapCommandLineExamples methodsFor: 'accessing' stamp: ''!
defaultRecipient
	^ self
		translationFor: self language
		from: self translatedRecipients! !

!ClapCommandLineExamples methodsFor: 'running' stamp: ''!
sayHelloOn: aStream
	self recipients do: [ :each |
		aStream
			<< (self voice: self greeting , ', ' , each);
			lf ]! !

!ClapCommandLineExamples methodsFor: 'accessing' stamp: ''!
shouting
	^ self argumentAt: #shout! !

!ClapCommandLineExamples methodsFor: 'accessing' stamp: ''!
defaultLanguage
	^ #en! !

!ClapCommandLineExamples methodsFor: 'accessing' stamp: ''!
language
	^ self argumentAt: #language! !

!ClapCommandLineExamples class methodsFor: 'command line' stamp: ''!
hello
	"The usual Hello-World example, demonstrating a Clap command with a couple features."

	<commandline>
	^ (ClapCommand id: #hello)
		description: 'Provides greetings';
		add: ClapFlag forHelp;
		add: ((ClapFlag id: #whisper) description: 'Greet discretely');
		add: ((ClapFlag id: #shout) description: 'Greet loudly');
		add:
			((ClapFlag id: #language)
				description: 'Select language of greeting';
				add: ((ClapPositional id: #langCode)
					meaning: [ :pos | pos word asSymbol ];
					implicitMeaning: [ :arg :app | app defaultLanguage ]);
				meaning: [ :flag :app | (flag at: #langCode) value: app ]);
		add:
			((ClapPositional id: #who)
				description: 'Recipient of the greetings';
				multiple: true;
				implicitMeaning: [ :arg :app | app defaultRecipient ]);
		meaning: [ :args | 
			args at: #helpFlag ifPresent: [ :help | 
				help value; exitSuccess ].
			(self with: args) execute ]! !

!ClapCommandLineExamples class methodsFor: 'command line' stamp: ''!
git
	"A dummy command (no behavior besides help) to demonstrate nested subcommand and as a test subject for the documenter.
	<commandline> pragma omitted, because doesn't really make sense to make it available outside the image."
	^ (ClapCommand id: 'git')
		description: 'The stupid content tracker';
		add: ClapCommand forHelp;
		add: ((ClapCommand id: 'add')
			description: 'Add file contents to the index');
		add: ((ClapCommand id: 'branch')
			description: 'List, create, or delete branches');
		add: ((ClapCommand id: 'clone')
			description: 'Clone a repository into a new directory');
		add: ((ClapCommand id: 'commit')
			description: 'Record changes to the repository');
		add: ((ClapCommand id: 'init')
			description: 'Create an empty Git repository or reinitialize an existing one');
		add: ((ClapCommand id: 'remote')
			description: 'Manage set of tracked repositories';
			add: (ClapCommand id: 'add');
			add: (ClapCommand id: 'remove');
			add: (ClapCommand id: 'set-url');
			yourself);
		add: ((ClapCommand id: 'status')
			description: 'Show the working tree status');
		yourself! !

!ClapCommandLineHandler commentStamp: ''!
I hook Clap into the existing command-line handlers system.!
!ClapCommandLineHandler methodsFor: 'activation' stamp: ''!
handleExit: exit
	Smalltalk isInteractive
		ifFalse: [ ^ exit pass ].

	exit isSuccess
		ifFalse: [ ^ exit resignalAs: (Error new messageText: exit messageText) ]! !

!ClapCommandLineHandler methodsFor: 'activation' stamp: ''!
noneMatched
	self exitFailure: 'Unknown command'! !

!ClapCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	[
		ClapContext withPragmaCommands
			beObeyingExits;
			setStdio: Stdio;
			arguments: self arguments;
			executeToExit: [ :exit | self handleExit: exit ]
	]
	forkAt: Processor userSchedulingPriority
	named: 'Clap commandline handler process'! !

!ClapCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'clap'! !

!ClapCommandTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ ClapCommand! !

!ClapCommandTest methodsFor: 'tests' stamp: ''!
testMatches
	| subject arg argv match |
	subject := self namedSubject.
	arg := self subjectName copy.
	argv := { arg. #remainder } readStream.
	
	match := subject matchOn: argv.
	
	self deny: match isMismatch.
	self assert: match word equals: arg.
	self assert: argv next equals: #remainder! !

!ClapCommandTest methodsFor: 'tests' stamp: ''!
testMatchesWithSingleFlag
	| subject argv match |
	subject := self namedSubject.
	subject add: (ClapFlag id: #bar).
	argv := { self subjectName . '--bar' . #remainder } readStream.
		
	match := subject matchOn: argv.
	
	self deny: match isMismatch.
	self assert: (match includesMatchOf: #bar).
	self assert: argv next equals: #remainder! !

!ClapCommandTest methodsFor: 'tests' stamp: ''!
testMatchesWithSingleSubcommand
	| subject argv match |
	subject := self namedSubject.
	subject add: (ClapCommand id: #bar).
	argv := { self subjectName. 'bar'. #remainder } readStream.
	
	match := subject matchOn: argv.
	
	self deny: match isMismatch.
	self assert: (match includesMatchOf: #bar).
	self assert: argv next equals: #remainder! !

!ClapCommandTest methodsFor: 'tests' stamp: ''!
testMismatchesDifferentAlias
	| subject argv badCommand match |
	subject := self namedSubject.
	badCommand := self subjectName , 'NOT'.
	argv := { badCommand } readStream.
	
	match := subject matchOn: argv.
	
	self assert: match isMismatch.
	self
		assert: argv next
		identicalTo: badCommand! !

!ClapCommandTest methodsFor: 'tests' stamp: ''!
testAddSubcommand
	| subject cmd |
	subject := self namedSubject.
	cmd := ClapCommand id: #cmd.
	subject add: cmd.
	
	self assert: (subject subcommands includes: cmd)! !

!ClapCommandTest methodsFor: 'tests' stamp: ''!
testMatchesWithSinglePositional
	| subject argv match |
	subject := self namedSubject.
	subject add: (ClapPositional id: #bar).
	argv := { self subjectName copy. 'valueforbar'. #remainder } readStream.

	match := subject matchOn: argv.

	self deny: match isMismatch.
	self
		assert: match word
		equals: self subjectName.
	self assert: (match includesMatchOf: #bar).
	self
		assert: (match at: #bar) word
		equals: 'valueforbar'.
	self assert: argv next equals: #remainder! !

!ClapCommandTest methodsFor: 'tests' stamp: ''!
testMatchingStopsAtWrongFlag
	| subject argv badFlag match |
	subject := self namedSubject.
	subject add: (ClapFlag id: #bar).
	badFlag := '--notbar'.
	argv := { self subjectName. badFlag } readStream.

	match := subject matchOn: argv.

	self assert: match isMatch.
	self
		assert: argv next
		identicalTo: badFlag! !

!ClapCommandTest methodsFor: 'tests' stamp: ''!
testAddFlag
	| subject flag |
	subject := self namedSubject.
	flag := ClapFlag id: #flag.
	subject add: flag.
	
	self assert: (subject flags includes: flag)! !

!ClapCompositeMatch commentStamp: ''!
I am a match for a composite parameter specification, and thus cover a (possibly empty) range of words in the arguments sequence.

I provide methods for querying and accessing the matches of my specification's children parameters.!
!ClapCompositeMatch methodsFor: 'accessing' stamp: ''!
stop
	^ children
		ifEmpty: [ self start - 1 ]
		ifNotEmpty: [ children last stop ]! !

!ClapCompositeMatch methodsFor: 'testing' stamp: ''!
includesMatchOf: identifierOrSpec
	^ children anySatisfy: [ :arg | arg isMatchOf: identifierOrSpec ]! !

!ClapCompositeMatch methodsFor: 'initialization' stamp: ''!
initialize
	children := OrderedCollection new! !

!ClapCompositeMatch methodsFor: 'accessing - children' stamp: ''!
occurrencesOf: identifierOrSpec
	^ children select: [ :child | identifierOrSpec identifiesClapParameter: child specification ]! !

!ClapCompositeMatch methodsFor: 'evaluating' stamp: ''!
positionalValues
	^ specification positionals
		collect: [ :each | (self at: each) value ]! !

!ClapCompositeMatch methodsFor: 'accessing - children' stamp: ''!
at: identifierOrSpec ifPresent: foundBlock
	^ children
		detect: [ :child | identifierOrSpec identifiesClapParameter: child specification ]
		ifFound: foundBlock! !

!ClapCompositeMatch methodsFor: 'matching' stamp: ''!
completeMatchOn: aStream
	startIndex := aStream position + 1.
	self matchChildrenOn: aStream! !

!ClapCompositeMatch methodsFor: 'enumerating' stamp: ''!
occurrencesOf: identifierOrSpec do: aBlock
	^ children
		select: [ :child | identifierOrSpec identifiesClapParameter: child specification ]
		thenDo: aBlock! !

!ClapCompositeMatch methodsFor: 'validation' stamp: ''!
validateOn: aReport
	super validateOn: aReport.
	children do: [ :each | each validateOn: aReport ]! !

!ClapCompositeMatch methodsFor: 'accessing - children' stamp: ''!
at: identifierOrSpec
	^ self at: identifierOrSpec
		ifAbsent: [
			specification at: identifierOrSpec
				ifPresent: [ :spec | ClapImplicit of: spec in: self ]
				ifAbsent: [ self notYetImplemented ] ]! !

!ClapCompositeMatch methodsFor: 'matching' stamp: ''!
detectMatchOn: aStream ifFound: foundBlock ifNone: noneBlock
	self specification parametersDo: [ :param |
		(param isMultiple or: (self includesMatchOf: param) not)
			ifTrue: [ | sub |
				sub := param matchOn: aStream.
				sub isMismatch
					ifFalse: [ ^ foundBlock cull: sub ] ] ].
	^ noneBlock value! !

!ClapCompositeMatch methodsFor: 'accessing - children' stamp: ''!
at: identifierOrSpec ifAbsent: absentBlock
	^ children
		detect: [ :child | identifierOrSpec identifiesClapParameter: child specification ]
		ifNone: absentBlock! !

!ClapCompositeMatch methodsFor: 'accessing - children' stamp: ''!
matchedSubcommand: foundBlock ifNone: noneBlock
	^ children
		detect: [ :child | specification subcommands includes: child specification ]
		ifFound: [ :cmdMatch | foundBlock cull: cmdMatch ]
		ifNone: noneBlock! !

!ClapCompositeMatch methodsFor: 'matching' stamp: ''!
addChild: aSubExpression
	children add: aSubExpression! !

!ClapCompositeMatch methodsFor: 'accessing - children' stamp: ''!
at: identifierOrSpec ifPresent: foundBlock ifAbsent: absentBlock
	^ children
		detect: [ :child | identifierOrSpec identifiesClapParameter: child specification ]
		ifFound: foundBlock
		ifNone: absentBlock! !

!ClapCompositeMatch methodsFor: 'matching' stamp: ''!
matchChildrenOn: aStream
	[ self
		detectMatchOn: aStream
		ifFound: [ :arg | arg recordIn: self ]
		ifNone: [ ^ self ]
	] repeat! !

!ClapCompositeMatch methodsFor: 'enumerating' stamp: ''!
occurrencesOf: identifierOrSpec collect: aBlock
	^ children
		select: [ :child | identifierOrSpec identifiesClapParameter: child specification ]
		thenCollect: aBlock! !

!ClapCompositeMatch methodsFor: 'accessing - children' stamp: ''!
flags
	^ children select: [ :each | specification flags includes: each specification ]! !

!ClapContext commentStamp: ''!
I represent the (stateful) context in which command parsing & execution are happening.
My specification is the root command or parameter that will be matched against the the sequence of arguments I receive.
To enable dependency injection, all command code should ask me for any external resource (e.g. exiting, error handling, I/O streams).

For example, the command invocation "eval '1 + 2' " is represented by this:
	ClapContext on: #('eval' '1 + 2')
!
!ClapContext methodsFor: 'streams' stamp: ''!
stdio
	^ stdio ifNil: [ stdio := self defaultStdio ]! !

!ClapContext methodsFor: 'accessing' stamp: ''!
context
	^ self! !

!ClapContext methodsFor: 'streams' stamp: ''!
binaryStderr
	^ self stdio stderr! !

!ClapContext methodsFor: 'running' stamp: ''!
exitSuccess: message
	^ Exit signalSuccess: message! !

!ClapContext methodsFor: 'activation' stamp: ''!
rememberSession
	session := Smalltalk session! !

!ClapContext methodsFor: 'initialization' stamp: ''!
arguments: aCollection
	arguments := aCollection! !

!ClapContext methodsFor: 'testing' stamp: ''!
shouldObeyExit
	^ obeyingExits and: [ Smalltalk isInteractive not ]! !

!ClapContext methodsFor: 'streams' stamp: ''!
stdout
	^ self stdoutEncoded: 'utf8'! !

!ClapContext methodsFor: 'accessing' stamp: ''!
exit
	^ self exitSuccess! !

!ClapContext methodsFor: 'streams' stamp: ''!
stdoutEncoded: anEncoding
	^ ZnNewLineWriterStream on:
		(ZnCharacterWriteStream on: self binaryStdout encoding: anEncoding)! !

!ClapContext methodsFor: 'activation' stamp: ''!
execute
	^ self executeToExit: [ :exc | self handleExit: exc ]! !

!ClapContext methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		print: arguments;
		nextPut: $)! !

!ClapContext methodsFor: 'validation' stamp: ''!
validateOn: aReport
	match validateOn: aReport.
	aReport add: (ClapLeftoversValidation new validate: self).

	^ aReport! !

!ClapContext methodsFor: 'accessing' stamp: ''!
exitException
	^ exitException! !

!ClapContext methodsFor: 'accessing' stamp: ''!
match
	^ match ifNil: [ self doMatch ]! !

!ClapContext methodsFor: 'activation' stamp: ''!
noneMatched
	^ self exitFailure: 'Unknown command'! !

!ClapContext methodsFor: 'accessing' stamp: ''!
leftovers
	^ leftovers! !

!ClapContext methodsFor: 'initialization' stamp: ''!
beObeyingExits
	obeyingExits := true! !

!ClapContext methodsFor: 'streams' stamp: ''!
stderr
	^ self stderrEncoded: 'utf8'! !

!ClapContext methodsFor: 'validation' stamp: ''!
allValidations
	^ self validateOn: ClapValidationReport success.! !

!ClapContext methodsFor: 'matching' stamp: ''!
doMatch
	| args |
	args := self arguments readStream.
	match := self specification matchOn: args.
	match parent: self.
	leftovers := args upToEnd.
	^ match! !

!ClapContext methodsFor: 'running' stamp: ''!
exitSuccess
	^ Exit signalSuccess! !

!ClapContext methodsFor: 'running' stamp: ''!
exitFailure: message
	^ Exit signalFailure: message! !

!ClapContext methodsFor: 'running' stamp: ''!
exit: status message: message
	^ (Exit status: status) signal: message! !

!ClapContext methodsFor: 'activation' stamp: ''!
handleExit: exit
	self hasSessionChanged ifTrue: [ ^ self ].

	self shouldObeyExit
		ifTrue: [ exit pass ]! !

!ClapContext methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!ClapContext methodsFor: 'initialization' stamp: ''!
initialize
	arguments := #().
	obeyingExits := false! !

!ClapContext methodsFor: 'activation' stamp: ''!
hasSessionChanged
	^ session ~~ Smalltalk session! !

!ClapContext methodsFor: 'initialization' stamp: ''!
setStdio: anStdio
	stdio := anStdio! !

!ClapContext methodsFor: 'running' stamp: ''!
exit: status
	^ (Exit status: status) signal! !

!ClapContext methodsFor: 'activation' stamp: ''!
executeToExit: exitBlock
	^ [
		self rememberSession;
			ifMatch: [ :m | 
				m value: self.
				self exitSuccess ]
			ifMismatch: [ self noneMatched ]
	]
		on: Exit
		do: [ :exception |
			exitException := exception.
			exitBlock value: self exitException ]! !

!ClapContext methodsFor: 'running' stamp: ''!
exitFailure
	^ Exit signalFailure! !

!ClapContext methodsFor: 'accessing' stamp: ''!
documenter
	^ ClapDocumenter on: self stdout! !

!ClapContext methodsFor: 'streams' stamp: ''!
stdinEncoded: anEncoding
	^ ZnCharacterReadStream
		on: self binaryStdin
		encoding: anEncoding! !

!ClapContext methodsFor: 'streams' stamp: ''!
stdin
	^ self stdinEncoded: 'utf8'! !

!ClapContext methodsFor: 'accessing' stamp: ''!
exitStatus
	^ exitException status! !

!ClapContext methodsFor: 'streams' stamp: ''!
binaryStdout
	^ self stdio stdout! !

!ClapContext methodsFor: 'streams' stamp: ''!
defaultStdio
	^ ClapPluggableStdio onByteArrays! !

!ClapContext methodsFor: 'validation' stamp: ''!
validateAll
	| report |
	report := self allValidations.
	report isSuccess ifTrue: [ ^ self ].
	
	self stderr print: report; flush.
	self exitFailure! !

!ClapContext methodsFor: 'testing' stamp: ''!
ifMatch: matchBlock ifMismatch: failBlock
	^ self match
		ifMatch: matchBlock
		ifMismatch: failBlock! !

!ClapContext methodsFor: 'streams' stamp: ''!
binaryStdin
	^ self stdio stdin! !

!ClapContext methodsFor: 'streams' stamp: ''!
stderrEncoded: anEncoding
	^ ZnNewLineWriterStream on:
		(ZnCharacterWriteStream on: self binaryStderr encoding: anEncoding)! !

!ClapContext class methodsFor: 'accessing' stamp: ''!
pragmaCommands
	^ (Pragma allNamed: #commandline) collect: [ :pragma |
			| theClass theSelector |
			theClass := pragma method methodClass.
			theSelector := pragma method selector.
			self assert: [ theSelector isUnary ].
			
			theClass instanceSide
				perform: theSelector ]! !

!ClapContext class methodsFor: 'instance creation' stamp: ''!
withAll: commandCandidates
	^ self specification: (self defaultRoot addAll: commandCandidates; yourself)! !

!ClapContext class methodsFor: 'accessing' stamp: ''!
defaultRoot
	^ (ClapRoot id: #clap)
		description: 'Entry point for commands implemented with Clap';
		add: ClapFlag forHelp;
		add: ClapCommand forHelp;

		add: ((ClapFlag id: #save)
			description: 'Save the image after the command terminates');
		add: ((ClapFlag id: #noSave)
			description: 'Do not save the image even if the command is stateful');
		add: ((ClapFlag id: #rename)
			description: 'Rename the image as <NAME> before running the command';
			add: (ClapPositional id: #NAME));

		add: ((ClapFlag id: #keepAlive)
			description: 'Keep the image running after the command terminates');

		meaning: [ :args |
			args at: #helpFlag ifPresent: [ :help |
				help value; exitSuccess ].
			args validateAll ];
		yourself! !

!ClapContext class methodsFor: 'instance creation' stamp: ''!
withPragmaCommands 
	^ self withAll: self pragmaCommands! !

!ClapContextTest methodsFor: 'running' stamp: ''!
testWrongFlagMatchingButInvalid
	context
		arguments: #('hello' '--inexistent');
		match.
	
	self assert: context isMatch.
	self deny: context isValid.
	self
		assert: context leftovers
		equals: #('--inexistent')! !

!ClapContextTest methodsFor: 'running' stamp: ''!
testRootPositionalAfterSubcommand
	context
		arguments: #('hello' 'world' '--directory' 'foo/bar/baz');
		match.
	
	self assert: context isMatch.
	self deny: context isValid.
	self
		assert: context leftovers
		equals: #('--directory' 'foo/bar/baz')! !

!ClapContextTest methodsFor: 'running' stamp: ''!
testMatch
	context
		arguments: #('hello' 'world');
		match.
	
	self assert: context isMatch.
	self assert: context isValid.
	self assert: context leftovers isEmpty! !

!ClapContextTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	context := ClapContext specification: ClapCommandLineExamples hello! !

!ClapDocumentationFormatter commentStamp: ''!
I wrap a stream and generate documentation in a concrete format.

The intent is that sister classes will implement various concrete formats (HTML, Man page, LaTeX, colored terminal output…)!
!ClapDocumentationFormatter methodsFor: 'formattting' stamp: ''!
newLine
	^ stream newLine! !

!ClapDocumentationFormatter methodsFor: 'formattting' stamp: ''!
text: aString
	stream nextPutAll: aString! !

!ClapDocumentationFormatter methodsFor: 'accessing' stamp: ''!
columnIndent
	^ 16! !

!ClapDocumentationFormatter methodsFor: 'formattting' stamp: ''!
space: anInteger
	anInteger timesRepeat: [ stream space ]! !

!ClapDocumentationFormatter methodsFor: 'accessing' stamp: ''!
space
	^ stream space! !

!ClapDocumentationFormatter methodsFor: 'accessing' stamp: ''!
listIndent
	^ 4! !

!ClapDocumentationFormatter methodsFor: 'initialization' stamp: ''!
stream: aStream
	stream := 	(aStream respondsTo: #newLine)
		ifTrue: [ aStream ]
		ifFalse: [ ZnNewLineWriterStream on: aStream ]! !

!ClapDocumentationFormatter methodsFor: 'formattting' stamp: ''!
section: titleString with: contentsBlock
	| contents |
	contents := self class new.
	contentsBlock value: contents.
	
	contents isEmpty ifFalse: [
		stream
			nextPutAll: titleString; nextPut: $:;
			newLine;
			nextPutAll: contents contents ]! !

!ClapDocumentationFormatter methodsFor: 'formattting' stamp: ''!
tabularize: associations
	associations do: [ :each |
		| keyWidth |
		keyWidth := each key size + self listIndent.
		self space: self listIndent.
		stream nextPutAll: each key.
		keyWidth + self columnSeparation > self columnIndent
			ifTrue: [ self newLine; space: self columnIndent ]
			ifFalse: [ self space: self columnIndent - keyWidth ].
		stream nextPutAll: each value.
		self newLine ]! !

!ClapDocumentationFormatter methodsFor: 'accessing' stamp: ''!
contents
	^ stream contents! !

!ClapDocumentationFormatter methodsFor: 'accessing' stamp: ''!
columnSeparation
	^ 3! !

!ClapDocumentationFormatter methodsFor: 'flushing' stamp: ''!
flush
	stream flush! !

!ClapDocumentationFormatter class methodsFor: 'instance creation' stamp: ''!
on: aCharacterWriteStream
	^ self new
		stream: aCharacterWriteStream;
		yourself! !

!ClapDocumentationTest methodsFor: 'tests' stamp: ''!
testHelloShortUsage
	| command doc lines |
	command := ClapCommandLineExamples hello.
	
	doc := ClapDocumenter stringFrom: [ :documenter | documenter explain: command ].
	lines := doc lines.
	
	self assert: (doc endsWith: OSPlatform current lineEnding).
	self assert: lines first equals: 'Provides greetings'.
	self assert: lines second isEmpty.
	self assert: (lines third beginsWith: 'Usage: hello').
	self assert: (lines third endsWith: '[<who>]').! !

!ClapDocumenter commentStamp: ''!
I generate the documentation for a parameter.

I handle the general semantic structure of the documentation, but delegate the actual format to a formatter.!
!ClapDocumenter methodsFor: 'documenting' stamp: ''!
parameterDescriptions: aCommand
	self section: 'Parameters:' listing: aCommand positionals.
	self section: 'Options:' listing: aCommand flags.
	self section: 'Commands:' listing: aCommand subcommands! !

!ClapDocumenter methodsFor: 'documenting' stamp: ''!
positional: each
	^ formatter
		text: '[<';
		text: each canonicalName;
		text: '>]'! !

!ClapDocumenter methodsFor: 'documenting' stamp: ''!
flagSynopsis: each
	^ formatter
		text: '[';
		text: '--';
		text: each canonicalName;
		text: ']'! !

!ClapDocumenter methodsFor: 'documenting' stamp: ''!
descriptionSummary: aCommand
	formatter
		text: aCommand description;
		newLine! !

!ClapDocumenter methodsFor: 'accessing' stamp: ''!
contents
	^ formatter contents! !

!ClapDocumenter methodsFor: 'documenting' stamp: ''!
explain: aCommand
	self descriptionSummary: aCommand.
	formatter newLine.
	self usage: aCommand.
	self parameterDescriptions: aCommand.
	formatter flush! !

!ClapDocumenter methodsFor: 'documenting' stamp: ''!
usage: aCommand
	formatter
		text: 'Usage: ';
		text: aCommand canonicalName.
	aCommand flags ifNotEmpty: [ :flags | 
		formatter space.
		flags
			do: [ :each | self flagSynopsis: each ]
			separatedBy: [ formatter space ] ].
	aCommand positionals ifNotEmpty: [ :positionals | 
		formatter space.
		positionals
			do: [ :each | self positional: each ]
			separatedBy: [ formatter space ] ].
	formatter newLine! !

!ClapDocumenter methodsFor: 'initialization' stamp: ''!
initializeOn: aFormatter
	self initialize.
	formatter := aFormatter! !

!ClapDocumenter methodsFor: 'documenting' stamp: ''!
section: titleString listing: parameters
	parameters ifEmpty: [ ^ self ].

	formatter
		newLine;
		text: titleString;
		newLine;
		tabularize: (parameters collect:
			[ :each | each synopsis -> each description ])! !

!ClapDocumenter class methodsFor: 'convenience' stamp: ''!
stringFrom: documenterBlock
	^ String streamContents: [ :stream |
		documenterBlock value: (self on: stream)
	]! !

!ClapDocumenter class methodsFor: 'instance creation' stamp: ''!
new

	^ self error: 'A ClapDocumenter should be created with on:'! !

!ClapDocumenter class methodsFor: 'instance creation' stamp: ''!
on: aCharacterWriteStream
	^ self onFormatter: (ClapDocumentationFormatter on: aCharacterWriteStream)! !

!ClapDocumenter class methodsFor: 'convenience' stamp: ''!
explain: aClapParameter
	^ self stringFrom: [ :doc | doc explain: aClapParameter ]! !

!ClapDocumenter class methodsFor: 'instance creation' stamp: ''!
onFormatter: aFormatter
	^ self basicNew
		initializeOn: aFormatter! !

!ClapExplicit commentStamp: ''!
I represent an explicit match over words in the argument sequence, which constitutes an explicit occurrence of my specification.

My instances have a value, given by the meaning block of my specification.!
!ClapExplicit methodsFor: 'accessing' stamp: ''!
stop
	^ self subclassResponsibility! !

!ClapExplicit methodsFor: 'evaluating' stamp: ''!
words
	^ self context arguments
		collect: [ :str | str asByteArray utf8Decoded ]
		from: self start
		to: self stop! !

!ClapExplicit methodsFor: 'matching' stamp: ''!
completeMatchOn: aStream
	self subclassResponsibility! !

!ClapExplicit methodsFor: 'testing' stamp: ''!
isExplicit
	^ true! !

!ClapExplicit methodsFor: 'adding' stamp: ''!
recordIn: parentMatch
	self parent: parentMatch.
	self parent addChild: self! !

!ClapExplicit methodsFor: 'accessing' stamp: ''!
span
	^ self start to: self stop! !

!ClapExplicit methodsFor: 'accessing' stamp: ''!
start
	^ startIndex! !

!ClapExplicit methodsFor: 'evaluating' stamp: ''!
wordsDo: aBlock
	^ self context arguments
		from: self start
		to: self stop
		do: [ :str | aBlock value: str asByteArray utf8Decoded ]! !

!ClapExplicit class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == ClapExplicit! !

!ClapExpression commentStamp: ''!
I am a concrete manifestation (a match) of my specification (a ClapParameter) in the context of a specific command-line invocation.
!
!ClapExpression methodsFor: 'evaluating' stamp: ''!
value: arg
	^ specification valueFor: self with: arg! !

!ClapExpression methodsFor: 'accessing' stamp: ''!
context
	^ self subclassResponsibility! !

!ClapExpression methodsFor: 'testing' stamp: ''!
isMatchOf: identifierOrSpec
	^ identifierOrSpec identifiesClapParameter: self specification! !

!ClapExpression methodsFor: 'testing' stamp: ''!
ifMatch: aBlock
	^ self
		ifMatch: aBlock
		ifMismatch: [ self ]! !

!ClapExpression methodsFor: 'testing' stamp: ''!
isMatch
	^ self
		ifMatch: [ true ]
		ifMismatch: [ false ]! !

!ClapExpression methodsFor: 'testing' stamp: ''!
isMismatch
	^ self
		ifMatch: [ false ]
		ifMismatch: [ true ]! !

!ClapExpression methodsFor: 'validation' stamp: ''!
validateOn: aReport
	"Recursively validate the receiver and any subexpressions, enriching aReport"
	
	self specification
		validate: self on: aReport! !

!ClapExpression methodsFor: 'initialization' stamp: ''!
specification: anArgumentSpec 
	specification := anArgumentSpec! !

!ClapExpression methodsFor: 'evaluating' stamp: ''!
value
	^ self value: nil! !

!ClapExpression methodsFor: 'testing' stamp: ''!
isValid
	"Semantic validation, post-parse"
	self flag: 'obsolete?'.
	^ self allValidations isSuccess! !

!ClapExpression methodsFor: 'validation' stamp: ''!
validateAll
	"Validate the activation as a whole, or report and exit."
	self context validateAll! !

!ClapExpression methodsFor: 'testing' stamp: ''!
ifMismatch: aBlock
	^ self
		ifMatch: [ self ]
		ifMismatch: aBlock! !

!ClapExpression methodsFor: 'accessing' stamp: ''!
specification
	^ specification! !

!ClapExpression methodsFor: 'validation' stamp: ''!
allValidations
	^ self context allValidations! !

!ClapExpression methodsFor: 'testing' stamp: ''!
ifMatch: matchBlock ifMismatch: mismatchBlock
	^ self subclassResponsibility! !

!ClapExpression methodsFor: 'evaluating' stamp: ''!
exitSuccess
	^ self context exitSuccess! !

!ClapExpression class methodsFor: 'instance creation' stamp: ''!
specification: aParameter 
	^ self new
		specification: aParameter;
		yourself! !

!ClapExpression class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == ClapExpression! !

!ClapFlag commentStamp: ''!
I represent a flag (also called option).

A flag is recognized by its form, starting with dashes (e.g. `--foo` in long form or `-f` in short form). Often, flags are optional and take a boolean meaning representing their presence or absence, but they can also be used as named parameters or to accept complex values in the form of positionals.!
!ClapFlag methodsFor: 'adding' stamp: ''!
addTo: parentParameter
	^ parentParameter addFlag: self! !

!ClapFlag methodsFor: 'accessing' stamp: ''!
shortForm
	^ '-' , self shortName! !

!ClapFlag methodsFor: 'documenting' stamp: ''!
synopsisOn: aStream
	aStream
		nextPutAll: '--';
		nextPutAll: self canonicalName! !

!ClapFlag methodsFor: 'initialization' stamp: ''!
meaningScalar
	"Should only be allowed when there's a single positional"
	self meaning: [ :match | (match at: self positionals first) value ]! !

!ClapFlag methodsFor: 'initialization' stamp: ''!
meaningCollection
	self meaning: [ :match | match positionalValues ]! !

!ClapFlag methodsFor: 'accessing' stamp: ''!
shortName
	^ self canonicalName copyFrom: 1 to: 1! !

!ClapFlag methodsFor: 'matching - testing' stamp: ''!
canMatchWith: word
	^ word = self shortForm
		or: [ word = self longForm ]! !

!ClapFlag methodsFor: 'accessing' stamp: ''!
longForm
	^ '--' , self canonicalName! !

!ClapFlag class methodsFor: 'predefined flags' stamp: ''!
forHelp
	^ (self id: #helpFlag)
		description: 'Prints this documentation';
		canonicalName: 'help';
		
		meaning: [ :match |
			(ClapDocumenter on: (ZnCharacterWriteStream on: match context stdout))
				explain: match parent specification.
			true ]! !

!ClapFlag class methodsFor: 'evaluating' stamp: ''!
basicMeaning
	^ [ :match |
			match isExplicit and: [ match isMatch ] ]! !

!ClapFlagTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ ClapFlag! !

!ClapFlagTest methodsFor: 'tests' stamp: ''!
testMatchesShortForm
	| subject argv flagName match |
	subject := self namedSubject.
	flagName := '-' , (self subjectName first: 1).
	argv := { flagName. #remainder } readStream.
	
	match := subject matchOn: argv.
	
	self deny: match isMismatch.
	self
		assert: match specification
		identicalTo: subject.
	self assert: match word equals: flagName.
	self assert: argv next equals: #remainder! !

!ClapFlagTest methodsFor: 'tests' stamp: ''!
testMatchesLongForm
	| subject argv flagName match |
	subject := self namedSubject.
	flagName := '--' , self subjectName.
	argv := { flagName. #remainder } readStream.
	
	match := subject matchOn: argv.
	
	self deny: match isMismatch.
	self
		assert: match specification
		identicalTo: subject.
	self assert: match word equals: '--foo'.
	self assert: argv next equals: #remainder! !

!ClapFlagTest methodsFor: 'tests' stamp: ''!
testMismatchesWrongShortForm
	| subject argv badFlag match |
	subject := self namedSubject.
	badFlag := '-' , (self subjectName first: 1) asUppercase.
	argv := { badFlag } readStream.
	
	match := subject matchOn: argv.
	
	self assert: match isMismatch.
	self
		assert: match specification
		identicalTo: subject.
	self assert: match word equals: badFlag.
	self assert: argv next identicalTo: badFlag! !

!ClapFlagTest methodsFor: 'tests' stamp: ''!
testMismatchesWrongLongForm
	| subject argv badFlag match |
	subject := self namedSubject.
	badFlag := '--' , self subjectName , 'NOT'.
	argv := { badFlag } readStream.
	
	match := subject matchOn: argv.
	
	self assert: match isMismatch.
	self
		assert: match specification
		identicalTo: subject.
	self assert: match word equals: badFlag.
	self assert: argv next identicalTo: badFlag! !

!ClapHelloTest methodsFor: 'tests' stamp: ''!
testHello
	context := ClapCommandLineExamples hello activateWith: #('hello').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: 'hello, world.' , self lineEnding! !

!ClapHelloTest methodsFor: 'tests' stamp: ''!
testHelloShoutingShort
	context := ClapCommandLineExamples hello activateWith: #('hello' '-s').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: 'HELLO, WORLD!!' , self lineEnding! !

!ClapHelloTest methodsFor: 'tests' stamp: ''!
testHelloWhisperingShort
	context := ClapCommandLineExamples hello activateWith: #('hello' '-w').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: '(hello, world)' , self lineEnding! !

!ClapHelloTest methodsFor: 'tests' stamp: ''!
testHelloShoutingLong
	context := ClapCommandLineExamples hello activateWith: #('hello' '--shout').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: 'HELLO, WORLD!!' , self lineEnding! !

!ClapHelloTest methodsFor: 'tests' stamp: ''!
testHelloSomeone
	context := ClapCommandLineExamples hello activateWith: #('hello' 'someone').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: 'hello, someone.' , self lineEnding! !

!ClapHelloTest methodsFor: 'tests' stamp: ''!
testHelloWhisperingLong
	context := ClapCommandLineExamples hello activateWith: #('hello' '--whisper').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: '(hello, world)' , self lineEnding! !

!ClapHelloTest methodsFor: 'tests' stamp: ''!
testHelloBothShoutingAndWhispering
	context := ClapCommandLineExamples hello activateWith: #('hello' '--shout' '--whisper').
	
	self skip: 'should probably fail or obey the latest flag'! !

!ClapHelloTest methodsFor: 'tests' stamp: ''!
testHelloFrench
	context := ClapCommandLineExamples hello activateWith: #('hello' '--language' 'fr').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: 'bonjour, tout le monde.' , self lineEnding! !

!ClapHelloWorldTest methodsFor: 'tests - matching' stamp: ''!
testHello
	| match |
	match := hello match: #('hello').

	self deny: match isMismatch.
	self deny: (match includesMatchOf: #shout).
	self deny: (match includesMatchOf: #who)! !

!ClapHelloWorldTest methodsFor: 'tests - matching' stamp: ''!
testShoutingAfterthought
	| match |
	match := hello match: #('hello' 'world' '-s').

	self deny: match isMismatch.
	self assert: (match includesMatchOf: #shout).
	self assert: (match includesMatchOf: #who)! !

!ClapHelloWorldTest methodsFor: 'tests - matching' stamp: ''!
testLanguageFlag
	| match lang |
	lang := ClapPositional id: #language.
	hello add: ((ClapFlag id: #lang)
		add: lang;
		meaning: [ :flag | (flag at: lang) value]).

	match := hello match: #('hello' 'monde' '--lang' 'fr' '--shout').

	self deny: match isMismatch.
	self assert: (match includesMatchOf: #shout).
	self assert: (match includesMatchOf: #who).
	self
		assert: (match at: #who) word
		equals: 'monde'.
	self assert: (match includesMatchOf: #lang).
	self assert: ((match at: #lang) includesMatchOf: #language).
	self
		assert: (match at: #lang) value
		equals: 'fr'.
	self flag: 'needs a context'. "((match atName: 'lang') at: lang) context should be: match."! !

!ClapHelloWorldTest methodsFor: 'tests - matching' stamp: ''!
testHelloWorld
	| match |
	match := hello match: #('hello' 'world').

	self deny: match isMismatch.
	self deny: (match includesMatchOf: #shout).
	self assert: (match includesMatchOf: #who).
	self
		assert: (match at: #who) word
		equals: 'world'.
	self
		assert: (match at: #who) parent
		identicalTo: match! !

!ClapHelloWorldTest methodsFor: 'tests - matching' stamp: ''!
testShouting
	| match |
	match := hello match: #('hello' '--shout').

	self deny: match isMismatch.
	self assert: (match includesMatchOf: #shout).
	self deny: (match includesMatchOf: #who)! !

!ClapHelloWorldTest methodsFor: 'tests - matching' stamp: ''!
testShoutingWorld
	| match |
	match := hello match: #('hello' '--shout' 'world').

	self deny: match isMismatch.
	self assert: (match includesMatchOf: #shout).
	self assert: (match includesMatchOf: #who)! !

!ClapHelloWorldTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	hello := (ClapCommand id: #hello)
		add: (ClapFlag id: #shout);
		add: (ClapPositional id: #who)! !

!ClapImage class methodsFor: 'command line - subcommands' stamp: ''!
saveCommand

	^ (ClapCommand id: #save)
		  description: 'Save the image/changes file under a new name';
		  add: (ClapFlag id: #rename);
		  add: (ClapFlag id: #backup);
		  add: (ClapPositional id: #NAME);
		  yourself! !

!ClapImage class methodsFor: 'command line - subcommands' stamp: ''!
cleanupCommand

	^ (ClapCommand id: 'cleanup')
		  description: 'Clean caches & other temporary data from the image ';
		  add: ((ClapFlag id: 'aggressive') description: 'Also delete resources, change sets, etc');
		  add: ((ClapFlag id: 'release') description: 'Prepare for release (implies --aggressive)');
		  add: ((ClapFlag id: 'production') description: 'Unload tests, examples, etc, for production (implies --release)');
		  yourself! !

!ClapImage class methodsFor: 'command line' stamp: ''!
image
	<commandline>
	^ (ClapCommand id: #image)
		description: 'Manage image/changes files';
		add: self saveCommand;
		add: self cleanupCommand;
		meaning: [ :args | 
			args at: #helpFlag ifPresent: [ :help | 
				help value; exitSuccess ].
			args validateAll.
			(self with: args) execute ]! !

!ClapImplicit commentStamp: ''!
I represent the non-occurrence of a parameter in the argument sequence.

My instances are only created on demand in response to a query for a parameter that was not recognized in the argument sequence, i.e. it was omitted.
When evaluated with #value or #value:, my meaning is given by the implicit meaning block of my specification.!
!ClapImplicit methodsFor: 'evaluating' stamp: ''!
value: arg
	^ specification valueForImplicit: self with: arg! !

!ClapImplicit methodsFor: 'enumerating' stamp: ''!
allOccurrencesCollect: aBlock
	^ Array with: (aBlock value: self)! !

!ClapImplicit methodsFor: 'enumerating' stamp: ''!
allOccurrencesDo: aBlock
	aBlock value: self! !

!ClapImplicit methodsFor: 'testing' stamp: ''!
isExplicit
	^ false! !

!ClapImplicit methodsFor: 'testing' stamp: ''!
isValid
	self flag: 'could be false if resulted from wrong access...'.
	^ true! !

!ClapImplicit methodsFor: 'enumerating' stamp: ''!
allOccurrences
	^ Array with: self! !

!ClapImplicit class methodsFor: 'instance creation' stamp: ''!
of: aParameter in: parentMatch
	^ (self specification: aParameter)
		parent: parentMatch;
		yourself! !

!ClapLeftoversValidation commentStamp: ''!
I validate a Clap context by checking that it has matched completely, i.e. no word remains unmatched by a parameter.!
!ClapLeftoversValidation methodsFor: 'validation' stamp: ''!
description
	^ 'Unrecognized arguments'! !

!ClapLeftoversValidation methodsFor: 'validation' stamp: ''!
matches: aClapExpression
	^ aClapExpression context leftovers isEmpty! !

!ClapMatchesTest commentStamp: ''!
Tests around matching non-trivial commands and parameters.

In the absence of a parent context however, we can't test invalid or extra arguments; see ClapContextTest for this.!
!ClapMatchesTest methodsFor: 'tests' stamp: ''!
testFlagValue
	| match flagMatch |
	slowFlag meaning: [ :flag | flag isMismatch not ].
	
	match := clap match: #('clap' 'this' '--slow').
	flagMatch := ((match at: #this) at: slowFlag).
	
	self assert: flagMatch isExplicit.
	self
		assert: flagMatch parent parent
		identicalTo: match.
	self assert: flagMatch value! !

!ClapMatchesTest methodsFor: 'tests' stamp: ''!
testSubcommandAccessing
	| match |
	match := clap match: #('clap' 'this').
	
	self deny: match isMismatch.
	self deny: (match includesMatchOf: #directory).
	self assert: (match includesMatchOf: #this).
	self deny: (match includesMatchOf: #that).
	self deny: (match at: #this) isMismatch.
	self deny: ((match at: #this) includesMatchOf: #slow).
	
	self
		should: [ match at: #this ifPresent: [ Notification signal ] ]
		raise: Notification.
	self
		should: [ match at: #this ifPresent: [ Notification signal ] ifAbsent: [ self fail ] ]
		raise: Notification.! !

!ClapMatchesTest methodsFor: 'tests' stamp: ''!
testParameterizedFlagValue
	| match |
	dirFlag meaning: [ :flag | Path from: (flag at: #DIR) value ].
	
	match := clap match: #('clap' '--directory' 'foo/bar/baz').
	
	self
		assert: (match at: dirFlag) value
		equals: (Path * 'foo' / 'bar' / 'baz').! !

!ClapMatchesTest methodsFor: 'tests' stamp: ''!
testThis
	| match |
	match := clap match: #('clap' 'this').
	
	self deny: match isMismatch.
	self deny: (match includesMatchOf: #directory).
	self assert: (match includesMatchOf: #this).
	self deny: (match includesMatchOf: #that).
	self deny: (match at: #this) isMismatch.
	self deny: ((match at: #this) includesMatchOf: #slow)! !

!ClapMatchesTest methodsFor: 'tests' stamp: ''!
testRootPositionalBeforeSubcommand
	| match |
	match := clap match: #('clap' '--directory' 'foo/bar/baz' 'this').
	
	self deny: match isMismatch.
	self assert: (match includesMatchOf: #directory).
	self assert: (match includesMatchOf: #this).
	self deny: (match includesMatchOf: #that).
	self
		assert: ((match at: #directory) at: #DIR) value
		equals: 'foo/bar/baz'.
	self
		assert: (match at: dirFlag) positionalValues asArray
		equals: #( 'foo/bar/baz' )! !

!ClapMatchesTest methodsFor: 'tests' stamp: ''!
testFlagAbsentValue
	| match flagMatch |
	slowFlag meaning: [ :flag | flag isMismatch not ].
	
	match := clap matchOn: #('clap' 'this') readStream.
	flagMatch := (match at: #this) at: slowFlag.

	self deny: flagMatch isExplicit.
	self
		assert: flagMatch parent parent
		identicalTo: match.
	self deny: flagMatch value! !

!ClapMatchesTest methodsFor: 'tests' stamp: ''!
testFlagOmittedValue
	| match flagMatch |
	clap add: slowFlag. "we need another flag to follow the incomplete one"
	
	match := clap match: #('clap' '--directory' '--slow').
	flagMatch := match at: dirFlag.

	self assert: flagMatch isExplicit.
	self
		deny: flagMatch value
		identicalTo: '--slow'.
	self deny: (flagMatch at: #DIR) isExplicit.
	self assert: (match at: slowFlag) isExplicit.! !

!ClapMatchesTest methodsFor: 'tests' stamp: ''!
testWrongCommandMismatches
	| match |
	match := clap match: #('foo' '-d' 'bar/baz/qux' 'this').
	
	self assert: match isMismatch.
	self
		assert: match word
		equals: 'foo'! !

!ClapMatchesTest methodsFor: 'tests' stamp: ''!
testMultiplePositional
	| match |
	clap add: ((ClapPositional id: #list) multiple: true).
	
	match := clap match: #('clap' 'foo' 'bar' 'baz' '-d' 'a/b/c').
	
	self deny: match isMismatch.
	self assert: (match includesMatchOf: #directory).
	self assert: (match includesMatchOf: #list).
	self
		assertCollection: (match occurrencesOf: #list collect: #value) asArray
		equals: #('foo' 'bar' 'baz').
	self
		assertCollection: ((match at: #list) allOccurrencesCollect: #value) asArray
		equals: #('foo' 'bar' 'baz').! !

!ClapMatchesTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	dirFlag := (ClapFlag id: #directory)
		add: (ClapPositional id: #DIR);
		yourself.
	slowFlag := ClapFlag id: #slow.
	
	clap := (ClapCommand id: #clap)
		add: dirFlag;
		add: ((ClapCommand id: #this)
			add: slowFlag; yourself);
			yourself;
		add: ((ClapCommand id: #that)
			add: (ClapFlag id: #encore);
			add: (ClapPositional id: #clappee);
			yourself);
		yourself! !

!ClapMeaningsTest methodsFor: 'tests' stamp: ''!
testArgFlagCollectionMeaning
	| flag match |
	flag := (ClapFlag id: #foo)
		add: ((ClapPositional id: #bar) implicitMeaning: [ #nobar ]);
		add: ((ClapPositional id: #baz) implicitMeaning: [ #nobaz ]);
		meaningCollection.
	match := flag match: #('--foo' 'whatever 1' 'whatever 2').
	self assert: match value asArray equals: #('whatever 1' 'whatever 2').
	match := flag match: #('--foo' 'whatever').
	self assert: match value asArray equals: #('whatever' nobaz).
	match := flag match: #('--foo').
	self assert: match value asArray equals: #(nobar nobaz)! !

!ClapMeaningsTest methodsFor: 'tests' stamp: ''!
testSimpleFlagBasicMeaning
	| flag match |
	flag := ClapFlag id: #foo.

	match := flag match: #('--foo').
	
	self assert: match value.
	self deny: (flag match: #()) value! !

!ClapMeaningsTest methodsFor: 'tests' stamp: ''!
testArgFlagScalarMeaning
	| flag match |
	flag := (ClapFlag id: #foo)
		add: ((ClapPositional id: #bar) implicitMeaning: [ 'oops' ]);
		meaningScalar.
	match := flag match: #('--foo' 'whatever').
	self assert: match value equals: 'whatever'.
	match := flag match: #('--foo').
	self assert: match value equals: 'oops'.
	match := flag match: #().	"might be wrong, since this is really a mismatch"
	self assert: match value equals: 'oops'! !

!ClapMeaningsTest methodsFor: 'tests' stamp: ''!
testArgFlagBasicMeaning
	| flag match |
	flag := (ClapFlag id: #foo)
		add: (ClapPositional id: #bar).

	match := flag match: #('--foo' 'whatever').
	
	self assert: match value.
	self deny: (flag match: #()) value! !

!ClapMetacello methodsFor: 'baselines' stamp: ''!
baselineName
	^ arguments at: #NAME! !

!ClapMetacello methodsFor: 'execution' stamp: ''!
execute
	self outputStreamDo: [ :out | 
		out
			print: self repositoryUrl;
			print: self baselineName;
			newLine ]! !

!ClapMetacello methodsFor: 'accessing' stamp: ''!
version
	^ arguments at: #groups! !

!ClapMetacello methodsFor: 'accessing' stamp: ''!
repositoryUrl
	^ arguments at: #REPOSITORY! !

!ClapMetacello methodsFor: 'accessing' stamp: ''!
groups
	^ arguments at: #version! !

!ClapMetacello class methodsFor: 'command line' stamp: ''!
metacello
	<commandline>
	^ (ClapCommand id: #metacello)
		description: 'Load code using Metacello';
		add: ClapFlag forHelp;
		add: ClapCommand forHelp;
		add: ((ClapPositional id: #REPOSITORY)
			description: 'URL of the repository to load code from');
		add: ((ClapPositional id: #NAME)
			description: 'Name of the project to load');
		add: ((ClapFlag id: #groups)
			description: 'Names of groups to load, comma-separated';
			add: ((ClapPositional id: #GROUPS)
				meaning: [ :pos | pos word splitOn: $, ];
				implicitMeaning: [ #() ]));
		add: ((ClapFlag id: #version)
			description: 'Version to load (only valid for configurations)';
			add: (ClapPositional id: #VERSION));
		meaning: [ :args | 
			args	at: #helpFlag ifPresent: [ :help | help value; exitSuccess ].
			(self with: args) execute ]! !

!ClapMismatch commentStamp: ''!
I am a failed match of my specification at a given word of the arguments sequence.!
!ClapMismatch methodsFor: 'printing' stamp: ''!
printDetailsOn: aStream
	aStream
		print: specification;
		nextPutAll: ' mismatched'.
	word
		ifNil: [ aStream nextPutAll: ' (nothing to match)' ]
		ifNotNil: [
			aStream
				nextPutAll: ' word ''';
				nextPutAll: word;
				nextPutAll: '''' ]! !

!ClapMismatch methodsFor: 'matching' stamp: ''!
completeMatchOn: aStream
	word:= aStream peek.
	startIndex := aStream position + 1.! !

!ClapMismatch methodsFor: 'accessing' stamp: ''!
at: identifierOrSpec
	^ specification at: identifierOrSpec
		ifPresent: [ :spec | ClapImplicit of: spec in: self ]! !

!ClapMismatch methodsFor: 'testing' stamp: ''!
isValid
	^ false! !

!ClapMismatch methodsFor: 'adding' stamp: ''!
recordIn: parentMatch 
	"this match failed, so do nothing"! !

!ClapMismatch methodsFor: 'testing' stamp: ''!
ifMatch: matchingBlock ifMismatch: mismatchBlock
	^ mismatchBlock cull: self! !

!ClapNamedMatch commentStamp: ''!
I am a match for a named composite parameter; I cover at least one word (corresponding to one of my specification's aliases).!
!ClapNamedMatch methodsFor: 'matching' stamp: ''!
completeMatchOn: aStream
	keyword := aStream next.
	startIndex := aStream position.
	self matchChildrenOn: aStream! !

!ClapNamedMatch methodsFor: 'matching' stamp: ''!
word
	^ keyword! !

!ClapParameter commentStamp: ''!
My instances represent formal parameters in command-line invocations.

My subclasses implement the various conventional kinds of command-line parameters, and their instances are composed to specify the syntax of a given command.!
!ClapParameter methodsFor: 'testing' stamp: ''!
identifiesClapParameter: aParameter
	^ self == aParameter! !

!ClapParameter methodsFor: 'matching' stamp: ''!
matchOn: aStream
	^ (self newMatchAt: aStream)
		completeMatchOn: aStream;
		yourself! !

!ClapParameter methodsFor: 'adding' stamp: ''!
addTo: parentParameter
	^ self subclassResponsibility! !

!ClapParameter methodsFor: 'accessing' stamp: ''!
basicMeaning
	^ self class basicMeaning! !

!ClapParameter methodsFor: 'activating' stamp: ''!
activation
	^ ClapContext specification: self! !

!ClapParameter methodsFor: 'testing' stamp: ''!
isMultiple
	^ multiple! !

!ClapParameter methodsFor: 'accessing' stamp: ''!
description
	^ description! !

!ClapParameter methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self canonicalName;
		nextPut: $)! !

!ClapParameter methodsFor: 'validation' stamp: ''!
validationDiagnosticsFor: aMatch
	^ validationBlock
		ifNil: [ #() ]
		ifNotNil: [ validationBlock value: aMatch ]! !

!ClapParameter methodsFor: 'documenting' stamp: ''!
synopsisOn: aStream
	^ self subclassResponsibility! !

!ClapParameter methodsFor: 'documenting' stamp: ''!
synopsis
	^ String streamContents: [ :aStream | self synopsisOn: aStream ]! !

!ClapParameter methodsFor: 'accessing' stamp: ''!
matchClass
	^ self subclassResponsibility! !

!ClapParameter methodsFor: 'activating' stamp: ''!
activateWith: arguments
	"Convenience method for activating in an interactive context"
	^ (self activationWith: arguments) execute! !

!ClapParameter methodsFor: 'accessing' stamp: ''!
meaning
	^ meaningBlock! !

!ClapParameter methodsFor: 'initialization' stamp: ''!
validations: aBlock
	validationBlock := aBlock! !

!ClapParameter methodsFor: 'converting' stamp: ''!
asClapIdentifier
	^ self identifier! !

!ClapParameter methodsFor: 'initialization' stamp: ''!
multiple: aBoolean
	multiple := aBoolean! !

!ClapParameter methodsFor: 'accessing' stamp: ''!
implicitMeaning
	^ implicitMeaningBlock! !

!ClapParameter methodsFor: 'accessing' stamp: ''!
identifier
	^ identifier! !

!ClapParameter methodsFor: 'initialization' stamp: ''!
initialize
	description := ''.
	multiple := false.
	meaningBlock := self basicMeaning.
	implicitMeaningBlock := meaningBlock! !

!ClapParameter methodsFor: 'initialization' stamp: ''!
meaning: aBlock
	meaningBlock := aBlock! !

!ClapParameter methodsFor: 'accessing' stamp: ''!
valueForImplicit: aMatch with: arg
	^ self implicitMeaning cull: aMatch cull: arg! !

!ClapParameter methodsFor: 'initialization' stamp: ''!
description: aString
	description := aString! !

!ClapParameter methodsFor: 'initialization' stamp: ''!
implicitMeaning: aBlock
	implicitMeaningBlock := aBlock! !

!ClapParameter methodsFor: 'activating' stamp: ''!
activationWith: arguments
	^ self activation
		arguments: arguments;
		yourself! !

!ClapParameter methodsFor: 'accessing' stamp: ''!
valueFor: aMatch with: arg
	^ self meaning
		cull: aMatch
		cull: arg! !

!ClapParameter methodsFor: 'initialization' stamp: ''!
identifier: anIdentifier
	identifier := anIdentifier! !

!ClapParameter methodsFor: 'initialization' stamp: ''!
canonicalName: aName
	canonicalName := aName asString! !

!ClapParameter methodsFor: 'matching' stamp: ''!
match: aStreamOrSequenceable
	^ self matchOn: aStreamOrSequenceable readStream! !

!ClapParameter methodsFor: 'matching - testing' stamp: ''!
canMatchWith: word
	^ self subclassResponsibility! !

!ClapParameter methodsFor: 'accessing' stamp: ''!
canonicalName
	^ canonicalName ifNil: [ self identifier asString ]! !

!ClapParameter methodsFor: 'matching' stamp: ''!
newMatchAt: aStream
	^ ((self canMatchAt: aStream)
				ifTrue: [ self matchClass ]
				ifFalse: [ ClapMismatch ])
			specification: self! !

!ClapParameter methodsFor: 'validation' stamp: ''!
validate: aMatch on: aReport
	aReport addAll: (self validationDiagnosticsFor: aMatch)! !

!ClapParameter methodsFor: 'matching - testing' stamp: ''!
canMatchAt: aStream
	^ aStream atEnd not
		and: [ self canMatchWith: aStream peek ]! !

!ClapParameter class methodsFor: 'evaluating' stamp: ''!
basicMeaning
	^ [ :match | match ]! !

!ClapParameter class methodsFor: 'instance creation' stamp: ''!
id: anIdentifier
	^ self new
		identifier: anIdentifier asSymbol;
		yourself! !

!ClapParameter class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == ClapParameter! !

!ClapParameterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ self subclassResponsibility! !

!ClapParameterTest methodsFor: 'tests - fixture' stamp: ''!
namedSubject
	^ self classToTest id: self subjectName asSymbol! !

!ClapParameterTest methodsFor: 'tests' stamp: ''!
testIdentifierDerivedFromCanonicalName
	self
		assert: self namedSubject identifier
		equals: self subjectName asSymbol! !

!ClapParameterTest methodsFor: 'tests' stamp: ''!
testCanonicalName
	self
		assert: self namedSubject canonicalName
		equals: self subjectName asString! !

!ClapParameterTest methodsFor: 'tests' stamp: ''!
testSubjectIdentifier
	| subject |
	subject := self classToTest id: #subjectId.
	subject canonicalName: self subjectName.
	
	self
		assert: subject identifier
		equals: #subjectId.
	self
		assert: subject canonicalName
		equals: self subjectName! !

!ClapParameterTest methodsFor: 'tests - fixture' stamp: ''!
subjectName
	^ 'foo'! !

!ClapParameterTest methodsFor: 'tests' stamp: ''!
testMismatchesAtEnd
	| subject argv match |
	subject := self namedSubject.
	argv := #() readStream.
	
	match := subject matchOn: argv.
	
	self assert: match isMismatch.
	self
		assert: match specification
		identicalTo: subject! !

!ClapParameterTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!ClapParameterTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = ClapParameterTest! !

!ClapParameterized commentStamp: ''!
I am an abstract class specifying a parameter with nested positional parameters.!
!ClapParameterized methodsFor: 'initialization' stamp: ''!
aliases: aCollection
	aliases := aCollection! !

!ClapParameterized methodsFor: 'accessing' stamp: ''!
aliases
	^ aliases! !

!ClapParameterized methodsFor: 'adding' stamp: ''!
addPositional: aPositional
	positionals add: aPositional! !

!ClapParameterized methodsFor: 'adding' stamp: ''!
add: aParameter
	parameters
		at: aParameter identifier
		ifPresent: [ :param | self signalIdentifierConflictOf: aParameter with: param ]
		ifAbsentPut: aParameter.
	^ aParameter addTo: self! !

!ClapParameterized methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	parameters := OrderedDictionary new.
	positionals := OrderedCollection new.
	aliases := #()! !

!ClapParameterized methodsFor: 'accessing' stamp: ''!
at: identifierOrSpec ifPresent: presentBlock
	^ parameters
		at: identifierOrSpec asClapIdentifier
		ifPresent: presentBlock! !

!ClapParameterized methodsFor: 'private' stamp: ''!
signalIdentifierConflictOf: newParameter with: currentParameter
	Error signal: 'Identifier conflict (' , newParameter identifier , ')'! !

!ClapParameterized methodsFor: 'accessing' stamp: ''!
at: identifierOrSpec
	^ parameters at: identifierOrSpec asClapIdentifier! !

!ClapParameterized methodsFor: 'accessing' stamp: ''!
at: identifierOrSpec ifAbsent: absentBlock
	^ parameters at: identifierOrSpec asClapIdentifier
		ifAbsent: absentBlock! !

!ClapParameterized methodsFor: 'adding' stamp: ''!
addAll: parametersToAdd
	parametersToAdd do: [ :each | each addTo: self ]! !

!ClapParameterized methodsFor: 'enumerating' stamp: ''!
parametersDo: aBlock
	positionals do: aBlock! !

!ClapParameterized methodsFor: 'accessing' stamp: ''!
at: identifierOrSpec ifPresent: presentBlock ifAbsent: absentBlock
	^ parameters
		at: identifierOrSpec asClapIdentifier
		ifPresent: presentBlock
		ifAbsent: absentBlock! !

!ClapParameterized methodsFor: 'accessing' stamp: ''!
matchClass
	^ ClapNamedMatch! !

!ClapParameterized methodsFor: 'testing' stamp: ''!
hasAlias: aString
	^ aString = self canonicalName or: [ self aliases includes: aString ]! !

!ClapParameterized methodsFor: 'accessing' stamp: ''!
positionals
	^ positionals! !

!ClapParameterized class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == ClapParameterized! !

!ClapParameterizedTest methodsFor: 'tests' stamp: ''!
testIdentifierConflict
	| subject first second |
	subject := self namedSubject.
	first := ClapPositional id: #theSame.
	second := ClapPositional id: #theSame.
	subject add: first.

	self
		should: [ subject add: second ]
		raise: Error! !

!ClapParameterizedTest methodsFor: 'tests' stamp: ''!
testAddPositional
	| subject pos |
	subject := self namedSubject.
	pos := (ClapPositional id: #myPositional)
		canonicalName: 'ARG';
		yourself.
	subject add: pos.
	
	self assert: (subject at: #myPositional) identicalTo: pos.
	self assert: (subject positionals includes: pos).! !

!ClapParameterizedTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = ClapParameterizedTest! !

!ClapPharoApplication methodsFor: 'execution' stamp: ''!
prepareImage
	arguments at: #rename ifPresent: [ :rename | 
		| imageFile |
		imageFile := rename value asFileReference.
		self flag: 'check if it already exists & not same as current'.
		Smalltalk image
				changeImagePathTo: imageFile;
				closeSourceFiles;
				openSourceFiles ]! !

!ClapPharoApplication methodsFor: 'execution' stamp: ''!
execute
	arguments validateAll.
	arguments at: #helpFlag ifPresent: [ :help | help value; exitSuccess ].

	self prepareImage! !

!ClapPharoApplication methodsFor: 'execution' stamp: ''!
shouldSave
	^ (arguments at: #save) isExplicit
		or: [ (arguments at: #noSave) isExplicit not ]! !

!ClapPharoCommandsTest methodsFor: 'asserting' stamp: ''!
assertSuccess
	self assert: context exitStatus equals: 0! !

!ClapPharoCommandsTest methodsFor: 'accessing' stamp: ''!
outputString
	^ context stdio stdout contents utf8Decoded! !

!ClapPharoCommandsTest methodsFor: 'tests - fixture' stamp: ''!
lineEnding
	^ OSPlatform current lineEnding! !

!ClapPharoCommandsTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!ClapPharoCommandsTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = ClapPharoCommandsTest! !

!ClapPharoVersion commentStamp: ''!
I report release and version information about the image and VM, in various formats.!
!ClapPharoVersion methodsFor: 'version strings' stamp: ''!
numericVersionString
	^ SystemVersion current highestUpdate printString! !

!ClapPharoVersion methodsFor: 'accessing' stamp: ''!
formatStringFor: formatName
	^ self perform: (self formatSelectorFor: formatName)! !

!ClapPharoVersion methodsFor: 'version strings' stamp: ''!
vmVersionString
	^ Smalltalk vm version! !

!ClapPharoVersion methodsFor: 'version strings' stamp: ''!
fullVersionString
	^ SystemVersion current imageVersionString! !

!ClapPharoVersion methodsFor: 'version strings' stamp: ''!
hashVersionString
	^ SystemVersion current commitHash! !

!ClapPharoVersion methodsFor: 'execution' stamp: ''!
execute
	self showVersionsNamed: self formats! !

!ClapPharoVersion methodsFor: 'accessing' stamp: ''!
formats
	^ (arguments flags
		collect: [ :each | each specification canonicalName asSymbol ])
		ifEmpty: [ #(full) ]! !

!ClapPharoVersion methodsFor: 'accessing' stamp: ''!
formatSelectorFor: formatName
	^ formatName asSymbol , #VersionString! !

!ClapPharoVersion methodsFor: 'version strings' stamp: ''!
licenseVersionString
	^ Smalltalk licenseString! !

!ClapPharoVersion methodsFor: 'printing' stamp: ''!
showVersionsNamed: formatNames
	| out |
	out := self context stdout.
	formatNames do: [ :each | 
		out nextPutAll: (self formatStringFor: each); lf ].
	out flush! !

!ClapPharoVersion methodsFor: 'version strings' stamp: ''!
releaseVersionString
	^ SystemVersion current shortVersionString! !

!ClapPharoVersion class methodsFor: 'command line' stamp: ''!
version
	<commandline>
	^ (ClapCommand id: #version)
		description: 'Displays version information, in various formats';
		add: ClapFlag forHelp;
		add: ((ClapFlag id: #full) description: 'Full image version (default format)');
		add: ((ClapFlag id: #release) description: 'Major.minor alpha/stable');
		add: ((ClapFlag id: #numeric) description: '5-digit sequential integration number');
		add: ((ClapFlag id: #hash) description: 'Integration commit hash');
		add: ((ClapFlag id: #vm) description: 'VM build and version');
		add: ((ClapFlag id: #license) description: 'Licensing and copyright');
		meaning: [ :args |
			args at: #helpFlag ifPresent: [ :help |
				help value; exitSuccess ].
			args validateAll.

			(self with: args) execute ]! !

!ClapPharoVersionTest methodsFor: 'tests' stamp: ''!
testHelpFlag
	context := ClapPharoVersion version activateWith: #('version' '--help').
	
	self assertSuccess.
	self
		assert: self outputString lines first
		equals: 'Displays version information, in various formats'! !

!ClapPharoVersionTest methodsFor: 'tests' stamp: ''!
testLicenseFormat
	context := ClapPharoVersion version activateWith: #('version' '--license').
	
	self assertSuccess.
	self
		assert: self outputString trim
		equals: (Smalltalk licenseString withLineEndings: self lineEnding)! !

!ClapPharoVersionTest methodsFor: 'tests' stamp: ''!
testNumericFormat
	context := ClapPharoVersion version activateWith: #('version' '--numeric').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: SystemVersion current highestUpdate printString , self lineEnding! !

!ClapPharoVersionTest methodsFor: 'tests' stamp: ''!
testDefaultFormat
	context := ClapPharoVersion version activateWith: #('version').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: SystemVersion current imageVersionString , self lineEnding! !

!ClapPharoVersionTest methodsFor: 'tests' stamp: ''!
testHashFormat
	context := ClapPharoVersion version activateWith: #('version' '--hash').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: SystemVersion current commitHash , self lineEnding! !

!ClapPharoVersionTest methodsFor: 'tests' stamp: ''!
testMultipleFormats
	| lines |
	context := ClapPharoVersion version activateWith: #('version' '--hash' '--release' '--numeric').
	
	self assertSuccess.
	lines := self outputString lines.
	self
		assert: (lines at: 1)
		equals: SystemVersion current commitHash.
	self
		assert: (lines at: 2)
		equals: SystemVersion current shortVersionString.
	self
		assert: (lines at: 3)
		equals: SystemVersion current highestUpdate printString! !

!ClapPharoVersionTest methodsFor: 'tests' stamp: ''!
testVmFormat
	context := ClapPharoVersion version activateWith: #('version' '--vm').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: (Smalltalk vm version withLineEndings: self lineEnding)! !

!ClapPharoVersionTest methodsFor: 'tests' stamp: ''!
testReleaseFormat
	context := ClapPharoVersion version activateWith: #('version' '--release').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: SystemVersion current shortVersionString , self lineEnding! !

!ClapPharoVersionTest methodsFor: 'tests' stamp: ''!
testFullFormat
	context := ClapPharoVersion version activateWith: #('version' '--full').
	
	self assertSuccess.
	self
		assert: self outputString
		equals: SystemVersion current imageVersionString , self lineEnding! !

!ClapPluggableStdio commentStamp: ''!
I am a utility for replacing the normal Stdio during tests and maybe for activating Clap commands from a workspace.!
!ClapPluggableStdio methodsFor: 'accessing' stamp: ''!
stdout
	^ out! !

!ClapPluggableStdio methodsFor: 'accessing' stamp: ''!
stdin
	^ in! !

!ClapPluggableStdio methodsFor: 'accessing' stamp: ''!
stderr
	^ err! !

!ClapPluggableStdio methodsFor: 'initializing' stamp: ''!
initializeInput: inputStream output: outputStream error: errorStream
	in := inputStream.
	out := outputStream.
	err := errorStream! !

!ClapPluggableStdio class methodsFor: 'instance creation' stamp: ''!
onByteArraysWithInput: aString
	^ self onByteArraysWithInputBytes: aString utf8Encoded! !

!ClapPluggableStdio class methodsFor: 'instance creation' stamp: ''!
onByteArraysWithInputBytes: aByteArray
	^ self new
		initializeInput: aByteArray readStream
		output: #[] writeStream
		error: #[] writeStream! !

!ClapPluggableStdio class methodsFor: 'instance creation' stamp: ''!
onByteArrays
	^ self onByteArraysWithInputBytes: #[]! !

!ClapPositional commentStamp: ''!
I represent a free-form parameter which is passed as a single shell word and recognized based on its position in the input.
!
!ClapPositional methodsFor: 'adding' stamp: ''!
addTo: parentParameter
	^ parentParameter addPositional: self! !

!ClapPositional methodsFor: 'documenting' stamp: ''!
synopsisOn: aStream
	^ aStream
			nextPut: $<;
			nextPutAll: self canonicalName;
			nextPut: $>! !

!ClapPositional methodsFor: 'matching - testing' stamp: ''!
canMatchWith: word
	^ (word beginsWith: '-') not! !

!ClapPositional methodsFor: 'accessing' stamp: ''!
matchClass
	^ ClapWordMatch! !

!ClapPositional class methodsFor: 'evaluating' stamp: ''!
basicMeaning
	^ [ :match | match word ]! !

!ClapPositionalTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ ClapPositional! !

!ClapPositionalTest methodsFor: 'tests' stamp: ''!
testMatches
	| subject argv match |
	subject := self namedSubject.
	argv := { 'bar'. #remainder } readStream.
	
	match := subject matchOn: argv.
	
	self deny: match isMismatch.
	self
		assert: match specification
		identicalTo: subject.
	self assert: match word equals: 'bar'.
	self assert: argv next equals: #remainder! !

!ClapRoot commentStamp: ''!
I represent a nameless command, serving as the root of the command hierarchy and providing default behavior and error handling.
My subcommands are effectively the main commands available to the user.!
!ClapRoot methodsFor: 'matching - testing' stamp: ''!
canMatchWith: word
	^ true! !

!ClapRoot methodsFor: 'accessing' stamp: ''!
matchClass
	^ ClapCompositeMatch! !

!ClapSubExpression commentStamp: ''!
I am a node in the match tree.
My parent is either the match I'm a child of, or the context for the whole command invocation.!
!ClapSubExpression methodsFor: 'accessing' stamp: ''!
context
	^ parent context! !

!ClapSubExpression methodsFor: 'enumerating' stamp: ''!
allOccurrencesCollect: aBlock
	^ self parent
		occurrencesOf: self specification
		collect: aBlock! !

!ClapSubExpression methodsFor: 'accessing' stamp: ''!
parent: aMatch
	parent := aMatch! !

!ClapSubExpression methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!ClapSubExpression methodsFor: 'enumerating' stamp: ''!
allOccurrencesDo: aBlock
	^ self parent
		occurrencesOf: self specification
		do: aBlock! !

!ClapSubExpression methodsFor: 'testing' stamp: ''!
isExplicit
	^ self subclassResponsibility! !

!ClapSubExpression methodsFor: 'testing' stamp: ''!
ifMatch: matchBlock ifMismatch: mismatchBlock
	^ matchBlock cull: self! !

!ClapSubExpression methodsFor: 'enumerating' stamp: ''!
allOccurrences
	^ self parent
		occurrencesOf: self specification! !

!ClapSubExpression class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == ClapSubExpression! !

!ClapTestRunner commentStamp: ''!
I run unit tests found in specified packages, and display their results to standard output.!
!ClapTestRunner methodsFor: 'accessing' stamp: ''!
suite
	suite ifNil: [ self buildSuite ].
	^ suite! !

!ClapTestRunner methodsFor: 'execution' stamp: ''!
execute
	| result |
	self outputStreamDo: [ :out |
		self suite
			when: TestAnnouncement
			do: [ :ann | out nextPutAll: ann test name; lf ];
			when: TestCaseAnnouncement
			do: [ :ann | out space; space; nextPutAll: ann testSelector; lf ].
		result := [ self suite run ]
			ensure: [ self suite unsubscribe: TestAnnouncement ].
		out print: result; lf
	].
	
	self context exitSuccess! !

!ClapTestRunner methodsFor: 'accessing' stamp: ''!
packages
	^ self packagePatterns
		flatCollect: [ :regex |
			RPackage organizer packages
				select: [ :package | regex matches: package name ]]
		as: Set! !

!ClapTestRunner methodsFor: 'private' stamp: ''!
buildSuite
	| packageSuites |
	packageSuites := self packages
		collect: [ :each | SUnitSuiteBuilder new visit: each ]
		thenReject: [ :each | each tests isEmpty ].
	suite := (TestSuite named: packageSuites size printString , ' packages')
		addTests: packageSuites! !

!ClapTestRunner methodsFor: 'accessing' stamp: ''!
packagePatterns
	^ arguments
		occurrencesOf: #PKG
		collect: #value! !

!ClapTestRunner class methodsFor: 'command line' stamp: ''!
test
	<commandline>
	^ (ClapCommand id: #test)
		add: ClapFlag forHelp;
		add: ((ClapFlag id: #xml)
			description: 'Output results in JUnit-compatible XML format');
		add: ((ClapFlag id: #tap)
			description: 'Output results in Test-Anything Protocol format');
		add: ((ClapPositional id: #PKG)
			description: 'Run tests from packages matching this pattern';
			multiple: true;
			meaning: [ :match | match word asRegex ]);
		meaning: [ :args |
			args at: #helpFlag ifPresent: [ :help |
				help value; exitSuccess ].
			args validateAll.
			
			(self with: args) execute ]! !

!ClapValidation commentStamp: ''!
I represent a validation criterium that various subjects might have to pass at a later point.
My subclasses implement specific validations for Clap parameters.!
!ClapValidation methodsFor: 'validation' stamp: ''!
failureDescriptionFor: anObject
	^ String streamContents: [ :str |
		str nextPutAll: 'Unrecognized arguments: '.
		anObject context leftovers
			do: [ :each | str nextPutAll: each ]
			separatedBy: [ str nextPutAll: ', ' ] ]! !

!ClapValidation methodsFor: 'validation' stamp: ''!
description
	^ self subclassResponsibility! !

!ClapValidation methodsFor: 'validation' stamp: ''!
matches: aClapExpression
	^ self subclassResponsibility! !

!ClapValidation methodsFor: 'validation' stamp: ''!
validate: anObject
	^ ClapValidationDiagnostic of: self subject: anObject! !

!ClapValidationDiagnostic commentStamp: ''!
I am the result of applying a validation to a given subject.
If the subject does not pass my criterium, I can provide a helpful description why.!
!ClapValidationDiagnostic methodsFor: 'testing' stamp: ''!
isFailure
	^ success not! !

!ClapValidationDiagnostic methodsFor: 'accessing' stamp: ''!
description
	^ validation failureDescriptionFor: subject! !

!ClapValidationDiagnostic methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: self description! !

!ClapValidationDiagnostic methodsFor: 'testing' stamp: ''!
isSuccess
	^ success! !

!ClapValidationDiagnostic methodsFor: 'initialization' stamp: ''!
validation: aValidation subject: anExpression
	validation := aValidation.
	subject := anExpression.
	success := validation matches: subject! !

!ClapValidationDiagnostic class methodsFor: 'instance creation' stamp: ''!
of: aValidation subject: anExpression
	^ self new
		validation: aValidation subject: anExpression;
		yourself! !

!ClapValidationReport commentStamp: ''!
I aggregate multiple validation diagnostics together.!
!ClapValidationReport methodsFor: 'testing' stamp: ''!
isFailure
	^ self isSuccess not! !

!ClapValidationReport methodsFor: 'controlling' stamp: ''!
add: aDiagnostic
	aDiagnostic isFailure ifTrue: [ problems add: aDiagnostic ].! !

!ClapValidationReport methodsFor: 'initialization' stamp: ''!
initialize
	problems := OrderedCollection new! !

!ClapValidationReport methodsFor: 'printing' stamp: ''!
printOn: aStream
	problems do: [ :each |
		aStream
			print: each;
			cr ]! !

!ClapValidationReport methodsFor: 'testing' stamp: ''!
isSuccess
	^ problems isEmpty! !

!ClapValidationReport methodsFor: 'controlling' stamp: ''!
addAll: diagnostics
	diagnostics do: [ :each | self add: each ]! !

!ClapValidationReport class methodsFor: 'instance creation' stamp: ''!
success
	^ self new! !

!ClapWordMatch commentStamp: ''!
I am a leaf match, covering a single word of the argument sequence.!
!ClapWordMatch methodsFor: 'accessing' stamp: ''!
stop
	^ self start! !

!ClapWordMatch methodsFor: 'matching' stamp: ''!
completeMatchOn: aStream
	word := aStream next.
	startIndex := aStream position.! !

!ClapWordMatch methodsFor: 'accessing' stamp: ''!
word
	^ word! !

!Class commentStamp: ''!
I add a number of facilities to those in ClassDescription:
	A set of all my subclasses (defined in ClassDescription, but only used here and below)
	A name by which I can be found in a SystemDictionary
	A classPool for class variables shared between this class and its metaclass
	A list of sharedPools which probably should be supplanted by some better mechanism.

My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription.

The slot 'subclasses' is a redundant structure.  It is never used during execution, but is used by the development system to simplify or speed certain operations.  !
!Class methodsFor: 'accessing - class hierarchy' stamp: ''!
addSubclass: aSubclass 
	"Make the argument, aSubclass, be one of the subclasses of the receiver. 
	Create an error notification if the argument's superclass is not the receiver."
	aSubclass superclass ~~ self 
		ifTrue: [^self error: aSubclass name , ' is not my subclass'].
	subclasses ifNil: [
		self subclasses: (Array with: aSubclass).
		^ self ].
	self subclasses do:[:cl| cl == aSubclass ifTrue:[^self]]. "Already my subclass"
	self subclasses: (subclasses copyWith: aSubclass).! !

!Class methodsFor: 'class variables' stamp: ''!
definesClassVariableNamed: aString
	"Return whether the receiver has a class variables (shared variables among its class and subclasses) named: aString"
	
	^ self classVarNames includes: aString! !

!Class methodsFor: 'initialization' stamp: ''!
removeFromSystem
	"Forget the receiver from the Smalltalk global dictionary. Any existing 
	instances will refer to an obsolete version of the receiver."
	self removeFromSystem: true.! !

!Class methodsFor: '*TraitsV2' stamp: ''!
immediateSubclass: aClassName uses: aTraitCompositionOrArray instanceVariableNames: instVarNameList 
	classVariableNames: classVarNames package: cat
	"Added to allow for a simplified subclass creation experience. "
	
	^ self immediateSubclass: aClassName 
		uses: aTraitCompositionOrArray
		instanceVariableNames: instVarNameList  
		classVariableNames: classVarNames 
		poolDictionaries: ''
		package: cat! !

!Class methodsFor: 'deprecation' stamp: ''!
deprecationRefactorings

	"Return a list of refactorings that will apply class deprecation in the system. E.g. to
	move installed extension methods to a proper class to which the deprecated class was renamed.
	For default deprecation use the following refactoring:
	^ { RBApplyClassDeprecationRefactoring rename: self to: #NewName } "	
	
	^ #()! !

!Class methodsFor: 'compiling' stamp: ''!
compileAllFrom: oldClass
	"Recompile all the methods in the receiver's method dictionary (not the
	subclasses). Also recompile the methods in the metaclass."

	super compileAllFrom: oldClass.
	self classSide compileAllFrom: oldClass classSide! !

!Class methodsFor: '*Monticello' stamp: 'nil'!
classDefinitions
	^ Array with: self asClassDefinition! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
	^ self
		variableWordSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		package: cat! !

!Class methodsFor: '*TraitsV2' stamp: ''!
variableWordSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNameList classVariableNames: classVarNames package: cat
	^ self
		variableWordSubclass: className
		uses: aTraitCompositionOrArray
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		package: cat! !

!Class methodsFor: 'slots' stamp: ''!
classVariablesNeedFullDefinition

	^ self classVariables anySatisfy: [ :each | each needsFullDefinition ]! !

!Class methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asFullRingDefinition
	"A behavior is converted to a ring class including its variables, methods, direct superclass, direct subclasses and the package in which is loaded.
	Active methods are generated and each knows its package as well.
	Note that for its direct superclass and subclasses no full definitions are requested. If you need to traverse hierarchies use #asRingDefinitionWithMethods:withSuperclasses:withSubclasses:withPackages:"
	
	| rgClass rgSuper rgSub rgMethod packageKeys |
	rgClass:= self asRingDefinition.
	rgClass package: (RGContainer packageOfClass: rgClass).
	
	self superclass notNil 
		ifTrue: [ 
			rgSuper := self superclass asRingDefinition.
			rgClass superclass: rgSuper ]
		ifFalse: [  
			self isTrait ifTrue: [ 
				rgSuper := Trait asRingDefinition.
				rgClass superclass: rgSuper. ]
			].

	self subclasses do:[ :each |
		rgSub := each asRingDefinition.
		rgSub superclass: rgClass ].
	
	packageKeys := RGContainer packageKeys.
	self methodsDo:[ :mth|  
			rgMethod := mth asActiveRingDefinition.
			rgClass addMethod: rgMethod.
			rgMethod package: (RGContainer packageOfMethod: rgMethod using: packageKeys) ].
	self classSide methodsDo:[ :mth|  
			rgMethod := mth asActiveRingDefinition.
			rgClass classSide addMethod: rgMethod.
			rgMethod package: (RGContainer packageOfMethod: rgMethod using: packageKeys) ].
	
	^ rgClass! !

!Class methodsFor: 'pool variables' stamp: ''!
hasSharedPools
	"Returns whether the receiver uses shared pools directly (Does not take into account that it may inherit shared pool uses."
	^ self sharedPools notEmpty! !

!Class methodsFor: '*Reflectivity' stamp: ''!
nonAnonymousClass
	^ self! !

!Class methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toTemporary: aTempVar
	self flag: 'Not sure what it should do. The tests are not passing for this... See method testLinkClassToTempVarNamed'.
	aTempVar link: aMetaLink! !

!Class methodsFor: 'class variables' stamp: ''!
classVariableNamed: aString
	"Answer the Class Variable"

	^self classVariableNamed: aString ifAbsent: [self error: 'no such class var']! !

!Class methodsFor: 'fileout' stamp: ''!
expandedDefinitionStringFor: aPrinter

	^ aPrinter expandedClassDefinitionString! !

!Class methodsFor: 'pool variables' stamp: ''!
addSharedPool: aSharedPool 
	"Add the argument, aSharedPool, as one of the receiver's shared pools. 
	Create an error if the shared pool is already one of the pools.
	This method will work with shared pools that are plain Dictionaries or thenewer SharedPool subclasses"

	(self sharedPools includes: aSharedPool)
		ifTrue: [^self error: 'This is already in my shared pool list'].
	self sharedPools == nil
		ifTrue: [self sharedPools: (OrderedCollection with: aSharedPool)]
		ifFalse: [self sharedPools add: aSharedPool]! !

!Class methodsFor: 'subclass creation - immediate' stamp: ''!
immediateSubclass: className instanceVariableNames: instVarNameList  
	classVariableNames: classVarNames package: cat
	"
	An immediate subclass define a class for which its value is coded within the OOP itself (like SmallInteger in 32 bits). It is not meant to be used by non-experimented users.
	
	Immediates are objects that are stored in an object pointer using a tag to distinguish them from ordinary object pointers.  In v3 the only immediate is SmallInteger.  In 32-but spur there are SmallInteger and Character.  An implication of this is that in spur all Characters can be compared using #==.  In 64-bit Spur there is also SmallFloat64.  If a float's exponent is in the middle 8-bits of the 11-bit exponent range then it will be immediate.  If a float's exponent is outside of the middle 8-bits it will be boxed.
	"
	^self immediateSubclass: className
		instanceVariableNames: instVarNameList 
		classVariableNames: classVarNames
		poolDictionaries: ''
		package: cat! !

!Class methodsFor: 'subclass creation' stamp: ''!
subclass: t instanceVariableNames: ins
	^ self
		subclass: t
		instanceVariableNames: ins
		classVariableNames: ''
		poolDictionaries: ''
		package: 'Unclassified'! !

!Class methodsFor: '*CodeExport' stamp: ''!
fileOutPool: aPool onFileStream: aFileStream 
	| aPoolName |
	(aPool  isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now'].
	aPoolName := self environment keyAtIdentityValue: aPool.
	SystemNotification signal: 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: 'copying' stamp: ''!
copyForAnnouncement
	"Answer a copy of the receiver to be used in the announcement of changes.
	You should not use this class for anything else, it is invalid."
	| newClass |
	
	
	newClass := self class copy new
		basicSuperclass: superclass;
		methodDict: self methodDict copy;
		setFormat: format;
		setName: name;
		organization: self organization copy;
		classPool: classPool copy;
		sharedPools: sharedPools copy.
	self class instSize+1 to: self class instSize do:
		[:offset | newClass instVarAt: offset put: (self instVarAt: offset)].
	newClass classLayout: (layout copy host: newClass).
	^ newClass! !

!Class methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterPreview: aBuilder

	^ aBuilder newCode
		beForScripting;
		beNotEditable;
		text: self definitionString;
		yourself! !

!Class methodsFor: 'private' stamp: ''!
getName

	^ name! !

!Class methodsFor: 'class variables' stamp: ''!
classVarNamed: aString
	"for compatibility"

	^self readClassVariableNamed: aString! !

!Class methodsFor: 'fileout' stamp: ''!
definitionStringFor: aConfiguredPrinter

	^ aConfiguredPrinter classDefinitionString! !

!Class methodsFor: '*TraitsV2' stamp: ''!
variableSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory

	^ self
		subclass: aName
		uses: aTraitComposition
		layout: VariableLayout
		slots: someInstanceVariableNames asSlotCollection
		classVariablesNames: someClassVariableNames
		poolDictionaries: someSharedPoolNames
		category: aCategory! !

!Class methodsFor: 'subclass creation - variableByte' stamp: ''!
variableDoubleByteSubclass: className instanceVariableNames: instVarNameList  classVariableNames: classVarNames package: cat

	^ self classInstaller
		make: [ :builder | 
			builder
				superclass: self;
				name: className;
				layoutClass: DoubleByteLayout;
				slots: instVarNameList asSlotCollection;
				sharedVariablesFromString: classVarNames;
				category: cat;
				environment: self environment ]! !

!Class methodsFor: '*CodeExport' stamp: ''!
fileOutSharedPoolsOn: aFileStream
	"file out the shared pools of this class after prompting the user about each pool"
	| poolsToFileOut |
	poolsToFileOut := self sharedPools select: 
		[:aPool | (self shouldFileOutPool: (self environment keyAtIdentityValue: aPool))].
	poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream].! !

!Class methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalCommentDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: ('classComment:', self name) asSymbol ifAbsentRegister: [
		RGComment parent: (self asRingMinimalDefinitionIn: anRGEnvironment).
	]. 
	! !

!Class methodsFor: '*Epicea' stamp: ''!
asEpiceaRingDefinition

	| ring |
	ring := (RGClassDefinition named: self name)
		        category: self category;
		        superclassName: self superclass asString;
		        "Note it's nil for ProtoObject"traitCompositionSource:
			        self traitCompositionString;
		        addInstanceVariables: self instVarNames;
		        addClassVariables: self classVarNames;
		        addSharedPools: self sharedPoolNames;
		        comment: self organization classComment;
		        stamp: self organization commentStamp;
		        definitionSource: self definitionString;
		        package: (EpPlatform current packageNameFor: self);
		        withMetaclass.

	ring classSide
		traitCompositionSource: self classSide traitCompositionString;
		definitionSource: self classSide definitionString;
		addInstanceVariables: self classSide instVarNames.

	^ ring! !

!Class methodsFor: 'organization' stamp: ''!
category
	"Answer the system organization category for the receiver. First check whether the
	category name stored in the ivar is still correct and only if this fails look it up
	(latter is much more expensive)"

	| result |
	self basicCategory ifNotNil: [ :symbol |
		((self environment organization listAtCategoryNamed: symbol) includes: self name)
			ifTrue: [ ^symbol ] ].
	result := (self environment organization categoryOfElement: self name)
		ifNil: [ #Unclassified ]
		ifNotNil: [:value | value].
	self basicCategory: result.
	
	^ result! !

!Class methodsFor: '*TraitsV2' stamp: ''!
variableWordSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNameList classVariableNames: classVarNames category: cat

	^ self
		variableWordSubclass: className
		uses: aTraitCompositionOrArray
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		package: cat! !

!Class methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionClassDefinition

	"This provides an editable comment of the current class"

	<inspectorPresentationOrder: 915 title: 'Definition'>
	^ SpCodePresenter new
		  beForScripting;
		  text: self definitionString;
		  beNotEditable! !

!Class methodsFor: 'accessing - class hierarchy' stamp: ''!
commonSuperclassWith: aClass
	"return the next common superclass between me and aClass. If I am the superclass of aClass, that is me"
	^ self withAllSuperclasses detect: [ :class | (aClass allSuperclasses includes: class) ] ifNone: nil! !

!Class methodsFor: 'accessing' stamp: ''!
name
	"Answer the name of the receiver."

	^ name ifNil: [ super name ]! !

!Class methodsFor: 'subclass creation - slots' stamp: ''!
subclass: aSubclassSymbol slots: slotDefinition classVariables: classVarDefinition poolDictionaries: someSharedPoolNames package: aCategorySymbol
	^ self classInstaller
		make: [ :builder | 
			builder
				name: aSubclassSymbol;
				superclass: self;
				slots: slotDefinition;
				sharedVariables: classVarDefinition;
				sharedPools: someSharedPoolNames;
				category: aCategorySymbol ]! !

!Class methodsFor: 'class variables' stamp: ''!
hasClassVariable: aGlobal
	"Return whether the receiver has a class variables (shared variables among its class and subclasses) named: aString"
	
	^ self classVariables identityIncludes: aGlobal! !

!Class methodsFor: 'pool variables' stamp: ''!
sharedPools
	"Answer an orderedCollection  of the shared pools declared in the receiver."

	^ sharedPools ifNil: [ sharedPools := OrderedCollection new ]! !

!Class methodsFor: 'testing' stamp: ''!
hasAbstractMethods
	"Tells whether the receiver locally defines an abstract method, i.e., a method sending subclassResponsibility"

	^ super hasAbstractMethods or: [ self classSide hasAbstractMethods ]! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: subclassName uses: aTraitComposition layout: aLayout slots: someSlots classVariables: someClassVariables poolDictionaries: somePoolDictionaries category: aCategory
	
	^ self classInstaller
		make: [ :builder | 
			builder
				name: subclassName;
				superclass: self;
				slots: someSlots;
				layoutClass: aLayout;
				sharedVariables: someClassVariables;
				sharedPools: somePoolDictionaries;
				traitComposition: aTraitComposition asTraitComposition;
				classTraitComposition: aTraitComposition asTraitComposition classComposition;
				category: aCategory ]! !

!Class methodsFor: '*ClassAnnotation' stamp: ''!
classAnnotationAt: selector
	^self classAnnotations 
		detect: [ :each | each declarationSelector = selector ]! !

!Class methodsFor: '*CodeExport' stamp: ''!
fileOutInitializerOn: aStream
	^self class fileOutInitializerOn: aStream! !

!Class methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitClass: self! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: aTraitName uses: aTraitCompositionOrArray instanceVariableNames: instVarNameList classVariableNames: classVarNames package: cat

	^ self
		subclass: aTraitName
		uses: aTraitCompositionOrArray
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		category: cat! !

!Class methodsFor: '*TraitsV2' stamp: ''!
weakSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNameList classVariableNames: classVarNames category: cat

	^ self
		weakSubclass: className
		uses: aTraitCompositionOrArray
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		category: cat! !

!Class methodsFor: 'subclass creation - weak' stamp: ''!
weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s package: cat
	"This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have weak indexable pointer variables."

	^ self classInstaller
		make: [ :builder | 
			builder
				superclass: self;
				name: t;
				layoutClass: WeakLayout;
				slots: f asSlotCollection;
				sharedVariablesFromString: d;
				sharedPools: s;
				category: cat;
				environment: self environment ]! !

!Class methodsFor: 'subclass creation - weak' stamp: ''!
ephemeronSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s package: cat
	"This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have weak indexable pointer variables."

	^ self classInstaller
		make: [ :builder | 
			builder
				superclass: self;
				name: t;
				layoutClass: EphemeronLayout;
				slots: f asSlotCollection;
				sharedVariablesFromString: d;
				sharedPools: s;
				category: cat;
				environment: self environment ]! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: t uses: aTraitComposition

	^ self
		subclass: t
		uses: aTraitComposition
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Unclassified'! !

!Class methodsFor: 'class variables' stamp: ''!
writeClassVariableNamed: aString value: anObject
	"Store anObject in the class variable."
	
	(self classVariableNamed: aString) write: anObject! !

!Class methodsFor: 'deprecation' stamp: ''!
applyDeprecation

	self deprecationRefactorings do: #execute.! !

!Class methodsFor: 'class variables' stamp: ''!
removeClassVarNamed: aString interactive: interactive
	"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 varUserClass |
	aSymbol := aString asSymbol.
	(self classPool includesKey: aSymbol)
		ifFalse: [ ^ self error: aString , ' is not a class variable' ].
	varUserClass := self anyUserOfClassVarNamed: aSymbol.
	varUserClass notNil & interactive ifTrue: [ 
		(self	confirm: (aString , ' is still used in code of class ' , varUserClass name , '.\Is it okay to move it to Undeclared?') withCRs)
			ifFalse: [ ^ self ] ].
	
	varUserClass 
		ifNotNil: [
			NewUndeclaredWarning signal: aString in: self name.
			Undeclared declare: aSymbol from: self classPool]
		ifNil: [ self classPool removeKey: aSymbol].
		
	self classPool isEmpty
		ifTrue: [ self classPool: nil ].
		
	SystemAnnouncer uniqueInstance classModificationAppliedTo: self! !

!Class methodsFor: '*TraitsV2' stamp: ''!
variableSubclass: aClassName uses: aTraitCompositionOrArray instanceVariableNames: instVarNameList classVariableNames: classVarNames category: cat

	^ self
		variableSubclass: aClassName
		uses: aTraitCompositionOrArray
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		category: cat! !

!Class methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asRingDefinitionWithMethods: methodsBoolean withSuperclasses: supersBoolean withSubclasses: subsBoolean withPackages: packsBoolean
	"Retrieves a ring class/trait based on the receiver.
	The data loaded in the class/trait (active methods, superclasses, subclasses and packages) is requested by the users.
	As it may need to traverse hierarchies for retrieving super and subclasses a ring slice is created as the container for every class, method and package.
	To retrieve the slice:  aRGClass environment "
	| rgClass rgSlice  rgPackageKeys |
	
	rgSlice := RGSlice named: #fromImage.
	packsBoolean ifTrue: [ 
		rgPackageKeys := rgSlice loadPackagesFromImage ].
	rgClass := self asRingDefinitionWithMethods: methodsBoolean withSuperclasses: supersBoolean withSubclasses: subsBoolean withPackageKeys: rgPackageKeys in: rgSlice.
	rgSlice cleanEmptyPackages.
	rgSlice loadTraitUsers.
		
	^ rgClass! !

!Class methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toClassVariable: aClassVariable
	aClassVariable link: aMetaLink! !

!Class methodsFor: '*Reflectivity' stamp: ''!
intanceSpecificMetaLinksAvailable
	^false! !

!Class methodsFor: 'copying' stamp: ''!
duplicateClassWithNewName: aSymbol
	| copysName class |
	copysName := aSymbol asSymbol.
	copysName = self name
		ifTrue: [ ^ self ].
	(self environment includesKey: copysName)
		ifTrue: [ ^ self error: copysName , ' already exists' ].
	class := self classInstaller
		make: [ :builder | 
			builder
				fillFor: self;
				name: copysName ].
	class copyAllCategoriesFrom: self.
	class class copyAllCategoriesFrom: self class.
	^ class! !

!Class methodsFor: 'subclass creation' stamp: ''!
classInstaller
	"Answer the class responsible of creating subclasses of myself in the system."
	^self isAnonymous 
		ifTrue: [Smalltalk anonymousClassInstaller]
		ifFalse: [Smalltalk classInstaller]! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
variableWordSubclass: className instanceVariableNames: instVarNameList classVariableNames: classVarNames category: cat
	"Added to allow for a simplified subclass creation experience. "

	^ self
		variableWordSubclass: className
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		package: cat! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
	^ self
		subclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		package: cat! !

!Class methodsFor: 'instance variables' stamp: ''!
addInstVarNamed: aString
	"Add the argument, aString, as one of the receiver's instance variables."

	aString substrings do: [ :each|
		self addSlot: (InstanceVariableSlot named: each asSymbol) ]! !

!Class methodsFor: '*OpalCompiler-Core' stamp: ''!
classSideCompiler
	"Redefine this method if you want to customize the compiler for class-side methods"
	^self classSideCompilerClass new
		environment: self classSide environment;
		class: self classSide! !

!Class methodsFor: 'testing' stamp: ''!
isObsolete
	"Return true if the receiver is obsolete."

	^ self propertyAt: #obsolete ifAbsent: false! !

!Class methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterReferenceFor: aStep
	<stSpotterOrder: 30>
	
	aStep listProcessor
			title: 'References';
			allCandidates: [ (SystemNavigation default allReferencesTo: self binding) collect: [:each | each compiledMethod ] ];
			itemName: [ :method | method displayString ];
			filter: StFilterSubstring! !

!Class methodsFor: '*TraitsV2' stamp: ''!
weakSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames package: aCategory

	^ self
		weakSubclass: aName
		uses: aTraitComposition
		instanceVariableNames: someInstanceVariableNames
		classVariableNames: someClassVariableNames
		poolDictionaries: someSharedPoolNames
		category: aCategory! !

!Class methodsFor: '*CodeExport' stamp: ''!
shouldFileOutPool: aPoolName
	"respond with true if the user wants to file out aPoolName"
	^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! !

!Class methodsFor: 'organization' stamp: ''!
environment: anEnvironment

	environment := anEnvironment! !

!Class methodsFor: 'subclass creation' stamp: ''!
subclass: aSubclassSymbol instanceVariableNames: instVarNameList classVariableNames: classVarNames package: aPackageSymbol
	"Added to allow for a simplified subclass creation experience. "

	^ self
		subclass: aSubclassSymbol
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		package: aPackageSymbol! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
variableSubclass: className instanceVariableNames: instVarNameList classVariableNames: classVarNames category: cat
	"Added to allow for a simplified subclass creation experience. "

	^ self
		variableSubclass: className
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		package: cat! !

!Class methodsFor: '*ClassAnnotation' stamp: ''!
classAnnotations
	^ClassAnnotation findAllAnnotationsFor: self! !

!Class methodsFor: 'accessing - class hierarchy' stamp: ''!
subclasses
	"Answer a Set containing the receiver's subclasses."

	^subclasses 
		ifNil: [ #() ]
		ifNotNil: [ subclasses copy ]! !

!Class methodsFor: 'testing' stamp: ''!
isUsed
	
	^ self hasSubclasses
		ifFalse: [ super isUsed ]
		ifTrue: [ true ]! !

!Class methodsFor: '*TraitsV2' stamp: ''!
weakSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory

	^ self
		subclass: aName
		uses: aTraitComposition
		layout: WeakLayout
		slots: someInstanceVariableNames asSlotCollection
		classVariablesNames: someClassVariableNames
		poolDictionaries: someSharedPoolNames
		category: aCategory! !

!Class methodsFor: 'pool variables' stamp: ''!
sharedPoolOfVarNamed: aString
	"Returns the SharedPool or nil from which the pool variable named aString is coming from."

	^ self sharedPools
		detect: [ :each | each usesClassVarNamed: aString ]
		ifNone: [ self superclass ifNotNil: [ self superclass sharedPoolOfVarNamed: aString ] ]! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: aSubclassSymbol uses: aTraitCompositionOrArray slots: slotDefinition classVariables: classVarDefinition category: aCategorySymbol

	^ self
		subclass: aSubclassSymbol
		uses: aTraitCompositionOrArray
		layout: self classLayout class
		slots: slotDefinition
		classVariables: classVarDefinition
		poolDictionaries: ''
		category: aCategorySymbol! !

!Class methodsFor: 'testing' stamp: ''!
isAnonymous
	^self getName isNil! !

!Class methodsFor: 'class variables' stamp: ''!
classVariableNamed: aString ifAbsent: absentBlock
	"Answer the Class Variable"

	^self classPool associationAt: aString asSymbol ifAbsent: absentBlock! !

!Class methodsFor: 'pool variables' stamp: ''!
definedVariables
	"return all the Variables defined by this class"
	^self slots, self classVariables! !

!Class methodsFor: 'class variables' stamp: ''!
removeClassVariable: aGlobal
	"Remove the class variable"
	self removeClassVarNamed: aGlobal name! !

!Class methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toSlotNamed: aSlotName
	self link: aMetaLink toSlot: (self nonAnonymousClass slotNamed: aSlotName)! !

!Class methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGClass named: self name asSymbol parent: anRGEnvironment]. 
	! !

!Class methodsFor: '*TraitsV2' stamp: ''!
variableSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames package: aCategory

	^ self
		variableSubclass: aName
		uses: aTraitComposition
		instanceVariableNames: someInstanceVariableNames
		classVariableNames: someClassVariableNames
		poolDictionaries: someSharedPoolNames
		category: aCategory! !

!Class methodsFor: 'compiling' stamp: ''!
reformatAll 
	"Reformat all methods in this class.
	Leaves old code accessible to version browsing"

	super reformatAll.		"me..."
	self classSide reformatAll.	"...and my metaclass"! !

!Class methodsFor: 'subclass creation - slots' stamp: ''!
subclass: aSubclassSymbol layout: layoutClass slots: slotDefinition classVariables: classVarDefinition poolDictionaries: someSharedPoolNames package: aCategorySymbol
	^ self classInstaller
		make: [ :builder | 
			builder
				name: aSubclassSymbol;
				superclass: self;
				layoutClass: layoutClass;
				slots: slotDefinition;
				sharedVariables: classVarDefinition;
				sharedPools: someSharedPoolNames;
				category: aCategorySymbol ]! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
subclass: aSubclassSymbol instanceVariableNames: instVarNameList classVariableNames: classVarNames category: aCategorySymbol
	"Added to allow for a simplified subclass creation experience. "

	^ self
		subclass: aSubclassSymbol
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		package: aCategorySymbol! !

!Class methodsFor: '*Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	aBuilder 
		header: [ aBuilder text: 'Class: '.
					aBuilder text: self name ] withLevel: 1;
		horizontalLine;
		text: aString! !

!Class methodsFor: 'class variables' stamp: ''!
classVarNames
	"Answer a collection of the receiver's class variable names."

	^self classPool keys sort! !

!Class methodsFor: 'slots' stamp: ''!
needsSlotClassDefinition
    "return true if we define something else than InstanceVariableSlots or normal class variables"

    ^ super needsSlotClassDefinition or: [ self classVariablesNeedFullDefinition ]! !

!Class methodsFor: 'subclass creation' stamp: ''!
subclass: t
	^ self
		subclass: t
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		package: 'Unclassified'! !

!Class methodsFor: '*Ring-Core' stamp: ''!
ensureRingDefinitionIn: anRGEnvironment

	^ anRGEnvironment ask behaviors 
		detect: [:each | each name = self name] 
		ifNone: [ 
			| behaviorModel |
			behaviorModel := self asRingMinimalDefinitionIn: anRGEnvironment.
			anRGEnvironment addBehavior: behaviorModel.
			behaviorModel]! !

!Class methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterMethodsFor: aStep
	<stSpotterOrder: 10>
	
	aStep listProcessor
			title: 'Instance methods';
			allCandidates: [ self methods ];
			itemName: [ :method | method selector ];
			filter: StFilterSubstring! !

!Class methodsFor: 'compiling' stamp: ''!
innerBindingOf: aSymbol
	"Answer the binding of some variable resolved in the scope of the receiver, or one of its superclass
	but do not look up binding in receiver's environment.
	Use #bindingOf: for looking up the variable binding in a full scope, including receiver's environment"

	"First look in classVar dictionary."
	(self classPool bindingOf: aSymbol) ifNotNil: [:binding | ^binding].
	"Next look in shared pools."
	self sharedPools do: [:pool | (pool bindingOf: aSymbol) ifNotNil: [:binding | ^binding]].
	self superclass ifNotNil: [:supercl | ^ supercl innerBindingOf: aSymbol].	
	^ nil! !

!Class methodsFor: '*TraitsV2' stamp: ''!
variableSubclass: aClassName uses: aTraitCompositionOrArray instanceVariableNames: instVarNameList classVariableNames: classVarNames package: cat

	^ self
		variableSubclass: aClassName
		uses: aTraitCompositionOrArray
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		category: cat! !

!Class methodsFor: 'accessing - class hierarchy' stamp: ''!
removeSubclass: aSubclass 
	"If the argument, aSubclass, is one of the receiver's subclasses, remove it."

	self subclasses == nil ifFalse:
		[self subclasses:  (self subclasses copyWithout: aSubclass).
		self subclasses isEmpty ifTrue: [self subclasses: nil]].! !

!Class methodsFor: 'accessing - parallel hierarchy' stamp: ''!
hasClassSide
	^self classSide notNil.! !

!Class methodsFor: 'compiling' stamp: ''!
hasBindingThatBeginsWith: aString
	"Answer true if the receiver has a binding that begins with aString, false otherwise"

	"First check the slots / instance variabless"
	(self classLayout hasBindingThatBeginsWith: aString) ifTrue: [^ true].

	"Then look in classVar dictionary"
	(self classPool hasBindingThatBeginsWith: aString) ifTrue: [ ^true].
	
	"Next look in shared pools"
	(self sharedPools anySatisfy: [:pool | pool hasBindingThatBeginsWith: aString ]) ifTrue: [ ^true].
	
	"Last: go to the outer environment"
	^ self environment hasBindingThatBeginsWith: aString! !

!Class methodsFor: 'private' stamp: ''!
setName: aSymbol

	name := aSymbol.! !

!Class methodsFor: '*TraitsV2' stamp: ''!
setTraitComposition: aTraitComposition
		
	^ self classInstaller
		update: self to: [ :builder | 
			builder
				fillFor: self;
				traitComposition: aTraitComposition asTraitComposition;
				classTraitComposition: aTraitComposition asTraitComposition classComposition]! !

!Class methodsFor: 'private' stamp: ''!
isValidTraitName: aSymbol

	aSymbol ifNil: [ ^ false ].
	^ aSymbol isValidGlobalName.! !

!Class methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating
	^self isObsolete not! !

!Class methodsFor: 'subclass creation - variableByte' stamp: ''!
variableDoubleWordSubclass: className instanceVariableNames: instVarNameList  classVariableNames: classVarNames package: cat

	^ self classInstaller
		make: [ :builder | 
			builder
				superclass: self;
				name: className;
				layoutClass: DoubleWordLayout;
				slots: instVarNameList asSlotCollection;
				sharedVariablesFromString: classVarNames;
				category: cat;
				environment: self environment ]! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
	^ self weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s package: cat! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: aSubclassSymbol uses: aTraitCompositionOrArray slots: slotDefinition classVariables: classVarDefinition poolDictionaries: someSharedPoolNames category: aCategorySymbol

	^ self
		subclass: aSubclassSymbol
		uses: aTraitCompositionOrArray
		layout: self classLayout class
		slots: slotDefinition
		classVariables: classVarDefinition
		poolDictionaries: someSharedPoolNames
		category: aCategorySymbol! !

!Class methodsFor: '*Roassal3' stamp: ''!
dependentClassesWithOccurences
	"Return the list of classes used myself. The result may contains multiple times the same element."
	
	"Morph dependentClassesWithOccurences"
	| cll | 
	cll := OrderedCollection new.
	"A class depends on its superclass"
	self superclass ifNotNil: [ cll add: self superclass ].
	
	"We unify a class and its metaclass"
	(self methods, self classSide methods) 
		do: [ :m | m literalsDo: [ :l | 
					"We also check if the method is not an extension"
					((((l isVariableBinding 
					and: [ l value notNil ]) 
					and: [ l value isBehavior ])
					and: [ m category notEmpty ] )
					and: [ m category first ~= $* ])  ifTrue: [ cll add: l value ] ]  ].
	^ cll asArray! !

!Class methodsFor: '*TraitsV2' stamp: ''!
variableByteSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory
	| oldClassOrNil actualLayoutClass |
	oldClassOrNil := self environment at: aName ifAbsent: [ nil ].
	actualLayoutClass := (oldClassOrNil notNil and: [ oldClassOrNil classLayout class == CompiledMethodLayout ])
		ifTrue: [ CompiledMethodLayout ]
		ifFalse: [ ByteLayout ].

	^ self
		subclass: aName
		uses: aTraitComposition
		layout: actualLayoutClass
		slots: someInstanceVariableNames asSlotCollection
		classVariablesNames: someClassVariableNames
		poolDictionaries: someSharedPoolNames
		category: aCategory! !

!Class methodsFor: '*CodeExport' stamp: ''!
fileOut
	"Create a file whose name is the name of the receiver with '.st' as the 
	extension, and file a description of the receiver onto it."
	
	| internalStream |
	internalStream := (String new: 100) writeStream.
	internalStream header; timeStamp.

	self hasSharedPools ifTrue: [
		self shouldFileOutPools
			ifTrue: [self fileOutSharedPoolsOn: internalStream]].
	self fileOutOn: internalStream.

	CodeExporter writeSourceCodeFrom: internalStream baseName: self name isSt: true! !

!Class methodsFor: 'accessing' stamp: ''!
basicCategory: aSymbol
	category := aSymbol! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: aSubclassSymbol uses: aTraitCompositionOrArray slots: slotDefinition classVariables: classVarDefinition poolDictionaries: someSharedPoolNames package: aCategorySymbol

	^ self
		subclass: aSubclassSymbol
		uses: aTraitCompositionOrArray
		layout: self classLayout class
		slots: slotDefinition
		classVariables: classVarDefinition
		poolDictionaries: someSharedPoolNames
		category: aCategorySymbol! !

!Class methodsFor: '*CodeExport' stamp: ''!
shouldFileOutPools
	"respond with true if the user wants to file out the shared pools"
	^self confirm: 'FileOut selected sharedPools?'! !

!Class methodsFor: 'subclass creation' stamp: ''!
newSubclass
	| i className |
	i := 1.
	[ className := (self name , i printString) asSymbol.
	self environment includesKey: className ] whileTrue: [ i := i + 1 ].
	^ self
		subclass: className
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		package: 'Unclassified'

	"Point newSubclass new"! !

!Class methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
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 classSide
				methodsDo: [ :mth | 
					rgMethod := mth asActiveRingDefinition.
					aRGSlice loadMethod: rgMethod inClass: rgClass classSide using: packageKeys ] ].
	supersBoolean
		ifTrue: [ 
			self superclass
				ifNotNil: [ 
					rgSuper := aRGSlice classNamed: self superclass name.
					rgSuper
						ifNil: [ 
							rgSuper := self superclass
								asRingDefinitionWithMethods: methodsBoolean
								withSuperclasses: supersBoolean
								withSubclasses: subsBoolean
								withPackageKeys: packageKeys
								in: aRGSlice ].
					rgClass superclass: rgSuper ] ].
	subsBoolean
		ifTrue: [ 
			subs := self subclasses reject: [ :sub | sub isMeta ].
			rgClass name = #Trait
				ifTrue: [ subs := aRGSlice environment allTraits ].
			subs
				do: [ :each | 
					rgSub := aRGSlice classNamed: each name.
					rgSub
						ifNil: [ 
							rgSub := each
								asRingDefinitionWithMethods: methodsBoolean
								withSuperclasses: supersBoolean
								withSubclasses: subsBoolean
								withPackageKeys: packageKeys
								in: aRGSlice ].
					rgSub superclass: rgClass ] ].
	^ rgClass! !

!Class methodsFor: '*Reflectivity' stamp: ''!
isInClassHierarchyOf: aClass

	^ (self includesBehavior: aClass) or: [ 
		  aClass includesBehavior: self ]! !

!Class methodsFor: 'class variables' stamp: ''!
readClassVariableNamed: aString
	"Answer the content of the Class Variable"

	^(self classVariableNamed: aString) read! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: aSubclassSymbol uses: aTraitCompositionOrArray layout: layoutClass slots: slotDefinition classVariables: classVarDefinition package: aCategorySymbol

	^ self
		subclass: aSubclassSymbol
		uses: aTraitCompositionOrArray
		layout: layoutClass
		slots: slotDefinition
		classVariables: classVarDefinition
		poolDictionaries: ''
		category: aCategorySymbol! !

!Class methodsFor: 'accessing' stamp: ''!
classPool: aDictionary
	classPool := aDictionary! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: subclassName uses: aTraitComposition layout: aLayout slots: someSlots classVariables: someClassVariables poolDictionaries: somePoolDictionaries package: aCategory
	
	^ self classInstaller
		make: [ :builder | 
			builder
				name: subclassName;
				superclass: self;
				slots: someSlots;
				layoutClass: aLayout;
				sharedVariables: someClassVariables;
				sharedPools: somePoolDictionaries;
				traitComposition: aTraitComposition asTraitComposition;
				classTraitComposition: aTraitComposition asTraitComposition classComposition;
				category: aCategory ]! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
ephemeronSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
	^ self ephemeronSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s package: cat! !

!Class methodsFor: 'subclass creation - variableWord' stamp: ''!
variableWordSubclass: className instanceVariableNames: instVarNameList classVariableNames: classVarNames package: cat
	"Variable word is like variable byte (ByteArray), variable size, with indices instead of named instance variables, but each index points to a full word (32 bits).
	
	Objects on the heap are either pointers or bits.  For example instances of Point, Array, BlockClosure etc are pointer objects.  But Bitmap, ByteString, WideString etc are bits objects.  In v3 bits objects are either a sequence of bytes (ByteArray, ByteString, ByteSymbol etc) or 32-bit words (WideString, Float, Bitmap etc).  Spur supports byte, short, word and double-word bits objects even though currently only byte and word classes exist.  16-bit strings will be useful on Windows, for example."

	^ self
		variableWordSubclass: className
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		package: cat! !

!Class methodsFor: 'testing' stamp: ''!
isClass

	^ true! !

!Class methodsFor: '*Reflectivity' stamp: ''!
newBreakpointForVariable: aVariableName
	^ VariableBreakpoint
		newBreakpointForVariable: aVariableName
		inClass: self! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: aSubclassSymbol uses: aTraitCompositionOrArray slots: slotDefinition classVariables: classVarDefinition package: aCategorySymbol

	^ self
		subclass: aSubclassSymbol
		uses: aTraitCompositionOrArray
		layout: self classLayout class
		slots: slotDefinition
		classVariables: classVarDefinition
		poolDictionaries: ''
		category: aCategorySymbol! !

!Class methodsFor: 'compiling' stamp: ''!
binding
   "Answer a binding for the receiver, sharing if possible"
   | binding |
	binding := self environment associationAt: self name ifAbsent: [LiteralVariable key: nil value: self].
   ^binding value == self ifTrue: [binding] ifFalse: [LiteralVariable key: nil value: self]! !

!Class methodsFor: 'accessing' stamp: ''!
basicCategory
	^category! !

!Class methodsFor: 'subclass creation - immediate' stamp: ''!
immediateSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s package: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable pointer variables."
		
	^ self classInstaller make: [ :builder |
		builder
			superclass: self;
			name: t;
			layoutClass: ImmediateLayout;
			slots: f asSlotCollection;
			sharedVariablesFromString: d;
			sharedPools: s;
			category: cat;
			environment: self environment ].! !

!Class methodsFor: 'testing' stamp: ''!
isAbstract
	"Tells whether the receiver locally defines an abstract method, i.e., a method sending subclassResponsibility"

	^ super isAbstract or: [ self classSide isAbstract ]! !

!Class methodsFor: 'class variables' stamp: ''!
addClassVarNamed: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	
	self addClassVariable: (aString asSymbol => ClassVariable)! !

!Class methodsFor: 'class variables' stamp: ''!
addClassVariable: aClassVariable
	"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 copyForAnnouncement.
	symbol := aClassVariable name asSymbol.
	self withAllSubclasses do: [:subclass | 
		(subclass bindingOf: symbol) ifNotNil:[
			^ self error: symbol asString 
				, ' is already used as a variable name in class ' 
				, subclass name]].
	self basicDeclareClassVariable: aClassVariable.
	SystemAnnouncer uniqueInstance 
			classDefinitionChangedFrom: oldState to: self;
			classModificationAppliedTo: self! !

!Class methodsFor: 'subclass creation - slots' stamp: ''!
subclass: aSubclassSymbol layout: layoutClass slots: slotDefinition classVariables: classVarDefinition package: aCategorySymbol
	^ self
		subclass: aSubclassSymbol
		layout: layoutClass
		slots: slotDefinition
		classVariables: classVarDefinition
		poolDictionaries: ''
		package: aCategorySymbol! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
weakSubclass: className instanceVariableNames: instVarNameList classVariableNames: classVarNames category: cat
	"Added to allow for a simplified subclass creation experience. "

	^ self
		weakSubclass: className
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		package: cat! !

!Class methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toAST: aNode
	aNode link: aMetaLink! !

!Class methodsFor: '*Monticello' stamp: 'nil'!
asClassDefinition
	"we use a very ugly hack to encode complex slots as string with MC... later MC should model Slots directly"
	"We do not dispatch on the printer because in fact MC only support the oldPharo syntax. 
	This syntax is hijacked to store the full definition of a slot in case of complex slots: 
				#x => PropertySlot 
				
	This is produces by definitionString on slot while x is produced simnply by invoking name.
	"
	^ self needsSlotClassDefinition 
		ifTrue: [ MCClassDefinition
						name: self name
						superclassName: (self superclass ifNil: [ nil asString ] ifNotNil: [ self superclass name ])
						traitComposition: self traitCompositionString
						classTraitComposition: self class traitCompositionString
						category: self category 
						instVarNames: (self localSlots collect: [:each | each definitionString])
						classVarNames: (self classVariables collect: [:each | each definitionString])
						poolDictionaryNames: self sharedPoolNames
						classInstVarNames: (self class localSlots collect: [:each | each definitionString])
						type: self mcType
						comment: self organization classComment	asString
						commentStamp: self organization commentStamp ]
	
		ifFalse: [  
				 MCClassDefinition
						name: self name
						superclassName: (self superclass ifNil: [ nil asString ] ifNotNil: [ self superclass name ])
						traitComposition: self traitCompositionString
						classTraitComposition: self class traitCompositionString
						category: self category 
						instVarNames:  (self localSlots collect: [ :each | each name ])
						classVarNames: self classVarNames
						poolDictionaryNames: self sharedPoolNames
						classInstVarNames: (self class localSlots collect: [ :each | each name ])
						type: self mcType
						comment: self organization classComment	asString
						commentStamp: self organization commentStamp ]
	




! !

!Class methodsFor: 'class variables' stamp: ''!
classVariableDefinitionString
	"Answer a string that evaluates to the definition of the class Variables"
	
	^String streamContents: [ :str | | fullDef |
		str nextPutAll: '{ '.
		self classVariables do: [:global |
				str nextPutAll: global definitionString.
				fullDef := global needsFullDefinition]				
			separatedBy: [ 
				str nextPutAll: ' . '.  
				fullDef ifTrue: [ str cr;tab;tab;tab;tab ]].
		str nextPutAll: ' }'. ]! !

!Class methodsFor: 'class name' stamp: ''!
rename: aString 
	"The new name of the receiver is the argument, aString."

	| oldName newName |
	(newName := aString asSymbol) = (oldName := self name)
		ifTrue: [^ self].
	(self environment includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists'].
	self setName: newName.
	self environment renameClass: self from: oldName.
	(Undeclared includesKey: newName)
		ifTrue: [self inform: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].! !

!Class methodsFor: 'accessing - parallel hierarchy' stamp: ''!
classSide
	"Return the metaclass of the couple class/metaclass. Useful to avoid explicit test."
	"Point classSide >>> Point class"
	"Point class classSide >>> Point class"
	
	^ self class! !

!Class methodsFor: 'pool variables' stamp: ''!
sharedPools: aCollection
	sharedPools := aCollection! !

!Class methodsFor: 'pool variables' stamp: ''!
allSharedPools
	"Answer an ordered collection of the pools the receiver shares, including those defined  in the superclasses of the receiver."
	
	^self superclass
		ifNil: [self sharedPools copy]
		ifNotNil: [ | aSet |  
			aSet := self superclass allSharedPools.
			aSet addAll: self sharedPools; yourself]! !

!Class methodsFor: 'pool variables' stamp: ''!
usesPoolVarNamed: aString
	"Return whether the receiver has a pool variable named: aString, taking into account superclasses too"
	
	^self allSharedPools anySatisfy: [:each | each usesClassVarNamed: aString]! !

!Class methodsFor: '*TraitsV2' stamp: ''!
variableWordSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory

	^ self
		variableWordSubclass: aName
		uses: aTraitComposition
		instanceVariableNames: someInstanceVariableNames
		classVariableNames: someClassVariableNames
		poolDictionaries: someSharedPoolNames
		package: aCategory! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: aTraitName uses: aTraitCompositionOrArray instanceVariableNames: instVarNameList classVariableNames: classVarNames category: cat 

	^ self
		subclass: aTraitName
		uses: aTraitCompositionOrArray
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		category: cat ! !

!Class methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toSlot: aSlot
	aSlot link: aMetaLink! !

!Class methodsFor: 'initialization' stamp: ''!
removeFromSystemUnlogged
	"Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver.  Do not log the removal either to the current change set nor to the system changes log"
	^self removeFromSystem: false! !

!Class methodsFor: 'pool variables' stamp: ''!
usesLocalPoolVarNamed: aString
	"Return whether the receiver uses a pool variable named: aString which is defined locally"

	^ self sharedPools anySatisfy: [ :each | each usesClassVarNamed: aString ]! !

!Class methodsFor: 'class variables' stamp: ''!
allClassVariables
	"Answer the meta objects of all class variables of the class and its superclass"

	^self withAllSuperclasses flatCollect:  [ :each | each classVariables ]! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: subclassName uses: aTraitComposition layout: aLayout slots: someSlots classVariablesNames: someClassVariablesNames poolDictionaries: somePoolDictionaries category: aCategory
	
	^ self classInstaller
		make: [ :builder | 
			builder
				name: subclassName;
				superclass: self;
				slots: someSlots;
				layoutClass: aLayout;
				sharedVariablesFromString: someClassVariablesNames;
				sharedPools: somePoolDictionaries;
				traitComposition: aTraitComposition asTraitComposition;
				classTraitComposition: aTraitComposition asTraitComposition classComposition;
				category: aCategory ]! !

!Class methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter 
		writeObject: self 
		listSingleton: self name asSymbol! !

!Class methodsFor: '*Manifest-Core' stamp: ''!
criticTheNonMetaclassClass

	"Return the class of the receiver for the critic browser. This behavior may be folded later by changing the name of this method or using another one."
	
	^ self! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: aName uses: aTraitCompositionOrArray instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory

	^ self
		subclass: aName
		uses: aTraitCompositionOrArray
		layout: self classLayout class
		slots: someInstanceVariableNames asSlotCollection
		classVariablesNames: someClassVariableNames
		poolDictionaries: someSharedPoolNames
		category: aCategory! !

!Class methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterSuperClassMethodsFor: aStep
	<stSpotterOrder: 16>
	|superclasses|
	superclasses := self class withAllSuperclasses select: #isMeta.
	aStep listProcessor
			title: 'Super class methods';
			allCandidates: [ self classSide allMethods select: [ :each |(each methodClass = self classSide) not & (superclasses includes: each methodClass) ] ];
			filter: StFilterSubstring! !

!Class methodsFor: '*Shift-ClassInstaller' stamp: ''!
removeSlot: aSlot 
	
	(self classLayout slots includes: aSlot)
		ifFalse: [self error: aSlot name , ' is not one of my slots'].
		
	^self classInstaller update: self to: [ :builder |
		builder
			fillFor: self;
			slots: (self classLayout slots copyWithout: aSlot)]
	! !

!Class methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterSuperMethodsFor: aStep
	<stSpotterOrder: 11>
	
	aStep listProcessor
			title: 'Super instance methods';
			allCandidates: [ self allMethods reject: [ :each | each methodClass = self ] ];
			filter: StFilterSubstring! !

!Class methodsFor: 'initialization' stamp: ''!
sharing: poolString 
	"Set up sharedPools. Answer whether recompilation is advisable."
	| oldPools |
	oldPools := self sharedPools.
	self sharedPools: OrderedCollection new.
	(poolString substrings: ' ') do: 
		[:poolName | 
		self sharedPools add: (self environment at: poolName asSymbol ifAbsent:[
			(self confirm: 'The pool dictionary ', poolName,' does not exist.',
						'\Do you want it automatically created?' withCRs)
				ifTrue: [ self classInstaller make: [ :builder | 
							builder superclass: SharedPool;
							name: poolName;
							category: self category ]]
				ifFalse:[^self error: poolName,' does not exist']])].
	self sharedPools isEmpty ifTrue: [self sharedPools: nil].
	oldPools do: [:pool |
				| found |
				found := self sharedPools anySatisfy: [:p | p == pool].
				found ifFalse: [^ true "A pool got deleted"]].
	^ false! !

!Class methodsFor: 'class variables' stamp: ''!
anyUserOfClassVarNamed: aSymbol
	self withAllSubclasses do: [ :subclass | 
 		(Array with: subclass with: subclass class) do: [ :classOrMeta | 
			(classOrMeta whichSelectorsReferTo: (self classPool associationAt: aSymbol)) 
				ifNotEmpty: [ ^classOrMeta ]]].
				
	^nil! !

!Class methodsFor: 'class variables' stamp: ''!
classVariables
	"Answer the meta objects of all class variables"

	^self classPool associations! !

!Class methodsFor: '*TraitsV2' stamp: ''!
weakSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNameList classVariableNames: classVarNames package: cat

	^ self
		weakSubclass: className
		uses: aTraitCompositionOrArray
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		category: cat! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
immediateSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
	^self immediateSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s package: cat! !

!Class methodsFor: '*CodeExport' stamp: ''!
fileOutOn: aFileStream
	"File a description of the receiver on aFileStream."

	^ self fileOutOn: aFileStream initializing: true! !

!Class methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toClassVariableNamed: aClassVariableName
	self
		link: aMetaLink
		toClassVariable: (self nonAnonymousClass classVariableNamed: aClassVariableName asSymbol)! !

!Class methodsFor: '*TraitsV2' stamp: ''!
usesTraitLocally: aTrait
	"Returns whether self is among the users of aTrait. Note that this will return false if aTrait is used by a superclass of self and not self itself. If you want to get true in this case, use #usesTrait:"
	^ aTrait users includes: self! !

!Class methodsFor: '*TraitsV2' stamp: ''!
usesTrait: aTrait
	"Returns whether self or one of its superclasses are among the users of aTrait"
	^ aTrait users includesAny: self withAllSuperclasses! !

!Class methodsFor: 'subclass creation - variableWord' stamp: ''!
variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s package: cat
	"This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable word-sized nonpointer variables."

	^ self classInstaller
		make: [ :builder | 
			builder
				superclass: self;
				name: t;
				layoutClass: WordLayout;
				slots: f asSlotCollection;
				sharedVariablesFromString: d;
				sharedPools: s;
				category: cat;
				environment: self environment ]! !

!Class methodsFor: 'accessing' stamp: ''!
classPool
	"Answer the dictionary of class variables."

	^classPool ifNil: [ classPool := Dictionary new ]! !

!Class methodsFor: 'initialization' stamp: ''!
obsolete
	"Change the receiver and all of its subclasses to an obsolete class."
	self == Object 
		ifTrue: [^self error: 'Object is NOT obsolete'].
	self setName: 'AnObsolete' , self name.
	Object class instSize + 1 to: self classSide instSize do:
		[:i | self instVarAt: i put: nil]. "Store nil over class instVars."
	self classPool: nil.
	self sharedPools: nil.
	self hasClassSide ifTrue: [ self classSide obsolete].
	self propertyAt: #obsolete put: true.
	super obsolete.! !

!Class methodsFor: 'class variables' stamp: ''!
removeClassVarNamed: aString
	"Remove the class variable whose name is the argument, aString, from 
    the names defined in the receiver, a class. Create an error notification if 
    aString is not a class variable or if it is still being used in the code of 
    the class."
	
	self removeClassVarNamed: aString interactive: false! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: aSubclassSymbol uses: aTraitCompositionOrArray layout: layoutClass slots: slotDefinition classVariables: classVarDefinition category: aCategorySymbol

	^ self
		subclass: aSubclassSymbol
		uses: aTraitCompositionOrArray
		layout: layoutClass
		slots: slotDefinition
		classVariables: classVarDefinition
		poolDictionaries: ''
		category: aCategorySymbol! !

!Class methodsFor: '*HelpSystem-Core' stamp: ''!
asHelpTopic
	^SystemReference forClass: self! !

!Class methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterClassMethodsFor: aStep
	<stSpotterOrder: 15>
	
	aStep listProcessor
			title: 'Class methods';
			allCandidates: [ self classSide methods ];
			itemName: [ :method | method selector ];
			filter: StFilterSubstring! !

!Class methodsFor: 'testing' stamp: ''!
isClassOrTrait
	^true! !

!Class methodsFor: '*CodeExport' stamp: ''!
fileOutOn: aFileStream initializing: aBool
	"File a description of the receiver on aFileStream."

	SystemNotification signal: self name.
	super fileOutOn: aFileStream.
	self class nonTrivial
		ifTrue: [
			aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr.
			self class
				fileOutOn: aFileStream
				initializing: aBool ]! !

!Class methodsFor: 'organization' stamp: ''!
environment

	^environment ifNil: [super environment]! !

!Class methodsFor: 'subclass creation' stamp: ''!
classBuilder
		"Answer the object responsible of creating subclasses of myself in the system."
	
		^ self classInstaller new builder! !

!Class methodsFor: 'pool variables' stamp: ''!
removeSharedPool: aDictionary 
	"Remove the pool dictionary, aDictionary, as one of the receiver's pool 
	dictionaries. Create an error notification if the dictionary is not one of 
	the pools.
	: Note that it removes the wrong one if there are two empty Dictionaries in the list."

	| satisfiedSet workingSet aSubclass |
	(self sharedPools includes: aDictionary)
		ifFalse: [^self error: 'the dictionary is not in my pool'].

	"first see if it is declared in a superclass in which case we can remove it."
	(self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty
		ifFalse: [self sharedPools remove: aDictionary.
				self sharedPools isEmpty ifTrue: [self sharedPools: nil].
				^self]. 

	"second get all the subclasses that reference aDictionary through me rather than a 
	superclass that is one of my subclasses."

	workingSet := self subclasses asOrderedCollection.
	satisfiedSet := Set new.
	[workingSet isEmpty] whileFalse:
		[aSubclass := workingSet removeFirst.
		(aSubclass sharedPools includes: aDictionary)
			ifFalse: 
				[satisfiedSet add: aSubclass.
				workingSet addAll: aSubclass subclasses]].

	"for each of these, see if they refer to any of the variables in aDictionary because 
	if they do, we can not remove the dictionary."
	satisfiedSet add: self.
	satisfiedSet do: 
		[:sub | 
		aDictionary associationsDo: 
			[:aGlobal | 
			(sub whichSelectorsReferTo: aGlobal) isEmpty 
				ifFalse: [^self error: aGlobal key 
								, ' is still used in code of class '
								, sub name]]].
	self sharedPools remove: aDictionary.
	self sharedPools isEmpty ifTrue: [self sharedPools: nil]! !

!Class methodsFor: 'accessing - class hierarchy' stamp: ''!
hasSubclasses
	^ self subclasses isNotEmpty! !

!Class methodsFor: 'subclass creation - slots' stamp: ''!
subclass: aSubclassSymbol slots: slotDefinition classVariables: classVarDefinition package: aCategorySymbol
	^ self
		subclass: aSubclassSymbol
		slots: slotDefinition
		classVariables: classVarDefinition
		poolDictionaries: ''
		package: aCategorySymbol! !

!Class methodsFor: '*Fuel-Tests-Core' stamp: ''!
renameSilently: aName
	 [ self rename: aName] fuelValueWithoutNotifications! !

!Class methodsFor: 'subclass creation - weak' stamp: ''!
weakSubclass: className instanceVariableNames: instVarNameList classVariableNames: classVarNames package: cat
	"Added to allow for a simplified subclass creation experience. "

	^ self
		weakSubclass: className
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		package: cat! !

!Class methodsFor: '*TraitsV2' stamp: ''!
immediateSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames package: aCategory

	^ self
		subclass: aName
		uses: aTraitComposition
		layout: ImmediateLayout
		slots: someInstanceVariableNames asSlotCollection 
		classVariablesNames: someClassVariableNames
		poolDictionaries: someSharedPoolNames
		category: aCategory! !

!Class methodsFor: '*TraitsV2' stamp: ''!
variableByteSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNameList classVariableNames: classVarNames category: cat

	^ self
		variableByteSubclass: className
		uses: aTraitCompositionOrArray
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		category: cat! !

!Class methodsFor: 'subclass creation' stamp: ''!
newAnonymousSubclass

	^ Smalltalk anonymousClassInstaller make: [ :builder |
		builder
			superclass: self ;
			layoutClass: self classLayout class ].! !

!Class methodsFor: 'class variables' stamp: ''!
usesClassVarNamed: aString
	"Return whether the receiver or its superclasses have a class variable named: aString"
	
	^ self allClassVarNames includes: aString! !

!Class methodsFor: 'class variables' stamp: ''!
basicDeclareClassVariable: aClassVariable 
	"Add aClassVariable to the receiver. Two cases are handled here: 
	- When there is exiting variable in class pool and it is an instance of different class
	- When given variable is registered as undeclared 
	This method was extracted from existing users and it keeps known issues (therefore a flag):
	- When a class of a variable is changed we must recompile using methods because new variable can implement specific compilation logic (method bytecode can become different).
	- Undeclared case requires much more clever logic. Now in that case the class variable will be shared between all classes previously referencing undeclared variable despite on the fact that they do no see a class variables from other classes"
	self flag: #todo.
	aClassVariable owningClass: self.

	self classPool associationAt: aClassVariable name ifPresent:  [:existingVar |
		(existingVar class == aClassVariable class) ifTrue: [^self].
		"need to take care to migrate existing variables to new global if class if different"
		aClassVariable write: existingVar read.
		self classPool removeKey: existingVar name ].
	"Pick up any refs in Undeclared"
	Undeclared associationAt: aClassVariable name ifPresent:  [:existingVar |
		Undeclared removeKey: existingVar name.
		existingVar becomeForward: aClassVariable
	].
	self classPool add: aClassVariable! !

!Class methodsFor: 'subclass creation - variable' stamp: ''!
variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s package: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable pointer variables."

	^ self classInstaller
		make: [ :builder | 
			builder
				superclass: self;
				name: t;
				layoutClass: VariableLayout;
				slots: f asSlotCollection;
				sharedVariablesFromString: d;
				sharedPools: s;
				category: cat;
				environment: self environment ]! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
variableByteSubclass: className instanceVariableNames: instVarNameList  classVariableNames: classVarNames category: cat
	"Added to allow for a simplified subclass creation experience. "

	^ self
		variableByteSubclass: className
		instanceVariableNames: instVarNameList 
		classVariableNames: classVarNames
		package: cat! !

!Class methodsFor: '*System-Settings-Core' stamp: ''!
acceptSettings: aVisitor 
	^ aVisitor visitClass: self! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
	^ self
		variableByteSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		package: cat! !

!Class methodsFor: 'testing' stamp: ''!
hasMethods
	"Answer a Boolean according to whether any methods are defined for the 
	receiver (includes whether there are methods defined in the receiver's 
	metaclass)."

	^super hasMethods or: [ self classSide hasMethods ]! !

!Class methodsFor: 'initialization' stamp: ''!
unload
	"Sent when a the class is removed.  Does nothing, but may be overridden by (class-side) subclasses."! !

!Class methodsFor: 'subclass creation - weak' stamp: ''!
ephemeronSubclass: className instanceVariableNames: instVarNameList classVariableNames: classVarNames package: cat
	"Added to allow for a simplified subclass creation experience. "

	^ self
		ephemeronSubclass: className
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		package: cat! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: aName uses: aTraitCompositionOrArray instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames package: aCategory

	^ self
		subclass: aName
		uses: aTraitCompositionOrArray
		layout: self classLayout class
		slots: someInstanceVariableNames asSlotCollection
		classVariablesNames: someClassVariableNames
		poolDictionaries: someSharedPoolNames
		category: aCategory! !

!Class methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
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 := (RGClassDefinition named: self name)
		category: self category;
		superclassName: (self superclass
			ifNil: [ nil printString ]
			ifNotNil: [ self superclass name ]);
		traitCompositionSource: self traitCompositionString;
		addInstanceVariables: self instVarNames;
		addClassVariables: self classVarNames;
		addSharedPools: self sharedPoolNames;
		comment: self organization classComment;
		stamp: self organization commentStamp;
		definitionSource: self definitionString;
		package: self package asRingDefinition;
		withMetaclass.
	ring classSide 
		traitCompositionSource: self classSide traitCompositionString;
		definitionSource: self classSide definitionString;
		addInstanceVariables: self classSide instVarNames.  
	^ ring! !

!Class methodsFor: 'initialization' stamp: ''!
declareClassVariables: newVars 
	"Declare class variables common to all instances. Answer whether 
	recompilation is advisable."
	|  conflicts newVarNames |	
	conflicts := false.	
	newVarNames := newVars collect: [ :each | each name ].
	"Remove. Warn if vars are removed that are still used"
	(self classVarNames difference: newVarNames) do: [:varName | 
		self removeClassVarNamed: varName interactive: false].
	
	(newVarNames difference: self classVarNames) do: [:varName | "adding"
			"check if new vars are defined elsewhere"
			(self innerBindingOf: varName) ifNotNil: [:existingVar | 
				DuplicatedVariableError signalWith: existingVar.
				conflicts := true]].
	newVars do: [:var | self basicDeclareClassVariable: var ].
	^conflicts! !

!Class methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toVariableNamed: vName option: accessStrategy
	^aMetaLink
		installOnVariable: (self lookupVar: vName)
		for: self
		option: accessStrategy
		instanceSpecific: false! !

!Class methodsFor: '*TraitsV2' stamp: ''!
variableWordSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames package: aCategory

	^ self
		subclass: aName
		uses: aTraitComposition
		layout: WordLayout
		slots: someInstanceVariableNames asSlotCollection
		classVariablesNames: someClassVariableNames
		poolDictionaries: someSharedPoolNames
		category: aCategory! !

!Class methodsFor: 'accessing - class hierarchy' stamp: ''!
subclasses: aCollection
	subclasses := aCollection.! !

!Class methodsFor: 'subclass creation - variableByte' stamp: ''!
variableByteSubclass: className instanceVariableNames: instVarNameList  classVariableNames: classVarNames package: cat
	"Added to allow for a simplified subclass creation experience. "

	^ self
		variableByteSubclass: className
		instanceVariableNames: instVarNameList 
		classVariableNames: classVarNames
		poolDictionaries: ''
		package: cat! !

!Class methodsFor: '*ClassAnnotation' stamp: ''!
classAnnotationsDo: aBlock
	^(ClassAnnotation findAllAnnotationsFor: self) do: aBlock! !

!Class methodsFor: '*ClassAnnotation' stamp: ''!
asAnnotationContext
	^SimpleAnnotationContext of: self! !

!Class methodsFor: 'class variables' stamp: ''!
hasClassVarNamed: aString
	"Return whether the receiver has a class variables (shared variables among its class and subclasses) named: aString"
	
	^ self classPool includesKey: aString! !

!Class methodsFor: 'compiling' stamp: ''!
bindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver, or nil
	if variable with such name is not defined"

	"The lookup recurses up to superclasses looking inside their class and shared pools,
	but not the environment, since two classes, even if they have ancestry relationship,
	could use different environments.
	That's why we doing an environment lookup only as a last step of symbol lookup 
	and taking only the environment of receiver only, not any of it's superclass(es) "
	
	| aSymbol |
	aSymbol := varName asSymbol.

	^ (self innerBindingOf: aSymbol) ifNil: [
		 self environment lookupVar: aSymbol
	]! !

!Class methodsFor: 'organization' stamp: ''!
category: aString 
	"Categorize the receiver under the system category, aString, removing it from 
	any previous categorization."

	| oldCategory |
	oldCategory := self basicCategory.
	aString isString
		ifTrue: [
			self basicCategory: aString asSymbol.
			self environment organization classify: self name under: self basicCategory ]
		ifFalse: [self errorCategoryName].
	SystemAnnouncer uniqueInstance
		class: self recategorizedFrom: oldCategory to: self basicCategory! !

!Class methodsFor: 'pool variables' stamp: ''!
sharedPoolsDo: aBlockClosure 
	"Iterate shared pools.
	The shared pool collection is lazily created on access.
	This method avoids creating the collection for a simple iteration"
	self hasSharedPools ifFalse: [ ^ self ].
	self sharedPools do: aBlockClosure! !

!Class methodsFor: 'accessing - class hierarchy' stamp: ''!
subclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	
	self subclasses do: aBlock! !

!Class methodsFor: '*OpalCompiler-Core' stamp: ''!
classSideCompilerClass 
	"Redefine this method if you want to customize the compiler class for class-side methods"
	^ Smalltalk compilerClass! !

!Class methodsFor: 'class variables' stamp: ''!
classVarNamed: aString put: anObject
	"for compatibility"
	
	self writeClassVariableNamed: aString value: anObject! !

!Class methodsFor: '*Roassal3' stamp: ''!
numberOfVariables
	"Return the number of variables"
	
	^ self instVarNames size! !

!Class methodsFor: 'subclass creation - deprecated' stamp: ''!
variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
	^ self
		variableSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		package: cat! !

!Class methodsFor: 'initialization' stamp: ''!
removeFromSystem: logged
	"Forget the receiver from the Smalltalk global dictionary. Any existing  instances will refer to an obsolete version of the receiver.
	Keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want.
	Tell class to deactivate and unload itself-- two separate events in the module system"
	| myCategory |
	self release.
	self unload.

	self superclass ifNotNil:
		["If we have no superclass there's nothing to be remembered"
		self superclass addObsoleteSubclass: self].
	
	"we add the class to Undeclared so that if references still exist, they will  be automatically fixed 
	if this class is loaded again. We do not check if references exist as it is too slow"
	Undeclared declare: self name asSymbol from: Smalltalk globals.
	myCategory := self category.
	self environment forgetClass: self logged: logged.
	self obsolete.
	logged ifTrue: [SystemAnnouncer uniqueInstance classRemoved: self fromCategory: myCategory].! !

!Class methodsFor: '*Shift-ClassInstaller' stamp: ''!
addClassSlot: aSlot

	^ self classInstaller update: self to: [ :builder |
		builder
			fillFor: self;
			classSlots: (self class classLayout slots copyWith: aSlot)]! !

!Class methodsFor: '*System-Support' stamp: ''!
allUnreferencedClassVariables
	"Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses"

	^ self allClassVariables reject: [ :classVar | classVar isReferenced ]! !

!Class methodsFor: 'initialization' stamp: ''!
superclass: aClass methodDictionary: mDict format: fmt
	"Basic initialization of the receiver"
	super superclass: aClass methodDictionary: mDict format: fmt.
	self subclasses: nil.! !

!Class methodsFor: 'class variables' stamp: ''!
definesClassVariable: aGlobal
	"Return whether the receiver has a class variables (shared variables among its class and subclasses) named: aString"
	
	^ self classVariables includes: aGlobal! !

!Class methodsFor: 'compiling' stamp: ''!
possibleVariablesFor: misspelled continuedFrom: oldResults

	| results |
	results := misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults.
	self sharedPools do: [:pool | 
		results := misspelled correctAgainstDictionary: pool classPool continuedFrom: results ].
	self superclass == nil
		ifTrue: 
			[ ^ misspelled correctAgainstDictionary: self environment continuedFrom: results ]
		ifFalse:
			[ ^ self superclass possibleVariablesFor: misspelled continuedFrom: results ]! !

!Class methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionAllReferences
	<inspectorPresentationOrder: 920 title: 'All References'>
	| allReferences allClassesReferencing sortBlock treeTable childrenBlock |
	
	allReferences := SystemNavigation default allReferencesTo: self binding.
	sortBlock := [ :x :y | x name < y name ].
	
	"Roots: classes with references to self binding"	
	allClassesReferencing := (allReferences
		collect: [ :rbMethodDef | rbMethodDef methodClass ]) asSet asSortedCollection: sortBlock.
	
	"Children: references from selected class"
	childrenBlock := [ :aClass | 
		(allReferences	select: [ :rbMethodDef | 
				rbMethodDef methodClass == aClass ])	asSortedCollection: sortBlock ].
	
	treeTable := SpTreeTablePresenter new.	
	treeTable
		roots: allClassesReferencing;
		children: childrenBlock.
	treeTable addColumn: (SpStringTableColumn title: 'References' evaluated: #name).
	
	^ treeTable! !

!Class methodsFor: '*System-Changes' stamp: 'nil'!
removeFromChanges
	"References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet."

	self class environment at: #ChangeSet ifPresent: [ :changeSet |
		changeSet current removeClassAndMetaClassChanges: self ].! !

!Class methodsFor: 'pool variables' stamp: ''!
addSharedPoolNamed: aSharedPoolName 
	
	|poolClass|
	poolClass := aSharedPoolName asClassIfAbsent: [nil].
	poolClass isPool 
		ifTrue: [ self addSharedPool: poolClass ]
		ifFalse: [ self error: 'The specified class is not pool.' ]! !

!Class methodsFor: '*Shift-ClassInstaller' stamp: ''!
addSlot: aSlot

	^self classInstaller update: self to: [ :builder |
		builder
			fillFor: self;
			slots: (self localSlots copyWith: aSlot)].! !

!Class methodsFor: 'subclass creation - variable' stamp: ''!
variableSubclass: className instanceVariableNames: instVarNameList classVariableNames: classVarNames package: cat
	^ self
		variableSubclass: className
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: ''
		package: cat! !

!Class methodsFor: '*Shift-ClassInstaller' stamp: ''!
removeClassSlot: aSlot

	^ self classInstaller update: self to: [ :builder |
		builder
			fillFor: self;
			classSlots: (self class classLayout slots copyWithout: aSlot)]! !

!Class methodsFor: 'accessing - parallel hierarchy' stamp: ''!
instanceSide
	"Return the class of the couple class/metaclass. Useful to avoid explicit test."
	"Point instanceSide >>> Point"
	"Point class instanceSide >>> Point"
	
	^ self! !

!Class methodsFor: 'pool variables' stamp: ''!
sharedPoolNames
	^ self sharedPools collect: [:ea |
		ea isObsolete
			ifTrue: [ ea name ]
			ifFalse: [ self environment keyAtIdentityValue: ea ] ]! !

!Class methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionClassComment
	"This provides an editable comment of the current class"
	<inspectorPresentationOrder: 920 title: 'Comment'>
	
	^ SpTextPresenter new
		text: self comment;
		whenSubmitDo: [ :text | 
			self 
				comment: text 
				stamp: Author changeStamp ]! !

!Class methodsFor: 'subclass creation' stamp: ''!
subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s package: cat

	^ self classInstaller
		make: [ :builder | 
			builder
				superclass: self;
				name: t;
				layoutClass: self classLayout class;
				slots: f asSlotCollection;
				sharedVariablesFromString: d;
				sharedPools: s;
				category: cat;
				environment: self environment ]! !

!Class methodsFor: 'subclass creation - variableByte' stamp: ''!
variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s package: 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."

	| oldClassOrNil actualLayoutClass |
	oldClassOrNil := self environment at: t ifAbsent: [ nil ].
	actualLayoutClass := (oldClassOrNil notNil and: [ oldClassOrNil classLayout class == CompiledMethodLayout ])
		ifTrue: [ CompiledMethodLayout ]
		ifFalse: [ ByteLayout ].

	^ self classInstaller
		make: [ :builder | 
			builder
				superclass: self;
				name: t;
				layoutClass: actualLayoutClass;
				slots: f asSlotCollection;
				sharedVariablesFromString: d;
				sharedPools: s;
				category: cat;
				environment: self environment ]! !

!Class methodsFor: '*TraitsV2' stamp: ''!
subclass: subclassName uses: aTraitComposition layout: aLayout slots: someSlots classVariablesNames: someClassVariablesNames poolDictionaries: somePoolDictionaries package: aCategory
	
	^ self classInstaller
		make: [ :builder | 
			builder
				name: subclassName;
				superclass: self;
				slots: someSlots;
				layoutClass: aLayout;
				sharedVariablesFromString: someClassVariablesNames;
				sharedPools: somePoolDictionaries;
				traitComposition: aTraitComposition asTraitComposition;
				classTraitComposition: aTraitComposition asTraitComposition classComposition;
				category: aCategory ]! !

!Class class methodsFor: 'instance creation' stamp: ''!
templateForSubclassOf: priorClassName category: systemCategoryName 
	"Answer an expression that can be edited and evaluated in order to define a new class, given that the class previously looked at was as given"

	^priorClassName asString, ' subclass: #NameOfSubclass
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	package: ''' , systemCategoryName asString , ''''! !

!Class class methodsFor: 'inquiries' stamp: ''!
rootsOfTheWorld
	"return all classes that have a nil superclass"
	
	^(self environment select: [:each | each isBehavior and: [each superclass isNil]]) asOrderedCollection! !

!Class class methodsFor: 'private' stamp: ''!
hasNoDependenciesFor: aClass in: unprocessedClasses cache: cache 
	^ (self hasNoSuperclassesOf: aClass in: unprocessedClasses cache: cache) and: [
		aClass isMeta not or: [
			self hasNoDependenciesForMetaclass: aClass in: unprocessedClasses cache: cache]]! !

!Class class methodsFor: 'instance creation' stamp: ''!
template: aSystemCategoryName 
	"Answer an expression that can be edited and evaluated in order to define a new class."

	^ self templateForSubclassOf: Object name category: aSystemCategoryName! !

!Class class methodsFor: 'file in/out' stamp: ''!
doesNotIncludeInstanceOrSuperclassesFor: aClass in: unprocessedClasses cache: cache 
	| soleInstance |
	soleInstance := aClass soleInstance.
	^ (unprocessedClasses includes: soleInstance) not and: [
				self hasNoSuperclassesOf: soleInstance in: unprocessedClasses cache: cache]! !

!Class class methodsFor: 'file in/out' stamp: ''!
hasNoSuperclassesOf: aClass in: unprocessedClasses cache: cache 
	^ (unprocessedClasses includesAnyOf: (self allSuperclassesFor: aClass cache: cache)) not! !

!Class class methodsFor: 'file in/out' stamp: ''!
hasNoDependenciesForMetaclass: aClass in: unprocessedClasses cache: cache 
	| soleInstance |
	soleInstance := aClass soleInstance.
	^ (unprocessedClasses includes: soleInstance) not and: [
				self hasNoSuperclassesOf: soleInstance in: unprocessedClasses cache: cache]! !

!Class class methodsFor: 'file in/out' stamp: ''!
allSuperclassesFor: aClass cache: cache 	
	^ cache at: aClass ifAbsentPut: [aClass allSuperclasses asArray]! !

!Class class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	| theClassName theClass |
	theClassName := stonReader parseListSingleton.
	theClass := self environment at: theClassName.
	^ theClass! !

!Class class methodsFor: 'file in/out' stamp: ''!
superclassOrder: classes
    "Arrange the classes in the collection, classes, in superclass order so the 
    classes can be properly filed in. Do it in sets instead of ordered collections.
    Preserve provided classes order when there is no hierarchy relationship."

    | all list unprocessedClasses cache |
    list := classes copy asArray. "list is indexable"
    unprocessedClasses := classes asSet. 
    cache := Dictionary new.
    all := OrderedCollection new: unprocessedClasses size.
    unprocessedClasses size timesRepeat:
        [ | nextClass nextClassIndex |
            nextClassIndex := list findFirst: [:aClass | aClass notNil
                and: [(unprocessedClasses includes: aClass)
                and: [self hasNoDependenciesFor: aClass in: unprocessedClasses cache: cache]]].
            nextClass := list at: nextClassIndex.
            list at: nextClassIndex put: nil.
            all addLast: nextClass.
            unprocessedClasses remove: nextClass].
    ^all! !

!ClassAPIHelpBuilder commentStamp: ''!
A builder to build the API Help for a class

Instance Variables
	addMethods:		<Boolean>
	addSubclasses:		<Boolean>
	subclassesAsSeparateTopic:		<Boolean>

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: ''!
addSubclasses
	^ addSubclasses! !

!ClassAPIHelpBuilder methodsFor: 'initialization' stamp: ''!
initialize
	"Initializes the receiver"
	
	super initialize.
	addSubclasses := false.
	addMethods := true.
	subclassesAsSeparateTopic := true.
	addMethodsWithoutComment := true.! !

!ClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
subclassesAsSeparateTopic
	^ subclassesAsSeparateTopic! !

!ClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addSubclasses: anObject
	addSubclasses := anObject! !

!ClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addMethodsWithoutComment
	^ addMethodsWithoutComment! !

!ClassAPIHelpBuilder methodsFor: 'private - building' stamp: ''!
buildSubclassTopicFor: aSubclass
	 
	^(self class new) 
			rootToBuildFrom: aSubclass;
			addSubclasses: addSubclasses;
			addMethods: addMethods;
			subclassesAsSeparateTopic: subclassesAsSeparateTopic;
			build;
			topicToBuild! !

!ClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addMethods: anObject
	addMethods := anObject! !

!ClassAPIHelpBuilder methodsFor: 'building' stamp: ''!
build
	topicToBuild := HelpTopic named: rootToBuildFrom name.
	topicToBuild iconName: #pageIcon.
	topicToBuild contents: rootToBuildFrom comment.
	addMethods
		ifTrue: [ self buildSubnodesForMethods ].
	addSubclasses
		ifTrue: [ self buildSubnodesForSubclasses ]! !

!ClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addMethods
	^ addMethods! !

!ClassAPIHelpBuilder methodsFor: 'private - building' stamp: ''!
buildMethodTopicsOn: topic for: aClass
	|stream methodComment|
	stream := String new writeStream.
	aClass selectors asSortedCollection do: [:selector | 
		methodComment := (aClass>>selector) comment.
		addMethodsWithoutComment | methodComment notNil ifTrue: [ 
			stream 
				nextPutAll: aClass name;
				nextPutAll: '>>#';
				nextPutAll: selector asString;
				cr.		

		methodComment ifNil: [ methodComment := 'Method has no comment.' ].
		stream nextPutAll: methodComment;cr;cr ] ].
	
	topic contents: stream contents.! !

!ClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
subclassesAsSeparateTopic: anObject
	subclassesAsSeparateTopic := anObject! !

!ClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addMethodsWithoutComment: anObject
	addMethodsWithoutComment := anObject! !

!ClassAPIHelpBuilder methodsFor: 'private - building' stamp: ''!
buildSubnodesForMethods
	| instanceSide classSide |
	instanceSide := HelpTopic named: 'Instance side'.
	classSide := HelpTopic named: 'Class side'.
	topicToBuild iconName: #bookIcon.
	topicToBuild
		addSubtopic: instanceSide;
		addSubtopic: classSide.
	self buildMethodTopicsOn: instanceSide for: rootToBuildFrom.
	self buildMethodTopicsOn: classSide for: rootToBuildFrom class! !

!ClassAPIHelpBuilder methodsFor: 'private - building' stamp: ''!
buildSubnodesForSubclasses
	| topic |
	rootToBuildFrom subclasses isEmpty
		ifTrue: [ ^ self ].
	topicToBuild iconName: #bookIcon.
	topic := subclassesAsSeparateTopic
		ifTrue: [ topicToBuild addSubtopic: (HelpTopic named: 'Subclasses') ]
		ifFalse: [ topicToBuild ].
	rootToBuildFrom subclasses
		do:
			[ :subclass | topic addSubtopic: (self buildSubclassTopicFor: subclass) ].
	topic sortSubtopicsByTitle! !

!ClassAPIHelpBuilder class methodsFor: 'building' stamp: ''!
buildHierarchicalHelpTopicFrom: aClass withSubclasses: aBoolean withMethods: anotherBoolean
	"Start building from the given class"
	
	^(self new)
		addSubclasses: aBoolean;
		addMethods: anotherBoolean;
		rootToBuildFrom: aClass;
		build;
		topicToBuild! !

!ClassAPIHelpBuilderTest commentStamp: ''!
SUnit tests for ClassAPIHelpBuilder!
!ClassAPIHelpBuilderTest methodsFor: 'testing' stamp: ''!
testDefaultBuilding
	| topic |
	topic := ClassAPIHelpBuilder buildHelpTopicFrom: Integer.
	self assert: topic subtopics size equals: 2.
	self assert: topic subtopics first title equals: 'Instance side'.
	self assert: topic subtopics last title equals: 'Class side'! !

!ClassAPIHelpBuilderTest methodsFor: 'testing' stamp: ''!
testMethodsButNoSubclasses
	| topic |
	topic := ClassAPIHelpBuilder buildHierarchicalHelpTopicFrom: Integer withSubclasses: false withMethods: true.
	self assert: topic subtopics size equals: 2.
	self assert: topic subtopics first title equals: 'Instance side'.
	self assert: topic subtopics last title equals: 'Class side'! !

!ClassAPIHelpBuilderTest methodsFor: 'testing' stamp: ''!
testBuildingTraits
	| topic |
	topic := ClassAPIHelpBuilder buildHelpTopicFrom: TSortable.
	self assert: topic subtopics size equals: 2.
	self assert: topic subtopics first title equals: 'Instance side'.
	self assert: topic subtopics last title equals: 'Class side'! !

!ClassAdded commentStamp: ''!
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: ''!
classCategory: aClassCategoryName
	classCategory := aClassCategoryName! !

!ClassAdded methodsFor: 'accessing' stamp: ''!
classAffected
	^self classAdded! !

!ClassAdded methodsFor: 'accessing' stamp: ''!
classAdded: aClass
	classAdded := aClass! !

!ClassAdded methodsFor: 'accessing' stamp: ''!
classAdded
	^classAdded! !

!ClassAdded methodsFor: 'accessing' stamp: ''!
classCategory
	^classCategory! !

!ClassAdded class methodsFor: 'instance creation' stamp: ''!
class: aClass category: aClassCategoryName
	^self new
			classAdded: aClass;
			classCategory: aClassCategoryName;
			yourself! !

!ClassAnnotation commentStamp: ''!
I am the root of class annotation hierarchy.
My subclasses should annotate classes using class side methods with the pragma #classAnnotation. 
For example:

	MyClass class>>specialAnnotationExample
		<classAnnotation>
		^MySpecialAnnotation new

The annotating method should return an instance of the annotation.

I provide a query API to retrieve all registered instances of a concrete annotation class:

	MySpecialAnnotation registeredInstances.
	MySpecialAnnotation registeredInstancesFor: MyClass.
	MySpecialAnnotation registeredInstancesDo: [:each | each logCr].

Each annotation includes the annotated class and the selector of declaration method.
All annotations are cached in default ClassAnnotationRegistry instance. It is cheap to query them.

Classes itself can be queried for all attached annotations:

	MyClass classAnnotations.
	MyClass classAnnotationsDo: [:each | each logCr].

I provide extra hook to forbid annotating of particular classes. For example my subclasses can define that abstract classses should not be annotated by them.
The rule should be  implemented in the method:

	MySpecialAnnotation >>isForbidden
		^annotatedClass isAbstract 

By default method returns true which means that annotation can annotate any class.

Because annotations are declared in the methods it provides interesting feature to extend meta information from external packages.
Just define declaration method as class extension. And when your package will be loaded the new annotation will be added into existing class.
 
There is no special way how instantiate annotation instances. It is up to your domain.
The internal state is initialized during Registry creation.  Users should not think about it. 
You can add any domain specific variables to your annotations and add constructors to initialize them in declaration methods. 
Annotations are just normal objects without any restrictions. You can also attatch annotations to annotations like in other languages.

-----------Advanced features. Priority------------

Annotations in the registry are sorted by priority. It provides out of the box mechanizm for ordering annotated classes for the user domain purposes. 
Just pass priority number into the annotation when you create it in declaration method. And define suitable constructor for this.

-----------Advanced features. Context------------

Any annotation can be contextual. You can specify instance of context where annotation can be used:
	MySpecialAnnotation for: anAnotationContext
Context describes annotation users where they should be active.

For simplicity you can specify any class instead of context instance. It will represent all users of annotation of particular class hierarchy:

	MySpecialAnnotation for: MyUserClass.

Internallly argument is always converted to the context:

	MyUserClass asAnnotationContext.

I provide query interface to retriev registered annotations which are active in given context:

	MySpecialAnnotation activeInstancesInContext: anAnnotationUser.
	MySpecialAnnotation activeInstancesInContext: anAnnotationUser do: [:ann | ].
	MySpecialAnnotation activeInstancesFor: MyClass inContext: anAnnotationUser do: [:ann | ].

By default the annotation is active if given user is described by declared context:

	ClassAnnotation>>isActiveInContext: anAnnotationUser
		^activeContext describes: anAnnotationUser

Subclasses can provide extra conditions for active annotations. In that case they override this method:

	MySpecialAnnotation>>isActiveInContext: anAnnotationUser
		^(super isActiveInContext: anAnnotationUser)
			and: [annotatingClass canBeUsedInContext: anAnnotationUser]

So the logic can depends on annotating class itself and actual annotation user.

For some scenarios you may need to query annotations according to original "active" definition despite of extra conditions.
For such cases I introduced the "visibility" of annotations: the annotation is visible if it is declared for given user:

	ClassAnnotation>>isVisibleInContext: anAnnotationUser
		^activeContext describes: anAnnotationUser

So the visible annotation is not necessary active. But active annotation is always visible for given user:

	ClassAnnotation>>isActiveInContext: anAnnotationUser
		^self isVisibleInContext: anAnnotationUser

(I showed another version above to simplify description).
There are extra query methods to retrieve visible annotations:

	MySpecialAnnotation visibleInstancesInContext: anAnnotationUser.
	MySpecialAnnotation visibleInstancesInContext: anAnnotationUser do: [:ann | ].
	MySpecialAnnotation visibleInstancesFor: MyClass inContext: anAnnotationUser do: [:ann | ].

-----------Advanced features. Annotation dependency methods------------

It is possible to call other methods inside annotation declaring methods (with pragma <classAnnotation>).
Such methods are dependency methods and their modification requires updating annotation cache (registry).
You can do it manually using

	ClassAnnotation resetAll
	
Or you can mark such methods with special pragma <classAnnotationDependency> and systen will track these methods for automatically.	
For example in Commander package there is CmdShortcutCommandActivation annotation. It provides reusable methods for rename and remove shorcuts: cmd+r and cmd+x. So you can annotate commands using: 

	MyRenameCommand class>>shortcutActivation
		<classAnnotation>
		^CmdShortcutCommandActivation renamingFor: MyApp.

This annotation will keep cmd+r in instance variable. 
If you will modify #renamingFor: method with new shorctut the annotations should be updated. And special pragma ensures this logic:

	CmdShortcutCommandActivation class>>renamingFor: anAnnotationUser
		<classAnnotationDependency>
		^self by: $r meta for: anAnnotationUser 

-----------Advanced features. Redefining registered instances------------

All annotations are collected from methods and cached in default ClassAnnotationRegistry instance. 
I provide special mechanizm to redefine collected instances. When cache is updated I use and keep all redefined annotations.

To redefine particular annotation use #redefineBy: message with block which sets custom properties to original instance.
For example following code allows to redefine shortcut of #browse command in Calypso: 

	(ClySpawnFullBrowserCommand classAnnotationsAt: #browserShortcutActivation)
		redefineBy: [:shortcut | shortcut keyCombination: $o meta ].
	
Try evaluate it and press cmd+o on selected item in browser. If will open new browser window.
You can notice that old shortcut cmd+b is not working anymore.

Now you can manualy reset annotation cache to check that it will not affect redefined shortcut: 

	ClassAnnotation resetCache.
	
To inspect redefined annotations ask their class for: 

	CmdShortcutCommandActivation redefinedInstances
	
Redefined instances are stored in class side variable #redefinedInstances. 
It is a dictionary which keys are new redefining annotations and values are original annotations collected from methods.
Notice that key and value are equal objects because annotations define equality using annotated class and declaration selector.
So dictionary items can be accessed using both objects.

To check that annotation is redefined use following example: 

	 (ClySpawnFullBrowserCommand classAnnotationsAt: #browserShortcutActivation)
			isRedefined

And you can ask actual redefined annotaion: 

	 (ClySpawnFullBrowserCommand classAnnotationsAt: #browserShortcutActivation)
			redefinedInstance
		
Using annotation instance you can also retrieve redefining instance: 

	anAnnotation redefiningInstance.
	
It should be identical to cached one.
	
To revert redefined annotation use #revertRedefinedInstance message: 

	(ClySpawnFullBrowserCommand classAnnotationsAt: #browserShortcutActivation)
			revertRedefinedInstance

Check that now browse command is again activated by cmd+b shortcut (which is defined in annotation declaration method).

To revert all annotations use following script: 

	CmdShortcutCommandActivation revertRedefinedInstances

Redefining logic is very suitable mehanizm to override system behavior which depends on annotations without changing the code.
It can be used to manage particular kind of annotation in settings browser. 
For example shortcut annotations based on Commander are available in setting browser. Users can explore and edit all shortcuts in the system. And these settings are persistable.

-----------Internal Representation and Key Implementation Points------------
 
    Instance Variables
	annotatedClass:		<Class>
	declarationSelector:		<Symbol>
	priority:		<Number>
	activeContext:		<AnnotationContext>!
!ClassAnnotation methodsFor: 'testing' stamp: ''!
isVisibleInContext: anAnnotationUser
	"Annotation is only visible for users which are described by activeContext"
	
	^activeContext describes: anAnnotationUser! !

!ClassAnnotation methodsFor: 'printing' stamp: ''!
printDeclarationOn: aStream

	aStream 
		nextPut: $(;
		nextPutAll: annotatedClass name;
		nextPutAll: ' class>>';
		nextPutAll: declarationSelector;
		nextPut: $)! !

!ClassAnnotation methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ annotatedClass = anObject annotatedClass
		and: [ declarationSelector = anObject declarationSelector ]! !

!ClassAnnotation methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ annotatedClass hash bitXor: declarationSelector hash! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
freshInstance
	"Returnes new annotation instance by evaluating declaration method.
	So new fresh instance will be return which can be different then current one"
	
	^annotatedClass perform: declarationSelector! !

!ClassAnnotation methodsFor: 'redefining' stamp: ''!
revertRedefinedInstance

	^self revertRedefinedInstanceIfAbsent: [
		self error: 'Redefined annotation not exists anymore!!']! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
declarationSelector
	^ declarationSelector! !

!ClassAnnotation methodsFor: 'testing' stamp: ''!
isActiveInContext: anAnnotationUser
	"The annotation can be active only when it is visible for given user.
	But other conditions can be required for concrete type of annotation.
	For example the activeness of the annotation can depends on the state of given user.
	In that case annotation should override this method with extra logic.
	But by default visible annotation is also active"
	
	^self isVisibleInContext: anAnnotationUser! !

!ClassAnnotation methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherClassAnnotation

	^self class = anotherClassAnnotation class 
		and: [annotatedClass = anotherClassAnnotation annotatedClass
			and: [activeContext = anotherClassAnnotation activeContext]]! !

!ClassAnnotation methodsFor: 'redefining' stamp: ''!
redefiningInstance

	^self class redefiningInstanceFor: self! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
declarationSelector: anObject
	declarationSelector := anObject! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
priority
	^ priority! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
priority: anObject
	priority := anObject! !

!ClassAnnotation methodsFor: 'testing' stamp: ''!
isForbidden
	"Subclasses can forbid annotating of particular classes.
	For exampe abstract classes can be forbidden.
	By default annotation can annotate any class"
	
	^false! !

!ClassAnnotation methodsFor: 'testing' stamp: ''!
isRedefined
	^self class isInstanceRedefined: self! !

!ClassAnnotation methodsFor: 'redefining' stamp: ''!
updateRedefinedInstance

	self class updateRedefinedInstance: self! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
id
	^annotatedClass name, '>>', declarationSelector! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
declarationMethod
	^annotatedClass classSide lookupSelector: declarationSelector! !

!ClassAnnotation methodsFor: 'testing' stamp: ''!
annotates: aClass 
	^annotatedClass == aClass! !

!ClassAnnotation methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	priority := 0.
	activeContext := NullAnnotationContext instance! !

!ClassAnnotation methodsFor: 'redefining' stamp: ''!
redefineBy: modifierBlock

	^self class redefineInstance: self by: modifierBlock! !

!ClassAnnotation methodsFor: 'redefining' stamp: ''!
revertRedefinedInstanceIfAbsent: absentBlock

	self class revertRedefinedInstanceFor: self.
	^annotatedClass classAnnotations 
		detect: [ :each | each = self ] ifNone: absentBlock.! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
activeContext
	^ activeContext! !

!ClassAnnotation methodsFor: 'redefining' stamp: ''!
asRedefinedInstance
	"it is a hook method to allow subclasses copy extra state if needed 
	to keep redefined instance in safe"
	^self copy! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
annotatedClass: anObject
	annotatedClass := anObject! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
activeContext: aContextDefinition
	activeContext := aContextDefinition! !

!ClassAnnotation methodsFor: 'accessing' stamp: ''!
annotatedClass
	^ annotatedClass! !

!ClassAnnotation methodsFor: 'testing' stamp: ''!
isObsolete

	^(self class isInstanceRegistered: self) not! !

!ClassAnnotation methodsFor: 'redefining' stamp: ''!
redefinedInstance

	^self class redefinedInstanceFor: self! !

!ClassAnnotation class methodsFor: 'queries-contextual' stamp: ''!
activeInstancesInContext: anAnnotationUser
	"it will return all my registered instances which should be active for given anAnnotationUser"
	
	^self registeredInstances 
		select: [ :each | each isActiveInContext: anAnnotationUser ]! !

!ClassAnnotation class methodsFor: 'private' stamp: ''!
createContainerForRegistry
	^SortedCollection sortBlock: #priority descending! !

!ClassAnnotation class methodsFor: 'private' stamp: ''!
registry

	^ClassAnnotationRegistry default! !

!ClassAnnotation class methodsFor: 'redefining' stamp: ''!
updateRedefinedInstance: aClassAnnotation
	"It updates actual redefined instance of annotation.
	It sets given annotation as new value.
	Both redefined and redefining annotations are equal. 
	So dictionary value can be used as a key"
	
	redefinedInstances ifNil: [ ^self error: 'Given annotation is not redefined!!' ].
	
	redefinedInstances 
		at: aClassAnnotation ifAbsent: [ self error: 'Given annotation is not redefined!!' ].
	
	redefinedInstances at: aClassAnnotation put: aClassAnnotation! !

!ClassAnnotation class methodsFor: 'for tests' stamp: ''!
withAnnotatedClass: aClass
	"This method is created to be used in tests. 
	Normally annotatedClass is initialized by system during annotation registry building"
	
	^self new 
		annotatedClass: aClass! !

!ClassAnnotation class methodsFor: 'queries-general' stamp: ''!
registeredInstancesFor: aClass 
	"it will return all my registered instances which are annotating given aClass"
	
	^self registeredInstances
		select: [ :each | each annotates: aClass ]! !

!ClassAnnotation class methodsFor: 'queries-general' stamp: ''!
registeredInstances

	^self registry allInstancesOf: self! !

!ClassAnnotation class methodsFor: 'redefining' stamp: ''!
revertRedefinedInstanceFor: aClassAnnotation
	redefinedInstances ifNil: [ ^self].
	
	redefinedInstances removeKey: aClassAnnotation ifAbsent: [  ].
	self resetCache! !

!ClassAnnotation class methodsFor: 'queries-contextual' stamp: ''!
visibleInstancesFor: aClass inContext: anAnnotationUser do: aBlock
	"it will enumerate all my registered instances visible for given anAnnotationUser 
	which are annotating given aClass"
	
	self registeredInstances 
		select: [ :each | 
			(each annotates: aClass) and: [each isVisibleInContext: anAnnotationUser] ]
		thenDo: aBlock! !

!ClassAnnotation class methodsFor: 'redefining' stamp: ''!
redefiningInstanceFor: aClassAnnotation
	"It returnes the annotation instance which redefines given default collected annotation"
	
	| assoc |
	redefinedInstances ifNil: [ ^self error: 'Given annotation is not redefined!!' ].
	
	assoc := redefinedInstances 
		associationAt: aClassAnnotation ifAbsent: [ self error: 'Given annotation is not redefined!!' ].
	^assoc key! !

!ClassAnnotation class methodsFor: 'queries-contextual' stamp: ''!
visibleInstancesInContext: anAnnotationUser
	"it will return all my registered instances which should be visible for given anAnnotationUser"
	
	^self registeredInstances 
		select: [ :each | each isVisibleInContext: anAnnotationUser ]! !

!ClassAnnotation class methodsFor: 'redefining' stamp: ''!
redefiningInstances
	redefinedInstances ifNil: [ ^#() ].
	
	^self redefinedInstances keys! !

!ClassAnnotation class methodsFor: 'queries-contextual' stamp: ''!
activeInstancesFor: aClass inContext: anAnnotationUser do: aBlock
	"it will enumerate all my registered instances active for given anAnnotationUser 
	which are annotating given aClass"
	
	self registeredInstances 
		select: [ :each | 
			(each annotates: aClass) and: [each isActiveInContext: anAnnotationUser] ]
		thenDo: aBlock! !

!ClassAnnotation class methodsFor: 'redefining' stamp: ''!
redefineInstance: aClassAnnotation by: aBlock
	| redefined |
	redefinedInstances ifNil: [ redefinedInstances := Dictionary new ].
	
	redefined := redefinedInstances 
		removeKey: aClassAnnotation ifAbsent: [ aClassAnnotation asRedefinedInstance ].
	redefinedInstances at: aClassAnnotation put: redefined.
	aBlock cull: aClassAnnotation! !

!ClassAnnotation class methodsFor: 'instance creation' stamp: ''!
for: anAnnotationContextOrCompatible
	"For example argument can be a class which represents the context"
	^ self new 
		activeContext: anAnnotationContextOrCompatible asAnnotationContext! !

!ClassAnnotation class methodsFor: 'redefining' stamp: ''!
redefinedInstanceFor: aClassAnnotation
	"It returnes the annotation instance which is redefined by given annotation"	
	redefinedInstances ifNil: [ ^self error: 'Given annotation is not redefined!!' ].
	
	^redefinedInstances 
		at: aClassAnnotation ifAbsent: [ self error: 'Given annotation is not redefined!!' ]! !

!ClassAnnotation class methodsFor: 'testing' stamp: ''!
isInstanceRegistered: aClassAnnotation

	^self registry includesAnnotation: aClassAnnotation! !

!ClassAnnotation class methodsFor: 'queries-general' stamp: ''!
findAllAnnotationsFor: aClass 
	
	^self registry allAnnotating: aClass! !

!ClassAnnotation class methodsFor: 'queries-general' stamp: ''!
registeredInstancesDo: aBlock
	
	self registeredInstances do: aBlock! !

!ClassAnnotation class methodsFor: 'redefining' stamp: ''!
redefinedInstances
	self cleanRedefinedGarbage.
	
	^redefinedInstances ifNil: [ #() ]! !

!ClassAnnotation class methodsFor: 'redefining' stamp: ''!
cleanRedefinedGarbage
	"We should remove here all obsolete annotations which not exist in cache anymore.
	It can happen for several reasons: 
		- annotation method was removed.
		- annotated class was removed
		- and various changes related to class hierarchy"	
	redefinedInstances ifNil: [ ^self].
	
	(redefinedInstances select: [ :each | each isObsolete ])
		do: [ :each | redefinedInstances removeKey: each ]! !

!ClassAnnotation class methodsFor: 'queries-contextual' stamp: ''!
visibleInstancesInContext: anAnnotationUser do: aBlock
	"it will enumerate all my registered instances which should be visible for given anAnnotationUser"
	
	self registeredInstances 
		select: [ :each | each isVisibleInContext: anAnnotationUser ]
		thenDo: aBlock! !

!ClassAnnotation class methodsFor: 'for tests' stamp: ''!
for: aContext withAnnotatedClass: aClass
	"This method is created to be used in tests. 
	Normally annotatedClass is initialized by system during annotation registry building"
	
	^(self for: aContext) 
		annotatedClass: aClass! !

!ClassAnnotation class methodsFor: 'queries-contextual' stamp: ''!
activeInstancesInContext: anAnnotationUser do: aBlock
	"it will enumerate all my registered instances which should be active for given anAnnotationUser"
	
	self registeredInstances 
		select: [ :each | each isActiveInContext: anAnnotationUser ]
		thenDo: aBlock! !

!ClassAnnotation class methodsFor: 'testing' stamp: ''!
isInstanceRedefined: aClassAnnotation

	redefinedInstances ifNil: [ ^false ].
	
	^redefinedInstances includesKey: aClassAnnotation! !

!ClassAnnotation class methodsFor: 'redefining' stamp: ''!
revertRedefinedInstances
	
	redefinedInstances := nil.
	self resetCache! !

!ClassAnnotation class methodsFor: 'private' stamp: ''!
resetCache
	<script>
	ClassAnnotationRegistry reset! !

!ClassAnnotationExampleWithFailedForbiddenCheck methodsFor: 'testing' stamp: ''!
isForbidden
	self error: 'Failed forbidden check should lead to the BrokenClassAnnotation instance'! !

!ClassAnnotationRegistry commentStamp: ''!
I implement a registry of class annotations.
I organize it in two dictionaries:

1)  annotations
It maps annotation class to all instances of this class. Instances are sorted by annotation priority in ascending order. 
Annotation class is responsible to provide such container: 

	ClassAnnotation createContainerForRegistry

For details about annotation priorities look at ClassAnnotation comment.

2) annotatedClasses
It maps annotated class to all its annotations. The annotations are managed as a Set.

I provide default instance which keeps all class annotations in the system.

	ClassAnnotationRegistry default
	
 It is used by ClassAnnotation query methods and you can access it from it:
	
	ClassAnnotation registry

I am subscribed on system changes and reset default instance when related methods or classes are changed.
And when user access annotations I rebuild it lazily. 
Look for details in class side method #ensureSystemSubscription  

Internal Representation and Key Implementation Points.

    Instance Variables
	annotations:		<IdentityDictionary<ClassAnnotation class, SortedCollection<ClassAnnotation>>>
	annotatedClasses:		<IdentityDictionary<Class, Set<ClassAnnotation>>>!
!ClassAnnotationRegistry methodsFor: 'accessing' stamp: ''!
annotatedClasses
	^ annotatedClasses! !

!ClassAnnotationRegistry methodsFor: 'testing' stamp: ''!
includesAnnotation: aClassAnnotation

	| allClassAnnotations |
	allClassAnnotations := annotatedClasses at: aClassAnnotation annotatedClass ifAbsent: [ ^false ].
	^allClassAnnotations includes: aClassAnnotation! !

!ClassAnnotationRegistry methodsFor: 'accessing' stamp: ''!
annotations: anObject
	annotations := anObject! !

!ClassAnnotationRegistry methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	annotations := IdentityDictionary new.
	annotatedClasses := IdentityDictionary new! !

!ClassAnnotationRegistry methodsFor: 'private' stamp: ''!
createAnnotationsForAllSubclassesFromPragma: aPragma
	
	| declaringClass annotation result |
	result := OrderedCollection new.
	declaringClass := aPragma methodClass instanceSide.
	declaringClass withAllSubclassesDo: [ :annotatedClass | 
		annotation := self createAnnotationFor: annotatedClass fromPragma: aPragma. 
		result add: annotation].
	^result! !

!ClassAnnotationRegistry methodsFor: 'accessing' stamp: ''!
annotations
	^ annotations! !

!ClassAnnotationRegistry methodsFor: 'accessing' stamp: ''!
addAnnotation: aClassAnnotation
	| container actualAnnotation |
	actualAnnotation := aClassAnnotation.
	actualAnnotation isRedefined ifTrue: [
		actualAnnotation updateRedefinedInstance.
		actualAnnotation := actualAnnotation redefiningInstance].
	
	container := annotations at: actualAnnotation class ifAbsentPut: [ 
		aClassAnnotation class createContainerForRegistry ].
	(container includes: actualAnnotation) ifTrue: [ ^self ].
	container add: actualAnnotation.

	container := annotatedClasses 
		at: actualAnnotation annotatedClass ifAbsentPut: [ Set new].
	container add: actualAnnotation! !

!ClassAnnotationRegistry methodsFor: 'queries' stamp: ''!
allInstancesOf: anAnnotationClass

	^annotations at: anAnnotationClass ifAbsent: [ #() ]! !

!ClassAnnotationRegistry methodsFor: 'private' stamp: ''!
createAnnotationFor: aClass fromPragma: aPragma
	"Here we evaluate pragma method expecting annotation instance as result.
	Of course the method can fail or it can not return annotation 
	(user can forgot return for example). 
	In such cases BrokenClassAnnotation will be used instead.
	Also here we perform check isForbidden which should be evaluated on initialized instance 
	and also can fail due to bad implementation. 
	Failed check will also lead to BrokenClassAnnotation instance.
	If annotation instance is forbidden 
	then the ForbiddenClassAnnotation instance will be returned instead.
	And it will will not be added to the registry"
	| annotation |
	[
		annotation := aClass perform: aPragma methodSelector.
		(annotation isKindOf: ClassAnnotation) ifFalse: [ 
			annotation := BrokenClassAnnotation forBadMethodReturn].
		"isForbidden should be performed with initialized instance"
		annotation 
			annotatedClass: aClass;
			declarationSelector: aPragma methodSelector.
		annotation isForbidden ifTrue: [ annotation := ForbiddenClassAnnotation new ]
	] on: Error do: [:err | 
		annotation := BrokenClassAnnotation withError: err].
	"For simplisity initialization is repeated although it can be already initialized"
	^annotation 
		annotatedClass: aClass;
		declarationSelector: aPragma methodSelector! !

!ClassAnnotationRegistry methodsFor: 'queries' stamp: ''!
allAnnotating: aClass

	^annotatedClasses at: aClass ifAbsent: [ #() ]! !

!ClassAnnotationRegistry methodsFor: 'accessing' stamp: ''!
annotatedClasses: anObject
	annotatedClasses := anObject! !

!ClassAnnotationRegistry methodsFor: 'testing' stamp: ''!
includesAnnotationsFor: aClass

	^annotatedClasses includesKey: aClass! !

!ClassAnnotationRegistry methodsFor: 'accessing' stamp: ''!
addAllFromPragmas: pragmas

	| collectedAnnotations |
	pragmas do: [ :pragma |
		collectedAnnotations := self createAnnotationsForAllSubclassesFromPragma: pragma.
		collectedAnnotations do: [ :each | self addAnnotation: each]]! !

!ClassAnnotationRegistry methodsFor: 'testing' stamp: ''!
includesAnnotationsInheritedBy: aClass

	aClass superclass ifNil: [ ^false ].
	
	^self includesAnnotationsFor: aClass superclass! !

!ClassAnnotationRegistry methodsFor: 'accessing' stamp: ''!
forgetAnnotation: aClassAnnotation
	"This test was created for tests to emulate that annotation not exist anymore"
	| container |

	container := annotations at: aClassAnnotation class ifAbsent: [ ^self ].
	container remove: aClassAnnotation ifAbsent: [ ^self ].
	
	(annotatedClasses at: aClassAnnotation annotatedClass) remove: aClassAnnotation! !

!ClassAnnotationRegistry class methodsFor: 'pragma collecting' stamp: ''!
annotationPragmasIn: aClass do: aBlock

	aClass pragmasDo: [ :pragma |
		pragma selector == self annotationPragmaName ifTrue: [aBlock value: pragma]]! !

!ClassAnnotationRegistry class methodsFor: 'system changes' stamp: ''!
doesMethodDefineAnnotation: aMethod
	"The second condition allows to mark methods 
	which are sent inside annotation definition methods 
	which makes them annotation dependency.
	For example CmdShortcutCommandActivation annotation has method #removaFor:.
	It provides reusable cmd+x shorcut. And all removal related commands are depends on it.
	When user will modify this method the annotation registry will be updated 
	because of <classAnnotationDependency> pragma"
	
	^(aMethod hasPragmaNamed: self annotationPragmaName)
		or: [ aMethod hasPragmaNamed: self annotationDependencyPragmaName ]! !

!ClassAnnotationRegistry class methodsFor: 'system changes' stamp: ''!
handleOldMethodChange: aMethodModified
	
	self resetIf: [ self doesMethodAffectAnnotations: aMethodModified oldMethod]! !

!ClassAnnotationRegistry class methodsFor: 'instance creation' stamp: ''!
collectNewFromSystem
	^self new
		addAllFromPragmas: self collectAnnotationPragmas! !

!ClassAnnotationRegistry class methodsFor: 'system changes' stamp: ''!
handleMethodChange: aMethodAnnouncement
	
	self resetIf: [ self doesMethodAffectAnnotations: aMethodAnnouncement methodAffected]! !

!ClassAnnotationRegistry class methodsFor: 'pragma collecting' stamp: ''!
annotationPragmaName
	"This pragma is used to define class annotations inside methods.
	They should return instances of ClassAnnotation subclasses"
	
	^#classAnnotation! !

!ClassAnnotationRegistry class methodsFor: 'pragma collecting' stamp: ''!
collectAnnotationPragmas

	| result |
	result := OrderedCollection new.
	
	self environment allClassesDo: [ :each | 
		self annotationPragmasIn: each classSide do: [:pragma | result add: pragma]].
	self environment allTraitsDo: [ :each | 
		self annotationPragmasIn: each classSide do: [:pragma | result add: pragma]].
	
	^result! !

!ClassAnnotationRegistry class methodsFor: 'system changes' stamp: ''!
ensureSystemSubscription

	SystemAnnouncer uniqueInstance unsubscribe: self.
	
	SystemAnnouncer uniqueInstance weak
		when: ClassRemoved, ClassAdded, ClassModificationApplied send: #handleClassChanged: to: self;
		when: MethodRemoved, MethodAdded, MethodModified send: #handleMethodChange: to: self;
		when: MethodModified send: #handleOldMethodChange: to: self! !

!ClassAnnotationRegistry class methodsFor: 'system changes' stamp: ''!
handleClassChanged: aClassAnnouncement

	self resetIf: [ 
		(default includesAnnotationsFor: aClassAnnouncement classAffected)
			or: [default includesAnnotationsInheritedBy: aClassAnnouncement classAffected]]! !

!ClassAnnotationRegistry class methodsFor: 'system changes' stamp: ''!
doesMethodAffectAnnotations: aMethod
	
	(self doesMethodDefineAnnotation: aMethod) ifTrue: [ ^true ].

	aMethod methodClass superclass ifNotNil: [ :parentClass | 
		"check if there is overridden method which defines annotation"
		(parentClass lookupSelector: aMethod selector) ifNotNil: [:overriddenMethod |
			(self doesMethodDefineAnnotation: overriddenMethod) ifTrue: [^true]].
	].	

	^false! !

!ClassAnnotationRegistry class methodsFor: 'accessing' stamp: ''!
default
	^default ifNil: [ 
		self ensureSystemSubscription.
		default := self collectNewFromSystem]! !

!ClassAnnotationRegistry class methodsFor: 'accessing' stamp: ''!
resetIf: conditionBlock
	default ifNil: [ ^self ].
	
	conditionBlock value ifTrue: [ self reset ]! !

!ClassAnnotationRegistry class methodsFor: 'pragma collecting' stamp: ''!
annotationDependencyPragmaName
	"This pragma is used to mark methods which are sent inside annotation definition methods.
	They are annotation dependencies.
	For example CmdShortcutCommandActivation annotation has method #removaFor:.
	It provides reusable cmd+x shorcut. And all removal related commands are depends on it.
	When user will modify this method the annotation registry will be updated"
	
	^#classAnnotationDependency! !

!ClassAnnotationRegistry class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	
	SystemAnnouncer uniqueInstance unsubscribe: self.
	default := nil! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testRedefiningInstanceTwice
	| annotation newAnnotation reverted |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	
	annotation redefineBy: [ annotation priority: -1000 ].
	self assert: annotation redefinedInstance priority equals: 0.
	annotation redefineBy: [ annotation priority: -2000 ].
	self assert: annotation redefinedInstance priority equals: 0.
	
	ClassAnnotation resetCache.
	newAnnotation := ClassWithSingleAnnotation classAnnotations anyOne.
	self assert: newAnnotation priority equals: -2000.
	newAnnotation revertRedefinedInstance.
	reverted := ClassWithSingleAnnotation classAnnotations anyOne.
	self assert: reverted priority equals: 0.! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testObsolete
	| annotation |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	self deny: annotation isObsolete.
	
	ClassAnnotation registry forgetAnnotation: annotation.
	
	self assert: annotation isObsolete! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testHasZeroPriorityByDefault
	
	| ann |
	ann := ClassAnnotationExample1 new.
	
	self assert: ann priority equals: 0! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testGettingFreshInstance
	| ann actual |
	ann := ClassAnnotationExample1 withAnnotatedClass: ClassWithSingleAnnotation.
	ann declarationSelector: #annotationExample. 
	
	actual := ann freshInstance.
	
	self assert: actual equals: ClassWithSingleAnnotation annotationExample! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testNotSimilarToAnnotationOfDifferentClass
	| ann1 ann2 |
	ann1 := ClassAnnotationExample1 withAnnotatedClass: ClassWithSingleAnnotation.
	
	ann2 := ClassAnnotationExample1 withAnnotatedClass: SubclassWithOnlyInheritedAnnotation.
	
	self deny: (ann1 isSimilarTo: ann2)! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testNotSimilarToDifferentKindAnnotation
	| ann1 ann2 |
	ann1 := ClassAnnotationExample1 withAnnotatedClass: ClassWithSingleAnnotation.
	
	ann2 := ClassAnnotationExample2 withAnnotatedClass: ClassWithSingleAnnotation.
	
	self deny: (ann1 isSimilarTo: ann2)! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testGettingAllRedefinedInstances
	| annotation allRedefined |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	annotation redefineBy: [ annotation priority: -1000 ].

	allRedefined := annotation class redefinedInstances.	
	self assert: allRedefined size equals: 1.
	self assert: allRedefined anyOne priority equals: 0! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testRedefiningInstanceUsingBlockWithArgument
	| newAnnotation |
	
	ClassWithSingleAnnotation classAnnotations anyOne
		redefineBy: [:annotation | annotation priority: -1000 ].
		
	newAnnotation := ClassWithSingleAnnotation classAnnotations anyOne.
	self assert: newAnnotation priority equals: -1000.
	self assert: newAnnotation isRedefined! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testCheckIfAnnotatesGivenClass
	| ann|
	ann := ClassAnnotationExample1 withAnnotatedClass: ClassWithSingleAnnotation.
	
	self assert: (ann annotates: ClassWithSingleAnnotation).
	self deny: (ann annotates: ClassWithThreeAnnotations)! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testRedefiningInstance
	| annotation newAnnotation |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	
	annotation redefineBy: [ annotation priority: -1000 ].
	self assert: annotation priority equals: -1000.
	self assert: annotation isRedefined.
	
	ClassAnnotation resetCache.
	newAnnotation := ClassWithSingleAnnotation classAnnotations anyOne.
	self assert: newAnnotation priority equals: -1000.
	self assert: newAnnotation isRedefined! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testGettingRedefinedInstance
	| annotation redefinedInstance |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	annotation redefineBy: [ annotation priority: -1000 ].

	redefinedInstance := annotation redefinedInstance.
	self deny: redefinedInstance identicalTo: annotation.
	self assert: redefinedInstance priority equals: 0.
	self assert: redefinedInstance isRedefined! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testGettingAllRedefiningInstances
	| annotation allRedefining |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	annotation redefineBy: [ annotation priority: -1000 ].

	allRedefining := annotation class redefiningInstances.
	self assert: allRedefining size equals: 1.
	self assert: allRedefining anyOne priority equals: -1000.
	self assert: allRedefining anyOne identicalTo: annotation! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testComparisonOfTwoDifferentAnnotations
	| ann1 ann2 |
	ann1 := ClassAnnotationExample1 withAnnotatedClass: ClassWithSingleAnnotation.
	ann1 declarationSelector: #selector1.

	ann2 := ClassAnnotationExample2 withAnnotatedClass: ClassWithSingleAnnotation.
	ann2 declarationSelector: #selector1.

	self deny: ann1 equals: ann2! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testGettingAllRedefinedInstancesShouldCleanGarbage
	| annotation allRedefined |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	annotation redefineBy: [ annotation priority: -1000 ].
	
	ClassAnnotation registry forgetAnnotation: annotation.
	
	allRedefined := annotation class redefinedInstances.	
	self assert: allRedefined isEmpty! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testGettingAllRedefiningInstancesShouldCleanGarbage
	| annotation allRedefined |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	annotation redefineBy: [ annotation priority: -1000 ].
	
	ClassAnnotation registry forgetAnnotation: annotation.
	
	allRedefined := annotation class redefiningInstances.	
	self assert: allRedefined isEmpty! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testRevertingAllRedefinedInstances
	| annotation |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	annotation class revertRedefinedInstances.
	
	self assert: annotation class redefinedInstances isEmpty.
	self assert: annotation class redefiningInstances isEmpty! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testNotSimilarToAnnotationOfSameClassButForDifferentContext
	| ann1 ann2 |
	ann1 := ClassAnnotationExample1 withAnnotatedClass: ClassWithSingleAnnotation.
	
	ann2 := ClassAnnotationExample1 for: AnnotationUserExample withAnnotatedClass: ClassWithSingleAnnotation.
	
	self deny: (ann1 isSimilarTo: ann2)! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testComparisonOfTwoAnnotationsWithSameSelectorAndClass
	| ann1 ann2 |
	ann1 := ClassAnnotationExample1 withAnnotatedClass: ClassWithThreeAnnotations.
	ann1 declarationSelector: #selector1.
	
	ann2 := ClassAnnotationExample1 withAnnotatedClass: ClassWithThreeAnnotations.
	ann2 declarationSelector: #selector1.
	
	self assert: ann1 equals: ann2.
	self assert: ann1 hash equals: ann2 hash! !

!ClassAnnotationTest methodsFor: 'running' stamp: ''!
tearDown
	"Some tests redefine following annotation. 
	Here we clear redefining state which forces cache reset"
	ClassAnnotationExample3 revertRedefinedInstances.
	"ClassAnnotationExample3 = ClassWithSingleAnnotation classAnnotations anyOne class"
	
	super tearDown.! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testCreationForExplicitAnnotationContext
	| ann context |
	context := SimpleAnnotationContext of: AnnotationUserExample.
	ann := ClassAnnotationExample1 for: context.
	
	self assert: ann class equals: ClassAnnotationExample1.
	self assert: ann activeContext equals: context.! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testForgettingAnnotation
	| annotation |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	
	ClassAnnotation registry forgetAnnotation: annotation.
	
	self assert: ClassWithSingleAnnotation classAnnotations isEmpty! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testComparisonOfTwoAnnotationsWithDifferentClass
	| ann1 ann2 |
	ann1 := ClassAnnotationExample1 withAnnotatedClass: ClassWithSingleAnnotation.
	ann1 declarationSelector: #selector1.

	ann2 := ClassAnnotationExample1 withAnnotatedClass: SubclassWithOnlyInheritedAnnotation.
	ann2 declarationSelector: #selector1.

	self deny: ann1 equals: ann2! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testSimilarToAnnotationOfSameClassForSameContext
	| ann1 ann2 |
	ann1 := ClassAnnotationExample1 for: AnnotationUserExample withAnnotatedClass: ClassWithSingleAnnotation.
	
	ann2 := ClassAnnotationExample1 for: AnnotationUserExample withAnnotatedClass: ClassWithSingleAnnotation.
	
	self assert: (ann1 isSimilarTo: ann2)! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testComparisonOfTwoAnnotationsWithDifferentSelector
	| ann1 ann2 |
	ann1 := ClassAnnotationExample1 withAnnotatedClass: ClassWithThreeAnnotations.
	ann1 declarationSelector: #selector1.

	ann2 := ClassAnnotationExample1 withAnnotatedClass: ClassWithThreeAnnotations.
	ann2 declarationSelector: #selector2.

	self deny: ann1 equals: ann2! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testSimilarToAnnotationOfSameClassWhenBothDoNotDefinedWithContext
	| ann1 ann2 |
	ann1 := ClassAnnotationExample1 withAnnotatedClass: ClassWithSingleAnnotation.
	
	ann2 := ClassAnnotationExample1 withAnnotatedClass: ClassWithSingleAnnotation.
	
	self assert: (ann1 isSimilarTo: ann2)! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testHasNullContextByDefault
	
	| ann |
	ann := ClassAnnotationExample1 new.
	
	self assert: ann activeContext equals: NullAnnotationContext instance! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testRevertingRedefinedInstance
	| annotation revertedAnnotation |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	annotation redefineBy: [ annotation priority: -1000 ].
	revertedAnnotation := annotation revertRedefinedInstance.

	self deny: revertedAnnotation identicalTo: annotation.
	self assert: revertedAnnotation identicalTo: ClassWithSingleAnnotation classAnnotations anyOne.
	self assert: revertedAnnotation priority equals: 0.
	self deny: revertedAnnotation isRedefined! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testGettingRedefiningInstance
	| annotation actual |
	annotation := ClassWithSingleAnnotation classAnnotations anyOne.
	annotation redefineBy: [ annotation priority: -1000 ].

	actual := annotation copy redefiningInstance.

	self assert: actual identicalTo: annotation! !

!ClassAnnotationTest methodsFor: 'tests' stamp: ''!
testGettingSingleAnnotationUsingSelector
	| expected actual |
	expected := ClassWithThreeAnnotations classAnnotations detect: [ :each | each declarationSelector = #annotationExample2 ].
	actual := ClassWithThreeAnnotations classAnnotationAt: #annotationExample2.

	self assert: actual identicalTo: expected! !

!ClassAnnotationTestCase class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClassAnnotationTestCase! !

!ClassAnnouncement commentStamp: ''!
I am an abstract class used to gather all the announcements related to class modifications.!
!ClassAnnouncement methodsFor: 'accessing' stamp: ''!
packagesAffected
	^{self packageAffected}! !

!ClassAnnouncement methodsFor: 'testing' stamp: ''!
affectsClasses
	^true! !

!ClassAnnouncement methodsFor: 'accessing' stamp: ''!
classAffected
	self subclassResponsibility ! !

!ClassAnnouncement methodsFor: 'testing' stamp: ''!
affectsClassesDefinedInPackage: aPackage
	^self packagesAffected includes: aPackage! !

!ClassAnnouncement methodsFor: 'testing' stamp: ''!
affectsClassesExtendedInPackage: aPackage
	^aPackage extendsClass: self classAffected! !

!ClassAnnouncement methodsFor: 'testing' stamp: ''!
affectsPackages
	^true! !

!ClassAnnouncement methodsFor: 'accessing' stamp: ''!
classTagAffected
	^self packageAffected toTagName: self classAffected category! !

!ClassAnnouncement methodsFor: 'testing' stamp: ''!
affectsClass: aClass
	^self classAffected == aClass! !

!ClassAnnouncement methodsFor: 'accessing' stamp: ''!
packageAffected
	^self classAffected package! !

!ClassBuilderError commentStamp: ''!
I represent an error raised while building a class. !
!ClassChangeRecord commentStamp: ''!
A ClassChangeRecorder keeps track of most substantive changes premissible in a project, isolated or not.

Structure:
inForce		a boolean
			Tells whether these changes are in effect.
			true for all changeSets in and above the current project.
			It should be sufficient only to record this for the changeSet
			as a whole, but this redundancy could help in error recovery.
classIsLocal	a boolean
			True if and only if this class is defined in this layer of the
			project structure.
changeTypes an identitySet
			Summarizes which changes have been made in this class.
			Values include #comment, #reorganize, #rename,
			and the four more summarized below.
thisName	a string
			Retains the class name for this layer.
priorName	a string
			Preserves the prior name.
thisComment	a text
			Retains the class comment for this layer.
priorComment	a text
			Preserves the prior comment.
thisOrganization	a classOrganizer
			Retains the class organization for this layer.
priorOrganization	a classOrganizer
			Preserves the prior organization.
thisMD	a methodDictionary
			Used to prepare changes for nearly atomic invocation
			of this layer (see below).
priorMD	a methodDictionary
			Preserves the state of an altered class as it exists in the next
			outer layer of the project structure.
methodChanges		a dictionary of classChangeRecords
			Retains all the method changes for this layer.

Four of the possible changeTypes are maintained in a mutually exclusive set, analogously to MethodChangeRecords.  Here is a simple summary of the relationship between these four changeType symbols and the recording of prior state
			|	prior == nil			|	prior not nil	
	---------	|----------------------------	|--------------------
	add		|	add					|	change
	---------	|----------------------------	|--------------------
	remove	|	addedThenRemoved	|	remove

A classChangeRecorder is notified of changes by the method
		noteMethodChange: <ClassChangeRecord>.
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: 'removing' stamp: 'nil'!
forgetChangesIn: otherRecord
	"See forgetAllChangesFoundIn:.  Used in culling changeSets."

	| cls otherMethodChanges |
	(cls := self realClass) ifNil: [ ^ self ].	"We can do better now, though..."
	otherMethodChanges := otherRecord methodChangeTypes.
	otherMethodChanges
		associationsDo: [ :assoc | 
			| selector actionToSubtract |
			selector := assoc key.
			actionToSubtract := assoc value.
			(cls includesSelector: selector)
				ifTrue: [ 
					(#(#add #change) includes: actionToSubtract)
						ifTrue: [ methodChanges removeKey: selector ifAbsent: [  ] ] ]
				ifFalse: [ 
					(#(#remove #addedThenRemoved) includes: actionToSubtract)
						ifTrue: [ methodChanges removeKey: selector ifAbsent: [  ] ] ] ].
	changeTypes isEmpty
		ifTrue: [ ^ self ].
	changeTypes removeAllFoundIn: otherRecord allChangeTypes.
	(changeTypes includes: #rename)
		ifFalse: [ changeTypes removeAllSuchThat: [ :x | x beginsWith: 'oldName: ' ] ]! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'nil'!
allChangeTypes
	| chgs |
	(priorName notNil and: [ changeTypes includes: #rename ])
		ifTrue: [ 
			(chgs := changeTypes copy) add: 'oldName: ' , priorName.
			^ chgs ].
	^ changeTypes! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'nil'!
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: 'definition' stamp: 'nil'!
priorDefinition

	^ priorDefinition! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'nil'!
changedSelectors
	"Return a set of the changed or removed selectors."

	^ methodChanges keys! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'nil'!
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: 'method changes' stamp: 'nil'!
findOrMakeMethodChangeAt: selector priorMethod: priorMethod 
	^methodChanges at: selector
		ifAbsentPut: [MethodChangeRecord new]! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'nil'!
methodChanges

	^ methodChanges! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'nil'!
atSelector: selector put: changeType

	(self findOrMakeMethodChangeAt: selector priorMethod: nil)
		noteChangeType: changeType! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'nil'!
atSelector: selector ifAbsent: absentBlock

	^ (methodChanges at: selector ifAbsent: absentBlock)
		changeType! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'nil'!
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: 'nil'!
includesChangeType: changeType

	changeType == #new ifTrue: [^ changeTypes includes: #add].  "Backwd compat"
	^ changeTypes includes: changeType! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'nil'!
noteNewMethod: newMethod selector: selector priorMethod: methodOrNil
	| methodChange |
	methodChange := self findOrMakeMethodChangeAt: selector priorMethod: methodOrNil.
	methodOrNil 
		ifNil: [ methodChange noteChangeType: #add ]
		ifNotNil: [ methodChange noteChangeType: #change ].! !

!ClassChangeRecord methodsFor: 'rename' stamp: 'nil'!
priorName

	^ priorName! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'nil'!
noteChangeType: changeSymbol

	^ self noteChangeType: changeSymbol fromClass: nil! !

!ClassChangeRecord methodsFor: 'removing' stamp: 'nil'!
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: 'definition' stamp: 'nil'!
notePriorDefinition: oldClass

	oldClass ifNil: [^ self].
	priorDefinition ifNil: [priorDefinition := oldClass definitionString ]! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'nil'!
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: 'definition' stamp: 'nil'!
checkCoherence
	"If I recreate the class then don't remove it"

	(changeTypes includes: #remove)
		ifTrue: [ 
			changeTypes remove: #remove.
			changeTypes add: #change ].
	(changeTypes includes: #addedThenRemoved)
		ifFalse: [ ^ self ].
	changeTypes remove: #addedThenRemoved.
	changeTypes add: #add! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'nil'!
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: 'rename' stamp: 'nil'!
noteNewName: newName

	thisName := newName! !

!ClassChangeRecord methodsFor: 'initialization' stamp: 'nil'!
initFor: className

	changeTypes := IdentitySet new.
	methodChanges := IdentityDictionary new.
	priorName := thisName := className.! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'nil'!
hasNoChanges

	^ changeTypes isEmpty and: [methodChanges isEmpty]! !

!ClassChangeRecord methodsFor: 'rename' stamp: 'nil'!
thisName

	^ thisName! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'nil'!
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: 'isolation layers' stamp: 'nil'!
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 ] ]! !

!ClassCommentChunk commentStamp: ''!
I represent the declaration of a class comment in a file.  My contents are the class comment to import, and the comment reader is the object who knows the class where to put the class comment.

Sending me the message #import makes me install the comment into the class.!
!ClassCommentChunk methodsFor: 'accessing' stamp: ''!
stamp
	^ stamp! !

!ClassCommentChunk methodsFor: 'accessing' stamp: ''!
stamp: classCommentStamp
	stamp := classCommentStamp! !

!ClassCommentChunk methodsFor: 'importing' stamp: ''!
importFor: aRequestor logSource: logSource
	(self existsBehavior)
		ifFalse: [ self error: ('Cannot install comment in unexistent behavior {1}' format: { behaviorName asString } ) ].
	
	^self targetClass instanceSide
						classComment: contents
						stamp: stamp! !

!ClassCommentChunk methodsFor: 'accessing' stamp: ''!
description

	^ 'Comment (', behaviorName, ')', stamp asString! !

!ClassCommentChunk methodsFor: 'testing' stamp: ''!
isClassCommentDeclaration

	^ true! !

!ClassCommentChunk methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	^ aVisitor visitClassCommentChunk: self! !

!ClassCommentChunk class methodsFor: 'instance creation' stamp: ''!
contents: someContents behaviorName: behaviorName isMeta: aBoolean stamp: stamp
	^self new
			contents: someContents;
			behaviorName: behaviorName;
			isMeta: aBoolean;
			stamp: stamp;
			yourself! !

!ClassCommented commentStamp: ''!
This announcement will be emitted when a class or a trait comment changes!
!ClassCommented methodsFor: 'accessing' stamp: ''!
classCommented
	^classCommented! !

!ClassCommented methodsFor: 'accessing' stamp: ''!
newStamp: aNewStamp
	newStamp := aNewStamp! !

!ClassCommented methodsFor: 'accessing' stamp: ''!
classAffected
	^self classCommented! !

!ClassCommented methodsFor: 'accessing' stamp: ''!
newComment
	^newComment! !

!ClassCommented methodsFor: 'accessing' stamp: ''!
newStamp
	^newStamp! !

!ClassCommented methodsFor: 'accessing' stamp: ''!
classCommented: aClass
	classCommented := aClass! !

!ClassCommented methodsFor: 'accessing' stamp: ''!
oldComment: andOldComment
	oldComment := andOldComment! !

!ClassCommented methodsFor: 'accessing' stamp: ''!
oldComment
	^ oldComment! !

!ClassCommented methodsFor: 'accessing' stamp: ''!
oldStamp: anOldStamp
	oldStamp := anOldStamp! !

!ClassCommented methodsFor: 'accessing' stamp: ''!
newComment: aNewComment
	newComment := aNewComment! !

!ClassCommented methodsFor: 'accessing' stamp: ''!
oldStamp
	^ oldStamp! !

!ClassCommented class methodsFor: 'instance creation' stamp: ''!
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: ''!
classCommented: aClass
	self flag: #pharoFixMe. "nils? no way!! "
	^self class: aClass oldComment: nil newComment: nil oldStamp: nil newStamp: nil! !

!ClassDefinitionPrinter commentStamp: ''!
The idea is that we want to have a printer


ClassDefinitionPrinter 
	should be able to return either a specific printer
	or the default one shared globally.
	By default this ithe one we want to use. 

```	
ClassDefinitionPrinter showFluidClassDefinition.

(ClassDefinitionPrinter for: Array) definitionString
```
should return

```
ArrayedCollection < #Array
	layout: VariableLayout;
	tag: ''Base'';
	package: ''Collections-Sequenceable'''
```
	

```
ClassDefinitionPrinter new 
	oldPharo;
	for: Array;
	definitionString
	
ClassDefinitionPrinter new 
	fluid;
	for: Array;
	definitionString
	
ClassDefinitionPrinter new 
	legacy;
	for: Array;
	definitionString
```	

In addition the printer should support 
	- templateDefinitionString
	
	- expandedDefinitionString is the same as definitionString on OldPharo and Legacy.







!
!ClassDefinitionPrinter methodsFor: 'printing' stamp: ''!
definitionString
	"The method is part of the double dispatch. It is an extra starting point. 
	Each entity will select the right definition and call me back.
	Normally this method is not used because the main point is the class...."
	
	^ forClass definitionStringFor: self! !

!ClassDefinitionPrinter methodsFor: 'accessing' stamp: ''!
for: aClass 
	forClass := aClass! !

!ClassDefinitionPrinter methodsFor: 'printing' stamp: ''!
expandedDefinitionString
	"The method is part of the double dispatch. It is an extra starting point. 
	Each entity will select the right definition and call me back.
	Normally this method is not used because the main point is the class...."
	
	^ forClass expandedDefinitionStringFor: self! !

!ClassDefinitionPrinter class methodsFor: 'instance creation' stamp: ''!
new

	^ self showFluidClassDefinition
			ifTrue: [ self fluid ]
			ifFalse: [ self oldPharo ]! !

!ClassDefinitionPrinter class methodsFor: 'configure' stamp: ''!
displayEmptySlots

	^ DisplayEmptySlots ifNil: [ DisplayEmptySlots := true ]! !

!ClassDefinitionPrinter class methodsFor: 'instance creation' stamp: ''!
for: aClass 
	"Given the current class definition syntax and the need for the class, 
	return the correct printer. 
	We only print slots with the fluid class definition."
	
	| instance |
	instance := 
		(aClass needsSlotClassDefinition 
			or: [ self showFluidClassDefinition ])
				ifTrue: [ self fluid ]
				ifFalse: [ self oldPharo ].
	^ instance
		for: aClass; 
		yourself! !

!ClassDefinitionPrinter class methodsFor: 'configure' stamp: ''!
showFluidClassDefinition

	^ ShowFluidClassDefinition ifNil: [ ShowFluidClassDefinition := false ]! !

!ClassDefinitionPrinter class methodsFor: 'configure' stamp: ''!
toggleShowFluidClassDefinition

	self showFluidClassDefinition: self showFluidClassDefinition not! !

!ClassDefinitionPrinter class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	"This method could be packaged in a setting kernel related package.
	For now when the Settings system is not available it will just be deadcode."
	
	<systemsettings>
	(aBuilder setting: #showFluidClassDefinition)
		parent: #codeBrowsing;
		default: false;
		label: 'Use fluid class definition';
		description: 'If true, the system will display the class definition using a fluid interface e.g., 

Object << #Point
	slots: { #x . #y };
	tag: ''BasicObjects'';
	package: ''Kernel''
	
We suggest to use it because it will become the default syntax for Pharo. This new class definition has been designed to control the parameter explosion of the old one. 
In addition, as soon as you will use slots such as ObservableSlot and more this fluid class definition will be used because the old one is not handling well the slots.';
		target: self.
		
	(aBuilder setting: #displayEmptySlots)
		parent: #codeBrowsing;
		default: true;
		label: 'Display empty slots';
		description: 'If true, the system will display the slots even if they are empty e.g., 

Object << #Faked
	slots: { };
	tag: ''BasicObjects'';
	package: ''Kernel''
	';
		target: self.! !

!ClassDefinitionPrinter class methodsFor: 'instance creation' stamp: ''!
fluid 
	^  FluidClassDefinitionPrinter basicNew initialize! !

!ClassDefinitionPrinter class methodsFor: 'configure' stamp: ''!
showFluidClassDefinition: aBoolean
 
	ShowFluidClassDefinition := aBoolean! !

!ClassDefinitionPrinter class methodsFor: 'configure' stamp: ''!
displayEmptySlots: aBoolean

	DisplayEmptySlots := aBoolean! !

!ClassDefinitionPrinter class methodsFor: 'instance creation' stamp: ''!
oldPharo 
	^ OldPharoClassDefinitionPrinter basicNew initialize! !

!ClassDefinitionPrinter class methodsFor: 'instance creation' stamp: ''!
legacy
	^ LegacyClassDefinitionPrinter basicNew initialize! !

!ClassDefinitionPrinterConfigurationTest methodsFor: 'tests' stamp: ''!
testLegacyPharoConfiguration

	self 
		assert: (ClassDefinitionPrinter legacy
 						for: Array;
						definitionString)
		equals: 'ArrayedCollection variableSubclass: #Array
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''Collections-Sequenceable-Base'''! !

!ClassDefinitionPrinterConfigurationTest methodsFor: 'tests' stamp: ''!
testToggleIsWorking

	| value |
	value := ClassDefinitionPrinter showFluidClassDefinition.
	ClassDefinitionPrinter toggleShowFluidClassDefinition.
	self assert: ClassDefinitionPrinter showFluidClassDefinition equals: value not.! !

!ClassDefinitionPrinterConfigurationTest methodsFor: 'tests' stamp: ''!
testFluidConfiguration

	self 
		assert: (ClassDefinitionPrinter fluid
 						for: Array;
						definitionString)
		equals: 'ArrayedCollection << #Array
	layout: VariableLayout;
	tag: ''Base'';
	package: ''Collections-Sequenceable'''! !

!ClassDefinitionPrinterConfigurationTest methodsFor: 'tests' stamp: ''!
testOldPharoConfiguration

	self 
		assert: (ClassDefinitionPrinter oldPharo
 						for: Array;
						definitionString)
		equals: 'ArrayedCollection variableSubclass: #Array
	instanceVariableNames: ''''
	classVariableNames: ''''
	package: ''Collections-Sequenceable-Base'''! !

!ClassDescription commentStamp: ''!
I add a number of facilities to basic Behaviors:
	Named instance variables
	Category organization for methods
	The notion of a name of this class (implemented as subclass responsibility)
	The maintenance of a ChangeSet, and logging changes on a file
	Most of the mechanism for fileOut.
	
I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass.!
!ClassDescription methodsFor: 'enumerating' stamp: ''!
allUnreferencedInstanceVariables
	"Return a list of the instance variables known to the receiver which are not referenced"

	^ self allSlots reject: [:slot | slot isReferenced]! !

!ClassDescription methodsFor: 'fileout' stamp: ''!
definitionPrinter
	"Return a configurated printer associated with the current class definition format."

	^ ClassDefinitionPrinter for: self! !

!ClassDescription methodsFor: 'printing' stamp: ''!
instanceVariablesOn: aStream
	"Write my instance variable names separated by spaces on the argument."
	
	self localSlots
		do: [ :each | aStream nextPutAll: each name asString]
		separatedBy: [ aStream space ].! !

!ClassDescription methodsFor: '*System-Sources' stamp: ''!
logMethodSource: aText forMethod: aCompiledMethod inCategory: category withStamp: changeStamp
	aCompiledMethod
		putSource: aText
		class: self
		category: category
		withStamp: changeStamp 
		priorMethod: (self
					compiledMethodAt: aCompiledMethod selector
					ifAbsent: [])! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
noteCompilationOfMethod: aCompiledMethod meta: isMeta
	self noteCompilationOf: aCompiledMethod selector meta: isMeta! !

!ClassDescription methodsFor: 'organization' stamp: ''!
reorganize
	"During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization.  See the transfer of control where ReadWriteStream fileIn calls scanFrom:"

	^self organization! !

!ClassDescription methodsFor: 'copying' stamp: ''!
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: '*CodeExport' stamp: ''!
fileOutCategory: catName 

	self organization fileOutCategory: catName! !

!ClassDescription methodsFor: '*Reflectivity' stamp: ''!
sendNodes
	^self methods flatCollect: [ :each | each sendNodes ]! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
extensionSelectors
	^ self extendingPackages flatCollect: [ :each | each extensionSelectorsForClass: self ]! !

!ClassDescription methodsFor: '*Tool-Finder' stamp: ''!
allSelectorsToTestInMethodFinderWithArity: anInteger 
	"Returns all the selectors with a certain arity which are approved by the class so which can be tested in the Method Finder."
	
	^  self allSelectorsToTestInMethodFinder select: [ :selector | selector numArgs = anInteger ]! !

!ClassDescription methodsFor: 'slots' stamp: ''!
slotNamed: aName ifFound: foundBlock ifNone: exceptionBlock
	^self classLayout resolveSlot: aName asSymbol ifFound: foundBlock ifNone: exceptionBlock! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
removeProtocol: aString 
	"Remove each of the messages categorized under aString in the method 
	dictionary of the receiver. Then remove the category aString."
	| categoryName |
	categoryName := aString asSymbol.
	(self organization listAtCategoryNamed: categoryName) do:
		[:sel | self removeSelector: sel].
	self organization removeCategory: categoryName! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
wantsChangeSetLogging
	"Answer whether code submitted for the receiver should be remembered by the changeSet mechanism."

	^ true! !

!ClassDescription methodsFor: 'copying' stamp: ''!
copyAll: selArray from: class classified: cat 
	"Install all the methods found in the method dictionary of the second 
	argument, class, as the receiver's methods. Classify the messages under 
	the third argument, cat."

	selArray do: [:s |
		(class includesLocalSelector: s) ifTrue: [
			self copy: s
				from: class
				classified: cat ] ]! !

!ClassDescription methodsFor: 'pool variable' stamp: ''!
hasSharedPools
	"Only a class may have shared pools"
	^ false! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
compileSilently: code classified: category notifying: requestor
	"Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed."

	^ SystemAnnouncer uniqueInstance 
		suspendAllWhile: [self compile: code classified: category notifying: requestor].! !

!ClassDescription methodsFor: 'testing' stamp: ''!
isDeprecated
	^ self package isDeprecated! !

!ClassDescription methodsFor: 'slots' stamp: ''!
definesSlotNamed: aString
	"Return true whether the receiver defines an instance variable named aString."
	
	^ self slotNames includes: aString! !

!ClassDescription methodsFor: 'queries' stamp: ''!
whichSelectorsRead: instVarName
	"Answer the selectors whose methods read the argument, instVarName, as a named instance variable."

	^ self
		slotNamed: instVarName
		ifFound: [ :slot | self selectors select: [ :sel | slot isReadIn: self >> sel ] ]
		ifNone: [ #() ]! !

!ClassDescription methodsFor: 'initialization' stamp: ''!
superclass: aSuperclass withLayoutType: layoutType slots: slotArray
	| superLayout newScope newLayout |
	superLayout := aSuperclass
						ifNil: [ EmptyLayout instance ]
						ifNotNil: [ aSuperclass classLayout ].
	newScope := superLayout slotScope extend: slotArray.
	newLayout := layoutType extending: superLayout scope: newScope host: self.
	newLayout checkSanity.
	self
		superclass: aSuperclass
		layout: newLayout! !

!ClassDescription methodsFor: 'slots' stamp: ''!
hasSlot: aSlot
	"Return true whether the receivers hierarchy defines an instance variable named aString."
	
	^ self allSlots identityIncludes: aSlot! !

!ClassDescription methodsFor: 'accessing - comment' stamp: ''!
comment: aStringOrText
	"Set the receiver's comment to be the argument, aStringOrText."

	self instanceSide classComment: aStringOrText.! !

!ClassDescription methodsFor: 'file in/out' stamp: ''!
definition
	"Answer a String that defines the receiver."
	self
		deprecated: #definition
		transformWith: '`@receiver definition' -> '`@receiver definitionString'.
	^ self definitionString! !

!ClassDescription methodsFor: 'fileout' stamp: ''!
expandedDefinitionStringFor: aPrinter

	^ self subclassResponsibility! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
package
	^ RPackage organizer packageOf: self.! !

!ClassDescription methodsFor: 'private' stamp: ''!
spaceUsed
	^super spaceUsed + (self hasClassSide
		ifTrue: [self classSide spaceUsed] 
		ifFalse: [0])! !

!ClassDescription methodsFor: '*Manifest-Core' stamp: ''!
criticNameOn: aStream
	"This behavior may be folded later by changing the name of this method or using another one."
	
	aStream 
		<< self name 
		<< ' (' 
		<< self category 
		<< ')'! !

!ClassDescription methodsFor: 'file in/out' stamp: ''!
classComment: aString stamp: aStamp
	"Store the comment, aString or Text or RemoteString, associated with the class we are organizing.  Empty string gets stored only if had a non-empty one before."

	| pointer header oldComment oldStamp preamble |
	oldComment := self organization classComment.
	oldStamp := self organization commentStamp.

	aString string = oldComment string ifTrue: [ ^ self ].

	pointer := self organization commentSourcePointer ifNil: [0]. 
		
	
	preamble := String streamContents: [ :file |
		file cr; nextPut: $!!.
		header := String streamContents: [:strm | 
			strm 
				nextPutAll: self name;
				nextPutAll: ' commentStamp: '.
			aStamp storeOn: strm.
			strm nextPutAll: ' prior: '; nextPutAll: pointer printString ].
		file nextChunkPut: header; cr ].

	SourceFiles
		writeSource: aString
		preamble: preamble
		onSuccess: [ :newSourcePointer | 
			self organization 
				commentSourcePointer: newSourcePointer]
		onFail: [ "ignore" ].
	
	SystemAnnouncer uniqueInstance 
		class: self 
		oldComment: oldComment 
		newComment: aString 
		oldStamp: oldStamp 
		newStamp: aStamp! !

!ClassDescription methodsFor: 'fileout' stamp: ''!
expandedDefinitionString
	"Return the string of the class definition, each of my subclass may tell the printer how to printer it. A kind of double dispatch since we have multiple printers and multiple entities to be printed."

	^ self expandedDefinitionStringFor: (self definitionPrinter for: self)! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
compile: code classified: heading 
	"Compile the argument, code, as source code in the context of the 
	receiver and install the result in the receiver's method dictionary under 
	the classification indicated by the second argument, heading. nil is to be 
	notified if an error occurs. The argument code is either a string or an 
	object that converts to a string or a PositionableStream on an object that 
	converts to a string."

	^self
		compile: code
		classified: heading
		notifying: nil! !

!ClassDescription methodsFor: 'organization' stamp: ''!
zapOrganization
	"Remove the organization of this class by message categories.
	This is typically done to save space in small systems.  Classes and methods
	created or filed in subsequently will, nonetheless, be organized"

	self organization: nil.
	self isClassSide ifFalse: [self classSide zapOrganization]! !

!ClassDescription methodsFor: 'private' stamp: ''!
errorCategoryName
	self error: 'Category name must be a String'! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
compile: text classified: category notifying: requestor
	| stamp |
	stamp := self acceptsLoggingOfCompilation
		ifTrue: [ Author changeStamp ]
		ifFalse: [ nil ].
	^ self
		compile: text
		classified: category
		withStamp: stamp
		notifying: requestor! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
packages
	"the extending packages of a class are the packages that extend it."
	
	^  self extendingPackages asSet copy add: self package; yourself! !

!ClassDescription methodsFor: 'slots' stamp: ''!
definesSlot: aSlot
	"Return true whether the receiver defines an instance variable named aString"
	
	^ self slots identityIncludes: aSlot! !

!ClassDescription methodsFor: '*CodeExport' stamp: ''!
fileOutChangedMessages: aSet on: aFileStream
	"File a description of the messages of this class that have been 
	changed (i.e., are entered into the argument, aSet) onto aFileStream."

	| org |
	(org := self organization) categories
		do: [ :cat | 
			| sels |
			sels := (org listAtCategoryNamed: cat) select: [ :sel | aSet includes: sel ].
			sels do: [ :sel | self printMethodChunk: sel on: aFileStream ] ]! !

!ClassDescription methodsFor: '*TraitsV2' stamp: ''!
asTraitComposition

	^ TaCompositionElement for: self! !

!ClassDescription methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterPackageFor: aStep
	<stSpotterOrder: 50>
	aStep listProcessor
			title: 'Package';
			allCandidates: [ {self package} ];
			itemName: [ :item | item packageName ];
			itemIcon: #systemIcon;
			filter: StFilterSubstring! !

!ClassDescription methodsFor: 'fileout' stamp: ''!
definitionStringFor: aConfiguredPrinter

	^ self subclassResponsibility! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
isExtended

	^ self extendingPackages isEmpty! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
packageOrganizer
	"Returns the organizer of this class"
	^ RPackage organizer! !

!ClassDescription methodsFor: 'slots' stamp: ''!
slotNames
	^self slots collect: [ :each | each name ]! !

!ClassDescription methodsFor: 'private' stamp: ''!
linesOfCode 
	"An approximate measure of lines of code.
	Includes comments, but excludes blank lines."

	| lines |
	lines := self localMethods inject: 0 into: [ :sum :each | sum + each linesOfCode ].
	^ self isMeta 
		ifTrue: [ lines ]
		ifFalse: [ lines + self classSide linesOfCode ]! !

!ClassDescription methodsFor: 'private' stamp: ''!
numberOfMethods
	"count all methods that are local (not comming from a trait)"
	| num |
	num := self localMethods size.
	^ self isMeta  
		ifTrue: [ num ]
		ifFalse: [ num + self classSide numberOfMethods ]! !

!ClassDescription methodsFor: 'accessing - deprecated parallel hierarchy' stamp: ''!
baseClass
	"This method is deprecated so consider to migrate."
	self deprecated:  'Please use #instanceSide instead' transformWith:  '`@receiver baseClass' 
						-> '`@receiver instanceSide'.
	^ self instanceSide! !

!ClassDescription methodsFor: '*CodeExport' stamp: ''!
fileOutMethod: selector
	"Write source code of a single method on a file.  Make up a name for the file."
	
	| internalStream |
	internalStream := (String new: 1000) writeStream.
	self fileOutMethod: selector on: internalStream.
	CodeExporter writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '..')) isSt: true.! !

!ClassDescription methodsFor: '*TraitsV2' stamp: ''!
addToComposition: aTrait
	self setTraitComposition: self traitComposition + aTrait! !

!ClassDescription methodsFor: 'file in/out' stamp: ''!
commentStamp: changeStamp
	"update the changeStamp"
	self comment: self organization comment stamp: changeStamp! !

!ClassDescription methodsFor: 'authors' stamp: ''!
authors
	"Returns a bag representing the author frequency based on the latest version of the methods of the receiver."

	^(self methods, self classSide methods) collect: [ :each | each author ] as: Bag! !

!ClassDescription methodsFor: 'accessing - tags' stamp: ''!
tagsForMethods
	"Any method could be tagged with multiple symbols for user purpose. 
	And class contains all method tags which used or not used yet by methods.
	For now we could only implemented it on top of Protocol. 
	It supposed to not include any method tags inherited from Traits 
	which is opposite to current Protocol implementation.
	And extension protocol is not treated as tag"
	| allProtocols |
	allProtocols := self organization protocols reject: [ :each | each name = Protocol unclassified | each isExtensionProtocol ].
		
	^ allProtocols select: [ :each | self isLocalMethodsProtocol: each ] thenCollect: #name! !

!ClassDescription methodsFor: '*Renraku' stamp: ''!
reBanName

	^ self name, ' (Class)'! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
instVarNames
	"Answer an Array of the receiver's instance variable names."

	^self slots collect: [ :each | each name ]! !

!ClassDescription methodsFor: 'pool variable' stamp: ''!
sharedPools
	^ OrderedCollection new! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
addSelectorSilently: selector withMethod: compiledMethod
	super addSelectorSilently: selector withMethod: compiledMethod.
	self instanceSide noteAddedSelector: selector meta: self isMeta.! !

!ClassDescription methodsFor: 'accessing - tags' stamp: ''!
methodsTaggedWith: aSymbol
	"Any method could be tagged with multiple symbols for user purpose. 
	And class contains all method tags which used or not used yet by methods.
	This method select all methods marked by given tag.
	Tags are not inherited from traits. So we only select local methods"
	
	^self localMethods select: [ :each | each isTaggedWith: aSymbol ]! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
packageFromOrganizer: anOrganizer
	"returns the package that defines this class"
	^ anOrganizer packageOf: self.! !

!ClassDescription methodsFor: '*TraitsV2' stamp: ''!
baseComposition
	^ TaEmptyComposition new! !

!ClassDescription methodsFor: '*Tool-Finder' stamp: ''!
allSelectorsToTestInMethodFinder
	"Returns all the selectors that the class approved, so which can be tested by the MethodFinder without problem. This set is the set of selectors that the class approved plus all the selectors approved by its superclass unless if they are forbidden by the class."
	
	^ (self approvedSelectorsForMethodFinder union: self superclass allSelectorsToTestInMethodFinder) 
			difference: self forbiddenSelectorsForMethodFinder asSet.! !

!ClassDescription methodsFor: '*Fuel-Tests-Core' stamp: ''!
duringTestCompileSilently: code classified: aCategory
	^ self 
		duringTestCompileSilently: code
		storeSource: true
		classified: aCategory! !

!ClassDescription methodsFor: 'printing' stamp: ''!
sharedPoolStringOn: aStream
	"Write my shared pools separated by dots on argument, aStream."

	self sharedPools do:  [ :p | aStream nextPutAll: p name ] separatedBy: [ aStream nextPutAll: ' . ' ]! !

!ClassDescription methodsFor: 'accessing - comment' stamp: ''!
hasComment
	"Return whether this class truly has a comment other than the default"
	^self instanceSide organization hasComment! !

!ClassDescription methodsFor: 'accessing - comment' stamp: ''!
classCommentBlank
	"Classes can override this method to show another template."
	"There are two use cases: a class hierarchy can give information about what kind of comment is 
	useful (see 'PackageManifest class'). If in addition, '#hasComment ^true' can be implemented in 
	cases where the class does not need a dedicated comment. See 'TestCase class'for an example"

	| stream |
	stream := (String new: 100) writeStream.
	stream nextPutAll: 'Please comment me using the following template inspired by Class Responsibility Collaborator (CRC) design:

For the Class part:  State a one line summary. For example, "I represent a paragraph of text".

For the Responsibility part: Three sentences about my main responsibilities - what I do, what I know.

For the Collaborators Part: State my main collaborators and one line about how I interact with them. 

Public API and Key Messages

- message one   
- message two 
- (for bonus points) how to create instances.

   One simple example is simply gorgeous.
 
Internal Representation and Key Implementation Points.'.
			
	(self instanceVariables isNotEmpty)
		 ifTrue: [stream cr; cr; nextPutAll: '    Instance Variables'.  ].
		
	self instVarNames sorted do: [:each |
		stream
			cr; tab; nextPutAll: each;
			nextPut: $:;
			tab; tab;
			nextPutAll: '<Object>'].
	stream cr.
	stream cr; cr; nextPutAll: '    Implementation Points'.
	^stream contents! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
hasInstVarNamed: aString
	"Return true whether the receiver defines an instance variable named aString."
	
	^ self instVarNames includes: aString! !

!ClassDescription methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self methodDict includesKey: aSelector! !

!ClassDescription methodsFor: 'slots' stamp: ''!
localSlots

	^ self slots select: [ :aSlot | aSlot isDefinedByOwningClass ]! !

!ClassDescription methodsFor: 'queries' stamp: ''!
whichSelectorsAccess: instVarName
	"Answer the selectors whose methods access the argument, instVarName, as a named instance variable."

	^ self
		slotNamed: instVarName
		ifFound: [ :slot | self selectors select: [ :sel | slot isAccessedIn: self>>sel ] ]
		ifNone: [ #() ]! !

!ClassDescription methodsFor: '*CodeExport' stamp: ''!
fileOutCategory: aSymbol on: aFileStream
	"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 on: aFileStream ].
	^ self! !

!ClassDescription methodsFor: '*System-Support' stamp: ''!
allCallsOnIn: aSystemNavigation
	"Answer a SortedCollection of all the methods that refer to me by name or as part of an association in a global dict."

	^ (aSystemNavigation allReferencesTo: (self environment associationAt: self instanceSide name))
  	        , (aSystemNavigation allCallsOn: self instanceSide name)! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
addInstVarNamed: aString 
	"Add the argument, aString, as one of the receiver's instance variables."

	self subclassResponsibility! !

!ClassDescription methodsFor: 'pool variable' stamp: ''!
includesSharedPoolNamed:  aSharedPoolString 
	"Answer whether the receiver uses the shared pool named aSharedPoolString"
	
	^ self sharedPools anySatisfy: [:each | each name = aSharedPoolString]! !

!ClassDescription methodsFor: 'accessing - class hierarchy' stamp: ''!
classesThatImplementAllOf: selectorSet
	"Return an array of any classes that implement all the messages in selectorSet."

	| found remaining |
	found := OrderedCollection new.
	selectorSet do:
		[:sel | (self includesSelector: sel) ifTrue: [found add: sel]].
	found isEmpty
		ifTrue: [^ self subclasses inject: Array new
						into: [:subsThatDo :sub |
							subsThatDo , (sub classesThatImplementAllOf: selectorSet)]]
		ifFalse: [remaining := selectorSet copyWithoutAll: found.
				remaining isEmpty ifTrue: [^ Array with: self].
				^ self subclasses inject: Array new
						into: [:subsThatDo :sub |
							subsThatDo , (sub classesThatImplementAllOf: remaining)]]! !

!ClassDescription methodsFor: 'organization updating' stamp: ''!
notifyOfRecategorizedSelector: selector from: oldCategory to: newCategory
	"If compiled method is not there, it meens it has been removed, not recategorized... so I skip 
	 the method recategorized announce"
	(self compiledMethodAt: selector ifAbsent: [ nil ]) 
		ifNotNil: [ :method | 
			SystemAnnouncer uniqueInstance 
				methodRecategorized: method
				oldProtocol: oldCategory ].! !

!ClassDescription methodsFor: 'copying' stamp: ''!
copy: sel from: class 
	"Install the method associated with the first argument, sel, a message 
	selector, found in the method dictionary of the second argument, class, 
	as one of the receiver's methods. Classify the message under -As yet not 
	classified-."

	self copy: sel
		from: class
		classified: nil! !

!ClassDescription methodsFor: 'accessing - comment' stamp: ''!
comment: aStringOrText stamp: aStamp
	"Set the receiver's comment to be the argument, aStringOrText."

	self instanceSide classComment: aStringOrText stamp: aStamp.! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
extendingPackages
	"the extending packages of a class are the packages that extend it."
	^ RPackage organizer extendingPackagesOf: self! !

!ClassDescription methodsFor: 'slots' stamp: ''!
slotsNeedFullDefinition
	"return true if we define something else than InstanceVariableSlots"
	^self slots anySatisfy: [ :each | each needsFullDefinition ]! !

!ClassDescription methodsFor: '*CodeExport' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	"File out methods for this category."
	
	| selectors |
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.

	selectors do: [:sel | self printMethodChunk: sel on: aFileStream ].
	^ self! !

!ClassDescription methodsFor: 'private' stamp: ''!
newInstanceFrom: oldInstance variable: variable size: instSize map: map
	"Create a new instance of the receiver based on the given old instance.
	The supplied map contains a mapping of the old instVar names into
	the receiver's instVars"
	| new |
	variable
		ifTrue: [new := self basicNew: oldInstance basicSize]
		ifFalse: [new := self basicNew].
	1 to: instSize do: 
		[:offset |  (map at: offset) > 0 ifTrue:
			[new instVarAt: offset
					put: (oldInstance instVarAt: (map at: offset))]].
	variable 
		ifTrue: [1 to: oldInstance basicSize do: 
					[:offset |
					new basicAt: offset put: (oldInstance basicAt: offset)]].
	^new! !

!ClassDescription methodsFor: 'accessing - tags' stamp: ''!
tagWith: aSymbol
	| package packageTag |
	"Any class or trait could be tagged by multiple symbols for user purpose.
	For now we could only model single tag with RPackageTag"
	
	package := self package.
	packageTag := package addClassTag: aSymbol.
	packageTag addClass: self! !

!ClassDescription methodsFor: 'copying' stamp: ''!
copy: sel from: class classified: cat 
	"Install the method associated with the first arugment, sel, a message 
	selector, found in the method dictionary of the second argument, class, 
	as one of the receiver's methods. Classify the message under the third 
	argument, cat."

	| code category |
	"Useful when modifying an existing class"
	code := class sourceCodeAt: sel.
	code ifNotNil: 
			[cat
				ifNil: [category := class organization categoryOfElement: sel]
				ifNotNil: [category := cat].
			(self includesLocalSelector: sel)
				ifTrue: [code asString = (self sourceCodeAt: sel) asString 
							ifFalse: [self error: self name 
										, ' ' 
										, sel 
										, ' will be redefined if you proceed.']].
			self compile: code classified: category]! !

!ClassDescription methodsFor: 'pool variable' stamp: ''!
sharedPoolsString
	"Answer a string of my shared pool names separated by spaces."

	^String streamContents: [ :stream |
		self sharedPools 
			do: [ :each |
				stream nextPutAll: (self environment 
					keyAtIdentityValue: each 
					ifAbsent: [ 
						each isObsolete
							ifTrue: [ each name ] "obsolete classes should be visible"
							ifFalse: [ 'private' ] ]) ] "if class is from different environment, mark it as private"
			separatedBy: [ stream space ] ]! !

!ClassDescription methodsFor: 'copying' stamp: ''!
copyAllCategoriesFrom: aClass 
	"Specify that the categories of messages for the receiver include all of 
	those found in the class, aClass. Install each of the messages found in 
	these categories into the method dictionary of the receiver, classified 
	under the appropriate categories."

	aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! !

!ClassDescription methodsFor: '*Renraku' stamp: ''!
suitableRulesFrom: aReRuleManager 
	^ aReRuleManager classRules! !

!ClassDescription methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream nextPutAll: self name! !

!ClassDescription methodsFor: 'pool variable' stamp: ''!
sharedPoolOfVarNamed: aString
	"Only classes may have shared pools"
	
	^ nil! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
definedSelectors
	^ self package definedSelectorsForClass: self! !

!ClassDescription methodsFor: '*Fuel-Core' stamp: ''!
instanceVariableNamesDo: anUnaryBlock
	"This is part of the interface between the compiler and a class's instance or field names.
	 The class should enumerate anUnaryBlock with the instance variable name strings.  The order is important. Names evaluated later will override the
	 same names occurring earlier."

	| superInstSize |
	(superInstSize := self superclass notNil ifTrue: [self superclass instSize] ifFalse: [0]) > 0 ifTrue:
		[self superclass instanceVariableNamesDo: anUnaryBlock].
	1 to: self instSize - superInstSize do:
		[:i| anUnaryBlock value: (self instVarNames at: i)]! !

!ClassDescription methodsFor: '*SUnit-Core' stamp: ''!
isTestCase
	^false! !

!ClassDescription methodsFor: '*TraitsV2' stamp: ''!
traitComposition
	^ TaEmptyComposition new! !

!ClassDescription methodsFor: '*Renraku' stamp: ''!
banChecksForValidation
"returns ban levels that have to be chacked before validation"

	^ { self }! !

!ClassDescription methodsFor: 'printing' stamp: ''!
classVariablesOn: aStream
	"Write my class variable names separated by spaces on the argument."
	
	self classVarNames 
		do: [ :each | aStream nextPutAll: each ]
		separatedBy: [ aStream space ]! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
classThatDefinesInstVarNamed: instVarName
	^self 
		slotNamed: instVarName
		 ifFound: [ :slot | slot definingClass  ]
		 ifNone: nil! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
reformatAll
	"Reformat all methods in this class"
	self methods do: [:method | method reformat]! !

!ClassDescription methodsFor: '*Fuel-Tests-Core' stamp: ''!
duringTestCompileSilently: code storeSource: storeSource classified: aCategory
	^ FLPlatform current 
		useAuthor: 'TestsAuthor'
		during: [ [
			self 
				compile: code
				classified: (aCategory ifNil: [ '' ])
				withStamp: nil 
				notifying: nil 
				logSource: storeSource ] fuelValueWithoutNotifications ]! !

!ClassDescription methodsFor: '*ClassParser' stamp: ''!
classDefinitionParserClass
	"Based on the currently selected syntax and the constraints imposed by the class (e.e.g complex slots) return the correct class parser."
	
	^ (ClassDefinitionPrinter for: self) classDefinitionParserClass! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource
 
	| method selector |

	method := self compiler
		source: text;
		requestor: requestor;
		failBlock:  [ ^nil ];
		compile.
	
	selector := method selector.
	logSource ifTrue: [
		self 
			logMethodSource: (requestor ifNotNil: [ :r | r text ] ifNil: [ text ]) "the requestor text might have been changed by the compiler and may be different thant text argument"
			forMethod: method
			inCategory: category 
			withStamp: changeStamp].
		
	self 
		addAndClassifySelector: selector 
		withMethod: method 
		inProtocol: category.
			
	self instanceSide 
		noteCompilationOfMethod: method 
		meta: self isClassSide.

	^ selector! !

!ClassDescription methodsFor: 'accessing' stamp: ''!
slots
	^self classLayout visibleSlots! !

!ClassDescription methodsFor: 'organization' stamp: ''!
methodsInProtocol: aString

	^ (self organization listAtCategoryNamed: aString) 
			collect: [ :each | (self compiledMethodAt: each) ]! !

!ClassDescription methodsFor: 'slots' stamp: ''!
needsSlotClassDefinition
    "return true if we define something else than InstanceVariableSlots or normal class variables"

    ^ self slotsNeedFullDefinition or: [ self class slotsNeedFullDefinition ]! !

!ClassDescription methodsFor: 'private' stamp: ''!
newInstanceFrom: oldInstance variable: variable size: instSize
	"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  value |
	variable
		ifTrue: [ new := self basicNew: oldInstance basicSize ]
		ifFalse: [ new := self basicNew ].
		
	"Slot migration happens there"	
	self allSlots
		do: [ :newSlot | 
			oldInstance class
				slotNamed: newSlot name
				ifFound: [ :oldSlot | 
					newSlot wantsInitialization ifTrue: [ self initializeSlots: new ].
					value := oldSlot read: oldInstance.
					newSlot write: value to: new ] ].
	variable
		ifTrue: [ 1 to: oldInstance basicSize do: [ :offset | new basicAt: offset put: (oldInstance basicAt: offset) ] ].
	^ new! !

!ClassDescription methodsFor: 'testing' stamp: ''!
isTaggedWith: aSymbol
	^self tags includes: aSymbol! !

!ClassDescription methodsFor: '*Reflectivity' stamp: ''!
variableReadNodes
	^self methods flatCollect: [ :each | each variableReadNodes ]! !

!ClassDescription methodsFor: '*Roassal3-UML' stamp: ''!
shouldUseUMLClassTab
	^ true! !

!ClassDescription methodsFor: 'accessing - tags' stamp: ''!
addMethodTag: aSymbol
	"Any method could be tagged with multiple symbols for user purpose.
	In class we could define what tags could be used for methods"
	self organization addCategory: aSymbol! !

!ClassDescription methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	aProtocol methodSelectors ifEmpty: [ ^ true ].

	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ClassDescription methodsFor: 'printing' stamp: ''!
classVariablesString
	"Answer a string of my class variable names separated by spaces."

	^ String streamContents: [ :stream | self classVariablesOn: stream ]! !

!ClassDescription methodsFor: 'slots' stamp: ''!
hasSlotNamed: aString
	"Return true whether the receiver defines an instance variable named aString.
	this includes non-visible slots"
	
	^ self classLayout hasSlotNamed: aString! !

!ClassDescription methodsFor: 'accessing - parallel hierarchy' stamp: ''!
hasClassSide
	^self subclassResponsibility.! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category
	| priorMethodOrNil priorOriginOrNil oldProtocol newProtocol |

	priorMethodOrNil := self 
		compiledMethodAt: selector 
		ifAbsent: [ nil ].
	priorMethodOrNil ifNotNil: [ priorOriginOrNil := priorMethodOrNil origin ].
	
	self addSelectorSilently: selector withMethod: compiledMethod.
	
	oldProtocol := self organization categoryOfElement: selector.
	SystemAnnouncer uniqueInstance suspendAllWhile: [ 
		self organization 
			classify: selector 
			under: (category = Protocol unclassified 
				ifTrue: [ oldProtocol ]
				ifFalse: [ category ]) ].
	newProtocol := self organization categoryOfElement: selector.
	
	self isAnonymous ifTrue: [ ^ self ].
	
	(priorMethodOrNil isNil or: [ priorOriginOrNil ~= compiledMethod origin ])
		ifTrue: [ SystemAnnouncer uniqueInstance methodAdded: compiledMethod ]
		ifFalse: [ 
			"If protocol changed and someone is from different package, I need to throw a method recategorized"
			self
				notifyRepackage: selector
				method: compiledMethod
				oldProtocol: oldProtocol
				newProtocol: newProtocol.	
					
			SystemAnnouncer uniqueInstance
				methodChangedFrom: priorMethodOrNil
				to: compiledMethod
				oldProtocol: oldProtocol ]! !

!ClassDescription methodsFor: 'file in/out' stamp: ''!
classComment: aString
	"Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing.  Empty string gets stored only if had a non-empty one before."
	^ self classComment: aString stamp: '<historical>'! !

!ClassDescription methodsFor: '*Reflectivity' stamp: ''!
instanceVariableReadNodes
	^self methods flatCollect: [ :each | each instanceVariableReadNodes ]! !

!ClassDescription methodsFor: 'printing' stamp: ''!
sharedPoolString
	"Answer a string of my shared pools separated by spaces."

	^String streamContents: [ :stream | 
		self sharedPoolStringOn: stream ]! !

!ClassDescription methodsFor: 'obsolete subclasses' stamp: ''!
allLocalCallsOn: aSymbol
	"Answer all the methods that call on aSymbol, anywhere in my class hierarchy."

	^ self instanceSide withAllSuperAndSubclasses flatCollect: [ :class | 
			(class thoroughWhichMethodsReferTo: aSymbol), (class class thoroughWhichMethodsReferTo: aSymbol)]! !

!ClassDescription methodsFor: 'private' stamp: ''!
notifyRepackage: selector method: compiledMethod oldProtocol: oldProtocol newProtocol: newProtocol
	| oldPackage newPackage |
	
	(newProtocol = oldProtocol)
		ifTrue: [ ^ self ].
		
	"This indirection is because we need to abstract RPackage from the kernel"
	self class environment at: #RPackage ifPresent: [ :rPackageClass | 
			newPackage := rPackageClass organizer 
				packageForProtocol: newProtocol 
				inClass: self.
			oldPackage := rPackageClass organizer 
				packageForProtocol: oldProtocol 
				inClass: self.
			
			"Announce recategorization"
			newPackage = oldPackage
				ifFalse: [ 
					SystemAnnouncer uniqueInstance 
						methodRepackaged: compiledMethod 
						from: oldPackage 
						to: newPackage ] ].	
	
	SystemAnnouncer uniqueInstance methodRecategorized: compiledMethod oldProtocol: oldProtocol! !

!ClassDescription methodsFor: 'copying' stamp: ''!
copyCategory: cat from: class 
	"Specify that one of the categories of messages for the receiver is cat, as 
	found in the class, class. Copy each message found in this category."

	self copyCategory: cat
		from: class
		classified: cat! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
removeSelector: selector 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."
	
	| priorMethod priorProtocol origin | 
	priorMethod := self compiledMethodAt: selector ifAbsent: [^ nil].
	origin := priorMethod origin.
	priorProtocol := self whichCategoryIncludesSelector: selector.
	self organization removeElement: selector.
	
	super removeSelector: selector.
		
	SystemAnnouncer uniqueInstance methodRemoved: priorMethod protocol: priorProtocol origin: origin! !

!ClassDescription methodsFor: '*Fuel-Tests-Core' stamp: ''!
duringTestCompileSilently: code
	^ self 
		duringTestCompileSilently: code 
		storeSource: true! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
compileSilently: code 
	"Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed."

	^ self compileSilently: code classified: 'not defined category' notifying: nil.! !

!ClassDescription methodsFor: '*Renraku' stamp: ''!
critiques
	^ ReCriticEngine critiquesOf: self! !

!ClassDescription methodsFor: '*Tool-Finder' stamp: ''!
forbiddenSelectorsForMethodFinder
	"The list of selector forbidden by the class. A forbidden selector will not be tested by the Method Finder. So, a forbiden selector could be a method which modifies the environment, a global variable, etc."

	^ #()! !

!ClassDescription methodsFor: '*Reflectivity' stamp: ''!
variableWriteNodes
	^self methods flatCollect: [ :each | each variableWriteNodes ]! !

!ClassDescription methodsFor: '*CodeExport' stamp: ''!
fileOutOrganizationOn: aFileStream
	"File a description of the receiver's organization on aFileStream."

	aFileStream cr; nextPut: $!!.
	aFileStream nextChunkPut: self name, ' reorganize'; cr.
	aFileStream nextChunkPut: self organization stringForFileOut ; cr! !

!ClassDescription methodsFor: '*Reflectivity' stamp: ''!
variableNodes
	^self methods flatCollect: [ :each | each variableNodes ]! !

!ClassDescription methodsFor: '*Roassal3-UML' stamp: ''!
buildUMLCanvasWithBrowserTool: tool
	^ nil! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
forceNewFrom: anArray
    "Create a new instance of the class and fill
    its instance variables up with the array."
    | object max |

    object := self new.
    max := self instSize.
    anArray doWithIndex: [:each :index |
        index > max ifFalse:
            [object instVarAt: index put: each]].
    ^ object! !

!ClassDescription methodsFor: 'accessing - parallel hierarchy' stamp: ''!
isClassSide
	"Return true whether the receiver is a metaclass (in a couple class/metaclass sense)."
	"Point isClassSide >>> false"
	"Point class isClassSide >>> true"
	
	^self == self classSide! !

!ClassDescription methodsFor: 'printing' stamp: ''!
sharedPoolsOn: aStream
	"Answer a string of my shared pool names separated by spaces."

	self sharedPools 
		do: [ :each |
				aStream nextPutAll: (self environment 
					keyAtIdentityValue: each 
					ifAbsent: [ 
						each isObsolete
							ifTrue: [ each name ] "obsolete classes should be visible"
							ifFalse: [ 'private' ] ]) ] "if class is from different environment, mark it as private"
			separatedBy: [ aStream space ]! !

!ClassDescription methodsFor: 'slots' stamp: ''!
slotNamed: aName
	^self classLayout resolveSlot: aName asSymbol! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	| priorMethodOrNil oldProtocol |
	priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil].
	oldProtocol := priorMethodOrNil ifNotNil: [ priorMethodOrNil protocol ].
	self addSelectorSilently: selector withMethod: compiledMethod.
	priorMethodOrNil 
		ifNil: [SystemAnnouncer uniqueInstance methodAdded: compiledMethod ]
		ifNotNil: [SystemAnnouncer uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod oldProtocol: oldProtocol ].! !

!ClassDescription methodsFor: 'accessing - parallel hierarchy' stamp: ''!
classSide
	"Return the metaclass of the couple class/metaclass. Useful to avoid explicit test."
	"Point classSide >>> Point class"
	"Point class classSide >>> Point class"
	
	^ self subclassResponsibility! !

!ClassDescription methodsFor: 'pool variable' stamp: ''!
allSharedPools
	"Answer an ordered collection of the shared pools the receiver shares, including those defined  in the superclasses of the receiver."
	
	^ OrderedCollection new! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
allInstVarNamesEverywhere
	"Answer the set of inst var names used by the receiver, all superclasses, and all subclasses"

	^ self withAllSuperAndSubclasses flatCollectAsSet: [ :cls | cls instVarNames ]! !

!ClassDescription methodsFor: 'pool variable' stamp: ''!
usesPoolVarNamed: aString
	"Only classes may use a pool variable named: aString"
	
	^ false! !

!ClassDescription methodsFor: '*CodeExport' stamp: ''!
selectorsToFileOutCategory: aSymbol
	^ self organization listAtCategoryNamed: aSymbol! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
allProtocolsUpTo: mostGenericClass
	"Answer a list of all the method protocols of the receiver and all its superclasses, up through mostGenericClass"

	| otherClassCategories thisClassCategories lowercaseSortBlock  |
		
	otherClassCategories := OrderedCollection new.
	lowercaseSortBlock  := [ :a :b | a asLowercase <= b asLowercase ].
	
	(self allSuperclassesIncluding: mostGenericClass) do: [ :aClass | 
		 otherClassCategories addAll: aClass organization categories ].
	otherClassCategories remove: 'no messages' ifAbsent: [  ].
	thisClassCategories := self organization categories sorted: lowercaseSortBlock.
													
	^ thisClassCategories , ((otherClassCategories asSet removeAllSuchThat: [ :each |
								thisClassCategories includes: each ]) sorted: lowercaseSortBlock)! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
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: 'instance variables' stamp: ''!
removeInstVarNamed: aString 
	"Remove the argument, aString, as one of the receiver's instance variables."

	^self removeSlot: (self slotNamed: aString)! !

!ClassDescription methodsFor: 'organization' stamp: ''!
basicOrganization
	^ organization! !

!ClassDescription methodsFor: 'pool variable' stamp: ''!
usesLocalPoolVarNamed: aString
	^false.! !

!ClassDescription methodsFor: 'organization' stamp: ''!
organization: aClassOrg
	"Install an instance of ClassOrganizer that represents the organization of the messages of the receiver."

	aClassOrg ifNotNil: [aClassOrg setSubject: self].
	self basicOrganization: aClassOrg.! !

!ClassDescription methodsFor: 'copying' stamp: ''!
copyAll: selArray from: class 
	"Install all the methods found in the method dictionary of the second 
	argument, class, as the receiver's methods. Classify the messages under 
	-As yet not classified-."

	self copyAll: selArray
		from: class
		classified: nil! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
allSelectorsInProtocol: aName 
	"Answer a list of all the methods of the receiver and all its 
	superclasses that are in the protocol named aName"
	
	^self withAllSuperclasses
		flatCollectAsSet: [ :class | class organization listAtCategoryNamed: aName ]! !

!ClassDescription methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects
	^ false! !

!ClassDescription methodsFor: '*DrTests' stamp: ''!
drTestsBrowse

	Smalltalk tools browser openOnClass: self! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
removeSlot: aSlot

	^self subclassResponsibility! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
uncategorizedSelectors
	^ self selectorsInProtocol: Protocol unclassified! !

!ClassDescription methodsFor: 'printing' stamp: ''!
instanceVariablesString
	"Answer a string of my instance variable names separated by spaces."

	^ String streamContents: [ :stream | self instanceVariablesOn: stream ]! !

!ClassDescription methodsFor: '*Tool-Finder' stamp: ''!
approvedSelectorsForMethodFinder
	"The list of the selectors that the class approved. It's empty by default.
    An approved selector is a selector where the message send to the class could be
    tested by the Method Finder without problem. For instance, it does not modify 
    the environment and it does not touch to a globalvariable ."

	^ #(isNil)! !

!ClassDescription methodsFor: 'accessing - tags' stamp: ''!
tags
	| packageTag |
	"Any class or trait could be tagged by multiple symbols for user purpose.
	For now we only define API to manage them on top of RPackageTag"
	packageTag := self package classTagForClass: self.
	packageTag ifNil: [ ^#() ].
	packageTag isRoot ifTrue: [ ^#() ].
	
	^{packageTag name}! !

!ClassDescription methodsFor: 'organization' stamp: ''!
addCategory: newName before: aCategory

	^ self organization addCategory: newName before: aCategory! !

!ClassDescription methodsFor: 'accessing - deprecated parallel hierarchy' stamp: ''!
isMeta
	^self isClassSide! !

!ClassDescription methodsFor: '*CodeExport' stamp: ''!
fileOutOn: aFileStream
	"File a description of the receiver on aFileStream."

	aFileStream nextChunkPut: self definitionString.
	self organization putCommentOnFile: aFileStream forClass: self.
	self organization categories 
		do: [ :heading | self fileOutLocalMethodsInCategory: heading on: aFileStream ]! !

!ClassDescription methodsFor: 'organization' stamp: ''!
basicOrganization: aClassOrg
	organization := aClassOrg! !

!ClassDescription methodsFor: 'printing' stamp: ''!
storeOn: aStream
	"Classes and Metaclasses have global names."

	aStream nextPutAll: self name! !

!ClassDescription methodsFor: '*Manifest-Core' stamp: ''!
manifestBuilderForRuleChecker: aRuleChecker
	"Return the manifestsince the rulechecker is keeping a cache, we ask it back"

	^ aRuleChecker manifestBuilderOfClass: self! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
instVarIndexFor: instVarName ifAbsent: aBlock
	"Answer the index of the named instance variable."

	^self
		slotNamed: instVarName
		ifFound: [ :slot | slot isVirtual ifTrue: aBlock ifFalse: [slot index]]
		ifNone: aBlock! !

!ClassDescription methodsFor: 'accessing - deprecated parallel hierarchy' stamp: ''!
theMetaClass
	"This method is deprecated so consider to migrate."
	self deprecated:  'Please use #classSide instead' transformWith:  '`@receiver theMetaClass' 
						-> '`@receiver classSide'.
	^ self classSide! !

!ClassDescription methodsFor: 'initialization' stamp: ''!
obsolete
	"Make the receiver obsolete."
	self superclass removeSubclass: self.
	super obsolete.! !

!ClassDescription methodsFor: '*CodeExport' stamp: ''!
fileOutMethod: selector on: aStream
	
	(selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.'].
	(self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found'].
	aStream header; timeStamp.
	self printMethodChunk: selector on: aStream.! !

!ClassDescription methodsFor: 'accessing - parallel hierarchy' stamp: ''!
isInstanceSide
	"Return true whether the receiver is a class (in a couple class/metaclass sense)."
	"Point isClassSide >>> false"
	"Point class isClassSide >>> true"
	
	^ self isClassSide not! !

!ClassDescription methodsFor: '*CodeExport' stamp: ''!
printMethodChunk: selector on: outStream
	"Copy the source code for the method associated with selector onto the fileStream."

	| preamble method |
	preamble := self name, ' methodsFor: ', (self organization categoryOfElement: selector) asString printString.
	method := self methodDict
		at: selector
		ifAbsent: [ 
			outStream
				nextPutAll: selector;
				cr.
			outStream
				tab;
				nextPutAll: '** ERROR!!  THIS SCRIPT IS MISSING ** ';
				cr;
				cr.
			outStream nextPutAll: '  '.
			^ outStream ].

	"Print the preamble"
	outStream cr; nextChunkPut: ''.
	outStream nextChunkPut: (String streamContents: [ :strm | 
		strm nextPutAll: preamble.
		method stamp ifNotEmpty: [ :stamp | 
			strm
				nextPutAll: ' stamp: ';
				print: stamp ] ]).
	outStream cr.

	"Print the source code"
	outStream 
		nextChunkPut: method sourceCode;
		nextChunkPut: ' '; cr.
	
	^ outStream! !

!ClassDescription methodsFor: '*Fuel-Tests-Core' stamp: ''!
duringTestCompileSilently: code storeSource: storeSource
	^ self
		duringTestCompileSilently: code
		storeSource: storeSource
		classified: #Unclassified! !

!ClassDescription methodsFor: '*Reflectivity' stamp: ''!
blockNodes
	^self methods flatCollect: [ :each | each blockNodes ]! !

!ClassDescription methodsFor: 'private' stamp: ''!
instVarMappingFrom: oldClass
	"Return the mapping from instVars of oldClass to new class that is used for converting old instances of oldClass."
	| oldInstVarNames |
	oldInstVarNames := oldClass allInstVarNames.
	^self allInstVarNames 
			collect: [:instVarName | oldInstVarNames indexOf: instVarName].! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
noteAddedSelector: aSelector meta: isMeta
	"A hook allowing some classes to react to adding of certain selectors"! !

!ClassDescription methodsFor: '*TraitsV2' stamp: ''!
selectorsWithExplicitOrigin
	^self traitComposition selectors , self localSelectors! !

!ClassDescription methodsFor: '*Manifest-Core' stamp: ''!
criticClass
	"Return the class of the receiver for the critic browser. This behavior may be folded later by changing the name of this method or using another one."
	
	^ self! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
selectorsInCategory: aName 
	"Answer a list of the selectors of the receiver that are in category named aName"
	
	| aColl |
	aColl := Set withAll: (self organization listAtCategoryNamed: aName).
	^ aColl asArray sort! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
compile: text classified: category withStamp: changeStamp notifying: requestor
	^ self
		compile: text
		classified: category
		withStamp: changeStamp
		notifying: requestor
		logSource: self acceptsLoggingOfCompilation! !

!ClassDescription methodsFor: '*Reflectivity' stamp: ''!
instanceVariableWriteNodes
	^self methods flatCollect: [ :each | each instanceVariableWriteNodes ]! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
instVarIndexFor: instVarName
	"Answer the index of the named instance variable."

	^self instVarIndexFor: instVarName ifAbsent: 0! !

!ClassDescription methodsFor: 'organization' stamp: ''!
whichCategoryIncludesSelector: aSelector 
	"Answer the category of the argument, aSelector, in the organization of 
	the receiver, or answer nil if the receiver does not inlcude this selector."

	^self organization categoryOfElement: aSelector! !

!ClassDescription methodsFor: '*Reflectivity' stamp: ''!
assignmentNodes
	^self methods flatCollect: [ :each | each assignmentNodes ]! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
isExtendedInPackage: aPackage
	"returns true if aPackage defines an extension to this class"
	^ aPackage extendsClass: self.! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
classThatDefinesClassVariable: classVarName
	"Answer the class that defines the given class variable"

	(self classPool includesKey: classVarName asSymbol) ifTrue: [^ self]. 
	^self superclass ifNotNil: [self superclass classThatDefinesClassVariable: classVarName]! !

!ClassDescription methodsFor: 'initialization' stamp: ''!
superclass: aSuperclass layout: aLayout
	layout := aLayout. 
	
	self
		superclass: aSuperclass
		methodDictionary: self emptyMethodDictionary
		format: aLayout format.! !

!ClassDescription methodsFor: '*Renraku' stamp: ''!
banLevelCandidates
"returns code entities which can ban a rule for this entity"

	^ { self } , self package banLevelCandidates! !

!ClassDescription methodsFor: '*CodeExport' stamp: ''!
printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod 
	"Print a method category preamble.  This must have a category name.
	It may have an author/date stamp, and it may have a prior source link.
	If it has a prior source link, it MUST have a stamp, even if it is empty."

"The current design is that changeStamps and prior source links are preserved in the changes file.  All fileOuts include changeStamps.  Condensing sources, however, eliminates all stamps (and links, natch)."

	aFileStream cr; nextPut: $!!.
	aFileStream nextChunkPut: (String streamContents:
		[:strm |
		strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString.
		(changeStamp ~~ nil and:
			[changeStamp size > 0 or: [priorMethod ~~ nil]]) ifTrue:
			[strm nextPutAll: ' stamp: '; print: changeStamp].
		priorMethod ~~ nil ifTrue:
			[strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]).! !

!ClassDescription methodsFor: 'slots' stamp: ''!
slotNamed: aName ifFound: foundBlock
	^self slotNamed: aName ifFound: foundBlock ifNone: [ "do nothing" ]! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
noteCompilationOf: aSelector meta: isMeta
	"A hook allowing some classes to react to recompilation of certain selectors"! !

!ClassDescription methodsFor: '*Manifest-Core' stamp: ''!
mcWorkingCopy
	MCWorkingCopy managersForClass:  self do: [: package | ^ package ]! !

!ClassDescription methodsFor: 'accessing - tags' stamp: ''!
removeMethodTag: aSymbol
	"Any method could be tagged with multiple symbols for user purpose.
	In class we could define what tags could be used for methods.
	Here we could remove what we not need"
	self organization removeCategory: aSymbol! !

!ClassDescription methodsFor: 'slots' stamp: ''!
allSlots
	^self classLayout allVisibleSlots! !

!ClassDescription methodsFor: 'accessing - deprecated parallel hierarchy' stamp: ''!
theNonMetaClass
	"This method is deprecated so consider to migrate."
	self deprecated:  'Please use #instanceSide instead' transformWith:  '`@receiver theNonMetaClass' 
						-> '`@receiver instanceSide'.
	^ self instanceSide! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
compile: code notifying: requestor 
	"Refer to the comment in Behavior|compile:notifying:." 

	^self compile: code
		 classified: Protocol unclassified
		 notifying: requestor! !

!ClassDescription methodsFor: 'fileout' stamp: ''!
definitionString
	"Return the string of the class definition, each of my subclass may tell the printer how to printer it. A kind of double dispatch since we have multiple printers and multiple entities to be printed."

	^ self definitionPrinter definitionString! !

!ClassDescription methodsFor: 'compiling' stamp: ''!
compileSilently: code classified: category
	"Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed."

	^ self compileSilently: code classified: category notifying: nil.! !

!ClassDescription methodsFor: 'file in/out' stamp: ''!
oldDefinition
	
	^ ClassDefinitionPrinter legacy
		for: self;
		definitionString! !

!ClassDescription methodsFor: 'initialization' stamp: ''!
superclass: aClass methodDictionary: mDict format: fmt
	"Basic initialization of the receiver"
	super superclass: aClass methodDictionary: mDict format: fmt.
	self organization: nil.! !

!ClassDescription methodsFor: '*Calypso-SystemQueries' stamp: ''!
tagsForAllMethods
	"I act as #tagsForMethods but I also takes into account methods comming from traits"

	| allProtocols |
	allProtocols := self organization protocols reject: [ :each | each name = Protocol unclassified | each isExtensionProtocol ].

	^ allProtocols
		select: [ :protocol | protocol methodSelectors ifEmpty: [ true ] ifNotEmpty: [ :methods | methods anySatisfy: [ :method | self selectors includes: method ] ] ]
		thenCollect: #name! !

!ClassDescription methodsFor: 'organization' stamp: ''!
organization
	"Answer the instance of ClassOrganizer that represents the organization 
	of the messages of the receiver."

	self basicOrganization
		ifNil: [ self basicOrganization: (self isTrait
						ifTrue: [ ClassOrganization new ]
						ifFalse: [ ClassOrganization forClass: self ]) ].
	^self basicOrganization setSubject: self.	"Making sure that subject is set correctly. It should not be necessary."! !

!ClassDescription methodsFor: 'accessing - tags' stamp: ''!
untagFrom: aSymbol
	| package packageTag |
	"Any class or trait could be tagged by multiple symbols for user purpose.
	For now we could only model single tag with RPackageTag"
	package := self package.
	packageTag := package classTagForClass: self.
	packageTag ifNil: [ ^#() ].
	packageTag isRoot ifTrue: [ ^#() ].
	packageTag name = aSymbol ifFalse: [ ^self ].
	packageTag removeClass: self.
	package addClass: self! !

!ClassDescription methodsFor: 'queries' stamp: ''!
whichSelectorsWrite: instVarName
	"Answer the selectors whose methods write the argument, instVarName, as a named instance variable"

	^ self
		slotNamed: instVarName
		ifFound: [ :slot | self selectors select: [ :sel | slot isWrittenIn: self >> sel ] ]
		ifNone: [ #() ]! !

!ClassDescription methodsFor: 'accessing - method dictionary' stamp: ''!
selectorsInProtocol: aName 
	"Answer a list of the selectors of the receiver that are in category named aName"
	
	| aColl |
	aColl := Set withAll: (self organization listAtCategoryNamed: aName).
	^ aColl asArray sort! !

!ClassDescription methodsFor: 'instance variables' stamp: ''!
addSlot: aSlot

	^self subclassResponsibility! !

!ClassDescription methodsFor: 'accessing - comment' stamp: ''!
comment
    "Answer the receiver's comment. (If missing, supply a template) "
    ^self instanceSide organization classComment ifEmpty: [ self classCommentBlank ]! !

!ClassDescription methodsFor: 'accessing - parallel hierarchy' stamp: ''!
instanceSide
	"Return the class of the couple class/metaclass. Useful to avoid explicit test."
	"Point instanceSide >>> Point"
	"Point class instanceSide >>> Point"
	
	^ self subclassResponsibility! !

!ClassDescription methodsFor: '*RPackage-Core' stamp: ''!
isDefinedInPackage: aPackage
	"returns true if aPackage contains the definitino of this class"
	
	^ aPackage includesClass: self.! !

!ClassDescription methodsFor: '*Renraku' stamp: ''!
ban: aCritique

	ReSystemAnnouncer uniqueInstance
		notifyCritique: aCritique
		of: aCritique sourceAnchor entity
		bannedOn: self.

	(TheManifestBuilder of: self)
		banRule: aCritique rule for: self.! !

!ClassDescriptionTest commentStamp: ''!
This is the unit test for the class ClassDescription. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- there is a chapter in the PharoByExample book (http://pharobyexample.org)
	- the sunit class category!
!ClassDescriptionTest methodsFor: 'tests - slots' stamp: ''!
testSlotNamed
	self assert: (Point slotNamed: #x) name equals: #x! !

!ClassDescriptionTest methodsFor: 'tests - instance variables' stamp: ''!
testwhichSelectorsWrite
	self assert: ((Point whichSelectorsWrite: #x) includes: #setX:setY:).
	self deny: ((Point whichSelectorsWrite: #x) includes: #x).
	
	self assert: ((Point whichSelectorsWrite: #doesNotExist) isEmpty).! !

!ClassDescriptionTest methodsFor: 'tests - slots' stamp: ''!
testDefinesSlotNamed
	self assert: (Point definesSlotNamed: #x).
	self deny: (Point definesSlotNamed: #z).
	
	self assert: (ExampleForTest11 definesSlotNamed: #aSubclassVariable).
	self deny: (ExampleForTest11 definesSlotNamed: #aSuperclassVariable).! !

!ClassDescriptionTest methodsFor: 'tests' stamp: ''!
testWhichCategoryIncludesSelector
	self assert: (ClassDescription whichCategoryIncludesSelector: #comment) equals: #'accessing - comment'.
	self assert: (ClassDescription whichCategoryIncludesSelector: #doesNotExist) equals: nil.! !

!ClassDescriptionTest methodsFor: 'tests - instance variables' stamp: ''!
testwhichSelectorsRead
	self assert: ((Point whichSelectorsRead: #y) includes: #y).
	self deny: ((Point whichSelectorsRead: #y) includes: #x).
	
	self assert: ((Point whichSelectorsRead: #doesNotExist) isEmpty)! !

!ClassDescriptionTest methodsFor: 'tests - slots' stamp: ''!
testHasSlotNamed
	self assert: (Context hasSlotNamed: #sender).
	self assert: (Context hasSlotNamed: #method).! !

!ClassDescriptionTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAllLocalCallsOn
	
	self assert: (( Point allLocalCallsOn: #asPoint )  notEmpty).
	self assert: (( Point allLocalCallsOn: #asPoint )  size) equals: 4.
	self assert: (( Point allLocalCallsOn: #asPoint )  includes: (Point>> #roundDownTo:) ).
	self assert: (( Point allLocalCallsOn: #asPoint )  includes: (Point >> #roundUpTo:) ).
	self assert: (( Point allLocalCallsOn: #asPoint )  includes: (Point >> #roundTo:) ).
	self assert: (( Point allLocalCallsOn: #asPoint )  includes: (Point >> #truncateTo: ) ).! !

!ClassDescriptionTest methodsFor: 'tests - instance variables' stamp: ''!
testwhichSelectorsAccess
	self assert: ((Point whichSelectorsAccess: #y) includes: #y).
	self deny: ((Point whichSelectorsAccess: #y) includes: #x).
	self assert: ((Point whichSelectorsAccess: #x) includes: #setX:setY:).
	
	self assert: ((Point whichSelectorsAccess: #doesNotExist) isEmpty)! !

!ClassDescriptionTest methodsFor: 'tests' stamp: ''!
testOrganization

	| aClassOrganizer |
	aClassOrganizer := ClassDescription organization.
	self assert: (aClassOrganizer isKindOf: ClassOrganization).! !

!ClassDescriptionTest methodsFor: 'tests' stamp: ''!
testNumberOfMethods
	self assert: Point numberOfMethods equals: Point localMethods size + Point class localMethods size! !

!ClassDescriptionTest methodsFor: 'tests - slots' stamp: ''!
testSlotNames
	self assert: Point slotNames equals: #(x y)! !

!ClassDescriptionTest methodsFor: 'tests' stamp: ''!
testAllMethodCategoriesIntegratedThrough
	"If this test fails, it may be because method protocols are sorted in #allMethodCategoriesIntegratedThrough. Take care that if the protocols of the class under test are already sorted, you won't see any problem."
	self assert: ((CompiledMethod selectorsInProtocol: 'testing') includes: #isAbstract).
	CompiledMethod allProtocolsUpTo: Object.
	self assert: ((CompiledMethod selectorsInProtocol: 'testing') includes: #isAbstract)! !

!ClassDescriptionTest methodsFor: 'tests - slots' stamp: ''!
testHasSlot
	self assert: (ExampleForTest11 hasSlot: (ExampleForTest11 slotNamed: #aSuperclassVariable)).
	self deny: (ExampleForTest11 definesSlot: (ExampleForTest11 slotNamed: #aSuperclassVariable)).! !

!ClassDescriptionTest methodsFor: 'tests - slots' stamp: ''!
testSlots
	self assert: Context slots size equals: 6! !

!ClassDescriptionTest methodsFor: 'tests' stamp: ''!
testMethods
	self assert: Object methods equals: Object methodDict values! !

!ClassDescriptionTest methodsFor: 'tests - instance variables' stamp: ''!
testclassThatDefinesInstVarNamed
	self assert: (Point classThatDefinesInstVarNamed: 'x') equals: Point.
	self assert: (Class classThatDefinesInstVarNamed: 'methodDict') equals: Behavior.
	self assert: (Point classThatDefinesInstVarNamed: 'methodDict') equals: nil.! !

!ClassDescriptionTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ ClassDescription! !

!ClassDescriptionTest methodsFor: 'tests - slots' stamp: ''!
testAllSlots
	self assert: Context allSlots size equals: 6! !

!ClassDiffBuilder commentStamp: ''!
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: ''!
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 ] ]! !

!ClassDiffBuilder methodsFor: 'private' stamp: ''!
print: aString withAttributes: attributes on: stream

	stream
		withAttributes: attributes 
		do: [ stream nextPutAll: aString ]! !

!ClassFactoryForTestCase commentStamp: ''!
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: 'creating' stamp: ''!
newTrait

	^ self
		  newTraitNamed: self newTraitName
		  uses: Array new
		  tag: self defaultTagPostfix! !

!ClassFactoryForTestCase methodsFor: 'accessing' stamp: ''!
defaultCategory

	^ (self packageName , '-' , self defaultTagPostfix) asSymbol! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString

	^ self
		  newSubclassOf: aClass
		  uses: {  }
		  instanceVariableNames: ivNamesString
		  classVariableNames: classVarsString
		  category: self defaultTagPostfix! !

!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: ''!
cleanUpChangeSetForClassNames: classeNames

	self class environment at: #ChangeSet ifPresent: [ :aChangeSetClass |
		| changeSet |
		changeSet := aChangeSetClass current.
		classeNames do: [:name|	
			changeSet 
				removeClassChanges: name;
				removeClassChanges: name, ' class']]! !

!ClassFactoryForTestCase methodsFor: 'accessing' stamp: ''!
createdClassNames

	^ self createdClasses collect: [ :class | class name ]! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
duplicateClass: aClass withNewName: name

	| newClass |
	newClass := aClass duplicateClassWithNewName: name.
	self createdClasses add: newClass.
	^ newClass! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newSubclassOf: aClass uses: aTraitComposition instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: poolNamesString category: category

	| newClass |
	newClass := self class classInstaller make: [ :aBuilder | 
		            aBuilder
			            name: self newClassName;
			            superclass: aClass;
			            traitComposition: aTraitComposition asTraitComposition;
			            slots: ivNamesString asSlotCollection;
			            sharedVariablesFromString: classVarsString;
			            sharedPools: poolNamesString;
			            package: (self packageName , '-' , category) asSymbol ].

	self createdClasses add: newClass.
	^ newClass! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newTraitNamed: aTraitName uses: aTraitComposition tag: aTag

	| newTrait |
	newTrait := self class classInstaller make: [ :aBuilder | 
		            aBuilder
			            name: aTraitName;
			            traitComposition: aTraitComposition asTraitComposition;
			            package: (self packageName , '-' , aTag) asSymbol;
			            beTrait ].

	self createdTraits add: newTrait.
	^ newTrait! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newClass

	^ self
		  newSubclassOf: self defaultSuperclass
		  instanceVariableNames: ''
		  classVariableNames: ''! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newSubclassOf: aClass using: aTraitComposition

	^ self
		  newSubclassOf: aClass
		  uses: aTraitComposition
		  instanceVariableNames: ''
		  classVariableNames: ''
		  category: self defaultTagPostfix! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newClassUsing: aTraitComposition

	^ self
		  newSubclassOf: self defaultSuperclass
		  uses: aTraitComposition
		  instanceVariableNames: ''
		  classVariableNames: ''
		  category: self defaultTagPostfix! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category

	^ self
		  newSubclassOf: aClass
		  uses: {  }
		  instanceVariableNames: ivNamesString
		  classVariableNames: classVarsString
		  category: category! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
redefineClass: aClass category: aString

	^ self
		  redefineClass: aClass
		  subclassOf: aClass superclass
		  uses: aClass traitComposition
		  instanceVariableNames: aClass instanceVariablesString
		  classVariableNames: aClass classVariablesString
		  poolDictionaries: aClass sharedPoolsString
		  package: aString! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
redefineClass: aClass instanceVariableNames: aString

	^ self
		  redefineClass: aClass
		  subclassOf: aClass superclass
		  uses: aClass traitComposition
		  instanceVariableNames: aString
		  classVariableNames: aClass classVariablesString
		  poolDictionaries: aClass sharedPoolsString
		  package: aClass category! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newClassInCategory: category

	^ self
		  newSubclassOf: self defaultSuperclass
		  instanceVariableNames: ''
		  classVariableNames: ''
		  category: category! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newSubclassOf: aClass

	^ self
		  newSubclassOf: aClass
		  instanceVariableNames: ''
		  classVariableNames: ''! !

!ClassFactoryForTestCase methodsFor: 'accessing' stamp: ''!
packageName

	^ #CategoryForTestToBeDeleted! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newSubclassOf: aClass uses: aTraitComposition instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category

	^ self
		  newSubclassOf: aClass
		  uses: aTraitComposition
		  instanceVariableNames: ivNamesString
		  classVariableNames: classVarsString
		  poolDictionaries: ''
		  category: category! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newTraitInTag: aTag

	^ self
		  newTraitNamed: self newTraitName
		  uses: Array new
		  tag: aTag asSymbol! !

!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: ''!
deleteTraits

	self createdTraits do: [ :trait | self delete: trait ]! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newClassWithInstanceVariableNames: aString

	^ self
		  newSubclassOf: self defaultSuperclass
		  instanceVariableNames: aString
		  classVariableNames: ''! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newTraitName

	| postFix |
	postFix := (self createdTraits size + 1) printString.
	^ (#TraitForTestToBeDeleted , postFix) asSymbol! !

!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: ''!
deletePackage

	| categoriesMatchString |
	categoriesMatchString := self packageName , '-*'.
	SystemOrganization removeCategoriesMatching: categoriesMatchString! !

!ClassFactoryForTestCase methodsFor: 'accessing' stamp: ''!
defaultTagPostfix

	^ #Default! !

!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: ''!
deleteClasses

	self createdClasses do: [ :class | self delete: class ]! !

!ClassFactoryForTestCase methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	createdClasses := IdentitySet new.
	createdTraits := IdentitySet new.
	createdSilently := IdentitySet new! !

!ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: ''!
silentlyNewClassInCategory: category

	^ self
		  silentlyNewSubclassOf: self defaultSuperclass
		  instanceVariableNames: ''
		  classVariableNames: ''
		  category: category! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
withNotificationsNewClassWithInstanceVariableNames: instanceVariableNames

	^ self
		  newSubclassOf: Object
		  instanceVariableNames: instanceVariableNames
		  classVariableNames: ''
		  category: self defaultTagPostfix! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
withNotificationsNewClass

	^ self withNotificationsNewClassWithInstanceVariableNames: ''! !

!ClassFactoryForTestCase methodsFor: 'accessing' stamp: ''!
defaultSuperclass

	^ Object! !

!ClassFactoryForTestCase methodsFor: 'accessing' stamp: ''!
nextCount
	"Global counter to avoid name clash between test runs, in case of some previous failure."

	^ Counter := (Counter ifNil: [ 0 ]) + 1! !

!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: ''!
deleteClass: aClass

	self createdClasses remove: aClass.
	self delete: aClass! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
redefineClass: aClass subclassOf: aSuperclass uses: aTraitComposition instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: poolNamesString package: aPackageName

	| newClass |
	newClass := self class classInstaller make: [ :aBuilder | 
		            aBuilder
			            name: aClass name;
			            superclass: aSuperclass;
			            traitComposition: aTraitComposition asTraitComposition;
			            slots: ivNamesString asSlotCollection;
			            sharedVariablesFromString: classVarsString;
			            sharedPools: poolNamesString;
			            package: aPackageName asSymbol ].

	self createdClasses add: newClass.
	^ newClass! !

!ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: ''!
silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString
	
	^ self
		silentlyNewSubclassOf: aClass
		instanceVariableNames: ivNamesString
		classVariableNames: classVarsString
		category: self defaultTagPostfix! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newClassName

	| postFix |
	postFix := self nextCount printString.
	^ (#ClassForTestToBeDeleted , postFix) asSymbol! !

!ClassFactoryForTestCase methodsFor: 'accessing' stamp: ''!
createdClasses

	^ createdClasses! !

!ClassFactoryForTestCase methodsFor: 'accessing' stamp: ''!
createdTraits

	^ createdTraits! !

!ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: ''!
silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category

	^ self
		  silentlyNewSubclassOf: aClass
		  instanceVariableNames: ivNamesString
		  classVariableNames: classVarsString
		  package: (self packageName , '-' , category) asSymbol! !

!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: ''!
delete: aBehavior

	aBehavior isObsolete ifTrue: [ ^ self ].
	self class environment
		at: #ChangeSet
		ifPresent: [ aBehavior removeFromChanges ].
	(createdSilently includes: aBehavior)
		ifTrue: [ aBehavior removeFromSystemUnlogged ]
		ifFalse: [ aBehavior removeFromSystem ]! !

!ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: ''!
silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString package: packageName

	SystemAnnouncer uniqueInstance suspendAllWhile: [ 
		^ self
			  newSubclassOf: aClass
			  uses: #(  )
			  instanceVariableNames: ivNamesString
			  classVariableNames: classVarsString
			  poolDictionaries: ''
			  category: packageName ]! !

!ClassFactoryForTestCase methodsFor: 'creating' stamp: ''!
newTraitUsing: aTraitComposition

	^ self
		  newTraitNamed: self newTraitName
		  uses: aTraitComposition
		  tag: self defaultTagPostfix! !

!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: ''!
cleanUp

	| createdClassNames createdTraitNames |
	createdClassNames := self createdClassNames.
	createdTraitNames := self createdTraitNames.

	self 
		deleteClasses;
		deleteTraits;
		deletePackage;
		cleanUpChangeSetForClassNames: createdClassNames;
		cleanUpChangeSetForClassNames: createdTraitNames! !

!ClassFactoryForTestCase methodsFor: 'accessing' stamp: ''!
createdTraitNames

	^ self createdTraits collect: [ :trait | trait name ]! !

!ClassFactoryForTestCaseTest commentStamp: ''!
SUnit tests for ClassFactoryForTestCase !
!ClassFactoryForTestCaseTest methodsFor: 'running' stamp: ''!
tearDown
	
	factory cleanUp.
	super tearDown! !

!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: ''!
testSingleClassFastCreation
	| class elementsInCategoryForTest |
	class := factory newClass.
	self assert: (SystemNavigation new allClasses includes: class).
	elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory.
	self assert: elementsInCategoryForTest equals: {class name}.
	self assertEmpty: class instVarNames.
	self assertEmpty: class classPool! !

!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: ''!
testSingleTraitCreation
	| trait |
	trait := factory newTrait.
	self assert: (testingEnvironment allTraits includes: trait).
	self assert: trait traitUsers size equals: 0.
	self assert: trait traits size equals: 0! !

!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: ''!
testTraitCreationInDifferentCategories
	| firstThreeTraits lastTwoTraits |
	3 timesRepeat: [
		factory newTraitInTag: #One].
	firstThreeTraits := factory createdTraits copy.
	2 timesRepeat: [
		factory newTraitInTag: #Two].
	lastTwoTraits := factory createdTraits copyWithoutAll: firstThreeTraits.
	self assert: (firstThreeTraits allSatisfy: [:trait| trait category = (factory packageName, '-', #One) asSymbol]).
	self assert: (lastTwoTraits allSatisfy: [:trait| trait category = (factory packageName, '-', #Two) asSymbol]).! !

!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: ''!
testMultipleClassCreation
	5 timesRepeat: [ factory newClass ].
	self assert: (SystemNavigation new allClasses includesAll: factory createdClasses).
	self assert: factory createdClassNames asSet size equals: 5.
	self assert: (SystemOrganization listAtCategoryNamed: factory defaultCategory) asSet equals: factory createdClassNames asSet! !

!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: ''!
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: ''!
testDefaultCategoryCleanUp
	| createdClassNames allClasses allTraits |
	
	3 timesRepeat: [
		factory newClass.
		factory newTrait].
	
	createdClassNames := factory createdClassNames.
	
	factory cleanUp.	
	
	self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). 
	self assert: (factory createdTraits allSatisfy: [:trait| trait isObsolete]). 
	
	allClasses := SystemNavigation new allClasses.
	allTraits := testingEnvironment allTraits.
	
	self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]).
	self assert: (factory createdTraits noneSatisfy: [:trait| allTraits includes: trait]).
	self deny: (SystemOrganization categories includes: factory defaultCategory). 
	self class environment at: #ChangeSet ifPresent: [:changeSet |
		self deny: (changeSet current changedClassNames includesAnyOf: createdClassNames) ].
! !

!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: ''!
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 assertEmpty: (SystemOrganization categoriesMatching: factory packageName , '*').
	self class environment at: #ChangeSet ifPresent: [ :changeSet | self deny: (changeSet current changedClassNames includesAnyOf: createdClassNames) ]! !

!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: ''!
testDuplicateClassWithNewName
	| createdClass |
	
	"Skip this tests if no compiler is available. Do not use #skip because it breaks an announcements tests"
	
	Smalltalk compilerClass ifNotNil: [ 	
		createdClass := factory duplicateClass: TestCase withNewName: #MyTestClass.
		self assert: (factory createdClasses allSatisfy: [:class| self class environment includesKey: class name ]).
		factory cleanUp.
		self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]) ]
	
! !

!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: ''!
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: ''!
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 equals: {class name}.
	self assert: class instVarNames equals: #(a b c).
	self assert: class classPool keys asSet equals: #(X Y) asSet! !

!ClassFactoryForTestCaseTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	factory := ClassFactoryForTestCase new! !

!ClassFactoryForTestCaseTest class methodsFor: 'history' stamp: ''!
lastStoredRun
	^ ((Dictionary new) add: (#passed->((Set new) add: #testDefaultCategoryCleanUp; add: #testPackageCleanUp; add: #testSingleClassCreation; add: #testClassCreationInDifferentCategories; add: #testClassFastCreationInDifferentCategories; add: #testMultipleClassCreation; add: #testSingleClassFastCreation; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! !

!ClassFactoryWithOrganization commentStamp: ''!
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: 'cleaning' stamp: ''!
deletePackage

	| categoriesMatchString |
	categoriesMatchString := self packageName , '-*'.
	self organization
		removeCategoriesMatching: categoriesMatchString;
		removeEmptyCategories! !

!ClassFactoryWithOrganization methodsFor: 'creating' stamp: ''!
newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString

	^ self
		  newSubclassOf: aClass
		  instanceVariableNames: ivNamesString
		  classVariableNames: classVarsString
		  category:
		  (self packageName , '-' , self defaultTagPostfix) asSymbol! !

!ClassFactoryWithOrganization methodsFor: 'accessing' stamp: ''!
organization

	^ organization! !

!ClassFactoryWithOrganization methodsFor: 'creating' stamp: ''!
newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category

	| newClass |
	newClass := aClass classInstaller make: [ :builder | 
		            builder
			            superclass: aClass;
			            name: self newClassName;
			            layoutClass: aClass classLayout class;
			            slots: ivNamesString asSlotCollection;
			            sharedVariablesFromString: classVarsString;
			            sharedPools: '';
			            category: category asSymbol;
			            environment: self organization environment ].
	self createdClasses add: newClass.
	^ newClass! !

!ClassFactoryWithOrganization methodsFor: 'creating' stamp: ''!
newClassNamed: aString 
	subclassOf: aClass 
	instanceVariableNames: ivNamesString 
	classVariableNames:  classVarsString 
	
	^ self 
		newClassNamed: aString
		subclassOf: aClass 
		instanceVariableNames: ivNamesString 
		classVariableNames: classVarsString 
		category:  (self packageName, '-', self defaultTagPostfix) asSymbol.! !

!ClassFactoryWithOrganization methodsFor: 'accessing' stamp: ''!
organization: aSystemOrganizer
	organization := aSystemOrganizer! !

!ClassFactoryWithOrganization methodsFor: 'creating' stamp: ''!
newClassNamed: aString subclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category

	| newClass |
	newClass := aClass classInstaller make: [ :builder | 
		            builder
			            superclass: aClass;
			            name: aString;
			            layoutClass: aClass classLayout class;
			            slots: ivNamesString asSlotCollection;
			            sharedVariablesFromString: classVarsString;
			            sharedPools: '';
			            category: category asSymbol;
			            environment: self organization environment ].
	self createdClasses add: newClass.
	^ newClass! !

!ClassFactoryWithOrganization class methodsFor: 'instance creation' stamp: ''!
newWithOrganization: aSystemOrganizer
	^self new
		organization: aSystemOrganizer;
		yourself! !

!ClassFactoryWithOrganizationTest commentStamp: ''!
SUnit tests for ClassFactoryWithOrganization!
!ClassFactoryWithOrganizationTest methodsFor: 'running' stamp: ''!
setUp
	| environment |
	super setUp.
	environment := SystemDictionary withOrganizer: SystemOrganizer new.
	factory := ClassFactoryWithOrganization newWithOrganization: environment organization.
	! !

!ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: ''!
assertEnvironmentOf: aBehavior
	self assert: aBehavior environment equals: self testedEnvironment! !

!ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: ''!
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 equals: {class name}.
	self assertEmpty: class instVarNames.
	self assertEmpty: class classPool! !

!ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: ''!
testMultipleClassCreation
	5 timesRepeat: [ factory newClass ].
	self assert: (self testedEnvironment allClasses includesAll: factory createdClasses).
	self assert: factory createdClassNames asSet size equals: 5.
	self assert: (self testedOrganization listAtCategoryNamed: factory defaultCategory) asSet equals: factory createdClassNames asSet.
	factory createdClasses do: [ :aClass | self assertEnvironmentOf: aClass ]! !

!ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: ''!
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: ''!
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 class environment at: #ChangeSet ifPresent: [:changeSet |
		self deny: (changeSet current changedClassNames includesAnyOf: createdClassNames) ].
! !

!ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: ''!
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 assertEmpty: (self testedOrganization categoriesMatching: factory packageName , '*').
	self class environment at: #ChangeSet ifPresent: [ :changeSet | self deny: (changeSet current changedClassNames includesAnyOf: createdClassNames) ]! !

!ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: ''!
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 equals: {class name}.
	self assert: class instVarNames equals: #(a b c).
	self assert: class classPool keys asSet equals: #(X Y) asSet! !

!ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: ''!
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: 'accessing' stamp: ''!
testedOrganization
	^factory organization! !

!ClassFactoryWithOrganizationTest methodsFor: 'accessing' stamp: ''!
testedEnvironment
	^self testedOrganization environment! !

!ClassHierarchyPrinter commentStamp: ''!
I'm a nice class hierarchy printer.
I can be configured as follows: 
	- show or not class instance variables (`ClassHierarchy>>#doNotShowState`)
	- show or not superclasses (`ClassHierarchy>>#doNotShowState`)
	- limit the classes to a given set
	- exclude some classes
	
For examples browse `ClassHierarchyPrinterTest`

```
ClassHierarchyPrinter new 
		forClass: RBNode; 
		doNotShowState;
		doNotShowSuperclasses;
		excludedClasses: (RBNode withAllSubclasses select: [ :each | each name beginsWith: 'RBPattern' ]);
		limitedToClasses: (RBNode withAllSubclasses select: [:each | each name beginsWith: 'RB']).
```

produces 

```
'RBNode
	RBProgramNode
		RBComment
		RBMethodNode
		RBPragmaNode
		RBReturnNode
		RBSequenceNode
		RBValueNode
			RBArrayNode
			RBAssignmentNode
			RBBlockNode
			RBCascadeNode
			RBLiteralNode
				RBLiteralArrayNode
				RBLiteralValueNode
			RBMessageNode
			RBParseErrorNode
				RBEnglobingErrorNode
					RBArrayErrorNode
					RBBlockErrorNode
					RBInvalidCascadeErrorNode
					RBLiteralArrayErrorNode
					RBLiteralByteArrayErrorNode
					RBMissingOpenerErrorNode
					RBParenthesesErrorNode
					RBPragmaErrorNode
					RBTemporariesErrorNode
					RBUnfinishedStatementErrorNode
					RBUnreachableStatementErrorNode
			RBSelectorNode
			RBVariableNode
				RBArgumentNode
				RBGlobalNode
				RBInstanceVariableNode
				RBSelfNode
				RBSuperNode
				RBTemporaryNode
				RBThisContextNode
	RBSlotInitializationNode
'
```	
### Some nice examples
	
Another nice example is the following one which prints a package roots by roots.

```
String streamContents: [ :st |  
	| printer |
	printer := ClassHierarchyPrinter new.
	printer doNotShowSuperclasses.
	printer on: st.	
	((SortedCollection sortBlock: [ :a :b | a name < b name ])
		addAll: (RPackageOrganizer default packageNamed: 'Refactoring-Core') roots)
			do: [ :each | 
				printer forClass: each. 
				printer print.
				printer resetLevel]]
```

Now to print according to tags:

```
| p roots |
p := (RPackageOrganizer default packageNamed: 'MenuRegistration').
roots := p roots. 
String streamContents: [ :st |  
	| printer |
	printer := ClassHierarchyPrinter new.
	printer doNotShowSuperclasses.
	printer on: st.    
	p classTags do: [ :aTag | 
		| rootsPerTag |
		printer 
			nextPutAll: 'Tag: ', aTag name ; 
			cr;
			nextPutAll: '==================================='; cr.
		  rootsPerTag := (p classesForClassTag: aTag name) select: [ :each | roots includes: each ].
        rootsPerTag
             do: [ :each | 
                    printer forClass: each. 
                    printer print.
                    printer resetLevel]]]
```

!
!ClassHierarchyPrinter methodsFor: 'public API' stamp: ''!
print
	"Answer a description containing the names and instance variable names 
	of all of the subclasses and superclasses of the class."
	
	theClass ifNotNil: [ 
		showSuperclasses 
			ifTrue: [ self printSuperclasses ].
			self printSubclassesOf: theClass ].
	^ stream contents! !

!ClassHierarchyPrinter methodsFor: 'initialization' stamp: ''!
initializeStream 
	stream := (String new: 100) writeStream! !

!ClassHierarchyPrinter methodsFor: 'initialization' stamp: ''!
initialize 	
	super initialize.
	excludedClasses := #().
	limitedToClasses := #().
	self resetLevel.
	showSuperclasses := true.
	showState := true.
	self initializeStream! !

!ClassHierarchyPrinter methodsFor: 'public API' stamp: ''!
on: aStream

	stream := aStream! !

!ClassHierarchyPrinter methodsFor: 'configuration' stamp: ''!
limitedToClasses: aCollection
	"To set the only classes that should be printed."
	
	limitedToClasses := aCollection! !

!ClassHierarchyPrinter methodsFor: 'printing' stamp: ''!
printSubclassesOf: aClass
	"As part of the algorithm for printing a description of the receiver, print the
	subclass on the file stream, aStream, indenting level times."

	| sortedSubclasses |
	limitedToClasses ifNotEmpty: [ 
			(limitedToClasses includes: aClass) 
				ifFalse: [ ^ self ]
			].
	(excludedClasses includes: aClass)
		ifTrue: [ ^ self ].
		
	self printClass: aClass.
	aClass == Class
		ifTrue: [ stream
				tab: index + 1;
				nextPutAll: '[ ... all the Metaclasses ... ]'.
			^ self ].
	sortedSubclasses := aClass subclasses
		asSortedCollection: [ :c1 :c2 | c1 name <= c2 name ].
	sortedSubclasses do: [ :subclass | 
			index := index + 1.
			self printSubclassesOf: subclass.
			index := index - 1 ]! !

!ClassHierarchyPrinter methodsFor: 'configuration' stamp: ''!
doNotShowState

	showState := false! !

!ClassHierarchyPrinter methodsFor: 'printing' stamp: ''!
printSuperclasses

	theClass allSuperclasses
		reverseDo: [ :aClass | 
			self printClass: aClass.
			index := index + 1 ].
	stream cr.	"to spot the requested class."! !

!ClassHierarchyPrinter methodsFor: 'public API' stamp: ''!
forClass: aClass 
	theClass := aClass! !

!ClassHierarchyPrinter methodsFor: 'public API' stamp: ''!
tab
	stream tab! !

!ClassHierarchyPrinter methodsFor: 'initialization' stamp: ''!
resetLevel 
	index := 0.! !

!ClassHierarchyPrinter methodsFor: 'configuration' stamp: ''!
excludedClasses: aCollection
	"To set the classes that we do not want to see printed."
	excludedClasses := aCollection! !

!ClassHierarchyPrinter methodsFor: 'configuration' stamp: ''!
showSuperclasses

	showSuperclasses := true! !

!ClassHierarchyPrinter methodsFor: 'printing' stamp: ''!
printClass: aClass
	"Print a single line in the printout."
	stream tab: index.
	stream nextPutAll: aClass name.
	aClass instVarNames ifNotEmpty: [ :vars | 
		showState ifTrue: [ stream space. 
								stream nextPutAll: '( '.
								aClass instVarNames
									do: [ :iv | stream nextPutAll:  iv asString ]
									separatedBy: [ stream space ].
								stream  nextPutAll: ' )' ] ].
	stream cr! !

!ClassHierarchyPrinter methodsFor: 'public API' stamp: ''!
nextPutAll: aString
	stream nextPutAll: aString! !

!ClassHierarchyPrinter methodsFor: 'configuration' stamp: ''!
doNotShowSuperclasses

	showSuperclasses := false! !

!ClassHierarchyPrinter methodsFor: 'public API' stamp: ''!
cr
	stream cr! !

!ClassHierarchyPrinter class methodsFor: 'instance creation' stamp: ''!
forClass: aClass

	^ self new forClass: aClass; yourself! !

!ClassHierarchyPrinterTest methodsFor: 'tests' stamp: ''!
testPrintHierarchyOfRectangle

	printer forClass: Rectangle. 
	self 
		assert: printer print 
		equals:
'ProtoObject
	Object

		Rectangle ( origin corner )
			CharacterBlock ( stringIndex text textLine )
'! !

!ClassHierarchyPrinterTest methodsFor: 'tests' stamp: ''!
testPrintClassNamesOnly

	printer 
		forClass: Rectangle; 
		doNotShowState;
		doNotShowSuperclasses.
	self 
		assert: printer print 
		equals: 
'Rectangle
	CharacterBlock
'! !

!ClassHierarchyPrinterTest methodsFor: 'tests' stamp: ''!
testPrintFullHierarchyOfRectangle

	printer forClass: Rectangle. 
	self 
		assert: printer print  
		equals: 'ProtoObject
	Object

		Rectangle ( origin corner )
			CharacterBlock ( stringIndex text textLine )
'! !

!ClassHierarchyPrinterTest methodsFor: 'tests' stamp: ''!
testPrintHierarchyOfRectangleWithFilteredClasses

	printer forClass: Rectangle. 
	printer limitedToClasses: { Rectangle }.
	self 
		assert: printer print 
		equals: 
'ProtoObject
	Object

		Rectangle ( origin corner )
'! !

!ClassHierarchyPrinterTest methodsFor: 'tests' stamp: ''!
testPrintHierarchyOfPoint

	printer forClass: Point. 
	self 
		assert: printer print 
		equals:
'ProtoObject
	Object

		Point ( x y )
'! !

!ClassHierarchyPrinterTest methodsFor: 'tests' stamp: ''!
testPrintHierarchyOfPointNoState

	printer 
		forClass: Point ; 
		doNotShowState.
	self 
		assert: printer print 
		equals:
'ProtoObject
	Object

		Point
'! !

!ClassHierarchyPrinterTest methodsFor: 'tests' stamp: ''!
testOnlyRBASTNodes

	printer 
		forClass: RBNode; 
		doNotShowState;
		doNotShowSuperclasses;
		excludedClasses: (RBNode withAllSubclasses select: [ :each | each name beginsWith: 'RBPattern' ]);
		limitedToClasses: (RBNode withAllSubclasses select: [:each | each name beginsWith: 'RB']).
	self assert: printer print equals: 
	'RBNode
	RBProgramNode
		RBComment
		RBMethodNode
		RBPragmaNode
		RBReturnNode
		RBSequenceNode
		RBValueNode
			RBArrayNode
			RBAssignmentNode
			RBBlockNode
			RBCascadeNode
			RBLiteralNode
				RBLiteralArrayNode
				RBLiteralValueNode
			RBMessageNode
			RBParseErrorNode
				RBEnglobingErrorNode
					RBArrayErrorNode
					RBBlockErrorNode
					RBInvalidCascadeErrorNode
					RBLiteralArrayErrorNode
					RBLiteralByteArrayErrorNode
					RBMissingOpenerErrorNode
					RBParenthesesErrorNode
					RBPragmaErrorNode
					RBTemporariesErrorNode
					RBUnfinishedStatementErrorNode
					RBUnreachableStatementErrorNode
			RBSelectorNode
			RBVariableNode
	RBSlotInitializationNode
'! !

!ClassHierarchyPrinterTest methodsFor: 'tests' stamp: ''!
testPrintHierarchyOfPointNoSuperclasses

	printer 
		forClass: Point;
		doNotShowSuperclasses.
	self 
		assert: printer print 
		equals: 'Point ( x y )
'! !

!ClassHierarchyPrinterTest methodsFor: 'tests' stamp: ''!
testOnlyFreeText

	printer 
		nextPutAll: 'Start';
		cr;
		tab;
		nextPutAll: 'Tabbed';
		cr;
		nextPutAll: 'End'.
		
		
	self assert: printer print equals: 'Start
	Tabbed
End'! !

!ClassHierarchyPrinterTest methodsFor: 'tests' stamp: ''!
testPrintHierarchyOfRectangleNoSuperclasses

	printer 
		forClass: Rectangle; 
		doNotShowSuperclasses.
	self 
		assert: printer print 
		equals:
'Rectangle ( origin corner )
	CharacterBlock ( stringIndex text textLine )
'! !

!ClassHierarchyPrinterTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	printer := ClassHierarchyPrinter new.! !

!ClassHierarchyTest commentStamp: ''!
SUnit tests for the class hierarchy!
!ClassHierarchyTest methodsFor: 'tests' stamp: ''!
testSubclasses
	" self class fixSubclasses "

	SystemNavigation new
		allClassesDo: [ :cls | 
			self
				assert: (cls superclass isNil or: [ cls superclass subclasses includes: cls ])
				description: cls name , ' is not in ' , (cls superclass ifNotNil: [ :superclass | superclass name ] ifNil: [ 'nil' ]) , '''s subclasses' ]! !

!ClassHierarchyTest methodsFor: 'tests' stamp: ''!
testObjectFormatInstSize
	| offending |
	"check that #instSize is in sync with the layout of the class"
	offending := SystemNavigation default allBehaviors reject: [ :cls | 
		cls instSize = cls classLayout fieldSize].
	self assertCollection: offending hasSameElements: {}.! !

!ClassHierarchyTest methodsFor: 'tests' stamp: ''!
testSubclassInstVar
	| subclasses |
	SystemNavigation new
		allClassesDo: [ :cls | 
			subclasses := cls subclasses.
			self assert: subclasses isNil not.
			subclasses
				do: [ :subclass | 
					self assert: (subclasses occurrencesOf: subclass) equals: 1.
					self assert: subclass superclass identicalTo: cls ] ]! !

!ClassHierarchyTest class methodsFor: 'fixing' stamp: ''!
fixSlotScope
	"postscript for issue 11596"
	
	| ivName all candidates toRebuild |
    ivName := 'anIVNameImPrettySureNobodyUses'.
    all := Smalltalk allClasses flatCollect: [ :e | { e . e class } ].
    candidates := all reject: [ :e | e superclass isNil or: [e classLayout slotScope isKindOf: LayoutEmptyScope ] ].
    toRebuild := candidates reject: [ :e | e superclass classLayout slotScope == e classLayout slotScope parentScope ].
    toRebuild sort: [ :a :b | a allSuperclasses size > b allSuperclasses size ].
    toRebuild do: [ :e | 
    e addInstVarNamed: ivName.
        (e isClassSide
          ifTrue: [ (Smalltalk at: e instanceSide name) classSide ]
          ifFalse: [ Smalltalk at: e name ]) removeInstVarNamed: ivName ]! !

!ClassListExample commentStamp: ''!
ClassListExample new openOn: Object
!
!ClassListExample methodsFor: 'instance creation' stamp: ''!
open
	^ self openOn: Object! !

!ClassListExample methodsFor: 'instance creation' stamp: ''!
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: 'user interface' stamp: ''!
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 iconNamed: #smallOpenIcon)
					target: nil
					actionSelector: nil
					arguments: #()).
			(MorphTreeColumn new
				rowMorphGetSelector: #commentText;
				headerButtonLabel: 'Comments'
					font: nil
					icon: (self iconNamed: #smallPrintIcon)
					target: nil
					actionSelector: nil
					arguments: #())};
		makeLastColumnUnbounded;
		withHLines: true;
		allowColumnDrop;
		useSquareCorners;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		rowInset: 5;
		columnInset: 5;
		resizerWidth: 2;
		preferedPaneColor: Color white;
		getMenuSelector: #menu:shifted:;
		columnColorForEven: evenColor odd: oddColor.
	^ treeMorph buildContents! !

!ClassListExample methodsFor: 'accessing' stamp: ''!
keyStroke: anEvent from: aTreeMorph
	self selectedNode
		ifNotNil: [:current | current keyStroke: anEvent from: aTreeMorph]! !

!ClassListExample methodsFor: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
rootNodeClassFromItem: anItem
	^ClassListNodeExample! !

!ClassListExample methodsFor: 'accessing' stamp: ''!
rootClass
	^ rootClass ifNil: [rootClass := Object]! !

!ClassListExample methodsFor: 'accessing' stamp: ''!
rootClass: aClass
	 rootClass := aClass! !

!ClassListExample methodsFor: 'accessing' stamp: ''!
rootItems
	^ self rootClass allSubclasses asArray sort: [:a :b | a name < b name ]! !

!ClassListExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>

	^self new openOn: self! !

!ClassListNodeExample commentStamp: ''!
Example for a class list node!
!ClassListNodeExample methodsFor: 'menu' stamp: ''!
commentText

	^ (self theme newTextIn: self text: self item comment)
		unlock;
		wrapFlag: true;
		yourself! !

!ClassListNodeExample methodsFor: 'accessing' stamp: ''!
exploreItem
	self inspect! !

!ClassListNodeExample methodsFor: 'accessing' stamp: ''!
keyStroke: anEvent from: aTreeMorph
	| c |
	c := anEvent keyCharacter.
	c = $b
		ifTrue: [self browseItem. ^ true].
	c = $i
		ifTrue: [self inspectItem. ^ true].
	c = $I
		ifTrue: [self exploreItem. ^ true].
	^ false! !

!ClassListNodeExample methodsFor: 'menu' stamp: ''!
classButton
	^ (self theme 
		newButtonIn: self
		for: self
		getState: nil
		action: #browseItem
		arguments: {}
		getEnabled: #enabled
		getLabel: nil
		help: 'Open a browser on ' translated , self item name)
			label: (self theme windowLabelForText: (self item name) , '...');
			yourself! !

!ClassListNodeExample methodsFor: 'accessing' stamp: ''!
menu: menu shifted: b 
	menu
		add: 'Browse (b)' 
		target: self
		selector: #browseItem.
	menu
		add: 'Inspect (i)' 
		target: self
		selector: #inspectItem.
	menu
		add: 'Explore (I)' 
		target: self
		selector: #exploreItem.! !

!ClassListNodeExample methodsFor: 'menu' stamp: ''!
icon
	^ self iconNamed: #smallExpertIcon! !

!ClassListNodeExample methodsFor: 'accessing' stamp: ''!
browseItem
	Smalltalk tools browser openOnClass: self item! !

!ClassListNodeExample methodsFor: 'accessing' stamp: ''!
inspectItem
	self inspect! !

!ClassModificationApplied commentStamp: ''!
This announcement will be emitted when a class or a trait definition changes and completally installed.

It is different than ClassModifiedClassDefinition because it signalled only after new version of class/trait object is installed to system by become operation.  And that's why only modifiedClass variable is available (after #becomeForward: operation old version of class/trait disappear)!
!ClassModificationApplied methodsFor: '*Calypso-SystemQueries' stamp: ''!
affectsMethod: aMethod
	"Class modification leads to methods recompilation (because variables are changed).
	So it means that this event affects any method of modified class"
	
	^self classAffected == aMethod origin! !

!ClassModificationApplied methodsFor: 'accessing' stamp: ''!
classAffected
	^modifiedClass ! !

!ClassModificationApplied methodsFor: '*Calypso-SystemQueries' stamp: ''!
affectsVariablesOf: aClass
	"Any class has ClassVariables which are visible from both sides: instance side and class 	side.
	Therefore any class modification can affect variables from both class sides.
	And we do not need to distinguish it"

	aClass instanceSide = modifiedClass instanceSide ifTrue: [ ^true ].
	
	^false! !

!ClassModificationApplied methodsFor: 'accessing' stamp: ''!
modifiedClass: anObject
	modifiedClass := anObject! !

!ClassModificationApplied class methodsFor: 'instance creation' stamp: ''!
toClass: aClassOrTrait

	^self new 
		modifiedClass: aClassOrTrait! !

!ClassModifiedClassDefinition commentStamp: ''!
This announcement will be emitted when a class or a trait definition changes.

For example, when an instance variable is added or when the trait composition is modified in a class definition.!
!ClassModifiedClassDefinition methodsFor: 'accessing' stamp: ''!
newClassDefinition
	^newClassDefinition! !

!ClassModifiedClassDefinition methodsFor: 'accessing' stamp: ''!
classAffected
	^self newClassDefinition! !

!ClassModifiedClassDefinition methodsFor: 'accessing' stamp: ''!
oldClassDefinition: aClass
	oldClassDefinition := aClass! !

!ClassModifiedClassDefinition methodsFor: 'accessing' stamp: ''!
newClassDefinition: aClass
	newClassDefinition := aClass! !

!ClassModifiedClassDefinition methodsFor: 'accessing' stamp: ''!
oldClassDefinition
	^oldClassDefinition! !

!ClassModifiedClassDefinition methodsFor: '*Calypso-SystemQueries' stamp: ''!
shouldBeConsideredByCalypsoEnvironment
	"We dont want this event at all because when it happen system has no information about new class
	and both globals and packages are referenced old object.
	So instead ClassModificationApplied is used"
	^false! !

!ClassModifiedClassDefinition class methodsFor: 'instance creation' stamp: ''!
classDefinitionChangedFrom: oldClass to: newClass
	^self new
			oldClassDefinition: oldClass;
			newClassDefinition: newClass;
			yourself! !

!ClassMultiplePoolUser commentStamp: ''!
I'm a class using two shared pools. !
!ClassMultiplePoolUser class methodsFor: 'accessing' stamp: ''!
gloups

	^ Gloups! !

!ClassMultiplePoolUser class methodsFor: 'accessing' stamp: ''!
author

	^ AnAuthor! !

!ClassMultiplePoolUser class methodsFor: 'accessing' stamp: ''!
variableInPoolDefiner2

	^ VariableInPoolDefiner2! !

!ClassOrganization commentStamp: ''!
This class manages the class comment and a protocol organizer!
!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
ownCategories
        "get all categories that are not obtained from traits. Order is random"

        | traitsCategories |

        traitsCategories := self subject traits
                inject: Set new
                into: [:set :trait |
                        set addAll: (trait organization protocolOrganizer protocols
                                reject: [ :eachProtocol |
                                        self subject methods anySatisfy: [ :eachMethod |
                                                eachMethod origin = self subject
                                                                and: [ eachMethod protocol = eachProtocol name ] ] ]).
                        set ].
        ^ ((self protocolOrganizer protocols collect: [:each | each name])
                copyWithoutAll: (traitsCategories collect: [:each | each name])) asArray.! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
classComment: aString

	self comment: aString! !

!ClassOrganization methodsFor: 'testing' stamp: ''!
hasComment
	^ commentSourcePointer isNotNil! !

!ClassOrganization methodsFor: 'copying' stamp: ''!
copyFrom: otherOrganization
	commentSourcePointer  := otherOrganization commentSourcePointer.
	otherOrganization protocols do: [ :p | p methodSelectors do: [ :m | protocolOrganizer classify: m inProtocolNamed: p name ] ]! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
hasSubject

	^ organizedClass notNil! !

!ClassOrganization methodsFor: 'cleanup' stamp: ''!
cleanUpCategoriesForClass: aClass
	"remove all entries that have no methods"
	 self allMethodSelectors do: [:each | 
		(aClass includesSelector: each) ifFalse: [self removeElement: each ]].! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
removeElement: aSymbol
	| oldProtocol |
	
	oldProtocol := self categoryOfElement: aSymbol.
	self protocolOrganizer removeMethod: aSymbol.
	self notifyOfChangedSelector: aSymbol from: oldProtocol to: (self categoryOfElement: aSymbol).! !

!ClassOrganization methodsFor: 'notifications' stamp: ''!
notifyOfChangedSelector: element from: oldCategory to: newCategory
	(self hasSubject and: [(oldCategory ~= newCategory)]) 
		ifTrue: [
			self subject 
				notifyOfRecategorizedSelector: element 
				from: oldCategory 
				to: newCategory ].! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
removeProtocol: aProtocol
	| oldCategories |
	
	oldCategories := self protocolOrganizer allProtocolsNames copy.
	self protocolOrganizer removeProtocol: aProtocol.
	self notifyOfRemovedCategory: aProtocol name.
	self 
		notifyOfChangedCategoriesFrom: oldCategories 
		to: self protocolOrganizer allProtocolsNames.! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
categoryOfElement: aSelector ifAbsent: aBlock

	^ (self protocolOrganizer protocolsOfSelector: aSelector)
		ifEmpty: [ 
			(organizedClass includesSelector: aSelector)
				ifTrue: [ Protocol unclassified ]
				ifFalse: aBlock ]
		ifNotEmpty: [:col | col first name ]! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
classify: aSymbol under: aProtocolName

	^ self 
		classify: aSymbol
		under: aProtocolName
		suppressIfDefault: true! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
removeProtocolIfEmpty: protocolName
	"The protocol may already have been removed, be non empty or a special protocol which can't be removed, such as 'all'."

	(self protocolNamed: protocolName)
		ifNotNil: [ :protocol | 
			(protocol isEmpty and: [ protocol canBeRemoved ])
				ifTrue: [ self removeProtocol: protocol ] ]! !

!ClassOrganization methodsFor: 'initialization' stamp: ''!
initializeClass: aClass
	self initialize.
	organizedClass := aClass.
	organizedClass selectors do: [ :each | 
		self classify: each under: Protocol unclassified ]! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
setSubject: anObject
	
	organizedClass := anObject! !

!ClassOrganization methodsFor: '*CodeExport' stamp: ''!
stringForFileOut

	^ self protocolOrganizer stringForFileOut! !

!ClassOrganization methodsFor: '*CodeImport' stamp: ''!
changeFromString: aString 
	"Parse the argument, aString, and make this be the receiver's structure."

	| categorySpecs |
	categorySpecs := aString parseLiterals.
	
	"If nothing was scanned and I had no elements before, then default me"
	(categorySpecs isEmpty and: [ self protocolOrganizer protocols isEmpty ])
		ifTrue: [ ^ self protocolOrganizer reset ].

	^ self changeFromCategorySpecs: categorySpecs! !

!ClassOrganization methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	protocolOrganizer := ProtocolOrganizer new.! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
categories
	^ self protocolOrganizer protocolsNames! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
sortCategories
	"Do nothing"! !

!ClassOrganization methodsFor: 'notifications' stamp: ''!
notifyOfChangedCategoryFrom: oldNameOrNil to: newNameOrNil
	(self hasSubject and: [oldNameOrNil ~= newNameOrNil]) 
		ifTrue: [
			SystemAnnouncer uniqueInstance 
				protocolRenamedFrom: oldNameOrNil 
				to: newNameOrNil 
				inClass: self subject.
			SystemAnnouncer uniqueInstance classReorganized: self subject].! !

!ClassOrganization methodsFor: '*CodeExport' stamp: ''!
fileOutCommentOn: aFileStream
	"Copy the class comment to aFileStream."

	self classComment ifNil: [ ^ self ].
	aFileStream
		cr;
		nextChunkPut: self classComment string! !

!ClassOrganization methodsFor: 'testing' stamp: ''!
isEmptyCategoryNamed: categoryName
	^ (self protocolOrganizer protocolNamed: categoryName) isEmpty! !

!ClassOrganization methodsFor: 'notifications' stamp: ''!
notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil
	(self hasSubject and: [ oldCollectionOrNil ~= newCollectionOrNil ]) 
		ifTrue: [ SystemAnnouncer uniqueInstance classReorganized: self subject ].! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
commentSourcePointer: anObject
	commentSourcePointer := anObject! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
comment: aString
	organizedClass comment: aString! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
categoryOfElement: aSelector

	^ self categoryOfElement: aSelector ifAbsent: [ nil ]! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
allProtocols
	^ self protocolOrganizer allProtocols! !

!ClassOrganization methodsFor: 'notifications' stamp: ''!
notifyOfRemovedCategory: protocolName
	
	self hasSubject ifFalse: [ ^ self ].
	
	SystemAnnouncer uniqueInstance 
		protocolRemoved: protocolName 
		inClass: self subject! !

!ClassOrganization methodsFor: 'private' stamp: ''!
silentlyRenameCategory: oldName toBe: newName

	self protocolOrganizer 
		renameProtocol: oldName
		into: newName.! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
allMethodSelectors
	^ protocolOrganizer allMethodSelectors! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
allCategories
	^ self protocolOrganizer allProtocolsNames! !

!ClassOrganization methodsFor: 'notifications' stamp: ''!
notifyOfAddedCategory: protocolName
	
	self hasSubject ifFalse: [ ^ self ].
	
	SystemAnnouncer uniqueInstance 
		protocolAdded: protocolName 
		inClass: self subject! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
commentSourcePointer
	^ commentSourcePointer! !

!ClassOrganization methodsFor: '*CodeExport' stamp: ''!
putCommentOnFile: aFileStream forClass: aClass
	"Store the comment about the class onto file, aFileStream."

	| header |
	self classComment isEmptyOrNil ifTrue:[ ^ self ].

	aFileStream cr; nextPut: $!!.
	header := String streamContents: [:strm | 
			strm nextPutAll: aClass name;
			nextPutAll: ' commentStamp: '.
			self commentStamp storeOn: strm.
			strm nextPutAll: ' prior: '; nextPutAll: '0'].
	aFileStream nextChunkPut: header.
	aClass organization fileOutCommentOn: aFileStream.
	aFileStream cr! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
organizedClass
	^ organizedClass! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
listAtCategoryNamed: aName		
	^ (self protocolOrganizer methodsInProtocolNamed: aName) asArray! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
removeEmptyCategories
	| oldCategories removedProtocols |
	
	oldCategories := self protocolOrganizer allProtocolsNames copy.
	
	removedProtocols := self protocolOrganizer removeEmptyProtocols.	
	removedProtocols do: [ :each |  self notifyOfRemovedCategory: each name ].
	
	self notifyOfChangedCategoriesFrom: oldCategories to: self protocolOrganizer allProtocolsNames.! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
protocolNamed: aString 
	^ self protocolOrganizer 
		protocolNamed: aString 
		ifAbsent: [ nil ]! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
allProtocolsNames
	^ self allProtocols collect: [:each |each name]! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
extensionProtocols 
	^ self protocolOrganizer extensionProtocols.! !

!ClassOrganization methodsFor: '*CodeImport' stamp: ''!
changeFromCategorySpecs: categorySpecs

	"notification"
	self internalChangeFromString: categorySpecs! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
removeCategory: protocolName
	(self protocolOrganizer hasProtocolNamed: protocolName)
		ifFalse: [ ^ self ].
	
	self removeProtocol: (self protocolNamed: protocolName)! !

!ClassOrganization methodsFor: '*CodeImport' stamp: ''!
internalChangeFromString: categorySpecs 
	"Parse the argument, aString, and make this be the receiver's structure."

	protocolOrganizer := ProtocolOrganizer fromSpec: categorySpecs! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
commentStamp

	^ commentSourcePointer
		  ifNil: [ '' ]
		  ifNotNil: [ SourceFiles commentTimeStampAt: commentSourcePointer]! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
addCategory: aString
	| oldCategories |
	
	(self protocolOrganizer hasProtocolNamed: aString)
		ifTrue: [ ^self ].

	oldCategories := self categories copy.
	self protocolOrganizer addProtocolNamed: aString.
	self notifyOfAddedCategory: aString.
	self 
		notifyOfChangedCategoriesFrom: oldCategories 
		to: self categories.! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
categoriesSorted

	^ self protocolOrganizer protocolsSorted! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
addCategory: aProtocolName before: aUselessArgument
	self addCategory: aProtocolName! !

!ClassOrganization methodsFor: 'private' stamp: ''!
protocolOrganizer
	
	^ protocolOrganizer! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
classComment

	^ self comment! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
comment

	^ commentSourcePointer ifNil: [''] ifNotNil: [:ptr | SourceFiles sourceCodeAt: ptr ]! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
renameCategory: oldName toBe: newName
	
	self 
		silentlyRenameCategory: oldName 
		toBe: newName.

	self notifyOfChangedCategoryFrom: oldName to: newName.
	"I need to notify also the selector changes, otherwise RPackage will not notice"
	(self protocolOrganizer protocolNamed: newName) methodSelectors 
		do: [ :each | self notifyOfChangedSelector: each from: oldName to: newName ]! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
classify: selector under: aProtocolName suppressIfDefault: aBoolean
	| oldCategory forceNotify oldProtocols |
	forceNotify := (self protocolOrganizer includesSelector: selector) not.
	oldCategory := self categoryOfElement: selector.
	(forceNotify or: [ oldCategory ~= aProtocolName or: [ aBoolean not or: [ aProtocolName ~= Protocol unclassified ] ] ])
		ifFalse: [ ^ self ].
	oldProtocols := self protocolOrganizer protocolsOfSelector: selector.
	self protocolOrganizer
		classify: selector
		inProtocolNamed: aProtocolName.		
	aBoolean ifTrue: [
		(oldProtocols 
			select: #canBeRemoved)
			do: [:e | self  removeProtocol: e ] ].
	oldCategory ifNotNil: [ self notifyOfChangedSelector: selector from: oldCategory to: aProtocolName ]! !

!ClassOrganization methodsFor: 'backward compatibility' stamp: ''!
subject

	^organizedClass! !

!ClassOrganization methodsFor: 'accessing' stamp: ''!
protocols 
	^ self protocolOrganizer protocols.! !

!ClassOrganization class methodsFor: 'instance creation' stamp: ''!
forClass: aClass
	^ self basicNew
		initializeClass: aClass;
		yourself! !

!ClassOrganizationChunk commentStamp: ''!
I represent the declaration of a class organization in a file.  My contents is the class organization string to import, and the class organizer is the one of the changed class.

Sending me the message #import makes me install the class organization I carry into the class.!
!ClassOrganizationChunk methodsFor: 'accessing' stamp: ''!
description

	^ 'Organization (', behaviorName, ')'! !

!ClassOrganizationChunk methodsFor: 'importing' stamp: ''!
importFor: aRequestor logSource: logSource
	(self existsBehavior)
		ifFalse: [ self error: ('Cannot change organization of unexistent behavior {1}' format: { behaviorName asString } ) ]. 
		
	self targetClass organization changeFromString: contents! !

!ClassOrganizationChunk methodsFor: 'testing' stamp: ''!
isClassOrganizationDeclaration

	^ true! !

!ClassOrganizationChunk methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	^ aVisitor visitClassOrganizationChunk: self! !

!ClassOrganizationChunk class methodsFor: 'instance creation' stamp: ''!
contents: someContents behaviorName: behaviorName isMeta: aBoolean
	^self new
		contents: someContents;
		behaviorName: behaviorName;
		isMeta: aBoolean;
		yourself! !

!ClassOrganizationChunk class methodsFor: 'instance creation' stamp: ''!
contents: someContents organizer: aClassOrganizer 
	^self new
			contents: someContents;
			organizer: aClassOrganizer;
			yourself! !

!ClassOrganizationTest commentStamp: ''!
SUnit tests for class organization!
!ClassOrganizationTest methodsFor: 'running' stamp: ''!
tearDown
	class removeFromSystem.
	super tearDown.! !

!ClassOrganizationTest methodsFor: 'tests' stamp: ''!
testCategories
	| categories |
	
	categories := self organization categories.
	self assert: categories notEmpty.! !

!ClassOrganizationTest methodsFor: 'accessing' stamp: ''!
organization 
	^ organization! !

!ClassOrganizationTest methodsFor: 'tests' stamp: ''!
testListAtCategoryNamed
	| methods |
	methods := self organization listAtCategoryNamed: 'empty'.
	self assertEmpty: methods.

	methods := self organization listAtCategoryNamed: 'one'.
	self assert: methods size equals: 1.
	self assert: methods first equals: #one! !

!ClassOrganizationTest methodsFor: 'tests' stamp: ''!
testRemoveNonExistingProtocol
	self organization removeCategory: 'non-existent'! !

!ClassOrganizationTest methodsFor: 'tests' stamp: ''!
testAddCategory
	
	self organization addCategory: 'test-protocol'.
	
	self assert: (self organization categories includes: 'test-protocol')! !

!ClassOrganizationTest methodsFor: 'running' stamp: ''!
runCase 
	SystemAnnouncer uniqueInstance 
		suspendAllWhile: [ super runCase ]! !

!ClassOrganizationTest methodsFor: 'tests' stamp: ''!
testRemoveCategory
	self assert: self organization categories size equals: 2.
	"just ignore removing of non empty categories" 
	self organization removeCategory: 'one'.
	self assert: self organization categories size equals: 2.
	self organization removeCategory: 'empty'.
	self assert: self organization categories size equals: 1.
	self assert: self organization categories first equals: 'one'! !

!ClassOrganizationTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	
	class := self class classInstaller make: [ :aBuilder | 
		aBuilder name: #ClassForTests;
		package: 'ClassOrganizer-Tests' ].
	
	organization := ClassOrganization forClass: class.
	organization addCategory: 'empty'.
	organization addCategory: 'one'.
	organization classify: #one under: 'one' suppressIfDefault: true.! !

!ClassParentRenamed commentStamp: ''!
This announcement will be emitted when a class or a traits superclass is renamed.

The class definition and structure may be unaffected if just the name of the superclass changes. But tools
showing the class definition or package organizer depending on the changed class definition string/command and 
may need to be updated or track the changes.!
!ClassParentRenamed methodsFor: 'accessing' stamp: ''!
parentOldName
	^ parentOldName! !

!ClassParentRenamed methodsFor: 'accessing' stamp: ''!
parentNewName: anObject
	parentNewName := anObject! !

!ClassParentRenamed methodsFor: 'accessing' stamp: ''!
classAffected
	^ classAffected! !

!ClassParentRenamed methodsFor: 'accessing' stamp: ''!
classAffected: anObject
	classAffected := anObject! !

!ClassParentRenamed methodsFor: 'accessing' stamp: ''!
parentNewName
	^ parentNewName! !

!ClassParentRenamed methodsFor: 'accessing' stamp: ''!
parentOldName: anObject
	parentOldName := anObject! !

!ClassParentRenamed class methodsFor: 'instance creation' stamp: ''!
classParentOf: aClass renamedFrom: oldName to: newName
	^ self new
		parentOldName: oldName;
		parentNewName: newName;
		classAffected: aClass;
		yourself! !

!ClassQueryTest commentStamp: ''!
Unit tests for queries on classes!
!ClassQueryTest methodsFor: 'tests' stamp: ''!
testAllCallsOn

	| calls |
	calls := ClassQueryTest allCallsOn.
	self assert: calls size equals: 1.
	self assert: calls first compiledMethod equals: ClassQueryTest>>#testAllCallsOn! !

!ClassQueryTest methodsFor: 'tests' stamp: ''!
testReferencedClasses
	
	| refs |
	refs := Metaclass referencedClasses.
	self assert: (refs includesAll: { LiteralVariable. String. Class }).
	
	refs := self class referencedClasses.
	self assert: (refs includesAll: { Metaclass. Object. LiteralVariable. String. OrderedCollection. Class. })! !

!ClassQueryTest methodsFor: 'tests' stamp: ''!
testAllCallsOnASymbol

	| set cm |
	set := Object allCallsOn: #shallowCopy.
	cm := (set detect: [ :rgMethod | (rgMethod selector == #copy) and: [rgMethod methodClass = Object]]).
	self assert: (cm literals includes: #shallowCopy)! !

!ClassRecategorized commentStamp: ''!
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: ''!
newCategory: aNewCategory
	newCategory := aNewCategory! !

!ClassRecategorized methodsFor: 'accessing' stamp: ''!
classAffected
	^self classRecategorized! !

!ClassRecategorized methodsFor: 'accessing' stamp: ''!
classRecategorized
	^classRecategorized! !

!ClassRecategorized methodsFor: 'accessing' stamp: ''!
oldCategory: anOldCategory
	oldCategory := anOldCategory! !

!ClassRecategorized methodsFor: 'accessing' stamp: ''!
newCategory 
	^newCategory! !

!ClassRecategorized methodsFor: 'accessing' stamp: ''!
classRecategorized: aClass
	classRecategorized := aClass! !

!ClassRecategorized methodsFor: 'accessing' stamp: ''!
oldCategory
	^oldCategory! !

!ClassRecategorized class methodsFor: 'instance creation' stamp: ''!
class: aClass recategorizedFrom: oldCategory to: newCategory
	^self new
			classRecategorized: aClass;
			oldCategory: oldCategory;
			newCategory: newCategory;
			yourself! !

!ClassRemoved commentStamp: ''!
the announcement will be emitted when removing a class or a trait using:  
	=> removeFromSystem!
!ClassRemoved methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInClass: aClass

	^classRemoved == aClass! !

!ClassRemoved methodsFor: 'accessing' stamp: ''!
classAffected
	^self classRemoved! !

!ClassRemoved methodsFor: 'testing' stamp: ''!
affectsMethodsTaggedWith: tagName
	^classRemoved tagsForMethods includes: tagName! !

!ClassRemoved methodsFor: 'accessing' stamp: ''!
packageAffected
	^ownerPackage! !

!ClassRemoved methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage

	^ownerPackage == aPackage! !

!ClassRemoved methodsFor: 'accessing' stamp: ''!
categoryName: anObject
	
	categoryName := anObject! !

!ClassRemoved methodsFor: 'accessing' stamp: ''!
classRemoved
	
	^ classRemoved! !

!ClassRemoved methodsFor: 'accessing' stamp: ''!
classRemoved: aClass
	
	classRemoved := aClass.
	ownerPackage := aClass package! !

!ClassRemoved methodsFor: 'testing' stamp: ''!
affectsMethod: aMethod
	^classRemoved == aMethod origin! !

!ClassRemoved methodsFor: '*Calypso-SystemQueries' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery
	^true! !

!ClassRemoved methodsFor: 'testing' stamp: ''!
affectsMethods
	"methods are removed together with removed class"
	^true! !

!ClassRemoved methodsFor: 'accessing' stamp: ''!
classTagAffected
	^ownerPackage toTagName: categoryName ! !

!ClassRemoved methodsFor: 'accessing' stamp: ''!
categoryName
	
	^ categoryName! !

!ClassRemoved class methodsFor: 'instance creation' stamp: ''!
class: aClass category: aCategoryName
	^self new
			classRemoved: aClass;
			categoryName: aCategoryName;
			yourself.! !

!ClassRenameFixTest methodsFor: 'tests' stamp: ''!
testRenameClassUsingClass

	self renameClassUsing: [:class :newName | class rename: newName].! !

!ClassRenameFixTest methodsFor: 'running' stamp: ''!
tearDown

	self removeEverythingInSetFromSystem: testsChangeSet.
	ChangeSet newChanges: previousChangeSet.
	ChangeSet removeChangeSet: testsChangeSet.
	previousChangeSet := nil.
	testsChangeSet := nil.
	SystemAnnouncer uniqueInstance unsubscribe: self.
	super tearDown.! !

!ClassRenameFixTest methodsFor: 'running' stamp: ''!
verifyRenameEvent: aRenamedEvent
	| renamedClass |
	renamedClass := aRenamedEvent classRenamed.
	self assert: (testingEnvironment classNamed: newClassName) name equals: newClassName.
	self assert: renamedClass name equals: newClassName! !

!ClassRenameFixTest methodsFor: 'private' stamp: ''!
removeEverythingInSetFromSystem: aChangeSet 

	aChangeSet changedMessageList
		do: [:methodRef | methodRef actualClass removeSelector: methodRef selector].
	aChangeSet changedClasses
		do: [:each | each isMeta
				ifFalse: [each removeFromSystemUnlogged]]! !

!ClassRenameFixTest methodsFor: 'tests' stamp: ''!
renameClassUsing: aBlock
	| createdClass foundClasses |
	originalName := self newUniqueClassName.

	createdClass := self class classInstaller make: [ :aBuilder | 
		aBuilder name: originalName;
		package: 'ClassRenameFix-GeneradClass' ].

	newClassName := self newUniqueClassName.
	aBlock value: createdClass value: newClassName.
	self assert: (testingEnvironment classNamed: originalName) isNil.
	self assert: (testingEnvironment classNamed: newClassName) notNil.
	foundClasses := testingEnvironment organization listAtCategoryNamed: 'ClassRenameFix-GeneradClass'.
	self assert: foundClasses notEmpty.
	self assert: (foundClasses includes: newClassName).
	self assert: createdClass name equals: newClassName! !

!ClassRenameFixTest methodsFor: 'private' stamp: ''!
newUniqueClassName
	"Return a class name that is not used in the system."

	"self new newClassName"

	| baseName newName |
	baseName := 'AutoGeneratedClassForTestingSystemChanges'.
	1 to: 9999
		do: 
			[:number | 
			newName := baseName , number printString.
			(Smalltalk hasClassNamed: newName) ifFalse: [^newName asSymbol]].
	^self 
		error: 'Can no longer find a new and unique class name for the SystemChangeTest !!'! !

!ClassRenameFixTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	previousChangeSet := ChangeSet current.
	testsChangeSet := ChangeSet new.
	ChangeSet newChanges: testsChangeSet.
	SystemAnnouncer uniqueInstance weak
		when: ClassRenamed
		send: #verifyRenameEvent:
		to: self.
	super setUp! !

!ClassRenamed commentStamp: ''!
the announcement 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: ''!
oldName
	^oldName! !

!ClassRenamed methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInClass: aClass

	^classRenamed == aClass! !

!ClassRenamed methodsFor: 'accessing' stamp: ''!
classAffected
	^self classRenamed! !

!ClassRenamed methodsFor: 'testing' stamp: ''!
affectsVariablesOf: aClass
	"Any class has ClassVariables which are visible from both sides: instance side and class 	side.
	That's any class modification can affect variables from both class sides.
	And we do not need to distinguish it"

	aClass instanceSide = classRenamed instanceSide ifTrue: [ ^true ].
	
	^false! !

!ClassRenamed methodsFor: 'testing' stamp: ''!
affectsMethodsTaggedWith: tagName
	^classRenamed tagsForMethods includes: tagName! !

!ClassRenamed methodsFor: 'accessing' stamp: ''!
classRenamed
	
	^ classRenamed! !

!ClassRenamed methodsFor: 'accessing' stamp: ''!
category: anObject
	
	category := anObject! !

!ClassRenamed methodsFor: 'accessing' stamp: ''!
category
	
	^ category! !

!ClassRenamed methodsFor: 'accessing' stamp: ''!
newName
	^newName! !

!ClassRenamed methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage

	^classRenamed package == aPackage! !

!ClassRenamed methodsFor: 'accessing' stamp: ''!
newName: anObject
	
	newName := anObject! !

!ClassRenamed methodsFor: 'accessing' stamp: ''!
packagesAffected
	^ self classAffected packages! !

!ClassRenamed methodsFor: 'accessing' stamp: ''!
oldName: anObject
	
	oldName := anObject! !

!ClassRenamed methodsFor: 'testing' stamp: ''!
affectsMethod: aMethod
	^self classAffected == aMethod origin! !

!ClassRenamed methodsFor: '*Calypso-SystemQueries' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery
	^true! !

!ClassRenamed methodsFor: 'testing' stamp: ''!
affectsMethods
	"methods belong to class which could be represented by tools as part of method"
	^true! !

!ClassRenamed methodsFor: 'accessing' stamp: ''!
classRenamed: anObject
	
	classRenamed := anObject! !

!ClassRenamed class methodsFor: 'instance creation' stamp: ''!
class: aClass category: aCategoryName oldName: anOldClassName newName: aNewClassName
	^self new
			classRenamed: aClass;
			category: aCategoryName;
			oldName: anOldClassName;
			newName: aNewClassName;
			yourself! !

!ClassReorganized commentStamp: ''!
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: '*Calypso-SystemQueries' stamp: ''!
shouldBeConsideredByCalypsoEnvironment
	"this event is actually about protocol rename.
	So we skip it and use explicit ProtocolRenamed event"
	^false! !

!ClassReorganized methodsFor: 'accessing' stamp: ''!
classAffected
	^self classReorganized! !

!ClassReorganized methodsFor: 'accessing' stamp: ''!
classReorganized
	
	^ classReorganized! !

!ClassReorganized methodsFor: 'accessing' stamp: ''!
classReorganized: anObject
	
	classReorganized := anObject! !

!ClassReorganized class methodsFor: 'instance creation' stamp: ''!
class: aClass
	^self new
			classReorganized: aClass;
			yourself! !

!ClassRepackaged commentStamp: ''!
Notify about repackaging of a class!
!ClassRepackaged methodsFor: 'accessing' stamp: ''!
oldPackage: anObject
	
	oldPackage := anObject! !

!ClassRepackaged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInClass: aClass

	^classRepackaged == aClass! !

!ClassRepackaged methodsFor: 'accessing' stamp: ''!
classAffected
	
	^ classRepackaged! !

!ClassRepackaged methodsFor: 'accessing' stamp: ''!
classRepackaged: anObject
	
	classRepackaged := anObject! !

!ClassRepackaged methodsFor: 'testing' stamp: ''!
affectsMethodsTaggedWith: tagName
	^classRepackaged tagsForMethods includes: tagName! !

!ClassRepackaged methodsFor: 'accessing' stamp: ''!
newPackage: anObject
	
	newPackage := anObject! !

!ClassRepackaged methodsFor: 'accessing' stamp: ''!
newPackage
	
	^ newPackage! !

!ClassRepackaged methodsFor: 'accessing' stamp: ''!
oldPackage
	
	^ oldPackage! !

!ClassRepackaged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage

	^oldPackage == aPackage or: [ newPackage == aPackage ]! !

!ClassRepackaged methodsFor: 'accessing' stamp: ''!
packagesAffected
	^{oldPackage. newPackage}! !

!ClassRepackaged methodsFor: 'accessing' stamp: ''!
classRepackaged
	
	^ classRepackaged! !

!ClassRepackaged methodsFor: '*Calypso-SystemQueries' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery

	^true! !

!ClassRepackaged methodsFor: 'testing' stamp: ''!
affectsMethods
	"methods belong to class which could be represented by tools as part of method"
	^true! !

!ClassRepackaged class methodsFor: 'instance creation' stamp: ''!
classRepackaged: aClass oldPackage: oldPackage newPackage: newPackage
	^self new
			classRepackaged: aClass;
			oldPackage: oldPackage;
			newPackage: newPackage;
			yourself.! !

!ClassResolver commentStamp: ''!
I am in charge of resolving the existence of a class!
!ClassResolver methodsFor: 'resolving' stamp: ''!
resolve: aClassName inEnv: anEnvironment
	^ (anEnvironment classNamed: aClassName) ifNil: [ self resolve: aClassName ]! !

!ClassResolver methodsFor: 'resolving' stamp: ''!
resolve: aCDClassDefinitionNode
	^self subclassResponsibility! !

!ClassResolverStrictResolve commentStamp: ''!
My strategy is to raise an error if the class doesn't exist!
!ClassResolverStrictResolve methodsFor: 'resolving' stamp: ''!
resolve: aClassName
	"^Error new:'You''re superclass doesn''t exist'."
	^ self error: 'Superclass ', aClassName,' doesn''t exist'! !

!ClassSessionHandler commentStamp: ''!
I handle a Session for a specific class, providing the API the class should implement.
Handlers will be triggered by the SessionManager.!
!ClassSessionHandler methodsFor: 'accessing' stamp: ''!
registeredClassName: aClassName 
	registeredClassName := aClassName! !

!ClassSessionHandler methodsFor: 'handlers' stamp: ''!
startup: isImageStarting
	self registeredClass startUp: isImageStarting! !

!ClassSessionHandler methodsFor: 'handlers' stamp: ''!
registeredClass
	^ Smalltalk globals at: registeredClassName asSymbol! !

!ClassSessionHandler methodsFor: 'accessing' stamp: ''!
handledId
	^ registeredClassName! !

!ClassSessionHandler methodsFor: 'handlers' stamp: ''!
shutdown: isImageQuitting
	self registeredClass shutDown: isImageQuitting! !

!ClassSessionHandler class methodsFor: 'instance creation' stamp: ''!
forClassNamed: aClassName
	^ self new
		registeredClassName: aClassName;
		yourself! !

!ClassStoredSetting commentStamp: ''!
I am responsible for keeping class name.!
!ClassStoredSetting methodsFor: 'accessing' stamp: ''!
realValue
	^ self class environment at: realValue! !

!ClassTagAdded commentStamp: ''!
I am announced when new class tag is added into package!
!ClassTagAnnouncement commentStamp: ''!
My classes represent class tags modifications on package!
!ClassTagAnnouncement methodsFor: 'accessing' stamp: ''!
packagesAffected
	^{self package}! !

!ClassTagAnnouncement methodsFor: 'testing' stamp: ''!
affectsPackage: aPackage
	^package == aPackage! !

!ClassTagAnnouncement methodsFor: 'accessing' stamp: ''!
tag
	^ tag! !

!ClassTagAnnouncement methodsFor: 'accessing' stamp: ''!
package: anObject
	package := anObject! !

!ClassTagAnnouncement methodsFor: 'testing' stamp: ''!
affectsPackages
	^true! !

!ClassTagAnnouncement methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!ClassTagAnnouncement methodsFor: 'accessing' stamp: ''!
tag: anObject
	tag := anObject! !

!ClassTagAnnouncement class methodsFor: 'instance creation' stamp: ''!
in: aPackage tag: aSymbol
	^self new 
		package: aPackage;
		tag: aSymbol! !

!ClassTagRemoved commentStamp: ''!
I am announced when existing class tag is removed from package!
!ClassTagRenamed commentStamp: ''!
I am announced when existing class tag is removed!
!ClassTagRenamed methodsFor: 'accessing' stamp: ''!
newName
	^ newName! !

!ClassTagRenamed methodsFor: 'accessing' stamp: ''!
newName: anObject
	newName := anObject! !

!ClassTagRenamed class methodsFor: 'instance creation' stamp: ''!
in: aPackage tag: aSymbol to: newTagName

	^(self in: aPackage tag: aSymbol)
		newName: newTagName ! !

!ClassTest commentStamp: ''!
SUnit tests for classes!
!ClassTest methodsFor: 'tests' stamp: ''!
testChangingShapeDoesNotPutNilInMethodsLastLiteralKey
	"Test that when the shape of a class changes, the key of the last literal of the methods is not nil"
	| tutu |
	tutu := testEnvironment 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: 'tests - access' stamp: ''!
testSharedPools
	self assert: Point sharedPools equals: OrderedCollection new.
	self assert: Date sharedPools first equals: ChronologyConstants.
	self assert: Date sharedPools size equals: 1.	"a metaclass does not have shared pools since only classes have shared pools"
	Date class sharedPools.
	self assert: RootClassPoolUser sharedPools size equals: 1.
	self assert: ClassMultiplePoolUser sharedPools size equals: 2.	"has shared pools does not take into account the fact that a superclass may use some shared pools"
	self assertEmpty: SubclassPoolUser sharedPools! !

!ClassTest methodsFor: 'setup' stamp: ''!
deleteClass
	| cl |
	cl := testEnvironment at: className ifAbsent: [ ^ self ].
	
	testingEnvironment at: #ChangeSet ifPresent: [ 
		cl removeFromChanges ].
	
	cl removeFromSystemUnlogged! !

!ClassTest methodsFor: 'tests - file in/out' stamp: ''!
testSuperclassOrder
	|  ordered orderedSuperclasses shuffledSuperclasses |
	orderedSuperclasses := {ProtoObject. Object. Collection. SequenceableCollection}.
	
	"a shuffled collection of superclasses of OrderedCollection"
	shuffledSuperclasses := {Collection. SequenceableCollection. ProtoObject. Object}.
	
	ordered := Class superclassOrder: shuffledSuperclasses.
	
	"should not affect the order as there is no dependencies"
	self assert: ordered equals: orderedSuperclasses asOrderedCollection! !

!ClassTest methodsFor: 'setup' stamp: ''!
categoryNameForTemporaryClasses
	"Answer the category where to classify temporarily created classes"

	^'Dummy-Tests-Class'! !

!ClassTest methodsFor: 'tests - access' stamp: ''!
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: 'tests - class creation' stamp: ''!
unclassifiedCategory
	^#Unclassified! !

!ClassTest methodsFor: 'referencing methods' stamp: ''!
referencingMethod2

	^ {ExampleForTest12. ExampleForTest1}! !

!ClassTest methodsFor: 'tests - access' stamp: ''!
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: 'AnAuthor').
	"a subclass does not have the one of its superclass - but it would be good to change that"
	self deny: (SubclassPoolUser usesLocalPoolVarNamed: 'AnAuthor').! !

!ClassTest methodsFor: 'tests' stamp: ''!
testAddSlot

	| tutu |
	tutu := testEnvironment at: #TUTU.
	tutu addSlot: #x => InstanceVariableSlot.
	self assert: tutu instVarNames equals: #('x').
	self assert: tutu name equals: #TUTU.
	tutu addSlot: #y => InstanceVariableSlot.
	self assert: tutu instVarNames equals: #('x' 'y')! !

!ClassTest methodsFor: 'referencing methods' stamp: ''!
referencingMethod1

	^ ExampleForTest1! !

!ClassTest methodsFor: 'tests - navigation' stamp: ''!
testMethodsReferencingClass
	self assert: (ClassTest methodsReferencingClass: (Smalltalk classNamed: #ExampleForTest111)) equals: {(ClassTest >> #testOrdersACollectionOfClassesBySuperclass)}.
	self
		assert: ((ClassTest methodsReferencingClass: (Smalltalk classNamed: #ExampleForTest1)) sort: [ :a :b | a name <= b name ]) asArray
		equals: {(ClassTest >> #referencingMethod1) . (ClassTest >> #referencingMethod2) . (ClassTest >> #testOrdersACollectionOfClassesBySuperclass)}.
	self assertEmpty: (ClassTest methodsReferencingClass: (Smalltalk classNamed: #BehaviorTest))! !

!ClassTest methodsFor: 'tests - access' stamp: ''!
testAllSharedPools
	self assert: Point allSharedPools equals: OrderedCollection new.
	self assert: Date sharedPools first equals: ChronologyConstants.
	self assert: Date sharedPools size equals: 1.	"a metaclass does not have shared pools since only classes have shared pools"

	self assert: RootClassPoolUser sharedPools size equals: 1.
	self assert: ClassMultiplePoolUser sharedPools size equals: 2.	"has shared pools does not take into account the fact that a superclass may use some shared pools"
	self assertEmpty: SubclassPoolUser sharedPools! !

!ClassTest methodsFor: 'accessing' stamp: ''!
testEnvironment: anObject
	testEnvironment := anObject! !

!ClassTest methodsFor: 'tests' stamp: ''!
testAddSlotAnonymous

	| tutu |
	tutu := Object newAnonymousSubclass.
	self assert: tutu getName isNil.
	tutu := tutu addSlot: #x => InstanceVariableSlot.
	self assert: tutu instVarNames equals: #('x').
	self assert: tutu getName isNil.
	tutu := tutu addSlot: #y => InstanceVariableSlot.
	self assert: tutu getName isNil.
	self assert: tutu instVarNames equals: #('x' 'y')! !

!ClassTest methodsFor: 'tests - class variables' stamp: ''!
testHasClassVarNamed

	self assert: (Object hasClassVarNamed: #DependentsFields).
	self deny: (Object hasClassVarNamed: #CompilerClass)! !

!ClassTest methodsFor: 'tests' stamp: ''!
testCompileAll
	ClassTest compileAll! !

!ClassTest methodsFor: 'test - accessing parallel hierarchy' stamp: ''!
testInstanceSide

	self assert: Point instanceSide equals: Point. 
	self assert: Point class instanceSide equals: Point.! !

!ClassTest methodsFor: 'tests - file in/out' stamp: ''!
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: 'tests - pools' stamp: ''!
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. "

	PoolDefiner initialize.
	SubclassPoolUser compileAll.

	self assert: SubclassPoolUser gloups equals: 42.
	self assert: SubclassPoolUser author equals: 'Ducasse'! !

!ClassTest methodsFor: 'tests - navigation' stamp: ''!
testReferencedClasses
	{(ExceptionTester -> { MyTestNotification. Warning. String. MyResumableTestError. OrderedCollection. MyTestError}). 
	 (CollectionCombinator -> {Array}).
	 (ExecutionEnvironmentStub -> {OrderedCollection}).
	 (ReferencedClassesTestClass -> {Array. OrderedCollection. Object})
	}
		do: [ :assoc | 
			self assert: assoc key referencedClasses notEmpty.
			self assert: (assoc key referencedClasses asSet includesAll: assoc value asSet)].
		
	"classes referenced from class variables should not be seen as referenced statically"
	self assert: (SmalltalkImage class>>#compilerClass ) referencedClasses isEmpty.! !

!ClassTest methodsFor: 'accessing' stamp: ''!
testEnvironment
	^ testEnvironment! !

!ClassTest methodsFor: 'test - accessing parallel hierarchy' stamp: ''!
testIsClassSide

	self deny: Point isClassSide.
	self assert: Point class isClassSide! !

!ClassTest methodsFor: 'tests' stamp: ''!
testCommonSuperclassWith
	self assert: (OrderedCollection commonSuperclassWith: Array) equals: SequenceableCollection.
	self assert: (OrderedCollection commonSuperclassWith: OrderedCollection) equals: SequenceableCollection.
	"if the reveiver is the common superclass, return it"
	self assert: (ProtoObject commonSuperclassWith: Object) equals: ProtoObject.
	"but the other way this is not true"
	self assert: (Object commonSuperclassWith: ProtoObject) equals: nil.
	"as nil is the terminator of the hierarchy, we have to support it"
	self assert: (nil commonSuperclassWith: ProtoObject) equals: nil.! !

!ClassTest methodsFor: 'tests' stamp: ''!
testRemoveClassSlot
	| tutu slot1 slot2 |
	tutu := testEnvironment at: #TUTU.
	slot1 := #X => InstanceVariableSlot.
	slot2 := #Y => InstanceVariableSlot.
	tutu addClassSlot: slot1.
	self assert: tutu class instVarNames equals: #(#X).
	tutu addClassSlot: slot2.
	self assert: tutu class instVarNames equals: #(#X #Y).
	tutu removeClassSlot: slot2.
	self assert: tutu class instVarNames equals: #(#X).
	tutu removeClassSlot: slot1.
	self assert: tutu class instVarNames equals: #().! !

!ClassTest methodsFor: 'tests' stamp: ''!
testHasBindingThatBeginsWith
	self assert: (SmalltalkImage hasBindingThatBeginsWith: 'Compiler').
	self assert: (SmalltalkImage hasBindingThatBeginsWith: 'Object').
	
	"Pools are looked up, too"
	self assert: (TimeZone hasBindingThatBeginsWith: 'DaysInMo').
	
	"CompiledMethodLayout works, too"
	self deny: (CompiledMethod hasBindingThatBeginsWith: 'Compiler').! !

!ClassTest methodsFor: 'tests - navigation' stamp: ''!
testMethodsReferencingClasses

	| collectionOfMethods collectionOfMethodsShouldBe |
	
	collectionOfMethods := ((ClassTest methodsReferencingClasses: {Smalltalk classNamed: #ExampleForTest12. Smalltalk classNamed: #ExampleForTest1}) sort: [ :a :b | a name <= b name]) asArray.
	
	collectionOfMethodsShouldBe := {
		ClassTest>>#referencingMethod1.
		ClassTest>>#referencingMethod2.
		ClassTest>>#testOrdersACollectionOfClassesBySuperclass}.
		
	self assert: collectionOfMethods asSet equals: collectionOfMethodsShouldBe asSet! !

!ClassTest methodsFor: 'tests' stamp: ''!
testClassVariableEntanglement 
	| firstClassName firstClass secondClassName secondClass thirdClassName thirdClass |

	firstClassName := 'MyFirstClass'.

	firstClass := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: firstClassName;
			sharedVariablesFromString: 'MyVar';
			package: self categoryNameForTemporaryClasses ].
		
	[ 

		firstClass class compile: 'myVar
	^ MyVar'.
		firstClass class compile: 'myVar: anObject
	MyVar := anObject'.

		secondClassName := 'MySecondClass'.

		secondClass := self class classInstaller make: [ :aBuilder |
			aBuilder 
				name: secondClassName;
				sharedVariablesFromString: 'MyVar';
				package: self categoryNameForTemporaryClasses ].
			
		[ 

			secondClass class compile: 'myVar
	^ MyVar'.
			secondClass class compile: 'myVar: anObject
		MyVar := anObject'.

			thirdClassName := 'MyThirdClass'.
			thirdClass := secondClass duplicateClassWithNewName: thirdClassName.
			[ 

				self assert: firstClass myVar equals: nil.
				self assert: secondClass myVar equals: nil.
				self assert: thirdClass myVar equals: nil.
	
				firstClass myVar: 123.
				self assert: firstClass myVar equals: 123.
				self assert: secondClass myVar equals: nil.
				self assert: thirdClass myVar equals: nil.

				secondClass myVar: 456.
				self assert: firstClass myVar equals: 123.
				self assert: secondClass myVar equals: 456.
				self assert: thirdClass myVar equals: nil.

				thirdClass myVar: 789.
				self assert: firstClass myVar equals: 123.
				self assert: secondClass myVar equals: 456.
				self assert: thirdClass myVar equals: 789.

			 ] ensure: [ 
				thirdClass 
					removeFromChanges;
					removeFromSystemUnlogged ].
		 ] ensure: [ 
			secondClass 
				removeFromChanges;
				removeFromSystemUnlogged ].
	 ] ensure: [ 
		firstClass 
			removeFromChanges;
			removeFromSystemUnlogged ].! !

!ClassTest methodsFor: 'tests - file in/out' stamp: ''!
testSuperclassOrderPreservingOrder
	| noHierarchicalRelationship ordered |
	"a shuffled collection of direct subclasses of Collection"
	noHierarchicalRelationship := {CharacterSet. WideCharacterSet. OrderedDictionary. DependentsArray. Bag. SmallDictionary. SequenceableCollection. HashedCollection. WeakRegistry. Heap}.
	
	ordered := Class superclassOrder: noHierarchicalRelationship.
	
	"should not affect the order as there is no dependencies"
	self assert: ordered equals: noHierarchicalRelationship asOrderedCollection! !

!ClassTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	className := #TUTU.
	testEnvironment:= Smalltalk globals.
	self deleteClass.
	
	self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: className;
			package: self categoryNameForTemporaryClasses]! !

!ClassTest methodsFor: 'referencing methods' stamp: ''!
referencingMethod3
	"no reference"

	^ self! !

!ClassTest methodsFor: 'tests - access' stamp: ''!
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: 'AnAuthor').
	"a subclass  has  the one of its superclass"
	self assert: (SubclassPoolUser usesPoolVarNamed: 'AnAuthor')! !

!ClassTest methodsFor: 'tests - class creation' stamp: ''!
testNewSubclass
	| cls |
	cls := Point newSubclass.
	self assert: cls isBehavior.
	self assert: cls superclass identicalTo: Point.
	self assert: (Point allSubclasses includes: cls).
	self assert: cls instVarNames equals: #().
	self assert: cls category equals: self unclassifiedCategory.
	self assert: cls classVarNames equals: #().

	cls removeFromSystem! !

!ClassTest methodsFor: 'running' stamp: ''!
tearDown
	self deleteClass.
	{self unclassifiedCategory. self categoryNameForTemporaryClasses} do: [:category|
			RPackage organizer unregisterPackageNamed: category].
	super tearDown! !

!ClassTest methodsFor: 'test - accessing parallel hierarchy' stamp: ''!
testIsInstanceSide

	self assert: Point isInstanceSide.
	self deny: Point class isInstanceSide! !

!ClassTest methodsFor: 'tests - class variables' stamp: ''!
testallClassVariables

	self assert: SmalltalkImage allClassVariables last name equals: #DependentsFields! !

!ClassTest methodsFor: 'tests - class variables' stamp: ''!
testclassVarNames

	self assert: (Object classVarNames includes: #DependentsFields).
	
	"A class and it's meta-class share the class variables"
	self assert: Object classVarNames equals: Object class classVarNames! !

!ClassTest methodsFor: 'tests - pools' stamp: ''!
testPoolVariableAccessibleInClassUser
	"This test shows that a Pool Variable is accessible from the class that declare the Pool usage: here the superclass"

	PoolDefiner initialize.
	RootClassPoolUser compileAll.

	self assert: RootClassPoolUser gloups equals: 42.
	self assert: RootClassPoolUser author equals: 'Ducasse'! !

!ClassTest methodsFor: 'tests - class creation' stamp: ''!
testSubclass
	| cls |
	(testEnvironment includesKey: #SubclassExample) ifTrue: [ (testEnvironment at: #SubclassExample) removeFromSystem ].

	self deny: (testEnvironment includesKey: #SubclassExample).
	cls := self class classInstaller make: [ :aBuilder | aBuilder name: #SubclassExample ].
	
	self assert: (testEnvironment includesKey: #SubclassExample).

	self assert: (testEnvironment at: #SubclassExample) identicalTo: cls.
	self assert: cls category equals: self unclassifiedCategory.
	self assert: cls instVarNames equals: #().

	cls removeFromSystem! !

!ClassTest methodsFor: 'test - accessing parallel hierarchy' stamp: ''!
testClassSide

	self assert: Point classSide equals: Point class. 
	self assert: Point class classSide equals: Point class.! !

!ClassTest methodsFor: 'tests - class variables' stamp: ''!
testclassVariables

	self assert: Object classVariables first name equals: #DependentsFields.
	
	"A class and it's meta-class share the class variables"
	self assert: Object classVariables equals: Object class classVariables! !

!ClassTest methodsFor: 'tests - access' stamp: ''!
testSharedPoolOfVarNamed	

	self assert: (Date sharedPoolOfVarNamed: 'DayNames') equals: 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: 'AnAuthor') equals: PoolDefiner.
	self assert: (RootClassPoolUser sharedPoolOfVarNamed: 'Gloups') equals: PoolDefiner.
	self assert: (SubclassPoolUser sharedPoolOfVarNamed: 'AnAuthor') equals: PoolDefiner.
	
	self assert: (ClassMultiplePoolUser sharedPoolOfVarNamed: 'AnAuthor') equals: PoolDefiner.
	self assert: (ClassMultiplePoolUser sharedPoolOfVarNamed: 'VariableInPoolDefiner2') equals: PoolDefiner2.
	self assert: (ClassMultiplePoolUser sharedPoolOfVarNamed: 'Gloups') equals: PoolDefiner! !

!ClassTest methodsFor: 'tests' stamp: ''!
testAddClassSlot
	| tutu slot1 slot2 |
	tutu := testEnvironment at: #TUTU.
	slot1 := #X => InstanceVariableSlot.
	slot2 := #Y => InstanceVariableSlot.
	tutu addClassSlot: slot1.
	self assert: tutu class instVarNames equals: #(#X).
	tutu addClassSlot: slot2.
	self assert: tutu class instVarNames equals: #(#X #Y)! !

!ClassTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Class! !

!ClassTest methodsFor: 'tests - class creation' stamp: ''!
testSubclassInstanceVariableNames
	| cls |
	(testEnvironment includesKey: #SubclassExample) ifTrue: [ (testEnvironment at: #SubclassExample) removeFromSystem ].

	self deny: (testEnvironment includesKey: #SubclassExample).

	cls := self class classInstaller make: [ :aBuilder | 
		aBuilder 
			name: #SubclassExample;
			slots: 'x y' asSlotCollection].

	self assert: (testEnvironment includesKey: #SubclassExample).

	self assert: (testEnvironment at: #SubclassExample) identicalTo: cls.
	self assert: cls category equals: self unclassifiedCategory.
	self assert: cls instVarNames equals: #('x' 'y').

	cls removeFromSystem! !

!ClassTest methodsFor: 'tests' stamp: ''!
testAddInstVarName

	| tutu |
	tutu := testEnvironment at: #TUTU.
	tutu addInstVarNamed: 'x'.
	self assert: tutu instVarNames equals: #('x').
	tutu addInstVarNamed: 'y'.
	self assert: tutu instVarNames equals: #('x' 'y')! !

!ClassTest methodsFor: 'tests - dependencies' stamp: ''!
testDependencies
	self assert: (self class dependentClasses includes: self class superclass).
	self assert: (self class dependentClasses includes: Date)! !

!ClassTest methodsFor: 'tests - file in/out' stamp: ''!
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).! !

!ClassTestCase commentStamp: ''!
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: ''!
selectorsNotTested

	^ self selectorsToBeTested difference: self selectorsTested
! !

!ClassTestCase methodsFor: 'coverage' stamp: ''!
selectorsTested

	| literals |
	literals := Set new.
	self class selectorsAndMethodsDo: [ :s :m | 
		(s beginsWith: 'test') ifTrue: [ literals addAll: m messages ] ].
	^ literals asArray sort! !

!ClassTestCase methodsFor: '*Manifest-Core' stamp: ''!
targetClassEnvironment
	^RBClassEnvironment class: self targetClass.! !

!ClassTestCase methodsFor: 'utilities' stamp: ''!
repeatedMethodsThatDoNotAccessInstanceVariablesBetween: firstClass and: secondClass

	| repeatedSelectors repeatedMethodsThatDoNotAccessInstanceVariables |	
	repeatedSelectors := firstClass localSelectors intersection: secondClass localSelectors.
	
	repeatedMethodsThatDoNotAccessInstanceVariables := repeatedSelectors select: [ :selector | | m1 m2| 
										 m1 := firstClass>>selector. 
										 m2 := secondClass>>selector.
										((m1 sourceCode = m2 sourceCode) and: [ m1 hasInstVarRef not ]) and: [ m2 hasInstVarRef not ]].
									
	^ repeatedMethodsThatDoNotAccessInstanceVariables! !

!ClassTestCase methodsFor: 'private' stamp: ''!
categoriesForClass: aClass

	^ aClass organization allMethodSelectors collect: [ :each | 
		  aClass organization categoryOfElement: each ]! !

!ClassTestCase methodsFor: '*Manifest-Core' stamp: ''!
assertValidLintRule: aLintRule
	| runner |
	runner := ReSmalllintChecker new.
	runner 
		rule: {aLintRule};
		environment: self targetClassEnvironment;
		run.
	self
		assert: (runner criticsOf: aLintRule) isEmpty
		description: [ aLintRule rationale ]! !

!ClassTestCase methodsFor: 'tests' stamp: ''!
testUnCategorizedMethods

	| uncategorizedMethods |
	uncategorizedMethods := self targetClass selectorsInProtocol:
		                        Protocol unclassified.
	self
		assert: uncategorizedMethods isEmpty
		description: uncategorizedMethods asString! !

!ClassTestCase methodsFor: 'private' stamp: ''!
targetClass

	[ ^ self classToBeTested ]
		on: Error
		do: [ 
			| className |
			className := self class name asString
				             copyFrom: 1
				             to: self class name size - 4.
			^ testingEnvironment at: className asString asSymbol ]! !

!ClassTestCase methodsFor: 'coverage' stamp: ''!
selectorsToBeIgnored

	^ #(  )! !

!ClassTestCase methodsFor: 'utilities' stamp: ''!
differentMethodsWithSameSelectorBetween: firstClass and: secondClass

	| repeatedSelectors differentMethodsWithSameSelector |	
	repeatedSelectors := firstClass localSelectors intersection: secondClass localSelectors.
	
	differentMethodsWithSameSelector := repeatedSelectors select: [ :selector | | m1 m2| 
										 m1 := firstClass>>selector. 
										 m2 := secondClass>>selector.
										 m1 sourceCode ~= m2 sourceCode].
									
	^ differentMethodsWithSameSelector! !

!ClassTestCase methodsFor: '*Refactoring-Critics' stamp: ''!
testTraitExplicitRequirementMethodsMustBeImplementedInTheClassOrInASuperclass

	self assertValidLintRule: ReExplicitRequirementMethodsRule new! !

!ClassTestCase methodsFor: '*Refactoring-Critics' stamp: ''!
testMethodsOfTheClassShouldNotBeRepeatedInItsSuperclasses
		
	self assertValidLintRule: ReEquivalentSuperclassMethodsRule new! !

!ClassTestCase methodsFor: 'coverage' stamp: ''!
selectorsToBeTested

	^ ({ 
		   self classToBeTested.
		   self classToBeTested class } flatCollect: [ :c | c selectors ]) 
		  difference: self selectorsToBeIgnored! !

!ClassTestCase methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ self subclassResponsibility! !

!ClassTestCase methodsFor: 'tests' stamp: ''!
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: ''!
testNew

	self targetClass new! !

!ClassTestCase class methodsFor: 'testing' stamp: ''!
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: ''!
mustTestCoverage

	^ false! !

!ClassTrait commentStamp: ''!
This class used to represent the class side of a trait. 
It is only kept for compatibility.
The Class Traits now are instances of MetaclassForTraits.!
!ClassTrait methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitClassTrait: self
! !

!ClassTraitTest methodsFor: 'tests' stamp: ''!
testUsers
	self assert: self t2 classSide traitUsers size equals: 3.
	self assert: (self t2 classSide traitUsers includesAll: {self t4 classTrait . self t5 classTrait . self t6 classTrait}).
	self assert: self t5 classSide traitUsers size equals: 1.
	self assert: self t5 classSide traitUsers anyOne equals: self c2 class.
	self c2 setTraitComposition: self t1 + self t5.
	self assert: self t5 classSide traitUsers size equals: 1.
	self assert: self t5 classSide traitUsers anyOne equals: self c2 class.
	self c2 setTraitComposition: self t2 asTraitComposition.
	self assertEmpty: self t5 classSide traitUsers! !

!ClassTraitTest methodsFor: 'tests' stamp: ''!
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 equals: 'T1 classTrait + T2 classTrait'.
	self t5 classSide
		setTraitComposition:
			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) equals: 99.
	self assert: (self c2 m2ClassSideAlias2: 13) equals: 13! !

!ClassTraitTest methodsFor: 'tests' stamp: ''!
testIsClassOrTrait

	self 
		assert: TSortable isClassOrTrait;
		assert: Class isClassOrTrait;
		assert: Class class isClassOrTrait;
		deny: Object new isClassOrTrait;
		assert: TSortable classTrait isClassOrTrait.! !

!ClassTraitTest methodsFor: 'tests' stamp: ''!
testChanges
	"Test the most important features to ensure that
	general functionality of class traits are working."

	| classTrait |
	classTrait := self t1 classTrait.
	self deny: (self t5 classSide includesSelector: #m1ClassSide).
	classTrait compile: 'm1ClassSide ^17' classified: 'mycategory'.	"local selectors"
	self assert: (classTrait includesLocalSelector: #m1ClassSide).
	self deny: (classTrait includesLocalSelector: #otherSelector).	"propagation"
	self assert: (self t5 classSide methodDict includesKey: #m1ClassSide).
	self assert: (self c2 class methodDict includesKey: #m1ClassSide).
	self c2 m1ClassSide.
	self assert: self c2 m1ClassSide equals: 17.	"category"
	self assert: (self c2 class organization categoryOfElement: #m1ClassSide) equals: 'mycategory'.	"conflicts"
	self t2 classSide compile: 'm1ClassSide' classified: 'mycategory'.
	self assert: (self c2 class methodDict includesKey: #m1ClassSide).
	self deny: (self c2 class includesLocalSelector: #m1ClassSide).
	self should: [ self c2 m1ClassSide ] raise: Error.	"conflict category"
	self assert: (self c2 class organization categoryOfElement: #m1ClassSide) equals: #mycategory! !

!ClassTraitTest methodsFor: 'tests' stamp: ''!
testInitialization
	| classTrait |
	classTrait := self t1 classTrait.
	self assert: self t1 hasClassSide.
	self assert: self t1 classTrait equals: classTrait.
	self assert: classTrait isClassTrait.
	self assert: classTrait classSide equals: classTrait.
	self deny: classTrait isBaseTrait.
	self assert: classTrait instanceSide equals: self t1.

	"assert classtrait methods are propagated to users when setting traitComposition"
	self assert: self t4 hasClassSide.
	self assert: self t5 hasClassSide.
	self assert: (self t2 classSide includesLocalSelector: #m2ClassSide:).
	self assert: (self t4 classSide includesSelector: #m2ClassSide:).
	self assert: (self t5 classSide includesSelector: #m2ClassSide:).
	self assert: (self c2 m2ClassSide: 17) equals: 17! !

!ClassTreeExample commentStamp: ''!
ClassTreeExample new openOn: Object
!
!ClassTreeExample methodsFor: 'instance creation' stamp: ''!
open
	^ self openOn: Object! !

!ClassTreeExample methodsFor: 'instance creation' stamp: ''!
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: 'user interface' stamp: ''!
treeMorph
	| treeMorph |
	treeMorph := (MorphTreeMorph on: self)
				beMultiple;
				columns: {
					MorphTreeColumn new startWidth: 300; rowMorphGetSelector: #classButton; headerButtonLabel: 'Class' font:  nil.
					MorphTreeColumn new startWidth: 500; rowMorphGetSelector: #commentText; headerButtonLabel: 'Comment' font:  nil
				};
				rowInset: 4;
				treeLineWidth: 1;
				columnInset: 4;
				getMenuSelector: #menu:shifted:;
				rowColorForEven: Color lightGray muchLighter.
	^ treeMorph buildContents! !

!ClassTreeExample methodsFor: 'accessing' stamp: ''!
keyStroke: anEvent from: aTreeMorph 
	self selectedNode
		ifNotNil: [:current | current keyStroke: anEvent from: aTreeMorph]! !

!ClassTreeExample methodsFor: 'accessing' stamp: ''!
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'
			target: self
			selector: #expandAllFromNode:
			argument: current].
	^ menu! !

!ClassTreeExample methodsFor: 'accessing' stamp: ''!
rootNodeClassFromItem: anItem
	^ ClassTreeNodeExample! !

!ClassTreeExample methodsFor: 'accessing' stamp: ''!
rootClass
	^ rootClass ifNil: [rootClass := Object]! !

!ClassTreeExample methodsFor: 'accessing' stamp: ''!
rootClass: aClass
	 rootClass := aClass! !

!ClassTreeExample methodsFor: 'accessing' stamp: ''!
rootItems
	^ OrderedCollection with: self rootClass! !

!ClassTreeExample class methodsFor: 'examples' stamp: ''!
example

	ClassTreeExample new openOn: Object! !

!ClassTreeNodeExample commentStamp: ''!
Example for class tree nodes!
!ClassTreeNodeExample methodsFor: 'menu' stamp: ''!
commentText

	^ (self theme newTextIn: self text: self item comment)
		unlock;
		wrapFlag: true;
		yourself! !

!ClassTreeNodeExample methodsFor: 'accessing' stamp: ''!
exploreItem
	self inspect! !

!ClassTreeNodeExample methodsFor: 'accessing' stamp: ''!
keyStroke: anEvent from: aTreeMorph 
	| c  |
	c := anEvent keyCharacter.
	c = $b
		ifTrue: [self browseItem. ^ true].
	c = $i
		ifTrue: [self inspectItem. ^ true].
	c = $I
		ifTrue: [self exploreItem. ^ true].
	^ false! !

!ClassTreeNodeExample methodsFor: 'menu' stamp: ''!
classButton
	^ (self theme 
			newButtonIn: self
			for: self
			getState: nil
			action: #browseItem
			arguments: {}
			getEnabled: #enabled
			getLabel: nil
			help: 'Open a browser on ' translated , self item name)
				label: (self theme  windowLabelForText: (self item name) , '...');
				yourself! !

!ClassTreeNodeExample methodsFor: 'accessing' stamp: ''!
menu: menu shifted: b 
	menu
		add: 'Browse (b)'
		target: self
		selector: #browseItem.
	menu
		add: 'Inspect (i)'
		target: self
		selector: #inspectItem.
	menu
		add: 'Explore (I)'
		target: self
		selector: #exploreItem.! !

!ClassTreeNodeExample methodsFor: 'menu' stamp: ''!
childrenItems
	^ (self item subclasses asArray sort: [:a :b | a name < b name]) asOrderedCollection! !

!ClassTreeNodeExample methodsFor: 'menu' stamp: ''!
icon
	^ self iconNamed: #smallExpertIcon! !

!ClassTreeNodeExample methodsFor: 'menu' stamp: ''!
contents
	^ contents ifNil: [contents := super contents]! !

!ClassTreeNodeExample methodsFor: 'accessing' stamp: ''!
browseItem
	Smalltalk tools browser openOnClass: self item! !

!ClassTreeNodeExample methodsFor: 'accessing' stamp: ''!
inspectItem
	self inspect! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
methodWithASuperBlock

	^ [ super aSuperMethod: 1 with: 2 ]! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
callingAMethodWithHalt

	self aMethodWithHalt! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
expectedValue

	^ expectedValue! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
methodWithASuperBlockWithoutArguments

	^ [ super yourself ]! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
aMethodWithMNU

	Processor activeProcess suspend.
	self iAmAnMNUMessage.! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
aSuperMethod: anInteger with: anotherInteger

	^ self error! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
aMethodWithHalt

	<haltOrBreakpointForTesting>

	Processor activeProcess suspend.
	self halt.! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
aMethodSuspendedBeforeTheTerminateOfAnotherProcess

	Processor activeProcess suspend.

	aProcess terminate.
	
	expectedValue := 42.! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
aMethodWithMustBeBooleanMNU

	Processor activeProcess suspend.

	^ 2 ifTrue: [ 5 ] ifFalse: [ 7 ]! !

!ClassUsedInInstructionStreamTest methodsFor: 'accessing' stamp: ''!
process: aValue 
	
	aProcess := aValue! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
callingAMethodWithSuspendAndReturnANumber

	^ self aMethodWithSuspendAndReturnANumber! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
aMethodWithSuspendAndReturnANumber

	Processor activeProcess suspend.
	^ 42.! !

!ClassUsedInInstructionStreamTest methodsFor: 'instance creation' stamp: ''!
newMethodWithALotOfLiteralsToTestExtensions

	| anArray |

	anArray := { 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 }.

	Array
		with: 'Those '
		with: 'are'
		with: 'a '
		with: ' lot'
		with: ' of '
		with: ' literals'! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
valueOfBlockWithSupersend

	expectedValue := self methodWithASuperBlock value! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
callingAMethodSuspendedBeforeTheTerminateOfAnotherProcess

	self aMethodSuspendedBeforeTheTerminateOfAnotherProcess! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
callingAMethodWithMNU

	self aMethodWithMNU! !

!ClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
callingAMethodWithMustBeBooleanMNU

	self aMethodWithMustBeBooleanMNU! !

!ClassVariable commentStamp: ''!
I model Class Variables and therefore Pool Variables, too. I am stored as a binding in the classPool of the class defining me.

The compiler forwards bytecode generation to me for accessing the variable.

You can subclass me and implement #read and #write: for creating special kinds of globals that can be used as special class Variables (similar to special Slots).

Note: PoolVariable is not modeled as it's own subclass to allow all special kinds of globals to be used
as pool variables.!
!ClassVariable methodsFor: 'printing' stamp: ''!
definitionString
	"non special globals are defined by the symbol"
	^ self needsFullDefinition
		ifTrue: [ super definitionString ]
		ifFalse: [ self name printString ]! !

!ClassVariable methodsFor: 'testing' stamp: ''!
isReferenced
	^ self possiblyUsingClasses anySatisfy: [ :behavior | behavior hasMethodAccessingVariable: self]! !

!ClassVariable methodsFor: 'accessing' stamp: ''!
owningClass: anObject
	owningClass := anObject! !

!ClassVariable methodsFor: 'accessing' stamp: ''!
definingClass
	"if a Variable is from a Trait is installed in a class, we store the orginal class of the trait here"
	^ definingClass ifNil: [ self owningClass ]! !

!ClassVariable methodsFor: 'testing' stamp: ''!
isClassVariable
	^ true! !

!ClassVariable methodsFor: 'testing' stamp: ''!
isDefinedByOwningClass

	^ self owningClass = self definingClass! !

!ClassVariable methodsFor: '*SystemCommands-VariableCommands' stamp: ''!
createRefactoring: variableRefactoringClass for: declarationClass
	^variableRefactoringClass classVariableAnalog
			variable: self name
			class: declarationClass! !

!ClassVariable methodsFor: 'testing' stamp: ''!
needsFullDefinition
	"only ClassVariable can use a simplified definition"

	^ self class ~= ClassVariable! !

!ClassVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitClassVariableNode: aNode! !

!ClassVariable methodsFor: 'queries' stamp: ''!
possiblyUsingClasses

	| classes |
	classes := self definingClass withAllSubclasses.

	"For pool variables we need to add the poolUsers and it's subclasses"
	self isPoolVariable ifTrue: [ 
		classes addAll:
			(self definingClass poolUsers flatCollect: [ :each | each withAllSubclasses ]) ].

	"we can access from both the class and the metaclass"
	classes addAll: (classes collect: [ :class | class class ]).
	^ classes! !

!ClassVariable methodsFor: 'accessing' stamp: ''!
definingClass: anObject
	definingClass := anObject! !

!ClassVariable methodsFor: 'testing' stamp: ''!
isPoolVariable
	^ self definingClass isPool! !

!ClassVariable methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder

	methodBuilder pushLiteralVariable: self! !

!ClassVariable methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder

	methodBuilder storeIntoLiteralVariable: self.! !

!ClassVariable methodsFor: 'accessing' stamp: ''!
owningClass
	^ owningClass! !

!ClassVariable methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment 

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
			RGClassVariable 
				named: self key asSymbol 
				parent: (self definingClass asRingMinimalDefinitionIn: anRGEnvironment) ]! !

!ClassVariable methodsFor: 'queries' stamp: ''!
usingMethods
	^self possiblyUsingClasses flatCollect: [ :class | class whichMethodsReferTo: self ]! !

!ClassVariableTest commentStamp: ''!
Tests for ClassVariable!
!ClassVariableTest methodsFor: 'tests - properties' stamp: ''!
testPropertyAtPut

	| testValue classVariable |
	
	testValue := Date today.
	classVariable := self class classVariableNamed: #TestVariable.
	
	classVariable propertyAt: #testKeySelector put: testValue.
	self
		assert: (classVariable propertyAt: #testKeySelector)
		equals: testValue.

	TestVariable := 5. "of course changing the var does not change the property"
	
	self
		assert: (classVariable propertyAt: #testKeySelector)
		equals: testValue.
		
	classVariable removeProperty: #testKeySelector.
	self assert: classVariable properties isNil.! !

!ClassVariableTest methodsFor: 'tests' stamp: ''!
testScope
	| variable |
	variable := SmalltalkImage classVariableNamed: #CompilerClass.
	self assert: variable scope equals: SmalltalkImage.
	self assert: (variable scope lookupVar: variable name) equals: variable! !

!ClassVariableTest methodsFor: 'tests' stamp: ''!
testPossiblyUsingClasses
	| variable |

	"this is a normal class var"
	variable := CharacterScanner classVariableNamed: #CompositionStopConditions.

	"it can be accessed from the class and the meta class"
	self assert: (variable possiblyUsingClasses includes: CharacterScanner).
	self assert: (variable possiblyUsingClasses includes: CharacterScanner class).
	"and subclasses"
	self assert: (variable possiblyUsingClasses includes: CompositionScanner).
	self assert: (variable possiblyUsingClasses includes: CompositionScanner class).

	"Pools are more complex"
	variable := TextConstants classVariableNamed: #Basal.
	self assert: variable isPoolVariable.
	"same for pool var: class and meta class of the defining class"
	self assert: (variable possiblyUsingClasses includes: TextConstants).
	self assert: (variable possiblyUsingClasses includes: TextConstants class).
	"but in addition the all the users"
	self assert: (variable possiblyUsingClasses includes: CharacterScanner).
	self assert: (variable possiblyUsingClasses includes: CharacterScanner class).
	"and subclasses"
	self assert: (variable possiblyUsingClasses includes: CompositionScanner).
	self assert: (variable possiblyUsingClasses includes: CompositionScanner class)! !

!ClassVariableTest methodsFor: 'tests' stamp: ''!
testisPoolVariable
	| variable |
	variable := SmalltalkImage classVariableNamed: #CompilerClass.
	self deny: variable isPoolVariable.
	variable := TextConstants classVariableNamed: #Basal.
	self assert: variable isPoolVariable.! !

!ClassVariableTest methodsFor: 'tests - properties' stamp: ''!
testReadingFromContext

	| classVariable |
	TestVariable := #testValue.
	classVariable := self class classVariableNamed: #TestVariable.
	
	self
		assert: (classVariable readInContext: thisContext)
		equals: #testValue! !

!ClassVariableTest methodsFor: 'tests - properties' stamp: ''!
testIsReadInMethod

	DefaultTimeLimit printString. "reading class variable".
	
	self assert: ((TestCase classVariableNamed: #DefaultTimeLimit) isReadIn: self class >> testSelector)! !

!ClassVariableTest methodsFor: 'tests - properties' stamp: ''!
testRemoveProperty
	| classVariable |
	classVariable := self class classVariableNamed: #TestVariable.

	classVariable propertyAt: #testKeySelector put: 1.
	classVariable removeProperty: #testKeySelector.
	self
		assert: (classVariable propertyAt: #testKeySelector)
		equals: nil.
	self assert: classVariable properties isNil.! !

!ClassVariableTest methodsFor: 'tests - properties' stamp: ''!
testNotReadInMethod

	self deny: ((TestCase classVariableNamed: #DefaultTimeLimit) isReadIn: self class >> testSelector)! !

!ClassVariableTest methodsFor: 'tests' stamp: ''!
testIsShadowing
	| variable |
	variable := SmalltalkImage classVariableNamed: #CompilerClass.
	self deny: variable isShadowing
! !

!ClassVariableTest methodsFor: 'tests - properties' stamp: ''!
testIsWrittenInMethod

	DefaultTimeLimit := DefaultTimeLimit. "writing class variable".
	
	self assert: ((TestCase classVariableNamed: #DefaultTimeLimit) isWrittenIn: self class >> testSelector)! !

!ClassVariableTest methodsFor: 'tests' stamp: ''!
testUsingMethods
	| variable |
	"The semantics of where to search is tested as part of #testPossiblyUsingClasses"
	
	variable := CharacterScanner classVariableNamed: #CompositionStopConditions.
	self assert: (variable usingMethods includes: CompositionScanner>>#setStopConditions).
	 
	variable := TextConstants classVariableNamed: #DefaultMarginTabsArray.
	self assert: variable isPoolVariable.
	self assert: (variable usingMethods includes: TextConstants class>>#DefaultMarginTabsArray).
	self assert: (variable usingMethods includes: TextStyle>>#newFontArray:)! !

!ClassVariableTest methodsFor: 'tests - properties' stamp: ''!
testNotWrittenInMethodWhenItIsOnlyRead

	DefaultTimeLimit printString. "reading class variable".
	
	self deny: ((TestCase classVariableNamed: #DefaultTimeLimit) isWrittenIn: self class >> testSelector)! !

!ClassVariableTest methodsFor: 'tests' stamp: ''!
testIsReferenced
	self assert: (SmalltalkImage classVariableNamed: #CompilerClass) isReferenced.
	TestVariable.
	self assert: (self class classVariableNamed: #TestVariable) isReferenced.
	"Check that it works for references to pool vars in the pool defining class"
	self assert: (TestSharedPool classVariableNamed: #One) isReferenced.
	ReferencedInTest.
	self assert: (TestSharedPool classVariableNamed: #ReferencedInTest) isReferenced! !

!ClassVariableTest methodsFor: 'tests - properties' stamp: ''!
testWritingToContext

	| classVariable |
	classVariable := self class classVariableNamed: #TestVariable.
	classVariable write: #testValue inContext: thisContext.
	
	self assert: TestVariable equals: #testValue! !

!ClassWithAnnotationDefinedForUserSuperclass class methodsFor: 'annotations' stamp: ''!
annotationExample
	<classAnnotation>
	
	^ContextualClassAnnotationExample2 for: BaseAnnotationUserExample! !

!ClassWithAnnotationsDefinedForUserClass class methodsFor: 'annotations' stamp: ''!
annotationExample2
	<classAnnotation>
	
	^ContextualClassAnnotationExample1 for: AnnotationUserExample! !

!ClassWithAnnotationsDefinedForUserClass class methodsFor: 'annotations' stamp: ''!
annotationExample1
	<classAnnotation>
	
	^ContextualClassAnnotationExample1 for: AnnotationUserExample! !

!ClassWithBadAnnotatingMethod class methodsFor: 'annotations' stamp: ''!
badAnnotation
	<classAnnotation>
	
	"bad annotation do not return an annotation instance.
	In that case user forgot to return anything. And the result will be class itself"! !

!ClassWithBrokenAnnotatingMethod class methodsFor: 'annotations' stamp: ''!
brokenAnnotation
	<classAnnotation>
	
	self error: self brokenAnnotationMessage! !

!ClassWithBrokenAnnotatingMethod class methodsFor: 'annotations' stamp: ''!
brokenAnnotationMessage
	^'This is example of failed class annotation method'! !

!ClassWithForbiddenAnnotationExample class methodsFor: 'annotations' stamp: ''!
failedForbiddenAnnotation
	<classAnnotation>
	
	^ClassAnnotationExampleWithFailedForbiddenCheck new! !

!ClassWithForbiddenAnnotationExample class methodsFor: 'annotations' stamp: ''!
forbiddenAnnotation
	<classAnnotation>
	
	^ForbiddenClassAnnotationExample new! !

!ClassWithPrioritizedAnnotations class methodsFor: 'annotations' stamp: ''!
annotationWithPriority3
	<classAnnotation>
	
	^ClassAnnotationExampleWithPriority new priority: 15! !

!ClassWithPrioritizedAnnotations class methodsFor: 'annotations' stamp: ''!
annotationWithPriority2
	<classAnnotation>
	
	^ClassAnnotationExampleWithPriority new priority: 20! !

!ClassWithPrioritizedAnnotations class methodsFor: 'annotations' stamp: ''!
annotationWithPriority1
	<classAnnotation>
	
	^ClassAnnotationExampleWithPriority new priority: 10! !

!ClassWithSingleAnnotation class methodsFor: 'annotations' stamp: ''!
annotationExample
	<classAnnotation>
	
	^ClassAnnotationExample3 new! !

!ClassWithThreeAnnotations class methodsFor: 'annotations' stamp: ''!
annotationExample2
	<classAnnotation>
	
	^ClassAnnotationExample1 new! !

!ClassWithThreeAnnotations class methodsFor: 'annotations' stamp: ''!
annotationExample3
	<classAnnotation>
	
	^ClassAnnotationExample2 new! !

!ClassWithThreeAnnotations class methodsFor: 'annotations' stamp: ''!
annotationExample1
	<classAnnotation>
	
	^ClassAnnotationExample1 new! !

!CleanBlockChecker commentStamp: ''!
My job is to scan bytecodes to determine if a block is clean or not.

See #isClean!
!CleanBlockChecker methodsFor: 'instruction decoding' stamp: ''!
methodReturnTop
	isClean := false! !

!CleanBlockChecker methodsFor: 'initialization' stamp: ''!
interpretNextInstructionUsing: aScanner 
	
	isClean := true.
	aScanner interpretNextInstructionFor: self.
	^isClean! !

!CleanBlockChecker methodsFor: 'instruction decoding' stamp: ''!
methodReturnReceiver
	isClean := false! !

!CleanBlockChecker methodsFor: 'validation' stamp: ''!
check: aMethod
	| scanner end |
	
	scanner := InstructionStream on: aMethod.
	end := aMethod endPC.

	[scanner pc <= end] whileTrue: [
		(self interpretNextInstructionUsing: scanner) ifFalse: [^false].
	].
	^true! !

!CleanBlockChecker methodsFor: 'instruction decoding' stamp: ''!
pushReceiver
	isClean := false! !

!CleanBlockChecker methodsFor: 'instruction decoding' stamp: ''!
popIntoReceiverVariable: offset
	isClean := false! !

!CleanBlockChecker methodsFor: 'instruction decoding' stamp: ''!
storeIntoReceiverVariable: offset
	isClean := false! !

!CleanBlockChecker methodsFor: 'instruction decoding' stamp: ''!
methodReturnConstant: offset
	isClean := false! !

!CleanBlockChecker methodsFor: 'instruction decoding' stamp: ''!
pushReceiverVariable: offset
	isClean := false! !

!CleanBlockChecker class methodsFor: 'validation' stamp: ''!
check: aMethod
	^ self new check: aMethod! !

!CleanBlockClosure commentStamp: ''!
Experimental

This is disabled by default.

If you want to experiment, you can enable the #optionCleanBlockClosure compiler option.

In the current system (with that option disabled), blocks are compiled to instances of CompiledBlock.
They are stored as literals and we create/push a FullBlockClosure with a special bytecode.

This bytecode thus creates a FullBock at runtime. 

If a block is clean (does not access self, super, outer temps/args, does not return), we can create the block
at compile time instead. 

CleanBlockClosure is exactly that: a closure created at compile time, it is stored in the literal frame and just
pushed on the stack.

For debugging, it does implement all needed machinary to read temps (via tempNamed:) just like a FullBlockClosure.


Cleanup for later:
- This should not be a subclass of FullBlock (as it does not need the receiver ivar, for example)!
!CleanBlockClosure methodsFor: 'debugger access' stamp: ''!
sender
	" clean blocks do not know the sender"
	^nil! !

!CleanBlockClosure methodsFor: 'accessing' stamp: ''!
refersToLiteral: aLiteral
	^self compiledBlock refersToLiteral: aLiteral! !

!CleanBlockClosure methodsFor: 'accessing' stamp: ''!
sendsAnySelectorOf: aCollection
	^self compiledBlock sendsAnySelectorOf: aCollection! !

!CleanBlockClosure methodsFor: 'scanning' stamp: ''!
readsField: varIndex 
	^self compiledBlock readsField: varIndex! !

!CleanBlockClosure methodsFor: 'scanning' stamp: ''!
writesField: varIndex 
	^self compiledBlock writesField: varIndex! !

!CleanBlockClosure methodsFor: 'accessing' stamp: ''!
outerCode: aCompiledCode
	self compiledBlock outerCode: aCompiledCode! !

!CleanBlockClosure methodsFor: 'scanning' stamp: ''!
readsThisContext
	^self compiledBlock readsThisContext! !

!CleanBlockClosure methodsFor: 'accessing' stamp: ''!
hasLiteralSuchThat: aLiteral
	^self compiledBlock hasLiteralSuchThat: aLiteral! !

!CleanBlockClosure methodsFor: 'scanning' stamp: ''!
readsSelf
	^self compiledBlock readsSelf! !

!CleanBlockClosure methodsFor: 'accessing' stamp: ''!
innerCompiledBlocksDo: aBlock
	^self compiledBlock innerCompiledBlocksDo: aBlock! !

!CleanBlockClosure methodsFor: 'testing' stamp: ''!
isEmbeddedBlock
	^ true! !

!CleanBlockClosure methodsFor: 'printing' stamp: ''!
doPrintOn: aStream

	aStream nextPutAll: self sourceNode value sourceCode! !

!CleanBlockClosure methodsFor: 'accessing' stamp: ''!
literalsEvenTheOnesInTheInnerBlocks
	^self compiledBlock literalsEvenTheOnesInTheInnerBlocks! !

!CleanBlockClosure methodsFor: 'accessing' stamp: ''!
messages 
	^self compiledBlock messages! !

!CleanBlockClosure methodsFor: 'accessing' stamp: ''!
hasLiteral: aLiteral
	^self compiledBlock hasLiteral: aLiteral! !

!CleanBlockClosure methodsFor: 'testing' stamp: ''!
isClean
	^true! !

!CleanBlockClosure methodsFor: 'scanning' stamp: ''!
sendsToSuper
	^self compiledBlock sendsToSuper! !

!CleanBlockClosure methodsFor: 'accessing' stamp: ''!
innerCompiledBlocksAnySatisfy: aBlock
	^self compiledBlock innerCompiledBlocksAnySatisfy: aBlock! !

!Clipboard commentStamp: ''!
I implement the entry point of the clipboard to the system.

One of my instance is used as a default null implementation, storing the copied values in an instance variable.

A real OSWindowClipboard will replace me, but I am still in case something is using the clipboard when there is no real OSWindow.!
!Clipboard methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	contents := '' asText.
	recent := OrderedCollection new! !

!Clipboard methodsFor: 'private' stamp: ''!
noteRecentClipping: text
	"Keep most recent clippings in a queue for pasteRecent (paste... command)"
	text isEmpty ifTrue: [^ self].
	text size > 50000 ifTrue: [^ self].
	(recent includes: text) ifTrue: [^ self].
	recent addFirst: text.
	[recent size > 5] whileTrue: [recent removeLast].! !

!Clipboard methodsFor: 'accessing' stamp: ''!
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: String cr
					    with: '\') copyReplaceAll: String tab with: '|' ])
		  values: recent! !

!Clipboard methodsFor: 'accessing' stamp: ''!
clipboardText: text

	self noteRecentClipping: text asText copyWithoutExternalReferences.
	contents := text asText copyWithoutExternalReferences.! !

!Clipboard methodsFor: 'accessing' stamp: ''!
clipboardText

	^ contents! !

!Clipboard class methodsFor: 'initialization' stamp: ''!
initialize
	self startUp: true.
	SessionManager default 
		registerSystemClassNamed: self name! !

!Clipboard class methodsFor: 'system startup' stamp: ''!
shutDown: isImageQuitting
	"Pharo is shutting down. If this platform requires specific shutdown code, this is a great place to put it."! !

!Clipboard class methodsFor: 'accessing' stamp: ''!
chooseRecentClipping  "Clipboard chooseRecentClipping"
	"Choose by menu from among the recent clippings"
	^self default chooseRecentClipping! !

!Clipboard class methodsFor: 'accessing' stamp: ''!
clipboardText: aText 
	^self default clipboardText: aText! !

!Clipboard class methodsFor: 'accessing' stamp: ''!
default
	^Default ifNil: [Default := self new].! !

!Clipboard class methodsFor: 'accessing' stamp: ''!
clipboardText "Clipboard clipboardText"
	^self default clipboardText.! !

!Clipboard class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting
	"Pharo is starting up. If this platform requires specific initialization, this is a great place to put it."
	isImageStarting
		ifTrue: [Default := nil]! !

!Clipboard class methodsFor: '*Iceberg-TipUI' stamp: ''!
clipboardText: aText informing: aString
	UIManager inform: aString.
	^ self clipboardText: aText! !

!ClippingCanvas commentStamp: ''!
A modified canvas which clips all drawing commands.!
!ClippingCanvas methodsFor: 'testing' stamp: ''!
isShadowDrawing
	^canvas isShadowDrawing! !

!ClippingCanvas methodsFor: 'accessing' stamp: ''!
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: ''!
clipRect
	^clipRect! !

!ClippingCanvas methodsFor: 'private' stamp: ''!
apply: aBlock
	"apply the given block to the inner canvas with clipRect as the clipping rectangle"
	canvas clipBy: clipRect during: aBlock! !

!ClippingCanvas methodsFor: 'accessing' stamp: ''!
form
	^canvas form! !

!ClippingCanvas methodsFor: 'initialization' stamp: ''!
canvas: aCanvas  clipRect: aRectangle
	canvas := aCanvas.
	clipRect := aRectangle.! !

!ClippingCanvas methodsFor: 'accessing' stamp: ''!
shadowColor
	^canvas shadowColor! !

!ClippingCanvas methodsFor: 'testing' stamp: ''!
isBalloonCanvas
	^canvas isBalloonCanvas! !

!ClippingCanvas class methodsFor: 'instance creation' stamp: ''!
canvas: aCanvas  clipRect: aRectangle
	^self new canvas: aCanvas  clipRect: aRectangle! !

!ClyAbstractClassMock commentStamp: ''!
I am example of class with abstract methods!
!ClyAbstractClassMock methodsFor: 'protocol' stamp: ''!
abstractMethod1
	self subclassResponsibility! !

!ClyAbstractClassMock methodsFor: 'protocol' stamp: ''!
overriddenMethod
	^#originalValue! !

!ClyAbstractClassMock methodsFor: 'protocol' stamp: ''!
abstractMethod2
	self subclassResponsibility! !

!ClyAbstractClassScope commentStamp: ''!
I am a root of class scope hierarchy.
From any class scope you are able access classes, methods and variables. 
And my subclasses define what exact objects are accessible.

For example ClyInstanceSideScope can only access instance side methods. While ClyClassSideScope see only class side methods.
Or ClySuperclassScope can access methods of all superclasses of basis classes. 

Class scope instances should be created on set of classes:

	ClyClassScope of: String .
	ClyClassScope ofAll: { String. Array }.

I define accessing interface with following set of methods: 

- classesDo: aBlock 
Each scope should implement visible classes enumeration

- methodsDo: aBlock
Each scope should implement visible methodes enumeration

- instanceVariablesDo: aBlock
It enumerates all instance variables available from visible classes. It is not abstract method. It is based of class enumeration.

- classVariablesDo: aBlock
It enumerates all class variables available from visible classes. It is not abstract method. It is based of class enumeration.

- variablesDo: aBlock
It enumerates all available variables from visible classes. It is not abstract.

- methodGroupsDo: aBlock 
It is special method which collects and enumerates all methods groups available for given class scope using environment plugins. The actual logic of groups colletion is explained in ClyAllMethodGroups comment.

- collectAllClasses

- includesClass: aClass

The methods enumeration is abstract because I do not apply any restriction on the visible meta level of classes.  
So for given class I do not know what methods I can access: instance side or class side, or both. 
It is responsibility of my subclasses to define concrete meta level logic and implement #methodsDo: according to it. 
So to define meta level logic subclasses should implement following methods:

- metaLevelsOf: aClass do: aBlock
It should evaluate given aBlock with all meta levels of given class which are accessible from receiver. For example ClyInstanceSideScope will evaluate aBlock with instance side of aClass. And ClyBothMetaLevelClassScope will evaluate aBlock twice with instance side and class side separately.

- localScopeClass 
It should return one of ClyLocalClassScope subclasses depending on what local scope the receiver represents.

- asLocalClassScope 
It should convert the receiver to it local scope.

- withMetaLevel: aMetaLevelScopeClass
It should convert the receiver to the similar scope but which will represent given meta level. Local scopes are converted completaly to new scope class with this method.

- adoptLocalScopeClassTo: aLocalScopeClass
It should adopt receiver to the given local scope. As opposite to the previous method it supposed to modify receiver.
It is internal method to support #asScope: convertion propertly. Idea that converted class scope should keep receiver local scope if possible. And local scope itself implement this method with empty body.

And I provide several convertion methods whichare used by tools to increase or decrease class and methods visibility:

- asInheritedScope
It return the scope based on receiver basis which provide view on all inherited classes by any definition of inheritance availably in the system. It uses class annotation ClyInheritedScopeProvider to find actual scope class which is responsible to build inheritance scope from receiver. By default it is ClySuperclassScope which includes all superclasses of basis. But with Traits plugin it will be composed scope which includes superclasses and inherited traits. 

- increasedByClassesFrom: aClassScope 
It returned similar scope to receiver but with basis increased by all classes visible from given aClassScope. 
 
- reducedByClassesFrom: aClassScope
It returned similar scope to receiver but with basis reduced by all classes visible from given aClassScope.

- asInterestingClassScope
This methods was introduced specifically to be able restrict ClySuperclassScope by excluding too common superclasses like Object and ProtoObject. For this purpose the ClyInterestingSuperclassScope was implemented. 
This method is also implemented in ClyCompositeScope. So in case when you have full class hierarchy composition scope you are also able restrict it by excluding uninteresting parts like Object.
It is used by browser to enable visibility of all inherited methods accept methods from most common classes like Object and ProtoObject.

Also I implement methods which are used in system changes processing. Queries ask me about various kind of affect which particular event could produce ob objects which are visible from me. Look at methods under tag "system changes".

And to support scoped refactoring my instances can be converted to the refactoring environment:
- asRBEnvironment !
!ClyAbstractClassScope methodsFor: 'queries' stamp: ''!
methodGroupsDo: aBlock
	| dynamicGroups groups |
	dynamicGroups := OrderedCollection new.
	
	self methodGroupProvidersDo: [ :groupProvider |
		groups := groupProvider buildGroupsFrom: self.
		groupProvider isStatic
			ifTrue: [ groups do: aBlock ]
			ifFalse: [ dynamicGroups addAll: groups ]].
		
	self processDynamicMethodGroups: dynamicGroups by: aBlock! !

!ClyAbstractClassScope methodsFor: 'refactoring support' stamp: ''!
asRBEnvironment
	^RBClassEnvironment classes: self collectAllClasses! !

!ClyAbstractClassScope methodsFor: 'private' stamp: ''!
methodGroupProvidersDo: aBlock
	| providers |

	environment pluginsDo: [ :plugin | 
		providers := plugin collectMethodGroupProviders.
		providers do: aBlock ]! !

!ClyAbstractClassScope methodsFor: 'private' stamp: ''!
collectAllClasses
	| classes |
	classes := OrderedCollection new: basisObjects size.
	
	self classesDo: [ :each | classes add: each ].
	
	^classes! !

!ClyAbstractClassScope methodsFor: 'converting' stamp: ''!
asScope: aClassScopeClass

	| newScope |
	newScope := super asScope: aClassScopeClass.
	newScope adoptLocalScopeClassTo: self localScopeClass.
	^newScope! !

!ClyAbstractClassScope methodsFor: 'queries' stamp: ''!
methodsDo: aBlock

	self subclassResponsibility! !

!ClyAbstractClassScope methodsFor: 'meta level' stamp: ''!
metaLevelsOf: aClass do: aBlock
	"Subclasses should decide what class meta level is visible. 
	For example it can be instance side, class side or both"
	
	self subclassResponsibility! !

!ClyAbstractClassScope methodsFor: 'private' stamp: ''!
instanceVariablesOf: definingClass do: aBlock

	| slots |
	self metaLevelsOf: definingClass do: [ :concreteMetaLevelClass |
		"Ugly way to support Pharo7 slots from traits"
		slots := (concreteMetaLevelClass respondsTo: #localSlots) 
			ifTrue: [ concreteMetaLevelClass localSlots]
			ifFalse: [ concreteMetaLevelClass slots ].
		slots do: [:var | 
			aBlock value: (ClyInstanceVariable on: var definedIn: definingClass) ]]! !

!ClyAbstractClassScope methodsFor: 'queries' stamp: ''!
classesDo: aBlock
	self subclassResponsibility! !

!ClyAbstractClassScope methodsFor: 'system changes' stamp: ''!
includesClassesAffectedBy: aSystemAnnouncement

	self classesDo: [ :each | 
		(aSystemAnnouncement affectsClass: each) ifTrue: [ ^true ]].
	^false! !

!ClyAbstractClassScope methodsFor: 'meta level' stamp: ''!
localScopeClass
	self subclassResponsibility! !

!ClyAbstractClassScope methodsFor: 'system changes' stamp: ''!
includesMethodGroupsAffectedBy: aSystemAnnouncement
	self
		methodGroupProvidersDo: [ :each | 
			(each providesGroupsAffectedBy: aSystemAnnouncement inScope: self)
				ifTrue: [ ^ true ] ].
	^ false! !

!ClyAbstractClassScope methodsFor: 'queries' stamp: ''!
instanceVariablesDo: aBlock

	self classesDo: [ :eachClass | 
		self instanceVariablesOf: eachClass do: aBlock]! !

!ClyAbstractClassScope methodsFor: 'queries' stamp: ''!
variablesDo: aBlock

	self classesDo: [ :eachClass | 
		self classVariablesOf: eachClass do: aBlock.
		self instanceVariablesOf: eachClass do: aBlock]! !

!ClyAbstractClassScope methodsFor: 'converting' stamp: ''!
asInterestingClassScope
	^self! !

!ClyAbstractClassScope methodsFor: 'converting' stamp: ''!
withMetaLevel: aMetaLevelScopeClass
	self subclassResponsibility! !

!ClyAbstractClassScope methodsFor: 'private' stamp: ''!
classVariablesOf: definingClass do: aBlock
	"Class variables are visible from any meta level of declaring class.
	But we can retrieve them only from instance side of given class"
	definingClass instanceSide classVariables associationsDo: [:var | 
		aBlock value: (ClyClassVariable on: var definedIn: definingClass instanceSide)]! !

!ClyAbstractClassScope methodsFor: 'converting' stamp: ''!
asInheritingScope
	^ClyInheritedScopeProviderAnnotation createInheritingScopeFrom: self! !

!ClyAbstractClassScope methodsFor: 'system changes' stamp: ''!
includesVariablesAffectedBy: aSystemAnnouncement

	self classesDo: [ :class | 
		(aSystemAnnouncement affectsVariablesOf: class) ifTrue: [^true]].
	
	^false! !

!ClyAbstractClassScope methodsFor: 'converting' stamp: ''!
asInheritedScope
	^ClyInheritedScopeProviderAnnotation createInheritedScopeFrom: self! !

!ClyAbstractClassScope methodsFor: 'converting' stamp: ''!
adoptLocalScopeClassTo: aLocalScopeClass
	self subclassResponsibility! !

!ClyAbstractClassScope methodsFor: 'private' stamp: ''!
processDynamicMethodGroups: dynamicGroups by: aBlock

	| activeGroups |
	activeGroups := OrderedCollection new: dynamicGroups size.
	self methodsDo: [ :eachMethod |
		dynamicGroups do: [ :eachGroup | 
			(eachGroup dependsOnMethod: eachMethod) ifTrue: [ 
				aBlock value: eachGroup.
				activeGroups add: eachGroup]].
		dynamicGroups removeAll: activeGroups.
		dynamicGroups ifEmpty: [ ^self ].
		activeGroups reset].! !

!ClyAbstractClassScope methodsFor: 'converting' stamp: ''!
increasedByClassesFrom: aClassScope

	^self withExtraBasisObjects: aClassScope collectAllClasses! !

!ClyAbstractClassScope methodsFor: 'converting' stamp: ''!
reducedByClassesFrom: aClassScope

	| myClasses classesToExclude |
	myClasses := basisObjects collect: [:each | each instanceSide].
	classesToExclude := aClassScope collectAllClasses collect: [:each | each instanceSide].

	^self withNewBasisObjects: (myClasses copyWithoutAll: classesToExclude)! !

!ClyAbstractClassScope methodsFor: 'printing' stamp: ''!
printBasisObject: aClass on: aStream

	^aStream nextPutAll: aClass name! !

!ClyAbstractClassScope methodsFor: 'testing' stamp: ''!
includesClass: aClass
	
	self classesDo: [ :each | each = aClass ifTrue: [^true]].
	^false! !

!ClyAbstractClassScope methodsFor: 'converting' stamp: ''!
asLocalClassScope
	self subclassResponsibility! !

!ClyAbstractClassScope methodsFor: 'system changes' stamp: ''!
includesMethodsAffectedBy: aSystemAnnouncement

	self classesDo: [ :each | 
		(each includesMethodsAffectedBy: aSystemAnnouncement) ifTrue: [ ^true ]].
	^false! !

!ClyAbstractClassScope methodsFor: 'queries' stamp: ''!
classVariablesDo: aBlock

	self classesDo: [ :eachClass | 
		self classVariablesOf: eachClass do: aBlock]! !

!ClyAbstractClassScope class methodsFor: 'scope names' stamp: ''!
userHierarchyScopeName
	^'user hier'! !

!ClyAbstractClassScope class methodsFor: 'scope names' stamp: ''!
hierarchyScopeName
	^'hier'! !

!ClyAbstractClassScope class methodsFor: 'scope names' stamp: ''!
inheritedScopeName
	^'parents'! !

!ClyAbstractClassScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'classes'! !

!ClyAbstractClassScope class methodsFor: 'scope names' stamp: ''!
inheritingScopeName
	^'children'! !

!ClyAbstractClassScope class methodsFor: 'converting' stamp: ''!
asInterestingClassScope
	^self! !

!ClyAbstractClassScopeTest methodsFor: 'running' stamp: ''!
extraBasisSample 	
	^ClyClass2FromP1Mock! !

!ClyAbstractClassScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToReducedScopeByExtraClassScope

	| convertedScope extraClassScope increasedScope |
	scope := self multipleScopeSample.
	extraClassScope := ClySuperclassScope of: self class in: environment.
	increasedScope := scope increasedByClassesFrom: extraClassScope.
	convertedScope := increasedScope reducedByClassesFrom: extraClassScope.
	
	self assert: convertedScope class equals: scope class.
	self assert: convertedScope basisObjects equals: (scope basisObjects collect: [:each | each instanceSide])! !

!ClyAbstractClassScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToSomeHierarchyScope
	| convertedScope |
	scope := self createSampleScope.
	
	convertedScope := scope asScope: ClySubclassScope.
	
	self assert: convertedScope class equals: ClySubclassScope.
	self assert: convertedScope localScopeClass equals: scope localScopeClass.
	self assert: convertedScope basisObjects equals: scope basisObjects.
	self assert: convertedScope environment equals: environment! !

!ClyAbstractClassScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToInterestingClassScope
	| convertedScope |
	scope := self createSampleScope.
	
	convertedScope := scope asInterestingClassScope.
	
	self assert: convertedScope equals: scope! !

!ClyAbstractClassScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToIncreasedScopeByExtraClassScope
	| convertedScope extraClassScope |
	scope := self singleScopeSample.
	
	extraClassScope := ClySuperclassScope of: self class in: environment.
	convertedScope := scope increasedByClassesFrom: extraClassScope.
	
	self assert: convertedScope class equals: scope class.
	self assert: convertedScope basisObjects equals: scope basisObjects, self class allSuperclasses.! !

!ClyAbstractClassScopeTest methodsFor: 'running' stamp: ''!
singleBasisSample 	
	^ClyClass1FromP1Mock! !

!ClyAbstractClassScopeTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyAbstractClassScopeTest! !

!ClyAbstractClassTableDecorator commentStamp: ''!
I decorate table with special italic font for abstract classes.
I am activated only in browser with installed ClyInheritanceAnalysisBrowserPlugin!
!ClyAbstractClassTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem
	| nameMorph |
		
	nameMorph := anItemCellMorph label.
	nameMorph emphasis: TextEmphasis italic emphasisCode.
	nameMorph color: (nameMorph color contrastingColorAdjustment) contrastingColorAdjustment! !

!ClyAbstractClassTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	^aDataSourceItem isMarkedWith: ClyAbstractItemTag! !

!ClyAbstractClassTableDecorator class methodsFor: 'decoration' stamp: ''!
browserPluginClass
	^ClyInheritanceAnalysisBrowserPlugin! !

!ClyAbstractItemTag commentStamp: ''!
I am used to mark abstract classes and methods!
!ClyAbstractMethodGroupProvider commentStamp: ''!
I provide "abstract" method group which includes all abstract methods of given classes!
!ClyAbstractMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyAbstractMethodsQuery from: aClassScope! !

!ClyAbstractMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'abstract' priority: -10 on: aMethodQuery! !

!ClyAbstractMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyAbstractMethodGroupProvider! !

!ClyAbstractMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup

	^ClyAbstractClassMock! !

!ClyAbstractMethodTableDecorator commentStamp: ''!
I decorate table with special italic font and icon for abstract classes (with #subclassResponsibility inside).
I am activated only in browser with installed ClyInheritanceAnalysisBrowserPlugin!
!ClyAbstractMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem
	| nameMorph |
		
	nameMorph := anItemCellMorph label.
	nameMorph clyAddEmphasis: TextEmphasis italic.
	nameMorph color: (nameMorph color contrastingColorAdjustment) contrastingColorAdjustment! !

!ClyAbstractMethodTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	^aDataSourceItem isMarkedWith: ClyAbstractItemTag! !

!ClyAbstractMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
priority
	^700! !

!ClyAbstractMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	
	anItemCellMorph definitionIcon: #abstractIcon! !

!ClyAbstractMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
browserPluginClass
	^ClyInheritanceAnalysisBrowserPlugin! !

!ClyAbstractMethodsQuery commentStamp: ''!
I return all abstract method from given scope. 
I select such methods using #isAbstract message. So it can be #subclassResponsibility methods or other trait related requirements.!
!ClyAbstractMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^aMethod sendsSelector: #subclassResponsibility! !

!ClyAbstractMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'abstract methods'! !

!ClyAbstractMethodsQueryTest methodsFor: 'tests' stamp: ''!
testSelectsAbstractMethod

	self assert: (query selectsMethod: ClyAbstractClassMock>>#abstractMethod1)! !

!ClyAbstractMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: ClyAbstractClassMock >> #abstractMethod1 in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope of: Object >> #printString in: environment).
	self assert: query checkEmptyResult! !

!ClyAbstractMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyAbstractClassMock >> #abstractMethod1. 
		ClyAbstractClassMock >> #abstractMethod2.
		Object >> #printString}.
	
	self assert: foundSelectors equals: #(abstractMethod1 abstractMethod2)! !

!ClyAbstractMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsNotAbstractMethod
	
	self deny: (query selectsMethod: Object >> #printString)! !

!ClyAbstractMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyAbstractMethodsQuery from: ClyClassScope of: ClyAbstractClassMock in: environment! !

!ClyAbstractNavigationEnvironmentTest methodsFor: 'running' stamp: ''!
setUpEnvironment
	environment := ClyNavigationEnvironment new! !

!ClyAbstractNavigationEnvironmentTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self setUpEnvironment! !

!ClyAbstractNavigationEnvironmentTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyAbstractNavigationEnvironmentTest! !

!ClyAbstractSubclassMock commentStamp: ''!
I am example of abstact class which is subclass of another abstract class.
I define new extra abstract methods!
!ClyAbstractSubclassMock methodsFor: 'protocol' stamp: ''!
abstractMethod1! !

!ClyAbstractSubclassMock methodsFor: 'protocol' stamp: ''!
abstractSubclassMethod
	self subclassResponsibility! !

!ClyAccrossWindowNavigationState commentStamp: ''!
I represent the state of the browser which spawn another browser.
I am recorded as first item in navigation history of spawned browser.
When I am applied to the browser I close it and activate original one using window reference. If window is closed I recreate new browser instance from scratch.
I keep all original browser parameters in my variables including its own navigation history. So recreated browser instances is ready to continue go back in history. 

Notice that I do not keep reference to original browser. I keep reference to window. When window is closing the browser cleans references to it. So closed window do not reference browser.

To create my instance use following expression: 

	ClyAccrossWindowNavigationState from: aBrowser 
	
Internal Representation and Key Implementation Points.

    Instance Variables
	browserPlugins:		<Collection of<ClyBrowserPlugin>>
	browserState:		<ClyBrowserState>
	navigationEnvironment:		<ClyNavigationEnvironment>
	navigationHistory:		<ClyNavigationHistory>
	window:		<SystemWindow>
	windowGroup:		<ClyGroupWindowMorph>!
!ClyAccrossWindowNavigationState methodsFor: 'operations' stamp: ''!
applyTo: aBrowser byUndo: undoExecuting

	(window isInWorld and: [(browserState isCurrentStateOf: window model) not]) 
		ifTrue: [ ^self ].
	
	navigationHistory recordAcrossWindowNavigationFrom: aBrowser byUndo: undoExecuting. 
	undoExecuting ifTrue: [ aBrowser close].	
		
	self restoreBrowserWindow.
	window model focusActiveTab! !

!ClyAccrossWindowNavigationState methodsFor: 'accessing' stamp: ''!
browserState
	^ browserState! !

!ClyAccrossWindowNavigationState methodsFor: 'accessing' stamp: ''!
navigationHistory
	^ navigationHistory! !

!ClyAccrossWindowNavigationState methodsFor: 'accessing' stamp: ''!
browserPlugins
	^ browserPlugins! !

!ClyAccrossWindowNavigationState methodsFor: 'private' stamp: ''!
restoreBrowserWindow
	| newBrowser |
	window isInWorld ifFalse: [ 
		"Closed browser window is always cleaned from browser. Look at ClyBrowser>>windowIsClosing"
		newBrowser := self createBrowser.
		window addMorph: newBrowser frame: (0@0 extent: 1@1).
		window model: newBrowser.
		browserState applyTo: newBrowser].
	windowGroup 
		ifNil: [
			window isInWorld 
				ifTrue: [ window comeToFront; activate]
			 	ifFalse: [window openInWorld ] ]
		ifNotNil: [ 
			windowGroup isInWorld 
				ifTrue: [ windowGroup window comeToFront ]
				ifFalse: [ windowGroup window openInWorld ].
			windowGroup activateWindow: window]! !

!ClyAccrossWindowNavigationState methodsFor: 'operations' stamp: ''!
retrieveStateFrom: aBrowser

	browserState := aBrowser snapshotState.
	(window := aBrowser window) ifNotNil: [
		windowGroup := window ownerThatIsA: GroupWindowMorph].
	browserPlugins := aBrowser plugins collect: [:each | each copy browser: nil].
	navigationEnvironment := aBrowser navigationEnvironment.
	navigationHistory := aBrowser navigationHistory! !

!ClyAccrossWindowNavigationState methodsFor: 'testing' stamp: ''!
representsConcreteQuery
	^true! !

!ClyAccrossWindowNavigationState methodsFor: 'accessing' stamp: ''!
navigationEnvironment: anObject
	navigationEnvironment := anObject! !

!ClyAccrossWindowNavigationState methodsFor: 'accessing' stamp: ''!
browserPlugins: anObject
	browserPlugins := anObject! !

!ClyAccrossWindowNavigationState methodsFor: 'accessing' stamp: ''!
browserState: anObject
	browserState := anObject! !

!ClyAccrossWindowNavigationState methodsFor: 'private' stamp: ''!
createBrowser
	| newBrowser |
	newBrowser := browserState createBrowser.
	
	browserPlugins do: [:each | newBrowser addPlugin: each copy ].
	newBrowser navigationEnvironment: navigationEnvironment.
	newBrowser navigationHistory: navigationHistory.
	browserState restoreStateOf: newBrowser.
	
	^newBrowser! !

!ClyAccrossWindowNavigationState methodsFor: 'accessing' stamp: ''!
navigationEnvironment
	^ navigationEnvironment! !

!ClyAccrossWindowNavigationState methodsFor: 'accessing' stamp: ''!
navigationHistory: anObject
	navigationHistory := anObject! !

!ClyAccrossWindowNavigationState class methodsFor: 'instance creation' stamp: ''!
from: aBrowser
	^self new 
		retrieveStateFrom: aBrowser! !

!ClyAccrossWindowNavigationStateTest methodsFor: 'tests' stamp: ''!
testRetrievesNavigationHistory
	
	self snapshotState.
	
	self assert: navigationState navigationHistory equals: browser navigationHistory! !

!ClyAccrossWindowNavigationStateTest methodsFor: 'running' stamp: ''!
restoreBrowserInstance

	self snapshotState.
	
	browser := navigationState createBrowser! !

!ClyAccrossWindowNavigationStateTest methodsFor: 'tests' stamp: ''!
testCreatesBrowserWithNavigationHistory
	
	self restoreBrowserInstance.
	
	self assert: browser navigationHistory equals: navigationState navigationHistory! !

!ClyAccrossWindowNavigationStateTest methodsFor: 'tests' stamp: ''!
testCreatesBrowserWithPlugins
	browser addPlugin: ClyStandardBrowserPlugin new.

	self restoreBrowserInstance.

	self assert: browser plugins first browser equals: browser.
	self assert: browser plugins first class equals: ClyStandardBrowserPlugin.
	self deny: navigationState browserPlugins first identicalTo: browser plugins first! !

!ClyAccrossWindowNavigationStateTest methodsFor: 'tests' stamp: ''!
testPluginsWithoutBrowser

	browser addPlugin: ClyStandardBrowserPlugin new.
	
	self snapshotState.
	
	self assert: navigationState browserPlugins first browser isNil! !

!ClyAccrossWindowNavigationStateTest methodsFor: 'tests' stamp: ''!
testRetrievesBrowserEnvironment

	self snapshotState.
	
	self assert: navigationState navigationEnvironment equals: environment! !

!ClyAccrossWindowNavigationStateTest methodsFor: 'running' stamp: ''!
snapshotState

	navigationState := ClyAccrossWindowNavigationState from: browser! !

!ClyAccrossWindowNavigationStateTest methodsFor: 'tests' stamp: ''!
testCreatesBrowserWithNavigationEnvironment
	
	self restoreBrowserInstance.
	
	self assert: browser navigationEnvironment equals: environment! !

!ClyAccrossWindowNavigationStateTest methodsFor: 'tests' stamp: ''!
testRetrievesBrowserState

	self snapshotState.
	
	self assert: (navigationState browserState isKindOf: ClyBrowserState )! !

!ClyAccrossWindowNavigationStateTest methodsFor: 'tests' stamp: ''!
testRetrievesPlugins

	browser addPlugin: ClyStandardBrowserPlugin new.
	
	self snapshotState.
	
	self assert: navigationState browserPlugins first class equals: ClyStandardBrowserPlugin! !

!ClyActiveBreakpointsQuery commentStamp: ''!
I return all methods which have installed breakpoints or send the halt message (and friends like haltIf:)!
!ClyActiveBreakpointsQuery methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
decorateResultMethodEditor: aMethodEditor

	aMethodEditor selectAnySelector: #(halt halt: haltIf: haltOnce haltOnCount)! !

!ClyActiveBreakpointsQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."
	
	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^excludesHaltsForTesting = anObject excludesHaltsForTesting.! !

!ClyActiveBreakpointsQuery methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	excludesHaltsForTesting := true.! !

!ClyActiveBreakpointsQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash bitXor: excludesHaltsForTesting hash! !

!ClyActiveBreakpointsQuery methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph label color: Color red.
	anItemCellMorph definitionIcon: #smallDebug! !

!ClyActiveBreakpointsQuery methodsFor: 'accessing' stamp: ''!
excludesHaltsForTesting
	^ excludesHaltsForTesting! !

!ClyActiveBreakpointsQuery methodsFor: 'printing' stamp: ''!
description
	^'Active Breakpoints'! !

!ClyActiveBreakpointsQuery methodsFor: 'accessing' stamp: ''!
excludesHaltsForTesting: anObject
	excludesHaltsForTesting := anObject! !

!ClyActiveBreakpointsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	"If the method does not contain halts or breakpoints, we do not show it"
	(aMethod hasBreakpoint or: [ aMethod containsHalt ]) ifFalse: [ ^false ].
	"If the method contains halts or breakpoints and we are not exclude halts for testing, we show it"
	(self excludesHaltsForTesting) ifFalse: [ ^true. ].
	"If we are excluding methods with halts for testing, we show the method if it has not been marked as containing halts for tests or those that implement halts (e.g. Object>>#halt)"
	^ ((aMethod hasPragmaNamed: #haltOrBreakpointForTesting) 
		or: [(aMethod hasPragmaNamed: #debuggerCompleteToSender)]) not.! !

!ClyActiveBreakpointsQuery class methodsFor: 'instance creation' stamp: ''!
newIncludingHaltsForTesting
	| cab |
	cab := self new.
	cab excludesHaltsForTesting: false.
	^ cab.! !

!ClyActiveBreakpointsQueryTest methodsFor: 'tests' stamp: ''!
testComparison
	self assert: ClyActiveBreakpointsQuery new equals: ClyActiveBreakpointsQuery new.

	self assert: ClyActiveBreakpointsQuery newIncludingHaltsForTesting equals: ClyActiveBreakpointsQuery newIncludingHaltsForTesting.

	self deny: ClyActiveBreakpointsQuery new equals: ClyActiveBreakpointsQuery newIncludingHaltsForTesting! !

!ClyActiveBreakpointsQueryTest methodsFor: 'running' stamp: ''!
tearDown
	installedBreakpoints do: [ :each | each remove ].
	installedBreakpoints removeAll.
	ClyClassWithHaltsMock removeSelector: #methodWithHalts1.
	super tearDown! !

!ClyActiveBreakpointsQueryTest methodsFor: 'tests' stamp: ''!
testDecoratingMethodWithBreakpoint

	| plugin method methodItem |
	plugin := ClyReflectiveEnvironmentPlugin new.
	self installBreakpointInto: (ClyClassWithBreakpointsMock >> #methodWithBreakpoints).
	method := ClyClassWithBreakpointsMock >> #methodWithBreakpoints.
	methodItem := method asCalypsoBrowserItem.
		
	plugin decorateBrowserItem: methodItem ofMethod: method.
	
	self assert: (methodItem isMarkedWith: ClyMethodWithBreakpointTag).
	self deny: (methodItem isMarkedWith: ClyMethodWithHaltTag).! !

!ClyActiveBreakpointsQueryTest methodsFor: 'tests' stamp: ''!
testSelectsMethodWithHalt
	
	self assert: (query selectsMethod: ClyClassWithHaltsMock>>#methodWithHalts1)! !

!ClyActiveBreakpointsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	self installBreakpointInto: (ClyClassWithBreakpointsMock >> #methodWithBreakpoints).
	query scope: (ClyMethodScope 
		of: (ClyClassWithHaltsMock >> #methodWithHalts1) in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyClassWithBreakpointsMock >> #methodWithBreakpoints) in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyClassWithBreakpointsMock >> #methodWithoutBreakpoints) in: environment).
	self assert: query checkEmptyResult! !

!ClyActiveBreakpointsQueryTest methodsFor: 'tests' stamp: ''!
testDecoratingMethodWithHalt

	| plugin method methodItem |
	plugin := ClyReflectiveEnvironmentPlugin new.
	method := ClyClassWithHaltsMock >> #methodWithHalts1.
	methodItem := method asCalypsoBrowserItem.
		
	plugin decorateBrowserItem: methodItem ofMethod: method.
	
	self assert: (methodItem isMarkedWith: ClyMethodWithHaltTag).
	self deny: (methodItem isMarkedWith: ClyMethodWithBreakpointTag)! !

!ClyActiveBreakpointsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethods
	self installBreakpointInto: (ClyClassWithBreakpointsMock >> #methodWithBreakpoints).
	self queryFromScope: ClyMethodScope ofAll: {
		ClyClassWithHaltsMock >> #methodWithHalts1. 
		ClyClassWithBreakpointsMock >> #methodWithBreakpoints.
		ClyClassWithBreakpointsMock >> #methodWithoutBreakpoints}.
	
	self assert: foundSelectors sorted asArray equals: #(#methodWithBreakpoints #methodWithHalts1)! !

!ClyActiveBreakpointsQueryTest methodsFor: 'tests' stamp: ''!
testSelectsMethodWithBreakpoint
	self installBreakpointInto: (ClyClassWithBreakpointsMock >> #methodWithBreakpoints).

	self assert: (query selectsMethod: ClyClassWithBreakpointsMock >> #methodWithBreakpoints)! !

!ClyActiveBreakpointsQueryTest methodsFor: 'running' stamp: ''!
installBreakpointInto: aMethod
	| breakpoint |
	breakpoint := Breakpoint new node: aMethod ast; always.
	installedBreakpoints add: breakpoint.
	breakpoint install! !

!ClyActiveBreakpointsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyActiveBreakpointsQuery from: ClyClassScope of: ClyClassWithHaltsMock in: environment! !

!ClyActiveBreakpointsQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsMethodWithoutBreakpoint
	self installBreakpointInto: (ClyClassWithBreakpointsMock >> #methodWithBreakpoints).

	self deny: (query selectsMethod: ClyClassWithBreakpointsMock >> #methodWithoutBreakpoints)! !

!ClyActiveBreakpointsQueryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	installedBreakpoints := OrderedCollection new.
	ClyClassWithHaltsMock compile: 'methodWithHalts1 self halt'! !

!ClyActivityAnimationIconMorph commentStamp: ''!
I implement rotated icon anomation.
I use TabMorph animation icons (#refreshIcon1, #refreshIcon2, ..) to switch rotating splines at every UI step.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	progress:		<Integer>
	progressIconMorph:		<ImageMorph>!
!ClyActivityAnimationIconMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		changeTableLayout;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		listDirection: #leftToRight;
		cellInset: 2.
	progress := 1.
	progressIconMorph := self currentIcon asMorph.
	self addMorphBack: progressIconMorph.
	self extent: progressIconMorph extent.! !

!ClyActivityAnimationIconMorph methodsFor: 'stepping' stamp: ''!
step
	progress := progress + 1.
	progress > 10 ifTrue: [ progress := 1 ].
	
	progressIconMorph form: self currentIcon! !

!ClyActivityAnimationIconMorph methodsFor: 'initialization' stamp: ''!
addLabel: aStringOrMorph

	self addMorphBack: aStringOrMorph asMorph! !

!ClyActivityAnimationIconMorph methodsFor: 'accessing' stamp: ''!
currentIcon
	^TabMorph perform: (#refreshIcon, progress asString) asSymbol! !

!ClyActivityAnimationIconMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^Color transparent! !

!ClyActivityAnimationIconMorph methodsFor: 'stepping' stamp: ''!
stepTime
	
	^ 100 "milliseconds"! !

!ClyActivityAnimationIconMorph class methodsFor: 'instance creation' stamp: ''!
label: aString
	^self new 
		addLabel: aString;
		yourself! !

!ClyAddBreakpointCommand commentStamp: ''!
I am a base class for commands which add new breakpoints into particular source node.

My subclasses should implement single method: 

- applyBreakpointCondition: aBreakpoint!
!ClyAddBreakpointCommand methodsFor: 'execution' stamp: ''!
execute
	
	| breakpoint |
	breakpoint := Breakpoint new node: sourceNode.
	self applyBreakpointCondition: breakpoint.
	breakpoint install! !

!ClyAddBreakpointCommand methodsFor: 'execution' stamp: ''!
applyBreakpointCondition: aBreakpoint
	self subclassResponsibility! !

!ClyAddBreakpointCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallDebug! !

!ClyAddBreakpointCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aBrowserContext

	^aBrowserContext isSelectedItemHasBreakpoint not! !

!ClyAddBreakpointCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyAddBreakpointCommand! !

!ClyAddBreakpointCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder
	<classAnnotationDependency>
	^1! !

!ClyAddConditionalBreakpointCommand commentStamp: ''!
I am a command to add conditional breakpoint into particular source node..
Condition is configured by block
 
Internal Representation and Key Implementation Points.

    Instance Variables
	conditionBlock:		<BlockClosure>!
!ClyAddConditionalBreakpointCommand methodsFor: 'execution' stamp: ''!
requestConditionBlock
	| script |
	script := 'true'.
	script := UIManager default 
		request: 'This expression will be evaluated in the context of the position of this breakpoint.
		You can use variables, globals, `thisContext`, `self` and `super`.
		`:=` and Pool variables are not supported`'
		initialAnswer: script
		title: 'Break on what condition?'.
	script isEmptyOrNil ifTrue: [ CmdCommandAborted signal ].
	^ self generateConditionBlockFrom: script! !

!ClyAddConditionalBreakpointCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Add Breakpoint condition..'! !

!ClyAddConditionalBreakpointCommand methodsFor: 'execution' stamp: ''!
applyBreakpointCondition: aBreakpoint
	aBreakpoint condition: conditionBlock! !

!ClyAddConditionalBreakpointCommand methodsFor: 'accessing' stamp: ''!
conditionBlock
	^ conditionBlock! !

!ClyAddConditionalBreakpointCommand methodsFor: 'accessing' stamp: ''!
conditionBlock: anObject
	conditionBlock := anObject! !

!ClyAddConditionalBreakpointCommand methodsFor: 'block generation' stamp: ''!
generateConditionBlockFrom: aString
	| conditionBlockProducerMethodAST |
	conditionBlockProducerMethodAST := self conditionBlockProducerMethodAST: aString.

	^ ((conditionBlockProducerMethodAST generateWithSource) valueWithReceiver: nil arguments: {}).! !

!ClyAddConditionalBreakpointCommand methodsFor: 'block generation' stamp: ''!
parserClass
	^ RBParser! !

!ClyAddConditionalBreakpointCommand methodsFor: 'block generation' stamp: ''!
rewriteASTToSimulateExecutionInADifferentContext: anAST
	| semanticallyAnalysedMethodAST allUndeclaredVariableNodes allUndeclaredVariableSymbols rewriter rewrittenConditionBlockProducerAST allMessageNodes receiverSuperclassValueNode intermediateAST analysedIntermediateAST rewriter2 |
	"AnAST is the AST of a method returning a block taking a context as its argument named `ThisContext` and whose body is the condition of this conditional breakpoint.
	The goal is to rewrite this AST so that evaluating the block by passing it a context as argument will evaluate its body as it would have been evaluated in the passed context.
	To do this, we rewrite anAST following these three rules:
	1) Rewriting references to variables named 'ThisContext' into context lookups to avoid conflicts with the 'ThisContext' argument of the block.
	For example, a reference to a variable named ThisContext is rewritten into `ThisContext readVariableNamed: #ThisContext`
	2) Replacing all message nodes whose receiver is super with alternative ast replicating the method lookup a message send to super has.
		For example, 'super foo: 1' is rewritten into 'ThisContext receiver perform: #foo withArguments: 1 inSuperclass: ThisContext receiver class superclass'
	3) Rewriting references to undeclared variables into context lookup
		For example, a reference to a variable named flower is rewritten into `ThisContext readVariableNamed: #flower`
	4) Rewriting references to `thisContext` into references to `ThisContext`
	5) Rewriting references to `self` into references to `ThisContext receiver`"
	rewriter := RBParseTreeRewriter new.
	semanticallyAnalysedMethodAST := anAST doSemanticAnalysis.	"To find which variables are undefined"
	rewriter
		replace: (RBVariableNode named: #ThisContext) name
		with:
			'(ThisContext readVariableNamed: #'
				, (RBVariableNode named: #ThisContext) name , ')'.
	allMessageNodes := semanticallyAnalysedMethodAST allChildren
		select: [ :astElem | astElem isMessage ].
	receiverSuperclassValueNode := self parserClass
		parseExpression: 'ThisContext receiver class superclass'.
	allMessageNodes
		do: [ :msgNode | 
			msgNode receiver isSuperVariable
				ifTrue: [ rewriter
						replaceTree: msgNode
						withTree:
							(RBMessageNode
								receiver: (self parserClass parseExpression: 'ThisContext receiver')
								selector: #perform:withArguments:inSuperclass:
								arguments:
									{(RBLiteralValueNode value: msgNode selector).
									(RBArrayNode statements: msgNode arguments).
									receiverSuperclassValueNode}) ] ].
	intermediateAST := rewriter
		executeTree: semanticallyAnalysedMethodAST;
		tree.
	analysedIntermediateAST := intermediateAST doSemanticAnalysis.
	rewriter2 := RBParseTreeRewriter new.
	allUndeclaredVariableNodes := analysedIntermediateAST allChildren
		select: [ :astElem | astElem isVariable and: [ astElem isUndeclaredVariable ] ].
	allUndeclaredVariableSymbols := (allUndeclaredVariableNodes
		collect: [ :varNode | varNode name ]) asSet asArray.
	allUndeclaredVariableSymbols
		withIndexDo: [ :tempName :index | 
			rewriter2
				replace: tempName
				with: '(ThisContext readVariableNamed: #' , tempName , ')' ].
	rewriter2 replace: 'thisContext' with: 'ThisContext'.
	rewriter2 replace: 'self' with: 'ThisContext receiver'.
	rewrittenConditionBlockProducerAST := rewriter2
		executeTree: analysedIntermediateAST;
		tree.
	^ rewrittenConditionBlockProducerAST doSemanticAnalysis! !

!ClyAddConditionalBreakpointCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aBrowserContext
	super prepareFullExecutionInContext: aBrowserContext.
	
	conditionBlock := self requestConditionBlock! !

!ClyAddConditionalBreakpointCommand methodsFor: 'block generation' stamp: ''!
conditionBlockProducerMethodAST: conditionString
	| conditionBlockProducerMethodAST conditionAST |
	conditionAST := self parserClass parseExpression: conditionString.
	conditionBlockProducerMethodAST := RBMethodNode
		selector: #conditionBlockGenerator
		body:
			(RBReturnNode
				value:
					(RBBlockNode
						arguments: {(RBVariableNode named: 'ThisContext')}
						body:
							(RBMessageNode
								receiver: (RBVariableNode named: 'Breakpoint')
								selector: #checkBreakConditionValue:
								arguments: {conditionAST}) asSequenceNode)) asSequenceNode.
	conditionBlockProducerMethodAST := self
		rewriteASTToSimulateExecutionInADifferentContext: conditionBlockProducerMethodAST.
	conditionBlockProducerMethodAST
		source: conditionBlockProducerMethodAST formattedCode.
	"The following commented code is a failed attempt at adding a comment to the conditionBlockProducerMethod source code, saying that it is autogenerated and that modifying it is pointless."
	"conditionBlockProducerMethodAST comments: {RBComment with: 'Auto generated' at: (conditionBlockProducerMethodAST selector size)}."
	"Setting a source code for the AST, so that inspecting it, for example after an exception occured, works."
	^ conditionBlockProducerMethodAST! !

!ClyAddConditionalBreakpointCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder
	^1.2! !

!ClyAddConditionalBreakpointCommandTest methodsFor: 'tests' stamp: ''!
testthisContext_conditionBlockProducerMethodAST
	self
		assert:
			(ClyAddConditionalBreakpointCommand new
				conditionBlockProducerMethodAST: 'thisContext')
		equals:
			(self parserClass
				parseMethod:
					'conditionBlockGenerator ^[ :ThisContext | Breakpoint checkBreakConditionValue: ThisContext ]')! !

!ClyAddConditionalBreakpointCommandTest methodsFor: 'tests' stamp: ''!
testSimpleCondition_conditionBlockProducerMethodAST
	self
		assert:
			(ClyAddConditionalBreakpointCommand new
				conditionBlockProducerMethodAST: 'true')
		equals:
			(self parserClass
				parseMethod:
					'conditionBlockGenerator ^[ :ThisContext | Breakpoint checkBreakConditionValue: true ]')! !

!ClyAddConditionalBreakpointCommandTest methodsFor: 'tests' stamp: ''!
testSuperSendNoArg_conditionBlockProducerMethodAST
	self
		assert:
			(ClyAddConditionalBreakpointCommand new
				conditionBlockProducerMethodAST: 'super msg')
		equals:
			(self parserClass
				parseMethod:
					'conditionBlockGenerator ^[ :ThisContext | Breakpoint checkBreakConditionValue: (ThisContext receiver perform: #msg withArguments: {} inSuperclass: ThisContext receiver class superclass)]')! !

!ClyAddConditionalBreakpointCommandTest methodsFor: 'tests' stamp: ''!
testSuperSendWithArgs_conditionBlockProducerMethodAST
	self
		assert:
			(ClyAddConditionalBreakpointCommand new
				conditionBlockProducerMethodAST: 'super foo: arg1 bar: arg2')
		equals:
			(self parserClass
				parseMethod:
					'conditionBlockGenerator ^[ :ThisContext | Breakpoint checkBreakConditionValue: (ThisContext receiver perform: #foo:bar: withArguments: {ThisContext readVariableNamed: #arg1. ThisContext readVariableNamed: #arg2.} inSuperclass: ThisContext receiver class superclass)]')! !

!ClyAddConditionalBreakpointCommandTest methodsFor: 'tests' stamp: ''!
testVariableLookup_conditionBlockProducerMethodAST
	self
		assert:
			(ClyAddConditionalBreakpointCommand new
				conditionBlockProducerMethodAST: 'var')
		equals:
			(self parserClass
				parseMethod:
					'conditionBlockGenerator ^[ :ThisContext | Breakpoint checkBreakConditionValue: (ThisContext readVariableNamed: #var)]')! !

!ClyAddConditionalBreakpointCommandTest methodsFor: 'tests' stamp: ''!
testSelf_conditionBlockProducerMethodAST
	self
		assert:
			(ClyAddConditionalBreakpointCommand new
				conditionBlockProducerMethodAST: 'self')
		equals:
			(self parserClass
				parseMethod:
					'conditionBlockGenerator ^[ :ThisContext | Breakpoint checkBreakConditionValue: ThisContext receiver ]')! !

!ClyAddConditionalBreakpointCommandTest methodsFor: 'tests' stamp: ''!
testMessageSend_conditionBlockProducerMethodAST
	self
		assert:
			(ClyAddConditionalBreakpointCommand new
				conditionBlockProducerMethodAST: 'val msg: arg')
		equals:
			(self parserClass
				parseMethod:
					'conditionBlockGenerator ^[ :ThisContext | Breakpoint checkBreakConditionValue: ((ThisContext readVariableNamed: #val) msg: (ThisContext readVariableNamed: #arg))]')! !

!ClyAddConditionalBreakpointCommandTest methodsFor: 'tests' stamp: ''!
parserClass
	^ RBParser! !

!ClyAddConditionalBreakpointCommandTest methodsFor: 'tests' stamp: ''!
testVariableNamedThisContext_conditionBlockProducerMethodAST
	self
		assert:
			(ClyAddConditionalBreakpointCommand new
				conditionBlockProducerMethodAST: 'ThisContext')
		equals:
			(self parserClass
				parseMethod:
					'conditionBlockGenerator ^[ :ThisContext | Breakpoint checkBreakConditionValue: (ThisContext readVariableNamed: #ThisContext)]')! !

!ClyAddExecutionCounterCommand commentStamp: ''!
I am a command to install execution counter into given method or source node!
!ClyAddExecutionCounterCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Add Counter'! !

!ClyAddExecutionCounterCommand methodsFor: 'execution' stamp: ''!
execute
	
	ExecutionCounter installOn: sourceNode! !

!ClyAddExecutionCounterCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#classIcon! !

!ClyAddExecutionCounterCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aBrowserContext

	^aBrowserContext isSelectedItemHasExecutionCounter not! !

!ClyAddExecutionCounterCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder
	^2! !

!ClyAddOnceBreakpointCommand commentStamp: ''!
I am a command to add once breakpoint into particular source node.!
!ClyAddOnceBreakpointCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Add Breakpoint once'! !

!ClyAddOnceBreakpointCommand methodsFor: 'execution' stamp: ''!
applyBreakpointCondition: aBreakpoint
	aBreakpoint once! !

!ClyAddStaticBreakpointCommand commentStamp: ''!
I am a command to add static breakpoint into particular source node.!
!ClyAddStaticBreakpointCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Add Breakpoint'! !

!ClyAddStaticBreakpointCommand methodsFor: 'execution' stamp: ''!
applyBreakpointCondition: aBreakpoint
	aBreakpoint always! !

!ClyAddStaticBreakpointCommand class methodsFor: 'activation' stamp: ''!
methodEditorLeftBarClickActivation
	<classAnnotation>
	
	^CmdTextLeftBarClickActivation for: ClyMethodSourceCodeContext! !

!ClyAddWatchCommand commentStamp: ''!
I am a command to install watchpoint into the given method or source node!
!ClyAddWatchCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Add Watchpoint'! !

!ClyAddWatchCommand methodsFor: 'execution' stamp: ''!
execute
	
	Watch in: sourceNode! !

!ClyAddWatchCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#haloView! !

!ClyAddWatchCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aBrowserContext

	^aBrowserContext isSelectedItemHasWatch not! !

!ClyAddWatchCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder
	^3! !

!ClyAllBasisCritiqueQuery commentStamp: ''!
I return all critiques directly from basis objects of my scope.
So I am a kind of universal query because I do not restrict scopes for information which they provide.
I just ask scope basis objects for critiques!
!ClyAllBasisCritiqueQuery methodsFor: 'execution' stamp: ''!
analyzedObjectsDo: aBlock
	scope basisObjects do: aBlock! !

!ClyAllBasisCritiqueQuery methodsFor: 'printing' stamp: ''!
description

	^'critiques of scope basis'! !

!ClyAllBasisCritiquesTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
		
	query scope: self scopeWithCritiques.
	self deny: query checkEmptyResult.
	
	query scope: self scopeWithoutCritiques.
	self assert: query checkEmptyResult.! !

!ClyAllBasisCritiquesTest methodsFor: 'tests' stamp: ''!
testExecution
	
	self executeQuery.
	
	self assert: resultItems size equals: 1! !

!ClyAllBasisCritiquesTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyAllBasisCritiqueQuery from: self scopeWithCritiques! !

!ClyAllClassGroupsQuery commentStamp: ''!
I am a query of all class groups from given scope.

Scope should support #classGroupsDo:. 
Currently it is only ClyPackageScope.

The scope delegates class group building to the environment plugins.
It asks each plugin to collect class group providers using: 

	plugin collectClassGroupProviders 

And then each provider creates set of class groups using method: 

	groupProvider classGroupsIn: aPackageScope do: aBlockWithGroup
	
Look at ClyClassGroupProvider for details!
!ClyAllClassGroupsQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin
	anEnvironmentPlugin collectMetadataOfClassGroups: aQueryResult! !

!ClyAllClassGroupsQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	^scope includesClassGroupsAffectedBy: aSystemAnnouncement! !

!ClyAllClassGroupsQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult 

	| groups |
	groups := OrderedCollection new.
	
	scope classGroupsDo: [ :each | groups add: each].
	
	aQueryResult fillWith: groups! !

!ClyAllClassGroupsQuery methodsFor: 'printing' stamp: ''!
description

	^'all class groups'! !

!ClyAllClassGroupsQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	scope classGroupsDo: [ :each | ^false].
	
	^true! !

!ClyAllClassGroupsQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	^ClyClassGroup! !

!ClyAllClassGroupsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	| scope |
	scope := ClyPackageScope of: ClyClass7WithTag1FromP5Mock package in: environment.
	query scope: scope.
	self deny: query checkEmptyResult.
	
	scope := ClyPackageScope of: ClySubclassMOfClass1FromP2Mock package in: environment.
	query scope: scope.
	self assert: query checkEmptyResult! !

!ClyAllClassGroupsQueryTest methodsFor: 'tests' stamp: ''!
testFromSinglePackage

	self queryFromScope: ClyPackageScope of: ClyClass7WithTag1FromP5Mock package.
	
	self assert: (resultItems collect: #class as: Set) equals: { ClyNoTagClassGroup. ClyTaggedClassGroup. ClyClassGroup} asSet.
	self 
		assert: (resultItems select:[:each | each class = ClyTaggedClassGroup] thenCollect: #tag) asSet
		equals: ClyClass7WithTag1FromP5Mock package tagsForClasses asSet! !

!ClyAllClassGroupsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyAllClassGroupsQuery from: ClyPackageScope of: Object package in: environment! !

!ClyAllClassGroupsQueryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	environment addPlugin: ClyDefaultSystemEnvironmentPlugin new! !

!ClyAllClassVariablesQuery commentStamp: ''!
I return all class variables from given scope.

Scope should support #classVariablesDo:.
Now only class scopes support it.!
!ClyAllClassVariablesQuery methodsFor: 'testing' stamp: ''!
retrievesItem: aVariable
	^aVariable isKindOf: ClyClassVariable! !

!ClyAllClassVariablesQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult

	| vars |
	vars := OrderedCollection new.
	
	scope classVariablesDo: [ :each | vars add: each ].
	
	aQueryResult fillWith: vars! !

!ClyAllClassVariablesQuery methodsFor: 'printing' stamp: ''!
description

	^'class variables'! !

!ClyAllClassVariablesQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	scope classVariablesDo: [ :each | ^false ].
	
	^true! !

!ClyAllClassVariablesQueryTest methodsFor: 'tests' stamp: ''!
testFromSingleClass

	| varNames |
	self queryFromScope: ClyClassScope of: ClyClass2FromP1Mock.
	
	varNames := resultItems collect: #name as: Set.
	self assert: varNames equals: (ClyClass2FromP1Mock classVariables collect: #name as: Set)! !

!ClyAllClassVariablesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyClassScope of: ClyClass2FromP1Mock in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyClassScope of: ProtoObject in: environment).
	self assert: query checkEmptyResult! !

!ClyAllClassVariablesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyAllClassVariablesQuery from: ClyClassScope of: ClyClass2FromP1Mock in: environment! !

!ClyAllClassesQuery commentStamp: ''!
I am a query of all classes from given scope!
!ClyAllClassesQuery methodsFor: 'testing' stamp: ''!
selectsClass: aClass
	^true! !

!ClyAllClassesQuery methodsFor: 'printing' stamp: ''!
description

	^'all classes'! !

!ClyAllClassesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyClassScope of: ClyClass1FromP1Mock in: environment).
	
	self deny: query checkEmptyResult! !

!ClyAllClassesQueryTest methodsFor: 'tests' stamp: ''!
testFromSinglePackage

	self queryFromScope: ClyPackageScope of: ClyClass1FromP1Mock package.

	self assert: resultItems asSet equals: ClyClass1FromP1Mock package definedClasses.
	self deny: (resultItems includes: ClySubclassLOfClass0FromPExtendedByP1Mock)! !

!ClyAllClassesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyAllClassesQuery from: ClyClassScope of: Object in: environment! !

!ClyAllCritiqueQuery commentStamp: ''!
I am abstract critique query which subclasses are supposed to return all critiques abailable from scope.
It is possible to retrieve critiques differently from objects which are visible from scope.
My subclasses define concrete way but all of them return all critiques without any extra condition.
They should implement method: 

- analyzedObjectsDo: aBlock!
!ClyAllCritiqueQuery methodsFor: 'execution' stamp: ''!
analyzedObjectsDo: aBlock
	self subclassResponsibility! !

!ClyAllCritiqueQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
		
	| result |
	result := OrderedCollection new.
	
	self analyzedObjectsDo: [ :each | result addAll: each critiques].

	aQueryResult fillWith: result! !

!ClyAllCritiqueQuery methodsFor: 'printing' stamp: ''!
description

	^'all critiques'! !

!ClyAllCritiqueQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	
	self analyzedObjectsDo: [ :each | 
		each critiques ifNotEmpty: [ ^false ] ].
	
	^true! !

!ClyAllCritiquesMethodGroup commentStamp: ''!
I am a method group which include all methods with critiques.

Also I am expanded to critique groups allowing user filter methods by particular severity level of problem.

I am based on async method query. And in the browser I am animated to indicate query background processing!
!ClyAllCritiquesMethodGroup methodsFor: 'accessing' stamp: ''!
loadAsyncQueryResult
	"Here method query is based on actual critiques query. 
	And each subgroup method query is also based on it. 
	So we need to hold reference to based critue query result instead of method query"
	^methodQuery loadCritiquesAsync! !

!ClyAllCritiquesMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethods: aMethodQuery from: aClassScope
	| subgroupsQuery |
	subgroupsQuery := ClyAllMethodCritiqueQuery 
		from: aClassScope as: ClyGroupedCritiqueResult new.
	
	^self named: 'critiques' priority: 8.5 on: aMethodQuery withSubgroupsFrom: subgroupsQuery! !

!ClyAllExtensionMethodsQuery commentStamp: ''!
I return only extension methods.!
!ClyAllExtensionMethodsQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	^aSystemAnnouncement affectsClassExtension
		and: [ scope includesMethodsAffectedBy: aSystemAnnouncement]! !

!ClyAllExtensionMethodsQuery methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph definitionIcon: #protocolExtensionIcon! !

!ClyAllExtensionMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^aMethod isExtension! !

!ClyAllExtensionMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'extension methods'! !

!ClyAllExtensionMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: (ClySubclassLOfClass0FromPExtendedByP1Mock>>#extensionMethodFromSubclassL)
		in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope of: (ClyClass1FromP1Mock >> #tag1Method1) in: environment).
	self assert: query checkEmptyResult! !

!ClyAllExtensionMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyClass1FromP1Mock >> #tag1Method1. Object >> #printString. 
		ClySubclassLOfClass0FromPExtendedByP1Mock >> #extensionMethodFromSubclassL}.
	
	self assert: foundSelectors equals: #(#extensionMethodFromSubclassL)! !

!ClyAllExtensionMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyAllExtensionMethodsQuery from: ClyClassScope of: Object in: environment! !

!ClyAllInstanceVariablesQuery commentStamp: ''!
I return all instance variables from given scope.

Scope should support #instanceVariablesDo:.
Now only class scopes support it.!
!ClyAllInstanceVariablesQuery methodsFor: 'testing' stamp: ''!
retrievesItem: aVariable
	^aVariable isKindOf: ClyInstanceVariable! !

!ClyAllInstanceVariablesQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult

	| vars |
	vars := OrderedCollection new.
	
	scope instanceVariablesDo: [ :each | vars add: each ].
	
	aQueryResult fillWith: vars! !

!ClyAllInstanceVariablesQuery methodsFor: 'printing' stamp: ''!
description

	^'instance variables'! !

!ClyAllInstanceVariablesQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	scope instanceVariablesDo: [ :each | ^false ].
	
	^true! !

!ClyAllInstanceVariablesQueryTest methodsFor: 'tests' stamp: ''!
testFromSingleClass

	| varNames |
	self queryFromScope: ClyClassScope of: ClyClass2FromP1Mock.
	
	varNames := resultItems collect: #name as: Set.
	self assert: varNames equals: ClyClass2FromP1Mock instVarNames asSet! !

!ClyAllInstanceVariablesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyClassScope of: ClyClass2FromP1Mock in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyClassScope of: ProtoObject in: environment).
	self assert: query checkEmptyResult! !

!ClyAllInstanceVariablesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyAllInstanceVariablesQuery from: ClyClassScope of: ClyClass2FromP1Mock in: environment! !

!ClyAllMethodCritiqueQuery commentStamp: ''!
I return critiques of all methods visible from my scope!
!ClyAllMethodCritiqueQuery methodsFor: 'execution' stamp: ''!
analyzedObjectsDo: aBlock
	scope methodsDo: aBlock! !

!ClyAllMethodCritiquesTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
		
	query scope: self scopeWithCritiques .
	self deny: query checkEmptyResult.
	
	query scope: self scopeWithoutCritiques.
	self assert: query checkEmptyResult.! !

!ClyAllMethodCritiquesTest methodsFor: 'tests' stamp: ''!
testExecution

	self executeQuery.
	
	self assert: resultItems size equals: 1! !

!ClyAllMethodCritiquesTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyAllMethodCritiqueQuery from: self scopeWithCritiques! !

!ClyAllMethodGroup commentStamp: ''!
I includes all methods from concrete meta level of given class.

I represented in the browser either with "instance side" or "class side" names depending on concrete meta level of my method query.

I am expanded to inherited method groups for each of trait or class which are inherited by my class scope!
!ClyAllMethodGroup methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem
	super decorateTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph browser metaLevelScope = ClyClassSideScope ifTrue: [ 
		anItemCellMorph label clyAddEmphasis: TextEmphasis bold]! !

!ClyAllMethodGroup methodsFor: 'operations' stamp: ''!
importMethod: aMethod 
	"To support some people scenario to unclassify methods 
	by drag and drop into this group (which was with ALL name in past)"
	
	aMethod tags do: [ :each | aMethod untagFrom: each ]! !

!ClyAllMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethodQuery: aMethodQuery andClassesInheritedFrom: aClassScope
	| group |
	group := super withMethodQuery: aMethodQuery andClassesInheritedFrom: aClassScope.
	group name: (aMethodQuery scope localScopeClass = ClyInstanceSideScope 
		ifTrue: [ 'instance side' ]
		ifFalse: [ 'class side' ]).
	^group! !

!ClyAllMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethodsInheritedFrom: aClassScope

	^self  
		withMethodQuery: (ClyAllMethodsQuery from: aClassScope asLocalClassScope)
		andClassesInheritedFrom: aClassScope! !

!ClyAllMethodGroupsQuery commentStamp: ''!
I am a query of all method groups from given scope.

Scope should support #methodGroupsDo:. 
Currently it is only ClyAbstractClassScope.

The scope delegates method group building to the environment plugins.
It asks each plugin to collect method group providers using: 

	plugin collectMethodGroupProviders 

And then each provider creates set of method groups using method: 

	groupProvider buildGroupsFrom: aClassScope

The scope ensures that all methods from given scope will be enumerated only once.
So provider should return groups without looking into the methods of scope.
Then the scope itself will check that every built group includes at least one method:

	aGroup dependsOnMethod: aMethod

So scope will enumerate all available methods once and verify each group.

Scope also allow static groups which do not need any method check. Provider of such groups should return true from method #isStatic: 
	
	methodGroupProvider isStatic >>> true

Look at ClyMethodGroupProvider for more details!
!ClyAllMethodGroupsQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin
	anEnvironmentPlugin collectMetadataOfMethodGroups: aQueryResult! !

!ClyAllMethodGroupsQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	| asyncGroups |
	(scope includesMethodGroupsAffectedBy: aSystemAnnouncement) ifTrue: [ ^true ].
	
	(aSystemAnnouncement isKindOf: ClyAsyncQueryIsDone) ifTrue: [ 
		asyncGroups := aQueryResult items select: [ :each | each isKindOf: ClyAsyncMethodGroup ].
		(asyncGroups anySatisfy: [ :each | each asyncQueryResult == aSystemAnnouncement queryResult])
			ifTrue: [ ^true ]
	 ].

	^false! !

!ClyAllMethodGroupsQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult 

	| groups |
	groups := OrderedCollection new.
	
	scope methodGroupsDo: [:group | groups add: group].
	
	aQueryResult fillWith: groups! !

!ClyAllMethodGroupsQuery methodsFor: 'printing' stamp: ''!
description

	^'all method groups'! !

!ClyAllMethodGroupsQuery methodsFor: 'converting' stamp: ''!
withMetaLevelScope: aScopeClass 
	^self withScope: (scope withMetaLevel: aScopeClass)! !

!ClyAllMethodGroupsQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	
	scope methodGroupsDo: [ :each | ^false].
	
	^true! !

!ClyAllMethodGroupsQuery methodsFor: 'accessing' stamp: ''!
shortName
	^'Methods'! !

!ClyAllMethodGroupsQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	^ClyMethodGroup! !

!ClyAllMethodGroupsQueryTest methodsFor: 'tests' stamp: ''!
testFromSingleClass

	self queryFromScope: ClyInstanceSideScope of: ClyClass1FromP1Mock.
	
	self assert: (resultItems collect: #class as: Set) equals: { ClyAllMethodGroup. ClyTaggedMethodGroup} asSet.
	self 
		assert: (resultItems select:[:each | each class = ClyTaggedMethodGroup] thenCollect: #tag) asSet
		equals: ClyClass1FromP1Mock tagsForMethods asSet! !

!ClyAllMethodGroupsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	| scope |
	scope := ClyInstanceSideScope of: ClyClass1FromP1Mock in: environment.
	query scope: scope.
	
	self deny: query checkEmptyResult! !

!ClyAllMethodGroupsQueryTest methodsFor: 'tests' stamp: ''!
testConvertingToNewMetaLevel

	| newQuery |
	newQuery := query withMetaLevelScope: ClyInstanceSideScope.
	
	self assert: newQuery scope class equals: ClyInstanceSideScope.
	self assert: newQuery scope basisObjects equals: query scope basisObjects.! !

!ClyAllMethodGroupsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyAllMethodGroupsQuery from: ClyClassScope of: Object in: environment! !

!ClyAllMethodGroupsQueryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	environment addPlugin: ClyDefaultSystemEnvironmentPlugin new! !

!ClyAllMethodsQuery commentStamp: ''!
I return all methods which are visible from the scope.!
!ClyAllMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod

	^true! !

!ClyAllMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'all methods'! !

!ClyAllMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromSingleClass

	self queryFromScope: ClyClassScope of: ClyClass1FromP1Mock.
	
	self assert: foundSelectors equals: #(#instanceSideVar1ReaderMethod #instanceSideVar1WriterMethod #instanceSideVar2 #superclassTag1Method #tag1Method1)! !

!ClyAllMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: (ClyClass1FromP1Mock >> #tag1Method1) in: environment).
	self deny: query checkEmptyResult! !

!ClyAllMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyAllMethodsQuery from: ClyClassScope of: Object in: environment! !

!ClyAllPackagesQuery commentStamp: ''!
I return all packages from the scope!
!ClyAllPackagesQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	"Normally system shows dirty state of package after any system change.
	It means that we think that any system change affects packages.
	But generally it should be responsibility of plugin to know
	that package items are marked by dirty tag.
	
	Also right now we don't care that there is possibility to query packages from other objects than from packages themselves or general system environment.
	So any package change is related to my items"
	
	^aSystemAnnouncement affectsPackages! !

!ClyAllPackagesQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	| packages |
	packages := OrderedCollection new.
	
	scope packagesDo: [ :each | packages add: each].
	
	aQueryResult fillWith: packages! !

!ClyAllPackagesQuery methodsFor: 'printing' stamp: ''!
description

	^'all packages'! !

!ClyAllPackagesQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	
	scope packagesDo: [ :each | ^false].
	
	^true! !

!ClyAllPackagesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyPackageScope of: ClyClass1FromP1Mock package in: environment).
	
	self deny: query checkEmptyResult! !

!ClyAllPackagesQueryTest methodsFor: 'tests' stamp: ''!
testFromSinglePackage

	self queryFromScope: ClyPackageScope of: ClyClass1FromP1Mock package.

	self assert: resultItems asSet equals: {ClyClass1FromP1Mock package} asSet! !

!ClyAllPackagesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyAllPackagesQuery from: ClyPackageScope of: Object package in: environment! !

!ClyAllProblemMethodQuery commentStamp: ''!
I return methods from my scope which include critiques from my critiquesQuery parameter.

To create my instance use following methods: 

	ClyAllProblemMethods from: aScope withCritiquesFrom: aCritiqueQuery.
	ClyAllProblemMethods from: aScope withCritiquesFromGroup: crituqueGroupName.
	
Internal Representation and Key Implementation Points.

    Instance Variables
	critiqueQuery:		<ClyCritiqueQuery>!
!ClyAllProblemMethodQuery methodsFor: 'accessing' stamp: ''!
critiqueQuery
	^ critiqueQuery! !

!ClyAllProblemMethodQuery methodsFor: 'accessing' stamp: ''!
scope: aScope
	super scope: aScope.
	critiqueQuery scope: aScope! !

!ClyAllProblemMethodQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
		
	^critiqueQuery = anObject critiqueQuery! !

!ClyAllProblemMethodQuery methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	critiqueQuery := ClyAllMethodCritiqueQuery new! !

!ClyAllProblemMethodQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: critiqueQuery hash! !

!ClyAllProblemMethodQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	aSystemAnnouncement affectsCritiques ifFalse: [ ^false ].
	(super isResult: aQueryResult affectedBy: aSystemAnnouncement) ifTrue: [ ^true ].	
	"We can not compute affect on critiques by any kind system change
	because critiques are composed by some external system
	So without real knowledge we can only update critiqies after any system change.
	It can of course lead to very poor system performance because critic computation is slow process
	and triggering it after every system change can slow down system a lot.
	So instead we just reset given aQueryResult silently. So users should update views manually"
	aQueryResult forceLazyRebuild.
	^false! !

!ClyAllProblemMethodQuery methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph definitionIcon: #smallDebug! !

!ClyAllProblemMethodQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult

	| critiques methods |
	critiques := critiqueQuery execute.
	
	methods := critiques items collect: [ :each | each sourceAnchor entity ] as: IdentitySet.
	
	aQueryResult fillWith: methods! !

!ClyAllProblemMethodQuery methodsFor: 'printing' stamp: ''!
description

	^'problem methods (', critiqueQuery description, ')'! !

!ClyAllProblemMethodQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	| critiques |
	critiques := self loadCritiquesAsync.
	
	^critiques items 
		anySatisfy: [ :each | each sourceAnchor entity == aMethod ]! !

!ClyAllProblemMethodQuery methodsFor: 'accessing' stamp: ''!
critiqueQuery: aCritiqueQuery
	critiqueQuery := scope adoptQuery: aCritiqueQuery! !

!ClyAllProblemMethodQuery methodsFor: 'execution' stamp: ''!
loadCritiquesAsync

	^critiqueQuery async execute! !

!ClyAllProblemMethodQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	^critiqueQuery hasEmptyResult! !

!ClyAllProblemMethodQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream
	super printExtraInfoOn: aStream.
	
	aStream nextPutAll: critiqueQuery description! !

!ClyAllProblemMethodQuery class methodsFor: 'instance creation' stamp: ''!
from: aScope withCritiquesFromGroup: critiqueGroupName
	^self 
		from: aScope 
		withCritiquesFrom: (ClyConcreteGroupCritiqueQuery 
			filter: ClyAllMethodCritiqueQuery new from: aScope byGroup: critiqueGroupName)! !

!ClyAllProblemMethodQuery class methodsFor: 'instance creation' stamp: ''!
from: aScope withCritiquesFrom: aCritiqueQuery
	^(self from: aScope)
		critiqueQuery: aCritiqueQuery! !

!ClyAllProblemMethodsTest methodsFor: 'tests' stamp: ''!
testNotSelectsMethodWithCritiquesWhenTheyNotComputedYet

	self deny: (query selectsMethod: (ClyClassWithProblemMethods >> #methodWithHalt))! !

!ClyAllProblemMethodsTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: (ClyClassWithProblemMethods >> #methodWithHalt) in: environment).
	self deny: query checkEmptyResult.
	
	query := self createQuery.
	query scope: (ClyMethodScope
		of: (ClyClassWithProblemMethods >> #methodWithoutCritiques) in: environment).
	self assert: query checkEmptyResult! !

!ClyAllProblemMethodsTest methodsFor: 'tests' stamp: ''!
testExecution
	
	self executeQuery.
	
	self assert: foundSelectors equals: #(methodWithHalt methodWithHalt2)! !

!ClyAllProblemMethodsTest methodsFor: 'tests' stamp: ''!
testNotSelectsMethodWithoutCritiques

	self deny: (query selectsMethod: (ClyClassWithProblemMethods >> #methodWithoutCritiques))! !

!ClyAllProblemMethodsTest methodsFor: 'tests' stamp: ''!
testSelectsMethodWithCritiquesWhenTheyExistAndComputedInAdvance

	| critiques |
	critiques := query critiqueQuery async execute.
	[ critiques isBuilt ] whileFalse: [ 30 milliSeconds wait ].

	self assert: (query selectsMethod: (ClyClassWithProblemMethods >> #methodWithHalt))! !

!ClyAllProblemMethodsTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyAllProblemMethodQuery
		from: ClyClassScope of: ClyClassWithProblemMethods in: environment! !

!ClyAllProjectsQuery commentStamp: ''!
I am a query of all projects from given scope.
The project managers should return a subclass of myself.
!
!ClyAllProjectsQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	^ClyManagedProject! !

!ClyAllVariablesQuery commentStamp: ''!
I return all type of variables from given scope.

Scope should support #variablesDo:.
Now only class scopes support it.!
!ClyAllVariablesQuery methodsFor: 'testing' stamp: ''!
retrievesItem: aVariable
	^true! !

!ClyAllVariablesQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult

	| allVars |
	allVars := OrderedCollection new.
	
	scope variablesDo: [ :each | allVars add: each ].
	
	aQueryResult fillWith: allVars! !

!ClyAllVariablesQuery methodsFor: 'printing' stamp: ''!
description

	^'all variables'! !

!ClyAllVariablesQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	scope variablesDo: [ :each | ^false ].
	
	^true! !

!ClyAllVariablesQuery methodsFor: 'accessing' stamp: ''!
shortName
	^'Vars'! !

!ClyAllVariablesQueryTest methodsFor: 'tests' stamp: ''!
testFromSingleClass

	| varNames |
	self queryFromScope: ClyClassScope of: ClyClass2FromP1Mock.
	
	varNames := resultItems collect: [:each | each name] as: Set.
	self 
		assert: varNames 
		equals: ClyClass2FromP1Mock instVarNames asSet, (ClyClass2FromP1Mock classVariables collect: [:each | each name])! !

!ClyAllVariablesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyClassScope of: ClyClass2FromP1Mock in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyClassScope of: ProtoObject in: environment).
	self assert: query checkEmptyResult! !

!ClyAllVariablesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyAllVariablesQuery from: ClyClassScope of: ClyClass2FromP1Mock in: environment! !

!ClyApplyClassDeprecationCommand commentStamp: ''!
I am a command to apply class deprecation in system.
I ask class itself to get target refactorings and then execute them!
!ClyApplyClassDeprecationCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	^targetClass deprecationRefactorings! !

!ClyApplyClassDeprecationCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	^true! !

!ClyApplyClassDeprecationCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Apply deprecation'! !

!ClyApplyClassDeprecationCommand methodsFor: 'execution' stamp: ''!
execute
	
	self executeRefactorings! !

!ClyApplyClassDeprecationCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: ClyClass asCalypsoItemContext! !

!ClyApplyClassDeprecationCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^(super canBeExecutedInContext: aToolContext)
		and: [ aToolContext selectedClassItems last isMarkedWith: ClyDeprecatedItemTag  ]! !

!ClyAsyncBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testHasQueryResult

	self assert: cursor queryResult class equals: ClyAsyncBrowserQueryResultAdapter.
	self assert: cursor queryResult actualResult equals: queryResult! !

!ClyAsyncBrowserQueryCursorTest methodsFor: 'running' stamp: ''!
createQuery
	^super createQuery semiAsync! !

!ClyAsyncBrowserQueryCursorTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors 
	^true! !

!ClyAsyncBrowserQueryResultAdapter commentStamp: ''!
I adopt ClyAsyncQueryResult retrieving ClyBrowserQueryResult to the ClyBrowserQueryResult.

I am used by ClyAsyncQueryResult in case when actual query produces kind of ClyBrowserQueryResult. In that case actual result items are ClyBrowserItem instances. But owner ClyAsyncQueryResult is not a kind of ClyBrowserQueryResult. 
So without special adapter nobody will collect properties of retrieved browser items. And browser query interface will not be supported.
Notice that ClyQueryResultBrowserAdapter can not be used in that case because it expects that items real objects instead of ClyBrowserItem instances. It required details to correctly implement items query interface.

When async result retrives another basic result then my superclass is used as adapter as in any other cases!
!ClyAsyncBrowserQueryResultAdapter methodsFor: 'queries' stamp: ''!
allItems
	^self prepareItems: actualResult allItems! !

!ClyAsyncBrowserQueryResultAdapter methodsFor: 'queries' stamp: ''!
findItemsSimilarTo: sampleEnvironmentItems
	| rest found |
	actualResult protectItemsWhile: [ 
		rest := sampleEnvironmentItems as: OrderedCollection.
		found := OrderedCollection new.	
		actualResult items do: [ :existing |
			rest
				detect: [ :sample | sample isSimilarTo: existing]
				ifFound: [ :sample | 
					existing prepareIn: self environment.
					found add: existing. 
					rest remove: sample.
					rest ifEmpty: [ ^found ] ]].	
		^found]! !

!ClyAsyncBrowserQueryResultAdapter methodsFor: 'queries' stamp: ''!
itemsStartingWhere: conditionBlock count: size

	^self prepareItems: (actualResult itemsStartingWhere: conditionBlock count: size)! !

!ClyAsyncBrowserQueryResultAdapter methodsFor: 'private' stamp: ''!
prepareItems: browserItems

	browserItems do: [ :each | each ifNotNil: [ each prepareIn: self environment ]].
	^browserItems! !

!ClyAsyncBrowserQueryResultAdapter methodsFor: 'queries' stamp: ''!
itemsStartingAt: startIndex count: size

	^self prepareItems: (actualResult itemsStartingAt: startIndex count: size)! !

!ClyAsyncBrowserQueryResultAdapter methodsFor: 'queries' stamp: ''!
findItemsWith: actualObjects
	"it returnes environment items which represent actualObjects.
	Result will be in same order as given actualObjects array.
	If some object is absent in content then it will return nil in place of it.
	All returned items will be resilved"
	| result |
	^actualResult protectItemsWhile: [
		result := actualObjects collect: [ :eachObject |
			actualResult items
				detect: [ :item | item representsObjectEqualTo: eachObject ] 
				ifNone: nil].
		self prepareItems: result]! !

!ClyAsyncBrowserQueryResultAdapter methodsFor: 'queries' stamp: ''!
itemsWhere: conditionBlock

	^self prepareItems: (actualResult itemsWhere: conditionBlock)! !

!ClyAsyncMethodGroup commentStamp: ''!
I represent method group based on async method query.
I am decorated in the browser with animation indicating background query processing.

My instances are usually created from another method group using converting method: 

	aMethodGroup asAsyncQueryGroup

I hold reference to async query result. So it is kept in memory together with my instance.

Internal Representation and Key Implementation Points.

    Instance Variables
	asyncQueryResult:		<ClyAsyncQueryResult>
!
!ClyAsyncMethodGroup methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem
	super decorateTableCell: anItemCellMorph of: groupItem.
	
	(groupItem isMarkedWith: ClyBackgroundProcessingTag) 
		ifTrue: [ anItemCellMorph definitionMorph: ClyActivityAnimationIconMorph new ]
		ifFalse: [methodQuery decorateMethodGroupTableCell: anItemCellMorph of: groupItem]! !

!ClyAsyncMethodGroup methodsFor: 'accessing' stamp: ''!
loadAsyncQueryResult

	^methodQuery execute! !

!ClyAsyncMethodGroup methodsFor: 'accessing' stamp: ''!
asyncQueryResult: anObject
	asyncQueryResult := anObject! !

!ClyAsyncMethodGroup methodsFor: 'testing' stamp: ''!
includesMethod: aMethod
	self asyncQueryResult isBuilt ifFalse: [ ^false ].
	^super includesMethod: aMethod! !

!ClyAsyncMethodGroup methodsFor: 'testing' stamp: ''!
asAsyncQueryGroup
	^self! !

!ClyAsyncMethodGroup methodsFor: 'decoration' stamp: ''!
decorateOwnBrowserItem: myItem
	super decorateOwnBrowserItem: myItem.
	
	self asyncQueryResult isBuilt ifFalse: [  myItem markWith: ClyBackgroundProcessingTag]! !

!ClyAsyncMethodGroup methodsFor: 'accessing' stamp: ''!
asyncQueryResult
	^ asyncQueryResult ifNil: [ asyncQueryResult := self loadAsyncQueryResult ]! !

!ClyAsyncMethodGroup methodsFor: 'testing' stamp: ''!
dependsOnMethod: aMethod

	"If query result are not built yet we are depending on any possible method.
	And when result is done we can check actual dependency"
	self asyncQueryResult isBuilt ifFalse: [ ^true ].
	
	^super dependsOnMethod: aMethod! !

!ClyAsyncMethodGroup class methodsFor: 'item preparation' stamp: ''!
prepareCalypsoItemCopy: aBrowserItem

	| groupCopy |
	groupCopy := aBrowserItem actualObject copy.
	groupCopy asyncQueryResult: nil.
	aBrowserItem actualObject: groupCopy! !

!ClyAsyncQuery commentStamp: ''!
I run my subquery using background process.
I do not implement #buildResult: as other queries. 
Instead I return special ClyAsyncQueryResult instance to represent result of execution. 
Async result overrides building logic in the way that it forks actual query execution and updates itself when execution completes. For details look at this class.
So I only implement hook which triggers background execution of actual query.

Any query can be converted to async query using:

	aQuery async 
	
It returns instance of me. And in case when I am receiver I just return myself.

There is special mode to emulate sync execution of fast queries. To activate it use #semyAsync message instead of simple #async: 

	aQuery semiAsync 

It will return my instance configured with ClySemiAsyncQueryResult. So during execution it will be used instead of simple ClyAsyncQueryResult.
The idea of semi async execution is to wait half seconds until query will be executed. If this time is enough (which is true for fast queries) then for users it will look like normal syncronous execution. But otherwise it will be asyncronous execution and returned result will indicate progress.

The concrete type of async result is holden in asyncResult variable.

While I am executed users can check the execution state. A ClyAsyncQueryResult is returned from #execute method which can be checked for the status:

	aQuery execute isBuilt
	
It returns true only when execution is completed.

For the empty test (#checkEmptyResult) I always return false when execution is still in progress. Idea that we do not know exactly if result would be empty or not. And for many scenarios it is convenient to get false in that case.

Internal Representation and Key Implementation Points.

    Instance Variables
	asyncResult:		<ClyAsyncQueryResult>!
!ClyAsyncQuery methodsFor: 'converting' stamp: ''!
semiAsync
	^self copy 
		asyncResult: ClySemiAsyncQueryResult new! !

!ClyAsyncQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ asyncResult = anObject asyncResult! !

!ClyAsyncQuery methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	asyncResult := ClyAsyncQueryResult new! !

!ClyAsyncQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: asyncResult hash! !

!ClyAsyncQuery methodsFor: 'accessing' stamp: ''!
asyncResult: anObject
	asyncResult := anObject! !

!ClyAsyncQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	self shouldNotImplement! !

!ClyAsyncQuery methodsFor: 'accessing' stamp: ''!
asyncResult
	^ asyncResult! !

!ClyAsyncQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	| result |
	result := self execute.
	result isBuilt ifTrue: [ ^result isEmpty ].
	^false "If actual result is still in processing then we can not be sure about empty check"! !

!ClyAsyncQuery methodsFor: 'testing' stamp: ''!
isAsync
	^true! !

!ClyAsyncQuery methodsFor: 'converting' stamp: ''!
async
	^self! !

!ClyAsyncQuery methodsFor: 'execution' stamp: ''!
prepareNewResult
	
	^asyncResult prepareNewFor: self actualQuery in: self environment! !

!ClyAsyncQueryIsDone commentStamp: ''!
I am announcing the async query completion.
Every async query announces me at the end of execution when result is completelly built.

To create instance use: 

	ClyAsyncQueryIsDone with: anAsyncQueryResult
 
Internal Representation and Key Implementation Points.

    Instance Variables
	queryResult:		<ClyAsyncQueryResult>!
!ClyAsyncQueryIsDone methodsFor: '*Calypso-SystemPlugins-Critic-Queries' stamp: ''!
affectsCritiques
	^false! !

!ClyAsyncQueryIsDone methodsFor: 'accessing' stamp: ''!
queryResult
	^ queryResult! !

!ClyAsyncQueryIsDone methodsFor: 'accessing' stamp: ''!
queryResult: anObject
	queryResult := anObject! !

!ClyAsyncQueryIsDone class methodsFor: 'instance creation' stamp: ''!
with: anAsyncQueryResult
	^self new 
		queryResult: anAsyncQueryResult! !

!ClyAsyncQueryResult commentStamp: ''!
I am special kind of query result which implements building in background process.

I override #rebuild method where I fork actual query execution and mark myself with ClyBackgroundProcessingTag.
When actual query is done I notify my observers to perform update.

I am created by ClyAsyncQuery as actual result instance instead of requiredResult. My #buildingQuery is actual query which I execute in the background.

Besides background processing I have other differences to my superclass logic:
- metadata is not lazy and it is built in background together with items
- built tems are never reset due to system changes. They are replaced with actual result when it is finally built.

I override #isBuilt method to detect that background processing completes and items are really built.
So you can check that async query is done using following expression: 
	asyncQuery execute isBuilt 
 
I keep reference to actual result in my #actualResult instance. So it is keep in memory as soon as I am used by somebody.

To force async query execution you need convert given query using: 
	aQuery async
	
It returns ClyAsyncQuery instance with #asyncResult variable which points to me.

I use specific logic to adopt my instances for the browser. Look at #adoptForBrowser. 
When I represent raw query result then my superclass implementation is fine. The instance of ClyQueryResultBrowserAdapter will be returned which wraps raw query items to ClyBrowserItem instances.
But If I represent a kind of ClyBrowserQueryResult then it is already adopted for the browser. But from the other side I do not provide required API of ClyBrowserQueryResult. So in that case I will return ClyAsyncBrowserQueryResultAdapter which adopts my instance to the ClyBrowserQueryResult.

Internal Representation and Key Implementation Points.

    Instance Variables
	actualResult:		<ClyQueryResult>
	buildProcess:		<Process>!
!ClyAsyncQueryResult methodsFor: 'building' stamp: ''!
buildActualResult
	"The loop here prevents the race condition when actual query is just executed 
	but system is changed and this change reset built result which means nil returned from #items.
	In that case we just repeat query again"
	[actualResult := buildingQuery execute.
	(items := actualResult items) isNil] whileTrue.
	self collectMetadata.
	buildProcess := nil.
	self buildIsDone! !

!ClyAsyncQueryResult methodsFor: 'system changes' stamp: ''!
handleSystemChange: aSystemAnnouncement byProcessingList: allProcessingResults
	| expectedResult |
	super handleSystemChange: aSystemAnnouncement byProcessingList: allProcessingResults.
	
	expectedResult := environment cachedResultOf: buildingQuery.
	expectedResult ifNil: [ ^self ].
	
	needsRebuild ifTrue: [ 
		buildProcess ifNotNil: [ 
			buildProcess terminate.
			metadata removeProperty: ClyBackgroundProcessingTag instance].
		expectedResult itemsChanged].
	
	allProcessingResults remove: expectedResult ifAbsent: [  ]! !

!ClyAsyncQueryResult methodsFor: 'accessing' stamp: ''!
actualResult
	^ actualResult! !

!ClyAsyncQueryResult methodsFor: 'accessing' stamp: ''!
buildProcess
	^ buildProcess! !

!ClyAsyncQueryResult methodsFor: 'testing' stamp: ''!
isBuilt
	^super isBuilt 
		and: [(self hasMetaProperty: ClyBackgroundProcessingTag) not]! !

!ClyAsyncQueryResult methodsFor: 'initialization' stamp: ''!
initializeItems
	"async query should never reset existing items.
	Idea to seemlessly update items when new result is ready"
	items ifNil: [super initializeItems]! !

!ClyAsyncQueryResult methodsFor: 'building' stamp: ''!
rebuild
	self initializeItems.	
	metadata ifNil: [metadata := ClyQueryResultMetadata new].
	metadata addProperty: ClyBackgroundProcessingTag instance.
	
	self runBuildProcess! !

!ClyAsyncQueryResult methodsFor: 'building' stamp: ''!
runBuildProcess

	buildProcess := [self buildActualResult] newProcess.
	buildProcess 
		name: 'Build result of ', buildingQuery printString;
		priority: Processor userBackgroundPriority.
	buildProcess resume! !

!ClyAsyncQueryResult methodsFor: 'converting' stamp: ''!
adoptForBrowser
	"In case when actual query produces browser items 
	we should adopt our own interface to the interface of ClyBrowserQueryResult.
	Otherwise when actual query do not produce browser items 
	we just use superclass adapter for raw items"
	buildingQuery retrievesBrowserItems ifTrue: [ 
		^ClyAsyncBrowserQueryResultAdapter for: self ].
	
	^super adoptForBrowser! !

!ClyAsyncQueryResult methodsFor: 'building' stamp: ''!
buildIsDone
	self notifyObservers.
	environment systemChanged: (ClyAsyncQueryIsDone with: self)! !

!ClyAsyncQueryResult methodsFor: 'building' stamp: ''!
forceLazyRebuild
	"Async result never reset own items. 
	They should keep previous values until actual result will built new one"
	
	self protectAccessWhile: [ 	
		needsRebuild := true].! !

!ClyAsyncQueryResult methodsFor: 'accessing' stamp: ''!
rawItems
	^buildingQuery retrievesBrowserItems 
		ifTrue: [ items collect: [ :each | each actualObject ] ]
		ifFalse: [ items]! !

!ClyAsyncQueryResult methodsFor: 'building' stamp: ''!
collectMetadata
	"In async query we always collect metadata in background 
	and full execution process completes only after this.
	So no protection is needed here and no lazy logic over metadata variable"
	metadata := ClyQueryResultMetadata new.
	environment pluginsDo: [:each | 
		buildingQuery collectMetadataOf: self by: each	]! !

!ClyAsyncQueryResult methodsFor: 'building' stamp: ''!
fillWith: queriedObjects
	self shouldNotImplement! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testItemsChangedNotificationShouldResetItems
	<expectedFailure>
	"Async query should not reset own items which was already built.
	Another test describes that it should only reset actual result"
	
	super testItemsChangedNotificationShouldResetItems! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testIsBuiltWhenBuildComplete

	queryResult rebuild.
	query passExecution.
	self waitBuildComplete.
	
	self assert: queryResult isBuilt! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testItemsChangedNotificationShouldNotResetExistingItems
	
	queryResult items: #(items).
	
	queryResult itemsChanged.
	
	self assert: queryResult items equals: #(items).
	self assert: queryResult needsRebuild! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testItemsInitializationShouldNotResetExistingItems
	
	queryResult items: #(items).
	queryResult initializeItems.
	
	self assert: queryResult items equals: #(items)! !

!ClyAsyncQueryResultTest methodsFor: 'running' stamp: ''!
waitBuildComplete
	[queryResult buildProcess isNil or: [queryResult buildProcess isTerminated]]
		whileFalse: [ 20 milliSeconds wait ]! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testBuildCompletionShouldResetProcess

	queryResult rebuild.
	query passExecution.
	self waitBuildComplete.
	
	self assert: queryResult buildProcess isNil! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testBuildShouldSetUpItemsFromActualResultWhenTheyReady
	queryResult rebuild.
	query passExecution.
	self waitBuildComplete.

	self deny: (queryResult hasMetaProperty: ClyBackgroundProcessingTag).
	self assert: queryResult items identicalTo: queryResult actualResult items.
	self assert: queryResult items asSet equals: query scope basisObjects! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testForceLazyRebuildShouldNotResetExistingItems
	
	self assert: queryResult items notNil.
	 
	queryResult forceLazyRebuild.
	
	self assert: queryResult needsRebuild.
	self assert: queryResult isBuilt.
	self assert: queryResult items notNil! !

!ClyAsyncQueryResultTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyAsyncQueryResult new! !

!ClyAsyncQueryResultTest methodsFor: 'running' stamp: ''!
createQuery

	^ClyLongExampleQuery from: ClyExampleScope of: String in: environment! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testBuildCompletionShouldNotifyItemObservers
	| observer |
	observer := ClyItemObserverExample new.
	queryResult openBrowserCursorFor: observer.

	queryResult rebuild.
	query passExecution.
	self waitBuildComplete.

	self assert: observer wasNotified! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testNotBuiltWhenBuildIsJustStarted

	queryResult rebuild.
	
	self deny: queryResult isBuilt! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testNotBuiltByDefault

	queryResult := queryResult class new.
	
	self deny: queryResult isBuilt! !

!ClyAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testBuildShouldStartBackgroundProcessing

	queryResult rebuild.
	
	self assert: (queryResult hasMetaProperty: ClyBackgroundProcessingTag).
	self deny: queryResult buildProcess isTerminated! !

!ClyAsyncQueryTest methodsFor: 'tests' stamp: ''!
testComparingWithAnotherAsyncQueryWithDifferentAsyncResult
	| anotherQuery |
	anotherQuery := query semiAsync.

	self deny: query equals: anotherQuery! !

!ClyAsyncQueryTest methodsFor: 'tests' stamp: ''!
testConvertingToSemiAsyncQuery
	| convertedQuery |
	convertedQuery := query semiAsync.

	self assert: convertedQuery asyncResult class equals: ClySemiAsyncQueryResult.
	self deny: convertedQuery identicalTo: query.
	self assert: convertedQuery class equals: query class.
	self assert: convertedQuery requiredResult identicalTo: query requiredResult.
	self assert: convertedQuery scope identicalTo: query scope! !

!ClyAsyncQueryTest methodsFor: 'tests' stamp: ''!
testConvertingToAsyncQuery
	self assert: query async identicalTo: query! !

!ClyAsyncQueryTest methodsFor: 'tests' stamp: ''!
testPrepareResultForExecution
	| preparedResult |
	preparedResult := query prepareNewResult.

	self assert: preparedResult class equals: ClyAsyncQueryResult.
	self assert: preparedResult buildingQuery identicalTo: query actualQuery.
	self assert: preparedResult environment identicalTo: environment.
	self assert: preparedResult isProtected! !

!ClyAsyncQueryTest methodsFor: 'running' stamp: ''!
queryClass
	^ClyAsyncQuery! !

!ClyAsyncQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyAsyncQuery for: (ClyReturningScopeBasisExampleQuery
			from: ClyExampleScope of: self class in: environment)! !

!ClyAsyncQueryTest methodsFor: 'tests' stamp: ''!
testPrepareResultForExecutionWhenItIsSemiAsync
	| preparedResult |
	preparedResult := query semiAsync prepareNewResult.

	self assert: preparedResult class equals: ClySemiAsyncQueryResult.
	self assert: preparedResult buildingQuery identicalTo: query actualQuery.
	self assert: preparedResult environment identicalTo: environment.
	self assert: preparedResult isProtected! !

!ClyAsyncQueryTest methodsFor: 'tests' stamp: ''!
testHasAsyncResultbyDefault

	self assert: query asyncResult class equals: ClyAsyncQueryResult! !

!ClyAsyncRawQueryCursorTest methodsFor: 'running' stamp: ''!
createQuery
	^super createQuery semiAsync! !

!ClyAsyncRawQueryCursorTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors 
	^true! !

!ClyBackgroundProcessingTag commentStamp: ''!
I mark object that it is processed in background.
I can be used to resolve item properties in background process when it is too slow.
Tools can indicate it with special animation!
!ClyBanCritiqueRuleCommand commentStamp: ''!
I am a command to ban given critique rule!
!ClyBanCritiqueRuleCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.

	aToolContext tool criticView update! !

!ClyBanCritiqueRuleCommand methodsFor: 'table decoration' stamp: ''!
description
	^'Ban this rule'! !

!ClyBanCritiqueRuleCommand methodsFor: 'execution' stamp: ''!
execute

	critique guidedBan! !

!ClyBanCritiqueRuleCommand methodsFor: 'initialization' stamp: ''!
defaultMenuIconName
	^#smallCancelIcon! !

!ClyBothMetaLevelClassScope commentStamp: ''!
I represent local scope of classes which merges both instance and class sides!
!ClyBothMetaLevelClassScope methodsFor: 'queries' stamp: ''!
classesDo: aBlock

	basisObjects do: [ :each | 
		aBlock value: each instanceSide ]! !

!ClyBothMetaLevelClassScope class methodsFor: 'meta level' stamp: ''!
metaLevelsOf: aClass do: aBlock

	aBlock value: aClass instanceSide.
	aBlock value: aClass classSide! !

!ClyBothMetaLevelClassScope class methodsFor: 'meta level' stamp: ''!
metaLevelForHierarchyOf: aClass
	"For hierarchies I work as ClyMetaLevelClassScope.
	I restrict any hierarchy by instance side relationship.
	For example using class side scope you can analyze hierarchy of ProtoObject. 
	It will gives you only ProtoObject and ProtoObject class despite of
	ProtoObject class superclass is not nil"
	^aClass instanceSide! !

!ClyBothMetaLevelClassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumeration
	scope := ClyBothMetaLevelClassScope ofAll: {ClyClass1FromP1Mock. ClyClass2FromP1Mock}.
	
	scope classesDo: [ :each | result add: each ].
	
	self assert: result asArray equals: {ClyClass1FromP1Mock. ClyClass2FromP1Mock}! !

!ClyBothMetaLevelClassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBasisIsClass
	scope := ClyBothMetaLevelClassScope of: ClyClass1FromP1Mock.
	
	scope methodsDo: [ :each | result add: each ].
	
	self assert: (result includesAll: ClyClass1FromP1Mock localMethods).
	self assert: (result includesAll: ClyClass1FromP1Mock classSide localMethods)! !

!ClyBothMetaLevelClassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationWhenMetaClassIsBasis
	scope := ClyBothMetaLevelClassScope of: ClyClass1FromP1Mock class.
	
	scope classesDo: [ :each | result add: each ].
	
	self assert: result asArray equals: {ClyClass1FromP1Mock}! !

!ClyBothMetaLevelClassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBasisIsMetaclass
	scope := ClyBothMetaLevelClassScope of: ClyClass1FromP1Mock classSide.
	
	scope methodsDo: [ :each | result add: each ].
	
	self assert: (result includesAll: ClyClass1FromP1Mock localMethods).
	self assert: (result includesAll: ClyClass1FromP1Mock classSide localMethods)! !

!ClyBothMetaLevelClassScopeTest methodsFor: 'running' stamp: ''!
scopeClass

	^ClyBothMetaLevelClassScope! !

!ClyBreakOnAccessCommand commentStamp: ''!
Commands to install a breakpoint on the selected variable accesses from the vars view in Calypso!
!ClyBreakOnAccessCommand methodsFor: 'execution' stamp: ''!
breakOn: variable
	VariableBreakpoint
		watchVariable: variable name
		inClass: variable definingClass! !

!ClyBreakOnAccessCommand methodsFor: 'execution' stamp: ''!
defaultMenuItemName
	^'Break on access'! !

!ClyBreakOnReadCommand commentStamp: ''!
Commands to install a breakpoint on the selected variable reads from the vars view in Calypso!
!ClyBreakOnReadCommand methodsFor: 'execution' stamp: ''!
breakOn: variable
	VariableBreakpoint
		watchVariableReads: variable name
		inClass: variable definingClass! !

!ClyBreakOnReadCommand methodsFor: 'execution' stamp: ''!
defaultMenuItemName
	^'Break on read'! !

!ClyBreakOnVarAccessCommand commentStamp: ''!
I break on all accesses to selected target variable in the source code!
!ClyBreakOnVarAccessCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	sourceNode isVariable ifFalse:[^'(unvalid node)'].
	^'Break on accesses to ', sourceNode name! !

!ClyBreakOnVarAccessCommand methodsFor: 'execution' stamp: ''!
installVariableBreakpointOn: aVariableName in: methodOrClass
	VariableBreakpoint watchVariable: sourceNode name inClass: methodOrClass! !

!ClyBreakOnVarAccessCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aSourceCodeContext
	^ (super canBeExecutedInContext: aSourceCodeContext)
		and: [ aSourceCodeContext selectedSourceNode isArgumentVariable not ]! !

!ClyBreakOnVarReadsCommand commentStamp: ''!
I break on all accesses to selected target variable in the source code!
!ClyBreakOnVarReadsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	sourceNode isVariable ifFalse:[^'(unvalid node)'].
	^'Break on reads to ', sourceNode name! !

!ClyBreakOnVarReadsCommand methodsFor: 'execution' stamp: ''!
installVariableBreakpointOn: aVariableName in: methodOrClass
	VariableBreakpoint watchVariableReads: sourceNode name inClass: methodOrClass! !

!ClyBreakOnVarWritesCommand commentStamp: ''!
I break on all accesses to selected target variable in the source code!
!ClyBreakOnVarWritesCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	sourceNode isVariable ifFalse:[^'(unvalid node)'].
	^'Break on writes to ', sourceNode name! !

!ClyBreakOnVarWritesCommand methodsFor: 'execution' stamp: ''!
installVariableBreakpointOn: aVariableName in: methodOrClass
	VariableBreakpoint watchVariableWrites: sourceNode name inClass: methodOrClass! !

!ClyBreakOnVarWritesCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aSourceCodeContext
	^ (super canBeExecutedInContext: aSourceCodeContext)
		and: [ aSourceCodeContext selectedSourceNode isArgumentVariable not ]! !

!ClyBreakOnVariableCommand commentStamp: ''!
Commands to install a breakpoint on the selected variable from the vars view in Calypso!
!ClyBreakOnVariableCommand methodsFor: 'execution' stamp: ''!
breakOn: variable
	self subclassResponsibility! !

!ClyBreakOnVariableCommand methodsFor: 'execution' stamp: ''!
execute
	self breakOn: variables last! !

!ClyBreakOnVariableCommand methodsFor: 'execution' stamp: ''!
defaultMenuIconName
	^#smallDebug! !

!ClyBreakOnVariableCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	^ CmdContextMenuActivation
		byItemOf: ClyDebuggingMenuGroup
		for: ClyFullBrowserVariableContext! !

!ClyBreakOnVariableCommand class methodsFor: 'testing' stamp: ''!
isAbstract 
	^self == ClyBreakOnVariableCommand! !

!ClyBreakOnVariableCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aSourceCodeContext
	^ self isAbstract not
		and: [ super canBeExecutedInContext: aSourceCodeContext ]! !

!ClyBreakOnWriteCommand commentStamp: ''!
Commands to install a breakpoint on the selected variable writes from the vars view in Calypso!
!ClyBreakOnWriteCommand methodsFor: 'execution' stamp: ''!
breakOn: variable
	VariableBreakpoint
		watchVariableWrites: variable name
		inClass: variable definingClass! !

!ClyBreakOnWriteCommand methodsFor: 'execution' stamp: ''!
defaultMenuItemName
	^'Break on write'! !

!ClyBreakpointMethodGroupProvider commentStamp: ''!
I provide "breakpoints" method group when classes include methods with breakpoints or halts!
!ClyBreakpointMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyActiveBreakpointsQuery from: aClassScope! !

!ClyBreakpointMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'breakpoints' priority: 8.4 on: aMethodQuery! !

!ClyBreakpointMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyBreakpointMethodGroupProvider! !

!ClyBreakpointMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	^ClyClassWithHaltsMock! !

!ClyBrokenCritiqueTag commentStamp: ''!
I mark broken critiques. They raise some exception when are computed.
I am used to show broken critiques in full critiques list allowing to debug and fix failure.!
!ClyBrowseBreakpointsCommand commentStamp: ''!
I am a command to open browser with methods where halts or breakpoints are installed.

I am registered in world toolbar using class side method #worldMenuOn:!
!ClyBrowseBreakpointsCommand methodsFor: 'accessing' stamp: ''!
description

	^'Open browser with methods where Halts or Breakpoints are installed'! !

!ClyBrowseBreakpointsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName

	^'Browse Breakpoints'! !

!ClyBrowseBreakpointsCommand methodsFor: 'execution' stamp: ''!
execute 
	
	ClyQueryBrowserMorph browseBreakpoints! !

!ClyBrowseBreakpointsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName

	^#smallDebug! !

!ClyBrowseBreakpointsCommand class methodsFor: 'world menu' stamp: ''!
worldMenuOn: aBuilder
	<worldMenu>
	
	| command |
	command := self new.
	(aBuilder item: command defaultMenuItemName)
		parent: #Breakpoints;
		order: 1;
		icon: command defaultMenuIcon;
		help: command description;
		action: [ command execute ]! !

!ClyBrowseCoveringTestCaseCommand commentStamp: ''!
I am a command that opens a new browser on the test class corresponding to the selected class.!
!ClyBrowseCoveringTestCaseCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Browse test class'! !

!ClyBrowseCoveringTestCaseCommand methodsFor: 'execution' stamp: ''!
execute
	| testCase |
	testCase := (selectedClassItem getProperty: ClyTestedClassProperty) coveringTestCase.
	
	browser spawnBrowser: ClyFullBrowserMorph withState: [ :b |
		b selectClass: testCase]! !

!ClyBrowseCoveringTestCaseCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	selectedClassItem := aToolContext lastSelectedItem! !

!ClyBrowseCoveringTestCaseCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	^ CmdContextMenuActivation
		byItemOf: ClyQueryMenuGroup
		for: ClyClass asCalypsoItemContext! !

!ClyBrowseCoveringTestCaseCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext
	(super canBeExecutedInContext: aBrowserContext) ifFalse: [ ^false ].
	
	^ aBrowserContext lastSelectedItem hasProperty: ClyTestedClassProperty! !

!ClyBrowseCritiqueRuleCommand commentStamp: ''!
I am a command that can be executed in the critic context (ClyCriticContext) and that will allows one to browser the class of a rule in the system.

This might be useful in case a user want to understand a rule from the code.
	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	criticClass:		<aClass> 		The critic class to browse.!
!ClyBrowseCritiqueRuleCommand methodsFor: 'table decoration' stamp: ''!
description
	^ 'Command to browse the class defining the rule producing the critique.'! !

!ClyBrowseCritiqueRuleCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Browse rule'! !

!ClyBrowseCritiqueRuleCommand methodsFor: 'execution' stamp: ''!
execute
	self critique rule class browse! !

!ClyBrowseCritiqueRuleCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^ #smallSystemBrowser! !

!ClyBrowseCritiqueRuleCommand class methodsFor: 'activation' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	^ CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClyCriticContext! !

!ClyBrowseCritiqueRuleCommand class methodsFor: 'activation' stamp: ''!
criticTableIconActivation
	"We do not want this command to appear in the command icons next to critiques, so we override the method."! !

!ClyBrowseIcebergCommitCommand commentStamp: ''!
I am a command to open Calypso browser on all packages from given Iceberg commit!
!ClyBrowseIcebergCommitCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #glamorousBrowse! !

!ClyBrowseIcebergCommitCommand methodsFor: 'execution' stamp: ''!
execute

	| env snapshot methodHistoryLogEntry |
	env := RGEnvironment new.
	methodHistoryLogEntry := self methodHistoryLogEntryModel entity.
	methodHistoryLogEntry commit packageNames
		do: [ :packageName |
			snapshot := methodHistoryLogEntry commit snapshotFor: (RPackage named: packageName).
			snapshot importInto: env asPackageNamed: packageName ] 
		displayingProgress: 'loading'.
	env clean.
	env browseAs: methodHistoryLogEntry commit repository origin url , '[', methodHistoryLogEntry shortId, ']'! !

!ClyBrowseIcebergCommitCommand methodsFor: 'execution' stamp: ''!
methodHistoryLogEntryModel

	^ self item! !

!ClyBrowseIcebergCommitCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $b meta! !

!ClyBrowseIcebergCommitCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription

	^ 'Browse the version in repository'! !

!ClyBrowseIcebergCommitCommand class methodsFor: 'accessing' stamp: ''!
defaultName

	^ 'Browse this version in Calypso'! !

!ClyBrowseIcebergPackageCommand commentStamp: ''!
I am a command to open Calypso browser on given package from given Iceberg repository!
!ClyBrowseIcebergPackageCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #glamorousBrowse! !

!ClyBrowseIcebergPackageCommand methodsFor: 'execution' stamp: ''!
execute

	| env commit snapshot |
	env := RGEnvironment new.
	commit := self repositoryModel commit.

	#(1) do: [ :i |
			snapshot := commit snapshotFor: (RPackage named: self packageModel name).
 			snapshot importInto: env asPackageNamed: self packageModel name]
		displayingProgress: 'loading'.
	env clean.
	env browseAs: self repository description! !

!ClyBrowseIcebergPackageCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $b meta! !

!ClyBrowseIcebergPackageCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription

	^ 'Browse the version in the repository'! !

!ClyBrowseIcebergPackageCommand class methodsFor: 'accessing' stamp: ''!
defaultName

	^ 'Browse this version in Calypso'! !

!ClyBrowseIcebergRepositoryCommand commentStamp: ''!
I am a command to open Calypso browser on all packages from given Iceberg repository (from the head commit)!
!ClyBrowseIcebergRepositoryCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #glamorousBrowse! !

!ClyBrowseIcebergRepositoryCommand methodsFor: 'execution' stamp: ''!
execute

	| env commit snapshot |
	commit := self repositoryModel commit.
	env := RGEnvironment new.
	commit packageNames
		do: [ :packageName |
			snapshot := commit snapshotFor: (RPackage named: packageName).
			snapshot importInto: env asPackageNamed: packageName ]
		displayingProgress: 'loading'.
	env clean.
	env browseAs: self repository description! !

!ClyBrowseIcebergRepositoryCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $b meta! !

!ClyBrowseIcebergRepositoryCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self isRepositoryOperational! !

!ClyBrowseIcebergRepositoryCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription

	^ 'Browse the version in repository'! !

!ClyBrowseIcebergRepositoryCommand class methodsFor: 'accessing' stamp: ''!
defaultName

	^ 'Browse this version in Calypso'! !

!ClyBrowserButtonMorph commentStamp: ''!
I am a toolbar button which executes particular command!
!ClyBrowserButtonMorph methodsFor: 'operations' stamp: ''!
executeCommand

	[ super executeCommand ]	on: Exception fork: [:exc | exc pass ]! !

!ClyBrowserButtonMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		layoutInset: 4@0! !

!ClyBrowserButtonMorph methodsFor: 'installing' stamp: ''!
mouseEnter: evt
	super mouseEnter: evt.
	self currentHand showTemporaryCursor: Cursor webLink.! !

!ClyBrowserButtonMorph methodsFor: 'installing' stamp: ''!
mouseLeave: evt
	super mouseLeave: evt.
	self currentHand showTemporaryCursor: nil! !

!ClyBrowserButtonMorph methodsFor: 'initialization' stamp: ''!
build
	| label |
	label := self theme newLabelIn: self label: self title.
	label on: #click send: #executeCommand to: self.
	label emphasis: TextEmphasis underlined emphasisCode.
	
	self addMorph: label! !

!ClyBrowserButtonMorph methodsFor: 'installing' stamp: ''!
handlesMouseOver: evt
	^true! !

!ClyBrowserCommand commentStamp: ''!
I am the root of the command hierarchy which affects state of the browser.

Instance Variables
	browser:		<ClyBrowser>!
!ClyBrowserCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aToolContext
	super readParametersFromContext: aToolContext.
	browser := aToolContext browser! !

!ClyBrowserCommand methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyBrowserCommand methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!ClyBrowserCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyBrowserCommand! !

!ClyBrowserContext commentStamp: ''!
My subclasses represent the navigation context of the browser, the browser state. They describe the concrete type of selected items together with items itself.

My tool is always the browser. And I provide the #browser method to use this fact explicitly.

I provide default implementations of how to work with selected items in the Calypso browser model:
- selectedItems, returns the actually selected items.
- selectedObjects , returns the actual object of selected items.
- lastSelectedItem
- lastSelectedObject
- lastSelectedObjectIn: items, encapsulates the knowledge of what is the last item in the selection.
- firstSelectedObjectIn: items
- hasSelecteditems

Users can retrieve actual system which browser navigate:
	context system

There are several operation with browser which can be performed using me:
- updateBrowser, it will force the browser to perform full update of navigation data sources
- restoreBrowserState, it should be implemented by subclasses whey they should recover browser state which is described by context instance!
!ClyBrowserContext methodsFor: 'tool controlling' stamp: ''!
showMethodTag: aString
	"Default is to do nothing"! !

!ClyBrowserContext methodsFor: 'browser state' stamp: ''!
updateBrowser
	self browser update! !

!ClyBrowserContext methodsFor: 'browser state' stamp: ''!
restoreBrowserState
	self subclassResponsibility! !

!ClyBrowserContext methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	selectedItems := #()! !

!ClyBrowserContext methodsFor: 'helpers' stamp: ''!
lastSelectedObject
	^self lastSelectedItem actualObject! !

!ClyBrowserContext methodsFor: 'helpers' stamp: ''!
selectedObjects
	^self actualSelectionFrom: selectedItems! !

!ClyBrowserContext methodsFor: 'helpers' stamp: ''!
lastSelectedItem
	^selectedItems first! !

!ClyBrowserContext methodsFor: 'helpers' stamp: ''!
firstSelectedObjectIn: selectedObjects
	^selectedObjects last! !

!ClyBrowserContext methodsFor: 'copying' stamp: ''!
initializeForBrowserStateSnapshot

	selectedItems := selectedItems collect: [ :each | each copyForBrowserStateSnapshot ].
	selectedItems do: [ :each | each ownerDataSource parentItem: nil ].
	tool := nil! !

!ClyBrowserContext methodsFor: 'accessing' stamp: ''!
system
	^tool system! !

!ClyBrowserContext methodsFor: 'testing' stamp: ''!
isAboutBrowserItemType: itemTypeClass

	^selectedItems anySatisfy: [ :each | 
		each type isCalypsoItemType: itemTypeClass ]! !

!ClyBrowserContext methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserContext
	self class = anotherBrowserContext class ifFalse: [ ^false ].
	
	(selectedItems size = anotherBrowserContext selectedItems size)
		ifFalse: [ ^false ].
		
	^selectedItems allSatisfy: [ :each |
		anotherBrowserContext isAboutSelectedItem: each]! !

!ClyBrowserContext methodsFor: 'helpers' stamp: ''!
lastSelectedObjectIn: selectedObjects
	^selectedObjects first! !

!ClyBrowserContext methodsFor: 'accessing - context' stamp: ''!
currentMetaLevelOf: aClass
	"we do not model class side vs instance side"
	^aClass! !

!ClyBrowserContext methodsFor: 'accessing' stamp: ''!
browser
	^tool! !

!ClyBrowserContext methodsFor: 'copying' stamp: ''!
copyForBrowserStateSnapshot

	^self copy 
		initializeForBrowserStateSnapshot;
		yourself! !

!ClyBrowserContext methodsFor: 'testing' stamp: ''!
hasSelectedItems
	^selectedItems notEmpty! !

!ClyBrowserContext methodsFor: 'accessing' stamp: ''!
selectedItems
	^ selectedItems! !

!ClyBrowserContext methodsFor: 'accessing' stamp: ''!
activeQueryView

	^self browser navigationViews detect: [ :each |
		each createSelectionContext class = self class ]! !

!ClyBrowserContext methodsFor: 'drag and drop' stamp: ''!
asDraggableMorph
	^(String streamContents: [ :s| 
		selectedItems 
			do: [ :each | s nextPutAll: each name ]
			separatedBy: [ s space ]]) asStringMorph! !

!ClyBrowserContext methodsFor: 'helpers' stamp: ''!
actualSelectionFrom: browserItemCollection
	^browserItemCollection collect: [ :each | each actualObject ]! !

!ClyBrowserContext methodsFor: 'testing' stamp: ''!
isAboutSelectedItem: aDataSourceItem
	"It can be just last line: #isEqualTo:. 
	But in remote scenario it could lead to few messages to underlying remote objects. 
	It is nice to avoid such interaction.
	So here we first try simplified comparison. And then complete version is used"
	(selectedItems anySatisfy: [ :each | each actualObject == aDataSourceItem actualObject])
		ifTrue: [ ^true ].
	(selectedItems anySatisfy: [ :each | each name = aDataSourceItem name]) 
		ifFalse: [ ^false ].
	^selectedItems anySatisfy: [ :each | each isEqualTo: aDataSourceItem  ]! !

!ClyBrowserContext methodsFor: 'accessing' stamp: ''!
navigationEnvironment
	^self browser navigationEnvironment! !

!ClyBrowserContext methodsFor: 'accessing' stamp: ''!
selectedItems: anObject
	selectedItems := anObject! !

!ClyBrowserContext class methodsFor: 'instance creation' stamp: ''!
ofSelection: aSelection for: aBrowser
	^self of: aSelection detachedItems for: aBrowser! !

!ClyBrowserContext class methodsFor: 'instance creation' stamp: ''!
of: selectedItems for: aBrowser
	^(self for: aBrowser)
		selectedItems: selectedItems! !

!ClyBrowserDialogContext commentStamp: ''!
I represent a context of specific dialog which can be opened from the specific browser.
For example there is ClyBrowserSearchDialog. It opens from the browser to allow user choose specific item from the given environment query.
I allow to bind special context implementation to this kind of dialog which can be different depending on the browser.
For example system browser require special ClySystemSearchDialogContext which implement system related context interface.

Following example shows how to use me to annotate specific kind of browser dialog context:
	ClySystemSearchDialogContext class>>selectionStrategy
		<classAnnotation>
		^ClyContextSelectionStrategy for: (ClyBrowserDialogContext of: ClyBrowserSearchDialog in: ClyFullBrowser)

Internal Representation and Key Implementation Points.

    Instance Variables
	browserClass:		<ClyBrowser class>
	dialogClass:		<Class>!
!ClyBrowserDialogContext methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ dialogClass = anObject dialogClass
		and: [ browserClass = anObject browserClass ]! !

!ClyBrowserDialogContext methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ dialogClass hash bitXor: browserClass hash! !

!ClyBrowserDialogContext methodsFor: 'accessing' stamp: ''!
browserClass: anObject
	browserClass := anObject! !

!ClyBrowserDialogContext methodsFor: 'accessing' stamp: ''!
dialogClass
	^ dialogClass! !

!ClyBrowserDialogContext methodsFor: 'accessing' stamp: ''!
dialogClass: anObject
	dialogClass := anObject! !

!ClyBrowserDialogContext methodsFor: 'testing' stamp: ''!
describes: aBrowserDialog

	^(aBrowserDialog isKindOf: dialogClass)
		and: [ aBrowserDialog browser isKindOf: browserClass]! !

!ClyBrowserDialogContext methodsFor: 'accessing' stamp: ''!
browserClass
	^ browserClass! !

!ClyBrowserDialogContext class methodsFor: 'instance creation' stamp: ''!
ofSearchIn: aBrowserClass
	^self of: ClyBrowserSearchDialogWindow in: aBrowserClass! !

!ClyBrowserDialogContext class methodsFor: 'instance creation' stamp: ''!
of: aDialogClass in: aBrowserClass
	^self new 
		dialogClass: aDialogClass;
		browserClass: aBrowserClass! !

!ClyBrowserItem commentStamp: ''!
I wrap actual object retrieved by query and extend it with information required for the browser:
- name of item
- type of item (a class)
- position inside result items
- depth inside items hierarchy (if hierarchycal result was built)
- properties about actual object

For example you can query classes from system. The result can be sorted by name. Or classes can be arranged in subclass hierarchy. 
In first case I will represent particular class with one position and zero depth. But in another case position of same class will be different and depth could be not zero.
	
Properties are represented by first class objects: subclasses of ClyProperty. To add and access them use following messages:
	- addProperty: aProperty
	- getProperty: aPropertyClass
	- getProperty: aPropertyClass ifAbsent: aBlock
	- hasProperty: aPropertyClass

There are special kind of properties for specific purposes:

There is hierarchy of item tags represented by subclasses of ClySimpleTag. They allow mark object with specific tag. For example there is ClyAbstractItemTag which is used to mark abstract classes and methods.
You can use following methods to manage tags:
	- markWith: aSimpleTagClass
	- isMarkedWith: aSimpleTagClass. It is analogue to #hasProperty:

There is special property ClyItemChildrenTag to mark object that it includes particilar kind of children. Kind of children is represented by class of children type.
For example you can mark class with methods:
	classItem markWithChildrenOf: ClyMethod.
To check that object has particular children use:
	classItem hasChildrenOf: ClyMethod

Another special kind of property is ClyItemLocalHierarchyProperty. It includes number of all local children which exists in item query result. 
For example if you look at classes as a hierarchy then you can see Object and its subclasses. This hierarchy can be limited by package scope.
So in case of one particular package Object can have 10 subclasses. But in another package it can be 30 (for example).
And ClyItemLocalHierarchyProperty represents such local hierarchy size. To access it use following methods:
	- localHierarchySize
	- localHierarchySize: count
ClyItemLocalHierarchyProperty is used by tools to organize tree view for list of items which provide local hierarchy by themselves. Item has no real list of children. But instead it knows count of internal tree. It allows tool hide right number of items when given parent node needs to be collapsed. Important condition here is that property must hold count of full subtree of local hierarchy (not just first level children).

I collect properties using environment plugins. Query result prepares own browser items lazely when they should be returned to the user:

	aBrowserItem prepareIn: environment

But actual preparation is delegated to plugins:

	environment pluginsDo: [ :each | aBrowserItem decorateBy: each].

So every plugin decorates item with properties. At the end decoration is dispatched to the item type which sends concrete typed message back to the plugin. 
For example method decoration is evaluated to:

	aPlugin decorateBrowserItem: aBrowserItem ofMethod: aBrowserItem actualObject.
	
Properties computation can be heavy process and I use special flag #isPrepared to collect them only once.

To create my instances there is class side method:

	ClyBrowserItem named: aString with: anObject

But normally you should ask anObject directly: 
	
	anObject asCalypsoBrowserItem

During instance creation I collect the type of given object:

	anObject calypsoEnvironmentType 

The idea behind item type is to separate it from object class to not depends on single implementation of particular kind of objects. For example there is CompiledMethod, RGMethodDefinition and RG2MethodDefinition. They all represent different model of methods. But for the browser it is important to work with them in same way. So all of them return ClyMethod class as calypsoEnvironmentType. It allows avoid duplication of methods by delegating actual logic to the reusable item type class. 
For example system browser defines commands to be used in context of selected methods. It uses ClyMethod type to attach commands to methods. And they available and work independently from concrete method class. 
But by default the calypso type is the class of object. And it is not necessery to introduce separate type for every kind of item.

I provide several methods to compare items: 

- isSameAs: anotherBrowserItem
It checks that receiver and argument represent same actual object. The #same meaning is based on item type to which I delegate actual comparison:

	type checkCalypsoItem: actualObject isSameAs: anotherBrowserItem actualObject

- isEqualTo: anotherBrowserItem 
It checks that receiver and argument represent equal actual objects. The #equal meaning is based on item type to which I delegate actual comparison:
	type checkCalypsoItem: actualObject isEqualTo: anotherBrowserItem actualObject

- isSimilarTo: anotherBrowserItem
It is very weak comparison which return true for two equaly named items of same type. If they are named differently then isEqualTo: comparison will be result.
The method is used in browser logic to restore desired selection. For example when user selects new class which has the method similar to the prevous method selection of another class.

As you see comparison logic is also delegated to the item type. So in method example all method implementations do not need to duplicate them.

There are few other testing methods:

- representsItemOfType: itemType
It check that browser item belongs to the given type. It uses #includesBehaviour: logic.

- representsObject: anObject
It checks that browser item represents same object as argument. Actual comparison is delegated to the item type.

- representsObjectEqualTo: anObject
It checks that browser item represents object equal to argument. Actual comparison is delegated to the item type.

Internal Representation and Key Implementation Points.

    Instance Variables
	actualObject:		<Object>
	name:		<String>
	position:		<Number>
	depth:		<Number>
	type: <Class>
	properties:		<Collection of<ClyProperty>>
	isPrepared:		<Boolean>	
!
!ClyBrowserItem methodsFor: 'testing' stamp: ''!
hasChildrenOf: itemTypeClass

	^self hasChildrenWhich: [ :childType | childType = itemTypeClass]! !

!ClyBrowserItem methodsFor: 'preparation' stamp: ''!
addProperty: aProperty
	properties add: aProperty! !

!ClyBrowserItem methodsFor: 'preparation' stamp: ''!
decorateBy: anEnvironmentPlugin

	type decorateBrowserItem: self by: anEnvironmentPlugin! !

!ClyBrowserItem methodsFor: 'preparation' stamp: ''!
markWith: simpleTagClass
	self addProperty: simpleTagClass instance! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!ClyBrowserItem methodsFor: 'preparation' stamp: ''!
markWithChildrenOf: anItemTypeClass
	self addProperty: (ClyItemChildrenTag childrenType: anItemTypeClass)! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
actualObject
	^actualObject! !

!ClyBrowserItem methodsFor: 'preparation' stamp: ''!
asCalypsoBrowserItem
	^self! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
position: anObject
	position := anObject! !

!ClyBrowserItem methodsFor: 'preparation' stamp: ''!
prepareIn: aNavigationEnvironment
	isPrepared ifTrue: [ ^self ].
	
	aNavigationEnvironment pluginsDo: [ :each | 
		self decorateBy: each].
	
	isPrepared := true! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
isRoot
	^depth = 0! !

!ClyBrowserItem methodsFor: 'preparation' stamp: ''!
adoptForNewCalypsoQuery

	^self copy! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
type: aClass
	type := aClass! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
depth
	^ depth! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserItem

	type = anotherBrowserItem type ifFalse: [ ^false ].
	
	^name = anotherBrowserItem name or: [ self isEqualTo: anotherBrowserItem ]! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
localHierarchySize

	| property |
	property := self getProperty: ClyItemLocalHierarchyProperty ifAbsent: [ ^0].
	
	^property subtreeSize! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
actualObject: anObject
	actualObject := anObject.
	type := anObject calypsoEnvironmentType! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
isMarkedWith: propertyClass

	^self hasProperty: propertyClass! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
localHierarchySize: childrenCount
	childrenCount = 0 ifTrue: [ ^self ].
	
	self addProperty: (ClyItemLocalHierarchyProperty size: childrenCount).! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!ClyBrowserItem methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	aStream nextPutAll: name.
	aStream nextPut: $).! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
representsItemOfType: aClass
	^type isCalypsoItemType: aClass! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
representsObject: anObject
	actualObject == anObject ifTrue: [ ^true ].
	
	type = anObject calypsoEnvironmentType ifFalse: [ ^false ].
	
	^type checkCalypsoItem: actualObject isSameAs: anObject! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
isSameAs: anotherBrowserItem

	type = anotherBrowserItem type ifFalse: [ ^false ].
	
	^type checkCalypsoItem: actualObject isSameAs: anotherBrowserItem actualObject! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
hasProperty: propertyClass

	^properties anySatisfy: [ :each | each isKindOf: propertyClass ]! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
isPrepared
	^ isPrepared! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
includesActualObject: anObject
	^ self actualObject == anObject! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
getProperty: propertyClass ifAbsent: absentBlock

	^properties detect: [ :each | each isKindOf: propertyClass ] ifNone: absentBlock! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
representsObjectEqualTo: anObject
	actualObject == anObject ifTrue: [ ^true ].
	
	type = anObject calypsoEnvironmentType ifFalse: [ ^false ].
	
	^type checkCalypsoItem: actualObject isEqualTo: anObject! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
type
	^type! !

!ClyBrowserItem methodsFor: '*Calypso-SystemQueries' stamp: ''!
systemDefinition
	
	^self 
		getProperty: ClyItemDefinitionProperty 
		ifAbsent: [ self error: 'No system definition is specified for item' ].! !

!ClyBrowserItem methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	depth := 0.
	properties := OrderedCollection new.
	isPrepared := false! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
isEqualTo: anotherBrowserItem

	type = anotherBrowserItem type ifFalse: [ ^false ].
	
	^type checkCalypsoItem: actualObject isEqualTo: anotherBrowserItem actualObject! !

!ClyBrowserItem methodsFor: 'copying' stamp: ''!
copy
	| copy |
	copy := super copy.
	type prepareCalypsoItemCopy: copy.
	^copy! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
properties: anObject
	properties := anObject! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
properties
	^ properties! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
name
	^name! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
isPrepared: anObject
	isPrepared := anObject! !

!ClyBrowserItem methodsFor: '*Calypso-SystemQueries' stamp: ''!
ensureSystemDefinition: aBlock
	
	self getProperty: ClyItemDefinitionProperty ifAbsent: [ 
		self addProperty: aBlock value]! !

!ClyBrowserItem methodsFor: '*Calypso-SystemQueries' stamp: ''!
systemDefinitionClass
	
	^self systemDefinition definingClass! !

!ClyBrowserItem methodsFor: 'testing' stamp: ''!
hasChildrenWhich: aBlockWithChildType

	^properties anySatisfy: [ :each | 
		(each isKindOf: ClyItemChildrenTag) 
			and: [ aBlockWithChildType value: each childrenType ] ]! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
getProperty: propertyClass 

	^properties detect: [ :each | each isKindOf: propertyClass ]! !

!ClyBrowserItem methodsFor: 'accessing' stamp: ''!
depth: anObject
	depth := anObject! !

!ClyBrowserItem class methodsFor: 'instance creation' stamp: ''!
named: aString with: anObject
	^self new 
		actualObject: anObject;
		name: aString! !

!ClyBrowserItem class methodsFor: 'instance creation' stamp: ''!
with: anObject
	^self new 
		actualObject: anObject! !

!ClyBrowserItemContext commentStamp: ''!
I represent any browser context of the selected items of particular class.

I was introduced to activate browser commands and tools in the context of concrete type of selected items. It avoids duplication of annotaions for every browser type. So you can annotated command in context of ClyMethod. And it will be available in all browser which shows methods.

You can use the scope class directly as context in browser annotations:
	ClyRenameMessageCommand class>>shortcutActivation
		^CmdShortcutCommandActivation by: $r meta for: ClyMethod

Internal Representation and Key Implementation Points.

    Instance Variables
	itemType:		<Class>!
!ClyBrowserItemContext methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ itemType = anObject itemType! !

!ClyBrowserItemContext methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ itemType hash! !

!ClyBrowserItemContext methodsFor: 'accessing' stamp: ''!
itemType
	^ itemType! !

!ClyBrowserItemContext methodsFor: 'testing' stamp: ''!
describes: aBrowserContext

	^aBrowserContext isAboutBrowserItemType: itemType! !

!ClyBrowserItemContext methodsFor: 'accessing' stamp: ''!
itemType: aClass
	itemType := aClass! !

!ClyBrowserItemContext class methodsFor: 'instance creation' stamp: ''!
itemType: scopeClass
	^self new 
		itemType: scopeClass! !

!ClyBrowserItemCursorTest methodsFor: 'tests' stamp: ''!
testAllItems
	
	| allItems unprepared |
	allItems := cursor retrieveAll.
	
	self assert: allItems equals: queryResult items.
	unprepared := allItems reject: [:each | each isPrepared].
	self assert: unprepared isEmpty.
	self assert: (allItems collect: [:each | each position]) asArray equals: (1 to: queryResult size) asArray.! !

!ClyBrowserItemCursorTest methodsFor: 'tests' stamp: ''!
testHasQueryResult

	self assert: cursor queryResult equals: queryResult! !

!ClyBrowserItemCursorTest methodsFor: 'running' stamp: ''!
rawResultItems
	^queryResult items collect: [ :each | each actualObject ]! !

!ClyBrowserItemCursorTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyBrowserQueryExampleResult new! !

!ClyBrowserMock methodsFor: 'mocking' stamp: ''!
spawnQueryBrowserOn: aCollection

	hasSpawned := true.
	elements := aCollection! !

!ClyBrowserMock methodsFor: 'testing' stamp: ''!
hasSpawnedQueryBrowser

	^hasSpawned! !

!ClyBrowserMock methodsFor: 'initialization' stamp: ''!
initialize

	hasSpawned := false! !

!ClyBrowserMock methodsFor: 'testing' stamp: ''!
hasSpawnedQueryBrowserOn: aCollection

	^hasSpawned and: [ elements resultItems asArray = aCollection asArray ]! !

!ClyBrowserModeSwitchMorph commentStamp: ''!
I represent the command which switches the browser to particular mode.
Therefore I use radio button widget to reflect that target browser mode is already active.
I ask the activator #isCommandAppliedToBrowser to detect this state.
I implement this logic in the method #isModeActive.

When user click on radio button I just execute the command.

Internal Representation and Key Implementation Points.

    Instance Variables
	radioButton:		<Morph>!
!ClyBrowserModeSwitchMorph methodsFor: 'accessing' stamp: ''!
addIcon: anIcon

	"do not supported for now"! !

!ClyBrowserModeSwitchMorph methodsFor: 'updating' stamp: ''!
beBoldIfActive

	self isModeActive 
		ifTrue: [ radioButton labelMorph emphasis: TextEmphasis bold emphasisCode]
		ifFalse: [ radioButton labelMorph emphasis: TextEmphasis normal emphasisCode]! !

!ClyBrowserModeSwitchMorph methodsFor: 'testing' stamp: ''!
isModeActive
	^activator isCommandAppliedToBrowser! !

!ClyBrowserModeSwitchMorph methodsFor: 'accessing' stamp: ''!
build
	radioButton := self theme 
		newRadioButtonIn: self
		for: self 
		getSelected: #isModeActive 
		setSelected: #toggleMode:
		getEnabled: nil
		label: self title
		help: nil.
	"self beBoldIfActive."
	self addMorph: radioButton! !

!ClyBrowserModeSwitchMorph methodsFor: 'controling' stamp: ''!
toggleMode: aBool
	
	self executeCommand! !

!ClyBrowserMorph commentStamp: ''!
I am a base class for various browser implementations.
My main subcasses are ClyFullBrowser (for an advanced 4 panes browser) and ClyQueryBrowser (to display results of senders/implementors/...).

I provide UI layout structure for my subclasses:

- all navigation views occupy the top half of the browser.
- the tabs panel is placed at the bottom half of the browser.
- and the toolbar is placed at the middle.

Navigation is represented by ClyQueryView(Morph) instances placed from left to right. This reflects the flow of navigation: selection in the left panel leads to the new content at the right panel.

!!!! Example of Queries 

I create query instances using current state like selections, metalevel scope (class/inst side) and current queries themselves. 
In some cases it is quite complex logic and it requires interaction between different objects. For exampe the construction logic of methodGroupQuery is very complex:
	- the different query class for variable mode (vars in protocols pane)
	- in variable mode the scope is different (vars are shown from all superclasses)
	- extra query composition when query is build from scope of extended classes (grey classes are selected)
	- extra logic to allow default traits visibility
	- some other details.
(it could be extracted to new kind of queries and scopes)

!!!! Browser Logic 
Another part of browser logic is defined in methods like #selectMethod:, #selectClass:, selectPackage:. A browser knows that to select method it should first select its class. To select class it should first select its package. In some cases it is also not trivial logic. Look at selectClass: method. 

Ideally browser should be a model itself independently from UI.  But this point deserves another iteration. The main concern of the current version was to introduce queries to manage browser state. It simplifies a lot of behaviour but it still not enough to get really clean solution. 


!!!! Browser contexts 

Browser contexts are not for maintaining the state. They only represent possible state of components. They are approach to have pluggability points for commands, tabs, toolbars and table decorators. Remember that commands are annotated with activators for particular context where they should be used. Exactly the same logic is used for other parts of browser. Everything you read in Commander chapter is applicable for tabs, table decorators and toolbar items. Tabs are annotated with ClyTabActivationStrategy. Table decorators are annotated with ClyTableDecorationStrategy.

So a browser collects contexts from children because otherwise children will need to know about toolbar and tabs. Now they only know the browser. Also all contexts are used to build spotter command menu (cmd+/). Query views has no information about it.  


!!!! Browser changes 

I implement logic how and when rebuild tabs and toolbar. Any browser change should be wrapped by method #changeStateBy:

	browser changeStateBy: [ packageView selection selectItemsWith: { 'Kernel' asPackage } ]
	
Any selection change can lead to the changes in all related navigation views which follow navigation flow. I ensure in this method that tabs and toolbar will be rebuilt only when navigation will be completely finished. However this is only when all views will set new content and selection that I will update tabs and toolbar.

Also I manage navigation history by allowing go back and forward in the browser. And this method also ensures that intermediate navigation states will not be considered as navigation. Many selection changes can be triggered from single #changeStateBy: call. But I will add only one item to the history.

I provide two methods to force go back and forward navigation: 

	browser navigateBack.
	browser navigateForward.

For more details on history implementation look at ClyNavigationHistory.





!!!! How to create new browsers


Subclasses should implement #initializeNavigationViews to configure the number of navigation panes and their properties.
They should create navigation views using #newNavigationView message: 

	packageView := self newNavigationView.
	
The content of view should be set in another methods (see bellow). During initialization you should only configure structure of the view.
For example by default created view will show single column with the name of item.
But you can configure different label using following method: 

	packageView mainColumn 
		displayItemPropertyBy: [:packageItem | packageItem name, packageItem actualObject classes size asString].

(the argument of the block is instance of ClyDataSourceItem which wrap actual object retrieved by query).

Also to describe navigation flow you should setup selector which should called when user will select any item: 
	
	packageView requestNavigationBy: #packageSelectionChanged.
	 
Look at ClyQueryView(Morph) to find more possible settings and browser senders of #newNavigationView (for example you can add more columns to the view).

To setup the content of the navigation views you should implement method #prepareInitialState. For the package view example it can be: 

	packages := ClyAllPackages sortedFrom: self systemScope.
	packageView showQuery: packages 

You do not need to set up the content of all navigation views. They have kind of empty data source by default.
During navigation you will configure them in the navigation request methods. You will create appropriate queries for them based on new selected objects.

The last responsibility of subclasses is to implement #newWindowTitle. It is used to setup the title of window which contains the browser. And it is updated when state of browser is changed.









Internal Representation and Key Implementation Points.

    Instance Variables
	navigationEnvironment:		<ClyNavigationEnvironment>
	navigationHistory:		<ClyNavigationHistory>
	navigationPanel:		<Morph>
	navigationStarted:		<Boolean>
	navigationViews:		<OrderedCollection of<ClyQueryView>>
	plugins:		<Collection of<ClyBrowserPlugin>>
	systemScope:		<ClySystemScope>
	tabManager:		<ClyTabManager>
	toolPanel:		<Morph>
	toolbar:		<ClyToolbar>!
!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
disableSlowPlugins

	plugins removeAllSuchThat: [ :each | each isSlow]! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateMethodEditor: aMethodEditor! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
initializeNavigationViews
	self subclassResponsibility! !

!ClyBrowserMorph methodsFor: 'tools support' stamp: ''!
toggleFullWindowTabs
	
	| tabMorph |
	tabMorph := tabManager tabMorph.
	(submorphs includes: tabMorph ) 
		ifFalse: [ self addMorph: tabMorph fullFrame: LayoutFrame identity]
		ifTrue: [ toolPanel addMorphBack: tabMorph ]! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
requestRemoveClassStrategyFor: classes

	| result strategies title |
	strategies := SycRemoveClassStrategy
		              createForBrowser: self
		              classes: classes.

	strategies size = 1 ifTrue: [ ^ strategies first ].
	
	title := classes size = 1
		ifTrue: [ 'Class has references, subclasses, or users' ]
		ifFalse: [ 'Classes have references, subclasses, or users' ].

	result := UIManager default
		          chooseFrom:
		          (strategies collect: [ :each | each userRequestString ])
		          values: strategies
		          title: title.

	^ result ifNil: [ SycNotRemoveClassStrategy new ]! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
spawnHierarchyForClass: aClass selector: aSymbolOrNil
	"For compatibility with SystemNavigation 
	we should ensure current image environment if it is absent".
	navigationEnvironment ifNil: [ 
		self navigationEnvironment: ClyNavigationEnvironment currentImage.
		self setUpAvailablePlugins].
	self spawnBrowser: ClyFullBrowserMorph withState: [ :browser | 
		browser selectClass: aClass.
		browser switchToFullClassHierarchy.
		aSymbolOrNil ifNotNil: [ 
			browser selectMethod: aClass >> aSymbolOrNil ]
	]! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
addPlugin: aBrowserPlugin
	plugins detect: [ :each | each class = aBrowserPlugin class ] ifFound: [ ^self ].
	
	aBrowserPlugin browser: self.
	plugins add: aBrowserPlugin! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
browseReferencesTo: aSymbol
	
	self browseReferencesTo: aSymbol from: self system! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
confirmEmptySystemQuery: aQuery excluding: classes
	
	| showResult result |
	
	result := aQuery execute.
	(result isEmpty or: [ ((result items collect: [:each | each origin]) difference: classes ) isEmpty]) ifTrue: [ ^#(true false) ].
	
	showResult := UIManager default confirm: 'There are '
		, result size asString, ' ', aQuery description, '. Show them?'.
	showResult ifTrue: [self spawnQueryBrowserOn: aQuery].
	^Array with: false with: showResult! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
prepareInitialState
	self subclassResponsibility! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
navigationHistory
	^ navigationHistory! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
switchFocusToPreviousPane

	| focused next |
	focused := navigationViews detect: [ :each | each hasKeyboardFocus ] ifNone: [ ^self ].
	next := navigationViews before: focused ifAbsent: [ ^self ].
	next takeKeyboardFocus! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
prepareDefaultState
	"The initial state is required state for browser.
	But default state is the state which should be applyed 
	when user to not setup any custom state to the browser.
	For example browser can be opened with particulal selected item.
	In that case it will be initial state of browser and default state will be ignored"
	self prepareInitialState! !

!ClyBrowserMorph methodsFor: 'opening/closing' stamp: ''!
okToChange

	^tabManager okToChange! !

!ClyBrowserMorph methodsFor: 'testing' stamp: ''!
hasPluginOf: aBrowserPluginClass
	^plugins anySatisfy: [ :each | each class = aBrowserPluginClass ]! !

!ClyBrowserMorph methodsFor: 'testing' stamp: ''!
hasPlugin: aBrowserPlugin
	^self hasPluginOf: aBrowserPlugin class! !

!ClyBrowserMorph methodsFor: 'testing' stamp: ''!
isNavigationPanelFocused

	^navigationViews anySatisfy: [ :each | each hasKeyboardFocus ]! !

!ClyBrowserMorph methodsFor: 'keymapping' stamp: ''!
kmDispatcher

	^ CmdKMDispatcher attachedTo: self! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
browseClassNamed: aString
	
	| classToBrowse |
	classToBrowse := (self system bindingOf: aString)
		ifNil: [ self chooseClassToBrowseFrom: aString ]
		ifNotNil: [:binding | classToBrowse := binding value].
	classToBrowse ifNil: [ ^self ].
	classToBrowse isClassOrTrait ifFalse: [ classToBrowse := classToBrowse class ].
	
	self spawnBrowser: ClyFullBrowserMorph withState: [ :browser |
		browser selectClass: classToBrowse]! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
changeStateOf: aQueryView by: aBlock
	
	| newTools |
	self changeStateBy: [
		aBlock value.
		aQueryView changesWasInitiatedByUser ifTrue: [
			newTools := OrderedCollection new.	
			tabManager buildToolsOn: newTools for: aQueryView createSelectionContext.
			tabManager desiredSelection: (newTools collect: [:each | each class])	].
	]! !

!ClyBrowserMorph methodsFor: 'tools support' stamp: ''!
decorateTool: aBrowserTool

	plugins do: [ :each | each decorateTool: aBrowserTool  ]! !

!ClyBrowserMorph methodsFor: 'updating' stamp: ''!
itemsChanged
	
	navigationStarted ifTrue: [ ^self ].
	navigationStarted := true.

	[self rebuildToolsForChangedEnvironment] ensure: [ navigationStarted := false ]! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
confirmUnusedVariablesInDefiningClass: variables
	
	| refQuery classScope |
	classScope := ClyBothMetaLevelClassScope ofAll: (variables collect: [:each | each definingClass]) in: navigationEnvironment. 
	refQuery := ClyVariableReferencesQuery ofAny: variables from: classScope.
	
	^self confirmEmptySystemQuery: refQuery! !

!ClyBrowserMorph methodsFor: 'tools support' stamp: ''!
confirmDiscardChanges

	^self confirm: 'Changes have not been saved.
Is it OK to discard changes?'! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
newNavigationView
	| view |
	view := ClyQueryViewMorph for: self. 
	navigationViews add: view.
	^view! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	navigationStarted := false.
	navigationHistory := ClyNavigationHistory new.
	plugins := SortedCollection sortBlock: [ :a :b | a priority <= b priority ].
	self extent: self initialExtent.
	self changeProportionalLayout.
	self initializeToolsPanel.
	self initializeNavigationPanel.
	self addPaneSplitters! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
initialExtent
	^ 850@620! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
plugins
	^plugins! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
initializeNavigationPanel
	
	| eachViewExtent lastViewLeft |
	navigationPanel := PanelMorph new.
	navigationPanel name: 'navigation panel'.
	navigationPanel changeProportionalLayout.	
	navigationViews := OrderedCollection new.
	self initializeNavigationViews.
	
	eachViewExtent := 1.0 / navigationViews size.
	lastViewLeft := 0.0.
	navigationViews do: [ :each | | frame |
		frame := (lastViewLeft @ 0.0 corner: lastViewLeft + eachViewExtent @ 1.0) asLayoutFrame.
		each == navigationViews last ifFalse: [ 
			frame := frame rightOffset: -4 ].
		navigationPanel 
			addMorph: each 
			fullFrame: frame.
		lastViewLeft := lastViewLeft + eachViewExtent ].
	
	navigationPanel addPaneSplitters.
	self addMorph: navigationPanel fullFrame: ((0.0 @ 0 corner: 1.0 @ 0.5) asLayoutFrame bottomOffset: toolbar height negated)! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
changeStateBy: aBlock

	| state navigationFailed |
	navigationStarted ifTrue: [^aBlock value].
	navigationStarted := true.
	navigationFailed := false.
	state := self snapshotState.
	^[
		aBlock on: Error do: [:err | 
			navigationFailed := true. "this flag prevents any UI update in case of error"
			err pass]
	] ensure: [ 
		navigationStarted := false.
		navigationFailed | (state isCurrentStateOf: self) ifFalse: [ 
			self recordNavigationState: state.
			self updateWindowTitle.				
			self rebuildAllTools]]! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
removePlugin: aBrowserPlugin

	plugins removeAllSuchThat: [ :each | each class = aBrowserPlugin class ]! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
systemScope: aSystemScope
	systemScope := aSystemScope! !

!ClyBrowserMorph methodsFor: 'opening/closing' stamp: ''!
windowIsClosing

	navigationViews do: [ :each | each windowIsClosing ].
	tabManager windowIsClosing.
	self window ifNotNil: [ :w |
		w
			removeMorph: self;
			updatePanesFromSubmorphs;
			model: nil]! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
allNavigationScopes
	
	| defaultScope |
	defaultScope := self defaultNavigationScope.
	
	^self systemScope = defaultScope 
		ifTrue: [ {self systemScope} ]
		ifFalse: [ { self systemScope. defaultScope } ]! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
system
	^ navigationEnvironment system! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
confirmEmptySystemQuery: aQuery
	
	| showResult result |
	
	result := aQuery execute.
	result isEmpty ifTrue: [ ^true ].
	
	showResult := UIManager default confirm: 'There are '
		, result size asString, ' ', aQuery description, '. Show them?'.
	showResult ifTrue: [self spawnQueryBrowserOn: aQuery].
	^false! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
setUpAvailablePlugins

	ClyBrowserPlugin allSubclasses 
		select: [ :each | each isAutoActivated ]
		thenDo: [ :each | self addPlugin: each new ]! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
spawnQueryBrowserOn: aQuery
	
	self spawnQueryBrowserOn: aQuery withState: []! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
navigationContextsDo: aBlock

	navigationViews do: [ :each | aBlock value: each createSelectionContext ]! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
browseImplementorsOf: aSymbol
	| classBinding classToBrowse |
	aSymbol first isUppercase ifTrue: [ 
		classBinding := self system bindingOf: aSymbol.
		classBinding ifNotNil: [ 
			classToBrowse := classBinding value.
			classToBrowse isClassOrTrait ifFalse: [ classToBrowse := classToBrowse class ].
			^self spawnBrowser: ClyFullBrowserMorph withState: [ :browser | 
				browser selectClass: classToBrowse]]].
	
	self spawnQueryBrowserOn: (ClyMessageImplementorsQuery of: aSymbol)! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
browseReferencesTo: aSymbol from: anEnvironment
	
	| classBinding |
	aSymbol isSymbol and: [ aSymbol first isUppercase ifTrue: [ 
		classBinding := anEnvironment bindingOf: aSymbol.
		classBinding ifNotNil: [ 
			^self spawnQueryBrowserOn: (ClyClassReferencesQuery of: classBinding)]]].
		
	self browseSendersOf: aSymbol! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
browseSendersOf: aSymbol
	
	self spawnQueryBrowserOn: (ClyMessageSendersQuery of: aSymbol)! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
confirmUnusedClasses: classes
	"Returns a vector of size 2
	The first value is TRUE when it doesn't have any reference, subclass or is used (for traits), otherwise is FALSE.
	The second value is TRUE when in case of having references, subclasses or users and the user agreed to be shown those references, otherwise is FALSE. "
	| refQuery noUsers answer subclasses users |
	
	refQuery := ClyClassReferencesQuery toAny: classes from: self systemScope.	
	"we need to exclude both the class and instance side of the class"
	noUsers := self confirmEmptySystemQuery: refQuery excluding: (classes flatCollect: [ :each | { each . each classSide } ]).
	subclasses := (classes flatCollect: [:each | each subclasses]) copyWithoutAll: classes.
	subclasses ifNotEmpty: [ 
		noUsers at: 1 put: false.
		answer := UIManager default confirm: 'There are subclasses. Show them?'.
		answer ifTrue: [ self spawnQueryBrowserOn: (ClyConstantQuery returning: subclasses).
			noUsers at: 2 put: true. ] ].
	
	users := (classes flatCollect: [:each | each users]) copyWithoutAll: classes.
	users ifNotEmpty: [ 
		noUsers at: 1 put: false.
		answer := UIManager default confirm: 'There are users of trait. Show them?'. 
		answer ifTrue: [ self spawnQueryBrowserOn: (ClyConstantQuery returning: users).
			noUsers at: 2 put: true. ]].
	^noUsers! !

!ClyBrowserMorph methodsFor: 'opening/closing' stamp: ''!
openAnotherBrowser: aBrowser
	aBrowser open! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
requestRemoveMethodStrategyFor: methods
	| selectors result strategies caption  senders senderCount plural |
	
	selectors := (methods collect: [ :each | each selector ] as: IdentitySet) asArray.	
	
	senders := (ClyMessageSendersQuery ofAny: selectors from: self defaultNavigationScope) execute.
	(self allowSilentlyRemoveMethods: methods whichHaveSenders: senders)
		ifTrue: [ ^SycSilentlyRemoveMethodStrategy new ].

	strategies := SycRemoveMethodStrategy createAllForBrowser: self.
	senderCount := senders size.
	plural := '' asPluralBasedOn: senderCount.
	
	caption := selectors size > 1 
		ifTrue: [ 'There are {1} sender{2}' format: {senderCount. plural}]
		ifFalse: ['The message #{1} has {2} sender{3}' format: {selectors anyOne. senderCount. plural}].	
			
	result := UIManager default 
		chooseFrom: (strategies collect: [:each | each userRequestString]) values: strategies title: caption.
		
	^result ifNil: [ SycNotRemoveMethodStrategy new ]! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
ignoreNavigationDuring: aBlock

	navigationStarted ifTrue: [^aBlock value].
	navigationStarted := true.
	aBlock ensure: [ navigationStarted := false ]! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
activeStatusBar

	^tabManager activeStatusBar! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
wasSpawnedFrom: aBrowser
	
	self recordNavigationState:  (ClyAccrossWindowNavigationState from: aBrowser).! !

!ClyBrowserMorph methodsFor: 'opening/closing' stamp: ''!
openInWindow: aWindow
	| groupWindow myWindow |
	groupWindow := self createWindowGroupFrom: aWindow.
	
	myWindow := self buildWindow.
	groupWindow addWindow: myWindow.
	myWindow activate.
	myWindow announceOpened! !

!ClyBrowserMorph methodsFor: 'tools support' stamp: ''!
withTool: aToolClass do: aBlock
	^tabManager withTool: aToolClass do: aBlock! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
spawnFullBrowser
	
	^self spawnBrowser: ClyFullBrowserMorph withState: [ :browser | 
		self navigateSpawnedFullBrowser: browser]! !

!ClyBrowserMorph methodsFor: 'opening/closing' stamp: ''!
createWindowGroupFrom: currentWindow
  | group pos ext |
	(currentWindow ownerThatIsA: GroupWindowMorph) ifNotNil: [:existing | ^existing].
	
	pos := currentWindow position.
	ext := currentWindow extent.
	group := ClyGroupWindowMorph new.
	group addWindow: currentWindow.
	(group openInWindowLabeled: currentWindow label) 
 		extent: ext;
		position: pos.
	^group! !

!ClyBrowserMorph methodsFor: 'updating' stamp: ''!
newWindowTitle
	self subclassResponsibility! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
ensureInitialState

	(navigationViews anySatisfy: [ :each | each hasRealQuery ])
		ifTrue: [ ^self].
		
	self prepareDefaultState! !

!ClyBrowserMorph methodsFor: 'context' stamp: ''!
createCommandContext
	"Some subclasses needs general global context where commands can be attached
	independently from the actual internal widget under focus. 
	They should override this method returning appropriate global context instance.
	But by default it is undefined unknown context"
	
	^ClyUnknownBrowserContext for: self! !

!ClyBrowserMorph methodsFor: 'updating' stamp: ''!
setWindowTitle: aString in: aWindow

	aWindow setLabel: aString! !

!ClyBrowserMorph methodsFor: 'updating' stamp: ''!
update

	navigationViews do: [ :each | each update ]! !

!ClyBrowserMorph methodsFor: 'opening/closing' stamp: ''!
open
	| window |
	
	self ensureInitialState.
	window := self openInWindow.
	window model: self.
	self updateWindowTitle.
	window minimumExtent: 675@500.0 ! !

!ClyBrowserMorph methodsFor: 'tools support' stamp: ''!
focusActiveTab
	tabManager focusActiveTab! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
systemScope
	^systemScope ifNil: [systemScope := navigationEnvironment systemScope]! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
prepareInitialStateBy: aBlock
	
	navigationHistory ignoreNavigationDuring: [		
		self prepareInitialState.
		aBlock valueWithPossibleArgument: self]! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
snapshotState
	
	^ClyBrowserState of: self! !

!ClyBrowserMorph methodsFor: 'tools support' stamp: ''!
searchDialog
	^ClyBrowserSearchDialogWindow for: self! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
allContexts

	| result |
	result := OrderedCollection new.
	
	self allContextsDo: [:each | result add: each ].
	
	^result! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
navigationEnvironment: aNavigationEnvironment
	navigationEnvironment := aNavigationEnvironment! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
allowSilentlyRemoveMethods: methods whichHaveSenders: senders

	| singleSender sendersCount |
	sendersCount := senders size.
	sendersCount = 0 ifTrue: [ ^true].
	methods size = 1 & (sendersCount = 1) ifFalse: [^false].
	 
	singleSender := senders itemAt: 1.
	^singleSender == methods first! !

!ClyBrowserMorph methodsFor: 'opening/closing' stamp: ''!
close
	| currentWindow |
	currentWindow := self window.
	
	(currentWindow ownerThatIsA: GroupWindowMorph) ifNotNil: [:group | 
		^self okToChange ifTrue: [  
			[group removeWindow: currentWindow] 
				on: ProvideAnswerNotification do: [:notification | 
					"We already got answer from okToChange check above"
					notification resume: true]]].
	
	currentWindow close! !

!ClyBrowserMorph methodsFor: 'updating' stamp: ''!
rebuildToolbar

	toolbar updateItems! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
spawnQueryBrowserOn: aQuery withState: navigationBlock
	| targetQuery |
	targetQuery := aQuery.
	aQuery isBoundToEnvironment ifFalse: [ 
		targetQuery := aQuery withScope: self defaultNavigationScope].
	
	targetQuery scope = self systemScope ifTrue: [ 
		"If query is empty in system (global) scope then it is empty in any other scope.
		In that case we do not need a query browser because it will be always empty and useless"
		targetQuery semiAsync hasEmptyResult ifTrue: [ 
			"For slow queries we will not wait and open a browser to indicate execution progress"
			^self inform: 'There are no ', targetQuery description ]  ].
	
	self spawnBrowser: ClyQueryBrowserMorph withState: [ :browser | 
		browser queryScopes: self allNavigationScopes.
		browser showResultOf: targetQuery.
		navigationBlock valueWithPossibleArgs: {browser}]! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
navigationViews
	^ navigationViews! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
navigateForward
	navigationHistory redoNavigationOf: self! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
navigationHistory: aNavigationHistory
	navigationHistory := aNavigationHistory! !

!ClyBrowserMorph methodsFor: 'updating' stamp: ''!
updateWindowTitle

	self window ifNotNil: [ :w | 
		self setWindowTitle: self newWindowTitle in: w.
		"in the case when window is managed as tab by window group
		we should set up top group window label too"
		(self ownerThatIsA: GroupWindowMorph) ifNotNil: [:group | 
			group window ifNotNil: [:mainWindow |
				self setWindowTitle: w labelString in: mainWindow]]
	]! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
switchFocusToNextPane

	| focused next |
	focused := navigationViews detect: [ :each | each hasKeyboardFocus ] ifNone: [ ^self ].
	next := navigationViews after: focused ifAbsent: [ ^self focusActiveTab ].
	next takeKeyboardFocus! !

!ClyBrowserMorph methodsFor: 'opening/closing' stamp: ''!
buildWindow	
	| window |
	window := (SystemWindow labelled: self newWindowTitle) model: self.
	window 
		addMorph: self frame: (0@0 extent: 1@1);
		updatePaneColors.
	^window! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
confirmUnusedVariables: variables
	
	| refQuery |
	refQuery := ClyVariableReferencesQuery ofAny: variables from: self systemScope.
	
	^self confirmEmptySystemQuery: refQuery! !

!ClyBrowserMorph methodsFor: 'updating' stamp: ''!
rebuildAllTools

	tabManager updateTools.
	self rebuildToolbar! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
navigateBack
	navigationHistory undoNavigationOf: self! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
defaultNavigationScope
	
	^self systemScope! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
spawnBrowser: aBrowserClass withState: navigationBlock
	| browser |
	browser := aBrowserClass on: navigationEnvironment systemScope: self systemScope.
	browser disablePluginsWhichAreNotIn: self.
	
	browser prepareInitialStateBy: navigationBlock.
	self openAnotherBrowser: browser.
	browser wasSpawnedFrom: self.
	^browser! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
toolbar
	^toolbar! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
isMethodSelected: aMethod

	^self methodSelection includesActualObject: aMethod! !

!ClyBrowserMorph methodsFor: 'initialization' stamp: ''!
initializeToolsPanel
	toolbar := ClyToolbarMorph of: self.
	tabManager := ClyNotebookManager of: self.
	
	toolPanel := PanelMorph new.
	toolPanel name: 'tools panel'. 
	toolPanel 
		changeTableLayout;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		listDirection: #topToBottom.
	self addMorph: toolPanel fullFrame: ((0.0 @ 0.5 corner: 1.0 @ 1.0) asLayoutFrame topOffset: toolbar height negated).

	toolPanel addMorphBack: toolbar.
	toolPanel addMorphBack: tabManager tabMorph! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
allContextsDo: aBlock

	self navigationContextsDo: aBlock.
	
	tabManager tools 
		select: [ :each | each isKindOf: ClyTextEditorToolMorph ]
		thenDo: [ :each | aBlock value: each createTextContext ]! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
tabManager
	^tabManager! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
disablePluginsWhichAreNotIn: aBrowser

	plugins removeAllSuchThat: [ :each | 
		each isAutoActivated and: [ (aBrowser hasPlugin: each) not ] ]! !

!ClyBrowserMorph methodsFor: 'accessing' stamp: ''!
navigationEnvironment
	^ navigationEnvironment! !

!ClyBrowserMorph methodsFor: 'updating' stamp: ''!
rebuildToolsForChangedEnvironment

	tabManager updateToolsForChangedEnvironment.
	self rebuildToolbar! !

!ClyBrowserMorph methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
chooseClassToBrowseFrom: aClassNamePattern
	| query result |
	query := (ClyAllClassesQuery sortedFrom: self systemScope)
		 filteredBy: (ClyItemNameFilter substringPattern: aClassNamePattern).
	result := query execute.
	result isEmpty ifTrue: [ ^nil ].
	result size = 1 ifTrue: [ ^result items first ].
	
	^[self searchDialog 
		requestSingleObject: 'Choose a class to browse...' 
		from: query] on: CmdCommandAborted do: [ nil ]! !

!ClyBrowserMorph methodsFor: 'navigation' stamp: ''!
recordNavigationState: aBrowserNavigationState
	navigationHistory recordState: aBrowserNavigationState! !

!ClyBrowserMorph class methodsFor: 'tools registration' stamp: ''!
beAllDefault
	<script>
	self subclasses select: [ :each | each canBeDefault  ] thenDo: [ :each | each beDefaultBrowser ]! !

!ClyBrowserMorph class methodsFor: 'instance creation' stamp: ''!
on: aNavigationEnvironment
	^self new 
		navigationEnvironment: aNavigationEnvironment;
		setUpAvailablePlugins! !

!ClyBrowserMorph class methodsFor: 'testing' stamp: ''!
canBeDefault
	^self class includesSelector: #beDefaultBrowser! !

!ClyBrowserMorph class methodsFor: 'instance creation' stamp: ''!
on: aNavigationEnvironment systemScope: aSystemScope
	^(self on: aNavigationEnvironment)
		systemScope: aSystemScope! !

!ClyBrowserNavigationCommand commentStamp: ''!
I am a root of navigation command classes.

I just define common places (activations) where commands should be accessible.
By default shorcuts are alt+left and alt+right to go back and forward.!
!ClyBrowserNavigationCommand class methodsFor: 'activation' stamp: ''!
textEditorShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: self defaultShortcut for: ClyTextEditorContext! !

!ClyBrowserNavigationCommand class methodsFor: 'activation' stamp: ''!
defaultShortcut
	<classAnnotationDependency>
	
	self subclassResponsibility! !

!ClyBrowserNavigationCommand class methodsFor: 'activation' stamp: ''!
browserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: self defaultShortcut for: ClyBrowserContext! !

!ClyBrowserNavigationCommand class methodsFor: 'activation' stamp: ''!
browserTabActivation
	<classAnnotation>
	
	^ClyBrowserTabCommandActivation for: ClyBrowserContext! !

!ClyBrowserNavigationCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyBrowserNavigationCommand! !

!ClyBrowserPlugin commentStamp: ''!
I am a root of the hierarchy of browser plugins.

My subclasses have two responsibilities:

- they can decorate browser tabs
- they can restrict table decorations

To decorate browser tab my subclasses should implement

- decorateTool: aBrowserTool 

Argument is normal morph. So subclasses can do with it whatever they want: 
- add new widgets 
- style some properties 
- force some selections

Plugins can be used to restrict table decoration of the browser.
Concrete plugin package can provide special kinds of table decorators. And it can be improtant to activate them only when particular browser plugin is actually installed into the browser.
So plugin itself do not need to implement anything special for this. Other objects can check that browser includes it.

By default new browser instances collect all auto activated plugins. It is based on method class side #isAutoActived which is true by default.
So as soon as you create new plugin class it will be present in new browser instances.
You can enable/disable plugin manually:

	ClyBrowserPlugin disable. 
	ClyBrowserPlugin enable.
	
I have class side variable #isAutoActivated which keeps this state.
	
Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>!
!ClyBrowserPlugin methodsFor: 'testing' stamp: ''!
isAutoActivated
	^self class isAutoActivated! !

!ClyBrowserPlugin methodsFor: 'accessing' stamp: ''!
priority
	^100! !

!ClyBrowserPlugin methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyBrowserPlugin methodsFor: 'testing' stamp: ''!
isSlow
	^false! !

!ClyBrowserPlugin methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!ClyBrowserPlugin methodsFor: 'tools decoration' stamp: ''!
decorateTool: aBrowserTool! !

!ClyBrowserPlugin class methodsFor: 'testing' stamp: ''!
disable
	isAutoActivated := false! !

!ClyBrowserPlugin class methodsFor: 'testing' stamp: ''!
enable
	isAutoActivated := true! !

!ClyBrowserPlugin class methodsFor: 'testing' stamp: ''!
isAutoActivated
	^isAutoActivated ifNil: [ true ]! !

!ClyBrowserQueryCache commentStamp: ''!
I represent the cache of browser items retrieved by query. I have start position of loaded items, actual cache size and cached items.

My instances can be created using:

	ClyBrowserQueryCache withSize: cacheSize.
	ClyBrowserQueryCache filledBy: aBrowserQueryResult startingAt: startPosition size: cacheSize

I am used by ClyBrowserQueryCursor to cache observed items. It uses first instantiation method to prepare initial cache. It not loads any items from query result. Items are loaded explicitly by one of my methods: 
	- loadItemOf: aBrowserQueryResult at: position. It checks if given position is already cached and if it is not then It loads new portion of items starting from requested position.
	- loadItemsOf: aBrowserQueryResult startingWhere: conditionBlock. It asks given result to load new portion of items starting at position where conditionBlock is true. At the end method will return true if such item is found and false otherwise. If no items were found the current cached items will be not changed.
	
Second method is used when cursor performs full items update. In that case query result itself is asked to create full update object which includes new cache. It is important for remote scenario because in that case result is remote object and in one request it will return complete cache object including total result size, starting position and updated items.
I am supposed to be used by loading new items into cache from different positions. If original result is changed completaly the new cache instance should be requested from it. For example if user removes method from class it will change total size of class methods. In that case all observing cursors should request updated information:

	update := cache createFullUpdateOf: aBrowserQueryResult.
	updatedCache := update itemCache

It returns new instance of cache with updated items and total result size. In remote scenario it will return all information in one request.
	
I provide few methods to simplify access to my cached items: 
	- itemAt: globalPosition. It returns cached item at position of underlying query result. globalPosition here is not index inside cache. It is index inside full query result. So the method computes local cache position and if cache has no such item then error is signalled.
	- findItemsWith: actualObjects forAbsentDo: absentBlock. it returns items which represent actualObjects. If there is no item for some of given objects method uses absentBlock result.
	- findItemWhich: blockCondition ifExists: presentBlock. It finds item in cache which satisfies given condition. And if item exists then presentBlock is evaluated with it.
	
My cached items are always prepared ClyBrowserItem instances. All their properties are precomputed by plugins and ready to use. It is logic of browser query result to prepare items requested by user. Which means for the browser that only visible items collect properties.

Internal Representation and Key Implementation Points.

    Instance Variables
	items:		<SequenceableCollection of<ClyBrowserItem>>
	sizeLimit:		<Integer>
	startPosition:		<Integer>!
!ClyBrowserQueryCache methodsFor: 'accessing' stamp: ''!
findItemWhich: blockCondition ifExists: presentBlock

	items detect: blockCondition ifFound: presentBlock! !

!ClyBrowserQueryCache methodsFor: 'accessing' stamp: ''!
findItemsWith: actualObjects forAbsentDo: absentBlock
	"it returns items which represent actualObjects.
	If there is no item for some of given objects method uses absentBlock result.
	For comparision cache uses identity while normally content delegates comparison to environment property which by default is equality.
	We use identity for cache because with remote scenario actual objects will be proxies which will send remote messages for each object to compare	and we want to escape it"
	
	^actualObjects collect: [ :eachObject |
		items detect: [ :item | item actualObject == eachObject ] ifNone: absentBlock]! !

!ClyBrowserQueryCache methodsFor: 'testing' stamp: ''!
includesItemAt: position

	^position between: startPosition and: startPosition + items size - 1! !

!ClyBrowserQueryCache methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	startPosition := 0.
	items := Array empty! !

!ClyBrowserQueryCache methodsFor: 'controlling' stamp: ''!
createFullUpdateOf: aBrowserQueryResult

	^aBrowserQueryResult createUpdateWithItemsStartingAt: startPosition count: sizeLimit! !

!ClyBrowserQueryCache methodsFor: 'accessing' stamp: ''!
startPosition: anObject
	startPosition := anObject! !

!ClyBrowserQueryCache methodsFor: 'accessing' stamp: ''!
startPosition
	^ startPosition! !

!ClyBrowserQueryCache methodsFor: 'controlling' stamp: ''!
loadItemOf: aBrowserQueryResult at: position
	(self includesItemAt: position) ifTrue: [ ^ self ].
	
	startPosition := position.
	self fillItemsFrom: aBrowserQueryResult! !

!ClyBrowserQueryCache methodsFor: 'controlling' stamp: ''!
loadItemsOf: aBrowserQueryResult startingWhere: conditionBlock
	
	| newItems |
	newItems := aBrowserQueryResult itemsStartingWhere: conditionBlock count: sizeLimit.
	newItems ifEmpty: [ ^false  ].
	
	startPosition := newItems first position.
	items := newItems.
	^true! !

!ClyBrowserQueryCache methodsFor: 'accessing' stamp: ''!
sizeLimit: anObject
	sizeLimit := anObject! !

!ClyBrowserQueryCache methodsFor: 'private' stamp: ''!
fillItemsFrom: aBrowserQueryResult

	items := aBrowserQueryResult itemsStartingAt: startPosition count: sizeLimit! !

!ClyBrowserQueryCache methodsFor: 'accessing' stamp: ''!
items: anObject
	items := anObject! !

!ClyBrowserQueryCache methodsFor: 'accessing' stamp: ''!
sizeLimit
	^ sizeLimit! !

!ClyBrowserQueryCache methodsFor: 'accessing' stamp: ''!
itemAt: globalPosition

	^items at: globalPosition - startPosition + 1! !

!ClyBrowserQueryCache methodsFor: 'accessing' stamp: ''!
items
	^ items! !

!ClyBrowserQueryCache class methodsFor: 'instance creation' stamp: ''!
withSize: cacheSize

	^self new 
		sizeLimit: cacheSize! !

!ClyBrowserQueryCache class methodsFor: 'instance creation' stamp: ''!
filledBy: aBrowserQueryResult startingAt: startPosition size: cacheSize

	^(self withSize: cacheSize)
		startPosition: startPosition;
		fillItemsFrom: aBrowserQueryResult! !

!ClyBrowserQueryCursor commentStamp: ''!
I organize stream access to query result represented with ClyBrowserItem instances.

I can be opened on any query result:
	aQueryResult openBrowserCursorFor: anObserver 
Or you can request me directly from query: 
	aQuery openBrowserCursorFor: anObserver 
It executes given aQuery and cursor is opened on the result like in first case.

The argument anObserver here is subscribed by result on changes. It is responsibility of anObserver to update its cache when it receives notification. Result sent #itemsChanged to it.
So I am passive object. Users should react on result changes and request me for update.
I can't be active and subscribe on result by myself because in remote scenario it would not work. I am supposed to be transfered by value to the client and it leads to such restrictions.

So I am always created with observer which is subscribed on result changes. When users do not need cursor anymore they should close it:
	aCursor close 
It will unsubscribe observer. I keep reference to it im my variable itemObserver.
The result of #close operation is ClyClosedBrowserCursor instance. So users can replace my instance with it to indicate closed state:
	cursor := cursor close.

I cache part of result items and load more by demand. When user ask next item I check cache for it and if it is not in cache I load new part of items and use it as a new cache.
Loaded items are always prepared. Observed query result computes properties of cached items when cache is created or updated. 

My cache is represented by instance of ClyBrowserQueryCache which maintains start position, cache size and cached items. 
When user asks me for items at given position which are not exist in cache I move cache to requested position which loads new portion of items.
When user asks me to update items I retrieve new updated cache from query result. It returns new cache instance with updated items, total result size and result metadata:
	aCursor updateItemCache

Together with item cache I keep total result size and result metadata.
Metadata is an instance of ClyQueryResultMetadata which represents information about result in general. Internally it is collection of properties collected by environment plugins from all result items. 
To access it use following methods:
- getMetaProperty: aPropertyClass
- hasMetaProperty: aPropertyClass
- metadata 

All logic around stream access with cache and metadata follows one important goal: provide optimized access to remote items which was build by query in remote environment.
In remote scenario cursor, cache and metadata is transfered by value to client side. But observed result is represented by proxy. 
Cache and metadata allow avoid communication with remote side because they include all required data to build tools to browse result items.
Communication will happen only when new portion of data is needed or when observed result is changed. For UI it means that only visible part of items is loaded by tools and usually in one request.

To access items one by one use following methods:
	- currentItem 
	- moveTo: positionNumber
	- moveToStart
	- moveToNext
	- moveToItemWhich: conditionBlock
	- nextItem. It moves cursor to next position and returns new current item
	
To find group of items:
	- findItemsWhich: conditionBlock 
	- findItemsWith: actualObjects. it returnes browser items which represent actualObjects. Result will be in same order and with same size as given actualObjects array. If some object is absent in result then it will be nil in place of it. 
	- findItemsSimilarTo: sampleBrowserItems. There is criteria of similarity between two browser items. For example two items with same name are similar to each other. It is usefull for tools to restore selection when data source is changed.
	
There are also methods to retrieve all result items: 
	- retrieveAll. It returns all items of observed result. All items will be prepared as in other requests.
  
Internal Representation and Key Implementation Points.

    Instance Variables
	cache:		<ClyBrowserQueryCache>
	metadata:		<ClyQueryResultMetadata>
	queryResult:		<ClyBrowserQueryResult>
	position:		<SmallInteger>
	itemCount: <Integer>
	itemObserver: <Object>!
!ClyBrowserQueryCursor methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!ClyBrowserQueryCursor methodsFor: 'navigation' stamp: ''!
moveToStart

	self moveTo: 1! !

!ClyBrowserQueryCursor methodsFor: 'queries' stamp: ''!
findItemsSimilarTo: sampleBrowserItems

	^cache 
		findItemsWith: (sampleBrowserItems collect: [:each | each actualObject])
		forAbsentDo: [ 
			^queryResult findItemsSimilarTo: sampleBrowserItems]! !

!ClyBrowserQueryCursor methodsFor: 'accessing' stamp: ''!
position: anObject
	position := anObject! !

!ClyBrowserQueryCursor methodsFor: 'printing' stamp: ''!
printOn: aStream 
	super printOn: aStream.
	aStream nextPut: $(.
	queryResult buildingQuery printOn: aStream.
	aStream nextPut: $)! !

!ClyBrowserQueryCursor methodsFor: 'accessing' stamp: ''!
cache
	^cache! !

!ClyBrowserQueryCursor methodsFor: 'private' stamp: ''!
updateItemCache
	| update |
	update := cache createFullUpdateOf: queryResult.
	cache := update itemCache.
	itemCount := update totalItemCount.
	metadata := update metadata! !

!ClyBrowserQueryCursor methodsFor: 'controlling' stamp: ''!
close

	queryResult unsubscribe: itemObserver.
	itemObserver := nil.	
	^ClyClosedBrowserCursor instance! !

!ClyBrowserQueryCursor methodsFor: 'accessing' stamp: ''!
queryResult
	^ queryResult! !

!ClyBrowserQueryCursor methodsFor: 'accessing' stamp: ''!
itemObserver
	^itemObserver! !

!ClyBrowserQueryCursor methodsFor: 'accessing' stamp: ''!
queryResult: aQueryResult
	queryResult := aQueryResult.
	position := 0.
	cache := ClyBrowserQueryCache withSize: 20.
	itemCount := aQueryResult size.
	metadata := queryResult metadata.
	"we need to retrieve metadata ahead of time to avoid future requests to content about it.
	It is important for remote scenario"! !

!ClyBrowserQueryCursor methodsFor: 'queries' stamp: ''!
findItemsWhere: conditionBlock
	
	^queryResult itemsWhere: conditionBlock! !

!ClyBrowserQueryCursor methodsFor: 'navigation' stamp: ''!
moveToItemWhich: conditionBlock 
	| itemsFound |
	cache 
		findItemWhich: conditionBlock 
		ifExists: [ :cached | position := cached position. ^true ].
	
	itemsFound := cache loadItemsOf: queryResult startingWhere: conditionBlock.
	itemsFound ifFalse: [ ^false  ].
	
	position := cache startPosition.
	^true! !

!ClyBrowserQueryCursor methodsFor: 'navigation' stamp: ''!
moveToNext
	
	self moveTo: position + 1! !

!ClyBrowserQueryCursor methodsFor: 'controlling' stamp: ''!
forceFullUpdate
	queryResult forceRebuild! !

!ClyBrowserQueryCursor methodsFor: 'private' stamp: ''!
cleanCache

	cache items: #()! !

!ClyBrowserQueryCursor methodsFor: 'navigation' stamp: ''!
moveTo: newPosition
	
	position := newPosition.	
	cache loadItemOf: queryResult at: position! !

!ClyBrowserQueryCursor methodsFor: 'queries' stamp: ''!
nextItem
	self moveToNext.
	^self currentItem! !

!ClyBrowserQueryCursor methodsFor: 'controlling' stamp: ''!
openFor: anItemObserver

	self moveToStart.
	itemObserver := anItemObserver.
	queryResult subscribe: itemObserver! !

!ClyBrowserQueryCursor methodsFor: 'accessing' stamp: ''!
itemObserver: anObject
	itemObserver := anObject! !

!ClyBrowserQueryCursor methodsFor: 'accessing' stamp: ''!
itemCount
	^itemCount! !

!ClyBrowserQueryCursor methodsFor: 'testing' stamp: ''!
hasMetaProperty: aPropertyClass

	^metadata hasProperty: aPropertyClass! !

!ClyBrowserQueryCursor methodsFor: 'queries' stamp: ''!
retrieveAll

	^queryResult allItems! !

!ClyBrowserQueryCursor methodsFor: 'queries' stamp: ''!
currentItem
	^cache itemAt: position! !

!ClyBrowserQueryCursor methodsFor: 'accessing' stamp: ''!
getMetaProperty: aPropertyClass
	^metadata getProperty: aPropertyClass! !

!ClyBrowserQueryCursor methodsFor: 'queries' stamp: ''!
findItemsWith: actualObjects
	"it returnes environment items which represent actualObjects.
	Result will be in same order as given actualObjects array.
	If some object is absent in content then it will return nil in place of it.
	We always try to find items in cache and then ask content for it"
	
	^cache findItemsWith: actualObjects forAbsentDo: [ 
		^queryResult findItemsWith: actualObjects]! !

!ClyBrowserQueryCursor methodsFor: 'accessing' stamp: ''!
metadata
	^metadata! !

!ClyBrowserQueryCursor class methodsFor: 'instance creation' stamp: ''!
for: aBrowserQueryResult
	^self new 
		queryResult: aBrowserQueryResult! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testFindItemsSimilarToOthers
	
	| found |
	found := cursor findItemsSimilarTo: ({Class. Array} collect: [:each | each asCalypsoBrowserItem]).
	
	self assert: found size equals: 1.
	self assert: found first actualObject equals: Array.
	self assert: found first isPrepared.
	self assert: found first position equals: (self rawResultItems indexOf: Array).! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testFindItemsUsingPredicateWhenTheyAreNotInCache
	
	| allItems |
	cursor cleanCache.
	allItems := cursor findItemsWhere: [:each | each actualObject = Object].
	
	self assert: allItems size equals: 1.
	self assert: allItems first actualObject equals: Object.
	self assert: allItems first isPrepared.
	self assert: allItems first position equals: 2.! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testCurrentItem
	
	| item |
	item := cursor currentItem.
	
	self assert: item class equals: ClyBrowserItem.
	self assert: item isPrepared.
	self assert: item position equals: 1.! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testMoveToItemWhichNotSatisfiesCondition
	
	| found |
	found := cursor moveToItemWhich: [:each | each actualObject = Object].
	self assert: found.
	self assert: cursor position equals: 2.
	
	found := cursor moveToItemWhich: [:each | false].
	self deny: found.	
	self assert: cursor position equals: 2! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testMoveToItemWhichSatisfiesConditionWhenItNotExistsInCache
	
	| found |
	cursor cleanCache.
	found := cursor moveToItemWhich: [:each | each actualObject = Object].
	
	self assert: found.	
	self assert: cursor position equals: 2.
	self assert: cursor currentItem actualObject equals: Object.! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testMoveToItemWhichSatisfiesCondition
	
	| found |
	found := cursor moveToItemWhich: [:each | each actualObject = Object].
	
	self assert: found.	
	self assert: cursor position equals: 2.
	self assert: cursor currentItem actualObject equals: Object.! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testFindItemsUsingPredicate
	
	| allItems |
	allItems := cursor findItemsWhere: [:each | each actualObject = Array].
	
	self assert: allItems size equals: 1.
	self assert: allItems first actualObject equals: Array.
	self assert: allItems first isPrepared.
	self assert: allItems first position equals: (self rawResultItems indexOf: Array).! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testOpeningShouldSubscribeObserver

	self assert: (queryResult hasSubscriber: itemObserver).
	self assert: cursor itemObserver equals: itemObserver! !

!ClyBrowserQueryCursorTest methodsFor: 'running' stamp: ''!
rawResultItems
	self subclassResponsibility! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testFindItemsWithActualObjects
	
	| found |
	found := cursor findItemsWith: {#absentItem1. Array. #absentItem2}.
	
	self assert: found size equals: 3.
	self assert: found first equals: nil.
	self assert: found last equals: nil.
	self assert: found second actualObject equals: Array.
	self assert: found second isPrepared.
	self assert: found second position equals: (self rawResultItems indexOf: Array).! !

!ClyBrowserQueryCursorTest methodsFor: 'running' stamp: ''!
createQueryResult
	self subclassResponsibility! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testFindItemsWithActualObjectsWhenTheyAreNotInCache
	
	| found |
	cursor cleanCache.
	found := cursor findItemsWith: {#absentItem1. Array. #absentItem2}.
	
	self assert: found size equals: 3.
	self assert: found first equals: nil.
	self assert: found last equals: nil.
	self assert: found second actualObject equals: Array.
	self assert: found second isPrepared.
	self assert: found second position equals: (self rawResultItems indexOf: Array).! !

!ClyBrowserQueryCursorTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyReturningScopeBasisExampleQuery
		from: (ClyExampleScope ofAll: {Array. Object. String} in: environment)
		as: self createQueryResult! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testFindItemsSimilarToOthersWhenTheyAreNotInCache
	
	| found |
	cursor cleanCache.
	found := cursor findItemsSimilarTo: ({Class. Array} collect: [:each | each asCalypsoBrowserItem]).
	
	self assert: found size equals: 1.
	self assert: found first actualObject equals: Array.
	self assert: found first isPrepared.
	self assert: found first position equals: (self rawResultItems indexOf: Array).! !

!ClyBrowserQueryCursorTest methodsFor: 'tests' stamp: ''!
testClosing

	cursor close.
	self deny: (queryResult hasSubscriber: itemObserver)! !

!ClyBrowserQueryCursorTest methodsFor: 'running' stamp: ''!
setUp
	| query |
	super setUp.
	query := self createQuery.
	queryResult := query execute.
	itemObserver := ClyItemObserverExample new.
	cursor := queryResult openBrowserCursorFor: itemObserver! !

!ClyBrowserQueryCursorTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyBrowserQueryCursorTest! !

!ClyBrowserQueryExampleResult methodsFor: 'building' stamp: ''!
fillWith: objects
	items := objects collect: [ :each | ClyBrowserItem named: each printString with: each ]! !

!ClyBrowserQueryResult commentStamp: ''!
I am a root of hierarchy of query result classes which represent retrieved items as ClyBrowserItem instances.

My subclasses represent items in browser compatible form which includes information about:
- position inside internal result items
- depth inside internal result hierarchy  
- extendable properties of actual underlying items  

I lazely compute properties of items when they are requested by user. 
I just ask items to prepare themselves:
	item prepareIn: environment
And depending on actual item type the ClyBrowserItem delegates preparation to every plugin in the environment using appropriate method. For example:
	anEnvironmentPlugin decorateBrowserItem: aBrowserItem ofMethod: aBrowserItem actualObject
And plugin decorates given item with appropriate properties.

So I override all query methods to prepare found items. 
And in addition I implement new ones: 
- findItemsSimilatTo: otherBrowserItems 
It finds all items which are similar to given items collection. For comparison I use #isSimilarTo: method.
-findItemsWith: actualObjects 
It returnes items which represent actualObjects.	Result will be in same order as given actualObjects array. For the missing items there will be nil in the result array.

Also I implement rawItems methods by returning actual unwrapped objects!
!ClyBrowserQueryResult methodsFor: 'accessing' stamp: ''!
rawItemsDo: aBlock

	^items collect: [:each | each actualObject] thenDo: aBlock! !

!ClyBrowserQueryResult methodsFor: 'building' stamp: ''!
buildIndexes
	
	items withIndexDo: [ :each :index | each position: index]! !

!ClyBrowserQueryResult methodsFor: 'queries' stamp: ''!
createUpdateWithItemsStartingAt: startPosition count: cacheSize
	"it is important for remote scenario to call new metadata and new cache by single message.
	In this case all required properties of metadata and cache will be transferred in one request using update instance"
	
	| itemCache |
	itemCache := ClyBrowserQueryCache 
		filledBy: self 
		startingAt: startPosition
		size: cacheSize.
	^ClyBrowserQueryUpdate of: self withItems: itemCache! !

!ClyBrowserQueryResult methodsFor: 'queries' stamp: ''!
findItemsSimilarTo: sampleBrowserItems
	| rest found |
	self protectItemsWhile: [ 
		rest := sampleBrowserItems as: OrderedCollection.
		found := OrderedCollection new.	
		items do: [ :existing |
			rest
				detect: [ :sample | sample isSimilarTo: existing]
				ifFound: [ :sample | 
					existing prepareIn: environment.
					found add: existing. 
					rest remove: sample.
					rest ifEmpty: [ ^found ] ]].	
		^found]! !

!ClyBrowserQueryResult methodsFor: 'building' stamp: ''!
rebuild
	super rebuild.
	
	self buildIndexes! !

!ClyBrowserQueryResult methodsFor: 'testing' stamp: ''!
representsBrowserItems
	^true! !

!ClyBrowserQueryResult methodsFor: 'initialization' stamp: ''!
containerForItemsSortedByName
	^SortedCollection sortBlock: #name ascending! !

!ClyBrowserQueryResult methodsFor: 'accessing' stamp: ''!
adoptForBrowser
	^self! !

!ClyBrowserQueryResult methodsFor: 'queries' stamp: ''!
itemsStartingAt: startIndex count: size

	| result |
	result := super itemsStartingAt: startIndex count: size.
	result do: [ :each | each prepareIn: environment ].
	^result! !

!ClyBrowserQueryResult methodsFor: 'queries' stamp: ''!
findItemsWith: actualObjects
	"it returnes browser items which represent actualObjects.
	Result will be in same order as given actualObjects array.
	If some object is absent in content then it will return nil in place of it.
	All returned items will be resilved"
	| result |
	self protectItemsWhile: [
		result := actualObjects collect: [ :eachObject |
			items 
				detect: [ :item | item representsObjectEqualTo: eachObject ] 
				ifNone: nil].
	
		result select: #notNil thenDo: [ :each | 
			each prepareIn: environment ].
		^result]! !

!ClyBrowserQueryResult methodsFor: 'queries' stamp: ''!
itemsWhere: conditionBlock	
	| result |
	result := super itemsWhere: conditionBlock.
	result do: [ :each | each prepareIn: environment  ].
	^result! !

!ClyBrowserQueryResult methodsFor: 'accessing' stamp: ''!
rawItems

	^items collect: [:each | each actualObject]! !

!ClyBrowserQueryResultTest methodsFor: 'tests' stamp: ''!
testOpeningBrowserCursor
	
	| itemObserver |
	itemObserver := ClyItemObserverExample new.
	cursor := queryResult openBrowserCursorFor: itemObserver.
	
	self assert: cursor class equals: ClyBrowserQueryCursor.
	self assert: cursor queryResult equals: queryResult.
	self assert: cursor itemObserver equals: itemObserver.
	queryResult hasSubscriber: itemObserver! !

!ClyBrowserQueryResultTest methodsFor: 'helpers' stamp: ''!
meaningfullObjectToAssert: resultItem
	^resultItem actualObject! !

!ClyBrowserQueryResultTest methodsFor: 'helpers' stamp: ''!
assertItems: itemValueWithDepthArray withValue: aBlockToGetValue
	| i actualItem valueOfItem |
	items := queryResult items.
	self assert: queryResult size equals: itemValueWithDepthArray size / 2.
	i := 1.
	itemValueWithDepthArray pairsDo: [ :expectedValue :expectedDepth |
		actualItem := items at: i.
		valueOfItem := aBlockToGetValue value: actualItem.
		self assert: valueOfItem equals: expectedValue.
		self assert: actualItem depth equals: expectedDepth.
		i := i + 1]! !

!ClyBrowserQueryResultTest methodsFor: 'helpers' stamp: ''!
assertItems: itemValueWithDepthArray

	self 
		assertItems: itemValueWithDepthArray 
		withValue: [:item | self meaningfullObjectToAssert: item]! !

!ClyBrowserQueryResultTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyBrowserQueryResultTest! !

!ClyBrowserQueryUpdate commentStamp: ''!
I represent information update from query result instance. I include updated metadata, total result size and item cache starting from particular position.

I was introduced to update cursor cache and metadata together by single message. It is important for remote scenario where query rsult is remote proxy and any interaction with it leads to network communication. I return all updated information in one request by single remote message.

Create my instances using following message:
	ClyBrowserQueryUpdate of: aBrowserQueryResult withItems: aBrowserQueryCache

Internal Representation and Key Implementation Points.

    Instance Variables
	itemCache:		<ClyBrowserQueryCache>
	metadata:		<ClyQueryResultMetadata>
	totalItemCount: <Integer>!
!ClyBrowserQueryUpdate methodsFor: 'accessing' stamp: ''!
itemCache: anObject
	itemCache := anObject! !

!ClyBrowserQueryUpdate methodsFor: 'accessing' stamp: ''!
totalItemCount: anObject
	totalItemCount := anObject! !

!ClyBrowserQueryUpdate methodsFor: 'accessing' stamp: ''!
totalItemCount
	^ totalItemCount! !

!ClyBrowserQueryUpdate methodsFor: 'accessing' stamp: ''!
itemCache
	^ itemCache! !

!ClyBrowserQueryUpdate methodsFor: 'accessing' stamp: ''!
metadata: anObject
	metadata := anObject! !

!ClyBrowserQueryUpdate methodsFor: 'accessing' stamp: ''!
metadata
	^ metadata! !

!ClyBrowserQueryUpdate class methodsFor: 'instance creation' stamp: ''!
of: aBrowserQueryResult withItems: aBrowserQueryCache
	^self new 
		metadata: aBrowserQueryResult metadata;
		itemCache: aBrowserQueryCache;
		totalItemCount: aBrowserQueryResult size! !

!ClyBrowserSearchDialogWindow commentStamp: ''!
I a a search dialog to select one or multiples items from the queries objects.
I am created by browser and users should call me using following methods: 

	browser searchDialog 
		requestSingleObject: 'Choose package' from: ClyAllPackages sorted.

	browser searchDialog 
		requestMultipleObjects: 'Choose classes' from: ClyAllClasses sorted

I always force semi async execution of given query.

In case when query result include just a couple of items I hide default view filters.

To select items in the list users can use #enter key. To close dialog they can use #esc. 

By default filter is focused. And as soon as dialog openes user can type filter.
If after filter there is only item in the list I will choose it when user submit the dialog.
If there are multiple items I try to find the item with exact same name as filter text.

Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>
	itemsView:		<ClyQueryView>!
!ClyBrowserSearchDialogWindow methodsFor: 'controlling' stamp: ''!
itemsChanged! !

!ClyBrowserSearchDialogWindow methodsFor: 'requests' stamp: ''!
requestMultipleObjects: dialogTitle from: aQuery inScope: aScope

	aScope bindTo: browser navigationEnvironment.
	
	^self requestMultipleObjects: dialogTitle from: (aScope adoptQuery: aQuery)! !

!ClyBrowserSearchDialogWindow methodsFor: 'initialization' stamp: ''!
newContentMorph
	itemsView := ClyQueryViewMorph for: self.
	itemsView width: 250.
		
	itemsView whenDoubleClickDo: [:ann | self ok ].
	itemsView whenEnterKeyPressedDo: [:ann | self ok ].
	itemsView whenEscapeKeyPressedDo: [:ann | self cancel ].
	^itemsView! !

!ClyBrowserSearchDialogWindow methodsFor: 'requests' stamp: ''!
requestMultipleObjects: dialogTitle from: aQuery
	
	^ self requestMultipleObjects: dialogTitle from: aQuery selecting: #()! !

!ClyBrowserSearchDialogWindow methodsFor: 'events handling' stamp: ''!
defaultFocusMorph

	^itemsView filterField ifNil: [ itemsView dataSource table ]! !

!ClyBrowserSearchDialogWindow methodsFor: 'controlling' stamp: ''!
changeStateBy: aBlock
	aBlock value! !

!ClyBrowserSearchDialogWindow methodsFor: 'private' stamp: ''!
openOn: aQuery withTitle: dialogTitle thenDo: resultActionBlock

	^ self openOn: aQuery selecting: #() withTitle: dialogTitle thenDo: resultActionBlock! !

!ClyBrowserSearchDialogWindow methodsFor: 'private' stamp: ''!
openOn: aQuery selecting: items withTitle: dialogTitle thenDo: resultActionBlock

	self showItemsOf: aQuery.
	self title: dialogTitle.
	itemsView selection selectItems: (itemsView findItemsWith: items).

	browser window openModal: self.

	^["Following two lines should prevent special condition 
	when filter background process modifies current table data source.
	During this process it first closes existing data source 
	and only after that it sets up new filtered data source"
	itemsView table cleanupFilter. "it ensures that filter process will not affect table anymore" 
	itemsView dataSource isClosed ifTrue: [  
		"This branch is consiquence of corner case when filter logic closes current data source 
		but does not yet set up new filtered data source.
		In that case any query of items from closed data source will fail.
		And to avoid it we simply abort search request"
		CmdCommandAborted signal ].
	
	self cancelled ifTrue: [ CmdCommandAborted signal ].
	resultActionBlock value]	
		ensure: [ itemsView closeDataSource]! !

!ClyBrowserSearchDialogWindow methodsFor: 'requests' stamp: ''!
requestSingleObject: dialogTitle from: aQuery inScope: aScope
	
	aScope bindTo: browser navigationEnvironment.

	^self requestSingleObject: dialogTitle from: (aScope adoptQuery: aQuery)! !

!ClyBrowserSearchDialogWindow methodsFor: 'private' stamp: ''!
showItemsOf: aQuery

	| actualQuery |
	actualQuery := aQuery isBoundToEnvironment
		ifTrue: [ aQuery ]
		ifFalse: [ aQuery withScope: browser systemScope ]..
	
	itemsView showQuery: actualQuery semiAsync.
	itemsView adoptForDialog! !

!ClyBrowserSearchDialogWindow methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyBrowserSearchDialogWindow methodsFor: 'requests' stamp: ''!
requestSingleObject: dialogTitle from: aQuery
	
	self 
		openOn: aQuery
		withTitle: dialogTitle
		thenDo: [ 
			itemsView selection isEmpty ifTrue: [ 
				^self findObjectsSameAsFilter 
					ifEmpty: [ CmdCommandAborted signal ]
					ifNotEmpty: [ :items | items first]].
	
			^itemsView selection lastSelectedItem actualObject]! !

!ClyBrowserSearchDialogWindow methodsFor: 'private' stamp: ''!
findObjectsSameAsFilter
	itemsView dataSource numberOfRows = 1 ifTrue: [ 
		"single element means that it was found by filter and we can use it without extra search"
		^ itemsView dataSource allElements collect: [:each | each actualObject] ].
	^ itemsView findItemsSameAsFilter
		ifNotEmpty: [ :foundItems | foundItems collect: [:each | each actualObject] ]! !

!ClyBrowserSearchDialogWindow methodsFor: 'controlling' stamp: ''!
ignoreNavigationDuring: aBlock
	aBlock value! !

!ClyBrowserSearchDialogWindow methodsFor: 'controlling' stamp: ''!
changeStateOf: aQueryView by: aBlock
	aBlock value! !

!ClyBrowserSearchDialogWindow methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!ClyBrowserSearchDialogWindow methodsFor: 'requests' stamp: ''!
requestMultipleObjects: dialogTitle from: aQuery selecting: items
	
	self 
		openOn: aQuery 
		selecting: items
		withTitle: dialogTitle
		thenDo: [ 
			itemsView selection isEmpty ifTrue: [ ^self findObjectsSameAsFilter ].
			^itemsView selection actualObjects]! !

!ClyBrowserSearchDialogWindow class methodsFor: 'instance creation' stamp: ''!
for: aBrowser
	^self new 
		browser: aBrowser! !

!ClyBrowserState commentStamp: ''!
I am a root of subclasses which represent the state of particular kind of browser.
I am used as navigation history items.

While subclasses can provide additional state they all include following properties: 
- viewStates, the collection of state of all navigation views, instances of ClyQueryViewState.
- selectedTabs, the colletion of selected browser tabs 
- systemScope, the system scope of the browser 

My instances are created with browser: 

	ClyBrowserState of: aBrowser

Or simply ask 
	
	aBrowser snapshotState

During initialization I retrieve the browser state in method #retrieveStateFrom:.

When history performs undo/redo operation it just applies particular browser state to the browser: 

	aBrowserState applyTo: aBrowser byUndo: true
	
Which calls simple #applyTo:. Extra agrument is required to support properly across window navigation.

Navigation history support accors window navigation to be able return back and forward between spawned windows.
It requires browser state to be able create browser instances from scratch because when we are trying to move back to original browser it can be already closed and not exists anymore.
So subclasses should implement #createBrowser method. It should just return new browser instance without any initialization logic. 	
 
Internal Representation and Key Implementation Points.

    Instance Variables
	viewStates:		<Collection of<ClyQueryViewState>>
	selectedTabs:		<Collection of<ClyBrowserTool>>
	systemScope:		<ClySystemScope>
!
!ClyBrowserState methodsFor: 'accessing' stamp: ''!
viewStates: anObject
	viewStates := anObject! !

!ClyBrowserState methodsFor: 'operations' stamp: ''!
restoreNavigationStateOf: aBrowser
	
	aBrowser navigationViews with: viewStates do: [:view :state |
		view ignoreNavigationDuring: [ 
			state applyTo: view]]! !

!ClyBrowserState methodsFor: 'operations' stamp: ''!
applyTo: aBrowser byUndo: undoExecuting
	self applyTo: aBrowser! !

!ClyBrowserState methodsFor: 'accessing' stamp: ''!
systemScope: anObject
	systemScope := anObject! !

!ClyBrowserState methodsFor: 'accessing' stamp: ''!
systemScope
	^ systemScope! !

!ClyBrowserState methodsFor: 'private' stamp: ''!
restoreStateOf: aBrowser

	aBrowser systemScope: systemScope! !

!ClyBrowserState methodsFor: 'accessing' stamp: ''!
selectedTabs
	^ selectedTabs! !

!ClyBrowserState methodsFor: 'accessing' stamp: ''!
selectedTabs: anObject
	selectedTabs := anObject! !

!ClyBrowserState methodsFor: 'operations' stamp: ''!
retrieveStateFrom: aBrowser

	systemScope :=  aBrowser systemScope.
	viewStates := aBrowser navigationViews collect: [ :each | each snapshotState ].
	selectedTabs := aBrowser tabManager selectedTools 
		collect: [ :each | each copyForBrowserStateSnapshot ].! !

!ClyBrowserState methodsFor: 'testing' stamp: ''!
representsConcreteQuery
	"this method allows to detect that browser is in state when it not shows any concrete content at any of panels. It is happens when browser was not requested to show anything yet"
	
	^(viewStates allSatisfy: [ :each | each representsConcreteQuery not ]) not! !

!ClyBrowserState methodsFor: 'operations' stamp: ''!
applyTo: aBrowser

	aBrowser changeStateBy: [ 
		self restoreStateOf: aBrowser.	
		self restoreNavigationStateOf: aBrowser.
		aBrowser tabManager restoreBrowserState: self ]! !

!ClyBrowserState methodsFor: 'private' stamp: ''!
createBrowser
	self subclassResponsibility! !

!ClyBrowserState methodsFor: 'accessing' stamp: ''!
viewStates
	^ viewStates! !

!ClyBrowserState methodsFor: 'testing' stamp: ''!
isCurrentStateOf: aBrowser

	aBrowser navigationViews with: viewStates do: [:view :state | 
		(state isCurrentStateOf: view) ifFalse: [ ^false]].
	
	^aBrowser tabManager selectsTools: selectedTabs! !

!ClyBrowserState class methodsFor: 'instance creation' stamp: ''!
of: aBrowser
	^self new 
		retrieveStateFrom: aBrowser! !

!ClyBrowserStateTest methodsFor: 'tests' stamp: ''!
testRetrievesStateOfAllNavigationViews

	self snapshotState.
	
	self assert: navigationState viewStates size equals: browser navigationViews size! !

!ClyBrowserStateTest methodsFor: 'running' stamp: ''!
snapshotState

	navigationState := browser snapshotState.! !

!ClyBrowserStateTest methodsFor: 'tests' stamp: ''!
testSelectedTabsAreNotBuild

	| tab |
	self snapshotState.
	
	tab := navigationState selectedTabs first.
	self deny: tab isBuilt! !

!ClyBrowserStateTest methodsFor: 'tests' stamp: ''!
testSelectedTabsWithoutBrowser

	| tab |
	self snapshotState.
	
	tab := navigationState selectedTabs first.
	self assert: tab browser isNil! !

!ClyBrowserStateTest methodsFor: 'tests' stamp: ''!
testSelectedTabsWithoutContext

	| tab |
	self snapshotState.
	
	tab := navigationState selectedTabs first.
	self assert: tab context isNil! !

!ClyBrowserStateTest methodsFor: 'tests' stamp: ''!
testSelectedTabsWithoutOwner

	| tab |
	self snapshotState.
	
	tab := navigationState selectedTabs first.
	self assert: tab owner isNil! !

!ClyBrowserStateTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyBrowserStateTest! !

!ClyBrowserTabCommandActivation commentStamp: ''!
I am command activation strategy to access commands as tab manager icons. 
TabManagerMorph provides special place in tab panel (top right) for extended iconic buttons!
!ClyBrowserToolDecorator commentStamp: ''!
I a base class for various kinds of browser tab decorators.
Decorators are added to browser tools by browser plugins using following method: 

	aBrowserTool addDecorator: aBrowserToolDecorator
	
Subclasses should implement single method: 

- decorateTool

When decorator is added to the tool it sets my browserTool variable.
And #decorateTool method performs required logic with this given tool.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	browserTool:		<ClyBrowserTool>!
!ClyBrowserToolDecorator methodsFor: 'decoration' stamp: ''!
decorateTool
	self subclassResponsibility! !

!ClyBrowserToolDecorator methodsFor: 'accessing' stamp: ''!
browserTool: anObject
	browserTool := anObject! !

!ClyBrowserToolDecorator methodsFor: 'accessing' stamp: ''!
browserEnvironment
	^ self browser navigationEnvironment! !

!ClyBrowserToolDecorator methodsFor: 'accessing' stamp: ''!
browser
	^ browserTool browser! !

!ClyBrowserToolDecorator methodsFor: 'accessing' stamp: ''!
browserTool
	^ browserTool! !

!ClyBrowserToolDecorator methodsFor: 'controlling' stamp: ''!
toolWasRemoved! !

!ClyBrowserToolMorph commentStamp: ''!
I am a root of browser tabs hierarchy.
My subclasses should implement single method #build where they should create and add required widgets.

The build is always executed in background due to the TabManagerMorph logic.

Tab manager collects all subclasses which should be opened for current browser state.
It lookups tools annotated with ClyTabActivationStrategy for current browser context.

So to enable any tool in the browser you should annotated it with еру strategy for appropriate context where tool should be opened.
For example:

	ClyMethodCodeEditorTool class>>methodTabActivation
		<classAnnotation>
		^ClyTabActivationStrategy for: ClyMethod asCalypsoItemContext

It will open method editor when method is selected in the browser.	

Subclasses can define extra condition to check that they can be opened in particular browser context instance.
They should override class side method: 

- shouldBeActivatedInContext: aBrowserContext

It returns true by default.

Also abstract subclasses are never opened in the browser. By default the tool is abstract if it has subclasses.
The class side method #isAbstact should be overridden if this default condition is not valid.

Tab instances are created with browser context 

	ClyBrowserTool for: aBrowser inContext: aBrowserContext
	
Subclasses should implement initialization methods to retrieve required state from the given context:

- setUpModelFromContext
- setUpParametersFromModel

Last method is also used to update tool when model is changed.

Subclasses should override method #isSimilarTo: to compare with another tool which has same parameters.
For example ClyMethodCodeEditorTool checks that other method editor is based on same method.
#isSimilarTo: method is used by ClyTabManager to update existing tabs in new browser state. If similar tool is already opened in browser then it will be not replaced by new instance.
Look ClyTabManager comments for details.

Tab manager never close dirty tabs when browser selection is changed. Instead if ask the tool to indicate different browser context.
To support this logic tools should implement following methods: 

- belongsToCurrentBrowserContext
For example method editor checks that browser still selects editing method.

- warnUserAboutMyContext
Here the tool is supposed to reset any indication of different context. It happens when user move selection back where dirty tab should be opened again. 

- warnUserAboutDifferentContext
Here the tool can indicate that it is now is untouched from the current browser state. For example when user selects new method while dirty method is still opened. 

- warnUserAboutChangedContext
It just merges previous two methods by testing for #belongsToCurrentBrowserContext.

To support dirty state subclasses should implement method #hasUnacceptedEdits. It is false by default.
And indication of dirtiness can be overridden in the method #updateDirtyState. By default it just adds * to the tab title. 

- hasUnacceptedEdits (false by default)
- updateDirtyState

So tabs are based on some models. For example method editor model is a method. 
When tool model is removed from system (method is removed) the tab should be automatically closed.
Tab manager detects such conditions using following method which tools should implement:

- belongsToRemovedBrowserContext

For example method editor checks that editing method was removed from system.

So the model of the tool can be modified and therefore the tool should implement update logic using following methods:

- attachToSystem
It should subscribe the tool for model changes.

- detachFromSystem
It should unsubscribe the tool from the model.

In addition I provide method #update which subclasses should reuse in the update logic of the method changes.
#update refreshes basic visual properties of tool retrieved from the model and it rebuilds status bar.

TabManager orders retrieved tools using method #tabOrder.
Also manager chooses what tab should be selected first. It selects the tool with highest #activationPriority which is equal to #tabOrder by default.
In general tab selection logic is more complex. Look at ClyTabManager comments for details.

To specify tab title and icon subclasses can implement following methods: 

- defaultIconName
- defaultIcon (to be able create dynamic icon instance when simple icon name is not enough)
- defaultTitle (by default it is the name of current selected item in the browser or just a tool class name if nothing selected)

I provide status bar. And subclasses can add items to it in the method: 

- fillStatusBar

Any tool can be decorated by browser plugins which can inject other widgets or modify general style of the tool.
Plugins add decorators using following method: 
	
	aBrowserTool addDecorator: aBrowserToolDecorator

And at the end of building process I apply all configured decorators:

	self applyDecorations
	
Notice that full tab building logic is implemented in the method: 

- buildAndDecorate

To remove the tool from browser just call #removeFromBrowser method.

Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>
	containerTab:		<TabMorph>
	context:		<ClyBrowserContext>
	decorators:		<OrderedCollection of<ClyBrowserToolDecorator>>
	isDirty:		<Boolean>
	isManagedByUser:		<Boolean>
	statusBar:		<ClyStatusBar>!
!ClyBrowserToolMorph methodsFor: 'testing' stamp: ''!
belongsToRemovedBrowserContext
	^false! !

!ClyBrowserToolMorph methodsFor: 'testing' stamp: ''!
wantsStayInDifferentContext

	self isBuilt ifFalse: [ ^ false ].
	self hasUnacceptedEdits ifTrue: [ ^ true ].
	(self isTabSelected and: [ self isExtraSelectionRequested ]) ifTrue: [ ^ true ].
	self belongsToRemovedBrowserContext ifTrue: [ ^ false ].
	
	^ isManagedByUser! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
whenReadyDo: aBlock

	aBlock value: self! !

!ClyBrowserToolMorph methodsFor: 'building' stamp: ''!
fillStatusBar

	self belongsToCurrentBrowserContext ifFalse: [ 
		statusBar addContextItem: (ClyToolContextNavigatorMorph for: self) ]! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
warnUserAboutDifferentContext

	containerTab icon: (self iconNamed: #uncommentedClass)! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
context: aBrowserContext
	context := aBrowserContext! !

!ClyBrowserToolMorph methodsFor: 'testing' stamp: ''!
hasUnacceptedEdits
	^false! !

!ClyBrowserToolMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth 
	^0! !

!ClyBrowserToolMorph methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserTool
	^self class = anotherBrowserTool class! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
waitBuildCompletion
	containerTab waitReadyMorphFor: 50 milliSeconds! !

!ClyBrowserToolMorph methodsFor: 'testing' stamp: ''!
allowsDifferentActivationPriority
	^true! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
activationPriorityInNonActiveContext
	"when tool is shown in not active browser context it should be in less priority for activating tabs"
	^isManagedByUser 
		ifTrue: [ self activationPriority ] 
		ifFalse: [Float negativeInfinity ]! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
tabOrder
	^ self class tabOrder! !

!ClyBrowserToolMorph methodsFor: 'building' stamp: ''!
createTab
	| menu |
	
	menu := CmdMenu activatedBy: ClyBrowserTabCommandActivation.
	menu buildInContext: context.
	
	containerTab := TabMorph
		label: self defaultTitle
		icon: self defaultIcon
		retrievingBlock: [ self buildAndDecorate ]
		actions: menu buildBrowserTabActions.
	
	containerTab model: self.
	^ containerTab! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
containerTab
	^ containerTab! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
attachToSystem! !

!ClyBrowserToolMorph methodsFor: 'testing' stamp: ''!
isCommandAvailable: aCommand
	"A double dispatch mechanism to allow tools to validate commands that can be 
	 executed on it. Subclasses can override me to perform the proper dispatch."
	"Previous definition was: aCommand canBeExecutedInTool: self but it led to an error 
	since canBeExecutedInTool: did not exist"
	
	^ true! !

!ClyBrowserToolMorph methodsFor: 'printing' stamp: ''!
printContext
	^''! !

!ClyBrowserToolMorph methodsFor: 'building' stamp: ''!
buildAndDecorate
	self isBuilt ifTrue: [ ^self ] "somehow tab manager can call building process multiple times".
	self setUpParametersFromModel.
	self decorateContainerTab.
	self build. 
	self buildStatusBar.
	self applyDecorations.
	self attachToSystem! !

!ClyBrowserToolMorph methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
spawnQueryBrowserOn: aQuery 
	browser spawnQueryBrowserOn: aQuery! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
okToClose
	self hasUnacceptedEdits ifFalse: [ ^true ].
	
	^browser confirmDiscardChanges! !

!ClyBrowserToolMorph methodsFor: 'building' stamp: ''!
decorateContainerTab! !

!ClyBrowserToolMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	decorators := OrderedCollection new.
	isManagedByUser := false.
	isDirty := false.
	self
		changeTableLayout;
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		vResizing: #spaceFill! !

!ClyBrowserToolMorph methodsFor: 'building' stamp: ''!
rebuildStatusBar
	self isBuilt ifFalse: [ ^self ].
	
	statusBar clear.
	self fillStatusBar! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
removeFromBrowser

	containerTab delete! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
statusBar
	^statusBar! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
activeColor
	^self theme backgroundColor! !

!ClyBrowserToolMorph methodsFor: 'building' stamp: ''!
applyDecorations
	decorators do: [ :each | each decorateTool ]! !

!ClyBrowserToolMorph methodsFor: 'initialization' stamp: ''!
defaultTitle
	^context hasSelectedItems 
		ifTrue: [ context lastSelectedItem name]
		ifFalse: [ self class name]! !

!ClyBrowserToolMorph methodsFor: 'updating' stamp: ''!
triggerUpdate
	self update! !

!ClyBrowserToolMorph methodsFor: 'copying' stamp: ''!
copyForBrowserStateSnapshot

	^self shallowCopy
		resetStateForSnapshot;
		yourself! !

!ClyBrowserToolMorph methodsFor: 'initialization' stamp: ''!
setUpDefaultIcon

	containerTab icon: self defaultIcon! !

!ClyBrowserToolMorph methodsFor: 'building' stamp: ''!
buildPageAndDecorate

	self setUpParametersFromModel.
	self decorateContainerTab.
	self build. 
	self buildStatusBar.
	self applyDecorations.
	self attachToSystem! !

!ClyBrowserToolMorph methodsFor: 'initialization' stamp: ''!
defaultIcon
	self defaultIconName ifNil: [ ^nil ].
	
	^self iconNamed: self defaultIconName! !

!ClyBrowserToolMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^Color transparent! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
warnUserAboutMyContext

	self setUpDefaultIcon! !

!ClyBrowserToolMorph methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
supportsCriticDecoration
	^false! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
activationPriority
	^self tabOrder! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
warnUserAboutChangedContext

	self belongsToCurrentBrowserContext
		ifTrue: [ self warnUserAboutMyContext ]
		ifFalse: [ self warnUserAboutDifferentContext ]! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
backgroundColor
	
	^ containerTab backgroundColor! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
deselectTab
	
	containerTab removeFromSelection! !

!ClyBrowserToolMorph methodsFor: 'initialization' stamp: ''!
setUpModelFromContext! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
selectAsMainTab

	containerTab addToSelection! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
isManagedByUser
	^ isManagedByUser! !

!ClyBrowserToolMorph methodsFor: 'updating' stamp: ''!
update
	self setUpParametersFromModel.
	self decorateContainerTab.
	self rebuildStatusBar.
	self warnUserAboutChangedContext! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
containerTab: anObject
	containerTab := anObject! !

!ClyBrowserToolMorph methodsFor: 'updating' stamp: ''!
browserContextWasChanged

	self warnUserAboutChangedContext.
	self rebuildStatusBar! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
updateDirtyState
	
	self hasUnacceptedEdits == isDirty ifTrue: [ ^ self ].

	isDirty := self hasUnacceptedEdits.
	containerTab markDirty: isDirty! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyBrowserToolMorph methodsFor: 'testing' stamp: ''!
isExtraSelectionRequested
	"It checks that users wants multiple selected tabs.
	So cmd click on table just adds new selected items and keep existed selected.
	And this method allow tab manager to keep current tool selected in that case.
	In addition tab manager will force all similar tools (of same class) to be selected.
	So cmd+click on method pane leads to multiple methods selected in the table and in the tabs"

	"Following mouse logic ensures that we are under condition when mouseDown+cmd was produced.
	(it should be simple #meta modifier. But we don't have it"
	| lastEvent |
	lastEvent := (self activeHand ifNil: [ ^ false ])lastEvent.
	^ lastEvent isMouse and: [ lastEvent isMouseDown 
		and: [lastEvent commandKeyPressed or: [ lastEvent controlKeyPressed ]]]! !

!ClyBrowserToolMorph methodsFor: 'initialization' stamp: ''!
resetStateForSnapshot
	owner := nil.
	submorphs := EmptyArray.
	extension := nil.
	browser := nil.
	context := nil.
	containerTab := nil.
	statusBar := nil.
	isDirty := false.
	decorators := nil! !

!ClyBrowserToolMorph methodsFor: 'building' stamp: ''!
build
	self subclassResponsibility! !

!ClyBrowserToolMorph methodsFor: 'building' stamp: ''!
buildStatusBar

	statusBar := ClyStatusBarMorph new.
	statusBar 
		width: browser width. "it is required because tool is build in background"
"		color: self theme windowColor."
	self addMorphBack: statusBar.
	
	self fillStatusBar! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
isManagedByUser: anObject
	isManagedByUser := anObject! !

!ClyBrowserToolMorph methodsFor: 'initialization' stamp: ''!
setUpParametersFromModel! !

!ClyBrowserToolMorph methodsFor: 'testing' stamp: ''!
belongsToCurrentBrowserContext
	"my subclasses must define condition which means that tool has context which is the same as current browser context.
	This method is not subclass responsibility to not break browser when new tool class is created"
	^true! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
addDecorator: aBrowserToolDecorator
	aBrowserToolDecorator browserTool: self.
	decorators add: aBrowserToolDecorator! !

!ClyBrowserToolMorph methodsFor: 'initialization' stamp: ''!
defaultIconName
	^nil! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
selectAsExtraTab
	containerTab addToSelection! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
restoreBrowserState
	context restoreBrowserState! !

!ClyBrowserToolMorph methodsFor: 'testing' stamp: ''!
isBuilt
	containerTab ifNil: [ ^ false ].
	self flag: #TODO. "This patch is to ensure compatibility while working. 
	Ensure to remove later."
	(containerTab respondsTo: #isRendered) ifTrue: [ 
		 ^ containerTab isRendered ].
	^ containerTab morph == self! !

!ClyBrowserToolMorph methodsFor: 'building' stamp: ''!
addNotebookPageOn: aNotebook 
	| menu |
	
	menu := CmdMenu activatedBy: ClyBrowserTabCommandActivation.
	menu buildInContext: context.
	
	containerTab := ClyNotebookPageMorph 
		newLabel: self defaultTitle
		icon: self defaultIcon
		provider: [ self buildPageAndDecorate ].
	containerTab beCloseable.
	containerTab actions: menu buildBrowserNotebookActions.
	containerTab model: self.
	
	aNotebook 
		addPage: containerTab 
		label: containerTab labelMorph.
	
	^ containerTab! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
detachFromSystem! !

!ClyBrowserToolMorph methodsFor: 'testing' stamp: ''!
isTabSelected
	| selectedTab |
	
	selectedTab := containerTab owner
		ifNotNil: [ :aMorph | aMorph selectedTab ].
	^ selectedTab = containerTab! !

!ClyBrowserToolMorph methodsFor: 'controlling' stamp: ''!
cleanAfterRemove

 	self detachFromSystem.		
 	decorators do: [ :each | each toolWasRemoved ]! !

!ClyBrowserToolMorph methodsFor: 'accessing' stamp: ''!
browser: aBrowser
	browser := aBrowser! !

!ClyBrowserToolMorph class methodsFor: 'instance creation' stamp: ''!
for: aBrowser inContext: aBrowserContext

	^self new 
		browser: aBrowser;
		context: aBrowserContext;
		setUpModelFromContext;
		yourself! !

!ClyBrowserToolMorph class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyBrowserToolMorph! !

!ClyBrowserToolMorph class methodsFor: 'accessing' stamp: ''!
tabOrder
	^1000! !

!ClyBrowserToolMorph class methodsFor: 'testing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	"Subclasses can define extra condition 
	to check that they can be opened in particular browser context instance.
	By default it is always true"
	^true! !

!ClyBrowserToolbarItemMorph commentStamp: ''!
My subclasses are different kind of UI elements which represent particular command in the browser toolbar. 
Instances should be created with command activator: 

	ClyBrowserButton activatingBy: aCommandActivator  

When browser buids the toolbar it collect all commands annotated with ClyToolbarCommandActivation and asks all of them to build toolbar item.
So command decides what UI element (my subclass) should be used to represent it in the toolbar. 
  
Subclasses should implement method #build which should create actual widged which will perform the command using #executeCommand method.
Also I provide the #title method which is based on menu item name of the command.

Internal Representation and Key Implementation Points.

    Instance Variables
	activator:		<CmdCommandActivator>!
!ClyBrowserToolbarItemMorph methodsFor: 'accessing' stamp: ''!
addIcon: anIcon

	self addMorphFront: anIcon asMorph! !

!ClyBrowserToolbarItemMorph methodsFor: 'operations' stamp: ''!
executeCommand
	activator executeCommand! !

!ClyBrowserToolbarItemMorph methodsFor: 'accessing' stamp: ''!
activator: aCommandActivator
	activator := aCommandActivator.
	self build! !

!ClyBrowserToolbarItemMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		changeTableLayout;
		listDirection: #leftToRight;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		cellInset: 4! !

!ClyBrowserToolbarItemMorph methodsFor: 'accessing' stamp: ''!
activator
	^activator! !

!ClyBrowserToolbarItemMorph methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	activator printOn: aStream.
	aStream nextPut: $).! !

!ClyBrowserToolbarItemMorph methodsFor: 'initialization' stamp: ''!
build! !

!ClyBrowserToolbarItemMorph methodsFor: 'accessing' stamp: ''!
defaultColor
	^Color transparent! !

!ClyBrowserToolbarItemMorph methodsFor: 'accessing' stamp: ''!
title
	^activator menuItemName! !

!ClyBrowserToolbarItemMorph class methodsFor: 'instance creation' stamp: ''!
activatingBy: aCommandActivator
	^self new 
		activator: aCommandActivator! !

!ClyButtonToolbarGroup commentStamp: ''!
I group commands in the browser toolbar which should be represented as general button.
I allow to place all button based commands at the end of toolbar.!
!ClyButtonToolbarGroup methodsFor: 'accessing' stamp: ''!
order
	^5000! !

!ClyClass commentStamp: ''!
I represent the type of any kind of classes or traits.
I am introduced to abstract actual class implementation where in live system it would be Behavior or TraitBehavior.
So when Calypso build browser items for classes or traits their type is supposed to be me.
Look at class references to discover all compatible class definitions!
!ClyClass class methodsFor: 'printing' stamp: ''!
printSystemPathTo: aClass
	^aClass package name! !

!ClyClass class methodsFor: 'sorting' stamp: ''!
defaultSortFunctionForCalypso
	^ClySortByNameFunction ascending! !

!ClyClass class methodsFor: 'testing' stamp: ''!
match: aClass forQueryBrowserFilter: aQueryBrowserFilter

	(aQueryBrowserFilter matchesString: aClass name) ifTrue: [ ^true ].
	^aQueryBrowserFilter matchesString: aClass package name! !

!ClyClass class methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: aBrowserItem by: anEnvironmentPlugin
	^ anEnvironmentPlugin
		decorateBrowserItem: aBrowserItem
		ofClass: aBrowserItem actualObject! !

!ClyClass class methodsFor: 'sorting' stamp: ''!
itemsSortOrderForCalypso
	^2! !

!ClyClass class methodsFor: 'item convertation' stamp: ''!
convertToCalypsoBrowserItem: aClass

	| item |
	item := ClyBrowserItem named: aClass name with: aClass.
	item addProperty: (ClyClassDefinitionProperty of: aClass).
	^item! !

!ClyClass0FromPWithSingleClassMock methodsFor: 'protocol' stamp: ''!
abstractMethod1
	self subclassResponsibility! !

!ClyClass0FromPWithSingleClassMock methodsFor: 'protocol' stamp: ''!
abstractMethod2
	self subclassResponsibility! !

!ClyClass1FromP1Mock methodsFor: 'tag1' stamp: ''!
tag1Method1! !

!ClyClass1FromP1Mock methodsFor: 'var accessors' stamp: ''!
instanceSideVar1ReaderMethod
	^instanceSideVar1! !

!ClyClass1FromP1Mock methodsFor: 'accessing' stamp: ''!
instanceSideVar2
	^ instanceSideVar2! !

!ClyClass1FromP1Mock methodsFor: 'var accessors' stamp: ''!
instanceSideVar1WriterMethod
	instanceSideVar1 := #var1Value! !

!ClyClass1FromP1Mock methodsFor: 'superclassTag1' stamp: ''!
superclassTag1Method! !

!ClyClass1FromP1Mock class methodsFor: 'protocol' stamp: ''!
classSideMethodFromClass1! !

!ClyClass2FromP1Mock methodsFor: 'accessing' stamp: ''!
instVar

	 ^ instVar! !

!ClyClass2FromP1Mock methodsFor: 'as yet unclassified' stamp: ''!
instanceSideClassVar1Reader
	^ClassVar1! !

!ClyClass2FromP1Mock methodsFor: 'accessing' stamp: ''!
instanceSideClassVar1Writer
	ClassVar1 := #classVar1Value! !

!ClyClass2FromP1Mock methodsFor: 'accessing' stamp: ''!
instanceSideClassVar2Reader
	^ClassVar2! !

!ClyClass2FromP1Mock class methodsFor: 'accessing' stamp: ''!
classSideClassVar1Reader
	^ClassVar1! !

!ClyClass2FromP1Mock class methodsFor: 'accessing' stamp: ''!
classSideClassVar1Writer
	ClassVar1 := #classVar1Value! !

!ClyClass9FromPExtendedByP5Mock methodsFor: '*Calypso-SystemQueries-Tests-P5WithTags' stamp: ''!
extensionMethodFromClass9! !

!ClyClass9FromPExtendedByP5Mock methodsFor: '*Calypso-SystemQueries-Tests-P5WithTags-extraNonPackageTag' stamp: ''!
extensionMethod2FromClass9! !

!ClyClassBindingsResult commentStamp: ''!
I am posible result of class query.
I convert given clases to bindings.

I am used by ClyClassReferences query to adopt class queries to the variables (bindings are polymorphic to them)!
!ClyClassBindingsResult methodsFor: 'building' stamp: ''!
fillWith: classes
	items := classes collect: [ :each |
		each isVariableBinding 
			ifTrue: [ each ] 
			ifFalse: [ 
				each isObsolete 
					ifTrue: [ GlobalVariable 
						key: (each name allButFirst: 'AnObsolete' size) asSymbol 
						value: each]
					ifFalse: [ each instanceSide binding ]]]! !

!ClyClassBindingsTest methodsFor: 'tests' stamp: ''!
testFillingWithTwoClasses

	queryResult fillWith: {Array. String}.
	
	self assert: queryResult items equals: {Array binding. String binding}.! !

!ClyClassBindingsTest methodsFor: 'tests' stamp: ''!
testFillingWithMetaclass

	queryResult fillWith: {Array class}.
	
	self assert: queryResult items equals: {Array binding}.! !

!ClyClassBindingsTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyClassBindingsResult new! !

!ClyClassChange commentStamp: ''!
I represent all possible changes with class.
I am used to subscribe with single subscription to any changes related to classes.
So you can write code like this: 

	SystemAnnouncer uniqueInstance when: (ClyClassChange of: MyClass) do: [ :ann | ann logCr ].
	
I provide more general subscription logic than subscribing on base ClassAnnouncement class. Many other events can be also related to class changes like renaming package or running class tests. They are not covered by ClassAnnouncement hierarchy.
I reuse logic of queries how they detect that their result is affected by system changes: 
	
	ClyClassChange>>handlesAnnouncement: anAnnouncement 
 		^anAnnouncement affectsClass: affectedClass	

I am used by class editor tools to be updated when editing class is changed.
	
Internal Representation and Key Implementation Points.

    Instance Variables
	affectedClass:		<Class>!
!ClyClassChange methodsFor: 'accessing' stamp: ''!
affectedClass: anObject
	affectedClass := anObject! !

!ClyClassChange methodsFor: 'testing' stamp: ''!
handlesAnnouncement: anAnnouncement

	^anAnnouncement affectsClass: affectedClass! !

!ClyClassChange methodsFor: 'accessing' stamp: ''!
affectedClass
	^ affectedClass! !

!ClyClassChange class methodsFor: 'instance creation' stamp: ''!
of: aClass
	^self new 
		affectedClass: aClass! !

!ClyClassComment commentStamp: ''!
I represent class comment.

To create my instances use following script:
 
	ClyClassComment of: Object.
	
My instances are returned from class comments query.

Internal Representation and Key Implementation Points.

    Instance Variables
	definingClass:		<Class>!
!ClyClassComment methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ definingClass = anObject definingClass! !

!ClyClassComment methodsFor: 'accessing' stamp: ''!
definingClass
	^ definingClass! !

!ClyClassComment methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ definingClass hash! !

!ClyClassComment methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream nextPut: $(.
	definingClass printOn: aStream.
	aStream nextPut: $).! !

!ClyClassComment methodsFor: 'accessing' stamp: ''!
definingClass: anObject
	definingClass := anObject! !

!ClyClassComment class methodsFor: 'printing' stamp: ''!
printSystemPathTo: aClassComment
	^aClassComment definingClass package name, ' / ' , aClassComment definingClass name! !

!ClyClassComment class methodsFor: 'sorting' stamp: ''!
defaultSortFunctionForCalypso
	^ClySortByDefiningClassFunction ascending! !

!ClyClassComment class methodsFor: 'testing' stamp: ''!
match: aClassComment forQueryBrowserFilter: aQueryBrowserFilter
	^aClassComment definingClass matchesQueryBrowserFilter: aQueryBrowserFilter! !

!ClyClassComment class methodsFor: 'instance creation' stamp: ''!
of: aClass
	^self new 
		definingClass: aClass! !

!ClyClassComment class methodsFor: 'item convertation' stamp: ''!
convertToCalypsoBrowserItem: aClassComment

	| item |
	item := ClyBrowserItem named: 'Comment' with: aClassComment.
	item addProperty: (ClyClassDefinitionProperty of: aClassComment definingClass).
	^item! !

!ClyClassComment class methodsFor: 'testing' stamp: ''!
checkCalypsoItem: anObject isSameAs: anObject2
	^self checkCalypsoItem: anObject isEqualTo: anObject2! !

!ClyClassCommentEditorToolMorph commentStamp: ''!
I am an editor of class comment!
!ClyClassCommentEditorToolMorph methodsFor: 'testing' stamp: ''!
wantsTextStyling
	^false! !

!ClyClassCommentEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingMode
	^ RubSmalltalkCommentMode new! !

!ClyClassCommentEditorToolMorph methodsFor: 'initialization' stamp: ''!
defaultTitle
	^'Comment'! !

!ClyClassCommentEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingText
	^editingClass comment! !

!ClyClassCommentEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpDefaultIcon
	"Here we duplicate logic of #defaultIconName to directly ask class about comment.
	This method is called during background tab building. 
	So it does not really affect performance which is critical for remote scenario"
	
	| iconName |
	iconName := editingClass hasComment ifTrue: [ #commentsIcon ] ifFalse: [ #uncommentedClass ].
	containerTab icon: (self iconNamed: iconName)! !

!ClyClassCommentEditorToolMorph methodsFor: 'operations' stamp: ''!
applyChanges

	self pendingText asString = self editingText asString 
		ifFalse: [ editingClass 
						comment: self pendingText 
						stamp: Author changeStamp].

	^true! !

!ClyClassCommentEditorToolMorph methodsFor: 'printing' stamp: ''!
printContext
	^super printContext , ' / ', editingClass name! !

!ClyClassCommentEditorToolMorph methodsFor: 'initialization' stamp: ''!
defaultIconName
	^(context lastSelectedItem isMarkedWith: ClyNoCommentTag)
		ifTrue: [ #uncommentedClass ]
		ifFalse: [ #commentsIcon]! !

!ClyClassCommentEditorToolMorph class methodsFor: 'activation' stamp: ''!
classCommentTabActivation
	<classAnnotation>
	
	^ClyTabActivationStrategyAnnotation for: ClyClassComment asCalypsoItemContext! !

!ClyClassCommentEditorToolMorph class methodsFor: 'accessing' stamp: ''!
tabOrder
	^ super tabOrder - 1! !

!ClyClassCommentTableDecorator commentStamp: ''!
I decorate table with simple constant icon for class comments.
For example query browser can show ClyClassComment instances in the table!
!ClyClassCommentTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyClassCommentTableDecorator class methodsFor: 'decoration' stamp: ''!
decorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyClassComment asCalypsoItemContext! !

!ClyClassCommentTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.

	anItemCellMorph definitionIcon: #commentsIcon! !

!ClyClassCommentsQuery commentStamp: ''!
I am a query of class comments

I filter available classes using particular string pattern which class comment should satisfy.
For example it can be simple substring or regex expression. 
But generally pattern is represented by ClyStringPattern subclasses.

To create my instances use following methods:

	ClyClassComment withString: 'probe string'.
	ClyClassComment withString: 'probe string' caseSensitive: true.
	ClyClassComment filteredBy: aStringPattern
	
Internal Representation and Key Implementation Points.

    Instance Variables
	pattern:		<ClyStringPattern>!
!ClyClassCommentsQuery methodsFor: 'testing' stamp: ''!
selectsClass: aClass

	^aClass hasComment and: [ pattern matches: aClass comment]! !

!ClyClassCommentsQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."
	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ pattern = anObject pattern! !

!ClyClassCommentsQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: pattern hash! !

!ClyClassCommentsQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	| classComments |
	classComments := OrderedCollection new.
	
	scope classesDo: [ :each | 
		(self selectsClass: each) ifTrue: [
			classComments add: (ClyClassComment of: each)]].
	
	aQueryResult fillWith: classComments! !

!ClyClassCommentsQuery methodsFor: 'printing' stamp: ''!
description

	^'class comments with ', pattern value printString! !

!ClyClassCommentsQuery methodsFor: 'accessing' stamp: ''!
pattern: anObject
	pattern := anObject! !

!ClyClassCommentsQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream
	super printExtraInfoOn: aStream.

	aStream nextPutAll: pattern value! !

!ClyClassCommentsQuery methodsFor: 'accessing' stamp: ''!
pattern
	^ pattern! !

!ClyClassCommentsQuery class methodsFor: 'instance creation' stamp: ''!
withString: aString caseSensitive: aBool

	^self filteredBy: (ClySubstringPattern with: aString caseSensitive: aBool)! !

!ClyClassCommentsQuery class methodsFor: 'instance creation' stamp: ''!
filteredBy: aStringPattern from: aScope
	^(self from: aScope)
		pattern: aStringPattern! !

!ClyClassCommentsQuery class methodsFor: 'instance creation' stamp: ''!
filteredBy: aStringPattern
	^self new 
		pattern: aStringPattern! !

!ClyClassCommentsQuery class methodsFor: 'instance creation' stamp: ''!
withString: aString

	^self withString: aString caseSensitive: false! !

!ClyClassCommentsQuery class methodsFor: 'instance creation' stamp: ''!
withString: aString caseSensitive: aBool from: aScope

	^self 
		filteredBy: (ClySubstringPattern with: aString caseSensitive: aBool)
		from: aScope! !

!ClyClassCommentsQuery class methodsFor: 'instance creation' stamp: ''!
withString: aString from: aScope

	^self withString: aString caseSensitive: false from: aScope! !

!ClyClassCommentsQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	^ClyClassComment! !

!ClyClassCommentsQueryTest commentStamp: ''!
I am a test case which describes the ClyClassCommentQuery.
It should find all classes which comments includes the given string.
In tests I use following substring:
	it should be in the comment of this class to test class comment query
which should be found!
!ClyClassCommentsQueryTest methodsFor: 'tests' stamp: ''!
testFromClassScope

	self queryFromScope: ClyClassScope ofAll: { self class. self class superclass }.
	
	self assert: resultItems size equals: 1.
	
	self assert: resultItems first equals: (ClyClassComment of: self class)! !

!ClyClassCommentsQueryTest methodsFor: 'tests' stamp: ''!
testComparison
	self assert: (ClyClassCommentsQuery withString: 'test substring') equals: (ClyClassCommentsQuery withString: 'test ' , 'substring').

	self assert: (ClyClassCommentsQuery withString: 'test substring') hash equals: (ClyClassCommentsQuery withString: 'test ' , 'substring') hash.

	self deny: (ClyClassCommentsQuery withString: 'test substring') equals: (ClyClassCommentsQuery withString: 'another substring')! !

!ClyClassCommentsQueryTest methodsFor: 'tests' stamp: ''!
testFromClassWithoutCommentWhenPatternSatisfiesCommentTemplate

	| noCommentClass substring |
	noCommentClass := Object newAnonymousSubclass.
	self deny: noCommentClass hasComment.
	substring := noCommentClass comment copyFrom: 4 to: 30.
	
	query pattern: (ClySubstringPattern with: substring).	
	self queryFromScope: ClyClassScope of: noCommentClass.
	
	self assert: resultItems isEmpty! !

!ClyClassCommentsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyClassScope of: self class in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyClassScope of: self class superclass in: environment).
	self assert: query checkEmptyResult! !

!ClyClassCommentsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyClassCommentsQuery
		withString: self expectedClassCommentSubstring
		from: (ClyPackageScope of: Object package in: environment)! !

!ClyClassCommentsQueryTest methodsFor: 'tests' stamp: ''!
testThisClassShouldIncludeExpectedComment

	self assert: (self class comment 
		includesSubstring: self expectedClassCommentSubstring caseSensitive: false)! !

!ClyClassCommentsQueryTest methodsFor: 'running' stamp: ''!
expectedClassCommentSubstring
	^'it should be in the comment of this class to test class comment query'! !

!ClyClassCreationToolMorph commentStamp: ''!
I am a tool to create a class using textual class definition.

I retrieve a package and class tag from given context and use them in class definition.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	classTag:		<Symbol>
	package:		<RPackage>!
!ClyClassCreationToolMorph methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
supportsCriticDecoration
	^package notNil! !

!ClyClassCreationToolMorph methodsFor: 'accessing' stamp: ''!
classTag: anObject
	classTag := anObject! !

!ClyClassCreationToolMorph methodsFor: 'accessing' stamp: ''!
classTag
	^ classTag! !

!ClyClassCreationToolMorph methodsFor: 'initialization' stamp: ''!
setUpModelFromContext
	super setUpModelFromContext.

	context isPackageSelected ifTrue: [ package := context lastSelectedPackage ].
	context isClassTagSelected ifTrue: [ classTag := context lastSelectedClassTag]! !

!ClyClassCreationToolMorph methodsFor: 'building' stamp: ''!
fillStatusBar 
	super fillStatusBar.
	
	statusBar addCommandItem: (ClyFluidClassDefinitionSwitchMorph for: self)! !

!ClyClassCreationToolMorph methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
decorateByCritic: aCriticTool! !

!ClyClassCreationToolMorph methodsFor: 'initialization' stamp: ''!
defaultTitle
	^'New class'! !

!ClyClassCreationToolMorph methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserTool
	(super isSimilarTo: anotherBrowserTool) ifFalse: [ ^false ].
	
	^package = anotherBrowserTool package 
		and: [ classTag = anotherBrowserTool classTag ]! !

!ClyClassCreationToolMorph methodsFor: 'building' stamp: ''!
editingText
	^self classTemplate! !

!ClyClassCreationToolMorph methodsFor: 'template' stamp: ''!
classTemplate

	^ ClassDefinitionPrinter new compactClassDefinitionTemplateInPackage:  self packageName! !

!ClyClassCreationToolMorph methodsFor: 'accessing' stamp: ''!
packageName

	package ifNil: [ ^'' ].

	classTag ifNil: [ ^package name ].

	^package name , '-' , classTag! !

!ClyClassCreationToolMorph methodsFor: 'operations' stamp: ''!
applyChanges

	| newClass |
	newClass := browser 
						compileANewClassFrom: self pendingText asString 
						notifying: textMorph 
						startingFrom: nil.
	newClass ifNil: [ ^false].
	
	self removeFromBrowser.
	browser selectClass: newClass.
	^true! !

!ClyClassCreationToolMorph methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
criticAnalysisScope

	^ClyPackageScope of: package in: browser navigationEnvironment! !

!ClyClassCreationToolMorph methodsFor: 'testing' stamp: ''!
belongsToCurrentBrowserContext

	| packageSelection |
	packageSelection := browser packageSelection.
	package ifNil: [ ^packageSelection isEmpty].
	packageSelection isEmpty ifTrue: [ ^true ].
	
	^packageSelection includesActualObject: package! !

!ClyClassCreationToolMorph methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!ClyClassCreationToolMorph methodsFor: 'accessing' stamp: ''!
package: anObject
	package := anObject! !

!ClyClassCreationToolMorph methodsFor: 'printing' stamp: ''!
printContext
	package ifNil: [^super printContext].	
	classTag ifNil: [ ^package name ].
	^package name, ' / ' , classTag! !

!ClyClassCreationToolMorph methodsFor: 'initialization' stamp: ''!
defaultIconName
	^#add! !

!ClyClassCreationToolMorph class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserPackageActivation
	<classAnnotation>
	
	^ClyTabActivationStrategyAnnotation for: ClyFullBrowserPackageContext! !

!ClyClassCreationToolMorph class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserClassGroupActivation
	<classAnnotation>
	
	^ClyTabActivationStrategyAnnotation for: ClyFullBrowserClassGroupContext! !

!ClyClassCreationToolMorph class methodsFor: 'accessing' stamp: ''!
tabOrder
	^1! !

!ClyClassCreationToolMorph class methodsFor: 'testing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	^aBrowserContext isClassSelected not! !

!ClyClassDefinitionEditorToolMorph commentStamp: ''!
I am an editor of class definition.
I allow to modify class properties (package, tags and variables) using text editor.

And in addition I allow to create new classes by typing new class name!
!ClyClassDefinitionEditorToolMorph methodsFor: 'building' stamp: ''!
decorateContainerTab
	| title |
	super decorateContainerTab.
	title := editingClass name.

	editingClass isClassSide 
		ifTrue: [ title := title asText allBold ].

	containerTab label: title! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpModelFromContext

	super setUpModelFromContext.
	editingClass := context selectedClassSide! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'to sort' stamp: ''!
createTextContext
	^self selectedSourceNode
		ifNil: [ super createTextContext ]
		ifNotNil: [ :astNode | ClyClassDefinitionContext for: self selectedNode: astNode]! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'building' stamp: ''!
fillStatusBar 
	super fillStatusBar.
	statusBar addCommandItem: (ClyFluidClassDefinitionSwitchMorph for: self)! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'accessing' stamp: ''!
selectedSourceNode
	| selectedInterval definitionNode |
	selectedInterval := self selectedTextInterval.
	definitionNode := self parseClassDefinition.
	
	^(definitionNode bestNodeFor: selectedInterval)
		ifNil: [ definitionNode ]! !

!ClyClassDefinitionEditorToolMorph methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
decorateByCritic: aCriticTool! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'selecting text' stamp: ''!
selectVariableNamed: aString 
	| classDefinition varNode |
	classDefinition := self parseClassDefinition.
	varNode := classDefinition children 
		detect: [ :each | each isVariable and: [each name = aString]]
		ifNone: [ ^self ].
	self selectSourceNode: varNode! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'to sort' stamp: ''!
editingText
	
	^ editingClass definitionString! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'selecting text' stamp: ''!
selectSourceNode: aCDNode 
	textMorph setSelection: aCDNode sourceInterval! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'building' stamp: ''!
applyChangesAsMethodDefinition

	| newMethod selector selectedClass |
	selectedClass := self editingClass.

	selector := selectedClass
		            compile: self pendingText asString
		            notifying: textMorph.

	selector ifNil: [ ^ false ].
	newMethod := selectedClass >> selector.
	MethodClassifier classify: newMethod.

	self removeFromBrowser.
	browser tabManager desiredSelection: { ClyMethodCodeEditorToolMorph }.
	browser selectMethod: newMethod.
	^ true! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'to sort' stamp: ''!
parseClassDefinition

	self editingClass needsSlotClassDefinition 
		ifTrue: [ ^ ClassDefinitionPrinter fluid classDefinitionParserClass parse: self editingText].
	^ ClassDefinitionPrinter new classDefinitionParserClass parse: self editingText! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'building' stamp: ''!
applyChanges

	| text |
	text := self pendingText copy.
	^ self applyChangesAsClassDefinition or: [ 
		  self pendingText: text.
		  self applyChangesAsMethodDefinition ]! !

!ClyClassDefinitionEditorToolMorph methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
criticAnalysisScope
	^ ClyClassScope of: editingClass in: browser navigationEnvironment! !

!ClyClassDefinitionEditorToolMorph methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
supportsCriticDecoration
	^true! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'testing' stamp: ''!
isCommandAvailable: aCommand 

	^ aCommand canBeExecutedInClassEditor: self! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'building' stamp: ''!
applyChangesAsClassDefinition

	| newClass oldText |
	oldText := self pendingText copy.
	newClass := browser
		            compileANewClassFrom: self pendingText asString
		            notifying: textMorph
		            startingFrom: editingClass.
	
	"This was indeed a class, however, there is a syntax error somewhere"
	textMorph text = oldText ifFalse: [ ^ true ].
	
	newClass ifNil: [ ^ false ].

	editingClass == newClass ifFalse: [ self removeFromBrowser ].
	browser selectClass: newClass.
	^ true! !

!ClyClassDefinitionEditorToolMorph methodsFor: 'initialization' stamp: ''!
defaultIconName
	^#classIcon! !

!ClyClassDefinitionProperty commentStamp: ''!
I represent definition of class which includes package and class itself as defining objects.

You can create me by: 

	ClyClassDefinitionProperty of: aClass!
!ClyClassDefinitionProperty methodsFor: 'printing' stamp: ''!
printDefinition
	^definingPackageItem name! !

!ClyClassDefinitionProperty class methodsFor: 'instance creation' stamp: ''!
of: aClass
	
	^self package: aClass package class: aClass! !

!ClyClassEditorToolMorph commentStamp: ''!
I am a base class for various class editors based on text.

My subclasses retrieve particular textual property from the class and initialize text editor with it.
My subclasses are activated in context of selected class which I keep in my editingClass variable.

Internal Representation and Key Implementation Points.

    Instance Variables
	editingClass:		<Class>!
!ClyClassEditorToolMorph methodsFor: 'testing' stamp: ''!
belongsToRemovedBrowserContext
	^editingClass isObsolete! !

!ClyClassEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingClass
	^editingClass! !

!ClyClassEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpModelFromContext

	super setUpModelFromContext.
	editingClass := context lastSelectedClass! !

!ClyClassEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
selectedClassOrMetaClass
	^editingClass! !

!ClyClassEditorToolMorph methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserTool

	(super isSimilarTo: anotherBrowserTool) ifFalse: [ ^false ].	
	^editingClass = anotherBrowserTool editingClass! !

!ClyClassEditorToolMorph methodsFor: 'controlling' stamp: ''!
detachFromSystem

	browser system unsubscribe: self! !

!ClyClassEditorToolMorph methodsFor: 'testing' stamp: ''!
belongsToCurrentBrowserContext

	^(browser isClassSelected: editingClass)
		or: [ browser isClassSelected: editingClass instanceSide ]! !

!ClyClassEditorToolMorph methodsFor: 'controlling' stamp: ''!
attachToSystem

	browser system 
		when: (ClyClassChange of: editingClass) send: #triggerUpdate to: self! !

!ClyClassEditorToolMorph methodsFor: 'printing' stamp: ''!
printContext
	^editingClass printSystemPath! !

!ClyClassEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingClass: anObject
	editingClass := anObject! !

!ClyClassEditorToolMorph class methodsFor: 'activation' stamp: ''!
classTabActivation
	<classAnnotation>
	
	^ClyTabActivationStrategyAnnotation for: ClyClass asCalypsoItemContext! !

!ClyClassEditorToolMorph class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyClassEditorToolMorph! !

!ClyClassEditorToolMorph class methodsFor: 'accessing' stamp: ''!
tabOrder
	^ 10! !

!ClyClassEditorToolMorph class methodsFor: 'testing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	^aBrowserContext isClassSelected! !

!ClyClassExternalReferencesQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	| toExclude |
	
	super buildResult: aQueryResult.
	toExclude := self variableQuery resultItems flatCollect: [ :each | { each . each classSide } ].
	aQueryResult items removeAllSuchThat: [ :each | toExclude includes: each origin ]! !

!ClyClassExternalReferencesQueryTest methodsFor: 'tests' stamp: ''!
testFromSystemScope

	self queryFromScope: ClySystemEnvironmentScope of: ClySystemEnvironment currentImage.
	"Expect the query to be empty even though the class references itself in #referencedClass"
	self assert: resultItems isEmpty! !

!ClyClassExternalReferencesQueryTest methodsFor: 'running' stamp: ''!
referencedClass
	"Use an explicit reference instead of 'self class'"
	^ClyClassExternalReferencesQueryTest! !

!ClyClassExternalReferencesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyClassExternalReferencesQuery
		to: self referencedClass
		from: (ClyClassScope of: Object in: environment)! !

!ClyClassGroup commentStamp: ''!
I am a root of hierarchy of class groups.

Any class group is created on class query:

	ClyClassGroup named: 'some group' on: aClassQuery

Class query can be also composite but it should return classes.

Also I can be expanded to subgroups using subgroupsQuery. You can specify it in another instance creation method: 

	ClyClassGroup named: 'some group' on: aClassQuery withSubgroupsFrom: aQuery	

And there are additional constructors to specify priority of group:

	ClyClassGroup named: 'some group' priority: 20 on: aClassQuery.
	ClyClassGroup named: 'some group' priority: 20 on: aClassQuery withSubgroupsFrom: aQuery

All groups are sorted by priority and name in the browser. Larger priority value put group to the top of list.

I provide several methods to implement various commands: 

- importClass: aClass
It supposed to modify given aClass in the way that it will become the part of group.

- importClasses: classes 
It imports multiple classes
		 
- removeWithClasses
It removes all classes and should ensure that groups will be removed too which is true for all virtual groups.

Internal Representation and Key Implementation Points.

    Instance Variables
	classQuery:		<ClyClassQuery>
	subgroupsQuery:		<ClyQuery>!
!ClyClassGroup methodsFor: 'accessing' stamp: ''!
classesSize
	^classQuery execute size! !

!ClyClassGroup methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class	ifFalse: [ ^ false ].
	^ classQuery = anObject classQuery! !

!ClyClassGroup methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	subgroupsQuery := ClyUnknownQuery instance! !

!ClyClassGroup methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ classQuery hash! !

!ClyClassGroup methodsFor: 'accessing' stamp: ''!
subgroupsQuery
	^ subgroupsQuery! !

!ClyClassGroup methodsFor: 'accessing' stamp: ''!
classQuery
	^ classQuery! !

!ClyClassGroup methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	classQuery printOn: aStream.
	aStream nextPut: $).! !

!ClyClassGroup methodsFor: 'operations' stamp: ''!
importClasses: classesCollection

	classesCollection do: [ :each | self importClass: each ]! !

!ClyClassGroup methodsFor: 'decoration' stamp: ''!
decorateOwnBrowserItem: myItem
	super decorateOwnBrowserItem: myItem.
		
	classQuery decorateItemGroup: myItem.	
	subgroupsQuery decorateItemGroup: myItem! !

!ClyClassGroup methodsFor: 'accessing' stamp: ''!
subgroupsQuery: anObject
	subgroupsQuery := anObject! !

!ClyClassGroup methodsFor: 'operations' stamp: ''!
importClass: aClass! !

!ClyClassGroup methodsFor: 'accessing' stamp: ''!
classQuery: anObject
	classQuery := anObject! !

!ClyClassGroup methodsFor: 'operations' stamp: ''!
removeWithClasses
	self classes do: [ :each | each removeFromSystem ]! !

!ClyClassGroup methodsFor: 'accessing' stamp: ''!
classes
	^classQuery execute items! !

!ClyClassGroup class methodsFor: 'accessing' stamp: ''!
prepareClassQueriesFrom: classGroups in: aNavigationEnvironment

	^ classGroups collect: [ :each | each classQuery ]! !

!ClyClassGroup class methodsFor: 'instance creation' stamp: ''!
named: aString on: aClassQuery
	^(self named: aString)
		classQuery: aClassQuery! !

!ClyClassGroup class methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: aBrowserItem by: anEnvironmentPlugin
	^ anEnvironmentPlugin
		decorateBrowserItem: aBrowserItem
		ofClassGroup: aBrowserItem actualObject! !

!ClyClassGroup class methodsFor: 'instance creation' stamp: ''!
named: aString priority: aNumber on: aClassQuery withSubgroupsFrom: subgroupsQuery
	^(self named: aString priority: aNumber on: aClassQuery) 
		subgroupsQuery: subgroupsQuery! !

!ClyClassGroup class methodsFor: 'testing' stamp: ''!
isBasedOnClassTag
	^false! !

!ClyClassGroup class methodsFor: 'instance creation' stamp: ''!
named: aString on: aClassQuery  withSubgroupsFrom: subgroupsQuery
	^(self named: aString on: aClassQuery) 
		subgroupsQuery: subgroupsQuery! !

!ClyClassGroup class methodsFor: 'instance creation' stamp: ''!
named: aString priority: aNumber on: aClassQuery
	^(self named: aString priority: aNumber)
		classQuery: aClassQuery! !

!ClyClassGroupProvider commentStamp: ''!
I am a root of hierarchy of class group providers.
My subclasses must build class groups for given package scope.

They should implement following method: 

- classGroupsIn: aPackageScope do: aBlock

It should create class group instances and pass them into the block.
Look at ClyClassGroup comment to see how create groups.!
!ClyClassGroupProvider methodsFor: 'building groups' stamp: ''!
classGroupsIn: aPackageScope do: aBlock
	self subclassResponsibility! !

!ClyClassGroupProvider methodsFor: 'system changes' stamp: ''!
providesGroupsAffectedBy: aSystemAnnouncement inScope: aPackageScope
	aPackageScope packagesDo: [ :each | 
		(aSystemAnnouncement affectsPackage: each) ifTrue: [^true]].
	^false! !

!ClyClassGroupProviderTest methodsFor: 'running' stamp: ''!
packageSampleWhichHasGroup
	self subclassResponsibility! !

!ClyClassGroupProviderTest methodsFor: 'running' stamp: ''!
buildGroupsForAll: packages
	| classScope |
	classScope := ClyPackageScope ofAll: packages in: environment.
	groupProvider
		classGroupsIn: classScope
		do: [ :each | builtGroups add: each ]! !

!ClyClassGroupProviderTest methodsFor: 'running' stamp: ''!
buildGroupsFor: aPackage
	| classScope |
	classScope := ClyPackageScope of: aPackage in: environment.
	groupProvider
		classGroupsIn: classScope
		do: [ :each | builtGroups add: each ]! !

!ClyClassGroupProviderTest methodsFor: 'tests' stamp: ''!
testBuildingGroups

	self buildGroupsFor: self packageSampleWhichHasGroup.
	
	self assert: builtGroups notEmpty! !

!ClyClassGroupProviderTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyClassGroupProviderTest! !

!ClyClassHierarchy commentStamp: ''!
My subclasses provide model of different kind of class hierarchies.
They define concrete relationship between classes which are used to build hierarchies.
The result of build is an instance of ClyClassHierarchyMap which provides dictionary between parent classes and their children.
To build map instance use following message: 

	map := ClySubclassHierarchy new buildFrom: { Object. Array }.

or simply ask class for this:

	map := ClySubclassHierarchy buildFrom: { Object. Array }.

With hierarchy map you can iterate classes in hierarchical order: 

	map doInOrder: [ :class | ].
	map doInOrderWithDepth: [ :class :depth | ].

And you can ask map for children of class: 

	map childrenOf: Object.
	
Or you can also access the roots: 

	map rootsDo: [ :class | ]

The children are collected as sorted list which order is defined by #sortFunction.
So you can build hierarchies where children are sorted by different criterias. By default they are sorted by class name in ascending order.
To instantiate hierarchy with another sort function use following expression:
	
	ClySubclassHierarchy sortedBy: aSortFunction 
	
And you can build sorted hierarchy using short class side method:

	ClySubclassHierarchy buildFrom: Smalltalk allClasses sortedBy: ClySortByNameFunction descending.

It will sort children by class name in reversed order.

And you can convert any hierarchy to new sorted version: 

	newHierarchy := aHierarchy sortedBy: aSortFunction.

So subclasses define relationship between classes. They should implement following method:

- buildParentMap: aHierarchyMap for: aClass

where they add every pair parent and aClass to the map. They should do it using following method: 

	aHierarchyMap addChild: aClass to: eachParentClass

Look at implementors of #buildParentMap:for: for examples.

The relationship which defined by each subclass arranges kind of natural order of hierarchy. But it can be inverted.
For example natural order of ClySubclassHierarchy will put all common superclasses to the roots of hierarchy.
And inverse version will put all leaf subclasses to the roots.

I encode flag inverse logic in the variable #inverse. You can create inverse hierarchies with following expression: 

	ClySubclassHierarchy inverse.

Or you can build inverse hierarchy with short class side methods: 

	ClySubclassHierarchy buildInverseFrom: {Object. String}.
	ClySubclassHierarchy buildInverseFrom: {Object. String} sortedBy: aSortFunction.

You can see in inspector that in first expression the root is String class.

And you can convert any hierarchy to the inverted version: 

	newHierarchy := aHierarchy inverted.

Also I provide converting method to create query result which you can pass to the queries: 

	ClyAllClasses as: ClySubclassHierarchy inverse asQueryResult 

Internal Representation and Key Implementation Points.

    Instance Variables
	inverse:		<Boolean>
	sortFunction:		<SortFunction>!
!ClyClassHierarchy methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ sortFunction = anObject sortFunction
		and: [ inverse = anObject isInverse ]! !

!ClyClassHierarchy methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	inverse := false! !

!ClyClassHierarchy methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ sortFunction hash bitXor: inverse hash! !

!ClyClassHierarchy methodsFor: 'accessing' stamp: ''!
inverse: aBoolean
	inverse := aBoolean! !

!ClyClassHierarchy methodsFor: 'accessing' stamp: ''!
sortFunction: anObject
	sortFunction := anObject! !

!ClyClassHierarchy methodsFor: 'building' stamp: ''!
buildParentMap: aHierarchyMap for: aClass
	self subclassResponsibility! !

!ClyClassHierarchy methodsFor: 'converting' stamp: ''!
inverted
	^self copy 
		inverse: inverse not! !

!ClyClassHierarchy methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	inverse ifTrue: [ aStream nextPutAll: '(inverse)']! !

!ClyClassHierarchy methodsFor: 'converting' stamp: ''!
asQueryResult

	^ClyHierarchicallySortedClassesResult with: self! !

!ClyClassHierarchy methodsFor: 'converting' stamp: ''!
sortedBy: aSortFunction
	^self copy 
		sortFunction: aSortFunction! !

!ClyClassHierarchy methodsFor: 'composition' stamp: ''!
, anotherHierarchy
	^ClyMergedHierarchy merge: { self. anotherHierarchy }! !

!ClyClassHierarchy methodsFor: 'building' stamp: ''!
containerForChildren
	^SortedCollection sortBlock: sortFunction! !

!ClyClassHierarchy methodsFor: 'accessing' stamp: ''!
sortFunction
	^ sortFunction! !

!ClyClassHierarchy methodsFor: 'testing' stamp: ''!
isInverse
	^inverse! !

!ClyClassHierarchy methodsFor: 'building' stamp: ''!
buildFrom: classes
	| map |
	map := ClyClassHierarchyMap for: self of: classes.
	map build.
	^map! !

!ClyClassHierarchy class methodsFor: 'instance creation' stamp: ''!
new
	^super new 
		sortFunction: ClySortByNameFunction ascending! !

!ClyClassHierarchy class methodsFor: 'building' stamp: ''!
buildFrom: classes sortedBy: aSortFunction
	^(self sortedBy: aSortFunction)
		buildFrom: classes! !

!ClyClassHierarchy class methodsFor: 'instance creation' stamp: ''!
sortedBy: aSortFunction
	^super new 
		sortFunction: aSortFunction! !

!ClyClassHierarchy class methodsFor: 'building' stamp: ''!
buildInverseFrom: classes sortedBy: aSortFunction

	^(self sortedBy: aSortFunction)
		inverse: true;
		buildFrom: classes! !

!ClyClassHierarchy class methodsFor: 'instance creation' stamp: ''!
inverse
	^self new 
		inverse: true! !

!ClyClassHierarchy class methodsFor: 'building' stamp: ''!
buildFrom: classes
	^self buildFrom: classes sortedBy: ClySortByNameFunction ascending! !

!ClyClassHierarchy class methodsFor: 'building' stamp: ''!
buildInverseFrom: classes
	^self buildInverseFrom: classes sortedBy: ClySortByNameFunction ascending! !

!ClyClassHierarchyChanged commentStamp: ''!
I am a root of special kind of ClassAnnouncement which subclasses are triggered by ClyInheritanceAnalysisEnvironmentPlugin to invalidate related method queries.

Plugin decorates methods with overriding and overridden status. And to update this information in arbitrary method queries plugin triggers special kind of events which override default event processing logic.

For example Object methods status should be updated when you remove some subclass which overrides his method.
And otherwise when you change superclass of another class. Subclasses of another class should update their methods status because they could override methods from original removed deep superclass.!
!ClyClassHierarchyChanged methodsFor: 'testing' stamp: ''!
affectsMethod: aMethod
	^self affectsMethodsDefinedInClass: aMethod origin! !

!ClyClassHierarchyChanged methodsFor: 'testing' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery
	^true! !

!ClyClassHierarchyChanged methodsFor: 'testing' stamp: ''!
affectsMethods
	"When class hierarchy is changed dur to modified superclass of subclass
	it always affect override status of methods in hierarchy"
	^true! !

!ClyClassHierarchyMap commentStamp: ''!
I represent the actual relationship between classes using simple map between parents and children.
Concrete type of hierarchy build my instances where it defines what classes should be parent and what should be children:

	aHierarchyMap addChild: childClass to: parentClass.

My instances are created by hierarchies using following method: 

	map := ClyClassHierarchyMap for: aHierarchy of: classes.

And my method #build initiates actual map building. 

Users do not need to create map directly. Instead they ask concrete hierarchy to build from classes: 

	map := ClySubclassHierarchy buildFrom: classes.

During building I collect roots which are used as a starting point to access classes in hierarchical order:

	map doInOrder: [ :class |  ]
	map doInOrderWithDepth: [ :class :depth | ]

You can also iterate roots: 

	map rootsDo: [ :class |  ]

Childen of every class are sorted according to the sort function of the hierarchy.

Internal Representation and Key Implementation Points.

    Instance Variables
	classes:		<IdentitySet<Class>>
	hierarchy:		<ClyClassHierarchy>
	parentMap:		<Dictionary<Class, SortedCollection<Class>>>
	roots:		<IdentitySet<Class>>!
!ClyClassHierarchyMap methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	parentMap := IdentityDictionary new.! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
childrenOf: aClass
	^parentMap at: aClass ifAbsent: [ #() ]! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
hierarchy: anObject
	hierarchy := anObject! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
hierarchy
	^ hierarchy! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
allChildrenOf: aClass depth: currentDepth do: blockWithClass

	| children childDepth |
	children := parentMap at: aClass ifAbsent: [ ^self ].
	childDepth := currentDepth + 1.
	children do: [:eachChild | 
		blockWithClass value: eachChild value: childDepth.
		self allChildrenOf: eachChild depth: childDepth do: blockWithClass]! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
classes: classCollection
	classes := classCollection asIdentitySet! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
allChildrenOf: aClass do: blockWithClass

	| children |
	children := parentMap at: aClass ifAbsent: [ ^self ].
	children do: [:eachChild | 
		blockWithClass value: eachChild.
		self allChildrenOf: eachChild do: blockWithClass]! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
doInOrder: blockWithClass
	
	self rootsDo: [ :root | 
		blockWithClass value: root.
		self allChildrenOf: root do: blockWithClass ]! !

!ClyClassHierarchyMap methodsFor: 'testing' stamp: ''!
includesClass: aClass
	^classes includes: aClass! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
rootsDo: aBlock

	self containerForChildren 
		addAll: roots;
		do: aBlock! !

!ClyClassHierarchyMap methodsFor: 'building' stamp: ''!
build
	
	roots := IdentitySet withAll: classes.
	parentMap := IdentityDictionary new.
	
	classes do: [ :each |	hierarchy buildParentMap: self for: each]! !

!ClyClassHierarchyMap methodsFor: 'private' stamp: ''!
addActualChild: childClass to: parentClass
 
	| children |
	children := parentMap at: parentClass ifAbsentPut: [	self containerForChildren].
	children add: childClass.
	roots remove: childClass ifAbsent: nil! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
containerForChildren
	^hierarchy containerForChildren! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
addChild: childClass to: parentClass
 
	hierarchy isInverse 
		ifTrue: [ self addActualChild: parentClass to: childClass ]
		ifFalse: [ self addActualChild: childClass to: parentClass ]! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
doInOrderWithDepth: blockWithClassAndDepth
	
	self rootsDo: [ :root | 
		blockWithClassAndDepth value: root value: 0.
		self allChildrenOf: root depth: 0 do: blockWithClassAndDepth ]! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
roots
	^roots! !

!ClyClassHierarchyMap methodsFor: 'accessing' stamp: ''!
classes
	^ classes! !

!ClyClassHierarchyMap class methodsFor: 'instance creation' stamp: ''!
for: aClassHierarchy of: classes
	^self new 
		hierarchy: aClassHierarchy;
		classes: classes! !

!ClyClassHierarchyScope commentStamp: ''!
I am a root of scope classes which show objects accessible from the particular kind of class hierarchy. 
For example there is ClySuperclassScope with superclasses of basis classes and all their methods (inherited by basis).
And there is ClySubclassScope which shows all subclasses and their methods.

I implement all abstract methods from superclass and introduce new method which should be defined by subclasses: 

- classesRelatedTo: aClass do: aBlock

In this method subclasses should evaluate given block with all other classes which are related to given aClass according to the logic of given class hierarchy.

My varable localScopeClass specifies what part of class itself is visible. It can be instance side, class side or both with corresponsing variable values: ClyInstanceSideScope, ClyClassSideScope and ClyBothMetaLevelClassScope.
I use this variable to define methods required for scope query protocol. Look at overrides for details.

To create instance I provide several new methods where you can specify local scope class:

	ClySubclassScope of: Array localScope: ClyClassSideScope.
	ClySubclassScope of: Array in: ClyNavigationEnvironment currentImage localScope: ClyInstanceSideScope.
	ClySubclassScope ofAll: {Array. Point} localScope: ClyBothMetaLevelClassScope.
	ClySubclassScope ofAll: {Array. Point} in: ClyNavigationEnvironment currentImage  localScope: ClyClassScope.
	
Internal Representation and Key Implementation Points.

    Instance Variables
	localScopeClass:		<ClyLocalClassScope class>!
!ClyClassHierarchyScope methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^false ].
	
	^ localScopeClass = anObject localScopeClass! !

!ClyClassHierarchyScope methodsFor: 'converting' stamp: ''!
adoptLocalScopeClassTo: aLocalScopeClass
	localScopeClass := aLocalScopeClass! !

!ClyClassHierarchyScope methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: localScopeClass hash! !

!ClyClassHierarchyScope methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	localScopeClass := ClyClassScope "By default we only look at own class meta level"! !

!ClyClassHierarchyScope methodsFor: 'meta level' stamp: ''!
localScopeClass: aLocalScopeClass
	localScopeClass := aLocalScopeClass! !

!ClyClassHierarchyScope methodsFor: 'queries' stamp: ''!
methodsDo: aBlock

	self classesDo: [ :eachClass | 
		eachClass methods do: aBlock ]! !

!ClyClassHierarchyScope methodsFor: 'meta level' stamp: ''!
metaLevelsOf: aClass do: aBlock

	localScopeClass metaLevelsOf: aClass do: aBlock! !

!ClyClassHierarchyScope methodsFor: 'queries' stamp: ''!
classesDo: aBlock

	basisObjects do: [ :each | 
		self allClassesRelatedTo: each do: aBlock]! !

!ClyClassHierarchyScope methodsFor: 'meta level' stamp: ''!
localScopeClass
	^ localScopeClass! !

!ClyClassHierarchyScope methodsFor: 'testing' stamp: ''!
canDetectAffectOnClassesBy: aSystemAnnouncement
	"I can not detect that removed class was in my hierarchy.
	I can not detect that removed trait from class definition was in users hierarchy of some root trait.
	For example when remove event is announced 
	then affected class is still in the list of subclasses of superclass"		
	
	^(aSystemAnnouncement isKindOf: ClassAnnouncement) not! !

!ClyClassHierarchyScope methodsFor: 'converting' stamp: ''!
asLocalClassScope
	^self asScope: localScopeClass! !

!ClyClassHierarchyScope methodsFor: 'queries' stamp: ''!
classesRelatedTo: aClass do: aBlock
	self subclassResponsibility! !

!ClyClassHierarchyScope methodsFor: 'converting' stamp: ''!
withMetaLevel: aScopeClass 
	^self copy 
		localScopeClass: aScopeClass! !

!ClyClassHierarchyScope methodsFor: 'queries' stamp: ''!
allClassesRelatedTo: aClass do: aBlock
	"Any hierarchy is defined in terms of relationship between classes 
	retrieved from meta level which are specified by local scope class
	Hierarchy analyze are continue only when following condition is true:
		(localClassScope metaLevelForHierarchyOf: each) = each
	It ensures that at next iteration we will not move out of specified local class scope bounderies  
	It is important condition for complex cases when we are analyzing metaclasses.
	For example Class allSubclasses will return almost all classes in system.
	And depending on local scope we want all of them 
	or we want only actual subclasses which was defined by users.
	So only with ClassScope as local scope we will see everything.
	But concrete meta level scopes (instance side or class side) will see you only real classes
	
	Also any hierarchy scope should ignore obsolete classes"
	| actualClass |
	actualClass := localScopeClass metaLevelForHierarchyOf: aClass.
	
	self classesRelatedTo: actualClass do: [:each | 
		((localScopeClass metaLevelForHierarchyOf: each) = each) ifTrue: [ 
			each isObsolete ifFalse: [ self metaLevelsOf: each do: aBlock].
			self allClassesRelatedTo: each do: aBlock]]! !

!ClyClassHierarchyScope class methodsFor: 'instance creation' stamp: ''!
ofAll: basisObjects localScope: aClassScopeClass
	^ (self ofAll: basisObjects) localScopeClass: aClassScopeClass! !

!ClyClassHierarchyScope class methodsFor: 'instance creation' stamp: ''!
ofAll: basisObjects in: aNavigationEnvironment localScope: aClassScopeClass
	^ (self ofAll: basisObjects in: aNavigationEnvironment)
		localScopeClass: aClassScopeClass! !

!ClyClassHierarchyScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^self hierarchyScopeName! !

!ClyClassHierarchyScope class methodsFor: 'instance creation' stamp: ''!
of: basisObjects localScope: aClassScopeClass
	^ (self of: basisObjects) localScopeClass: aClassScopeClass! !

!ClyClassHierarchyScope class methodsFor: 'instance creation' stamp: ''!
of: basisObjects in: aNavigationEnvironment localScope: aClassScopeClass
	^ (self of: basisObjects in: aNavigationEnvironment)
		localScopeClass: aClassScopeClass! !

!ClyClassHierarchyScopeTest methodsFor: 'tests' stamp: ''!
testComparisonWithSimilarScopeButWithDifferentMetaLevelScope
	| scope2 |
	scope := self createSampleScope.
	scope2 := self createSampleScope.

	self deny: scope localScopeClass equals: ClyInstanceSideScope.
	scope2 localScopeClass: ClyInstanceSideScope.
	self deny: scope equals: scope2! !

!ClyClassHierarchyScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToInheritingScope
	| convertedScope |
	scope := self createSampleScope.
	scope localScopeClass: ClyInstanceSideScope.
	
	convertedScope := scope asInheritingScope.
	
	self assert: (convertedScope representsScope: ClySubclassScope).
	self assert: convertedScope localScopeClass equals: ClyInstanceSideScope.
	self assert: convertedScope basisObjects equals: scope basisObjects.
	self assert: convertedScope environment equals: environment.
	self assert: convertedScope name equals: ClyClassScope inheritingScopeName! !

!ClyClassHierarchyScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToInheritedScope
	| convertedScope |
	scope := self createSampleScope.
	scope localScopeClass: ClyInstanceSideScope.
	
	convertedScope := scope asInheritedScope.
	
	self assert: (convertedScope representsScope: ClySuperclassScope).
	self assert: convertedScope localScopeClass equals: ClyInstanceSideScope.
	self assert: convertedScope basisObjects equals: scope basisObjects.
	self assert: convertedScope environment equals: environment.
	self assert: convertedScope name equals: ClyClassScope inheritedScopeName! !

!ClyClassHierarchyScopeTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewBasisShouldKeepMetaLevelScope
	| convertedScope |
	scope := self singleScopeSample.
	scope localScopeClass: ClyInstanceSideScope.
	
	convertedScope := scope withNewBasisObjects: {self extraBasisSample}.
	
	self assert: convertedScope localScopeClass equals: ClyInstanceSideScope! !

!ClyClassHierarchyScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToNewMetaLevel
	| convertedScope |
	scope := self createSampleScope.
	self deny: scope localScopeClass equals: ClyInstanceSideScope.

	convertedScope := scope withMetaLevel: ClyInstanceSideScope.

	self assert: convertedScope class equals: scope class.
	self assert: convertedScope localScopeClass equals: ClyInstanceSideScope.
	self assert: convertedScope basisObjects equals: scope basisObjects.
	self assert: convertedScope environment equals: environment! !

!ClyClassHierarchyScopeTest methodsFor: 'tests' stamp: ''!
testHasDefaultClassLocalScope

	scope := self createSampleScope.
	
	self assert: scope localScopeClass equals: ClyClassScope! !

!ClyClassHierarchyScopeTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyClassHierarchyScopeTest! !

!ClyClassHierarchyToolbarGroup commentStamp: ''!
I am a toolbar menu group to show class view modes of the browser together!
!ClyClassHierarchyToolbarGroup methodsFor: 'accessing' stamp: ''!
order
	^2! !

!ClyClassIconTableDecorator commentStamp: ''!
I decorate classes with their icons defined by #systemIcon method.

My decoration logic is a bit complex. I am supposed to work in remote browser too. And sending #systemIcon to remote class would be very expensive.
So instead I find same class in my local environment and ask it for the icon.!
!ClyClassIconTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyClassIconTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	
	| icon |
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	    
   icon := Object environment at: aDataSourceItem name asSymbol
            ifPresent: [ :aClass | aClass systemIcon ]
            ifAbsent: [ Object systemIcon ].

    anItemCellMorph definitionMorph: icon asMorph! !

!ClyClassInitializationScript commentStamp: ''!
I represent class side method #initialize!
!ClyClassInitializationScript methodsFor: 'accessing' stamp: ''!
description
	^ '(Re)initialize class'! !

!ClyClassInitializationScript class methodsFor: 'script detection' stamp: ''!
isImplementedByMethod: aMethod

	^ aMethod selector == #initialize! !

!ClyClassQuery commentStamp: ''!
I am abstract query of all classes from given scope.
Subclasses should define concrete condition which all retrieved classes should satisfy: 
- selectsClass: aClass 

Scope should support #classesDo: which I use to collect and filter all available classes.

I provide several convenient methods to instantiate queries with hierarchical result:

	ClyAllClasses hierarchical
	ClyAllClasses hierarchicalFrom: aScope
	
In that cases instances will be created with ClyHierarchicallySortedClasses required result!
!ClyClassQuery methodsFor: 'testing' stamp: ''!
selectsClass: aClass
	self subclassResponsibility! !

!ClyClassQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin
	anEnvironmentPlugin collectMetadataOfClasses: aQueryResult! !

!ClyClassQuery methodsFor: 'testing' stamp: ''!
retrievesItem: aClass
	^self selectsClass: aClass! !

!ClyClassQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	(scope includesClassesAffectedBy: aSystemAnnouncement) ifTrue: [ ^true ].
	
	(scope canDetectAffectOnClassesBy: aSystemAnnouncement) ifTrue: [ ^false ].	
	"In some scopes we should check every class that it was affected by event
	For example class hierarchy scope could not track that removed class was in hierarchy using only events. 
	It should be improved in system but right now it is like that"					
	aQueryResult rawItemsDo: [ :each |
		(aSystemAnnouncement affectsClass: each) ifTrue: [^true]].	
	^false! !

!ClyClassQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	| filteredClasses |
	filteredClasses := Set new.
	
	scope classesDo: [ :each | 
		(self selectsClass: each) ifTrue: [filteredClasses add: each]].
	
	aQueryResult fillWith: filteredClasses! !

!ClyClassQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	scope classesDo: [ :each | 
		(self selectsClass: each) ifTrue: [^false]].
	
	^true! !

!ClyClassQuery class methodsFor: 'instance creation' stamp: ''!
hierarchical

	^self as: ClyHierarchicallySortedClassesResult new! !

!ClyClassQuery class methodsFor: 'instance creation' stamp: ''!
hierarchicalFrom: aScope

	^self from: aScope as: ClyHierarchicallySortedClassesResult new! !

!ClyClassQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	^ClyClass! !

!ClyClassQueryTest methodsFor: 'tests' stamp: ''!
testIsEmptyFromEmptyClassScope

	query scope: (ClyClassScope emptyIn: environment).
	
	self assert: query checkEmptyResult! !

!ClyClassQueryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyClassQueryTest! !

!ClyClassReferencesQuery commentStamp: ''!
I return methods which reference given classes.
So I expect that my variableQuery will be in fact class query.
But because class itself is not a variable I convert given query to class bindings which can play role of variables in the method filtering logic:

	ClyClassReferences>>variableQuery: aClassQuery
		super variableQuery: (aClassQuery withResult: ClyClassBindings new)

And in addition I provide more readable methods to instantiate my instances from classes:

	ClyClassReferences to: aClass.
	ClyClassReferences to: aClass from: aScope.
	ClyClassReferences toAny: {Array. String}.
	ClyClassReferences toAny: {Array. String} from: aScope.!
!ClyClassReferencesQuery methodsFor: 'testing' stamp: ''!
doesMethod: aMethod useVar: aVariable
	(super doesMethod: aMethod useVar: aVariable) ifTrue: [ ^true ].

	^aMethod hasSelector: aVariable name asSymbol! !

!ClyClassReferencesQuery methodsFor: 'accessing' stamp: ''!
variableQuery: aClassQuery
	super variableQuery: (aClassQuery withResult: ClyClassBindingsResult new)! !

!ClyClassReferencesQuery class methodsFor: 'instance creation' stamp: ''!
to: aClass from: aScope

	^self of: aClass from: aScope! !

!ClyClassReferencesQuery class methodsFor: 'instance creation' stamp: ''!
to: aClass

	^self of: aClass! !

!ClyClassReferencesQuery class methodsFor: 'instance creation' stamp: ''!
toAny: classes from: aScope

	^self ofAny: classes from: aScope! !

!ClyClassReferencesQuery class methodsFor: 'instance creation' stamp: ''!
toAny: classes

	^self ofAny: classes! !

!ClyClassReferencesQueryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	environment system: ClySystemEnvironment currentImage.
	environment detachFromSystem.! !

!ClyClassReferencesQueryTest methodsFor: 'tests' stamp: ''!
testFromClassScope

	self queryFromScope: ClyBothMetaLevelClassScope of: self class.
	
	self assert: resultItems size equals: 3.	
	self assert: foundSelectors equals: #(classSideReference1OfClass reference1OfClass reference2OfClass)! !

!ClyClassReferencesQueryTest methodsFor: 'tests' stamp: ''!
testComparison
	self assert: (ClyClassReferencesQuery to: Point) equals: (ClyClassReferencesQuery to: Point).

	self assert: (ClyClassReferencesQuery to: Point) hash equals: (ClyClassReferencesQuery to: Point) hash.

	self deny: (ClyClassReferencesQuery to: Point) equals: (ClyClassReferencesQuery to: Rectangle)! !

!ClyClassReferencesQueryTest methodsFor: 'methods for tests' stamp: ''!
reference1OfClass

	^ClyClassReferencesQueryTest! !

!ClyClassReferencesQueryTest methodsFor: 'tests' stamp: ''!
testShouldFoundClassNameSymbolReference
	query variableQuery: (ClyConstantQuery returning: {Number}).
	self queryFromScope: ClyMethodScope of: self class >> #referenceOfNumberClassByNameSymbol.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: self class >> #referenceOfNumberClassByNameSymbol! !

!ClyClassReferencesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: (self class >> #reference1OfClass) in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (self class >> #referenceOfAnotherClass) in: environment).
	self assert: query checkEmptyResult! !

!ClyClassReferencesQueryTest methodsFor: 'tests' stamp: ''!
testDescriptionWhenSimpleClassBindingIsUsed

	query := ClyClassReferencesQuery to: Object binding.
	
	self assert: query description equals: 'references to Object'! !

!ClyClassReferencesQueryTest methodsFor: 'tests' stamp: ''!
testFromMethodScope
	self queryFromScope: ClyMethodScope ofAll: {(self class >> #reference1OfClass) . (self class >> #referenceOfAnotherClass)}.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: self class >> #reference1OfClass! !

!ClyClassReferencesQueryTest methodsFor: 'tests' stamp: ''!
testForMetaclass
	query := ClyClassReferencesQuery to: self referencedClass classSide.

	self queryFromScope: ClyMethodScope of: self class >> #reference1OfClass.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: self class >> #reference1OfClass! !

!ClyClassReferencesQueryTest methodsFor: 'tests' stamp: ''!
testFromSystemScope

	self queryFromScope: ClySystemEnvironmentScope of: ClySystemEnvironment currentImage.
	
	self assert: resultItems size equals: 3.	
	self assert: foundSelectors equals: #(classSideReference1OfClass reference1OfClass reference2OfClass)! !

!ClyClassReferencesQueryTest methodsFor: 'tests' stamp: ''!
testForGlobalVariable
	query variableQuery: (ClyConstantQuery returning: {(self class environment bindingOf: #Smalltalk)}).
	self queryFromScope: ClyMethodScope of: self class >> #referenceOfSmalltalk.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: self class >> #referenceOfSmalltalk! !

!ClyClassReferencesQueryTest methodsFor: 'methods for tests' stamp: ''!
reference2OfClass

	^ClyClassReferencesQueryTest! !

!ClyClassReferencesQueryTest methodsFor: 'tests' stamp: ''!
testFromPackageScope

	self queryFromScope: ClyPackageScope of: self class package.
	
	self assert: resultItems size equals: 3.	
	self assert: foundSelectors equals: #(classSideReference1OfClass reference1OfClass reference2OfClass)! !

!ClyClassReferencesQueryTest methodsFor: 'methods for tests' stamp: ''!
referenceOfNumberClassByNameSymbol

	^#Number! !

!ClyClassReferencesQueryTest methodsFor: 'running' stamp: ''!
referencedClass
	^self class! !

!ClyClassReferencesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyClassReferencesQuery
		to: self referencedClass
		from: (ClyClassScope of: Object in: environment)! !

!ClyClassReferencesQueryTest methodsFor: 'methods for tests' stamp: ''!
referenceOfAnotherClass

	^Point! !

!ClyClassReferencesQueryTest methodsFor: 'methods for tests' stamp: ''!
referenceOfSmalltalk

	^Smalltalk! !

!ClyClassReferencesQueryTest class methodsFor: 'methods for tests' stamp: ''!
classSideReference1OfClass

	^ClyClassReferencesQueryTest! !

!ClyClassScope commentStamp: ''!
I represent the local scope of classes which they define by themselves:

	ClyClassScope of: Array 
	
It represents instance side of Array.

	ClyClassScope of: Array class 
	
It represents class side of Array.

Also I provide natural hierarchy traversal of basis classes. 
It means that 

	ClySuperclassScope of: Array class localScope: ClyClassScope  

will see Class and Object because any metaclass is subclass of Class which by itself is subclass of Object.

It is ortogonal to behaviour of ClyMetaLevelClassScope subclasses which restrict hierarchical traversal to the relationships of instance side. For example 

	ClySuperclassScope of: Array class localScope: ClyClassSideScope	

will not see Class and Object. It will end up at Object class and ProtoObject class.

So I am the default local scope for hierarchy scopes which gives the natural look at classes without user metalevel restrictions!
!ClyClassScope methodsFor: 'converting' stamp: ''!
asRBEnvironment

	^ RBClassEnvironment classes: basisObjects! !

!ClyClassScope class methodsFor: 'meta level' stamp: ''!
metaLevelsOf: aClass do: aBlock
	"By default meta level of class is class itself"
	
	aBlock value: aClass! !

!ClyClassScope class methodsFor: 'meta level' stamp: ''!
metaLevelForHierarchyOf: aClass
	"I not restrict any hierarchy.
	It will be native hierarchy of given class"
	^aClass! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumeration
	scope := ClyClassScope ofAll: {ClyClass1FromP1Mock. ClyClass2FromP1Mock}.
	
	scope classesDo: [ :each | result add: each ].
	
	self assert: result asArray equals: {ClyClass1FromP1Mock. ClyClass2FromP1Mock}! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testVariablesEnumerationForObject
	scope := ClyClassScope of: Object.
	
	scope variablesDo: [ :each | result add: each ].
	
	self assert: result size equals: 1.
	self
		assert: result anyOne
		equals: (ClyClassVariable on: Object classVariables first definedIn: Object)! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testVariablesEnumerationWhenThereAreNoVariables
	scope := ClyClassScope of: ProtoObject.
	
	scope variablesDo: [ :each | result add: each ].
	
	self assert: result isEmpty! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testVariablesEnumerationForClassWithInstanceVariables
	scope := ClyClassScope of: ClyClass1FromP1Mock.
	
	scope variablesDo: [ :each | result add: each ].
	
	self assert: (result as: Set) equals: {
		ClyInstanceVariable named: #instanceSideVar2 definedIn: ClyClass1FromP1Mock.
		ClyInstanceVariable named: #instanceSideVar1 definedIn: ClyClass1FromP1Mock
	} asSet! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testInstVarsEnumerationWhenThereAreNoVariables
	scope := ClyClassScope of: Object.
	
	scope instanceVariablesDo: [ :each | result add: each ].
	
	self assert: result isEmpty! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testMethodGroupsEnumeration
	environment addPlugin: ClyDefaultSystemEnvironmentPlugin new.
	scope := ClyClassScope of: ClyClass1FromP1Mock in: environment.
	
	scope methodGroupsDo: [ :each | result add: each ].
	
	self
		assert: (result collect: #class as: Set)
		equals: {ClyAllMethodGroup. ClyTaggedMethodGroup} asSet.
	self
		assert: (result
				select: [ :each | each class = ClyTaggedMethodGroup ]
				thenCollect: #tag) sorted asArray
		equals: ClyClass1FromP1Mock tagsForMethods sorted asArray! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testClassVarsEnumeration
	scope := ClyClassScope ofAll: {Object. ClyClass1FromP1Mock}.	"last one has no class vars"
		
	scope classVariablesDo: [ :each | result add: each ].
	
	self assert: result size equals: 1.
	self
		assert: result anyOne
		equals: (ClyClassVariable on: Object classVariables first definedIn: Object)! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testVariablesEnumerationForTwoClassesWithClassAndInstanceVars
	scope := ClyClassScope ofAll: {Object. ClyClass1FromP1Mock}.
	
	scope variablesDo: [ :each | result add: each ].
	
	self assert: (result as: Set) equals: {
		ClyClassVariable named: #DependentsFields definedIn: Object.
		ClyInstanceVariable named: #instanceSideVar2 definedIn: ClyClass1FromP1Mock.
		ClyInstanceVariable named: #instanceSideVar1 definedIn: ClyClass1FromP1Mock
	} asSet! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testClassVarsEnumerationWhenTheyNotExist
	scope := ClyClassScope of: ClyClass1FromP1Mock.
	
	scope classVariablesDo: [ :each | result add: each ].
	
	self assert: result isEmpty! !

!ClyClassScopeTest methodsFor: 'running' stamp: ''!
scopeClass	
	^ClyClassScope! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumeration

	| expected |
	scope := ClyClassScope of: ClyClass1FromP1Mock.
	scope methodsDo: [ :each | result add: each selector ].
	expected := ClyClass1FromP1Mock localMethods collect: [:each | each selector].
	self assert: result sorted asArray equals: expected sorted asArray! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testClassVarsEnumerationFromClassSideOfDefiningClass
	scope := ClyClassScope of: Object class.
	
	scope classVariablesDo: [ :each | result add: each ].
	
	self assert: result size equals: 1.
	self
		assert: result anyOne
		equals: (ClyClassVariable on: Object classVariables first definedIn: Object)! !

!ClyClassScopeTest methodsFor: 'tests' stamp: ''!
testInstVarsEnumeration
	scope := ClyClassScope of: ClyClass1FromP1Mock.

	scope instanceVariablesDo: [ :each | result add: each ].

	self assert: (result as: Set) equals: {
		ClyInstanceVariable named: #instanceSideVar2 definedIn: ClyClass1FromP1Mock.
		ClyInstanceVariable named: #instanceSideVar1 definedIn: ClyClass1FromP1Mock
	} asSet! !

!ClyClassScript commentStamp: ''!
I am abstract class which represents kind of script which can be extracted and executed from class methods.
My subclasses define what methods are representing them. They should implement class side method #isImplementedByMethod:.

For example methods with pragma <sampleInstance> are represented by ClySampeInstanceScript

	ClySampeInstanceScript class >> isImplementedByMethod: aMethod
		^ aMethod hasPragmaNamed: #sampleInstance

In addition I define what kind of methods are able to provide scripts in general. By default it is always class side methods without arguments:

	ClyClassScript class >> canBeProvidedByMethod: aMethod
		^ aMethod origin isClassSide and: [ aMethod numArgs = 0 ]

If subclass define logic for instance side methods or for method arguments it should override method #canBeProvidedByMethod: in addition.
	
To create my instances use following method: 

	ClyClassScript createFrom: aMethod
 
To run the script send execute message: 

	aScript executeBy: aClass 
	
The argument can be different then the class which defines the method. Because the script can be run by subclasses.

I provide description methods for the UI. Some subclasses override them: 

- description 
- iconName 

Internal Representation and Key Implementation Points.

    Instance Variables
	implementorMethod:		<CompiledMethod>!
!ClyClassScript methodsFor: 'accessing' stamp: ''!
implementorClass
	^ implementorMethod origin! !

!ClyClassScript methodsFor: 'accessing' stamp: ''!
implementorMethod: anObject
	implementorMethod := anObject! !

!ClyClassScript methodsFor: 'accessing' stamp: ''!
iconName
	^ #scriptManagerIcon! !

!ClyClassScript methodsFor: 'accessing' stamp: ''!
description
	^ 'Run the script'! !

!ClyClassScript methodsFor: 'execution' stamp: ''!
executeOn: aClass
	"Execute the corresponding method of the argument."
	
	^ aClass instanceSide perform: implementorMethod selector! !

!ClyClassScript methodsFor: 'accessing' stamp: ''!
implementorMethod
	^ implementorMethod! !

!ClyClassScript methodsFor: 'testing' stamp: ''!
isImplementedByClass: aClass
	
	^ aClass instanceSide respondsTo: self implementorSelector! !

!ClyClassScript methodsFor: 'accessing' stamp: ''!
implementorSelector
	^ implementorMethod selector! !

!ClyClassScript class methodsFor: 'instance creation' stamp: ''!
createFrom: aMethod
	^self new 
		implementorMethod: aMethod! !

!ClyClassScript class methodsFor: 'script detection' stamp: ''!
canBeProvidedByMethod: aMethod
	"This method just checks that method in general can be used for this kind of script"

	^ aMethod origin isClassSide and: [ aMethod numArgs = 0 ]! !

!ClyClassScript class methodsFor: 'script detection' stamp: ''!
isImplementedByMethod: aMethod
	"Subclasses should override it.
	The method is not abstract to not corrupt browser if new script is not completelly implemented"
	
	^ false! !

!ClyClassScript class methodsFor: 'script detection' stamp: ''!
detectInMethod: aMethod ifAbsent: absentBlock
	

	self allSubclassesDo: [ :each | 
		((each canBeProvidedByMethod: aMethod)
			and: [each isImplementedByMethod: aMethod]) 
				ifTrue: [ ^ each createFrom: aMethod ]].
	^ absentBlock value! !

!ClyClassScriptEnvironmentPlugin commentStamp: ''!
I am special plugin which decorates scripting class side methods.
I use hierarchy of ClyClassScript to detect that given method provides a script!
!ClyClassScriptEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod

	| script |
	script := ClyClassScript detectInMethod: aMethod ifAbsent: [ ^ self ].
	anItem addProperty: (ClyClassScriptProperty script: script)! !

!ClyClassScriptProperty commentStamp: ''!
I am used to extend method items with information about script which they represent.

To create my instances use following method: 

	ClyClassScriptProperty script: aScript

Internal Representation and Key Implementation Points.

    Instance Variables
	script:		<ClyClassScript>!
!ClyClassScriptProperty methodsFor: 'accessing' stamp: ''!
script
	^ script! !

!ClyClassScriptProperty methodsFor: 'accessing' stamp: ''!
script: anObject
	script := anObject! !

!ClyClassScriptProperty class methodsFor: 'instance creation' stamp: ''!
script: aClassScript
	^self new 
		script: aClassScript! !

!ClyClassSideBoldTableDecorator commentStamp: ''!
I decorate table with bold font for method groups and methods when full browser shows the class side!
!ClyClassSideBoldTableDecorator class methodsFor: 'decoration' stamp: ''!
variableDecorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyFullBrowserVariableContext! !

!ClyClassSideBoldTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem

	anItemCellMorph label clyAddEmphasis: TextEmphasis bold! !

!ClyClassSideBoldTableDecorator class methodsFor: 'decoration' stamp: ''!
methodDecorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyFullBrowserMethodContext! !

!ClyClassSideBoldTableDecorator class methodsFor: 'decoration' stamp: ''!
methodGroupDecorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyFullBrowserMethodGroupContext! !

!ClyClassSideBoldTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem

	^aDataSourceItem browser metaLevelScope = ClyClassSideScope! !

!ClyClassSideLinkTableDecorator commentStamp: ''!
I decorate tables in the full browser with special icon for methods and protocol which are named like "see class side".
The icon switches the browser to the class side!
!ClyClassSideLinkTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyClassSideLinkTableDecorator class methodsFor: 'decoration' stamp: ''!
methodDecorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyFullBrowserMethodContext! !

!ClyClassSideLinkTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph inContext: itemContext
	| command activator icon button |
	super decorateMainTableCell: anItemCellMorph inContext: itemContext.
	
	command := ClySwitchToClassSideCommand new.
	itemContext prepareNewCommand: command.
	activator := CmdCommandActivator new 
			command: command; 
			context: itemContext.
	icon := anItemCellMorph iconNamed: #forward.
	button := command createTableCellButtonWith: icon using: activator.
	button setBalloonText: 'Switch to the class side'.
	anItemCellMorph definitionMorph: button! !

!ClyClassSideLinkTableDecorator class methodsFor: 'decoration' stamp: ''!
methodGroupDecorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyTaggedMethodGroup asCalypsoItemContext! !

!ClyClassSideLinkTableDecorator class methodsFor: 'decoration' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	
	| tagName |
	tagName := aDataSourceItem name asLowercase.	
	^#('see class side' 'seeclassside') 
		anySatisfy: [ :each | tagName beginsWith: each ]! !

!ClyClassSideLinkTableDecorator class methodsFor: 'decoration' stamp: ''!
priority
	^100000! !

!ClyClassSideScope commentStamp: ''!
I represent class side of classes!
!ClyClassSideScope methodsFor: 'queries' stamp: ''!
methodsDo: aBlock

	self classesDo: [ :eachClass | 
		self metaLevelsOf: eachClass do: [ :concreteMetaLevelClass |
			concreteMetaLevelClass visibleMethods do: aBlock ] ]! !

!ClyClassSideScope class methodsFor: 'class selection' stamp: ''!
metaLevelOf: aClass
	^aClass classSide! !

!ClyClassSideScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'class side'! !

!ClyClassSideScopeTest methodsFor: 'running' stamp: ''!
extraBasisSample 	
	^super extraBasisSample classSide! !

!ClyClassSideScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumeration
	scope := ClyClassSideScope ofAll: {ClyClass1FromP1Mock classSide. ClyClass2FromP1Mock}.
	
	scope classesDo: [ :each | result add: each ].
	
	self
		assertCollection: result asArray
		hasSameElements: {ClyClass1FromP1Mock classSide. ClyClass2FromP1Mock classSide}! !

!ClyClassSideScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBasisIsClass

	| expected |
	scope := ClyClassSideScope of: ClyClass1FromP1Mock.
	scope methodsDo: [ :each | result add: each selector ].
	expected := ClyClass1FromP1Mock classSide localMethods collect: [:each | each selector].
	self assertCollection: result sorted asArray equals: expected sorted! !

!ClyClassSideScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBasisIsTraitedClassClassSide
	| expected |
	scope := ClyClassSideScope of: ClyClassWithTraits classSide.
	
	scope methodsDo: [ :each | result add: each selector ].
	
	expected := ClyClassWithTraits class methods reject: [ :e | e origin = TraitedClass ] thenCollect: #selector.
	self assert: result sorted asArray equals: expected sorted asArray! !

!ClyClassSideScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBasisIsTraitedClass
	| expected |
	scope := ClyClassSideScope of: ClyClassWithTraits.
	
	scope methodsDo: [ :each | result add: each selector ].
	
	expected := ClyClassWithTraits class methods reject: [ :e | e origin = TraitedClass ] thenCollect: #selector.
	self assert: result sorted asArray equals: expected sorted asArray! !

!ClyClassSideScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBasisIsMetaclass

	| expected |
	scope := ClyClassSideScope of: ClyClass1FromP1Mock classSide.	
	scope methodsDo: [ :each | result add: each selector ].
	expected := ClyClass1FromP1Mock classSide localMethods collect: [:each | each selector].
	self assert: result sorted asArray equals: expected sorted asArray! !

!ClyClassSideScopeTest methodsFor: 'running' stamp: ''!
scopeClass

	^ClyClassSideScope! !

!ClyClassSideScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToIncreasedScopeByExtraClassScope
	| convertedScope extraClassScope |
	scope := self singleScopeSample.
	
	extraClassScope := ClySuperclassScope of: self class localScope: self scopeClass.
	convertedScope := scope increasedByClassesFrom: extraClassScope.
	
	self assert: convertedScope class equals: scope class.
	self assert: convertedScope basisObjects equals: scope basisObjects, extraClassScope collectAllClasses.! !

!ClyClassSideScopeTest methodsFor: 'running' stamp: ''!
singleBasisSample 	
	^super singleBasisSample classSide! !

!ClyClassTableDecorator commentStamp: ''!
I am a base class for class table decorators.

I am annotated by decoration strategy in context of selected class.
So my subclasses should just implement decoration logic!
!ClyClassTableDecorator class methodsFor: 'decoration' stamp: ''!
decorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyClass asCalypsoItemContext! !

!ClyClassTableDecorator class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyClassTableDecorator! !

!ClyClassVariable commentStamp: ''!
I represent Class variable of class.
I am like ClassVariable but I include explicit information about defining class.

You can create my instance using:
	ClyClassVariable named: #DependentsFields definedIn: Object.
	ClyClassVariable on: aClassVariable definedIn: aClass
 !
!ClyClassVariable methodsFor: 'operations' stamp: ''!
openInspector

	actualVariable value inspect! !

!ClyClassVariable methodsFor: 'testing' stamp: ''!
isClassVariable
	^true! !

!ClyClassVariable methodsFor: 'accessing' stamp: ''!
detectDefiningClassFrom: anUserClass ifAbsent: aBlock

	(anUserClass instanceSide classVariables includes: actualVariable) ifTrue: [ 
		definingClass := anUserClass instanceSide.
		^self].
	
	anUserClass instanceSide sharedPools do: [ :each |
		self detectDefiningClassFrom: each ifAbsent: [].
		definingClass ifNotNil: [ ^self ] ].
	
	anUserClass isRootInEnvironment ifTrue: [ ^aBlock value ].
	
	self detectDefiningClassFrom: anUserClass superclass ifAbsent: aBlock! !

!ClyClassVariable methodsFor: 'accessing' stamp: ''!
detectDefiningClassFrom: anUserClass

	self detectDefiningClassFrom: anUserClass ifAbsent: [ 
		self error: 'Cant find the class defining variable' ]! !

!ClyClassVariable methodsFor: 'testing' stamp: ''!
isLive

	^true! !

!ClyClassVariable methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
createRefactoring: variableRefactoringClass for: aClass
	^variableRefactoringClass classVariableAnalog
			variable: actualVariable name
			class: aClass! !

!ClyClassVariable methodsFor: 'testing' stamp: ''!
isAccessibleFrom: aClass

	(aClass instanceSide withAllSuperclasses anySatisfy: [ :c | 
		 c includesSharedPoolNamed: definingClass name ]) ifTrue: [ ^ true ].

	^ aClass instanceSide = definingClass or: [ 
		  aClass instanceSide inheritsFrom: definingClass ]! !

!ClyClassVariable class methodsFor: 'queries' stamp: ''!
queryClass
	^ClyAllClassVariablesQuery! !

!ClyClassVariable class methodsFor: 'instance creation' stamp: ''!
named: aSymbol definedIn: aClass
	^self 
		on: (aClass classVariableNamed: aSymbol)
		definedIn: aClass! !

!ClyClassVariableTest methodsFor: 'tests' stamp: ''!
testDetectingDefiningClassFromSharedPoolUserClassSide

	| varBinding var |
	varBinding := ChronologyConstants classVariableNamed: #DayNames.
	
	var := ClyClassVariable on: varBinding visibleFrom: Date class.
		
	self assert: var definingClass equals: ChronologyConstants! !

!ClyClassVariableTest methodsFor: 'tests' stamp: ''!
testDetectingDefiningClassFromSubclassClassSide

	| varBinding var |
	varBinding := ClyClass2FromP1Mock classVariableNamed: #ClassVar1.
	
	var := ClyClassVariable on: varBinding visibleFrom: ClySubclassLOfClass2FromP1Mock class.
		
	self assert: var definingClass equals: ClyClass2FromP1Mock! !

!ClyClassVariableTest methodsFor: 'tests' stamp: ''!
testDetectingDefiningClassFromSharedPoolUser

	| varBinding var |
	varBinding := ChronologyConstants classVariableNamed: #DayNames.
	
	var := ClyClassVariable on: varBinding visibleFrom: Date.
		
	self assert: var definingClass equals: ChronologyConstants! !

!ClyClassVariableTest methodsFor: 'tests' stamp: ''!
testDetectingDefiningClassFromSubclass

	| varBinding var |
	varBinding := ClyClass2FromP1Mock classVariableNamed: #ClassVar1.
	
	var := ClyClassVariable on: varBinding visibleFrom: ClySubclassLOfClass2FromP1Mock.
		
	self assert: var definingClass equals: ClyClass2FromP1Mock! !

!ClyClassVariableTest methodsFor: 'tests' stamp: ''!
testDetectingDefiningClassFromItself

	| varBinding var |
	varBinding := ClyClass2FromP1Mock classVariableNamed: #ClassVar1.
	
	var := ClyClassVariable on: varBinding visibleFrom: ClyClass2FromP1Mock.
		
	self assert: var definingClass equals: ClyClass2FromP1Mock! !

!ClyClassVariableTest methodsFor: 'tests' stamp: ''!
testDetectingDefiningClassFromClassSide

	| varBinding var |
	varBinding := ClyClass2FromP1Mock classVariableNamed: #ClassVar1.
	
	var := ClyClassVariable on: varBinding visibleFrom: ClyClass2FromP1Mock class.
		
	self assert: var definingClass equals: ClyClass2FromP1Mock! !

!ClyClassWhichInheritsAbstractClassMock commentStamp: ''!
I am example of class which inherits from abstract superclass!
!ClyClassWhichInheritsAbstractClassMock methodsFor: 'protocol' stamp: ''!
abstractMethod1
	^#result! !

!ClyClassWhichInheritsAbstractClassMock methodsFor: 'protocol' stamp: ''!
overriddenMethod
	^#newValue! !

!ClyClassWhichInheritsAbstractClassMock methodsFor: 'protocol' stamp: ''!
notOverriddenMethod! !

!ClyClassWhichInheritsAbstractSubclassMock commentStamp: ''!
I am example of class which inherits from abstract superclass!
!ClyClassWithBreakpointsMock commentStamp: ''!
I am example class which has methods with breakpoints!
!ClyClassWithBreakpointsMock methodsFor: 'methods' stamp: ''!
methodWithoutBreakpoints2! !

!ClyClassWithBreakpointsMock methodsFor: 'methods' stamp: ''!
methodWithBreakpoints
	self printString! !

!ClyClassWithBreakpointsMock methodsFor: 'methods' stamp: ''!
methodWithoutBreakpoints! !

!ClyClassWithDeprecatedMethods commentStamp: ''!
I am example class which deprecated methods!
!ClyClassWithDeprecatedMethods methodsFor: 'protocol - deprecated' stamp: ''!
deprecatedMethod1
	self deprecated: 'it is deprecated method for testing deprecation analyzis'! !

!ClyClassWithDeprecatedMethods methodsFor: 'protocol - deprecated' stamp: ''!
deprecatedMethod2
	self deprecated: 'it is deprecated method for testing deprecation analyzis'! !

!ClyClassWithDeprecatedMethods methodsFor: 'protocol' stamp: ''!
notDeprecatedMethod! !

!ClyClassWithFFIMethods commentStamp: ''!
I am example class which has ffi methods!
!ClyClassWithFFIMethods methodsFor: 'ffi methods' stamp: ''!
ffiMethod

	^ self ffiCall: #(int system #(char * command))! !

!ClyClassWithFFIMethods methodsFor: 'not ffi methods' stamp: ''!
notFFIMethod! !

!ClyClassWithFlags commentStamp: ''!
I am example class which has methods with flag!
!ClyClassWithFlags methodsFor: 'methods with flags' stamp: ''!
methodWithoutFlag! !

!ClyClassWithFlags methodsFor: 'methods with flags' stamp: ''!
methodWithFlag

	self flag: #todo! !

!ClyClassWithHaltsMock commentStamp: ''!
I am example class which has methods with halts!
!ClyClassWithHaltsMock methodsFor: 'methods' stamp: ''!
methodWithoutHalts

	self printString! !

!ClyClassWithProblemMethods commentStamp: ''!
I am an example class which methods have example critiques!
!ClyClassWithProblemMethods methodsFor: 'method examples' stamp: ''!
methodWithHalt2
	<haltOrBreakpointForTesting>
	self halt.! !

!ClyClassWithProblemMethods methodsFor: 'method examples' stamp: ''!
methodWithHalt
	<haltOrBreakpointForTesting>
	self halt.
	self methodWithHalt2.! !

!ClyClassWithProblemMethods methodsFor: 'method examples' stamp: ''!
methodWithoutCritiques
	"this is example method which should not have critiques"
	^self printString! !

!ClyClassWithScripts commentStamp: ''!
I am example class which includes all kind of scripts.
Look at the class side!
!ClyClassWithScripts methodsFor: 'methods with script' stamp: ''!
instSideMethodWithScriptWithArgument
	<script: 'self inform: ''It is example inst side method with script with argument from '', self name'>! !

!ClyClassWithScripts class methodsFor: 'class initialization' stamp: ''!
initialize
	self inform: 'it is class initialization example from ', self name! !

!ClyClassWithScripts class methodsFor: 'methods with samples' stamp: ''!
methodWithSample
	<sampleInstance>
	
	^'it is string sample instance from ', self name! !

!ClyClassWithScripts class methodsFor: 'methods with scripts' stamp: ''!
methodWithScriptWithArgument
	<script: 'self inform: ''It is example method with script with argument from '', self name'>! !

!ClyClassWithScripts class methodsFor: 'methods with examples' stamp: ''!
methodWithExample
	<example>
	self inform: 'it is example string from ', self name.
	
	^'it is example string'! !

!ClyClassWithScripts class methodsFor: 'methods with scripts' stamp: ''!
methodWithScript
	<script>
	self inform: 'It is example method with script from ', self name! !

!ClyClassWithTraits methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait' stamp: ''!
extensionMethodFromRoot1Trait! !

!ClyClassWithTraits methodsFor: 'tag' stamp: ''!
localMethod! !

!ClyClassWithTraits methodsFor: 'accessing' stamp: ''!
methodFromTraitChild2! !

!ClyClassWithTraits methodsFor: 'tag' stamp: ''!
methodFromTraitChild1! !

!ClyClassWithTraits methodsFor: 'accessing' stamp: ''!
methodFromRoot1! !

!ClyClassWithTraits class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ClyClassWithTraits class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ClyClassWithTraits class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ClyClassWithTraits class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ClyClassWithTraits class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ClyClassWithTraits class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ClyClassWithTraits class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ClyClassWithTraits class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ClyClassWithTraits class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyClassWithTraits class methodsFor: 'accessing' stamp: ''!
classSideMethodFromRoot1! !

!ClyClassWithTraits class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ClyClassWithTraits class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ClyClassWithTraits class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ClyClassWithTraits class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ClyClassWithTraits class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ClyClassWithTraits class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ClyClassWithTraits class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ClyClassWithTraits class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ClyClassWithTraits class methodsFor: 'protocol' stamp: ''!
localClassSideMethod! !

!ClyClassWithTraits class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyClassWithTraits class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ClyClassWithTraits class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ClyClassWithTraits class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ClyClassWithTraits class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ClyClassWithTraits class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ClyClassWithTraits class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ClyClassWithTraits class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ClyClassWithTraits class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ClyClassWithTraits class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ClyClassWithTraits class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ClyClassWithTraits class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ClyClassWithUndeclares commentStamp: ''!
I am example class with methods which use undeclared variables!
!ClyClassWithUndeclares methodsFor: 'with undeclares' stamp: ''!
method2WithUndeclares
	undeclaredStubInstVar2 := 100! !

!ClyClassWithUndeclares methodsFor: 'with undeclares' stamp: ''!
method1WithUndeclares
	^undeclaredStubInstVar1 printString! !

!ClyClassWithUndeclares class methodsFor: 'without undeclares' stamp: ''!
withFloatReturn
	^10.2! !

!ClyClassWithoutBreakpoints commentStamp: ''!
I am example class which methods have no halts or breakpoints!
!ClyClassWithoutBreakpoints methodsFor: 'accessing' stamp: ''!
method1! !

!ClyClassWithoutBreakpoints methodsFor: 'accessing' stamp: ''!
method2! !

!ClyClassWithoutDeprecatedMethods commentStamp: ''!
I am example class without deprecated methods!
!ClyClassWithoutDeprecatedMethods methodsFor: 'protocol' stamp: ''!
someNotDeprecatedMethod! !

!ClyCloseBrowserCommand commentStamp: ''!
I am a command to close browser window. 

There are already system shortcuts like `$w` command to close current window. But some morphs like tab manager are implementing it differently.
In a browser the desired behaviour is to close the full window instead of single tab. 
I override it by shortcut activator for source code context. 
When you edit code and press `$w` command" I will close browser window. 
Also it fixes the case for method browser managed by tabs group window. 
Before `$w` command, it keeps an empty tab without closing it.!
!ClyCloseBrowserCommand methodsFor: 'execution' stamp: ''!
execute
	browser close! !

!ClyCloseBrowserCommand class methodsFor: 'activation' stamp: ''!
textToolShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $w meta for: ClyTextEditorContext! !

!ClyCloseBrowserCommand class methodsFor: 'activation' stamp: ''!
browserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $w meta for: ClyBrowserContext! !

!ClyClosedBrowserCursor commentStamp: ''!
I represent closed query cursor.
I am used by data source to represent closed state.

My singleton instance is supposed to be used:

	ClyClosedBrowserCursor instance!
!ClyClosedBrowserCursor methodsFor: 'accessing' stamp: ''!
itemCount
	^0! !

!ClyClosedBrowserCursor methodsFor: 'testing' stamp: ''!
hasMetaProperty: aPropertyClass 
	^false! !

!ClyClosedBrowserCursor methodsFor: 'controlling' stamp: ''!
updateItemCache! !

!ClyClosedBrowserCursor methodsFor: 'controlling' stamp: ''!
close! !

!ClyClosedBrowserCursor methodsFor: 'queries' stamp: ''!
findItemsWith: aCollection 
	^Array new: aCollection size withAll: nil! !

!ClyClosedBrowserCursor class methodsFor: 'accessing' stamp: ''!
instance
	^instance ifNil: [ instance := self new ]! !

!ClyCollapsedDataSource commentStamp: ''!
I am table data source which items are all initially collapsed.
I maintain list of expanded items and compute items position according to it (row indexes in full table).
 
Internal Representation and Key Implementation Points.

    Instance Variables
	expandedItems:		<SortedCollection of: ClyDataSourceItem>	sorted by item position!
!ClyCollapsedDataSource methodsFor: 'accessing' stamp: ''!
globalPositionOf: childDataSourceItem

	| result |
	result := parentItem ifNil: [ 0 ] ifNotNil: [ parentItem globalPosition ].
	expandedItems do: [ :each | 
		(each isAfter: childDataSourceItem position) ifTrue: [
			^result + childDataSourceItem position].
		result := result + each childrenCount].
	
	^result + childDataSourceItem position! !

!ClyCollapsedDataSource methodsFor: 'accessing' stamp: ''!
countChildrenOf: aDataSourceItem
	aDataSourceItem childrenDataSource ifNotNil: [:children | ^children numberOfRows].
	
	self definesChildren ifFalse: [ ^0 ].

	self error: 'should not happen'! !

!ClyCollapsedDataSource methodsFor: 'accessing' stamp: ''!
findDataSourceSameAs: aDataSource ifNone: noneBlock
	| found |
	(self isSameAs: aDataSource) ifTrue: [ ^self ].
	
	expandedItems do: [ :each | 
		found := each childrenDataSource findDataSourceSameAs: aDataSource ifNone: [nil].
		found ifNotNil: [ ^found ]].
		
	^noneBlock value! !

!ClyCollapsedDataSource methodsFor: 'accessing' stamp: ''!
elementAt: rowIndex
	| localIndex |
	localIndex := rowIndex.	

	expandedItems do: [:each | 
		each position = localIndex ifTrue: [ ^each ].
		(each hasChildAt: localIndex) ifTrue: [
			^each childrenItemAt: localIndex].
		(each isAfter: localIndex) ifTrue: [
			self itemCursor moveTo: localIndex.
			^ ClyDataSourceItem of: self value: self itemCursor currentItem ].
		localIndex := localIndex - each childrenCount.
	].

	self itemCursor moveTo: localIndex.
	^ClyDataSourceItem of: self value: self itemCursor currentItem! !

!ClyCollapsedDataSource methodsFor: 'queries' stamp: ''!
findItemsWhere: conditionBlock

	| myItems childItems |
	myItems := super findItemsWhere: conditionBlock.
	
	childItems := expandedItems flatCollect: [ :each | 
		each  childrenDataSource findItemsWhere: conditionBlock].
	
	^myItems, childItems! !

!ClyCollapsedDataSource methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
		
	expandedItems := SortedCollection sortBlock: [ :a :b | a position < b position ]! !

!ClyCollapsedDataSource methodsFor: 'controlling' stamp: ''!
forceFullUpdate
	super forceFullUpdate.
	expandedItems do: [ :each | each childrenDataSource forceFullUpdate]! !

!ClyCollapsedDataSource methodsFor: 'testing' stamp: ''!
isExpanded: aDataSourceItem

	^expandedItems includes: aDataSourceItem! !

!ClyCollapsedDataSource methodsFor: 'accessing' stamp: ''!
expandedItems: items
	expandedItems := items! !

!ClyCollapsedDataSource methodsFor: 'queries' stamp: ''!
findItemsSimilarTo: dataSourceItems

	| myItems childItems |
	myItems := super findItemsSimilarTo: dataSourceItems.
	myItems size == dataSourceItems size ifTrue: [ ^myItems ].
	
	childItems := expandedItems flatCollect: [ :each | 
		each childrenDataSource findItemsSimilarTo: dataSourceItems].
	
	^myItems, childItems! !

!ClyCollapsedDataSource methodsFor: 'controlling' stamp: ''!
openOn: aQueryView
	super openOn: aQueryView.

	expandedItems do: [:each | each childrenDataSource openOn: aQueryView]! !

!ClyCollapsedDataSource methodsFor: 'controlling' stamp: ''!
retrieveChildrenOf: aDataSourceItem
	| childQuery childDataSource |
	childQuery := queryView 
		queryToExpand: aDataSourceItem 
		ifAbsent: [self error: 'cant retrieve children from ', aDataSourceItem printString].
	
	childDataSource := ClyCollapsedDataSource on: childQuery.
	childDataSource openOn: queryView.
	^childDataSource! !

!ClyCollapsedDataSource methodsFor: 'private' stamp: ''!
findCachedElementWith: anEnvironmentItem ifAbsent: absentBlock

	^expandedItems 
		detect: [ :each | each actualObject == anEnvironmentItem actualObject ]
		ifNone: absentBlock! !

!ClyCollapsedDataSource methodsFor: 'accessing' stamp: ''!
numberOfRows
	^self itemCursor itemCount 
		+ (expandedItems sum: [ :each | each childrenCount ])! !

!ClyCollapsedDataSource methodsFor: 'private' stamp: ''!
updateExpandingItems
	self updateItems: expandedItems.
	expandedItems := expandedItems reject: [ :each | each isRemoved ]! !

!ClyCollapsedDataSource methodsFor: 'controlling' stamp: ''!
close
	super close.
	
	expandedItems do: [ :each | each childrenDataSource close  ]! !

!ClyCollapsedDataSource methodsFor: 'controlling' stamp: ''!
expand: aDataSourceItem
	queryView changeStateBy: [
		aDataSourceItem expandChildren.
	
		expandedItems add: aDataSourceItem.

		self expansionChanged]! !

!ClyCollapsedDataSource methodsFor: 'testing' stamp: ''!
isInSameStateAs: anotherDataSource

	(super isInSameStateAs: anotherDataSource) ifFalse: [ ^false ].
	
	expandedItems size = anotherDataSource expandedItems size ifFalse: [ ^false ].
	^expandedItems allSatisfy: [ :myItem | 
		anotherDataSource expandedItems 
			detect: [ :anotherItem | myItem isSameAs: anotherItem ]
			ifFound: [ :anotherItem | 
				myItem childrenDataSource isInSameStateAs: anotherItem childrenDataSource ]
			ifNone: [ false ] ]! !

!ClyCollapsedDataSource methodsFor: 'accessing' stamp: ''!
expandedItems
	^expandedItems! !

!ClyCollapsedDataSource methodsFor: 'queries' stamp: ''!
findItemsWith: actualObjects

	| myItems childItems |
	myItems := super findItemsWith: actualObjects.
	myItems size == actualObjects size ifTrue: [ ^myItems ].
	
	childItems := expandedItems flatCollect: [ :each | 
		each childrenDataSource findItemsWith: actualObjects].
	
	^myItems, childItems! !

!ClyCollapsedDataSource methodsFor: 'testing' stamp: ''!
doesItemHaveChildren: aDataSourceItem
	| childQuery |
	aDataSourceItem childrenDataSource ifNotNil: [:children | ^children isEmpty not].
	
	self definesChildren ifFalse: [ ^false ].

	childQuery := queryView queryToExpand: aDataSourceItem ifAbsent: [^false].
	
	^aDataSourceItem browserItem hasChildrenWhich: [:childType | 
		childQuery retrievesItemsOfType: childType ]! !

!ClyCollapsedDataSource methodsFor: 'copying' stamp: ''!
initializeForBrowserStateSpanshot
	| copy |
	super initializeForBrowserStateSpanshot.
	copy := expandedItems collect: [ :each | 
		each copyForBrowserStateSnapshotOf: self ].
	expandedItems := copy asSortedCollection: [ :a :b | a position < b position ]! !

!ClyCollapsedDataSource methodsFor: 'controlling' stamp: ''!
collapse: aDataSourceItem
	queryView changeStateBy: [ 
		expandedItems remove: aDataSourceItem.
		aDataSourceItem childrenDataSource close.	

		self expansionChanged]! !

!ClyCollapsedDataSource methodsFor: 'testing' stamp: ''!
definesChildren
	^queryView definesTree! !

!ClyCommandBasedTableDecorator commentStamp: ''!
I delegate decoration of table to all commands annotated by ClyTableIconCommandActivation.
I allow extend table cell with command based iconic buttons. 
Any command class which is annotated with ClyTableIconCommandActivation will be represented by clickable icon in main table cell!
!ClyCommandBasedTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyCommandBasedTableDecorator class methodsFor: 'decoration' stamp: ''!
decorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyBrowserContext! !

!ClyCommandBasedTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph inContext: itemContext

	ClyTableIconCommandActivation 
		activateAllInContext: itemContext 
		by: [:commandActivator | 
			commandActivator decorateTableCell: anItemCellMorph ]! !

!ClyCommandBasedTableDecorator class methodsFor: 'decoration' stamp: ''!
priority
	"command based decoration should be in most priority then anything else"
	^1000! !

!ClyCommitMCPackageCommand commentStamp: ''!
I am a command to commit given packages.

I use Iceberg if it is repository of package. 
Otherwise I use Komitter.!
!ClyCommitMCPackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Commit'! !

!ClyCommitMCPackageCommand methodsFor: 'execution' stamp: ''!
execute
	| repoBrowser commitBrowser repos targetRepo |
	repoBrowser := self class environment at: #IceTipRepositoriesBrowser ifAbsent: [ ^ self inform: 'Iceberg 0.7 and higher is required' ].
	commitBrowser := self class environment at: #IceTipCommitBrowser ifAbsent: [ ^ self inform: 'Iceberg 0.7 and higher is required' ].
	packages ifEmpty: [ ^ repoBrowser new openWithSpec ].
	repos := IceRepository registry select: [ :repo | packages anySatisfy: [ :each | repo includesPackageNamed: each name ] ].
	repos ifEmpty: [ ^ self inform: 'Selected packages are not managed by Iceberg' ].
	targetRepo := repos size = 1 ifTrue: [ repos first ] ifFalse: [ UIManager default chooseFrom: (repos collect: [:each | each name]) values: repos title: 'Choose repository' ].
	targetRepo ifNil: [ ^ self ].
	(targetRepo isMissing or: [ 
		targetRepo isCodeMissing or: [ 
			targetRepo workingCopy isDetached or: [ 
				targetRepo head isDetached or: [ 
					targetRepo workingCopy project isUnborn ] ] ] ])
		ifTrue: [ UIManager default
				alert:
					'The ' , targetRepo name
						,
							' repository is not operational to commit.
Causes can be:
- The local repository is missing
- The code directory is missing
- The project is in detached head state
- Metadatas are missing.

You can fix this problem using the Iceberg tool.'
				title: 'Error'.
			^ self ].
	(commitBrowser onRepository: targetRepo) openWithSpec! !

!ClyCommitMCPackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#monticelloPackage! !

!ClyCommitMCPackageCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 10000 for: ClyFullBrowserPackageContext! !

!ClyCommitMCPackageCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	"if no packages are selected then command will commit all changes in image"
	^true! !

!ClyCommitMCPackageCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $s meta for: ClyFullBrowserGlobalContext! !

!ClyCompositeQuery commentStamp: ''!
I represent composition of queries. 
I am abstract class and my subclasses implement concrete logic what to do with subqueries.
They should only implement three methods: 

- buildResult: aQueryResult 
Subclasses should deside what to do with result of subqueries.

- #unionWith: typedQueries as: aQueryResult
Subclasses should implement how union itself with given query collection.

- #, anotherQuery 
Subclasses should implement union with another query.

Other methods from the superclass I implement using delegation to my subqueries.

My instances can be created using #with: message: 

	ClyCompositeQuery with: { aQuery1. aQuery2 }
	ClyCompositeQuery with: { aQuery1. aQuery2 } as: aQueryResult
	
My scope is composition of scopes from all my subqueries. In general it is ClyCompositeScope instance. But in case of similar subscopes it can be single typed scope.

I redefine #description to print subqueries splitted by comma by default.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	subqueries:		<Set of: <ClyQuery>>!
!ClyCompositeQuery methodsFor: 'converting' stamp: ''!
withSubqueries: newSubqueries

	^self class with: newSubqueries as: requiredResult! !

!ClyCompositeQuery methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateResultMethodEditor: aMethodEditor

	subqueries do: [ :each | each decorateResultMethodEditor: aMethodEditor]! !

!ClyCompositeQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ subqueries = anObject subqueries! !

!ClyCompositeQuery methodsFor: 'converting' stamp: ''!
restrictedByScope: aScope
	| newSubqueries |
	newSubqueries := subqueries collect: [ :each | each restrictedByScope: aScope ].
	^self withSubqueries: newSubqueries! !

!ClyCompositeQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: subqueries hash! !

!ClyCompositeQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin
	subqueries do: [ :each | each collectMetadataOf: aQueryResult by: anEnvironmentPlugin ]! !

!ClyCompositeQuery methodsFor: 'testing' stamp: ''!
retrievesItem: anObject
	^subqueries anySatisfy: [ :each | each retrievesItem: anObject ]! !

!ClyCompositeQuery methodsFor: 'converting' stamp: ''!
withoutItemsOfType: anItemTypeClass

	^self withSubqueries: (subqueries reject: [ :each | each retrievesItemsOfType: anItemTypeClass ])! !

!ClyCompositeQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement

	^subqueries anySatisfy: [ :each | 
			each isResult: aQueryResult affectedBy: aSystemAnnouncement ]! !

!ClyCompositeQuery methodsFor: 'item group decoration' stamp: ''!
decorateItemGroup: groupItem
	subqueries do: [ :each | each decorateItemGroup: groupItem ]! !

!ClyCompositeQuery methodsFor: 'accessing' stamp: ''!
subqueries
	^ subqueries! !

!ClyCompositeQuery methodsFor: 'printing' stamp: ''!
description
	^String streamContents: [ :s | self printExtraInfoOn: s]! !

!ClyCompositeQuery methodsFor: 'accessing' stamp: ''!
subqueries: aCollection
	| subscopes |
	aCollection ifEmpty: [ ^self error: 'Composite query must have at least one subquery' ].
	
	subqueries := aCollection asSet.
	subscopes := subqueries collect: [:each | each scope].
	scope := ClyCompositeScope on: subscopes.
	self requiredResult: subqueries anyOne requiredResult! !

!ClyCompositeQuery methodsFor: 'converting' stamp: ''!
withScopeOf: newBasisObjects
	| newSubqueries |
	newSubqueries := subqueries collect: [ :each | each withScopeOf: newBasisObjects ].
	^self withSubqueries: newSubqueries! !

!ClyCompositeQuery methodsFor: 'converting' stamp: ''!
withScope: aTypedScope
	| newSubqueries |
	newSubqueries := subqueries collect: [ :each | each withScope: aTypedScope ].
	^self withSubqueries: newSubqueries! !

!ClyCompositeQuery methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	subqueries do: [:each |
		each decorateMethodGroupTableCell: anItemCellMorph of: groupItem  ]! !

!ClyCompositeQuery methodsFor: 'testing' stamp: ''!
retrievesItemsOfType: itemTypeClass
	
	^subqueries anySatisfy: [ :each | each retrievesItemsOfType: itemTypeClass ]! !

!ClyCompositeQuery methodsFor: 'testing' stamp: ''!
executesQuery: aTypedQueryClass
	^subqueries anySatisfy: [:each | each executesQuery: aTypedQueryClass ]! !

!ClyCompositeQuery methodsFor: 'execution' stamp: ''!
fixStateBeforeExecution
	super fixStateBeforeExecution.
	
	subqueries do: [ :each | each fixStateBeforeExecution ]! !

!ClyCompositeQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	^ subqueries allSatisfy: [ :each | each hasEmptyResult ]! !

!ClyCompositeQuery methodsFor: '*Calypso-SystemQueries' stamp: ''!
withMetaLevelScope: aScopeClass 
	| newSubqueries |
	newSubqueries := subqueries collect: [ :each | 
		each withMetaLevelScope: aScopeClass ].
	^self class with: newSubqueries as: requiredResult! !

!ClyCompositeQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream
	| descriptions |
	super printExtraInfoOn: aStream.

	descriptions := subqueries collect: [:each | each description] as: Set.
	descriptions do: [:each | 
		aStream nextPutAll: each; nextPutAll: ', '].
	aStream skip: -2 "composite can not be empty"! !

!ClyCompositeQuery class methodsFor: 'instance creation' stamp: ''!
with: subqueries
	subqueries ifEmpty: [ ^ClyUnknownQuery instance ].
	
	^self new 
		subqueries: subqueries! !

!ClyCompositeQuery class methodsFor: 'instance creation' stamp: ''!
with: subqueries as: aQueryResult
	^(self with: subqueries)
		requiredResult: aQueryResult! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromScopeOfBasisObject
	
	self assert: (query isExecutedFromScopeOf: query scope basisObjects anyOne).
	
	self deny: (query isExecutedFromScopeOf: #someObject).! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromSingleScopeWhenSingleSubqueryIsBasedOnIt

	query subqueries: { 
		self subqueryFromScopeOf: self class.
	}.
	
	self assert: query isExecutedFromSingleScope! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testFixingStateBeforeExecutionShouldFixSubqueriesState

	query fixStateBeforeExecution.
	
	query subqueries do: [ :each | 
		self assert: each isReadOnlyObject.
		self assert: each scope isReadOnlyObject]! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testNotExecutedFromMultipleScopeWhenAllSubqueriesAreFromEmptyScope

	query subqueries: { 
		self subqueryFromScope: ClyExampleScope empty.
		self subqueryFromScope: ClyExample2Scope empty.
	}.
	
	self deny: query isExecutedFromMultipleScope! !

!ClyCompositeQueryTest methodsFor: 'running' stamp: ''!
subqueryFromScope: aScope
	aScope bindTo: environment.
	^ ClyReturningScopeBasisExampleQuery
		from: aScope! !

!ClyCompositeQueryTest methodsFor: 'running' stamp: ''!
subqueryFromScopeOf: aBasisObject
	^self subqueryFromScope: ClyExampleScope of: aBasisObject! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromConcreteScopeClass

	self assert: (query isExecutedFromScope: ClyExampleScope).
	self assert: (query isExecutedFromScope: ClyScope).
	
	self deny: (query isExecutedFromScope: Array).! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromEmptyScope

	self deny: query isExecutedFromEmptyScope.
	
	query := self queryClass with: { self subqueryFromScope: ClyExampleScope empty}.
	self assert: query isExecutedFromEmptyScope! !

!ClyCompositeQueryTest methodsFor: 'running' stamp: ''!
queryClass
	self subclassResponsibility! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testCreationWithEmptySubqueriesShouldReturnUnknownQuery
	query := self queryClass with: {}.

	self assert: query identicalTo: ClyUnknownQuery instance! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromSingleScopeWhenSubqueriesAreFromDifferentScopesOfSameObject

	query subqueries: { 
		self subqueryFromScope: ClyExampleScope of: self class.
		self subqueryFromScope: ClyExample2Scope of: self class.
	}.
	
	self assert: query isExecutedFromSingleScope! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testConvertingAsRestrictedByAnotherScope

	| convertedQuery restrictedScope |
	restrictedScope := ClyExample2Scope of: #restrictedBasis.
	convertedQuery := query restrictedByScope: restrictedScope.
	self assert: convertedQuery class equals: query class.
	self assert: convertedQuery requiredResult identicalTo: query requiredResult.
	self assert: (convertedQuery subqueries collect: [:each | each class]) equals: (query subqueries collect: #class).
	self assert: (convertedQuery subqueries collect: [:each | each scope]) equals: (query subqueries collect: [ :each | each scope withNewBasisObjects: #(restrictedBasis) ])! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testHasCompositeScopeFromSubqueries

	| scope |
	scope := query scope.
	self assert: scope class equals: ClyCompositeScope.
	self assert: scope subscopes equals: (query subqueries collect: [:each | each scope]).! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testNotExecutedFromSingleScopeWhenAllSubqueriesAreFromEmptyScope

	query subqueries: { 
		self subqueryFromScope: ClyExampleScope empty.
		self subqueryFromScope: ClyExample2Scope empty.
	}.
	
	self deny: query isExecutedFromSingleScope! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewScopeBasis
	| convertedQuery |
	convertedQuery := query withScopeOf: #(newBasis).

	self assert: convertedQuery class equals: query class.
	self assert: convertedQuery requiredResult identicalTo: query requiredResult.
	self assert: (convertedQuery subqueries collect: [:each | each class]) equals: (query subqueries collect: #class).
	self assert: (convertedQuery subqueries collect: [:each | each scope]) equals: (query subqueries collect: [ :each | each scope withNewBasisObjects: #(newBasis) ])! !

!ClyCompositeQueryTest methodsFor: 'running' stamp: ''!
subqueryFromScope: aScopeClass of: aBasisObject
	^self subqueryFromScope: (aScopeClass of: aBasisObject)! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromMultipleScopeWhenSubqueriesAreFromScopesOfDifferentObjects

	query subqueries: { 
		self subqueryFromScopeOf: self class.
		self subqueryFromScopeOf: self class superclass.
	}.
	
	self assert: query isExecutedFromMultipleScope.! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testNotExecutedFromMultipleScopeWhenSubqueriesAreFromDifferentScopesOfSameObject

	query subqueries: { 
		self subqueryFromScope: ClyExampleScope of: self class.
		self subqueryFromScope: ClyExample2Scope of: self class.
	}.
	
	self deny: query isExecutedFromMultipleScope! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testExecutesConcreteQueryClass
	query subqueries: { self subqueryFromScopeOf: #basis }.
	
	self deny: (query executesQuery: query class).
	
	self assert: (query executesQuery: query subqueries anyOne class).
	
	self deny: (query executesQuery: ClyReturningScopeBasis2ExampleQuery)! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewScope
	| newScope convertedQuery |
	newScope := ClyExample2Scope of: #someBasis in: environment.

	convertedQuery := query withScope: newScope.

	self assert: convertedQuery class equals: query class.
	self assert: convertedQuery requiredResult identicalTo: query requiredResult.
	self assert: (convertedQuery subqueries collect: [:each | each class]) equals: (query subqueries collect: #class).
	self assert: (convertedQuery subqueries collect: [:each | each scope] as: Set) equals: {newScope} asSet! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testNotExecutedFromSingleScopeWhenSubqueriesAreFromScopesOfDifferentObjects

	query subqueries: { 
		self subqueryFromScopeOf: self class.
		self subqueryFromScopeOf: self class superclass.
	}.
	
	self deny: query isExecutedFromSingleScope.! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testNotExecutedFromMultipleScopeWhenSingleSubqueryIsFromEmptyScope

	query subqueries: { 
		self subqueryFromScope: ClyExampleScope empty.
	}.
	
	self deny: query isExecutedFromMultipleScope! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testCompareWithSimilarQueryWhichSubqueryHasDifferentScope
	| query2 |
	query2 := self queryClass with: {(self subqueryFromScopeOf: self class superclass)}.

	self deny: query equals: query2! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testNotExecutedFromMultipleScopeWhenSingleSubqueryIsBasedOnScopeOfSingleObject

	query subqueries: { 
		self subqueryFromScopeOf: self class.
	}.
	
	self deny: query isExecutedFromMultipleScope! !

!ClyCompositeQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromMultipleScopeWhenSingleSubqueryIsBasedOnIt

	query subqueries: { 
		self subqueryFromScope: (ClyExampleScope ofAll: { self class. self class superclass}).
	}.
	
	self assert: query isExecutedFromMultipleScope! !

!ClyCompositeQueryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyCompositeQueryTest! !

!ClyCompositeScope commentStamp: ''!
I am scope which merges multiple subscopes. 
I am supposed to represent scope of composite query where real execution logic is delegated to each subquery. 
So am not really participate in query execution. But I am still can be used by UI tools to provide optional scopes for query execution.

To create my instances use following script:

		ClyCompositeScope on: { aScope1. aScope2 }
		
But usually I am created using concatenation message to simple scope: 

	aScope1 , aScope2 
	
I am supposed to be created on the set of typed scopes.

And I implement abstract methods of superclass: 

- adoptQuery: aQuery. It creates ClyUnionQuery with subqueries created from given aQuery with each subscope.
- representsScope: aScopeClass. It ask every subscope if it represents given scope.
- supportsQuery: aQuery. I support only composite queries.

Internal Representation and Key Implementation Points.

    Instance Variables
	subscopes:		<ClyTypedScope>
!
!ClyCompositeScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
asInheritedScope
	| newSubscopes |
	newSubscopes := subscopes collect: [ :each | each asInheritedScope ].
	^ClyCompositeScope on: newSubscopes in: environment named: ClyClassScope inheritedScopeName! !

!ClyCompositeScope methodsFor: 'queries' stamp: ''!
adoptQuery: aQuery
	| subqueries result |
	subqueries := subscopes collect: [ :each | aQuery withScope: each ].
	result := ClyQuery unionFrom: subqueries.
	result scope name: name.
	^result! !

!ClyCompositeScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
asRBEnvironment
	| env |
	subscopes do: [:each | 
		env := env ifNil: [ each asRBEnvironment ] ifNotNil: [ env | each asRBEnvironment ]].
	^env! !

!ClyCompositeScope methodsFor: 'accessing' stamp: ''!
bindTo: aNavigationEnvironment
	super bindTo: aNavigationEnvironment.
	
	subscopes do: [ :each | each bindTo: aNavigationEnvironment]! !

!ClyCompositeScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
collectAllClasses
	| result |
	result := IdentitySet new.
	
	subscopes do: [ :scope | scope classesDo: [:each | result add: each ]].
	
	^result! !

!ClyCompositeScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
packagesDo: aBlock 
	subscopes do: [ :each | each packagesDo: aBlock]! !

!ClyCompositeScope methodsFor: 'printing' stamp: ''!
printBasisObject: anObject on: aStream

	| actualScope |
	actualScope := subscopes detect: [ :each | each isBasedOn: anObject ].
	^actualScope printBasisObject: anObject on: aStream! !

!ClyCompositeScope methodsFor: 'printing' stamp: ''!
printDescriptionOn: aStream

	name ifNotNil: [ ^super printDescriptionOn: aStream ].
	
	subscopes do: [ :each | 
		each printDescriptionOn: aStream.
		aStream nextPutAll: ', ' ].
	aStream skip: -2 "composite scope must include at least on subscope"! !

!ClyCompositeScope methodsFor: 'accessing' stamp: ''!
subscopes: aCollection
	aCollection ifEmpty: [ ^self error: 'ClyCompositeScope should include at least one subscope' ].
	
	subscopes := aCollection.
	environment := subscopes anyOne environment.
	self basisObjects: (subscopes flatCollect: [ :each | each basisObjects ])! !

!ClyCompositeScope methodsFor: 'testing' stamp: ''!
supportsQuery: aQuery
	^aQuery isKindOf: ClyCompositeQuery! !

!ClyCompositeScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
classesDo: aBlock 
	subscopes do: [ :each | each classesDo: aBlock]! !

!ClyCompositeScope methodsFor: 'accessing' stamp: ''!
subscopes
	^ subscopes! !

!ClyCompositeScope methodsFor: 'composition' stamp: ''!
, anotherTypedScope
	(anotherTypedScope isKindOf: ClyTypedScope) ifFalse: [ 
		^self error: 'Complex composition is not supported' ].
	^ClyCompositeScope on: (subscopes copyWith: anotherTypedScope)! !

!ClyCompositeScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
asInterestingClassScope
	| newSubscopes |
	newSubscopes := subscopes collect: [ :each | each asInterestingClassScope ].
	^ClyCompositeScope on: newSubscopes in: environment named: name! !

!ClyCompositeScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
asLocalClassScope
	| newSubscopes |
	newSubscopes := subscopes collect: [ :each | each asLocalClassScope ].
	^ClyCompositeScope on: newSubscopes in: environment! !

!ClyCompositeScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
withMetaLevel: aScopeClass 
	| newSubscopes |
	newSubscopes := subscopes collect: [ :each | each withMetaLevel: aScopeClass ].
	^ClyCompositeScope on: newSubscopes in: environment named: name! !

!ClyCompositeScope methodsFor: 'testing' stamp: ''!
representsScope: aScopeClass
	^subscopes anySatisfy: [ :each | each representsScope: aScopeClass ]! !

!ClyCompositeScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
asInheritingScope
	| newSubscopes |
	newSubscopes := subscopes collect: [ :each | each asInheritingScope ].
	^ClyCompositeScope on: newSubscopes in: environment named: ClyClassScope inheritingScopeName! !

!ClyCompositeScope class methodsFor: 'instance creation' stamp: ''!
on: subscopes
	subscopes size = 1 ifTrue: [ ^subscopes anyOne ].
	
	^self new 
		subscopes: subscopes! !

!ClyCompositeScope class methodsFor: 'instance creation' stamp: ''!
on: subscopes in: aNavigationEnvironment
	^(self on: subscopes)
		bindTo: aNavigationEnvironment! !

!ClyCompositeScope class methodsFor: 'instance creation' stamp: ''!
on: subscopes in: aNavigationEnvironment named: aString
	^(self on: subscopes in: aNavigationEnvironment)
		name: aString! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testCreationOnTwoSimilarSubscopesOfSameObject
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope ofAll: #(sameBasisObject basisObject1) in: environment.
	subscope2 := ClyExampleScope ofAll: #(sameBasisObject basisObject2) in: environment.
	
	scope := ClyCompositeScope on: {subscope1. subscope2}.
	
	self
		assert: scope basisObjects asSet
		equals: #(sameBasisObject basisObject1 basisObject2) asSet! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testHasEnvironmentFromSubscopes

	scope := self createSampleScope.

	self assert: scope environment equals: environment! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testAdoptQuery
	| query adoptedQuery |
	scope := ClyCompositeScope on: {
		ClyExampleScope of: Object in: environment.
		ClyExample2Scope of: Array in: environment}.
	query := ClyReturningScopeBasisExampleQuery new.
	query extraParameter: #testParameter.
	
	adoptedQuery := scope adoptQuery: query.
	
	self assert: adoptedQuery class equals: ClyUnionQuery.
	self assert: adoptedQuery subqueries size equals: 2.
	adoptedQuery subqueries do: [ :each | 
			self assert: each class equals: query class.
			self assert: each extraParameter equals: #testParameter ].
	self
		assert: (adoptedQuery subqueries collect: [:each | each scope])
		equals: scope subscopes asSet! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testComparisonWithCompositeScopeBasedOnDifferentQueries
	| scope2 |
	scope := self createSampleScope.
	scope2 := self createSampleScope.
	scope2 subscopes: {(ClyExample2Scope of: #someBasis in: environment)}.

	self deny: scope equals: scope2! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testCreationByComma
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope of: #basisObject1 in: environment.
	subscope2 := ClyExample2Scope of: #basisObject2 in: environment.
	
	scope := subscope1 , subscope2.
	
	self assert: scope class equals: ClyCompositeScope.
	self assert: scope basisObjects equals: #(basisObject1 basisObject2) asSet.
	self assert: scope subscopes asSet equals: {subscope1. subscope2} asSet.
	self assert: scope environment equals: environment! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testIsBasedOnSingleBasisWhenTwoSubscopesAreBasedOnSameSingleObject
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope of: #basisObject in: environment.
	subscope2 := ClyExample2Scope of: #basisObject in: environment.
	scope := ClyCompositeScope on: {subscope1. subscope2}.
	
	self assert: scope isBasedOnSingleBasis! !

!ClyCompositeScopeTest methodsFor: '*Calypso-SystemQueries-Tests' stamp: ''!
testConvertingToNewMetaLevelShouldKeepScopeName
	| convertedScope |
	scope := ClyCompositeScope on: {
		ClyClassScope of: Object in: environment.
		ClySubclassScope of: Array in: environment}.
	scope name: 'test scope'.
		
	convertedScope := scope withMetaLevel: ClyInstanceSideScope.
	
	self assert: convertedScope name equals: 'test scope'! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testRepresentsClassOfScope

	scope := self createSampleScope.
	self assert: (scope representsScope: ClyExampleScope).
	self assert: (scope representsScope: ClyTypedScope).
	
	self deny: (scope representsScope: String). "Class of scope which are not the class of subscopes"! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testBindToEnvironmentShouldBindSubscopes
	| subscopes |
	scope := ClyCompositeScope on: {
		ClyExampleScope of: Object. 
		ClyExample2Scope of: Array}.

	scope bindTo: environment.
	
	subscopes := scope subscopes asArray.
	self assert: subscopes first environment equals: environment.
	self assert: subscopes second environment equals: environment! !

!ClyCompositeScopeTest methodsFor: '*Calypso-SystemQueries-Tests' stamp: ''!
testConvertingToInterestingClassScope
	| convertedScope |
	scope := ClyCompositeScope on: { 
		ClySuperclassScope of: String in: environment localScope: ClyInstanceSideScope.
		ClySubclassScope of: Array in: environment localScope: ClyClassSideScope }.
	
	convertedScope := scope asInterestingClassScope.
	
	self assert: convertedScope class equals: ClyCompositeScope.
	self 
		assert: convertedScope subscopes asSet 
		equals: {
			ClyInterestingSuperclassScope of: String localScope: ClyInstanceSideScope.
			ClySubclassScope of: Array localScope: ClyClassSideScope} asSet.
	self assert: convertedScope environment equals: environment.! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testNotBasedOnSingleBasisWhenTwoSubscopesAreBasedOnSingleButDifferentObject
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope of: #basisObject1 in: environment.
	subscope2 := ClyExampleScope of: #basisObject2 in: environment.
	scope := ClyCompositeScope on: {subscope1. subscope2}.

	self deny: scope isBasedOnSingleBasis! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testCreationOnSingleSubscopeOfMultipleObjects
	| subscope |
	subscope := ClyExampleScope ofAll: #(basisObject1 basisObject2) in: environment.
	
	scope := ClyCompositeScope on: {subscope}.
	
	self assert: scope basisObjects asSet equals: subscope basisObjects asSet! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testIsBasedOnSingleBasisWhenSingleSubscopeIs
	| subscope |
	subscope := ClyExampleScope of: #basisObject in: environment.
	scope := ClyCompositeScope on: {subscope}.
	
	self assert: scope isBasedOnSingleBasis! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testNotBasedOnSingleBasisWhenSingleSubscopeIsNot
	| subscope |
	subscope := ClyExampleScope ofAll: #(basisObject1 basisObject2) in: environment.
	scope := ClyCompositeScope on: {subscope}.
	
	self deny: scope isBasedOnSingleBasis! !

!ClyCompositeScopeTest methodsFor: '*Calypso-SystemQueries-Tests' stamp: ''!
testConvertingToInterestingClassScopeShouldKeepScopeName
	| convertedScope |
	scope := ClyCompositeScope on: {
		ClySuperclassScope of: String. ClySubclassScope of: Array}.
	scope name: 'test scope'.
	
	convertedScope := scope asInterestingClassScope.
	
	self assert: convertedScope name equals: 'test scope'! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testNotBasedOnMultipleBasisWhenAllSubscopesHaveEmptyBasis
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope emptyIn: environment.
	subscope2 := ClyExampleScope emptyIn: environment.
	scope := ClyCompositeScope on: {subscope1. subscope2}.

	self deny: scope isBasedOnMultipleBasis! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testNotBasedOnMultipleBasisWhenSingleSubscopeIsNot
	| subscope |
	subscope := ClyExampleScope of: #basisObject in: environment.
	scope := ClyCompositeScope on: {subscope}.
	
	self deny: scope isBasedOnMultipleBasis! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testNotBasedOnSingleBasisWhenAllSubscopesHaveEmptyBasis
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope emptyIn: environment.
	subscope2 := ClyExampleScope emptyIn: environment.
	scope := ClyCompositeScope on: {subscope1. subscope2}.
	
	self deny: scope isBasedOnSingleBasis! !

!ClyCompositeScopeTest methodsFor: 'running' stamp: ''!
createSampleScope
	| subscope subscope2 |
	subscope := ClyExampleScope of: #basisObject in: environment.
	subscope2 := ClyExample2Scope of: #basisObject2 in: environment.
	^ ClyCompositeScope on: {subscope. subscope2}! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testIsBasedOnMultipleBasisWhenSingleSubscopeIs
	| subscope |
	subscope := ClyExampleScope ofAll: #(basisObject1 basisObject2) in: environment.
	
	scope := ClyCompositeScope on: {subscope}.
	
	self assert: scope isBasedOnMultipleBasis! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testIsBasedOnMultipleBasisWhenTwoSubscopesAreBasedOnSingleButDifferentObject
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope of: #basisObject1 in: environment.
	subscope2 := ClyExampleScope of: #basisObject2 in: environment.	
	scope := ClyCompositeScope on: {subscope1. subscope2}.
	
	self assert: scope isBasedOnMultipleBasis! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testCreationOnTwoDifferentSubscopesOfSameObject
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope ofAll: #(sameBasisObject basisObject1) in: environment.
	subscope2 := ClyExample2Scope ofAll: #(sameBasisObject basisObject2) in: environment.
	
	scope := ClyCompositeScope on: {subscope1. subscope2}.
	self
		assert: scope basisObjects asSet
		equals: #(sameBasisObject basisObject1 basisObject2) asSet! !

!ClyCompositeScopeTest methodsFor: '*Calypso-SystemQueries-Tests' stamp: ''!
testConvertingToInheritingScope
	| convertedScope |
	scope := ClyCompositeScope on: {
		ClyInstanceSideScope of: Object in: environment.
		ClyClassSideScope of: Array in: environment}.
		
	convertedScope := scope asInheritingScope.
	
	self assert: convertedScope class equals: ClyCompositeScope.
	self assert: (convertedScope subscopes first representsScope: ClySubclassScope).
	self assert: (convertedScope subscopes last representsScope: ClySubclassScope).
	self
		assert: (convertedScope subscopes collect: #localScopeClass as: Set)
		equals: {ClyInstanceSideScope. ClyClassSideScope} asSet.
	self assert: convertedScope environment equals: environment.
	self assert: convertedScope name equals: ClyClassScope inheritingScopeName! !

!ClyCompositeScopeTest methodsFor: '*Calypso-SystemQueries-Tests' stamp: ''!
testConvertingToInheritedScope
	| convertedScope |
	scope := ClyCompositeScope on: {
		ClyInstanceSideScope of: Object in: environment.
		ClyClassSideScope of: Array in: environment}.
		
	convertedScope := scope asInheritedScope.
	
	self assert: convertedScope class equals: ClyCompositeScope.
	self assert: (convertedScope subscopes first representsScope: ClySuperclassScope).
	self assert: (convertedScope subscopes last representsScope: ClySuperclassScope).
	self
		assert: (convertedScope subscopes collect: #localScopeClass as: Set)
		equals: {ClyInstanceSideScope. ClyClassSideScope} asSet.
	self assert: convertedScope environment equals: environment.
	self assert: convertedScope name equals: ClyClassScope inheritedScopeName! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testAdoptQueryShouldKeepScopeName
	| query adoptedQuery |
	scope := ClyCompositeScope on: {
		ClyExampleScope of: Object in: environment.
		ClyExample2Scope of: Array in: environment}.
	scope name: 'test scope'.
	query := ClyReturningScopeBasisExampleQuery new.
	
	adoptedQuery := scope adoptQuery: query.
	
	self assert: adoptedQuery scope name equals: 'test scope'! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testCreationOnTwoSubscopesOfDifferentObjects
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope of: #basisObject1 in: environment.
	subscope2 := ClyExampleScope of: #basisObject2 in: environment.
	
	scope := ClyCompositeScope on: {subscope1. subscope2}.
	
	self
		assert: scope basisObjects asSet
		equals: #(basisObject1 basisObject2) asSet! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testEmptySubscopesAreForbidden
	
	[ClyCompositeScope on: #().
	self assert: false description: 'empty subscopes should be forbidden'] onErrorDo: [].! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToAnotherScopeClassShouldRemoveDuplications
	| convertedScope |
	scope := ClyCompositeScope on: {
		ClyExampleScope of: Object in: environment.
		ClyExample2Scope ofAll: {Object. Array} in: environment}.
		
	convertedScope := scope asScope: ClyExample2Scope.
	
	self assert: convertedScope class equals: ClyExample2Scope.
	self assert: convertedScope basisObjects size equals: 2.
	self assert: convertedScope basisObjects asIdentitySet equals: {Object. Array} asSet.
	self assert: convertedScope environment equals: environment! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testCreationByCommaFromThreeSubscopes
	| subscope1 subscope2 subscope3 |
	subscope1 := ClyExampleScope of: #basisObject1 in: environment.
	subscope2 := ClyExample2Scope of: #basisObject2 in: environment.
	subscope3 := ClyExample2Scope of: #basisObject3 in: environment.
	
	scope := subscope1 , subscope2 , subscope3.
	
	self assert: scope class equals: ClyCompositeScope.
	self
		assert: scope basisObjects
		equals: #(basisObject1 basisObject2 basisObject3) asSet.
	self 
		assert: scope subscopes asSet 
		equals: {subscope1. subscope2. subscope3} asSet.
	self assert: scope environment equals: environment! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testBasedOnBasisObject

	scope := self createSampleScope.

	self assert: (scope isBasedOn: scope basisObjects anyOne).
	self deny: (scope isBasedOn: #anotherObject)! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testIsBasedOnEmptyBasisWhenAllSubscopesHaveEmptyBasis
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope emptyIn: environment.
	subscope2 := ClyExampleScope emptyIn: environment.
	
	scope := ClyCompositeScope on: {subscope1. subscope2}.
	
	self assert: scope isBasedOnEmptyBasis! !

!ClyCompositeScopeTest methodsFor: 'tests' stamp: ''!
testNotBasedOnMultipleBasisWhenTwoSubscopesAreBasedOnSameSingleObject
	| subscope1 subscope2 |
	subscope1 := ClyExampleScope of: #basisObject in: environment.
	subscope2 := ClyExample2Scope of: #basisObject in: environment.
	scope := ClyCompositeScope on: {subscope1. subscope2}.
	
	self deny: scope isBasedOnMultipleBasis! !

!ClyCompositeScopeTest methodsFor: '*Calypso-SystemQueries-Tests' stamp: ''!
testConvertingToNewMetaLevel
	| convertedScope |
	scope := ClyCompositeScope on: {
		ClyClassScope of: Object in: environment.
		ClySubclassScope of: Array in: environment}.
		
	convertedScope := scope withMetaLevel: ClyInstanceSideScope.
	
	self assert: convertedScope class equals: ClyCompositeScope.
	self
		assert: convertedScope subscopes first
		equals: (ClyInstanceSideScope of: Object).
	self
		assert: convertedScope subscopes last class
		equals: ClySubclassScope.
	self
		assert: convertedScope subscopes last localScopeClass
		equals: ClyInstanceSideScope.
	self assert: convertedScope environment equals: environment.
	self
		assert: (convertedScope subscopes collect: #environment as: Set)
		equals: {environment} asSet! !

!ClyCompositeTestResultProperty commentStamp: ''!
I compose test result information from all classes which inherit tests from decorated method or class.
My counts variables provide summary on all of them. And the map testCaseResults include information for each of them.

I am used to correctly run inherited tests when they are visible in the browser from subclasses.
And I allow to run all tests of abstract class including all subclasses.
   
Internal Representation and Key Implementation Points.

    Instance Variables
	testCaseResults:		<Dictionary of<TestCase class, ClyTestResultProperty>>!
!ClyCompositeTestResultProperty methodsFor: 'accessing' stamp: ''!
concreteResultOf: aTestClass ifPresent: presentBlock

	^testCaseResults at: aTestClass ifPresent: presentBlock! !

!ClyCompositeTestResultProperty methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	testCaseResults := IdentityDictionary new! !

!ClyCompositeTestResultProperty methodsFor: 'accessing' stamp: ''!
testCaseResults: anObject
	testCaseResults := anObject! !

!ClyCompositeTestResultProperty methodsFor: 'accessing' stamp: ''!
testCases
	^ testCaseResults keys! !

!ClyCompositeTestResultProperty methodsFor: 'accessing' stamp: ''!
accumulateTestMethod: aMethod
	| testSelector result inheritingScope |	
	testSelector := aMethod selector.
	inheritingScope := (ClyClassScope of: aMethod methodClass) withInheritingScope.
	inheritingScope classesDo: [ :concreteTestCase | 
		(concreteTestCase isTestCase and: [concreteTestCase isAbstract not]) ifTrue: [
			self accumulateTest: testSelector of: concreteTestCase.
			
			result := testCaseResults 
				at: concreteTestCase ifAbsentPut: [ ClyTestResultProperty new ].
			result accumulateTest: testSelector of: concreteTestCase ]]! !

!ClyCompositeTestResultProperty methodsFor: 'accessing' stamp: ''!
testCaseResults
	^ testCaseResults! !

!ClyConcreteCritiqueMethodGroup commentStamp: ''!
I am a method group which include methods with critiques of particular severity level.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	ruleSeverity:		<ClyCritiqueSeverity>!
!ClyConcreteCritiqueMethodGroup methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem
		
	anItemCellMorph definitionIcon: ruleSeverity iconName! !

!ClyConcreteCritiqueMethodGroup methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	ruleSeverity := ClyCritiqueSeverityProperty default! !

!ClyConcreteCritiqueMethodGroup methodsFor: 'accessing' stamp: ''!
ruleSeverity
	^ ruleSeverity! !

!ClyConcreteCritiqueMethodGroup methodsFor: 'accessing' stamp: ''!
ruleSeverity: anObject
	ruleSeverity := anObject! !

!ClyConcreteCritiqueMethodGroup methodsFor: 'accessing' stamp: ''!
addCritique: aCritique
	| newSeverity |
	newSeverity := ClyCritiqueSeverityProperty of: aCritique.
	(newSeverity isMoreImportantThan: ruleSeverity)
		ifTrue: [ ruleSeverity := newSeverity ]! !

!ClyConcreteCritiqueMethodGroup class methodsFor: 'instance creation' stamp: ''!
basedOn: aCritique withMethodsFrom: aScope

	| groupName methodQuery |
	groupName := aCritique rule group.
	methodQuery := ClyAllProblemMethodQuery 
			from: aScope withCritiquesFromGroup: groupName.

	^self named: groupName asLowercase on: methodQuery! !

!ClyConcreteGroupCritiqueQuery commentStamp: ''!
I return critiques of my base query which belongs to particular group.

To create my instance use following expression: 

	ClyConcreteGroupCritiques filter: aCritiqueQuery from: aScope byGroup: aString
 
Internal Representation and Key Implementation Points.

    Instance Variables
	groupName:		<String>!
!ClyConcreteGroupCritiqueQuery methodsFor: 'accessing' stamp: ''!
groupName: anObject
	groupName := anObject! !

!ClyConcreteGroupCritiqueQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
		
	^groupName = anObject groupName! !

!ClyConcreteGroupCritiqueQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: groupName hash! !

!ClyConcreteGroupCritiqueQuery methodsFor: 'accessing' stamp: ''!
groupName
	^ groupName! !

!ClyConcreteGroupCritiqueQuery methodsFor: 'testing' stamp: ''!
selectsCritique: aCritique
	^aCritique rule group = groupName! !

!ClyConcreteGroupCritiqueQuery methodsFor: 'printing' stamp: ''!
description

	^groupName! !

!ClyConcreteGroupCritiqueQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream
	super printExtraInfoOn: aStream.

	aStream nextPutAll: groupName! !

!ClyConcreteGroupCritiqueQuery class methodsFor: 'instance creation' stamp: ''!
filter: aCritiqueQuery from: aScope byGroup: aString

	^(self filter: aCritiqueQuery from: aScope)
		groupName: aString! !

!ClyConcreteGroupCritiquesTest methodsFor: 'tests' stamp: ''!
testExecutionWhenNoCritiquesFromRequiredGroup

	query groupName: 'wrong group'.
	
	self executeQuery.
	
	self assert: resultItems isEmpty! !

!ClyConcreteGroupCritiquesTest methodsFor: 'tests' stamp: ''!
testComparisonWithQueryOfAnotherGroup
	| query2 |
	query2 := self createQuery.
	query2 groupName: 'another group'.

	self deny: query equals: query2! !

!ClyConcreteGroupCritiquesTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	
	query scope: self scopeWithoutCritiques.
	self assert: query checkEmptyResult.

	query := self createQuery.		
	query scope: self scopeWithCritiques .
	self deny: query checkEmptyResult.
	
	query groupName: 'wrong group'.
	self assert: query checkEmptyResult.! !

!ClyConcreteGroupCritiquesTest methodsFor: 'tests' stamp: ''!
testExecution

	self executeQuery.
	
	self assert: resultItems size equals: 1! !

!ClyConcreteGroupCritiquesTest methodsFor: 'running' stamp: ''!
createQuery
	| exampleCritique |
	exampleCritique := self methodWithCritiques critiques anyOne.
	
	^ClyConcreteGroupCritiqueQuery 
		filter: ClyAllMethodCritiqueQuery new
		from: self scopeWithCritiques 
		byGroup: exampleCritique rule group! !

!ClyConstantMethodQuery commentStamp: ''!
I am most trivial method query which just returns constant set of methods.

I implement logic to always return live method instances:
- I filter out removed methods
- I return actual version of methods if they were modified
Look at the method #filterInstalledMethods: for details.

To create my instances use:
	ClyConstantMethodQuery with: {Rectangle >> #area}
Or with special description:
	ClyConstantMethodQuery named: 'todo methods' with: {Rectangle >> #area}
 
Internal Representation and Key Implementation Points.

    Instance Variables
	description:		<String>
	methods:		<IdentitySet of: CompiledMethod>!
!ClyConstantMethodQuery methodsFor: 'converting' stamp: ''!
semiAsync
	^self! !

!ClyConstantMethodQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].	
	^ methods = anObject methods! !

!ClyConstantMethodQuery methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	description := 'Methods'! !

!ClyConstantMethodQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash bitXor: methods hash! !

!ClyConstantMethodQuery methodsFor: 'accessing' stamp: ''!
methods: anObject
	methods := anObject asIdentitySet! !

!ClyConstantMethodQuery methodsFor: 'accessing' stamp: ''!
description: anObject
	description := anObject! !

!ClyConstantMethodQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult

	aQueryResult fillWith: self scopedMethods! !

!ClyConstantMethodQuery methodsFor: 'accessing' stamp: ''!
description
	^ description! !

!ClyConstantMethodQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod

	^methods anySatisfy: [ :each | 
		each calypsoEnvironmentType checkCalypsoItem: each isEqualTo: aMethod]! !

!ClyConstantMethodQuery methodsFor: 'execution' stamp: ''!
filterInstalledMethods: methodsCollection

	^methodsCollection
		collect: [ :each | each origin localMethodNamed: each selector ifAbsent: [nil] ]
		thenReject: [ :each | each isNil or: [each package isNil or: [ each isInstalled not]]]! !

!ClyConstantMethodQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	^self installedMethods isEmpty! !

!ClyConstantMethodQuery methodsFor: 'execution' stamp: ''!
scopedMethods

	| installedMethods scopedMethods |
	installedMethods := self installedMethods.
	scopedMethods := IdentitySet new.
	
	scope methodsDo: [ :each | 
		(installedMethods includes: each) ifTrue: [ 
			scopedMethods add: each.
			installedMethods remove: each.
			installedMethods ifEmpty: [ ^scopedMethods ] ]].
	
	^scopedMethods! !

!ClyConstantMethodQuery methodsFor: 'accessing' stamp: ''!
methods
	^ methods! !

!ClyConstantMethodQuery methodsFor: 'converting' stamp: ''!
async
	^self! !

!ClyConstantMethodQuery methodsFor: 'execution' stamp: ''!
installedMethods

	^self filterInstalledMethods: methods! !

!ClyConstantMethodQuery class methodsFor: 'instance creation' stamp: ''!
named: queryDescription with: methods
	^(self with: methods)
		description: queryDescription! !

!ClyConstantMethodQuery class methodsFor: 'instance creation' stamp: ''!
with: methods
	^self new 
		methods: methods! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testIsEmptyFromEmptyMethodScope
	"Constant query do not depends on scope. So we redefine this method"
	<expectedFailure>
	super testIsEmptyFromEmptyMethodScope! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testComparison
	self assert: (ClyConstantMethodQuery with: {(self class >> #method1)}) equals: (ClyConstantMethodQuery with: {(self class >> #method1)}).

	self assert: (ClyConstantMethodQuery with: {(self class >> #method1)}) hash equals: (ClyConstantMethodQuery with: {(self class >> #method1)}) hash.

	self deny: (ClyConstantMethodQuery with: {(self class >> #method1)}) equals: (ClyConstantMethodQuery with: {(self class >> #method2)})! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testFromWrongClassScope

	self queryFromScope: ClyClassScope of: self class superclass.
	
	self assert: resultItems isEmpty! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testEmptyWhenNoMethods
	query scope: (ClyMethodScope of: (self class >> #method1) in: environment).
		
	query methods: #().
	
	self assert: query checkEmptyResult! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testNotEmptyFromEmptyMethodScope
	query scope: (ClyMethodScope emptyIn: environment).
	
	self deny: query checkEmptyResult! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testConvertingToSemiAsyncQuery
	| convertedQuery |
	convertedQuery := query semiAsync.

	self assert: convertedQuery identicalTo: query! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	self deny: query checkEmptyResult! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testConvertingToAsyncQuery
	| convertedQuery |
	convertedQuery := query async.

	self assert: convertedQuery identicalTo: query! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testFromSystemScope

	self queryFromScope: ClySystemEnvironmentScope of: ClySystemEnvironment currentImage.
	
	self assert: resultItems size equals: 2.	
	self assert: (resultItems identityIncludes: self class >> #method1).
	self assert: (resultItems identityIncludes: self class >> #method2)! !

!ClyConstantMethodQueryTest methodsFor: 'running' stamp: ''!
method1
	^#method1! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testFromPackageScope

	self queryFromScope: ClyPackageScope of: self class package.
	
	self assert: resultItems size equals: 2.	
	self assert: (resultItems identityIncludes: self class >> #method1).
	self assert: (resultItems identityIncludes: self class >> #method2)! !

!ClyConstantMethodQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ (ClyConstantMethodQuery
		with: {self class >> #method1. self class >> #method2})
			scope: (ClyExampleScope emptyIn: environment)! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testSelectsMethodOnWhichItIsBased

	self assert: (query selectsMethod: self class >> #method1)! !

!ClyConstantMethodQueryTest methodsFor: 'running' stamp: ''!
method2
	^#method2! !

!ClyConstantMethodQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsMethodOnWhichItIsBased

	self deny: (query selectsMethod: Point >> #x)! !

!ClyConstantQuery commentStamp: ''!
I am special kind of typed query which always return constant collection of items independently of scope.
Items are supposed to be homogeneous collection (a kind of same class).

To create my instance use following methods: 

	ClyConstantQuery returning: { Object. String }.
	ClyConstantQuery returning: { Object. String } as: (ClySortedQueryResult using: ClySortByNameFunction ascending).
	ClyConstantQuery returning: { Object. String } from: aScope 
	
 
Internal Representation and Key Implementation Points.

    Instance Variables
	resultItems:		<Collection>
!
!ClyConstantQuery methodsFor: 'converting' stamp: ''!
semiAsync
	^self! !

!ClyConstantQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
		
	^ resultItems = anObject resultItems! !

!ClyConstantQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: resultItems hash! !

!ClyConstantQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin! !

!ClyConstantQuery methodsFor: 'testing' stamp: ''!
retrievesItem: anObject
	^resultItems includes: anObject! !

!ClyConstantQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	^false! !

!ClyConstantQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	aQueryResult fillWith: resultItems! !

!ClyConstantQuery methodsFor: 'printing' stamp: ''!
description

	^', ' join: (resultItems collect: [:each | each printAsConstantQueryItem])! !

!ClyConstantQuery methodsFor: 'printing' stamp: ''!
fullDescription
	"Constant query do not depends on scope. And in many cases it is default empty scope.
	So scope here is useless and confusing information. And we just return simple description"
	^self description! !

!ClyConstantQuery methodsFor: 'execution' stamp: ''!
execute
	| result |
	result := self prepareNewResult.
	result initializeItems.
	self buildResult: result.
	^result! !

!ClyConstantQuery methodsFor: 'accessing' stamp: ''!
resultItems: anObject
	resultItems := anObject! !

!ClyConstantQuery methodsFor: 'testing' stamp: ''!
retrievesItemsOfType: itemTypeClass
	^resultItems anySatisfy: [ :each | 
		each calypsoEnvironmentType = itemTypeClass  ]! !

!ClyConstantQuery methodsFor: 'accessing' stamp: ''!
resultItems
	^ resultItems! !

!ClyConstantQuery methodsFor: 'converting' stamp: ''!
withMetaLevelScope: aScopeClass 
	^self withScope: (scope withMetaLevel: aScopeClass)! !

!ClyConstantQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	^resultItems isEmpty! !

!ClyConstantQuery methodsFor: 'converting' stamp: ''!
async
	^self! !

!ClyConstantQuery class methodsFor: 'instance creation' stamp: ''!
returning: objects from: aScope
	^(self from: aScope)
		resultItems: objects! !

!ClyConstantQuery class methodsFor: 'instance creation' stamp: ''!
returning: objects
	^self new 
		resultItems: objects! !

!ClyConstantQuery class methodsFor: 'instance creation' stamp: ''!
returning: objects as: aQueryResult
	^self new 
		resultItems: objects;
		requiredResult: aQueryResult! !

!ClyConstantQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	self shouldNotImplement! !

!ClyConstantQueryTest methodsFor: 'tests' stamp: ''!
testCheckingForEmptyResult

	| empty notEmpty |
	empty := self createQuery: #().
	notEmpty := self createQuery.
	self assert: empty checkEmptyResult;
		deny: notEmpty checkEmptyResult.! !

!ClyConstantQueryTest methodsFor: 'tests' stamp: ''!
testConvertingToSemiAsyncQuery
	| convertedQuery |
	convertedQuery := query semiAsync.

	self assert: convertedQuery identicalTo: query! !

!ClyConstantQueryTest methodsFor: 'running' stamp: ''!
createQuery: aCollection

	^ ClyConstantQuery
		  returning: aCollection
		  from: (ClyExampleScope emptyIn: environment)! !

!ClyConstantQueryTest methodsFor: 'tests' stamp: ''!
testConvertingToAsyncQuery
	| convertedQuery |
	convertedQuery := query async.

	self assert: convertedQuery identicalTo: query! !

!ClyConstantQueryTest methodsFor: 'tests' stamp: ''!
testExecution

	self executeQuery.
	
	self assert: resultItems asArray equals: query resultItems! !

!ClyConstantQueryTest methodsFor: 'running' stamp: ''!
createQuery

	^ self createQuery: #( #item1 #item2 )! !

!ClyConstantQueryTest methodsFor: 'tests' stamp: ''!
testComparisonToSimilarQueryWhichReturningDifferentObjects
	| query2 |
	query2 := self createQuery.
	query2 resultItems: #(anotherResult).

	self deny: query equals: query2! !

!ClyContextSelectionStrategyAnnotation commentStamp: ''!
I describe the way the context of browser selection should be actived

!
!ClyContextSelectionStrategyAnnotation methodsFor: 'context creation' stamp: ''!
createBrowserContextOfSingleItem: aDataSourceItem for: aBrowser

	^annotatedClass of: {aDataSourceItem} for: aBrowser! !

!ClyContextSelectionStrategyAnnotation methodsFor: 'testing' stamp: ''!
shouldBeAppliedFor: aSelectionOrItem

	targetItemType ifNil: [ 
	"if no scope specified strategy will be applied to any selection independently from it kind"	
		^true ].
	
	^aSelectionOrItem isBasedOnItemType: targetItemType! !

!ClyContextSelectionStrategyAnnotation methodsFor: 'context creation' stamp: ''!
createBrowserContextOf: aSelection for: aBrowser

	^annotatedClass ofSelection: aSelection for: aBrowser! !

!ClyContextSelectionStrategyAnnotation methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream 
		nextPut: $(;
		nextPutAll: annotatedClass name.
	targetItemType ifNotNil: [ 
		aStream
			nextPutAll: '; ';
			nextPutAll: targetItemType name].
	aStream
		nextPut: $)! !

!ClyContextSelectionStrategyAnnotation methodsFor: 'accessing' stamp: ''!
targetItemType
	^ targetItemType! !

!ClyContextSelectionStrategyAnnotation methodsFor: 'accessing' stamp: ''!
targetItemType: aClass
	targetItemType := aClass! !

!ClyContextSelectionStrategyAnnotation class methodsFor: 'query' stamp: ''!
selectContextOf: aSelection for: aBrowser

	self activeInstancesInContext: aBrowser do: [ :strategy | 
		(strategy shouldBeAppliedFor: aSelection) ifTrue: [ 
			^strategy createBrowserContextOf: aSelection for: aBrowser]].
	
	^ClyUnknownBrowserContext for: aBrowser! !

!ClyContextSelectionStrategyAnnotation class methodsFor: 'query' stamp: ''!
selectContextOfSingleItem: aDataSourceItem for: aBrowser

	self activeInstancesInContext: aBrowser do: [ :strategy | 
		(strategy shouldBeAppliedFor: aDataSourceItem) ifTrue: [ 
			^strategy createBrowserContextOfSingleItem: aDataSourceItem for: aBrowser]].
	
	^ClyUnknownBrowserContext for: aBrowser! !

!ClyContextSelectionStrategyAnnotation class methodsFor: 'instance creation' stamp: ''!
for: aBrowserClass selectionType: aScopeClass
	^(self for: aBrowserClass)
		targetItemType: aScopeClass! !

!ClyConvertMethodGroupToTagCommand commentStamp: ''!
I am a command to convert given method groups to method tag.
I perform kind of "Move to protocol" operation for all contained methods
 
Internal Representation and Key Implementation Points.

    Instance Variables
	tagName:		<Symbol>!
!ClyConvertMethodGroupToTagCommand methodsFor: 'accessing' stamp: ''!
tagName
	^ tagName! !

!ClyConvertMethodGroupToTagCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	aToolContext showMethodTag: tagName! !

!ClyConvertMethodGroupToTagCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName

	^'Convert to protocol'! !

!ClyConvertMethodGroupToTagCommand methodsFor: 'execution' stamp: ''!
execute
	
	methodGroups do: [ :each | each convertToMethodTag: tagName]! !

!ClyConvertMethodGroupToTagCommand methodsFor: 'accessing' stamp: ''!
tagName: anObject
	tagName := anObject! !

!ClyConvertMethodGroupToTagCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	tagName := aToolContext requestSingleMethodTag: 'New protocol name'! !

!ClyConvertMethodGroupToTagCommand class methodsFor: 'activation' stamp: ''!
fullBrowserContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: ClyMethodGroup asCalypsoItemContext! !

!ClyConvertMethodGroupToTagCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isMethodTagSelected not! !

!ClyCreateClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'New class'! !

!ClyCreateClassCommand methodsFor: 'command execution' stamp: ''!
execute
	| classDefinition p resultTrait |
	p := package name.
	classTag ifNotNil: [ p := p , '-' , classTag ].
	classDefinition := ClassDefinitionPrinter new classDefinitionTemplateInPackage: p.
	classDefinition := UIManager default
		                   multiLineRequest: 'Define class definition:'
		                   initialAnswer: classDefinition
		                   answerHeight: 250.
	classDefinition isEmptyOrNil ifTrue: [ ^ self ].
	resultTrait := browser
		               compileANewClassFrom: classDefinition
		               notifying: nil
		               startingFrom: nil.
	resultTrait ifNotNil: [ browser selectClass: resultTrait ]! !

!ClyCreateClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aBrowserContext
	super prepareFullExecutionInContext: aBrowserContext.
	
	package := aBrowserContext lastSelectedPackage.
	aBrowserContext isClassTagSelected ifTrue: [ 
		classTag := aBrowserContext lastSelectedClassTag]! !

!ClyCreateClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#class! !

!ClyCreateClassCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 4 for: ClyFullBrowserClassContext! !

!ClyCreateClassCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext
	(super canBeExecutedInContext: aBrowserContext) ifFalse: [ ^false ].
	
	^aBrowserContext isPackageSelected! !

!ClyCreateTestCaseCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'New test class'! !

!ClyCreateTestCaseCommand methodsFor: 'command execution' stamp: ''!
execute
	| classDefinition p resultClass |
	p := package name.
	classTag ifNotNil: [ p := p , '-' , classTag ].
	classDefinition := ClassDefinitionPrinter new testClassDefinitionTemplateInPackage: p.
	classDefinition := UIManager default
		                   multiLineRequest: 'Define test class:'
		                   initialAnswer: classDefinition
		                   answerHeight: 250.
	classDefinition isEmptyOrNil ifTrue: [ ^ self ].
	resultClass := browser
		               compileANewClassFrom: classDefinition
		               notifying: nil
		               startingFrom: nil.
	resultClass ifNotNil: [ browser selectClass: resultClass ]! !

!ClyCreateTestCaseCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aBrowserContext
	super prepareFullExecutionInContext: aBrowserContext.
	
	package := aBrowserContext lastSelectedPackage.
	aBrowserContext isClassTagSelected ifTrue: [ 
		classTag := aBrowserContext lastSelectedClassTag]! !

!ClyCreateTestCaseCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#testGreen! !

!ClyCreateTestCaseCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 5 for: ClyFullBrowserClassContext! !

!ClyCreateTestCaseCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext
	(super canBeExecutedInContext: aBrowserContext) ifFalse: [ ^false ].
	
	^aBrowserContext isPackageSelected! !

!ClyCreateTraitCommand commentStamp: ''!
I am a command to create new trait in selected package.
I am a copy of command from Nautilus.
I just ask user to type trait definition in dialog window. Then I compile trait by evaluation of given definition.

Internal Representation and Key Implementation Points.

    Instance Variables
	package:		<RPackage>
	classTag:		<Symcol>
!
!ClyCreateTraitCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'New trait'! !

!ClyCreateTraitCommand methodsFor: 'command execution' stamp: ''!
execute
	| traitDefinition category resultTrait |
	category := package name.
	classTag ifNotNil: [ category := category , '-' , classTag ].
	traitDefinition := ClassDefinitionPrinter new traitDefinitionTemplateInPackage: category.
	traitDefinition := UIManager default
		                   multiLineRequest: 'Define trait:'
		                   initialAnswer: traitDefinition
		                   answerHeight: 250.
	traitDefinition isEmptyOrNil ifTrue: [ ^ self ].
	resultTrait := browser
		               compileANewClassFrom: traitDefinition
		               notifying: nil
		               startingFrom: nil.
	resultTrait ifNotNil: [ browser selectClass: resultTrait ]! !

!ClyCreateTraitCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aBrowserContext
	super prepareFullExecutionInContext: aBrowserContext.
	
	package := aBrowserContext lastSelectedPackage.
	aBrowserContext isClassTagSelected ifTrue: [ 
		classTag := aBrowserContext lastSelectedClassTag]! !

!ClyCreateTraitCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#trait! !

!ClyCreateTraitCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 3 for: ClyFullBrowserClassContext! !

!ClyCreateTraitCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext
	(super canBeExecutedInContext: aBrowserContext) ifFalse: [ ^false ].
	
	^aBrowserContext isPackageSelected! !

!ClyCriticBrowserPlugin commentStamp: ''!
I am browser plugin.
I decorate browser tools with critiques information about their subjects.
This information is shown in bottom pane of the tool as a table of related critiques!
!ClyCriticBrowserPlugin methodsFor: 'accessing' stamp: ''!
priority
	^SmallInteger maxVal! !

!ClyCriticBrowserPlugin methodsFor: 'testing' stamp: ''!
isSlow
	^true! !

!ClyCriticBrowserPlugin methodsFor: 'tools installing' stamp: ''!
decorateTool: aBrowserTool

	aBrowserTool supportsCriticDecoration ifFalse: [ ^self ].
		
	aBrowserTool addDecorator: ClyCriticDecorator new.! !

!ClyCriticContext commentStamp: ''!
I am a context of critique decorators tool representing selected critiques

 
Internal Representation and Key Implementation Points.

    Instance Variables
	analyzedObject:		<Object>!
!ClyCriticContext methodsFor: 'command execution' stamp: ''!
executeCommand: aCommand by: aCommandActivator

	aCommand isComplexRefactoring ifTrue: [
		aCommand confirmRefactoringInContext: self by: aCommandActivator].
	
	aCommand execute! !

!ClyCriticContext methodsFor: 'refactoring support' stamp: ''!
refactoringScopes
	^self browser allNavigationScopes! !

!ClyCriticContext methodsFor: 'accessing' stamp: ''!
browser
	^tool browser! !

!ClyCriticContext methodsFor: 'accessing' stamp: ''!
selectedCritique
	^self lastSelectedItem actualObject! !

!ClyCriticContext methodsFor: 'accessing' stamp: ''!
analyzedObject
	^ tool analyzedObject! !

!ClyCriticContext class methodsFor: 'selection strategy' stamp: ''!
selectionStrategy
	<classAnnotation>
	
	^ClyContextSelectionStrategyAnnotation for: ClyCriticDecorator! !

!ClyCriticDecorator commentStamp: ''!
I am a browser too decorator which adds extra panel with table of critiques related to the model of tool.
I show critiques of methods, classes and packages.

During tool decoration I create query view (criticView) on ClyAllBasisCritiques query in async mode.
While query is executed the criticView is hidden and special animation indicates analysis process in the status bar of the tool.
When query is complete and include any critique I show criticView panel to the user. 
 
Internal Representation and Key Implementation Points.

    Instance Variables
	analysisScope:		<ClyScope>
	criticView:		<ClyQueryView>
	originalToolPanel:		<Morph>
	progressMorph:		<ClyActivityAnimationIconMorph>!
!ClyCriticDecorator methodsFor: 'controlling' stamp: ''!
itemsChanged
	self refreshCritiques! !

!ClyCriticDecorator methodsFor: 'controlling' stamp: ''!
hideCritiques
 
	criticView delete.
	browserTool removePaneSplitters.
	originalToolPanel layoutFrame bottomFraction: 1; bottomOffset: 0.! !

!ClyCriticDecorator methodsFor: 'decoration' stamp: ''!
decorateTool
	| newScope |	
	criticView ifNil: [ self prepare].	
	newScope := browserTool criticAnalysisScope.
	(analysisScope isNil or: [ newScope basisObjects ~= analysisScope basisObjects]) ifTrue: [ 
		analysisScope := newScope.
		self updateCriticView].
	
	self refreshCritiques! !

!ClyCriticDecorator methodsFor: 'decoration' stamp: ''!
adoptBrowserToolLayout

	originalToolPanel := PanelMorph new.
	originalToolPanel 
		name: 'original tool elements';
		color: Color transparent;		
		borderWidth: 0;
		layoutPolicy: browserTool layoutPolicy.
	browserTool submorphs do: [ :each | originalToolPanel addMorphBack: each ].
	browserTool changeProportionalLayout.
	browserTool addMorph: originalToolPanel fullFrame: (0@0 corner: 1@1) asLayoutFrame! !

!ClyCriticDecorator methodsFor: 'controlling' stamp: ''!
changeStateBy: aBlock
	aBlock value! !

!ClyCriticDecorator methodsFor: 'controlling' stamp: ''!
showCritiques
	criticView owner ifNotNil: [ ^self ].
	
	originalToolPanel layoutFrame bottomFraction: 0.8.
	browserTool addMorph: criticView fullFrame: ((0@0.8 corner: 1@1) asLayoutFrame).
	browserTool addPaneSplitters! !

!ClyCriticDecorator methodsFor: 'decoration' stamp: ''!
prepare
	self adoptBrowserToolLayout.
	self createCriticView.
	progressMorph := ClyActivityAnimationIconMorph label: 'critiques analysis'! !

!ClyCriticDecorator methodsFor: 'controlling' stamp: ''!
refreshCritiques

	"Big literal methods (who are containing big strings ot byte arrays) should not
	 run critiques (not needed, and very time consuming)"
	(self analyzedObject isCompiledMethod 
		and: [ self analyzedObject isBigLiteralMethod ])
		ifTrue: [ ^ self ].

	browserTool decorateByCritic: self.
	
	criticView dataSource isEmpty 
		ifTrue: [ self hideCritiques ]
		ifFalse: [ self showCritiques ].
	(criticView dataSource hasMetaProperty: ClyBackgroundProcessingTag)
		ifFalse: [ progressMorph delete. browserTool statusBar update ]
		ifTrue: [ browserTool statusBar addContextItem: progressMorph  ]! !

!ClyCriticDecorator methodsFor: 'controlling' stamp: ''!
updateCriticView
	
	| critiqueQuery |
	
	critiqueQuery := (ClyAllBasisCritiqueQuery from: analysisScope) async.
	criticView showQuery: critiqueQuery! !

!ClyCriticDecorator methodsFor: 'decoration' stamp: ''!
buildCriticalTextSegmentsFor: anObject

	| interval segment severity |
	^criticView dataSource allElements
		select: [ :critique | critique hasProperty: ClySourceNodeCritiqueIntervalProperty ]
		thenCollect: [ :critique |
			interval := critique getProperty: ClySourceNodeCritiqueIntervalProperty.		
			segment := ClyCriticalTextSegmentMorph
				from: interval start
				to: interval stop + 1.
			severity := critique getProperty: ClyCritiqueSeverityProperty.
			segment
				label: critique name;
				icon: (browserTool iconNamed: severity iconName);
				color: severity color;
				critique: critique actualObject;
				entity: anObject;
				yourself]! !

!ClyCriticDecorator methodsFor: 'controlling' stamp: ''!
toolWasRemoved
	
	criticView ifNotNil: [ criticView closeDataSource ]! !

!ClyCriticDecorator methodsFor: 'decoration' stamp: ''!
createCriticView

	criticView := ClyQueryViewMorph for: self.
	criticView 
		name: 'critiques table';
		hResizing: #spaceFill;
		vResizing: #rigid;
		borderWidth: 4;
		borderColor: browserTool containerTab backgroundColor.
	criticView height: 50! !

!ClyCriticDecorator methodsFor: 'controlling' stamp: ''!
ignoreNavigationDuring: aBlock 
	aBlock value! !

!ClyCriticDecorator methodsFor: 'controlling' stamp: ''!
changeStateOf: aQueryView by: aBlock
	aBlock value! !

!ClyCriticDecorator methodsFor: 'accessing' stamp: ''!
criticView
	^criticView! !

!ClyCriticDecorator methodsFor: 'accessing' stamp: ''!
analyzedObject
	^analysisScope basisObjects anyOne! !

!ClyCriticEnvironmentPlugin commentStamp: ''!
I plug environment with information about critiques:

1) I decorate critiques with various properties 
2) I provide "critiques" method group
 
I allow disable method group using class side methods: 

- ClyCriticEnvironmentPlugin disableMethodGroup.
- ClyCriticEnvironmentPlugin enableMethodGroup.

Internal Representation and Key Implementation Points.

    Instance Variables
	providesMethodGroup:		<Boolean>!
!ClyCriticEnvironmentPlugin methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	providesMethodGroup := self class providesMethodGroupByDefault! !

!ClyCriticEnvironmentPlugin methodsFor: 'method groups' stamp: ''!
collectMethodGroupProviders
	providesMethodGroup ifFalse: [ ^#() ].
	
	^{ClyCriticMethodGroupProvider new}! !

!ClyCriticEnvironmentPlugin methodsFor: 'accessing' stamp: ''!
providesMethodGroup: anObject
	providesMethodGroup := anObject! !

!ClyCriticEnvironmentPlugin methodsFor: 'accessing' stamp: ''!
providesMethodGroup
	^ providesMethodGroup! !

!ClyCriticEnvironmentPlugin class methodsFor: 'settings' stamp: ''!
isEnabled: aBoolean
	aBoolean 
		ifTrue: [ self enableMethodGroup ]
		ifFalse: [ self disableMethodGroup ]! !

!ClyCriticEnvironmentPlugin class methodsFor: 'accessing' stamp: ''!
disableMethodGroup
	providesMethodGroupByDefault := false.
	(ClyNavigationEnvironment currentImage getPlugin: self ifAbsent: [^self])
		providesMethodGroup: false! !

!ClyCriticEnvironmentPlugin class methodsFor: 'settings' stamp: ''!
isEnabled
	^self providesMethodGroupByDefault! !

!ClyCriticEnvironmentPlugin class methodsFor: 'accessing' stamp: ''!
enableMethodGroup
	providesMethodGroupByDefault := true.
	(ClyNavigationEnvironment currentImage getPlugin: self ifAbsent: [^self])
		providesMethodGroup: true! !

!ClyCriticEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isSlow
	^true! !

!ClyCriticEnvironmentPlugin class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #isEnabled)
		parent: #Calypso;
		default: false;
		label: 'Show critiques method group?';
		description: 'If true, there will be special method group which will analyze all methods of selected classes in the browser. Analysis is performed in the background and should not affect general performance of the system';
		target: self! !

!ClyCriticEnvironmentPlugin class methodsFor: 'accessing' stamp: ''!
providesMethodGroupByDefault
	^providesMethodGroupByDefault ifNil: [ false ]! !

!ClyCriticMethodGroupProvider commentStamp: ''!
I provide "critiques" method group which include all problem methods!
!ClyCriticMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^(ClyAllProblemMethodQuery from: aClassScope) async! !

!ClyCriticMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	
	^ClyAllCritiquesMethodGroup 
		withMethods: aMethodQuery actualQuery from: aClassScope! !

!ClyCriticMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyCriticMethodGroupProvider! !

!ClyCriticMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup

	^ClyClassWithProblemMethods! !

!ClyCriticalTextSegmentMorph commentStamp: ''!
I am a slight modification of the rubric text segment morph which creates custom menu items for displaying critiques!
!ClyCriticalTextSegmentMorph methodsFor: 'actions' stamp: ''!
addItemToMenu: aMenu
	| listItem |
	listItem := ClyCritiqueMenuItemMorph new
		layoutPolicy: TableLayout new;
		listDirection: #leftToRight;
		cellPositioning: #center;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		cellInset: 5;
		color: Color transparent;
		"layoutInset: (Margin left: 0 top: 0 right: 10 bottom: 0);"
			yourself.
	listItem addMorphBack: (ImageMorph withForm: critique icon).
	listItem addMorphBack: critique title asStringMorph.
	critique actions
		do: [ :action | 
			listItem
				addMorphBack:
					(IconicButtonMorph new
						target: action;
						labelGraphic: action icon;
						actionSelector: #actOnCritic:ofEntity:;
						arguments:
							{critique.
							entity};
						color: Color transparent;
						helpText: action description;
						extent: 16 @ 16;
						borderWidth: 0;
						yourself) ].
	^ aMenu addMenuItem: listItem! !

!ClyCriticalTextSegmentMorph methodsFor: 'accessing' stamp: ''!
critique
	^ critique! !

!ClyCriticalTextSegmentMorph methodsFor: 'accessing' stamp: ''!
entity
	^ entity! !

!ClyCriticalTextSegmentMorph methodsFor: 'accessing' stamp: ''!
critique: anObject
	critique := anObject! !

!ClyCriticalTextSegmentMorph methodsFor: 'accessing' stamp: ''!
entity: anObject
	entity := anObject! !

!ClyCritiqueCommand commentStamp: ''!
I am a root of commands hierarhcy which perform various set of operations with critiques.

My subclasses are shown as icons in critiques tables.

Internal Representation and Key Implementation Points.

    Instance Variables
	analyzedObject:		<Object>
	critique:		<Object>!
!ClyCritiqueCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aCriticContext
	super readParametersFromContext: aCriticContext.
	
	critique := aCriticContext selectedCritique.
	analyzedObject := aCriticContext analyzedObject! !

!ClyCritiqueCommand methodsFor: 'table decoration' stamp: ''!
decorateTableCell: anItemCellMorph with: aMorph

	aMorph setBalloonText: self description.
	anItemCellMorph addExtraTool: aMorph! !

!ClyCritiqueCommand methodsFor: 'accessing' stamp: ''!
critique
	^ critique! !

!ClyCritiqueCommand methodsFor: 'table decoration' stamp: ''!
description
	^''! !

!ClyCritiqueCommand methodsFor: 'accessing' stamp: ''!
analyzedObject: anObject
	analyzedObject := anObject! !

!ClyCritiqueCommand methodsFor: 'accessing' stamp: ''!
critique: anObject
	critique := anObject! !

!ClyCritiqueCommand methodsFor: 'accessing' stamp: ''!
analyzedObject
	^ analyzedObject! !

!ClyCritiqueCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyCritiqueCommand! !

!ClyCritiqueCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aCriticContext
	
	^aCriticContext hasSelectedItems and: [
		(aCriticContext lastSelectedItem isMarkedWith: ClyBackgroundProcessingTag) not]! !

!ClyCritiqueCommand class methodsFor: 'activation' stamp: ''!
criticTableIconActivation
	<classAnnotation>
	
	^ClyTableIconCommandActivation for: ReAbstractCritique asCalypsoItemContext! !

!ClyCritiqueFixableTag commentStamp: ''!
I mark critiques which can be fixed by refactoring!
!ClyCritiqueMenuItemMorph commentStamp: ''!
I simulate the functionality of MenuItemMorph while providing more sophisticated visualization for rubric annotations !
!ClyCritiqueMenuItemMorph methodsFor: 'accessing' stamp: ''!
isEnabled

	^ true! !

!ClyCritiqueMenuItemMorph methodsFor: 'selecting' stamp: ''!
select: sth! !

!ClyCritiqueMenuItemMorph methodsFor: 'accessing' stamp: ''!
hasSubMenu

	^ false! !

!ClyCritiqueMenuItemMorph methodsFor: 'selecting' stamp: ''!
deselect: sth! !

!ClyCritiqueMenuItemMorph methodsFor: 'testing' stamp: ''!
isMenuItemMorph
	^ true! !

!ClyCritiqueMenuItemMorph methodsFor: 'events' stamp: ''!
activateSubmenu: evt

	^ false! !

!ClyCritiqueMenuItemMorph methodsFor: 'accessing' stamp: ''!
hasIconOrMarker
	^ true! !

!ClyCritiqueQuery commentStamp: ''!
I am a root of critique queries hierarchy.
My subclasses are supposed to return critiques instances.

I implement system changes processing and metadata collection logic.!
!ClyCritiqueQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin
	anEnvironmentPlugin resolveMetadataOfCritiques: aQueryResult! !

!ClyCritiqueQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	"We can not compute affect on critiques by any kind system change
	because critiques are composed by some external system
	So without real knowledge we can only update critiqies after any system change.
	It can of course lead to very poor system performance because critic computation is slow process
	and triggering it after every system change can slow down system a lot.
	So instead we just reset given aQueryResult silently. So users should update views manually"
	aSystemAnnouncement affectsCritiques ifFalse: [ ^false ].
	
	aQueryResult forceLazyRebuild.	
	^false "and we return false to prevent result observers to be notified"! !

!ClyCritiqueQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	^ReAbstractCritique! !

!ClyCritiqueQueryTest methodsFor: 'examples' stamp: ''!
scopeWithCritiques
	^ ClyMethodScope of: self methodWithCritiques in: environment! !

!ClyCritiqueQueryTest methodsFor: 'examples' stamp: ''!
scopeWithoutCritiques
	^ ClyMethodScope of: self methodWithoutCritiques in: environment! !

!ClyCritiqueQueryTest methodsFor: 'examples' stamp: ''!
methodWithCritiques
	^ ClyClassWithProblemMethods >> #methodWithHalt! !

!ClyCritiqueQueryTest methodsFor: 'examples' stamp: ''!
methodWithoutCritiques
	^ ClyClassWithProblemMethods >> #methodWithoutCritiques! !

!ClyCritiqueQueryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyCritiqueQueryTest! !

!ClyCritiqueSeverityProperty commentStamp: ''!
I represent first class severity levels of critiques.
There are three of them: information, warning, error. 

You can get me from critique using: 
	
	ClyCrituqueSeverity of: aCritiques.
	
I provide name and color for the UI. And I allow to sort critiques by severity using my method #isMoreImportantThan:. 

Internal Representation and Key Implementation Points.

    Instance Variables
	color:		<Color>
	name:		<String>!
!ClyCritiqueSeverityProperty methodsFor: 'accessing' stamp: ''!
color: anObject
	color := anObject! !

!ClyCritiqueSeverityProperty methodsFor: 'accessing' stamp: ''!
iconName
	^ 'small', name capitalized, 'Icon'! !

!ClyCritiqueSeverityProperty methodsFor: 'accessing' stamp: ''!
level
	^ #(information warning error) indexOf: name! !

!ClyCritiqueSeverityProperty methodsFor: 'testing' stamp: ''!
isMoreImportantThan: anotherSeverity

	^self level > anotherSeverity level! !

!ClyCritiqueSeverityProperty methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!ClyCritiqueSeverityProperty methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!ClyCritiqueSeverityProperty methodsFor: 'accessing' stamp: ''!
color
	^ color! !

!ClyCritiqueSeverityProperty class methodsFor: 'instance creation' stamp: ''!
of: aCritique

	^self new 
		name: aCritique rule severity;
		color: aCritique color! !

!ClyCritiqueSeverityProperty class methodsFor: 'instance creation' stamp: ''!
default
	^self new 
		name: #information;
		color: Color blue! !

!ClyCritiquesTableDecorator commentStamp: ''!
I decorate table of critiques with severity level icon!
!ClyCritiquesTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem

	anItemCellMorph color: (aDataSourceItem position odd  
		ifTrue:  [ Smalltalk ui theme backgroundColor ]
		ifFalse: [ Smalltalk ui theme lightBackgroundColor ]).! !

!ClyCritiquesTableDecorator class methodsFor: 'decoration' stamp: ''!
decorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ReAbstractCritique asCalypsoItemContext! !

!ClyCritiquesTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
		
	anItemCellMorph definitionIcon: (aDataSourceItem getProperty: ClyCritiqueSeverityProperty) iconName! !

!ClyCritiquesTableDecorator class methodsFor: 'decoration' stamp: ''!
browserPluginClass
	^ClyCriticBrowserPlugin! !

!ClyCursorPositionLabelMorph commentStamp: ''!
I print position of cursor in the text editor.
Look at #printCursorPosition method for details.
  
Internal Representation and Key Implementation Points.

    Instance Variables
	labelMorph:		<StringMorph>!
!ClyCursorPositionLabelMorph methodsFor: 'controlling' stamp: ''!
detachFromTextMorph
	super detachFromTextMorph.
	
	self textArea announcer unsubscribe: self! !

!ClyCursorPositionLabelMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.	
	self setBalloonText: 'Current line number/Total line number [Current character number]'.
	labelMorph := '' asStringMorph.
	self addMorph: labelMorph! !

!ClyCursorPositionLabelMorph methodsFor: 'updating' stamp: ''!
printCursorPosition
	| result textArea |
	textArea := self textArea.
	textArea selectionStart ifNil: [ ^ '' ].
	textArea paragraph lines ifNil: [ ^ '' ].
	result := self printTextLinePositionOf: textArea selectionStart.
	textArea selectionStop ~= textArea selectionStart
		ifTrue: [ result := result , ' -- ' , (self printTextLinePositionOf: textArea selectionStop) ].
	^result! !

!ClyCursorPositionLabelMorph methodsFor: 'updating' stamp: ''!
updateContents

	labelMorph contents: self printCursorPosition! !

!ClyCursorPositionLabelMorph methodsFor: 'controlling' stamp: ''!
attachToTextMorph
	super attachToTextMorph.
	
	self textArea announcer when: RubSelectionChanged send: #updateContents to: self.
	self updateContents! !

!ClyCursorPositionLabelMorph methodsFor: 'updating' stamp: ''!
printTextLinePositionOf: aCharacterBlock
	| result textLine linePosition |
	textLine := aCharacterBlock textLine.
	linePosition := aCharacterBlock stringIndex - textLine first + 1.
	result := textLine lineNumber printString , '/' , self textArea lines size printString
		, ' [', linePosition printString, ']'.
	^ result! !

!ClyDataSource commentStamp: ''!
I am a root of fast table data source classes which adopt Calypso query result to FastTable interface.

My subclasses represent concrete kind of underlying tree structure: all items can be initialy expanded or initialy collapsed.
To create my instances use following expression:
	dataSource := ClyCollapsedDataSource on: aQuery.
It just creates instance of data source without executing given query.
Query is opened by ClyQueryView when you pass data source to it: 
	queryView dataSource: aDataSource 
It ask data source to open for itself:
	dataSource openOn: queryView
It executes the query and retrieves cursor to access result items in optimized way.
Also it subscribes on result changes. So the query view is updated when result is changed.
When data source is not needed anymore it should be closed:
	dataSource close

I represent actual elements of fast table by ClyDataSourceItem.
	dataSource elementAt: 1 "=>aDataSourceItem"  
Management of children is implemented by my subclasses. According to type of tree structure they implement following methods: 
- numberOfRows
- elementAt: rowIndex
- globalPositionOf: childDataSourceItem
- countChildrenOf: aDataSourceItem
- isItemHasChildren: aDataSourceItem
- definesChildren
- collapse: aDataSourceItem
- expand: aDataSourceItem
- isExpanded: aDataSourceItem
- updateExpandingItems
Children are represented by data sources too. My parentItem and depth variables point to the position in full tree.
You can ask global position in the tree using: 
	dataSource globalPositionOf: childDataSourceItem
It should return global row index in the table of given children item.

I implement query interface to find items
- findItemsWhere: conditionBlock 
- findItemsWith: actualObjects 
- findItemsSimilarTo: dataSourceItems

My instances are subscribed on ClyEnvironmentChanged event which happen when underlying query result is changed.
In case of the event I update my children structure and refresh table:
- itemsChanged
Update is performed in special logic to prevent multiple updates during complex system changes.
First I check if I am already dirty. In that case I do nothing.
Otherwise I mark myself as dirty and defer actual update using UpdateScheduler which performs update in low priority process when there is a time. So if complex system change is initiated from UI operation (which is common scenario) I will be updated only when full operation will be finished. And it will be always single update independently how many changes operation produces with the system. 
For details look at ClyDataSourceUpdateScheduler comments.

Internal Representation and Key Implementation Points.

    Instance Variables
	query:		<ClyQuery>
	queryView:		<ClyQueryView>
	itemCursor:		<ClyBrowserQueryCursor>
	parentItem:		<ClyDataSourceItem>
	depth:		<Integer>
	dirty: <Boolean>
	lastFilteredDataSource: <ClyDataSource>!
!ClyDataSource methodsFor: 'testing' stamp: ''!
isParentExpanded
	parentItem ifNil: [ ^true ].
	^parentItem isExpanded! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
findDataSourceSameAs: aDataSource ifNone: noneBlock
	^(self isSameAs: aDataSource) 
		ifTrue: [ ^self ]
		ifFalse: noneBlock! !

!ClyDataSource methodsFor: 'drag and drop' stamp: ''!
transferFor: dataSourceItems from: aMorph
	| selection passenger |
	selection := dataSourceItems first rootDataSource 
		newSelectionWith: dataSourceItems. "to get selection bound to last selected item. In FastTable last selected item is first in the list"

	passenger := queryView createDragPassengerFor: selection.
	
	^super transferFor: passenger from: aMorph! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
queryView
	^ queryView! !

!ClyDataSource methodsFor: 'controlling' stamp: ''!
openOn: aQueryView
	
	self isClosed ifFalse: [ self close ].

	queryView := aQueryView.	
	table := aQueryView table.
	itemCursor := query openBrowserCursorFor: self.
	dirty := false! !

!ClyDataSource methodsFor: 'queries' stamp: ''!
findItemsSimilarTo: dataSourceItems

	| foundItems relatedItems |
	relatedItems := dataSourceItems 
		select: [ :each | self isBasedOnQueryOf: each type ]
		thenCollect: [ :each | each browserItem ].
	foundItems := self itemCursor findItemsSimilarTo: relatedItems.
	^foundItems collect: [:each | self createElementWith: each ]! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
newSelectionWith: dataSourceItems
	^ClyDataSourceSelection fromRoot: self items: dataSourceItems! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isRoot
	^parentItem isNil! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
depth
	^ depth! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isParentCollapsed
	^self isParentExpanded not! !

!ClyDataSource methodsFor: 'controlling' stamp: ''!
expand: aDataSourceItem
	self subclassResponsibility! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isBasedOnQueryOf: itemTypeClass

	^query retrievesItemsOfType: itemTypeClass! !

!ClyDataSource methodsFor: 'context menu' stamp: ''!
menuColumn: column row: rowIndex
	
	^queryView menuColumn: column row: rowIndex! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
queryResult
	^self itemCursor queryResult! !

!ClyDataSource methodsFor: 'private' stamp: ''!
updateItems: dataSourceItems
	"I update given data source items with refreshed environment items	which belongs to same actual objects. If there is no actual object anymore for some of data source item I will put nil to it.
	Then users should correctly process updated items"
	| updatedItems |
	updatedItems := itemCursor findItemsWith: (dataSourceItems collect: [:each | each actualObject]).
	dataSourceItems with: updatedItems do: [ :myItem :updatedBrowserItem | 
		myItem updateItemWith: updatedBrowserItem  ]! !

!ClyDataSource methodsFor: 'controlling' stamp: ''!
collapse: aDataSourceItem
	self subclassResponsibility! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
definesChildren
	self subclassResponsibility! !

!ClyDataSource methodsFor: 'controlling' stamp: ''!
itemsChanged
	"Method is called when underlying query result was changed.
	In that case we implement lazy updating 
	when we only mark data source as dirty 
	and defer actual update for future processing by next UI iteration.
	It allows to ensure only update of UI despite of multiple system changes
	when they are happen during single UI command.
	At the and it optimizes UI reaction on system changes and makes UI smooth.
	Notice that update (#runUpdate) can be forced by user 
	when he manually requests operations with data source.
	In that case deferred update is skipped 
	because dirty flag is reset during processing (look at #runUpdate)"
	dirty ifTrue: [ ^self ].
	dirty := true.
	self scheduleUpdate! !

!ClyDataSource methodsFor: 'controlling' stamp: ''!
expansionChanged
	queryView restoreSelectedItems.
	self tableRefresh.
	self table resetFunction! !

!ClyDataSource methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	query := ClyUnknownQuery instance.
	itemCursor := ClyClosedBrowserCursor instance.
	depth := 0.
	dirty := false! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
parentItem
	^ parentItem! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
query
	^ query! !

!ClyDataSource methodsFor: 'queries' stamp: ''!
searchText: aString
	"we search only original elements"
	| found |
	found := self itemCursor moveToItemWhich: [ :each | 
		each name asLowercase beginsWith: aString asLowercase ].
	
	^found ifFalse: [ #() ] ifTrue: [ {self itemCursor position}]! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
itemCursor
	dirty ifTrue: [ self runUpdate ].
	^itemCursor! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isDirty
	^dirty! !

!ClyDataSource methodsFor: 'copying' stamp: ''!
copyForBrowserStateSnapshot

	^self copy
		initializeForBrowserStateSpanshot;
		yourself! !

!ClyDataSource methodsFor: 'controlling' stamp: ''!
scheduleUpdate

	self class scheduleUpdateOf: self! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
doesItemHaveChildren: aDataSourceItem
	self subclassResponsibility! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
globalPositionOf: childDataSourceItem
	self subclassResponsibility! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex

	| item |
	item := self elementAt: rowIndex.
	^column createCellFor: item in: queryView! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isEmpty
	^self itemCursor itemCount = 0! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
countChildrenOf: aDataSourceItem
	self subclassResponsibility! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isBasedOn: aQuery

	^query = aQuery! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isClosed
	^itemCursor == ClyClosedBrowserCursor instance! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
allElements
	^(1 to: self numberOfRows) collect: [ :i | 
		self elementAt: i]! !

!ClyDataSource methodsFor: 'drag and drop' stamp: ''!
wantsDropElements: aPassenger type: type index: rowIndex
	| dropTargetItem |
	rowIndex = 0 | (rowIndex > self numberOfRows) ifTrue: [ ^false ].
	self dragTransferType == type ifFalse: [ ^false ].
	dropTargetItem := self elementAt: rowIndex.
	^ queryView wantsDropPassenger: aPassenger at: dropTargetItem! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
parentItem: anObject
	parentItem := anObject! !

!ClyDataSource methodsFor: 'private' stamp: ''!
updateExpandingItems
	self subclassResponsibility! !

!ClyDataSource methodsFor: 'controlling' stamp: ''!
close
	lastFilteredDataSource ifNotNil: [ 
		lastFilteredDataSource close].
	
	itemCursor := itemCursor close! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isSameAs: anotherDataSource

	self class == anotherDataSource class ifFalse: [ ^false ].
	
	^self isBasedOn: anotherDataSource query! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isInSameStateAs: anotherDataSource

	^self isSameAs: anotherDataSource! !

!ClyDataSource methodsFor: 'copying' stamp: ''!
initializeForBrowserStateSpanshot
	table := nil.
	queryView := nil.	
	itemCursor := ClyClosedBrowserCursor instance.	
	lastFilteredDataSource := nil.
	dirty := false.! !

!ClyDataSource methodsFor: 'private' stamp: ''!
runUpdate
	self isClosed ifTrue: [^self].
	dirty ifFalse: [ ^self ].
	
	dirty := false.
	itemCursor updateItemCache.
	self updateExpandingItems.
	queryView itemsChangedIn: self.
	self tableRefresh! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
parentGlobalPosition
	^parentItem ifNil: [ 0 ] ifNotNil: [ parentItem globalPosition ]! !

!ClyDataSource methodsFor: 'queries' stamp: ''!
findItemsWhere: conditionBlock

	| foundItems |
	foundItems := self itemCursor findItemsWhere: conditionBlock.

	^foundItems collect: [:each | self createElementWith: each ]! !

!ClyDataSource methodsFor: 'queries' stamp: ''!
newDataSourceMatching: anItemFilter
	"IMPORTANT: DO NOT CALL IT FROM THE UI PROCESS"
	"Any data source instance should be closed after usage.
	Problem that filtered data sources are managed out of the application, internally inside FastTable.
	So this method is supposed to be called by fast table to create filtered data source 
	which will be not shared to any other users.
	And to close retrieved data source together with original one (self) it will keep reference to it.
	And every new filter request will close existing filtered data source"
	lastFilteredDataSource ifNotNil: [lastFilteredDataSource close].
	self isClosed ifTrue: [
		"This is hackish solution to the current fast table problem with filter process.
		Filter process is not managed by anybody 
		and will continue work after table is removed from the world"
		(Processor activeProcess == UIManager default uiProcess) ifTrue: [ 
			self error: 'Should not happens'].
		^Processor terminateActive].
	lastFilteredDataSource := self class on: (query filteredBy: anItemFilter).
	lastFilteredDataSource openOn: queryView.
	^lastFilteredDataSource! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
toString: anItem

	^anItem  name! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isExpanded: aDataSourceItem
	self subclassResponsibility! !

!ClyDataSource methodsFor: 'controlling' stamp: ''!
forceFullUpdate

	itemCursor forceFullUpdate! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
query: anObject
	query := anObject! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
realElementAt: anIndex

	^ (self elementAt: anIndex) browserItem! !

!ClyDataSource methodsFor: 'drag and drop' stamp: ''!
dragTransferType
	^#CommanderDragAndDrop! !

!ClyDataSource methodsFor: 'private' stamp: ''!
createElementWith: anEnvironmentItem

	^self 
		findCachedElementWith: anEnvironmentItem 
		ifAbsent: [ ClyDataSourceItem of: self value: anEnvironmentItem]! !

!ClyDataSource methodsFor: 'private' stamp: ''!
findCachedElementWith: anEnvironmentItem ifAbsent: absentBlock
	self subclassResponsibility! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
hasMetaProperty: aPropertyClass

	^self itemCursor hasMetaProperty: aPropertyClass! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
queryView: aQueryView
	queryView := aQueryView! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
queryEnvironment
	^query environment! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
depth: anObject
	depth := anObject! !

!ClyDataSource methodsFor: 'queries' stamp: ''!
findItemsWith: actualObjects

	| foundItems |
	foundItems := self itemCursor findItemsWith: actualObjects.

	^foundItems select: #notNil thenCollect: [:each | 
		self createElementWith: each ]! !

!ClyDataSource methodsFor: 'accessing' stamp: ''!
getMetaProperty: aPropertyClass
	^self itemCursor getMetaProperty: aPropertyClass! !

!ClyDataSource methodsFor: 'drag and drop' stamp: ''!
dropElements: aPassenger index: rowIndex
	| dropTargetItem |
	dropTargetItem := self elementAt: rowIndex.
	
	^queryView dropPassenger: aPassenger at: dropTargetItem! !

!ClyDataSource methodsFor: 'testing' stamp: ''!
isParentRemoved
	parentItem ifNil: [ ^false ].
	^parentItem isRemoved! !

!ClyDataSource class methodsFor: 'instance creation' stamp: ''!
empty

	^ClyCollapsedDataSource on: ClyUnknownQuery instance! !

!ClyDataSource class methodsFor: 'instance creation' stamp: ''!
on: aQuery
	^self new 
		query: aQuery! !

!ClyDataSource class methodsFor: 'scheduling updates' stamp: ''!
scheduleUpdateOf: aDataSource

	UpdateScheduler ifNil: [ UpdateScheduler := ClyDataSourceUpdateScheduler new ].
	
	UpdateScheduler register: aDataSource! !

!ClyDataSourceItem commentStamp: ''!
I represent item of ClyDataSource.
I am created with owner data source and browser item which I wrap:
	ClyDataSourceItem of: aDataSource value: aBrowserItem
You can access actual object of browser item:
	aDataSourceItem actualObject

You can control expansion
- supportsExpansion
- collapse
- expand
- isExpanded
When I expand I keep children items in childrenDataSource.

Methods to manage position in table: 
- position. It is position of environment item in owner environment content.
- depth. It is depth of environment item in owner environment content.
- globalPosition. It is row index in owner data source table.

Methods to manage tree structure in table:
- parentItem. It is parent data source.
- rootParentItem
- rootDataSource
- childrenItems
- childrenCount
- childrenItemAt: ownerIndex

You can convert me to selection instance with single item: 
- asSelection

You can retrieve item properties:
- getProperty: aPropertyClass 
- getProperty: aPropertyClass ifAbsent: aBlock
- hasProperty: aPropertyClass
- isMarkedWith: aPropertyTagClass
 
Internal Representation and Key Implementation Points.

    Instance Variables
	browserItem:		<ClyBrowserItem>
	ownerDataSource:		<ClyDataSource>
	childrenDataSource:		<ClyDataSource>!
!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
queryView
	^ownerDataSource queryView! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
globalPosition
	^ownerDataSource globalPositionOf: self! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
isRoot
	^ownerDataSource isRoot & browserItem isRoot! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
childrenDataSource: aDataSource
	childrenDataSource := aDataSource.
	childrenDataSource ifNotNil: [ 
		childrenDataSource parentItem: self.
		childrenDataSource depth: self depth + 1]! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
depth
	^ownerDataSource depth + browserItem depth! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
childrenCount
	^ownerDataSource countChildrenOf: self! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
systemDefinition
	^browserItem systemDefinition! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
actualObject: anObject
	^browserItem actualObject: anObject! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
isSameKindAs: anotherItem
	^self type = anotherItem type! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
ownerDataSource: anObject
	ownerDataSource := anObject! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
isRemoved
	^browserItem isNil 
		or: [ ownerDataSource isParentRemoved 
				or: [ ownerDataSource isParentCollapsed] ]! !

!ClyDataSourceItem methodsFor: 'copying' stamp: ''!
copyForBrowserStateSnapshotOf: rootDataSourceSnapshot
	| copy ownerDataSourceSnapshot |
	ownerDataSourceSnapshot := rootDataSourceSnapshot 
		findDataSourceSameAs: ownerDataSource 
		ifNone: [ self error: 'should not happen' ].	
	copy := self copy.
	copy ownerDataSource: ownerDataSourceSnapshot.
	childrenDataSource ifNotNil: [ 
		copy childrenDataSource: childrenDataSource copyForBrowserStateSnapshot].
	^copy! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
browserItem
	^ browserItem! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
isEqualTo: anotherItem
	^browserItem isEqualTo: anotherItem browserItem! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
childrenDataSource
	^ childrenDataSource! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
parentItem
	^ ownerDataSource isRoot 
		ifTrue: [ nil ]
		ifFalse: [ ownerDataSource parentItem]! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
rootParentItem
	^ ownerDataSource isRoot 
		ifTrue: [ self ]
		ifFalse: [ self parentItem rootParentItem ]! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
supportsExpansion
	^ownerDataSource definesChildren! !

!ClyDataSourceItem methodsFor: 'copying' stamp: ''!
copy

	| copy |
	copy := super copy.
	copy browserItem: browserItem copy.
	^copy! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
childrenItems

	^childrenDataSource allElements! !

!ClyDataSourceItem methodsFor: 'controlling' stamp: ''!
collapse
	ownerDataSource collapse: self! !

!ClyDataSourceItem methodsFor: 'copying' stamp: ''!
copyForBrowserStateSnapshot
	^self copyForBrowserStateSnapshotOf: ownerDataSource copyForBrowserStateSnapshot! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
getProperty: anEnvironmentPropertyClass
	^browserItem getProperty: anEnvironmentPropertyClass! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
isBasedOnItemType: aClass
	^browserItem representsItemOfType: aClass! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
hasChildAt: ownerDataSourceIndex

	^ownerDataSourceIndex > self position and: [
		ownerDataSourceIndex <= (self position + self childrenCount)]! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
position
	^browserItem position! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
belongsToDataSource: aDataSource
	^ownerDataSource == aDataSource! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
actualObject
	"environmentItem can be nil when actual object was removed. In that case actualObject should be nil too. It is convention of updating items/selection logic"
	^browserItem ifNotNil: [browserItem actualObject]! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
hasChildren
	^ownerDataSource doesItemHaveChildren: self! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
isExpanded
	^ownerDataSource isExpanded: self! !

!ClyDataSourceItem methodsFor: 'controlling' stamp: ''!
expandChildren
	
	self childrenDataSource: (ownerDataSource retrieveChildrenOf: self)! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
findParentItemOf: itemTypeClass
	| parent |
	parent := self parentItem ifNil: [ ^nil ].
	(parent isBasedOnItemType: itemTypeClass) ifTrue: [ ^parent ].
	
	^parent findParentItemOf: itemTypeClass! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
isMarkedWith: propertyClass
	^browserItem isMarkedWith: propertyClass! !

!ClyDataSourceItem methodsFor: 'controlling' stamp: ''!
expand
	self isExpanded ifTrue: [ ^self ].
	
	ownerDataSource expand: self! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
browser
	^self queryView browser! !

!ClyDataSourceItem methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream nextPut: $(.
	browserItem 
		ifNil: [ nil printOn: aStream ]
		ifNotNil: [ aStream nextPutAll: browserItem name ].
	aStream nextPut: $).! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
childrenItemAt: ownerIndex

	^childrenDataSource elementAt: ownerIndex - self position! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
isSameAs: anotherItem
	^browserItem isSameAs: anotherItem browserItem! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
hasProperty: propertyClass
	^browserItem hasProperty: propertyClass! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
ownerDataSource
	^ ownerDataSource! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
includesActualObject: anObject

	^ self browserItem includesActualObject: anObject! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
getProperty: anEnvironmentPropertyClass ifAbsent: absentBlock
	^browserItem getProperty: anEnvironmentPropertyClass ifAbsent: absentBlock! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
type
	^browserItem type! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
updateItemWith: updatedEnvironmentItem
	browserItem := updatedEnvironmentItem! !

!ClyDataSourceItem methodsFor: 'converting' stamp: ''!
asSelection
	^self rootDataSource newSelectionWith: {self}! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
rootDataSource
	^ ownerDataSource isRoot 
		ifTrue: [ ownerDataSource ]
		ifFalse: [ ownerDataSource parentItem rootDataSource ]! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
browserItem: aBrowserItem
	browserItem := aBrowserItem! !

!ClyDataSourceItem methodsFor: 'testing' stamp: ''!
isAfter: ownerIndex

	^ownerIndex <= self position! !

!ClyDataSourceItem methodsFor: 'accessing' stamp: ''!
name
	^browserItem name! !

!ClyDataSourceItem class methodsFor: 'instance creation' stamp: ''!
of: aDataSource value: anEnvironmentItem
	^self new 
		ownerDataSource: aDataSource;
		browserItem: anEnvironmentItem! !

!ClyDataSourceSelection commentStamp: ''!
I represent collection of selected data source items.
You can create my instances by: 
	ClyDataSourceSelection fromRoot: aDataSource items: itemsArray
I can give you interesting information:
- size
- actualObjects of my items 
- itemsScope, the class of environment scope which my items arrange.
- lastSelectedItem, an item which user selects last time which means main selected item when multiple selection is not interesting.
- uniformActualObjects, filtered actual objects which belongs to scope of last selected item.

I can be modified using following methods which update visible table selection: 
- selectItems: dataSourceItems. It just changes selection to given items.
- selectItemsWhich: aBlock. It queries data source for items satisfying given block criteria.
- selectItemsWith: actualObjectsArray. It queries data source to find items in underlying query result which belongs to given objects array.

Also there are filter methods which return new selection instances:
- asSelectedRoots. It return new selection which includes only root parents of my own items.
- asSelectedItemsOf: anItemTypeClass. It returns new selection which only includes items which belongs to given item type. 
I can be converted to the scope of my items: 
- asItemsScope: aTypedScope
I can create desired selection instance which responsible to restore selection on different data sources: 
- asDesiredSelection

When data source is changed I am responsible to update visible selection of the table:
	aSelection updateItemsWhichBelongsTo: aDataSource
For example when user expands tree node selected indexes should be shifted when expansion happens before selection. Same should be done when items of data source are removed or added.

Internal Representation and Key Implementation Points.

    Instance Variables
	items:		<SequenceableCollection of<ClyDataSourceItem>>
	rootDataSource:		<ClyDataSource>!
!ClyDataSourceSelection methodsFor: 'controlling' stamp: ''!
restoreTableSelectionSilently: silentSelection

	| selectionIndexes |
	items := items reject: [ :each | each isRemoved ].
	selectionIndexes := items collect: [:each | each globalPosition].
	
	self 
		setUpSelectedRows: selectionIndexes 
		in: rootDataSource table 
		silently: silentSelection! !

!ClyDataSourceSelection methodsFor: 'testing' stamp: ''!
isEmpty
	^items isEmpty! !

!ClyDataSourceSelection methodsFor: 'converting' stamp: ''!
asSelectedRoots

	| roots lastSelectedRoot resultItems |
	self isEmpty ifTrue: [ ^self ].
	roots := items collect: [ :each | each rootParentItem ] as: Set.
	roots = items ifTrue: [ ^self ].
	
	"We want to save root of lastSelectedItem as lastSelectedItem of new selection. 
	This item should be first according to FastTable logic"
	lastSelectedRoot := self lastSelectedItem rootParentItem.
	roots remove: lastSelectedRoot.
	resultItems := OrderedCollection with: lastSelectedRoot.
	resultItems addAll: roots.
	
	^self class fromRoot: self rootDataSource items: resultItems! !

!ClyDataSourceSelection methodsFor: 'controlling' stamp: ''!
updateItemsWhichBelongsTo: aDataSource
	| relatedItems actualSelectionChanged |
	relatedItems := items select: [ :each | each belongsToDataSource: aDataSource].
	aDataSource updateItems: relatedItems.
	
	actualSelectionChanged := relatedItems anySatisfy: #isRemoved.
	
	self restoreTableSelectionSilently: actualSelectionChanged not.
	
	^actualSelectionChanged! !

!ClyDataSourceSelection methodsFor: 'converting' stamp: ''!
asDesiredSelection

	| itemsCopy |
	itemsCopy := items collect: [ :each | each copy childrenDataSource: nil].
	^ClyDesiredSelection fromRoot: rootDataSource items: itemsCopy.! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
lastSelectedItem

	^items first " it is related to ordering logic in FastTable"! !

!ClyDataSourceSelection methodsFor: 'testing' stamp: ''!
includesItemsOf: itemTypeClass

	^items anySatisfy: [ :each | each isBasedOnItemType: itemTypeClass ]! !

!ClyDataSourceSelection methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream nextPut: $(.
	items do: [ :each | aStream nextPutAll: each name; nextPutAll: '; ' ].
	items ifNotEmpty: [ aStream skip: -2 ].
	aStream nextPut: $).! !

!ClyDataSourceSelection methodsFor: 'controlling' stamp: ''!
selectItemsWith: actualObjects

	| newItems |
	newItems := rootDataSource queryView findItemsWith: actualObjects.
	self selectItems: newItems! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
groupItemsByTypeAndDo: typeAndItemsBlock

	self groupItemsByType keysAndValuesDo: typeAndItemsBlock! !

!ClyDataSourceSelection methodsFor: 'controlling' stamp: ''!
ensureVisibleLastItem

	"in fact first selection index is last selected item"
	rootDataSource table ensureVisibleFirstSelection! !

!ClyDataSourceSelection methodsFor: 'testing' stamp: ''!
hasSelectedItems
	^self isEmpty not! !

!ClyDataSourceSelection methodsFor: 'testing' stamp: ''!
isSameAs: anotherSelection

	self size = anotherSelection size ifFalse: [ ^false ].
	
	items with: anotherSelection items do: [ :myItem :anotherItem | 
		myItem actualObject == anotherItem actualObject ifFalse: [ ^false ]].
	
	^true! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
actualObjects
	^items collect: [:each | each actualObject]! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
detachedItems
	"Selection manages own items in the way that they should not be in long use from outside.
	For example when items data source is changed my items could have null environment item inside
	accouring to selection update logic. So users should not break because of that.
	If users want to use selection items for long time (for example browser context wants) 
	then they should ask for #detachedItems"
	
	^items collect: [:each | each copy]! !

!ClyDataSourceSelection methodsFor: 'testing' stamp: ''!
includesActualObject: anObject
	^items anySatisfy: [ :each | each includesActualObject: anObject ]! !

!ClyDataSourceSelection methodsFor: 'controlling' stamp: ''!
restoreTableSelection
	| actualSelectionChanged |
	actualSelectionChanged := items anySatisfy: #isRemoved.
	
	self restoreTableSelectionSilently: actualSelectionChanged not.
	
	^actualSelectionChanged! !

!ClyDataSourceSelection methodsFor: 'controlling' stamp: ''!
beEmpty

	self selectItems: { }! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
groupItemsByType

	| groups |
	groups := IdentityDictionary new.
	
	items do: [ :each | | group |
		group := groups at: each type ifAbsentPut: [ OrderedCollection new ].
		group add: each actualObject].
	
	^groups! !

!ClyDataSourceSelection methodsFor: 'controlling' stamp: ''!
selectItems: dataSourceItems
	
	| newSelectionIsSame |
	newSelectionIsSame := (dataSourceItems collect: #actualObject as: IdentitySet) = 
		(items collect: #actualObject as: IdentitySet).

	items := dataSourceItems.
	self restoreTableSelectionSilently: newSelectionIsSame.
	self ensureVisibleLastItem! !

!ClyDataSourceSelection methodsFor: 'copying' stamp: ''!
copyForBrowserStateSnapshotOf: aDataSource

	| copy |
	copy := self asDesiredSelection.
	copy rootDataSource: aDataSource.
	copy items: (items collect: [ :each | each copyForBrowserStateSnapshotOf: aDataSource]).
	^copy! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
rootDataSource
	^ rootDataSource! !

!ClyDataSourceSelection methodsFor: 'controlling' stamp: ''!
restoreDesiredSelectionWith: newDataSourceItems silently: aBool 

	items := newDataSourceItems.

	self restoreTableSelectionSilently: aBool.
	
	aBool ifFalse: [self ensureVisibleLastItem]! !

!ClyDataSourceSelection methodsFor: 'controlling' stamp: ''!
selectItemsWhere: conditionBlock

	| newItems |
	newItems := rootDataSource findItemsWhere: conditionBlock.
	self selectItems: newItems! !

!ClyDataSourceSelection methodsFor: 'converting' stamp: ''!
asSelectedParentsOf: itemTypeClass

	| parents resultItems currentItems resultSet lastSelectedItem |
	self isEmpty ifTrue: [ ^self ].
	currentItems := items select: [ :each | each isBasedOnItemType: itemTypeClass].
	currentItems = items ifTrue: [ ^self ].
	parents := items 
		reject: [:each | each isBasedOnItemType: itemTypeClass ] 
		thenCollect: [ :each |each findParentItemOf: itemTypeClass ].
	resultSet := parents asSet.
	resultSet remove: nil ifAbsent: [].
	resultSet addAll: currentItems.
	
	
	"We want to save root of lastSelectedItem as lastSelectedItem of new selection. 
	This item should be first according to FastTable logic".
	resultItems := resultSet asOrderedCollection.
	lastSelectedItem := self lastSelectedItem.
	(resultSet includes: lastSelectedItem) ifTrue: [ 
		resultItems remove: lastSelectedItem.
		resultItems addFirst: lastSelectedItem].	
	
	^self class fromRoot: self rootDataSource items: resultItems! !

!ClyDataSourceSelection methodsFor: 'converting' stamp: ''!
asSelectedItemsOf: itemTypeClass

	| resultItems |
	self isEmpty ifTrue: [ ^self ].
	resultItems := items select: [ :each | each isBasedOnItemType: itemTypeClass ].
	resultItems = items ifTrue: [ ^self ].
	
	^self class fromRoot: self rootDataSource items: resultItems! !

!ClyDataSourceSelection methodsFor: 'private' stamp: ''!
setUpSelectedRows: indexes in: aTableMorph silently: silentSelection
	silentSelection
		ifTrue: [ aTableMorph basicSelectIndexes: indexes ]
		ifFalse: [ "we should prevent ignoring new selection if indexes are still same"
			aTableMorph basicSelectIndexes: #(-1000).
			aTableMorph selectIndexes: indexes ]! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
size
	^items size! !

!ClyDataSourceSelection methodsFor: 'controlling' stamp: ''!
updateIfDirty
	
	rootDataSource isDirty ifTrue: [ rootDataSource runUpdate ].
	items do: [ :each | each ownerDataSource isDirty 
		ifTrue: [ each ownerDataSource runUpdate] ]! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
items: anObject
	items := anObject! !

!ClyDataSourceSelection methodsFor: 'testing' stamp: ''!
isSingleSelected
	^items size = 1! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
items
	^ items! !

!ClyDataSourceSelection methodsFor: 'converting' stamp: ''!
asItemsScope: aTypedScope
	| actualItems |
	actualItems := self uniformActualObjects.
	^ aTypedScope ofAll: actualItems in: rootDataSource queryEnvironment! !

!ClyDataSourceSelection methodsFor: 'testing' stamp: ''!
isBasedOnItemType: aClass

	^self isEmpty 
		ifTrue: [ rootDataSource isBasedOnQueryOf: aClass ]
		ifFalse: [ self lastSelectedItem isBasedOnItemType: aClass  ]! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
uniformActualObjects

	| lastItem |
	self isEmpty ifTrue: [ ^#() ].
	lastItem := self lastSelectedItem.
	
	^(items allSatisfy: [:each | each isSameKindAs: lastItem ]) 
		ifTrue: [ items collect: [:each | each actualObject] ]
		ifFalse: [{lastItem actualObject}]! !

!ClyDataSourceSelection methodsFor: 'testing' stamp: ''!
isMultipleSelected
	^items size > 1! !

!ClyDataSourceSelection methodsFor: 'accessing' stamp: ''!
rootDataSource: anObject
	rootDataSource := anObject! !

!ClyDataSourceSelection class methodsFor: 'instance creation' stamp: ''!
fromRoot: aDataSource items: dataSourceItems
	^self new 
		rootDataSource: aDataSource;
		items: dataSourceItems! !

!ClyDataSourceUpdateScheduler commentStamp: ''!
I organize scheduled updates of data sources.
Idea to always defer update of browser until current UI command will be completelly done. 
It ensures that browser updates will not affect general performance of basic operations which modifies system because any update will be just queued and processes in low priority process when there will be time for this.

My single instance is created by ClyDataSource as shared class variable UpdateScheduler.
Data sources register themselfs for updates when they receives event that items were changed: 
	
	UpdateScheduler register: aDataSource.
	 
In addition actual update is executed in UI process using standart deferring logic: 

	UIManager default defer: [ next runUpdate ]

But this deferring is triggered from low priority process.

Internal Representation and Key Implementation Points.

    Instance Variables
	process:		<Process>
	updateQueue:		<AtomicSharedQueue>!
!ClyDataSourceUpdateScheduler methodsFor: 'controlling' stamp: ''!
runUpdateFor: dataSources

	UIManager default defer: [ 
		dataSources do: [ :each | each runUpdate ] ]! !

!ClyDataSourceUpdateScheduler methodsFor: 'controlling' stamp: ''!
ensureRunning
	(process notNil and: [ process isTerminated not ]) ifTrue: [ ^self].
	
	process := [ self processQueue ] 
		forkAt: Processor userBackgroundPriority + 1 named: 'Calypso update'! !

!ClyDataSourceUpdateScheduler methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	updateQueue := AtomicSharedQueue new! !

!ClyDataSourceUpdateScheduler methodsFor: 'controlling' stamp: ''!
processQueue

	 [| available next |
        available := OrderedCollection with: updateQueue next.
        [ next := updateQueue nextOrNil ] whileNotNil: [ available add: next ].
        self runUpdateFor: available.    
    ] repeat! !

!ClyDataSourceUpdateScheduler methodsFor: 'controlling' stamp: ''!
register: aDataSource

	updateQueue nextPut: aDataSource.
	self ensureRunning! !

!ClyDebugBrokenCritiqueCommand commentStamp: ''!
I am a command to debug broken critique.
I expect that my critique is ReExceptionProperty instance representign the failure which was raisen during critique computation!
!ClyDebugBrokenCritiqueCommand methodsFor: 'table decoration' stamp: ''!
decorateTableCell: anItemCellMorph with: aMorph
	super decorateTableCell: anItemCellMorph with: aMorph.
	
	anItemCellMorph definitionIcon: #exceptionIcon! !

!ClyDebugBrokenCritiqueCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Debug the exception'! !

!ClyDebugBrokenCritiqueCommand methodsFor: 'execution' stamp: ''!
execute

	(OupsDebugRequest newForContext: critique stack)
		label: critique message;
		submit! !

!ClyDebugBrokenCritiqueCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallDebug! !

!ClyDebugBrokenCritiqueCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aCriticContext
	
	^aCriticContext hasSelectedItems and: [
		aCriticContext lastSelectedItem isMarkedWith: ClyBrokenCritiqueTag]! !

!ClyDebugBrokenCritiqueCommand class methodsFor: 'activation' stamp: ''!
criticTableIconActivation
	<classAnnotation>
	
	^ClyTableIconCommandActivation for: ReProperty asCalypsoItemContext! !

!ClyDebugTestCommand commentStamp: ''!
I am a command to debug selected test method.
I install breakpoint to the start of method which opens debugger during following test run!
!ClyDebugTestCommand methodsFor: 'execution' stamp: ''!
runTest: testSelector of: testClass

	| breakpoint |
	breakpoint := Breakpoint new
		node: (testClass lookupSelector: testSelector) ast;
		install.
	[super runTest: testSelector of: testClass] ensure: [ breakpoint remove ]! !

!ClyDebugTestCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Debug tests'! !

!ClyDebugTestCommand methodsFor: 'execution' stamp: ''!
defaultMenuIcon
	^Smalltalk ui iconNamed: #smallDebug! !

!ClyDebugTestCommand class methodsFor: 'activation' stamp: ''!
fullBrowserTableIconActivation
	"It should not be as icon in table"! !

!ClyDebugTestCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $d meta for: self contextClass! !

!ClyDebuggingCommand commentStamp: ''!
I am a base class for commands which add/remove metalinks into given method or source node!
!ClyDebuggingCommand class methodsFor: 'activation' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation 
		byItemOf: ClyDebuggingMenuGroup order: self contextMenuOrder for: ClyMethod asCalypsoItemContext! !

!ClyDebuggingCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyDebuggingCommand! !

!ClyDebuggingCommand class methodsFor: 'activation' stamp: ''!
methodEditorLeftBarMenuActivation
	<classAnnotation>
	
	^CmdTextLeftBarMenuActivation 
		byItemOf: ClyDebuggingMenuGroup order: self contextMenuOrder for: ClyMethodSourceCodeContext! !

!ClyDebuggingCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder
	<classAnnotationDependency>
	self subclassResponsibility! !

!ClyDebuggingCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycDebuggingMenuActivation 
		byItemOf: ClyDebuggingMenuGroup order: self contextMenuOrder for: ClyMethodSourceCodeContext! !

!ClyDebuggingMenuGroup commentStamp: ''!
I am menu group to arrange together all metalink related commands (breakpoints, counters, watchpoints)!
!ClyDebuggingMenuGroup methodsFor: 'accessing' stamp: ''!
order
	^1.5! !

!ClyDebuggingMenuGroup methodsFor: 'testing' stamp: ''!
isInlined
	^true! !

!ClyDefaultSystemEnvironmentPlugin commentStamp: ''!
I represent default plugin for navigation environment. 
I fill items with basic properties related to Smalltalk meta model.
And I provide standart method and class groups!
!ClyDefaultSystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod
	
	anItem ensureSystemDefinition: [ClyMethodDefinitionProperty of: aMethod]! !

!ClyDefaultSystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
checkPackageHasClassGroups: aPackage
	| providers packageScope |
	packageScope := ClyPackageScope of: aPackage in: environment.
	environment
		pluginsDo: [ :plugin | 
			providers := plugin collectClassGroupProviders.
			providers
				do: [ :each | each classGroupsIn: packageScope do: [ :group | ^ true ] ] ].
	^ false! !

!ClyDefaultSystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofClass: aClass

	anItem ensureSystemDefinition: [ClyClassDefinitionProperty of: aClass].
	
	aClass localSelectors ifNotEmpty: [ anItem markWithChildrenOf: ClyMethod].

	aClass hasComment ifFalse: [ anItem markWith: ClyNoCommentTag]! !

!ClyDefaultSystemEnvironmentPlugin methodsFor: 'method groups' stamp: ''!
collectMethodGroupProviders 

	^{ClyInheritedMethodGroupProvider. ClyTaggedMethodGroupProvider. ClyUnclassifiedMethodGroupProvider. ClyExtendedMethodGroupProvider}
		collect: [ :each | each new ]! !

!ClyDefaultSystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethodGroup: aMethodGroup
	
	aMethodGroup decorateOwnBrowserItem: anItem! !

!ClyDefaultSystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofPackage: aPackage
	
	aPackage classes ifNotEmpty: [ anItem markWithChildrenOf: ClyClass ].
	
	(self checkPackageHasClassGroups: aPackage) ifTrue: [ 
		anItem markWithChildrenOf: ClyClassGroup]! !

!ClyDefaultSystemEnvironmentPlugin methodsFor: 'method groups' stamp: ''!
collectClassGroupProviders

	^{ClyExtendedClassGroupProvider. ClyNoTagClassGroupProvider. ClyTaggedClassGroupProvider}
		collect: [ :each | each new ]! !

!ClyDefaultSystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofClassGroup: aClassGroup
	
	aClassGroup decorateOwnBrowserItem: anItem! !

!ClyDeprecatedClassExample commentStamp: ''!
I am example of deprecated class.
I just implement #isDeprecated as true!
!ClyDeprecatedClassExample class methodsFor: 'testing' stamp: ''!
isDeprecated
	^true! !

!ClyDeprecatedItemTableDecorator commentStamp: ''!
I decorate deprecated methods in the table with struck out font!
!ClyDeprecatedItemTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem
	| nameMorph |

	nameMorph := anItemCellMorph label.
	nameMorph clyAddEmphasis: TextEmphasis struckOut! !

!ClyDeprecatedItemTableDecorator class methodsFor: 'decoration' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	^aDataSourceItem isMarkedWith: ClyDeprecatedItemTag! !

!ClyDeprecatedItemTableDecorator class methodsFor: 'decoration' stamp: ''!
browserDecorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClySystemBrowserContext! !

!ClyDeprecatedItemTag commentStamp: ''!
I mark deprecated objects like methods or classes !
!ClyDeprecatedMethodGroupProvider commentStamp: ''!
I provide "deprecated" method groups when given classes define them!
!ClyDeprecatedMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyDeprecatedMethodsQuery from: aClassScope! !

!ClyDeprecatedMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'deprecated' priority: -9 on: aMethodQuery! !

!ClyDeprecatedMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyDeprecatedMethodGroupProvider! !

!ClyDeprecatedMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup

	^ClyClassWithDeprecatedMethods! !

!ClyDeprecatedMethodsQuery commentStamp: ''!
I return all deprecated methods from my scope!
!ClyDeprecatedMethodsQuery methodsFor: '*Calypso-SystemPlugins-Deprecation-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph label clyAddEmphasis: TextEmphasis struckOut! !

!ClyDeprecatedMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^aMethod isDeprecated! !

!ClyDeprecatedMethodsQuery methodsFor: 'printing' stamp: ''!
description
	^'deprecated methods'! !

!ClyDeprecatedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testSelectsDeprecatedMethod

	self assert: (query selectsMethod: ClyClassWithDeprecatedMethods >> #deprecatedMethod1)! !

!ClyDeprecatedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsNotDeprecatedMethod

	self deny: (query selectsMethod: ClyClassWithDeprecatedMethods >> #notDeprecatedMethod)! !

!ClyDeprecatedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: (ClyClassWithDeprecatedMethods >> #deprecatedMethod1)
		in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyClassWithDeprecatedMethods >> #notDeprecatedMethod)
		in: environment).
	self assert: query checkEmptyResult! !

!ClyDeprecatedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyClassWithDeprecatedMethods >> #deprecatedMethod1. 
		ClyClassWithDeprecatedMethods >> #deprecatedMethod2.
		ClyClassWithDeprecatedMethods >> #notDeprecatedMethod}.
	
	self assert: foundSelectors sorted asArray equals: #(deprecatedMethod1 deprecatedMethod2)! !

!ClyDeprecatedMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyDeprecatedMethodsQuery from: ClyClassScope of: Object in: environment! !

!ClyDeprecationEnvironmentPlugin commentStamp: ''!
I am special plugin which analyzes deprecated methods/classes and mark them with deprecation tag.
Also I provide deprecated method group to see all deprecated methods together!
!ClyDeprecationEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofClass: aClass
	aClass isDeprecated ifTrue: [ anItem markWith: ClyDeprecatedItemTag ]! !

!ClyDeprecationEnvironmentPlugin methodsFor: 'method groups' stamp: ''!
collectMethodGroupProviders
	^{ClyDeprecatedMethodGroupProvider new}! !

!ClyDeprecationEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofPackage: aPackage
	aPackage isDeprecated ifTrue: [ anItem markWith: ClyDeprecatedItemTag ]! !

!ClyDeprecationEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod

	aMethod isDeprecated ifTrue: [ 
		anItem markWith: ClyDeprecatedItemTag]! !

!ClyDesiredSelection commentStamp: ''!
I represent desired selection which should be restored on different data sources.
For example when in the browser user selects particular method and switches to another class then similar method (with same name) should be selected in new class automatically. 
I am created by ClyNavigationView when user manually selects new table items. When new data source is set to view I responsible to restore previous selection of table:
	desiredSelection restoreCurrentSelection: aDataSourceSelection 
Inside this method I ask given selection to find similar items as mine to set them as a new selection:
	aDataSourceSelection restoreDesiredSelectionWith: newItems silently: selectionIsSame.
Last argument indicates that items from new data source are same as selected before. So table should not trigger selection changed event because in fact selection is still same.
To achieve this logic I keep flag that I am the same as current selection from which I was created.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	isSameAsCurrent:		<Boolean>!
!ClyDesiredSelection methodsFor: 'controlling' stamp: ''!
restoreCurrentSelection: currentSelection
	"We should signal selection change only when previous selection was different 
	and new given data source has no same items.
	We don't want trigger changes when selection was not changed in fact"
	| wasSameAsCurrent newItems currentSelectionIsChanged |
	wasSameAsCurrent := isSameAsCurrent.
	self checkItemsOfCurrentSelection: currentSelection.
	newItems := isSameAsCurrent 
		ifTrue: [ currentSelection items]
		ifFalse: [ currentSelection rootDataSource findItemsSimilarTo: items].
		
	currentSelectionIsChanged := (wasSameAsCurrent & isSameAsCurrent) not.
	currentSelection 
		restoreDesiredSelectionWith: newItems 
		silently: currentSelectionIsChanged not.
	^currentSelectionIsChanged! !

!ClyDesiredSelection methodsFor: 'accessing' stamp: ''!
isSameAsCurrent
	^ isSameAsCurrent! !

!ClyDesiredSelection methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	isSameAsCurrent := true! !

!ClyDesiredSelection methodsFor: 'controlling' stamp: ''!
restoreCurrentSelectionAfterUpdate: currentSelection
	"We should signal selection change only when previous selection was different 
	and new given data source has no same items.
	We don't want trigger changes when selection was not changed in fact
	DIFFERENCE from basic #restoreCurrentSelection::
	After update we should not switch selection to similar items.
	After update we should only try to restore exact selection as before.
	So we ask data source to find items exactly with my content
	instead of something similar"
	| wasSameAsCurrent newItems currentSelectionIsChanged |
	wasSameAsCurrent := isSameAsCurrent.
	self checkItemsOfCurrentSelection: currentSelection.
	newItems := isSameAsCurrent 
		ifTrue: [ currentSelection items]
		ifFalse: [ currentSelection rootDataSource findItemsWith: self actualObjects].
		
	currentSelectionIsChanged := (wasSameAsCurrent & isSameAsCurrent) not.
	currentSelection 
		restoreDesiredSelectionWith: newItems 
		silently: currentSelectionIsChanged not.
	^currentSelectionIsChanged! !

!ClyDesiredSelection methodsFor: 'controlling' stamp: ''!
updateItemsWhichBelongsTo: aDataSource
	"We override this method by two reasons:
	- desired selection should always keep all items even if some of them was removed from current data source
	- desired selection should never affect actual table selection ofter changes. That's why here we always return false which means that actual selection is not changed"
	| relatedItems updatedItems |
	relatedItems := items select: [ :each | each belongsToDataSource: aDataSource].
	updatedItems := aDataSource itemCursor findItemsWith: (relatedItems collect: [:each | each actualObject]).
	relatedItems with: updatedItems do: [ :myItem :updatedBrowserItem | 
		updatedBrowserItem ifNotNil: [ myItem updateItemWith: updatedBrowserItem ]].
	^false! !

!ClyDesiredSelection methodsFor: 'controlling' stamp: ''!
checkItemsOfCurrentSelection: currentSelection
	| newItems |
	isSameAsCurrent := false.
	newItems := currentSelection items.	

	newItems size = items size ifFalse: [ ^self].
	newItems do: [ :eachNewItem | items do: [ :eachMyItem |
		(eachNewItem isSameAs: eachMyItem) ifFalse: [ ^self ] ] ].

	isSameAsCurrent := true! !

!ClyDesiredSelection methodsFor: 'accessing' stamp: ''!
isSameAsCurrent: anObject
	isSameAsCurrent := anObject! !

!ClyDirtyPackageTag commentStamp: ''!
I mark dirty package items!
!ClyDynamicBallonTooltip commentStamp: ''!
I am a hook to get dynamically updatable balloon tooltip.

To install me into the morph use following expression:

	ClyDynamicBallonTooltip from: ['test string'] installInto: aMorph!
!ClyDynamicBallonTooltip methodsFor: 'accessing' stamp: ''!
block
	^ block! !

!ClyDynamicBallonTooltip methodsFor: 'accessing' stamp: ''!
block: anObject
	block := anObject! !

!ClyDynamicBallonTooltip methodsFor: 'installation' stamp: ''!
installInto: aMorph
	"Dynamic update is done by #asString converting.
	But simple aMorph setBalloonText: also converts given argument to string.
	So here I use low level morph extension logic which simply assigns given tooltip instance"
	aMorph assureExtension balloonText: self! !

!ClyDynamicBallonTooltip methodsFor: 'converting' stamp: ''!
asString
	^block value! !

!ClyDynamicBallonTooltip class methodsFor: 'instance creation' stamp: ''!
from: aBlock
	^self new 
		block: aBlock! !

!ClyDynamicBallonTooltip class methodsFor: 'instance creation' stamp: ''!
from: aBlock installInto: aMorph
	^(self from: aBlock)
		installInto: aMorph; 
		yourself! !

!ClyEmptyClassSelectionContext methodsFor: 'testing' stamp: ''!
describes: aBrowserContext
	^(aBrowserContext isKindOf: ClyFullBrowserContext) 
		and: [aBrowserContext isClassSelected not]! !

!ClyEmptyPackageTableDecorator commentStamp: ''!
I decorate table with special icon for empty packages which has no classes!
!ClyEmptyPackageTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyEmptyPackageTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	^(aDataSourceItem browserItem hasChildrenOf: ClyClass) not! !

!ClyEmptyPackageTableDecorator class methodsFor: 'decoration' stamp: ''!
priority
	^ClyPackageIconTableDecorator priority + 1! !

!ClyEmptyPackageTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	
	anItemCellMorph definitionIcon: #emptyPackageIcon! !

!ClyEnvironmentChanged commentStamp: ''!
I am announced when query result when it is changed due to occured system change!
!ClyEnvironmentPlugin commentStamp: ''!
I am a root of environment plugins hierarchy.
My subclasses are responsible for three things:

1) Extend browser items with arbitrary properties. Any plugin can compute specific properties for given item. 
For example plugin can mark class that it is abstract:
	
	MyPluginClass>>decorateBrowserItem: anItem ofClass: aClass
		aClass isAbstract ifTrue: [ anItem markWith: ClyAbstractItemTag  ]
		
Concrete decoration methods which plugin can implement are depends on the item types which plugin is going support. For another example to decorate methods plugin should implement: 

- decorateBrowserItem: anItem ofMethod: aMethod

Normally when you develop navigation over concrete system you build some common superclass plugin which will provide stubs for all item types form your domain. 
In case of Smalltalk navigation there is ClySystemEnvironmentPlugin which implements empty methods to decorate packages, classes and methods (like in examples)

2) Connect external systems to the navigation environment. 
Plugin package can provide new kind of queries and scopes which retrieves new kind of items. These items can be from systems which are external to the main navigation environment. 
Plugin should take care about external updates by subscribing to external system for the changes and by delegating them to the navigation environment.

For example SUnit plugin extends Smalltalk environment with information about tests. It subscribes on SUnit events about test ran. And when it happens it delegates event to the environment which updates methods queries with new information about test result.

To connect to external system plugin implements following method:
- attatchToSystem 
Here plugin can subscribe on external events. For example SUnit plugin subscribes on "TestCase historyAnnouncer" to know when user run tests.

And to disconnect from system should implement:
- detatchFromSystem
For example SUnit plugin unsubscribes from "TestCase historyAnnouncer".

3) Collect query result metadata. 
For example SUnit plugin can collect how many success tests are retrieved by method query.
The exact methods which plugin should implement depends on the kind of queries it is supposed to support. In case of SUnit it implements:
- collectMetadataOfMethods: aQueryResult

But decision what method to use is responsibility of queries. For example: 

	ClyMethodQuery>>collectMetadataOf: aQueryResult by: anEnvironmentPlugin
		anEnvironmentPlugin collectMetadataOfMethods: aQueryResult

As in case of items decoration the superclass of plugins can provide empty methods for metadata collection. So concrete plugin only chooses what it wants.

That is all responsibility.
 
To activate plugin it should be added to navigation environment: 
	environment addPlugin: anEnvironmentPlugin 

Default global environment adds all plugins automatically. Only plugins marked as auto-activated are used (which is true by default):
	
	ClyEnvironmentPlugin class>>isAutoActivated
		^isAutoActivated ifNil [true]

You can disable any plugin using: 
	
	ClyConcretePlugin disable

But it do not affect default navigation environment. You will need recreate it.

 
Internal Representation and Key Implementation Points.

    Instance Variables
	environment:		<ClyNavigationEnvironment>!
!ClyEnvironmentPlugin methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!ClyEnvironmentPlugin methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!ClyEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofObject: anObject! !

!ClyEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
detachFromSystem! !

!ClyEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
attachToSystem! !

!ClyEnvironmentPlugin class methodsFor: 'initialization' stamp: ''!
initialize
	self isAbstract ifTrue: [ ^self ].
	
	ClyNavigationEnvironment installNewPlugin: self! !

!ClyEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isRelatedTo: aSystem
	"My subclasses should decide what kind of system they are related to"
	
	self subclassResponsibility! !

!ClyEnvironmentPlugin class methodsFor: 'initialization' stamp: ''!
disable
	isAutoActivated := false! !

!ClyEnvironmentPlugin class methodsFor: 'initialization' stamp: ''!
enable
	isAutoActivated := true! !

!ClyEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyEnvironmentPlugin! !

!ClyEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isAutoActivatedOn: aNavigationEnvironment
	^self isAbstract not & self isAutoActivated 
		and: [ self isRelatedTo: aNavigationEnvironment system ]! !

!ClyEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isAutoActivated
	^isAutoActivated ifNil: [ true ]! !

!ClyEnvironmentUpdateStrategy commentStamp: ''!
I am a root strategy which subclasses defines how environment should be updated due to accepted change events.

Subclasses should implement two methods:

- announceChangesOf: aQueryResult
here subclasses should define what to do with given change

- publishCollectedChanges
here subclasses can publish all collected changes at once when their logic is to collect events instead of instant announcing them!
!ClyEnvironmentUpdateStrategy methodsFor: 'updating' stamp: ''!
publishCollectedChanges
	self subclassResponsibility! !

!ClyEnvironmentUpdateStrategy methodsFor: 'updating' stamp: ''!
announceChangesOf: aQueryResult
	self subclassResponsibility! !

!ClyEvaluationScript commentStamp: ''!
I represent class side methods with pragma <script>!
!ClyEvaluationScript class methodsFor: 'script detection' stamp: ''!
isImplementedByMethod: aMethod
	^ aMethod hasPragmaNamed: #script! !

!ClyEvaluationScriptWithArgument commentStamp: ''!
I represent any methods with parametric pragma <script:>.
Pragma parameter is an actual expression which should be evaluated.

So for execution I extract the argument from pragma and evaluate it using compiler. I do not use method itself.!
!ClyEvaluationScriptWithArgument methodsFor: 'execution' stamp: ''!
executeOn: aClass

	| pragma |
	pragma := implementorMethod pragmaAt: #script:.
	^ aClass compiler
		receiver: aClass instanceSide;
		evaluate: pragma arguments first! !

!ClyEvaluationScriptWithArgument methodsFor: 'testing' stamp: ''!
isImplementedByClass: aClass
	
	^ aClass instanceSide includesBehavior: self implementorClass instanceSide! !

!ClyEvaluationScriptWithArgument class methodsFor: 'script detection' stamp: ''!
canBeProvidedByMethod: aMethod
	"Parametric script can be used in any method. 
	It is retrieved from pragma argument and method itself is not used for execution"
	^ true! !

!ClyEvaluationScriptWithArgument class methodsFor: 'script detection' stamp: ''!
isImplementedByMethod: aMethod
	^ aMethod hasPragmaNamed: #script:! !

!ClyExampleScope methodsFor: 'accessing' stamp: ''!
extraParameter: anObject
	extraParameter := anObject! !

!ClyExampleScope methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ extraParameter = anObject extraParameter! !

!ClyExampleScope methodsFor: '*Calypso-SystemQueries-Tests' stamp: ''!
adoptLocalScopeClassTo: aLocalScopeClass
	"To fix abstrat test covering scope convertion"! !

!ClyExampleScope methodsFor: 'accessing' stamp: ''!
extraParameter
	^ extraParameter! !

!ClyExampleScope methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: extraParameter hash! !

!ClyExampleScript commentStamp: ''!
I represent the action of the performed on class side methods marked with pragma <example> or with selector beginning with example word.

example1

	BorderedMorph new openInWorld 
	
or 

foo
	<example>
	
	BorderedMorph new openInWorld
	
will open both a new morph in the world. 

Note that if you add in addition the pragma <sampleInstance> you will get an inspector on the result. !
!ClyExampleScript methodsFor: 'accessing' stamp: ''!
iconName
	^#smallDoItIcon! !

!ClyExampleScript methodsFor: 'accessing' stamp: ''!
description
	^ 'Run the example'! !

!ClyExampleScript class methodsFor: 'script detection' stamp: ''!
isImplementedByMethod: aMethod
	(aMethod hasPragmaNamed: #sampleInstance) ifTrue: [ ^ false ].
	^ (aMethod selector beginsWith: 'example') 
		 or: [ aMethod hasPragmaNamed: #example ]! !

!ClyExpandClassDefinitionCommand methodsFor: 'accessing' stamp: ''!
applyResultInContext: aToolContext

	super applyResultInContext: aToolContext. 
	aToolContext tool pendingText: aToolContext tool editingClass expandedDefinitionString! !

!ClyExpandClassDefinitionCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Expand'! !

!ClyExpandClassDefinitionCommand methodsFor: 'accessing' stamp: ''!
execute
	"
	empty on purpose logic is in applyResultInContext:
	"! !

!ClyExpandClassDefinitionCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#glamorousBrowse! !

!ClyExpandClassDefinitionCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
   <classAnnotation>
   ^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.2 for: ClyClassDefinitionContext! !

!ClyExpandedDataSource commentStamp: ''!
I am table data source which items are all initially expanded.
I maintain list of collapsed items and compute items position according to it (row indexes in full table).

Internal Representation and Key Implementation Points.

    Instance Variables
	collapsedItems:		<SortedCollection of: ClyDataSourceItem>	sorted by item position!
!ClyExpandedDataSource methodsFor: 'accessing' stamp: ''!
globalPositionOf: childDataSourceItem

	| result |
	result := parentItem ifNil: [ 0 ] ifNotNil: [ parentItem globalPosition ].
	collapsedItems do: [ :each | 
		(each isAfter: childDataSourceItem position) ifTrue: [
			^result + childDataSourceItem position].
		result := result - each childrenCount].
	
	^result + childDataSourceItem position! !

!ClyExpandedDataSource methodsFor: 'testing' stamp: ''!
countChildrenOf: aDataSourceItem
	| environmentItem |
	environmentItem := aDataSourceItem browserItem.
	
	^environmentItem localHierarchySize! !

!ClyExpandedDataSource methodsFor: 'accessing' stamp: ''!
elementAt: rowIndex
	| localIndex |
	localIndex := rowIndex.

	collapsedItems do: [:each | 
		each position = localIndex ifTrue: [ ^each ].
		(each isAfter: localIndex) ifTrue: [
			self itemCursor moveTo: localIndex.
			^ ClyDataSourceItem of: self value: self itemCursor currentItem ].
		localIndex := localIndex + each childrenCount.
	].

	self itemCursor moveTo: localIndex.
	^ClyDataSourceItem of: self value: self itemCursor currentItem! !

!ClyExpandedDataSource methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
		
	collapsedItems := SortedCollection sortBlock: [ :a :b | a position < b position ]! !

!ClyExpandedDataSource methodsFor: 'testing' stamp: ''!
isExpanded: aDataSourceItem

	^(collapsedItems includes: aDataSourceItem) not! !

!ClyExpandedDataSource methodsFor: 'accessing' stamp: ''!
collapsedItems: items
	collapsedItems := items! !

!ClyExpandedDataSource methodsFor: 'private' stamp: ''!
findCachedElementWith: anEnvironmentItem ifAbsent: absentBlock

	^collapsedItems
		detect: [ :each | each actualObject == anEnvironmentItem actualObject ]
		ifNone: absentBlock! !

!ClyExpandedDataSource methodsFor: 'accessing' stamp: ''!
numberOfRows
	^self itemCursor itemCount
		- (collapsedItems sum: [ :each | each childrenCount ])! !

!ClyExpandedDataSource methodsFor: 'private' stamp: ''!
updateExpandingItems
	self updateItems: collapsedItems.
	collapsedItems := collapsedItems reject: [ :each | each isRemoved ]! !

!ClyExpandedDataSource methodsFor: 'controlling' stamp: ''!
expand: aDataSourceItem
	queryView changeStateBy: [
		collapsedItems remove: aDataSourceItem.
	
		self expansionChanged]! !

!ClyExpandedDataSource methodsFor: 'testing' stamp: ''!
isInSameStateAs: anotherDataSource

	(super isInSameStateAs: anotherDataSource) ifFalse: [ ^false ].
	
	collapsedItems size = anotherDataSource collapsedItems size ifFalse: [ ^false ].
	^collapsedItems allSatisfy: [ :myItem | 
		anotherDataSource collapsedItems anySatisfy: [ :anotherItem | 
			myItem isSameAs: anotherItem ] ]! !

!ClyExpandedDataSource methodsFor: 'copying' stamp: ''!
initializeForBrowserStateSpanshot
	| copy |
	super initializeForBrowserStateSpanshot.
	copy := collapsedItems collect: [ :each | 
		each copyForBrowserStateSnapshotOf: self ].
	collapsedItems := copy asSortedCollection: [ :a :b | a position < b position ].! !

!ClyExpandedDataSource methodsFor: 'accessing' stamp: ''!
collapsedItems
	^collapsedItems! !

!ClyExpandedDataSource methodsFor: 'testing' stamp: ''!
doesItemHaveChildren: aDataSourceItem
	| environmentItem |
	environmentItem := aDataSourceItem browserItem.
	
	^environmentItem localHierarchySize > 0! !

!ClyExpandedDataSource methodsFor: 'controlling' stamp: ''!
collapse: aDataSourceItem
	queryView changeStateBy: [
		collapsedItems removeAllSuchThat: [ :each |
			aDataSourceItem hasChildAt: each position].
		collapsedItems add: aDataSourceItem.
	
		self expansionChanged]! !

!ClyExpandedDataSource methodsFor: 'testing' stamp: ''!
definesChildren
	^true! !

!ClyExpectedFailedTestMethodsQuery commentStamp: ''!
I return all test methods which are marked with <expectedFailure> pragma!
!ClyExpectedFailedTestMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^aMethod hasPragmaNamed: #expectedFailure! !

!ClyExpectedFailedTestMethodsQuery methodsFor: 'printing' stamp: ''!
description
	^'expected failures'! !

!ClyExpectedFailedTestMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: ClyTestedClassMockTest >> #testExpectedFailure in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope 
		of: ClyTestedClassMockTest >> #testOne in: environment).
	self assert: query checkEmptyResult! !

!ClyExpectedFailedTestMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromTwoMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyTestedClassMockTest >> #testExpectedFailure. 
		ClyTestedClassMockTest >> #testOne}.
	
	self assert: foundSelectors sorted asArray equals: #(testExpectedFailure)! !

!ClyExpectedFailedTestMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyExpectedFailedTestMethodsQuery from: ClyClassScope of: ClyTestedClassMockTest in: environment! !

!ClyExpectedFailedTestMethodsQueryTest methodsFor: 'tests' stamp: ''!
testSelectsTestMethodWithExpectedFailurePragma
	
	self assert: (query selectsMethod: ClyTestedClassMockTest >> #testExpectedFailure)! !

!ClyExpectedFailedTestMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsMethodWithoutExpectedFailurePragma
	
	self deny: (query selectsMethod: ClyTestedClassMockTest >> #testOne)! !

!ClyExpectedFailureMethodGroupProvider commentStamp: ''!
I provide "expected failures" method group when test cases include tests marked with <expectedFailure> pragma!
!ClyExpectedFailureMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyExpectedFailedTestMethodsQuery from: aClassScope! !

!ClyExpectedFailureMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'expected failures' priority: -2 on: aMethodQuery! !

!ClyExpectedFailureMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyExpectedFailureMethodGroupProvider! !

!ClyExpectedFailureMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	^ClyTestedClassMockTest! !

!ClyExplicitAbstractClassExampleMock commentStamp: ''!
I am example of a class which is explicitly definined as abstract by overrideing class side method #isAbstract!
!ClyExplicitAbstractClassExampleMock class methodsFor: 'testing' stamp: ''!
isAbstract
	^true! !

!ClyExtendedClassGroupProvider commentStamp: ''!
I provide "extensions" class group. I add this group only when package has extensions.!
!ClyExtendedClassGroupProvider methodsFor: 'enumerating' stamp: ''!
createClassQueryFrom: aPackageScope
	^ClyAllClassesQuery from: (aPackageScope asScope: ClyPackageExtensionScope)! !

!ClyExtendedClassGroupProvider methodsFor: 'enumerating' stamp: ''!
createClassGroupFor: aClassQuery from: aPackageScope
	^ClyClassGroup named: 'Extensions' priority: 0 on: aClassQuery! !

!ClyExtendedClassGroupProviderTest methodsFor: 'running' stamp: ''!
packageSampleWhichHasGroup
	^ClyClass1FromP1Mock package! !

!ClyExtendedClassGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyExtendedClassGroupProvider! !

!ClyExtendedClassTag commentStamp: ''!
I am used to mark classes which are only extended in given scope.
In the full browser all extended classes (in grey color) are tagged with me!
!ClyExtendedMethodGroupProvider commentStamp: ''!
I provide 'extensions' method group!
!ClyExtendedMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyAllExtensionMethodsQuery from: aClassScope! !

!ClyExtendedMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	
	| subgroupsQuery |
	subgroupsQuery := ClyExtendingPackagesQuery 
		from: aClassScope as: ClyGroupedExtendingPackagesResult new.
		
	^ClyMethodGroup 
		named: 'extensions' priority: 9
		on: aMethodQuery withSubgroupsFrom: subgroupsQuery! !

!ClyExtendedMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyExtendedMethodGroupProvider! !

!ClyExtendedMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	^ClySubclassLOfClass0FromPExtendedByP1Mock! !

!ClyExtendingPackagesQuery commentStamp: ''!
I return packages which extends methods available from given scope.

My scope should understand #methodsDo: which I use to filter all extensions and collect their extending packages.

I was mainly introduced to implement #extensions method group in full browser. When you expand it you see all packages which extends the class.
But I can give you extending package from any scope. For example you can retrieve all packages in the system which extends some class: 

	(ClyExtendingPackages from: ClyNavigationEnvironment currentImageScope) execute.
!
!ClyExtendingPackagesQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	^scope includesMethodsAffectedBy: aSystemAnnouncement! !

!ClyExtendingPackagesQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	| packages classPackage |
	packages := IdentitySet new.
	
	scope methodsDo: [ :eachMethod | 
		classPackage := eachMethod origin package.
		(eachMethod isDefinedInPackage: classPackage) ifFalse: [ 
			eachMethod package ifNotNil: [ :p | packages add: p]]].
		
	aQueryResult fillWith: packages! !

!ClyExtendingPackagesQuery methodsFor: 'printing' stamp: ''!
description

	^'extending packages'! !

!ClyExtendingPackagesQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	
	| classPackage |
	scope methodsDo: [ :eachMethod | 
		classPackage := eachMethod origin package.
		(eachMethod isDefinedInPackage: classPackage) ifFalse: [ 
			eachMethod package ifNotNil: [ :p | ^false]]].
		
	^true! !

!ClyExtendingPackagesQueryTest methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests' stamp: ''!
testFromClassWhichTraitIsExtendedButNotItself
	"I'm tagging this expected failure because I'm not sure now if it is appropriate to keep 
	 or not with the removal of the 'traits-as-multiple-inheritance' stuff."
	<expectedFailure>

	self queryFromScope: ClyClassScope of: ClyClassWithTraits.
	self assert: resultItems size equals: 0! !

!ClyExtendingPackagesQueryTest methodsFor: 'tests' stamp: ''!
testFromSingleClass

	self queryFromScope: ClyClassScope of: ClySubclassLOfClass0FromPExtendedByP1Mock.

	self assert: resultItems asSet equals: {ClyClass1FromP1Mock package} asSet! !

!ClyExtendingPackagesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyClassScope of: ClySubclassLOfClass0FromPExtendedByP1Mock in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyClassScope of: ClyClass1FromP1Mock in: environment).
	self assert: query checkEmptyResult! !

!ClyExtendingPackagesQueryTest methodsFor: 'tests' stamp: ''!
testFromClassWhichIncludesTwoProtocolExtensionsOfSamePackage

	self queryFromScope: ClyClassScope of: ClyClass9FromPExtendedByP5Mock.

	self assert: resultItems asSet equals: {ClyClass7WithTag1FromP5Mock package} asSet! !

!ClyExtendingPackagesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyExtendingPackagesQuery from: ClyClassScope of: Object in: environment! !

!ClyExtendingPackagesQueryTest methodsFor: 'tests' stamp: ''!
testFromTwoClasses

	self queryFromScope: ClyClassScope ofAll: {
		ClyClass9FromPExtendedByP5Mock. ClySubclassLOfClass0FromPExtendedByP1Mock }.

	self assert: resultItems asSet equals: {ClyClass1FromP1Mock package. ClyClass7WithTag1FromP5Mock package} asSet! !

!ClyExtensionLastSortedClassResult commentStamp: ''!
I am a special class query result which put extension classes to the end of list.
I am used in class view to show all extensions in the bottom. 

To detect which classes are extensions I use the scope from where the query was executed. In fact I detect which classes are defined in building query scope. And the rest are extensions.
For this logic I find in scope the package which defines given class. So I expect that query scope understands #packagesDo:. Now it is ClyPackageScope and ClyProjectScope.
Look at #isQueryScopeDefinesClass: for details.

And at last step I format classes from each part. I use #baseQueryResult for this.
I can be configured to show classes in simple sorted way: 

	ClyExtensionLastSortedClasses simple 
	
or to show classes in sorted hierarchy: 

	ClyExtensionLastSortedClasses hierarchical
	
For other cases you can instantiate me by #using: method: 

	ClyExtensionLastSortedClasses using: ClySubclassHierarchy inverse asQueryResult
 
In addition I mark all extended classes with ClyExtendedClassTag which is used by UI to work with such classes differently.

Also notice that I am a kind of ClyBrowserQueryResult. So I convert all given classes to the ClyBrowserItem instances.

Internal Representation and Key Implementation Points.

    Instance Variables
	baseQueryResult:		<ClyQueryResult>!
!ClyExtensionLastSortedClassResult methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ baseQueryResult = anObject baseQueryResult! !

!ClyExtensionLastSortedClassResult methodsFor: 'accessing' stamp: ''!
baseQueryResult
	^ baseQueryResult! !

!ClyExtensionLastSortedClassResult methodsFor: 'comparing' stamp: ''!
hash
	^super hash bitXor: baseQueryResult hash! !

!ClyExtensionLastSortedClassResult methodsFor: 'building' stamp: ''!
buildItemsFrom: classes

	| subResult |
	subResult := baseQueryResult prepareNewFor: buildingQuery in: environment.
	subResult buildWith: classes.
	^subResult items collect: [:each | each asCalypsoBrowserItem ]! !

!ClyExtensionLastSortedClassResult methodsFor: 'building' stamp: ''!
isQueryScopeDefinesClass: aClass

	| classPackage |
	classPackage := aClass package.
	buildingQuery scope packagesDo: [ :each | 
		(each isAboutPackage: classPackage) ifTrue: [ ^true ]].
	^false! !

!ClyExtensionLastSortedClassResult methodsFor: 'accessing' stamp: ''!
baseQueryResult: anObject
	baseQueryResult := anObject! !

!ClyExtensionLastSortedClassResult methodsFor: 'building' stamp: ''!
buildExtensionItemsFrom: classes

	| extensions |
	extensions := self buildItemsFrom: classes.
	extensions do: [ :each | each markWith: ClyExtendedClassTag ].
	^extensions! !

!ClyExtensionLastSortedClassResult methodsFor: 'building' stamp: ''!
fillWith: classes

	| definedClasses extensions |
	definedClasses := IdentitySet withAll: classes.
	extensions := OrderedCollection new.
	classes do: [ :each | 
		(self isQueryScopeDefinesClass: each) ifFalse: [ 
			definedClasses remove: each.
			extensions add: each]].
	items := self buildItemsFrom: definedClasses.
	items addAll: (self buildExtensionItemsFrom: extensions)! !

!ClyExtensionLastSortedClassResult class methodsFor: 'instance creation' stamp: ''!
hierarchical
	^self using: ClyHierarchicallySortedClassesResult new! !

!ClyExtensionLastSortedClassResult class methodsFor: 'instance creation' stamp: ''!
simple
	^self using: (ClySortedQueryResult using: ClySortByNameFunction ascending)! !

!ClyExtensionLastSortedClassResult class methodsFor: 'instance creation' stamp: ''!
using: aQueryResult
	^self new
		baseQueryResult: aQueryResult! !

!ClyExtensionLastSortedClassesTest methodsFor: 'tests' stamp: ''!
testCreationSimpleInstance

	queryResult := ClyExtensionLastSortedClassResult simple.
	
	self assert: queryResult baseQueryResult class equals: ClySortedQueryResult! !

!ClyExtensionLastSortedClassesTest methodsFor: 'tests' stamp: ''!
testCreationHierarchicalInstance

	queryResult := ClyExtensionLastSortedClassResult hierarchical.
	
	self assert: queryResult baseQueryResult class equals: ClyHierarchicallySortedClassesResult! !

!ClyExtensionLastSortedClassesTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyExtensionLastSortedClassResult simple! !

!ClyExtensionLastSortedClassesTest methodsFor: 'tests' stamp: ''!
testFillingHierarchicalInstance
	query := ClyAllClassesQuery from: ClyPackageScope of: ClyClass1FromP1Mock package in: environment.
	queryResult := ClyExtensionLastSortedClassResult hierarchical prepareNewFor: query in: environment..
	
	queryResult buildWith: {
		ClySubclassLOfClass0FromPExtendedByP1Mock. ClySubclassN1OfClass1FromP1Mock.  ClyClass1FromP1Mock}.
	
	self assertItems: {ClyClass1FromP1Mock. 0. ClySubclassN1OfClass1FromP1Mock. 1.
		 ClySubclassLOfClass0FromPExtendedByP1Mock. 0}.
	self assert: (items last isMarkedWith: ClyExtendedClassTag).
	self deny: (items first isMarkedWith: ClyExtendedClassTag).
	self deny: (items second isMarkedWith: ClyExtendedClassTag)! !

!ClyExtensionLastSortedClassesTest methodsFor: 'tests' stamp: ''!
testFillingSimpleInstance
	query := ClyAllClassesQuery from: ClyPackageScope of: ClyClass1FromP1Mock package in: environment.
	queryResult := ClyExtensionLastSortedClassResult simple prepareNewFor: query in: environment.

	queryResult buildWith: {
		ClySubclassLOfClass0FromPExtendedByP1Mock. ClySubclassN1OfClass1FromP1Mock.  ClyClass1FromP1Mock}.
	
	self assertItems: {ClyClass1FromP1Mock. 0. ClySubclassN1OfClass1FromP1Mock. 0.
		 ClySubclassLOfClass0FromPExtendedByP1Mock. 0}.
	self assert: (items last isMarkedWith: ClyExtendedClassTag).
	self deny: (items first isMarkedWith: ClyExtendedClassTag).
	self deny: (items second isMarkedWith: ClyExtendedClassTag)! !

!ClyExtensionLastSortedClassesTest methodsFor: 'tests' stamp: ''!
testFillingWithExtendedClassSide
	query := ClyAllClassesQuery from: ClyPackageScope of: ClyClass1FromP1Mock package in: environment.
	queryResult := ClyExtensionLastSortedClassResult simple prepareNewFor: query in: environment.
	
	queryResult buildWith: {
		ClySubclassLOfClass0FromPExtendedByP1Mock class. ClyClass2FromP1Mock.  ClyClass1FromP1Mock}.
	
	self assertItems: {ClyClass1FromP1Mock. 0. ClyClass2FromP1Mock. 0.
		 ClySubclassLOfClass0FromPExtendedByP1Mock class. 0}.
	self assert: (items last isMarkedWith: ClyExtendedClassTag)! !

!ClyExtensionLastSortedClassesTest methodsFor: 'tests' stamp: ''!
testHasDefaultBaseQueryResultByDefault

	self assert: queryResult baseQueryResult class equals: ClySortedQueryResult! !

!ClyExtensionLastSortedClassesTest methodsFor: 'tests' stamp: ''!
testComparisonToSimilarResultButWithWithDifferentBaseResult
	| result2 |
	queryResult := ClyExtensionLastSortedClassResult simple.
	result2 := ClyExtensionLastSortedClassResult hierarchical.

	self deny: queryResult equals: result2! !

!ClyExternalPackageMethodGroup commentStamp: ''!
I am group of class extension methods from concrete package.
 
I represent subgroups of "extensions" method group.

Internal Representation and Key Implementation Points.

    Instance Variables
	package:		<RPackage>!
!ClyExternalPackageMethodGroup methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem
	super decorateTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph definitionIcon: #protocolExtensionIcon.
		
	(anItemCellMorph browser isPackagePartOfSelection: self package)
		ifTrue: [ anItemCellMorph label emphasis: TextEmphasis bold emphasisCode]
		ifFalse: [ anItemCellMorph label color: Smalltalk ui theme classExtensionColor].! !

!ClyExternalPackageMethodGroup methodsFor: 'operations' stamp: ''!
importMethod: aMethod 
	super importMethod: aMethod.
	
	self package addMethod: aMethod.	
	aMethod tagWith: ('*', self package name) asSymbol! !

!ClyExternalPackageMethodGroup methodsFor: 'accessing' stamp: ''!
package
	^ methodQuery package! !

!ClyExternalPackageMethodGroup class methodsFor: 'testing' stamp: ''!
isEditableGroup
	^true! !

!ClyExternalPackageMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethodsFrom: aClassScope packagedIn: aPackage

	| methodQuery |
	methodQuery := ClyPackageExtensionMethodsQuery of: aPackage from: aClassScope.
	
	"Priority is the value to be greater than all extensions group 
	in case when they are in same list (when extended class is selected)"
	^self named: aPackage name priority: 8.9 on: methodQuery! !

!ClyFFIEnvironmentPlugin commentStamp: ''!
I am special plugin which analyzes ffi methods and mark them with ClyFFIMethodTag.
Also I provide ffi method group to see all ffi calls together!
!ClyFFIEnvironmentPlugin methodsFor: 'method groups' stamp: ''!
collectMethodGroupProviders 
	^{ClyFFIMethodGroupProvider new}! !

!ClyFFIEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod

	aMethod isFFIMethod ifTrue: [ 
		anItem markWith: ClyFFIMethodTag]! !

!ClyFFIMethodGroupProvider commentStamp: ''!
I provide "FFI calls" method groups when given classes define them!
!ClyFFIMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyFFIMethodQuery from: aClassScope! !

!ClyFFIMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'ffi calls' on: aMethodQuery! !

!ClyFFIMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyFFIMethodGroupProvider! !

!ClyFFIMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	^ClyClassWithFFIMethods! !

!ClyFFIMethodQuery commentStamp: ''!
I return all FFI methods from my scope!
!ClyFFIMethodQuery methodsFor: '*Calypso-SystemPlugins-FFI-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph definitionIcon: #recoverLostChanges! !

!ClyFFIMethodQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^ aMethod isFFIMethod! !

!ClyFFIMethodQuery methodsFor: 'printing' stamp: ''!
description
	^'ffi calls'! !

!ClyFFIMethodTableDecorator commentStamp: ''!
I decorate table with special icon for ffi methods!
!ClyFFIMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyFFIMethodTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	^aDataSourceItem isMarkedWith: ClyFFIMethodTag! !

!ClyFFIMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	
	anItemCellMorph definitionIcon: #recoverLostChanges! !

!ClyFFIMethodTag commentStamp: ''!
I mark method that it is FFI call!
!ClyFFIMethodsTest methodsFor: 'tests' stamp: ''!
testNotSelectsNotFFIMethod

	self deny: (query selectsMethod: ClyClassWithFFIMethods >> #notFFIMethod)! !

!ClyFFIMethodsTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: (ClyClassWithFFIMethods >> #ffiMethod)
		in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyClassWithFFIMethods >> #notFFIMethod)
		in: environment).
	self assert: query checkEmptyResult! !

!ClyFFIMethodsTest methodsFor: 'tests' stamp: ''!
testFromTwoMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyClassWithFFIMethods >> #ffiMethod. 
		ClyClassWithFFIMethods >> #notFFIMethod}.
	
	self assert: foundSelectors sorted asArray equals: #(ffiMethod)! !

!ClyFFIMethodsTest methodsFor: 'tests' stamp: ''!
testSelectsFFIMethod

	self assert: (query selectsMethod: ClyClassWithFFIMethods >> #ffiMethod)! !

!ClyFFIMethodsTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyFFIMethodQuery from: ClyClassScope of: Object in: environment! !

!ClyFailedTestGroupProvider commentStamp: ''!
I provide "failed tests" method group when there are failed tests in given test cases!
!ClyFailedTestGroupProvider methodsFor: 'testing' stamp: ''!
isStatic
	^true! !

!ClyFailedTestGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyFailedTestMethodsQuery from: aClassScope! !

!ClyFailedTestGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'failed tests' priority: -1 on: aMethodQuery! !

!ClyFailedTestMethodsQuery commentStamp: ''!
I return all failed tests from given test cases available in my scope!
!ClyFailedTestMethodsQuery methodsFor: '*Calypso-SystemPlugins-SUnit-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	"we can detect that yellow color is needed but it looks bad"
	anItemCellMorph label color: Color red! !

!ClyFailedTestMethodsQuery methodsFor: 'item group decoration' stamp: ''!
decorateItemGroup: methodGroupItem
	| property |
	super decorateItemGroup: methodGroupItem.
	
	property := 	ClyTestResultProperty new.
	scope classesDo: [:testCase | | failures errors |
		(testCase isTestCase and: [testCase isAbstract not]) ifTrue: [ 
			failures := (testCase history at: #failures) size.
			errors := (testCase history at: #errors) size.
			property accumulateFailures: failures andErrors: errors]
	].	
	methodGroupItem addProperty: property! !

!ClyFailedTestMethodsQuery methodsFor: 'testing' stamp: ''!
buildResult: aQueryResult
	| failedTests |
	failedTests := OrderedCollection new.
	scope classesDo: [ :each | each isTestCase ifTrue: [
		(each history at: #failures) do: [ :testSelector |
			(each lookupSelector: testSelector) ifNotNil: [ :method | 
				failedTests add: method ]].
		(each history at: #errors) do: [ :testSelector |
			(each lookupSelector: testSelector) ifNotNil: [ :method | 
				failedTests add: method ]].
	]].
	aQueryResult fillWith: failedTests! !

!ClyFailedTestMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'failed tests'! !

!ClyFailedTestMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	
	^aMethod isTestMethod and: [aMethod isPassedTest not]! !

!ClyFailedTestMethodsQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	scope classesDo: [ :each | 
		(each isTestCase and: [each isAbstract not
			and: [ each hasFailedTest or: [ each hasErrorTest ] ]])
				ifTrue: [ ^false ]].
	^true! !

!ClyFileOutCommand commentStamp: ''!
I am a command to file out given objects.
I simply call #fileOut for each of them.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	codeObjects:		<Colletion of<Object>>!
!ClyFileOutCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'File Out'! !

!ClyFileOutCommand methodsFor: 'execution' stamp: ''!
execute
	
	codeObjects do: [ :each | each fileOut ]! !

!ClyFileOutCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	codeObjects := aToolContext selectedObjects! !

!ClyFileOutCommand class methodsFor: 'activation' stamp: ''!
browserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClySystemBrowserContext! !

!ClyFileOutCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext hasSelectedItems! !

!ClyFilterQuery commentStamp: ''!
I represent query which filters results of another query.
My instances can be created by:

	ClyFilterQuery for: anQuery filter: anItemFilter

Or you can simply convert any query using filter: 

	aQuery filteredBy: anItemFilter

During execution I evaluate #actualQuery and filter received items with my #itemFilter.
Look at method #buildResult: for details.

itemFilter is a kind of ClyItemFilter. For example there is ClyItemNameFilter which matches items by name using specified pattern. Look ClyItemFilter comments for details. 

Internal Representation and Key Implementation Points.

    Instance Variables
	itemFilter:		<ClyItemFilter>!
!ClyFilterQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ itemFilter = anObject itemFilter! !

!ClyFilterQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: itemFilter hash! !

!ClyFilterQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	
	| fullResult filteredItems |
	fullResult := self actualQuery execute.
	filteredItems := fullResult items 
		select: [ :each | itemFilter matches: each ] 
		thenCollect: [ :each | each adoptForNewCalypsoQuery].
	aQueryResult items: filteredItems! !

!ClyFilterQuery methodsFor: 'printing' stamp: ''!
description
	^super description, ' filtered by ', itemFilter printCriteria! !

!ClyFilterQuery methodsFor: 'accessing' stamp: ''!
itemFilter
	^ itemFilter! !

!ClyFilterQuery methodsFor: 'accessing' stamp: ''!
itemFilter: anObject
	itemFilter := anObject! !

!ClyFilterQuery class methodsFor: 'instance creation' stamp: ''!
for: originalQuery filter: aClyItemFilter
	^(self with: {originalQuery})
		itemFilter: aClyItemFilter! !

!ClyFilterQueryTest methodsFor: 'tests' stamp: ''!
testExecution
	| scope mainQuery |
	scope := ClyExampleScope ofAll: {self class superclass. self class} in: environment.
	mainQuery := ClyReturningScopeBasisExampleQuery from: scope.
	query subqueries: {mainQuery}.
	
	self executeQuery.
	
	self assert: resultItems size equals: 1.
	self assert: resultItems first equals: self class! !

!ClyFilterQueryTest methodsFor: 'tests' stamp: ''!
testExecutionOverExistingQuery
	| scope mainQuery |
	scope := ClyExampleScope ofAll: {self class superclass. self class} in: environment.
	mainQuery := ClyReturningScopeBasisExampleQuery from: scope.
	query := mainQuery filteredBy: query itemFilter.
	
	result := query execute.
	resultItems := result items.
	self assert: resultItems size equals: 1.
	self assert: resultItems first equals: self class! !

!ClyFilterQueryTest methodsFor: 'running' stamp: ''!
queryClass
	^ClyFilterQuery! !

!ClyFilterQueryTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewScopeBasisShouldKeepFilter
	| convertedQuery |

	convertedQuery := query withScopeOf: #(newBasis).
	
	self assert: convertedQuery itemFilter equals: query itemFilter! !

!ClyFilterQueryTest methodsFor: 'tests' stamp: ''!
createQuery
	^ ClyFilterQuery
		for: (ClyReturningScopeBasisExampleQuery
				from: ClyExampleScope of: self class in: environment)
		filter: (ClyItemNameFilter substringPattern: 'FilterQueryTest')! !

!ClyFilterQueryTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewScopeShouldKeepFilter
	| newScope convertedQuery |
	newScope := ClyExample2Scope of: #someBasis in: environment.
	
	convertedQuery := query withScope: newScope.
	
	self assert: convertedQuery itemFilter equals: query itemFilter! !

!ClyFilteringCritiqueQuery commentStamp: ''!
I am abstract critique query which subclasses wrap another critique query and filter result critiques according to their logic.

To create my instances use following expression: 

	ClyFilteringCritiqueQuery filter: aCritiqueQuery from: aScope
	
Internal Representation and Key Implementation Points.

    Instance Variables
	baseCritiqueQuery:		<ClyCritiqueQuery>!
!ClyFilteringCritiqueQuery methodsFor: 'accessing' stamp: ''!
scope: aScope
	super scope: aScope.
	baseCritiqueQuery scope: aScope! !

!ClyFilteringCritiqueQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
		
	^baseCritiqueQuery = anObject baseCritiqueQuery! !

!ClyFilteringCritiqueQuery methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	baseCritiqueQuery := ClyAllBasisCritiqueQuery new! !

!ClyFilteringCritiqueQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: baseCritiqueQuery hash! !

!ClyFilteringCritiqueQuery methodsFor: 'accessing' stamp: ''!
baseCritiqueQuery
	^ baseCritiqueQuery! !

!ClyFilteringCritiqueQuery methodsFor: 'testing' stamp: ''!
selectsCritique: aCritique
	self subclassResponsibility! !

!ClyFilteringCritiqueQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
		
	| allCritiques filtered |
	allCritiques := baseCritiqueQuery execute.
	
	filtered := allCritiques items select: [:each | self selectsCritique: each].

	aQueryResult fillWith: filtered! !

!ClyFilteringCritiqueQuery methodsFor: 'accessing' stamp: ''!
baseCritiqueQuery: aCritiqueQuery
	baseCritiqueQuery := scope adoptQuery: aCritiqueQuery! !

!ClyFilteringCritiqueQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	| allCritiques |
	allCritiques := baseCritiqueQuery execute.
	
	^(allCritiques items 
		anySatisfy: [:each | self selectsCritique: each]) not! !

!ClyFilteringCritiqueQuery class methodsFor: 'instance creation' stamp: ''!
filter: aCritiqueQuery from: aScope

	^(self from: aScope)
		baseCritiqueQuery: aCritiqueQuery! !

!ClyFilteringCritiqueQueryTest methodsFor: 'tests' stamp: ''!
testHasBasisCritiquesAsBaseQuery

	query := query class new.
	self assert: query baseCritiqueQuery class equals: ClyAllBasisCritiqueQuery! !

!ClyFilteringCritiqueQueryTest methodsFor: 'tests' stamp: ''!
testComparisonWithSimilarQueryBasedOnDifferentBaseCritiqueQuery
	| query2 |
	query baseCritiqueQuery: ClyAllBasisCritiqueQuery new.
	query2 := self createQuery.
	query2 baseCritiqueQuery: ClyAllMethodCritiqueQuery new.

	self deny: query equals: query2! !

!ClyFilteringCritiqueQueryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyFilteringCritiqueQueryTest! !

!ClyFindClassCommand commentStamp: ''!
I am a command to find class and show it in the browser.

By default I am executed by cmd+f shortcut!
!ClyFindClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Find class'! !

!ClyFindClassCommand methodsFor: 'execution' stamp: ''!
execute

	| class |
	class := browser searchDialog 
		requestSingleObject: 'Choose class' from: ClyAllClassesQuery sorted.
	
	browser selectClass: class! !

!ClyFindClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallFindIcon! !

!ClyFindClassCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyFullBrowserPackageContext! !

!ClyFindClassCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $f meta for: ClyFullBrowserGlobalContext! !

!ClyFindMethodInBrowserCommand commentStamp: ''!
I am a command to find method in methodView of full browser.
I request user with search dialog using method view query.
So dialog shows all methods from method view panel.

By default I am activated by cmd+f.!
!ClyFindMethodInBrowserCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Find method'! !

!ClyFindMethodInBrowserCommand methodsFor: 'execution' stamp: ''!
execute
	| method |
	
	method := browser searchDialog 
		requestSingleObject: 'Choose method' from: browser methodView query.
	
	browser selectMethod: method! !

!ClyFindMethodInBrowserCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallFindIcon! !

!ClyFindMethodInBrowserCommand class methodsFor: 'menu' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyFullBrowserMethodContext! !

!ClyFindMethodInBrowserCommand class methodsFor: 'menu' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $f meta for: ClyFullBrowserMethodContext! !

!ClyFixCritiqueCommand commentStamp: ''!
I am a command to fix given critique by applying proposed changes.
I open changes preview on them!
!ClyFixCritiqueCommand methodsFor: 'table decoration' stamp: ''!
description
	^'Automatically resolve the issue'! !

!ClyFixCritiqueCommand methodsFor: 'execution' stamp: ''!
execute

	(ChangesBrowser changes: { critique change }) open! !

!ClyFixCritiqueCommand methodsFor: 'initialization' stamp: ''!
defaultMenuIconName
	^#repairIcon! !

!ClyFixCritiqueCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aCriticContext
	(super canBeExecutedInContext: aCriticContext) ifFalse: [ ^false ].
	
	^aCriticContext lastSelectedItem isMarkedWith: ClyCritiqueFixableTag! !

!ClyFlagMethodGroupProvider commentStamp: ''!
I provide "flags" method groups when given classes define methods with flag!
!ClyFlagMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyFlaggingMethodsQuery from: aClassScope! !

!ClyFlagMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'flags' priority: 8.3 on: aMethodQuery! !

!ClyFlagMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyFlagMethodGroupProvider! !

!ClyFlagMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	^ClyClassWithFlags! !

!ClyFlagMethodTableDecorator commentStamp: ''!
I decorate methods with flag in the table with special icon!
!ClyFlagMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyFlagMethodTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	
	^aDataSourceItem isMarkedWith: ClyMethodFlag! !

!ClyFlagMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
priority
	^900! !

!ClyFlagMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	
	| icon |
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	
	icon := anItemCellMorph definitionIcon: #flagIcon.
	icon setBalloonText: 'Method has a flag'! !

!ClyFlaggingMethodsQuery commentStamp: ''!
I return all methods which send #flag: message!
!ClyFlaggingMethodsQuery methodsFor: '*Calypso-SystemPlugins-Flags-Browser' stamp: ''!
decorateResultMethodEditor: aMethodEditor

	aMethodEditor selectAnySelector: #(flag:)! !

!ClyFlaggingMethodsQuery methodsFor: '*Calypso-SystemPlugins-Flags-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	| icon |
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	icon := anItemCellMorph definitionIcon: #flagIcon.
	icon setBalloonText: 'There are methods with flag'! !

!ClyFlaggingMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^aMethod sendsAnySelectorOf: #(flag:)! !

!ClyFlaggingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsMethodWithoutFlag

	self deny: (query selectsMethod: ClyClassWithFlags >> #methodWithoutFlag)! !

!ClyFlaggingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testSelectsMethodWithFlag

	self assert: (query selectsMethod: ClyClassWithFlags >> #methodWithFlag)! !

!ClyFlaggingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: (ClyClassWithFlags >> #methodWithFlag)
		in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyClassWithFlags >> #methodWithoutFlag)
		in: environment).
	self assert: query checkEmptyResult! !

!ClyFlaggingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromTwoMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyClassWithFlags >> #methodWithFlag. 
		ClyClassWithFlags >> #methodWithoutFlag}.
	
	self assert: foundSelectors sorted asArray equals: #(methodWithFlag)! !

!ClyFlaggingMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyFlaggingMethodsQuery from: ClyClassScope of: Object in: environment! !

!ClyFlagsEnvironmentPlugin commentStamp: ''!
I am special plugin which mark methods which have any flag.
Also I provide flags method group to see all such methods together!
!ClyFlagsEnvironmentPlugin methodsFor: 'method groups' stamp: ''!
collectMethodGroupProviders 
	^{ClyFlagMethodGroupProvider new}! !

!ClyFlagsEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod

	(aMethod sendsAnySelectorOf: #(flag:)) ifTrue: [ 
		anItem markWith: ClyMethodFlag]! !

!ClyFluidClassDefinitionSwitchMorph commentStamp: ''!
I am a status bar item for class tools to switch between old class definition and new one which is based on slots
 
Internal Representation and Key Implementation Points.

    Instance Variables
	checkbox:		<CheckboxMorph>!
!ClyFluidClassDefinitionSwitchMorph methodsFor: 'configure' stamp: ''!
usesSlotBasedDefinition

	^ ClassDefinitionPrinter showFluidClassDefinition! !

!ClyFluidClassDefinitionSwitchMorph methodsFor: 'configure' stamp: ''!
toggle

	ClassDefinitionPrinter toggleShowFluidClassDefinition.
	ownerTool update! !

!ClyFluidClassDefinitionSwitchMorph methodsFor: 'building' stamp: ''!
build
	
	checkbox := CheckboxMorph 
		on: self selected: #usesSlotBasedDefinition changeSelected: #toggle.
	checkbox
		getLabelSelector: #definitionTypeLabel;
		labelClickable: true;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		setBalloonText:	'To switch between old and new fluid class definition. The fluid definition will be default in the future'.
	self addMorph: checkbox! !

!ClyFluidClassDefinitionSwitchMorph methodsFor: 'accessing' stamp: ''!
definitionTypeLabel
	^ 'Fluid'! !

!ClyFormatAsReadSwitchMorph commentStamp: ''!
I am a tool to force method editor to automatically format given source code.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	checkbox:		<Object>!
!ClyFormatAsReadSwitchMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	checkbox := CheckboxMorph 
		on: self selected: #formatAsYouRead changeSelected: #toggle.
	checkbox
		getLabelSelector: #formatAsYouReadLabel;
		labelClickable: true;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		setBalloonText:
			'Autoformat code without editing. Useful when reading some old/unformatted code. You can configure your own format in the settings browser.'.
	self addMorph: checkbox! !

!ClyFormatAsReadSwitchMorph methodsFor: 'operations' stamp: ''!
toggle
	| formatter isDirty |
	formatter := RBProgramNode formatterClass.
	formatter formatAsYouReadPolicy
		ifTrue: [ 
			formatter formatAsYouReadPolicy: false. 
			textMorph model canDiscardEdits
				ifTrue: [ textMorph model cancelEdits ] ]
		ifFalse: [ 
			formatter formatAsYouReadPolicy: true.
			isDirty := textMorph hasUnacceptedEdits.
			textMorph model	formatSourceCodeInView.
			isDirty ifFalse: [ textMorph model clearUserEdits ]]! !

!ClyFormatAsReadSwitchMorph methodsFor: 'formatting' stamp: ''!
formatAsYouReadLabel
	^ 'F'! !

!ClyFormatAsReadSwitchMorph methodsFor: 'formatting' stamp: ''!
formatAsYouRead
	 
	^ RBProgramNode formatterClass formatAsYouReadPolicy! !

!ClyFullBrowserClassContext commentStamp: ''!
I am a context of selected classes in full browser!
!ClyFullBrowserClassContext methodsFor: 'selection-classes' stamp: ''!
selectedClassItems
	^selectedItems! !

!ClyFullBrowserClassContext methodsFor: 'browser state' stamp: ''!
restoreBrowserState

	self browser selectClass: self lastSelectedClass! !

!ClyFullBrowserClassContext class methodsFor: 'selection strategy' stamp: ''!
selectionStrategy
	<classAnnotation>
	
	^ClyContextSelectionStrategyAnnotation for: ClyFullBrowserMorph selectionType: ClyClass! !

!ClyFullBrowserClassGroupContext commentStamp: ''!
I am a context of selected class groups in full browser!
!ClyFullBrowserClassGroupContext methodsFor: 'selection-class groups' stamp: ''!
selectedClassGroups
	^self selectedObjects! !

!ClyFullBrowserClassGroupContext methodsFor: 'testing' stamp: ''!
isPackageSelected
	^tool packageSelection isEmpty not! !

!ClyFullBrowserClassGroupContext methodsFor: 'testing' stamp: ''!
isClassGroupSelected
	^self hasSelectedItems! !

!ClyFullBrowserClassGroupContext methodsFor: 'testing' stamp: ''!
isClassTagSelected
	| classGroupClass |
	self isClassGroupSelected ifFalse: [ ^false ].
	
	classGroupClass := self lastSelectedItem type.
	
	^classGroupClass isBasedOnClassTag! !

!ClyFullBrowserClassGroupContext methodsFor: 'selection-class groups' stamp: ''!
lastSelectedClassGroup
	^self lastSelectedObject! !

!ClyFullBrowserClassGroupContext methodsFor: 'selection-class groups' stamp: ''!
lastSelectedClassTag
	
	^self lastSelectedObjectIn: self selectedClassTags! !

!ClyFullBrowserClassGroupContext methodsFor: 'selection-class groups' stamp: ''!
selectedClassTags
	
	^selectedItems 
		select: [ :each | each type isBasedOnClassTag ] 
		thenCollect: [ :each | each name ]! !

!ClyFullBrowserClassGroupContext class methodsFor: 'selection strategy' stamp: ''!
selectionStrategy
	<classAnnotation>
	
	^ClyContextSelectionStrategyAnnotation for: ClyFullBrowserMorph selectionType: ClyClassGroup! !

!ClyFullBrowserContext commentStamp: ''!
I represent a context of the full browser, i.e., a selected class, package, method, group of methods,...

I extend superclass interface with class and method groups information. 
And I keep meta level scope of the browser.
 
Internal Representation and Key Implementation Points.

Instance Variables
	metaLevelScope:		<ClyMetaLevelClassScope>!
!ClyFullBrowserContext methodsFor: 'tool controlling' stamp: ''!
showVariableNamed: varName
	tool selectVariableNamed: varName! !

!ClyFullBrowserContext methodsFor: 'selection-projects' stamp: ''!
lastSelectedProjectChild
	^self lastSelectedObjectIn: self selectedProjectChildren! !

!ClyFullBrowserContext methodsFor: 'tool controlling' stamp: ''!
showPackage: aPackage atClassTag: tagName
	tool selectPackage: aPackage atClassTag: tagName! !

!ClyFullBrowserContext methodsFor: 'selection-method groups' stamp: ''!
selectedMethodGroupClass

	^(self lastSelectedObjectIn: self selectedMethodGroupItems) type! !

!ClyFullBrowserContext methodsFor: 'selection-methods' stamp: ''!
selectedMethodItems
	^tool methodSelection items! !

!ClyFullBrowserContext methodsFor: 'accessing' stamp: ''!
metaLevelScope: anObject
	metaLevelScope := anObject! !

!ClyFullBrowserContext methodsFor: 'selection-method groups' stamp: ''!
isMethodGroupSelected
	^self selectedMethodGroupItems notEmpty! !

!ClyFullBrowserContext methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserContext
	^(super isSimilarTo: anotherBrowserContext)
		and: [ metaLevelScope == anotherBrowserContext metaLevelScope ]! !

!ClyFullBrowserContext methodsFor: 'accessing' stamp: ''!
currentMetaLevelOf: aClass
	^metaLevelScope metaLevelOf: aClass! !

!ClyFullBrowserContext methodsFor: 'selection-packages' stamp: ''!
selectedPackageItems
	^tool packageSelection items! !

!ClyFullBrowserContext methodsFor: 'accessing' stamp: ''!
metaLevelScope
	^ metaLevelScope! !

!ClyFullBrowserContext methodsFor: 'selection-projects' stamp: ''!
selectedProjects
	^self actualSelectionFrom: self selectedProjectItems! !

!ClyFullBrowserContext methodsFor: 'selection-projects' stamp: ''!
selectedProjectItems
	^tool projectSelection items! !

!ClyFullBrowserContext methodsFor: 'selection-projects' stamp: ''!
selectedProjectChildItems
	^tool projectChildrenSelection items! !

!ClyFullBrowserContext methodsFor: 'selection-method groups' stamp: ''!
selectedMethodGroups
	^self actualSelectionFrom: self selectedMethodGroupItems! !

!ClyFullBrowserContext methodsFor: 'selection-method groups' stamp: ''!
isSelectedMethodGroupEditable
	
	self isMethodGroupSelected ifFalse: [ ^false ].
	
	^self selectedMethodGroupClass isEditableGroup! !

!ClyFullBrowserContext methodsFor: 'selection-method groups' stamp: ''!
selectedMethodGroupItems
	^tool methodGroupSelection items! !

!ClyFullBrowserContext methodsFor: 'tool controlling' stamp: ''!
showMethodTag: tagName
	tool selectMethodGroupNamed: tagName! !

!ClyFullBrowserContext methodsFor: 'selection-classes' stamp: ''!
selectedClassItems
	^tool classSelection items! !

!ClyFullBrowserContext methodsFor: 'selection-classes' stamp: ''!
selectedClassSide
	"The browser (tool) has selected classes but the side from where browser show it can be instance side of class side.
	So this method return actual 'meta side' of selected class"
	^ tool currentMetaLevelOf: self lastSelectedClass! !

!ClyFullBrowserContext methodsFor: 'accessing' stamp: ''!
tool: aBrowser
	super tool: aBrowser.
	metaLevelScope := aBrowser metaLevelScope! !

!ClyFullBrowserContext methodsFor: 'selection-projects' stamp: ''!
lastSelectedProject
	^self lastSelectedObjectIn: self selectedProjects! !

!ClyFullBrowserContext methodsFor: 'selection-packages' stamp: ''!
isClassTagSelected
	| groups |
	groups := tool classGroupSelection.
	groups isEmpty ifTrue: [ ^false ].
	^groups lastSelectedItem type isBasedOnClassTag! !

!ClyFullBrowserContext methodsFor: 'selection-projects' stamp: ''!
selectedProjectChildren
	^self actualSelectionFrom: self selectedProjectChildItems! !

!ClyFullBrowserContext methodsFor: 'selection-projects' stamp: ''!
isProjectChildSelected
	^self selectedProjectChildItems notEmpty! !

!ClyFullBrowserContext methodsFor: 'selection-method groups' stamp: ''!
lastSelectedMethodGroup
	^self lastSelectedObjectIn: self selectedMethodGroups! !

!ClyFullBrowserContext methodsFor: 'selection-packages' stamp: ''!
lastSelectedClassTag
	| tagItem |
	tagItem := tool classGroupSelection items 
		detect: [ :each | each type isBasedOnClassTag ].
	^tagItem name! !

!ClyFullBrowserContext methodsFor: 'selection-method groups' stamp: ''!
isMethodTagSelected

	self isMethodGroupSelected ifFalse: [ ^false ].
	
	^self selectedMethodGroupClass isBasedOnMethodTag! !

!ClyFullBrowserContext methodsFor: 'tool controlling' stamp: ''!
showPackage: aPackage
	tool selectPackage: aPackage! !

!ClyFullBrowserContext methodsFor: 'selection-projects' stamp: ''!
isProjectSelected
	^self selectedProjectItems notEmpty! !

!ClyFullBrowserGlobalContext commentStamp: ''!
I am a global context of full browser!
!ClyFullBrowserMethodContext commentStamp: ''!
I am a context of selected methods in full browser!
!ClyFullBrowserMethodContext methodsFor: 'browser state' stamp: ''!
restoreBrowserState

	self browser selectMethod: self lastSelectedMethod! !

!ClyFullBrowserMethodContext methodsFor: 'selection-methods' stamp: ''!
selectedMethodItems
	^selectedItems! !

!ClyFullBrowserMethodContext class methodsFor: 'selection strategy' stamp: ''!
selectionStrategy
	<classAnnotation>
	
	^ClyContextSelectionStrategyAnnotation for: ClyFullBrowserMorph selectionType: ClyMethod! !

!ClyFullBrowserMethodGroupContext commentStamp: ''!
I am a context of selected method groups in full browser!
!ClyFullBrowserMethodGroupContext methodsFor: 'selection-method groups' stamp: ''!
selectedMethodGroupItems
	^selectedItems! !

!ClyFullBrowserMethodGroupContext class methodsFor: 'selection strategy' stamp: ''!
selectionStrategy
	<classAnnotation>
	
	^ClyContextSelectionStrategyAnnotation for: ClyFullBrowserMorph selectionType: ClyMethodGroup! !

!ClyFullBrowserMorph commentStamp: ''!
I am a classic four panes Smalltalk browser.

The instance side and class side mode is based on #metaLevelScope class. It affects the query scope which is used to show methods and method groups.

The method groups and variables mode is based on #methodGroupQuery: 
- when user switches to variables the groups query is replaced by ClyAllVariables query based on same scope.
- when user switches to groups the variables query is replaced by ClyAllMethodGroups query based on same scope.

Also methodGroupQuery is used to keep current method visibility level:
- when user enables some superclass visibility it just adds to the current query scope.

In addition I implement special logic for extending classes and default visibility of traits:

- when extending class is selected (which is gray in class view) I switches to its one meta level.
- when extending class is selected I add at the top of list the extending package method group

Internal Representation and Key Implementation Points.

    Instance Variables
	packageView:		<ClyQueryView>
	classView:		<ClyQueryView>
	methodGroupView:		<ClyQueryView>
	methodView:		<ClyQueryView>
	metaLevelScope:		<ClyMetaLevelClassScope>
	methodGroupQuery:		<ClyQuery>!
!ClyFullBrowserMorph methodsFor: 'initialization' stamp: ''!
newMethodView
	"Creates the method pane"

	^ self newNavigationView
		displayMainColumnBy: [ :cell :item | 
			self specifyMethodItemNameOn: cell label for: item browserItem];
		requestNavigationBy: #methodSelectionChanged! !

!ClyFullBrowserMorph methodsFor: 'tools support' stamp: ''!
decorateMethodEditor: aMethodEditor

	methodView query decorateResultMethodEditor: aMethodEditor! !

!ClyFullBrowserMorph methodsFor: 'initialization' stamp: ''!
initializeNavigationViews
	"Initialize all panes (navigation views) of the browser. 
	 Regular browsers have four panes: package, class, protocol and method."

	packageView := self newPackageView.
	classView := self newClassView.
	methodGroupView := self newMethodGroupView.
	methodView := self newMethodView! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
methodGroupQuery: aQuery
	methodGroupQuery := aQuery! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToFullClassHierarchy
	
	| classScope |
	classScope := self classSelection asItemsScope: ClyInstanceSideScope.
	
	self 
		switchClassViewTo: ClyHierarchicallySortedClassesResult new
		inScope: classScope asFullHierarchyScope! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
defaultPackageFilter
	^DefaultPackageFilter ifNil: [ 
		DefaultPackageFilter := ClyTableFilterFactory of: ClyItemNameFilter using: ClyRegexPattern new]! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
selectMethod: aMethod

	| foundItems |
	self changeStateBy: [
		foundItems := methodView findItemsWith: { aMethod }.
		foundItems ifNotEmpty: [ ^self methodSelection selectItems: foundItems ].
	
		self selectClass: aMethod origin.
		self classSelection isEmpty ifTrue: [ ^self ].
		self methodGroupSelection beEmpty.
		self methodSelection selectItemsWith: {aMethod}
	]! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
selectClass: aClass atMethodTag: tagName

	self changeStateBy: [ 
		self selectClass: aClass.
		self methodGroupSelection selectItemsWhere: [ :each | each name = tagName ]]! !

!ClyFullBrowserMorph methodsFor: 'initialization' stamp: ''!
prepareInitialState

	methodGroupQuery := ClyAllMethodGroupsQuery sortedFrom: (metaLevelScope emptyIn: navigationEnvironment).
	
	self switchToPackages! !

!ClyFullBrowserMorph methodsFor: 'initialization' stamp: ''!
prepareDefaultState
	super prepareDefaultState.
	
	DefaultPackageFilter ifNotNil: [ 
		packageView activateFilterWith: DefaultPackageFilter].
	
	UIManager default defer: [packageView takeKeyboardFocus]! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
methodSelection
	^methodView selection! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
selectClass: aClass
	| foundItems classDefinition |
	self changeStateBy: [ 
		self switchToMetaLevelScope: aClass metaLevelScope.	
		foundItems := classView findItemsWith: { aClass instanceSide }.
		foundItems ifNotEmpty: [ 
			"we want ensure that selected package is the package of found class.
			If it is not then we will select required package"
			classDefinition := foundItems anyOne systemDefinition.
			(self isPackageSelected: classDefinition definingPackage) 
				ifTrue: [ ^self classSelection selectItems: foundItems ]].
		
		aClass tags 
			ifEmpty: [ self selectPackage: aClass package]
			ifNotEmpty: [:tags | self selectPackage: aClass package atClassTag: tags anyOne].
		self packageSelection isEmpty ifTrue: [ ^self ].
		
		self showsFullClassHierarchy ifTrue: [ self switchToFullClassHierarchyOf: aClass ].
		self classSelection selectItemsWith: { aClass instanceSide }
	]! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
metaLevelScope
	^metaLevelScope! !

!ClyFullBrowserMorph methodsFor: 'accessing - view' stamp: ''!
methodView
	^ methodView! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
projectChildrenSelection
	^packageView selection asSelectedParentsOf: ClyProjectChildItem! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
selectPackage: aPackage

	self changeStateBy: [
		packageView selection selectItemsWith: { aPackage }.
		packageView selection isEmpty ifTrue: [ self switchToPackages ].
		packageView selection selectItemsWith: { aPackage }.
	]! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
defaultClassScopeForMethods

	| selectedClassScope |
	selectedClassScope := self classSelection asItemsScope: metaLevelScope.
	
	^self extendClassScopeForMethods: selectedClassScope! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
classSelection
	^classView selection! !

!ClyFullBrowserMorph methodsFor: 'testing' stamp: ''!
isScopedModeEnabled
	^packageView showsItemsFromScope: ClyPackageScope! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
classScopeForMethods
	| currentClassScope |
	currentClassScope := methodGroupQuery scope asScope: metaLevelScope.
	
	^self extendClassScopeForMethods: currentClassScope! !

!ClyFullBrowserMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	metaLevelScope := ClyInstanceSideScope! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToPackageScopeOf: packages

	| query scope |
	scope := ClyPackageScope ofAll: packages in: navigationEnvironment.
	scope name: 'Scoped pckg'.
	query := ClyAllPackagesQuery sortedFrom: scope.

	packageView showQuery: query! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToPackages
	| packages |
	packages := ClyAllPackagesQuery sortedFrom: self systemScope.

	packageView showQuery: packages! !

!ClyFullBrowserMorph methodsFor: 'class compilation' stamp: ''!
compileANewClassFrom: aString notifying: aController startingFrom: aClass
	
	^ self system compileANewClassFrom: aString notifying: aController startingFrom: aClass! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
projectClass

	^ ClyManagedProject! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToMethodGroups
	
	self changeMethodGroupQueryBy: [ 
		ClyAllMethodGroupsQuery sortedFrom: self classScopeForMethods
	]! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
allNavigationScopes
	
	| classLocalScope |
	classLocalScope := self classSelection asItemsScope: ClyBothMetaLevelClassScope.

	^super allNavigationScopes, { 
		self packageSelection asItemsScope: ClyPackageScope. 
		classLocalScope asFullHierarchyScope. 
		classLocalScope }, RefactoringSettings availableScopes! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
selectCurrentExtensionMethodGroup
	
	self classSelection isEmpty ifTrue: [ ^self ].
	self classSelection isMultipleSelected ifTrue: [ ^self ].
	
	(self classSelection lastSelectedItem isMarkedWith: ClyExtendedClassTag) 
		ifFalse: [ ^self].
		
	self selectMethodGroupNamed: self packageSelection lastSelectedItem name! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToMetaLevelScope: aMetaLevelScopeClass
	metaLevelScope = aMetaLevelScopeClass ifTrue: [ ^self ].
	
	self changeMethodGroupQueryBy: [
		metaLevelScope := aMetaLevelScopeClass.				
		methodGroupQuery withMetaLevelScope: metaLevelScope
	]! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToVariables
	| classScope |
	
	self changeMethodGroupQueryBy: [
		classScope := self classScopeForMethods.
		ClyAllVariablesQuery 
			from: classScope, classScope asInheritedScope 
			as: ClyGroupedInstanceVariablesResult withDefaultHierarchy 
	]! !

!ClyFullBrowserMorph methodsFor: 'accessing - view' stamp: ''!
methodGroupView
	^ methodGroupView! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
packageSelection
	^packageView selection asSelectedParentsOf: RPackage! !

!ClyFullBrowserMorph methodsFor: 'private' stamp: ''!
specifyMethodItemNameOn: nameMorph for: methodItem
	| definition |
	nameMorph contents: methodItem name.
	
	definition := methodItem	systemDefinition.
	(self isPackagePartOfSelection: definition definingPackage) ifFalse: [
		nameMorph color: self theme classExtensionColor].
	
	self classSelection isMultipleSelected ifTrue: [
		^nameMorph contents: (definition printFullNameOf: methodItem)].
	
	(self isClassSelected: definition definingClass) ifTrue: [ ^self].
	
	nameMorph emphasis: TextEmphasis italic emphasisCode.
	nameMorph contents: (definition printFullNameOf: methodItem)! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToFullClassHierarchyOf: aClass
	
	| classScope |
	classScope := ClyInstanceSideScope of: aClass in: navigationEnvironment.
	
	self 
		switchClassViewTo: ClyHierarchicallySortedClassesResult new
		inScope: classScope asFullHierarchyScope! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
classSelectionChanged
	
	self changeStateBy: [
		self showsFlatClasses ifFalse: [ 
			self silentlySelectPackageOfSelectedClass].
		 
		self changeMethodGroupQueryBy: [ 
			self adoptForExtendedClass.
			methodGroupQuery restrictedByScope: self defaultClassScopeForMethods].
		
		self selectCurrentExtensionMethodGroup
	]! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToProjects
	packageView showQuery: (systemScope projectQueryFor: self systemScope).! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
chooseClassesForNewMethod: aMethod

	| methodClass selectedClasses |
	methodClass := aMethod origin.
	
	selectedClasses := self chooseClassesForNewMethod.
	selectedClasses := selectedClasses copyWithout: methodClass.
	^selectedClasses, {methodClass}! !

!ClyFullBrowserMorph methodsFor: 'updating' stamp: ''!
newWindowTitle
	| newTitle |
	
	packageView selection isEmpty ifTrue: [ ^self systemScope description].	
	
	newTitle := self buildTitleFromSelections.
	self systemScope isCurrentImage ifFalse: [ 
		newTitle := newTitle , ' in ', self systemScope description ].
	
	^newTitle! !

!ClyFullBrowserMorph methodsFor: 'accessing - context' stamp: ''!
createCommandContext
	^ClyFullBrowserGlobalContext for: self! !

!ClyFullBrowserMorph methodsFor: 'updating' stamp: ''!
setWindowTitle: aString in: aWindow
	| emphasis |
	super setWindowTitle: aString in: aWindow.
	
	aWindow basicLabel ifNotNil: [:label |
		emphasis := metaLevelScope = ClyInstanceSideScope 
			ifTrue: [ TextEmphasis normal ] ifFalse: [ TextEmphasis bold ].
		label emphasis: emphasis emphasisCode]! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
methodGroupQuery
	^methodGroupQuery! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
extendClassScopeForMethods: aClassScope
	| resultScope |

	resultScope := aClassScope.
	(ClyMethodVisibilityLevel allAvailableFor: self classSelection items)
		ifNotEmpty: [ :levels | 
			"It will be likely one, but who knows"
			resultScope := levels anyOne extendClassScope: resultScope ].
	
	^resultScope! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
navigateSpawnedFullBrowser: aFullBrowser
	self isScopedModeEnabled ifTrue: [
		aFullBrowser switchToPackageScopeOf: packageView query scope basisObjects].
	 
	self methodSelection isEmpty ifFalse: [ 
		^aFullBrowser selectMethod: self methodSelection lastSelectedItem actualObject].
	
	self classSelection isEmpty ifFalse: [ 
		^aFullBrowser selectClass: self classSelection lastSelectedItem actualObject].
	
	self packageSelection isEmpty ifFalse: [ 
		^aFullBrowser selectPackage: self packageSelection lastSelectedItem actualObject]! !

!ClyFullBrowserMorph methodsFor: 'testing' stamp: ''!
isPackagePartOfSelection: aPackage

	(self isPackageSelected: aPackage) ifTrue: [ ^true ].
	
	^self projectSelection actualObjects
		anySatisfy: [ :each | each includesPackage: aPackage ]! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
metaLevelScope: aMetaLevelScopeClass
	metaLevelScope := aMetaLevelScopeClass! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
changeMethodGroupQueryBy: aBlock
	
	self changeStateBy: [
		methodGroupQuery := aBlock value.
		methodGroupView showQuery: methodGroupQuery.
		methodGroupView initiateUIChangeBy: [
			"view should know that any change here was not requested by user"
			self methodGroupSelectionChanged] 
	]! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
snapshotState
	
	^ClyFullBrowserState of: self! !

!ClyFullBrowserMorph methodsFor: 'accessing - context' stamp: ''!
currentMetaLevelOf: aClass
	^metaLevelScope metaLevelOf: aClass! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
chooseClassesForNewMethod

	^self classSelection actualObjects collect: [ :each | 
		metaLevelScope metaLevelOf: each]! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
packageSelectionChanged
	
	self switchToFlatClasses! !

!ClyFullBrowserMorph methodsFor: 'updating' stamp: ''!
buildTitleFromSelections
	| newTitle mainItem |	
	self projectSelection isEmpty ifFalse: [ 
		newTitle := self projectSelection lastSelectedItem name].
	
	self packageSelection isEmpty ifFalse: [ 
		newTitle := self packageSelection lastSelectedItem name].
	
	self classSelection isEmpty ifTrue: [ ^newTitle ].
	
	mainItem := self methodSelection isEmpty 
		ifTrue: [ self classSelection lastSelectedItem ]
		ifFalse: [ self methodSelection lastSelectedItem].

	newTitle := mainItem systemDefinition printDefiningClass.
	mainItem systemDefinition isInstanceSide & (metaLevelScope = ClyClassSideScope)
		ifTrue: [ newTitle := newTitle , ' class' ].
	self methodSelection isEmpty ifFalse: [ 
		newTitle := newTitle , '>>' , self methodSelection lastSelectedItem name ].
	^newTitle! !

!ClyFullBrowserMorph methodsFor: 'private' stamp: ''!
specifyClassItemNameOn: nameMorph for: classItem
	| definition |
	nameMorph contents: classItem name.
	
	definition := classItem systemDefinition.
	
	self packageSelection isMultipleSelected ifTrue: [
		nameMorph contents: (definition printFullNameOf: classItem)].
	(self isPackagePartOfSelection: definition definingPackage) 
		ifFalse: [nameMorph color: self theme classExtensionColor]! !

!ClyFullBrowserMorph methodsFor: 'testing' stamp: ''!
isInProjectView
	
	^ self packageView showsItemsFromQuery: (systemScope projectQueryFor: self systemScope) class! !

!ClyFullBrowserMorph methodsFor: 'private' stamp: ''!
updateDefaultPackageFilter

	DefaultPackageFilter := packageView filterField getText ifEmpty: [ nil ]! !

!ClyFullBrowserMorph methodsFor: 'testing' stamp: ''!
showsFlatClasses
	^self packageSelection isEmpty not 
		and: [ (classView showsItemsFromScope: ClyClassHierarchyScope) not]! !

!ClyFullBrowserMorph methodsFor: 'initialization' stamp: ''!
newPackageView
	"Creates the package pane"
	| newPackageView |
	
	newPackageView := self newNavigationView
		treeStructure: 	{ 
			ClyProjectChildItem -> #prepareProjectItemsQueryFrom:in:.
			RPackage -> #prepareClassGroupQueryFrom:in: };
		enableFilterUsing: ClyRegexPattern new;
		requestNavigationBy: #packageSelectionChanged.
	newPackageView filterField announcer 
		when: RubTextChanged 
		send: #updateDefaultPackageFilter 
		to: self.
		
	^ newPackageView! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
selectPackage: aPackage atClassTag: tagName

	| packageItem targetClassGroup foundPackages |

	self changeStateBy: [
		foundPackages := packageView findItemsWith: {aPackage}.
		foundPackages ifEmpty: [ 
			self switchToPackages.
			foundPackages := packageView findItemsWith: {aPackage} ].
		packageItem := foundPackages first.
		packageItem expand.
		targetClassGroup := packageItem childrenItems detect: [:each | each name = tagName ].
	
		packageView selection selectItems: { targetClassGroup }
	]! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
methodGroupSelectionChanged
		
	| methodQueries |
	methodGroupView changesWasInitiatedByUser ifTrue: [
		tabManager skipCurrentDesiredSelection]. "It will force selecting of method creation tab"
	
	self methodGroupSelection isEmpty ifTrue: [ ^self showAllMethods].

	methodQueries := self methodGroupSelection actualObjects 
		collect: [ :eachGroup | eachGroup methodQuery].
	methodView 
		showQueries: methodQueries as: (ClySortedQueryResult using: ClySortMethodBySelectorFunction ascending)! !

!ClyFullBrowserMorph methodsFor: 'testing' stamp: ''!
isPackageSelected: aPackage

	^self packageSelection includesActualObject: aPackage! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
classGroupSelection
	^packageView selection asSelectedItemsOf: ClyClassGroup! !

!ClyFullBrowserMorph methodsFor: 'accessing - view' stamp: ''!
packageView
	^ packageView! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToFlatClasses
	
	| classQueries |
	classQueries := OrderedCollection new.
	packageView selection groupItemsByTypeAndDo: [ :typeClass :items | 
		classQueries addAll: (typeClass prepareClassQueriesFrom: items in: navigationEnvironment)].
	
	classView showQueries: classQueries as: ClyExtensionLastSortedClassResult hierarchical! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
defaultNavigationScope
	
	^self isScopedModeEnabled 
		ifFalse: [ super defaultNavigationScope ]
		ifTrue: [ packageView query scope]! !

!ClyFullBrowserMorph methodsFor: 'testing' stamp: ''!
isClassSelected: aClass
	"It is the logic to return true when metaclass is selected but given aClass is its instance side. 
	In future this complexity should be addressed with first class ClassBrowserItem"
	^self classSelection items anySatisfy: [ :each | 
		each actualObject == aClass or: [ 
			each systemDefinition definingClass == aClass ]]! !

!ClyFullBrowserMorph methodsFor: 'initialization' stamp: ''!
newClassView
	"Creates the class pane"

	^ self newNavigationView
		displayMainColumnBy: [ :cell :item |
			cell useFullIndentation.
			self specifyClassItemNameOn: cell label for: item browserItem];
		enableFilter;
		enableCollapsingOfPreexpandedItems;
		requestNavigationBy: #classSelectionChanged! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
projectSelection
	^packageView selection asSelectedParentsOf: self projectClass! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
methodGroupSelection
	^methodGroupView selection! !

!ClyFullBrowserMorph methodsFor: 'initialization' stamp: ''!
newMethodGroupView
	"Creates the 'method group' pane (formerly the 'protocol' pane)"

	^ self newNavigationView
		treeStructure: { 
			ClyMethodGroup -> #prepareSubgroupsQueryFrom:in: };
		requestNavigationBy: #methodGroupSelectionChanged;
		neverRestoreSelection! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
selectVariableNamed: varName

	self selectMethodGroupNamed: varName! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
showAllMethods
		
	| methodQuery |
	
	methodQuery := ClyAllMethodsQuery sortedFrom: self classScopeForMethods.	
	methodView showQuery: methodQuery! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
silentlySelectPackageOfSelectedClass
		
	| selectedClass |
		
	self classSelection isEmpty ifTrue: [ ^self ].

	selectedClass := self classSelection lastSelectedItem actualObject.
	
	packageView ignoreNavigationDuring: [
		selectedClass tags
			ifEmpty: [ self selectPackage: selectedClass package]
			ifNotEmpty: [:tags | self selectPackage: selectedClass package atClassTag: tags anyOne]]! !

!ClyFullBrowserMorph methodsFor: 'testing' stamp: ''!
showsFullClassHierarchy
	^classView showsItemsFromScope: ClySuperclassScope! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
setUpScopedModeWith: aScope

	(aScope isKindOf: ClyPackageScope) ifFalse: [ ^self ].
	
	self switchToPackageScopeOf: aScope basisObjects! !

!ClyFullBrowserMorph methodsFor: 'private' stamp: ''!
adoptForExtendedClass
	| extendingPackages extraGroups |
	self classSelection isEmpty ifTrue: [ ^self ].
	methodGroupQuery := methodGroupQuery withoutItemsOfType: RPackage. "To remove previous package injection"
	(self classSelection lastSelectedItem isMarkedWith: ClyExtendedClassTag) ifFalse: [ ^self ].
	
	"it will ensures method groups mode for extended class 
	to auto select extension methods of selected packages"
	methodGroupQuery := ClyAllMethodGroupsQuery sortedFrom: self classScopeForMethods.
	
	extendingPackages := self packageSelection actualObjects.
	extraGroups := ClyConstantQuery 
				returning: extendingPackages as: ClyGroupedExtendingPackagesResult new.
	extraGroups := methodGroupQuery scope adoptQuery: extraGroups.
	methodGroupQuery := methodGroupQuery , extraGroups! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
restrictMethodVisibilityBy: aClassScope

	self changeMethodGroupQueryBy: [
		methodGroupQuery restrictedByScope: aClassScope]! !

!ClyFullBrowserMorph methodsFor: 'accessing' stamp: ''!
chooseClassForEditorOfMethod: aMethod

	| selectedClass |
	self classSelection isSingleSelected ifTrue: [ 
		selectedClass := self classSelection lastSelectedItem actualObject.
		^self currentMetaLevelOf: selectedClass ].
	
	^aMethod origin! !

!ClyFullBrowserMorph methodsFor: 'accessing - view' stamp: ''!
classView
	^ classView! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
selectMethodGroupNamed: tagName

	self changeStateBy: [ 
		self methodGroupSelection selectItemsWhere: [ :each | each name = tagName ]
	]! !

!ClyFullBrowserMorph methodsFor: 'navigation' stamp: ''!
switchClassViewTo: aQueryResult inScope: aScope
	| classes |
	classes := ClyAllClassesQuery from: aScope as: aQueryResult.
	
	classView showQuery: classes! !

!ClyFullBrowserMorph methodsFor: 'accessing - selection' stamp: ''!
methodSelectionChanged
	| actualMethods |

	actualMethods := self methodSelection actualObjects.
	methodGroupView highlightItemsWhich: [ :eachGroup | 
		actualMethods anySatisfy: [ :eachMethod |
			eachGroup actualObject includesMethod: eachMethod ] ]! !

!ClyFullBrowserMorph class methodsFor: 'opening' stamp: ''!
openOnPackage: aPackage

	^self openWithState: [:browser | browser selectPackage: aPackage]! !

!ClyFullBrowserMorph class methodsFor: 'icons' stamp: ''!
taskbarIconName
	^#smallSystemBrowser! !

!ClyFullBrowserMorph class methodsFor: 'tools registration' stamp: ''!
beDefaultBrowser
	<script>
	self registerToolsOn: Smalltalk tools! !

!ClyFullBrowserMorph class methodsFor: 'opening' stamp: ''!
open
	<script>
	^ self openOn: ClyNavigationEnvironment currentImage! !

!ClyFullBrowserMorph class methodsFor: 'opening' stamp: ''!
openOn: aNavigationEnvironment

	| browser |
	browser := self on: aNavigationEnvironment.
	browser open.	
	^browser! !

!ClyFullBrowserMorph class methodsFor: 'opening' stamp: ''!
openOn: aNavigationEnvironment withState: navigationBlock

	| browser |
	browser := self on: aNavigationEnvironment.
	browser prepareInitialStateBy: navigationBlock.
	browser open.	
	^browser! !

!ClyFullBrowserMorph class methodsFor: 'opening' stamp: ''!
openOnClass: aClass

	^self openWithState: [:browser | browser selectClass: aClass]! !

!ClyFullBrowserMorph class methodsFor: 'opening' stamp: ''!
openOnMethod: aMethod

	^self openWithState: [:browser | browser selectMethod: aMethod]! !

!ClyFullBrowserMorph class methodsFor: 'tools registration' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]" 
	registry register: self as: #browser! !

!ClyFullBrowserMorph class methodsFor: 'settings' stamp: ''!
settingsGroupOn: aBuilder
	<systemsettings>
	(aBuilder group: #Calypso)
		label: 'Calypso Browser';
		parent: #codeBrowsing;
		description: 'Settings related to the browser'! !

!ClyFullBrowserMorph class methodsFor: 'opening' stamp: ''!
onDefaultEnvironment
	<script>
	^ (self on: ClyNavigationEnvironment currentImage)
			prepareInitialState;
			yourself! !

!ClyFullBrowserMorph class methodsFor: 'opening' stamp: ''!
openOnClass: aClass selector: aSymbol highlight: aString

	| browser |
	browser := self openOnClass: aClass selector: aSymbol.
	browser withTool: ClyMethodCodeEditorToolMorph do: [ :editor | 
		editor selectAnyString: { aString }].
	^browser! !

!ClyFullBrowserMorph class methodsFor: 'opening' stamp: ''!
openWithState: navigationBlock

	^ self openOn: ClyNavigationEnvironment currentImage withState: navigationBlock! !

!ClyFullBrowserMorph class methodsFor: 'opening' stamp: ''!
openOnClass: aClass selector: aSymbol

	^(aClass lookupSelector: aSymbol)
		ifNil: [ self openOnClass: aClass ]
		ifNotNil: [:method | self openOnMethod: method]! !

!ClyFullBrowserPackageContext commentStamp: ''!
I am a context of selected packages in full browser!
!ClyFullBrowserPackageContext methodsFor: 'selection-class groups' stamp: ''!
isClassGroupSelected
	^false! !

!ClyFullBrowserPackageContext methodsFor: 'selection-class groups' stamp: ''!
isClassTagSelected
	^false! !

!ClyFullBrowserPackageContext methodsFor: 'public' stamp: ''!
lastSelectedClassGroup
	^self lastSelectedObject! !

!ClyFullBrowserPackageContext methodsFor: 'selection-packages' stamp: ''!
selectedPackageItems
	^selectedItems! !

!ClyFullBrowserPackageContext class methodsFor: 'selection strategy' stamp: ''!
selectionStrategy
	<classAnnotation>
	
	^ClyContextSelectionStrategyAnnotation for: ClyFullBrowserMorph selectionType: RPackage! !

!ClyFullBrowserProjectContext commentStamp: ''!
I am a context of selected projects in full browser!
!ClyFullBrowserProjectContext methodsFor: 'testing' stamp: ''!
isClassGroupSelected
	^false! !

!ClyFullBrowserProjectContext methodsFor: 'testing' stamp: ''!
isClassTagSelected
	^false! !

!ClyFullBrowserProjectContext methodsFor: 'selection-projects' stamp: ''!
selectedProjectItems
	
	^selectedItems collect: [ :each | each rootParentItem ]! !

!ClyFullBrowserProjectContext class methodsFor: 'selection strategy' stamp: ''!
selectionStrategy
	<classAnnotation>
	
	^ClyContextSelectionStrategyAnnotation for: ClyFullBrowserMorph selectionType: ClyProjectChildItem! !

!ClyFullBrowserState commentStamp: ''!
I represent state of full browser. 
So I keep its current metaLevelScope and methodGroupQuery.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	metaLevelScope:		<ClyMetaLevelClassScope>
	methodGroupQuery:		<ClyQuery>!
!ClyFullBrowserState methodsFor: 'accessing' stamp: ''!
methodGroupQuery: aQuery
	methodGroupQuery := aQuery! !

!ClyFullBrowserState methodsFor: 'accessing' stamp: ''!
methodGroupQuery
	^ methodGroupQuery! !

!ClyFullBrowserState methodsFor: 'private' stamp: ''!
restoreStateOf: aBrowser
	super restoreStateOf: aBrowser.
	
	aBrowser 
		metaLevelScope: metaLevelScope;
		methodGroupQuery: methodGroupQuery! !

!ClyFullBrowserState methodsFor: 'accessing' stamp: ''!
metaLevelScope: anObject
	metaLevelScope := anObject! !

!ClyFullBrowserState methodsFor: 'operations' stamp: ''!
retrieveStateFrom: aBrowser
	super retrieveStateFrom: aBrowser.
	
	metaLevelScope := aBrowser metaLevelScope.
	methodGroupQuery := aBrowser methodGroupQuery! !

!ClyFullBrowserState methodsFor: 'accessing' stamp: ''!
metaLevelScope
	^ metaLevelScope! !

!ClyFullBrowserState methodsFor: 'private' stamp: ''!
createBrowser
	^ClyFullBrowserMorph new! !

!ClyFullBrowserStateTest methodsFor: 'running' stamp: ''!
restoreBrowserInstance

	self snapshotState.
	
	navigationState applyTo: browser! !

!ClyFullBrowserStateTest methodsFor: 'tests' stamp: ''!
testRetrievesMethodGroupContent

	self snapshotState.
	
	self assert: navigationState methodGroupQuery equals: browser methodGroupQuery! !

!ClyFullBrowserStateTest methodsFor: 'tests' stamp: ''!
testRetrievesSystemScope

	self snapshotState.
	
	self assert: navigationState systemScope equals: environment systemScope! !

!ClyFullBrowserStateTest methodsFor: 'tests' stamp: ''!
testRestoredBrowserInstanceWithMethodGroupQuery
	
	browser methodGroupQuery: #testQuery.
	
	self restoreBrowserInstance.
	
	self assert: browser methodGroupQuery equals: #testQuery! !

!ClyFullBrowserStateTest methodsFor: 'tests' stamp: ''!
testRestoredBrowserInstanceWithMetaLevelScope
	
	browser metaLevelScope: #testScope.
	
	self restoreBrowserInstance.
	
	self assert: browser metaLevelScope equals: #testScope! !

!ClyFullBrowserStateTest methodsFor: 'tests' stamp: ''!
testRetrievesMetaLevelScope

	self snapshotState.
	
	self assert: navigationState metaLevelScope equals: browser metaLevelScope! !

!ClyFullBrowserStateTest methodsFor: 'tests' stamp: ''!
testRestoredBrowserInstanceWithSystemScope
	
	browser systemScope: #testScope.
	
	self restoreBrowserInstance.
	
	self assert: browser systemScope equals: #testScope! !

!ClyFullBrowserStateTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	browser prepareInitialState! !

!ClyFullBrowserVariableContext commentStamp: ''!
I am a context of selected variables in full browser!
!ClyFullBrowserVariableContext methodsFor: 'selection-variables' stamp: ''!
lastSelectedVariable
	^self lastSelectedObject variable! !

!ClyFullBrowserVariableContext methodsFor: 'selection-variables' stamp: ''!
isVariableSelected
	^self hasSelectedItems! !

!ClyFullBrowserVariableContext methodsFor: 'selection-variables' stamp: ''!
isGlobalVariableSelected
	^false! !

!ClyFullBrowserVariableContext methodsFor: 'selection-variables' stamp: ''!
selectedVariables
	^self selectedObjects collect: [ :each | each variable ]! !

!ClyFullBrowserVariableContext class methodsFor: 'selection strategy' stamp: ''!
selectionStrategy2
	<classAnnotation>
	
	^(ClyContextSelectionStrategyAnnotation for: ClyFullBrowserMorph selectionType: ClyVariable)! !

!ClyFullBrowserVariableContext class methodsFor: 'selection strategy' stamp: ''!
selectionStrategy
	<classAnnotation>
	
	^(ClyContextSelectionStrategyAnnotation for: ClyFullBrowserMorph selectionType: ClyVariableMethodGroup)
		priority: 1000 "variable context should be with more priority than basic method group context"! !

!ClyFullEnvironmentUpdateStrategy commentStamp: ''!
I am special strategy to perform full update of environment after multiple changes when all cached query results were correctly updated. 
I collect all changes and publish them all together when environment finish overall processing.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	changes:		<IdentityDictionary of<ClyQueryResult, Announcement>>!
!ClyFullEnvironmentUpdateStrategy methodsFor: 'updating' stamp: ''!
publishCollectedChanges
	changes do: [ :queryResult | queryResult notifyChanges ].
	changes removeAll! !

!ClyFullEnvironmentUpdateStrategy methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	changes := IdentitySet new! !

!ClyFullEnvironmentUpdateStrategy methodsFor: 'updating' stamp: ''!
announceChangesOf: aQueryResult

	changes add: aQueryResult! !

!ClyFullVisibilityLevel commentStamp: ''!
I represent visibility of all inherited methods.
I limit inheritance up to Object to avoid less interesting methods. So Object and ProtoObject methods are not shown when you activate me.

I create extra scope using #asInheritedScope message.!
!ClyFullVisibilityLevel methodsFor: 'testing' stamp: ''!
isRedundant
	"the level is reduntant if there are no interesting classes to show"
	extraClassScope asInterestingClassScope classesDo: [ :each | ^false ].
	^true! !

!ClyFullVisibilityLevel methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	| tool |
	tool := ClyMethodVisibilityMorph for: anItemCellMorph browser level: self.
	tool build.
	anItemCellMorph addExtraIcon: #hierarchy.
	anItemCellMorph addExtraTool: tool! !

!ClyFullVisibilityLevel methodsFor: 'controlling' stamp: ''!
activateExtraScope
	"We only want to show interesting classes which means we do not case about Object and rest"
	^visibleClassScope increasedByClassesFrom: extraClassScope asInterestingClassScope! !

!ClyFullVisibilityLevel class methodsFor: 'instance creation' stamp: ''!
of: aClassScope
	
	^(super of: aClassScope)
		extraClassScope: aClassScope asInheritedScope! !

!ClyGlobalVariable commentStamp: ''!
I represent a glopbal variable.
I am like GlobalVariable.

You can create my instance using:
	ClyGlobalVariable on: aGlobalVariable
 !
!ClyGlobalVariable methodsFor: 'operations' stamp: ''!
openInspector

	actualVariable value inspect! !

!ClyGlobalVariable methodsFor: 'testing' stamp: ''!
isClassVariable
	^false! !

!ClyGlobalVariable methodsFor: 'testing' stamp: ''!
isLive

	^true! !

!ClyGlobalVariable methodsFor: 'accessing' stamp: ''!
detectDefiningClassFrom: anUserClass
	"There is no defining class for the global"! !

!ClyGlobalVariable methodsFor: 'operations' stamp: ''!
openBrowser

	actualVariable value browse! !

!ClyGlobalVariable methodsFor: 'testing' stamp: ''!
isAccessibleFrom: aClass

	^true! !

!ClyGlobalVariable class methodsFor: 'instance creation' stamp: ''!
on: aGlobalVariable
	^self on: aGlobalVariable definedIn: nil! !

!ClyGroupItemTableDecorator commentStamp: ''!
I delegate decoration of any group item to the group itself:

	groupItem actualObject decorateTableCell: anItemCellMorph of: groupItem
	
The actualObject is a kind ClyGroup. There are method, class and package groups.

If you introduce new kind of group then to activate this decorator you will need to annotate me with new decoration strategy for new context of this new group!
!ClyGroupItemTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem! !

!ClyGroupItemTableDecorator class methodsFor: 'decoration' stamp: ''!
methodGroupDecorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyMethodGroup asCalypsoItemContext! !

!ClyGroupItemTableDecorator class methodsFor: 'decoration' stamp: ''!
classGroupDecorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyClassGroup asCalypsoItemContext! !

!ClyGroupItemTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: groupItem
	super decorateMainTableCell: anItemCellMorph of: groupItem.
	
	groupItem actualObject decorateTableCell: anItemCellMorph of: groupItem! !

!ClyGroupWindowMorph commentStamp: ''!
I fix bad behaviour of my superclass in context of Calypso requirement.
For example I update group window title to be same as selected tab title.!
!ClyGroupWindowMorph methodsFor: 'updating' stamp: ''!
update: aSymbol  with: anObject
	"Handle tab changes."

	super update: aSymbol with: anObject.
	self updateMainWindowTitle! !

!ClyGroupWindowMorph methodsFor: 'updating' stamp: ''!
activeWindow
	self tabGroup pages size = 0 ifTrue: [ ^nil].
	self tabGroup selectedPageIndex <= 0 ifTrue: [ ^nil ].
	
	^self tabGroup pages at: self tabGroup selectedPageIndex! !

!ClyGroupWindowMorph methodsFor: 'updating' stamp: ''!
activateWindow: aWindow
	
	| index |
	(self tabGroup pages includes: aWindow) ifTrue: [ 
		index := self tabGroup pages indexOf: aWindow.
		^self tabGroup selectedPageIndex: index].
	
	self addWindow: aWindow.
	aWindow activate; announceOpened! !

!ClyGroupWindowMorph methodsFor: 'updating' stamp: ''!
update: aSymbol
	"Handle tab changes."

	super update: aSymbol.
	self updateMainWindowTitle! !

!ClyGroupWindowMorph methodsFor: 'updating' stamp: ''!
updateMainWindowTitle
	
	| activeWindow |
		
	activeWindow := self activeWindow ifNil: [^self].

	self window ifNotNil: [:w | w  setLabel: activeWindow label]! !

!ClyGroupWindowMorph methodsFor: 'dropping/grabbing' stamp: ''!
dragTab: aSystemWindow event: anEvent in: aTabLabel
	"Drag a tab. Remove the window from the organiser and place in hand."
	aSystemWindow announcer unsubscribe: self.
	self tabGroup removePage: aSystemWindow.
	aSystemWindow configureForUnembedding.
	self tabGroup pages size = 0 ifTrue: [ self owner delete ].
	aSystemWindow position: anEvent targetPoint.
	anEvent hand grabMorph: aSystemWindow! !

!ClyGroupedClassVariablesResult commentStamp: ''!
I special variable query result which filter only class variables and represent them as ClyVariableMethodGroup instances in hierarchical order!
!ClyGroupedClassVariablesResult methodsFor: 'building' stamp: ''!
fillWithGroupedVariables: varsPerTypeAndDefiningClass
	
	varsPerTypeAndDefiningClass at: ClyClassVariable ifPresent: [:classVarsPerClass |
		self fillWithVariables: classVarsPerClass type: ClyClassVariable]! !

!ClyGroupedClassVariablesTest methodsFor: 'tests' stamp: ''!
testFillingWithEmptyList

	queryResult fillWith: { }.
	
	self assertItems: {}! !

!ClyGroupedClassVariablesTest methodsFor: 'tests' stamp: ''!
testFillingWithThreeClasVarsOfSuperclassAndSubclass

	queryResult fillWith: { 
		ClyClassVariable named: #ClassVar1 definedIn: ClyClass2FromP1Mock.
		ClyClassVariable named: #SubclassClassVar definedIn: ClySubclassLOfClass2FromP1Mock.
		ClyClassVariable named: #ClassVar2 definedIn: ClyClass2FromP1Mock}.
	
	self assertItems: {
		ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1. ClyVariableMethodGroup. 1.
		ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1}.
	self assertVars: #(#ClassVar1 #ClassVar2 #SubclassClassVar).! !

!ClyGroupedClassVariablesTest methodsFor: 'tests' stamp: ''!
testFillingWithSingleClassVar

	| classVarGroup allClassVarGroup |
	queryResult fillWith: { ClyClassVariable named: #ClassVar1 definedIn: ClyClass2FromP1Mock }.
	
	self assertItems: {ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1}.
	classVarGroup := items last actualObject.
	self assert: classVarGroup methodQuery class equals: ClyVariableReferencesQuery.
	self 
		assert: classVarGroup methodQuery variableQuery resultItems 
		equals: {ClyClassVariable named: #ClassVar1 definedIn: ClyClass2FromP1Mock}.
	allClassVarGroup :=  items first actualObject.
	self assert: allClassVarGroup methodQuery class equals: ClyVariableReferencesQuery.
	self assert: allClassVarGroup methodQuery variableQuery class equals: ClyAllClassVariablesQuery.! !

!ClyGroupedClassVariablesTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyGroupedClassVariablesResult withHierarchy: ClySubclassHierarchy new! !

!ClyGroupedCritiqueResult commentStamp: ''!
I am critique query result which group given critiques by group name.
I represent these groups with ClyConcreteCritiqueMethodGroup instances!
!ClyGroupedCritiqueResult methodsFor: 'building' stamp: ''!
buildMethodGroupWithCritique: aCritique on: resultDictionary
	| critiqueGroupName group |
	
	critiqueGroupName := aCritique rule group.
	group := resultDictionary at: critiqueGroupName ifAbsentPut: [ 
		ClyConcreteCritiqueMethodGroup 
			basedOn: aCritique withMethodsFrom: self scope].
	group addCritique: aCritique! !

!ClyGroupedCritiqueResult methodsFor: 'initialization' stamp: ''!
defaultItems
	^SortedCollection sortBlock: ClySortByNameFunction ascending! !

!ClyGroupedCritiqueResult methodsFor: 'building' stamp: ''!
fillWith: critiques
	| groups |
	groups := Dictionary new.
	
	critiques do: [ :eachCritique |
		self buildMethodGroupWithCritique: eachCritique on: groups ].
	
	groups do: [ :each | items add: each  ]! !

!ClyGroupedCritiquesTest methodsFor: 'tests' stamp: ''!
testFillingWithEmptyList

	queryResult fillWith: { }.
	
	self assert: queryResult isEmpty! !

!ClyGroupedCritiquesTest methodsFor: 'tests' stamp: ''!
testFillingWithOneCritique
	| method critique group |
	method := ClyClassWithProblemMethods >> #methodWithHalt.
	critique := method critiques anyOne.
	
	queryResult fillWith: { critique }.
	
	self assert: queryResult size equals: 1.
	group := queryResult items first.
	self assert: group class equals: ClyConcreteCritiqueMethodGroup.
	self assert: group name equals: critique rule group asLowercase.
	self assert: group ruleSeverity name equals: critique rule severity! !

!ClyGroupedCritiquesTest methodsFor: 'tests' stamp: ''!
testFillingWithTwoSimilarCritiques
	| method method2 critique group |
	method := ClyClassWithProblemMethods >> #methodWithHalt.
	method2 := ClyClassWithProblemMethods >> #methodWithHalt2.
	critique := method critiques anyOne.
	
	queryResult fillWith: method critiques, method2  critiques.
	
	self assert: queryResult size equals: 1.
	group := queryResult items first.
	self assert: group class equals: ClyConcreteCritiqueMethodGroup.
	self assert: group name equals: critique rule group asLowercase.
	self assert: group ruleSeverity name equals: critique rule severity! !

!ClyGroupedCritiquesTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyGroupedCritiqueResult new! !

!ClyGroupedCritiquesTest methodsFor: 'running' stamp: ''!
createQuery

	^ClyAllProblemMethodQuery from: (ClyClassScope emptyIn: environment).! !

!ClyGroupedExtendingPackagesResult commentStamp: ''!
I am a package query result which converts all packages to the instances of ClyExternalPackageMethodGroup.

I am used in full browser logic to show extending method groups in the third pane.!
!ClyGroupedExtendingPackagesResult methodsFor: 'initialization' stamp: ''!
defaultItems
	^SortedCollection sortBlock: ClySortByNameFunction ascending! !

!ClyGroupedExtendingPackagesResult methodsFor: 'building' stamp: ''!
fillWith: packages
	| group |
	packages do: [ :each | 
		group := ClyExternalPackageMethodGroup 
			withMethodsFrom: self scope packagedIn: each.
		items add: group]! !

!ClyGroupedExtendingPackagesTest methodsFor: 'tests' stamp: ''!
testFillingWithEmptyList

	queryResult fillWith: #().
	
	self assert: queryResult size equals: 0! !

!ClyGroupedExtendingPackagesTest methodsFor: 'tests' stamp: ''!
testFillingWithThreePackages

	| groups |
	queryResult fillWith: { ClySubclassMOfClass1FromP2Mock package. 
		ClySubclassLOfSubclassMFromP3Mock package.
		ClyClass1FromP1Mock package}.
	groups := queryResult items collect: #package as: Array.
	self assert: groups equals: { ClyClass1FromP1Mock package.
		ClySubclassMOfClass1FromP2Mock package.
		ClySubclassLOfSubclassMFromP3Mock package}! !

!ClyGroupedExtendingPackagesTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyGroupedExtendingPackagesResult new! !

!ClyGroupedExtendingPackagesTest methodsFor: 'tests' stamp: ''!
testFillingWithOnePackage

	| group |
	queryResult fillWith: {ClyClass1FromP1Mock package}.
	
	group := queryResult items first.
	self assert: group class equals: ClyExternalPackageMethodGroup.
	self assert: group package equals: ClyClass1FromP1Mock package.
	self 
		assert: group methodQuery 
		equals: (ClyPackageExtensionMethodsQuery of: ClyClass1FromP1Mock package from: query scope)! !

!ClyGroupedInstanceVariablesResult commentStamp: ''!
I special variable query result which filters instance variables and represents them as ClyVariableMethodGroup instances in hierarchical order.

In addition I add extra method group for class variables if they exist. It shows all class variables when it is expanded.
And I add default ClyAllMethodGroup as first item. !
!ClyGroupedInstanceVariablesResult methodsFor: 'building' stamp: ''!
fillWithGroupedVariables: varsPerTypeAndDefiningClass
	self addInheritedMethodGroup.
	
	varsPerTypeAndDefiningClass at: ClyClassVariable ifPresent: [:classVarsPerClass |
		self addClassVariableGroup].
	varsPerTypeAndDefiningClass at: ClyInstanceVariable ifPresent: [:instVarsPerClass |
		self fillWithVariables: instVarsPerClass type: ClyInstanceVariable]! !

!ClyGroupedInstanceVariablesResult methodsFor: 'building' stamp: ''!
addClassVariableGroup

	| variableQuery methodQuery group |
	variableQuery := ClyAllClassVariablesQuery from: self queryScope.
	methodQuery := ClyVariableReferencesQuery 
		from: self queryScope asLocalClassScope
		toVariablesFrom: variableQuery.
	
	group := ClyMethodGroup 
		named: 'Class variables' priority: 9 
		on: methodQuery 
		withSubgroupsFrom: (variableQuery withResult: (ClyGroupedClassVariablesResult withHierarchy: hierarchy)).
	items add: group asCalypsoBrowserItem! !

!ClyGroupedInstanceVariablesResult methodsFor: 'building' stamp: ''!
addInheritedMethodGroup

	| group |
	group := ClyAllMethodGroup withMethodsInheritedFrom: self queryScope. 
	items add: group asCalypsoBrowserItem! !

!ClyGroupedInstanceVariablesTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndSuperclassVariables

	queryResult fillWith: { 
		ClyInstanceVariable named: #subclassN1Var definedIn: ClySubclassN1OfClass1FromP1Mock.
		ClyInstanceVariable named: #instanceSideVar2 definedIn: ClyClass1FromP1Mock.
		ClyInstanceVariable named: #subclassSameVar definedIn: ClySubclassN1OfClass1FromP1Mock.
		ClyInstanceVariable named: #instanceSideVar1 definedIn: ClyClass1FromP1Mock}.
	
	self assertItems: {ClyAllMethodGroup. 0.
		ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1. ClyVariableMethodGroup. 1.
		ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1. ClyVariableMethodGroup. 1 }.
	self assertVars: #(#instanceSideVar1 #instanceSideVar2 #subclassN1Var #subclassSameVar)! !

!ClyGroupedInstanceVariablesTest methodsFor: 'tests' stamp: ''!
testFillingWithEmptyList

	queryResult fillWith: { }.
	
	self assertItems: {ClyAllMethodGroup. 0}! !

!ClyGroupedInstanceVariablesTest methodsFor: 'tests' stamp: ''!
testFillingWithSingleInstVar

	| classVarGroup allClassVarGroup |
	queryResult fillWith: { ClyInstanceVariable named: #instVar definedIn: ClyClass2FromP1Mock }.
	
	self assertItems: {ClyAllMethodGroup. 0. 
		ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1}.
	classVarGroup := items last actualObject.
	self assert: classVarGroup methodQuery class equals: ClyVariableReferencesQuery.
	self 
		assert: classVarGroup methodQuery variableQuery resultItems 
		equals: {ClyInstanceVariable named: #instVar definedIn: ClyClass2FromP1Mock}.
	allClassVarGroup :=  items second actualObject.
	self assert: allClassVarGroup methodQuery class equals: ClyVariableReferencesQuery.
	self assert: allClassVarGroup methodQuery variableQuery class equals: ClyAllInstanceVariablesQuery.! !

!ClyGroupedInstanceVariablesTest methodsFor: 'tests' stamp: ''!
testFillingWithSingleClassVar

	| classVarGroup |
	queryResult fillWith: { ClyClassVariable named: #ClassVar1 definedIn: ClyClass2FromP1Mock }.
	
	self assertItems: {ClyAllMethodGroup. 0. ClyMethodGroup. 0}.
	classVarGroup := items last actualObject.
	self assert: classVarGroup methodQuery class equals: ClyVariableReferencesQuery.
	self assert: classVarGroup methodQuery variableQuery class equals: ClyAllClassVariablesQuery.
	self assert: classVarGroup subgroupsQuery class equals: ClyAllClassVariablesQuery.
	self assert: classVarGroup subgroupsQuery requiredResult class equals: ClyGroupedClassVariablesResult.
	self 
		assert: classVarGroup subgroupsQuery requiredResult hierarchy 
		equals: queryResult hierarchy! !

!ClyGroupedInstanceVariablesTest methodsFor: 'helpers' stamp: ''!
createQueryResult
	^ClyGroupedInstanceVariablesResult withHierarchy: ClySubclassHierarchy new! !

!ClyGroupedInstanceVariablesTest methodsFor: 'tests' stamp: ''!
testFillingWithOneInstVarAndTwoClassVarsOfSameClass

	queryResult fillWith: { 
		ClyInstanceVariable named: #instVar definedIn: ClyClass2FromP1Mock.
		ClyClassVariable named: #ClassVar2 definedIn: ClyClass2FromP1Mock.
		ClyClassVariable named: #ClassVar1 definedIn: ClyClass2FromP1Mock}.
	
	self assertItems: {ClyAllMethodGroup. 0. ClyMethodGroup. 0.
		ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1 }.
	self assertVars: #(#instVar)! !

!ClyGroupedInstanceVariablesTest methodsFor: 'tests' stamp: ''!
testFillingWithTwoInstVarsOfSameClass
	| variables |
	variables := {
		ClyInstanceVariable named: #instanceSideVar2 definedIn: ClyClass1FromP1Mock.
		ClyInstanceVariable named: #instanceSideVar1 definedIn: ClyClass1FromP1Mock}.
	queryResult fillWith: variables.
	
	self assertItems: {ClyAllMethodGroup. 0. 
		ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1. ClyVariableMethodGroup. 1 }.
	self assertVars: #(#instanceSideVar1 #instanceSideVar2 )! !

!ClyGroupedInstanceVariablesTest methodsFor: 'tests' stamp: ''!
testFillingWithTwoEqualVarsOfDifferentSubclassesAndOneVarOfSuperclass

	queryResult fillWith: { 
		ClyInstanceVariable named: #subclassSameVar definedIn: ClySubclassN2OfClass1FromP1Mock.
		ClyInstanceVariable named: #instanceSideVar2 definedIn: ClyClass1FromP1Mock.
		ClyInstanceVariable named: #subclassSameVar definedIn: ClySubclassN1OfClass1FromP1Mock}.
	
	self assertItems: {ClyAllMethodGroup. 0. 
		ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1.
		ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1.
		ClyVarDefinitionMethodGroup. 0. ClyVariableMethodGroup. 1}.
	self assertVars: #(#instanceSideVar2 #subclassSameVar #subclassSameVar).! !

!ClyGroupedVariablesResult commentStamp: ''!
I am abstract variable query result which represents variables as ClyVariableMethodGroup instances.
My subclases are used in full browser to show variables in third pane.

For subclasses I provide dictionary kind of variable type -> defining class -> variables where 
- variable type is class of given variable. For example there are ClyInstanceVariable and ClyClassVariable.
- defining class is a class which defines given variables 
- and variables is the sorted by name list  

So subclasses should implement method 

- fillWithGroupedVariables: varsPerTypeAndDefiningClass 

which will build required variable groups from given variable structure.
General logic to convert concrete type of variables to groups is common for all subclasses. So they just call my methods: 

- fillWithVariables: varsPerClass type: varTypeClass

which really creates variable group items.
I order variables according to their class hierarchy. The concrete kind of hierarchy is specified in my variable #hierarchy.
So you can get variable list in the order from superclass to subclass or otherwise.

To create my instances use following method: 

	ClyGroupedInstanceVariables withHierarchy: ClySubclassHierarhy new.

Or ask for default hierarchy: 

	ClyGroupedInstanceVariables withDefaultHierarchy.
	
The default hierarchy for variables are managed by ClySubclassHierarchy class:
 	
	ClySubclassHierarchy hierarchyForVariables.
	 
Internal Representation and Key Implementation Points.

    Instance Variables
	hierarchy:		<ClyClassHierarchy>!
!ClyGroupedVariablesResult methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^false ].
	
	^ hierarchy = anObject hierarchy! !

!ClyGroupedVariablesResult methodsFor: 'building' stamp: ''!
fillWithGroupedVariables: varsPerTypeAndDefiningClass
	self subclassResponsibility! !

!ClyGroupedVariablesResult methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: hierarchy hash! !

!ClyGroupedVariablesResult methodsFor: 'building' stamp: ''!
groupVariablesByTypeAndDefinition: variables

	| groups varsPerClass typedVars |
	groups := IdentityDictionary new.
	variables do: [ :var | 
		typedVars := groups at: var class ifAbsentPut: [ IdentityDictionary new ].
		varsPerClass := typedVars 
			at: var definingClass ifAbsentPut: [ self containerForItemsSortedByName ].
		varsPerClass add: var].	
	^groups! !

!ClyGroupedVariablesResult methodsFor: 'accessing' stamp: ''!
hierarchy: anObject
	hierarchy := anObject! !

!ClyGroupedVariablesResult methodsFor: 'accessing' stamp: ''!
hierarchy
	^ hierarchy! !

!ClyGroupedVariablesResult methodsFor: 'building' stamp: ''!
queryScope
	^buildingQuery scope! !

!ClyGroupedVariablesResult methodsFor: 'building' stamp: ''!
fillWith: variables
	| typedGroups |
	typedGroups := self groupVariablesByTypeAndDefinition: variables.
	
	self fillWithGroupedVariables: typedGroups! !

!ClyGroupedVariablesResult methodsFor: 'building' stamp: ''!
fillWithVariables: varsPerClass type: varTypeClass

	| classMap vars declarationGroup varItem methodQueryScope |
	methodQueryScope := self queryScope asLocalClassScope.
	classMap := hierarchy buildFrom: varsPerClass keys.
	classMap doInOrder: [ :eachClass |
		vars := varsPerClass at: eachClass.
		declarationGroup := ClyVarDefinitionMethodGroup
			withMethodsFrom: methodQueryScope 
			referencedAny: varTypeClass definedIn: eachClass.
		items add: declarationGroup asCalypsoBrowserItem.
		vars do: [:each | | varGroup |
			varGroup := ClyVariableMethodGroup withMethodsFrom: methodQueryScope referencedVar: each.
			varItem := varGroup asCalypsoBrowserItem.
			varItem depth: 1.
			items add: varItem] 
	]! !

!ClyGroupedVariablesResult class methodsFor: 'instance creation' stamp: ''!
defaultHierarchy

	^ClySubclassHierarchy hierarchyForVariables! !

!ClyGroupedVariablesResult class methodsFor: 'instance creation' stamp: ''!
withDefaultHierarchy

	^self withHierarchy: self defaultHierarchy! !

!ClyGroupedVariablesResult class methodsFor: 'testing' stamp: ''!
isExpandedHierarchy
	^true! !

!ClyGroupedVariablesResult class methodsFor: 'instance creation' stamp: ''!
withHierarchy: aClassHierarchy

	^self new 
		hierarchy: aClassHierarchy! !

!ClyGroupedVariablesTest methodsFor: 'helpers' stamp: ''!
meaningfullObjectToAssert: aBrowserItem
	^aBrowserItem actualObject class! !

!ClyGroupedVariablesTest methodsFor: 'helpers' stamp: ''!
assertVars: varNames

	| vars i var |
	vars := items 
		select: [ :each | each actualObject isKindOf: ClyVariableMethodGroup ].
	self assert: vars size equals: varNames size.
	i := 1.
	varNames do: [ :expectedVar |
		var := vars at: i.
		self assert: var actualObject name equals: expectedVar.
		i := i + 1]! !

!ClyGroupedVariablesTest methodsFor: 'running' stamp: ''!
createQuery
	"ClyGroupedVariables should build variable method groups using query scope.
	Scope is required to get methods from built groups which are visible only from these classes
	and not just from classes which define given variables"

	| scope |
	scope := ClyInstanceSideScope ofAll: {Object. Array. String} in: environment.
	^ ClyAllClassesQuery from: scope! !

!ClyGroupedVariablesTest methodsFor: 'tests' stamp: ''!
testComparisonWithAnotherHierarchy
	| queryResult2 |
	queryResult2 := self createQueryResult.
	queryResult2 hierarchy: queryResult hierarchy inverted.

	self deny: queryResult equals: queryResult2! !

!ClyGroupedVariablesTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyGroupedVariablesTest! !

!ClyHaltMethodTableDecorator commentStamp: ''!
I decorate table with special icon for methods with halt or breakpoint!
!ClyHaltMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyHaltMethodTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	^ (aDataSourceItem isMarkedWith: ClyMethodWithHaltTag) 
			and: [ (aDataSourceItem isMarkedWith: ClyMethodWithBreakpointTag) not ]! !

!ClyHaltMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
priority
	^900! !

!ClyHaltMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	
	| icon |
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	
	icon := anItemCellMorph definitionIcon: #halt.
	icon setBalloonText: 'halt call inside method'! !

!ClyHierarchicalSystemItemsResult commentStamp: ''!
I am a special kind of system query result which merges together multiple kind of system items in single hierarchy.
So I sort hierarchically classes, methods and class comments, all together.

I am used in query browser to show items.

First I build subclass hierarchy of all classes with define given objects.
For this I convert every object to the browser item and ask it systemDefinitionClass.
At the end I got map between class and children items which are defined by this class. 
The children are sorted using special ClySortSystemItemFunction which takes into account different type of items and their own default sort logic.

Using this built hierarchy I fill my items in hierarchical order.!
!ClyHierarchicalSystemItemsResult methodsFor: 'building' stamp: ''!
buildItemsPerClassFrom: systemObjects
	| itemsPerClass item localItems |
	itemsPerClass := IdentityDictionary new.

	systemObjects do: [ :each |
		item := each asCalypsoBrowserItem.
		localItems := itemsPerClass
			at: item systemDefinitionClass ifAbsentPut: [self containerForItemsOfClass ].
		localItems add: item].
	
	^itemsPerClass! !

!ClyHierarchicalSystemItemsResult methodsFor: 'building' stamp: ''!
containerForItemsOfClass
	^SortedCollection sortBlock: ClySortSystemItemFunction ascending forBrowserItems! !

!ClyHierarchicalSystemItemsResult methodsFor: 'building' stamp: ''!
fillWith: objects
	"System objects supposed to have definition class and package.
	It can be classes, methods, variables, class comments and so on"
	| itemsPerClass localItems classMap |
	itemsPerClass := self buildItemsPerClassFrom: objects.
	classMap := ClySubclassHierarchy buildFrom: itemsPerClass keys.
	
	items := OrderedCollection new: objects size.
	classMap doInOrderWithDepth: [ :eachClass :depth |
		localItems := itemsPerClass at: eachClass.
		localItems do: [:each | each depth: depth].
		items addAll: localItems].! !

!ClyHierarchicalSystemItemsTest methodsFor: 'tests' stamp: ''!
testFillingWithSuperclassAndSubclassMethods

	queryResult fillWith: ClyClass1FromP1Mock localMethods, ClySubclassN1OfClass1FromP1Mock localMethods.

	self 
		assertItems: #(#instanceSideVar1ReaderMethod 0 #instanceSideVar1WriterMethod 0 #instanceSideVar2 0 
			#superclassTag1Method 0 #tag1Method1 0 
			#noTagMethod 1 #subclassN1Var 1 #subclassSameVar 1 #tag1Method1 1 #tag1Method2 1 #tag2Method1 1 ) 		
		withValue: [ :each | each name ]! !

!ClyHierarchicalSystemItemsTest methodsFor: 'tests' stamp: ''!
testFillingWithMethodsAndClasses

	queryResult fillWith: {ClyClass1FromP1Mock. ClyClass1FromP1Mock >> #tag1Method1}.

	self 
		assertItems: #(tag1Method1 0 #ClyClass1FromP1Mock 0) 
		withValue: [ :each | each name ]! !

!ClyHierarchicalSystemItemsTest methodsFor: 'tests' stamp: ''!
testFillingWithClassesFromOneHierarchy

	queryResult fillWith: { ClySubclassN1OfClass1FromP1Mock. ClySubclassLOfSubclassMFromP3Mock. ClyClass1FromP1Mock. ClySubclassN2OfClass1FromP1Mock }.

	self assertItems: {
		ClyClass1FromP1Mock. 0. ClySubclassLOfSubclassMFromP3Mock. 1. 
		ClySubclassN1OfClass1FromP1Mock. 1. ClySubclassN2OfClass1FromP1Mock. 1 }! !

!ClyHierarchicalSystemItemsTest methodsFor: 'helpers' stamp: ''!
createQueryResult
	^ClyHierarchicalSystemItemsResult new! !

!ClyHierarchicalSystemItemsTest methodsFor: 'tests' stamp: ''!
testFillingWithMethodsOfSameClass

	queryResult fillWith: (
		#(tag1Method1 instanceSideVar1WriterMethod instanceSideVar1ReaderMethod) 
			collect: [:each | ClyClass1FromP1Mock >> each]).

	self 
		assertItems: #(#instanceSideVar1ReaderMethod 0 #instanceSideVar1WriterMethod 0 #tag1Method1 0) 
		withValue: [ :each | each name ]! !

!ClyHierarchicallySortedClassesResult commentStamp: ''!
I am a class query result which represent retrieved classes as hierarchically sorted list.

I do not implement hierarchy building logic by myself. Instead I delegate it to the hierarchy variable, a kind of ClyClassHierarchy.
And I use built map to enumerate classes in hierarchical order and convert them to ClyBrowserItem instances.

You can create my instances directly from hierarchy: 

	ClySubcalssHierarchy new asQueryResult
	
Or use explicit class side method: 
	
	ClyHierarchicallySortedClasses with: ClySubcalssHierarchy new.
	
I also provide converting methods to get inverse hierarchy result or sorted by another function: 

	aQueryResult withInverseHierarchy.
	aQueryResult sortedBy: aSortFunction.
!
!ClyHierarchicallySortedClassesResult methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ hierarchy = anObject hierarchy! !

!ClyHierarchicallySortedClassesResult methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	hierarchy := ClySubclassHierarchy new! !

!ClyHierarchicallySortedClassesResult methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: hierarchy hash! !

!ClyHierarchicallySortedClassesResult methodsFor: 'building' stamp: ''!
buildItemFor: aClass from: aHierarchyMap depth: currentDepth

	| item childDepth children subTreeSize childItem |
	item := ClyBrowserItem named: aClass name with: aClass. 
	item depth: currentDepth.
	items add: item.
	childDepth := currentDepth + 1.
	children := aHierarchyMap childrenOf: aClass.
	subTreeSize := children size.
	children do: [ :child | 
		childItem := self buildItemFor: child from: aHierarchyMap depth: childDepth.
		subTreeSize := subTreeSize + childItem localHierarchySize].
	item localHierarchySize: subTreeSize.
	^item! !

!ClyHierarchicallySortedClassesResult methodsFor: 'accessing' stamp: ''!
hierarchy
	^ hierarchy! !

!ClyHierarchicallySortedClassesResult methodsFor: 'accessing' stamp: ''!
hierarchy: anObject
	hierarchy := anObject! !

!ClyHierarchicallySortedClassesResult methodsFor: 'converting' stamp: ''!
withInverseHierarchy
	^self copy 
		hierarchy: hierarchy inverted! !

!ClyHierarchicallySortedClassesResult methodsFor: 'converting' stamp: ''!
sortedBy: aSortFunction
	^self copy 
		hierarchy: (hierarchy sortedBy: aSortFunction)! !

!ClyHierarchicallySortedClassesResult methodsFor: 'building' stamp: ''!
fillWith: classes

	| hierarchyMap |
	items := OrderedCollection new: classes size.
	hierarchyMap := hierarchy buildFrom: classes.
	
	hierarchyMap rootsDo: [ :root | 
		self buildItemFor: root from: hierarchyMap depth: 0]! !

!ClyHierarchicallySortedClassesResult class methodsFor: 'building items' stamp: ''!
buildItemsFrom: classes

	| classesHierarchy |
	classesHierarchy := self new.
	classesHierarchy items: (OrderedCollection new: classes size).
	classesHierarchy fillWith: classes.
	^classesHierarchy items! !

!ClyHierarchicallySortedClassesResult class methodsFor: 'testing' stamp: ''!
isExpandedHierarchy
	^true! !

!ClyHierarchicallySortedClassesResult class methodsFor: 'instance creation' stamp: ''!
with: aClassHierarchy
	^self new 
		hierarchy: aClassHierarchy! !

!ClyHierarchicallySortedClassesTest methodsFor: 'tests' stamp: ''!
testComparisonWithResultWithAnotherSortFunction
	| queryResult2 |
	queryResult2 := queryResult sortedBy: #anotherSortFunction.

	self deny: queryResult equals: queryResult2.
	self deny: queryResult identicalTo: queryResult2! !

!ClyHierarchicallySortedClassesTest methodsFor: 'tests' stamp: ''!
testComparisonWithResultWithAnotherHierarchyType
	| queryResult2 |
	queryResult2 := self createQueryResult.
	queryResult2 hierarchy: #anotherHierarchy.

	self deny: queryResult equals: queryResult2! !

!ClyHierarchicallySortedClassesTest methodsFor: 'tests' stamp: ''!
testFillingWithClassesFromOneHierarchy

	queryResult fillWith: { ClySubclassN1OfClass1FromP1Mock. ClySubclassLOfSubclassMFromP3Mock. ClyClass1FromP1Mock. ClySubclassN2OfClass1FromP1Mock }.

	self assertItems: {
		ClyClass1FromP1Mock. 0. ClySubclassLOfSubclassMFromP3Mock. 1. 
		ClySubclassN1OfClass1FromP1Mock. 1. ClySubclassN2OfClass1FromP1Mock. 1 }! !

!ClyHierarchicallySortedClassesTest methodsFor: 'tests' stamp: ''!
testFillingWithObjectAndTwoProtoObjects

	queryResult fillWith: { Object. ProtoObject. ProtoObject }.
	
	self assertItems: {ProtoObject. 0. Object. 1}! !

!ClyHierarchicallySortedClassesTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyHierarchicallySortedClassesResult new! !

!ClyHierarchicallySortedClassesTest methodsFor: 'tests' stamp: ''!
testComparisonWithResultWithSameHierarchyAbdSortFunction
	| queryResult2 |
	queryResult2 := queryResult sortedBy: queryResult hierarchy sortFunction.

	self assert: queryResult equals: queryResult2.
	self assert: queryResult hash equals: queryResult2 hash! !

!ClyHierarchicallySortedClassesTest methodsFor: 'tests' stamp: ''!
testComparisonWithResultWithSimilarInverseHierarchy
	| queryResult2 |
	queryResult2 := self createQueryResult.
	queryResult2 := queryResult2 withInverseHierarchy.

	self deny: queryResult equals: queryResult2! !

!ClyHierarchicallySortedClassesTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItGrandSuperclass
	
	queryResult fillWith: { ClyClass1FromP1Mock. ClySubclassLOfSubclassMFromP3Mock }.
	
	self assertItems: {ClyClass1FromP1Mock. 0. ClySubclassLOfSubclassMFromP3Mock. 1}! !

!ClyHierarchicallySortedClassesTest methodsFor: 'tests' stamp: ''!
testFillingWithTwoSameClasses

	queryResult fillWith: { ClyClass1FromP1Mock. ClyClass1FromP1Mock }.

	self assertItems: { ClyClass1FromP1Mock. 0 }! !

!ClyHighlightingSelection commentStamp: ''!
I represent highlighted table items.

When data source is changed I responsible to update highlighted rows of table.
For example when user expands tree node highlighted indexes should be shifted when expansion happens before selection. Same should be done when items of data source are removed or added.

I just override how set up table selection by applying highlighted row indexes to table!
!ClyHighlightingSelection methodsFor: 'initialization' stamp: ''!
setUpSelectedRows: indexes in: aTableMorph silently: silentSelection
	silentSelection
		ifTrue: [ aTableMorph basicHighlightIndexes: indexes ]
		ifFalse: [ "we should prevent ignoring new selection if indexes are still same"
			aTableMorph basicHighlightIndexes: #(-1000).
			aTableMorph highlightIndexes: indexes ]! !

!ClyHighlightingSelection methodsFor: 'controlling' stamp: ''!
ensureVisibleLastItem
	"highlighting should never force table visible position"! !

!ClyIcebergShowMethodVersionCommand commentStamp: ''!
I am a command to show method history available from iceberg repository.
So I am only available for packages driven by Iceberg.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	method:		<CompiledMethod>
	repository:		<IceRepository>!
!ClyIcebergShowMethodVersionCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'History'! !

!ClyIcebergShowMethodVersionCommand methodsFor: 'execution' stamp: ''!
execute
	| browserClass packageName repositoriesWithPackage repository |
	
	packageName := method package name.
	repositoriesWithPackage := 	IceRepository registry 
		select: [ :each | each includesPackageNamed: packageName ].
	repositoriesWithPackage ifEmpty: [ 
		UIManager default inform: 'No repositories include package ', packageName.
		^ self ].
	repository := repositoriesWithPackage size > 1 
		ifTrue: [ 
			UIManager default 
				chooseFrom: (repositoriesWithPackage collect: [ :each | each name ])
				values: repositoriesWithPackage
				title: 'Repository' ]
		ifFalse: [ repositoriesWithPackage anyOne ].
	repository ifNil: [ ^ self ].
	
	self flag: #pharoTodo.
	"This is a way to hide a dependency to Iceberg-IceTip package."
	browserClass := #IceTipVersionHistoryBrowser
		asClassInEnvironment: self class environment.
		
	(browserClass onRepository: repository method: method) openWithSpec! !

!ClyIcebergShowMethodVersionCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	
	super prepareFullExecutionInContext: aToolContext.
	method := aToolContext lastSelectedMethod! !

!ClyIcebergShowMethodVersionCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#komitterSmalltalkhubRemote! !

!ClyIcebergShowMethodVersionCommand class methodsFor: 'accessing' stamp: ''!
methodBrowserTabActivation
	<classAnnotation>
	
	^ClyBrowserTabCommandActivation for: ClyMethod asCalypsoItemContext! !

!ClyIcebergShowMethodVersionCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	self flag: #todo. "Check for IceLog is temporal, to let time to update iceberg on Pharo 7.0a"
	^ aToolContext isMethodSelected 
		and: [ (Smalltalk globals includesKey: #IceLog)
		and: [ (IceRepository registeredRepositoryIncludingPackage: aToolContext lastSelectedMethod package) notNil ] ]! !

!ClyIcebergShowMethodVersionCommand class methodsFor: 'accessing' stamp: ''!
methodMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup order: 1001 for: ClyMethod asCalypsoItemContext! !

!ClyIconProperty commentStamp: ''!
I am used to mark objects with icon.
To instantiate me execute:
	ClyIconProperty named: aSymbol 
 
Internal Representation and Key Implementation Points.

    Instance Variables
	iconName:		<Symbol>!
!ClyIconProperty methodsFor: 'accessing' stamp: ''!
iconName: anObject
	iconName := anObject! !

!ClyIconProperty methodsFor: 'accessing' stamp: ''!
iconName
	^ iconName! !

!ClyIconProperty methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	aStream nextPutAll: iconName.
	aStream nextPut: $).! !

!ClyIconProperty class methodsFor: 'instance creation' stamp: ''!
named: aString
	^self new
		iconName: aString! !

!ClyInheritanceAnalysisBrowserPlugin commentStamp: ''!
I am special browser plugin to restrict table decorators in this package to appear only in browsers where I am installed!
!ClyInheritanceAnalysisEnvironmentPlugin commentStamp: ''!
I plug environment with many kind of inheritance hints.

I tag abstract classes and method.
I analyze method inheritance and tag method with overriden and overriding tags.

To check if method is overriding superclass methods use following expression: 

	plugin isMethodOverriding: aMethod.

For implementation I simply call "aMethod isOverriding" which checks if any superclass implements same selector. It is quite fast operation due to the fact that the size of most of the hierarchies are not much than 10.

To check if method is overridden by some of subclasses methods use following expression: 

	plugin isMethodOverridden: aMethod.

The "aMethod isOverridden" can be very expensive. It enumerates all subclasses of the method class. And there are classes with really huge hierarchies like Object or Morph. 
To optimize overridden state analysis I build the cache of all method implementors in the image (#allImplementorsCache). It makes the analysis for big hierarchies very fast. But for small hierachies the #isOverridden operation is faster. I use the cache only when the class of the method has more than 10 subclasses in the hierarchy. Testing approves that it is a good criteria. But you can specify different value using #littleHierarchyMaxSize variable.

In addition #allImplementorsCache is built lazely only when I need to analyze big hierarchy. It avoids the effect of slow analysis in general browser experience. Users rarely open the browser on huge hierarcies. And only in such scenarious they can notice the little initial delay when browser is opening. (Testing shows just 200 ms to build the cache for vanila Pharo image on macair machine).

I am subscribed on system changes and invalidate #allImplementorsCache when related classes or methods are changed (look at #attachToSystem method for details).

In addition I provide following method groups:
	- abstract methods
	- override methods
	- overridden methods 
	- should be implemented methods!
!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'methods analysis' stamp: ''!
isMethodOverriding: aMethod
	"We do not use implementors cache for overriding state analysis 
	because the direct method #isOverriding is much faster"
	^aMethod isOverriding! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'implementors cache' stamp: ''!
updateCacheForMethod: aMethod
	allImplementorsCache ifNil: [ ^self ].
	
	cacheGuard critical: [
		aMethod isInstalled 
			ifTrue: [ self cacheMethod: aMethod ]
			ifFalse: [ self removeMethodFromCache: aMethod]				
	]! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
processFullClassChange: aClassModificationApplied
	
	environment systemChanged: (
		ClyOverriddenSuperclassesChanged overridingSubclass: aClassModificationApplied classAffected).
	environment systemChanged: (
		ClyOverridingSubclassesChanged overriddenSuperclass: aClassModificationApplied classAffected)! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	cacheGuard := Mutex new.
	littleHierarchyMaxSize := 10! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'methods analysis' stamp: ''!
isMethodOverridden: aMethod
	| classes methodClass |
	"Implementors cache optimizes analyzis only for classes with a lot of subclasses.
	For example Object and Morph are really profit from it.
	But for simple hierarchies the direct overridden state analysis is quite cheap operation.
	And it's much faster than processing using cache.
	In addition using cheap processing path allows to defer the cache building.
	It removes the effect of initial slow analysis from general browser experience 
	where user rarely browse the root classes of big hierarchies"
	(self isClassCheapForOverriddenMethodsAnalysis: aMethod methodClass) ifTrue: [ 
			^aMethod isOverridden ].
	
	classes := self implementorsOf: aMethod.	
	methodClass := aMethod methodClass.
	^classes anySatisfy: [ :each | 
		each notNil and: [(each inheritsFrom: methodClass) and: [ each isObsolete not ]]]! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'implementors cache' stamp: ''!
cacheMethod: aMethod
	| classes |
	classes := self implementorsOf: aMethod.
	classes add: aMethod methodClass! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'accessing' stamp: ''!
littleHierarchyMaxSize
	^ littleHierarchyMaxSize! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofClass: aClass
	(aClass classSide includesLocalSelector: #isAbstract) ifTrue: [ 
		aClass instanceSide isAbstract ifTrue: [ anItem markWith: ClyAbstractItemTag ].
		^self].
		
	(self checkClassIsAbstract: aClass) ifTrue: [ 
		anItem markWith: ClyAbstractItemTag ]! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'accessing' stamp: ''!
littleHierarchyMaxSize: anObject
	littleHierarchyMaxSize := anObject! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'method groups' stamp: ''!
collectMethodGroupProviders
	^{ClyAbstractMethodGroupProvider. ClyOverridingMethodGroupProvider. ClyOverriddenMethodGroupProvider. ClyRequiredMethodGroupProvider}
		collect: [ :each | each new ]! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'methods analysis' stamp: ''!
isClassCheapForOverriddenMethodsAnalysis: aClass
	"Building cache of all implementors is expensive operation 
	and we are trying to avoid it until it becomes really necessary for performance.
	Here we are using a simple criteria to detect that we can avoid the cache.
	When there are small amount of subclasses if it always cheap operation without any cache"
		
	| numberOfSubclasses |
	numberOfSubclasses := 0.
	aClass allSubclassesDo: [ :each | 
		numberOfSubclasses > littleHierarchyMaxSize ifTrue: [ ^false ].
		numberOfSubclasses := numberOfSubclasses + 1].
	^true! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'implementors cache' stamp: ''!
cacheAllImplementors

	cacheGuard critical: [ 
		allImplementorsCache := IdentityDictionary new: Symbol selectorTable size.
		environment systemScope methodsDo: [ :each |
			self cacheMethod: each ]
	]! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'implementors cache' stamp: ''!
implementorsOf: aMethod
	allImplementorsCache ifNil: [ self cacheAllImplementors ].
	
	^allImplementorsCache at: aMethod selector ifAbsentPut: [ WeakOrderedCollection new ]
	"Classes implementing each selector are cached using weak structure.
	It allows to avoid cleaning cache when user removes the class.
	As consequence nobody needs anymore to test the presence of given class in these caches.
	it allows to use WeakOrderedCollection here 
	which is much faster for building full implementors cache.
	Notice that WeakOrderedCollection requires to be carefull with enumerating items 
	because they can become nil by garbage collector"! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
processClassRemoval: aClassRemoved
	"We do not update cache when class is removed 	because it will slow down removal operation.
	(it requires enumeration of all key elements (~54000 selectors in the image)
	The cleaning is based on weak registry for classes 
	and cache analysis skips obsolete classes when they are still in cache"
	
	environment systemChanged: (
		ClyOverriddenSuperclassesChanged overridingSubclass: aClassRemoved classAffected)! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'implementors cache' stamp: ''!
removeMethodFromCache: aMethod
	
	| classes |
	classes := allImplementorsCache at: aMethod selector ifAbsent: [^self].
	classes remove: aMethod methodClass ifAbsent: [ ].
	"Classes are WeakOrderedCollection 
	and when it is cleaned by GS it does not become empty. All items are just replaced by nil"
	(classes isEmpty or: [ 
		classes allSatisfy: [:each | each isNil or: [ each isObsolete ] ]])
			ifTrue: [allImplementorsCache removeKey: aMethod selector]! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
processMethodChange: aMethodAnnouncement
	| method |
	self updateCacheForMethod: aMethodAnnouncement methodAffected.
	
	method := aMethodAnnouncement methodAffected.
	method methodClass superclass ifNotNil: [ :superclass |
		(superclass lookupSelector: method selector) ifNotNil: [:overriddenMethod |
			^environment systemChanged: (ClyOverriddenMethodChanged method: overriddenMethod)]
	].
	method methodClass subclasses ifEmpty: [ ^self ].
	environment systemChanged: (
		ClyOverridingMethodsChanged initiatedBy: self forOverriddenMethod: method)! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
detachFromSystem 
	environment system unsubscribe: self.
	
	super detachFromSystem! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
checkClassIsAbstract: aClass
	"Method is copied from Pharo7 Behavior>>isAbstract"
	
	aClass withAllSuperclassesDo: [ :eachClass | 
		eachClass methodsDo: [ :eachMethod |
			(eachMethod isAbstract and: [ (aClass lookupSelector: eachMethod selector) isAbstract ])
				ifTrue: [ ^true ]]].
	
	^false! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'implementors cache' stamp: ''!
resetImplementorsCache

	cacheGuard critical: [ 
		allImplementorsCache := nil.
	]! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
attachToSystem
	super attachToSystem.
	
	environment system when: MethodAdded, MethodRemoved send: #processMethodChange: to: self.
	environment system when: ClassRemoved send: #processClassRemoval: to: self.
	environment system when: ClassModifiedClassDefinition send: #processClassDefinitionChange: to: self.
	environment system when: ClassModificationApplied send: #processFullClassChange: to: self.! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
processClassDefinitionChange: aClassDefinitionChange
	aClassDefinitionChange oldClassDefinition superclass ifNotNil: [:superclass |
		"Two definition changes are always triggered. 
		We always skip the first one when system is inconsistent state 
		which is reflected by following condition"
		(superclass subclasses includes: aClassDefinitionChange oldClassDefinition)
			ifTrue: [ ^self ] ].
	(aClassDefinitionChange oldClassDefinition superclass 
		= aClassDefinitionChange newClassDefinition superclass) ifTrue: [ ^self ].	
	
	environment systemChanged: (
		ClyOverriddenSuperclassesChanged overridingSubclass: aClassDefinitionChange oldClassDefinition)! !

!ClyInheritanceAnalysisEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod

	aMethod isAbstract ifTrue: [ anItem markWith: ClyAbstractItemTag ].
	
	(self isMethodOverriding: aMethod) ifTrue: [ 
		anItem markWith: ClyOverridingMethodTag ].
	(self isMethodOverridden: aMethod) ifTrue: [ 
		anItem markWith: ClyOverriddenMethodTag ]! !

!ClyInheritanceAnalysisEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isSlow
	^true! !

!ClyInheritanceAnalysisMethodQuery commentStamp: ''!
I am abstract method query to group together other queries which analyzes methods inheritance.

I provide implementation to react on system changes and some helper methods for subclasses!
!ClyInheritanceAnalysisMethodQuery methodsFor: 'testing' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	"This query is not restricted by the scope
	because it analyses methods from scope classes together with all superclasses.
	So the result can be affected by the changes out of query scope.
	And here we omit scope logic and rely completely on event.
	So the actual decision about affect 
	is based on #isAffectedByChangedMethod: method
	and generally on any class change"
	^aSystemAnnouncement affectsClasses 
		or: [ aSystemAnnouncement canAffectResultOfMethodQuery: self]! !

!ClyInheritanceAnalysisMethodQuery methodsFor: 'testing' stamp: ''!
isFromScopeWithClassKindOf: aClass
	scope
		classesDo: [ :each | 
			(each includesBehavior: aClass)
				ifTrue: [ ^ true ] ].
	^ false! !

!ClyInheritedMethodGroup commentStamp: ''!
I am group of inherited methods. 
Depending on my query I include methods from on or all traits and superclasses which are inherited by given classes.

I can be expanded by subgroups of each inherited class. It will be also my instances but they will be configured by single class scope method query.

In the browser I provide few checkboxes to switch method visibility. It is based on my visibilityLevels, collection of ClyMethodVisibilityLevel instances.
They are extended by plugins. For example Traits plugin adds local trait visibility level. 


Internal Representation and Key Implementation Points.

    Instance Variables
	visibilityLevels:		<Collection of<ClyMethodVisibilityLevel>>
!
!ClyInheritedMethodGroup methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem
	super decorateTableCell: anItemCellMorph of: groupItem.
	anItemCellMorph setBalloonText: self tooltipText.
	
	visibilityLevels do: [ :each | 
		each decorateMethodGroupTableCell: anItemCellMorph of: groupItem ]! !

!ClyInheritedMethodGroup methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
tooltipText

	^'Expand me to toggle method visibility of concrete class.
Use checkbox at the right of label to make all inherited methods visible in browser (it skips Object methods). Select me to see all inherited methods which are not overriden by selected class'! !

!ClyInheritedMethodGroup methodsFor: 'operations' stamp: ''!
removeWithMethods
	self error: 'You should not remove inherited methods'! !

!ClyInheritedMethodGroup methodsFor: 'accessing' stamp: ''!
visibilityLevels
	^ visibilityLevels! !

!ClyInheritedMethodGroup methodsFor: 'testing' stamp: ''!
includesMethod: aMethod
	"Original version:
		^self methodQuery retrievesItem: aMethod
	shows bad logic behind #retrievesItem: method. It do not take into account scope of the query.
	It can be addressed in future. 
	Now we just think that argument here could not be inherited method. So the group never include it"
	
	^ true! !

!ClyInheritedMethodGroup methodsFor: 'accessing' stamp: ''!
visibilityLevels: levelCollection
	visibilityLevels := levelCollection reject: [ :each | each isRedundant ]! !

!ClyInheritedMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethodQuery: aMethodQuery andClassesInheritedFrom: aClassScope
	| subgroupsQuery |
	subgroupsQuery := ClyAllClassesQuery 
		from: aClassScope asInheritedScope, aClassScope asLocalClassScope
		as: ClyMethodVisibilityGroupsResult withDefaultHierarchy.		
				
	^(self named: 'inherited methods' priority: 10 on: aMethodQuery withSubgroupsFrom: subgroupsQuery)
		visibilityLevels: { ClyFullVisibilityLevel of: aClassScope }! !

!ClyInheritedMethodGroup class methodsFor: 'accessing' stamp: ''!
priority
	^10! !

!ClyInheritedMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethodsInheritedFrom: aClassScope

	^self  
		withMethodQuery: (ClyAllMethodsQuery from: aClassScope asInheritedScope)
		andClassesInheritedFrom: aClassScope! !

!ClyInheritedMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethodsOf: aClass toShowIn: aClassScope
	
	| methodQuery |
	methodQuery := ClyAllMethodsQuery 
		from: (aClassScope asScope: ClyClassScope of: aClass).
				
	^(self named: aClass name on: methodQuery)
		visibilityLevels: { ClySuperclassVisibilityLevel of: aClassScope toShow: aClass }! !

!ClyInheritedMethodGroupProvider commentStamp: ''!
I statically provide single ClyAllMethodGroup.

It is shown in the browser either with 'instance side' or 'class side' names depending on meta level of my method query!
!ClyInheritedMethodGroupProvider methodsFor: 'testing' stamp: ''!
isStatic
	^true! !

!ClyInheritedMethodGroupProvider methodsFor: 'testing' stamp: ''!
shouldBuildGroupWith: aMethodQuery
	
	^true! !

!ClyInheritedMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyAllMethodsQuery from: aClassScope asLocalClassScope! !

!ClyInheritedMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	
	^ClyAllMethodGroup 
		withMethodQuery: aMethodQuery andClassesInheritedFrom: aClassScope! !

!ClyInheritedMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyInheritedMethodGroupProvider! !

!ClyInheritedMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	^ClyClass1FromP1Mock! !

!ClyInheritedScopeProviderAnnotation commentStamp: ''!
I am special annotation which marks classes that they can provide inherited scope.

Users do not need to lookup my instances. They can simple use following method which will find appropriate class and create the scope using it:

	ClyInheritedScopeProvider createScopeFrom: aClassScope

Or simply convert given class scope using: 

	aClassScope asInheritedScope
	
I am used to be able redefine meaning of inherited scope in the system. 
By default it is ClySuperclassScope. But with traits it is composite scope which also includes inherited traits.

During annotations lookup I just use first registered annotation with lagest priority. 
For example ClyInheritedTraitScope is annotated by me with high priority value 100.

I expect that annotated classes will implement following class side method 

- createInheritedScopeFrom: aClassScope

Look at ClyInheritedScopeProvider references for examples!
!ClyInheritedScopeProviderAnnotation methodsFor: 'scope creation' stamp: ''!
createInheritedScopeFrom: aClassScope

	| scope |
	scope := annotatedClass createInheritedScopeFrom: aClassScope.
	scope name: ClyClassScope inheritedScopeName.
	^scope! !

!ClyInheritedScopeProviderAnnotation methodsFor: 'scope creation' stamp: ''!
createInheritingScopeFrom: aClassScope

	| scope |
	scope := annotatedClass createInheritingScopeFrom: aClassScope.
	scope name: ClyClassScope inheritingScopeName.
	^scope! !

!ClyInheritedScopeProviderAnnotation class methodsFor: 'scope creation' stamp: ''!
createInheritedScopeFrom: aClassScope
	"We just search first most priority annotation 
	which class defines inherited scope.
	So plugin packages can introduce and override inherited scope by annotating 
	factory classes with greater priority value"
	self registeredInstancesDo: [ :each | 
		^each createInheritedScopeFrom: aClassScope].
	
	self error: 'No scope is found which defines inherited class scope'! !

!ClyInheritedScopeProviderAnnotation class methodsFor: 'scope creation' stamp: ''!
createInheritingScopeFrom: aClassScope
	"We just search first most priority annotation 
	which class defines inherited scope. Such classes must also define inverse inheriting scope.
	So plugin packages can introduce and override inherited scope by annotating 
	factory classes with greater priority value"
	self registeredInstancesDo: [ :each | 
		^each createInheritingScopeFrom: aClassScope].
	
	self error: 'No scope is found which defines inheriting class scope'! !

!ClyInheritedTraitScope commentStamp: ''!
I represent class scope of all inherited traits excluding basis.
I see methods of all traits which are used by my basis classes or traits!
!ClyInheritedTraitScope class methodsFor: 'inherited scope' stamp: ''!
createInheritedScopeFrom: aClassScope
	^(aClassScope asScope: ClyMultipleClassRelationScope)
		relationScopeClasses: { ClySuperclassScope. self }! !

!ClyInheritedTraitScope class methodsFor: 'inherited scope' stamp: ''!
createInheritingScopeFrom: aClassScope
	^(aClassScope asScope: ClyMultipleClassRelationScope)
		relationScopeClasses: { ClySubclassScope. ClyTraitUserScope }! !

!ClyInheritedTraitScope class methodsFor: 'inherited scope' stamp: ''!
inheritedScopeProvider
	<classAnnotation>
	
	^ClyInheritedScopeProviderAnnotation new 
		priority: 100! !

!ClyInheritedTraitScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'traits'! !

!ClyInheritedTraitScope class methodsFor: 'accessing' stamp: ''!
classesRelatedTo: aClass do: aBlock
	"Do nothing. Traits are NOT inherited."! !

!ClyInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithOnlyClassWhichHasTraits
	
	queryResult fillWith: {ClyClassWithTraits}.
		
	self assertItems: {ClyClassWithTraits. 0}! !

!ClyInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithTwoClassWhichInheriteSameTraits
	
	queryResult fillWith: {ClyClassWithTraits. ClyTraitChild2. ClyTraitRoot2.
		ClySubclassWithTraitsOfClassWithTraits "inherits Root2 in deep chain"}.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild2. 1. ClyTraitRoot2. 2. 
			ClyTraitRoot2. 1.
		ClySubclassWithTraitsOfClassWithTraits. 0. ClyTraitRoot2. 1}! !

!ClyInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItsDeepTwoTraits
	
	queryResult fillWith: {ClyClassWithTraits. ClyTraitChild2. ClyTraitRoot2 }.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild2. 1. ClyTraitRoot2. 2. 
			ClyTraitRoot2. 1}! !

!ClyInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassWithoutTraits
	
	queryResult fillWith: {ClyClassWithoutTraits}.
		
	self assertItems: {ClyClassWithoutTraits. 0}! !

!ClyInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithTraitsOfClassWhichIsMissingInGivenList
	
	queryResult fillWith: {
		ClyTraitChild1. ClyTraitChild2. ClyTraitRoot1. ClyTraitChild2Child }.
		
	self assertItems: {
		ClyTraitChild1. 0. ClyTraitRoot1. 1. 
		ClyTraitChild2Child. 0. ClyTraitChild2. 1. ClyTraitRoot1. 2}.! !

!ClyInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItsTraitsWhenSomeMiddleTraitIsMissing
	
	queryResult fillWith: {
		ClyClassWithTraits. ClyTraitChild1. ClyTraitRoot1. ClyTraitChild2Child }.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild1. 1. ClyTraitRoot1. 2. 
			ClyTraitChild2Child. 1. ClyTraitRoot1. 2}.! !

!ClyInheritedTraitsHierarchyTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyTraitUserHierarchy inverse asQueryResult! !

!ClyInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItsTraits
	
	queryResult fillWith: {
		ClyClassWithTraits. ClyTraitChild1. ClyTraitChild2. ClyTraitRoot1. ClyTraitChild2Child }.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild1. 1. ClyTraitRoot1. 2. 
			ClyTraitChild2Child. 1. ClyTraitChild2. 2. ClyTraitRoot1. 3}.! !

!ClyInspectSelectionCommand commentStamp: ''!
I am a command to inspect current selected items in the browser.
If there is multiple selection I open inspector on selected list.
And when there single selection I open inspector directly on single item.

Internal Representation and Key Implementation Points.

    Instance Variables
	selectedItems:		<Collection of<Object>>!
!ClyInspectSelectionCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Inspect'! !

!ClyInspectSelectionCommand methodsFor: 'execution' stamp: ''!
execute
	selectedItems size = 1 
		ifTrue: [ selectedItems first inspect ]
		ifFalse: [ selectedItems inspect]! !

!ClyInspectSelectionCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aBrowserContext
	super prepareFullExecutionInContext: aBrowserContext.
	
	selectedItems := aBrowserContext selectedObjects! !

!ClyInspectSelectionCommand class methodsFor: 'activation' stamp: ''!
browserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: PharoShortcuts current inspectItShortcut for: ClyBrowserContext! !

!ClyInspectSelectionCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext
	^aBrowserContext hasSelectedItems! !

!ClyInspectSelectionCommand class methodsFor: 'activation' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClyBrowserContext! !

!ClyInstallMetaLinkCommand commentStamp: ''!
I am a command to install metalinks on the selected method or one of its ast nodes.
I open a small browser to choose which metalink to install among existing metalink instances.!
!ClyInstallMetaLinkCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Install MetaLink...'! !

!ClyInstallMetaLinkCommand methodsFor: 'execution' stamp: ''!
execute
	ClyMetaLinkInstallationPresenter openInstallerOnNode: sourceNode! !

!ClyInstallMetaLinkCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallObjects! !

!ClyInstallMetaLinkCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder
	^100! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'tests' stamp: ''!
testToolbarButtonsForMetalinkUninstallation
	|toolbarButtons|
	toolbarButtons := self presenterForMetalinkUninstallation toolbarButtons.
	self assert: toolbarButtons first label equals: 'Uninstall'.
	self assert: toolbarButtons last label equals: 'Cancel'.! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'helper methods' stamp: ''!
nodeInRealMethod
	^(self class >> #dummyMethod) ast statements first! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'running' stamp: ''!
presenterForMetalinkInstallation
	^ClyMetaLinkInstallationPresenter onNode: node forInstallation:  true! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'running' stamp: ''!
tearDown
	metalink uninstall.
	metalink2 uninstall.
	super tearDown! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'tests' stamp: ''!
testUninstallSelectedMetalinkActionButton
	|presenter list|
	self nodeInRealMethod link: metalink.
	presenter := ClyMetaLinkInstallationPresenter onNode: self nodeInRealMethod forInstallation:  false.
	list := presenter metalinkListPresenter.
	list clickItem: 1.	
	self assert: self nodeInRealMethod hasMetaLinks.
	presenter toolbarButtons first click.
	self deny: self nodeInRealMethod hasMetaLinks! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'tests' stamp: ''!
testUninstallSelectedMetalink
	|presenter list|
	self nodeInRealMethod link: metalink.
	presenter := ClyMetaLinkInstallationPresenter onNode: self nodeInRealMethod forInstallation:  false.
	list := presenter metalinkListPresenter.
	list clickItem: 1.
	self assert: self nodeInRealMethod hasMetaLinks.
	presenter uninstallSelectedMetalink.
	self deny: self nodeInRealMethod hasMetaLinks! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'tests' stamp: ''!
testRelevantMetalinksForInstallation
	|links|
	links := self presenterForMetalinkInstallation allRelevantMetaLinks.
	self assert: links size >= 2.
	self assertCollection: links includesAll: { metalink. metalink2 }.
	self denyCollection: links includesAll: { breakpoint. watchpoint. executionCounter  }.! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'tests' stamp: ''!
testToolbarButtonsCollectionSize
	self assert: self presenterForMetalinkInstallation toolbarButtons size equals: 2.
	self assert: self presenterForMetalinkUninstallation toolbarButtons size equals: 2.! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'helper methods' stamp: ''!
dummyMethod
	self! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'tests' stamp: ''!
testRelevantMetalinksForUninstallation
	| links |
	links := self presenterForMetalinkUninstallation allRelevantMetaLinks.
	self assert: links size equals: 1.
	self assertCollection: links hasSameElements: { metalink }! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'tests' stamp: ''!
testToolbarButtonsForMetalinkInstallation
	|toolbarButtons|
	toolbarButtons := self presenterForMetalinkInstallation toolbarButtons.
	self assert: toolbarButtons first label equals: 'Install'.
	self assert: toolbarButtons last label equals: 'Cancel'.! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'running' stamp: ''!
presenterForMetalinkUninstallation
	^ ClyMetaLinkInstallationPresenter onNode: node forInstallation: false! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'tests' stamp: ''!
testInstallSelectedMetalink
	|presenter list|
	presenter := ClyMetaLinkInstallationPresenter onNode: self nodeInRealMethod forInstallation:  true.
	list := presenter metalinkListPresenter.
	list clickItem: 1.
	self deny: self nodeInRealMethod hasMetaLinks.
	presenter installSelectedMetalink.
	self assert: self nodeInRealMethod hasMetaLinks.
	self assert: self nodeInRealMethod links asArray first identicalTo: list items first! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'tests' stamp: ''!
testInstallSelectedMetalinkActionButton
	|presenter list|
	presenter := ClyMetaLinkInstallationPresenter onNode: self nodeInRealMethod forInstallation:  true.
	list := presenter metalinkListPresenter.
	list clickItem: 1.	
	self deny: self nodeInRealMethod hasMetaLinks.
	presenter toolbarButtons first click.
	self assert: self nodeInRealMethod hasMetaLinks.
	self assert: self nodeInRealMethod links asArray first identicalTo: list items first! !

!ClyInstallMetaLinkPresenterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	MetaLink uninstallAll.
	node := RBVariableNode named: 'test'.
	metalink := MetaLink new.
	metalink2 := MetaLink new.
	breakpoint := MetaLink new metaObject: Break; yourself.
	executionCounter := MetaLink new metaObject: ExecutionCounter new; yourself.
	watchpoint := MetaLink new metaObject: Watch new; yourself.
	node propertyAt: #links put: {metalink. breakpoint. executionCounter. watchpoint} asOrderedCollection! !

!ClyInstanceSideScope commentStamp: ''!
I represent instance side of classes!
!ClyInstanceSideScope class methodsFor: 'class selection' stamp: ''!
metaLevelOf: aClass
	^aClass instanceSide! !

!ClyInstanceSideScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'inst. side'! !

!ClyInstanceSideScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumeration
	scope := ClyInstanceSideScope ofAll: {ClyClass1FromP1Mock classSide. ClyClass2FromP1Mock}.
	
	scope classesDo: [ :each | result add: each ].
	
	self assert: result asArray equals: {ClyClass1FromP1Mock. ClyClass2FromP1Mock}! !

!ClyInstanceSideScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBasisIsClass

	| expected |
	scope := ClyInstanceSideScope of: ClyClass1FromP1Mock.
	scope methodsDo: [ :each | result add: each selector ].
	expected := ClyClass1FromP1Mock localMethods collect: [:each | each selector].
	self assert: result sorted asArray equals: expected sorted asArray! !

!ClyInstanceSideScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBasisIsTraitedClass

	| expected |
	scope := ClyInstanceSideScope of: ClyClassWithTraits.	
	scope methodsDo: [ :each | result add: each selector ].
	expected := ClyClassWithTraits methods collect: [:each | each selector].
	self assert: result sorted asArray equals: expected sorted asArray! !

!ClyInstanceSideScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBasisIsTraitedClassClasSide

	| expected |
	scope := ClyInstanceSideScope of: ClyClassWithTraits classSide.
	scope methodsDo: [ :each | result add: each selector ].
	expected := ClyClassWithTraits methods collect: [:each | each selector].
	self assert: result sorted asArray equals: expected sorted asArray! !

!ClyInstanceSideScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBasisIsMetaclass

	| expected |
	scope := ClyInstanceSideScope of: ClyClass1FromP1Mock classSide.	
	scope methodsDo: [ :each | result add: each selector ].
	expected := ClyClass1FromP1Mock localMethods collect: [:each | each selector].
	self assert: result sorted asArray equals: expected sorted asArray! !

!ClyInstanceSideScopeTest methodsFor: 'running' stamp: ''!
scopeClass

	^ClyInstanceSideScope! !

!ClyInstanceVariable commentStamp: ''!
I represent instance variable of class.
I am like slot but include explicit information about defining class.

You can create my instance using:
	ClyInstanceVariable named: #x definedIn: Point.
	ClyInstanceVariable on: aSlot definedIn: aClass!
!ClyInstanceVariable methodsFor: 'operations' stamp: ''!
openInspector
	definingClass isClassSide ifTrue: [ 
		^(actualVariable read: definingClass instanceSide) inspect].
	
	super openInspector.! !

!ClyInstanceVariable methodsFor: 'testing' stamp: ''!
isClassVariable
	^false! !

!ClyInstanceVariable methodsFor: 'testing' stamp: ''!
isLive

	^definingClass isClassSide! !

!ClyInstanceVariable methodsFor: 'accessing' stamp: ''!
detectDefiningClassFrom: anUserClass

	(anUserClass slots includes: actualVariable) ifTrue: [ 
		definingClass := anUserClass.
		^self].
	
	anUserClass isRootInEnvironment ifTrue: [ 
		self error: 'Cant find the class defining variable' ].
	
	self detectDefiningClassFrom: anUserClass superclass! !

!ClyInstanceVariable methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
createRefactoring: variableRefactoringClass for: aClass
	^actualVariable createRefactoring: variableRefactoringClass for: aClass! !

!ClyInstanceVariable methodsFor: 'testing' stamp: ''!
isAccessibleFrom: aClass

	^aClass = definingClass or: [ aClass inheritsFrom: definingClass ]! !

!ClyInstanceVariable class methodsFor: 'queries' stamp: ''!
queryClass
	^ClyAllInstanceVariablesQuery! !

!ClyInstanceVariable class methodsFor: 'instance creation' stamp: ''!
named: aSymbol definedIn: aClass
	^self 
		on: (aClass slotNamed: aSymbol)
		definedIn: aClass! !

!ClyInstantEnvironmentUpdateStrategy commentStamp: ''!
I am default updating strategy for navigation environment. I force query result to notify observers immediatelly when any change was happen!
!ClyInstantEnvironmentUpdateStrategy methodsFor: 'updating' stamp: ''!
publishCollectedChanges! !

!ClyInstantEnvironmentUpdateStrategy methodsFor: 'updating' stamp: ''!
announceChangesOf: aQueryResult

	aQueryResult notifyChanges! !

!ClyInteractiveRemoveClassStrategy commentStamp: ''!
I am the abstract strategy to be used in those cases where a class can't be removed.

My concrete subclasses allow the users to browse the references, subclasses, or users preventing the removal of the class.!
!ClyInteractiveRemoveClassStrategy methodsFor: 'accessing' stamp: ''!
browser

	^ browser! !

!ClyInteractiveRemoveClassStrategy methodsFor: 'accessing' stamp: ''!
browser: anObject

	browser := anObject! !

!ClyInteractiveRemoveClassStrategy class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyInteractiveRemoveClassStrategy! !

!ClyInteractiveRemoveClassStrategy class methodsFor: 'instance creation' stamp: ''!
newForBrowser: aBrowser

	^self new 
		browser: aBrowser! !

!ClyInteractiveRemoveMethodStrategy commentStamp: ''!
I am a base class for remove method strategies which request some additional information from the user.

Strategies should be created with browser which is used by subclasses for user requests: 

	ClyInteractiveRemoveMethodStrategy newForBrowser: aBrowser
 
Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<Object>!
!ClyInteractiveRemoveMethodStrategy methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyInteractiveRemoveMethodStrategy methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!ClyInteractiveRemoveMethodStrategy class methodsFor: 'instance creation' stamp: ''!
newForBrowser: aBrowser

	^self new 
		browser: aBrowser! !

!ClyInterestingSuperclassScope commentStamp: ''!
I am similar to ClySuperclasScope but I restrict superclasses chain up to Object which is not interesting command class for many browser scenarios.
So I show all superclasses, their methods and variables except Object, ProtoObject and all their related stuff.

You can restrict any class scope to be interesting scope using convertation method: 

	aClassScope asInterestingClassScope 

By default it will return class scope itself. But in case when given scope consist of superclass scope it will be replaced by my instance!
!ClyInterestingSuperclassScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'superclasses'! !

!ClyInterestingSuperclassScope class methodsFor: 'accessing' stamp: ''!
classesRelatedTo: aClass do: aBlock
	| nextSuperclass |
	aClass isRootInEnvironment ifTrue: [ ^self ].
	
	nextSuperclass := aClass superclass.
	nextSuperclass = Object ifTrue: [ ^self ].
	
	aBlock value: nextSuperclass! !

!ClyInterestingSuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverClassShouldStopAtObject
	scope := ClyInterestingSuperclassScope of: Class.
	
	scope classesDo: [ :each | result add: each ].
	
	self assert: result asSet equals: {ClassDescription. Behavior} asSet! !

!ClyInterestingSuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverMetaclassBasisWhenInstanceSideIsLocalScope

	scope := ClyInterestingSuperclassScope 
		of: ClySubclassN1OfClass1FromP1Mock class localScope: ClyInstanceSideScope.
	
	scope classesDo: [ :each | result add: each].
	
	self assert: result asSet equals: {ClyClass1FromP1Mock } asSet! !

!ClyInterestingSuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationShouldStopAtObject
	scope := ClyInterestingSuperclassScope of: ClySubclassN1OfClass1FromP1Mock.
	
	scope classesDo: [ :each | result add: each ].
	
	self assert: result asArray equals: {ClyClass1FromP1Mock}! !

!ClyInterestingSuperclassScopeTest methodsFor: 'running' stamp: ''!
scopeClass
	^ClyInterestingSuperclassScope! !

!ClyInterestingSuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverMetaclassBasisWhenClassSideIsLocalScope

	scope := ClyInterestingSuperclassScope 
		of: ClySubclassN1OfClass1FromP1Mock class localScope: ClyClassSideScope.
	
	scope classesDo: [ :each | result add: each].
	
	self assert: result asSet equals: {ClyClass1FromP1Mock class} asSet! !

!ClyInterestingSuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationWhenObjectIsFirstSuperclass
	scope := ClyInterestingSuperclassScope of: ClyClass1FromP1Mock.
	
	scope classesDo: [ :each | result add: each ].
	
	self assert: result isEmpty! !

!ClyInvalidClassForTestClassGeneration commentStamp: ''!
Description
--------------------

I am an exception raised when we want to generate a test class from an invalid class. (For example if the class is a metaclass)!
!ClyInvalidClassForTestClassGeneration methodsFor: 'printing' stamp: ''!
standardMessageText	
	^ String streamContents: [ :stream |
		stream print: self baseClass.
		stream nextPutAll: ' is not a valid class to generate a test class' ]! !

!ClyInvalidClassForTestClassGeneration methodsFor: 'accessing' stamp: ''!
baseClass
	^ baseClass! !

!ClyInvalidClassForTestClassGeneration methodsFor: 'accessing' stamp: ''!
baseClass: anObject
	baseClass := anObject! !

!ClyInvalidClassForTestClassGeneration methodsFor: 'accessing' stamp: ''!
messageText
	"Overwritten to initialiaze the message text to a standard text if it has not yet been set"
	
	^ messageText ifNil: [ messageText := self standardMessageText ]! !

!ClyInvalidClassForTestClassGeneration class methodsFor: 'signalling' stamp: ''!
signalFor: aClass
	^ self new
		baseClass: aClass;
		signal! !

!ClyInvertMethodVisibilityHierarchyCommand commentStamp: ''!
I am a command to invert hierarhcy in the method visibility class list.
(it is shown when user expands first item in the method groups pane)!
!ClyInvertMethodVisibilityHierarchyCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Invert hierarchy'! !

!ClyInvertMethodVisibilityHierarchyCommand methodsFor: 'execution' stamp: ''!
execute
	ClySubclassHierarchy invertMethodVisibilityHierarchy.
	browser switchToMethodGroups! !

!ClyInvertMethodVisibilityHierarchyCommand class methodsFor: 'activation' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClyInheritedMethodGroup asCalypsoItemContext! !

!ClyInvertVariableOrderCommand commentStamp: ''!
I am a command to invert hierarhcy of variable list in full browser.
By default variables are ordered from superclass to subclass. And I allow to toggle this order!
!ClyInvertVariableOrderCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Invert hierarchy'! !

!ClyInvertVariableOrderCommand methodsFor: 'execution' stamp: ''!
execute

	ClySubclassHierarchy invertVariableHierarchy.
	browser switchToVariables! !

!ClyInvertVariableOrderCommand class methodsFor: 'activation' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClyVariableMethodGroup asCalypsoItemContext! !

!ClyItemCellMorph commentStamp: ''!
I represent simple label based cell in QueryView table.
You can decorate this lable using special color or font styles: 
	cellMorph label emphasis: TextEmphasis italic emphasisCode.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	label:		<Morph>!
!ClyItemCellMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	label := StringMorph new.! !

!ClyItemCellMorph methodsFor: 'building' stamp: ''!
build
	self addMorphBack: label! !

!ClyItemCellMorph methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!ClyItemChildrenTag commentStamp: ''!
I am special tag to mark objects that they have particilar kind of children. Kind of children is represented by children type which is class of children objects by default.
For example you can mark class with methods:
	classItem markWithChildrenOf: ClyMethod.

To create my instance manually use:
	ClyItemChildrenTag childrenType: ClyMethod

I cache all my instances. I use class variable "Types" to ensure single property instance for each scope class.
	
You can ask browser item to check that object has particular children:
	classItem hasChildrenOf: ClyMethod

Internal Representation and Key Implementation Points.

    Instance Variables
	childrenType:		<Class>!
!ClyItemChildrenTag methodsFor: 'accessing' stamp: ''!
childrenType: aClass
	childrenType := aClass! !

!ClyItemChildrenTag methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	childrenType printOn: aStream.
	aStream nextPut: $).! !

!ClyItemChildrenTag methodsFor: 'accessing' stamp: ''!
childrenType
	^ childrenType! !

!ClyItemChildrenTag class methodsFor: 'instance creation' stamp: ''!
childrenType: itemTypeClass
	^self types at: itemTypeClass ifAbsentPut: [ 
		self new childrenType: itemTypeClass]! !

!ClyItemChildrenTag class methodsFor: 'cache' stamp: ''!
types
	^Types ifNil: [ Types := IdentityDictionary new ]! !

!ClyItemDefinitionProperty commentStamp: ''!
I am a root of hierarchy of system object definitions.
System objects are supposed to have defining package and defining class.
And idea to decorate items with these information.

When system objects are converted to browser items they add system definition property: 
	
	Array asCalypsoBrowserItem 

And you can access definition from any item: 

	Array asCalypsoBrowserItem systemDefinition.

Definitions were introduced to cover remote scenario of browser where package and class should be loaded together with methods.
Query browser shows package and class for every item. So it is important to not request them from remote side for every item.
Maybe this approach will be replaced by better idea in future.

I provide suitavle instantiation method for my subclasses: 

- package: aPackage class: aClass 

Internally I convert given package and class to browser items. So my variables include wrapper.
To access actual class or package use: 
		itemDefinition definingClass
		itemDefinition definingPackage.

Notice that my defining class is always instance side of class. And I have extra flag isInstanceSide to indicate that object is actually defined on instance side or on class side. 
It can be also avoided in future because defining class can be metaclass when object is defined on class side.
But for now it was more suitable to use definitions in this form from the UI and in case of remote scenario.
   
Internal Representation and Key Implementation Points.

    Instance Variables
	definingClassItem:		<ClyBrowserItem>
	definingPackageItem:		<ClyBrowserItem>
	isInstanceSide:		<Boolean>!
!ClyItemDefinitionProperty methodsFor: 'accessing' stamp: ''!
definingPackage
	^self definingPackageItem actualObject! !

!ClyItemDefinitionProperty methodsFor: 'printing' stamp: ''!
printDefiningClass

	^isInstanceSide 
		ifTrue: [ definingClassItem name]
		ifFalse: [ definingClassItem name, ' class']! !

!ClyItemDefinitionProperty methodsFor: 'accessing' stamp: ''!
definingMetaLevelScope
	^isInstanceSide 
		ifTrue: [ ClyInstanceSideScope ]
		ifFalse: [ ClyClassSideScope  ]! !

!ClyItemDefinitionProperty methodsFor: 'accessing' stamp: ''!
definingClass
	^self definingClassItem actualObject! !

!ClyItemDefinitionProperty methodsFor: 'accessing' stamp: ''!
definingClassItem
	^ definingClassItem! !

!ClyItemDefinitionProperty methodsFor: 'accessing' stamp: ''!
isInstanceSide: anObject
	isInstanceSide := anObject! !

!ClyItemDefinitionProperty methodsFor: 'accessing' stamp: ''!
isInstanceSide
	^ isInstanceSide! !

!ClyItemDefinitionProperty methodsFor: 'printing items' stamp: ''!
printDefinition

	self subclassResponsibility! !

!ClyItemDefinitionProperty methodsFor: 'accessing' stamp: ''!
definingClass: aClass

	definingClassItem := ClyBrowserItem named: aClass name with: aClass! !

!ClyItemDefinitionProperty methodsFor: 'accessing' stamp: ''!
definingPackage: aPackage

	definingPackageItem := ClyBrowserItem named: aPackage name with: aPackage! !

!ClyItemDefinitionProperty methodsFor: 'printing' stamp: ''!
printDefiningProtocol
	^ 'no protocol'! !

!ClyItemDefinitionProperty methodsFor: 'printing items' stamp: ''!
printFullNameOf: anEnvironmentItem

	^anEnvironmentItem name, ' (', self printDefinition, ')'! !

!ClyItemDefinitionProperty methodsFor: 'accessing' stamp: ''!
definingPackageItem
	^ definingPackageItem! !

!ClyItemDefinitionProperty class methodsFor: 'instance creation' stamp: ''!
package: aPackage class: aClass
	
	^self new 
		definingClass: aClass instanceSide;
		isInstanceSide: aClass isInstanceSide;
		definingPackage: aPackage! !

!ClyItemFilter commentStamp: ''!
I am a root of hierarchy of filters.

My subclasses must implement method #matches: to check if given object satisfies specific condition.

My instances are used by various types of queries. For example ClyFilterQuery select subset of actual query result using some of my subclasses.

So as part of query I am participate in the environment query cache. And therefore my subclasses should correctly implement comparison methods (equality and hash) when they are pluggable by any parameter!
!ClyItemFilter methodsFor: 'testing' stamp: ''!
matches: anEnvironmentItem
	self subclassResponsibility! !

!ClyItemFilter methodsFor: 'printing' stamp: ''!
printCriteria

	^self printString! !

!ClyItemFilterTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyItemFilterTest! !

!ClyItemGroup commentStamp: ''!
I am a root of hierarchy of groups for different kind of objects.
I provide name and priority for users: 	
	ClyConcreteItemGroup named: 'a group name'.
	ClyConcreteItemGroup named: 'a group name' priority 100.
Priority is used to sort groups when they are represented by sorted query result. By default bigger priority moves group to the end of result list.

When groups are represented as browser items they are able to decorate them with specific properties: 
	aGroup decorateOwnBrowserItem: aBrowserItem

And when group is shown in the browser it can decorate table cells:
	aGroup decorateTableCell: anItemCellMorph of: groupItem
By default I decorate cell with special color when it shows readonly groups.

Any group is readonly by default. To mark editable group you should implement class side method #isEditableGroup by returning true!
!ClyItemGroup methodsFor: '*Calypso-Browser' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem

	self isEditableGroup ifFalse: [ 
		anItemCellMorph label color: anItemCellMorph theme calypsoFrozenItemColor]! !

!ClyItemGroup methodsFor: 'testing' stamp: ''!
isEditableGroup
	^self class isEditableGroup! !

!ClyItemGroup methodsFor: 'accessing' stamp: ''!
priority
	^priority ifNil: [ self class priority ]! !

!ClyItemGroup methodsFor: 'accessing' stamp: ''!
name
	^name! !

!ClyItemGroup methodsFor: 'accessing' stamp: ''!
name: aString
	name := aString! !

!ClyItemGroup methodsFor: 'accessing' stamp: ''!
priority: anObject
	priority := anObject! !

!ClyItemGroup methodsFor: 'decoration' stamp: ''!
decorateOwnBrowserItem: myItem! !

!ClyItemGroup methodsFor: '*Calypso-SystemPlugins-FileOut-Queries' stamp: ''!
fileOut
	self inform: 'not supported yet'! !

!ClyItemGroup class methodsFor: 'instance creation' stamp: ''!
named: aString priority: aNumber
	^(self named: aString)
			priority: aNumber! !

!ClyItemGroup class methodsFor: 'sorting' stamp: ''!
defaultSortFunctionForCalypso
	^ClySortItemGroupFunction ascending! !

!ClyItemGroup class methodsFor: 'testing' stamp: ''!
isEditableGroup
	^false! !

!ClyItemGroup class methodsFor: 'instance creation' stamp: ''!
named: aString
	^self new 
		name: aString! !

!ClyItemGroup class methodsFor: 'accessing' stamp: ''!
priority
	^1! !

!ClyItemGroup class methodsFor: 'browser item preparation' stamp: ''!
convertToCalypsoBrowserItem: aGroup

	^ClyBrowserItem named: aGroup name with: aGroup! !

!ClyItemGroup class methodsFor: 'testing' stamp: ''!
checkCalypsoItem: aGroup isSameAs: aGroup2
	^(super checkCalypsoItem: aGroup isSameAs: aGroup2)
		or: [ aGroup = aGroup2 ]! !

!ClyItemGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	self subclassResponsibility! !

!ClyItemGroupProviderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	groupProvider := self groupProviderClass new.
	builtGroups := OrderedCollection new.! !

!ClyItemGroupProviderTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyItemGroupProviderTest! !

!ClyItemLocalHierarchyProperty commentStamp: ''!
I represent how many local children exist for object in concrete query result.

For example if you look at classes as a hierarchy then you can see Object and its subclasses. This hierarchy can be limited by package scope.
So in case of one particular package Object can have 10 subclasses. But in another package it can be 30 (for example).
And I represents such local hierarchy size. To access it from browser item use following methods:
	- aBrowserItem localHierarchySize
	- aBrowserItem localHierarchySize: count
I am used by tools to organize tree view for list of items which provide local hierarchy by themselves. Item has no real list of children. But instead it knows count of internal tree. It allows tool hide right number of items when given parent node needs to be collapsed. Important condition here is that I must hold count of full subtree of local hierarchy (not just first level children).
 
To manually create my instances use:
	ClyItemLocalHierarchyProperty size: 10

Internal Representation and Key Implementation Points.

    Instance Variables
	subtreeSize:		<Integer>!
!ClyItemLocalHierarchyProperty methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	aStream nextPutAll: 'size: '.
	subtreeSize printOn: aStream.
	aStream nextPut: $).! !

!ClyItemLocalHierarchyProperty methodsFor: 'accessing' stamp: ''!
subtreeSize: anObject
	subtreeSize := anObject! !

!ClyItemLocalHierarchyProperty methodsFor: 'accessing' stamp: ''!
subtreeSize
	^ subtreeSize! !

!ClyItemLocalHierarchyProperty class methodsFor: 'instance creation' stamp: ''!
size: subtreeSize
	^self new 
		subtreeSize: subtreeSize! !

!ClyItemNameFilter commentStamp: ''!
I filter objects by name using given string filter.

So I am compatible with objects which respond to the #name!
!ClyItemNameFilter methodsFor: 'testing' stamp: ''!
matches: anEnvironmentItem

	^pattern matches: anEnvironmentItem name! !

!ClyItemNameFilterTest methodsFor: 'tests' stamp: ''!
testFilterObjectWithName

	filter := ClyItemNameFilter substringPattern: 'ject'. "Object"
	
	self assert: (filter matches: Object).
	self deny: (filter matches: Array)! !

!ClyItemNameFilterTest methodsFor: 'tests' stamp: ''!
testComparisonWithAnotherFilter
	| anotherFilter |
	filter := ClyItemNameFilter substringPattern: 'filter'.

	anotherFilter := ClyItemNameFilter substringPattern: 'filter'.
	self assert: filter equals: anotherFilter.
	self assert: filter hash equals: anotherFilter hash.

	anotherFilter := ClyItemNameFilter substringPattern: 'filter2'.
	self deny: filter equals: anotherFilter! !

!ClyItemObserverExample methodsFor: 'controlling' stamp: ''!
itemsChanged
	wasNotified := true! !

!ClyItemObserverExample methodsFor: 'testing' stamp: ''!
wasNotified
	^wasNotified ifNil: [ false ]! !

!ClyItemStringFilter commentStamp: ''!
I am a root of hierarchy of filters which use string pattern to filter objects.
Concrete filter function is still responsibility of subclasses.

I only define correct comparison with other filters and suitable constructors:

	StringFilterClass regexPattern: aRegexString.
	StringFilterClass substringPattern: aSubString
	StringFilterClass pattern: aStringPattern
	
Internal Representation and Key Implementation Points.

    Instance Variables
	pattern:		<ClyStringPattern>!
!ClyItemStringFilter methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ pattern = anObject pattern! !

!ClyItemStringFilter methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ pattern hash! !

!ClyItemStringFilter methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream nextPut: $(.
	pattern printOn: aStream.
	aStream nextPut: $)! !

!ClyItemStringFilter methodsFor: 'accessing' stamp: ''!
pattern: anObject
	pattern := anObject! !

!ClyItemStringFilter methodsFor: 'accessing' stamp: ''!
pattern
	^ pattern! !

!ClyItemStringFilter methodsFor: 'printing' stamp: ''!
printCriteria

	^pattern value! !

!ClyItemStringFilter class methodsFor: 'instance creation' stamp: ''!
substringPattern: aString
	^self 	pattern: (ClySubstringPattern with: aString)! !

!ClyItemStringFilter class methodsFor: 'instance creation' stamp: ''!
pattern: aStringPattern
	^self new 
		pattern: aStringPattern! !

!ClyItemStringFilter class methodsFor: 'instance creation' stamp: ''!
regexPattern: regexString
	^self 	pattern: (ClyRegexPattern with: regexString)! !

!ClyJumpToTestClassCommand commentStamp: ''!
Description
--------------------

I am a command available in the class context menu of Calypso. When activated I'll jump on the test class corresponding to the class. 

If the class does not exists I will create it in the corresponding package.
	
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	testClass:		<aClass>		Test class corresponding to the class I was activated with!
!ClyJumpToTestClassCommand methodsFor: 'action' stamp: ''!
addNewCommentForTestClass: aClass basedOn: baseClass
	aClass
		comment:
			(String
				streamContents: [ :stream | 
					| name |
					name := aClass name.
					name first isVowel
						ifTrue: [ stream nextPutAll: 'An ' ]
						ifFalse: [ stream nextPutAll: 'A ' ].
					stream
						nextPutAll: name;
						nextPutAll: ' is a test class for testing the behavior of ';
						nextPutAll: baseClass name ])! !

!ClyJumpToTestClassCommand methodsFor: 'accessing' stamp: ''!
testClassFor: inputClass
	| className resultClass |
	className := self testClassNameFor: inputClass.
	self systemEnvironment
		classNamed: className
		ifPresent: [ :class | resultClass := class ]
		ifAbsent: [
			(self isValidClass: inputClass) ifFalse: [ ClyInvalidClassForTestClassGeneration signalFor: inputClass ].
			self systemEnvironment ensureExistAndRegisterPackageNamed: inputClass package name asString , '-Tests'.
			
			resultClass := self class classInstaller make: [ :aBuilder |
				aBuilder name: className;
					superclass: TestCase;
					package: (self newTestClassCategoryFor: inputClass) ].

			self addNewCommentForTestClass: resultClass basedOn: inputClass ].
	^ resultClass! !

!ClyJumpToTestClassCommand methodsFor: 'accessing' stamp: ''!
testClassNameFor: inputClass
	^ (inputClass name , 'Test') asSymbol! !

!ClyJumpToTestClassCommand methodsFor: 'action' stamp: ''!
newTestClassCategoryFor: aClass
	| tag |
	tag := aClass package classTagForClass: aClass.
	^ String
		streamContents: [ :s | 
			s
				nextPutAll: aClass package name;
				nextPutAll: '-Tests'.
			tag isRoot
				ifFalse: [ s
						nextPut: $-;
						nextPutAll: tag name ] ]! !

!ClyJumpToTestClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Jump to test class'! !

!ClyJumpToTestClassCommand methodsFor: 'execution' stamp: ''!
execute
	[ browser selectClass: (self testClassFor: targetClass) ]
		on: ClyInvalidClassForTestClassGeneration
		do: [ :ex | self inform: 'Cannot generate test class for ' , ex baseClass printString , '.' ]! !

!ClyJumpToTestClassCommand methodsFor: 'accessing' stamp: ''!
systemEnvironment
	^ systemEnvironment! !

!ClyJumpToTestClassCommand methodsFor: 'testing' stamp: ''!
isValidClass: inputClass
	^ (inputClass isTestCase or: [ inputClass isMeta ]) not! !

!ClyJumpToTestClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	browser := aToolContext browser.
	systemEnvironment := aToolContext systemEnvironment! !

!ClyJumpToTestClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#jump! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ClyJumpToTestClassCommand class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ClyJumpToTestClassCommand class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ClyJumpToTestClassCommand class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ClyJumpToTestClassCommand class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ClyJumpToTestClassCommand class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ClyJumpToTestClassCommand class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyJumpToTestClassCommand class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ClyJumpToTestClassCommand class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ClyJumpToTestClassCommand class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ClyJumpToTestClassCommand class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyJumpToTestClassCommand class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ClyJumpToTestClassCommand class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ClyJumpToTestClassCommand class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ClyJumpToTestClassCommand class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ClyJumpToTestClassCommand class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ClyJumpToTestClassCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^ CmdContextMenuActivation byRootGroupItemOrder: 5 for: ClyFullBrowserClassContext! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ClyJumpToTestClassCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ClyJumpToTestClassCommand class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ClyJumpToTestClassCommand class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ClyJumpToTestClassCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^ CmdShortcutActivation by: $g meta, $j meta for: ClyFullBrowserClassContext! !

!ClyJumpToTestMethodCommand commentStamp: ''!
Description
--------------------

I am a command available in the method context menu of Calypso. When activated I'll jump on the test method corresponding to the method. 

If the method does not exists I will create it in the corresponding class.

Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	selectedMethods:			<aCollection>	Methods selected by the user that should have their tests generated.
	testMethodToBrowse:		<aMethod>			The method to browse at the end of the execution of the command.
!
!ClyJumpToTestMethodCommand methodsFor: 'action' stamp: ''!
generateTestMethodNamed: aSymbol in: aClass
	| body |
	body := '{1}

	self flag: #toImplement.
	self assert: false' format: {aSymbol}.
	aClass compile: body classified: 'test'! !

!ClyJumpToTestMethodCommand methodsFor: 'execution' stamp: ''!
generateTestMethodFor: aMethod
	[
	| testClass selector |
	testClass := self testClassFor: aMethod methodClass.
	
	selector := self testMethodNameFor: aMethod.
	(testClass includesSelector: selector) ifFalse: [ self generateTestMethodNamed: selector in: testClass ].
	
	testMethodToBrowse := testClass >> selector ] 
		on: ClyInvalidClassForTestClassGeneration
		do: [ :ex | self inform: 'Impossible to create test class for ' , ex baseClass printString , '.' ]! !

!ClyJumpToTestMethodCommand methodsFor: 'action' stamp: ''!
addNewCommentForTestClass: aClass basedOn: baseClass
	aClass
		comment:
			(String
				streamContents: [ :stream | 
					| name |
					name := aClass name.
					name first isVowel
						ifTrue: [ stream nextPutAll: 'An ' ]
						ifFalse: [ stream nextPutAll: 'A ' ].
					stream
						nextPutAll: name;
						nextPutAll: ' is a test class for testing the behavior of ';
						nextPutAll: baseClass name ])! !

!ClyJumpToTestMethodCommand methodsFor: 'accessing' stamp: ''!
testClassFor: inputClass
	| className resultClass |
	className := self testClassNameFor: inputClass.
	self systemEnvironment
		classNamed: className
		ifPresent: [ :class | resultClass := class ]
		ifAbsent: [
			(self isValidClass: inputClass) ifFalse: [ ClyInvalidClassForTestClassGeneration signalFor: inputClass ].
			self systemEnvironment ensureExistAndRegisterPackageNamed: inputClass package name asString , '-Tests'.
			
			resultClass := self class classInstaller make: [ :aBuilder |
				aBuilder name: className;
					superclass: TestCase;
					package: (self newTestClassCategoryFor: inputClass) ].

			self addNewCommentForTestClass: resultClass basedOn: inputClass ].
	^ resultClass! !

!ClyJumpToTestMethodCommand methodsFor: 'accessing' stamp: ''!
testClassNameFor: inputClass
	^ (inputClass name , 'Test') asSymbol! !

!ClyJumpToTestMethodCommand methodsFor: 'action' stamp: ''!
newTestClassCategoryFor: aClass
	| tag |
	tag := aClass package classTagForClass: aClass.
	^ String
		streamContents: [ :s | 
			s
				nextPutAll: aClass package name;
				nextPutAll: '-Tests'.
			tag isRoot
				ifFalse: [ s
						nextPut: $-;
						nextPutAll: tag name ] ]! !

!ClyJumpToTestMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Jump to test method'! !

!ClyJumpToTestMethodCommand methodsFor: 'execution' stamp: ''!
execute
	self methods do: [ :method | self generateTestMethodFor: method ].
	
	testMethodToBrowse ifNotNil: [ :testMethod | browser selectMethod: testMethod ]! !

!ClyJumpToTestMethodCommand methodsFor: 'accessing' stamp: ''!
systemEnvironment
	^ systemEnvironment! !

!ClyJumpToTestMethodCommand methodsFor: 'accessing' stamp: ''!
testMethodNameFor: aMethod
	^ aMethod selector asTestSelector! !

!ClyJumpToTestMethodCommand methodsFor: 'testing' stamp: ''!
isValidClass: inputClass
	^ (inputClass isTestCase or: [ inputClass isMeta ]) not! !

!ClyJumpToTestMethodCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	browser := aToolContext browser.
	systemEnvironment := aToolContext systemEnvironment! !

!ClyJumpToTestMethodCommand class methodsFor: 'activation' stamp: ''!
methodShortcutActivation
	<classAnnotation>
	^ CmdShortcutActivation by: $h meta , $j meta for: ClyMethod asCalypsoItemContext! !

!ClyJumpToTestMethodCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext
	^ aBrowserContext isInstanceSideMethodSelected and: [ aBrowserContext selectedItems anySatisfy: [ :each | (each hasProperty: ClyTestResultProperty) not ] ]! !

!ClyJumpToTestMethodCommand class methodsFor: 'activation' stamp: ''!
methodMenuActivation
	<classAnnotation>
	^ CmdContextMenuActivation byItemOf: ClySUnitMethodMenuGroup order: 10 for: ClyMethod asCalypsoItemContext! !

!ClyLocalClassScope commentStamp: ''!
I am the root of the hierarchy of local class scopes.
My subclasses represent only specified classes. They do not look at any hierarchical relationship like superclasses or subclasses.

The visibility of methods and variables is defined in terms of meta levels which given scope provides: 
	aLocalClassScope metaLevelsOf: aClass do: aBlock
It is supposed to evaluate the given aBlock with either the instance side or the class side of the given aClass or with both of them.	
I delegate this method to the class side. So it can be used from classes themselves.
So subclasses should implement the #metaLevelsOf:do: method on ctheir lass side.

My subclasses define local scope of any class scope: 

	aClassScope localScopeClass
	
For example, ClyClassHierarchyScope has a variable to keep the local scope class. And different values affect the actual classes which are visible from the given hierarchy.

When my subclasses are used by hierarchy scopes, they have the extra responsibility to define a separate meta level that should be used to build hierarchies.
They should implement class side method: 

- metaLevelForHierarchyOf: aClass

Subclasses should decide what meta level of the given class should be used to retrieve/build a hierarchy.
For example, the superclass hierarchy of "ProtoObject class" can be empty from the perspective of the "instance side hierarchy":

		ProtoObject superclass >>> nil

Or it can follow the full "native" superclass chain which will end at Object and ProtoObject:

		ProtoObject class superclass >>> Class

because any metaclass inherits from Class, which itself inherits from Object.

So the method #metaLevelForHierarchyOf: delegates such decision to concrete local scopes which allows local scopes to restrict the visibility of a class hierarchy.!
!ClyLocalClassScope methodsFor: 'converting' stamp: ''!
withInheritingScope

	| fullScope |
	fullScope := self , self asInheritingScope. 
	fullScope name: self class userHierarchyScopeName.
	^fullScope! !

!ClyLocalClassScope methodsFor: 'converting' stamp: ''!
adoptLocalScopeClassTo: aLocalScopeClass
	"Local scopes can not be addopted to another local scope class.
	So we just ignore this message send. Maybe better message name can be found"! !

!ClyLocalClassScope methodsFor: 'converting' stamp: ''!
asFullHierarchyScope
	| subclassScope fullScope |
	subclassScope := self asScope: ClySubclassScope.
		
	fullScope := self withInheritedScope, subclassScope. 
	fullScope name: self class hierarchyScopeName.
	^fullScope! !

!ClyLocalClassScope methodsFor: 'converting' stamp: ''!
withInheritedScope

	| fullScope |
	fullScope := self , self asInheritedScope. 
	fullScope name: self class hierarchyScopeName.
	^fullScope! !

!ClyLocalClassScope methodsFor: 'queries' stamp: ''!
methodsDo: aBlock

	self classesDo: [ :eachClass | 
		self metaLevelsOf: eachClass do: [ :concreteMetaLevelClass |
			concreteMetaLevelClass methods do: aBlock ] ]! !

!ClyLocalClassScope methodsFor: 'meta level' stamp: ''!
metaLevelsOf: aClass do: aBlock
	"Subclasses can define what meta level is visible. 
	For example it can be instance side, class side or both.
	By default given class is its own meta level"
	
	self class metaLevelsOf: aClass do: aBlock! !

!ClyLocalClassScope methodsFor: 'queries' stamp: ''!
classesDo: aBlock
	basisObjects do: [:each | 
		self metaLevelsOf: each do: aBlock]! !

!ClyLocalClassScope methodsFor: 'meta level' stamp: ''!
localScopeClass
	^self class! !

!ClyLocalClassScope methodsFor: 'converting' stamp: ''!
asLocalClassScope
	^self! !

!ClyLocalClassScope methodsFor: 'converting' stamp: ''!
withMetaLevel: aScopeClass 
	^self asScope: aScopeClass! !

!ClyLocalClassScope class methodsFor: 'meta level' stamp: ''!
metaLevelsOf: aClass do: aBlock
	"Subclasses should decide what class meta level is visible. 
	For example it can be instance side, class side or both"
	
	self subclassResponsibility! !

!ClyLocalClassScope class methodsFor: 'meta level' stamp: ''!
metaLevelForHierarchyOf: aClass
	"Subclasses should decide what meta level of given class
	should be used to retrieve/build hierarchy.
	For example superclass hierarchy of ProtoObject class 
	can stop at it according to instance side hierarchy 
		ProtoObject superclass >>> nil
	Or it can follow full superclass chain which will ends at Object and ProtoObject
		ProtoObject class superclass >>> Class
	This method adds such decision to concrete kind of local scope
	which allows to use scopes to restrict visibility of class hierarchy"
	self subclassResponsibility! !

!ClyLocalClassScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToScopeIncludedInheritedScope
	| convertedScope inheritedScope |
	scope := self createSampleScope.
	inheritedScope := scope asInheritedScope.
	
	convertedScope := scope withInheritedScope.
	
	self assert: convertedScope class equals: ClyCompositeScope.
	self assert: convertedScope name equals: ClyClassScope hierarchyScopeName.
	self assert: (convertedScope subscopes includes: scope).
	self assert: (convertedScope subscopes includes: inheritedScope)! !

!ClyLocalClassScopeTest methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests' stamp: ''!
testConvertingToInheritingScopeShouldAddTraitUsers
	| convertedScope |
	scope := self createSampleScope.
	
	convertedScope := scope asInheritingScope.
	
	self assert: (convertedScope representsScope: ClyTraitUserScope)! !

!ClyLocalClassScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToInheritedScope
	| convertedScope |
	scope := self createSampleScope.
	
	convertedScope := scope asInheritedScope.
	
	self assert: (convertedScope representsScope: ClySuperclassScope).
	self assert: convertedScope localScopeClass equals: self scopeClass.
	self assert: convertedScope basisObjects equals: scope basisObjects.
	self assert: convertedScope environment equals: environment.
	self assert: convertedScope name equals: ClyClassScope inheritedScopeName! !

!ClyLocalClassScopeTest methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests' stamp: ''!
testConvertingToInheritedScopeShouldAddInheritedTraits
	| convertedScope |
	scope := self createSampleScope.
	
	convertedScope := scope asInheritedScope.
	
	self assert: (convertedScope representsScope: ClyInheritedTraitScope)! !

!ClyLocalClassScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToScopeIncludedInheritingScope
	| convertedScope inheritingScope |
	scope := self createSampleScope.
	inheritingScope := scope asInheritingScope.
	
	convertedScope := scope withInheritingScope.
	
	self assert: convertedScope class equals: ClyCompositeScope.
	self assert: convertedScope name equals: ClyClassScope userHierarchyScopeName.
	self assert: (convertedScope subscopes includes: scope).
	self assert: (convertedScope subscopes includes: inheritingScope)! !

!ClyLocalClassScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToNewMetaLevel
	| convertedScope |
	scope := self createSampleScope.
	
	convertedScope := scope withMetaLevel: ClyInstanceSideScope.
	
	self assert: convertedScope class equals: ClyInstanceSideScope.
	self assert: convertedScope basisObjects equals: scope basisObjects.
	self assert: convertedScope environment equals: environment! !

!ClyLocalClassScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToFullHierarchyScope
	| convertedScope inheritedScope |
	scope := self createSampleScope.
	inheritedScope := scope asInheritedScope.
	
	convertedScope := scope asFullHierarchyScope.
	
	self assert: convertedScope class equals: ClyCompositeScope.
	self assert: convertedScope name equals: ClyClassScope hierarchyScopeName.
	self assert: (convertedScope subscopes includes: scope).
	self assert: (convertedScope subscopes includes: inheritedScope).
	self assert: (convertedScope subscopes includes: (
		ClySubclassScope ofAll: scope basisObjects localScope: scope class))! !

!ClyLocalClassScopeTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyLocalClassScopeTest! !

!ClyLongExampleQuery methodsFor: 'controlling' stamp: ''!
delayExecution
	executionSemaphore consumeAllSignals! !

!ClyLongExampleQuery methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	executionSemaphore := Semaphore new! !

!ClyLongExampleQuery methodsFor: 'controlling' stamp: ''!
passExecution
	executionSemaphore signal! !

!ClyLongExampleQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	executionSemaphore wait.
	
	super buildResult: aQueryResult! !

!ClyLongExampleQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	executionSemaphore wait.
	super checkEmptyResult! !

!ClyLongExampleQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	self shouldBeImplemented! !

!ClyMainItemCellMorph commentStamp: ''!
I represent main cell in table row. 
I responsible to show expansion icon, current depth indentation when tree structure is specified.
I allow to decorate me with
- definition morph which will be placed before label
	cellMorph definitionMorph: aMorph
	cellMorph definitionIcon: iconName
- extraToolMorphs which will be placed after label
	cellMorph addExtraTool: aMorph
	cellMorph addExtraIcon: iconName
- any kind of properties for my label
	cellMorph label emphasis: TextEmphasis italic emphasisCode.

I implement layout logic in method #build.

My instances are created using:
	ClyMainItemCellMorph on: aDataSourceItem

I provide two identation strategies which you can switch using fullIndentation variable.
In full identation mode children items are shifted together with collapsing button.
Otherwise collapsion button is always in same place but label and icons are shifted.

Internal Representation and Key Implementation Points.

    Instance Variables
	definitionMorph:		<Morph>
	extraToolMorphs:		<OrderedCollection of<Morph>>
	item:		<ClyDataSourceItem>
	itemDepth:		<Integer>
	fullIndentation: <Boolean>!
!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
definitionMorph: aMorph
	
	definitionMorph := aMorph.
	definitionMorph width: 16.
	^definitionMorph! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
browserItem
	^item browserItem! !

!ClyMainItemCellMorph methodsFor: 'building' stamp: ''!
buildWithFullIndentation

	| expansionButton |
	self addBarForFullIndentation.
	item supportsExpansion ifTrue: [ 
		expansionButton := self currentExpansionButton.
		self addMorphBack: expansionButton].
	definitionMorph ifNotNil: [
		definitionMorph width: 16.
		 self addMorphBack: definitionMorph].
	
	
	self addMorphBack: label.
	extraToolMorphs ifNotNil: [ extraToolMorphs do: [:each |
			each width: 16.
			 self addMorphBack: each  ] ]! !

!ClyMainItemCellMorph methodsFor: 'buttons' stamp: ''!
currentExpansionButton

	item hasChildren ifFalse: [^FTTreeDataSource emptyMorph].
	
	^item isExpanded 
		ifTrue: [ self expandedButton ]
		ifFalse: [self collapsedButton]! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
actualObject
	^item actualObject! !

!ClyMainItemCellMorph methodsFor: 'building' stamp: ''!
buildWithLabelIndentation

	| expansionButton |
	item supportsExpansion ifTrue: [ 
		expansionButton := self currentExpansionButton.
		self addMorphBack: expansionButton].
	definitionMorph ifNotNil: [
		definitionMorph width: 16.
		 self addMorphBack: definitionMorph].
	
	self addBarForLabelIndentation.
	self addMorphBack: label.
	extraToolMorphs ifNotNil: [ extraToolMorphs do: [:each |
			each width: 16.
			 self addMorphBack: each  ] ]! !

!ClyMainItemCellMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	fullIndentation := false.
	self cellInset: 2@0! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
itemDepth
	^itemDepth ifNil: [item depth]! !

!ClyMainItemCellMorph methodsFor: 'buttons' stamp: ''!
collapsedButton
	^ IconicButtonMorph new
		target: item;
		actionSelector: #expand;
		arguments: {};
		labelGraphic: self theme treeUnexpandedForm;
		color: Color transparent;
		helpText: 'Expand Item';
		borderWidth: 0! !

!ClyMainItemCellMorph methodsFor: 'buttons' stamp: ''!
expandedButton
	^ IconicButtonMorph new
		target: item;
		actionSelector: #collapse;
		arguments: {};
		labelGraphic: self theme treeExpandedForm;
		color: Color transparent;
		helpText: 'Unexpand Item';
		borderWidth: 0! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
overrideItemDepthByDelta: delta 
	^itemDepth := item depth + delta! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
addExtraTool: aMorph
	
	extraToolMorphs ifNil: [ extraToolMorphs := OrderedCollection new].
	extraToolMorphs add: aMorph.
	^aMorph! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
useFullIndentation
	fullIndentation := true! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
definitionIcon: iconName
	
	| icon |
	icon := self iconNamed: iconName.
	^self definitionMorph: icon asMorph! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
browser
	^item browser! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
addExtraIcon: iconName
	
	| icon |
	icon := self iconNamed: iconName.
	^self addExtraTool: icon asMorph! !

!ClyMainItemCellMorph methodsFor: 'building' stamp: ''!
build

	fullIndentation 
		ifTrue: [ self buildWithFullIndentation ]
		ifFalse: [ self buildWithLabelIndentation  ].! !

!ClyMainItemCellMorph methodsFor: 'building' stamp: ''!
addBarForLabelIndentation

	| placeForExpansionRequired mainItemsCount absentItemsCount requiredWidth |
	placeForExpansionRequired := item rootDataSource definesChildren.
	mainItemsCount := placeForExpansionRequired ifTrue: [ 2 ] ifFalse: [ 1 ].
	absentItemsCount := mainItemsCount - submorphs size.

	requiredWidth := absentItemsCount * 16 + (self itemDepth * 8).
	requiredWidth = 0 ifTrue: [ ^self ].
	
	self addMorphBack: (self emptyBarWithWidth: requiredWidth)! !

!ClyMainItemCellMorph methodsFor: 'building' stamp: ''!
emptyBarWithWidth: aNumber
	| bar |
	bar := Morph new.
	bar 
		setNamePropertyTo: 'emptyBar';
		color: Color transparent;
		changeTableLayout;		
		vResizing: #spaceFill;
		hResizing: #rigid;
		minWidth: 0;
		width: aNumber.
	^bar! !

!ClyMainItemCellMorph methodsFor: 'building' stamp: ''!
addBarForFullIndentation

	| mainItemsCount absentItemsCount requiredWidth |
	mainItemsCount := 0.
	absentItemsCount := mainItemsCount - submorphs size.

	requiredWidth := absentItemsCount * 16 + (self itemDepth * 8).
	requiredWidth = 0 ifTrue: [ ^self ].
	
	self addMorphBack: (self emptyBarWithWidth: requiredWidth)! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
item
	^ item! !

!ClyMainItemCellMorph methodsFor: 'accessing' stamp: ''!
item: aDataSourceItem
	item := aDataSourceItem! !

!ClyMainItemCellMorph class methodsFor: 'instance creation' stamp: ''!
on: aDataSourceItem
	^self new 
		item: aDataSourceItem! !

!ClyMainTableColumn commentStamp: ''!
I am special main table column which represent cells by ClyMainItemCellMorph.
My cells are responsible to show expansion icon and any other decoration tools: definition morph, extra tool morps.
I ask given queryView to decorate cell which will pass cell morph through all related table decorators.!
!ClyMainTableColumn methodsFor: 'testing' stamp: ''!
isMainColumn 

	^ true! !

!ClyMainTableColumn methodsFor: 'cells creation' stamp: ''!
createCellFor: aDataSourceItem in: aQueryView

	| cell |
	cell := ClyMainItemCellMorph on: aDataSourceItem.
	displayBlock value: cell value: aDataSourceItem.
	aQueryView decorateMainTableCell: cell of: aDataSourceItem.
	cell build.
	^cell! !

!ClyMainTableColumn class methodsFor: 'instance creation' stamp: ''!
default
	^(self id: #item)
		displayItemName! !

!ClyManagedProject commentStamp: ''!
I represent the project which is managed by concrete package system.
Calypso provides infrastructure for various package management systems. 
Each system should implement subclass of ClyPackageManager which returns my instances created over projects in that system:

	ClyManagerProject for: aConcreteSystemProject named: aString managedBy: aPackageManager

Currently there is only Cargo implementation. But in future we can also provide Metacello support.

So I was introduced for project mode in the browser.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	manager:		<ClyPackageManager>
	name:		<String>
	project:		<Object>!
!ClyManagedProject class methodsFor: 'queries' stamp: ''!
prepareClassQueriesFrom: projects in: aNavigationEnvironment 
	^{ClyAllClassesQuery from: ClyProjectScope ofAll: projects in: aNavigationEnvironment }! !

!ClyManagedProject class methodsFor: 'instance creation' stamp: ''!
for: aProject named: aString managedBy: aPackageManager
	^self new 
		name: aString;
		manager: aPackageManager;
		project: aProject! !

!ClyManagedProject class methodsFor: 'testing' stamp: ''!
checkCalypsoItem: aProject isSameAs: aProject2
	^(super checkCalypsoItem: aProject isSameAs: aProject2)
		or: [ aProject = aProject2 ]! !

!ClyMergedHierarchy commentStamp: ''!
I am a special kind of hierarchy which merges multiple different hierarchies.
Each of my #mergedParts adds own relationship to the building hiearchy map: 

	ClyMergedHierarchy>>buildParentMap: aHierarchyMap for: aClass
		mergedParts do: [ :each | 
			aHierarchyMap hierarchy: each.
			each buildParentMap: aHierarchyMap for: aClass ].
		aHierarchyMap hierarchy: self.

To create my instances use following methods:
	
	ClyMergedHierarchy merge: {ClySuperclassHierarchy new. ClyTraitUserHierarchy new}.

Or simply use comma to concatenate hierarchies	:
	
	ClySubclassHierarchy new, ClyTraitUserHierarchy new.

In this example the parent of each class can be either superclass or inherited trait.
Such hierarchy can include duplicated nodes.

To provide consisten merging I override sort function of all my parts to ensure that all of them are sorted in same way.

Internal Representation and Key Implementation Points.

    Instance Variables
	mergedParts:		<Collection of<ClyClassHierarchy>>!
!ClyMergedHierarchy methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ mergedParts = anObject mergedParts! !

!ClyMergedHierarchy methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	mergedParts := #()! !

!ClyMergedHierarchy methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash bitXor: mergedParts hash! !

!ClyMergedHierarchy methodsFor: 'accessing' stamp: ''!
sortFunction: aSortFunction
	super sortFunction: aSortFunction.
	mergedParts do: [:each | each sortFunction: aSortFunction]! !

!ClyMergedHierarchy methodsFor: 'building' stamp: ''!
buildParentMap: aHierarchyMap for: aClass

	mergedParts do: [ :each | 
		aHierarchyMap hierarchy: each.
		each buildParentMap: aHierarchyMap for: aClass ].
	
	aHierarchyMap hierarchy: self.! !

!ClyMergedHierarchy methodsFor: 'accessing' stamp: ''!
mergedParts: anObject
	mergedParts := anObject! !

!ClyMergedHierarchy methodsFor: 'accessing' stamp: ''!
mergedParts
	^ mergedParts! !

!ClyMergedHierarchy class methodsFor: 'instance creation' stamp: ''!
merge: hierarchies
	^self new 
		mergedParts: hierarchies! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithOnlyClassWhichHasTraits
	
	queryResult fillWith: {ClyClassWithTraits}.
		
	self assertItems: {ClyClassWithTraits. 0}! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithTwoClassWhichInheriteSameTraits
	
	queryResult fillWith: {ClyClassWithTraits. ClyTraitChild2. ClyTraitRoot2.
		ClySubclassWithTraitsOfClassWithTraits "inherits Root2 in deep chain"}.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild2. 1. ClyTraitRoot2. 2. 
			ClyTraitRoot2. 1.
			ClySubclassWithTraitsOfClassWithTraits. 1. 
				ClyTraitRoot2. 2}! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItsDeepTwoTraits
	
	queryResult fillWith: {ClyClassWithTraits. ClyTraitChild2. ClyTraitRoot2 }.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild2. 1. ClyTraitRoot2. 2. 
			ClyTraitRoot2. 1}! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassWithoutTraits
	
	queryResult fillWith: {ClyClassWithoutTraits}.
		
	self assertItems: {ClyClassWithoutTraits. 0}! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassesFromOneHierarchy

	queryResult fillWith: { ClySubclassN1OfClass1FromP1Mock. ClySubclassLOfSubclassMFromP3Mock. ClyClass1FromP1Mock. ClySubclassN2OfClass1FromP1Mock }.

	self assertItems: {
		ClyClass1FromP1Mock. 0. ClySubclassLOfSubclassMFromP3Mock. 1. 
		ClySubclassN1OfClass1FromP1Mock. 1. ClySubclassN2OfClass1FromP1Mock. 1 }! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItsTraitsWhenSomeMiddleTraitIsMissing
	
	queryResult fillWith: {
		ClyClassWithTraits. ClyTraitChild1. ClyTraitRoot1. ClyTraitChild2Child }.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild1. 1. ClyTraitRoot1. 2. 
			ClyTraitChild2Child. 1. ClyTraitRoot1. 2}.! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithTraitsOfClassWhichIsMissingInGivenList
	
	queryResult fillWith: {
		ClyTraitChild1. ClyTraitChild2. ClyTraitRoot1. ClyTraitChild2Child }.
		
	self assertItems: {
		ClyTraitChild1. 0. ClyTraitRoot1. 1. 
		ClyTraitChild2Child. 0. ClyTraitChild2. 1. ClyTraitRoot1. 2}.! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithObjectAndTwoProtoObjects

	queryResult fillWith: { Object. ProtoObject. ProtoObject }.
	
	self assertItems: {ProtoObject. 0. Object. 1}! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'running' stamp: ''!
createQueryResult
	^(ClySubclassHierarchy new, ClyTraitUserHierarchy inverse) 
		asQueryResult sortedBy: ClyTraitFirstSortFunction ascending! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItsTraits
	
	queryResult fillWith: {
		ClyClassWithTraits. ClyTraitChild1. ClyTraitChild2. ClyTraitRoot1. ClyTraitChild2Child }.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild1. 1. ClyTraitRoot1. 2. 
			ClyTraitChild2Child. 1. ClyTraitChild2. 2. ClyTraitRoot1. 3}.! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItGrandSuperclass
	
	queryResult fillWith: { ClyClass1FromP1Mock. ClySubclassLOfSubclassMFromP3Mock }.
	
	self assertItems: {ClyClass1FromP1Mock. 0. ClySubclassLOfSubclassMFromP3Mock. 1}! !

!ClyMergedSubclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithTwoSameClasses

	queryResult fillWith: { ClyClass1FromP1Mock. ClyClass1FromP1Mock }.

	self assertItems: { ClyClass1FromP1Mock. 0 }! !

!ClyMergedSuperclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithOnlyClassWhichHasTraits
	
	queryResult fillWith: {ClyClassWithTraits}.
		
	self assertItems: {ClyClassWithTraits. 0}! !

!ClyMergedSuperclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithTwoClassWhichInheriteSameTraits
	
	queryResult fillWith: {ClyClassWithTraits. ClyTraitChild2. ClyTraitRoot2.
		ClySubclassWithTraitsOfClassWithTraits "inherits Root2 in deep chain"}.
		
	self assertItems: {
		ClySubclassWithTraitsOfClassWithTraits. 0.
			ClyTraitRoot2. 1.
			ClyClassWithTraits. 1.
				ClyTraitChild2. 2. ClyTraitRoot2. 3. 
				ClyTraitRoot2. 2}! !

!ClyMergedSuperclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItsDeepTwoTraits
	
	queryResult fillWith: {ClyClassWithTraits. ClyTraitChild2. ClyTraitRoot2 }.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild2. 1. ClyTraitRoot2. 2. 
			ClyTraitRoot2. 1}! !

!ClyMergedSuperclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassWithoutTraits
	
	queryResult fillWith: {ClyClassWithoutTraits}.
		
	self assertItems: {ClyClassWithoutTraits. 0}! !

!ClyMergedSuperclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithTraitsOfClassWhichIsMissingInGivenList
	
	queryResult fillWith: {
		ClyTraitChild1. ClyTraitChild2. ClyTraitRoot1. ClyTraitChild2Child }.
		
	self assertItems: {
		ClyTraitChild1. 0. ClyTraitRoot1. 1. 
		ClyTraitChild2Child. 0. ClyTraitChild2. 1. ClyTraitRoot1. 2}.! !

!ClyMergedSuperclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItsTraitsWhenSomeMiddleTraitIsMissing
	
	queryResult fillWith: {
		ClyClassWithTraits. ClyTraitChild1. ClyTraitRoot1. ClyTraitChild2Child }.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild1. 1. ClyTraitRoot1. 2. 
			ClyTraitChild2Child. 1. ClyTraitRoot1. 2}.! !

!ClyMergedSuperclassesAndInheritedTraitsHierarchyTest methodsFor: 'running' stamp: ''!
createQueryResult
	^(ClySubclassHierarchy inverse, ClyTraitUserHierarchy inverse) 
		asQueryResult sortedBy: ClyTraitFirstSortFunction ascending! !

!ClyMergedSuperclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassAndItsTraits
	
	queryResult fillWith: {
		ClyClassWithTraits. ClyTraitChild1. ClyTraitChild2. ClyTraitRoot1. ClyTraitChild2Child }.
		
	self assertItems: {
		ClyClassWithTraits. 0.
			ClyTraitChild1. 1. ClyTraitRoot1. 2. 
			ClyTraitChild2Child. 1. ClyTraitChild2. 2. ClyTraitRoot1. 3}.! !

!ClyMergedSuperclassesAndInheritedTraitsHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithTwoClassWhichInheriteSameTraitsAndTheirSuperclasses
	
	queryResult fillWith: {ClyClassWithTraits. ClyTraitChild2. ClyTraitRoot2.
		ClySubclassWithTraitsOfClassWithTraits. Object. ProtoObject}.
		
	self assertItems: {
		ClySubclassWithTraitsOfClassWithTraits. 0.
			ClyTraitRoot2. 1.
			ClyClassWithTraits. 1.
				ClyTraitChild2. 2. ClyTraitRoot2. 3. 
				ClyTraitRoot2. 2.
				Object. 2. ProtoObject. 3}! !

!ClyMessageBasedQuery commentStamp: ''!
I am a root of hierarchy of method queries which uses set of selectors to filter methods.

My instances can be created using following methods:

	ClyMessageSenders of: #selector.
	ClyMessageImplementors of: #selector from: aScope.
	ClyMessageSenders ofAny: #(selector1 selector2).
	ClyMessageImplementors ofAny: #(selector1 selector2) from: aScope.

I provide suitable printing methods and correct comparison implementation.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	selectors:		<Array of<Symbol>>!
!ClyMessageBasedQuery methodsFor: 'printing' stamp: ''!
printSelectors

	^',' join: selectors! !

!ClyMessageBasedQuery methodsFor: 'accessing' stamp: ''!
selectors: anObject
	selectors := anObject! !

!ClyMessageBasedQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^selectors = anObject selectors! !

!ClyMessageBasedQuery methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateResultMethodEditor: aMethodEditor

	aMethodEditor selectAnySelector: selectors! !

!ClyMessageBasedQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash bitXor: selectors hash! !

!ClyMessageBasedQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream
	super printExtraInfoOn: aStream.

	aStream nextPutAll: self printSelectors! !

!ClyMessageBasedQuery methodsFor: 'accessing' stamp: ''!
selectors
	^ selectors! !

!ClyMessageBasedQuery class methodsFor: 'instance creation' stamp: ''!
of: aSelector from: aScope
	^self ofAny: {aSelector} from: aScope! !

!ClyMessageBasedQuery class methodsFor: 'instance creation' stamp: ''!
ofAny: selectors
	^self new 
		selectors: selectors! !

!ClyMessageBasedQuery class methodsFor: 'instance creation' stamp: ''!
of: aSelector
	^self ofAny: { aSelector }! !

!ClyMessageBasedQuery class methodsFor: 'instance creation' stamp: ''!
ofAny: selectors from: aScope
	^aScope adoptQuery: (self ofAny: selectors)! !

!ClyMessageImplementorsQuery commentStamp: ''!
I return all implementors of given selectors!
!ClyMessageImplementorsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod

	"is implementor if it is implemented in the same class 
	 that is defined (to exclude trait users)"
	^ (selectors includes: aMethod selector)
		and: [  aMethod origin = aMethod methodClass ]! !

!ClyMessageImplementorsQuery methodsFor: 'printing' stamp: ''!
description

	^'implementors of ', self printSelectors! !

!ClyMessageImplementorsQueryTest methodsFor: 'methods for tests' stamp: ''!
messageImplementor2! !

!ClyMessageImplementorsQueryTest methodsFor: 'tests' stamp: ''!
testFromClassScope
	
	self queryFromScope: ClyBothMetaLevelClassScope of: self class.
	
	self assert: resultItems size equals: 2.	
	self assert: (resultItems identityIncludes: (self class >> self targetSelector)).
	self assert: (resultItems identityIncludes: (self class classSide >> self targetSelector)).! !

!ClyMessageImplementorsQueryTest methodsFor: 'tests' stamp: ''!
testComparison
	self assert: (ClyMessageImplementorsQuery of: #message1) equals: (ClyMessageImplementorsQuery of: #message1).

	self assert: (ClyMessageImplementorsQuery of: #message1) hash equals: (ClyMessageImplementorsQuery of: #message1) hash.

	self deny: (ClyMessageImplementorsQuery of: #message1) equals: (ClyMessageImplementorsQuery of: #message2)! !

!ClyMessageImplementorsQueryTest methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests' stamp: ''!
testFromClassAndInheritedTrait
	query := ClyMessageImplementorsQuery of: #methodFromRoot1.
	self queryFromScope: ClyBothMetaLevelClassScope ofAll: {ClyClassWithTraits . ClyTraitRoot1}.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: ClyTraitRoot1 >> #methodFromRoot1! !

!ClyMessageImplementorsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope of: (self class >> self targetSelector) in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope of: (self class >> #messageImplementor2) in: environment).
	self assert: query checkEmptyResult! !

!ClyMessageImplementorsQueryTest methodsFor: 'tests' stamp: ''!
testFromMethodScope
	self queryFromScope: ClyMethodScope ofAll: {(self class >> self targetSelector) . (self class >> #messageImplementor2)}.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: self class >> self targetSelector! !

!ClyMessageImplementorsQueryTest methodsFor: 'tests' stamp: ''!
testFromSystemScope

	self queryFromScope: ClySystemEnvironmentScope of: ClySystemEnvironment currentImage.
	
	self assert: resultItems size equals: 3.	
	self assert: (resultItems identityIncludes: self class >> self targetSelector).
	self assert: (resultItems identityIncludes: self class classSide >> self targetSelector).
	self assert: (resultItems identityIncludes: self class superclass >> self targetSelector).! !

!ClyMessageImplementorsQueryTest methodsFor: 'methods for tests' stamp: ''!
clyMessageImplementor1! !

!ClyMessageImplementorsQueryTest methodsFor: 'tests' stamp: ''!
testFromPackageScope
	
	self queryFromScope: ClyPackageScope of: self class package.
	
	self assert: resultItems size equals: 3.	
	self assert: (resultItems identityIncludes: self class >> self targetSelector).
	self assert: (resultItems identityIncludes: self class classSide >> self targetSelector).
	self assert: (resultItems identityIncludes: self class superclass >> self targetSelector).! !

!ClyMessageImplementorsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyMessageImplementorsQuery
		of: self targetSelector
		from: (ClyClassScope of: Object in: environment)! !

!ClyMessageImplementorsQueryTest methodsFor: 'running' stamp: ''!
targetSelector
	^#clyMessageImplementor1! !

!ClyMessageImplementorsQueryTest class methodsFor: 'methods for tests' stamp: ''!
clyMessageImplementor1! !

!ClyMessageSendersQuery commentStamp: ''!
I return all senders of any of given selectors!
!ClyMessageSendersQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	
	selectors with: self specialSelectorIndexes do: [ :selector :specialIndex |
		(aMethod hasSelector: selector specialSelectorIndex: specialIndex) 
			ifTrue: [	^true] ].
			
	^false! !

!ClyMessageSendersQuery methodsFor: 'printing' stamp: ''!
description

	^'senders of ', self printSelectors! !

!ClyMessageSendersQuery methodsFor: 'execution' stamp: ''!
prepareStateBeforeExecution
	super prepareStateBeforeExecution.
	
	"Special selector indexes are required for lookup in method.
	Here it is collected in advance to be used during execution
	because after execution query become readonly object"
	self specialSelectorIndexes! !

!ClyMessageSendersQuery methodsFor: 'accessing' stamp: ''!
specialSelectorIndexes
	^specialSelectorIndexes ifNil: [ 
		specialSelectorIndexes := selectors collect: [:each | Smalltalk specialSelectorIndexOrNil: each]]! !

!ClyMessageSendersQueryTest methodsFor: 'methods for tests' stamp: ''!
sender2OfMessage1
	self clyReferencedMessage1! !

!ClyMessageSendersQueryTest methodsFor: 'tests' stamp: ''!
testComparison
	self assert: (ClyMessageSendersQuery of: #message1) equals: (ClyMessageSendersQuery of: #message1).

	self assert: (ClyMessageSendersQuery of: #message1) hash equals: (ClyMessageSendersQuery of: #message1) hash.

	self deny: (ClyMessageSendersQuery of: #message1) equals: (ClyMessageSendersQuery of: #message2)! !

!ClyMessageSendersQueryTest methodsFor: 'methods for tests' stamp: ''!
senderOfMessage2
	self message2! !

!ClyMessageSendersQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope:	(ClyMethodScope of: (self class >> #sender1OfMessage1) in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope of: (self class >> #senderOfMessage2) in: environment).
	self assert: query checkEmptyResult! !

!ClyMessageSendersQueryTest methodsFor: 'tests' stamp: ''!
testFromMethodScope
	self queryFromScope: ClyMethodScope ofAll: {(self class >> #sender1OfMessage1) . (self class >> #senderOfMessage2)}.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: self class >> #sender1OfMessage1! !

!ClyMessageSendersQueryTest methodsFor: 'running' stamp: ''!
referencedSelector
	"String is used here to not make this method sender of it"
	^'clyReferencedMessage1' asSymbol! !

!ClyMessageSendersQueryTest methodsFor: 'tests' stamp: ''!
testFromSystemScope
	
	self queryFromScope: ClySystemEnvironmentScope of: ClySystemEnvironment currentImage.	
	
	self assert: foundSelectors equals: #(classSideSender1OfMessage1 classSideSender2OfMessage1 
		sender1OfMessage1 sender2OfMessage1 
		superclassSenderOfMessage1)! !

!ClyMessageSendersQueryTest methodsFor: 'tests' stamp: ''!
testDetectingSpecialSelectorLikeIfTrue
	query := ClyMessageSendersQuery of: #ifTrue:.

	self queryFromScope: ClyMethodScope of: self class >> #senderOfIfTrue.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: self class >> #senderOfIfTrue! !

!ClyMessageSendersQueryTest methodsFor: 'tests' stamp: ''!
testFromPackageScope
	
	self queryFromScope: ClyPackageScope of: self class package.	
		
	self assert: foundSelectors equals: #(classSideSender1OfMessage1 classSideSender2OfMessage1 
		sender1OfMessage1 sender2OfMessage1 
		superclassSenderOfMessage1)! !

!ClyMessageSendersQueryTest methodsFor: 'methods for tests' stamp: ''!
senderOfIfTrue
	^2*2 = 4 ifTrue: [100]! !

!ClyMessageSendersQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyMessageSendersQuery
		of: self referencedSelector
		from: (ClyClassScope of: Object in: environment)! !

!ClyMessageSendersQueryTest methodsFor: 'methods for tests' stamp: ''!
sender1OfMessage1
	self clyReferencedMessage1! !

!ClyMessageSendersQueryTest methodsFor: 'tests' stamp: ''!
testFromLocalClassScope

	self queryFromScope: ClyBothMetaLevelClassScope of: self class.
	
	self assert: foundSelectors equals: #(classSideSender1OfMessage1 classSideSender2OfMessage1 
		sender1OfMessage1 sender2OfMessage1)! !

!ClyMessageSendersQueryTest class methodsFor: 'methods for tests' stamp: ''!
classSideSender2OfMessage1
	self clyReferencedMessage1! !

!ClyMessageSendersQueryTest class methodsFor: 'methods for tests' stamp: ''!
classSideSender1OfMessage1
	self clyReferencedMessage1! !

!ClyMetaLevelClassScope commentStamp: ''!
I am abstract scope which represents concrete meta level of class. There are instance side and class side scopes. 
Look at subclasses. They should implement class side method #resolveClass:  which returns instanceSide of classSide of given class!
!ClyMetaLevelClassScope methodsFor: 'meta level' stamp: ''!
metaLevelOf: aClass
	^self class metaLevelOf: aClass! !

!ClyMetaLevelClassScope class methodsFor: 'meta level' stamp: ''!
metaLevelOf: aClass
	"Subclasses should decide what meta level of given class they see.
	Look at subclasses"
	self subclassResponsibility! !

!ClyMetaLevelClassScope class methodsFor: 'meta level' stamp: ''!
metaLevelsOf: aClass do: aBlock
	aBlock value: (self metaLevelOf: aClass)! !

!ClyMetaLevelClassScope class methodsFor: 'meta level' stamp: ''!
metaLevelForHierarchyOf: aClass
	"My subclasses should restrict any hierarchy by instance side relationship.
	For example using class side scope you can analyze hierarchy of ProtoObject. 
	It will gives you only ProtoObject class despite of
	ProtoObject class superclass is not nil"
	^aClass instanceSide! !

!ClyMetaLevelToolbarGroup commentStamp: ''!
I am a toolbar menu group to show meta level modes of the browser together!
!ClyMetaLevelToolbarGroup methodsFor: 'accessing' stamp: ''!
order
	^3! !

!ClyMetaLinkInstallationPresenter commentStamp: ''!
I present a list of available metalink for a given ast node to be installed or uninstalled.
The presenter can be in install mode or uninstall mode, see class methods.
The list of links for a node is either all the instances of metalinks from the system when in install mode or all node currently installed on that node.!
!ClyMetaLinkInstallationPresenter methodsFor: 'accessing' stamp: ''!
sourceNode: anObject
	sourceNode := anObject! !

!ClyMetaLinkInstallationPresenter methodsFor: 'accessing' stamp: ''!
metalinkListPresenter
	^ metalinkListPresenter! !

!ClyMetaLinkInstallationPresenter methodsFor: 'accessing' stamp: ''!
allRelevantMetaLinks
	| baseLinks |
	baseLinks := self isForMetaLinkInstallation
		             ifTrue: [ "This is temporary, I should have put a comment.
The idea would be to add an explicit option at the metalink level, so that only the ones that are ''installable through the menu'' would appear.
But we need to think about how to do that exactly." 
			             MetaLink allInstances ]
		             ifFalse: [ sourceNode links ].
	^ baseLinks reject: [ :link | 
		  link metaObject == Break or: [ 
			  { 
				  Watch.
				  ExecutionCounter } includes: link metaObject class ] ]! !

!ClyMetaLinkInstallationPresenter methodsFor: 'installation' stamp: ''!
uninstallSelectedMetalink
	metalinkListPresenter selection selectedItem ifNotNil: [ :metalink | 
		sourceNode removeLink: metalink ].
	self close! !

!ClyMetaLinkInstallationPresenter methodsFor: 'installation' stamp: ''!
installSelectedMetalink
	metalinkListPresenter selection selectedItem ifNotNil: [ :metalink | 
		sourceNode link: metalink ].
	self close! !

!ClyMetaLinkInstallationPresenter methodsFor: 'accessing' stamp: ''!
toolbarButtons
	| buttons |
	buttons := OrderedCollection new.
	buttons add: (self isForMetaLinkInstallation
			 ifTrue: [ 
				 self newToolbarButton
					 label: 'Install';
					 icon: (self iconNamed: #smallOk);
					 help: 'Install the selected metalink';
					 action: [ self installSelectedMetalink ];
					 yourself ]
			 ifFalse: [ 
				 self newToolbarButton
					 label: 'Uninstall';
					 icon: (self iconNamed: #smallOk);
					 help: 'Uninstall the selected metalink';
					 action: [ self uninstallSelectedMetalink ];
					 yourself ]).
	buttons add: (self newToolbarButton
			 label: 'Cancel';
			 icon: (self iconNamed: #smallCancel);
			 help: 'Cancel';
			 action: [ self close ];
			 yourself).

	^ buttons! !

!ClyMetaLinkInstallationPresenter methodsFor: 'initialization' stamp: ''!
close
	self withWindowDo: #close! !

!ClyMetaLinkInstallationPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	super initializeWindow: aWindowPresenter.
	aWindowPresenter title: sourceNode printString! !

!ClyMetaLinkInstallationPresenter methodsFor: 'testing' stamp: ''!
isForMetaLinkInstallation
	^isForMetaLinkInstallation ifNil:[isForMetaLinkInstallation := true]! !

!ClyMetaLinkInstallationPresenter methodsFor: 'accessing' stamp: ''!
isForMetaLinkInstallation: anObject
	isForMetaLinkInstallation := anObject! !

!ClyMetaLinkInstallationPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	metalinkListPresenter := self newList.
	metalinkListPresenter items: self allRelevantMetaLinks.
	toolBar := self newToolbar.
	self toolbarButtons do: [ :button | toolBar addItem: button ]! !

!ClyMetaLinkInstallationPresenter class methodsFor: 'opening' stamp: ''!
openInstallerOnNode: aSourceNode
	(self onNode: aSourceNode forInstallation: true) openWithSpec! !

!ClyMetaLinkInstallationPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		  add: #toolBar
		  expand: false
		  fill: false
		  padding: 0;
		  add: #metalinkListPresenter;
		  yourself! !

!ClyMetaLinkInstallationPresenter class methodsFor: 'instance creation' stamp: ''!
onNode: aSourceNode forInstallation: forInstallation
	^ self basicNew
		  sourceNode: aSourceNode;
		  isForMetaLinkInstallation: forInstallation;
		  initialize! !

!ClyMetaLinkInstallationPresenter class methodsFor: 'opening' stamp: ''!
openUninstallerOnNode: aSourceNode
	(self onNode: aSourceNode forInstallation: false) openWithSpec! !

!ClyMethod commentStamp: ''!
I represent the type of any kind of methods.
I am introduced to abstract actual method implementation where in live system it would be CompiledMethod.
So when Calypso build browser items for methods their type is supposed to be me.
Look at class references to discover all compatible method definitions.!
!ClyMethod class methodsFor: 'printing' stamp: ''!
printSystemPathTo: aMethod
	^aMethod origin package name, ' / ' , aMethod origin name! !

!ClyMethod class methodsFor: 'sorting' stamp: ''!
defaultSortFunctionForCalypso
	^ClySortMethodBySelectorFunction ascending! !

!ClyMethod class methodsFor: 'testing' stamp: ''!
match: aMethod forQueryBrowserFilter: aQueryBrowserFilter

	(aQueryBrowserFilter matchesString: aMethod selector) ifTrue: [ ^true ].
	(aQueryBrowserFilter matchesString: aMethod origin name) ifTrue: [ ^true ].
	^aQueryBrowserFilter matchesString: aMethod package name! !

!ClyMethod class methodsFor: 'testing' stamp: ''!
checkCalypsoItem: aCompiledMethod isEqualTo: anotherCompiledMethod
	aCompiledMethod == anotherCompiledMethod ifTrue: [ ^true ].
	
	^aCompiledMethod origin == anotherCompiledMethod origin 
		and: [ aCompiledMethod selector == anotherCompiledMethod selector ]! !

!ClyMethod class methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: aBrowserItem by: anEnvironmentPlugin
	^ anEnvironmentPlugin
		decorateBrowserItem: aBrowserItem
		ofMethod: aBrowserItem actualObject! !

!ClyMethod class methodsFor: 'sorting' stamp: ''!
itemsSortOrderForCalypso
	^1! !

!ClyMethod class methodsFor: 'item convertation' stamp: ''!
convertToCalypsoBrowserItem: aMethod

	| item |
	item := ClyBrowserItem named: aMethod selector with: aMethod.
	item addProperty: (ClyMethodDefinitionProperty of: aMethod).
	^item! !

!ClyMethodCallCountersQuery commentStamp: ''!
I return all methods which has installed execution counters!
!ClyMethodCallCountersQuery methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph label color: Color red.
	anItemCellMorph definitionIcon: #classIcon! !

!ClyMethodCallCountersQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	| plugin |
	plugin := self environment getPlugin: ClyReflectiveEnvironmentPlugin.
	^plugin doesMethodHasExecutionCounter: aMethod! !

!ClyMethodCallCountersQuery methodsFor: 'printing' stamp: ''!
description
	^'Method call counters'! !

!ClyMethodCallCountersQueryTest methodsFor: 'tests' stamp: ''!
testDecoratingMethodWithExecutionCounter

	| plugin method methodItem |
	plugin := ClyReflectiveEnvironmentPlugin new.
	self installCounterInto: #methodWithCounter.
	method := self class >> #methodWithCounter.
	methodItem := method asCalypsoBrowserItem.
		
	plugin decorateBrowserItem: methodItem ofMethod: method.
	
	self assert: (methodItem isMarkedWith: ClyMethodWithExecutionCounterTag)! !

!ClyMethodCallCountersQueryTest methodsFor: 'running' stamp: ''!
tearDown
	installedCounters do: [ :each | each uninstall ].
	installedCounters removeAll.
	
	super tearDown! !

!ClyMethodCallCountersQueryTest methodsFor: 'running' stamp: ''!
methodWithCounter
	^1+2! !

!ClyMethodCallCountersQueryTest methodsFor: 'tests' stamp: ''!
testSelectsMethodWithCounter
	self installCounterInto: #methodWithCounter.

	self assert: (query selectsMethod: self class >> #methodWithCounter)! !

!ClyMethodCallCountersQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	self installCounterInto: #methodWithCounter.
	query scope: (ClyMethodScope 
		of: (self class >> #methodWithCounter) in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyClassWithBreakpointsMock >> #methodWithoutBreakpoints) in: environment).
	self assert: query checkEmptyResult! !

!ClyMethodCallCountersQueryTest methodsFor: 'tests' stamp: ''!
testFromTwoMethods
	self installCounterInto: #methodWithCounter.
	self queryFromScope: ClyMethodScope ofAll: {
		self class >> #methodWithCounter. 
		self class >> #methodWithoutCounter}.
	
	self assert: foundSelectors sorted asArray equals: #(#methodWithCounter)! !

!ClyMethodCallCountersQueryTest methodsFor: 'running' stamp: ''!
methodWithoutCounter! !

!ClyMethodCallCountersQueryTest methodsFor: 'running' stamp: ''!
installCounterInto: selector
	| counter |
	counter := ExecutionCounter installOn: (self class >> selector) ast sendNodes last.
	installedCounters add: counter.
	^counter! !

!ClyMethodCallCountersQueryTest methodsFor: 'running' stamp: ''!
setUpEnvironment
	super setUpEnvironment.
	
	environment addPlugin: ClyReflectiveEnvironmentPlugin new! !

!ClyMethodCallCountersQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsMethodWithoutCounter

	self deny: (query selectsMethod: self class >> #methodWithoutCounter)! !

!ClyMethodCallCountersQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyMethodCallCountersQuery from: ClyClassScope of: self class in: environment! !

!ClyMethodCallCountersQueryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	installedCounters := OrderedCollection new! !

!ClyMethodChange commentStamp: ''!
I represent all possible changes with method.
I am used to subscribe with single subscription to any changes related to methods.
So you can write code like this: 

	SystemAnnouncer uniqueInstance when: (ClyMethodChange of: MyClass >> #someMethod) do: [ :ann | ann logCr ].
	
I provide more general subscription logic than subscribing on base MethodAnnouncement class. Many other events can be also related to method changes like renaming package or running test. They are not covered by MethodAnnouncement hierarchy.
I reuse logic of queries how they detect that their result is affected by system changes: 
	
	ClyMethodChange>>handlesAnnouncement: anAnnouncement 
 		^anAnnouncement affectsMethod: affectedMethod	

Also I provide class side method to get AnnouncementSet representing multiple method changes: 

	ClyMethodChange ofAll: { MyClass >> #someMethod. MyClass >> #someMethod2 }.

I am used by method editor tools to be updated when editing method is changed.
	
Internal Representation and Key Implementation Points.

    Instance Variables
	affectedMethod:		<CompiledMethod>!
!ClyMethodChange methodsFor: 'accessing' stamp: ''!
affectedMethod
	^ affectedMethod! !

!ClyMethodChange methodsFor: 'accessing' stamp: ''!
affectedMethod: anObject
	affectedMethod := anObject! !

!ClyMethodChange methodsFor: 'testing' stamp: ''!
handlesAnnouncement: anAnnouncement

	| newMethod |
	affectedMethod isInstalled ifFalse: [ 
		newMethod := affectedMethod origin 
			localMethodNamed: affectedMethod selector ifAbsent: [nil].
		newMethod ifNotNil: [ affectedMethod := newMethod ]  ].
	
	^anAnnouncement affectsMethod: affectedMethod! !

!ClyMethodChange class methodsFor: 'instance creation' stamp: ''!
of: aMethod
	^self new 
		affectedMethod: aMethod! !

!ClyMethodChange class methodsFor: 'instance creation' stamp: ''!
ofAll: methods
	^methods collect: [ :each | self of: each ] as: AnnouncementSet! !

!ClyMethodCodeEditorToolMorph commentStamp: ''!
I am a method source code editor.

I am opened in the browser when method is selected.

I am subscribed on the system changes related to my editing method.

Internal Representation and Key Implementation Points.

    Instance Variables
	editingMethod:		<CompiledMethod>!
!ClyMethodCodeEditorToolMorph methodsFor: 'testing' stamp: ''!
belongsToRemovedBrowserContext
	| actualMethod |
	super belongsToRemovedBrowserContext ifTrue: [ ^true ].
	
	actualMethod := editingMethod origin 
		localMethodNamed: editingMethod selector ifAbsent: [^true].
		
	self editingMethod: actualMethod.
	^false! !

!ClyMethodCodeEditorToolMorph methodsFor: 'accessing' stamp: ''!
methodClass

	self belongsToCurrentBrowserContext ifFalse: [ ^editingMethod origin ].
	
	^browser chooseClassForEditorOfMethod: editingMethod! !

!ClyMethodCodeEditorToolMorph methodsFor: 'operations' stamp: ''!
toggleExtendingPackage
	super toggleExtendingPackage.
	
	self hasUnacceptedEdits ifFalse: [self packageEditingMethod: editingMethod]! !

!ClyMethodCodeEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingMethod: aMethod
	editingMethod := aMethod! !

!ClyMethodCodeEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpModelFromContext
	super setUpModelFromContext.

	editingMethod := context lastSelectedMethod! !

!ClyMethodCodeEditorToolMorph methodsFor: 'updating' stamp: ''!
update

	editingMethod := editingMethod origin 
		localMethodNamed: editingMethod selector ifAbsent: [^self].
	
	super update.
	
	self formatTextIfNeeded.! !

!ClyMethodCodeEditorToolMorph methodsFor: 'selecting text' stamp: ''!
findAnyVariableInSourceCode: varNames
	| foundNode |
	
	foundNode := editingMethod variableNodes 
		detect: [ :each | varNames includes: each name ] ifNone: [ ^0 to: -1 ].
		
	^foundNode start to: foundNode stop! !

!ClyMethodCodeEditorToolMorph methodsFor: 'contexts' stamp: ''!
createCommandContextForCursorAt: aCursorPoint

	| sourceNode |
	sourceNode := self findSourceNodeAt: aCursorPoint.
	
	^ClyMethodSourceCodeContext for: self selectedNode: sourceNode! !

!ClyMethodCodeEditorToolMorph methodsFor: 'accessing' stamp: ''!
selectedSourceNode

	| selectedInterval selectedNode |
	selectedInterval := self selectedTextInterval.
	
	selectedNode := selectedInterval isEmpty 
		ifTrue: [ ast bestNodeForPosition: selectedInterval first ]
		ifFalse: [ ast bestNodeFor: selectedInterval ].
	
	^ selectedNode ifNil: [ ast ]! !

!ClyMethodCodeEditorToolMorph methodsFor: '*Calypso-SystemTools-OldToolCompatibillity' stamp: ''!
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! !

!ClyMethodCodeEditorToolMorph methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
decorateByCritic: aCriticTool
	| segments |
	(textMorph segments select: [ :each | each class = ClyCriticalTextSegmentMorph ])
		do: [ :each | each delete ]. "We should not remove while iterating"
	
	segments := aCriticTool buildCriticalTextSegmentsFor: editingMethod.	
	segments do: [ :each | textMorph addSegment: each]! !

!ClyMethodCodeEditorToolMorph methodsFor: '*Calypso-SystemTools-OldToolCompatibillity' stamp: ''!
findString: searchedString asSelectorIn: 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! !

!ClyMethodCodeEditorToolMorph methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserTool
	(super isSimilarTo: anotherBrowserTool) ifFalse: [ ^false ].
	
	^editingMethod == anotherBrowserTool editingMethod or: 
		[ editingMethod selector == anotherBrowserTool editingMethod selector
			and: [ editingMethod origin == anotherBrowserTool editingMethod origin ] ]! !

!ClyMethodCodeEditorToolMorph methodsFor: 'initialization' stamp: ''!
initializeAST
	"When the editor is created, we get the AST from the method"
	^ editingMethod ast! !

!ClyMethodCodeEditorToolMorph methodsFor: 'accessing' stamp: ''!
extendingPackage: aPackage
	super extendingPackage: aPackage.
	
	self hasUnacceptedEdits ifFalse: [self packageEditingMethod: editingMethod]! !

!ClyMethodCodeEditorToolMorph methodsFor: 'building' stamp: ''!
buildLeftSideBar
	super buildLeftSideBar.

	self leftSideBar enableMouseCommands: CmdTextLeftBarClickActivation withContextFrom: self! !

!ClyMethodCodeEditorToolMorph methodsFor: 'operations' stamp: ''!
cancelChanges
	self updateMethodTagsAndPackage.
	
	super cancelChanges! !

!ClyMethodCodeEditorToolMorph methodsFor: 'selecting text' stamp: ''!
selectSourceNode: anASTNode

	textMorph setSelection: anASTNode sourceInterval! !

!ClyMethodCodeEditorToolMorph methodsFor: 'operations' stamp: ''!
applyChanges
	| selector methodClass currentMethod |
	methodClass := self chooseClassForNewMethodIfNone: [^false].
	selector := methodClass compile: self pendingText classified: editingMethod protocol notifying: textMorph.
	selector ifNil: [^false ].
	currentMethod := methodClass >> selector.
	self tagAndPackageEditingMethod: currentMethod.
	self switchToMethod: currentMethod.
	"update the AST to the just compiled method. This clears breakpoints. To be improved"
	ast := self initializeAST.
	^true! !

!ClyMethodCodeEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpParametersFromModel
	super setUpParametersFromModel.

	self updateMethodTagsAndPackage! !

!ClyMethodCodeEditorToolMorph methodsFor: 'testing' stamp: ''!
belongsToCurrentBrowserContext
	^browser methodSelection isEmpty 
		ifTrue: [ browser isClassSelected: self editingMethod origin ]
		ifFalse: [ browser isMethodSelected: self editingMethod]! !

!ClyMethodCodeEditorToolMorph methodsFor: 'controlling' stamp: ''!
attachToSystem

	browser system 
		when: (ClyMethodChange of: self editingMethod)
		send: #triggerUpdate
		to: self! !

!ClyMethodCodeEditorToolMorph methodsFor: 'testing' stamp: ''!
isCommandAvailable: aCommand 

	^ aCommand canBeExecutedInCodeMethodEditor: self! !

!ClyMethodCodeEditorToolMorph methodsFor: 'accessing' stamp: ''!
methodTags: tagsArray
	super methodTags: tagsArray.
	
	self hasUnacceptedEdits ifFalse: [ self tagEditingMethod: editingMethod]! !

!ClyMethodCodeEditorToolMorph methodsFor: 'initialization' stamp: ''!
defaultIconName
	^#scriptManagerIcon! !

!ClyMethodCodeEditorToolMorph methodsFor: 'printing' stamp: ''!
printContext
	^self editingMethod printSystemPath! !

!ClyMethodCodeEditorToolMorph methodsFor: 'operations' stamp: ''!
switchToMethod: aMethod
	self detachFromSystem.
	editingMethod := aMethod.
	self attachToSystem.	
	browser selectMethod: editingMethod.
	self update.! !

!ClyMethodCodeEditorToolMorph methodsFor: 'building' stamp: ''!
decorateContainerTab
	| title |
	super decorateContainerTab.
	title := editingMethod selector.

	editingMethod origin isClassSide ifTrue: [ 
		title := title asText allBold ].

	containerTab label: title! !

!ClyMethodCodeEditorToolMorph methodsFor: 'contexts' stamp: ''!
findSourceNodeAt: aCursorPoint
	| startPosition endPosition line lineIndex  selection |
	lineIndex := self leftSideBar lineIndexForPoint: aCursorPoint. "strangely we can't ask text morph about it"
	line := textMorph paragraph lines at: lineIndex.	
	startPosition := line first.
	endPosition := line last.

	selection := self selectedTextInterval.
	selection ifNotNil: [ 
		selection first >= startPosition & (selection last <= endPosition) ifTrue: [ 
			startPosition := selection first max: 1.
			endPosition := selection last min: self editingText size]].

	^(ast bestNodeFor: (startPosition to: endPosition))
		ifNil: [ ast ]! !

!ClyMethodCodeEditorToolMorph methodsFor: 'contexts' stamp: ''!
createTextContext
	^self selectedSourceNode
		ifNil: [super createTextContext]
		ifNotNil: [ :astNode | ClyMethodSourceCodeContext for: self selectedNode: astNode]! !

!ClyMethodCodeEditorToolMorph methodsFor: 'selecting text' stamp: ''!
selectAnySelector: selectors

	textMorph setSelection: (self findAnySelectorInSourceCode: selectors)! !

!ClyMethodCodeEditorToolMorph methodsFor: 'selecting text' stamp: ''!
findAnySelectorInSourceCode: selectors

	| foundSelector foundNode positions |
	foundNode := ast sendNodes 
		detect: [:each | selectors includes: (foundSelector := each selector) ] 
		ifNone: [ 
			ast allChildren
				detect: [:each | each isLiteralNode and: [ selectors includes: each value ]]
				ifFound: [:literal | ^ literal sourceInterval ].
			^0 to: -1].
		
	positions := foundNode keywordsPositions.
	^positions first to: positions last + foundSelector keywords last size - 1.! !

!ClyMethodCodeEditorToolMorph methodsFor: 'selecting text' stamp: ''!
selectAnyVariable: varNames

	textMorph setSelection: (self findAnyVariableInSourceCode: varNames)! !

!ClyMethodCodeEditorToolMorph methodsFor: 'testing' stamp: ''!
modifiesExtension
	^editingMethod isExtension 
		ifTrue: [ extendingPackage ~~ editingMethod package  ]
		ifFalse: [ extendingPackage notNil and: [extendingPackage ~~ self methodClass package] ]! !

!ClyMethodCodeEditorToolMorph methodsFor: 'updating' stamp: ''!
updateMethodTagsAndPackage
	
	methodTags := editingMethod tags reject: [ :each | each beginsWith: '*' ].	
	extendingPackage := editingMethod isExtension ifTrue: [ editingMethod package ] ifFalse: [ nil ].! !

!ClyMethodCodeEditorToolMorph methodsFor: '*Calypso-SystemTools-OldToolCompatibillity' stamp: ''!
selectStringAsInMessageBrowser: criteriaString

	| interval |
	interval := (self findAnySelectorInSourceCode: {criteriaString}) 
			ifEmpty: [ self findString: criteriaString asSelectorIn: self pendingText].
	textMorph setSelection: interval! !

!ClyMethodCodeEditorToolMorph methodsFor: 'building' stamp: ''!
applyDecorations
	| hasEdits |
	
	hasEdits := textMorph hasUnacceptedEdits.
	textMorph segments copy do: #delete.	
	"literal methods do not need ot be stylized and this is an operation that can take 
	 a lot of time, we will skip it when it is the case"
	editingMethod isLiteralMethod ifFalse: [ 
		IconStyler withStaticStylers  
			styleText: textModel withAst: ast ].	
	textMorph hasUnacceptedEdits: hasEdits.
	
	super applyDecorations.
	
	browser decorateMethodEditor: self! !

!ClyMethodCodeEditorToolMorph methodsFor: 'selecting text' stamp: ''!
selectVariableNamed: varName

	self selectAnyVariable: { varName }! !

!ClyMethodCodeEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingMethod
	^editingMethod! !

!ClyMethodCodeEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingText
	^editingMethod sourceCode! !

!ClyMethodCodeEditorToolMorph methodsFor: 'controlling' stamp: ''!
detachFromSystem

	browser system unsubscribe: self! !

!ClyMethodCodeEditorToolMorph methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
criticAnalysisScope
	^ ClyMethodScope of: editingMethod in: browser navigationEnvironment! !

!ClyMethodCodeEditorToolMorph methodsFor: '*Calypso-SystemPlugins-Critic-Browser' stamp: ''!
supportsCriticDecoration
	^true! !

!ClyMethodCodeEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpTargetClasses

	targetClasses := browser chooseClassesForNewMethod: editingMethod! !

!ClyMethodCodeEditorToolMorph class methodsFor: 'activation' stamp: ''!
browserTabActivation
	"This declaration specifies that in any browser when methods are selected, a method editor will be available in a tab."
	
	<classAnnotation>
	^ClyTabActivationStrategyAnnotation for: ClyMethod asCalypsoItemContext! !

!ClyMethodCodeEditorToolMorph class methodsFor: 'testing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	^aBrowserContext isMethodSelected! !

!ClyMethodCounterGroupProvider commentStamp: ''!
I provide "counters" method group which put together all methods with installed execution counters!
!ClyMethodCounterGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyMethodCallCountersQuery from: aClassScope! !

!ClyMethodCounterGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'counters' priority: 8.4 on: aMethodQuery! !

!ClyMethodCounterGroupProviderTest methodsFor: 'running' stamp: ''!
tearDown
	
	installedCounter uninstall.
	
	super tearDown.! !

!ClyMethodCounterGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyMethodCounterGroupProvider! !

!ClyMethodCounterGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	^ClyMethodCallCountersQueryTest! !

!ClyMethodCounterGroupProviderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	installedCounter := ClyMethodCallCountersQueryTest new setUp; installCounterInto: #methodWithCounter! !

!ClyMethodCreationToolMorph commentStamp: ''!
I am a tool to create methods using source code editor.

I am opened in browser when class is selected. But in addition I disappear when there is selected method (it can be changed in the future).

Internal Representation and Key Implementation Points.

    Instance Variables
	methodClass:		<CompiledMethod>
!
!ClyMethodCreationToolMorph methodsFor: 'initialization' stamp: ''!
defaultIconName
	^#add! !

!ClyMethodCreationToolMorph methodsFor: 'accessing' stamp: ''!
methodClass
	^methodClass! !

!ClyMethodCreationToolMorph methodsFor: 'initialization' stamp: ''!
decorateContainerTab
	| title |
	
	super decorateContainerTab.
	
	browser metaLevelScope == ClyClassSideScope ifFalse: [ ^ self ].
	 
	title := self defaultTitle asText allBold. 
	containerTab label: title! !

!ClyMethodCreationToolMorph methodsFor: 'controlling' stamp: ''!
restoreBrowserState

	browser selectClass: methodClass! !

!ClyMethodCreationToolMorph methodsFor: 'initialization' stamp: ''!
setUpModelFromContext
	| selectedGroup |
	super setUpModelFromContext.

	methodClass := context selectedClassSide.
	context isMethodGroupSelected ifFalse: [ ^self].
	selectedGroup := context lastSelectedMethodGroup.
	(selectedGroup isKindOf: ClyExternalPackageMethodGroup) ifTrue: [ 
		^extendingPackage := selectedGroup package].
	(selectedGroup isKindOf: ClyTaggedMethodGroup) ifTrue: [ 
		^methodTags := {selectedGroup tag}]! !

!ClyMethodCreationToolMorph methodsFor: 'testing' stamp: ''!
modifiesExtension
	"I create new method. So I am not modify anything"
	^false! !

!ClyMethodCreationToolMorph methodsFor: 'initialization' stamp: ''!
defaultTitle

	^browser metaLevelScope defaultName capitalized, ' method'! !

!ClyMethodCreationToolMorph methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserTool
	(super isSimilarTo: anotherBrowserTool) ifFalse: [ ^false ].
	
	^methodClass == anotherBrowserTool methodClass
		and: [ methodTags = anotherBrowserTool methodTags 
				and: [ extendingPackage = anotherBrowserTool extendingPackage ] ]! !

!ClyMethodCreationToolMorph methodsFor: 'accessing' stamp: ''!
editingText
	^methodClass sourceCodeTemplate! !

!ClyMethodCreationToolMorph methodsFor: 'operations' stamp: ''!
applyChanges
	| newMethod selector selectedClass |
	selectedClass := self chooseClassForNewMethodIfNone: [^false].
	
	selector := methodTags 
		ifEmpty: [ selectedClass compile: self pendingText asString notifying: textMorph]
		ifNotEmpty: [
			selectedClass compile: self pendingText asString classified: methodTags anyOne notifying: textMorph].
			
	selector ifNil: [ ^false ].
	
	newMethod := selectedClass >> selector.
	methodTags ifEmpty: [ 
		MethodClassifier classify: newMethod.
		methodTags := newMethod tags ].
	self tagAndPackageEditingMethod: newMethod.
	
	self removeFromBrowser.
	browser tabManager desiredSelection: {ClyMethodCodeEditorToolMorph}.
	browser selectMethod: newMethod.
	^true! !

!ClyMethodCreationToolMorph methodsFor: 'testing' stamp: ''!
belongsToCurrentBrowserContext
	^browser isClassSelected: methodClass instanceSide! !

!ClyMethodCreationToolMorph methodsFor: 'initialization' stamp: ''!
setUpTargetClasses

	targetClasses := browser chooseClassesForNewMethod.
	(targetClasses includes: methodClass) ifFalse: [ 
		targetClasses := {methodClass}, targetClasses ]! !

!ClyMethodCreationToolMorph methodsFor: 'printing' stamp: ''!
printContext
	^methodClass printSystemPath, ' / ' , methodClass name! !

!ClyMethodCreationToolMorph methodsFor: 'accessing' stamp: ''!
activationPriority
	"We want creation tool be active by default only when user select method group.
	Instead when user select class creation tool should not be activated"
	^browser methodGroupSelection isEmpty 
		ifTrue: [ 0]
		ifFalse: [ ClyClassDefinitionEditorToolMorph tabOrder + 1 ]! !

!ClyMethodCreationToolMorph class methodsFor: 'accessing' stamp: ''!
tabOrder
	^ 1000! !

!ClyMethodCreationToolMorph class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserActivation
	<classAnnotation>
	
	^ClyTabActivationStrategyAnnotation for: ClyFullBrowserMethodGroupContext! !

!ClyMethodCreationToolMorph class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserActivation2
	<classAnnotation>
	
	^ClyTabActivationStrategyAnnotation for: ClyFullBrowserVariableContext! !

!ClyMethodCreationToolMorph class methodsFor: 'testing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	^aBrowserContext isClassSelected! !

!ClyMethodDefinitionProperty commentStamp: ''!
I represent definition of method which includes defining package and defining class.

You can create me by: 

	ClyClassDefinitionProperty of: aMethod 
	
Also I provide extra flag #isExtension to mark that method is extension.
			 
Internal Representation and Key Implementation Points.

    Instance Variables
	isExtension:		<Boolean>!
!ClyMethodDefinitionProperty methodsFor: 'accessing' stamp: ''!
isExtension: anObject
	isExtension := anObject! !

!ClyMethodDefinitionProperty methodsFor: 'printing' stamp: ''!
printDefinition

	^self printDefiningClass! !

!ClyMethodDefinitionProperty methodsFor: 'accessing' stamp: ''!
isExtension
	^ isExtension! !

!ClyMethodDefinitionProperty methodsFor: 'printing' stamp: ''!
printDefiningProtocol
	^ protocol! !

!ClyMethodDefinitionProperty methodsFor: 'accessing' stamp: ''!
protocol: anObject
	protocol := anObject! !

!ClyMethodDefinitionProperty class methodsFor: 'instance creation' stamp: ''!
package: aPackage class: aClass protocol: aProtocol
	
	^(super package: aPackage class: aClass)
		isExtension: aClass package ~~ aPackage;
		protocol: aProtocol;
		yourself.! !

!ClyMethodDefinitionProperty class methodsFor: 'instance creation' stamp: ''!
of: aMethod
	| methodPackage methodClass methodProtocol |
	methodPackage := aMethod package.
	methodClass := aMethod origin.
	methodProtocol := aMethod protocol.
	
	methodPackage ifNil: [ methodPackage := methodClass package ]. "it happens when creation new method in trait. It should be fixed in system"
	
	^ self package: methodPackage class: methodClass protocol: methodProtocol! !

!ClyMethodDefinitionProperty class methodsFor: 'instance creation' stamp: ''!
package: aPackage class: aClass
	
	^(super package: aPackage class: aClass)
		isExtension: aClass package ~~ aPackage! !

!ClyMethodDiffToolMorph commentStamp: ''!
I a browser tool to compare two methods.
I am automatically activated when two methods are selected.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	diffMorph:		<DiffMorph>
	leftMethod:		<CompiledMethod>
	rightMethod:		<CompiledMethod>!
!ClyMethodDiffToolMorph methodsFor: 'testing' stamp: ''!
belongsToRemovedBrowserContext
	^self leftMethod isInstalled not or: [ self rightMethod isInstalled not ]! !

!ClyMethodDiffToolMorph methodsFor: 'initialization' stamp: ''!
defaultIconName
	^#diff! !

!ClyMethodDiffToolMorph methodsFor: 'initialization' stamp: ''!
setUpModelFromContext 

	leftMethod := context firstSelectedMethod.
	rightMethod := context lastSelectedMethod! !

!ClyMethodDiffToolMorph methodsFor: 'updating' stamp: ''!
update
	leftMethod := leftMethod origin 
		localMethodNamed: leftMethod selector ifAbsent: [^self].
	rightMethod := rightMethod origin 
		localMethodNamed: rightMethod selector ifAbsent: [^self].
	
	super update.
	
	diffMorph from: leftMethod sourceCode to: rightMethod sourceCode! !

!ClyMethodDiffToolMorph methodsFor: 'initialization' stamp: ''!
defaultTitle
	^'Diff'! !

!ClyMethodDiffToolMorph methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserTool
	(super isSimilarTo: anotherBrowserTool) ifFalse: [ ^false ].
	
	^{leftMethod. rightMethod} asIdentitySet = {anotherBrowserTool leftMethod. anotherBrowserTool rightMethod  } asIdentitySet! !

!ClyMethodDiffToolMorph methodsFor: 'initialization' stamp: ''!
resetStateForSnapshot
	super resetStateForSnapshot.
	
	diffMorph := nil! !

!ClyMethodDiffToolMorph methodsFor: 'controlling' stamp: ''!
detachFromSystem

	browser system unsubscribe: self! !

!ClyMethodDiffToolMorph methodsFor: 'building' stamp: ''!
build
	diffMorph := DiffMorph from: self leftMethod sourceCode to: self rightMethod sourceCode.
	diffMorph	
		contextClass: self rightMethod sourceCode;
		hResizing:	#spaceFill;
		vResizing: #spaceFill;
		showOptions: false.
	self addMorph: diffMorph fullFrame: LayoutFrame identity! !

!ClyMethodDiffToolMorph methodsFor: 'accessing' stamp: ''!
rightMethod
	^rightMethod! !

!ClyMethodDiffToolMorph methodsFor: 'testing' stamp: ''!
belongsToCurrentBrowserContext
	^(browser isMethodSelected: leftMethod) 
		and: [ browser isMethodSelected: rightMethod ]! !

!ClyMethodDiffToolMorph methodsFor: 'controlling' stamp: ''!
attachToSystem

	browser system 
		when: (ClyMethodChange ofAll: {self leftMethod. self rightMethod}) 
		send: #triggerUpdate to: self! !

!ClyMethodDiffToolMorph methodsFor: 'accessing' stamp: ''!
leftMethod
	^leftMethod! !

!ClyMethodDiffToolMorph methodsFor: 'printing' stamp: ''!
printContext
	^'left / ', leftMethod printSystemPath , ' vs right / ', rightMethod printSystemPath! !

!ClyMethodDiffToolMorph methodsFor: 'accessing' stamp: ''!
activationPriority
	^0! !

!ClyMethodDiffToolMorph class methodsFor: 'activation' stamp: ''!
browserTabActivation
	"This declaration specifies that in any browser when methods are selected, a diff tool will be available in a tab."

	<classAnnotation>
	^ClyTabActivationStrategyAnnotation for: ClyMethod asCalypsoItemContext! !

!ClyMethodDiffToolMorph class methodsFor: 'accessing' stamp: ''!
tabOrder
	^10000! !

!ClyMethodDiffToolMorph class methodsFor: 'accessing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	^aBrowserContext selectedMethods size > 1! !

!ClyMethodEditorCommand commentStamp: ''!
I a base class for commands which manages the method editor.

Subclasses can be executed in context of ClyMetodEditor.

Internal Representation and Key Implementation Points.

    Instance Variables
	methodEditor:		<ClyMethodEditor>!
!ClyMethodEditorCommand methodsFor: 'accessing' stamp: ''!
methodEditor: anObject
	methodEditor := anObject! !

!ClyMethodEditorCommand methodsFor: 'accessing' stamp: ''!
methodEditor
	^ methodEditor! !

!ClyMethodEditorCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	methodEditor := aToolContext tool! !

!ClyMethodEditorCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation for: ClyTextEditorContext! !

!ClyMethodEditorCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInCodeMethodEditor: aTool
	
	^ true! !

!ClyMethodEditorCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInClassEditor: aTool

	^ false! !

!ClyMethodEditorCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyMethodEditorCommand! !

!ClyMethodEditorCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInMethodEditor: aTool

	^ false! !

!ClyMethodEditorCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext

	^ aToolContext tool isCommandAvailable: self! !

!ClyMethodEditorToolMorph commentStamp: ''!
I am a base class for method edito tools.

I implement correctly the styling of typed source code. 
Also I add multiple text editing tools to the status bar: 
- wrap mode switch 
- line number=s switch
- format as you read 
- method tags and package editor.

In addition to the superclass abstract methods subclasses should implement following methods: 

- methodClass 
Subclasses should decide what class will accept editing method

- modifiesExtension 
Subclasses should detect that editing method is going to be extension.

Internal Representation and Key Implementation Points.

    Instance Variables
	extendingPackage:		<RPackage>
	methodTags:		<Array of<Symbol>>!
!ClyMethodEditorToolMorph methodsFor: 'testing' stamp: ''!
belongsToRemovedBrowserContext
	super belongsToRemovedBrowserContext ifTrue: [ ^true ].
	
	^self methodClass isObsolete! !

!ClyMethodEditorToolMorph methodsFor: 'building' stamp: ''!
buildTextMorph
	super buildTextMorph.
	ast := self initializeAST.
	self formatTextIfNeeded.! !

!ClyMethodEditorToolMorph methodsFor: 'accessing' stamp: ''!
methodClass
	self subclassResponsibility! !

!ClyMethodEditorToolMorph methodsFor: 'accessing' stamp: ''!
methodTags
	^methodTags! !

!ClyMethodEditorToolMorph methodsFor: 'operations' stamp: ''!
toggleExtendingPackage

	extendingPackage ifNotNil: [ ^extendingPackage := nil ].
	
	extendingPackage := browser searchDialog 
		requestSingleObject: 'Choose package for method' from: ClyAllPackagesQuery sorted! !

!ClyMethodEditorToolMorph methodsFor: 'building' stamp: ''!
fillStatusBar
	| position |
	super fillStatusBar.
	
	position := statusBar addContextItem: (ClyCursorPositionLabelMorph of: textMorph).
	position comeToFront.
	statusBar addCommandItem: (ClyTextWrapModeSwitchMorph of: textMorph).
	statusBar addCommandItem: (ClyTextLineNumbersSwitchMorph of: textMorph).
	statusBar addCommandItem: (ClyFormatAsReadSwitchMorph of: textMorph).
	
	statusBar addCommandItem: (ClyMethodTagsAndPackageEditorMorph for: self).! !

!ClyMethodEditorToolMorph methodsFor: 'operations' stamp: ''!
chooseClassForNewMethodIfNone: aBlock
	
	targetClasses size = 1 ifTrue: [ ^ targetClasses first].

	^[self browser searchDialog 
			requestSingleObject: 'Where install new method?'
			from: (ClyAllClassesQuery as: ClyMethodVisibilityProviderAnnotation defaultHierarchy asQueryResult) 
			inScope: (ClyClassScope ofAll: targetClasses)]
		on: CmdCommandAborted do: [:err | aBlock value ]! !

!ClyMethodEditorToolMorph methodsFor: 'initialization' stamp: ''!
initializeAST
	"subclasses might get it from the method"
	^ self currentEditedAST! !

!ClyMethodEditorToolMorph methodsFor: 'operations' stamp: ''!
tagEditingMethod: aMethod
	| existingTags removedTags newTags |
	self applyChangesBy: [
		existingTags := aMethod tags reject: [:each | each beginsWith: '*'].
		removedTags := existingTags reject: [ :each | methodTags includes: each ].
		newTags := methodTags reject: [ :each | existingTags includes: each ].
	
		newTags do: [ :each | aMethod tagWith: each asSymbol].
		removedTags do: [ :each | aMethod untagFrom: each asSymbol]
	]! !

!ClyMethodEditorToolMorph methodsFor: 'accessing' stamp: ''!
extendingPackage: aPackage
	extendingPackage := aPackage.
	methodTags := #().! !

!ClyMethodEditorToolMorph methodsFor: 'testing' stamp: ''!
allowsDifferentActivationPriority
	^false! !

!ClyMethodEditorToolMorph methodsFor: 'accessing' stamp: ''!
extendingPackage
	^ extendingPackage! !

!ClyMethodEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpParametersFromModel
	super setUpParametersFromModel.

	self setUpTargetClasses! !

!ClyMethodEditorToolMorph methodsFor: 'testing' stamp: ''!
isCommandAvailable: aCommand 

	^ aCommand canBeExecutedInMethodEditor: self! !

!ClyMethodEditorToolMorph methodsFor: 'accessing' stamp: ''!
methodTags: tagsArray
	methodTags := tagsArray.
	extendingPackage := nil! !

!ClyMethodEditorToolMorph methodsFor: 'events handling' stamp: ''!
currentEditedAST

	^ self methodClass compiler
		  source: self pendingText;
		  options: #( + optionParseErrors + optionSkipSemanticWarnings );
		  parse! !

!ClyMethodEditorToolMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	methodTags := #()! !

!ClyMethodEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingClass 
	^self methodClass! !

!ClyMethodEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
selectedClassOrMetaClass
	^self methodClass! !

!ClyMethodEditorToolMorph methodsFor: 'testing' stamp: ''!
modifiesExtension
	"it should answer if tool is going to modify extension state of method.
	For example tool ca move method to another package
	ot it can move extension method back to class package"
	self subclassResponsibility! !

!ClyMethodEditorToolMorph methodsFor: 'operations' stamp: ''!
packageEditingMethod: aMethod
	
	self applyChangesBy: [ 
		(extendingPackage notNil and: [aMethod package ~~ extendingPackage]) ifTrue: [
			^(SycMoveMethodsToPackageCommand for: {aMethod} to: extendingPackage) 
				execute].
	
		(extendingPackage isNil and: [ aMethod isExtension ]) ifTrue: [ 
			(SycMoveMethodsToPackageDefiningClassCommand for: {aMethod}) 
				execute]
	]! !

!ClyMethodEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
isForScripting
	^false! !

!ClyMethodEditorToolMorph methodsFor: 'accessing' stamp: ''!
tagsAndPackageEditor
	^(statusBar findDeeplyA: ClyMethodTagsAndPackageEditorMorph) ifNil: [ CmdCommandAborted signal ]! !

!ClyMethodEditorToolMorph methodsFor: 'events handling' stamp: ''!
changesAreAboutApply
	| tagsEditor |
	super changesAreAboutApply.
	
	tagsEditor := statusBar findDeeplyA: ClyMethodTagsEditorMorph.
	tagsEditor ifNil: [ ^self ].
	
	tagsEditor acceptTags! !

!ClyMethodEditorToolMorph methodsFor: 'operations' stamp: ''!
formatSourceCode
	textMorph formatSourceCode! !

!ClyMethodEditorToolMorph methodsFor: 'building' stamp: ''!
formatTextIfNeeded
	RBProgramNode formatterClass formatAsYouReadPolicy ifFalse: [ ^self].
	
	textMorph formatSourceCode. 
	textModel clearUserEdits! !

!ClyMethodEditorToolMorph methodsFor: 'operations' stamp: ''!
tagAndPackageEditingMethod: aMethod
	self tagEditingMethod: aMethod.
	"Tagging should be performed before package movement 
	because extending package is still based on protocol begining with star. 
	So it should override manual tagging"	
	self packageEditingMethod: aMethod! !

!ClyMethodEditorToolMorph methodsFor: 'events handling' stamp: ''!
textChanged: aTextChanged
	super textChanged: aTextChanged.
	ast := self currentEditedAST.
	textMorph segments copy do: #delete.
	IconStyler new
	   stylerClasses: {ErrorNodeStyler . SemanticMessageIconStyler . SemanticVariableIconStyler }; 
		styleText: textModel withAst: ast.
	^ ast! !

!ClyMethodEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpTargetClasses
	self subclassResponsibility! !

!ClyMethodEditorToolMorph class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyMethodEditorToolMorph! !

!ClyMethodEditorToolMorph class methodsFor: 'accessing' stamp: ''!
tabOrder
	^20! !

!ClyMethodExtensionSwitchMorph commentStamp: ''!
I am status bar tool for method editors to switch the extension status of the editing method. 

Internal Representation and Key Implementation Points.

    Instance Variables
	checkbox:		<Object>
!
!ClyMethodExtensionSwitchMorph methodsFor: 'testing' stamp: ''!
isActive

	^ownerTool extendingPackage notNil! !

!ClyMethodExtensionSwitchMorph methodsFor: 'operations' stamp: ''!
toggle

	[ownerTool toggleExtendingPackage] on: CmdCommandAborted do: [ :err | ].
	checkbox updateLabel! !

!ClyMethodExtensionSwitchMorph methodsFor: 'accessing' stamp: ''!
checkbox
	^ checkbox! !

!ClyMethodExtensionSwitchMorph methodsFor: 'initialization' stamp: ''!
build
	
	checkbox := self theme 
		newCheckboxIn: self 
		for: self 
		getSelected: #isActive 
		setSelected: #toggle 
		getEnabled: nil 
		getLabel: #label
		help: 'toggle check box to choose/reset package of method'.
	checkbox
		changeTableLayout;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap.
	self addMorph: checkbox! !

!ClyMethodExtensionSwitchMorph methodsFor: 'accessing' stamp: ''!
checkbox: anObject
	checkbox := anObject! !

!ClyMethodExtensionSwitchMorph methodsFor: 'accessing' stamp: ''!
label
	| label |
	label := ownerTool extendingPackage 
		ifNil: ['extension']
		ifNotNil: [:package | package name ].
	ownerTool modifiesExtension ifTrue: [ label := '*', label ].
	^label! !

!ClyMethodFlag commentStamp: ''!
I mark methods which send #flag: message!
!ClyMethodGroup commentStamp: ''!
I am the root of the method group hierarchy.

 method group is created on a method query:

	ClyMethodGroup named: 'some group' on: aMethodQuery

A method query can also be a composite, and should return methods in any case.

Also, a method group can be expanded into subgroups using subgroupsQuery, which you can specify using this other instance creation method: 

	ClyMethodGroup named: 'some group' on: aMethodQuery withSubgroupsFrom: aQuery	

There are additional constructors to specify the group's priority:

	ClyMethodGroup named: 'some group' priority: 20 on: aMethodQuery.
	ClyMethodGroup named: 'some group' priority: 20 on: aMethodQuery withSubgroupsFrom: aQuery

In the browser, groups are sorted by descending priority and then by name.

I provide several methods to implement various commands: 

- importMethod: aMethod
It is supposed to modify aMethod, making it part of the group.

- importMethods: methods 
Same as above, but for multiple methods
		 
- removeWithMethods
It removes all methods and should ensure that groups will be removed too which is true for all virtual groups.

And I provide #includesMethod:, which is used in the browser to highlight groups which contains selected method(s).

Internal Representation and Key Implementation Points.

    Instance Variables
	methodQuery:		<ClyMethodQuery>
	subgroupsQuery:		<ClyQuery>!
!ClyMethodGroup methodsFor: 'testing' stamp: ''!
isEmpty
	^methodQuery hasEmptyResult! !

!ClyMethodGroup methodsFor: '*Calypso-Browser' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem
	super decorateTableCell: anItemCellMorph of: groupItem.
	
	methodQuery decorateMethodGroupTableCell: anItemCellMorph of: groupItem! !

!ClyMethodGroup methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].
	
	^ methodQuery = anObject methodQuery
		and: [ subgroupsQuery = anObject subgroupsQuery ]! !

!ClyMethodGroup methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	subgroupsQuery := ClyUnknownQuery instance! !

!ClyMethodGroup methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ methodQuery hash bitXor: subgroupsQuery hash! !

!ClyMethodGroup methodsFor: 'accessing' stamp: ''!
methodQuery
	^methodQuery! !

!ClyMethodGroup methodsFor: 'operations' stamp: ''!
removeWithMethods
	self methods do: [ :each | each removeFromSystem ]! !

!ClyMethodGroup methodsFor: 'operations' stamp: ''!
convertToMethodTag: aTagName

	self methods do: [ :each | each tagWith: aTagName ]! !

!ClyMethodGroup methodsFor: 'accessing' stamp: ''!
subgroupsQuery
	^subgroupsQuery! !

!ClyMethodGroup methodsFor: 'operations' stamp: ''!
importMethod: aMethod! !

!ClyMethodGroup methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	methodQuery printOn: aStream.
	aStream nextPut: $).! !

!ClyMethodGroup methodsFor: 'operations' stamp: ''!
importMethods: methodsCollection 

	methodsCollection do: [ :each | self importMethod: each ]! !

!ClyMethodGroup methodsFor: 'accessing' stamp: ''!
methodsSize
	^self methods size! !

!ClyMethodGroup methodsFor: 'testing' stamp: ''!
includesMethod: aMethod
	^self methodQuery retrievesItem: aMethod! !

!ClyMethodGroup methodsFor: 'system changes' stamp: ''!
isAffectedByPackageChange: aPackageAnnouncement
	^false! !

!ClyMethodGroup methodsFor: 'testing' stamp: ''!
asAsyncQueryGroup
	^ClyAsyncMethodGroup 
		named: name 
		priority: priority 
		on: methodQuery
		withSubgroupsFrom: subgroupsQuery! !

!ClyMethodGroup methodsFor: 'decoration' stamp: ''!
decorateOwnBrowserItem: myItem
	super decorateOwnBrowserItem: myItem.
	
	methodQuery decorateItemGroup: myItem.
	subgroupsQuery decorateItemGroup: myItem.! !

!ClyMethodGroup methodsFor: 'accessing' stamp: ''!
methodQuery: aMethodQuery
	methodQuery := aMethodQuery! !

!ClyMethodGroup methodsFor: 'accessing' stamp: ''!
methods
	^methodQuery execute items! !

!ClyMethodGroup methodsFor: 'accessing' stamp: ''!
subgroupsQuery: anObject
	subgroupsQuery := anObject! !

!ClyMethodGroup methodsFor: '*Calypso-SystemPlugins-FileOut-Queries' stamp: ''!
fileOut
	| internalStream class |
	internalStream := (String new: 1000) writeStream.
	internalStream
		timeStamp;
		cr.
	self methods do: [ :each | each origin printMethodChunk: each selector on: internalStream ].
	class := methodQuery scope basisObjects anyOne.
	^ CodeExporter writeSourceCodeFrom: internalStream baseName: class name , '-' , self name isSt: true! !

!ClyMethodGroup methodsFor: 'testing' stamp: ''!
dependsOnMethod: aMethod
	"This method is used to collect dynamic method group which depends on methods.
	It can be simple #includesMethod: which is default implementation here.
	But some groups require hook to be in group list but do not includes any methods.
	They will override it with true return. For example look at async method group"
	^self includesMethod: aMethod! !

!ClyMethodGroup class methodsFor: 'instance creation' stamp: ''!
named: aString on: aMethodQuery
	^(self named: aString)
		methodQuery: aMethodQuery! !

!ClyMethodGroup class methodsFor: 'queries' stamp: ''!
prepareSubgroupsQueryFrom: aMethodGroup in: aNavigationEnvironment

	^aMethodGroup subgroupsQuery! !

!ClyMethodGroup class methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: aBrowserItem by: anEnvironmentPlugin
	^ anEnvironmentPlugin
		decorateBrowserItem: aBrowserItem
		ofMethodGroup: aBrowserItem actualObject! !

!ClyMethodGroup class methodsFor: 'instance creation' stamp: ''!
named: aString priority: aNumber on: aMethodQuery withSubgroupsFrom: subgroupsQuery
	^(self named: aString priority: aNumber on: aMethodQuery) 
		subgroupsQuery: subgroupsQuery! !

!ClyMethodGroup class methodsFor: 'queries' stamp: ''!
shortName
	^'Methods'! !

!ClyMethodGroup class methodsFor: 'testing' stamp: ''!
isBasedOnMethodTag
	^false! !

!ClyMethodGroup class methodsFor: 'instance creation' stamp: ''!
named: aString on: aMethodQuery withSubgroupsFrom: subgroupsQuery
	^(self named: aString on: aMethodQuery) 
		subgroupsQuery: subgroupsQuery! !

!ClyMethodGroup class methodsFor: 'instance creation' stamp: ''!
named: aString priority: aNumber on: aMethodQuery
	^(self named: aString priority: aNumber)
		methodQuery: aMethodQuery! !

!ClyMethodGroupCommand commentStamp: ''!
I am a base class for command which perform some action with method groups.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	methodGroups:		<Collection of<ClyMethodGroup>>!
!ClyMethodGroupCommand methodsFor: 'accessing' stamp: ''!
methodGroups
	^ methodGroups! !

!ClyMethodGroupCommand methodsFor: 'accessing' stamp: ''!
methodGroups: anObject
	methodGroups := anObject! !

!ClyMethodGroupCommand methodsFor: 'activation - drag and drop' stamp: ''!
prepareExecutionInDragContext: aToolContext
	super prepareExecutionInDragContext: aToolContext.
	
	methodGroups := aToolContext selectedMethodGroups! !

!ClyMethodGroupCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	methodGroups := aToolContext selectedMethodGroups! !

!ClyMethodGroupCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyMethodGroupCommand! !

!ClyMethodGroupCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isMethodGroupSelected! !

!ClyMethodGroupProvider commentStamp: ''!
I am a root of hierarchy of method group providers.
My subclasses build method groups for given class scope. They should implement: 

- buildGroupsFrom: aClassScope

Implementors should not think about it emptiness of created groups. Groups query filters reduntant groups by itself.
But subclasses can specify that group should be always present using method #isStatic. By default any provider defines static groups. 
Static groups are not depends the count of methods which they provide!
!ClyMethodGroupProvider methodsFor: 'testing' stamp: ''!
isStatic
	^true! !

!ClyMethodGroupProvider methodsFor: 'system changes' stamp: ''!
providesGroupsAffectedBy: aSystemAnnouncement inScope: aClassScope

	aClassScope classesDo: [ :each | 
		(aSystemAnnouncement affectsClass: each) ifTrue: [ ^true ]].
		
	^false! !

!ClyMethodGroupProvider methodsFor: 'building groups' stamp: ''!
buildGroupsFrom: aClassScope 
	self subclassResponsibility! !

!ClyMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	self subclassResponsibility! !

!ClyMethodGroupProviderTest methodsFor: 'running' stamp: ''!
buildGroupsFor: aClass
	| classScope |
	classScope := ClyClassScope of: aClass in: environment.
	builtGroups := groupProvider buildGroupsFrom: classScope! !

!ClyMethodGroupProviderTest methodsFor: 'tests' stamp: ''!
testBuildingGroups

	self buildGroupsFor: self classSampleWhichHasGroup.
	
	self assert: builtGroups notEmpty! !

!ClyMethodGroupProviderTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyMethodGroupProviderTest! !

!ClyMethodGroupTest methodsFor: 'running' stamp: ''!
createMethodGroup
	self subclassResponsibility! !

!ClyMethodGroupTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	group := self createMethodGroup! !

!ClyMethodQuery commentStamp: ''!
I am abstract query of all methods from given scope.
Subclasses should define concrete condition which all retrieved methods should satisfy: 
- selectsMethod: aMethod 

Scope should support #methodsDo: which I use to collect and filter all available methods.!
!ClyMethodQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin
	anEnvironmentPlugin collectMetadataOfMethods: aQueryResult! !

!ClyMethodQuery methodsFor: 'system changes' stamp: ''!
isAffectedByChangedMethod: aMethod
	
	^self selectsMethod: aMethod! !

!ClyMethodQuery methodsFor: 'testing' stamp: ''!
retrievesItem: aMethod
	^self selectsMethod: aMethod! !

!ClyMethodQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	^(aSystemAnnouncement canAffectResultOfMethodQuery: self)
		and: [ scope includesMethodsAffectedBy: aSystemAnnouncement]! !

!ClyMethodQuery methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem! !

!ClyMethodQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	| filteredMethods |
	filteredMethods := OrderedCollection new.
	
	scope methodsDo: [ :each | 
		(self selectsMethod: each) ifTrue: [filteredMethods add: each]].
	
	aQueryResult fillWith: filteredMethods! !

!ClyMethodQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	self subclassResponsibility! !

!ClyMethodQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	scope methodsDo: [ :each | 
		(self selectsMethod: each) ifTrue: [^false]].
	
	^true! !

!ClyMethodQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	^ClyMethod! !

!ClyMethodQueryTest methodsFor: 'tests' stamp: ''!
testIsEmptyFromEmptyMethodScope
	query scope: (ClyMethodScope emptyIn: environment).
	self assert: query checkEmptyResult! !

!ClyMethodQueryTest methodsFor: 'methods for tests' stamp: ''!
clyMessageImplementor1! !

!ClyMethodQueryTest methodsFor: 'running' stamp: ''!
executeQuery
	super executeQuery.
	foundSelectors := (resultItems collect: [:each | each selector]) sorted asArray.! !

!ClyMethodQueryTest methodsFor: 'running' stamp: ''!
setUpEnvironment
	super setUpEnvironment.
	
	environment system: ClySystemEnvironment currentImage! !

!ClyMethodQueryTest methodsFor: 'methods for tests' stamp: ''!
superclassSenderOfMessage1
	self clyReferencedMessage1! !

!ClyMethodQueryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyMethodQueryTest! !

!ClyMethodScope commentStamp: ''!
I am a scope of methods.

Currently I do not provide any information except methods itself!
!ClyMethodScope methodsFor: 'initialization' stamp: ''!
prepareBasisFrom: aCollection
	^aCollection asIdentitySet! !

!ClyMethodScope methodsFor: 'queries' stamp: ''!
methodsDo: aBlock
	basisObjects do: aBlock! !

!ClyMethodScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'methods'! !

!ClyMethodScopeTest methodsFor: 'running' stamp: ''!
extraBasisSample
	^self class >> #method2! !

!ClyMethodScopeTest methodsFor: 'helpers' stamp: ''!
method1! !

!ClyMethodScopeTest methodsFor: 'running' stamp: ''!
scopeClass

	^ClyMethodScope! !

!ClyMethodScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumeration
	scope := ClyMethodScope ofAll: {self class >> #method1. self class >> #method2}.
		
	scope methodsDo: [ :each | result add: each ].
	
	self assertCollection: result asArray hasSameElements: scope basisObjects! !

!ClyMethodScopeTest methodsFor: 'helpers' stamp: ''!
method2! !

!ClyMethodScopeTest methodsFor: 'running' stamp: ''!
singleBasisSample
	^self class >> #method1! !

!ClyMethodSourceCodeContext methodsFor: 'selection' stamp: ''!
selectedMethods
	^{self selectedMethod}! !

!ClyMethodSourceCodeContext methodsFor: 'accessing' stamp: ''!
methodEditor
	^tool! !

!ClyMethodSourceCodeContext methodsFor: 'tool controlling' stamp: ''!
showMessage: aMessageDescription renamedTo: newSelector
	"here we expect only messages which was created from ast-nodes"
	tool editingMethod selector == aMessageDescription selector 
		ifTrue: [ tool switchToMethod: tool methodClass >> newSelector]
		ifFalse: [ tool selectAnySelector: { newSelector } ]! !

!ClyMethodSourceCodeContext methodsFor: 'testing' stamp: ''!
isMethodSelected

	^self selectedSourceNode isMethod! !

!ClyMethodSourceCodeContext methodsFor: 'selection' stamp: ''!
lastSelectedMethod
	^self selectedMethod! !

!ClyMethodSourceCodeContext methodsFor: 'selection' stamp: ''!
selectedMethod
	^tool editingMethod! !

!ClyMethodSourcesQuery commentStamp: ''!
I return all methods which source code includes particular string pattern.
For example it can be simple substring or regex expression. 
But generally pattern is represented by ClyStringPattern subclasses.

To create my instances use following methods:

	ClyMethodSourcesQuery withString: 'probe string'.
	ClyMethodSourcesQuery withString: 'probe string' caseSensitive: true.
	ClyMethodSourcesQuery filteredBy: aStringPattern
	
Internal Representation and Key Implementation Points.

    Instance Variables
	pattern:		<ClyStringPattern>!
!ClyMethodSourcesQuery methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateResultMethodEditor: aMethodEditor
	
	aMethodEditor selectAnyString: {pattern value}! !

!ClyMethodSourcesQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."
	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ pattern = anObject pattern! !

!ClyMethodSourcesQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: pattern hash! !

!ClyMethodSourcesQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod

	^pattern matches: aMethod sourceCode! !

!ClyMethodSourcesQuery methodsFor: 'printing' stamp: ''!
description

	^'methods sources with ', pattern value printString! !

!ClyMethodSourcesQuery methodsFor: 'accessing' stamp: ''!
pattern: anObject
	pattern := anObject! !

!ClyMethodSourcesQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream
	super printExtraInfoOn: aStream.

	^aStream nextPutAll: pattern value! !

!ClyMethodSourcesQuery methodsFor: 'accessing' stamp: ''!
pattern
	^ pattern! !

!ClyMethodSourcesQuery class methodsFor: 'instance creation' stamp: ''!
withString: aString caseSensitive: aBool

	^self filteredBy: (ClySubstringPattern with: aString caseSensitive: aBool)! !

!ClyMethodSourcesQuery class methodsFor: 'instance creation' stamp: ''!
filteredBy: aStringPattern from: aScope
	^(self from: aScope)
		pattern: aStringPattern! !

!ClyMethodSourcesQuery class methodsFor: 'instance creation' stamp: ''!
filteredBy: aStringPattern
	^self new 
		pattern: aStringPattern! !

!ClyMethodSourcesQuery class methodsFor: 'instance creation' stamp: ''!
withString: aString

	^self withString: aString caseSensitive: false! !

!ClyMethodSourcesQuery class methodsFor: 'instance creation' stamp: ''!
withString: aString caseSensitive: aBool from: aScope

	^self 
		filteredBy: (ClySubstringPattern with: aString caseSensitive: aBool)
		from: aScope! !

!ClyMethodSourcesQuery class methodsFor: 'instance creation' stamp: ''!
withString: aString from: aScope

	^self withString: aString caseSensitive: false from: aScope! !

!ClyMethodSourcesQueryTest methodsFor: 'tests' stamp: ''!
testFromClassScope

	self queryFromScope: ClyClassScope of: self class.
	
	self assert: resultItems size equals: 1.
	
	self assert: resultItems first equals: (self class >> #methodWithExpectedStringInSources)! !

!ClyMethodSourcesQueryTest methodsFor: 'example methods' stamp: ''!
expectedSourceCodeSubstring
	^'it should be in the source code of ', #expectedMethod! !

!ClyMethodSourcesQueryTest methodsFor: 'tests' stamp: ''!
testComparison
	self assert: (ClyMethodSourcesQuery withString: 'test substring') equals: (ClyMethodSourcesQuery withString: 'test ' , 'substring').

	self assert: (ClyMethodSourcesQuery withString: 'test substring') hash equals: (ClyMethodSourcesQuery withString: 'test ' , 'substring') hash.

	self deny: (ClyMethodSourcesQuery withString: 'test substring') equals: (ClyMethodSourcesQuery withString: 'another substring')! !

!ClyMethodSourcesQueryTest methodsFor: 'tests' stamp: ''!
testExpectedMethodShouldIncludeExpectedString

	self assert: ((self class >> #methodWithExpectedStringInSources) sourceCode 
		includesSubstring: self expectedSourceCodeSubstring caseSensitive: false)! !

!ClyMethodSourcesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyClassScope of: self class in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyClassScope of: self class superclass in: environment).
	self assert: query checkEmptyResult! !

!ClyMethodSourcesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyMethodSourcesQuery
		withString: self expectedSourceCodeSubstring
		from: (ClyClassScope of: self class in: environment)! !

!ClyMethodSourcesQueryTest methodsFor: 'example methods' stamp: ''!
methodWithExpectedStringInSources
	"it should be in the source code of expectedMethod"
	^self printString! !

!ClyMethodTableDecorator commentStamp: ''!
I am a base class for method table decorators.

I am annotated by decoration strategy in context of selected method.
So my subclasses should just implement decoration logic!
!ClyMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyMethod asCalypsoItemContext! !

!ClyMethodTableDecorator class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyMethodTableDecorator! !

!ClyMethodTagsAndPackageEditorMorph commentStamp: ''!
I am status bar tool for method editors to select method tags or extending package for the editing method.

While system only support tags when method is not extension I do not show both elements.
So I provide checkbox for extension status.
When it is active I should extending package in the label.
When it is not active I show method tag (protocol) in the label.

When user toggle checkbox I request either package or protocol depending on requested mode of method.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	editButton:		<Morph>
	extensionCheckbox:		<Morph>
	label:		<StringMorph>
!
!ClyMethodTagsAndPackageEditorMorph methodsFor: 'building' stamp: ''!
buildExtensionCheckBoxButton
	extensionCheckbox := self theme 
		newCheckboxIn: self 
		for: self 
		getSelected: #isExtensionActive 
		setSelected: #toggleExtension
		getEnabled: nil 
		label: 'extension'
		help: 'toggle check box to choose/reset package of method'.
	extensionCheckbox
		changeTableLayout;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'building' stamp: ''!
buildResetButton

	resetButton := IconicButtonMorph new
		target: self;
		actionSelector: #resetTagsAndPackage;
		arguments: #();
		labelGraphic: (self iconNamed: #glamorousClose);
		color: Color transparent;
		borderWidth: 0;
		hResizing: #shinkWrap;
		layoutInset: 4@0! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'building' stamp: ''!
buildLabel

	label := self theme newLabelIn: self label: self printMethodTagsOrPackage.
	label on: #click send: #openEditor to: self! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.	
	self cellInset: 2@2! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'building' stamp: ''!
update
	label color: label defaultColor.
	label contents: self printMethodTagsOrPackage.
	self isExtensionActive 
		ifTrue: [ editButton helpText: 'Choose package for method']
		ifFalse: [ editButton helpText: 'Classify method']! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'printing' stamp: ''!
printMethodTagsOrPackage

	^self isExtensionActive 
		ifTrue: [ ownerTool extendingPackage name]
		ifFalse: [ self printMethodTags ]! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'printing' stamp: ''!
printMethodTags

	^ownerTool methodTags 
		ifEmpty: [ 'as yet unclassified' asText makeAllColor: Color red ]
		ifNotEmpty: [ :tags | tags joinUsing: ', ' ]! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'operations' stamp: ''!
resetTagsAndPackage
	ownerTool methodTags: #().
	self update! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'operations' stamp: ''!
openEditor

	self requestChangeBy: [
		self isExtensionActive 
			ifTrue: [ self requestPackage]
			ifFalse: [ self requestTag ]
	]! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'operations' stamp: ''!
requestPackage

	| extendingPackage |
	extendingPackage := ownerTool context requestSinglePackage: 'Choose package for method'.
		
	ownerTool extendingPackage: extendingPackage! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'building' stamp: ''!
build	
	self buildResetButton.
	self addMorphBack: resetButton.
	
	self buildEditButton.
	self addMorphBack: editButton.
	
	self buildLabel.
	self addMorphBack: label.
	
	self buildExtensionCheckBoxButton.
	self addMorphBack: extensionCheckbox.
	
	self update! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'testing' stamp: ''!
isExtensionActive

	^ownerTool extendingPackage notNil! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'building' stamp: ''!
buildEditButton
	editButton := IconicButtonMorph new
		target: self;
		actionSelector: #openEditor;
		arguments: #();
		labelGraphic: (self iconNamed: #edit);
		color: Color transparent;
		borderWidth: 0! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'operations' stamp: ''!
requestChangeBy: aBlock
	
	aBlock on: CmdCommandAborted do: [ :err ].
	
	self update! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'operations' stamp: ''!
requestTag

	| selectedTag existingTag |
	existingTag := ownerTool methodTags 
		ifEmpty: [ '' ] ifNotEmpty: [ :tags | tags anyOne ].

	selectedTag := self ownerTool context
		requestSingleMethodTag: 'New protocol name' suggesting: existingTag.
	selectedTag = existingTag ifTrue: [ ^CmdCommandAborted signal ].
	
	ownerTool methodTags: { selectedTag asSymbol }! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'operations' stamp: ''!
toggleExtension

	self requestChangeBy: [ 
		self isExtensionActive 
			ifTrue: [ self requestTag ]
			ifFalse: [ self requestPackage]
	]! !

!ClyMethodTagsAndPackageEditorMorph methodsFor: 'accessing' stamp: ''!
ownerTool: anObject

	super ownerTool: anObject! !

!ClyMethodTagsEditorMorph commentStamp: ''!
I am status bar tool for method editors to input method tags for the editing method.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	textMorph:		<Object>!
!ClyMethodTagsEditorMorph methodsFor: 'operations' stamp: ''!
printMethodTags

	^', ' join: ownerTool methodTags! !

!ClyMethodTagsEditorMorph methodsFor: 'operations' stamp: ''!
acceptTags

	textMorph accept.
	textMorph hasUnacceptedEdits: false! !

!ClyMethodTagsEditorMorph methodsFor: 'building' stamp: ''!
build
	self hResizing: #rigid.
	self width: 120.
	textMorph := self theme 
		newTextEntryIn: self 
		for: self 
		get: #printMethodTags 
		set: #setNewMethodTags: 
		class: nil 
		getEnabled: nil 
		help: 'input tags which should be applied to current method'.
	textMorph 
		hResizing: #spaceFill;
		acceptOnFocusChange: false;
		ghostText: 'as yet unclassified'.
	
	self addMorph: textMorph! !

!ClyMethodTagsEditorMorph methodsFor: 'operations' stamp: ''!
setNewMethodTags: tagsString

	| tags |
	tags := (',' split: tagsString) collect: #trimBoth as: Array.
	
	ownerTool methodTags: (tags reject: #isEmpty)! !

!ClyMethodViewToolbarGroup commentStamp: ''!
I am a toolbar menu group to show method group view modes of the browser together!
!ClyMethodViewToolbarGroup methodsFor: 'accessing' stamp: ''!
order
	^4! !

!ClyMethodVisibilityGroupsResult commentStamp: ''!
I am a class query result whch represent classes as ClyInheritedMethodGroup instances wrapped as browser items.
I am used to represent classes when you expand first item in the third pane of full browser.
ClyInheritedMethodGroup instances provide tools to control method visibility in the browser by showing/hidding methods of corresponding inherited classes.

I sort classes hierarchically according to specified hierarchy. You can create my instances with: 

	ClyMethodVisibilityGroups withHierarchy: ClySubclassHierarchy inverse.
	
Tools create me with default hierarchy using: 
	
	ClyMethodVisibilityGroups withDefaultHierarchy.

Calypso provides settings to invert default hierarchy and to extend it with plugins. 
It is based on class annotation ClyMethodVisibilityProvider. Look at it for details.

Internal Representation and Key Implementation Points.

    Instance Variables
	hierarchy:		<ClyClassHierarchy>!
!ClyMethodVisibilityGroupsResult methodsFor: 'building' stamp: ''!
buildGroupFor: aClass depth: depth toShowMethodsFrom: aScope

	| group item |
	group := ClyInheritedMethodGroup withMethodsOf: aClass toShowIn: aScope.
	item := group asCalypsoBrowserItem.
	item depth: depth.
	items add: item! !

!ClyMethodVisibilityGroupsResult methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^false ].
	
	^ hierarchy = anObject hierarchy! !

!ClyMethodVisibilityGroupsResult methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: hierarchy hash! !

!ClyMethodVisibilityGroupsResult methodsFor: 'accessing' stamp: ''!
hierarchy: anObject
	hierarchy := anObject! !

!ClyMethodVisibilityGroupsResult methodsFor: 'accessing' stamp: ''!
hierarchy
	^ hierarchy! !

!ClyMethodVisibilityGroupsResult methodsFor: 'building' stamp: ''!
fillWith: classes
	| actualClassScope classMap addedClasses |
	actualClassScope := self scope asLocalClassScope. 
	classMap := hierarchy buildFrom: classes.
	addedClasses := Set new.
	classMap doInOrderWithDepth: [ :each :depth |
		(addedClasses includes: each) ifFalse: [ 
			addedClasses add: each.
			self buildGroupFor: each depth: depth toShowMethodsFrom: actualClassScope]]! !

!ClyMethodVisibilityGroupsResult class methodsFor: 'instance creation' stamp: ''!
defaultHierarchy

	^ClyMethodVisibilityProviderAnnotation defaultHierarchy! !

!ClyMethodVisibilityGroupsResult class methodsFor: 'instance creation' stamp: ''!
withDefaultHierarchy

	^self withHierarchy: self defaultHierarchy! !

!ClyMethodVisibilityGroupsResult class methodsFor: 'instance creation' stamp: ''!
withHierarchy: aClassHierarchy

	^self new 
		hierarchy: aClassHierarchy! !

!ClyMethodVisibilityGroupsTest methodsFor: 'tests' stamp: ''!
testDefaultHierarchyShouldExist

	self assert: (ClyMethodVisibilityGroupsResult defaultHierarchy isKindOf: ClyClassHierarchy)! !

!ClyMethodVisibilityGroupsTest methodsFor: 'running' stamp: ''!
meaningfullObjectToAssert: resultItem
	^resultItem actualObject methodQuery scope basisObjects anyOne! !

!ClyMethodVisibilityGroupsTest methodsFor: 'tests' stamp: ''!
testFillingWithThreeClasses

	queryResult fillWith: {ClyClass2FromP1Mock. ClySubclassN1OfClass1FromP1Mock. ClyClass1FromP1Mock}.
	
	self assertItems: { ClyClass1FromP1Mock. 0. ClySubclassN1OfClass1FromP1Mock. 1.
		ClyClass2FromP1Mock. 0}! !

!ClyMethodVisibilityGroupsTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyMethodVisibilityGroupsResult withHierarchy: ClySubclassHierarchy new! !

!ClyMethodVisibilityGroupsTest methodsFor: 'tests' stamp: ''!
testFillingWithSingleClasses
	| group visibilityLevel |
	queryResult fillWith: {ClyClass2FromP1Mock}.
	self assert: queryResult size equals: 1.
	group := queryResult items first actualObject.
	self assert: group class equals: ClyInheritedMethodGroup.
	self assert: group name equals: ClyClass2FromP1Mock name.
	self
		assert: group methodQuery
		equals: (ClyAllMethodsQuery from: ClyClassScope	of: ClyClass2FromP1Mock in: environment).
	self assert: group visibilityLevels size equals: 1.
	visibilityLevel := group visibilityLevels first.
	self
		assert: visibilityLevel class
		equals: ClySuperclassVisibilityLevel.
	self
		assert: visibilityLevel visibleClassScope
		equals: (ClyClassScope of: ClyClass1FromP1Mock in: environment).
	self
		assert: visibilityLevel extraClassScope
		equals: (ClyClassScope of: ClyClass2FromP1Mock in: environment)! !

!ClyMethodVisibilityGroupsTest methodsFor: 'running' stamp: ''!
createQuery
	^super createQuery 
		scope: (ClyClassScope of: ClyClass1FromP1Mock in: environment)! !

!ClyMethodVisibilityGroupsTest methodsFor: 'tests' stamp: ''!
testComparisonWithAnotherHierarchy
	| queryResult2 |
	queryResult2 := self createQueryResult.
	queryResult2 hierarchy: queryResult hierarchy inverted.

	self deny: queryResult equals: queryResult2! !

!ClyMethodVisibilityLevel commentStamp: ''!
I am a root of hierarchy of different kind of method visibilities.
Instances are created with currently visible class scope and extra scope which can be activated.

Activation/decactivation methods returns new scope which represent result method visibility: 

- activateExtraScope 
- deactivateExtraScope 

My instances are used by browser to switch method visibility of inherited classes. They use simple method #toggleScope which also returns result method scope.
To represent current state of visible scope I compute #isActive flag:
If any of classes from extra scope is included in the visible scope then my instance is considered active

My instances are created on currently visible class scope. And subclasses create extra scope according to their logic.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	visibleClassScope:		<ClyClassScope>
	extraClassScope:		<ClyAbstractClassScope>
	isActive:		<Boolean>
	


    Implementation Points!
!ClyMethodVisibilityLevel methodsFor: 'testing' stamp: ''!
isRedundant
	"the level is reduntant if there are no extra classes to show"
	extraClassScope classesDo: [ :each | ^false ].
	^true! !

!ClyMethodVisibilityLevel methodsFor: 'testing' stamp: ''!
isActive
	^isActive! !

!ClyMethodVisibilityLevel methodsFor: 'accessing' stamp: ''!
visibleClassScope
	^ visibleClassScope! !

!ClyMethodVisibilityLevel methodsFor: 'accessing' stamp: ''!
extraClassScope: aScope
	extraClassScope := aScope.
	self detectActiveState! !

!ClyMethodVisibilityLevel methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	self subclassResponsibility! !

!ClyMethodVisibilityLevel methodsFor: 'controlling' stamp: ''!
activateExtraScope
	^visibleClassScope increasedByClassesFrom: extraClassScope! !

!ClyMethodVisibilityLevel methodsFor: 'accessing' stamp: ''!
extraClassScope
	^ extraClassScope! !

!ClyMethodVisibilityLevel methodsFor: 'controlling' stamp: ''!
deactivateExtraScope
	^visibleClassScope reducedByClassesFrom: extraClassScope! !

!ClyMethodVisibilityLevel methodsFor: 'controlling' stamp: ''!
detectActiveState

	extraClassScope classesDo: [:each | 
		(visibleClassScope includesClass: each) ifTrue: [ 
			^isActive := true ] ].
	
	isActive := false! !

!ClyMethodVisibilityLevel methodsFor: 'controlling' stamp: ''!
toggleScope
	^self isActive
		ifTrue: [ self deactivateExtraScope ]
		ifFalse: [ self activateExtraScope ]! !

!ClyMethodVisibilityLevel methodsFor: 'accessing' stamp: ''!
visibleClassScope: aClassScope
	"We should cut off any inherited scopes here.
	Visible class scope must be an instance of ClyClassScope"
	visibleClassScope := aClassScope asLocalClassScope! !

!ClyMethodVisibilityLevel methodsFor: '*Calypso-SystemPlugins-Traits-Queries' stamp: ''!
asTraitVisibility
	self subclassResponsibility! !

!ClyMethodVisibilityLevel class methodsFor: 'testing' stamp: ''!
canBeAppliedForClasses: classItems
	^true! !

!ClyMethodVisibilityLevel class methodsFor: 'testing' stamp: ''!
isActiveByDefault
	^false! !

!ClyMethodVisibilityLevel class methodsFor: 'instance creation' stamp: ''!
of: aClassScope
	^self new 
		visibleClassScope: aClassScope! !

!ClyMethodVisibilityLevel class methodsFor: 'accessing' stamp: ''!
allAvailableFor: items
	
	^ self allSubclasses select: [ :each | 
		each isActiveByDefault and: (each canBeAppliedForClasses: items) ]! !

!ClyMethodVisibilityMorph commentStamp: ''!
I represent simple checkbox which toggle method visibility of the full browser.

I am created on visibility level which gives me new class scope which I pass to the browser.

Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>
	visibilityLevel:		<ClyMethodVisibilityLevel>!
!ClyMethodVisibilityMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	color := Color transparent.
	self changeTableLayout.
	self vResizing: #shrinkWrap.
	self hResizing: #shrinkWrap.
	self minWidth: 0.
	self minHeight: 0.! !

!ClyMethodVisibilityMorph methodsFor: 'accessing' stamp: ''!
visibilityLevel: anObject
	visibilityLevel := anObject! !

!ClyMethodVisibilityMorph methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyMethodVisibilityMorph methodsFor: 'building' stamp: ''!
build

	| checkBox |
	checkBox := CheckboxMorph 
		on: self selected: #isMethodsVisible changeSelected: #showInheritedMethods:.
	checkBox
		borderWidth: 0;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap.
	checkBox labelMorph delete.	

	self addMorph: checkBox.! !

!ClyMethodVisibilityMorph methodsFor: 'testing' stamp: ''!
isMethodsVisible
	
	^visibilityLevel isActive! !

!ClyMethodVisibilityMorph methodsFor: 'controlling' stamp: ''!
showInheritedMethods: aBoolean

	| newScope |
	self isMethodsVisible == aBoolean ifTrue: [ ^self ].
	
	newScope := visibilityLevel toggleScope.
	newScope isBasedOnEmptyBasis ifFalse: [ 
		browser restrictMethodVisibilityBy: newScope]! !

!ClyMethodVisibilityMorph methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!ClyMethodVisibilityMorph methodsFor: 'accessing' stamp: ''!
visibilityLevel
	^ visibilityLevel! !

!ClyMethodVisibilityMorph class methodsFor: 'instance creation' stamp: ''!
for: aBrowser level: aMethodVisibilityLevel
	^self new 
		browser: aBrowser;
		visibilityLevel: aMethodVisibilityLevel! !

!ClyMethodVisibilityProviderAnnotation commentStamp: ''!
I am special annotation which marks classes that they can provide special hierarchy to represent method visibility classes.
Users do not need to lookup my instances. They can simple use following method which will find appropriate class and create the hierarchy:

	ClyMethodVisibilityProvider defaultHierarchy

In simple case it is just inverse ClySubclassHierarchy. 
So when you expand inherited classes (first item in third browser pane) you will see selected class on top of list and then all superclasses.

But when class uses traits then traits are also shown in the hierarchy in special inheritance order. 
It is available only when trait plugin is loaded to the system. 
Plugin brings new type of hierarchy ClyTraitUserHierarchy which overrides default method visibility hierarchy by annotation.
During annotations lookup the first registered annotation is used. It has lagest priority. 
So ClyTraitUserHierarchy is just annotated with high priority value 100 which overrides default hierarchy annotation.

I expect that annotated classes will implement following class side method 

- hierarchyForMethodVisibility

Look at ClyMethodVisibilityProvider references for details!
!ClyMethodVisibilityProviderAnnotation methodsFor: 'hierarchy creation' stamp: ''!
createHierarchy
	^annotatedClass hierarchyForMethodVisibility! !

!ClyMethodVisibilityProviderAnnotation class methodsFor: 'default hierarchy' stamp: ''!
defaultHierarchy

	self registeredInstancesDo: [ :each | ^each createHierarchy ].
	
	self error: 'No hierarchy provider is found to represent method visibility hierarchy'! !

!ClyMethodWatchQuery commentStamp: ''!
I return all methods which has installed watchpoints!
!ClyMethodWatchQuery methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph label color: Color red.
	anItemCellMorph definitionIcon: #haloView! !

!ClyMethodWatchQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	| plugin |
	plugin := self environment getPlugin: ClyReflectiveEnvironmentPlugin.
	^plugin doesMethodHasWatch: aMethod! !

!ClyMethodWatchQuery methodsFor: 'printing' stamp: ''!
description
	^'Method Watchpoints'! !

!ClyMethodWatchQueryTest methodsFor: 'tests' stamp: ''!
testDecoratingMethodWithExecutionCounter

	| plugin method methodItem |
	plugin := ClyReflectiveEnvironmentPlugin new.
	self installWatchInto: #methodWithWatch.
	method := self class >> #methodWithWatch.
	methodItem := method asCalypsoBrowserItem.
		
	plugin decorateBrowserItem: methodItem ofMethod: method.
	
	self assert: (methodItem isMarkedWith: ClyMethodWithWatchTag)! !

!ClyMethodWatchQueryTest methodsFor: 'running' stamp: ''!
methodWithWatch
	"Currently watchpoint is only compatible with message nodes.
	So we can't install it directly on method node"
	^1+2! !

!ClyMethodWatchQueryTest methodsFor: 'running' stamp: ''!
tearDown
	installedWatchpoints do: [ :each | each uninstall ].
	installedWatchpoints removeAll.
	
	super tearDown! !

!ClyMethodWatchQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	self installWatchInto: #methodWithWatch.
	query scope: (ClyMethodScope 
		of: (self class >> #methodWithWatch) in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyClassWithBreakpointsMock >> #methodWithoutBreakpoints) in: environment).
	self assert: query checkEmptyResult! !

!ClyMethodWatchQueryTest methodsFor: 'running' stamp: ''!
methodWithoutWatch! !

!ClyMethodWatchQueryTest methodsFor: 'tests' stamp: ''!
testFromTwoMethods
	self installWatchInto: #methodWithWatch.
	self queryFromScope: ClyMethodScope ofAll: {
		self class >> #methodWithWatch. 
		self class >> #methodWithoutWatch}.
	
	self assert: foundSelectors sorted asArray equals: #(#methodWithWatch)! !

!ClyMethodWatchQueryTest methodsFor: 'running' stamp: ''!
setUpEnvironment
	super setUpEnvironment.
	
	environment addPlugin: ClyReflectiveEnvironmentPlugin new! !

!ClyMethodWatchQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsMethodWithoutWatch

	self deny: (query selectsMethod: self class >> #methodWithoutWatch)! !

!ClyMethodWatchQueryTest methodsFor: 'tests' stamp: ''!
testSelectsMethodWithWatch
	self installWatchInto: #methodWithWatch.

	self assert: (query selectsMethod: self class >> #methodWithWatch)! !

!ClyMethodWatchQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyMethodWatchQuery from: ClyClassScope of: self class in: environment! !

!ClyMethodWatchQueryTest methodsFor: 'running' stamp: ''!
installWatchInto: selector
	| watchpoint |
	watchpoint := Watch in: (self class >> selector) ast sendNodes last.
	installedWatchpoints add: watchpoint.
	^watchpoint! !

!ClyMethodWatchQueryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	installedWatchpoints := OrderedCollection new! !

!ClyMethodWithBreakpointTag commentStamp: ''!
I mark the method that it has breakpoint!
!ClyMethodWithExecutionCounterTag commentStamp: ''!
I mark methods that they have installed execution counters!
!ClyMethodWithHaltTag commentStamp: ''!
I mark the method that it has halt (sends any of halt message)!
!ClyMethodWithWatchTag commentStamp: ''!
I mark methods that they have installed watchpoints!
!ClyModifiedPackageTableDecorator commentStamp: ''!
I decorate dirty packages in the table using special icon.
I am active only when ClyMonticelloBrowserPlugin is installed into the browser!
!ClyModifiedPackageTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyModifiedPackageTableDecorator class methodsFor: 'decoration' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem

	^aDataSourceItem isMarkedWith: ClyDirtyPackageTag! !

!ClyModifiedPackageTableDecorator class methodsFor: 'decoration' stamp: ''!
priority
	^ClyPackageIconTableDecorator priority + 100! !

!ClyModifiedPackageTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	
	anItemCellMorph definitionIcon: #dirtyMonticelloPackageIcon! !

!ClyModifiedPackageTableDecorator class methodsFor: 'decoration' stamp: ''!
browserPluginClass
	^ClyMonticelloBrowserPlugin! !

!ClyMonticelloBrowserPlugin commentStamp: ''!
I am very simple plugin to allow disable table decoration of dirty package items.
Decoration is active only when I am installed into the browser!
!ClyMonticelloEnvironmentPlugin commentStamp: ''!
I mark dirty packages with special tag!
!ClyMonticelloEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
systemChanged: aPackageModified

	environment systemChanged: aPackageModified! !

!ClyMonticelloEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofPackage: aPackage

	| workingCopy |

	workingCopy := aPackage mcWorkingCopy.
	workingCopy ifNil: [ ^self ].
	
	workingCopy modified ifTrue: [
		anItem markWith: ClyDirtyPackageTag].! !

!ClyMonticelloEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
detachFromSystem

	environment system unsubscribe: self! !

!ClyMonticelloEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
attachToSystem

	environment system subscribe: self for: MCPackageModified! !

!ClyMoreRefactorsMenuGroup commentStamp: ''!
I am a submenu for rarely used refactorings!
!ClyMoreRefactorsMenuGroup methodsFor: 'accessing' stamp: ''!
buildContextMenu: aMenu
	aMenu addLine.
	
	super buildContextMenu: aMenu.
	aMenu addLine.! !

!ClyMoreRefactorsMenuGroup methodsFor: 'accessing' stamp: ''!
order
	^10100! !

!ClyMoreRefactorsMenuGroup methodsFor: 'accessing' stamp: ''!
name
	^ 'Refactorings'! !

!ClyMoveClassToGroupCommand commentStamp: ''!
I am a command to move classes into given class group.

By default I only available by dragging classes into the target class group.

Internal Representation and Key Implementation Points.

    Instance Variables
	classGroup:		<ClyClassGroup>!
!ClyMoveClassToGroupCommand methodsFor: 'accessing' stamp: ''!
classGroup: anObject
	classGroup := anObject! !

!ClyMoveClassToGroupCommand methodsFor: 'execution' stamp: ''!
prepareExecutionInDropContext: aToolContext
	super prepareExecutionInDropContext: aToolContext.
	classGroup := aToolContext lastSelectedClassGroup
	"this command can be also activated on package which is polimorphic to class group.
	If given context is package context then it will return package as class group"! !

!ClyMoveClassToGroupCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Move to package'! !

!ClyMoveClassToGroupCommand methodsFor: 'execution' stamp: ''!
execute

	classGroup importClasses: classes! !

!ClyMoveClassToGroupCommand methodsFor: 'accessing' stamp: ''!
classGroup
	^ classGroup! !

!ClyMoveClassToGroupCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	"class group could be package. In this activation it is only make sense to request user for package"
	
	classGroup := aToolContext requestSinglePackage: 'Choose package'! !

!ClyMoveClassToGroupCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallRedo! !

!ClyMoveClassToGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserDragAndDropActivation
	<classAnnotation>
	
	^CmdDragAndDropActivation 
		for: ClyClass asCalypsoItemContext 
		toDropIn: RPackage asCalypsoItemContext! !

!ClyMoveClassToGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserDragAndDropActivation2
	<classAnnotation>
	
	^CmdDragAndDropActivation 
		for: ClyClass asCalypsoItemContext 
		toDropIn: ClyTaggedClassGroup asCalypsoItemContext! !

!ClyMoveClassToGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserDragAndDropActivation3
	<classAnnotation>
	
	^CmdDragAndDropActivation 
		for: ClyClass asCalypsoItemContext 
		toDropIn: ClyNoTagClassGroup asCalypsoItemContext! !

!ClyMoveClassToGroupCommand class methodsFor: 'activation' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	
	^ SycClassMenuActivation byRootGroupItemOrder: 1000 for: ClyClass asCalypsoItemContext! !

!ClyMoveClassToGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $m meta, $c meta for: ClyFullBrowserClassContext! !

!ClyMoveMethodGroupToClassCommand commentStamp: ''!
I am a command to move method group together with methods into another class.

By default I am activated by dragging method groups into the target class.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	targetClass:		<Class>
!
!ClyMoveMethodGroupToClassCommand methodsFor: 'accessing' stamp: ''!
targetClass: anObject
	targetClass := anObject! !

!ClyMoveMethodGroupToClassCommand methodsFor: 'execution' stamp: ''!
prepareExecutionInDropContext: aToolContext
	super prepareExecutionInDropContext: aToolContext.
	targetClass := aToolContext lastSelectedClass.
	targetClass := aToolContext currentMetaLevelOf: targetClass! !

!ClyMoveMethodGroupToClassCommand methodsFor: 'execution' stamp: ''!
execute

	| moveCommand |
	methodGroups do: [ :each | 
		moveCommand := SycMoveMethodsToClassCommand methods: each methods class: targetClass.
		moveCommand execute.
		each removeWithMethods]! !

!ClyMoveMethodGroupToClassCommand methodsFor: 'accessing' stamp: ''!
targetClass
	^ targetClass! !

!ClyMoveMethodGroupToClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	targetClass := aToolContext requestSingleClass: 'Choose class'.
	targetClass := aToolContext currentMetaLevelOf: targetClass! !

!ClyMoveMethodGroupToClassCommand class methodsFor: 'activation' stamp: ''!
fullBrowserDragAndDropActivation
	<classAnnotation>
	
	^CmdDragAndDropActivation 
		for: ClyMethodGroup asCalypsoItemContext 
		toDropIn: ClyClass asCalypsoItemContext! !

!ClyMoveMethodGroupToClassCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext

	^aToolContext isSelectedMethodGroupEditable! !

!ClyMoveMethodGroupsToPackageCommand commentStamp: ''!
I am a command to move all methods of given method groups to another package.

Internal Representation and Key Implementation Points.

    Instance Variables
	package:		<RPackage>!
!ClyMoveMethodGroupsToPackageCommand methodsFor: 'execution' stamp: ''!
prepareExecutionInDropContext: aToolContext
	super prepareExecutionInDropContext: aToolContext.
	package := aToolContext lastSelectedPackage! !

!ClyMoveMethodGroupsToPackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName

	^'Convert to extension'! !

!ClyMoveMethodGroupsToPackageCommand methodsFor: 'execution' stamp: ''!
execute
	
	| repackagingCommand |
	methodGroups do: [ :each | 
		repackagingCommand := SycMoveMethodsToPackageCommand for: each methods to: package.
		repackagingCommand execute.
		each removeWithMethods]! !

!ClyMoveMethodGroupsToPackageCommand methodsFor: 'accessing' stamp: ''!
package: anObject
	package := anObject! !

!ClyMoveMethodGroupsToPackageCommand methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!ClyMoveMethodGroupsToPackageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	package := aToolContext requestSinglePackage: 'Choose package'! !

!ClyMoveMethodGroupsToPackageCommand class methodsFor: 'activation' stamp: ''!
fullBrowserDragAndDropActivation
	<classAnnotation>
	
	^CmdDragAndDropActivation 
		for: ClyMethodGroup asCalypsoItemContext 
		toDropIn: RPackage asCalypsoItemContext! !

!ClyMoveMethodGroupsToPackageCommand class methodsFor: 'activation' stamp: ''!
fullBrowserContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: ClyMethodGroup asCalypsoItemContext! !

!ClyMoveMethodsToGroupCommand commentStamp: ''!
I am a command to move methods to the method group.
By default I am activated by dragging selected method into the method tag (protocol).
 
Internal Representation and Key Implementation Points.

    Instance Variables
	methodGroup:		<ClyMethodGroup>!
!ClyMoveMethodsToGroupCommand methodsFor: 'accessing' stamp: ''!
methodGroup
	^ methodGroup! !

!ClyMoveMethodsToGroupCommand methodsFor: 'accessing' stamp: ''!
targetClass: anObject
	targetClass := anObject! !

!ClyMoveMethodsToGroupCommand methodsFor: 'drag and drop support' stamp: ''!
prepareExecutionInDropContext: aToolContext
	| selectedClasses |
	super prepareExecutionInDropContext: aToolContext.
	methodGroup := aToolContext lastSelectedMethodGroup.
	selectedClasses := aToolContext selectedClasses. 
	selectedClasses := selectedClasses collect: [:each | aToolContext currentMetaLevelOf: each].
	targetClass := selectedClasses size > 1 
		ifTrue: [ aToolContext 
			requestSingleClass: 'In what class you want to move method?' from: selectedClasses ]
		ifFalse: [ selectedClasses last ]! !

!ClyMoveMethodsToGroupCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Move to method group'! !

!ClyMoveMethodsToGroupCommand methodsFor: 'execution' stamp: ''!
execute
	
	| methodsOfAnotherClass |
	methodsOfAnotherClass := methods reject: [ :each | each origin = targetClass ].
	methodsOfAnotherClass ifNotEmpty: [ 
		(SycMoveMethodsToClassCommand methods: methodsOfAnotherClass class: targetClass) execute].
	
	methodGroup importMethods: methods! !

!ClyMoveMethodsToGroupCommand methodsFor: 'accessing' stamp: ''!
methodGroup: anObject
	methodGroup := anObject! !

!ClyMoveMethodsToGroupCommand methodsFor: 'accessing' stamp: ''!
targetClass
	^ targetClass! !

!ClyMoveMethodsToGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserDragAndDropActivation
	<classAnnotation>
	
	^CmdDragAndDropActivation 
		for: ClyMethod asCalypsoItemContext 
		toDropIn: ClyTaggedMethodGroup asCalypsoItemContext! !

!ClyMoveMethodsToGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserDragAndDropActivation2
	<classAnnotation>
	
	^CmdDragAndDropActivation 
		for: ClyMethod asCalypsoItemContext 
		toDropIn: ClyAllMethodGroup asCalypsoItemContext! !

!ClyMoveMethodsToGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserDragAndDropActivation3
	<classAnnotation>
	
	^CmdDragAndDropActivation 
		for: ClyMethod asCalypsoItemContext 
		toDropIn: ClyExternalPackageMethodGroup asCalypsoItemContext! !

!ClyMultipleClassRelationScope commentStamp: ''!
I represent complex hierarchy scope which merges together multiple kind of class relationship.
Class relations are represented by subclasses of ClySingleClassRelationScope. I use their #classesRelatedTo:do: method to enumerate all classes related to my basis:

	ClyMultipleClassRelationScope>>classesRelatedTo: aClass do: aBlock
		relationScopeClasses do: [ :each | 
			each classesRelatedTo: aClass do: aBlock ]

There is big difference between me and possible composition scope of other class relation scopes. 
For example try look at SomeTrait from the composition scope of ClySuperclassScope and ClyTraitUserScope.
First one will return no classes because traits has no superclass.
And the last one will return all classes and traits which uses given SomeTrait.

But my instance will behaves differently. For every class it will analyze both relationships: superclass and trait user. So every trait user will provide superclasses for the scope:

	ClyMultipleClassRelationScope of: SomeTrait merging: { ClySuperclassScope. ClyTraitUserScope }

From this scope you will see all classes and traits which uses given SomeTrait. But in addition it will show all superclasses of those classes and traits.

So idea behind me is to expand class visibility by multiple relationships. Every class retrieved from the basis will be recursivelly analyzed using all given relationships. 

Internal Representation and Key Implementation Points.

    Instance Variables
	relationScopeClasses:		<Collection of<ClySingleClassRelationScope class>>!
!ClyMultipleClassRelationScope methodsFor: 'accessing' stamp: ''!
relationScopeClasses: anObject
	relationScopeClasses := anObject! !

!ClyMultipleClassRelationScope methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^false ].
	
	^ relationScopeClasses = anObject relationScopeClasses! !

!ClyMultipleClassRelationScope methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: relationScopeClasses hash! !

!ClyMultipleClassRelationScope methodsFor: 'converting' stamp: ''!
asInterestingClassScope
	^self copy
		relationScopeClasses: (relationScopeClasses collect: [:each | each asInterestingClassScope])! !

!ClyMultipleClassRelationScope methodsFor: 'queries' stamp: ''!
classesRelatedTo: aClass do: aBlock
	relationScopeClasses do: [ :each | 
		each classesRelatedTo: aClass do: aBlock ]! !

!ClyMultipleClassRelationScope methodsFor: 'testing' stamp: ''!
representsScope: aScopeClass
	^(super representsScope: aScopeClass)
		or: [ relationScopeClasses anySatisfy: [ :each | each includesBehavior: aScopeClass ] ]! !

!ClyMultipleClassRelationScope methodsFor: 'accessing' stamp: ''!
relationScopeClasses
	^ relationScopeClasses! !

!ClyMultipleClassRelationScope class methodsFor: 'instance creation' stamp: ''!
of: basisObjects in: aNavigationEnvironment merging: singleRelationScopeClasses
	^(self ofAll: basisObjects in: aNavigationEnvironment)
		relationScopeClasses: singleRelationScopeClasses! !

!ClyMultipleClassRelationScope class methodsFor: 'instance creation' stamp: ''!
of: basisObjects merging: singleRelationScopeClasses
	^ (self ofAll: basisObjects)
		relationScopeClasses: singleRelationScopeClasses! !

!ClyMultipleClassRelationScopeTest methodsFor: 'running' stamp: ''!
multipleScopeSample
	| newScope |
	newScope := super multipleScopeSample.
	newScope relationScopeClasses: {ClySuperclassScope}.
	^newScope! !

!ClyMultipleClassRelationScopeTest methodsFor: 'running' stamp: ''!
singleScopeSample
	| newScope |
	newScope := super singleScopeSample.
	newScope relationScopeClasses: {ClySuperclassScope}.
	^newScope! !

!ClyMultipleClassRelationScopeTest methodsFor: 'tests' stamp: ''!
testRepresentsClassOfScope

	scope := ClyMultipleClassRelationScope of: #() merging: { ClySuperclassScope }.
	self assert: (scope representsScope: ClySuperclassScope).
	self assert: (scope representsScope: ClyMultipleClassRelationScope).
	self assert: (scope representsScope: ClyTypedScope).
	
	self deny: (scope representsScope: ClySubclassScope).
	self deny: (scope representsScope: ClyCompositeScope).! !

!ClyMultipleClassRelationScopeTest methodsFor: 'running' stamp: ''!
scopeClass
	^ClyMultipleClassRelationScope! !

!ClyMultipleClassRelationScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToInterestingClassScope
	| convertedScope |
	scope := ClyMultipleClassRelationScope of: {String} merging: {ClySuperclassScope . ClySubclassScope}.
	scope localScopeClass: ClyInstanceSideScope.

	convertedScope := scope asInterestingClassScope.

	self deny: convertedScope identicalTo: scope.
	self assert: convertedScope class equals: ClyMultipleClassRelationScope.
	self assert: convertedScope relationScopeClasses equals: {ClyInterestingSuperclassScope . ClySubclassScope}.
	self assert: convertedScope basisObjects equals: scope basisObjects.
	self assert: convertedScope localScopeClass equals: scope localScopeClass.
	self assert: convertedScope environment equals: scope environment! !

!ClyMultipleClassRelationScopeTest methodsFor: 'tests' stamp: ''!
testComparisonWithDifferentRelationScopes
	| scope2 |
	scope := ClyMultipleClassRelationScope of: #() merging: {ClySuperclassScope}.
	scope2 := ClyMultipleClassRelationScope of: #() merging: {ClySubclassScope}.

	self deny: scope equals: scope2! !

!ClyNavigateBrowserBackCommand commentStamp: ''!
I am a command to go back in the browser.
I move browser to previous navigation state.

By default I can be executed by alt+left shortcut!
!ClyNavigateBrowserBackCommand methodsFor: 'accessing' stamp: ''!
description
	^'go backward in the navigation history'! !

!ClyNavigateBrowserBackCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'go backward'! !

!ClyNavigateBrowserBackCommand methodsFor: 'execution' stamp: ''!
execute
	browser navigateBack! !

!ClyNavigateBrowserBackCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#back! !

!ClyNavigateBrowserBackCommand class methodsFor: 'accessing' stamp: ''!
defaultShortcut
	^Character arrowLeft alt! !

!ClyNavigateBrowserForwardCommand commentStamp: ''!
I am a command to go forward in the browser.
I move browser to the next navigation state which was recorded after go back operation.

By default I can be executed by alt+right shortcut!
!ClyNavigateBrowserForwardCommand methodsFor: 'accessing' stamp: ''!
description
	^'go forward in the navigation history'! !

!ClyNavigateBrowserForwardCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'go forward'! !

!ClyNavigateBrowserForwardCommand methodsFor: 'execution' stamp: ''!
execute
	browser navigateForward! !

!ClyNavigateBrowserForwardCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#forward! !

!ClyNavigateBrowserForwardCommand class methodsFor: 'accessing' stamp: ''!
defaultShortcut
	^Character arrowRight alt! !

!ClyNavigationEnvironment commentStamp: ''!
I am an environment allowing navigation over a particular system by quering objects from a particular scope of other objects. 
I cache query results and extend retrieved objects using the builtin plugin system.

My instances should be created over some system: 

	environment := ClyNavigationEnvironment over: aSystem

I do not impose any requirements on the class of the target system. It can be any object from the particular domain which represents its global view.
But Calypso requires two things which system should implement. It can define them as extensions in the Calypso integration package:

1) The system should provide a global scope which will adapt it to Calypso's navigation model. This scope will represent the root from which all objects in the system can be reached.
Concrete systems should implement a subclass of ClySystemScope and return an instance as the global scope of an actual system object. It should be returned from the system's #asGlobalScopeIn: method.
Users can access the system and its scope from my instance:
	
	environment system
	environment systemScope

2) The system should notify my instance about changes.
I maintain a query cache and it requires invalidation when the system is changed. So systems have the responsibility to subscribe and unsubscribe my instances for possible changes: 
	
	aSystem subscribe: environment
	aSystem unsubscribe: environment
	
I am subscribed when I am attaching to the system:
	
	environment attachToSystem
	
And I am unsubscribed when detaching: 

	environment detachFromSystem
	
User should manually attach my instances to the system when they are interested in updates.

I should not be subclassed. 

Users can maintain a singleton instance of me for a concrete system. It will provide a global cache for all queries over the given system.
For this purpose, I provide a class side variable defaultGlobalEnvironments. It maps a system instance to my instance (aNavigationEnvironment) over it.
The idea is that applications usually have a kind of default system instance (e.g. Smalltalk global). To provide default navigation over it, users can extend my class-side with an appropriate accessing method. 
For example, navigation over the current Smalltalk image is accessed using the #currentImage method: 

	ClyNavigationEnvironment class>>currentImage 	
		^self defaultOver: ClySystemEnvironment currentImage

The method #defaultOver: retrieves existing instance or creates new one. Such default instances are automatically attached to the system.
In this example the system is an instance of ClySystemEnvironment which represents Smalltalk system. (it was suitable to introduce extra wrapper for this domain. Look it comment for details).

To reset all global environments send #reset message to me: 

	ClyNavigationEnvironment reset
	
It will detach (unsubscribe) environments from their systems and clear collection.

I provide #query: method to execute queries using cache. But userrs should not use it directly.
Users should prepare scope instance using given environment:

	scope := ClyClassScope of: Object in: environment 

And then create and execute query instance: 

	query := ClyAllMethods from: scope.
	query execute

Underhood my #query: method is called by scope during query execution logic. I returns existing result if it exists. Otherwise I build new one.

There is another method which allow to check that given query will produce empty result:
	
	environment isQueryEmpty: query
	
It also should not be used directly. But query should be asked directly: 

	query hasEmptyResult

If there is existing result then I just check that it is not empty. Otherwise I ask query to #checkEmptyResult where it evaluates actual logic.

To maintain query cache I use two mutexes:

- accessGuard, protects any modification of queryCache
- updateGuard, protects cache updating in the way that multiple changes will be always processed in sequence

In my cache the query is a key and the result is a value. The cache is weak and unused result is cleaned by GC. In same time unused keys (queries which result is cleaned) are collected when new query is executed (using #cleanGarbageInCache).

I am extendable by plugins, subclasses of ClyEnvironmentPlugin. Plugins are responsible to extend queries of particular system in following ways:

- plugin can extend properties of query result (ClyBrowserItem instances and query metadata).
- plugin can supply information about other systems. 
Plugins are packaged separatelly. Plugin package can extend visibility of existing scopes by providing new information from external systems. This information can be retrieved by new queries.
And to manage this information plugin should notify environment about external changes.

To add plugin use following method:

	environment addPlugin: MyTestPlugin new.
	
And to access plugins use: 
	
	environment pluginsDo: aBlock
	
When I am attached to the system I also attach all my plugins to it using:

	plugin attachToSystem

In this method plugin is able to subscribe on own system changes to notify environment about them.
 
Internal Representation and Key Implementation Points.

    Instance Variables 
	plugins:		<Collection of<ClyEnvironmentPlugin>>>
	queryCache:		<WeakValueDictionary of<ClyQuery, ClyQueryResult>>
	system: 	<Object>
	updateStrategy:	<ClyEnvironmentUpdateStrategy>
	updateGuard:	<Mutex>
	accessGuard:	<Mutex>!
!ClyNavigationEnvironment methodsFor: 'cleaning' stamp: ''!
cleanGarbageInCache

	accessGuard critical: [ 
		queryCache clyCleanGarbage]! !

!ClyNavigationEnvironment methodsFor: 'accessing' stamp: ''!
getPlugin: environmentPluginClass
	^plugins detect: [ :each | each class = environmentPluginClass ]! !

!ClyNavigationEnvironment methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	accessGuard := Mutex new.
	updateGuard := Mutex new.
	plugins := OrderedCollection new.
	queryCache := WeakValueDictionary new.
	updateStrategy := ClyInstantEnvironmentUpdateStrategy new! !

!ClyNavigationEnvironment methodsFor: 'accessing' stamp: ''!
addPlugin: anEnvironmentPlugin
	plugins detect: [ :each | each class = anEnvironmentPlugin class ] ifFound: [ ^self ].
	
	anEnvironmentPlugin environment: self.
	plugins add: anEnvironmentPlugin! !

!ClyNavigationEnvironment methodsFor: 'converting' stamp: ''!
asRBEnvironment 
	^ self system environment! !

!ClyNavigationEnvironment methodsFor: 'accessing' stamp: ''!
plugins
	^plugins! !

!ClyNavigationEnvironment methodsFor: 'queries' stamp: ''!
query: aQuery

	| result |
	self cleanGarbageInCache.
	result := queryCache at: aQuery ifAbsent: [nil]. "cache is weak dict where ifAbsentPut: not works"
	result ifNil: [  
		result := aQuery prepareNewResult.
		aQuery fixStateBeforeExecution.
		"We should ensure that state of query will not be modified after execution 
		because it is the key in cache.
		So aQuery is supposed to become readonly object together with required internal state"
		accessGuard critical: [ queryCache at: aQuery put: result]].	
	result rebuildIfNeeded.
	^result! !

!ClyNavigationEnvironment methodsFor: 'queries' stamp: ''!
isQueryEmpty: aQuery
	| result |
	result := queryCache at: aQuery ifAbsent: [ nil ].	"cache is weak dict where ifAbsentPut: not works"
	result ifNotNil: [ 
		result isBuilt ifTrue: [ ^result isEmpty ]].
	^ aQuery checkEmptyResult! !

!ClyNavigationEnvironment methodsFor: 'accessing' stamp: ''!
queryCache
	^queryCache! !

!ClyNavigationEnvironment methodsFor: 'accessing' stamp: ''!
system: anObject
	system := anObject! !

!ClyNavigationEnvironment methodsFor: 'accessing' stamp: ''!
getPlugin: environmentPluginClass ifAbsent: absentBlock
	^plugins detect: [ :each | each class = environmentPluginClass ] ifNone: absentBlock! !

!ClyNavigationEnvironment methodsFor: 'accessing' stamp: ''!
cachedResultOf: aQuery

	^queryCache at: aQuery ifAbsent: [ nil ]! !

!ClyNavigationEnvironment methodsFor: 'initialization' stamp: ''!
setUpAvailablePlugins

	ClyEnvironmentPlugin allSubclasses 
		select: [ :each | each isAutoActivatedOn: self ]
		thenDo: [ :each | self addPlugin: each new ]! !

!ClyNavigationEnvironment methodsFor: 'accessing' stamp: ''!
system
	^ system! !

!ClyNavigationEnvironment methodsFor: 'system changes' stamp: ''!
announceChangesOf: aQueryResult
	
	updateStrategy announceChangesOf: aQueryResult! !

!ClyNavigationEnvironment methodsFor: 'system changes' stamp: ''!
systemChanged: aSystemAnnouncement

	self updateUsing: ClyFullEnvironmentUpdateStrategy new by: [
		self handleSystemChange: aSystemAnnouncement 
	]! !

!ClyNavigationEnvironment methodsFor: 'queries' stamp: ''!
systemScope
	^ system asGlobalScopeIn: self! !

!ClyNavigationEnvironment methodsFor: 'accessing' stamp: ''!
withCachedQueriesDo: aBlock

	queryCache select: [ :each | each notNil ] thenDo: aBlock! !

!ClyNavigationEnvironment methodsFor: 'system subscription' stamp: ''!
detachFromSystem
	system unsubscribe: self.
	plugins do: [ :each | each detachFromSystem ]! !

!ClyNavigationEnvironment methodsFor: 'queries' stamp: ''!
querySystemFor: aTypedQuery 
	aTypedQuery bindTo: self systemScope in: self.
	^aTypedQuery execute! !

!ClyNavigationEnvironment methodsFor: 'system changes' stamp: ''!
updateUsing: newUpdateStrategy by: updateBlock
	"here is special logic to break current mutex when any error is signalled.
	Without this logic fixing code inside spawned debugger will lead to deadlock
	because applying method changes will blocked at this accessGuard.
	Breaking mutex is done by creating new one which meand that current process
	is not guarded any more and proceeding execution in debugger can lead to some errors in rare cases. But it is less problem than locked UI"
	[
		updateGuard critical: [ | oldStrategy |
			oldStrategy := updateStrategy.
			[
				updateStrategy := newUpdateStrategy.
				updateBlock on: Error do: [ :err |
					updateStrategy := oldStrategy.
					updateGuard := Mutex new.
					err pass]
			] ensure: [ 
				updateStrategy == newUpdateStrategy ifTrue: [ 
					"In case of error another process can set up new strategy. 
					This condition will avoid possible collision"
					updateStrategy := oldStrategy ]]]
	] ensure: [ newUpdateStrategy publishCollectedChanges]! !

!ClyNavigationEnvironment methodsFor: 'system subscription' stamp: ''!
attachToSystem
	system subscribe: self.
	plugins do: [:each | each attachToSystem]! !

!ClyNavigationEnvironment methodsFor: 'system changes' stamp: ''!
handleSystemChange: aSystemAnnouncement

	| todoList todoSize anyResult |
	todoList := 	(queryCache values select: [ :each | each notNil ]) as: IdentitySet.
	todoSize := 0.
	[[todoSize = todoList size] whileFalse: [
		todoSize := todoList size.  
		todoList asArray do: [ :eachResult |
			(todoList includes: eachResult) ifTrue: [  
				eachResult handleSystemChange: aSystemAnnouncement byProcessingList: todoList]]].
	todoList notEmpty] whileTrue: [ 
		anyResult := todoList anyOne.
		anyResult handleSystemChange: aSystemAnnouncement.
		todoList remove: anyResult]! !

!ClyNavigationEnvironment methodsFor: 'accessing' stamp: ''!
pluginsDo: aBlock
	^plugins do: aBlock! !

!ClyNavigationEnvironment class methodsFor: '*Calypso-SystemQueries' stamp: ''!
currentImage
	^self defaultOver: ClySystemEnvironment currentImage! !

!ClyNavigationEnvironment class methodsFor: '*Calypso-SystemQueries' stamp: ''!
queryCurrentImageFor: aQuery
	^self currentImageScope query: aQuery! !

!ClyNavigationEnvironment class methodsFor: 'default' stamp: ''!
installNewPlugin: anEnvironmentPluginClass
	defaultGlobalEnvironments ifNil: [ ^self ].
	
	defaultGlobalEnvironments do: [ :each | 
		(anEnvironmentPluginClass isAutoActivatedOn: each)
			ifTrue: [ each addPlugin: anEnvironmentPluginClass new]]! !

!ClyNavigationEnvironment class methodsFor: 'default' stamp: ''!
defaultOver: aSystem
	defaultGlobalEnvironments ifNil: [ defaultGlobalEnvironments := IdentityDictionary new ].
	
	^defaultGlobalEnvironments at: aSystem ifAbsentPut: [ 
		(ClyNavigationEnvironment over: aSystem)
			setUpAvailablePlugins;
			attachToSystem ]! !

!ClyNavigationEnvironment class methodsFor: '*Calypso-SystemQueries' stamp: ''!
overSystemEnvironment: aSystemEnvironment
	^(self over: aSystemEnvironment)
		addPlugin: ClyDefaultSystemEnvironmentPlugin new! !

!ClyNavigationEnvironment class methodsFor: '*Calypso-SystemQueries' stamp: ''!
currentImageScope
	^self currentImage systemScope! !

!ClyNavigationEnvironment class methodsFor: 'instance creation' stamp: ''!
over: aSystem
	^self new 
		system: aSystem! !

!ClyNavigationEnvironment class methodsFor: 'class initialization' stamp: ''!
reset
	"It will reset all caches and unsubscribe from system environment"
	<script>
	defaultGlobalEnvironments ifNil: [ ^self ].
	defaultGlobalEnvironments do: #detachFromSystem.
	defaultGlobalEnvironments := nil! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testCheckEmptyQueryWhenThereIsNotEmptyResult

	| query result |
	query := self createQueryFromScopeOf: self class.
	result := environment query: query.
	self assert: result items notEmpty.
	
	self deny: (environment isQueryEmpty: query)! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testCheckEmptyQueryWhenThereIsNoResultButItWouldNotBeEmpty

	| query |
	query := self createQueryFromScopeOf: self class.
	
	self deny: (environment isQueryEmpty: query)! !

!ClyNavigationEnvironmentTest methodsFor: 'helpers' stamp: ''!
createQueryFromScopeOf: aBasisObject
	^ self createQueryFromScope: (ClyExampleScope of: aBasisObject)! !

!ClyNavigationEnvironmentTest methodsFor: 'helpers' stamp: ''!
createQueryFromScope: aScope
	aScope bindTo: environment.
	^ ClyReturningScopeBasisExampleQuery from: aScope! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testProcessingQueryCacheWhenSomeWasCollectedAsGarbage

	| evaluated |
	environment query: (self createQueryFromScopeOf: self class).
	Smalltalk garbageCollectMost; garbageCollectMost.
	
	evaluated := false.
	environment withCachedQueriesDo: [ :each | evaluated := true ].
	
	self deny: evaluated! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testQueryResultShouldBeCached
	| result1 result2 |
	result1 := environment query: (self createQueryFromScopeOf: self class).
	result2 := environment query: (self createQueryFromScopeOf: self class).

	self assert: result1 identicalTo: result2! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testMakeQueryOfResultAsReadOnlyObjectWhenItIsExecuted

	| query |
	query := self createQueryFromScopeOf: self class.
	environment query: query.
	
	self assert: query isReadOnlyObject! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testMakeQueryScopeOfResultAsReadOnlyObjectWhenItIsExecuted

	| query |
	query := self createQueryFromScopeOf: self class.
	environment query: query.
	
	self assert: query scope isReadOnlyObject! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testQueryExecutionShouldRemoveOldWeaklyGarbagedCache

	| result query |
	query := self createQueryFromScopeOf: self class.
	environment query: query.
	Smalltalk garbageCollectMost; garbageCollectMost.
	result := environment cachedResultOf: query.
	self assert: result equals: nil.
	
	result := environment query: (self createQueryFromScopeOf: self class superclass).
	self deny: (environment queryCache includesKey: query)! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testQueryExecutionWhenResultWasWeaklyCollectedAsGarbage
	| cache result result2 query |
	query := self createQueryFromScopeOf: self class.
	environment query: query.
	Smalltalk
		garbageCollectMost;
		garbageCollectMost.
	cache := environment cachedResultOf: query.
	self assert: cache equals: nil.

	result := environment query: query.
	self assert: result class equals: ClyRawQueryResult.
	result2 := environment query: query.
	self assert: result identicalTo: result2! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testCheckEmptyQueryWhenThereIsNoResultButItWouldBeEmpty

	| query |
	query := self createQueryFromScope: ClyExampleScope empty.
	
	self assert: (environment isQueryEmpty: query)! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testQueryCacheShouldBeWeak

	| cache query |
	query := self createQueryFromScopeOf: self class.
	environment query: query.	
	Smalltalk garbageCollectMost; garbageCollectMost.
	
	cache := environment cachedResultOf: query.
	self assert: cache equals: nil! !

!ClyNavigationEnvironmentTest methodsFor: 'tests' stamp: ''!
testCheckEmptyQueryWhenThereIsEmptyResult

	| query result |
	query := self createQueryFromScope: ClyExampleScope empty.
	result := environment query: query.
	self assert: result items isEmpty.
	
	self assert: (environment isQueryEmpty: query)! !

!ClyNavigationHistory commentStamp: ''!
I implement navigation history.
I maintain two lists: 
- redoList 
- undoList 
They include collection of ClyBrowserState instances.

To record new state send following message: 

	navigationHistory recordState: aBrowserState 

And to undo changes call: 

	navigationHistory undoNavigationOf: aBrowser 
	
To redo them call: 

	navigationHistory redoNavigationOf: aBrowser
	
When you undo last browser state it adds new item to the redo list. And otherwise: when you perform redo it adds new item to the undo list.
This logic is implemented using undoExecuting and redoExecuting flags.

I allow to ignore navigation during given block: 

	navigationHistory ignoreNavigationDuring: aBlock	

During given block execution the #recordState: method do nothing. It resets flag #waitingNewState to achive this.

You can always check that history is empty: 

	navigationHistory isEmpty

Important detail:
I am implemented in the way to not keep reference to the browser and any of query results.
So long history do not prevent query results in environment cache to be garbage collected.
 	
Internal Representation and Key Implementation Points.

    Instance Variables
	redoExecuting:		<Boolean>
	redoList:		<OrderedCollection of<ClyBrowserState>>
	undoExecuting:		<Boolean>
	undoList:		<OrderedCollection of<ClyBrowserState>>
	waitingNewState:		<Boolean>!
!ClyNavigationHistory methodsFor: 'accessing' stamp: ''!
redoList: anObject
	redoList := anObject! !

!ClyNavigationHistory methodsFor: 'testing' stamp: ''!
isEmpty
	^undoList isEmpty and: [redoList isEmpty]! !

!ClyNavigationHistory methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	undoExecuting := false.
	redoExecuting := false.
	waitingNewState := true.
	undoList := OrderedCollection new.
	redoList := OrderedCollection new! !

!ClyNavigationHistory methodsFor: 'operations' stamp: ''!
redoNavigationOf: aBrowser
	redoList ifEmpty: [ ^self ].
	
	self executeRedoBy: [ 
		self restoreNavigationState: redoList removeLast of: aBrowser]! !

!ClyNavigationHistory methodsFor: 'private' stamp: ''!
restoreNavigationState: aBrowserState of: aBrowser

	aBrowserState applyTo: aBrowser byUndo: undoExecuting! !

!ClyNavigationHistory methodsFor: 'operations' stamp: ''!
recordAcrossWindowNavigationFrom: aBrowser byUndo: isUndoOperation

	| returnState |
	returnState := ClyAccrossWindowNavigationState from: aBrowser.
	isUndoOperation 
		ifTrue: [ self executeUndoBy: [ self recordState: returnState ] ]
		ifFalse: [ self executeRedoBy: [ self recordState: returnState ] ]! !

!ClyNavigationHistory methodsFor: 'operations' stamp: ''!
undoNavigationOf: aBrowser
	undoList ifEmpty: [ ^self ].
	
	self executeUndoBy: [ 
		self restoreNavigationState: undoList removeLast of: aBrowser ]! !

!ClyNavigationHistory methodsFor: 'private' stamp: ''!
executeUndoBy: aBlock
	undoExecuting := true.
	aBlock ensure: [ undoExecuting := false. waitingNewState := true ]! !

!ClyNavigationHistory methodsFor: 'accessing' stamp: ''!
undoList
	^ undoList! !

!ClyNavigationHistory methodsFor: 'operations' stamp: ''!
clear

	undoList removeAll.
	redoList removeAll! !

!ClyNavigationHistory methodsFor: 'operations' stamp: ''!
recordState: aBrowserState
	aBrowserState representsConcreteQuery ifFalse: [ ^self ]. 
	waitingNewState ifFalse: [ ^self ].
	
	undoExecuting | redoExecuting ifTrue: [ 
		"During undo or redo system can trigger multiple navigation changes.
		waitingNewState flag here is to address this case. We need to track only first change"
		waitingNewState := false ].
	
	undoExecuting 
		ifTrue: [ redoList add: aBrowserState ]
		ifFalse: [ 
			redoExecuting ifFalse: [ redoList removeAll].
			undoList add: aBrowserState ]! !

!ClyNavigationHistory methodsFor: 'operations' stamp: ''!
ignoreNavigationDuring: aBlock
	waitingNewState := false.
	aBlock ensure: [ waitingNewState := true ]! !

!ClyNavigationHistory methodsFor: 'accessing' stamp: ''!
redoList
	^ redoList! !

!ClyNavigationHistory methodsFor: 'private' stamp: ''!
executeRedoBy: aBlock
	redoExecuting := true.
	aBlock ensure: [ redoExecuting := false. waitingNewState := true ]! !

!ClyNavigationHistory methodsFor: 'accessing' stamp: ''!
undoList: anObject
	undoList := anObject! !

!ClyNavigationHistoryTest methodsFor: 'running' stamp: ''!
snapshotState
	self subclassResponsibility! !

!ClyNavigationHistoryTest methodsFor: 'running' stamp: ''!
createBrowser
	^ClyFullBrowserMorph new! !

!ClyNavigationHistoryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	environment := ClyNavigationEnvironment overSystemEnvironment: ClySystemEnvironment currentImage.
	environment detachFromSystem "to ensure no subscriptions".
	
	browser := self createBrowser.
	browser navigationEnvironment: environment.
	browser plugins removeAll.! !

!ClyNavigationHistoryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyNavigationHistoryTest! !

!ClyNoCommentTag commentStamp: ''!
I am used to mark classes which has no comment!
!ClyNoTagClassGroup commentStamp: ''!
I represent group of classes which does not marked by any tag.

I provide simple method to tag all my classes:

	aGroup renameClassTagTo: aSymbol
	
It is polymorphic to ClyTaggedClassGroup which performs actual tag renaming.

My class query is ClyRestUntaggedClasses !
!ClyNoTagClassGroup methodsFor: 'operations' stamp: ''!
importClass: aClass
	| newPackages |
	super importClass: aClass.
	newPackages := OrderedCollection new.
	classQuery scope packagesDo: [ :each | 
		each = aClass package ifFalse: [ newPackages add: each ]].
	newPackages size > 1 ifTrue: [ ^self error: 'You should select single package for import!!' ].
	
	newPackages ifNotEmpty: [ ^newPackages first addClass: aClass ].
	aClass tags do: [:eachTag | aClass untagFrom: eachTag ]! !

!ClyNoTagClassGroup methodsFor: 'operations' stamp: ''!
renameClassTagTo: newTag
	
	self classes do: [ :each | each tagWith: newTag]! !

!ClyNoTagClassGroup class methodsFor: 'accessing' stamp: ''!
priority
	^10! !

!ClyNoTagClassGroup class methodsFor: 'testing' stamp: ''!
isBasedOnClassTag
	^true! !

!ClyNoTagClassGroupProvider commentStamp: ''!
I provide "Uncategorized" class group when there are class tags in the package but in same time there are classes without tags.

When package has no tags at all I do not provide any group.!
!ClyNoTagClassGroupProvider methodsFor: 'building groups' stamp: ''!
createClassQueryFrom: aPackageScope
	^ClyRestUntaggedClassesQuery from: aPackageScope! !

!ClyNoTagClassGroupProvider methodsFor: 'building groups' stamp: ''!
createClassGroupFor: aClassQuery from: aPackageScope
	^ClyNoTagClassGroup named: 'Uncategorized' priority: 100 on: aClassQuery! !

!ClyNoTagClassGroupProviderTest methodsFor: 'running' stamp: ''!
packageSampleWhichHasGroup
	^ClyClass6UntaggedFromP5Mock package "P5WithTags"! !

!ClyNoTagClassGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyNoTagClassGroupProvider! !

!ClyNoTagMethodGroup commentStamp: ''!
I am group of unclassified methods. I include only methods without any tag!
!ClyNoTagMethodGroup methodsFor: 'operations' stamp: ''!
renameMethodTagTo: newTag
	
	self methods do: [ :each | each tagWith: newTag]! !

!ClyNoTagMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethodsFrom: aMethodQuery

	^self named: self groupName on: aMethodQuery! !

!ClyNoTagMethodGroup class methodsFor: 'accessing' stamp: ''!
groupName
	^'as yet unclassified'! !

!ClyNoTagMethodGroup class methodsFor: 'accessing' stamp: ''!
priority
	^8! !

!ClyNoTagMethodGroup class methodsFor: 'testing' stamp: ''!
isBasedOnMethodTag
	^true! !

!ClyNotRemoveAndShowReferencesClassStrategy commentStamp: ''!
I am the strategy to be used when a class can't be removed due to the presence of references.

I allow the user to browse those references.!
!ClyNotRemoveAndShowReferencesClassStrategy methodsFor: 'execution' stamp: ''!
orderForBrowser
	^5! !

!ClyNotRemoveAndShowReferencesClassStrategy methodsFor: 'execution' stamp: ''!
execute: aSycRemoveClassCommand

	(ClyShowClassRefCommand forClasses: (aSycRemoveClassCommand classes flatCollect: [ :each | { each. each class } ]) by: browser) execute! !

!ClyNotRemoveAndShowReferencesClassStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	^'Don''t remove, but show me those references'! !

!ClyNotRemoveAndShowReferencesClassStrategy class methodsFor: 'testing' stamp: ''!
canExecuteWithReferences: hasReferences subclasses: hasSubclasses users: hasUsers
	^hasReferences! !

!ClyNotRemoveAndShowReferencesClassStrategyTest commentStamp: ''!
A ClyNotRemoveAndShowReferencesClassStrategyTest is a test class for testing the behavior of ClyNotRemoveAndShowReferencesClassStrategy!
!ClyNotRemoveAndShowReferencesClassStrategyTest methodsFor: 'tests' stamp: ''!
testExecutingCommand
	| browser command strategy |
	browser := ClyBrowserMock new.
	strategy := ClyNotRemoveAndShowReferencesClassStrategy newForBrowser: browser.
	command := SycRemoveClassCommand for: { SycRemoveClassCommand }.
	strategy execute: command.
	self assert: browser hasSpawnedQueryBrowser! !

!ClyNotRemoveAndShowSendersMethodStrategy commentStamp: ''!
I am a remove method strategy which do not remove methods but instead it shows all senders.!
!ClyNotRemoveAndShowSendersMethodStrategy methodsFor: 'accessing' stamp: ''!
orderForBrowser
	^3! !

!ClyNotRemoveAndShowSendersMethodStrategy methodsFor: 'execution' stamp: ''!
removeMethods: methods
	
	(ClyShowMessageSenderCommand forMethods: methods by: browser) execute! !

!ClyNotRemoveAndShowSendersMethodStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	^'Don''t remove, but show me those senders'! !

!ClyNotRemoveAndShowSubclassesClassStrategy commentStamp: ''!
I am the strategy to be used when a class can't be removed due to the presence of subclasses.

I allow the user to browse those subclasses.!
!ClyNotRemoveAndShowSubclassesClassStrategy methodsFor: 'execution' stamp: ''!
orderForBrowser
	^6! !

!ClyNotRemoveAndShowSubclassesClassStrategy methodsFor: 'execution' stamp: ''!
execute: aSycRemoveClassCommand
	| subclasses |
	subclasses := (aSycRemoveClassCommand classes flatCollect: [:each | each subclasses])
						copyWithoutAll: aSycRemoveClassCommand classes.
	browser spawnQueryBrowserOn: (ClyConstantQuery returning: subclasses)! !

!ClyNotRemoveAndShowSubclassesClassStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	^'Don''t remove, but show me those subclasses'! !

!ClyNotRemoveAndShowSubclassesClassStrategy class methodsFor: 'testing' stamp: ''!
canExecuteWithReferences: hasReferences subclasses: hasSubclasses users: hasUsers
	^hasSubclasses! !

!ClyNotRemoveAndShowSubclassesClassStrategyTest commentStamp: ''!
A ClyNotRemoveAndShowSubclassesClassStrategyTest is a test class for testing the behavior of ClyNotRemoveAndShowSubclassesClassStrategy!
!ClyNotRemoveAndShowSubclassesClassStrategyTest methodsFor: 'tests' stamp: ''!
testExecutingCommand
	| browser command strategy |
	browser := ClyBrowserMock new.
	strategy := ClyNotRemoveAndShowSubclassesClassStrategy newForBrowser: browser.
	command := SycRemoveClassCommand for: { ClyInteractiveRemoveClassStrategy }.
	strategy execute: command.
	self assert: (browser hasSpawnedQueryBrowserOn: ClyInteractiveRemoveClassStrategy allSubclasses)! !

!ClyNotRemoveAndShowUsersClassStrategy commentStamp: ''!
I am the strategy to be used when a trait can't be removed due to the presence of users.

I allow the user to browse those trait users.!
!ClyNotRemoveAndShowUsersClassStrategy methodsFor: 'execution' stamp: ''!
orderForBrowser
	^7! !

!ClyNotRemoveAndShowUsersClassStrategy methodsFor: 'execution' stamp: ''!
execute: aSycRemoveClassCommand
	| users |
	users := (aSycRemoveClassCommand classes flatCollect: [:each | each users])
						copyWithoutAll: aSycRemoveClassCommand classes.
	browser spawnQueryBrowserOn: (ClyConstantQuery returning: users)! !

!ClyNotRemoveAndShowUsersClassStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	^'Don''t remove, but show me those users'! !

!ClyNotRemoveAndShowUsersClassStrategy class methodsFor: 'testing' stamp: ''!
canExecuteWithReferences: hasReferences subclasses: hasSubclasses users: hasUsers
	^hasUsers! !

!ClyNotRemoveAndShowUsersClassStrategyTest commentStamp: ''!
A ClyNotRemoveAndShowUsersClassStrategyTest is a test class for testing the behavior of ClyNotRemoveAndShowUsersClassStrategy!
!ClyNotRemoveAndShowUsersClassStrategyTest methodsFor: 'tests' stamp: ''!
testExecutingCommand
	| browser command strategy |
	browser := ClyBrowserMock new.
	strategy := ClyNotRemoveAndShowUsersClassStrategy newForBrowser: browser.
	command := SycRemoveClassCommand for: { TRBProgramNodeVisitor }.
	strategy execute: command.
	self assert: (browser hasSpawnedQueryBrowserOn: TRBProgramNodeVisitor users)! !

!ClyNotebookManager commentStamp: ''!
I manage tabs in the browser.
Any tab in browser is represented by ClyBrowserTool subclasses.
And my responsibility is to show all appropriate tools which are relevant to the current browser context (state). 
`#updateTools` method is doing that. 

The logic is simple: 
When selection (browser context) is changed then browser collects new tools which should be opened in that new browser state. 
Then it removes all old tools and open all new tools. 
But there is special case when new collected tool is already opened. In that case such new tool will be not used. And existing tool will be not removed. So it will stay opened.

I use `#isSimilarTo:` tab method to detect that new collected tool is already opened (the browser already shows similar tool).
By default #isSimilarTo: simply checks the class of given tool. My subclases should redefine it when they include extra state because otherwise new tool instance will never replace old one (browser will think that it is already opened).

There are cases when existing tools are not closed when selection is changed. For example when method editor is dirty and you select another method.
In that case dirty method will indicate that it is now do not belongs to the context of browser.
Tools implement method #belongsToCurrentBrowserContext to support this logic.
For example method editor checks that browser still selects editing method.

There is one complex part of my behaviour: the way how I choose what tab should be selected.
In simple cases I just select the tab with lagest value of #activationPriority. But it is not enough.
Problem that user want to keep current selected tab (the kind of tab) when he selects another item in the table.
For example in full browser user can select class. It will automatically selects the tab with class definition because it has the most activation priority.
But then user can select class comment tab and switch to another class. The desired behaviour is to keep comment tab selected for this newly selected class.

And for this logic I maintain desired set of selected tool in the variable desiredSelection.
It adds and removes items when user manually selects tabs.
But in addition browser fills it with tools which are relevant for manually selected table.
Every time user selects new item in the table the browser collects tools which are relevant for this new selection and it passes them to me as new desired selection. 

So at the end I always select tab with most activation priority which exists in desiredSelection list.

By default activationPriority is equal to `#tabOrder` which defines general order between tabs.

My instances are created on the browser: 

```
	ClyTabManager of: aBrowser
```	!
!ClyNotebookManager methodsFor: 'updating' stamp: ''!
updateTools

	self updateToolsBy: [ 
		self basicUpdateTools ]! !

!ClyNotebookManager methodsFor: 'focus management' stamp: ''!
focusActiveTab
	| activeTool |

	activeTool := self selectedTools detectMax: [ :each | 
		self activationPriorityOf: each ].
		
	activeTool ifNotNil: [ tabMorph page: activeTool containerTab ]! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
tabOrderOf: anObject

	^ anObject model 
		ifNotNil: [ :model | model tabOrder ] 
		ifNil: [ 0 ]! !

!ClyNotebookManager methodsFor: 'updating' stamp: ''!
updateTabsWith: newTools
	| toRemove toInstall |

	toRemove := OrderedCollection withAll: tools.
	toInstall := OrderedCollection new.
	newTools do: [ :new | 
		tools 
			detect: [ :existing | existing isSimilarTo: new ]
			ifFound: [ :existing | toRemove remove: existing ]
			ifNone: [ toInstall add: new ] ].

	"We need to install the new tabs before removing the old ones.
	Because removing the old ones force to generate the content of the existing ones.
	Even the ones we are going to remove"
	toInstall do: [ :each | self addTool: each ].
	toRemove 
		reject: [ :each | each wantsStayInDifferentContext ]
		thenDo: [ :each | self removeTool: each ].
	tools do: [ :each | each browserContextWasChanged ].! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
updateToolsBy: aBlock
	updatingStarted := true.
	aBlock ensure: [ updatingStarted := false ]! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
restoreSelectedTools: selectedTools
	| mainTool extraTools |

	tools ifEmpty: [ ^ self ].
	mainTool := self selectMainTool.
	
	extraTools := selectedTools reject: [ :each | each class = mainTool class ].
	extraTools size = selectedTools size 
		ifTrue: [ extraTools := #() ] "if main tool not existed before then we reset previously selected extra tools"
		ifFalse: [ 
			"To allow multiple selected tabs by cmd+click on table"
			mainTool isExtraSelectionRequested 
				ifTrue: [ extraTools := extraTools copyWith: mainTool ] ].
	(tools copyWithout: mainTool) do: [ :currentTool | 
		"Generally if previously selected extra tab is found in new tools then it should be selected.
		Other tools should be deselected"
		extraTools 
			detect: [ :oldTool | oldTool class = currentTool class  ]
			ifFound: [ self restoreSelectionOfExtraTool: currentTool ]
			ifNone: [ "currentTool deselectTab" ] ].
		
	extraTools ifNotEmpty: [ 
		"last selected tab is looks different from others. We want main tool looks like last selected tab"
		mainTool deselectTab.
		mainTool selectAsExtraTab ].

	"mainTool waitBuildCompletion" "to avoid blinking we try to wait a little bit until mainly selected tab wiull be build. When it is built fast it will look like no background building was happen"! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
closeTab: tab
	
	tab model okToClose ifFalse: [ ^ self ].
	self tabMorph removePage: tab.
	self tabDeleted: tab! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
activationPriorityOf: aBrowserTool
	| priority |

	aBrowserTool belongsToCurrentBrowserContext 
		ifFalse: [ ^ aBrowserTool activationPriorityInNonActiveContext ].
	
	priority := self overridenPriorityOf: aBrowserTool.
	^ (desiredSelection includes: aBrowserTool class)
		ifTrue: [ priority * 1000 ]
		ifFalse: [ priority ]! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
buildToolsOn: toolsList for: aBrowserContext
	| tool |
	ClyTabActivationStrategyAnnotation 
		activeInstancesInContext: aBrowserContext
		do: [ :strategy | 
			tool := strategy createToolFor: browser inContext: aBrowserContext.
			browser decorateTool: tool.
			toolsList add: tool ]! !

!ClyNotebookManager methodsFor: 'event handling' stamp: ''!
okToChange

	(tools anySatisfy: #hasUnacceptedEdits) ifFalse: [ ^ true ].
	^browser confirmDiscardChanges! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
skipCurrentDesiredSelection
	shouldSkipCurrentDesiredSelection := true! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
shouldSkipCurrentDesiredSelection: anObject
	shouldSkipCurrentDesiredSelection := anObject! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
restoreSelectionOfExtraTool: aBrowserTool
	
	aBrowserTool hasUnacceptedEdits ifFalse: [ aBrowserTool selectAsExtraTab. ^self ].
	
	(self countToolsSimilarTo: aBrowserTool) = 1
		ifTrue: [ aBrowserTool selectAsExtraTab ]
		ifFalse: [aBrowserTool deselectTab]! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
shouldSkipCurrentDesiredSelection
	^ shouldSkipCurrentDesiredSelection! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
tabMorph

	^ tabMorph! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
swapPrioritiesBetween: aTool1 and: aTool2
	| priority1 priority2 |
	
	aTool1 allowsDifferentActivationPriority ifFalse: [ ^self ].
	aTool2 allowsDifferentActivationPriority ifFalse: [ ^self ].
	
	priority1 := self overridenPriorityOf: aTool1.
	priority2 := self overridenPriorityOf: aTool2.	
	selectionPriorities at: aTool1 class put: priority2.
	selectionPriorities at: aTool2 class put: priority1.! !

!ClyNotebookManager methodsFor: 'updating' stamp: ''!
basicUpdateTools
		| newTools needsNewSelection selectedTools currentTools |
		newTools := OrderedCollection new.	
		browser navigationContextsDo: [ :each | self buildToolsOn: newTools for: each].
		needsNewSelection := self requiresNewDesiredSelection.
		selectedTools := self selectedTools.
		currentTools := tools copy.

		self updateTabsWith: newTools.
		(needsNewSelection or: [ tools ~= currentTools ]) 
			ifTrue: [ self restoreSelectedTools: selectedTools].! !

!ClyNotebookManager methodsFor: 'updating' stamp: ''!
restoreBrowserState: aBrowserState
	| existingTools |
	"Browser state do only hold selected tabs. 
	So first we should restore all tools in new context and then restore selection"
	self updateTools.
	
	existingTools := aBrowserState selectedTabs
		collect: [ :oldTool | tools detect: [ :each | each isSimilarTo: oldTool ] ifNone: [ nil ] ]
		thenSelect: #notNil.
		
	existingTools ifEmpty: [ ^ self ].
	self tabMorph page: existingTools first.
	existingTools allButFirstDo: [ :each | each selectAsExtraTab ]! !

!ClyNotebookManager methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	tools := SortedCollection sortBlock: [ :a :b | a tabOrder <= b tabOrder ].
	selectionPriorities := IdentityDictionary new.
	desiredSelection := IdentitySet new.
	shouldSkipCurrentDesiredSelection := false.
	updatingStarted := false.
	tabMorph := ClyNotebookMorph new.
	tabMorph useSortedTabsBy: [ :a :b | (self tabOrderOf: a) <= (self tabOrderOf: b) ].
	tabMorph announcer
		when: SpNotebookPageChanged 
		send: #pageChanged: 
		to: self.
	tabMorph 
		hResizing: #spaceFill;
		vResizing: #spaceFill! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
tools: anObject
	tools := anObject! !

!ClyNotebookManager methodsFor: 'updating' stamp: ''!
updateToolsForChangedEnvironment
	| currentState |
	currentState := OrderedCollection new: tools size.
	tools do: [ :each | 
		currentState add: each -> each isManagedByUser.
		each isManagedByUser: true].
	
	self updateTools.
	
	currentState do: [ :each | each key isManagedByUser: each value ]! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
addTool: aBrowserTool
	| tab |
	
	tools add: aBrowserTool.
	"tab build is performed in background when owner is not exist yet. But we need proper width to perform kind of styling/formatting for tool if needed"
	aBrowserTool width: tabMorph width.
	tab := aBrowserTool addNotebookPageOn: tabMorph.
	tab 
		onClose: [ self closeTab: tab ];
		onDoubleClick: [ browser toggleFullWindowTabs ]! !

!ClyNotebookManager methodsFor: 'event handling' stamp: ''!
windowIsClosing

	tools do: [ :each | each cleanAfterRemove ]! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
desiredSelection: toolClasses
	| currentSelection |

	desiredSelection := toolClasses asIdentitySet.
	shouldSkipCurrentDesiredSelection ifFalse: [ 
		currentSelection := self selectedTools collect: [ :each | each class ].
		desiredSelection addAll: currentSelection ].
	shouldSkipCurrentDesiredSelection := false "it is one time option"! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
tabDeleted: aTab
	| removedTool |

	removedTool := aTab model.
	(tools includes: removedTool) ifFalse: [ ^ self ].
	tools remove: removedTool.
	removedTool cleanAfterRemove! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
overridenPriorityOf: aBrowserTool
	
	^selectionPriorities at: aBrowserTool class ifAbsent: [ aBrowserTool activationPriority  ]! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
desiredSelection
	^ desiredSelection! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
removeTool: aTool

	self flag: #TODO. "Why sometimes is not there?"
	(tabMorph pages includes: aTool containerTab)
		ifTrue: [ tabMorph removePage: aTool containerTab ].
	self tabDeleted: aTool containerTab! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
pageChanged: ann
	| selectedTool oldSelectedTools browserState |
	
	updatingStarted ifTrue: [ ^ self ].
	selectedTool := ann page model.
	oldSelectedTools := ann oldPage model 
		ifNotNil: [ :aTool | { aTool } ] 
		ifNil: [ #() ].
	"happens somehow during tabs rebuild".
	(tools includes: selectedTool) ifFalse: [ ^ self ]. 
	
	oldSelectedTools ifEmpty: [ ^ self ].
	desiredSelection removeAll.
	browserState := browser snapshotState.
	browserState selectedTabs: oldSelectedTools.
	browser recordNavigationState: browserState.
	
	self 
		swapPrioritiesBetween: selectedTool
		and: oldSelectedTools first! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
selectMainTool
	| desiredTools mainTool |
	
	desiredTools := tools select: [ :each | desiredSelection includes: each class ].
	desiredTools ifEmpty: [ desiredTools := tools ].

	mainTool := desiredTools detectMax: [ :each | 
		self activationPriorityOf: each ].
	
	tabMorph page: mainTool containerTab.
	
	^ mainTool! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
selectedTools

	^ tabMorph page
		ifNotNil: [ :aPage | { aPage } ]
		ifNil: [ #() ]! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
countToolsSimilarTo: aBrowserTool

	^ tools count: [ :each | each class = aBrowserTool class ]! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
withTool: aToolClass do: aBlock
	| tool |
	tool := tools detect: [ :each | each isKindOf: aToolClass ].
	^ tool whenReadyDo: aBlock! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
activeStatusBar

	^ self selectedTools first statusBar! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
tools
	^ tools! !

!ClyNotebookManager methodsFor: 'testing' stamp: ''!
requiresNewDesiredSelection
	desiredSelection ifEmpty: [ ^false ].
	
	^(self selectedTools allSatisfy: [ :each | desiredSelection includes: each class]) not! !

!ClyNotebookManager methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!ClyNotebookManager methodsFor: 'private' stamp: ''!
selectsTools: toolsArray
	
	| selectedTools |
	selectedTools := self selectedTools.
	selectedTools size = toolsArray size ifFalse: [ ^false ].
	
	^selectedTools allSatisfy: [ :existingTool | 
		toolsArray anySatisfy: [ :each | existingTool isSimilarTo: each ]]! !

!ClyNotebookManager class methodsFor: 'instance creation' stamp: ''!
of: aBrowser
	^self new 
		browser: aBrowser! !

!ClyNotebookMorph commentStamp: ''!
I extend a notebook by adding sortable capabilities.
!
!ClyNotebookMorph methodsFor: 'adding-removing' stamp: ''!
addToSelection: aPage 

	self selectedPageIndex: (pageMorphs indexOf: aPage)! !

!ClyNotebookMorph methodsFor: 'initialization' stamp: ''!
initialize

	toolbarMorph := self newToolbarMorph.
	super initialize! !

!ClyNotebookMorph methodsFor: 'private' stamp: ''!
postAddPage: aPage

	self addActions: aPage actions! !

!ClyNotebookMorph methodsFor: 'adding-removing' stamp: ''!
removeFromSelection: aPage 

	self selectedPageIndex = (pageMorphs indexOf: aPage)
		ifTrue: [ self selectedPageIndex: 0 ].! !

!ClyNotebookMorph methodsFor: 'private' stamp: ''!
newToolbarMorph

	^ SpNotebookPanelMorph new
		fillStyle: (SolidFillStyle color: self theme baseColor);
		borderWidth: 2;
		borderColor: self theme baseColor;
		vResizing: #spaceFill;
		hResizing: #shrinkWrap;
		cellPositioning: #center;
		changeTableLayout;
		listDirection:#leftToRight;
		cellInset: 4;
		yourself! !

!ClyNotebookMorph methodsFor: 'theme' stamp: ''!
themeChanged

	super themeChanged.
	self toolbarMorph 
		fillStyle: (SolidFillStyle color: self theme baseColor);
		borderColor: self theme baseColor.
	self tabSelectorMorph
		color: self theme baseColor.
	self pages do: [ :each | each themeChanged ]! !

!ClyNotebookMorph methodsFor: 'accessing' stamp: ''!
addPage: aMorph label: aStringOrMorph
	"Add a page and its tab."
	| index |
	aMorph
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	self pages add: aMorph.
	aMorph privateOwner: self.
	
	index := self pages indexOf: aMorph.
	self tabSelectorMorph addTab: aStringOrMorph beforeIndex: index! !

!ClyNotebookMorph methodsFor: 'accessing' stamp: ''!
addActions: aCollection

	self toolbarMorph 
		removeAllMorphs;
		addAllMorphs: aCollection! !

!ClyNotebookMorph methodsFor: 'accessing' stamp: ''!
useSortedTabsBy: aBlock 
	
	self pageMorphs: (SortedCollection sortBlock: aBlock)! !

!ClyNotebookMorph methodsFor: 'factory' stamp: ''!
newTabSelectorMorph

	^ super newTabSelectorMorph
		color: self theme baseColor;
		yourself! !

!ClyNotebookMorph methodsFor: 'private' stamp: ''!
newHeaderMorph

	^ (self theme newRowIn: self theme for: { self tabSelectorMorph. self toolbarMorph }) 
		cellInset: 0; 
		cellPositioning: #bottomCenter; 
		borderWidth: 0! !

!ClyNotebookMorph methodsFor: 'accessing' stamp: ''!
toolbarMorph

	^ toolbarMorph! !

!ClyNotebookPageAction commentStamp: ''!
I am a data object representing an action associated to a page.
I contains
	- an action to be performed when clicked
	- an icon to be rendered
	- a label to add indication about what I am supposed to do!
!ClyNotebookPageAction methodsFor: 'accessing' stamp: ''!
action: anObject

	action := anObject.
	icon on: #click send: #value to: action! !

!ClyNotebookPageAction methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	icon := ImageMorph new! !

!ClyNotebookPageAction methodsFor: 'accessing' stamp: ''!
label: aLabel

	label := aLabel.
	icon setBalloonText: label maxLineLength: 100! !

!ClyNotebookPageAction methodsFor: 'accessing' stamp: ''!
action
	^ action! !

!ClyNotebookPageAction methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!ClyNotebookPageAction methodsFor: 'accessing' stamp: ''!
icon: aForm

	icon image: aForm.
	label 
		ifNotNil: [ icon setBalloonText: label maxLineLength: 100 ].
	action ifNotNil: [ icon on: #click send: #value to: action ]! !

!ClyNotebookPageAction methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!ClyNotebookPageAction class methodsFor: 'instance creation' stamp: ''!
action: action icon: icon label: label

	^ self new
		action: action;
		icon: icon;
		label: label;
		yourself! !

!ClyNotebookPageActionButtonMorph commentStamp: ''!
I am a multi state button supporting icon.
I am used to render page actions.!
!ClyNotebookPageActionButtonMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas

	super drawOn: aCanvas.
	icon ifNil: [ ^ self ].
	icon form ifNil: [ ^ self ].
	aCanvas
		translucentImage: icon form
		at: self topLeft! !

!ClyNotebookPageActionButtonMorph methodsFor: 'theme' stamp: ''!
themeChanged
	| baseColor |

	super themeChanged.

	baseColor := self theme baseColor.
	self activeDisabledNotOverUpFillStyle: (self theme buttonDisabledFillStyleFor: self).
	self activeEnabledNotOverUpFillStyle: baseColor.
	self passiveEnabledNotOverUpFillStyle: baseColor.
	self passiveDisabledNotOverUpFillStyle: baseColor.
	self
		activeEnabledOverUpFillStyle: (self theme buttonMouseOverFillStyleFor: self);
		passiveEnabledOverUpFillStyle: (self theme buttonMouseOverFillStyleFor: self);
		activeEnabledOverDownFillStyle: (self theme buttonPressedFillStyleFor: self);
		passiveEnabledOverDownFillStyle: (self theme buttonPressedFillStyleFor: self)! !

!ClyNotebookPageActionButtonMorph methodsFor: 'instance creation' stamp: ''!
forAction: anAction
	| baseColor |
	
	baseColor := self theme baseColor.
	self extent: anAction icon extent.
	
	self activeEnabledNotOverUpFillStyle: baseColor.
	
	self activeDisabledNotOverUpFillStyle: (self theme buttonDisabledFillStyleFor: self).
	self passiveEnabledNotOverUpFillStyle: baseColor.
	self passiveDisabledNotOverUpFillStyle: baseColor.
	
	self
		activeEnabledOverUpFillStyle: (self theme buttonMouseOverFillStyleFor: self);
		passiveEnabledOverUpFillStyle: (self theme buttonMouseOverFillStyleFor: self).
	
	self
		activeEnabledOverDownFillStyle: (self theme buttonPressedFillStyleFor: self);
		passiveEnabledOverDownFillStyle: (self theme buttonPressedFillStyleFor: self);
		addUpAction: [ anAction action value ];
		setBalloonText: anAction label;
		extent: 16@16.
		
	icon := anAction icon.
		
	^ self! !

!ClyNotebookPageActionButtonMorph methodsFor: 'accessing' stamp: ''!
icon: anObject
	
	icon := anObject! !

!ClyNotebookPageActionButtonMorph class methodsFor: 'instance creation' stamp: ''!
forAction: anAction

	^ self new
		forAction: anAction;
		yourself! !

!ClyNotebookPageHeaderPresenter methodsFor: 'event processing' stamp: ''!
doClose

	closeAction ifNil: [ ^ self ].
	closeAction cull: self! !

!ClyNotebookPageHeaderPresenter methodsFor: 'event handling' stamp: ''!
onDoubleClick: aBlock 

	doubleClickAction := aBlock! !

!ClyNotebookPageHeaderPresenter methodsFor: 'event processing' stamp: ''!
doDoubleClick

	doubleClickAction ifNil: [ ^ self ].
	doubleClickAction cull: self! !

!ClyNotebookPageHeaderPresenter methodsFor: 'initialization' stamp: ''!
updatePresenter

	iconImage image: pageMorph icon.
	titleLabel label: pageMorph label.
	pageMorph isCloseable
		ifTrue: [ closeImage show ]
		ifFalse: [ closeImage hide ]! !

!ClyNotebookPageHeaderPresenter methodsFor: 'event processing' stamp: ''!
mouseDown: event 

	"bubble up"
	self adapter widget owner eventHandler 
		mouseDown: event 
		fromMorph: self adapter widget owner! !

!ClyNotebookPageHeaderPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aPageMorph

	pageMorph := aPageMorph! !

!ClyNotebookPageHeaderPresenter methodsFor: 'event processing' stamp: ''!
mouseUp: event 

	"bubble up"
	self adapter widget owner eventHandler 
		mouseUp: event 
		fromMorph: self adapter widget owner! !

!ClyNotebookPageHeaderPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	iconImage := self newImage.
	titleLabel := self newLabel
		addStyle: 'fixed';
		yourself.
	closeImage := self newImage 
		image: (self application iconNamed: #glamorousClose);
		yourself.
		
	closeImage eventHandler 
		whenMouseDownDo: [ :anEvent | 
			anEvent isPrimaryButton 
				ifTrue: [ self doClose ] ].

	titleLabel eventHandler
		"This is required to fix a problem that arrives when doubleClick 
		 event of tab label happens: ot disables event processing by its parent. 
		 So this is just to bubble up the event"
		whenMouseDownDo: [ :anEvent | self mouseDown: anEvent ];
		whenMouseUpDo: [ :anEvent | self mouseUp: anEvent ];
		whenDoubleClickDo: [ :anEvent | self doDoubleClick ].

	self updatePresenter! !

!ClyNotebookPageHeaderPresenter methodsFor: 'event handling' stamp: ''!
onClose: aBlock 

	closeAction := aBlock! !

!ClyNotebookPageHeaderPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		spacing: 3;
		add: #iconImage expand: false;
		add: #titleLabel;
		addLast: #closeImage expand: false;
		yourself! !

!ClyNotebookPageMorph commentStamp: ''!
I am a page on a calypso notebook.
I define a different kind of header (icon, label, close) plus some actions on it.!
!ClyNotebookPageMorph methodsFor: 'accessing' stamp: ''!
actions: aCollection

	actions := aCollection! !

!ClyNotebookPageMorph methodsFor: 'accessing' stamp: ''!
backgroundColor

	^ Color transparent! !

!ClyNotebookPageMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	closeable := false.
	labelPresenter := ClyNotebookPageHeaderPresenter on: self.
	self flag: #TODO. "I'm hardcoding this width because I need to keep this sizes consistent. 
	But this is not good, think a better way."
	labelMorph := (labelPresenter buildWithSpec
		hResizing: #rigid;
		width: 120;
		yourself)! !

!ClyNotebookPageMorph methodsFor: 'accessing' stamp: ''!
label: aStringOrText

	label := aStringOrText! !

!ClyNotebookPageMorph methodsFor: 'events handling' stamp: ''!
onDoubleClick: aBlock

	labelPresenter onDoubleClick: aBlock! !

!ClyNotebookPageMorph methodsFor: 'accessing' stamp: ''!
actions

	^ actions! !

!ClyNotebookPageMorph methodsFor: 'testing' stamp: ''!
isCloseable

	^ closeable! !

!ClyNotebookPageMorph methodsFor: 'accessing' stamp: ''!
themeChanged

	super themeChanged.
	self actions do: [ :each | each themeChanged ]! !

!ClyNotebookPageMorph methodsFor: 'adding-removing' stamp: ''!
addToSelection
	
	owner addToSelection: self! !

!ClyNotebookPageMorph methodsFor: 'accessing' stamp: ''!
icon

	^ icon! !

!ClyNotebookPageMorph methodsFor: 'accessing' stamp: ''!
markDirty: dirty

	dirty
		ifTrue: [ self label: '*', self label ]
		ifFalse: [ 
			(self label beginsWith: '*')
				ifTrue: [  self label: self label allButFirst ] ].
	labelPresenter updatePresenter! !

!ClyNotebookPageMorph methodsFor: 'adding-removing' stamp: ''!
removeFromSelection
	owner removeFromSelection: self! !

!ClyNotebookPageMorph methodsFor: 'accessing' stamp: ''!
beCloseable

	closeable := true.
	labelPresenter updatePresenter! !

!ClyNotebookPageMorph methodsFor: 'events handling' stamp: ''!
onClose: aBlock

	labelPresenter onClose: aBlock.
	self beCloseable! !

!ClyNotebookPageMorph methodsFor: 'accessing' stamp: ''!
icon: anIcon

	icon := anIcon.
	labelPresenter updatePresenter! !

!ClyNotebookPageMorph methodsFor: 'accessing' stamp: ''!
label

	^ label! !

!ClyNotebookPageMorph class methodsFor: 'instance creation' stamp: ''!
newLabel: aString icon: anIcon provider: aBlock

	^ self new 
		label: aString; 
		icon: anIcon;
		lazyPageMorphCreation: aBlock;
		yourself! !

!ClyOldMessageBrowserAdapter commentStamp: ''!
I am a special adapter for the old message browser interface which users call using: 

	Smalltalk tools messageList 

The most of system queries are triggered by SystemNavigation which collects list of result methods and pass them to the registered message browser.
In contrast Calypso needs instance of query.

So to suppord old (current) approach I build special ClyOldMessageBrowserQuery on constant list of methods and then I open ClyQueryBrowser on it.
 
When Calypso is registered as default browser I am used as #messageList.
In future we should introduce #queryBrowser instead of it with direct usage of Calypso queries.

Internal Representation and Key Implementation Points.

    Instance Variables
	autoSelect:		<Boolean>
	messages:		<Collection of<CompiledMethod>>
	refreshingBlock:		<BlockClosure>
	title:		<String>!
!ClyOldMessageBrowserAdapter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	title := 'MessageBrowser'! !

!ClyOldMessageBrowserAdapter methodsFor: 'opening' stamp: ''!
open
	| query methods comments |
	methods := messages 
		select: [:each | (each isRingObject and: [ each isMethod ]) or: [ each isCompiledMethod  ] ]
		thenCollect: [ :each | each compiledMethod ].
	comments := messages 
		select: [:each | each isRingObject and: [ each isComment  ]]
		thenCollect: [ :each | ClyClassComment of: each realParent ].
	query := ClyOldMessageBrowserQuery named: title with: methods asOrderedCollection, comments.
	query
		criteriaString: autoSelect;
		criteriaBlock: refreshingBlock.
	openedBrowser := ClyQueryBrowserMorph openOn: query.! !

!ClyOldMessageBrowserAdapter methodsFor: 'accessing' stamp: ''!
title: anObject
	title := anObject! !

!ClyOldMessageBrowserAdapter methodsFor: 'accessing' stamp: ''!
refreshingBlock
	^ refreshingBlock! !

!ClyOldMessageBrowserAdapter methodsFor: 'accessing' stamp: ''!
messages: anObject
	messages := anObject! !

!ClyOldMessageBrowserAdapter methodsFor: 'accessing' stamp: ''!
autoSelect: anObject
	autoSelect := anObject! !

!ClyOldMessageBrowserAdapter methodsFor: 'accessing' stamp: ''!
messages
	^ messages! !

!ClyOldMessageBrowserAdapter methodsFor: 'accessing' stamp: ''!
autoSelect
	^ autoSelect! !

!ClyOldMessageBrowserAdapter methodsFor: 'opening' stamp: ''!
close
	openedBrowser ifNotNil: #close! !

!ClyOldMessageBrowserAdapter methodsFor: 'accessing' stamp: ''!
refreshingBlock: anObject
	refreshingBlock := anObject! !

!ClyOldMessageBrowserAdapter methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!ClyOldMessageBrowserAdapter class methodsFor: 'opening' stamp: ''!
browse: methods
	^ self new
		messages: methods;
		open! !

!ClyOldMessageBrowserAdapter class methodsFor: 'tools registration' stamp: ''!
beDefaultBrowser
	<script>
	self registerToolsOn: Smalltalk tools! !

!ClyOldMessageBrowserAdapter class methodsFor: 'tools registration' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]" 
	registry register: self as: #messageList! !

!ClyOldMessageBrowserAdapter class methodsFor: 'opening' stamp: ''!
browseImplementorsOf: aSymbol 
	^ClyQueryBrowserMorph browseImplementorsOf: aSymbol! !

!ClyOldMessageBrowserAdapter class methodsFor: 'opening' stamp: ''!
browseSendersOf: aSymbol 
	^ClyQueryBrowserMorph browseSendersOf: aSymbol! !

!ClyOldMessageBrowserAdapter class methodsFor: 'opening' stamp: ''!
browse: methods title: aString autoSelect: aSelectString
	^ self new
		messages: methods;
		title: aString;
		autoSelect: aSelectString;
		open! !

!ClyOldMessageBrowserAdapter class methodsFor: 'opening' stamp: ''!
browseClasses: classes 
	^ClyQueryBrowserMorph browseClasses: classes! !

!ClyOldMessageBrowserAdapter class methodsFor: 'opening' stamp: ''!
browse: methods title: aString
	^ self new
		messages: methods;
		title: aString;
		open! !

!ClyOldMessageBrowserQuery commentStamp: ''!
I am a special query which is based on constant list of methods or class comments. 

I am introduced to support old (current) approach for system queries which is based on SystemNavigation collecting list of methods.

I am used by ClyOldMessageBrowserAdapter which is installed as default as part of Calypso toolset.

I implement semantics of old MessageBrowser.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	criteriaBlock:		<BlockClosure>
	criteriaString:		<String>
	extraMethods:		<Collection of<CompiledMethod>>!
!ClyOldMessageBrowserQuery methodsFor: 'tools decoration' stamp: ''!
decorateResultMethodEditor: aMethodEditor

	criteriaString ifNil: [ ^self ].
	
	aMethodEditor selectStringAsInMessageBrowser: criteriaString! !

!ClyOldMessageBrowserQuery methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	extraMethods := IdentitySet new! !

!ClyOldMessageBrowserQuery methodsFor: 'accessing' stamp: ''!
criteriaString: anObject
	criteriaString := anObject asString! !

!ClyOldMessageBrowserQuery methodsFor: 'accessing' stamp: ''!
criteriaBlock
	^ criteriaBlock! !

!ClyOldMessageBrowserQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	| result |
	(super selectsMethod: aMethod) ifTrue: [ ^true ].
	criteriaBlock ifNil: [ ^false ].

	extraMethods removeAllSuchThat: [ :each | 
		each calypsoEnvironmentType checkCalypsoItem: each isEqualTo: aMethod].

	result := criteriaBlock value: aMethod.
	result ifTrue: [ extraMethods add: aMethod ].
	^result! !

!ClyOldMessageBrowserQuery methodsFor: 'accessing' stamp: ''!
criteriaBlock: anObject
	criteriaBlock := anObject! !

!ClyOldMessageBrowserQuery methodsFor: 'accessing' stamp: ''!
criteriaString
	^ criteriaString! !

!ClyOldMessageBrowserQuery methodsFor: 'execution' stamp: ''!
installedMethods

	| onlyMethods actualMethods |
	onlyMethods := methods select: [ :each | each isCompiledMethod ].
	
	actualMethods := self filterInstalledMethods: onlyMethods, extraMethods.
	^actualMethods, (methods reject: [ :each | each isCompiledMethod ])! !

!ClyOpenCriticBrowserCommand commentStamp: ''!
I am a command to open a critic browser on given set of packages!
!ClyOpenCriticBrowserCommand methodsFor: 'activation' stamp: ''!
defaultMenuItemName
	^'Browse critiques'! !

!ClyOpenCriticBrowserCommand methodsFor: 'execution' stamp: ''!
execute

	CriticBrowser
		openOnRule: (ReRuleManager uniqueInstance allRules) 
		onEnvironment: (RBPackageEnvironment packages: packages)! !

!ClyOpenCriticBrowserCommand class methodsFor: 'activation' stamp: ''!
packageContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation 
		byItemOf: ClyQueryMenuGroup for: RPackage asCalypsoItemContext! !

!ClyOpenDependencyBrowserCommand commentStamp: ''!
I am a command to open dependency browser on set of packages!
!ClyOpenDependencyBrowserCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Browse dependencies'! !

!ClyOpenDependencyBrowserCommand methodsFor: 'execution' stamp: ''!
execute

	| packageNames |
	packageNames := packages collect: [ :each | each name ].
	(DAPackageAnalyzerPackageDependenciesWindow onPackagesNamed: packageNames) open! !

!ClyOpenDependencyBrowserCommand class methodsFor: 'activation' stamp: ''!
packageContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: RPackage asCalypsoItemContext! !

!ClyOverriddenMethodChanged commentStamp: ''!
I am a special kind of MethodAnnouncement which represent that overridden method changes own "overridden status"!
!ClyOverriddenMethodChanged class methodsFor: 'instance creation' stamp: ''!
method: aMethod
	^self new 
		method: aMethod! !

!ClyOverriddenMethodGroupProvider commentStamp: ''!
I provide "overridden" method group which includes all methods of given classes which are overridden by subclasses!
!ClyOverriddenMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyOverriddenMethodsQuery from: aClassScope! !

!ClyOverriddenMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'overridden' priority: -10 on: aMethodQuery! !

!ClyOverriddenMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyOverriddenMethodGroupProvider! !

!ClyOverriddenMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup

	^ClyAbstractClassMock! !

!ClyOverriddenMethodGroupProviderTest methodsFor: 'running' stamp: ''!
setUpEnvironment
	super setUpEnvironment.
	
	environment addPlugin: ClyInheritanceAnalysisEnvironmentPlugin new! !

!ClyOverriddenMethodTableDecorator commentStamp: ''!
I decorate table with special double icon (up and down arrows) for overridden and overriding methods.
I add two or one iconic buttons as single icon which allow to open overridden or overriding methods for selected item.

I am activated only in browser with installed ClyInheritanceAnalysisBrowserPlugin!
!ClyOverriddenMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyOverriddenMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph inContext: itemContext 
	
	| commands |
	commands := OrderedCollection new: 2.
	(itemContext lastSelectedItem isMarkedWith: ClyOverriddenMethodTag) ifTrue: [ 
		commands add: ClyShowOverridingMethodsCommand new].
	(itemContext lastSelectedItem isMarkedWith: ClyOverridingMethodTag) ifTrue: [ 
		commands add: ClyShowOverriddenMethodsCommand new].
	
	self decorateTableCell: anItemCellMorph withCommands: commands inContext: itemContext! !

!ClyOverriddenMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph withCommands: commands inContext: itemContext

	| panel activator button |
	panel := self createMultiIconMorph.
	commands do: [ :each | 
		activator := CmdCommandActivator new 
			command: each; 
			context: itemContext.
		button := each createTableCellButtonUsing: activator.
		button hResizing: #spaceFill.
		button vResizing: #spaceFill.
		panel addMorph: button].
	anItemCellMorph definitionMorph: panel! !

!ClyOverriddenMethodTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem

	^(aDataSourceItem isMarkedWith: ClyOverridingMethodTag)
		or: [ aDataSourceItem isMarkedWith: ClyOverriddenMethodTag ]! !

!ClyOverriddenMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
priority
	^800! !

!ClyOverriddenMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
createMultiIconMorph

	^Morph new 
		changeTableLayout;
		listDirection: #topToBottom;
		listCentering: #center;
		wrapCentering: #center;
		extent: 16@16;
		color: Color transparent! !

!ClyOverriddenMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
browserPluginClass
	^ClyInheritanceAnalysisBrowserPlugin! !

!ClyOverriddenMethodTag commentStamp: ''!
I mark overridden methods which are overridden by any of subclasses!
!ClyOverriddenMethodsQuery commentStamp: ''!
I return all method from given scope which are overridden by any subclasses.

To detect overridden method I use inheritanceAnalyzer which caches this information!
!ClyOverriddenMethodsQuery methodsFor: 'system changes' stamp: ''!
isAffectedByChangedMethod: aMethod
	| selector methodClass |
	selector := aMethod selector.
	methodClass := aMethod origin.
	scope classesDo: [ :each | 
		each = methodClass ifTrue: [ ^true ].		
		((methodClass inheritsFrom: each) and: [ each includesLocalSelector: selector ])
			 ifTrue: [ ^true]
	].	
	^false! !

!ClyOverriddenMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^scope inheritanceAnalyzer isMethodOverridden: aMethod! !

!ClyOverriddenMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'overridden methods'! !

!ClyOverriddenMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope 
		of: (ClyAbstractClassMock >> #abstractMethod1)	in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyAbstractClassMock >> #overriddenMethod) in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyAbstractClassMock >> #abstractMethod2) in: environment).
	self assert: query checkEmptyResult! !

!ClyOverriddenMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsNotOverriddenMethod

	self deny: (query selectsMethod: ClyClassWhichInheritsAbstractClassMock>>#notOverriddenMethod)! !

!ClyOverriddenMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyAbstractClassMock >> #abstractMethod1. 
		ClyAbstractClassMock >> #abstractMethod2.
		ClyAbstractClassMock >> #overriddenMethod}.
	
	self assert: foundSelectors equals: #(abstractMethod1 overriddenMethod)! !

!ClyOverriddenMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotAffectedByChangeOfSubclassMethodWhichNotOverridesSuperclass
	
	self deny: (query isAffectedByChangedMethod: ClyClassWhichInheritsAbstractClassMock>>#notOverriddenMethod)! !

!ClyOverriddenMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsAffectedByChangeOfOwnMethodWhichIsNotOverridden
	query := ClyOverriddenMethodsQuery 
		from: ClyClassScope of: ClyClassWhichInheritsAbstractClassMock in: environment.
	
	self assert: (query isAffectedByChangedMethod: ClyClassWhichInheritsAbstractClassMock >>#notOverriddenMethod)! !

!ClyOverriddenMethodsQueryTest methodsFor: 'tests' stamp: ''!
testSelectsOverriddenMethod

	self assert: (query selectsMethod: ClyAbstractClassMock>>#overriddenMethod)! !

!ClyOverriddenMethodsQueryTest methodsFor: 'running' stamp: ''!
setUpEnvironment
	super setUpEnvironment.
	environment addPlugin: ClyInheritanceAnalysisEnvironmentPlugin new! !

!ClyOverriddenMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsAffectedByChangeOfSubclassMethodWhichOverridesSuperclass
	
	self assert: (query isAffectedByChangedMethod: ClyClassWhichInheritsAbstractClassMock>>#overriddenMethod)! !

!ClyOverriddenMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyOverriddenMethodsQuery from: ClyClassScope of: ClyAbstractClassMock in: environment! !

!ClyOverriddenMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethodsWhenImplementorsCacheShouldBeUsed
	| plugin |
	plugin := environment getPlugin: ClyInheritanceAnalysisEnvironmentPlugin.
	plugin littleHierarchyMaxSize: -1. 
	"This parameter forces plugin to build and use the cache for analysis"
	
	self queryFromScope: ClyMethodScope ofAll: {
		ClyAbstractClassMock >> #abstractMethod1. 
		ClyAbstractClassMock >> #abstractMethod2.
		ClyAbstractClassMock >> #overriddenMethod}.
	
	self assert: foundSelectors equals: #(abstractMethod1 overriddenMethod)! !

!ClyOverriddenMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsAffectedByChangeOfOwnMethodWhichIsOverridden
	
	self assert: (query isAffectedByChangedMethod: ClyAbstractClassMock>>#overriddenMethod)! !

!ClyOverriddenSuperclassesChanged commentStamp: ''!
I represent event when some class (overridingSubclass) is changed. In that case all superclasses are changed too because all their methods should update the "overridden status".

Read more details in superclass comment.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	overridingSubclass:		<Class>!
!ClyOverriddenSuperclassesChanged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInClass: aClass

	^overridingSubclass inheritsFrom: aClass instanceSide! !

!ClyOverriddenSuperclassesChanged methodsFor: 'accessing' stamp: ''!
classAffected
	^overridingSubclass! !

!ClyOverriddenSuperclassesChanged methodsFor: 'testing' stamp: ''!
affectsMethodsTaggedWith: tagName

	overridingSubclass allSuperclassesDo: [:each | 
		(each tagsForMethods includes: tagName) ifTrue: [ ^true ] ].

	^false! !

!ClyOverriddenSuperclassesChanged methodsFor: 'accessing' stamp: ''!
overridingSubclass
	^overridingSubclass! !

!ClyOverriddenSuperclassesChanged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage

	overridingSubclass allSuperclassesDo: [:each | 
		(each package = aPackage) ifTrue: [ ^true ] ].

	^false! !

!ClyOverriddenSuperclassesChanged methodsFor: 'accessing' stamp: ''!
overridingSubclass: aClass
	overridingSubclass := aClass! !

!ClyOverriddenSuperclassesChanged class methodsFor: 'instance creation' stamp: ''!
overridingSubclass: aClass
	^self new 
		overridingSubclass: aClass! !

!ClyOverridingMethodGroupProvider commentStamp: ''!
I provide "overrides" method group which includes all methods which are overridden by given classes!
!ClyOverridingMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyOverridingMethodsQuery from: aClassScope! !

!ClyOverridingMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'overrides' priority: -10 on: aMethodQuery! !

!ClyOverridingMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyOverridingMethodGroupProvider! !

!ClyOverridingMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup

	^ClyClassWhichInheritsAbstractClassMock! !

!ClyOverridingMethodGroupProviderTest methodsFor: 'running' stamp: ''!
setUpEnvironment
	super setUpEnvironment.
	
	environment addPlugin: ClyInheritanceAnalysisEnvironmentPlugin new! !

!ClyOverridingMethodTag commentStamp: ''!
I mark overriding methods (which override any of subclass or trait methods)!
!ClyOverridingMethodsChanged commentStamp: ''!
I am a special kind of MethodAnnouncement which represent that overriding methods changes the "override status" because the method which they override (my affected method) is changed.

So I modify default MethodAnnouncement processing logic to affect overriding methods.!
!ClyOverridingMethodsChanged methodsFor: 'accessing' stamp: ''!
announcerPlugin
	^ announcerPlugin! !

!ClyOverridingMethodsChanged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInClass: aClass

	^ (aClass includesLocalSelector: self overriddenMethod selector)
			and: [ aClass inheritsFrom: self overriddenMethod origin ]! !

!ClyOverridingMethodsChanged methodsFor: 'accessing' stamp: ''!
overriddenMethod
	^method! !

!ClyOverridingMethodsChanged methodsFor: 'testing' stamp: ''!
affectsMethodsTaggedWith: tagName

	^announcerPlugin isMethodOverridden: method! !

!ClyOverridingMethodsChanged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage

	^aPackage definesOverridesOf: self overriddenMethod! !

!ClyOverridingMethodsChanged methodsFor: 'testing' stamp: ''!
affectsMethod: aMethod
	^(aMethod selector = self overriddenMethod selector)
		and: [ aMethod origin inheritsFrom: self overriddenMethod origin]! !

!ClyOverridingMethodsChanged methodsFor: 'accessing' stamp: ''!
announcerPlugin: anObject
	announcerPlugin := anObject! !

!ClyOverridingMethodsChanged class methodsFor: 'instance creation' stamp: ''!
initiatedBy: anInheritenceAnalysisPlugin forOverriddenMethod: aMethod
	^self new 
		method: aMethod;
		announcerPlugin: anInheritenceAnalysisPlugin! !

!ClyOverridingMethodsQuery commentStamp: ''!
I return all method from given scope which override methods from inherited classes.

To detect overriding method I use inheritanceAnalyzer which caches this information!
!ClyOverridingMethodsQuery methodsFor: 'system changes' stamp: ''!
isAffectedByChangedMethod: aMethod
	| selector |
	
	(self isFromScopeWithClassKindOf: aMethod origin) ifFalse: [ ^false ].
	
	selector := aMethod selector.
	scope classesDo: [ :each | 
		(each lookupSelector: selector) ifNotNil: [ ^true ]].
	^ false! !

!ClyOverridingMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^scope inheritanceAnalyzer isMethodOverriding: aMethod! !

!ClyOverridingMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'overriding methods'! !

!ClyOverridingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsAffectedByChangeOfSuperclassMethodWhichIsAlreadyImplemented
	
	self assert: (query isAffectedByChangedMethod: ClyAbstractClassMock >> #overriddenMethod)! !

!ClyOverridingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotAffectedByChangeOfOverriddenMethodFromAnotherHierarchyWhenSameMethodExistsHereToo
	
	self deny: (query isAffectedByChangedMethod: ClyAbstractSubclassMock >> #abstractMethod1)! !

!ClyOverridingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: (ClyClassWhichInheritsAbstractClassMock >> #abstractMethod1) in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyClassWhichInheritsAbstractClassMock >> #overriddenMethod) in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: (ClyClassWhichInheritsAbstractClassMock >> #notOverriddenMethod) in: environment).
	self assert: query checkEmptyResult! !

!ClyOverridingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsAffectedByChangeOfSuperclassMethodWhichOverridesAnotherSuperclassMethod
	"this case is important to be affected when override method was removed"
	
	query := ClyOverridingMethodsQuery 
		from: ClyClassScope of: ClyClassWhichInheritsAbstractSubclassMock in: environment.
		
	self assert: (query isAffectedByChangedMethod: ClyAbstractSubclassMock >> #abstractMethod1)! !

!ClyOverridingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyClassWhichInheritsAbstractClassMock >> #abstractMethod1. 
		ClyClassWhichInheritsAbstractClassMock >> #notOverriddenMethod.
		ClyClassWhichInheritsAbstractClassMock >> #overriddenMethod}.
	
	self assert: foundSelectors equals: #(abstractMethod1 #overriddenMethod)! !

!ClyOverridingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsAffectedByChangeOfOwnMethodWhichIsNotOverridden
	
	self assert: (query isAffectedByChangedMethod: ClyClassWhichInheritsAbstractClassMock >> #notOverriddenMethod)! !

!ClyOverridingMethodsQueryTest methodsFor: 'running' stamp: ''!
setUpEnvironment
	super setUpEnvironment.
	
	environment addPlugin: ClyInheritanceAnalysisEnvironmentPlugin new! !

!ClyOverridingMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyOverridingMethodsQuery from: ClyClassScope of: ClyClassWhichInheritsAbstractClassMock in: environment! !

!ClyOverridingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testSelectsOverrideMethod

	self assert: (query selectsMethod: ClyClassWhichInheritsAbstractClassMock>>#overriddenMethod)! !

!ClyOverridingMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsNotOverrideMethod

	self deny: (query selectsMethod: ClyClassWhichInheritsAbstractClassMock>>#notOverriddenMethod)! !

!ClyOverridingSubclassesChanged commentStamp: ''!
I represent event when superclass (overriddenSuperclass) of some classes is changed. In that case all subclasses which could override his methods are also changed: their methods should update the "override status".

Read more details in superclass comment.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	overriddenSuperclass:		<Class>
!
!ClyOverridingSubclassesChanged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInClass: aClass

	^aClass instanceSide includesBehavior: overriddenSuperclass! !

!ClyOverridingSubclassesChanged methodsFor: 'accessing' stamp: ''!
classAffected
	^ overriddenSuperclass! !

!ClyOverridingSubclassesChanged methodsFor: 'accessing' stamp: ''!
overriddenSuperclass
	^ overriddenSuperclass! !

!ClyOverridingSubclassesChanged methodsFor: 'accessing' stamp: ''!
overriddenSuperclass: anObject
	overriddenSuperclass := anObject! !

!ClyOverridingSubclassesChanged methodsFor: 'testing' stamp: ''!
affectsMethodsTaggedWith: tagName

	overriddenSuperclass withAllSubclassesDo: [:each | 
		(each tagsForMethods includes: tagName) ifTrue: [ ^true ] ].

	^false! !

!ClyOverridingSubclassesChanged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage

	overriddenSuperclass withAllSubclassesDo: [:each | 
		(each package = aPackage) ifTrue: [ ^true ] ].

	^false! !

!ClyOverridingSubclassesChanged class methodsFor: 'instance creation' stamp: ''!
overriddenSuperclass: aClass

	^self new 
		overriddenSuperclass: aClass! !

!ClyPackageChange commentStamp: ''!
I represent all possible changes with package.
I am used to subscribe with single subscription to any changes related to packages.
So you can write code like this: 

	SystemAnnouncer uniqueInstance when: (ClyPackageChange of: aPackage) do: [ :ann | ann logCr ].
	
I provide more general subscription logic than subscribing on base RPackageAnnouncement class. Many other events can be also related to package changes like class creation. They are not covered by RPackageAnnouncement hierarchy.
I reuse logic of queries how they detect that their result is affected by system changes: 
	
	ClyPackageChange>>handlesAnnouncement: anAnnouncement 
 		^anAnnouncement affectsPackage: affectedPackage	

I am used by class editor tools to be updated when editing class is changed.
	
Internal Representation and Key Implementation Points.

    Instance Variables
	affectedPackage:		<RPackage>!
!ClyPackageChange methodsFor: 'accessing' stamp: ''!
affectedPackage
	^ affectedPackage! !

!ClyPackageChange methodsFor: 'accessing' stamp: ''!
affectedPackage: anObject
	affectedPackage := anObject! !

!ClyPackageChange methodsFor: 'testing' stamp: ''!
handlesAnnouncement: anAnnouncement

	^anAnnouncement affectsPackage: affectedPackage! !

!ClyPackageChange class methodsFor: 'instance creation' stamp: ''!
of: aPackage
	^self new 
		affectedPackage: aPackage! !

!ClyPackageCommentEditorToolMorph commentStamp: ''!
I am an editor of package comment
 
Internal Representation and Key Implementation Points.

    Instance Variables
	editingPackage:		<RPackage>!
!ClyPackageCommentEditorToolMorph methodsFor: 'testing' stamp: ''!
wantsTextStyling
	^false! !

!ClyPackageCommentEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpModelFromContext
	super setUpModelFromContext.

	editingPackage := context lastSelectedPackage! !

!ClyPackageCommentEditorToolMorph methodsFor: 'initialization' stamp: ''!
defaultTitle
	^'Comment'! !

!ClyPackageCommentEditorToolMorph methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserTool
	(super isSimilarTo: anotherBrowserTool) ifFalse: [ ^false ].
	
	^editingPackage = anotherBrowserTool editingPackage! !

!ClyPackageCommentEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingText
	^editingPackage packageManifestOrNil 
		ifNil: [ self packageCommentBlank ]
		ifNotNil: [ :manifest | 
			manifest hasComment 
				ifTrue: [ manifest comment ] 
				ifFalse: [ self packageCommentBlank ] ]! !

!ClyPackageCommentEditorToolMorph methodsFor: 'accessing' stamp: ''!
packageCommentBlank

	^'Please comment package here'! !

!ClyPackageCommentEditorToolMorph methodsFor: 'controlling' stamp: ''!
detachFromSystem

	browser system unsubscribe: self! !

!ClyPackageCommentEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingPackage
	^ editingPackage! !

!ClyPackageCommentEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingPackage: anObject
	editingPackage := anObject! !

!ClyPackageCommentEditorToolMorph methodsFor: 'operations' stamp: ''!
applyChanges

	self pendingText asString = self editingText ifFalse: [
		editingPackage packageManifest comment: self pendingText stamp: Author changeStamp].

	^true! !

!ClyPackageCommentEditorToolMorph methodsFor: 'controlling' stamp: ''!
attachToSystem

	browser system 
		when: (ClyPackageChange of: editingPackage) send: #triggerUpdate to: self! !

!ClyPackageCommentEditorToolMorph methodsFor: 'printing' stamp: ''!
printContext
	^editingPackage name! !

!ClyPackageCommentEditorToolMorph methodsFor: 'initialization' stamp: ''!
defaultIconName
	^#commentsIcon! !

!ClyPackageCommentEditorToolMorph class methodsFor: 'activation' stamp: ''!
browserTabActivation2
	<classAnnotation>
	
	^ClyTabActivationStrategyAnnotation for: ClyClassGroup asCalypsoItemContext! !

!ClyPackageCommentEditorToolMorph class methodsFor: 'activation' stamp: ''!
browserTabActivation
	"This declaration specifies that in any browser when packages are selected, a comment editor will be available in a tab."

	<classAnnotation>
	^ClyTabActivationStrategyAnnotation for: RPackage asCalypsoItemContext! !

!ClyPackageCommentEditorToolMorph class methodsFor: 'activation' stamp: ''!
tabOrder
	^ -10! !

!ClyPackageCommentEditorToolMorph class methodsFor: 'testing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	^aBrowserContext isPackageSelected and: [aBrowserContext isClassSelected not]! !

!ClyPackageExtensionMethodsQuery commentStamp: ''!
I return all methods from the scope which are extended by particular package.

To instantiate my instances use following expressions: 

	ClyPackageExtensionMethods of: aPackage.
	ClyPackageExtensionMethods of: aPackage from: aScope
 
Internal Representation and Key Implementation Points.

    Instance Variables
	package:		<RPackage>
!
!ClyPackageExtensionMethodsQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^package = anObject package! !

!ClyPackageExtensionMethodsQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash bitXor: package hash! !

!ClyPackageExtensionMethodsQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	^(aSystemAnnouncement affectsMethodsDefinedInPackage: package)
		and: [ scope includesMethodsAffectedBy: aSystemAnnouncement]! !

!ClyPackageExtensionMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^aMethod isExtension and: [ aMethod package = package ]! !

!ClyPackageExtensionMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'extension methods of ', package name! !

!ClyPackageExtensionMethodsQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream
	super printExtraInfoOn: aStream.

	^aStream nextPutAll: package name! !

!ClyPackageExtensionMethodsQuery methodsFor: 'accessing' stamp: ''!
package: anObject
	package := anObject! !

!ClyPackageExtensionMethodsQuery methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!ClyPackageExtensionMethodsQuery class methodsFor: 'instance creation' stamp: ''!
of: aPackage from: aScope

	^(self from: aScope)
		package: aPackage! !

!ClyPackageExtensionMethodsQuery class methodsFor: 'instance creation' stamp: ''!
of: aPackage

	^self new 
		package: aPackage! !

!ClyPackageExtensionMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope 
		of: ClySubclassLOfClass0FromPExtendedByP1Mock >> #extensionMethodFromSubclassL
		in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope
		of: ClyClass9FromPExtendedByP5Mock >> #extensionMethodFromClass9 in: environment).
	self assert: query checkEmptyResult! !

!ClyPackageExtensionMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyClass1FromP1Mock >> #tag1Method1. Object >> #printString. 
		ClySubclassLOfClass0FromPExtendedByP1Mock >> #extensionMethodFromSubclassL.
		ClyClass9FromPExtendedByP5Mock >> #extensionMethodFromClass9}.
	
	self assert: foundSelectors equals: #(#extensionMethodFromSubclassL)! !

!ClyPackageExtensionMethodsQueryTest methodsFor: 'tests' stamp: ''!
testComparisonToSimilarQueryButWithDifferentPackage
	| query2 |
	query package: Object package.
	query2 := self createQuery.
	query2 package: String package.

	self deny: query equals: query2! !

!ClyPackageExtensionMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyPackageExtensionMethodsQuery
		of: ClyClass1FromP1Mock package
		from: (ClyClassScope of: ClyClass1FromP1Mock in: environment)! !

!ClyPackageExtensionScope commentStamp: ''!
I am a scope of packages which shows only objects which packages extend.
I see all extended classes and extension methods!
!ClyPackageExtensionScope methodsFor: 'queries' stamp: ''!
methodsDo: aBlock
	
	self packagesDo: [ :package | 
		package extensionMethods do: aBlock ]! !

!ClyPackageExtensionScope methodsFor: 'queries' stamp: ''!
packagesDo: aBlock
	basisObjects do: aBlock! !

!ClyPackageExtensionScope methodsFor: 'printing' stamp: ''!
printBasisObject: aPackage on: aStream

	aStream nextPutAll: aPackage name! !

!ClyPackageExtensionScope methodsFor: 'queries' stamp: ''!
classesDo: aBlock 
	self packagesDo: [ :package | 
		package extendedClasses 
			collect: [ :each | each instanceSide ] 
			thenDo: aBlock]! !

!ClyPackageExtensionScopeTest methodsFor: 'running' stamp: ''!
extraBasisSample
	^ClySubclassMOfClass1FromP2Mock package! !

!ClyPackageExtensionScopeTest methodsFor: 'tests' stamp: ''!
testClassesEnumeration
	scope := ClyPackageExtensionScope of: ClyClass1FromP1Mock package.
	
	scope classesDo: [ :each | result add: each ].
	
	self deny: (result includesAll: ClyClass1FromP1Mock package definedClasses).
	self assert: (result includesAll: ClyClass1FromP1Mock package extendedClasses)! !

!ClyPackageExtensionScopeTest methodsFor: 'running' stamp: ''!
scopeClass

	^ClyPackageExtensionScope! !

!ClyPackageExtensionScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumeration
	scope := ClyPackageExtensionScope of: ClyClass1FromP1Mock package.
	
	scope methodsDo: [ :each | result add: each ].
	
	self deny: (result includesAll: ClyClass1FromP1Mock localMethods).
	self deny: (result includesAll: ClyClass2FromP1Mock classSide localMethods).
	self assert: (result includesAll: ClySubclassLOfClass0FromPExtendedByP1Mock localMethods)! !

!ClyPackageExtensionScopeTest methodsFor: 'tests' stamp: ''!
testPackageEnumeration
	scope := ClyPackageExtensionScope ofAll: {Array package. Object package}.
	
	scope packagesDo: [ :each | result add: each ].
	
	self assert: result asArray equals: {Array package. Object package}! !

!ClyPackageExtensionScopeTest methodsFor: 'running' stamp: ''!
singleBasisSample
	^ClyClass1FromP1Mock package! !

!ClyPackageIconTableDecorator commentStamp: ''!
I decorate table with simple constant icon for packages!
!ClyPackageIconTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyPackageIconTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	
	anItemCellMorph definitionIcon: #packageIcon! !

!ClyPackageQuery commentStamp: ''!
I am abstract query of all packages from given scope.

I only implement method related to the retrieved items type.
So my subclasses still should implement main query methods!
!ClyPackageQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin
	anEnvironmentPlugin collectMetadataOfPackages: aQueryResult! !

!ClyPackageQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	^RPackage! !

!ClyPackageQueryTest methodsFor: 'tests' stamp: ''!
testIsEmptyFromEmptyPackageScope
	query scope: (ClyPackageScope emptyIn: environment).
	
	self assert: query checkEmptyResult! !

!ClyPackageQueryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyPackageQueryTest! !

!ClyPackageScope commentStamp: ''!
I am a scope of packages.
So I see all objects which are defined by given packages: 
- packages
- classes 
- methods!
!ClyPackageScope methodsFor: 'refactoring support' stamp: ''!
asRBEnvironment
	^RBPackageEnvironment packages: basisObjects! !

!ClyPackageScope methodsFor: 'queries' stamp: ''!
methodsDo: aBlock
	self classesDo: [:class | 
		class localMethods do: aBlock.
		class classSide localMethods do: aBlock].
	
	self packagesDo: [ :package | 
		package extensionMethods do: aBlock ]! !

!ClyPackageScope methodsFor: 'queries' stamp: ''!
packagesDo: aBlock
	basisObjects do: aBlock! !

!ClyPackageScope methodsFor: 'printing' stamp: ''!
printBasisObject: aPackage on: aStream

	^aStream nextPutAll: aPackage name! !

!ClyPackageScope methodsFor: 'queries' stamp: ''!
classesDo: aBlock
	self packagesDo: [ :package | 
		package definedClasses do: aBlock]! !

!ClyPackageScope methodsFor: 'queries' stamp: ''!
classGroupsDo: aBlock

	self classGroupProvidersDo: [ :groupProvider |
		groupProvider classGroupsIn: self do: [:group | 
			aBlock value: group] ]! !

!ClyPackageScope methodsFor: 'system changes' stamp: ''!
includesClassGroupsAffectedBy: aSystemAnnouncement

	| providers |
	basisObjects do: [ :eachPackage | 
		environment pluginsDo: [ :plugin |
			providers := plugin collectClassGroupProviders.
			providers do: [ :eachProvider | 
				(eachProvider providesGroupsAffectedBy: aSystemAnnouncement inScope: self)
					ifTrue: [^true]]]].
	^false! !

!ClyPackageScope methodsFor: 'queries' stamp: ''!
classGroupProvidersDo: aBlock
	
	| providers |
	environment pluginsDo: [ :plugin |
		providers := plugin collectClassGroupProviders.
		providers do: aBlock]! !

!ClyPackageScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'packages'! !

!ClyPackageScopeTest methodsFor: 'running' stamp: ''!
extraBasisSample
	^ClySubclassMOfClass1FromP2Mock package! !

!ClyPackageScopeTest methodsFor: 'tests' stamp: ''!
testClassesEnumeration
	scope := ClyPackageScope of: ClyClass1FromP1Mock package.
	
	scope classesDo: [ :each | result add: each ].
	
	self assert: (result includesAll: ClyClass1FromP1Mock package definedClasses).
	self deny: (result includesAll: ClyClass1FromP1Mock package extendedClasses)! !

!ClyPackageScopeTest methodsFor: 'running' stamp: ''!
scopeClass

	^ClyPackageScope! !

!ClyPackageScopeTest methodsFor: 'tests' stamp: ''!
testClassGroupEnumeration
	environment addPlugin: ClyDefaultSystemEnvironmentPlugin new.
	scope := ClyPackageScope of: ClyClass7WithTag1FromP5Mock package in: environment.
	
	scope classGroupsDo: [ :each | result add: each ].
	
	self
		assert: (result collect: #class as: Set)
		equals: {ClyNoTagClassGroup. ClyTaggedClassGroup. ClyClassGroup} asSet.
	self
		assert: 
			(result
				select: [ :each | each class = ClyTaggedClassGroup ]
				thenCollect: #tag) sorted asArray
		equals: ClyClass7WithTag1FromP5Mock package tagsForClasses sorted asArray! !

!ClyPackageScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumeration
	scope := ClyPackageScope of: ClyClass1FromP1Mock package.
	
	scope methodsDo: [ :each | result add: each ].
	
	self assert: (result includesAll: ClyClass1FromP1Mock localMethods).
	self assert: (result includesAll: ClyClass2FromP1Mock localMethods).
	self
		assert: (result includesAll: ClyClass1FromP1Mock classSide localMethods)
		description: 'Package scope should see class side methods too'.
	self
		assert: (result includesAll: ClySubclassLOfClass0FromPExtendedByP1Mock localMethods)
		description: 'Package scope should see all clas extensions'! !

!ClyPackageScopeTest methodsFor: 'tests' stamp: ''!
testPackageEnumeration
	scope := ClyPackageScope ofAll: {Array package. Object package}.
	
	scope packagesDo: [ :each | result add: each ].
	
	self assert: result asArray equals: {Array package. Object package}! !

!ClyPackageScopeTest methodsFor: 'running' stamp: ''!
singleBasisSample
	^ClyClass1FromP1Mock package! !

!ClyPackageTableDecorator commentStamp: ''!
I am a base class for package table decorators.

I am annotated by decoration strategy in context of selected package.
So my subclasses should just implement decoration logic!
!ClyPackageTableDecorator class methodsFor: 'decoration' stamp: ''!
decorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: RPackage asCalypsoItemContext! !

!ClyPackageTableDecorator class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyPackageTableDecorator! !

!ClyPackageToolbarGroup commentStamp: ''!
I am a toolbar menu group to show package view modes of the browser together!
!ClyPackageToolbarGroup methodsFor: 'accessing' stamp: ''!
order
	^1! !

!ClyProjectChildItem commentStamp: ''!
I represent the item of project.
Concrete project manager plugins are supposed to implement my subclasses to represent concrete types of project items.

Subclasses should implement following methods:
- items
- allPackages
- classes
- isEmpty

Instancees should be creation with project: 

	ClyProjectChildItem project: aProject
	 
Internal Representation and Key Implementation Points.

    Instance Variables
	project:		<ClyManagedProject>!
!ClyProjectChildItem methodsFor: 'testing' stamp: ''!
isEmpty
	self subclassResponsibility! !

!ClyProjectChildItem methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem! !

!ClyProjectChildItem methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateTableCell: anItemCellMorph inContext: itemContext

	^ self
		decorateTableCell: anItemCellMorph
		of: itemContext lastSelectedItem! !

!ClyProjectChildItem methodsFor: 'accessing' stamp: ''!
items
	self subclassResponsibility! !

!ClyProjectChildItem class methodsFor: 'queries' stamp: ''!
prepareClassQueriesFrom: projectItems in: aNavigationEnvironment 
	^{ClyAllClassesQuery from: ClyProjectScope ofAll: projectItems in: aNavigationEnvironment }! !

!ClyProjectChildItem class methodsFor: 'instance creation' stamp: ''!
project: aProject
	^self new 
		project: aProject! !

!ClyProjectChildItem class methodsFor: 'sorting' stamp: ''!
defaultSortFunctionForCalypso 
	^ClySortByNameFunction ascending! !

!ClyProjectChildItem class methodsFor: 'queries' stamp: ''!
prepareProjectItemsQueryFrom: aProjectChildItem in: aNavigationEnvironment 

	^ ClyProjectContentQuery 
			sortedFrom: (ClyProjectScope of: aProjectChildItem in: aNavigationEnvironment)! !

!ClyProjectChildItem class methodsFor: 'item convertation' stamp: ''!
convertToCalypsoBrowserItem: aProjectChildItem 
	| item |
	item := ClyBrowserItem named: aProjectChildItem name with: aProjectChildItem.
	aProjectChildItem isEmpty ifFalse: [ item markWithChildrenOf: ClyProjectChildItem].
	^item! !

!ClyProjectChildItemTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem! !

!ClyProjectChildItemTableDecorator class methodsFor: 'decoration' stamp: ''!
decorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyProjectChildItem asCalypsoItemContext! !

!ClyProjectChildItemTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph inContext: itemContext

	itemContext lastSelectedItem actualObject
		decorateTableCell: anItemCellMorph inContext: itemContext! !

!ClyProjectContentQuery commentStamp: ''!
I return all contents of the project.
The actual objects are depends on project implementation. Look at ClyManagedProject for details.
!
!ClyProjectContentQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin! !

!ClyProjectContentQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	self flag: #todo.
	^false! !

!ClyProjectContentQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult

	| allItems |
	allItems := OrderedCollection new.
	
	scope projectsDo: [ :each | 
		allItems addAll: each items  ].
	
	aQueryResult fillWith: allItems! !

!ClyProjectContentQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	
	scope projectsDo: [ :each | 
		each items ifNotEmpty: [ ^false ]  ].
	^true! !

!ClyProjectContentQuery class methodsFor: 'accessing' stamp: ''!
resultItemsType
	^ClyProjectChildItem! !

!ClyProjectManager commentStamp: ''!
My subclasses represent concrete package management system like Cargo or Metacello.
They implement behaviour which is needed to query project and package information from concrete management system: version, comment, metadata.
Project and package are represented by classes ClyManagedProject and ClyManagedPackage!
!ClyProjectManager methodsFor: 'api - queries' stamp: ''!
projectQueryFor: aClySystemEnvironmentScope 
	
	^ ClyUnknownQuery instance! !

!ClyProjectManager methodsFor: 'api - queries' stamp: ''!
queryClass
	^ self subclassResponsibility! !

!ClyProjectManagerRegistry commentStamp: ''!
I provide access to all projects from different kind of package managers.
It can be Cargo manager, Metacello manager, etc.

ClySystemEnvironment instance keeps my instance. To register new package manager in image use following expression: 
	
	ClySystemEnvironment currentImage registerPackageManager: aPackageManager
	
I allow different kind of package managers to be used by Calypso browser to display all available projects.

Internal Representation and Key Implementation Points.

    Instance Variables
	packageManagers:		<Collection of<ClyPackageManager>>!
!ClyProjectManagerRegistry methodsFor: 'registration' stamp: ''!
registerProjectManager: aPackageManager
	projectManagers removeAllSuchThat: [ :each | each class = aPackageManager class ].
	projectManagers add: aPackageManager! !

!ClyProjectManagerRegistry methodsFor: 'accessing' stamp: ''!
projectManagers
	^ projectManagers! !

!ClyProjectManagerRegistry methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	projectManagers := OrderedCollection new! !

!ClyProjectManagerRegistry methodsFor: 'queries' stamp: ''!
projectQueryFor: aScope

	projectManagers isEmpty ifTrue: [ ^ ClyUnknownQuery instance ].
	^ (projectManagers collect: [ :found | found queryClass sortedFrom: aScope ])
		reduce: [ :a :b | a , b ]! !

!ClyProjectManagerRegistry methodsFor: 'accessing' stamp: ''!
projects
	^projectManagers flatCollect: [ :each | each projects ]! !

!ClyProjectManagerRegistry methodsFor: 'accessing' stamp: ''!
projectManagers: anObject
	projectManagers := anObject! !

!ClyProjectScope commentStamp: ''!
I am a scope of projects.
So I see all objects which are defined in given projects:
- projects
- packages
- classes 
- methods!
!ClyProjectScope methodsFor: 'queries' stamp: ''!
packagesDo: aBlock
	self projectsDo: [ :project |
		project packages do: aBlock ]! !

!ClyProjectScope methodsFor: 'queries' stamp: ''!
projectsDo: aBlock
	basisObjects do: aBlock! !

!ClyProjectScope methodsFor: 'queries' stamp: ''!
classesDo: aBlock
	self projectsDo: [ :project |
		project classes do: aBlock ]! !

!ClyProjectScope methodsFor: 'system changes' stamp: ''!
includesClassesAffectedBy: aSystemAnnouncement
	^false! !

!ClyProjectScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'projects'! !

!ClyProjectTableIndentationDecorator commentStamp: ''!
I decorate table of projects with full identation mode.
So projects tree in the full browser shifts children together with collapsing items.

I am always applied to the projects!
!ClyProjectTableIndentationDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyProjectTableIndentationDecorator class methodsFor: 'decoration' stamp: ''!
decorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyFullBrowserContext! !

!ClyProjectTableIndentationDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	^aDataSourceItem rootParentItem isBasedOnItemType: ClyManagedProject! !

!ClyProjectTableIndentationDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	
	anItemCellMorph useFullIndentation! !

!ClyProperty commentStamp: ''!
I am a root of hierarchy of item properties.
My subclasses represent specific information about objects!
!ClyQuery commentStamp: ''!
I am a root of hierarchy of queries.
My subclasses implement specific logic how to retrieve particular objects from given environment scope. 

Any query should be created with scope:

	query := ClyAllMethods from: scope
	
And to create scope instance you need some navigation environment. For example to query Smalltalk image there is global #currentImage environment: 

	scope := ClyClassScope of: Object in: ClyNavigationEnvironment currentImage.
	
When query instance is created you can simply execute it: 

	result := query execute.
	
The result of any query is a kind of ClyQueryResult.
By default it is always ClyRawQueryResult which do not apply any formatting or transformation on retrieved items.
The required result is a parameter of any query, the variable #requiredResult. Responsibility of result is to format or transform items retrieved by query. 
For example there are ClySortedQueryResult which sort items using given sort funciton.

The value of requiredResult variable is used as prototype to create actual result instances. During execution the query creates it using: 

	actualResult := requiredResult prepareNewFor: aQuery in: environment
	
You can specify requird result when you create query instances. For example: 

	ClyAllClassQuery from: packageScope as: ClySubclassHierarchy new asQueryResult.
	
My subclasses provide various constructors to specify such parameters.
	
Any query instance can be converted to query with new required result: 

	aQuery withResult: ClySpecialQueryResult new
	
There are other converting methods which are supported by any kind of queries: 

- withScope: aScope, it returnes similar query but with different scope
- withScopeOf: newBasisObjects, it returns similar query with scope of different basis
- restrictedByScope: aScope, it returnes similar query with similar scope restricted by basis of given scope.
- filtereBy: anItemFilter, it returns wrapper query which filters original query result using given filter

My subclasses must implement several methods: 
	
- buildResult: aQueryResult 
It is the method where query retrieves items from the scope and fill given result with them. Look at implementors.

- checkEmptyResult
It checks that result will be empty without full execution.

-isResult: aQueryResult affectedBy: aSystemAnnouncement
Any query can be affected by system changes. Subclasses should decide what changes can affect them.

- retrivesItem: anObject
Subclasses should check that given item can be retrieved. This check should not depends on query scope.

- retrivesItemOfType: aClass
Subclasses should check what kind of items they retrieve.

- executesQuery: aTypedQueryClass
Subclasses should check that they in fact executes given query class. For example composite query will ask subqueries for this question. But typed queries will use simple isKindOf: check.

- withScope: aScope 
Subclasses should implement converting to the similar query from new given scope.

- withScopeOf: newBasisObjects 
Subclasses should implement converting to the similar query from the similar scope of new given basis.
 
- #unionWith: typedQueries as: aQueryResult
Subclasses should implement converting to composite query union given collection of subqueries.

- #, anotherQuery 
Subclasses should implement union with another query.

-collectMetadataOf: aQueryResult by: anEnvironmentPlugin
Subclasses should dispatch metadata collection to the given environment plugin.

Also there is special ClyUnionQuery class which requires additional method to be implemented: 

- mergeOwnInstances: queries
It should merge similar query instances. Idea to reduce subqueries count in union query. Subclasses should produce single query with merged collection of parameters. The argument is always collection of receiver instances.

Queries should define user friendly #description. I provide very general implementation based on class name. Look at implementors for examples.

Navigation environment caches my instances and their results. It requires correct implementation of equality and hashing.
Some queries include various state which can be initialized at different time. It is important that instance will be not modified after execution because instead it can affect hash and equality functions which are used by cache. 
For this reason I implement special method #fixStateBeforeExecution which marks the instance and related state (the scope for example) as read only objects (#beReadOnlyObject). So after execution my instances became immutable.

And according to this logic I provide special hook #prepareStateBeforeExecution to prepare complete state of query instance before execution. It allows initialize lazy variables before making instance immutable.
			
The Calypso-Browser package provide UI widget to browse query results. For this purpose I provide helper method to open browser cursor:

	aQuery openBrowserCursorFor: anItemObserver

It is shortcut method to execute query and open cursor on result. So read details in ClyQueryResult comments.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	requestedResult:		<ClyQueryResult>
	scope:		<ClyScope>!
!ClyQuery methodsFor: 'execution' stamp: ''!
hasEmptyResult
	^scope isQueryEmpty: self! !

!ClyQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^requiredResult hash bitXor: scope hash! !

!ClyQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	self subclassResponsibility! !

!ClyQuery methodsFor: 'printing' stamp: ''!
description
	^String streamContents: [:s | 
		s nextPutAll: self class name.
		s nextPut: $(.
		self printExtraInfoOn: s.
		s nextPut: $)]! !

!ClyQuery methodsFor: 'accessing' stamp: ''!
environment
	scope ifNil: [ self error: 'Scope is not defined. So environment is undefined' ].
	^scope environment! !

!ClyQuery methodsFor: 'execution' stamp: ''!
execute
	^scope query: self! !

!ClyQuery methodsFor: 'execution' stamp: ''!
fixStateBeforeExecution
	"Here the query should become readonly object together with all required internal state. By default it is only instance itself. But subclasses like composite query force additional objects (subqueries) to fix their state.
	If query needs additional state for execution 
	it should retrieve it in prepare method which is executed before readonly fix"
	self prepareStateBeforeExecution.
	self beReadOnlyObject.
	scope beReadOnlyObject! !

!ClyQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream! !

!ClyQuery methodsFor: 'converting' stamp: ''!
async
	^ClyAsyncQuery for: self! !

!ClyQuery methodsFor: 'converting' stamp: ''!
withoutItemsOfType: anItemTypeClass
	self subclassResponsibility! !

!ClyQuery methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self resetScope.
	self requiredResult: self defaultResult! !

!ClyQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin
	self subclassResponsibility! !

!ClyQuery methodsFor: 'testing' stamp: ''!
retrievesItem: anObject
	self subclassResponsibility! !

!ClyQuery methodsFor: 'composition' stamp: ''!
unionWith: typedQueries as: aQueryResult
	"Subclasses should return ClyUnionQuery with collection of given subqueries together with itself or own subqueries if exists.
	To create ClyUnionQuery they can yse short version ClyQuery unionFrom:"
	self subclassResponsibility! !

!ClyQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement

	^self subclassResponsibility! !

!ClyQuery methodsFor: 'converting' stamp: ''!
filteredBy: anItemFilter
	^ClyFilterQuery for: self filter: anItemFilter.! !

!ClyQuery methodsFor: 'converting' stamp: ''!
withScopeOf: newBasisObjects
	self subclassResponsibility! !

!ClyQuery methodsFor: 'printing' stamp: ''!
fullDescription
	
	^self description, ' from ',
		(scope isBasedOnEmptyBasis ifTrue: [ 'empty scope'] ifFalse: [ scope description])! !

!ClyQuery methodsFor: 'testing' stamp: ''!
retrievesItemsOfType: itemTypeClass
	self subclassResponsibility! !

!ClyQuery methodsFor: 'execution' stamp: ''!
openBrowserCursorFor: anItemObserver
	^self execute openBrowserCursorFor: anItemObserver! !

!ClyQuery methodsFor: 'testing' stamp: ''!
isAsync
	^false! !

!ClyQuery methodsFor: 'execution' stamp: ''!
prepareNewResult
	
	^requiredResult prepareNewFor: self in: self environment! !

!ClyQuery methodsFor: 'testing' stamp: ''!
buildsDefaultResult

	^self retrievesItemsAs: self defaultResult class! !

!ClyQuery methodsFor: 'testing' stamp: ''!
isBoundToEnvironment
	^scope isBoundToEnvironment! !

!ClyQuery methodsFor: 'accessing' stamp: ''!
ensureScope: aScope
	scope == ClyUnknownScope instance ifTrue: [ ^self scope: aScope ].
	
	scope == aScope ifFalse: [ 
		self error: 'Scope modification is forbidden. Query is bound to scope forever' ]! !

!ClyQuery methodsFor: 'accessing' stamp: ''!
requiredResult
	^ requiredResult! !

!ClyQuery methodsFor: 'converting' stamp: ''!
semiAsync
	^self async 
		asyncResult: ClySemiAsyncQueryResult new! !

!ClyQuery methodsFor: 'testing' stamp: ''!
isExecutedFromScope: aTypedScopeClass

	^scope representsScope: aTypedScopeClass! !

!ClyQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class	ifFalse: [ ^ false ].
		
	^ requiredResult = anObject requiredResult	
		and: [scope = anObject scope]! !

!ClyQuery methodsFor: 'converting' stamp: ''!
restrictedByScope: aScope
	self subclassResponsibility! !

!ClyQuery methodsFor: 'accessing' stamp: ''!
scope: aScope
	aScope isBoundToEnvironment ifFalse: [ 
		^self error: 'Query should be always initialized with scope bound to concrete environment' ].
	(aScope supportsQuery: self) ifFalse: [ 
		self error: 'Given scope do not support given query!! Try use #adoptQuery:' ].
	
	scope := aScope! !

!ClyQuery methodsFor: 'initialization' stamp: ''!
resetScope
	scope := ClyUnknownScope instance! !

!ClyQuery methodsFor: 'converting' stamp: ''!
withResult: aQueryResult
	| copy |
	copy := self copy.
	copy requiredResult: aQueryResult.
	^copy! !

!ClyQuery methodsFor: 'printing' stamp: ''!
printOn: aStream
	| position |
	super printOn: aStream.
	
	aStream nextPut: $(.
	position := aStream position.
	self printExtraInfoOn: aStream.
	aStream position = position 
		ifTrue: [ aStream skip: -1; nextPut: $  ]
		ifFalse: [ aStream nextPutAll: ') ' ].
	aStream nextPutAll: 'from '.
	scope isBasedOnEmptyBasis 
		ifTrue: [ aStream nextPutAll: 'empty scope']
		ifFalse: [ scope printDescriptionOn: aStream].! !

!ClyQuery methodsFor: 'testing' stamp: ''!
executesQuery: aTypedQueryClass
	"We should be able to check that given query executes particular kind of query class.
	It allows simple check for tools that desired kind of query is activated.
	Composite query should check all subqueries according to this logic"
	self subclassResponsibility! !

!ClyQuery methodsFor: 'execution' stamp: ''!
prepareStateBeforeExecution
	"Here subclasses can initialize some additional state from own instance variables
	which is required for execution"! !

!ClyQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	self subclassResponsibility! !

!ClyQuery methodsFor: 'testing' stamp: ''!
retrievesBrowserItems
	^requiredResult representsBrowserItems! !

!ClyQuery methodsFor: 'testing' stamp: ''!
retrievesItemsAs: aQueryResultClass
	^requiredResult isKindOf: aQueryResultClass! !

!ClyQuery methodsFor: 'accessing' stamp: ''!
bindTo: aScope in: aNavigationEnvironment
	aScope bindTo: aNavigationEnvironment.
	self scope: aScope! !

!ClyQuery methodsFor: 'testing' stamp: ''!
isExecutedFromMultipleScope
	^scope isBasedOnMultipleBasis! !

!ClyQuery methodsFor: 'testing' stamp: ''!
isExecutedFromSingleScope
	^scope isBasedOnSingleBasis! !

!ClyQuery methodsFor: 'testing' stamp: ''!
isExecutedFromEmptyScope

	^scope isBasedOnEmptyBasis! !

!ClyQuery methodsFor: 'accessing' stamp: ''!
requiredResult: aQueryResult
	requiredResult := aQueryResult.
	requiredResult beReadOnlyObject! !

!ClyQuery methodsFor: 'converting' stamp: ''!
withScope: aScope
	self subclassResponsibility! !

!ClyQuery methodsFor: 'initialization' stamp: ''!
defaultResult
	^ClyRawQueryResult new! !

!ClyQuery methodsFor: 'testing' stamp: ''!
isExecutedFromScopeOf: basisObject

	^scope isBasedOn: basisObject! !

!ClyQuery methodsFor: 'composition' stamp: ''!
, anotherQuery 
	self subclassResponsibility! !

!ClyQuery methodsFor: 'accessing' stamp: ''!
scope
	^ scope! !

!ClyQuery class methodsFor: 'instance creation' stamp: ''!
unionFrom: subqueries as: aQueryResult
	^ClyUnionQuery with: subqueries as: aQueryResult! !

!ClyQuery class methodsFor: 'instance creation' stamp: ''!
as: aQueryResultClass
	^self new 
		requiredResult: aQueryResultClass! !

!ClyQuery class methodsFor: 'merging queries' stamp: ''!
mergeOwnInstances: queries
	"Subclasses should return collection of queries merged from given array.
	For example two AllClasses queries from same package scope can be merged.
	They can be represented by single AllClasses query 
	from unified scope of both packages from original queries"
	self subclassResponsibility! !

!ClyQuery class methodsFor: 'instance creation' stamp: ''!
unionFrom: subqueries
	^ClyUnionQuery with: subqueries! !

!ClyQuery class methodsFor: 'instance creation' stamp: ''!
sortedBy: aSortFunction
	^self as: (ClySortedQueryResult using: aSortFunction)! !

!ClyQueryBrowserContext commentStamp: ''!
I represent query browser context!
!ClyQueryBrowserContext methodsFor: 'selection-classes' stamp: ''!
selectedClassItems
	
	| unique classItem |
	unique := OrderedCollection new.
	selectedItems do: [ :each | 
		classItem := each systemDefinition definingClassItem.
		unique 
			detect: [:existing | existing actualObject == classItem actualObject] 
			ifNone: [unique add: classItem]].
	^unique! !

!ClyQueryBrowserContext methodsFor: 'selection-classes' stamp: ''!
lastSelectedClass
	
	^self lastSelectedItem systemDefinition definingClass! !

!ClyQueryBrowserContext methodsFor: 'selection-packages' stamp: ''!
isPackageSelected
	"here we extract selected packages from selected items"
	^self hasSelectedItems! !

!ClyQueryBrowserContext methodsFor: 'browser state' stamp: ''!
restoreBrowserState

	self browser selectObject: self lastSelectedObject! !

!ClyQueryBrowserContext methodsFor: 'selection-packages' stamp: ''!
lastSelectedPackage
	
	^self lastSelectedItem systemDefinition definingPackage! !

!ClyQueryBrowserContext methodsFor: 'selection-classes' stamp: ''!
selectedClassSide
	^self lastSelectedClass! !

!ClyQueryBrowserContext methodsFor: 'selection-methods' stamp: ''!
selectedMethodItems
	^selectedItems select: [ :each | each isBasedOnItemType: ClyMethod ]! !

!ClyQueryBrowserContext methodsFor: 'selection-classes' stamp: ''!
isClassSelected
	"here we extract selected classes from selected items"
	^self hasSelectedItems! !

!ClyQueryBrowserContext methodsFor: 'selection-methods' stamp: ''!
isMethodSelected
	"optimized version without extra collection copy"
	
	^selectedItems anySatisfy: [ :each | each isBasedOnItemType: ClyMethod  ]! !

!ClyQueryBrowserContext methodsFor: 'selection-packages' stamp: ''!
selectedPackageItems
	
	| unique packageItem |
	unique := OrderedCollection new.
	selectedItems do: [ :each | 
		packageItem := each systemDefinition definingPackageItem.
		unique 
			detect: [:existing | existing actualObject == packageItem actualObject] 
			ifNone: [unique add: packageItem]].
	^unique! !

!ClyQueryBrowserContext class methodsFor: 'selection strategy' stamp: ''!
selectionStrategy
	<classAnnotation>
	
	^ClyContextSelectionStrategyAnnotation for: ClyQueryBrowserMorph! !

!ClyQueryBrowserFilter commentStamp: ''!
I am a query filter which specifically created for the query browser which can represent different kind of items in one list.
I delegate actual testing logic to the actual object of given browser items:

	actualObject matchesQueryBrowserFilter: self

This method is implemented by methods, classes and class comments. So this objects can be shown and filtered in query browser.
Implementors call be back with #matchesString: messge where I check given string for my pattern.

I also provide special trick to filter items by script. To activate it the pattern string should be in form of one arg block. For example:
	[ :each | each linesOfCode > 10 ] 
Such block will be evaluated with actual object of browser item.
  
Internal Representation and Key Implementation Points.

    Instance Variables
	badScript:		<Boolean>
	scriptBlock:		<BlockClosure>!
!ClyQueryBrowserFilter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	badScript := false.! !

!ClyQueryBrowserFilter methodsFor: 'testing' stamp: ''!
matchesByScript: anObject

	badScript ifTrue: [ ^true ].
	scriptBlock ifNil: [ self createBlockFromPattern].
	badScript ifTrue: [ ^true ].	
	
	^[(scriptBlock value: anObject) ~~ false] onErrorDo: [ false ]! !

!ClyQueryBrowserFilter methodsFor: 'testing' stamp: ''!
matchesString: aString

	^pattern matches: aString! !

!ClyQueryBrowserFilter methodsFor: 'private' stamp: ''!
createBlockFromPattern

	(pattern value endsWith: ']') ifFalse: [
		badScript := true.
		^self].

	[scriptBlock := self class compiler evaluate: pattern value] 
		on: Exception do: [:err | badScript := true ]! !

!ClyQueryBrowserFilter methodsFor: 'testing' stamp: ''!
matches: aBrowserItem
	| actualObject |
	actualObject := aBrowserItem class = ClyBrowserItem 
		ifTrue: [ aBrowserItem actualObject] ifFalse: [ aBrowserItem ].
		
	(pattern value beginsWith: '[') ifTrue: [ 
			^self matchesByScript: actualObject].

	^actualObject matchesQueryBrowserFilter: self! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter classes' stamp: ''!
testNotMatchesClassWithWrongNameAndPackage

	filter := ClyQueryBrowserFilter substringPattern: 'filter not matches class name and package'.
	
	self deny: (filter matches: self itemOfThisTestClass)! !

!ClyQueryBrowserFilterTest methodsFor: 'helpers' stamp: ''!
itemOfThisTestMethod
	^ClyBrowserItem with: self class >> testSelector! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter methods' stamp: ''!
testNotMatchesMethodWithWrongClassAndPackageAndSelector

	filter := ClyQueryBrowserFilter substringPattern: 'filter not matches package, class or selector'.
	
	self deny: (filter matches: self itemOfThisTestMethod)! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter by script' stamp: ''!
testUsingBadScriptWithoutClosingBracket

	filter := ClyQueryBrowserFilter substringPattern: '[:each | true '.
	
	self assert: (filter matches: self itemOfThisTestMethod).
	self assert: (filter matches: (ClyBrowserItem with: Object >> #printString)).! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter classes' stamp: ''!
testMatchesClassWhichNameMatchesIt

	filter := ClyQueryBrowserFilter substringPattern: 'FilterTest'.
	
	self assert: (filter matches: self itemOfThisTestClass)! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter methods' stamp: ''!
testMatchesMethodOfClassWhichMatchesIt

	filter := ClyQueryBrowserFilter substringPattern: 'FilterTest'.
	
	self assert: (filter matches: self itemOfThisTestMethod)! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter methods' stamp: ''!
testMatchesMethodWithSelectorWhichMatchesIt

	filter := ClyQueryBrowserFilter substringPattern: 'MethodWithSelector'.
	
	self assert: (filter matches: self itemOfThisTestMethod)! !

!ClyQueryBrowserFilterTest methodsFor: 'helpers' stamp: ''!
itemOfThisTestClass
	^ClyBrowserItem with: self class! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter by script' stamp: ''!
testUsingBadScriptWhichNotReturnBoolean

	filter := ClyQueryBrowserFilter substringPattern: '[:each | each selector]'.
	
	self assert: (filter matches: self itemOfThisTestMethod).
	self assert: (filter matches: (ClyBrowserItem with: Object >> #printString)).! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter by script' stamp: ''!
testUsingUncompiledScript

	filter := ClyQueryBrowserFilter substringPattern: '[:each | each 123selector]'.
	
	self assert: (filter matches: self itemOfThisTestMethod).
	self assert: (filter matches: (ClyBrowserItem with: Object >> #printString)).! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter classes' stamp: ''!
testMatchesClassOfPackageWhichMatchesIt

	filter := ClyQueryBrowserFilter substringPattern: 'SystemQueries-Tests'.
	
	self assert: (filter matches: self itemOfThisTestClass)! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter by script' stamp: ''!
testUsingScript

	filter := ClyQueryBrowserFilter substringPattern: '[:each | each selector = #testUsingScript]'.
	
	self assert: (filter matches: self itemOfThisTestMethod).
	self deny: (filter matches: (ClyBrowserItem with: Object >> #printString)).! !

!ClyQueryBrowserFilterTest methodsFor: 'tests - filter methods' stamp: ''!
testMatchesMethodOfPackageWhichMatchesIt

	filter := ClyQueryBrowserFilter substringPattern: 'SystemQueries-Tests'.
	
	self assert: (filter matches: self itemOfThisTestMethod)! !

!ClyQueryBrowserMorph commentStamp: ''!
I am a query browser.
I show in one table result of any system query.

To show query use following method: 

	ClyQueryBrowser openOn: (ClyMessageSenders of: #do:)

I implement more simple API on class side: 

	ClyQueryBrowser browseSendersOf: #do:.
	ClyQueryBrowser browseImplementorsOf: #do:.
	ClyQueryBrowser browseMethods: {Point>>#x. Point>>#y}.

Last method is suitable to show given list of methods. But normally users should use first class queries.

I provide scoping mechanizm: user can filter query result using scopes from the compobox in toolbar.

When I spawned from the browser I receive all its navigation scopes.
For full browser I receive current selection package and class scopes.
For query browser I inherit all scopes which it has.
Also I add extra scopes to my scope list which is based on my current selection.
For example selected method will bring extra class and package scopes of this method.  

Internal Representation and Key Implementation Points.

    Instance Variables
	activeScope:		<ClyScope>
	queryScopes:		<OrderedCollection of<ClyScope>>
	resultView:		<ClyQueryView>
	systemQuery:		<ClyQuery>!
!ClyQueryBrowserMorph methodsFor: 'tools support' stamp: ''!
decorateMethodEditor: aMethodEditor

	systemQuery decorateResultMethodEditor: aMethodEditor! !

!ClyQueryBrowserMorph methodsFor: 'initialization' stamp: ''!
initializeNavigationViews
	resultView := self newNavigationView.
	resultView enableFilter: ClyQueryBrowserFilter.
	resultView allowsDeselection: false.
	resultView mainColumn 
		width: 250;
		displayItemPropertyBy: [:item | self classNameOf: item].
	(resultView addColumn: #name) 
		width: 200;
		displayItemPropertyBy: [:item | self mainNameOf: item].
	(resultView addColumn: #protocol) 
		width: 200;
		displayItemPropertyBy: [:item | self protocolNameOf: item].
	(resultView addColumn: #package) 
		width: 50;
		displayItemPropertyBy: [:item | self packageNameOf: item]! !

!ClyQueryBrowserMorph methodsFor: 'initialization' stamp: ''!
packageNameOf: aBrowserItem

	^aBrowserItem systemDefinition definingPackageItem name! !

!ClyQueryBrowserMorph methodsFor: 'initialization' stamp: ''!
setUpActiveScope
	systemQuery isBoundToEnvironment ifFalse: [ 
		systemQuery := systemQuery withScope: self systemScope].
	(queryScopes includes: systemQuery scope) ifFalse: [ 
		queryScopes add: systemQuery scope ].	
	activeScope := systemQuery scope! !

!ClyQueryBrowserMorph methodsFor: 'initialization' stamp: ''!
mainNameOf: aBrowserItem
	aBrowserItem type = ClyClass ifTrue: [ ^'' ].
	
	^aBrowserItem name! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToHierarchicalResult

	DefaultQueryResult := ClyHierarchicalSystemItemsResult new.
	self switchResultTo: DefaultQueryResult! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
selectMethod: aMethod 

	self selectObject: aMethod! !

!ClyQueryBrowserMorph methodsFor: 'initialization' stamp: ''!
prepareInitialState
	"no initialization is required.
	If user do not set up system query I will be just with empty list"! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
expectedFlatQueryResult: anObject
	expectedFlatQueryResult := anObject! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
packageScopeOfSelectedItems
	| packages |
	packages := self selection items
		collect: [ :methodItem | methodItem systemDefinition definingPackage ].
	^ ClyPackageScope ofAll: packages in: navigationEnvironment! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
methodSelection
	^self selection asSelectedItemsOf: ClyMethod! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
showResultOf: aQuery
	"If given query has specific result then browser will show it as requested.
	Otherwise it will force query to build currently configured required result 
	(when given query has no explicitly specified result which means it has only default value)"		
	self changeStateBy: [
		systemQuery := aQuery buildsDefaultResult 
			ifTrue: [aQuery withResult: self requiredQueryResult]
			ifFalse: [ aQuery ].
		self showQueryResult
	]! !

!ClyQueryBrowserMorph methodsFor: 'testing' stamp: ''!
showsQueryResultAs: aQueryResult

	^systemQuery requiredResult = aQueryResult! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
selectClass: aClass 

	self selectObject: aClass! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
switchScopeTo: aScope
	
	self changeStateBy: [
		systemQuery := systemQuery withScope: aScope.
		self showQueryResult]! !

!ClyQueryBrowserMorph methodsFor: 'testing' stamp: ''!
isQueryScopeActive: aScope

	^self activeScope = aScope! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
queryScopes
	^queryScopes! !

!ClyQueryBrowserMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	queryScopes := OrderedCollection new.
	expectedFlatQueryResult := self defaultFlatQueryResult! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
requiredQueryResult
	^systemQuery 
		ifNil: [self class defaultQueryResult]
		ifNotNil: [ systemQuery requiredResult  ]! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
activeScope
	^activeScope ifNil: [ activeScope := self systemScope ]! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
allNavigationScopes
	| extraScopes |
	extraScopes := self extraScopesOfSelectedItems reject: #isBasedOnEmptyBasis.
	^queryScopes, (extraScopes copyWithoutAll: queryScopes)! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
selection
	^resultView selection! !

!ClyQueryBrowserMorph methodsFor: 'initialization' stamp: ''!
protocolNameOf: aClyBrowserItem 
	^ aClyBrowserItem systemDefinition printDefiningProtocol! !

!ClyQueryBrowserMorph methodsFor: 'opening/closing' stamp: ''!
openAnotherBrowser: aBrowser
	(aBrowser isKindOf: ClyQueryBrowserMorph)
		ifTrue: [ aBrowser openInWindow: self window]
		ifFalse: [ aBrowser open ]! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
spawnFullBrowser
	super spawnFullBrowser.
	
	self itemCount = 1 ifTrue: [ 
		[self close] on: ProvideAnswerNotification do: [:notification | 
			"If we have ditry tabs we are not able close it"
			notification resume: false]
	].! !

!ClyQueryBrowserMorph methodsFor: 'testing' stamp: ''!
showsFlatResult

	^(systemQuery retrievesItemsAs: ClyHierarchicalSystemItemsResult) not! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
systemQuery
	^ systemQuery! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
chooseClassesForNewMethod: aMethod
	^{aMethod origin}! !

!ClyQueryBrowserMorph methodsFor: 'updating' stamp: ''!
newWindowTitle
	| title | 
	title := systemQuery description.
	resultView areItemsLoaded 
		ifTrue: [title := title capitalized , ' [' ,  self itemCount asString, ']']
		ifFalse: [title := 'Loading: ', title ].
	
	self systemScope isCurrentImage ifFalse: [ 
		title := title , ' in ', self systemScope description ].
	
	^title! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
expectedFlatQueryResult
	^ expectedFlatQueryResult! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
classScopeOfSelectedItems
	| classes |
	classes := self selection items
		collect: [ :methodItem | methodItem systemDefinition definingClass ].
	^ ClyBothMetaLevelClassScope ofAll: classes in: navigationEnvironment! !

!ClyQueryBrowserMorph methodsFor: 'initialization' stamp: ''!
showQueryResult	
	self showsFlatResult ifTrue: [ 
		"Browser keeps flat query result in variable 
		to be able switch back to it later from hierarchy mode"	
		expectedFlatQueryResult := systemQuery requiredResult ].
	
	self setUpActiveScope.
	resultView showQuery: systemQuery semiAsync! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
selectLastItem
	
	self changeStateBy: [
		resultView selectLastItem
	]! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
navigateSpawnedFullBrowser: aFullBrowser

	| lastItem definition |
	aFullBrowser setUpScopedModeWith: self activeScope.
	
	lastItem := self selection lastSelectedItem.
	definition := lastItem systemDefinition.
	
	aFullBrowser selectPackage: definition definingPackage.
	aFullBrowser selectClass: definition definingClass.
	
	(definition isKindOf: ClyMethodDefinitionProperty) ifTrue: [ 
		aFullBrowser selectMethod: lastItem actualObject].! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
snapshotState
	
	^ClyQueryBrowserState of: self! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
resultView
	^ resultView! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
spawnQueryBrowserOn: aQuery withState: navigationState
	
	| actualQuery |
	actualQuery := aQuery isBoundToEnvironment 
		ifTrue: [ aQuery ]
		ifFalse: [ aQuery withScope: activeScope].
	
	super spawnQueryBrowserOn: actualQuery withState: navigationState! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
selectObject: anObject 
	| foundItems |
	self changeStateBy: [
		foundItems := resultView findItemsWith: { anObject }.
	
		foundItems ifNotEmpty: [ 
			self selection selectItems: foundItems ]
	]! !

!ClyQueryBrowserMorph methodsFor: 'initialization' stamp: ''!
classNameOf: aBrowserItem

	^aBrowserItem systemDefinition printDefiningClass! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
defaultNavigationScope
	^self activeScope! !

!ClyQueryBrowserMorph methodsFor: 'initialization' stamp: ''!
defaultFlatQueryResult
	^ClySortedQueryResult using: ClySortSystemItemFunction ascending! !

!ClyQueryBrowserMorph methodsFor: 'testing' stamp: ''!
isClassSelected: aClass

	^self selection items anySatisfy: [ :methodItem |
		methodItem systemDefinition definingClass == aClass ]! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
queryScopes: scopesCollection
	queryScopes := (scopesCollection
		reject: [ :each | each isBasedOnEmptyBasis])
		as: OrderedCollection! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
activeScope: anEnvironmentScope
	activeScope := anEnvironmentScope! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
switchResultTo: aQueryResult

	self changeStateBy: [
		systemQuery := systemQuery withResult: aQueryResult.
		self showQueryResult
	]! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
systemQuery: anObject
	systemQuery := anObject! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
itemCount
	^resultView itemCount! !

!ClyQueryBrowserMorph methodsFor: 'navigation' stamp: ''!
switchToFlatResult
	"There is only type of default flat query result.
	If user passes query with specific flat result it should not modify default one.
	So senders and implementors will continue use same type of flat result.
	But when browser opens on query with special result it will use it localy to switch result mode"
	DefaultQueryResult := self defaultFlatQueryResult.
	self switchResultTo: expectedFlatQueryResult! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
chooseClassForEditorOfMethod: aMethod
	^aMethod origin! !

!ClyQueryBrowserMorph methodsFor: 'accessing' stamp: ''!
extraScopesOfSelectedItems
	| classScope |
	classScope := self classScopeOfSelectedItems.
	^{
		self packageScopeOfSelectedItems. 
		classScope asFullHierarchyScope.
		classScope
	}, RefactoringSettings availableScopes! !

!ClyQueryBrowserMorph methodsFor: 'updating' stamp: ''!
rebuildToolsForChangedEnvironment
	super rebuildToolsForChangedEnvironment.
	
	tabManager tools ifEmpty: [ 
		resultView ensureSelectedItem.
		self rebuildAllTools ].
	self updateWindowTitle! !

!ClyQueryBrowserMorph class methodsFor: 'default' stamp: ''!
defaultQueryResult
	^DefaultQueryResult ifNil: [ 
		DefaultQueryResult := ClyHierarchicalSystemItemsResult new]! !

!ClyQueryBrowserMorph class methodsFor: 'opening' stamp: ''!
browseMethods: methods withTitle: aString
	^self openOn: (ClyConstantMethodQuery named: aString with: methods)! !

!ClyQueryBrowserMorph class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for an instance of the receiver in a task bar"

	^#referencesIcon! !

!ClyQueryBrowserMorph class methodsFor: '*Calypso-SystemTools-OldToolCompatibillity' stamp: ''!
beDefaultBrowser
	<script>
	^ClyOldMessageBrowserAdapter beDefaultBrowser! !

!ClyQueryBrowserMorph class methodsFor: 'opening' stamp: ''!
openOn: aQuery
	| browser |
	browser := self on: ClyNavigationEnvironment currentImage.
	browser showResultOf: aQuery.
	^browser open! !

!ClyQueryBrowserMorph class methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
browseBreakpointsIncludingHaltsForTesting
	| query |
	query := ClyActiveBreakpointsQuery newIncludingHaltsForTesting withResult: (ClySortedQueryResult using: ClySortMethodByPackageFunction ascending).
	^ClyQueryBrowserMorph openOn: query! !

!ClyQueryBrowserMorph class methodsFor: 'opening' stamp: ''!
browseImplementorsOf: aSymbol
	^self openOn: (ClyMessageImplementorsQuery of: aSymbol)! !

!ClyQueryBrowserMorph class methodsFor: 'opening' stamp: ''!
browseSendersOf: aSymbol
	^self openOn: (ClyMessageSendersQuery of: aSymbol)! !

!ClyQueryBrowserMorph class methodsFor: 'instance creation' stamp: ''!
on: aNavigationEnvironment scopes: scopes

	^(self on: aNavigationEnvironment) 
		queryScopes: scopes! !

!ClyQueryBrowserMorph class methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
browseBreakpoints
	"Excludes methods that contain halts marked as for testing. To browse all breakpoints, see this class's browseBreakpointsIncludingHaltsForTesting method"
	| query |
	query := ClyActiveBreakpointsQuery as: (ClySortedQueryResult using: ClySortMethodByPackageFunction ascending).
	^ClyQueryBrowserMorph openOn: query! !

!ClyQueryBrowserMorph class methodsFor: 'opening' stamp: ''!
browseClasses: classes
	^self openOn: (ClyConstantQuery returning: classes)! !

!ClyQueryBrowserMorph class methodsFor: 'opening' stamp: ''!
browseMethods: methods
	^self openOn: (ClyConstantMethodQuery with: methods)! !

!ClyQueryBrowserState commentStamp: ''!
I represent query browser state which includes active scope and active query and extra scopes list. 
 
Internal Representation and Key Implementation Points.

    Instance Variables
	activeScope:		<Object>
	methodQuery:		<Object>
	queryScopes:		<Object>!
!ClyQueryBrowserState methodsFor: 'accessing' stamp: ''!
expectedFlatQueryResult
	^ expectedFlatQueryResult! !

!ClyQueryBrowserState methodsFor: 'accessing' stamp: ''!
queryScopes
	^ queryScopes! !

!ClyQueryBrowserState methodsFor: 'private' stamp: ''!
restoreStateOf: aBrowser
	super restoreStateOf: aBrowser.
	
	aBrowser  
		systemQuery: methodQuery;
		queryScopes: queryScopes;
		activeScope: activeScope;
		expectedFlatQueryResult: expectedFlatQueryResult! !

!ClyQueryBrowserState methodsFor: 'accessing' stamp: ''!
queryScopes: anObject
	queryScopes := anObject! !

!ClyQueryBrowserState methodsFor: 'accessing' stamp: ''!
activeScope: anObject
	activeScope := anObject! !

!ClyQueryBrowserState methodsFor: 'accessing' stamp: ''!
activeScope
	^ activeScope! !

!ClyQueryBrowserState methodsFor: 'accessing' stamp: ''!
expectedFlatQueryResult: anObject
	expectedFlatQueryResult := anObject! !

!ClyQueryBrowserState methodsFor: 'accessing' stamp: ''!
systemQuery: anObject
	methodQuery := anObject! !

!ClyQueryBrowserState methodsFor: 'operations' stamp: ''!
retrieveStateFrom: aBrowser
	super retrieveStateFrom: aBrowser.
	
	queryScopes := aBrowser queryScopes.
	activeScope := aBrowser activeScope.
	methodQuery := aBrowser systemQuery.
	expectedFlatQueryResult := aBrowser expectedFlatQueryResult! !

!ClyQueryBrowserState methodsFor: 'accessing' stamp: ''!
systemQuery
	^ methodQuery! !

!ClyQueryBrowserState methodsFor: 'private' stamp: ''!
createBrowser
	^ClyQueryBrowserMorph new! !

!ClyQueryBrowserStateTest methodsFor: 'running' stamp: ''!
restoreBrowserInstance

	self snapshotState.
	
	navigationState applyTo: browser! !

!ClyQueryBrowserStateTest methodsFor: 'tests' stamp: ''!
testRestoredBrowserInstanceWithActiveScope

	browser activeScope: browser queryScopes last.
	
	self restoreBrowserInstance.
	
	self assert: browser activeScope equals: browser queryScopes last! !

!ClyQueryBrowserStateTest methodsFor: 'tests' stamp: ''!
testRestoredBrowserInstanceWithMethodQuery

	| query |
	query := ClyAllMethodsQuery sorted.
	browser systemQuery: query.
	
	self restoreBrowserInstance.
	
	self assert: browser systemQuery equals: query! !

!ClyQueryBrowserStateTest methodsFor: 'tests' stamp: ''!
testRetrievesExpectedFlatQueryResult

	self snapshotState.
	
	self assert: navigationState expectedFlatQueryResult equals: browser expectedFlatQueryResult! !

!ClyQueryBrowserStateTest methodsFor: 'tests' stamp: ''!
testRetrievesQueryScopes

	self snapshotState.
	
	self assert: navigationState queryScopes equals: browser queryScopes! !

!ClyQueryBrowserStateTest methodsFor: 'tests' stamp: ''!
testRestoredBrowserInstanceWithExpectedFlatQueryResult

	self restoreBrowserInstance.
	
	self assert: navigationState expectedFlatQueryResult notNil.
	self assert: browser expectedFlatQueryResult equals: navigationState expectedFlatQueryResult! !

!ClyQueryBrowserStateTest methodsFor: 'tests' stamp: ''!
testRestoredBrowserInstanceWithQueryScopes

	self restoreBrowserInstance.
	self assert: navigationState queryScopes size equals: 2.
	
	self assert: browser queryScopes equals: navigationState queryScopes.! !

!ClyQueryBrowserStateTest methodsFor: 'tests' stamp: ''!
testRetrievesActiveScope

	self snapshotState.
	
	self assert: navigationState activeScope equals: browser activeScope! !

!ClyQueryBrowserStateTest methodsFor: 'tests' stamp: ''!
testRetrievesMethodQuery

	self snapshotState.
	
	self assert: navigationState systemQuery equals: browser systemQuery! !

!ClyQueryBrowserStateTest methodsFor: 'running' stamp: ''!
createBrowser
	^ ClyQueryBrowserMorph on: environment scopes: {
			ClyBothMetaLevelClassScope of: ClyClass1FromP1Mock in: environment.
			ClyBothMetaLevelClassScope of: ClyClass2FromP1Mock in: environment}	"class with methods"! !

!ClyQueryBrowserStateTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	browser showResultOf: (ClyAllMethodsQuery sortedFrom: browser queryScopes first)! !

!ClyQueryExampleTest methodsFor: 'tests' stamp: ''!
testCreationUnifiedInstanceWhenThereIsExtraScopeParameter

	| unifiedInstance |
	query extraParameter: #testParameter.
	
	unifiedInstance := query asUnifiedInstance.
	
	self assert: unifiedInstance extraParameter equals: #testParameter! !

!ClyQueryExampleTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewScopeWhenThereIsExtraQueryParameter
	| newScope convertedQuery |
	query extraParameter: #testParameter.
	newScope := ClyExample2Scope of: #someBasis in: environment.
	
	convertedQuery := query withScope: newScope.
	
	self assert: convertedQuery extraParameter equals: #testParameter! !

!ClyQueryExampleTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyReturningScopeBasisExampleQuery from: ClyExampleScope of: #basisObject in: environment! !

!ClyQueryMenuGroup commentStamp: ''!
I am reusable menu group for commands.
I am supposed to group commands which are related to querying the system!
!ClyQueryMenuGroup methodsFor: 'accessing' stamp: ''!
order
	^1! !

!ClyQueryMenuGroup methodsFor: 'accessing' stamp: ''!
name
	^'Query'! !

!ClyQueryMenuGroup methodsFor: 'testing' stamp: ''!
isInlined
	^true! !

!ClyQueryNavigationResultTest methodsFor: 'tests' stamp: ''!
testIsBuiltWhenItemsExist
	
	queryResult initializeItems.
	
	self assert: queryResult isBuilt! !

!ClyQueryNavigationResultTest methodsFor: 'tests' stamp: ''!
testItemsChangedNotificationShouldResetItems
	
	queryResult initializeItems.
	self assert: queryResult isBuilt.
	
	queryResult itemsChanged.
	
	self deny: queryResult isBuilt.
	self assert: queryResult items isNil! !

!ClyQueryNavigationResultTest methodsFor: 'tests' stamp: ''!
testComparisonWithCopy

	| queryResult2 |
	queryResult2 := queryResult copy.
	
	self assert: queryResult equals: queryResult2! !

!ClyQueryNavigationResultTest methodsFor: 'tests' stamp: ''!
testComparisonWithSimilarResult

	| queryResult2 |
	queryResult := self createQueryResult.
	queryResult2 := self createQueryResult.
	
	self assert: queryResult equals: queryResult2.
	self assert: queryResult hash equals: queryResult2 hash! !

!ClyQueryNavigationResultTest methodsFor: 'tests' stamp: ''!
testComparisonWithItself

	self assert: queryResult equals: queryResult! !

!ClyQueryNavigationResultTest methodsFor: 'tests' stamp: ''!
testNeedsRebuildByDefault
	
	queryResult := self createQueryResult.
	
	self assert: queryResult needsRebuild! !

!ClyQueryNavigationResultTest methodsFor: 'running' stamp: ''!
createQueryResult
	self subclassResponsibility! !

!ClyQueryNavigationResultTest methodsFor: 'tests' stamp: ''!
testForceLazyRebuild
	
	self assert: queryResult items notNil.
	
	queryResult forceLazyRebuild.
	
	self assert: queryResult needsRebuild! !

!ClyQueryNavigationResultTest methodsFor: 'tests' stamp: ''!
testPreparation
	| newQuery newResult |
	newQuery := self createQuery.
	newResult := queryResult prepareNewFor: newQuery in: environment.

	self assert: newResult class equals: queryResult class.
	self deny: newResult identicalTo: queryResult.
	self assert: newResult buildingQuery identicalTo: newQuery.
	self assert: newResult environment equals: environment.
	self assert: newResult isProtected! !

!ClyQueryNavigationResultTest methodsFor: 'running' stamp: ''!
createQuery

	^ClyReturningScopeBasisExampleQuery 
		from: (ClyExampleScope emptyIn: environment)! !

!ClyQueryNavigationResultTest methodsFor: 'tests' stamp: ''!
testComparisonWithAnotherKindOfResult
	self deny: queryResult equals: ClyQueryResult new! !

!ClyQueryNavigationResultTest methodsFor: 'tests' stamp: ''!
testCheckingForEmpty
	self
		assert: queryResult isEmpty;
		deny: queryResult notEmpty! !

!ClyQueryNavigationResultTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	query := self createQuery.
	
	queryResult := self createQueryResult prepareNewFor: query in: environment.
	queryResult cancelRebuild. 
	"by default result is in state to be rebuilt by query.
	We do not need it in tests where we usually just test fillWith: logic"! !

!ClyQueryNavigationResultTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyQueryNavigationResultTest! !

!ClyQueryResult commentStamp: ''!
I represent collection of items retrieved by query from environment. 
My subclasses implement specific format or transformation of items. They should implement method:

- fillWith: items 

Any query has special parameter #requiredResult which specifies what kind of result should represent retrieved items. It is an instance of result which is used as prototype to create actual result instances. 

When query is executed at first time the navigation environment prepares new instance of required result:
	
	actualResult := aQuery prepareNewResult.

where query asks #requiredResult for: 

	actualResult := requiredResult prepareNewFor: aQuery in: environment

Then actualResult is cached using query as a key. And subsequent query execution just returns existing value.

Thus my instances describe required result and they can be implemented using composition of other objects. So different instances of same result class can lead to different result of query.
For example there is ClySortedQueryResult with #sortFunction variable. It allows to sort retrieved items using different criteria and different direction (ascending or descending).

Since requiredResult is part of query it is used in query comparison and hashing logic. And therefore my subclasses should correctly implement equality and hash operations when they introduce new parameters.
Also instances which are used as required result should be immutable because instead modification of result can corrupt cache of queries. 
To ensure this property #requiredResult is marked as readOnlyObject when it is assigned to the query.

Actual query execution is initiated by me using method #rebuildIfNeeded. Navigation environment calls it before returning result to the user.

I maintain special flag #needsRebuild to detect that existing items are dirty or are not built yet. So at first time #rebuildIfNeeded will lead to actual query execution (result building). But then it will do nothing until update will be not requested again.

So #rebuildIfNeeded will call #rebuild which will ask #buildingQuery to build result: 

	aQuery buildResult: self 

At the end aQuery fills result instance with items retrieved from the scope of environment.

Notice that #rebuild itself is private method. Users should use #rebuildIfNeeded. In fact users do not need it too because it is lazely evaluated when my items are accessed. But in case when query is executed it is evaluated explicitly by navigation environment. So callers always receive fresh result.

In the case when you want force items update there are two methods: 

- forceRebuild 
It set flag #needsRebuild to true and notify observers about changes (observers will be explained below).

- forceLazyRebuild 
It silently set flag #needsRebuild to true without any notification to observers.

In first case observers can handle notification by requesting new items from the result instance.
For example if UI widget observes result items and shows them to the user the #forceRebuild message will update shown items immediately. 
But #forceLazyRebuild will not update items until user request it manually.
In addition both methods reset items to nil.

There is extra helper method #cancelRebuild which reset rebuild flag and reset items to the empty collection.

My instances are safe to be used from multiple processes. Building and updating of items are protected by my #accessGuard mutex.

I provide several methods to access built items: 

- itemsStartingAt: startIndex count: size

- itemsStartingWhere: conditionBlock count: size
It finds first item where condition is true and then it returns "size" items starting from the found position

- itemsWhere: conditionBlock
It collects all items where conditionBlock is true

- allItems

- size

- isEmpty

These methods are safe to be used at any time: when user calls them I first ensure that items are ready and if not I rebuild them. 
Also I protect these methods by #accessGuard mutex. So it is safe to access items from multiple processes.
To ensure this logic I use helper method #protectItemsWhile:.

So I am cached by navigation environment. And this cache requires updates when underlying system is changed.
For this purpose navigation environment subscribes on system changes. And when any change happens the environment asks every result in cache to handle given event object:

	aQueryResult handleSystemChange: aSystemAnnouncement
 
To handle system change I ask my #buildingQuery if it is affected by given event. And if it is affected I force rebuild using #itemsChanged method where I announce that I was changed.
I allow my users to be notified when my items are changed. Users should subscribe to me using #subscribe: method:
	
	aQueryResult subscribe: anObserver 
	
Underhood I subscribe anObserver for ClyEnvironmentChanged to my #announcer. And it will be notified using #itemsChanged message. So observers should implement this method.
Also observers must #unsubscribe: when they are not interested anymore. 

For the UI support I provide special stream kind access in the form of ClyBrowserQueryCursor instance which returns items as ClyBrowserItem instances.
ClyBrowserItem is a wrapper over actual result item which provides UI specific information like position in the result, depth in the hierarchy and extendable set of properties related to the underlying object.
To get cursor instance you should open it for concrete observer:

	cursor := aQueryResult openBrowserCursorFor: anObserver

anObserver will be subscribed on my changes and new cursor instance will be returned to the caller.
When cursor is not needed anymore it should be closed. It will unsubscribe observer in addition:

	cursor close

With cursor you are able access items as ClyBrowserItem instances. For example: 

	cursor currentItem.
	cursor moveToNext.
	cursor findItemsWhere: conditionBlock 
	
The important responsibility of cursor is to organize cache of retrieved browser items. It is especially important for remote scenario where cache represents loaded remote items. But also it caches all extended properties collected for items by environment plugins.  

So cursor expects instances of ClyBrowserItem from inderlying query result. 
Some my subclasses build them directly from retrieved raw items. They are subclasses of ClyBrowseQueryResult. They provide extra query methods to lookup browser items.
When cursor is requested for such result it is just created over receiver instance.
But other result classes can't be used directly in cursor because they have no knowledge about browser items. For example ClyRawQueryResult just returns raw objects which were retrieved by query.
For such cases I provide special adapter ClyQueryResultBrowserAdapter: by default cursor instance is always created over adapter which wraps actual result instance.
Adapter converts actual items to the ClyBrowserItem instances and implements same query methods as ClyBrowserQueryResult.
This logic is implemented in method #adoptForBrowser which is overridden by ClyBrowserQueryResult with self return.

For more details about cursor look at ClyBrowserQueryCursor comments. And read comments of ClyBrowserItem.

The last feature which I provide for my subclasses is metadata. I compute it lazily on demand and keed it in the #metadata variable. Metadata is updated together with items. So when items are changed the metadata is reset and subsequent call for it will recompute it again.
The metadata is an instance of ClyQueryResultMetadata which represents extended properties of result in general. For example the result of class query can include the count of success tests as metadata property.
Properties are represented by first class objects, a kind of ClyProperty.
The metadata is collected using environment plugins. So it is extended by them. 
Plugins collect information of concrete type of result items. For example: 
	
		plugin collectMetadataOfClasses: aQueryResult
		plugin collectMetadataOfMethods: aQueryResult
		
The decision what method to use is responsibility of #buildingQuery which knows what kind of items it retrieves:

	metadata := ClyQueryResultMetadata new.
	environment pluginsDo: [:each | 
		buildingQuery collectMetadataOf: self by: each	]

So every query class should implement the method #collectMetadataOf:by:.

To access metadata there are several methods:

- addMetaProperty: aProperty
- getMetaProperty: aPropertyClass
- hasMetaProperty: aPropertyClass	
- metadata

Same protocol is also implemented in ClyBrowserQueryCursor. So with cursor instance you are also able to access metadata of query result.


Internal Representation and Key Implementation Points.

    Instance Variables
	announcer:		<Announcer>
	buildingQuery:		<ClyQuery>
	environment:		<ClyNavigationEnvironment>
	items:		<SequenceableCollection of<ClyBrowserItem>>
	metadata:	<ClyQueryResultMetadata>
	accessGuard:	<Mutex>
	needsRebuild:	Boolean!
!ClyQueryResult methodsFor: 'system changes' stamp: ''!
notifyObservers

	announcer ifNil: [ ^self ].	
	environment announceChangesOf: self! !

!ClyQueryResult methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ items hash! !

!ClyQueryResult methodsFor: 'system changes' stamp: ''!
handleSystemChange: aSystemAnnouncement byProcessingList: allProcessingResults 
	needsRebuild ifTrue: [ ^allProcessingResults remove: self ]. 
	aSystemAnnouncement shouldBeConsideredByCalypsoEnvironment 
		ifFalse: [ ^allProcessingResults remove: self ]. "some system events can happen in wrong system state or be just obsolete. This little hook allows skip such events"
	accessGuard 
		tryEnterCritical: [self handleSystemChange: aSystemAnnouncement]
		ifLocked: [ ^self ].
		
	allProcessingResults remove: self! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!ClyQueryResult methodsFor: 'converting' stamp: ''!
adoptForBrowser

	^ClyQueryResultBrowserAdapter for: self! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
addMetaProperty: aProperty
	"I allow to annotate result about its internal items. For example SUnit plugin annotate method query result with summary about test runs"
	
	self metadata addProperty: aProperty! !

!ClyQueryResult methodsFor: 'system changes' stamp: ''!
handleSystemChange: aSystemAnnouncement
	needsRebuild ifTrue: [ ^self ].
	aSystemAnnouncement shouldBeConsideredByCalypsoEnvironment ifFalse: [ ^self ]. "some system events can happen in wrong system state or be just obsolete. This little hook allows skip such events"	

	self protectAccessWhile: [
		(buildingQuery isResult: self affectedBy: aSystemAnnouncement)
			ifTrue: [ self itemsChanged]]! !

!ClyQueryResult methodsFor: 'initialization' stamp: ''!
defaultItems
	^OrderedCollection new! !

!ClyQueryResult methodsFor: 'building' stamp: ''!
fillWith: queriedObjects
	self subclassResponsibility! !

!ClyQueryResult methodsFor: 'testing' stamp: ''!
isProtected
	^accessGuard notNil! !

!ClyQueryResult methodsFor: 'system changes' stamp: ''!
itemsChanged

	self forceRebuild! !

!ClyQueryResult methodsFor: 'queries' stamp: ''!
allItems

	^self itemsStartingAt: 1 count: self size! !

!ClyQueryResult methodsFor: 'queries' stamp: ''!
itemsWhere: conditionBlock	
	^self protectItemsWhile: [ 
		items select: conditionBlock]! !

!ClyQueryResult methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	needsRebuild := true! !

!ClyQueryResult methodsFor: 'system changes' stamp: ''!
notifyChanges

	announcer announce: ClyEnvironmentChanged! !

!ClyQueryResult methodsFor: 'queries' stamp: ''!
itemsStartingWhere: conditionBlock count: size

	| firstItemIndex |
	firstItemIndex := items findFirst: conditionBlock.
	firstItemIndex = 0 ifTrue: [ ^#() ].
	^self itemsStartingAt: firstItemIndex count: size! !

!ClyQueryResult methodsFor: 'testing' stamp: ''!
needsRebuild
	^needsRebuild! !

!ClyQueryResult methodsFor: 'building' stamp: ''!
rebuild
	self initializeItems.
	buildingQuery buildResult: self.
	metadata := nil	"metadata is computed and updated lazily"! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
size
	^self protectItemsWhile: [items size]! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
openBrowserCursorFor: anItemObserver

	| cursor |
	cursor := ClyBrowserQueryCursor for: self adoptForBrowser.
	cursor openFor: anItemObserver.
	^cursor.! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
rawItemsOf: itemTypeClass do: aBlock

	^self rawItemsDo: [:each | 
		each calypsoEnvironmentType = itemTypeClass ifTrue: [ 
			aBlock value: each ]
	]! !

!ClyQueryResult methodsFor: 'building' stamp: ''!
cancelRebuild

	items ifNil: [self initializeItems].
	needsRebuild := false! !

!ClyQueryResult methodsFor: 'testing' stamp: ''!
notEmpty
	^self isEmpty not! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
itemAt: index
	^items at: index! !

!ClyQueryResult methodsFor: 'queries' stamp: ''!
itemsStartingAt: startIndex count: size

	^self protectItemsWhile: [	
		items copyFrom: startIndex to: (startIndex + size - 1 min: items size)]! !

!ClyQueryResult methodsFor: 'building' stamp: ''!
forceLazyRebuild
	"This method allows reset result cache without observers notification.
	It can be suitable for some queries to not force observers update after changes
	but instead allow them update items manually. 
	After this method is called observers will be updated only when they will try access items again"
	
	self protectAccessWhile: [ 	
		needsRebuild := true.
		items := nil]! !

!ClyQueryResult methodsFor: 'initialization' stamp: ''!
collectMetadata
	self protectAccessWhile: [ 
		metadata ifNotNil: [ ^self ].

		metadata := ClyQueryResultMetadata new.
		environment pluginsDo: [:each | 
			buildingQuery collectMetadataOf: self by: each	]
	]! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
buildingQuery
	^ buildingQuery! !

!ClyQueryResult methodsFor: 'building' stamp: ''!
forceRebuild

	self forceLazyRebuild.
	
	self notifyObservers! !

!ClyQueryResult methodsFor: 'testing' stamp: ''!
isEmpty
	^self size = 0! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!ClyQueryResult methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ items = anObject items! !

!ClyQueryResult methodsFor: 'system changes' stamp: ''!
hasSubscriber: anObject

	announcer ifNil: [ ^false].
	
	^announcer hasSubscriber: anObject! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
rawItemsDo: aBlock

	^self rawItems do: aBlock! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
buildingQuery: anEnvironmentQuery
	buildingQuery := anEnvironmentQuery! !

!ClyQueryResult methodsFor: 'private' stamp: ''!
beProtected
	accessGuard := Mutex new! !

!ClyQueryResult methodsFor: 'building' stamp: ''!
buildWith: objects
	"it is suitable method to build result manually avoiding query logic.
	needsRebuild false value will prevent rebuilding when accessing items which were manually filled"
	needsRebuild := false.
	self initializeItems.
	self fillWith: objects! !

!ClyQueryResult methodsFor: 'initialization' stamp: ''!
prepareNewFor: aQuery in: aNavigationEnvironment
	^self copy 
		environment: aNavigationEnvironment;
		buildingQuery: aQuery;
		beProtected.! !

!ClyQueryResult methodsFor: 'private' stamp: ''!
protectAccessWhile: aBlock

	^accessGuard critical: [
		aBlock value
	]! !

!ClyQueryResult methodsFor: 'testing' stamp: ''!
representsBrowserItems
	^false! !

!ClyQueryResult methodsFor: 'system changes' stamp: ''!
unsubscribe: anObject

	announcer ifNil: [ ^self ].
	announcer unsubscribe: anObject! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
rawItems
	^items! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
announcer
	^announcer! !

!ClyQueryResult methodsFor: 'private' stamp: ''!
protectItemsWhile: aBlock

	^self protectAccessWhile: [ 
		self rebuildIfNeeded.
		aBlock value
	]! !

!ClyQueryResult methodsFor: 'system changes' stamp: ''!
subscribe: anObject

	announcer ifNil: [ announcer := Announcer new].
	
	announcer when: ClyEnvironmentChanged send: #itemsChanged to: anObject! !

!ClyQueryResult methodsFor: 'testing' stamp: ''!
isBuilt
	^items notNil! !

!ClyQueryResult methodsFor: 'initialization' stamp: ''!
initializeItems
	items := self defaultItems! !

!ClyQueryResult methodsFor: 'testing' stamp: ''!
hasMetaProperty: aPropertyClass

	^self metadata hasProperty: aPropertyClass! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
items: anObject
	items := anObject! !

!ClyQueryResult methodsFor: 'building' stamp: ''!
rebuildIfNeeded
	self protectAccessWhile: [
		
		needsRebuild ifTrue: [ 
			needsRebuild := false.
			self rebuild]
		
	]! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
getMetaProperty: aPropertyClass
	^self metadata getProperty: aPropertyClass! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
items
	^ items! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
scope
	^buildingQuery scope! !

!ClyQueryResult methodsFor: 'accessing' stamp: ''!
metadata
	^metadata ifNil: [ self collectMetadata. metadata ]! !

!ClyQueryResult class methodsFor: 'testing' stamp: ''!
isExpandedHierarchy
	^false! !

!ClyQueryResultBrowserAdapter commentStamp: ''!
I adopt arbitrary query result to ClyBrowserQueryResult.
I implement query interface of ClyBrowserQueryResult and convert actual raw items to the ClyBrowserItem instances. 
I prepare converted browser items with full semantics of ClyBrowserQueryResult. So all requested items include precomputed properties.

I am used to be able represent any query result in the browser. 
Browser always work with result using cursor. And cursor expects to be created over ClyBrowserQueryResult. So I am used to open cursor on any other kind of result. The hook is in the result method #adoptForBrowser:
	
	ClyQueryResult>>adoptForBrowser
		^ClyQueryResultBrowserAdapter for: self

	ClyBrowserQueryResult>>adoptForBrowser
		^self

Internal Representation and Key Implementation Points.

    Instance Variables
	actualResult:		<ClyQueryResult>!
!ClyQueryResultBrowserAdapter methodsFor: 'building' stamp: ''!
forceRebuild
	actualResult forceRebuild! !

!ClyQueryResultBrowserAdapter methodsFor: 'queries' stamp: ''!
rawItemsDo: aBlock
	actualResult rawItemsDo: aBlock! !

!ClyQueryResultBrowserAdapter methodsFor: 'queries' stamp: ''!
allItems
	^self wrapRawItems: actualResult allItems startingAt: 1! !

!ClyQueryResultBrowserAdapter methodsFor: 'system changes' stamp: ''!
hasSubscriber: anObject
	^actualResult hasSubscriber: anObject! !

!ClyQueryResultBrowserAdapter methodsFor: 'system changes' stamp: ''!
subscribe: aBrowserQueryCursor
	actualResult subscribe: aBrowserQueryCursor! !

!ClyQueryResultBrowserAdapter methodsFor: 'accessing' stamp: ''!
createUpdateWithItemsStartingAt: startPosition count: cacheSize
	"it is important for remote scenario to call new metadata and new cache by single message.
	In this case all required properties of metadata and cache will be transferred in one request using update instance"
	
	| itemCache |
	itemCache := ClyBrowserQueryCache 
		filledBy: self 
		startingAt: startPosition
		size: cacheSize.
	^ClyBrowserQueryUpdate of: self withItems: itemCache! !

!ClyQueryResultBrowserAdapter methodsFor: 'accessing' stamp: ''!
actualResult: anObject
	actualResult := anObject! !

!ClyQueryResultBrowserAdapter methodsFor: 'queries' stamp: ''!
findItemsSimilarTo: sampleEnvironmentItems
	| rest found existingItem |
	actualResult protectItemsWhile: [
		rest := sampleEnvironmentItems as: OrderedCollection.
		found := OrderedCollection new.	
		actualResult items doWithIndex: [ :existing :index |
			existingItem := existing asCalypsoBrowserItem.
			rest
				detect: [ :sample | sample isSimilarTo: existingItem]
				ifFound: [ :sample | 
					existingItem position: index.
					existingItem prepareIn: self environment.
					found add: existingItem. 
					rest remove: sample.
					rest ifEmpty: [ ^found ] ]].	
		^found]! !

!ClyQueryResultBrowserAdapter methodsFor: 'accessing' stamp: ''!
actualResult
	^ actualResult! !

!ClyQueryResultBrowserAdapter methodsFor: 'accessing' stamp: ''!
environment
	^actualResult environment! !

!ClyQueryResultBrowserAdapter methodsFor: 'queries' stamp: ''!
itemsStartingWhere: conditionBlock count: size
	
	actualResult protectItemsWhile: [
		actualResult items doWithIndex: [ :each :i |
			 (conditionBlock value: each asCalypsoBrowserItem) 
					ifTrue: [	^self itemsStartingAt: i count: size	]]
	].

	^#()! !

!ClyQueryResultBrowserAdapter methodsFor: 'system changes' stamp: ''!
unsubscribe: anObject 
	actualResult unsubscribe: anObject! !

!ClyQueryResultBrowserAdapter methodsFor: 'private' stamp: ''!
wrapRawItems: objects startingAt: firstItemIndex

	| result |
	result := objects collect: [:each | each asCalypsoBrowserItem].
	result doWithIndex: [ :each :i | 
		each position: firstItemIndex + i - 1.
		each prepareIn: self environment ].
	^result! !

!ClyQueryResultBrowserAdapter methodsFor: 'accessing' stamp: ''!
size
	^actualResult size! !

!ClyQueryResultBrowserAdapter methodsFor: 'queries' stamp: ''!
itemsStartingAt: startIndex count: size

	^self 
		wrapRawItems: (actualResult itemsStartingAt: startIndex count: size)
		startingAt: startIndex! !

!ClyQueryResultBrowserAdapter methodsFor: 'queries' stamp: ''!
findItemsWith: actualObjects
	"it returnes environment items which represent actualObjects.
	Result will be in same order as given actualObjects array.
	If some object is absent in content then it will return nil in place of it.
	All returned items will be resilved"
	| found result foundIndex |
	actualResult protectItemsWhile: [ 
		result := actualObjects collect: [ :eachObject |
			foundIndex := actualResult items findFirst: [ :item | 
				item calypsoEnvironmentType checkCalypsoItem: item isEqualTo: eachObject ].
			foundIndex > 0 
				ifTrue: [ found := (actualResult itemAt: foundIndex) asCalypsoBrowserItem.
					found position: foundIndex.
					found prepareIn: self environment.
					found]
				ifFalse: [nil]].
		^result]! !

!ClyQueryResultBrowserAdapter methodsFor: 'queries' stamp: ''!
itemsWhere: conditionBlock 
	| found item |
	actualResult protectItemsWhile: [
		found := OrderedCollection new.
		actualResult items doWithIndex: [ :each :i | 
			item := each asCalypsoBrowserItem.
			(conditionBlock value: item)	ifTrue: [ 
				item position: i.
				item prepareIn: self environment.	
				found add: item ] ].
		^found]! !

!ClyQueryResultBrowserAdapter methodsFor: 'queries' stamp: ''!
rawItems
	^actualResult rawItems! !

!ClyQueryResultBrowserAdapter methodsFor: 'accessing' stamp: ''!
metadata
	^actualResult metadata! !

!ClyQueryResultBrowserAdapter methodsFor: 'accessing' stamp: ''!
buildingQuery
	^actualResult buildingQuery! !

!ClyQueryResultBrowserAdapter class methodsFor: 'instance creation' stamp: ''!
for: aQueryResult
	^self new 
		actualResult: aQueryResult! !

!ClyQueryResultMetadata commentStamp: ''!
I represent metadata of query result as collection of first class properties (kind of ClyProperty).
I allow annotate query result with summary information about items. 

For example SUnit plugin annotates method queries with information about tests.
Another example: ClyAsyncQueryResult includes metadata ClyBackgroundProcessingTag which indicates that result is still in processing. 

To access properties use following methods: 
- addProperty: aProperty
- getProperty: aPropertyClass
- hasProperty: aPropertyClass

Metadata is collected lazely when user asks it from the result: 
	aQueryResult metadata 

Actual logic to collect metadata is implemented by environment plugins. But concrete dispatch method is choosen by query which built given result:

	metadata := ClyQueryResultMetadata new.
	environment pluginsDo: [:each | 
		buildingQuery collectMetadataOf: self by: each	] 

Query sends typed message depending on items which query retrieves. For example:
	
	ClyMethodQuery>>collectMetadataOf: aQueryResult by: anEnvironmentPlugin
		anEnvironmentPlugin collectMetadataOfMethods: aQueryResult

So metadata is property of query result. But when you open browser cursor metadata is passed to the cursor instances. It is important optimization for remote scenario where result is remote proxy. In that case cursor is transferred to the client by value together with metadata. So all properties are available for the local cursor user.
	
Internal Representation and Key Implementation Points.

    Instance Variables
	properties:	<OrderedCollection of: <ClyProperty>>!
!ClyQueryResultMetadata methodsFor: 'accessing' stamp: ''!
addProperty: aProperty
	properties add: aProperty! !

!ClyQueryResultMetadata methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	properties := OrderedCollection new! !

!ClyQueryResultMetadata methodsFor: 'accessing' stamp: ''!
properties: anObject
	properties := anObject! !

!ClyQueryResultMetadata methodsFor: 'accessing' stamp: ''!
removeProperty: aProperty
	properties remove: aProperty ifAbsent: [  ]! !

!ClyQueryResultMetadata methodsFor: 'accessing' stamp: ''!
properties
	^ properties! !

!ClyQueryResultMetadata methodsFor: 'accessing' stamp: ''!
getProperty: aPropertyClass 

	^properties detect: [ :each | each isKindOf: aPropertyClass ]! !

!ClyQueryResultMetadata methodsFor: 'testing' stamp: ''!
hasProperty: aPropertyClass

	^properties anySatisfy: [ :each | each isKindOf: aPropertyClass ]! !

!ClyQueryResultMetadata methodsFor: 'initialization' stamp: ''!
reset
	properties removeAll! !

!ClyQueryResultToolbarGroup commentStamp: ''!
I am a toolbar menu group to show together query browser controlling commands!
!ClyQueryResultToolbarGroup methodsFor: 'accessing' stamp: ''!
order
	^4! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testComparisonOfSameQueries

	| query2 |
	self assert: query equals: query.
	
	query2 := self createQuery.		
	self assert: query equals: query2.
	self assert: query hash equals: query2 hash! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testFixingStateBeforeExecution

	query fixStateBeforeExecution.
	
	self assert: query isReadOnlyObject.
	self assert: query scope isReadOnlyObject! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testBuildsDefaultResultByDefault

	self assert: query buildsDefaultResult! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testConvertingToSemiAsyncQuery
	| convertedQuery |
	convertedQuery := query semiAsync.

	self assert: convertedQuery class equals: ClyAsyncQuery.
	self assert: convertedQuery actualQuery identicalTo: query.
	self assert: convertedQuery requiredResult identicalTo: query requiredResult.
	self assert: convertedQuery scope identicalTo: query scope.
	self assert: convertedQuery asyncResult class equals: ClySemiAsyncQueryResult! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testConvertingToAsyncQuery
	| convertedQuery |
	convertedQuery := query async.

	self assert: convertedQuery class equals: ClyAsyncQuery.
	self assert: convertedQuery actualQuery identicalTo: query.
	self assert: convertedQuery requiredResult identicalTo: query requiredResult.
	self assert: convertedQuery scope identicalTo: query scope.
	self assert: convertedQuery asyncResult class equals: ClyAsyncQueryResult! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testNotBoundToEnvironmentByDefault

	query := query class new.
	self deny: query isBoundToEnvironment! !

!ClyQueryTest methodsFor: 'running' stamp: ''!
executeQuery

	result := query execute.
	resultItems := result items! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testComparisonOfSameQueriesWithDifferentRequestedContent
	| query2 |
	query requiredResult: #contentClass1.
	query2 := self createQuery.
	query2 requiredResult: #contentClass2.

	self deny: query equals: query2! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testHasRequiredResultByDefault

	self assert: query requiredResult notNil! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testPrepareResultForExecution
	| preparedResult |
	preparedResult := query prepareNewResult.

	self assert: preparedResult class equals: query requiredResult class.
	self assert: preparedResult buildingQuery identicalTo: query.
	self assert: preparedResult environment identicalTo: environment! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testIsBoundToEnvironmentWhenScopeIs

	self assert: query scope isBoundToEnvironment.
	self assert: query isBoundToEnvironment! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewRequiredResult
	| newResult convertedQuery |
	newResult := ClyRawQueryResult new.
	convertedQuery := query withResult: newResult.

	self assert: convertedQuery class equals: query class.
	self assert: convertedQuery scope equals: query scope.
	self assert: convertedQuery requiredResult identicalTo: newResult! !

!ClyQueryTest methodsFor: 'running' stamp: ''!
createQuery
	self subclassResponsibility! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testHasReadonlyRequiredResultByDefault

	self assert: query requiredResult isReadOnlyObject! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testHasUnknownScopeByDefault

	query := query class new.
	self assert: query scope equals: ClyUnknownScope instance! !

!ClyQueryTest methodsFor: 'tests' stamp: ''!
testGettingEnvironment

	self assert: query environment equals: environment! !

!ClyQueryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	query := self createQuery! !

!ClyQueryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyQueryTest! !

!ClyQueryViewMorph commentStamp: ''!
I represent query result using fast table.
I should be created for browser:

	ClyQueryView for: aBrowser

or using helper browser method:

	aBrowser newNavigationView.

By default I initialize table with single column, the instance of ClyMainTableColumn. You can ask it to set up specific column properties

	aQueryView mainColumn 
		width: 100;
		displayItemPropertyBy: [:rowItem | rowItem name, 'special name suffix for test' ].

Or you can set up display block using:

	aQueryView displayMainColumnBy: [ :cell :item | 
		cell nameMorph contents: item name.
		cell nameMorph color: Color green].

To create more columns use #addColumn: method:

	(aQueryView addColumn: #package) 
		width: 50;
		displayItemPropertyBy: [:methodItem | self packageNameOf: methodItem]

To show items user should pass query instance into me:

	aQueryView showQuery: aQuery

When user selects any item in table I trigger navigation request which ask browser for desired action. To set up navigation selector use:

	aQueryView requestNavigationBy: #showMethodsForSelectedClasses

I maintain several selection objects to always show correct table selection after any tree expansion, items addition of removal.

Main selection is what user selects on table. I manage it in #selection variable, instance of ClyDataSourceSeleciton.

Next is desiredSelection, instance of ClyDesiredSelection. Every time user passes me new query I am trying to restore desired selection on new items. Idea is to show previously selected items on new data source. I try to find same items and if they not exists I lookup similar items by name.
I set new desiredSelection instance only when user manually modifies table selection.

And last type of selection is highlighting, instance of ClyHighlightingSelection. User can set it by:

	aQueryView highlightItemsWhich: predicateBlock.

All type of selections maintain correct state to be in sync with actual table seletion indexes after any data source changes. This logic implemented in method #updateSelectedItemsOf:.

By default user can type characters on table to search required items. But also explicit filter with extra field can be added: 

- enableFilter
It adds simple ClyItemNameFilter.

- enableFilter: anItemStringFilterClass

I use Commander library to implement:

- context menu using CmdContextMenuCommandActivator:

	- menuColumn: column row: rowIndex

- shortcuts using CmdShortcutCommandActivator 

	- kmDispatcher

-  drag and drop using CmdDragAndDropCommandActivator 

	- createDragPassengerFor: aSelection

To use Commander I ask browser for command context of given selection.
The context is also used to decorate table cells with appropriate decorators:

	- decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	- decorateTableCell: anItemCellMorph of: aDataSourceItem

There is special decorator which also based on Commander: ClyTableIconCommandActivation. It adds iconic button to table cells for all interested commands.
It brings behaviour of Nautilus method widget where table icons are extended by AbstractMethodIconAction. Here commands should be marked with ClyTableIconCommandActivation.

I provide extra suitable events which in future should be also based on commands:
- whenDoubleClickDo: 
- whenEnterKeyPressedDo: 
- whenEscapeKeyPressedDo: 
ClyBrowserSearchDialog uses them to provide user friendly behaviour.

Other suitable methods:
- ignoreNavigationDuring: aBlock. It allows to modify my selection without triggering navigation  request to browser.
- findItemsSameAsFilter. It allows to use full filter string to search my data source for item with exacly same name. It is used by ClyBrowserSearchDialog.
- allowsDeselection: aBoolean.

Internal Representation and Key Implementation Points.

    Instance Variables
	table:		<FTTableMorph>
	browser:		<ClyBrowser>
	navigationSelector:		<aSymbol>
	selection:		<ClyDataSourceSelection>
	desiredSelection:		<ClyDesiredSelection>
	highlighting:		<ClyHighlightingSelection>	
	changesWasInitiatedByUser:		<Boolean>
	shouldRestoreSelection: <Boolean>
	treeStructure: <Array of<Association>>!
!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
hoverOverDropItemStartTime

	^ hoverOverDropItemStartTime! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
targetDropItem: anObject

	targetDropItem := anObject! !

!ClyQueryViewMorph methodsFor: 'drag and drop support' stamp: ''!
hasUserBeenFocusingOnItem: aSelectedItem

	targetDropItem ifNil: [ ^ false ].
	hoverOverDropItemStartTime ifNil: [ ^ false].
	aSelectedItem browserItem = targetDropItem browserItem ifFalse: [ ^ false ].

	^ self class dragAndDropDelay * 1000 < (Time microsecondsSince: hoverOverDropItemStartTime)! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
closeDataSource
	 
	table initialDataSource ifNil: [ ^self dataSource close ].	
	
	"In filter mode initial data source is the main original data source. 
	It manages filtered data source by itself.
	So we do not need to close it manually"	
	table cleanupFilter.
	table initialDataSource close.		
	"We could not reset to nil because some filter process of table can be spawned.
	And it will fail if initialDataSource is nil.
	Normally process should be terminated if table is closed 
	but it is not done in fast table"! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
ensureSelectedItem

	| selectionIndex |
	self selection isEmpty ifFalse: [ ^self ].
	self dataSource isEmpty ifTrue: [ ^self ]. 
	
	selectionIndex := 1.
	(desiredSelection notNil and: [desiredSelection isEmpty not]) ifTrue: [ 
		selectionIndex := desiredSelection lastSelectedItem globalPosition
									min: self dataSource numberOfRows ].
	self selection selectItems: {self dataSource elementAt: selectionIndex}.
	self ensureVisibleSelection! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
enableFilterUsing: aStringPattern

	self enableFilter: ClyItemNameFilter using: aStringPattern! !

!ClyQueryViewMorph methodsFor: 'drag and drop support' stamp: ''!
isReadyToExpandForDrop: aSelectedItem
	"/!!\ Although the selector sounds like a tester, it is modifying the state upon returning true/
	
	Current limitation:
	- You have to move to send another dragAndDrop event so the time can be checked again"
	| newFocus |

	newFocus := (self hasUserBeenFocusingOnItem: aSelectedItem) 
		ifTrue:[ nil ]
		ifFalse: [ aSelectedItem ].
	
	^ self userNowFocusesOn: newFocus
	! !

!ClyQueryViewMorph methodsFor: 'keymapping' stamp: ''!
kmDispatcher

	^ CmdKMDispatcher attachedTo: self! !

!ClyQueryViewMorph methodsFor: 'testing' stamp: ''!
showsItemsFromScope: aTypedScopeClass

	^self query isExecutedFromScope: aTypedScopeClass! !

!ClyQueryViewMorph methodsFor: 'queries' stamp: ''!
showQuery: aQuery

	| dataSource |
	self initiateUIChangeBy: [ 
		dataSource := self dataSourceClass on: aQuery.
		self dataSource: dataSource.
		self ensureSelectedItemIfNeeded].! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
enableFilter

	self enableFilter: ClyItemNameFilter! !

!ClyQueryViewMorph methodsFor: 'menu building' stamp: ''!
menuColumn: column row: rowIndex
	
	| menuSelection context |
	menuSelection := self grabSelectionAt: rowIndex.
		
	context := self createSelectionContextOf: menuSelection.
	
	^CmdContextMenuActivation buildContextMenuFor: self inContext: context! !

!ClyQueryViewMorph methodsFor: 'testing' stamp: ''!
definesTree
	^treeStructure notEmpty! !

!ClyQueryViewMorph methodsFor: 'drag and drop support' stamp: ''!
dropPassenger: aPassanger at: aDataSourceItem
	| context |
	context := self createSelectionContextOf: aDataSourceItem asSelection.
	
	^aPassanger dropInContext: context! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
activateFilterWith: patternString
	
	self initiateUIChangeBy: [ 
		table activateFilterWith: patternString.
		"Following update forces new selection instance which will be based on filtered data source.
		Selection always should be bound to actual data source of table"
		self updateSelection ]! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
query
	^self dataSource query! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
windowIsClosing
	self closeDataSource! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
ensureVisibleSelection

	self selection isEmpty ifFalse: [ ^self ].

	"following sentence is required to make first item selected in cases
	where browser is just opened and automatic item visibility 
	can be wrongly computed"
	UIManager default defer: [self selection ensureVisibleLastItem]! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
grabSelectionAt: rowIndex
	| selectedItems |
	(table isIndexSelected: rowIndex)
		ifTrue: [ ^ self selection ].
	selectedItems := rowIndex = 0
		ifTrue: [ #() ]
		ifFalse: [ {(self itemAt: rowIndex)} ].
	^ self newSelectionWith: selectedItems! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
ignoreNavigationDuring: aBlock

	| selector |
	selector := navigationSelector.
	navigationSelector := nil.
	aBlock ensure: [ navigationSelector := selector ]! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
requestNavigationBy: aBlock
	navigationSelector := aBlock! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
restoreSelectedItems

	self initiateUIChangeBy: [ 
		selection restoreTableSelection].
	highlighting restoreTableSelection! !

!ClyQueryViewMorph methodsFor: 'queries' stamp: ''!
findItemsSameAsFilter

	| filterString |
	filterString := table filterString asLowercase.
	^self dataSource findItemsWhere:  [:each | each name asLowercase = filterString ]! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
displayMainColumnBy: cellAndItemBlock

	self mainColumn displayBlock: cellAndItemBlock! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
enableFilterWithFactory: aTableFilterFactory

	table 
		enableFilter: aTableFilterFactory; 
		explicitFunction! !

!ClyQueryViewMorph methodsFor: 'context' stamp: ''!
createSelectionContext
	^self createSelectionContextOf: self selection! !

!ClyQueryViewMorph methodsFor: 'drag and drop support' stamp: ''!
createDragPassengerFor: aSelection
	| context |
	context := self createSelectionContextOf: aSelection. 
	
	^CmdDragAndDropActivation createDragPassengerInContext: context! !

!ClyQueryViewMorph methodsFor: 'initialization' stamp: ''!
refreshAsyncState
	(self findA: ClyActivityAnimationIconMorph) ifNotNil: #delete.
	
	self areItemsLoaded ifFalse: [ 
		self addMorph: (ClyActivityAnimationIconMorph label: 'loading items') ]! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
selectLastItem

	| rowsCount |
	rowsCount := self dataSource numberOfRows.
	rowsCount = 0 ifTrue: [ ^self ].
	
	self selection selectItems: {self dataSource elementAt: rowsCount}.
	UIManager default defer: [self selection ensureVisibleLastItem]! !

!ClyQueryViewMorph methodsFor: 'testing' stamp: ''!
isFilterActive
	table initialDataSource ifNil: [ ^false ].
	
	^self dataSource ~~ table initialDataSource! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
snapshotState
	
	| dataSourceSnapshot |
	dataSourceSnapshot := selection rootDataSource copyForBrowserStateSnapshot.
	
	^ClyQueryViewState new 
		dataSource: dataSourceSnapshot;
		selection: (selection copyForBrowserStateSnapshotOf: dataSourceSnapshot)! !

!ClyQueryViewMorph methodsFor: 'drag and drop support' stamp: ''!
userNowFocusesOn: aSelectedItem
	"if this is true, then we're not ready to expand, and we do not want to update the time."
	(targetDropItem isNotNil and: [ aSelectedItem isNotNil
		and: [ targetDropItem browserItem = aSelectedItem browserItem ]]) ifTrue: [ ^ false ].
	
	targetDropItem := aSelectedItem.
	hoverOverDropItemStartTime := Time microsecondClockValue.
	"new focus, we do not expand"
	^ targetDropItem isNil! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
refreshTable
	table refresh! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyQueryViewMorph methodsFor: 'context' stamp: ''!
createSelectionContextOf: aSelection

	^ClyContextSelectionStrategyAnnotation selectContextOf: aSelection for: browser! !

!ClyQueryViewMorph methodsFor: 'events subscription' stamp: ''!
whenDoubleClickDo: aBlock

	table onAnnouncement: FTStrongSelectionChanged do: aBlock! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
hoverOverDropItemStartTime: anObject

	hoverOverDropItemStartTime := anObject! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
addColumn: columnId

	| newColumn |
	newColumn := ClyTableColumn id: columnId.
	table addColumn: newColumn.
	^newColumn! !

!ClyQueryViewMorph methodsFor: 'event handling' stamp: ''!
triggerDoubleClickCommands

	CmdDoubleClickActivation executeCommandInContext: self createSelectionContext! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
updateSelection
	| selectedItems |
	"in some conditions table returnes bad index 0 which should not happens normaly.
	Following select protects from this case"
	selectedItems := table selectedIndexes
		select: [ :i | i between: 1 and: self dataSource numberOfRows ]
		thenCollect: [ :each | self itemAt: each ].
	selection := self newSelectionWith: selectedItems.
	shouldRestoreSelection
		ifTrue: [ changesWasInitiatedByUser
				ifTrue: [ desiredSelection := selection asDesiredSelection ]
				ifFalse: [ desiredSelection
						ifNotNil: [ desiredSelection checkItemsOfCurrentSelection: selection ] ] ]! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
allowsDeselection: aBool
	table allowsDeselection: aBool! !

!ClyQueryViewMorph methodsFor: 'initialization' stamp: ''!
initializeTable
	table := FTTableMorph new.
	table allowsDeselection: true.
	table beMultipleSelection.
	table beResizable.
	table dragEnabled: true.
	table dropEnabled: true.
	table onAnnouncement: FTSelectionChanged send: #selectionChanged to: self.
	table addColumn: ClyMainTableColumn default.
	table vResizing: #spaceFill.
	table hResizing: #spaceFill.
	self addMorph: table! !

!ClyQueryViewMorph methodsFor: 'initialization' stamp: ''!
setUpDataSource: aDataSource
	table dataSource: aDataSource.
	table initialDataSource: nil. "We should always cleanup initial data source when set up new one. And it is required to restart filter process if it was terminated before"
	highlighting := ClyHighlightingSelection fromRoot: aDataSource items: #().
	highlighting restoreTableSelection. 
	"it is important to reset highligting before selection restore because desired selection could lead to new highlighting items"
	selection := self newSelectionWith: #().	
	aDataSource openOn: self.	
	self showDesiredSelection.
	self refreshAsyncState.
	self ensureSelectedItemIfNeeded! !

!ClyQueryViewMorph methodsFor: 'events subscription' stamp: ''!
whenEscapeKeyPressedDo: aBlock

	table bindKeyCombination: Character escape asShortcut toAction: aBlock! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
dataSourceClass
	^ dataSourceClass ifNil: [ ClyCollapsedDataSource ]! !

!ClyQueryViewMorph methodsFor: 'drag and drop support' stamp: ''!
wantsDropPassenger: aPassenger at: dropTargetItem
	| context |
	 
	context := self createSelectionContextOf: dropTargetItem asSelection.
	(aPassenger canBeDroppedInContext: context) ifFalse:[ ^ false ].
	
	"if we are able to drop, we always return true.
	However, the rest is guarded to enable expansion"
	dropTargetItem hasChildren ifFalse: [ ^ true ].
	(self isReadyToExpandForDrop: dropTargetItem) ifFalse:[ ^ true ].

	dropTargetItem expand.
	^ true! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
dataSourceClass: aClass
	dataSourceClass := aClass! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
filterField
	^ table filterField! !

!ClyQueryViewMorph methodsFor: 'initialization' stamp: ''!
newSelectionWith: dataSourceItems
	^self dataSource newSelectionWith: dataSourceItems! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
updateSelectedItemsOf: aDataSource

	| actualSelectionChanged |
	self initiateUIChangeBy: [ 
		actualSelectionChanged := selection updateItemsWhichBelongsTo: aDataSource.
		highlighting updateItemsWhichBelongsTo: aDataSource.
		desiredSelection ifNotNil: [
			desiredSelection updateItemsWhichBelongsTo: aDataSource.
			actualSelectionChanged := actualSelectionChanged 
				| (desiredSelection restoreCurrentSelectionAfterUpdate: selection)].
		^actualSelectionChanged]! !

!ClyQueryViewMorph methodsFor: 'testing' stamp: ''!
showsItemsOfType: itemTypeClass

	^self query retrievesItemsOfType: itemTypeClass! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
initiateUIChangeBy: aBlock
	"We need to distingish UI state changes produced by user or by tool itself.
	This method setup special flag which shows that all following operations are performed by tool.
	So in any method we could check that it was initiated by user or not"
	
	changesWasInitiatedByUser ifFalse: [ ^aBlock value ].
	changesWasInitiatedByUser := false.
	aBlock ensure: [ changesWasInitiatedByUser := true ]! !

!ClyQueryViewMorph methodsFor: 'testing' stamp: ''!
hasKeyboardFocus 
	^super hasKeyboardFocus or: [ table hasKeyboardFocus  ]! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
mainColumn
	"Answer the main column in table"

	^ table columns detect: #isMainColumn! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
table
	^table! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
adoptForDialog
	(self areItemsLoaded and: [self itemCount < 10])
		ifTrue: [ self height: 100 ]
		ifFalse: [ self height: 300; enableFilterUsing: ClyRegexPattern new]! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem
	| context |
	context := ClyContextSelectionStrategyAnnotation selectContextOfSingleItem: aDataSourceItem for: browser.
	
	ClyTableDecorationStrategyAnnotation activeInstancesInContext: context do: [ :strategy | 
		strategy decorateTableCell: anItemCellMorph inContext: context]! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
ensureSelectedItemIfNeeded

	table allowsDeselection ifFalse: [ self ensureSelectedItem ].
	self ensureVisibleSelection! !

!ClyQueryViewMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self changeTableLayout.
	self initializeTable.
	self whenDoubleClickDo: [ self triggerDoubleClickCommands ].
	
	shouldRestoreSelection := true.
	changesWasInitiatedByUser := true.
	treeStructure := #().	
	self setUpDataSource: ClyDataSource empty! !

!ClyQueryViewMorph methodsFor: 'event handling' stamp: ''!
selectionChanged
	"This method is called by two reasons:
		- user selects the item
		- user typed the filter (table is reset selection in current Fast table logic)
	The isFilterChanged condition handle last case 
	when we want to keep selection on filtered data source if it exists.
	The main complexity is how and when update desired selection instance
	which is performed by #updateSelectionForNewFilter and #updateSelection methods"
	| selectionIsChanged |
	selectionIsChanged := true.
	self changeStateBy: [		
		self isFilterChanged ifTrue: [ 
			selectionIsChanged := self updateSelectionForNewFilter.
			selectionIsChanged ifFalse: [ ^self ] "No selection change happens"].		
		selectionIsChanged ifTrue: [ self updateSelection].
		navigationSelector ifNotNil: [
			browser 
				perform: navigationSelector 
				withEnoughArguments: {self selection}].
	].
	self triggerClickCommands! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
changeStateBy: aBlock
	browser changeStateOf: self by: aBlock! !

!ClyQueryViewMorph methodsFor: 'events subscription' stamp: ''!
whenEnterKeyPressedDo: aBlock

	table bindKeyCombination: Character cr asShortcut toAction: aBlock! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
takeKeyboardFocus
	table takeKeyboardFocus! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
selection
	"following logic fixes the case when filter is applied on table without selected items.
	In that case selectionChanged is not triggered and existing selection is not updated.
	It continue points to the old data source from the last selection update"
	self isFilterChanged ifTrue: [ 
		self initiateUIChangeBy: [self updateSelection] ].
	selection updateIfDirty.
	
	^selection! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
changesWasInitiatedByUser
	^changesWasInitiatedByUser! !

!ClyQueryViewMorph methodsFor: 'queries' stamp: ''!
showQueries: queries as: aQueryResult

	| fullQuery |
	fullQuery := ClyQuery unionFrom: queries as: aQueryResult.
	
	self showQuery: fullQuery! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
itemAt: rowIndex
	^self dataSource elementAt: rowIndex! !

!ClyQueryViewMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^Color transparent! !

!ClyQueryViewMorph methodsFor: 'queries' stamp: ''!
findAllItemsBy: aBlockWithDataSource
	self 
		findAllItemsBy: aBlockWithDataSource 
		stopLookupWhen: [:result | false "by default we always look into both data source if exists"]! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	| context |
	context := ClyContextSelectionStrategyAnnotation selectContextOfSingleItem: aDataSourceItem for: browser.
	
	ClyTableDecorationStrategyAnnotation activeInstancesInContext: context do: [ :strategy | 
		strategy decorateMainTableCell: anItemCellMorph inContext: context]! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
showDesiredSelection
	
	self initiateUIChangeBy: [
		desiredSelection ifNil: [ ^selection beEmpty ].
		
		desiredSelection restoreCurrentSelection: selection]! !

!ClyQueryViewMorph methodsFor: 'context' stamp: ''!
createCommandContext
	^self createSelectionContext! !

!ClyQueryViewMorph methodsFor: 'event handling' stamp: ''!
updateSelectionForNewFilter
	"This method is supposed to update selection instance for new filtered data source.
	And it tries to recover previously selected items using desired selection.
	At the end method returns the anwer: does selection really changed
	which is true when filtered data source does not include selected items"
	| oldSelection |
	oldSelection := selection.
	
	self initiateUIChangeBy: [ 
		self updateSelection.
		(desiredSelection notNil and: [ desiredSelection isEmpty not ]) ifTrue: [
			"We should never restore empty selection when filter was changed"
			desiredSelection restoreCurrentSelection: selection]].
	
	^(selection isSameAs: oldSelection) not! !

!ClyQueryViewMorph methodsFor: 'testing' stamp: ''!
areItemsLoaded
	^(self dataSource hasMetaProperty: ClyBackgroundProcessingTag) not! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
update

	self dataSource forceFullUpdate! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
treeStructure: anObject
	treeStructure := anObject! !

!ClyQueryViewMorph methodsFor: 'event handling' stamp: ''!
triggerClickCommands

	CmdClickActivation executeCommandInContext: self createSelectionContext! !

!ClyQueryViewMorph methodsFor: 'event handling' stamp: ''!
itemsChangedIn: aDataSource 
	| selectionWasEmpty |
	self refreshAsyncState.
	selectionWasEmpty := 	self selection isEmpty.
		
	browser ignoreNavigationDuring: [ 
		self updateSelectedItemsOf: aDataSource.
		selectionWasEmpty ifTrue: [self ensureSelectedItemIfNeeded]].
	browser itemsChanged! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
treeStructure
	^ treeStructure! !

!ClyQueryViewMorph methodsFor: 'queries' stamp: ''!
findAllItemsBy: aBlockWithDataSource stopLookupWhen: stopCondition
	| result fullResult |
	result := aBlockWithDataSource value: self dataSource.
	self isFilterActive ifFalse: [^result].	
	(stopCondition value: result) ifTrue: [ ^result ].
	"In case if view is in filter mode we should try to find items in full original data source.
	If it will be different result then we should reset filter. 
	Idea that if view is able to find items then they should be accessible/visible in table.
	And view must find items in original data source in case if filter do not include them"
	fullResult := aBlockWithDataSource value: table initialDataSource.
	result size = fullResult size ifTrue: [ 
		"if full lookup produces same result as filtered data source
		then no need for full mode switch"
		^result ].
	self setUpDataSource: table initialDataSource.
	^fullResult! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
enableCollapsingOfPreexpandedItems
	dataSourceClass := ClyExpandedDataSource.! !

!ClyQueryViewMorph methodsFor: 'testing' stamp: ''!
showsItemsFromQuery: aTypedQueryClass

	^self query executesQuery: aTypedQueryClass! !

!ClyQueryViewMorph methodsFor: 'testing' stamp: ''!
showsItemsFromMultipleScope

	^self query isExecutedFromMultipleScope! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
enableFilter: anItemStringFilterClass

	self enableFilterWithFactory: (ClyTableFilterFactory of: anItemStringFilterClass)! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
dataSource
	^table dataSource! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
highlightItemsWhich: predicateBlock

	highlighting selectItemsWhere: predicateBlock! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
neverRestoreSelection
	shouldRestoreSelection := false! !

!ClyQueryViewMorph methodsFor: 'controlling' stamp: ''!
enableFilter: anItemStringFilterClass using: aStringPattern

	self enableFilterWithFactory: (ClyTableFilterFactory of: anItemStringFilterClass using: aStringPattern)! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
moveMainColumnAtTheEnd

	| mainColumn |
	mainColumn := self mainColumn.
	table columns: (table columns copyWithout: mainColumn), {mainColumn}! !

!ClyQueryViewMorph methodsFor: 'queries' stamp: ''!
findItemsWhere: conditionBlock

	^self findAllItemsBy: [ :ds | ds findItemsWhere: conditionBlock]! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
targetDropItem

	^ targetDropItem! !

!ClyQueryViewMorph methodsFor: 'testing' stamp: ''!
isFilterChanged
	"when user filters the table in the filter field 
	the table resets selection and sets the new data source.
	But existing selection will points to another original data source 
	which allows detect this event in current fast table logic"
	table initialDataSource ifNil: [ 
		"it means that filter is not used by user"
		^false ]. 
	"only way to change data source of table without affecting selection is by using filter 
	which set up new filtered data source almost on every key stroke"
	^selection rootDataSource ~~ self dataSource! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
itemCount
	^self dataSource numberOfRows! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
dataSource: aDataSource

	self changeStateBy: [ 
		self closeDataSource.	
		self setUpDataSource: aDataSource.	
		self refreshTable
	]! !

!ClyQueryViewMorph methodsFor: 'testing' stamp: ''!
hasRealQuery

	^self query ~~ ClyUnknownQuery instance! !

!ClyQueryViewMorph methodsFor: 'tree support' stamp: ''!
queryToExpand: aDataSourceItem ifAbsent: absentBlock
	
	| itemTypeAndQuerySelector |
	itemTypeAndQuerySelector := treeStructure 
		detect: [:each | aDataSourceItem isBasedOnItemType: each key ] 
		ifNone: absentBlock.
	^aDataSourceItem type 
		perform: itemTypeAndQuerySelector value 
		with: aDataSourceItem actualObject
		with: self dataSource queryEnvironment! !

!ClyQueryViewMorph methodsFor: 'queries' stamp: ''!
findItemsWith: actualObjects

	^self 
		findAllItemsBy: [:ds | ds findItemsWith: actualObjects] 
		stopLookupWhen: [:result | result size = actualObjects size]! !

!ClyQueryViewMorph methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!ClyQueryViewMorph class methodsFor: 'instance creation' stamp: ''!
for: aBrowser
	^self new 
		browser: aBrowser! !

!ClyQueryViewMorph class methodsFor: 'accessing' stamp: ''!
dragAndDropDelay: aNumber
	DragAndDropDelay := aNumber! !

!ClyQueryViewMorph class methodsFor: 'settings' stamp: ''!
settingsDragAndDropDelayOn: aBuilder
	<systemsettings>
	(aBuilder setting: #dragAndDropDelay)
		parent: #Calypso;
		default: 1500;
		label: 'DragAndDrop delay (ms)';
		description: 'Delay to extend the list of item in the target of a drag and drop. 
For example drag and drop on a package which contains tag will be extended after dragAndDropDelay miliseconds.
Expects an integer giving the number of miliseconds';
		target: self.
		! !

!ClyQueryViewMorph class methodsFor: 'accessing' stamp: ''!
dragAndDropDelay
	"Modified by settings CodeBrowsing/Calypso: self classSide >> #settingsDragAndDropDelayOn:"
	^ DragAndDropDelay! !

!ClyQueryViewMorphShouldExpandTest commentStamp: ''!
A ClyQueryViewMorphTest is a test class for testing the behavior of ClyQueryViewMorph!
!ClyQueryViewMorphShouldExpandTest methodsFor: 'test-init' stamp: ''!
testFirstDragEventShouldNotBeReadyToExpand

	| view item1 |
	view := ClyQueryViewMorph new.
	item1 := ClyDataSourceItem new.
	self deny: (view isReadyToExpandForDrop: item1).! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-expand' stamp: ''!
testShouldChangeTheTimeIfITHasBeenLongEnough
	 
	| view item initialTime |
	view := ClyQueryViewMorph new.
	item := ClyDataSourceItem new.
	view hoverOverDropItemStartTime: Time microsecondClockValue * 2.
	initialTime := view hoverOverDropItemStartTime.
	view isReadyToExpandForDrop: item.
	"This is because we've added so much time.
	Point is that it should have reset to time now"
	self assert: initialTime > view hoverOverDropItemStartTime
	! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-focus' stamp: ''!
testUserIstFocusingOnDifferentItems
	 
	| view item1 item2 |
	view := ClyQueryViewMorph new.
	item1 := ClyDataSourceItem new browserItem: 1; yourself.
	item2 := ClyDataSourceItem new browserItem: 2; yourself.
	view userNowFocusesOn: item1.
	view hoverOverDropItemStartTime: (Time hour: 23 minute: 59 second: 59).
	self deny: (view hasUserBeenFocusingOnItem: item2).! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-expand' stamp: ''!
testShouldChangeTheTargetIfItemChanged
	 
	| view item1 initialObject item2 |
	view := ClyQueryViewMorph new.
	item1 := ClyDataSourceItem new.
	item2 := ClyDataSourceItem new browserItem: 1 ; yourself.
	view userNowFocusesOn: item1.
	initialObject := view targetDropItem.
	view isReadyToExpandForDrop: item2.
	self deny: initialObject equals: view targetDropItem! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-focus' stamp: ''!
testHasUserBeenFocusingOnSameItem
	 
	| view item |
	view := ClyQueryViewMorph new.
	item := ClyDataSourceItem new.
	view userNowFocusesOn: item.
	view hoverOverDropItemStartTime: Time microsecondClockValue / 2.
	self assert: (view hasUserBeenFocusingOnItem: item).! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-expand' stamp: ''!
testShouldNotChangeTheTargetIfItemDidNotChange
	 
	| view item1 initialObject |
	view := ClyQueryViewMorph new.
	item1 := ClyDataSourceItem new.
	view userNowFocusesOn: item1.
	initialObject := view targetDropItem.
	view isReadyToExpandForDrop: item1.
	self assert: initialObject equals: view targetDropItem! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-expand' stamp: ''!
testShouldNotExpandIfItHasNotBeenLongEnough
	 
	| view item1 initialTime |
	view := ClyQueryViewMorph new.
	item1 := ClyDataSourceItem new.
	view userNowFocusesOn: item1.
	initialTime := view hoverOverDropItemStartTime.
	self deny: (view isReadyToExpandForDrop: item1)! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-expand' stamp: ''!
testShouldNotChangeTheTimeIfItemDidNotChange
	 
	| view item1 initialTime |
	view := ClyQueryViewMorph new.
	item1 := ClyDataSourceItem new.
	view userNowFocusesOn: item1.
	initialTime := view hoverOverDropItemStartTime.
	view isReadyToExpandForDrop: item1.
	self assert: initialTime equals: view hoverOverDropItemStartTime! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-expand' stamp: ''!
testShouldChangeTheTimeIfItemChanged
	 
	| view item1 item2 initialTime |
	view := ClyQueryViewMorph new.
	item1 := ClyDataSourceItem new.
	item2 := ClyDataSourceItem new browserItem: 1 ; yourself.
	initialTime := view hoverOverDropItemStartTime.
	view isReadyToExpandForDrop: item2.
	self deny: initialTime equals: view hoverOverDropItemStartTime! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-expand' stamp: ''!
testShouldExpandIfItHasBeenLongEnough
	| view item initialTime |
	view := ClyQueryViewMorph new.
	item := ClyDataSourceItem new.
	view userNowFocusesOn: item.
	
	initialTime := view hoverOverDropItemStartTime.
	view hoverOverDropItemStartTime: Time microsecondClockValue / 2.
	self assert: (view isReadyToExpandForDrop: item).! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-expand' stamp: ''!
testShouldNotExpandIfItemChanged
	 
	| view item1 initialObject item2 |
	view := ClyQueryViewMorph new.
	item1 := ClyDataSourceItem new.
	item2 := ClyDataSourceItem new browserItem: 1 ; yourself.
	view userNowFocusesOn: item1.
	initialObject := view targetDropItem.
	self deny: (view isReadyToExpandForDrop: item2)! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-expand' stamp: ''!
testShouldExpandIfUserHasBeenFocusedLongEnough
	 
	| view item |
	view := ClyQueryViewMorph new.
	item := ClyDataSourceItem new.
	view userNowFocusesOn: item.
	view hoverOverDropItemStartTime: Time microsecondClockValue / 2.
	view isReadyToExpandForDrop: item.
	self assert: view targetDropItem isNil
	! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-expand' stamp: ''!
testShouldNotAllowToExpandInstantlyLastExpandedItem
	| view item initialTime |
	view := ClyQueryViewMorph new.
	item := ClyDataSourceItem new.
	view userNowFocusesOn: item.
	view hoverOverDropItemStartTime: Time microsecondClockValue / 2.
	initialTime := view hoverOverDropItemStartTime.
	"This checks that we indeed finalized an expand"
	self assert: (view isReadyToExpandForDrop: item).
	self deny: (view isReadyToExpandForDrop: item).! !

!ClyQueryViewMorphShouldExpandTest methodsFor: 'tests-focus' stamp: ''!
testHasUserBeenFocusingNotLongEnough
	| view item |
	view := ClyQueryViewMorph new.
	item := ClyDataSourceItem new.
	view userNowFocusesOn: item.
	self deny: (view hasUserBeenFocusingOnItem: item).! !

!ClyQueryViewState commentStamp: ''!
I represent the state of particular query view.
I keep data source and current selection of view.

I am supposed to not keep reference to the result of data source query.
So when I am initialized I ask data source for clean copy: 

	aQueryView dataSource copyForBrowserStateSnapshot.

And I convert current view selection to desired selection and clean it by detaching items from active data source.
Look at method #initializeFrom: for details.

My instances are created from query views: 

	ClyQueryViewState of: aQueryView

Or simply ask 
	
	aQueryView snapshotState
	
Internal Representation and Key Implementation Points.

    Instance Variables
	dataSource:		<ClyDataSource>
	selection:		<ClyDesiredDataSource>!
!ClyQueryViewState methodsFor: 'accessing' stamp: ''!
selection
	^ selection! !

!ClyQueryViewState methodsFor: 'accessing' stamp: ''!
dataSource: anObject
	dataSource := anObject! !

!ClyQueryViewState methodsFor: 'testing' stamp: ''!
representsConcreteQuery
	"this method allows to detect that query view is in state when it not shows any concrete query. It is happens when view was not requested to show anything yet. In that case data source is initialized with unknown query instance"
	
	^(dataSource isBasedOn: ClyUnknownQuery instance) not! !

!ClyQueryViewState methodsFor: 'operations' stamp: ''!
applyTo: aQueryView

	| newDataSource |
	(aQueryView dataSource isInSameStateAs: dataSource) ifFalse: [ 
		newDataSource := dataSource copyForBrowserStateSnapshot.
		aQueryView dataSource: newDataSource].
	
	selection restoreCurrentSelection: aQueryView selection.
	aQueryView selection ensureVisibleLastItem! !

!ClyQueryViewState methodsFor: 'accessing' stamp: ''!
dataSource
	^ dataSource! !

!ClyQueryViewState methodsFor: 'accessing' stamp: ''!
selection: anObject
	selection := anObject! !

!ClyQueryViewState methodsFor: 'testing' stamp: ''!
isCurrentStateOf: aQueryView
	
	^(aQueryView dataSource isInSameStateAs: dataSource)
		and: [aQueryView selection isSameAs: selection]! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testApplyingToQueryViewShouldRestoreExpandedItems

	| expandedItem newView |
	self selectedItem expand.
	
	self snapshotState.
	newView := ClyQueryViewMorph for: browser.
	navigationState applyTo: newView.

	expandedItem := navigationState dataSource expandedItems first.
	self assert: expandedItem childrenDataSource isClosed description: 'applying should not open data source snapshot'.
	
	self assert: newView dataSource expandedItems size equals: 1.	
	expandedItem := newView dataSource expandedItems first.
	self assert: (expandedItem isSameAs: self selectedItem).
	self deny: expandedItem childrenDataSource isClosed.
	self assert: expandedItem childrenDataSource queryView equals: newView.
	self assert: expandedItem childrenDataSource table notNil! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testExpandedItemWithRetrievedOwnerDataSource

	| expandedItem |
	self selectedItem expand.
	
	self snapshotState.
	
	expandedItem := navigationState dataSource expandedItems first.
	self assert: expandedItem ownerDataSource equals: navigationState dataSource! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testApplyingToQueryViewShouldCreateOpenedDataSource

	| newView |
	self snapshotState.
	newView := ClyQueryViewMorph for: browser.
	navigationState applyTo: newView.
	 
	self assert: newView dataSource ~~ navigationState dataSource.
	self deny: newView dataSource isClosed.
	self assert: newView dataSource queryView equals: newView.
	self assert: newView dataSource table notNil! !

!ClyQueryViewStateTest methodsFor: 'running' stamp: ''!
selectedItem
	^viewDataSource elementAt: 1  "it is self class"! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testSelectedChildInExpandedItemWithRetrievedExpandedDataSource

	| selectedItem retrievedSelectedItem |
	self selectedItem expand.
	selectedItem := self selectedItem childrenDataSource elementAt: 1. "some class group".
	queryView selection selectItems: { selectedItem }.
	self snapshotState.
	
	retrievedSelectedItem := navigationState selection items first.
	self assert: retrievedSelectedItem ownerDataSource equals: navigationState dataSource expandedItems first childrenDataSource! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testViewDataSourceIsNotDetatchedAfterSnapshoting

	self snapshotState.
	
	self assert: (viewDataSource queryResult hasSubscriber: viewDataSource)! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testRetrievesCurrentSelection

	self snapshotState.
	
	self assert: (navigationState selection lastSelectedItem isSameAs: self selectedItem)! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testExpandedDataSourceIsClosed

	| expandedItem |
	self selectedItem expand.
	
	self snapshotState.
	
	expandedItem := navigationState dataSource expandedItems first.
	self assert: expandedItem childrenDataSource isClosed! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testSelectionWithRetrievedDataSourceCopy

	self snapshotState.
	
	self assert: navigationState selection rootDataSource equals: navigationState dataSource! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testExpandedDataSourceWithoutQueryView

	| expandedItem |
	self selectedItem expand.
	
	self snapshotState.
	
	expandedItem := navigationState dataSource expandedItems first.
	self assert: expandedItem childrenDataSource queryView isNil! !

!ClyQueryViewStateTest methodsFor: 'running' stamp: ''!
snapshotState

	navigationState := queryView snapshotState.! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testExpandedDataSourceWithRetrievedExpandedItem

	| expandedItem |
	self selectedItem expand.
	
	self snapshotState.
	
	expandedItem := navigationState dataSource expandedItems first.
	self assert: expandedItem childrenDataSource parentItem equals: expandedItem! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testDataSourceIsClosed

	self snapshotState.
	
	self assert: navigationState dataSource isClosed! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testDataSourceWithExpandedItems

	self selectedItem expand.
	
	self snapshotState.
	
	self assert: (navigationState dataSource expandedItems first isSameAs: viewDataSource expandedItems first)! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testExpandedDataSourceWithoutTable

	| expandedItem |
	self selectedItem expand.
	
	self snapshotState.
	
	expandedItem := navigationState dataSource expandedItems first.
	self assert: expandedItem childrenDataSource table isNil! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testDataSourceWithoutQueryView

	self snapshotState.
	
	self assert: navigationState dataSource queryView isNil! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testSelectedItemPointsToRetrievedDataSource

	| item |
	self snapshotState.
	
	item := navigationState selection items first.
	self assert: item ownerDataSource equals: navigationState dataSource! !

!ClyQueryViewStateTest methodsFor: 'tests' stamp: ''!
testDataSourceWithoutTable

	self snapshotState.
	
	self assert: navigationState dataSource table isNil! !

!ClyQueryViewStateTest methodsFor: 'running' stamp: ''!
setUp
	| packages |
	super setUp.
	packages := ClyAllPackagesQuery 
		from: ClyPackageScope of: ClyClass7WithTag1FromP5Mock package in: environment.
	"it is P5WithTag package which allow items expansion"
	viewDataSource := ClyCollapsedDataSource on: packages.
	queryView := ClyQueryViewMorph for: browser.
	queryView
		treeStructure: {(RPackage -> #prepareClassGroupQueryFrom:in:)}.
	queryView dataSource: viewDataSource.
	queryView selection selectItems: {self selectedItem}! !

!ClyRawItemCursorTest methodsFor: 'tests' stamp: ''!
testAllItems
	| allItems unprepared |
	allItems := cursor retrieveAll.

	self deny: allItems equals: queryResult items.
	self assert: (allItems collect: [:each | each actualObject]) equals: queryResult items.
	unprepared := allItems reject: [:each | each isPrepared].
	self assert: unprepared isEmpty.
	self assert: (allItems collect: [:each | each position]) asArray equals: (1 to: queryResult size) asArray! !

!ClyRawItemCursorTest methodsFor: 'tests' stamp: ''!
testHasResultAdapterOverActualQueryResult

	self assert: cursor queryResult class equals: ClyQueryResultBrowserAdapter.
	self assert: cursor queryResult actualResult equals: queryResult! !

!ClyRawItemCursorTest methodsFor: 'running' stamp: ''!
rawResultItems

	^queryResult items! !

!ClyRawItemCursorTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyRawQueryResult new! !

!ClyRawQueryResult commentStamp: ''!
I represent items as is. I do not apply any formatting or transformation.

I am default #requiredResult of any query.!
!ClyRawQueryResult methodsFor: 'building' stamp: ''!
fillWith: queriedObjects

	items addAll: queriedObjects! !

!ClyRawQueryResultTest methodsFor: 'tests' stamp: ''!
testFillingWithItems

	queryResult fillWith: #(1 2 3).
	
	self assert: queryResult items asArray equals: #(1 2 3)! !

!ClyRawQueryResultTest methodsFor: 'tests' stamp: ''!
testGettingAllItemsSatisfyingCondition

	| actual |
	queryResult fillWith: #(1 2 3 4 5 6).

	actual := queryResult itemsWhere: [:each | each between: 2 and: 4].
	
	self assert: actual asArray equals: #(2 3 4)! !

!ClyRawQueryResultTest methodsFor: 'tests' stamp: ''!
testGettingItemsStartingAtGivenPosition

	| actual |
	queryResult fillWith: #(1 2 3 4 5 6).

	actual := queryResult itemsStartingAt: 3 count: 2.
	
	self assert: actual asArray equals: #(3 4)! !

!ClyRawQueryResultTest methodsFor: 'tests' stamp: ''!
testFillingWithItemsTwice

	queryResult fillWith: #(1 2 3).
	queryResult fillWith: #(4 5 6).
	
	self assert: queryResult items asArray equals: #(1 2 3 4 5 6)! !

!ClyRawQueryResultTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyRawQueryResult new! !

!ClyRawQueryResultTest methodsFor: 'tests' stamp: ''!
testGettingItemsStartingWhereConditionIsValid

	| actual |
	queryResult fillWith: #(1 2 3 4 5 6).

	actual := queryResult itemsStartingWhere: [:each | each > 3] count: 2.
	
	self assert: actual asArray equals: #(4 5)! !

!ClyRawQueryResultTest methodsFor: 'tests' stamp: ''!
testGettingAllItems

	| actual |
	queryResult fillWith: #(1 2 3).

	actual := queryResult allItems.
	
	self assert: actual asArray equals: #(1 2 3)! !

!ClyReflectiveEnvironmentPlugin commentStamp: ''!
I am special plugin which decorate methods with various kind of metalinks: halts, breakpoint, counters and watchpoints.
And I provide related method groups
- breakpoints
- counters
- watchpoints
They group related methods together!
!ClyReflectiveEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
doesMethodHasExecutionCounter: aMethod

	^self doesAnyManager: ExecutionCounter allCounters belongsTo: aMethod! !

!ClyReflectiveEnvironmentPlugin methodsFor: 'method groups' stamp: ''!
collectMethodGroupProviders
	^{ClyBreakpointMethodGroupProvider new. ClyMethodCounterGroupProvider new. ClyWatchMethodGroupProvider new}! !

!ClyReflectiveEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
doesAnyManager: metalinkManagers belongsTo: aMethod

	^metalinkManagers anySatisfy: [ :each |
		each notNil and: [ self doesNodeOf: each belongsTo: aMethod]]! !

!ClyReflectiveEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
doesNodeOf: aMetalinkManager belongsTo: aMethod

	| methodNode |
	methodNode := aMetalinkManager node methodNode.
	methodNode selector == aMethod selector ifFalse: [ ^false ].
	methodNode methodClass == aMethod methodClass ifFalse: [ ^false ].
	methodNode == aMethod ast ifFalse: [ ^false ].
	
	^true! !

!ClyReflectiveEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
doesMethodHasWatch: aMethod

	^self doesAnyManager: Watch allWatches belongsTo: aMethod! !

!ClyReflectiveEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod

	aMethod containsHalt ifTrue: [ anItem markWith: ClyMethodWithHaltTag ].
	aMethod hasBreakpoint ifTrue: [ anItem markWith: ClyMethodWithBreakpointTag ].	

	(self doesMethodHasExecutionCounter: aMethod) 
		ifTrue: [ anItem markWith: ClyMethodWithExecutionCounterTag ].
	(self doesMethodHasWatch: aMethod) 
		ifTrue: [ anItem markWith: ClyMethodWithWatchTag ]! !

!ClyRegexPattern commentStamp: ''!
I represent string pattern using regex expression!
!ClyRegexPattern methodsFor: 'testing' stamp: ''!
matches: aString
	| matcher |
	matcher := self createRegexMatcherIfFailed: [^true].
	
	^matcher search: aString! !

!ClyRegexPattern methodsFor: 'testing' stamp: ''!
createFixedRegexMatcherIfFailed: errorBlock

	| fixedPattern |
	fixedPattern := value copyReplaceAll: '*' with: '.*' .
	
	^ [ fixedPattern asRegexIgnoringCase ]
		on: RegexSyntaxError
		do: [ :ex | errorBlock value ]! !

!ClyRegexPattern methodsFor: 'testing' stamp: ''!
createRegexMatcherIfFailed: errorBlock

	value trimBoth ifEmpty: [^errorBlock value].
	
	^ [ value asRegexIgnoringCase ]
		on: RegexSyntaxError
		do: [ :ex | ^self createFixedRegexMatcherIfFailed: errorBlock ]! !

!ClyRegexPatternTest methodsFor: 'tests' stamp: ''!
testMatchesAnyStringWhenItIsEmpty

	| pattern |
	pattern := ClyRegexPattern with: ''.
	
	self assert: (pattern matches: 'any string')! !

!ClyRegexPatternTest methodsFor: 'tests' stamp: ''!
testMatchesStringWhichMatchesCorrectRegex

	| pattern |
	pattern := ClyRegexPattern with: '.abs'.
	
	self assert: (pattern matches: '1abs').
	self deny: (pattern matches: 'abs')! !

!ClyRegexPatternTest methodsFor: 'tests' stamp: ''!
testMatchesAnyStringWhenItIsBadRegex

	| pattern |
	pattern := ClyRegexPattern with: '!!*'.
	
	self assert: (pattern matches: 'any string')! !

!ClyRegexPatternTest methodsFor: 'tests' stamp: ''!
testMatchesAnyStringWhenItIsOnlySpaces

	| pattern |
	pattern := ClyRegexPattern with: '  '.
	
	self assert: (pattern matches: 'any string')! !

!ClyRegexPatternTest methodsFor: 'tests' stamp: ''!
testTriesFixWronglyUsedStarInRegex

	| pattern |
	pattern := ClyRegexPattern with: '*abs'.
	
	self assert: (pattern matches: 'abs').
	self deny: (pattern matches: 'ert')! !

!ClyRemoveAndShowSendersMethodStrategy commentStamp: ''!
I am a remove method strategy which removes methods but in addition it shows all senders.!
!ClyRemoveAndShowSendersMethodStrategy methodsFor: 'accessing' stamp: ''!
orderForBrowser
	^2! !

!ClyRemoveAndShowSendersMethodStrategy methodsFor: 'execution' stamp: ''!
removeMethods: methods
	SycSilentlyRemoveMethodStrategy new removeMethods: methods.
	(ClyShowMessageSenderCommand forMethods: methods by: browser) execute! !

!ClyRemoveAndShowSendersMethodStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	^'Remove, then browse senders'! !

!ClyRemoveBreakpointCommand commentStamp: ''!
I am a command to remove all breakpoints from given method or source node!
!ClyRemoveBreakpointCommand methodsFor: 'execution' stamp: ''!
debuggingToolClass
	^Breakpoint! !

!ClyRemoveBreakpointCommand methodsFor: 'table decoration' stamp: ''!
tableCellIcon
	^Smalltalk ui iconNamed: #halt! !

!ClyRemoveBreakpointCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aBrowserContext

	^aBrowserContext isSelectedItemHasBreakpoint! !

!ClyRemoveBreakpointCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder
	^1! !

!ClyRemoveClassGroupCommand commentStamp: ''!
I am a command to remove class group with containing classes.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	classGroup:		<ClyClassGroup>!
!ClyRemoveClassGroupCommand methodsFor: 'accessing' stamp: ''!
classGroup: anObject
	classGroup := anObject! !

!ClyRemoveClassGroupCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Remove'! !

!ClyRemoveClassGroupCommand methodsFor: 'execution' stamp: ''!
execute
	
	classGroup removeWithClasses! !

!ClyRemoveClassGroupCommand methodsFor: 'accessing' stamp: ''!
classGroup
	^ classGroup! !

!ClyRemoveClassGroupCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	| confirmed |
	super prepareFullExecutionInContext: aToolContext.
	
	classGroup := aToolContext lastSelectedClassGroup.

	classGroup classesSize > 0 ifTrue: [
		confirmed := UIManager default 
			confirm: 'Are you sure you want to remove all classes in group ', classGroup name, '?'.
		confirmed ifFalse: [CmdCommandAborted signal]]! !

!ClyRemoveClassGroupCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#removeIcon! !

!ClyRemoveClassGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 10000 for: ClyFullBrowserClassGroupContext! !

!ClyRemoveClassGroupCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isClassTagSelected! !

!ClyRemoveClassGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation removalFor: ClyFullBrowserClassGroupContext! !

!ClyRemoveDebuggingCommand commentStamp: ''!
I am a base class for commands which remove particular kind of metalink from given method or source node.
My subclasses should implement following class side methods: 

- metalinkManagerClass
It is a class which manages target type of metalinks. For example Breakpoint or ExecutionCounter.

- contextMenuOrder
It should return order in context menu!
!ClyRemoveDebuggingCommand methodsFor: 'execution' stamp: ''!
debuggingToolClass
	self subclassResponsibility! !

!ClyRemoveDebuggingCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Remove ', self debuggingToolClass name asLowercase! !

!ClyRemoveDebuggingCommand methodsFor: 'execution' stamp: ''!
execute
	
	sourceNode nodesWithLinks do: [:each | 
		self debuggingToolClass removeFrom: each]! !

!ClyRemoveDebuggingCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallCancel! !

!ClyRemoveDebuggingCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyRemoveDebuggingCommand! !

!ClyRemoveDebuggingCommand class methodsFor: 'activation' stamp: ''!
methodBrowserTableIconActivation
	<classAnnotation>
	
	^ClyTableIconCommandActivation priority: 900 for: ClyMethod asCalypsoItemContext! !

!ClyRemoveExecutionCounterCommand commentStamp: ''!
I am a command to remove execution counters from given method of node!
!ClyRemoveExecutionCounterCommand methodsFor: 'accessing' stamp: ''!
tableDescription
	^'Sent ', self currentCallsCount asString, ' times. Click to remove'! !

!ClyRemoveExecutionCounterCommand methodsFor: 'execution' stamp: ''!
debuggingToolClass
	^ExecutionCounter! !

!ClyRemoveExecutionCounterCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	
	^sourceNode hasExecutionCounter 
		ifTrue: [ 'Remove counter (', self currentCallsCount asString, ')']
	 	ifFalse: [ 'Remove counter' ]! !

!ClyRemoveExecutionCounterCommand methodsFor: 'accessing' stamp: ''!
currentCallsCount
	
	^sourceNode counter count! !

!ClyRemoveExecutionCounterCommand methodsFor: 'accessing' stamp: ''!
createTableCellButtonWith: anIcon using: aCommandActivator
	| button |
	button := super createTableCellButtonWith: anIcon using: aCommandActivator.
	sourceNode hasExecutionCounter ifTrue: [ 
		ClyDynamicBallonTooltip from: [self tableDescription] installInto: button].
	^button! !

!ClyRemoveExecutionCounterCommand methodsFor: 'table decoration' stamp: ''!
tableCellIcon
	^Smalltalk ui iconNamed: #classIcon! !

!ClyRemoveExecutionCounterCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aBrowserContext

	^aBrowserContext isSelectedItemHasExecutionCounter! !

!ClyRemoveExecutionCounterCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder	
	^2! !

!ClyRemoveMethodGroupCommand commentStamp: ''!
I am a command to remove method group with containing methods!
!ClyRemoveMethodGroupCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Remove'! !

!ClyRemoveMethodGroupCommand methodsFor: 'execution' stamp: ''!
execute
	
	methodGroups do: #removeWithMethods! !

!ClyRemoveMethodGroupCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	| tagsString confirmed |
	super prepareFullExecutionInContext: aToolContext.
	
	tagsString := ', ' join: (methodGroups collect: [:each | each name]).
	(methodGroups anySatisfy: [ :each | each methodsSize > 0])
		ifTrue: [
			confirmed := UIManager default 
					confirm: 'Are you sure you want to remove methods tagged with ', tagsString, '?'.
			confirmed ifFalse: [CmdCommandAborted signal]]! !

!ClyRemoveMethodGroupCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#removeIcon! !

!ClyRemoveMethodGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 100000 for: ClyFullBrowserMethodGroupContext! !

!ClyRemoveMethodGroupCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation removalFor: ClyFullBrowserMethodGroupContext! !

!ClyRemoveWatchCommand commentStamp: ''!
I am a command to remove all watchpoints from given method or source node!
!ClyRemoveWatchCommand methodsFor: 'execution' stamp: ''!
debuggingToolClass
	^Watch! !

!ClyRemoveWatchCommand methodsFor: 'table decoration' stamp: ''!
tableCellIcon
	^Smalltalk ui iconNamed: #haloView! !

!ClyRemoveWatchCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aBrowserContext

	^aBrowserContext isSelectedItemHasWatch! !

!ClyRemoveWatchCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder
	^3! !

!ClyRenameClassTagCommand commentStamp: ''!
I am a command to rename class tag of the package
 
Internal Representation and Key Implementation Points.

    Instance Variables
	classGroup:		<ClyClassGroup>
	newName:		<String>
	package:		<RPackage>
!
!ClyRenameClassTagCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	aToolContext showPackage: package atClassTag: newName! !

!ClyRenameClassTagCommand methodsFor: 'accessing' stamp: ''!
classGroup: anObject
	classGroup := anObject! !

!ClyRenameClassTagCommand methodsFor: 'accessing' stamp: ''!
newName
	^ newName! !

!ClyRenameClassTagCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Rename'! !

!ClyRenameClassTagCommand methodsFor: 'execution' stamp: ''!
execute

	classGroup renameClassTagTo: newName! !

!ClyRenameClassTagCommand methodsFor: 'accessing' stamp: ''!
newName: anObject
	newName := anObject! !

!ClyRenameClassTagCommand methodsFor: 'accessing' stamp: ''!
classGroup
	^ classGroup! !

!ClyRenameClassTagCommand methodsFor: 'accessing' stamp: ''!
package: anObject
	package := anObject! !

!ClyRenameClassTagCommand methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!ClyRenameClassTagCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	package := aToolContext lastSelectedPackage.
	classGroup := aToolContext lastSelectedClassGroup.
	newName := UIManager default 
		request: 'New name of the class tag' 
		initialAnswer: classGroup name 
		title: 'Rename a class tag'.
	newName isEmptyOrNil | (newName = classGroup name) ifTrue: [ CmdCommandAborted signal]! !

!ClyRenameClassTagCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 1 for: ClyFullBrowserClassGroupContext! !

!ClyRenameClassTagCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isClassTagSelected! !

!ClyRenameClassTagCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation renamingFor: ClyFullBrowserClassGroupContext! !

!ClyRenameMethodTagCommand commentStamp: ''!
I am a command to rename method tag (protocol).

My method group should be either ClyTaggedMethodGroup or ClyNoTagMethodGroup.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	methodGroup:		<ClyMethodGroup>
	newName:		<String>!
!ClyRenameMethodTagCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	aToolContext showMethodTag: newName! !

!ClyRenameMethodTagCommand methodsFor: 'accessing' stamp: ''!
methodGroup
	^ methodGroup! !

!ClyRenameMethodTagCommand methodsFor: 'accessing' stamp: ''!
newName
	^ newName! !

!ClyRenameMethodTagCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Rename'! !

!ClyRenameMethodTagCommand methodsFor: 'execution' stamp: ''!
execute
	
	methodGroup renameMethodTagTo: newName asSymbol! !

!ClyRenameMethodTagCommand methodsFor: 'accessing' stamp: ''!
methodGroup: anObject
	methodGroup := anObject! !

!ClyRenameMethodTagCommand methodsFor: 'accessing' stamp: ''!
newName: anObject
	newName := anObject! !

!ClyRenameMethodTagCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	methodGroup := aToolContext lastSelectedMethodGroup.
	newName := aToolContext 
		requestSingleMethodTag: 'New name of protocol' suggesting: methodGroup name.
	newName = methodGroup name ifTrue: [ CmdCommandAborted signal ]! !

!ClyRenameMethodTagCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 1 for: ClyFullBrowserMethodGroupContext! !

!ClyRenameMethodTagCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isMethodTagSelected! !

!ClyRenameMethodTagCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation renamingFor: ClyFullBrowserMethodGroupContext! !

!ClyRequestMethodPackageForEditorCommand commentStamp: ''!
I am a command to request package from the user which should be used as editing method package!
!ClyRequestMethodPackageForEditorCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Select method package'! !

!ClyRequestMethodPackageForEditorCommand methodsFor: 'execution' stamp: ''!
execute
	| packageEditor |
	packageEditor := methodEditor tagsAndPackageEditor.
	packageEditor requestChangeBy: [ packageEditor requestPackage]! !

!ClyRequestMethodPackageForEditorCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInMethodEditor: aTool

	^ true! !

!ClyRequestMethodPackageForEditorCommand class methodsFor: 'activation' stamp: ''!
methodEditorShorcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $e meta, $p meta for: ClyTextEditorContext! !

!ClyRequestMethodTagForEditorCommand commentStamp: ''!
I am a command to request method tag from the user which should be used to tag editing method!
!ClyRequestMethodTagForEditorCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aToolContext

	menuItemName := aToolContext tool hasUnacceptedEdits 
		ifTrue: [ 'Classify currently editing method' ]
		ifFalse: [ 'Classify method' ]! !

!ClyRequestMethodTagForEditorCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName

	^ menuItemName! !

!ClyRequestMethodTagForEditorCommand methodsFor: 'execution' stamp: ''!
execute
	| tagEditor |
	tagEditor := methodEditor tagsAndPackageEditor.
	tagEditor requestChangeBy: [ tagEditor requestTag]! !

!ClyRequestMethodTagForEditorCommand class methodsFor: 'activation' stamp: ''!
methodEditorShorcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $e meta, $t meta for: ClyTextEditorContext! !

!ClyRequiredMethodGroupProvider commentStamp: ''!
I provide "should be implemented" method group which includes all abstract methods from inherited classes which are still not implemented by given classes!
!ClyRequiredMethodGroupProvider methodsFor: 'testing' stamp: ''!
isStatic
	^true! !

!ClyRequiredMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyUnimplementedMethodsQuery from: aClassScope! !

!ClyRequiredMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope

	^ClyMethodGroup named: 'should be implemented' priority: 8.5 on: aMethodQuery! !

!ClyRequiredMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyRequiredMethodGroupProvider! !

!ClyRequiredMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup

	^ClyClassWhichInheritsAbstractSubclassMock! !

!ClyResetMethodTagForEditorCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName

	^ 'Unclassify method'! !

!ClyResetMethodTagForEditorCommand methodsFor: 'execution' stamp: ''!
execute

	| tagEditor |
	tagEditor := methodEditor tagsAndPackageEditor.
	tagEditor resetTagsAndPackage! !

!ClyResetMethodTagForEditorCommand class methodsFor: 'activation' stamp: ''!
methodEditorShorcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $e meta, $r meta for: ClyTextEditorContext! !

!ClyRestUntaggedClassesQuery commentStamp: ''!
I am a query of unclassified classes.

I a bit complex class query which returns classes without any tag.
The complexity is related to the logic that I will return nothing from the package which has no tags at all.

You can see class group #extensions which is based on me. 
It appears only when tagged and untagged classes exist together in the package!
!ClyRestUntaggedClassesQuery methodsFor: 'testing' stamp: ''!
selectsClass: aClass
	^aClass tags isEmpty! !

!ClyRestUntaggedClassesQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	
	| foundClasses |
	scope packagesDo: [ :each | 
		each tagsForClasses ifNotEmpty: [ 
			foundClasses := scope query: ClyUntaggedClassesQuery new.
			^aQueryResult fillWith: foundClasses rawItems]]! !

!ClyRestUntaggedClassesQuery methodsFor: 'printing' stamp: ''!
description

	^'rest unclassified classes'! !

!ClyRestUntaggedClassesQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	
	scope packagesDo: [ :each | 
		each tagsForClasses ifNotEmpty: [ 
			^scope isQueryEmpty: ClyUntaggedClassesQuery new]].
	
	^true! !

!ClyRestUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testFromPackageWithExtensionsButWithoutTags
	
	self queryFromScope: ClyPackageScope of: ClyClass1FromP1Mock package.

	self assert: resultItems isEmpty! !

!ClyRestUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testSelectsClassWithoutTags
	
	self assert: (query selectsClass: ClyClass6UntaggedFromP5Mock)! !

!ClyRestUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testIsEmptyFromEmptyClassScope
	"This query supports only package scope"
	<expectedFailure>
	
	super testIsEmptyFromEmptyClassScope! !

!ClyRestUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testEmptyInPackageWithoutAnyTags
	query scope: (ClyPackageScope 
		of: ClyClass9FromPExtendedByP5Mock package in: environment).
		
	self assert: query checkEmptyResult! !

!ClyRestUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testNotEmptyInPackageWithTagsAndUncategorizedClasses
	query scope: (ClyPackageScope 
		of: ClyClass6UntaggedFromP5Mock package in: environment).
		
	self deny: query checkEmptyResult! !

!ClyRestUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testFromPackageWithTagsAndUncategorizedClasses
	
	self queryFromScope: ClyPackageScope of: ClyClass6UntaggedFromP5Mock package.

	self assert: resultItems asSet equals: {ClyClass6UntaggedFromP5Mock} asSet! !

!ClyRestUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testFromPackageWithoutTagsAndExtensions
	
	self queryFromScope: ClyPackageScope of: ClyClass9FromPExtendedByP5Mock package.

	self assert: resultItems isEmpty! !

!ClyRestUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsTaggedClass
	
	self deny: (query selectsClass: ClyClass7WithTag1FromP5Mock)! !

!ClyRestUntaggedClassesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyRestUntaggedClassesQuery from: ClyPackageScope of: Object package in: environment! !

!ClyReturningScopeBasisExampleQuery methodsFor: 'accessing' stamp: ''!
extraParameter: anObject
	extraParameter := anObject! !

!ClyReturningScopeBasisExampleQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ extraParameter = anObject extraParameter! !

!ClyReturningScopeBasisExampleQuery methodsFor: 'accessing' stamp: ''!
extraParameter
	^ extraParameter! !

!ClyReturningScopeBasisExampleQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: extraParameter hash! !

!ClyReturningScopeBasisExampleQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	^false! !

!ClyReturningScopeBasisExampleQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult 
	"For tests we need predictable order of query result items"
	
	aQueryResult fillWith: (scope basisObjects sorted: #printString ascending)! !

!ClyReturningScopeBasisExampleQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	^scope basisObjects isEmpty! !

!ClyRing2Environment commentStamp: ''!
Please comment me using the following template inspired by Class Responsibility Collaborator (CRC) design:

For the Class part:  State a one line summary. For example, "I represent a paragraph of text".

For the Responsibility part: Three sentences about my main responsibilities - what I do, what I know.

For the Collaborators Part: State my main collaborators and one line about how I interact with them. 

Public API and Key Messages

- message one   
- message two 
- (for bonus points) how to create instances.

   One simple example is simply gorgeous.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	environment:		<Object>
	name:		<Object>


    Implementation Points!
!ClyRing2Environment methodsFor: 'initialization' stamp: ''!
defaultClassCompiler

	^ self class compiler! !

!ClyRing2Environment methodsFor: 'accessing' stamp: ''!
packageOrganizer
	^ packageOrganizer! !

!ClyRing2Environment methodsFor: 'initialization' stamp: ''!
createPackageNamed: aPackageName

	^ environment ensurePackageNamed: aPackageName! !

!ClyRing2Environment methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!ClyRing2Environment methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	environment := RGEnvironment new.
	projectManager := ClyProjectManagerRegistry new! !

!ClyRing2Environment methodsFor: 'initialization' stamp: ''!
subscribe: anObject
	self subscribe: anObject for: SystemAnnouncement! !

!ClyRing2Environment methodsFor: 'announcing' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject
	self environment announcer when: anAnnouncementClass send: aSelector to: anObject! !

!ClyRing2Environment methodsFor: 'initialization' stamp: ''!
compileANewClassFrom: aString notifying: aController startingFrom: aClass
	
	| importer |
	
	importer := RGChunkImporter new.
	importer environment: self environment.
	importer fileInFrom: (aString, '!!') readStream.
	
	^ aClass! !

!ClyRing2Environment methodsFor: 'binding' stamp: ''!
bindingOf: aSymbol
	
	^ environment bindingOf: aSymbol! !

!ClyRing2Environment methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!ClyRing2Environment methodsFor: 'initialization' stamp: ''!
unsubscribe: anObject
	environment announcer unsubscribe: anObject! !

!ClyRing2Environment methodsFor: 'initialization' stamp: ''!
includesClassNamed: aSymbol

	^ self environment includesClassNamed: aSymbol! !

!ClyRing2Environment methodsFor: 'initialization' stamp: ''!
packages

	^ environment ask packages! !

!ClyRing2Environment methodsFor: 'accessing' stamp: ''!
packageOrganizer: anObject
	packageOrganizer := anObject! !

!ClyRing2Environment methodsFor: 'accessing' stamp: ''!
name
	^ name ifNil: [ super printString ]! !

!ClyRing2Environment methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!ClyRing2Environment methodsFor: 'accessing' stamp: ''!
projectManager
	^ projectManager! !

!ClyRing2Environment methodsFor: 'accessing' stamp: ''!
projectManager: anObject
	projectManager := anObject! !

!ClyRing2Environment methodsFor: 'initialization' stamp: ''!
subscribe: anObject for: anAnnouncementClass
	self unsubscribe: anObject.
	environment announcer when: anAnnouncementClass send: #systemChanged: to: anObject! !

!ClyRing2Environment methodsFor: 'converting' stamp: ''!
asGlobalScopeIn: aNavigationEnvironment

	
	^ClySystemEnvironmentScope of: self in: aNavigationEnvironment named: name! !

!ClyRing2Environment methodsFor: 'accessing' stamp: ''!
classes
	^ self environment ask allClasses! !

!ClyRing2Environment class methodsFor: 'instance creation' stamp: ''!
on: anRGEvironment

	^ self new 
		environment: anRGEvironment;
		yourself.! !

!ClyRunAllTestsFromMethodDataSourceCommand commentStamp: ''!
I am a command to run all tests available in given data source!
!ClyRunAllTestsFromMethodDataSourceCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	self hasTestResult ifFalse: [ ^'Run all' ].
	
	^'Run all (', self testResult allCount asString, ')'! !

!ClyRunAllTestsFromMethodDataSourceCommand methodsFor: 'execution' stamp: ''!
buildTestSuite
	
	| suite |
	suite := TestSuite new.
	
	self testMethodsDo: [ :eachMethod |
			suite addTest: (eachMethod methodClass selector: eachMethod selector)].

	^suite! !

!ClyRunClassScriptCommand commentStamp: ''!
I a command to run particular script by given class.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	script:		<ClyClassScript>
	targetClass:		<Class>
!
!ClyRunClassScriptCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aBrowserContext
	super readParametersFromContext: aBrowserContext.
	
	script := aBrowserContext selectedClassScript! !

!ClyRunClassScriptCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Run script'! !

!ClyRunClassScriptCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIcon
	^Smalltalk ui iconNamed: script iconName! !

!ClyRunClassScriptCommand methodsFor: 'execution' stamp: ''!
execute
	script executeOn: targetClass! !

!ClyRunClassScriptCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aBrowserContext
	super prepareFullExecutionInContext: aBrowserContext.
	
	script := aBrowserContext selectedClassScript.
	targetClass := aBrowserContext selectedClasses
		detect: [ :each | script isImplementedByClass: each ]
		ifNone: [ script implementorClass ]! !

!ClyRunClassScriptCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#scriptManagerIcon! !

!ClyRunClassScriptCommand class methodsFor: 'activation' stamp: ''!
methodTableIconActivation
	<classAnnotation>
	
	^ClyTableIconCommandActivation for: ClyMethod asCalypsoItemContext! !

!ClyRunClassScriptCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext
	(super canBeExecutedInContext: aBrowserContext) ifFalse: [ ^false ].
	
	^aBrowserContext isClassSelected 
		and: [ aBrowserContext isClassScriptSelected ]! !

!ClyRunCoveringTestMethodsCommand commentStamp: ''!
I am a command to run all covering tests of selected methods!
!ClyRunCoveringTestMethodsCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aToolContext
	super readParametersFromContext: aToolContext.
	testItems := aToolContext selectedItems 
		select: [ :each | each hasProperty: ClyTestedMethodProperty ]! !

!ClyRunCoveringTestMethodsCommand methodsFor: 'execution' stamp: ''!
testSelectorOf: methodItem

	^(methodItem getProperty: ClyTestedMethodProperty) coveringTest selector! !

!ClyRunCoveringTestMethodsCommand methodsFor: 'execution' stamp: ''!
testResultOf: methodItem
	^(methodItem getProperty: ClyTestedMethodProperty) testResult! !

!ClyRunCoveringTestMethodsCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	
	^aToolContext selectedMethodItems anySatisfy: [ :each | 
		each hasProperty: ClyTestedMethodProperty ]! !

!ClyRunFailedTestsFromMethodDataSourceCommand commentStamp: ''!
I am a command to run all failed tests available in given data source!
!ClyRunFailedTestsFromMethodDataSourceCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	self hasTestResult ifFalse: [ ^'Run failed' ].
	
	^'Run failed (', self testResult brokenCount asString, ')'! !

!ClyRunFailedTestsFromMethodDataSourceCommand methodsFor: 'execution' stamp: ''!
buildTestSuite
	
	| suite |
	suite := TestSuite new.
	
	self testMethodsDo: [ :eachMethod |
		eachMethod isFailedTest | eachMethod isErrorTest ifTrue: [ 
			suite addTest: (eachMethod methodClass selector: eachMethod selector)]].

	^suite! !

!ClyRunFailedTestsFromMethodDataSourceCommand class methodsFor: 'activation' stamp: ''!
menuOrder
	^super menuOrder + 1! !

!ClyRunFailedTestsFromMethodDataSourceCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext
	| testResult |
	(super canBeExecutedInContext: aBrowserContext) ifFalse: [ ^false].
	
	testResult := aBrowserContext browser resultView dataSource getMetaProperty: ClyTestResultProperty.
	^testResult hasBrokenTests! !

!ClyRunTestsForPackageOrClassGroupCommand commentStamp: ''!
I provide an abstract class for class group/package 'run tests' commands.!
!ClyRunTestsForPackageOrClassGroupCommand methodsFor: 'initialization' stamp: ''!
setUpIconForMenuItem: aMenuItemMorph! !

!ClyRunTestsForPackageOrClassGroupCommand methodsFor: 'execution' stamp: ''!
execute

	testItems do: [ :each | self runTestsOf: each actualObject ]! !

!ClyRunTestsForPackageOrClassGroupCommand methodsFor: 'execution' stamp: ''!
runTestsOf: aClassGroup
	| testResult testClasses |
	
	testClasses := aClassGroup classes
		select: [ :each | each isTestCase and: [ each isAbstract not ] ].
	testClasses 
		ifEmpty: [testResult := TestAsserter classForTestResult new]
		ifNotEmpty: [ testResult := testClasses anyOne classForTestResult new].
		
	testClasses do: [ :each | self runTestCase: each results: testResult].		
	testResult updateResultsInHistory.	
	self  
		notifyUserAboutResults: testResult 
		with: aClassGroup name! !

!ClyRunTestsForPackageOrClassGroupCommand methodsFor: 'execution' stamp: ''!
decorateTableCell: anItemCellMorph using: aCommandActivator! !

!ClyRunTestsFromClassGroupCommand commentStamp: ''!
I run all tests from selected classGroup (package tags)!
!ClyRunTestsFromClassGroupCommand class methodsFor: 'activation' stamp: ''!
contextClass
	^ ClyClassGroup asCalypsoItemContext! !

!ClyRunTestsFromClassesCommand commentStamp: ''!
I run all selected test cases!
!ClyRunTestsFromClassesCommand methodsFor: 'execution' stamp: ''!
runTestCase: testCase

	| testResult |
	testResult := testCase classForTestResult new.
	
	self runTestCase: testCase results: testResult.
	
	testResult updateResultsInHistory.
	
	self  
		notifyUserAboutResults: testResult 
		with: testCase name! !

!ClyRunTestsFromClassesCommand methodsFor: 'execution' stamp: ''!
execute
	
	testItems do: [ :each | self runTestCase: each actualObject]! !

!ClyRunTestsFromClassesCommand class methodsFor: 'activation' stamp: ''!
contextClass
	^ClyClass asCalypsoItemContext! !

!ClyRunTestsFromMethodDataSourceCommand commentStamp: ''!
I am a root of commands hierarchy which supposed to run all method available in particular method data source.

My subclasses are used in ClyQueryBrowser to run all tests available in the list.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	methodDataSource:		<ClyDataSource>!
!ClyRunTestsFromMethodDataSourceCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aBrowserContext
	super readParametersFromContext: aBrowserContext.
	
	methodDataSource := aBrowserContext browser resultView dataSource! !

!ClyRunTestsFromMethodDataSourceCommand methodsFor: 'execution' stamp: ''!
execute
	| testSuite result |
	testSuite := self buildTestSuite.
	
	result := testSuite run.
	
	result updateResultsInHistory.
	
	self
		notifyUserAboutResults: result 
		with: 'Tests complete'! !

!ClyRunTestsFromMethodDataSourceCommand methodsFor: 'execution' stamp: ''!
buildTestSuite
	
	self subclassResponsibility! !

!ClyRunTestsFromMethodDataSourceCommand methodsFor: 'execution' stamp: ''!
testMethodsDo: aBlock

	methodDataSource queryResult rawItemsDo: [ :eachMethod | 
		(eachMethod isTestMethod and: [ eachMethod methodClass isAbstract not]) 
			ifTrue: [ aBlock value: eachMethod]]! !

!ClyRunTestsFromMethodDataSourceCommand methodsFor: 'testing' stamp: ''!
hasTestResult

	^methodDataSource hasMetaProperty: ClyTestResultProperty! !

!ClyRunTestsFromMethodDataSourceCommand methodsFor: 'testing' stamp: ''!
testResult

	^methodDataSource getMetaProperty: ClyTestResultProperty! !

!ClyRunTestsFromMethodDataSourceCommand class methodsFor: 'activation' stamp: ''!
menuOrder
	<classAnnotationDependency>
	^10000! !

!ClyRunTestsFromMethodDataSourceCommand class methodsFor: 'activation' stamp: ''!
queryBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation 
		byItemOf: ClyButtonToolbarGroup order: self menuOrder for: ClyQueryBrowserContext! !

!ClyRunTestsFromMethodDataSourceCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyRunTestsFromMethodDataSourceCommand! !

!ClyRunTestsFromMethodDataSourceCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext

	^aBrowserContext browser resultView dataSource hasMetaProperty: ClyTestResultProperty! !

!ClyRunTestsFromMethodsCommand commentStamp: ''!
I run all selected test methods using selected test cases (runTestCases) as their implementation.
I am allow browser to run inherited test method by selected class.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	runTestCases:		<Collection of<TestCase class>>!
!ClyRunTestsFromMethodsCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aToolContext
	super readParametersFromContext: aToolContext.
	
	runTestCases := aToolContext selectedClasses! !

!ClyRunTestsFromMethodsCommand methodsFor: 'execution' stamp: ''!
runTest: testSelector of: testClass

	| testResult |
	testResult := testClass debug: testSelector.
	
	self
		notifyUserAboutResults: testResult 
		with: 'Method: ' , testClass asString , '>>#' , testSelector asString! !

!ClyRunTestsFromMethodsCommand methodsFor: 'execution' stamp: ''!
testSelectorOf: testMethodItem

	^testMethodItem name asSymbol! !

!ClyRunTestsFromMethodsCommand methodsFor: 'execution' stamp: ''!
targetTestCasesFor: testItem
	| fullResult itemTestCases |
	itemTestCases := IdentitySet new.
	fullResult := self testResultOf: testItem.
	
	runTestCases do: [:each |
		fullResult concreteResultOf: each ifPresent: [ :concreteResult | 
			itemTestCases add: each ]].
	
	^itemTestCases ifEmpty: [fullResult testCases ]! !

!ClyRunTestsFromMethodsCommand methodsFor: 'execution' stamp: ''!
execute
	testItems do: [:each | self runTestItem: each ]! !

!ClyRunTestsFromMethodsCommand methodsFor: 'execution' stamp: ''!
defaultMenuIcon

	| fullResult |
	fullResult := self testResult.
	runTestCases do: [ :each | 
		fullResult concreteResultOf: runTestCases first ifPresent: [:testResult |
			^testResult createIcon ]].
	
	^fullResult createIcon! !

!ClyRunTestsFromMethodsCommand methodsFor: 'execution' stamp: ''!
runTestItem: testItem

	| testSelector |
	testSelector := self testSelectorOf: testItem.
	
	(self targetTestCasesFor: testItem) do: [ :each | 
		self runTest: testSelector of: each ]! !

!ClyRunTestsFromMethodsCommand class methodsFor: 'activation' stamp: ''!
contextClass
	^ClyMethod asCalypsoItemContext! !

!ClyRunTestsFromPackagesCommand commentStamp: ''!
I run all tests from selected packages!
!ClyRunTestsFromPackagesCommand class methodsFor: 'activation' stamp: ''!
contextClass
	^RPackage asCalypsoItemContext! !

!ClyRunTestsFromPackagesCommand class methodsFor: 'activation' stamp: ''!
fullBrowserClassGroupTableIconActivation
	<classAnnotation>
	
	^ClyTableIconCommandActivation for: ClyFullBrowserClassGroupContext! !

!ClyRunTestsFromSelectedItemsCommand commentStamp: ''!
I am a root of commands hierarchy which are supposed to run tests related to selected items.

I provide initialization, description and icon for subclasses.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	testItems:		<Collection of<ClyDataSourceItem>>!
!ClyRunTestsFromSelectedItemsCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aToolContext
	super readParametersFromContext: aToolContext.
	testItems := aToolContext selectedItems 
		select: [ :each | each hasProperty: ClyTestResultProperty ]! !

!ClyRunTestsFromSelectedItemsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Run tests'! !

!ClyRunTestsFromSelectedItemsCommand methodsFor: 'accessing' stamp: ''!
testItems: anObject
	testItems := anObject! !

!ClyRunTestsFromSelectedItemsCommand methodsFor: 'accessing' stamp: ''!
testItems
	^ testItems! !

!ClyRunTestsFromSelectedItemsCommand methodsFor: 'execution' stamp: ''!
runTestCase: testCase results: testResult

	testCase resetHistory.
	testCase suite run: testResult! !

!ClyRunTestsFromSelectedItemsCommand methodsFor: 'context menu support' stamp: ''!
testResultOf: anItem

	^anItem getProperty: ClyTestResultProperty! !

!ClyRunTestsFromSelectedItemsCommand methodsFor: 'context menu support' stamp: ''!
testResult

	^self testResultOf: testItems first! !

!ClyRunTestsFromSelectedItemsCommand class methodsFor: 'activation' stamp: ''!
contextClass
	self subclassResponsibility! !

!ClyRunTestsFromSelectedItemsCommand class methodsFor: 'activation' stamp: ''!
fullBrowserTableIconActivation
	<classAnnotation>
	
	^ClyTableIconCommandActivation priority: 1000 for: self contextClass! !

!ClyRunTestsFromSelectedItemsCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: self contextClass! !

!ClyRunTestsFromSelectedItemsCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyRunTestsFromSelectedItemsCommand! !

!ClyRunTestsFromSelectedItemsCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext

	^aToolContext selectedItems	anySatisfy: [ :each | 
			each hasProperty: ClyTestResultProperty ]! !

!ClyRunTestsFromSelectedItemsCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $t meta for: self contextClass! !

!ClySUnitEnvironmentPlugin commentStamp: ''!
I extend items with information about contained tests.

I decorate package, classes and methods with ClyTestResultProperty. Browser plugin uses it to show special icon/button and install test related commands.

Also I provide failed tests group to show all such tests together.

When I am activated on environment I subscribe to test history announcer. And when tests run I ask environment to process results (I wrap SUnit event with my ClyTestCaseRan).!
!ClySUnitEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod

	(self isTestMethod: aMethod) ifFalse: [ ^self ].
	
	anItem addProperty: (ClyTestResultProperty ofMethod: aMethod)! !

!ClySUnitEnvironmentPlugin methodsFor: 'query metadata' stamp: ''!
collectMetadataOfMethods: aQueryResult
	| property |
	property := 	ClyTestResultProperty new.
		
	aQueryResult rawItemsOf: ClyMethod do: [ :method | 
		(method isTestMethod and: [ method methodClass isAbstract not ]) ifTrue: [ 
			property accumulateTestMethod: method]].
	
	property allCount > 0 ifTrue: [ aQueryResult addMetaProperty: property ]! !

!ClySUnitEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofClass: aClass

	(aClass isTestCase not or: [aClass isAbstract]) ifTrue: [ ^self ].
	
	anItem addProperty: (ClyTestResultProperty ofTestCase: aClass)! !

!ClySUnitEnvironmentPlugin methodsFor: 'method groups' stamp: ''!
collectMethodGroupProviders 

	^{ClyFailedTestGroupProvider new. ClyExpectedFailureMethodGroupProvider new}! !

!ClySUnitEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofPackage: aPackage
	"this can be slow and proper implementation will require recomputing for every test run
	which slow down running of big test suite. 
	So for package and class group we only detect that it has tests"

	(aPackage classes anySatisfy: [:testCase | 
		testCase isTestCase and: [testCase isAbstract not]])
		ifFalse: [ ^self ].
		
	anItem addProperty: ClyTestResultProperty new! !

!ClySUnitEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
detachFromSystem

	TestCase historyAnnouncer unsubscribe: self! !

!ClySUnitEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
isTestMethod: aMethod
	
	aMethod numArgs isZero ifFalse: [ ^ false ].
	"unary selectors starting with 'should' are supposed to be treated as test methods too"
	((aMethod selector beginsWith: 'test') or: [ aMethod selector beginsWith: 'should' ])
		ifFalse: [ ^ false ].
	
	^self isTestClass: aMethod methodClass! !

!ClySUnitEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
testRan: aTestSuiteEnded
	| event |
	
	"testResult actually returns the TestCase class ran"	
	event := ClyTestCaseRan testCase: aTestSuiteEnded testResult.
	
	environment systemChanged: event! !

!ClySUnitEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
attachToSystem

	TestCase historyAnnouncer 
		weak when: TestSuiteEnded send: #testRan: to: self! !

!ClySUnitEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
isTestClass: aClass
	
	^aClass isTestCase or: [ 
		"Following logic is to detect tests from traits but without explicit dependency. 
		So we think that traits are test classes if they are used in test cases"
		aClass users anySatisfy: [ :eachUser | self isTestClass: eachUser ] ]! !

!ClySUnitEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofClassGroup: aClassGroup
	self decorateBrowserItem: anItem ofPackage: aClassGroup! !

!ClySUnitMethodMenuGroup methodsFor: 'accessing' stamp: ''!
order
	^ 1.5! !

!ClySUnitMethodMenuGroup methodsFor: 'accessing' stamp: ''!
name
	^ 'SUnit'! !

!ClySUnitMethodMenuGroup methodsFor: 'testing' stamp: ''!
isInlined
	^ true! !

!ClySampleInstanceScript commentStamp: ''!
I represent the action of the performed on class side methods marked with pragma <sampleInstance>.
After method execution I open an inspector on the result.
Note that if your method is named 

[[[  
example1
	<sampleInstance>
	^ 42
]]]

It will still open an inspector even if the browser consider them as example (see comments of the ClyExampleScript class)!
!ClySampleInstanceScript methodsFor: 'accessing' stamp: ''!
iconName
	^ #smallDoItIcon! !

!ClySampleInstanceScript methodsFor: 'accessing' stamp: ''!
description
	^ 'Get the class sample (predefined instance) in a inspector to tweak it and have fun with it'! !

!ClySampleInstanceScript methodsFor: 'execution' stamp: ''!
executeOn: aClass

 	(super executeOn: aClass) inspect! !

!ClySampleInstanceScript class methodsFor: 'script detection' stamp: ''!
isImplementedByMethod: aMethod
	^aMethod hasPragmaNamed: #sampleInstance! !

!ClyScope commentStamp: ''!
My subclasses represent specific point of view on system environment. 
They play role of source of data for queries which are always executed from concrete scope instance.

Concrete types of scopes implement several methods to access concrete type of objects which are visible from given scope. This methods are supposed to be in form of enumeration based on block:
	aScope someKindOfObjectsDo: aBlockWithObjectArg
For example ClyPackageScope shows objects which are visible from given packages: packages, classes and methods. And to access them it implements following methods:
- packagesDo:
- classesDo:
- methodsDo:

Scope instances are always created in some environment and based on set of basis objects. Basis objects are the root of information which scope can provide for queries.
Scopes which are based on single type objects are represented by subclasses of ClyTypedScope. They provide instance creation methods:

	scope := ClyPackageScope of: 'Kernel' asPackage in: ClyNavigationEnvironment currentImage.
	scope := ClyPackageScope ofAll: {'Kernel' asPackage. 'Alien' asPackage} in: ClyNavigationEnvironment currentImage.

For more information read ClyTypedScope comment.
I do not provide any constructor because I do not know how concrete scope will be created, how it will setup the basis.
But I provide set of operation to convert any scope to the given typed scope class:
- asScope: aTypedScopeClass. It creates instance of given scope class using receiver basis and environment.
- asScope: aTypedScopeClass of: singleBasisObject. It creates instance of given scope class using given singleBasisObject and receiver environment.
- asScope: aTypedScopeClass ofAll: newBasisObjects. It creates instance of given scope class using given newBasisObjects and receiver environment.
So the main point of these methods is to create new scope instances with existing properties of given scope. Where environment is always shared. 

Also I implement several testing methods which are used in some UI logic:
- isBasedOn: aBasisObject
- isBasedOnEmptyBasis
- isBasedOnSingleBasis
- isBasedOnMultipleBasis

Although it is preferred to instantiate scopes in the environment in some cases it is conveinient to bound scope to the environment separately from instantiation. 
For this purpose there are few methods:
- isBoundToEnvironment
- bindTo: aNavigationEnvironment

Scope is integral part of query. So it participates in environment query cache. And therefore any scope should correctly implement comparison: equal and hash operations. 
I provide default implementation based on basis objects. And subclasses which introduce extra parameters should provide specialized implementation.
Also it adds restriction that scope should be completaly initialized at query execution time and after it should never be modified. It is protected by write barrier logic when query fixes state before execution. It forces scope to beReadOnlyObject.

To support query execution I also provide several methods which are supposed to not be used externally:
- query: aQuery
- isQueryEmpty: aQuery
These methods are called by query. And I just delegate them to the environment.
Also subclasses should implement #adoptQuery: method to prepare given query for execution from receiver.
For example there is composite scope which converts given query to the composite query. Because simple query can't be executed directly from composite.
And by same reason I require subclasses implement:
- supportsQuery: aQuery
Query checks it when it is assigned to the scope. It allows to detect incompatibitily early and signal error.

Also in case of composite scope users can be still interested to know that they work with some simple scope which is part of composite. 
To made such test independent of type of scope I require subclasses to implement:
- representsScope: aScopeClass 
In case of composte it will check subscopes. And in case of simple scope it will simply check isKindOf:.

In addition I provide printing infrastructure.
Subclasses can define class side method #defaultName. And users can override it in instance:
	aScope name: 'special name'  
I implement #description with these names which is used in UI and to print queries:
	aScope description
In addition basis objects are appended in the end of desription. 
Subclasses can specialize how basis objects are printed using method #printBasisObject:on:.
For printString logic I just print basis in brackets. 
Look at examples:
	(ClyPackageScope of: 'Kernel' asPackage) description "==> 'packages: Kernel'"
	(ClyPackageScope of: 'Kernel' asPackage) printString "==>  'a ClyPackageScope(Kernel)'"
 
Internal Representation and Key Implementation Points.

    Instance Variables
	basisObjects:		<Set>
	environment:		<ClyNavigationEnvironment>
	name:		String!
!ClyScope methodsFor: 'testing' stamp: ''!
isBasedOn: someBasisObject
	^basisObjects includes: someBasisObject! !

!ClyScope methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ basisObjects = anObject basisObjects! !

!ClyScope methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^basisObjects hash! !

!ClyScope methodsFor: 'accessing' stamp: ''!
basisObjects
	^ basisObjects! !

!ClyScope methodsFor: 'accessing' stamp: ''!
bindTo: aNavigationEnvironment
	environment ifNil: [ environment := aNavigationEnvironment ].
	
	environment == aNavigationEnvironment
		ifFalse: [ self error: 'Scope should never be rebound to new environment' ]! !

!ClyScope methodsFor: 'converting' stamp: ''!
asScope: anotherTypedScopeClass
	"It will create new scope instance of given class but in same environment and with same basis"

	^ anotherTypedScopeClass ofAll: basisObjects in: environment named: name! !

!ClyScope methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!ClyScope methodsFor: 'printing' stamp: ''!
description

	^String streamContents: [ :s | self printDescriptionOn: s]! !

!ClyScope methodsFor: 'printing' stamp: ''!
printBasisOn: aStream
	basisObjects ifEmpty: [ ^self ].
	
	basisObjects do: [:each |
		self printBasisObject: each on: aStream.
		aStream nextPutAll: ', '].
	aStream skip: -2.! !

!ClyScope methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	self printBasisOn: aStream.
	aStream nextPut: $).! !

!ClyScope methodsFor: 'accessing' stamp: ''!
basisSize
	^ basisObjects size! !

!ClyScope methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!ClyScope methodsFor: 'testing' stamp: ''!
isBasedOnMultipleBasis
	^self basisSize > 1! !

!ClyScope methodsFor: 'queries' stamp: ''!
adoptQuery: aQuery
	"Not all kind of scopes support any kind of query.
	Idea is to be able adopt given query instance by target scope.
	For example composite scope will create composite query 
	on top of subqueries created for each subscope from given aQuery.
	This method should return adopted query instance which can be given query itself
	if it is appropriate"
	self subclassResponsibility! !

!ClyScope methodsFor: 'queries' stamp: ''!
query: aQuery
	self isBasedOnEmptyBasis ifTrue: [ 
		"It is optimization to prevent real query execution in remote scenario.
		Any query is a priory empty when its scope is based on empty basis"
		^ClyUnknownQueryResult instance ].

	aQuery ensureScope: self.
	
	^environment query: aQuery! !

!ClyScope methodsFor: 'queries' stamp: ''!
isQueryEmpty: aQuery
	self isBasedOnEmptyBasis ifTrue: [ 
		"It is optimization to prevent real query execution in remote scenario.
		Any query is a priory empty when its scope is based on empty basis"
		^true ].
	
	aQuery ensureScope: self.
	
	^environment isQueryEmpty: aQuery! !

!ClyScope methodsFor: 'accessing' stamp: ''!
basisObjects: aCollection
	basisObjects := aCollection asSet! !

!ClyScope methodsFor: 'accessing' stamp: ''!
system
	^environment system! !

!ClyScope methodsFor: 'converting' stamp: ''!
asScope: anotherTypedScopeClass ofAll: newBasisObjects
	"It will create completely new scope instance but in same environment"

	^ anotherTypedScopeClass ofAll: newBasisObjects in: environment! !

!ClyScope methodsFor: '*Calypso-SystemPlugins-InheritanceAnalysis-Queries' stamp: ''!
inheritanceAnalyzer

	^environment getPlugin: ClyInheritanceAnalysisEnvironmentPlugin! !

!ClyScope methodsFor: 'printing' stamp: ''!
printBasisObject: anObject on: aStream

	^anObject printOn: aStream! !

!ClyScope methodsFor: 'accessing' stamp: ''!
defaultName
	^self class defaultName! !

!ClyScope methodsFor: 'printing' stamp: ''!
printDescriptionOn: aStream

	aStream nextPutAll: self name.
	aStream nextPutAll: ': '.
	self printBasisOn: aStream! !

!ClyScope methodsFor: 'accessing' stamp: ''!
name
	^ name ifNil: [ self defaultName ]! !

!ClyScope methodsFor: 'testing' stamp: ''!
supportsQuery: aQuery
	self subclassResponsibility! !

!ClyScope methodsFor: 'composition' stamp: ''!
, anotherTypedScope
	self subclassResponsibility! !

!ClyScope methodsFor: 'testing' stamp: ''!
isBasedOnEmptyBasis
	
	^self basisSize = 0! !

!ClyScope methodsFor: 'testing' stamp: ''!
isBasedOnSingleBasis
	^self basisSize = 1! !

!ClyScope methodsFor: 'testing' stamp: ''!
isBoundToEnvironment
	^environment notNil! !

!ClyScope methodsFor: 'converting' stamp: ''!
asScope: anotherTypedScopeClass of: singleBasisObject
	"It will create completely new scope instance but in same environment"

	^ anotherTypedScopeClass of: singleBasisObject in: environment! !

!ClyScope methodsFor: 'testing' stamp: ''!
representsScope: aScopeClass
	self subclassResponsibility! !

!ClyScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
isCurrentImage
	^false! !

!ClyScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^self name! !

!ClyScopeCompoBoxMorph commentStamp: ''!
I am a tool to switch query browser to new choosen scope.
I use compobox to allow user choose it.

I am shown as first item in the browser toolbar.

By instances should be created on browser: 

	ClyScopeCompoBox for: ClyQueryBrowser.
	
Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyQueryBrowser>
	dropList:		<Object>
!
!ClyScopeCompoBoxMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		changeTableLayout;
		hResizing: #rigid;
		width: 200! !

!ClyScopeCompoBoxMorph methodsFor: 'accessing' stamp: ''!
currentScopeIndex: index
	self currentScope: (self scopes at: index)! !

!ClyScopeCompoBoxMorph methodsFor: 'accessing' stamp: ''!
currentScope
	^ self scopes detect: [ :each | browser isQueryScopeActive: each]! !

!ClyScopeCompoBoxMorph methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyScopeCompoBoxMorph methodsFor: 'accessing' stamp: ''!
scopes

	^browser allNavigationScopes! !

!ClyScopeCompoBoxMorph methodsFor: 'accessing' stamp: ''!
scopeNames

	^self scopes collect: [ :each | each description capitalized]! !

!ClyScopeCompoBoxMorph methodsFor: 'initialization' stamp: ''!
build
	dropList := self theme 
		newDropListIn: self
		for: self 
		list: #scopeNames
		getSelected: #currentScopeIndex 
		setSelected: #currentScopeIndex: 
		getEnabled: nil useIndex: true
		help: self currentScope description. 
		
	self addMorph: dropList! !

!ClyScopeCompoBoxMorph methodsFor: 'accessing' stamp: ''!
currentScope: aScope

	browser switchScopeTo: aScope.	
	dropList setBalloonText: aScope description.! !

!ClyScopeCompoBoxMorph methodsFor: 'accessing' stamp: ''!
currentScopeIndex
	^self scopes indexOf: self currentScope! !

!ClyScopeCompoBoxMorph methodsFor: 'accessing' stamp: ''!
browser: aMethodBrowser
	browser := aMethodBrowser.
	self build! !

!ClyScopeCompoBoxMorph class methodsFor: 'instance creation' stamp: ''!
for: aBrowser
	^self new 
		browser: aBrowser! !

!ClyScopeExampleTest methodsFor: 'running' stamp: ''!
extraBasisSample
	^#extraBasis! !

!ClyScopeExampleTest methodsFor: 'tests' stamp: ''!
testCreationUnifiedInstanceWhenThereIsExtraScopeParameter

	| unifiedInstance |
	scope := self multipleScopeSample.
	scope extraParameter: #testParameter.
	
	unifiedInstance := scope asUnifiedInstance.
	
	self assert: unifiedInstance extraParameter equals: #testParameter! !

!ClyScopeExampleTest methodsFor: 'tests' stamp: ''!
testConvertingWithExtraBasisObjectWhenThereIsExtraScopeParameter
	| convertedScope |
	scope := self singleScopeSample.
	scope extraParameter: #testParameter.
		
	convertedScope := scope withExtraBasisObject: self extraBasisSample.
	
	self assert: convertedScope extraParameter equals: #testParameter! !

!ClyScopeExampleTest methodsFor: 'running' stamp: ''!
scopeClass
	^ClyExampleScope! !

!ClyScopeExampleTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewBasisObjectsWhenThereIsExtraScopeParameter
	| convertedScope |
	scope := self singleScopeSample.
	scope extraParameter: #testParameter.
	
	convertedScope := scope withNewBasisObjects: {self extraBasisSample}.
	
	self assert: convertedScope extraParameter equals: #testParameter! !

!ClyScopeExampleTest methodsFor: 'running' stamp: ''!
singleBasisSample
	^#singleBasis! !

!ClyScopeTest methodsFor: 'tests' stamp: ''!
testComparisonWithSimilarScope

	| scope2 |
	scope := self createSampleScope.
	scope2 := self createSampleScope.
	
	self assert: scope equals: scope2.
	self assert: scope hash equals: scope2 hash! !

!ClyScopeTest methodsFor: 'running' stamp: ''!
createSampleScope
	self subclassResponsibility! !

!ClyScopeTest methodsFor: 'tests' stamp: ''!
testComparisonWithCopy

	| copy |
	scope := self createSampleScope.
	copy := scope copy.	
	self assert: scope equals: copy.
	self assert: scope hash equals: copy hash! !

!ClyScopeTest methodsFor: 'tests' stamp: ''!
testBindToEnvironment

	scope := self createSampleScope.

	scope bindTo: environment.
	
	self assert: scope environment equals: environment.
	self assert: scope isBoundToEnvironment! !

!ClyScopeTest methodsFor: 'tests' stamp: ''!
testComparisonWithItself

	scope := self createSampleScope.
	
	self assert: scope equals: scope! !

!ClyScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToAnotherScopeClass
	| convertedScope |
	scope := self createSampleScope.
	
	convertedScope := scope asScope: ClyExampleScope.
	
	self assert: convertedScope class equals: ClyExampleScope.
	self assert: convertedScope basisObjects asIdentitySet equals: scope basisObjects asIdentitySet.
	self assert: convertedScope environment equals: environment! !

!ClyScopeTest methodsFor: 'tests' stamp: ''!
testComparisonWithDifferentScope
	| scope2 |
	scope := self createSampleScope.
	scope2 := ClyExample2Scope of: #basisObject in: environment.
	self deny: scope equals: scope2! !

!ClyScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToAnotherScopeClassShouldKeepName
	| convertedScope |
	scope := self createSampleScope.
	scope name: 'test scope'.
	
	convertedScope := scope asScope: ClyExampleScope.
	
	self assert: convertedScope name equals: 'test scope'.! !

!ClyScopeTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	"For tests we want predictable order or collected items to simplify assertions"
	result := SortedCollection sortBlock: #printString ascending! !

!ClyScopeTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyScopeTest! !

!ClySemiAsyncQueryResult commentStamp: ''!
I am special kind of async query result which tries to emulate synchronous execution of fast queries.

Idea is to wait half second until background processing is finished. If it is enough time for query then for users I will be normal synchronous result. Otherwise they will see indication of processing. 

Implementation is based on semaphore which I am waiting for a half second before return to user. And my background process signals it at the end of execution. 
So in case of fast query this semahore will be signaled before delay expiration and I will return to the user with the normal synchronous state with ready to use built items.
Otherwise I will return to the user after half second with the indication of asynchronous processing.

To force semi async query execution you need convert given query using: 
	aQuery semiAsync
	
It returns ClyAsyncQuery instance with #asyncResult variable which points to me!
!ClySemiAsyncQueryResult methodsFor: 'building' stamp: ''!
runBuildProcess
	"Idea is to look like sync query when it is fast enough.
	I wait half second maximum until background query will be done.
	If it will complete in time then users will not notice any progress indication
	and they will think that query was sync"
	| semaphore |
	"following flag is used to not trigger async build norifications
	when query was fast enough to be executed synchronously"
	asyncModeIsActive := false. 
	semaphore := Semaphore new.
	buildProcess := [self buildActualResult. semaphore signal] 
		forkAt: Processor userBackgroundPriority 
		named: 'Build result of ', buildingQuery printString.
	semaphore wait: 500 milliSeconds.
	asyncModeIsActive := buildProcess notNil! !

!ClySemiAsyncQueryResult methodsFor: 'building' stamp: ''!
buildIsDone
	asyncModeIsActive ifTrue: [ super buildIsDone ]! !

!ClySemiAsyncQueryResultTest methodsFor: 'tests' stamp: ''!
testFastQueryShouldBeSync

	query passExecution.
	queryResult rebuild.
	
	self assert: queryResult isBuilt.
	self assert: queryResult buildProcess isNil! !

!ClySemiAsyncQueryResultTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClySemiAsyncQueryResult new! !

!ClySemiAsyncQueryResultTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^true! !

!ClyShowClassRefCommand commentStamp: ''!
I am a command to show all class references

To show references I ask the browser to spawn new query browser.

Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>!
!ClyShowClassRefCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Class refs.'! !

!ClyShowClassRefCommand methodsFor: 'execution' stamp: ''!
execute

	browser spawnQueryBrowserOn: (ClyClassReferencesQuery toAny: classes)! !

!ClyShowClassRefCommand methodsFor: 'accessing' stamp: ''!
browser

	^ browser! !

!ClyShowClassRefCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	browser := aToolContext browser! !

!ClyShowClassRefCommand methodsFor: 'accessing' stamp: ''!
browser: anObject

	browser := anObject! !

!ClyShowClassRefCommand class methodsFor: 'activation' stamp: ''!
queryBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation byItemOf: ClyButtonToolbarGroup for: ClyQueryBrowserContext! !

!ClyShowClassRefCommand class methodsFor: 'activation' stamp: ''!
queryBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyQueryBrowserContext! !

!ClyShowClassRefCommand class methodsFor: 'activation' stamp: ''!
queryBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $c meta, $n meta for: ClyQueryBrowserContext! !

!ClyShowClassRefCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byItemOf: ClyQueryMenuGroup for: ClySourceCodeContext! !

!ClyShowClassRefCommand class methodsFor: 'activation' stamp: ''!
fullBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation byItemOf: ClyButtonToolbarGroup for: ClyFullBrowserClassContext! !

!ClyShowClassRefCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyFullBrowserClassContext! !

!ClyShowClassRefCommand class methodsFor: 'instance creation' stamp: ''!
forClasses: classes by: aBrowser 
	^(self for: classes) 
		browser: aBrowser! !

!ClyShowClassRefCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $n meta for: ClyFullBrowserClassContext! !

!ClyShowCritiqueDetailsCommand commentStamp: ''!
I am a command to show critique details.
I just show the dialog with critique description and title!
!ClyShowCritiqueDetailsCommand methodsFor: 'table decoration' stamp: ''!
description
	^'View rationale behind the rule'! !

!ClyShowCritiqueDetailsCommand methodsFor: 'execution' stamp: ''!
execute

	UIManager default longMessage: critique description title: critique title! !

!ClyShowCritiqueDetailsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallQuestionIcon! !

!ClyShowDependencyCritiqueCommand commentStamp: ''!
I a command which opens dependency browser of given package which is my analyzed object!
!ClyShowDependencyCritiqueCommand methodsFor: 'table decoration' stamp: ''!
description
	^'Open dependency analyzer'! !

!ClyShowDependencyCritiqueCommand methodsFor: 'execution' stamp: ''!
execute

	(DAPackageAnalyzerPackageDependenciesWindow
		onPackagesNamed: {analyzedObject packageName}) open! !

!ClyShowDependencyCritiqueCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallWindow! !

!ClyShowDependencyCritiqueCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aCriticContext
	(super canBeExecutedInContext: aCriticContext) ifFalse: [ ^false ].
	
	^aCriticContext selectedCritique class = ArchitecturalCritique! !

!ClyShowGroupsInMethodBrowserCommand commentStamp: ''!
I am a command to show all methods in the groups in new method browser.

To show methods I ask the browser to spawn new query browser.

Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>!
!ClyShowGroupsInMethodBrowserCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Show in method browser'! !

!ClyShowGroupsInMethodBrowserCommand methodsFor: 'execution' stamp: ''!
execute

	| queries fullQuery |
	queries := methodGroups collect: [:each | each methodQuery].
	fullQuery := ClyQuery unionFrom: queries.
	
	browser spawnQueryBrowserOn: fullQuery! !

!ClyShowGroupsInMethodBrowserCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	browser := aToolContext browser! !

!ClyShowGroupsInMethodBrowserCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#glamorousBrowse! !

!ClyShowGroupsInMethodBrowserCommand class methodsFor: 'activation' stamp: ''!
fullBrowserDoubleClickMenuActivation
	<classAnnotation>
	
	^(CmdDoubleClickActivation for: ClyFullBrowserMethodGroupContext)
		priority: 10000! !

!ClyShowGroupsInMethodBrowserCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMethodGroupMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyFullBrowserMethodGroupContext! !

!ClyShowLocalImplementorsCommand commentStamp: ''!
I am a root of commands hierarchy which are supposed to show implementors of selected methods in local class scope of these methods.
My subclasses should define what exact local scope they allow to browse. They should implement following method:

- createInheritanceScopeFrom: classes 

It should return parcicular class scope instance.
Also my subclasses can define default selection in spawned query browser. They should override method:

- selectMethodsIn: aQueryBrowser

My instance should be created on method selection and browser.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>!
!ClyShowLocalImplementorsCommand methodsFor: 'execution' stamp: ''!
createQueryScope

	| classes scope |
	classes := methods collect: [ :each | each origin].
	
	scope := self createInheritanceScopeFrom: classes.
	scope := scope withMetaLevel: ClyClassScope.
	^scope! !

!ClyShowLocalImplementorsCommand methodsFor: 'execution' stamp: ''!
selectMethodsIn: aQueryBrowser! !

!ClyShowLocalImplementorsCommand methodsFor: 'execution' stamp: ''!
execute

	| selectors query |
	selectors := methods collect: [ :each | each selector].
	
	query := 	ClyMessageImplementorsQuery ofAny: selectors from: self createQueryScope.
	browser spawnQueryBrowserOn: query withState: [:queryBrowser |
		self selectMethodsIn: queryBrowser ]! !

!ClyShowLocalImplementorsCommand methodsFor: 'execution' stamp: ''!
createInheritanceScopeFrom: classes

	self subclassResponsibility! !

!ClyShowLocalImplementorsCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	browser := aToolContext browser! !

!ClyShowLocalImplementorsCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyShowLocalImplementorsCommand! !

!ClyShowMessageImplementorCommand commentStamp: ''!
I am a command to show all message implementors.

To show implementors I ask the browser to spawn new query browser.

Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>!
!ClyShowMessageImplementorCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Implementors'! !

!ClyShowMessageImplementorCommand methodsFor: 'execution' stamp: ''!
execute

	| selectors |
	selectors := messages collect: [ :each | each selector].
	browser spawnQueryBrowserOn: (ClyMessageImplementorsQuery ofAny: selectors)! !

!ClyShowMessageImplementorCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	browser := aToolContext browser! !

!ClyShowMessageImplementorCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallFindIcon! !

!ClyShowMessageImplementorCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byItemOf: ClyQueryMenuGroup for: ClySourceCodeContext! !

!ClyShowMessageImplementorCommand class methodsFor: 'activation' stamp: ''!
methodShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $m meta for: ClyMethod asCalypsoItemContext! !

!ClyShowMessageImplementorCommand class methodsFor: 'activation' stamp: ''!
methodBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation byItemOf: ClyButtonToolbarGroup for: ClyMethod asCalypsoItemContext! !

!ClyShowMessageImplementorCommand class methodsFor: 'activation' stamp: ''!
sourceCodeShortcutActivation
	"it is not supported yet. Look senders command"

	"<commandActivator>
	
	^ClyShortcutCommandActivator by: $m meta for: ClySourceCodeContext"! !

!ClyShowMessageImplementorCommand class methodsFor: 'activation' stamp: ''!
methodMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyMethod asCalypsoItemContext! !

!ClyShowMessageSenderCommand commentStamp: ''!
I am a command to show all message senders.

To show senders I ask the browser to spawn new query browser.

Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>!
!ClyShowMessageSenderCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Senders'! !

!ClyShowMessageSenderCommand methodsFor: 'execution' stamp: ''!
execute
	
	| selectors |
	selectors := messages collect: [ :each | each selector].
	browser spawnQueryBrowserOn: (ClyMessageSendersQuery ofAny: selectors)! !

!ClyShowMessageSenderCommand methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyShowMessageSenderCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	browser := aToolContext browser! !

!ClyShowMessageSenderCommand methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!ClyShowMessageSenderCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallFindIcon! !

!ClyShowMessageSenderCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byItemOf: ClyQueryMenuGroup for: ClySourceCodeContext! !

!ClyShowMessageSenderCommand class methodsFor: 'instance creation' stamp: ''!
forMethods: methods by: aBrowser 
	^(self forMethods: methods) 
		browser: aBrowser! !

!ClyShowMessageSenderCommand class methodsFor: 'activation' stamp: ''!
methodShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $n meta for: ClyMethod asCalypsoItemContext! !

!ClyShowMessageSenderCommand class methodsFor: 'activation' stamp: ''!
methodBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation byItemOf: ClyButtonToolbarGroup for: ClyMethod asCalypsoItemContext! !

!ClyShowMessageSenderCommand class methodsFor: 'activation' stamp: ''!
sourceCodeShortcutActivation
	"it is not supported yet. 
	One reason is that common text morph shorcuts are in priority.
	Another reason is that more clever logic needs to be implemented in ClySourceCodeContext to retrivev selected message from text selection"
	
	"<commandActivator>
	
	^ClyShortcutCommandActivator by: $n meta for: ClySourceCodeContext"! !

!ClyShowMessageSenderCommand class methodsFor: 'activation' stamp: ''!
methodMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyMethod asCalypsoItemContext! !

!ClyShowMethodInheritanceCommand commentStamp: ''!
I am a command to show all method implementors in full hierarchy of selected method classes.
I select current method in spawned browser by default.!
!ClyShowMethodInheritanceCommand methodsFor: 'execution' stamp: ''!
selectMethodsIn: aQueryBrowser

	aQueryBrowser selectObject: methods last! !

!ClyShowMethodInheritanceCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Inheritance'! !

!ClyShowMethodInheritanceCommand methodsFor: 'execution' stamp: ''!
createInheritanceScopeFrom: classes

	| classScope |
	classScope := ClyClassScope ofAll: classes in: browser navigationEnvironment.
	
	^classScope asFullHierarchyScope! !

!ClyShowMethodInheritanceCommand class methodsFor: 'activation' stamp: ''!
browserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $h meta for: ClyMethod asCalypsoItemContext! !

!ClyShowMethodInheritanceCommand class methodsFor: 'activation' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyMethod asCalypsoItemContext! !

!ClyShowOverriddenMethodsCommand commentStamp: ''!
I am a command to show all methods which are overridden by my selected methods!
!ClyShowOverriddenMethodsCommand methodsFor: 'execution' stamp: ''!
selectMethodsIn: aQueryBrowser 

	aQueryBrowser selectLastItem! !

!ClyShowOverriddenMethodsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Overridden methods'! !

!ClyShowOverriddenMethodsCommand methodsFor: 'execution' stamp: ''!
createInheritanceScopeFrom: classes
	| classScope |
	classScope := ClyClassScope ofAll: classes in: browser navigationEnvironment.
	
	^classScope asInheritedScope! !

!ClyShowOverriddenMethodsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#arrowUp! !

!ClyShowOverridingMethodsCommand commentStamp: ''!
I am a command to show all methods which override all my selected methods!
!ClyShowOverridingMethodsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 
	^'Overriding methods'! !

!ClyShowOverridingMethodsCommand methodsFor: 'execution' stamp: ''!
createInheritanceScopeFrom: classes

	^ClySubclassScope 
		ofAll: classes 
		in: browser navigationEnvironment! !

!ClyShowOverridingMethodsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#arrowDown! !

!ClyShowTraitUsersCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Show trait users'! !

!ClyShowTraitUsersCommand methodsFor: 'execution' stamp: ''!
execute

	classes first isTrait ifTrue: [ 
		browser spawnQueryBrowserOn: (ClyConstantQuery
				 returning: classes first traitUsers
				 as: (ClySortedQueryResult using: ClySortByNameFunction ascending)) ]! !

!ClyShowTraitUsersCommand methodsFor: 'accessing' stamp: ''!
browser

	^ browser! !

!ClyShowTraitUsersCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	browser := aToolContext browser! !

!ClyShowTraitUsersCommand methodsFor: 'accessing' stamp: ''!
browser: anObject

	browser := anObject! !

!ClyShowTraitUsersCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyFullBrowserClassContext! !

!ClyShowVariableRefCommand commentStamp: ''!
I am a command to show all variable references.

To show references I ask the browser to spawn new query browser.

Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>!
!ClyShowVariableRefCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'References'! !

!ClyShowVariableRefCommand methodsFor: 'execution' stamp: ''!
execute
	
	browser spawnQueryBrowserOn: (ClyVariableReferencesQuery ofAny: variables)! !

!ClyShowVariableRefCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	browser := aToolContext browser! !

!ClyShowVariableRefCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byItemOf: ClyQueryMenuGroup for: ClySourceCodeContext! !

!ClyShowVariableRefCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup order: 2000 for: ClyFullBrowserVariableContext! !

!ClyShowVariableRefCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $n meta for: ClyFullBrowserVariableContext! !

!ClyShowVariableWriterCommand commentStamp: ''!
I am a command to show all variable writers (the methods which assigns new value to the variables).

To show writers I ask the browser to spawn new query browser.

Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>!
!ClyShowVariableWriterCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Writers'! !

!ClyShowVariableWriterCommand methodsFor: 'execution' stamp: ''!
execute
	
	browser spawnQueryBrowserOn: (ClyVariableWritersQuery ofAny: variables)! !

!ClyShowVariableWriterCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	browser := aToolContext browser! !

!ClyShowVariableWriterCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byItemOf: ClyQueryMenuGroup for: ClySourceCodeContext! !

!ClyShowVariableWriterCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup order: 2001 for: ClyFullBrowserVariableContext! !

!ClyShowVariableWriterCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $m meta for: ClyFullBrowserVariableContext! !

!ClySimpleTag commentStamp: ''!
I am a root of hierarchy of first class tags which can mark objects.

For example ClyAbstractItemTag is created to mark abstract classes and methods.

ClyBrowserItem provides suitable methods for tagging:
	- item markWith: aSimpleTagClass
	- item isMarkedWith: aSimpleTagClass
	
I provide singleton instance for my subclasses:
	ClyAbstractItemTag instance 
So tagging items do not produce garbage!
!ClySimpleTag class methodsFor: 'singleton' stamp: ''!
instance
	^instance ifNil: [ instance := self new ]! !

!ClySingleClassGroupProvider commentStamp: ''!
I am a root of hierarchy of class group providers which build just one group for given package scope.

While class group is based on class query my subclasses should implement two methods: 

- createClassQueryFrom: aPackageScope
It should return class query representing classes for the group.

- createClassGroupFor: aClassQuery from: aPackageScope
It should creates group instance using given scope. The package scope is given to build subgroups query if needed. Any class group can be expanded to children subgroups!
!ClySingleClassGroupProvider methodsFor: 'building groups' stamp: ''!
classGroupsIn: aPackageScope do: aBlock
	
	| classQuery |
	classQuery := self createClassQueryFrom: aPackageScope.
	classQuery hasEmptyResult ifTrue: [ ^self ].
	
	aBlock value: (self createClassGroupFor: classQuery from: aPackageScope)! !

!ClySingleClassGroupProvider methodsFor: 'building groups' stamp: ''!
createClassQueryFrom: aPackageScope
	self subclassResponsibility! !

!ClySingleClassGroupProvider methodsFor: 'building groups' stamp: ''!
createClassGroupFor: aClassQuery from: aPackageScope
	self subclassResponsibility! !

!ClySingleClassRelationScope commentStamp: ''!
My subclasses represents simple class hierarchy scope which is built using single relationship between classes.
For example ClySubclassScope shows only subclasses of scope basis where relationship superclass-subclass is only used. 

I delegate #classesRelatedTo:do: to the class side. So it can be used by classes themselves and not only instances.
Subclasses should implement this method on class side.!
!ClySingleClassRelationScope methodsFor: 'queries' stamp: ''!
classesRelatedTo: aClass do: aBlock
	self class classesRelatedTo: aClass do: aBlock! !

!ClySingleClassRelationScope class methodsFor: 'accessing' stamp: ''!
classesRelatedTo: aClass do: aBlock
	self subclassResponsibility! !

!ClySingleMethodGroupProvider commentStamp: ''!
I am a root of hierarchy of simple method group providers which always supply single group for given class scope.
I simplify implementation of simple plugins which only want to define one extra method group. They should implement two methods: 

- createMethodQueryFrom: aClassScope
It should return method query representing methods for the group.

- createMethodGroupFor: aMethodQuery from: aClassScope
It should create group instance using given scope. The class scope is given to build subgroups query if needed. Any method group can be expanded to children subgroups

All my subclasses are not static by default. So they particupate in analysis of all methods in the scope!
!ClySingleMethodGroupProvider methodsFor: 'testing' stamp: ''!
isStatic
	^false! !

!ClySingleMethodGroupProvider methodsFor: 'testing' stamp: ''!
shouldBuildGroupWith: aMethodQuery
	
	self isStatic ifFalse: [ ^true ].
	^aMethodQuery hasEmptyResult not! !

!ClySingleMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	self subclassResponsibility! !

!ClySingleMethodGroupProvider methodsFor: 'system changes' stamp: ''!
providesGroupsAffectedBy: aSystemAnnouncement inScope: aClassScope

	| query |
	query := self createMethodQueryFrom: aClassScope.
	^query isResult: ClyUnknownQueryResult instance affectedBy: aSystemAnnouncement! !

!ClySingleMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	
	self subclassResponsibility! !

!ClySingleMethodGroupProvider methodsFor: 'building groups' stamp: ''!
buildGroupsFrom: aClassScope

	| methodQuery methodGroup |
	methodQuery := self createMethodQueryFrom: aClassScope.
	(self shouldBuildGroupWith: methodQuery) ifFalse: [ ^#() ].
		
	methodGroup := self createMethodGroupFor: methodQuery from: aClassScope.
	methodQuery isAsync ifTrue: [ methodGroup := methodGroup asAsyncQueryGroup ].
	
	^Array with: methodGroup! !

!ClySingleTraitVisibilityLevel commentStamp: ''!
I represent visibility of methods of concrete trait.

I am same as ClySuperclassVisibilityLevel. But I was introduced to allow decorate visibility item with special trait icon!
!ClySingleTraitVisibilityLevel methodsFor: '*Calypso-SystemPlugins-Traits-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem

	anItemCellMorph addExtraIcon: #trait! !

!ClySingleTraitVisibilityLevel methodsFor: '*Calypso-SystemPlugins-Traits-Queries' stamp: ''!
asTraitVisibility
	^self! !

!ClySortBrowserItemFunction commentStamp: ''!
I implement sorting of ClyBrowserItem instances by their actual objects.
And to sort actual objects I include another sort function in the variable actualObjectSortFunction.

To create my instances use following script:

	ClySortBrowserItemFunction with: actualObjectSortFunction
	
Or simply convert any sort function using: 

	aSortFuntion forBrowserItems	
		 
Internal Representation and Key Implementation Points.

    Instance Variables
	actualObjectSortFunction:		<SortFunction>!
!ClySortBrowserItemFunction methodsFor: 'accessing' stamp: ''!
actualObjectSortFunction: anObject
	actualObjectSortFunction := anObject! !

!ClySortBrowserItemFunction methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ actualObjectSortFunction = anObject actualObjectSortFunction! !

!ClySortBrowserItemFunction methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: actualObjectSortFunction hash! !

!ClySortBrowserItemFunction methodsFor: 'accessing' stamp: ''!
actualObjectSortFunction
	^ actualObjectSortFunction! !

!ClySortBrowserItemFunction methodsFor: 'evaluating' stamp: ''!
collate: aBrowserItem1 with: aBrowserItem2
	^actualObjectSortFunction 
		collate: aBrowserItem1 actualObject 
		with: aBrowserItem2 actualObject! !

!ClySortBrowserItemFunction class methodsFor: 'instance creation' stamp: ''!
with: actualObjectSortFunction
	^self new 
		actualObjectSortFunction: actualObjectSortFunction! !

!ClySortBrowserItemFunctionTest methodsFor: 'tests' stamp: ''!
testComparisonWithAnotherFunction
	| function2 |
	function := ClySortBrowserItemFunction with: ClySortByNameFunction ascending.
	function2 := ClySortBrowserItemFunction with: ClySortByNameFunction ascending.

	self assert: function equals: function2.
	self assert: function hash equals: function2 hash.

	function2 := ClySortBrowserItemFunction with: ClySortByNameFunction descending.
	self deny: function equals: function2! !

!ClySortBrowserItemFunctionTest methodsFor: 'tests' stamp: ''!
testCompareTwoItemsOfClasses

	function := ClySortBrowserItemFunction with: ClySortByNameFunction ascending.
	
	self deny: (function value: Object asCalypsoBrowserItem value: Array asCalypsoBrowserItem).
	self assert: (function value: Array asCalypsoBrowserItem value: Object asCalypsoBrowserItem).
	self assert: (function value: Object asCalypsoBrowserItem value: Object asCalypsoBrowserItem).! !

!ClySortByDefiningClassFunction commentStamp: ''!
I sort objects in ascending order using the name of their defining class!
!ClySortByDefiningClassFunction methodsFor: 'evaluating' stamp: ''!
collate: anObject1 with: anObject2
	^anObject1 definingClass name threeWayCompareTo: anObject2 definingClass name! !

!ClySortByDefiningClassFunctionTest methodsFor: 'tests' stamp: ''!
testAscending

	function := ClySortByDefiningClassFunction ascending.
	
	self deny: (function value: (ClyClassComment of: Object) value: (ClyClassComment of: Array)).
	self assert: (function value: (ClyClassComment of: Array) value: (ClyClassComment of: Object)).
	self assert: (function value: (ClyClassComment of: Object) value: (ClyClassComment of: Object))! !

!ClySortByNameFunction commentStamp: ''!
I just sort given objects by name.
So I am supposed that sorted objects will respond to #name!
!ClySortByNameFunction methodsFor: 'evaluating' stamp: ''!
collate: anObject1 with: anObject2
	^anObject1 name threeWayCompareTo: anObject2 name! !

!ClySortByNameFunctionTest methodsFor: 'tests' stamp: ''!
testDescending

	function := ClySortByNameFunction descending.
	
	self assert: (function value: Object value: Array ).
	self deny: (function value: Array value: Object ).
	self assert: (function value: Object value: Object )! !

!ClySortByNameFunctionTest methodsFor: 'tests' stamp: ''!
testAscending

	function := ClySortByNameFunction ascending.
	
	self deny: (function value: Object value: Array ).
	self assert: (function value: Array value: Object ).
	self assert: (function value: Object value: Object )! !

!ClySortFunction commentStamp: ''!
I implement first class function to be used instead of block in sorted collection.
There is system SortFunction. I am introduced to be safely used in caches.
Now in Pharo 7 SortFunction is improved and can completally replace and can be used instead of me.
But for Pharo 6 compatibility am still here and use by other Calypso based packages.

So for general overview read system SortFunction comments.

Internal Representation and Key Implementation Points.

    Instance Variables
	direction:		<Integer>!
!ClySortFunction methodsFor: 'accessing' stamp: ''!
direction: anObject
	direction := anObject! !

!ClySortFunction methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ direction = anObject direction! !

!ClySortFunction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	direction := 1! !

!ClySortFunction methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ direction hash! !

!ClySortFunction methodsFor: 'evaluating' stamp: ''!
collate: anObject1 with: anObject2
	self subclassResponsibility! !

!ClySortFunction methodsFor: 'evaluating' stamp: ''!
value: anObject1 value: anObject2
	| result |
	result := (self collate: anObject1 with: anObject2) * direction.
	^result <= 0! !

!ClySortFunction methodsFor: 'accessing' stamp: ''!
direction
	^ direction! !

!ClySortFunction methodsFor: 'converting' stamp: ''!
forBrowserItems
	^ClySortBrowserItemFunction with: self! !

!ClySortFunction class methodsFor: 'instance creation' stamp: ''!
descending

	^self new 
		direction: -1! !

!ClySortFunction class methodsFor: 'instance creation' stamp: ''!
ascending

	^self new
		direction: 1! !

!ClySortFunctionTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClySortFunctionTest! !

!ClySortItemGroupFunction commentStamp: ''!
I implement sorting groups, kind of ClyItemGroup.

I sort them first by priority and after by name!
!ClySortItemGroupFunction methodsFor: 'evaluating' stamp: ''!
collate: aGroup1 with: aGroup2
	"ascending order by name but descending by priority"
	
	aGroup1 priority = aGroup2 priority ifTrue: [ 
		^aGroup1 name threeWayCompareTo: aGroup2 name].
	
	^aGroup2 priority threeWayCompareTo: aGroup1 priority! !

!ClySortItemGroupFunctionTest methodsFor: 'tests' stamp: ''!
testDescending

	function := ClySortItemGroupFunction descending.
 
	self deny: (function 
		value: (ClyItemGroup named: 'group1' priority: 20) 
		value: (ClyItemGroup named: 'group2' priority: 10) ).
	self assert: (function 
		value: (ClyItemGroup named: 'group1' priority: 10) 
		value: (ClyItemGroup named: 'group2' priority: 20)).	
	self assert: (function 
		value: (ClyItemGroup named: 'group2') value: (ClyItemGroup named: 'group1') ).
	self deny: (function 
		value: (ClyItemGroup named: 'group1') value: (ClyItemGroup named: 'group2'))! !

!ClySortItemGroupFunctionTest methodsFor: 'tests' stamp: ''!
testAscending

	function := ClySortItemGroupFunction ascending.
 
	self assert: (function 
		value: (ClyItemGroup named: 'group1' priority: 20) 
		value: (ClyItemGroup named: 'group2' priority: 10) ).
	self deny: (function 
		value: (ClyItemGroup named: 'group1' priority: 10) 
		value: (ClyItemGroup named: 'group2' priority: 20)).	
	self deny: (function 
		value: (ClyItemGroup named: 'group2') value: (ClyItemGroup named: 'group1') ).
	self assert: (function 
		value: (ClyItemGroup named: 'group1') value: (ClyItemGroup named: 'group2'))! !

!ClySortMethodByPackageFunction commentStamp: ''!
See comment of my collate:with: method!
!ClySortMethodByPackageFunction methodsFor: 'evaluating' stamp: ''!
collate: aMethod1 with: aMethod2
	"Returns:
		-1 if aMethod1 is 'lower than' aMethod2
		0 if aMethod1 is 'equal to' aMethod2
		1 if aMethod1 is 'greater than' aMethod2
		
	aMethod1 is considered 'lower than' aMethod2 if:
		the name of aMethod1's package is lower than aMethod2's 
		or if the package names are the same and the name of aMethod1's class is lower than aMethod2's
		or if the package names and the class names are the same, and aMethod1's name is lower than aMethod2's name"
	| comparisonResult |
	comparisonResult := (aMethod1 package name threeWayCompareTo: aMethod2 package name).
	(comparisonResult = 0) ifFalse: [ ^ comparisonResult ].
	
	comparisonResult := (aMethod1 origin name threeWayCompareTo: aMethod2 origin name).
	(comparisonResult = 0) ifFalse: [ ^ comparisonResult ].

	^aMethod1 selector threeWayCompareTo: aMethod2 selector! !

!ClySortMethodByPackageFunctionTest methodsFor: 'tests' stamp: ''!
testDescendingSamePackageDifferentClass

	function := ClySortMethodByPackageFunction descending.
	
	self deny: (function value: Object >> #printString value: True >> #not ).
	self assert: (function value: True >> #not value: Object >> #printString).! !

!ClySortMethodByPackageFunctionTest methodsFor: 'tests' stamp: ''!
testDescendingSamePackageSameClassDifferentSelector

	function := ClySortMethodByPackageFunction descending.
	
	self deny: (function value: Object >> #printString value: Object >> #yourself ).
	self assert: (function value: Object >> #yourself value: Object >> #printString ).! !

!ClySortMethodByPackageFunctionTest methodsFor: 'tests' stamp: ''!
testAscendingDifferentPackage

	function := ClySortMethodByPackageFunction ascending.
	
	self deny: (function value: Object >> #printString value: Number >> #printString ).
	self assert: (function value: Number >> #printString value: Object >> #printString ).
	self assert: (function value: Object >> #printOn: value: Object >> #printString )! !

!ClySortMethodByPackageFunctionTest methodsFor: 'tests' stamp: ''!
testAscendingSamePackageDifferentClass

	function := ClySortMethodByPackageFunction ascending.
	
	self deny: (function value: True >> #not value: Object >> #printString).
	self assert: (function value: Object >> #printString value: True >> #not )! !

!ClySortMethodByPackageFunctionTest methodsFor: 'tests' stamp: ''!
testDescendingDifferentPackage

	function := ClySortMethodByPackageFunction descending.
	
	self deny: (function value: Number >> #printString value: Object >> #printString ).
	self assert: (function value: Object >> #printString value: Number >> #printString ).! !

!ClySortMethodByPackageFunctionTest methodsFor: 'tests' stamp: ''!
testAscendingSamePackageSameClassDifferentSelector

	function := ClySortMethodByPackageFunction ascending.
	
	self deny: (function value: Object >> #yourself value: Object >> #printString ).
	self assert: (function value: Object >> #printString value: Object >> #yourself )! !

!ClySortMethodBySelectorFunction commentStamp: ''!
I sort methods in the way that binary methods will be first in the ascending list.!
!ClySortMethodBySelectorFunction methodsFor: 'evaluating' stamp: ''!
collate: aMethod1 with: aMethod2

	(aMethod1 selector isBinary and: [aMethod2 selector isBinary not]) ifTrue: [ ^-1 ].
	(aMethod1 selector isBinary not and: [aMethod2 selector isBinary]) ifTrue: [ ^1 ].
	
	aMethod1 selector = aMethod2 selector ifTrue: [ 
		^aMethod1 origin name threeWayCompareTo: aMethod2 origin name ].
	
	^aMethod1 selector threeWayCompareTo: aMethod2 selector! !

!ClySortMethodBySelectorFunctionTest methodsFor: 'tests' stamp: ''!
testDescending

	function := ClySortMethodBySelectorFunction descending.
	
	self assert: (function value: Object >> #size value: Object >> #printString ).
	self deny: (function value: Object >> #printString value: Object >> #size ).
	self assert: (function value: Object >> #printString value: Object >> #printString )! !

!ClySortMethodBySelectorFunctionTest methodsFor: 'tests' stamp: ''!
testAscendingMethodsWithSameSelectorButDifferentClass

	function := ClySortMethodBySelectorFunction ascending.
	
	self deny: (function value: Object >> #printString value: Number >> #printString ).
	self assert: (function value: Number >> #printString value: Object >> #printString )! !

!ClySortMethodBySelectorFunctionTest methodsFor: 'tests' stamp: ''!
testDescendingForBinaryAndUnarySelectors
	"binary selector is always on top when ascending and on botton when descending"
	function := ClySortMethodBySelectorFunction descending.
	
	self assert: #| > #abs. "this should not affect desired sort behaviour"	
	self deny: (function value: Integer >> #| value: Number >> #abs ).
	self assert: (function value: Number >> #abs value: Integer >> #| ).
	
	self deny: #+ > #abs. "this should not affect desired sort behaviour"	
	self deny: (function value: Number >> #+ value: Number >> #abs ).
	self assert: (function value: Number >> #abs value: Number >> #+ )! !

!ClySortMethodBySelectorFunctionTest methodsFor: 'tests' stamp: ''!
testAscending

	function := ClySortMethodBySelectorFunction ascending.
	
	self deny: (function value: Object >> #size value: Object >> #printString ).
	self assert: (function value: Object >> #printString value: Object >> #size ).
	self assert: (function value: Object >> #printString value: Object >> #printString )! !

!ClySortMethodBySelectorFunctionTest methodsFor: 'tests' stamp: ''!
testAscendingForBinaryAndUnarySelectors
	"binary selector is always on top when ascending and on botton when descending"
	function := ClySortMethodBySelectorFunction ascending.
	
	self assert: #| > #abs. "this should not affect desired sort behaviour"
	self assert: (function value: Integer >> #| value: Number >> #abs ).
	self deny: (function value: Number >> #abs value: Integer >> #| ).
	
	self deny: #+ > #abs. "this should not affect desired sort behaviour"	
	self assert: (function value: Number >> #+ value: Number >> #abs ).
	self deny: (function value: Number >> #abs value: Number >> #+ )! !

!ClySortMethodBySelectorFunctionTest methodsFor: 'tests' stamp: ''!
testDescendingMethodsWithSameSelectorButDifferentClass

	function := ClySortMethodBySelectorFunction descending.
	
	self assert: (function value: Object >> #printString value: Number >> #printString ).
	self deny: (function value: Number >> #printString value: Object >> #printString )! !

!ClySortSystemItemFunction commentStamp: ''!
I implement sorting of different kind of system items like methods and classes.

First I check the type of given items using #calypsoEnvironmentType. If items are belongs to same type I use their #defaultSortFunctionForCalypso to sort them.
In addition I cache all created sort functions.

And when items are belongs to the different type I compare this types using #itemsSortOrderForCalypso number.
Look at #collate:with: method for details
 
Internal Representation and Key Implementation Points.

    Instance Variables
	functionsForTypes:		<Dictionary<Class, SortFunction>>!
!ClySortSystemItemFunction methodsFor: 'evaluating' stamp: ''!
sortFunctionFor: systemObject

	^functionsForTypes 
		at: systemObject calypsoEnvironmentType 
		ifAbsentPut: [ systemObject calypsoEnvironmentType defaultSortFunctionForCalypso].! !

!ClySortSystemItemFunction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	functionsForTypes := IdentityDictionary new.! !

!ClySortSystemItemFunction methodsFor: 'evaluating' stamp: ''!
collate: systemObject1 with: systemObject2

	| function |
	systemObject1 calypsoEnvironmentType = systemObject2 calypsoEnvironmentType ifTrue: [ 
		function := self sortFunctionFor: systemObject1.
		^function collate: systemObject1 with: systemObject2 ].
	
	^systemObject1 calypsoEnvironmentType itemsSortOrderForCalypso
		threeWayCompareTo: systemObject2 calypsoEnvironmentType itemsSortOrderForCalypso! !

!ClySortSystemItemFunctionTest methodsFor: 'tests' stamp: ''!
testCompareClassesAndMethods

	function := ClySortSystemItemFunction ascending.
	
	self deny: (function value: Object value: Object >> #printString ).
	self assert: (function value: Object >> #printString value: Object )! !

!ClySortSystemItemFunctionTest methodsFor: 'tests' stamp: ''!
testCompareTwoMethods

	function := ClySortSystemItemFunction ascending.
	
	self deny: (function value: Object >> #size value: Object >> #printString ).
	self assert: (function value: Object >> #printString value: Object >> #size ).
	self assert: (function value: Object >> #printString value: Object >> #printString )! !

!ClySortSystemItemFunctionTest methodsFor: 'tests' stamp: ''!
testCompareTwoClasses

	function := ClySortSystemItemFunction ascending.
	
	self deny: (function value: Object value: Array).
	self assert: (function value: Array value: Object).
	self assert: (function value: Object value: Object).! !

!ClySortedQueryResult commentStamp: ''!
I represent sorted query result.
I simply apply my #sortFunction for given result items.  

To create my instance use #using: method:

	ClySortedQueryResult using: ClySortByNameFunction ascending.
	
My #sortFunction can be a kind of SortFunction or ClySortFunction. 
First is valid to use in Pharo 7 because it was refactored to be safelly use in caches. SortFunction in old Pharo's do not define equality and hash. So Calypso uses its own ClySortFunction implementation in existing code.

Notice, the query result is cached as part of query requiredResult. It adds strong requirement to the values of my sortFunction variable: it should be safe for caches. This condition forbids using blocks in parameters.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	sortFunction:		<ClySortFunction>!
!ClySortedQueryResult methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ sortFunction = anObject sortFunction! !

!ClySortedQueryResult methodsFor: 'accessing' stamp: ''!
sortFunction: anObject
	sortFunction := anObject! !

!ClySortedQueryResult methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: sortFunction hash! !

!ClySortedQueryResult methodsFor: 'accessing' stamp: ''!
sortFunction
	^ sortFunction! !

!ClySortedQueryResult methodsFor: 'initialization' stamp: ''!
defaultItems
	^SortedCollection sortBlock: sortFunction! !

!ClySortedQueryResult methodsFor: 'building' stamp: ''!
fillWith: objects 
	items addAll: objects! !

!ClySortedQueryResult class methodsFor: 'instance creation' stamp: ''!
using: aSortFunction 
	^self new 
		sortFunction: aSortFunction! !

!ClySortedQueryResultTest methodsFor: 'tests' stamp: ''!
testComparisonWithSortedResultBasedOnAnotherFunction
	| queryResult2 |
	queryResult2 := ClySortedQueryResult using: #someAspect ascending.

	self deny: queryResult equals: queryResult2! !

!ClySortedQueryResultTest methodsFor: 'tests' stamp: ''!
testFillingItems

	queryResult fillWith: {Object. Array. Point} "query sorts items by name".
	
	self assert: queryResult items asArray equals: { Array. Object. Point }! !

!ClySortedQueryResultTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClySortedQueryResult using: ClySortByNameFunction ascending! !

!ClySourceCodeContext commentStamp: ''!
I am context of source code editor tool.
I am based on the ast of editing code.

I provide following interface to query code editor state. It is polymorphic to system browser context:

- selectedClasses 
- lastSeletedClass 
- isClassSelected 

- selectedMethods
- lastSelectedMethod 
- isMethodSelected 

- selectedMessages
- lastSelectedMessage 
- isMessageSelected 

- selectedVariables
- lastSelectedVariable
- isVariableSelected
- isTempVariableSelected 

Internal Representation and Key Implementation Points.

    Instance Variables
	selectedSourceNode:		<RBProgramNode>!
!ClySourceCodeContext methodsFor: 'tool controlling' stamp: ''!
showVariableNamed: aString
	tool selectVariableNamed: aString! !

!ClySourceCodeContext methodsFor: 'selection' stamp: ''!
lastSelectedClass

	^self selectedClass! !

!ClySourceCodeContext methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
isSelectedItemHasWatch
	^selectedSourceNode hasWatch! !

!ClySourceCodeContext methodsFor: 'tool controlling' stamp: ''!
showSourceNode

	tool selectSourceNode: selectedSourceNode! !

!ClySourceCodeContext methodsFor: 'selection' stamp: ''!
selectedClass

	^self selectedSourceNode binding value! !

!ClySourceCodeContext methodsFor: 'selection' stamp: ''!
selectedMessages

	^{self selectedMessage}! !

!ClySourceCodeContext methodsFor: 'testing' stamp: ''!
isTempVariableSelected
	^ self selectedSourceNode isTempVariable! !

!ClySourceCodeContext methodsFor: 'accessing' stamp: ''!
selectedSourceNode
	^selectedSourceNode! !

!ClySourceCodeContext methodsFor: 'selection' stamp: ''!
lastSelectedVariable

	^self selectedVariable! !

!ClySourceCodeContext methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
isSelectedItemHasExecutionCounter
	^selectedSourceNode hasExecutionCounter! !

!ClySourceCodeContext methodsFor: 'refactoring support' stamp: ''!
refactoringScopes
	^self browser allNavigationScopes! !

!ClySourceCodeContext methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
isSelectedItemHasBreakpoint
	^selectedSourceNode hasBreakpoint! !

!ClySourceCodeContext methodsFor: 'testing' stamp: ''!
isMessageSelected

	^self selectedSourceNode isMessage! !

!ClySourceCodeContext methodsFor: 'selection' stamp: ''!
lastSelectedSourceNode

	^self selectedSourceNode! !

!ClySourceCodeContext methodsFor: 'testing' stamp: ''!
isArgOrTempVariableSelected
	^ self selectedSourceNode isLocalVariable! !

!ClySourceCodeContext methodsFor: 'testing' stamp: ''!
isVariableSelected
	| node |
	self isClassSelected ifTrue: [ ^ false ].
	node := self selectedSourceNode.
	node isVariable ifFalse: [ ^ false ].
	
	^ node isLiteralVariable | node isInstanceVariable! !

!ClySourceCodeContext methodsFor: 'testing' stamp: ''!
isGlobalVariableSelected
	| node binding |
	node := self selectedSourceNode.
	node isVariable ifFalse: [ ^false ].
	
	binding := node binding.
	
	^binding isGlobalVariable! !

!ClySourceCodeContext methodsFor: 'selection' stamp: ''!
selectedVariable

	^self selectedSourceNode binding asCalypsoVariableOf: tool editingClass! !

!ClySourceCodeContext methodsFor: 'user requests' stamp: ''!
confirmUnusedVariablesInDefiningClass: variables
	^self browser confirmUnusedVariablesInDefiningClass: variables! !

!ClySourceCodeContext methodsFor: 'testing' stamp: ''!
isAssignmentSelected
	| node |
	node := self selectedSourceNode.
	[node notNil] whileTrue: [ 
		node isAssignment ifTrue: [ ^true ].
		node := node parent].
	^false! !

!ClySourceCodeContext methodsFor: 'user requests' stamp: ''!
confirmUnusedVariables: variables
	^self browser confirmUnusedVariables: variables! !

!ClySourceCodeContext methodsFor: 'accessing' stamp: ''!
selectedSourceNode: anObject
	selectedSourceNode := anObject! !

!ClySourceCodeContext methodsFor: 'command execution' stamp: ''!
executeCommand: aCommand by: aCommandActivator

	aCommand isComplexRefactoring ifTrue: [
		aCommand confirmRefactoringInContext: self by: aCommandActivator].
	
	aCommand execute! !

!ClySourceCodeContext methodsFor: 'selection' stamp: ''!
lastSelectedMessage

	^self selectedMessage! !

!ClySourceCodeContext methodsFor: 'testing' stamp: ''!
isClassSelected

	| node |
	node := self selectedSourceNode.
	node isVariable ifFalse: [ ^false ].
	
	^node binding isLiteralVariable 
		and: [ node binding isGlobalClassNameBinding ]! !

!ClySourceCodeContext methodsFor: 'testing' stamp: ''!
isMethodSelected 
	^false! !

!ClySourceCodeContext methodsFor: 'user requests' stamp: ''!
confirmUnusedClasses: variables
	^self browser confirmUnusedClasses: variables! !

!ClySourceCodeContext methodsFor: 'selection' stamp: ''!
selectedClasses

	^{self selectedClass}! !

!ClySourceCodeContext methodsFor: 'selection' stamp: ''!
selectedMessage
	^SycMessageDescription ofMessageNode: self selectedSourceNode! !

!ClySourceCodeContext methodsFor: 'selection' stamp: ''!
selectedVariables

	^{self selectedVariable}! !

!ClySourceCodeContext class methodsFor: 'instance creation' stamp: ''!
for: anEditorTool selectedNode: aProgramNode

	^(self for: anEditorTool)
		selectedSourceNode: aProgramNode! !

!ClySourceNodeCritiqueIntervalProperty commentStamp: ''!
I represent problem part of source code using interval.
  
Internal Representation and Key Implementation Points.

    Instance Variables
	start:		<Integer>
	stop:		<Integer>!
!ClySourceNodeCritiqueIntervalProperty methodsFor: 'accessing' stamp: ''!
stop
	^ stop! !

!ClySourceNodeCritiqueIntervalProperty methodsFor: 'accessing' stamp: ''!
stop: anObject
	stop := anObject! !

!ClySourceNodeCritiqueIntervalProperty methodsFor: 'accessing' stamp: ''!
start
	^ start! !

!ClySourceNodeCritiqueIntervalProperty methodsFor: 'accessing' stamp: ''!
start: anObject
	start := anObject! !

!ClySourceNodeCritiqueIntervalProperty class methodsFor: 'instance creation' stamp: ''!
from: anInterval

	anInterval ifEmpty: [ ^ self new start: 0; stop: 0 ].

	^self new 
		start: anInterval first;
		stop: anInterval last! !

!ClySpawnFullBrowserCommand commentStamp: ''!
I am a command to spawn full browser from current browser state.
I simply ask browser #spawnFullBrowser.

By default I am available everywhere using cmd+b shortcut and "Browse" context menu item.

Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>
!
!ClySpawnFullBrowserCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Browse'! !

!ClySpawnFullBrowserCommand methodsFor: 'execution' stamp: ''!
execute

	browser spawnFullBrowser! !

!ClySpawnFullBrowserCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	browser := aToolContext browser! !

!ClySpawnFullBrowserCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#glamorousBrowse! !

!ClySpawnFullBrowserCommand class methodsFor: 'activation' stamp: ''!
browserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClySystemBrowserContext! !

!ClySpawnFullBrowserCommand class methodsFor: 'activation' stamp: ''!
browserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $b meta for: ClySystemBrowserContext! !

!ClySpawnFullBrowserCommand class methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
queryBrowserDoubleClickMenuActivation
	<classAnnotation>
	
	^CmdDoubleClickActivation for: ClyQueryBrowserContext! !

!ClySpawnFullBrowserCommand class methodsFor: 'activation' stamp: ''!
fullBrowserDoubleClickMenuActivation
	<classAnnotation>
	
	^CmdDoubleClickActivation for: ClyFullBrowserContext! !

!ClySpawnFullBrowserCommand class methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
queryBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation byItemOf: ClyButtonToolbarGroup for: ClyQueryBrowserContext! !

!ClySpawnFullBrowserCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext hasSelectedItems! !

!ClyStandardBrowserPlugin commentStamp: ''!
I represent kind of standard browser plugin.
All table decorators are belongs to me by default.!
!ClyStandardBrowserPlugin methodsFor: 'accessing' stamp: ''!
priority
	^0! !

!ClyStatusBarItemMorph commentStamp: ''!
I am a base class for status bar items related to particular browser tab (tool).
My subclasses should implement method #build where they should create required widgets and subscribe of required events.

My instance should be create for concrete browser tool: 

	ClyStatusBarItem for: aBrowserTool
	
Internal Representation and Key Implementation Points.

    Instance Variables
	ownerTool:		<ClyBrowserTool>!
!ClyStatusBarItemMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.	
	self 
		changeTableLayout;
		listDirection: #leftToRight;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		extent: 0@0! !

!ClyStatusBarItemMorph methodsFor: 'accessing' stamp: ''!
ownerTool
	^ ownerTool! !

!ClyStatusBarItemMorph methodsFor: 'building' stamp: ''!
build
	self subclassResponsibility! !

!ClyStatusBarItemMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^Color transparent! !

!ClyStatusBarItemMorph methodsFor: 'accessing' stamp: ''!
ownerTool: anObject
	ownerTool := anObject.
	self build! !

!ClyStatusBarItemMorph class methodsFor: 'instance creation' stamp: ''!
for: aBrowserTool
	^self new 
		ownerTool: aBrowserTool! !

!ClyStatusBarMorph commentStamp: ''!
I represent browser tab status bar.
I provide two panels where items can be added: 

- commandBar
- contextBar 

It should be redone because it is completely strange names and separation of these panels.

Internal Representation and Key Implementation Points.

    Instance Variables
	commandBar:		<Morph>
	contextBar:		<Morph>
!
!ClyStatusBarMorph methodsFor: 'accessing' stamp: ''!
addContextItem: aMorph
	contextBar addMorphBack: aMorph.
	^aMorph! !

!ClyStatusBarMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.	
	self 
		color: self theme windowColor;
		changeTableLayout;
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		height: 0;
		minHeight: 0;
		layoutInset: 10@2.
	self buildContextBar.
	self buildCommandBar! !

!ClyStatusBarMorph methodsFor: 'updating' stamp: ''!
update
	"Here I just trying to reset extent.
	When there are no items it should hide it.
	Otherwise layout policy will ignore it".
	(contextBar submorphs isEmpty and: [commandBar submorphs isEmpty]) 
		ifTrue: [ 
			self height: 0.
			contextBar height: 0.
			commandBar height: 0]! !

!ClyStatusBarMorph methodsFor: 'initialization' stamp: ''!
buildContextBar
	contextBar := Morph new
		setNameTo: 'context bar';
		changeTableLayout;
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		cellInset: 4@0;
		color: Color transparent;
		height: 0;
		minHeight: 0.
	self addMorphBack: contextBar! !

!ClyStatusBarMorph methodsFor: 'initialization' stamp: ''!
buildCommandBar
	commandBar := Morph new
		setNameTo: 'command bar';
		changeTableLayout;
		listDirection: #rightToLeft;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		cellInset: 4@0;
		color: Color transparent;
		height: 0;
		minHeight: 0.
	self addMorphBack: commandBar! !

!ClyStatusBarMorph methodsFor: 'accessing' stamp: ''!
addCommandItem: aMorph
	commandBar addMorphBack: aMorph.
	^aMorph! !

!ClyStatusBarMorph methodsFor: 'accessing' stamp: ''!
clear
	commandBar removeAllMorphs.
	contextBar removeAllMorphs! !

!ClyStringPattern commentStamp: ''!
My subclasses represent specific kind of pattern to filter given strings.

Subclases should implement single method #matches: to check if string in argument is satisfied pattern.

If my subclasses define extra state the should implement comparison method according to my logic.

I keep actual pattern string in the value variable. 
Instances can be created using #with: message:
	ClySubstringPattern with: 'expected substring'

Internal Representation and Key Implementation Points.

    Instance Variables
	value:		<String>!
!ClyStringPattern methodsFor: 'accessing' stamp: ''!
value: anObject
	value := anObject! !

!ClyStringPattern methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ value = anObject value! !

!ClyStringPattern methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ value hash! !

!ClyStringPattern methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream 
		nextPut: $(;
		nextPutAll: value;
		nextPut: $)! !

!ClyStringPattern methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!ClyStringPattern methodsFor: 'testing' stamp: ''!
matches: aString
	self subclassResponsibility! !

!ClyStringPattern class methodsFor: 'instance creation' stamp: ''!
with: patternString
	^self new 
		value: patternString! !

!ClyStringPatternTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyStringPatternTest! !

!ClySubclassHierarchy commentStamp: ''!
I represent hierarchy of classes where roots are all common superclasses and children of every class are its subclasses.

In addition I provide default hierarchy for variables and for method visibility.

Variable hierarchy order them by relation between defining classes. I keep default hierarchy in class side variable #hierarchyForVariables.
You can invert it using settings or just by method call: 

	ClySubclassHierarchy invertVariableHierarchy.
	
The method visibility hierarchy is used to represent inherited classes in full browser when you expand first item in third pane. I manage default hierarchy in variable #hierarchyForMethodVisibility.
You can invert it using settings or just by method call: 

	ClySubclassHierarchy invertMethodVisibilityHierarchy!
!ClySubclassHierarchy methodsFor: 'building' stamp: ''!
buildParentMap: aHierarchyMap for: aClass

	| eachClass superclass |
	eachClass := aClass.
	[eachClass isRootInEnvironment] whileFalse: [ 
		superclass := eachClass superclass.	
		(aHierarchyMap includesClass: superclass) ifTrue: [
			^aHierarchyMap addChild: aClass to: superclass].
		eachClass := superclass]! !

!ClySubclassHierarchy class methodsFor: 'method visibility' stamp: ''!
invertMethodVisibilityHierarchy
	<script>
	^hierarchyForMethodVisibility := self hierarchyForMethodVisibility inverted! !

!ClySubclassHierarchy class methodsFor: 'method visibility' stamp: ''!
hierarchyForMethodVisibility
	^hierarchyForMethodVisibility ifNil: [ 
		hierarchyForMethodVisibility := self inverse]! !

!ClySubclassHierarchy class methodsFor: 'method visibility' stamp: ''!
isDefaultHierarchyForMethodVisibility
	^self hierarchyForMethodVisibility isInverse not! !

!ClySubclassHierarchy class methodsFor: 'variable hierarchy' stamp: ''!
isDefaultHierarchyForVariables
	^self hierarchyForVariables isInverse not! !

!ClySubclassHierarchy class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #isDefaultHierarchyForVariables)
		parent: #Calypso;
		label: 'Show variables in standard hierarchical order?';
		default: true;
		description: 'If true, FullBrowser will show variables in the order from superclass to subclass';
		target: self.
	(aBuilder setting: #isDefaultHierarchyForMethodVisibility)
		parent: #Calypso;
		default: false;		
		label: 'Show method visibility classes in standard hierarchical order?';
		description: 'If true, FullBrowser will show "inherited method" expanded classes in the order from superclass to subclass';
		target: self! !

!ClySubclassHierarchy class methodsFor: 'variable hierarchy' stamp: ''!
isDefaultHierarchyForVariables: aBool
	self isDefaultHierarchyForVariables = aBool 
		ifFalse: [ self invertVariableHierarchy ]! !

!ClySubclassHierarchy class methodsFor: 'method visibility' stamp: ''!
methodVisibilityProvider
	<classAnnotation>
	^ClyMethodVisibilityProviderAnnotation new! !

!ClySubclassHierarchy class methodsFor: 'method visibility' stamp: ''!
isDefaultHierarchyForMethodVisibility: aBool
	self isDefaultHierarchyForMethodVisibility = aBool
		ifFalse: [ self invertMethodVisibilityHierarchy ]! !

!ClySubclassHierarchy class methodsFor: 'variable hierarchy' stamp: ''!
hierarchyForVariables
	^hierarchyForVariables ifNil: [ 
		hierarchyForVariables := self new]! !

!ClySubclassHierarchy class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	hierarchyForMethodVisibility := nil.
	hierarchyForVariables := nil! !

!ClySubclassHierarchy class methodsFor: 'variable hierarchy' stamp: ''!
invertVariableHierarchy
	<script>
	^hierarchyForVariables := self hierarchyForVariables inverted! !

!ClySubclassLOfClass0FromPExtendedByP1Mock methodsFor: '*Calypso-SystemQueries-Tests-P1WithHierarchy' stamp: ''!
extensionMethodFromSubclassL! !

!ClySubclassLOfClass2FromP1Mock methodsFor: 'accessing' stamp: ''!
subclassClassVarReader
	^SubclassClassVar! !

!ClySubclassLOfClass2FromP1Mock methodsFor: 'accessing' stamp: ''!
subclassClassVar1Reader
	^ClassVar1! !

!ClySubclassLOfClass2FromP1Mock methodsFor: 'accessing' stamp: ''!
subclassClassVar1Writer
	ClassVar1 := #subclassClassVar1Value! !

!ClySubclassN1OfClass1FromP1Mock methodsFor: 'tag1' stamp: ''!
tag1Method1! !

!ClySubclassN1OfClass1FromP1Mock methodsFor: 'accessing' stamp: ''!
subclassSameVar

	^ subclassSameVar! !

!ClySubclassN1OfClass1FromP1Mock methodsFor: 'tag1' stamp: ''!
tag1Method2! !

!ClySubclassN1OfClass1FromP1Mock methodsFor: 'tag2' stamp: ''!
tag2Method1! !

!ClySubclassN1OfClass1FromP1Mock methodsFor: 'accessing' stamp: ''!
subclassN1Var

	^ subclassN1Var! !

!ClySubclassN1OfClass1FromP1Mock methodsFor: 'accessing' stamp: ''!
noTagMethod! !

!ClySubclassN1OfClass1FromP1Mock class methodsFor: 'accessing' stamp: ''!
classSideMethodFromSubclassN1! !

!ClySubclassN2OfClass1FromP1Mock methodsFor: 'accessing' stamp: ''!
superclassVar1WriterMethod
	instanceSideVar1 := #subclassVar1Value! !

!ClySubclassN2OfClass1FromP1Mock methodsFor: 'accessing' stamp: ''!
subclassN2VarReaderMethod
	^subclassN2Var! !

!ClySubclassN2OfClass1FromP1Mock methodsFor: 'accessing' stamp: ''!
subclassN2VarWriterMethod
	subclassN2Var := #subclassN2VarValue! !

!ClySubclassN2OfClass1FromP1Mock methodsFor: 'accessing' stamp: ''!
superclassVar1ReaderMethod
	^instanceSideVar1! !

!ClySubclassN2OfClass1FromP1Mock methodsFor: 'accessing' stamp: ''!
subclassSameVar

	^ subclassSameVar! !

!ClySubclassN2OfClass1FromP1Mock class methodsFor: 'accessing' stamp: ''!
classSideMethodFromSubclassN2! !

!ClySubclassScope commentStamp: ''!
I represent scope of all subclasses of my basis classes.  
I show all subclasses, their methods and variables!
!ClySubclassScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'subclasses'! !

!ClySubclassScope class methodsFor: 'accessing' stamp: ''!
classesRelatedTo: aClass do: aBlock

	aClass subclassesDo: aBlock! !

!ClySubclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumeration
	| expected |
	scope := ClySubclassScope of: ClyClass1FromP1Mock.
	
	scope classesDo: [ :each | result add: each ].
	
	expected := ClyClass1FromP1Mock allSubclasses.
	self assert: result asSet equals: expected asSet! !

!ClySubclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverClassWhenConcreteClassScopeIsLocal

	| expected |
	scope := ClySubclassScope of: Class localScope: ClyClassScope.

	scope classesDo: [ :each | result add: each].
	
	expected := Class allSubclasses asSet.
	self assert: result asSet equals: expected asSet! !

!ClySubclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverClassWhenClassSideIsLocalScope

	| expected |
	scope := ClySubclassScope of: Class localScope: ClyClassSideScope.

	scope classesDo: [ :each | result add: each].
	
	expected := Class subclasses select: #isInstanceSide thenCollect: #classSide.
	self assert: result asSet equals: expected asSet! !

!ClySubclassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenInstanceSideMetaLevel
	| subclassMethods |
	scope := ClySubclassScope of: ClyClass1FromP1Mock.
	scope localScopeClass: ClyInstanceSideScope.
	
	scope methodsDo: [ :each | result add: each ].
	
	self assert: (result includesAll: ClyClass1FromP1Mock subclasses first localMethods).
	subclassMethods := ClyClass1FromP1Mock subclasses
		flatCollect: [ :each | each classSide localMethods ].
	self assert: subclassMethods notEmpty.
	self deny: (result includesAll: subclassMethods)! !

!ClySubclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverClassWhenBothMetaLevelsAreLocalScope

	| expected |
	scope := ClySubclassScope of: Class localScope: ClyBothMetaLevelClassScope.

	scope classesDo: [ :each | result add: each].
	
	expected := Class subclasses select: #isInstanceSide.
	expected := expected flatCollect: [:each | {each instanceSide. each classSide}].
	self assert: result asSet equals: expected asSet! !

!ClySubclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverClassWhenInstanceSideIsLocalScope

	| expected |
	scope := ClySubclassScope of: Class localScope: ClyInstanceSideScope.

	scope classesDo: [ :each | result add: each].
	
	expected := Class subclasses select: #isInstanceSide.
	self assert: result asSet equals: expected asSet! !

!ClySubclassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBothMetaLevels

	scope := ClySubclassScope of: ClyClass1FromP1Mock localScope: ClyBothMetaLevelClassScope.
	
	scope methodsDo: [ :each | result add: each].
	
	self assert: (result includesAll: ClyClass1FromP1Mock subclasses first localMethods).
	self assert: (result includesAll: ClyClass1FromP1Mock subclasses first classSide localMethods).
	self assert: (result includesAll: ClyClass1FromP1Mock subclasses second localMethods).
	self assert: (result includesAll: ClyClass1FromP1Mock subclasses second classSide localMethods).
	self deny: (result includesAll: ClyClass1FromP1Mock localMethods).
	self deny: (result includesAll: ClyClass1FromP1Mock classSide localMethods).
	self deny: (result includesAll: ClyClass1FromP1Mock superclass localMethods).
	self deny: (result includesAll: ClyClass1FromP1Mock superclass classSide localMethods)! !

!ClySubclassScopeTest methodsFor: 'running' stamp: ''!
scopeClass
	
	^ClySubclassScope! !

!ClySubclassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumeration
	scope := ClySubclassScope of: ClyClass1FromP1Mock.
	
	scope methodsDo: [ :each | result add: each ].
	
	self assert: (result includesAll: ClyClass1FromP1Mock subclasses first localMethods).
	self deny: (result includesAll: ClyClass1FromP1Mock subclasses first classSide localMethods).
	self assert: (result includesAll: ClyClass1FromP1Mock subclasses second localMethods).
	self deny: (result includesAll: ClyClass1FromP1Mock subclasses second classSide localMethods).
	self deny: (result includesAll: ClyClass1FromP1Mock localMethods).
	self deny: (result includesAll: ClyClass1FromP1Mock classSide localMethods).
	self deny: (result includesAll: ClyClass1FromP1Mock superclass localMethods).
	self deny: (result includesAll: ClyClass1FromP1Mock superclass classSide localMethods)! !

!ClySubclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverMetaClass

	| expected |
	scope := ClySubclassScope of: ClyClass1FromP1Mock class.
	scope classesDo: [ :each | result add: each ].
	expected := ClyClass1FromP1Mock allSubclasses collect: [:each | each classSide].
	self assert: result asSet equals: expected asSet! !

!ClySubclassWithInheritedScripts commentStamp: ''!
I am example class which inherits scripts from superclass!
!ClySubclassWithTraitsOfClassWithTraits methodsFor: 'accessing' stamp: ''!
methodFromTraitChild3! !

!ClySubclassWithTraitsOfClassWithTraits methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait' stamp: ''!
extensionMethodFromRoot1Trait! !

!ClySubclassWithTraitsOfClassWithTraits methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait' stamp: ''!
extensionMethodFromClassItself! !

!ClySubclassWithTraitsOfClassWithTraits methodsFor: 'protocol' stamp: ''!
localMethodFromSubclass! !

!ClySubclassWithTraitsOfClassWithTraits methodsFor: 'accessing' stamp: ''!
methodFromRoot1! !

!ClySubclassWithTraitsOfClassWithTraits class methodsFor: 'accessing' stamp: ''!
classSideMethodFromRoot1! !

!ClySubstringPattern commentStamp: ''!
I represent string pattern using substring which tested strings are supposed to include.

I can be case sensitive or not depending on my variable.
To create my instances you can use following messages:
	ClySubstringPattern with: 'expected substring' caseSensitive: true
By default my instances are not case sensitive.	
	
Internal Representation and Key Implementation Points.

    Instance Variables
	isCaseSensitive:		<Boolean>!
!ClySubstringPattern methodsFor: 'accessing' stamp: ''!
isCaseSensitive: anObject
	isCaseSensitive := anObject! !

!ClySubstringPattern methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].

	^ isCaseSensitive = anObject isCaseSensitive! !

!ClySubstringPattern methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	isCaseSensitive := false! !

!ClySubstringPattern methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: isCaseSensitive hash! !

!ClySubstringPattern methodsFor: 'testing' stamp: ''!
matches: aString
	^aString includesSubstring: value caseSensitive: isCaseSensitive! !

!ClySubstringPattern methodsFor: 'accessing' stamp: ''!
isCaseSensitive
	^ isCaseSensitive! !

!ClySubstringPattern class methodsFor: 'instance creation' stamp: ''!
with: patternString caseSensitive: aBool 
	^(self with: patternString)
		isCaseSensitive: aBool! !

!ClySubstringPatternTest methodsFor: 'tests' stamp: ''!
testCaseInsensitiveByDefault

	| pattern |
	pattern := ClySubstringPattern with: 'subString'.
	
	self deny: pattern isCaseSensitive! !

!ClySubstringPatternTest methodsFor: 'tests' stamp: ''!
testComparison
	| pattern pattern2 |
	pattern := ClySubstringPattern with: 'subString' caseSensitive: true.
	pattern2 := ClySubstringPattern with: 'subString' copy caseSensitive: true.
	self assert: pattern equals: pattern2.
	self assert: pattern hash equals: pattern2 hash.

	pattern2 value: 'another pattern'.
	self deny: pattern equals: pattern2.

	pattern2 value: pattern value.
	pattern2 isCaseSensitive: pattern isCaseSensitive not.
	self deny: pattern equals: pattern2! !

!ClySubstringPatternTest methodsFor: 'tests' stamp: ''!
testCaseInsensitiveMathingString

	| pattern |
	pattern := ClySubstringPattern with: 'subString' caseSensitive: false.
	
	self assert: (pattern matches: 'start subString end').
	self assert: (pattern matches: 'start substring end').
	
	self deny: (pattern matches: 'another string').! !

!ClySubstringPatternTest methodsFor: 'tests' stamp: ''!
testCaseSensitiveMathingString

	| pattern |
	pattern := ClySubstringPattern with: 'subString' caseSensitive: true.
	
	self assert: (pattern matches: 'start subString end').
	
	self deny: (pattern matches: 'start substring end').! !

!ClySuperclassScope commentStamp: ''!
I represent scope of all superclasses of my basis classes.  
I show all superclasses, their methods and variables!
!ClySuperclassScope methodsFor: 'converting' stamp: ''!
asInterestingClassScope
	^self asScope: ClyInterestingSuperclassScope! !

!ClySuperclassScope class methodsFor: 'inherited scope' stamp: ''!
createInheritedScopeFrom: aClassScope
	^aClassScope asScope: self! !

!ClySuperclassScope class methodsFor: 'inherited scope' stamp: ''!
createInheritingScopeFrom: aClassScope
	^aClassScope asScope: ClySubclassScope! !

!ClySuperclassScope class methodsFor: 'inherited scope' stamp: ''!
inheritedScopeProvider
	<classAnnotation>
	
	^ClyInheritedScopeProviderAnnotation new! !

!ClySuperclassScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'superclasses'! !

!ClySuperclassScope class methodsFor: 'converting' stamp: ''!
asInterestingClassScope
	^ClyInterestingSuperclassScope! !

!ClySuperclassScope class methodsFor: 'accessing' stamp: ''!
classesRelatedTo: aClass do: aBlock
	aClass isRootInEnvironment ifTrue: [ ^self ].
	
	aBlock value: aClass superclass! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumeration
	| expected |
	scope := ClySuperclassScope of: ClyClass1FromP1Mock.
	
	scope classesDo: [ :each | result add: each ].
	
	expected := ClyClass1FromP1Mock allSuperclasses.
	self assert: result asArray equals: expected asArray! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationOverMetaclassWhenClassSideIsLocalScope

	| expected |
	scope := ClySuperclassScope of: ClyClass1FromP1Mock class localScope: ClyClassSideScope.
	
	scope methodsDo: [ :each | result add: each].

	expected := { Object class. ProtoObject class  } flatCollect: #localMethods as: IdentitySet..
	self assert: result asIdentitySet equals: expected! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationOverMetaclassWhenBothMetaLevelsAreLocalScope

	| expected |
	scope := ClySuperclassScope of: ClyClass1FromP1Mock class localScope: ClyBothMetaLevelClassScope.
	
	scope methodsDo: [ :each | result add: each].

	expected := { Object. Object class. ProtoObject. ProtoObject class  }
		flatCollect: #localMethods as: IdentitySet..
	self assert: result asIdentitySet equals: expected! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverMetaclassWhenClassSideIsLocalScope

	scope := ClySuperclassScope of: ClyClass1FromP1Mock class localScope: ClyClassSideScope.
	
	scope classesDo: [ :each | result add: each].
	
	self assert: result asSet equals: {Object class. ProtoObject class } asSet! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverMetaclassBasisWhenInstanceSideIsLocalScope

	scope := ClySuperclassScope of: ClyClass1FromP1Mock class localScope: ClyInstanceSideScope.
	
	scope classesDo: [ :each | result add: each].
	
	self assert: result asSet equals: {Object. ProtoObject } asSet! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverInstanceSideBasisWhenBothMetaLevelsAreLocalScope

	scope := ClySuperclassScope of: ClyClass1FromP1Mock localScope: ClyBothMetaLevelClassScope.
	
	scope classesDo: [ :each | result add: each].
	
	self assert: result asSet equals: {Object. Object class. ProtoObject. ProtoObject class } asSet! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationOverMetaclassWhenConcreteClassScopeIsScope

	| expected |
	scope := ClySuperclassScope of: ClyClass1FromP1Mock class localScope: ClyClassScope.
	
	scope methodsDo: [ :each | result add: each].

	"Now we should see more classes than Object and ProtoObject 
	because ProtoObject class has more superclasses including Object and ProtoObject itself"
	expected := ClyClass1FromP1Mock class allSuperclasses flatCollect: #methods as: IdentitySet.
	self assert: result asIdentitySet equals: expected! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWithBothMetaLevelScopeShouldNotDublicateMethods
	| expected |
	scope := ClySuperclassScope of: ClySubclassN1OfClass1FromP1Mock localScope: ClyBothMetaLevelClassScope.
	
	scope methodsDo: [ :each | 
		each methodClass instanceSide = ClyClass1FromP1Mock ifTrue: [result add: each] ].
	
	expected := (ClyClass1FromP1Mock localMethods , ClyClass1FromP1Mock class localMethods) asIdentitySet.
	self assert: result asIdentitySet equals: expected! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationOverInstanceSideWhenBothMetaLevelsAreLocalScope

	| expected |
	scope := ClySuperclassScope of: ClyClass1FromP1Mock localScope: ClyBothMetaLevelClassScope.
	
	scope methodsDo: [ :each | result add: each].

	expected := { Object. Object class. ProtoObject. ProtoObject class  }
		flatCollect: #localMethods as: IdentitySet..
	self assert: result asIdentitySet equals: expected! !

!ClySuperclassScopeTest methodsFor: 'running' stamp: ''!
scopeClass
	
	^ClySuperclassScope! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToInterestingClassScope
	| convertedScope |
	scope := self createSampleScope.
	scope localScopeClass: ClyInstanceSideScope.
	
	convertedScope := scope asInterestingClassScope.
	
	self assert: convertedScope class equals: ClyInterestingSuperclassScope.
	self assert: convertedScope basisObjects equals: scope basisObjects.
	self assert: convertedScope localScopeClass equals: scope localScopeClass.
	self assert: convertedScope environment equals: scope environment! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumeration
	| expected |
	scope := ClySuperclassScope of: ClyClass1FromP1Mock.
	
	scope methodsDo: [ :each | result add: each ].
	
	expected := {Object.
	ProtoObject} flatCollect: #localMethods as: IdentitySet.
	self assert: result asIdentitySet equals: expected! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverMetaclassWhenBothMetaLevelsAreLocalScope

	scope := ClySuperclassScope of: ClyClass1FromP1Mock class localScope: ClyBothMetaLevelClassScope.
	
	scope classesDo: [ :each | result add: each].
	
	self assert: result asSet equals: {Object. Object class. ProtoObject. ProtoObject class } asSet! !

!ClySuperclassScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumerationOverMetaclassWhenConcreteClassScopeIsLocal

	scope := ClySuperclassScope of: ClyClass1FromP1Mock class localScope: ClyClassScope.

	scope classesDo: [ :each | result add: each].
	
	self assert: result asSet equals: ClyClass1FromP1Mock class allSuperclasses asSet! !

!ClySuperclassVisibilityLevel commentStamp: ''!
I represent visibility of methods of concrete class.
My extra scope is created for single class: 
	visibleScope asScope: ClyClassScope of: aConcreteSuperclass
	
My instances are created using following method:

	ClySuperclassVisibilityLevel of: aClassScope toShow: aClass!
!ClySuperclassVisibilityLevel methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	| tool |
	tool := ClyMethodVisibilityMorph for: anItemCellMorph browser level: self.
	tool build.
	anItemCellMorph definitionMorph: tool! !

!ClySuperclassVisibilityLevel methodsFor: '*Calypso-SystemPlugins-Traits-Queries' stamp: ''!
asTraitVisibility
	| traits |
	traits := extraClassScope basisObjects select: [ :each | each isTrait ].
	
	^(ClySingleTraitVisibilityLevel of: visibleClassScope)
		extraClassScope: (visibleClassScope asScope: ClyClassScope ofAll: traits)! !

!ClySuperclassVisibilityLevel class methodsFor: 'instance creation' stamp: ''!
of: aClassScope toShow: aClass
	^(self of: aClassScope)
		extraClassScope: (aClassScope asScope: ClyClassScope of: aClass)! !

!ClySwitchBrowserModeCommand commentStamp: ''!
I am a root of commands which are supposed to switch browser mode.
My instances are represented in browser toolbar as radio buttons which state reflects the "applied status" of the command.
So subclasses should implement the method #isAppliedToBrowser.

The radio button is wraped by ClyBrowserModeSwitch widget.

Also I force browser toolbar update after execution!
!ClySwitchBrowserModeCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	browser rebuildToolbar! !

!ClySwitchBrowserModeCommand methodsFor: 'activation - toolbar support' stamp: ''!
createToolbarItemFor: aCommandActivator

	^ClyBrowserModeSwitchMorph activatingBy: aCommandActivator! !

!ClySwitchBrowserModeCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser
	self subclassResponsibility! !

!ClySwitchBrowserModeCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClySwitchBrowserModeCommand! !

!ClySwitchClassMetaLevelCommand commentStamp: ''!
I am a base class for the commands which switch the full browser meta level.
Full browser can show instance side or class side of selected classes.

My subclasses define target meta level in following method: 

- metaLevelScope
It should return ClyInstanceSideScope or ClyClassSideScope.

Also I am annotated with toolbar activation strategy. So my subclasses will be shown in the browser toolbar as radio buttons.
And they should implement #toolbarOrder method
!
!ClySwitchClassMetaLevelCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^self metaLevelScope defaultName capitalized! !

!ClySwitchClassMetaLevelCommand methodsFor: 'execution' stamp: ''!
execute
	browser switchToMetaLevelScope: self metaLevelScope! !

!ClySwitchClassMetaLevelCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser
	^browser metaLevelScope = self metaLevelScope! !

!ClySwitchClassMetaLevelCommand methodsFor: 'execution' stamp: ''!
metaLevelScope
	self subclassResponsibility! !

!ClySwitchClassMetaLevelCommand class methodsFor: 'activation' stamp: ''!
fullBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation 
		byItemOf: ClyMetaLevelToolbarGroup 
		order: self toolbarOrder 
		for: ClyFullBrowserClassContext! !

!ClySwitchClassMetaLevelCommand class methodsFor: 'activation' stamp: ''!
toolbarOrder
	<classAnnotationDependency>
	
	self subclassResponsibility! !

!ClySwitchClassMetaLevelCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClySwitchClassMetaLevelCommand! !

!ClySwitchClassViewModeCommand commentStamp: ''!
I am a base class for the commands which switch the full browser mode of the class view.
It can be flat list or class hierarchy for example!
!ClySwitchClassViewModeCommand class methodsFor: 'activation' stamp: ''!
fullBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation byItemOf: ClyClassHierarchyToolbarGroup for: ClyFullBrowserClassContext! !

!ClySwitchClassViewModeCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClySwitchClassViewModeCommand! !

!ClySwitchClassViewModeCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isClassSelected! !

!ClySwitchFocusToNextBrowserPaneCommand commentStamp: ''!
I am a command to move browser focus to next (right) navigation pane!
!ClySwitchFocusToNextBrowserPaneCommand methodsFor: 'execution' stamp: ''!
execute
	browser switchFocusToNextPane! !

!ClySwitchFocusToNextBrowserPaneCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext
	^aBrowserContext browser isNavigationPanelFocused! !

!ClySwitchFocusToNextBrowserPaneCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: Character arrowRight asShortcut for: ClyFullBrowserContext! !

!ClySwitchFocusToPreviousBrowserPaneCommand commentStamp: ''!
I am a command to move browser focus to previous (left) navigation pane!
!ClySwitchFocusToPreviousBrowserPaneCommand methodsFor: 'execution' stamp: ''!
execute
	browser switchFocusToPreviousPane! !

!ClySwitchFocusToPreviousBrowserPaneCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aBrowserContext
	^aBrowserContext browser isNavigationPanelFocused! !

!ClySwitchFocusToPreviousBrowserPaneCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: Character arrowLeft asShortcut for: ClyFullBrowserContext! !

!ClySwitchMethodViewModeCommand commentStamp: ''!
I am a base class for commands which switch full browser method group mode.
It can be either method groups or variables.

Subclasses define what kind of method groups whey target. They implement following class side method: 

- methodGroupType!
!ClySwitchMethodViewModeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^self methodGroupType shortName! !

!ClySwitchMethodViewModeCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser
	^browser methodGroupView showsItemsOfType: self methodGroupType! !

!ClySwitchMethodViewModeCommand methodsFor: 'accessing' stamp: ''!
methodGroupType
	self subclassResponsibility! !

!ClySwitchMethodViewModeCommand class methodsFor: 'activation' stamp: ''!
fullBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation byItemOf: ClyMethodViewToolbarGroup for: ClyFullBrowserClassContext! !

!ClySwitchMethodViewModeCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClySwitchMethodViewModeCommand! !

!ClySwitchMethodViewModeCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isClassSelected! !

!ClySwitchPackageViewModeCommand commentStamp: ''!
I am a base class for commands which switch full browser package mode
It can be either raw packages or projects!
!ClySwitchPackageViewModeCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser
	^false! !

!ClySwitchPackageViewModeCommand class methodsFor: 'activation' stamp: ''!
fullBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation 
		byItemOf: ClyPackageToolbarGroup 
		order: self toolbarOrder
		for: ClyFullBrowserPackageContext! !

!ClySwitchPackageViewModeCommand class methodsFor: 'activation' stamp: ''!
fullBrowserToolbarActivation3
	<classAnnotation>
	
	^ClyToolbarActivation 
		byItemOf: ClyPackageToolbarGroup 
		order: self toolbarOrder
		for: ClyFullBrowserProjectContext! !

!ClySwitchPackageViewModeCommand class methodsFor: 'activation' stamp: ''!
fullBrowserToolbarActivation2
	<classAnnotation>
	
	^ClyToolbarActivation 
		byItemOf: ClyPackageToolbarGroup 
		order: self toolbarOrder
		for: ClyFullBrowserClassGroupContext! !

!ClySwitchPackageViewModeCommand class methodsFor: 'activation' stamp: ''!
toolbarOrder
	<classAnnotationDependency>
	^10! !

!ClySwitchPackageViewModeCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClySwitchPackageViewModeCommand! !

!ClySwitchQueryResultCommand commentStamp: ''!
I am a base class for the commands which switch the required result in query browser.
It can be flat list or hierarchically sorted items.

My subclasses should implement class side method:

- requiredQueryResult!
!ClySwitchQueryResultCommand class methodsFor: 'activation' stamp: ''!
queryBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation byItemOf: ClyQueryResultToolbarGroup for: ClyQueryBrowserContext! !

!ClySwitchQueryResultCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClySwitchQueryResultCommand! !

!ClySwitchQueryScopeCommand commentStamp: ''!
I am a command to switch the current scope of the query in the query browser.

Currently I support only context menu and toolbar activation where I retrieve available navigation scopes from the browser to allow user select one of them.

Internal Representation and Key Implementation Points.

    Instance Variables
	queryScope:		<ClyScope>!
!ClySwitchQueryScopeCommand methodsFor: 'activation - toolbar support' stamp: ''!
addToolbarItemInto: toolbarMorph using: aCommandActivator
	
	| compoBox |
	compoBox := ClyScopeCompoBoxMorph for: browser.
	
	toolbarMorph addNewItem: compoBox! !

!ClySwitchQueryScopeCommand methodsFor: 'accessing' stamp: ''!
queryScope: anObject
	queryScope := anObject! !

!ClySwitchQueryScopeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	queryScope ifNil: [ ^'Switch scope' ].
	
	^'Switch scope to ', queryScope description! !

!ClySwitchQueryScopeCommand methodsFor: 'execution' stamp: ''!
execute
	browser switchScopeTo: queryScope! !

!ClySwitchQueryScopeCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser
	^browser isQueryScopeActive: queryScope! !

!ClySwitchQueryScopeCommand methodsFor: 'accessing' stamp: ''!
defaultToolbarItemName
	
	^queryScope description! !

!ClySwitchQueryScopeCommand methodsFor: 'activation - context menu' stamp: ''!
fillContextMenu: aMenu using: aCommandActivator
	| concreteScopeCommand switchActivator |
	
	browser allNavigationScopes do: [ :newScope |
		concreteScopeCommand := self class toScope: newScope in: browser.
		switchActivator := aCommandActivator newForCommand: concreteScopeCommand.
		aMenu 	add: switchActivator menuItemName target: switchActivator selector: #executeCommand]! !

!ClySwitchQueryScopeCommand methodsFor: 'accessing' stamp: ''!
queryScope
	^ queryScope! !

!ClySwitchQueryScopeCommand class methodsFor: 'instance creation' stamp: ''!
toScope: anEnvironmentScope in: aBrowser
	^self new 
		browser: aBrowser;
		queryScope: anEnvironmentScope! !

!ClySwitchQueryScopeCommand class methodsFor: 'activation' stamp: ''!
queryBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClySwitchScopeMenuGroup for: ClyQueryBrowserContext! !

!ClySwitchQueryScopeCommand class methodsFor: 'activation' stamp: ''!
queryBrowserToolbarActivation
	<classAnnotation>
	
	^ClyToolbarActivation byItemOf: ClyQueryResultToolbarGroup order: -5 for: ClyQueryBrowserContext! !

!ClySwitchScopeMenuGroup commentStamp: ''!
I am a context menu group which holds all generated ClySwitchQueryScopeCommand items!
!ClySwitchScopeMenuGroup methodsFor: 'accessing' stamp: ''!
order
	^50000! !

!ClySwitchScopeMenuGroup methodsFor: 'accessing' stamp: ''!
name
	^'Switch scope to'! !

!ClySwitchScopeMenuGroup class methodsFor: 'parents' stamp: ''!
parentGroup
	^ClyQueryMenuGroup! !

!ClySwitchToClassSideCommand commentStamp: ''!
I am a command to switch full browser to the class side mode!
!ClySwitchToClassSideCommand methodsFor: 'execution' stamp: ''!
metaLevelScope
	^ClyClassSideScope! !

!ClySwitchToClassSideCommand class methodsFor: 'activation' stamp: ''!
toolbarOrder
	^2! !

!ClySwitchToFlatClassesCommand commentStamp: ''!
I am a command to switch the full browser to flat class mode!
!ClySwitchToFlatClassesCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Flat'! !

!ClySwitchToFlatClassesCommand methodsFor: 'execution' stamp: ''!
execute

	browser switchToFlatClasses! !

!ClySwitchToFlatClassesCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser

	^browser showsFlatClasses! !

!ClySwitchToFlatQueryResultCommand commentStamp: ''!
I am a command to switch query browser to flat items list.

By default flat list is sorted by item name (selector in case of methods)!
!ClySwitchToFlatQueryResultCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Flat'! !

!ClySwitchToFlatQueryResultCommand methodsFor: 'execution' stamp: ''!
execute
	browser switchToFlatResult! !

!ClySwitchToFlatQueryResultCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser
	^browser showsFlatResult! !

!ClySwitchToFullHierarchyCommand commentStamp: ''!
I am a command to switch the full browser to full hierarchy mode of selected classes!
!ClySwitchToFullHierarchyCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Hier.'! !

!ClySwitchToFullHierarchyCommand methodsFor: 'execution' stamp: ''!
execute
	
	browser switchToFullClassHierarchy! !

!ClySwitchToFullHierarchyCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser

	^browser showsFullClassHierarchy! !

!ClySwitchToFullHierarchyCommand class methodsFor: '*Calypso-SystemPlugins-Traits-Browser' stamp: ''!
canBeExecutedInContext: aToolContext
	(super canBeExecutedInContext: aToolContext) ifFalse: [ ^false ].
	
	^aToolContext isTraitSelected not! !

!ClySwitchToFullHierarchyCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $h meta for: ClyFullBrowserClassContext! !

!ClySwitchToHierarchicalQueryResultCommand commentStamp: ''!
I am a command to switch query browser to hierarchically sorted items list.

In this mode items is grouped by defining class and shown in class hierarchy tree sorted by name!
!ClySwitchToHierarchicalQueryResultCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Hier.'! !

!ClySwitchToHierarchicalQueryResultCommand methodsFor: 'execution' stamp: ''!
execute
	browser switchToHierarchicalResult! !

!ClySwitchToHierarchicalQueryResultCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser
	^browser showsFlatResult not! !

!ClySwitchToInheritedTraitsCommand commentStamp: ''!
I a command to show in browser a hierarchy of traits which are inherited by selected classes!
!ClySwitchToInheritedTraitsCommand methodsFor: 'execution' stamp: ''!
requiredQueryResult
	^ClyTraitUserHierarchy inverse asQueryResult! !

!ClySwitchToInheritedTraitsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Traits'! !

!ClySwitchToInheritedTraitsCommand methodsFor: 'execution' stamp: ''!
traitScopeClass
	^ClyInheritedTraitScope! !

!ClySwitchToInheritedTraitsCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	(super canBeExecutedInContext: aToolContext) ifFalse: [ ^false ].
	
	^aToolContext isSelectedClassUsesTraits! !

!ClySwitchToInstanceSideCommand commentStamp: ''!
I am a command to switch full browser to the instance side mode!
!ClySwitchToInstanceSideCommand methodsFor: 'execution' stamp: ''!
metaLevelScope
	^ClyInstanceSideScope! !

!ClySwitchToInstanceSideCommand class methodsFor: 'activation' stamp: ''!
toolbarOrder
	^1! !

!ClySwitchToMethodGroupsCommand commentStamp: ''!
I am a command to switch full browser to the method group mode.
In that state browser shows method tags (protocol) and other virtual groups!
!ClySwitchToMethodGroupsCommand methodsFor: 'controling' stamp: ''!
execute
	browser switchToMethodGroups! !

!ClySwitchToMethodGroupsCommand methodsFor: 'accessing' stamp: ''!
methodGroupType
	^ClyMethodGroup! !

!ClySwitchToPackagesCommand commentStamp: ''!
I am a command to switch full browser to raw packages mode. !
!ClySwitchToPackagesCommand methodsFor: 'accessing' stamp: ''!
description
	^ 'Click to show all packages'.! !

!ClySwitchToPackagesCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	
	^ 'All Packages'! !

!ClySwitchToPackagesCommand methodsFor: 'execution' stamp: ''!
execute
	^browser switchToPackages! !

!ClySwitchToPackagesCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser

	^ (browser packageView showsItemsFromQuery: ClyAllPackagesQuery) and: [ browser isScopedModeEnabled not ]! !

!ClySwitchToPackagesCommand class methodsFor: 'activation' stamp: ''!
toolbarOrder
	^1! !

!ClySwitchToProjectsCommand commentStamp: ''!
I am a command to switch full browser to the projects mode.

Projects mode is not really supported. It requires plugin which provides package manager implementation.
There is Cargo package manager. But it is not ready yet.
Normally we should implement Metacello integration.!
!ClySwitchToProjectsCommand methodsFor: 'accessing' stamp: ''!
description
	^'Do not supported currently'! !

!ClySwitchToProjectsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Projects'! !

!ClySwitchToProjectsCommand methodsFor: 'execution' stamp: ''!
execute
	browser switchToProjects! !

!ClySwitchToProjectsCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser

	^ browser isInProjectView! !

!ClySwitchToProjectsCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aContext

	^ ClySystemEnvironment currentImage projectManager projectManagers notEmpty! !

!ClySwitchToScopedModeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Set up scope'! !

!ClySwitchToScopedModeCommand methodsFor: 'execution' stamp: ''!
execute
	
	browser switchToPackageScopeOf: packages! !

!ClySwitchToScopedModeCommand methodsFor: 'accessing' stamp: ''!
packages
	^ packages! !

!ClySwitchToScopedModeCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aBrowserContext
	|items|
	super prepareFullExecutionInContext: aBrowserContext.
	items := aBrowserContext selectedPackageItems collect: [:e | e actualObject ].
	packages := browser searchDialog 
		requestMultipleObjects: 'Select package scope' 
		from: ClyAllPackagesQuery sorted
		selecting: items.
	packages ifEmpty: [ CmdCommandAborted signal ]! !

!ClySwitchToScopedModeCommand methodsFor: 'accessing' stamp: ''!
packages: anObject
	packages := anObject! !

!ClySwitchToScopedModeCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: ClyFullBrowserPackageContext! !

!ClySwitchToScopedViewCommand methodsFor: 'accessing' stamp: ''!
description

	^ 'Scope to selected packages'.! !

!ClySwitchToScopedViewCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	
	^ 'Scoped View'! !

!ClySwitchToScopedViewCommand methodsFor: 'execution' stamp: ''!
execute
	
	^ browser packageSelection actualObjects ifNotEmpty: [ :packages |
		browser switchToPackageScopeOf: packages]! !

!ClySwitchToScopedViewCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser

	^ (browser packageView showsItemsFromQuery: ClyAllPackagesQuery) and: [ browser isScopedModeEnabled ]! !

!ClySwitchToScopedViewCommand class methodsFor: 'activation' stamp: ''!
toolbarOrder
	^1! !

!ClySwitchToTraitUsersCommand commentStamp: ''!
I a command to show in browser a hierarchy of traits which are used by selected classes!
!ClySwitchToTraitUsersCommand methodsFor: 'execution' stamp: ''!
requiredQueryResult
	^ClyTraitUserHierarchy new asQueryResult! !

!ClySwitchToTraitUsersCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Users'! !

!ClySwitchToTraitUsersCommand methodsFor: 'execution' stamp: ''!
traitScopeClass
	^ClyTraitUserScope! !

!ClySwitchToTraitUsersCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	(super canBeExecutedInContext: aToolContext) ifFalse: [ ^false ].
	
	^aToolContext isTraitSelected! !

!ClySwitchToVariablesCommand commentStamp: ''!
I am a command to switch full browser to the variables mode.
In that state browser shows variables in the third pane!
!ClySwitchToVariablesCommand methodsFor: 'controling' stamp: ''!
execute
	browser switchToVariables! !

!ClySwitchToVariablesCommand methodsFor: 'accessing' stamp: ''!
methodGroupType
	^ClyVariable! !

!ClySwitchTraitHierarchyModeCommand commentStamp: ''!
I am abstract command which subclasses should switch browser to particular trait hierarchy mode.
They should implement two methods: 

- requiredQueryResult
- traitScopeClass

Note that while scope and result in that cases are use same type of trait relation between classes they still provide different concerns and can be merged in single entity:
- required result is responsible to build trait hierarhcy from given set of classes 
- trat scope is responsible to retrieve trait related classes from given scope!
!ClySwitchTraitHierarchyModeCommand methodsFor: 'execution' stamp: ''!
requiredQueryResult
	self subclassResponsibility! !

!ClySwitchTraitHierarchyModeCommand methodsFor: 'execution' stamp: ''!
execute
	| classScope |
	classScope := browser classSelection asItemsScope: ClyClassScope.
	
	browser 
		switchClassViewTo: self requiredQueryResult
		inScope: classScope, (classScope asScope: self traitScopeClass)! !

!ClySwitchTraitHierarchyModeCommand methodsFor: 'testing' stamp: ''!
isAppliedToBrowser

	^browser classView showsItemsFromScope: self traitScopeClass! !

!ClySwitchTraitHierarchyModeCommand methodsFor: 'execution' stamp: ''!
traitScopeClass
	self subclassResponsibility! !

!ClySwitchTraitHierarchyModeCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClySwitchTraitHierarchyModeCommand! !

!ClySystemBrowserContext commentStamp: ''!
I am a root of contexts hierarchy which represent the state of any kind of system browsers.

I define main interface to check the browser state:  

- For packages: 
	
	- selectedPackages 
	- lastSelectedPackage
	- isPackageSelected
	
- For classes 

	- selectedClasses 
	- lastSelectedClass
	- isClassSelected

- For methods 

	- selectedMethods 
	- lastSelectedMethod
	- isMethodSelected

- For messages 

	- selectedMessages 
	- lastSelectedMessage
	- isMessageSelected

Message is a selector+arguments. Any method defines correspondant message. So it allows to have polymorphic interface to work with messages like in the source code editor. 

In addition I provide tool controlling methods: 

- showClass: aClass
- showMethod: aMethod 
- showMessage: aMessage renamedTo: newSelector 

And I implement simplified search requests: 

- requestSinglePackage: 'Choose a package'
- requestSingleClass: 'Choose a class'
- requestSingleMethodTag: 'Choose a protocol'
!
!ClySystemBrowserContext methodsFor: 'selection-methods' stamp: ''!
selectedMethods
	^self actualSelectionFrom: self selectedMethodItems! !

!ClySystemBrowserContext methodsFor: 'selection-methods' stamp: ''!
isExtensionMethodSelected

	self isMethodSelected ifFalse: [ ^false].
	
	^self selectedMethodItems anySatisfy: [ :each |
		each systemDefinition isExtension]! !

!ClySystemBrowserContext methodsFor: 'selection-packages' stamp: ''!
isPackageSelected
	^self selectedPackageItems notEmpty! !

!ClySystemBrowserContext methodsFor: 'selection-classes' stamp: ''!
lastSelectedClass
	^self lastSelectedObjectIn: self selectedClasses! !

!ClySystemBrowserContext methodsFor: 'selection-packages' stamp: ''!
lastSelectedPackage
	^self lastSelectedObjectIn: self selectedPackages! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
requestRemoveClassStrategyFor: classes
	^tool requestRemoveClassStrategyFor: classes! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
requestSinglePackage: queryTitle
	^tool searchDialog requestSingleObject: queryTitle from: ClyAllPackagesQuery sorted! !

!ClySystemBrowserContext methodsFor: 'selection-messages' stamp: ''!
selectedMessages
	^self selectedMethods collect: [ :each | SycMessageDescription ofMethod: each ]! !

!ClySystemBrowserContext methodsFor: 'selection-methods' stamp: ''!
isInstanceSideMethodSelected

	self isMethodSelected ifFalse: [ ^false].
	
	^self selectedMethodItems anySatisfy: [ :each |
		each systemDefinition isInstanceSide ]! !

!ClySystemBrowserContext methodsFor: 'selection-methods' stamp: ''!
selectedMethodItems
	self subclassResponsibility! !

!ClySystemBrowserContext methodsFor: '*Calypso-SystemPlugins-ClassScripts-Browser' stamp: ''!
isClassScriptSelected

	^self isMethodSelected and: [ 
		(self lastSelectedObjectIn: self selectedMethodItems) hasProperty: ClyClassScriptProperty]! !

!ClySystemBrowserContext methodsFor: 'refactoring support' stamp: ''!
refactoringScopes
	"It returns default browser scope as first one which makes it default for users"
	| allScopes defaultScope |
	allScopes := tool allNavigationScopes.
	defaultScope := tool defaultNavigationScope.
	^(allScopes copyWithout: defaultScope) copyWithFirst: defaultScope! !

!ClySystemBrowserContext methodsFor: '*Calypso-SystemPlugins-ClassScripts-Browser' stamp: ''!
selectedClassScript

	| methodItem |
	methodItem := self lastSelectedObjectIn: self selectedMethodItems.
	^(methodItem getProperty: ClyClassScriptProperty) script! !

!ClySystemBrowserContext methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
browseVariableReferencesOf: variables

	tool spawnQueryBrowserOn: (ClyVariableReferencesQuery ofAny: variables )! !

!ClySystemBrowserContext methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
isSelectedItemHasBreakpoint
	^selectedItems anySatisfy: [ :each | 
		each isMarkedWith: ClyMethodWithBreakpointTag ]! !

!ClySystemBrowserContext methodsFor: 'selection-messages' stamp: ''!
isMessageSelected
	^self isMethodSelected! !

!ClySystemBrowserContext methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
isSelectedItemHasExecutionCounter
	^selectedItems anySatisfy: [ :each | 
		each isMarkedWith: ClyMethodWithExecutionCounterTag ]! !

!ClySystemBrowserContext methodsFor: '*Calypso-SystemPlugins-Traits-Browser' stamp: ''!
isSelectedClassUsesTraits
	| classItem |
	classItem := self lastSelectedObjectIn: self selectedClassItems.
	
	^classItem isMarkedWith: ClyTraitUserTag! !

!ClySystemBrowserContext methodsFor: '*Calypso-SystemPlugins-Reflectivity-Browser' stamp: ''!
isSelectedItemHasWatch
	^selectedItems anySatisfy: [ :each | 
		each isMarkedWith: ClyMethodWithWatchTag ]! !

!ClySystemBrowserContext methodsFor: 'selection-methods' stamp: ''!
lastSelectedSourceNode

	^self lastSelectedMethod astForStylingInCalypso! !

!ClySystemBrowserContext methodsFor: 'selection-packages' stamp: ''!
selectedPackageItems
	self subclassResponsibility! !

!ClySystemBrowserContext methodsFor: 'accessing' stamp: ''!
systemEnvironment
	^self system! !

!ClySystemBrowserContext methodsFor: 'selection-packages' stamp: ''!
selectedPackages
	^self actualSelectionFrom: self selectedPackageItems! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
requestMultiplePackages: queryTitle

	^ tool searchDialog 
		requestMultipleObjects: queryTitle 
		from: ClyAllPackagesQuery sorted! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
requestMultipleVariables: queryTitle from: classes

	^tool searchDialog 
		requestMultipleObjects: queryTitle 
		from: ClyAllInstanceVariablesQuery sorted
		inScope: (ClyClassScope ofAll: classes) withInheritedScope! !

!ClySystemBrowserContext methodsFor: 'selection-methods' stamp: ''!
isClassSideMethodSelected

	self isMethodSelected ifFalse: [ ^false].
	
	^self selectedMethodItems anySatisfy: [ :each |
		each systemDefinition isInstanceSide not]! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
confirmUnusedVariablesInDefiningClass: variables
	^tool confirmUnusedVariablesInDefiningClass: variables! !

!ClySystemBrowserContext methodsFor: 'selection-classes' stamp: ''!
selectedClassItems
	self subclassResponsibility! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
confirmUnusedVariables: variables
	^tool confirmUnusedVariables: variables! !

!ClySystemBrowserContext methodsFor: 'tool controlling' stamp: ''!
showClass: aClass
	tool selectClass: aClass! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
requestSingleClass: queryTitle

	^tool searchDialog requestSingleObject: queryTitle from: ClyAllClassesQuery sorted! !

!ClySystemBrowserContext methodsFor: 'command execution' stamp: ''!
executeCommand: aCommand by: aCommandActivator

	aCommand isComplexRefactoring ifTrue: [
		aCommand confirmRefactoringInContext: self by: aCommandActivator].
	
	aCommand execute! !

!ClySystemBrowserContext methodsFor: 'selection-methods' stamp: ''!
firstSelectedMethod
	^self firstSelectedObjectIn: self selectedMethods! !

!ClySystemBrowserContext methodsFor: 'selection-messages' stamp: ''!
lastSelectedMessage
	^SycMessageDescription ofMethod: self lastSelectedMethod! !

!ClySystemBrowserContext methodsFor: 'tool controlling' stamp: ''!
showMessage: aMessageDescription renamedTo: newSelector
	| method newMethod |
	method := aMessageDescription contextUser.
	newMethod := method origin >> newSelector.
	self showMethod: newMethod! !

!ClySystemBrowserContext methodsFor: 'selection-classes' stamp: ''!
isClassSelected
	^self selectedClassItems notEmpty! !

!ClySystemBrowserContext methodsFor: 'selection-methods' stamp: ''!
isMethodSelected
	^self selectedMethodItems notEmpty! !

!ClySystemBrowserContext methodsFor: 'selection-methods' stamp: ''!
lastSelectedMethod
	^self lastSelectedObjectIn: self selectedMethods! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
requestSingleClass: queryTitle from: classCollection
	^tool searchDialog 
		requestSingleObject: queryTitle
		from: ClyAllClassesQuery hierarchical 
		inScope: (ClyClassScope ofAll: classCollection)! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
confirmUnusedClasses: variables
	^tool confirmUnusedClasses: variables! !

!ClySystemBrowserContext methodsFor: 'selection-methods' stamp: ''!
lastSelectedMethodClass
	| lastMethodItem |
	lastMethodItem := self lastSelectedObjectIn: self selectedMethodItems.
	^lastMethodItem systemDefinition definingClass! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
requestRemoveMethodStrategyFor: methods
	^tool requestRemoveMethodStrategyFor: methods! !

!ClySystemBrowserContext methodsFor: 'user requests' stamp: ''!
requestSimpleVariable: queryTitle from: classes

	^tool searchDialog 
		requestSingleObject: queryTitle 
		from: ClyAllInstanceVariablesQuery sorted
		inScope: (ClyClassScope ofAll: classes) withInheritedScope! !

!ClySystemBrowserContext methodsFor: 'selection-classes' stamp: ''!
selectedClasses
	^self actualSelectionFrom: self selectedClassItems! !

!ClySystemBrowserContext methodsFor: '*Calypso-SystemPlugins-Traits-Browser' stamp: ''!
isTraitSelected
	| classItem |
	classItem := self lastSelectedObjectIn: self selectedClassItems.
	^classItem isMarkedWith: ClyTraitTag! !

!ClySystemBrowserContext methodsFor: 'tool controlling' stamp: ''!
showMethod: aMethod
	tool selectMethod: aMethod! !

!ClySystemEnvironment commentStamp: ''!
I represent environment of Pharo system. I incapsulate globals (Smalltalk globals), packageOrganizer (RPackageOrganizer  default) and changesAnnouncer (SystemAnnouncer uniqueInstance). I have class side #currentImage instance created with all corresponding globals of current image.

I am used to navigate over system by ClyNavigationEnvironment.

Public API and Key Messages

- packages
- createPackageNamed: aString
- removePackage: aPackage
- includesClassNamed: aString 
- defaultClassCompiler
- subscribe: aNavigationEnvironment
- unsubscribe: aNavigationEnvironment

Internal Representation and Key Implementation Points.

    Instance Variables
	changesAnnouncer:		<SystemAnnouncer>
	globals:		<SmalltalkDictionary> "Smalltalk globals class"
	name:		<String>
	packageOrganizer:		<RPackageOrganizer>
	projectManager:		<ClyProjectManager>!
!ClySystemEnvironment methodsFor: 'package management' stamp: ''!
registerProjectManager: aPackageManager
	aPackageManager systemEnvironment: self.
	projectManager registerProjectManager: aPackageManager! !

!ClySystemEnvironment methodsFor: 'class compilation' stamp: ''!
classCompilerFor: aClass

	"Use aClass superclass because it knows the definerClass of aClass."

	^ aClass
		  ifNil: [ self defaultClassCompiler ]
		  ifNotNil: [ aClass superclass subclassDefinerClass new ]! !

!ClySystemEnvironment methodsFor: 'package management' stamp: ''!
createPackageNamed: packageName
	^packageOrganizer createPackageNamed: packageName! !

!ClySystemEnvironment methodsFor: 'class management' stamp: ''!
classNamed: aString ifAbsent: aBlockClosure 
	^globals 
		at: aString
		ifPresent: [ :existing | 
			existing isBehavior ifTrue: [ existing ] ifFalse: aBlockClosure] 
		ifAbsent: aBlockClosure! !

!ClySystemEnvironment methodsFor: 'converting' stamp: ''!
asRBEnvironment
	^ self environment asRBEnvironment! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
globals: anObject
	globals := anObject! !

!ClySystemEnvironment methodsFor: 'testing' stamp: ''!
isOldTraitDefinition: traitDefinitionString

	| defTokens |
	defTokens := traitDefinitionString findTokens:
		             Character separators.
	^ defTokens size >= 2 and: [ 
		  (defTokens first = 'Trait' and: [ defTokens second = 'named:' ]) 
			  or: [ defTokens second = 'classTrait' ] ]! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
allProcesses
	^Process allSubInstances! !

!ClySystemEnvironment methodsFor: 'package management' stamp: ''!
packageNamed: aString 
	^packageOrganizer packageNamed: aString! !

!ClySystemEnvironment methodsFor: 'class management' stamp: ''!
bindingOf: aSymbol
	^globals bindingOf: aSymbol! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
environment
	^ RBBrowserEnvironment new! !

!ClySystemEnvironment methodsFor: 'class management' stamp: ''!
classNamed: aString
	^globals classNamed: aString! !

!ClySystemEnvironment methodsFor: 'class management' stamp: ''!
includesClassNamed: aSymbol
	^globals includesKey: aSymbol! !

!ClySystemEnvironment methodsFor: 'compiling' stamp: ''!
defineNewFluidClassOrTraitFrom: newClassDefinitionString notifying: aController startingFrom: oldClass

	"Precondition: newClassDefinitionString is a fluid class or trait"

	| newClass |
	[ 
	newClass := (self classCompilerFor: oldClass)
		            source: '(' , newClassDefinitionString , ') install';
		            requestor: aController;
		            logged: true;
		            "for now a super ugly patch"evaluate ]
		on: OCUndeclaredVariableWarning
		do: [ :ex | "we are only interested in class definitions"
			ex compilationContext noPattern ifFalse: [ ex pass ].
			"Undeclared Vars should not lead to the standard dialog to define them but instead should not accept"
			self inform: 'Undeclared Variable in Class Definition'.
			^ nil ].

	^ newClass isBehavior
		  ifTrue: [ newClass ]
		  ifFalse: [ nil ]! !

!ClySystemEnvironment methodsFor: 'testing' stamp: ''!
isFluidDefinition: aDefinitionString

	^ (self isFluidClassDefinition: aDefinitionString) or: [ 
		  self isFluidTraitDefinition: aDefinitionString ]! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
packages
	^ packageOrganizer packages! !

!ClySystemEnvironment methodsFor: 'class management' stamp: ''!
classNamed: aString ifPresent: aBlockClosure ifAbsent: anotherBlockClosure
	^ globals at: aString ifPresent: aBlockClosure ifAbsent: anotherBlockClosure! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
globals
	^ globals! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!ClySystemEnvironment methodsFor: 'testing' stamp: ''!
isTraitDefinition: newClassDefinitionString

	^ (self isFluidTraitDefinition: newClassDefinitionString) or: [ 
		  self isOldTraitDefinition: newClassDefinitionString ]! !

!ClySystemEnvironment methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	name ifNil: [ ^self ].
	
	aStream nextPut: $(.
	aStream nextPutAll: name.
	aStream nextPut: $).! !

!ClySystemEnvironment methodsFor: 'class management' stamp: ''!
isOverridingExistingClassWhenDefiningClassNamed: newClassName startingFrom: oldClass

	"Attempting to define new class over existing one when not looking at the original one in this browser..."

	^ (oldClass isNil or: [ 
		   oldClass instanceSide name asString ~= newClassName ]) and: [ 
		  self includesClassNamed: newClassName asSymbol ]! !

!ClySystemEnvironment methodsFor: 'testing' stamp: ''!
isFluidClassDefinition: classDefinitionString

	| splitted |
	splitted := classDefinitionString splitOn: '<<'.
	^ splitted size = 2 and: [ 
		  splitted first trim ~= 'Trait' and: [ 
			  '#*' match:
				  (splitted second findTokens: Character separators) first ] ]! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
projects
	^projectManager projects! !

!ClySystemEnvironment methodsFor: 'package management' stamp: ''!
removePackage: aPackage

	packageOrganizer unregisterPackage: aPackage! !

!ClySystemEnvironment methodsFor: 'subscription' stamp: ''!
unsubscribe: anObject
	changesAnnouncer unsubscribe: anObject! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
classes
	^ globals allClassesAndTraits! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
packageOrganizer
	^ packageOrganizer! !

!ClySystemEnvironment methodsFor: 'compiling' stamp: ''!
defineNewClassFrom: newClassDefinitionString notifying: aController startingFrom: oldClass

	"Precondition: newClassDefinitionString is not a fluid class"

	| newClass |
	[ 
	newClass := (self classCompilerFor: oldClass)
		            source: newClassDefinitionString;
		            requestor: aController;
		            failBlock: [ ^ nil ];
		            logged: true;
		            evaluate ]
		on: OCUndeclaredVariableWarning
		do: [ :ex | "we are only interested in class definitions"
			ex compilationContext noPattern ifFalse: [ ex pass ].
			"Undeclared Vars should not lead to the standard dialog to define them but instead should not accept"
			self inform: 'Undeclared Variable in Class Definition'.
			^ nil ].

	^ newClass isBehavior
		  ifTrue: [ newClass ]
		  ifFalse: [ nil ]! !

!ClySystemEnvironment methodsFor: 'subscription' stamp: ''!
subscribe: anObject
	self subscribe: anObject for: SystemAnnouncement! !

!ClySystemEnvironment methodsFor: 'subscription' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject
	changesAnnouncer weak when: anAnnouncementClass send: aSelector to: anObject! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
changesAnnouncer: anObject
	changesAnnouncer := anObject! !

!ClySystemEnvironment methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	projectManager := ClyProjectManagerRegistry new! !

!ClySystemEnvironment methodsFor: '*Calypso-SystemPlugins-Traits-Queries' stamp: ''!
defineTrait: defString notifying: aController startingFrom: aClass

	| defTokens keywdIx oldTrait newTraitName trait |
	aClass isTrait ifTrue:[oldTrait := aClass].
	defTokens := defString findTokens: Character separators.
	keywdIx := defTokens findFirst: [:x | x = 'category'].
	keywdIx := defTokens findFirst: [:x | x = 'named:'].
	newTraitName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
	((oldTrait isNil or: [oldTrait instanceSide name asString ~= newTraitName])
		and: [self includesClassNamed: 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 defaultClassCompiler
		source: defString; requestor: aController; 
		logged: true; 
		evaluate.
	^trait isTrait ifTrue: [ trait ] ifFalse: [ nil ]! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
changesAnnouncer
	^ changesAnnouncer! !

!ClySystemEnvironment methodsFor: 'compiling' stamp: ''!
compileANewClassFrom: newClassDefinitionString notifying: aController startingFrom: oldClass

	"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."

	| newClassName |
	newClassName := self extractNameFrom: newClassDefinitionString.
	((self
		  isOverridingExistingClassWhenDefiningClassNamed: newClassName
		  startingFrom: oldClass) and: [ 
		 (self confirmToOverrideExistingClassNamed: newClassName) not ]) 
		ifTrue: [ ^ nil ].

	(self isFluidDefinition: newClassDefinitionString)
		ifTrue: [ 
			ClassDefinitionPrinter showFluidClassDefinition: true.
			^ self
				  defineNewFluidClassOrTraitFrom: newClassDefinitionString
				  notifying: aController
				  startingFrom: oldClass ]
		ifFalse: [ 
			(self isTraitDefinition: newClassDefinitionString)
				ifTrue: [ 
					^ self
						  defineTrait: newClassDefinitionString
						  notifying: aController
						  startingFrom: oldClass ]
				ifFalse: [ 
					(self isClassDefinition: newClassDefinitionString)
						ifTrue: [
							^ self
							  defineNewClassFrom: newClassDefinitionString
							  notifying: aController
							  startingFrom: oldClass ]
						ifFalse: [ ^ nil ] ] ]! !

!ClySystemEnvironment methodsFor: 'compiling' stamp: ''!
isClassDefinition: newClassDefinitionString
	| defTokens |
	defTokens := newClassDefinitionString findTokens: Character separators.
	^ (self class environment classNamed: defTokens first) isNotNil.! !

!ClySystemEnvironment methodsFor: 'class management' stamp: ''!
confirmToOverrideExistingClassNamed: newClassName

	"Attempting to define new class/trait over existing one when not looking at the original one in this browser..."

	^ self confirm:
		((newClassName , ' 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: newClassName size)! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
packageOrganizer: anObject
	packageOrganizer := anObject! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
name
	^ name ifNil: [ super printString ]! !

!ClySystemEnvironment methodsFor: 'testing' stamp: ''!
isFluidTraitDefinition: traitDefinitionString

	| splitted |
	splitted := traitDefinitionString splitOn: '<<'.
	^ splitted size = 2 and: [ 
		  splitted first trim = 'Trait' and: [ 
			  '#*' match:
				  (splitted second findTokens: Character separators) first ] ]! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
projectManager
	^ projectManager! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
projectManager: anObject
	projectManager := anObject! !

!ClySystemEnvironment methodsFor: 'subscription' stamp: ''!
subscribe: anObject for: anAnnouncementClass
	self when: anAnnouncementClass send: #systemChanged: to: anObject! !

!ClySystemEnvironment methodsFor: 'accessing' stamp: ''!
asGlobalScopeIn: aNavigationEnvironment

	
	^ClySystemEnvironmentScope of: self in: aNavigationEnvironment named: name! !

!ClySystemEnvironment methodsFor: 'package management' stamp: ''!
ensureExistAndRegisterPackageNamed: packageName
	^packageOrganizer ensureExistAndRegisterPackageNamed: packageName! !

!ClySystemEnvironment methodsFor: 'class management' stamp: ''!
extractNameFrom: aDefinitionString

	| defTokens keywdIx |
	(self isFluidDefinition: aDefinitionString)
		ifFalse: [ 
			defTokens := aDefinitionString findTokens: Character separators.
			(self isTraitDefinition: aDefinitionString)
				ifFalse: [ 
					keywdIx := defTokens findFirst: [ :x | x beginsWith: 'category' ].
					keywdIx := defTokens findFirst: [ :x | '*subclass*' match: x ] ]
				ifTrue: [ 
					keywdIx := defTokens findFirst: [ :x | x = 'category' ].
					keywdIx := defTokens findFirst: [ :x | x = 'named:' ] ].
			^ (defTokens at: keywdIx + 1 ifAbsent: [ '' ]) copyWithoutAll:
				  '#()' ]
		ifTrue: [ 
			defTokens := aDefinitionString findTokens:
				             Character separators , '<#'.
			^ defTokens at: 2 ifAbsent: [ '' ] ]! !

!ClySystemEnvironment methodsFor: 'class compilation' stamp: ''!
defaultClassCompiler

	^ self class compiler! !

!ClySystemEnvironment class methodsFor: 'accessing' stamp: ''!
currentImage
	^currentImage ifNil: [
		currentImage := self new
			name: 'Current image';
			globals: Smalltalk globals;
			packageOrganizer: RPackageOrganizer default;
			changesAnnouncer: SystemAnnouncer uniqueInstance]! !

!ClySystemEnvironment class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	currentImage := nil! !

!ClySystemEnvironmentPlugin commentStamp: ''!
I am a root of ClySystemEnvironment navigation plugins hierarchy.
My subclasses extend system objects and their properties.

For example there is ClySUnitEnvironmentPlugin. It adds test related properties to methods, classes and packages. Also it provides new kind of method group to represent broken tests.

To extend objects subclasses should implement methods: 
	- resolvePropertiesOfClass: classItem
	- resolvePropertiesOfMethod: methodItem
	- look at "items resolving" protocol for more

Plugins can provide new kind of package, class and method groups. They return own group providers in following methods:
	- collectMethodGroupProviders
	- collectClassGroupProviders

Notice that current image environment adds all plugins automatically. 
Look at superclass ClyEnvironmentPlugin for responsibility details.

For subclasses I provide notion of slow plugins and methods to enable/disable them:

- disableSlowPlugins
- enableSlowPlugins

Any system plugin can implement #isSlow as true. It is important for slow machines (like Raspberry) to be able easily disable all heavy logic in the browser.!
!ClySystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofClassGroup: aClassGroup! !

!ClySystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anEnvironmentItem ofMethod: aMethod! !

!ClySystemEnvironmentPlugin methodsFor: 'query metadata' stamp: ''!
collectMetadataOfClassGroups: aQueryResult! !

!ClySystemEnvironmentPlugin methodsFor: 'query metadata' stamp: ''!
collectMetadataOfMethods: aQueryResult! !

!ClySystemEnvironmentPlugin methodsFor: 'query metadata' stamp: ''!
collectMetadataOfClasses: aQueryResult! !

!ClySystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofClass: aClass! !

!ClySystemEnvironmentPlugin methodsFor: 'groups collecting' stamp: ''!
collectMethodGroupProviders
	^#()! !

!ClySystemEnvironmentPlugin methodsFor: 'query metadata' stamp: ''!
collectMetadataOfProjects: aQueryResult! !

!ClySystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethodGroup: aMethodGroup! !

!ClySystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofPackage: aPackage! !

!ClySystemEnvironmentPlugin methodsFor: 'groups collecting' stamp: ''!
collectClassGroupProviders
	^#()! !

!ClySystemEnvironmentPlugin methodsFor: '*Calypso-SystemPlugins-Critic-Queries' stamp: ''!
resolveMetadataOfCritiques: aClySortedCritiques! !

!ClySystemEnvironmentPlugin methodsFor: 'query metadata' stamp: ''!
collectMetadataOfPackages: aQueryResult! !

!ClySystemEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofProject: aProject! !

!ClySystemEnvironmentPlugin methodsFor: 'query metadata' stamp: ''!
collectMetadataOfMethodGroups: aQueryResult! !

!ClySystemEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
disableSlowPlugins
	<script>
	SlowPluginsAreDisabled := true! !

!ClySystemEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isRelatedTo: aSystem

	^aSystem isKindOf: ClySystemEnvironment! !

!ClySystemEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
enableSlowPlugins
	<script>
	SlowPluginsAreDisabled := false! !

!ClySystemEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClySystemEnvironmentPlugin! !

!ClySystemEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isSlow
	^false! !

!ClySystemEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isAutoActivated
	(SlowPluginsAreDisabled = true and: [ self isSlow ]) ifTrue: [ ^false ].
	
	^super isAutoActivated! !

!ClySystemEnvironmentScope commentStamp: ''!
I represent global scope of full system environment.
I provide view on all packages, classes and methods in the system.

My basis is instance of ClySystemEnvironment which represents global Smalltalk with friends (package organizer, system annoncer and others).

You can access default instance from current image environment: 

	ClyNavigationEnvironment currentImageScope!
!ClySystemEnvironmentScope methodsFor: 'queries' stamp: ''!
processesDo: aBlock
	
	self system allProcesses do: aBlock! !

!ClySystemEnvironmentScope methodsFor: 'refactoring support' stamp: ''!
asRBEnvironment

	^self environment asRBEnvironment! !

!ClySystemEnvironmentScope methodsFor: 'accessing - projects' stamp: ''!
projectQueryFor: aScope 
	
	^ environment system projectManager projectQueryFor: aScope! !

!ClySystemEnvironmentScope methodsFor: 'queries' stamp: ''!
methodsDo: aBlock
	
	self classesDo: [:class | 
		class instanceSide localMethods do: aBlock.
		class classSide localMethods do: aBlock]! !

!ClySystemEnvironmentScope methodsFor: 'queries' stamp: ''!
packagesDo: aBlock
	
	self system packages do: aBlock! !

!ClySystemEnvironmentScope methodsFor: 'queries' stamp: ''!
projectsDo: aBlock
	
	self system projects do: aBlock! !

!ClySystemEnvironmentScope methodsFor: 'queries' stamp: ''!
classesDo: aBlock
	
	self system classes do: aBlock! !

!ClySystemEnvironmentScope methodsFor: 'system changes' stamp: ''!
includesClassesAffectedBy: aSystemAnnouncement
	^aSystemAnnouncement affectsClasses! !

!ClySystemEnvironmentScope methodsFor: 'system changes' stamp: ''!
includesMethodsAffectedBy: aSystemAnnouncement
	^aSystemAnnouncement affectsMethods! !

!ClySystemEnvironmentScope methodsFor: 'testing' stamp: ''!
isCurrentImage
	
	^self system == ClySystemEnvironment currentImage! !

!ClySystemEnvironmentTest commentStamp: ''!
A ClySystemEnvironmentTest is a test class for testing the behavior of ClySystemEnvironment!
!ClySystemEnvironmentTest methodsFor: 'tests' stamp: ''!
testIsFluidTraitDefinition

	self deny: (dummySystemEnvironment isFluidTraitDefinition:
			 'Object subclass: #ClySystemEnvironment
	instanceVariableNames: ''name globals changesAnnouncer packageOrganizer projectManager''
	classVariableNames: ''''
	package: ''Calypso-SystemQueries-Domain''').
	self deny: (dummySystemEnvironment isFluidTraitDefinition:
			 'Object subclass: #ClySystemEnvironment').
	self deny: (dummySystemEnvironment isFluidTraitDefinition:
			 'Object << #ClySystemEnvironment').
	self deny: (dummySystemEnvironment isFluidTraitDefinition:
			 'Object<<#ClySystemEnvironment').
	self deny: (dummySystemEnvironment isFluidTraitDefinition:
			 'Object << #ClySystemEnvironment
	slots: {};
	sharedVariables: {};
	package: ''Calypso-SystemQueries-Domain''').
	self assert:
		(dummySystemEnvironment isFluidTraitDefinition: 'Trait << #TMyTrait
	traits: {};
	slots: {};
	tag: '''' ;
	package: ''Calypso-SystemQueries-Domain''').

	self deny: (dummySystemEnvironment isFluidTraitDefinition:
			 'Trait named: #TMyTraits
	traits: {}
	package: ''Calypso-SystemQueries-Domain''')! !

!ClySystemEnvironmentTest methodsFor: 'tests' stamp: ''!
testIsTraitDefinition

	self deny: (dummySystemEnvironment isTraitDefinition:
			 'Object subclass: #ClySystemEnvironment
	instanceVariableNames: ''name globals changesAnnouncer packageOrganizer projectManager''
	classVariableNames: ''''
	package: ''Calypso-SystemQueries-Domain''').
	self deny: (dummySystemEnvironment isTraitDefinition:
			 'Object subclass: #ClySystemEnvironment').
	self deny: (dummySystemEnvironment isTraitDefinition:
			 'Object << #ClySystemEnvironment').
	self deny: (dummySystemEnvironment isTraitDefinition:
			 'Object<<#ClySystemEnvironment').
	self deny: (dummySystemEnvironment isTraitDefinition:
			 'Object << #ClySystemEnvironment
	slots: {};
	sharedVariables: {};
	package: ''Calypso-SystemQueries-Domain''').
	
	self assert: (dummySystemEnvironment isTraitDefinition:
			 'Trait << #TMyTrait
	traits: {};
	slots: {};
	tag: '''' ;
	package: ''Calypso-SystemQueries-Domain''').
	
	self assert: (dummySystemEnvironment isTraitDefinition:
			 'Trait named: #TMyTraits
	traits: {}
	package: ''Calypso-SystemQueries-Domain''')! !

!ClySystemEnvironmentTest methodsFor: 'tests' stamp: ''!
testIsOldTraitDefinition

	self deny: (dummySystemEnvironment isOldTraitDefinition:
			 'Object subclass: #ClySystemEnvironment
	instanceVariableNames: ''name globals changesAnnouncer packageOrganizer projectManager''
	classVariableNames: ''''
	package: ''Calypso-SystemQueries-Domain''').
	self deny: (dummySystemEnvironment isOldTraitDefinition:
			 'Object subclass: #ClySystemEnvironment').
	self deny: (dummySystemEnvironment isOldTraitDefinition:
			 'Object << #ClySystemEnvironment').
	self deny: (dummySystemEnvironment isOldTraitDefinition:
			 'Object<<#ClySystemEnvironment').
	self deny: (dummySystemEnvironment isOldTraitDefinition:
			 'Object << #ClySystemEnvironment
	slots: {};
	sharedVariables: {};
	package: ''Calypso-SystemQueries-Domain''').
	
	self deny: (dummySystemEnvironment isOldTraitDefinition:
			 'Trait << #TMyTrait
	traits: {};
	slots: {};
	tag: '''' ;
	package: ''Calypso-SystemQueries-Domain''').
	self assert: (dummySystemEnvironment isOldTraitDefinition:
			 'Trait named: #TMyTraits
	uses: {}
	package: ''Calypso-SystemQueries-Domain''')! !

!ClySystemEnvironmentTest methodsFor: 'tests' stamp: ''!
testExtractClassNameFrom

	self
		assert: (dummySystemEnvironment extractNameFrom:
				 'Object subclass: #ClySystemEnvironment
	instanceVariableNames: ''name globals changesAnnouncer packageOrganizer projectManager''
	classVariableNames: ''''
	package: ''Calypso-SystemQueries-Domain''')
		equals: 'ClySystemEnvironment'.
	self
		assert: (dummySystemEnvironment extractNameFrom:
				 'Object subclass: #ClySystemEnvironment')
		equals: 'ClySystemEnvironment'.
	self
		assert: (dummySystemEnvironment extractNameFrom:
				 'Object << #ClySystemEnvironment')
		equals: 'ClySystemEnvironment'.
	self
		assert: (dummySystemEnvironment extractNameFrom:
				 'Object<<#ClySystemEnvironment')
		equals: 'ClySystemEnvironment'.
	self
		assert: (dummySystemEnvironment extractNameFrom:
				 'Object << #ClySystemEnvironment
	slots: {};
	sharedVariables: {};
	package: ''Calypso-SystemQueries-Domain''')
		equals: 'ClySystemEnvironment'.
	self
		assert:
			(dummySystemEnvironment extractNameFrom: 'Trait << #TMyTrait
	traits: {};
	slots: {};
	tag: '''' ;
	package: ''Calypso-SystemQueries-Tests-Domain''')
		equals: 'TMyTrait'.
	self
		assert:
			(dummySystemEnvironment extractNameFrom: 'Trait named: #TMyTraits
	 uses: {}
	 package: ''Calypso-SystemQueries-Tests-Domain''')
		equals: 'TMyTraits'! !

!ClySystemEnvironmentTest methodsFor: 'tests' stamp: ''!
testIsFluidClassDefinition

	self deny: (dummySystemEnvironment isFluidClassDefinition:
			 'Object subclass: #ClySystemEnvironment
	instanceVariableNames: ''name globals changesAnnouncer packageOrganizer projectManager''
	classVariableNames: ''''
	package: ''Calypso-SystemQueries-Domain''').
	self deny: (dummySystemEnvironment isFluidClassDefinition:
			 'Object subclass: #ClySystemEnvironment').
	self assert: (dummySystemEnvironment isFluidClassDefinition:
			 'Object << #ClySystemEnvironment').
	self assert: (dummySystemEnvironment isFluidClassDefinition:
			 'Object<<#ClySystemEnvironment').
	self assert: (dummySystemEnvironment isFluidClassDefinition:
			 'Object << #ClySystemEnvironment
	slots: {};
	sharedVariables: {};
	package: ''Calypso-SystemQueries-Domain''').
	
	self deny:
		(dummySystemEnvironment isFluidClassDefinition: 'Trait << #TMyTrait
	traits: {};
	slots: {};
	tag: '''' ;
	package: ''Calypso-SystemQueries-Domain''').
	self deny: (dummySystemEnvironment isFluidClassDefinition:
			 'Trait named: #TMyTraits
	uses: {}
	package: ''Calypso-SystemQueries-Domain''')! !

!ClySystemEnvironmentTest methodsFor: 'tests' stamp: ''!
testIsFluidDefinition

	self deny: (dummySystemEnvironment isFluidDefinition:
			 'Object subclass: #ClySystemEnvironment
	instanceVariableNames: ''name globals changesAnnouncer packageOrganizer projectManager''
	classVariableNames: ''''
	package: ''Calypso-SystemQueries-Domain''').
	self deny: (dummySystemEnvironment isFluidDefinition:
			 'Object subclass: #ClySystemEnvironment').
	self assert: (dummySystemEnvironment isFluidDefinition:
			 'Object << #ClySystemEnvironment').
	self assert: (dummySystemEnvironment isFluidDefinition:
			 'Object<<#ClySystemEnvironment').
	self assert: (dummySystemEnvironment isFluidDefinition:
			 'Object << #ClySystemEnvironment
	slots: {};
	sharedVariables: {};
	package: ''Calypso-SystemQueries-Domain''').
	
	self assert:
		(dummySystemEnvironment isFluidDefinition: 'Trait << #TMyTrait
	traits: {};
	slots: {};
	tag: '''' ;
	package: ''Calypso-SystemQueries-Tests-Domain''').

	self deny:
		(dummySystemEnvironment isFluidDefinition: 'Trait named: #TMyTraits
	 traits: {}
	 package: ''Calypso-SystemQueries-Tests-Domain''')! !

!ClySystemEnvironmentTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	dummySystemEnvironment := ClySystemEnvironment new! !

!ClySystemScope commentStamp: ''!
I am a root of hierarchy of scope classes which represent a global point of view on concrete system.

My subclasses define what is the concrete system and implement accessing methods to retrieve all possible information from it.

I am supposed to be created with single object basis. In case of multiple basis I signal error.
So to create me use single basis #of: message: 

	ClyConcreteSystemScope of: aSystem

And to access the system I provide simple message #system which just returns single basis item!
!ClySystemScope methodsFor: 'initialization' stamp: ''!
prepareBasisFrom: aCollection
	aCollection size = 1 ifFalse: [ 
		self error: 'System scope should be created on single basis' ].

	^aCollection! !

!ClySystemScope methodsFor: 'printing' stamp: ''!
description

	^name ifNil: [self system name]! !

!ClySystemScope methodsFor: 'private' stamp: ''!
asUnifiedInstance
	^self! !

!ClySystemScope methodsFor: 'accessing' stamp: ''!
system
	^basisObjects anyOne! !

!ClySystemScope methodsFor: 'printing' stamp: ''!
printBasisObject: aSystemEnvironment on: aStream

	aStream nextPutAll: aSystemEnvironment name! !

!ClySystemSearchDialogContext methodsFor: 'selection-classes' stamp: ''!
selectedClassItems
	^self selectedItemsOfType: ClyClass! !

!ClySystemSearchDialogContext methodsFor: 'selection-methods' stamp: ''!
selectedMethodItems
	^self selectedItemsOfType: ClyMethod! !

!ClySystemSearchDialogContext methodsFor: 'accessing' stamp: ''!
browser
	^tool browser! !

!ClySystemSearchDialogContext methodsFor: 'selection-packages' stamp: ''!
selectedPackageItems
	^self selectedItemsOfType: RPackage! !

!ClySystemSearchDialogContext methodsFor: 'private' stamp: ''!
selectedItemsOfType: itemTypeClass
	
	^selectedItems select: [ :each | 
		each isBasedOnItemType: itemTypeClass ]! !

!ClySystemSearchDialogContext class methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
selectionStrategyForQueryBrowser
	<classAnnotation>
	^ClyContextSelectionStrategyAnnotation for: (ClyBrowserDialogContext ofSearchIn: ClyQueryBrowserMorph)! !

!ClySystemSearchDialogContext class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
selectionStrategyForFullBrowser
	<classAnnotation>
	^ClyContextSelectionStrategyAnnotation for: (ClyBrowserDialogContext ofSearchIn: ClyFullBrowserMorph)! !

!ClyTabActivationStrategy class methodsFor: 'testing' stamp: ''!
isDeprecated
	^true! !

!ClyTabActivationStrategyAnnotation commentStamp: ''!
I annotate browser tools that they should be opened as a tab in particular browser context.

I am not active for abstract classes. 
By default tool is abstract if it has subclasses. So for the cases when it is not true the tool class should override class side method #isAbstract!
!ClyTabActivationStrategyAnnotation methodsFor: 'testing' stamp: ''!
isActiveInContext: aBrowserContext
	^(super isActiveInContext: aBrowserContext)
		and: [ self toolClass shouldBeActivatedInContext: aBrowserContext ]! !

!ClyTabActivationStrategyAnnotation methodsFor: 'testing' stamp: ''!
isForbidden
	^self toolClass isAbstract! !

!ClyTabActivationStrategyAnnotation methodsFor: 'accessing' stamp: ''!
toolClass
	^annotatedClass! !

!ClyTabActivationStrategyAnnotation methodsFor: 'operations' stamp: ''!
createToolFor: aBrowser inContext: aBrowserContext

	^self toolClass for: aBrowser inContext: aBrowserContext! !

!ClyTabManager commentStamp: ''!
I manage tabs in the browser.
Any tab in browser is represented by `ClyBrowserTool` subclasses.
And my responsibility is to show all appropriate tools which are relevant to the current browser context (state). 
`#updateTools` method is doing that. 

The logic is simple: 
When selection (browser context) is changed then browser collects new tools which should be opened in that new browser state. 
Then it removes all old tools and open all new tools. 
But there is special case when new collected tool is already opened. In that case such new tool will be not used. And existing tool will be not removed. So it will stay opened.

I use `#isSimilarTo:` tab method to detect that new collected tool is already opened (the browser already shows similar tool).
By default #isSimilarTo: simply checks the class of given tool. My subclases should redefine it when they include extra state because otherwise new tool instance will never replace old one (browser will think that it is already opened).

There are cases when existing tools are not closed when selection is changed. For example when method editor is dirty and you select another method.
In that case dirty method will indicate that it is now do not belongs to the context of browser.
Tools implement method #belongsToCurrentBrowserContext to support this logic.
For example method editor checks that browser still selects editing method.

There is one complex part of my behaviour: the way how I choose what tab should be selected.
In simple cases I just select the tab with lagest value of #activationPriority. But it is not enough.
Problem that user want to keep current selected tab (the kind of tab) when he selects another item in the table.
For example in full browser user can select class. It will automatically selects the tab with class definition because it has the most activation priority.
But then user can select class comment tab and switch to another class. The desired behaviour is to keep comment tab selected for this newly selected class.

And for this logic I maintain desired set of selected tool in the variable desiredSelection.
It adds and removes items when user manually selects tabs.
But in addition browser fills it with tools which are relevant for manually selected table.
Every time user selects new item in the table the browser collects tools which are relevant for this new selection and it passes them to me as new desired selection. 

So at the end I always select tab with most activation priority which exists in desiredSelection list.

By default activationPriority is equal to `#tabOrder` which defines general order between tabs.

My instances are created on the browser: 

	ClyTabManager of: aBrowser
	
Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>
	selectionPriorities:		<Dictionary<ClyBrowserTool class, Number>>
	tabMorph:		<TabManagerMorph>
	tools:		<Collection of<ClyBrowserTool>>
	updatingStarted:		<Boolean>
	desiredSelection: <Set of<ClyBrowserTool class>>!
!ClyTabManager methodsFor: 'updating' stamp: ''!
updateTools
	| newTools selectedTools currentTools needsNewSelection |
	self updateToolsBy: [
		newTools := OrderedCollection new.	
		browser navigationContextsDo: [ :each | self buildToolsOn: newTools for: each].
		needsNewSelection := self requiresNewDesiredSelection.
		selectedTools := self selectedTools.
		currentTools := tools copy.
		self updateTabsWith: newTools.
		tools ~= currentTools | needsNewSelection ifTrue: [ self restoreSelectedTools: selectedTools].
	]! !

!ClyTabManager methodsFor: 'focus management' stamp: ''!
focusActiveTab

	| activeTab |
	activeTab := self selectedTools detectMax: [ :each | 
		self activationPriorityOf: each].
		
	activeTab ifNotNil: [ activeTab takeKeyboardFocus]! !

!ClyTabManager methodsFor: 'updating' stamp: ''!
updateTabsWith: newTools
	| toRemove toInstall |
	toRemove := OrderedCollection withAll: tools.
	toInstall := OrderedCollection new.
	newTools do: [:new | 
		tools 
			detect: [ :existing | existing isSimilarTo: new ]
			ifFound: [:existing | toRemove remove: existing ]
			ifNone: [ toInstall add: new ]].

	toRemove do: [ :each | 
		each wantsStayInDifferentContext ifFalse: [  each removeFromBrowser ]].
	tools do: [ :each | each browserContextWasChanged ].
	toInstall do: [ :each | self addTool: each]! !

!ClyTabManager methodsFor: 'private' stamp: ''!
updateToolsBy: aBlock
	updatingStarted := true.
	aBlock ensure: [ updatingStarted := false]! !

!ClyTabManager methodsFor: 'private' stamp: ''!
restoreSelectedTools: selectedTools
	| mainTool extraTools |
	tools ifEmpty: [ ^self ].
	mainTool := self selectMainTool.
	
	extraTools := selectedTools reject: [ :each | each class = mainTool class ].
	extraTools size = selectedTools size 
		ifTrue: [ extraTools := #() ] "if main tool not existed before then we reset previously selected extra tools"
		ifFalse: [ mainTool isExtraSelectionRequested 
			ifTrue: [ extraTools add: mainTool ] "To allow multiple selected tabs by cmd+click on table"].
	(tools copyWithout: mainTool) do: [ :currentTool | 
		"Generally if previously selected extra tab is found in new tools then it should be selected.
		Other tools should be deselected"
		extraTools 
			detect: [:oldTool | oldTool class = currentTool class  ]
			ifFound: [ self restoreSelectionOfExtraTool: currentTool]
			ifNone: [ currentTool deselectTab ]].
		
	extraTools ifNotEmpty: [ "last selected tab is looks different from others. We want main tool looks like last selected tab"
		mainTool deselectTab.
		mainTool selectAsExtraTab].

	mainTool waitBuildCompletion "to avoid blinking we try to wait a little bit until mainly selected tab wiull be build. When it is built fast it will look like no background building was happen"! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
morph
	"for compatibility"

	^ self tabMorph! !

!ClyTabManager methodsFor: 'event handling' stamp: ''!
okToChange

	(tools anySatisfy: #hasUnacceptedEdits) ifFalse: [ ^true ].
	
	^browser confirmDiscardChanges! !

!ClyTabManager methodsFor: 'private' stamp: ''!
activationPriorityOf: aBrowserTool
	
	| priority |
	aBrowserTool belongsToCurrentBrowserContext ifFalse: [ 
		^aBrowserTool activationPriorityInNonActiveContext].
	
	priority := self overridenPriorityOf: aBrowserTool.
	^(desiredSelection includes: aBrowserTool class)
		ifTrue: [ priority * 1000 ]
		ifFalse: [ priority ]! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyTabManager methodsFor: 'private' stamp: ''!
buildToolsOn: toolsList for: aBrowserContext
	| tool |
	ClyTabActivationStrategyAnnotation 
		activeInstancesInContext: aBrowserContext
		do: [ :strategy | 
			tool := strategy createToolFor: browser inContext: aBrowserContext.
			browser decorateTool: tool.
			toolsList add: tool ]! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
skipCurrentDesiredSelection
	shouldSkipCurrentDesiredSelection := true! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
shouldSkipCurrentDesiredSelection: anObject
	shouldSkipCurrentDesiredSelection := anObject! !

!ClyTabManager methodsFor: 'private' stamp: ''!
restoreSelectionOfExtraTool: aBrowserTool
	
	aBrowserTool hasUnacceptedEdits ifFalse: [ aBrowserTool selectAsExtraTab. ^self ].
	
	(self countToolsSimilarTo: aBrowserTool) = 1
		ifTrue: [ aBrowserTool selectAsExtraTab ]
		ifFalse: [aBrowserTool deselectTab]! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
shouldSkipCurrentDesiredSelection
	^ shouldSkipCurrentDesiredSelection! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
tabMorph
	^ tabMorph! !

!ClyTabManager methodsFor: 'private' stamp: ''!
swapPrioritiesBetween: aTool1 and: aTool2

	| priority1 priority2 |
	aTool1 allowsDifferentActivationPriority ifFalse: [ ^self ].
	aTool2 allowsDifferentActivationPriority ifFalse: [ ^self ].
	
	priority1 := self overridenPriorityOf: aTool1.
	priority2 := self overridenPriorityOf: aTool2.	
	selectionPriorities at: aTool1 class put: priority2.
	selectionPriorities at: aTool2 class put: priority1.! !

!ClyTabManager methodsFor: 'private' stamp: ''!
tabSelected: aTab
	| oldTabs newTab browserState |
	updatingStarted ifTrue: [ ^self ].
	"ifNone case happens somehow during tabs rebuild".
	newTab := tools detect: [ :each | each containerTab == aTab ] ifNone: [^self]. 
	newTab takeKeyboardFocus.
	oldTabs := tools select: [:each | each isTabSelected & (each containerTab ~~ aTab)].
	oldTabs ifEmpty: [ ^self ].
	desiredSelection removeAll.
	browserState := browser snapshotState.
	browserState selectedTabs: oldTabs.
	browser recordNavigationState: browserState.
	
	self swapPrioritiesBetween: newTab and: oldTabs first! !

!ClyTabManager methodsFor: 'updating' stamp: ''!
restoreBrowserState: aBrowserState
	| existingTools |
	"Browser state do only hold selected tabs. 
	So first we should restore all tools in new context and then restore selection"
	self updateTools.
	
	existingTools := aBrowserState selectedTabs 
		collect: [ :oldTool | tools detect: [ :each | each isSimilarTo: oldTool ] ifNone: [ nil ]]
		thenSelect: #notNil.
		
	existingTools ifEmpty: [ ^self].
	existingTools first selectAsMainTab.
	existingTools allButFirstDo: [ :each | each selectAsExtraTab ]! !

!ClyTabManager methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	tools := SortedCollection sortBlock: [:a :b | a tabOrder <= b tabOrder ].
	selectionPriorities := IdentityDictionary new.
	desiredSelection := IdentitySet new.
	shouldSkipCurrentDesiredSelection := false.
	updatingStarted := false.
	tabMorph := TabManagerMorph new.
	tabMorph useSortedTabsBy: [:a :b | a model tabOrder <= b model tabOrder ].
	tabMorph 
		hResizing: #spaceFill;
		vResizing: #spaceFill! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
tools: anObject
	tools := anObject! !

!ClyTabManager methodsFor: 'updating' stamp: ''!
updateToolsForChangedEnvironment
	| currentState |
	currentState := OrderedCollection new: tools size.
	tools do: [ :each | 
		currentState add: each -> each isManagedByUser.
		each isManagedByUser: true].
	
	self updateTools.
	
	currentState do: [ :each | each key isManagedByUser: each value ]! !

!ClyTabManager methodsFor: 'private' stamp: ''!
addTool: aBrowserTool

	| tab |
	tools add: aBrowserTool.
	"tab build is performed in background when owner is not exist yet. But we need proper width to perform kind of styling/formatting for tool if needed"
	aBrowserTool width: tabMorph width.
	tab := aBrowserTool createTab.
	tab when: #tabDeleted send: #tabDeleted: to: self.
	tab when: #tabSelected send: #tabSelected: to: self.
	tab label on: #doubleClick send: #toggleFullWindowTabs to: browser.
	"Following code is required to fix the problem 
	when doubleClick handler of tab label disables event processing by its parent, TabMorph"
	tab label on: #mouseDown send: #mouseDown: to: tab.
	tab label on: #mouseUp send: #mouseUp: to: tab.
	tabMorph addTab: tab! !

!ClyTabManager methodsFor: 'event handling' stamp: ''!
windowIsClosing

	tools do: [ :each | each cleanAfterRemove ]! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
desiredSelection: toolClasses
	| currentSelection |
	desiredSelection := toolClasses asIdentitySet.
	shouldSkipCurrentDesiredSelection ifFalse: [ 
		currentSelection := self selectedTools collect: [ :each | each class ].
		desiredSelection addAll: currentSelection].
	shouldSkipCurrentDesiredSelection := false "it is one time option"! !

!ClyTabManager methodsFor: 'private' stamp: ''!
tabDeleted: aTab

	| removedTool |
	removedTool := tools detect: [ :each | each containerTab = aTab ] ifNone: [ ^self ].
	tools remove: removedTool.
	removedTool cleanAfterRemove! !

!ClyTabManager methodsFor: 'private' stamp: ''!
overridenPriorityOf: aBrowserTool
	
	^selectionPriorities at: aBrowserTool class ifAbsent: [ aBrowserTool activationPriority  ]! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
desiredSelection
	^ desiredSelection! !

!ClyTabManager methodsFor: 'private' stamp: ''!
selectMainTool

	| desiredTools mainTool |
	desiredTools := tools select: [ :each | desiredSelection includes: each class].
	
	desiredTools ifEmpty: [ desiredTools := tools ].

	mainTool := desiredTools detectMax: [ :each | 
		self activationPriorityOf: each].
	mainTool selectAsMainTab.
	^mainTool! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
selectedTools

	^tools select: [ :each | each isTabSelected ]! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
tabMorph: anObject
	tabMorph := anObject! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
countToolsSimilarTo: aBrowserTool

	^tools count: [ :each | each class = aBrowserTool class ]! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
withTool: aToolClass do: aBlock
	| tool |
	tool := tools detect: [:each | each isKindOf: aToolClass ].
	^tool whenReadyDo: aBlock! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
activeStatusBar

	^self selectedTools first statusBar! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
tools
	^ tools! !

!ClyTabManager methodsFor: 'testing' stamp: ''!
requiresNewDesiredSelection
	desiredSelection ifEmpty: [ ^false ].
	
	^(self selectedTools allSatisfy: [ :each | desiredSelection includes: each class]) not! !

!ClyTabManager methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!ClyTabManager methodsFor: 'private' stamp: ''!
selectsTools: toolsArray
	
	| selectedTools |
	selectedTools := self selectedTools.
	selectedTools size = toolsArray size ifFalse: [ ^false ].
	
	^selectedTools allSatisfy: [ :existingTool | 
		toolsArray anySatisfy: [ :each | existingTool isSimilarTo: each ]]! !

!ClyTabManager class methodsFor: 'instance creation' stamp: ''!
of: aBrowser
	^self new 
		browser: aBrowser! !

!ClyTableColumn commentStamp: ''!
I represent fast table column which responsible for cell creation: 
	column createCellFor: aDataSourceItem in: itemsView
I use block to set up column specific cell properties. Block expects two arguments: cell and item. 
It can modify cell morph in any possible way. But usually users wants only label for cell. I provide few methods to simplify such cases:
- column displayItemName. It will put string label into cell with given item name.
- displayItemPropertyBy: blockWithItem. It will use given block to retrieve string from item (or any morph) as cell label. 
 
Internal Representation and Key Implementation Points.

    Instance Variables
	displayBlock:		<BlockClosure>	two argument block!
!ClyTableColumn methodsFor: 'accessing' stamp: ''!
displayBlock
	^ displayBlock! !

!ClyTableColumn methodsFor: 'accessing' stamp: ''!
displayItemPropertyBy: propertyBlock
	displayBlock := [ :cell :item | 
		cell label contents: (propertyBlock value: item browserItem) ]! !

!ClyTableColumn methodsFor: 'testing' stamp: ''!
isMainColumn
	
	^ false! !

!ClyTableColumn methodsFor: 'cells creation' stamp: ''!
createCellFor: aDataSourceItem in: aQueryView

	| cell |
	cell := ClyItemCellMorph new.
	displayBlock value: cell value: aDataSourceItem.
	aQueryView decorateTableCell: cell of: aDataSourceItem.
	cell build.
	^cell! !

!ClyTableColumn methodsFor: 'accessing' stamp: ''!
displayItemName
	self displayItemPropertyBy: [ :item | item name ]! !

!ClyTableColumn methodsFor: 'accessing' stamp: ''!
displayBlock: anObject
	displayBlock := anObject! !

!ClyTableColumn class methodsFor: 'instance creation' stamp: ''!
id: id displayBlock: aBlock
	^(self id: id)
		displayBlock: aBlock! !

!ClyTableDecorationStrategyAnnotation commentStamp: ''!
I annotate table decorators (ClyTableDecorator subclasses) to define where decorator should be used, in what context of selected items.

For example following method will declare that classes in any browsers should be decorated with abstract class decorator:

ClyAbstractClassTableDecorator class>>classDecorationStrategy
	<classAnnotation>
	^ClyTableDecorationStrategy for: ClyClass asCalypsoItemContext
	
It only declares where to use decorator but decorator itself can define extra conditions to check that given item is actually should be decorated
	annotatedClass wantsDecorateTableCellInContext: aBrowserItemContext
	
I sort my registered instances according to ascending priority. It is opposite to default order of annotation registry. 
Idea that most prioritized decorator should be able override visual effects from less prioritized decorators. And to achieve it I just enumerate instances in described order: asceding priority, which evaluates most prioritized decorator at last order.

Important notice. The actual priority is defined by decorator classes in class side method #priority. I retrieve them when annotation is created!
!ClyTableDecorationStrategyAnnotation methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph inContext: itemContext 

	annotatedClass decorateMainTableCell: anItemCellMorph inContext: itemContext! !

!ClyTableDecorationStrategyAnnotation methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph inContext: itemContext 

	annotatedClass decorateTableCell: anItemCellMorph inContext: itemContext! !

!ClyTableDecorationStrategyAnnotation methodsFor: 'testing' stamp: ''!
isActiveInContext: aBrowserItemContext
	^(super isActiveInContext: aBrowserItemContext)
		and: [ annotatedClass wantsDecorateTableCellInContext: aBrowserItemContext ]! !

!ClyTableDecorationStrategyAnnotation methodsFor: 'accessing' stamp: ''!
annotatedClass: aTableDecoratorClass
	super annotatedClass: aTableDecoratorClass.
	
	priority := aTableDecoratorClass priority! !

!ClyTableDecorationStrategyAnnotation methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream 
		nextPut: $(;
		nextPutAll: (annotatedClass ifNil: [ 'detached' ] ifNotNil: [ annotatedClass name]);
		nextPutAll: '; ';
		nextPutAll: priority asString;
		nextPut: $)! !

!ClyTableDecorationStrategyAnnotation methodsFor: 'testing' stamp: ''!
isForbidden
	^annotatedClass isAbstract! !

!ClyTableDecorationStrategyAnnotation class methodsFor: 'private' stamp: ''!
createContainerForRegistry
	"Decoration with more priority should override applied changes of table row 
	which was produced by less prioritized decorations.
	It can be done if most prioritized decorator will be applied on the table at last order.
	Here we revert annotation enumeration logic by managing registry in opposite order
	according to described idea"
	
	^SortedCollection sortBlock: #priority ascending! !

!ClyTableDecorator commentStamp: ''!
I am a root of hierarchy of table decorators.
My subclasses are responsible to decorate table rows/cells.
Currently my subclasses are not supposed to be instantiated. All behaviour are on class side.

To activate decorator it should be annotated with ClyTableDecorationStrategy with context of items where table should be decorated:

	ClyAbstractClassTableDecorator class>>classDecorationStrategy
		<classAnnotation>
		^ClyTableDecorationStrategy for: ClyClass asCalypsoItemContext

Also decorators can decide what exact items they want decorate. They should override the method:
	 wantsDecorateTableCellOf: aDataSourceItem
By default it returns true.

Actual decoration logic should be implemented in following two methods:

- decorateMainTableCell: anItemCellMorph of: aDataSourceItem
- decorateTableCell: anItemCellMorph of: aDataSourceItem

Idea is to decorate all columns in the table. But the main column is special. It can be decorated with extra tools like icons and buttons.
Other columns are simple label and they can be decorated only by special label style.

So if you only need special label for your items then implement only last method.
But for complex logic you should define first one. 
Notice that in multi column case last method will accept cell morphs which do not support any icons decoration.

These methods simplify decoration in simple cases which depends only on current item state.
But there are other methods which allow decoration which depends on complex context of the full browser.
For example style of method can be different depending on the method and the class selected in the browser.
Following methods should be overridden in such cases: 

- decorateMainTableCell: anItemCellMorph inContext: itemContext 
- decorateTableCell: anItemCellMorph inContext: itemContext

By default they just call first pair of methods with selected item in context.

When table is building multiple decorators can override same cell properties. To manage these overrides I introduce priority which specifies what decoration is more important. More important decoration is evaluated at last time which overrides equal properties from other decorations.
Enumeration order is implemented on annotation level. ClyTableDecorationStrategy defines special sorted registry for this.

Important notice. The actual priority is defined by my subclasses. But annotation extracts it and use it as own priority value in registry. 
Also the annotation is forbidden for abstract classes. By default I define abstract decorators as a classes which has subclasses. But it can be redefined in method #isAbstract. 

To be able control set of decorators per browser instance subclasses can be attached to concrete browser plugins.
Browser instance is created with specific set of plugins which restrict number of decorators which affect browser tables.
To specify plugin following class side method should be overridden:
- browserPluginClass
By default any decorators is bound to ClyStandardBrowserPlugin!
!ClyTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem
	self subclassResponsibility! !

!ClyTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph inContext: itemContext 

	self decorateMainTableCell: anItemCellMorph of: itemContext lastSelectedItem! !

!ClyTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellInContext: singleItemContext
	(singleItemContext browser hasPluginOf: self browserPluginClass)
		ifFalse: [ ^false ].

	^self wantsDecorateTableCellOf: singleItemContext lastSelectedItem! !

!ClyTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph inContext: itemContext 

	self decorateTableCell: anItemCellMorph of: itemContext lastSelectedItem! !

!ClyTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	^true! !

!ClyTableDecorator class methodsFor: 'decoration' stamp: ''!
priority
	"Decorators can override table cell properties. Priorities allow manage these overrides. 
	So developers can specify what decoration is more important. 
	Larger value increases level of importance"
	<classAnnotationDependency>
	^0! !

!ClyTableDecorator class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyTableDecorator! !

!ClyTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem 

	self decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyTableDecorator class methodsFor: 'decoration' stamp: ''!
browserPluginClass
	^ClyStandardBrowserPlugin! !

!ClyTableFilterFactory commentStamp: ''!
I responsible to create new filter instances of given itemFilterClass using specified string pattern.

I am a kind of hook to be able configure complex filters for fast table where it uses just a filter class. Fast table instantiates instances using #pattern: message which I define as filter creation method

Internal Representation and Key Implementation Points.

    Instance Variables
	itemFilterClass:		<ClyItemStringFilter class>
	stringPattern:		<ClyStringPatter>!
!ClyTableFilterFactory methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	stringPattern := ClySubstringPattern with: '' caseSensitive: false! !

!ClyTableFilterFactory methodsFor: 'accessing' stamp: ''!
itemFilterClass
	^ itemFilterClass! !

!ClyTableFilterFactory methodsFor: 'accessing' stamp: ''!
stringPattern: anObject
	stringPattern := anObject! !

!ClyTableFilterFactory methodsFor: 'accessing' stamp: ''!
itemFilterClass: anObject
	itemFilterClass := anObject! !

!ClyTableFilterFactory methodsFor: 'accessing' stamp: ''!
stringPattern
	^ stringPattern! !

!ClyTableFilterFactory methodsFor: 'filter creation' stamp: ''!
pattern: aString
	"The method is called from fast table filter function to create new instance of item filter"
	| newPattern |
	newPattern := stringPattern copy.
	newPattern value: aString.
	^itemFilterClass pattern: newPattern! !

!ClyTableFilterFactory class methodsFor: 'instance creation' stamp: ''!
of: anItemStringFilterClass
	^self new 
		itemFilterClass: anItemStringFilterClass! !

!ClyTableFilterFactory class methodsFor: 'instance creation' stamp: ''!
of: anItemStringFilterClass using: aStringPattern
	^(self of: anItemStringFilterClass)
		stringPattern: aStringPattern! !

!ClyTableIconCommandActivation commentStamp: ''!
I describe how to access and execute commands using iconic button in table row.
I implement way how to decorate table view with icons like in Nautilus method pane.
These icons are buttons based on commands which are marked with my instances.

Actual table decoration is delegated to command itself:

		command decorateTableCell: anItemCellMorph using: self

By default command just builds single iconic button using default menu icon. 
So you can simply implement #defaultMenuIconName on class side of command and it will be shown in the table.
But if you want special icon (different from menu) then you can redefine instance side method #tableCellIcon. 

At the end iconic button is added into the cell morph: 

	command decorateTableCell: anItemCellMorph with: aMorph

By default icon is added as cell definition morph:

	anItemCellMorph definitionMorph: aMorph

But command subclasses can define it as extra tool:

	anItemCellMorph addExtraTool: aMorph

Command subclasses can redefine default decoration logic and build completally different UI items instead of iconic button. They should override method:

- createTableCellButtonWith: anIcon using: aCommandActivator

Multiple commands can override decorated elements of each others. To manage such overrides you can specify priority for decoration:

	^ClyTableIconCommandActivation priority: 100 for: ClyMethodScope.

The command with most priority will decorate table at last order which means that their UI elements will present in table.

To implement correct order of my instances in registry I provide special sorted container for this. It manages instances in opposite order then default one!
!ClyTableIconCommandActivation class methodsFor: 'private' stamp: ''!
createContainerForRegistry
	"This strategy decorates table rows with UI element which execute the command.
	Decoration with more priority should override applied changes of table row 
	which was produced by less prioritized decoration.
	It can be done if most priority command will decorate the table at last order.
	Here we revert annotation enumeration logic by managing registry in opposite order
	according to described idea"
	
	^SortedCollection sortBlock: #priority ascending! !

!ClyTableIconCommandActivation class methodsFor: 'instance creation' stamp: ''!
priority: aNumber for: aBrowserContext
	"More priority value will allow command to override decorations from less priority commands"
	
	^(self for: aBrowserContext)
		priority: aNumber! !

!ClyTaggedClassGroup commentStamp: ''!
I represent group of classes which does marked by specific tag.

You can create my instance using: 

	ClyTaggedClassGroup withClassesFrom: aPackageScope taggedBy: aSymbol.
	 
I provide simple method to rename this tag:

	aGroup renameClassTagTo: aSymbol

Which in fact untags all classes and then marks them with new tag.

For the #removeWithClasses operation I remove empty class tag from registrered tags of package.
	
My class query is ClyTaggedClasses!
!ClyTaggedClassGroup methodsFor: 'accessing' stamp: ''!
tag
	^ classQuery tag! !

!ClyTaggedClassGroup methodsFor: '*Calypso-SystemPlugins-FileOut-Queries' stamp: ''!
fileOut

	classQuery scope packagesDo: [ :each |
		(each classTagNamed: self tag) fileOut]! !

!ClyTaggedClassGroup methodsFor: 'operations' stamp: ''!
importClass: aClass
	| newPackages |
	super importClass: aClass.
	
	newPackages := OrderedCollection new.
	classQuery scope packagesDo: [ :each | 
		each = aClass package ifFalse: [ newPackages add: each ]].
	newPackages size > 1 ifTrue: [ ^self error: 'You should select single package for import!!' ].
	newPackages ifNotEmpty: [ newPackages first addClass: aClass]. 
	aClass tagWith: self tag! !

!ClyTaggedClassGroup methodsFor: 'operations' stamp: ''!
renameClassTagTo: newTag
	self classes do: [ :each |
		each tagWith: newTag.
		each untagFrom: self tag].
	
	classQuery scope packagesDo: [ :each | 
		(each tagsForClasses includes: newTag) 
			ifFalse: [ each addClassTag: newTag ].
		each removeClassTag: self tag]! !

!ClyTaggedClassGroup methodsFor: 'operations' stamp: ''!
removeWithClasses

	super removeWithClasses.
	classQuery scope packagesDo: [ :each |
		each removeClassTag: self tag]! !

!ClyTaggedClassGroup class methodsFor: 'instance creation' stamp: ''!
withClassesFrom: aPackageScope taggedBy: tagName
	| classQuery |
	classQuery := ClyTaggedClassesQuery by: tagName from: aPackageScope.
	^ClyTaggedClassGroup named: tagName on: classQuery.! !

!ClyTaggedClassGroup class methodsFor: 'testing' stamp: ''!
isEditableGroup
	^true! !

!ClyTaggedClassGroup class methodsFor: 'testing' stamp: ''!
isBasedOnClassTag
	^true! !

!ClyTaggedClassGroupProvider commentStamp: ''!
I provide tagged class groups. 

I collect all class tags from the package scope and create ClyTaggedClassGroup instances for each of them!
!ClyTaggedClassGroupProvider methodsFor: 'building groups' stamp: ''!
classGroupsIn: aPackageScope do: aBlock
	| classGroups group |
	classGroups := Dictionary new.	
	aPackageScope packagesDo: [ :each |
		each tagsForClasses do: [ :eachTag |	
			classGroups at: eachTag ifAbsentPut: [
				group := ClyTaggedClassGroup 
					withClassesFrom: aPackageScope taggedBy: eachTag.
				aBlock value: group.
				group].				
	]]! !

!ClyTaggedClassGroupProviderTest methodsFor: 'running' stamp: ''!
packageSampleWhichHasGroup
	^ClyClass7WithTag1FromP5Mock package "P5WithTags"! !

!ClyTaggedClassGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyTaggedClassGroupProvider! !

!ClyTaggedClassGroupProviderTest methodsFor: 'tests' stamp: ''!
testFromTwoSamePackages

	self buildGroupsForAll: {ClyClass7WithTag1FromP5Mock package. ClyClass7WithTag1FromP5Mock package}.
	
	self assert: builtGroups size equals: 2.
	self assert: (builtGroups collect: [:each | each tag]) sorted asArray equals: #(Tag1 Tag2)! !

!ClyTaggedClassGroupProviderTest methodsFor: 'tests' stamp: ''!
testCreatesGroupsForEveryTag

	self buildGroupsFor: ClyClass7WithTag1FromP5Mock package.
	
	self assert: builtGroups size equals: 2.
	self assert: (builtGroups collect: [:each | each tag]) sorted asArray equals: #(Tag1 Tag2)! !

!ClyTaggedClassesQuery commentStamp: ''!
I return all classes marked with particular tag.

To create my instance use following methods: 

	ClyTaggedClasses by: #SomeTag
	ClyTaggedClasses by: #SomeTag from: aScope
 
Internal Representation and Key Implementation Points.

    Instance Variables
	tag:		<Symbol>!
!ClyTaggedClassesQuery methodsFor: 'testing' stamp: ''!
selectsClass: aClass
	^aClass isTaggedWith: tag! !

!ClyTaggedClassesQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."
	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ tag = anObject tag! !

!ClyTaggedClassesQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^super hash bitXor: tag hash! !

!ClyTaggedClassesQuery methodsFor: 'printing' stamp: ''!
description

	^'classes tagged with ', tag! !

!ClyTaggedClassesQuery methodsFor: 'accessing' stamp: ''!
tag: anObject
	tag := anObject! !

!ClyTaggedClassesQuery methodsFor: 'accessing' stamp: ''!
tag
	^ tag! !

!ClyTaggedClassesQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream
	super printExtraInfoOn: aStream.

	^aStream nextPutAll: tag! !

!ClyTaggedClassesQuery class methodsFor: 'instance creation' stamp: ''!
by: tagName from: aScopeClass

	^(self from: aScopeClass)
		tag: tagName! !

!ClyTaggedClassesQuery class methodsFor: 'instance creation' stamp: ''!
by: tagName

	^self new 
		tag: tagName! !

!ClyTaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query tag: #Tag1.
	query scope: (ClyClassScope of: ClyClass7WithTag1FromP5Mock in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyClassScope of: ClyClass8WithTag2FromP5Mock in: environment).
	self assert: query checkEmptyResult! !

!ClyTaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeClasses
	query tag: #Tag1.
	
	self queryFromScope: ClyClassScope ofAll: {
		ClyClass6UntaggedFromP5Mock. ClyClass7WithTag1FromP5Mock. ClyClass8WithTag2FromP5Mock }.

	self assert: resultItems asArray equals: {ClyClass7WithTag1FromP5Mock}! !

!ClyTaggedClassesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyTaggedClassesQuery
		by: #Tag1
		from: (ClyClassScope of: Object in: environment)! !

!ClyTaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testComparisonToSimilarQueryWithDifferentTag
	| query2 |
	query2 := self createQuery.
	query2 tag: #AnotherTag1.

	self deny: query equals: query2! !

!ClyTaggedMethodGroup commentStamp: ''!
I am group of methods marked by concrete tag!
!ClyTaggedMethodGroup methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem
	| myName |
	super decorateTableCell: anItemCellMorph of: groupItem.
	myName := name asLowercase.
	(myName beginsWith: 'private') ifTrue: [ 
		^anItemCellMorph definitionIcon: #protocolPrivateIcon ].
	
	(#('initial' 'class initial' 'releaz' 'releas' 'finali') 
		anySatisfy: [ :each | myName beginsWith: each ])
			ifTrue: [ anItemCellMorph definitionIcon: #protocolProtectedIcon]! !

!ClyTaggedMethodGroup methodsFor: 'operations' stamp: ''!
removeWithMethods
	super removeWithMethods.
	methodQuery scope classesDo: [ :each | each removeMethodTag: self tag ]! !

!ClyTaggedMethodGroup methodsFor: 'operations' stamp: ''!
convertToMethodTag: aTagName

	self renameMethodTagTo: aTagName! !

!ClyTaggedMethodGroup methodsFor: 'operations' stamp: ''!
importMethod: aMethod 
	super importMethod: aMethod.
	
	aMethod tagWith: self tag! !

!ClyTaggedMethodGroup methodsFor: 'accessing' stamp: ''!
tag
	^ methodQuery tag! !

!ClyTaggedMethodGroup methodsFor: 'operations' stamp: ''!
renameMethodTagTo: newTag 
	newTag = self tag ifTrue: [ ^self ].
	
	self methods do: [ :each |
		each tagWith: newTag.
		each untagFrom: self tag].
	
	methodQuery scope classesDo:  [ :each | 
		(each tagsForMethods includes: newTag) 
			ifFalse: [ each addMethodTag: newTag ].
		each removeMethodTag: self tag]! !

!ClyTaggedMethodGroup class methodsFor: 'testing' stamp: ''!
isEditableGroup
	^true! !

!ClyTaggedMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethodsFrom: aClassScope taggedBy: tagName
	^ClyTaggedMethodGroup named: tagName on: (ClyTaggedMethodsQuery by: tagName from: aClassScope)! !

!ClyTaggedMethodGroup class methodsFor: 'testing' stamp: ''!
isBasedOnMethodTag
	^true! !

!ClyTaggedMethodGroupProvider commentStamp: ''!
I provide tagged method groups. 
I collect all tags from class scope and create ClyTaggedMethodGroup instances for each of them.

I skip any tag which represent class extension, according to star convention('*PackageName'). Class extensions are handled by different provider: ClyExtendedMethodGroupProvider. It creates only general "extensions" group which can be expanded by subgroups for each package which extends given class. Subgroups are represented by explicit ClyExternalPackageMethodGroup. No star-convension is needed here!
!ClyTaggedMethodGroupProvider methodsFor: 'system changes' stamp: ''!
providesGroupsAffectedBy: aSystemAnnouncement inScope: aClassScope

	aClassScope classesDo: [ :each | 
		(aSystemAnnouncement affectsMethodTagIn: each) ifTrue: [ ^true ]
	].

	^false! !

!ClyTaggedMethodGroupProvider methodsFor: 'building groups' stamp: ''!
buildGroupsFrom: aClassScope
	| groups |
	groups := IdentityDictionary new.
	
	aClassScope classesDo: [ :eachClass |
		eachClass tagsForAllMethods do: [ :eachTag | 
			groups at: eachTag ifAbsentPut: [ 
				ClyTaggedMethodGroup withMethodsFrom: aClassScope taggedBy: eachTag ] ] ].

	^ groups values! !

!ClyTaggedMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyTaggedMethodGroupProvider! !

!ClyTaggedMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	^ClyClass1FromP1Mock! !

!ClyTaggedMethodGroupProviderTest methodsFor: 'tests' stamp: ''!
testCreateGroupsForEveryMethodTag
	| groups query |
	
	self buildGroupsFor: ClySubclassN1OfClass1FromP1Mock.
	
	groups := builtGroups select: [ :each | each isKindOf: ClyTaggedMethodGroup ].
	self
		assert: (groups collect: #tag as: Set)
		equals: ClySubclassN1OfClass1FromP1Mock tagsForMethods asSet.
	query := groups first methodQuery.
	self assert: query class equals: ClyTaggedMethodsQuery.
	self assert: query scope equals: (ClyClassScope of: ClySubclassN1OfClass1FromP1Mock)! !

!ClyTaggedMethodsQuery commentStamp: ''!
I return methods which are marked by particular tag.

To instantiate my instances use following expressions: 

	ClyTaggedMethods by: #accessing.
	ClyTaggedMethods by: #accessing from: aScope
 
Internal Representation and Key Implementation Points.

    Instance Variables
	tag:		<Symbol>!
!ClyTaggedMethodsQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^tag = anObject tag! !

!ClyTaggedMethodsQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash bitXor: tag hash! !

!ClyTaggedMethodsQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	^(aSystemAnnouncement affectsMethodsTaggedWith: tag)
		and: [ scope includesMethodsAffectedBy: aSystemAnnouncement]! !

!ClyTaggedMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^aMethod isTaggedWith: tag! !

!ClyTaggedMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'methods tagged with ', tag! !

!ClyTaggedMethodsQuery methodsFor: 'accessing' stamp: ''!
tag: anObject
	tag := anObject! !

!ClyTaggedMethodsQuery methodsFor: 'accessing' stamp: ''!
tag
	^ tag! !

!ClyTaggedMethodsQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream
	super printExtraInfoOn: aStream.

	^aStream nextPutAll: tag! !

!ClyTaggedMethodsQuery class methodsFor: 'instance creation' stamp: ''!
by: tagName from: aScope

	^(self from: aScope)
		tag: tagName! !

!ClyTaggedMethodsQuery class methodsFor: 'instance creation' stamp: ''!
by: tagName

	^self new 
		tag: tagName! !

!ClyTaggedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: ClyClass1FromP1Mock >> #tag1Method1 in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope of: Object >> #printString in: environment).
	self assert: query checkEmptyResult! !

!ClyTaggedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyClass1FromP1Mock >> #tag1Method1. Object >> #printString. 
		ClyClass2FromP1Mock >> #instanceSideClassVar1Reader}.
	
	self assert: foundSelectors equals: #(tag1Method1)! !

!ClyTaggedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testComparisonToSimilarQueryButWithDifferentTag
	| query2 |
	query tag: #tag1.
	query2 := self createQuery.
	query2 tag: #anotherTag.

	self deny: query equals: query2! !

!ClyTaggedMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyTaggedMethodsQuery
		by: #tag1
		from: (ClyClassScope of: ClyClass1FromP1Mock in: environment)! !

!ClyTestCaseRan commentStamp: ''!
I represent event about test run. I am passed to environment instead of native SUnit events.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	testCase:		<TestCase>!
!ClyTestCaseRan methodsFor: 'accessing' stamp: ''!
testCase: anObject
	testCase := anObject! !

!ClyTestCaseRan methodsFor: 'event processing' stamp: ''!
affectsMethodsDefinedInClass: aClass

	^testCase == aClass! !

!ClyTestCaseRan methodsFor: 'accessing' stamp: ''!
classAffected
	^testCase! !

!ClyTestCaseRan methodsFor: 'testing' stamp: ''!
affectsCritiques
	"It should be packages in critic plugin package 
	but for such simple message we can not do it"
	^false! !

!ClyTestCaseRan methodsFor: 'event processing' stamp: ''!
affectsMethodsTaggedWith: tagName
	^testCase tagsForMethods includes: tagName! !

!ClyTestCaseRan methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	testCase printOn: aStream.
	aStream nextPut: $).! !

!ClyTestCaseRan methodsFor: 'event processing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage

	^testCase package == aPackage or: [ aPackage extendsClass: testCase ]! !

!ClyTestCaseRan methodsFor: 'event processing' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery

	^true! !

!ClyTestCaseRan methodsFor: 'event processing' stamp: ''!
affectsPackages
	"we do not want update packages after every test case run"
	^false! !

!ClyTestCaseRan methodsFor: 'event processing' stamp: ''!
affectsMethods
	^true! !

!ClyTestCaseRan methodsFor: 'accessing' stamp: ''!
testCase
	^ testCase! !

!ClyTestCaseRan class methodsFor: 'instance creation' stamp: ''!
testCase: aClass
	^self new 
		testCase: aClass! !

!ClyTestCommand commentStamp: ''!
I am a root of hierarchy of commands to run any kind of tests!
!ClyTestCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	"Following code forces browser update to not wait for deferred updating logic
	to give immediate feedback with actual test icons.
	Without this code the icons updating is visually delayed"
	
	aToolContext activeQueryView dataSource runUpdate.! !

!ClyTestCommand methodsFor: 'context menu support' stamp: ''!
defaultMenuIcon
	
	^self testResult createIcon! !

!ClyTestCommand methodsFor: 'execution' stamp: ''!
notifyUserAboutResults: testResult with: message

	| color |	
	color := Color gray.
	testResult hasPassed
		ifTrue: [ color := TestResult defaultColorBackGroundForPassingTest ].
	testResult hasFailures
		ifTrue: [ color := TestResult defaultColorBackGroundForFailureTest ].
	testResult hasErrors
		ifTrue: [ color := TestResult defaultColorBackGroundForErrorTest ].
		
	GrowlMorph 
		openWithLabel: message
		contents: testResult printString
		backgroundColor: color
		labelColor: Color black! !

!ClyTestCommand methodsFor: 'tests' stamp: ''!
testResult
	self subclassResponsibility! !

!ClyTestCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyTestCommand! !

!ClyTestResultProperty commentStamp: ''!
I provide information about result of running tests which are related to my environment item.

My instances are created from method ot test case: 

	ClyTestResultProperty ofMethod: aCompiledMethod.
	ClyTestResultProperty ofMethod: aTestCaseClass.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	allCount:		<Integer>
	errorsCount:		<Integer>
	failuresCount:		<Integer>
	successesCount:		<Integer>!
!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
successCount
	^ successCount! !

!ClyTestResultProperty methodsFor: 'presentation' stamp: ''!
createIcon

	allCount = 0 ifTrue: [ ^ self iconNamed: #testNotRunIcon ].
	allCount = successCount
		ifTrue: [ ^ self iconNamed: #testGreenIcon ].
	errorCount = 0 & (failureCount > 0)
		ifTrue: [ ^ self iconNamed: #testYellowIcon ].
	errorCount > 0
		ifTrue: [ ^ self iconNamed: #testRedIcon ].
		
	^ self iconNamed: #testNotRunIcon! !

!ClyTestResultProperty methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	allCount := 0.
	successCount := 0.
	failureCount := 0.
	errorCount := 0! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
brokenCount
	^failureCount + errorCount! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
failureCount: anObject
	failureCount := anObject! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
accumulateTest: testSelector of: aTestClass

	allCount := allCount + 1.
	successCount := successCount + (aTestClass methodPassed: testSelector) asBit.
	failureCount := failureCount + (aTestClass methodFailed: testSelector) asBit.
	errorCount := errorCount + (aTestClass methodRaisedError: testSelector) asBit! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
errorCount: anObject
	errorCount := anObject! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
allCount: anObject
	allCount := anObject! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
accumulateTestCase: aClass

	allCount := allCount + aClass allTestSelectors size.
	successCount := successCount + (aClass history at: #passed) size.
	failureCount := failureCount + (aClass history at: #failures) size.
	errorCount := errorCount + (aClass history at: #errors) size! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
allCount
	^ allCount! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
failureCount
	^ failureCount! !

!ClyTestResultProperty methodsFor: 'testing' stamp: ''!
hasBrokenTests
	^failureCount > 0 | (errorCount > 0)! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
successCount: anObject
	successCount := anObject! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
accumulateFailures: failures andErrors: errors

	allCount := allCount + failures + errors.
	failureCount := failureCount + failures.
	errorCount := errorCount + errors! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
errorCount
	^ errorCount! !

!ClyTestResultProperty methodsFor: 'accessing' stamp: ''!
accumulateTestMethod: testMethod

	self accumulateTest: testMethod selector of: testMethod methodClass! !

!ClyTestResultProperty class methodsFor: 'instance creation' stamp: ''!
ofMethod: aMethod
	^ClyCompositeTestResultProperty new 
		accumulateTestMethod: aMethod! !

!ClyTestResultProperty class methodsFor: 'instance creation' stamp: ''!
ofTestCase: aTestCaseClass
	^self new 
		accumulateTestCase: aTestCaseClass! !

!ClyTestSetUpEditorToolMorph commentStamp: ''!
I am special method editor which operates on #setUp method.
So I am appears only on TestCase's and edit most relevant #setUp method.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	testClass:		<TestCase>!
!ClyTestSetUpEditorToolMorph methodsFor: 'building' stamp: ''!
buildTextMorph
	super buildTextMorph.
	
	editingMethod == (TestCase >> #setUp) ifTrue: [ 
		self setUpDefaultTemplate ].! !

!ClyTestSetUpEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpDefaultTemplate

	textModel setInitialText: self defaultTemplateForNewSetUp.
	targetClasses := { testClass }! !

!ClyTestSetUpEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpModelFromContext
	
	testClass := context lastSelectedClass! !

!ClyTestSetUpEditorToolMorph methodsFor: 'initialization' stamp: ''!
defaultTitle
	^'setUp'! !

!ClyTestSetUpEditorToolMorph methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserTool
	^self class = anotherBrowserTool class
		and: [ testClass == anotherBrowserTool testClass ]! !

!ClyTestSetUpEditorToolMorph methodsFor: 'initialization' stamp: ''!
defaultTemplateForNewSetUp

	^'setUp
	super setUp.
	
	"Put here a common initialization logic for tests"'! !

!ClyTestSetUpEditorToolMorph methodsFor: 'accessing' stamp: ''!
testClass
	^ testClass! !

!ClyTestSetUpEditorToolMorph methodsFor: 'initialization' stamp: ''!
setUpParametersFromModel

	editingMethod := testClass lookupSelector: #setUp.
	super setUpParametersFromModel! !

!ClyTestSetUpEditorToolMorph methodsFor: 'testing' stamp: ''!
belongsToCurrentBrowserContext
	^browser isClassSelected: testClass! !

!ClyTestSetUpEditorToolMorph methodsFor: 'controlling' stamp: ''!
switchToMethod: aMethod

	browser selectMethod: aMethod.
	self removeFromBrowser! !

!ClyTestSetUpEditorToolMorph methodsFor: 'accessing' stamp: ''!
activationPriority
	^-100! !

!ClyTestSetUpEditorToolMorph class methodsFor: 'activation' stamp: ''!
browserTabActivation
	"This declaration specifies that in any browser when classes are selected, a test setup editor will be available in a tab."
	
	<classAnnotation>
	^ ClyTabActivationStrategyAnnotation for: ClyClass asCalypsoItemContext! !

!ClyTestSetUpEditorToolMorph class methodsFor: 'accessing' stamp: ''!
tabOrder
	^ ClyClassDefinitionEditorToolMorph tabOrder + 1! !

!ClyTestSetUpEditorToolMorph class methodsFor: 'testing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	aBrowserContext isClassSelected ifFalse: [ ^false ].
	
	(aBrowserContext lastSelectedItem hasProperty: ClyTestResultProperty) ifFalse: [ ^false ].
	
	(aBrowserContext lastSelectedClass lookupSelector: #setUp) ifNil: [ ^false ].
	"last condition is to not show this tool if user selects #setUp method manually"
	aBrowserContext isMethodSelected ifFalse: [ ^true ].	
	^aBrowserContext browser methodSelection lastSelectedItem name ~= 'setUp'! !

!ClyTestedClass2Mock commentStamp: ''!
I am example of class which is covered by tests using Test sufix!
!ClyTestedClassMock commentStamp: ''!
I am example of class which is covered by tests using Tests sufix
 
Internal Representation and Key Implementation Points.

    Instance Variables
	one:		<Object>
	two:		<Object>!
!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
untestedOne: anObject
	self one: anObject! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
untestedTwo
	^ self two! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
untestedTwo: anObject
	self two: anObject! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
two
	^ two! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
two: anObject
	two := anObject! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
one: aFirstObject two: aSecondObject
	self
		one: aFirstObject;
		two: aSecondObject! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
untestedOneTwo: anObject
	self two: anObject! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
one
	^ one! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
oneTwo: anObject
	self two: anObject! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
untestedOne
	^ self one! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
untestedOne: aFirstObject two: aSecondObject
	self
		one: aFirstObject;
		two: aSecondObject! !

!ClyTestedClassMock methodsFor: 'accessing' stamp: ''!
one: anObject
	one := anObject! !

!ClyTestedClassMock class methodsFor: 'protocol' stamp: ''!
one: aFirstObject two: aSecondObject
	^ self new
		one: aFirstObject
		two: aSecondObject! !

!ClyTestedClassMock class methodsFor: 'protocol' stamp: ''!
untestedOne: aFirstObject two: aSecondObject
	^ self new
		one: aFirstObject;
		two: aSecondObject! !

!ClyTestedClassMockTest methodsFor: 'tests' stamp: ''!
testOne
	| testedObject |
	testedObject := self newTestedObject.
	self
		assert: testedObject one isNil;
		assert: (testedObject one: #one) identicalTo: testedObject;
		assert: testedObject one equals: #one! !

!ClyTestedClassMockTest methodsFor: 'running' stamp: ''!
newTestedObject
	^self classUnderTest new! !

!ClyTestedClassMockTest methodsFor: 'running' stamp: ''!
classUnderTest
	^ClyTestedClassMock! !

!ClyTestedClassMockTest methodsFor: 'tests' stamp: ''!
testOneTwo
	| testedObject |
	testedObject := self newTestedObject one: #one two: #two.
	self
		assert: testedObject one equals: #one;
		assert: testedObject two equals: #two;
		assert: (testedObject one: #three two: #four) identicalTo: testedObject;
		assert: testedObject one equals: #three;
		assert: testedObject two equals: #four;
		assert: (testedObject oneTwo: #five) identicalTo: testedObject;
		assert: testedObject one equals: #three;
		assert: testedObject two equals: #five! !

!ClyTestedClassMockTest methodsFor: 'tests' stamp: ''!
testExpectedFailure
	<expectedFailure>
	self assert: false description: 'it is example test with expected failure'! !

!ClyTestedClassMockTest methodsFor: 'tests' stamp: ''!
testTwo
	| testedObject |
	testedObject := self newTestedObject.
	self
		assert: testedObject two isNil;
		assert: (testedObject two: #two) identicalTo: testedObject;
		assert: testedObject two equals: #two! !

!ClyTestedClassProperty commentStamp: ''!
I mark classes which has covering test case. 
I include reference to coverint test class.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	coveringTestCase:		<TestCase>!
!ClyTestedClassProperty methodsFor: 'accessing' stamp: ''!
coveringTestCase
	^ coveringTestCase! !

!ClyTestedClassProperty methodsFor: 'accessing' stamp: ''!
coveringTestCase: anObject
	coveringTestCase := anObject! !

!ClyTestedClassProperty class methodsFor: 'accessing' stamp: ''!
coveringTestCase: aTestCase
	^self new 
		coveringTestCase: aTestCase! !

!ClyTestedEnvironmentPlugin commentStamp: ''!
I mark covered methods with information about test which cover them.

I decorate covered methods with ClyTestedMethodProperty which includes information about test result (ClyTestResultProperty). 

To find covering test I use simple hueristics: 
- Test or Tests suffix 
- test prefix for method name with various combinations.
Look at "tests lookup" methods for details.!
!ClyTestedEnvironmentPlugin methodsFor: 'tests lookup' stamp: ''!
findTestCaseCovering: aClass ifAbsent: absentBlock

	| className |
	className := aClass instanceSide name.
	
	^environment system classNamed: (className , 'Test') asSymbol ifAbsent: [ 
		environment system classNamed: (className , 'Tests') asSymbol ifAbsent: absentBlock ]! !

!ClyTestedEnvironmentPlugin methodsFor: 'tests lookup' stamp: ''!
findTestMethodCovering: aMethod ifAbsent: aBlock
	| selectorString testCase |
	aMethod isTestMethod ifTrue: [ ^ aBlock value ].
	testCase := self findTestCaseCovering: aMethod methodClass ifAbsent: [^aBlock value].
	
	selectorString := 'test', (self normalizeSelectorForComparison: aMethod selector).
	
	^ testCase methods
		detect: [ :each | (self normalizeSelectorForComparison: each selector) = selectorString ]
		ifNone: aBlock! !

!ClyTestedEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofClass: aClass

	| testCase |
	aClass isTestCase ifTrue: [ ^self ].

	testCase := self findTestCaseCovering: aClass ifAbsent: [^self].
	
	anItem addProperty: (ClyTestedClassProperty coveringTestCase: testCase)! !

!ClyTestedEnvironmentPlugin methodsFor: 'tests lookup' stamp: ''!
normalizeSelectorForComparison: aString
	"Returns a normalized version of given string without colons and in all lowercase"
	| selectorString selectorStringSize normalizedSelectorString normalizedSelectorStringSize |
	"asString to convert Symbols"
	selectorString := aString asString.
	selectorStringSize := aString size.
	normalizedSelectorString := selectorString class new: selectorStringSize.
	normalizedSelectorStringSize := 0.
	"this inlined to:do: loop with direct string manipulation is faster than
	using copyWithout:, which relies on reject:"
	1 to: selectorStringSize do: [ :i | 
		| nextChar |
		(nextChar := selectorString at: i) == $:
			ifFalse: [
				normalizedSelectorString
					at: (normalizedSelectorStringSize := normalizedSelectorStringSize + 1)
					put: nextChar ] ].
	"faster to use asLowercase on the entire string after instead of on chars
	in the to:do: loop because of the bad Character>>#asLowercase implementation"
	^ (normalizedSelectorStringSize < selectorStringSize
		ifTrue: [ normalizedSelectorString first: normalizedSelectorStringSize ]
		ifFalse: [ selectorString ]) asLowercase! !

!ClyTestedEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
detachFromSystem

	TestCase historyAnnouncer unsubscribe: self! !

!ClyTestedEnvironmentPlugin methodsFor: 'tests lookup' stamp: ''!
findTestedClassCoveredBy: aTestClass ifAbsent: absentBlock

	| className |
	className := aTestClass instanceSide name.
	(className endsWith: 'Test') ifTrue: [ 
		^environment system 
			classNamed: (className allButLast: 4) asSymbol  ifAbsent: absentBlock ].
	
	^absentBlock value! !

!ClyTestedEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
testRan: aTestSuiteEnded
	| event runTestCase testedClass |
	
	"testResult actually returns the TestCase class ran"	
	runTestCase := aTestSuiteEnded testResult.
	testedClass := self findTestedClassCoveredBy: runTestCase ifAbsent: [ ^self ].
	"Here we just reuse normal event with tested class which is covered by runTestCase.
	Logic for updates is same in that case"	
	event := ClyTestCaseRan testCase: testedClass.
	environment systemChanged: event! !

!ClyTestedEnvironmentPlugin methodsFor: 'controlling' stamp: ''!
attachToSystem

	TestCase historyAnnouncer 
		weak when: TestSuiteEnded send: #testRan: to: self! !

!ClyTestedEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod

	| testMethod testResult |
	aMethod isTestMethod ifTrue: [ ^self ].

	testMethod := self findTestMethodCovering: aMethod ifAbsent: [^self].
	
	testResult := (ClyTestResultProperty ofMethod: testMethod).
	anItem addProperty: (ClyTestedMethodProperty coveringTest: testMethod result: testResult)! !

!ClyTestedEnvironmentPlugin class methodsFor: 'testing' stamp: ''!
isSlow
	^true! !

!ClyTestedEnvironmentPluginTest methodsFor: 'tests' stamp: ''!
testFindingTestCoveringMethod
	{((ClyTestedClassMock >> #one) -> (ClyTestedClassMockTest >> #testOne)) . ((ClyTestedClassMock >> #one:) -> (ClyTestedClassMockTest >> #testOne)).
	((ClyTestedClassMock >> #two) -> (ClyTestedClassMockTest >> #testTwo)) . ((ClyTestedClassMock >> #two:) -> (ClyTestedClassMockTest >> #testTwo)).
	((ClyTestedClassMock >> #one:two:) -> (ClyTestedClassMockTest >> #testOneTwo)) . ((ClyTestedClassMock >> #oneTwo:) -> (ClyTestedClassMockTest >> #testOneTwo)).
	((ClyTestedClassMock >> #untestedOne) -> nil) . ((ClyTestedClassMock >> #untestedOne:) -> nil) . ((ClyTestedClassMock >> #untestedTwo) -> nil).
	((ClyTestedClassMock >> #untestedTwo:) -> nil) . ((ClyTestedClassMock >> #untestedOne:two:) -> nil) . ((ClyTestedClassMock >> #untestedOneTwo:) -> nil).
	((ClyTestedClassMock class >> #one:two:) -> (ClyTestedClassMockTest >> #testOneTwo)).
	((ClyTestedClassMock class >> #untestedOne:two:) -> nil) . ((ClyTestedClassMockTest >> #testOne) -> nil) . ((ClyTestedClassMockTest >> #testTwo) -> nil).
	((ClyTestedClassMockTest >> #testOneTwo) -> nil)} do: [ :each | self assert: (plugin findTestMethodCovering: each key ifAbsent: nil) identicalTo: each value ]! !

!ClyTestedEnvironmentPluginTest methodsFor: 'tests' stamp: ''!
testFindTestedClassCoveredByTestCaseWhenItAbsent

	| foundClass |
	foundClass := plugin findTestedClassCoveredBy: ClyAbstractlyNamedTest ifAbsent: [#noResult].

	self assert: foundClass equals: #noResult! !

!ClyTestedEnvironmentPluginTest methodsFor: 'tests' stamp: ''!
testFindTestedClassCoveredByTestCaseWithoutSuffix

	| foundClass |
	foundClass := plugin findTestedClassCoveredBy: ClyTestedClassMock ifAbsent: [#noResult].

	self assert: foundClass equals: #noResult! !

!ClyTestedEnvironmentPluginTest methodsFor: 'tests' stamp: ''!
testNormalizingSelectorForComparison
	#(#one #one: #two #two: #one:two: #oneTwo: #+ #- #+-)
		with: #('one' 'one' 'two' 'two' 'onetwo' 'onetwo' '+' '-' '+-')
		do: [ :original :transformed | 
			self assert: (plugin normalizeSelectorForComparison: original) equals: transformed.
			self assert: (plugin normalizeSelectorForComparison: original asString) equals: transformed.
			self assert: (plugin normalizeSelectorForComparison: transformed) equals: transformed.

			"should always return a string copy"
			self deny: (plugin normalizeSelectorForComparison: original) identicalTo: original.
			self deny: (plugin normalizeSelectorForComparison: transformed) identicalTo: transformed.
			self deny: (plugin normalizeSelectorForComparison: original) isSymbol.
			self deny: (plugin normalizeSelectorForComparison: transformed) isSymbol ]! !

!ClyTestedEnvironmentPluginTest methodsFor: 'tests' stamp: ''!
testFindTestedClassCoveredByTestCase

	| foundClass |
	foundClass := plugin findTestedClassCoveredBy: ClyTestedClassMockTest ifAbsent: [].

	self assert: foundClass equals: ClyTestedClassMock! !

!ClyTestedEnvironmentPluginTest methodsFor: 'tests' stamp: ''!
testFindTestCaseCoveringTestedMetaclass

	| foundClass |
	foundClass := plugin findTestCaseCovering: ClyTestedClassMock class ifAbsent: [  ].

	self assert: foundClass equals: ClyTestedClassMockTest! !

!ClyTestedEnvironmentPluginTest methodsFor: 'running' stamp: ''!
setUpEnvironment
	super setUpEnvironment.
	
	environment system: ClySystemEnvironment currentImage.
	plugin := ClyTestedEnvironmentPlugin new.
	plugin environment: environment.! !

!ClyTestedEnvironmentPluginTest methodsFor: 'tests' stamp: ''!
testFindTestCaseCoveringTestedClass

	| foundClass |
	foundClass := plugin findTestCaseCovering: ClyTestedClassMock ifAbsent: [  ].

	self assert: foundClass equals: ClyTestedClassMockTest! !

!ClyTestedEnvironmentPluginTest methodsFor: 'tests' stamp: ''!
testFindTestCaseWithAnotherSuffixCoveringTestedClass

	| foundClass |
	foundClass := plugin findTestCaseCovering: ClyTestedClass2Mock ifAbsent: [  ].

	self assert: foundClass equals: ClyTestedClass2MockTest! !

!ClyTestedEnvironmentPluginTest methodsFor: 'tests' stamp: ''!
testFindTestedClassCoveredByTestCaseWithAnotherSuffix

	| foundClass |
	foundClass := plugin findTestedClassCoveredBy: ClyTestedClass2MockTest ifAbsent: [].

	self assert: foundClass equals: ClyTestedClass2Mock! !

!ClyTestedEnvironmentPluginTest methodsFor: 'tests' stamp: ''!
testFindTestCaseCoveringUntestedClass

	| foundClass |
	foundClass := plugin findTestCaseCovering: ClyUntestedClassMock ifAbsent: [ #noResult  ].

	self assert: foundClass equals: #noResult! !

!ClyTestedMethodProperty commentStamp: ''!
I mark methods which has covering test. 
I include information about result of such test.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	coveringTest:		<TestCase>
	testResult:		<ClyTestResultProperty>!
!ClyTestedMethodProperty methodsFor: 'accessing' stamp: ''!
testResult: anObject
	testResult := anObject! !

!ClyTestedMethodProperty methodsFor: 'accessing' stamp: ''!
coveringTest: anObject
	coveringTest := anObject! !

!ClyTestedMethodProperty methodsFor: 'accessing' stamp: ''!
coveringTest
	^ coveringTest! !

!ClyTestedMethodProperty methodsFor: 'accessing' stamp: ''!
testResult
	^ testResult! !

!ClyTestedMethodProperty class methodsFor: 'instance creation' stamp: ''!
coveringTest: aMethodTest result: aTestResultProperty

	^self new 
		coveringTest: aMethodTest;
		testResult: aTestResultProperty! !

!ClyTextEditingMode commentStamp: ''!
I am used to override standard text editor operations in Calypso way.
Actual logic is in ClyTextEditor. I am another helper class which allows hook into the text morph.

Internal Representation and Key Implementation Points.

    Instance Variables
	browserTool:		<ClyTextEditorTool>
	isForScripting:		<Boolean>!
!ClyTextEditingMode methodsFor: 'initialize-release' stamp: ''!
updateTextAreaWhenPlugged
	super updateTextAreaWhenPlugged.
	isForScripting ifTrue: [ self textArea shoutStyler beForSmalltalkScripting]! !

!ClyTextEditingMode methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	
	isForScripting := false! !

!ClyTextEditingMode methodsFor: 'accessing' stamp: ''!
browserTool: aTextEditorTool
	browserTool := aTextEditorTool! !

!ClyTextEditingMode methodsFor: 'accessing' stamp: ''!
isForScripting
	^ isForScripting! !

!ClyTextEditingMode methodsFor: 'initialize-release' stamp: ''!
editorClass
	^ClyTextEditor! !

!ClyTextEditingMode methodsFor: 'accessing' stamp: ''!
browser
	^ browserTool browser! !

!ClyTextEditingMode methodsFor: 'accessing' stamp: ''!
browserTool
	^ browserTool! !

!ClyTextEditingMode methodsFor: 'accessing' stamp: ''!
isForScripting: anObject
	isForScripting := anObject! !

!ClyTextEditingMode class methodsFor: 'instance creation' stamp: ''!
browserTool: aTextEditorTool
	^self new 
		browserTool: aTextEditorTool! !

!ClyTextEditor commentStamp: ''!
I am used to override standard text editor operations in Calypso way.
I override all kind of navigation requests like sendersOfIt, implementorsOfIt and others.
I always call my actual browser owner to perform requested navigation query!
!ClyTextEditor methodsFor: 'operations' stamp: ''!
cancel

	self browserTool cancelChanges! !

!ClyTextEditor methodsFor: 'operations' stamp: ''!
undo

	super undo.

	self editingState undoManager hasPrevious ifFalse: [ 
		self browserTool changesCancelled]! !

!ClyTextEditor methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
sendersOf: selectedSelector

	self browser browseReferencesTo: selectedSelector! !

!ClyTextEditor methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
classNamesContainingIt
	"Open a browser on classes whose names contain the selected string"

	| query |
	self lineSelectAndEmptyCheck: [^self].

	query := ClyAllClassesQuery new filteredBy: (ClyItemNameFilter substringPattern: self selection string).
	self browser spawnQueryBrowserOn: query! !

!ClyTextEditor methodsFor: 'operations' stamp: ''!
printIt
	"Treat the current text selection as an expression; evaluate it. Insert the 
	description of the result of evaluation after the selection and then make 
	this description the new text selection."

	| printString |
	self
		evaluateSelectionAndDo: [ :result | 
			printString := [ result asScriptResultStringInCalypso ]
				on: Error
				do: [ '<error in printString: try ''Inspect it'' to debug>' ].
			self afterSelectionInsertAndSelect: printString ]! !

!ClyTextEditor methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
sendersOfIt

	| selector |
	(selector := self selectedSelector) ifNil: [ ^ textArea flash ].
	self sendersOf: selector! !

!ClyTextEditor methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
methodSourceContainingIt
	"Open a browser class comments which contain the current selection somewhere in them."

	| query pattern |
	self lineSelectAndEmptyCheck: [^ self].
	pattern := self selection string.
	query := (ClyMethodSourcesQuery withString: pattern), (ClyClassCommentsQuery withString: pattern).
	self browser spawnQueryBrowserOn: query! !

!ClyTextEditor methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
referencesToIt
	| selector |
	"self lineSelectAndEmptyCheck: [^ self]."
	(selector := self selectedSelector) == nil ifTrue: [^ textArea flash].
	
	self referencesTo: selector! !

!ClyTextEditor methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
implementorsOf: selectedSelector
	
	self browser browseImplementorsOf: selectedSelector! !

!ClyTextEditor methodsFor: 'accessing' stamp: ''!
browser
	^textArea editingMode browser! !

!ClyTextEditor methodsFor: 'accessing' stamp: ''!
browserTool
	^textArea editingMode browserTool! !

!ClyTextEditor methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
classCommentsContainingIt
	"Open a browser class comments which contain the current selection somewhere in them."

	| query |
	self lineSelectAndEmptyCheck: [^ self].

	query := ClyClassCommentsQuery withString: self selection string.
	self browser spawnQueryBrowserOn: query! !

!ClyTextEditor methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
referencesTo: aVariableName
	"Open a references browser on the given symbol"
	| class var |
	" ugly dispatch, but current Browser protocol names aren't really cool "
	class := self modelCurrentSelectedClass.

	class isBehavior ifTrue: [ 
		class slotNamed: aVariableName ifFound: [:slot | 
			var := ClyInstanceVariable on: slot visibleFrom: class.
			^self browser spawnQueryBrowserOn: (ClyVariableReferencesQuery of: var)]].
	
	self browser browseReferencesTo: aVariableName asSymbol from: class! !

!ClyTextEditor methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
browseFullClass
	"self lineSelectAndEmptyCheck: [^ self]."
	
	self evaluateSelectionAndDo: [:result | 
		self browser browseClassNamed: result class instanceSide name ]! !

!ClyTextEditor methodsFor: '*Calypso-SystemTools-QueryBrowser' stamp: ''!
implementorsOfIt

	| selector |
	(selector := self selectedSelector) ifNil: [ ^ textArea flash ].
	selector isCharacter ifTrue: [ ^ textArea flash ].
	self browser browseImplementorsOf: selector! !

!ClyTextEditor class methodsFor: 'context menu' stamp: ''!
contextMenuOn: aBuilder
	<RubSmalltalkCodeMenu>

	| context |
	(aBuilder model editingMode isKindOf: ClyTextEditingMode)
		ifFalse: [ ^self ].
		
	context := aBuilder model browserTool createCommandContext.
	CmdContextMenuActivation registerContextMenuOn: aBuilder inContext: context! !

!ClyTextEditorContext commentStamp: ''!
I am default text editor context!
!ClyTextEditorContext methodsFor: 'public' stamp: ''!
selectedTextInterval
	^tool selectedTextInterval! !

!ClyTextEditorContext methodsFor: 'public' stamp: ''!
browser
	^tool browser! !

!ClyTextEditorToolMorph commentStamp: ''!
I am a root for browser tools which requires text editor.
I install hooks into standard text morph to intercept all navigation requests and evaluated by Calypso logic.
Also I provide support for smart suggestions.

My subclasses should implement two methods: 

- editingText 
The text which is actually edited 

- applyChanges 
The operation to accept editing text changes 

Internal Representation and Key Implementation Points.

    Instance Variables
	applyingChanges:		<Boolean>
	changesCancelRequested:		<Boolean>
	textModel:		<RubScrolledTextModel>
	textMorph:		<RubScrolledTextMorph>!
!ClyTextEditorToolMorph methodsFor: 'building' stamp: ''!
buildTextMorph
	textModel := RubScrolledTextModel new.
	textModel interactionModel: self.
	textMorph := textModel newScrolledText.
	textMorph
		width: self width; "build is performed in background when owner is not exist yet. But we need proper width to perform kind of styling/formatting if needed"
		beWrapped;
		font: StandardFonts codeFont;
		editingMode: self editingMode.
	CmdKMDispatcher attachedTo: textMorph textArea withCommandsFrom: self. "It overrides default text morph shortcuts with Commander"
	self buildLeftSideBar.
	textModel setInitialText: self editingText.! !

!ClyTextEditorToolMorph methodsFor: 'contexts' stamp: ''!
createCommandContext
	^self createTextContext! !

!ClyTextEditorToolMorph methodsFor: 'accessing' stamp: ''!
leftSideBar
	^textMorph rulerNamed: #textSegmentIcons! !

!ClyTextEditorToolMorph methodsFor: 'testing' stamp: ''!
wantsStayInDifferentContext

	^ applyingChanges or: [ super wantsStayInDifferentContext ]! !

!ClyTextEditorToolMorph methodsFor: 'selecting text' stamp: ''!
selectAnyString: strings

	textMorph setSelection: (self findAnyString: strings in: self pendingText)! !

!ClyTextEditorToolMorph methodsFor: 'updating' stamp: ''!
update
	| unacceptedText newText |
	super update.
	newText := self editingText.
	self pendingText asString = newText ifTrue: [ 
		self applyDecorations.
		^self ].

	self hasUnacceptedEdits ifTrue: [unacceptedText := self pendingText copy].
	textModel setInitialText: newText.
	unacceptedText ifNil: [ ^self textUpdated ].

	self pendingText: unacceptedText.
	textMorph hasEditingConflicts: true.
	textMorph changed! !

!ClyTextEditorToolMorph methodsFor: 'accessing' stamp: ''!
textModel
	^textModel! !

!ClyTextEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
bindingOf: aString 
	^self selectedClassOrMetaClass bindingOf: aString! !

!ClyTextEditorToolMorph methodsFor: 'testing' stamp: ''!
hasUnacceptedEdits
	textMorph ifNil: [ ^false ].
	
	^textMorph hasUnacceptedEdits! !

!ClyTextEditorToolMorph methodsFor: 'building' stamp: ''!
subscribeOnTextChanges

	textMorph announcer 		
		when: RubTextAccepted send: #changesAccepted to: self;
		when: RubTextChanged send: #textChanged: to: self;
		when: RubCancelEditRequested send: #changesCancelRequested: to: self! !

!ClyTextEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
doItReceiver
	^self selectedClassOrMetaClass ifNotNil: [:class | class instanceSide]! !

!ClyTextEditorToolMorph methodsFor: 'updating' stamp: ''!
browserContextWasChanged
	"We should ignore any notifications during applying changes 
	because applied changes can cause them which can lead to wrong recursive updates"
	applyingChanges ifFalse: [ super browserContextWasChanged ]! !

!ClyTextEditorToolMorph methodsFor: 'events handling' stamp: ''!
changesAccepted

	| applied |
	^self applyChangesBy: [ 
		textMorph hasUnacceptedEdits: true.
		[self changesAreAboutApply.
		applied := self applyChanges] on: Error do: [ :err | 
			textModel text: self editingText. 
			textMorph hasUnacceptedEdits: true.
			err pass].	
		applied 
			ifTrue: [ textMorph hasUnacceptedEdits: false. 
				self textUpdated.
				browser focusActiveTab ]
			ifFalse: [ 
				textModel text: self editingText. 
				textMorph hasUnacceptedEdits: true].
	]! !

!ClyTextEditorToolMorph methodsFor: 'building' stamp: ''!
buildLeftSideBar
	textMorph withTextSegmentIcons! !

!ClyTextEditorToolMorph methodsFor: 'accessing' stamp: ''!
activationPriorityInNonActiveContext 

	^applyingChanges
		ifTrue: [ Float infinity ]
		ifFalse: [ super activationPriorityInNonActiveContext ]! !

!ClyTextEditorToolMorph methodsFor: 'keymapping' stamp: ''!
kmDispatcher

	^ CmdKMDispatcher attachedTo: self! !

!ClyTextEditorToolMorph methodsFor: 'building' stamp: ''!
build	
	self buildTextMorph.
	textModel clearUndoManager.
	self subscribeOnTextChanges.
	
	textMorph 
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	self addMorph: textMorph! !

!ClyTextEditorToolMorph methodsFor: 'operations' stamp: ''!
cancelChanges

	changesCancelRequested := true.
	textMorph setText: self editingText.
	changesCancelRequested := false.
	self rebuildStatusBar! !

!ClyTextEditorToolMorph methodsFor: 'initialization' stamp: ''!
resetStateForSnapshot
	super resetStateForSnapshot.
	
	textMorph := nil.
	textModel := nil! !

!ClyTextEditorToolMorph methodsFor: 'operations' stamp: ''!
applyChanges
	self subclassResponsibility! !

!ClyTextEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
bindings
	"no additional bindings provided by the Requestor"
	^#() asDictionary! !

!ClyTextEditorToolMorph methodsFor: 'accessing' stamp: ''!
textMorph
	^textMorph! !

!ClyTextEditorToolMorph methodsFor: 'events handling' stamp: ''!
changesCancelled

	textMorph hasUnacceptedEdits: false.
	self textUpdated! !

!ClyTextEditorToolMorph methodsFor: 'accessing' stamp: ''!
pendingText: aText
	textMorph updateTextWith: aText.
	textMorph hasUnacceptedEdits: true! !

!ClyTextEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
doItContext
	^nil! !

!ClyTextEditorToolMorph methodsFor: 'testing' stamp: ''!
wantsTextStyling
	^true! !

!ClyTextEditorToolMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	changesCancelRequested := false.
	applyingChanges := false! !

!ClyTextEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
shoutAboutToStyle: aMorph
	^self wantsTextStyling! !

!ClyTextEditorToolMorph methodsFor: 'contexts' stamp: ''!
createTextContext
	^ClyTextEditorContext for: self! !

!ClyTextEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
hasBindingOf: aString 
	^self selectedClassOrMetaClass hasBindingOf: aString! !

!ClyTextEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
selectedClassOrMetaClass
	^nil! !

!ClyTextEditorToolMorph methodsFor: 'building' stamp: ''!
editingMode
	| editingMode |
	editingMode := ClyTextEditingMode browserTool: self.
	editingMode
		classOrMetaClass: self selectedClassOrMetaClass;
		isForScripting: self isForScripting.
	^editingMode! !

!ClyTextEditorToolMorph methodsFor: 'accessing' stamp: ''!
selectedTextInterval
	^textMorph selectionInterval! !

!ClyTextEditorToolMorph methodsFor: 'focus management' stamp: ''!
takeKeyboardFocus 
	textMorph ifNotNil: [ textMorph takeKeyboardFocus]! !

!ClyTextEditorToolMorph methodsFor: 'updating' stamp: ''!
textUpdated
	self applyDecorations.
	self updateDirtyState.! !

!ClyTextEditorToolMorph methodsFor: 'rubric interaction model' stamp: ''!
isForScripting
	^true! !

!ClyTextEditorToolMorph methodsFor: 'updating' stamp: ''!
triggerUpdate
	applyingChanges ifFalse: [self update]! !

!ClyTextEditorToolMorph methodsFor: 'accessing' stamp: ''!
pendingText
	^textMorph text! !

!ClyTextEditorToolMorph methodsFor: 'accessing' stamp: ''!
editingText
	self subclassResponsibility! !

!ClyTextEditorToolMorph methodsFor: 'selecting text' stamp: ''!
findAnyString: strings in: text

	| index |
	strings do: [ :each | 
		index := text findString: each startingAt: 1.
		index > 0 ifTrue: [^index to: index + each size]].
	
	^0 to: -1! !

!ClyTextEditorToolMorph methodsFor: 'events handling' stamp: ''!
changesCancelRequested: aRubCancelEditRequested 

	changesCancelRequested := true! !

!ClyTextEditorToolMorph methodsFor: 'events handling' stamp: ''!
changesAreAboutApply
	"it is a hook method to allow subclasses prepare state 
	just before applying changes"! !

!ClyTextEditorToolMorph methodsFor: 'events handling' stamp: ''!
applyChangesBy: aBlock

	applyingChanges := true.
	^aBlock ensure: [ applyingChanges := false]! !

!ClyTextEditorToolMorph methodsFor: 'events handling' stamp: ''!
textChanged: aTextChanged

	changesCancelRequested ifTrue: [ 
		"user cancel changes and now text morph shows original text model".
		changesCancelRequested := false.
		^self changesCancelled ].
	
	self updateDirtyState! !

!ClyTextEditorToolMorph class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyTextEditorToolMorph! !

!ClyTextLineNumbersSwitchMorph commentStamp: ''!
I am a clickable label to toggle text morph decoration with line numbers.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	label:		<StringMorph>!
!ClyTextLineNumbersSwitchMorph methodsFor: 'operations' stamp: ''!
toggle
	textMorph lineNumbersRuler 
		ifNil: [ textMorph withLineNumbers ]
		ifNotNil: [ textMorph withoutLineNumbers ].
	self updateLabel! !

!ClyTextLineNumbersSwitchMorph methodsFor: 'updating' stamp: ''!
updateLabel

	| newValue |
	newValue := textMorph lineNumbersRuler ifNil: [ '+L' ] ifNotNil: [ 'L' ].
	label contents: newValue! !

!ClyTextLineNumbersSwitchMorph methodsFor: 'controlling' stamp: ''!
attachToTextMorph 
	super attachToTextMorph.
	
	label := StringMorph new.
	label setBalloonText:
			'Let you decide if the code pane should show the line numbers at the left of the code pane or not. +L: Click to add the lines number/L: Click to hide them.'.
	label on: #mouseDown send: #toggle to: self.
	self updateLabel.
	self addMorph: label.
	self class showLineNumbers 
		ifTrue: [ self toggle ].! !

!ClyTextLineNumbersSwitchMorph class methodsFor: 'settings' stamp: ''!
showLineNumbers: aBoolean
	showLineNumbers := aBoolean.
	self allInstancesDo: [ :inst | 
		| textMorph |
		textMorph := inst textMorph.
		(showLineNumbers and: [textMorph lineNumbersRuler isNil])
			ifTrue: [ textMorph withLineNumbers ].
		(showLineNumbers not and: [ textMorph lineNumbersRuler isNotNil ])
			ifTrue: [ textMorph withoutLineNumbers ].
		inst updateLabel ].! !

!ClyTextLineNumbersSwitchMorph class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #showLineNumbers)
		label: 'Show lines numbers for all browsers';
		parent: #Calypso;
		default: false;
		target: self;
		description: 'If true, line numbers will appear in new system browsers for method editor'.! !

!ClyTextLineNumbersSwitchMorph class methodsFor: 'settings' stamp: ''!
showLineNumbers
	^ showLineNumbers ifNil: [ false ].! !

!ClyTextMorphToolMorph commentStamp: ''!
I am a root of possible tools which affect text editors.
Instances are supposed to be placed in the status bar of the editor.
They should be created using following method: 

	ClyTextMorphTool of: aTextMorph
	
If subclass need to be notified about text changes it should implement changes subscription in #attachToTextMorph method.
By default it do nothing.

Internal Representation and Key Implementation Points.

    Instance Variables
	textMorph:		<Object>!
!ClyTextMorphToolMorph methodsFor: 'controlling' stamp: ''!
detachFromTextMorph! !

!ClyTextMorphToolMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.	
	self 
		changeTableLayout;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap! !

!ClyTextMorphToolMorph methodsFor: 'controlling' stamp: ''!
outOfWorld: aWorld
	super outOfWorld: aWorld.
	
	self detachFromTextMorph! !

!ClyTextMorphToolMorph methodsFor: 'accessing' stamp: ''!
textArea
	^ textMorph textArea! !

!ClyTextMorphToolMorph methodsFor: 'accessing' stamp: ''!
textMorph: aTextMorph
	textMorph := aTextMorph.
	self attachToTextMorph! !

!ClyTextMorphToolMorph methodsFor: 'controlling' stamp: ''!
attachToTextMorph! !

!ClyTextMorphToolMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^Color transparent! !

!ClyTextMorphToolMorph methodsFor: 'accessing' stamp: ''!
textMorph
	^ textMorph! !

!ClyTextMorphToolMorph class methodsFor: 'instance creation' stamp: ''!
of: aTextMorph
	^self new 
		textMorph: aTextMorph! !

!ClyTextWrapModeSwitchMorph commentStamp: ''!
I am a clickable label to toggle wrap mode of text morph.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	wrapModeLabel:		<StringMorph>!
!ClyTextWrapModeSwitchMorph methodsFor: 'operations' stamp: ''!
toggle
	textMorph wrapped 
		ifTrue: [ textMorph beNotWrapped  ]
		ifFalse: [ textMorph beWrapped ].
	self updateLabel! !

!ClyTextWrapModeSwitchMorph methodsFor: 'updating' stamp: ''!
updateLabel

	| newValue |
	newValue := textMorph wrapped ifTrue: [ 'W' ] ifFalse: [ 'NW' ].
	wrapModeLabel contents: newValue! !

!ClyTextWrapModeSwitchMorph methodsFor: 'controlling' stamp: ''!
attachToTextMorph 
	super attachToTextMorph.
	
	wrapModeLabel := StringMorph new.
	wrapModeLabel setBalloonText:
			'Let you decide if the code pane should automaticaly wrap lines if a line reach the end of the line. W: Wrap / NW: Add a scrollbar.'.
	wrapModeLabel on: #mouseDown send: #toggle to: self.
	self updateLabel.
	self addMorph: wrapModeLabel! !

!ClyToolContextNavigatorMorph commentStamp: ''!
I represent the context of given browser tab (tool).
I show kind of path to the tab model.
For example for the method editor it would be package/class string.

In addition I provide a button to force browser to restore state when the tool was created.
I simply ask the tool: 

	ownerTool restoreBrowserState
 
!
!ClyToolContextNavigatorMorph methodsFor: 'operations' stamp: ''!
restoreBrowserState
	ownerTool restoreBrowserState! !

!ClyToolContextNavigatorMorph methodsFor: 'building' stamp: ''!
build
	| goButton contextLabel |
	contextLabel := ownerTool printContext.
	contextLabel ifEmpty: [ ^self ]. "if ownerTool not defines meaningfull context name we ignore it"
	self addMorphBack: (self iconNamed: #uncommentedClass) asMorph.
	self addMorphBack: contextLabel asMorph.
	goButton := IconicButtonMorph new
		target: self;
		actionSelector: #restoreBrowserState;
		arguments: {};
		labelGraphic: (self iconNamed: #forward);
		color: Color transparent;
		helpText: 'Move browser to ', contextLabel;
		borderWidth: 0.
	self addMorphBack: goButton! !

!ClyToolbarActivation commentStamp: ''!
I annotate commands which should be placed in the toolbar.

By default I use #defaultMenuItemName to be used as a title of toolbar UI elements.
But if you want the title which is different from context menu then you should override #defaultToolbarItemName in the instance side of command!
!ClyToolbarActivation methodsFor: 'accessing' stamp: ''!
menuItemNameFor: aCommand
	^ menuItemName ifNil: [ aCommand defaultToolbarItemName ]! !

!ClyToolbarMorph commentStamp: ''!
I implement toobar in the browser (middle panel).
I collect all commands annotated by ClyToolbarCommandActivation strategy and ask them to build toolbar items.

This logic is implemented in method #updateItems. You can ask it anytime to update toolbar in the browser.
It is based on Commander menu:

	menu := CmdMenu activatedBy: ClyToolbarCommandActivation.

But in contrast to context menu all toolbar groups inline UI items into single toolbar panel.
So the menu groups in toolbar only allow to group several commands together to be close to each other. 

My instances are created on the browser: 

	ClyToolbar of: aBrowser
	 
Internal Representation and Key Implementation Points.

    Instance Variables
	browser:		<ClyBrowser>!
!ClyToolbarMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		color: self theme windowColor;
		changeTableLayout;
		height: self defaultHeight;	
		layoutInset: 2@0; 
		listDirection: #leftToRight;
		wrapCentering: #center;
		hResizing: #spaceFill;
		vResizing: #rigid! !

!ClyToolbarMorph methodsFor: 'updating' stamp: ''!
updateItems

	| menu |
	menu := CmdMenu activatedBy: ClyToolbarActivation.
	browser navigationContextsDo: [ :eachContext | menu buildInContext: eachContext].
	
	self hide.
	self removeAllMorphs.
	[menu buildBrowserToolbar: self] ensure: [self show]! !

!ClyToolbarMorph methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!ClyToolbarMorph methodsFor: 'accessing' stamp: ''!
addNewItem: aMorph
	self addMorphBack: aMorph! !

!ClyToolbarMorph methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!ClyToolbarMorph methodsFor: 'initialization' stamp: ''!
defaultHeight
	^30! !

!ClyToolbarMorph class methodsFor: 'instance creation' stamp: ''!
of: aBrowser
	^self new 
		browser: aBrowser! !

!ClyToolbarSeparatorMorph commentStamp: ''!
I am a vertical line which is used to separate toolbar elements which belongs to different menu groups.

I am used by CmdMenuGroup to build toolbar items: 

	menuGroup buildBrowserToolbar: aToolbar!
!ClyToolbarSeparatorMorph methodsFor: 'initialization' stamp: ''!
initialize
	| separator |
	super initialize.
	self 
		changeTableLayout;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		layoutInset: 4@0.
	separator := self theme newLabelIn: self label: '|'.
		
	self addMorph: separator! !

!ClyToolbarSeparatorMorph methodsFor: 'accessing' stamp: ''!
defaultColor
	^Color transparent! !

!ClyTraitChild1 methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait' stamp: ''!
extensionMethodFromRoot1Trait! !

!ClyTraitChild1 methodsFor: 'tag' stamp: ''!
methodFromTraitChild1! !

!ClyTraitChild1 methodsFor: 'accessing' stamp: ''!
methodFromRoot1! !

!ClyTraitChild1 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ClyTraitChild1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ClyTraitChild1 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ClyTraitChild1 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ClyTraitChild1 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ClyTraitChild1 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ClyTraitChild1 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ClyTraitChild1 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ClyTraitChild1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitChild1 classTrait methodsFor: 'accessing' stamp: ''!
classSideMethodFromRoot1! !

!ClyTraitChild1 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ClyTraitChild1 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ClyTraitChild1 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ClyTraitChild1 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ClyTraitChild1 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ClyTraitChild1 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ClyTraitChild1 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ClyTraitChild1 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ClyTraitChild1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitChild1 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ClyTraitChild1 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ClyTraitChild1 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ClyTraitChild1 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ClyTraitChild1 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ClyTraitChild1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ClyTraitChild1 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ClyTraitChild1 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ClyTraitChild2 methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait' stamp: ''!
extensionMethodFromRoot1Trait! !

!ClyTraitChild2 methodsFor: 'accessing' stamp: ''!
methodFromTraitChild2! !

!ClyTraitChild2 methodsFor: 'accessing' stamp: ''!
methodFromRoot1! !

!ClyTraitChild2 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ClyTraitChild2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ClyTraitChild2 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ClyTraitChild2 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ClyTraitChild2 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ClyTraitChild2 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ClyTraitChild2 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ClyTraitChild2 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ClyTraitChild2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitChild2 classTrait methodsFor: 'accessing' stamp: ''!
classSideMethodFromRoot1! !

!ClyTraitChild2 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ClyTraitChild2 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ClyTraitChild2 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ClyTraitChild2 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ClyTraitChild2 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ClyTraitChild2 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ClyTraitChild2 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ClyTraitChild2 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ClyTraitChild2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitChild2 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ClyTraitChild2 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ClyTraitChild2 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ClyTraitChild2 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ClyTraitChild2 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ClyTraitChild2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ClyTraitChild2 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ClyTraitChild2 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ClyTraitChild2Child methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait' stamp: ''!
extensionMethodFromRoot1Trait! !

!ClyTraitChild2Child methodsFor: 'accessing' stamp: ''!
methodFromTraitChild2! !

!ClyTraitChild2Child methodsFor: 'accessing' stamp: ''!
methodFromRoot1! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ClyTraitChild2Child classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ClyTraitChild2Child classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ClyTraitChild2Child classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ClyTraitChild2Child classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ClyTraitChild2Child classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ClyTraitChild2Child classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing' stamp: ''!
classSideMethodFromRoot1! !

!ClyTraitChild2Child classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ClyTraitChild2Child classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ClyTraitChild2Child classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ClyTraitChild2Child classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitChild2Child classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ClyTraitChild2Child classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ClyTraitChild2Child classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ClyTraitChild2Child classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ClyTraitChild2Child classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ClyTraitChild2Child classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ClyTraitChild3 methodsFor: 'accessing' stamp: ''!
methodFromTraitChild3! !

!ClyTraitChild3 methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait' stamp: ''!
extensionMethodFromRoot1Trait! !

!ClyTraitChild3 methodsFor: 'accessing' stamp: ''!
methodFromRoot1! !

!ClyTraitChild3 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ClyTraitChild3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ClyTraitChild3 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ClyTraitChild3 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ClyTraitChild3 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ClyTraitChild3 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ClyTraitChild3 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ClyTraitChild3 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ClyTraitChild3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitChild3 classTrait methodsFor: 'accessing' stamp: ''!
classSideMethodFromRoot1! !

!ClyTraitChild3 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ClyTraitChild3 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ClyTraitChild3 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ClyTraitChild3 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ClyTraitChild3 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ClyTraitChild3 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ClyTraitChild3 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ClyTraitChild3 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ClyTraitChild3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitChild3 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ClyTraitChild3 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ClyTraitChild3 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ClyTraitChild3 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ClyTraitChild3 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ClyTraitChild3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ClyTraitChild3 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ClyTraitChild3 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ClyTraitEnvironmentPlugin commentStamp: ''!
I plug environment with information about traits.

I decorate classes that they are traits, or users of traits.
I decorate methods that they are defined by trait.

And I extend method visibility of inherited method group which provide extra checkbox in the browser to enable/disable visibility of trait methods of selected classes!
!ClyTraitEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofClass: aClass

	aClass isTrait ifTrue: [ anItem markWith: ClyTraitTag ].
	aClass traits ifNotEmpty: [ anItem markWith: ClyTraitUserTag ]! !

!ClyTraitEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod

	aMethod origin isTrait ifTrue: [ 
		anItem systemDefinition definingClassItem markWith: ClyTraitTag ]! !

!ClyTraitFirstSortFunction commentStamp: ''!
I sort classes in the order by name but I put traits before normal classes.
I am used in method visibility hierarchy where inherited traits are shown in merged hierarchy with user classes!
!ClyTraitFirstSortFunction methodsFor: 'evaluating' stamp: ''!
collate: aClass1 with: aClass2
	aClass1 isTrait & aClass2 isTrait not ifTrue: [ ^-1].
	aClass1 isTrait not & aClass2 isTrait ifTrue: [ ^1].
	
	^aClass1 name threeWayCompareTo: aClass2 name! !

!ClyTraitFirstSortFunctionTest methodsFor: 'tests' stamp: ''!
testAscending
	
	function := ClyTraitFirstSortFunction ascending.
	
	self assert: (function value: ClyTraitRoot1 value: ClyTraitRoot2 ).
	self deny: (function value: ClyTraitRoot2 value: ClyTraitRoot1 ).
	self deny: (function value: ClyClass1FromP1Mock value: ClyTraitRoot1).
	self assert: (function value: ClyTraitRoot1 value: ClyClass1FromP1Mock ).
	self assert: (function value: ClyTraitRoot1 value: ClyTraitRoot1 ).
	self assert: (function value: ClyClass1FromP1Mock value: ClyClass1FromP1Mock )! !

!ClyTraitMethodDecorator commentStamp: ''!
I decorate table with special icon for methods which are defined in traits.
Notice that I only apply decoration when selected class is different than method defining trait!
!ClyTraitMethodDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyTraitMethodDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellInContext: methodItemContext
	"Idea is to decorate trait methods only when browser do not selects their origin"
	| definingClass |
	(super wantsDecorateTableCellInContext: methodItemContext) ifFalse: [ ^false ].
	
	methodItemContext isClassSelected ifFalse: [ ^false ].
	definingClass := methodItemContext selectedMethodItems last systemDefinition definingClassItem.
	
	(definingClass isMarkedWith: ClyTraitTag) ifFalse: [ ^false ].
	 
	^methodItemContext lastSelectedClass ~~ definingClass actualObject! !

!ClyTraitMethodDecorator class methodsFor: 'decoration' stamp: ''!
priority
	^200! !

!ClyTraitMethodDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	
	anItemCellMorph definitionIcon: #traitIcon! !

!ClyTraitRoot1 methodsFor: '*Calypso-SystemPlugins-Traits-Queries-Tests-PExtendingTrait' stamp: ''!
extensionMethodFromRoot1Trait! !

!ClyTraitRoot1 methodsFor: 'accessing' stamp: ''!
methodFromRoot1! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ClyTraitRoot1 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ClyTraitRoot1 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ClyTraitRoot1 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ClyTraitRoot1 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ClyTraitRoot1 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ClyTraitRoot1 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing' stamp: ''!
classSideMethodFromRoot1! !

!ClyTraitRoot1 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ClyTraitRoot1 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ClyTraitRoot1 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ClyTraitRoot1 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitRoot1 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ClyTraitRoot1 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ClyTraitRoot1 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ClyTraitRoot1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ClyTraitRoot1 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ClyTraitRoot1 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ClyTraitRoot2 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ClyTraitRoot2 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ClyTraitRoot2 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ClyTraitRoot2 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ClyTraitRoot2 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ClyTraitRoot2 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitRoot2 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ClyTraitRoot2 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ClyTraitRoot2 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ClyTraitRoot2 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ClyTraitRoot2 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ClyTraitRoot2 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ClyTraitRoot2 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ClyTraitRoot2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ClyTraitRoot2 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ClyTraitRoot2 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ClyTraitTag commentStamp: ''!
I am used to mark traits!
!ClyTraitUserHierarchy commentStamp: ''!
I represent hierarchy of classes where roots are common traits or classes without traits.
The children of every trait are user classes or traits.
And basic classes has no children because they are not traits!
!ClyTraitUserHierarchy methodsFor: 'building' stamp: ''!
buildParentMap: aHierarchyMap for: aClass
	| allParents eachParent |
	allParents := IdentitySet withAll: aClass traits.  		
	[allParents isEmpty] whileFalse: [
		eachParent := allParents anyOne.
		allParents remove: eachParent.
		(aHierarchyMap includesClass: eachParent) 
			ifTrue: [aHierarchyMap addChild: aClass to: eachParent]
			ifFalse: [ allParents addAll: eachParent traits].
	]! !

!ClyTraitUserHierarchy class methodsFor: 'method visibility' stamp: ''!
hierarchyForMethodVisibility
	"It will add inherited traits to the list of inherited classes to toggle visibility of methods"
	^(ClySubclassHierarchy hierarchyForMethodVisibility, self inverse) 
		sortedBy: ClyTraitFirstSortFunction ascending! !

!ClyTraitUserHierarchy class methodsFor: 'method visibility' stamp: ''!
methodVisibilityProvider
	<classAnnotation>
	^ClyMethodVisibilityProviderAnnotation new
		priority: 100 "We should override current default hierarchy in system"! !

!ClyTraitUserScope commentStamp: ''!
I represent class scope of all users of my basis traits.
I see methods of all classes and traits which use my basis traits !
!ClyTraitUserScope class methodsFor: 'accessing' stamp: ''!
defaultName
	^'trait users'! !

!ClyTraitUserScope class methodsFor: 'accessing' stamp: ''!
classesRelatedTo: aTrait do: aBlock
	aTrait users do: aBlock! !

!ClyTraitUserScopeTest methodsFor: 'tests' stamp: ''!
testClassEnumeration
	scope := ClyTraitUserScope of: ClyTraitRoot1.
	
	scope classesDo: [ :each | result add: each ].
	
	self assert: result asSet equals: {
		ClyTraitChild1.	ClyTraitChild2. 
		ClyClassWithTraits. ClyTraitChild2Child. ClyTraitChild3.
		ClySubclassWithTraitsOfClassWithTraits} asSet! !

!ClyTraitUserScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumerationWhenBothMetaLevels

	scope := ClyTraitUserScope of: ClyTraitRoot1 localScope: ClyBothMetaLevelClassScope.
	
	scope methodsDo: [ :each | result add: each].
	
	self assert: (result includesAll: ClyTraitChild1 localMethods).
	self assert: (result includesAll: ClyTraitChild1 classSide localMethods).
	self assert: (result includesAll: ClyClassWithTraits localMethods).
	self assert: (result includesAll: ClyClassWithTraits classSide localMethods).
	self deny: (result includesAll: ClyTraitRoot1 localMethods).
	self deny: (result includesAll: ClyTraitRoot1 classSide localMethods).! !

!ClyTraitUserScopeTest methodsFor: 'running' stamp: ''!
scopeClass
	
	^ClyTraitUserScope! !

!ClyTraitUserScopeTest methodsFor: 'tests' stamp: ''!
testMethodsEnumeration
	scope := ClyTraitUserScope of: ClyTraitRoot1.

	scope methodsDo: [ :each | result add: each ].

	self assert: (result includesAll: ClyTraitChild1 localMethods).
	self assert: (result includesAll: ClyClassWithTraits localMethods).
	self deny: (result includesAll: ClyClassWithTraits classSide localMethods).
	self deny: (result includesAll: ClyTraitRoot1 localMethods).
	self deny: (result includesAll: ClyTraitRoot1 classSide localMethods)! !

!ClyTraitUserTag commentStamp: ''!
I am used to mark classes which inherit traits!
!ClyTraitUsersHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithUsersOfTraitWhenRootTraitIsMissingInGivenList
	
	queryResult fillWith: {
		ClyTraitChild1. ClyClassWithTraits. ClyTraitChild2}.
		
	self assertItems: { 
		ClyTraitChild1. 0. ClyClassWithTraits. 1. 
		ClyTraitChild2. 0. ClyClassWithTraits. 1 }! !

!ClyTraitUsersHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithClassInsteadOfTrait
	
	queryResult fillWith: {ClyClassWithoutTraits}.
		
	self assertItems: {ClyClassWithoutTraits. 0}! !

!ClyTraitUsersHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithOnlyTraitWithoutUsers
	
	queryResult fillWith: {ClyTraitRoot1}.
		
	self assertItems: { ClyTraitRoot1. 0}! !

!ClyTraitUsersHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithTraitAndItsUsersWhenSomeUserInMiddleIsMissing
	
	queryResult fillWith: {
		ClyTraitRoot1. ClyTraitChild1. ClyClassWithTraits. ClyTraitChild2}.
		
	self assertItems: { 
		ClyTraitRoot1. 0.
			ClyTraitChild1. 1. ClyClassWithTraits. 2. 
			ClyTraitChild2. 1. ClyClassWithTraits. 2
		 }! !

!ClyTraitUsersHierarchyTest methodsFor: 'running' stamp: ''!
createQueryResult
	^ClyTraitUserHierarchy new asQueryResult! !

!ClyTraitUsersHierarchyTest methodsFor: 'tests' stamp: ''!
testFillingWithTraitAndItsUsers
	
	queryResult fillWith: {
		ClyTraitRoot1. ClyTraitChild1. ClyClassWithTraits. ClyTraitChild2. ClyTraitChild2Child}.
		
	self assertItems: { 
		ClyTraitRoot1. 0.
			ClyTraitChild1. 1. ClyClassWithTraits. 2. 
			ClyTraitChild2. 1. ClyTraitChild2Child. 2. ClyClassWithTraits. 3
		 }! !

!ClyTypedQuery commentStamp: ''!
My subclasses represent queries which retrieve particular kind of objects.
Subclasses should return class of items from class side method #resultItemsType.

I implement many required methods of superclass. 
The rest is responsibility of subclasses:

- buildResult: aQueryResult 
It is the method where query retrieves items from the scope and fill given result with them. Look at implementors.

- checkEmptyResult
Subclasses should be able detect that result will be empty without execution.

-isResult: aQueryResult affectedBy: aSystemAnnouncement
Any query can be affected by system changes. Subclasses should implement what change affects their results.

- retrivesItem: anObject
Subclasses should check that given item can be retrieved independently on scope.

-collectMetadataOf: aQueryResult by: anEnvironmentPlugin
Subclasses should dispatch metadata collection to the given environment plugin.

I provide many instance creation methods. For example you can execute any typed query with sorted result:

	ClyAllClasses sortedFrom: ClyNavigationEnvironment currentImageScope.

And I provide union query support. Typed queries can be concatinated using command message:
	aClassQuery, aMethodQuery

Look at class side for more options!
!ClyTypedQuery methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateResultMethodEditor: aMethodEditor! !

!ClyTypedQuery methodsFor: 'converting' stamp: ''!
restrictedByScope: aScope

	^self withScope: (scope restrictedBy: aScope)! !

!ClyTypedQuery methodsFor: 'converting' stamp: ''!
withoutItemsOfType: anItemTypeClass

	^(self retrievesItemsOfType: anItemTypeClass)
		ifTrue: [ ClyUnknownQuery instance ]
		ifFalse: [ self ]! !

!ClyTypedQuery methodsFor: 'composition' stamp: ''!
unionWith: typedQueries as: aQueryResult

	^ClyQuery unionFrom: (typedQueries copyWith: self) as: aQueryResult! !

!ClyTypedQuery methodsFor: 'item group decoration' stamp: ''!
decorateItemGroup: groupItem
	groupItem markWithChildrenOf: self resultItemsType! !

!ClyTypedQuery methodsFor: 'converting' stamp: ''!
withScopeOf: newBasisObjects

	^self withScope: (scope withNewBasisObjects: newBasisObjects)! !

!ClyTypedQuery methodsFor: 'private' stamp: ''!
asUnifiedInstance
	^self copy 
		resetScope! !

!ClyTypedQuery methodsFor: 'converting' stamp: ''!
withScope: aScope
	| copy |
	copy := self copy.
	^aScope adoptQuery: copy! !

!ClyTypedQuery methodsFor: 'testing' stamp: ''!
retrievesItemsOfType: itemTypeClass
	^ self resultItemsType isCalypsoItemType: itemTypeClass! !

!ClyTypedQuery methodsFor: 'testing' stamp: ''!
executesQuery: aTypedQueryClass
	^self isKindOf: aTypedQueryClass! !

!ClyTypedQuery methodsFor: 'composition' stamp: ''!
, anotherQuery
	^ anotherQuery unionWith: {self} as: requiredResult! !

!ClyTypedQuery methodsFor: 'accessing' stamp: ''!
resultItemsType
	^self class resultItemsType! !

!ClyTypedQuery class methodsFor: 'instance creation' stamp: ''!
from: aScopeClass ofAll: basisObjects in: aNavigationEnvironment
	^ self
		from: (aScopeClass ofAll: basisObjects in: aNavigationEnvironment)! !

!ClyTypedQuery class methodsFor: 'instance creation' stamp: ''!
from: aScope

	^aScope adoptQuery: self new! !

!ClyTypedQuery class methodsFor: 'merging queries' stamp: ''!
mergeOwnInstances: queries

	| queryGroups merged |
	queryGroups := queries groupedBy: [ :each | each asUnifiedInstance ].
	
	merged := OrderedCollection new.
	queryGroups keysAndValuesDo: [ :unifiedQuery :groupedQueries |
		merged addAll: (self mergeOwnInstances: groupedQueries unifiedBy: unifiedQuery)].
	
	^merged! !

!ClyTypedQuery class methodsFor: 'merging queries' stamp: ''!
mergeOwnInstances: queries unifiedBy: ownUnifiedInstance
	| scopeGroups result mergedBasis mergedScope |
	scopeGroups := queries groupedBy: [ :each | each scope asUnifiedInstance ].
	
	result := OrderedCollection new.
	scopeGroups keysAndValuesDo: [ :unifiedScope :groupedQueries | 
		mergedBasis := groupedQueries 
			flatCollect: [:each | each scope basisObjects] 
			as: OrderedCollection. "Merging duplications will be performed by scope itself"
		mergedScope := unifiedScope withNewBasisObjects: mergedBasis.
		result add: (ownUnifiedInstance withScope: mergedScope)].
		
	^result! !

!ClyTypedQuery class methodsFor: 'instance creation' stamp: ''!
from: aScopeClass of: aBasisObject in: aNavigationEnvironment
	^ self
		from: (aScopeClass of: aBasisObject in: aNavigationEnvironment)! !

!ClyTypedQuery class methodsFor: 'instance creation' stamp: ''!
fromAll: scopeClasses of: aBasisObject in: aNavigationEnvironment

	| subqueries |
	subqueries := scopeClasses collect: [:eachScope | 
		self from: eachScope of: aBasisObject in: aNavigationEnvironment].
	^ClyQuery unionFrom: subqueries! !

!ClyTypedQuery class methodsFor: 'instance creation' stamp: ''!
sorted
	^self sortedBy: self resultItemsType defaultSortFunctionForCalypso! !

!ClyTypedQuery class methodsFor: 'instance creation' stamp: ''!
sortedFrom: aScope
	
	^self sorted 
		scope: aScope! !

!ClyTypedQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	self subclassResponsibility! !

!ClyTypedQuery class methodsFor: 'instance creation' stamp: ''!
from: aScope as: aQueryResult

	^(self from: aScope)
		requiredResult: aQueryResult! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewScopeBasis
	| convertedQuery |
	
	convertedQuery := query withScopeOf: #(newBasis).
	
	self assert: convertedQuery class equals: query class.
	self assert: convertedQuery scope class equals: query scope class.
	self assert: convertedQuery scope basisObjects equals: #(newBasis) asSet! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromMultipleScope

	query scope: (ClyExampleScope ofAll: #(object1 object2) in: environment).
	self assert: query isExecutedFromMultipleScope.

	query scope: (ClyExampleScope of: #singleObject in: environment).
	self deny: query isExecutedFromMultipleScope.

	query scope: (ClyExampleScope emptyIn: environment).
	self deny: query isExecutedFromMultipleScope! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromScopeOfBasisObject
	query scope: (ClyExampleScope of: #basis in: environment).

	self assert: (query isExecutedFromScopeOf: query scope basisObjects anyOne).
	self deny: (query isExecutedFromScopeOf: #someObject)! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testForbidCreationOnScopeWithoutEnvironment
	[ 
		query scope: (ClyExampleScope ofAll: {}).
		self assert: false description: 'Query should be only created on scope bound to concrete environment']
			onErrorDo: [  ]! !

!ClyTypedQueryTest methodsFor: 'running' stamp: ''!
queryFromScope: scopeClass of: aBasisObject
	query scope: (scopeClass of: aBasisObject in: environment).
	self executeQuery! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromConcreteScopeClass

	self assert: (query isExecutedFromScope: query scope class).
	self assert: (query isExecutedFromScope: query scope class superclass).
	
	self deny: (query isExecutedFromScope: ClyExample2Scope).! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testComparisonOfSimilarQueriesWithDifferentScopes
	| query2 |
	query2 := self createQuery.
	query scope: (ClyExampleScope of: #basisObject1 in: environment).
	query2 scope: (ClyExampleScope of: #basisObject2 in: environment).
	self deny: query equals: query2.

	query2 scope: (ClyExample2Scope of: #basisObject1 in: environment).
	self deny: query equals: query2! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromEmptyScope
	
	query scope: (ClyExampleScope ofAll: #(object1 object2) in: environment).
	self deny: query isExecutedFromEmptyScope.
	
	query scope: (ClyExampleScope emptyIn: environment).
	self assert: query isExecutedFromEmptyScope! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewCompositeScope
	| newScope convertedQuery |
	newScope := ClyCompositeScope on: {
		ClyExampleScope of: #someBasis1 in: environment.
		ClyExample2Scope of: #someBasis2 in: environment}.
		
	convertedQuery := query withScope: newScope.
	
	self assert: convertedQuery class equals: ClyUnionQuery.
	self
		assert: (convertedQuery subqueries collect: #class as: Set)
		equals: {query class} asSet.
	self
		assert: (convertedQuery subqueries collect: #scope as: Set)
		equals: newScope subscopes asSet! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testCreationUnifiedInstance

	| unifiedInstance |
	unifiedInstance := query asUnifiedInstance.
	
	self assert: unifiedInstance class equals: query class.
	self assert: unifiedInstance requiredResult equals: query requiredResult.
	self assert: unifiedInstance scope equals: ClyUnknownScope instance! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testCreationOnMultipleScopeOfSameBasis

	| queryClass |
	queryClass := query class.
	query := queryClass 
		fromAll: {ClyExampleScope. ClyExample2Scope } of: Array in: environment.
	
	self assert: query class equals: ClyUnionQuery.
	self assert: query subqueries equals: {
		queryClass from: ClyExampleScope of: Array in: environment.
		queryClass from: ClyExample2Scope of: Array in: environment.
	} asSet.! !

!ClyTypedQueryTest methodsFor: 'running' stamp: ''!
queryFromScope: scopeClass ofAll: basisObjects
	query scope: (scopeClass ofAll: basisObjects in: environment).
	self executeQuery! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewScope
	| newScope convertedQuery |
	newScope := ClyExample2Scope of: #someBasis in: environment.
	
	convertedQuery := query withScope: newScope.
	
	self assert: convertedQuery class equals: query class.
	self assert: convertedQuery scope equals: newScope! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testExecutesConcreteQueryClass
	
	self assert: (query executesQuery: query class).
	self assert: (query executesQuery: query class superclass).
	
	self deny: (query executesQuery: ClyReturningScopeBasis2ExampleQuery)! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testComparisonOfSimilarQueriesWithEqualScopes
	| query2 |
	query2 := self createQuery.
	query scope: (ClyExampleScope of: #basisObject in: environment).
	query2 scope: (ClyExampleScope of: #basisObject in: environment).
	
	self assert: query equals: query2.
	self assert: query hash equals: query2 hash! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testConvertingAsRestrictedByAnotherScope
	| newScope convertedQuery |
	newScope := ClyExample2Scope of: #newBasis in: environment.
	
	convertedQuery := query restrictedByScope: newScope.
	
	self assert: convertedQuery class equals: query class.
	self assert: convertedQuery scope class equals: query scope class.
	self assert: convertedQuery scope basisObjects equals: #(newBasis) asSet! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testForbidCreationOnScopeWhichNotSupportIt

	[query scope: (ClyCompositeScope in: environment).
	self assert: false description: 'Query should be supported by scope'
	] onErrorDo: [].! !

!ClyTypedQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromSingleScope
	query scope: (ClyExampleScope ofAll: #(object1 object2) in: environment).
	self deny: query isExecutedFromSingleScope.

	query scope: (ClyExampleScope of: #singleObject in: environment).
	self assert: query isExecutedFromSingleScope.

	query scope: (ClyExampleScope emptyIn: environment).
	self deny: query isExecutedFromSingleScope! !

!ClyTypedQueryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyTypedQueryTest! !

!ClyTypedScope commentStamp: ''!
My subclasses represent the scope of concrete typed objects.
I do not require them to implement any specific methods. They just define logically what objects they represent. And they should provide methods to assess information from them.

For example there is ClyClassScope which is based on set of classes. And there is ClyPackageScope which is based on set of packages.
And they provide methods which queries are using to retrieve required objects: 
	aClassScope classesDo: aBlock
	aClassScope methodsDo: aBlock 
	aPackageScope packagesDo: aBlock 
	aPackageScope classesDo: aBlock 
	aPackageScope methodsDo: aBlock

I provide several methods to instantiate typed scopes:

	ClyClassScope of: String.
	ClyClassScope of: String in: ClyNavigationEnvironment currentImage.
	ClyClassScope of: String in: ClyNavigationEnvironment currentImage named: 'String scope'.

They create class scopes based on single basis object String.

	ClyClassScope ofAll: {String. Point}.
	ClyClassScope of: {String. Point} in: ClyNavigationEnvironment currentImage.
	ClyClassScope of: {String. Point} in: ClyNavigationEnvironment currentImage named: 'String and Point'.

They create scopes of two classes String and Point.

Also users can ask for empty scope: 

	ClyClassScope empty.
	ClyClassScope emptyIn: ClyNavigationEnvironment.
	
I implement several methods convert existing scopes to new one with modified basis:

- withNewBasisObjects: newBasisObjects
It returns new scope similar to receiver but with basis.

- withExtraBasisObject: extraBasisObject 
It returnes new scope similar to receiver but with basis extended by given extraBasisObject.

- withExtraBasisObjects: extraBasisObjects 
It returnes new scope similar to receiver but with basis extended by all extraBasisObjects.

- withoutBasisObject: existingBasisObject 
It returnes new scope similar to receiver but with basis which excludes existingBasisObject. It ignores the case when given object is not in the basis of receiver scope.

- withoutBasisObjects: existingBasisObjects 
It returnes new scope similar to receiver but with basis which excludes all existingBasisObjects. It ignores the case when some of given objects are not in the basis of receiver scope.

- restrictedBy: anotherScope
It returnes new scope similar to receiver but with basis of given anotherScope

Also I provide scope composition method which merges two scopes: 
	
	(ClyClassScope of: String) , (ClyClassScope of: Array)
	
It returns ClyCompositeScope instance. 

To support composite scope and query I introduce method #asUnifiedInstance which supposed to return similar scope with same kind of scope class and internal parameters but with empty basis.
So any possible instance of my subclass should produce equal unified instance with this method. It is used to merge subqueries and their scopes when ClyUnionQuery is built. 
	
Also I implement my superclass abstract methods like: 
- supportsQuery: aQuery. It returns true for any kind of ClyTypedQuery.
- representsScope: aScopeClass. It just checks if receiver is kind of given scope class.
- adoptQuery: aQuery. It just assigns receiver to the aQuery to be it scope.
!
!ClyTypedScope methodsFor: 'converting' stamp: ''!
restrictedBy: aScope

	^self withNewBasisObjects: aScope basisObjects! !

!ClyTypedScope methodsFor: 'converting' stamp: ''!
withoutBasisObject: existingBasisObject

	^self withNewBasisObjects: (basisObjects copyWithout: existingBasisObject)! !

!ClyTypedScope methodsFor: 'queries' stamp: ''!
adoptQuery: aQuery
	aQuery scope: self.
	^aQuery! !

!ClyTypedScope methodsFor: 'initialization' stamp: ''!
prepareBasisFrom: aCollection
	^aCollection! !

!ClyTypedScope methodsFor: 'converting' stamp: ''!
withExtraBasisObjects: extraBasisObjects

	| newBasis |
	newBasis := OrderedCollection withAll: basisObjects.
	extraBasisObjects do: [ :each | 
		(newBasis identityIncludes: each) ifFalse: [ newBasis add: each ] ].

	^self withNewBasisObjects: newBasis! !

!ClyTypedScope methodsFor: 'accessing' stamp: ''!
basisObjects: aCollection
	super basisObjects: (self prepareBasisFrom: aCollection)! !

!ClyTypedScope methodsFor: 'private' stamp: ''!
asUnifiedInstance
	^self withNewBasisObjects: #()! !

!ClyTypedScope methodsFor: 'converting' stamp: ''!
withNewBasisObjects: newBasisObjects

	^self copy 
		basisObjects: newBasisObjects;
		bindTo: environment! !

!ClyTypedScope methodsFor: 'converting' stamp: ''!
withExtraBasisObject: newBasisObject

	(basisObjects includes: newBasisObject) ifTrue: [ ^self ].
	 
	^self withNewBasisObjects: (basisObjects copyWith: newBasisObject)! !

!ClyTypedScope methodsFor: 'testing' stamp: ''!
supportsQuery: aQuery
	^aQuery isKindOf: ClyTypedQuery! !

!ClyTypedScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
includesClassesAffectedBy: aSystemAnnouncement

	^basisObjects anySatisfy: [ :each | 
		each includesClassesAffectedBy: aSystemAnnouncement ]! !

!ClyTypedScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
canDetectAffectOnClassesBy: aSystemAnnouncement
	"it is special hook to allow particular scopes define that all items should be checked.
	For example class hierarchy scope could not track that removed class was in hierarchy
	using only events. It should be improved in system but right now it is like that"		
	
	^true! !

!ClyTypedScope methodsFor: 'composition' stamp: ''!
, anotherTypedScope
	^ClyCompositeScope on: { self. anotherTypedScope }! !

!ClyTypedScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
includesClassGroupsAffectedBy: aSystemAnnouncement

	^false! !

!ClyTypedScope methodsFor: 'testing' stamp: ''!
representsScope: aScopeClass
	^self isKindOf: aScopeClass! !

!ClyTypedScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
includesMethodsAffectedBy: aSystemAnnouncement

	^basisObjects anySatisfy: [ :each | 
		each includesMethodsAffectedBy: aSystemAnnouncement ]! !

!ClyTypedScope methodsFor: 'converting' stamp: ''!
withoutBasisObjects: existingBasisObjects

	^self withNewBasisObjects: (basisObjects copyWithoutAll: existingBasisObjects)! !

!ClyTypedScope methodsFor: '*Calypso-SystemQueries' stamp: ''!
includesVariablesAffectedBy: aSystemAnnouncement
	^false! !

!ClyTypedScope class methodsFor: 'instance creation' stamp: ''!
empty
	^ self ofAll: #()! !

!ClyTypedScope class methodsFor: 'instance creation' stamp: ''!
of: aBasisObject
		
	^self ofAll: {aBasisObject}! !

!ClyTypedScope class methodsFor: 'instance creation' stamp: ''!
emptyIn: aNavigationEnvironment
	^ self ofAll: #() in: aNavigationEnvironment! !

!ClyTypedScope class methodsFor: 'instance creation' stamp: ''!
of: aBasisObject in: aNavigationEnvironment

	^self ofAll: {aBasisObject} in: aNavigationEnvironment! !

!ClyTypedScope class methodsFor: 'instance creation' stamp: ''!
of: aBasisObject in: aNavigationEnvironment named: aString

	^(self of: aBasisObject in: aNavigationEnvironment)
		name: aString! !

!ClyTypedScope class methodsFor: 'instance creation' stamp: ''!
ofAll: basisObjects in: aNavigationEnvironment

	^(self ofAll: basisObjects)
		bindTo: aNavigationEnvironment! !

!ClyTypedScope class methodsFor: 'instance creation' stamp: ''!
ofAll: aBasisObject in: aNavigationEnvironment named: aString

	^(self ofAll: aBasisObject in: aNavigationEnvironment)
		name: aString! !

!ClyTypedScope class methodsFor: 'instance creation' stamp: ''!
ofAll: basisObjects

	^self new
		basisObjects: basisObjects! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testBasedOnEmptyBasis

	scope := self multipleScopeSample.
	self deny: scope isBasedOnEmptyBasis.

	scope := self singleScopeSample.
	self deny: scope isBasedOnEmptyBasis.
	
	scope := self emptyScopeSample.
	self assert: scope isBasedOnEmptyBasis! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testConvertingWithoutExistingBasisObjects
	| convertedScope |
	scope := self multipleScopeSample.
	
	convertedScope := scope withoutBasisObjects: scope basisObjects.
	
	self assert: convertedScope class equals: scope class.
	self deny: (convertedScope basisObjects includesAll: scope basisObjects).! !

!ClyTypedScopeTest methodsFor: 'running' stamp: ''!
multipleScopeSample
	^ self scopeClass 
		ofAll: {self singleBasisSample. self extraBasisSample}
		in: environment! !

!ClyTypedScopeTest methodsFor: 'running' stamp: ''!
singleScopeSample
	^ self scopeClass of: self singleBasisSample in: environment! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testAdoptQuery
	| query adoptedQuery |
	scope := self singleScopeSample.
	query := ClyReturningScopeBasisExampleQuery new.

	adoptedQuery := scope adoptQuery: query.

	self assert: adoptedQuery identicalTo: query! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testConvertingWithExtraBasisObjectIfItIsAlreadyBasis
	| convertedScope |
	scope := self createSampleScope.
	
	convertedScope := scope withExtraBasisObject: scope basisObjects anyOne.
	
	self assert: convertedScope basisObjects equals: scope basisObjects.! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testRepresentsClassOfScope

	scope := self createSampleScope.
	self assert: (scope representsScope: self scopeClass).
	self assert: (scope representsScope: ClyTypedScope).
	
	self deny: (scope representsScope: ClyCompositeScope). "Class of scope which are not the class of subscopes"! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testBasedOnSingleBasis

	scope := self singleScopeSample.
	self assert: scope isBasedOnSingleBasis.

	scope := self multipleScopeSample.
	self deny: scope isBasedOnSingleBasis.
		
	scope := self emptyScopeSample.
	self deny: scope isBasedOnSingleBasis! !

!ClyTypedScopeTest methodsFor: 'running' stamp: ''!
scopeClass
	self subclassResponsibility! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testConvertingAsRestrictedByAnotherScope2
	| convertedScope restrictedScope |
	scope := self singleScopeSample.
	restrictedScope := self multipleScopeSample.
	
	convertedScope := scope restrictedBy: restrictedScope.
	
	self assert: convertedScope class equals: scope class.
	self assert: convertedScope basisObjects equals: restrictedScope basisObjects.! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testConvertingAsRestrictedByAnotherScope
	| convertedScope restrictedScope |
	scope := self multipleScopeSample.
	restrictedScope := self singleScopeSample.
	
	convertedScope := scope restrictedBy: restrictedScope.
	
	self assert: convertedScope class equals: scope class.
	self assert: convertedScope basisObjects equals: restrictedScope basisObjects.! !

!ClyTypedScopeTest methodsFor: 'running' stamp: ''!
singleBasisSample
	self subclassResponsibility! !

!ClyTypedScopeTest methodsFor: 'running' stamp: ''!
extraBasisSample
	self subclassResponsibility! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testConvertingWithExtraBasisObjects
	| convertedScope |
	scope := self singleScopeSample.
	
	convertedScope := scope withExtraBasisObjects: {self singleBasisSample. self extraBasisSample}.
	
	self assert: convertedScope class equals: scope class.
	self assert: (convertedScope basisObjects asIdentitySet includesAll: scope basisObjects).
	self assert: (convertedScope basisObjects asIdentitySet includes: self extraBasisSample).
	self assert: convertedScope basisSize equals: scope basisSize + 1 "should skip existing basis"! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testConvertingWithoutAbsentBasisObject
	| convertedScope |
	scope := self createSampleScope.
	
	convertedScope := scope withoutBasisObject: #notExistedBasis.
	
	self assert: convertedScope class equals: scope class.
	self assert: convertedScope basisObjects equals: scope basisObjects! !

!ClyTypedScopeTest methodsFor: 'running' stamp: ''!
createSampleScope
	^self multipleScopeSample! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewBasisObjects
	| convertedScope |
	scope := self singleScopeSample.
	
	convertedScope := scope withNewBasisObjects: {self extraBasisSample}.
	
	self assert: convertedScope class equals: scope class.
	self 
		assert: convertedScope basisObjects asSet 
		equals: {self extraBasisSample} asSet.
	self assert: convertedScope basisSize equals: 1.
	self assert: convertedScope environment notNil.
	self assert: convertedScope environment equals: environment! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testConvertingWithExtraBasisObject
	| convertedScope |
	scope := self singleScopeSample.
	
	convertedScope := scope withExtraBasisObject: self extraBasisSample.
	
	self assert: convertedScope class equals: scope class.
	self assert: (convertedScope basisObjects includesAll: scope basisObjects).
	self assert: (convertedScope basisObjects includes: self extraBasisSample).
	self assert: convertedScope basisSize equals: scope basisSize + 1! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testCreationUnifiedInstance

	| unifiedInstance |
	scope := self multipleScopeSample.
	unifiedInstance := scope asUnifiedInstance.
	
	self assert: unifiedInstance class equals: scope class.
	self assert: unifiedInstance environment equals: environment.
	self assert: unifiedInstance basisObjects isEmpty! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testBasedOnMultipleBasis

	scope := self multipleScopeSample.
	self assert: scope isBasedOnMultipleBasis.

	scope := self singleScopeSample.
	self deny: scope isBasedOnMultipleBasis.
		
	scope := self emptyScopeSample.
	self deny: scope isBasedOnMultipleBasis! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testCreationOnBasisObjects

	| expectedBasis |
	scope := self createSampleScope.
	expectedBasis := scope prepareBasisFrom: scope basisObjects.
	self assert: scope basisObjects equals: expectedBasis! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testBasedOnBasisObject

	scope := self createSampleScope.

	self assert: (scope isBasedOn: scope basisObjects anyOne).
	self deny: (scope isBasedOn: #anotherObject)! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testConvertingWithoutExistingBasisObject
	| convertedScope |
	scope := self multipleScopeSample.
	
	convertedScope := scope withoutBasisObject: self extraBasisSample.
	
	self assert: convertedScope class equals: scope class.
	self deny: (convertedScope basisObjects includes: self extraBasisSample).
	self assert: (convertedScope basisObjects includes: self singleBasisSample).! !

!ClyTypedScopeTest methodsFor: 'running' stamp: ''!
emptyScopeSample
	^ self scopeClass emptyIn: environment! !

!ClyTypedScopeTest methodsFor: 'tests' stamp: ''!
testConvertingWithoutBasisObjectsWhenSomeIsNotExist
	| convertedScope |
	scope := self createSampleScope.
	
	convertedScope := scope withoutBasisObjects: {#absentObject. scope basisObjects anyOne}.
	
	self assert: convertedScope class equals: scope class.
	self deny: (convertedScope basisObjects includes: scope basisObjects anyOne).! !

!ClyTypedScopeTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyTypedScopeTest! !

!ClyUnclassifiedMethodGroupProvider commentStamp: ''!
I provide unclassified method group!
!ClyUnclassifiedMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyUnclassifiedMethodsQuery from: aClassScope! !

!ClyUnclassifiedMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
		
	^ClyNoTagMethodGroup withMethodsFrom: aMethodQuery! !

!ClyUnclassifiedMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyUnclassifiedMethodGroupProvider! !

!ClyUnclassifiedMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	^ClySubclassN1OfClass1FromP1Mock! !

!ClyUnclassifiedMethodsQuery commentStamp: ''!
I return all unclassified methods.!
!ClyUnclassifiedMethodsQuery methodsFor: 'testing' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	^aSystemAnnouncement affectsMethods
		and: [ scope includesMethodsAffectedBy: aSystemAnnouncement]! !

!ClyUnclassifiedMethodsQuery methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph label color: Color red! !

!ClyUnclassifiedMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^aMethod tags isEmpty! !

!ClyUnclassifiedMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'unclassified methods'! !

!ClyUnclassifiedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope:(ClyMethodScope
		of: ClyClass2FromP1Mock >> #instanceSideClassVar1Reader in: environment).
	self deny: query checkEmptyResult.

	query scope:	(ClyMethodScope of: ClyClass1FromP1Mock >> #tag1Method1 in: environment).
	self assert: query checkEmptyResult! !

!ClyUnclassifiedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyClass1FromP1Mock >> #tag1Method1. Object >> #printString. 
		ClyClass2FromP1Mock >> #instanceSideClassVar1Reader}.
	
	self assert: foundSelectors equals: #(instanceSideClassVar1Reader)! !

!ClyUnclassifiedMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyUnclassifiedMethodsQuery
		from: (ClyClassScope of: ClyClass1FromP1Mock in: environment)! !

!ClyUncommentedItemTableDecorator commentStamp: ''!
I decorate table with special icon for classes which has no comment.

I add this icon as an extra tool of table cell. So it do not override and do not overridden by other decorators.!
!ClyUncommentedItemTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem! !

!ClyUncommentedItemTableDecorator class methodsFor: 'decoration' stamp: ''!
decorationStrategy
	<classAnnotation>
	
	^ClyTableDecorationStrategyAnnotation for: ClyClass asCalypsoItemContext! !

!ClyUncommentedItemTableDecorator class methodsFor: 'decoration' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	^aDataSourceItem isMarkedWith: ClyNoCommentTag! !

!ClyUncommentedItemTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateMainTableCell: anItemCellMorph of: aDataSourceItem
	| noCommentWarn |
	super decorateMainTableCell: anItemCellMorph of: aDataSourceItem.
	
	noCommentWarn := anItemCellMorph addExtraIcon: #uncommentedClass.
	noCommentWarn setBalloonText: 'There is no comment!!'! !

!ClyUndeclaredEnvironmentPlugin commentStamp: ''!
I am special plugin which decorate methods which use undeclared variables
Also I provide "undeclared" method group to see all such methods together!
!ClyUndeclaredEnvironmentPlugin methodsFor: 'method groups' stamp: ''!
collectMethodGroupProviders
	^{ClyUndeclaredMethodGroupProvider new}! !

!ClyUndeclaredEnvironmentPlugin methodsFor: 'item decoration' stamp: ''!
decorateBrowserItem: anItem ofMethod: aMethod

	aMethod usesUndeclareds ifTrue: [ 
		anItem markWith: ClyUndeclaresUserTag]! !

!ClyUndeclaredMethodGroupProvider commentStamp: ''!
I provide "undeclared" method group when classes include any method which uses undeclared variable!
!ClyUndeclaredMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyUndeclaredMethodsQuery from: aClassScope! !

!ClyUndeclaredMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'undeclared' priority: 8.4 on: aMethodQuery! !

!ClyUndeclaredMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyUndeclaredMethodGroupProvider! !

!ClyUndeclaredMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup

	^ClyClassWithUndeclares! !

!ClyUndeclaredMethodTableDecorator commentStamp: ''!
I decorate table items with red font for methods which use undeclared variables!
!ClyUndeclaredMethodTableDecorator class methodsFor: 'decoration' stamp: ''!
decorateTableCell: anItemCellMorph of: aDataSourceItem
	| nameMorph |

	nameMorph := anItemCellMorph label.
	nameMorph color: Color red! !

!ClyUndeclaredMethodTableDecorator class methodsFor: 'testing' stamp: ''!
wantsDecorateTableCellOf: aDataSourceItem
	^aDataSourceItem isMarkedWith: ClyUndeclaresUserTag! !

!ClyUndeclaredMethodsQuery commentStamp: ''!
I return all methods which use undeclared variables!
!ClyUndeclaredMethodsQuery methodsFor: '*Calypso-SystemPlugins-Undeclared-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph label color: Color red.
	anItemCellMorph definitionIcon: #smallDebug! !

!ClyUndeclaredMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	^aMethod usesUndeclareds! !

!ClyUndeclaredMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'methods with undeclared variables'! !

!ClyUndeclaredMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsMethodWhichHasNoUndeclares
	
	self deny: (query selectsMethod: Object >> #printString)! !

!ClyUndeclaredMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsClassSideMethodWhichReturnesFloat

	self deny: (query selectsMethod: ClyClassWithUndeclares class>>#withFloatReturn)! !

!ClyUndeclaredMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope
		of: ClyClassWithUndeclares >> #method1WithUndeclares in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope of: Object >> #printString in: environment).
	self assert: query checkEmptyResult! !

!ClyUndeclaredMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeMethods

	self queryFromScope: ClyMethodScope ofAll: {
		ClyClassWithUndeclares >> #method1WithUndeclares. 
		ClyClassWithUndeclares >> #method2WithUndeclares.
		Object >> #printString}.
	
	self assert: foundSelectors sorted asArray equals: #(method1WithUndeclares method2WithUndeclares)! !

!ClyUndeclaredMethodsQueryTest methodsFor: 'tests' stamp: ''!
testSelectsMethodWhichUsesUndeclares
	
	self assert: (query selectsMethod: ClyClassWithUndeclares >> #method1WithUndeclares)! !

!ClyUndeclaredMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyUndeclaredMethodsQuery
		from: (ClyClassScope of: ClyClassWithUndeclares in: environment)! !

!ClyUndeclaresUserTag commentStamp: ''!
I mark methods which use undeclared variables!
!ClyUnimplementedMethodsQuery commentStamp: ''!
I return all abstract methods inherited by classes in my scope which are still not implemented by them!
!ClyUnimplementedMethodsQuery methodsFor: 'testing' stamp: ''!
isClass: aClass shouldImplement: aSelector

	| inheritedMethod |
	aClass isRootInEnvironment ifTrue: [ ^false].
	
	inheritedMethod := aClass superclass lookupSelector: aSelector.
	inheritedMethod ifNil: [ ^false ].
	
	^self isAbstractMethod: inheritedMethod! !

!ClyUnimplementedMethodsQuery methodsFor: 'execution' stamp: ''!
methodsToImplementIn: aClass
	| result implementor |
	(self doesClassDefinedAsAbstract: aClass) ifTrue: [ ^#()].
		
	result := OrderedCollection new.
	aClass allSuperclassesDo: [ :superclass | 
		superclass == Object ifTrue: [ ^result ].

		self withAbstractMethodsOf: superclass do: [ :abstractMethod |  
			implementor := aClass lookupSelector: abstractMethod selector.
			implementor == abstractMethod ifTrue: [ result add: implementor ]]			
	].	
	^result! !

!ClyUnimplementedMethodsQuery methodsFor: 'testing' stamp: ''!
isAffectedByChangedMethod: aMethod
	| methodClass selector |
	selector := aMethod selector.
	methodClass := aMethod origin.
	
	(self isFromScopeWithClassKindOf: methodClass) ifFalse: [ ^false ].
	
	^(self isAbstractMethod: aMethod) or: [self isClass: methodClass shouldImplement: selector]! !

!ClyUnimplementedMethodsQuery methodsFor: 'execution' stamp: ''!
withAbstractMethodsOf: aClass do: aBlock

	aClass localMethods 
		select: [ :each | self isAbstractMethod: each ]
		thenDo: aBlock! !

!ClyUnimplementedMethodsQuery methodsFor: '*Calypso-SystemPlugins-InheritanceAnalysis-Browser' stamp: ''!
decorateMethodGroupTableCell: anItemCellMorph of: groupItem
	super decorateMethodGroupTableCell: anItemCellMorph of: groupItem.
	
	anItemCellMorph label color: Color red! !

!ClyUnimplementedMethodsQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	
	| methods |
	methods := OrderedCollection new.
	
	scope classesDo: [ :eachClass | 
		methods addAll: (self methodsToImplementIn: eachClass)].
	
	aQueryResult fillWith: methods! !

!ClyUnimplementedMethodsQuery methodsFor: 'printing' stamp: ''!
description

	^'unimplemented methods'! !

!ClyUnimplementedMethodsQuery methodsFor: 'testing' stamp: ''!
isAbstractMethod: aMethod
	^aMethod sendsSelector: #subclassResponsibility! !

!ClyUnimplementedMethodsQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod

	| selector |
	selector := aMethod selector.
	
	scope classesDo: [:eachClass | 
		((self isClass: eachClass shouldImplement: selector) 
			and: [(eachClass includesSelector: selector) not])
				ifTrue: [ ^true ]].
	^false! !

!ClyUnimplementedMethodsQuery methodsFor: 'testing' stamp: ''!
doesClassDefinedAsAbstract: aClass
	^(aClass classSide includesLocalSelector: #isAbstract) and: [aClass instanceSide isAbstract]! !

!ClyUnimplementedMethodsQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult

	scope classesDo: [ :eachClass |
		(self isClassHasToBeImplemented: eachClass) ifTrue: [ ^false ]].
	^true! !

!ClyUnimplementedMethodsQuery methodsFor: 'testing' stamp: ''!
isClassHasToBeImplemented: aClass
	(self doesClassDefinedAsAbstract: aClass) ifTrue: [ ^false].
	
	aClass allSuperclassesDo: [ :superclass | 
		superclass == Object ifTrue: [ ^false ].
		
		self withAbstractMethodsOf: superclass do: [:abstractMethod | | implementor |
			implementor := aClass lookupSelector: abstractMethod selector.
			implementor == abstractMethod ifTrue: [ ^true]]].
	
	^false! !

!ClyUnimplementedMethodsQuery class methodsFor: '*Calypso-SystemPlugins-InheritanceAnalysis-Browser' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem
	
	anItemCellMorph label color: Color red! !

!ClyUnimplementedMethodsQuery class methodsFor: 'accessing' stamp: ''!
priority
	^8.5! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsEmptyFromEmptyMethodScope
	"This query only supports class, package and global scopes
	because it analyses classes and only then methods"
	<expectedFailure>
	super testIsEmptyFromEmptyMethodScope! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsAbstractMethodWhichIsImplemented
	
	self deny: (query selectsMethod: ClyAbstractClassMock >> #abstractMethod1)! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testSelectsAbstractMethodWhichIsNotImplemented

	self assert: (query selectsMethod: ClyAbstractClassMock>>#abstractMethod2).
	self assert: (query selectsMethod: ClyAbstractSubclassMock>>#abstractSubclassMethod)! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsAffectedByChangeOfAbstractMethodWhichIsImplemented
	
	self assert: (query isAffectedByChangedMethod: ClyAbstractClassMock >> #abstractMethod1)! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testFromSingleClass

	self executeQuery.
	
	self assert: foundSelectors equals: #(abstractMethod2 abstractSubclassMethod)! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsAffectedByChangeOfMethodOfTargetClassWhichOverridesAbstractOne
	query scope: (ClyClassScope	of: ClyClassWhichInheritsAbstractClassMock in: environment).
		
	self assert: (query isAffectedByChangedMethod: ClyClassWhichInheritsAbstractClassMock >> #abstractMethod1)! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyClassScope of: ClyAbstractSubclassMock in: environment).
	self deny: query checkEmptyResult.	"it has unimplemented #abstractMethod2"

	query scope: (ClyClassScope of: ClyAbstractClassMock in: environment).
	self assert: query checkEmptyResult! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsEmptyFromEmptyClassScope
	query scope: (ClyClassScope emptyIn: environment).
	
	self assert: query checkEmptyResult! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsEmptyForExplicitlyDefinedAbstractMetaclass

	query scope: (ClyClassScope of: ClyExplicitAbstractClassExampleMock class in: environment).

	self assert: query checkEmptyResult.
	
	self executeQuery.
	
	self assert: foundSelectors isEmpty! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotAffectedByChangeOfNotAbstractMethod
	query scope: (ClyClassScope of: ClyClassWhichInheritsAbstractClassMock in: environment).
	
	self deny: (query isAffectedByChangedMethod: ClyClassWhichInheritsAbstractClassMock >> #notOverriddenMethod)! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testNotAffectedByChangeOfAbstractMethodOfNotRelatedClass
	
	self deny: (query isAffectedByChangedMethod: self class >> #createQuery)! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsAffectedByChangeOfAbstractMethodWhichIsNotImplemented
	
	self assert: (query isAffectedByChangedMethod: ClyAbstractClassMock>>#abstractMethod2).
	self assert: (query isAffectedByChangedMethod: ClyAbstractSubclassMock>>#abstractSubclassMethod)! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyUnimplementedMethodsQuery 
		from: ClyClassScope 
		of: ClyClassWhichInheritsAbstractSubclassMock
		in: environment! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsAffectedByChangeOfNotAbstractMethodWhichImplementsAbstractOne
	
	self assert: (query isAffectedByChangedMethod: ClyAbstractSubclassMock >> #abstractMethod1)! !

!ClyUnimplementedMethodsQueryTest methodsFor: 'tests' stamp: ''!
testIsEmptyForExplicitlyDefinedAbstractClass

	query scope: (ClyClassScope of: ClyExplicitAbstractClassExampleMock in: environment).

	self assert: query checkEmptyResult.
	
	self executeQuery.
	
	self assert: foundSelectors isEmpty! !

!ClyUninstallMetaLinkCommand commentStamp: ''!
I am a copy of class ClyInstallMetaLinkCommand. This comment is copied from there, and might not be entirely accurate

I am a command to install metalinks on the selected method or one of its ast nodes.
I open a small browser to choose which metalink to install among existing metalink instances.!
!ClyUninstallMetaLinkCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Uninstall MetaLink...'! !

!ClyUninstallMetaLinkCommand methodsFor: 'execution' stamp: ''!
execute
	ClyMetaLinkInstallationPresenter openUninstallerOnNode: sourceNode! !

!ClyUninstallMetaLinkCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallObjects! !

!ClyUninstallMetaLinkCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder
	^101! !

!ClyUnionQuery commentStamp: ''!
I am a union of subqueries.
I execute all subqueries and merge result items into single result instance.

My subqueries must be a kind of ClyTypedQuery. And I implement union logic to ensure this invariant.
During instance creation I try unify all subqueries. And in some cases the result query can be single type query instead of my instance.
For example:

	ClyUnionQuery with: { 
		ClyMessageSenders of: #(do:) from: (ClyClassScope of: Object in: environment). 
		ClyMessageSenders of: #(do:) from: (ClyClassScope of: String in: environment). 
	} 

It will return single senders query: 

	ClyMessageSenders of: #(do:) from: (ClyClassScope ofAll: {Object. String} in: environment).

But in general case the result union query will be return with subset of given queries with merged scope.

General query concatination using comma message produced my instances. Previous example can be rewritten as: 

	(ClyMessageSenders of: #(do:) from: (ClyClassScope of: Object in: environment))
		, (ClyMessageSenders of: #(do:) from: (ClyClassScope of: String in: environment))

!
!ClyUnionQuery methodsFor: 'composition' stamp: ''!
unionWith: typedQueries as: aQueryResult

	^ClyQuery unionFrom: (typedQueries , subqueries) as: aQueryResult! !

!ClyUnionQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	
	| subResult allItems |
	allItems := subqueries flatCollect: [ :each | 
		subResult := each execute.
		subResult items].
	
	aQueryResult fillWith: allItems asIdentitySet! !

!ClyUnionQuery methodsFor: 'composition' stamp: ''!
, anotherQuery
	^ anotherQuery unionWith: subqueries as: requiredResult! !

!ClyUnionQuery class methodsFor: 'merging queries' stamp: ''!
mergeOwnInstances: queries
	
	| allSubqueries |
	allSubqueries := queries flatCollect: [ :each | each subqueries ].
	^self merge: allSubqueries! !

!ClyUnionQuery class methodsFor: 'instance creation' stamp: ''!
with: subqueries
	| mergedQueries |
	subqueries ifEmpty: [ ^ClyUnknownQuery instance ].
	
	mergedQueries := self merge: subqueries.
	mergedQueries size = 1 ifTrue: [ ^mergedQueries anyOne copy].
	
	^(super with: mergedQueries)
		requiredResult: subqueries anyOne requiredResult! !

!ClyUnionQuery class methodsFor: 'merging queries' stamp: ''!
merge: queries
	| result queryGroups |
	queries size = 1 ifTrue: [ ^{queries anyOne} ].
	
	result := OrderedCollection new.
	queryGroups := queries groupedBy: [ :each | each class ].
	queryGroups keysAndValuesDo: [ :queryClass :groupedQueries | 
		result addAll: (queryClass mergeOwnInstances: groupedQueries)].
	
	^result! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testIsEmptyWhenAllSubqueriesAreEmpty
	query subqueries: {
		(self subqueryFromScope: ClyExampleScope empty).
		(self subqueryFromScope: ClyExample2Scope empty)
	}.
	
	self assert: query checkEmptyResult! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testCreationFromTwoUnionQueries
	| subquery1 subquery2 subquery3 subquery4 unionQuery1 unionQuery2 scopes |
	subquery1 := self subqueryFromScope: ClyExampleScope of: Array.
	subquery2 := self subqueryFromScope: ClyExample2Scope of: String.
	subquery3 := self subqueryFromScope: ClyExampleScope of: Object.
	subquery4 := self subqueryFromScope: ClyExample2Scope of: Class.

	unionQuery1 := subquery1 , subquery2.
	unionQuery2 := subquery3 , subquery4.
	query := unionQuery1 , unionQuery2.

	self assert: query class equals: self queryClass.
	self assert: query subqueries size equals: 2.
	self assert: (query subqueries collect: #class as: Set) equals: {subquery1 class} asSet.
	scopes := query subqueries collect: #scope as: Set.
	self assert: scopes equals: {(ClyExampleScope ofAll: {Array . Object}) . (ClyExample2Scope ofAll: {String . Class})} asSet.
	self assert: query requiredResult identicalTo: subquery1 requiredResult! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewScopeWhenAllSubqueriesAreSameKind
	| newScope convertedQuery |
	query subqueries: {(self subqueryFromScope: ClyExampleScope of: Array) . (self subqueryFromScope: ClyExample2Scope of: String)}.
	newScope := ClyExample2Scope of: #someBasis in: environment.
	convertedQuery := query withScope: newScope.
	self assert: convertedQuery class equals: query subqueries anyOne class.
	self assert: convertedQuery scope equals: newScope.
	self assert: convertedQuery requiredResult identicalTo: query requiredResult! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testCreationFromAnotherCompositeQueryAndSimilarQuery

	| subquery1 subquery2 subquery3 |
	subquery1 := self subqueryFromScopeOf: Array.
	subquery2 := self subqueryFromScope: ClyExample2Scope of: String.
	subquery3 := self subqueryFromScopeOf: Object.	
		
	query := subquery1, subquery2, subquery3.
	
	self assert: query class equals: self queryClass.
	self assert: query subqueries equals: { 
		self subqueryFromScope: (ClyExampleScope ofAll: { Array. Object }). subquery2} asSet.
	self assert: query requiredResult equals: subquery1 requiredResult! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testCreationFromTwoQueriesOfSameTypeAndScopeButWithDifferentParameter
	| subquery1 subquery2 |
	subquery1 := self subqueryFromScopeOf: Array.
	subquery1 extraParameter: #testParameter.
	subquery2 := self subqueryFromScopeOf: Array.
	subquery2 extraParameter: #testParameter2.
	query := subquery1 , subquery2.

	self assert: query class equals: self queryClass.
	self assert: query subqueries equals: {subquery1 . subquery2} asSet.
	self assert: query requiredResult identicalTo: subquery1 requiredResult! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testNotEmptyWhenThereIsNotEmptySubquery
	query subqueries: {
		(self subqueryFromScope: ClyExampleScope empty).
		(self subqueryFromScope: ClyExample2Scope of: self class superclass)
	}.
	
	self deny: query checkEmptyResult! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testCreationFromTwoQueriesOfSameTypeButDifferentScope
	| subquery1 subquery2 |
	subquery1 := self subqueryFromScope: ClyExampleScope of: Array.
	subquery2 := self subqueryFromScope: ClyExample2Scope of: String.

	query := subquery1 , subquery2.

	self assert: query class equals: self queryClass.
	self assert: query subqueries asSet equals: {subquery1 . subquery2} asSet.
	self assert: query requiredResult identicalTo: subquery1 requiredResult! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testExecution

	query subqueries: { 
		self subqueryFromScope: ClyExampleScope of: self class.
		self subqueryFromScope: ClyExample2Scope of: self class superclass.
	}.
	self executeQuery.
	
	self assert: resultItems size equals: 2.
	self assert: resultItems asSet equals: {self class. self class superclass} asSet! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testCreationFromTwoSameQueriesOfSameScopeButWithDifferentParameter
	| subquery1 subquery2 |
	subquery1 := self subqueryFromScopeOf: Array.
	subquery1 scope extraParameter: #testParameter.
	subquery2 := self subqueryFromScopeOf: Array.
	subquery2 scope extraParameter: #testParameter2.
	query := subquery1 , subquery2.

	self assert: query class equals: self queryClass.
	self assert: query subqueries equals: {subquery1 . subquery2} asSet.
	self assert: query requiredResult identicalTo: subquery1 requiredResult! !

!ClyUnionQueryTest methodsFor: 'running' stamp: ''!
queryClass
	^ClyUnionQuery! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testCreationWithSingleSubquery
	| subquery |
	subquery := self subqueryFromScopeOf: Array.

	query := ClyUnionQuery with: {subquery}.

	self assert: query equals: subquery.
	self deny: query identicalTo: subquery! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testCreationWithSingleSubqueryButAnotherResult
	| subquery |
	subquery := self subqueryFromScopeOf: Array.

	query := ClyUnionQuery with: {subquery} as: #specialResult.

	self assert: query class equals: subquery class.
	self assert: query scope equals: subquery scope.
	self assert: query requiredResult equals: #specialResult.
	self deny: subquery requiredResult equals: #specialResult! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testCreationFromAnotherCompositeQueryAndNewDifferentSubquery

	| subquery1 subquery2 subquery3 |
	subquery1 := self subqueryFromScope: ClyExampleScope of: Array.
	subquery2 := self subqueryFromScope: ClyExample2Scope of: String.
	subquery3 := ClyReturningScopeBasis2ExampleQuery from: ClyExampleScope of: Object in: environment.
	
	query := subquery1, subquery2, subquery3.
	
	self assert: query class equals: ClyUnionQuery.
	self assert: query subqueries equals: {subquery1. subquery2. subquery3} asSet.
	self assert: query requiredResult equals: subquery1 requiredResult! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testExecutionShouldRemoveDuplication

	query subqueries: { 
		self subqueryFromScope: ClyExampleScope of: self class.
		self subqueryFromScope: ClyExample2Scope of: self class.
	}.
	self executeQuery.
	
	self assert: resultItems asArray equals: {self class }! !

!ClyUnionQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyUnionQuery with: { 
		ClyReturningScopeBasisExampleQuery from: ClyExampleScope of: self class in: environment.
		ClyReturningScopeBasis2ExampleQuery from: ClyExample2Scope of: self class superclass in: environment}! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testCreationFromTwoDifferentTypedQueries
	| subquery1 subquery2 |
	subquery1 := ClyReturningScopeBasisExampleQuery from: ClyExampleScope of: Array in: environment.
	subquery2 := ClyReturningScopeBasis2ExampleQuery from: ClyExampleScope of: String in: environment.

	query := subquery1 , subquery2.

	self assert: query class equals: self queryClass.
	self assert: query subqueries equals: {subquery1 . subquery2} asSet.
	self assert: query requiredResult identicalTo: subquery1 requiredResult! !

!ClyUnionQueryTest methodsFor: '*Calypso-SystemQueries-Tests' stamp: ''!
testConvertingToNewMetaLevel
	| newQuery scopes |
	query
		subqueries:
			{(ClyAllMethodGroupsQuery from: ClyClassScope of: Object in: environment).
			(ClyAllMethodGroupsQuery from: ClySubclassScope of: Array in: environment)}.

	newQuery := query withMetaLevelScope: ClyInstanceSideScope.
	self assert: newQuery class equals: self queryClass.
	self assert: (newQuery subqueries collect: [:each | each class]) equals: (query subqueries collect: [:each | each class]).
	self assert: newQuery requiredResult identicalTo: query requiredResult.
	scopes := newQuery subqueries collect: [ :each | each scope ] as: Set.
	self assert: scopes equals: {(ClyInstanceSideScope of: Object) . (ClySubclassScope of: Array localScope: ClyInstanceSideScope)} asSet! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testEmptySubqueriesAreForbidden

	[query subqueries: {}.
	self assert: false description: 'empty subqueries should be forbidden'] onErrorDo: [].! !

!ClyUnionQueryTest methodsFor: 'tests' stamp: ''!
testCreationFromTwoQueriesOfSameTypeSimilarScope
	| subquery1 subquery2 |
	subquery1 := self subqueryFromScope: ClyExampleScope of: Array.
	subquery2 := self subqueryFromScope: (ClyExampleScope ofAll: {String . Array}).

	query := subquery1 , subquery2.

	self assert: query class equals: subquery1 class.
	self deny: query identicalTo: subquery1.
	self assert: query scope equals: (ClyExampleScope ofAll: {Array . String} in: environment).
	self assert: query requiredResult identicalTo: subquery1 requiredResult! !

!ClyUnknownBrowserContext commentStamp: ''!
I represent undefined browser context. 
I usually used as a stub in cases when context is not found or is not implemented for required places in the browser.
Many browser extensions are defined for the specific context. And I allow to ignore all of them when given part of browser do not reifies real context!
!ClyUnknownQuery commentStamp: ''!
I am special kind of query which implements NULL pattern.

I always return empty array as result and for any convertion methods I return myself.
Users should use my singleton #instance defined in class side: 	
	
	ClyUnknownQuery instance 

I am used as default query in Calypso-Browser widgets!
!ClyUnknownQuery methodsFor: 'item group decoration' stamp: ''!
decorateItemGroup: groupItem! !

!ClyUnknownQuery methodsFor: 'converting' stamp: ''!
asUnifiedInstance
	^self! !

!ClyUnknownQuery methodsFor: 'initialization' stamp: ''!
defaultResult
	^ClyUnknownQueryResult instance! !

!ClyUnknownQuery methodsFor: 'testing' stamp: ''!
retrievesItemsOfType: itemTypeClass 
	^false! !

!ClyUnknownQuery methodsFor: 'testing' stamp: ''!
executesQuery: aClass 
	^false! !

!ClyUnknownQuery methodsFor: 'execution' stamp: ''!
checkEmptyResult
	^true! !

!ClyUnknownQuery class methodsFor: 'merging queries' stamp: ''!
mergeOwnInstances: queries
	^queries anyOne! !

!ClyUnknownQuery class methodsFor: 'accessing' stamp: ''!
instance
	^instance ifNil: [ instance := ClyUnknownQuery new ]! !

!ClyUnknownQuery class methodsFor: 'class initialization' stamp: ''!
reset
	instance := nil! !

!ClyUnknownQueryResult commentStamp: ''!
I implement null pattern for query result.

Users should use my singleton #instance on class side: 

	ClyUnknownQueryResult instance!
!ClyUnknownQueryResult methodsFor: 'building' stamp: ''!
forceRebuild! !

!ClyUnknownQueryResult methodsFor: 'system changes' stamp: ''!
itemsChanged! !

!ClyUnknownQueryResult methodsFor: 'system changes' stamp: ''!
subscribe: anObject! !

!ClyUnknownQueryResult methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	needsRebuild := false.
	self initializeItems.
	self collectMetadata! !

!ClyUnknownQueryResult methodsFor: 'queries' stamp: ''!
findItemsSimilarTo: sampleEnvironmentItems
	^#()! !

!ClyUnknownQueryResult methodsFor: 'private' stamp: ''!
beProtected! !

!ClyUnknownQueryResult methodsFor: 'private' stamp: ''!
protectAccessWhile: aBlock
	^aBlock value! !

!ClyUnknownQueryResult methodsFor: 'system changes' stamp: ''!
unsubscribe: anObject! !

!ClyUnknownQueryResult methodsFor: 'accessing' stamp: ''!
adoptForBrowser
	^self! !

!ClyUnknownQueryResult methodsFor: 'queries' stamp: ''!
itemsStartingAt: startIndex count: size
	^#()! !

!ClyUnknownQueryResult methodsFor: 'queries' stamp: ''!
findItemsWith: aCollection 
	^Array new: aCollection size withAll: nil! !

!ClyUnknownQueryResult methodsFor: 'building' stamp: ''!
forceLazyRebuild! !

!ClyUnknownQueryResult methodsFor: 'initialization' stamp: ''!
collectMetadata
	metadata := ClyQueryResultMetadata new! !

!ClyUnknownQueryResult methodsFor: 'initialization' stamp: ''!
defaultItems
	^#()! !

!ClyUnknownQueryResult methodsFor: 'building' stamp: ''!
fillWith: objects! !

!ClyUnknownQueryResult class methodsFor: 'singleton' stamp: ''!
instance
	^instance ifNil: [instance := ClyUnknownQueryResult new]! !

!ClyUnknownQueryTest methodsFor: 'tests' stamp: ''!
testGettingSingletonInstanceFromScratch
	ClyUnknownQuery reset.

	self assert: ClyUnknownQuery instance identicalTo: ClyUnknownQuery instance! !

!ClyUnknownQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty

	self assert: query hasEmptyResult.
	self assert: query checkEmptyResult! !

!ClyUnknownQueryTest methodsFor: 'tests' stamp: ''!
testExecution
	self executeQuery.

	self assert: result identicalTo: ClyUnknownQueryResult instance.
	self assert: resultItems equals: #()! !

!ClyUnknownQueryTest methodsFor: 'tests' stamp: ''!
testCreationUnifiedInstance
	self assert: query asUnifiedInstance identicalTo: query! !

!ClyUnknownQueryTest methodsFor: 'tests' stamp: ''!
testHasUnknownResultInstance
	self assert: query requiredResult identicalTo: ClyUnknownQueryResult instance! !

!ClyUnknownQueryTest methodsFor: 'tests' stamp: ''!
testDoesNotExecuteAnyQuery
	
	self deny: (query executesQuery: #any)! !

!ClyUnknownQueryTest methodsFor: 'tests' stamp: ''!
testIsBoundToEnvironmentWhenScopeIs
	<expectedFailure>
	"Unknown query is never bound to the environment"
	super testIsBoundToEnvironmentWhenScopeIs! !

!ClyUnknownQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ClyUnknownQuery new! !

!ClyUnknownQueryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	"Unknown query is always bound to unknown scope which have no environment"
	environment := nil! !

!ClyUnknownScope commentStamp: ''!
I am kind of null object for environment scope.

I am default scope of any query. I provide #instance singleton for this.

Also I prevent real execution of query by returning ClyUnknownResult instance from #query method. 
So environment is not requested to evaluate given query when query is bound to me.!
!ClyUnknownScope methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	basisObjects := #()! !

!ClyUnknownScope methodsFor: 'queries' stamp: ''!
adoptQuery: aQuery 
	^aQuery! !

!ClyUnknownScope methodsFor: 'queries' stamp: ''!
query: aQuery
	^ClyUnknownQueryResult instance! !

!ClyUnknownScope methodsFor: 'queries' stamp: ''!
asScope: anotherEnvironmentScopeClass

	^self! !

!ClyUnknownScope methodsFor: 'testing' stamp: ''!
isQueryEmpty: aQuery
	^true! !

!ClyUnknownScope methodsFor: 'converting' stamp: ''!
asUnifiedInstance
	^self! !

!ClyUnknownScope methodsFor: 'converting' stamp: ''!
withNewBasisObjects: aCollection 
	^self! !

!ClyUnknownScope methodsFor: 'testing' stamp: ''!
supportsQuery: aQuery
	^true! !

!ClyUnknownScope class methodsFor: 'accessing' stamp: ''!
instance
	^instance ifNil: [ instance := ClyUnknownScope new ]! !

!ClyUnknownScope class methodsFor: 'class initialization' stamp: ''!
reset
	instance := nil! !

!ClyUnknownScopeTest methodsFor: 'tests' stamp: ''!
testGettingSingletonInstanceFromScratch
	ClyUnknownScope reset.

	self assert: ClyUnknownScope instance identicalTo: ClyUnknownScope instance! !

!ClyUnknownScopeTest methodsFor: 'tests' stamp: ''!
testAdoptQuery
	| query adoptedQuery |
	scope := self createSampleScope.
	query := ClyReturningScopeBasisExampleQuery new.

	adoptedQuery := scope adoptQuery: query.

	self assert: adoptedQuery identicalTo: query! !

!ClyUnknownScopeTest methodsFor: 'tests' stamp: ''!
testIsNotBasedOnAnyObject

	scope := self createSampleScope.

	self deny: (scope isBasedOn: #anyObject)! !

!ClyUnknownScopeTest methodsFor: 'running' stamp: ''!
createSampleScope
	^ClyUnknownScope new! !

!ClyUnknownScopeTest methodsFor: 'tests' stamp: ''!
testIsNotBasedOnSingleBasis

	scope := self createSampleScope.

	self deny: scope isBasedOnSingleBasis! !

!ClyUnknownScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToNewBasis
	scope := self createSampleScope.

	self assert: (scope withNewBasisObjects: #(newBasis)) identicalTo: scope.
	self assert: scope basisObjects isEmpty! !

!ClyUnknownScopeTest methodsFor: 'tests' stamp: ''!
testConvertingToAnotherScopeClass
	| convertedScope |
	scope := self createSampleScope.

	convertedScope := scope asScope: ClyExampleScope.

	self assert: convertedScope identicalTo: scope! !

!ClyUnknownScopeTest methodsFor: 'tests' stamp: ''!
testCreationUnifiedInstance
	scope := self createSampleScope.

	self assert: scope asUnifiedInstance identicalTo: scope! !

!ClyUnknownScopeTest methodsFor: 'tests' stamp: ''!
testHasEmptyBasisObjects

	scope := self createSampleScope.

	self assert: scope basisObjects isEmpty! !

!ClyUnknownScopeTest methodsFor: 'tests' stamp: ''!
testIsBasedOnEmptyBasis

	scope := self createSampleScope.

	self assert: scope isBasedOnEmptyBasis! !

!ClyUnknownScopeTest methodsFor: 'tests' stamp: ''!
testIsNotBasedOnMultipleBasis

	scope := self createSampleScope.

	self deny: scope isBasedOnMultipleBasis! !

!ClyUntaggedClassesQuery commentStamp: ''!
I return all classes without any tag!
!ClyUntaggedClassesQuery methodsFor: 'testing' stamp: ''!
selectsClass: aClass
	^aClass tags isEmpty! !

!ClyUntaggedClassesQuery methodsFor: 'printing' stamp: ''!
description

	^'classes without tags'! !

!ClyUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testSelectsClassWithoutTags
	
	self assert: (query selectsClass: ClyClass6UntaggedFromP5Mock)! !

!ClyUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyClassScope of: ClyClass6UntaggedFromP5Mock in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyClassScope of: ClyClass7WithTag1FromP5Mock in: environment).
	self assert: query checkEmptyResult! !

!ClyUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testFromThreeClasses
	
	self queryFromScope: ClyClassScope ofAll: {
		ClyClass7WithTag1FromP5Mock. ClyClass6UntaggedFromP5Mock. ClyClass1FromP1Mock }.

	self assert: resultItems asSet equals: {ClyClass6UntaggedFromP5Mock. ClyClass1FromP1Mock} asSet! !

!ClyUntaggedClassesQueryTest methodsFor: 'tests' stamp: ''!
testNotSelectsTaggedClass
	
	self deny: (query selectsClass: ClyClass7WithTag1FromP5Mock)! !

!ClyUntaggedClassesQueryTest methodsFor: 'running' stamp: ''!
createQuery
	^ ClyUntaggedClassesQuery
		from: (ClyClassScope of: Object in: environment)! !

!ClyUntestedClassMock commentStamp: ''!
I am example of untested class which is not covered by any test!
!ClyUpdateBrowserCommand commentStamp: ''!
I am a command to force full update of all browser views!
!ClyUpdateBrowserCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Update'! !

!ClyUpdateBrowserCommand methodsFor: 'execution' stamp: ''!
execute
	browser update! !

!ClyUpdateBrowserCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallUpdate! !

!ClyUpdateBrowserCommand class methodsFor: 'activations' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClyBrowserContext! !

!ClyVarDefinitionMethodGroup commentStamp: ''!
I am group of methods which reference any instance variable of some class.
I not keep this class directly. All required information is passed to my instance from variables query!
!ClyVarDefinitionMethodGroup methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
decorateTableCell: anItemCellMorph of: groupItem
	| currentFont |
	super decorateTableCell: anItemCellMorph of: groupItem.
	
	currentFont := anItemCellMorph label font.
	anItemCellMorph label font: (LogicalFont familyName: currentFont familyName pointSize: currentFont pointSize - 1).
	
	anItemCellMorph label color: Color gray.! !

!ClyVarDefinitionMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethodsFrom: aClassScope referencedAny: aVariableClass definedIn: definingClass

	| variableQuery |
	variableQuery := aVariableClass queryClass 
		from: (aClassScope asScope: ClyClassScope of: definingClass).
	^self 
		named: definingClass name 
		on: (ClyVariableReferencesQuery from: aClassScope toVariablesFrom: variableQuery)! !

!ClyVariable commentStamp: ''!
I represent variables of class with explicit information about defining class.
I am always created on some actual variable instance like Slot or ClassVariable:

	ClyVariable on: aSlot definedIn: aClass

My subclasses implement three methods:
- isAccessibleFrom: aClass
- isReadIn: aMethod
- isAccessedIn: aMethod

Internal Representation and Key Implementation Points.

    Instance Variables
	actualVariable:		<Slot, ClassVariable>
	declaringClass:		<Class>!
!ClyVariable methodsFor: 'accessing' stamp: ''!
actualVariable: anObject
	actualVariable := anObject! !

!ClyVariable methodsFor: 'operations' stamp: ''!
openInspector

	actualVariable inspect! !

!ClyVariable methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ definingClass = anObject definingClass
		and: [ actualVariable = anObject actualVariable ]! !

!ClyVariable methodsFor: 'accessing' stamp: ''!
definingClass
	^ definingClass! !

!ClyVariable methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ definingClass hash bitXor: actualVariable hash! !

!ClyVariable methodsFor: 'testing' stamp: ''!
isClassVariable
	self subclassResponsibility! !

!ClyVariable methodsFor: 'testing' stamp: ''!
isLive

	^false! !

!ClyVariable methodsFor: 'accessing' stamp: ''!
detectDefiningClassFrom: anUserClass

	self subclassResponsibility! !

!ClyVariable methodsFor: 'testing' stamp: ''!
isReadIn: aMethod
	
	(self isAccessibleFrom: aMethod origin)	ifFalse: [ ^false ].
	
	^actualVariable isReadIn: aMethod! !

!ClyVariable methodsFor: 'testing' stamp: ''!
isWrittenIn: aMethod
	
	(self isAccessibleFrom: aMethod origin)	ifFalse: [ ^false ].
		
	^actualVariable isWrittenIn: aMethod! !

!ClyVariable methodsFor: 'operations' stamp: ''!
openBrowser

	definingClass browse! !

!ClyVariable methodsFor: 'printing' stamp: ''!
printAsConstantQueryItem
	^self name! !

!ClyVariable methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
createVariableRefactoring: variableRefactoringClass 
	^self createRefactoring: variableRefactoringClass for: definingClass! !

!ClyVariable methodsFor: 'accessing' stamp: ''!
actualVariable
	^ actualVariable! !

!ClyVariable methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream 
		nextPut: $(;
		nextPutAll: self name;
		nextPut: $)! !

!ClyVariable methodsFor: 'accessing' stamp: ''!
definingClass: anObject
	definingClass := anObject! !

!ClyVariable methodsFor: 'testing' stamp: ''!
isAccessedIn: aMethod
	
	(self isAccessibleFrom: aMethod origin)	ifFalse: [ ^false ].
		
	^actualVariable isAccessedIn: aMethod! !

!ClyVariable methodsFor: 'accessing' stamp: ''!
name
	^actualVariable name! !

!ClyVariable methodsFor: 'testing' stamp: ''!
isAccessibleFrom: aClass
	self subclassResponsibility! !

!ClyVariable class methodsFor: 'sorting' stamp: ''!
defaultSortFunctionForCalypso
	^ClySortByNameFunction ascending! !

!ClyVariable class methodsFor: 'instance creation' stamp: ''!
on: aVariableOrSlot definedIn: aClass
	^self new 
		actualVariable: aVariableOrSlot;
		definingClass: aClass! !

!ClyVariable class methodsFor: 'queries' stamp: ''!
queryClass
	^ClyAllVariablesQuery! !

!ClyVariable class methodsFor: 'instance creation' stamp: ''!
named: aSymbol definedIn: aClass
	self subclassResponsibility! !

!ClyVariable class methodsFor: 'queries' stamp: ''!
shortName
	^'Vars'! !

!ClyVariable class methodsFor: 'instance creation' stamp: ''!
on: aVariableOrSlot visibleFrom: aClass
	^self new 
		actualVariable: aVariableOrSlot;
		detectDefiningClassFrom: aClass! !

!ClyVariable class methodsFor: 'sorting' stamp: ''!
itemsSortOrderForCalypso 
	^1.2! !

!ClyVariable class methodsFor: 'browser item preparation' stamp: ''!
convertToCalypsoBrowserItem: myItem

	^ClyBrowserItem named: myItem name with: myItem! !

!ClyVariableBreakpointCommand commentStamp: ''!
Commands to install a variable breakpoint on the selected variable in the source code.
If the variable is a temporary, installs the variable breakpoint on all variable nodes refering to that variable name in the method.
If the variable is an intance variable, installs the breakpoint on all methods using the variable.!
!ClyVariableBreakpointCommand methodsFor: 'execution' stamp: ''!
execute
	| methodOrClass |
	sourceNode isVariable
		ifFalse: [ ^ self ].
	methodOrClass := sourceNode isLocalVariable
		ifTrue: [ method ]
		ifFalse: [ method methodClass ].
	self installVariableBreakpointOn: sourceNode name in: methodOrClass! !

!ClyVariableBreakpointCommand methodsFor: 'execution' stamp: ''!
installVariableBreakpointOn: aVariableName in: methodOrClass
	self subclassResponsibility! !

!ClyVariableBreakpointCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallDebug! !

!ClyVariableBreakpointCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aSourceCodeContext
	^ self isAbstract not
		and: [ aSourceCodeContext lastSelectedSourceNode isVariable ]! !

!ClyVariableBreakpointCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == ClyVariableBreakpointCommand! !

!ClyVariableBreakpointCommand class methodsFor: 'activation' stamp: ''!
contextMenuOrder
	^3! !

!ClyVariableMethodGroup commentStamp: ''!
I am group of methods which reference some variable. 

I not keep this variable directly. All required information is passed to my instance from variables query!
!ClyVariableMethodGroup methodsFor: 'accessing' stamp: ''!
variable
	^methodQuery variableQuery resultItems first "it should be always variable"! !

!ClyVariableMethodGroup class methodsFor: 'testing' stamp: ''!
isCalypsoItemType: aClass
	 
	^self = aClass! !

!ClyVariableMethodGroup class methodsFor: 'testing' stamp: ''!
isEditableGroup
	^true! !

!ClyVariableMethodGroup class methodsFor: 'instance creation' stamp: ''!
withMethodsFrom: aClassScope referencedVar: aVariable
	^self 
		named: aVariable name 
		on: (ClyVariableReferencesQuery of: aVariable from: aClassScope)! !

!ClyVariableQuery commentStamp: ''!
I am abstract query of all variables from given scope.

I only implement method related to the retrieved items type.
So my subclasses still should implement main query methods.

And I provide extra convertation method to get similar query but from different meta level class scope:
	
	aVariableQuery withMetaLevelScope: ClyInstanceSideScope!
!ClyVariableQuery methodsFor: 'execution' stamp: ''!
collectMetadataOf: aQueryResult by: anEnvironmentPlugin
	self flag: #todo! !

!ClyVariableQuery methodsFor: 'system changes' stamp: ''!
isResult: aQueryResult affectedBy: aSystemAnnouncement
	
	^scope includesVariablesAffectedBy: aSystemAnnouncement! !

!ClyVariableQuery methodsFor: 'converting' stamp: ''!
withMetaLevelScope: aScopeClass 
	^self withScope: (scope withMetaLevel: aScopeClass)! !

!ClyVariableQuery class methodsFor: 'items type' stamp: ''!
resultItemsType
	^ClyVariable! !

!ClyVariableQueryTest methodsFor: 'tests' stamp: ''!
testConvertingToNewMetaLevel

	| newQuery |
	newQuery := query withMetaLevelScope: ClyInstanceSideScope.
	
	self assert: newQuery class equals: query class.
	self assert: newQuery scope class equals: ClyInstanceSideScope.
	self assert: newQuery scope basisObjects equals: query scope basisObjects.! !

!ClyVariableQueryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyVariableQueryTest! !

!ClyVariableReadersQuery commentStamp: ''!
I return only methods which read given variables!
!ClyVariableReadersQuery methodsFor: 'testing' stamp: ''!
doesMethod: aMethod useVar: aVariable

	^aVariable isReadIn: aMethod! !

!ClyVariableReadersQuery methodsFor: 'printing' stamp: ''!
description

	^'readers of ', self printVariables! !

!ClyVariableReadersQueryTest methodsFor: 'tests' stamp: ''!
testFromClassScope

	self queryFromScope: ClyBothMetaLevelClassScope of: self class.
	
	self assert: resultItems size equals: 2.	
	self assert: foundSelectors equals: #(reader1OfVar1 reader2OfVar1)! !

!ClyVariableReadersQueryTest methodsFor: 'methods for tests' stamp: ''!
reader1OfVar1

	^readVar1! !

!ClyVariableReadersQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope of: self class >> #reader1OfVar1 in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope of: self class >> #writerOfVar1 in: environment).
	self assert: query checkEmptyResult! !

!ClyVariableReadersQueryTest methodsFor: 'tests' stamp: ''!
testFromMethodScope
	self queryFromScope: ClyMethodScope ofAll: {(self class >> #reader1OfVar1) . (self class >> #writerOfVar1)}.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: self class >> #reader1OfVar1! !

!ClyVariableReadersQueryTest methodsFor: 'methods for tests' stamp: ''!
reader2OfVar1

	^readVar1! !

!ClyVariableReadersQueryTest methodsFor: 'tests' stamp: ''!
testFromPackageScope

	self queryFromScope: ClyPackageScope of: self class package.
	
	self assert: resultItems size equals: 3.	
	self assert: foundSelectors equals: #(reader1OfVar1 reader2OfVar1 supeclassReaderOfVar1)! !

!ClyVariableReadersQueryTest methodsFor: 'running' stamp: ''!
queryClass
	^ClyVariableReadersQuery! !

!ClyVariableReadersQueryTest methodsFor: 'methods for tests' stamp: ''!
writerOfVar1

	readVar1 := #testValue! !

!ClyVariableReadersQueryTest methodsFor: 'running' stamp: ''!
targetVarName
	^#readVar1! !

!ClyVariableReferencesQuery commentStamp: ''!
I return all methods which reference one of the variables retrieved by given variableQuery.

To create my instance use following expressions: 

	ClyVariableReferences toVariablesFrom: aVariableQuery.
	ClyVariableReferences from: aScope toVariablesFrom: aVariableQuery.

Query argument here is supposed return variables, instances of ClyVariable subclasses. So it can be complex query instead of concrete variable query.
  
And for simple cases there is another set of expressions when you need references to existing list of variables: 
	
	ClyVariableReferences of: aVariable.
	ClyVariableReferences of: aVariable from: aScope.
	
	ClyVariableReferences ofAny: { 
		ClyInstanceVariable named: #x definedIn: Point.
		ClyInstanceVariable named: #y definedIn: Point}.
	ClyVariableReferences ofAny: variables from: aScope.

Variables here are represented by subclasses of ClyVariable. 
		
I have few subclases which define specific meaning of reference like only readers or only writers. They redefine method #doesMethod:useVar: for this purpose.

Internal Representation and Key Implementation Points.

    Instance Variables
	variableQuery:		<ClyVariableQuery>!
!ClyVariableReferencesQuery methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
decorateResultMethodEditor: aMethodEditor
	| vars |
	vars := variableQuery execute items.
	aMethodEditor selectAnyVariable: (vars collect: [:each | each name])! !

!ClyVariableReferencesQuery methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	super = anObject ifFalse: [ ^ false ].
	^ variableQuery = anObject variableQuery! !

!ClyVariableReferencesQuery methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash bitXor: variableQuery hash! !

!ClyVariableReferencesQuery methodsFor: 'testing' stamp: ''!
doesMethod: aMethod useVar: aVariable

	^aVariable isAccessedIn: aMethod! !

!ClyVariableReferencesQuery methodsFor: 'accessing' stamp: ''!
variableQuery
	^ variableQuery! !

!ClyVariableReferencesQuery methodsFor: 'execution' stamp: ''!
buildResult: aQueryResult
	| filteredMethods vars |
	vars := variableQuery execute items.
	filteredMethods := OrderedCollection new.
	
	scope methodsDo: [ :each | 
		(self doesMethod: each useAnyOf: vars) ifTrue: [filteredMethods add: each]].
	
	aQueryResult fillWith: filteredMethods! !

!ClyVariableReferencesQuery methodsFor: 'printing' stamp: ''!
description

	^'references to ', self printVariables! !

!ClyVariableReferencesQuery methodsFor: 'testing' stamp: ''!
doesMethod: aMethod useAnyOf: vars
	
	^vars anySatisfy: [ :each |
		self doesMethod: aMethod useVar: each]! !

!ClyVariableReferencesQuery methodsFor: 'testing' stamp: ''!
selectsMethod: aMethod
	
	| vars |
	vars := variableQuery execute.
	
	^self doesMethod: aMethod useAnyOf: vars items! !

!ClyVariableReferencesQuery methodsFor: 'printing' stamp: ''!
printVariables

	^variableQuery scope == scope 
		ifTrue: [variableQuery description]
		ifFalse: [ variableQuery fullDescription ]! !

!ClyVariableReferencesQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream
	super printExtraInfoOn: aStream.

	aStream nextPutAll: self printVariables! !

!ClyVariableReferencesQuery methodsFor: 'accessing' stamp: ''!
variableQuery: aVariableQuery
	variableQuery := aVariableQuery! !

!ClyVariableReferencesQuery class methodsFor: 'instance variables' stamp: ''!
of: aVariable from: aScope
	^self ofAny: { aVariable } from: aScope! !

!ClyVariableReferencesQuery class methodsFor: 'instance variables' stamp: ''!
toVariablesFrom: aVariableQuery 
	^self new
		variableQuery: aVariableQuery! !

!ClyVariableReferencesQuery class methodsFor: 'instance variables' stamp: ''!
ofAny: variables
	^self new
		variableQuery: (ClyConstantQuery returning: variables)! !

!ClyVariableReferencesQuery class methodsFor: 'instance variables' stamp: ''!
from: aScope toVariablesFrom: aVariableQuery 
	^(self from: aScope)
		variableQuery: aVariableQuery! !

!ClyVariableReferencesQuery class methodsFor: 'instance variables' stamp: ''!
of: aVariable
	^self ofAny: { aVariable }! !

!ClyVariableReferencesQuery class methodsFor: 'instance variables' stamp: ''!
ofAny: variables from: aScope
	^aScope adoptQuery: (self toVariablesFrom: (ClyConstantQuery returning: variables))! !

!ClyVariableReferencesQueryTest methodsFor: 'tests' stamp: ''!
testFromClassScope

	self queryFromScope: ClyClassScope of: self class.
	
	self assert: resultItems size equals: 2.	
	self assert: foundSelectors equals: #(reference1OfVar1 reference2OfVar1)! !

!ClyVariableReferencesQueryTest methodsFor: 'methods for tests' stamp: ''!
reference2OfVar1

	referencedVar1 := #testValue! !

!ClyVariableReferencesQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope of: self class >> #reference1OfVar1 in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope of: self class >> #referenceOfAnotherVar in: environment).
	self assert: query checkEmptyResult! !

!ClyVariableReferencesQueryTest methodsFor: 'tests' stamp: ''!
testForSharedClassVariable

	| classVar |
	classVar := ClyClassVariable named: #DayNames definedIn: ChronologyConstants.
	query := ClyVariableReferencesQuery of: classVar.
	self queryFromScope: ClyBothMetaLevelClassScope of: Date.
	
	self assert: resultItems notEmpty! !

!ClyVariableReferencesQueryTest methodsFor: 'tests' stamp: ''!
testFromMethodScope
	self queryFromScope: ClyMethodScope ofAll: {(self class >> #reference1OfVar1) . (self class >> #referenceOfAnotherVar)}.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: self class >> #reference1OfVar1! !

!ClyVariableReferencesQueryTest methodsFor: 'tests' stamp: ''!
testForClassVariable

	| classVar |
	classVar := ClyClassVariable named: #ClassVar1 definedIn: ClyClass2FromP1Mock.
	query := ClyVariableReferencesQuery of: classVar.
	self queryFromScope: ClyClassScope of: ClyClass2FromP1Mock.
	
	self assert: resultItems size equals: 2.	
	self assert: foundSelectors equals: #(instanceSideClassVar1Reader instanceSideClassVar1Writer)! !

!ClyVariableReferencesQueryTest methodsFor: 'tests' stamp: ''!
testFromPackageScope

	self queryFromScope: ClyPackageScope of: self class package.
	
	self assert: resultItems size equals: 3.	
	self assert: foundSelectors equals: #(reference1OfVar1 reference2OfVar1 #supeclassReferenceOfVar1)! !

!ClyVariableReferencesQueryTest methodsFor: 'running' stamp: ''!
queryClass
	^ClyVariableReferencesQuery! !

!ClyVariableReferencesQueryTest methodsFor: 'methods for tests' stamp: ''!
reference1OfVar1

	^referencedVar1! !

!ClyVariableReferencesQueryTest methodsFor: 'methods for tests' stamp: ''!
referenceOfAnotherVar

	^var2! !

!ClyVariableReferencesQueryTest methodsFor: 'running' stamp: ''!
targetVarName
	^#referencedVar1! !

!ClyVariableReferencesTest methodsFor: 'tests' stamp: ''!
testComparison
	self
		assert: (self queryClass of: {(ClyInstanceVariable named: #x definedIn: Point)})
		equals: (self queryClass of: {(ClyInstanceVariable named: #x definedIn: Point)}).

	self
		assert: (self queryClass of: {(ClyInstanceVariable named: #x definedIn: Point)}) hash
		equals: (self queryClass of: {(ClyInstanceVariable named: #x definedIn: Point)}) hash.

	self
		deny: (self queryClass of: {(ClyInstanceVariable named: #x definedIn: Point)})
		equals: (self queryClass of: (ClyInstanceVariable named: #y definedIn: Point))! !

!ClyVariableReferencesTest methodsFor: 'methods for tests' stamp: ''!
supeclassReaderOfVar1

	^readVar1! !

!ClyVariableReferencesTest methodsFor: 'methods for tests' stamp: ''!
supeclassReferenceOfVar1

	^referencedVar1! !

!ClyVariableReferencesTest methodsFor: 'running' stamp: ''!
queryClass
	self subclassResponsibility! !

!ClyVariableReferencesTest methodsFor: 'running' stamp: ''!
createQuery
	^ self queryClass
		of: (ClyInstanceVariable
			named: self targetVarName definedIn: ClyVariableReferencesTest)
		from: (ClyClassScope of: self class in: environment)! !

!ClyVariableReferencesTest methodsFor: 'methods for tests' stamp: ''!
supeclassWriterOfVar1

	writtenVar1 := #superclassValue! !

!ClyVariableReferencesTest methodsFor: 'running' stamp: ''!
targetVarName
	self subclassResponsibility! !

!ClyVariableReferencesTest methodsFor: 'tests' stamp: ''!
testComparisonToSimilarQueryButWithDifferentVariables
	| query2 |
	query2 := self createQuery.
	query2 variableQuery: (ClyConstantQuery returning: #(someAnotherVar)).

	self deny: query equals: query2! !

!ClyVariableReferencesTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ClyVariableReferencesTest! !

!ClyVariableWritersQuery commentStamp: ''!
I return only methods which write given variables!
!ClyVariableWritersQuery methodsFor: 'testing' stamp: ''!
doesMethod: aMethod useVar: aVariable

	^aVariable isWrittenIn: aMethod! !

!ClyVariableWritersQuery methodsFor: 'printing' stamp: ''!
description

	^'writers of ', self printVariables! !

!ClyVariableWritersQueryTest methodsFor: 'tests' stamp: ''!
testFromClassScope

	self queryFromScope: ClyBothMetaLevelClassScope of: self class.
	
	self assert: resultItems size equals: 2.
	self assert: foundSelectors equals: #(writer1OfVar1 writer2OfVar1)! !

!ClyVariableWritersQueryTest methodsFor: 'methods for tests' stamp: ''!
readerOfVar1

	^writtenVar1! !

!ClyVariableWritersQueryTest methodsFor: 'tests' stamp: ''!
testCheckIfEmpty
	query scope: (ClyMethodScope of: self class >> #writer1OfVar1 in: environment).
	self deny: query checkEmptyResult.
	
	query scope: (ClyMethodScope of: self class >> #readerOfVar1 in: environment).
	self assert: query checkEmptyResult! !

!ClyVariableWritersQueryTest methodsFor: 'tests' stamp: ''!
testFromMethodScope
	self queryFromScope: ClyMethodScope ofAll: {(self class >> #writer1OfVar1) . (self class >> #readerOfVar1)}.

	self assert: resultItems size equals: 1.
	self assert: resultItems first identicalTo: self class >> #writer1OfVar1! !

!ClyVariableWritersQueryTest methodsFor: 'methods for tests' stamp: ''!
writer2OfVar1

	writtenVar1 := #value2! !

!ClyVariableWritersQueryTest methodsFor: 'tests' stamp: ''!
testFromPackageScope

	self queryFromScope: ClyPackageScope of: self class package.
	
	self assert: resultItems size equals: 3.	
	self assert: foundSelectors equals: #(supeclassWriterOfVar1 writer1OfVar1 writer2OfVar1)! !

!ClyVariableWritersQueryTest methodsFor: 'running' stamp: ''!
queryClass
	^ClyVariableWritersQuery! !

!ClyVariableWritersQueryTest methodsFor: 'methods for tests' stamp: ''!
writer1OfVar1

	writtenVar1 := #value1! !

!ClyVariableWritersQueryTest methodsFor: 'running' stamp: ''!
targetVarName
	^#writtenVar1! !

!ClyWatchMethodGroupProvider commentStamp: ''!
I provide a "watchpoints" method group which put together all methods with installed watchpoints!
!ClyWatchMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodQueryFrom: aClassScope
	^ClyMethodWatchQuery from: aClassScope! !

!ClyWatchMethodGroupProvider methodsFor: 'building groups' stamp: ''!
createMethodGroupFor: aMethodQuery from: aClassScope
	^ClyMethodGroup named: 'watchpoints' priority: 8.4 on: aMethodQuery! !

!ClyWatchMethodGroupProviderTest methodsFor: 'running' stamp: ''!
tearDown
	
	installedWatchpoint uninstall.
	
	super tearDown.! !

!ClyWatchMethodGroupProviderTest methodsFor: 'running' stamp: ''!
groupProviderClass
	^ClyWatchMethodGroupProvider! !

!ClyWatchMethodGroupProviderTest methodsFor: 'running' stamp: ''!
classSampleWhichHasGroup
	^ClyMethodWatchQueryTest! !

!ClyWatchMethodGroupProviderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	installedWatchpoint := ClyMethodWatchQueryTest new setUp; installWatchInto: #methodWithWatch! !

!ClyWrapQueryTest methodsFor: 'tests' stamp: ''!
testNotExecutedFromMultipleScopeWhenAllSubqueriesAreFromEmptyScope
	<expectedFailure>
	"Async query forbid creation on several subqueries.
	It shoud always wrap single query"
	super testNotExecutedFromMultipleScopeWhenAllSubqueriesAreFromEmptyScope! !

!ClyWrapQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromMultipleScopeWhenSubqueriesAreFromScopesOfDifferentObjects
	<expectedFailure>
	"Async query forbid creation on several subqueries.
	It shoud always wrap single query"
	super testIsExecutedFromMultipleScopeWhenSubqueriesAreFromScopesOfDifferentObjects! !

!ClyWrapQueryTest methodsFor: 'tests' stamp: ''!
testHasScopeFromSubquery

	self assert: query scope equals: query subqueries anyOne scope! !

!ClyWrapQueryTest methodsFor: 'tests' stamp: ''!
testNotExecutedFromMultipleScopeWhenSubqueriesAreFromDifferentScopesOfSameObject
	<expectedFailure>
	"Async query forbid creation on several subqueries.
	It shoud always wrap single query"
	super testNotExecutedFromMultipleScopeWhenSubqueriesAreFromDifferentScopesOfSameObject! !

!ClyWrapQueryTest methodsFor: 'tests' stamp: ''!
testConvertingWithNewRequiredResultShouldConvertActualQueryToo
	| newResult convertedQuery |
	newResult := ClyRawQueryResult new.
	convertedQuery := query withResult: newResult.

	self assert: convertedQuery actualQuery requiredResult identicalTo: newResult! !

!ClyWrapQueryTest methodsFor: 'tests' stamp: ''!
testNotExecutedFromSingleScopeWhenSubqueriesAreFromScopesOfDifferentObjects
	<expectedFailure>
	"Async query forbid creation on several subqueries.
	It shoud always wrap single query"
	super testNotExecutedFromSingleScopeWhenSubqueriesAreFromScopesOfDifferentObjects! !

!ClyWrapQueryTest methodsFor: 'tests' stamp: ''!
testIsExecutedFromSingleScopeWhenSubqueriesAreFromDifferentScopesOfSameObject
	<expectedFailure>
	"Async query forbid creation on several subqueries.
	It shoud always wrap single query"
	super testIsExecutedFromSingleScopeWhenSubqueriesAreFromDifferentScopesOfSameObject! !

!ClyWrapQueryTest methodsFor: 'tests' stamp: ''!
testHasCompositeScopeFromSubqueries
	<expectedFailure>
	"Async query must be created on single subquery.
	And in that case scope will be same as scope of this subquery"
	super testHasCompositeScopeFromSubqueries! !

!ClyWrapQueryTest methodsFor: 'tests' stamp: ''!
testNotExecutedFromSingleScopeWhenAllSubqueriesAreFromEmptyScope
	<expectedFailure>
	"Async query forbid creation on several subqueries.
	It shoud always wrap single query"
	super testNotExecutedFromSingleScopeWhenAllSubqueriesAreFromEmptyScope! !

!ClyWrapQueryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = ClyWrapQueryTest! !

!ClyWrapperQuery commentStamp: ''!
I represent hierarchy of wrapper queries.
The wrapper query is a single item composite query which uses single subquery in own execution logic.

To create my instances use #for: message: 
	
	ClyWrapperQuery for: aQuery

Subclasses can use #actualQuery to access single subquery for convenience.

I redefine #description to look like subquery by default.!
!ClyWrapperQuery methodsFor: 'converting' stamp: ''!
withSubqueries: newSubqueries

	^self copy 
		subqueries: newSubqueries! !

!ClyWrapperQuery methodsFor: 'converting' stamp: ''!
withResult: aQueryResult
	
	| newQuery |
	newQuery := super withResult: aQueryResult.
	newQuery subqueries: (subqueries collect: [ :each | each withResult: aQueryResult ]).
	^newQuery! !

!ClyWrapperQuery methodsFor: 'accessing' stamp: ''!
subqueries: queriesCollection
	queriesCollection size = 1 ifFalse: [ self error: 'Wrapper query should include single subquery' ].
	super subqueries: queriesCollection! !

!ClyWrapperQuery methodsFor: 'printing' stamp: ''!
description

	^self actualQuery description! !

!ClyWrapperQuery methodsFor: 'accessing' stamp: ''!
actualQuery
	^subqueries anyOne! !

!ClyWrapperQuery methodsFor: 'printing' stamp: ''!
printExtraInfoOn: aStream

	^aStream nextPutAll: self description! !

!ClyWrapperQuery class methodsFor: 'instance creation' stamp: ''!
for: aQuery
	^self with: { aQuery }! !

!CmAbstractCommand commentStamp: ''!
I am an abstract class defining the API a command should understand.

See my subclasses for concrete examples.!
!CmAbstractCommand methodsFor: 'accessing' stamp: ''!
context
	^ self subclassResponsibility! !

!CmAbstractCommand methodsFor: 'visiting' stamp: ''!
acceptVisitor: aCmCommandOrGroup
	^ aCmCommandOrGroup visitCommand: self! !

!CmAbstractCommand methodsFor: 'accessing' stamp: ''!
context: anObject
	^ self subclassResponsibility! !

!CmAbstractCommand methodsFor: 'executing' stamp: ''!
execute
	"Execute the actions that should be done by the command.
	 This method expect that the context has been put in #context inst. var. if any context is relevant."
	self subclassResponsibility! !

!CmAbstractCommand methodsFor: 'testing' stamp: ''!
isCommand
	^ true! !

!CmAbstractCommand methodsFor: 'testing' stamp: ''!
canBeExecuted
	"This hook allows the command decide if it can be run with the context it holds or not.
	 It should return a boolean.
	"
	^ self subclassResponsibility! !

!CmAbstractCommand class methodsFor: 'instance creation' stamp: ''!
forContext: anObject
	"Creates a new command with anObject as context."
	^ self new
		context: anObject;
		yourself! !

!CmAbstractCommandsGroup commentStamp: ''!
I am an abstract class defining the API a command group should understand.

See my subclasses for concrete examples.!
!CmAbstractCommandsGroup methodsFor: 'testing' stamp: ''!
hasEntryNamed: aString
	^ self subclassResponsibility! !

!CmAbstractCommandsGroup methodsFor: 'visiting' stamp: ''!
acceptVisitor: aCmCommandOrGroup
	^ aCmCommandOrGroup visitCommandGroup: self! !

!CmAbstractCommandsGroup methodsFor: 'public-api' stamp: ''!
/ aString
	"Alias for #commandOrRegisterNamed:."
	^ self commandOrGroupNamed: aString! !

!CmAbstractCommandsGroup methodsFor: 'public-api' stamp: ''!
commands
	^ self subclassResponsibility! !

!CmAbstractCommandsGroup methodsFor: 'testing' stamp: ''!
hasCommand: aCmCommand
	^ self subclassResponsibility! !

!CmAbstractCommandsGroup methodsFor: 'testing' stamp: ''!
isGroup
	^ true! !

!CmAbstractCommandsGroup methodsFor: 'accessing' stamp: ''!
allCommands
	^ self subclassResponsibility! !

!CmAbstractCommandsGroup methodsFor: 'public-api' stamp: ''!
commandOrGroupNamed: aString
	^ self subclassResponsibility! !

!CmAbstractCommandsGroup methodsFor: '*NewTools-Debugger' stamp: ''!
commandOrGroupNamed: aString ifNone: aBlock
	self subclassResponsibility ! !

!CmAbstractCommandsGroup methodsFor: 'public-api' stamp: ''!
groups
	^ self subclassResponsibility! !

!CmAbstractCommandsGroup methodsFor: 'public-api' stamp: ''!
register: aCmCommandsOrRegister
	^ self subclassResponsibility! !

!CmAbstractCommandsGroup methodsFor: 'public-api' stamp: ''!
unregister: aCmCommandOrRegister
	^ self subclassResponsibility! !

!CmAbstractCommandsGroup methodsFor: 'public-api' stamp: ''!
entries
	^ self subclassResponsibility! !

!CmBlockCommand commentStamp: ''!
While other commands actions should be defined by overriding #execute method, I'm a block command. 
I  execute a block as my action.
!
!CmBlockCommand methodsFor: 'accessing' stamp: ''!
block
	^ block! !

!CmBlockCommand methodsFor: 'accessing' stamp: ''!
block: anObject
	block := anObject! !

!CmBlockCommand methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self canBeExecutedBlock: [ :ctxt | true ]! !

!CmBlockCommand methodsFor: 'accessing' stamp: ''!
canBeExecutedBlock
	^ canBeExecutedBlock! !

!CmBlockCommand methodsFor: 'executing' stamp: ''!
execute
	self hasContext
		ifTrue: [ block value: self context ]
		ifFalse: [ block value ]! !

!CmBlockCommand methodsFor: 'testing' stamp: ''!
canBeExecuted
	self hasContext
		ifFalse: [ ^ super canBeExecuted ].	"When no context is set, we consider the command to be runnable. So we call super."
	^ self canBeExecutedBlock value: self context! !

!CmBlockCommand methodsFor: 'accessing' stamp: ''!
canBeExecutedBlock: anObject
	canBeExecutedBlock := anObject! !

!CmCommand commentStamp: ''!
I am the common superclass to all commands defined in the context of Commander2.

My subclasses need to redefine at least #execute method.
This method defines the behaviour of the command.

Eventually, #canBeRun can be override to check if the command can be run according to its current context.!
!CmCommand methodsFor: 'accessing' stamp: ''!
context
	"The #context might be a BlockClosure that computes the actual context object when needed.
	 Thus, we send #value which in case of a BlockClosure evaluate it and in case of another
	 Object, simply returns itself.
	"
	^ context value! !

!CmCommand methodsFor: 'decorating' stamp: ''!
decorateWith: aDecorator
	^ aDecorator decorate: self! !

!CmCommand methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self name: self class defaultName.
	self description: self class defaultDescription! !

!CmCommand methodsFor: '*Spec2-Commander2' stamp: ''!
asSpecCommand
	"Subclasses might override this method to define default icon and shortcut."
	^ self decorateWith: SpCommand! !

!CmCommand methodsFor: 'accessing' stamp: ''!
dynamicDescription
	"This hook is called to generate a description dynamically.
	 In the case of a command, the context can be used to provide additional
	 contextual information to the String returned.
	 When entering this method, one can expect that the context can be accessed
	 through a call to #context method.
	 By default, my #description is returned.
	"
	^ self description! !

!CmCommand methodsFor: 'accessing' stamp: ''!
description: anObject
	basicDescription := anObject! !

!CmCommand methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!CmCommand methodsFor: 'accessing' stamp: ''!
description
	^ basicDescription! !

!CmCommand methodsFor: 'accessing' stamp: ''!
dynamicName
	"This hook is called to generate a name dynamically.
	 In the case of a command, the context can be used to provide additional
	 contextual information to the String returned.
	 When entering this method, one can expect that the context can be accessed
	 through a call to #context method.
	 By default, my #name is returned.
	"
	^ self name! !

!CmCommand methodsFor: 'testing' stamp: ''!
hasContext
	^ self context isNotNil! !

!CmCommand methodsFor: '*Spec2-Commander2' stamp: ''!
asSpecCommandWithShortcutKey: aKMKeyCombination
	^ self asSpecCommand
		shortcutKey: aKMKeyCombination;
		yourself! !

!CmCommand methodsFor: '*NewTools-Core' stamp: ''!
appliesTo: aTool

	^ true! !

!CmCommand methodsFor: 'accessing' stamp: ''!
name
	^ basicName! !

!CmCommand methodsFor: 'accessing' stamp: ''!
name: anObject
	basicName := anObject! !

!CmCommand methodsFor: '*Spec2-Commander2' stamp: ''!
asSpecCommandWithIconNamed: aSymbol shortcutKey: aKMKeyCombination
	^ self asSpecCommand
		iconName: aSymbol;
		shortcutKey: aKMKeyCombination;
		yourself! !

!CmCommand methodsFor: '*Spec2-Commander2' stamp: ''!
asSpecCommandWithIconNamed: aSymbol
	^ self asSpecCommand
		iconName: aSymbol;
		yourself! !

!CmCommand methodsFor: 'testing' stamp: ''!
canBeExecuted
	"See my super class comment for this method.
	 By default I return true.
	"
	^ true! !

!CmCommand class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CmCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CmCommand class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CmCommand class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CmCommand class methodsFor: '*NewTools-Core' stamp: ''!
instantiateCommands: commandClasses for: aTool

	^ commandClasses
		collect: [ :commandClass | commandClass forSpecContext: aTool ]
		thenSelect: [ :debugCommand | debugCommand decoratedCommand appliesTo: aTool ]! !

!CmCommand class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CmCommand class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CmCommand class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CmCommand class methodsFor: '*Spec2-Commander2' stamp: ''!
forSpecWithIconNamed: aSymbol shortcutKey: aKMKeyCombination
	^ self new
		asSpecCommandWithIconNamed: aSymbol shortcutKey: aKMKeyCombination! !

!CmCommand class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CmCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmCommand class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CmCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CmCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CmCommand class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CmCommand class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CmCommand class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CmCommand class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CmCommand class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CmCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmCommand class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CmCommand class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CmCommand class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CmCommand class methodsFor: '*Spec2-Commander2' stamp: ''!
forSpecWithIconNamed: aSymbol
	^ self new asSpecCommandWithIconNamed: aSymbol! !

!CmCommand class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CmCommand class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CmCommand class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CmCommand class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CmCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Not described command.'! !

!CmCommand class methodsFor: '*Spec2-Commander2' stamp: ''!
forSpecContext: anObject

	^ self new 
	context: anObject;
	asSpecCommand! !

!CmCommand class methodsFor: '*NewTools-Core' stamp: ''!
instantiateCommandsFromPragma: pragmaName for: aTool

	^ self 
		instantiateCommands: (self commandClassesFromPragma: pragmaName) 
		for: aTool! !

!CmCommand class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CmCommand class methodsFor: 'default' stamp: ''!
defaultName 

	^ 'Unnamed'! !

!CmCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CmCommand class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CmCommand class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CmCommand class methodsFor: '*NewTools-Core' stamp: ''!
commandClassesFromPragma: aSymbol
	"Collects command classes matching the pragma aSymbol. 
	 WARNING: The collection will happen takign the caller class and subclasses. If you 
	 execute: CmCommand commandClassesForPragma: #myPragma:, it will scan all commands in 
	 system. THIS IS NOT RECOMMENDED. Please use your own hierarchy as starting point"
	| commandsClasses |
	
	commandsClasses := OrderedCollection new.
	(self allSubclasses reject: [ :sc | sc hasAbstractMethods ])
		do: [ :commandClass | 
			commandsClasses addAll: (Pragma
				allNamed: aSymbol
				from: commandClass class
				to: commandClass class) ].
	
	^ ((aSymbol last = $:)
		ifTrue: [ commandsClasses sorted: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ] ]
		ifFalse: [ commandsClasses ])
		collect: [ :pragma | pragma methodClass soleInstance ]! !

!CmCommand class methodsFor: '*Spec2-Commander2' stamp: ''!
forSpec
	^ self new
		asSpecCommand! !

!CmCommandAborted commentStamp: ''!
I am raised when the execution of a command has been aborted.!
!CmCommandAborted methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		reason: 'Unkown reason'! !

!CmCommandAborted methodsFor: 'accessing' stamp: ''!
reason
	^ reason! !

!CmCommandAborted methodsFor: '*Spec2-Commander2' stamp: ''!
actForSpec
	UIManager default inform: ('"{1}" command was aborted because: {2}' format: { self command name . self reason })! !

!CmCommandAborted methodsFor: 'accessing' stamp: ''!
reason: anObject
	reason := anObject! !

!CmCommandCollector commentStamp: ''!
I am a concrete visitor that reucrsively collects all the commands of a command registry. I'm used by the `CmCommandGroup>>#allCommands` message.!
!CmCommandCollector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	commandsCollected := OrderedCollection new! !

!CmCommandCollector methodsFor: 'accessing' stamp: ''!
commandsCollected
	^ commandsCollected! !

!CmCommandCollector methodsFor: 'visiting' stamp: ''!
visitCommand: aCmCommand
	commandsCollected add: aCmCommand.
	^ aCmCommand! !

!CmCommandDecorator commentStamp: ''!
I am the implementation of the decorator design pattern for commands.

I just delegate everything to the #decoratedCommand. My subclasses probably do something more interesting.!
!CmCommandDecorator methodsFor: 'accessing' stamp: ''!
context
	^ self decoratedCommand context! !

!CmCommandDecorator methodsFor: 'accessing' stamp: ''!
dynamicDescription
	^ self decoratedCommand dynamicDescription! !

!CmCommandDecorator methodsFor: 'decorating' stamp: ''!
decorate: aCmCommand
	self decoratedCommand: aCmCommand! !

!CmCommandDecorator methodsFor: 'accessing' stamp: ''!
context: anObject
	self decoratedCommand context: anObject! !

!CmCommandDecorator methodsFor: 'accessing' stamp: ''!
description
	^ self decoratedCommand description! !

!CmCommandDecorator methodsFor: 'accessing' stamp: ''!
decoratedCommand: anObject
	decoratedCommand := anObject! !

!CmCommandDecorator methodsFor: 'accessing' stamp: ''!
description: aString
	self decoratedCommand description: aString! !

!CmCommandDecorator methodsFor: 'accessing' stamp: ''!
dynamicName
	^ self decoratedCommand dynamicName! !

!CmCommandDecorator methodsFor: 'executing' stamp: ''!
execute
	self decoratedCommand execute! !

!CmCommandDecorator methodsFor: 'accessing' stamp: ''!
decoratedCommand
	^ decoratedCommand! !

!CmCommandDecorator methodsFor: 'accessing' stamp: ''!
name
	^ self decoratedCommand name! !

!CmCommandDecorator methodsFor: 'accessing' stamp: ''!
name: aString
	self decoratedCommand name: aString! !

!CmCommandDecorator methodsFor: 'testing' stamp: ''!
canBeExecuted
	"This hook allows the command decide if it can be run with the context it holds or not.
	 It should return a boolean.
	"
	^ self decoratedCommand canBeExecuted! !

!CmCommandDecorator class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CmCommandDecorator class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CmCommandDecorator class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CmCommandDecorator class methodsFor: 'instance creation' stamp: ''!
decorate: anObject
	"Create a decorator decorating anObject."
	^ self new
		decorate: anObject;
		yourself! !

!CmCommandDecorator class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CmCommandDecorator class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CmCommandDecorator class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CmCommandDecorator class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CmCommandDecorator class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CmCommandDecorator class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmCommandDecorator class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CmCommandDecorator class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CmCommandDecorator class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CmCommandDecorator class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CmCommandDecorator class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CmCommandDecorator class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CmCommandDecorator class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CmCommandDecorator class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CmCommandDecorator class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmCommandDecorator class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CmCommandDecorator class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CmCommandDecorator class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CmCommandDecorator class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CmCommandDecorator class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CmCommandDecorator class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CmCommandDecorator class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CmCommandDecorator class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CmCommandDecorator class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CmCommandDecorator class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CmCommandDecorator class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CmCommandDecoratorTest commentStamp: ''!
A LtCommandDecoratorTest is a test class for testing the behavior of LtCommandDecorator!
!CmCommandDecoratorTest methodsFor: 'tests' stamp: ''!
testDynamicDescription
	self assert: decorator description equals: commandToBeDecorated description! !

!CmCommandDecoratorTest methodsFor: 'tests' stamp: ''!
testDecorate
	self assert: decorator class equals: CmCommandDecorator.
	self assert: decorator decoratedCommand equals: commandToBeDecorated! !

!CmCommandDecoratorTest methodsFor: 'tests' stamp: ''!
testName
	self assert: decorator name equals: commandToBeDecorated name! !

!CmCommandDecoratorTest methodsFor: 'tests' stamp: ''!
testDescription
	self assert: decorator description equals: commandToBeDecorated description! !

!CmCommandDecoratorTest methodsFor: 'tests' stamp: ''!
testContext
	self assert: decorator context equals: commandToBeDecorated context! !

!CmCommandDecoratorTest methodsFor: 'tests' stamp: ''!
testDecoratedCommand
	self assert: decorator decoratedCommand equals: commandToBeDecorated! !

!CmCommandDecoratorTest methodsFor: 'tests' stamp: ''!
testDynamicName
	self assert: decorator dynamicName equals: commandToBeDecorated dynamicName! !

!CmCommandDecoratorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	commandToBeDecorated := CmCommand new.
	
	commandToBeDecorated
		name: 'command for test';
		description: 'This command is only cerated for the purpose of unit tests.';
		context: Object new.
		
	decorator := CmCommandDecorator decorate: commandToBeDecorated! !

!CmCommandError commentStamp: ''!
I am an abstract error that can be thrown by a command.

I hold the command that generated myself in my #command inst. var.

One can create an instance of myself like this:
[[[
LtCommandError command: LtCommand new
]]]

One can create an instance of myself and directly signal it like this:
[[[
LtCommandError signalCommand: LtCommand new
]]]!
!CmCommandError methodsFor: 'accessing' stamp: ''!
command
	^ command! !

!CmCommandError methodsFor: 'accessing' stamp: ''!
command: aCmSpecCommand 
	command := aCmSpecCommand! !

!CmCommandError class methodsFor: 'instance creation' stamp: ''!
command: aCmSpecCommand 
	^ self new
		command: aCmSpecCommand;
		yourself! !

!CmCommandError class methodsFor: 'signalling' stamp: ''!
signalCommand: aCmSpecCommand 
	(self command: aCmSpecCommand) signal! !

!CmCommandGroup commentStamp: ''!
I allow one to group together commands that are semantically related.

I can hold either commands or sub-groups.

I provide a nice API to query the tree of commands and groups. See my 'public-api' protocol.!
!CmCommandGroup methodsFor: 'testing' stamp: ''!
hasEntryNamed: aString
	"Returns true if one of my entries (command, registry, ...) is named aString.
	 Else returns false.
	"
	^ entries anySatisfy: [ :any | any name = aString ]! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
register: aCommandOrGroup insteadOf: anotherCommandOrGroup
	| commandToReplaceIndex |
	commandToReplaceIndex := self entriesIndexOf: anotherCommandOrGroup.
	
	((self commands collect: #name) \ { (entries at: commandToReplaceIndex) } includes: aCommandOrGroup name)
		ifTrue: [ CmDuplicatedEntryName signalEntryNamed: aCommandOrGroup name ].
	
	entries at: commandToReplaceIndex put: aCommandOrGroup! !

!CmCommandGroup methodsFor: 'decorating' stamp: ''!
decorateWith: aDecorator
	^ aDecorator decorate: self! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
registerFirst: aCommandOrGroup
	self ensureNotDuplicated: aCommandOrGroup.
	entries addFirst: aCommandOrGroup! !

!CmCommandGroup methodsFor: '*Spec2-Commander2' stamp: ''!
asSpecGroup
	"Subclasses might override this method to define default icon."
	^ self decorateWith: SpCommandGroup! !

!CmCommandGroup methodsFor: 'accessing' stamp: ''!
dynamicDescription
	"This hook is called to generate a description dynamically.
	 In the case of a command, the context can be used to provide additional
	 contextual information to the String returned.
	 When entering this method, one can expect that the context can be accessed
	 through a call to #context method.
	 By default, my #description is returned.
	"
	^ self description! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
commands
	^ entries select: [ :entry | entry isCommand ]! !

!CmCommandGroup methodsFor: 'accessing' stamp: ''!
description
	^ basicDescription! !

!CmCommandGroup methodsFor: 'accessing' stamp: ''!
dynamicName
	"This hook is called to generate a name dynamically.
	 In the case of a command, the context can be used to provide additional
	 contextual information to the String returned.
	 When entering this method, one can expect that the context can be accessed
	 through a call to #context method.
	 By default, my #name is returned.
	"
	^ self name! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
register: aCommandOrGroup after: anotherCommandOrGroup
	self ensureNotDuplicated: aCommandOrGroup.
	self entries add: aCommandOrGroup after: anotherCommandOrGroup! !

!CmCommandGroup methodsFor: '*NewTools-Debugger' stamp: ''!
commandOrGroupNamed: aString ifNone: aBlock
	^ entries
		detect: [ :commandOrRegister | commandOrRegister name = aString ]
		ifNone: aBlock! !

!CmCommandGroup methodsFor: 'accessing' stamp: ''!
name: anObject
	basicName := anObject! !

!CmCommandGroup methodsFor: 'accessing' stamp: ''!
allCommands
	| visitor |
	visitor := CmCommandCollector new.
	self acceptVisitor: visitor.
	^ visitor commandsCollected! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
commandOrGroupNamed: aString
	^ (entries detect: [ :commandOrRegister | commandOrRegister name = aString ])! !

!CmCommandGroup methodsFor: 'private' stamp: ''!
entriesIndexOf: aCommandOrGroup
	"Returns the index of aCommandOrGroup in my entries.
	 If aCommandOrGroup is not included in my entries, raises a NotFound error.
	"
	^ entries
		indexOf: aCommandOrGroup
		ifAbsent:[ 
			NotFound new
				collection: self;
				object: aCommandOrGroup;
				signal: 'Command or group to replace is not found in the group.' ]! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
registerLast: aCommandOrGroup
	self ensureNotDuplicated: aCommandOrGroup.
	entries addLast: aCommandOrGroup! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
register: aCommandOrGroup
	self registerLast: aCommandOrGroup! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
unregister: aCmCommandOrGroup
	entries remove: (entries detect: [ :e | e = aCmCommandOrGroup ])! !

!CmCommandGroup methodsFor: '*Spec2-Commander2' stamp: ''!
asSpecGroupWithIconNamed: aSymbol
	^ self asSpecGroup
		iconName: aSymbol;
		yourself! !

!CmCommandGroup methodsFor: 'testing' stamp: ''!
hasGroup: aCommandGroup
	^ self groups includes: aCommandGroup! !

!CmCommandGroup methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self name: self class defaultName.
	self description: self class defaultDescription.
	entries := OrderedCollection new! !

!CmCommandGroup methodsFor: 'accessing' stamp: ''!
description: anObject
	basicDescription := anObject! !

!CmCommandGroup methodsFor: 'private' stamp: ''!
ensureNotDuplicated: aCommandOrGroup
	"Check that aCommandOrGroup's #basicName is not already used by one of my entries.
	 If it is, raises a CmDuplicatedEntryName error.
	"
	(self hasEntryNamed: aCommandOrGroup name)
		ifTrue: [ CmDuplicatedEntryName signalEntryNamed: aCommandOrGroup name ]! !

!CmCommandGroup methodsFor: 'testing' stamp: ''!
hasCommand: aCmCommand
	^ self commands includes: aCmCommand! !

!CmCommandGroup methodsFor: 'accessing' stamp: ''!
name
	^ basicName! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
groups
	^ entries select: [ :entry | entry isGroup ]! !

!CmCommandGroup methodsFor: '*Iceberg-TipUI' stamp: ''!
commandOrGroupNamed: aString ifFound: aBlock

	^ entries
		  detect: [ :commandOrRegister | commandOrRegister name = aString ]
		  ifFound: aBlock! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
register: aCommandOrGroup before: anotherCommandOrGroup
	self ensureNotDuplicated: aCommandOrGroup.
	self entries add: aCommandOrGroup before: anotherCommandOrGroup! !

!CmCommandGroup methodsFor: 'public-api' stamp: ''!
entries
	^ entries! !

!CmCommandGroup class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CmCommandGroup class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CmCommandGroup class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CmCommandGroup class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CmCommandGroup class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CmCommandGroup class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CmCommandGroup class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CmCommandGroup class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CmCommandGroup class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmCommandGroup class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CmCommandGroup class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CmCommandGroup class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CmCommandGroup class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CmCommandGroup class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CmCommandGroup class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CmCommandGroup class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CmCommandGroup class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CmCommandGroup class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmCommandGroup class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CmCommandGroup class methodsFor: 'instance creation' stamp: ''!
named: aString
	^ self new
		name: aString;
		yourself! !

!CmCommandGroup class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CmCommandGroup class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CmCommandGroup class methodsFor: '*Spec2-Commander2' stamp: ''!
forSpecWithIconNamed: aSymbol
	^ self new asSpecGroupWithIconNamed: aSymbol! !

!CmCommandGroup class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CmCommandGroup class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CmCommandGroup class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CmCommandGroup class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CmCommandGroup class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'I''m group and I should provide a nice description for my user.'! !

!CmCommandGroup class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CmCommandGroup class methodsFor: 'default' stamp: ''!
defaultName
	^ 'Unnamed group'! !

!CmCommandGroup class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CmCommandGroup class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CmCommandGroup class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CmCommandGroup class methodsFor: '*Spec2-Commander2' stamp: ''!
forSpec
	^ self new asSpecGroup! !

!CmCommandGroupDecorator commentStamp: ''!
I am the implementation of the decorator design pattern for command group.

I just delegate everything to the #decoratedGroup. My subclasses probably do something more interesting.!
!CmCommandGroupDecorator methodsFor: 'testing' stamp: ''!
hasEntryNamed: aString
	^ self decoratedGroup hasEntryNamed: aString! !

!CmCommandGroupDecorator methodsFor: 'accessing' stamp: ''!
dynamicDescription
	^ self decoratedGroup dynamicDescription! !

!CmCommandGroupDecorator methodsFor: 'decorating' stamp: ''!
decorate: aCmCommandsGroup
	self decoratedGroup: aCmCommandsGroup! !

!CmCommandGroupDecorator methodsFor: 'public-api' stamp: ''!
commands
	^ self decoratedGroup commands! !

!CmCommandGroupDecorator methodsFor: 'accessing' stamp: ''!
description
	^ self decoratedGroup description! !

!CmCommandGroupDecorator methodsFor: 'accessing' stamp: ''!
description: aString
	self decoratedGroup description: aString! !

!CmCommandGroupDecorator methodsFor: 'accessing' stamp: ''!
dynamicName
	^ self decoratedGroup dynamicName! !

!CmCommandGroupDecorator methodsFor: 'testing' stamp: ''!
hasCommand: aCmCommand
	^ self decoratedGroup hasCommand: aCmCommand! !

!CmCommandGroupDecorator methodsFor: 'accessing' stamp: ''!
decoratedGroup: anObject
	decoratedGroup := anObject! !

!CmCommandGroupDecorator methodsFor: 'accessing' stamp: ''!
name
	^ self decoratedGroup name! !

!CmCommandGroupDecorator methodsFor: 'accessing' stamp: ''!
allCommands
	^ self decoratedGroup allCommands! !

!CmCommandGroupDecorator methodsFor: 'public-api' stamp: ''!
commandOrGroupNamed: aString
	^ self decoratedGroup commandOrGroupNamed: aString! !

!CmCommandGroupDecorator methodsFor: 'accessing' stamp: ''!
decoratedGroup
	^ decoratedGroup! !

!CmCommandGroupDecorator methodsFor: 'accessing' stamp: ''!
name: aString
	self decoratedGroup name: aString! !

!CmCommandGroupDecorator methodsFor: '*NewTools-Debugger' stamp: ''!
commandOrGroupNamed: aString ifNone: aBlock
	^ self decoratedGroup commandOrGroupNamed: aString ifNone: aBlock! !

!CmCommandGroupDecorator methodsFor: 'public-api' stamp: ''!
groups
	^ self decoratedGroup groups! !

!CmCommandGroupDecorator methodsFor: '*Iceberg-TipUI' stamp: ''!
commandOrGroupNamed: aString ifFound: aBlock

	^ self decoratedGroup commandOrGroupNamed: aString ifFound: aBlock! !

!CmCommandGroupDecorator methodsFor: 'public-api' stamp: ''!
register: aCmCommandOrGroup
	self decoratedGroup register: aCmCommandOrGroup! !

!CmCommandGroupDecorator methodsFor: 'public-api' stamp: ''!
unregister: aCmCommandOrGroup
	^ self decoratedGroup unregister: aCmCommandOrGroup! !

!CmCommandGroupDecorator methodsFor: 'public-api' stamp: ''!
entries
	^ self decoratedGroup entries! !

!CmCommandGroupDecorator class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CmCommandGroupDecorator class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CmCommandGroupDecorator class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CmCommandGroupDecorator class methodsFor: 'instance creation' stamp: ''!
decorate: anObject
	"Create a decorator decorating anObject."
	^ self new
		decorate: anObject;
		yourself! !

!CmCommandGroupDecorator class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CmCommandGroupDecorator class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CmCommandGroupDecorator class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CmCommandGroupDecorator class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CmCommandGroupDecorator class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CmCommandGroupDecorator class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmCommandGroupDecorator class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CmCommandGroupDecorator class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CmCommandGroupDecorator class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CmCommandGroupDecorator class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CmCommandGroupDecorator class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CmCommandGroupDecorator class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CmCommandGroupDecorator class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CmCommandGroupDecorator class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CmCommandGroupDecorator class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmCommandGroupDecorator class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CmCommandGroupDecorator class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CmCommandGroupDecorator class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CmCommandGroupDecorator class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CmCommandGroupDecorator class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CmCommandGroupDecorator class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CmCommandGroupDecorator class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CmCommandGroupDecorator class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CmCommandGroupDecorator class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CmCommandGroupDecorator class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CmCommandGroupDecorator class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CmCommandTest methodsFor: 'tests' stamp: ''!
testDynamicDescription
	command context: 42.
	
	self assert: command dynamicDescription equals: command description , ' 42'! !

!CmCommandTest methodsFor: 'tests' stamp: ''!
testHasContext
	self deny: command hasContext.
	
	command context: 42.
	
	self assert: command hasContext.
	
	command context: [ 42 ].
	
	self assert: command hasContext.! !

!CmCommandTest methodsFor: 'tests' stamp: ''!
testName
	self assert: command name equals: 'Fake command'.! !

!CmCommandTest methodsFor: 'tests' stamp: ''!
testDescription
	self assert: command description equals: 'I am a fake command for testing purposes.'.! !

!CmCommandTest methodsFor: 'tests' stamp: ''!
testContext
	self assert: command context isNil.
	
	command context: 42.
	
	self assert: command context equals: 42.
	
	command context: [ 41 + 1 ].
	
	self assert: command context equals: 42.! !

!CmCommandTest methodsFor: 'tests' stamp: ''!
testCanBeExecuted
	command context: 0. "Need to set context before because the command expects it."
	self deny: command canBeExecuted.
	
	command context: 42.
	self assert: command canBeExecuted.! !

!CmCommandTest methodsFor: 'tests' stamp: ''!
testDynamicName
	command context: 42.
	
	self assert: command dynamicName equals: command name , ' 42'! !

!CmCommandTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	command := CmFakeCommand new.! !

!CmCommandsGroupTest commentStamp: ''!
A LtCommandsRegistryTest is a test class for testing the behavior of LtCommandsRegistry!
!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testRegisterSubRegister
	| subGroup3 |
	self deny: (group hasEntryNamed: 'sub group 3').
	
	subGroup3 := CmCommandGroup named: 'sub group 3'.
	group register: subGroup3.
	
	self assert: (group hasEntryNamed: 'sub group 3').
	self assert: (group commandOrGroupNamed: 'sub group 3') equals: subGroup3.
	
	self
		should: [ group register: (CmCommandGroup named: 'sub group 3') ]
		raise: CmDuplicatedEntryName
		withExceptionDo: [ :error |
			self assert: error entryName equals: 'sub group 3' ]! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testAllCommands
	self assertCollection: group allCommands equals: { firstCommand . subCommand1 } asOrderedCollection! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testInitialize
	| newGroup |
	newGroup := CmCommandGroup new.
	
	self assert: newGroup name equals: CmCommandGroup defaultName.
	self assert: newGroup entries isEmpty! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testRegisterCommandWithContextBlock
	| secondCommand secondCommandWithSameName |
	self deny: (group hasEntryNamed: 'second command').
	
	secondCommand := CmBlockCommand new 
							name: 'second command';
							block: [ :x | x ];
							context: [ 42 ];
							yourself.
	group register: secondCommand.
	
	self assert: (group hasEntryNamed: 'second command').
	self assert: (group commandOrGroupNamed: 'second command') equals: secondCommand.
	
	secondCommandWithSameName := CmBlockCommand new 
											name: 'second command';
											block: [ :x | x ];
											context: [ ];
											yourself.
	
	self
		should: [ group register: secondCommandWithSameName]
		raise: CmDuplicatedEntryName
		withExceptionDo: [ :error |
			self assert: error entryName equals: 'second command' ]! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testCommandOrGroupNamed
	self assert: (group commandOrGroupNamed: 'first command') equals: firstCommand.
	self assert: (group commandOrGroupNamed: 'sub group 1') equals: subGroup1.
	self assert: (group commandOrGroupNamed: 'sub group 2') equals: subGroup2.	
	
	self should: [ group commandOrGroupNamed: 'unknown' ] raise: NotFound.
	
	self assert: ((group commandOrGroupNamed: 'sub group 1') commandOrGroupNamed: 'sub command 1') equals: subCommand1.! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testHasCommand
	self deny: (group hasCommand: CmCommand new).
	
	self assert: (group hasCommand: firstCommand)! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testRegisterCommandWithContext
	| secondCommand |
	self deny: (group hasEntryNamed: 'second command').
	
	secondCommand := CmBlockCommand new 
							name: 'second command';
							block: [ :x | x ];
							context: 42;
							yourself.
	group register: secondCommand.
	
	self assert: (group hasEntryNamed: 'second command').
	self assert: (group commandOrGroupNamed: 'second command') equals: secondCommand.
	self assert: group entries last context equals: 42! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testGroups
	self assertCollection: group groups equals: { subGroup1. subGroup2 } asOrderedCollection! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testCommands
	self assertCollection: group commands equals: { firstCommand } asOrderedCollection! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testHasEntryNamed
	self deny: (group hasEntryNamed: 'nope').
	
	self assert: (group hasEntryNamed: 'first command').
	
	self deny: (group hasEntryNamed: 'sub command 1').! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testEntries
	self assert: (group entries allSatisfy: [ :e | e isCommand or: [ e isGroup ] ]).
	self assertCollection: (group entries) equals: { firstCommand . subGroup1 . subGroup2 } asOrderedCollection! !

!CmCommandsGroupTest methodsFor: 'tests' stamp: ''!
testUnregister
	self assert: (group hasEntryNamed: 'first command').
	group unregister: firstCommand.
	self deny: (group hasEntryNamed: 'first command').
	
	self assert: (group hasEntryNamed: 'sub group 1').
	group unregister: subGroup1.
	self deny: (group hasEntryNamed: 'sub group 1').! !

!CmCommandsGroupTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	group := CmCommandGroup named: 'main group'.
	firstCommand := CmBlockCommand new
							name: 'first command';
							block: [ :x | x ];
							context: [ 1 ];
							yourself.
	
	
	subCommand1 :=  CmBlockCommand new
							name: 'sub command 1';
							block: [ :x | x ];
							context: [ 11 ];
							yourself.
	
	subGroup1 := (CmCommandGroup named: 'sub group 1')
							register: subCommand1;
							yourself.
	
	subGroup2 := CmCommandGroup named: 'sub group 2'. "Empty on purpose."
	
	group
		register: firstCommand;
		register: subGroup1;
		register: subGroup2! !

!CmDuplicatedEntryName commentStamp: ''!
I am the error raised when one tries add an entry in registry for which the name already exists.!
!CmDuplicatedEntryName methodsFor: 'accessing' stamp: ''!
entryName: aString
	entryName := aString! !

!CmDuplicatedEntryName methodsFor: 'accessing' stamp: ''!
entryName
	^ entryName! !

!CmDuplicatedEntryName class methodsFor: 'instance creation' stamp: ''!
forEntryNamed: aString
	^ self new
		entryName: aString;
		yourself! !

!CmDuplicatedEntryName class methodsFor: 'signalling' stamp: ''!
signalEntryNamed: aString
	^ (self forEntryNamed: aString)  signal! !

!CmFakeCommand methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		name: 'Fake command';
		description: 'I am a fake command for testing purposes.'! !

!CmFakeCommand methodsFor: 'accessing' stamp: ''!
dynamicDescription
	^ super dynamicDescription , ' ' , self context asString! !

!CmFakeCommand methodsFor: 'accessing' stamp: ''!
dynamicName
	^ super dynamicName , ' ' , self context asString! !

!CmFakeCommand methodsFor: 'testing' stamp: ''!
canBeExecuted
	^ self context = 42! !

!CmNoShortcutIsDefined commentStamp: ''!
I am raised when no shortcut is defined for a LtSpecCommand but #shortcutKey has been called.!
!CmObject commentStamp: ''!
I am an abstract class defining the API that should be understood by any command or command group.!
!CmObject methodsFor: 'testing' stamp: ''!
isGroup
	^ false! !

!CmObject methodsFor: 'testing' stamp: ''!
isCommand
	^ false! !

!CmTDecorable commentStamp: ''!
I implement methods that a decorable object understand.!
!CmTDecorable methodsFor: 'decorating' stamp: ''!
decorateWith: aDecorator
	^ aDecorator decorate: self! !

!CmTDecorable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CmTDecorable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CmTDecorable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CmTDecorable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CmTDecorable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CmTDecorable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CmTDecorable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CmTDecorable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CmTDecorable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmTDecorable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CmTDecorable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CmTDecorable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CmTDecorable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CmTDecorable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CmTDecorable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CmTDecorable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CmTDecorable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CmTDecorable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmTDecorable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CmTDecorable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CmTDecorable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CmTDecorable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CmTDecorable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CmTDecorable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CmTDecorable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CmTDecorable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CmTDecorator commentStamp: ''!
I implement methods that a decorator object understand.!
!CmTDecorator methodsFor: 'decorating' stamp: ''!
decorate: anObject
	"Decorate anObject. To be defined by users of this trait."
	self explicitRequirement! !

!CmTDecorator classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CmTDecorator classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CmTDecorator classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CmTDecorator classTrait methodsFor: 'instance creation' stamp: ''!
decorate: anObject
	"Create a decorator decorating anObject."
	^ self new
		decorate: anObject;
		yourself! !

!CmTDecorator classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CmTDecorator classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CmTDecorator classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CmTDecorator classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CmTDecorator classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CmTDecorator classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmTDecorator classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CmTDecorator classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CmTDecorator classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CmTDecorator classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CmTDecorator classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CmTDecorator classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CmTDecorator classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CmTDecorator classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CmTDecorator classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmTDecorator classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CmTDecorator classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CmTDecorator classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CmTDecorator classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CmTDecorator classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CmTDecorator classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CmTDecorator classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CmTDecorator classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CmTWithBasicNameAndDescription commentStamp: ''!
I provide #basicDescription and #basicName slots with their accessors and mutators.

I also define #description and #name that are hook to be overrided by my users if they want to generate description or name dynamically (i.e. through computation).!
!CmTWithBasicNameAndDescription methodsFor: 'accessing' stamp: ''!
dynamicDescription
	"This hook is called to generate a description dynamically.
	 In the case of a command, the context can be used to provide additional
	 contextual information to the String returned.
	 When entering this method, one can expect that the context can be accessed
	 through a call to #context method.
	 By default, my #description is returned.
	"
	^ self description! !

!CmTWithBasicNameAndDescription methodsFor: 'accessing' stamp: ''!
description: anObject
	basicDescription := anObject! !

!CmTWithBasicNameAndDescription methodsFor: 'accessing' stamp: ''!
description
	^ basicDescription! !

!CmTWithBasicNameAndDescription methodsFor: 'accessing' stamp: ''!
dynamicName
	"This hook is called to generate a name dynamically.
	 In the case of a command, the context can be used to provide additional
	 contextual information to the String returned.
	 When entering this method, one can expect that the context can be accessed
	 through a call to #context method.
	 By default, my #name is returned.
	"
	^ self name! !

!CmTWithBasicNameAndDescription methodsFor: 'accessing' stamp: ''!
name
	^ basicName! !

!CmTWithBasicNameAndDescription methodsFor: 'accessing' stamp: ''!
name: anObject
	basicName := anObject! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CmTWithBasicNameAndDescription classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CmTWithBasicNameAndDescription classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CmUICommand commentStamp: ''!
I am a command decorator adding informations useful when for usage in context of user interface (UI).

Basically, I add:
- an #icon (#blank by default)
- a #shortcutKey (optional)
- a #displayStrategy to handle how to show the command if it is not executable on a context (default is to be disabled)
- a #positionStrategy to handle on which side presenter with left and right side I should be (default is left)
!
!CmUICommand methodsFor: 'testing' stamp: ''!
hasShortcutKey

	^ shortcutKey isNotNil! !

!CmUICommand methodsFor: 'configuring' stamp: ''!
iconName: aString from: anIconProvider 
	self iconProvider: anIconProvider.
	self iconName: aString.! !

!CmUICommand methodsFor: 'testing' stamp: ''!
hasIcon

	^ self iconName isNotNil! !

!CmUICommand methodsFor: 'configuring' stamp: ''!
beHiddenWhenCantBeRun
	self displayStrategy: CmUIHideWhenCantBeRun new! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
displayStrategy
	^ displayStrategy! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
iconName: aSymbol 
	iconName := aSymbol! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
iconName
	^ iconName! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
iconProvider
	^ iconProvider ifNil: [ iconProvider := Smalltalk ui icons ]! !

!CmUICommand methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	self beDisabledWhenCantBeRun.
	self beDisplayedOnLeftSide! !

!CmUICommand methodsFor: 'configuring' stamp: ''!
beDisabledWhenCantBeRun
	self displayStrategy: CmUIDisableWhenCantBeRun new! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
shortcutKey: aShortcutKey
 	shortcutKey := aShortcutKey! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
displayStrategy: anObject
	displayStrategy := anObject! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
iconProvider: anObject
	iconProvider := anObject! !

!CmUICommand methodsFor: 'configuring' stamp: ''!
beDisplayedOnRightSide
	positionStrategy := CmUIRightPositionStrategy new! !

!CmUICommand methodsFor: 'configuring' stamp: ''!
beDisplayedOnLeftSide
	positionStrategy := CmUILeftPositionStrategy new! !

!CmUICommand methodsFor: 'printing' stamp: ''!
printOn: stream 

	super printOn: stream.
	stream << '(' << self name << ')'! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
icon
	self iconName ifNil: [ ^ nil ].
	
	^ self iconNamed: self iconName! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
positionStrategy
	^ positionStrategy! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
iconNamed: aSymbol
	^ self iconProvider iconNamed: aSymbol! !

!CmUICommand methodsFor: 'accessing' stamp: ''!
shortcutKey
	^ shortcutKey ifNil: [ CmNoShortcutIsDefined signalCommand: self ]! !

!CmUICommandDisplayStrategy commentStamp: ''!
I allow to configure how a group display itself when shown in UI.!
!CmUICommandDisplayStrategy methodsFor: '*Spec2-Commander2' stamp: ''!
display: aCmSpecCommand in: aMenuOrGroupPresenter do: aBlock
	aMenuOrGroupPresenter
		addItem: [ :item |
			aBlock value: item.
			item enabled: aCmSpecCommand canBeExecuted.
			item ]! !

!CmUICommandDisplayStrategy methodsFor: '*Iceberg-TipUI' stamp: ''!
ifVisible: aCmSpecCommand do: aBlock

	self subclassResponsibility! !

!CmUICommandGroup commentStamp: ''!
I am a command group decorator adding informations useful when for usage in context of user interface (UI).

Basically, I add:
- an #icon (#blank by default)
- the strategy to display commands group in a menu (I am displayed as a sub-menu by default).!
!CmUICommandGroup methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self displayStrategy: self class defaultDisplayStrategy.
	self isRoot: false! !

!CmUICommandGroup methodsFor: 'accessing' stamp: ''!
displayStrategy
	^ displayStrategy! !

!CmUICommandGroup methodsFor: 'configuring' stamp: ''!
beDisplayedAsGroup
	self displayStrategy: CmUIDisplayAsGroup new! !

!CmUICommandGroup methodsFor: 'accessing' stamp: ''!
iconName: aSymbol


	self icon: (self iconNamed: aSymbol)! !

!CmUICommandGroup methodsFor: 'accessing' stamp: ''!
isRoot
	^ isRoot! !

!CmUICommandGroup methodsFor: 'accessing' stamp: ''!
displayStrategy: anObject
	displayStrategy := anObject! !

!CmUICommandGroup methodsFor: 'configuring' stamp: ''!
beRoot
	self isRoot: true.! !

!CmUICommandGroup methodsFor: 'configuring' stamp: ''!
beDisplayedAsSubMenu
	self displayStrategy: CmUIDisplayAsSubMenu new! !

!CmUICommandGroup methodsFor: 'accessing' stamp: ''!
icon 

	^ icon! !

!CmUICommandGroup methodsFor: 'accessing' stamp: ''!
isRoot: anObject
	isRoot := anObject! !

!CmUICommandGroup methodsFor: 'accessing' stamp: ''!
icon: anIcon

	icon := anIcon! !

!CmUICommandGroup class methodsFor: 'default' stamp: ''!
defaultIconName
	^ #blank! !

!CmUICommandGroup class methodsFor: 'default' stamp: ''!
defaultDisplayStrategy

	^ CmUIDisplayAsSubMenu new! !

!CmUICommandGroupDisplayStrategy commentStamp: ''!
I allow to configure how a command group display when shown in UI.!
!CmUICommandGroupDisplayStrategy methodsFor: '*Spec2-Commander2' stamp: ''!
display: aCmSpecCommandGroup in: aMenuPresenter do: aBlock
	self subclassResponsibility! !

!CmUICommandTest commentStamp: ''!
A CmUICommandTest is a test class for testing the behavior of CmUICommand!
!CmUICommandTest methodsFor: 'tests' stamp: ''!
testIcon
	self assert: command icon isNil.
	
	command iconName: #add.
	
	self assert: command icon equals: (command iconNamed: #add).! !

!CmUICommandTest methodsFor: 'tests' stamp: ''!
testIconNameFrom
	self assert: command iconProvider equals: Smalltalk ui icons.
	
	command iconName: #banana from: self.
	
	self assert: command iconProvider equals: self.
	self assert: (command icon) equals: self banana! !

!CmUICommandTest methodsFor: 'tests' stamp: ''!
testShortcutKey
	self should: [ command shortcutKey ] raise: CmNoShortcutIsDefined.
	
	command shortcutKey: $a asKeyCombination.
	
	self assert: command shortcutKey equals:  $a asKeyCombination! !

!CmUICommandTest methodsFor: 'tests' stamp: ''!
testIconName
	self assert: command iconName isNil.
	
	command iconName: #add.
	
	self assert: command iconName equals: #add! !

!CmUICommandTest methodsFor: 'tests' stamp: ''!
testHasIcon
	self deny: command hasIcon.
	
	command iconName: #banana.
	
	self assert: command hasIcon! !

!CmUICommandTest methodsFor: 'tests' stamp: ''!
testIconProvider
	self assert: command iconProvider equals: Smalltalk ui icons.
	
	command iconProvider: self.
	
	self assert: command iconProvider equals: self.
	
	command iconName: #banana.
	self assert: (command icon) equals: self banana! !

!CmUICommandTest methodsFor: 'tests' stamp: ''!
testHasShortcutKey
	self deny: command hasShortcutKey.
	
	command shortcutKey: $a asKeyCombination.
	
	self assert: command hasShortcutKey.! !

!CmUICommandTest methodsFor: 'helpers' stamp: ''!
iconNamed: aSymbol
	aSymbol ~= #banana
		ifTrue: [ self error: 'Only #banana icon is needed for tests.' ].
		
	^ self banana! !

!CmUICommandTest methodsFor: 'helpers' stamp: ''!
banana
	"Does not return an icon, it is not needed for the test."
	^ 42! !

!CmUICommandTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	command := CmUICommand new! !

!CmUIDisableWhenCantBeRun commentStamp: ''!
I implement the fact that the button corresponding to a command is disabled when it can not be run.!
!CmUIDisableWhenCantBeRun methodsFor: '*Spec2-Commander2' stamp: ''!
display: aCmSpecCommand in: aMenuOrGroupPresenter do: aBlock
	aMenuOrGroupPresenter
		addItem: [ :item |
			aBlock value: item.
			item enabled: aCmSpecCommand canBeExecuted.
			item ]! !

!CmUIDisableWhenCantBeRun methodsFor: '*Iceberg-TipUI' stamp: ''!
ifVisible: aCmSpecCommand do: aBlock
	"Always visible"

	aBlock value! !

!CmUIDisplayAsGroup commentStamp: ''!
I display a command group as a group in the MenuPresenter.!
!CmUIDisplayAsGroup methodsFor: '*Spec2-Commander2' stamp: ''!
display: aCmSpecCommandGroup in: aMenuPresenter do: aBlock

	aMenuPresenter addGroup: [ :menuGroup |
		aBlock value: menuGroup ]! !

!CmUIDisplayAsSubMenu commentStamp: ''!
I display a command group as a submenu in the MenuPresenter.!
!CmUIDisplayAsSubMenu methodsFor: '*Spec2-Commander2' stamp: ''!
display: aCmSpecCommandGroup in: aMenuPresenter do: aBlock

	aMenuPresenter addItem: [ :menuItem |
		menuItem subMenu: (self 
			fillSubMenuIn: menuItem 
			with: aCmSpecCommandGroup 
			do: aBlock) ]! !

!CmUIDisplayAsSubMenu methodsFor: '*Spec2-Commander2' stamp: ''!
fillSubMenuIn: menuItem with: aCmSpecCommandGroup do: aBlock
	| subMenu |
	
	menuItem
		name: aCmSpecCommandGroup name;
		description: aCmSpecCommandGroup description;
		icon: aCmSpecCommandGroup icon.
	subMenu := SpMenuPresenter new.
	aBlock value: subMenu.
	^ subMenu! !

!CmUIHideWhenCantBeRun commentStamp: ''!
I implement the fact that the button corresponding to a command is hidden when it can not be run.!
!CmUIHideWhenCantBeRun methodsFor: '*Spec2-Commander2' stamp: ''!
display: aCmSpecCommand in: aMenuOrGroupPresenter do: aBlock
	aCmSpecCommand canBeExecuted "If can not be run, stop because we want to hide the command."
		ifFalse: [ ^ self ].
	aMenuOrGroupPresenter
		addItem: [ :item |
			aBlock value: item.
			item ]! !

!CmUIHideWhenCantBeRun methodsFor: '*Iceberg-TipUI' stamp: ''!
ifVisible: aCmSpecCommand do: aBlock
	"Visible if #canBeExecuted"

	aCmSpecCommand canBeExecuted ifTrue: aBlock! !

!CmUILeftPositionStrategy commentStamp: ''!
I set the button generated from a command on the left side of the UI.!
!CmUILeftPositionStrategy methodsFor: '*Spec2-Commander2' stamp: ''!
addButton: aButtonPresenter toToolbar: aToolbarPresenter
	aToolbarPresenter addItemLeft: aButtonPresenter! !

!CmUILeftPositionStrategy methodsFor: '*Spec2-Commander2' stamp: ''!
addButton: aButtonPresenter toActionBar: anActionBarPresenter
	anActionBarPresenter add: aButtonPresenter! !

!CmUILeftPositionStrategyExtensionsTest commentStamp: ''!
A SpSetButtonLeftStrategyTest is a test class for testing the behavior of SpSetButtonLeftStrategy!
!CmUILeftPositionStrategyExtensionsTest methodsFor: 'tests' stamp: ''!
testAddButtonToActionBar
	| actionBar button |
	actionBar := SpActionBarPresenter new.
	button := SpButtonPresenter new.
	
	self assertEmpty: actionBar items.
	
	CmUILeftPositionStrategy new
		addButton: button toActionBar: actionBar.
		
	self assert: actionBar items size equals: 1.
	self assert: (actionBar items includesKey: #start).
	self assert: (actionBar items at: #start) size equals: 1.
	self assert: (actionBar items at: #start) anyOne equals: button! !

!CmUILeftPositionStrategyExtensionsTest methodsFor: 'tests' stamp: ''!
testAddButtonToToolbar
	| toolbar button |
	toolbar := SpToolbarPresenter new.
	button := SpToolbarButtonPresenter new.
	
	self assertEmpty: toolbar items.
	
	CmUILeftPositionStrategy new
		addButton: button toToolbar: toolbar.
		
	self assert: toolbar leftItems size equals: 1.
	self assert: toolbar leftItems anyOne equals: button.
	self assertEmpty: toolbar rightItems! !

!CmUIPositionStrategy commentStamp: ''!
I model a strategy to add a command for which it can be either left or right in the UI.!
!CmUIPositionStrategy methodsFor: '*Spec2-Commander2' stamp: ''!
addButton: aButtonPresenter toToolbar: aToolbarPresenter
	self subclassResponsibility! !

!CmUIPositionStrategy methodsFor: '*Spec2-Commander2' stamp: ''!
addButton: aButtonPresenter toActionBar: anActionBarPresenter
	self subclassResponsibility! !

!CmUIRightPositionStrategy commentStamp: ''!
I set the button generated from a command on the right side of the UI.!
!CmUIRightPositionStrategy methodsFor: '*Spec2-Commander2' stamp: ''!
addButton: aButtonPresenter toToolbar: aToolbarPresenter
	aToolbarPresenter addItemRight: aButtonPresenter! !

!CmUIRightPositionStrategy methodsFor: '*Spec2-Commander2' stamp: ''!
addButton: aButtonPresenter toActionBar: anActionBarPresenter
	anActionBarPresenter addLast: aButtonPresenter! !

!CmUIRightPositionStrategyExtensionsTest commentStamp: ''!
A SpSetButtonRightStrategyTest is a test class for testing the behavior of SpSetButtonRightStrategy!
!CmUIRightPositionStrategyExtensionsTest methodsFor: 'tests' stamp: ''!
testAddButtonToActionBar
	| actionBar button |
	actionBar := SpActionBarPresenter new.
	button := SpButtonPresenter new.
	
	self assertEmpty: actionBar items.
	
	CmUIRightPositionStrategy new
		addButton: button toActionBar: actionBar.
		
	self assert: actionBar items size equals: 1.
	self assert: (actionBar items includesKey: #end).
	self assert: (actionBar items at: #end) size equals: 1.
	self assert: (actionBar items at: #end) anyOne equals: button! !

!CmUIRightPositionStrategyExtensionsTest methodsFor: 'tests' stamp: ''!
testAddButtonToToolbar
	| toolbar button |
	toolbar := SpToolbarPresenter new.
	button := SpToolbarButtonPresenter new.
	
	self assertEmpty: toolbar items.
	
	CmUIRightPositionStrategy new
		addButton: button toToolbar: toolbar.
		
	self assert: toolbar rightItems size equals: 1.
	self assert: toolbar rightItems anyOne equals: button.
	self assertEmpty: toolbar leftItems! !

!CmVisitor commentStamp: ''!
I am the implementation of the visitor design pattern for commands and commands group.
I am abstract, my subclasses should at least implement `#visitCommand:`.
I define default behaviour for visiting a command group.!
!CmVisitor methodsFor: 'visiting' stamp: ''!
visitCommandGroup: aCmCommandsGroup
	^ aCmCommandsGroup entries collect: [ :entry |
		entry acceptVisitor: self ]! !

!CmVisitor methodsFor: 'visiting' stamp: ''!
visitCommand: aCmCommandEntry
	^ self subclassResponsibility! !

!CmVisitor methodsFor: 'visiting' stamp: ''!
visit: anObject
	^ anObject acceptVisitor: self! !

!CmdAbstractCommandExample class methodsFor: 'activation' stamp: ''!
activationExample1
	<classAnnotation>
	
	^CmdCommandActivationExample for: CmdToolContextStub1! !

!CmdAbstractCommandExample class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = CmdAbstractCommandExample! !

!CmdClickActivation commentStamp: ''!
I represent activation of commands using mouse click event!
!CmdClickActivation class methodsFor: 'morphs setup' stamp: ''!
morphicEventType
	^#click! !

!CmdClickActivation class methodsFor: 'morphs setup' stamp: ''!
enableInMorph: aMorph withCommandsFrom: someObjectWithCommandContext
	super enableInMorph: aMorph withCommandsFrom: someObjectWithCommandContext.
	
	"Following subscribtion is requried because morphic does not generate mouse click 
	when right mouse (yellow) was clicked. In that case mouse up is triggered"
	
	aMorph 
		on: #mouseUp
		send: #handleYellowMouseClickUsing:event:from: to: self withValue: someObjectWithCommandContext! !

!CmdClickActivation class methodsFor: 'morphs setup' stamp: ''!
handleYellowMouseClickUsing: someObjectWithCommandContext event: anEvent from: sourceMorph

	anEvent yellowButtonChanged ifFalse: [ ^ self ].
	
	^self handleMouseUsing: someObjectWithCommandContext event: anEvent from: sourceMorph! !

!CmdCommand commentStamp: ''!
I am a root of first class commands hierarchy. 
My subclasses should just implement #execute method with all required state which is needed for command execution. 
Then users can attach various activation strategies to them which provide specific way how to create command instances, how to represent them to user, how initialize their state.

Activation strategies annotate command classes as class annotation. Look at ClassAnnotation for details.
For example to make YourCommand executable by shortcut you need to add following method to class side of command:
	YourCommand class>>yourAppShortcutActivation
		<classAnnotation>
		^CmdShortcutCommandActivation by: $e meta for: YourAppContext 
If you want execute command from context menu you need another activator:
	YourCommand class>>yourAppMenuActivation
		<classAnnotation>
		^CmdContextMenuCommandActivation byRootGroupItemFor: YourAppContext 

Any activation should be created for concrete context of application tool, subclass of CmdToolContext. In examples above it is YourAppContext.
To be able to use commands application/tool should provide instance of current context to perform command lookup:

	CmdShortcutCommandActivation allAvailableInContext: aToolContext do: blockWithActivation

It enumerate all shortcut activation strategies which are declared for given aToolContext. 
Found activation can check if command can be executed in given context or not:
	registeredActivation canExecuteCommandInContext: aToolContext
which  delegates question to context and then to command:
	aToolContext allowsExecutionOf: command
	command canBeExecutedInContext: aToolContext
By default It returns true. But my subclasses can implement it using specific information of given context.
It is important that this message is not taken into account in enumeration method. There are cases when users want all commands including the commands which could not be executed in current context. For example in context menu such commands can be disabled and it can be important to show them in special unclickable state. Currently all "disabled" commands are skipped during menu building. But it can be configurable in future versions.

Next thing to do with found activation is to create new activator instance which is responsible for command execution in given context:
	commandActivator := activationStrategy newActivatorFor: aToolContext
Command activator keeps information about activation context and it is able to execute command. It initializes command with the state relevant to the current context:
	command readParametersFromContext:  aToolContext 
By default It is the empty method and usually commands not override it. There is another method to prepare full state of command just before execution (see below). And for simplicity commands usually implement only this.
Some tools collect activators to represent commands to user. For example in context menu every item is based on activator. Using command instance it provides label and icon for the menu item. Commands provide default values for them which sometimes depend on internal command state. For such cases commands retrieve this state in advance from the given context instance in the method readParametersFromStandardContext:.

Command activator can execute the command:
	commandActivator executeCommand
It performs three steps:
1) Prepare command for execution.  Command should retrieve all state required for execution from given context. By default activator asks command using:
	command prepareFullExecutionInContext: aToolContext
During preparation commands can ask user for extra data. 
I provide empty implementation for this method and my subclasses overrides it.
Commands can signal CmdCommandAborted to break execution process. For example It happens when user cancel confirmation dialog during command preparation.

2) Command execution. All logic is implemented by command in #execute method.

3) Applying execution result to given context:
	command applyResultInContext: aToolContext 
Idea is to be able interract with application when command completes. For example if user creates new package from the browser then at the end the browser should  open created package.

Commands are supposed to be reusable for different contexts and activators. And these methods should be implemented with that in mind. They should not discover internal structure of contexts.

t is possible to override activation methods for specific contexts and send own set of messages to command. For example: 

	SpecialContextA>>allowsExecutionOf: aCommand
		 ^aCommand canBeExecutedInSpecialContextA: self
	
	SpecialContextA>>prepareFullExecutionOf: aCommand
		 aCommand prepareFullExecutionInSpecialContextA: self

	SpecialContextA>>applyResultOf: aCommand
		 aCommand applyResultInSpecialContextA: self

By default I can implement these extensions with standard context methods. And only particular subclasses will override them specifically:

	CmdCommand>>prepareFullExecutionInSpecialContextA: aSpecialContextA
		 self prepareFullExecutionInContext: aSpecialContextA

	SomeCommand>>prepareFullExecutionInSpecialContextA: aSpecialContextA
 		 "special logic to prepare command for execution"

Besides, specific command activation strategies can require own set of activation methods. For example CmdDragAndDropCommandActivator needs two contexts to prepare command. First context describes the place where drag was started. Last context describes drop target tool.  And for execution command should be prepared in both context. They bring different information and together they are supposed to provide all required data for command execution without extra user requests. 

Different activation strategies extends me with UI related messages. For example look at context menu activation. It asks me to build menu items:
	command fillContextMenu: aMenu using: anActivator
By default I just create standart item morph and allow subclasses to define default label and icon:	
- defaultMenuItemName
- setUpIconForMenuItem: aMenuItemMorph
But subclasses can override build method and represent themselves more specifically. For example they can provide menu item with check box. You can see such cases in morph menu.

The way how concrete type of activation strategy hook into application is responsibility of application. For example to support shortcuts based on commands application should define specific kmDispatcher for target morphs:
	YourAppMorph>>kmDispatcher
		^ CmdKMDispatcher attachedTo: self
with supporting method:
	YourAppMorph>>createCommandContext
		^YourAppContext for: self
		
If application wants context menu based on commands then it needs to hook into context menu part of application and ask context menu activation to build menu:
	menu := CmdContextMenuCommandActivator buildMenuFor: anAppMorph inContext: aToolContext
	
In future Commander will be deeply integrated in UI. So many things will work automatically!
!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
decorateTableCell: anItemCellMorph with: aMorph

	anItemCellMorph definitionMorph: aMorph! !

!CmdCommand methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
registerContextMenuItemsFor: aCommandItem withBuilder: aBuilder
	
	^ self doRegisterContextMenuItemsFor: aCommandItem withBuilder: aBuilder! !

!CmdCommand methodsFor: '*SystemCommands-RefactoringSupport' stamp: ''!
confirmRefactoringInContext: aToolContext by: aCommandActivator
	| submitDialog |
	submitDialog := SycRefactoringPreviewPresenter
		for: self
		scopes: aToolContext refactoringScopes.
	submitDialog existChanges ifTrue:[
	submitDialog openDialogWithSpec
		okAction: [ submitDialog accept.
			aCommandActivator applyCommandResult ];
		cancelAction: [ :p | p beCancel ]]
	ifFalse: [ submitDialog alert: 'There is no change produced by this refactoring' ].
	CmdCommandAborted signal! !

!CmdCommand methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
setUpIconForMenuItem: aMenuItemMorph

	self defaultMenuIcon ifNotNil: [:icon |
		aMenuItemMorph icon: icon ]! !

!CmdCommand methodsFor: 'accessing' stamp: ''!
description
	"By default the result is nil which is not really nice 
	but it is already expected by many tools. So it is easy to allow nil"
	^nil! !

!CmdCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	"For compatibility default instance side method delegates to class side.
	But normally it should just return 
		self class name"
	
	^self class defaultMenuItemName! !

!CmdCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIcon
	"By default the result is nil which is not really nice 
	but it is already expected by many tools.	So it is easy to allow nil.
	For simple cases users should implement class side method #defaultMenuIconName"
	^self defaultMenuIconName ifNotNil: [ :iconName | 
		Smalltalk ui iconNamed: iconName ]! !

!CmdCommand methodsFor: 'execution' stamp: ''!
execute
	self subclassResponsibility! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
defaultToolbarItemName
	^self defaultMenuItemName! !

!CmdCommand methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
fillContextMenu: aMenu using: aCommandActivator
	| item |
	
	item := aMenu 
		add: aCommandActivator menuItemName
		target: aCommandActivator 
		selector: #executeCommand.
	
	aCommandActivator setUpShortcutTipForMenuItem: item.
	self setUpIconForMenuItem: item.
	self description ifNotNil: [:d | item setBalloonText: d]! !

!CmdCommand methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
prepareExecutionInDragContext: aToolContext! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
tableCellIcon

	^self secureMenuIcon! !

!CmdCommand methodsFor: 'accessing' stamp: ''!
secureMenuIcon
	"In case when icon should be mandatory property of command
	users should call this method. It ensure Form instance 
	which will indicate missing icon as a problem"
	
	^self defaultMenuIcon ifNil: [ Smalltalk ui iconNamed: #error ]! !

!CmdCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aToolContext! !

!CmdCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
createTableCellButtonUsing: aCommandActivator

	| icon |
	icon := self tableCellIcon.
	
	^self createTableCellButtonWith: icon using: aCommandActivator.! !

!CmdCommand methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
doRegisterContextMenuItemsFor: aCommandItem withBuilder: aBuilder
	| item itemOrder |
	itemOrder := aCommandItem order.
	aCommandItem parentGroup isRoot not & aCommandItem parentGroup isInlined ifTrue: [ 
		"When we are inlining we should try keep order according to the order of parent.
		So we just put item order as deimal addition to parent order"
		itemOrder := aCommandItem parentGroup order + (itemOrder / 10000000.0)].
	item := (aBuilder item: aCommandItem name)
		parent: aCommandItem actualParentGroup name;
		order: itemOrder;
		help: aCommandItem description;
		action: [aCommandItem executeCommand]. 
	
	aCommandItem setUpShortcutTipForMenuItem: item.
	self setUpIconForMenuItem: item! !

!CmdCommand methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
applyDropResultInContext: aToolContext! !

!CmdCommand methodsFor: '*SystemCommands-RefactoringSupport' stamp: ''!
isComplexRefactoring
	^false! !

!CmdCommand methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
prepareExecutionInDropContext: aToolContext! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
addToolbarItemInto: toolbarMorph using: aCommandActivator
	
	| item |
	item := self createToolbarItemFor: aCommandActivator.
	self decorateToolbarItem: item.
	toolbarMorph addNewItem: item! !

!CmdCommand methodsFor: '*SystemCommands-RefactoringSupport' stamp: ''!
executeRefactorings
	self asRefactorings do: [ :each | each execute ]! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserTabActionsUsing: aCommandActivator

	^{
		TabAction 
			action: [ aCommandActivator executeCommand ]
			icon: self browserTabActionIcon
			label: aCommandActivator commandDescription
	}! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
createToolbarItemFor: aCommandActivator
	
	^ClyBrowserButtonMorph activatingBy: aCommandActivator! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserNotebookActionsUsing: aCommandActivator
	
	^ { ClyNotebookPageActionButtonMorph forAction: (ClyNotebookPageAction 
		action: [ aCommandActivator executeCommand ]
		icon: self browserTabActionIcon
		label: aCommandActivator commandDescription) }! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
createTableCellButtonWith: anIcon using: aCommandActivator

	^IconicButtonMorph new
		target: aCommandActivator;
		actionSelector: #executeCommand;
		color: Color transparent;
		helpText: self defaultMenuItemName;
		borderWidth: 0;
		labelGraphic: anIcon;
		extent: anIcon extent! !

!CmdCommand methodsFor: 'converting' stamp: ''!
asCommandActivator
	^CmdCommandActivator new 
		command: self;
		context: CmdNullToolContext new;
		activationStrategy: (CmdManualActivationStrategy withAnnotatedClass: self class)! !

!CmdCommand methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
setUpIconNamed: aString forMenuItem: aMenuItemMorph

	aMenuItemMorph icon: (aMenuItemMorph iconNamed: aString)! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
decorateToolbarItem: aBrowserToolbarItem

	self description ifNotNil: [ :d | 
		aBrowserToolbarItem setBalloonText: d ].
	
	self defaultMenuIcon ifNotNil: [:icon |
		aBrowserToolbarItem addIcon: icon asMorph]! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
browserTabActionIcon

	^self secureMenuIcon! !

!CmdCommand methodsFor: '*Calypso-Browser' stamp: ''!
decorateTableCell: anItemCellMorph using: aCommandActivator

	| button |
	button := self createTableCellButtonUsing: aCommandActivator.
		
	self decorateTableCell: anItemCellMorph with: button! !

!CmdCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext! !

!CmdCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	"For compatibility it delegates actual logic to class side. But it should be just 
		^nil
	Not really nice to return nil. But it is already expected by many tools.
	So it is easy to allow nil.
	When users want to define real icon instead of standard named icon
	they should override another instance side method #defaultMenuIcon
	which should return desired Form instance"
	^self class defaultMenuIconName! !

!CmdCommand methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
canBeExecutedInDropContext: aToolContext
	^true! !

!CmdCommand class methodsFor: '*Commander-Spec2-Compatibility' stamp: ''!
defaultHelp
	^ self defaultMenuItemName! !

!CmdCommand class methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	"It should be defined on instance side. 
	But for compatibility default instance side method delegates to class side"
	^self name! !

!CmdCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = CmdCommand! !

!CmdCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^true! !

!CmdCommand class methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	"For compatibility the actual icon named can be defined on class side.
	But right way it to use same instance side method.

	Not really nice to return nil. But it is already expected by many tools.
	So it is easy to allow nil.
	But users should use instance side method defaultMenuIcon which should return Form instance"
	^nil! !

!CmdCommandAborted commentStamp: ''!
I am exception which used to break command execution. 
Usually I am signalled during command preparation when user declines UI request !
!CmdCommandAborted methodsFor: 'notification' stamp: ''!
notifyUserOfCommand: aCommand! !

!CmdCommandActivationStrategy commentStamp: ''!
I am a root of command activation strategy hierarchy. My subclasses represent different ways how to access and execute commands in specific context, how to represent them to user, how initialize their state.

Users attach concrete activation strategy to commands as class annotation (look at ClassAnnotation comment).
For example to make YourCommand executable by shortcut you need following method:
	YourCommand class>>yourAppShortcutActivator
		<classAnnotation>
		^CmdShortcutCommandActivator by: $e meta for: YourAppContext 

My instances should be created for concrete context of application tool, subclass of CmdToolContext. Application/tool provides instance of this context for the command lookup:
	CmdShortcutCommandActivation allAvailableInContext: aToolContext do: [:activationStrategy  | ]
This method enumerates all registered strategies which are declared to be used in given context. You can check it  manually: 
	anActivationStrategy canBeUsedInContext: aToolContext
There is another enumaration method to access all strategies which are able execute commands in specified context:
	CmdShortcutCommandActivation allExecutableInContext: aToolContext do: [:activationStrategy  | ]
Each command defines the method which checks that given context is appropriate for command execution:
	commandClass canBeExecutedInContext: aToolContext.
Also you can ask the activation strategy about it:
	anActivationStrategy canExecuteCommandInContext: aToolContext

My instances itself are not supposed to execute commands. For this purpose you  need an activator instances:
	activator := anActivationStrategy newActivatorFor: aToolContext
The activator instance incapsulates the current context where command should be executed. And you can work with it as a self containt object.
You can check if activator can execute the command:
	activator canExecuteCommand
You can execute the command:
	activator executeCommand
Internally activator creates command instance and initializes it with the state related to the current context. 
But actual logic of these operations is implemented by command itself. So activator delegates it to the command:
	command readParametersFromContext:  context 
	command prepareFullExecutionInContext: context
	command execute.
Initialization logic of the command depends on the type of activation strategy. For example drag and drop activation will require two steps to prepare command:
	command prepareExecutionInDragContext: aToolContext
It will initialize the state of command which is available from the context of drag operation.
	command prepareExecutionInDropContext: aToolContext
It will initialize the state of command in the context of drop operation.

Look at CmdCommand and CmdCommandActivator for details on these logic.

I also provide simple method to work with all commands using activators prepared for the given context:
	activationStrategyClass activateAllInContext: aToolContext by: [:activator | ]
Also you can collect all these activators:
	activationStrategyClass creatActivatorsExecutableInContext: aToolContext
	
Internal Representation and Key Implementation Points.

    Instance Variables
	contextDefinition:		<CmdContextDefinition>	definition of the context where command can be activated!
!CmdCommandActivationStrategy methodsFor: 'accessing' stamp: ''!
commandClass
	^annotatedClass! !

!CmdCommandActivationStrategy methodsFor: 'activation' stamp: ''!
defaultActivatorClass
	^CmdCommandActivator! !

!CmdCommandActivationStrategy methodsFor: 'testing' stamp: ''!
isActiveInContext: aToolContext
	^(super isActiveInContext: aToolContext)
		and: [ aToolContext allowsExecutionOf: self commandClass]! !

!CmdCommandActivationStrategy methodsFor: 'activation' stamp: ''!
newActivatorFor: aToolContext
	
	^self defaultActivatorClass
		for: self commandClass
		inContext: aToolContext 
		using: self! !

!CmdCommandActivationStrategy methodsFor: 'testing' stamp: ''!
isForbidden
	^self commandClass isAbstract! !

!CmdCommandActivationStrategy class methodsFor: 'activation' stamp: ''!
createActivatorsExecutableInContext: aToolContext
	| result |
	result := OrderedCollection new.
	
	self 
		activateAllInContext: aToolContext 
		by: [:each | result add: each].
		
	^result! !

!CmdCommandActivationStrategy class methodsFor: 'activation' stamp: ''!
activateAllInContext: aToolContext by: blockWithActivator

	self 
		activeInstancesInContext: aToolContext 
		do: [:activationStrategy | 
			blockWithActivator value: (activationStrategy newActivatorFor: aToolContext)]! !

!CmdCommandActivationStrategyTest methodsFor: 'tests' stamp: ''!
testCreationNewActivatorForGivenContext
	| activation context actual |
	activation := CmdCommandActivationExample withAnnotatedClass: CmdCommandExampleInheritedFromAbstract.
	context := CmdToolContextStub new.
	
	actual := activation newActivatorFor: context.
	
	self assert: actual class equals: CmdCommandActivator.
	self assert: actual activationStrategy equals: activation.
	self assert: actual context equals: context.
	self assert: actual command class equals: CmdCommandExampleInheritedFromAbstract.
	self assert: actual command savedParametersContext equals: context! !

!CmdCommandActivationStrategyTest methodsFor: 'tests' stamp: ''!
testIteratingInstancesShouldSkipAbstractCommands

	| activators context |
	context := CmdToolContextStub1 new.
	activators := OrderedCollection new.
	CmdCommandActivationExample  
		visibleInstancesInContext: context
		do: [:activator | activators add: activator].
	
	self assert: activators size equals: 1.
	self assert: activators first commandClass equals: CmdCommandExampleInheritedFromAbstract! !

!CmdCommandActivator commentStamp: ''!
I responsible to execute the command instance in concrete application context according to given activation strategy. 

I define three steps to execute command:

1) #prepareCommandForExecution. Command should retrieve all state required for execution from activation context. By default ths logic is delegated to the command though context instance:
	CmdCommandActivator>>prepareCommandForExecution
		actualActivationContext prepareExecutionOf: command  
During preparation commands can break execution by signalling CmdCommandAborted. For example It should happen if user cancel some confirmation dialog during command preparation.

2) Command execution. All logic is implemented by command itself (#execute method).
	command execute.
	
3) Applying execution result to activation context. It is also delegated to the command itself though context instance:
	CmdCommandActivator>>applyCommandResult
		actualActivationContext applyResultOf: command  
Idea is to be able interact with application when command completes. For example if user creates new package from browser then at the end the browser should open created package.
 
For more details look at CmdCommand comments.

I am able to check if comand can be executed in my context:
	activator canExecuteCommand

Different packages extends me to represent commands according to concrete activation strategy. For example context menu will ask me to create menu items. In such cases I just delegate actual logic to the command itself.

Complex activation strategy can provide my subclasses. For example Drag&Drop command activation requires two steps to prepare and execute command. And there is CmdDragAndDropCommandActivator which incapsulates two active contexts where command should be executed. Look at it for details.  

My instances are created by activation strategy:
	activationStratagy newActivatorFor: aToolContext

Internal Representation and Key Implementation Points.

    Instance Variables
	command:		<CmdCommand> an activating command
	context:		<CmdToolContext>	an active context where command is activated
	activationStrategy:		<CmdCommandActivationStrategy>	strategy which defines how command should be accessed and executed in given context!
!CmdCommandActivator methodsFor: 'execution' stamp: ''!
executeCommand

	[self prepareCommandForExecution.
	context executeCommand: command by: self.
	self applyCommandResult] 
		on: Exception do: [ :exc | self processCommandFailure: exc ]! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!CmdCommandActivator methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
buildContextMenu: aMenu
	
	self canExecuteCommand ifFalse: [ ^self ].
	
	command fillContextMenu: aMenu using: self! !

!CmdCommandActivator methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
registerContextMenuItemsFor: aCommandItem withBuilder: aBuilder
	
	self canExecuteCommand ifFalse: [ ^self ].
	
	command registerContextMenuItemsFor: aCommandItem withBuilder: aBuilder! !

!CmdCommandActivator methodsFor: '*Calypso-Browser' stamp: ''!
isCommandAppliedToBrowser

	^command isAppliedToBrowser! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
menuItemName
	^activationStrategy menuItemNameFor: command! !

!CmdCommandActivator methodsFor: 'testing' stamp: ''!
canExecuteCommand

	^activationStrategy isActiveInContext: context! !

!CmdCommandActivator methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherCommandActivator

	^(activationStrategy isSimilarTo: anotherCommandActivator activationStrategy)
		and: [context isSimilarTo: anotherCommandActivator context ]! !

!CmdCommandActivator methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream nextPut: $(.
	command printOn: aStream.
	aStream nextPut: $).! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
menuItemIcon
	^self command defaultMenuIcon! !

!CmdCommandActivator methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserNotebookActions

	self canExecuteCommand ifFalse: [ ^ #() ].
	
	^ command buildBrowserNotebookActionsUsing: self! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
activationStrategy: anObject
	activationStrategy := anObject! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
activationStrategy
	^ activationStrategy! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
commandDescription

	^command description ifNil: [ self menuItemName ]! !

!CmdCommandActivator methodsFor: 'execution' stamp: ''!
prepareCommandForExecution
	context prepareFullExecutionOf: command! !

!CmdCommandActivator methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserTabActions

	self canExecuteCommand ifFalse: [ ^#() ].
	
	^command buildBrowserTabActionsUsing: self! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
newForCommand: aCommand
	
	| copy |
	copy := self copy.
	copy command: aCommand.
	^copy! !

!CmdCommandActivator methodsFor: '*Commander-Spec2-Compatibility' stamp: ''!
help
	^ self command class defaultHelp.! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
menuItemOrder
	^activationStrategy menuItemOrder! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
command
	^ command! !

!CmdCommandActivator methodsFor: 'testing' stamp: ''!
activatesCommand: aCommandClass 
	^activationStrategy annotates: aCommandClass! !

!CmdCommandActivator methodsFor: 'accessing' stamp: ''!
command: anObject
	command := anObject! !

!CmdCommandActivator methodsFor: '*Commander-Spec2-Compatibility' stamp: ''!
getShortcutTipForMenuItem
	CmdShortcutActivation
		activeInstancesFor: command class
		inContext: context
		do:
			[ :shortcut | "this is trick to show shortcut on menu with existing menu support" 
			^ shortcut keyCombination ].
		^nil! !

!CmdCommandActivator methodsFor: '*Calypso-Browser' stamp: ''!
decorateTableCell: anItemCellMorph 

	command decorateTableCell: anItemCellMorph using: self! !

!CmdCommandActivator methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserToolbar: toolbarMorph

	self canExecuteCommand ifFalse: [ ^self ].
	
	command addToolbarItemInto: toolbarMorph using: self! !

!CmdCommandActivator methodsFor: '*NewTools-Spotter' stamp: ''!
evaluateFor: aStSpotter 
	
	self doEvaluate! !

!CmdCommandActivator methodsFor: 'converting' stamp: ''!
asCommandActivator
	^self! !

!CmdCommandActivator methodsFor: 'execution' stamp: ''!
processCommandFailure: anException
	
	context processFailure: anException of: command! !

!CmdCommandActivator methodsFor: 'execution' stamp: ''!
applyCommandResult
	context applyResultOf: command! !

!CmdCommandActivator methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
setUpShortcutTipForMenuItem: aMenuItemMorph
	
	CmdShortcutActivation 
		activeInstancesFor: command class inContext: context
		do: [ :shortcut |  	
			aMenuItemMorph keyText: (shortcut keyCombination acceptVisitor: OSPlatform current shortcutPrinter)]! !

!CmdCommandActivator class methodsFor: 'instance creation' stamp: ''!
createCommand: aCommandClass inContext: aToolContext
	| command |
	command := aCommandClass new.
	aToolContext prepareNewCommand: command.
	^command! !

!CmdCommandActivator class methodsFor: 'instance creation' stamp: ''!
for: aCommandClass inContext: aToolContext using: aCommandActivationStrategy
	| command |
	command := self createCommand: aCommandClass inContext: aToolContext.
	
	^self new 
		command: command;
		context: aToolContext;
		activationStrategy: aCommandActivationStrategy! !

!CmdCommandActivatorTest methodsFor: 'tests' stamp: ''!
testConvertingCommandToActivator

	| activator command |
	command := CmdCommandExampleInRootMenu new.
	
	activator := command asCommandActivator.
	
	self assert: activator class equals: CmdCommandActivator.
	self assert: activator command equals: command.
	self assert: activator context class equals: CmdNullToolContext.
	self assert: activator activationStrategy class equals: CmdManualActivationStrategy.
	self assert: activator activationStrategy commandClass equals: command class.! !

!CmdCommandActivatorTest methodsFor: 'tests' stamp: ''!
testConvertingToActivator
	| activator |
	activator := CmdCommandActivator new.

	self assert: activator asCommandActivator identicalTo: activator! !

!CmdCommandActivatorTest methodsFor: 'tests' stamp: ''!
testCreationNewForNewCommand
	| activator newActivator |
	activator := CmdCommandActivator new.
	activator
		command: #command;
		context: #context;
		activationStrategy: #activation.

	newActivator := activator newForCommand: #newCommand.

	self deny: newActivator identicalTo: activator.
	self assert: newActivator class equals: activator class.
	self assert: newActivator command equals: #newCommand.
	self assert: newActivator context equals: #context.
	self assert: newActivator activationStrategy equals: #activation! !

!CmdCommandExampleInDeepMenuGroup class methodsFor: 'activation' stamp: ''!
menuActivationExample
	<classAnnotation>
	
	^CmdMenuCommandActivationExample byItemOf: CmdDeepChildMenuGroupStub for: CmdToolContextStub2! !

!CmdCommandExampleInMultipleMenuGroups class methodsFor: 'activation' stamp: ''!
childMenuGroupActivationExample1
	<classAnnotation>
	
	^CmdMenuCommandActivationExample byItemOf: CmdMenuGroupExample1 for: CmdToolContextStub1! !

!CmdCommandExampleInMultipleMenuGroups class methodsFor: 'activation' stamp: ''!
childMenuGroupActivationExample2
	<classAnnotation>
	 
	^CmdMenuCommandActivationExample byItemOf: CmdMenuGroupExample2 for: CmdToolContextStub1! !

!CmdCommandExampleInMultipleMenuGroups class methodsFor: 'activation' stamp: ''!
rootMenuActivationExample
	<classAnnotation>
	
	^CmdMenuCommandActivationExample byRootGroupItemOrder: 2 for: CmdToolContextStub1! !

!CmdCommandExampleInRootMenu class methodsFor: 'activation' stamp: ''!
rootMenuActivationExample
	<classAnnotation>
	
	^CmdMenuCommandActivationExample byRootGroupItemOrder: 1 for: CmdToolContextStub1! !

!CmdCommandMenuItem commentStamp: ''!
I represent command in menu.
I am created with command activator and delegate all messages to it to support menu protocol.
 
To create my instances use:
	CmdCommandMenuItem activatingBy: aCommandActivator
	
Internal Representation and Key Implementation Points.

    Instance Variables
	activator:		<CmdCommandActivator>!
!CmdCommandMenuItem methodsFor: 'execution' stamp: ''!
executeCommand
	activator executeCommand! !

!CmdCommandMenuItem methodsFor: '*Commander-Spec2-Compatibility' stamp: ''!
addToMenuPresenter: aSpMenuPresenter
	aSpMenuPresenter
		addItem: [ :anItem | 
			anItem
				name: self name;
				icon: self icon;
				action: [ self executeCommand ];
				enabled: self isActive;
				description: self command class defaultHelp.
				self getShortcutTipForMenuItem ifNotNil: [ :shortcut | anItem shortcut: shortcut ] ]! !

!CmdCommandMenuItem methodsFor: 'accessing' stamp: ''!
findGroupLike: menuGroupClass ifExists: aBlockClosure! !

!CmdCommandMenuItem methodsFor: 'testing' stamp: ''!
isActive
	^activator canExecuteCommand! !

!CmdCommandMenuItem methodsFor: 'accessing' stamp: ''!
activator: anObject
	activator := anObject! !

!CmdCommandMenuItem methodsFor: 'testing' stamp: ''!
includesCommand: aCommandClass

	^activator activatesCommand: aCommandClass! !

!CmdCommandMenuItem methodsFor: 'accessing' stamp: ''!
activator
	^ activator! !

!CmdCommandMenuItem methodsFor: 'accessing' stamp: ''!
command
	^ activator command! !

!CmdCommandMenuItem methodsFor: 'accessing' stamp: ''!
order
	^activator menuItemOrder! !

!CmdCommandMenuItem methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
buildContextMenu: aMenuView
	
	activator buildContextMenu: aMenuView! !

!CmdCommandMenuItem methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
registerContextMenuItemsWithBuilder: aBuilder

	activator registerContextMenuItemsFor: self withBuilder: aBuilder! !

!CmdCommandMenuItem methodsFor: '*Commander-Spec2-Compatibility' stamp: ''!
getShortcutTipForMenuItem
 	^activator getShortcutTipForMenuItem! !

!CmdCommandMenuItem methodsFor: 'accessing' stamp: ''!
description
	^activator commandDescription! !

!CmdCommandMenuItem methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserToolbar: toolbarMorph
	
	activator buildBrowserToolbar: toolbarMorph! !

!CmdCommandMenuItem methodsFor: 'testing' stamp: ''!
isSimilarTo: aMenuItem
	^self class == aMenuItem class and: [ 
		activator isSimilarTo: aMenuItem activator]! !

!CmdCommandMenuItem methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	aStream nextPutAll: self name.
	aStream nextPut: $).! !

!CmdCommandMenuItem methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserNotebookActions
	
	^ activator buildBrowserNotebookActions! !

!CmdCommandMenuItem methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserTabActions
	
	^activator buildBrowserTabActions! !

!CmdCommandMenuItem methodsFor: 'accessing' stamp: ''!
name
	^activator menuItemName! !

!CmdCommandMenuItem methodsFor: 'accessing' stamp: ''!
icon
	^activator menuItemIcon! !

!CmdCommandMenuItem methodsFor: 'updating' stamp: ''!
synchronizeContentWith: anotherMenuItem! !

!CmdCommandMenuItem methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
setUpShortcutTipForMenuItem: aMenuItemMorph

	activator setUpShortcutTipForMenuItem: aMenuItemMorph! !

!CmdCommandMenuItem methodsFor: 'testing' stamp: ''!
isCommandItem
	^true! !

!CmdCommandMenuItem class methodsFor: 'instance creation' stamp: ''!
activatingBy: aMenuCommandActivator
	^self new 
		activator: aMenuCommandActivator! !

!CmdCompositeToolContext commentStamp: ''!
I represent composition of existing context of given tool.
I always delegate command operations to context which is active for given operation. 
 
Internal Representation and Key Implementation Points.

    Instance Variables
	existingContexts:		<Collection of<CmdToolContext>>!
!CmdCompositeToolContext methodsFor: 'accessing' stamp: ''!
activeContextFor: aCommand
	^existingContexts detect: [ :each | 
		each allowsExecutionOf: aCommand]! !

!CmdCompositeToolContext methodsFor: 'command execution' stamp: ''!
prepareNewCommand: aCommand
	
	(self activeContextFor: aCommand)
		prepareNewCommand: aCommand! !

!CmdCompositeToolContext methodsFor: 'command execution' stamp: ''!
prepareFullExecutionOf: aCommand

	(self activeContextFor: aCommand)
		prepareFullExecutionOf: aCommand! !

!CmdCompositeToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
allowsDropExecutionOf: aCommand

	^existingContexts anySatisfy: [ :each | 
		each allowsDropExecutionOf: aCommand ]! !

!CmdCompositeToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
prepareDropExecutionOf: aCommand

	| activeDropContext |
	activeDropContext := existingContexts detect: [ :each | 
		each allowsDropExecutionOf: aCommand ].
	
	activeDropContext prepareDropExecutionOf: aCommand! !

!CmdCompositeToolContext methodsFor: 'command execution' stamp: ''!
applyResultOf: aCommand

	(self activeContextFor: aCommand)
		applyResultOf: aCommand! !

!CmdCompositeToolContext methodsFor: 'testing' stamp: ''!
representsSimpleAnnotationUser: aToolClass

	^existingContexts anySatisfy: [:each |
		each representsSimpleAnnotationUser: aToolClass]! !

!CmdCompositeToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
prepareDragActivationOf: aCommand

	(self activeContextFor: aCommand)
		prepareDragActivationOf: aCommand! !

!CmdCompositeToolContext methodsFor: 'accessing' stamp: ''!
existingContexts
	^ existingContexts! !

!CmdCompositeToolContext methodsFor: 'testing' stamp: ''!
allowsExecutionOf: aCommandClass

	^existingContexts anySatisfy: [:each | 
		each allowsExecutionOf: aCommandClass]! !

!CmdCompositeToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
applyDropResultOf: aCommand

	| activeDropContext |
	activeDropContext := existingContexts detect: [ :each | 
		each allowsDropExecutionOf: aCommand ].
	
	activeDropContext applyDropResultOf: aCommand! !

!CmdCompositeToolContext methodsFor: 'accessing' stamp: ''!
existingContexts: anObject
	existingContexts := anObject! !

!CmdContextMenuActivation commentStamp: ''!
I describe how access and execute commands from context menu items.

Add me to commands using:

	YourCommand>>yourApplicationContextMenuActivation
		<classAnnotation>
		^CmdContextMenuCommandActivation byRootGroupItemFor:  YourAppContext

It will add command to the root of context menu. There are a couple of methods to specify menu group and order:
- byRootGroupItemOrder: aNumber for: YourAppContext
- byItemOf: YourMenuGroupClass for: YourAppContext
- byItemOf: YourMenuGroupClass order: aNumber for: YourAppContext

Larger order puts command to the end of menu.

Application which wants menu based on commands should create current application context instance and use my class side method to build menu:

	CmdContextMenuCommandActivation buildMenuInContext:  anYourAppContext

During full menu building my instances build menu items. They delegate building to underlying command instance:
	command fillContextMenu: aMenu using: aCommandActivator
Commands  can override this method to build something specific but by default they just build menu item morph with label and icon. To parametrize this default behaviour commands can define two methods:
- defaultMenuItemName 
- setUpIconForMenuItem: 
 
Look also at my superclass CmdMenuCommandActivator comment for more details!
!CmdDeepChildMenuGroupStub class methodsFor: 'parents' stamp: ''!
parentGroup
	^CmdMenuGroupExample2! !

!CmdDoubleClickActivation commentStamp: ''!
I represent activation of commands using mouse double click event!
!CmdDoubleClickActivation class methodsFor: 'morphs setup' stamp: ''!
morphicEventType
	^#doubleClick! !

!CmdDragAndDropActivation commentStamp: ''!
I describe how access and execute command using drag and drop UI operation.

Add me to commands using:

	YourCommand>>yourApplicationDragAndDropActivation
		<classAnnotation>
		^CmdDragAndDropCommandActivation for: YourAppContextForDrag toDropIn: YourAppContextForDrop

First argument of activation strategy is a context where drap operation can be started. Last argument is a context where command can be executed by drop.

Applications which support me should implement few drag and drop methods according to the UI library (Morphic). At drag start a CmdDragPassenger should be created in current application context: 

	CmdDragAndDropCommandActivation createDragPassengerInContext:  aToolContext
	
Then at drop target widget (morph) the drop context should be created. It should be used to ask given passenger about possibility to execute the drop:
- aPassenger canBeDroppedInContext: targetToolContext 
- aPassanger dropInContext: targetToolContex 

To support all these methods passenger asks the command activator which delegate processing to underlying commands. Commands should define three methods:
- canBeExecutedInDropContext: aToolContext 
- prepareExecutionInDragContext: aToolContext
- prepareExecutionInDropContext: aToolContext

By default commands can be executed by any drop context and for preparation they do nothing. 

For command activation I return new kind of activator CmdDragAndDropCommandActivator which implements logic to execute commands in addition drop context of application. Look at it comment for details.

Internal Representation and Key Implementation Points.

    Instance Variables
	dropContextDefinition:		<CmdContextDefinition>!
!CmdDragAndDropActivation methodsFor: 'testing' stamp: ''!
isDropActiveInContext: aToolContext
	^ activeDropContext describes: aToolContext! !

!CmdDragAndDropActivation methodsFor: 'accessing' stamp: ''!
activeDropContext: anObject
	activeDropContext := anObject! !

!CmdDragAndDropActivation methodsFor: 'activation' stamp: ''!
defaultActivatorClass
	^CmdDragAndDropCommandActivator! !

!CmdDragAndDropActivation methodsFor: 'accessing' stamp: ''!
activeDropContext
	^ activeDropContext! !

!CmdDragAndDropActivation class methodsFor: 'instance creation' stamp: ''!
for: dragAnnotationContext toDropIn: dropAnnotationContext
	^(self for: dragAnnotationContext)
		activeDropContext: dropAnnotationContext asAnnotationContext! !

!CmdDragAndDropActivation class methodsFor: 'passenger creation' stamp: ''!
createDragPassengerInContext: aToolContext
	| activators |
	activators := self createActivatorsExecutableInContext: aToolContext.
		
	^CmdDragPassenger draggedFromContext: aToolContext toActivate: activators! !

!CmdDragAndDropCommandActivator commentStamp: ''!
I represent activation of command through drag and drop operation.
In that case context variable from my superclass keeps context where drag was initiated.
And my variable dropContext holds context where command should be executed by drop operation.

I redefine execution logic with two separate steps:
- prepare command in context of drag operation:
	context prepareDragActivationOf: command
- prepare command in context of drop operation:
	dropContext prepareDropExecutionOf:  command
Actual preparation logic is implemented by command. Contexts delegate processing to it. 

Drag and drop logic of concrete UI application should execute command using:
	activator executeDropInContext: aToolContextForDropOperation

My instances are created by CmdDragAndDropCommandActivation:
	dragAndDropActivation newActivatorFor: aContextForDragOperation.
		
Internal Representation and Key Implementation Points.

    Instance Variables
	dropContext:		<CmdToolContext>!
!CmdDragAndDropCommandActivator methodsFor: 'testing' stamp: ''!
canExecuteDropInContext: aToolContext

	^(activationStrategy isDropActiveInContext: aToolContext)
		and: [  aToolContext allowsDropExecutionOf: command ]! !

!CmdDragAndDropCommandActivator methodsFor: 'execution' stamp: ''!
executeDropInContext: aToolContext
	dropContext := aToolContext.
	self executeCommand! !

!CmdDragAndDropCommandActivator methodsFor: 'testing' stamp: ''!
canExecuteCommand

	^super canExecuteCommand and: [ self canExecuteDropInContext: dropContext ]! !

!CmdDragAndDropCommandActivator methodsFor: 'execution' stamp: ''!
prepareCommandForExecution
	context prepareDragActivationOf: command.
	dropContext prepareDropExecutionOf: command! !

!CmdDragAndDropCommandActivator methodsFor: 'execution' stamp: ''!
applyCommandResult

	context applyResultOf: command.
	dropContext applyDropResultOf: command! !

!CmdDragAndDropCommandActivator class methodsFor: 'instance creation' stamp: ''!
createCommand: aCommandClass inContext: aToolContext
	| command |
	command := super createCommand: aCommandClass inContext: aToolContext.
	aToolContext prepareDragActivationOf: command.
	^command! !

!CmdDragPassenger commentStamp: ''!
I represent passenger of drag and drop operation. I am created at start of drag operation  in current context of application with set of appropriate commands annotated by drag&drop activation strategies.
Then at drop target I detect most suitable command for given target context and execute it.
Look at CmdDragAndDropCommandActivation comment for details

Internal Representation and Key Implementation Points.

    Instance Variables
	dragContext:		<ToolContext>
	dropActivators:		<Collection of<CmdDragAndDropCommandActivator>>!
!CmdDragPassenger methodsFor: 'accessing' stamp: ''!
dragContext
	^ dragContext! !

!CmdDragPassenger methodsFor: 'accessing' stamp: ''!
dropActivators
	^ dropActivators! !

!CmdDragPassenger methodsFor: 'dropping' stamp: ''!
dropInContext: aToolContext
	| targetActivator |
	targetActivator := dropActivators detect: [ :each | 
		each canExecuteDropInContext: aToolContext].
	
	targetActivator executeDropInContext: aToolContext.
	
	^true! !

!CmdDragPassenger methodsFor: 'converting' stamp: ''!
asDraggableMorph
	^dragContext asDraggableMorph! !

!CmdDragPassenger methodsFor: 'testing' stamp: ''!
canBeDroppedInContext: aToolContext

	^dropActivators anySatisfy: [ :each | 
		each canExecuteDropInContext: aToolContext]! !

!CmdDragPassenger methodsFor: 'accessing' stamp: ''!
dragContext: anObject
	dragContext := anObject! !

!CmdDragPassenger methodsFor: 'accessing' stamp: ''!
dropActivators: anObject
	dropActivators := anObject! !

!CmdDragPassenger class methodsFor: 'instance creation' stamp: ''!
draggedFromContext: aToolContext toActivate: commandActivators

	^self new 
		dragContext: aToolContext;
		dropActivators: commandActivators! !

!CmdExtraMenuGroup commentStamp: ''!
I represent kind of reusable additional method group which users can reuse for grouping set of extra rarely used commands.

I am always the last group in the menu which is always separated by line in the context menu !
!CmdExtraMenuGroup methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
buildContextMenu: aMenu
	aMenu addLine.
	
	super buildContextMenu: aMenu! !

!CmdExtraMenuGroup methodsFor: 'accessing' stamp: ''!
order
	"Idea to put extra group to the end of menu"
	^SmallInteger maxVal! !

!CmdExtraMenuGroup methodsFor: 'accessing' stamp: ''!
description
	^'Rarely used commands'! !

!CmdExtraMenuGroup methodsFor: 'accessing' stamp: ''!
name
	^'Extra'! !

!CmdKMDispatcher commentStamp: ''!
I implement dispatch by delegating execution to appropriate command which defines shortcut activation strategy suitable for given KM events.

User should override morph kmDispatcher to use me instead of default:

	YourMorph>>kmDispatcher
		^ CmdKMDispatcher attachedTo: self
		
In case when commands should be provided by another object instead of morph you should use another method: 
	
	CmdKMDispatcher attachedTo: self withCommandsFrom: someObjectWithCommandContext
	
During dispatch process I ask command provider to create command context. And by default provider is morph itself.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	commandProvider:		<Object>!
!CmdKMDispatcher methodsFor: 'dispatching' stamp: ''!
commandProvider
	^commandProvider ifNil: [target morph]! !

!CmdKMDispatcher methodsFor: 'accessing' stamp: ''!
commandProvider: someObjectWithCommandContext
	commandProvider := someObjectWithCommandContext! !

!CmdKMDispatcher methodsFor: 'dispatching' stamp: ''!
dispatch: anEventBuffer

	| context executed |
	context := self commandProvider createCommandContext.
	
	CmdShortcutActivation visibleInstancesInContext: context do: [ :shortcut | 
		executed := shortcut tryExecuteCommandInContext: context byEvents: anEventBuffer.
		executed ifTrue: [ ^self ] ].
	
	super dispatch: anEventBuffer! !

!CmdKMDispatcher class methodsFor: 'instance creation' stamp: ''!
attachedTo: aMorph

	| dispatcher |
	aMorph valueOfProperty: #kmDispatcher ifPresentDo: [:existing | 
		(existing isKindOf: self) ifTrue: [^existing]].
	dispatcher := CmdKMDispatcher target: aMorph.
	aMorph initializeShortcuts: dispatcher.
	aMorph setProperty: #kmDispatcher toValue: dispatcher.
	^dispatcher! !

!CmdKMDispatcher class methodsFor: 'instance creation' stamp: ''!
attachedTo: aMorph withCommandsFrom: someObjectWithCommandContext

	| dispatcher |
	dispatcher := self attachedTo: aMorph.
	dispatcher commandProvider: someObjectWithCommandContext.
	^dispatcher! !

!CmdManualActivationStrategy commentStamp: ''!
I represent manual command activation to allow reuse activation machinery in cases when user creates command instances manually.
For example I can be used in button kind widgets where model is command activator. 
In that case widgets are able create activator directly from given command using my instance and null tool context.!
!CmdManualActivationStrategy methodsFor: 'accessing' stamp: ''!
menuItemNameFor: aCommand
	^ aCommand defaultMenuItemName! !

!CmdMenu commentStamp: ''!
I represent abstract tree structure for concrete menu implementation like context menu, toolbar, halo menu and etc..
I am created for commands which have given #commandActivatorClass:
	menu := CmdMenu activatedBy: aCommandActivatorClass

Then I can build items for given context:
	menu buildInContext: aToolContext.
This method can be called multiple times for different contexts. It allows to build single menu for multiple parts of application. For example toolbar menu can include commands for all visible widgets.   
When menu is built you can inspect #rootGroup to analyze structure.

Concrete activator packages extend me to build concrete type of end user menu. For example context menu activator ask me to #buildContextMenu. Then I ask all my items to build context menu. And at the end commands receive context menu message where they build menu item morphs. 
 
Internal Representation and Key Implementation Points.

    Instance Variables
	commandActivatorClass:		<CmdMenuCommandActivator class>
	rootCommandClass:		<CmdCommand class>
	rootGroup:		<CmdMenuGroup class>!
!CmdMenu methodsFor: 'testing' stamp: ''!
isEmpty
	^rootGroup isEmpty! !

!CmdMenu methodsFor: 'testing' stamp: ''!
isActive
	^rootGroup isActive! !

!CmdMenu methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	rootGroup := CmdRootMenuGroup new! !

!CmdMenu methodsFor: '*Commander-Spec2-Compatibility' stamp: ''!
asSpMenuPresenter
	| menu |
	menu := SpMenuPresenter new.
	rootGroup contents do: [ :each | each addToMenuPresenter: menu  ].
	^menu! !

!CmdMenu methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
registerContextMenuItemsWithBuilder: aBuilder

	rootGroup registerContextMenuItemsWithBuilder: aBuilder! !

!CmdMenu methodsFor: 'building' stamp: ''!
buildInContext: aToolContext

	activationStrategyClass 
		visibleInstancesInContext: aToolContext
		do: [ :activation | 
			self buildCommandItemInContext: aToolContext activatingBy: activation]! !

!CmdMenu methodsFor: 'accessing' stamp: ''!
itemsWithCommandLike: aCommandClass 
	| groups |
	groups := self groupsWithCommandLike: aCommandClass.
	^groups 
		flatCollect: [ :each | { each. each commandItemLike: aCommandClass } ]! !

!CmdMenu methodsFor: 'accessing' stamp: ''!
activationStrategyClass
	^ activationStrategyClass! !

!CmdMenu methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserToolbar: aToolbar

	rootGroup buildBrowserToolbar: aToolbar! !

!CmdMenu methodsFor: 'accessing' stamp: ''!
rootGroup: anObject
	rootGroup := anObject! !

!CmdMenu methodsFor: 'building' stamp: ''!
buildCommandItemInContext: aToolContext activatingBy: anActivationStrategy

	| commandActivator group |
	commandActivator := anActivationStrategy newActivatorFor: aToolContext.
	
	group := self ensureGroup: anActivationStrategy menuGroup.
	group addItem: (CmdCommandMenuItem activatingBy: commandActivator)! !

!CmdMenu methodsFor: 'accessing' stamp: ''!
rootGroup
	^ rootGroup! !

!CmdMenu methodsFor: 'building' stamp: ''!
ensureGroup: menuGroupClass

	| parentGroup group |
	rootGroup class = menuGroupClass ifTrue: [ ^rootGroup ].
	rootGroup findGroupLike: menuGroupClass ifExists: [:existing | ^existing].
	
	parentGroup := self ensureGroup: menuGroupClass parentGroup.
	group := menuGroupClass new.
	parentGroup addItem: group.
	^group! !

!CmdMenu methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserNotebookActions

	^ rootGroup buildBrowserNotebookActions! !

!CmdMenu methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserTabActions

	^rootGroup buildBrowserTabActions! !

!CmdMenu methodsFor: 'accessing' stamp: ''!
groupsWithCommandLike: aCommandClass 
	
	| result |
	result := rootGroup allGroupsWhich: [ :each | each includesCommand: aCommandClass ].
	(rootGroup includesCommand: aCommandClass)
		ifTrue: [ result add: rootGroup ].
	^result! !

!CmdMenu methodsFor: 'accessing' stamp: ''!
activationStrategyClass: anObject
	activationStrategyClass := anObject! !

!CmdMenu methodsFor: 'accessing' stamp: ''!
rootItems
	^rootGroup contents! !

!CmdMenu methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
buildContextMenuFor: aMorph

	| menu |
	menu := UIManager default newMenuIn: aMorph for: aMorph.

	rootGroup buildContextMenu: menu.
	
	menu hasSubmorphs ifTrue: [ 
		menu lastSubmorph isMenuLineMorph ifTrue: [ menu lastSubmorph delete ]].
	^menu! !

!CmdMenu class methodsFor: 'instance creation' stamp: ''!
activatedBy: aCommandActivationStrategyClass

	^self new 
		activationStrategyClass: aCommandActivationStrategyClass! !

!CmdMenuCommandActivationStrategy commentStamp: ''!
I am a root of command activation hierarchy which supposed to represent commands in kind of menu.
I provide information about name, group and position of command inside menu:
- menuItemName. If it is not specified I ask command for #defaultMenuItemName.
- menuItemOrder
- menuGroup
My subclasses provide meaning of concrete menu type. It could be context menu, toolbar menu, halo menu and etc..
To build any kind of end user menu my subclasses first build abstract CmdMenu. It represents tree structure of concrete menu implemetation.
Concrete menu activations extend abstract menu to delegate item building to underlying commands and groups.

Menu groups are represented by subclasses of CmdMenuGroup. They are used as classes to declare activation strategy. Instances are only created during menu building.
Groups are containers of command items and other groups.
Each group defines #parentGroup on class side. By default it is CmdRootMenuGroup. Subclasses can override it to define deep tree structure.

I provide suitable methods to declare activators:
	ConcreteMenuCommandActivation byRootGroupItemFor: YourAppContext 
	ConcreteMenuCommandActivation byRootGroupItemOrder: aNumber for: YourAppContext
	ConcreteMenuCommandActivation byItemOf: menuGroupClass for: YourAppContext
	ConcreteMenuCommandActivation byItemOf: menuGroupClass order: aNumber for: YourAppContext

Larger order pushes command to the end of menu. Groups are also define order by instance side method #order.

Internal Representation and Key Implementation Points.

    Instance Variables
	menuGroup:		<CmdMenuGroup class>
	menuItemName:		<String>
	menuItemOrder:		<Number>!
!CmdMenuCommandActivationStrategy methodsFor: 'accessing' stamp: ''!
menuGroup
	^ menuGroup! !

!CmdMenuCommandActivationStrategy methodsFor: 'accessing' stamp: ''!
menuItemNameFor: aCommand
	^ menuItemName ifNil: [ aCommand defaultMenuItemName ]! !

!CmdMenuCommandActivationStrategy methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	menuItemOrder := 1000.
	menuGroup := CmdRootMenuGroup! !

!CmdMenuCommandActivationStrategy methodsFor: 'accessing' stamp: ''!
menuItemOrder
	^ menuItemOrder! !

!CmdMenuCommandActivationStrategy methodsFor: 'accessing' stamp: ''!
menuItemOrder: anObject
	menuItemOrder := anObject! !

!CmdMenuCommandActivationStrategy methodsFor: 'accessing' stamp: ''!
menuItemName
	^ menuItemName! !

!CmdMenuCommandActivationStrategy methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	menuGroup printOn: aStream.
	aStream nextPutAll: '; '.
	menuItemOrder printOn: aStream.
	aStream nextPut: $).! !

!CmdMenuCommandActivationStrategy methodsFor: 'accessing' stamp: ''!
menuItemName: anObject
	menuItemName := anObject! !

!CmdMenuCommandActivationStrategy methodsFor: 'accessing' stamp: ''!
menuGroup: anObject
	menuGroup := anObject! !

!CmdMenuCommandActivationStrategy class methodsFor: 'instance creation' stamp: ''!
byItemOf: menuGroupClass order: aNumber for: aToolContextClass
	^(self byItemOf: menuGroupClass for: aToolContextClass)
		menuItemOrder: aNumber! !

!CmdMenuCommandActivationStrategy class methodsFor: 'instance creation' stamp: ''!
byItem: itemName of: menuGroupClass for: aToolContextClass
	^(self byItemOf: menuGroupClass for: aToolContextClass)
		 menuItemName: itemName! !

!CmdMenuCommandActivationStrategy class methodsFor: 'instance creation' stamp: ''!
byItemOf: menuGroupClass for: aToolContextClass
	^(self for: aToolContextClass)
		 menuGroup: menuGroupClass! !

!CmdMenuCommandActivationStrategy class methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
registerContextMenuOn: aBuilder inContext: aToolContext
	| menu |
	menu := self buildMenuInContext: aToolContext.
	menu registerContextMenuItemsWithBuilder: aBuilder! !

!CmdMenuCommandActivationStrategy class methodsFor: 'instance creation' stamp: ''!
byRootGroupItem: itemName for: aToolContextClass
	^(self byRootGroupItemFor: aToolContextClass)
		menuItemName: itemName! !

!CmdMenuCommandActivationStrategy class methodsFor: 'menu creation' stamp: ''!
buildMenuInContext: aToolContext
	| menu |
	menu := CmdMenu activatedBy: self.
	menu buildInContext: aToolContext.
	^ menu! !

!CmdMenuCommandActivationStrategy class methodsFor: 'instance creation' stamp: ''!
byRootGroupItemOrder: aNumber for: aToolContextClass
	^self byItemOf: CmdRootMenuGroup order: aNumber for: aToolContextClass! !

!CmdMenuCommandActivationStrategy class methodsFor: 'instance creation' stamp: ''!
byRootGroupItemFor: aToolContextClass
	^self byItemOf: CmdRootMenuGroup for: aToolContextClass! !

!CmdMenuCommandActivationStrategy class methodsFor: 'instance creation' stamp: ''!
byItem: itemName of: menuGroupClass order: aNumber for: aToolContextClass
	^(self byItemOf: menuGroupClass order: aNumber for: aToolContextClass)
		menuItemName: itemName! !

!CmdMenuCommandActivationStrategy class methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
buildContextMenuFor: aMorph inContext: aToolContext

	| menu |
	menu := self buildMenuInContext: aToolContext.	
	^menu buildContextMenuFor: aMorph! !

!CmdMenuCommandActivationStrategy class methodsFor: 'instance creation' stamp: ''!
byRootGroupItem: itemName order: aNumber for: aToolContextClass
	^(self byRootGroupItemOrder: aNumber for: aToolContextClass)
		menuItemName: itemName! !

!CmdMenuGroup commentStamp: ''!
I am a root of hierarchy of first class menu groups.
My subclasses are used to declare command position in menu. They are declared in menu command activation strategies.
My own menu position is defined statically by instance side method #order and class side method #parentGroup. By default #parentGroup is CmdRootMenuGroup which represents root menu items. If some group wants to be in deep tree structure it overrides #parentGroup method to return another group class. 

My instances contain other menu items (commands and groups). I provide accessing methods for them:
- addItem: aMenuItem
- removeItem: aMenuItem
- includes: aMenuItem
- size

Different kinds of menu activation strategies extend me to build different kind of menu (context menu, toobar, halo menu, etc.)

Internal Representation and Key Implementation Points.

    Instance Variables
	contents:		<OrderedCollection of<CmdMenuItem>>!
!CmdMenuGroup methodsFor: '*Commander-Spec2-Compatibility' stamp: ''!
addToMenuPresenter: aSpMenuPresenter
	| subMenuPresenter |
	subMenuPresenter := SpMenuPresenter new.
	self contents
		do: [ :each | each addToMenuPresenter: subMenuPresenter ].
	aSpMenuPresenter
		addItem: [ :item | 
			item
				name: self name;
				icon: self icon;
				subMenu: subMenuPresenter ]! !

!CmdMenuGroup methodsFor: 'testing' stamp: ''!
isEmpty
	^contents isEmpty! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
findGroupLike: menuGroupClass ifExists: foundBlock

	contents detect: [ :each | each isKindOf: menuGroupClass] ifFound: foundBlock.
		
	contents do: [ :each | each findGroupLike: menuGroupClass ifExists: foundBlock ]! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
addItem: aMenuItem
	aMenuItem parentGroup: self.
	contents add: aMenuItem! !

!CmdMenuGroup methodsFor: 'testing' stamp: ''!
includes: aMenuItem
	^contents anySatisfy: [ :each | each isSimilarTo: aMenuItem ]! !

!CmdMenuGroup methodsFor: 'testing' stamp: ''!
includesCommand: aClass 
	"It answers only about itself without looking recursively into child groups"
	^contents anySatisfy: [:each |
		each isCommandItem and: [each includesCommand: aClass] ]! !

!CmdMenuGroup methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
buildContextMenu: aMenu

	self isInlined 
		ifTrue: [ self inlineContextMenuItemsInto: aMenu ]
		ifFalse: [ self buildContextSubMenuIn: aMenu ]! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
findItemSimilarTo: aMenuItem ifPresent: presentBlock ifAbsent: absentBlock

	contents 
		detect: [:each | each isSimilarTo: aMenuItem  ]
		ifFound: presentBlock
		ifNone: absentBlock! !

!CmdMenuGroup methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
registerContextMenuItemsWithBuilder: aBuilder

	self isActive ifFalse: [ ^self ].
	
	self isInlined
		ifTrue: [ aBuilder items ifNotEmpty: [aBuilder withSeparatorAfter] ]
		ifFalse: [ self registerContextSubMenuWithBuilder: aBuilder].
		
	contents do: [ :each | 
		each registerContextMenuItemsWithBuilder: aBuilder ].
	
	self isInlined & aBuilder items notEmpty 
		ifTrue: [ aBuilder withSeparatorAfter ]! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
commands
	^contents 
		select: [ :each | each isCommandItem ] 
		thenCollect: [ :each | each command ]! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
description
	"By default the result is nil which is not really nice 
	but it is already expected by many tools. So it is easy to allow nil"
	^nil! !

!CmdMenuGroup methodsFor: 'testing' stamp: ''!
isRoot
	^false! !

!CmdMenuGroup methodsFor: 'testing' stamp: ''!
isSimilarTo: aMenuItem
	^self class == aMenuItem class! !

!CmdMenuGroup methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
registerContextSubMenuWithBuilder: aBuilder

	(aBuilder item: self name)
		order: self order;
		parent: parentGroup name;
		target: self;
		icon: self icon;
		help: self description! !

!CmdMenuGroup methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserNotebookActions

	self isActive ifFalse: [ ^#()] .
	
	^contents flatCollect: [ :each | each buildBrowserNotebookActions ]! !

!CmdMenuGroup methodsFor: 'testing' stamp: ''!
isLastMenuItem: childMenuItem

	^contents last == childMenuItem and: [ self isLastInMenu ]! !

!CmdMenuGroup methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserTabActions

	self isActive ifFalse: [ ^#()].
	
	^contents flatCollect: [ :each | each buildBrowserTabActions ]! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
icon
	"By default the result is nil which is not really nice 
	but it is already expected by many tools.	So it is easy to allow nil.
	For simple cases users should implement method #iconName"
	^self iconName 
		ifNotNil: [:iconName | Smalltalk ui iconNamed: iconName ]! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
contents
	^ contents! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
contents: anObject
	contents := anObject! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
removeItem: aGroupOrCommand
	contents remove: aGroupOrCommand! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
allGroupsWhich: aBlock 
	| result |
	result := OrderedCollection new.
	
	contents 
		reject: [ :each | each isCommandItem ]
		thenDo: [ :each | 
			(aBlock value: each) ifTrue: [ result add: each ].
			result addAll: (each allGroupsWhich: aBlock) ].
		
	^result! !

!CmdMenuGroup methodsFor: 'testing' stamp: ''!
isLastActiveMenuItem: childMenuItem

	contents reverseDo: [ :each | 
		each isActive ifTrue: [ ^each == childMenuItem ] ].
	
	^false! !

!CmdMenuGroup methodsFor: 'testing' stamp: ''!
isActive
	^contents anySatisfy: [ :each | each isActive ]! !

!CmdMenuGroup methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
inlineContextMenuItemsInto: aMenu

	aMenu addLine.
	
	contents do: [ :each | each buildContextMenu: aMenu ].
	
	aMenu addLine.! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
allItemsWhich: aBlock 
	| result |
	result := OrderedCollection new.
	
	contents do: [ :each | 
		(aBlock value: each) ifTrue: [ result add: each ].
		each isCommandItem ifFalse: [ 
			result addAll: (each allItemsWhich: aBlock) ]].
		
	^result! !

!CmdMenuGroup methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	contents := SortedCollection sortBlock: [ :a :b | 
		a order = b order 
			ifTrue: [ a name <= b name ]
			ifFalse: [ a order <= b order ]]! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
order
	^500! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
iconName
	"Not really nice to return nil. But it is already expected by many tools.
	So it is easy to allow nil.
	Users should use method #icon which returns Form instance"
	
	^nil! !

!CmdMenuGroup methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserToolbar: toolbarMorph

	self isActive ifFalse: [ ^self].
	toolbarMorph submorphs ifNotEmpty: [ 
		toolbarMorph addNewItem: ClyToolbarSeparatorMorph new].
	contents do: [ :each | each buildBrowserToolbar: toolbarMorph ]! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
size
	^contents size! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
name
	^self class name! !

!CmdMenuGroup methodsFor: 'updating' stamp: ''!
synchronizeContentWith: anotherGroup

	contents removeAllSuchThat: [ :each | (anotherGroup includes: each) not].
	anotherGroup contents do: [ :each | 
		self 
			findItemSimilarTo: each
			ifPresent: [ :existing | 
				existing synchronizeContentWith: each.
				existing isEmpty ifTrue: [ self removeItem: existing ] ]
			ifAbsent: [ self addItem: each]]! !

!CmdMenuGroup methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
buildContextSubMenuIn: aMenu

	| submenu |
	submenu := UIManager default newMenuIn: aMenu defaultTarget for: aMenu defaultTarget.
	
	contents do: [ :each | each buildContextMenu: submenu ].
	
	submenu hasItems ifTrue: [ 
		aMenu add: self name icon: self icon subMenu: submenu.
		self description ifNotNil: [:d | aMenu lastItem setBalloonText: d] ]! !

!CmdMenuGroup methodsFor: 'testing' stamp: ''!
isCommandItem
	^false! !

!CmdMenuGroup methodsFor: 'accessing' stamp: ''!
commandItemLike: aCommandClass

	^contents detect: [ :each | 
		each isCommandItem and: [ each includesCommand: aCommandClass ]]! !

!CmdMenuGroup methodsFor: 'testing' stamp: ''!
isInlined
	^false! !

!CmdMenuGroup class methodsFor: 'parents' stamp: ''!
parentGroup
	^CmdRootMenuGroup! !

!CmdMenuItem commentStamp: ''!
I represent abstract menu item.
I have two main subclasses: ClyComandMenuItem and CmdMenuGroup. Last subclass is a root of menu group hierarchy.

To support menu my subclasses implement following methods:
- name
- order. It defines position in menu. Larger value pushes item to the end of menu.
- isActive. It defines if item can be activated. 
- isEmpty. It defines if item has children. 
- isSimilarTo: anotherMenuItem. It defines if two items are similar.

Also different kinds of menu activation strategy extend me and my subclasses by methods to support concrete menu!
!CmdMenuItem methodsFor: 'accessing' stamp: ''!
actualParentGroup
	parentGroup isRoot ifTrue: [ ^parentGroup ].
	
	^parentGroup isInlined 
		ifTrue: [ parentGroup actualParentGroup ]
		ifFalse: [ parentGroup]! !

!CmdMenuItem methodsFor: 'testing' stamp: ''!
isEmpty
	^false! !

!CmdMenuItem methodsFor: 'accessing' stamp: ''!
findGroupLike: menuGroupClass ifExists: aBlockClosure
	self subclassResponsibility! !

!CmdMenuItem methodsFor: 'testing' stamp: ''!
isActive
	self subclassResponsibility! !

!CmdMenuItem methodsFor: 'accessing' stamp: ''!
parentGroup: anObject
	parentGroup := anObject! !

!CmdMenuItem methodsFor: 'testing' stamp: ''!
includesCommand: aCommandClass

	self subclassResponsibility! !

!CmdMenuItem methodsFor: 'accessing' stamp: ''!
pathToRoot
	^parentGroup 
		ifNil: [ ^#() ]
		ifNotNil: [ parentGroup pathToRoot, {parentGroup} ]! !

!CmdMenuItem methodsFor: 'accessing' stamp: ''!
order
	self subclassResponsibility! !

!CmdMenuItem methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
buildContextMenu: aMenu

	self subclassResponsibility! !

!CmdMenuItem methodsFor: '*Commander-Activators-ContextMenu' stamp: ''!
registerContextMenuItemsWithBuilder: aBuilder

	self subclassResponsibility! !

!CmdMenuItem methodsFor: 'accessing' stamp: ''!
description
	self subclassResponsibility! !

!CmdMenuItem methodsFor: 'testing' stamp: ''!
isLastInMenu
	^parentGroup isLastMenuItem: self! !

!CmdMenuItem methodsFor: 'testing' stamp: ''!
isSimilarTo: aMenuItem
	self subclassResponsibility! !

!CmdMenuItem methodsFor: '*Calypso-Browser' stamp: ''!
buildBrowserToolbar: toolbarMorph

	self subclassResponsibility! !

!CmdMenuItem methodsFor: 'testing' stamp: ''!
isLastActiveItemInMenu
	^parentGroup isLastActiveMenuItem: self! !

!CmdMenuItem methodsFor: 'accessing' stamp: ''!
name
	self subclassResponsibility! !

!CmdMenuItem methodsFor: 'accessing' stamp: ''!
icon
	self subclassResponsibility! !

!CmdMenuItem methodsFor: 'updating' stamp: ''!
synchronizeContentWith: anotherMenuItem
	self subclassResponsibility! !

!CmdMenuItem methodsFor: 'accessing' stamp: ''!
parentGroup
	^ parentGroup! !

!CmdMenuItem methodsFor: 'testing' stamp: ''!
isCommandItem
	^self subclassResponsibility! !

!CmdMenuTest methodsFor: 'tests' stamp: ''!
testWhenCommandShouldBeInMultipleGroups
	| menu containingGroups |
	menu := self buildMenuInContext: CmdToolContextStub1 new.
	
	containingGroups := menu groupsWithCommandLike: CmdCommandExampleInMultipleMenuGroups.
	self 
		assert: (containingGroups collect: #class as: Set)
		equals: {CmdMenuGroupExample1. CmdMenuGroupExample2. CmdRootMenuGroup } asSet! !

!CmdMenuTest methodsFor: 'tests' stamp: ''!
testWhenCommandShouldBeInDeepChildGroup

	| menu containingItems parents |
	menu := self buildMenuInContext: CmdToolContextStub2 new.
	containingItems := menu itemsWithCommandLike: CmdCommandExampleInDeepMenuGroup.
	self assert: containingItems size equals: 2. "group and commandItem"
	self assert: containingItems last isCommandItem.
	parents := containingItems last pathToRoot collect: [:each | each class].
	self assert: parents equals: {CmdRootMenuGroup. CmdMenuGroupExample2. CmdDeepChildMenuGroupStub }! !

!CmdMenuTest methodsFor: 'tests' stamp: ''!
testWhenCommandShouldBeInRootMenu
	| menu containingItems |
	menu := self buildMenuInContext: CmdToolContextStub1 new.
	
	containingItems := menu groupsWithCommandLike: CmdCommandExampleInRootMenu.
	self assert: containingItems size equals: 1. "group and commandItem"
	self assert: containingItems first equals: menu rootGroup! !

!CmdMenuTest methodsFor: 'tests' stamp: ''!
buildMenuInContext: aToolContext
	| menu |
	menu := CmdMenu  
		activatedBy: CmdMenuCommandActivationExample.
	
	menu buildInContext: aToolContext.
	
	^menu! !

!CmdMenuTest methodsFor: 'tests' stamp: ''!
testWhenGivenContextIsUnused
	| menu |
	menu := self buildMenuInContext: CmdUnusedToolContextStub new.
	
	self assert: menu rootGroup size equals: 0! !

!CmdMenuTest methodsFor: 'tests' stamp: ''!
testCommandItemShouldContainPreparedCommandInstance
	| menu command context containingItems |
	context := CmdToolContextStub1 new.
	menu := self buildMenuInContext: context.
	containingItems := menu itemsWithCommandLike: CmdCommandExampleInRootMenu.
	self assert: containingItems last isCommandItem.
	
	command := containingItems last command.
	self assert: command class equals: CmdCommandExampleInRootMenu.
	self assert: command savedParametersContext equals: context.! !

!CmdMouseCommandActivation commentStamp: ''!
My subclasses represent particular kind of mouse events which should activate annotated commands.
For example it can be mouse click or double click.

My instances are configured with type of mouse button and keyboard modifier which are expected to be used to activate commands.

By default the left click is expected:

	CmdClickActivation for: aCommandUser.

With extra parameter you can configure modifier: 

	CmdClickActivation with: KMModifier shift for: aCommandUser.
	
To specify mouse button use following messages: 

	(CmdClickActivation for: aCommandUser) beBlueButton.
	(CmdClickActivation for: aCommandUser) beYellowButton.
	(CmdClickActivation for: aCommandUser) beRedButton

And there is special constructor for yellow button which is usefull for various context menu activations:

	CmdClickActivation byYellowButtonFor: aCommandUser.
	CmdClickActivation byYellowButtonWith: KMModifier shift for: aCommandUser

My instances are active when they are match last mouse event:

	aMouseActivation isActiveInContext: aToolContext 
	
I extend this method to check that last mouse event matches expected button and modifier. 
		
There are few methods how to enable mouse commands in the morphs: 

	aMorph enableMouseCommands: CmdClickActivation withContextFrom: aToolContext.

It enables click action to execute commands in given aMorph instance.

	aMorph enableAllMouseCommandsFrom: aToolContext.    	 
		
It enables all kind of mouse events to execute commands in given aMorph instance.

Internal Representation and Key Implementation Points.

    Instance Variables
	keyboardModifier:		<KMModifier>
	whichButton:		<Integer>!
!CmdMouseCommandActivation methodsFor: 'accessing' stamp: ''!
keyboardModifier: anObject
	keyboardModifier := anObject! !

!CmdMouseCommandActivation methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	self beRedButton! !

!CmdMouseCommandActivation methodsFor: 'testing' stamp: ''!
matchesEvent: aMouseEvent
	(aMouseEvent respondsTo: #whichButton) ifFalse: [ ^false ].
	aMouseEvent fixStateForClickAndModifierIssue.
	
	(keyboardModifier isNil and: [ "shift is somehow ignored by first check logic"
		aMouseEvent anyModifierKeyPressed | aMouseEvent shiftPressed]) ifTrue: [ ^false ].
	
	(keyboardModifier notNil and: [ (keyboardModifier matchesEvent: aMouseEvent) not ])
		ifTrue: [ ^false ].
	
	^aMouseEvent whichButton anyMask: whichButton! !

!CmdMouseCommandActivation methodsFor: 'accessing' stamp: ''!
whichButton: anObject
	whichButton := anObject! !

!CmdMouseCommandActivation methodsFor: 'accessing' stamp: ''!
whichButton
	^ whichButton! !

!CmdMouseCommandActivation methodsFor: 'initialization' stamp: ''!
beBlueButton
	
	whichButton := MouseEvent blueButton! !

!CmdMouseCommandActivation methodsFor: 'initialization' stamp: ''!
beYellowButton
	
	whichButton := MouseEvent yellowButton! !

!CmdMouseCommandActivation methodsFor: 'testing' stamp: ''!
isActiveInContext: aToolContext
	| mouseEvent |
	mouseEvent := aToolContext currentWorld activeHand lastEvent.

	^(self matchesEvent: mouseEvent)
		and: [super isActiveInContext: aToolContext]! !

!CmdMouseCommandActivation methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream nextPut: $(.
	aStream nextPutAll: self printWhichButton.
	keyboardModifier ifNotNil: [ 
		aStream nextPutAll: ' '.
		keyboardModifier printOn: aStream ].
	aStream nextPut: $).! !

!CmdMouseCommandActivation methodsFor: 'printing' stamp: ''!
printWhichButton
	"Return a string identifying expected pressed buttons"
	self isRedButton ifTrue:[ ^'red' ].
	self isYellowButton ifTrue:[ ^'yellow'].
	self isBlueButton ifTrue:[ 'blue'].
	
	^'uknown button'! !

!CmdMouseCommandActivation methodsFor: 'testing' stamp: ''!
isBlueButton

	^whichButton anyMask: MouseEvent blueButton! !

!CmdMouseCommandActivation methodsFor: 'testing' stamp: ''!
isRedButton

	^whichButton anyMask: MouseEvent redButton! !

!CmdMouseCommandActivation methodsFor: 'testing' stamp: ''!
isYellowButton

	^whichButton anyMask: MouseEvent yellowButton! !

!CmdMouseCommandActivation methodsFor: 'accessing' stamp: ''!
keyboardModifier
	^ keyboardModifier! !

!CmdMouseCommandActivation methodsFor: 'initialization' stamp: ''!
beRedButton
	
	whichButton := MouseEvent redButton! !

!CmdMouseCommandActivation class methodsFor: 'instance creation' stamp: ''!
byYellowButtonFor: aCommandUser

	^(self for: aCommandUser)
		beYellowButton! !

!CmdMouseCommandActivation class methodsFor: 'instance creation' stamp: ''!
with: aKMModifier for: aCommandUser

	^(self for: aCommandUser)
		keyboardModifier: aKMModifier! !

!CmdMouseCommandActivation class methodsFor: 'instance creation' stamp: ''!
byYellowButtonWith: aKMModifier for: aCommandUser

	^(self byYellowButtonFor: aCommandUser)
		keyboardModifier: aKMModifier! !

!CmdMouseCommandActivation class methodsFor: 'morphs setup' stamp: ''!
morphicEventType
	self subclassResponsibility! !

!CmdMouseCommandActivation class methodsFor: 'morphs setup' stamp: ''!
handleMouseUsing: someObjectWithCommandContext event: anEvent from: sourceMorph 
	| targetContext |
	targetContext := someObjectWithCommandContext 
		createCommandContextForCursorAt: anEvent cursorPoint.
	
	self executeCommandInContext: targetContext.
	
	anEvent wasHandled: false! !

!CmdMouseCommandActivation class methodsFor: 'command execition' stamp: ''!
executeCommandInContext: aToolContext

	self activateAllInContext: aToolContext by: [:activator | 
		activator executeCommand.
		^true ].
	^false! !

!CmdMouseCommandActivation class methodsFor: 'morphs setup' stamp: ''!
enableInMorph: aMorph withCommandsFrom: someObjectWithCommandContext

	aMorph 
		on: self morphicEventType 
		send: #handleMouseUsing:event:from: to: self withValue: someObjectWithCommandContext! !

!CmdNullToolContext commentStamp: ''!
I allow to use CmdCommandActivator in cases when command is created manually without any tool.
In that case activation has no context and command is prepared by user manually.!
!CmdNullToolContext methodsFor: 'command execution' stamp: ''!
prepareNewCommand: aCommand! !

!CmdNullToolContext methodsFor: 'command execution' stamp: ''!
prepareFullExecutionOf: aCommand! !

!CmdNullToolContext methodsFor: 'command execution' stamp: ''!
applyResultOf: aCommand! !

!CmdNullToolContext methodsFor: 'testing' stamp: ''!
allowsExecutionOf: aCommandClass

	^true! !

!CmdOpenContextMenuCommand commentStamp: ''!
I am a hierarchy of commands which opens context menu using specified tool context which was using to activate me.

Subclasses should be created to open special kind of menus represented by different kind of CmdMenuCommandActivationStrategy.
They should implement method #activationStrategy by returning a class for required type of menu.

Internal Representation and Key Implementation Points.

    Instance Variables
	context:		<CmdToolContext>!
!CmdOpenContextMenuCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aToolContext
	super readParametersFromContext: aToolContext.
	
	context := aToolContext! !

!CmdOpenContextMenuCommand methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!CmdOpenContextMenuCommand methodsFor: 'context menu' stamp: ''!
registerContextMenuItemsFor: aCommandItem withBuilder: aBuilder
	"Here we need to take care because this command itself is added to menu of same context.
	So we will always enter into this method during submenu generation. 
	We catch this recursion using RecursionStopper. 
	It is easier than adding extra logic to menu registration process"	
	| submenu |
	RecursionStopper during: [ 		
		submenu := self activationStrategy buildMenuInContext: context.		 
		submenu isActive ifTrue: [ 					
			self doRegisterContextMenuItemsFor: aCommandItem withBuilder: aBuilder.
			"Registration builder uses #name to bind children to parent"
			submenu rootGroup name: aCommandItem name.
			submenu registerContextMenuItemsWithBuilder: aBuilder]		
	]! !

!CmdOpenContextMenuCommand methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!CmdOpenContextMenuCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Open context menu'! !

!CmdOpenContextMenuCommand methodsFor: 'execution' stamp: ''!
execute
	
	| menu |
	menu := self createContextMenu.
	menu hasItems ifFalse: [^self].
	
	menu setInvokingView: context tool.
	menu invokeModal! !

!CmdOpenContextMenuCommand methodsFor: 'context menu' stamp: ''!
fillContextMenu: aMenu using: aCommandActivator
	"Here we need to take care because this command itself is added to menu of same context.
	So we will always enter into this method during submenu generation. 
	We catch this recursion using RecursionStopper. 
	It is easier than adding extra logic to menu building process"	
	| submenu |
	RecursionStopper during: [ 
		submenu := self createContextMenu.
		submenu hasItems ifFalse: [ ^self ].
		
		super fillContextMenu: aMenu using: aCommandActivator.
		aMenu lastItem subMenu: submenu
	]! !

!CmdOpenContextMenuCommand methodsFor: 'execution' stamp: ''!
activationStrategy
	"Subclasses should return specific kind of activation strategy
	which will be used to collect context menu commands"
	self subclassResponsibility! !

!CmdOpenContextMenuCommand methodsFor: 'context menu' stamp: ''!
createContextMenu 

	^self activationStrategy buildContextMenuFor: context tool inContext: context! !

!CmdOpenContextMenuCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = CmdOpenContextMenuCommand! !

!CmdOpenStandardContextMenuCommand commentStamp: ''!
I am a command to open standard context menu.

I use CmdContextMenuCommandActivation to collect menu items.!
!CmdOpenStandardContextMenuCommand methodsFor: 'execution' stamp: ''!
activationStrategy
	^CmdContextMenuActivation! !

!CmdOpenTextLeftBarMenuCommand commentStamp: ''!
I am a command to open context menu of left side bar of text editor.
I use CmdTextLeftBarMenuActivation to collect all releated commands!
!CmdOpenTextLeftBarMenuCommand methodsFor: 'execution' stamp: ''!
activationStrategy
	^CmdTextLeftBarMenuActivation! !

!CmdOpenTextLeftBarMenuCommand class methodsFor: 'activation' stamp: ''!
contextClickActivation
	<classAnnotation>
	
	^CmdTextLeftBarClickActivation byYellowButtonFor: CmdToolContext! !

!CmdRootMenuGroup commentStamp: ''!
I represent root of menu!
!CmdRootMenuGroup methodsFor: 'testing' stamp: ''!
isRoot
	^true! !

!CmdRootMenuGroup methodsFor: 'testing' stamp: ''!
isLastInMenu
	"menu have only root. So I am always last in menu"
	^true! !

!CmdRootMenuGroup methodsFor: 'testing' stamp: ''!
isLastActiveItemInMenu
	"menu have only root. So I am always last in menu"
	^true! !

!CmdRootMenuGroup methodsFor: 'accessing' stamp: ''!
name
	^ name ifNil: [ super name ]! !

!CmdRootMenuGroup methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!CmdRootMenuGroup methodsFor: 'testing' stamp: ''!
isInlined
	"Root group is never presented as separate item in the list"
	^true! !

!CmdRootMenuGroup class methodsFor: 'parents' stamp: ''!
parentGroup
	self error: 'should not be called'! !

!CmdRootOfCommandExamples methodsFor: 'execution' stamp: ''!
readParametersFromContext: aToolContext
	savedParametersContext := aToolContext! !

!CmdRootOfCommandExamples methodsFor: 'accessing' stamp: ''!
savedParametersContext: anObject
	savedParametersContext := anObject! !

!CmdRootOfCommandExamples methodsFor: 'accessing' stamp: ''!
savedParametersContext
	^ savedParametersContext! !

!CmdRootOfCommandExamples class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = CmdRootOfCommandExamples! !

!CmdShortcutActivation commentStamp: ''!
I describe how access and execute command using given shortcut.

Add me to commands using:

	YourCommand>>yourApplicationShortcutActivation
		<classAnnotation>
		^CmdShortcutCommandActivation by: $y meta for: YourAppContext

I also define standard shortcuts on class side for rename and remove commands:

- renamingFor: aToolContext
- removalFor: aToolContext

In addition I add to the settings browser the root group "Shortcuts" with all my registered instances.
So user can redefine default values in settings browser. I use class annotation redefinition mehanizm to support it. 
To reset all redefined values evaluate following expression:

	CmdShortcutCommandActivation revertRedefinedInstances. 

Internal Representation and Key Implementation Points.

    Instance Variables
	keyCombination:		<KKKeyCombination>!
!CmdShortcutActivation methodsFor: 'accessing' stamp: ''!
keyCombination: anObject
	keyCombination := anObject! !

!CmdShortcutActivation methodsFor: 'settings' stamp: ''!
buildSettingNodeOn: aBuilder
	| nodeBuilder |
	nodeBuilder := aBuilder 
		nodeClass: CmdShortcutSetting name: self id.
	nodeBuilder node item shortcutActivation: self.
	^nodeBuilder! !

!CmdShortcutActivation methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	keyCombination printOn: aStream.
	aStream nextPut: $).! !

!CmdShortcutActivation methodsFor: 'command execution' stamp: ''!
tryExecuteCommandInContext: aToolContext byEvents: anEventBuffer
	
	| activator |
	(keyCombination matches: anEventBuffer) ifTrue: [ 
		(self isActiveInContext: aToolContext) ifFalse: [ ^false].
		
		(keyCombination matchesCompletely: anEventBuffer)
			ifTrue: [ KMBuffer uniqueInstance completeMatch.
				activator := self newActivatorFor: aToolContext.
				activator executeCommand]
			ifFalse: [ KMBuffer uniqueInstance partialMatch].
		^true].
	^false! !

!CmdShortcutActivation methodsFor: 'accessing' stamp: ''!
keyCombination
	^ keyCombination! !

!CmdShortcutActivation class methodsFor: 'settings' stamp: ''!
buildSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #shortcuts)
		label: 'Shortcuts';
		description: 'All System Command Shortcuts';
		with: [
			self buildSettingsFor: self redefiningInstances on: aBuilder.
			self 
				buildSettingsFor: (self registeredInstances copyWithoutAll: self redefiningInstances)
				on: aBuilder.
		]! !

!CmdShortcutActivation class methodsFor: 'well known shortcuts' stamp: ''!
renamingFor: anAnnotationUser  
	<classAnnotationDependency>
	
	^self by: $r meta for: anAnnotationUser! !

!CmdShortcutActivation class methodsFor: 'settings' stamp: ''!
buildSettingsFor: activations on: aBuilder
	| sorted |
	sorted := activations sorted: [ :a :b | a commandClass name <= b commandClass name ].
	sorted do: [ :each |	each buildSettingNodeOn: aBuilder]! !

!CmdShortcutActivation class methodsFor: 'well known shortcuts' stamp: ''!
removalFor: anAnnotationUser  
	<classAnnotationDependency>
	
	^self by: $x meta for: anAnnotationUser! !

!CmdShortcutActivation class methodsFor: 'instance creation' stamp: ''!
by: aKeyCombination for: anAnnotationUser  
	^(self for: anAnnotationUser)
		keyCombination: aKeyCombination! !

!CmdShortcutActivation class methodsFor: 'settings' stamp: ''!
settingInputWidgetForNode: aShortcutSetting
	| catcherMorph theme |
	theme := UITheme builder.
	catcherMorph := KMCatcherMorph for: aShortcutSetting.
	^ theme newRow: {catcherMorph}! !

!CmdShortcutSetting commentStamp: ''!
I represent a setting of concrete instance of shortcut activation strategy, the annotation instance registered in the system.

I use redefinition mechanizm of class annotations to change the parameters of given shortcut activation. Currently I only modify key combination value, the actual shortcut value.

I mark redefined shortcut with special star (*) at the beginning of my label.

When I user reset value to default I revert redefined annotation instance:

	shortcutActivation revertRedefinedInstance

I am used in class side methods of CmdShortcutCommandActivation which settings browser nodes for all registered shortcut instances.

Internal Representation and Key Implementation Points.

    Instance Variables
	shortcutActivation:		<CmdShortuctCommandActivation>!
!CmdShortcutSetting methodsFor: 'accessing' stamp: ''!
shortcutActivation: aShortcutActivation
	shortcutActivation := aShortcutActivation.
	
	label := shortcutActivation id.
	description := shortcutActivation commandClass comment.
	self markRedefinedStatus.! !

!CmdShortcutSetting methodsFor: 'updating' stamp: ''!
updated

	self markRedefinedStatus.
	self triggerEvent: self privateChangeEvent with: self! !

!CmdShortcutSetting methodsFor: 'accessing' stamp: ''!
realValue: aShortcutActivation

	shortcutActivation redefineBy: [
			shortcutActivation keyCombination: aShortcutActivation keyCombination].
		
	self updated! !

!CmdShortcutSetting methodsFor: 'visitor' stamp: ''!
acceptSettings: aVisitor 

	shortcutActivation isRedefined ifTrue: [ ^ aVisitor visitCmdShortcutSetting: self]! !

!CmdShortcutSetting methodsFor: 'accessing' stamp: ''!
hasDefault

	^shortcutActivation isRedefined! !

!CmdShortcutSetting methodsFor: 'accessing' stamp: ''!
default

	^shortcutActivation isRedefined 
		ifTrue: [ shortcutActivation redefinedInstance ]
		ifFalse: [ shortcutActivation ]! !

!CmdShortcutSetting methodsFor: 'accessing' stamp: ''!
shortcut
	^shortcutActivation keyCombination! !

!CmdShortcutSetting methodsFor: 'accessing' stamp: ''!
shortcutActivation
	^ shortcutActivation! !

!CmdShortcutSetting methodsFor: 'accessing' stamp: ''!
setToDefault

	shortcutActivation := shortcutActivation revertRedefinedInstanceIfAbsent: [
		self inform: 'Annotation not exists anymore'. 
		^self].
		
	self updated! !

!CmdShortcutSetting methodsFor: 'accessing' stamp: ''!
realValue

	^ shortcutActivation! !

!CmdShortcutSetting methodsFor: 'shortcut editor' stamp: ''!
accept: aKeyCombination 

	shortcutActivation redefineBy: [  shortcutActivation keyCombination: aKeyCombination ].
	self updated! !

!CmdShortcutSetting methodsFor: 'updating' stamp: ''!
markRedefinedStatus
	(label beginsWith: '*') ifTrue: [label := label allButFirst].
	
	shortcutActivation isRedefined ifTrue: [ label := '*', label ]! !

!CmdSimpleToolContext commentStamp: ''!
I represent context of simple tool where tool itself provide required and complete information about own state.
I pass tool as context instance to command activation methods. For example:

	aCommand prepareFullExecutionInContext: tool.
	
I simplify command activation for tools when context is not really needed.

But it is not recomended to use me for tool with list widgets because in that case I do not keep actual selection state. And every my instance will represent same state which is not appropriate in many cases. For example drag and drop operation of list items requires real context reification.!
!CmdSimpleToolContext methodsFor: 'command execution' stamp: ''!
prepareNewCommand: aCommand
	aCommand readParametersFromContext: tool! !

!CmdSimpleToolContext methodsFor: 'command execution' stamp: ''!
prepareFullExecutionOf: aCommand
	aCommand prepareFullExecutionInContext: tool! !

!CmdSimpleToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
allowsDropExecutionOf: aCommand
	^aCommand canBeExecutedInDropContext: tool! !

!CmdSimpleToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
prepareDropExecutionOf: aCommand
	aCommand prepareExecutionInDropContext: tool! !

!CmdSimpleToolContext methodsFor: 'command execution' stamp: ''!
applyResultOf: aCommand
	aCommand applyResultInContext: tool! !

!CmdSimpleToolContext methodsFor: 'testing' stamp: ''!
representsSimpleAnnotationUser: aToolClass

	^tool isKindOf: aToolClass! !

!CmdSimpleToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
prepareDragActivationOf: aCommand
	aCommand prepareExecutionInDragContext: tool! !

!CmdSimpleToolContext methodsFor: 'testing' stamp: ''!
allowsExecutionOf: aCommandClass

	^aCommandClass canBeExecutedInContext: tool! !

!CmdSimpleToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
applyDropResultOf: aCommand
	aCommand applyDropResultInContext: tool! !

!CmdSpecDragPassenger methodsFor: 'accessing' stamp: ''!
draggedItems: anObject
	draggedItems := anObject! !

!CmdSpecDragPassenger methodsFor: 'accessing' stamp: ''!
sourcePresenter
	^ sourcePresenter! !

!CmdSpecDragPassenger methodsFor: 'accessing' stamp: ''!
commandPassenger
	^ commandPassenger! !

!CmdSpecDragPassenger methodsFor: 'accessing' stamp: ''!
draggedItems
	^ draggedItems! !

!CmdSpecDragPassenger methodsFor: 'accessing' stamp: ''!
commandPassenger: anObject
	commandPassenger := anObject! !

!CmdSpecDragPassenger methodsFor: 'dropping' stamp: ''!
dropInContext: aToolContext
	commandPassenger dropInContext: aToolContext! !

!CmdSpecDragPassenger methodsFor: 'converting' stamp: ''!
asDraggableMorph
	^(draggedItems collect: [:each | sourcePresenter displayBlock value: each])
	 	asDraggableMorph! !

!CmdSpecDragPassenger methodsFor: 'testing' stamp: ''!
canBeDroppedInContext: aToolContext

	^commandPassenger canBeDroppedInContext: aToolContext! !

!CmdSpecDragPassenger methodsFor: 'accessing' stamp: ''!
sourcePresenter: anObject
	sourcePresenter := anObject! !

!CmdSpecDragPassenger methodsFor: '*Commander-SpecSupport' stamp: ''!
buildWithSpec
	^self! !

!CmdSpecDragPassenger class methodsFor: 'instance creation' stamp: ''!
from: sourcePresenter on: aDragPassenger with: draggedItems

	^self new 
		sourcePresenter: sourcePresenter;
		commandPassenger: aDragPassenger;
		draggedItems: draggedItems! !

!CmdTextLeftBarClickActivation commentStamp: ''!
I am activation of commands by click on left side bar in text editors.

Currently this bar is known as #textSegmentIcons ruler in the Rubric editor. It shows various iconic tips about source code. 
I provide the way how activate commands by clicking on this Rubric area: most priority activation strategy is used to execute single command!
!CmdTextLeftBarMenuActivation commentStamp: ''!
I represent special context menu of left side bar in text editors.

Currently this bar is known as #textSegmentIcons ruler in the Rubric editor. It shows various iconic tips about source code. 
I provide context menu by cmd+click or right click on this Rubric area: I build normal context menu with commands annotated by me.!
!CmdToolContext commentStamp: ''!
I am a root of application context hierarchy. I am bound to concrete tool (widget. element) of application.
My subclasses provide specific information about tool/application state.
They are used to declare command activation strategies. Every activation is created for concrete context class.

###TODO: 
Instances of my subclasses are used for command lookup. Each activation strategy checks that given context instance is activation of declared context class:
	aToolContext isActivationOf: toolContextClass 
By default I am activation of any of my superclasses. If command activation is defined for most base context class like me (CmdToolContext) then such command will be available for any kind of command tools: any shotcuts lookup, any menu, etc..
Subclasses can override this method to extend set of commands which should be available for them but which declared for other context classes.

I also responsible for command activation:
- allowsExecutionOf: aCommand
- prepareNewCommand: aCommand
- prepareFullExecutionOf: aCommand
- applyResultOf: aCommand

I delegate these messages to command with idea that my default implementation is kind of standard context. For example: 
	CmdToolContext>prepareFullExecutionOf: aCommand
		aCommand prepareFullExecutionInContext: self
My subclasses can override these method to ask commands for specific set of activation messages.

I provide comparison method #isSimilarTo: to compare two context instances. It can be usefull to detect that some visible tool/widget is not relevant anymore to current context of application.  It can be used when kind of tools should be rebuilt when some selections are changed.

Use following method to create instances:
	CmdToolContext for: aTool
	
Internal Representation and Key Implementation Points.

    Instance Variables
	tool:		<Object>!
!CmdToolContext methodsFor: 'accessing' stamp: ''!
tool: anObject
	tool := anObject! !

!CmdToolContext methodsFor: 'ui requests' stamp: ''!
openContextMenu: aMenu

	tool openContextMenu: aMenu! !

!CmdToolContext methodsFor: 'command execution' stamp: ''!
prepareNewCommand: aCommand
	aCommand readParametersFromContext: self! !

!CmdToolContext methodsFor: 'accessing' stamp: ''!
tool
	^ tool! !

!CmdToolContext methodsFor: 'command execution' stamp: ''!
executeCommand: aCommand by: aCommandActivator
	aCommand execute! !

!CmdToolContext methodsFor: 'command execution' stamp: ''!
prepareFullExecutionOf: aCommand
	aCommand prepareFullExecutionInContext: self! !

!CmdToolContext methodsFor: 'user requests' stamp: ''!
requestSingleMethodTag: queryTitle
	^self requestSingleMethodTag: queryTitle suggesting: ''! !

!CmdToolContext methodsFor: 'user requests' stamp: ''!
requestSingleMethodTag: queryTitle suggesting: suggestedTag
	| knownTags ui selectedTag |
	knownTags := (SystemNavigation default allExistingProtocolsFor: true)
		reject: [ :each | each beginsWith: '*' ].
	knownTags := knownTags asSortedCollection: [ :a :b | a asLowercase < b asLowercase ].	
	ui := ListDialogWindow new
		getList: [ :r | knownTags select: [ :e | r search: e ] ];
		displayBlock: [ :e | e ];
		initialAnswer: suggestedTag;
		acceptNewEntry: true;
		title: queryTitle;
		yourself.
	ui defaultFocusMorph contentMorph selectAll.
	selectedTag := ui chooseFromOwner: tool.
	selectedTag isEmptyOrNil ifTrue: [ CmdCommandAborted signal].
	(selectedTag beginsWith: '*') ifTrue: [ 
		self inform: 'Star is forbidden for protocol name. You can specify package in method editor using status bar checkbox'.
		^CmdCommandAborted signal].

	^selectedTag asSymbol! !

!CmdToolContext methodsFor: 'command execution' stamp: ''!
applyResultOf: aCommand
	aCommand applyResultInContext: self! !

!CmdToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
allowsDropExecutionOf: aCommand
	^aCommand canBeExecutedInDropContext: self! !

!CmdToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
prepareDropExecutionOf: aCommand
	aCommand prepareExecutionInDropContext: self! !

!CmdToolContext methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherToolContext
	^self = anotherToolContext! !

!CmdToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
prepareDragActivationOf: aCommand
	aCommand prepareExecutionInDragContext: self! !

!CmdToolContext methodsFor: 'testing' stamp: ''!
allowsExecutionOf: aCommandClass

	^aCommandClass canBeExecutedInContext: self! !

!CmdToolContext methodsFor: '*Calypso-Browser' stamp: ''!
isAboutBrowserItemType: itemTypeClass 
	^false! !

!CmdToolContext methodsFor: '*Commander-Activators-DragAndDrop' stamp: ''!
applyDropResultOf: aCommand
	aCommand applyDropResultInContext: self! !

!CmdToolContext methodsFor: 'command execution' stamp: ''!
processFailure: anException of: aCommand
	anException notifyUserOfCommand: aCommand! !

!CmdToolContext class methodsFor: 'instance creation' stamp: ''!
for: aTool
	^self new 
		tool: aTool! !

!CmdWorldMenuContext commentStamp: ''!
I represent a global context of World.
My tool is a current World morph instance.

Users can use me as context for commands which should be available in world menu or accessible by global shortcut. For example: 

	SycOpenBrowserCommand class>>worldMenuActivation
		<classAnnotation>
		^CmdContextMenuCommandActivation byRootGroupItemOrder: -1 for: CmdWorldMenuContext 
		
	SycOpenBrowserCommand class>>shortcutActivation
		<classAnnotation>
		^CmdShortcutCommandActivation by: $b meta for: CmdWorldMenuContext !
!CmdWorldMenuRegistration commentStamp: ''!
I implement registration of world menu and global shortucts using standard system pragmas: 

- <worldMenu>
- <keymap>

In addition to support shortucts I register special #CmdWorldShortcutsCategory in current World instance. During shortcuts collection I use this category to add keymaps into the given builder.  

Registration is done during class initialization. Or you can reevaluate it with:

	CmdWorldMenuRegistration attachShorctutsToWorld !
!CmdWorldMenuRegistration class methodsFor: 'world menu' stamp: ''!
createCommandContext

	^CmdWorldMenuContext for: self currentWorld! !

!CmdWorldMenuRegistration class methodsFor: 'world menu' stamp: ''!
initialize
	
	self enableWorldShortcuts! !

!CmdWorldMenuRegistration class methodsFor: 'world menu' stamp: ''!
enableWorldShortcuts
	<script>
	CmdKMDispatcher attachedTo: self currentWorld withCommandsFrom: self! !

!CmdWorldMenuRegistration class methodsFor: 'world menu' stamp: ''!
registerMenuOn: aBuilder 
	<worldMenu>

	CmdContextMenuActivation
		registerContextMenuOn: aBuilder inContext: self createCommandContext! !

!CoASTHeuristicsResultSetBuilder commentStamp: ''!
I am the an AST based heuristics builder.

When building the complishon, I build the AST from the source in the context, and get the current node from the context position.
Then I do a double dispatch on the current node and from it
1) I decide what fetchers to create
2) I extract the currently typed text and set is as initial filter!
!CoASTHeuristicsResultSetBuilder methodsFor: 'heuristics' stamp: ''!
messageHeuristic

	^ messageHeuristic ifNil: [ messageHeuristic := self newHeuristicBuilder
		add: CoSelfMessageHeuristic new;
		add: CoSuperMessageHeuristic new;
		add: CoInitializeInferencedMessageHeuristic new;
		add: CoLiteralMessageHeuristic new;
		add: CoGlobalVariableMessageHeuristic new;
		add: CoVariableWithTypeNameMessageHeuristic new;
		add: CoVariableValueMessageHeuristic new;
		add: CoUnknownMessageHeuristic new;
		build ]! !

!CoASTHeuristicsResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitMethodNode: aRBMethodNode 

	^ self
		configureFetcherForNode: aRBMethodNode
		usingHeuristicAvoidingRepetitions: self methodNodeHeuristic! !

!CoASTHeuristicsResultSetBuilder methodsFor: 'heuristics' stamp: ''!
newHeuristicBuilder
	^ CoHeuristicBuilder new! !

!CoASTHeuristicsResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitMessageNode: aRBMessageNode 
	
	^ self
		configureFetcherForNode: aRBMessageNode
		usingHeuristicAvoidingRepetitions: self messageHeuristic! !

!CoASTHeuristicsResultSetBuilder methodsFor: 'heuristics' stamp: ''!
methodNodeHeuristic
	^ methodNodeHeuristic ifNil: [
		methodNodeHeuristic := self newHeuristicBuilder
		add: CoSuperMessageHeuristic new;
		add: CoUnknownMessageHeuristic new;
		build ]! !

!CoASTHeuristicsResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitVariableNode: aRBVariableNode 

	^ self
		configureFetcherForNode: aRBVariableNode
		usingHeuristicAvoidingRepetitions: self variablesHeuristic! !

!CoASTHeuristicsResultSetBuilder methodsFor: 'heuristics' stamp: ''!
variablesHeuristic
	^ variablesHeuristic ifNil: [ variablesHeuristic := self newHeuristicBuilder
		add: CoLocalScopeVariablesHeuristic new;
		add: CoWorkspaceVariablesHeuristic new;
		add: CoInstanceAccessibleVariablesHeuristic new;
		add: CoGlobalVariablesHeuristic new;
		build ]! !

!CoASTNodeFetcherHeuristic commentStamp: ''!
I implement a fetcher heuristic for an AST node.
My responsibility is to build a fetcher for a given node in a given context.
I am implemented as a chain of responsibility: I treat the build request if possible, otherwise I forward the request to the next heuristic.

My main method #fetcherFor:inContext: is a template method.
My subclasses should redefine:
 - #appliesForNode:inContext: returning a boolean if the heuristic applies for context/node
 - #buildFetcherFor:inContext: returning the effective heuristic built!
!CoASTNodeFetcherHeuristic methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	next := CoNullFetcherHeuristic new! !

!CoASTNodeFetcherHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aRBMessageNode inContext: aContext
	
	^ false! !

!CoASTNodeFetcherHeuristic methodsFor: 'accessing' stamp: ''!
next
	^ next! !

!CoASTNodeFetcherHeuristic methodsFor: 'accessing' stamp: ''!
next: nextHeuristic 
	next := nextHeuristic! !

!CoASTNodeFetcherHeuristic methodsFor: 'testing' stamp: ''!
isStatisticsHeuristicWrapper
	
	^ false! !

!CoASTNodeFetcherHeuristic methodsFor: 'fetcher-creation' stamp: ''!
newMessageInHierarchyFetcherForClass: aClass inASTNode: astNode
	
	^ CoClassImplementedMessagesFetcher new
		astNode: astNode;
		completionClass: aClass;
		forHierarchy! !

!CoASTNodeFetcherHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aRBMessageNode inContext: aContext

	^ CoEmptyFetcher new! !

!CoASTNodeFetcherHeuristic methodsFor: 'requests' stamp: ''!
fetcherFor: aRBMessageNode inContext: aContext

	| nextFetcher |
	nextFetcher := self next fetcherFor: aRBMessageNode inContext: aContext.
	^ (self appliesForNode: aRBMessageNode inContext: aContext)
		ifTrue: [
			(self buildFetcherFor: aRBMessageNode inContext: aContext),
				nextFetcher ]
		ifFalse: [ nextFetcher ]! !

!CoASTResultSetBuilder commentStamp: ''!
I'm an abstract superclass for defining AST Based Complishons!
!CoASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
node: aNode

	node := aNode! !

!CoASTResultSetBuilder methodsFor: 'API - building' stamp: ''!
configureEmptyFetcherForNode: aNode
	
	^ self
		configureFetcher: CoEmptyFetcher new
		forNode: aNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitBlockNode: aRBBlockNode 

	^ self visitNode: aRBBlockNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitLiteralValueNode: aRBLiteralValueNode 
	
	^ self visitNode: aRBLiteralValueNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitArgumentVariableNode: anArgumentNode

	^ self visitVariableNode: anArgumentNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aRBSequenceNode 
	
	^ self visitNode: aRBSequenceNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitTemporaryVariableNode: anArgumentNode

	^ self visitVariableNode: anArgumentNode! !

!CoASTResultSetBuilder methodsFor: 'private - building' stamp: ''!
configureFetcher: aFetcher forNode: aNode
	
	| completion |
	completion := CoResultSet fetcher: aFetcher.
	completion filter: (CoBeginsWithFilter caseSensitive: NECPreferences caseSensitive filterString: completionContext completionToken).
	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: completionContext completionToken).
	^ completion! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitReturnNode: aRBReturnNode 
	
	^ self visitNode: aRBReturnNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitClassVariableNode: aRBVariableNode

	^ self visitVariableNode: aRBVariableNode! !

!CoASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
astNode
	
	^ astNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: aRBAssignmentNode 
	
	^ self visitNode: aRBAssignmentNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitCascadeNode: aRBCascadeNode 

	^ self visitNode: aRBCascadeNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitLiteralVariableNode: aRBVariableNode
	^ self visitVariableNode: aRBVariableNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitMethodNode: aRBMethodNode
	
	^ self visitNode: aRBMethodNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitNode: aNode
	
	^ self configureEmptyFetcherForNode: aNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitPragmaNode: aRBPragmaNode

	^ self visitNode: aRBPragmaNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitParseErrorNode: aRBParseErrorNode 
	
	^ self visitNode: aRBParseErrorNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitThisContextNode: aRBThisContextNode

	^ self visitNode: aRBThisContextNode! !

!CoASTResultSetBuilder methodsFor: 'API - building' stamp: ''!
parseNode

	^ node ifNil: [
		(completionContext completionClass compiler
			source: completionContext source;
			noPattern: completionContext isWorkspace; 
			options: #(+ optionParseErrors + optionSkipSemanticWarnings);
			parse) nodeForOffset: completionContext position ]! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitGlobalVariableNode: aRBVariableNode

	^ self visitVariableNode: aRBVariableNode! !

!CoASTResultSetBuilder methodsFor: 'private - building' stamp: ''!
configureFetcherForNode: aNode usingHeuristicAvoidingRepetitions: heuristic
	
	| fetcher |
	fetcher := heuristic fetcherFor: aNode inContext: completionContext.
	^ self
		configureFetcher: fetcher withoutRepetition withNarrowHistory
		forNode: aNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitEnglobingErrorNode: aRBVariableNode 
	^ self visitNode: aRBVariableNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aRBLiteralArrayNode 

	^ self visitNode: aRBLiteralArrayNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitArrayNode: aRBArrayNode 
	
	^ self visitNode: aRBArrayNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitSuperNode: aRBSuperNode 
	
	^ self visitNode: aRBSuperNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitSelfNode: aRBSelfNode 
	
	^ self visitNode: aRBSelfNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitMessageNode: aRBMessageNode
	
	^ self visitNode: aRBMessageNode! !

!CoASTResultSetBuilder methodsFor: 'API - building' stamp: ''!
buildCompletion

	"Visiting the node configures the completion for that node"
	astNode := self parseNode.
	^ astNode acceptVisitor: self! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitVariableNode: aRBVariableNode
	
	^ self visitNode: aRBVariableNode! !

!CoASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitInstanceVariableNode: aRBVariableNode 
	^ self visitVariableNode: aRBVariableNode! !

!CoASTResultSetBuilder class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == CoASTResultSetBuilder! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildMessageHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBMessageNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #message! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildVariableTempVariableHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: ((RBVariableNode named: 'temp') variable: (TemporaryVariable named: 'temp'));
		buildCompletion.
		
	self assert: builder heuristic equals: #variable! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildParseErrorHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBParseErrorNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #error! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildSequenceHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBSequenceNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #sequence! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildVariableUndeclaredHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: ((RBVariableNode named: 'ClassVar') variable: (UndeclaredVariable named: 'ClassVar'));
		buildCompletion.
		
	self assert: builder heuristic equals: #variable! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildVariableClassVariableHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: ((RBVariableNode named: 'ClassVar') variable: (ClassVariable named: 'ClassVar'));
		buildCompletion.
		
	self assert: builder heuristic equals: #variable! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildMethodHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBMethodNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #method! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildBlockHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBBlockNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #block! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildVariableGlobalHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: ((RBVariableNode named: 'Object') variable: Object binding);
		buildCompletion.
		
	self assert: builder heuristic equals: #variable! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildLiteralArrayHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBLiteralArrayNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #literalArray! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildPragmaHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBPragmaNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #pragma! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildCascadeHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBCascadeNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #cascade! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildVariableInstanceVariableHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: ((RBVariableNode named: 'ivar') variable: (Slot named: 'ivar'));
		buildCompletion.
		
	self assert: builder heuristic equals: #variable! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildLiteralHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBLiteralValueNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #literal! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
newCompletionContext

	^ CoCompletionContext new
		engine: CoMockEngine new;
		yourself! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildReturnHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBReturnNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #return! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildArrayHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBArrayNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #array! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildThisContextHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBVariableNode thisContextNode;
		buildCompletion.
		
	self assert: builder heuristic equals: #thisContext! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildAssignmentHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBAssignmentNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #assignment! !

!CoASTResultSetBuilderTest methodsFor: 'tests' stamp: ''!
testBuildVariableHeuristic

	| builder |
	builder := CoMockASTResultSetBuilder new.
	builder
		completionContext: self newCompletionContext;
		node: RBVariableNode new;
		buildCompletion.
		
	self assert: builder heuristic equals: #variable! !

!CoASTSessionResultSetBuilder methodsFor: 'heuristics' stamp: ''!
messageHeuristic
	^ messageHeuristic ifNil: [ messageHeuristic := self newHeuristicBuilder
		add: (CoSessionMessagesHeuristic new
			session: session;
			yourself);
		add: CoUnknownMessageHeuristic new;
		build ]! !

!CoASTSessionResultSetBuilder methodsFor: 'accessing' stamp: ''!
session
	^ session! !

!CoASTSessionResultSetBuilder methodsFor: 'accessing' stamp: ''!
session: anObject
	session := anObject! !

!CoAvoidRepeatedFetcher commentStamp: ''!
GenericComplishonFetcher I ensure that I will not return twice the same entity.
I am mainly used in the context of code completion of messages, although I can be used in other context.

For example, when looking to autocomplete messages for ==self==, an heuristic may choose to show the selectors in the class, then the selectors in the superclass, and so on, following the inheritance chain. However, in the class hierarchy we may observe redefined methods, so a naive fetcher will first show #redefined from the subclass and then #redefined again from the superclass.

I can be easily created by sending the #withoutRepetition message to another fetcher.

(GenericComplishonFetcher onCollection: aCollection) withoutRepetition.!
!CoAvoidRepeatedFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock
	decoree
		entriesDo: [ :elem | 
			(self hasAlreadyReturned: elem)
				ifFalse: [ 
					"As the NECEntry does not know how to compare I will enter the content as symbol"
					elements add: elem contents asSymbol.
					aBlock value: elem ] ]! !

!CoAvoidRepeatedFetcher methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	elements := Set new.! !

!CoAvoidRepeatedFetcher methodsFor: 'accessing' stamp: ''!
hasAlreadyReturned: anEntry

	^ elements includes: anEntry contents asSymbol! !

!CoAvoidRepeatedFetcher methodsFor: 'resetting' stamp: ''!
reset

	super reset.
	elements := Set new.! !

!CoAvoidRepeatedFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoAvoidRepeatedFetcher new
		decoree: (CoCollectionFetcher onCollection: #( a b b a c )).
	expectedElements := #(a b c).! !

!CoBasicCompletionTest methodsFor: 'tests' stamp: ''!
completionClass

	^ completionClass! !

!CoBasicCompletionTest methodsFor: 'tests' stamp: ''!
innerASTNode
	| nodeInsideABlock |
	RBMethodNode
		selector: #foo
		arguments: (#(methodArgument) collect: [ :e | RBVariableNode named: e ])
		body:
			(RBSequenceNode
				temporaries: (#(methodTemporary) collect: [ :e | RBVariableNode named: e ])
				statements:
					{(RBBlockNode
						arguments: (#(blockArgument) collect: [ :e | RBVariableNode named: e ])
						body:
							(RBSequenceNode
								temporaries: (#(blockTemporary) collect: [ :e | RBVariableNode named: e ])
								statements: {(nodeInsideABlock := RBVariableNode named: '')}))}).
	^ nodeInsideABlock! !

!CoBasicCompletionTest methodsFor: 'tests' stamp: ''!
systemNavigation

	^ systemNavigation! !

!CoBasicCompletionTest methodsFor: 'tests' stamp: ''!
assertCollectionOfEntry: aCollection equals: anotherCollection

	self assert: aCollection size equals: anotherCollection size.

	aCollection with: anotherCollection do: [ :a :b |
		self assertEntry: a equals: b ].! !

!CoBasicCompletionTest methodsFor: 'tests' stamp: ''!
assertEntry: anEntry equals: expectedEntry

	"Entries do not define equality :("
	self assert: anEntry class equals: expectedEntry class.
	self assert: anEntry contents equals: expectedEntry contents.! !

!CoBasicCompletionTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	completionClass := CoMockClass new
		instanceVariables: #(a b c);
		selectors: #(ma mb mc);
		classVariables: #(Ca Cb Cc);
		sharedPools: { 
			CoMockClass new
				classVariables: #(Sa Sb);
				superclass: (CoMockClass new
					classVariables: #(SSupera SSuperb);
					yourself);
				yourself.
			CoMockClass new
				classVariables: #(Sc);
				superclass: (CoMockClass new
					classVariables: #(SSuperc);
					yourself);
				yourself.
		};
		superclass: (CoMockClass new
			instanceVariables: #( supera superb superc );
			selectors: #(superma supermb supermc);
			classVariables: #(SuperCa SuperCb SuperCc);
			yourself)
		yourself.
	
	systemNavigation := CoMockSystemNavigation new
		globals: {'A' . 'B' . 'C'};
		yourself! !

!CoBasicCompletionTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == CoBasicCompletionTest! !

!CoBasicFetcherTest methodsFor: 'tests' stamp: ''!
testConsumedFetcherShouldBeAtEnd
	
	self fetcher upToEnd.
	self assert: self fetcher atEnd! !

!CoBasicFetcherTest methodsFor: 'accessing' stamp: ''!
fetcher
	^ fetcher! !

!CoBasicFetcherTest methodsFor: 'tests' stamp: ''!
testNextShouldReturnNilAfterEnd

	self fetcher upToEnd.
	self assert: self fetcher next equals: nil! !

!CoBasicFetcherTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == CoBasicFetcherTest! !

!CoBasicFetcherWithElementsTest methodsFor: 'tests' stamp: ''!
testNextManyShouldReturnCollection

	| fetchedElements expected |
	fetchedElements := self fetcher next: 2.
	expected := { self firstExpectedElement . self secondExpectedElement }.
	fetchedElements withIndexDo: [ :each :index |
		self assertEntry: each equals: (expected at: index) ].
	self assert: fetchedElements size equals: expected size! !

!CoBasicFetcherWithElementsTest methodsFor: 'tests' stamp: ''!
testResetShouldRestartGenerator

	| fetchedElements |
	self fetcher upToEnd; reset.
	fetchedElements := self fetcher next: expectedElements size + 1.
	fetchedElements withIndexDo: [ :each :index |
		self assertEntry: each equals: (expectedElements at: index) ].
	self assert: fetchedElements size equals: expectedElements size! !

!CoBasicFetcherWithElementsTest methodsFor: 'helpers' stamp: ''!
secondExpectedElement

	^ expectedElements second! !

!CoBasicFetcherWithElementsTest methodsFor: 'tests' stamp: ''!
testNextManyAfterLimitShouldStopAfterLimit

	| fetchedElements |
	fetchedElements := self fetcher next: expectedElements size + 1.
	fetchedElements withIndexDo: [ :each :index |
		self assertEntry: each equals: (expectedElements at: index) ].
	self assert: fetchedElements size equals: expectedElements size! !

!CoBasicFetcherWithElementsTest methodsFor: 'tests' stamp: ''!
testNextNextShouldReturnSecondExpectedElement

	self fetcher next.
	self assertEntry: self fetcher next equals: self secondExpectedElement! !

!CoBasicFetcherWithElementsTest methodsFor: 'tests' stamp: ''!
testNewFetcherWithElementsShouldNotBeAtEnd

	self deny: self fetcher atEnd! !

!CoBasicFetcherWithElementsTest methodsFor: 'tests' stamp: ''!
testNextShouldReturnFirstElement

	self assertEntry: self fetcher next equals: self firstExpectedElement! !

!CoBasicFetcherWithElementsTest methodsFor: 'helpers' stamp: ''!
firstExpectedElement

	^ expectedElements first! !

!CoBasicFetcherWithElementsTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == CoBasicFetcherWithElementsTest! !

!CoBeginsWithFilter commentStamp: ''!
I am representing the filters with a begins with.
!
!CoBeginsWithFilter methodsFor: 'accessing' stamp: ''!
completionString

	^ completionString! !

!CoBeginsWithFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanNegation: anotherFilter

	^ false! !

!CoBeginsWithFilter methodsFor: 'accessing' stamp: ''!
completionString: anObject

	completionString := anObject! !

!CoBeginsWithFilter class methodsFor: 'instance creation' stamp: ''!
caseSensitive: aBoolean filterString: aString 

	aBoolean ifTrue: [ 
		^ CoCaseSensitiveBeginsWithFilter new
			completionString: aString;
			yourself ] 
		ifFalse: [ 
		^ CoCaseInsensitiveBeginsWithFilter new
			completionString: aString;
			yourself	]! !

!CoBenchmarkContext commentStamp: ''!
I implement a completion context for benchmark purposes.
I contain an AST and provide information for the autocompletion based on it.
See CoStaticBenchmarks.!
!CoBenchmarkContext methodsFor: 'accessing' stamp: ''!
completionClass
	
	^ callsite methodNode methodClass! !

!CoBenchmarkContext methodsFor: 'testing' stamp: ''!
isWorkspace
	
	^ false! !

!CoBenchmarkContext methodsFor: 'accessing' stamp: ''!
doItContext
	
	^ nil! !

!CoBenchmarkContext methodsFor: 'accessing' stamp: ''!
position
	
	^ position first + 1! !

!CoBenchmarkContext methodsFor: 'accessing' stamp: ''!
position: aPosition
	
	position := aPosition! !

!CoBenchmarkContext methodsFor: 'accessing' stamp: ''!
callsite: anObject
	callsite := anObject! !

!CoBenchmarkContext methodsFor: 'accessing' stamp: ''!
source
	
	^ callsite methodNode method sourceCode! !

!CoBenchmarkContext methodsFor: 'accessing' stamp: ''!
doItRequestor

	^ nil! !

!CoBenchmarkContext methodsFor: 'accessing' stamp: ''!
environmentAt: aString ifPresent: aBlockClosure 
	
	self class environment at: aString ifPresent: aBlockClosure! !

!CoBenchmarkContext methodsFor: 'accessing' stamp: ''!
callsite
	^ callsite! !

!CoBenchmarkPackage commentStamp: ''!
I represent a package for benchmarking.
I mainly give access to methds in the package.
I am required because packages and methods are not polymorphic.!
!CoBenchmarkPackage methodsFor: 'enumerating' stamp: ''!
methodsDo: aBlockClosure 
	
	package definedClassesDo: [ :each | | class |
		class := self class environment at: each.
		class isTrait ifFalse: [
			(package definedMethodsForClass: class) do: aBlockClosure] ]! !

!CoBenchmarkPackage methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream print: package name! !

!CoBenchmarkPackage methodsFor: 'accessing' stamp: ''!
package: aRPackage 
	
	package := aRPackage! !

!CoBenchmarkPackage class methodsFor: 'instance creation' stamp: ''!
on: aRPackage 
	
	^ self new
		package: aRPackage;
		yourself! !

!CoCaseInsensitiveBeginsWithFilter commentStamp: ''!
The begins with can be case sensitive or not.
I am the implementation of insensitive comparison.
!
!CoCaseInsensitiveBeginsWithFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanCaseSensitive: anotherFilter

	^ false! !

!CoCaseInsensitiveBeginsWithFilter methodsFor: 'testing' stamp: ''!
isMoreNarrowThan: anotherFilter

	^ anotherFilter isLessNarrowThanCaseInsensitive: self! !

!CoCaseInsensitiveBeginsWithFilter methodsFor: 'testing' stamp: ''!
accepts: aCandidate
	
	completionString ifEmpty: [ ^ true ].
	^ aCandidate contents asLowercase beginsWith: completionString asLowercase! !

!CoCaseInsensitiveBeginsWithFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanCaseInsensitive: anotherFilter

	^ anotherFilter completionString beginsWith: self completionString! !

!CoCaseInsensitiveBeginsWithFilter class methodsFor: 'instance creation' stamp: ''!
filterString: aString

	^ self new
		completionString: aString;
		yourself! !

!CoCaseSensitiveBeginsWithFilter commentStamp: ''!
The begins with can be case sensitive or not.
I am the implementation of sensitive comparison.
!
!CoCaseSensitiveBeginsWithFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanCaseSensitive: anotherFilter

	^ anotherFilter completionString beginsWith: self completionString! !

!CoCaseSensitiveBeginsWithFilter methodsFor: 'testing' stamp: ''!
isMoreNarrowThan: anotherFilter

	^ anotherFilter isLessNarrowThanCaseSensitive: self! !

!CoCaseSensitiveBeginsWithFilter methodsFor: 'testing' stamp: ''!
accepts: aCandidate
	
	completionString ifEmpty: [ ^ true ].
	^ aCandidate contents beginsWith: completionString! !

!CoCaseSensitiveBeginsWithFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanCaseInsensitive: anotherFilter

	^ false! !

!CoCaseSensitiveBeginsWithFilter class methodsFor: 'instance creation' stamp: ''!
filterString: aString

	^ self new
		completionString: aString;
		yourself! !

!CoClassBasedFetcher commentStamp: ''!
I am an abstract complishon fetcher that looks for things inside a class.
My subclasses will, for example, fetch a class' class variables, messages implemented in the class, instance variables.

I am explicitly created with the superclass I will look into.
This allows other combinators to act upon me.
- I define #onSuperclass that creates a copy of myself but acting on my superclass.
- I define #forHierarchy that decorates myself with a HierarchyComplishonFetcher that makes a search for the entire hierarchy.!
!CoClassBasedFetcher methodsFor: 'accessing' stamp: ''!
completionClass
	^ completionClass! !

!CoClassBasedFetcher methodsFor: 'accessing' stamp: ''!
completionClass: anObject
	completionClass := anObject! !

!CoClassBasedFetcher methodsFor: 'hierarchy-fetching' stamp: ''!
forHierarchy
	
	^ CoHierarchyFetcher new
		decoree: self;
		yourself! !

!CoClassBasedFetcher methodsFor: 'accessing' stamp: ''!
astNode
	^ astNode! !

!CoClassBasedFetcher methodsFor: 'accessing' stamp: ''!
astNode: anObject
	astNode := anObject! !

!CoClassBasedFetcher methodsFor: 'hierarchy-fetching' stamp: ''!
onSuperclass
	
	completionClass superclass
		ifNil: [ ^ CoEmptyFetcher new ].

	^ self copy
		completionClass: completionClass superclass;
		yourself! !

!CoClassBasedFetcher class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == CoClassBasedFetcher! !

!CoClassImplementedMessagesFetcher commentStamp: ''!
I am a fetcher looking for the messages implemented in a class.!
!CoClassImplementedMessagesFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock
	
	self completionClass selectorsDo: [ :e | 
		aBlock value: (NECSelectorEntry contents: e node: astNode)]! !

!CoClassVariableFetcher commentStamp: ''!
I am a fetcher looking for the class variables implemented in a class.!
!CoClassVariableFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock
	
	self completionClass instanceSide classVarNames do: [ :e |
		aBlock value: (NECClassVarEntry contents: e node: astNode)]! !

!CoClassVariableFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoClassVariableFetcher new.
	fetcher completionClass: self completionClass.
	expectedElements := { 
		NECClassVarEntry contents: 'Ca' node: nil. 
		NECClassVarEntry contents: 'Cb' node: nil.
		NECClassVarEntry contents: 'Cc' node: nil.}! !

!CoCollectionFetcher commentStamp: ''!
I'm a fetcher simply enumerating a collection of items defined using the collection: message.
Mainly used for testing.!
!CoCollectionFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock

	collection do: aBlock! !

!CoCollectionFetcher methodsFor: 'accessing' stamp: ''!
collection: aCollection 
	collection := aCollection! !

!CoCollectionFetcher class methodsFor: 'instance creation' stamp: ''!
onCollection: aCollection 
	
	^ self new
		collection: aCollection;
		yourself! !

!CoCompletionCancelledEvent commentStamp: ''!
I represent the event of having quit the code completion without having accepted any entry.!
!CoCompletionContext commentStamp: ''!
I am the interface with the System's CompletionEngine, following the API of CompletionContext (entries, entryCount, activateEntryAt:, etc).
I delegate the calculation of the entries completely to a complishon object which is lazily built by a complishon builder.
The complishonBuilder instance can be specialized or replaced to change the search heuristics.!
!CoCompletionContext methodsFor: 'testing' stamp: ''!
isWorkspace
	
	^ engine notNil and: [ engine isScripting ]! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
completionAt: aNumber
	| entry |
	
	entry := (self entries at: aNumber) contents asSymbol separateKeywords.
	^ NECEntry spaceAfterCompletion 
		ifTrue: [ entry, ' ' ]
		ifFalse: [ entry ]! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
engine
	^ engine! !

!CoCompletionContext methodsFor: 'activating' stamp: ''!
activateEntryAt: anIndex

	(self entries at: anIndex) activateOn: self! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
engine: anObject
	engine := anObject! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
variableBindingNames

	^ self engine variableBindingNames! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
position: anObject
	position := anObject! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
systemNavigation
	
	^ CoSystemEnvironment new! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
completion: anObject
	completion := anObject! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!CoCompletionContext methodsFor: 'testing' stamp: ''!
completion

	completion ifNotNil: [ ^ completion ].
	completion := self completionBuilder
		completionContext: self;
		buildCompletion.
	completion filter: (CoBeginsWithFilter caseSensitive: NECPreferences caseSensitive filterString: self completionToken).
	^ completion! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
entryCount
	^ self entries size! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
title

	^ ''! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
completionToken

	^ self engine completionToken! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
completionClass
	
	^ completionClass! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
completionClass: aClass
	
	^ completionClass := aClass! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
doItContext

	^ engine doItContext! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
completionBuilder: anUndefinedObject 
	completionBuilder := anUndefinedObject! !

!CoCompletionContext methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	completionBuilder := CoASTHeuristicsResultSetBuilder initializeOnContext: self! !

!CoCompletionContext methodsFor: 'testing' stamp: ''!
hasEntries

	^ self completion notEmpty! !

!CoCompletionContext methodsFor: 'narrowing' stamp: ''!
narrowWith: aString 

	self completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: aString)! !

!CoCompletionContext methodsFor: 'replacing' stamp: ''!
replaceTokenInEditorWith: aString
	
	engine replaceTokenInEditorWith: aString! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
doItRequestor

	^ engine doItRequestor! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
environmentAt: aString ifPresent: aBlockClosure 
	
	^ self systemNavigation environmentAt: aString ifPresent: aBlockClosure! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
completionBuilder
	^ completionBuilder! !

!CoCompletionContext methodsFor: 'menu' stamp: ''!
hasMessage
	
	^ false! !

!CoCompletionContext methodsFor: 'accessing' stamp: ''!
entries

	^ self completion first: 20! !

!CoCompletionContext class methodsFor: 'initialize-release' stamp: ''!
engine: aCompletionEngine class: aClass source: aString position: anInteger

	^ self new
		completionClass: aClass;
		engine: aCompletionEngine;
		source: aString;
		position: anInteger;
		yourself! !

!CoCompletionEngine commentStamp: ''!
I am an adaptor between the Morphic text morphs supporting completion and Complishon.
I contain a complishonBuilder that is used to create a complishon.

See my superclass for details!
!CoCompletionEngine methodsFor: 'accessing' stamp: ''!
doItContext
	"Rubric sends the morph as requestor to the compiler.
	We need to use it to keep the same semantics..."

	^ self editor model doItContext! !

!CoCompletionEngine methodsFor: 'accessing' stamp: ''!
completionBuilder: anObject
	completionBuilder := anObject! !

!CoCompletionEngine methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	contextClass := CoCompletionContext.! !

!CoCompletionEngine methodsFor: 'accessing' stamp: ''!
variableBindingNames

	^ self doItRequestor 
		ifNil: [ #() ]
		ifNotNil: [ :requestor | requestor model variableBindings keys ]! !

!CoCompletionEngine methodsFor: 'accessing' stamp: ''!
doItRequestor

	^ self editor morph! !

!CoCompletionEngine methodsFor: 'accessing' stamp: ''!
completionBuilder

	^ completionBuilder ifNil: [ CoASTHeuristicsResultSetBuilder new ]! !

!CoCompletionEngine methodsFor: 'menu morph' stamp: ''!
createContext

	^ super createContext
		completionBuilder: self completionBuilder;
		yourself! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testPreviousWordClosesCompletionContext
	
	| text |
	text := 'self mEthOdThatDoesNotExist toto'.
	self
		setEditorText: text;
		selectAt: text size.
	
	editor textArea openInWorld.
	controller openMenu.
	
	"This is the current shortcut of the completion engine... Cmd+left for all platforms"
	editor keystroke: (self keyboardEventFor: Character arrowLeft useCommand: true).
	
	self deny: controller hasCompletionContext! !

!CoCompletionEngineTest methodsFor: 'accessing' stamp: ''!
doItContext
	
	^ nil! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testEndGoesToEndOfLine
	
	| text |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size - 5.
	
	editor textArea openInWorld.
	controller openMenu.
	
	editor keyDown: (self keyboardEventFor: Character end).
	
	self assert: editor caret equals: text size + 1! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testAdvanceWordGoesToNextWord
	
	| text |
	text := 'self mEthOdThatDoesNotExist toto'.
	self
		setEditorText: text;
		selectAt: text size - 10.
	
	editor textArea openInWorld.
	controller openMenu.
	
	"This is the current shortcut of the completion engine... Cmd+right for all platforms"
	editor keyDown: (self keyboardEventFor: Character arrowRight useCommand: true).
	
	self assert: editor caret equals: text size - 'toto' size.! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testHomeGoesToStartOfLine
	
	| text |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size - 5.
	
	editor textArea openInWorld.
	controller openMenu.
	
	editor keyDown: (self keyboardEventFor: Character home).
	
	self assert: editor caret equals: 1! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testPreviousWordGoesToPreviousWord
	
	| text |
	text := 'self mEthOdThatDoesNotExist toto'.
	self
		setEditorText: text;
		selectAt: text size.
	
	editor textArea openInWorld.
	controller openMenu.
	
	"This is the current shortcut of the completion engine... Cmd+left for all platforms"
	editor keyDown: (self keyboardEventFor: Character arrowLeft useCommand: true).
	
	self assert: editor caret equals: text size - 'toto' size + 1.! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testEndClosesCompletionContext
	
	| text |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size - 5.
	
	editor textArea openInWorld.
	controller openMenu.
	
	editor keystroke: (self keyboardEventFor: Character end).
	
	self deny: controller hasCompletionContext.! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testAdvanceWordDoesNotCloseCompletionContext
	"Because it will still be at the end of the current word"
	| text |
	text := 'self mEthOdThatDoesNotExist toto'.
	self
		setEditorText: text;
		selectAt: text size - 10.
	
	editor textArea openInWorld.
	controller openMenu.
	
	"This is the current shortcut of the completion engine... Cmd+right for all platforms"
	editor keyDown: (self keyboardEventFor: Character arrowRight useCommand: true).
	
	self assert: controller hasCompletionContext.! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testTypeCharacterWithoutResultsNarrowsSelection
	
	| text |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size + 1.
	
	editor textArea openInWorld.
	controller openMenu.
	
	editor keystroke: (self keyboardEventFor: $a).
	
	self assert: controller context completionToken equals: 'mEthOdThatDoesNotExist' , 'a'! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testHomeClosesCompletionContext
	
	| text |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size - 5.
	
	editor textArea openInWorld.
	controller openMenu.
	
	editor keystroke: (self keyboardEventFor: Character home).
	
	self deny: controller hasCompletionContext.! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testAdvanceWordTwiceClosesCompletionContext
	"Because it exists current word"
	| text |
	text := 'self mEthOdThatDoesNotExist toto'.
	self
		setEditorText: text;
		selectAt: text size - 10.
	
	editor textArea openInWorld.
	controller openMenu.
	
	"This is the current shortcut of the completion engine... Cmd+right for all platforms"
	2 timesRepeat: [
		editor keystroke: (self keyboardEventFor: Character arrowRight useCommand: true) ].
	
	self deny: controller hasCompletionContext.! !

!CoCompletionEngineTest methodsFor: 'asserting' stamp: ''!
shouldInheritSelectors

	^ true! !

!CoCompletionEngineTest methodsFor: 'running' stamp: ''!
newCompletionEngine
	
	^ CoCompletionEngine new! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testOpenMenuCreatesCompletionContext
	
	| text |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size + 1.
	
	editor textArea openInWorld.
	controller openMenu.
	
	self assert: controller hasCompletionContext! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testTypeCharacterWithoutResultsDoesNotCloseContext
	
	| text firstContext |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size + 1.
	
	editor textArea openInWorld.
	controller openMenu.
	firstContext := controller context.
	
	editor keystroke: (self keyboardEventFor: $a).
	
	self assert: controller context equals: firstContext! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testLeftWithoutResultsDoesNotCloseContext
	
	| text firstContext |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size + 1.
	
	editor textArea openInWorld.
	controller openMenu.
	firstContext := controller context.
	
	editor keyDown: (self keyboardEventFor: Character arrowLeft).
	
	self assert: controller context equals: firstContext! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testLeftWithoutResultsBroadensSelection
	
	| text |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size + 1.
	
	editor textArea openInWorld.
	controller openMenu.
	
	editor keyDown: (self keyboardEventFor: Character arrowLeft).
	
	self assert: controller context completionToken equals: 'mEthOdThatDoesNotExis'! !

!CoCompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testInitialCompletionEngineHasNoContext

	"If we did no interaction, no completion context should be initialized"
	
	| text |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size + 1.
		
	self deny: controller hasCompletionContext.! !

!CoEmptyFetcher commentStamp: ''!
By default I do not nothing. I'm the NullObject of the fetcher hierarchy.!
!CoEmptyFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock

	"Nothing"! !

!CoEmptyFetcher methodsFor: 'testing' stamp: ''!
isEmptyCompletionFetcher
	
	^ true! !

!CoEntryAcceptedEvent commentStamp: ''!
I represent the event of having accepted an entry in the candidate list of the code completion.
I have the index of the entry and the source that produced it (typically the heuristic)!
!CoEntryAcceptedEvent methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!CoEntryAcceptedEvent methodsFor: 'accessing' stamp: ''!
completedEntry
	^ completedEntry! !

!CoEntryAcceptedEvent methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!CoEntryAcceptedEvent methodsFor: 'accessing' stamp: ''!
completedEntry: anObject
	completedEntry := anObject! !

!CoEntryAcceptedEvent methodsFor: 'accessing' stamp: ''!
index: anObject
	index := anObject! !

!CoEntryAcceptedEvent methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!CoFetcher commentStamp: ''!
I'm a kind of iterator (in the sense of GoF) that goes one by one over "a stream" of entities that can be consumed by the completion engine within a completion context.

I provide access to the elements I return one by one (using the next message) in a controlled manner. 
At the root, I define the architecture to yield one entry at a time. 
The next method invokes the hook method #entriesDo: with a generator yielding capability.
This way any use of #next will be done step by step. 

My subclasses implement the following method entriesDo: aBlock which defines the semantics of element fetching
Here is a simple example where a generic fetcher is used on a collection, and wrapped by a fetcher that avoids returning duplicate elements.

[[[
fetcher := AvoidRepeatedComplishonFetcher new
	complishonFetcher: (GenericComplishonFetcher onCollection: #( a b b a c )).
]]]
	
Here are two examples of definition

[[[
AvoidRepeatedComplishonFecther >> entriesDo: aBlock
	decoree
		entriesDo: [ :elem | 
			(self hasAlreadyReturned: elem)
				ifFalse: [ elements add: elem.
					aBlock value: elem ] ]
]]]

[[[
GenericComplishonFetcher >> entriesDo: aBlock

	collection do: aBlock
]]]



	
!
!CoFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock
	"Key method for subclasses to define their semantics."
	
	^ self subclassResponsibility! !

!CoFetcher methodsFor: 'composing' stamp: ''!
unnarrowFilter: aFilter narrowKey: aKey

	self filter: aFilter! !

!CoFetcher methodsFor: 'private' stamp: ''!
initialize
	super initialize.
	
	filter := CoFilter empty! !

!CoFetcher methodsFor: 'composing' stamp: ''!
narrowFilter: aFilter narrowKey: aKey
	
	self filter: aFilter! !

!CoFetcher methodsFor: 'fetching' stamp: ''!
next
	
	^ self generator next! !

!CoFetcher methodsFor: 'fetching' stamp: ''!
next: anInteger 
	
	^ Array new: anInteger streamContents: [ :stream | | total last |
		total := 0.
		[ (last := self next) ifNotNil: [ :each | 
			stream nextPut: each.
			total := total + 1 ] ]
			doWhileTrue: [ total < anInteger and: [ last notNil ] ] ]! !

!CoFetcher methodsFor: 'enumerating' stamp: ''!
upToEnd
	
	^ self generator upToEnd! !

!CoFetcher methodsFor: 'resetting' stamp: ''!
filter: newFilter
	
	(newFilter isMoreNarrowThan: filter)
		ifFalse: [ self reset ].
		
	filter := newFilter.! !

!CoFetcher methodsFor: 'private' stamp: ''!
acceptsEntry: entry

	^ filter accepts: entry! !

!CoFetcher methodsFor: 'private' stamp: ''!
generator
	^ generator ifNil: [ 
		generator := Generator on: [ :g | 
			self entriesDo: [ :entry | 
				(self acceptsEntry: entry)
					ifTrue: [ g yield: entry ] ] ] ]! !

!CoFetcher methodsFor: 'composing' stamp: ''!
withNarrowHistory

	^ CoNarrowHistoryFetcher new
		decoree: self;
		yourself! !

!CoFetcher methodsFor: 'composing' stamp: ''!
, anotherFetcher 

	^ CoFetcherSequence new
		add: self;
		add: anotherFetcher;
		yourself! !

!CoFetcher methodsFor: 'testing' stamp: ''!
atEnd
	
	^ self generator atEnd! !

!CoFetcher methodsFor: 'composing' stamp: ''!
collect: aBlockClosure 
	
	^ CoMappingFetcher new
		decoree: self;
		collectBlock: aBlockClosure;
		yourself! !

!CoFetcher methodsFor: 'resetting' stamp: ''!
reset
	
	generator := nil! !

!CoFetcher methodsFor: 'testing' stamp: ''!
isEmptyCompletionFetcher
	
	^ false! !

!CoFetcher methodsFor: 'composing' stamp: ''!
withoutRepetition

	^ CoAvoidRepeatedFetcher new
		decoree: self;
		yourself! !

!CoFetcherDecorator commentStamp: ''!
I am an abstract decorator superclass encapsulating common tasks that should be done with my decoree.
I am a complishon fetcher exposing the same API, and redirecting it to my decoree by default.
My decoree is also a complishon fetcher.!
!CoFetcherDecorator methodsFor: 'accessing' stamp: ''!
decoree: anotherFetcher
	
	decoree := anotherFetcher! !

!CoFetcherDecorator methodsFor: 'accessing' stamp: ''!
filter: aFilter

	super filter: aFilter.
	decoree filter: aFilter! !

!CoFetcherDecorator methodsFor: 'resetting' stamp: ''!
reset

	super reset.
	decoree reset.! !

!CoFetcherDecorator class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == CoFetcherDecorator! !

!CoFetcherSequence commentStamp: ''!
I'm a fetcher composed of a sequence of subfetchers. 
When executed, I execute my subfetchers one by one.

Sequences are created by sending the message #, between two fetchers.!
!CoFetcherSequence methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock
	subcompletions do: [ :completion | completion entriesDo: aBlock ]! !

!CoFetcherSequence methodsFor: 'adding' stamp: ''!
add: aCompletion
	
	subcompletions add: aCompletion! !

!CoFetcherSequence methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	subcompletions := OrderedCollection new! !

!CoFetcherSequence methodsFor: 'resetting' stamp: ''!
context: anObject
	
	super context: anObject.
	subcompletions do: [ :each | each context: anObject ]! !

!CoFetcherSequence methodsFor: 'enumerating' stamp: ''!
filter: aFilter

	super filter: aFilter.
	subcompletions do: [ :completion | completion filter: aFilter ]! !

!CoFetcherSequence methodsFor: 'resetting' stamp: ''!
reset
	
	super reset.
	subcompletions do: [ :each | each reset ].! !

!CoFetcherWithNoResultsTest methodsFor: 'tests' stamp: ''!
testCompletionWithNoResultsShouldBeAtEnd

	self assert: self fetcher atEnd! !

!CoFetcherWithNoResultsTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoInstanceVariableFetcher new.
	fetcher completionClass: self completionClass.
	fetcher := fetcher filter: (CoCaseSensitiveBeginsWithFilter filterString: '*Non¨_exiuting')! !

!CoFilter commentStamp: ''!
The filters are first class objects that knows what is the filter operation and also can compare with each other to see if they are narrowing or not the search. 
This information is used to know if the fetcher should be reset or not, if we are just narrowing the same query, we don't need to renarrow the fetcher.!
!CoFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanCaseSensitive: anotherFilter

	^ self subclassResponsibility! !

!CoFilter methodsFor: 'testing' stamp: ''!
negated

	^ CoNegationFilter new
		negatedFilter: self;
		yourself! !

!CoFilter methodsFor: 'testing' stamp: ''!
isMoreNarrowThan: anotherFilter

	^ self subclassResponsibility! !

!CoFilter methodsFor: 'testing' stamp: ''!
accepts: aCandidate
	
	self subclassResponsibility! !

!CoFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanNegation: anotherFilter

	^ self subclassResponsibility! !

!CoFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanCaseInsensitive: anotherFilter

	^ self subclassResponsibility! !

!CoFilter class methodsFor: 'instance creation' stamp: ''!
empty
	
	^ CoCaseSensitiveBeginsWithFilter filterString: ''! !

!CoFilterFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoInstanceVariableFetcher new.
	fetcher completionClass: self completionClass.
	fetcher filter: (CoCaseSensitiveBeginsWithFilter filterString: 'a') negated.
	expectedElements := { 
		NECInstVarEntry contents: 'b' node: nil. 
		NECInstVarEntry contents: 'c' node: nil. }! !

!CoFilterNarrowingComparisonTest methodsFor: 'tests' stamp: ''!
testCaseInsensitiveFilterIsNarrowWhenTheInternalAreNarrowed

	| caseSensitive caseSensitive2 |

	caseSensitive := CoCaseInsensitiveBeginsWithFilter filterString: 'ab'.
	caseSensitive2 := CoCaseInsensitiveBeginsWithFilter filterString: 'abc'.

	self deny: (caseSensitive isMoreNarrowThan: caseSensitive2).
	self assert: (caseSensitive2 isMoreNarrowThan: caseSensitive).! !

!CoFilterNarrowingComparisonTest methodsFor: 'tests' stamp: ''!
testCaseSensitiveFilterIsNarrowWhenTheInternalAreNarrowed

	| caseSensitive caseSensitive2 |

	caseSensitive := CoCaseSensitiveBeginsWithFilter filterString: 'ab'.
	caseSensitive2 := CoCaseSensitiveBeginsWithFilter filterString: 'abc'.

	self deny: (caseSensitive isMoreNarrowThan: caseSensitive2).
	self assert: (caseSensitive2 isMoreNarrowThan: caseSensitive).! !

!CoFilterNarrowingComparisonTest methodsFor: 'tests' stamp: ''!
testCaseSensitiveFilterIsNotNarrowWhenTheInternalAreNotNarrowed

	| caseSensitive caseSensitive2 |

	caseSensitive := CoCaseSensitiveBeginsWithFilter filterString: 'ab'.
	caseSensitive2 := CoCaseSensitiveBeginsWithFilter filterString: 'ax'.

	self deny: (caseSensitive isMoreNarrowThan: caseSensitive2).
	self deny: (caseSensitive2 isMoreNarrowThan: caseSensitive).! !

!CoFilterNarrowingComparisonTest methodsFor: 'tests' stamp: ''!
testNegatedFilterIsNotNarrowThanCaseSensitive

	| caseSensitive negated |

	caseSensitive := CoCaseSensitiveBeginsWithFilter filterString: 'ab'.
	negated := caseSensitive negated.
	
	self deny: (negated isMoreNarrowThan: caseSensitive)! !

!CoFilterNarrowingComparisonTest methodsFor: 'tests' stamp: ''!
testNegatedFilterIsNotNarrowThanCaseInsensitive

	| caseInsensitive negated |

	caseInsensitive := CoCaseInsensitiveBeginsWithFilter filterString: 'ab'.
	negated := caseInsensitive negated.
	
	self deny: (negated isMoreNarrowThan: caseInsensitive)! !

!CoFilterNarrowingComparisonTest methodsFor: 'tests' stamp: ''!
testCaseInsensitiveFilterIsNotNarrowThanNegated

	| caseInsensitive negated |

	caseInsensitive := CoCaseInsensitiveBeginsWithFilter filterString: 'ab'.
	negated := caseInsensitive negated.
	
	self deny: (caseInsensitive isMoreNarrowThan: negated)! !

!CoFilterNarrowingComparisonTest methodsFor: 'tests' stamp: ''!
testCaseSensitiveFilterIsNotNarrowThanNegated

	| caseSensitive negated |

	caseSensitive := CoCaseSensitiveBeginsWithFilter filterString: 'ab'.
	negated := caseSensitive negated.
	
	self deny: (caseSensitive isMoreNarrowThan: negated)! !

!CoFilterNarrowingComparisonTest methodsFor: 'tests' stamp: ''!
testNegatedFilterIsNotNarrowThanANegatedWithANonNarrowed

	| caseSensitive negated caseSensitive2 negated2 |

	caseSensitive := CoCaseSensitiveBeginsWithFilter filterString: 'ab'.
	caseSensitive2 := CoCaseSensitiveBeginsWithFilter filterString: 'ax'.

	self deny: (caseSensitive isMoreNarrowThan: caseSensitive2).
	self deny: (caseSensitive2 isMoreNarrowThan: caseSensitive). 

	negated := caseSensitive negated.
	negated2 := caseSensitive2 negated.
	
	self deny: (negated isMoreNarrowThan: negated2).
	self deny: (negated2 isMoreNarrowThan: negated)! !

!CoFilterNarrowingComparisonTest methodsFor: 'tests' stamp: ''!
testNegatedFilterIsNarrowWhenTheInternalAreNarrowed

	| caseSensitive negated caseSensitive2 negated2 |

	caseSensitive := CoCaseSensitiveBeginsWithFilter filterString: 'ab'.
	caseSensitive2 := CoCaseSensitiveBeginsWithFilter filterString: 'abc'.

	self deny: (caseSensitive isMoreNarrowThan: caseSensitive2).
	self assert: (caseSensitive2 isMoreNarrowThan: caseSensitive). 

	negated := caseSensitive negated.
	negated2 := caseSensitive2 negated.
	
	self deny: (negated isMoreNarrowThan: negated2).
	self assert: (negated2 isMoreNarrowThan: negated)! !

!CoFilterNarrowingComparisonTest methodsFor: 'tests' stamp: ''!
testCaseInsensitiveFilterIsNotNarrowWhenTheInternalAreNotNarrowed

	| caseSensitive caseSensitive2 |

	caseSensitive := CoCaseInsensitiveBeginsWithFilter filterString: 'ab'.
	caseSensitive2 := CoCaseInsensitiveBeginsWithFilter filterString: 'ax'.

	self deny: (caseSensitive isMoreNarrowThan: caseSensitive2).
	self deny: (caseSensitive2 isMoreNarrowThan: caseSensitive).! !

!CoGlobalSorterResultSetBuilder commentStamp: ''!
I build a resultset with all possible candidates for an AST node, pre-sorted with a sorter.!
!CoGlobalSorterResultSetBuilder methodsFor: 'API - building' stamp: ''!
parseNode

	| aNewNode |
	aNewNode := super parseNode.
	TypingVisitor new visitNode: aNewNode methodNode.
	^ aNewNode! !

!CoGlobalSorterResultSetBuilder methodsFor: 'accessing' stamp: ''!
sorterClass: anObject
	sorterClass := anObject! !

!CoGlobalSorterResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitNode: aNode

	| fetcher entries sorter |
	entries := aNode completionEntries: completionContext position.
	sorter := self sorterClass new context: completionContext.
	entries := sorter sortCompletionList: entries asOrderedCollection.

	fetcher := (CoCollectionFetcher onCollection: entries).

	^ self
		configureFetcher: fetcher
		forNode: aNode! !

!CoGlobalSorterResultSetBuilder methodsFor: 'accessing' stamp: ''!
sorterClass
	
	^ sorterClass ifNil: [ completionContext class sorterClass ]! !

!CoGlobalVariableFetcher commentStamp: ''!
I am a fetcher looking for globals in an environment.!
!CoGlobalVariableFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock

	self systemNavigation
		allClassNamesStartingWith: filter completionString 
		do: [ :e | aBlock value: (NECGlobalEntry contents: e node: astNode) ]! !

!CoGlobalVariableFetcher methodsFor: 'accessing' stamp: ''!
systemNavigation
	^ systemNavigation ifNil: [ SystemNavigation new ]! !

!CoGlobalVariableFetcher methodsFor: 'accessing' stamp: ''!
astNode
	^ astNode! !

!CoGlobalVariableFetcher methodsFor: 'accessing' stamp: ''!
systemNavigation: anObject
	systemNavigation := anObject! !

!CoGlobalVariableFetcher methodsFor: 'accessing' stamp: ''!
astNode: anObject
	astNode := anObject! !

!CoGlobalVariableFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoGlobalVariableFetcher new.
	fetcher systemNavigation: self systemNavigation.

	expectedElements := { 
		NECGlobalEntry contents: 'A' node: nil.
		NECGlobalEntry contents: 'B' node: nil. 
		NECGlobalEntry contents: 'C' node: nil. }! !

!CoGlobalVariableMessageHeuristic commentStamp: ''!
I implement an heuristic for messages sent to globals.
If the global object is available in the environment, 
 - if it is a class complete messages in it class side
 - if it is a global object complete messages in the global object's class

See my superclass for details.!
!CoGlobalVariableMessageHeuristic methodsFor: 'requests' stamp: ''!
newFetcherForGlobal: aGlobal inASTNode: ast

	"This is a class or trait. Autocomplete class-side messages" 
	aGlobal isClassOrTrait ifTrue: [
		^ CoClassImplementedMessagesFetcher new
			astNode: ast;
			completionClass: aGlobal classSide;
			forHierarchy ].

	"This is not a class binding but a global object. Autocomplete based on its class"
	^ CoClassImplementedMessagesFetcher new
		astNode: ast;
		completionClass: aGlobal class;
		forHierarchy! !

!CoGlobalVariableMessageHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aRBMessageNode inContext: completionContext

	completionContext
		environmentAt: aRBMessageNode receiver name
		ifPresent: [ :global | ^ self newFetcherForGlobal: global inASTNode: aRBMessageNode ].

	^ CoEmptyFetcher new! !

!CoGlobalVariablesHeuristic commentStamp: ''!
I implement an heuristic for global variables accessible in the completion environment.

See my superclass for details.!
!CoGlobalVariablesHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ aNode isVariable! !

!CoGlobalVariablesHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aNode inContext: completionContext

	^ CoGlobalVariableFetcher new
			astNode: aNode;
			yourself! !

!CoHeuristicBuilder commentStamp: ''!
I am an heuristic builder.
I am composed with several small heuristics and generate a chain of responsibility from them in the right order.

For example, given a list of heuristics:

CoHeuristicBuilder new
	add: CoSelfMessageHeuristic new;
	add: CoSuperMessageHeuristic new;
	add: CoInitializeInferencedMessageHeuristic new;
	yourself.

I create the following chain:

CoSelfMessageHeuristic -next-> CoSuperMessageHeuristic -next-> CoInitializeInferencedMessageHeuristic
	
I am used also as a hook, that can be redefined in subclasses and build heuristics differently.!
!CoHeuristicBuilder methodsFor: 'adding' stamp: ''!
add: anHeuristic
	
	heuristics add: anHeuristic! !

!CoHeuristicBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	heuristics := OrderedCollection new! !

!CoHeuristicBuilder methodsFor: 'building' stamp: ''!
build

	^ heuristics reduceRight: [ :left :right | left next: right. left ]! !

!CoHierarchyClassVariableFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoClassVariableFetcher new
		completionClass: self completionClass;
		forHierarchy.
	expectedElements := { 
		NECClassVarEntry contents: 'Ca' node: nil. 
		NECClassVarEntry contents: 'Cb' node: nil.
		NECClassVarEntry contents: 'Cc' node: nil.
		NECClassVarEntry contents: 'SuperCa' node: nil. 
		NECClassVarEntry contents: 'SuperCb' node: nil.
		NECClassVarEntry contents: 'SuperCc' node: nil.}! !

!CoHierarchyFetcher commentStamp: ''!
I am a complishon fetcher decorator for ClassBasedComplishonFetcher that will iterate from my child up to the end of the class hierarchy.
I'll yield all results found in one, then move to the superclass, and so on.!
!CoHierarchyFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock
	| currentCompletionFetcher |
	currentCompletionFetcher := decoree.
	[ currentCompletionFetcher isEmptyCompletionFetcher ]
		whileFalse: [ currentCompletionFetcher entriesDo: aBlock.
			currentCompletionFetcher := currentCompletionFetcher onSuperclass ]! !

!CoHierarchyImplementedSelectorsFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoClassImplementedMessagesFetcher new
		completionClass: self completionClass;
		forHierarchy.
	expectedElements := { 
		NECSelectorEntry contents: 'ma' node: nil.
		NECSelectorEntry contents: 'mb' node: nil.
		NECSelectorEntry contents: 'mc' node: nil.
		NECSelectorEntry contents: 'superma' node: nil.
		NECSelectorEntry contents: 'supermb' node: nil.
		NECSelectorEntry contents: 'supermc' node: nil.}! !

!CoHierarchyInstanceVariableFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoInstanceVariableFetcher new
		completionClass: self completionClass;
		forHierarchy.
	expectedElements := { 
		NECInstVarEntry contents: 'a' node: nil. 
		NECInstVarEntry contents: 'b' node: nil.
		NECInstVarEntry contents: 'c' node: nil.
		NECInstVarEntry contents: 'supera' node: nil. 
		NECInstVarEntry contents: 'superb' node: nil.
		NECInstVarEntry contents: 'superc' node: nil. }! !

!CoImplementedSelectorsFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoClassImplementedMessagesFetcher new.
	fetcher completionClass: self completionClass.
	expectedElements := { 
		NECSelectorEntry contents: 'ma' node: nil.
		NECSelectorEntry contents: 'mb' node: nil.
		NECSelectorEntry contents: 'mc' node: nil.}! !

!CoInitializeInferencedMessageHeuristic commentStamp: ''!
I am an heuristic using depth-bound type inference to type variables.
I autocomplete messages in the hierarchy of the found types.!
!CoInitializeInferencedMessageHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ aContext completionClass notNil
		and: [ aNode receiver isVariable ]! !

!CoInitializeInferencedMessageHeuristic methodsFor: 'requests' stamp: ''!
inferTypesIn: aClass

	^ CoTypeInferencer new
		inferFrom: aClass;
		variables! !

!CoInitializeInferencedMessageHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aNode inContext: aContext

	| variables fetcher |
	variables := self inferTypesIn: aContext completionClass.
	fetcher := CoEmptyFetcher new.
	variables
		at: aNode receiver name
		ifPresent: [ :types |
			types do: [ :each |
				fetcher := (self newMessageInHierarchyFetcherForClass: each inASTNode: aNode), fetcher ] ].
	^ fetcher! !

!CoInitializeTypeInferenceTest methodsFor: 'tests' stamp: ''!
testInferInstanceVariableNotUsedInInitializeHasNoType

	| types |
	types := CoTypeInferencer new
		inferFrom: (CoMockClass new
			methodAt: #initialize put: (CoMockMethod new
				source: 'initialize
					a := 1'
				yourself);
			instanceVariables: #(a b c);
			yourself);
		variables.
		
	self assert: (types at: #b) isEmpty! !

!CoInitializeTypeInferenceTest methodsFor: 'tests' stamp: ''!
testInferUndefinedInstanceVariableUsedInInitialize

	| types |
	types := CoTypeInferencer new
		inferFrom: (CoMockClass new
			methodAt: #initialize put: (CoMockMethod new
				source: 'initialize
					a'
				yourself);
			instanceVariables: #();
			yourself);
		variables.
		
	self assertCollection: (types at: #a) hasSameElements: Set new! !

!CoInitializeTypeInferenceTest methodsFor: 'tests' stamp: ''!
testInferInstanceVariableUsedInInitialize

	| types |
	types := CoTypeInferencer new
		inferFrom: (CoMockClass new
			methodAt: #initialize put: (CoMockMethod new
				source: 'initialize
					a := 1'
				yourself);
			instanceVariables: #(a b c);
			yourself);
		variables.
		
	self assertCollection: (types at: #a) hasSameElements: { SmallInteger }! !

!CoInitializeTypeInferenceTest methodsFor: 'tests' stamp: ''!
testInferVariablesWithNoInitializeFindsNoTypes

	| types |
	types := CoTypeInferencer new
		inferFrom: (CoMockClass new
			instanceVariables: #(a b c);
			yourself);
		variables.
		
	self assert: (types values allSatisfy: [ :e | e isEmpty ]).! !

!CoInstanceAccessibleVariablesHeuristic commentStamp: ''!
I implement an heuristic for variables accessible from the instance side, such as instance variables and class variables.

See my superclass for details.!
!CoInstanceAccessibleVariablesHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ aContext completionClass notNil! !

!CoInstanceAccessibleVariablesHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: astNode inContext: completionContext
	
	| ivFetcher cvFetcher |
	
	"Then instance variables"
	ivFetcher := (CoInstanceVariableFetcher new
		astNode: astNode;
		completionClass: completionContext completionClass) forHierarchy.
	
	"Then class variables if not a workspace"
	cvFetcher :=  (CoClassVariableFetcher new
			astNode: astNode;
			completionClass: completionContext completionClass) forHierarchy.
	
	^ ivFetcher, cvFetcher, (CoSharedPoolVariableFetcher new
		astNode: astNode;
		completionClass: completionContext completionClass;
		yourself) forHierarchy! !

!CoInstanceVariableFetcher commentStamp: ''!
I am a fetcher looking for the instance variables implemented in a class.!
!CoInstanceVariableFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock
	
	self completionClass instVarNames do: [ :e |
		aBlock value: (NECInstVarEntry contents: e node: astNode)]! !

!CoInstanceVariableFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoInstanceVariableFetcher new.
	fetcher completionClass: self completionClass.
	expectedElements := { 
		NECInstVarEntry contents: 'a' node: nil. 
		NECInstVarEntry contents: 'b' node: nil.
		NECInstVarEntry contents: 'c' node: nil. }! !

!CoLiteralMessageHeuristic commentStamp: ''!
I implement an heuristic for messages sent to literals.
If there is a literal as receiver, create a fetcher for messages of its class.

See my superclass for details.!
!CoLiteralMessageHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ aNode receiver isLiteralNode! !

!CoLiteralMessageHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aRBMessageNode inContext: aContext

	^ self newMessageInHierarchyFetcherForClass: aRBMessageNode receiver value class inASTNode: aRBMessageNode! !

!CoLocalScopeVariablesHeuristic commentStamp: ''!
I implement an heuristic for local variables accessible from the current AST node.

See my superclass for details.!
!CoLocalScopeVariablesHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ true! !

!CoLocalScopeVariablesHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aNode inContext: aContext

	^ CoMethodVariableFetcher new completionASTNode: aNode! !

!CoMappingFetcher commentStamp: ''!
I am a mapping complishon fetcher. I decorate a complishon fetcher and transform its results to those ones using the collectBlock block.
I can be created by sending the #collect: message to an existing fetcher.

(GenericComplishonFetcher onCollection: aCollection) collect [ :each | each * 2 ]!
!CoMappingFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlockClosure

	decoree entriesDo: [ :each | aBlockClosure value: (collectBlock value: each) ]! !

!CoMappingFetcher methodsFor: 'accessing' stamp: ''!
collectBlock: aBlockClosure 
	
	collectBlock := aBlockClosure! !

!CoMethodVariableFetcher commentStamp: ''!
I am a complishon fetcher that autocompletes variable names accessible in the lexical context of a method.
That is, block temporaries, block arguments, method temporaries and method arguments.

From a given ast node, I walk up the tree looking for scopes and yield the variables I find.!
!CoMethodVariableFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock

	self methodVariableNamesDo: [ :each |
		aBlock value: (NECLocalEntry contents: each node: completionASTNode) ]! !

!CoMethodVariableFetcher methodsFor: 'accessing' stamp: ''!
methodVariableNamesDo: aBlock

	| currentNode |
	currentNode := completionASTNode.
	[ currentNode notNil ] whileTrue: [ 
		"ASTs are strange.
		There is no way to ask the variables defined in the scope in an ordered way.
		Hack our way through"
		self flag: #notNice.
		currentNode isSequence ifTrue: [ 
			currentNode temporaryNames do: aBlock.
			currentNode parent argumentNames do: aBlock ].
		currentNode := currentNode parent ]! !

!CoMethodVariableFetcher methodsFor: 'accessing' stamp: ''!
completionASTNode
	^ completionASTNode! !

!CoMethodVariableFetcher methodsFor: 'accessing' stamp: ''!
completionASTNode: anObject
	completionASTNode := anObject! !

!CoMethodVariablesFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoMethodVariableFetcher new.
	fetcher completionASTNode: self innerASTNode.
	expectedElements := #(blockTemporary blockArgument methodTemporary methodArgument)
		collect: [:e | NECLocalEntry contents: e node: nil ].! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitBlockNode: aNode

	heuristic := #block.
	^ super visitBlockNode: aNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitLiteralValueNode: aNode

	heuristic := #literal.
	^ super visitLiteralValueNode: aNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitLiteralArrayNode: aNode

	heuristic := #literalArray.
	^ super visitLiteralArrayNode: aNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitSequenceNode: aNode

	heuristic := #sequence.
	^ super visitSequenceNode: aNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitReturnNode: aNode

	heuristic := #return.
	^ super visitReturnNode: aNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
heuristic

	^ heuristic! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitAssignmentNode: aRBAssignmentNode

	heuristic := #assignment.
	^ super visitAssignmentNode: aRBAssignmentNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitCascadeNode: aRBCascadeNode 

	heuristic := #cascade.
	^ super visitCascadeNode: aRBCascadeNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitMethodNode: aNode

	heuristic := #method.
	^ super visitMethodNode: aNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitArrayNode: aRBArrayNode

	heuristic := #array.
	^ super visitArrayNode: aRBArrayNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitMessageNode: aNode

	heuristic := #message.
	^ super visitMessageNode: aNode! !

!CoMockASTResultSetBuilder methodsFor: 'visiting' stamp: ''!
visitPragmaNode: aRBPragmaNode 

	heuristic := #pragma.
	^ super visitPragmaNode: aRBPragmaNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitParseErrorNode: aNode

	heuristic := #error.
	^ super visitParseErrorNode: aNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitThisContextNode: aNode

	heuristic := #thisContext.
	^ super visitThisContextNode: aNode! !

!CoMockASTResultSetBuilder methodsFor: 'accessing' stamp: ''!
visitVariableNode: aNode

	heuristic := #variable.
	^ super visitVariableNode: aNode! !

!CoMockClass commentStamp: ''!
I am a mock class used in the tests to get the information.!
!CoMockClass methodsFor: 'accessing' stamp: ''!
classVariables: aCollection

	classVariables := aCollection! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
selectors: aCollection 

	"Install nil methods just for compatibility"
	aCollection do: [ :k |
		methodDictionary at: k put: nil
	]! !

!CoMockClass methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	methodDictionary := OrderedDictionary new! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
sharedPools: aCollection 
	sharedPools := aCollection! !

!CoMockClass methodsFor: 'methods' stamp: ''!
lookupSelector: aString 
	
	^ methodDictionary
		at: aString
		ifAbsent: [ 
			superclass ifNil: [ ^ nil ].
			superclass lookupSelector: aString ]! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
classVarNames
	
	^ classVariables! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
allInstVarNames
	
	| superclassVarNames |
	superclassVarNames := superclass
		ifNil: [ #() ]
		ifNotNil: [ superclass allInstVarNames ].
	^ superclassVarNames , instanceVariables! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
instanceVariables
	^ instanceVariables! !

!CoMockClass methodsFor: 'methods' stamp: ''!
methodAt: aString put: aCoMockMethod 
	
	methodDictionary at: aString asSymbol put: aCoMockMethod.
	aCoMockMethod methodClass: self! !

!CoMockClass methodsFor: 'configuration' stamp: ''!
addInstanceVariable: aString 
	
	instanceVariables := instanceVariables copyWith: aString! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
allClassVarNames
	"Answer the names of the receiver's and the receiver's ancestor's class variables."

	^ self superclass
		ifNil: [ self classVarNames ]
		ifNotNil: [ :sup | self classVarNames, sup allClassVarNames ]! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
instanceSide
	
	^ self! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
instanceVariables: anObject
	instanceVariables := anObject! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
instVarNames
	
	^ self instanceVariables! !

!CoMockClass methodsFor: 'testing' stamp: ''!
isTestCase
	
	^ false! !

!CoMockClass methodsFor: 'enumerating' stamp: ''!
selectorsDo: aBlockClosure 
	
	self selectors do: aBlockClosure! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
sharedPools
	
	^ sharedPools ifNil: [ #() ]! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
superclass
	
	^ superclass! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
superclass: aCompletionMockClass 
	
	superclass := aCompletionMockClass! !

!CoMockClass methodsFor: 'accessing' stamp: ''!
selectors
	^ methodDictionary keys! !

!CoMockEngine methodsFor: 'accessing' stamp: ''!
completionToken
	"This is the token used to autocomplete"
	^ 'token'! !

!CoMockFetcherToRecordResets methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock

	1 to: 1000 do: [ :anIndex | (NECGlobalEntry contents: anIndex printString node: nil) ]! !

!CoMockFetcherToRecordResets methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	resetingCount := 0.! !

!CoMockFetcherToRecordResets methodsFor: 'accessing' stamp: ''!
resetingCount
	
	^ resetingCount! !

!CoMockFetcherToRecordResets methodsFor: 'initialization' stamp: ''!
reset 

	resetingCount := resetingCount + 1.
	super reset! !

!CoMockMethod methodsFor: 'accessing' stamp: ''!
ast
	^ ast! !

!CoMockMethod methodsFor: 'accessing' stamp: ''!
methodClass
	
	^ methodClass! !

!CoMockMethod methodsFor: 'accessing' stamp: ''!
methodClass: aCoMockClass 
	methodClass := aCoMockClass! !

!CoMockMethod methodsFor: 'accessing' stamp: ''!
source: aString 
	
	ast := RBParser parseMethod: aString! !

!CoMockSystemNavigation commentStamp: ''!
I am a mock environment. The tests use me to scope the environment to a known one.!
!CoMockSystemNavigation methodsFor: 'accessing' stamp: ''!
globals: anObject
	globals := anObject! !

!CoMockSystemNavigation methodsFor: 'accessing' stamp: ''!
environment

	^ globals! !

!CoMockSystemNavigation methodsFor: 'accessing' stamp: ''!
allClassNamesStartingWith: aString do: aBlock

	globals do: [ :e |
		(aString isEmpty or: [ e beginsWith: aString ])
			ifTrue: [ aBlock value: e ] ]! !

!CoMockSystemNavigation methodsFor: 'accessing' stamp: ''!
globals
	^ globals! !

!CoNarrowHistoryFetcher commentStamp: ''!
I am a decorator that allows the narrowing and unnarrowing without needing to reset the decoree.
I store the intermediate state of the query and perform the subsequent query taking care of the results already handled.!
!CoNarrowHistoryFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock

	currentResults do: aBlock.

	"If previously I have detected that the decoree has not found entries, we need to avoid getting them again"
	currentFinished ifTrue: [ ^ self ].
	
	decoree entriesDo: [ :elem | 
		currentResults add: elem.
		aBlock value: elem ].
	
	currentFinished := true.! !

!CoNarrowHistoryFetcher methodsFor: 'composing' stamp: ''!
unnarrowFilter: aFilter narrowKey: aKey

	history at: aKey 
		ifPresent: [ :historyItem |
			decoree := historyItem fetcher.
			currentResults := historyItem results.
			currentFinished := historyItem hasFinished.
			filter := aFilter.	
			generator := nil.			
			 ] 
		ifAbsent: [ 
			self filter: aFilter.
			decoree := decoree unnarrowFilter: aFilter narrowKey: aKey.
			currentFinished := false ].

	currentKey := aKey.! !

!CoNarrowHistoryFetcher methodsFor: 'enumerating' stamp: ''!
initialize

	super initialize.
	currentResults := OrderedCollection new.
	currentKey := ''.
	currentFinished := false.
	history := Dictionary new.! !

!CoNarrowHistoryFetcher methodsFor: 'composing' stamp: ''!
narrowFilter: aFilter narrowKey: aKey

	history at: currentKey put: (CoNarrowHistoryItem forFetcher: decoree results: currentResults hasFinished: currentFinished).

	currentResults := currentResults select: [ :e | aFilter accepts: e ].

	decoree := decoree narrowFilter: aFilter narrowKey: currentKey.
	filter := aFilter.
	generator := nil.
	currentFinished := false.
	
	currentKey := aKey.
	
	^ self! !

!CoNarrowHistoryFetcher methodsFor: 'composing' stamp: ''!
withNarrowHistory

	^ self! !

!CoNarrowHistoryFetcher methodsFor: 'initialization' stamp: ''!
reset

	super reset.
	currentResults := OrderedCollection new.
	currentFinished := false.
	history := Dictionary new.! !

!CoNarrowHistoryFetcherTest methodsFor: 'tests' stamp: ''!
testNarrowingAndUnnarrowingReturnsSameResult

	| f1Result f2Result f3Result |

	fetcher := (CoCollectionFetcher onCollection: Symbol selectorTable)
		           withNarrowHistory.
	fetcher := fetcher
		           narrowFilter: (CoCaseSensitiveBeginsWithFilter filterString: 'as')
		           narrowKey: 'as'.
	f1Result := fetcher next: 10.

	fetcher := fetcher
		           narrowFilter: (CoCaseSensitiveBeginsWithFilter filterString: 'asC')
		           narrowKey: 'asC'.
	f2Result := fetcher next: 10.

	fetcher := fetcher
		      unnarrowFilter: (CoCaseSensitiveBeginsWithFilter filterString: 'as')
		      narrowKey: 'as'.
	f3Result := fetcher next: 10.

	self assertCollection: f1Result equals: f3Result! !

!CoNarrowHistoryFetcherTest methodsFor: 'tests' stamp: ''!
testNarrowingReturnsSameElementsThatCallingDirectly

	| originalSearch narrowedResults |
	
	"First execution with complete query"
	fetcher := (CoCollectionFetcher onCollection: Symbol selectorTable)
		           withNarrowHistory.
	fetcher := fetcher
		           narrowFilter: (CoCaseSensitiveBeginsWithFilter filterString: 'asL')
		           narrowKey: 'as'.
	originalSearch := fetcher next: 10.

	"Second execution with query using narrowing"
	fetcher := (CoCollectionFetcher onCollection: Symbol selectorTable)
		           withNarrowHistory.
	fetcher := fetcher
		           narrowFilter: (CoCaseSensitiveBeginsWithFilter filterString: 'as')
		           narrowKey: 'as'.
	fetcher next: 10.
	fetcher := fetcher
		           narrowFilter: (CoCaseSensitiveBeginsWithFilter filterString: 'asL')
		           narrowKey: 'asL'.

	narrowedResults := fetcher next: 10.
	
	self assertCollection: originalSearch equals: narrowedResults! !

!CoNarrowHistoryFetcherTest methodsFor: 'tests' stamp: ''!
testUnnarrowingAndThenNarrowingReturnsSameResult


	| originalResults newResults |
	fetcher := (CoCollectionFetcher onCollection: Symbol selectorTable)
		           withNarrowHistory.
	fetcher := fetcher
		           narrowFilter: (CoCaseSensitiveBeginsWithFilter filterString: 'as')
		           narrowKey: 'as'.
	fetcher upToEnd.

	fetcher := fetcher
		           narrowFilter: (CoCaseSensitiveBeginsWithFilter filterString: 'asL')
		           narrowKey: 'asC'.
	originalResults := fetcher upToEnd.

	fetcher := fetcher
		      unnarrowFilter: (CoCaseSensitiveBeginsWithFilter filterString: 'as')
		      narrowKey: 'as'.
	fetcher upToEnd.

	fetcher := fetcher
		           narrowFilter: (CoCaseSensitiveBeginsWithFilter filterString: 'asL')
		           narrowKey: 'asC'.
	newResults := fetcher upToEnd.

	self assertCollection: originalResults equals: newResults! !

!CoNarrowHistoryFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoNarrowHistoryFetcher new
		decoree: (CoCollectionFetcher onCollection: #( a b c )).
	expectedElements := #(a b c).! !

!CoNarrowHistoryItem commentStamp: ''!
I am an item in the history when using the CoNarrowHistoryFetcher.
I represent the intermediate results of a query, allowing to narrowing and unnarrowing without needing to reset the decoree fetcher.!
!CoNarrowHistoryItem methodsFor: 'accessing' stamp: ''!
fetcher: anObject

	fetcher := anObject! !

!CoNarrowHistoryItem methodsFor: 'accessing' stamp: ''!
fetcher

	^ fetcher! !

!CoNarrowHistoryItem methodsFor: 'accessing' stamp: ''!
results

	^ results! !

!CoNarrowHistoryItem methodsFor: 'accessing' stamp: ''!
results: anObject

	results := anObject! !

!CoNarrowHistoryItem methodsFor: 'accessing' stamp: ''!
hasFinished: anObject

	hasFinished := anObject! !

!CoNarrowHistoryItem methodsFor: 'accessing' stamp: ''!
hasFinished

	^ hasFinished! !

!CoNarrowHistoryItem class methodsFor: 'instance creation' stamp: ''!
forFetcher: fetcher results: results hasFinished: hasFinished

	^ self new
		fetcher: fetcher;
		results: results;
		hasFinished: hasFinished;
		yourself! !

!CoNegationFilter commentStamp: ''!
Negating a filter returns an instance of CoNegationFilter.
I wrap another filter. 
When I need to calculate if I am narrow or not I calculate on the wrapped one, just in case the other filter is also a negated one.!
!CoNegationFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanCaseSensitive: anotherFilter

	^ false! !

!CoNegationFilter methodsFor: 'testing' stamp: ''!
negated

	^ negatedFilter! !

!CoNegationFilter methodsFor: 'testing' stamp: ''!
isMoreNarrowThan: anotherFilter

	^ anotherFilter isLessNarrowThanNegation: self! !

!CoNegationFilter methodsFor: 'testing' stamp: ''!
accepts: aCandidate
	
	^ (negatedFilter accepts: aCandidate) not! !

!CoNegationFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanNegation: anotherNegation

	^ anotherNegation negatedFilter isMoreNarrowThan: self negatedFilter! !

!CoNegationFilter methodsFor: 'accessing' stamp: ''!
negatedFilter

	^ negatedFilter! !

!CoNegationFilter methodsFor: 'testing' stamp: ''!
isLessNarrowThanCaseInsensitive: anotherFilter

	^ false! !

!CoNegationFilter methodsFor: 'accessing' stamp: ''!
negatedFilter: anObject

	negatedFilter := anObject! !

!CoNullFetcherHeuristic commentStamp: ''!
I am a null fetcher heuristic, returning an empty fetcher!
!CoNullFetcherHeuristic methodsFor: 'testing' stamp: ''!
isNullHeuristic
	
	^ true! !

!CoNullFetcherHeuristic methodsFor: 'requests' stamp: ''!
fetcherFor: aNode inContext: anObject

	^ CoEmptyFetcher new! !

!CoPackageImplementedMessagesFetcher commentStamp: ''!
I am a fetcher that yields the messages implemented in the given package.!
!CoPackageImplementedMessagesFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock

	SystemNavigation new allSentMessagesInPackage: completionPackage do: [ :e |
		aBlock value: (NECSelectorEntry contents: e node: astNode)]! !

!CoPackageImplementedMessagesFetcher methodsFor: 'accessing' stamp: ''!
astNode
	^ astNode! !

!CoPackageImplementedMessagesFetcher methodsFor: 'accessing' stamp: ''!
astNode: anObject
	astNode := anObject! !

!CoPackageImplementedMessagesFetcher methodsFor: 'accessing' stamp: ''!
completionPackage
	^ completionPackage! !

!CoPackageImplementedMessagesFetcher methodsFor: 'accessing' stamp: ''!
completionPackage: anObject
	completionPackage := anObject! !

!CoRepeatedHierarchyImplementedSelectorsFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := (CoClassImplementedMessagesFetcher new
		completionClass: self completionClass;
		forHierarchy)
		withoutRepetition withNarrowHistory.
	self completionClass superclass
		selectors: (self completionClass superclass selectors copyWith: 'ma').
	expectedElements := { 
		NECSelectorEntry contents: 'ma' node: nil.
		NECSelectorEntry contents: 'mb' node: nil.
		NECSelectorEntry contents: 'mc' node: nil.
		NECSelectorEntry contents: 'superma' node: nil.
		NECSelectorEntry contents: 'supermb' node: nil.
		NECSelectorEntry contents: 'supermc' node: nil.}! !

!CoResultSet commentStamp: ''!
I am the main entry point of the completion system.
I am built from a (potentially composed) fetcher and a filter-string.

When asked for results, I fetch them from the fetcher.
Internally, I keep also a list of already fetched results to avoid fetching many times the same.
This is particularly useful when the filter is being narrowed (e.g., we go from a filter 'ab' to a filter 'abc').
In such a case, some of the results already fetched are still valid, and the fetcher state is valid too.
  => we then filter the subresults and change the fetcher filter
In case the filter is being broadened (e.g., we go from 'abc' to 'ab'), all results we already have are valid, but probably lots of other results were filtered already. So we reset both the results and the fetcher and restart the search.!
!CoResultSet methodsFor: 'fetching' stamp: ''!
fetchAll
	
	results addAll: fetcher upToEnd! !

!CoResultSet methodsFor: 'accessing' stamp: ''!
fetcher: anObject

	fetcher := anObject! !

!CoResultSet methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	results := OrderedCollection new.
	filter := CoFilter empty! !

!CoResultSet methodsFor: 'accessing' stamp: ''!
fetcher
	^ fetcher! !

!CoResultSet methodsFor: 'accessing' stamp: ''!
first: anInteger 

	self ensureResults: anInteger.	
	
	results size > anInteger
		ifTrue: [ ^ results first: anInteger ].
	^ results! !

!CoResultSet methodsFor: 'enumerating' stamp: ''!
ensureResults: aSize
	
	results size >= aSize ifTrue: [ ^ self ].
	self fetch: aSize - results size.! !

!CoResultSet methodsFor: 'fetching' stamp: ''!
fetch: anInteger 
	
	| newResults |
	newResults := fetcher next: anInteger.
	results addAll: newResults! !

!CoResultSet methodsFor: 'accessing' stamp: ''!
filter: anObject

	filter := anObject.
	fetcher filter: filter.! !

!CoResultSet methodsFor: 'accessing' stamp: ''!
results
	^ results! !

!CoResultSet methodsFor: 'accessing' stamp: ''!
filter

	^ filter! !

!CoResultSet methodsFor: 'accessing' stamp: ''!
results: anObject
	results := anObject! !

!CoResultSet methodsFor: 'enumerating' stamp: ''!
first
	
	self ensureResults: 1.
	^ results first! !

!CoResultSet methodsFor: 'testing' stamp: ''!
hasMoreElements
	
	^ fetcher atEnd not! !

!CoResultSet methodsFor: 'testing' stamp: ''!
notEmpty
	
	^ results notEmpty or: [ fetcher atEnd not ]! !

!CoResultSet methodsFor: 'api-filtering' stamp: ''!
replaceFilterWith: newFilter

	"Narrow results"

	newFilter completionString = filter completionString ifTrue: [ ^ self ].

	newFilter completionString size >= filter completionString size
		ifTrue: [
			"Filter existing results"
			fetcher := fetcher narrowFilter: newFilter narrowKey: newFilter completionString ]
		ifFalse: [
			"Smaller filter, reset results and filter"
			fetcher := fetcher unnarrowFilter: newFilter narrowKey: newFilter completionString ].
		
	results := OrderedCollection new.		
	filter := newFilter! !

!CoResultSet methodsFor: 'api-filtering' stamp: ''!
resetFilter
	
	results removeAll.
	fetcher reset.
	fetcher filter: CoFilter empty.! !

!CoResultSet methodsFor: 'accessing' stamp: ''!
completionToken
	
	^ filter completionString! !

!CoResultSet class methodsFor: 'instance creation' stamp: ''!
fetcher: aFetcher
	
	^ self new
		fetcher: aFetcher;
		yourself! !

!CoResultSet class methodsFor: 'instance creation' stamp: ''!
onContext: aCompletionContext fetcher: aFetcher
	
	^ self new
		fetcher: aFetcher;
		yourself! !

!CoResultSetBuilder commentStamp: ''!
I am the an AST based heuristics builder.
The completion engine calls configures me with a completion context and eventually sends me the #buildCompletion message.
I then return a Complishon object configured with a correct fetcher and initial filter.

My subclasses define how to create the complishon given the context.!
!CoResultSetBuilder methodsFor: 'accessing' stamp: ''!
completionContext
	^ completionContext! !

!CoResultSetBuilder methodsFor: 'accessing' stamp: ''!
completionContext: anObject
	completionContext := anObject! !

!CoResultSetBuilder methodsFor: 'API - building' stamp: ''!
buildCompletion

	self subclassResponsibility! !

!CoResultSetBuilder methodsFor: 'initialization' stamp: ''!
initializeOnContext: aCompletionContext 
	
	completionContext := aCompletionContext! !

!CoResultSetBuilder class methodsFor: 'instance creation' stamp: ''!
initializeOnContext: aSystemCompletionContext
	
	^ self new
		initializeOnContext: aSystemCompletionContext;
		yourself! !

!CoResultSetResettingTest methodsFor: 'tests' stamp: ''!
testBroadenFilterShouldResetTheFilter

	completion replaceFilterWith: (CoCaseInsensitiveBeginsWithFilter filterString: 'BA').
	completion fetch: 1.
	completion replaceFilterWith: (CoCaseInsensitiveBeginsWithFilter filterString: 'B').

	self
		assert: mockFilter resetingCount
		equals: 1 + 1 "There is the initial one, and then the reset after setting a new one"! !

!CoResultSetResettingTest methodsFor: 'tests' stamp: ''!
testNarrowingFilterShouldNotResetTheFilter

	completion replaceFilterWith: (CoCaseInsensitiveBeginsWithFilter filterString: 'BA').
	completion fetch: 1.
	completion replaceFilterWith: (CoCaseInsensitiveBeginsWithFilter filterString: 'BAC').

	self
		assert: mockFilter resetingCount
		equals: 1 "There is the initial one"! !

!CoResultSetResettingTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	completion := CoResultSet fetcher: (mockFilter := CoMockFetcherToRecordResets new)! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testCompletionWithElementsToFetchShouldHaveMore

	self assert: completion hasMoreElements! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testCompletionWithNoElementsToFetchShouldNotHaveMore

	| c |
	c := CoResultSet fetcher: (CoInstanceVariableFetcher new
			completionClass: self completionClass).
	c fetchAll.	
	self deny: c hasMoreElements! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testFilterCompletionAfterFetchingShouldNarrowResults

	completion fetch: 1.
	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'b').

	self assertEntry: completion first equals: (NECInstVarEntry contents: 'b' node: nil)! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testBroadenFilterAfterFetchCompletionShouldBroadenResults

	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'ba').
	completion fetch: 1.
	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'b').
	
	self assertEntry: completion first equals: (NECInstVarEntry contents: 'b' node: nil)! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testBroadenFilterAfterFetchCompletionShouldBroadenResultsWhenCaseInsensitve

	completion replaceFilterWith: (CoCaseInsensitiveBeginsWithFilter filterString: 'BA').
	completion fetch: 1.
	completion replaceFilterWith: (CoCaseInsensitiveBeginsWithFilter filterString: 'B').

	self
		assertEntry: completion first
		equals: (NECInstVarEntry contents: 'b' node: nil)! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testBroaderFilterCompletionShouldBroadenResultsWhenCaseInsensitive

	completion replaceFilterWith: (CoCaseInsensitiveBeginsWithFilter filterString: 'ba').
	completion replaceFilterWith: (CoCaseInsensitiveBeginsWithFilter filterString: 'B').
	
	self assertEntry: completion first equals: (NECInstVarEntry contents: 'b' node: nil)! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testNarrowerFilterCompletionShouldNarrowResults

	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'b').
	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'ba').

	self assertEntry: completion first equals: (NECInstVarEntry contents: 'ba' node: nil)! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testResetFilterWithNoFilterSetShouldNotAlterResults

	completion resetFilter.

	self assertEntry: completion first equals: (NECInstVarEntry contents: 'a' node: nil)! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testEnumerateShouldFetch

	self assertEntry: completion first equals: (NECInstVarEntry contents: 'a' node: nil)! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testNarrowFilterAfterFetchCompletionShouldNarrowResults

	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'b').
	completion fetch: 1.
	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'ba').

	self assertEntry: completion first equals: (NECInstVarEntry contents: 'ba' node: nil)! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testResetFilterShouldRetrievePreviousResults

	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'b').
	completion fetch: 5.
	completion resetFilter.

	self assertEntry: completion first equals: (NECInstVarEntry contents: 'a' node: nil)! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testFilterTwiceWithSameCompletionShouldReturnSameResults
	
	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'ba').
	completion fetch: 2.
	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'ba').

	self assertCollectionOfEntry: (completion first: 2) equals: { NECInstVarEntry contents: 'ba' node: nil }! !

!CoResultSetTest methodsFor: 'tests' stamp: ''!
testBroaderFilterCompletionShouldBroadenResults

	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'ba').
	completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: 'b').
	
	self assertEntry: completion first equals: (NECInstVarEntry contents: 'b' node: nil)! !

!CoResultSetTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	self completionClass addInstanceVariable: 'ba'.
	completion := CoResultSet
		fetcher: (CoInstanceVariableFetcher new
			completionClass: self completionClass;
			yourself)! !

!CoSelfMessageHeuristic commentStamp: ''!
I implement an heuristic for self message sends.
I provide a fetcher for messages for the hierarchy of self class.

See my superclass for details.!
!CoSelfMessageHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ aNode receiver isSelfVariable! !

!CoSelfMessageHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aNode inContext: completionContext
	| completionClass |
	
	"When in the playground, the completion class is not available.
	But self is bound to nil"
	completionClass := completionContext completionClass ifNil: [ nil class ].
	^ self newMessageInHierarchyFetcherForClass: completionClass inASTNode: aNode! !

!CoSequenceFetcherTest methodsFor: 'tests' stamp: ''!
testCompletionCompositionNextManyShouldStopAfterEndOfElements

	self assertCollectionOfEntry: (self fetcher next: 10) equals: expectedElements! !

!CoSequenceFetcherTest methodsFor: 'tests' stamp: ''!
testNextManyAfterFirstSubfetcherShouldReturnCollectionWithSecondSubfetcherElements

	self
		assertCollectionOfEntry: (self fetcher next: 5)
		equals: expectedElements allButLast! !

!CoSequenceFetcherTest methodsFor: 'tests' stamp: ''!
testCompletionCompositionNextShouldReturnValuesOfSecondCompletionAfterFirst

	"Consume instance variables"
	self fetcher next: 3.
	self assertEntry: self fetcher next equals: (NECGlobalEntry contents: 'A' node: nil)! !

!CoSequenceFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := (CoInstanceVariableFetcher new
			completionClass: self completionClass)
				, (CoGlobalVariableFetcher new
					systemNavigation: self systemNavigation).
	expectedElements := { 
		NECInstVarEntry contents: 'a' node: nil. 
		NECInstVarEntry contents: 'b' node: nil.
		NECInstVarEntry contents: 'c' node: nil.
		NECGlobalEntry contents: 'A' node: nil. 
		NECGlobalEntry contents: 'B' node: nil.
		NECGlobalEntry contents: 'C' node: nil. }! !

!CoSession commentStamp: ''!
I implement a session that collects execution information.
I collect the last words in modified methods.!
!CoSession methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	vocabularyCache := LRUCache new maximumWeight: 1000! !

!CoSession methodsFor: 'accessing' stamp: ''!
words
	
	^ vocabularyCache keys! !

!CoSession methodsFor: 'accessing' stamp: ''!
size
	^ vocabularyCache size! !

!CoSession methodsFor: 'vocabulary' stamp: ''!
addVocabulary: aString at: aDateAndTime 
	
	vocabularyCache at: aString put: aDateAndTime! !

!CoSessionMessagesHeuristic commentStamp: ''!
I am an heuristic that autocompletes messages based on a session vocabulary.!
!CoSessionMessagesHeuristic methodsFor: 'accessing' stamp: ''!
session
	^ session! !

!CoSessionMessagesHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ aNode isMethod or: [ aNode isMessage ]! !

!CoSessionMessagesHeuristic methodsFor: 'accessing' stamp: ''!
session: anObject
	session := anObject! !

!CoSessionMessagesHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aRBMessageNode inContext: aContext

	^ CoCollectionFetcher onCollection: session words! !

!CoSharedPoolVariableFetcher commentStamp: ''!
I am a fetcher looking for the variables defined in the shared pools of the current class!
!CoSharedPoolVariableFetcher methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlock 
	
	self completionClass instanceSide sharedPools do: [ :e |
		e allClassVarNames do: [ :name | aBlock value: (NECClassVarEntry contents: name node: astNode) ] ]! !

!CoSharedPoolVariableFetcherTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fetcher := CoSharedPoolVariableFetcher new.
	fetcher completionClass: self completionClass.
	fetcher := fetcher forHierarchy.
	expectedElements := { 
		NECClassVarEntry contents: 'Sa' node: nil. 
		NECClassVarEntry contents: 'Sb' node: nil.
		NECClassVarEntry contents: 'SSupera' node: nil. 
		NECClassVarEntry contents: 'SSuperb' node: nil.
		NECClassVarEntry contents: 'Sc' node: nil.
		NECClassVarEntry contents: 'SSuperc' node: nil.}! !

!CoStaticBenchmarks commentStamp: ''!
I run a series of completion benchmarks over a static scope.
I take all existing callsites in a scope (a class, a package) and run the completion with different prefixes (2 to 8), asking for 10 results.
Then I check if the selector at that callsite is in those elements, and in what position.
I accumulate the results in a table per index in the results and prefix size.

I have an inspector extension to show the results in a table.

Examples:

global := CoStaticBenchmarks new
	scope: (CoBenchmarkPackage on: SpAbstractAdapter package);
	builder: (CoGlobalSorterResultSetBuilder new
		sorterClass: AlphabeticSorter;
		yourself);
	run.

staticHeuristics := CoStaticBenchmarks new
	scope: (CoBenchmarkPackage on: SpAbstractAdapter package);
	builder: CoASTHeuristicsResultSetBuilder new;
	run.!
!CoStaticBenchmarks methodsFor: 'scoring' stamp: ''!
score
	
	^ ((1 to: 7) sum: [ :i | (self gradeForPrefixSize: i + 1) / i ]) * 100 / ((1 to: 7) sum: [ :index | 1/index ])! !

!CoStaticBenchmarks methodsFor: 'benchmarks' stamp: ''!
benchCallsite: aRBMessageNode atPosition: aPosition
	
	| originalSelector |
	originalSelector := aRBMessageNode selector.
	2 to: (aRBMessageNode selector size min: 8) do: [ :index | | prefix completion candidates completionIndex previousResultsPerIndexPerPrefixSize |
	
		"The CoGlobalSorterResultSetBuilder uses the selector to pre-narrow the results"	
		prefix := originalSelector copyFrom: 1 to: index.
		aRBMessageNode selector: prefix.

		completion := builder
			node: aRBMessageNode;
			completionContext: (CoBenchmarkContext new
				callsite: aRBMessageNode;
				position: aPosition;
				yourself);
			buildCompletion.
		
		completion replaceFilterWith: (CoCaseSensitiveBeginsWithFilter filterString: prefix).
		candidates := completion first: 10.

		completionIndex := (candidates collect: [:each | each contents]) indexOf: originalSelector.
		
		previousResultsPerIndexPerPrefixSize := completionBenchs
			at: completionIndex
			at: prefix size
			ifAbsent: [ {0 . Set new } ].
		previousResultsPerIndexPerPrefixSize second add: originalSelector.
		completionBenchs
			at: completionIndex
			at: prefix size
			put: {previousResultsPerIndexPerPrefixSize first + 1 . previousResultsPerIndexPerPrefixSize second }
	].
	aRBMessageNode selector: originalSelector.! !

!CoStaticBenchmarks methodsFor: 'accessing' stamp: ''!
scope: aClass 
	scope := aClass! !

!CoStaticBenchmarks methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	completionBenchs := Dictionary new! !

!CoStaticBenchmarks methodsFor: 'inspector' stamp: ''!
accuracyForCompletionIndex: completionIndexRange withPrefixSize: prefixSize
	
	| totalEntries |
	totalEntries := self totalEntriesPerPrefixSize: prefixSize.
	totalEntries = 0 ifTrue: [ ^ 0 ].
	
	^ (completionIndexRange sum: [ :index |
		(completionBenchs at: index at: prefixSize ifAbsent: [ {0} ]) first
	]) / totalEntries! !

!CoStaticBenchmarks methodsFor: 'accessing' stamp: ''!
builder: aCompletionBuilder
	
	builder := aCompletionBuilder! !

!CoStaticBenchmarks methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		print: builder;
		nextPutAll: '(';
		print: scope;
		nextPutAll: ')'! !

!CoStaticBenchmarks methodsFor: 'inspector' stamp: ''!
gtResultsTableIn: composite
	<gtInspectorPresentationOrder: 1>
	| table |
	table := composite table title: 'Results'.
	"columns"
	table
		column: 'Prefix'
		evaluated: [ :completionIndexRange | | label |
			label := '% '.
			label := label, (completionIndexRange size = 1
				ifTrue: [ 
					{ 'fail' . '1st' . '2nd' . '3rd' } at: completionIndexRange first + 1 ]
				ifFalse: [ completionIndexRange first asString , '-', completionIndexRange last asString ]).
			label ]
		width: 70.
	self prefixSizes do: [ :prefixSize |
		table
			column: prefixSize asString
			evaluated: [ :completionIndexRange | | float | 
				float := self accuracyForCompletionIndex: completionIndexRange withPrefixSize: prefixSize.
				(float * 100) printShowingDecimalPlaces: 2 ]
			width: 70 ].
	"rows"
	table display: [ 
		self completionIndexes
	].
	^ table! !

!CoStaticBenchmarks methodsFor: 'inspector' stamp: ''!
totalEntriesPerPrefixSize: aPrefixSize

	^ completionBenchs sum: [ :benchsPerPrefix | (benchsPerPrefix at: aPrefixSize ifAbsent: [ {0} ]) first ]! !

!CoStaticBenchmarks methodsFor: 'inspector' stamp: ''!
completionIndexes
	
	^ { 1 to: 1.
	  2 to: 2.
	  3 to: 3.
	  4 to: 10.
	  0 to: 0.
	}! !

!CoStaticBenchmarks methodsFor: 'scoring' stamp: ''!
gradeForPrefixSize: prefixSize

	^ self accuracyForCompletionIndex: (2 to: 8) withPrefixSize: prefixSize! !

!CoStaticBenchmarks methodsFor: 'running' stamp: ''!
run
	
	scope methodsDo: [ :method |
		method parseTree nodesDo: [ :node |
			node isMessage ifTrue: [ 
				self benchCallsite: node atPosition: node keywordsIntervals first ]
		]
	]! !

!CoStaticBenchmarks methodsFor: 'inspector' stamp: ''!
prefixSizes

	^ 2 to: 8! !

!CoStaticBenchmarks class methodsFor: 'running' stamp: ''!
runFor: aClass 
	
	^ self new
		scope: aClass;
		run! !

!CoStatistics commentStamp: ''!
I am an object keeping code completion statistics.
I store two collection of events: accepted events and cancelled events.
Both events contain information about the completion context (class, is workspace...).
Accepted events contain also the text accepted, the index, and the heuristic.

I provide methods to access and query the statistics.

I have a singleton instance for convenience.!
!CoStatistics methodsFor: 'accessing' stamp: ''!
acceptedEntries
	
	^ acceptedEntries! !

!CoStatistics methodsFor: 'events' stamp: ''!
logAcceptEvent: anEntry
	
	| entries |
	entries := acceptedEntries at: anEntry index ifAbsentPut: [ OrderedCollection new ].
	entries add: anEntry! !

!CoStatistics methodsFor: 'accessing' stamp: ''!
entriesAtIndex: anInteger 
	
	^ acceptedEntries at: anInteger ifAbsentPut: [ CoEntryAcceptedEvent new ]! !

!CoStatistics methodsFor: 'accessing' stamp: ''!
numberOfCancelsByClass: aClassName 
	
	^ cancelledCompletions count: [ :e | e contextClassName = aClassName ]! !

!CoStatistics methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	acceptedEntries := Dictionary new.
	cancelledCompletions := OrderedCollection new! !

!CoStatistics methodsFor: 'accessing' stamp: ''!
numberOfCancels
	
	^ cancelledCompletions size! !

!CoStatistics methodsFor: 'accessing' stamp: ''!
numberOfCancelsByClassCompletions: cancelledCompletionsInClass
	
	^ cancelledCompletionsInClass sum: [ :e |
		e ifNil: [ 0 ] ifNotNil: [ e size ] ]! !

!CoStatistics methodsFor: 'events' stamp: ''!
logCancelEvent: aCancelEntry
	
	cancelledCompletions add: aCancelEntry.! !

!CoStatistics methodsFor: 'accessing' stamp: ''!
averageTypedCharacters
	
	| count total |
	count := 0.
	total := 0.
	acceptedEntries do: [ :entries |
		count := count + entries size.
		total := total + (entries sum: [ :entry | entry numberOfTypedCharacter ]).
	].
	
	^ count = 0
		ifTrue: [ 0 ]
		ifFalse: [ total / count ]! !

!CoStatistics methodsFor: 'events' stamp: ''!
logCancelCompletionFromTypedToken: typedToken inClass: aClassName withDynamicExtent: isDynamicExtent

	self logCancelEvent: (CoCompletionCancelledEvent new
		typedToken: typedToken;
		contextClassName: aClassName;
		isDynamicContext: isDynamicExtent;
		yourself)! !

!CoStatistics methodsFor: 'querying' stamp: ''!
groupBy: aBlockClosure 
	
	^ acceptedEntries gather: [ :entriesByIndex |
		entriesByIndex select: aBlockClosure ]! !

!CoStatistics methodsFor: 'accessing' stamp: ''!
entriesGeneratedBy: aSource

	^ acceptedEntries sum: [ :entries | 
		entries count: [ :entry | entry source = aSource ] ]! !

!CoStatistics methodsFor: 'accessing' stamp: ''!
averageTypedCharactersAt: anIndex
	
	| count total entries |
	count := total := 0.
	entries := acceptedEntries at: anIndex ifAbsent: [ ^ 0 ].
	count := count + entries size.
	total := entries sum: [ :entry | entry numberOfTypedCharacter ].
	^ count = 0
		ifTrue: [ 0 ]
		ifFalse: [ total / count ]! !

!CoStatistics class methodsFor: 'singleton' stamp: ''!
uniqueInstance
	
	^ UniqueInstance ifNil: [ 
		UniqueInstance := self new ]! !

!CoStatistics class methodsFor: 'class initialization' stamp: ''!
reset
	
	UniqueInstance := nil! !

!CoStatisticsASTHeuristicsResultSetBuilder commentStamp: ''!
I am a result set builder that builds heuristics using statistic support!
!CoStatisticsASTHeuristicsResultSetBuilder methodsFor: 'accessing' stamp: ''!
statistics: anObject
	statistics := anObject! !

!CoStatisticsASTHeuristicsResultSetBuilder methodsFor: 'heuristics' stamp: ''!
newHeuristicBuilder

	^ CoStatisticsHeuristicBuilder new
		statistics: statistics;
		yourself! !

!CoStatisticsASTHeuristicsResultSetBuilder methodsFor: 'accessing' stamp: ''!
statistics
	^ statistics! !

!CoStatisticsCompletionContext commentStamp: ''!
I am a completion context that tells a CoStatisticsCompletionEntry its index before being activated.
This is required because completion entries could be shown in different positions of the candidates, depending on the filters.!
!CoStatisticsCompletionContext methodsFor: 'activating' stamp: ''!
activateEntryAt: anIndex

	^ (self entries at: anIndex)
		index: anIndex;
		activateOn: self! !

!CoStatisticsCompletionEngine commentStamp: ''!
I am a completion engine that logs when the menu is closed without activating an entry.!
!CoStatisticsCompletionEngine methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	statistics := CoStatistics uniqueInstance.
	completionBuilder := CoStatisticsASTHeuristicsResultSetBuilder new
		statistics: statistics;
		yourself.
	contextClass := CoStatisticsCompletionContext.! !

!CoStatisticsCompletionEngine methodsFor: 'menu morph' stamp: ''!
closeMenu

	context ifNotNil: [
		statistics logCancelEvent: (CoCompletionCancelledEvent new
			typedToken: context completionToken;
			contextClassName: (self contextClass 
					ifNotNil: [ :aClass | aClass name ]);
			isDynamicContext: self isScripting;
			yourself) ].
	super closeMenu! !

!CoStatisticsCompletionEntry commentStamp: ''!
I am an entry to put in the list of candidates in the code completion list.
I wrap a normal entry (necEntry) and logs acceptance when I'm sent the #activateOn: message.

I'm meant to be created by a CoStatisticsHeuristicWrapper for each completion entry.
See CoStatisticsHeuristicWrapper for more details!
!CoStatisticsCompletionEntry methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!CoStatisticsCompletionEntry methodsFor: 'comparing' stamp: ''!
= anEntry
 
	^ self contents = anEntry contents! !

!CoStatisticsCompletionEntry methodsFor: 'comparing' stamp: ''!
hash
 
	^ self contents hash! !

!CoStatisticsCompletionEntry methodsFor: 'accessing' stamp: ''!
hightlightSymbol

	^ necEntry hightlightSymbol! !

!CoStatisticsCompletionEntry methodsFor: 'accessing' stamp: ''!
statistics: anObject
	statistics := anObject! !

!CoStatisticsCompletionEntry methodsFor: 'accessing' stamp: ''!
heuristic
	^ heuristic! !

!CoStatisticsCompletionEntry methodsFor: 'accessing' stamp: ''!
necEntry
	^ necEntry! !

!CoStatisticsCompletionEntry methodsFor: 'accessing' stamp: ''!
necEntry: aNECEntry 
	"self haltIf: [ aNECEntry isKindOf: self class ]."
	necEntry := aNECEntry! !

!CoStatisticsCompletionEntry methodsFor: 'accessing' stamp: ''!
contents
	
	^ necEntry contents! !

!CoStatisticsCompletionEntry methodsFor: 'accessing' stamp: ''!
statistics
	^ statistics! !

!CoStatisticsCompletionEntry methodsFor: 'accessing' stamp: ''!
index: anInteger 
	
	index := anInteger! !

!CoStatisticsCompletionEntry methodsFor: 'activating' stamp: ''!
activateOn: aCoCompletionContext 
	
	| entry |
	entry := CoEntryAcceptedEvent new
		index: index;
		source: heuristic;
		typedToken: aCoCompletionContext completionToken;
		completedEntry: self contents.
	statistics logAcceptEvent: entry.
	necEntry activateOn: aCoCompletionContext! !

!CoStatisticsCompletionEntry methodsFor: 'accessing' stamp: ''!
heuristic: anObject
	heuristic := anObject! !

!CoStatisticsCompletionEntry class methodsFor: 'instance creation' stamp: ''!
on: aNECEntry
	
	^ self new
		necEntry: aNECEntry;
		yourself! !

!CoStatisticsHeuristicBuilder commentStamp: ''!
I am an heuristic builder that builds statistic-enabled fetchers.
I wrap each of my heuristics with a CoStatisticsHeuristicWrapper, and then compose these wrappers into a chain of responsibility.
For example, given a list of heuristics:

CoHeuristicBuilder new
	add: CoSelfMessageHeuristic new;
	add: CoSuperMessageHeuristic new;
	yourself.

I create the following chain:

CoStatisticsHeuristicWrapper -next-> CoStatisticsHeuristicWrapper
           |                                     |
        decoree                               decoree
           |                                     |
           v                                     v
   CoSelfMessageHeuristic             CoSuperMessageHeuristic
	
I am used also as a hook, that can be redefined in subclasses and build heuristics differently.!
!CoStatisticsHeuristicBuilder methodsFor: 'adding' stamp: ''!
add: anHeuristic

	super add: (CoStatisticsHeuristicWrapper new
		statistics: statistics;
		wrapped: anHeuristic;
		yourself)! !

!CoStatisticsHeuristicBuilder methodsFor: 'accessing' stamp: ''!
statistics: anObject
	statistics := anObject! !

!CoStatisticsHeuristicBuilder methodsFor: 'accessing' stamp: ''!
statistics
	^ statistics! !

!CoStatisticsHeuristicWrapper commentStamp: ''!
I am an heuristic decorator that wraps an heuristic.
When asked to build a fetcher, I build the fetcher of the wrapped heuristic, and decorate it with a mapping fetcher. This mapping fetcher wraps the completion entries returned by the fetcher with a logging entry.

I'm created by the CoStatisticsHeuristicBuilder. See CoStatisticsHeuristicBuilder for more details.!
!CoStatisticsHeuristicWrapper methodsFor: 'accessing' stamp: ''!
wrapped: anObject
	wrapped := anObject! !

!CoStatisticsHeuristicWrapper methodsFor: 'accessing' stamp: ''!
wrapped
	^ wrapped! !

!CoStatisticsHeuristicWrapper methodsFor: 'accessing' stamp: ''!
statistics: anObject
	statistics := anObject! !

!CoStatisticsHeuristicWrapper methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ wrapped appliesForNode: aNode inContext: aContext! !

!CoStatisticsHeuristicWrapper methodsFor: 'testing' stamp: ''!
isStatisticsHeuristicWrapper
	
	^ true! !

!CoStatisticsHeuristicWrapper methodsFor: 'requests' stamp: ''!
buildFetcherFor: aNode inContext: aContext

	| fetcher wrappedFetcher |
	fetcher := wrapped buildFetcherFor: aNode inContext: aContext.
	wrappedFetcher := fetcher collect: [ :e |
		(CoStatisticsCompletionEntry on: e)
			heuristic: self next;
			statistics: statistics;
			yourself ].
	^ wrappedFetcher! !

!CoStatisticsHeuristicWrapper methodsFor: 'accessing' stamp: ''!
statistics
	^ statistics! !

!CoStatisticsTest methodsFor: 'tests - average' stamp: ''!
logAcceptedEvent: anIndex typedToken: aToken

	| entry |
	entry := CoEntryAcceptedEvent new
		index: anIndex;
		source: 'heuristic';
		typedToken: aToken;
		completedEntry: 'toto'.
	
	statistics logAcceptEvent: entry! !

!CoStatisticsTest methodsFor: 'tests - heuristicbuilder' stamp: ''!
testHeuristicBuilderForTwoHeuristicSecondWrapperWrapsNonWrapper
	| builder heuristic heuristic2 |
	builder := CoStatisticsHeuristicBuilder new.
	builder add: CoGlobalVariablesHeuristic new.
	builder add: (heuristic2 := CoGlobalVariablesHeuristic new).
	heuristic := builder build.

	self assert: heuristic next wrapped equals: heuristic2! !

!CoStatisticsTest methodsFor: 'tests - heuristicbuilder' stamp: ''!
testHeuristicBuilderForSingleHeuristicLastIsNullHeuristic

	| builder heuristic singleHeuristic |
	builder := CoStatisticsHeuristicBuilder new.
	singleHeuristic := CoGlobalVariablesHeuristic new.
	builder add: singleHeuristic.

	heuristic := builder build.
	self assert: heuristic next isNullHeuristic! !

!CoStatisticsTest methodsFor: 'tests - average' stamp: ''!
testAcceptEntryIncrementsAverage
	statistics := CoStatistics new.
	self logAcceptedEvent: 1.
	self logAcceptedEvent: 1 typedToken: 'tototo'.
	self assert: statistics averageTypedCharacters equals: 4! !

!CoStatisticsTest methodsFor: 'tests - average' stamp: ''!
testAcceptEntryLogsAverageTypedCharacters
	statistics := CoStatistics new.
	self logAcceptedEvent: 1.
	self assert: statistics averageTypedCharacters equals: 2! !

!CoStatisticsTest methodsFor: 'tests - heuristicbuilder' stamp: ''!
testHeuristicBuilderForSingleHeuristicBuildsWrapper

	| builder heuristic singleHeuristic |
	builder := CoStatisticsHeuristicBuilder new.
	singleHeuristic := CoGlobalVariablesHeuristic new.
	builder add: singleHeuristic.

	heuristic := builder build.
	self assert: heuristic isStatisticsHeuristicWrapper! !

!CoStatisticsTest methodsFor: 'tests - closing' stamp: ''!
testCancelCompletionInClassWithDynamicExtentLogsIt

	statistics := CoStatistics new.
	statistics logCancelCompletionFromTypedToken: 'to' inClass: #Object withDynamicExtent: false.
	self assert: statistics numberOfCancels equals: 1! !

!CoStatisticsTest methodsFor: 'tests - heuristicbuilder' stamp: ''!
testHeuristicBuilderForSingleHeuristicWrapsNonWrapper

	| builder heuristic singleHeuristic |
	builder := CoStatisticsHeuristicBuilder new.
	singleHeuristic := CoGlobalVariablesHeuristic new.
	builder add: singleHeuristic.

	heuristic := builder build.
	self assert: heuristic wrapped equals: singleHeuristic! !

!CoStatisticsTest methodsFor: 'tests - entries' stamp: ''!
testAcceptTwoEntriesAtDifferentIndexLogsSeparateCounts
	statistics := CoStatistics new.
	self logAcceptedEvent: 1.
	self logAcceptedEvent: 2.
	self assert: (statistics entriesAtIndex: 1) size equals: 1.
	self assert: (statistics entriesAtIndex: 2) size equals: 1! !

!CoStatisticsTest methodsFor: 'tests - average' stamp: ''!
testAcceptEntryIncrementsAverageEvenIfAtDifferentIndexes
	statistics := CoStatistics new.
	self logAcceptedEvent: 1.
	self logAcceptedEvent: 2 typedToken: 'tototo'.
	self assert: statistics averageTypedCharacters equals: 4! !

!CoStatisticsTest methodsFor: 'tests - closing' stamp: ''!
testCancelCompletionInClassWithDynamicExtentDoesNotLogOtherClass

	statistics := CoStatistics new.
	statistics logCancelCompletionFromTypedToken: 'to' inClass: #Object withDynamicExtent: false.
	self assert: (statistics numberOfCancelsByClass: #Point) equals: 0! !

!CoStatisticsTest methodsFor: 'tests - heuristicbuilder' stamp: ''!
testHeuristicBuilderForTwoHeuristicBuildsWrapper
	| builder heuristic |
	builder := CoStatisticsHeuristicBuilder new.
	builder add: CoGlobalVariablesHeuristic new.
	builder add: CoGlobalVariablesHeuristic new.
	heuristic := builder build.

	self assert: heuristic isStatisticsHeuristicWrapper! !

!CoStatisticsTest methodsFor: 'tests - entries' stamp: ''!
testAcceptEntryLogsItsSourceInSeparateEntries

	| entries |
	statistics := CoStatistics new.
	self logAcceptedEvent: 2.
	entries := statistics groupBy: [ :e | e index = 1 and: [ e source = 'heuristic' ] ].
	self assert: entries size equals: 0! !

!CoStatisticsTest methodsFor: 'tests - heuristicbuilder' stamp: ''!
testHeuristicBuilderForTwoHeuristicWrapsNonWrapper
	| builder heuristic heuristic1 |
	builder := CoStatisticsHeuristicBuilder new.
	builder add: (heuristic1 := CoGlobalVariablesHeuristic new).
	builder add: CoGlobalVariablesHeuristic new.
	heuristic := builder build.

	self assert: heuristic wrapped equals: heuristic1! !

!CoStatisticsTest methodsFor: 'tests - average' stamp: ''!
testAcceptEntryLogsAverageTypedCharactersAtPosition
	statistics := CoStatistics new.
	self logAcceptedEvent: 1.
	self assert: (statistics averageTypedCharactersAt: 1) equals: 2! !

!CoStatisticsTest methodsFor: 'tests - heuristicbuilder' stamp: ''!
testHeuristicBuilderForTwoHeuristicNextIsWrapper
	| builder heuristic |
	builder := CoStatisticsHeuristicBuilder new.
	builder add: CoGlobalVariablesHeuristic new.
	builder add: CoGlobalVariablesHeuristic new.
	heuristic := builder build.

	self assert: heuristic next isStatisticsHeuristicWrapper! !

!CoStatisticsTest methodsFor: 'tests - entries' stamp: ''!
testAcceptEntryLogsIt
	statistics := CoStatistics new.
	self logAcceptedEvent: 1.
	self assert: statistics acceptedEntries notEmpty! !

!CoStatisticsTest methodsFor: 'tests - average' stamp: ''!
testAcceptEntryLogsAverageTypedCharactersDoesNotAffectOtherIndexes
	statistics := CoStatistics new.
	self logAcceptedEvent: 2.
	self assert: (statistics averageTypedCharactersAt: 1) equals: 0! !

!CoStatisticsTest methodsFor: 'tests - entries' stamp: ''!
testAcceptEntryLogsAllSources

	statistics := CoStatistics new.
	self logAcceptedEvent: 1.
	self logAcceptedEvent: 2.
	self assert: (statistics entriesGeneratedBy: 'heuristic') equals: 2! !

!CoStatisticsTest methodsFor: 'tests - closing' stamp: ''!
testCancelCompletionInClassWithDynamicExtentLogsPerClass

	statistics := CoStatistics new.
	statistics logCancelCompletionFromTypedToken: 'to' inClass: #Object withDynamicExtent: false.
	self assert: (statistics numberOfCancelsByClass: #Object) equals: 1! !

!CoStatisticsTest methodsFor: 'tests - average' stamp: ''!
logAcceptedEvent: anIndex

	self logAcceptedEvent: anIndex typedToken: 'to'! !

!CoStatisticsTest methodsFor: 'tests - entries' stamp: ''!
testAcceptEntryLogsItsSource

	| entries |
	statistics := CoStatistics new.
	self logAcceptedEvent: 1.
	
	entries := statistics groupBy: [ :e | e index = 1 and: [ e source = 'heuristic' ] ].
	
	self assert: entries size equals: 1! !

!CoStatisticsTest methodsFor: 'tests - entries' stamp: ''!
testAcceptTwoEntriesAtSameIndexLogsCount
	statistics := CoStatistics new.
	self logAcceptedEvent: 1.
	self logAcceptedEvent: 1.
	self assert: (statistics entriesAtIndex: 1) size equals: 2! !

!CoStatisticsTest methodsFor: 'tests - entries' stamp: ''!
testNewStatisticsHaveNoAcceptedEntries

	statistics := CoStatistics new.
	self assert: statistics acceptedEntries isEmpty! !

!CoStatisticsTest methodsFor: 'tests - entries' stamp: ''!
testAcceptEntryLogsItsSize
	statistics := CoStatistics new.
	self logAcceptedEvent: 1.
	self assert: (statistics entriesAtIndex: 1) size equals: 1! !

!CoSuperMessageHeuristic commentStamp: ''!
I implement an heuristic for self message sends.
I provide a fetcher for messages for the hierarchy of self class superclass.

See my superclass for details.!
!CoSuperMessageHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ (aNode isMessage
		and: [ aNode receiver isSuperVariable ])
			or: [ aNode isMethod
				and: [ 
					"This heuristic is not valid for traits and nil subclasses"
					aContext completionClass notNil 
					and: [ aContext completionClass superclass notNil ] ] ]! !

!CoSuperMessageHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aNode inContext: completionContext
	| completionClass |
	
	"When in the playground, the completion class is not available.
	But self is bound to nil"
	completionClass := completionContext completionClass ifNil: [ nil class ].
	^ self newMessageInHierarchyFetcherForClass: completionClass superclass inASTNode: aNode! !

!CoSuperMessageHeuristicTest methodsFor: 'tests' stamp: ''!
testDoesApplyForSuperMessageSendNodes

	self assert: (CoSuperMessageHeuristic new
		appliesForNode: (RBMessageNode receiver: RBVariableNode superNode selector: #foo)
		inContext: nil)! !

!CoSuperMessageHeuristicTest methodsFor: 'tests' stamp: ''!
testDoesNotApplyForMethodNodeInContextWithNoSuperclass

	self deny: (CoSuperMessageHeuristic new
		appliesForNode: RBMethodNode new
		inContext: (CoCompletionContext new
			completionClass: (CoMockClass new superclass: nil);
			yourself))! !

!CoSuperMessageHeuristicTest methodsFor: 'tests' stamp: ''!
testDoesApplyForMethodNodeInContextWithSuperclass

	self assert: (CoSuperMessageHeuristic new
		appliesForNode: RBMethodNode new
		inContext: (CoCompletionContext new
			completionClass: (CoMockClass new superclass: CoMockClass new);
			yourself))! !

!CoSuperMessageHeuristicTest methodsFor: 'tests' stamp: ''!
testDoesNotApplyForNonSuperMessageSendNodes

	self deny: (CoSuperMessageHeuristic new
		appliesForNode: (RBMessageNode receiver: (RBVariableNode new variable: (GlobalVariable new)) selector: #foo)
		inContext: nil)! !

!CoSuperMessageHeuristicTest methodsFor: 'tests' stamp: ''!
testDoesApplyForMethodNodeInContextWithNilclass

	self deny: (CoSuperMessageHeuristic new
		appliesForNode: RBMethodNode new
		inContext: (CoCompletionContext new
			completionClass: nil;
			yourself))! !

!CoSystemEnvironment commentStamp: ''!
I represent an environment for the completion.
I know a system dictionary, and can be initialized with for example, Smalltalk globals.!
!CoSystemEnvironment methodsFor: 'accessing' stamp: ''!
at: aString ifPresent: aBlockClosure
	
	systemDictionary at: aString ifPresent: aBlockClosure! !

!CoSystemEnvironment methodsFor: 'accessing' stamp: ''!
globals
	
	^ systemDictionary keys sorted! !

!CoSystemEnvironment methodsFor: 'accessing' stamp: ''!
environmentAt: aKey ifPresent: aBlock
	
	^ systemDictionary at: aKey ifPresent: aBlock! !

!CoSystemEnvironment methodsFor: 'accessing' stamp: ''!
systemDictionary: aDictionary

	systemDictionary := aDictionary! !

!CoSystemEnvironment class methodsFor: 'instance creation' stamp: ''!
new

	^ self forSmalltalkGlobals! !

!CoSystemEnvironment class methodsFor: 'instance creation' stamp: ''!
forSmalltalkGlobals

	^ super new
		systemDictionary: Smalltalk globals;
		yourself! !

!CoTypeInferencer commentStamp: ''!
I am a simple type inferencer that is depth-bound.
That is, I infer a method up to a certain level of the callgraph.!
!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitInstanceVariableNode: aRBInstanceVariableNode 
	
	^ self ensureTypeOfVariable: aRBInstanceVariableNode name! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
inferMessageReturn: aRBMessageNode receiverType: type argumentTypes: argumentTypes

	| lookupClass inferer |
	lookupClass := aRBMessageNode receiver isSuperVariable
		ifTrue: [ method methodClass superclass ]
		ifFalse: [ type ].
	method := lookupClass lookupSelector: aRBMessageNode selector.
	method ifNil: [ ^ { CoUnknownType new } ].
	
	"We only explore n levels and we arrived at the last one.
	But we only stop if this is not a conditional.
	"
	(level <= 0 and: [
		(#( ifTrue: ifFalse: ifTrue:ifFalse: ifNil: ifNotNil: ifNil:ifNotNil:) 
			includes: aRBMessageNode selector) not ]) ifTrue: [
				"When we stop, check fast if the looked-up method has no return, and guess self"
				^ method ast body lastIsReturn
					ifTrue: [ { CoUnknownType new } ]
					ifFalse: [ { type } ] ].
	
	inferer := self class new
		level: level;
		arguments: argumentTypes;
		receiverClass: type.
	(receiverClass includesBehavior: type)
		ifTrue: [ inferer variables: variables ].
	^ inferer
		inferMethod: method;
		returnType! !

!CoTypeInferencer methodsFor: 'inference' stamp: ''!
inferMethod: aMethod

	method := aMethod.
	aMethod methodClass allInstVarNames do: [ :each |
		self ensureTypeOfVariable: each ].
	method ast acceptVisitor: self! !

!CoTypeInferencer methodsFor: 'accessing' stamp: ''!
variables
	^ variables! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitBlockNode: aRBBlockNode 
	
	"Just visit the contents"
	| last |
	last := { CoUnknownType new }.
	aRBBlockNode statements do: [ :each |
		last := each acceptVisitor: self ].
	^ last! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitLiteralValueNode: aRBLiteralValueNode 
	
	^ { aRBLiteralValueNode value class }! !

!CoTypeInferencer methodsFor: 'accessing' stamp: ''!
arguments: aCollection
	
	arguments := aCollection! !

!CoTypeInferencer methodsFor: 'accessing' stamp: ''!
returnType
	^ returnType! !

!CoTypeInferencer methodsFor: 'accessing' stamp: ''!
level
	^ level! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitGlobalNode: aRBGlobalNode 
	
	| binding |
	binding := aRBGlobalNode binding value.
	^ { binding class }! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitReturnNode: aRBReturnNode 
	
	^ returnType 
		addAll: (aRBReturnNode value acceptVisitor: self);
		yourself! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
ensureTypeOfVariable: aVariableName 

	^ variables
		at: aVariableName
		ifAbsentPut: [ Set new ]! !

!CoTypeInferencer methodsFor: 'inference' stamp: ''!
inferFrom: aClass typeGetters: aBoolean

	receiverClass := aClass.
	aClass allInstVarNames do: [ :each |
		self ensureTypeOfVariable: each ].
	self tryInferSelector: #initialize.
	aClass isTestCase ifTrue: [
		self tryInferSelector: #setUp ].
	
	aBoolean ifTrue: [ 
		aClass allInstVarNames do: [ :each |
			self tryInferSelector: each ] ].
	self cleanupTypes! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: aRBAssignmentNode 
	
	| types |
	types := self lookupVariableType: aRBAssignmentNode variable name.
	^ types addAll: (aRBAssignmentNode value acceptVisitor: self);
		yourself! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitCascadeNode: aRBCascadeNode 
	
	| receiverType last |
	receiverType := aRBCascadeNode receiver acceptVisitor: self.
	aRBCascadeNode messages do: [ :each |
		last := self
			visitMessageNode: each
			receiverType: receiverType ].
	^ last! !

!CoTypeInferencer methodsFor: 'accessing' stamp: ''!
level: anObject
	level := anObject! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitMethodNode: aRBMethodNode 
	
	aRBMethodNode arguments withIndexDo: [ :each :index |
		(self ensureTypeOfArgumentVariable: each name)
			addAll: (arguments at: index)
	].
	aRBMethodNode statements do: [ :each |
		each acceptVisitor: self ].
	aRBMethodNode statements ifNotEmpty: [ :statements |
		statements last isReturn
			ifFalse: [ returnType add: method methodClass ] ]! !

!CoTypeInferencer methodsFor: 'accessing' stamp: ''!
receiverClass: aClass 
	receiverClass := aClass! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitThisContextNode: aRBThisContextNode 
	
	^ { Context }! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
ensureTypeOfArgumentVariable: aVariableName 
	
	^ argumentVariables
		at: aVariableName
		ifAbsentPut: [ Set new ]! !

!CoTypeInferencer methodsFor: 'inference' stamp: ''!
cleanupTypes

	| unknownType |
	unknownType := CoUnknownType new.
	variables valuesDo: [ :e |
		e remove: unknownType ifAbsent: [ "nothing" ] ]! !

!CoTypeInferencer methodsFor: 'inference' stamp: ''!
tryInferSelector: aSelector

	"Try to infer types from a selector in the current class.
	If the class has no such selector, do nothing."
	
	| foundMethod |
	foundMethod := (receiverClass lookupSelector: #initialize).
	foundMethod ifNil: [ ^ self ].
	self inferMethod: foundMethod! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitTemporaryNode: aRBTemporaryNode 
	
	^ self ensureTypeOfTemporaryVariable: aRBTemporaryNode name! !

!CoTypeInferencer methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	level := 3.
	arguments := #().
	argumentVariables := Dictionary new.
	temporaryVariables := Dictionary new.
	variables := Dictionary new.
	returnType := OrderedCollection new.
	returnType add: CoUnknownType new! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aRBLiteralArrayNode 
	
	^ self visitArrayNode: aRBLiteralArrayNode! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
ensureTypeOfTemporaryVariable: aVariableName 
	
	^ temporaryVariables
		at: aVariableName
		ifAbsentPut: [ Set new ]! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
lookupVariableType: aVariableName 
	
	^ variables
		at: aVariableName
		ifAbsent: [ 
			argumentVariables
				at: aVariableName
				ifAbsent: [ self ensureTypeOfTemporaryVariable: aVariableName ] ]! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitArgumentNode: aRBArgumentNode 
	
	^ self ensureTypeOfArgumentVariable: aRBArgumentNode name! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitArrayNode: aRBArrayNode 
	
	^ { Array }! !

!CoTypeInferencer methodsFor: 'accessing' stamp: ''!
variables: aCollection 
	variables := aCollection! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
stackMessage: aBlock level: aNewLevel

	| previousLevel previousMethod previousTemporaries previousArguments |
	previousMethod := method.
	previousLevel := level.
	previousTemporaries := temporaryVariables.
	previousArguments := argumentVariables.
	level := aNewLevel.
	^ aBlock ensure: [ 
		level := previousLevel.
		method := previousMethod.
		temporaryVariables := previousTemporaries.
		argumentVariables := previousArguments ]! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitMessageNode: aRBMessageNode receiverType: receiverType
	
	| argumentTypes |
	(#(new basicNew new: basicNew:) includes: aRBMessageNode selector)
		ifTrue: [ ^ receiverType collect: [ :each | each instanceSide ] ].
	
	((#( = == > < >= <= and: or:) includes: aRBMessageNode selector)
		or: [ aRBMessageNode selector beginsWith: 'is' ])
			ifTrue: [ ^ { True . False } ].
	
	(#(yourself copy) includes: aRBMessageNode selector)
		ifTrue: [ ^ receiverType ].
	
	(#(+ - / *) includes: aRBMessageNode selector)
		ifTrue: [ ^ { Number } ].
	
	"(aRBMessageNode selector = #asValueHolder)
		ifTrue: [ ^ { NewValueHolder } ]."
	
	aRBMessageNode selector = #class
		ifTrue: [ ^ receiverType collect: [ :each | each class ] ].

	argumentTypes := aRBMessageNode arguments
		collect: [ :each | each acceptVisitor: self ].
		
	^ receiverType gather: [ :type |
		self
			stackMessage: [
				self
					inferMessageReturn: aRBMessageNode
					receiverType: type
					argumentTypes: argumentTypes ]
			level: ((#( initialize setUp ) includes: aRBMessageNode selector)
				ifTrue: [level]
				ifFalse: [level - 1]) ]! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitMessageNode: aRBMessageNode 
	
	| receiverType |
	receiverType := aRBMessageNode receiver acceptVisitor: self.
	^ self
		visitMessageNode: aRBMessageNode
		receiverType: receiverType! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitSelfNode: aRBSelfNode 
	
	^ { receiverClass }! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitSuperNode: aRBSuperNode 
	
	^ self visitSelfNode: aRBSuperNode! !

!CoTypeInferencer methodsFor: 'visiting' stamp: ''!
visitVariableNode: aRBVariableNode 

	^ self ensureTypeOfVariable: aRBVariableNode name! !

!CoTypeInferencer methodsFor: 'inference' stamp: ''!
inferFrom: aClass

	self inferFrom: aClass typeGetters: true! !

!CoUnknownMessageHeuristic commentStamp: ''!
I implement a default heuristic for when nothing else can be done.
I provide a fetcher for messages for the full system.
I am usually at the end of the chain of responsibility.

See my superclass for details.!
!CoUnknownMessageHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ aNode isMethod or: [ aNode isMessage ]! !

!CoUnknownMessageHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aNode inContext: completionContext
	"This is the main heuristic used for those messages where we cannot guess the type.
	I can be used also after more fine heuristics, to complete guessed heuristics that cannot be trusted too much, like variable names"

	"If the context allows it, autocomplete first messages in the current package, then the rest in the system"
	| fetcher |
	fetcher := (CoCollectionFetcher onCollection: Symbol selectorTable)
		collect: [ :e | NECSelectorEntry contents: e node: aNode ].
	completionContext completionClass ifNotNil: [
		fetcher := (CoPackageImplementedMessagesFetcher new
			astNode: aNode;
			completionPackage: completionContext completionClass package;
			yourself), fetcher
	].
	^ fetcher! !

!CoUnknownType commentStamp: ''!
I represent an unknown type for CoTypeInferencer.!
!CoUnknownType methodsFor: 'comparing' stamp: ''!
= aType

	^ aType isKindOf: CoUnknownType! !

!CoUnknownType methodsFor: 'comparing' stamp: ''!
hash

	^ self class hash! !

!CoUnknownType methodsFor: 'lookup' stamp: ''!
lookupSelector: aString 
	
	^ nil! !

!CoUnknownType methodsFor: 'accessing' stamp: ''!
instanceSide
	
	^ self! !

!CoUsageEvent commentStamp: ''!
I am an abstract class for events happening during code completion.
I'm used to take statistics about code completion usage.!
!CoUsageEvent methodsFor: 'accessing' stamp: ''!
isDynamicContext: anObject
	isDynamicContext := anObject! !

!CoUsageEvent methodsFor: 'accessing' stamp: ''!
contextClassName
	^ contextClassName! !

!CoUsageEvent methodsFor: 'accessing' stamp: ''!
numberOfTypedCharacter
	
	^ typedToken size! !

!CoUsageEvent methodsFor: 'accessing' stamp: ''!
contextClassName: anObject
	contextClassName := anObject! !

!CoUsageEvent methodsFor: 'accessing' stamp: ''!
typedToken
	^ typedToken! !

!CoUsageEvent methodsFor: 'accessing' stamp: ''!
typedToken: anObject
	typedToken := anObject! !

!CoUsageEvent methodsFor: 'accessing' stamp: ''!
isDynamicContext
	^ isDynamicContext! !

!CoUsageEvent class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == CoUsageEvent! !

!CoVariableMessageHeuristic commentStamp: ''!
I am an abstract class for heuristics for messages sent to variables.

See my superclass and concrete subclasses for details.!
!CoVariableMessageHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aRBMessageNode inContext: aContext

	^ aRBMessageNode receiver isVariable! !

!CoVariableMessageHeuristic class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == CoVariableMessageHeuristic! !

!CoVariableValueMessageHeuristic commentStamp: ''!
I implement an heuristic for messages sent to variables whose value is available in the context, for example in a debugger, workspace or inspector.
If there is a value for the variable, create a fetcher for messages of its class.

See my superclass for details.!
!CoVariableValueMessageHeuristic methodsFor: 'requests' stamp: ''!
valueOfVariable: aName inContext: completionContext ifPresent: aBlock

	| binding |
	"In the debugger, the binding values comes in the doItContext.
	If we find in the doItContext has a variable with the given name, use it, otherwise ignore it."
	(completionContext doItContext ifNotNil: [ :context | 
		(context lookupVar: aName)
			ifNotNil: [:var | var readInContext: context ] ])
		ifNotNil: [ :value | ^ aBlock value: value ].

	"In the playground, the binding values comes in the bindings of the requestor.
	If we find in the requestor a binding with the given name, use it, otherwise ignore it."
	
	"We check using hasBindingOf: to not create bindings that are not there"
	(completionContext doItRequestor hasBindingOf: aName) ifFalse:  [ ^ self ].
	
	binding := completionContext doItRequestor bindingOf: aName.
	^ aBlock value: binding value! !

!CoVariableValueMessageHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aRBMessageNode inContext: aContext

	"Try to fetch the real value of the variable from the context"
	self
		valueOfVariable: aRBMessageNode receiver name
		inContext: aContext
		ifPresent: [ :value | 
			^ self
				newMessageInHierarchyFetcherForClass: value class
				inASTNode: aRBMessageNode ].
	
	^ CoEmptyFetcher new! !

!CoVariableWithTypeNameMessageHeuristic commentStamp: ''!
I implement an heuristic for messages sent to variables in the form "aX" or "anX".
If a class X is available in the environment, I return a fetcher for X's instance side messages.

See my superclass for details.!
!CoVariableWithTypeNameMessageHeuristic methodsFor: 'requests' stamp: ''!
newFetcherForMaybeGlobalInstance: aGlobal inASTNode: astNode
	"Fetcher for messages to instance variables containing type information.
	For example: aCollection could autocomplete collection messages."

	"This is a class or trait. Autocomplete instance-side messages" 
	aGlobal isClassOrTrait ifTrue: [
		^ CoClassImplementedMessagesFetcher new
			astNode: astNode;
			completionClass: aGlobal instanceSide;
			forHierarchy ].

	"This is not a class binding but a global object.
	E.g., aSmalltalk
	Autocomplete based on its class"
	^ CoClassImplementedMessagesFetcher new
		astNode: astNode;
		completionClass: aGlobal class;
		forHierarchy! !

!CoVariableWithTypeNameMessageHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aRBMessageNode inContext: completionContext

	"Heuristic: variables with type information.
	This is maybe an instance of this class, autocomplete for that class first, then continue with normal completion.
	E.g., aCollection => use completion for Collection class first, then normal collection.
	There are two cases: aPoint and anASTCache"
	aRBMessageNode receiver name size > 1
		and: [ completionContext
				environmentAt: aRBMessageNode receiver name allButFirst asSymbol
				ifPresent: [ :global | 
					^ self newFetcherForMaybeGlobalInstance: global inASTNode: aRBMessageNode ] ].
	
	aRBMessageNode receiver name size > 2
		and: [ completionContext
				environmentAt: (aRBMessageNode receiver name allButFirst: 2) asSymbol
				ifPresent: [ :global | 
					^ self newFetcherForMaybeGlobalInstance: global inASTNode: aRBMessageNode ] ].
				
	^ CoEmptyFetcher new! !

!CoWorkspaceVariablesHeuristic commentStamp: ''!
I implement an heuristic for variables in a workspace/playground.

See my superclass for details.!
!CoWorkspaceVariablesHeuristic methodsFor: 'requests' stamp: ''!
appliesForNode: aNode inContext: aContext

	^ aContext isWorkspace! !

!CoWorkspaceVariablesHeuristic methodsFor: 'requests' stamp: ''!
buildFetcherFor: aNode inContext: aContext

	^ (CoCollectionFetcher onCollection: aContext variableBindingNames)
		collect: [ :e | NECLocalEntry contents: e node: aNode ]! !

!CodeChunk commentStamp: ''!
I'm the abstract superclass of all the code declarations that should exist in an exported file.!
!CodeChunk methodsFor: 'testing' stamp: ''!
isDoItDeclaration

	^ false! !

!CodeChunk methodsFor: 'testing' stamp: ''!
isMethodDeclaration

	^ false! !

!CodeChunk methodsFor: 'importing' stamp: ''!
importFor: aRequestor logSource: logSource
	self import! !

!CodeChunk methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	aStream nextPutAll: contents.
	aStream nextPut: $).! !

!CodeChunk methodsFor: 'testing' stamp: ''!
isClassCommentDeclaration

	^ false! !

!CodeChunk methodsFor: 'importing' stamp: ''!
import
	self importFor: nil logSource: true! !

!CodeChunk methodsFor: 'accessing' stamp: ''!
contents
	^ contents! !

!CodeChunk methodsFor: 'testing' stamp: ''!
isClassOrganizationDeclaration

	^ false! !

!CodeChunk methodsFor: 'accessing' stamp: ''!
contents: anObject
	contents := anObject! !

!CodeChunk methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	^ aVisitor visitCodeChunk: self! !

!CodeChunk class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == CodeChunk! !

!CodeChunk class methodsFor: 'instance creation' stamp: ''!
contents: someContents
	^self new
			contents: someContents;
			yourself! !

!CodeExporter commentStamp: ''!
An utility class for exporting code to changesets (*.cs) or Smalltalk source (*.st) files!
!CodeExporter class methodsFor: 'file-out' stamp: ''!
writeSourceCodeFrom: aStream toFileReference: aFileReference
	"Write the supplied changes to aFileReference"

	aFileReference
		ensureDelete;
		binaryWriteStreamDo: [ :outputStream | (ZnCharacterWriteStream on: outputStream encoding: 'utf8') nextPutAll: aStream contents ].

	UIManager default
		inform:
			(String
				streamContents: [ :s | 
					s
						nextPutAll: 'Filed out to: ';
						cr;
						nextPutAll: aFileReference pathString;
						cr;
						cr;
						nextPutAll: 'Click to open location' ])
		actionOnClick: [ aFileReference openInOSFileBrowser ]! !

!CodeExporter class methodsFor: 'file-out' stamp: ''!
writeSourceCodeFrom: aStream baseName: baseName isSt: stOrCsFlag

	| extension targetFile |
	extension := stOrCsFlag ifTrue: ['st']  ifFalse: ['cs'].
	targetFile := FileLocator imageDirectory / baseName asFileName, extension.

	self writeSourceCodeFrom: aStream toFileReference: targetFile! !

!CodeImporter commentStamp: ''!
## Description
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).
I read code from chunk format. The chunk format is a code format where elements are delimited by exclamation marks. Exclamation mark represents events of compilation (chunk that was being read from input stream is now  evaluated/compiled). 

Each code element is preceded by some kind of annotation that says what kind of element it is / how it should be read.
For example, the annotation:  
``` 
CodeImportTestCaseTestClass #methodsFor: ''some protocol'' #stamp: ''GuillermoPolito 5/2/2012 13:35
```  
says that the thing that follows is a method for the class CodeImportTestCaseTestClass, its protocol, and some other metadata like the last modification stamp.
A chunk can then contain:
- a method
- a class comment
- a "package organization" which is like a package definition, 
- an arbitrary "doIt" expression. 
- The definition of classes are integrated within arbitrary expressions.

## 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: 'accessing' stamp: ''!
requestor: anObject
	requestor := anObject! !

!CodeImporter methodsFor: 'evaluating' stamp: ''!
parseChunks
	^ codeDeclarations := (parserClass for: readStream) parseChunks.! !

!CodeImporter methodsFor: 'initialization' stamp: ''!
initialize
	codeDeclarations := OrderedCollection new.
	parserClass := ChunkFileFormatParser.
	logSource := true! !

!CodeImporter methodsFor: 'accessing' stamp: ''!
requestor
	^ requestor! !

!CodeImporter methodsFor: 'evaluating' stamp: ''!
flushChangesFile
	"Yes, we need to do this in order to flush the file, puaj"
	logSource ifTrue: [
		ChangesLog default logChange: '----End fileIn----'].! !

!CodeImporter methodsFor: 'accessing' stamp: ''!
file: aFileStream
	self readStream: aFileStream.
	self requestor: FileCompilerRequestor new! !

!CodeImporter methodsFor: 'evaluating' stamp: ''!
evaluateDeclarations
	"Evaluates the declarations from the text in the file and answers the last result"

	self parseChunks.
	^ self evaluate! !

!CodeImporter methodsFor: 'accessing' stamp: ''!
logSource: aBoolean

	logSource := aBoolean! !

!CodeImporter methodsFor: 'fileHandling' stamp: ''!
selectTextConverterForCode

	readStream text! !

!CodeImporter methodsFor: 'accessing' stamp: ''!
readStream: aReadStream
	readStream := aReadStream.! !

!CodeImporter methodsFor: 'public access' stamp: ''!
evaluate
	" stripped down version of evaluateDeclarations"
	| value |
	self codeDeclarations do: [ :declaration |
		requestor ifNotNil: [
			requestor contents: declaration contents ].
		value := declaration importFor: requestor logSource: logSource  ].
	self flushChangesFile.
	
	^value! !

!CodeImporter methodsFor: 'accessing' stamp: ''!
codeDeclarations
	^codeDeclarations! !

!CodeImporter class methodsFor: 'instance creation' stamp: ''!
fromString: aByteString 
	^self readStream: aByteString readStream! !

!CodeImporter class methodsFor: 'evaluating' stamp: ''!
evaluateFileStream: aFileStream
	^(self fileStream: aFileStream) evaluateDeclarations! !

!CodeImporter class methodsFor: 'evaluating' stamp: ''!
evaluateString: aString
	^(self fromString: aString) evaluateDeclarations! !

!CodeImporter class methodsFor: 'evaluating' stamp: ''!
evaluateReadStream: aReadStream
	^(self readStream: aReadStream) evaluateDeclarations! !

!CodeImporter class methodsFor: 'instance creation' stamp: ''!
chunksFromFileNamed: aFileName
	^ (self fileNamed: aFileName)
			parseChunks;
			codeDeclarations.! !

!CodeImporter class methodsFor: 'evaluating' stamp: ''!
evaluateFileNamed: aFileName
	^(self fileNamed: aFileName) evaluateDeclarations! !

!CodeImporter class methodsFor: 'instance creation' stamp: ''!
fileNamed: aFileName
	^ self new file: (aFileName asFileReference readStream).! !

!CodeImporter class methodsFor: 'instance creation' stamp: ''!
fileStream: aFileStream
	^self new
		file: aFileStream;
		yourself! !

!CodeImporter class methodsFor: 'instance creation' stamp: ''!
chunksFromStream: aStream
	^ (self fileStream: aStream)
			parseChunks;
			codeDeclarations.! !

!CodeImporter class methodsFor: 'instance creation' stamp: ''!
readStream: aReadStream
	^self new
		readStream: aReadStream;
		yourself! !

!CodeSimulationTest commentStamp: ''!
SUnit tests for code simulation!
!CodeSimulationTest methodsFor: 'private' stamp: ''!
indexedBasicAt: index 
	<primitive: 60 error: code >
	^ code! !

!CodeSimulationTest methodsFor: 'tests' stamp: ''!
testError
	self should: [ self runSimulated: [self methodWithError] ] raise: Error! !

!CodeSimulationTest methodsFor: 'tests - primitives' stamp: ''!
testErrorCodeNotFound
	| ctx result resultSimu |
	self skip.

	Smalltalk vm isRunningCog ifFalse: [ ^ self ].

	result := self veryBasicAt: 1.

	ctx := Context
		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: Context primitiveFailToken first identicalTo: resultSimu first.
	self assert: result equals: resultSimu second! !

!CodeSimulationTest methodsFor: 'tests' stamp: ''!
testErrorWithErrorHandler
	self
		runSimulated: [ [ self methodWithError ]
				on: Error
				do: [ :err |  ] ]! !

!CodeSimulationTest methodsFor: 'tests' stamp: ''!
testTranscriptPrinting
	self runSimulated: [ self methodWithTranscript ]! !

!CodeSimulationTest methodsFor: 'tests - primitives' stamp: ''!
testErrorToken
	| token1 token2 |
	token1 := Context primitiveFailToken.
	token2 := Context primitiveFailTokenFor: 100.

	self assert: token1 first identicalTo: token2 first.
	self assert: token1 second isNil.
	self assert: token2 second equals: 100! !

!CodeSimulationTest methodsFor: 'tests' stamp: ''!
methodWithError
	self error: 'my error'! !

!CodeSimulationTest methodsFor: 'tests' stamp: ''!
testTranscriptPrintingWithOpenedTranscriptExists
	self runSimulated: [ self methodWithTranscript ]! !

!CodeSimulationTest methodsFor: 'tests - primitives' stamp: ''!
testErrorCodeNotFoundIndexed
	| ctx result resultSimu |
	Smalltalk vm isRunningCog ifFalse: [ ^ self ].

	result := self indexedBasicAt: 100.

	ctx := Context
		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 equals: 2.
	self assert: Context primitiveFailToken first identicalTo: resultSimu first.
	self assert: result equals: resultSimu second! !

!CodeSimulationTest methodsFor: 'tests' stamp: ''!
testGoodSimulation
	self runSimulated: [ 1 + 2 ].! !

!CodeSimulationTest methodsFor: 'tests' stamp: ''!
testDNU
	self should: [ self runSimulated: [ self absentMethod ] ] raise: MessageNotUnderstood! !

!CodeSimulationTest methodsFor: 'private' stamp: ''!
veryBasicAt: index 
	<primitive: 'dooo' module: 'bar' error: code>
	^ code! !

!CodeSimulationTest methodsFor: 'tests' stamp: ''!
runSimulated: aBlock
	thisContext runSimulated: aBlock contextAtEachStep: [ :current |  ]! !

!CodeSimulationTest methodsFor: 'tests' stamp: ''!
methodWithTranscript
	self trace: 'something'! !

!CodeSimulationWithHaltTest methodsFor: 'tests' stamp: ''!
testHalt
	self should: [ self runSimulated: [ self methodWithHalt ] ] raise: Halt! !

!CodeSimulationWithHaltTest methodsFor: 'tests' stamp: ''!
testHaltWithHaltHandler
	self
		runSimulated: [ [ self methodWithHalt ]
				on: Halt
				do: [ :err |  ] ]! !

!CodeSimulationWithHaltTest methodsFor: 'tests' stamp: ''!
methodWithHalt
	<haltOrBreakpointForTesting>
	self halt! !

!CollapsedMorph commentStamp: ''!
This Morph is used to show  a collapsed Morph when the World lacks a Taskbar. 

!
!CollapsedMorph methodsFor: 'menu' stamp: ''!
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...' selector: #relabel.
	aMenu addLine.
	aMenu add: 'Send to back' selector: #sendToBack.
	aMenu add: 'Make next-to-topmost' selector: #makeSecondTopmost.
	aMenu addLine.
	self mustNotClose
		ifFalse:
			[aMenu add: 'Make unclosable' selector: #makeUnclosable]
		ifTrue:
			[aMenu add: 'Make closable' translated selector: #makeClosable].
	aMenu
		add: (self isSticky ifTrue: ['Make draggable'] ifFalse: ['Make undraggable']) 
		selector: #toggleStickiness.
	^aMenu! !

!CollapsedMorph methodsFor: 'collapse/expand' stamp: ''!
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: ''!
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.
	self activeHand attachMorph: nakedMorph! !

!CollapsedMorph methodsFor: 'resize/collapse' stamp: ''!
collapseOrExpand
	"Toggle the expand/collapsd state of the receiver.  If expanding, copy the window title back to the name of the expanded morph"

	isCollapsed ifTrue: [ | aWorld |
		uncollapsedMorph setProperty: #collapsedPosition toValue: self position.
		labelString ifNotNil: [uncollapsedMorph setNameTo: labelString].
		mustNotClose := false.	"We're not closing but expanding"
		aWorld := self world.
		self delete.
		aWorld addMorphFront: uncollapsedMorph.
		aWorld startSteppingSubmorphsOf: uncollapsedMorph ]
	ifFalse: [ super collapseOrExpand ]! !

!CollapsedMorph methodsFor: 'resize/collapse' stamp: ''!
wantsExpandBox
	"Answer whether I'd like an expand box"

	^ false! !

!CollatorBlockFunction commentStamp: ''!
I represent two args collator block which must return 1, -1 or 0.

Usually I am created directly from block using sorting messages:
	[:a :b | ] ascending
	[:a :b | ] descending.

Look at SortFunction comments for more details.

Internal Representation and Key Implementation Points.

    Instance Variables
	collatorBlock:		<BlockClosure>	This is the collation function that must return a -1, 0, or 1!
!CollatorBlockFunction methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^collatorBlock = anObject collatorBlock! !

!CollatorBlockFunction methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ collatorBlock hash! !

!CollatorBlockFunction methodsFor: 'accessing' stamp: ''!
collatorBlock
	^ collatorBlock! !

!CollatorBlockFunction methodsFor: 'evaluating' stamp: ''!
collate: anObject1 with: anObject2

	^collatorBlock value: anObject1 value: anObject2 ! !

!CollatorBlockFunction methodsFor: 'accessing' stamp: ''!
collatorBlock: anObject
	collatorBlock := anObject! !

!CollatorBlockFunction class methodsFor: 'instance creation' stamp: ''!
usingBlock: twoArgsBlock
	^self new 
		collatorBlock: twoArgsBlock! !

!CollectVisitor commentStamp: ''!
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: ''!
visitReference: anEntry
	out nextPut: (block value: anEntry)! !

!CollectVisitor class methodsFor: 'instance creation' stamp: ''!
preorder: aReference
	^ self preorder: aReference collect: [:entry | entry]! !

!CollectVisitor class methodsFor: 'instance creation' stamp: ''!
preorder: aReference collect: aBlock
	^ (self collect: aBlock) preorder: aReference! !

!CollectVisitor class methodsFor: 'instance creation' stamp: ''!
breadthFirst: aReference
	^ self breadthFirst: aReference collect: [:entry | entry]! !

!CollectVisitor class methodsFor: 'instance creation' stamp: ''!
breadthFirst: aReference collect: aBlock
	^ (self collect: aBlock) breadthFirst: aReference! !

!CollectVisitor class methodsFor: 'instance creation' stamp: ''!
postorder: aReference
	^ self postorder: aReference collect: [:entry | entry]! !

!CollectVisitor class methodsFor: 'instance creation' stamp: ''!
collect: aBlock
	^ self basicNew initializeWithBlock: aBlock! !

!CollectVisitor class methodsFor: 'instance creation' stamp: ''!
postorder: aReference collect: aBlock
	^ (self collect: aBlock) postorder: aReference! !

!CollectVisitorTest commentStamp: ''!
SUnit tests for class CollectVisitor!
!CollectVisitorTest methodsFor: 'tests' stamp: ''!
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'
			)! !

!CollectVisitorTest methodsFor: 'tests' stamp: ''!
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: ''!
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'
			)! !

!Collection commentStamp: ''!
I am the abstract superclass of all classes that represent a group of elements.

To get more information you read the explanation on Pharo by Example book in the next link: [Pharo by Example - Collections](https://github.com/SquareBracketAssociates/UpdatedPharoByExample/blob/pharo5/Collections/Collections.pillar).

Or if you want to read in PDF format, download it from [Pharo by Example](https://github.com/SquareBracketAssociates/PharoByExample80/releases/tag/continuous) and look for Chapter 13: Collections. !
!Collection methodsFor: 'enumerating' stamp: ''!
\ aCollection
	"Return all the elements in self that are not in aCollection"
	"'abc' \ 'cbe' >>> 'a'."
	
	^ self difference: aCollection! !

!Collection methodsFor: 'testing' stamp: ''!
isSequenceable
	^ false! !

!Collection methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
asKeyCombination
	| shortcut |
	self size = 1 ifTrue: [ ^self first asKeyCombination ].

	shortcut := KMKeyCombinationSequence new.
	self do: [ :each | shortcut addShortcut: each asKeyCombination ].
	^shortcut.! !

!Collection methodsFor: 'testing' stamp: ''!
includes: anObject 
	"Answer whether anObject is one of the receiver's elements."

	^ self anySatisfy: [:each | each = anObject]! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
setForDo: aBlock withInMetacelloConfig: aMetacelloConstructore
    aMetacelloConstructore setFor: self do: aBlock! !

!Collection methodsFor: 'enumerating' stamp: ''!
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.
	
	Example of use:
	(#(1 2 3 4 5) groupedBy: [ :v | v odd ]) asString >>> 'an OrderedDictionary(true->#(1 3 5) false->#(2 4))'
	"
	
	
	
	| groups |
	groups := OrderedDictionary new.
	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: '*Jobs' stamp: ''!
do: aBlock displayingProgress: aStringOrBlock every: msecs
	"Enumerate aBlock displaying progress information.
 	 If the argument is a string, use a static label for the process.
	 If the argument is a block, evaluate it with the element to retrieve the label.
 	 The msecs argument ensures that updates happen at most every msecs.
       Example:
               Smalltalk allClasses
                       do:[:aClass| (Delay forMilliseconds: 1) wait]
                       displayingProgress:[:aClass| 'Processing ', aClass name]
                       every: 0."

	| size labelBlock count oldLabel lastUpdate |
	self isEmpty ifTrue: [ ^ self ].
	oldLabel := nil.
	count := lastUpdate := 0.
	size := self size.
	'' displayProgressFrom: 0 to: size during: [:bar |
		labelBlock := aStringOrBlock isString
			ifTrue: [
				bar label: aStringOrBlock.
				[ :dummyItem | aStringOrBlock] ]
			ifFalse: [ aStringOrBlock ].

		self do: [ :each | | newLabel |
			"Special handling for first and last element"
			(count = 0 or: [ count + 1 = size or: [(Time millisecondsSince: lastUpdate) >= msecs]]) 
				ifTrue: [ 
					bar current: count.
					oldLabel = (newLabel := (labelBlock cull: each) ifNil: [oldLabel]) 
						ifFalse: [
							bar label: newLabel.
							oldLabel := newLabel ].
				lastUpdate := Time millisecondClockValue ].
			aBlock value: each.
			count := count + 1 ] ]! !

!Collection methodsFor: '*Collections-Arithmetic' stamp: ''!
average
	"Calculate the average of a collection, return a CollectionIsEmpty exception if the collection is empty. Look averageIfEmpty: aBlock"
	
	" #(2 6 7) average  >>> 5 "
	" #(3 5 7 7) average >>> (11/2) "

	^ self sum / self size! !

!Collection methodsFor: 'enumerating' stamp: ''!
do: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument."

	self subclassResponsibility! !

!Collection methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterItemsFor: aStep
	<stSpotterOrder: 10>
	| processor |

	(self isEmpty or: [ self size > self collectionSizeThreshold ]) ifTrue: [ ^ self ].
	processor := aStep previousProcessorFrom: self.
	^ aStep listProcessor
		title: processor title;
		candidatesLimit: 100;
		items: [ self collect: [ :each | each asStSpotterCandidateLink value ] as: OrderedCollection ];
		itemName: processor itemName;
		itemIcon: processor itemIcon;
		actLogic: processor actLogic; 
		filter: processor filter stListFilter;
		wantsToDisplayOnEmptyQuery: true! !

!Collection methodsFor: 'enumerating' stamp: ''!
count: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Answer the number of elements that answered true."
	"(#(1 2 3 4) count: [ :each | each even ]) >>> 2"

	| sum |
	sum := 0.
	self do: [:each | (aBlock value: each) ifTrue: [sum := sum + 1]].
	^ sum! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
squared
	^ self collect: [:each | each * each]! !

!Collection methodsFor: 'copying' stamp: ''!
copyWithoutDuplicates
	"Answer a copy of the receiver without any duplicated elements"
	"(#(2 3 4 4 5 6) copyWithoutDuplicates asSet)  >>> #(2 3 4 5 6) asSet"
	"(#('do' 'la' 'si' 'do' 'la') copyWithoutDuplicates) >>> #('la' 'do' 'si')"
	"(#(#do #la #si #do #la) copyWithoutDuplicates) >>> #(#la #do #si)"
	^ self asSet asArray! !

!Collection methodsFor: '*Morphic-Base-Basic' stamp: ''!
asDraggableMorph
	^ (String streamContents: [ :s| 
		self 
			do: [ :each | s print: each ]
			separatedBy: [ s space ]]) asStringMorph! !

!Collection methodsFor: '*Collections-arithmetic' stamp: ''!
- arg

	^ arg adaptToCollection: self andSend: #-! !

!Collection methodsFor: 'adding' stamp: ''!
add: newObject withOccurrences: anInteger
	"Add newObject anInteger times to the receiver. Answer newObject."

	anInteger timesRepeat: [self add: newObject].
	^ newObject! !

!Collection methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
asShortcut
	^ self asKeyCombination! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
removeFromMetacelloPackages: aMetacelloPackagesSpec

	self do: [:each | each removeFromMetacelloPackages: aMetacelloPackagesSpec ]! !

!Collection methodsFor: '*Geometry' stamp: ''!
asGPoint
	^ GPoint withCollection: self! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
degreeSin
	^self collect: [:each | each degreeSin]! !

!Collection methodsFor: 'converting' stamp: ''!
asOrderedDictionary

	^ self as: OrderedDictionary! !

!Collection methodsFor: '*Collections-Arithmetic' stamp: ''!
negated
	"Negated value of all elements in the collection"
	"#(1 2 3) negated >>> #(-1 -2 -3)"
	^ self collect: [:a | a negated]! !

!Collection methodsFor: 'enumerating' stamp: ''!
doWithIndex: elementAndIndexBlock
	"Use the new version with consistent naming
	
	Example of use:
	(#('hello' 'world' 'bonjour') doWithIndex: [ :element :index |  ])
	"

	^ self withIndexDo: elementAndIndexBlock! !

!Collection methodsFor: '*Geometry' stamp: ''!
asGVector
	^ GVector withCollection: self! !

!Collection methodsFor: 'enumerating' stamp: ''!
anySatisfy: aBlock
	"Evaluate aBlock with the elements of the receiver.
	If aBlock returns true for any element return true.
	Otherwise return false."
	"#(1 3) anySatisfy: [ :each | each even ] >>> false"
	"#(1 2) anySatisfy: [ :each | each even ] >>> true"

	self do: [:each | (aBlock value: each) ifTrue: [^ true]].
	^ false! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
setForVersion: aString withInMetacelloConfig: aMetacelloConstructore
    aMetacelloConstructore setFor: self version: aString! !

!Collection methodsFor: 'accessing' stamp: ''!
size
	"Answer how many elements the receiver contains."

	| tally |
	tally := 0.
	self do: [:each | tally := tally + 1].
	^ tally! !

!Collection methodsFor: '*Collections-arithmetic' stamp: ''!
min
	^ self inject: self anyOne into: [:min :each | min min: each]! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
truncated
	^ self collect: [:a | a truncated]! !

!Collection methodsFor: 'enumerating' stamp: ''!
reject: rejectBlock thenCollect: collectBlock
	"Utility method to improve readability."

	^ (self reject: rejectBlock) collect: collectBlock! !

!Collection methodsFor: 'testing' stamp: ''!
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: 'enumerating' stamp: ''!
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: 'math functions' stamp: ''!
sumNumbers: aBlock
	"This is implemented using a variant of the normal inject:into: pattern
	that is specific to handling numbers. aBlock is expected to return a number
	for every element in the collection.
	
	Different from the sum: implementation, the default value is zero. While sum: is 
	more general, sumNumbers: is meant to support the most often encountered use case of
	dealing with numbers."

	^ self 
		inject: 0 
		into: [ :sum :each |  sum + (aBlock value: each) ]! !

!Collection methodsFor: '*Fuel-Core' stamp: ''!
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: 'printing' stamp: ''!
asCommaStringAnd
	"Return collection printed as 'a, b and c' "
	"#( 'a' 'b' 'c') asCommaStringAnd >>> 'a, b and c'"

	^String streamContents: [:s | self asStringOn: s delimiter: ', ' last: ' and ']! !

!Collection methodsFor: '*Collections-arithmetic' stamp: ''!
* arg

	^ arg adaptToCollection: self andSend: #*! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
setIncludesInMetacelloPackage: aMetacelloPackageSpec

	aMetacelloPackageSpec setIncludes: self asArray.! !

!Collection methodsFor: 'enumerating' stamp: ''!
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."
	"(#(1 2 3 4 5) select: #even) >>> #(2 4)"
	
	| newCollection |
	newCollection := self copyEmpty.
	self do: [ :each | 
		(aBlock value: each) 
			ifTrue: [ newCollection add: each ]].
	^newCollection! !

!Collection methodsFor: 'removing' stamp: ''!
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: '*Metacello-MC' stamp: ''!
resolvePackageSpecsNamedForMetacelloMCVersion: aMetacelloMCVersion visited: visited ifAbsent: aBlock
    ^ aMetacelloMCVersion
        allPackagesForSpecs: (self collect: [ :ea | aMetacelloMCVersion packageNamed: ea ifAbsent: aBlock ])
        visited: visited! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
asMetacelloAttributeList
    ^ self! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
arcTan
	^self collect: [:each | each arcTan]! !

!Collection methodsFor: 'testing' stamp: ''!
ifEmpty: aBlock
	"Evaluate the given block, answering its value if the receiver is empty, otherwise answer the receiver."

	"Note that the fact that this method returns its receiver 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: 'printing' stamp: ''!
collectionSizeThreshold 
	^ 3000! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
degreeCos
	^self collect: [:each | each degreeCos]! !

!Collection methodsFor: 'copying' stamp: ''!
, aCollection
	"Concatenate the receiver with the argument."
	"#(1 2 3) , #(4 5 6) >>> #(1 2 3 4 5 6)"
	
	^self copy addAll: aCollection; yourself! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
setLoadsInMetacelloProject: aMetacelloPackageSpec

	aMetacelloPackageSpec setLoads: self asArray.! !

!Collection methodsFor: 'converting' stamp: ''!
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: 'enumerating' stamp: ''!
detect: aBlock ifFound: foundBlock
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	If some element evaluates aBlock to true, then cull this element into 
	foundBlock. 
	If no element matches the criteria then do nothing.
	Always returns self to avoid misuse and a potential isNil check on the sender."
	"(#(1 2) detect: [ :each | each even ] ifFound: [ ^'yay!!' ]) >>> 'yay!!'"
	"(#(1 3) detect: [ :each | each even ] ifFound: [ ^'yay!!' ]) >>> #(1 3)"

	self
		detect: aBlock
		ifFound: foundBlock
		ifNone: [ 
			"Do nothing on purpose"
			 ]! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
ln
	^self collect: [:each | each ln]! !

!Collection methodsFor: 'accessing' stamp: ''!
anyOne
	"Answer a representative sample of the receiver. It raises an error when the collection is empty. This method can be helpful when needing to preinfer the nature of the contents of semi-homogeneous collections."
	"#(1 2 3) anyOne >>> 1"
	"
	([#() anyOne] on: SubscriptOutOfBounds do: [ :ex | 'whatever' ]) >>> 'whatever'
	"
	
	self emptyCheck.
	self do: [:each | ^ each]! !

!Collection methodsFor: 'converting' stamp: ''!
asCharacterSet
	"Answer a CharacterSet whose elements are the unique elements of the receiver.
	The reciever should only contain characters."

	^ CharacterSet newFrom: self! !

!Collection methodsFor: 'testing' stamp: ''!
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
		ifTrue: [ emptyBlock value ]
		ifFalse: [ notEmptyBlock cull: self ]! !

!Collection methodsFor: 'converting' stamp: ''!
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: 'enumerating' stamp: ''!
flatCollect: aBlock 
	"Evaluate aBlock for each of the receiver's elements and answer the
	list of all resulting values flatten one level. Assumes that aBlock returns some kind
	of collection for each element. Equivalent to the lisp's mapcan"
	
	"( #((3 4) (1 2)) flatCollect: [:each | each ] )>>> #(3 4 1 2)"
	"( #(3 4 1 2) flatCollect: [:each | { each } ] ) >>> #(3 4 1 2)"
	
	^ self flatCollect: aBlock as: self species! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
floor
	^ self collect: [:a | a floor]! !

!Collection methodsFor: 'enumerating' stamp: ''!
do: elementBlock separatedBy: separatorBlock
	"Evaluate the elementBlock for all elements in the receiver,
	and evaluate the separatorBlock between."
	"(String streamContents: [:s | #(1 2 3) do: [:each | s << each asString] separatedBy: [s << ', ']]) >>> '1, 2, 3'"

	| beforeFirst | 
	beforeFirst := true.
	self do:
		[:each |
		beforeFirst
			ifTrue: [beforeFirst := false]
			ifFalse: [separatorBlock value].
		elementBlock value: each]! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
asMetacelloAttributePath
    ^ MetacelloMethodSectionPath withAll: self! !

!Collection methodsFor: 'enumerating' stamp: ''!
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] ) >>> 'if it is to be it is up to me'"

	^self reduce: binaryBlock! !

!Collection methodsFor: '*Collections-arithmetic' stamp: ''!
/ arg

	^ arg adaptToCollection: self andSend: #/! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
mergeIntoMetacelloPackages: aMetacelloPackagesSpec

	self do: [:each | each mergeIntoMetacelloPackages: aMetacelloPackagesSpec ]! !

!Collection methodsFor: '*Collections-Arithmetic' stamp: ''!
sign
	"Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0."
	"5 sign >>> 1"
	"-3 sign >>> -1"
	^self collect: [:each | each sign]! !

!Collection methodsFor: 'enumerating' stamp: ''!
union: aCollection
	"Answer the set theoretic union of two collections."
	"(#(1 2 3) union: #(4 5 6 2)) asSet >>> #(1 2 3 4 5 6) asSet"
	
	| set |
	set := self asSet addAll: aCollection; yourself.
	^ self species withAll: set asArray! !

!Collection methodsFor: 'enumerating' stamp: ''!
detect: aBlock ifFound: foundBlock ifNone: exceptionBlock
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	If some element evaluates aBlock to true, then cull this element into 
	foundBlock and answer the result of this evaluation. 
	If none evaluate to true, then evaluate exceptionBlock."

	self
		do: [ :each | 
			(aBlock value: each)
				ifTrue: [ ^ foundBlock cull: each ] ].
	^ exceptionBlock value! !

!Collection methodsFor: 'removing' stamp: ''!
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: 'private' stamp: ''!
errorEmptyCollection
	"Signal a CollectionIsEmpty exception"

	CollectionIsEmpty signalWith: self! !

!Collection methodsFor: '*Zinc-Resource-Meta-Core' stamp: 'nil'!
addedToZnUrl: url 
	^ url withPathSegments: self! !

!Collection methodsFor: 'enumerating' stamp: ''!
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"
	"( #(1 2 3 4 5) asSet reduce: [ :a :b :c | a + b + c ] ) >>> 1 + 2 + 3 + 4 + 5"
		
	^self asOrderedCollection reduce: aBlock! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
tan
	^self collect: [:each | each tan]! !

!Collection methodsFor: 'enumerating' stamp: ''!
& aCollection
	"#(1 2 3 4) & #(1 2 4 6 7) >>> #(1 2 4)"
	
	^ self intersection: aCollection! !

!Collection methodsFor: '*Metacello-Core-scripting' stamp: ''!
execute: projectSpecBlock against: aScriptExecutor
    aScriptExecutor executeCollection: self do: projectSpecBlock! !

!Collection methodsFor: 'enumerating' stamp: ''!
collect: collectBlock thenDo: doBlock 
	"Utility method to improve readability."
	
	^ self do: [ :each|
		doBlock value: (collectBlock value: each)]! !

!Collection methodsFor: 'converting' stamp: ''!
asSortedCollection: aSortBlock 
	"Answer a SortedCollection whose elements are the elements of the receiver. The sort order is defined by the argument, aSortBlock. Note that it 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: '*Collections-arithmetic-collectors' stamp: ''!
ceiling
	^ self collect: [:a | a ceiling]! !

!Collection methodsFor: '*ClassParser' stamp: ''!
selectEverySecond
	"#(1 2 3 4) selectEverySecond asArray >>> #(2 4)
	"
	^ self selectEvery: [ :i | i \\ 2 = 0 ]! !

!Collection methodsFor: 'removing' stamp: ''!
removeAll
	"Remove each element from the receiver and leave it empty.
	ArrayedCollections cannot respond to this message.
	There are two good reasons why a subclass should override this message:
	1) the subclass does not support being modified while being iterated
	2) the subclass provides a much faster way than iterating through each element"

	self do: [:each | self remove: each].! !

!Collection methodsFor: 'enumerating' stamp: ''!
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.
	
	Example of use:
	({ 2@3 . -4@6 . 10@ -3 } detectMin: [ :p | p x ]) >>> (-4@6)
	({ 2@3 . -4@6 . 10@ -3 } detectMin: [ :p | p y ]) >>> (10@ -3)
	"

	| 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: '*Collections-arithmetic' stamp: ''!
raisedTo: arg

	^ arg adaptToCollection: self andSend: #raisedTo:! !

!Collection methodsFor: 'enumerating' stamp: ''!
inject: thisValue into: binaryBlock 
	"Accumulate a running value associated with evaluating the argument, binaryBlock, with the current value of the argument, thisValue, and the receiver as block arguments."
	
	"( #(1 2 3) inject: 0 into: [ :sum :each | sum + each ] ) >>> 6"

	| nextValue |
	nextValue := thisValue.
	self do: [:each | nextValue := binaryBlock value: nextValue value: each].
	^nextValue! !

!Collection methodsFor: 'math functions' stamp: ''!
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."
	^ self sum: aBlock ifEmpty: [ 0 ]! !

!Collection methodsFor: 'enumerating' stamp: ''!
withIndexDo: elementAndIndexBlock
	"Just like do: except that the iteration index supplies the second argument to the block"
	"Support collection enumeration with a counter, even though not ordered"
	| index |
	index := 0.
	self do: [:item | elementAndIndexBlock value: item value: (index := index+1)]! !

!Collection methodsFor: 'enumerating' stamp: ''!
gather: aBlock
	"This method is kept for compatibility reasons, use flatCollect: instead."
	
	^ self flatCollect: aBlock.! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
log
	^ self collect: [:each | each log]! !

!Collection methodsFor: 'math functions' stamp: ''!
sumNumbers
	"This is implemented using a variant of the normal inject:into: pattern
	that is specific to handling numbers. The receiver should include only numbers.
	
	Different from the sum implementation, the default value is zero. While sum is 
	more general, sumNumbers is meant to support the most often encountered use case of
	dealing with numbers."

	^ self 
		inject: 0 
		into: [ :sum :each |  sum + each ]! !

!Collection methodsFor: 'converting' stamp: ''!
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."

	| newArray index |
	newArray := Array new: self size.
	index := 0.
	self do: [:each | newArray at: (index := index + 1) put: each].
	^ newArray! !

!Collection methodsFor: 'math functions' stamp: ''!
median
	"Return the middle element, or as close as we can get.
	
	Example of use:
	{1 . 2 . 3 . 4 . 5} median >>> 3
	{1 . 2 . 4 . 5} median >>> 3
	{1 . 2 . 5 . 5} median >>> (7/2)
	"
	
	^ self asSortedCollection median! !

!Collection methodsFor: 'printing' stamp: ''!
printOn: aStream 
	"Append a sequence of characters that identify the receiver to aStream."

	self printNameOn: aStream.
	self printElementsOn: aStream! !

!Collection methodsFor: 'enumerating' stamp: ''!
flattenOn: aStream

	self do: [ :each | each flattenOn: aStream ]! !

!Collection methodsFor: 'adapting' stamp: ''!
adaptToNumber: rcvr andSend: selector
	"If I am involved in arithmetic with a scalar, return a Collection of
	the results of each element combined with the scalar in that expression."

	^ self collect: [:element | rcvr perform: selector with: element]! !

!Collection methodsFor: 'printing' stamp: ''!
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: 'removing' stamp: ''!
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: ''!
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: '*Collections-arithmetic-collectors' stamp: ''!
arcCos
	^self collect: [:each | each arcCos]! !

!Collection methodsFor: '*Metacello-MC' stamp: ''!
removeFromMetacelloRepositories: aMetacelloRepositoriesSpec

	self do: [:each | each removeFromMetacelloRepositories: aMetacelloRepositoriesSpec ]! !

!Collection methodsFor: 'enumerating' stamp: ''!
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."
	"#(1 2 3 4 5) reject: #even >>>  #(1 3 5)"

	^ self select: [ :element | (aBlock value: element) == false ]! !

!Collection methodsFor: 'private' stamp: ''!
errorSizeMismatch
	"Signal a SizeMismatch exception"

	SizeMismatch signal! !

!Collection methodsFor: 'copying' stamp: ''!
copyEmpty
	^ self species new! !

!Collection methodsFor: '*Random-Core' stamp: ''!
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 atRandom: SharedRandom globalGenerator.

"Examples:
	#('one' 'or' 'the' 'other') atRandom
	(1 to: 10) atRandom
	'Just pick one of these letters at random' atRandom
	#(3 7 4 9 21) asSet atRandom		(just to show it also works for Sets)
"! !

!Collection methodsFor: 'enumerating' stamp: ''!
flatCollectAsSet: aBlock
	"Evaluate aBlock for each of the receiver's elements and answer the
	list of all resulting values flatten one level. Assumes that aBlock returns some kind
	of collection for each element. Equivalent to the lisp's mapcan"
	
	^ self flatCollect: aBlock as: Set! !

!Collection methodsFor: 'adding' stamp: ''!
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: 'testing' stamp: ''!
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: '*Refactoring-Help' stamp: ''!
collectAll: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Collect all the resulting values into a collection like the receiver. Answer  
	the new collection."

	| newCollection |
	newCollection := self species new.
	self do: [:each | newCollection addAll: (aBlock value: each)].
	^ newCollection! !

!Collection methodsFor: 'accessing' stamp: ''!
capacity
	"Answer the current capacity of the receiver."

	^ self size! !

!Collection methodsFor: '*Collections-arithmetic' stamp: ''!
// arg

	^ arg adaptToCollection: self andSend: #//! !

!Collection methodsFor: 'testing' stamp: ''!
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: '*Collections-arithmetic-collectors' stamp: ''!
exp
	^self collect: [:each | each exp]! !

!Collection methodsFor: 'adding' stamp: ''!
addAssignToFloatArray: aFloatArray
	1 to: aFloatArray size do: [ :i | aFloatArray at: i put: (aFloatArray at: i) + (self at: i) ].
	^ aFloatArray! !

!Collection methodsFor: '*ClassParser' stamp: ''!
selectEveryFirst
	"#(1 2 3 4) selectEveryFirst asArray >>> #(1 3)
	"
	^ self selectEvery: [ :i | (i+1 \\ 2) = 0 ]! !

!Collection methodsFor: 'enumerating' stamp: ''!
difference: aCollection
	"Answer the set theoretic difference of two collections. Pay attention that the difference is not commutative, hence the order is important."

	"(#(a b c d e f) difference:  #(a b z k))>>> #(#c #d #e #f)"

	"(#(a b z k) difference: #(a b c d e f)) >>> #(#z #k)"

	| set |
	set := self asSet
		removeAllFoundIn: aCollection;
		yourself.
	^ self species withAll: set asArray! !

!Collection methodsFor: 'adapting' stamp: ''!
adaptToCollection: rcvr andSend: selector
	"If I am involved in arithmetic with another Collection, return a Collection of
	the results of each element combined with the scalar in that expression."

	(rcvr isSequenceable and: [ self isSequenceable ]) ifFalse:
		[self error: 'Only sequenceable collections may be combined arithmetically'].
	^ rcvr with: self collect:
		[:rcvrElement :myElement | rcvrElement perform: selector with: myElement]! !

!Collection methodsFor: 'enumerating' stamp: ''!
detect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the first element for which aBlock evaluates to true."
	"(#(1 2 3 4) detect: [ :each | each even ]) >>> 2"

	^ self detect: aBlock ifNone: [self errorNotFound: aBlock]! !

!Collection methodsFor: 'removing' stamp: ''!
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: 'testing' stamp: ''!
includesAll: aCollection 
	"Answer whether all the elements of aCollection are in the receiver."
	aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]].
	^ true! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
addToMetacelloPackages: aMetacelloPackagesSpec

	self do: [:each | each addToMetacelloPackages: aMetacelloPackagesSpec ]! !

!Collection methodsFor: 'enumerating' stamp: ''!
occurrencesOf: anObject 
	"Answer how many of the receiver's elements are equal to anObject."

	| tally |
	tally := 0.
	self do: [:each | anObject = each ifTrue: [tally := tally + 1]].
	^tally! !

!Collection methodsFor: 'converting' stamp: ''!
asDictionary

	^ self as: Dictionary! !

!Collection methodsFor: 'filter streaming' stamp: ''!
contents
	^ self! !

!Collection methodsFor: 'converting' stamp: ''!
asIdentitySet
	^(IdentitySet new: self size) addAll: self; yourself! !

!Collection methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionItems: aBuilder
	<inspectorPresentationOrder: 0 title: 'Items'> 
	
	^ aBuilder newTable		
		addColumn: (SpIndexTableColumn new 
			title: 'Index';
			sortFunction: #yourself ascending;
			beNotExpandable;
			yourself);
		addColumn: (SpStringTableColumn new  
			title: 'Value'; 
			evaluated: [ :each | StObjectPrinter asTruncatedTextFrom: each ];
			sortFunction: #printString ascending;
			yourself);
		items: self asOrderedCollection;
		yourself! !

!Collection methodsFor: 'enumerating' stamp: ''!
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: 'printing' stamp: ''!
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: '*Random-Core' stamp: ''!
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 |

	self emptyCheck.
	rand := aGenerator nextInteger: self size.
	self withIndexDo: [:each :index | index = rand ifTrue: [^each]]! !

!Collection methodsFor: 'testing' stamp: ''!
includesAnyOf: aCollection 
	
	self flag: 'use includesAny: instead'.
	
	^ self includesAny: aCollection.! !

!Collection methodsFor: '*Network-Mail' stamp: ''!
asEmailHeaderString

	^ String streamContents: [ :str | 
			self
				do: [ :e | str nextPutAll: e asEmailHeaderString ]
				separatedBy: [ str nextPutAll: ', ' ] ]! !

!Collection methodsFor: 'testing' stamp: ''!
notEmpty
	"Answer whether the receiver contains any elements."
	"use isNotEmpty for consistency with isEmpty"

	^ self isEmpty not! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
cos
	^self collect: [:each | each cos]! !

!Collection methodsFor: 'testing' stamp: ''!
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."

	^ self isEmpty
		ifTrue: [ self ]
		ifFalse: [ aBlock cull: self ]! !

!Collection methodsFor: 'enumerating' stamp: ''!
associationsDo: aBlock
	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations).  If any non-association is within, the error is not caught now,
	but later, when a key or value message is sent to it."

	self do: aBlock! !

!Collection methodsFor: 'enumerating' stamp: ''!
reject: rejectBlock thenDo: doBlock 
	"Utility method to improve readability.
	Do not create the intermediate collection."
	
	self do: [ :each |
		(rejectBlock value: each)
			ifFalse: [ doBlock value: each ] ].! !

!Collection methodsFor: 'adding' stamp: ''!
add: newObject 
	"Include newObject as one of the receiver's elements. Answer newObject. 
	ArrayedCollections cannot respond to this message."

	self subclassResponsibility! !

!Collection methodsFor: '*Metacello-MC' stamp: ''!
loadRequiredForMetacelloMCVersion: aMetacelloMCVersion

	^aMetacelloMCVersion doLoadRequiredFromArray: self.! !

!Collection methodsFor: 'enumerating' stamp: ''!
| aCollection
	"Return all the elements that appear in self or in aCollection"
	"'abc' | 'cbe' >>> 'bcea'"
	
	^ self union: aCollection! !

!Collection methodsFor: 'sorting' stamp: ''!
sorted
	"Return a new sequenceable collection which contains the same elements as self but its 
elements are sorted"
	
	^self asArray sorted! !

!Collection methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"For collections we chose to write a list of elements as delivered by #do:
	This is not the best or most correct solution for all subclasses though,
	so some will revert to standard object behavior or chose another solution"
	
	stonWriter writeObject: self do: [
		stonWriter encodeList: self ]
! !

!Collection methodsFor: 'enumerating' stamp: ''!
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: 'testing' stamp: ''!
identityIncludes: anObject 
	"Answer whether anObject is one of the receiver's elements."

	self do: [:each | anObject == each ifTrue: [^true]].
	^false! !

!Collection methodsFor: 'testing' stamp: ''!
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 ]
		ifFalse: [ notEmptyBlock cull: self ]! !

!Collection methodsFor: '*Collections-Arithmetic' stamp: ''!
averageIfEmpty: aBlock 
	"This method return the average of the collection if it is not empty. In the other case,
	it return the value of the block. It means the user the user of this method decide of the return value. #() averageIfEmpty: [ 0 ]"
	self ifEmpty: [ ^ aBlock value ].
	^ self average! !

!Collection methodsFor: 'enumerating' stamp: ''!
intersection: aCollection
	"Answer the set theoretic intersection of two collections."

	"(#(1 2 3 4) intersection: #(3 4 5)) >>> #(3 4)"

	"(#(1 2 3 4) intersection: #()) >>> #()"

	"(#() intersection: #(1 2 3 4)) >>> #()"

	^ self species withAll: (self asSet intersection: aCollection) asArray! !

!Collection methodsFor: 'printing' stamp: ''!
printNameOn: aStream
	super printOn: aStream! !

!Collection methodsFor: '*Collections-arithmetic' stamp: ''!
\\ arg

	^ arg adaptToCollection: self andSend: #\\! !

!Collection methodsFor: 'enumerating' stamp: ''!
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: 'printing' stamp: ''!
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' stamp: ''!
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: 'enumerating' stamp: ''!
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: '*Collections-arithmetic-collectors' stamp: ''!
abs
	"Absolute value of all elements in the collection"
	^ self collect: [:a | a abs]! !

!Collection methodsFor: 'converting' stamp: ''!
asSet
	"Answer a Set whose elements are the unique elements of the receiver."

	^ Set withAll: self! !

!Collection methodsFor: 'copying' stamp: ''!
copyWith: newElement
	"Answer a new collection with newElement added (as last
	element if sequenceable)."

	^ self copy
		add: newElement;
		yourself! !

!Collection methodsFor: '*ClassParser' stamp: ''!
unzip
	"Given a collection returns in one pass two collections containing each odd and even elements in respective subcollections"
	"#(1 2 3 4) unzip first asArray  >>> #(1 3)"
	"#(1 2 3 4) unzip second asArray >>> #(2 4)"
	
	| odd even s |
	s := self size // 2.
	odd := OrderedCollection new: s.
	even := OrderedCollection new: s.
	1 
		to: self size 
		do: [ :i | (i \\ 2) = 0	
						ifTrue: [ even add: (self at: i) ]
						ifFalse: [ odd add: (self at: i) ] ].
	^ { odd . even }! !

!Collection methodsFor: 'testing' stamp: ''!
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: 'enumerating' stamp: ''!
do: aBlock without: anItem 
	"Enumerate all elements in the receiver. 
	Execute aBlock for those elements that are not equal to the given item"

	^ self do: [:each | anItem = each ifFalse: [aBlock value: each]]! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
roundTo: quantum
	^self collect: [ :ea | ea roundTo: quantum ]! !

!Collection methodsFor: 'adding' stamp: ''!
addAll: aCollection 
	"Include all the elements of aCollection as the receiver's elements. Answer 
	aCollection. Actually, any object responding to #do: can be used as argument."

	aCollection do: [:each | self add: each].
	^ aCollection! !

!Collection methodsFor: '*Metacello-MC' stamp: ''!
addToMetacelloRepositories: aMetacelloRepositoriesSpec

	self do: [:each | each addToMetacelloRepositories: aMetacelloRepositoriesSpec ]! !

!Collection methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new)'.
	noneYet := true.
	self do: 
		[:each | 
		noneYet
			ifTrue: [noneYet := false]
			ifFalse: [aStream nextPut: $;].
		aStream nextPutAll: ' add: '.
		aStream store: each].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !

!Collection methodsFor: 'converting' stamp: ''!
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: '*Collections-arithmetic' stamp: ''!
+ arg

	^ arg adaptToCollection: self andSend: #+! !

!Collection methodsFor: '*Collections-arithmetic' stamp: ''!
max
	"Return the maximum value of the collection
	
	Example of use:
	#(1 5 10 -4) max >>> 10
	"
	^ self inject: self anyOne into: [:max :each | max max: each]! !

!Collection methodsFor: 'private' stamp: ''!
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: '*Collections-arithmetic' stamp: ''!
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 |
	
	self emptyCheck.
	sample := self anyOne.
	sum := self inject: sample into: [:accum :each | accum + each].
	^ sum - sample! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
sqrt
	^ self collect: [:each | each sqrt]! !

!Collection methodsFor: 'math functions' stamp: ''!
sum: aBlock ifEmpty: anEmptySumBlock
	"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 |
	
	^ self
		ifNotEmpty: [ 
			sample := aBlock value: self anyOne.
			sum := self inject: sample into: [ :previousValue :each |
				previousValue + (aBlock value: each) ].
			sum - sample ]
		ifEmpty: anEmptySumBlock.! !

!Collection methodsFor: 'copying' stamp: ''!
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: 'comparing' stamp: ''!
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: ''!
asBag
	"Answer a Bag whose elements are the elements of the receiver."

	^ Bag withAll: self! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
sin
	^self collect: [:each | each sin]! !

!Collection methodsFor: 'enumerating' stamp: ''!
collect: collectBlock thenReject: selectBlock
	"Utility method to improve readability."

	^ (self collect: collectBlock) reject: selectBlock! !

!Collection methodsFor: 'copying' stamp: ''!
copyWithout: oldElement 
	"Answer a copy of the receiver that does not contain any
	elements equal to oldElement."
	"('fred the bear' copyWithout: $e) >>> 'frd th bar'"
	"(#(2 3 4 5 5 6) copyWithout: 5) >>> #(2 3 4 6)"
	
	
	^ self reject: [:each | each = oldElement]! !

!Collection methodsFor: 'enumerating' stamp: ''!
select: selectBlock thenDo: doBlock
    "Utility method to improve readability.
	Do not create the intermediate collection."

    self do: [: each |
        ( selectBlock value: each ) 
			ifTrue: [ doBlock value: each ]
    ].! !

!Collection methodsFor: '*Collections-Arithmetic' stamp: ''!
stdev
	| avg sample sum |
	"In statistics, the standard deviation is a measure that is used to quantify the amount of variation or dispersion of a set of data values.
	For details about implementation see comment in self sum."
	avg := self average.
	sample := self anyOne.
	sum := self inject: sample into: [ :accum :each | accum + (each - avg) squared ].
	sum := sum - sample.
	^ (sum / (self size - 1)) sqrt! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
arcSin
	^self collect: [:each | each arcSin]! !

!Collection methodsFor: 'enumerating' stamp: ''!
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: ''!
select: selectBlock thenCollect: collectBlock
	"Utility method to improve readability."

	^ (self select: selectBlock) collect: collectBlock! !

!Collection methodsFor: 'sorting' stamp: ''!
sorted: aSortBlockOrNil
	"Return a new sequenceable collection which contains the same elements as self but its 
elements are sorted by aSortBlockOrNil. The block should take two arguments and return true if 
the first element should preceed the second one. If aSortBlock is nil then <= is used for 
comparison."
	
	^self asArray sort: aSortBlockOrNil! !

!Collection methodsFor: 'adapting' stamp: ''!
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: 'copying' stamp: ''!
copyWithDependent: newElement
	"Answer a new collection with newElement added (as last
	element if sequenceable)."
	^self copyWith: newElement! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
setRequiresInMetacelloPackage: aMetacelloPackageSpec

	aMetacelloPackageSpec setRequires: self asArray.! !

!Collection methodsFor: 'printing' stamp: ''!
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 nextPutAll: delimString]! !

!Collection methodsFor: '*Collections-arithmetic-collectors' stamp: ''!
rounded
	^ self collect: [:a | a rounded]! !

!Collection methodsFor: 'enumerating' stamp: ''!
detect: aBlock ifNone: exceptionBlock
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Answer the first element for which aBlock evaluates to true. If none  
	evaluate to true, then evaluate the argument, exceptionBlock."

	^ self detect: aBlock ifFound: [ :element | element ] ifNone: exceptionBlock! !

!Collection methodsFor: '*Metacello-MC' stamp: ''!
fetchRequiredForMetacelloMCVersion: aMetacelloMCVersion

	^aMetacelloMCVersion doFetchRequiredFromArray: self.! !

!Collection methodsFor: '*Metacello-Core' stamp: ''!
setImportInVersionSpec: aMetacelloVersionSpec
  aMetacelloVersionSpec setImport: self asArray! !

!Collection methodsFor: 'printing' stamp: ''!
asCommaString
    "Return collection printed as 'a, b, c' "
    "#( 'a' 'b' 'c') asCommaString >>> 'a, b, c'"
    
    ^String streamContents: [:s | self asStringOn: s delimiter: ', ']! !

!Collection methodsFor: '*Metacello-MC' stamp: ''!
mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec

	self do: [:each | each mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec ]! !

!Collection methodsFor: '*ClassParser' stamp: ''!
selectEvery: aBlock
	"Select elements of the receiver whose index satisfy the argument. Look at selectEveryFirst and selectEverySecond for examples."
	
	| res |
	res := OrderedCollection new.
	1 to: self size do: [ :i | (aBlock value: i) 
											ifTrue: [res add: (self at: i) ]].
	^ res! !

!Collection methodsFor: '*Jobs' stamp: ''!
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: 'testing' stamp: ''!
isEmpty
	"Answer whether the receiver contains any elements."

	^self size = 0! !

!Collection methodsFor: 'testing' stamp: ''!
contains: aBlock
	"For compatibility, please use #anySatisfy: instead!!"
	^self anySatisfy: aBlock! !

!Collection methodsFor: 'private' stamp: ''!
emptyCheck

	self isEmpty ifTrue: [self errorEmptyCollection]! !

!Collection methodsFor: 'testing' stamp: ''!
isNotEmpty
	"Answer whether the receiver contains any elements.
	
	Example of use:
	
	#() isNotEmpty >>> false
	#(1 2 3) isNotEmpty >>> true
	"

	^ self isEmpty not! !

!Collection methodsFor: 'private' stamp: ''!
errorNotFound: anObject
	"Raise a NotFound exception."

	NotFound signalFor: anObject! !

!Collection methodsFor: 'printing' stamp: ''!
displayStringOn: stream
	self printNameOn: stream.
	stream
		space;
		nextPut: $[;
		print: self size;
		nextPutAll: (' item' asPluralBasedOn: self size);
		nextPut: $];
		space.
	self size <= self collectionSizeThreshold 
		ifTrue: [ self printElementsOn: stream ]! !

!Collection methodsFor: 'enumerating' stamp: ''!
collect: collectBlock thenSelect: selectBlock
	"Utility method to improve readability."

	^ (self collect: collectBlock) select: selectBlock! !

!Collection methodsFor: 'enumerating' stamp: ''!
detectMax: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the element for which aBlock evaluates to the highest magnitude.
	If collection empty, return nil.  This method might also be called elect:."

	| maxElement maxValue |
	self do: [:each | | val | 
		maxValue == nil
			ifFalse: [
				(val := aBlock value: each) > maxValue ifTrue: [
					maxElement := each.
					maxValue := val]]
			ifTrue: ["first element"
				maxElement := each.
				maxValue := aBlock value: each].
				"Note that there is no way to get the first element that works 
				for all kinds of Collections.  Must test every one."].
	^ maxElement! !

!Collection methodsFor: '*Collections-Arithmetic' stamp: ''!
range
	"returns the difference between the max and min element, their positions notwithstanding"
	"#( 1 51 10 ) range >>> 50"
	^ self max - self min! !

!Collection methodsFor: '*Metacello-MC' stamp: ''!
recordRequiredForMetacelloMCVersion: aMetacelloMCVersion

	^aMetacelloMCVersion doRecordRequiredFromArray: self.! !

!Collection methodsFor: '*Collections-Arithmetic' stamp: ''!
reciprocal
	"Return the reciever full of reciprocated elements"
	"#(1 11 0.5) reciprocal >>> {1 . 1/11 . 2.0}"
	^ self collect: [:a | a reciprocal]! !

!Collection methodsFor: '*Geometry' stamp: ''!
asGCoordinates
	^ GCoordinates withCollection: self! !

!Collection methodsFor: 'enumerating' stamp: ''!
flatCollect: aBlock as: aCollectionClass
	"Evaluate aBlock for each of the receiver's elements and answer the
	list of all resulting values flatten one level. Assumes that aBlock returns some kind
	of collection for each element. Equivalent to the lisp's mapcan"

	| col |
	col := OrderedCollection new: self size.
	self do: [ :each | col addAll: (aBlock value: each) ].
	^ aCollectionClass withAll: col! !

!Collection methodsFor: 'enumerating' stamp: ''!
flattened
	"Flattens a collection of collections (no matter how many levels of collections exist). Strings are considered atoms and, as such, won't be flattened"
	"( #(1 #(2 3) #(4 #(5))) flattened ) >>> #(1 2 3 4 5)" 
	"( #('string1' #('string2' 'string3')) flattened ) >>> #('string1' 'string2' 'string3')"
	
	^ Array streamContents: [ :stream | self flattenOn: stream].! !

!Collection methodsFor: 'enumerating' stamp: ''!
allSatisfy: aBlock
	"Evaluate aBlock with the elements of the receiver.
	If aBlock returns false for any element return false.
	Otherwise return true."
	"#(1 2) allSatisfy: [ :each | each even ] >>> false"
	"#(2 4) allSatisfy: [ :each | each even ] >>> true"

	self do: [:each | (aBlock value: each) ifFalse: [^ false]].
	^ true! !

!Collection methodsFor: '*Roassal3-Layouts' stamp: ''!
maxValue: aBlock
	^ self inject: (aBlock value: self anyOne) into: [ :max :each | max max: (aBlock value: each) ]! !

!Collection class methodsFor: '*Debugger-Model' stamp: ''!
canonicalArgumentName

	^ 'aCollection'.! !

!Collection class methodsFor: 'instance creation' stamp: ''!
empty
	^ self new! !

!Collection class methodsFor: '*Tool-Finder' stamp: ''!
approvedSelectorsForMethodFinder

	 ^ self selectors! !

!Collection class methodsFor: 'instance creation' stamp: ''!
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: ''!
withAll: aCollection
	"Create a new collection containing all the elements from aCollection."

	^ (self new: aCollection size)
		addAll: aCollection;
		yourself! !

!Collection class methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
systemIconName

	^ #collectionIcon! !

!Collection class methodsFor: 'testing' stamp: ''!
isAbstract

	^self name = #Collection! !

!Collection class methodsFor: 'instance creation' stamp: ''!
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: '*STON-Core' stamp: ''!
fromSton: stonReader
	"For collections we chose to instanciate based a list of elements using #add:
	This is not the best or most correct solution for all subclasses though,
	so some will revert to standard object behavior or chose another solution."
	
	| collection |
	collection := self new.
	stonReader parseListDo: [ :each |
		collection add: each ].
	^ collection! !

!Collection class methodsFor: 'instance creation' stamp: ''!
with: anObject 
	"Answer an instance of me containing anObject."

	^ self empty
		add: anObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: ''!
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: ''!
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: ''!
with: firstObject with: secondObject 
	"Answer an instance of me containing the two arguments as elements."

	^ self new
		add: firstObject;
		add: secondObject;
		yourself! !

!CollectionArithmeticTest commentStamp: ''!
Unit tests for collection arithmetic!
!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testDevision
	| collection |
	collection := #(2 4).
	self assert: collection / 2 equals: #(1 2).
	self assert: 10 / #(20) equals: {1/2}! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testAverageWithEmptySet
	self should: [ Set new average ] raise: CollectionIsEmpty! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testAverageWithEmptyArray
	self should: [ #() average ] raise: CollectionIsEmpty! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testAverageIfEmptyWithEmptyArray
	self assert: (#() averageIfEmpty: [ 0 ]) equals: 0! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testAverageIfEmptyWithEmptyCollection
	self should: [#() averageIfEmpty: [ CollectionIsEmpty signal: 'Collection empty' ]] raise: CollectionIsEmpty! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testAdd
	| collection |
	collection := #(1 2 3).
	self assert: collection + 1 equals: #(2 3 4).
	self assert: 1 + collection  equals: #(2 3 4)! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testAverageWithEmptyArrayShouldRaiseExecption
	self should: [ #() average ] raise: CollectionIsEmpty! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testRunningMax
	| result collection |
	collection := #(1 1 2 2 3 3).
	result := collection runningMax: 3. 

	self assert: result equals: {2 . 2 . 3 . 3}.! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testRunningMin
	| result collection |
	collection := #(1 1 2 2 3 3).
	result := collection runningMin: 3. 

	self assert: result equals: {1 . 1 . 2 . 2}.! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testRunningAverageSubscriptOutOfBounds
	| collection |
	collection := #(1 1 2 2 3 3).

	self should: [ collection runningAverage: 7 ] raise: SubscriptOutOfBounds.
	self  should: [ collection runningAverage: -2 ] raise: SubscriptOutOfBounds.! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testAverage
	| collection |
	collection := #(1 2 3).
	self assert: collection average equals: 2! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testRunningAverage
	| result collection |
	collection := #(1 1 2 2 3 3).
	result := collection runningAverage: 2. 

	self assert: result equals: {1 . (3/2) . 2 . (5/2) . 3}.! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testRunningAverageWithSubsetSize1IsSameAsCollection
	| collection |
	collection := #(1 1 2 2 3 3).
	
	self
		assert: (collection runningAverage: 1) 
		equals: collection.! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testAverageWithEmptyDictionary
	self should: [ Dictionary new average ] raise: CollectionIsEmpty! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testRunningAverageWithFullSubsetSizeIsSameAsAverage
	| collection |
	collection := #(1 1 2 2 3 3).
	
	self
		assert: (collection runningAverage: collection size) 
		equals: { collection average }.! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testAverageIfEmpty
	| collection |
	collection := #(1 2 3 4).
	self assert: (collection averageIfEmpty: [ 0 ]) equals: 2.5! !

!CollectionArithmeticTest methodsFor: 'tests' stamp: ''!
testAverageWithEmptyOrderedCollection
	self should: [ OrderedCollection new average ] raise: CollectionIsEmpty! !

!CollectionCombinator commentStamp: ''!
For a collection of collections, enumerate all elements of the cartesian product. The code shows how recursion is used to implement variable nesting of loops.
The cartesian product is usually a huge collection, that should not be kept in memory. Therefore the user of the class has to provide a block with one argument that is called each time a tuple is constructed. When possible, that block should not build a collection of all these tuples, but should immediately drop unsuitable tuples. 
To get a first impression, try this with 'inspect it':

     | result |
     result := OrderedCollection new.
    CollectionCombinator new
         forArrays:  (OrderedCollection with: #(#a #b #c)
                                             with: #(1 2 3 4 5)
                                             with: #('v' 'w' 'x' 'y' 'z')
                                             with: #('one' 'two' 'three')
                         )
         processWith: [:item |result addLast: item].
    result
         !
!CollectionCombinator methodsFor: 'operating' stamp: ''!
forArrays: anArray processWith: aBlock

 "  anArray is a kind of a sequenceable collection of arrays.
    aBlock is a block with one argument, that is used to process a  tuple immediately after it is constructed. "
  collectionOfArrays := anArray.
  resultProcessingBlock := aBlock.
  buffer := Array new: anArray size.
  self combineFromIdx: 1! !

!CollectionCombinator methodsFor: 'operating' stamp: ''!
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. "! !

!CollectionElement commentStamp: ''!
I am a helper class for handling the contents of some collections that need a special handling of nil values.

My main purpose is to allow a Set or WeakValueDictionary to contain nil.

Since nil represents an empty slot in those collections, it cannot be stored directly in the array of values. Instead, my instances are used as a wrapper. See implementors and senders of #asCollectionElement for wrapping, and #enclosedElement for unwrapping.!
!CollectionElement methodsFor: 'comparing' stamp: ''!
= anObject
	super = anObject ifTrue: [ ^ true ].
	anObject class = self class ifFalse: [ ^ false ].

	^ enclosedElement = anObject enclosedElement! !

!CollectionElement methodsFor: 'accessing' stamp: ''!
enclosedElement
	^ enclosedElement! !

!CollectionElement methodsFor: 'accessing' stamp: ''!
enclosedElement: anObject
	enclosedElement := anObject! !

!CollectionElement methodsFor: 'converting' stamp: ''!
asCollectionElement
	"A receiver has to be included into a collection needing a wrapper to manage nil elements, as a distinct object.
	We need to wrap receiver in own turn, otherwise #enclosedElement ill return wrong object for that collection"

	^ self class with: self! !

!CollectionElement methodsFor: 'comparing' stamp: ''!
hash
	^ enclosedElement hash! !

!CollectionElement class methodsFor: 'class initialization' stamp: ''!
initialize
	NilElement := self with: nil.! !

!CollectionElement class methodsFor: 'accessing' stamp: ''!
withNil
	^ NilElement! !

!CollectionElement class methodsFor: 'instance creation' stamp: ''!
with: anObject
	^ self new enclosedElement: anObject! !

!CollectionIsEmpty commentStamp: ''!
I am CollectionIsEmpty, an exception indicating that an operation was attempted 
on an empty collection where that does not make sense.
I am an Error and thus an Exception.

The collection that is empty is in my inherited signaler instance variable.
!
!CollectionIsEmpty methodsFor: 'private' stamp: ''!
collection
	"Return the collection where something is not found in"
	
	^ self signaler! !

!CollectionIsEmpty methodsFor: 'accessing' stamp: ''!
collection: aCollection
	"Set the collection where something is not found in"
	
	self signaler: aCollection! !

!CollectionIsEmpty methodsFor: 'private' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		stream print: self collection.
		stream << ' is empty' ]! !

!CollectionIsEmpty methodsFor: 'accessing' stamp: ''!
messageText
	"Overwritten to initialiaze the message text to a standard text if it has not yet been set"
	
	^ messageText ifNil: [ messageText := self standardMessageText ]! !

!CollectionIsEmpty class methodsFor: 'instance creation' stamp: ''!
signalWith: aCollection
	^ self new
		collection: aCollection;
		signal! !

!CollectionRootTest commentStamp: ''!
I'm the root of the hierarchy of the collection tests.
!
!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testBasicCollectThenDo

	| result index |
	index := 0.
	result := self collectionWithoutNilElements 
		collect: [ :each | nil ]
		thenDo: [ :each | 
			self assert: each isNil.
			index := index + 1]	.
			
	self assert: result equals: self collectionWithoutNilElements.
	self assert: index equals: self collectionWithoutNilElements size.! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testBasicCollect

	| res index |
	index := 0.
	res := self collectionWithoutNilElements collect: [ :each | 
		index := index + 1.
		each ].
	
	res do: [ :each | 
		self assert: (self collectionWithoutNilElements occurrencesOf: each) = (res occurrencesOf: each)].
	self assert: index equals: self collectionWithoutNilElements size.! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testSelectNoneThenDo
	| result |
	
	result := self collectionWithoutNilElements 
		select: [ :each | each isNil ] 
		thenDo: [ self fail ].
	
	self assert: result equals: self collectionWithoutNilElements! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testSelect

	| result element |
	result := self collectionWithoutNilElements select: [ :each | each notNil].
	self assert: result size equals: self collectionWithoutNilElements size.
	
	element := self collectionWithoutNilElements anyOne.
	result := self collectionWithoutNilElements select: [ :each | (each = element) not].
	self assert: result size equals: (self collectionWithoutNilElements size - 1).! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
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' stamp: ''!
testCollectThenDoOnEmpty
	self assertEmpty: (self empty collect: [ :e | self fail ] thenDo: [ self fail ])! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenDoOnEmpty
	self assertEmpty: (self empty reject: [ :e | self fail ] thenDo: [ self fail ])! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenCollect

	| result index selectIndex pivot |
	
	index := 0.
	selectIndex := 0.
	pivot := self collectionWithoutNilElements anyOne.
	
	result := self collectionWithoutNilElements 
		select: [ :each | 
			selectIndex := selectIndex + 1.
			"reject the first element"
			selectIndex > 1 ]
		thenCollect: [ :each | 
			self assert: each notNil.
			index := index + 1.
			pivot ].
			
	self assert: result ~= self collectionWithoutNilElements.
	self assert: selectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.
	
	self assert: (self collectionWithoutNilElements occurrencesOf: pivot) equals: 1.
	"should be > 1 for standard collection and = 1 for those that do not allow exact duplicates"
	self assert: (result occurrencesOf: pivot) >= 1.! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testRejectAllThenDo
	| result |
	
	result := self collectionWithoutNilElements 
		reject: [ :each | each notNil ] 
		thenDo: [ :each | self fail ].
	
	self assert: result equals: self collectionWithoutNilElements! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testCollectOnEmpty
	self assertEmpty: (self empty collect: [ :e | self fail ])! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testDo2
	"dc: Bad test, it assumes that a new instance of #speciesClass allows addition with #add:. This is not the case of Interval for which species is Array."
	"res := self speciesClass new.  
	self collection do: [:each | res add: each class].
	self assert: res = self result. "
	| collection cptElementsViewed cptElementsIn |
	collection := self collectionWithoutNilElements.
	cptElementsViewed := 0.
	cptElementsIn := OrderedCollection new.
	collection do: 
		[ :each | 
		cptElementsViewed := cptElementsViewed + 1.
		" #do doesn't iterate with the same objects than those in the collection for FloatArray( I don' t know why ) . That's why I use #includes: and not #identityIncludes:  '"
		(collection includes: each) ifTrue: [
			" the collection used doesn't include equal elements. Therefore each element viewed should not have been viewed before "
			( cptElementsIn includes: each ) ifFalse: [ cptElementsIn add: each ] .
			]. 
		].
	self assert: cptElementsViewed = collection size.
	self assert: cptElementsIn size  = collection size.! !

!CollectionRootTest methodsFor: 'tests - empty' stamp: ''!
testIfEmptyifNotEmpty
	self assert: (self empty ifEmpty: [ true ] ifNotEmpty: [ false ]).
	self assert: (self nonEmpty ifEmpty: [ false ] ifNotEmpty: [ true ])! !

!CollectionRootTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateTest
	| res |
	self collectionWithoutNilElements.
	self assert: (self collectionWithoutNilElements occurrencesOf: nil) = 0.
	res := true.
	self collectionWithoutNilElements detect: [ :each | (self collectionWithoutNilElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testReject

	| res element |
	res := self collectionWithoutNilElements reject: [:each | each notNil not].
	self assert: res size = self collectionWithoutNilElements size.
	
	element := self collectionWithoutNilElements anyOne.
	res := self collectionWithoutNilElements  reject: [:each | each = element].
	self assert: res size = (self collectionWithoutNilElements size - 1).! !

!CollectionRootTest methodsFor: 'tests - empty' stamp: ''!
testNotEmpty
	self assert: self nonEmpty notEmpty.
	self deny: self empty notEmpty! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenCollect

	| result index selectIndex pivot |
	
	index := 0.
	selectIndex := 0.
	pivot := self collectionWithoutNilElements anyOne.
	
	result := self collectionWithoutNilElements 
		reject: [ :each | 
			selectIndex := selectIndex + 1.
			"reject the first element"
			selectIndex = 1 ]
		thenCollect: [ :each | 
			self assert: each notNil.
			index := index + 1.
			pivot ].
			
	self assert: result ~= self collectionWithoutNilElements.
	self assert: selectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.
	
	self assert: (self collectionWithoutNilElements occurrencesOf: pivot) equals: 1.
	"should be > 1 for standard collection and = 1 for those that do not allow exact duplicates"
	self assert: (result occurrencesOf: pivot) >= 1.! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testSelectOnEmpty
	self assertEmpty: (self empty select: [ :e | self fail ])! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenDoOnEmpty
	self assertEmpty: (self empty select: [ :e | self fail ] thenDo: [ self fail ])! !

!CollectionRootTest methodsFor: 'tests - empty' stamp: ''!
testIfNotEmptyifEmpty
	self assert: (self empty ifNotEmpty: [ false ] ifEmpty: [ true ]).
	self assert: (self nonEmpty ifNotEmpty: [ true ] ifEmpty: [ false ])! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testNoneSatisfy

	| element |
	self assert: ( self collectionWithoutNilElements  noneSatisfy: [:each | each notNil not ] ).
	element := self collectionWithoutNilElements anyOne.
	self deny: ( self collectionWithoutNilElements  noneSatisfy: [:each | (each = element)not ] ).! !

!CollectionRootTest methodsFor: 'requirements' stamp: ''!
nonEmpty

	self subclassResponsibility! !

!CollectionRootTest methodsFor: 'tests - empty' stamp: ''!
testIfNotEmpty
	self empty ifNotEmpty: [ self assert: false ].
	self nonEmpty ifNotEmpty: [ self assert: true ].
	self assert: (self nonEmpty ifNotEmpty: [ :s | s ]) = self nonEmpty! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testCollectThenSelectOnEmpty
	self assertEmpty: (self empty collect: [ :e | self fail ] thenSelect: [ :e | self fail ])! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenCollectOnEmpty
	self assertEmpty: (self empty select: [ :e | self fail ] thenCollect: [ self fail ])! !

!CollectionRootTest methodsFor: 'requirements' stamp: ''!
elementTwiceIn
	^ 1 "12332312322"! !

!CollectionRootTest methodsFor: 'tests - iterate' stamp: ''!
testDetectIfFoundIfNoneWhenNobodyIsFound
	| wasFound |
	wasFound := self collectionWithoutNilElements detect: [ :each | each isNil ] ifFound: [ true ] ifNone: [ false ].
	self deny: wasFound! !

!CollectionRootTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	self subclassResponsibility! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenDo

	| result index selectIndex |
	
	index := 0.
	selectIndex := 0.
	
	result := self collectionWithoutNilElements 
		select: [ :each | 
			selectIndex := selectIndex + 1.
			"reject the first element"
			selectIndex > 1 ]
		thenDo: [ :each | 
			self assert: each notNil.
			index := index + 1]	.
			
	self assert: result equals: self collectionWithoutNilElements.
	self assert: selectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testDetect

	| res element |
	element := self collectionWithoutNilElements anyOne .
	 
	res := self collectionWithoutNilElements  detect: [:each | each = element].
	self assert: (res  = element).! !

!CollectionRootTest methodsFor: 'tests - fixture' stamp: ''!
test0TSizeTest
	self empty.
	self sizeCollection.
	self assertEmpty: self empty.
	self denyEmpty: self sizeCollection! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testSumNumbers
	|result|
	result:= self collectionWithoutNilElements 
		sumNumbers: [ :ele | ele notNil ifTrue: [ 1 ] ifFalse: [ 0 ]].
	
	self assert: self collectionWithoutNilElements size = result! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
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 - iterate' stamp: ''!
testDetectIfFoundIfNoneWhenSomethingIsFoundIgnoringTheFoundObject
	"The foundBlock can be a zero argument block ignoring the object found"

	| wasFound |
	wasFound := self collectionWithoutNilElements detect: [ :each | each notNil ] ifFound: [ true ] ifNone: [ false ].
	self assert: wasFound! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testAllSatisfy

	| element |
	" when all element  satisfy the condition, should return true : "
	self assert: ( self collectionWithoutNilElements  allSatisfy: [:each | (each notNil) ] ).
	
	" when all element don't satisfy the condition, should return false : "
	self deny: ( self collectionWithoutNilElements  allSatisfy: [:each | (each notNil) not ] ).
	
	" when only one element doesn't satisfy the condition' should return false'"
	element := self collectionWithoutNilElements anyOne.
	self deny: ( self collectionWithoutNilElements  allSatisfy: [:each | (each = element) not] ).! !

!CollectionRootTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureEmptyTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!CollectionRootTest methodsFor: 'tests - iterate' stamp: ''!
testDetectIfFoundWhenSomethingIsFoundIgnoringTheFoundObject
	"The foundBlock can be a zero argument block ignoring the object found"

	| wasFound |
	wasFound := false.
	self collectionWithoutNilElements detect: [ :each | each notNil ] ifFound: [ wasFound := true ].
	self assert: wasFound! !

!CollectionRootTest methodsFor: 'requirements' stamp: ''!
empty
	self subclassResponsibility! !

!CollectionRootTest methodsFor: 'requirements' stamp: ''!
element
	^ 3! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testRejectEmpty

	| res |
	res := self empty reject: [:each | each odd].
	self assert: res size = self empty size! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenCollectEmpty
	self assertEmpty: (self empty reject: [ :e | self fail ] thenCollect: [ :each | self fail ])! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testInjectInto
	|result|
	result:= self collectionWithoutNilElements 
		inject: 0
		into: [:inj :ele | ele notNil ifTrue: [ inj + 1 ]].
	
	self assert: self collectionWithoutNilElements size = result .! !

!CollectionRootTest methodsFor: 'tests - size capacity' stamp: ''!
testSize

	| size |
	self assert: self empty size = 0.
	size := 0.
	self sizeCollection do: [ :each | size := size + 1].
	
	self assert: self sizeCollection size = size.! !

!CollectionRootTest methodsFor: 'tests - empty' stamp: ''!
testIsEmptyOrNil
	self assert: self empty isEmptyOrNil.
	self deny: self nonEmpty isEmptyOrNil! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testDoSeparatedBy
	| string expectedString beforeFirst |
	
	string := ''.
	self collectionWithoutNilElements  
		do: [ :each | string := string , each asString ]
		separatedBy: [ string := string , '|' ].
		
	expectedString := ''.
	beforeFirst := true.
	self collectionWithoutNilElements  do: 
		[ :each | 
		beforeFirst = true 
			ifTrue: [ beforeFirst := false ]
			ifFalse: [ expectedString := expectedString , '|' ].
		expectedString := expectedString , each asString ].
	self assert: expectedString = string! !

!CollectionRootTest methodsFor: 'requirements' stamp: ''!
doWithoutNumber

	^ 2! !

!CollectionRootTest methodsFor: 'requirements' stamp: ''!
expectedElementByDetect

	^ -2! !

!CollectionRootTest methodsFor: 'tests - iterate' stamp: ''!
testDetectIfFoundWhenNobodyIsFound
	| wasFound |
	wasFound := false.
	self collectionWithoutNilElements detect: [ :each | each isNil ] ifFound: [ wasFound := true ].
	self deny: wasFound! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testAllSatisfyEmpty

	self assert: ( self empty allSatisfy: [:each | false]).! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testNoneSatisfyEmpty

	self assert: ( self empty noneSatisfy: [:each | false]).! !

!CollectionRootTest methodsFor: 'tests - iterate' stamp: ''!
testRejectNoReject
	| res collection |
	collection := self collectionWithoutNilElements.
	res := collection reject: [ :each | each isNil ].
	self assert: res size equals: collection size! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenDo

	| result index rejectIndex |
	
	index := 0.
	rejectIndex := 0.
	
	result := self collectionWithoutNilElements 
		reject: [ :each | 
			rejectIndex := rejectIndex + 1.
			"reject the first element"
			rejectIndex = 1 ]
		thenDo: [ :each | 
			self assert: each notNil.
			index := index + 1]	.
			
	self assert: result equals: self collectionWithoutNilElements.
	self assert: rejectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.! !

!CollectionRootTest methodsFor: 'tests - iterate' stamp: ''!
testDetectIfFoundWhenSomethingIsFound
	| wasFound foundObject |
	wasFound := false.
	foundObject := nil.
	self collectionWithoutNilElements
		detect: [ :each | each notNil ]
		ifFound: [ :element | 
			foundObject := element.
			wasFound := true ].
	self
		assert: wasFound;
		assert: (self collectionWithoutNilElements includes: foundObject)! !

!CollectionRootTest methodsFor: 'tests - iterate' stamp: ''!
testDetectIfFoundIfNoneWhenSomethingIsFound
	| wasFound foundObject |
	foundObject := nil.
	wasFound := self collectionWithoutNilElements
		detect: [ :each | each notNil ]
		ifFound: [ :element | 
			foundObject := element.
			true ]
		ifNone: [ false ].
	self
		assert: wasFound;
		assert: (self collectionWithoutNilElements includes: foundObject)! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testBasicCollectEmpty
	| res |
	res := self empty collect: [ :each | each class ].
	self assertEmpty: res! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testDetectIfNone

	| res element |
	res := self collectionWithoutNilElements  detect: [:each | each notNil not] ifNone: [100].
	self assert: res  = 100.
	
	element := self collectionWithoutNilElements anyOne.
	res := self collectionWithoutNilElements  detect: [:each | each = element] ifNone: [100].
	self assert: res  = element.! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testSelectNoneThenCollect
	| result |
	result := self collectionWithoutNilElements select: [ :each | each isNil ] thenCollect: [ :each | self fail ].

	self assertEmpty: result! !

!CollectionRootTest methodsFor: 'tests - empty' stamp: ''!
testIfEmpty
	self nonEmpty ifEmpty: [ self assert: false ].
	self empty ifEmpty: [ self assert: true ]! !

!CollectionRootTest methodsFor: 'tests - empty' stamp: ''!
testIsEmpty
	self assert: self empty isEmpty.
	self deny: self nonEmpty isEmpty! !

!CollectionRootTest methodsFor: 'tests - iterating' stamp: ''!
testRejectAllThenCollect
	| result |
	result := self collectionWithoutNilElements reject: [ :each | each notNil ] thenCollect: [ :each | self fail ].

	self assertEmpty: result! !

!CollectionRootTest methodsFor: 'requirements' stamp: ''!
sizeCollection
	"Answers a collection not empty"
	^ self subclassResponsibility! !

!CollectionRootTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!CollectionRootTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!CollectionRootTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!CollectionRootTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!CollectionRootTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!CollectionRootTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!CollectionRootTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!CollectionRootTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!CollectionRootTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CollectionRootTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!CollectionRootTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!CollectionRootTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!CollectionRootTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!CollectionRootTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self name = #CollectionRootTest! !

!CollectionRootTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!CollectionRootTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!CollectionRootTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!CollectionRootTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!CollectionRootTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!CollectionRootTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!CollectionRootTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!CollectionRootTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!CollectionRootTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!CollectionRootTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!CollectionRootTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!CollectionRootTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!CollectionRootTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!CollectionRootTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!CollectionRootTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!CollectionRootTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!CollectionTest commentStamp: ''!
Basic Collection tests!
!CollectionTest methodsFor: 'tests' stamp: ''!
testGroupedByGroupsOrderWithSortedCollectionOfDates
	| dataCollection grouped keys |
	"data collection full of Date instances is sorted ascending"
	dataCollection := OrderedCollection new.
	0 to: 10 do: [ :i | 0 to: 5 do: [ :j | dataCollection add: (Date year: 2000 month: 1 day: 1) + i years + j weeks ] ].
	
	"group dates collection by year"
	grouped := dataCollection groupedBy: [ :dateItem | dateItem year ].

	"test if groups (Years) order is preserved after groupedBy"	
	keys := grouped keys.
	1 to: grouped size do: [ :i |
		self assert: (keys at: i) equals: 2000 + i - 1.
		].! !

!CollectionTest methodsFor: 'tests' stamp: ''!
testCopyWithoutDuplicates
 	| a b |
	a := #(1 2 3 4 4 5 6 1) copyWithoutDuplicates.
	b := #(4 2 3 1 6 5).
	self assert: [(a includesAll: b) and: [ b includesAll: a ]].

	a := #('do' 'la' 'si' 'do' 'la') copyWithoutDuplicates .
	b := #('do' 'la' 'si' ).
	self assert: [(a includesAll: b) and: [ b includesAll: a ]].

	a := #(#do #la #si #do #la) copyWithoutDuplicates.
	b := #(#si #la #do).
	self assert: [(a includesAll: b) and: [ b includesAll: a ]].! !

!CollectionTest methodsFor: 'tests' stamp: ''!
testGroupedByGroupsOrderSimple
	| dataCollection grouped keys |
	"test of preserving groups order according to source collection order"
	dataCollection := OrderedCollection new
		add: #('ZZZ' '1');
		add: #('ZZZ' '2');
		add: #('ZZZ' '3');
		add: #('SSS' '4');
		add: #('SSS' '5');
		add: #('SSS' '6');
		add: #('BFLM' 'X');
		add: #('AAA' '1');
		add: #('AAA' '2');
		yourself.
	
	grouped := dataCollection groupedBy: [ :arrItem | arrItem at: 1 ].
	keys := grouped keys.
	self assert: (keys at: 1) equals: 'ZZZ'.
	self assert: (keys at: 2) equals: 'SSS'.
	self assert: (keys at: 3) equals: 'BFLM'.
	self assert: (keys at: 4) equals: 'AAA'.
	
	"---"
	
	dataCollection := OrderedCollection new
		add: #('k' 1);
		add: #('f' 2);
		add: #('k' 3);
		add: #('k' 4);
		add: #('k' 5);
		add: #('f' 6);
		add: #('f' 7);
		add: #('k' 8);
		yourself.
	grouped := dataCollection groupedBy: [ :arrItem | arrItem at: 1 ].
	keys := grouped keys.
	self assert: (keys at: 1) equals: 'k'.
	self assert: (keys at: 2) equals: 'f'.
	self assert: (grouped at: 'k') asArray equals: #(#('k' 1) #('k' 3) #('k' 4) #('k' 5) #('k' 8)).
	self assert: (grouped at: 'f') asArray equals: #(#('f' 2) #('f' 6) #('f' 7)).! !

!CollectionValueHolder commentStamp: ''!
I am designed specifically for collections.!
!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
atAll: aCollection put: anObject 
	
	| result |
	result := value atAll: aCollection put: anObject .
	self valueAdded: anObject.
	^ result! !

!CollectionValueHolder methodsFor: 'private' stamp: ''!
doesNotUnderstand: aMessage

	^ (value respondsTo: aMessage selector)
		ifTrue: [ value perform: aMessage selector withEnoughArguments: aMessage arguments ]
		ifFalse: [ super doesNotUnderstand: aMessage ]! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
removeFirst

	| result |
	result := value removeFirst.
	self valueRemoved: result.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
add: newObject
	| result |
	result := value add: newObject.
	self valueAdded: newObject.
	^ result! !

!CollectionValueHolder methodsFor: 'announcing' stamp: ''!
valueAdded: newValue
	self announcer announce: (ValueAdded newValue: newValue).
	self valueChanged: newValue! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
removeAt: index

	| result |
	result := value removeAt: index.
	self valueRemoved: result.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
atAll: indexArray putAll: valueArray
	
	| result |
	result := value atAll: indexArray putAll: valueArray.
	self valueAdded: valueArray.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
removeFirst: n 

	| result |
	result := value removeFirst: n .
	self valueRemoved: result.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
sort: aSortBlock 

	value sort: aSortBlock .
	self valueChanged! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
add: newObject before: oldObject
	
	| result |
	result := value add: newObject before: oldObject.
	self valueAdded: newObject.
	^ result! !

!CollectionValueHolder methodsFor: 'announcements' stamp: ''!
whenAddedDo: aBlock
	"Culled block [ :newValue :announcement | ]"

	self announcer when: ValueAdded do: [ :ann | aBlock cull: ann newValue cull: ann ]! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
atWrap: index put: anObject
	
	| result |
	result := value atWrap: index put: anObject.
	self valueAdded: value.
	^ result! !

!CollectionValueHolder methodsFor: 'override' stamp: ''!
at: anObject

	^ value at: anObject! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
add: newObject beforeIndex: index 
	
	| result |
	result := value add: newObject beforeIndex: index.
	self valueAdded: newObject.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
at: index ifAbsentPut: block

	| result |
	result := value at: index ifAbsentPut: block.
	self valueAdded: block value.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
atAllPut: anObject 
	
	| result |
	result := value atAllPut: anObject.
	self valueAdded: anObject.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
remove: oldObject

	| result |
	result := value remove: oldObject.
	self valueRemoved: oldObject.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
removeAll: aCollection
	| result |
	result := value removeAll: aCollection.
	self valueRemoved: result.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
addAllFirstUnlessAlreadyPresent: anOrderedCollection
	
	| result |
	result := value addAllFirstUnlessAlreadyPresent: anOrderedCollection.
	self valueAdded: anOrderedCollection.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
atLast: indexFromEnd put: obj
	
	| result |
	result := value atLast: indexFromEnd put: obj.
	self valueAdded: obj.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
removeLast: n

	| result |
	result := value removeLast: n.
	self valueRemoved: result.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
removeLast

	| result |
	result := value removeLast.
	self valueRemoved: result.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
addLast: newObject 

	| result |
	result := value addLast: newObject .
	self valueAdded: newObject.
	^ result! !

!CollectionValueHolder methodsFor: 'initialization' stamp: ''!
reset

	value reset.
	self valueChanged! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
resetTo: index

	value resetTo: index.
	self valueChanged! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
addFirst: newObject 

	| result |
	result := value addFirst: newObject .
	self valueAdded: newObject.
	^ result! !

!CollectionValueHolder methodsFor: 'announcing' stamp: ''!
valueRemoved: oldValue
	self announcer announce: (ValueRemoved oldValue: oldValue).
	self valueChanged: oldValue! !

!CollectionValueHolder methodsFor: 'override' stamp: ''!
at: key put: anObject

	value at: key put: anObject.
	self valueAdded: anObject.
	^ anObject! !

!CollectionValueHolder methodsFor: 'announcements' stamp: ''!
whenRemovedDo: aBlock
	"Culled block [ :oldValue :announcement | ]"

	self announcer when: ValueRemoved do: [ :ann | aBlock cull: ann oldValue cull: ann ]! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
add: newObject after: oldObject 
	
	| result |
	result := value add: newObject after: oldObject.
	self valueAdded: newObject.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
addAllFirst: anOrderedCollection
	
	| result |
	result := value addAllFirst: anOrderedCollection.
	self valueAdded: anOrderedCollection.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
replace: aBlock
	value replace: aBlock.
	self valueChanged! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
insert: anObject before: spot

	| result |
	result := value insert: anObject before: spot.
	self valueAdded: anObject.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
addAllLast: aCollection 
	
	| result |
	result := value addAllLast: aCollection.
	self valueAdded: aCollection.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
removeAll
	"Note: I'm not sure about the semantics here, because Collections normally don't return anything on #removeAll, even though one might expect the original content. Use with care."

	value removeAll.
	self valueRemoved: nil! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
replaceAll: oldObject with: newObject
	value replaceAll: oldObject with: newObject.
	self valueChanged: oldObject! !

!CollectionValueHolder methodsFor: 'override' stamp: ''!
size 

	^ value size! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
removeIndex: removedIndex

	| result |
	result := value removeIndex: removedIndex.
	self valueRemoved: result.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
addAll: aCollection 
	
	| result |
	result := value addAll: aCollection.
	self valueAdded: aCollection.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
add: newObject afterIndex: index 
	
	| result |
	result := value add: newObject afterIndex: index.
	self valueAdded: newObject.
	^ result! !

!CollectionValueHolder methodsFor: 'protocol' stamp: ''!
remove: oldObject ifAbsent: absentBlock

	| result |
	result := value remove: oldObject ifAbsent: absentBlock.
	self valueRemoved: oldObject.
	^ result! !

!CollectionValueHolderTest commentStamp: ''!
Unit tests for collection value holders!
!CollectionValueHolderTest methodsFor: 'tests' stamp: ''!
testAddMany
	empty
		whenAddedDo:
			[ :addedValue :ann | 
			fired := true.
			self assert: addedValue equals: #(1 2).
			self assert: (ann isMemberOf: ValueAdded) ].
	empty addAll: #(1 2).
	self assert: fired! !

!CollectionValueHolderTest methodsFor: 'tests' stamp: ''!
testChangeRemoveOne
	withItems
		whenChangedDo:
			[ :col :changed | 
			fired := true.
			self assert: col asArray equals: #(2 3).
			self assert: changed equals: 1 ].
	withItems remove: 1.
	self assert: fired! !

!CollectionValueHolderTest methodsFor: 'tests' stamp: ''!
testRemoveOne
	withItems
		whenRemovedDo:
			[ :removedValue :ann | 
			fired := true.
			self assert: withItems asArray equals: #(2 3).
			self assert: removedValue equals: 1.
			self assert: (ann isMemberOf: ValueRemoved) ].
	withItems remove: 1.
	self assert: fired! !

!CollectionValueHolderTest methodsFor: 'tests' stamp: ''!
testChangeAddOne
	empty
		whenChangedDo:
			[ :col :changed | 
			fired := true.
			self assert: col asArray equals: #(1).
			self assert: changed equals: 1 ].
	empty add: 1.
	self assert: fired! !

!CollectionValueHolderTest methodsFor: 'tests' stamp: ''!
testRemoveMany
	withItems
		whenRemovedDo:
			[ :removedValue :ann | 
			fired := true.
			self assert: withItems asArray equals: #(2).
			self assert: removedValue equals: #(1 3).
			self assert: (ann isMemberOf: ValueRemoved) ].
	withItems removeAll: #(1 3).
	self assert: fired! !

!CollectionValueHolderTest methodsFor: 'tests' stamp: ''!
testChangeAddMany
	empty
		whenChangedDo:
			[ :col :changed | 
			fired := true.
			self assert: col asArray equals: #(1 2 3).
			self assert: changed equals: #(1 2 3) ].
	empty addAll: #(1 2 3).
	self assert: fired! !

!CollectionValueHolderTest methodsFor: 'tests' stamp: ''!
testChangeRemoveMany
	withItems
		whenChangedDo:
			[ :col :changed | 
			fired := true.
			self assert: col asArray equals: #(2).
			self assert: changed equals: #(1 3) ].
	withItems removeAll: #(1 3).
	self assert: fired! !

!CollectionValueHolderTest methodsFor: 'tests' stamp: ''!
testAddOne
	empty
		whenAddedDo:
			[ :addedValue :ann | 
			fired := true.
			self assert: addedValue equals: 1.
			self assert: (ann isMemberOf: ValueAdded) ].
	empty add: 1.
	self assert: fired! !

!CollectionValueHolderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	empty := OrderedCollection new asValueHolder.
	withItems := #(1 2 3) asOrderedCollection asValueHolder.
	fired := false! !

!CollectionsAssembly commentStamp: ''!
I contain all basic collections.!
!CollectionsAssembly class methodsFor: 'meta-data' stamp: ''!
parts
	^ {#'Collections-Abstract' -> #().
	#'Collections-Arithmetic' -> #().
	#'Collections-Atomic' -> #().
	#'Collections-Native' -> #().
	#'Collections-Sequenceable' -> #().
	#'Collections-Stack' -> #().
	#'Collections-Streams' -> #().
	#'Collections-Strings' -> #().
	#'Collections-Support' -> #().
	#'Collections-Unordered' -> #().
	#'Collections-Weak' -> #()}! !

!CollectionsAssembly class methodsFor: 'meta-data' stamp: ''!
description
	^ 'I contain all basic collections.'! !

!CollectionsAssembly class methodsFor: 'meta-data' stamp: ''!
version
	^ '1.0-dev'! !

!CollectionsAssembly class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #Collections! !

!Color commentStamp: ''!
This class represents abstract color, regardless of the depth of bitmap it will be shown in.  At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with.  The supported depths (in bits) are 1, 2, 4, 8, 16, and 32.  The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million.  (See comment in BitBlt.)  To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8).  (See comment in DisplayMedium)

	Color is represented as the amount of light in red, green, and blue.  White is (1.0, 1.0, 1.0) and black is (0, 0, 0).  Pure red is (1.0, 0, 0).  These colors are "additive".  Think of Color's instance variables as:
	r	amount of red, a Float between 0.0 and 1.0.
	g	amount of green, a Float between 0.0 and 1.0.
	b	amount of blue, a Float between 0.0 and 1.0.
(But, in fact, the three are encoded as values from 0 to 1023 and combined in a single integer, rgb.  The user does not need to know this.)

	Many colors are named.  You find a color by name by sending a message to class Color, for example (Color lightBlue).  Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below)
	A color is essentially immutable.  Once you set red, green, and blue, you cannot change them.  Instead, create a new Color and use it.
	
	Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number.  Convert the range of this number to an integer from 1 to N.  Then call (Color green lightShades: N) to get an Array of colors from white to green.  Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array.  atPin: gives the first (or last) color if the index is out of range.  atWrap: wraps around to the other end if the index is out of range.
		
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.

	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.

   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,.)!
!Color methodsFor: 'queries' stamp: ''!
isOrientedFill
	"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
	^false! !

!Color methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
hue
	"Return the hue of this color, an angle in the range [0.0..360.0]."
	"Color red hue >>> 0.0"
	"(Color r: 0.5 g: 0.5 b: 1) hue >>> 240.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: '*Athens-Core' stamp: ''!
strokeRect: aRect on: aCanvas strokeWidth: width
	^ (aCanvas surface createSolidColorPaint: self) strokeRect: aRect on: aCanvas strokeWidth: width! !

!Color methodsFor: 'transformations' stamp: ''!
quiteWhiter

	^ self alphaMixed: 0.6 with: (ColorRegistry at: #white)! !

!Color methodsFor: 'accessing' stamp: ''!
red
	"Return the red component of this color, a float in the range [0.0..1.0]."

	^ self privateRed asFloat / ComponentMax! !

!Color methodsFor: 'converting' stamp: ''!
asColor
	"Convert the receiver into a color"
	^self! !

!Color methodsFor: 'private' stamp: ''!
privateMinComponent
	^ (self privateRed min: self privateGreen) min: self privateBlue! !

!Color methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating
	^ true! !

!Color methodsFor: 'converting' stamp: ''!
asHexString
	"Return a string representing the receiver in HEX (i.e., 6 elements in 16 basis)"
	"(Color red asHexString) >>> 'FF0000'"
	| s |
	s := '000000' copy.
	s at: 1 put: (Character digitValue: ((rgb bitShift: -6 - RedShift) bitAnd: 15)).
	s at: 2 put: (Character digitValue: ((rgb bitShift: -2 - RedShift) bitAnd: 15)).
	s at: 3 put: (Character digitValue: ((rgb bitShift: -6 - GreenShift) bitAnd: 15)).
	s at: 4 put: (Character digitValue: ((rgb bitShift: -2 - GreenShift) bitAnd: 15)).
	s at: 5 put: (Character digitValue: ((rgb bitShift: -6 - BlueShift) bitAnd: 15)).
	s at: 6 put: (Character digitValue: ((rgb bitShift: -2 - BlueShift) bitAnd: 15)).
	^ s! !

!Color methodsFor: 'transformations' stamp: ''!
whiter

	^ self alphaMixed: 0.8333 with: (ColorRegistry at: #white)! !

!Color methodsFor: 'transformations' stamp: ''!
atLeastAsLuminentAs: aFloat 
	| revisedColor |
	revisedColor := self.
	[ revisedColor luminance < aFloat ] whileTrue: [ revisedColor := revisedColor slightlyLighter ].
	^ revisedColor! !

!Color methodsFor: '*Graphics-Primitives' stamp: ''!
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: '*Athens-Core' stamp: ''!
asStrokePaintOn: aCanvas 
	^ aCanvas surface createStrokePaintFor: self! !

!Color methodsFor: '*Athens-Core' stamp: ''!
strokePath: aPath on: aCanvas strokeWidth: width
	^ (aCanvas surface createSolidColorPaint: self) strokePath: aPath on: aCanvas strokeWidth: width! !

!Color methodsFor: 'transformations' stamp: ''!
lighter
	"Answer a lighter shade of this color."

	^ self adjustSaturation: -0.03 brightness: 0.08! !

!Color methodsFor: 'private' stamp: ''!
privateGreen
	"Private!! Return the internal representation of my green component."

	^ (rgb bitShift: 0 - GreenShift) bitAnd: ComponentMask! !

!Color methodsFor: '*Graphics-Canvas' stamp: ''!
fillRectangle: aRectangle on: aCanvas
	"Fill the given rectangle on the given canvas with the receiver."
	
	aCanvas fillRectangle: aRectangle basicFillStyle: self! !

!Color methodsFor: 'transformations' stamp: ''!
- aColor
	"Answer aColor is subtracted from the given color in an additive color space.  "
	"(Color white - Color red) display"

	^ self class basicNew
		setPrivateRed: self privateRed - aColor privateRed
		green: self privateGreen - aColor privateGreen
		blue: self privateBlue - aColor  privateBlue;
		setAlpha: ((self = aColor) ifTrue: [ 0 ] ifFalse: [ self alpha ])! !

!Color methodsFor: 'transformations' stamp: ''!
slightlyDarker

	^ self adjustBrightness: -0.03! !

!Color methodsFor: '*Morphic-Base' stamp: ''!
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: 'accessing' stamp: ''!
blue
	"Return the blue component of this color, a float in the range [0.0..1.0]."

	^ self privateBlue asFloat / ComponentMax! !

!Color methodsFor: 'transformations' stamp: ''!
negated
	"Return an RGB inverted color"
	^Color
		r: 1.0 - self red
		g: 1.0 - self green
		b: 1.0 - self blue! !

!Color methodsFor: 'accessing' stamp: ''!
setAlpha: aFloat
	alpha := ((255.0 * aFloat) asInteger  min: 255) max: 0.! !

!Color methodsFor: 'accessing' stamp: ''!
green
	"Return the green component of this color, a float in the range [0.0..1.0]."
	"Color red green >>> 0.0"
	"(Color r: 0.5 g: 0.5 b: 1) green >>>  0.5004887585532747"
	
	^ self privateGreen asFloat / ComponentMax! !

!Color methodsFor: 'transformations' stamp: ''!
veryMuchLighter

	^ self alphaMixed: 0.1165 with: (ColorRegistry at: #white)! !

!Color methodsFor: 'wheels' stamp: ''!
lightShades: thisMany
	"Return an array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program.  "
	"(Color red lightShades: 12) inspect"

	^ self class white mix: self shades: thisMany! !

!Color methodsFor: 'printing' stamp: ''!
storeArrayValuesOn: aStream
	self isTransparent ifTrue: [ ^ aStream space. ].

	(self red roundTo: 0.001) storeOn: aStream.
	aStream space.
	(self green roundTo: 0.001) storeOn: aStream.
	aStream space.
	(self blue roundTo: 0.001) storeOn: aStream.
	aStream space.
	(self alpha roundTo: 0.001) storeOn: aStream.! !

!Color methodsFor: 'converting' stamp: ''!
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: [ "white" 0 ]
		ifFalse: [ 1 ]	"black"! !

!Color methodsFor: 'transformations' stamp: ''!
alphaMixed: proportion with: aColor 
	"Answer this color mixed with the given color. The proportion, a number 
	between 0.0 and 1.0, determines what what fraction of the receiver to  
	use in the mix. For example, 0.9 would yield a color close to the  
	receiver. This method uses RGB interpolation; HSV interpolation can lead 
	to surprises.  Mixes the alphas (for transparency) also."
	| frac1 frac2 |
	frac1 := proportion asFloat 
		min: 1.0
		max: 0.0.
	frac2 := 1.0 - frac1.
	^ self class 
		r: self red * frac1 + (aColor red * frac2)
		g: self green * frac1 + (aColor green * frac2)
		b: self blue * frac1 + (aColor blue * frac2)
		alpha: self alpha * frac1 + (aColor alpha * frac2)! !

!Color methodsFor: 'queries' stamp: ''!
isBitmapFill
	^false! !

!Color methodsFor: 'queries' stamp: ''!
isBlack
	"Return true if the receiver represents black"
	^rgb = 0! !

!Color methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionColor
	<inspectorPresentationOrder: 10 title: 'Color'>
	
	^ SpImagePresenter new  
		image: (Morph new 
			color: self;
			asFormOfSize: 50@50);
		yourself! !

!Color methodsFor: 'pixels handling' stamp: ''!
pixelWordForDepth: depth 
	"Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1."
	| pixelValue basicPixelWord |
	self isTransparent ifTrue: [ ^ 0 ].
	pixelValue := self pixelValueForDepth: depth.
	basicPixelWord := self pixelWordFor: depth filledWith: pixelValue.
	^ depth < 32 
		ifTrue: [ basicPixelWord ]
		ifFalse: [ (basicPixelWord bitAnd: 16777215) bitOr: (alpha bitShift: 24) ]! !

!Color methodsFor: 'private' stamp: ''!
setPrivateRed: r green: g blue: b 
	"Initialize this color's r, g, and b components to the given values in the range [0..ComponentMax].  Encoded in a single variable as 3 integers in [0..1023]."
	rgb == nil ifFalse: [ self attemptToMutateError ].
	rgb := ((r 
		min: ComponentMask
		max: 0) bitShift: RedShift) + ((g 
			min: ComponentMask
			max: 0) bitShift: GreenShift) + (b 
			min: ComponentMask
			max: 0).
	cachedDepth := nil.
	cachedBitPattern := nil! !

!Color methodsFor: 'transformations' stamp: ''!
blacker
	
	^ self alphaMixed: 0.8333 with: self class black! !

!Color methodsFor: 'initialization' stamp: ''!
initializePrivateRed: r green: g blue: b 
	"Initialize this color's r, g, and b components to the given values in the range [0..ComponentMax].  Encoded in a single variable as 3 integers in [0..1023]."
	rgb == nil ifFalse: [ self attemptToMutateError ].
	rgb := ((r 
		min: ComponentMask
		max: 0) bitShift: RedShift) + ((g 
			min: ComponentMask
			max: 0) bitShift: GreenShift) + (b 
			min: ComponentMask
			max: 0).
	cachedDepth := nil.
	cachedBitPattern := nil! !

!Color methodsFor: 'queries' stamp: ''!
isGradientFill
	^false! !

!Color methodsFor: 'pixels handling' stamp: ''!
pixelWordFor: depth filledWith: pixelValue 
	"Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1."
	| halfword |
	depth = 32 ifTrue: [ ^ pixelValue ].
	depth = 16 
		ifTrue: [ halfword := pixelValue ]
		ifFalse: 
			[ halfword := pixelValue * (#(
					65535
					21845
					#-
					4369
					#-
					#-
					#-
					257
				) at: depth)	"replicates at every bit"	"replicates every 2 bits"	"replicates every 4 bits"	"replicates every 8 bits" ].
	^ halfword bitOr: (halfword bitShift: 16)! !

!Color methodsFor: 'transformations' stamp: ''!
slightlyWhiter

	^ self alphaMixed: 0.85 with: (ColorRegistry at: #white)! !

!Color methodsFor: 'comparing' stamp: ''!
= aColor
	"Return true if the receiver equals the given color. This method handles translucent colors, too."

	aColor isColor ifFalse: [^ false].
	^ aColor privateRGB = rgb and:
		[aColor privateAlpha = self privateAlpha]! !

!Color methodsFor: 'transformations' stamp: ''!
* aNumberOrArray
	"Answer this color with its RGB multiplied by the given number, or
	 multiply this color's RGB values by the corresponding entries in the
	given array."
	"(self brown * 2) display"
	"(self brown * #(1 0 1)) display"
	| multipliers |
	multipliers := aNumberOrArray isCollection
		ifTrue: [aNumberOrArray]
		ifFalse:
			[Array
				with: aNumberOrArray
				with: aNumberOrArray
				with: aNumberOrArray].

	^ self class basicNew
		setPrivateRed: (self privateRed * multipliers first) asInteger
		green: (self privateGreen * multipliers second) asInteger
		blue: (self privateBlue * multipliers third) asInteger;
		setAlpha: self alpha! !

!Color methodsFor: 'transformations' stamp: ''!
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: 'private' stamp: ''!
privateRGB
	"Private!! Return the internal representation of my RGB components."

	^ rgb! !

!Color methodsFor: 'private' stamp: ''!
setRGB: rgb0 
	rgb == nil ifFalse: [ self attemptToMutateError ].
	rgb := rgb0! !

!Color methodsFor: 'initialization' stamp: ''!
initializeHue: hue saturation: saturation brightness: brightness alpha: anAlpha
	"Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details."

	| s v hf i f p q t |
	rgb == nil
		ifFalse: [ self attemptToMutateError ].
	s := saturation asFloat min: 1.0 max: 0.0.
	v := brightness asFloat min: 1.0 max: 0.0.
	
	"zero saturation yields gray with the given brightness"
	s = 0.0 ifTrue: [
		^ self
			initializeRed: v
			green: v
			blue: v
			alpha: anAlpha ].
	
	hf := hue asFloat \\ 360.0 / 60.0.
	i := hf asInteger.	"integer part of hue"
	f := hf fractionPart.	"fractional part of hue"
		
	p := (1.0 - s) * v.
	q := (1.0 - (s * f)) * v.
	t := (1.0 - (s * (1.0 - f))) * v.
	
	0 = i
		ifTrue: [ 
			^ self
				initializeRed: v
				green: t
				blue: p
				alpha: anAlpha ].
	1 = i
		ifTrue: [ 
			^ self
				initializeRed: q
				green: v
				blue: p
				alpha: anAlpha ].
	2 = i
		ifTrue: [ 
			^ self
				initializeRed: p
				green: v
				blue: t
				alpha: anAlpha ].
	3 = i
		ifTrue: [ 
			^ self
				initializeRed: p
				green: q
				blue: v
				alpha: anAlpha ].
	4 = i
		ifTrue: [ 
			^ self
				initializeRed: t
				green: p
				blue: v
				alpha: anAlpha ].
	5 = i
		ifTrue: [ 
			^ self
				initializeRed: v
				green: p
				blue: q
				alpha: anAlpha ].
	self error: 'implementation error'! !

!Color methodsFor: 'accessing' stamp: ''!
brightness
	"Return the HSV brightness of this color, a float in the range [0.0..1.0]."

	^ self privateMaxComponent asFloat / ComponentMax! !

!Color methodsFor: 'equality' stamp: ''!
diff: theOther
	"Returns a number between 0.0 and 1.0"
	"(Color red diff: Color red) >>> 0.0"
	"(Color white diff: Color black ) >>> 1.0"
	
	^ ((self privateRed - theOther privateRed) abs
		+ (self privateGreen - theOther privateGreen) abs
		+ (self privateBlue - theOther privateBlue) abs)
		/ 3.0 / ComponentMax! !

!Color methodsFor: '*Morphic-Base' stamp: ''!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	
	aMenu add: 'change color...' target: self selector: #changeColorIn:event: argument: aMorph! !

!Color methodsFor: 'queries' stamp: ''!
isSolidFill
	^true! !

!Color methodsFor: '*STON-Extensions' stamp: ''!
stonOn: stonWriter
	| name |
	(self isTranslucent or: [ (name := self name) = #unnamed ])
		ifTrue: [ 
			stonWriter writeObject: self streamMap: [ :map |
				#(red green blue alpha) do: [ :each | 
					map at: each put: ((self perform: each) roundTo: 0.001) ] ] ]
		ifFalse: [ 
			stonWriter writeObject: self listSingleton: name ]! !

!Color methodsFor: 'transformations' stamp: ''!
paler
	"Answer a paler shade of this color."

	^ self adjustSaturation: -0.09 brightness: 0.09! !

!Color methodsFor: 'other' stamp: ''!
raisedColor
	^ self! !

!Color methodsFor: '*Athens-Cairo' stamp: ''!
loadOnCairoCanvas: aCairoCanvas
	aCairoCanvas
		setSourceR: self red g: self green b: self blue a: self alpha! !

!Color methodsFor: '*Graphics-Primitives' stamp: ''!
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: '*STON-Extensions' stamp: ''!
stonContainSubObjects
	^ false! !

!Color methodsFor: 'converting' stamp: ''!
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 ]
		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: 'private' stamp: ''!
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: '*System-CommandLine-TextSupport' stamp: ''!
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: 'queries' stamp: ''!
isTranslucentButNotTransparent
	"Answer true if this any of this morph is translucent but not transparent."
	
	^ self isTranslucent and: [ self isTransparent not ]! !

!Color methodsFor: 'accessing - higher level' stamp: ''!
beOpaque
	"Set the transparency of the receiver to opaque, i.e. alpha to 1.0."
	
	^ self alpha: 1.0! !

!Color methodsFor: 'converting' stamp: ''!
asNontranslucentColor
	"Set the transparency of the receiver to opaque."
	
	^ self alpha: 1.0.! !

!Color methodsFor: 'accessing' stamp: ''!
hslSaturation
	"Return the HSL saturation of this color, a value between 0.0 and 1.0."
	"Color red hslSaturation >>> 1.0"
	"(Color r: 0.5 g: 0.5 b: 1) hslSaturation >>> 1.0"
	| chroma |
	chroma := self chroma.
	"Chroma is zero for black and white, which are the two cases of division by zero below."
	chroma isZero ifTrue: [ ^ chroma ].
	
	^ chroma / (1.0 - (self lightness * 2.0 - 1.0) abs)! !

!Color methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
privateBlue
	"Private!! Return the internal representation of my blue component."

	^ rgb bitAnd: ComponentMask! !

!Color methodsFor: 'private' stamp: ''!
privateMaxComponent
	^ (self privateRed max: self privateGreen) max: self privateBlue! !

!Color methodsFor: 'accessing' stamp: ''!
name
	^ self class registeredNameOf: self! !

!Color methodsFor: 'printing' stamp: ''!
storeArrayOn: aStream

	aStream nextPutAll: '#('.
	self storeArrayValuesOn: aStream.
	aStream nextPutAll: ') '! !

!Color methodsFor: '*Athens-Core' stamp: ''!
asAthensPaintOn: anAthensCanvas

	^ self
	
	"^ anAthensCanvas surface createSolidColorPaint: self"! !

!Color methodsFor: 'printing' stamp: ''!
shortPrintString
	"Return a short (but less precise) print string for use where space is tight."

	^ String streamContents: [ :s |
				s
					nextPutAll: '(';
					nextPutAll: self class name;
					nextPutAll: ' r: '.
				(self red roundTo: 0.01) printOn: s.
				s nextPutAll: ' g: '.
				(self green roundTo: 0.01) printOn: s.
				s nextPutAll: ' b: '.
				(self blue roundTo: 0.01) printOn: s.
				s nextPutAll: ')' ]! !

!Color methodsFor: 'transformations' stamp: ''!
adjustSaturation: saturation brightness: brightness
	"Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)"

	^ self class
		h: self hue
		s: (self saturation + saturation min: 1.0 max: 0.005)
		v: (self brightness + brightness min: 1.0 max: 0.005)
		alpha: self alpha! !

!Color methodsFor: 'converting' stamp: ''!
asColorref
	"Convert the receiver into a colorref, i.e, a number embedding r,g,b on 24 bits"
	"(Color red asColorref) >>> 255"
	"(Color white asColorref) >>>  16777215"
	
	^(self red * 255) asInteger + ((self green * 255) asInteger << 8) + ((self blue * 255) asInteger << 16)! !

!Color methodsFor: 'printing' stamp: ''!
storeOn: aStream
	self isTransparent
		ifTrue: [ ^ aStream nextPutAll: '(Color transparent)' ].
	aStream
		nextPutAll: '(';
		nextPutAll: self class name;
		nextPutAll: ' r: ';
		print: self red;
		nextPutAll: ' g: ';
		print: self green;
		nextPutAll: ' b: ';
		print: self blue;
		nextPutAll: ' alpha: ';
		print: self alpha;
		nextPutAll: ')'! !

!Color methodsFor: 'transformations' stamp: ''!
+ aColor
	"Answer this color mixed with the given color in an additive color space.  "

	^ self class basicNew
		setPrivateRed: self privateRed + aColor privateRed
		green: self privateGreen + aColor privateGreen
		blue: self privateBlue + aColor  privateBlue;
		setAlpha: (self alpha + aColor alpha min: 1.0)! !

!Color methodsFor: 'transformations' stamp: ''!
muchLighter

	^ self alphaMixed: 0.233 with: Color white! !

!Color methodsFor: '*Athens-Core' stamp: ''!
athensFillPath: aPath on: aCanvas 
	^ aCanvas surface fillPath: aPath withSolidColor:self! !

!Color methodsFor: 'comparing' stamp: ''!
hash

	^ rgb bitXor: alpha! !

!Color methodsFor: 'transformations' stamp: ''!
atMostAsLuminentAs: aFloat 
	| revisedColor |
	revisedColor := self.
	[ revisedColor luminance > aFloat ] whileTrue: [ revisedColor := revisedColor slightlyDarker ].
	^ revisedColor! !

!Color methodsFor: 'accessing' stamp: ''!
chroma
	"Return the chroma of this color, a float in the range [0.0..1.0].
	Some combinations of chroma and brightness (or lightness) are meaningless in RGB; therefore, HSL and HSV each define a specific saturation by scaling chroma to the full [0..1] range."

	^ (self privateMaxComponent - self privateMinComponent) asFloat / ComponentMax! !

!Color methodsFor: 'transformations' stamp: ''!
/ aNumber
	"Answer this color with its RGB divided by the given number. "
	"(Color red / 2) display"

	^ self class basicNew
		setPrivateRed: (self privateRed / aNumber) asInteger
		green: (self privateGreen / aNumber) asInteger
		blue: (self privateBlue / aNumber) asInteger;
		setAlpha: self alpha! !

!Color methodsFor: 'transformations' stamp: ''!
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: 'accessing' stamp: ''!
hsvSaturation
	"Return the HSV saturation of this color, a value between 0.0 and 1.0."

	"Color red hsvSaturation >>> 1.0"

	"(Color r: 0.5 g: 0.5 b: 1) hsvSaturation >>> 0.4995112414467253"

	| max |
	max := self privateMaxComponent.
	^ max isZero
		ifTrue: [ 0.0 ]
		ifFalse: [ (max - self privateMinComponent) asFloat / max asFloat ]! !

!Color methodsFor: 'wheels' stamp: ''!
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.  "
	"(Color wheel: 8) inspect"
	"(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c]"
	
	| sat bri step hue |
	sat := self saturation.
	bri := self brightness.
	hue := self hue.
	step := 360.0 / (thisMany max: 1).
	^ (1 to: thisMany) collect: 
		[ :num | | c | 
		c := self class 
			h: hue
			s: sat
			v: bri.	"hue is taken mod 360"
		hue := hue + step.
		c ]! !

!Color methodsFor: 'transformations' stamp: ''!
mixed: proportion with: aColor 
	"Mix with another color and do not preserve transpareny.  Only use this for extracting the RGB value and mixing it.  All other callers should use instead: 
	aColor alphaMixed: proportion with: anotherColor
	"
	| frac1 frac2 |
	frac1 := proportion asFloat 
		min: 1.0
		max: 0.0.
	frac2 := 1.0 - frac1.
	^ self class 
		r: self red * frac1 + (aColor red * frac2)
		g: self green * frac1 + (aColor green * frac2)
		b: self blue * frac1 + (aColor blue * frac2)! !

!Color methodsFor: 'private' stamp: ''!
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: 'initialization' stamp: ''!
initializeRed: r green: g blue: b alpha: anAlpha 
	"Initialize this color's r, g, and b components to the given values in the range [0.0..1.0].  Encoded in a single variable as 3 integers in [0..1023]."
	rgb == nil ifFalse: [ self attemptToMutateError ].
	rgb := (((r * ComponentMax) rounded bitAnd: ComponentMask) bitShift: RedShift) + (((g * ComponentMax) rounded bitAnd: ComponentMask) bitShift: GreenShift) + ((b * ComponentMax) rounded bitAnd: ComponentMask).
	cachedDepth := nil.
	cachedBitPattern := nil.
	self setAlpha: anAlpha.! !

!Color methodsFor: 'converting' stamp: ''!
dominantColor
	^ self! !

!Color methodsFor: 'queries' stamp: ''!
isTransparent

	^ alpha = 0! !

!Color methodsFor: '*Athens-Core' stamp: ''!
athensFillRectangle: aRect on: anAthensCanvas

	^ anAthensCanvas surface fillRectangle: aRect withSolidColor:self! !

!Color methodsFor: 'transformations' stamp: ''!
slightlyLighter

	^ self adjustSaturation: -0.01 brightness: 0.03! !

!Color methodsFor: 'converting' stamp: ''!
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: 'other' stamp: ''!
rgbTriplet
	"Returns an array composed of the three color float components."
	
	"Color black rgbTriplet >>> #(0.0 0.0 0.0)"
	"Color red rgbTriplet >>> #(1.0 0.0 0.0)"
	^ Array
		with: (self red roundTo: 0.01)
		with: (self green roundTo: 0.01)
		with: (self blue roundTo: 0.01)! !

!Color methodsFor: 'accessing' stamp: ''!
alpha
	"Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque."

	^ alpha asFloat / 255.0! !

!Color methodsFor: 'transformations' stamp: ''!
muchDarker

	^ self alphaMixed: 0.5 with: (ColorRegistry at: #black)! !

!Color methodsFor: 'accessing' stamp: ''!
lightness
	"Return the HSL lightness of this color, a float in the range [0.0..1.0]."

	^ (self privateMaxComponent + self privateMinComponent) asFloat
		/ ComponentMax / 2.0! !

!Color methodsFor: 'queries' stamp: ''!
isColor

	^ true! !

!Color methodsFor: 'pixels handling' stamp: ''!
scaledPixelValue32
	"Return the alpha scaled pixel value for depth 32"
	| pv32 a b g r |

	pv32 := self pixelWordForDepth: 32 .
	a := (self alpha * 255.0) rounded.
	b := (pv32 bitAnd: 255) * a // 256.
	g := ((pv32 bitShift: -8) bitAnd: 255) * a // 256.
	r := ((pv32 bitShift: -16) bitAnd: 255) * a // 256.
	^ b + (g bitShift: 8) + (r bitShift: 16) + (a bitShift: 24)! !

!Color methodsFor: 'private' stamp: ''!
privateRed
	"Private!! Return the internal representation of my red component."

	^ (rgb bitShift: 0 - RedShift) bitAnd: ComponentMask! !

!Color methodsFor: 'transformations' stamp: ''!
adjustBrightness: brightness
	"Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)"

	^ self class
		h: self hue
		s: self saturation
		v: (self brightness + brightness min: 1.0 max: 0.005)
		alpha: self alpha! !

!Color methodsFor: 'converting' stamp: ''!
contrastingBlackAndWhiteColor
	"Answer black or white depending on the luminance."

	self isTransparent ifTrue: [ ^ self class black].
	^self luminance > 0.5
		ifTrue: [self class black]
		ifFalse: [self class white]! !

!Color methodsFor: 'converting' stamp: ''!
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: '*Graphics-Primitives' stamp: ''!
bitPatternForDepth: depth 
	"Return a Bitmap, possibly containing a stipple pattern, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps. The resulting Bitmap may be multiple words to represent a stipple pattern of several lines.  "
	"See also:	pixelValueAtDepth:	-- value for single pixel
				pixelWordAtDepth:	-- a 32-bit word filled with the pixel value"
	"Details: The pattern for the most recently requested depth is cached."
	"Note for depths > 2, there are stippled and non-stippled versions (generated with #balancedPatternForDepth: and #bitPatternForDepth:, respectively). The stippled versions don't work with the window bit caching of StandardSystemView, so we make sure that for these depths, only unstippled patterns are returned"
	(depth = cachedDepth and: [ depth <= 2 or: [ cachedBitPattern size = 1 ] ]) ifTrue: [ ^ cachedBitPattern ].
	( self isTransparent and: [ cachedBitPattern isNil] )
			 ifTrue: [ cachedBitPattern := Bitmap with: 0 . 
					^ cachedBitPattern ].
	cachedDepth := depth.
	depth > 2 ifTrue: [ ^ cachedBitPattern := Bitmap with: (self pixelWordForDepth: depth) ].
	depth = 1 ifTrue: [ ^ cachedBitPattern := self halfTonePattern1 ].
	depth = 2 ifTrue: [ ^ cachedBitPattern := self halfTonePattern2 ]! !

!Color methodsFor: 'initialization' stamp: ''!
initializeHue: hue saturation: saturation lightness: lightness alpha: anAlpha
	"Initialize this color to the given hue, saturation, and lightness. See the comment in the instance creation method for details."

	| s l hf i f lo hi up dn |
	rgb == nil
		ifFalse: [ self attemptToMutateError ].
	s := saturation asFloat min: 1.0 max: 0.0.
	l := lightness asFloat min: 1.0 max: 0.0.

	"zero saturation yields gray with the given lightness"
	s = 0.0
		ifTrue: [ ^ self initializeRed: l green: l blue: l alpha: anAlpha ].

	hf := hue asFloat \\ 360.0 / 60.0.
	i := hf asInteger.	"integer part of hue"
	f := hf fractionPart.	"fractional part of hue"

	"Color components follow a step function between levels hi & lo with sloped transitions up & dn. Each component is phased according to hue."
	hi := l < 0.5 ifTrue: [(1.0 + s) * l] ifFalse: [l + s - (l * s)].
	lo := 2.0 * l - hi.
	up := (hi - lo) * f + lo.
	dn := (lo - hi) * f + hi.

	0 = i ifTrue: [ ^ self initializeRed: hi green: up blue: lo alpha: anAlpha ].
	1 = i ifTrue: [ ^ self initializeRed: dn green: hi blue: lo alpha: anAlpha ].
	2 = i ifTrue: [ ^ self initializeRed: lo green: hi blue: up alpha: anAlpha ].
	3 = i ifTrue: [ ^ self initializeRed: lo green: dn blue: hi alpha: anAlpha ].
	4 = i ifTrue: [ ^ self initializeRed: up green: lo blue: hi alpha: anAlpha ].
	5 = i ifTrue: [ ^ self initializeRed: hi green: lo blue: dn alpha: anAlpha ].
	self error: 'implementation error'! !

!Color methodsFor: 'private' stamp: ''!
flushCache
	"Flush my cached bit pattern."
	cachedDepth := nil.
	cachedBitPattern := nil! !

!Color methodsFor: 'accessing' stamp: ''!
saturation
	"Return the saturation of this color, a value between 0.0 and 1.0.
	
	Saturation is a scaling of chroma so that the whole [0..1] range is acceptable for any value of brightness/lightness.
	See #hslSaturation and #hsvSaturation; this method returns HSV saturation for compatibility."

	^ self hsvSaturation! !

!Color methodsFor: '*NumericInterpolator' stamp: ''!
interpolateTo: anObject at: t
	| start stop |
	anObject isColor ifFalse: [ ^ anObject interpolateTo: self at: 1 - t  ].
	start := self.
	stop := anObject.
	^ self class
		r: start red + ((stop red - start red) * t)
		g: start green + ((stop green - start green)  * t)
		b: start blue + ((stop blue - start blue) * t)
		alpha: start alpha + ((stop alpha - start alpha) * t)! !

!Color methodsFor: 'private' stamp: ''!
setRed: r green: g blue: b range: range 
	"Initialize this color's r, g, and b components to the given values in the range [0..r]."
	rgb == nil ifFalse: [ self attemptToMutateError ].
	rgb := ((r * ComponentMask // range bitAnd: ComponentMask) bitShift: RedShift) + ((g * ComponentMask // range bitAnd: ComponentMask) bitShift: GreenShift) + (b * ComponentMask // range bitAnd: ComponentMask).
	cachedDepth := nil.
	cachedBitPattern := nil! !

!Color methodsFor: 'wheels' stamp: ''!
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 red mix: Color green shades: 12) inspect"
	| redInc greenInc blueInc out rr gg bb |
	thisMany = 1 ifTrue: [ ^ Array with: color2 ].
	redInc := (color2 red - self red) / (thisMany - 1).
	greenInc := (color2 green - self green) / (thisMany - 1).
	blueInc := (color2 blue - self blue) / (thisMany - 1).
	rr := self red.
	gg := self green.
	bb := self blue.
	out := (1 to: thisMany) collect: 
		[ :num | | c | 
		c := self class 
			r: rr
			g: gg
			b: bb.
		rr := rr + redInc.
		gg := gg + greenInc.
		bb := bb + blueInc.
		c ].
	out 
		at: out size
		put: color2.	"hide roundoff errors"
	^ out! !

!Color methodsFor: '*Morphic-Base' stamp: ''!
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: 'printing' stamp: ''!
printOn: aStream
	| name |
	(name := self name).
	name = #unnamed
		ifFalse: [ 
			^ aStream
				nextPutAll: 'Color ';
				nextPutAll: name ].
	self storeOn: aStream! !

!Color methodsFor: 'wheels' stamp: ''!
darkShades: thisMany
	"Return 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 red darkShades: 12) inspect"

	^ self class black mix: self shades: thisMany! !

!Color methodsFor: 'transformations' stamp: ''!
darker
	"Answer a darker shade of this color."

	^ self adjustBrightness: -0.08! !

!Color methodsFor: 'private' stamp: ''!
privateAlpha
	"Private!! Return the raw alpha value for opaque. Used only for equality testing."

	^ alpha! !

!Color methodsFor: 'other' stamp: ''!
colorForInsets
	^ self! !

!Color methodsFor: 'pixels handling' stamp: ''!
pixelValueForDepth: d 
		 
		"Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths."
	| basicPixelWord |
	( d < 32 and:[ self isTransparent ] ) ifTrue: [ ^ 0 ].
	basicPixelWord := self basicPixelValueForDepth: d.
	^ d < 32 
		ifTrue: [ basicPixelWord ]
		ifFalse: [ (basicPixelWord bitAnd: 16777215) bitOr: (alpha bitShift: 24) ]! !

!Color methodsFor: 'transformations' stamp: ''!
alpha: aFloat 
	"Answer a new Color with the given amount of opacity ('alpha')."

	^ self class r: self red g: self green b: self blue alpha: aFloat! !

!Color methodsFor: 'transformations' stamp: ''!
dansDarker
	"Return a darker shade of the same color.
	An attempt to do better than the current darker method.
	(now obsolete, since darker has been changed to do this. -dew)"
	^ self class 
		h: self hue s: self saturation v: (self brightness - 0.16 max: 0.0)! !

!Color methodsFor: 'initialization' stamp: ''!
initializeRed: r green: g blue: b range: range 
	"Initialize this color's r, g, and b components to the given values in the range [0..r]."
	rgb == nil ifFalse: [ self attemptToMutateError ].
	rgb := ((r * ComponentMask // range bitAnd: ComponentMask) bitShift: RedShift) + ((g * ComponentMask // range bitAnd: ComponentMask) bitShift: GreenShift) + (b * ComponentMask // range bitAnd: ComponentMask).
	cachedDepth := nil.
	cachedBitPattern := nil.
	self setAlpha: 1.0.! !

!Color methodsFor: 'converting' stamp: ''!
asRGBInteger

	^	(self red * 255) asInteger + 
			((self green * 255) asInteger << 8) + 
				((self blue * 255) asInteger << 16)! !

!Color methodsFor: 'queries' stamp: ''!
isTranslucent

	^ alpha < 255! !

!Color methodsFor: 'converting' stamp: ''!
closestPixelValue4
	"Return the nearest approximation to this color for a 4-bit deep Form."
	"fast special cases"
	| bIndex |
	rgb = 0 ifTrue: [ ^ 1 ].	"black"
	rgb = 1073741823 ifTrue: [ ^ 2 ].	"opaque white"
	rgb = self class red privateRGB ifTrue: [ ^ 4 ].
	rgb = self class green privateRGB ifTrue: [ ^ 5 ].
	rgb = self class blue privateRGB ifTrue: [ ^ 6 ].
	rgb = self class cyan privateRGB ifTrue: [ ^ 7 ].
	rgb = self class yellow privateRGB ifTrue: [ ^ 8 ].
	rgb = self class magenta privateRGB ifTrue: [ ^ 9 ].
	bIndex := (self luminance * 8.0) rounded.	"bIndex in [0..8]"
	^ #(1 10 11 12 3 13 14 15 2 ) at: bIndex + 1	"black"	"1/8 gray"	"2/8 gray"	"3/8 gray"	"4/8 gray"	"5/8 gray"	"6/8 gray"	"7/8 gray"	"opaque white"! !

!Color methodsFor: 'transformations' stamp: ''!
quiteBlacker

	^ self alphaMixed: 0.8 with: (ColorRegistry at: #black)! !

!Color methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."! !

!Color methodsFor: '*Roassal3-Colors' stamp: ''!
translucent
	"Make the color transparent"
	^ self alpha: 0.4! !

!Color methodsFor: 'queries' stamp: ''!
isGray
	"Return true if the receiver represents a shade of gray"
	^(self privateRed = self privateGreen) and: [self privateRed = self privateBlue]! !

!Color methodsFor: 'queries' stamp: ''!
isOpaque
	^ alpha = 255! !

!Color methodsFor: 'transformations' stamp: ''!
twiceDarker
	"Answer a significantly darker shade of this color."

	^ self adjustBrightness: -0.15! !

!Color methodsFor: 'transformations' stamp: ''!
twiceLighter
	"Answer a significantly lighter shade of this color."

	^ self adjustSaturation: -0.06 brightness: 0.15! !

!Color methodsFor: 'converting' stamp: ''!
basicPixelValueForDepth: d 
	"Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:"
	"Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component."
	"Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue."
	| rgbBlack val |
	d = 8 ifTrue: [ ^ self closestPixelValue8 ].	"common case"
	d < 8 ifTrue: 
		[ d = 4 ifTrue: [ ^ self closestPixelValue4 ].
		d = 2 ifTrue: [ ^ self closestPixelValue2 ].
		d = 1 ifTrue: [ ^ self closestPixelValue1 ] ].
	rgbBlack := 1.	"closest black that is not transparent in RGB"
	d = 16 ifTrue: 
		[ "five bits per component; top bits ignored"
		val := (((rgb bitShift: -15) bitAnd: 31744) bitOr: ((rgb bitShift: -10) bitAnd: 992)) bitOr: ((rgb bitShift: -5) bitAnd: 31).
		^ val = 0 
			ifTrue: [ rgbBlack ]
			ifFalse: [ val ] ].
	d = 32 ifTrue: 
		[ "eight bits per component; top 8 bits set to all ones (opaque alpha)"
		val := LargePositiveInteger new: 4.
		val 
			at: 3
			put: ((rgb bitShift: -22) bitAnd: 255).
		val 
			at: 2
			put: ((rgb bitShift: -12) bitAnd: 255).
		val 
			at: 1
			put: ((rgb bitShift: -2) bitAnd: 255).
		val 
			at: 4
			put: 255.	"opaque alpha"
		^ val ].
	d = 12 ifTrue: 
		[ "for indexing a color map with 4 bits per color component"
		val := (((rgb bitShift: -18) bitAnd: 3840) bitOr: ((rgb bitShift: -12) bitAnd: 240)) bitOr: ((rgb bitShift: -6) bitAnd: 15).
		^ val = 0 
			ifTrue: [ rgbBlack ]
			ifFalse: [ val ] ].
	d = 9 ifTrue: 
		[ "for indexing a color map with 3 bits per color component"
		val := (((rgb bitShift: -21) bitAnd: 448) bitOr: ((rgb bitShift: -14) bitAnd: 56)) bitOr: ((rgb bitShift: -7) bitAnd: 7).
		^ val = 0 
			ifTrue: [ rgbBlack ]
			ifFalse: [ val ] ].
	self error: 'unknown pixel depth: ' , d printString! !

!Color methodsFor: 'converting' stamp: ''!
contrastingColorAdjustment
	"Answer darker or lighter color depending on the luminance."

	self isTransparent ifTrue: [ ^ self ].
	
	^ self luminance > 0.5
		ifTrue: [ self darker ] 
		ifFalse:  [ self lighter ]! !

!Color class methodsFor: 'instance creation' stamp: ''!
new

	^ self r: 0.0 g: 0.0 b: 0.0! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
defaultColors

	^{ #black. 0. 0. 0.
		#veryVeryDarkGray. 0.125. 0.125. 0.125.
		#veryDarkGray. 0.25. 0.25. 0.25.
		#darkGray. 0.375. 0.375. 0.375.
		#gray. 0.5. 0.5. 0.5.
		#lightGray. 0.625. 0.625. 0.625.
		#veryLightGray. 0.75. 0.75. 0.75.
		#veryVeryLightGray. 0.875. 0.875. 0.875.
		#white. 1.0. 1.0. 1.0.
		}! !

!Color class methodsFor: '*Graphics-Primitives' stamp: ''!
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: '*Graphics-Primitives' stamp: ''!
colorMapIfNeededFrom: sourceDepth to: destDepth
	"Return a colormap for mapping between the given depths, or nil if no colormap is needed."
	"Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!"

	sourceDepth = destDepth ifTrue: [^ nil].  "not needed if depths are the same"

	(sourceDepth >= 16) & (destDepth >= 16) ifTrue: [
		"mapping is done in BitBlt by zero-filling or truncating each color component"
		^ nil].

	^ self cachedColormapFrom: sourceDepth to: destDepth! !

!Color class methodsFor: 'examples' stamp: ''!
wheel: thisMany
	"Return a collection of thisMany colors evenly spaced around the color wheel."
	"(Color wheel: 12) inspect"

	^ self wheel: thisMany saturation: 0.9 brightness: 0.7! !

!Color class methodsFor: '*Graphics-Display Objects' stamp: ''!
colorPaletteForDepth: depth extent: chartExtent
	"Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively."
	"Note: It is slow to build this palette, so it should be cached for quick access."
	"(Color colorPaletteForDepth: 16 extent: 190@60) display"

	| basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps |
	palette := Form extent: chartExtent depth: depth.
	transCaption := 
		(Form extent: 34@9 depth: 1
			fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0)
			offset: 0@0).
	transHt := transCaption height.
	palette fillWhite: (0@0 extent: palette width@transHt).
	palette fillBlack: (0@transHt extent: palette width@1).
	transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0).
	grayWidth := 10.
	startHue := 338.0.
	vSteps := palette height - transHt // 2.
	hSteps := palette width - grayWidth.
	x := 0.
	startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h |
		basicHue := Color h: h asFloat s: 1.0 v: 1.0.
		y := transHt+1.
		0 to: vSteps do: [ :n | | c |
 			c := basicHue mixed: (n asFloat / vSteps asFloat) with: self white.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y := y + 1].
		1 to: vSteps do: [ :n | | c |
 			c := self black mixed: (n asFloat / vSteps asFloat) with: basicHue.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y := y + 1].
		x := x + 1].
	y := transHt + 1.
	1 to: vSteps * 2 do: [ :n | | c |
 		c := self black mixed: (n asFloat / (vSteps*2) asFloat) with: self white.
		palette fill: (x@y extent: 10@1) fillColor: c.
		y := y + 1].
	^ palette! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
defaultColors4

	^{
	#paleRed. 1.0. 0.901. 0.901.
	#palePeach. 1.0. 0.929. 0.835.
	#paleOrange. 0.991. 0.929. 0.843.
	#paleMagenta. 1.0. 0.901. 1.0.
	#paleGreen. 0.874. 1.0. 0.835.
	#paleBuff. 0.995. 0.979. 0.921.
	#paleBlue. 0.87. 0.976. 0.995.
		}! !

!Color class methodsFor: 'instance creation' stamp: ''!
h: hue s: saturation l: lightness
	"Create a color with the given hue, saturation, and lightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and lightness are numbers in [0.0..1.0] where larger values are more saturated or lighter colors. The difference with brightness in the HSV coordinates is that colors go from black at lightness 0, through vivid hues at lightness 0.5, to white at lightness 1. For example, (Color h: 0 s: 1 l: 0.5) is pure red."
	" (Color h: 0 s: 1 l: 0.5) >>> (Color r: 1 g: 0 b:0)"

	^ self
		h: hue
		s: saturation
		l: lightness
		alpha: 1.0! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
red

	^ ColorRegistry at: #red! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
paleYellow

	^ ColorRegistry at: #paleYellow! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
transparent

	^ ColorRegistry at: #transparent! !

!Color class methodsFor: 'instance creation' stamp: ''!
fromRgbTriplet: list
	"Return a color from its RGB components (0 - 1.0 floats)"
	"(Color colorFrom: #(1.0 1.0 1.0)) >>> (Color white)"

	^ self r: list first g: list second b: list last! !

!Color class methodsFor: 'accessing' stamp: ''!
unregisterColorNamed: aName
	"Remove the color named aName from the list of named colors."
	
	ColorRegistry removeKey: aName ifAbsent: nil! !

!Color class methodsFor: '*Graphics-Primitives' stamp: ''!
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: 'accessing - defaults' stamp: ''!
veryDarkGray

	^ ColorRegistry at: #veryDarkGray! !

!Color class methodsFor: 'private - initialization' stamp: ''!
registerColor: aColor named: aName
	ColorRegistry at: aName put: aColor.! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
defaultColors2

	^{	#red. 1.0. 0. 0.
		#yellow. 1.0. 1.0. 0.
		#green. 0. 1.0. 0.
		#cyan. 0. 1.0. 1.0.
		#blue. 0. 0. 1.0.
		#magenta. 1.0. 0. 1.0.
		#brown. 0.6. 0.2. 0.
		#orange. 1.0. 0.6. 0.
		#lightRed. 1.0. 0.8. 0.8.
		
		}! !

!Color class methodsFor: '*System-Settings-Browser' stamp: ''!
settingInputWidgetForNode: aSettingNode
	^ aSettingNode inputWidgetForColor! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
lightOrange

	^ ColorRegistry at: #lightOrange! !

!Color class methodsFor: '*Graphics-Primitives' stamp: ''!
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: 'accessing - defaults' stamp: ''!
brown

	^ ColorRegistry at: #brown! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
tan

	^ ColorRegistry at: #tan! !

!Color class methodsFor: 'instance creation' stamp: ''!
colorFromPixelValue: p depth: d
	"Convert a pixel value for the given display depth into a color."

	"Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color."

	| r g b alpha |
	d = 8 ifTrue: [ ^ IndexedColors at: (p bitAnd: 255) + 1 ].
	d = 4 ifTrue: [ ^ IndexedColors at: (p bitAnd: 15) + 1 ].
	d = 2 ifTrue: [ ^ IndexedColors at: (p bitAnd: 3) + 1 ].
	d = 1 ifTrue: [ ^ IndexedColors at: (p bitAnd: 1) + 1 ].
	d = 16 | (d = 15)
		ifTrue: [ "five bits per component"
			r := (p bitShift: -10) bitAnd: 31.
			g := (p bitShift: -5) bitAnd: 31.
			b := p bitAnd: 31.
			(r = 0 and: [ g = 0 ])
				ifTrue: [ b = 0 ifTrue: [ ^ self transparent ].
					b = 1 ifTrue: [ ^ self black ] ].
			^ self
				r: r
				g: g
				b: b
				range: 31 ].
	d = 32
		ifTrue: [ "eight bits per component; 8 bits of alpha"
			r := (p bitShift: -16) bitAnd: 255.
			g := (p bitShift: -8) bitAnd: 255.
			b := p bitAnd: 255.
			alpha := p bitShift: -24.
			alpha = 0 ifTrue: [ ^ self transparent ].
			^ alpha < 255
				ifTrue: [ (self
						r: r
						g: g
						b: b
						range: 255) alpha: alpha asFloat / 255.0 ]
				ifFalse: [ self
						r: r
						g: g
						b: b
						range: 255 ] ].
	d = 12
		ifTrue: [ "four bits per component"
			r := (p bitShift: -8) bitAnd: 15.
			g := (p bitShift: -4) bitAnd: 15.
			b := p bitAnd: 15.
			^ self
				r: r
				g: g
				b: b
				range: 15 ].
	d = 9
		ifTrue: [ "three bits per component"
			r := (p bitShift: -6) bitAnd: 7.
			g := (p bitShift: -3) bitAnd: 7.
			b := p bitAnd: 7.
			^ self
				r: r
				g: g
				b: b
				range: 7 ].
	self error: 'unknown pixel depth: ', d printString! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
blue

	^ ColorRegistry at: #blue! !

!Color class methodsFor: 'instance creation' stamp: ''!
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)."

	"(Color r: 31 g: 0 b: 0 range: 31) >>> (Color r: 1.0 g: 0 b: 0)"

	^ self basicNew
		initializeRed: r
			green: g
			blue: b
			range: range;
		yourself! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
black

	^ ColorRegistry at: #black! !

!Color class methodsFor: 'class initialization' stamp: ''!
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.
	
	self 
		initializeIndexedColors;
		initializeColorRegistry;
		initializeGrayToIndexMap.
	
	SessionManager default registerGuiClassNamed: self name! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
lightCyan

	^ ColorRegistry at: #lightCyan! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
paleBlue

	^ ColorRegistry at: #paleBlue! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
green

	^ ColorRegistry at: #green! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
paleMagenta

	^ ColorRegistry at: #paleMagenta! !

!Color class methodsFor: 'instance creation' stamp: ''!
r: r g: g b: b alpha: alpha
	"Return a color with the given r, g, and b components in the range [0.0..1.0]."
	
	^ self basicNew
		initializeRed: r green: g blue: b alpha: alpha ;
		yourself! !

!Color class methodsFor: '*Random-Core' stamp: ''!
random
	"Return a random color that isn't too dark or under-saturated."

	^ self 
		h: (360.0 * SharedRandom globalGenerator next)
		s: (0.3 + (SharedRandom globalGenerator next * 0.7))
		v: (0.4 + (SharedRandom globalGenerator next * 0.6))
		alpha: 1.0! !

!Color class methodsFor: '*Graphics-Primitives' stamp: ''!
computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth 
	| map |
	map := (IndexedColors 
		copyFrom: 1
		to: (1 bitShift: sourceDepth)) collect: 
		[ :cc | | f c | 
		f := 1.0 - ((cc red + cc green + cc blue) / 3.0).
		c := targetColor notNil 
			ifTrue: 
				[ destDepth = 32 
					ifTrue: [ targetColor * f alpha: f ]
					ifFalse: 
						[ targetColor 
							alphaMixed: f * 1.5
							with: self white ] ]
			ifFalse: [ cc ].
		destDepth = 32 
			ifTrue: [ c pixelValueForDepth: destDepth ]
			ifFalse: 
				[ f = 0.0 
					ifTrue: [ 0 ]
					ifFalse: [ c pixelValueForDepth: destDepth ] ] ].
	map := map as: Bitmap.
	^ map! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
palePeach

	^ ColorRegistry at: #palePeach! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
orange

	^ ColorRegistry at: #orange! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
veryVeryLightGray

	^ ColorRegistry at: #veryVeryLightGray! !

!Color class methodsFor: '*Graphics-Primitives' stamp: ''!
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: 'accessing - defaults' stamp: ''!
lightGreen

	^ ColorRegistry at: #lightGreen! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
magenta

	^ ColorRegistry at: #magenta! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
paleOrange

	^ ColorRegistry at: #paleOrange! !

!Color class methodsFor: 'accessing' stamp: ''!
registeredNameOf: aColor
	"Return the name of a color if it has a name, else #unnamed"
	
	| colorName |
	colorName := #unnamed.
	ColorRegistry
		keysAndValuesDo: [ :key :value | 
			value = aColor
				ifTrue: [ colorName := key ] ].
	^ colorName! !

!Color class methodsFor: 'private - initialization' stamp: ''!
initializeIndexedColors
	"Build an array of colors corresponding to the fixed colormap used
	 for display depths of 1, 2, 4, or 8 bits."
	"Color initializeIndexedColors"
	| a index grayVal |
	a := Array new: 256.

	"1-bit colors (monochrome)"
	a 
		at: 1
		put: (self 
				r: 1.0
				g: 1.0
				b: 1.0).	"white or transparent"
	a 
		at: 2
		put: (self 
				r: 0.0
				g: 0.0
				b: 0.0).	"black"

	"additional colors for 2-bit color"
	a 
		at: 3
		put: (self 
				r: 1.0
				g: 1.0
				b: 1.0).	"opaque white"
	a 
		at: 4
		put: (self 
				r: 0.5
				g: 0.5
				b: 0.5).	"1/2 gray"

	"additional colors for 4-bit color"
	a 
		at: 5
		put: (self 
				r: 1.0
				g: 0.0
				b: 0.0).	"red"
	a 
		at: 6
		put: (self 
				r: 0.0
				g: 1.0
				b: 0.0).	"green"
	a 
		at: 7
		put: (self 
				r: 0.0
				g: 0.0
				b: 1.0).	"blue"
	a 
		at: 8
		put: (self 
				r: 0.0
				g: 1.0
				b: 1.0).	"cyan"
	a 
		at: 9
		put: (self 
				r: 1.0
				g: 1.0
				b: 0.0).	"yellow"
	a 
		at: 10
		put: (self 
				r: 1.0
				g: 0.0
				b: 1.0).	"magenta"
	a 
		at: 11
		put: (self 
				r: 0.125
				g: 0.125
				b: 0.125).	"1/8 gray"
	a 
		at: 12
		put: (self 
				r: 0.25
				g: 0.25
				b: 0.25).	"2/8 gray"
	a 
		at: 13
		put: (self 
				r: 0.375
				g: 0.375
				b: 0.375).	"3/8 gray"
	a 
		at: 14
		put: (self 
				r: 0.625
				g: 0.625
				b: 0.625).	"5/8 gray"
	a 
		at: 15
		put: (self 
				r: 0.75
				g: 0.75
				b: 0.75).	"6/8 gray"
	a 
		at: 16
		put: (self 
				r: 0.875
				g: 0.875
				b: 0.875).	"7/8 gray"

	"additional colors for 8-bit color"
	"24 more shades of gray (1/32 increments but not repeating 1/8 increments)"
	index := 17.
	1 
		to: 31
		do: 
			[ :v | 
			v \\ 4 = 0 ifFalse: 
				[ grayVal := v / 32.0.
				a 
					at: index
					put: (Color 
							r: grayVal
							g: grayVal
							b: grayVal).
				index := index + 1 ] ].

	"The remainder of color table defines a color cube with six steps
	 for each primary color. Note that the corners of this cube repeat
	 previous colors, but this simplifies the mapping between RGB colors
	 and color map indices. This color cube spans indices 40 through 255
	 (indices 41-256 in this 1-based array)."
	0 
		to: 5
		do: 
			[ :r | 
			0 
				to: 5
				do: 
					[ :g | 
					0 
						to: 5
						do: 
							[ :b | 
							index := 41 + (36 * r + (6 * b) + g).
							index > 256 ifTrue: [ self error: 'index out of range in color table compuation' ].
							a 
								at: index
								put: (self 
										r: r
										g: g
										b: b
										range: 5) ] ] ].
	IndexedColors := a! !

!Color class methodsFor: 'instance creation' stamp: ''!
gray: brightness
	"Return a gray shade with the given brightness in the range [0.0..1.0]."

	^ self r: brightness g: brightness b: brightness! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
white

	^ ColorRegistry at: #white! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
lightBrown

	^ ColorRegistry at: #lightBrown! !

!Color class methodsFor: 'other' stamp: ''!
hex: aFloat
	"Return an hexadecimal two-digits string between 00 and FF
	for a float between 0.0 and 1.0"

	" Color hex: 0.2 >>> '33' "

	| str |
	str := (aFloat * 255) asInteger printStringHex asLowercase.
	^ str size = 1
		ifTrue: [ '0' , str ]
		ifFalse: [ str ]! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
paleGreen

	^ ColorRegistry at: #paleGreen! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
pink

 	^ ColorRegistry at: #pink! !

!Color class methodsFor: '*Graphics-Primitives' stamp: ''!
computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix 
	"Builds a colormap intended to convert from subpixelAA black values to targetColor values.
	keepSubPix
		ifTrue: [ Answer colors that also include subpixelAA ]
		ifFalse: [ 
			Take fullpixel luminance level. Apply it to targetColor.
			I.e. answer colors with NO subpixelAA ]"
	| mask map c bitsPerColor r g b f v |
	destDepth > 8 
		ifTrue: [ bitsPerColor := 5	"retain maximum color resolution" ]
		ifFalse: [ bitsPerColor := 4 ].
	"Usually a bit less is enough, but make it configurable"
	bitsPerColor := bitsPerColor min: self aaFontsColormapDepth.
	mask := (1 bitShift: bitsPerColor) - 1.
	map := Bitmap new: (1 bitShift: 3 * bitsPerColor).
	0 
		to: map size - 1
		do: 
			[ :i | 
			r := (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask.
			g := (i bitShift: 0 - bitsPerColor) bitAnd: mask.
			b := (i bitShift: 0) bitAnd: mask.
			f := 1.0 - ((r + g + b) / 3.0 / mask).
			c := targetColor notNil 
				ifTrue: 
					[ (keepSubPix and: [ destDepth > 8 ]) 
						ifTrue: 
							[ self 
								r: (1.0 - (r / mask)) * targetColor red
								g: (1.0 - (g / mask)) * targetColor green
								b: (1.0 - (b / mask)) * targetColor blue
								alpha: f * targetColor alpha	"alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ]
						ifFalse: 
							[ destDepth = 32 
								ifTrue: [ targetColor * f alpha: f * targetColor alpha ]
								ifFalse: 
									[ targetColor 
										alphaMixed: f * 1.5
										with: self white ] ] ]
				ifFalse: 
					[ self  
						r: r
						g: g
						b: b
						range: mask ].	"This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25"
			v := destDepth = 32 
				ifTrue: [ c pixelValueForDepth: destDepth ]
				ifFalse: 
					[ f < 0.1 
						ifTrue: [ 0 ]
						ifFalse: [ c pixelValueForDepth: destDepth ] ].
			map 
				at: i + 1
				put: v ].
	^ map! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
veryPaleRed

	^ ColorRegistry at: #veryPaleRed! !

!Color class methodsFor: 'examples' stamp: ''!
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 wheel: 12 saturation: 0.4 brightness: 1.0) inspect"
	"(Color wheel: 12 saturation: 0.8 brightness: 0.5) inspect"

	^ (self h: 0.0 s: s v: v) wheel: thisMany! !

!Color class methodsFor: 'other' stamp: ''!
indexedColors

	^ IndexedColors! !

!Color class methodsFor: 'instance creation' stamp: ''!
fromHexString: aColorHex
	"Returns a color instance from HEX (6 element elements)."

	"(Color fromHexString: 'FFFFFF')>>> (Color white) "

	| green red blue alpha hexString |
	hexString := aColorHex withoutPrefix: '#'.
	red := (Integer readFrom: (hexString first: 2) base: 16) / 255.
	green := (Integer readFrom: (hexString copyFrom: 3 to: 4) base: 16) / 255.
	blue := (Integer readFrom: (hexString copyFrom: 5 to: 6) base: 16) / 255.
	
	alpha := hexString size = 8 
		ifFalse: [ 1.0 ]
		ifTrue: [ (Integer readFrom: (hexString copyFrom: 7 to: 8) base: 16) / 255 ].
	
	^ self r: red g: green b: blue alpha: alpha! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
lightYellow

	^ ColorRegistry at: #lightYellow! !

!Color class methodsFor: 'instance creation' stamp: ''!
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."
	"(Color h: 0 s: 1 v: 1) >>> (Color r: 1 g: 0 b:0)"
	
	^ self h: hue s: saturation v: brightness alpha: 1.0! !

!Color class methodsFor: 'accessing' stamp: ''!
named: aColorName
	"Return the color associated with the name aColorName and nil otherwise. Note that only a subsets of colors have a name."

	^ ColorRegistry at: aColorName asSymbol ifAbsent: nil! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
paleBuff

	^ ColorRegistry at: #paleBuff! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
veryLightGray

	^ ColorRegistry at: #veryLightGray! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
defaultColors3

	^{
	#lightYellow. 1.0. 1.0. 0.8.
	#lightGreen. 0.8. 1.0. 0.6.
	#lightCyan. 0.4. 1.0. 1.0.
	#lightBlue. 0.8. 1.0. 1.0.
	#lightMagenta. 1.0. 0.8. 1.0.
	#lightBrown. 1.0. 0.6. 0.2.
	#lightOrange. 1.0. 0.8. 0.4.
	#pink. 1.0. 0.752899. 0.796118.
	#purple. 0.4. 0.0. 0.6.
	#tan. 0.8. 0.8. 0.5.
	#veryPaleRed. 1.0. 0.948. 0.948.
	#paleYellow. 1.0. 1.0. 0.85.
	#paleTan. 0.921. 0.878. 0.78.
	}! !

!Color class methodsFor: 'instance creation' stamp: ''!
r: r g: g b: b
	"Return a color with the given r, g, and b components in the range [0.0..1.0]."
	"(Color r: 1 g: 1 b: 1) >>> Color white"
	
	^ self r: r g: g b: b alpha: 1.0! !

!Color class methodsFor: 'instance creation' stamp: ''!
fromArray: colorDef
	colorDef size = 3
			ifTrue: [^self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)].
	colorDef size = 0
			ifTrue: [^self transparent].
	colorDef size = 4
			ifTrue: [^(self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)) alpha: (colorDef at: 4)].
	self error: 'Undefined color definition'! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
cyan

	^ ColorRegistry at: #cyan! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
lightMagenta

	^ ColorRegistry at: #lightMagenta! !

!Color class methodsFor: 'instance creation' stamp: ''!
fromString: aString
	"Return a color for HTML color spec: #FFCCAA or white/black passed as string."

	"(Color fromString: '#FFCCAA')>>> (Color r: 1.0 g: 0.8 b: 0.667 alpha: 1.0) "
	"(Color fromString: 'orange') >>> Color orange"

	| aColorHex |
	aString isEmptyOrNil
		ifTrue: [ ^ self white ].
	aColorHex := aString first = $#
		ifTrue: [ aString allButFirst ]
		ifFalse: [ aString ].	"Try to match aColorHex with known named colors, case insensitive."
	^ self registeredColorNames
		detect: [ :each | each sameAs: aColorHex ]
		ifFound: [ :namedColor | self named: namedColor ]
		ifNone: [ (aColorHex size = 6 and: [ aColorHex allSatisfy: [ :character | '0123456789ABCDEFabcdef' includes: character ] ])
				ifTrue: [ self fromHexString: aColorHex ]
				ifFalse: [ self white ] ]! !

!Color class methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionColors
	<inspectorPresentationOrder: 10 title: 'Registered'>
	
	^ SpListPresenter new 
		items: ColorRegistry associations;
		display: [ :each | each key ];
		displayIcon: [ :each | 
			Morph new 
				color: each value;
				asFormOfSize: 20@20 ];
		yourself! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
lightBlue

	^ ColorRegistry at: #lightBlue! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
paleTan

	^ ColorRegistry at: #paleTan! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
veryVeryDarkGray

	^ ColorRegistry at: #veryVeryDarkGray! !

!Color class methodsFor: 'instance creation' stamp: ''!
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"
	"Color colorFrom: #(blue darker) >>>  (Color r: 0.0 g: 0.0 b: 0.9198435972629521 alpha: 1.0) "
	"(Color colorFrom: Color blue darker)>>>( (Color r: 0.0 g: 0.0 b: 0.9198435972629521 alpha: 1.0))"
	"(Color colorFrom: #blue)>>> (Color blue)"
	"(Color colorFrom: #(0.0 0.0 1.0)) >>> (Color blue)"

	| 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 class methodsFor: '*Graphics-Primitives' stamp: ''!
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: 'private - colormaps' stamp: ''!
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: 'private - initialization' stamp: ''!
initializeColorRegistry 
	| values|
	ColorRegistry := IdentityDictionary new.
	values := self defaultColors, self defaultColors2, self defaultColors3, self defaultColors4.
	1 to: values size by: #(name r g b) size do:[:index|
		|  colorName red green blue color |
		colorName := values at: index.
		red := values at: index + 1.
		green := values at: index + 2.
		blue := values at: index +3.
		color :=  self  r: red g: green b: blue .
		self registerColor: color named: colorName ].
	self registerColor: (self r: 0 g: 0 b: 0 alpha: 0.0) named: #transparent.! !

!Color class methodsFor: '*Graphics-Primitives' stamp: ''!
computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor 
	"Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component."
	| mask map c |
	(#(3 4 5 ) includes: bitsPerColor) ifFalse: 
		[ self error: 'BitBlt only supports 3, 4, or 5 bits per color component' ].
	mask := (1 bitShift: bitsPerColor) - 1.
	map := Bitmap new: (1 bitShift: 3 * bitsPerColor).
	0 
		to: map size - 1
		do: 
			[ :i | 
			c := self 
				r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask)
				g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask)
				b: ((i bitShift: 0) bitAnd: mask)
				range: mask.
			map 
				at: i + 1
				put: (c pixelValueForDepth: destDepth) ].
	map 
		at: 1
		put: (self transparent pixelWordForDepth: destDepth).	"zero always transparent"
	^ map! !

!Color class methodsFor: 'system startup' stamp: ''!
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: 'private - initialization' stamp: ''!
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: '*Tool-Finder' stamp: ''!
approvedSelectorsForMethodFinder

	^ self selectors! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
purple

 	^ ColorRegistry at: #purple! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
darkGray

	^ ColorRegistry at: #darkGray! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
lightRed

	^ ColorRegistry at: #lightRed! !

!Color class methodsFor: 'instance creation' stamp: ''!
h: hue s: saturation l: lightness alpha: alpha
	"Create a color with the given hue, saturation, lightness, and alpha. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and lightness are numbers in [0.0..1.0] where larger values are more saturated or lighter colors. The difference with brightness in the HSV coordinates is that colors go from black at lightness 0, through vivid hues at lightness 0.5, to white at lightness 1. For example, (Color h: 0 s: 1 l: 0.5) is pure red."
	
	^ self basicNew
		initializeHue: hue
			saturation: saturation
			lightness: lightness
			alpha: alpha;
		yourself! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
gray

	^ ColorRegistry at: #gray! !

!Color class methodsFor: '*STON-Extensions' stamp: ''!
fromSton: stonReader
	| representation |
	representation := stonReader parseMapOrListRepresentation.
	^ representation isArray
		ifTrue: [ 
			self named: representation first ]
		ifFalse: [ 
			(representation includesKey: #rgb)
				ifTrue: [ 
					self basicNew setRGB: (representation at: #rgb); setAlpha: 1.0 "backwards compatibility" ]
				ifFalse: [ 
					self 
						r: (representation at: #red) 
						g: (representation at: #green) 
						b: (representation at: #blue) 
						alpha: (representation at: #alpha) ] ]! !

!Color class methodsFor: 'instance creation' stamp: ''!
h: hue s: saturation v: brightness alpha: alpha
	"Create a color with the given hue, saturation, brightness, and alpha. 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 alpha: 1) is pure red."
	"(Color h: 0 s: 1 v: 1 alpha: 1) >>> Color red "
	
	^ self basicNew
		initializeHue: hue saturation: saturation brightness: brightness alpha: alpha ;
		yourself! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
lightGray

	^ ColorRegistry at: #lightGray! !

!Color class methodsFor: 'accessing' stamp: ''!
registeredColorNames
	"Returns all the available names of named colors."
	
	^ ColorRegistry keys collect: [ :each | each asString ]! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
paleRed

	^ ColorRegistry at: #paleRed! !

!Color class methodsFor: 'accessing - defaults' stamp: ''!
yellow

	 ^ ColorRegistry at: #yellow! !

!ColorArray commentStamp: ''!
An array of colors!
!ColorArray methodsFor: 'accessing' stamp: ''!
at: index put: aColor
	^super at: index put: (aColor pixelWordForDepth: 32).! !

!ColorArray methodsFor: 'accessing' stamp: ''!
at: index
	^(super at: index) asColorOfDepth: 32! !

!ColorArray methodsFor: 'converting' stamp: ''!
asColorArray
	^self! !

!ColorChanged commentStamp: ''!
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: ''!
newColor
	^ newColor! !

!ColorChanged methodsFor: 'accessing' stamp: ''!
newColor: anObject
	newColor := anObject! !

!ColorChanged class methodsFor: 'instance creation' stamp: ''!
to: aColor
	^self new 
		newColor: aColor! !

!ColorChooserMorph commentStamp: ''!
ColorPresenter that opens a colour selector when clicked.!
!ColorChooserMorph methodsFor: 'enablement' stamp: ''!
enabledString
	"Answer the string to be shown in a menu to represent the 'enabled' status"
	
	^ (self enabled) -> 'enabled' translated! !

!ColorChooserMorph methodsFor: 'building' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	enabled := true.
	super initialize! !

!ColorChooserMorph methodsFor: 'updating' stamp: ''!
update: aSymbol 
	"Refer to the comment in View|update:."

	super update: aSymbol.
	aSymbol == self getEnabledSelector ifTrue: 
		[self updateEnabled.
		^ self]! !

!ColorChooserMorph methodsFor: 'menu & halo' stamp: ''!
addToggleItemsToHaloMenu: aCustomMenu 
	"Add toggle-items to the halo menu"
	
	super addToggleItemsToHaloMenu: aCustomMenu.
	aCustomMenu
		addUpdating: #enabledString
		target: self
		selector: #toggleEnabled! !

!ColorChooserMorph methodsFor: 'services' stamp: ''!
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 beOpaque.
	self setColorSelector ifNotNil: [self model perform: self setColorSelector with: newColor]! !

!ColorChooserMorph methodsFor: 'accessing' stamp: ''!
enabled
	"Answer the enabled state of the receiver."
	
	^enabled! !

!ColorChooserMorph methodsFor: 'enablement' stamp: ''!
toggleEnabled
	"Toggle the enabled state."

	self enabled: self enabled not! !

!ColorChooserMorph methodsFor: 'accessing' stamp: ''!
setColorSelector: anObject
	"Set the value of setColorSelector"

	setColorSelector := anObject! !

!ColorChooserMorph methodsFor: 'updating' stamp: ''!
updateEnabled
	"Update the enablement state."

	self model ifNotNil: [
		self getEnabledSelector ifNotNil: [
			self enabled: (self model perform: self getEnabledSelector)]]! !

!ColorChooserMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector
	"Answer the value of getEnabledSelector"

	^ getEnabledSelector! !

!ColorChooserMorph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	"Set the enabled state of the receiver."

	enabled := aBoolean.
	self contentMorph ifNotNil: [:m | m enabled: aBoolean].
	self changed: #enabled! !

!ColorChooserMorph methodsFor: 'instance creation' stamp: ''!
on: anObject color: getColSel changeColor: setColSel
	"Set the receiver to the given model parameterized by the given message selectors."

	self
		on: anObject color: getColSel;
		setColorSelector: setColSel! !

!ColorChooserMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector: anObject
	"Set the value of getEnabledSelector"

	getEnabledSelector := anObject.
	self updateEnabled! !

!ColorChooserMorph methodsFor: 'accessing' stamp: ''!
setColorSelector
	"Answer the value of setColorSelector"

	^ setColorSelector! !

!ColorChooserMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ColorChooserMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ColorChooserMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ColorChooserMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ColorChooserMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ColorChooserMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ColorChooserMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ColorChooserMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ColorChooserMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ColorChooserMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ColorChooserMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ColorChooserMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ColorChooserMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ColorChooserMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ColorChooserMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ColorChooserMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ColorChooserMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ColorChooserMorph class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ (ColorChooserMorph 
		on: (BorderedMorph new) 
		color: #color changeColor: #color:) openInWorld! !

!ColorChooserMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ColorChooserMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ColorChooserMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ColorChooserMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ColorChooserMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ColorChooserMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ColorChooserMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ColorChooserMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ColorChooserMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ColorChooserMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ColorChooserMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ColorChooserMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ColorChooserMorph class methodsFor: 'instance creation' stamp: ''!
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! !

!ColorFillStyle commentStamp: ''!
Simple fillstyle that draws a color at the specified origin with option extent.!
!ColorFillStyle methodsFor: 'testing' stamp: ''!
isOrientedFill
	"Answer true if origin is not nil so that morph movement adjusts origin."
	
	^self origin notNil! !

!ColorFillStyle methodsFor: 'comparing' stamp: ''!
= anObject

	^ super = anObject
		and: [ origin = anObject origin
			and: [ extent = anObject extent ] ]! !

!ColorFillStyle methodsFor: '*Athens-Morphic' stamp: ''!
asAthensPaintOn: anAthensCanvas
	^ (anAthensCanvas surface createSolidColorPaint: color)
		origin: origin;
		extent: extent;
		yourself! !

!ColorFillStyle methodsFor: 'accessing' stamp: ''!
origin
	"Answer the value of origin"

	^ origin! !

!ColorFillStyle methodsFor: 'accessing' stamp: ''!
extent
	"Answer the value of extent"

	^ extent! !

!ColorFillStyle methodsFor: 'accessing' stamp: ''!
origin: anObject
	"Set the value of origin"

	origin := anObject! !

!ColorFillStyle methodsFor: 'operating' stamp: ''!
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: 'accessing' stamp: ''!
extent: anObject
	"Set the value of extent"

	extent := anObject! !

!ColorForm commentStamp: ''!
ColorForm is a normal Form plus a color map of up to 2^depth Colors. Typically, one reserves one entry in the color map for transparent. This allows 1, 3, 15, or 255 non-transparent colors in ColorForms of depths 1, 2, 4, and 8 bits per pixel. ColorForms don't support depths greater than 8 bits because that would require excessively large color maps with little real benefit, since 16-bit and 32-bit depths already support thousands and millions of colors.

ColorForms have several uses:
  1) Precise colors. You can have up to 256 true colors, instead being limited to the 8-bit color palette.
  2) Easy transparency. Just store (Color transparent) at the desired position in the color map.
  3) Cheap color remapping by changing the color map.

A color map is an Array of up to 2^depth Color objects. A Bitmap colorMap is automatically computed and cached for rapid display. Note that if you change the color map, you must resubmit it via the colors: method to flush this cache.

ColorForms can be a bit tricky. Note that:
  a) When you BitBlt from one ColorForm to another, you must remember to copy the color map of the source ColorForm to the destination ColorForm.
  b) A ColorForm's color map is an array of depth-independent Color objects. BitBlt requires a BitMap of actual pixel values, adjusted to the destination depth. These are different things!! ColorForms automatically maintain a cache of the BitBlt-style color map corresponding to the colors array for the last depth on which the ColorForm was displayed, so there should be little need for clients to work with BitBlt-style color maps.
  c) The default map for 8 bit depth has black in the first entry, not transparent.  Say (cform colors at: 1 put: Color transparent).
!
!ColorForm methodsFor: 'pixel accessing' stamp: ''!
colorAt: aPoint put: aColor
	"Store the given color into the pixel at aPoint. The given color must match one of the colors in the receiver's colormap."

	| i |
	i := self colors indexOf: aColor
		ifAbsent: [^ self error: 'trying to use a color that is not in my colormap'].
	self pixelValueAt: aPoint put: i - 1.! !

!ColorForm methodsFor: 'copying' stamp: ''!
copy: aRect
 	"Return a new ColorForm containing the portion of the receiver delineated by aRect."

	| newForm |
	newForm := self class extent: aRect extent depth: depth.
	((BitBlt
		destForm: newForm
		sourceForm: self
		fillColor: nil
		combinationRule: Form over
		destOrigin: 0@0
		sourceOrigin: aRect origin
		extent: aRect extent
		clipRect: newForm boundingBox)
		colorMap: nil) copyBits.
	colors ifNotNil: [newForm colors: colors copy].
	^ newForm! !

!ColorForm methodsFor: 'scaling, rotation' stamp: ''!
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: 'displaying' stamp: ''!
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: 'color manipulation' stamp: ''!
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: 'pixel accessing' stamp: ''!
pixelValueAt: aPoint 
	"Return the raw pixel value at the given point. Typical clients use colorAt: to get a Color."
	"Details: To get the raw pixel value, be sure the peeker's colorMap is nil."

	^ (BitBlt bitPeekerFromForm: self) colorMap: nil; pixelAt: aPoint! !

!ColorForm methodsFor: 'color manipulation' stamp: ''!
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 mapping' stamp: ''!
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: 'accessing' stamp: ''!
colorsFromArray: colorArray
	| colorList |
	colorList := colorArray collect: [:colorDef |
		Color fromArray: colorDef].
	self colors: colorList! !

!ColorForm methodsFor: 'private' stamp: ''!
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: 'color manipulation' stamp: ''!
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: ''!
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: 'copying' stamp: ''!
blankCopyOf: aRectangle scaledBy: scale
	^Form extent: (aRectangle extent * scale) truncated depth: 32! !

!ColorForm methodsFor: 'color manipulation' stamp: ''!
indexOfColor: aColor
	"Return the index of aColor in my color array"

	self ensureColorArrayExists.
	^ colors indexOf: aColor ifAbsent: [0]! !

!ColorForm methodsFor: 'accessing' stamp: ''!
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: 'file in/out' stamp: ''!
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: 'file in/out' stamp: ''!
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: 'color manipulation' stamp: ''!
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: 'testing' stamp: ''!
mightBeTranslucent
	"Answer whether this form may be translucent"
	^true! !

!ColorForm methodsFor: 'color manipulation' stamp: ''!
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: 'testing' stamp: ''!
isTranslucent
	"Answer whether this form may be translucent"
	^true! !

!ColorForm methodsFor: 'private' stamp: ''!
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: 'file in/out' stamp: ''!
hibernate
	"Make myself take up less space. See comment in Form>hibernate."

	super hibernate.
	self clearColormapCache.
	colors ifNotNil:[colors := colors asColorArray].! !

!ColorForm methodsFor: 'pixel accessing' stamp: ''!
colorAt: aPoint
	"Return the color of the pixel at aPoint."

	^ self colors at: (self pixelValueAt: aPoint) + 1! !

!ColorForm methodsFor: 'copying' stamp: ''!
deepCopy

	^ self shallowCopy
		bits: bits copy;
		offset: offset copy;
		colors: colors! !

!ColorForm methodsFor: 'private' stamp: ''!
clearColormapCache

	cachedDepth := nil.
	cachedColormap := nil.! !

!ColorForm methodsFor: 'pixel accessing' stamp: ''!
isTransparentAt: aPoint 
	"Return true if the receiver is transparent at the given point."

	^ (self colorAt: aPoint) isTransparent! !

!ColorForm methodsFor: 'color manipulation' stamp: ''!
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: 'displaying' stamp: ''!
displayOnPort: port at: location

	port copyForm: self to: location rule: Form paint! !

!ColorForm methodsFor: 'copying' stamp: ''!
asCursorForm

	^ (self asFormOfDepth: 32) offset: offset! !

!ColorForm methodsFor: 'testing' stamp: ''!
isColorForm
	^true! !

!ColorForm methodsFor: 'private' stamp: ''!
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: ''!
depth: bitsPerPixel

	bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits'].
	super depth: bitsPerPixel.! !

!ColorForm methodsFor: 'color manipulation' stamp: ''!
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: 'file in/out' stamp: ''!
unhibernate
	colors ifNotNil:[colors := colors asArray].
	^super unhibernate.! !

!ColorForm methodsFor: 'file in/out' stamp: ''!
storeOn: aStream
	aStream nextPut: $(.
	super storeOn: aStream.
	aStream
		cr; tab;
		nextPutAll: 'colorsFromArray: #('.
	self colors do: [:color |
		color storeArrayOn: aStream].
	aStream nextPutAll: ' ))'.! !

!ColorForm methodsFor: 'private' stamp: ''!
unusedColormapEntry
	"Return the index of an unused color map entry, or zero if there isn't one."

	| tallies |
	tallies := self tallyPixelValues.
	1 to: tallies size do: [:i |
		(tallies at: i) = 0 ifTrue: [^ i]].
	^ 0! !

!ColorForm methodsFor: 'accessing' stamp: ''!
colors
	"Return my color palette."

	self ensureColorArrayExists.
	^ colors! !

!ColorForm methodsFor: 'color manipulation' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
extent: extentPoint depth: bitsPerPixel
	"Answer an instance of me with blank bitmap of the given dimensions and depth max 8."
	
	^ bitsPerPixel > 8 
		ifTrue: [ self basicNew setExtent: extentPoint depth: 8]
		ifFalse:  [ self basicNew setExtent: extentPoint depth: bitsPerPixel]! !

!ColorForm class methodsFor: 'instance creation' stamp: ''!
mappingWhiteToTransparentFrom: aFormOrCursor
	"Return a ColorForm copied from the given Form or Cursor with white mapped to transparent."

	| f map |
	aFormOrCursor depth <= 8 ifFalse: [
		^ self error: 'argument depth must be 8-bits per pixel or less'].
	(aFormOrCursor isColorForm) ifTrue: [
		f := aFormOrCursor deepCopy.
		map := aFormOrCursor colors.
	] ifFalse: [
		f := ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth.
		f copyBits: aFormOrCursor boundingBox
			from: aFormOrCursor
			at: 0@0
			clippingBox: aFormOrCursor boundingBox
			rule: Form over
			fillColor: nil.
		map := Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)].
	map := map collect: [:c |
		c = Color white ifTrue: [Color transparent] ifFalse: [c]].
	f colors: map.
	^ f! !

!ColorMap commentStamp: ''!
I'm a transformation of pixel values. I apply up to four masks and shifts 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.!
!ColorMap methodsFor: 'accessing' stamp: ''!
greenShift
	^shifts at: 2! !

!ColorMap methodsFor: 'accessing' stamp: ''!
alphaMask: value
	masks at: 4 put: value! !

!ColorMap methodsFor: 'accessing' stamp: ''!
redShift: value
	shifts at: 1 put: value! !

!ColorMap methodsFor: 'comparing' stamp: ''!
= 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: ''!
hash
	"Hash is re-implemented because #= is re-implemented"
	^colors hash bitXor: (shifts hash bitXor: masks hash)! !

!ColorMap methodsFor: 'private' stamp: ''!
setShifts: shiftArray masks: maskArray colors: colorArray 
	shiftArray ifNotNil: [ shifts := shiftArray asIntegerArray ].
	maskArray ifNotNil: [ masks := maskArray asWordArray ].
	colorArray ifNotNil: [ colors := colorArray asWordArray ]! !

!ColorMap methodsFor: 'accessing' stamp: ''!
alphaMask
	^masks at: 4! !

!ColorMap methodsFor: 'accessing' stamp: ''!
redMask
	^masks at: 1! !

!ColorMap methodsFor: 'accessing' stamp: ''!
redMask: value
	masks at: 1 put: value! !

!ColorMap methodsFor: 'accessing' stamp: ''!
at: index
	^colors at: index! !

!ColorMap methodsFor: 'accessing' stamp: ''!
alphaShift: value
	shifts at: 4 put: value! !

!ColorMap methodsFor: 'testing' stamp: ''!
isIndexed
	"Return true if the receiver uses a lookup mechanism for pixel mapping"
	^colors notNil! !

!ColorMap methodsFor: 'accessing' stamp: ''!
greenShift: value
	shifts at: 2 put: value.! !

!ColorMap methodsFor: 'pixel mapping' stamp: ''!
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: 'accessing' stamp: ''!
shifts
	^shifts! !

!ColorMap methodsFor: 'testing' stamp: ''!
isFixed
	"Return true if the receiver does not use a lookup mechanism for pixel mapping"
	^self isIndexed not! !

!ColorMap methodsFor: 'accessing' stamp: ''!
redShift
	^shifts at: 1! !

!ColorMap methodsFor: 'accessing' stamp: ''!
blueMask
	^masks at: 3! !

!ColorMap methodsFor: 'accessing' stamp: ''!
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: ''!
rgbaBitMasks
	"Return the rgba bit masks for the receiver"
	^masks asArray with: shifts collect:[:m :s| m bitShift: s]! !

!ColorMap methodsFor: 'accessing' stamp: ''!
masks
	^masks! !

!ColorMap methodsFor: 'accessing' stamp: ''!
at: index put: value
	^colors at: index put: value! !

!ColorMap methodsFor: 'accessing' stamp: ''!
blueShift: value
	shifts at: 3 put: value! !

!ColorMap methodsFor: 'testing' stamp: ''!
isColormap
	^true! !

!ColorMap methodsFor: 'accessing' stamp: ''!
greenMask
	^masks at: 2! !

!ColorMap methodsFor: 'pixel mapping' stamp: ''!
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: 'pixel mapping' stamp: ''!
mapPixel: pixelValue 
	"Perform a forward pixel mapping operation"
	| pv |
	(shifts == nil and: [ masks == nil ]) 
		ifFalse: 
			[ pv := (((pixelValue bitAnd: self redMask) bitShift: self redShift) bitOr: ((pixelValue bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pixelValue bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pixelValue bitAnd: self alphaMask) bitShift: self alphaShift)) ]
		ifTrue: [ pv := pixelValue ].
	colors ifNotNil: [ pv := colors at: pv ].
	"Need to check for translucency else Form>>paint goes gaga"
	pv = 0 ifTrue: [ pixelValue = 0 ifFalse: [ pv := 1 ] ].
	^ pv! !

!ColorMap methodsFor: 'accessing' stamp: ''!
greenMask: value
	masks at: 2 put: value! !

!ColorMap methodsFor: 'accessing' stamp: ''!
blueMask: value
	masks at: 3 put: value! !

!ColorMap methodsFor: 'accessing' stamp: ''!
blueShift
	^shifts at: 3! !

!ColorMap methodsFor: 'accessing' stamp: ''!
colors
	^colors! !

!ColorMap methodsFor: 'accessing' stamp: ''!
alphaShift
	^shifts at: 4! !

!ColorMap class methodsFor: 'instance creation' stamp: ''!
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: ''!
shifts: shiftArray masks: maskArray colors: colorArray
	^self new setShifts: shiftArray masks: maskArray colors: colorArray! !

!ColorMap class methodsFor: 'instance creation' stamp: ''!
shifts: shiftArray masks: maskArray
	^self shifts: shiftArray masks: maskArray colors: nil.! !

!ColorMap class methodsFor: 'instance creation' stamp: ''!
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: ''!
colors: colorArray
	^self new setShifts: nil masks: nil colors: colorArray! !

!ColorMap class methodsFor: 'instance creation' stamp: ''!
masks: maskArray shifts: shiftArray
	^self shifts: shiftArray masks: maskArray colors: nil.! !

!ColorMap class methodsFor: 'instance creation' stamp: ''!
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: ''!
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! !

!ColorMappingCanvas commentStamp: ''!
I'm an abstract class which introduce a filter between a drawing request and the final output, handled by #mapColor:

For each potential pixel operation like: source -> op -> output
it introducing a color mapping stage: source -> op -> mapping -> output

Then #mapColor: can be redefined in subclasses to implement more specific behavior. For example:
- ShadowDrawingCanvas will replace the rendered color with the color of shadow (if not transparent).
- AlphaBlendingCanvas will add or intensify alpha of rendered color.

For an easy to understand example see  #drawPolygon:color:borderWidth:borderColor:!
!ColorMappingCanvas methodsFor: 'drawing - rectangles' stamp: ''!
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: 'testing' stamp: ''!
isShadowDrawing
	^myCanvas isShadowDrawing! !

!ColorMappingCanvas methodsFor: 'drawing - support' stamp: ''!
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: ''!
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 - polygons' stamp: ''!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	"Draw the given polygon."
	^myCanvas
		drawPolygon: vertices
		color: aColor
		borderWidth: bw
		borderColor: (self mapColor: bc)! !

!ColorMappingCanvas methodsFor: 'drawing - images' stamp: ''!
stencil: aForm at: aPoint color: aColor
	myCanvas
		stencil: aForm
		at: aPoint
		color: (self mapColor: aColor)! !

!ColorMappingCanvas methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubParagraph: paragraph bounds: bounds color: c
	"Draw the given paragraph"
	myCanvas
		rubParagraph: paragraph
		bounds: bounds
		color: (self mapColor: c)! !

!ColorMappingCanvas methodsFor: 'accessing' stamp: ''!
origin
	^myCanvas origin! !

!ColorMappingCanvas methodsFor: 'accessing' stamp: ''!
depth
	^myCanvas depth! !

!ColorMappingCanvas methodsFor: 'drawing  -text' stamp: ''!
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: 'accessing' stamp: ''!
form
	^myCanvas form! !

!ColorMappingCanvas methodsFor: 'other' stamp: ''!
translateBy: delta clippingTo: aRectangle during: aBlock
	"Set a translation and clipping rectangle only during the execution of aBlock."
	| oldCanvas |
	oldCanvas := myCanvas.
	myCanvas translateBy: delta clippingTo: aRectangle during:[:newCanvas|
		myCanvas := newCanvas.
		aBlock value: self].
	myCanvas := oldCanvas.! !

!ColorMappingCanvas methodsFor: 'drawing - rectangles' stamp: ''!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	"Draw the rectangle using the given attributes"
	myCanvas
		frameAndFillRectangle: r
		fillColor: (self mapColor: fillColor)
		borderWidth: borderWidth
		borderColor: (self mapColor: borderColor)! !

!ColorMappingCanvas methodsFor: 'initialization' stamp: ''!
flush
	myCanvas flush.! !

!ColorMappingCanvas methodsFor: 'private' stamp: ''!
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: 'initialization' stamp: ''!
reset
	myCanvas reset.! !

!ColorMappingCanvas methodsFor: 'drawing - ovals' stamp: ''!
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: 'accessing' stamp: ''!
clipRect
	^myCanvas clipRect! !

!ColorMappingCanvas methodsFor: 'drawing' stamp: ''!
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: 'initialization' stamp: ''!
on: aCanvas
	myCanvas := aCanvas.! !

!ColorMappingCanvas methodsFor: 'accessing' stamp: ''!
extent
	^myCanvas extent! !

!ColorMappingCanvas methodsFor: 'private' stamp: ''!
mapColor: aColor
	^aColor! !

!ColorMappingCanvas methodsFor: 'drawing - support' stamp: ''!
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  -text' stamp: ''!
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: 'drawing - images' stamp: ''!
stencil: aForm at: aPoint sourceRect: aRect color: aColor
	myCanvas
		stencil: aForm
		at: aPoint
		sourceRect: aRect
		color: (self mapColor: aColor)! !

!ColorMappingCanvas methodsFor: 'drawing - support' stamp: ''!
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' stamp: ''!
paragraph: paragraph bounds: bounds color: c
	"Draw the given paragraph"
	myCanvas
		paragraph: paragraph
		bounds: bounds
		color: (self mapColor: c)! !

!ColorMappingCanvas class methodsFor: 'instance creation' stamp: ''!
on: aCanvas
	^self new on: aCanvas! !

!ColorPresenterMorph commentStamp: ''!
Displays a colour with alpha against a white, hatched and black background.!
!ColorPresenterMorph methodsFor: 'accessing' stamp: ''!
labelMorph
	"Answer the value of labelMorph"

	^ labelMorph! !

!ColorPresenterMorph methodsFor: 'accessing' stamp: ''!
solidLabelMorph
	"Answer the value of solidLabelMorph"

	^ solidLabelMorph! !

!ColorPresenterMorph methodsFor: 'accessing' stamp: ''!
labelMorph: anObject
	"Set the value of labelMorph"

	labelMorph := anObject! !

!ColorPresenterMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		borderWidth: 0;
		changeTableLayout;
		labelMorph: self newLabelMorph;
		solidLabelMorph: self newLabelMorph;
		contentMorph: self newContentMorph;
		addMorphBack: self contentMorph! !

!ColorPresenterMorph methodsFor: 'instance creation' stamp: ''!
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: 'instance creation' stamp: ''!
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: 'private' stamp: ''!
hatchForm
	"Answer a form showing a grid hatch pattern."

	^self class hatchForm! !

!ColorPresenterMorph methodsFor: 'accessing' stamp: ''!
contentMorph
	"Answer the value of contentMorph"

	^ contentMorph! !

!ColorPresenterMorph methodsFor: 'accessing' stamp: ''!
contentMorph: anObject
	"Set the value of contentMorph"

	contentMorph := anObject! !

!ColorPresenterMorph methodsFor: 'updating' stamp: ''!
update: aSymbol 
	"Refer to the comment in View|update:."

	aSymbol == self getColorSelector ifTrue: 
		[self updateColor.
		^ self]! !

!ColorPresenterMorph methodsFor: 'instance creation' stamp: ''!
newLabelMorph
	"Answer a new label morph"

	^Morph new! !

!ColorPresenterMorph methodsFor: 'accessing' stamp: ''!
solidLabelMorph: anObject
	"Set the value of solidLabelMorph"

	solidLabelMorph := anObject! !

!ColorPresenterMorph methodsFor: 'accessing' stamp: ''!
setColor: aColor
	"Update the colour of the labels."

	self labelMorph color: aColor.
	self solidLabelMorph color: aColor beOpaque! !

!ColorPresenterMorph methodsFor: 'accessing' stamp: ''!
getColorSelector
	"Answer the value of getColorSelector"

	^ getColorSelector! !

!ColorPresenterMorph methodsFor: 'accessing' stamp: ''!
getColorSelector: anObject
	"Set the value of getColorSelector"

	getColorSelector := anObject! !

!ColorPresenterMorph methodsFor: 'private - layout' stamp: ''!
updateColor
	"Update the color state."

	|col|
	self getColorSelector ifNotNil: [
		col := (self model perform: self getColorSelector) ifNil: [Color transparent].
		self setColor: col]! !

!ColorPresenterMorph methodsFor: 'instance creation' stamp: ''!
on: anObject color: getColSel
	"Set the receiver to the given model parameterized by the given message selectors."

	self
		model: anObject;
		getColorSelector: getColSel;
		updateColor! !

!ColorPresenterMorph class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>

	^ (ColorPresenterMorph on: (BorderedMorph new) color: #color) openInWorld! !

!ColorPresenterMorph class methodsFor: 'graphics constants' stamp: ''!
hatchForm
	"Answer a form showing a grid hatch pattern."

	^HatchForm ifNil: [HatchForm := self newHatchForm]! !

!ColorPresenterMorph class methodsFor: 'graphics constants' stamp: ''!
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: ''!
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! !

!ColorSelectorDialogWindow commentStamp: ''!
Standard dialog for selecting a colour by HSVA colour selector, picking from the screen or editing of values.!
!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
saturation
	"Answer the saturation value of the selected color."

	^(self selectedColor saturation * 255) asInteger! !

!ColorSelectorDialogWindow methodsFor: 'actions' stamp: ''!
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: 'accessing' stamp: ''!
hue
	"Answer the hue value of the selected color."

	^(self selectedColor hue / 359 * 255) asInteger! !

!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
selectedColor
	"Answer the value of selectedColor"

	^ selectedColor! !

!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
hsvaMorph
	"Answer the value of hsvaMorph"

	^ hsvaMorph! !

!ColorSelectorDialogWindow methodsFor: 'actions' stamp: ''!
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)
		minWidth: 40! !

!ColorSelectorDialogWindow methodsFor: 'constants' stamp: ''!
red
	"Answer the red value of the selected color."

	^(self selectedColor red * 255) asInteger! !

!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
brightness
	"Answer the brightness value of the selected color."

	^(self selectedColor brightness * 255) asInteger! !

!ColorSelectorDialogWindow methodsFor: 'coloring' stamp: ''!
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: 'accessing' stamp: ''!
selectedColor: aColor
	"Set the value of selectedColor. Update the color selectors."

	self basicSelectedColor: aColor.
	self hsvaMorph selectedColor: aColor! !

!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
colorSelected: aColor
	"A color has been selected.."

	self basicSelectedColor: aColor! !

!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
alpha: anInteger
	"Set the alpha value of the selected color."

	|c|
	c := self selectedColor.
	self selectedColor: (c alpha: anInteger / 255)! !

!ColorSelectorDialogWindow methodsFor: 'actions' stamp: ''!
newHSVAColorSelectorMorph
	"Answer a hsva color selector."

	^HSVAColorSelectorMorph new
		extent: (40@28) + 152;
		when: #selectedColor send: #colorSelected: to: self! !

!ColorSelectorDialogWindow methodsFor: 'actions' stamp: ''!
defaultLabel
	"Answer the default label for the receiver."

	^'Color Selector' translated! !

!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
alpha
	"Answer the alpha value of the selected color."

	^(self selectedColor alpha * 255) asInteger! !

!ColorSelectorDialogWindow methodsFor: 'coloring' stamp: ''!
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: 'constants' stamp: ''!
blue
	"Answer the blue value of the selected color."

	^(self selectedColor blue * 255) asInteger! !

!ColorSelectorDialogWindow methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	self
		basicSelectedColor: Color blue.
	super initialize.
	self selectedColor: self selectedColor! !

!ColorSelectorDialogWindow methodsFor: 'constants' stamp: ''!
green
	"Answer the green value of the selected color."

	^(self selectedColor green * 255) asInteger! !

!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
hsvaMorph: anObject
	"Set the value of hsvaMorph"

	hsvaMorph := anObject! !

!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
brightness: anInteger
	"Set the brightness value of the selected color."

	|c|
	c := self selectedColor.
	self selectedColor: ((Color h: c hue s: c saturation v: anInteger / 255) alpha: c alpha)! !

!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: ''!
saturation: anInteger
	"Set the saturation value of the selected color."

	|c|
	c := self selectedColor.
	self selectedColor: ((Color h: c hue s: anInteger / 255 v: c brightness) alpha: c alpha)! !

!ColorSelectorDialogWindow methodsFor: 'actions' stamp: ''!
newColorPresenterMorph
	"Answer a color presenter."

	^self
		newColorPresenterFor: self
		getColor: #selectedColor 
		help: 'Shows the selected color' translated! !

!ColorSelectorDialogWindow methodsFor: 'actions' stamp: ''!
pickColor
	"Pick a colour from the screen."

	| p c h |
	h := self activeHand.
	h
		showTemporaryCursor: (self iconNamed: #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: 'accessing' stamp: ''!
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: 'coloring' stamp: ''!
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: 'accessing' stamp: ''!
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: 'actions' stamp: ''!
newColorPickerButtonMorph
	"Answer a button to enable picking of colour."

	^ self
		newButtonFor: self
		getState: nil
		action: #pickColor
		arguments: nil
		getEnabled: nil
		labelForm:
			((self iconNamed: #eyedropperIcon)
				scaledIntoFormOfSize: 16)
		help: 'Pick a color from the screen' translated! !

!ColorTest commentStamp: ''!
SUnit tests for class Color!
!ColorTest methodsFor: 'tests - 32 bit' stamp: ''!
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: 'tests - multiply' stamp: ''!
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: 'tests' stamp: ''!
testColorFrom
	self assert: ((Color colorFrom: #white) asHexString sameAs: 'ffffff').
	self assert: ((Color colorFrom: #(1.0 0.5 0.0)) asHexString sameAs: 'ff8000').
	self assert: ((Color colorFrom: (Color white)) asHexString sameAs: 'ffffff').
	self assert: ((Color colorFrom: '#FF8800') asHexString sameAs: 'ff8800').
	self assert: ((Color colorFrom: '#222222') asHexString sameAs: '222222').! !

!ColorTest methodsFor: 'tests - 32 bit' stamp: ''!
test32BitBlackColorTranformation
	"Solve bug: https://pharo.manuscript.com/f/cases/14619"

	self assert: ((Color black pixelWordForDepth: 32) asColorOfDepth: 32) equals: Color black! !

!ColorTest methodsFor: 'tests' stamp: ''!
testFromString
	self assert: ((Color fromString: '#FF8800') asHexString sameAs: 'ff8800');
		assert: ((Color fromString: 'FF8800') asHexString sameAs: 'ff8800');
		assert: ((Color fromString: 'white') asHexString sameAs: 'ffffff');
		assert: ((Color fromString: 'black') asHexString sameAs: '000000');
		assert: ((Color fromString: nil) asHexString sameAs: 'ffffff');
		assert: ((Color fromString: 'inexistent color') asHexString sameAs: 'ffffff'); "should return white"
		assert: ((Color fromString: 'XXXXXX') asHexString sameAs: 'ffffff'); "not alphanumeric"
		assert: ((Color fromString: '00000000') asHexString 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: 'tests - multiply' stamp: ''!
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: 'tests' stamp: ''!
testAsHexString
	| table aColorString |
	self assert: Color white asHexString equals: 'FFFFFF'.
	self assert: Color red asHexString equals: 'FF0000'.
	self assert: Color black asHexString equals: '000000'.

	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 fromHexString: aColorString) asHexString sameAs: aColorString) ].

	table
		do: [ :each | 
			aColorString := '00' , each , each , '00'.
			self assert: ((Color fromHexString: aColorString) asHexString sameAs: aColorString) ].

	table
		do: [ :each | 
			aColorString := '0000' , each , each.
			self assert: ((Color fromHexString: aColorString) asHexString sameAs: aColorString) ].

	table
		do: [ :each | 
			aColorString := each , each , each , each , each , each.
			self assert: ((Color fromHexString: aColorString) asHexString sameAs: aColorString) ]! !

!ColorTest methodsFor: 'tests - multiply' stamp: ''!
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: 'asserting' stamp: ''!
assertColorrefFor: aColor equals: anInteger
	| colorref |
	colorref := aColor asColorref.
	self
		assert: colorref = anInteger
		description:
			('(<1p>) asColorref was <2s>; should have been <3s>' expandMacrosWith: aColor with: colorref hex with: anInteger hex)! !

!ColorTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^Color! !

!ColorTest methodsFor: 'tests - 32 bit' stamp: ''!
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: 'tests' stamp: ''!
testFromHexString

	| color |
	
	color := Color fromHexString: 'FFFFFF'.
	self assert: color equals: Color white.

	color := Color fromHexString: 'ff0000'.
	self assert: color equals: Color red.

	color := Color fromHexString: '#ff0000'.
	self assert: color equals: Color red.

	color := Color fromHexString: '#FF00FFFF'.
	self assert: color equals: Color magenta.

	color := Color fromHexString: '#FF00FF55'.
	self assert: (color alpha > 0.3 and: [color alpha < 0.4])! !

!ColorTest methodsFor: 'tests' stamp: ''!
testAsColorrefPrimaryColors
"issue 13784 Color>>#asColorref ignores blue"
	self assertColorrefFor: Color black equals: 16r000000;
	assertColorrefFor: Color red equals: 16r0000FF;
	assertColorrefFor: Color green equals: 16r00FF00;
	assertColorrefFor: Color yellow equals: 16r00FFFF;
	assertColorrefFor: Color blue equals: 16rFF0000;
	assertColorrefFor: Color cyan equals: 16rFFFF00;
	assertColorrefFor: Color magenta  equals: 16rFF00FF;
	assertColorrefFor: Color white equals: 16rFFFFFF! !

!CommandLineArguments commentStamp: ''!
The CommandLineArguments represents the arguments passed to the image.
In the following case,

	$PHARO_VM myImage.image --foo bar
	
`CommandLineArguments default` contains {'--foo'. 'bar'}.!
!CommandLineArguments methodsFor: 'accessing' stamp: ''!
optionAt: aString ifAbsent: absentBlock
	^ (aString size = 1)
		ifTrue: [ self shortOptionAt: aString ifAbsent: absentBlock ]
		ifFalse: [ self longOptionAt: aString ifAbsent: absentBlock ]! !

!CommandLineArguments methodsFor: 'testing' stamp: ''!
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: 'accessing' stamp: ''!
allFilesWithExtension: anExtension
	^ self arguments select: [ :arg|
		arg endsWith: anExtension ]! !

!CommandLineArguments methodsFor: 'initialization' stamp: ''!
initialize
	
	| documentPath  |
	
	arguments := OrderedCollection withAll: Smalltalk arguments.
	documentPath := Smalltalk vm documentPath.
	documentPath isEmptyOrNil
		ifFalse: [ arguments addFirst: documentPath ].! !

!CommandLineArguments methodsFor: 'accessing' stamp: ''!
optionAt: aString
	^ self optionAt: aString ifAbsent: [
		Error signal: 'Could not find option ', aString ]! !

!CommandLineArguments methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!CommandLineArguments methodsFor: 'testing' stamp: ''!
commandLineArguments
	"self commandLineArguments"
	
	| documentPath args |
	
	args := OrderedCollection withAll: Smalltalk arguments.
	documentPath := Smalltalk vm documentPath.
	documentPath isEmptyOrNil
		ifFalse: [ args addFirst: documentPath ].
 	^ args.! !

!CommandLineArguments methodsFor: 'initialization' stamp: ''!
initializeWithArguments: aCollection
	super initialize.
	arguments := aCollection.! !

!CommandLineArguments methodsFor: 'accessing' stamp: ''!
optionAt: aString ifPresent: presentBlock
	| option |
	
	option := self optionAt: aString ifAbsent: [ ^ self ].
	^ presentBlock value: option! !

!CommandLineArguments methodsFor: 'testing' stamp: ''!
hasArguments
	^ arguments size > 0! !

!CommandLineArguments methodsFor: 'copying' stamp: ''!
copySubcommand
	"return a new copy of this CommandLine without the first arguments"
	^ self class withArguments: arguments allButFirst! !

!CommandLineArguments methodsFor: 'testing' stamp: ''!
includesSubCommand: aName
	self withFirstArgument: [ :arg|
		arg = aName ifTrue: [ ^ true ]].
	^ false! !

!CommandLineArguments methodsFor: 'accessing' stamp: ''!
argumentAt: index
	^ arguments at: index ! !

!CommandLineArguments methodsFor: 'testing' stamp: ''!
longOptionAt: aString
	^ self longOptionAt: aString ifAbsent: [
		Error signal: 'Could not find long-form option: ', aString  ]! !

!CommandLineArguments methodsFor: 'accessing' stamp: ''!
optionAt: aString ifPresent: presentBlock ifAbsent: absentBlock
	| option |
	option := self optionAt: aString ifAbsent: [ ^ absentBlock value ].
	^ presentBlock value: option! !

!CommandLineArguments methodsFor: 'copying' stamp: ''!
copyWithoutPassword
	^ self class withArguments: (arguments reject: [ :each | each beginsWith: '--deploymentPassword' ])! !

!CommandLineArguments methodsFor: 'testing' stamp: ''!
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: ''!
longOptionAt: aString ifAbsent: absentBlock
	| optionStart |
	optionStart := '--' , aString , '='.
	^ self arguments
		detect: [ :arg | arg beginsWith: optionStart ]
		ifFound: [ :option | (option splitOn: '=') second ]
		ifNone: absentBlock! !

!CommandLineArguments methodsFor: 'testing' stamp: ''!
hasFileWithExtension: aFileExtension
	"return true if the first argument has the given file extension"
	^ self arguments anySatisfy: [ :arg| 
		arg endsWith: aFileExtension].! !

!CommandLineArguments methodsFor: 'testing' stamp: ''!
shortOptionAt: aString
	^ self shortOptionAt: aString ifAbsent: [
		Error signal: 'Could not find short-form option: ', aString  ]! !

!CommandLineArguments methodsFor: 'testing' stamp: ''!
withFirstArgument: aBlock
	self arguments ifEmpty: [ ^ self ].
	^ aBlock value: self arguments first! !

!CommandLineArguments class methodsFor: 'instance creation' stamp: ''!
withArguments: aCollection
	^ self basicNew 
		initializeWithArguments: aCollection;
		yourself! !

!CommandLineArguments class methodsFor: 'instance creation' stamp: ''!
default
	^singleton ifNil: [ singleton := self new ]! !

!CommandLineArgumentsTest commentStamp: ''!
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: 'tests' stamp: ''!
testAllFileTyped
	self assert: (self commandLine allFilesWithExtension: #txt) equals: #('noOpt2.txt' 'opt12.txt').
	self assertEmpty: (self commandLine allFilesWithExtension: #foo)! !

!CommandLineArgumentsTest methodsFor: 'tests' stamp: ''!
testHasFilesTyped
	self assert: (self commandLine hasFileWithExtension: #txt).
	self deny: (self commandLine hasFileWithExtension: #foo)! !

!CommandLineArgumentsTest methodsFor: 'accessing' stamp: ''!
commandLine
	^ commandLine! !

!CommandLineArgumentsTest methodsFor: 'accessing' stamp: ''!
parameters
	^ #('noOpt1' 'noOpt2.txt' 'noOpt3.avi' '--option1' 'opt11' 'opt12.txt' 'opt13.avi' '--option2' '--option3' 'opt31.st' 'opt32' '--option4' '--option5=option5Value' '-o' 'oValue')! !

!CommandLineArgumentsTest methodsFor: 'tests' stamp: ''!
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: ''!
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: ''!
testParameterAt
	self assert: (self commandLine argumentAt: 1) equals: 'noOpt1'.
	self assert: (self commandLine argumentAt: 4) equals: '--option1'.
	self deny: (self commandLine argumentAt: 5) equals: 'foo'.
	self deny: (self commandLine argumentAt: 1) isNil! !

!CommandLineArgumentsTest methodsFor: 'tests' stamp: ''!
testHasParameters
	self assert: (self commandLine hasArguments)! !

!CommandLineArgumentsTest methodsFor: 'tests' stamp: ''!
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: ''!
testAllParameters
	self assertCollection: self commandLine arguments equals: self parameters! !

!CommandLineArgumentsTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	commandLine := CommandLineArguments withArguments: self parameters! !

!CommandLineHandler commentStamp: ''!
A CommandLineHandler is activated by the CommandLine. 

The responsible handler with the highest priority is selected and its instance-side method #activate is invoked.

By default the handlers are selected by their class name. In the following shell invocation the FooHandler is chosen:

	pharo Pharo.image FooHandler

A handler may provide a short name with the class-side #commandName method. If the FooHandler defined #commandName returning 'foo' it would be activated with the following shell invocation:
	
	pharo Pharo.image foo
	
For more sophisticated handler selection the CommandLineHandler should implement the #isResponsibleFor: class-side method. An instance of the current command line options is passed to this method which should then return a boolean.

Between all the responsible handlers the one with the highest #priority is chosen. To change the priority overwrite the class-side accessor.
!
!CommandLineHandler methodsFor: 'accessing - arguments' stamp: ''!
optionAt: aString ifAbsent: absentBlock
	^ self commandLine 
		optionAt: aString ifAbsent: absentBlock! !

!CommandLineHandler methodsFor: 'accessing - arguments' stamp: ''!
hasOption: aString
	^ self commandLine hasOption: aString! !

!CommandLineHandler methodsFor: 'accessing' stamp: ''!
commandName
	^ self class commandName! !

!CommandLineHandler methodsFor: 'printing' stamp: ''!
printHelp
	self stderr
		nextPutAll: self class comment; lf! !

!CommandLineHandler methodsFor: 'accessing - arguments' stamp: ''!
optionAt: aString
	^ self commandLine optionAt: aString! !

!CommandLineHandler methodsFor: 'accessing' stamp: ''!
commandLine
	^ commandLine! !

!CommandLineHandler methodsFor: 'accessing - arguments' stamp: ''!
optionAt: aString ifPresent: absentBlock
	^ self commandLine 
		optionAt: aString ifPresent: absentBlock! !

!CommandLineHandler methodsFor: 'accessing' stamp: ''!
stdout
	^ stdout! !

!CommandLineHandler methodsFor: 'accessing' stamp: ''!
description
	^ self class description! !

!CommandLineHandler methodsFor: 'testing' stamp: ''!
hasArguments
	^ self commandLine hasArguments! !

!CommandLineHandler methodsFor: 'accessing' stamp: ''!
commandLine: aCommandLine 
	commandLine := aCommandLine! !

!CommandLineHandler methodsFor: 'utilities' stamp: ''!
quit
	self exitSuccess! !

!CommandLineHandler methodsFor: 'accessing' stamp: ''!
stderr
	^ stderr! !

!CommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	 self subclassResponsibility! !

!CommandLineHandler methodsFor: 'utilities' stamp: ''!
exitSuccess
	self hasSessionChanged
		ifTrue: [ ^ self ].
	Exit signalSuccess ! !

!CommandLineHandler methodsFor: 'initialization' stamp: ''!
initializeStderr
	"install the line end conversion and initialize the converter"
	stderr := VTermOutputDriver stderr.! !

!CommandLineHandler methodsFor: 'actions' stamp: ''!
help
	"This is a crude default help implementation."
	self printHelp.
	Smalltalk isInteractive 
		ifFalse: [ self exitSuccess ]! !

!CommandLineHandler methodsFor: 'utilities' stamp: ''!
exitFailure: aMessage 
	self hasSessionChanged
		ifTrue: [ ^ self ].
	Exit signalFailure: aMessage ! !

!CommandLineHandler methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	session := Smalltalk session.
	self 
		initializeStdout;
		initializeStderr.
	! !

!CommandLineHandler methodsFor: 'accessing - arguments' stamp: ''!
arguments
	^ self commandLine arguments! !

!CommandLineHandler methodsFor: 'testing' stamp: ''!
hasSessionChanged
	"check whether the session has changed since the commandline handler as been created"

	^ session ~~ Smalltalk session! !

!CommandLineHandler methodsFor: 'accessing' stamp: ''!
allHandlers 
	^ CommandLineHandler allHandlers ! !

!CommandLineHandler methodsFor: 'utilities' stamp: ''!
exitFailure
	 ^ self exitFailure: 'Command line handler failed'! !

!CommandLineHandler methodsFor: 'utilities' stamp: ''!
<< aString
	^ self stdout 
		nextPutAll: aString;
		yourself! !

!CommandLineHandler methodsFor: 'accessing - arguments' stamp: ''!
argumentAt: anInteger
	^ self commandLine argumentAt: anInteger! !

!CommandLineHandler methodsFor: 'initialization' stamp: ''!
initializeStdout
	"install the line end conversion and initialize the converter"
	stdout := VTermOutputDriver stdout.! !

!CommandLineHandler methodsFor: 'activation' stamp: ''!
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: 'activation' stamp: ''!
activateHelpWithoutArguments
	"Default help implementation, running #help if the there is no argument or a single one which is --help "
	((self hasOption: 'help') or: [ self arguments isEmpty ])
		ifTrue: [ 
			self help.
			^ true ].
	^ false! !

!CommandLineHandler methodsFor: 'accessing' stamp: ''!
name
	^ self printString! !

!CommandLineHandler methodsFor: 'accessing - arguments' stamp: ''!
optionAt: aString ifPresent: presentBlock ifAbsent: absentBlock
	^ self commandLine 
		optionAt: aString ifPresent: presentBlock ifAbsent: absentBlock! !

!CommandLineHandler class methodsFor: 'handler selection' stamp: ''!
selectHandlersFor: aCommandLine

	^ self allHandlers select: [ :handlerClass|
		handlerClass isResponsibleFor: aCommandLine ]! !

!CommandLineHandler class methodsFor: 'accessing' stamp: ''!
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: ''!
allHandlers
	^ self allSubclasses reject: [ :handler| handler isAbstract ]! !

!CommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	"This method should return a short one-line description of the command"
	^ nil! !

!CommandLineHandler class methodsFor: 'private' stamp: ''!
prepareSubcommand: commandLineArguments

	"strip the subcommand name from the arguments"
	commandLineArguments withFirstArgument: [ :arg|
		arg = self commandName 
			ifTrue: [ ^ commandLineArguments copySubcommand ]].
	
	"not a subcommand hence we keep the same args"
	^ commandLineArguments! !

!CommandLineHandler class methodsFor: 'instance creation' stamp: ''!
commandLine: aCommandLine 
	
	^ self new 
		commandLine: aCommandLine;
		yourself! !

!CommandLineHandler class methodsFor: 'handler selection' stamp: ''!
priority
	^ 0! !

!CommandLineHandler class methodsFor: 'testing' stamp: ''!
requireDeploymentPassword
	"Here so that we can distinguish user application services command line handlers from usual pharo command line handlers.
	The objective is to be able to filter command line accessible by the user.
	Command line handlers that are not application services can be protected by a password in deployment."

	^ true! !

!CommandLineHandler class methodsFor: 'accessing' stamp: ''!
isAbstract
	^ self = CommandLineHandler! !

!CommandLineHandler class methodsFor: 'handler selection' stamp: ''!
isResponsibleFor: aCommandLineArguments
	^ aCommandLineArguments includesSubCommand: self commandName! !

!CommandLineHandler class methodsFor: 'instance creation' stamp: ''!
activateWith: aCommandLine 
	
	^ self new 
		commandLine: (self prepareSubcommand: aCommandLine);
		activate! !

!CommandLineHandlerTest methodsFor: 'tests' stamp: ''!
testSelectHandlersCodeLoader
	| args handlers |
	args := self argumentsWith: #('/foo/bar/myScript.st').
	handlers := CommandLineHandler selectHandlersFor: args.
	self assert: handlers first equals: STCommandLineHandler.
	
	args := self argumentsWith: #('/foo/bar/myScript.st' '--verbose').
	handlers := CommandLineHandler selectHandlersFor: args.
	self assert: handlers first equals: STCommandLineHandler! !

!CommandLineHandlerTest methodsFor: 'utilities' stamp: ''!
argumentsWith: aCollection
	^ CommandLineArguments withArguments: aCollection! !

!CommandLineHandlerTest methodsFor: 'tests' stamp: ''!
testResponsibilityDefault
	| args |
	args := self argumentsWith: #('--help').
	self assert: (PharoCommandLineHandler isResponsibleFor: args).
	self deny: (STCommandLineHandler isResponsibleFor: args).
	self deny: (EvaluateCommandLineHandler isResponsibleFor: args)! !

!CommandLineHandlerTest methodsFor: 'tests' stamp: ''!
testBasicCommandlineHandler
	
	| args |
	args := self argumentsWith: #().
	"BasicCommandLineHandler gets activated by default on image startup, so there is no need to activate it in a nother case"
	self deny: (BasicCommandLineHandler isResponsibleFor: args).
	"The BasicCommandLineHandler should always delegate to the PharoCommandLineHandler if it is present"
	self 
		assert: BasicCommandLineHandler new selectedHandler
		equals: PharoCommandLineHandler! !

!CommandLineHandlerTest methodsFor: 'tests' stamp: ''!
testResponsibilitySt
	| args |
	args := self argumentsWith: #('/foo/bar/myScript.st').
	self assert: (PharoCommandLineHandler isResponsibleFor: args).
	self assert: (STCommandLineHandler isResponsibleFor: args).
	self deny: (EvaluateCommandLineHandler isResponsibleFor: args).
	
	args := self argumentsWith: #('st' '/foo/bar/myScript.st').
	self assert: (PharoCommandLineHandler isResponsibleFor: args).
	self assert: (STCommandLineHandler isResponsibleFor: args).
	self deny: (EvaluateCommandLineHandler isResponsibleFor: args)! !

!CommandLineHandlerTest methodsFor: 'tests' stamp: ''!
testResponsibilityEval
	| args |
	args := self argumentsWith: #('eval' '1+2').
	self assert: (PharoCommandLineHandler isResponsibleFor: args).
	self deny: (STCommandLineHandler isResponsibleFor: args).
	self assert: (EvaluateCommandLineHandler isResponsibleFor: args).
	
	args := self argumentsWith: #('-e' '1+2').
	self assert: (PharoCommandLineHandler isResponsibleFor: args).
	self deny: (STCommandLineHandler isResponsibleFor: args).
	self assert: (EvaluateCommandLineHandler isResponsibleFor: args).
	
	args := self argumentsWith: #('--evaluate' '1+2').
	self assert: (PharoCommandLineHandler isResponsibleFor: args).
	self deny: (STCommandLineHandler isResponsibleFor: args).
	self assert: (EvaluateCommandLineHandler isResponsibleFor: args)! !

!CommandLinePasswordManager commentStamp: ''!
I provide password management to execute commands through the command line handler. Use public API to define a new password a remove the current one.

The password is not be saved in clear. It is hashed using pepper and iterations.

The pepper of a hash is a fixed string appended to a password to increase the difficulty of finding the password. Also, we hash multiple times (iterations) to increase the strength of the protection.

If you wish to define "application" command lines who does not need a password protection, implement the method #requireDeploymentPassword on the class side to return false.

Examples of password protection
----------------

"Enable password protection"
CommandLinePasswordManager protectCommandLinesByPasswordWith: 'PharoPassword'

"You can also customize the pepper and number of iterations for the hashing of the password."
CommandLinePasswordManager protectCommandLinesByPasswordWith: 'PharoPassword' pepper: 'SomePepper' numberOfHashIterations: 10

"Remove password protection"
CommandLinePasswordManager removePasswordProtection!
!CommandLinePasswordManager methodsFor: 'public' stamp: ''!
protectCommandLinesByPasswordWith: aString pepper: anotherString numberOfHashIterations: aNumber
	"This method enables the password protection of command line. All command lines returning true to #requireDeploymentPassword ask a password to be executed. This is useful in deployment mode of private applications.
	This method accepts a custom pepper for the password hashing. See https://en.wikipedia.org/wiki/Pepper_(cryptography) for more information.
	This method also allows to specify a custom number of hash iterations."
	
	"Before setting the pepper and the number of iterations we set the password hash to nil else it migh raise an error since we cannot change pepper/iterations while a password it set."
	self passwordHash: nil.
	self hashingPepper: anotherString.
	self numberOfHashIterations: aNumber.
	self password: aString! !

!CommandLinePasswordManager methodsFor: 'activation' stamp: ''!
isMatchingPassword: aPassword
	^ (self hashString: aPassword) = self passwordHash! !

!CommandLinePasswordManager methodsFor: 'removing' stamp: ''!
removePasswordProtection
	self passwordHash: nil! !

!CommandLinePasswordManager methodsFor: 'private' stamp: ''!
hashString: password
	| hash |
	hash := self hashingPepper , password.
	(self numberOfHashIterations max: 1) timesRepeat: [ hash := (SHA256 hashMessage: hash) hex ].
	^ hash! !

!CommandLinePasswordManager methodsFor: 'accessing' stamp: ''!
hashingPepper: aString
	self hasPasswordSet ifTrue: [ self error: 'The pepper should not be changed when the password is already saved!! Please, use #removePasswordProtection.' ].
	hashingPepper := aString! !

!CommandLinePasswordManager methodsFor: 'testing' stamp: ''!
hasPasswordSet
	^ self passwordHash isNotNil! !

!CommandLinePasswordManager methodsFor: 'accessing' stamp: ''!
numberOfHashIterations: anObject
	self hasPasswordSet ifTrue: [ self error: 'Number of iterations should not be changed when the password is already saved!! Please, use #removePasswordProtection.' ].
	numberOfHashIterations := anObject! !

!CommandLinePasswordManager methodsFor: 'accessing' stamp: ''!
numberOfHashIterations
	"When the password protection is activated, define the number of times the password is hashed."
	
	^ numberOfHashIterations ifNil: [ numberOfHashIterations := self class defaultNumberOfHashIterations ]! !

!CommandLinePasswordManager methodsFor: 'accessing' stamp: ''!
passwordHash
	"When this variable is not nil, the command lines are protected by a password. The command line needs to begin with the argument '--password=ThePasswordDefinedByTheDev'"
	
	^ passwordHash! !

!CommandLinePasswordManager methodsFor: 'accessing' stamp: ''!
hashingPepper
	"If password protection is enabled, developer should change the pepper used for password  cyphering. (https://en.wikipedia.org/wiki/Pepper_(cryptography))"

	^ hashingPepper ifNil: [ hashingPepper := self class defaultHashingPepper ]! !

!CommandLinePasswordManager methodsFor: 'public' stamp: ''!
password: aString
	self passwordHash: (self hashString: aString)! !

!CommandLinePasswordManager methodsFor: 'accessing' stamp: ''!
passwordHash: aString	
	passwordHash := aString! !

!CommandLinePasswordManager class methodsFor: 'public' stamp: ''!
protectCommandLinesByPasswordWith: aString pepper: anotherString numberOfHashIterations: aNumber
	"This method enables the password protection of command line. All command lines returning true to #requireDeploymentPassword ask a password to be executed. This is useful in deployment mode of private applications.
	This method accepts a custom pepper for the password hashing. See https://en.wikipedia.org/wiki/Pepper_(cryptography) for more information.
	This method also allows to specify a custom number of hash iterations."

	self current protectCommandLinesByPasswordWith: aString pepper: anotherString numberOfHashIterations: aNumber! !

!CommandLinePasswordManager class methodsFor: 'public' stamp: ''!
removePasswordProtection
	self current removePasswordProtection! !

!CommandLinePasswordManager class methodsFor: 'accessing' stamp: ''!
current
	^ Instance ifNil: [ Instance := self new ]! !

!CommandLinePasswordManager class methodsFor: 'accessing' stamp: ''!
defaultHashingPepper
	^ 'Pharo'! !

!CommandLinePasswordManager class methodsFor: 'public' stamp: ''!
protectCommandLinesByPasswordWith: aString pepper: anotherString
	"This method enables the password protection of command line. All command lines returning true to #requireDeploymentPassword ask a password to be executed. This is useful in deployment mode of private applications.
		This method accepts a custom pepper for the password hashing. See https://en.wikipedia.org/wiki/Pepper_(cryptography) for more information."

	self protectCommandLinesByPasswordWith: aString pepper: anotherString numberOfHashIterations: nil! !

!CommandLinePasswordManager class methodsFor: 'public' stamp: ''!
protectCommandLinesByPasswordWith: aString
	"This method enables the password protection of command line. All command lines returning true to #requireDeploymentPassword ask a password to be executed. This is useful in deployment mode of private applications."
	
	self protectCommandLinesByPasswordWith: aString pepper: nil numberOfHashIterations: nil! !

!CommandLinePasswordManager class methodsFor: 'examples' stamp: ''!
exampleEnablePasswordProtection
	self protectCommandLinesByPasswordWith: 'PharoPassword'! !

!CommandLinePasswordManager class methodsFor: 'accessing' stamp: ''!
defaultNumberOfHashIterations
	^ 5! !

!CommandLinePasswordManager class methodsFor: 'examples' stamp: ''!
exampleRemovePasswordProtection
	self removePasswordProtection! !

!CommandLinePasswordManager class methodsFor: 'examples' stamp: ''!
exampleEnablePasswordProtectionCustomized
	self protectCommandLinesByPasswordWith: 'PharoPassword' pepper: 'SomePepper' numberOfHashIterations: 10! !

!CommandLinePasswordManagerTest commentStamp: ''!
A CommandLinePasswordManagerTest is a test class for testing the behavior of CommandLinePasswordManager!
!CommandLinePasswordManagerTest methodsFor: 'tests' stamp: ''!
testIsMatchingPassword
	passwordManager protectCommandLinesByPasswordWith: 'test' pepper: nil numberOfHashIterations: nil.
	self assert: (passwordManager isMatchingPassword: 'test')! !

!CommandLinePasswordManagerTest methodsFor: 'tests' stamp: ''!
testPasswordDoesNotStorePasswordInClear
	passwordManager password: 'test'.
	self deny: passwordManager passwordHash equals: 'test'! !

!CommandLinePasswordManagerTest methodsFor: 'tests' stamp: ''!
testNumberOfHashIterations
	| hashWithOneIteration |
	passwordManager protectCommandLinesByPasswordWith: 'test' pepper: nil numberOfHashIterations: 1.
	hashWithOneIteration := passwordManager passwordHash.
	passwordManager protectCommandLinesByPasswordWith: 'test' pepper: nil numberOfHashIterations: 2.
	self deny: hashWithOneIteration equals: passwordManager passwordHash! !

!CommandLinePasswordManagerTest methodsFor: 'tests' stamp: ''!
testCannotChangeNumberOfIterationsWhenPasswordIsSet
	passwordManager protectCommandLinesByPasswordWith: 'test' pepper: nil numberOfHashIterations: 1.
	self should: [ passwordManager numberOfHashIterations: 2 ] raise: Error! !

!CommandLinePasswordManagerTest methodsFor: 'tests' stamp: ''!
testHashingPepper
	| hashWithPreviousPepper |
	passwordManager protectCommandLinesByPasswordWith: 'test' pepper: 'pepper' numberOfHashIterations: nil.
	hashWithPreviousPepper := passwordManager passwordHash.
	passwordManager protectCommandLinesByPasswordWith: 'test' pepper: 'notSalt' numberOfHashIterations: nil.
	self deny: hashWithPreviousPepper equals: passwordManager passwordHash! !

!CommandLinePasswordManagerTest methodsFor: 'tests' stamp: ''!
testRemovePasswordProtection
	passwordManager protectCommandLinesByPasswordWith: 'test' pepper: nil numberOfHashIterations: nil.
	self assert: passwordManager hasPasswordSet.
	passwordManager removePasswordProtection.
	self deny: passwordManager hasPasswordSet! !

!CommandLinePasswordManagerTest methodsFor: 'tests' stamp: ''!
testHasPasswordSet
	self deny: passwordManager hasPasswordSet.
	passwordManager protectCommandLinesByPasswordWith: 'test' pepper: nil numberOfHashIterations: nil.
	self assert: passwordManager hasPasswordSet! !

!CommandLinePasswordManagerTest methodsFor: 'tests' stamp: ''!
testCannotChangePepperWhenPasswordIsSet
	passwordManager protectCommandLinesByPasswordWith: 'test' pepper: 'test' numberOfHashIterations: nil.
	self should: [ passwordManager hashingPepper: 'test2' ] raise: Error! !

!CommandLinePasswordManagerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	passwordManager := CommandLinePasswordManager new! !

!CommandLineTestRunner commentStamp: ''!
I am command line test runner. I run a TestSuite and outpout the progress in a terminal friendly way.!
!CommandLineTestRunner methodsFor: 'private' stamp: ''!
createStdout
	^ Stdio stdout! !

!CommandLineTestRunner methodsFor: 'running' stamp: ''!
done
	! !

!CommandLineTestRunner methodsFor: 'running' stamp: ''!
tearDown
	self printReport! !

!CommandLineTestRunner methodsFor: 'helper' stamp: ''!
writeError: anError of: aTestCase 
	self
		print: (self shortStackDescriptionFor: anError)
		short: ' [ERROR]' 
		of: aTestCase ! !

!CommandLineTestRunner methodsFor: 'accessing' stamp: ''!
stdout
	(stdout isNil or: [ stdout closed ])
		ifTrue: [ stdout := self createStdout ].
		
	^ stdout! !

!CommandLineTestRunner methodsFor: 'printing' stamp: ''!
printReport
	| cr |
	cr := OSPlatform current lineEnding.
	
	self stderr
		<< cr
		<< 'Finished running ' << maxTest asString  
		<< ' Test' << (maxTest = 1 ifTrue: [''] ifFalse: ['s'])
		<< cr! !

!CommandLineTestRunner methodsFor: 'helper' stamp: ''!
writeFailure: anError of: aTestCase 
	self
		print: (self shortStackDescriptionFor: anError)
		short: ' [FAIL]' 
		of: aTestCase ! !

!CommandLineTestRunner methodsFor: 'helper' stamp: ''!
shortStackDescriptionFor: anError
	^ (String streamContents: [ :s| 
			s << anError printString; cr.
			anError signalerContext shortDebugStackOn: s ])
		copyReplaceAll: String cr
		with: OSPlatform current lineEnding! !

!CommandLineTestRunner methodsFor: 'private' stamp: ''!
createStderr
	^ Stdio stderr! !

!CommandLineTestRunner methodsFor: 'printing' stamp: ''!
printTestCase: aTestCase! !

!CommandLineTestRunner methodsFor: 'helper' stamp: ''!
recordSkip: aTestSkip duringTest: aTestCase 
	self 
		print: nil
		short: ' [SKIPPED]' 
		of: aTestCase! !

!CommandLineTestRunner methodsFor: 'running' stamp: ''!
reportTestCase: aTestCase runBlock: aBlock

	self increaseTestCount.
	self printTestCase: aTestCase.	
	aBlock value! !

!CommandLineTestRunner methodsFor: 'helper' stamp: ''!
increaseTestCount
	currentTest := currentTest + 1.! !

!CommandLineTestRunner methodsFor: 'helper' stamp: ''!
recordPassOf: aTestCase
	self
		print: nil
		short: ' [OK]' 
		of: aTestCase ! !

!CommandLineTestRunner methodsFor: 'helper' stamp: ''!
print: longErrorMessage short: shortErrorMessage of: aTestCase 
	| cr |

	cr := OSPlatform current lineEnding.
	self stdout 
		<< (shortErrorMessage trimBoth padRightTo: 10)
		<< aTestCase printString
		<< cr.
	longErrorMessage isEmptyOrNil 
		ifFalse: [ self stdout << longErrorMessage << cr ]! !

!CommandLineTestRunner methodsFor: 'accessing' stamp: ''!
stderr
	(stderr isNil or: [ stderr closed ])
		ifTrue: [ stderr := self createStderr ].
	^ stderr ! !

!CommandLineTestRunner methodsFor: 'running' stamp: ''!
setUp
	
	currentTest := 0.
	maxTest := suite tests size.! !

!CommandLineUIManager commentStamp: ''!
I am UI manager for a headless setup.
I block all UI manager API that uses Morphs and will trow an error instead.!
!CommandLineUIManager methodsFor: 'default actions' stamp: ''!
unhandledErrorDefaultAction: anException

	self quitFrom: anException signalerContext  withMessage: anException description.
	
	UIManager default == self ifFalse: [
		^ UIManager default unhandledErrorDefaultAction: anException
		]! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
question: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."! !

!CommandLineUIManager methodsFor: 'ui requests' stamp: ''!
choose: questionsAnswerDict title: queryString
! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
deny: aStringOrText title: aString
	"Open a denial dialog."! !

!CommandLineUIManager methodsFor: '*Monticello' stamp: 'nil'!
merge: merger informing: aString
	"Check for conflicts, if there are none, just continue. 
	 Merger will accept all conflicts"
	merger hasConflicts ifFalse: [ ^ self ].
	self abort: aString title: 'Conflict detected'! !

!CommandLineUIManager methodsFor: 'events' stamp: ''!
onPrimitiveError: aString	

	" log error and quit "
	^ self quitFrom: thisContext sender withMessage: aString! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
question: aStringOrText
	"Open a question dialog."! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
abort: aStringOrText title: aString
	
	self logTitle: aString andDescription: aStringOrText to: self stderr.! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
alert: aStringOrText title: aString configure: aBlock
	"Ignore the block, because we don't create a dialog, so there is nothing to configure."

	self alert: aStringOrText title: aString.! !

!CommandLineUIManager methodsFor: 'display' stamp: ''!
restoreDisplay	
	"do nothing"! !

!CommandLineUIManager methodsFor: 'non-interactive' stamp: ''!
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: 'accessing' stamp: ''!
stderr
		
	^ Stdio stderr! !

!CommandLineUIManager methodsFor: 'private' stamp: ''!
activate
	NonInteractiveTranscript stdout install! !

!CommandLineUIManager methodsFor: 'error handling' stamp: ''!
handleError: anError log: shouldLog

	shouldLog ifTrue: [ self logError: anError ].! !

!CommandLineUIManager methodsFor: 'debug' stamp: ''!
debugProcess: process context: context label: title fullView: bool notification: notificationString
	| description |
	description := String streamContents: [ :stream |
		stream
			nextPutAll: 'debugging process: ';
			nextPutAll: process name;
			cr;
			nextPutAll: 'context:';
			cr;
			print: context.
		notificationString ifNotNil: [ stream nextPutAll: notificationString ] ].
	self 
		logTitle: title
		andDescription: description 
		to: self stderr! !

!CommandLineUIManager methodsFor: 'initialization' stamp: ''!
initialize
	doNotQuitOnRestart := false.! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
proceed: aStringOrText
	"Open a proceed dialog."! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
textEntry: aStringOrText
	"Open a text entry dialog."! !

!CommandLineUIManager methodsFor: 'utilities' stamp: ''!
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: 'handle debug requests' stamp: ''!
handleDebugRequest: aDebugRequest fromDebuggerSystem: anOupsDebuggerSystem

	anOupsDebuggerSystem
		logDebugRequest: aDebugRequest
		withUIManager: self! !

!CommandLineUIManager methodsFor: 'accessing' stamp: ''!
stdin

	^ Stdio stdin! !

!CommandLineUIManager methodsFor: 'ui requests' stamp: ''!
systemNotificationDefaultAction: aNotification
	
	Smalltalk logStdOutDuring: [:logger |
		logger nextPutAll: aNotification class name;
				 nextPutAll: ': ';  
				 nextPutAll: aNotification messageText; 
				 cr ].
	
	aNotification resume.
! !

!CommandLineUIManager methodsFor: 'utilities' stamp: ''!
logDuring: aBlock
	
	Smalltalk logStdErrorDuring: [ :stderr | aBlock value: stderr ]

! !

!CommandLineUIManager methodsFor: 'ui requests' stamp: ''!
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 TEasilyThemed' stamp: ''!
questionWithoutCancel: aStringOrText
	"Open a question dialog."! !

!CommandLineUIManager methodsFor: 'private' stamp: ''!
replacing: aUIManager

	" save the aUIManager to restore it later, when we become interactive again "
	
	uiManager := aUIManager.
	
	self beDefault.! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
textEntry: aStringOrText title: aString
	"Open a text entry dialog."! !

!CommandLineUIManager methodsFor: 'utilities' stamp: ''!
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: '*Jobs' stamp: ''!
informUserDuring: aBlock
	self
		displayProgress: ''
		from: 1 to: 100
		during: aBlock! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
questionWithoutCancel: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."! !

!CommandLineUIManager methodsFor: 'accessing' stamp: ''!
stdout
	
	^ Stdio stdout! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
deny: aStringOrText
	"Open a denial dialog."! !

!CommandLineUIManager methodsFor: 'private' stamp: ''!
logTitle: aString andDescription: aStringOrText to: aStream
	
	aStream
		nextPutAll: aString;
		nextPutAll: ': ';
		nextPutAll: aStringOrText asString;
		cr.! !

!CommandLineUIManager methodsFor: 'utilities' stamp: ''!
logYellowDuring: aBlock
	
	^ self logColored: '33' during: aBlock! !

!CommandLineUIManager methodsFor: 'display' stamp: ''!
newDisplayDepthNoRestore: pixelSize	
	"do nothing"
	
! !

!CommandLineUIManager methodsFor: 'utilities' stamp: ''!
logColored: anAnsiiColorCode during: aBlock
	
	Smalltalk logStdErrorDuring: [:stderr |
		stderr
			nextPut: Character escape; 
			nextPut: $[; nextPutAll: anAnsiiColorCode; nextPut: $m.
		
		aBlock value: stderr.
		
		stderr nextPut: Character escape; nextPutAll: '[0m'
	]! !

!CommandLineUIManager methodsFor: 'ui requests' stamp: ''!
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: 'utilities' stamp: ''!
logRedDuring: aBlock
	
	^ self logColored: '31' during: aBlock! !

!CommandLineUIManager methodsFor: 'accessing' stamp: ''!
headlessManager
	self class == CommandLineUIManager 
		ifFalse: [ ^ self ].
		
	^ CommandLineUIManager replacing: uiManager! !

!CommandLineUIManager methodsFor: 'display' stamp: ''!
restoreDisplayAfter: aBlock	
	"do nothing"! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
alert: aStringOrText title: aString

	self logTitle: aString andDescription: aStringOrText to: self stdout.! !

!CommandLineUIManager methodsFor: 'handle debug requests' stamp: ''!
handleWarningDebugRequest: aDebugRequest fromDebuggerSystem: anOupsDebuggerSystem

	anOupsDebuggerSystem
		warningRequest: aDebugRequest
		withUIManager: self! !

!CommandLineUIManager methodsFor: 'ui requests' stamp: ''!
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: ''!
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.! !

!CommandLineUIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString trueChoice: trueLabel falseChoice: falseLabel
	^self
		confirm: queryString
		trueChoice: trueLabel
		falseChoice: falseLabel
		cancelChoice: nil
		default: nil
		! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
alert: aStringOrText

	self abort: aStringOrText title: 'Alert'.! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
proceed: aStringOrText title: aString
	"Open a proceed dialog and answer true if not cancelled, false otherwise."! !

!CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
textEntry: aStringOrText title: aString entryText: defaultEntryText
	"Open a text entry dialog."
! !

!CommandLineUIManager methodsFor: 'ui requests' stamp: ''!
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 TEasilyThemed' stamp: ''!
abort: aStringOrText
	
	self abort: aStringOrText title: 'Error'.! !

!CommandLineUIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString label: title 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: title, ' ', queryString
! !

!CommandLineUIManager methodsFor: 'utilities' stamp: ''!
logGreenDuring: aBlock
	
	^ self logColored: '32' during: aBlock! !

!CommandLineUIManager methodsFor: '*CodeImportCommandLineHandlers' stamp: ''!
syntaxErrorNotificationDefaultAction: aSyntaxErrorNotification
	"log the syntax notification and print a nicely formatted and colored syntax error on stderr"
	Smalltalk logDuring: [ :logger |
		logger print: aSyntaxErrorNotification; cr.
		aSyntaxErrorNotification signalerContext errorReportOn: logger ].
	
	STCommandLineHandler printCompilerWarning: aSyntaxErrorNotification.
			
	"in noninteractive mode simply quit"
	^ self exitFailure! !

!CommandLineUIManager class methodsFor: 'testing' stamp: ''!
isValidForCurrentSystemConfiguration

	^ Smalltalk isHeadless and: [ Smalltalk isInteractive ]! !

!CommandLineUIManager class methodsFor: 'accessing' stamp: ''!
snapshotErrorImage
	^ SnapshotErrorImage == true! !

!CommandLineUIManager class methodsFor: 'settings' stamp: ''!
uiSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #nonInteractive)
		label: 'Headless mode';
		parent: #pharoSystem;
		description: 'Settings related to mode without UI';
		with: [
			(aBuilder setting: #snapshotErrorImage)
				label: 'Snapshot before quitting' ;
				default: false;
				target: CommandLineUIManager;
				description: 'On unhandled exception, save a new version of the image before quitting']! !

!CommandLineUIManager class methodsFor: 'accessing' stamp: ''!
snapshotErrorImage: aBoolean
	SnapshotErrorImage := aBoolean! !

!CommandLineUIManager class methodsFor: 'instance creation' stamp: ''!
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! !

!CommentTestCase commentStamp: ''!
I am a TestCase created from a comment.
To create a new instance you can call one of my factory methods, if you want to understand it better you can look at the example in my class side.
!
!CommentTestCase methodsFor: 'accessing' stamp: ''!
expectedValue
	^ docCommentNode result evaluate! !

!CommentTestCase methodsFor: 'accessing' stamp: ''!
currentValue
	^ docCommentNode expression evaluate! !

!CommentTestCase methodsFor: 'accessing' stamp: ''!
expression
	^ docCommentNode sourceNode contents! !

!CommentTestCase methodsFor: 'tests' stamp: ''!
testIt
	self assert: self expectedValue equals: self currentValue! !

!CommentTestCase methodsFor: 'private' stamp: ''!
instanceVariablesToKeep

	^ #( 'docCommentNode' )! !

!CommentTestCase methodsFor: 'printing' stamp: ''!
printString
	^ docCommentNode sourceNode contents! !

!CommentTestCase methodsFor: 'accessing' stamp: ''!
docCommentNode: aDocComment

	docCommentNode := aDocComment.
	testSelector := #testIt.! !

!CommentTestCase methodsFor: 'accessing' stamp: ''!
drTestsBrowse
 	docCommentNode browse! !

!CommentTestCase class methodsFor: 'instance creation' stamp: ''!
for: aDocComment

	^self new docCommentNode: aDocComment! !

!CommentTestCase class methodsFor: 'accessing' stamp: ''!
testSelectors
	"we remove the selectors to add back later one of them, depending if is is error or not"
	^ super testSelectors \ { #testIt }! !

!CommentsToTestsTest commentStamp: ''!
A DrTestsUITest is a test class for testing the behavior of DrTests-CommentsToTestsTest !
!CommentsToTestsTest methodsFor: 'tests' stamp: ''!
testCommentWithSyntaxError
	"(1+)>>>5"
	
	| docComment commentTestCase |

	docComment := thisContext method ast pharoDocCommentNodes first.
	commentTestCase := CommentTestCase for: docComment.
	
	self should: [commentTestCase testIt] raise: SyntaxErrorNotification! !

!CommentsToTestsTest methodsFor: 'tests' stamp: ''!
testCommentWithFailure
	"(1+3)>>>5"
	
	| docComment commentTestCase |

	docComment := thisContext method ast pharoDocCommentNodes first.
	commentTestCase := CommentTestCase for: docComment.
		
	self should: [commentTestCase testIt] raise: TestFailure! !

!CommentsToTestsTest methodsFor: 'tests' stamp: ''!
testSimpleComment
	"(1+3)>>>4"
	
	| docComment commentTestCase |

	docComment := thisContext method ast pharoDocCommentNodes first.
	commentTestCase := CommentTestCase for: docComment.
		
	self
		assert: commentTestCase currentValue
		equals: commentTestCase expectedValue! !

!CommentsToTestsTest methodsFor: 'tests' stamp: ''!
testErrorComment
	"(1+3)+6/0>>>4"
	
	| docComment commentTestCase |

	docComment := thisContext method ast pharoDocCommentNodes first.
	commentTestCase := CommentTestCase for: docComment.	
	
	self should: [commentTestCase testIt] raise: Error! !

!CommonClassDefinitionPrinterTest commentStamp: ''!
I do not test the factory logic of ClassDefinitionPrinter because it is done in a companion test class.
Here I'm just a way to share code between all the tests.!
!CommonClassDefinitionPrinterTest methodsFor: 'running' stamp: ''!
tearDown

	ClassDefinitionPrinter showFluidClassDefinition: slotUse.
	ClassDefinitionPrinter displayEmptySlots: slotDisplay.
	super tearDown! !

!CommonClassDefinitionPrinterTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	slotUse := ClassDefinitionPrinter showFluidClassDefinition.
	slotDisplay := ClassDefinitionPrinter displayEmptySlots.
	ClassDefinitionPrinter displayEmptySlots: false! !

!CompilationContext commentStamp: ''!
The compilationContext holds all information that is needed in the whole compiler chain.

requestor <Object> usually a textEditor. This can be used to bind editor variables (typically variables local to a workspace/playground) and to properly write error messages inlined.
failBlock <BlockClosure> block with non local return used to abort the compilation (like an exception).
noPattern <Boolean> false if compiling a method which has selector and arguments at the beginning (the so-called pattern) and true if compiling something without selector and arguments (such as a DoIt).
class <Behavior> the behavior in which the code is compiled into (used to know inst var names & methodClass for example)
logged <Boolean> true if the sources will be logged in external logging system (change file, epicea, ...)
interactive <Boolean> Interactive mode is typically used in the IDE (showing errors when compiling code inlined,  pop-ups for some errors/warnings, ...), non-interactive mode is used for headless & code loading to compile code by logging into stdout or Transcript but no interaction required by the user.
options <Set of Symbols> See optionsDescription method comment class side
environment <SystemDictionary> place to look for literal variables (Globals for instance)
!
!CompilationContext methodsFor: 'options' stamp: ''!
optionInlineWhile
	^ options includes: #optionInlineWhile! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
environment
	^ environment ifNil: [ environment := self getClass environment ]! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
compiledMethodClass
	"Return the class used to instantiate the compiled method created by the compiler"
	^ compiledMethodClass ifNil: [ 
		self productionEnvironment
			at: #CompiledMethod
			ifAbsent: [ CompiledMethod ] ]! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
requestorScopeClass: anObject
	"clients can set their own subclass of OCRequestorScope if needed"
	requestorScopeClass := anObject! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
interactive
	^ interactive ifNil: [ false ]! !

!CompilationContext methodsFor: 'plugins' stamp: ''!
astTransformPlugins
	^astTransformPlugins! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
bindings: aCollectionOfAssociations
	"bindings are LiteralVariables, not simple Associations.
	This method receives any collection with Associations or Variables inside and converts those to AdditionalBindings"
	bindings := (aCollectionOfAssociations asDictionary associations
		collect: [ :each | (each isAssociation ifTrue: [ AdditionalBinding key: each key value: each value ] ifFalse: [each])]) asDictionary! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
parserClass
	^ parserClass ifNil: [ parserClass := RBParser ]! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
logged
	^logged ifNil: [ false ].! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
encoderClass
	^ encoderClass ifNil: [ encoderClass := EncoderForSistaV1 ]! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
compiledMethod: anObject
	compiledMethod := anObject! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
failBlock: anObject
	failBlock := anObject! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionCleanBlockClosure
	^ options includes: #optionCleanBlockClosure! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
compiledMethodTrailer
	^ compiledMethodTrailer ifNil: [ compiledMethodTrailer := CompiledMethodTrailer empty ]! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionEmbeddSources
	^ options includes: #optionEmbeddSources! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
requestor
	^ requestor! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionInlineToDo
	^ options includes: #optionInlineToDo! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
noPattern
	^noPattern ifNil: [ false ].! !

!CompilationContext methodsFor: 'initialization' stamp: ''!
initialize
	options := Set new.
	astTransformPlugins := OrderedCollection withAll: self class defaultTransformationPlugins! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
bytecodeGeneratorClass
	^ bytecodeGeneratorClass ifNil: [ bytecodeGeneratorClass := IRBytecodeGenerator ]! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
parserClass: anObject
	parserClass := anObject! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
compiledMethodClass: aCompiledMethodClass
	"Return the class used to instantiate the compiled method created by the compiler"
	
	compiledMethodClass := aCompiledMethodClass! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
interactive: anObject
	interactive := anObject! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionInlineIfNil
	^ options includes: #optionInlineIfNil! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionInlineCase
	^ options includes: #optionInlineCase! !

!CompilationContext methodsFor: 'plugins' stamp: ''!
addASTTransformationPlugin: aPlugin
	astTransformPlugins add: aPlugin! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
compiledMethod
	^ compiledMethod! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
requestor: anObject
	requestor := anObject! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
logged: anObject
	logged := anObject! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
astTranslatorClass
	^ astTranslatorClass ifNil: [ astTranslatorClass := OCASTTranslator ]! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionInlineRepeat
	^ options includes: #optionInlineRepeat! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
semanticAnalyzerClass: anObject
	semanticAnalyzerClass := anObject! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionLongIvarAccessBytecodes
	^ options includes: #optionLongIvarAccessBytecodes! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionParseErrorsNonInteractiveOnly
	^ options includes: #optionParseErrorsNonInteractiveOnly! !

!CompilationContext methodsFor: 'options' stamp: ''!
parseOptions: optionsArray
	options parseOptions: optionsArray! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionInlineTimesRepeat
	^ options includes: #optionInlineTimesRepeat! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionInlineIf
	^ options includes: #optionInlineIf! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
class: anObject
	class := anObject! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionSkipSemanticWarnings
	^ options includes: #optionSkipSemanticWarnings! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
astTranslatorClass: anObject
	astTranslatorClass := anObject! !

!CompilationContext methodsFor: 'options' stamp: ''!
compilerOptions: anArray
	self parseOptions: anArray! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
bindings
	^ bindings! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionInlineAndOr
	^ options includes: #optionInlineAndOr! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
encoderClass: anObject
	encoderClass := anObject! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionInlineNone
	^ options includes: #optionInlineNone! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
semanticAnalyzerClass
	^ semanticAnalyzerClass ifNil: [ semanticAnalyzerClass := OCASTSemanticAnalyzer  ]! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
getClass
	^ class ifNil: [ UndefinedObject ]! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionParseErrors
	^ options includes: #optionParseErrors! !

!CompilationContext methodsFor: 'options' stamp: ''!
setOptions: opts
	options := opts! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
failBlock
	^ failBlock! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
requestorScopeClass
	^ requestorScopeClass ifNil: [ requestorScopeClass := OCRequestorScope ]! !

!CompilationContext methodsFor: 'options' stamp: ''!
optionOptimizeIR
	^ options includes: #optionOptimizeIR! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
productionEnvironment: aDictionary
	productionEnvironment := aDictionary! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
noPattern: anObject
	noPattern := anObject! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
bytecodeGeneratorClass: anObject
	bytecodeGeneratorClass := anObject! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
compiledMethodTrailer: anObject
	compiledMethodTrailer := anObject! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
productionEnvironment
	^productionEnvironment ifNil: [ ^self environment ]! !

!CompilationContext methodsFor: 'accessing' stamp: ''!
scope
	| newScope |

	newScope := self getClass.
	requestor ifNotNil: [
		"the requestor is allowed to manage variables, the workspace is using it to auto-define vars"  
		newScope := (self requestorScopeClass new
			compilationContext: self;
			requestor: requestor) outerScope: newScope].
		
	bindings ifNotNil: [
		"if we passed additional bindings in, setup a scope here"  
		newScope := (OCExtraBindingScope  new
			bindings: bindings) outerScope: newScope].	
		
	^newScope! !

!CompilationContext class methodsFor: 'removing' stamp: ''!
removeDefaultTransformationPlugin: aPlugin
	self defaultTransformationPlugins remove: aPlugin! !

!CompilationContext class methodsFor: 'options' stamp: ''!
cleanOptionString: string
	"Would be nice to put it on String but I don't fancy class extensions..."
	"Takes the option symbol and tries to beautify it  bit for the option menu (Add space, etc.)"
	| ws |
	ws := WriteStream on: (String new: string size + 5).
	string readStreamDo: [ :rs |
		(rs next: 'option' size) = 'option' ifFalse: [ rs reset ].
		ws nextPut: rs next asUppercase.
		[rs peek isUppercase ifTrue: [ rs peekBack isUppercase ifFalse: [ws space] ].
		 ws nextPut: rs next.
		 rs atEnd ] whileFalse ].
	^ ws contents! !

!CompilationContext class methodsFor: 'options' stamp: ''!
compilerSettingsOn: aBuilder
	self optionsDescription withIndexDo: [ :description :index |
		| optionStringCleaned option |
		option := description second.
		optionStringCleaned := self cleanOptionString: option.
		(aBuilder setting: option)
			order: index;
			target: self;
			label: optionStringCleaned;
			description: description third;
			default: (self defaultOptions includes: option).
		 ]! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineToDo: aBoolean
	^ self writeDefaultOption: #optionInlineToDo value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineRepeat
	^ self readDefaultOption: #optionInlineRepeat! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionLongIvarAccessBytecodes
	^ self readDefaultOption: #optionLongIvarAccessBytecodes! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionParseErrorsNonInteractiveOnly
	^ self readDefaultOption: #optionParseErrorsNonInteractiveOnly! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineWhile
	^ self readDefaultOption: #optionInlineWhile! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineRepeat: aBoolean
	^ self writeDefaultOption: #optionInlineRepeat value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineTimesRepeat
	^ self readDefaultOption: #optionInlineTimesRepeat! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineIf
	^ self readDefaultOption: #optionInlineIf! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineIf: aBoolean
	^ self writeDefaultOption: #optionInlineIf value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionSkipSemanticWarnings
	^ self readDefaultOption: #optionSkipSemanticWarnings! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
writeDefaultOption: option value: boolean
	boolean 
		ifTrue: [ self defaultOptions add: option ]
		ifFalse: [ self defaultOptions remove: option ifAbsent: []]! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionParseErrorsNonInteractiveOnly: aBoolean
	^ self writeDefaultOption: #optionParseErrorsNonInteractiveOnly value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineWhile: aBoolean
	^ self writeDefaultOption: #optionInlineWhile value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionCleanBlockClosure: aBoolean
	^ self writeDefaultOption: #optionCleanBlockClosure value: aBoolean! !

!CompilationContext class methodsFor: 'accessing' stamp: ''!
defaultTransformationPlugins
	^ DefaultTransformationPlugins ifNil: [ DefaultTransformationPlugins := OrderedCollection new ]! !

!CompilationContext class methodsFor: 'accessing' stamp: ''!
defaultTransformationPlugins: anObject
	DefaultTransformationPlugins := anObject! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionSkipSemanticWarnings: aBoolean
	^ self writeDefaultOption: #optionSkipSemanticWarnings value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineAndOr
	^ self readDefaultOption: #optionInlineAndOr! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineNone: aBoolean
	^ self writeDefaultOption: #optionInlineNone value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineNone
	^ self readDefaultOption: #optionInlineNone! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionOptimizeIR: aBoolean
	^ self writeDefaultOption: #optionOptimizeIR value: aBoolean! !

!CompilationContext class methodsFor: 'class initialization' stamp: ''!
initialize
	"Note: we don't set-up here DefaultOptions since it requires other class-side methods, and that's messed up."
	DefaultTransformationPlugins := OrderedCollection new! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionCleanBlockClosure
	^ self readDefaultOption: #optionCleanBlockClosure! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionEmbeddSources
	^ self readDefaultOption: #optionEmbeddSources! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineAndOr: aBoolean
	^ self writeDefaultOption: #optionInlineAndOr value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineToDo
	^ self readDefaultOption: #optionInlineToDo! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineIfNil: aBoolean
	^ self writeDefaultOption: #optionInlineIfNil value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionParseErrors
	^ self readDefaultOption: #optionParseErrors! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionEmbeddSources: aBoolean
	^ self writeDefaultOption: #optionEmbeddSources value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionParseErrors: aBoolean
	^ self writeDefaultOption: #optionParseErrors value: aBoolean! !

!CompilationContext class methodsFor: 'options' stamp: ''!
fallBackDefaultOptions
	^ (self optionsDescription collect: [ :each | each allButLast ]) flattened! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineCase: aBoolean
	^ self writeDefaultOption: #optionInlineCase value: aBoolean! !

!CompilationContext class methodsFor: 'options' stamp: ''!
defaultOptions
	^ DefaultOptions ifNil: [ DefaultOptions := Set new parseOptions: self fallBackDefaultOptions ]! !

!CompilationContext class methodsFor: 'adding' stamp: ''!
addDefaultTransformationPlugin: aPlugin
	self defaultTransformationPlugins add: aPlugin! !

!CompilationContext class methodsFor: 'instance creation' stamp: ''!
default 
	^ self new
		setOptions: self defaultOptions copy;
		yourself! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionOptimizeIR
	^ self readDefaultOption: #optionOptimizeIR! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionLongIvarAccessBytecodes: aBoolean
	^ self writeDefaultOption: #optionLongIvarAccessBytecodes value: aBoolean! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineIfNil
	^ self readDefaultOption: #optionInlineIfNil! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineCase
	^ self readDefaultOption: #optionInlineCase! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
optionInlineTimesRepeat: aBoolean
	^ self writeDefaultOption: #optionInlineTimesRepeat value: aBoolean! !

!CompilationContext class methodsFor: 'options' stamp: ''!
optionsDescription
	"Default options are held by DefaultOptions class variable.
	 The description of default options here is only used as a 
	 fall-back if DefaultOptions is not initialized (bootstrap, ...)"
	
	"each entry is fall-back default value (+/-), option name, description"
	^ #(
	(+ optionInlineIf 					'Inline ifTrue:, ifFalse:, ifTrue:ifFalse:, ifFalse:ifTrue: if specific conditions are met (See isInlineIf)')
	(+ optionInlineIfNil 				'Inline ifNil:, ifNotNil:, ifNil:ifNotNil:, ifNotNil:ifNil: if specific conditions are met (See isInlineIfNil)')
	(+ optionInlineAndOr 				'Inline and:, or: if specific conditions are met (See isInlineAndOr)')
	(+ optionInlineWhile 				'Inline whileTrue, whileTrue:, whileFalse:, whileFalse if specific conditions are met (See isInlineWhile)')
	(+ optionInlineToDo 				'Inline to:do:, to:by:do: if specific conditions are met (See isInlineToDo)')
	(+ optionInlineCase 				'Inline caseOf:, caseOf:otherwise: if specific conditions are met (See isInlineCase)')
	(- optionInlineTimesRepeat 		'Inline timesRepeat: if specific conditions are met (See isInlineTimesRepeat)')
	(- optionInlineRepeat 			'Inline repeat if specific conditions are met (See isInlineRepeat)')
	(- optionInlineNone 				'To turn off all inlining options. Overrides the others')
	
	(- optionEmbeddSources         'Embedd sources into CompiledMethod instead of storing in .changes')
	(- optionCleanBlockClosure 			'Compiler compiles closure creation to use CleanBlockClosure instead of FullBlockClosure for clean blocks. Experimental')
	(- optionLongIvarAccessBytecodes 	'Specific inst var accesses to Maybe context objects')
	(+ optionOptimizeIR 					'Rewrite jumps in bytecode in a slightly more efficient way')
	(- optionParseErrors 					'Parse syntactically wrong code (interactive and non-interactive')
	(- optionParseErrorsNonInteractiveOnly 	'Parse syntactically wrong code in non-interactive mode only')
	(- optionSkipSemanticWarnings 		'Do not warn about semantic problems (e.g. undeclared vars). Used for syntax highlight parsing')
		
	)! !

!CompilationContext class methodsFor: 'options - settings API' stamp: ''!
readDefaultOption: option
	^ self defaultOptions includes: option! !

!CompiledBlock commentStamp: ''!
Specific version of compiled code for block's.

CompiledBlock are used only in the recent BlockClosure implementation by Eliot Miranda and Clement Bera, also known as FullBlockClosure. This new representation makes possible heavier runtime optimisations while simplifying a lot of code, both image-side and VM-side.

In addition the execution mechanics, a compiled block have an extra optional literal. The last literal is the compiled code referring to the compiled block. 


!
!CompiledBlock methodsFor: 'properties' stamp: ''!
propertyAt: aString 
	
	^ nil! !

!CompiledBlock methodsFor: 'accessing' stamp: ''!
methodClass
	"answer the compiled method that I am installed in, or nil if none."
	^self outerCode methodClass! !

!CompiledBlock methodsFor: '*OpalCompiler-Core' stamp: ''!
sourceNodeInOuter
	^ self outerCode sourceNodeForPC: self pcInOuter! !

!CompiledBlock methodsFor: 'comparing' stamp: ''!
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.
	"sample approximately 20 bytes"
	initialPC to: endPC by: (endPC - initialPC // 20 max: 1) do:
		[:i| hash := hash + (self at: i)].
	^hash

	"(CompiledMethod>>#hash) hash"! !

!CompiledBlock methodsFor: 'scanning' stamp: ''!
hasMethodReturn
	"Answer whether the receiver has a method-return ('^') in its code."
	^ (InstructionStream on: self) scanFor: [:byte | 
		 self encoderClass methodReturnBytecodes includes: byte]! !

!CompiledBlock methodsFor: 'accessing' stamp: ''!
outerCode
	"answer the compiled code that I am installed in, or nil if none."
	^self literalAt: self numLiterals! !

!CompiledBlock methodsFor: 'accessing' stamp: ''!
outerCode: aCompiledCode
	^self literalAt: self numLiterals put: aCompiledCode! !

!CompiledBlock methodsFor: 'testing' stamp: ''!
isInstalled
	
	^ self method isInstalled! !

!CompiledBlock methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper
	^ aGeneralMapper visitCompiledBlock: self! !

!CompiledBlock methodsFor: 'accessing' stamp: ''!
endPC
	"Answer the index of the last bytecode."
	^ self size! !

!CompiledBlock methodsFor: 'printing' stamp: ''!
displayStringOn: stream
	self printOn: stream! !

!CompiledBlock methodsFor: 'testing' stamp: ''!
isTestMethod
	^ false! !

!CompiledBlock methodsFor: 'printing' stamp: ''!
printOn: anStream
	
	anStream 
		nextPutAll: 'a CompiledBlock: ';
		nextPutAll: self sourceNode sourceCode! !

!CompiledBlock methodsFor: 'testing' stamp: ''!
isEmbeddedBlock
	^ true! !

!CompiledBlock methodsFor: 'debugger support' stamp: ''!
stepIntoQuickMethods
	^self method stepIntoQuickMethods! !

!CompiledBlock methodsFor: 'comparing' stamp: ''!
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: [ ^ false ] ].
	"we can't do = on outer code or it will recursively call this code"
	^ true! !

!CompiledBlock methodsFor: 'testing' stamp: ''!
hasPragmaNamed: aSymbol
	^ false! !

!CompiledBlock methodsFor: 'properties' stamp: ''!
hasProperty: aString 
	
	^ false! !

!CompiledBlock methodsFor: 'accessing' stamp: ''!
primitive
	^ 0! !

!CompiledBlock methodsFor: '*Debugging-Core' stamp: ''!
pcInOuter
	| outer end instructionStream |
	outer := self outerCode.
	instructionStream := InstructionStream on: outer.
	end := outer endPC.
	[instructionStream pc <= end] whileTrue: 
		[ (self encoderClass isCreateFullBlock: self code: outer at: instructionStream pc)
			ifTrue: [ ^ instructionStream pc ].
			instructionStream pc: (instructionStream nextPc: (outer at: instructionStream pc))].
	"scan for clean block"	
	instructionStream := InstructionStream on: outer.
	[instructionStream pc <= end] whileTrue: [
			| literalOffset |
			literalOffset := self encoderClass literalIndexOfBytecodeAt: instructionStream pc in: outer.
			literalOffset ifNotNil: [
				| literal |
				literal := (self outerCode literalAt: literalOffset + 1).
				(literal class == CleanBlockClosure and: [literal compiledBlock = self  ])ifTrue: [ ^ instructionStream pc ].  ].
			instructionStream pc: (instructionStream nextPc: (outer at: instructionStream pc))].	
		
	self error: 'block not installed in outer code'.! !

!CompiledBlock methodsFor: 'literals' stamp: ''!
literalsToSkip

	^ 1! !

!CompiledBlock methodsFor: '*OpalCompiler-Core' stamp: ''!
ast
	^ self sourceNodeInOuter! !

!CompiledBlock methodsFor: 'accessing' stamp: ''!
method
	"answer the compiled method that I am installed in, or nil if none."
	^self outerCode method! !

!CompiledBlock methodsFor: 'accessing' stamp: ''!
methodNode
	^ self outerCode methodNode! !

!CompiledBlock methodsFor: 'testing' stamp: ''!
hasSourceCode
	^ self method hasSourceCode! !

!CompiledBlock methodsFor: 'accessing' stamp: ''!
selector
	^ self outerCode selector! !

!CompiledBlock methodsFor: '*OpalCompiler-Core' stamp: ''!
sourceNode
	^ self sourceNodeInOuter! !

!CompiledBlock methodsFor: 'testing' stamp: ''!
isCompiledBlock
	^ true! !

!CompiledBlock methodsFor: 'debugger support' stamp: ''!
stepIntoQuickMethods: aBoolean
	^self method stepIntoQuickMethods: aBoolean! !

!CompiledBlock methodsFor: '*OpalCompiler-Core' stamp: ''!
sourceNodeForPC: aPC
	| blockNode |
	blockNode := self outerCode sourceNodeForPC: self pcInOuter.
	^blockNode sourceNodeForPC: aPC! !

!CompiledBlock methodsFor: 'compatibility' stamp: ''!
properties
	^ nil->nil! !

!CompiledBlock methodsFor: 'source code management' stamp: ''!
sourcePointer
	^self outerCode sourcePointer! !

!CompiledBlock methodsFor: 'accessing' stamp: ''!
pragmas
	^ #()! !

!CompiledBlock methodsFor: 'accessing' stamp: ''!
sourceCode
	^ self outerCode sourceCode! !

!CompiledCode commentStamp: ''!
My instances (and subinstances) are objects suitable for execution by the virtual machine. My subclasses and I have a specific layout so the instances intermix both indexable pointer fields and indexable integer fields.

	
The current format of a CompiledCode is as follows:

	header (4 bytes)
	literals (4 bytes each)
	bytecodes  (variable)
	trailer (variable)

The header describes the compiled code. It's a small integer with the following format: 

sign bit 	1 bit: 	if set, the method is encoded in the SecondaryBytecodeSet, else in the PrimaryBytecodeSet (See class variables) 
(index 0)	15 bits:	number of literals
(index 16)	1 bit:	requires counters (in the sista JIT, methods marked this way cannot trip)
(index 17)	1 bit:	whether a large frame size is needed
(index 18)	6 bits:	number of temporary variables
(index 24)	4 bits:	number of arguments to the method
(index 28)	1 bit:	has primitive
(index 29)	1 bit:	flag bit, ignored by the VM

The trailer encodes how to fetch the method's sources. See CompiledMethodTrailer.!
!CompiledCode methodsFor: 'accessing' stamp: ''!
methodClass
	self subclassResponsibility! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
localWritesRef: 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: (self encoderClass bindingWriteScanBlockFor: litIndex using: scanner)! !

!CompiledCode methodsFor: 'literals' stamp: ''!
literalAt: index put: value 
	"Replace the literal indexed by the first argument with the second 
	argument. Answer the second argument."

	^self objectAt: index + 1 put: value! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
writesField: varIndex
	"Answer whether the receiver stores into the instance variable indexed by the argument."

	| varIndexCode scanner |
	varIndexCode := varIndex - 1.
	((scanner := InstructionStream on: self) scanFor: (self encoderClass instVarWriteScanBlockFor: varIndexCode using: scanner)) ifTrue: [ ^ true ].
	^ self innerCompiledBlocksAnySatisfy: [ :cb | cb writesField: varIndex ]! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
endPC
	^ self subclassResponsibility! !

!CompiledCode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionPragmas
	<inspectorPresentationOrder: 50 title: 'Pragmas'> 

	^ SpListPresenter new
		items: self pragmas;
		display: [ :aPragma | aPragma printString ];
		yourself! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
isTestMethod
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
originMethod
	^ self methodClass findOriginMethodOf: self method! !

!CompiledCode methodsFor: 'literals' stamp: ''!
hasSelector: selector 
	"Answers true if the method refers to the selector"
	^ self hasSelector: selector specialSelectorIndex: (Smalltalk specialSelectorIndexOrNil: selector)! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
literalsEvenTheOnesInTheInnerBlocks

	| literals numberLiterals |
	literals := OrderedCollection new:
		            (numberLiterals := self numLiterals
		                               - self literalsToSkip).
	1 to: numberLiterals do: [ :index | 
		| lit |
		lit := self literalAt: index.
		lit isEmbeddedBlock
			ifTrue: [ literals addAll: lit literalsEvenTheOnesInTheInnerBlocks ]
			ifFalse: [ literals addLast: lit ] ].
	^ literals asArray! !

!CompiledCode methodsFor: 'initialization' stamp: ''!
needsFrameSize: newFrameSize
	"Set the largeFrameBit to accomodate the newFrameSize"
	(self numTemps + newFrameSize) > LargeFrame ifTrue:
		[^ self error: 'Cannot compile -- stack including temps is too deep'].
	self setFrameBit: ((self numTemps + newFrameSize) > SmallFrame 
		or: [ self primitive = 84 "perform:withArguments:"])! !

!CompiledCode methodsFor: '*Debugging-Core' stamp: ''!
rangeForPC: aPC	
 	"return which code to hightlight in the debugger"		
 	^(self sourceNodeForPC: aPC) debugHighlightRange! !

!CompiledCode methodsFor: 'testing' stamp: ''!
isExternalCallPrimitive
	^self primitive = 120! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
withAllNestedLiteralsDo: aBlockClosure 
	"This method traverses all the nested literals.
	As a Block or Method can have literals in the nested blocks. 
	This is used to query all the selectors used in a method for example"
	
	self withAllBlocksDo: [ :aCompiledCode | 
		aCompiledCode literals do: aBlockClosure ]! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
encoderClass
	^ self signFlag 
		ifTrue: [ SecondaryBytecodeSetEncoderClass ]
		ifFalse: [ PrimaryBytecodeSetEncoderClass ]! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
numTemps
	"Answer the number of temporary variables used by the receiver."
	
	^ (self header bitShift: -18) bitAnd: 16r3F! !

!CompiledCode methodsFor: 'literals' stamp: ''!
innerCompiledBlocksAnySatisfy: aBlock
	self innerCompiledBlocksDo: [ :cb | (aBlock value: cb) ifTrue: [ ^ true ] ].
	^ false! !

!CompiledCode methodsFor: 'literals' stamp: ''!
literalsToSkip

	^ self subclassResponsibility! !

!CompiledCode methodsFor: '*OpalCompiler-Core' stamp: ''!
ast
	^ self subclassResponsibility! !

!CompiledCode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionBytecode
	<inspectorPresentationOrder: 30 title: 'Bytecode'>

	^ SpListPresenter new 
		items: self symbolicBytecodes;
		display: [ :aBytecode | aBytecode printString ];
		yourself
! !

!CompiledCode methodsFor: 'literals' stamp: ''!
literalsDo: aBlock
	"Evaluate aBlock for each of the literals referenced by the receiver."
	1 to: self numLiterals - self literalsToSkip do:
		[:index | aBlock value: (self literalAt: index)]! !

!CompiledCode methodsFor: 'testing' stamp: ''!
usesPrimaryBytecodeSet
	^ self header >= 0! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
hasSourceCode
	^ self subclassResponsibility! !

!CompiledCode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionPragmasContext: aContext 
	
	aContext active: self hasPragmas! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
readsSelf
	"Answer whether compiledMethod reads self, look into embedded blocks, too"
	self isReturnSelf ifTrue: [ ^ true ].
	self localReadsSelf ifTrue: [ ^ true ].
	^ self innerCompiledBlocksAnySatisfy: [ :cb | cb readsSelf]! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
flag
	"Answer the user-level flag bit"

	^((self header bitShift: -29) bitAnd: 1) = 1! !

!CompiledCode methodsFor: 'literals' stamp: ''!
allLiterals
	"Answer an Array of the literals referenced by the receiver.	
	 including superclass + selector/properties"
	| literals numberLiterals |
	literals := Array new: (numberLiterals := self numLiterals).
	1 to: numberLiterals do: [:index |
		literals at: index put: (self objectAt: index + 1)].
	^literals! !

!CompiledCode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
hasPragmas

	^ self pragmas notEmpty! !

!CompiledCode methodsFor: 'testing' stamp: ''!
isCollection
	"We should override it because most of collection methods are not working for CompiledMethod. It is special class which needs to be ByteArray by VM. But it is not behaves like ByteArray from user perspective.
	And some tools uses isCollection check for specific behaviour which will fail for CompiledMethod"
	^false! !

!CompiledCode methodsFor: '*RPackage-Core' stamp: ''!
package
	^ self packageFromOrganizer: RPackage organizer! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
pragmas
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'comparing' stamp: ''!
equivalentTo: aCompiledMethod
	^self = aCompiledMethod
	or: [self class == aCompiledMethod class
		and: [self numArgs = aCompiledMethod numArgs
		and: [self numLiterals = aCompiledMethod numLiterals
		and: [self methodNode = aCompiledMethod methodNode ]]]]! !

!CompiledCode methodsFor: 'comparing' stamp: ''!
= aCompiledMethod
	"Answer whether the receiver implements the same code as aCompiledMethod."

	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! !

!CompiledCode methodsFor: '*Debugging-Core' stamp: ''!
localMessages
	"Answer a Set of all the message selectors sent by this method."

	| scanner aSet |
	aSet := IdentitySet new.
	scanner := InstructionStream on: self.
	scanner	scanFor: [:x | 
			scanner addSelectorTo: aSet.
			false	"keep scanning"].
	^aSet! !

!CompiledCode methodsFor: 'printing' stamp: ''!
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"

	^ SourceFiles timeStampAt: self sourcePointer.! !

!CompiledCode methodsFor: 'literals' stamp: ''!
indexOfLiteral: literal
	"Answer the literal index of the argument, literal, or zero if none."
	1 to: self numLiterals - self literalsToSkip "exclude superclass + selector/properties"
	   do:
		[:index |
		literal == (self literalAt: index) ifTrue: [^index]].
	^0! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
signFlag
	"Answer the sign flag bit.  The sign flag bit may be
	 used by the VM to select an alternate bytecode set."

	^ self header < 0! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
writesSlot: aSlot
	^aSlot isWrittenIn: self! !

!CompiledCode methodsFor: 'literals' stamp: ''!
sendsSelector: aSymbol 	
	"Answer whether the method sends a particular selector"
	^ self messages includes: aSymbol! !

!CompiledCode methodsFor: '*OpalCompiler-Core' stamp: ''!
compilerClass
	^self methodClass 
		ifNil: [Smalltalk compilerClass] 
		ifNotNil: [:class | class compilerClass].! !

!CompiledCode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionItemsContext: aContext

	"Disable items view on compiled code"
	aContext active: false! !

!CompiledCode methodsFor: 'debugger support' stamp: ''!
stepIntoQuickMethods
	^self propertyAt: #stepIntoQuickMethod ifAbsent: [ false ]! !

!CompiledCode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionSource
	<inspectorPresentationOrder: 20 title: 'Source'>
	
	^ SpCodePresenter new 
		beForBehavior: self methodClass;
		text: self sourceCode;
		contextMenu: (SpMenuPresenter new addGroup: [ :group | group 
			addItem: [ :item | item 
				name: 'Browse method class'; 
				action: [ self methodClass browse ] ] ]);
		whenSubmitDo: [ :text | 
			self isInstalled 
				ifFalse: [ self inform: 'can not edit methods that are not installed' ]
				ifTrue: [ self methodClass compile: text ]];
		yourself! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
propertyAt: aString ifAbsent: aFullBlockClosure
	^ aFullBlockClosure value! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
numLiterals
	"Answer the number of literals used by the receiver."
	^self header bitAnd: 16r7FFF! !

!CompiledCode methodsFor: 'comparing' stamp: ''!
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"
								"don't create properties if they don't exist"
								(literal1 isSymbol and: [ literal2 isSymbol ]) 
									ifTrue: [ ^ false ]
									ifFalse: [
										(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 isAssociation
	                ifTrue: [literal1 key = literal2 key and: [literal1 value = literal2 value]]
	                ifFalse: [literal1 = literal2]]! !

!CompiledCode methodsFor: 'literals' stamp: ''!
objectAt: index put: value 
	"Primitive. Store the value argument into a literal in the receiver. An 
	index of 2 corresponds to the first literal. Fails if the index is less than 2 
	or greater than the number of literals. Answer the value as the result. 
	Normally only the compiler sends this message, because only the 
	compiler stores values in CompiledMethods. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 69>
	self primitiveFailed! !

!CompiledCode methodsFor: 'testing' stamp: ''!
localSendsAnySelectorOf: aCollection
	
	self literalsDo: [ :lit |
		(lit isSymbol and: [ aCollection includes: lit ]) 
			ifTrue: [ ^ self messages includesAny: aCollection ]
	].

	^ false! !

!CompiledCode methodsFor: 'printing' stamp: ''!
longPrintOn: aStream
	"List of all the byte codes in a method with a short description of each" 

	self isQuick ifTrue: 
		[self isReturnSpecial ifTrue:
			[^ aStream 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: [
		self printPrimitiveOn: aStream.
	].
	self symbolicBytecodes do: [ :each | each printOn: aStream ] separatedBy: [ aStream cr ]! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
withAllBlocks
	| all |
	all := IdentitySet new.
	self withAllBlocksDo: [ :each | all add: each ].
	^all! !

!CompiledCode methodsFor: '*Debugging-Core' stamp: ''!
localHasInstVarRef
	"Answer whether the method references an instance variable."

	
	^ InstVarRefLocator check: self! !

!CompiledCode methodsFor: 'printing' stamp: ''!
symbolic
	"Answer a String that contains a list of all the byte codes in a method with a short description of each."

	^self longPrintString.! !

!CompiledCode methodsFor: 'source code management' stamp: ''!
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]].
	^''! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
readsField: varIndex 
	"Answer whether the receiver loads the instance variable indexed by the argument."
	| varIndexCode scanner |
	varIndexCode := varIndex - 1.
	((scanner := InstructionStream on: self) scanFor: (self encoderClass instVarReadScanBlockFor: varIndexCode using: scanner)) ifTrue: [ ^ true ].
	^ self innerCompiledBlocksAnySatisfy: [ :cb | cb readsField: varIndex ]! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
localReadsSelf
	^ self encoderClass readsSelfFor: self! !

!CompiledCode methodsFor: '*Debugging-Core' stamp: ''!
symbolicBytecodes
	"Answer Collection that contains of all the byte codes in a method as an instance of SymbolicInstruction"

	^SymbolicBytecodeBuilder decode: self! !

!CompiledCode methodsFor: 'literals' stamp: ''!
literalsAt: anIndex
	"All literals are shifted of one slot. First slot is the method header"
	^ self objectAt: anIndex + 1! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
sourceNodeForPC: arg1 
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'printing' stamp: ''!
asString

	  ^self sourceCode! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
localSendsToSuper
	^ self encoderClass sendsToSuperFor: self! !

!CompiledCode methodsFor: 'testing' stamp: ''!
isRealPrimitive
	^self isPrimitive and: [ self isQuick not ]! !

!CompiledCode methodsFor: 'testing' stamp: ''!
isReturnSelf
	"Answer whether the receiver is a quick return of self."

	^ self primitive = 256! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
readsRef: literalAssociation 
	"Answer whether the receiver loads the argument."
	(self localReadsRef: literalAssociation) ifTrue: [ ^ true ].
	^ self innerCompiledBlocksAnySatisfy: [ :cb | cb readsRef: literalAssociation ]! !

!CompiledCode methodsFor: 'converting' stamp: ''!
asOrderedCollection
	"We should override it because most of collection methods are not working for CompiledMethod. And it can't be normally converted into OrderedCollection.	
	It is special class which needs to be ByteArray by VM. But it is not behaves like ByteArray from user perspective"
	
	^OrderedCollection with: self! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
scanner

	^ InstructionStream on: self! !

!CompiledCode methodsFor: 'testing' stamp: ''!
usesSecondaryBytecodeSet
	^ self header < 0! !

!CompiledCode methodsFor: '*RPackage-Core' stamp: ''!
packageFromOrganizer: anRPackageOrganizer
	| originSelector |
	"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'.
	originSelector := self originMethod selector.
	
	^self origin packages 
		detect: [ :each | 
			self origin isMeta
				ifFalse: [ each includesSelector: originSelector ofClassName: self origin instanceSide originalName]
				ifTrue: [ each includesSelector: originSelector ofMetaclassName: self origin instanceSide originalName]] 
		ifNone: [ nil ]! !

!CompiledCode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionAST
	<inspectorPresentationOrder: 35 title: 'AST'>

	^ SpTreePresenter new 
		roots: { self ast };
		children: [ :aNode | aNode children ];
		display: [ :each | 
			String
				streamContents: [ :stream | 
					stream
						nextPutAll: each class name;
						nextPut: $(;
						nextPutAll: ((each formattedCode truncateTo: 50) copyReplaceAll: String cr with: String space);
						nextPut: $)
			 ] ];
		yourself! !

!CompiledCode methodsFor: 'literals' stamp: ''!
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: '"signFlag: '.
	self signFlag printOn: s.
	s nextPutAll: ' ('.
	self encoderClass name printOn: s.
	s nextPut: $).
	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! !

!CompiledCode methodsFor: 'comparing' stamp: ''!
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"! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
bytecode
	"Answer an ByteArray of the btyecode of the method."

	| start stop bytecode |

	start := self initialPC.
	stop := self endPC.
	
	bytecode := ByteArray new: (stop - start + 1).
	start to: stop do: [:index |
		bytecode byteAt: index - start + 1 put: (self byteAt: index)].
	^bytecode! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
numArgs
	"Answer the number of arguments the receiver takes."

	^ (self header bitShift: -24) bitAnd: 16r0F! !

!CompiledCode methodsFor: 'literals' stamp: ''!
objectAt: index 
	"Primitive. Answer the method header (if index=1) or a literal (if index 
	>1) from the receiver. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 68>
	self primitiveFailed! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
scanFor: byte 
	"Answer whether the receiver contains the argument as a bytecode."

	^ (InstructionStream on: self) scanFor: [:instr | instr = byte]
"
Smalltalk browseAllSelect: [:m | m scanFor: 134]
"! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
clearSignFlag
	"Clear the sign flag bit.  The sign flag bit may be
	 used by the VM to select an alternate bytecode set."

	self signFlag ifTrue:
		[self objectAt: 1 put: self header - SmallInteger minVal]! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
accessesSlot: aSlot
	^aSlot isAccessedIn: self! !

!CompiledCode methodsFor: 'source code management' stamp: ''!
argumentNames
	^ self propertyAt: #argumentNames ifAbsent: [ self ast argumentNames ]! !

!CompiledCode methodsFor: 'literals' stamp: ''!
innerCompiledBlocksDo: aBlock
	"We ignore the enclosing compiled code in compiled block by ignoring the last literal"
	1 to: self numLiterals - self literalsToSkip do:
		[:index | | lit |
		lit := self literalAt: index.
		lit isEmbeddedBlock ifTrue: [ aBlock value: lit ] ]! !

!CompiledCode methodsFor: 'literals' stamp: ''!
literals

	"Answer an Array of the literals referenced by the receiver.	
	 Exclude superclass + selector/properties"

	| literals numberLiterals |
	literals := Array new:
		            (numberLiterals := self numLiterals
		                               - self literalsToSkip).
	1 to: numberLiterals do: [ :index | 
	literals at: index put: (self literalAt: index) ].
	^ literals! !

!CompiledCode methodsFor: '*Fuel-Tests-Core' stamp: ''!
isEqualRegardlessTrailerTo: anObject
	^ self = anObject! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
accessesField: varIndex
	"Answer whether the receiver accesses the instance variable indexed by the argument."

	^ (self readsField: varIndex) or: [ self writesField: varIndex ]! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
hasPragmaNamed: arg1 
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'testing' stamp: ''!
isDoIt
	^ false! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
localReadsRef: 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: (self encoderClass bindingReadScanBlockFor: litIndex using: scanner)! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
localReadsThisContext
	^ self encoderClass readsThisContextFor: self! !

!CompiledCode methodsFor: 'testing' stamp: ''!
refersToLiteral: aLiteral
	"Answer true if any literal in this method is literal,
	even if embedded in array structure."

	1 to: self numLiterals - self literalsToSkip do: [ :index | 
		"exclude selector or additional method state (penultimate slot) 
		and methodClass or outerCode (last slot)"
		((self literalAt: index) refersToLiteral: aLiteral)
			ifTrue: [ ^ true ] ].

	^ false! !

!CompiledCode methodsFor: '*Debugging-Core' stamp: ''!
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"! !

!CompiledCode methodsFor: '*Fuel-Core' stamp: ''!
bytecodesHash
	"Answer a 16-bit checksum of the bytecodes."

	^ CRC crc16FromCollection: (ByteArray 
		new: self size 
		streamContents: [ :stream | self 
			from: self initialPC 
			to: self endPC 
			do: [ :byte | stream nextPut: byte ] ])! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
methodNode
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
selector
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
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]! !

!CompiledCode methodsFor: '*Deprecated10' stamp: ''!
debuggerMap
	self deprecated: 'please use the reflective API directly to read variables!!'.
	^self compilerClass debuggerMethodMapForMethod: self.! !

!CompiledCode methodsFor: 'literals' stamp: ''!
literalAt: index 
	"Answer the literal indexed by the argument."

	^self objectAt: index + 1! !

!CompiledCode methodsFor: 'literals' stamp: ''!
hasLiteralSuchThat: litBlock
	"Answer true if litBlock returns true for any literal in this method, even if embedded in array structure."
	1 to: self numLiterals - self literalsToSkip do: "exclude header and methodClass or outerCode"
		[:index | | lit |
		lit := self literalAt: index.
		((litBlock value: lit)
		or: [lit isArray and: [lit hasLiteralSuchThat: litBlock]]) ifTrue:
			[^true].
		lit isEmbeddedBlock ifTrue: [ (lit hasLiteralSuchThat: litBlock) ifTrue: [ ^true ] ]].
	^false! !

!CompiledCode methodsFor: '*OpalCompiler-Core' stamp: ''!
compiler
	^self methodClass compiler! !

!CompiledCode methodsFor: 'testing' stamp: ''!
isQuick
	"Answer whether the receiver is a quick return (of self or of an instance 
	variable)."
	^ self primitive between: 256 and: 519! !

!CompiledCode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectorNodes
	"Answer a list of attributes as nodes"
	| nodes |

	nodes := OrderedCollection new.
	nodes add: (StInspectorDynamicNode 
				hostObject: self 
				label: 'literal0'
				value: self header).
	
	nodes addAll: (self allLiterals 
		collectWithIndex: [ :aLiteral :anIndex | 
			StInspectorDynamicNode 
				hostObject: self 
				label: ('literal', anIndex asString) 
				value: aLiteral ]).
	
	self initialPC to: self size do: [ :index |
		nodes add: (StInspectorDynamicNode 
			hostObject: self 
			label: ('bc ', index asString) 
			value: (self at: index) ) ] .
	
	^ nodes! !

!CompiledCode methodsFor: 'cleaning' stamp: ''!
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."

	<primitive: 215>
	^self flushCache! !

!CompiledCode methodsFor: 'literals' stamp: ''!
hasLiteral: literal
	"Answer whether the receiver references the argument, literal."
	1 to: self numLiterals - self literalsToSkip do: "exclude superclass + selector/properties"
		[:index |
		| lit |
		((lit := self literalAt: index) literalEqual: literal) ifTrue: [^true].
		lit isEmbeddedBlock ifTrue: [ (lit hasLiteral: literal) ifTrue: [ ^true ] ]].
	^false! !

!CompiledCode methodsFor: 'source code management' stamp: ''!
sourcePointer
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'literals' stamp: ''!
hasSelector: selector specialSelectorIndex: specialOrNil
	"Answers true if the method refers to the selector.
	 If you don't know what's a special selector, use #hasSelector:.
	 If you do, you may call this method directly to avoid recomputing 
	 the special selector index all the time.	
	 I traverse the method and all the compiled blocks in the literals"	
	(self refersToLiteral: selector) ifTrue: [ ^ true ].
	"refersToLiteral: traverses all blocks, but only for non-special literals"
	specialOrNil ifNil: [ ^ false ].
	"if the selector is special, scan all blocks and myself"
	self withAllBlocksDo: [ :aCompiledCode | 
		(aCompiledCode scanFor: self encoderClass firstSpecialSelectorByte + specialOrNil)
			ifTrue: [ ^true ] ].
	^false! !

!CompiledCode methodsFor: 'testing' stamp: ''!
isNamedPrimitive
	^self primitive = 117! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
sourceCode
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'source code management' stamp: ''!
stamp

	^ self timeStamp! !

!CompiledCode methodsFor: '*Debugging-Core' stamp: ''!
hasInstVarRef
	self localHasInstVarRef ifTrue: [ ^ true ].
	^ self innerCompiledBlocksAnySatisfy: [ :cb | cb hasInstVarRef ]! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
readsSlot: aSlot
	^aSlot isReadIn: self! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
allBlocksDo: aBlock

	self literals 
		select: [ :aLiteral | aLiteral isEmbeddedBlock ] 
		thenDo: [ :aLiteral | aLiteral withAllBlocksDo: aBlock  ]! !

!CompiledCode methodsFor: 'testing' stamp: ''!
sendsAnySelectorOf: aCollection
	
	(self localSendsAnySelectorOf: aCollection) ifTrue: [ ^ true ].
	^ self innerCompiledBlocksAnySatisfy: [ :cb | cb sendsAnySelectorOf: aCollection ]! !

!CompiledCode methodsFor: 'literals' stamp: ''!
header
	"Answer the word containing the information about the form of the 
	receiver and the form of the context needed to run the receiver."

	^self objectAt: 1! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
setSignFlag
	"Set the sign flag bit.  The sign flag bit may be
	 used by the VM to select an alternate bytecode set."

	self signFlag ifFalse:
		[self objectAt: 1 put: self header + SmallInteger minVal]! !

!CompiledCode methodsFor: '*Debugging-Core' stamp: ''!
bytecodeSizeForPc: pc
	"Returns the size of the bytecode at the given pc"

	^ self encoderClass bytecodeSize: (self at: pc)! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
readsThisContext
	"Answer whether compiledMethod reads thisContext, look into embedded blocks, too"
	self localReadsThisContext ifTrue: [ ^ true ].
	^ self innerCompiledBlocksAnySatisfy: [ :cb | cb readsThisContext]! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
origin
	^ self methodClass findOriginClassOf: self method! !

!CompiledCode methodsFor: '*Debugging-Core' stamp: ''!
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]! !

!CompiledCode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionHeader
	<inspectorPresentationOrder: 40 title: 'Header'> 
	
	^ SpTextPresenter new 
		text: self headerDescription;
		yourself! !

!CompiledCode methodsFor: '*Debugging-Core' stamp: ''!
messages
	"Answer a Set of all the message selectors sent by this method."
	| aSet |
	aSet := self localMessages.
	self innerCompiledBlocksDo: [ :cb | aSet := aSet , cb messages ].
	^ aSet! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
clearFlag
	"Clear the user-level flag bit"

	self objectAt: 1 put: (self header bitAnd: (1 << 29) bitInvert)! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
primitive
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
withAllBlocksDo: aBlock 
	
	aBlock value: self.
	self allBlocksDo: aBlock! !

!CompiledCode methodsFor: 'source code management' stamp: ''!
definitionString

	"Polymorphic to class definitionString"

	^ self sourceCode! !

!CompiledCode methodsFor: 'printing' stamp: ''!
primitiveErrorVariableName
	"Answer the primitive error code temp name, or nil if none."
	self isPrimitive ifTrue:
		[self pragmas do:
			[:pragma| | kwds ecIndex |
			((kwds := pragma selector keywords) first = 'primitive:'
			and: [(ecIndex := kwds indexOf: 'error:') > 0]) ifTrue:
				[^pragma argumentAt: ecIndex]]].
	^nil! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
method
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
sourceNode
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'testing' stamp: ''!
isPrimitive
	^self primitive > 0! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
accessesRef: literalVariable
	"Answer whether this method accesses the LiteralVariable"
	"we do not need to call readsRef: or #writesRef:, as if the variable 
	is stored as a Literal, it will be accessed. This check is much faster"

	^ self hasLiteral: literalVariable! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
comment
	"Return the first comment of the receiver"
	"(self>>#comment) comment"
	
	^ self ast firstPrecodeComment! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
properties
	^ self subclassResponsibility! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
writesRef: literalAssociation 
	"Answer whether the receiver stores into the argument."
	(self localWritesRef: literalAssociation) ifTrue: [ ^ true ].
	^ self innerCompiledBlocksAnySatisfy: [ :cb | cb writesRef: literalAssociation ]! !

!CompiledCode methodsFor: 'accessing' stamp: ''!
initialPC
	"Answer the program counter for the receiver's first bytecode."

	^ (self numLiterals + 1) * Smalltalk wordSize + 1! !

!CompiledCode methodsFor: 'initialization' stamp: ''!
setFrameBit: boolean 
	"true for large frame, else false"
	| largeFrameBit newHeader |
	largeFrameBit := 16r20000.
	newHeader := self header bitAnd: largeFrameBit bitInvert.
	boolean ifTrue: [ newHeader := newHeader + largeFrameBit ].
	self objectAt: 1 put: newHeader.! !

!CompiledCode methodsFor: '*Debugging-Core' stamp: ''!
pcPreviousTo: pc
	| scanner prevPc |
	pc > self endPC ifTrue: [^self endPC].
	scanner := InstructionStream on: self.
	[scanner pc < pc] whileTrue: [
		prevPc := scanner pc.
		scanner advanceToFollowingPc ].
	^prevPc! !

!CompiledCode methodsFor: 'scanning' stamp: ''!
sendsToSuper
	self localSendsToSuper ifTrue: [ ^ true ].
	^ self innerCompiledBlocksAnySatisfy: [ :cb | cb sendsToSuper ]! !

!CompiledCode class methodsFor: 'instance creation' stamp: ''!
newMethod: numberOfBytes header: headerWord
	"Primitive. Answer an instance of me. The number of literals (and other 
	 information) is specified by the headerWord (see my class comment).
	 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, or if memory is low. Once the header of a method is set by
	 this primitive, it cannot be changed to change the number of literals.
	 Essential. See Object documentation whatIsAPrimitive."

	<primitive: 79 error: ec>
	ec == #'insufficient object memory' ifTrue:
		[^self handleFailingNewMethod: numberOfBytes header: headerWord].
	^self primitiveFailed! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testLiteralsEvenTheOnesInTheInnerBlocks
	"The behavior is different than literals"
	| method |
	method := self class compiler compile: 'method 
		<pragma: #pragma>
		test := 1+2.
		Class.
		self doIt: [ 
		test := 1 - 2.
		test := #(arrayInBlock).
		Object.
		self name ].
		^#(#array) '.
	"Next assertion is expected: literals have a different behavior more close to the system"
	self deny: method literalsEvenTheOnesInTheInnerBlocks equals: method literals.
	self
		assertCollection: method literalsEvenTheOnesInTheInnerBlocks
		equals: { 
				2.
				(UndeclaredVariable key: #test value: nil).
				2.
				(UndeclaredVariable key: #test value: nil).
				#( #arrayInBlock ).
				#name.
				(GlobalVariable key: #Object value: Object).
				#doIt:.
				#( #array ).
				(GlobalVariable key: #Class value: Class) }! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testRefersToLiteralsReturnsTrueWhenLiteralIsInPragmaArguments
	
	self assert: (self compiledMethod1 refersToLiteral: 'bar').
	self assert: (self compiledMethod1 refersToLiteral: 123)! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testHasLiteral

	| method |
	method := self class compiler compile: 'method 
		<pragma: #pragma>
		test := 1+2.
		self doIt: [ 
		test := 1 - 2.
		test := #(arrayInBlock).
		self name ].
		^#(#array) '.
	"simpe case: normal send in the method itself"
	self assert: (method hasLiteral: #doIt:).
	"special selector in the method is not found"
	self deny: (method hasLiteral: #+).
	"special selector in the block not found, either"
	self deny: (method hasLiteral: #-).
	"normal selector in the block"
	self assert: (method hasLiteral: #name).
	"we do NOT into arrays, this is different to hasLiteralSuchThat:"
	self flag: #FIXME. "LiteralScanningMissmatch"
	self deny: (method hasLiteral: #array).
	"we do not into arrays in Blocks. this is different to hasLiteralSuchThat:"
	self flag: #FIXME. "LiteralScanningMissmatch"
	self deny: (method hasLiteral: #arrayInBlock).
	"pragmas are NOT covered."
	self deny: (method hasLiteral: #pragma:).
	"args of pragmas not found, too."
	self deny: (method hasLiteral: #pragma).
	"the method selector NOT"
	self deny: (method hasLiteral: #method).! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testHasSelectorSpecialSelectorIndex

	| method specialIndex |
	method := self class compiler compile: 'method 
		<pragma: #pragma>
		test := 1+2.
		self do: [ 
		test := 1 - 2.
		test := #(arrayInBlock).
		self name ].
		^#(#array) '.
	"simpe case: normal send in the method itself"
	specialIndex := Smalltalk specialSelectorIndexOrNil: #do:.
	self assert: (method hasSelector: #do: specialSelectorIndex: specialIndex).
	"special selector in the method"
	specialIndex := Smalltalk specialSelectorIndexOrNil: #+.
	self assert: (method hasSelector: #+ specialSelectorIndex: specialIndex).
	"special selector in the block"
	specialIndex := Smalltalk specialSelectorIndexOrNil: #-.
	self assert: (method hasSelector: #- specialSelectorIndex: specialIndex).
	"normal selector in the block"
	specialIndex := Smalltalk specialSelectorIndexOrNil: #name.
	self assert: (method hasSelector: #name specialSelectorIndex: specialIndex).
	"we look into arrays"
	specialIndex := Smalltalk specialSelectorIndexOrNil: #array.
	self assert: (method hasSelector: #array specialSelectorIndex: specialIndex).
	"we look into arrays in Blocks"
	specialIndex := Smalltalk specialSelectorIndexOrNil: #arrayInBlock.
	self assert: (method hasSelector: #arrayInBlock specialSelectorIndex: specialIndex).
	"pragmas are covered"
	specialIndex := Smalltalk specialSelectorIndexOrNil: #pragma:.
	self assert: (method hasSelector: #pragma: specialSelectorIndex: specialIndex).
	"args of pragmas are found, too"
	specialIndex := Smalltalk specialSelectorIndexOrNil: #pragma:.
	self assert: (method hasSelector: #pragma: specialSelectorIndex: specialIndex).
	"the method selector NOT"
	specialIndex := Smalltalk specialSelectorIndexOrNil: #method.
	self deny: (method hasSelector: #method specialSelectorIndex: specialIndex).! !

!CompiledCodeTest methodsFor: 'tests - scanning' stamp: ''!
testReadsRef
	| readMethod writeMethod classVar |
	readMethod := SmalltalkImage class>>#compilerClass.
	writeMethod := SmalltalkImage class>>#compilerClass:.
	classVar := SmalltalkImage classVariableNamed: #CompilerClass.
	
	self assert: (readMethod readsRef: classVar).
	self deny: (writeMethod readsRef: classVar).
	
	"Special test for a method with super in a full block. 
	We push a binding for this class but make sure that it is not the same"
	self deny: ((DelayMutexScheduler>>#unschedule:) readsRef: DelayMutexScheduler binding)! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testHasSelector

	| method |
	method := self class compiler compile: 'method 
		<pragma: #pragma>
		test := 1+2.
		self doIt: [ 
		test := 1 - 2.
		test := #(arrayInBlock).
		self name ].
		^#(#array) '.
	"simpe case: normal send in the method itself"
	self assert: (method hasSelector: #doIt:).
	"special selector in the method"
	self assert: (method hasSelector: #+).
	"special selector in the block"
	self assert: (method hasSelector: #-).
	"normal selector in the block"
	self assert: (method hasSelector: #name).
	"we look into arrays"
	self assert: (method hasSelector: #array).
	"we look into arrays in Blocks"
	self assert: (method hasSelector: #arrayInBlock).
	"pragmas are covered"
	self assert: (method hasSelector: #pragma:).
	"args of pragmas are found, too"
	self assert: (method hasSelector: #pragma).
	"the method selector NOT"
	self deny: (method hasSelector: #method).! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testLiteralsDoNotConsiderTheInnerBlockLiterals

	| method block |
	method := self class compiler compile: 'method 
		<pragma: #pragma>
		test := 1+2.
		Class.
		self doIt: [ 
		test := 1 - 2.
		test := #(arrayInBlock).
		Object.
		self name ].
		^#(#array) '.
	block := (self class compiler evaluate: '[ 
		test := 1 - 2.
		test := #(arrayInBlock).
		Object.
		self name ]') compiledBlock.
	self assertCollection: method literals equals: { 
			2.
			(UndeclaredVariable key: #test value: nil).
			block.
			#doIt:.
			#( #array ).
			(GlobalVariable key: #Class value: Class) }! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testRefersToLiteralsReturnsTrueWhenLiteralIsInPragmaSelector
	
	self assert: (self compiledMethod1
				refersToLiteral: #pragma1:foo:)! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testLiteralsDoesNotContainMethodClass
	
	self
		deny:
			(self compiledMethod1
				refersToLiteral: (self class environment associationAt: self class name asSymbol))! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testRefersToLiteralsReturnsTrueWhenLiteralIsByteString

	self assert: (self compiledMethod1 refersToLiteral: 'Pharo loves tests')! !

!CompiledCodeTest methodsFor: 'examples' stamp: ''!
method1
	
	<pragma1: 123 foo: 'bar' >
	| array | 
	array := Array new.
	array at: 1 put: 'Pharo loves tests'.
	#(#add #at: #remove) do: #printOn:! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testRefersToLiteralsReturnsTrueWhenLiteralIsContainedInArrayOfLitterals

	self assert: (self compiledMethod1 refersToLiteral: #add)! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testRefersToLiteralsReturnsTrueWhenLiteralIsByteSymbol

	self assert: (self compiledMethod1 refersToLiteral: #printOn:)! !

!CompiledCodeTest methodsFor: 'tests - scanning' stamp: ''!
testReadsSelf
	| method |
	method := self class compiler compile: 'method self doit'.
	self assert: method readsSelf.
	method := self class compiler compile: 'method ^self'.
	self assert: method readsSelf.
	method := self class compiler compile: 'method ^thisContext'.
	self deny: method readsSelf.
	"take care!! FFI methods have a self send, but they do not have self bytecode after the first call
	Here we test just the case of a FFI method that was not yet called to not make this test depend on FFI
	calls"
	method := self class compiler compile: 'status ^ self ffiCall: #(int cairo_scaled_font_status (self))'.
	self assert: method readsSelf.! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testHasLiteralSuchThat

	| method |
	method := self class compiler compile: 'method 
		<pragma: #pragma>
		test := 1+2.
		self doIt: [ 
		test := 1 - 2.
		test := #(arrayInBlock).
		self name ].
		^#(#array) '.
	"simpe case: normal send in the method itself"
	self assert: (method hasLiteralSuchThat: [:literal | literal == #doIt:]).
	"special selector in the method is not found"
	self deny: (method hasLiteralSuchThat: [:literal | literal == #+]).
	"special selector in the block not found, either"
	self deny: (method hasLiteralSuchThat: [:literal | literal == #-]).
	"normal selector in the block"
	self assert: (method hasLiteralSuchThat: [:literal | literal == #name]).
	"we look into arrays"
	self assert: (method hasLiteralSuchThat: [:literal | literal == #array]).
	"we look into arrays in Blocks"
	self assert: (method hasLiteralSuchThat: [:literal | literal == #arrayInBlock]).
	"pragmas are NOT covered"
	self deny: (method hasLiteralSuchThat: [:literal | literal == #pragma:]).
	"args of pragmas are NOT found, too"
	self deny: (method hasLiteralSuchThat: [:literal | literal == #pragma]).
	"the method selector NOT"
	self deny: (method hasLiteralSuchThat: [:literal | literal == #method]).! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testRefersToLiteralsReturnsTrueWhenLiteralIsGlobalVariable
	
	self assert: (self compiledMethod1
				refersToLiteral: (self class environment associationAt: #Array))! !

!CompiledCodeTest methodsFor: 'tests - debugging support' stamp: ''!
testStepIntoQuickMethods
	|ctx compiledBlock|
	
	self deny: self compiledMethod1 stepIntoQuickMethods. 
	ctx := [ 1 + 1 ] asContext.
	compiledBlock := ctx method.
	compiledBlock stepIntoQuickMethods: true.
	self assert: compiledBlock method stepIntoQuickMethods equals: compiledBlock stepIntoQuickMethods! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testRefersToLiteralsReturnsFalseWhenLiteralNotInMethodPropertiesKey
	
	[ self compiledMethod1 propertyAt: #Once put: true.
	self deny: (self compiledMethod1 refersToLiteral: #Absent) ]
		ensure: [ self compiledMethod1 removeProperty: #Once ]! !

!CompiledCodeTest methodsFor: 'tests - scanning' stamp: ''!
testReadsThisContext
	| method |
	method := self class compiler compile: 'method ^thisContext'.
	self assert: method readsThisContext.
	method := self class compiler compile: 'method ^self'.
	self deny: method readsThisContext.! !

!CompiledCodeTest methodsFor: 'examples' stamp: ''!
compiledMethod1
	^ self class >> #method1! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testLiteralsDoesNotContainMethodName

	self deny: (self compiledMethod1 refersToLiteral: #method1)! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testRefersToLiteralsReturnsTrueWhenLiteralIsArrayOfLiterals

	self assert: (self compiledMethod1 refersToLiteral: #(#add #at: #remove))! !

!CompiledCodeTest methodsFor: 'tests - scanning' stamp: ''!
testAccessesRef
	| readMethod writeMethod classVar |
	readMethod := SmalltalkImage class>>#compilerClass.
	writeMethod := SmalltalkImage class>>#compilerClass:.
	classVar := SmalltalkImage classVariableNamed: #CompilerClass.
	
	self assert: (readMethod accessesRef: classVar).
	self assert: (writeMethod accessesRef: classVar).! !

!CompiledCodeTest methodsFor: 'tests - literals' stamp: ''!
testLiteralsEvenTheOnesInTheInnerCleanBlocks

	"The behavior is different than literals"

	| method |
	method := self class compiler compile:
		          'exampleAccessOuterFromCleanBlock 
	<compilerOptions: #(+ optionCleanBlockClosure)>
	| b |
	b := 1. 
	^[ thisContext tempNamed: ''b'' ] value'.
	self
		assertCollection: method literalsEvenTheOnesInTheInnerBlocks
		equals: #( 'b' #tempNamed: )! !

!CompiledMethod commentStamp: ''!
Specific version of compiled code for method's.

CompiledMethod instances can be in two forms:
- up until Pharo 6, they encode both the method and the inner closures bytecodes and literals.
- since Pharo 6, they encode only the method's bytecodes and literals.

In addition the execution mechanics, a compiled method have two extra optional literals. The last literal, optional if there are no super sends, is the class in which the method is installed. The last but one literal is either the method's selector or an AdditionalMethodState instance. AdditionalMethodState instances are used to encode additional state to a method, as for example the pragmas.

The bytecode encodes the trailer at the end, in most cases it has 4 bytes encoding the sourcer pointer (see CompiledMethodTrailer).
Thus endPC of a compiled method is not the size of the bytecode, but the size minus the length of the trailer.
!
!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
propertyAt: propName
	| propertiesOrSelector |
	^(propertiesOrSelector := self penultimateLiteral) isMethodProperties
		ifTrue: [propertiesOrSelector propertyAt: propName ifAbsent: [nil]]
		ifFalse: [nil]! !

!CompiledMethod methodsFor: '*Slot-Core' stamp: ''!
hasTemporaryVariableNamed: aName
	^ self tempNames includes: aName! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
methodClass
	"answer the class that I am installed in"
	^self classBinding value! !

!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
removeProperty: propName ifAbsent: aBlock
	"Remove the property propName if it exists.
	 Answer the evaluation of aBlock if the property is missing."
	| value |
	value := self propertyAt: propName ifAbsent: [^aBlock value].
	self penultimateLiteral: (self penultimateLiteral copyWithout:
									(Association
										key: propName
										value: value)).
	^value! !

!CompiledMethod methodsFor: '*SUnit-Core' stamp: ''!
isErrorTest
	"Is the receiver a test method that raised an error?"

	^ self methodClass isTestCase
		and: [ self methodClass methodRaisedError: self selector ]! !

!CompiledMethod methodsFor: 'scanning' stamp: ''!
writesField: varIndex
	"Answer whether the receiver stores into the instance variable indexed by the argument."
	self isQuick ifTrue: [^false].
	^ super writesField: varIndex! !

!CompiledMethod methodsFor: 'initialization' stamp: ''!
removeFromSystem
	^ self methodClass removeSelector: self selector! !

!CompiledMethod methodsFor: '*SUnit-Core' stamp: ''!
isTestMethod

	^ self methodClass isTestCase and: [ self selector isTestSelector ]! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
sendNodes
	^self ast sendNodes! !

!CompiledMethod methodsFor: '*RPackage-Core' stamp: ''!
isExtension
	^ self origin package ~= self package! !

!CompiledMethod methodsFor: 'debugger support' stamp: ''!
prepareForSimulationWith: numArgs
	"This method changes the argument count of a CompiledMethod header to numArgs, its temporary count to numArgs + 1 and change the code handling primitive error to store the error code in the unique temporary of the method"
			
	| newHeader |
	newHeader := (((self header bitAnd: 2r01110000000000111111111111111111) 
			bitOr: (numArgs bitShift: 24))
			bitOr: (numArgs + 1 bitShift: 18)).
	newHeader := newHeader + (self class headerFlagForEncoder: self encoderClass).
	self objectAt: 1 put: newHeader.
	
	self encoderClass prepareMethod: self forSimulationWith: numArgs! !

!CompiledMethod methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asFullRingDefinition

	"Retrieves an active RGMethodDefinition which knows its parent <class>.
	Note that the full conversion does not happen at the level of the class. If you need that request asFullRingDefinition to the class"
	| rgClass rgMethod |
	rgClass := self realClass asRingDefinition.
	rgMethod := self asActiveRingDefinition.
	rgClass addMethod: rgMethod.
	rgMethod package: (RGContainer packageOfMethod: rgMethod).
	^ rgMethod! !

!CompiledMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForBytecodesFor: aStep
	<stSpotterOrder: 15>
	
	aStep listProcessor
		title: 'Bytecode';
		allCandidates: [ self symbolicBytecodes ];
		itemName: #printString;
		filter: StFilterSubstring! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isDeprecated
	
	^ self sendsAnySelectorOf: #(
			#deprecated: 
			#deprecated:transformWith:
			#deprecated:transformWith:when:
			#deprecated:on:in: 
			#deprecated:on:in:transformWith:
			#deprecated:on:in:transformWith:when:)! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isDisabled: marker
	^ marker == self class disabledMarker! !

!CompiledMethod methodsFor: '*System-Support' stamp: ''!
implementors
	^ SystemNavigation default allImplementorsOf: self selector! !

!CompiledMethod methodsFor: 'literals' stamp: ''!
literalsToSkip

	^ 2! !

!CompiledMethod methodsFor: '*AST-Core' stamp: ''!
ast
	"return an AST for this method. The AST is cached. see class comment of ASTCache"
	^ ASTCache at: self! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
classBinding: aBinding
       "sets the association to the class that I am installed in"
       ^self literalAt: self numLiterals put: aBinding.! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
hasSourcePointer
	^ self trailer hasSourcePointer! !

!CompiledMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForImplementorsFor: aStep
	<stSpotterOrder: 10>
	
	aStep listProcessor
			title: 'Implementors';
			allCandidates: [ self implementors collect: [:each | each compiledMethod] ];
			filter: StFilterSubstring;
			keyBinding: $m command! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
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: '*Reflectivity' stamp: ''!
installLink: aMetaLink
	self reflectiveMethod ifNil: [ self createTwin ].
	self reflectiveMethod increaseLinkCount.
	(aMetaLink optionCompileOnLinkInstallation or: [ self isRealPrimitive ])
		ifTrue: [ self reflectiveMethod compileAndInstallCompiledMethod ]
		ifFalse: [ self invalidate ]! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isOverridden
	| selector| 
	selector := self selector.
	self methodClass allSubclassesDo: [:each | 
		(each includesSelector: selector)
			ifTrue: [ ^ true ]].
	^ false! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
invalidate
	| reflectiveMethod |
	self reflectivityDisabled ifTrue: [ ^self ].
	
	reflectiveMethod := self reflectiveMethod.
	reflectiveMethod ifNil: [^self "do nothing"].
	(self isRealPrimitive or: (reflectiveMethod ast metaLinkOptionsFromClassAndMethod includes: #optionCompileOnLinkInstallation))
					ifTrue: [reflectiveMethod compileAndInstallCompiledMethod ] 
					ifFalse: [reflectiveMethod installReflectiveMethod]
	! !

!CompiledMethod methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
astForStylingInCalypso
	"this method simplified remote method styling. 
	Remote proxy will redefine it by building AST on client side"
	^self ast! !

!CompiledMethod methodsFor: 'initialization' stamp: ''!
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: 'accessing - pragmas & properties' stamp: ''!
pragmas
	| selectorOrProperties |
	^(selectorOrProperties := self penultimateLiteral) isMethodProperties
		ifTrue: [selectorOrProperties pragmas]
		ifFalse: [#()]! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
createTwin
	self reflectiveMethod: (ReflectiveMethod on: self)! !

!CompiledMethod methodsFor: '*Manifest-Core' stamp: ''!
criticNameOn: aStream
	"This behavior may be folded later by changing the name of this method or using another one."
	
	aStream 
		<< self methodClass name 
		<< '>>#' 
		<< self selector  
		<< ' (' 
		<< self methodClass instanceSide category 
		<< ')'! !

!CompiledMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterPreview: aBuilder

	^ aBuilder newCode
		beForMethod: self;
		beNotEditable;
		text: self sourceCode;
		yourself! !

!CompiledMethod methodsFor: '*Slot-Core' stamp: ''!
temporaryVariables
	"on the level of compiledMethod, temps include the arguments"
	self flag: #TODO. "we need to revist temps vs args"
	^(self sourceNode arguments collect: [ :each | each binding ]), 
		(self sourceNode temporaries collect: [ :each | each binding ])! !

!CompiledMethod methodsFor: 'source code management' stamp: ''!
getSourceReplacingSelectorWith: newSelector
	| oldKeywords newKeywords source newSource oldSelector start |
	source := self sourceCode.
	
	source ifNil: [ ^ nil ].
	
	oldSelector := self selector.
	oldSelector = newSelector ifTrue: [ ^ source ].
	
	oldKeywords := oldSelector keywords.
	newKeywords := (newSelector ifNil: [self defaultSelector]) keywords.
	[oldKeywords size = newKeywords size] assert.
	
	newSource := source.
	start := 1.
	oldKeywords with: newKeywords do: [:oldKey :newKey| |pos|
		pos := newSource findString: oldKey startingAt: start .
		newSource := newSource copyReplaceFrom: pos to: (pos + oldKey size -1) with: newKey.
		start := pos + newKey size ].

	^newSource! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isFaulty
 	"check if this method was compiled from syntactically wrong code"
	| ast |
	"fast pre-check: all methods with syntax errors reference this symbol"
  	(self refersToLiteral: #signalSyntaxError:) ifFalse: [ ^false].
	"we have to parse the ast here as #ast does not know that this needs optionParseErrors"
	ast := self methodClass compiler 
				source: self sourceCode;
				options: #(+ optionParseErrors);
				parse.
	^ ast isFaulty.! !

!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
cachePragmas

	self pragmas do: [ :pragma | pragma class addToCache: pragma ]! !

!CompiledMethod methodsFor: '*OpalCompiler-Core' stamp: ''!
reformat
	self methodClass compile: self ast formattedCode classified:  self category.! !

!CompiledMethod methodsFor: '*Monticello' stamp: 'nil'!
basicAsMCMethodDefinition

	"Creates a MCMethodDefinition from the receiver"

	^ MCMethodDefinition
		  className: self methodClass instanceSide name
		  classIsMeta: self isClassSide
		  selector: self selector
		  category: self protocol
		  timeStamp: self stamp
		  source: self sourceCode! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
protocol: aString
	^ self methodClass organization classify: self selector under: aString! !

!CompiledMethod methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asPassiveRingDefinition
	"Retrieves a passive RGMethodDefinition object based on the data of the receiver.
	Source, protocol and stamp are retrieved from value assigned in creation"
	
	^RGMethodDefinition new 
		 	name: self selector;
			parentName: self methodClass name;
			isMetaSide: self methodClass isMeta;
			protocol: self category;
			sourceCode: self sourceCode;
			stamp: self timeStamp;
			asPassive.! !

!CompiledMethod methodsFor: 'source code management' stamp: ''!
linesOfCode
	"An approximate measure of lines of code.
	Includes method's name and comments, but excludes empty lines."
	| lines |
	lines := 0.
	self sourceCode lineIndicesDo: [:start :endWithoutDelimiters :end |
		endWithoutDelimiters > start ifTrue: [lines := lines+1]].
	^lines! !

!CompiledMethod methodsFor: '*System-Sources' stamp: ''!
putSource: sourceStr class: class category: catName withStamp: changeStamp priorMethod: priorMethod
	^ self
		putSource: sourceStr
		withPreamble: [ :file | 
			class
				printCategoryChunk: catName
				on: file
				withStamp: changeStamp
				priorMethod: priorMethod.
			file cr ]! !

!CompiledMethod methodsFor: 'scanning' stamp: ''!
readsField: varIndex 
	"Answer whether the receiver loads the instance variable indexed by the argument."
	self isReturnField ifTrue: [^self returnField = (varIndex - 1)].
	^ super readsField: varIndex! !

!CompiledMethod methodsFor: '*Epicea-Ring' stamp: ''!
asEpiceaRingDefinition

	^ (RGMethodDefinition named: self selector)
		parentName: self methodClass name;
		isMetaSide: self methodClass isMeta;
		protocol: self category;
		sourceCode: self sourceCode;
		stamp: self timeStamp;
		package: (self package ifNotNil: [:package | package name]);
		yourself.! !

!CompiledMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterMethodClassFor: aStep
	<stSpotterOrder: 50>
	aStep listProcessor
			allCandidates: [  {self methodClass }];
			title: 'Class';
			filter: StFilterSubstring;
			itemIcon: #systemIcon! !

!CompiledMethod methodsFor: 'accessing - backward compatible' stamp: ''!
category
	"Please favor protocol instead of category. We want to have method protocol and class package and tag = a category"
	^ self methodClass organization categoryOfElement: self selector! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
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 | 
	Symbol internSelector:  aSelector.
	(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: '*AST-Core' stamp: ''!
firstComment
	"Answer a string representing the first comment in the method associated with selector. Return an empty string if the method's source code does not contain a comment."

	^ self comments ifEmpty: [ #() ] ifNotEmpty: [ :comments | comments first ]! !

!CompiledMethod methodsFor: '*Monticello' stamp: 'nil'!
sameAsMCDefinition: anMCMethodDefinition

	^ anMCMethodDefinition selector = self selector and: [ 
		  anMCMethodDefinition className = self className and: [ 
			  anMCMethodDefinition classIsMeta = self isClassSide 
				  and: [ 
					  anMCMethodDefinition category = self protocol and: [ 
						  anMCMethodDefinition source = self sourceCode ] ] ] ]! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
hasPragma
	^ self hasProperties and: [self pragmas isNotEmpty]! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
name
	^ self printString! !

!CompiledMethod methodsFor: 'lookup' stamp: ''!
lookupVar: aString 
	^self ast scope lookupVar: aString! !

!CompiledMethod methodsFor: '*Renraku' stamp: ''!
reBanName

	^ self name, ' (Method)'! !

!CompiledMethod methodsFor: 'source code management' stamp: ''!
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: 'testing' stamp: ''!
usesUndeclareds
	"this is mixing Undeclareds and Obsoletes, maybe we should have two methods"	
	self withAllNestedLiteralsDo: [ :literal | 
		literal class == UndeclaredVariable ifTrue: [ ^ true ].
		(literal isBlock not and: [ 
			 literal value isBehavior and: [ literal value isObsolete ] ]) 
			ifTrue: [ ^ true ] ].
	^ false! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
hasComment
	"check if this method has a method comment"
	^self comment isEmptyOrNil not! !

!CompiledMethod methodsFor: 'evaluating' stamp: ''!
receiver: aReceiver withArguments: anArray executeMethod: anObject
	<primitive: 188>
	self primitiveFailed! !

!CompiledMethod methodsFor: '*OpalCompiler-Core' stamp: ''!
recompile
	^ self methodClass recompile: self selector! !

!CompiledMethod methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitCompiledMethod: self! !

!CompiledMethod methodsFor: '*Fuel-Tests-Core' stamp: ''!
isEqualRegardlessTrailerTo: aCompiledMethod
	^ (self copyWithTrailerBytes: CompiledMethodTrailer empty) = (aCompiledMethod copyWithTrailerBytes: CompiledMethodTrailer empty)! !

!CompiledMethod methodsFor: 'source code management' stamp: ''!
argumentNames
	^ self propertyAt: #argumentNames ifAbsent: [ super argumentNames ]! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isExplicitlyRequired
	^ self isExplicitlyRequired: self markerOrNil! !

!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
propertyAt: 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: 'testing' stamp: ''!
isDoIt
	^self selector isDoIt.! !

!CompiledMethod methodsFor: 'literals' stamp: ''!
refersToLiteral: aLiteral
	"Answer true if any literal in this method is literal, even if embedded in array structure."
	
	^(self pragmaRefersToLiteral: aLiteral) or: [ super refersToLiteral: aLiteral]! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isSubclassResponsibility: marker
	^ marker == self class subclassResponsibilityMarker! !

!CompiledMethod methodsFor: '*OpalCompiler-Core' stamp: ''!
methodNode
	"returns an AST for this method, do not cache it. (see #ast for the cached alternative)"
	^self parseTree! !

!CompiledMethod methodsFor: 'copying' stamp: ''!
postCopy
	| penultimateLiteral |
	(penultimateLiteral := self penultimateLiteral) isMethodProperties ifTrue:
		[self penultimateLiteral: (penultimateLiteral copy
									method: self;
									yourself).
		 self penultimateLiteral pragmas do:
			[:p| p method: self]]! !

!CompiledMethod methodsFor: '*DrTests' stamp: ''!
asResultForDrTest

	^ DTTestLeafNode content: self! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
destroyTwin
	self reflectiveMethod: nil! !

!CompiledMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForMessagesFor: aStep
	<stSpotterOrder: 12>

	aStep listProcessor
			title: 'Messages';
			allCandidates: [ 
				self messages asSortedCollection 
					collect: [:each | StSelector new name: each ] ];
			filter: StFilterSubstring! !

!CompiledMethod methodsFor: '*Fuel-Tests-Core' stamp: ''!
sizeWithoutTrailer
	^ self trailer endPC! !

!CompiledMethod methodsFor: '*PharoDocComment' stamp: ''!
hasDocComment
	^ self pharoDocCommentNodes notEmpty! !

!CompiledMethod methodsFor: '*Tool-Base' stamp: ''!
browse

	^ Smalltalk tools browser openOnClass: self methodClass selector: self selector! !

!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
pragmaAt: aKey
	"Answer the first pragma with selector aKey, or nil if none."
	^ self pragmas detect: [ :pragma | pragma selector == aKey ] ifNone: nil! !

!CompiledMethod methodsFor: '*SUnit-Core' stamp: ''!
isFailedTest
	"Is the receiver a test method that failed?"

	^ self methodClass isTestCase
		and: [ self methodClass methodFailed: self selector ]! !

!CompiledMethod methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
realClass
	"answer the class that I am installed in"
	
	^ self methodClass! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isDisabled
	^ self isDisabled: self markerOrNil! !

!CompiledMethod methodsFor: 'source code management' stamp: ''!
sourcePointer
	"Answer the integer which can be used to find the source file and position for this method.
	The actual interpretation of this number is up to the SourceFileArray stored in the global variable SourceFiles."

	^ self trailer sourcePointer! !

!CompiledMethod methodsFor: 'accessing - tags' stamp: ''!
tagWith: aSymbol
	"Any method could be tagged with multiple symbols for user purpose. 
	This method should apply new tag. All existing tags should not be changed. 
	But now we could only implemented tags with protocols. 	
	So tagging method with tag removes all existing tags and add new one. 
	It should not be problem with single tag scenario which are now defined by single protocol"
	
	self protocol: aSymbol! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
compiledMethod
	^self! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
sourceCode
	"Retrieve or reconstruct the source code for this method."

	| trailer |
	trailer := self trailer.
	trailer sourceCode ifNotNil: [:code | ^ code ].
	trailer hasSourcePointer ifFalse: [ ^ self codeForNoSource ].

	^ self getSourceFromFile ifEmpty: [ self codeForNoSource ]! !

!CompiledMethod methodsFor: 'source code management' stamp: ''!
setSourcePointer: srcPointer
	"We can't change the trailer of existing method, since it could have completely different format. 	
	Therefore we need to generate a copy with new trailer, containing scrPointer, and then become it."

	| trailer copy |
	trailer := CompiledMethodTrailer new sourcePointer: srcPointer.
	copy := self copyWithTrailerBytes: trailer.
	"If possible do a replace in place as an optimization"
	(self trailer class == trailer class and: [ self size = copy size ])
		ifTrue: [ 
			| start |
			start := self endPC + 1.
			self replaceFrom: start to: self size with: copy startingAt: start ]
		ifFalse: [ self becomeForward: copy ].
	^ self! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isProvided: marker
	marker ifNil: [^ true].
	^ (self isRequired: marker) not and: [(self isDisabled: marker) not]! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isProvided
	^ self isProvided: self markerOrNil! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
removeLink: aLink

	self reflectiveMethod ifNotNil: [:rm | rm removeLink: aLink].! !

!CompiledMethod methodsFor: '*Renraku' stamp: ''!
suitableRulesFrom: aReRuleManager 
	^ aReRuleManager methodRules! !

!CompiledMethod methodsFor: 'printing' stamp: ''!
printOn: aStream 
	"Overrides method inherited from the byte arrayed collection."

	aStream print: self methodClass; nextPutAll: '>>'; print: self selector.! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
returnField
	"Answer the index of the instance variable returned by a quick return 
	method."
	| prim |
	prim := self primitive.
	prim < 264
		ifTrue: [self error: 'only meaningful for quick-return']
		ifFalse: [^ prim - 264]! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
codeForNoSource
	"if everything fails, decompile the bytecode"
	"If there is no compiler, we cannot decompile it"	
	Smalltalk hasCompiler ifFalse: [ ^ nil ].
	
	 ^(self compiler decompileMethod: self) formattedCode! !

!CompiledMethod methodsFor: '*Tool-CriticBrowser' stamp: ''!
populateCBMenu: aMenu
	
	super populateCBMenu: aMenu.
	aMenu
		add: 'Implementors of...'
		target: SystemNavigation new
		selector: #browseAllImplementorsOf:
		argument: self selector;
		
		add: 'Senders of...'
		target: SystemNavigation new
		selector: #browseAllSendersOf:
		argument: self selector! !

!CompiledMethod methodsFor: '*Renraku' stamp: ''!
banChecksForValidation
"returns ban levels that have to be checked before validation"

	^ { self . self methodClass }
! !

!CompiledMethod methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGMethod named: self selector asSymbol parent: (self methodClass asRingMinimalDefinitionIn: anRGEnvironment)]
! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
reflectiveMethod
	^self propertyAt: #reflectiveMethod ifAbsent: nil! !

!CompiledMethod methodsFor: '*OpalCompiler-Core' stamp: ''!
sourceNode
	^self ast! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
variableReadNodes
	^self ast variableReadNodes! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isTaggedWith: aSymbol
	"Not methods tags implemented by protocols. Look #tags comment"
	^self protocol == aSymbol! !

!CompiledMethod methodsFor: '*Ring-Core' stamp: ''!
ensureRingDefinitionIn: anRGEnvironment

	| parentModel |
	
	parentModel := (self methodClass ensureRingDefinitionIn: anRGEnvironment).
	
	^ parentModel methods 
		detect: [:each | each selector = self selector]
		ifNone: [ 
			| methodModel |
			methodModel := self asRingMinimalDefinitionIn: anRGEnvironment.
			parentModel addLocalMethod: methodModel.
			methodModel ]	! !

!CompiledMethod methodsFor: 'private' stamp: ''!
penultimateLiteral
	"Answer the penultimate literal of the receiver, which holds either
	 the receiver's selector or its properties (which will hold the selector)."
	| pIndex |
	^(pIndex := self numLiterals - 1) > 0 
		ifTrue: [self literalAt: pIndex]
		ifFalse: [nil]! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isRequired
	"A method is required if it is a method declaring a subclass responsibility or an explicit requirement. This mean the method needs to be overriden (in case of subclass reponsibility) or implemented (in case of explicit requirement)."

	^ self isRequired: self markerOrNil! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isReturnField
	"Answer whether the receiver is a quick return of an instance variable."
	^ self primitive between: 264 and: 519! !

!CompiledMethod methodsFor: '*OpalCompiler-Core' stamp: ''!
decompile
	^Smalltalk globals 
		at: #FBDDecompiler
		ifPresent: [ :decompiler | decompiler new  decompile: self]  
		ifAbsent: [ RBParser parseMethod: self selector asMethodPreamble, '
	self noSourceAvailable' ]! !

!CompiledMethod methodsFor: '*System-Support' stamp: ''!
referencedClasses

	"Return classes that are directly referenced by this method. 
	We only take globals into account, class vars are skipped.
	It traverses all the compiled methods to get the classes"

	| result |
	result := IdentitySet new.
	self withAllNestedLiteralsDo: [ :each | 
		(each isVariableBinding and: [ 
			 each isGlobalVariable and: [ each read isClass ] ]) ifTrue: [ 
			result add: each value ] ].
	^ result! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isRequired: marker
	marker ifNil: [^ false].
	(self isExplicitlyRequired: marker) ifTrue: [^ true]. 
	(self isSubclassResponsibility: marker) ifTrue: [^ true]. 
	^ false! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
instanceVariableReadNodes
	^self ast instanceVariableReadNodes! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
endPC
	"Answer the index of the last bytecode, as the trailer size varies we have to delegate"
	^ self trailer endPC! !

!CompiledMethod methodsFor: 'printing' stamp: ''!
isSelfEvaluating

	^self methodClass notNil and: [self isDoIt not]! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isExplicitlyRequired: marker
	^ marker == self class explicitRequirementMarker! !

!CompiledMethod methodsFor: '*Roassal3' stamp: ''!
dependentClassesWithOccurences
	"Return the list of classes used myself. The result contains my superclass. The result may contains multiple times the same element."
	
	"(Morph>>#drawOn:) dependentClassesWithOccurences"
	"(CompiledMethod>>#dependentClassesWithOccurences) dependentClassesWithOccurences"
	| cll | 
	cll := OrderedCollection new.
	
	"We unify a class and its metaclass"
	self literalsDo: [ :l | 
					"We also check if the method is not an extension"
					((l isVariableBinding 
					and: [ l value notNil ]) 
					and: [ l value isBehavior ])  ifTrue: [ cll add: l value ] ].
	^ cll asArray! !

!CompiledMethod methodsFor: '*Calypso-SystemPlugins-FileOut-Queries' stamp: ''!
fileOut

	^self origin fileOutMethod: self selector! !

!CompiledMethod methodsFor: 'evaluating' stamp: ''!
valueWithReceiver: aReceiver arguments: anArray 
	^self receiver: aReceiver withArguments: anArray executeMethod: self! !

!CompiledMethod methodsFor: 'printing' stamp: ''!
printPrimitiveOn: aStream
	"Print the primitive on aStream"
	| primDecl |
	self isPrimitive ifFalse: [ ^self ].

	self isExternalCallPrimitive ifTrue:
		[^aStream print: (self literalAt: 1); cr].
	aStream nextPutAll: '<primitive: '.
	self isNamedPrimitive
		ifTrue:
			[primDecl := self literalAt: 1.
			 (primDecl at: 2) asString printOn: aStream.
			 (primDecl at: 1) ifNotNil:
				[:moduleName|
				aStream nextPutAll:' module: '.
				moduleName asString printOn: aStream]]
		ifFalse:
			[aStream print: self primitive].
	self primitiveErrorVariableName ifNotNil:
		[:primitiveErrorVariableName|
		 aStream nextPutAll: ' error: '; nextPutAll: primitiveErrorVariableName].
	aStream nextPut: $>; cr! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
hasSourceCode

	"Retrieve or reconstruct the source code for this method."
	| trailer source |
	trailer := self trailer.
	trailer sourceCode ifNotNil: [:code | ^ true ].
	trailer hasSourcePointer ifFalse: [^ false].

	"Situation normal;  read the sourceCode from the file"
	source := [self getSourceFromFile]
				on: Error
				do: [ :ex | ex return: nil].
	source isEmptyOrNil ifTrue: [^ false].			
	^ true! !

!CompiledMethod methodsFor: 'source code management' stamp: ''!
copyWithSource: aString
	^self copyWithTrailerBytes: (CompiledMethodTrailer new sourceCode: aString)! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
hasBreakpoint
	^ Breakpoint isInstalledIn: self
	
	! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
metaLinkOptions
	^{
	#penultimateLiteral -> #( + optionCompileOnLinkInstallation).
	#selector -> #( + optionCompileOnLinkInstallation).
	#objectAt: -> #( + optionCompileOnLinkInstallation).
	#header -> #( + optionCompileOnLinkInstallation).
	#numLiterals -> #( + optionCompileOnLinkInstallation).
	#literalAt: -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
newBreakpointForVariable: aVariableName
	^ (self tempNames includes: aVariableName)
		ifTrue: [ VariableBreakpoint
				newBreakpointForVariable: aVariableName
				forMethod: self ]
		ifFalse: [ VariableBreakpoint
				newBreakpointForVariable: aVariableName
				inClass: self methodClass ]! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
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: ''!
classBinding
	"answer the association to the class that I am installed in, or nil if none."
	^self literalAt: self numLiterals! !

!CompiledMethod methodsFor: 'private' stamp: ''!
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: 'accessing - pragmas & properties' stamp: ''!
removeProperty: propName
	"Remove the property propName if it exists.
	 Do _not_ raise an error if the property is missing."
	| value |
	value := self propertyAt: propName ifAbsent: [^nil].
	self penultimateLiteral: (self penultimateLiteral copyWithout:
									(Association
										key: propName
										value: value)).
	^value! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
variableWriteNodes
	^self ast variableWriteNodes! !

!CompiledMethod methodsFor: '*Renraku' stamp: ''!
critiques
	| critiques |
	
	critiques := ReCriticEngine critiquesOf: self.
	critiques :=
		critiques,
		(ReCriticEngine nodeCritiquesOf: self).
	
	^ critiques! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
variableNodes
	^self ast variableNodes! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isAbstract
	"Answer true if I am abstract"
	
	| marker |
	marker := self markerOrNil ifNil: [^false].
	
	^marker == self class subclassResponsibilityMarker 
		or: [ marker == self class explicitRequirementMarker ]! !

!CompiledMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForSendersFor: aStep
	<stSpotterOrder: 11>
	aStep listProcessor
			title: 'Senders';
			allCandidates: [ self senders collect: [:each | each compiledMethod] ];
			filter: StFilterSubstring;
			keyBinding: $n command! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isClassSide
	^self methodClass isClassSide! !

!CompiledMethod methodsFor: 'literals' stamp: ''!
pragmaRefersToLiteral: literal

	^ self penultimateLiteral isMethodProperties and: [ 
		  self pragmas anySatisfy: [ :pragma | pragma refersToLiteral: literal ] ]! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isInstalled
	self methodClass ifNotNil:
		[:class|
		self selector ifNotNil:
			[:selector|
			^self == (class compiledMethodAt: selector ifAbsent: nil)]].
	^false! !

!CompiledMethod methodsFor: '*Refactoring-Critics' stamp: ''!
superMessages
	^self ast superMessages ! !

!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
propertyAt: propName ifAbsent: aBlock
	| propertiesOrSelector |
	^(propertiesOrSelector := self penultimateLiteral) isMethodProperties
		ifTrue: [propertiesOrSelector propertyAt: propName ifAbsent: aBlock]
		ifFalse: [aBlock value]! !

!CompiledMethod methodsFor: '*Manifest-Core' stamp: ''!
criticTheNonMetaclassClass
	"Return the class of the receiver for the critic browser. This behavior may be folded later by changing the name of this method or using another one."
	
	^ self methodClass instanceSide! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
hasProperties
	^ self penultimateLiteral isMethodProperties! !

!CompiledMethod methodsFor: '*Monticello' stamp: 'nil'!
asMCMethodDefinition
   "Creates a MCMethodDefinition from the receiver"
	| cached |
	cached := MCMethodDefinition cachedDefinitions
		at: self
		ifAbsent: [ nil ].

	"we compare that the cached version is in sync with the version 
	the receiver represents because it is an identity structure and the container (here the method definition may have changed internally: different packages, protocol.... )"
	(cached notNil and: [ self sameAsMCDefinition: cached ]) ifFalse: [
		cached := self basicAsMCMethodDefinition.
		MCMethodDefinition cachedDefinitions 
			at: self 
			put: cached ].

	^ cached! !

!CompiledMethod methodsFor: '*System-Support' stamp: ''!
senders
	^ SystemNavigation default allSendersOf: self selector! !

!CompiledMethod methodsFor: '*DrTests' stamp: ''!
drTestsBrowse

	Smalltalk tools browser openOnClass: self methodClass selector: self selector! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isFromTrait
	"Return true for methods that have been included from Traits"
	^ self origin isTrait and: [ self origin ~= self methodClass ]! !

!CompiledMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
stActDefault
	^ self browse! !

!CompiledMethod methodsFor: 'accessing - tags' stamp: ''!
tags
	"Any method could be tagged with multiple symbols for user purpose. 
	For now we only define API to manage them implemented on top of method protocols.
	Protocol unclassified means that method is not tagged by anything"
	| protocol |
	protocol := self protocol.
	protocol ifNil: [ ^#() ].
	protocol = Protocol unclassified ifTrue: [ ^#() ].
	^{protocol}! !

!CompiledMethod methodsFor: '*Fuel-Core' stamp: ''!
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: '*OpalCompiler-Core' stamp: ''!
sourceNodeForPC: aPC
	^self sourceNode sourceNodeForPC: aPC! !

!CompiledMethod methodsFor: '*PharoDocComment' stamp: ''!
pharoDocCommentNodes
	"we try to avoid to have to create the AST if we are sure that we do not need it"
	^ (self sourceCode includesSubstring: '>>>')
		  ifTrue: [ self ast pharoDocCommentNodes ]
		  ifFalse: [ ^ #(  ) ]! !

!CompiledMethod methodsFor: '*Slot-Core' stamp: ''!
temporaryVariableNamed: aName
	(self hasTemporaryVariableNamed: aName) ifFalse: [ ^nil ].
	^self sourceNode scope lookupVar: aName

! !

!CompiledMethod methodsFor: 'printing' stamp: ''!
storeOn: aStream
	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' newMethod: '.
	aStream store: self size - self initialPC + 1.
	aStream nextPutAll: ' header: '.
	aStream store: self header.
	aStream nextPut: $).
	noneYet := self storeElementsFrom: self initialPC to: self endPC on: aStream.
	1 to: self numLiterals do:
		[:index |
		noneYet
			ifTrue: [noneYet := false]
			ifFalse: [aStream nextPut: $;].
		aStream nextPutAll: ' literalAt: '.
		aStream store: index.
		aStream nextPutAll: ' put: '.
		aStream store: (self literalAt: index)].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !

!CompiledMethod methodsFor: '*Manifest-Core' stamp: ''!
manifestBuilderForRuleChecker: aRuleChecker
	"Return the manifestsince the rulechecker is keeping a cache, we ask it back"

	^ aRuleChecker manifestBuilderOfMethod: self! !

!CompiledMethod methodsFor: '*UnifiedFFI' stamp: ''!
ffiArgumentNames
	"Answer the method's argument names. We using a separate method, 
	to get arg names not from source code directly, but from method properties, collected at
	compile time. Useful, when there is no source code available (for some reason)"

	^ self
		  propertyAt: #ffiArgumentNames
		  ifAbsent: [ self propertyAt: #ffiArgumentNames put: self argumentNames ]! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
hasMetaLinks
	self reflectiveMethod ifNil: [ ^false ].
	^self reflectiveMethod hasMetaLinks. ! !

!CompiledMethod methodsFor: 'source code management' stamp: ''!
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."

	^ [ SourceFiles sourceCodeAt: self sourcePointer ] on: Error do: [ '' ]! !

!CompiledMethod methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inpectionIr
	<inspectorPresentationOrder: 35 title: 'IR'>

	^ SpTextPresenter new 
		text: (self ir longPrintString trimmed);
		yourself
! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isCompiledMethod

	^ true! !

!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
hasPragmaNamed: aSymbol
	^ self pragmas anySatisfy: [ :pragma | pragma selector = aSymbol ]! !

!CompiledMethod methodsFor: '*TraitsV2' stamp: ''!
traitSource
	^ self propertyAt: #traitSource! !

!CompiledMethod methodsFor: '*Renraku' stamp: ''!
overriddenMethods
	"all the methods of my superclasses that are overriden by me"
	| selector |
	selector := self selector.
	^ self methodClass allSuperclasses
		select: [ :class | class includesSelector: selector ]
		thenCollect: [ :class | class compiledMethodAt: selector ]! !

!CompiledMethod methodsFor: '*AST-Core' stamp: ''!
parseTree
	"returns an AST for this method, do not cache it. (see #ast for the cached alternative)"
	| ast |
	ast := self methodClass compiler 
		source: self sourceCode;
		failBlock: [^ self decompile ];
		parse.
	ast compilationContext compiledMethod: self.
	^ast! !

!CompiledMethod methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asActiveRingDefinition
	"Retrieves an active RGMethodDefinition object based on the data of the receiver.
	Source, protocol and stamp are retrieved from the compiled method"
	
	^ RGMethodDefinition new 
			name: self selector;
			parentName: self methodClass name;
			isMetaSide: self methodClass isMeta;
			asActive.
! !

!CompiledMethod methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
methodReference

	| class selector |
	class := self methodClass ifNil: [^nil].
	selector := self selector ifNil: [^nil].
	^(RGMethodDefinition realClass: class selector: selector) 
		package: self package asRingDefinition; yourself
	! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
blockNodes
	^self ast blockNodes! !

!CompiledMethod methodsFor: '*Manifest-Core' stamp: ''!
criticClass
	"Return the class of the receiver for the critic browser. This behavior may be folded later by changing the name of this method or using another one."
	
	^ self methodClass! !

!CompiledMethod methodsFor: '*Calypso-SystemQueries' stamp: ''!
isBigLiteralMethod

	^ self isLiteralMethod 
		and: [ self literals anySatisfy: [ :literal | 
				literal class isVariable and: [ literal size > 500 ] ] ]! !

!CompiledMethod methodsFor: '*SUnit-Core' stamp: ''!
isPassedTest
	"Is the receiver a test method that passed?"

	^ self methodClass isTestCase
		and: [ self methodClass methodPassed: self selector ]! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
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: '*OpalCompiler-Core' stamp: ''!
irPrimitive

	| primNode n |
	primNode := IRPrimitive new num: (n := self primitive).
	(n = 117 or: [n = 120]) ifTrue: [
		primNode spec: (self literalAt: 1)].
	^ primNode! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isBinarySelector
	^self selector
		allSatisfy: [:each | each isSpecial]! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
instanceVariableWriteNodes
	^self ast instanceVariableWriteNodes! !

!CompiledMethod methodsFor: '*System-Sources' stamp: ''!
putSource: source withPreamble: preambleBlock
	"Store the source code for the receiver on an external file."

	SourceFiles 
		writeSource: source 
		preamble: (String streamContents: preambleBlock)
		onSuccess: [ :newSourcePointer :theChangesFileStream |
			"Method chunk needs a final !! !!"
			(SourceChunkWriteStream on: theChangesFileStream) nextPut: ' '.
			"Update with new source pointer"
			self setSourcePointer: newSourcePointer ]
		onFail: [ 
			self becomeForward: (self copyWithSource: source) ]
! !

!CompiledMethod methodsFor: '*OpalCompiler-Core' stamp: ''!
ir
	"We as the AST for the IR... for decompiling ir from bytecode, look at IRBytecodeDecompiler"
	^ self ast ir! !

!CompiledMethod methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asRingDefinition
	"Retrieves an active RGMethodDefinition object based on the receiver.
	Note that its class is not converted."
	
	^ self asActiveRingDefinition! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toVariableNamed: vName option: accessStrategy
	^aMetaLink
		installOnVariable: (self lookupVar: vName)
		for: self methodClass
		option: accessStrategy
		instanceSpecific: false! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
assignmentNodes
	^self ast assignmentNodes! !

!CompiledMethod methodsFor: '*Refactoring-Critics' stamp: ''!
selfMessages
	^self ast selfMessages! !

!CompiledMethod methodsFor: '*Renraku' stamp: ''!
banLevelCandidates
"returns code entities which can ban a rule for this entity"

	^ { self } , self methodClass banLevelCandidates! !

!CompiledMethod methodsFor: '*UnifiedFFI' stamp: ''!
isFFIMethod
	
	^ self hasProperty: #isFFIMethod! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
reflectiveMethod: aReflectiveMethod
	self propertyAt: #reflectiveMethod put: aReflectiveMethod! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
flushCache
	"Tell the virtual machine to remove all references to this method from its method lookup caches, and to discard any optimized version 	of the method, if it has any of these.  This must be done whenever a method is modified in place, such as modifying its literals or 	machine code, to reflect the revised code.  c.f. Behavior>>flushCache & Symbol>>flushCache.  Essential.	 See MethodDictionary class 	comment."

	<primitive: 116>! !

!CompiledMethod methodsFor: '*Calypso-SystemPlugins-InheritanceAnalysis-Queries' stamp: ''!
isOverriding

	^(self origin superclass ifNotNil: [ :c | c lookupSelector: self selector]) notNil! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
containsHalt

	^ self hasProperty: #containsHalt! !

!CompiledMethod methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
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 := (RGMethodDefinition named: 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: '*Calypso-SystemQueries' stamp: ''!
calypsoEnvironmentType
	^ClyMethod! !

!CompiledMethod methodsFor: 'printing' stamp: ''!
displayStringOn: aStream
	aStream print: self methodClass; nextPutAll: '>>'; store: self selector.! !

!CompiledMethod methodsFor: 'source code management' stamp: ''!
tempNames
	"on the level of the compiled method, tempNames includes argument names"
	^self ast argumentNames, self ast temporaryNames! !

!CompiledMethod methodsFor: '*Manifest-Core' stamp: ''!
mcWorkingCopy
	 MCWorkingCopy managersForClass: self methodClass selector: self selector do: [ :package | ^ package ]! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isSubclassResponsibility
	^ self isSubclassResponsibility: self markerOrNil! !

!CompiledMethod methodsFor: '*RPackage-Core' stamp: ''!
isExtensionInPackage: anRPackage
	^ anRPackage includesExtensionSelector: self selector ofClass: self methodClass! !

!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
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 ]! !

!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
hasProperty: aKey

	| extendedMethodState |
	^ (extendedMethodState := self penultimateLiteral) isMethodProperties
		  ifTrue: [  extendedMethodState includesProperty: aKey ]
		  ifFalse: [ false ]! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
primitive
	"Answer the primitive index associated with the receiver.
	 Zero indicates that this is not a primitive method."
	| initialPC |
	^(self header anyMask: 65536) "Is the hasPrimitive? flag set?"
		ifTrue: [(self at: (initialPC := self initialPC) + 1) + ((self at: initialPC + 2) bitShift: 8)]
		ifFalse: [0]! !

!CompiledMethod methodsFor: 'source code management' stamp: ''!
getPreambleFrom: aFileStream at: position
	^ SourceFiles getPreambleFrom: aFileStream at: position! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
method
	"polymorphic with closure"

	^ self! !

!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
propertyKeysAndValuesDo: aBlock
	"Enumerate the receiver with all the keys and values."

	| propertiesOrSelector |
	(propertiesOrSelector := self penultimateLiteral) isMethodProperties ifTrue:
		[propertiesOrSelector propertyKeysAndValuesDo: aBlock]! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
trailer
	"Answer the receiver's trailer"
	^ CompiledMethodTrailer new method: self! !

!CompiledMethod methodsFor: '*Calypso-SystemQueries' stamp: ''!
isLiteralMethod

	^ self bytecode = self encoderClass literalMethodBytecodes! !

!CompiledMethod methodsFor: 'copying' stamp: ''!
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: '*OpalCompiler-Core' stamp: ''!
decompileIR
	
	^ IRBytecodeDecompiler new decompile: self! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
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: '*Keymapping-Core' stamp: ''!
isShortcutDeclaration
	^ self pragmas anySatisfy: [ :p | p selector = #shortcut ]! !

!CompiledMethod methodsFor: 'accessing - tags' stamp: ''!
untagFrom: aSymbol
	"Any method could be tagged with multiple symbols for user purpose. 
	This method should remove given tag from it. All other tags should not be changed. 
	But now we could implemented tags with protocols which allow only tag for method.
	And to remove tag from method we must change it protocol to Protocol unclassified"
	self protocol = aSymbol ifTrue: [ 
		self protocol: Protocol unclassified]! !

!CompiledMethod methodsFor: 'accessing - pragmas & properties' stamp: ''!
pragmasDo: aBlock
	| selectorOrProperties |
	(selectorOrProperties := self penultimateLiteral) isMethodProperties
		ifTrue: [selectorOrProperties pragmasDo: aBlock]! !

!CompiledMethod methodsFor: 'debugger support' stamp: ''!
stepIntoQuickMethods: aBoolean
	^self propertyAt: #stepIntoQuickMethod put: aBoolean! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
protocol
	"Return in which protocol (conceptual groups of methods) the receiver is grouped into."

	^ self category! !

!CompiledMethod methodsFor: 'accessing' stamp: ''!
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: '*DrTests-TestCoverage' stamp: ''!
drTestsName
	^ self printString! !

!CompiledMethod methodsFor: '*Reflectivity' stamp: ''!
reflectivityDisabled
	^self hasPragmaNamed: #disableReflectivity! !

!CompiledMethod methodsFor: '*RPackage-Core' stamp: ''!
isDefinedInPackage: anRPackage
	^ anRPackage includesDefinedSelector: self selector ofClass: self methodClass! !

!CompiledMethod methodsFor: 'private' stamp: ''!
markerOrNil
	^ self encoderClass markerOrNilFor: self! !

!CompiledMethod methodsFor: '*Renraku' stamp: ''!
ban: aCritique

	ReSystemAnnouncer uniqueInstance
		notifyCritique: aCritique
		of: aCritique sourceAnchor entity
		bannedOn: self.

	(TheManifestBuilder of: self)
		banRule: aCritique rule for: self.! !

!CompiledMethod methodsFor: '*AST-Core' stamp: ''!
comments
	"Answer a collection of strings representing the comments in the method. Return an empty collection if the method's source code does not contain a comment."

	^ self ast allComments collect: [:c| c contents]! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isConflict
	^ self markerOrNil == self class conflictMarker! !

!CompiledMethod methodsFor: 'testing' stamp: ''!
isReturnSpecial
	"Answer whether the receiver is a quick return of self or constant."

	^ self primitive between: 256 and: 263! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
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: ''!
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: ''!
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."
	| method pc |
	nArgs > 15 ifTrue:
		[^self error: 'Cannot compile -- too many arguments'].
	nTemps > 63 ifTrue:
		[^self error: 'Cannot compile -- too many temporary variables'].	
	nLits > 65535 ifTrue:
		[^self error: 'Cannot compile -- too many literals'].

	method := trailer
				createMethod: numberOfBytes
				class: self
				header:    (nArgs bitShift: 24)
						+ (nTemps bitShift: 18)
						+ ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0])
						+ nLits
						+ (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0])
						+ (flag ifTrue: [1 bitShift: 29] ifFalse: [0]).
	primitiveIndex > 0 ifTrue:
		[pc := method initialPC.
		 method
			at: pc + 0 put: method encoderClass callPrimitiveCode;
			at: pc + 1 put: (primitiveIndex bitAnd: 16rFF);
			at: pc + 2 put: (primitiveIndex bitShift: -8)].
	^method! !

!CompiledMethod class methodsFor: 'private' stamp: ''!
handleFailingFailingNewMethod: numberOfBytes header: headerWord
	"This newMethod:header: gets sent after handleFailingBasicNew: has done a full
	 garbage collection and possibly grown memory.  If this basicNew: fails then the
	 system really is low on space, so raise the OutOfMemory signal.

	 Primitive. Answer an instance of this class with the number of indexable variables
	 specified by the argument, headerWord, and the number of bytecodes specified
	 by numberOfBytes.  Fail if this if the arguments are not Integers, or if numberOfBytes
	 is negative, or if the receiver is not a CompiledMethod class, or if there is not enough
	 memory available. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 79>
	"space must be low."
	OutOfMemory signal.
	"retry if user proceeds"
	^self newMethod: numberOfBytes header: headerWord! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
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: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 264 + field! !

!CompiledMethod class methodsFor: 'class initialization' stamp: ''!
installPrimaryBytecodeSet: aBytecodeEncoderSubclass
	PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue:
		[ ^self ].
	self checkIsValidBytecodeEncoder: aBytecodeEncoderSubclass.
	self checkBytecodeSetConflictsInMethodsWith: [:m| 
		m usesPrimaryBytecodeSet and: [m encoderClass ~~ aBytecodeEncoderSubclass]].
	PrimaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
toReturnSelfTrailerBytes: trailer
	"Answer an instance of me that is a quick return of the instance (^self)."

	^self newBytes: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256! !

!CompiledMethod class methodsFor: 'accessing - class hierarchy' stamp: ''!
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: ''!
fullFrameSize  "CompiledMethod fullFrameSize"
	^ LargeFrame! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
basicNew

	self error: 'CompiledMethods may only be created with newMethod:header:'! !

!CompiledMethod class methodsFor: 'constants' stamp: ''!
subclassResponsibilityMarker
	^ #subclassResponsibility! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
cleanUpSourceInTrailers

	self allInstances do: [:e | e isInstalled ifFalse: [e embeddSourceInTrailer]].  
	"pay attention since embeddSourceInTrailer creates a new compiled method. So iterating while
	changing it is a bad idea. This is why we use allInstances do and not allInstancesDo:"! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
basicNew: size

	self error: 'CompiledMethods may only be created with newMethod:header:'! !

!CompiledMethod class methodsFor: 'constants' stamp: ''!
abstractMarker
	^ #subclassResponsibility! !

!CompiledMethod class methodsFor: 'constants' stamp: ''!
disabledMarker
	^ #shouldNotImplement! !

!CompiledMethod class methodsFor: 'class initialization' stamp: ''!
installSecondaryBytecodeSet: aBytecodeEncoderSubclass
	PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue:
		[ ^ self ].
	self checkIsValidBytecodeEncoder: aBytecodeEncoderSubclass.
	self checkBytecodeSetConflictsInMethodsWith: [ :m | 
		m usesSecondaryBytecodeSet and: [ m encoderClass ~~ aBytecodeEncoderSubclass ] ].
	SecondaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
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."
	| method pc |
	nArgs > 15 ifTrue:
		[^self error: 'Cannot compile -- too many arguments'].
	nTemps > 63 ifTrue:
		[^self error: 'Cannot compile -- too many temporary variables'].	
	nLits > 65535 ifTrue:
		[^self error: 'Cannot compile -- too many literals'].

	method := trailer
				createMethod: numberOfBytes
				class: self
				header:    (nArgs bitShift: 24)
						+ (nTemps bitShift: 18)
						+ ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0])
						+ nLits
						+ (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0]).
	primitiveIndex > 0 ifTrue:
		[pc := method initialPC.
		 method
			at: pc + 0 put: method encoderClass callPrimitiveCode;
			at: pc + 1 put: (primitiveIndex bitAnd: 16rFF);
			at: pc + 2 put: (primitiveIndex bitShift: -8)].
	^method! !

!CompiledMethod class methodsFor: 'class initialization' stamp: ''!
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.
	PrimaryBytecodeSetEncoderClass := nil. "Old encoder was removed"
	SecondaryBytecodeSetEncoderClass := EncoderForSistaV1! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
headerFlagForEncoder: anEncoderClass
	anEncoderClass == PrimaryBytecodeSetEncoderClass ifTrue: [ ^ 0 ].
	anEncoderClass == SecondaryBytecodeSetEncoderClass ifTrue: [ ^ SmallInteger minVal ].
	self error: 'The encoder is not one of the two installed bytecode sets'! !

!CompiledMethod class methodsFor: 'class initialization' stamp: ''!
smallFrameSize

	^ SmallFrame! !

!CompiledMethod class methodsFor: 'constants' stamp: ''!
conflictMarker
	^ #traitConflict! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
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: 'constants' stamp: ''!
explicitRequirementMarker
	^ #explicitRequirement! !

!CompiledMethod class methodsFor: 'private' stamp: ''!
handleFailingNewMethod: numberOfBytes header: headerWord
	"This newMethod:header: gets sent after newMethod:header: has failed
	 and allowed a scavenging garbage collection to occur.  The scavenging
	 collection will have happened as the VM is activating the (failing) basicNew:.
	 If handleFailingBasicNew: fails then the scavenge failed to reclaim sufficient
	 space and a global garbage collection is required.  Retry after garbage
	 collecting and growing memory if necessary.

	 Primitive. Answer an instance of this class with the number of indexable variables
	 specified by the argument, headerWord, and the number of bytecodes specified
	 by numberOfBytes.  Fail if this if the arguments are not Integers, or if numberOfBytes
	 is negative, or if the receiver is not a CompiledMethod class, or if there is not enough
	 memory available. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 79>
	| bytesRequested |
	bytesRequested := (headerWord bitAnd: 16rFFFF) + 1 * Smalltalk wordSize + numberOfBytes + 16.
	Smalltalk garbageCollect < bytesRequested ifTrue:
		[Smalltalk growMemoryByAtLeast: bytesRequested].
	"retry after global garbage collect and possible grow"
	^self handleFailingFailingNewMethod: numberOfBytes header: headerWord! !

!CompiledMethod class methodsFor: '*Collections-Abstract' stamp: ''!
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: 'instance creation' stamp: ''!
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: 'class initialization' stamp: ''!
checkIsValidBytecodeEncoder: aBytecodeEncoderSubclass
	(aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse:
		[self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder'].! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
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: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 + index! !

!CompiledMethod class methodsFor: 'instance creation' stamp: ''!
newInstanceFrom: oldInstance variable: variable size: instSize map: map
	"Create a new instance of the receiver based on the given old instance.
	The supplied map contains a mapping of the old instVar names into
	the receiver's instVars"
	| new |
	new := self newFrom: oldInstance.
	1 to: instSize do: 
		[:offset |  (map at: offset) > 0 ifTrue:
			[new instVarAt: offset
					put: (oldInstance instVarAt: (map at: offset))]].
	^new! !

!CompiledMethod class methodsFor: 'class initialization' stamp: ''!
checkBytecodeSetConflictsInMethodsWith: aBlock

	self allSubInstances
		detect: aBlock
		ifFound: [ Warning signal: 'There are existing CompiledMethods with a different encoderClass.' ]! !

!CompiledMethodLayout commentStamp: ''!
I am a special layout version for CompiledMethods. 
Unlike default Object layouts, CompiledMethods define a custom format integer since they mix bytes and pointer types.

See CompiledMethod for more details.!
!CompiledMethodLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	 ^ 24! !

!CompiledMethodLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGCompiledMethodLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)]
! !

!CompiledMethodLayout methodsFor: 'extending' stamp: ''!
extend
	self error: 'CompiledMethodLayout can not be extendend'! !

!CompiledMethodLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else!!"
	"there is no way to define classes of this Layput, the system shows them as variable classes"
	^#variableByteSubclass:! !

!CompiledMethodLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass
	^ superLayout extendCompiledMethod
		host: aClass;
		yourself! !

!CompiledMethodLayout class methodsFor: '*Monticello' stamp: 'nil'!
mcTypeSymbol 
	^ #compiledMethod ! !

!CompiledMethodTest commentStamp: ''!
This is the unit test for the class CompiledMethod. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- there is a chapter in the PharoByExample book (http://pharobyexample.org)
	- the sunit class category!
!CompiledMethodTest methodsFor: 'examples' stamp: ''!
returnTrue
	^true! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locEmptyMethod! !

!CompiledMethodTest methodsFor: 'tests - pragmas' stamp: ''!
testPragmaAt

	| method |
	method := (SmallInteger >> #+) copy.
	self
		assert: (method pragmaAt: #primitive:) selector
		equals: #primitive:.
	self assert: (method pragmaAt: #hello) equals: nil.
	method propertyAt: #hello put: true.
	"Pragmas are not Properties!!"
	self assert: (method pragmaAt: #hello) equals: nil! !

!CompiledMethodTest methodsFor: 'private - accessing' stamp: ''!
categoryNameForTemporaryClasses
	"Answer the category where to classify temporarily created classes"

	^'Dummy-Tests-Class'! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
deprecatedMethod3
	"Used to test sends of deprecation messages;
	do not recategorize in one of the 'deprecated' categories."

	self
		deprecated: 'Example of a deprecated method with transform'
		transformWith: '`@receiver deprecatedMethod3' 
						-> '`@receiver deprecatedMethod3'.! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
deprecatedMethod4
	"Used to test sends of deprecation messages;
	do not recategorize in one of the 'deprecated' categories."

	self
	
		deprecated: 'Example of a deprecated method with transform'
		on: '01/01/1970'
		in: #Pharo6
		transformWith: '`@receiver deprecatedMethod4' 
						-> '`@receiver deprecatedMethod4'.! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
readXandY
	
	^ x + y! !

!CompiledMethodTest methodsFor: 'tests - comparing' stamp: ''!
testMethodsThatHaveOnlyDifferentSelectorsShouldBeDifferent
	| method1 method2 |
	method1 := TestCase compiler compile: 'aMethod'.
	method2 := TestCase compiler compile: 'aMethod2'.

	self assert: (method1 literalAt: method1 numLiterals) identicalTo: (method2 literalAt: method2 numLiterals).
	self deny: method1 equals: method2! !

!CompiledMethodTest methodsFor: 'tests - instance variable' stamp: ''!
testHasInstVarRef
		
	| method  |
	method := self class compiledMethodAt: #readX.
	self assert: (method hasInstVarRef).

	method := self class compiledMethodAt: #readXandY.
	self assert: (method hasInstVarRef).
	
	method := self class compiledMethodAt: #writeX.
	self assert: (method hasInstVarRef).
	
	method := self class compiledMethodAt: #writeXandY.
	self assert: (method hasInstVarRef).! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
abstractMethod
	"I am an abstract method"
	
	^ self subclassResponsibility! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: ''!
testIsFaulty
	|  cm |
	cm := OpalCompiler new
				source: 'method 3+';
				options: #(+ optionParseErrors +optionEmbeddSources);
				compile.
	self assert: cm isFaulty.
	self deny: (OCASTTranslator>>#visitParseErrorNode:) isFaulty! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locMultilineMethodCommentWithoutWhitespace
"Comment"
	^ 1! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
deprecatedMethod2
	"Used to test sends of deprecation messages;
	do not recategorize in one of the 'deprecated' categories."

	self deprecated: 'example of a deprecated method' on: 'date' in: 'someversion'.! !

!CompiledMethodTest methodsFor: 'tests - literals' stamp: ''!
testHasLiteralSuchThat
	"#literals should not expose implementation hack that the last two literals are 
	used for name of method and class"

	self deny: (Object >> #yourself hasLiteralSuchThat: [ :lit | lit == #yourself ]).
	self assert: (Object >> #halt hasLiteralSuchThat: [ :lit | lit == #now ]).! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locEmptyMethodWithNewline! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeSimpleCase
	| method |
	method := self class >> #locSimple.
	self assert: method linesOfCode equals: 6.! !

!CompiledMethodTest methodsFor: 'tests' stamp: ''!
testCopyWithTrailerBytes
	<pragma: #pragma>
	| method copy |
	method := thisContext method.
	self assert: method pragmas notEmpty.
	copy := method copyWithTrailerBytes: method trailer.
	self assert: (method equivalentTo: copy).
	self deny: method identicalTo: copy.
	self assert: method symbolic equals: copy symbolic.	"but their bytecode should be the same"
	self assert: method ~~ copy.
	self assert: copy penultimateLiteral method identicalTo: copy.
	self assert: method penultimateLiteral method identicalTo: method.
	method pragmas do: [ :p | self assert: p method identicalTo: method ].
	copy pragmas do: [ :p | self assert: p method identicalTo: copy ]! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: ''!
testIsClassSide
	self deny: (Object>>#yourself) isClassSide.
	self assert: (Object class>>#initialize) isClassSide.! !

!CompiledMethodTest methodsFor: 'tests - accessing' stamp: ''!
testComments
	"I am the first comment to be found in this test"
	self
		assert: (CompiledMethodTest >> #testComments) comments first 
	"And I am the second comment to be found in this test"
		equals: 'I am the first comment to be found in this test'.
	self
		assert: (CompiledMethodTest >> #testComments) comments second
		equals: 'And I am the second comment to be found in this test'.
	"Next test assumes #compiledMethod has no comment..."
	self assert: (CompiledMethod >> #compiledMethod) comments isEmpty! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeSingleLineComment
	| method |
	method := self class >> #locSingleLineComment.
	self assert: method linesOfCode equals: 3.! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeSingleLineCommentWithoutWhitespace
	| method |
	method := self class >> #locSingleLineCommentWithoutWhitespace.
	self assert: method linesOfCode equals: 3.! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locEmptyLineWithTabInTheEnd
	| a |
	a := 1.
	^ a! !

!CompiledMethodTest methodsFor: 'tests - accessing' stamp: ''!
testBytecode
	"The result of this test depends on the used bytecode set. 
	
	 Because there are multiple versions of the encoders currently depending on the compiler used, we test the class name instead of the encoder class itself"
	| method expectedResult |
	method := Object>>#halt.
	expectedResult := (method encoderClass name endsWith: 'SistaV1')
		ifTrue: [#[16 129 216 88]]
		ifFalse: [#[64 209 135 120]].
	self assertCollection: (Object>>#halt) bytecode equals: expectedResult! !

!CompiledMethodTest methodsFor: 'tests' stamp: ''!
testCopy
	<pragma: #pragma>
	| method copy |
	method := thisContext method.
	self assert: method pragmas notEmpty.
	copy := method copy.
	self assert: (method equivalentTo: copy).
	self assert: method header equals: copy header.
	self assert: method equals: copy.
	self assert: method ~~ copy.
	self assert: copy penultimateLiteral method identicalTo: copy.
	self assert: method penultimateLiteral method identicalTo: method.
	method pragmas do: [ :p | self assert: p method identicalTo: method ].
	copy pragmas do: [ :p | self assert: p method identicalTo: copy ]! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locEmptyLineInTheMiddle
	| a |
	a := 1.

	^ a! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: ''!
testIsDeprecated
	| deprecatedSelectors |
	deprecatedSelectors := #(deprecatedMethod deprecatedMethod2 deprecatedMethod3 deprecatedMethod4).
	self class selectorsDo: [ :each |
		(deprecatedSelectors includes: each)
			ifTrue: [ self assert: (self class >> each) isDeprecated ]
			ifFalse: [ self deny: (self class >> each) isDeprecated ] ]! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeMultilineMethodComment
	| method |
	method := self class >> #locMultilineMethodComment.
	self assert: method linesOfCode equals: 4.! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeEmptyLineWithTabInTheMiddle
	| method |
	method := self class >> #locEmptyLineWithTabInTheMiddle.
	self assert: method linesOfCode equals: 4.! !

!CompiledMethodTest methodsFor: 'running' stamp: ''!
tearDown
	RPackage organizer unregisterPackageNamed: self categoryNameForTemporaryClasses.
	super tearDown! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locSingleLineMethodCommentWithoutWhitespace
"Comment"
	^ 1! !

!CompiledMethodTest methodsFor: 'tests - slots' stamp: ''!
testAccessesSlot

	"Check the source code availability to do not fail on images without sources"
	({ Point>>#x. Point>>#setX:setY: } allSatisfy: #hasSourceCode) 
		ifFalse: [ ^ self ].
	
	self assert: ((Point>>#x) accessesSlot: (Point slotNamed: #x)).
	self deny: ((Point>>#x) accessesSlot: (Point slotNamed: #y)).
	self assert: ((Point>>#setX:setY:) accessesSlot: (Point slotNamed: #y)).! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: ''!
testSendsSelector
	self assert: ((CompiledCode >> #sendsSelector:) sendsSelector: #includes:).
	self deny: ((CompiledCode >> #sendsSelector:) sendsSelector: #doBreakfastForMe)! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeSingleLineMethodComment
	| method |
	method := self class >> #locSingleLineMethodComment .
	self assert: method linesOfCode equals: 3.! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeEmptyMethod
	| method |
	method := self class >> #locEmptyMethod.
	self assert: method linesOfCode equals: 1.! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
readX
	| tmp |
	tmp := x.
	^ tmp! !

!CompiledMethodTest methodsFor: 'tests - literals' stamp: ''!
testLiterals
	"#literals should not expose implementation hack that the last two literals are 
	used for name of method and class"

	self assertEmpty: (Object >> #yourself) literals.
	self assert: (Object >> #yourself) allLiterals size equals: 2.
	self deny: (Object >> #yourself hasLiteral: #yourself)! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
nonAbstractMethod
	"I am not an abstract method"
	
	^ 4 + 5! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeSingleLineMethodCommentWithoutWhitespace
	| method |
	method := self class >> #locSingleLineMethodCommentWithoutWhitespace.
	self assert: method linesOfCode equals: 3.! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
writeXandY
	
	x := 33.
	y := 66! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locSingleLineComment
	^ 1
	"Comment"! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
writeX
	
	x := 33! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locMultilineComment
	^ 1
	"Multiline
	comment"! !

!CompiledMethodTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ CompiledMethod! !

!CompiledMethodTest methodsFor: 'tests - evaluating' stamp: ''!
testValueWithReceiverArguments
	
	| method value |

	method := self class compiledMethodAt: #returnTrue.

	value := method valueWithReceiver: nil arguments: #().
	self assert: value equals: true.

	method := self class compiledMethodAt: #returnPlusOne:.
	value := method valueWithReceiver: nil arguments: #(1).
	self assert: value equals: 2.! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeMultilineComment
	| method |
	method := self class >> #locMultilineComment.
	self assert: method linesOfCode equals: 4.! !

!CompiledMethodTest methodsFor: 'tests - performing' stamp: ''!
a1: a1 a2: a2 a3: a3 a4: a4 a5: a5 a6: a6 a7: a7 a8: a8 a9: a9 a10: a10 a11: a11 a12: a12 a13: a13 a14: a14 a15: a15
	"I'm a method with the maximum size of arguments that can be executed via normal send but crash on perform :)"
	
	^ a1 + a2 - a2! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locSingleLineCommentWithoutWhitespace
	^ 1
"Comment"! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeMultilineCommentWithoutWhitespace
	| method |
	method := self class >> #locMultilineCommentWithoutWhitespace.
	self assert: method linesOfCode equals: 6.! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locEmptyLineInTheEnd
	| a |
	a := 1.
	^ a! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeAllInOne
	| method |
	method := self class >> #locComplex.
	self assert: method linesOfCode equals: 14.! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: ''!
testHasComment
	self assert: (CompiledMethod>>#hasComment) hasComment! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeEmptyLineWithTabInTheEnd
	| method |
	method := self class >> #locEmptyLineWithTabInTheEnd.
	self assert: method linesOfCode equals: 4.! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locMultilineMethodComment
	"Multiline
	comments"
	^ 1! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locComplex

	"A multiline
	comment"
	
"Non-indented Comment"
	
	| a b |
	a := 1.
	b :=
	a + 2.
	
	10 timesRepeat: [ 
		"Comment inside a block"
		#(1 2 3) collect: [ :each |
			| c |
			c := each + b.
			c "Comment at the end of a line" ] ].! !

!CompiledMethodTest methodsFor: 'tests - performing' stamp: ''!
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)) equals: 1.
	self assert: (self class>>#testPerformCanExecutelongMethodWithTemps) frameSize equals: CompiledMethod smallFrameSize.
	self assert: (self class>>#a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15:) frameSize equals: CompiledMethod fullFrameSize.! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locSimple
	| a b c |
	a := 1.
	b := a + 2.
	c := b * 3.
	^ 1 / c! !

!CompiledMethodTest methodsFor: 'tests - instance variable' stamp: ''!
testReadsField		
	| method |
	method := self class compiledMethodAt: #readX.
	self assert: (method readsField: 4).
	
	method := self class compiledMethodAt: #readXandY.
	self assert: (method readsField: 5).
	
	
	"read is not write"
	method := self class compiledMethodAt: #writeX.
	self deny: (method readsField: 4).
	
	method := self class compiledMethodAt: #writeXandY.
	self deny: (method readsField: 4).
	
	method := self class compiledMethodAt: #writeXandY.
	self deny: (method readsField: 5)! !

!CompiledMethodTest methodsFor: 'tests - converting' stamp: ''!
testAsString

	self assert: thisContext method asString isString! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
deprecatedMethod
	"Used to test sends of deprecation messages;
	do not recategorize in one of the 'deprecated' categories."

	self deprecated: 'example of a deprecated method'! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: ''!
testIsQuick
	| method  |

	method := self class compiledMethodAt: #returnTrue.
	self assert: (method isQuick).

	method := self class compiledMethodAt: #returnPlusOne:.
	self deny: (method isQuick).! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: ''!
testIsInstalled
|  method cls |

	method := (self class)>>#returnTrue.
	self assert: method isInstalled.

	

	Smalltalk removeClassNamed: #TUTU.

	cls := self class classInstaller make: [ :aBuilder | 
		aBuilder 
			name: #TUTU;
			package: self categoryNameForTemporaryClasses].

	cls compile: 'foo ^ 10'.
	method := cls >> #foo.

	"now make an orphaned method by just deleting the method."
	cls removeSelector: #foo.
	
	self deny: method isInstalled. 
	Smalltalk removeClassNamed: #TUTU.! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeEmptyLineInTheEnd
	| method |
	method := self class >> #locEmptyLineInTheEnd.
	self assert: method linesOfCode equals: 4.! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: ''!
testHasPragma

	| methodWithPragma methodWithOutPragma |
	methodWithPragma := (SmallInteger >> #+).
	methodWithOutPragma := thisContext method.
	
	self assert: methodWithPragma hasPragma.
	self deny: methodWithOutPragma hasPragma! !

!CompiledMethodTest methodsFor: 'tests - comparing' stamp: ''!
testEqualityInstanceSideMethod
	| method1 method2 |
	method1 := TestCase compiler compile: 'aMethod'.
	method2 := TestCase compiler compile: 'aMethod'.

	self assert: (method1 literalAt: method1 numLiterals) identicalTo: (method2 literalAt: method2 numLiterals).
	self assert: method1 equals: method2! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
returnPlusOne: anInteger
	^anInteger + 1.! !

!CompiledMethodTest methodsFor: 'tests - abstract' stamp: ''!
testIsAbstract

	self assert: (self class >> #abstractMethod) isAbstract.
	self deny: (self class >> #nonAbstractMethod) isAbstract.
	self deny: (self class >> #shouldNotImplementMethod) isAbstract! !

!CompiledMethodTest methodsFor: 'tests - slots' stamp: ''!
testWritesSlot

	"Check the source code availability to do not fail on images without sources"
	({ Point>>#x. Point>>#setX:setY: } allSatisfy: #hasSourceCode) 
		ifFalse: [ ^ self ].

	self deny: ((Point>>#x) writesSlot: (Point slotNamed: #x)).
	self deny: ((Point>>#x) writesSlot: (Point slotNamed: #y)).
	
	self assert: ((Point>>#setX:setY:) writesSlot: (Point slotNamed: #y)).
	self assert: ((Point>>#setX:setY:) writesSlot: (Point slotNamed: #x)).! !

!CompiledMethodTest methodsFor: 'examples' stamp: ''!
shouldNotImplementMethod
	"I am not an abstract method"
	
	^ self shouldNotImplement! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locEmptyLineWithTabInTheMiddle
	| a |
	a := 1.
	
	^ a! !

!CompiledMethodTest methodsFor: 'tests - accessing' stamp: ''!
testComparison
	| method1 method2 |
	method1 := Float class >> #nan.
	method2 := thisContext method.

	self assert: method1 equals: method1.
	self assert: method2 equals: method2.
	self deny: method1 equals: method2.
	self deny: method2 equals: method1.

	Object methods
		do: [ :each | 
			self deny: method1 equals: each.
			self deny: each equals: method1.
			self deny: method2 equals: each.
			self deny: each equals: method2 ]! !

!CompiledMethodTest methodsFor: 'tests - comparing' stamp: ''!
testEqualityClassSideMethod
   	| method1 method2 |

	method1 := TestCase class compiler
			compile: 'aMethod'.
		
	method2 := TestCase class compiler
			compile: 'aMethod'.
			
 	self assert: method1 equals: method2.! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeEmptyMethodWithNewline
	| method |
	method := self class >> #locEmptyMethodWithNewline.
	self assert: method linesOfCode equals: 1.! !

!CompiledMethodTest methodsFor: 'tests - performing' stamp: ''!
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) equals: 1! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locSingleLineMethodComment
	"Comment"
	^ 1! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeEmptyLineInTheMiddle
	| method |
	method := self class >> #locEmptyLineInTheMiddle.
	self assert: method linesOfCode equals: 4.! !

!CompiledMethodTest methodsFor: 'tests - accessing' stamp: ''!
testSelector
	Author
		useAuthor: 'TUTU_TEST'
		during: [ | method cls |
			method := self class >> #returnTrue.
			self assert: method selector equals: #returnTrue.

			"now make an orphaned method. new semantics: return corrent name"
			Smalltalk removeClassNamed: #TUTU.

			cls := self class classInstaller make: [ :aBuilder | 
				aBuilder 
					name: #TUTU;
					package: self categoryNameForTemporaryClasses].

			cls compile: 'foo ^ 10'.

			method := cls >> #foo.

			Smalltalk removeClassNamed: #TUTU.

			self assert: method selector equals: #foo ]! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeMultilineMethodCommentWithoutWhitespace
	| method |
	method := self class >> #locMultilineMethodCommentWithoutWhitespace.
	self assert: method linesOfCode equals: 3.! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locEmptyMethodWithNewlineAndTab! !

!CompiledMethodTest methodsFor: 'tests - accessing' stamp: ''!
testOrigin
	| regularMethod methodFromTrait |
	"Regular method"
	regularMethod := Behavior >> #name.

	"Method from a trait without alias "
	methodFromTrait := Behavior >> #adoptInstance:.

	self assert: regularMethod origin identicalTo: regularMethod originMethod methodClass.
	self assert: methodFromTrait origin identicalTo: methodFromTrait originMethod methodClass! !

!CompiledMethodTest methodsFor: 'tests - accessing' stamp: ''!
testMethodClass
	| method cls |
	method := self class >> #returnTrue.
	self assert: method selector equals: #returnTrue.
	"now make an orphaned method by just deleting the class.
	old: #unknown
	new semantics: return Absolete class"
	Smalltalk removeClassNamed: #TUTU.

	cls := self class classInstaller make: [ :aBuilder | 
		aBuilder 
			name: #TUTU;
			package: self categoryNameForTemporaryClasses].

	cls compile: 'foo ^ 10'.
	method := cls >> #foo.
	Smalltalk removeClassNamed: #TUTU.
	self assert: method methodClass equals: cls! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: ''!
testUsesUndeclareds
	| method |
	method := self class compiler compile: 'x ^x'.
	self deny: method usesUndeclareds.
	method := self class compiler compile: 'z ^z'.
	self assert: method usesUndeclareds.
	method := self class compiler compile: 'msg self in: [ :anObject | var1 := 1 ]'.
	self assert: method usesUndeclareds.! !

!CompiledMethodTest methodsFor: 'examples - linesofcode' stamp: ''!
locMultilineCommentWithoutWhitespace
	^ 1
"Multiline
comment
without
whitespaces"! !

!CompiledMethodTest methodsFor: 'tests - instance variable' stamp: ''!
testAccessesField		
	| method |
	method := self class compiledMethodAt: #readX.
	self assert: (method accessesField: 4).
	
	method := self class compiledMethodAt: #readXandY.
	self assert: (method accessesField: 5).
	
	
	"read is not write"
	method := self class compiledMethodAt: #writeX.
	self assert: (method accessesField: 4).
	
	method := self class compiledMethodAt: #writeXandY.
	self assert: (method accessesField: 4).
	
	method := self class compiledMethodAt: #writeXandY.
	self assert: (method accessesField: 5)! !

!CompiledMethodTest methodsFor: 'tests - instance variable' stamp: ''!
testWritesField	
	| method |
	method := self class compiledMethodAt: #writeX.
	self assert: (method writesField: 4).
	
	method := self class compiledMethodAt: #writeXandY.
	self assert: (method writesField: 4).
	
	method := self class compiledMethodAt: #writeXandY.
	self assert: (method writesField: 5).
	
	"write is not read"
	
	method := self class compiledMethodAt: #readX.
	self deny: (method writesField: 4).
	
	method := self class compiledMethodAt: #readXandY.
	self deny: (method writesField: 4).
	
	method := self class compiledMethodAt: #readXandY.
	self deny: (method writesField: 5).! !

!CompiledMethodTest methodsFor: 'tests - slots' stamp: ''!
testReadsSlot

	"Check the source code availability to do not fail on images without sources"
	({ Point>>#x. Point>>#setX:setY: } allSatisfy: #hasSourceCode) 
		ifFalse: [ ^ self ].

	self assert: ((Point>>#x) readsSlot: (Point slotNamed: #x)).
	self deny: ((Point>>#x) readsSlot: (Point slotNamed: #y)).
	self deny: ((Point>>#setX:setY:) readsSlot: (Point slotNamed: #y)).! !

!CompiledMethodTest methodsFor: 'tests - linesofcode' stamp: ''!
testLinesOfCodeEmptyMethodWithNewlineAndTab
	| method |
	method := self class >> #locEmptyMethodWithNewlineAndTab.
	self assert: method linesOfCode equals: 1.! !

!CompiledMethodTrailer commentStamp: ''!
I am responsible for encoding and decoding various kinds of compiled method trailer data.
I should not expose any binary data outside of myself, so all tools which working with compiled methods
should ask me to encode the meta-data, they want to be added to the compiled method trailer, as well as retrieve it.

To add a new kind of trailer, you should give it a proper name and define it in the #trailerKinds method at my class side.
Then you need to implement a corresponding #encode<your name> and #decode<your name> 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: 'creating a method' stamp: ''!
createMethod: numberOfBytesForAllButTrailer class: aCompiledMethodClass header: headerWord 
	| meth |
	"Instantiates a compiled method with this trailer.
	- numberOfBytesForAllButTrailer specifies the number of bytes needed to encode the literals and the bytecode.
	- aCompiledMethodClass specifies the concrete class of the compiled method.
	- headerWord specifies the header used for the compiled method.
	
	This method will create a compiled method instance of the correct size, set it's header and trailing bytes. The bytecode and literals must be set by the caller."
	
	encodedData ifNil: [ self encode ].
	
	meth := aCompiledMethodClass newMethod: numberOfBytesForAllButTrailer + size header: headerWord.
	"copy the encoded trailer data"
	1 to: size do:
		[:i | meth at: meth size - size + i put: (encodedData at: i)].

	^meth! !

!CompiledMethodTrailer methodsFor: 'testing' stamp: ''!
isEmpty
	^ kind == #NoTrailer or: [ kind == #ClearedTrailer ]! !

!CompiledMethodTrailer methodsFor: 'encoding' stamp: ''!
encodeEmbeddedSource
	"data is string with method's source code"

	| length str encodedLength | 
	length := data size.
	str := WriteStream on: (ByteArray new: length).
	encodedLength := self encodeLengthField: length.
	str 
		nextPutAll: data asByteArray;
		nextPutAll: encodedLength;	"trailing byte"
	 	nextPut: self kindAsByte + encodedLength size - 1.
	encodedData := str contents! !

!CompiledMethodTrailer methodsFor: 'accessing' stamp: ''!
kind
	"Answer a symbolic name of trailer kind.
	See #trailerKinds on class side and class comment for details"
	
	^ kind! !

!CompiledMethodTrailer methodsFor: 'testing' stamp: ''!
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: ''!
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: ''!
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: ''!
kindAsByte
	| index |
	index := self class trailerKinds indexOf: kind.
	[index ~~ 0] assert.

	^ (index - 1) << 2! !

!CompiledMethodTrailer methodsFor: 'encoding' stamp: ''!
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: 'accessing' stamp: ''!
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: 'decoding' stamp: ''!
decodeNoTrailer
	"Not much to decode here"
	size := 4.! !

!CompiledMethodTrailer methodsFor: '*Compression-Streams' stamp: 'nil'!
decodeZip
	"data := <trailer> unzip utf8 to image"
	
	| 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 utf8Decoded! !

!CompiledMethodTrailer methodsFor: 'accessing' stamp: ''!
sourceCode: aString
	
	^ self embeddedSourceCode: aString! !

!CompiledMethodTrailer methodsFor: 'encoding' stamp: ''!
encodeUndefined

	self error: 'use of an undefined kind of trailer encoding'! !

!CompiledMethodTrailer methodsFor: 'encoding' stamp: ''!
encodeEmbeddedSourceQCompress
	"data is string with method's source code, 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: ''!
encodeEmbeddedSourceWide
	"data is string with method's source code"

	| str length encodedLength utf8data |
	[ data isString ] assert.
	utf8data := data utf8Encoded.
	str := WriteStream on: (ByteArray new: utf8data size).
	length := utf8data size.
	encodedLength := self encodeLengthField: length.
	str nextPutAll: utf8data asByteArray.
	str nextPutAll: encodedLength.	"trailing byte"
	str nextPut: self kindAsByte + encodedLength size - 1.
	encodedData := str contents.! !

!CompiledMethodTrailer methodsFor: 'accessing' stamp: ''!
compressedSourceCode
	"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 ifTrue: [^ data ].
	kind == #EmbeddedSourceZip ifTrue: [^ data ].
	^ nil! !

!CompiledMethodTrailer methodsFor: 'accessing' stamp: ''!
compressSourceCode: aString
	"Embed the source code into compiled method trailer, 
	pick best compression method"
	| temp |
	self clear.
	kind := #EmbeddedSourceQCompress.
	data := aString asString. 
	
	self encode.
	temp := encodedData.

	kind := #EmbeddedSourceZip.
	self encode.
	encodedData size > temp size ifTrue: [
		encodedData := temp.
		kind := #EmbeddedSourceQCompress.
		size := encodedData size.
		]! !

!CompiledMethodTrailer methodsFor: 'encoding' stamp: ''!
encodeNoTrailer

	"When creating methods with no trailer, male them, 4 bytes long so that we can update them to sourcePointers 
	without having to use #become:"

	size := 4.
	encodedData := #[0 0 0 0].! !

!CompiledMethodTrailer methodsFor: 'decoding' stamp: ''!
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: 'encoding' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
embeddedSourceCode: aString
	"Embed the source code into compiled method trailer"

	self clear.
	
	data := aString asString.
	kind := data isWideString  
		ifTrue: [#EmbeddedSourceWide]
		ifFalse: [#EmbeddedSource].
	self encode.! !

!CompiledMethodTrailer methodsFor: '*Compression-Streams' stamp: 'nil'!
decodeEmbeddedSourceZip

	"data is string with method's source code, compressed using zip compression"
	self decodeZip.! !

!CompiledMethodTrailer methodsFor: 'decoding' stamp: ''!
decodeUndefined
	self error: 'undefined method encoding'! !

!CompiledMethodTrailer methodsFor: 'initialization' stamp: ''!
initialize
	self clear! !

!CompiledMethodTrailer methodsFor: 'testing' stamp: ''!
hasSourcePointer
	^ kind == #SourcePointer or: [ kind == #VarLengthSourcePointer ]! !

!CompiledMethodTrailer methodsFor: '*Compression-Streams' stamp: 'nil'!
encodeUsingZip

	"data is string, encode it using gzip compression"
	| utf8str stream length encodedLength |

	[data isString] assert.
	utf8str := data utf8Encoded.
	
	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: ''!
embeddedSourceCode
	"Answer the already decoded source code of compiled method"
	
	^ data! !

!CompiledMethodTrailer methodsFor: 'encoding' stamp: ''!
decodeExtendedKind

	"reserved for future use"
	self shouldBeImplemented.! !

!CompiledMethodTrailer methodsFor: 'decoding' stamp: ''!
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: ''!
decodeClearedTrailer
	"Size is set in #decodeLengthField"

	self decodeLengthField.! !

!CompiledMethodTrailer methodsFor: 'accessing' stamp: ''!
size
	"Answer the size of method's trailer , in bytes"
	^ size! !

!CompiledMethodTrailer methodsFor: 'decoding' stamp: ''!
decodeEmbeddedSource
	"data is string with method's source code"

	| len start end newSize byteArray |
	len := self decodeLengthField.
	start := method size - self size + 1.
	end := method size - self size + len.
	newSize := end - start + 1. 
	byteArray := (ByteArray new: newSize)
		replaceFrom: 1
		to: newSize
		with: method
		startingAt: start.
	data := byteArray asString! !

!CompiledMethodTrailer methodsFor: '*Compression-Streams' stamp: 'nil'!
encodeEmbeddedSourceZip

	"data is string with method's source code, encode it using Zip compression method"
	self encodeUsingZip! !

!CompiledMethodTrailer methodsFor: 'encoding' stamp: ''!
encodeClearedTrailer

	"A cleared trailer is replaced by #NoTrailer, when used for encoding"
	self clear.
	kind := #NoTrailer.
	
	^ self encode! !

!CompiledMethodTrailer methodsFor: 'decoding' stamp: ''!
decodeEmbeddedSourceQCompress 
	"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 asByteArray utf8Decoded! !

!CompiledMethodTrailer methodsFor: 'initialization' stamp: ''!
clear
	kind := #NoTrailer.
	size := 4.
	data := encodedData := method := nil! !

!CompiledMethodTrailer methodsFor: 'decoding' stamp: ''!
decodeEmbeddedSourceWide
	"data is string with method's source code"

	| len start end newSize byteArray |
	len := self decodeLengthField.
	start := method size - self size + 1.
	end := method size - self size + len.
	newSize := end - start + 1. 
	byteArray := (ByteArray new: newSize)
		replaceFrom: 1
		to: newSize
		with: method
		startingAt: start.
	data := byteArray utf8Decoded! !

!CompiledMethodTrailer methodsFor: 'testing' stamp: ''!
hasSource
	^ kind == #EmbeddedSource or: [ kind == #EmbeddedSourceQCompress or: [ kind == #EmbeddedSourceZip ] ]! !

!CompiledMethodTrailer methodsFor: 'accessing' stamp: ''!
method: aMethod

	| flagByte |

	data := size := nil.
	method := aMethod.
	flagByte := method at: method size.

	"trailer kind encoded in 6 high bits of last byte"
	kind := self class trailerKinds at: 1+(flagByte>>2).

	"decode the trailer bytes, inline some common types to speed up decoding"
	kind == #SourcePointer
		ifTrue: [ ^self decodeSourcePointer ].
   kind == #VarLengthSourcePointer
		ifTrue: [ ^self decodeVarLengthSourcePointer ].
	kind == #EmbeddedSource
		ifTrue: [ ^self decodeEmbeddedSource ].
	kind == #NoTrailer
		ifTrue: [ ^self decodeNoTrailer ].

	"slow but general decoding using perform"
	self perform: ('decode' , kind) asSymbol.! !

!CompiledMethodTrailer methodsFor: 'private' stamp: ''!
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 utf8Encoded.

	stream := WriteStream on: (ByteArray new: utf8str size).
	oddNibble := nil.

	utf8str do:	[:byte | | ix |
		ix := 'ear tonsilcmbdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345[]()'
			indexOf: byte asCharacter ifAbsent: 0.
		(ix = 0
			ifTrue:
				[{ 0. byte // 16. byte \\ 16 }]
			ifFalse:
				[ix <= 11
					ifTrue: [{ ix }]
					ifFalse: [{ ix//16+12. ix\\16 }]])
				do: [:nibble |
					oddNibble
						ifNotNil: [stream nextPut: oddNibble*16 + nibble. oddNibble := nil]
						ifNil: [oddNibble := nibble]]].
	oddNibble ifNotNil: "4 = 'ear tonsil' indexOf: Character space"
		[stream nextPut: oddNibble * 16 + 4].
	^ stream! !

!CompiledMethodTrailer methodsFor: 'accessing' stamp: ''!
sourcePointer

	kind == #NativeCodeTrailer ifTrue: [ ^ data at: 3].
	^ (kind == #SourcePointer or: [ kind == #VarLengthSourcePointer ] )
		ifTrue: [ data ]
		ifFalse: [ 0 ]! !

!CompiledMethodTrailer methodsFor: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
sourceCode
	"Answer the source code of compiled method as it was decoded.
	Note: it does not attempts to read from source files using sourcePointer,
	nor reconstruct the source code using temp names"
	
	kind == #EmbeddedSource ifTrue: [ ^data ].
	kind == #EmbeddedSourceWide ifTrue: [ ^data ].
	kind == #EmbeddedSourceQCompress ifTrue: [ ^data ].
	kind == #EmbeddedSourceZip ifTrue: [ ^data ].
	^ nil! !

!CompiledMethodTrailer class methodsFor: 'kinds' stamp: ''!
empty
	"answer the empty trailer"
	^ self new! !

!CompiledMethodTrailer class methodsFor: 'kinds' stamp: ''!
trailerKinds
	" see class comment for description."
	
	^#(
"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" #EmbeddedSource
"001100" #EmbeddedSourceWide
"001101" #Undefined
"001110" #Undefined
"001111" #Undefined
"010000" #Undefined
"010001" #Undefined
"010010" #Undefined
"010011" #Undefined
"010100" #Undefined
"010101" #Undefined
"010110" #Undefined
"010111" #Undefined
"011000" #Undefined
"011001" #Undefined
"011010" #Undefined
"011011" #Undefined
"011100" #Undefined
"011101" #Undefined
"011110" #Undefined
"011111" #Undefined
"100000" #Undefined
"100001" #Undefined
"100010" #Undefined
"100011" #Undefined
"100100" #Undefined
"100101" #Undefined
"100110" #Undefined
"100111" #Undefined
"101000" #Undefined
"101001" #Undefined
"101010" #Undefined
"101011" #Undefined
"101100" #Undefined
"101101" #Undefined
"101110" #Undefined
"101111" #Undefined
"110000" #Undefined
"110001" #Undefined
"110010" #Undefined
"110011" #Undefined
"110100" #Undefined
"110101" #Undefined
"110110" #Undefined
"110111" #Undefined
"111000" #Undefined
"111001" #Undefined
"111010" #Undefined
"111011" #Undefined
"111100" #Undefined
"111101" #Undefined
"111110" #Undefined
"111111" #SourcePointer
	)! !

!CompiledMethodTrailer class methodsFor: 'generated' stamp: ''!
trailerKindDecoders

	^#(#decodeNoTrailer #decodeClearedTrailer #decodeTempsNamesQCompress #decodeTempsNamesZip #decodeSourceBySelector #decodeSourceByStringIdentifier #decodeEmbeddedSourceQCompress #decodeEmbeddedSourceZip #decodeVarLengthSourcePointer #decodeExtendedKind #decodeNativeCodeTrailer #decodeEmbeddedSource #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)! !

!CompiledMethodTrailerTest commentStamp: ''!
SUnit tests for CompiledMethodTrailer!
!CompiledMethodTrailerTest methodsFor: 'tests' stamp: ''!
testEncodingZeroSourcePointer

	| trailer |
	
	trailer := CompiledMethodTrailer new.

	self assert: (trailer sourcePointer: 0) testEncoding sourcePointer equals: 0! !

!CompiledMethodTrailerTest methodsFor: 'tests' stamp: ''!
testEmbeddingSourceCodeWide	
	"Test that wide strings survive"
	
	self testEmbeddingSourceCode: 'doit ^''Под южно дърво, цъфтящо в синьо, бягаше малко пухкаво зайче.'' '.! !

!CompiledMethodTrailerTest methodsFor: 'tests' stamp: ''!
testEncodingNoTrailer
	| trailer |
	trailer := CompiledMethodTrailer new.

	"by default it should be a no-trailer, 4 byte wide so it can be used to store a sourcePointer"
	self assert: trailer kind identicalTo: #NoTrailer.
	self assert: trailer size equals: 4.

	trailer := trailer testEncoding.

	self assert: trailer kind identicalTo: #NoTrailer.
	self assert: trailer size equals: 4.
	"the last bytecode index must be at 0"
	self assert: trailer endPC equals: 0! !

!CompiledMethodTrailerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testEmbeddingCompressedSourceCodeWithQCompress
	| trailer code |
	trailer := CompiledMethodTrailer new.

	code := 'foo'.
	trailer compressSourceCode: code.
	
	self assert: (trailer instVarNamed: #encodedData) equals: #[207 102 2 24]! !

!CompiledMethodTrailerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testEmbeddingSourceCodeBig	
	"Test a big string"
	
	self testEmbeddingSourceCode: (String loremIpsum: 30000)! !

!CompiledMethodTrailerTest methodsFor: 'tests' stamp: ''!
testEncodingVarLengthSourcePointer

	| trailer newTrailer |
	
	trailer := CompiledMethodTrailer new.
	
	trailer sourcePointer: 1.
	newTrailer := trailer testEncoding.
	
	self assert: newTrailer sourcePointer equals: 1.
	
	trailer sourcePointer: 16r100000000000000.
	newTrailer := trailer testEncoding.
	self assert: newTrailer sourcePointer equals: 16r100000000000000.
	"the last bytecode index must be at 0"
	self assert: newTrailer endPC equals: 0! !

!CompiledMethodTrailerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testEmbeddingCompressedSourceCode
	| trailer newTrailer code |
	trailer := CompiledMethodTrailer new.

	code := 'foo'.
	trailer compressSourceCode: code.
	newTrailer := trailer testEncoding.

	self assert: trailer kind identicalTo: #EmbeddedSourceQCompress.
	self assert: newTrailer sourceCode equals: code.

	"the last bytecode index must be at 0"
	self assert: newTrailer endPC equals: 0.

	code := 'testEmbeddingSourceCode

	| trailer newTrailer code |
	
	trailer := CompiledMethodTrailer new.
	
	trailer sourceCode: code.
	newTrailer := trailer testEncoding.
	
	self assert: newTrailer sourceCode equals: code.'.

	trailer compressSourceCode: code.
	self assert: trailer kind identicalTo: #EmbeddedSourceZip.
	newTrailer := trailer testEncoding.

	self assert: newTrailer sourceCode equals: code.
	"the last bytecode index must be at 0"
	self assert: newTrailer endPC equals: 0! !

!CompiledMethodTrailerTest methodsFor: 'utilities' stamp: ''!
testEmbeddingSourceCode: sourceCode

	| trailer newTrailer |
	
	trailer := CompiledMethodTrailer new.
	trailer embeddedSourceCode: sourceCode.
	newTrailer := trailer testEncoding.
	
	self assert: (#(EmbeddedSource EmbeddedSourceWide) includes: trailer kind).
	self assert: newTrailer sourceCode equals: sourceCode.

	"the last bytecode index must be at 0"
	self assert: newTrailer endPC equals: 0.! !

!CompiledMethodTrailerTest methodsFor: 'tests' stamp: ''!
testEncodingSourcePointer
	| trailer |
	trailer := CompiledMethodTrailer new.

	CompiledMethod
		allInstancesDo: [ :method | 
			| ptr |
			trailer method: method.
			self assert: (ptr := method sourcePointer) identicalTo: trailer sourcePointer.
			"the last bytecode index must be at 0"
			ptr ~= 0 ifTrue: [ self assert: method endPC equals: trailer endPC ] ]! !

!CompiledMethodTrailerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testEmbeddingSourceCode
	
	self testEmbeddingSourceCode: 'testEmbeddingSourceCode

	| trailer newTrailer code |
	
	trailer := CompiledMethodTrailer new.
	
	trailer sourceCode: code.
	newTrailer := trailer testEncoding.
	
	self assert: newTrailer sourceCode equals: code.'.
	
	"Test a big string"
	self testEmbeddingSourceCode: (String loremIpsum: 30000).
	
	""! !

!CompletionContext commentStamp: ''!
I am a context class that hooks the new completion functionality into the system. To do that, i reimplement some of the methods but use most of the old ones from NECompletion package, such as the functionality to call the menu, etc.!
!CompletionContext methodsFor: 'accessing' stamp: ''!
entries
	^entries ifNil: [entries := self initEntries ]! !

!CompletionContext methodsFor: 'parsing' stamp: ''!
isWorkspace
	^ engine notNil and: [ engine isScripting ]! !

!CompletionContext methodsFor: 'parsing' stamp: ''!
parseSource
	ast := class compiler
		source: source;
		noPattern: self isWorkspace;
		options: #(+ optionParseErrors + optionSkipSemanticWarnings);
		parse.
	TypingVisitor new visitNode: ast! !

!CompletionContext methodsFor: 'accessing' stamp: ''!
engine
	^ engine! !

!CompletionContext methodsFor: 'entries' stamp: ''!
activateEntryAt: anIndex

	(self entries at: anIndex) activateOn: self! !

!CompletionContext methodsFor: 'accessing' stamp: ''!
sorter: anObject
	"this allows tests to change the sorter"
	sorter := anObject! !

!CompletionContext methodsFor: 'testing' stamp: ''!
hasEntries
	^ self entries isEmptyOrNil not! !

!CompletionContext methodsFor: 'action' stamp: ''!
narrowWith: aString
	"we need to re-init if the string is shorter as the user types backspace"
	(aString size < self completionToken size) ifTrue: [	entries := self initEntries ].
	"we narrow the entries down"
	entries := self entries select: [ :each | each contents beginsWith: completionToken ].
	"and update the completionToken"
	completionToken := aString! !

!CompletionContext methodsFor: 'accessing' stamp: ''!
node
	^ node! !

!CompletionContext methodsFor: 'replacement' stamp: ''!
replaceTokenInEditorWith: aString
	
	engine replaceTokenInEditorWith: aString! !

!CompletionContext methodsFor: 'initialize-release' stamp: ''!
engine: aCompletionEngine class: aClass source: aString position: anInteger 
	class := aClass. 
	source := aString.
	position := anInteger.
	engine := aCompletionEngine.
	sorter := self class sorterClass new context: self.	
	self parseSource.
	node := ast nodeForOffset: position.
	completionToken := node completionToken: position! !

!CompletionContext methodsFor: 'entries' stamp: ''!
entryCount
	^ self entries size! !

!CompletionContext methodsFor: 'entries' stamp: ''!
initEntries
	^ sorter sortCompletionList: (node completionEntries: position) asOrderedCollection! !

!CompletionContext methodsFor: 'testing' stamp: ''!
hasMessage
	^ self message notNil! !

!CompletionContext methodsFor: 'accessing' stamp: ''!
message
	^self hasEntries 
		ifFalse: ['no completions found'] 
		ifTrue: [nil]! !

!CompletionContext methodsFor: 'accessing' stamp: ''!
title
	"we only give a title if we know the type of the receiver of a message send"
	node isMessage ifFalse: [ ^'' ].
	^node receiver propertyAt: #type ifPresent: #name ifAbsent: ''! !

!CompletionContext methodsFor: 'accessing' stamp: ''!
completionToken
	^ completionToken ifNil: [ ^ ''  ]! !

!CompletionContext class methodsFor: 'accessing' stamp: ''!
sorterClass: aSorter
	SorterClass := aSorter! !

!CompletionContext class methodsFor: 'instance creation' stamp: ''!
engine: aCompletionEngine class: aClass source: aString position: anInteger 
	^ self new
		engine: aCompletionEngine
		class: aClass
		source: aString
		position: anInteger! !

!CompletionContext class methodsFor: 'accessing' stamp: ''!
sorterClass
	^ SorterClass! !

!CompletionContextTest methodsFor: 'tests' stamp: ''!
testReceiverClassVar
	| text context |
	text := 'testIt
	ClassAnnotation so'.
	context := self 
		createContextFor: text
		at: text size.
	self assert: context title equals: 'ClassAnnotation class'! !

!CompletionContextTest methodsFor: 'tests' stamp: ''!
testReceiverGlobal
	| text context |
	text := 'testIt
	Dictionary n'.
	context := self createContextFor: text at: text size.
	self assert: context title equals: 'Dictionary class'.! !

!CompletionContextTest methodsFor: 'tests' stamp: ''!
testReceiverTemp
	| text context |
	text := 'testIt
	| b |
	b := Stream new.
	b nextPutA'.
	context := self createContextFor: text at: text size.
	self assert: context title equals: ''.
	
	text := 'testIt
	| b |
	b := Stream.
	b nextPutA'.
	context := self createContextFor: text at: text size.
	self assert: context title equals: 'Stream class'.
	
	text := 'testIt: aStream
	aStream nextPut'.
	context := self createContextFor: text at: text size.
	self assert: context title equals: ''.! !

!CompletionContextTest methodsFor: 'tests' stamp: ''!
testReceiverGlobalVarNew
	| text context |
	text := 'testIt
	Dictionary new fl'.
	context := self createContextFor: text at: text size.
	self assert: ((context entries collect: [:each | each contents]) includes: #flatCollect:).! !

!CompletionContextTest methodsFor: 'private' stamp: ''!
createContextFor: aString at: anInteger 
	^ CompletionContext
		engine: CompletionEngine new
		class: NECTestClass
		source: aString
		position: anInteger! !

!CompletionContextTest methodsFor: 'tests' stamp: ''!
testTempVariable
	| text context |
	text := 'testIt: aRectangle
	| abs bcs bds |
	ab'.
	context := self createContextFor: text at: text size.
	context narrowWith: 'ab'.
	self assert: ((context entries collect: [:each | each contents]) includes: #abs)! !

!CompletionContextTest methodsFor: 'tests' stamp: ''!
testReceiverArgument
	| text context |
	text := 'testIt: aRectangle
	aRectangle printS'.
	context := self 
		createContextFor: text
		at: text size.
	self assert: ((context entries collect: [:each | each contents]) includes: #printString).
	self assert: context title equals: ''.
	
	text := 'testIt: rect
	rect is'.
	context := self 
		createContextFor: text
		at: text size.
	self assert: context title equals: ''! !

!CompletionContextTest methodsFor: 'tests' stamp: ''!
testReceiverConstant
	| text context |	
	text := 'testIt
	''test'' pre'.
	context := self createContextFor: text at: text size.
	self assert: ((context entries collect: [:each | each contents]) includes: #prefixMatchesRegex:).
	
	text := 'testIt
	true ifTr'.
	context := self createContextFor: text at: text size.
	self assert: ((context entries collect: [:each | each contents]) includes: #ifTrue:ifFalse:).
	
	text := 'testIt
	false  "this is it"
		xo'.
	context := self createContextFor: text at: text size.
	self assert: ((context entries collect: [:each | each contents]) includes: #xor:).
	
	text := 'testIt
	a := [ :test | test * test ] 
		as'.
	context := self createContextFor: text at: text size.
	self assert: ((context entries collect: #contents) includes: #asMinimalRepresentation).
	
	text := 'testIt
	$c as'.
	context := self createContextFor: text at: text size.
	self assert: ((context entries collect: [:each | each contents]) includes: #asciiValue).
	
	text := 'testIt
	#gaga un'.
	context := self createContextFor: text at: text size.
	self assert: ((context entries collect: [:each | each contents]) includes: #uncapitalized).
	
	text := 'testIt
	#( 1 2 3) as'.
	context := self createContextFor: text at: text size.
	self assert: ((context entries collect: [:each | each contents]) includes: #asByteArray).
	
	text:='testIt
	2r1.1e2 ba'.
	context := self createContextFor: text at: text size.
	self assert: ((context entries collect: [:each | each contents]) includes: #basicIdentityHash).
	
	text:='testIt
	23s32 as'.
	context := self createContextFor: text at: text size.
	self assert: ((context entries collect: [:each | each contents]) includes: #asFraction).! !

!CompletionContextTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!CompletionEngine commentStamp: ''!
I live as an instance variable in a Browser, Debugger, Workspace or other window. I'm the glue between all participants of the completion system. I create the NECContext and pass myself to the NECMenuMorph. I process the keyboard events and pass them to the NECMenuMorph or close the morph if needed.

My method codeCompletionAround: aBlock textMorph: aTextMorph keyStroke: evt
is the starting point of the completion process.

I'm invoked before and after a keystroke. Check method handleKeystrokeBefore: evt editor: editor and handleKeystrokeAfter: evt editor: editor.

The completion occurs in specific character position. The editor is responsible for determining such positions: look at senders of ==atCompletionPosition==!
!CompletionEngine methodsFor: 'accessing' stamp: ''!
context
	^context! !

!CompletionEngine methodsFor: 'settings' stamp: ''!
smartCharactersMapping
	^ NECPreferences smartCharactersMapping! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
handleKeystrokeBefore: aKeyboardEvent editor: anEditor
	"I return a boolean. 
	true when I have handled the event and no futher processing is needed by the caller.
	
	This method would be cleaner if splitted."

	| keyCharacter controlKeyPressed |
	self setEditor: anEditor.
	keyCharacter := aKeyboardEvent keyCharacter.
	controlKeyPressed := aKeyboardEvent controlKeyPressed.
	
	(self smartInputWithEvent: aKeyboardEvent )
		ifNotNil: [ ^ true ].
	
	self isMenuOpen
		ifFalse: [ ^ self handleKeystrokeWithoutMenu: aKeyboardEvent ].
	
	(controlKeyPressed not and: [ aKeyboardEvent keyCharacter isCompletionCharacter ])
		ifFalse: [ 
			self closeMenu.
			^ keyCharacter = Character escape ].
	^ false! !

!CompletionEngine methodsFor: 'settings' stamp: ''!
smartInverseMapping
	^ inverseMapping ifNil: [ 
		inverseMapping := Dictionary new.
		self smartCharactersMapping
			keysAndValuesDo: [ :char :inverse | inverseMapping at: inverse key put: char ].
		inverseMapping ]! !

!CompletionEngine methodsFor: 'private' stamp: ''!
setEditor: anObject
	editor ifNotNil: [  
		"make sure we unsubscribe from old editor"
		editor morph ifNotNil: [:m | m announcer unsubscribe: self] ].
	editor := anObject.
	editor morph onAnnouncement: MorphLostFocus send: #closeMenu to: self.
	editor morph onAnnouncement: MorphClosePopups send: #closeMenu to: self.! !

!CompletionEngine methodsFor: 'settings' stamp: ''!
smartCharacters
	^ NECPreferences smartCharacters! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
handleKeyDownAfter: aKeyboardEvent editor: aParagraphEditor

	^ self updateCompletionAfterEdition: aParagraphEditor! !

!CompletionEngine methodsFor: 'private' stamp: ''!
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! !

!CompletionEngine methodsFor: 'private' stamp: ''!
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! !

!CompletionEngine methodsFor: 'settings' stamp: ''!
smartCharacterPairFor: char ifAbsent: aBlock
	| left right |
	
	left := self smartCharactersMapping at: char ifPresent: [ char ] ifAbsent: [ 
		self smartInverseMapping at: char ifPresent: [:key | key ] ifAbsent: [ ^aBlock value ]].
	
	right := self smartCharacterOppositeOf: left ifAbsent: [ ^aBlock value ].
	
 	^ left -> right! !

!CompletionEngine methodsFor: 'private' stamp: ''!
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! !

!CompletionEngine methodsFor: 'private' stamp: ''!
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! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
handleKeystrokeWithoutMenu: aKeyboardEvent
	"I handle resetting the completion menu, and I return true when I handle an event."
	
	self stopCompletionDelay.

	NECPreferences popupShowAutomatic ifTrue: [
		(aKeyboardEvent anyModifierKeyPressed not 
		and: [ aKeyboardEvent keyCharacter isCompletionCharacter ]) 
			ifTrue: [ self resetCompletionDelay ] ].
	
	^ false! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
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 matchingPair |
	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."
			matchingPair := self smartCharacterPairFor: 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 "
			
			editor encloseWith: matchingPair.
			self invalidateEditorMorph.
			^ true ].	"we are not in a selection"
			
	(self smartCharacterShouldClose: char)	
		ifFalse: [ 
			"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 ].
		
	opposite := self smartCharacterOppositeOf: char ifAbsent: [ ^nil ].
	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! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
smartInputWithEvent: anEvent
	"aCharacter is extracted from anEvent, anEvent is passed because we may need it.
	We may remove aCharacter if this is not costly."
	
	self smartCharacters 
		ifFalse: [ ^ nil ].
	
	^ self smartCharacterWithEvent: anEvent! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
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 smartCharacterOppositeOf: 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! !

!CompletionEngine methodsFor: 'menu morph' stamp: ''!
createContext
	
	| class |
	class := editor model ifNotNil: [ :model | model selectedClassOrMetaClass ].
	^ self contextClass
		engine: self
		class: class
		source: editor text string
		position: editor caret - 1! !

!CompletionEngine methodsFor: 'private' stamp: ''!
menuMorphClass
	^ NECMenuMorph! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
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! !

!CompletionEngine methodsFor: 'menu morph' stamp: ''!
isMenuOpen
	^menuMorph notNil! !

!CompletionEngine methodsFor: 'accessing' stamp: ''!
contextClass: aClass 
	contextClass := aClass! !

!CompletionEngine methodsFor: 'replacement' stamp: ''!
completionToken

	"Return the word just before the caret"
	^ (self editor text copyFrom: self completionTokenStart to: self editor caret - 1) asString! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
leftArrow
	"I return false when the arrow is at its left-most position.
	Otherwise i return true."
	
	(menuMorph hideDetail)	
			ifFalse: [ 
				self closeMenu.
				^ false ].	
	^ true! !

!CompletionEngine methodsFor: 'accessing' stamp: ''!
editor
	^ editor! !

!CompletionEngine methodsFor: 'private' stamp: ''!
contextClass
	
	^ contextClass ifNil: [ self class contextClass ]! !

!CompletionEngine methodsFor: 'settings' stamp: ''!
smartCharacterOppositeOf: char ifAbsent: aBlock
	^(self smartCharactersMapping at: char ifAbsent: [ ^aBlock value ]) key! !

!CompletionEngine methodsFor: 'menu morph' stamp: ''!
closeMenu
	self stopCompletionDelay.
	menuMorph
		ifNotNil: [ menuMorph delete ].
	menuMorph := nil.! !

!CompletionEngine methodsFor: 'replacement' stamp: ''!
completionTokenStart
	"This is the position in the editor where the completion token starts"
	^ self editor previousWord: self editor caret - 1! !

!CompletionEngine methodsFor: 'menu morph' stamp: ''!
menuClosed
	menuMorph := nil.
	context := nil.! !

!CompletionEngine methodsFor: 'replacement' stamp: ''!
replaceTokenInEditorWith: aString
	"Main API with the completion context.
	Replace the current completion token (as it was extracted by the completion context) by aString.
	aString may contain a keyword selector string where each keyword is separated by two spaces (between:  and:)
	After replacing, set the caret after the first keyword.
	The completion context uses this API to insert text into the text editor"

	| wordEnd old positionAfterFirstKeyword offset firstKeyword wordStart |
	"Try to correctly replace the current token in the word.
	The code editor should be able to do it by himself"
	wordEnd := self editor nextWord: self editor caret.
	wordStart := self editor previousWord: self editor caret - 1.
	self editor
		selectInvisiblyFrom: wordStart
		to: wordEnd - 1.
	old := self editor selection.
	self editor replaceSelectionWith: aString.
	
	offset := NECPreferences spaceAfterCompletion
		ifTrue: [ 1 ]
		ifFalse: [ 0 ].
	firstKeyword := (aString copyUpTo: $ ) size.
	positionAfterFirstKeyword := wordEnd + firstKeyword + offset - old size.
	self editor selectAt: positionAfterFirstKeyword.
	
	self editor morph invalidRect: self editor morph bounds! !

!CompletionEngine methodsFor: 'testing' stamp: ''!
captureNavigationKeys
	^ NECPreferences captureNavigationKeys! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
handleKeystrokeAfter: aKeyboardEvent editor: aParagraphEditor

	^ self updateCompletionAfterEdition: aParagraphEditor! !

!CompletionEngine methodsFor: 'testing' stamp: ''!
hasCompletionContext
	
	^ context notNil! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
invalidateEditorMorph
		editor morph invalidRect: editor morph bounds.! !

!CompletionEngine methodsFor: 'settings' stamp: ''!
smartCharacterShouldClose: char
	^(self smartCharactersMapping at: char ifAbsent: [ ^false ]) value! !

!CompletionEngine methodsFor: 'menu morph' stamp: ''!
openMenu
	| theMenu |
	self stopCompletionDelay.

	context := self createContext.
	theMenu := self menuMorphClass
				engine: self
				position: (editor selectionPosition: context completionToken).
				
	theMenu isClosed ifFalse: [ menuMorph := theMenu ]! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
updateCompletionAfterEdition: aParagraphEditor

	(aParagraphEditor isNil or: [ self isMenuOpen not ]) ifTrue: [ 
		^ self ].

	aParagraphEditor atCompletionPosition ifFalse: [ ^ self closeMenu ].

	context narrowWith: aParagraphEditor wordAtCaret.
	menuMorph refreshSelection! !

!CompletionEngine methodsFor: 'private' stamp: ''!
stopCompletionDelay

    completionDelay ifNotNil: [ 
        completionDelay isTerminating ifFalse: [ completionDelay terminate ] ]! !

!CompletionEngine methodsFor: 'private' stamp: ''!
resetCompletionDelay
	"Open the popup after 100ms and only after certain characters"
	self stopCompletionDelay.
	self isMenuOpen ifTrue: [ ^ self ].
	editor atCompletionPosition ifFalse: [ ^ self ].
	
	completionDelay := [
			(Delay forMilliseconds: NECPreferences popupAutomaticDelay) wait.
			UIManager default defer:  [ 
				editor atCompletionPosition ifTrue: [ self openMenu ]]
		] fork.! !

!CompletionEngine methodsFor: 'testing' stamp: ''!
isScripting

	^ self editor 
		ifNotNil: [ self editor isScripting ]
		ifNil: [ false ]! !

!CompletionEngine methodsFor: 'keyboard' stamp: ''!
handleKeyDownBefore: aKeyboardEvent editor: anEditor
	"I return a boolean. 
	true when I have handled the event and no futher processing is needed by the caller.
	
	This method would be cleaner if splitted."

	| key controlKeyPressed commandKeyPressed |
	self setEditor: anEditor.
	key := aKeyboardEvent key.
	controlKeyPressed := aKeyboardEvent controlKeyPressed.
	commandKeyPressed := aKeyboardEvent commandKeyPressed.
	
	(self isMenuOpen not and: [
		self editor atCompletionPosition and: [
			NECPreferences popupShowWithShortcut matches: {aKeyboardEvent}]])
				ifTrue: [ 
					aKeyboardEvent supressNextKeyPress: true.
					self openMenu. ^ true ].
	
	key = KeyboardKey backspace
		ifTrue: [ 
			self smartBackspace ifTrue: [ ^ true ]].	
	
	self isMenuOpen ifFalse: [ ^ false ].
	
	({ KeyboardKey left . KeyboardKey right.
		KeyboardKey keypadLeft . KeyboardKey keypadRight }
			includes: key) ifTrue: [ "just move the caret" ^ false ].
	
	({ KeyboardKey up . KeyboardKey keypadUp } includes: key)
		ifTrue: [ 
			menuMorph moveUp.
			^ true ].
	({ KeyboardKey down . KeyboardKey keypadDown } includes: key)
		ifTrue: [ 
			menuMorph moveDown.
			^ true ].
	(key = KeyboardKey pageUp)
		ifTrue: [ 
			menuMorph pageUp.
			^ true ].
	(key = KeyboardKey pageDown)
		ifTrue: [ 
			menuMorph pageDown.
			^ true ].
	((key = KeyboardKey enter or:[key = KeyboardKey keypadEnter]) and: [ NECPreferences useEnterToAccept ])
		ifTrue: [ 
			menuMorph insertSelected
				ifTrue: [ ^ true ] ].
	key = KeyboardKey tab
		ifTrue: [ 
			menuMorph insertSelected
						ifTrue: [ ^ true ] ].
	key = KeyboardKey backspace
		ifTrue: [ 
			editor isCaretBehindChar
				ifFalse: [ self closeMenu ].
			^ false ].
	(controlKeyPressed or: [ commandKeyPressed or: [ key = KeyboardKey escape ] ])
		ifTrue: [ 
			self closeMenu.
			^ true ].
	^ false! !

!CompletionEngine class methodsFor: 'accessing' stamp: ''!
contextClass
	^ContextClass ifNil: [ CompletionContext ]! !

!CompletionEngine class methodsFor: 'accessing' stamp: ''!
isCompletionEnabled
	^NECPreferences enabled! !

!CompletionEngine class methodsFor: 'accessing' stamp: ''!
contextClass: aClass
	ContextClass := aClass! !

!CompletionEngineTest commentStamp: ''!
A NECControllerTest is a test class for testing the behavior of NECController!
!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
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).! !

!CompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testReplaceTokenWithCaretOnEndOfWordReplacesEntireWord

	"If the caret is at the end of a word, replace the entire word"
	
	| text |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: text size + 1.
	
	editor textArea openInWorld.
	controller openMenu.

	controller context replaceTokenInEditorWith: 'toto'.
	
	self assert: editor text equals: 'self toto'! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartBackspaceWithSelection

	self setEditorText: 'Hello'; selectAll.
	self assert: controller smartBackspace not description: 'No smartbackspace if selection'.
	
	self selectAt: 2.
	self
		assert: controller smartBackspace not
		description: 'No smartbackspace if no selection and not a smart character'.! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
selectFrom: start to: stop
	editor selectFrom: start to: stop! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartCharacterAfterEspace
	"Test we surround selected text with smart characters properly"
	self
		setEditorText: 'a b';
		selectFrom: 2 to: 4.
	editor keystroke: (self keyboardPressFor: $").
	self assert: editor text equals: 'a" b"'.! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartQuoteSurroundsEscapesSelection
	"Test we surround selected text with smart characters properly"
	self
		setEditorText: ' te''xt ';
		selectFrom: 2 to: 6.
		
	controller smartCharacterWithEvent: (self keyboardPressFor: $').
	self assert: editor text equals: ' ''te''''xt'' '.! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartCharactersShouldClose
	"Some smart characters shouldn't auto close, ohers not"
	self assert: (controller smartCharacterShouldClose: $() equals: true.
	self assert: (controller smartCharacterShouldClose: $<) equals: false.! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartCharacterWithEventAndSelection
	"Test we surround selected text with smart characters properly"
	self
		setEditorText: ' text ';
		selectFrom: 2 to: 5.
		
	controller smartCharacterWithEvent: (self keyboardEventFor: $|).
	self assert: editor text equals: ' |text| '.
	
	self
		setEditorText: ' text ';
		selectFrom: 2 to: 5.
		
	controller smartCharacterWithEvent: (self keyboardEventFor: $[).
	self assert: editor text equals: ' [text] '.
	
	self
		setEditorText: ' text ';
		selectFrom: 2 to: 5.
	controller smartCharacterWithEvent: (self keyboardEventFor: $]).
	self assert: editor text equals: ' [text] '! !

!CompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testReplaceTokenWithCaretInTheMiddleOfWordReplacesEntireWord

	"If the caret is at the end of a word, replace the entire word"
	
	| text |
	text := 'self mEthOdThatDoesNotExist'.
	self
		setEditorText: text;
		selectAt: 'self mEthOdThatDoes' size + 1.
	
	editor textArea openInWorld.
	controller openMenu.

	controller context replaceTokenInEditorWith: 'toto'.
	
	self assert: editor text equals: 'self toto'! !

!CompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testReplaceKeywordTokenFollowedByAssignmentWithCaretInTheEndOfWordWithFollowingWordsReplacesEntireWord

	"If the caret is at the end of a word, replace the entire word"
	
	| text |
	text := 'self mEthOdThatDoesNotExist:= something that follows'.
	
	self
		setEditorText: text;
		selectAt: 'self mEthOdThatDoesNotExist' size.
	
	editor textArea openInWorld.
	controller openMenu.

	controller context replaceTokenInEditorWith: 'mEthOdThatDoesNotExist'.
	
	self assert: editor text asString equals: 'self mEthOdThatDoesNotExist:= something that follows'! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
selectAll
	editor selectAll! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
selectAt: anIndex
	editor selectFrom: anIndex to: anIndex - 1! !

!CompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testReplaceKeywordTokenWithCaretInTheEndOfWordAfterCaretWithFollowingWordsReplacesEntireWord

	"If the caret is at the end of a word, replace the entire word"
	
	| text |
	text := 'self mEthOdThatDoesNotExist: something that follows'.
	
	"Select just after the colon"
	self
		setEditorText: text;
		selectAt: 'self mEthOdThatDoesNotExist:' size + 1.
	
	editor textArea openInWorld.
	controller openMenu.

	controller context replaceTokenInEditorWith: 'mEthOdThatDoesNotExist:'.
	
	self assert: editor text asString equals: 'self mEthOdThatDoesNotExist: something that follows'! !

!CompletionEngineTest methodsFor: 'accessing' stamp: ''!
interactionModel
	
	^ nil! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
keyboardPressFor: char

	| event |
	event := KeyboardEvent new.
	event 
		setType: #keypress
		buttons: 0
		position:  0@0
		keyValue: char asciiValue 
		charCode: char asciiValue
		hand: nil 
		stamp: Time now.
	^event! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
setEditorText: aString
	editor selectAll; addString:  aString! !

!CompletionEngineTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	editor := RubSmalltalkEditor forTextArea: RubEditingArea new beForSmalltalkCode.
	controller := self newCompletionEngine.
	controller setEditor: editor.
	editor completionEngine: controller.
	editor textArea model: self.! !

!CompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testReplaceKeywordTokenFollowedByAssignmentWithCaretInTheMiddleOfWordWithFollowingWordsReplacesEntireWord

	"If the caret is at the end of a word, replace the entire word"
	
	| text |
	text := 'self mEthOdThatDoesNotExist:= something that follows'.
	
	self
		setEditorText: text;
		selectAt: 'self mEthOdThatDoes' size.

	editor textArea openInWorld.
	controller openMenu.

	controller context replaceTokenInEditorWith: 'mEthOdThatDoesNotExist'.
	
	self assert: editor text asString equals: 'self mEthOdThatDoesNotExist:= something that follows'! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartQuoteSurroundsSelection
	"Test we surround selected text with smart characters properly"
	self
		setEditorText: ' text ';
		selectFrom: 2 to: 5.
		
	controller smartCharacterWithEvent: (self keyboardPressFor: $').
	self assert: editor text equals: ' ''text'' '.! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
allSelfClosingCharacters
	^ {'{}' . '[]' . '()' . '<>' . '||' . '""' . ''''''}! !

!CompletionEngineTest methodsFor: 'running' stamp: ''!
tearDown
	
	controller closeMenu.
	editor textArea delete.
	super tearDown! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartDoubleQuoteDoesNotEscapeQuote
	"Test we surround selected text with smart characters properly"
	self
		setEditorText: ' te''xt ';
		selectFrom: 2 to: 6.
		
	controller smartCharacterWithEvent: (self keyboardPressFor: $").
	self assert: editor text equals: ' "te''xt" '.! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
keyboardEventFor: char useCommand: command

	| event modifier |
	event := KeyboardEvent new.
	modifier := 0.
	command ifTrue: [ modifier := modifier + 64].
	event 
		setType: #keyDown
		buttons: modifier
		position:  0@0
		keyValue: char asciiValue 
		charCode: char asciiValue
		hand: nil 
		stamp: Time now.
	event key: (KeyboardKey fromCharacter: char).
	^event! !

!CompletionEngineTest methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass
	
	^ nil! !

!CompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testReplaceKeywordTokenWithCaretInTheMiddleOfWordWithFollowingWordsReplacesEntireWord

	"If the caret is at the end of a word, replace the entire word"
	
	| text |
	text := 'self mEthOdThatDoesNotExist: something that follows'.
	
	self
		setEditorText: text;
		selectAt: 'self mEthOdThatDoes' size.

	editor textArea openInWorld.
	controller openMenu.

	controller context replaceTokenInEditorWith: 'mEthOdThatDoesNotExist:'.
	
	self assert: editor text asString equals: 'self mEthOdThatDoesNotExist: something that follows'! !

!CompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testReplaceTokenWithCaretInTheMiddleOfWordWithFollowingWordsReplacesEntireWord

	"If the caret is at the end of a word, replace the entire word"
	
	| text |
	text := 'self mEthOdThatDoesNotExist something that follows'.
	
	self
		setEditorText: text;
		selectAt: 'self mEthOdThatDoes' size + 1.
	
	editor textArea openInWorld.
	controller openMenu.
	editor keyDown: (self keyboardEventFor: Character arrowLeft).
	editor keyDown: (self keyboardEventFor: Character arrowLeft).

	controller context replaceTokenInEditorWith: 'toto'.
	
	self assert: editor text asString equals: 'self toto something that follows'! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartDoubleQuoteSurroundsSelection
	"Test we surround selected text with smart characters properly"
	self
		setEditorText: ' text ';
		selectFrom: 2 to: 5.
		
	controller smartCharacterWithEvent: (self keyboardPressFor: $").
	self assert: editor text equals: ' "text" '.! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
allSmartCharacters
	^ self allSelfClosingCharacters , { '||'. '<>' }! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartCharactersOppositeOf
	
	self allSmartCharacters
		do: [ :pairs | 
			self
				assert: (controller smartCharacterOppositeOf: pairs first ifAbsent: [ nil ])
				equals: pairs last ]! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartDoubleQuoteSurroundsEscapesSelection
	"Test we surround selected text with smart characters properly"
	self
		setEditorText: ' te"xt ';
		selectFrom: 2 to: 6.
		
	controller smartCharacterWithEvent: (self keyboardPressFor: $").
	self assert: editor text equals: ' "te""xt" '.! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartCharacterPairForIfAbsent

	"Check leading smart character has matching trailing character - e.g. { and }"
	self allSmartCharacters do: [ :pairs |
		self assert: (controller smartCharacterPairFor: pairs first ifAbsent: [ nil ]) equals: pairs first -> pairs last].
	
	"Check trailing smart character has matching leading character - e.g. } and {"
	self allSmartCharacters do: [ :pairs |
		self assert: (controller smartCharacterPairFor: pairs last ifAbsent: [ nil ]) equals: pairs first -> pairs last].
	
	self assert: (controller smartCharacterPairFor: $% ifAbsent: [ nil ]) equals: nil.! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartBackspaceOutsideSmartCharacters

	self setEditorText: '.[];'; selectAll.
	self selectAt: 2.
	self
		assert: controller smartBackspace not
		description: 'smartbackspace ignored if before smart character'.
		
	self selectAt: 4.
	self
		assert: controller smartBackspace not
		description: 'smartbackspace ignored if after smart character'! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartCharacterWithEventSelfClosing
	self
		setEditorText: ' ';
		selectAt: 2.
		
	controller smartCharacterWithEvent: (self keyboardEventFor: $().
	self assert: editor text equals: ' ()'.
	
	self
		setEditorText: ' ';
		selectAt: 2.
		
	controller smartCharacterWithEvent: (self keyboardEventFor: $)).
	self assert: editor text equals: ' '.
	
	self
		setEditorText: ' ';
		selectAt: 2.
		
	controller smartCharacterWithEvent: (self keyboardEventFor: $<).
	self assert: editor text equals: ' '.! !

!CompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testReplaceKeywordTokenWithCaretInTheEndOfWordWithFollowingWordsReplacesEntireWord

	"If the caret is at the end of a word, replace the entire word"
	
	| text |
	text := 'self mEthOdThatDoesNotExist: something that follows'.
	
	self
		setEditorText: text;
		selectAt: 'self mEthOdThatDoesNotExist' size + 1.
	
	editor textArea openInWorld.
	controller openMenu.

	controller context replaceTokenInEditorWith: 'mEthOdThatDoesNotExist:'.
	
	self assert: editor text asString equals: 'self mEthOdThatDoesNotExist: something that follows'! !

!CompletionEngineTest methodsFor: 'running' stamp: ''!
newCompletionEngine
	
	^ CompletionEngine new! !

!CompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testReplaceTokenAfterMovingCaretToMiddleOfWordWithFollowingWordsReplacesEntireWord

	"If the caret is at the end of a word, replace the entire word"
	
	| text |
	text := 'self mEthOdThatDoesNotExist something that follows'.
	
	self
		setEditorText: text;
		selectAt: 'self mEthOdThatDoesNotExist' size + 1.
	
	editor textArea openInWorld.
	controller openMenu.

	controller context replaceTokenInEditorWith: 'toto'.
	
	self assert: editor text equals: 'self toto something that follows'! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartQuoteSurroundsDoesNotEscapeDoubleQuote
	"Test we surround selected text with smart characters properly"
	self
		setEditorText: ' te"xt ';
		selectFrom: 2 to: 6.
		
	controller smartCharacterWithEvent: (self keyboardPressFor: $').
	self assert: editor text equals: ' ''te"xt'' '.! !

!CompletionEngineTest methodsFor: 'tests - interaction' stamp: ''!
testReplaceKeywordTokenFollowedByAssignmentWithCaretInTheEndOfWordAfterCaretWithFollowingWordsReplacesEntireWord

	"If the caret is at the end of a word, replace the entire word"
	
	| text |
	text := 'self mEthOdThatDoesNotExist:= something that follows'.
	
	"Select just after the colon"
	self
		setEditorText: text;
		selectAt: 'self mEthOdThatDoesNotExist:' size.
	
	editor textArea openInWorld.
	controller openMenu.

	controller context replaceTokenInEditorWith: 'mEthOdThatDoesNotExist:'.
	
	self assert: editor text asString equals: 'self mEthOdThatDoesNotExist::= something that follows'! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
testSmartBackspace
	"Pressing backspace inside paired smart characters should remove both of them"
	self allSmartCharacters
		do: [ :chars | 
			self
				setEditorText: '.' , chars , ';';
				selectAt: 3.
			self
				assert: controller smartBackspace
				description: 'smartbackspace if next to smart characters [' , chars , ']'.
			self assert: editor text equals: '.;' ]! !

!CompletionEngineTest methodsFor: 'tests - keyboard' stamp: ''!
keyboardEventFor: char

	^ self keyboardEventFor: char useCommand: false! !

!CompletionSorter commentStamp: ''!
Strategy pattern that describes the sorting functionality.

Sorter allSubclasses collect: #kind an OrderedCollection('' 'alphabetical' '' '')!
!CompletionSorter methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!CompletionSorter methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!CompletionSorter methodsFor: 'sorting' stamp: ''!
sortCompletionList: aList

	self shouldBeImplemented! !

!CompletionSorter class methodsFor: 'description' stamp: ''!
kind 
	^ ''! !

!CompletionSorter class methodsFor: 'tools registry' stamp: ''!
register
	CompletionContext sorterClass: AlphabeticSorter! !

!ComplexBorder commentStamp: ''!
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 class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!ComplexBorderStyle commentStamp: ''!
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.
].

!
!ComplexBorderStyle methodsFor: 'drawing' stamp: ''!
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.
	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].! !

!ComplexBorderStyle methodsFor: 'private' stamp: ''!
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))! !

!ComplexBorderStyle methodsFor: 'drawing' stamp: ''!
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).
	].! !

!ComplexBorderStyle methodsFor: 'private' stamp: ''!
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! !

!ComplexBorderStyle methodsFor: 'drawing' stamp: ''!
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 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 transformBy: tfm during:[:cc|
		cc drawPolygon: points fillStyle: fill.
	].
].! !

!ComplexBorderStyle methodsFor: 'drawing' stamp: ''!
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 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]! !

!ComplexBorderStyle methodsFor: 'accessing' stamp: ''!
style
	^style! !

!ComplexBorderStyle methodsFor: 'accessing' stamp: ''!
style: newStyle
	style == newStyle ifTrue:[^self].
	style := newStyle.
	self releaseCachedState.! !

!ComplexBorderStyle methodsFor: 'private' stamp: ''!
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! !

!ComplexBorderStyle methodsFor: 'private' stamp: ''!
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! !

!ComplexBorderStyle methodsFor: 'private' stamp: ''!
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! !

!ComplexBorderStyle methodsFor: 'color tracking' stamp: ''!
trackColorFrom: aMorph
	baseColor ifNil:[self color: aMorph raisedColor].! !

!ComplexBorderStyle methodsFor: 'accessing' stamp: ''!
widthForRounding
	^0! !

!ComplexBorderStyle methodsFor: 'private' stamp: ''!
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! !

!ComplexBorderStyle methodsFor: 'private' stamp: ''!
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! !

!ComplexBorderStyle methodsFor: 'testing' stamp: ''!
isComplex
	^true! !

!ComplexBorderStyle methodsFor: 'initialize' stamp: ''!
releaseCachedState
	colors := nil.
	lineStyles := nil.! !

!ComplexBorderStyle methodsFor: 'private' stamp: ''!
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.! !

!ComplexBorderStyle methodsFor: 'private' stamp: ''!
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! !

!ComplexBorderStyle methodsFor: 'accessing' stamp: ''!
colors
	^colors ifNil:[colors := self computeColors].! !

!ComplexBorderStyle methodsFor: 'private' stamp: ''!
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! !

!ComplexBorderStyle class methodsFor: 'instance creation' stamp: ''!
style: aSymbol
	^self new style: aSymbol! !

!ComposableMorph commentStamp: ''!
Morph with an inset border by default and theme access.!
!ComposableMorph methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		icon: iconSelector
		getEnabled: enabledSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newAlphaImage: aForm help: helpText
	"Answer an alpha image morph."

	^self theme
		newAlphaImageIn: self
		image: aForm
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText
	"Answer a morph list for the given model."

	^self
		newMorphListFor: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: nil
		help: helpText! !

!ComposableMorph methodsFor: 'services' stamp: ''!
deny: aStringOrText title: aString
	"Open a denial dialog."

	^self theme
		denyIn: self
		text: aStringOrText
		title: aString! !

!ComposableMorph methodsFor: 'services' stamp: ''!
question: aStringOrText
	"Open a question dialog."

	^self question: aStringOrText title: 'Question' translated! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
message: aStringOrText title: aString
	"Open a message dialog."

	^self theme
		messageIn: self
		text: aStringOrText
		title: aString! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: aModel
		label: aString
		offset: offset
		alpha: alpha
		getEnabled: enabledSel! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newString: aStringOrText style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: aStyle! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newColorPresenterFor: aModel getColor: getSel help: helpText
	"Answer a color presenter with the given selectors."

	^self theme
		newColorPresenterIn: self
		for: aModel
		getColor: getSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: #bottomLeft! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newImage: aForm
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newSeparator
	"Answer an horizontal separator."

	^self theme
		newSeparatorIn: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newScrollPaneFor: aMorph
	"Answer a new scroll pane morph to scroll the given morph."
	
	^self theme
		newScrollPaneIn: self
		for: aMorph! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newStack: controls
	"Answer a morph laid out with a stack of controls."

	^self theme
		newStackIn: self
		for: controls! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newLabelGroup: labelsAndControls
	"Answer a morph laid out with a column of labels and a column of associated controls.
	Controls having a vResizing value of #spaceFill will
	cause their row to use #spaceFill also, otherwise #shrinkWrap."

	^self theme
		newLabelGroupIn: self
		for: labelsAndControls! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newGroupboxForAll: controls
	"Answer a plain groupbox with the given controls."

	^self theme
		newGroupboxIn: self
		forAll: controls! !

!ComposableMorph methodsFor: 'services' stamp: ''!
message: aStringOrText
	"Open a message dialog."

	^self message: aStringOrText title: 'Information' translated! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newCancelButton
	"Answer a new cancel button."

	^self newCancelButtonFor: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newVerticalSeparator
	"Answer a vertical separator."

	^self theme
		newVerticalSeparatorIn: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText
	"Answer a list for the given model."

	^self
		newListFor: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: nil
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newNoButton
	"Answer a new No button."

	^self newNoButtonFor: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newYesButtonFor: aModel
	"Answer a new yes button."

	^self theme
		newYesButtonIn: self
		for: aModel! !

!ComposableMorph methodsFor: 'services' stamp: ''!
textEntry: aStringOrText
	"Open a text entry dialog."

	^self textEntry: aStringOrText title: 'Entry' translated! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title for: contentMorph
	"Answer a new pluggable dialog with the given content."

	^self theme
		newPluggableDialogWindowIn: self
		title: title
		for: contentMorph! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newToolbar
	"Answer a toolbar."

	^self theme
		newToolbarIn: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText
	"Answer a bracket slider with the given selectors."

	^self
		newBracketSliderFor: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum 
		getEnabled: nil
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: aClass
		default: defaultValue
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseColor
	"Answer the result of a color selector dialog ."

	^self chooseColor: Color black! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText
		entryCompletion: anEntryCompletion! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newGroupbox: aString
	"Answer a groupbox with the given label."

	^self theme
		newGroupboxIn: self
		label: aString! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title
	"Answer a new pluggable dialog with the given content."

	^self
		newPluggableDialogWindow: title
		for: nil! !

!ComposableMorph methodsFor: 'accessing' stamp: ''!
defaultTitle
	"Answer the default title label for the receiver."

	^'Composite' translated! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel help: helpText
	"Answer a text entry for the given model."

	^self
		newTextEntryFor: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: nil 
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a bracket slider with the given selectors."

	^self theme
		newBracketSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseFont
	"Answer the result of a font selector dialog."

	^self chooseFont: nil! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newExpander: aString forAll: controls
	"Answer an expander with the given label and controls."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: controls! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
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: 'initialization' stamp: ''!
defaultBorderColor
	"Answer the default border color/fill style for the receiver"
	
	^#inset! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseExistingFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseExistingFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!ComposableMorph methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText
	"Open a question dialog."

	^self questionWithoutCancel: aStringOrText title: 'Question' translated! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseColor: aColor 
	"Answer the result of a color selector dialog with the given color."

	^self theme
		chooseColorIn: self
		title: 'Colour Selector' translated
		color: aColor! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseDirectory: title 
	"Answer the result of a file dialog with the given title, answer a directory."

	^self
		chooseDirectory: title
		path: nil! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText list: aList
	"Open a drop list chooser dialog."

	^self
		chooseDropList: aStringOrText
		title: 'Choose' translated
		list: aList! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel ghostText: ghostText getEnabled: enabledSel help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: String
		default: ''
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: false
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
chooseForSaveFileReference: 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
		chooseForSaveFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector
	"Answer a new tree morph."
	
	^self theme
		newTreeIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newWindowFor: aModel title: titleString
	"Answer a new window morph."
	
	^self theme
		newWindowIn: self
		for: aModel
		title: titleString! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newToolbar: controls
	"Answer a toolbar with the given controls."

	^self theme
		newToolbarIn: self
		for: controls! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newOKButtonFor: aModel getEnabled: enabledSel
	"Answer a new OK button."

	^self theme
		newOKButtonIn: self
		for: aModel
		getEnabled: enabledSel! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newStack
	"Answer a morph laid out as a stack."

	^self theme
		newStackIn: self
		for: #()! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newToolSpacer
	"Answer a tool spacer."

	^self theme
		newToolSpacerIn: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newTitle: aString for: control
	"Answer a morph laid out with a column with a title."

	^self theme
		newTitleIn: self
		label: aString
		for: control! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion

	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel 
		help: helpText
		entryCompletion: anEntryCompletion! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText
	"Answer an inremental slider with the given selectors."

	^self theme
		newIncrementalSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: min
		max: max
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newOKButtonFor: aModel
	"Answer a new OK button."

	^self
		newOKButtonFor: aModel
		getEnabled: nil! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newCancelButtonFor: aModel
	"Answer a new cancel button."

	^self theme
		newCancelButtonIn: self
		for: aModel! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector
	"Answer a text editor for the given model."

	^self theme
		newTextEditorIn: self
		for: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: menuSelector! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newSVSelector: aColor help: helpText
	"Answer a saturation-volume selector with the given color."

	^self theme
		newSVSelectorIn: self
		color: aColor
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newButtonLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new button text label."

	^self theme
		newButtonLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseFont: aFont 
	"Answer the result of a font selector dialog with the given initial font."

	^self theme
		chooseFontIn: self
		title: 'Font Selector' translated
		font: aFont! !

!ComposableMorph methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString
	"Open an alert dialog."

	^self
		alert: aStringOrText
		title: aString
		configure: [:d | ]! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newString: aStringOrText
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: #plain! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newTabGroup: labelsAndPages
	"Answer a tab group with the given tab labels associated with pages."

	^self theme
		newTabGroupIn: self
		for: labelsAndPages! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newButtonLabel: aString
	"Answer a new button text label."

	^self
		newButtonLabelFor: nil
		label: aString
		getEnabled: nil! !

!ComposableMorph methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString entryText: defaultEntryText
	"Open a text entry dialog."

	^self theme
		textEntryIn: self
		text: aStringOrText
		title: aString
		entryText: defaultEntryText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: cornerSymbol! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newLabelGroup: labelsAndControls font: aFont labelColor: aColor
	"Answer a morph laid out with a column of labels and a column of associated controls.
	Controls having a vResizing value of #spaceFill will
	cause their row to use #spaceFill also, otherwise #shrinkWrap."

	^self theme
		newLabelGroupIn: self
		for: labelsAndControls
		font: aFont
		labelColor: aColor! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseForSaveFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseForSaveFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow
	"Answer a new pluggable dialog."

	^self
		newPluggableDialogWindow: 'Dialog'! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newExpander: aString for: aControl
	"Answer an expander with the given label and control."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: {aControl}! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newExpander: aString
	"Answer an expander with the given label."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: #()! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseExistingFileReference: 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
		chooseExistingFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self theme
		newRadioButtonIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
question: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionIn: self
		text: aStringOrText
		title: aString! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newCloseButtonFor: aModel
	"Answer a new close button."

	^self theme
		newCloseButtonIn: self
		for: aModel! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newFuzzyLabel: aString
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: nil
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: nil! !

!ComposableMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	"Answer the default border width for the receiver."
	
	^ 1! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newRow
	"Answer a morph laid out as a row."

	^self theme
		newRowIn: self
		for: #()! !

!ComposableMorph methodsFor: 'services' stamp: ''!
abort: aStringOrText title: aString
	"Open an error dialog."

	^self theme
		abortIn: self
		text: aStringOrText
		title: aString! !

!ComposableMorph methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		alertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText
		entryCompletion: anEntryCompletion! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newNoButtonFor: aModel
	"Answer a new No button."

	^self theme
		newNoButtonIn: self
		for: aModel! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newOverflowRowForAll: aCollectionOfMorphs
	"Answer a new overflow row morph that provides a drop down for
	the given contents that are unable to fit the bounds."
	
	^self theme
		newOverflowRowIn: self
		forAll: aCollectionOfMorphs! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a morph list for the given model."

	^self theme
		newMorphListIn: self
		for: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText title: aString list: aList
	"Open a drop list chooser dialog."

	^self theme
		chooseDropListIn: self
		text: aStringOrText
		title: aString
		list: aList! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newYesButton
	"Answer a new Yes button."

	^self newYesButtonFor: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newHSVSelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVSelectorIn: self
		color: aColor
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: nil
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		getLabel: labelSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newPanel
	"Answer a new panel."

	^self theme
		newPanelIn: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newGroupbox: aString forAll: controls
	"Answer a groupbox with the given label and controls."

	^self theme
		newGroupboxIn: self
		label: aString
		forAll: controls! !

!ComposableMorph methodsFor: 'services' stamp: ''!
proceed: aStringOrText
	"Open a proceed dialog."

	^self proceed: aStringOrText title: 'Proceed' translated! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a drop list for the given model."

	^self theme
		newDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newToolbarHandle
	"Answer a toolbar handle."

	^self theme
		newToolbarHandleIn: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newLabel: aString
	"Answer a new text label."

	^self
		newLabelFor: nil
		label: aString
		getEnabled: nil! !

!ComposableMorph methodsFor: 'services' stamp: ''!
longMessage: aStringOrText title: aString
	"Open a (long) message dialog."

	^self theme
		longMessageIn: self
		text: aStringOrText
		title: aString! !

!ComposableMorph methodsFor: 'theme' stamp: ''!
theme
	"Answer the ui theme that provides controls."

	^ Smalltalk ui theme! !

!ComposableMorph methodsFor: 'services' stamp: ''!
centeredAlert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		centeredAlertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newToolDockingBar
	"Answer a tool docking bar."

	^self theme
		newToolDockingBarIn: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseColor: aColor title: title
	"Answer the result of a color selector dialog with the given title and initial colour."

	^self theme
		chooseColorIn: self
		title: title
		color: aColor! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newMultistateButton
	"Answer a new multistate button morph.
	To be usable it needs to have fill styles assigned to various states along
	with mouse-up/down actions."
	
	^self theme
		newMultistateButtonIn: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newOKButton
	"Answer a new OK button."

	^self newOKButtonFor: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newHueSelector: aModel getHue: getSel setHue: setSel help: helpText
	"Answer a hue selector with the given selectors."

	^self theme
		newHueSelectorIn: self
		for: aModel
		getHue: getSel
		setHue: setSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		getLabel: labelSel
		getEnabled: enabledSel! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a morph drop list for the given model."

	^self theme
		newMorphDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newGroupbox
	"Answer a plain groupbox."

	^self theme
		newGroupboxIn: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newEmbeddedMenu
	"Answer a new menu."

	^self theme
		newEmbeddedMenuIn: self
		for: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newHSVASelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVASelectorIn: self
		color: aColor
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 
	"Answer a text editor for the given model."

	^self 
		newTextEditorFor: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: nil! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newGroupboxFor: control
	"Answer a plain groupbox with the given control."

	^self theme
		newGroupboxIn: self
		for: control! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newDialogPanel
	"Answer a new main dialog panel."

	^self theme
		newDialogPanelIn: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newImageFor: aModel get: getSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newImageIn: self
		for: aModel
		get: getSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newGroupbox: aString for: control
	"Answer a groupbox with the given label and control."

	^self theme
		newGroupboxIn: self
		label: aString
		for: control! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newMenuFor: aModel
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: aModel! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newString: aStringOrText font: aFont style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: aFont
		style: aStyle! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel 
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newMenu
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText
	"Answer an alpha channel selector with the given selectors."

	^self theme
		newAlphaSelectorIn: self
		for: aModel
		getAlpha: getSel
		setAlpha: setSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: enabledSel
		help: helpText! !

!ComposableMorph methodsFor: 'services' stamp: ''!
deny: aStringOrText
	"Open a denial dialog."

	^self deny: aStringOrText title: 'Access Denied' translated! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: aModel
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: enabledSel! !

!ComposableMorph methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionWithoutCancelIn: self
		text: aStringOrText
		title: aString! !

!ComposableMorph methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString
	"Open a text entry dialog."

	^self
		textEntry: aStringOrText
		title: aString
		entryText: ''! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newText: aStringOrText
	"Answer a new text."

	^self theme
		newTextIn: self
		text: aStringOrText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self
		newRadioButtonFor: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
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: 'instance creation' stamp: ''!
newWindow
	"Answer a new window with the receiver as model,
	except when the receiver is a morph."

	|w|
	w := StandardWindow new
		model: (self isMorph ifFalse: [self]);
		title: self defaultTitle;
		addMorph: self
		fullFrame: LayoutFrame identity;
		yourself.
	self borderWidth: 0.
	^w! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newRow: controls
	"Answer a morph laid out with a row of controls."

	^self theme
		newRowIn: self
		for: controls! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		getLabel: labelSel
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newColumn: controls
	"Answer a morph laid out with a column of controls."

	^self theme
		newColumnIn: self
		for: controls! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newSliderFor: aModel getValue: getSel setValue: setSel help: helpText
	"Answer a slider with the given selectors."

	^self theme
		newSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: 0
		max: 1
		quantum: nil
		getEnabled: nil
		help: helpText! !

!ComposableMorph methodsFor: 'services' stamp: ''!
chooseDirectory: title path: path
	"Answer the result of a file dialog with the given title, answer a directory."

	^self theme
		chooseDirectoryIn: self
		title: title
		path: path! !

!ComposableMorph methodsFor: 'services' stamp: ''!
alert: aStringOrText
	"Open an alert dialog."

	^self alert: aStringOrText title: 'Alert' translated! !

!ComposableMorph methodsFor: 'services' stamp: ''!
proceed: aStringOrText title: aString
	"Open a proceed dialog and answer true if not cancelled, false otherwise."

	^self theme
		proceedIn: self
		text: aStringOrText
		title: aString! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newCloseControlFor: aModel action: aValuable help: helpText
	"Answer a new cancel button."

	^self theme
		newCloseControlIn: self
		for: aModel
		action: aValuable
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel action: actionSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: nil 
		label: stringOrText
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newCloseButton
	"Answer a new close button."

	^self newCloseButtonFor: self! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newImage: aForm size: aPoint
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm
		size: aPoint! !

!ComposableMorph methodsFor: 'services' stamp: ''!
abort: aStringOrText
	"Open an error dialog."

	^self abort: aStringOrText title: 'Error' translated! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		useIndex: true
		help: helpText! !

!ComposableMorph methodsFor: 'controls' stamp: ''!
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 class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ComposableMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ComposableMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ComposableMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ComposableMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ComposableMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ComposableMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ComposableMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ComposableMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ComposableMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ComposableMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ComposableMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ComposableMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ComposableMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ComposableMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ComposableMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ComposableMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ComposableMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ComposableMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ComposableMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ComposableMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ComposableMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ComposableMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ComposableMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ComposableMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ComposableMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ComposableMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ComposableMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ComposableMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ComposablePresenter commentStamp: ''!
ComposablePresenter is an abstract class which represent a applicative presenter made to be composed with other ComposablePresenter

Most often, I am used to display other subclasses of ComposablePresenter or subclasses of AbstractWidgetPresenter.

I collaborate with 
-  ValueHolder to managed some of my variables.
- SpecFocusOrder when no focusOrder are specified.
- SpecLayout
- WindowPresenter or DialogWindowPresenter to display myself.

A new subclass of ComposablePresenter must at least define initializeWidgets and defaultSpec on the class side.

I provide the following methods
- aboutText: set the text displayed in the About.
- title: set the title of the window.
- extent: set the initial size of the window, alternative possibility is define again initialExtent, it must be called before have displayed the widget. 
- focusOrder: set an instance what manage the order of focus of the keyboard navigation.
- bindKeyCombination:toAction: create a shortcut on keyboard what perform the block of the  action.
- owner getter of my parent.
- window getter of the window displaying me.

On my class side, I provide methods returning standard height and width for some elements.

todo
- announce:
- applyMenuModel: and neglectMenuModel:
- keyStrokeForNextFocus: , giveFocusToNextFrom: and takeKeyboardFocus
- ensureExtentFor:
- hide
- needRebuild
- on:do:
- update:
- widget

Window
=======

- openWithSpec instantiate a WindowPresenter using the lookup to found the layout to use.
- openDialogWithSpec instanciate a DialogWindowPresenter using the lookup to found the layout to use.
Their variants openWithSpec: and openDialogWithSpec:  use the layout parameter.

These methods can be useful to manage the window
- isDisplayed return true if the window of the widget is displayed
- hasWindow return true if the widget have a window
- centered to center the window in the world.
- delete to delete the window.

todo
- cancelled
- setModal:
- windowIcon:


Instantiation
===========

* initializeWidgets is called by the initialize method, it should contain initialization of subwidgets and of the focusorder.

The instantiation of a subwidget should use one of that way
- instantiate: take a class in parameter and return the created instance.
- methods named 'new' followed by a widget name are shortcut working with instantiate:

Usually, the subwidgets must be added in the focusOrder using something like 'self focusOrder add: accessor of  the  subwidget'

Note that instantiateModels: is legacy code in ComposablePresenter and must not be used. It will be deprecated and removed.

* initializePresenter is called by the initialize method after initializeWidgets, it should manage interaction of subwidgets.

Methods named 'when' followed by an event provide hook to perform the action in parameter.

Note
-------
Be careful about code order if you are overriding initialize method.
Normally in Spec initializing instance variables should be done BEFORE calling super initialize (so the opposite of the normal approach), because super initialize calls initializeWidgets and initializePresenter that normally would make use of those variables.

Layout
======

See SpecLayout

defaultSpec or a method containing the pragma <spec: #default> must be defined in the class side of my subclasses.
It contains information about how place its elements.
It possible to define more than one method to give the possibility to use another layout, by default the one containing the pragma will be used if it exists, if not defaultSpec will be used.!
!ComposablePresenter methodsFor: 'api' stamp: ''!
askOkToClose

	^ askOkToClose value! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
centerWidget: aWindow

	self changed: #centerWidget: with: { aWindow }! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
specSelectors
	"Return all the spec names"
	
	^ self class specSelectors! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newCheckBox
	^ self instantiate: CheckBoxPresenter! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
openDialogWithSpecLayout: aSpec
	"Build the widget using the spec name provided as argument and display it into a window"

	(window value notNil and: [ self needRebuild not ])
		ifTrue: [
			window value rebuildWithSpec: aSpec ]
		ifFalse: [
			window value: (DialogWindowPresenter new model: self).
			window value openWithSpecLayout: aSpec.
			self initializeDialogWindow: window value.
			window value updateTitle.
			self takeKeyboardFocus ].
		
	^ window value! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
detectMorphicAdapterDo: aBlock

	^ self dependents 
		detect: [:e | e isMorphicAdapter ]
		ifFound: aBlock! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
openWorldWithSpec
	"Build the widget using the default spec and display it into the world"

	^ self openWorldWithSpec: self defaultSpecSelector.! !

!ComposablePresenter methodsFor: 'private - focus' stamp: ''!
registerKeyStrokesForNextFor: aWidget

	aWidget ifNil: [ ^ self ].
	
	self eventKeyStrokesForNextFocus do: [:each |
		aWidget bindKeyCombination: each toAction: [ self giveFocusToNextFrom: self ] ]! !

!ComposablePresenter methodsFor: 'private - focus' stamp: ''!
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 ]! !

!ComposablePresenter methodsFor: 'initialization - private' stamp: ''!
initializePrivateAnnouncer

  announcer := Announcer new.
! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
hide

	self widget ifNotNil: [:widget |
		(widget respondsTo: #hide) ifTrue: [ widget hide ]].! !

!ComposablePresenter methodsFor: 'private' stamp: ''!
okToChange

	^ owner 
		ifNil: [
			self canDiscardEdits ifTrue: [^ true].
			self changed: #wantToChange.  "Solicit cancel from view"
			^ self canDiscardEdits]
		ifNotNil: [ owner okToChange ]! !

!ComposablePresenter methodsFor: 'specs' stamp: ''!
defaultSpec

	^ self class perform: self defaultSpecSelector! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
windowIcon

	^ windowIcon value! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newMultiColumnList
	^ self instantiate: MultiColumnListPresenter! !

!ComposablePresenter methodsFor: 'api - shortcuts' stamp: ''!
bindMenuKeyCombination: aShortcut toAction: aBlock

	additionalKeyBindings at: aShortcut put: aBlock.
	
	self changed: #bindMenuKeyCombination:toAction: with: {aShortcut . aBlock}! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
needRebuild: aBoolean

	needRebuild value: aBoolean! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
applyMenuModel: aMenuModel

	aMenuModel menuGroups do: [ :group |
		group menuItems do: [ :item |
			item shortcut ifNotNil: [ :shortcut | self bindMenuKeyCombination: shortcut toAction: [ item performMenuActionWith: {} ] ].
			item subMenu ifNotNil: [ :subMenu | subMenu applyTo: self	] ] ]! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newImage
	^ self instantiate: ImagePresenter! !

!ComposablePresenter methodsFor: 'api - shortcuts' stamp: ''!
removeKeyCombination: aShortcut

	additionalKeyBindings 
		removeKey: aShortcut 
		ifAbsent: [ ^ self ].
	
	self changed: #removeKeyCombination: with: { aShortcut }! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
buildWithSpec
	"Build the widget using the default spec"
	
	^ self buildWithSpec: self defaultSpecSelector! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
spec

	^ spec! !

!ComposablePresenter methodsFor: 'api - focus' stamp: ''!
keyStrokeForPreviousFocus: aKMShortcut

	keyStrokesForPreviousFocusHolder value: { aKMShortcut }! !

!ComposablePresenter methodsFor: 'private' stamp: ''!
addAll: aWindow withSpec: aSpec

	aWindow
		addMorph: (self buildWithSpec: aSpec)
		frame: (0@0 corner: 1@1).! !

!ComposablePresenter methodsFor: 'private' stamp: ''!
delete

	window value
		ifNil: [ self changed: #delete with: #() ]
		ifNotNil: [ :w | w delete ]! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newDropList
	^ self instantiate: DropListPresenter! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
adapterFrom: aSpecLayout model: aModel
	^ SpecInterpreter interpretASpec: aSpecLayout model: aModel! !

!ComposablePresenter methodsFor: 'api - events' stamp: ''!
whenShortcutsChanged: aBlock
	"Set a block to value when the shortcuts block has changed"
	additionalKeyBindings whenChangedDo: aBlock! !

!ComposablePresenter methodsFor: 'api - events' stamp: ''!
whenWindowChanged: aBlock

	window whenChangedDo: aBlock! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
extent

	^  extentHolder value! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
show

	self widget ifNotNil: [:widget |
		(widget respondsTo: #show) ifTrue: [ widget show ]].! !

!ComposablePresenter methodsFor: 'api - focus' stamp: ''!
eventKeyStrokesForPreviousFocus
	"String describing the keystroke to perform to jump to the previous widget"

	^ keyStrokesForPreviousFocusHolder value! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
focusOrder: anObject
	^ focusOrder := anObject! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newTree
	^ self instantiate: TreePresenter! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
centeredRelativeTo: aModel

	window value ifNotNil: [ :w | w centeredRelativeTo: aModel ]! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
aboutText: aString

	aboutText value: aString! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
ensureMorphicAdapter

	^ self dependents 
		detect: [:e | e isMorphicAdapter ]
		ifNone: [ self buildWithSpec ]! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
isDisplayed
	"Return true if the widget is currently displayed on screen"
	
	^ self window notNil and: [ self window isDisplayed ]! !

!ComposablePresenter methodsFor: 'api - focus' stamp: ''!
keyStrokeForNextFocus: aKMShortcut

	keyStrokesForNextFocusHolder value: { aKMShortcut }! !

!ComposablePresenter methodsFor: 'api - shortcuts' stamp: ''!
bindKeyCombination: aShortcut toAction: aBlock

	additionalKeyBindings at: aShortcut put: aBlock.
	
	self changed: #bindKeyCombination:toAction: with: {aShortcut . aBlock}! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
heightToDisplayInTree: aTree
	"Return the width of my representation as a list item"
	
	^ self ensureMorphicAdapterDo: [ :adapter | adapter heightToDisplayInTree: aTree ]! !

!ComposablePresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	
	self subclassResponsibility! !

!ComposablePresenter methodsFor: 'api - focus' stamp: ''!
keyStrokesForPreviousFocus: aCollection

	keyStrokesForPreviousFocusHolder value: aCollection ! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newDynamicPresentersListIn: accessorSymbol usingBuilder: aDynamicPresentersListBuilder
	|mutatorSymbol newDynamicPresenter |
	mutatorSymbol := (accessorSymbol , ':') asSymbol.
	(self perform: accessorSymbol)
		ifNotNil: [ :dynamicPresenter | dynamicPresenter owner: nil ].
	newDynamicPresenter := aDynamicPresentersListBuilder build.
	
	self perform: mutatorSymbol with: newDynamicPresenter.
	
	newDynamicPresenter owner: self.
	
	self needRebuild: false.
	self buildWithSpec! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newLabel
	^ self instantiate: LabelPresenter! !

!ComposablePresenter methodsFor: 'window menu' stamp: ''!
addMenuItemsToWindowMenu: aMenu
	"Do nothing"! !

!ComposablePresenter methodsFor: 'private' stamp: ''!
defaultSpecSelector
	self class class
		withAllSuperclassesDo: [ :class | 
			(((SpecPragmaCollector behavior: class)
				filter:
					[ :pragma | pragma selector = 'spec:' and: [ pragma arguments includes: #default ] ])
				reset;
				collected)
				ifNotEmpty: [ :pragmas | ^ pragmas first method selector ] ].
	self specSelectors
		ifNotEmpty: [ :col | 
			col size = 1
				ifTrue: [ ^ col first ] ].

	"should use pragmas"
	^ #defaultSpec! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
iconNamed: aSymbol
	^ self class iconNamed: aSymbol! !

!ComposablePresenter methodsFor: 'private' stamp: ''!
private_buildWithSpec: aSpec
	"Build the widget using the spec name provided as argument"
	| adapter |
	adapter := self privateAdapterFromModel: self withSpec: aSpec.
	self setExtentAndBindingTo: adapter widget.	
	^ adapter! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
openWithSpec: aSpec
	"Build the widget using the spec name provided as argument and display it into a window"

	^ self openWithSpecLayout: (self retrieveSpec: aSpec)! !

!ComposablePresenter methodsFor: 'initialization - private' stamp: ''!
initializePrivateValueHolders

	extentHolder := nil asValueHolder.
	needRebuild := true asValueHolder.
	keyStrokesForNextFocusHolder := { KMNoShortcut new } asValueHolder.
	keyStrokesForPreviousFocusHolder := { KMNoShortcut new } asValueHolder.
	additionalKeyBindings := Dictionary new.
	aboutText := nil asValueHolder.
	windowIcon := nil asValueHolder.
	window := nil asValueHolder.
	askOkToClose := false asValueHolder.
	titleHolder := self class title asValueHolder.
	
! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
focusOrder

	^ focusOrder ifNil: [ focusOrder := OrderedCollection new ].! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newTab
	^ self instantiate: TabPresenter! !

!ComposablePresenter methodsFor: 'private - focus' stamp: ''!
ensureKeyBindingsFor: aWidget

	self registerKeyStrokesForNextFor: aWidget.
	self registerKeyStrokesForPreviousFor: aWidget.
	
	additionalKeyBindings associationsDo: [:association | aWidget bindKeyCombination: association key toAction: association value ]! !

!ComposablePresenter methodsFor: 'instance creation' stamp: ''!
instantiatePresenters: aCollectionOfPairs
	"instantiatePresenters: is legacy code in ComposablePresenter and must not be used. It will be deprecated and removed."

	"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) ] ]! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
title: aString

	titleHolder value: aString! !

!ComposablePresenter methodsFor: 'private - focus' stamp: ''!
registerKeyStrokesForPreviousFor: aWidget

	aWidget ifNil: [ ^ self ].
	
	self eventKeyStrokesForPreviousFocus do: [:each |
		aWidget bindKeyCombination: each toAction: [ self giveFocusToPreviousFrom: self ] ]! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
widget
	^ spec ifNotNil: [ :s | s instance ]! !

!ComposablePresenter methodsFor: 'instance creation' stamp: ''!
resolveSymbol: aSymbol

	^ Smalltalk at: aSymbol! !

!ComposablePresenter methodsFor: 'private - focus' stamp: ''!
handlesKeyboard: evt

	^ true! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
owner: anObject

	owner := anObject.! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph
	"Specify how this object as a list item should be drawn"

	^ self ensureMorphicAdapterDo: [ :adapter | adapter
		listRenderOn: aCanvas
		atRow: aRow
		bounds: drawBounds
		color: drawColor
		backgroundColor: backgroundColor
		from: aMorph ]! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
widthToDisplayInList: aList
	"Return the width of my representation as a list item"
	
	^ self ensureMorphicAdapterDo: [ :adapter | adapter widthToDisplayInList: aList ]! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
aboutText

	^ aboutText value ifNil: [ aboutText value: 'The about text for this window has not been set.'; value]! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newTabManager
	^ self instantiate: TabManagerPresenter! !

!ComposablePresenter methodsFor: 'api - events' stamp: ''!
whenBuiltDo: aBlock

	self announcer 
		when: WidgetBuilt
		do: aBlock! !

!ComposablePresenter methodsFor: '*Commander-SpecSupport' stamp: ''!
enableCommanderMenu

	self enableCommanderMenuBy: self! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newText
	^ self instantiate: TextPresenter! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newList
	^ self instantiate: FastTablePresenter! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newNullPresenter
	^ self instantiate: NullPresenter! !

!ComposablePresenter methodsFor: 'initialization - private' stamp: ''!
initializePrivateAnnouncements

	keyStrokesForNextFocusHolder whenChangedDo: [ self registerKeyStrokesForNextFor: self widget ].
	keyStrokesForPreviousFocusHolder whenChangedDo: [ self registerKeyStrokesForPreviousFor: self widget ].
	titleHolder whenChangedDo: [ self updateTitle ]! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newButton
	^ self instantiate: ButtonPresenter! !

!ComposablePresenter methodsFor: 'api - shortcuts' stamp: ''!
removeMenuKeyCombination: aShortcut

	additionalKeyBindings 
		removeKey: aShortcut 
		ifAbsent: [ ^ self ].
	
	self changed: #removeMenuKeyCombination: with: { aShortcut }! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
defaultWindowModelClass 
	^ WindowPresenter! !

!ComposablePresenter methodsFor: 'initialization - private' stamp: ''!
initializePrivateHooks

	self initializeWidgets.
	self initializePresenter.
	self updatePresenter.
! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
askOkToClose: aBoolean

	askOkToClose value: aBoolean! !

!ComposablePresenter methodsFor: 'initialization' stamp: ''!
updatePresenter! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph
	"Specify how this object as a list item should be drawn"

	^ self ensureMorphicAdapterDo: [ :adapter | adapter 
		treeRenderOn: aCanvas 
		bounds: drawBounds 
		color: drawColor 
		font: aFont 
		from: aMorph ]! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
announce: anAnnouncement

	self announcer announce: anAnnouncement! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
buildWithSpec: aSpec
	"Build the widget using the spec name provided as argument"
	
	^ self buildWithSpecLayout: (self retrieveSpec: aSpec)! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
owner

	^ owner! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
heightToDisplayInList: aList
	"Return the width of my representation as a list item"
	
	^ self ensureMorphicAdapterDo: [ :adapter | adapter heightToDisplayInList: aList ]! !

!ComposablePresenter methodsFor: 'instance creation' stamp: ''!
instantiate: aComposablePresenterClass
	"Instantiate a ComposablePresenter subclass and set its instance owner"
	^ aComposablePresenterClass owner: self! !

!ComposablePresenter methodsFor: '*Commander-SpecSupport' stamp: ''!
enableCommanderShortcutsIn: aWidget

	^ CmdKMDispatcher attachedTo: aWidget withCommandsFrom: self! !

!ComposablePresenter methodsFor: 'api - shortcuts' stamp: ''!
additionalKeyBindings

	^ additionalKeyBindings value! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newIconList
	^ self instantiate: IconListPresenter! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
setExtentAndBindingTo: widget

	self ensureExtentFor: widget.
	self ensureKeyBindingsFor: widget.
	self announce: (WidgetBuilt model: self widget: widget).
	! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
setModal: aWindow 
	
	self changed: #setModal: with: { aWindow }! !

!ComposablePresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	self initializePrivateAnnouncer.
	self initializePrivateValueHolders.
	
	self initializePrivateHooks.
		
	self initializePrivateAnnouncements.! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
initialExtent

	^ nil! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
window
	^ window value ifNil: [ owner ifNotNil: [ :o | o window ] ]! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
openWorldWithSpec: aSpec
	"Build the widget using the spec name provided as argument and display it into the world"

	^ self openWorldWithSpecLayout: (self retrieveSpec: aSpec)! !

!ComposablePresenter methodsFor: 'private' stamp: ''!
addAll: aWindow withSpecLayout: aSpec

	aWindow
		addMorph: (self buildWithSpecLayout: aSpec)
		frame: (0@0 corner: 1@1).! !

!ComposablePresenter methodsFor: 'private - focus' stamp: ''!
takeKeyboardFocus

	self focusOrder ifNotEmpty:[:focus | ^ focus first takeKeyboardFocus ].
	^ self changed: #takeKeyboardFocus with: #()! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
updateTitle
	"Update the window title"

	self window ifNotNil: [:w | w updateTitle ]! !

!ComposablePresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aWindow
	"used to initialize the model in the case of the use into a dialog window"! !

!ComposablePresenter methodsFor: 'testing' stamp: ''!
hasWindow
	"Answers true if there is an open window using this model."

	self owner ifNil: [ ^ self window ifNotNil: [ :w | w isClosed not ] ifNil: [ false ] ].
	 ^ self owner hasWindow! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
cancelled

	^ self window
		ifNil: [ false ]
		ifNotNil: [ :w | w cancelled ]! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
windowIcon: aForm

	windowIcon value: aForm! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
buildWithSpecLayout: aSpecLayout
	"Build the widget using the spec name provided as argument"
	| widget adapter|
	adapter := self adapterFrom: aSpecLayout model: self.
	widget := adapter asWidget.
	self setExtentAndBindingTo: widget.
	^ widget! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
apiSelectors

	^ self class apiSelectors! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newRadioButton
	^ self instantiate: RadioButtonPresenter! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
ensureExtentFor: widget

	self extent
		ifNil: [ self initialExtent
			ifNotNil: [ :ex | 
				(widget respondsTo: #extent:)
					ifTrue: [ widget extent: ex ] ] ]
		ifNotNil: [ :ex | 
			(widget respondsTo: #extent:)
				ifTrue: [ widget extent: ex ] ].
	! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
neglectMenuModel: aMenuModel

	aMenuModel menuGroups do: [ :group |
		group menuItems do: [ :item |
			item shortcut ifNotNil: [ :shortcut | self removeMenuKeyCombination: shortcut ].
			item subMenu ifNotNil: [ :subMenu | subMenu neglect: self	] ] ]! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
detectMorphicAdapterDo: doBlock ifNone: aBlock

	^ self dependents 
		detect: [:e | e isMorphicAdapter ]
		ifFound: doBlock
		ifNone: aBlock! !

!ComposablePresenter methodsFor: '*Commander-SpecSupport' stamp: ''!
buildCommanderMenuBy: aMenuCommandActivationClass

	^aMenuCommandActivationClass buildContextMenuFor: self inContext: self createCommandContext! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
openWorldWithSpecLayout: aSpec
	"Build the widget using the spec name provided as argument and display it into the world"

	(window value notNil and: [ self needRebuild not ])
		ifTrue: [
			window value rebuildWithSpecLayout: aSpec ]
		ifFalse: [ 
			window value: (WorldPresenter new model: self).
			window value openWithSpecLayout: aSpec.
			self takeKeyboardFocus ].
		
	^ window value! !

!ComposablePresenter methodsFor: '*Commander-SpecSupport' stamp: ''!
createCommandContext
	"Subclases should override it if they provide any selection"
	^self createCommandContextForSelection: #()! !

!ComposablePresenter methodsFor: '*Commander-SpecSupport' stamp: ''!
createCommandContextForSelection: selectedItems
	"simple context has no information about selected items"
	^CmdSimpleToolContext for: self! !

!ComposablePresenter methodsFor: '*Commander-SpecSupport' stamp: ''!
enableCommanderMenuBy: presenterWithCommands

	self menu: [ presenterWithCommands buildCommanderMenuBy: CmdContextMenuActivation]! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
openDialogWithSpec
	"Build the widget using the default spec and display it into a window"

	^ self openDialogWithSpec: self defaultSpecSelector.! !

!ComposablePresenter methodsFor: 'private' stamp: ''!
update: aParameter

	self changed: aParameter! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
openWithSpecLayout: aSpec
	"Build the widget using the spec name provided as argument and display it into a window"

	(window value notNil and: [ self needRebuild not ])
		ifTrue: [
			window value rebuildWithSpecLayout: aSpec ]
		ifFalse: [ 
			window value: (self defaultWindowModelClass new model: self).
			window value openWithSpecLayout: aSpec.
			self takeKeyboardFocus ].
		
	^ window value! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newTextInput
	^ self instantiate: TextInputFieldPresenter! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newCode
	^ (self instantiate: TextPresenter)
		beForCode;
		yourself! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
retrieveSpec: aSelector
	| layout |
	
	layout := self class perform: aSelector.
	layout isSpecLayout ifTrue: [ layout selector: aSelector ].
	^ layout! !

!ComposablePresenter methodsFor: 'api - announcements' stamp: ''!
on: anAnnouncement send: aSelector to: aTarget

	self announcer
		when: anAnnouncement 
		send: aSelector 
		to: aTarget! !

!ComposablePresenter methodsFor: 'model access' stamp: ''!
setModel: aDomainObject

! !

!ComposablePresenter methodsFor: 'private' stamp: ''!
privateAdapterFromModel: aModel withSpec: aSpec
	"apparently when looking at the implementation, it does not return a widget but an adapter so it should be called adapter :)"
	^ SpecInterpreter private_buildWidgetFor: self withSpec: aSpec.! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newDiff
	^ self instantiate: DiffPresenter! !

!ComposablePresenter methodsFor: 'model access' stamp: ''!
setModelBeforeInitialization: aDomainObject

! !

!ComposablePresenter methodsFor: 'private - focus' stamp: ''!
takeLastKeyboardFocus

	self focusOrder
		ifEmpty: [ self takeKeyboardFocus ]
		ifNotEmpty: [:focus | focus last takeKeyboardFocus ].! !

!ComposablePresenter methodsFor: 'api - focus' stamp: ''!
eventKeyStrokesForNextFocus
	"String describing the keystroke to perform to jump to the next widget"

	^ keyStrokesForNextFocusHolder value! !

!ComposablePresenter methodsFor: 'private' stamp: ''!
private_buildWithSpec
	"Build the widget using the default spec"
	
	^ self private_buildWithSpec: self defaultSpecSelector! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
extent: aPoint

	^  extentHolder value: aPoint! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
title
	"Return the window's title"

	^ titleHolder value! !

!ComposablePresenter methodsFor: 'api - focus' stamp: ''!
keyStrokesForNextFocus: aCollection

	keyStrokesForNextFocusHolder value: aCollection! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
beginsWith: aString fromList: aMorph
	"This method is used bu the list for the search of elements when you are typing directly in the list"
	
	^ self ensureMorphicAdapterDo: [ :adapter | adapter beginsWith: aString fromList: aMorph ]! !

!ComposablePresenter methodsFor: 'instance creation' stamp: ''!
createInstanceFor: aClassSymbol
	"Retrieve the class corresponding to aClassSymbol using the bindings, then create a new instance of this class"
	| class |
	
	class := self resolveSymbol: aClassSymbol.
	^ self instantiate: class.! !

!ComposablePresenter methodsFor: 'instance creation' stamp: ''!
instantiate: aComposablePresenterClass on: aModel
	"Instantiate a ComposablePresenter subclass and set its instance owner and model"
	^ aComposablePresenterClass owner: self on: aModel! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
ensureMorphicAdapterDo: aBlock

	^ aBlock value: self ensureMorphicAdapter! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
openDialogWithSpec: aSpec
	"Build the widget using the spec name provided as argument and display it into a window"

	^ self openDialogWithSpecLayout: (self retrieveSpec: aSpec)! !

!ComposablePresenter methodsFor: 'api - shortcuts' stamp: ''!
on: aShortcut do: aBlock

	self bindKeyCombination: aShortcut toAction: aBlock! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
centered

	window value ifNotNil: [ :w | w centered ]! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
needRebuild

	^ needRebuild value! !

!ComposablePresenter methodsFor: 'private - focus' stamp: ''!
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 ]! !

!ComposablePresenter methodsFor: 'api' stamp: ''!
openWithSpec
	"Build the widget using the default spec and display it into a window"

	^ self openWithSpec: self defaultSpecSelector.! !

!ComposablePresenter methodsFor: 'accessing' stamp: ''!
spec: aSpec

	spec := aSpec! !

!ComposablePresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
widthToDisplayInTree: aTree
	"Return the width of my representation as a list item"
	
	^ self ensureMorphicAdapterDo: [ :adapter | adapter widthToDisplayInTree: aTree ]! !

!ComposablePresenter methodsFor: 'widgets' stamp: ''!
newSlider
	^ self instantiate: SliderPresenter! !

!ComposablePresenter methodsFor: 'initialization' stamp: ''!
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 ]]].! !

!ComposablePresenter class methodsFor: 'protocol' stamp: ''!
specSelectors
	^ self class withAllSuperclasses
		flatCollect: [ :class | 
			(((SpecPragmaCollector behavior: class)
				filter: [ :pragma | pragma selector = #spec ])
				reset;
				collected) collect: [ :pragmas | pragmas method selector ] ]! !

!ComposablePresenter class methodsFor: 'defaults' stamp: ''!
buttonWidth

	^ (self defaultFont widthOfString: 'eilwp') + 44! !

!ComposablePresenter class methodsFor: 'queries' stamp: ''!
defaultFont 

	^ self platform defaultFont! !

!ComposablePresenter class methodsFor: 'instance creation' stamp: ''!
on: aDomainObject

	^ self basicNew
		setModelBeforeInitialization: aDomainObject;
		initialize;
		yourself! !

!ComposablePresenter class methodsFor: 'instance creation' stamp: ''!
owner: anOwningPresenter

	^ self basicNew
		owner: anOwningPresenter;
		initialize;
		yourself! !

!ComposablePresenter class methodsFor: 'defaults' stamp: ''!
buttonHeight

	^ self defaultFont height + 12! !

!ComposablePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ self subclassResponsibility! !

!ComposablePresenter class methodsFor: 'instance creation' stamp: ''!
owner: anOwningPresenter on: aDomainObject

	^ self basicNew
		owner: anOwningPresenter;
		setModelBeforeInitialization: aDomainObject;
		initialize;
		yourself! !

!ComposablePresenter class methodsFor: 'platform' stamp: ''!
platform

	^ SpecInterpreter bindings! !

!ComposablePresenter class methodsFor: 'defaults' stamp: ''!
toolbarHeight

	^ self defaultFont height + 12! !

!ComposablePresenter class methodsFor: 'defaults' stamp: ''!
labelHeight

	^ self defaultFont height! !

!ComposablePresenter class methodsFor: 'defaults' stamp: ''!
inputTextHeight

	^ self defaultFont height + 12! !

!ComposablePresenter class methodsFor: 'specs' stamp: ''!
title
	
	^ 'Untitled window'! !

!ComposablePresenterWithModel commentStamp: ''!
I am a composable presenter that  keeps reference to its domain model (announcingObject) optionally wrapped in a value holder and subscribes yourself to it.

As the model (announcingObject) we can set a subclass of Model or a value holder (NewValueHolder). In that case such models are stored directly into announcingObject.

You should implement the method #modelChanged in my subclasses
!
!ComposablePresenterWithModel methodsFor: 'initialization' stamp: ''!
modelChanged

	"subclass responsibility (optional)"! !

!ComposablePresenterWithModel methodsFor: 'updating' stamp: ''!
updatePresenter

	self modelChanged ! !

!ComposablePresenterWithModel methodsFor: 'accessing - private' stamp: ''!
setAnnouncingObject: aDomainObject

	announcingObject := aDomainObject wrappedInValueHolderIfNeeded.
	announcingObject whenChangedDo: [ self modelChanged ].
	! !

!ComposablePresenterWithModel methodsFor: 'accessing' stamp: ''!
model: aDomainObject

	"aDomainObject can be regular object, a value holder (NewValueHolder) or an instance of Model"
	
	(aDomainObject isAnnouncingObject not and: [ self announcingObject isValueHolder ])
		ifTrue: [ self announcingObject value: aDomainObject ]
		ifFalse: [ self setAnnouncingObject: aDomainObject ]
	! !

!ComposablePresenterWithModel methodsFor: 'accessing - private' stamp: ''!
announcingObject

	^ announcingObject! !

!ComposablePresenterWithModel methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aDomainObject

	self setAnnouncingObject: aDomainObject.
! !

!ComposablePresenterWithModel methodsFor: 'accessing' stamp: ''!
model

	 ^ self announcingObject value! !

!ComposedSortFunction commentStamp: ''!
A ComposedSortFunction is an abstract class wrapping over another SortFunction for the sake of composition.

Subclasses have to define the composition behavior via collate:with: message.

Instances variables:
	baseSortFunction		<SortFunction>	the wrapped sort function!
!ComposedSortFunction methodsFor: 'comparing' stamp: ''!
= aSortFunction
	self == aSortFunction ifTrue: [ ^true ].
	^self class = aSortFunction class and: [ baseSortFunction = aSortFunction baseSortFunction ]! !

!ComposedSortFunction methodsFor: 'accessing' stamp: ''!
baseSortFunction: aSortFunction
	baseSortFunction := aSortFunction! !

!ComposedSortFunction methodsFor: 'comparing' stamp: ''!
hash
	^baseSortFunction hash hashMultiply! !

!ComposedSortFunction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	baseSortFunction := self class default! !

!ComposedSortFunction methodsFor: 'accessing' stamp: ''!
baseSortFunction
	^baseSortFunction! !

!ComposedSortFunction class methodsFor: 'instance creation' stamp: ''!
on: aSortFunction
	^self new baseSortFunction: aSortFunction! !

!CompositeAnnotationContext commentStamp: ''!
I am composite context. I represent users of annotations which satisfy all my parts.

To create my instances use following method:

	CompositeAnnotationContext with: {aContext1. aContext2}
	
Or use comma message to concatenate other contexts: 

	aContext1 , aContext2

Internal Representation and Key Implementation Points.

    Instance Variables
	parts:		<Collection of<AnnotationContext>>!
!CompositeAnnotationContext methodsFor: 'accessing' stamp: ''!
parts
	^ parts! !

!CompositeAnnotationContext methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].
	
	^ parts = anObject parts! !

!CompositeAnnotationContext methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ parts hash! !

!CompositeAnnotationContext methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream nextPut: $(.
	parts do: [ :each | 
		each printOn: aStream.
		aStream nextPutAll: ', ' ].
	aStream skip: -1; nextPut: $)! !

!CompositeAnnotationContext methodsFor: 'converting' stamp: ''!
, anAnnotationContext
	^ self class with: (parts copyWith: anAnnotationContext asAnnotationContext)! !

!CompositeAnnotationContext methodsFor: 'testing' stamp: ''!
describes: anAnnotationUser
	^parts allSatisfy: [ :each | each describes: anAnnotationUser ]! !

!CompositeAnnotationContext methodsFor: 'accessing' stamp: ''!
parts: anObject
	parts := anObject! !

!CompositeAnnotationContext class methodsFor: 'instance creation' stamp: ''!
with: contextCollection
	^self new 
		parts: contextCollection! !

!CompositeAnnotationContextTest methodsFor: 'tests' stamp: ''!
testComparison
	self assert: Object asAnnotationContext , Array asAnnotationContext equals: Object asAnnotationContext , Array asAnnotationContext.
	self assert: (Object asAnnotationContext , Array asAnnotationContext) hash equals: (Object asAnnotationContext , Array asAnnotationContext) hash.

	self deny: Object asAnnotationContext , Array asAnnotationContext equals: Object asAnnotationContext , String asAnnotationContext! !

!CompositeAnnotationContextTest methodsFor: 'tests' stamp: ''!
testCreationByComma
	
	| context1 context2 context |
	context1 := Object asAnnotationContext.
	context2 := Array asAnnotationContext.
	
	context := context1 , context2.
	
	self assert: context class equals: CompositeAnnotationContext.
	self assert: context parts equals: {context1. context2}.! !

!CompositeAnnotationContextTest methodsFor: 'tests' stamp: ''!
testCreationByCommaWithCompatibleArgument
	
	| context1 context |
	context1 := Object asAnnotationContext.
	
	context := context1 , Array.
	
	self assert: context class equals: CompositeAnnotationContext.
	self assert: context parts equals: {context1. Array asAnnotationContext}.! !

!CompositeAnnotationContextTest methodsFor: 'tests' stamp: ''!
testCreationByCommaWithMultipleContexts
	
	| context1 context2 context context3 |
	context1 := Object asAnnotationContext.
	context2 := Array asAnnotationContext.
	context3 := String asAnnotationContext.
	
	context := context1 , context2, context3.
	
	self assert: context class equals: CompositeAnnotationContext.
	self assert: context parts equals: {context1. context2. context3}.! !

!CompositeAnnotationContextTest methodsFor: 'tests' stamp: ''!
testCreationByCommaWithMultipleCompatipleContexts
	
	| context1 context |
	context1 := Object asAnnotationContext.
	
	context := context1 , Array, String.
	
	self assert: context class equals: CompositeAnnotationContext.
	self 
		assert: context parts 
		equals: {context1. Array asAnnotationContext. String asAnnotationContext}! !

!CompositeBorder commentStamp: ''!
Border supporting multiple "sub-borders".!
!CompositeBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!CompositeBorderStyle commentStamp: ''!
Border supporting multiple "sub-borders".!
!CompositeBorderStyle methodsFor: 'comparing' stamp: ''!
= aBorderStyle
	"Check the sub-borders too"
	
	^super = aBorderStyle and: [
		self borders = aBorderStyle borders]! !

!CompositeBorderStyle methodsFor: 'comparing' stamp: ''!
hash
	"Since #= is overridden."
	
	^super hash bitXor: self borders hash! !

!CompositeBorderStyle methodsFor: 'accessing' stamp: ''!
borders
	"Answer the value of borders"

	^ borders! !

!CompositeBorderStyle methodsFor: '*Athens-Morphic' stamp: ''!
asAthensPaintOn: anAthensCanvas
	^ AthensCompositeStrokePaint new fromBorderStyles: borders on: anAthensCanvas! !

!CompositeBorderStyle methodsFor: 'accessing' stamp: ''!
borders: anObject
	"Set the value of borders"

	borders := anObject! !

!CompositeBorderStyle methodsFor: 'testing' stamp: ''!
isComposite
	"Answer true."

	^true! !

!CompositeBorderStyle methodsFor: 'accessing' stamp: ''!
colorsAtCorners
	"Return the colors of the first border."
	
	^self borders first colorsAtCorners! !

!CompositeBorderStyle methodsFor: 'drawing' stamp: ''!
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]! !

!CompositeFillStyle commentStamp: ''!
Fillstyle supporting compositing of multiple sub-fillstyles.!
!CompositeFillStyle methodsFor: 'testing' stamp: ''!
isOrientedFill
	"Answer whether any of the composited fill styles are oriented."

	self fillStyles reverseDo: [:fs |
		fs isOrientedFill ifTrue: [^true]].
	^false! !

!CompositeFillStyle methodsFor: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
isTranslucent
	"Answer whether all of the composited fill styles are transparent."

	^self fillStyles allSatisfy: [:fs | fs isTranslucent]! !

!CompositeFillStyle methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		fillStyles: OrderedCollection new! !

!CompositeFillStyle methodsFor: 'accessing' stamp: ''!
fillStyles: aCollection
	"Set the value of fillStyles. The first item in the collection is considered
	to be topmost when rendering."

	fillStyles := aCollection! !

!CompositeFillStyle methodsFor: 'testing' stamp: ''!
isCompositeFill
	"Answer whether the receiver is a composite fill.
	True for kinds of the receiver's class."

	^true! !

!CompositeFillStyle methodsFor: '*Morphic-Base' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
asAthensPaintOn: aCanvas 
	^ AthensCompositePaint new fromFillStyles: fillStyles on: aCanvas! !

!CompositeFillStyle methodsFor: 'accessing' stamp: ''!
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: 'converting' stamp: ''!
asColor
	"Answer a colour that is a best match to the receiver.
	Simple approach for the moment."
	
	^self fillStyles
		ifEmpty: [Color transparent]
		ifNotEmpty: [self fillStyles last asColor]! !

!CompositeFillStyle methodsFor: 'accessing' stamp: ''!
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: ''!
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: ''!
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: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
isTransparent
	"Answer whether all of the composited fill styles are transparent."

	^self fillStyles allSatisfy: [:fs | fs isTransparent]! !

!CompositeFillStyle methodsFor: '*Morphic-Base' stamp: ''!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	aMenu add: 'change origin' target: self selector: #changeOriginIn:event: argument: aMorph.
	aMenu add: 'change orientation' target: self selector: #changeOrientationIn:event: argument: aMorph.! !

!CompositeFillStyle methodsFor: '*Morphic-Base' stamp: ''!
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: ''!
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: 'testing' stamp: ''!
isGradientFill
	"Answer whether any of the composited fill styles are gradients."

	self fillStyles reverseDo: [:fs |
		fs isGradientFill ifTrue: [^true]].
	^false! !

!CompositeFillStyle methodsFor: 'accessing' stamp: ''!
fillStyles
	"Answer the value of fillStyles. The first item in the collection is considered
	to be topmost when rendered."

	^ fillStyles! !

!CompositeFillStyle class methodsFor: 'build' stamp: ''!
fillStyles: aCollection
	"Answer a new instance of the receiver with the specfied fill styles."

	^self new fillStyles: aCollection! !

!CompositeTransform commentStamp: ''!
A composite transform provides the effect of several levels of coordinate transformations.!
!CompositeTransform methodsFor: 'accessing' stamp: ''!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^self species new
		globalTransform: localTransform inverseTransformation
		localTransform: globalTransform inverseTransformation! !

!CompositeTransform methodsFor: 'initialization' stamp: ''!
globalTransform: gt localTransform: lt 
	globalTransform := gt.
	localTransform := lt! !

!CompositeTransform methodsFor: 'transforming points' stamp: ''!
localPointToGlobal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^globalTransform localPointToGlobal:
		(localTransform localPointToGlobal: aPoint)! !

!CompositeTransform methodsFor: 'converting' stamp: ''!
asMatrixTransform2x3
	^globalTransform asMatrixTransform2x3
		composedWithLocal: localTransform asMatrixTransform2x3! !

!CompositeTransform methodsFor: 'testing' stamp: ''!
isPureTranslation
	^ globalTransform isPureTranslation and: [localTransform isPureTranslation]! !

!CompositeTransform methodsFor: 'accessing' stamp: ''!
angle
	^ localTransform angle + globalTransform angle! !

!CompositeTransform methodsFor: 'transformations' stamp: ''!
invert: aPoint
	^ globalTransform invert: (localTransform invert: aPoint)! !

!CompositeTransform methodsFor: 'testing' stamp: ''!
isCompositeTransform
	^true! !

!CompositeTransform methodsFor: 'testing' stamp: ''!
isIdentity
	^ globalTransform isIdentity and: [localTransform isIdentity]! !

!CompositeTransform methodsFor: 'transforming points' stamp: ''!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^localTransform globalPointToLocal:
		(globalTransform globalPointToLocal: aPoint)! !

!CompositeTransform methodsFor: 'converting' stamp: ''!
asCompositeTransform
	^self! !

!CompositeTransform methodsFor: 'initialization' stamp: ''!
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: 'accessing' stamp: ''!
offset
	^ (self localPointToGlobal: 0@0) negated! !

!CompositeTransform methodsFor: 'accessing' stamp: ''!
scale
	^ localTransform scale * globalTransform scale! !

!CompositeTransform methodsFor: 'transformations' stamp: ''!
transform: aPoint
	^ localTransform transform: (globalTransform transform: aPoint)! !

!CompositeTransform methodsFor: 'converting' stamp: ''!
asMorphicTransform
	"Squash a composite transform down to a simple one"
	^ MorphicTransform offset: self offset angle: self angle scale: self scale! !

!CompositeTransform class methodsFor: 'instance creation' stamp: ''!
globalTransform: gt localTransform: lt
	^self new globalTransform: gt localTransform: lt! !

!CompositionScanner commentStamp: ''!
A CompositionScanner measures text and determines where line breaks.
Given a rectangular zone on input, it is used to split text in horizontal lines, and produce information about those lines on output (at which index a line starts/stops, which vertical space does the line require, which horizontal space if left for adjusting inter-word spacing, etc...)

Instance Variables
	baseline:		<Number>
	baselineAtSpace:		<Number>
	lastBreakIsNotASpace:		<Boolean>
	lineHeight:		<Number>
	lineHeightAtSpace:		<Number>
	nextIndexAfterLineBreak:		<Integer>
	spaceIndex:		<Integer>
	spaceX:		<Number>

baseline
	- the distance between top of line and the base line (that is the bottom of latin characters abcdehiklmnorstuvwx in most fonts)

baselineAtSpace
	- memorize the baseline at last encountered space or other breakable character.
	This is necessary because the CompositionScanner wants to break line at a breakable character.
	If a word layout overflows the right margin, the scanner has to roll back and restore the line state to last encountered breakable character.

lastBreakIsNotASpace
	- indicates that the last breakable character was not a space.
	This is necessary because handling a line break at a space differs from non space.
	If line break occurs on space, the space won't be displayed in next line.
	If it's another breakable character, it has to be displayed on next line.

lineHeight
	- the total line height from top to bottom, including inter-line spacing.

lineHeightAtSpace
	- the line height at last encountered space or other breakable character.
	See baselineAtSpace for explanation.

nextIndexAfterLineBreak
	- the index of character after the last line break that was encountered.

spaceIndex
	- the index of last space or other breakable character that was encountered

spaceX
	- the distance from left of composition zone to left of last encountered space or other breakable character 
	See baselineAtSpace for explanation.

Note: if a line breaks on a space, a linefeed or a carriage return, then the space, linefeed or carriage return is integrated in the line.
If there is a carriage return - linefeed pair, the pair is integrated to the line as if it were a single line break for compatibility with legacy software.!
!CompositionScanner methodsFor: 'stop conditions' stamp: ''!
wrapAtLastBreakable
	"Wrap the line before last encountered breakable character."
	pendingKernX := 0.
	nextIndexAfterLineBreak := spaceIndex.
	line stop: spaceIndex - 1.
	lineHeight := lineHeightAtSpace.
	baseline := baselineAtSpace.
	line paddingWidth: rightMargin - spaceX.
	line internalSpaces: spaceCount.
	^true! !

!CompositionScanner methodsFor: 'testing' stamp: ''!
canComputeDefaultLineHeight
	^ rightMargin notNil! !

!CompositionScanner methodsFor: 'stop conditions' stamp: ''!
columnBreak

	"Answer true. Set up values for the text line interval currently being 
	composed."

	pendingKernX := 0.
	line stop: lastIndex.
	spaceX := destX.
	lastBreakIsNotASpace := false.
	line paddingWidth: rightMargin - spaceX.
	^true! !

!CompositionScanner methodsFor: 'initialization' stamp: ''!
initialize
	wantsColumnBreaks := false.
	super initialize! !

!CompositionScanner methodsFor: 'stop conditions' stamp: ''!
wrapAtLastSpace
	"Wrap the line before last encountered space"
	
	pendingKernX := 0.
	nextIndexAfterLineBreak := spaceIndex + 1.
	alignment = Justified ifTrue: [
		"gobble all subsequent spaces"
		[nextIndexAfterLineBreak <= text size and: [(text at: nextIndexAfterLineBreak) == Space]]
			whileTrue: [nextIndexAfterLineBreak := nextIndexAfterLineBreak + 1]].
	
	line stop: nextIndexAfterLineBreak - 1.
	lineHeight := lineHeightAtSpace.
	baseline := baselineAtSpace.

	["remove the space at which we break..."
	spaceCount := spaceCount - 1.
	spaceIndex := spaceIndex - 1.

	"...and every other spaces preceding the one at which we wrap.
		Double space after punctuation, most likely."
	spaceCount >= 1 and: [(text at: spaceIndex) = Space]]
		whileTrue:
			["Account for backing over a run which might
				change width of space."
			font := text fontAt: spaceIndex withStyle: textStyle.
			spaceX := spaceX - (font widthOf: Space)].
	line paddingWidth: rightMargin - spaceX.
	line internalSpaces: spaceCount.
	^true! !

!CompositionScanner methodsFor: 'private' stamp: ''!
placeEmbeddedObject: anchoredMorph
	| w descent |
	"Workaround: The following should really use #textAnchorType"
	anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
	w := anchoredMorph width.
	(destX + w > rightMargin and: [(leftMargin + w) <= rightMargin or: [lastIndex > line first]])
		ifTrue: ["Won't fit, but would on next line"
				^ false].
	destX := destX + w + kern.
	descent := lineHeight - baseline.
	baseline := baseline max: anchoredMorph height.
	lineHeight := baseline + descent.
	^ true! !

!CompositionScanner methodsFor: 'accessing' stamp: ''!
doesTheLineBreaksAfterLastChar
	^nextIndexAfterLineBreak > text size! !

!CompositionScanner methodsFor: 'stop conditions' stamp: ''!
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: 'scanning' stamp: ''!
composeFrom: startIndex inRectangle: lineRectangle
	firstLine: firstLine leftSide: leftSide rightSide: rightSide
	"Answer an instance of TextLineInterval that represents the next line in the paragraph."
	| runLength stopCondition |
	"Set up margins"
	leftMargin := lineRectangle left.
	leftSide ifTrue: [leftMargin := leftMargin +
						(firstLine ifTrue: [textStyle firstIndent]
								ifFalse: [textStyle restIndent])].
	destX := spaceX := leftMargin.
	rightMargin := lineRectangle right.
	rightSide ifTrue: [rightMargin := rightMargin - textStyle rightIndent].
	lastIndex := startIndex.	"scanning sets last index"
	destY := lineRectangle top.
	lineHeight := baseline := 0.  "Will be increased by setFont"
	line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
				rectangle: lineRectangle.
	self setStopConditions.	"also sets font"
	runLength := text runLengthFor: startIndex.
	runStopIndex := (lastIndex := startIndex) + (runLength - 1).
	nextIndexAfterLineBreak := spaceCount := 0.
	lastBreakIsNotASpace := false.
	self handleIndentation.
	leftMargin := destX.
	line leftMargin: leftMargin.

	[stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex
		in: text string rightX: rightMargin.
	"See setStopConditions for stopping conditions for composing."
	self perform: stopCondition] whileFalse.

	^ line
		lineHeight: lineHeight + textStyle leading
		baseline: baseline + textStyle leading! !

!CompositionScanner methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	stopConditions := wantsColumnBreaks == true
		ifTrue: [ColumnBreakStopConditions]
		ifFalse: [CompositionStopConditions]! !

!CompositionScanner methodsFor: 'scanning' stamp: ''!
computeDefaultLineHeight
	"Compute the default line height for a potentially empty text"

	^ rightMargin notNil
		ifTrue: [ lastIndex := 1.
			self setFont.
			lineHeight + textStyle leading ]
		ifFalse: [ textStyle lineGrid ]! !

!CompositionScanner methodsFor: 'stop conditions' stamp: ''!
space
	"Record left x and character index of the space character just encountered. 
	Used for wrap-around. Answer whether the character has crossed the 
	right edge of the composition rectangle of the paragraph."

	spaceX := destX.
	spaceIndex := lastIndex.
	lineHeightAtSpace := lineHeight.
	baselineAtSpace := baseline.
	spaceCount := spaceCount + 1.
	lastBreakIsNotASpace := false.
	destX + spaceWidth > rightMargin ifTrue:[^self crossedX].
	destX := spaceX + spaceWidth + kern.
	lastIndex := lastIndex + 1.
	^false
! !

!CompositionScanner methodsFor: 'stop conditions' stamp: ''!
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
! !

!CompositionScanner methodsFor: 'stop conditions' stamp: ''!
wrapHere
	"Wrap the line before current character."
	pendingKernX := 0.
	nextIndexAfterLineBreak := lastIndex.
	lastIndex := lastIndex - 1.
	spaceX := destX.
	line paddingWidth: rightMargin - destX.
	line stop: (lastIndex max: line first).
	^true! !

!CompositionScanner methodsFor: 'text attributes' stamp: ''!
setActualFont: aFont

	"Keep track of max height and ascent for auto lineheight"

	| descent |

	super setActualFont: aFont.
	lineHeight
		ifNil: [ descent := font descent.
			baseline := font ascent.
			lineHeight := baseline + descent
			]
		ifNotNil: [ descent := lineHeight - baseline max: font descent.
			baseline := baseline max: font ascent.
			lineHeight := lineHeight max: baseline + descent
			]! !

!CompositionScanner methodsFor: 'stop conditions' stamp: ''!
crossedX
	"There is a word that has fallen across the right edge of the composition 
	rectangle. This signals the need for wrapping which is done to the last 
	space that was encountered, as recorded by the space stop condition,
	or any other breakable character if the language permits so."

	pendingKernX := 0.
	
	lastBreakIsNotASpace ifTrue:
		["In some languages line break is possible before a non space."
		^self wrapAtLastBreakable].
	 
	spaceCount >= 1 ifTrue:
		["The common case. there is a space on the line."
		^self wrapAtLastSpace].
	
	"Neither internal nor trailing spaces -- almost never happens."
	self advanceIfFirstCharOfLine.
	^self wrapHere! !

!CompositionScanner methodsFor: 'initialize' stamp: ''!
wantsColumnBreaks: aBoolean

	wantsColumnBreaks := aBoolean! !

!CompositionScanner methodsFor: 'stop conditions' stamp: ''!
cr
	"Answer true. Set up values for the text line interval currently being 
	composed."

	pendingKernX := 0.
	(lastIndex < text size and: [(text at: lastIndex) = CR and: [(text at: lastIndex+1) = Character lf]]) ifTrue: [lastIndex := lastIndex + 1].
	line stop: lastIndex.
	nextIndexAfterLineBreak := lastIndex + 1.
	spaceX := destX.
	lastBreakIsNotASpace := false.
	line paddingWidth: rightMargin - spaceX.
	^true! !

!CompressedBoundaryShape commentStamp: ''!
This class represents a very compact representation of a boundary shape. It consists of a number of compressed arrays that can be handled by the balloon engine directly. Due to this, there are certain restrictions (see below). Boundaries are always represented by three subsequent points that define a quadratic bezier segment. It is recommended that for straight line segments the control point is set either to the previous or the next point.

Instance variables:
	points		<PointArray | ShortPointArray>	Point storage area
	leftFills		<ShortRunArray>	Containing the "left" fill index of each segment
	rightFills	<ShortRunArray>	Containing the "right" fill index of each segment
	lineWidths	<ShortRunArray>	Containing the line width of each segment
	lineFills		<ShortRunArray>	Containing the line fill (e.g., line color) of each segment
	fillStyles	<Collections>			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: ''!
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: ''!
leftFills
	^leftFills! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: ''!
points
	^points! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: ''!
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: ''!
collectFills: aBlock
	fillStyles := fillStyles collect: aBlock.! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: ''!
rightFills
	^rightFills! !

!CompressedBoundaryShape methodsFor: 'editing' stamp: ''!
copyAndCollectFills: aBlock
	^self copy collectFills: aBlock! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: ''!
numSegments
	^points size // 3! !

!CompressedBoundaryShape methodsFor: 'morphing' stamp: ''!
morphFrom: srcShape to: dstShape at: ratio
	| scale unscale srcPoints dstPoints pt1 pt2 x y |
	scale := (ratio * 1024) asInteger.
	scale < 0 ifTrue:[scale := 0].
	scale > 1024 ifTrue:[scale := 1024].
	unscale := 1024 - scale.
	srcPoints := srcShape points.
	dstPoints := dstShape points.
	1 to: points size do:[:i|
		pt1 := srcPoints at: i.
		pt2 := dstPoints at: i.
		x := ((pt1 x * unscale) + (pt2 x * scale)) bitShift: -10.
		y := ((pt1 y * unscale) + (pt2 y * scale)) bitShift: -10.
		points at: i put: x@y].! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: ''!
lineFills
	^lineFills! !

!CompressedBoundaryShape methodsFor: 'private' stamp: ''!
setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList
	points := pointList.
	leftFills := leftFillList.
	rightFills := rightFillList.
	lineWidths := lineWidthList.
	lineFills := lineFillList.
	fillStyles := fillStyleList.! !

!CompressedBoundaryShape methodsFor: 'enumerating' stamp: ''!
segmentsDo: aBlock
	"Enumerate all segments in the receiver and execute aBlock"
	| p1 p2 p3 |
	1 to: points size by: 3 do:[:i|
		p1 := points at: i.
		p2 := points at: i+1.
		p3 := points at: i+2.
		(p1 = p2 or:[p2 = p3]) ifTrue:[
			aBlock value: (LineSegment from: p1 to: p3).
		] ifFalse:[
			aBlock value: (Bezier2Segment from: p1 via: p2 to: p3).
		].
	].! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: ''!
lineWidths
	^lineWidths! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: ''!
fillStyles
	^fillStyles! !

!CompressedBoundaryShape class methodsFor: 'instance creation' stamp: ''!
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! !

!ComputedSlot commentStamp: ''!
This is an example for a virtual slot that computes its value. 

It stores a block which is evaluated with the object as a parameter to calculate the value
on read. Writing is ignored.

e.g. make a class lile this:

Object subclass: #TT
	slots: { #i => ComputedSlot with: [ :o | o class methods size ] }
	classVariables: {  }
	package: 'TT'!
!ComputedSlot methodsFor: 'comparing' stamp: ''!
= other
	^ super = other and: [block = other block]! !

!ComputedSlot methodsFor: 'comparing' stamp: ''!
hash
	^super hash bitXor: block hash! !

!ComputedSlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	"we use #cull: to support both 0-arg and 1-arg blocks"
	^block cull: anObject
	! !

!ComputedSlot methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		store: self name;
		nextPutAll: ' => ';
		nextPutAll: self class name;
		nextPutAll: ' with: ';
		print: block ! !

!ComputedSlot methodsFor: 'comparing' stamp: ''!
hasSameDefinitionAs: otherSlot
	"other then #=, we use string comparision for the blocks here"
	^ (super hasSameDefinitionAs: otherSlot) 
		and: [ block printString = otherSlot block printString ]
! !

!ComputedSlot methodsFor: 'instance creation' stamp: ''!
with: aBlock
	block := aBlock! !

!ComputedSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
	"ignored, as the slot returns the computed value on read"! !

!ComputedSlot methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder
	"generate the bytecode for 'block cull: self'"
	methodBuilder
		pushLiteral: block;
		pushReceiver;
		send: #cull:.! !

!ComputedSlotTest methodsFor: 'tests' stamp: ''!
testReadComputedSlotReflectiveNoArg
	| slot object |
	slot := #slot1 => ComputedSlot with: [3 + 2 ].
	aClass := self make: [ :builder | builder slots: {slot} ].
	self assert: (aClass hasSlotNamed: #slot1).

	object := aClass new.
	
	self assert: (slot read: object) equals: 5! !

!ComputedSlotTest methodsFor: 'tests' stamp: ''!
testReadComputedSlotReflective
	| slot object |
	slot := #slot1 => ComputedSlot with: [:obj | 3 + 2 ].
	aClass := self make: [ :builder | builder slots: {slot} ].
	self assert: (aClass hasSlotNamed: #slot1).
	object := aClass new.
	
	self assert: (slot read: object) equals: 5! !

!ComputedSlotTest methodsFor: 'tests' stamp: ''!
testReadComputedSlotCompiled
	| object slot |
	slot := #slot1 => ComputedSlot with: [:obj | 3 + 2 ].
	aClass := self make: [ :builder | builder slots: {slot} ].
	self assert: (aClass hasSlotNamed: #slot1).
	
	object := aClass new.
	
	"The slot is virtual and does not use memory"
	self assert: object basicSize  equals: 0.
	
	"now compile an accessor and read"
	self compileAccessorsFor: slot.
	self assert: object slot1 equals: 5! !

!ComputedSlotTest methodsFor: 'tests' stamp: ''!
testWriteComputedSlotCompiled
	| slot object |
	slot := #slot1 => ComputedSlot with: [:obj | 3 + 2 ].
	aClass := self make: [ :builder | builder slots: {slot} ].
	self assert: (aClass hasSlotNamed: #slot1).
	
	object := aClass new.
	
	"now compile an accessor and write"
	self compileAccessorsFor: slot.
	object slot1: 10.
	"the write is ignored"
	self assert: object slot1 equals: 5! !

!ConfigurableHistoryIterator commentStamp: ''!
I am an history iterator you can configure with two blocks. One to define what to do during the redo action and the second to define what to do during the undo action. 

Then you can register context objects to me and ask to undo and redo actions, I will then use my undo and redo actions with my stored context to execute it.

Examples
--------------------
	
	| saved history |
	history := self
		undo: [ :integer | saved := integer ]
		redo: [ :integer | saved := integer asString ].
	
	history hasPrevious. "false"
	history hasNext. "false" 
	
	history register: 3.
	
	history current. "3"
	history hasNext. "false"
	history hasPrevious. "true"
	
	history undo.
	saved. "3"
	
	history hasPrevious. "false"
	history undo. "EXCEPTION: NothingToUndo"
	
	history undoIfEmpty: [ saved := nil ].
	saved. "nil"
	
	history register: 3.
	history register: 4.
	
	history undo.
	history undo.
	
	history hasNext. "true"
	history redo.
	saved. "'3'"
	history redo.
	saved. "'4'"
	history redo. "EXCEPTION: NothingToRedo"
	
	history redoIfEmpty: [ saved := nil ].
	saved. "nil"
	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	redoAction:		<aValuable>		A valuable to execute when we redo an action.
	redoStack:		<aStack>			A stack containing the contexts that can be redone.
	undoAction:		<aValuable>		A valuable to execute when we undo an action.
	undoStack:		<aStack>			A stack containing the contexts that can be undone.
						
	I work with a system of two stacks:
	- One stack to store contexts to undo 
	- One stack to store contexts to redo
	
	When the user wants to undo something, I'll pop the undo stack, evaluate the undo action with it and push it on the redo stack.
	When the user wants to redo something, I'll pop the redo stack, evaluate the redo action with it and push it on the undo stack.
	
	When the user add a new context on the undo stack, I flush the redo stack.
!
!ConfigurableHistoryIterator methodsFor: 'actions' stamp: ''!
undo
	"Undo the previous action, in case there is none, raise an exception."

	self undoIfEmpty: [ NothingToUndo signal ]! !

!ConfigurableHistoryIterator methodsFor: 'testing' stamp: ''!
hasNext
	"Return true if there is at least one action to redo."

	^ redoStack isNotEmpty! !

!ConfigurableHistoryIterator methodsFor: 'accessing' stamp: ''!
current
	"I return the current element of the iteration. In case there is nothing to undo, I raise an exception."

	self hasPrevious ifFalse: [ NothingToUndo signal ].
	^ undoStack top! !

!ConfigurableHistoryIterator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	undoStack := Stack new.
	redoStack := Stack new! !

!ConfigurableHistoryIterator methodsFor: 'actions' stamp: ''!
redoIfEmpty: aBlockClosure
	"Redo the next action and register it in the undo list. In case there is no next action, execute the block as parameter."

	| element |
	self hasNext ifFalse: [ ^ aBlockClosure value ].
	element := redoStack pop.
	redoAction value: element.
	undoStack push: element! !

!ConfigurableHistoryIterator methodsFor: 'actions' stamp: ''!
undoIfEmpty: aBlockClosure
	"Redo the previous action and register it in the redo list. In case there is no previous action, execute the block as parameter."
	| element |
	self hasPrevious ifFalse: [ ^ aBlockClosure value ].
	element := undoStack pop.
	undoAction value: element.
	redoStack push: element! !

!ConfigurableHistoryIterator methodsFor: 'testing' stamp: ''!
hasPrevious
	"Return true if there is at least one action to undo."

	^ undoStack isNotEmpty! !

!ConfigurableHistoryIterator methodsFor: 'accessing' stamp: ''!
undoAction: anObject
	undoAction := anObject! !

!ConfigurableHistoryIterator methodsFor: 'accessing' stamp: ''!
redoAction: anObject
	redoAction := anObject! !

!ConfigurableHistoryIterator methodsFor: 'accessing' stamp: ''!
size
	"Return the size of the previous history"

	^ undoStack size! !

!ConfigurableHistoryIterator methodsFor: 'actions' stamp: ''!
redo
	"Redo the next action, in case there is none, raise an exception."

	self redoIfEmpty: [ NothingToRedo signal ]! !

!ConfigurableHistoryIterator methodsFor: 'adding' stamp: ''!
register: anObject
	"Register an object to the undo list. This will flush the redo list."

	undoStack push: anObject.
	redoStack removeAll! !

!ConfigurableHistoryIterator class methodsFor: 'instance creation' stamp: ''!
action: aBlock
	^ self undo: aBlock redo: aBlock! !

!ConfigurableHistoryIterator class methodsFor: 'instance creation' stamp: ''!
undo: aBlockClosure redo: aBlockClosure2
	^ self new
		undoAction: aBlockClosure;
		redoAction: aBlockClosure2;
		yourself! !

!ConfigurableHistoryIteratorTest methodsFor: 'tests' stamp: ''!
testHasPrevious
	historyList register: 3.

	self assert: historyList hasPrevious.

	historyList undo.

	self deny: historyList hasPrevious! !

!ConfigurableHistoryIteratorTest methodsFor: 'tests' stamp: ''!
testRegister
	historyList register: 3.
	self assert: historyList size equals: 1.
	self assert: historyList current identicalTo: 3.

	historyList register: 5.
	self assert: historyList size equals: 2.
	self assert: historyList current identicalTo: 5! !

!ConfigurableHistoryIteratorTest methodsFor: 'tests' stamp: ''!
testUndo
	historyList register: 3.
	historyList register: 5.

	self assert: historyList hasPrevious.
	self assert: historyList current identicalTo: 5.

	historyList undo.

	self assert: historyList hasPrevious.
	self assert: historyList current identicalTo: 3.
	self assert: saved equals: 5.

	historyList undo.

	self deny: historyList hasPrevious.
	self should: [ historyList current ] raise: NothingToUndo.
	self assert: saved equals: 3.
	self should: [ historyList undo ] raise: NothingToUndo! !

!ConfigurableHistoryIteratorTest methodsFor: 'tests' stamp: ''!
testUndoIfEmpty
	historyList register: 3.

	self assert: historyList hasPrevious.
	self assert: historyList current identicalTo: 3.

	historyList undoIfEmpty: [ saved := nil ].

	self deny: historyList hasPrevious.
	self assert: saved equals: 3.

	historyList undoIfEmpty: [ saved := nil ].

	self assert: saved isNil! !

!ConfigurableHistoryIteratorTest methodsFor: 'tests' stamp: ''!
testRedoIfEmpty
	historyList register: 3.

	historyList undo.

	self assert: historyList hasNext.

	historyList redoIfEmpty: [ saved := nil ].

	self deny: historyList hasNext.
	self assert: saved equals: '3'.
	
	historyList redoIfEmpty: [ saved := nil ].

	self assert: saved isNil! !

!ConfigurableHistoryIteratorTest methodsFor: 'tests' stamp: ''!
testRegisterClearRedo
	historyList register: 3.
	historyList register: 5.

	historyList undo.

	self assert: historyList size equals: 1.
	self assert: historyList hasNext.

	historyList register: 4.

	self assert: historyList size equals: 2.
	self deny: historyList hasNext! !

!ConfigurableHistoryIteratorTest methodsFor: 'tests' stamp: ''!
testHasNext
	historyList register: 3.

	self deny: historyList hasNext.

	historyList undo.

	self assert: historyList hasNext! !

!ConfigurableHistoryIteratorTest methodsFor: 'tests' stamp: ''!
testRedo
	historyList register: 3.
	historyList register: 5.

	historyList undo.
	historyList undo.

	self assert: historyList hasNext.

	historyList redo.

	self assert: historyList hasNext.
	self assert: saved equals: '3'.
	self assert: historyList current equals: 3.
	
	historyList redo.

	self deny: historyList hasNext.
	self assert: saved equals: '5'.
	self assert: historyList current equals: 5.
	
	self should: [ historyList redo ] raise: NothingToRedo! !

!ConfigurableHistoryIteratorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	historyList := ConfigurableHistoryIterator undo: [ :integer | saved := integer ] redo: [ :integer | saved := integer asString ]! !

!ConfigurationCommandLineHandler commentStamp: ''!
Command line handler for dealing with Metacello configurations from the command line

Usage: config [--help] <repository url> [<configuration>] [--install[=<version>]] [--group=<group>] [--username=<username>] [--password=<password>][--no-quit][--no-save]
	--help              show this help message
	--no-quit        keep the image running after configuration install
	--no-save       Don't save the image after configuration install
	<repository url>    A Monticello repository name 
	<configuration>     A valid Metacello Configuration name
	<version>           A valid version for the given configuration
	<group>             A valid Metacello group name
	<username>          An optional username to access the configuration's repository
	<password>          An optional password to access the configuration's repository
	
Examples:
	# display this help message
	pharo Pharo.image config
	
	# list all configurations of a repository
	pharo Pharo.image config $MC_REPOS_URL
	
	# list all the available versions of a confgurtation
	pharo Pharo.image config $MC_REPOS_URL ConfigurationOfFoo
	
	# install the stable version
	pharo Pharo.image config $MC_REPOS_URL ConfigurationOfFoo --install
	
	#install a specific version '1.5'
	pharo Pharo.image config $MC_REPOS_URL ConfigurationOfFoo --install=1.5
	
	#install a specific version '1.5' and only a specific group 'Tests'
	pharo Pharo.image config $MC_REPOS_URL ConfigurationOfFoo --install=1.5 --group=Tests
!
!ConfigurationCommandLineHandler methodsFor: 'actions' stamp: ''!
listConfigurations
	"List possible configurations of the given repository"
	
	| configurations |
	
	self inform: 'All Configurations found in ', self repositoryUrl.
	
	configurations := self loadConfigurationNames.
	configurations ifEmpty: [ ^ self errorNoConfigurationsFound ].
	self printConfigurations: configurations.
	
	^ self exitSuccess! !

!ConfigurationCommandLineHandler methodsFor: 'printing' stamp: ''!
printConfigurations: configurations

	self inform: (String streamContents:  [ :s|
		s
			nextPutAll: 'Found ';
			print: configurations size;
			nextPutAll: ' Configuration';
			nextPutAll: (configurations size = 1 ifTrue: [':'] ifFalse: ['s:']) ]).
	
	configurations do: [ :name | 
			self << name. 
			self stdout lf ].! !

!ConfigurationCommandLineHandler methodsFor: 'actions' stamp: ''!
installConfiguration
	self installVersion: self configurationVersion! !

!ConfigurationCommandLineHandler methodsFor: 'actions' stamp: ''!
loadConfigurationNames
	| references |
	
	references := self gofer allResolved.
		
	references := references 
			collect: #packageName 
			thenSelect: [ :name| name beginsWith: 'ConfigurationOf' ].
	
	^ references asSet asSortedCollection! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
configuration
	| gofer |
	gofer := self gofer.
	self hasConfiguration 
		ifTrue: [ gofer package: self configurationName ]
		ifFalse: [ gofer configuration ].
	gofer load.
	^ Smalltalk globals at: self configurationName asSymbol! !

!ConfigurationCommandLineHandler methodsFor: 'actions' stamp: ''!
errorNoConfigurationsFound

	self exitFailure: 'No Configurations found in ', repositoryURL asString! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
loadRepositoryUrl
	| possibleUrl |
	possibleUrl := self argumentAt: 1.
	(possibleUrl includesSubstring: '://')
		ifTrue: [ ^ possibleUrl asUrl ].
	^ possibleUrl asFileReference! !

!ConfigurationCommandLineHandler methodsFor: 'actions' stamp: ''!
listConfigurationDetails
	"List possible configurations of the given repository"
	
	self printMetacelloProjectDetails: self project.
	
	^ self exitSuccess! !

!ConfigurationCommandLineHandler methodsFor: 'actions' stamp: ''!
handleMergeConflictDuring: aLoadBlock
	[aLoadBlock 
	on: MCMergeOrLoadWarning do: [ :mergeConflict | mergeConflict merge ]]
	on: MCMergeResolutionRequest do: [ :request |  request autoMerge ].! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
noSave
	^ self hasOption: 'no-save'! !

!ConfigurationCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self activateHelpWithoutArguments
		ifTrue: [ ^ self ].
	
	(self hasOption: 'install')
		ifFalse: [ ^ self list ].
		
	self installConfiguration.
	
	self postConfiguration.! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
configurationVersion
	^ (self hasOption: 'install')
		ifFalse: [ #stable ]
		ifTrue: [ self optionAt: 'install' ]! !

!ConfigurationCommandLineHandler methodsFor: 'actions' stamp: ''!
list
	(self hasConfiguration or: [ self hasRepositoryUrl ])
		ifTrue: [ self listConfigurationDetails ]
		ifFalse: [ self listConfigurations ]! !

!ConfigurationCommandLineHandler methodsFor: 'actions' stamp: ''!
postConfiguration
	Smalltalk snapshot: (self noSave not) andQuit: (self noQuit not).! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
defaultRepositoryUrl
	^ 'http://smalltalkhub.com/mc/Pharo/MetaRepoForPharo', SystemVersion current major asString, SystemVersion current minor asString, '/main'! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
configurationName
	^ configurationName ifNil: [
			self hasConfiguration 
				ifFalse: [ "Demeters favourite line :("
					^ self gofer configuration references last name ].
		 configurationName := self argumentAt: 2 ]! !

!ConfigurationCommandLineHandler methodsFor: 'testing' stamp: ''!
hasRepositoryUrl
	^ self arguments size > 0 and: [ 
		| possibleUrl |
		possibleUrl := self arguments first.
		"check if the first argument is some sort of a URL"
		(possibleUrl includesSubstring: '://') or: [ possibleUrl first = $. ]]! !

!ConfigurationCommandLineHandler methodsFor: 'testing' stamp: ''!
hasConfiguration
	self flag: 'TODO: should use proper cli parser Coral??'.
	^ (self arguments size > 1) and: [
		((self argumentAt: 2) beginsWith: '-') not ]! !

!ConfigurationCommandLineHandler methodsFor: 'printing' stamp: ''!
printMetacelloProjectDetails: metacelloProject
	| versions |
	self inform: 'Available versions for ', self configurationName.
	
	versions := metacelloProject symbolicVersionMap keys asSet.
	versions addAll: metacelloProject map keys.
	versions add: #last.
	
	"print the found version sorted alphabetically"
	versions asArray sorted do:[ :key|
		self stdout nextPutAll: key; lf ]! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
project
	^ self configuration project! !

!ConfigurationCommandLineHandler methodsFor: 'actions' stamp: ''!
installVersion: aVersionName
	| metacelloVersion |
	self inform: 'Installing ', self configurationName, ' ', aVersionName.
	
	metacelloVersion := (self metacelloVersion: aVersionName).
	
	self handleMergeConflictDuring: [
		(self hasOption: 'group')
			ifTrue: [ metacelloVersion load: self groups ]
			ifFalse: [ metacelloVersion load ]].! !

!ConfigurationCommandLineHandler methodsFor: 'actions' stamp: ''!
metacelloVersion: aVersionName
	| project |
	project := self project.
	^ [ project version: aVersionName ] 
		on: MetacelloVersionDoesNotExistError do: [ :error |
			aVersionName = 'last'
				ifTrue: [
					"manual fallback since there is no symbolic name for lastVersion"
					project lastVersion ]
				ifFalse: [ 
					"symbols and strings are not equal in Meteacello..."
					project version: aVersionName asSymbol ]].! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
noQuit
	^ self hasOption: 'no-quit'! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
repositoryUrl
	^ repositoryURL ifNil: [ 
		self hasRepositoryUrl 
			ifFalse: [ ^ self defaultRepositoryUrl ].
		repositoryURL := self loadRepositoryUrl ]! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
groups
	^ (self optionAt: 'group') substrings: {$,}! !

!ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: ''!
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 class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'config'! !

!ConfigurationCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Install and inspect Metacello Configurations from the command line'! !

!ConfigurationCommandLineHandlerTest commentStamp: ''!
SUnit tests for class ConfigurationCommandLineHandler!
!ConfigurationCommandLineHandlerTest methodsFor: 'convenience' stamp: ''!
argumentsWith: aCollection
	^ CommandLineArguments withArguments: aCollection! !

!ConfigurationCommandLineHandlerTest methodsFor: 'convenience' stamp: ''!
command: arguments
	^ ConfigurationCommandLineHandler commandLine: (self argumentsWith: arguments)! !

!ConfigurationCommandLineHandlerTest methodsFor: 'tests' stamp: ''!
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: ''!
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: ''!
testResponsibility
	| args |
	args := self argumentsWith: #('config').
	self assert: (ConfigurationCommandLineHandler isResponsibleFor: args).! !

!ConfigurationCommandLineHandlerTest methodsFor: 'convenience' stamp: ''!
activate: arguments
	^ PharoCommandLineHandler activateWith: (self argumentsWith: arguments)! !

!ConfigurationCommandLineHandlerTest methodsFor: 'tests' stamp: ''!
testGroups
	| cli |
	cli := self command: #('http://ss3.gemstone.com/ss/MetaRepoForPharo20' '--group=foo').
	self assertCollection: cli groups equals: {'foo'}.
	
	cli := self command: #('http://ss3.gemstone.com/ss/MetaRepoForPharo20' '--group=foo,boo').
	self assertCollection: cli groups equals: {'foo' . 'boo'}.! !

!ConfigurationOf commentStamp: ''!
You must use a *configuration* when your project is stored in a
repository using `.mcz` files.

If you are using a source code manager (SCM) like [git][1] and have
created a *baseline* (see the [**BaselineOf** class comment][3] for more info)
you may use a *configuration* to associate a specific
git commit (SHA, branch name, tag name) with a [Metacello version][2].

To create a new Metacello configuration:

1. Create a subclass of the **ConfigurationOf** class. The configuration
   class for your project should be names by appending the name of
   your project to the string `ConfigurationOf`. The name of the
   category and package should be the same as the name of the class:

    ```Smalltalk
    ConfigurationOf subclass: #ConfigurationOfExample
      instanceVariableNames: ''
      classVariableNames: ''
      poolDictionaries: ''
      category: 'ConfigurationOfExample'
    ```

2. Create a **baselineXXXX:** method where you specify the structure of your project:

    ```Smalltalk
    baseline0100: spec
      <baseline: '1.0-baseline'>

      spec for: #common do: [
        spec repository: 'http://ss3.gemstone.com/ss/Example'.
        spec
          package: 'Example-Core';
          package: 'Example-Tests' with: [
            spec requires: 'Example-Core' ]].
    ```

3. Create a **versionXXXX:** method where you specify the specific
   versions of the packages to be loaded for this version:

    ```Smalltalk
    version01000: spec
      <version: '1.0' imports: #('1.0-baseline')>

      spec for: #common do: [
        spec blessing: #release.
        spec
          package: 'Example-Core' with: 'Example-Core';
          package: 'Example-Tests' with: 'Example-Tests' ].
    ```

4. Create a Monticello package for your **ConfigurationOf** class and save it in the repository where your packages are stored. 

[1]: http://git-scm.com/
[2]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#metacello-version-numbers
[3]: https://github.com/dalehenrich/metacello-work/blob/master/repository/Metacello-Base.package/BaselineOf.class/README.md
!
!ConfigurationOf methodsFor: 'accessing' stamp: ''!
project: aProject

	project ifNil: [ self class ensureMetacello ].
	project := aProject! !

!ConfigurationOf methodsFor: 'accessing' stamp: ''!
versionNumberClass
    ^ MetacelloSemanticVersionNumber! !

!ConfigurationOf methodsFor: 'private' stamp: ''!
versionDoesNotExistError: versionStringOrSymbol

	((Smalltalk at: #MetacelloSymbolicVersionDoesNotExistError) project: self project versionString: versionStringOrSymbol) signal! !

!ConfigurationOf methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!ConfigurationOf methodsFor: 'defaults' stamp: ''!
defaultBleedingEdgeVersion
	| bleedingEdgeVersion |
	bleedingEdgeVersion := (self project map values select: [ :version | version blessing == #baseline ])
		detectMax: [ :version | version ].
	bleedingEdgeVersion ifNil: [ ^#'notDefined' ].
	^ bleedingEdgeVersion versionString! !

!ConfigurationOf methodsFor: 'accessing' stamp: ''!
project
    ^ project
        ifNil: [ 
            "Bootstrap Metacello if it is not already loaded"
            self class ensureMetacello.
            project := self projectClass new projectAttributes: self customProjectAttributes.	"Create the Metacello project"
            project versionNumberClass: self versionNumberClass.
            project class versionConstructorClass on: self project: project.	"Construct the project"
            project loadType: #'linear'.	"change to #atomic if desired"
            project ]! !

!ConfigurationOf methodsFor: 'defaults' stamp: ''!
bleedingEdge 
	"override if different behavior desired.
	 Use:
		self versionDoesNotExistError: #bleedingEdge
	 if #bleedingEdge version is disallowed."

	<defaultSymbolicVersion: #bleedingEdge>
	
	^self defaultBleedingEdgeVersion! !

!ConfigurationOf methodsFor: 'accessing' stamp: ''!
customProjectAttributes
    "Edit to return a collection of any custom attributes e.g. for conditional loading: Array with: #'Condition1' with: #'Condition2.
	For more information see: http://code.google.com/p/metacello/wiki/CustomProjectAttrributes "

    ^ #()! !

!ConfigurationOf class methodsFor: 'private' stamp: ''!
ensureGoferVersion: goferVersion repositoryUrl: repositoryUrl
	"load the p=file goferVersion if Gofer isn't loaded or an earlier version of Gofer is currently loaded"

	| goferVersionNumber wc pName env |
	env := self environment.
	(env at: #Gofer ifAbsent: [  ]) == nil
		ifTrue: [ ^ self bootstrapPackage: goferVersion from: repositoryUrl ].
	goferVersionNumber := (goferVersion copyAfterLast: $.) asNumber.
	wc := [ ((env at: #GoferPackageReference) name: 'Gofer') workingCopy ]
		on: Error
		do: [ :ex | 
			ex
				return: ((env at: #GoferPackageReference) name: 'Gofer-Core') workingCopy ].
	pName := wc ancestry ancestors first name.
	(pName copyAfterLast: $.) asNumber <= goferVersionNumber
		ifTrue: [ self bootstrapPackage: goferVersion from: repositoryUrl ]! !

!ConfigurationOf class methodsFor: 'private' stamp: ''!
ensureMetacello: loadList
	"Bootstrap Metacello, retry using alternate repository, if primary repository is not accessible"

	| env |
	env := self environment.
	env
		at: #MetacelloProject
		ifAbsent: [ | version error gofer |
			(Array
				with: 'http://smalltalkhub.com/mc/dkh/metacello/main'
				with: 'http://seaside.gemtalksystems.com/ss/metacello')
				do: [ :repositoryUrl | 
					"bootstrap Metacello"
					[ self bootstrapMetacelloFrom: repositoryUrl.
					env
						at: #ConfigurationOfMetacello
						ifAbsent: [ self
								retry: [ gofer := (env at: #Gofer) new.
									gofer
										perform: #url: with: repositoryUrl;
										perform: #package: with: 'ConfigurationOfMetacello';
										perform: #load ] ].
					version := (env at: #ConfigurationOfMetacello)
						project version: #previewBootstrap.
					version load: loadList.
					self
						retry: [ gofer := (env at: #Gofer) new.
							env
								at: #ConfigurationOfMetacelloPreview
								ifAbsent: [ gofer
										perform: #url: with: repositoryUrl;
										perform: #package: with: 'ConfigurationOfMetacelloPreview';
										perform: #load ] ].
					version := (env at: #ConfigurationOfMetacelloPreview)
						project version: #stable.	"load latest from GitHub"
					version load: loadList.
					^ self ]
						on: Error
						do: [ :ex | 
							error := ex.
							MetacelloNotification signal:
									(String
										streamContents: [ :stream | 
											stream nextPutAll: 'failed ensureMetacello using '.
											repositoryUrl printOn: stream.
											stream nextPutAll: ' : '.
											ex description printOn: stream.
											stream nextPutAll: '...retrying' ]).	"try again"
							ex return: nil ] ].	"shouldn't get here unless the load failed ... throw an error"
			self
				error:
					'retry with alternate repository failed: '
						, error description printString ]! !

!ConfigurationOf class methodsFor: 'private' stamp: ''!
bootstrapPackage: aString from: aPath
    | repository version |
    repository := (MCCacheRepository default includesVersionNamed: aString)
        ifTrue: [ MCCacheRepository default ]
        ifFalse: [ MCHttpRepository location: aPath user: '' password: '' ].
    self
        retry: [ 
            repository
                versionReaderForFileNamed: aString , '.mcz'
                do: [ :reader | 
                    version := reader version.
                    version load.
                    version workingCopy repositoryGroup addRepository: repository ] ]! !

!ConfigurationOf class methodsFor: 'private' stamp: ''!
ensureMetacello
    "Bootstrap Metacello and load the 'bootstrap' group"

    self ensureMetacello: #('batch')! !

!ConfigurationOf class methodsFor: 'private' stamp: ''!
retry: aBlock retryCount: retryCount
	| count |
	count := 1.
	[ true ]
		whileTrue: [ [ aBlock value.
			^ self ]
				on: Error
				do: [ :ex | 
					count < retryCount
						ifTrue: [ MetacelloNotification signal: 'RETRYING AFTER: ', String cr, ex description.
							(Delay forSeconds: 5) wait ]
						ifFalse: [ MetacelloNotification signal: 'FAILED RETRYING:', String cr, ex description.
							ex pass ] ].
			count := count + 1 ]! !

!ConfigurationOf class methodsFor: 'accessing' stamp: ''!
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"

	<apiDocumentation>
	self ensureMetacello.
	^ ((self environment at: #MetacelloToolBox) validateConfiguration: self debug: #() recurse: false) inspect! !

!ConfigurationOf class methodsFor: 'unloading Metacello' stamp: ''!
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"

	<apiDocumentation>
	| 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.! !

!ConfigurationOf class methodsFor: 'accessing' stamp: ''!
project

	^self new project! !

!ConfigurationOf class methodsFor: 'private' stamp: ''!
bootstrapMetacelloFrom: repositoryUrl
  "Corresponds to version 1.0.0-beta.32.6"

  "KEEP MetacelloConfigTemplate class>>ensureMetacelloBaseConfiguration in synch!!"

  | platformPkg |
  self ensureGoferVersion: 'Gofer-Core-lr.115' repositoryUrl: repositoryUrl.
  #('Metacello-Core-dkh.678' 'Metacello-MC-dkh.674')
    do: [ :pkg | self bootstrapPackage: pkg from: repositoryUrl ].
  platformPkg := self environment
    at: #'SystemVersion'
    ifPresent: [ :cl | 
      | versionString |
      versionString := cl current version.
      (versionString beginsWith: 'Squeak')
        ifTrue: [ 
          (versionString beginsWith: 'Squeak3')
            ifTrue: [ 'Metacello-Platform.squeak-dkh.5' ]
            ifFalse: [ 'Metacello-Platform.squeak-dkh.22' ] ]
        ifFalse: [ 
          (versionString beginsWith: 'Pharo')
            ifTrue: [ 
              self bootstrapPackage: 'Metacello-PharoCommonPlatform-dkh.2' from: repositoryUrl.
              (versionString beginsWith: 'Pharo2')
                ifTrue: [ 'Metacello-Platform.pharo20-dkh.33' ]
                ifFalse: [ 'Metacello-Platform.pharo-dkh.34' ] ] ] ].
  self bootstrapPackage: platformPkg from: repositoryUrl! !

!ConfigurationOf class methodsFor: 'private' stamp: ''!
retry: aBlock
    self retry: aBlock retryCount: 3! !

!ConnectionClosed commentStamp: ''!
Signals a prematurely closed connection.
!
!ConnectionQueue commentStamp: ''!
A ConnectionQueue listens on a given port number and collects a queue of client connections. In order to handle state changes quickly, a ConnectionQueue has its own process that: (a) tries to keep a socket listening on the port whenever the queue isn't already full of connections and (b) prunes stale connections out of the queue to make room for fresh ones.
!
!ConnectionQueue methodsFor: 'private' stamp: ''!
initPortNumber: anInteger queueLength: queueLength
	"Private!! Initialize the receiver to listen on the given port number. Up to queueLength connections will be queued."

	portNumber := anInteger.
	maxQueueLength := queueLength.
	connections := OrderedCollection new.
	accessSema := Semaphore forMutualExclusion.
	socket := nil.
	process := [self listenLoop] newProcess.
	process priority: Processor highIOPriority.
	process resume.! !

!ConnectionQueue methodsFor: 'public' stamp: ''!
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: ''!
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: 'private' stamp: ''!
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: ''!
pruneStaleConnections
	"Private!! The client may establish a connection and then disconnect while it is still in the connection queue. This method is called periodically to prune such sockets out of the connection queue and make room for fresh connections."

	accessSema critical: [
		| foundStaleConnection |
		foundStaleConnection := false.
		connections do: [:s |
			s isUnconnected ifTrue: [
				s destroy.
				foundStaleConnection := true]].
		foundStaleConnection ifTrue: [
			connections := connections select: [:s | s isValid]]].! !

!ConnectionQueue methodsFor: 'public' stamp: ''!
isValid
	^process notNil! !

!ConnectionQueue methodsFor: 'public' stamp: ''!
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: ''!
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: 'private' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
portNumber: anInteger queueLength: queueLength

	^ self new initPortNumber: anInteger queueLength: queueLength! !

!ConnectionRefused commentStamp: ''!
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: ''!
host: addressOrHostName port: portNumber
	host := addressOrHostName.
	port := portNumber! !

!ConnectionRefused methodsFor: 'accessing' stamp: ''!
host
	^ host! !

!ConnectionRefused methodsFor: 'accessing' stamp: ''!
port
	^ port! !

!ConnectionRefused class methodsFor: 'instance creation' stamp: ''!
host: addressOrHostName port: portNumber
	^ self new host: addressOrHostName port: portNumber! !

!ConnectionTimedOut commentStamp: ''!
Signals that a connection attempt timed out.
!
!ContainerPresenter commentStamp: ''!
I am a model for a container. My purpose is to hold multiple subwidgets to glue them together.


I should not be used directly!
!ContainerPresenter methodsFor: 'testing' stamp: ''!
isSpecContainer
	^ true! !

!ContainerPresenter methodsFor: 'api' stamp: ''!
buildAdapterWithSpec
	"Build the widget using the spec name provided as argument"
	| adapter widget aSpecLayout |	
	aSpecLayout := (self retrieveSpec: self defaultSpecSelector).
	adapter := SpecInterpreter 
		private_interpretASpec: aSpecLayout
		model: self
		selector: self defaultSpecSelector.
	widget := adapter widget.
	self setExtentAndBindingTo: widget. 
	^ adapter! !

!ContainerPresenter methodsFor: 'api - focus' stamp: ''!
eventKeyStrokesForPreviousFocus
	"String describing the keystroke to perform to jump to the previous widget"

	^ keyStrokesForPreviousFocusHolder value! !

!ContainerPresenter methodsFor: 'api - focus' stamp: ''!
eventKeyStrokesForNextFocus
	"String describing the keystroke to perform to jump to the next widget"

	^ keyStrokesForNextFocusHolder value! !

!ContainerPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(ContainerAdapter
		adapt: #(model))! !

!ContainerPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ContainerAdapter! !

!Context commentStamp: ''!
Instance variables:
	receiver: <Object> (self)
	closureOrNil: <BlockClosure|nil> 
		nil if I'm a method context
		the blockClosure being executed if I'm a block context
	method <CompiledMethod> 
		method being executed if I'm a method context
		method holding the block if I'm a block context
	variable fields: <Object> temporary variables (including arguments)

My instances hold all the dynamic state associated with the execution of either a method activation resulting from a message send or a block activation resulting from a block evaluation.
	
MethodContexts, though normal in their variable size, are actually only used in two sizes, small and large, which are determined by the temporary space required by the method being executed.

MethodContexts must only be created using the method newForMethod:.  Note that it is impossible to determine the real object size of a MethodContext except by asking for the frameSize of its method.  Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector.  Any store into stackp other than by the primitive method stackp: is potentially fatal.!
!Context methodsFor: 'private - exceptions' stamp: ''!
isHandlerContext
	"is this context for #on:do:?"
	^self isHandlerOrSignalingContext and: [ self selector == #on:do: ]! !

!Context methodsFor: 'testing' stamp: ''!
hasTemporaryVariableNamed: aName
	^ self tempNames includes: aName! !

!Context methodsFor: 'debugger access' stamp: ''!
methodClass 
	"Answer the class in which the receiver's method was found."
	
	^self compiledCode methodClass ifNil:[self receiver class].! !

!Context methodsFor: 'private - exceptions' stamp: ''!
findNextUnwindContextUpTo: aContext
	"Return the next unwind marked above the receiver, returning nil if there is none.  Search proceeds up to but not including aContext."

	| context |
	<primitive: 195>
	context := self.
	[
		(context := context sender) == nil
		or: [ context == aContext ]
	] whileFalse: [
		context isUnwindContext
			ifTrue: [ ^context ]].
	^nil! !

!Context methodsFor: 'printing' stamp: ''!
printDebugOn: aStream	
	"print a condensed for of the stack.
		For methods simply print Class >> selector
		For blocks only print the first line"
	| blockSource blockSourceSize |
	
	self printOn: aStream.
	self outerContext ifNil: [ ^ self ].
	"print the block..."
	aStream 
		nextPutAll: ' in Block: '.
	
	blockSource := [closureOrNil printStringLimitedTo: 50] on:Exception do: ['Cannot print the closure'].
	blockSourceSize := blockSource size.
	blockSource := blockSource copyUpTo: Character cr.
	
	aStream nextPutAll: blockSource.
	blockSource size < blockSourceSize
		ifTrue: [ aStream nextPutAll: '...' ].! !

!Context methodsFor: 'private' stamp: ''!
setNamedPrimitiveInformationFrom: fromMethod toMethod: toMethod
	"For named primitives, the first literal contains a special object that has information of the primitive. 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.! !

!Context methodsFor: 'private' stamp: ''!
startpc
	^closureOrNil
		ifNil:	[self compiledCode initialPC]
		ifNotNil: [closureOrNil startpc]! !

!Context methodsFor: 'initialization' stamp: ''!
privRefresh
	"Reinitialize the receiver so that it is in the state it was at its creation."
	 closureOrNil
		ifNotNil:
			[pc := closureOrNil startpc.
			self stackp: closureOrNil initialStackPointer.
			1 to: closureOrNil numCopiedValues do:
				[:i | self tempAt: closureOrNil numArgs + i put: (closureOrNil at: i)].
			closureOrNil clearTemporariesOn: self]
		ifNil:
			[pc := method initialPC.
			self stackp: method numTemps.
			method numArgs+1 to: method numTemps do:
				[:i | self tempAt: i put: nil]]! !

!Context methodsFor: 'query' stamp: ''!
bottomContext
	"Return the last context (the first context invoked) in my sender chain"

	^ self findContextSuchThat: [ :context | context sender isNil]! !

!Context methodsFor: 'instruction decoding' stamp: ''!
popIntoLiteralVariable: value 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into a literal variable of my method."

	value value: self pop! !

!Context methodsFor: 'accessing' stamp: ''!
closure
	^closureOrNil! !

!Context methodsFor: 'accessing' stamp: ''!
home 
	"Answer the context in which the receiver was defined, i.e. the context from which an ^-return should return from."

	closureOrNil == nil ifTrue:
		[^self].
	^closureOrNil outerContext home! !

!Context methodsFor: 'accessing' stamp: ''!
pc: anInteger 
	pc := anInteger! !

!Context methodsFor: 'instruction decoding' stamp: ''!
pushLiteralVariable: value 
	"Simulate the action of bytecode that pushes the contents of the literal 
	variable whose index is the argument, index, on the top of the stack."

	self push: value value! !

!Context methodsFor: 'accessing' stamp: ''!
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]! !

!Context methodsFor: 'private' stamp: ''!
activateReturn: aContext value: value
	"Activate 'aContext return: value' in place of self, so execution will return to aContext's sender"

	^ self
		activateMethod: Context theReturnMethod
		withArgs: {value}
		receiver: aContext
		class: aContext class! !

!Context methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 211>
	index isInteger ifTrue:
		[self errorSubscriptBounds: index].
	index isNumber
		ifTrue: [^self at: index asInteger put: value]
		ifFalse: [self errorNonIntegerIndex]! !

!Context methodsFor: 'query' stamp: ''!
findContextSuchThat: testBlock
	"Search self and my sender chain for first one that satisfies testBlock.  Return nil if none satisfy"

	| context |
	context := self.
	[ context isNil ] whileFalse: [
		(testBlock value: context) 
			ifTrue: [ ^ context ].
		context := context sender ].
	^ nil! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
findSecondToOldestSimilarSender
	"Search the stack for the second-to-oldest occurance of self's method.  Very useful for an infinite recursion.  Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning."

	| secondContext context lastContext |
	secondContext := self.
	context := self.
	[	lastContext := context findSimilarSender.
		lastContext isNil
	] whileFalse: [
		secondContext := context.
		context := lastContext.
	].
	^ secondContext! !

!Context methodsFor: 'private' stamp: ''!
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! !

!Context methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 212>
	"The number of indexable fields of fixed-length objects is 0"
	^self primitiveFail! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
returnSelfPrimitive

	^ 256! !

!Context methodsFor: '*OpalCompiler-Core' stamp: ''!
executedPC
	"Deeper in the stack the pc was already advanced one bytecode, so we need to go back 
	this one bytecode, which can consist of multiple bytes. But on IR, we record the *last* 
	bytecode offset as the offset of the IR instruction, which means we can just go back one"		
			
	"if we are at the start, return the startpc"		
	(pc == self startpc) ifTrue: [ ^self startpc ].
	
	"we need to guard for dead contexts (pc is nil)"
	^self isDead ifTrue: [ self endPC - 1] ifFalse: [ pc - 1].! !

!Context methodsFor: 'mirror primitives' stamp: ''!
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."

	<primitive: 62>
	"The number of indexable fields of fixed-length objects is 0"
	^0! !

!Context methodsFor: 'system simulation' stamp: ''!
pushArgs: arguments from: senderContext
	"Helps simulate action of the value primitive for closures.
	 This is used by Context>>runSimulated:contextAtEachStep:"

	closureOrNil
		ifNil: [self error: 'context needs a closure!!']
		ifNotNil: [
			"See BlockClosure>>asContextWithSender:"
			 stackp ~= (closureOrNil numArgs + closureOrNil numCopiedValues) 
				ifTrue: [ self error: 'stack pointer is incorrect!!' ]].

	1 to: closureOrNil numArgs do: [:i |
		self at: i put: (arguments at: i)].
	sender := senderContext! !

!Context methodsFor: 'testing' stamp: ''!
isEndOfProcessTermination 
	"The normal completion of any process always ends at Process>>doTerminationFromYourself method
	(see #newProcess and #terminateRealActive).
	The last instruction is the call to #suspend primitive method 
	which finally removes the process from the scheduler.
	This precise criteria of the terminated process is used here" 
	method selector == #doTerminationFromYourself ifFalse: [ ^false ].
	method methodClass == Process ifFalse: [ ^false ].	
	^pc = (self endPC - 1)! !

!Context methodsFor: 'instruction decoding' stamp: ''!
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)! !

!Context methodsFor: 'instruction decoding' stamp: ''!
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! !

!Context methodsFor: 'instruction decoding' stamp: ''!
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! !

!Context methodsFor: 'instruction decoding' stamp: ''!
pushClosureTemps: numTemps
	numTemps timesRepeat: [ self push: nil ]! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
temporaryVariables
	^self sourceNode temporaries collect: [ :each | each binding ]! !

!Context methodsFor: 'testing' stamp: ''!
hasContext: aContext 
	"Answer whether aContext is me or one of my senders"

	^ (self findContextSuchThat: [ :context | context == aContext ]) notNil! !

!Context methodsFor: 'private' stamp: ''!
cut: aContext
	"Cut aContext and its senders from my sender chain"

	| context callee |
	context := self.
	[ context == aContext ] whileFalse: [
		callee := context.
		context := context sender.
		context ifNil: [
			aContext ifNotNil: [
				self error: 'aContext not a sender' ]]].
	callee privSender: nil.! !

!Context methodsFor: '*Fuel-Core' stamp: ''!
cleanCopy 

	^ self class 
		sender: nil 
		receiver: receiver 
		method: method
		arguments: #()! !

!Context methodsFor: 'mirror primitives' stamp: ''!
object: anObject instVarAt: anIndex put: aValue 
	"Primitive. Store a value into a fixed variable in the argument anObject.
	 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 for the
	 debugger. See Object documentation whatIsAPrimitive."

	<primitive: 74>
	"Access beyond fixed fields"
	^self object: anObject basicAt: anIndex - (self objectClass: anObject) instSize put: aValue! !

!Context methodsFor: 'printing' stamp: ''!
printDetails: stream

	"Put my class>>selector and instance variables and arguments and temporaries on the stream.  Protect against errors during printing."

	| errorMessage string |
	self printOn: stream.
	stream cr.
	stream
		tab;
		nextPutAll: 'Receiver: '.
	errorMessage := '<<error during printing>>'.
	stream nextPutAll:
		([ receiver printStringLimitedTo: 90 ] on: Exception do: [ errorMessage ]).

	stream
		cr;
		tab;
		nextPutAll: 'Arguments and temporary variables: ';
		cr.
	string := [ 
	          (self tempsAndValuesLimitedTo: 80 indent: 2)
		          padRightTo: 1
		          with: $x ] on: Exception do:  [ errorMessage ].
	stream nextPutAll: string.

	stream
		cr;
		tab;
		nextPutAll: 'Receiver''s instance variables: ';
		cr.
	receiver class allInstVarNames isEmpty
		ifTrue: [ 
			stream nextPutAll:
				([ receiver printStringLimitedTo: 90 ] on: Exception do:  [ errorMessage ]) ]
		ifFalse: [ 
			[ receiver longPrintOn: stream limitedTo: 80 indent: 2 ] 
				on: Exception do:  [ stream nextPutAll: errorMessage ] ].
	stream cr! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
return: value to: aSender
	"Simulate the return of value to aSender."

	self releaseTo: aSender.
	aSender ifNil: [^ nil].
	^ aSender push: value! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
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! !

!Context methodsFor: 'debugger access' stamp: ''!
sender
	"Answer the context that sent the message that created the receiver."

	^sender! !

!Context methodsFor: '*UnifiedFFI' stamp: ''!
methodProperties
	^ self compiledCode properties! !

!Context methodsFor: 'accessing' stamp: ''!
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 compiledCode methodClass! !

!Context methodsFor: 'instruction decoding' stamp: ''!
doNop

	"do nothing"! !

!Context methodsFor: 'accessing' stamp: ''!
methodReturnContext

	^ self home.! !

!Context methodsFor: 'closure support' stamp: ''!
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! !

!Context methodsFor: 'private' stamp: ''!
cannotReturn: result to: aContext
	"The receiver tried to return result to homeContext that no longer exists."

	^ ContextCannotReturn result: result to: aContext! !

!Context methodsFor: 'testing' stamp: ''!
isDead
	"Context is dead when
	- it is self finished (returned to sender) 
	- it is at the last instruction of process termination (it is unwinded and process is suspended)"

	^ pc isNil or: [  self isEndOfProcessTermination ]! !

!Context methodsFor: 'controlling' stamp: ''!
pop
	"Answer the top of the receiver's stack and remove the top of the stack."
	| value |
	value := self at: stackp.
	self stackp: stackp - 1.
	^ value! !

!Context methodsFor: 'controlling' stamp: ''!
top
	"Answer the top of the receiver's stack."

	^self at: stackp! !

!Context methodsFor: 'instruction decoding' stamp: ''!
pushFullClosure: compiledBlock numCopied: numCopied receiverOnStack: onStack ignoreOuterContext: ignore
	| copiedValues cls |
	copiedValues := (1 to: numCopied) collect: [ :i | self pop ].
	self push: (cls := (FullBlockClosure new: numCopied) 
		outerContext: (ignore ifFalse: [self]);
		receiver: (onStack ifTrue: [ self pop ] ifFalse: [ receiver ]);
		numArgs: compiledBlock numArgs;
		compiledBlock: compiledBlock;
		yourself).
	copiedValues size to: 1 by: -1 do: [ :i |
		 cls at: copiedValues size - i + 1 put: (copiedValues at: i) ]! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
lookupVar: aSymbol
	^ self astScope lookupVar: aSymbol! !

!Context methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 211>
	index isInteger ifTrue:
		[self errorSubscriptBounds: index].
	self errorNonIntegerIndex! !

!Context methodsFor: 'private-exceptions' stamp: ''!
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)
		or: [ self nextHandlerContext canHandleSignal: exception ].! !

!Context methodsFor: 'private' stamp: ''!
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"

	<primitive: 76>
	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]
"! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
stepToSendOrReturn
	"Simulate the execution of bytecodes until either sending a message or 
	returning a value to the receiver (that is, until switching contexts)."

	| stream context |
	stream := InstructionStream on: method pc: pc.	
	[ self isDead or: [ stream willSend or: [ stream willReturn or: [ stream willStore or: [ stream willCreateBlock ] ] ] ] ]
		whileFalse: [
			context := stream interpretNextInstructionFor: self.
			context == self ifFalse: [
				"Caused by mustBeBoolean handling"
				^context ]]! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
findSimilarSender
	"Return the closest sender with the same method, return nil if none found"

	^ self sender findContextSuchThat: [ :context | 
		context compiledCode == method ]! !

!Context methodsFor: '*NewTools-Debugger' stamp: ''!
findFailedAssertionResultsInSenderChain
	|assertionContext assertionResult|
	assertionContext := self findFailedAssertionContextInSenderChain.
	assertionResult := StDebuggerAssertionFailureResult new.
	assertionResult actual: (assertionContext readVariableNamed: #actual).
	assertionResult expected: (assertionContext readVariableNamed: #expected).
	^assertionResult! !

!Context methodsFor: 'accessing' stamp: ''!
compiledCode

	^method! !

!Context methodsFor: 'accessing' stamp: ''!
numArgs
	"Answer the number of arguments for this activation."
	^closureOrNil
		ifNil: [method numArgs]
		ifNotNil: [closureOrNil numArgs]! !

!Context methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitMethodContext: self! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
unusedBytecode
	^ self respondsToUnknownBytecode! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
tempNamed: aName
	"Returns the value of the temporaries, aName"

	^(self lookupTempVar: aName) readInContext: self! !

!Context methodsFor: 'instruction decoding' stamp: ''!
pushActiveProcess
	"Simulate the action of bytecode that pushes the the active Process on the 
	top of its own stack."

	self push: Processor activeProcess! !

!Context methodsFor: 'private' stamp: ''!
insertSender: aContext
	"Insert aContext and its sender chain between me and my sender.  Return new callee of my original sender."

	| context |
	context := aContext bottomContext.
	context privSender: self sender.
	self privSender: aContext.
	^ context! !

!Context methodsFor: 'private - exceptions' stamp: ''!
exceptionsToCaptureWhenStepping

	| exceptionsToCapture exceptionsSet |
	exceptionsToCapture := Exception allSubclasses select: [ :c | 
		                       c captureIfSignalledWhenStepping ].
	exceptionsSet := ExceptionSet new.
	exceptionsToCapture do: [ :e | exceptionsSet add: e ].
	^ exceptionsSet! !

!Context methodsFor: 'controlling' stamp: ''!
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 an 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).
	If self is not a top context is the responsibility of the caller to push something in the context. If this is not guarantee an error when accessing the values in the context is produced. Pay special attention to the implementation of Context class >> #contextOn: exceptionClass do: block and Context class >> #contextEnsure:. 
	
	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 stepUntilSomethingOnStack].
	stackp = 0 ifTrue: [self push: nil].  "must be quick return self/constant"
	top := self pop.
	thisContext privSender: self.
	^ top! !

!Context methodsFor: 'instruction decoding' stamp: ''!
pushReceiver
	"Simulate the action of bytecode that pushes the active context's receiver 
	on the top of the stack."

	self push: self receiver! !

!Context methodsFor: 'controlling' stamp: ''!
send: selector to: rcvr with: arguments lookupIn: lookupClass
	"Simulate the action of sending a message with selector and arguments
	 to rcvr. The argument, lookupClass, is the class in which to lookup the
	 message.  This is the receiver's class for normal messages, but for super
	 messages it will be some specific class related to the source method."

	| meth primIndex val ctxt |
	(meth := lookupClass lookupSelector: selector) ifNil:
		[^self send: #doesNotUnderstand:
				to: rcvr
				with: {Message selector: selector arguments: arguments}
				lookupIn: lookupClass].
	(primIndex := meth primitive) > 0 ifTrue:
		[val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments.
		 (self isPrimFailToken: val) ifFalse:
			[^val]].
	(selector == #doesNotUnderstand: and: [lookupClass == ProtoObject]) ifTrue:
		[^self error: 'Simulated message ', arguments first selector, ' not understood'].
	ctxt := Context sender: self receiver: rcvr method: meth arguments: arguments.
	primIndex > 0 ifTrue:
		[ctxt failPrimitiveWith: val].
	^ctxt! !

!Context methodsFor: 'debugger access' stamp: ''!
depthBelow: aContext
	"Answer how many calls there are between this and aContext."

	| context depth |
	context := self.
	depth := 0.
	[ context == aContext or: [ context == nil ]]
		whileFalse: [
			context := context sender.
			depth := depth + 1 ].
	^ depth! !

!Context methodsFor: 'initialization' stamp: ''!
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! !

!Context methodsFor: 'mirror primitives' stamp: ''!
object: anObject basicAt: index 
	"Answer the value of an indexable element in the argument anObject without sending
	 it a message. Fail if the argument index is not an Integer or is out of bounds, or if
	 anObject is not indexable. This mimics the action of the VM when it indexes an object.
	 Used to simulate the execution machinery by, for example, the debugger.
	 Primitive.  See Object documentation whatIsAPrimitive."

	<primitive: 60>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber
		ifTrue: [^self object: anObject basicAt: index asInteger]
		ifFalse: [self errorNonIntegerIndex]! !

!Context methodsFor: '*OpalCompiler-Core' stamp: ''!
isPushTemp: aPC
	^ self compiledCode encoderClass isPushTempAt: aPC in: method! !

!Context methodsFor: 'accessing' stamp: ''!
methodNode
	^ self compiledCode methodNode.! !

!Context methodsFor: 'debugger access' stamp: ''!
swapSender: coroutine 
	"Replace the receiver's sender with coroutine and answer the receiver's 
	previous sender. For use in coroutining."

	| oldSender |
	oldSender := sender.
	sender := coroutine.
	^oldSender! !

!Context methodsFor: 'instruction decoding' stamp: ''!
popIntoReceiverVariable: offset 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into an instance variable of my receiver."

	self object: self receiver instVarAt: offset + 1 put: self pop! !

!Context methodsFor: 'testing' stamp: ''!
isContext
	^true! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
stepIntoQuickMethod
	^self compiledCode stepIntoQuickMethods! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
stepIntoQuickMethod: aBoolean

	self compiledCode stepIntoQuickMethods: aBoolean! !

!Context methodsFor: 'accessing' stamp: ''!
basicAt: index
	"Primitive. Assumes receiver is indexable. Answer the value of an
	 indexable element in the receiver. Fail if the argument index is not an
	 Integer or is out of bounds. Essential. See Object documentation
	 whatIsAPrimitive.  Override the default primitive to give latitude to
	 the VM in context management."

	<primitive: 210>
	index isInteger ifTrue:
		[self errorSubscriptBounds: index].
	self errorNonIntegerIndex! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
callChainAnySatisfy: aBlock

	(aBlock value: self) ifTrue: [ ^ true ].
	self sender ifNil: [ ^ false ].
	^ self sender callChainAnySatisfy: aBlock.! !

!Context methodsFor: 'private' stamp: ''!
doPrimitive: primitiveIndex method: meth receiver: aReceiver args: arguments 
	"Simulate a primitive method whose index is primitiveIndex.  The simulated receiver and
	 arguments are given as arguments to this message. If successful, push result and return
	 resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes
	 execution needs to be intercepted and simulated to avoid execution running away."

	| value |
	"Judicious use of primitive 19 (a null primitive that doesn't do anything) prevents
	 the debugger from entering various run-away activities such as spawning a new
	 process, etc.  Injudicious use results in the debugger not being able to debug
	 interesting code, such as the debugger itself.  hence use primitive 19 with care :-)"
	"SystemNavigation new browseAllSelect: [:m| m primitive = 19]"
	"primitiveIndex = 19 ifTrue:	[ | debugSession | 
			debugSession := Processor activeProcess newDebugSessionNamed: 'Code simulation error' startedAt: self.
			Smalltalk tools debugger openOn: debugSession withFullView: true]."

	((primitiveIndex between: 201 and: 222)
	 and: [(self objectClass: aReceiver) includesBehavior: BlockClosure]) ifTrue:
		[((primitiveIndex between: 201 and: 205)			 "BlockClosure>>value[:value:...]"
		  or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]"
			[^aReceiver simulateValueWithArguments: arguments caller: self].
		 primitiveIndex = 206 ifTrue:						"BlockClosure>>valueWithArguments:"
			[^aReceiver simulateValueWithArguments: arguments first caller: self]].
	
	((primitiveIndex between: 207 and: 209) "FullBlockClosure primitives"
	  and: [(self objectClass: aReceiver) includesBehavior: FullBlockClosure]) ifTrue: 
		[^primitiveIndex = 208 
			ifTrue: [aReceiver simulateValueWithArguments: arguments first caller: self]
			ifFalse: [aReceiver simulateValueWithArguments: arguments caller: self]].

	primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]"
		[^self send: arguments first to: aReceiver with: arguments allButFirst super: false].
	primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:"
		[^self send: arguments first to: aReceiver with: (arguments at: 2) lookupIn: (self objectClass: aReceiver)].
	primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:"
		[arguments size = 3 
			ifTrue: [ ^self send: arguments first to: aReceiver with: (arguments at: 2) lookupIn: (arguments at: 3)]
			ifFalse: [ ^self send: (arguments at: 2) to: (arguments at: 1) with: (arguments at: 3) lookupIn: (arguments at: 4) ]
		].

	primitiveIndex = 88 ifTrue: ["Process>>suspend"
		"Simulation of suspend primitive should do nothing (with receiver return) by two reasons:
			- if by mistake the receiver is a simulating process itself 
				the suspend would stop it and the simulation would hang.
				For example the debugger can hang during stepping over #suspend of real active process.
			- suspend over already suspended process does nothing anyway. 
				For example debugger always steps over suspended process"
		^self push: aReceiver ].

	"Mutex>>primitiveEnterCriticalSection
	 Mutex>>primitiveTestAndSetOwnershipOfCriticalSection"
	(primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue:
		[| active effective |
		 active := Processor activeProcess.
		 effective := active effectiveProcess.
		 "active == effective"
		 value := primitiveIndex = 186
					ifTrue: [aReceiver primitiveEnterCriticalSectionOnBehalfOf: effective]
					ifFalse: [aReceiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective].
		 ^(self isPrimFailToken: value)
			ifTrue: [value]
			ifFalse: [self push: value]].

	primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:"
		[arguments size = 2 
			ifTrue: "normal primitive"
				[^Context
					sender: self
					receiver: aReceiver
					method: (arguments at: 2)
					arguments: (arguments at: 1)]
			ifFalse: "mirror primitive"
				[^Context
					sender: self
					receiver: (arguments at: 1)
					method: (arguments at: 3)
					arguments: (arguments at: 2)]
		].
	"Closure primitives"
	(primitiveIndex = 200 and: [self == aReceiver]) ifTrue:
		[^self error: 'embedded block not supported'].

	primitiveIndex = 118 ifTrue: "tryPrimitive:withArgs:; avoid recursing in the VM"
		[(arguments size = 2
		 and: [arguments first isInteger
		 and: [(self objectClass: arguments last) == Array]]) ifFalse:
			[^Context primitiveFailTokenFor: nil].
		 ^self doPrimitive: arguments first method: meth receiver: aReceiver args: arguments last].

	value := primitiveIndex = 120 "FFI method"
				ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments]
				ifFalse:
					[primitiveIndex = 117 "named primitives"
						ifTrue: [self tryNamedPrimitiveIn: meth for: aReceiver withArgs: arguments]
						ifFalse: [aReceiver tryPrimitive: primitiveIndex withArgs: arguments]].

	^(self isPrimFailToken: value)
		ifTrue: [value]
		ifFalse: [self push: value]! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
lookupVar: aSymbol declare: aBoolean
	^ self astScope lookupVar: aSymbol declare: aBoolean! !

!Context methodsFor: 'debugger access' stamp: ''!
sourceCode
	^self compiledCode sourceCode.! !

!Context methodsFor: 'private' stamp: ''!
privSender: aContext 

	sender := aContext! !

!Context methodsFor: 'private - exceptions' stamp: ''!
swapReceiver: newReceiver

	receiver := newReceiver! !

!Context methodsFor: 'private' stamp: ''!
tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments
	<primitive: 218 error: errorCode>
	errorCode ifNotNil: [
		"If errorCode is an integer other than -1 there was a problem with primitive 218,
		 not with the external primitive itself.  -1 indicates a generic failure (where
		 errorCode should be nil) but errorCode = nil means primitive 218 is not implemented.  So
		 interpret -1 to mean the external primitive failed with a nil error code."
		errorCode isInteger 
			ifTrue: [
				errorCode = -1
					ifTrue: [ errorCode := nil ]
					ifFalse: [ self primitiveFailed ]].
				^  self class primitiveFailTokenFor: errorCode ].
	"Assume a nil error code implies the primitive is not implemented and fall back on the old code."
	
	"The primitive doesn't exist or there was an error. Hence, we follow another solution without the primitive"
	^ self 
		withoutPrimitiveTryNamedPrimitiveIn: aCompiledMethod
		for: aReceiver
		withArgs: arguments! !

!Context methodsFor: 'printing' stamp: ''!
printOn: aStream
	(closureOrNil isNotNil and: [closureOrNil isClean]) ifTrue: 
		[ | selector |
			selector := self selector ifNil: [ self compiledCode defaultSelector ].
			aStream 
			 print: closureOrNil;
			 nextPutAll: ' in ';
			 nextPutAll: self methodClass name;
			 nextPutAll: '>>';
			 nextPutAll: selector.
			 ^self].
	
	self outerContext
		ifNil:
			[ | selector class mclass |
			self compiledCode
				ifNil: [ ^ super printOn: aStream ].
			class := self receiver class.
			mclass := self methodClass.
			selector := self selector ifNil: [ self compiledCode 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 ] ]
		ifNotNil:
			[ :outerContext | 
			[closureOrNil printOn: aStream] on:Exception do: [aStream nextPutAll: 'Error printing the compiledBlock'].
			aStream nextPutAll: ' in '.
			outerContext printOn: aStream ]! !

!Context methodsFor: 'private' stamp: ''!
stackPtr  
	"For use only by the SystemTracer and the Debugger, Inspectors etc"
	^ stackp! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
tempsAndValues
	"Return a string of the temporary variabls and their current values"
	
	^ String streamContents: [ :aStream |
		self tempNames 
			do: [ :name  |
			 aStream nextPutAll: name; nextPut: $:; space; tab.
			 self print: (self tempNamed: name) on: aStream]
			separatedBy: [aStream cr ]]! !

!Context methodsFor: 'accessing' stamp: ''!
outerMostContext
	^ self outerContext 
		ifNil: [ self ]
		ifNotNil: [ self outerContext ]! !

!Context methodsFor: 'instruction decoding' stamp: ''!
doPop
	"Simulate the action of a 'remove top of stack' bytecode."

	self pop! !

!Context methodsFor: 'controlling' stamp: ''!
send: selector to: aReceiver with: arguments super: superFlag

	"Simulate the action of sending a message with selector, selector, and 
	arguments, args, to receiver. The argument, superFlag, tells whether the 
	receiver of the message was specified with 'super' in the source method."

	| class aMethod value context |
	class := superFlag
		         ifTrue: [ 
			         (self compiledCode literalAt:
				          self compiledCode numLiterals) value superclass ]
		         ifFalse: [ self objectClass: aReceiver ].
	aMethod := class lookupSelector: selector.
	aMethod == nil ifTrue: [ 
		^ self
			  send: #doesNotUnderstand:
			  to: aReceiver
			  with:
			  (Array with: (Message selector: selector arguments: arguments))
			  super: superFlag ].
	aMethod isCompiledMethod ifFalse: [ 
		^ self
			  send: #run:with:in:
			  to: aMethod
			  with: (Array with: selector with: arguments with: aReceiver)
			  super: superFlag ].

	(aMethod isRealPrimitive or:[self stepIntoQuickMethod not]) ifTrue: [ 
		value := self
			         tryPrimitiveFor: aMethod
			         receiver: aReceiver
			         args: arguments.
		"primitive runs without failure?"
		(self isFailToken: value) ifFalse: [ ^ value ] ].

	(selector == #doesNotUnderstand: and: [ 
		 (class canUnderstand: #doesNotUnderstand:) not ]) ifTrue: [ 
		^ self error:
			  'Simulated message ' , (arguments at: 1) selector
			  , ' not understood' ].

	(selector == #terminateRealActive and: [ aReceiver == Processor ]) ifTrue: [ 
		"We should never simulate #terminateRealActive as it will terminate a simulating process 
		(UI process of debugger) instead of the actual process under simulation.
		Therefore the simulation always delegates this method to the public one 
		which explicitly supports the simulation with effective process logic.
		Notice that #terminateRealActive is a process completion method 
		and normally users do not step over it"
		^self send: #terminateActive to: aReceiver with: arguments super: superFlag
	].

	"failure.. lets activate the method"
	context := self
		           activateMethod: aMethod
		           withArgs: arguments
		           receiver: aReceiver
		           class: class.
		
	"The quick method contains 3 bytecodes:
	- primitive 264 or 256: a 3 bytecode primitive (initialPC)
	- a push of a value (endPC - 1)
	- the return top instruction (endPC)
	When activating the quick method, we arrive on the PC corresponding to the primitive which is not suposed to be stepped.
	We have to fix the PC so that the next executed bytecode is the push.
	We do that by setting the PC to aMethod initialPC + 3 (the number of bytes of the primitive)."
	(aMethod isQuick and:[self stepIntoQuickMethod]) ifTrue: [ context pc: aMethod initialPC + self quickMethodPrimitiveBytecodeSize].
	
	"check if activated method handles the error code (a first bytecode will be store into temp)"
	"long store temp"
	(context compiledCode at: context pc) = 129 ifTrue: [ 
		context at: context stackPtr put: value last ].
	^ context! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
writeVariableNamed: aName value: anObject 
	^ (self lookupVar: aName) write: anObject inContext: self! !

!Context methodsFor: 'instruction decoding' stamp: ''!
blockReturnConstant: value 
	"Simulate the interpreter's action when a ReturnConstantToCaller
	bytecode is 
	encountered in the receiver. This should only happen in a closure
	activation. "
	self assert: closureOrNil isClosure.
	^ self return: value from: self! !

!Context methodsFor: 'controlling' stamp: ''!
return: value from: aSender
	"For simulation.  Roll back self to aSender and return value from it.  Execute any unwind blocks on the way.  ASSUMES aSender is a sender of self"
	| newTop context |
	aSender isDead ifTrue: [
		^ self send: #cannotReturn: to: self with: {value} super: false ].
	newTop := aSender sender.
	context := self findNextUnwindContextUpTo: newTop.
	(context notNil and: [ context unwindBlock = closureOrNil ]) ifTrue: [
		"Here the return happens inside the unwind block like in following example: 
				[ #test ] ensure: [ ^ #returnFromUnwindBlock ]
		In such cases #findNextUnwindContextUpTo: returns the corresponding #ensure context
		because it is always a sender of unwind block.
		Here we detect this case and lookup the next unwind context after the current ensure section (current unwind)"
		context := context findNextUnwindContextUpTo: newTop ].
	context ifNotNil: [
			"note: nil is sent to #resume:through via #aboutToReturn:through: to invoke fresh search for next unwind context there"
		^ self send: #aboutToReturn:through: to: self with: {value. nil} super: false ].
	self releaseTo: newTop.
	newTop ifNotNil: [ newTop push: value ].
	^ newTop! !

!Context methodsFor: 'private - exceptions' stamp: ''!
evaluateSignal: exception
	"The following primitive is just a marker used to find the evaluation context. 
	See MethodContext>>#isHandlerOrSignalingContext. "

	<primitive: 199>
	<debuggerCompleteToSender>
	| value |
	exception privHandlerContext: self contextTag.
	value := self exceptionHandlerBlock cull: exception.	
	"return from self if not otherwise directed in handle block"
	self return: value! !

!Context methodsFor: 'controlling' stamp: ''!
terminate
	"Make myself unresumable."

	sender := nil.
	pc := nil.! !

!Context methodsFor: 'instruction decoding' stamp: ''!
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! !

!Context methodsFor: 'accessing' stamp: ''!
client
	"Answer the client, that is, the object that sent the message that created this context."

	^sender receiver! !

!Context methodsFor: 'instruction decoding' stamp: ''!
directedSuperSend: selector numArgs: numArgs 
	
	| lookupClass arguments currentReceiver |

	lookupClass := self pop superclass.
	
	arguments := Array new: numArgs.
	numArgs to: 1 by: -1 do: [ :i | 
		arguments at: i put: self pop ].

	currentReceiver := self pop.
	
	^ self send: selector to: currentReceiver with: arguments lookupIn: lookupClass! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
tempsAndValuesLimitedTo: sizeLimit indent: indent
	"Return a string of the temporary variabls and their current values"

	^ String streamContents: [ :aStream |
		self tempNames 
			do: [ :name |
				indent timesRepeat: [ aStream tab ].
				aStream nextPutAll: name; nextPut: $:; space; tab.
				aStream nextPutAll: 
					((self tempNamed: name) printStringLimitedTo: (sizeLimit -3 -name size max: 1))]
			separatedBy: [aStream cr ]]! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
tempNamed: aName put: anObject
	"Assign the value of the temp with name in aContext"
	
	^(self lookupTempVar: aName) write: anObject inContext: self! !

!Context methodsFor: 'controlling' stamp: ''!
resume: value
	"Unwind thisContext to self and resume with value as result of last send.  Execute unwind blocks when unwinding.  ASSUMES self is a sender of thisContext"
	
	self resume: value through: (thisContext findNextUnwindContextUpTo: self)! !

!Context methodsFor: '*OpalCompiler-Core' stamp: ''!
sourceNode
	"Return the source node that created the method or the block of this context"

	^ closureOrNil
		ifNil: [ self compiledCode sourceNode ]
		ifNotNil: [ closureOrNil sourceNode ]! !

!Context methodsFor: 'instruction decoding' stamp: ''!
storeIntoLiteralVariable: value 
	"Simulate the action of bytecode that stores the top of the stack into a 
	literal variable of my method."

	value value: self top! !

!Context methodsFor: '*OpalCompiler-Core' stamp: ''!
isReturnAt: aPC
	^method encoderClass isReturnAt: aPC in: method.! !

!Context methodsFor: 'private - exceptions' stamp: ''!
receiver: anObject

	receiver := anObject! !

!Context methodsFor: 'debugger access' stamp: ''!
shortStack
	"Answer a String showing the top ten contexts on my sender chain."

	^ String streamContents: [ :stream |
		(self stackOfSize: 10) do: [ :item |
			stream print: item; cr]]! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
restartWithNewReceiver: obj

	self
		swapReceiver: obj;
		restart! !

!Context methodsFor: 'debugger access' stamp: ''!
contextStack 
	"Answer an Array of the contexts on the receiver's sender chain."

	^self stackOfSize: 100000! !

!Context methodsFor: 'instruction decoding' stamp: ''!
pushReceiverVariable: offset 
	"Simulate the action of bytecode that pushes the contents of the receiver's 
	instance variable whose index is the argument, index, on the top of the 
	stack."

	self push: (self object: self receiver instVarAt: offset + 1)! !

!Context methodsFor: 'controlling' stamp: ''!
activateMethod: newMethod withArgs: args receiver: rcvr class: class 
	"Answer a Context initialized with the arguments."

	^Context 
		sender: self
		receiver: rcvr
		method: newMethod
		arguments: args! !

!Context methodsFor: 'instruction decoding' stamp: ''!
pushConsArrayWithElements: numElements 
	| array |
	array := Array new: numElements.
	numElements to: 1 by: -1 do: [ :i |
		array at: i put: self pop ].
	self push: array! !

!Context methodsFor: 'accessing' stamp: ''!
receiver 

	^receiver! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
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 := Context
			sender: nil
			receiver: self home receiver
			method: self home compiledCode
			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! !

!Context methodsFor: 'debugger access' stamp: ''!
stack 
	"Answer an Array of the contexts on the receiver's sender chain."

	^self stackOfSize: 9999! !

!Context methodsFor: 'private' stamp: ''!
endPC
	^closureOrNil
		ifNil:	[self compiledCode endPC]
		ifNotNil: [closureOrNil endPC]! !

!Context methodsFor: 'controlling' stamp: ''!
resume
	"Roll back thisContext to self and resume.  Execute unwind blocks when rolling back.  ASSUMES self is a sender of thisContext"

	self resume: nil! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
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."

	| currentReceiver arguments  |
	arguments := Array new: numArgs.
	numArgs to: 1 by: -1 do: [ :i | 
		arguments at: i put: self pop ].
	currentReceiver := 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]. "
	^ self send: selector to: currentReceiver with: arguments super: superFlag! !

!Context methodsFor: 'private-exceptions' stamp: ''!
cannotReturn: result

	closureOrNil ifNotNil: [ 
		^ BlockCannotReturn result: result from: self home ].
	UIManager default
		requestDebuggerOpeningNamed: 'computation has been terminated'
		inContext: thisContext! !

!Context methodsFor: 'instruction decoding' stamp: ''!
jump: distance withInterpreter: anInterpreter
	"Simulate the action of a 'unconditional jump' bytecode whose offset is 
	the argument, distance."

	pc := pc + distance.
	anInterpreter pc: pc.! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
returnBooleanPrimitive

	^ 257! !

!Context methodsFor: 'controlling' stamp: ''!
resumeEvaluating: aBlock
	"Unwind thisContext to self and resume with aBlock value as result of last send.  
	Execute unwind blocks when unwinding.  
	ASSUMES self is a sender of thisContext"
	| context unwindBlock |
	self isDead ifTrue: [self cannotReturn: aBlock value to: self].
	context := thisContext.
	[
		context := context findNextUnwindContextUpTo: self.
		context isNil
	] whileFalse: [	
		context unwindComplete ifNil:[
			context unwindComplete: true.
			unwindBlock := context unwindBlock.
			thisContext terminateTo: context.
			unwindBlock value]
	].
	thisContext terminateTo: self.
	^aBlock value! !

!Context methodsFor: '*OpalCompiler-Core' stamp: ''!
astScope
	"Return the scope of the method or the block of this context. 
	Note: we can not just use #sourceNode as this ignores optimized blocks.
	We instead use sourceNodeExecuted and then get the the block or methodnode on the AST level.
	For the topmost context, sourceNodeExecuted is off by one but that is not a problem as 
	we still end up getting the scope  we want"

	^ self sourceNodeExecuted methodOrBlockNode scope! !

!Context methodsFor: 'instruction decoding' stamp: ''!
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! !

!Context methodsFor: 'query' stamp: ''!
copyTo: aContext
	"Copy self and my sender chain down to, but not including, aContext.  End of copied chain will have nil sender."

	| copy |
	self == aContext ifTrue: [^ nil].
	copy := self copy.
	self sender ifNotNil: [
		copy privSender: (self sender copyTo: aContext)].
	^ copy! !

!Context methodsFor: 'controlling' stamp: ''!
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! !

!Context methodsFor: 'mirror primitives' stamp: ''!
object: anObject eqeq: anOtherObject 
	"Answer whether the first and second arguments are the same object (have the
	 same object pointer) without sending a message to the first argument.  This
	 mimics the action of the VM when it compares two object pointers.  Used to
	 simulate the execution machinery by, for example, the debugger.
	 Primitive.  See Object documentation whatIsAPrimitive."

	<primitive: 110>
	self primitiveFailed! !

!Context methodsFor: 'instruction decoding' stamp: ''!
methodReturnReceiver
	"Simulate the action of a 'return receiver' bytecode. This corresponds to
	 the source expression '^self'."

	^self return: self receiver from: self methodReturnContext! !

!Context methodsFor: 'instruction decoding' stamp: ''!
pushActiveContext
	"Simulate the action of bytecode that pushes the the active context on the 
	top of its own stack."

	self push: self! !

!Context methodsFor: 'debugger access' stamp: ''!
releaseTo: caller 
	"Remove information from the receiver and the contexts on its sender 
	chain up to caller in order to break circularities."

	| contex senderContext |
	contex := self.
	[ contex == nil or: [ contex == caller ]]
		whileFalse: [
			senderContext := contex sender.
			contex singleRelease.
			contex := senderContext ]! !

!Context methodsFor: '*Fuel-Tests-Core' stamp: ''!
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
		ifNil: [ aTestCase assert: aMethodContext closure isNil ]
		ifNotNil: [ closureOrNil assertWellMaterializedInto: aMethodContext closure in: aTestCase ].
	aTestCase assert: receiver = aMethodContext receiver.
	aTestCase assert: (method isEqualRegardlessTrailerTo: aMethodContext compiledCode).
	sender
		ifNil: [ aTestCase assert: aMethodContext sender isNil ]
		ifNotNil: [ sender assertWellMaterializedInto: aMethodContext sender in: aTestCase ]! !

!Context methodsFor: 'instruction decoding' stamp: ''!
jump: distance if: condition withInterpreter: anInterpreter
	"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: #mustBeBoolean
			to: bool
			with: {}
			super: false].
	(bool eqv: condition) ifTrue: [self jump: distance withInterpreter: anInterpreter]! !

!Context methodsFor: 'private' stamp: ''!
quickMethodPrimitiveBytecodeSize

	"A quick method starts with a 3 bytecodes primitive (264 or 256)"

	^ 3! !

!Context methodsFor: 'printing' stamp: ''!
debugStackOn: aStream
	"print the top ten contexts on my sender chain."
	^ self debugStack: 100 on: aStream! !

!Context methodsFor: 'instruction decoding' stamp: ''!
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! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
stepToHome: aContext
	"Resume self until the home of top context is aContext.  Top context may be a block context."

	| home ctxt here error wrapperContext |
	here := thisContext.
	error := nil.
	
	wrapperContext := aContext insertSender: (Context contextOn: Exception do: [ :ex | 
				            error
					            ifNil: [ 
						            			error := ex.
												ex resumeUnchecked: here jump ]
					            ifNotNil: [ 
										ex pass ] ]).
	home := aContext home.

	"A first Step to do at least one step"
	ctxt := self step.

	home == ctxt home ifTrue: [ 
		"remove above inserted ensure and handler contexts"
		aContext terminateTo: wrapperContext sender.
		^ { 
			  ctxt.
			  error } ].

	[  ctxt := ctxt step.
		error ifNotNil: [ 
		"remove above inserted ensure and handler contexts"
		aContext terminateTo: wrapperContext sender.
			^ { 
				  ctxt.
				  error } ].

		home == ctxt home ] whileFalse: [ 
			(home isDead or: [ ctxt isDead ]) ifTrue: [ 
				^ { 
					  ctxt.
					  nil } ] ].
	"remove above inserted ensure and handler contexts"
	aContext terminateTo: wrapperContext sender.
	
	^ { 
		  ctxt.
		  nil }! !

!Context methodsFor: 'testing' stamp: ''!
isBlockContext
	"Is this executing a block versus a method?  In the new closure
	 implemetation this is true if closureOrNil is not nil, in which case
	 it should be holding a BlockClosure."

	^closureOrNil isClosure! !

!Context methodsFor: 'testing' stamp: ''!
isBottomContext
	"Answer if this is the last context (the first context invoked) in my sender chain"

	^sender isNil! !

!Context methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 211>
	^self at: index put: value! !

!Context methodsFor: '*EmergencyDebugger' stamp: ''!
printWithArgsValueOn: aStream
	| keywords |
	aStream << self method methodClass name.
	aStream << '>>'.
	self method numArgs = 0
		ifTrue: [ 
			"If self method is a compiled block, we ask its method.
			The method of a method is the method itself."
			aStream << self method method name.
			^ self ].
	keywords := self method selector keywords.
	1 to: keywords size do: [ :i | 
		| keyword argName argValue |
		keyword := keywords at: i.
		self flag: 'Sometimes the arguments cannot be accessed. Why?'.
		argName := [ self method argumentNames at: i ]
			on: Error
			do: [ $? ].
		
		argValue := [ self arguments at: i ]
			on: Error
			do: [ $? ].
		aStream << keyword.
		aStream space.
		aStream << argName.
		aStream space.
		aStream << '('.
		aStream << argValue printString.
		aStream << ')' ]! !

!Context methodsFor: 'query' stamp: ''!
copyStack

	^ self copyTo: nil! !

!Context methodsFor: 'testing' stamp: ''!
hasSender: context 
	"Answer whether the receiver is strictly above context on the stack."

	| senderContext |
	self == context 
		ifTrue: [^false].
	senderContext := sender.
	[senderContext == nil]
		whileFalse: [
			senderContext == context
				ifTrue: [^true].
			senderContext := senderContext sender].
	^false! !

!Context methodsFor: 'mirror primitives' stamp: ''!
objectClass: aReceiver
	<primitive: 111>
	self primitiveFailed! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
pcRangeContextIsActive: contextIsActive
 	"return the debug highlight for aPC"		 
	| thePC |

  	"make sure we have some usable value (can happen for contexts in the ProcessBrowser"		
 	thePC := self isDead ifTrue: [self endPC] ifFalse: [pc].

  	"When on the top of the stack the pc is pointing to right instruction, but deeper in the stack		
 	the pc was already advanced one bytecode, so we need to go back this one bytecode, which		
 	can consist of multiple bytes. But on IR, we record the *last* bytecode offset as the offset of		
 	the IR instruction, which means we can just go back one"		
 	thePC := contextIsActive ifTrue: [thePC] ifFalse: [thePC - 1].		

  	^self method rangeForPC: thePC! !

!Context methodsFor: 'debugger access' stamp: ''!
singleRelease
	"Remove information from the receiver in order to break circularities."

	stackp ifNotNil: [
		1 to: stackp do: [ :i |
			self at: i put: nil ]].
	sender := nil.
	pc := nil.! !

!Context methodsFor: 'mirror primitives' stamp: ''!
object: anObject instVarAt: anIndex
	"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 for the
	 debugger. See  Object documentation whatIsAPrimitive."

	<primitive: 73>
	"Access beyond fixed variables."
	^self object: anObject basicAt: anIndex - (self objectClass: anObject) instSize! !

!Context methodsFor: 'testing' stamp: ''!
hasMethodReturn
	^closureOrNil hasMethodReturn! !

!Context methodsFor: 'controlling' stamp: ''!
step
	"Simulate the execution of the receiver's next bytecode. Answer the 
	context that would be the active context after this bytecode."
	| stream result |
	stream := InstructionStream on: method pc: pc.
	result := stream interpretNextInstructionFor: self.
	^ result! !

!Context methodsFor: 'private - exceptions' stamp: ''!
unwindTo: aContext

	| context unwindBlock |
	context := self.
	[ (context := context findNextUnwindContextUpTo: aContext) isNil ] whileFalse: [
		(context unwindComplete) ifNil: [
			context unwindComplete: true.
			unwindBlock := context unwindBlock.
			unwindBlock value ]].! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
simulatePrimitive: primitiveIndex in: aMethod receiver: aReceiver arguments: arguments
	| key simulator |
	
	key := primitiveIndex = 117 
		ifTrue: [ | literal |
			literal := aMethod literalAt: 1.
			"primitive name, module name"
			{literal second. literal first}] 
		ifFalse: [ primitiveIndex ].
	
	simulator := self class specialPrimitiveSimulators at: key ifAbsent: [
		 "named primitives"
		^  primitiveIndex = 117
				ifTrue: [
					self withoutPrimitiveTryNamedPrimitiveIn: aMethod for: aReceiver withArgs: arguments.
					"this uses primitive 218, which doesn't works as expected... 
					self tryNamedPrimitiveIn: method for: receiver withArgs: arguments " ]
				ifFalse: [ aReceiver tryPrimitive: primitiveIndex withArgs: arguments ]]. 
	
	^ simulator 
		simulatePrimitiveFor: aMethod
		receiver: aReceiver
		arguments: arguments
		context: self! !

!Context methodsFor: '*OpalCompiler-Core' stamp: ''!
sourceNodeExecuted
	"When down in the stack, I return the node that executed"
	^ method sourceNodeForPC: self executedPC! !

!Context methodsFor: 'private' stamp: ''!
setSender: newSender receiver: newReceiver method: newMethod closure: newClosure startpc: startpc
	"Create the receiver's initial state."

	sender := newSender.
	receiver := newReceiver.
	method := newMethod.
	closureOrNil := newClosure.
	pc := startpc.
	stackp := 0! !

!Context methodsFor: '*Fuel-Tests-Core' stamp: ''!
initializeWith: aPc stackPtr: aStackPtr method: aMethod receiver: aReceiver sender: aSender
	pc := aPc.
	stackp := aStackPtr.
	method := aMethod.
	receiver := aReceiver.
	sender := aSender.
	! !

!Context methodsFor: 'private - exceptions' stamp: ''!
unwindForTermination
	"Unwind to execute pending ensure:/ifCurtailed: blocks before terminating active process.
	It assumes that self belongs to the active process. "
	| unwindContext unwindBlock |
	unwindContext := self.
	[ unwindContext := unwindContext findNextUnwindContextUpTo: nil.
	unwindContext isNil ] whileFalse: [ 
		unwindContext unwindComplete ifNil: [ 
			"N.B. Unlike Context>>unwindTo: we do not set complete (tempAt: 2) to true."
			unwindBlock := unwindContext unwindBlock.
			self terminateTo: unwindContext.
			unwindBlock value ]].
	self terminateTo: nil! !

!Context methodsFor: 'special context access' stamp: ''!
exceptionHandlerBlock
	"handlercontext only. access temporaries from BlockClosure>>#on:do:"
	^self tempAt: 2! !

!Context methodsFor: 'private - exceptions' stamp: ''!
isHandlerOrSignalingContext
	"Both BlockClosure>>on:do: (handler) and Context>>evaluateSignal: (signaling) 
	are marked with primitive 199."
	^method primitive = 199! !

!Context methodsFor: 'printing' stamp: ''!
shortDebugStackOn: aStream
	"print the top 30 contexts on my sender chain."

	^ self debugStack: 30 on: aStream! !

!Context methodsFor: 'instruction decoding' stamp: ''!
doDup
	"Simulate the action of a 'duplicate top of stack' bytecode."

	self push: self top! !

!Context methodsFor: '*OpalCompiler-Core' stamp: ''!
isPushLiteralNil: aPC
	^ (self compiledCode at: aPC) = method encoderClass pushNilByte! !

!Context methodsFor: 'controlling' stamp: ''!
stepUntilSomethingOnStack
	"Simulate the execution of bytecodes until either sending a message or 
	returning a value to the receiver (that is, until switching contexts)."

	| context |
	[ stackp = 0 ]
		whileTrue: [
			self isDead ifTrue: [ ^ self ].
			context := self step.
			context == self ifFalse: [
				"Caused by mustBeBoolean handling"
				^context ]]! !

!Context methodsFor: 'private - exceptions' stamp: ''!
isUnwindContext
	"is this context for  method that is marked?"
	^method primitive = 198! !

!Context methodsFor: 'accessing' stamp: ''!
pc 
	^ pc! !

!Context methodsFor: 'private - exceptions' stamp: ''!
findNextHandlerContext
	"Return the next handler marked context, returning nil if there is none.  
	Search starts with self and proceeds up to nil."
	| context searchStartContext |
	context := self findNextHandlerOrSignalingContext.
	context ifNil: [ ^ nil ].
	context isHandlerContext ifTrue: [ ^ context ].	
	"If it isn't a handler context, it must be a signaling context.
	When we reach a signaling context we must skip over any handlers
	that might be on the stack between the signaling context and the handler context for that signal"
	searchStartContext := context exception privHandlerContext ifNil: [ context ].
	^searchStartContext nextHandlerContext! !

!Context methodsFor: 'instruction decoding' stamp: ''!
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)! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
readVariableNamed: aName
	^ (self lookupVar: aName) readInContext: self! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
temporaryVariableNamed: aName
	(self hasTemporaryVariableNamed: aName)
		ifFalse: [ ^ nil ].
	^self lookupTempVar: aName! !

!Context methodsFor: 'mirror primitives' stamp: ''!
object: anObject basicAt: index put: value 
	"Store the last argument 
	 value in the indexable element of the argument anObject indicated by index without sending
	 anObject a message. Fail if the argument index is not an Integer or is out of bounds, or if
	 anObject is not indexable, or if value is an inappropriate value for anObject's indexable slots.
	 This mimics the action of the VM when it indexes an object.
	 Used to simulate the execution machinery by, for example, the debugger.
	 Primitive.  See Object documentation whatIsAPrimitive."

	<primitive: 61>
	index isInteger
		ifTrue: [(index >= 1 and: [index <= (self objectSize: anObject)])
					ifFalse: [self errorSubscriptBounds: index]].
	index isNumber
		ifTrue: [^self object: anObject basicAt: index asInteger put: value]
		ifFalse: [self errorNonIntegerIndex].
	anObject isReadOnlyObject 
		ifTrue: [ ^ (ModificationForbidden new
				object: anObject;
				fieldIndex: index;
				newValue: value;
				retrySelector: #basicAt:put:) signal ].
	self errorImproperStore! !

!Context methodsFor: 'controlling' stamp: ''!
runUntilErrorOrReturnFrom: aSender 
	"ASSUMES aSender is a sender of self.  Execute self's stack until aSender returns or an unhandled exception is raised.  Return a pair containing the new top context and a possibly nil exception.  The exception is not nil if it was raised before aSender returned and it was not handled.  The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it."
	"Self is run by jumping directly to it (the active process abandons thisContext and executes self).  However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated.  We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised.  In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext."

	| error context here topContext |
	here := thisContext.

	"Insert ensure and exception handler contexts under aSender"
	error := nil.
	context := aSender insertSender: (Context
		contextOn: self exceptionsToCaptureWhenStepping do: [:ex |
			error ifNil: [
				error := ex.
				topContext := thisContext.
				ex resumeUnchecked: here jump ]
			ifNotNil: [ ex pass ]]).
	context := context insertSender: (Context
		contextEnsure: [error ifNil: [
				topContext := thisContext.
				here jump]
		]).
	self jump.  "Control jumps to self"

	"Control resumes here once above ensure block or exception handler is executed"
	^ error ifNil: [
		"No error was raised, remove ensure context by stepping until popped"
		[ context isDead or: [ topContext isNil  ]] whileFalse: [topContext := topContext stepToCallee].
		{topContext. nil}

	] ifNotNil: [
		"Error was raised, remove inserted above contexts then return signaler context"
		aSender terminateTo: context sender.  "remove above ensure and handler contexts"
		{topContext. error}
	].! !

!Context methodsFor: 'accessing' stamp: ''!
activeHome
	"If executing closure, search senders for the activation of the original
	 (outermost) method that (indirectly) created my closure (the closureHome).
	 If the closureHome is not found on the sender chain answer nil."

	| methodReturnContext |
	self isBlockContext ifFalse: [^self].
	self sender ifNil: [^nil].
	methodReturnContext := self methodReturnContext.
	^self sender findContextSuchThat: [:ctxt | ctxt = methodReturnContext]! !

!Context methodsFor: 'printing' stamp: ''!
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 ]! !

!Context methodsFor: 'accessing' stamp: ''!
removeSelf
	"Nil the receiver pointer and answer its former value."

	| tempSelf |
	tempSelf := receiver.
	receiver := nil.
	^tempSelf! !

!Context methodsFor: '*OpalCompiler-Core' stamp: ''!
isBlockReturn: aPC
	^method encoderClass isBlockReturnAt: aPC in: method.! !

!Context methodsFor: 'system simulation' stamp: ''!
failPrimitiveWith: maybePrimFailToken
	"The receiver is a freshly-created context on a primitive method.  Skip the callPrimitive:
	 bytecode and store the primitive fail code if there is one and the method consumes it."
	self skipCallPrimitive.
	((self isPrimFailToken: maybePrimFailToken)
	  and: [method encoderClass isStoreAt: pc in: method]) ifTrue:
		[self at: stackp put: maybePrimFailToken last]! !

!Context methodsFor: 'private - exceptions' stamp: ''!
findNextHandlerOrSignalingContext
	"Return the next handler/signaling marked context, answering nil if there is none. 
	Search starts with self and proceeds up to nil."

	<primitive: 197>
	| context |
	context := self.
	[ 
	context isHandlerOrSignalingContext
		ifTrue: [ ^ context ].
	(context := context sender) == nil ] whileFalse.
	^ nil! !

!Context methodsFor: 'private - exceptions' stamp: ''!
nextHandlerContext

	^ self sender findNextHandlerContext! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
instructionStream
	
	^ InstructionStream on: method pc: pc! !

!Context methodsFor: 'controlling' stamp: ''!
shortDebugStack
	"Answer a String showing the top ten contexts on my sender chain."

	^ String streamContents: [ :stream | self debugStack: 10 on: stream ]! !

!Context methodsFor: '*NewTools-Debugger' stamp: ''!
findFailedAssertionContextInSenderChain

	^ (self findContextSuchThat: [ :ctx | 
		   (ctx hasTemporaryVariableNamed: #actual) and: [ 
			   ctx hasTemporaryVariableNamed: #expected ] ]) ifNil: [ 
		  StDebuggeAssertionFailureContextNotFound new signal ]! !

!Context methodsFor: 'accessing' stamp: ''!
outerContext
	"Answer the context within which the receiver is nested."
	
	^closureOrNil ifNotNil:
		[closureOrNil outerContext ifNil: ["if the outer is nil, this is a CleanBlock" self sender]]! !

!Context methodsFor: 'instruction decoding' stamp: ''!
pushNewArrayOfSize: arraySize 
	self push: (Array new: arraySize)! !

!Context methodsFor: 'controlling' stamp: ''!
terminateTo: previousContext
	"Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender."

	| currentContext sendingContext |
	<primitive: 196>
	(self hasSender: previousContext) ifTrue: [
		currentContext := sender.
		[currentContext == previousContext] whileFalse: [
			sendingContext := currentContext sender.
			currentContext terminate.
			currentContext := sendingContext ]].
	sender := previousContext! !

!Context methodsFor: 'accessing' stamp: ''!
basicSize
	"Primitive. Answer the number of indexable variables in the receiver. 
	This value is the same as the largest legal subscript. Essential. Do not 
	override in any subclass. See Object documentation whatIsAPrimitive.  Override the default primitive to give latitude to
	 the VM in context management."

	<primitive: 212>
	"The number of indexable fields of fixed-length objects is 0"
	^self primitiveFail! !

!Context methodsFor: 'closure support' stamp: ''!
asContext

	^ self! !

!Context methodsFor: 'controlling' stamp: ''!
resume: value through: firstUnwindContext
	"Unwind thisContext to self and resume with value as result of last send.
	 Execute any unwind blocks while unwinding.
	 ASSUMES self is a sender of thisContext."

	| context unwindBlock |
	self isDead 
		ifTrue: [ self cannotReturn: value to: self ].
	"note: nil value of firstUnwindContext is sent by #return:from: to invoke fresh search for first unwind context"
	context := firstUnwindContext ifNil: [thisContext findNextUnwindContextUpTo: self].
	[ context isNil ] whileFalse: [	
		context unwindComplete ifNil:[
			context unwindComplete: true.
			unwindBlock := context unwindBlock.
			thisContext terminateTo: context.
			unwindBlock value].
		context := context findNextUnwindContextUpTo: self].
	thisContext terminateTo: self.
	^value! !

!Context methodsFor: 'special context access' stamp: ''!
unwindComplete: aBoolean
	"unwindContext only. access temporaries from BlockClosure>>#ensure: and BlockClosure>>#ifCurtailed:"
	self tempAt: 2 put: aBoolean! !

!Context methodsFor: 'debugger access' stamp: ''!
longStack
	"Answer a String showing the top 100 contexts on my sender chain."

	^ String streamContents: [ :stream |
		(self stackOfSize: 100) do: [ :item | 
			stream print: item; cr ]]! !

!Context methodsFor: 'accessing' stamp: ''!
arguments
	"returns the arguments of a message invocation"
	
	| arguments numargs |
	numargs :=  self compiledCode numArgs.
	arguments := Array new: numargs.
	1 to: numargs do: [ :i | arguments at: i put: (self tempAt: i) ].
	^ arguments! !

!Context methodsFor: 'debugger access' stamp: ''!
selector
	"Answer the selector of the method that created the receiver."

	^self compiledCode selector ifNil: [self compiledCode defaultSelector].! !

!Context methodsFor: 'private' stamp: ''!
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 from 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 bytecodes 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 invocation), the receiver and the arguments. So the idea is to use a template compiled method that ONLY contains the primitive declaration (it doesn't include all the smalltalk code after the primitive). #tryNamedPrimitiveTemplateMethod answers such a template method which looks like:

tryNamedPrimitive
	<primitive:'' module:''>
	^ Context primitiveFailToken'

Since this method does not change its bytecodes for every invocation, 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 sends #primitiveFailToken. If this method invocation does not fail, then the Debugger continues debugging the sender of the primitive method. In this case, the step in is the same as step over. If the primitive fails, then the debugger continues executing the smalltalk part after the primitive method. In this case, step in is a real step in."	
	| theMethod  |
	arguments size > 8 
		ifTrue: [ ^ self class primitiveFailToken ].
	theMethod := self class tryNamedPrimitiveTemplateMethod.
	theMethod prepareForSimulationWith: arguments size.
	theMethod == nil 
		ifTrue: [ ^ self class primitiveFailToken ].
	self setNamedPrimitiveInformationFrom: aCompiledMethod toMethod: theMethod.
	theMethod flushCache.
	
	^ theMethod valueWithReceiver: aReceiver arguments: arguments! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
callPrimitive: primNumber
	| res |
	res := receiver tryPrimitive: primNumber withArgs: self arguments.
	primNumber >= (1 << 15) ifTrue: [ "inlined primitive, cannot fail" ^ self push: res ].  
	"regular primitive. Always at the beginning of methods."
	(self isFailToken: res) ifTrue: [ "keeps interpreting the method" ^ self ].
	self push: res.
	self methodReturnTop! !

!Context methodsFor: 'special context access' stamp: ''!
unwindComplete
	"unwindContext only. access temporaries from BlockClosure>>#ensure: and BlockClosure>>#ifCurtailed:"
	^self tempAt: 2! !

!Context methodsFor: 'controlling' stamp: ''!
push: value 
	"Push value on the receiver's stack."

	self stackp: stackp + 1.
	self at: stackp put: value! !

!Context methodsFor: 'instruction decoding' stamp: ''!
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! !

!Context methodsFor: 'private' stamp: ''!
tryPrimitiveFor: aMethod receiver: aReceiver 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 := aMethod primitive) = 0 
		ifTrue: [ ^ self class primitiveFailToken ].
	^ self doPrimitive: primIndex method: aMethod receiver: aReceiver args: arguments! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
restart
	"Unwind thisContext to self and resume from beginning.  Execute unwind blocks when unwinding.  ASSUMES self is a sender of thisContext"

	| context unwindBlock |
	self isDead ifTrue: [self cannotReturn: nil to: self].
	self privRefresh.
	context := thisContext.
	[	context := context findNextUnwindContextUpTo: self.
		context isNil 
	] whileFalse: [
		context unwindComplete ifNil:[
			context unwindComplete: true.
			unwindBlock := context unwindBlock.
			thisContext terminateTo: context.
			unwindBlock value ]].
	
	thisContext terminateTo: self.
	self jump.! !

!Context methodsFor: 'instruction decoding' stamp: ''!
storeIntoReceiverVariable: offset 
	"Simulate the action of bytecode that stores the top of the stack into an 
	instance variable of my receiver."

	self object: self receiver instVarAt: offset + 1 put: self top! !

!Context methodsFor: 'private - exceptions' stamp: ''!
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:)."
	<debuggerCompleteToSender>
	(self exceptionClass handles: exception)
		ifFalse: [ ^ self nextHandlerContext handleSignal: exception ].
	self evaluateSignal: exception! !

!Context methodsFor: 'accessing' stamp: ''!
hasInstVarRef
	"Answer whether the receiver references an instance variable."

	^self compiledCode hasInstVarRef.! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
updatePCForQuickPrimitiveRestart

	({self returnBooleanPrimitive.	self returnSelfPrimitive } includes: self method primitive) 
		ifTrue: [ 
			pc := self method endPC.
			^ self ].

	pc := pc + self quickMethodPrimitiveBytecodeSize! !

!Context methodsFor: 'instruction decoding' stamp: ''!
pushConstant: value 
	"Simulate the action of bytecode that pushes the constant, value, on the 
	top of the stack."

	self push: value! !

!Context methodsFor: 'accessing' stamp: ''!
methodSelector
	^ self compiledCode selector! !

!Context methodsFor: 'controlling' stamp: ''!
stepToCallee
	"Step to callee or sender"

	| context |
	context := self.
	[ (context := context step) == self ] whileTrue.
	^ context! !

!Context methodsFor: 'special context access' stamp: ''!
exception
	"signaling context (Context>>evaluateSignal:) only. Access the exception argument."
	^self tempAt: 1! !

!Context methodsFor: 'special context access' stamp: ''!
unwindBlock
	"unwindContext only. access temporaries from BlockClosure>>#ensure: and BlockClosure>>#ifCurtailed:"
	^self tempAt: 1! !

!Context methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 210>
	index isInteger ifTrue:
		[self errorSubscriptBounds: index].
	index isNumber
		ifTrue: [^self at: index asInteger]
		ifFalse: [self errorNonIntegerIndex]! !

!Context methodsFor: 'special context access' stamp: ''!
exceptionClass
	"handlercontext only. access temporaries from BlockClosure>>#on:do:"
	^self tempAt: 1! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
tempNames
	"Answer all the temp names in scope in aContext starting with the home's first local 
	(the first argument or first temporary if no arguments).
	
	These are all the temps that a programmer could access in the context, but keep in mind
	that as they might not be accesses here. 
	In addition, even vars that are accessed in this context could be stored
	in a temp vector, which itself would be a copied temp that has no name..."
	
	^ self astScope allTempNames! !

!Context methodsFor: 'mirror primitives' stamp: ''!
object: anObject perform: selector withArguments: argArray inClass: lookupClass
	"Send the selector, aSymbol, to anObject with arguments in argArray.
	 Fail if the number of arguments expected by the selector 
	 does not match the size of argArray, or if lookupClass
	 cannot be found among the anObject's superclasses.
	 Primitive. Essential for the debugger."

	<primitive: 100 error: error>
	selector isSymbol
		ifFalse: [ ^ self error: 'selector argument must be a Symbol' ].
	(argArray isMemberOf: Array)
		ifFalse: [ ^ self error: 'argArray must be an Array' ].
	selector numArgs = argArray size
		ifFalse: [ ^ self error: 'incorrect number of arguments' ].
	((self objectClass: anObject) includesBehavior: lookupClass)
		ifFalse: [ ^ self error: 'lookupClass is not in anObject''s inheritance chain' ].
	self primitiveFailed! !

!Context methodsFor: 'private' stamp: ''!
setSender: newSender receiver: newReceiver method: newMethod arguments: arguments 
	"Create the receiver's initial state."

	sender := newSender.
	receiver := newReceiver.
	method := newMethod.
	closureOrNil := nil.
	pc := method initialPC.
	self stackp: method numTemps.
	1 to: arguments size do: [ :i | 
		self at: i put: (arguments at: i)]! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
respondsToUnknownBytecode
	"This method is triggerred by the VM when the interpreter tries to execute an unknown bytecode"
	
	| unknownBytecode |
	unknownBytecode := self compiledCode at: self pc.
	self error: 'VM cannot run unknown bytecode ', unknownBytecode printString! !

!Context methodsFor: '*Debugging-Core' stamp: ''!
lookupTempVar: aSymbol
	| var |
	var := self lookupVar: aSymbol.
	var isLocalVariable ifFalse: [ ^self error: var name, ' is not a temp but, ', var class name].
	^var! !

!Context methodsFor: 'private' stamp: ''!
instVarAt: index put: value
	index = 3 
		ifTrue: [
			self stackp: value. 
			^ value].
	^ super instVarAt: index put: value! !

!Context methodsFor: 'private' stamp: ''!
isPrimFailToken: anObject
	^ (self objectClass: anObject) == Array
		  and: [anObject size = 2
		  and: [anObject first == PrimitiveFailToken]]! !

!Context methodsFor: 'accessing' stamp: ''!
activeOuterContext
	"If executing closure, search senders for the activation in which the receiver's
	 closure was created (the receiver's outerContext).  If the outerContext is not
	 found on the sender chain answer nil."

	| outerContext |
	self isBlockContext ifFalse: [^self].
	self sender ifNil: [^nil].
	outerContext := self outerContext.
	^self sender findContextSuchThat: [:ctxt | ctxt = outerContext]! !

!Context methodsFor: 'accessing' stamp: ''!
method
	"self
		deprecated: 'Should use compiledCode since it can be CompiledMethod or a CompiledBlock'
		transformWith: '`@receiver method' 
						-> '`@receiver compiledCode'."

	^method! !

!Context methodsFor: 'debugger access' stamp: ''!
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! !

!Context methodsFor: 'controlling' stamp: ''!
return
	"Unwind until my sender is on top"

	self return: self receiver! !

!Context methodsFor: 'testing' stamp: ''!
isExecutingBlock
	"for compatibility"
	^self isBlockContext! !

!Context methodsFor: 'private' stamp: ''!
isFailToken: anObject
	^ (self objectClass: anObject) == Array 
			and: [ anObject size = 2 and: [(anObject at: 1) == PrimitiveFailToken]]! !

!Context methodsFor: 'controlling' stamp: ''!
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! !

!Context methodsFor: 'debugger access' stamp: ''!
release
	"Remove information from the receiver and all of the contexts on its 
	sender chain in order to break circularities."

	self releaseTo: nil! !

!Context methodsFor: 'debugger access' stamp: ''!
stackOfSize: limit 
	"Answer an OrderedCollection of the top 'limit' contexts
	 on the receiver's sender chain."

	| stack context |
	stack := OrderedCollection new.
	stack addLast: (context := self).
	[(context := context sender) ~~ nil
	 and: [stack size < limit]] whileTrue: [
		stack addLast: context ].
	^ stack! !

!Context methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 210>
	^self at: index! !

!Context methodsFor: 'debugger access' stamp: ''!
errorReportOn: stream
	"Write a detailed error report on the stack (above me) on a  
	stream.  For both the error file, and emailing a bug report.   
	Suppress any errors while getting printStrings.  Limit the length."
	
	| stackDepth aContext |
	stream print: Date today; space; print: Time now; cr.
	stream cr.
	stream nextPutAll: 'VM: ';
		nextPutAll: Smalltalk os name asString;
		nextPutAll: ' - ';	
		nextPutAll: Smalltalk os subtype asString;
		nextPutAll: ' - ';
		nextPutAll: Smalltalk os version asString;
		nextPutAll: ' - ';
		nextPutAll: Smalltalk vm version asString;
		cr.	
	stream nextPutAll: 'Image: ';
		nextPutAll:  SystemVersion current version asString;
		nextPutAll: ' [';
		nextPutAll: Smalltalk lastUpdateString asString;
		nextPutAll: ']';
		cr.
	stream cr.
	"Note: The following is an open-coded version of  Context>>stackOfSize: since this method may be called during a  low space condition and we might run out of space for allocating the  full stack."	
	stackDepth := 0.  
	aContext := self.
	[ aContext notNil and: [ (stackDepth := stackDepth + 1) < 40 ]] 
		whileTrue: [
			"variable values"
			aContext printDetails: stream.
			stream cr.
			aContext := aContext sender ].
	stream cr; nextPutAll: '--- The full stack ---'; cr.
	aContext := self.	
	stackDepth := 0.
	[ aContext == nil ] whileFalse:	[
		stackDepth := stackDepth + 1.	
		stackDepth = 40 ifTrue: [ stream nextPutAll: ' - - - - - - - - - - - - - - -  
			- - - - - - - - - - - - - - - - - -'; cr ].
		"just class>>selector"	
		stream print: aContext; cr. 		
		stackDepth > 200 ifTrue: [
			stream nextPutAll: '-- and more not shown --'.
			^  self ].
		aContext := aContext sender ].! !

!Context class methodsFor: '*Debugging-Core' stamp: ''!
tallyInstructions: aBlock
	"
	Count the occurrences of each bytecode during the execution of aBlock.
	Return a Array of associations using the byte as key and the occurrences as values sorted by the instruction opcode numeric values.
	
	This method uses the in-image bytecode interpreter to evaluate and count the instructions.
	
	(Context tallyInstructions: [3.14159 printString]) size >>> 122
	"
	
	| tallies |
	tallies := Bag new.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current | tallies add: current instructionStream peekByte ].
	^tallies sortedElements! !

!Context class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Contexts must only be created with newForMethod:'! !

!Context class methodsFor: 'simulation' stamp: ''!
initializeTryNamedPrimitiveTemplateMethod
	| source method |
	source := 'tryNamedPrimitive
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:'' error: errorCode>
	^ Context primitiveFailTokenFor: errorCode'.
	method := Smalltalk compiler
				class: UndefinedObject;
				source: source;
				compile.
	TryNamedPrimitiveTemplateMethod := method copyWithSource: source.! !

!Context class methodsFor: 'simulation' stamp: ''!
initializePrimitiveSimulators
	"extra primitive simulators can be registered by implementing
	#registerPrimitiveSimulators method in class side of your class."
	<ignoreUnimplementedCalls: #(#registerPrimitiveSimulators)>
	
	SpecialPrimitiveSimulators := Dictionary new.

	Class allSubclassesDo: [:metaclass |
		(metaclass includesSelector: #registerPrimitiveSimulators) ifTrue: [
			metaclass instanceSide registerPrimitiveSimulators.
			]
		].! !

!Context class methodsFor: 'hacks' stamp: ''!
allInstancesDo: aBlock
	"Evaluate aBlock with each of the current instances of the receiver."
	| instances inst next |
	instances := self allInstancesOrNil.
	instances ifNotNil:
		[instances do: aBlock.
		 ^self].
	"allInstancesOrNil can fail because memory is low.  If so, fall back on the old
	 enumeration code.  Because aBlock might change the class of inst (for example,
	 using become:), it is essential to compute next before aBlock value: inst.
	 Only count until thisContext since evaluation of aBlock will create new contexts."
	inst := self someInstance.
	[inst == thisContext or: [inst == nil]] whileFalse:
		[next := inst nextInstance.
		 aBlock value: inst.
		 inst := next]! !

!Context class methodsFor: 'instance creation' stamp: ''!
basicNew: size
	self error: 'Contexts must only be created with newForMethod:'! !

!Context class methodsFor: 'special context creation' stamp: ''!
theReturnMethod

	| meth |
	meth := self lookupSelector: #return:.
	meth isPrimitive ifTrue: [^ self error: 'expected #return: to not be a primitive'].
	^ meth! !

!Context class methodsFor: '*Debugging-Core' stamp: ''!
runSimulated: aBlock
	"Simulate the execution of the argument, current. Answer the result it 
	returns."

	^ thisContext sender
		runSimulated: aBlock
		contextAtEachStep: [:ignored |]

	"Context runSimulated: [Pen new defaultNib: 5; go: 100]"! !

!Context class methodsFor: 'simulation' stamp: ''!
primitiveFailToken

	^ self primitiveFailTokenFor: nil! !

!Context class methodsFor: 'instance creation' stamp: ''!
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! !

!Context class methodsFor: 'special context creation' stamp: ''!
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. 
	
		"As the jump will return to the current context inside the context on:do:
		It is needed to emulate the return value of sending the message on:do:
		If this is not done, the context will do an additional pop, affecting the temporary variables. 
		This is required because we are breaking a condition on Context >> jump.
		The receiver of jump should be a Top context, in this case it is not. "
		ctxt push:nil. 
		ctxt jump] on: exceptionClass do: block.
	"jump above will resume here without unwinding chain"
	^ chain! !

!Context class methodsFor: '*Debugging-Core' stamp: ''!
tallyMethods: aBlock
	"This method uses the simulator to count the number of calls on each method
	invoked in evaluating aBlock. Results are given in order of decreasing counts."
	| prev tallies |
	tallies := Bag new.
	prev := aBlock.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			current == prev ifFalse: "call or return"
				[prev sender ifNotNil: "call only"
					[tallies add: current printString].
				prev := current]].
	^ tallies sortedCounts

	"Contex tallyMethods: [3.14159 printString]"! !

!Context class methodsFor: 'simulation' stamp: ''!
initialize

	"A unique object to be returned when a primitive fails during simulation"
	PrimitiveFailToken := Object new.
	self initializeTryNamedPrimitiveTemplateMethod.
	SpecialPrimitiveSimulators := nil! !

!Context class methodsFor: 'simulation' stamp: ''!
primitiveFailTokenFor: errorCode

	^ { PrimitiveFailToken. errorCode }! !

!Context class methodsFor: 'instance creation' stamp: ''!
new: size

	self error: 'Contexts must only be created with newForMethod:'! !

!Context class methodsFor: 'accessing' stamp: ''!
specialPrimitiveSimulators
	SpecialPrimitiveSimulators ifNil: [ self initializePrimitiveSimulators ].
	^ SpecialPrimitiveSimulators! !

!Context class methodsFor: 'compiler' stamp: ''!
compiler
	"The JIT compiler needs to trap all reads to instance variables of contexts. As this check is costly, it is only done in the long form of the bytecodes, which are not used often. In this hierarchy we force the compiler to alwasy generate long bytecodes"
	^super compiler options: #(+ optionLongIvarAccessBytecodes)! !

!Context class methodsFor: '*Fuel-Core' stamp: ''!
newFromFrameSize: aFrameSize
	
	^ super basicNew: aFrameSize! !

!Context class methodsFor: '*Debugging-Core' stamp: ''!
simulatePrimitive: primName module: moduleName with: simulator
	^ self specialPrimitiveSimulators at: {primName. moduleName} put: simulator! !

!Context class methodsFor: 'instance creation' stamp: ''!
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! !

!Context class methodsFor: 'enumerating' stamp: ''!
allInstances
	"Answer all instances of the receiver."
	<primitive: 177>
	"The primitive can fail because memory is low.  If so, fall back on the old
	 enumeration code, which gives the system a chance to GC and/or grow.
	 Because aBlock might change the class of inst (for example, using become:),
	 it is essential to compute next before aBlock value: inst.
	 Only count until thisContext since this context has been created only to
	 compute the existing instances."
	| inst insts next |
	insts := WriteStream on: (Array new: 64).
	inst := self someInstance.
	[inst == thisContext or: [inst == nil]] whileFalse:
		[next := inst nextInstance.
		 insts nextPut: inst.
		 inst := next].
	^insts contents! !

!Context class methodsFor: 'private' stamp: ''!
carefullyPrint: anObject on: aStream
	aStream nextPutAll: ([anObject printString]
		on: Error
		do: ['unprintable ' , anObject class name])! !

!Context class methodsFor: '*Debugging-Core' stamp: ''!
simulatePrimitiveNumber: num with: simulator
	^ self specialPrimitiveSimulators at: num put: simulator! !

!Context class methodsFor: 'accessing' stamp: ''!
tryNamedPrimitiveTemplateMethod
	^ TryNamedPrimitiveTemplateMethod! !

!Context class methodsFor: 'special context creation' stamp: ''!
contextEnsure: block
	"Create an #ensure: context that is ready to return from executing its receiver"

	| ctxt chain |
	ctxt := thisContext.
	[chain := thisContext sender cut: ctxt. 
		
		"As the jump will return to the current context inside the context ensure:
		It is needed to emulate the return value of sending the message ensure:
		If this is not done, the context will do an additional pop, affecting the temporary variables. 
		This is required because we are breaking a condition on Context >> jump.
		The receiver of jump should be a Top context, in this case it is not. "
		ctxt push: nil. 
		ctxt jump] ensure: block.
	"jump above will resume here without unwinding chain"
	^ chain! !

!ContextCannotReturn commentStamp: ''!
This exception is thrown when a value is returned from a context, but the context is dead and the return can not be done.!
!ContextCannotReturn methodsFor: 'accessing' stamp: ''!
target: anObject
	target := anObject! !

!ContextCannotReturn methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!ContextCannotReturn class methodsFor: 'signalling' stamp: ''!
result: anObject to: aContext

	^self new 
		result: anObject;
		target: aContext;
		signal! !

!ContextDebuggingTest methodsFor: 'tests' stamp: ''!
testStepToSendOrReturn
	| context |
	context := self deadContext.
	self assert: context isDead.
	context := context stepToSendOrReturn.
	self assert: context isDead! !

!ContextDebuggingTest methodsFor: 'helpers' stamp: ''!
zeroReturnMethod
	^0! !

!ContextDebuggingTest methodsFor: 'helpers' stamp: ''!
contextForMethod: aCompiledMethod

	^ Context
		  sender: thisContext
		  receiver: self class basicNew
		  method: aCompiledMethod
		  arguments: #(  )! !

!ContextDebuggingTest methodsFor: 'helpers' stamp: ''!
selfReturnMethod
	#foo asSymbol! !

!ContextDebuggingTest methodsFor: 'helpers' stamp: ''!
trueReturnMethod
	^true! !

!ContextDebuggingTest methodsFor: 'helpers' stamp: ''!
deadContext
	| process context |
	process := [  ] newProcess.
	context := process suspendedContext.
	context pc: nil.
	^ context! !

!ContextDebuggingTest methodsFor: 'helpers' stamp: ''!
accessorMethod
	^instVar! !

!ContextDebuggingTest methodsFor: 'tests' stamp: ''!
testUpdatePCForQuickPrimitiveRestart

	|method newContext  |
	method := self class >> #accessorMethod.
	newContext := self  contextForMethod: method.
	newContext updatePCForQuickPrimitiveRestart.	
	self
		assert: newContext pc
		equals: method initialPC + newContext quickMethodPrimitiveBytecodeSize.
		
	method := self class >> #zeroReturnMethod.
	newContext := self contextForMethod: method.
	newContext updatePCForQuickPrimitiveRestart.	
	self
		assert: newContext pc
		equals: method initialPC + newContext quickMethodPrimitiveBytecodeSize.
		
	method := self class >> #trueReturnMethod.
	newContext := self  contextForMethod: method.
	newContext updatePCForQuickPrimitiveRestart.	
	self
		assert: newContext pc
		equals: method endPC.
		
	method := Symbol >> #asSymbol.
	newContext := self  contextForMethod: method.
	newContext updatePCForQuickPrimitiveRestart.	
	self
		assert: newContext pc
		equals: method endPC! !

!ContextTest commentStamp: ''!
I am an SUnit Test of Context.

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 ...  
nonActiveBlockContext  - the Context of a block whose home context is not in its sender chain (because the method that created this block already returned)
!
!ContextTest methodsFor: 'tests' stamp: ''!
testActivateReturnValue
	self assert: ((aSender activateReturn: aMethodContext value: #()) isKindOf: Context).
	self assert: (aSender activateReturn: aMethodContext value: #()) receiver equals: aMethodContext! !

!ContextTest methodsFor: 'tests' stamp: ''!
testSteppingReturnSelfMethod

	|newContext|
	aMethodContext := Context
		sender: thisContext
		receiver: SimulationMock new
		method: (SimulationMock >>#exampleSelfReturnCall)
		arguments: #().	
			
	aMethodContext step.
	aMethodContext stepIntoQuickMethod: true.
	newContext := aMethodContext step.
	
	"We're in the quick method now, it should be steppable"
	self assert: newContext sender identicalTo: aMethodContext.
	self assert: newContext instructionStream willReturn.
	
	newContext := newContext step.
	self assert: newContext identicalTo: aMethodContext! !

!ContextTest methodsFor: 'private' stamp: ''!
testActiveHomeMethodContext
	self
		assert: aMethodContext activeHome identicalTo: aMethodContext;
		assert: aMethodContext activeHome identicalTo: aMethodContext home! !

!ContextTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testTempNamed
	| oneTemp context |
	oneTemp := 1.
	self assert: (thisContext tempNamed: 'oneTemp') equals: oneTemp.

	context := self class contextWithTempForTesting.
	self assert: (context tempNamed: 'string') equals: 'test'! !

!ContextTest methodsFor: 'tests' stamp: ''!
testReturn
	"Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp."

	aMethodContext := Context
		sender: thisContext
		receiver: aReceiver
		method: aCompiledMethod
		arguments: #().
	self assert: (aMethodContext return: 5) equals: 5! !

!ContextTest methodsFor: 'tests' stamp: ''!
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 equals: aMethodContext.
	self assert: aMethodContext receiver equals: aReceiver.
	self assert: (aMethodContext method isKindOf: CompiledMethod).
	self assert: aMethodContext method equals: aCompiledMethod.
	self assert: aMethodContext client printString equals: 'ContextTest>>#testSetUp'! !

!ContextTest methodsFor: 'tests' stamp: ''!
testStepIntoQuickMethodBoolean

	self deny: aMethodContext stepIntoQuickMethod! !

!ContextTest methodsFor: 'tests' stamp: ''!
testStepIntoQuickMethodInCompiledBlock

	|newContext|
	newContext := [ ] asContext.
	newContext stepIntoQuickMethod: false.
	self deny: newContext method stepIntoQuickMethods.
	newContext stepIntoQuickMethod: true.
	self assert: newContext method stepIntoQuickMethods! !

!ContextTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testReadVariableNamed
	|localVar|
	localVar := 2.
	instVarForTestLookupSymbol := 3.
	classVarForTestLookupSymbol := 4.
	self assert: (thisContext readVariableNamed: #localVar) equals: 2.
	self assert: (thisContext readVariableNamed: #instVarForTestLookupSymbol) equals: 3.
	self assert: (thisContext readVariableNamed: #classVarForTestLookupSymbol) equals: 4.
	self assert: (thisContext readVariableNamed: #Smalltalk) equals: Smalltalk.! !

!ContextTest methodsFor: 'tests' stamp: ''!
testFindContextSuchThat
	self assert: (aMethodContext findContextSuchThat: [ :each | true ]) printString equals: aMethodContext printString.
	self assert: (aMethodContext hasContext: aMethodContext)! !

!ContextTest methodsFor: 'tests' stamp: ''!
testNoStepIntoQuickMethod

	|newContext |
	aMethodContext := Context
		sender: thisContext
		receiver: aReceiver
		method: (Rectangle >>#center)
		arguments: #().
	
	"We step into #center to get on the topLeft message.
	We did not change context."
	aMethodContext step.

	"Now we step into #topLeft which is a quick method.
	The primitive should be executed as the flag to step into quick methods
	has not been set."
	newContext := aMethodContext step.
	self assert: newContext identicalTo: aMethodContext! !

!ContextTest methodsFor: 'tests' stamp: ''!
testMethodContextPrintDetails

	self
		assert: (String streamContents: [ :stream | 
				 aMethodContext printDetails: stream ])
		equals: 'Rectangle>>areasOutside:
	Receiver: (100@100) corner: (200@200)
	Arguments and temporary variables: 
		aRectangle: 	(200@200) corner: (420@420)
	Receiver''s instance variables: 
		origin: 	(100@100)
		corner: 	(200@200)

'! !

!ContextTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testTempNamedPutShouldReturnAssignedValue
	| oneTemp |
	oneTemp := 1.
	self assert: (thisContext tempNamed: 'oneTemp' put: 2) equals: 2! !

!ContextTest methodsFor: 'private' stamp: ''!
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 equals: a.
			self assert: nil identicalTo: b.
			b := a + 20.
			firstTimeThrough
				ifTrue: [ firstTimeThrough := false.
					thisContext restart ].
			b ] value! !

!ContextTest methodsFor: 'tests' stamp: ''!
testActiveBlockContextHomeAndActiveHome
	[ self assert: thisContext home identicalTo:  thisContext activeHome.] value! !

!ContextTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	aCompiledMethod := Rectangle methodDict at: #areasOutside:.
	aReceiver := 100 @ 100 corner: 200 @ 200.
	aSender := thisContext.
	anArgument := 420 @ 420 corner: 200 @ 200.
	aMethodContext := Context
		                  sender: aSender
		                  receiver: aReceiver
		                  method: aCompiledMethod
		                  arguments: { anArgument }! !

!ContextTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testJump
	#(exampleClosure exampleSend exampleStore) do: [ :selector |
		self verifyJumpWithSelector: selector ]! !

!ContextTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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!!"! !

!ContextTest methodsFor: 'running' stamp: ''!
tearDown
	aMethodContext stepIntoQuickMethod: false.
	super tearDown! !

!ContextTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testSourceNodeExecuted
	| sourceNode |
	sourceNode := thisContext sender sender sourceNodeExecuted.
	self assert: sourceNode selector equals: #performTest! !

!ContextTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testSourceNodeExecutedWhenContextIsJustAtStartpc
	| sourceNode context |
	
	context := Context sender: thisContext receiver: self method: self class >> testSelector arguments: #().
	sourceNode := context sourceNodeExecuted.
	self assert: sourceNode equals: (self class >> testSelector) ast sendNodes first receiver! !

!ContextTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testScopeOptimizedBlock
	"When asking for the scope of a block that is not there at runtime, we nevertheless what to 
	get the corresponding scope of the optimized block"
	
	| astScope method |
	
	method := Smalltalk compiler
							  class: Object;
							  compile:  'test 1 to: 1 do: [ :i | ^ thisContext astScope ]'.
	astScope := method valueWithReceiver: nil arguments: #(). 
	
	self assert: astScope class equals: OCOptimizedBlockScope .! !

!ContextTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testTempNamedShouldFailGivenNameIsNotTemp

	self assert: (self class hasSlotNamed: #testSelector).
	self should: [thisContext tempNamed: #testSelector] raise: Error! !

!ContextTest methodsFor: 'tests' stamp: ''!
testNonActiveBlockContextHome
	nonActiveBlockContext := self class returnNonActiveContextOfBlock.
	self assert: (nonActiveBlockContext home) isNotNil.! !

!ContextTest methodsFor: 'tests' stamp: ''!
testStepIntoQuickMethod

	|newContext quickMethod|
	aMethodContext := Context
		sender: thisContext
		receiver: aReceiver
		method: (Rectangle >>#center)
		arguments: #().
	
	"We step into #center to get on the topLeft message.
	We did not change context."
	aMethodContext step.
	
	"Now we step into #topLeft which is a quick method"
	aMethodContext stepIntoQuickMethod: true.
	newContext := aMethodContext step.
	quickMethod := (Rectangle >> #topLeft).
	self assert: newContext sender identicalTo: aMethodContext.
	self assert: newContext method identicalTo: quickMethod.
	self assert: quickMethod isQuick.
	
	"The quick method contains 3 bytecodes:
	- primitive 264: a 3 bytecode primitive (initialPC)
	- a push of a value (endPC - 1)
	- the return top instruction (endPC)
	When activating the quic method, we arrive on the PC corresponding to the primitive.
	This one is not suposed to be stepped.
	The first steppable bytecode is the push just before the return.
	We do that by setting the PC to aMethod initialPC + 3 (the number of bytes of the primitive)."
	self assert: newContext pc equals: (quickMethod initialPC + 3)! !

!ContextTest methodsFor: '*NewTools-Debugger-Tests' stamp: ''!
testFailedAssertionContextInSenderChain

	! !

!ContextTest methodsFor: 'private' stamp: ''!
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 equals: a.
			self assert: nil identicalTo: b.
			b := a + 20.
			firstTimeThrough
				ifTrue: [ firstTimeThrough := false.
					thisContext restart ].
			b ] value: 10)! !

!ContextTest methodsFor: 'tests' stamp: ''!
testSteppingAQuickMethod

	|newContext|
	aMethodContext := Context
		sender: thisContext
		receiver: aReceiver
		method: (Rectangle >>#center)
		arguments: #().	
	
	aMethodContext step.
	aMethodContext stepIntoQuickMethod: true.
	newContext := aMethodContext step.
	
	"We're in the quick method now, it should be steppable"
	self assert: newContext sender identicalTo: aMethodContext.
	self deny: newContext instructionStream willReturn.
	
	newContext := newContext step.
	self assert: newContext instructionStream willReturn.
	
	newContext := newContext step.
	self assert: newContext identicalTo: aMethodContext! !

!ContextTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testCannotReturn
	| context p |
	p := [context := thisContext] fork.
	[p isTerminated] whileFalse: [ 10 milliSeconds wait ].

	[ context resume: #result.
	self assert: false description: 'ContextCannotReturn should be signaled' ]
		 on: ContextCannotReturn do: [ :err |
			self assert: err result equals: #result.
			self assert: err target equals: context]! !

!ContextTest methodsFor: 'tests' stamp: ''!
testNonActiveBlockContextActiveHome
	nonActiveBlockContext := self class returnNonActiveContextOfBlock.
	self assert: (nonActiveBlockContext activeHome) isNil.! !

!ContextTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testTempNamedPut
	| oneTemp |
	oneTemp := 1.
	thisContext tempNamed: 'oneTemp' put: 2.

	self assert: (thisContext tempNamed: 'oneTemp') equals: 2! !

!ContextTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testSourceNodeOptimizedBlock
	"When asking for the sourceNode of a block that is not there at runtime, we nevertheless what to 
	get the corresponding ASTnode of the ASTNode that created thisContext, the method in this case"
	
	| sourceNode method |
	
	method := Smalltalk compiler
							  class: Object;
							  compile:  'test 1 to: 1 do: [ :i | ^ thisContext sourceNode ]'.
	sourceNode := method valueWithReceiver: nil arguments: #(). 
	
	self assert: sourceNode isMethod.! !

!ContextTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testWriteVariableNamedValue
	|localVar|
	localVar := 2.
	instVarForTestLookupSymbol := 3.
	classVarForTestLookupSymbol := 4.
	thisContext writeVariableNamed: #localVar value: #changed1.
	self assert: (thisContext readVariableNamed: #localVar) equals: #changed1.
	thisContext writeVariableNamed: #instVarForTestLookupSymbol value: #changed2.
	self assert: (thisContext readVariableNamed: #instVarForTestLookupSymbol) equals: #changed2.
	thisContext writeVariableNamed: #classVarForTestLookupSymbol value: #changed3.
	self assert: (thisContext readVariableNamed: #classVarForTestLookupSymbol) equals: #changed3! !

!ContextTest methodsFor: 'tests' stamp: ''!
verifyJumpWithSelector: selector
	| guineaPig normalStackp readOnlyStackp |
	guineaPig := SimulationMock new.
	normalStackp := (guineaPig perform: selector) stackPtr.
	guineaPig beReadOnlyObject.
	[ readOnlyStackp := (guineaPig perform: selector) stackPtr ]
		on: ModificationForbidden
		do: [ :ex | ex resumeUnchecked: nil ].
	self assert: normalStackp equals: readOnlyStackp! !

!ContextTest methodsFor: 'private' stamp: ''!
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 equals: a.
			self assert: nil identicalTo: 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)! !

!ContextTest methodsFor: 'tests' stamp: ''!
testMethodContext

	self assert: aMethodContext home notNil.
	self assert: aMethodContext receiver notNil.
	self assert: (aMethodContext method isKindOf: CompiledMethod).! !

!ContextTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testTempNamedPutShouldFailGivenNameIsNotTemp
	
	self assert: (self class hasSlotNamed: #expectedFails).	
	self should: [thisContext tempNamed: #expectedFails put: 0] raise: Error! !

!ContextTest methodsFor: 'tests' stamp: ''!
testStepIntoReturnSelfMethod

	|newContext quickMethod|
	aMethodContext := Context
		sender: thisContext
		receiver: SimulationMock new
		method: (SimulationMock >>#exampleSelfReturnCall)
		arguments: #().	
	
	"(SimulationMock >>#exampleSelfReturnCall) just executes 
	self yourself
	We step over self to get on the yourself message.
	We did not change context."
	aMethodContext step.
	
	"Now we step into #yourself which is a quick method just returning self"
	aMethodContext stepIntoQuickMethod: true.
	newContext := aMethodContext step.
	quickMethod := (Object >> #yourself).
	self assert: newContext sender identicalTo: aMethodContext.
	self assert: newContext method identicalTo: quickMethod.
	self assert: quickMethod isQuick.
	
	"The quick method contains 3 bytecodes:
	- primitive 256: a 3 bytecode primitive (initialPC)
	- the return self instruction (endPC)
	When activating the quick method, we arrive on the PC corresponding to the primitive.
	This one is not suposed to be stepped.
	The first steppable bytecode is the push just before the return.
	We do that by setting the PC to aMethod initialPC + 3 (the number of bytes of the primitive)."
	self assert: newContext pc equals: (quickMethod initialPC + 3)! !

!ContextTest class methodsFor: 'helper' stamp: ''!
returnNonActiveContextOfBlock
	Block := self createBlock.
	^ Block value! !

!ContextTest class methodsFor: 'helper' stamp: ''!
createBlock
	"we reference self to force a full block"
	^ [ self . thisContext ]! !

!ContextTest class methodsFor: 'closures for testing' stamp: ''!
contextWithTempForTesting 
	| string |
	string := 'test'.
	^ [self class. string asUppercase] asContext.! !

!ContextualClassAnnotationExample1 methodsFor: 'testing' stamp: ''!
isActiveInContext: anAnnotationUser
	^(super isActiveInContext: anAnnotationUser)
		and: [ anAnnotationUser isSimulatedActiveAnnotation ]! !

!Continuation commentStamp: ''!
I permit to save the execution flow and to restart it later. I was originally used in seaside.

Example :

You have an object with the instance variable executionFlow.

You save the current execution flow with :
Continuation currentDo: [ :cc | executionFlow := cc]

You restart the execution flow with :
executionFlow value: true


!
!Continuation methodsFor: 'evaluating' stamp: ''!
value: anObject
	"Invoke the continuation and answer anObject as return value."

	self terminate: thisContext.
	self restoreValues.
	thisContext swapSender: values first.
	^ anObject! !

!Continuation methodsFor: 'private' stamp: ''!
initializeFromContext: aContext
	| valueStream context |
	valueStream := WriteStream on: (Array new: 20).
	context := aContext.
	[context notNil] whileTrue:
		[valueStream nextPut: context.
		1 to: context class instSize do: [:i | valueStream nextPut: (context instVarAt: i)].
		1 to: context size do: [:i | valueStream nextPut: (context at: i)].
		context := context sender].
	values := valueStream contents! !

!Continuation methodsFor: 'evaluating' stamp: ''!
value
	self value: nil! !

!Continuation methodsFor: 'private' stamp: ''!
restoreValues
	| valueStream context |
	valueStream := values readStream.
	[valueStream atEnd] whileFalse:
		[context := valueStream next.
		1 to: context class instSize do: [:i | context instVarAt: i put: valueStream next].
		1 to: context size do: [:i | context at: i put: valueStream next]]! !

!Continuation methodsFor: 'private' stamp: ''!
terminate: aContext
	| context |
	context := aContext.
	[context notNil] whileTrue: [context := context swapSender: nil]! !

!Continuation methodsFor: 'accessing' stamp: ''!
numArgs
	^ 1! !

!Continuation methodsFor: 'evaluating' stamp: ''!
valueWithArguments: anArray
	anArray size = 1
		ifFalse: [ ^ self error: 'continuations can only be resumed with one argument' ].
	self value: anArray first! !

!Continuation class methodsFor: 'instance creation' stamp: ''!
try: tryBlock otherwise: elseBlock
	^ self
		currentDo: [ :success | 
			| localResult |
			localResult := self
				currentDo: [ :local | success value: (tryBlock value: local) ].
			elseBlock cull: localResult ]! !

!Continuation class methodsFor: 'instance creation' stamp: ''!
current
	^ self fromContext: thisContext sender! !

!Continuation class methodsFor: 'instance creation' stamp: ''!
fromContext: aStack
	^self new initializeFromContext: aStack! !

!Continuation class methodsFor: 'instance creation' stamp: ''!
currentDo: aBlock
	^ aBlock value: (self fromContext: thisContext sender)! !

!Continuation class methodsFor: 'instance creation' stamp: ''!
try: tryBlock or: orBlock otherwise: elseBlock
	"	^ self
		currentDo: [ :success | 
			| localResult localResult1 |
			localResult := self
				currentDo: [ :local | success value: (tryBlock value: local) ].
			localResult1 := self
				currentDo: [ :local | success value: (orBlock cull: local cull: localResult) ].
			elseBlock cull: localResult1 cull: localResult ]"

	^ self
		try: tryBlock
		otherwise: [ :res | 
			self
				try: [ :cont | orBlock cull: cont cull: res ]
				otherwise: [ :lastRes | elseBlock cull: lastRes cull: res ] ]! !

!Continuation class methodsFor: 'instance creation' stamp: ''!
try: tryBlock or: orBlock or: orrBlock otherwise: elseBlock
	^ self
		try: tryBlock
		otherwise: [ :res | 
			self
				try: [ :cont | orBlock cull: cont cull: res ]
				or: orrBlock
				otherwise: [ :rr :r | elseBlock cull: rr cull: r cull: res ] ]! !

!ContinuationTest commentStamp: ''!
I represent intentend to provide complete coverage for the Continuation class.!
!ContinuationTest methodsFor: 'tests' stamp: ''!
testSimpleCallCC
	| x continuation |
	x := self callcc: [ :cc | continuation := cc. false ].
	x ifFalse: [ continuation value: true ].
	self assert: x! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
intersectWithCCAllWithCC: sets
	^ sets
		ifNotEmpty: [ Continuation
				currentDo: [ :cc | 
					self
						intersectWithCC: sets first
						withAll: sets allButFirst
						continuation: cc ] ]! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
remove: anObj uptoLast: aLinkedList
	^ aLinkedList
		ifNotEmpty: [ | valueLink |
			valueLink := Continuation
				currentDo: [ :skip | 
					self
						remove: anObj
						uptoLastValueLink: aLinkedList firstLink
						continuation: skip ].
			LinkedList with: valueLink ]! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
intersect: aSet withAll: sets continuation: hop
	^ aSet
		ifEmpty: [ hop value: aSet ]
		ifNotEmpty: [ sets
				ifEmpty: [ aSet ]
				ifNotEmpty: [ self
						intersect: aSet
						withCollection:
							(self
								intersect: sets first
								withAll: sets allButFirst
								continuation: hop) ] ]! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testSimplestCallCC
	| x |
	x := self callcc: [ :cc | cc value: true ].
	self assert: x! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testRemoveOneStar
	| tree1 tree2 |
	tree1 := #Swedish ~~> (#rye ~~> nil)
		~~>
			(#French ~~> (#mustard ~~> (#salad ~~> (#turkey ~~> nil)) ~~> nil)
				~~> (#salad ~~> nil)).
	tree2 := #pasta ~~> (#meat ~~> nil)
		~~>
			(#pasta
				~~>
					(#noodles ~~> (#meat ~~> (#sauce ~~> nil))
						~~> (#meat ~~> (#tomatoes ~~> nil)))).
	self
		assert: (self printStringOfTree: tree1)
		equals: '((#Swedish #rye) (#French (#mustard #salad #turkey)) #salad)'.
	self
		assert: (self printStringOfTree: tree2)
		equals: '((#pasta #meat) #pasta (#noodles #meat #sauce) #meat #tomatoes)'.
	self
		assert: (self printStringOfTree: (self remove: #salad oneStar: tree1))
		equals: '((#Swedish #rye) (#French (#mustard #turkey)) #salad)'.
	self
		assert: (self printStringOfTree: (self remove: #salad oneStarWithTry: tree1))
		equals: '((#Swedish #rye) (#French (#mustard #turkey)) #salad)'.
	self
		assert: (self printStringOfTree: (self remove: #meat oneStar: tree2))
		equals: '((#pasta) #pasta (#noodles #meat #sauce) #meat #tomatoes)'.
	self
		assert: (self printStringOfTree: (self remove: #meat oneStarWithTry: tree2))
		equals: '((#pasta) #pasta (#noodles #meat #sauce) #meat #tomatoes)'! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testBlockEscape
	| x |
	tmp := 0.
	x := [ tmp := tmp + 1.
	tmp2 value ].
	self
		callcc: [ :cc | 
			tmp2 := cc.
			x value ].
	tmp2 := [  ].
	x value.
	self assert: tmp equals: 2! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
intersectWithCC: aSet withAll: sets continuation: hop
	^ aSet
		ifEmpty: [ hop value: aSet ]
		ifNotEmpty: [ sets
				ifEmpty: [ aSet ]
				ifNotEmpty: [ self
						intersect: aSet
						withCollection:
							(self
								intersectWithCC: sets first
								withAll: sets allButFirst
								continuation: hop)
						continuation: hop ] ]! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
intersect: aLinkedList withCollection: aCollection
	^ aLinkedList
		ifNotEmpty: [ (self
				intersectValueLink: aLinkedList firstLink
				withCollection: aCollection)
				ifNil: [ LinkedList new ]
				ifNotNil: [ :link | LinkedList with: link ] ]! !

!ContinuationTest methodsFor: 'utilities' stamp: ''!
callcc: aBlock
	^ Continuation currentDo: aBlock! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
intersectAllWithCC: sets
	^ sets
		ifNotEmpty: [ Continuation
				currentDo:
					[ :cc | self intersect: sets first withAll: sets allButFirst continuation: cc ] ]! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testMethodTemps
	| i continuation |
	i := 0.
	i := i + (self callcc: [:cc | continuation := cc. 1]).
	self assert: i ~= 3.
	i = 2 ifFalse: [ continuation value: 2 ]! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testReentrant
	| assoc |
	assoc := self callcc: [ :cc | cc -> 0 ].
	assoc value: assoc value + 1.
	self assert: assoc value ~= 5.
	assoc value = 4
		ifFalse: [ assoc key value: assoc ]! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
intersect: aLinkedList withCollection: aCollection continuation: hop
	^ aCollection
		ifEmpty: [ hop value: aCollection ]
		ifNotEmpty: [ self intersect: aLinkedList withCollection: aCollection ]! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
remove: anObj oneStar: aTree
	| newTree sentinel |
	sentinel := #absent.
	newTree := self
		callcc: [ :oh | 
			self
				remove: anObj
				oneStar: aTree
				sentinel: sentinel
				continuation: oh ].
	^ newTree = sentinel
		ifTrue: [ aTree ]
		ifFalse: [ newTree ]! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testBlockTemps
	| y |
	#(1 2 3)
		do: [ :i | 
			| x |
			x := i.
			tmp
				ifNil: [ tmp2 := self
						callcc: [ :cc | 
							tmp := cc.
							[ :q |  ] ] ].
			tmp2 value: x.
			x := 17 ].
	y := self
		callcc: [ :cc | 
			tmp value: cc.
			42 ].
	self assert: y equals: 1! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
remove: anObj uptoLastValueLink: aValueLink continuation: skip
	^ aValueLink
		ifNotNil: [ | car cdr |
			car := aValueLink value.
			cdr := self
				remove: anObj
				uptoLastValueLink: aValueLink nextLink
				continuation: skip.
			anObj = car
				ifTrue: [ skip value: cdr ]
				ifFalse: [ car ~~> cdr ] ]! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testIntersectWith
	self
		assert:
			(self
				intersect: (LinkedList with: #apple with: #banana with: #avocado)
				withCollection: (LinkedList with: 1 with: 2 with: #apple))
		equals: (LinkedList with: #apple).
	self
		assert:
			(self
				intersect: ((1 to: 10) as: LinkedList)
				withCollection: (9 to: 20))
		equals: (9 to: 10).
	self
		assert:
			(self
				intersect: ((1 to: 10) as: LinkedList)
				withCollection: (11 to: 20))
		equals: {}! !

!ContinuationTest methodsFor: 'printing' stamp: ''!
printStringOfTree: aValueLink
	^ String
		streamContents: [ :aStream | self printStringOfTree: aValueLink onStream: aStream ]! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testIntersectAll
	self
		assert:
			(self
				intersectAll:
					{(LinkedList with: 3 with: #mangos with: #and).
					(LinkedList with: 3 with: #kiwis with: #and).
					(LinkedList with: 3 with: #hamburges)})
		equals: {3}.
	self
		assert:
			(self
				intersectAll:
					{(LinkedList with: 3 with: #steaks with: #and).
					(LinkedList with: #no with: #food with: #and).
					(LinkedList with: #three with: #baked with: #potatoes).
					(LinkedList with: 3 with: #diet with: #hamburges)})
		equals: {}.
	self
		assert:
			(self
				intersectAll:
					{(LinkedList with: 3 with: #steaks with: #and).
					LinkedList new.
					(LinkedList with: #three with: #baked with: #potatoes).
					(LinkedList with: 3 with: #diet with: #hamburges)})
		equals: {}.
	self
		assert:
			(self
				intersectAllWithCC:
					{(LinkedList with: 3 with: #steaks with: #and).
					LinkedList new.
					(LinkedList with: #three with: #baked with: #potatoes).
					(LinkedList with: 3 with: #diet with: #hamburges)})
		equals: {}.
	self
		assert:
			(self
				intersectWithCCAllWithCC:
					{(LinkedList with: 3 with: #steaks with: #and).
					(LinkedList with: #no with: #food with: #and).
					(LinkedList with: #three with: #baked with: #potatoes).
					(LinkedList with: 3 with: #diet with: #hamburges)})
		equals: {}! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
leftmost: aBlock tree: aTree continuation: out
	^ (aTree isNotNil and: [ aTree isMemberOf: ValueLink ])
		ifTrue: [ | car |
			car := aTree value.
			(car isKindOf: Link)
				ifTrue: [ self leftmost: aBlock tree: car continuation: out ]
				ifFalse: [ (aBlock value: car)
						ifTrue: [ out value: car ] ].
			self leftmost: aBlock tree: aTree nextLink continuation: out ]
		ifFalse: [ nil ]! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
remove: anObj oneStar: aTree sentinel: aSymbol continuation: oh
	^ aTree
		ifNil: [ oh value: aSymbol ]
		ifNotNil: [ | car cdr naturalRecursion |
			car := aTree value.
			cdr := aTree nextLink.
			naturalRecursion := [ | newCdr |
			newCdr := self
				remove: anObj
				oneStar: cdr
				sentinel: aSymbol
				continuation: oh.
			car ~~> newCdr ].
			(car isMemberOf: ValueLink)
				ifTrue: [ | newCar |
					newCar := Continuation
						currentDo: [ :ooh | 
							self
								remove: anObj
								oneStar: car
								sentinel: aSymbol
								continuation: ooh ].
					newCar = aSymbol
						ifTrue: naturalRecursion
						ifFalse: [ newCar ~~> cdr ] ]
				ifFalse: [ anObj = car
						ifTrue: [ cdr ]
						ifFalse: naturalRecursion ] ]! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
remove: anObj oneStarWithTry: aTree continuation: oh
	^ aTree
		ifNil: [ oh value: #absent ]
		ifNotNil: [ | car cdr naturalRecursion |
			car := aTree value.
			cdr := aTree nextLink.
			naturalRecursion := [ | newCdr |
			newCdr := self remove: anObj oneStarWithTry: cdr continuation: oh.
			car ~~> newCdr ].
			(car isMemberOf: ValueLink)
				ifTrue: [ Continuation
						try: [ :ooh | 
							| newCar |
							newCar := self
								remove: anObj
								oneStarWithTry: car
								continuation: ooh.
							newCar ~~> cdr ]
						otherwise: naturalRecursion ]
				ifFalse: [ anObj = car
						ifTrue: [ cdr ]
						ifFalse: naturalRecursion ] ]! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
intersect: aSet withAll: sets
	^ sets
		ifEmpty: [ aSet ]
		ifNotEmpty: [ self
				intersect: aSet
				withCollection: (self intersect: sets first withAll: sets allButFirst) ]! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
intersectAll: sets
	^ sets
		ifNotEmpty: [ self intersect: sets first withAll: sets allButFirst ]! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
leftmost: aBlock tree: aTree
	^ self
		callcc: [ :skip | self leftmost: aBlock tree: aTree continuation: skip ]! !

!ContinuationTest methodsFor: 'printing' stamp: ''!
printStringOfTree: aValueLink onStream: aStream
	aStream nextPut: $(.
	(aValueLink isMemberOf: Link)
		ifFalse: [ | cell |
			cell := aValueLink.
			[ | car |
			car := cell value.
			(car isKindOf: Link)
				ifTrue: [ self printStringOfTree: car onStream: aStream ]
				ifFalse: [ car printOn: aStream ].
			cell nextLink ifNotNil: [ aStream nextPut: Character space ].
			cell := cell nextLink.
			cell isMemberOf: ValueLink ] whileTrue.
			cell
				ifNotNil: [ aStream
						nextPut: $.;
						nextPut: Character space.
					cell printOn: aStream ] ].
	aStream nextPut: $)! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
remove: anObj oneStarWithTry: aTree
	^ Continuation
		try: [ :oh | self remove: anObj oneStarWithTry: aTree continuation: oh ]
		otherwise: [ aTree ]! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testBlockVars
	| continuation |
	tmp := 0.
	tmp := (self
		callcc: [ :cc | 
			continuation := cc.
			0 ]) + tmp.
	tmp2
		ifNotNil: [ tmp2 value ]
		ifNil: [ #(1 2 3)
				do: [ :i | 
					self
						callcc: [ :cc | 
							tmp2 := cc.
							continuation value: i ] ] ].
	self assert: tmp equals: 6! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testSimpleStoreCallCC
	| x continuation |
	continuation := self callcc: #yourself.
	x := false.
	continuation = true
		ifTrue: [ x := true ]
		ifFalse: [ continuation value: true.
			self error: 'This message shouldn''t be sent, ever.' ].
	self assert: x! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testRemoveUptoLast
	self
		assert:
			(self
				remove: #cookies
				uptoLast:
					(LinkedList new
						add: #cookies;
						add: #chocolate;
						add: #mints;
						add: #caramel;
						add: #delight;
						add: #ginger;
						add: #snaps;
						add: #desserts;
						add: #chocolate;
						add: #mousse;
						add: #vanilla;
						add: #ice;
						add: #cream;
						add: #German;
						add: #chocolate;
						add: #cake;
						add: #more;
						add: #cookies;
						"from this down to the last should be kept in the result
						because the previous #cookies is the last one #cookies in the list."
							add: #gingerbreadman;
						add: #chocolate;
						add: #chip;
						add: #brownies;
						yourself))
		equals:
			(LinkedList new
				add: #gingerbreadman;
				add: #chocolate;
				add: #chip;
				add: #brownies;
				yourself)! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testLeftmost
	| tree |
	tree := #a ~~> nil ~~> nil
		~~> (4 ~~> (Link new ~~> (1 ~~> nil ~~> nil))).
	self
		assert: (self printStringOfTree: tree)
		equals: '(((#a)) 4 () (1))'.
	self assert: (self leftmost: #isSymbol tree: tree) equals: #a.
	self assert: (self leftmost: #isInteger tree: tree) equals: 4.
	self assert: (self leftmost: [ :v | v = 1 ] tree: tree) equals: 1.
	self assert: (self leftmost: #isNil tree: tree) equals: nil.
	self assert: (self leftmost: [ :v | v = 5 ] tree: tree) equals: nil! !

!ContinuationTest methodsFor: 'tests' stamp: ''!
testTwoInARow
	| tree1 tree2 |
	tree1 := #solid ~~> (#food ~~> nil ~~> (Link new ~~> nil))
		~~> (#food ~~> nil ~~> nil ~~> nil ~~> nil).
	tree2 := #solid ~~> (#food ~~> nil ~~> (#marmellade ~~> nil))
		~~> (#food ~~> nil ~~> nil ~~> nil ~~> nil).
	self
		assert: (self printStringOfTree: tree1)
		equals: '((#solid (#food) ()) (((#food))))'.
	self assert: (TwoInARowStar new tree: tree1) equals: true.
	self
		assert: (self printStringOfTree: tree2)
		equals: '((#solid (#food) #marmellade) (((#food))))'.
	self assert: (TwoInARowStar new tree: tree2) equals: false! !

!ContinuationTest methodsFor: 'functions' stamp: ''!
intersectValueLink: aValueLink withCollection: anotherSet
	^ aValueLink
		ifNotNil: [ | car cdr |
			car := aValueLink value.
			cdr := self
				intersectValueLink: aValueLink nextLink
				withCollection: anotherSet.
			(anotherSet includes: car)
				ifTrue: [ car ~~> cdr ]
				ifFalse: [ cdr ] ]! !

!ControlButtonMorph commentStamp: ''!
Specially themed "control" button. Used for drop-lists, expanders etc.!
!ControlButtonMorph methodsFor: 'style' stamp: ''!
normalFillStyle
	"Return the normal fillStyle of the receiver."
	
	^self theme controlButtonNormalFillStyleFor: self! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
mouseOverBorderStyle
	"Return the mouse over borderStyle of the receiver."
	
	^self theme controlButtonMouseOverBorderStyleFor: self! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
selectedDisabledFillStyle
	"Return the selected disabled fillStyle of the receiver."
	
	^self theme controlButtonSelectedDisabledFillStyleFor: self! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
selectedPressedFillStyle
	"Return the selected pressed fillStyle of the receiver."
	
	^self theme controlButtonSelectedPressedFillStyleFor: self! !

!ControlButtonMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self layoutInset: (self theme controlButtonLabelInsetFor: self)! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
normalBorderStyle
	"Return the normal borderStyle of the receiver."
	
	^self theme controlButtonNormalBorderStyleFor: self! !

!ControlButtonMorph methodsFor: 'accessing' stamp: ''!
minWidth
	"Consult the theme also."

	^self perform: #minWidth withArguments: #() inSuperclass: Morph! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
pressedBorderStyle
	"Return the pressed borderStyle of the receiver."
	
	^self theme controlButtonPressedBorderStyleFor: self! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
selectedMouseOverBorderStyle
	"Return the selected mouse over borderStyle of the receiver."
	
	^self theme controlButtonSelectedMouseOverBorderStyleFor: self! !

!ControlButtonMorph methodsFor: 'accessing' stamp: ''!
selectedDisabledBorderStyle
	"Return the selected disabled borderStyle of the receiver."
	
	^self theme controlButtonSelectedDisabledBorderStyleFor: self! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
mouseOverFillStyle
	"Return the mouse over fillStyle of the receiver."
	
	^self theme controlButtonMouseOverFillStyleFor: self! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
selectedFillStyle
	"Return the selected fillStyle of the receiver."
	
	^self theme controlButtonSelectedFillStyleFor: self! !

!ControlButtonMorph methodsFor: 'accessing' stamp: ''!
disabledFillStyle
	"Return the disabled fillStyle of the receiver."
	
	^self theme controlButtonDisabledFillStyleFor: self! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
pressedFillStyle
	"Return the pressed fillStyle of the receiver."
	
	^self theme controlButtonPressedFillStyleFor: self! !

!ControlButtonMorph methodsFor: 'accessing' stamp: ''!
disabledBorderStyle
	"Return the disabled borderStyle of the receiver."
	
	^self theme controlButtonDisabledBorderStyleFor: self! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
selectedPressedBorderStyle
	"Return the selected pressed borderStyle of the receiver."
	
	^self theme controlButtonSelectedPressedBorderStyleFor: self! !

!ControlButtonMorph methodsFor: 'style' stamp: ''!
selectedMouseOverFillStyle
	"Return the selected mouse over fillStyle of the receiver."
	
	^self theme controlButtonSelectedMouseOverFillStyleFor: self! !

!CoonsPaintPatch commentStamp: ''!
I am patch that performs bilinear interpolation along four curved vertices. I can be used for simulating more complex gradients such as conical gradients.!
!CoonsPaintPatch methodsFor: '*Athens-Cairo' stamp: ''!
addToCairoMeshGradientPaint: meshGradientPaint
	meshGradientPaint
		beginPatch;
		moveTo: (controlPoints at: 1);
		curveVia: (controlPoints at: 2) and: (controlPoints at: 3) to: (controlPoints at: 4);
		curveVia: (controlPoints at: 5) and: (controlPoints at: 6) to: (controlPoints at: 7);
		curveVia: (controlPoints at: 8) and: (controlPoints at: 9) to: (controlPoints at: 10);
		curveVia: (controlPoints at: 11) and: (controlPoints at: 12) to: (controlPoints at: 1);
		setCorner: 0 color: colors first;
		setCorner: 1 color: colors second;
		setCorner: 2 color: colors third;
		setCorner: 3 color: colors fourth;
		endPatch! !

!CopiedLocalVariable commentStamp: ''!
A copied variable is an arg or temp var that is copied into a block that later reads this variable!
!CopiedLocalVariable methodsFor: 'testing' stamp: ''!
isArgumentVariable
	^originalVar isArgumentVariable! !

!CopiedLocalVariable methodsFor: 'accessing' stamp: ''!
originalVar
	^ originalVar! !

!CopiedLocalVariable methodsFor: 'debugging' stamp: ''!
writeFromContext: aContext scope: contextScope value: aValue
	self isWritable ifFalse: [ 	^self error: 'Arguments are read only' ].
	"we need to change this var, all the other copies, and the orginal"
	^contextScope setCopyingTempToAllScopesUpToDefTemp: originalVar to: aValue from: aContext! !

!CopiedLocalVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ originalVar acceptVisitor: aProgramNodeVisitor node: aNode! !

!CopiedLocalVariable methodsFor: 'read/write usage' stamp: ''!
isUninitialized
	^originalVar isUninitialized! !

!CopiedLocalVariable methodsFor: 'queries' stamp: ''!
definingNode
	^originalVar definingNode! !

!CopiedLocalVariable methodsFor: 'testing' stamp: ''!
isWritable
	^originalVar isWritable! !

!CopiedLocalVariable methodsFor: 'accessing' stamp: ''!
index: anIndex
	self scope == originalVar scope ifTrue: [ originalVar index: anIndex ].
	super index: anIndex! !

!CopiedLocalVariable methodsFor: 'accessing' stamp: ''!
originalVar: anObject
	originalVar := anObject! !

!CopiedLocalVariable methodsFor: 'testing' stamp: ''!
isCopying
	^true! !

!CopyToClipboardDebugAction commentStamp: ''!
A CopyToClipboardDebugAction copies a short debugging stack to the clipboard.
!
!CopyToClipboardDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 120! !

!CopyToClipboardDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Copy a short debugging stack to the clipboard.'! !

!CopyToClipboardDebugAction methodsFor: 'actions' stamp: ''!
executeAction

	Clipboard clipboardText: (String streamContents: [ :s| 
		self debugger interruptedContext shortDebugStackOn: s ])! !

!CopyToClipboardDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #copyToClipboard! !

!CopyToClipboardDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Copy Stack to Clipboard'! !

!CopyToClipboardDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<contextMenuDebuggingAction>! !

!CopyVisitor commentStamp: ''!
I create a copy of the directory tree that I visit. I use the PreorderGuide so that I can create directories before creating their contents. !
!CopyVisitor methodsFor: 'visiting' stamp: ''!
visit
	(PreorderGuide for: self) 
		show: source! !

!CopyVisitor methodsFor: 'visiting' stamp: ''!
visitDirectory: anEntry
	| reference |
	reference := anEntry reference.
	reference = source
		ifTrue: [dest ensureCreateDirectory]
		ifFalse: [self copyDirectory: reference]! !

!CopyVisitor methodsFor: 'initialization' stamp: ''!
initializeWithSource: srcReference dest: dstReference
	self initialize.
	source := srcReference.
	dest := dstReference! !

!CopyVisitor methodsFor: 'visiting' stamp: ''!
visitFile: anEntry
	| reference |
	reference := anEntry reference.
	reference = source
		ifTrue: [source copyTo: dest]
		ifFalse: [self copyFile: reference]! !

!CopyVisitor methodsFor: 'visiting' stamp: ''!
copyFile: aReference
	| copy |
	copy := dest resolve: (aReference relativeTo: source).
	aReference copyTo: copy! !

!CopyVisitor methodsFor: 'visiting' stamp: ''!
copyDirectory: aReference
	| directory |
	directory := dest resolve: (aReference relativeTo: source).
	directory createDirectory! !

!CopyVisitor class methodsFor: 'instance creation' stamp: ''!
from: srcReference to: dstReference
	^ self basicNew
		initializeWithSource: srcReference 
		dest: dstReference! !

!CopyVisitor class methodsFor: 'instance creation' stamp: ''!
copy: source to: dest
	(self from: source to: dest) visit! !

!CopyVisitorTest commentStamp: ''!
SUnit tests for CopyVisitor!
!CopyVisitorTest methodsFor: 'running' stamp: ''!
createFile: aString 
	source store createFile: (source store pathFromString: aString)! !

!CopyVisitorTest methodsFor: 'running' stamp: ''!
createDirectory: aString 
	source createDirectory: (source store pathFromString: aString)! !

!CopyVisitorTest methodsFor: 'tests' stamp: ''!
testAll
	self setUpGreek.
	CopyVisitor 
		copy: (source / 'alpha') 
		to: (dest / 'alpha').
	self assert: (dest isDirectory: '/alpha').
	self assert: (dest isFile: '/alpha/beta/gamma')! !

!CopyVisitorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	source := FileSystem memory.
	dest := FileSystem memory! !

!CornerGripMorph commentStamp: ''!
I am the superclass of a hierarchy of morph specialized in allowing the user to resize windows.!
!CornerGripMorph methodsFor: 'accessing' stamp: ''!
targetPoint
	"Answer the reference point of the target."

	^self target bounds pointAtSideOrCorner: self ptName! !

!CornerGripMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self extent: self defaultWidth @ self defaultHeight.
	self layoutFrame: self gripLayoutFrame! !

!CornerGripMorph methodsFor: 'accessing' stamp: ''!
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: ''!
mouseDown: anEvent
	"Remember the receiver and target offsets too."
	
	|cp|
	cp := anEvent cursorPoint.
	lastMouse := {cp. cp - self position. cp - self targetPoint}! !

!CornerGripMorph methodsFor: 'accessing' stamp: ''!
defaultWidth
	^ 22! !

!CornerGripMorph methodsFor: 'accessing' stamp: ''!
target
	"Answer the target."

	^target! !

!CornerGripMorph methodsFor: 'accessing' stamp: ''!
defaultHeight
	^ 22! !

!CornerGripMorph methodsFor: 'event' stamp: ''!
mouseMove: anEvent
	"Track the mouse for resizing."
	
	target ifNil: [^ self].
	target fastFramingOn 
		ifTrue: [target doFastWindowReframe: self ptName] 
		ifFalse: [
			lastMouse at: 1 put: anEvent cursorPoint.
			self targetPoint: lastMouse first - lastMouse last.
			self position: (lastMouse first - lastMouse second)].! !

!CornerGripMorph methodsFor: 'accessing' stamp: ''!
target: aMorph

	target := aMorph.
	aMorph ifNotNil: [
		self fillStyle: (aMorph theme resizerGripNormalFillStyleFor: self)]! !

!CornerRounder commentStamp: ''!
This class is a quick hack to support rounded corners in morphic.

Rather than produce rounded rectangles, it tweaks the display of corners.
Rather than work for any radius, it only supports a radius of 6.
Rather than work for any border width, it only supports widths 0, 1 and 2.
The corners, while apparently transparent, still behave opaquely to mouse clicks.

Worse than this, the approach relies on the ability to extract underlying bits from the canvas prior to display.  This ran afoul of top-down display, it seems, in SystemWindow spawnReframeHandle: (qv).  It will also make a postscript printer very unhappy.

But, hey, it's cute.!
!CornerRounder methodsFor: 'all' stamp: ''!
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: ''!
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 methodsFor: 'all' stamp: ''!
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: ''!
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 class methodsFor: 'all' stamp: ''!
roundShadowCornersOf: aMorph on: aCanvas in: bounds displayBlock: displayBlock borderWidth: w corners: aList

	| rounder |
	rounder := CR0.
	w = 1 ifTrue: [rounder := CR1].
	w = 2 ifTrue: [rounder := CR2].
	rounder := rounder copy.
	rounder saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: aList.
	displayBlock value.
	rounder tweakShadowCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: aList! !

!CornerRounder class methodsFor: 'all' stamp: ''!
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: ''!
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: ''!
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! !

!CounterIconStyler commentStamp: ''!
I am rendering ExecutionCounters in the editor.!
!CounterIconStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	^[ :seg | ExecutionCounter removeFrom: aNode. seg delete]! !

!CounterIconStyler methodsFor: 'defaults' stamp: ''!
iconLabelBlock: aNode

	^ [aNode counter count asString]! !

!CounterIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^aNode hasExecutionCounter! !

!CounterIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #classIcon ! !

!CoverageDemo commentStamp: ''!
I'm an example of how metalinks can be used to show the coverage of an execution.

CoverageDemo open!
!CoverageDemo methodsFor: 'accessing' stamp: ''!
coverageCode: anObject
	coverageCode := anObject! !

!CoverageDemo methodsFor: 'initialization' stamp: ''!
initialize
	coverageCode := [ CoverageDemo exampleMethod ].
	compiledMethods := OrderedCollection new.
	compiledMethods add: CoverageDemo class >> #exampleMethod.

	super initialize! !

!CoverageDemo methodsFor: 'initialization' stamp: ''!
initializeWidgets
	installMetalinkButton := self newButton.
	runCodeButton := self newButton.
	codePanelMorph := self newMorph.

	codePanelMorph morph: ReflectivitySourceCodeAgroupation new.

	installMetalinkButton label: 'Install Metalink'.
	runCodeButton label: 'Run Example Code'! !

!CoverageDemo methodsFor: 'styling' stamp: ''!
updateRubricStyle
	codePanelMorph morph submorphs
		do: [ :card | 
			| conf ast |
			"delete previous styling"
			conf := RubConfigurationChange new.
			conf configurationBlock: [ :text | text segments copy do: #delete ].
			card textModel announce: conf.

			"add new styling"
			ast := card compiledMethod ast.
			(ast children anySatisfy: [ :node | node hasBeenExecuted ]) ifTrue: [ ast acceptVisitor: (CoverageRubricStyler new textModel: card textModel) ] ]! !

!CoverageDemo methodsFor: 'accessing' stamp: ''!
compiledMethods: anObject
	compiledMethods := anObject! !

!CoverageDemo methodsFor: 'accessing' stamp: ''!
metalinkBlock
	^ metalinkBlock! !

!CoverageDemo methodsFor: 'examples' stamp: ''!
exampleNotCompleteCoverage

	self coverageCode: [ CoverageDemo exampleIfTrueIfFalse. ].
	self compiledMethods add: CoverageDemo class >>#exampleIfTrueIfFalse.
	
	self openWithSpec.! !

!CoverageDemo methodsFor: 'examples' stamp: ''!
exampleMethod

	self openWithSpec.! !

!CoverageDemo methodsFor: 'api' stamp: ''!
openWithSpec
	self addCards.
	^ super openWithSpec! !

!CoverageDemo methodsFor: 'action' stamp: ''!
runCoverageCode

	coverageCode value.
	self updateRubricStyle.! !

!CoverageDemo methodsFor: 'adding' stamp: ''!
addCards
	compiledMethods do: [ :method | codePanelMorph morph addMorph: (ReflectivityCodeMorph compiledMethod: method) ]! !

!CoverageDemo methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	aWindowPresenter
		title: self title;
		initialExtent: 700 @ 600;
		whenClosedDo: [ self removeMetalink ]! !

!CoverageDemo methodsFor: 'action' stamp: ''!
installMetalink
	| link |
	link := MetaLink new
		metaObject: #node;
		selector: #tagExecuted.

	compiledMethods do: [ :method | method ast nodesDo: [ :node | node link: link ] ]! !

!CoverageDemo methodsFor: 'accessing' stamp: ''!
metalinkBlock: anObject
	metalinkBlock := anObject! !

!CoverageDemo methodsFor: 'accessing' stamp: ''!
compiledMethods
	^ compiledMethods! !

!CoverageDemo methodsFor: 'accessing' stamp: ''!
coverageCode
	^ coverageCode! !

!CoverageDemo methodsFor: 'action' stamp: ''!
removeMetalink
	
	compiledMethods do:[:method| method methodClass recompile].
	! !

!CoverageDemo methodsFor: 'initialization' stamp: ''!
initializePresenter
	installMetalinkButton action: [ self installMetalink ].
	runCodeButton action: [ self runCoverageCode ]! !

!CoverageDemo class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #codePanelMorph;
		add:
			(SpBoxLayout newLeftToRight
				add: #installMetalinkButton;
				add: #runCodeButton;
				yourself)
			withConstraints: [ :constraints | constraints height: self toolbarHeight ];
		yourself! !

!CoverageDemo class methodsFor: 'open' stamp: ''!
open
	<script>
	self new openWithSpec! !

!CoverageDemo class methodsFor: 'examples' stamp: ''!
exampleMethod
	^ 2 + 3! !

!CoverageDemo class methodsFor: 'specs' stamp: ''!
title
	^'Coverage Demo'! !

!CoverageDemo class methodsFor: 'examples' stamp: ''!
exampleIfTrueIfFalse
	| t |
	t := false.
	t ifTrue: [ self bar ] ifFalse: [ 'hello' ].
	^ 5 ! !

!CoverageDemoTest methodsFor: 'running' stamp: ''!
tearDown
	link ifNotNil: [link uninstall].
	ReflectivityExamples recompile: selector.
	super tearDown! !

!CoverageDemoTest methodsFor: 'tests' stamp: ''!
testCoverageControlFlow
	selector := #exampleIfTrueIfFalse.
	link := MetaLink new
		metaObject: #node;
		selector: #tagExecuted.
	(ReflectivityExamples >> #exampleIfTrueIfFalse) ast
		nodesDo: [ :node | node link: link ].
	self assert: ReflectivityExamples new exampleIfTrueIfFalse equals: 5.
	self
		deny:
			((ReflectivityExamples >> #exampleIfTrueIfFalse) ast sendNodes
				select: [ :each | each selector = 'bar' ]) first hasBeenExecuted.
	self
		deny:
			(ReflectivityExamples >> #exampleIfTrueIfFalse) blockNodes first
				hasBeenExecuted.
	self flag: #pharoTodo.	"should be true. need to implement links on optimized block bodies"
	self
		deny:
			(ReflectivityExamples >> #exampleIfTrueIfFalse) blockNodes first body
				hasBeenExecuted.
	self
		assert:
			(ReflectivityExamples >> #exampleIfTrueIfFalse) blockNodes second
				hasBeenExecuted.
	self
		assert:
			(ReflectivityExamples >> #exampleIfTrueIfFalse) blockNodes second body
				hasBeenExecuted.
	self
		assert: (ReflectivityExamples >> #exampleIfTrueIfFalse) ast hasBeenExecuted! !

!CoverageDemoTest methodsFor: 'tests' stamp: ''!
testCoverageMethod
	selector := #exampleMethod.
	link := MetaLink new
		metaObject: #node;
		selector: #tagExecuted.

	(ReflectivityExamples>>#exampleMethod) ast link: link.

	self deny: (ReflectivityExamples>>#exampleMethod) ast hasBeenExecuted.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: (ReflectivityExamples>>#exampleMethod) ast hasBeenExecuted.! !

!CoverageDemoTest methodsFor: 'tests' stamp: ''!
testCoverageAST
	selector := #exampleMethod.
	link := MetaLink new
		metaObject: #node;
		selector: #tagExecuted.
	(ReflectivityExamples >> #exampleMethod) ast
		nodesDo: [ :node | node link: link ].
	self
		deny: (ReflectivityExamples >> #exampleMethod) ast hasBeenExecuted.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self
		assert: (ReflectivityExamples >> #exampleMethod) ast hasBeenExecuted.
	self
		assert:
			(ReflectivityExamples >> #exampleMethod) sendNodes first
				hasBeenExecuted! !

!CoverageRubricStyler commentStamp: ''!
A styler that highlight with green all executed statement!
!CoverageRubricStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	^[ aNode inspect]! !

!CoverageRubricStyler methodsFor: 'styling' stamp: ''!
addIconStyle: aNode from: start to: stop
	|rejectClass|
	
	rejectClass := { RBMethodNode . RBSequenceNode }.
	(rejectClass includes: aNode class) ifTrue: [ ^self ]. "do nothing" 
	aNode hasBeenExecuted ifTrue: [  super addIconStyle: aNode from: start to: stop]! !

!CoverageRubricStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode
	^ 'Metalink'! !

!CoverageRubricStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^aNode hasMetalink! !

!CoverageRubricStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #arrowUpIcon.! !

!CriticBrowser commentStamp: ''!
I display code critics, the results obtained when running a lint rule.

Example: 


| rule env |
rule :=  RBExcessiveArgumentsRule new.
env := (RBPackageEnvironment packageName: 'Manifest-Core').

(CriticBrowser openOnRule: rule onEnvironment: env).!
!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
handleMethodRemoved: anAnnouncement

	self methodRemoved: anAnnouncement methodRemoved
! !

!CriticBrowser methodsFor: 'user interface' stamp: ''!
addModelItemsToWindowMenu: aMenu
	"Add model-related items to the window menu"

	aMenu
		addLine;
		add: 'Clean all manifest' target: checker selector: #cleanAllManifest;
		add: 'Reapply all  rules' target: self selector: #reapplyAllRules! !

!CriticBrowser methodsFor: 'private' stamp: ''!
reapplyRule: aRule

	cache removeRule: aRule.
	checker resetResult.
	rbEnvironment packages do: [ :package | 
		checker runRules: { aRule } onPackage: package withoutTestCase: removeTestCase ]. 
	(checker criticsOf: aRule) do:	[ :crit |
		cache addCritic: crit forRule: aRule ].
	(checker falsePositiveOf: aRule) do:	[ :crit |
		cache addFalsePositive: crit forRule: aRule ].
	(checker toDoOf: aRule) do:	[ :crit |
		cache addToDo: crit forRule: aRule ].	
	
	cache updateBrowser! !

!CriticBrowser methodsFor: 'api' stamp: ''!
setTitle: aTitle

	title := aTitle.
	
	self window updateTitle 
	! !

!CriticBrowser methodsFor: 'accessing' stamp: ''!
environment
	^ rbEnvironment
! !

!CriticBrowser methodsFor: 'initialization' stamp: ''!
setActionResetButton
	
	^ [(UIManager default confirm: 'Do you want to delete the current configuration
 and create a new configuration ?')
		ifTrue: [ self delete. 
				SelectPackageBrowser open ]]! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
handleMethodModified: anAnnouncement

	self
		methodRemoved: anAnnouncement oldMethod;
		methodAdded: anAnnouncement newMethod
	
! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
methodAdded: aMethod

	| rules |

	(rbEnvironment includesMethod: aMethod) ifFalse: [ ^ self ].

	rules := self allRules.
	checker
		resetResult;
		getCritiquesAbout: aMethod by: (rules select: [ :r | r class checksMethod ]).

	rules do: [ :rule |		
		(checker criticsOf: rule) do:	[ :crit |
			cache addCritic: crit forRule: rule ].
		(checker falsePositiveOf: rule) do:	[ :crit |
			cache addFalsePositive: crit forRule: rule ].
		(checker toDoOf: rule) do:	[ :crit |
			cache addToDo: crit forRule: rule ] ].
	
	cache updateBrowser.! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
handleClassRemoved: anAnnouncement

	self classRemoved: anAnnouncement classRemoved
! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
unregisterFromAnnouncements

	SystemAnnouncer uniqueInstance unsubscribe: self! !

!CriticBrowser methodsFor: 'private' stamp: ''!
browseRule

	rulesModel selectedItem ifNotNil: [ :item | item content browse ]! !

!CriticBrowser methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	cache := CriticsCache new.
	checker := ReSmalllintChecker new.
	cache checker: checker.
	cache browser: self.
	criticModel cache: cache! !

!CriticBrowser methodsFor: 'api' stamp: ''!
initialExtent

	^ 760@370! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
registerToAnnouncements
	
	self unregisterFromAnnouncements.
	
	SystemAnnouncer uniqueInstance weak
		when: ClassAdded send: #handleClassAdded: to: self;
		when: ClassModifiedClassDefinition send: #handleClassModified: to: self;
		when: ClassRemoved send: #handleClassRemoved: to: self;
		when: MethodAdded send: #handleMethodAdded: to: self;
		when: MethodModified send: #handleMethodModified: to: self;
		when: MethodRemoved send: #handleMethodRemoved: to: self.
	self window window announcer when: WindowClosed send: #onWindowClosed to: self! !

!CriticBrowser methodsFor: 'initialization' stamp: ''!
setActionUpdateButton
	^ [ self reapplyAllRules ]! !

!CriticBrowser methodsFor: 'accessing' stamp: ''!
rulesModel

	^ rulesModel! !

!CriticBrowser methodsFor: 'initialization' stamp: ''!
setUpdateButton

	updateButton 
		state: false;
		label: 'Update';
		action: self setActionUpdateButton.! !

!CriticBrowser methodsFor: 'accessing' stamp: ''!
updateButton
	^ updateButton ! !

!CriticBrowser methodsFor: 'api' stamp: ''!
defaultTitle

	^ 'Critic Browser'! !

!CriticBrowser methodsFor: 'accessing' stamp: ''!
logButton
	^ logButton ! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
handleClassAdded: anAnnouncement

	self classAdded: anAnnouncement classAdded
! !

!CriticBrowser methodsFor: 'initialization' stamp: ''!
setResetButton

	resetButton 
		state: false;
		label: 'Run new configuration';
		action: self setActionResetButton! !

!CriticBrowser methodsFor: 'initialization' stamp: ''!
setLogButton

	logButton 
		state: false;
		label: 'Save Critics';
		action: self setActionLogButton ! !

!CriticBrowser methodsFor: 'accessing' stamp: ''!
resetButton
	^ resetButton ! !

!CriticBrowser methodsFor: 'api' stamp: ''!
onWindowClosed

	self unregisterFromAnnouncements.

	cache cacheChange 
		ifTrue: [	
			(UIManager default confirm: 'Do you want log all wrong violations in the Manifests
before closing the Critics Browser ?')
				ifTrue: [ cache logInManifest ]].
	
! !

!CriticBrowser methodsFor: 'accessing' stamp: ''!
environment: aEnv
	rbEnvironment := aEnv
! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
handleClassModified: anAnnouncement

	self
		classRemoved: anAnnouncement oldClassDefinition;
		classAdded: anAnnouncement newClassDefinition
	! !

!CriticBrowser methodsFor: 'initialization' stamp: ''!
initializeWidgets
	
	title := self defaultTitle.
	rulesModel := self newTree.
	resetButton := self newButton.
	updateButton := self newButton.
	logButton := self newButton.
	
	self setLogButton.
	self setResetButton.
	self setUpdateButton.
	 
	criticModel := SingleCodeCriticResultList new.
	rulesModel childrenBlock: [ :rule | 
		rule isComposite 
			ifTrue: [ rule rules ]
			ifFalse: [ #() ]]. 

	rulesModel displayBlock: [ :rule | self stringMorphForRule: rule ].
	
	rulesModel menu: [ :aMenu :shifted | self menu: aMenu shifted: shifted ].	
	
	self focusOrder
		add: rulesModel;
		add: criticModel! !

!CriticBrowser methodsFor: 'display' stamp: ''!
open

	^ self openWithSpec! !

!CriticBrowser methodsFor: 'private' stamp: ''!
colorForRule: aRule
	| total |
	^ (total := cache criticsOf: aRule)
		ifEmpty: [ self class theme textColor ]
		ifNotEmpty: [ (cache falsePositiveOf: aRule) = total
				ifTrue: [ criticModel falsePositiveColor ]
				ifFalse: [ criticModel defaultColor ]]! !

!CriticBrowser methodsFor: 'private' stamp: ''!
removeRuleToFalsePositive

	rulesModel selectedItem ifNotNil: [ :rule |
		rule leaves do: [ :r |
			rbEnvironment packages do: [ :package |
				 cache removeFalsePositiveRule: r forPackage: package ]]]

	
	! !

!CriticBrowser methodsFor: 'accessing' stamp: ''!
rules: rulesCollection

	self rulesModel roots: ((
		(rulesCollection groupedBy: #group) associations collect: [ :as |
			CriticBrowserRulesGroup
				named: as key
				rules: as value ])
					sorted: [ :a :b | a name < b name ])! !

!CriticBrowser methodsFor: 'private' stamp: ''!
stringMorphForRule: rule
	| unclassified falsePositives toDos text total |
	falsePositives := (cache falsePositiveOf: rule) size.
	toDos := (cache toDosOf: rule) size.
	total := (cache criticsOf: rule) size.
	unclassified := total - falsePositives - toDos.
	text := String
		streamContents: [ :s | 
			s
				<< rule name;
				<< ' (To sort: ';
				print: unclassified;
				<< ', ToDo: ';
				print: toDos;
				<< ', Wrong: ';
				print: falsePositives;
				<< ')' ].
	^ text asMorph
		color: (self colorForRule: rule);
		yourself
		! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
classAdded: aClass

	| rules |

	(rbEnvironment definesClass: aClass) ifFalse: [ ^ self ].

	rules := self allRules.
	checker
		resetResult;
		checkClass: aClass.
		
	rules do: [ :rule |		
		(checker criticsOf: rule) do:	[ :crit |
			cache addCritic: crit forRule: rule ].
		(checker falsePositiveOf: rule) do:	[ :crit |
			cache addFalsePositive: crit forRule: rule ].
		(checker toDoOf: rule) do:	[ :crit |
			cache addToDo: crit forRule: rule ] ].
	
	cache updateBrowser.! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
handleMethodAdded: anAnnouncement

	self methodAdded: anAnnouncement methodAdded
! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
classRemoved: aClass

	(rbEnvironment definesClass: aClass)
		ifTrue: [ cache itemRemoved: aClass ].
		
	cache updateBrowser! !

!CriticBrowser methodsFor: 'thread' stamp: ''!
updateTree
	criticModel updateList. 
	rulesModel updateTree! !

!CriticBrowser methodsFor: 'api' stamp: ''!
title
	^ title! !

!CriticBrowser methodsFor: 'private' stamp: ''!
reapplyThisRule

	| rule |
	rulesModel selectedItem ifNil: [ ^ self ].
	rule := rulesModel selectedItem content.
	rule isComposite 
		ifTrue: [ rule rules do: [ :each | self reapplyRule: each ] ]
		ifFalse: [ self reapplyRule: rule ]
	
! !

!CriticBrowser methodsFor: 'private' stamp: ''!
addRuleToFalsePositive
	rulesModel selectedItem ifNotNil: [ :rule |
		rule leaves do: [ :r |
			rbEnvironment packages do: [ :package |
				cache addFalsePositiveRule: r forPackage: package ]]].
	! !

!CriticBrowser methodsFor: 'private' stamp: ''!
allRules
	^ rulesModel roots flatCollect: #rules! !

!CriticBrowser methodsFor: 'private' stamp: ''!
logInManifest
	cache logInManifest! !

!CriticBrowser methodsFor: 'initialization' stamp: ''!
setActionLogButton
	^ [ (UIManager default
		confirm:
			'Do you want to save all false positive and toDo in the Manifests ?
(this action may generate new manifest classes and make dirty your package)')
		ifTrue: [ cache logInManifest ] ]! !

!CriticBrowser methodsFor: 'menu' stamp: ''!
menu: aMenu shifted: aBoolean
	aMenu
		addGroup:[ :group | 
			group addItem: [ :item |
				item 
					name: 'Browse rule' translated;
					action: [ self browseRule ]].
			group addItem: [ :item |
				item 
					name: 'Reapply this rule' translated;
					action: [ self reapplyThisRule ] ] ];
		addGroup:[ :group | 
			group addItem: [ :item |
				item 
					name: 'Ban from selected packages' translated;
					action: [ self addRuleToFalsePositive ]].
			group addItem: [ :item |
				item 
					name: 'Unban from selected packages' translated;
					action: [ self removeRuleToFalsePositive ] ] ].
		
	 ^ aMenu! !

!CriticBrowser methodsFor: 'private' stamp: ''!
reapplyAllRules
	
	cache initialize.
	self applyRules ! !

!CriticBrowser methodsFor: 'system annoucements' stamp: ''!
methodRemoved: aMethod

	(rbEnvironment includesMethod: aMethod)
		ifTrue: [ cache itemRemoved: aMethod ].
		
	cache updateBrowser! !

!CriticBrowser methodsFor: 'accessing' stamp: ''!
removeTestCase: aBoolean
	removeTestCase :=  aBoolean! !

!CriticBrowser methodsFor: 'private' stamp: ''!
applyRules
	| packageCount nbPackage process rules |
	rules := self allRules.
	nbPackage := rbEnvironment packages size.
	packageCount := 0.
	self updateTree.
	process := [ rbEnvironment packages
		do: [ :package | 
			| windowTitle |
			packageCount := packageCount + 1.
			windowTitle := String
				streamContents: [ :s | 
					s << 'run rules on ' << package packageName << ' ('
						<< packageCount asString << '/' << nbPackage asString << ')' ].
			self setTitle: windowTitle.
			checker
				runRules: rules
				onPackage: package
				withoutTestCase: removeTestCase ].
	checker rule: rules.
	self setTitle: self defaultTitle.
	cache packages: rbEnvironment.
	cache initCache.
	self updateTree.
	self registerToAnnouncements ] newProcess.
	process name: 'SmallLint'.
	process resume! !

!CriticBrowser methodsFor: 'accessing' stamp: ''!
criticModel
	^ criticModel! !

!CriticBrowser methodsFor: 'initialization' stamp: ''!
initializePresenter
	rulesModel
		whenSelectedItemChanged: [ :rule | 
			(rule isNil or: [ rule isComposite ])
				ifFalse: [ criticModel
						resetSelection;
						rule: rule;
						setTextModelForNil ].
			self setTitle: (rule ifNil: [ self defaultTitle ] ifNotNil: [ rule name ]) ]! !

!CriticBrowser class methodsFor: 'instance creation' stamp: ''!
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: 'icons' stamp: ''!
taskbarIconName

	^#smallWarningIcon! !

!CriticBrowser class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	
	| env rules |
	rules :=  RBCompositeLintRule allGoodRules rules.
	env := RBBrowserEnvironment default.
	self openOnRule: rules onEnvironment: env! !

!CriticBrowser class methodsFor: 'menu' stamp: ''!
openOnCurrentWorkingConfiguration
	<script>
	
	CriticWorkingConfiguration exists
		ifTrue: [ ResetWindow new openWithSpec ]
		ifFalse: [ SelectPackageBrowser open]! !

!CriticBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ SpecLayout composed 
		newColumn: [:c |
			c 
				newRow: [:r |
					r 
						newColumn: [:c1 |
							c1 add: #rulesModel.
							c1 newRow: [:c2 |
								c2 add: #resetButton.
								c2 add: #updateButton.
								c2 add: #logButton
							] height: 25
						];
						newColumn: [:c1 |
							c1 
								add: #(criticModel textInputFieldModel) height: 20;
								add: #(criticModel criticsModel);
								add: #(criticModel toolbarModel) height: 25 ]];
				addSplitter;
				add: #(criticModel textModel) ]! !

!CriticBrowser class methodsFor: 'icons' stamp: ''!
icon
	"Answer an icon for the receiver."

	^ self iconNamed: #smallWarningIcon! !

!CriticBrowser class methodsFor: 'menu' stamp: ''!
criticsBrowserMenuOn: aBuilder 
	<worldMenu>
	
	(aBuilder item: 'Critic Browser')
		action: [ self openOnCurrentWorkingConfiguration];
		order: 2;
		parent: #Browsing;
		help: 'To manage rule checks.';
		icon: self icon! !

!CriticBrowser class methodsFor: 'instance creation' stamp: ''!
openOnWorkingConfiguration: aWorkingConfiguration

	| cbr |
	cbr := self new 
		rules: aWorkingConfiguration rule;
		environment: aWorkingConfiguration environment;
		removeTestCase: aWorkingConfiguration removeTestCase;
		yourself.

	cbr openWithSpec.
	cbr applyRules. 
	cbr rulesModel  changed:  #listElementAt:! !

!CriticBrowserRulesGroup commentStamp: ''!
I represent a group of rules in CriticBrowser tree view!
!CriticBrowserRulesGroup methodsFor: 'accessing' stamp: ''!
rules: anObject
	rules := anObject! !

!CriticBrowserRulesGroup methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!CriticBrowserRulesGroup methodsFor: 'enumerating' stamp: ''!
do: aBlock

	rules do: aBlock! !

!CriticBrowserRulesGroup methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!CriticBrowserRulesGroup methodsFor: 'testing' stamp: ''!
isComposite

	^ true! !

!CriticBrowserRulesGroup methodsFor: 'accessing' stamp: ''!
rules
	^ rules! !

!CriticBrowserRulesGroup class methodsFor: 'instance creation' stamp: ''!
named: aString rules: aCollection

	^ self new
		name: aString;
		rules: aCollection;
		yourself! !

!CriticToolbar commentStamp: ''!
I am the toolbar for a selected SmallLint Critic in the critic browser.


Instance Variables
	browseModel:		<Object>
	criticHolder:		<Object>
	falsepositiveModel:		<Object>
	ruleHolder:		<Object>
	transformModel:		<Object>

browseModel
	- xxxxx

criticHolder
	- xxxxx

falsepositiveModel
	- xxxxx

ruleHolder
	- xxxxx

transformModel
	- xxxxx
!
!CriticToolbar methodsFor: 'initialization' stamp: ''!
whenFalsePositiveClickedDo: aBlock

	self falsepositiveModel whenActionPerformedDo: aBlock! !

!CriticToolbar methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	criticHolder := nil asValueHolder.
	ruleHolder := nil asValueHolder.
	browseModel := self instantiate: ButtonPresenter.
	transformModel := self instantiate: ButtonPresenter.
	falsepositiveModel := self instantiate: ButtonPresenter.
	self setFocusOrder.	
	self setBrowseModel.
	self setTransformModel.
	self setFalsepositiveModel.
	self registerForChanges! !

!CriticToolbar methodsFor: 'initialization' stamp: ''!
setTransformModel
	
	transformModel
		state: false;
		label: 'Transform';
		action: [ self transformCritic ]
	
! !

!CriticToolbar methodsFor: 'initialization' stamp: ''!
initializeWidgets! !

!CriticToolbar methodsFor: 'accessing' stamp: ''!
falsepositiveModel

	^ falsepositiveModel! !

!CriticToolbar methodsFor: 'initialization' stamp: ''!
setFocusOrder

	self focusOrder
		add: browseModel;
		add: transformModel;
		add: falsepositiveModel
		! !

!CriticToolbar methodsFor: 'private' stamp: ''!
browseCritic

	criticHolder value ifNotNil: [ :elem | elem sourceAnchor entity browse ] ! !

!CriticToolbar methodsFor: 'initialization' stamp: ''!
registerForChanges

	criticHolder whenChangedDo: [ :contents |
		| boolean |
		boolean := contents notNil.
		browseModel state: (boolean and: [ browseModel enabled ]).
		transformModel state: (boolean and: [ transformModel enabled ]).
		falsepositiveModel state: (boolean and: [ falsepositiveModel enabled ]) 
		]
! !

!CriticToolbar methodsFor: 'initialization' stamp: ''!
setFalsepositiveModel
	
	falsepositiveModel
		state: false;
		label: 'Mark as wrong';
		action: [  ]
	
! !

!CriticToolbar methodsFor: 'accessing' stamp: ''!
transformModel

	^ transformModel! !

!CriticToolbar methodsFor: 'api' stamp: ''!
critic: aCritic

	criticHolder value: aCritic.
	transformModel enabled: (aCritic isNotNil and: [ aCritic providesChange ])! !

!CriticToolbar methodsFor: 'initialization' stamp: ''!
setBrowseModel
	
	browseModel
		state: false;
		label: 'Browse';
		action: [ self browseCritic ]
	
! !

!CriticToolbar methodsFor: 'accessing' stamp: ''!
browseModel

	^ browseModel! !

!CriticToolbar methodsFor: 'api' stamp: ''!
rule: aRule
	
	ruleHolder value: aRule. 
	
! !

!CriticToolbar methodsFor: 'private' stamp: ''!
transformCritic
	 criticHolder value
		ifNotNil: [:critic | critic change execute ]
	
! !

!CriticToolbar class methodsFor: 'specs' stamp: ''!
defaultSpec
<spec>

	^SpecLayout composed
		newRow: [:row |
			row 
				add: #browseModel;
				add: #transformModel;
				add: #falsepositiveModel
			]  height: 25! !

!CriticWorkingConfiguration commentStamp: ''!
A CriticWorkspace holds the current worspace for the CriticBrowser.

It's composed of the set of rules to check (as a composite rule) and the environment to work in.!
!CriticWorkingConfiguration methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!CriticWorkingConfiguration methodsFor: 'accessing' stamp: ''!
logInManifest
	^ logInManifest! !

!CriticWorkingConfiguration methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!CriticWorkingConfiguration methodsFor: 'accessing' stamp: ''!
logInManifest: anObject
	logInManifest := anObject! !

!CriticWorkingConfiguration methodsFor: 'accessing' stamp: ''!
rule
	^ rule! !

!CriticWorkingConfiguration methodsFor: 'accessing' stamp: ''!
removeTestCase: aBoolean
	removeTestCase := aBoolean! !

!CriticWorkingConfiguration methodsFor: 'accessing' stamp: ''!
removeTestCase
	^ removeTestCase! !

!CriticWorkingConfiguration methodsFor: 'accessing' stamp: ''!
rule: anObject
	rule := anObject! !

!CriticWorkingConfiguration class methodsFor: 'testing' stamp: ''!
exists

	^ Current notNil! !

!CriticWorkingConfiguration class methodsFor: 'instance creation' stamp: ''!
new

	^ self shouldNotImplement! !

!CriticWorkingConfiguration class methodsFor: 'instance creation' stamp: ''!
current

	^ Current ifNil: [ Current  := self basicNew initialize ].! !

!CriticWorkingConfiguration class methodsFor: 'class initialization' stamp: ''!
reset

	Current := nil! !

!CriticsCache commentStamp: ''!
I am a cache for the critics and false positives critics

Instance Variables
	browser:		<Object>
	checker:		<Object>
	critics:		<Object>
	falsePositiveClasses:		<Object>
	falsePositiveRules:		<Object>
	falsePositives:		<Object>
	packages:		<Object>
	toDos:		<Object>

browser
	- xxxxx

checker
	- xxxxx

critics
	- xxxxx

falsePositiveClasses
	- xxxxx

falsePositiveRules
	- xxxxx

falsePositives
	- xxxxx

packages
	- xxxxx

toDos
	- xxxxx
!
!CriticsCache methodsFor: 'add/remove' stamp: ''!
addFalsePositiveRule: aRule forPackage: aPackage
	
	| fp |
	(falsePositiveRules includesKey: aPackage) 
		ifFalse: [ falsePositiveRules at: aPackage put: Set new ].
	(falsePositiveRules at: aPackage) add: (aRule class uniqueIdentifierName). 
	fp := (critics at: aRule ifAbsent: [^ self])
				select: [ :c |  (self packageOf: c) package name = aPackage packageName ].	
	fp do: [ :c | self addFalsePositive: c forRule: aRule ]! !

!CriticsCache methodsFor: 'private' stamp: ''!
builderManifestClass
	^ TheManifestBuilder! !

!CriticsCache methodsFor: 'add/remove' stamp: ''!
removeFalsePositive: aCritic forRule: aRule

	(falsePositives includesKey: aRule) 
		ifFalse: [^ self ].
	[ (falsePositiveClasses includes: aCritic sourceAnchor entity criticTheNonMetaclassClass) 
			ifTrue: [^ self] ]
		on: MessageNotUnderstood 
		do: [ ^ self "#criticTheNonMetaclassClass makes no sense on a Package, ignore"].
	(falsePositives at: aRule) remove: aCritic ifAbsent: [^ self].
	self updateBrowser! !

!CriticsCache methodsFor: 'add/remove' stamp: ''!
removeRule: aRule

	{ critics . toDos . falsePositives } do: [ :ruleDict |
		ruleDict removeKey: aRule ]! !

!CriticsCache methodsFor: 'private' stamp: ''!
addAllCriticToFalsePositive: aCollectionOfCritic forRule: aRule on: aManifestBuilder

	| ruleId versionId  criticss |
	criticss := aCollectionOfCritic 
						reject: [ :c | falsePositiveClasses includes: c criticTheNonMetaclassClass ].
	ruleId := aRule class uniqueIdentifierName.
	versionId := aRule class identifierMinorVersionNumber.
	(aManifestBuilder hasFalsePositiveOf: ruleId version: versionId) 
		ifFalse: [ aManifestBuilder installFalsePositiveOf: ruleId version: versionId ].		
	 aManifestBuilder addAllFalsePositive: criticss of: ruleId version: versionId

	! !

!CriticsCache methodsFor: 'add/remove' stamp: ''!
addFalsePositiveClass: aClass 
	
	| fp |
	falsePositiveClasses add: aClass instanceSide. 
	critics keysAndValuesDo: [ :rule :criticss |
		fp := criticss select: [ :critic | aClass = critic criticTheNonMetaclassClass ].
		fp do: [ :each | self addFalsePositive: each forRule: rule] ].
	self updateBrowser	
! !

!CriticsCache methodsFor: 'testing' stamp: ''!
isToDo: aCritic forRule: aRule
	^ (self toDosOf: aRule) includes: aCritic! !

!CriticsCache methodsFor: 'protocol' stamp: ''!
criticsOf: aRule

	aRule ifNil: [ ^ {} ].	
	^ aRule isComposite
		ifTrue: [ aRule rules flatCollect: [ :rule | self criticsOf: rule ]]
		ifFalse: [ critics at: aRule ifAbsent: [ {} ]]! !

!CriticsCache methodsFor: 'protocol' stamp: ''!
falsePositiveOf: aRule
	
	aRule ifNil: [ ^ {}].
	^ aRule isComposite
		ifTrue: [ aRule rules flatCollect: [ :rule | self falsePositiveOf: rule ]]
		ifFalse: [ falsePositives at: aRule ifAbsent: [ {} ]]
	
	! !

!CriticsCache methodsFor: 'private' stamp: ''!
logFalsePositiveInManifest
	| removeFp addFp |
	falsePositives
		keysAndValuesDo: [ :rule :criticss | 
			removeFp := (checker falsePositiveOf: rule) \ criticss.
			removeFp := removeFp collect: [ :c | c sourceAnchor entity ].
			addFp := criticss \ (checker falsePositiveOf: rule).
			addFp := addFp collect: [ :c | c sourceAnchor entity ].			
			(removeFp groupedBy: [ :each | self builderManifestClass of: each ])
				keysAndValuesDo: [ :manifestBuilder :value | self removeAllCriticToFalsePositive: value forRule: rule on: manifestBuilder ].
			(addFp groupedBy: [ :each | self builderManifestClass of: each ])
				keysAndValuesDo: [ :manifestBuilder :value | 
					(manifestBuilder rejectRules includes: rule class uniqueIdentifierName)
						ifFalse: [ self addAllCriticToFalsePositive: value forRule: rule on: manifestBuilder ] ] ]! !

!CriticsCache methodsFor: 'accessing' stamp: ''!
cacheChange
	^ change! !

!CriticsCache methodsFor: 'private' stamp: ''!
logToDosInManifest
	| removeFp addFp |
	toDos
		keysAndValuesDo: [ :rule :criticss | 
			removeFp := (checker toDoOf: rule) \ criticss.
			removeFp := removeFp collect: [ :c | c sourceAnchor entity ].
			addFp := criticss \ (checker toDoOf: rule).
			addFp := addFp collect: [ :c | c sourceAnchor entity ].	
			(removeFp groupedBy: [ :each | self builderManifestClass of: each ])
				keysAndValuesDo: [ :manifestBuilder :value | self removeAllCriticToToDo: value forRule: rule on: manifestBuilder ].
			(addFp groupedBy: [ :each | self builderManifestClass of: each ])
				keysAndValuesDo: [ :manifestBuilder :value | 
					(manifestBuilder rejectRules includes: rule class uniqueIdentifierName)
						ifFalse: [ self addAllCriticToToDo: value forRule: rule on: manifestBuilder ] ] ]! !

!CriticsCache methodsFor: 'private' stamp: ''!
logFalsePositiveClassInManifest
	| manifestBuilder |
	packages
		do: [ :package | 
			manifestBuilder := self builderManifestClass ofPackageNamed: package packageName.
			manifestBuilder rejectClasses \ falsePositiveClasses do: [ :cl | manifestBuilder removeRejectClass: cl ].
			falsePositiveClasses \ manifestBuilder rejectClasses do: [ :cl | manifestBuilder addRejectClass: cl ] ]! !

!CriticsCache methodsFor: 'protocol' stamp: ''!
replaceAll: oldMethod by: newMethod

	critics valuesDo: [:each |  
		(each includes: oldMethod)
			ifTrue: [
				each remove: oldMethod.
				each add: newMethod ]].
		
	falsePositives valuesDo: [:each |  
		(each includes: oldMethod)
			ifTrue: [
				each remove: oldMethod.
				each add: newMethod ]].

	toDos valuesDo: [:each |  
		(each includes: oldMethod)
			ifTrue: [
				each remove: oldMethod.
				each add: newMethod ]]
	! !

!CriticsCache methodsFor: 'accessing' stamp: ''!
packages: aPackageEnv
	
	packages := aPackageEnv packages! !

!CriticsCache methodsFor: 'add/remove' stamp: ''!
itemRemoved: anItem

	{ critics . toDos . falsePositives } do: [ :ruleDict |
		ruleDict valuesDo: [ :crits |
			crits removeAllSuchThat: [ :crit |
				crit sourceAnchor entity = anItem ]]]
	! !

!CriticsCache methodsFor: 'protocol' stamp: ''!
toDosOf: aRule

	aRule ifNil: [ ^{} ].
	^ aRule isComposite
		ifTrue: [ aRule rules flatCollect: [:rule | self toDosOf: rule ]]
		ifFalse: [toDos at: aRule ifAbsent: [ {} ]]! !

!CriticsCache methodsFor: 'private' stamp: ''!
logFalsePositiveRulesInManifest
	| manifestBuilder |
	falsePositiveRules
		keysAndValuesDo: [:package :rules | 
			manifestBuilder := self builderManifestClass ofPackageNamed: package packageName.
			manifestBuilder rejectRules \ rules do: [ :rule | manifestBuilder removeRejectRule: rule ].
			rules \ manifestBuilder rejectRules do: [ :rule | manifestBuilder addRejectRule: rule ]]! !

!CriticsCache methodsFor: 'private' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	
	super initialize.
	falsePositives := Dictionary new.
	toDos := Dictionary new.	
	critics := Dictionary new.	
	falsePositiveRules := Dictionary new.
	falsePositiveClasses := IdentitySet new.
	change := false	
! !

!CriticsCache methodsFor: 'private' stamp: ''!
cacheChanged 
	change := true! !

!CriticsCache methodsFor: 'private' stamp: ''!
cacheNotChanged 
	change := false! !

!CriticsCache methodsFor: 'protocol' stamp: ''!
logInManifest

	self cacheChange 
		ifFalse: [^ self].
	self logFalsePositiveRulesInManifest.
	self logFalsePositiveClassInManifest.
	self logFalsePositiveInManifest.
	self logToDosInManifest.
	self cacheNotChanged. 		
	self initCache
	! !

!CriticsCache methodsFor: 'private' stamp: ''!
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: ''!
addAllCriticToToDo: aCollectionOfCritic forRule: aRule on: aManifestBuilder

	| ruleId versionId  |
	ruleId := aRule class uniqueIdentifierName.
	versionId := aRule class identifierMinorVersionNumber.
	(aManifestBuilder hasToDoOf: ruleId version: versionId) 
		ifFalse: [ aManifestBuilder installToDoOf: ruleId version: versionId ].		
	 aManifestBuilder addAllToDo: aCollectionOfCritic of: ruleId version: versionId

	! !

!CriticsCache methodsFor: 'add/remove' stamp: ''!
removeCritic: aCritic forRule: aRule

	(critics includesKey: aRule) 
		ifFalse: [^ self].
	(critics at: aRule) remove: aCritic ifAbsent: [^ self].
	self updateBrowser
	! !

!CriticsCache methodsFor: 'initialization' stamp: ''!
initCache


	checker rule 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: (checker criticsOf: rule)) 
	].
	packages do: [ :package |	
		falsePositiveRules at: package put: (checker rejectRulesOf: package) asSet.
		falsePositiveClasses addAll: (checker rejectClassesOf: package) asIdentitySet.
	]! !

!CriticsCache methodsFor: 'add/remove' stamp: ''!
removeFalsePositiveRule: aRule forPackage: aPackage
	| fp |
	
	(falsePositiveRules includesKey: aPackage) 
		ifFalse: [^ self].
	
	(falsePositiveRules at:aPackage) remove: (aRule class uniqueIdentifierName) ifAbsent: [^ self]. 

	fp := (critics at: aRule ifAbsent: [^ self])
		select: [:c | ((self packageOf: c) package name) = (aPackage packageName) and: [
						(falsePositiveClasses includes: c criticTheNonMetaclassClass) not]].			
	fp do: [:c | self removeFalsePositive: c forRule: aRule]. 
	
	self updateBrowser ! !

!CriticsCache methodsFor: 'add/remove' stamp: ''!
removeToDo: aCritic forRule: aRule

	(toDos includesKey: aRule) 
		ifFalse: [^ self].
			
	(toDos at:aRule) remove: aCritic ifAbsent: [^ self].
	self updateBrowser
	! !

!CriticsCache methodsFor: 'testing' stamp: ''!
isFalsePositive: aCritic forRule: aRule
	^ (self falsePositiveOf: aRule) includes: aCritic! !

!CriticsCache methodsFor: 'private' stamp: ''!
updateBrowser

	self cacheChanged.
	browser updateTree ! !

!CriticsCache methodsFor: 'accessing' stamp: ''!
checker: aSmallLintChercker
	checker := aSmallLintChercker! !

!CriticsCache methodsFor: 'add/remove' stamp: ''!
removeFalsePositiveClass: aClass
	
	| fp |
	falsePositiveClasses remove: aClass ifAbsent: [^ self]. 
	critics keysAndValuesDo: [ :rule :criticss |
		fp := criticss select: [ :critic | aClass = critic criticTheNonMetaclassClass].
		fp do: [ :each | self removeFalsePositive: each forRule: rule ]]! !

!CriticsCache methodsFor: 'add/remove' stamp: ''!
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: ''!
addToDo: aCritic forRule: aRule

	(toDos includesKey: aRule) 
		ifFalse: [ toDos at:aRule put: IdentitySet new ].
	(toDos at: aRule) add: aCritic. 
	self updateBrowser! !

!CriticsCache methodsFor: 'private' stamp: ''!
packageOf: aCritc
	^ aCritc mcWorkingCopy ! !

!CriticsCache methodsFor: 'add/remove' stamp: ''!
addFalsePositive: aCritic forRule: aRule

	(falsePositives includesKey: aRule) 
		ifFalse: [ falsePositives at: aRule put: IdentitySet new ].
	(falsePositives at: aRule) add: aCritic. 
	self updateBrowser 	! !

!CriticsCache methodsFor: 'accessing' stamp: ''!
browser: aCodeCritiicBrowser
	browser := aCodeCritiicBrowser ! !

!Cubic commentStamp: ''!
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: ''!
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: ''!
bestSegments
	"Return the smallest integer number of segments that give the best curve."
	
	^ self honeIn: self calcEnoughSegments! !

!Cubic methodsFor: 'cubic support' stamp: ''!
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: ''!
leeway
	"How close can measure be"
	
	^ 0.1! !

!Cubic methodsFor: 'cubic support' stamp: ''!
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 distanceTo: p1).
			p1 := p2].
	^ measure! !

!Cubic methodsFor: 'cubic support' stamp: ''!
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: ''!
honeIn: enough 
	"Find if there is a smaller n than enough that give the same  
	measure for n."
	
	[enough isPowerOfTwo]  assert.
	enough < 2 ifTrue: [^ enough].
	^ self
		honeIn: enough
		step: enough // 2
		measure: (self measureFor: enough)
		withIn: self leeway! !

!Cubic class methodsFor: 'instance creation' stamp: ''!
with: pt1 with: pt2  with: pt3 with: pt4
	"a cubic object is composed of 4 points"
	
	^ self withAll: {pt1 . pt2 . pt3 . pt4}! !

!CurrentChangeSetChanged commentStamp: ''!
Announce that the current change set has changed!
!CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'nil'!
new
	^ new! !

!CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'nil'!
new: anObject
	new := anObject! !

!CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'nil'!
old
	^ old! !

!CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'nil'!
old: anObject
	old := anObject  ! !

!CurrentExecutionEnvironment commentStamp: ''!
I am container for special meta object ExecutionEnvironment which represent current execution environment for active process.

Look at ExecutionEnvironment for details!
!CurrentExecutionEnvironment methodsFor: 'accessing' stamp: ''!
default
	^DefaultExecutionEnvironment instance! !

!CurrentExecutionEnvironment methodsFor: 'inheriting' stamp: ''!
installValue: anExecutionEnvironment intoForked: newProcess from: ownerProcess
	super installValue: anExecutionEnvironment intoForked: newProcess from: ownerProcess.
	
	anExecutionEnvironment prepareForNewProcess: newProcess! !

!CurrentExecutionEnvironment class methodsFor: 'testing' stamp: ''!
isInheritable
	^true! !

!CurrentExecutionEnvironment class methodsFor: 'controlling' stamp: ''!
activate: anExecutionEnvironment for: aBlock

	| current |
	self value == anExecutionEnvironment ifTrue: [ ^aBlock value ].
	
	current := self soleInstance valueOrNil.	
	[ self value: anExecutionEnvironment.
	anExecutionEnvironment activated.
	aBlock value  ] ensure: [
		self value: current.
		anExecutionEnvironment deactivated]! !

!CurrentExecutionEnvironment class methodsFor: '*SUnit-Core' stamp: ''!
runTestCase: aTestCase

	self value runTestCase: aTestCase
! !

!CurrentExecutionEnvironment class methodsFor: 'controlling' stamp: ''!
restoreDefault

	| current |
	current := self value.
	current deactivated.
	self value: nil! !

!CurrentExecutionEnvironment class methodsFor: '*SUnit-Core' stamp: ''!
runTestsBy: aBlock

	self value runTestsBy: aBlock! !

!CurrentJob commentStamp: ''!
I am a DynamicVariable whose value is the current Job in a process.!
!CurrentSpecDefaultBindings commentStamp: ''!
Dynamic variable for Spec on which of the bindings (Morphic or other) should be used as default!
!Cursor commentStamp: ''!
Description
--------------------

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 "constants" category of class methods. For example, "Cursor normal" and "Cursor wait". 

Public API and Key Messages
--------------------

- #showWhile: 	When send to a cursor, it will use the cursor as the current cursor during the block execution

Examples
--------------------

	"Use the wait cursor for 3 seconds"
	Cursor wait showWhile: [ 3 second wait ].
	
	"Morph implements methods to help with the management of cursors via the hand morph. This is useful when you want to change the cursor and revert the change in different places instead of changinig it during the execution of a block."
	self currentHand showTemporaryCursor: Cursor wait. 
	self flag: #doSomethingHere.
	self currentHand showTemporaryCursor: nil. "Reset the cursor to the previous one"
!
!Cursor methodsFor: 'primitives' stamp: ''!
activateInCursorOwner: aCursorOwner

	^ self subclassResponsibility! !

!Cursor methodsFor: 'converting' stamp: ''!
withMask
	^CursorWithMask derivedFrom: self! !

!Cursor methodsFor: 'testing' stamp: ''!
hasMask
	^false! !

!Cursor methodsFor: 'primitives' stamp: ''!
scaledToSize: newExtent

	"We need to override, so we can scale also the offset."

	| newOne |
	newOne := super scaledToSize: newExtent.
	newOne offset: offset * (newExtent / self extent).
	^ newOne! !

!Cursor methodsFor: 'printing' stamp: ''!
printOn: aStream

	self storeOn: aStream base: 2! !

!Cursor methodsFor: 'displaying' stamp: ''!
show
	"Make the hardware's mouse cursor look like the receiver"
	self currentWorld activeHand ifNotNil: [:aHand | aHand currentCursor: self ]! !

!Cursor methodsFor: 'converting' stamp: ''!
asCursorForm
	| form |
	form := Form extent: self extent depth: 8.
	form fillShape: self fillColor: Color black at: offset negated.
	^ form offset: offset! !

!Cursor methodsFor: 'updating' stamp: ''!
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 flag: 'FIXME: Please, check on whether is this really needed'.
	
	"Removed for Morphic World specific cursor."
	"self == CurrentCursor ifTrue: [self beCursor]."
	super changed: aParameter! !

!Cursor methodsFor: 'displaying' stamp: ''!
showWhile: aBlock 
	"While evaluating the argument, aBlock, make the receiver be the cursor shape."
	| oldcursor |
	oldcursor := self currentWorld currentCursor.
	self show.
	^aBlock ensure: [oldcursor show]! !

!Cursor class methodsFor: 'instance creation' stamp: ''!
resizeForEdge: aSymbol
	"Cursor resizeForEdge: #top"
	"Cursor resizeForEdge: #bottomLeft"
	^self perform: ('resize', aSymbol first asString asUppercase, (aSymbol copyFrom: 2 to: aSymbol size)) asSymbol.! !

!Cursor class methodsFor: 'constants' stamp: ''!
topRight
	"Cursor topRight showWhile: [Sensor waitButton]"
	^ TopRightCursor! !

!Cursor class methodsFor: 'instance creation' stamp: ''!
new

	^ self extent: 16 @ 16
		fromArray: (Array new: 16 withAll: 0)
		offset: 0 @ 0! !

!Cursor class methodsFor: 'constants' stamp: ''!
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: 'initialization - private' stamp: ''!
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 - private' stamp: ''!
initResizeTopLeft

       ResizeTopLeftCursor :=
               (Cursor extent: 16 @ 16 fromArray: #(
               2r0000000000000000
               2r0111110000000000
               2r0111100000000000
               2r0111000000000000
               2r0110100000000000
               2r0100010000000000
               2r0000001000000000
               2r0000000100000000
               2r0000000010000000
               2r0000000001000100
               2r0000000000101100
               2r0000000000011100
               2r0000000000111100
               2r0000000001111100
               2r0000000000000000
               2r0000000000000000)
       offset: -7 @ -7) withMask! !

!Cursor class methodsFor: 'constants' stamp: ''!
square
	"Answer the instance of me that is the shape of a square."

	^SquareCursor! !

!Cursor class methodsFor: 'constants' stamp: ''!
resizeBottomLeft
	"Cursor resizeBottomLeft showWhile: [Sensor waitButton]"
	^self resizeTopRight! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
initRightArrow 

	RightArrowCursor  :=
		      (Cursor
	extent: 16@16
	fromArray: #(
		2r100000000000
		2r111000000000
		2r1111111110000000
		2r111000000000
		2r100000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
	
	"Cursor initRightArrow"! !

!Cursor class methodsFor: 'constants' stamp: ''!
move
	"Answer the instance of me that is the shape of a cross inside a square."

	^MoveCursor! !

!Cursor class methodsFor: 'constants' stamp: ''!
execute
	"Answer the instance of me that is the shape of an arrow slanted left 
	with a star next to it."

	^XeqCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
initOrigin

	OriginCursor :=   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000)
			offset: 0@0).! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
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 - private' stamp: ''!
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 - private' stamp: ''!
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: 'constants' stamp: ''!
up
	"Answer the instance of me that is the shape of an arrow facing upward."

	^UpCursor! !

!Cursor class methodsFor: 'constants' stamp: ''!
bottomLeft
	"Cursor bottomLeft showWhile: [Sensor waitButton]"
	^BottomLeftCursor! !

!Cursor class methodsFor: 'instance creation' stamp: ''!
extent: extentPoint fromArray: anArray offset: offsetPoint 
	"Answer a new instance of me with width and height specified by
	extentPoint, offset by offsetPoint, and bits from anArray.
	NOTE: This has been kluged to take an array of 16-bit constants,
	and shift them over so they are left-justified in a 32-bit bitmap"

	extentPoint = (16 @ 16)
		ifTrue: 
			[^ super
				extent: extentPoint
				fromArray: (anArray collect: [:bits | bits bitShift: 16])
				offset: offsetPoint]
		ifFalse: [self error: 'cursors must be 16@16']! !

!Cursor class methodsFor: 'constants' stamp: ''!
rightArrow 
	"Answer the instance of me that is the shape of an arrow pointing to the right."

	^RightArrowCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
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 - private' stamp: ''!
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: 'initialize-release' stamp: ''!
initialize
	self createStandardCursors.
	SessionManager default registerGuiClassNamed: self name.! !

!Cursor class methodsFor: 'constants' stamp: ''!
overEditableText
	^ OverEditableText! !

!Cursor class methodsFor: 'constants' stamp: ''!
resizeRight
	"Cursor resizeRight showWhile: [Sensor waitButton]"
	^self resizeLeft! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
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 - private' stamp: ''!
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: 'constants' stamp: ''!
resizeBottom
	"Cursor resizeBottom showWhile: [Sensor waitButton]"
	^self resizeTop! !

!Cursor class methodsFor: 'constants' stamp: ''!
menu 
	"Answer the instance of me that is the shape of a menu."

	^MenuCursor! !

!Cursor class methodsFor: 'constants' stamp: ''!
topLeft
	"Cursor topLeft showWhile: [Sensor waitButton]"
	^ TopLeftCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
initUp

	UpCursor := 
		    (Cursor
	extent: 16@16
	fromArray: #(
		2r11000000000000
		2r111100000000000
		2r1111110000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).! !

!Cursor class methodsFor: 'constants' stamp: ''!
write
	"Answer the instance of me that is the shape of a pen writing."

	^WriteCursor! !

!Cursor class methodsFor: 'constants' stamp: ''!
resizeTopRight
	"Cursor resizeTopRight showWhile: [Sensor waitButton]"
	^ResizeTopRightCursor! !

!Cursor class methodsFor: 'constants' stamp: ''!
marker
	"Answer the instance of me that is the shape of a small ball."

	^MarkerCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
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: 'constants' stamp: ''!
read
	"Answer the instance of me that is the shape of eyeglasses."

	^ReadCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
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 - private' stamp: ''!
initNormal

	NormalCursor :=   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1000000000000000
		2r1100000000000000
		2r1110000000000000
		2r1111000000000000
		2r1111100000000000
		2r1111110000000000
		2r1111111000000000
		2r1111100000000000
		2r1111100000000000
		2r1001100000000000
		2r0000110000000000
		2r0000110000000000
		2r0000011000000000
		2r0000011000000000
		2r0000001100000000
		2r0000001100000000)
	offset: 0@0).! !

!Cursor class methodsFor: 'constants' stamp: ''!
target
	"Answer the instance of me that is the shape of a gunsight."
	"Cursor target show"
	^TargetCursor ifNil:[self initTarget]! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
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 - private' stamp: ''!
initXeq

	XeqCursor := 
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1000000000010000
		2r1100000000010000
		2r1110000000111000
		2r1111000111111111
		2r1111100011000110
		2r1111110001000100
		2r1111111001111100
		2r1111000001101100
		2r1101100011000110
		2r1001100010000010
		2r0000110000000000
		2r0000110000000000
		2r0000011000000000
		2r0000011000000000
		2r0000001100000000
		2r0000001100000000)
	offset: 0@0).! !

!Cursor class methodsFor: 'constants' stamp: ''!
corner
	"Answer the instance of me that is the shape of the bottom right corner 
	of a rectangle."

	^CornerCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
initTopRight
	TopRightCursor := 
		(Cursor extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011)
			offset: -16@0).! !

!Cursor class methodsFor: 'constants' stamp: ''!
bottomRight
	"Cursor bottomRight showWhile: [Sensor waitButton]"
	^BottomRightCursor! !

!Cursor class methodsFor: 'constants' stamp: ''!
origin
	"Answer the instance of me that is the shape of the top left corner of a 
	rectangle."

	^OriginCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
initBottomLeft

	BottomLeftCursor := 
		(Cursor extent: 16 @ 16
			fromArray: #(
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1111111111111111
		2r1111111111111111)
			offset: 0 @ -16).! !

!Cursor class methodsFor: 'constants' stamp: ''!
normal
	"Answer the instance of me that is the shape of an arrow slanted left."

	^NormalCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
initRead

	ReadCursor :=  
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0000000000000000
		2r0000000000000000
		2r0001000000001000
		2r0010100000010100
		2r0100000000100000
		2r1111101111100000
		2r1000010000100000
		2r1000010000100000
		2r1011010110100000
		2r0111101111000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).! !

!Cursor class methodsFor: 'constants' stamp: ''!
resizeTop
	"Cursor resizeTop showWhile: [Sensor waitButton]"
	^ResizeTopCursor! !

!Cursor class methodsFor: 'constants' stamp: ''!
webLink
	"Return a cursor that can be used for emphasizing web links"
	"Cursor webLink showWhile: [Sensor waitButton]"
	^WebLinkCursor ifNil:[
		WebLinkCursor :=  (CursorWithMask extent: 16@16
			fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 )
			offset: -5@0) setMaskForm:
		(Form extent: 16@16 
			fromArray: (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 )  collect: [:bits | bits bitShift: 16])
			offset: 0@0)].! !

!Cursor class methodsFor: 'constants' stamp: ''!
down
	"Answer the instance of me that is the shape of an arrow facing 
	downward."

	^DownCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
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 - private' stamp: ''!
initMenu 

	MenuCursor  :=
		        (Cursor
	extent: 16@16
	fromArray: #(
		2r1111111111100000
		2r1000000000100000
		2r1010011000100000
		2r1000000000100000
		2r1101001101100000
		2r1111111111100000
		2r1000000000100000
		2r1011001010100000
		2r1000000000100000
		2r1010110010100000
		2r1000000000100000
		2r1010010100100000
		2r1000000000100000
		2r1111111111100000
		0)
	offset: 0@0).! !

!Cursor class methodsFor: 'constants' stamp: ''!
resizeTopLeft
	"Cursor resizeTopLeft showWhile: [Sensor waitButton]"
	^ ResizeTopLeftCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
makeCursorsWithMask
	"Cursor initialize;makeCursorsWithMask"

	self classPool associationsDo: [:var |
		var value hasMask
			ifFalse: [var value: var value withMask]]! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
initMarker

	MarkerCursor := 
		Cursor
			extent: 16@16
			fromArray: #(
		2r0111000000000000
		2r1111100000000000
		2r1111100000000000
		2r0111000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
			offset: 0@0.! !

!Cursor class methodsFor: 'constants' stamp: ''!
resizeLeft
	"Cursor resizeLeft showWhile: [Sensor waitButton]"
	^ResizeLeftCursor! !

!Cursor class methodsFor: 'constants' stamp: ''!
resizeBottomRight
	"Cursor resizeBottomRight showWhile: [Sensor waitButton]"
	^self resizeTopLeft! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
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: 'initialize-release' stamp: ''!
createStandardCursors 
	self 
		initOrigin;
		initRightArrow;
		initMenu;
		initCorner;
		initRead;
		initWrite;
		initWait.
	BlankCursor := Cursor new.
	self 
		initXeq;
		initSquare;
		initNormalWithMask;
		initCrossHair;
		initMarker;
		initUp;
		initDown;
		initMove;
		initBottomLeft;
		initBottomRight;
		initResizeLeft;
		initResizeTop;
		initResizeTopLeft;
		initResizeTopRight;
		initTopLeft;
		initTopRight;
		initTarget;
		initOverEditableText;
		makeCursorsWithMask.! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
initDown

	DownCursor  :=
		     (Cursor
	extent: 16@16
	fromArray: #(
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r1111110000000000
		2r111100000000000
		2r11000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).! !

!Cursor class methodsFor: 'constants' stamp: ''!
crossHair
	"Answer the instance of me that is the shape of a cross."

	^CrossHairCursor! !

!Cursor class methodsFor: 'constants' stamp: ''!
blank
	"Answer the instance of me that is all white."

	^BlankCursor! !

!Cursor class methodsFor: 'initialization - private' stamp: ''!
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).! !

!CursorWithAlpha commentStamp: ''!
A 32-bit ARGB Cursor of arbitrary extent (some platforms may limit the size). Compositing assumes alpha is pre-multiplied.!
!CursorWithAlpha methodsFor: 'converting' stamp: ''!
asCursorForm

	^ Form newFrom: self! !

!CursorWithAlpha methodsFor: 'accessing' stamp: ''!
fallback: aCursor
	fallback := aCursor! !

!CursorWithAlpha methodsFor: 'accessing' stamp: ''!
fallback
	^fallback ifNil: [NormalCursor]! !

!CursorWithMask commentStamp: ''!
A Cursor which additionally has a 16x16 transparency bitmap called a "mask".  See the comment of beCursorWithMask: for details on how the mask is treated.!
!CursorWithMask methodsFor: 'mask' stamp: ''!
setMaskForm: aForm
	maskForm := aForm! !

!CursorWithMask methodsFor: 'primitives' stamp: ''!
activateInCursorOwner: aCursorOwner
	maskForm unhibernate.
	^ aCursorOwner activateCursor: self withMask: maskForm! !

!CursorWithMask methodsFor: 'mask' stamp: ''!
withMask
	^self! !

!CursorWithMask methodsFor: 'mask' stamp: ''!
maskForm
	^ maskForm! !

!CursorWithMask methodsFor: 'mask' stamp: ''!
hasMask
	^true! !

!CursorWithMask methodsFor: 'mask' stamp: ''!
storeOn: aStream base: anInteger

	aStream nextPut: $(.
	super storeOn: aStream base: anInteger.
	aStream nextPutAll: ' setMaskForm: '.
	maskForm storeOn: aStream base: anInteger.
	aStream nextPut: $)! !

!CursorWithMask methodsFor: 'converting' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
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! !

!CustomHelp commentStamp: ''!
This is a common superclass for custom help. Subclasses of this class are automatically included into the system help.

By default the informations provided on the receiver class are converted into help topics by a specific builder 
- here the CustomHelpHelpBuilder. Note that you can provide an own custom builder by overriding the #builder method

!
!CustomHelp class methodsFor: 'formatting' stamp: ''!
heading: aString

	^ self formatter heading: aString! !

!CustomHelp class methodsFor: 'instance creation' stamp: ''!
newColoredText: color withRunAction: aString
	"Return new Text object with copy icon and run action."
	| run icon |
	icon := Text
		string: (String value: 1)
		attributes: { 
			(TextAnchor new anchoredMorph: (self iconNamed: #glamorousGo)).
			(TextAction new actOnClickBlock: [
				Smalltalk compiler evaluate: aString]; yourself) }.
	run := ' (execute it)' asText
		addAttribute:
			(TextAction new actOnClickBlock: [
				Smalltalk compiler evaluate: aString]; yourself);
		addAttribute: (TextColor new color: color);
		addAttribute: TextEmphasis italic;
		yourself.
	^ icon, run! !

!CustomHelp class methodsFor: 'converting' stamp: ''!
asHelpTopic
	"Convert the receiver to a help topic"
	<systemHelp>
	
	^self builder buildHelpTopicFrom: self! !

!CustomHelp class methodsFor: 'formatting' stamp: ''!
subsubheading: aString

	^ self formatter subsubheading: aString! !

!CustomHelp class methodsFor: 'accessing' stamp: ''!
bookName
	"Returns the name of the custom help book"
	
	^'Help'! !

!CustomHelp class methodsFor: 'defaults' stamp: ''!
defaultFormatter
	^ CustomHelpTextFormatter! !

!CustomHelp class methodsFor: 'accessing' stamp: ''!
formatter: aFormatter
	Formatter := aFormatter! !

!CustomHelp class methodsFor: 'accessing' stamp: ''!
formatter
	Formatter ifNil: [ Formatter := self defaultFormatter new].
	^ Formatter! !

!CustomHelp class methodsFor: 'testing' stamp: ''!
isUsed
	"all my sublasses are used"
	^self name = 'CustomHelp'
		ifTrue: [ super isUsed ]
		ifFalse: [ true ]! !

!CustomHelp class methodsFor: 'formatting' stamp: ''!
sourceCode: aSourceCode

	^ self formatter sourceCode: aSourceCode! !

!CustomHelp class methodsFor: 'formatting' stamp: ''!
heading: aString withSubtitle: aSubtitleString

	^ self formatter heading: aString withSubtitle: aSubtitleString! !

!CustomHelp class methodsFor: 'editing' stamp: ''!
edit: aSelector
	"Open a Workspace on the text in the given selector.
	When accepted, compile the result as a help topic."

	| topic |
	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.'].
	UIManager default
		edit: topic contents
		label: topic title
		accept: [:text| 
			|newTitle|
			newTitle := UIManager default request: 'Save with title ' initialAnswer: topic title.		 
			newTitle ifNotNil: [ self accept: aSelector title: newTitle contents: text ]].! !

!CustomHelp class methodsFor: 'formatting' stamp: ''!
doItScriptFrom: aString
	"Return Text object with a specific color and mouse click action
	that executes aString; aString should be a Smalltalk script that is possible to evaluate.
	After the script, a copy to clipboard and run action appears."

	| color text clipboard run |
	color := Color fromHexString: 'aa5693'.
	aString ifEmpty: [ self errorEmptyString ].
	text := aString asText
		addAttribute: (TextColor new color: color);
		yourself.
	clipboard := self newColoredText: color withClipboardAction: aString.
	run := self newColoredText: color withRunAction: aString.
	^ text , '  ' asText , clipboard, '  ' asText, run! !

!CustomHelp class methodsFor: 'accessing' stamp: ''!
icon
	"Returns an icon used for displaying the custom help book"

	^ self iconNamed: #bookIcon! !

!CustomHelp class methodsFor: 'formatting' stamp: ''!
bold: aString

	^ self formatter bold: aString! !

!CustomHelp class methodsFor: 'formatting' stamp: ''!
underlined: aString

	^ self formatter underlined: aString! !

!CustomHelp class methodsFor: 'errors' stamp: ''!
errorEmptyString

	self error: 'Expected a non empty string'! !

!CustomHelp class methodsFor: 'formatting' stamp: ''!
subheading: aString

	^ self formatter subheading: aString! !

!CustomHelp class methodsFor: 'formatting' stamp: ''!
doItFrom: aString

	^ self formatter doItFrom: aString! !

!CustomHelp class methodsFor: 'accessing' stamp: ''!
bookDescription
	"return description of the book that will be visible when one selects the book node"
	^ ''! !

!CustomHelp class methodsFor: 'accessing' stamp: ''!
key
	"Returns a unique key identifying the receiver in the help system"
	
	^''! !

!CustomHelp class methodsFor: 'accessing' stamp: ''!
pages 
	"Returns a collection of method selectors to return the pages of the custom help book"
		
	^#()! !

!CustomHelp class methodsFor: 'formatting' stamp: ''!
url: aString

	^ self formatter url: aString! !

!CustomHelp class methodsFor: 'instance creation' stamp: ''!
newColoredText: color withClipboardAction: aString
	"Return new Text object with copy icon and copy to clipboard action."
	| text icon |
	icon := Text
		string: (String value: 1)
		attributes:
			{(TextAnchor new anchoredMorph: (self iconNamed: #smallCopy)).
			(TextAction new
				actOnClickBlock: [ Clipboard clipboardText: aString.
					self inform: 'The URL has been pasted into your clipboard' ])}.
	text := ' (copy to clipboard)' asText
		addAttribute:
			(TextAction new
				actOnClickBlock: [ Clipboard clipboardText: aString.
					self inform: 'The URL has been pasted into your clipboard' ]);
		addAttribute: (TextColor new color: color);
		addAttribute: TextEmphasis italic;
		yourself.
	^ icon, text! !

!CustomHelp class methodsFor: 'editing' stamp: ''!
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."'.
		s crtab; nextPutAll: '<script: ''self 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: 'defaults' stamp: ''!
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: 'accessing' stamp: ''!
systemIcon 

	^self icon! !

!CustomHelp class methodsFor: 'formatting' stamp: ''!
doItFrom: aString text: textString

	^ self formatter doItFrom: aString text: textString! !

!CustomHelp2 commentStamp: ''!
I'm a version of CustomHelp that emit microdown instead of tweaking text.!
!CustomHelp2 class methodsFor: 'formatting' stamp: ''!
doItFrom: aString
	"Return Text object with a specific color and mouse click action
	that executes aString; aString should also be a Smalltalk script that is possible to evaluate."
	
	^self doItFrom: aString text: aString! !

!CustomHelp2 class methodsFor: 'formatting' stamp: ''!
heading: aString
	"Return Text object with heading formating attributes."

	^ '# ', aString, Character cr asString! !

!CustomHelp2 class methodsFor: 'instance creation' stamp: ''!
newColoredText: color withRunAction: aString
	"Return new Text object with copy icon and run action."
	| run icon |
	icon := Text
		string: (String value: 1)
		attributes: { 
			(TextAnchor new anchoredMorph: (self iconNamed: #glamorousGo)).
			(TextAction new actOnClickBlock: [
				Smalltalk compiler evaluate: aString]; yourself) }.
	run := ' (execute it)' asText
		addAttribute:
			(TextAction new actOnClickBlock: [
				Smalltalk compiler evaluate: aString]; yourself);
		addAttribute: (TextColor new color: color);
		addAttribute: TextEmphasis italic;
		yourself.
	^ icon, run! !

!CustomHelp2 class methodsFor: 'converting' stamp: ''!
asHelpTopic
	"Convert the receiver to a help topic"
	<newSystemHelp>
	
	^self builder buildHelpTopicFrom: self! !

!CustomHelp2 class methodsFor: 'accessing' stamp: ''!
bookDescription
	"return description of the book that will be visible when one selects the book node"
	^ ''! !

!CustomHelp2 class methodsFor: 'accessing' stamp: ''!
key
	"Returns a unique key identifying the receiver in the help system"
	
	^''! !

!CustomHelp2 class methodsFor: 'accessing' stamp: ''!
pages 
	"Returns a collection of method selectors to return the pages of the custom help book"
		
	^#()! !

!CustomHelp2 class methodsFor: 'accessing' stamp: ''!
bookName
	"Returns the name of the custom help book"
	
	^'Help'! !

!CustomHelp2 class methodsFor: 'formatting' stamp: ''!
url: aString
	"Return Text object with copy aString to the clipboard after mouse click."
	| clickBlock |
	
	aString ifEmpty: [ self errorEmptyString ].
	
	clickBlock := [ WebBrowser openOn: aString ].

	^ aString asText 
		addAttribute: (	TextAction new actOnClickBlock: clickBlock);
		addAttribute: (TextColor new color: self theme urlColor);
		yourself! !

!CustomHelp2 class methodsFor: 'testing' stamp: ''!
isUsed
	"all my sublasses are used"
	^self name = 'CustomHelp'
		ifTrue: [ super isUsed ]
		ifFalse: [ true ]! !

!CustomHelp2 class methodsFor: 'instance creation' stamp: ''!
newColoredText: color withClipboardAction: aString
	"Return new Text object with copy icon and copy to clipboard action."
	| text icon |
	icon := Text
		string: (String value: 1)
		attributes:
			{(TextAnchor new anchoredMorph: (self iconNamed: #smallCopy)).
			(TextAction new
				actOnClickBlock: [ Clipboard clipboardText: aString.
					self inform: 'The URL has been pasted into your clipboard' ])}.
	text := ' (copy to clipboard)' asText
		addAttribute:
			(TextAction new
				actOnClickBlock: [ Clipboard clipboardText: aString.
					self inform: 'The URL has been pasted into your clipboard' ]);
		addAttribute: (TextColor new color: color);
		addAttribute: TextEmphasis italic;
		yourself.
	^ icon, text! !

!CustomHelp2 class methodsFor: 'accessing' stamp: ''!
icon
	"Returns an icon used for displaying the custom help book"

	^ self iconNamed: #bookIcon! !

!CustomHelp2 class methodsFor: 'defaults' stamp: ''!
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! !

!CustomHelp2 class methodsFor: 'formatting' stamp: ''!
doItScriptFrom: aString
	"Return Text object with a specific color and mouse click action
	that executes aString; aString should be a Smalltalk script that is possible to evaluate.
	After the script, a copy to clipboard and run action appears."

	| color text clipboard run |
	color := Color fromHexString: 'aa5693'.
	aString ifEmpty: [ self errorEmptyString ].
	text := aString asText
		addAttribute: (TextColor new color: color);
		yourself.
	clipboard := self newColoredText: color withClipboardAction: aString.
	run := self newColoredText: color withRunAction: aString.
	^ text , '  ' asText , clipboard, '  ' asText, run! !

!CustomHelp2 class methodsFor: 'formatting' stamp: ''!
bold: aString
	"Return Text object with bold emphasis."
	aString ifEmpty: [ self errorEmptyString ].
	^ aString asText addAttribute: TextEmphasis bold from: 1 to: aString size.! !

!CustomHelp2 class methodsFor: 'errors' stamp: ''!
errorEmptyString

	self error: 'Expected a non empty string'! !

!CustomHelp2 class methodsFor: 'accessing' stamp: ''!
systemIcon 

	^self icon! !

!CustomHelp2 class methodsFor: 'formatting' stamp: ''!
doItFrom: aString text: textString
	"Return Text object with a specific color and mouse click action displayed as textString; 
	 aString should be a Smalltalk script that is possible to evaluate."
	| color |
	
	color := Color fromHexString: 'aa5693'.

	aString ifEmpty: [ self errorEmptyString ].
	^ textString asText
		addAttribute: (TextAction new actOnClickBlock: [
				Smalltalk compiler evaluate: aString]; yourself) 
			from: 1 to: textString size;
		addAttribute: (TextColor new color: color) from: 1 to: textString size;
		yourself! !

!CustomHelp2 class methodsFor: 'formatting' stamp: ''!
subheading: aString
	"Return Text object with subheading formating attributes."

	^ '## ', aString, Character cr asString! !

!CustomHelpHelpBuilder commentStamp: ''!
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: 'private' stamp: ''!
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 contents: aDescription bookDescription.
	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! !

!CustomHelpHelpBuilder methodsFor: 'building' stamp: ''!
build
	"Start building a help topic from a code description"
	
	topicToBuild := self createTopicFrom: rootToBuildFrom! !

!CustomHelpMicrodownFormatter methodsFor: 'formatting' stamp: ''!
doItFrom: aString
	"Return Text object with a specific color and mouse click action
	that executes aString; aString should also be a Smalltalk script that is possible to evaluate."
	
	^self doItFrom: aString text: aString! !

!CustomHelpMicrodownFormatter methodsFor: 'formatting' stamp: ''!
heading: aString
	"Return Text object with heading formating attributes."
	^ String cr, '# ', aString, String cr! !

!CustomHelpMicrodownFormatter methodsFor: 'formatting' stamp: ''!
subsubheading: aString
	^ String cr, '### ' , aString, String cr! !

!CustomHelpMicrodownFormatter methodsFor: 'formatting' stamp: ''!
url: aString
	"Return Text object with copy aString to the clipboard after mouse click."
	
	^ '[{1}]({1})' format: { aString  }! !

!CustomHelpMicrodownFormatter methodsFor: 'accessing' stamp: ''!
sourceCode: aSourceCode

	^'```
{1}
````' format: { aSourceCode  }! !

!CustomHelpMicrodownFormatter methodsFor: 'formatting' stamp: ''!
heading: aString withSubtitle: aSubtitleString
	^ (self heading: aString), (self subheading: aSubtitleString )! !

!CustomHelpMicrodownFormatter methodsFor: 'formatting' stamp: ''!
bold: aString
	"Return microdown  with bold emphasis."
	aString ifEmpty: [ ^ '' ].
	^ '**',aString,'**'! !

!CustomHelpMicrodownFormatter methodsFor: 'formatting' stamp: ''!
underlined: aString
	"Microdown do not do underline - should. make italic instead"
	^ '_',aString,'_'! !

!CustomHelpMicrodownFormatter methodsFor: 'formatting' stamp: ''!
doItFrom: aString text: textString
	"Return Text object with a specific color and mouse click action displayed as textString; 
	 aString should be a Smalltalk script that is possible to evaluate."
	^ '[',textString ,'](doit://', aString urlEncoded,')'! !

!CustomHelpMicrodownFormatter methodsFor: 'formatting' stamp: ''!
subheading: aString
	"Return Text object with subheading formating attributes."
	^ String cr, '## ' , aString, Character cr asString! !

!CustomHelpTest commentStamp: ''!
SUnit tests for class CustomHelp
!
!CustomHelpTest methodsFor: 'testing' stamp: ''!
testOpenBrowserOnThisHelpType
	| browser |
	browser := HelpBrowser openOn: CustomHelp.
	self currentWorld doOneCycleNow.
	browser close! !

!CustomHelpTextFormatter methodsFor: 'formatting' stamp: ''!
doItFrom: aString
	"Return Text object with a specific color and mouse click action
	that executes aString; aString should also be a Smalltalk script that is possible to evaluate."
	
	^self doItFrom: aString text: aString! !

!CustomHelpTextFormatter methodsFor: 'formatting' stamp: ''!
heading: aString
	"Return Text object with heading formating attributes."

	| font color |
	
	font := (LogicalFont familyName: 'Source Sans Pro' pointSize: 20).
	color := Color fromHexString: '3196D3'.

	aString ifEmpty: [ self errorEmptyString ].
	^ (aString asText, String cr, String cr)
		addAttribute: (TextFontReference toFont: font) from: 1 to: aString size;
		addAttribute: TextEmphasis bold from: 1 to: aString size;
		addAttribute: (TextColor new color: color) from: 1 to: aString size;
		yourself! !

!CustomHelpTextFormatter methodsFor: 'instance creation' stamp: ''!
newColoredText: color withRunAction: aString
	"Return new Text object with copy icon and run action."
	| run icon |
	icon := Text
		string: (String value: 1)
		attributes: { 
			(TextAnchor new anchoredMorph: (self iconNamed: #glamorousGo)).
			(TextAction new actOnClickBlock: [
				Smalltalk compiler evaluate: aString]; yourself) }.
	run := ' (execute it)' asText
		addAttribute:
			(TextAction new actOnClickBlock: [
				Smalltalk compiler evaluate: aString]; yourself);
		addAttribute: (TextColor new color: color);
		addAttribute: TextEmphasis italic;
		yourself.
	^ icon, run! !

!CustomHelpTextFormatter methodsFor: 'formatting' stamp: ''!
subsubheading: aString
	"Return Text object with subheading formating attributes."

	| text font color |
	
	font := (LogicalFont familyName: 'Source Sans Pro' pointSize:12).
	color := Color fromHexString: '3196D3'.
	text := (String cr asText, String cr, aString, String cr, String cr).
	
	^ text
		addAttribute: (TextFontReference toFont: font) from: 3 to: text size - 1;
		addAttribute: TextEmphasis bold from: 1 to: text size - 1;
		addAttribute: (TextColor new color: color) from: 1 to: text size - 1;
		yourself! !

!CustomHelpTextFormatter methodsFor: 'formatting' stamp: ''!
url: aString
	"Return Text object with copy aString to the clipboard after mouse click."
	| clickBlock |
	
	aString ifEmpty: [ self errorEmptyString ].
	
	clickBlock := [ WebBrowser openOn: aString ].

	^ aString asText 
		addAttribute: (	TextAction new actOnClickBlock: clickBlock);
		addAttribute: (TextColor new color: self theme urlColor);
		yourself! !

!CustomHelpTextFormatter methodsFor: 'instance creation' stamp: ''!
newColoredText: color withClipboardAction: aString
	"Return new Text object with copy icon and copy to clipboard action."
	| text icon |
	icon := Text
		string: (String value: 1)
		attributes:
			{(TextAnchor new anchoredMorph: (self iconNamed: #smallCopy)).
			(TextAction new
				actOnClickBlock: [ Clipboard clipboardText: aString.
					self inform: 'The URL has been pasted into your clipboard' ])}.
	text := ' (copy to clipboard)' asText
		addAttribute:
			(TextAction new
				actOnClickBlock: [ Clipboard clipboardText: aString.
					self inform: 'The URL has been pasted into your clipboard' ]);
		addAttribute: (TextColor new color: color);
		addAttribute: TextEmphasis italic;
		yourself.
	^ icon, text! !

!CustomHelpTextFormatter methodsFor: 'formatting' stamp: ''!
sourceCode: aSourceCode

	| font text |
	font := (LogicalFont familyName: 'Source Code Pro' pointSize: 10).
	text := aSourceCode asText.
	
	^ text
		addAttribute: (TextFontReference toFont: font) from: 3 to: text size - 1;
		yourself! !

!CustomHelpTextFormatter methodsFor: 'formatting' stamp: ''!
heading: aString withSubtitle: aSubtitleString
	"Return Text object with heading formating attributes."

	| font color |
	
	font := (LogicalFont familyName: 'Source Sans Pro' pointSize: 20).
	color := Color fromHexString: '3196D3'.

	aString ifEmpty: [ self errorEmptyString ].
	^ (aString asText, String cr, aSubtitleString, String cr, String cr)
		addAttribute: (TextFontReference toFont: font) from: 1 to: aString size;
		addAttribute: TextEmphasis bold from: 1 to: aString size;
		addAttribute: (TextColor new color: color) from: 1 to: aString size;
		addAttribute: (TextColor new color: color) from: aString size+1 to: aString size+1+aSubtitleString size;
		yourself! !

!CustomHelpTextFormatter methodsFor: 'formatting' stamp: ''!
bold: aString
	"Return Text object with bold emphasis."
	aString ifEmpty: [ self errorEmptyString ].
	^ aString asText addAttribute: TextEmphasis bold from: 1 to: aString size.! !

!CustomHelpTextFormatter methodsFor: 'formatting' stamp: ''!
underlined: aString
	"Return Text object with underlined emphasis."
	aString ifEmpty: [ self errorEmptyString ].
	
	^ aString asText addAttribute: TextEmphasis underlined from: 1 to: aString size.! !

!CustomHelpTextFormatter methodsFor: 'formatting' stamp: ''!
doItFrom: aString text: textString
	"Return Text object with a specific color and mouse click action displayed as textString; 
	 aString should be a Smalltalk script that is possible to evaluate."
	| color |
	
	color := Color fromHexString: 'aa5693'.

	aString ifEmpty: [ self errorEmptyString ].
	^ textString asText
		addAttribute: (TextAction new actOnClickBlock: [
				Smalltalk compiler evaluate: aString]; yourself) 
			from: 1 to: textString size;
		addAttribute: (TextColor new color: color) from: 1 to: textString size;
		yourself! !

!CustomHelpTextFormatter methodsFor: 'formatting' stamp: ''!
subheading: aString
	"Return Text object with subheading formating attributes."

	| text font color |
	
	font := (LogicalFont familyName: 'Source Sans Pro' pointSize:16).
	color := Color fromHexString: '3196D3'.
	text := (String cr asText, String cr, aString, String cr, String cr).
	
	^ text
		addAttribute: (TextFontReference toFont: font) from: 3 to: text size - 1;
		addAttribute: TextEmphasis bold from: 1 to: text size - 1;
		addAttribute: (TextColor new color: color) from: 1 to: text size - 1;
		yourself! !

!CustomQuestionDialogWindow commentStamp: ''!
QuestionDialog supporting custom text/buttons for yes/no choices.!
!CustomQuestionDialogWindow methodsFor: 'defaults' stamp: ''!
defaultNoButton
	"Answer a default no button."

	^self newNoButton! !

!CustomQuestionDialogWindow methodsFor: 'accessing - text' stamp: ''!
yesText: aStringOrText help: helpString
	"Set the yes button label.
	if the text is nil, remove the button."

	aStringOrText
		ifNil: [self cancelButton delete]
		ifNotNil: [self yesButton
					hResizing: #shrinkWrap;
					label: aStringOrText;
					setBalloonText: helpString]! !

!CustomQuestionDialogWindow methodsFor: 'accessing' stamp: ''!
cancelButton: anObject

	cancelButton := anObject! !

!CustomQuestionDialogWindow methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	self
		yesButton: self defaultYesButton;
		noButton: self defaultNoButton;
		cancelButton: self defaultCancelButton.
	super initialize! !

!CustomQuestionDialogWindow methodsFor: 'defaults' stamp: ''!
defaultYesButton
	"Answer a default yes button."

	^self newYesButton! !

!CustomQuestionDialogWindow methodsFor: 'accessing' stamp: ''!
cancelButton

	^ cancelButton! !

!CustomQuestionDialogWindow methodsFor: 'building' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self yesButton. self noButton. self cancelButton}! !

!CustomQuestionDialogWindow methodsFor: 'accessing - text' stamp: ''!
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: 'accessing - text' stamp: ''!
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: 'defaults' stamp: ''!
defaultCancelButton
	"Answer a default cancel button."

	^self newCancelButton! !

!CustomQuestionDialogWindow methodsFor: 'accessing' stamp: ''!
noButton: anObject
	"Set the value of noButton"

	noButton := anObject! !

!CustomQuestionDialogWindow methodsFor: 'defaults' stamp: ''!
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: 'accessing' stamp: ''!
yesButton: anObject
	"Set the value of yesButton"

	yesButton := anObject! !

!CustomQuestionDialogWindow methodsFor: 'accessing' stamp: ''!
yesButton
	"Answer the value of yesButton"

	^ yesButton! !

!CustomQuestionDialogWindow methodsFor: 'accessing' stamp: ''!
noButton
	"Answer the value of noButton"

	^ noButton! !

!DAAbstractItemDiff commentStamp: ''!
A PDAbstractItemDiff is a object which represent an item who added/modified/removed from an old analysis.!
!DAAbstractItemDiff methodsFor: 'testing' stamp: ''!
isRemoved
	^ removed! !

!DAAbstractItemDiff methodsFor: 'actions' stamp: ''!
beNew
	new := true! !

!DAAbstractItemDiff methodsFor: 'initialization' stamp: ''!
initialize
	new := false.
	removed := false.
	underteminate := false! !

!DAAbstractItemDiff methodsFor: 'testing' stamp: ''!
hasChanged
	self subclassResponsibility ! !

!DAAbstractItemDiff methodsFor: 'testing' stamp: ''!
beUnderteminate
	underteminate := true! !

!DAAbstractItemDiff methodsFor: 'accessing' stamp: ''!
content: aContent
	content := aContent! !

!DAAbstractItemDiff methodsFor: 'testing' stamp: ''!
isNew
	^ new! !

!DAAbstractItemDiff methodsFor: 'printing' stamp: ''!
printOn: aStream
	self subclassResponsibility ! !

!DAAbstractItemDiff methodsFor: 'testing' stamp: ''!
canBeDisplay
	^ (self isNew or: [ self isRemoved ]) or: [ self hasChanged ].! !

!DAAbstractItemDiff methodsFor: 'testing' stamp: ''!
isUnderteminate
	 ^ underteminate ! !

!DAAbstractItemDiff methodsFor: 'accessing' stamp: ''!
content
	 ^ content! !

!DAAbstractItemDiff methodsFor: 'accessing' stamp: ''!
diff: anObject
	diff := anObject! !

!DAAbstractItemDiff methodsFor: 'actions' stamp: ''!
beRemoved
	removed := true! !

!DAAbstractItemDiff methodsFor: 'accessing' stamp: ''!
diff
	^ diff! !

!DAAbstractItemDiff class methodsFor: 'testing' stamp: ''!
isAbstract

	^self == DAAbstractItemDiff! !

!DAAbstractItemDiff class methodsFor: 'instance creation' stamp: ''!
newWith: aContent
	^ (self new)
		content: aContent;
		yourself! !

!DAAbstractPackageNode commentStamp: ''!
Abstract class from package node displaying in the tree.!
!DAAbstractPackageNode methodsFor: 'accessing' stamp: ''!
packageName
	^ self content target packageName! !

!DAAbstractPackageNode methodsFor: 'browse-nautilus' stamp: ''!
selectInBrowser
	"rPackage is always a RPackageSet"
	
	self selectPackage: self rPackage packages last.! !

!DAAbstractPackageNode class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == DAAbstractPackageNode! !

!DAAddPackagePresenter commentStamp: ''!
A simple CompasableModel to add new packages to the current package dependencies analysis.
It implies to be open from a PDPackageAnalyzerWindowPackageDependencies instance. !
!DAAddPackagePresenter methodsFor: 'accessing' stamp: ''!
systemPackages
	^ (RPackageOrganizer default packages collect: [ :package | package packageName asString ] )asSortedCollection! !

!DAAddPackagePresenter methodsFor: 'accessing' stamp: ''!
packageAnalyzerTreeModel
	^ packageAnalyzerTreeModel! !

!DAAddPackagePresenter methodsFor: 'actions' stamp: ''!
buildList
	| packagesAdded packagesNotAdded |
	packagesAdded := self packageAnalyzerTreeModel seenPackagesName.
	packagesNotAdded := self systemPackages.
	packagesNotAdded removeAll: packagesAdded.
	packageList items: packagesNotAdded.! !

!DAAddPackagePresenter methodsFor: 'api' stamp: ''!
initialExtent
	^ (600@600)! !

!DAAddPackagePresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	
	packageList := self newList
		multiSelection: true;
		yourself.
	
	buttonAddPackage := self newButton
		help: 'Add these packages to the current analysis';
		label: 'Add packages';
		icon: (self iconNamed: #addIcon);
		yourself.! !

!DAAddPackagePresenter methodsFor: 'instance creation' stamp: ''!
open
	^ self openWithSpec! !

!DAAddPackagePresenter methodsFor: 'accessing' stamp: ''!
packageList
	^ packageList! !

!DAAddPackagePresenter methodsFor: 'initialization' stamp: ''!
selectedItemsFromPackageList
	^ self packageList selectedItems! !

!DAAddPackagePresenter methodsFor: 'accessing' stamp: ''!
packageAnalyzerTreeModel: aPackageAnalyzerTreeModel
	packageAnalyzerTreeModel := aPackageAnalyzerTreeModel.
	self buildList! !

!DAAddPackagePresenter methodsFor: 'protocol' stamp: ''!
actionOnAddPackage
	| relationGraph packagesToAdd |
	buttonAddPackage
		action: [ 
			self selectedItemsFromPackageList
				ifNotEmpty: [ 
					relationGraph := self packageAnalyzerTreeModel relationGraph.
					packagesToAdd := self selectedItemsFromPackageList
						collect: [ :packageName | (DAPackage on: (RPackageSet named: packageName)) beSeen ].
					relationGraph addPackages: packagesToAdd.
					self packageAnalyzerTreeModel
						refresh;
						resetDefaultSettings.
					self delete ] ]! !

!DAAddPackagePresenter methodsFor: 'accessing' stamp: ''!
buttonAddPackage
	^ buttonAddPackage! !

!DAAddPackagePresenter methodsFor: 'protocol' stamp: ''!
title
	^ 'Choose packages to add'! !

!DAAddPackagePresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	self actionOnAddPackage! !

!DAAddPackagePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newColumn:
			[ :col | 
			col
				add: #packageList;
				add: #buttonAddPackage height: 30
				] yourself! !

!DAAssemblyNode commentStamp: ''!
I reprensent a package assembly (i.e. a set of packages).
I collect all dependencies related to the assembly parts.!
!DAAssemblyNode methodsFor: 'testing' stamp: ''!
includes: aPackageName
	^ (self dependencies collect: [:aDep | aDep packageName]) includes: aPackageName! !

!DAAssemblyNode methodsFor: 'accessing' stamp: ''!
children
	^ dependencies! !

!DAAssemblyNode methodsFor: 'testing' stamp: ''!
hasChildren
	^ true! !

!DAAssemblyNode methodsFor: 'initialization' stamp: ''!
initializeWith: aCollection 
	self initialize.
	dependencies := aCollection! !

!DAAssemblyNode methodsFor: 'accessing' stamp: ''!
daPackage
	^ self parentNode daPackage! !

!DAAssemblyNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #forwardIcon! !

!DAAssemblyNode methodsFor: 'accessing' stamp: ''!
dependencies
	^ dependencies! !

!DAAssemblyNode methodsFor: 'browse-nautilus' stamp: ''!
selectInBrowser
	"nothing to browse"! !

!DAAssemblyNode methodsFor: 'api' stamp: ''!
childNodeClassFor: anItem
	^ DADependentPackageNode! !

!DAAssemblyNode methodsFor: 'displaying' stamp: ''!
label
	^ self content! !

!DAAssemblyNode class methodsFor: 'instance creation' stamp: ''!
newWith: aCollection 
	^ self basicNew
		initializeWith: aCollection;
		yourself! !

!DAClassNode commentStamp: ''!
A DAClassDependencyNode is the superclass node for DAInheritanceDependencyNode and DATraitDependencyNode. Indeed these two nodes have the same behavior to browse the dependency in the browser
!
!DAClassNode methodsFor: 'browse-nautilus' stamp: ''!
classFromContent
	^ self content theClass! !

!DAClassNode methodsFor: 'browse-nautilus' stamp: ''!
selectInBrowser
	self selectClass: self classFromContent! !

!DAClassToDependencyNode methodsFor: 'browse-nautilus' stamp: ''!
spawnNewBrowser
	self browseClass: self content browse! !

!DAClassToDependencyNode methodsFor: 'accessing' stamp: ''!
children
	^ self dependencies! !

!DAClassToDependencyNode methodsFor: 'accessing' stamp: ''!
hasChildren
	^ self dependencies isNotEmpty! !

!DAClassToDependencyNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #confirmIcon! !

!DAClassToDependencyNode methodsFor: 'accessing' stamp: ''!
dependencies
	^ self package dependenciesFrom: self content! !

!DAClassToDependencyNode methodsFor: 'accessing' stamp: ''!
package: anObject
	package := anObject! !

!DAClassToDependencyNode methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!DAClassToDependencyNode methodsFor: 'procotol' stamp: ''!
childNodeClassFor: anItem
	 ^ anItem nodeClass! !

!DACompositeDependency commentStamp: ''!
A PDCompositeDependency is a composite dependency. A composite pattern is using.

Actually in all case this dependency contains the dependencies between two packages and the instance variable dependencies contains all the type of dependencies (Extension, Inheritance, Reference, Trait).!
!DACompositeDependency methodsFor: 'adding' stamp: ''!
add: aDependency
	dependencies add: aDependency! !

!DACompositeDependency methodsFor: 'testing' stamp: ''!
dependenciesWithoutExtensionDependency
	^ dependencies reject: [ :dependency | dependency isExtensionDependency ].! !

!DACompositeDependency methodsFor: 'accessing' stamp: ''!
extensionDependenciesSize
	^ self dependencies sum: [ :dependency | 
			dependency isExtensionDependency
				ifTrue: [ 1 ]
				ifFalse: [ 0 ] ]! !

!DACompositeDependency methodsFor: 'initialization' stamp: ''!
initializeFrom: aSourcePackage to: aTargetPackage

	super initializeFrom: aSourcePackage to: aTargetPackage.
	dependencies := OrderedCollection new! !

!DACompositeDependency methodsFor: 'printing' stamp: ''!
printShortReasonOn: aStream
	aStream nextPutAll: dependencies size asString! !

!DACompositeDependency methodsFor: 'accessing' stamp: ''!
referenceDependenciesFrom: aClass
	| references |
	references := self referenceDependencies.
	
	^ references select: [ :reference | reference theClass = aClass ].! !

!DACompositeDependency methodsFor: '*Tool-DependencyAnalyser-UI' stamp: ''!
nodeClass
	^ self dependencies first isMessageSendDependency
		ifTrue: [ DAManuallyAddedDependentPackageNode ]
		ifFalse: [ DADependentPackageNode ]! !

!DACompositeDependency methodsFor: 'accessing' stamp: ''!
extensionDependencies
 	^ dependencies select: [ :each | each isExtensionDependency ]! !

!DACompositeDependency methodsFor: 'testing' stamp: ''!
containsOnlyExtensionDependency
	(self dependencies isEmpty ) ifTrue: [ ^ false ].
	 ^ self dependencies allSatisfy: [ :dependency | dependency isExtensionDependency ]! !

!DACompositeDependency methodsFor: 'accessing' stamp: ''!
referenceDependencies
 	^ dependencies select: [ :each | each isReferenceDependency ]! !

!DACompositeDependency methodsFor: 'accessing' stamp: ''!
dependencies
	^ dependencies! !

!DACompositeDependency methodsFor: 'accessing' stamp: ''!
dependenciesFrom: aClass
	
	^ dependencies select: [ :reference | reference theClass = aClass ].! !

!DACompositeDependency methodsFor: 'accessing' stamp: ''!
numberOfDependencies
	^ dependencies size! !

!DACompositeDependency methodsFor: 'printing' stamp: ''!
printReasonOn: aStream
	aStream nextPutAll: dependencies size asString; nextPutAll: ' dependencies: '.
	dependencies
		do: [ :each | each printReasonOn: aStream ]
		separatedBy: [ aStream nextPutAll: ', ' ]! !

!DACycleNode commentStamp: ''!
A PDCycleNode is used to display a cycle in a tree.!
!DACycleNode methodsFor: 'building-menu' stamp: ''!
addMenuEntriesOn: aMenuGroup
	| graphvizGenerator |

	aMenuGroup 
		addMenuItem:
			(MenuItemPresenter new
						name: 'Generate GraphViz file';
						action: [ self ifGraphVizAbsent: [ self error: 'Please install Graphviz Support' ].
									graphvizGenerator := DAPackageCycleGenerator 
										newWith: self cycle 
										named: 'CycleGraph' , self cycle size asString , 'nodes'.
									self saveGraphAndOpenWith: graphvizGenerator ])! !

!DACycleNode methodsFor: 'accessing' stamp: ''!
children
	^ self content packages! !

!DACycleNode methodsFor: 'accessing' stamp: ''!
isCycleNode
	^ true! !

!DACycleNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #refreshIcon! !

!DACycleNode methodsFor: 'browse-nautilus' stamp: ''!
selectInBrowser
	"we cannot browse a cycle in browser"
	^ self! !

!DACycleNode methodsFor: 'accessing' stamp: ''!
childNodeClassFor: anItem
	^ DAPackageUnderAnalysisNode! !

!DADependenciesHTMLPublisher commentStamp: ''!
This class generates an HTML report of system dependencies in HTML format.

Example: 

 '/tmp/report.html' asFileReference writeStreamDo: [ :stream |
	 DADependenciesHTMLPublisher 
		publishReportFrom: (DADependencyChecker new transitiveDependenciesOf: #Kernel)
		stream: stream ]!
!DADependenciesHTMLPublisher methodsFor: 'html utilities' stamp: ''!
sizeBadgeFor: aCollection
	^ self badgeFor: aCollection size asString! !

!DADependenciesHTMLPublisher methodsFor: 'html utilities' stamp: ''!
badgeFor: aString
	^ '<span class="badge"> ' , aString , '</span>'! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
htmlForDependency: dependencyPackageName of: aPackageName
	^ 	dependencyPackageName
! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
publish
	self 
		publishHTMLHeader;
		publishSetup;
		publishWarnings;
		publishDependenciesCaption;
		publishDependencies;
		publishDependenciesCaption;
		publishHTMLFooter.
	stream close.! !

!DADependenciesHTMLPublisher methodsFor: 'html utilities' stamp: ''!
warningLabel: aString
	^ '<span class="label label-warning">' , aString , '</span>'! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
imageVersionString
	^ report imageVersion majorMinorVersion, ' update ' , report imageVersion highestUpdate printString! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
htmlForDependencies: dependencies of: aPackageName
	^ String streamContents: [ :str |
		dependencies
			do: [ :dependency | str 
				<< '<a href="#'
				<< dependency
				<< '">'
				<< (self htmlForDependency: dependency of: aPackageName)
				<< '</a>' ]
			separatedBy: [ str space ] ]
		
! !

!DADependenciesHTMLPublisher methodsFor: 'html utilities' stamp: ''!
dangerLabel: aString
	^ '<span class="label label-danger">' , aString , '</span>'! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
publishHTMLHeader
	self stream
		<< '<!!DOCTYPE html>'; lf;
		<< '<html lang="en">'; lf;
		<< '<head>'; lf;
		<< '<title>Dependencies Report: </title>'; lf.

	self styleSheet: 'https://maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css'.
	self styleSheet: 'https://cdn.datatables.net/1.10.8/css/jquery.dataTables.min.css'.
	self javaScript: 'https://code.jquery.com/jquery-1.11.3.min.js'.
	self javaScript: 'https://cdn.datatables.net/1.10.8/js/jquery.dataTables.min.js'.
	self javaScript: 'https://maxcdn.bootstrapcdn.com/bootstrap/3.3.5/js/bootstrap.min.js'.
			
	stream << '<script type="text/javascript" class="init">
$(document).ready(function() {
	$(''#example'').DataTable( {
		"paging": false,
		"aoColumns": [ null, { "bSearchable": false }, { "bSearchable": false } ]
	});
} );
	</script>'.
		
	self stream
		lf;
		<< '</head>'; lf;
		<< '<body>'; lf;
		<< '<div class="container">'; lf;
		<< '<h1>Dependency analysis</h1>'; lf.! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
publishPackagesToRemoveDependants
	"Standard dependency report do not care about packages to remove for the bootsrap.
	Nothing to do."! !

!DADependenciesHTMLPublisher methodsFor: 'html utilities' stamp: ''!
styleSheet: styleSheetUrl
	stream 
		<< '<link rel="stylesheet" type="text/css" href="'
		<< styleSheetUrl 
		<< '">'; lf! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
publishDependenciesCaption
	self stream lf;
		<< (self warningLabel: 'Ignored dependency'); lf! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
publish: aPackageName dependencies: dependencies dependants: dependants
	| dependantLinks |
	dependantLinks := dependants sorted collect: [ :name | '<a href="#', name , '">' , name , '</a>' ].
	
	stream << 
'						<tr>
							<td id="' << aPackageName << '">' << (self htmlForPackage: aPackageName) << '</td>
							<td>' << (self sizeBadgeFor: dependencies) << Character space 
							<< (self htmlForDependencies: dependencies sorted of: aPackageName) << Character space
							<< (self htmlForIgnoredDependenciesOf: aPackageName) << '</td>
							<td>' << (self sizeBadgeFor: dependants) << Character space << (Character space join: dependantLinks) << '</td>
						</tr>'; lf.! !

!DADependenciesHTMLPublisher methodsFor: 'html utilities' stamp: ''!
javaScript: scriptFileName
	stream 
		<< '<script type="text/javascript" language="javascript" src="'
		<< scriptFileName 
		<< '"></script>'; lf! !

!DADependenciesHTMLPublisher methodsFor: 'html utilities' stamp: ''!
accordion: id name: name headingContent: heading body: body
	stream 
		<< '<div class="panel-group" id="' << id << '" role="tablist" aria-multiselectable="true">'.

	stream << '  <div class="panel panel-default">
    <div class="panel-heading" role="tab" id="heading' << name << '">
      <h4 class="panel-title">
        <a role="button" data-toggle="collapse" data-parent="#' << id << '" href="#collapse' << name << '" aria-expanded="true" aria-controls="collapse' << name << '">' ; lf.
	stream
		<< heading
<< '
        </a>
      </h4>
    </div>
    <div id="collapse' << name << '" class="panel-collapse collapse in" role="tabpanel" aria-labelledby="heading' << name << '">
      <div class="panel-body">
      		'.
	stream 
		<< body
		<< '
      </div>
    </div>
  </div>'.
		
	stream
		<< '</div>'; lf! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
htmlForIgnoredDependenciesOf: aPackageName
	^ String streamContents: [ :str |
		(RPackage organizer packageNamed: aPackageName) ignoredDependencies 
			do: [ :dependency | str << (self warningLabel: dependency) ]
			separatedBy: [ str space ] ]! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
htmlForPackage: aPackageName
	^ 	aPackageName
! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
publishHTMLFooter
	self stream lf;
		<< '</div>'; lf;
		<< '</body>'; lf;
		<< '</html>'; lf! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
publishSetup
	| body |
	body := String streamContents: [ :str |
		str
			<< 'Image version: <span class="label label-primary">';
			<< self imageVersionString; 
			<< '</span></br> Analysis run on ';
			<< report analysisRunString ; 
			<< '</br>' ].
	self accordion: 'accordionSetup' name: 'Setup' headingContent: 'Analysis setup' body: body! !

!DADependenciesHTMLPublisher methodsFor: 'accessing' stamp: ''!
stream
	^ stream! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
publishWarnings
	| body |
	body := String streamContents: [ :str |
		(report warnings sorted: [ :a :b | a package < b package ])
			do: [ :warning | str << warning messageText << '<br/>' ] ].
	self 
		accordion: 'accordionWarnings'
		name: 'Warnings'
		headingContent: 'Warnings ' , (self sizeBadgeFor: report warnings)
		body: body.		
	stream
		<< '</br>'; lf.
	! !

!DADependenciesHTMLPublisher methodsFor: 'initialization' stamp: ''!
initializeWithReport: aCGODependencyReport stream: aStream
	super initialize.
	stream := aStream.
	report := aCGODependencyReport! !

!DADependenciesHTMLPublisher methodsFor: 'publishing' stamp: ''!
publishDependencies
	stream
		<<
			'				<table id="example" class="display" cellspacing="0" width="100%">
					<thead>
						<tr>
							<th>Package</th>
							<th>Dependencies</th>
							<th>Dependants</th>
						</tr>
					</thead>
					<tbody>';
		lf.
	report
		dependenciesAndKnownDependantsDo:
			[ :packageName :dependencies :dependants | self
				publish: packageName
				dependencies: dependencies
				dependants: dependants ].
	self publishPackagesToRemoveDependants.
	stream
		<<
			'					</tbody>
				</table>';
		lf! !

!DADependenciesHTMLPublisher class methodsFor: 'publishing' stamp: ''!
publishReportFrom: aCGODependencyReport stream: aStream 
	self basicNew 
		initializeWithReport: aCGODependencyReport stream: aStream;
		publish
		! !

!DADependenciesHTMLPublisher class methodsFor: 'publishing' stamp: ''!
generateSystemReport

	<script>
	
	| report |
	
	report := DADependencyChecker new computeImageDependencies.
'dependency-report.html' asFileReference writeStreamDo: [ :stream |
	 DADependenciesHTMLPublisher 
		publishReportFrom: report
		stream: stream ].

	! !

!DADependencyChecker commentStamp: ''!
Utility class to easily check  dependencies of packages.


DADependencyChecker new dependenciesOf: #CargoPackageManager.

DADependencyChecker new transitiveDependenciesOf: #'CargoPackageManager-Minimal'.

DADependencyChecker new dependentsOf: #CargoPackageManager.!
!DADependencyChecker methodsFor: 'private' stamp: ''!
buildPackageRelationGraphFor: aPackageName
	^ [ (DAPackageRelationGraph onPackagesNamed: { aPackageName }) build ]
		on: PotentialOutDatedDependencyWarning 
		do: [ :ex | report addWarning: ex. ex resume ]! !

!DADependencyChecker methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self newReport! !

!DADependencyChecker methodsFor: 'private' stamp: ''!
manuallyResolvedDependenciesOf: aPackageName
	^ (RPackage organizer packageNamed: aPackageName) manuallyResolvedDependencies ! !

!DADependencyChecker methodsFor: 'computing - dependencies' stamp: ''!
shortestPathToPackageIntroducingDependency: dependencyPackageName startingFrom: aPackageName
	"This method allows to easily spots a package dependency we want to avoid in the System.
	ex: DADependencyChecker new 
			computeImageDependencies;
			shortestPathToPackageIntroducingDependency: #'Athens-Core' startingFrom: 'Monticello'.
	The answer will be the shortest path (one, not all) going from #Monticello to #'Athens-Core',
	showing dependencies that leads to the introduction of the  #'Athens-Core' dependency.
		=> #(#Monticello #Kernel #'System-Settings-Core' #'Morphic-Widgets-Windows' #'Rubric' #'Athens-Morphic' #'Athens-Core').
	Now, we know that System-Settings-Core brings the whole graphical environment with him and that we should avoid the dependency 
	between #Kernel and #'System-Settings-Core'."
	| dijkstra |
	report ifNil: [ ^ self ].
	dijkstra := MalDijkstra new.
	dijkstra nodes: report dependencies keys.
	report dependenciesDo: [ :packageName :dependencies |
		dependencies do: [ :dependency | 
			dijkstra edges: { packageName } from: [ :ignored | packageName ] to: [ :ignored | dependency ] ] ].
	dijkstra runFrom: aPackageName to: dependencyPackageName.
	^ dijkstra backtrack! !

!DADependencyChecker methodsFor: 'private' stamp: ''!
daPackageFor: aPackageName
	^ (((self buildPackageRelationGraphFor: aPackageName) packages)
			select: #isSeen) first! !

!DADependencyChecker methodsFor: 'private' stamp: ''!
computeDependenciesOf: aPackageName
	| dependencies |
	dependencies := (self daPackageFor: aPackageName) dependentPackages collect: [:each | each packageName].
	^ ((dependencies
			addAll: (self manuallyResolvedDependenciesOf: aPackageName);
			yourself) 
		difference: (self ignoredDependenciesOf: aPackageName)) 
		sorted! !

!DADependencyChecker methodsFor: 'initialization' stamp: ''!
newReport
	^ report := DADependencyReport new! !

!DADependencyChecker methodsFor: 'private' stamp: ''!
ignoredDependenciesOf: aPackageName
	^ (RPackage organizer packageNamed: aPackageName) ignoredDependencies ! !

!DADependencyChecker methodsFor: 'accessing' stamp: ''!
dependenciesOf: aPackageName
	^ report 
		dependenciesOf: aPackageName asSymbol
		ifAbsentPut: [ self computeDependenciesOf: aPackageName ]! !

!DADependencyChecker methodsFor: 'accessing' stamp: ''!
unresolvedDependenciesOf: aPackageName 
	^ [ (DAMessageSendAnalyzer on: aPackageName) missingMethodsWithPotentialMatchAfterManuallyResolvedDependenciesAddition
		reject: #isEmpty ]
		on: PotentialOutDatedDependencyWarning
		do: [ :ex | ex resume ]! !

!DADependencyChecker methodsFor: 'computing - dependencies' stamp: ''!
computeImageDependencies
	| visited |
	self newReport.
	report 
		analysisRunString: 'Pharo image dependencies';
		imageVersion: SystemVersion current.
	visited := Set new.
	RPackageOrganizer default packageNames 
		do: [ :packageName |
			self computeDependenciesOf: packageName visitedPackages: visited ].
	^ report! !

!DADependencyChecker methodsFor: 'computing - dependencies' stamp: ''!
transitiveDependenciesOf: aPackageName
	self newReport.
	report 
		analysisRunString: 'Transitive dependencies of ' , aPackageName;
		imageVersion: SystemVersion current.
	self computeTransitiveDependenciesOf: aPackageName visitedPackages: Set new.
	^ report! !

!DADependencyChecker methodsFor: 'private' stamp: ''!
computeDependenciesOf: aPackageName visitedPackages: visited
	| packageName |
	packageName := aPackageName asSymbol.
	report 
			add: packageName 
			dependencies: (self computeDependenciesOf: packageName).
	visited add: packageName! !

!DADependencyChecker methodsFor: 'private' stamp: ''!
computeTransitiveDependenciesOf: aPackageName visitedPackages: visited
	(visited includes: aPackageName) ifTrue: [ ^ self ].
	self computeDependenciesOf: aPackageName visitedPackages: visited.
	(self dependenciesOf: aPackageName) 
		do: [ :each | self computeTransitiveDependenciesOf: each visitedPackages: visited ]! !

!DADependencyCheckerTest methodsFor: 'tests' stamp: ''!
testShouldGetUnresolvedDependencies

	| result |	
	result := (checker unresolvedDependenciesOf: 'Tool-DependencyAnalyser-Tests-Data').
	self 	
		assert: result size
		equals: 2.
	self flag: #Torevisit.
	"I do not like to have a dependency on another tools. It would be better to check against a lib in a lower layer."
	self assert: ((result at: #collect:as:) includesAll: #(#'NewTools-Spotter' #'Collections-Abstract')).
	! !

!DADependencyCheckerTest methodsFor: 'tests' stamp: ''!
testShouldGetDirectDependencies
	self 	
		assert: (checker dependenciesOf: 'Tool-DependencyAnalyser-Tests-Data')
		equals: #(#Kernel #'Kernel-BytecodeEncoders')! !

!DADependencyCheckerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	checker := DADependencyChecker new! !

!DADependencyFromClass commentStamp: ''!
A PDDependencyFromClass is a dependency from the class. The source class is stored in the inst var.!
!DADependencyFromClass methodsFor: '*Tool-DependencyAnalyser-UI' stamp: ''!
nodeClass
	self subclassResponsibility! !

!DADependencyFromClass methodsFor: 'accessing' stamp: ''!
theClass
	^ theClass! !

!DADependencyFromClass methodsFor: 'accessing' stamp: ''!
theClass: aClass
	theClass := aClass! !

!DADependencyFromClass methodsFor: 'comparing' stamp: ''!
<= other
	^ self theClass <= other theClass! !

!DADependencyItemDiff commentStamp: ''!
A PDDependencyItemDiff is a object which represent a dependent package who added/removed from an old analysis.!
!DADependencyItemDiff methodsFor: 'testing' stamp: ''!
hasChanged
	^ self ! !

!DADependencyItemDiff methodsFor: 'printing' stamp: ''!
printOn: aStream
	
	aStream print: self content ! !

!DADependencyReport commentStamp: ''!
I'm reporting dependencies of packages previously analysed byt the dependnecy checker.!
!DADependencyReport methodsFor: 'accessing' stamp: ''!
imageVersion
	^ imageVersion! !

!DADependencyReport methodsFor: 'accessing' stamp: ''!
imageVersion: aSystemVersion 
	imageVersion := aSystemVersion! !

!DADependencyReport methodsFor: 'iterating' stamp: ''!
dependenciesAndKnownDependantsDo: aBlockClosure 
	dependencies keysAndValuesDo: [ :pkgName :deps |
		aBlockClosure 
			value: pkgName
			value: deps
			value: (self knownDependantsOf: pkgName) ]! !

!DADependencyReport methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	dependencies := Dictionary new.
	warnings := Set new! !

!DADependencyReport methodsFor: 'accessing' stamp: ''!
dependenciesOf: aPackageName ifAbsentPut: aBlock
	^ dependencies 
		at: aPackageName
		put: aBlock value! !

!DADependencyReport methodsFor: 'accessing' stamp: ''!
warnings
	^ warnings! !

!DADependencyReport methodsFor: 'adding' stamp: ''!
add: aPackageName dependencies: aListOfPackages
	dependencies 
		at: aPackageName 
		put: aListOfPackages! !

!DADependencyReport methodsFor: 'accessing' stamp: ''!
analysisRunString
	^ analysisRunString! !

!DADependencyReport methodsFor: 'accessing' stamp: ''!
analysisRunString: aString
	analysisRunString := aString! !

!DADependencyReport methodsFor: 'adding' stamp: ''!
addWarning: aWarning 
	warnings add: aWarning! !

!DADependencyReport methodsFor: 'iterating' stamp: ''!
dependenciesDo: aBlockClosure 
	dependencies keysAndValuesDo: aBlockClosure! !

!DADependencyReport methodsFor: 'accessing' stamp: ''!
dependenciesOf: aPackageName
	^ dependencies at: aPackageName! !

!DADependencyReport methodsFor: 'accessing' stamp: ''!
knownDependantsOf: aPackageName
	^ dependencies associations 
		select: [ :association | association value includes: aPackageName ]
		thenCollect: #key! !

!DADependencyReport methodsFor: 'accessing' stamp: ''!
transitiveDependenciesOf: aPackageName withoutDependenciesOf: aListOfPackageNames
	"Do not add noise to the analysis by adding transitive dependencies of dependencies we want to remove."
	^ self 
		transitiveDependenciesOf: aPackageName
		visited: (aListOfPackageNames collect: #asSymbol as: Set)! !

!DADependencyReport methodsFor: 'converting' stamp: ''!
newReportScopedOn: aPackageName withoutDependencies: aListOfPackageNameToIgnore
	"Generates a new dependency report discarding 
	- all packages that are not present in aPackageName transitive dependencies
	- all packages in aListOfPackageNameToIgnore"
	| report dependenciesToInclude |
	report := self class new.
	report
		imageVersion: imageVersion; 
		analysisRunString: analysisRunString , ' scoped on ' , aPackageName.
	dependenciesToInclude := self transitiveDependenciesOf: aPackageName withoutDependenciesOf: aListOfPackageNameToIgnore.
	warnings 
		select: [:warning | dependenciesToInclude includes: warning package ]
		thenDo: [:warning | report addWarning: warning ].
	dependencies associationsDo: [ :assoc |
		((dependenciesToInclude includes: assoc key) 
		and: [ (aListOfPackageNameToIgnore includes: assoc key) not ])
			ifTrue: [ report 
							add: assoc key 
							dependencies: assoc value ] ].
	^ report! !

!DADependencyReport methodsFor: 'private' stamp: ''!
transitiveDependenciesOf: aPackageName visited: alreadyVisitedPackages
	| deps |
	deps := Set new.
	alreadyVisitedPackages add: aPackageName.
	deps 
		addAll: (dependencies at: aPackageName).
	deps
		reject: [ :packageName | alreadyVisitedPackages includes: packageName ]
		thenDo: [ :packageName | deps addAll: (self transitiveDependenciesOf: packageName visited: alreadyVisitedPackages) ].
	^ deps! !

!DADependencyReport methodsFor: 'accessing' stamp: ''!
transitiveDependenciesOf: aPackageName
	^ self transitiveDependenciesOf: aPackageName visited: Set new! !

!DADependencyReport methodsFor: 'accessing' stamp: ''!
allPackages
	^ Set new
		addAll: dependencies keys;
		addAll: dependencies values flattened;
		yourself
		! !

!DADependencyReport class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new 
		add: #A dependencies: #();
		add: #B dependencies: #(#A);
		add: #C dependencies: #(#A #B);
		add: #D dependencies: #(#C #A #E);
		add: #E dependencies: #(#D);
		yourself! !

!DADependentPackageItemDiff commentStamp: ''!
A PDDependentPackageItemDiff is a object which represent a dependent package who added/modified/removed from an old analysis.!
!DADependentPackageItemDiff methodsFor: 'testing' stamp: ''!
hasChanged
	^ self isNew or: [ self isRemoved ].! !

!DADependentPackageItemDiff methodsFor: 'accessing' stamp: ''!
parent: anObject
	parent := anObject! !

!DADependentPackageItemDiff methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream 
		nextPutAll: content packageName;
		nextPutAll: ' Parent : ';
		nextPutAll: self parent packageName! !

!DADependentPackageItemDiff methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!DADependentPackageNode commentStamp: ''!
A DADependentPackageNode is used to display a dependent package in a tree.!
!DADependentPackageNode methodsFor: 'testing' stamp: ''!
isPackageNode
	^ true! !

!DADependentPackageNode methodsFor: 'accessing' stamp: ''!
children
	| aCompositeDependency |
	aCompositeDependency := self compositeDependencyTo.
	^ aCompositeDependency dependencies! !

!DADependentPackageNode methodsFor: 'testing' stamp: ''!
hasChildren
	^ [ self content dependencies notEmpty ]! !

!DADependentPackageNode methodsFor: 'accessing' stamp: ''!
compositeDependencyTo
	"should return one composite dependency anytime"
	^ self content! !

!DADependentPackageNode methodsFor: 'accessing' stamp: ''!
rPackage
	^ self content target rPackageSet! !

!DADependentPackageNode methodsFor: 'accessing' stamp: ''!
daPackage
	^ self parentNode daPackage! !

!DADependentPackageNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #forwardIcon! !

!DADependentPackageNode methodsFor: 'api' stamp: ''!
childNodeClassFor: anItem
	^ anItem nodeClass! !

!DADependentPackageNode methodsFor: 'displaying' stamp: ''!
label
	^ self rPackage packageName! !

!DADependentPackageWrapper commentStamp: ''!
Other wrapper for dependent package (use in TreePresenter). Useful in reverse analysis.!
!DADependentPackageWrapper methodsFor: 'initialization' stamp: ''!
initializeFrom: aPackage on: aRelationGraph
	pdPackage := aPackage.
	relationGraph :=aRelationGraph.! !

!DADependentPackageWrapper methodsFor: 'accessing' stamp: ''!
usersOfPackageSize
	^ self usersOfPackage size! !

!DADependentPackageWrapper methodsFor: 'accessing' stamp: ''!
extensionDependenciesSize
	| usersOf |
	usersOf := self usersOfPackage.
	^ usersOf 
			inject: 0 
			into: [ :sum :each | sum + (each extensionDependenciesSizeTo: self daPackage) ]! !

!DADependentPackageWrapper methodsFor: 'accessing' stamp: ''!
daPackage: anObject
	pdPackage := anObject! !

!DADependentPackageWrapper methodsFor: 'accessing' stamp: ''!
dependenciesSize
	| usersOf |
	usersOf := self usersOfPackage.
	^ usersOf
			 inject: 0
			 into: [ :sum :each | sum + (each dependenciesSizeTo: self daPackage) ]! !

!DADependentPackageWrapper methodsFor: 'accessing' stamp: ''!
relationGraph
	^ relationGraph! !

!DADependentPackageWrapper methodsFor: 'accessing' stamp: ''!
usersOfPackage
	^ relationGraph usersOf: pdPackage! !

!DADependentPackageWrapper methodsFor: 'printing' stamp: ''!
printOn: aStream
	| numberOfExtension |
	numberOfExtension := self extensionDependenciesSize.
	aStream
		nextPutAll: self packageName;
		nextPutAll: ' <-- Users : ';
		print: self usersOfPackageSize;
		nextPutAll: ' package(s) | ';
		nextPutAll: 'Dependencies : ';
		print: ((self dependenciesSize) - numberOfExtension);
		nextPutAll: ' (+ ';
		print: numberOfExtension;
		nextPutAll: ' extension dependencies ';
		nextPutAll: ')'.! !

!DADependentPackageWrapper methodsFor: 'accessing' stamp: ''!
daPackage
	^ pdPackage! !

!DADependentPackageWrapper methodsFor: 'accessing' stamp: ''!
packageName
	^ self daPackage packageName! !

!DADependentPackageWrapper methodsFor: 'accessing' stamp: ''!
rPackageSet
	^ pdPackage rPackageSet! !

!DADependentPackageWrapper methodsFor: 'accessing' stamp: ''!
relationGraph: anObject
	relationGraph := anObject! !

!DADependentPackageWrapper methodsFor: 'comparing' stamp: ''!
<= other
	^ self daPackage <= other daPackage! !

!DADependentPackageWrapper class methodsFor: 'instance creation' stamp: ''!
newWith: aPackage on: relationGraph
	^ self new initializeFrom: aPackage on: relationGraph! !

!DAExtensionDependency commentStamp: ''!
A PDExtensionDependency is an extension dependency between two packages.

Instance Variables
	selector:		the selector 
	method : 		the CompiledMethod
		!
!DAExtensionDependency methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!DAExtensionDependency methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!DAExtensionDependency methodsFor: '*Tool-DependencyAnalyser-UI' stamp: ''!
nodeClass
	^ DAExtensionDependencyNode! !

!DAExtensionDependency methodsFor: 'accessing' stamp: ''!
selector: aSelector
	selector := aSelector! !

!DAExtensionDependency methodsFor: 'accessing' stamp: ''!
method: anObject
	method := anObject! !

!DAExtensionDependency methodsFor: 'testing' stamp: ''!
isExtensionDependency
	^ true! !

!DAExtensionDependency methodsFor: 'printing' stamp: ''!
printReasonOn: aStream
	aStream
		nextPutAll: self theClass name;
		nextPutAll: '>>';
		print: self selector;
		nextPutAll: ' (extension)'! !

!DAExtensionDependencyNode commentStamp: ''!
A PDCycleNode is used to display a extension dependency in a tree.!
!DAExtensionDependencyNode methodsFor: 'accessing' stamp: ''!
icon
	^  self iconNamed: #editIcon! !

!DAGraphVizGenerator commentStamp: ''!
A class able to generate a dot file to represent a graph.!
!DAGraphVizGenerator methodsFor: 'saving' stamp: ''!
saveDotFileAndGenerateForType: extension
	^ graphviz generator makeNoWait: extension.! !

!DAGraphVizGenerator methodsFor: 'accessing' stamp: ''!
nameOfGraph: anObject
	nameOfGraph := anObject! !

!DAGraphVizGenerator methodsFor: 'accessing' stamp: ''!
nameOfGraph
	^ nameOfGraph ifNil: [ 'UnamedGraph' ]! !

!DAGraphVizGenerator methodsFor: 'accessing' stamp: ''!
graphviz
	^ graphviz! !

!DAGraphVizGenerator methodsFor: 'saving' stamp: ''!
openWith: extension
	"make sure the .gv is generated and converted into a image format"
	graphviz openInWindowWith: extension! !

!DAGraphVizGenerator methodsFor: 'build items' stamp: ''!
buildGraphViz
	graphviz := (self class environment at: #GVGraphViz) new.
	graphviz
		beDirected;
		name: self nameOfGraph.
	graphviz add: #node with: {(#shape -> #box)}.
	graphviz add: #graph with: { (#label -> self nameOfGraph). (#fontsize -> 20) }.	
	
	self
		buildNodes;
		buildEdges.! !

!DAGraphVizGenerator methodsFor: 'accessing' stamp: ''!
builder
	^ builder! !

!DAGraphVizGenerator class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == DAGraphVizGenerator! !

!DAGraphVizGenerator class methodsFor: 'instance creation' stamp: ''!
newWith: aContent named: aString
	self subclassResponsibility! !

!DAInheritanceDependency commentStamp: ''!
A PDInheritanceDependency is an inheritance dependency between two packages.

	superclass:		the superclass that includes in the target PDPackag
!
!DAInheritanceDependency methodsFor: '*Tool-DependencyAnalyser-UI' stamp: ''!
nodeClass
	^ DAInheritanceDependencyNode! !

!DAInheritanceDependency methodsFor: 'accessing' stamp: ''!
superclass
	^ superclass! !

!DAInheritanceDependency methodsFor: 'printing' stamp: ''!
printReasonOn: aStream
	aStream
		nextPutAll: self theClass name;
		nextPutAll: ' inherits from ';
		nextPutAll: self superclass name! !

!DAInheritanceDependency methodsFor: 'accessing' stamp: ''!
superclass: aClass
	superclass := aClass! !

!DAInheritanceDependency methodsFor: 'testing' stamp: ''!
isInheritanceDependency
	^ true! !

!DAInheritanceDependencyNode commentStamp: ''!
A node used to display a inheritance dependency in a tree.!
!DAInheritanceDependencyNode methodsFor: 'browse-nautilus' stamp: ''!
spawnNewBrowser
	self browseClass: self content superclass! !

!DAInheritanceDependencyNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #arrowUpIcon! !

!DAInheritanceDependencyNode methodsFor: 'accessing' stamp: ''!
isClassToDependencyNode
	^ true! !

!DAManuallyAddedDependentPackageNode commentStamp: ''!
I'm a node  representing a dependency not computed automatically but added manually on the package Manifest.!
!DAManuallyAddedDependentPackageNode methodsFor: 'accessing' stamp: ''!
children
	^ self content dependencies flatCollect: 
		[ :dependency | 
		dependency users collect: 
			[ :association | | method sentMessages |
			method := association key.
			sentMessages := association value.
			DAMessageSendDependencyNode new
				content: method;
				parentNode: self;
				sentMessages: sentMessages 
				yourself ] ]! !

!DAManuallyAddedDependentPackageNode methodsFor: 'accessing' stamp: ''!
hasChildren
	^ [ self children isNotEmpty ]! !

!DAManuallyAddedDependentPackageNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #smallRedoIcon! !

!DAManuallyAddedDependentPackageNode methodsFor: 'browse-nautilus' stamp: ''!
selectInBrowser
	"Nothing to do"! !

!DAMessageSendAnalyzer commentStamp: ''!
I analyze package sent messages to reveal dependencies.

Examples:
(self on: 'Kernel') difference
(self on: 'Kernel') missingMethodsWithPotentialMatch
(self on: 'Kernel') possibleDeadCode
(self on: 'Kernel') missingDependencies
(self on: 'Kernel') 	missingMethodsWithPotentialMatchAfterMissingDependenciesAddition
!
!DAMessageSendAnalyzer methodsFor: 'accessing' stamp: ''!
missingMethods
	^ self missingMethodsWithPotentialMatch keys! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
missingMethodsWithPotentialMatchAfterManuallyResolvedDependenciesAddition
	| dictionary |
	
	dictionary := Dictionary new.
	self unimplementedCallsInAllDependencies do: [ :selector |
		dictionary 
			at: selector 
			put: (self packagesProvidingSelector: selector) ].
	^ dictionary! !

!DAMessageSendAnalyzer methodsFor: 'accessing' stamp: ''!
packageStaticDependencies	
	^ packageAnalysis dependencies 
		collect: [:each | each target packageName ]
		as: Set! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
possibleDeadCode
	^ self missingMethodsWithPotentialMatch
		select: #isEmpty! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
unimplementedCallsInAllDependencies
	^ self sentMessages difference: self implementedMessagesWithManuallyResolvedDependencies! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
sentMessages
	^ self rPackage methods 
		flatCollect: #messages
		as: Set! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
packagesProvidingSelector: aSelector
	^ self class packagesProvidingSelector: aSelector! !

!DAMessageSendAnalyzer methodsFor: 'initialization' stamp: ''!
initializeWith: aDAPackage
	packageAnalysis := aDAPackage! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
missingMethodsImplementedIn: aPackageName
	^ (RPackageOrganizer default packageNamed: aPackageName) selectors
		intersection: self missingMethods! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
implementedMessagesWithManuallyResolvedDependencies
	^ (self manuallyResolvedDependencies 
		flatCollect: [ :name | (RPackageOrganizer default packageNamed: name) selectors ]
		as: Set)
			addAll: self implementedMessages;
			yourself! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
implementedMessages
	^ (self packageStaticDependencies 
		add: self packageName;
		yourself)
		flatCollect: [ :name | (RPackageOrganizer default packageNamed: name) selectors ]! !

!DAMessageSendAnalyzer methodsFor: 'accessing' stamp: ''!
manuallyResolvedDependencies
	^ self rPackage manuallyResolvedDependencies ! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
missingDependencies
	^ (self missingMethodsWithPotentialMatch
		select: [ :each | each size = 1 ]) flattened asSet! !

!DAMessageSendAnalyzer methodsFor: 'accessing' stamp: ''!
packageName
	^ packageAnalysis packageName! !

!DAMessageSendAnalyzer methodsFor: 'accessing' stamp: ''!
rPackage
	^ packageAnalysis rPackageSet packages detect: [ :each | each packageName = self packageName ]! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
unimplementedCalls
	^ self sentMessages difference: self implementedMessages! !

!DAMessageSendAnalyzer methodsFor: 'computing' stamp: ''!
missingMethodsWithPotentialMatch
	^ missingMethods ifNil: 
		[ missingMethods := Dictionary new.
		self unimplementedCalls do: [ :selector |
		missingMethods
			at: selector 
			put: (self packagesProvidingSelector: selector) ].
		missingMethods ]! !

!DAMessageSendAnalyzer class methodsFor: 'instance creation' stamp: ''!
on: aPackageName
	| packageAnalysis |
	packageAnalysis := ((DAPackageRelationGraph onPackagesNamed: { aPackageName })
				build;
				packages)
			select: #isSeen.
	^ self basicNew
		initializeWith: packageAnalysis first;
		yourself! !

!DAMessageSendAnalyzer class methodsFor: 'utilities' stamp: ''!
packagesProvidingSelector: aSelector
	^ aSelector implementors 
		collect: [:each | each package name]
		as: Set! !

!DAMessageSendAnalyzerTest methodsFor: 'tests' stamp: ''!
testShouldFindDependencyWhenUnimplementedCalls
	self 
		assert: analyzer missingMethods size 
		equals: 3! !

!DAMessageSendAnalyzerTest methodsFor: 'tests' stamp: ''!
testShouldGetPotentialMatchForUnimplementedCalls

	self 
		assert: (analyzer missingMethodsWithPotentialMatch values collect: [:each | each size])
		equals: #(0 2 10).
	self 
		assert: (analyzer missingMethodsWithPotentialMatchAfterManuallyResolvedDependenciesAddition values collect: #size)
		equals: #(0 2 10)! !

!DAMessageSendAnalyzerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	analyzer := DAMessageSendAnalyzer on: 'Tool-DependencyAnalyser-Tests-Data'! !

!DAMessageSendDependency commentStamp: ''!
I represent a potential Dependency on a Package because it implements a method called by the package under analysis but the method is not implemented in the package, neither in the static dependencies of this package (inheritence, reference, trait, extension).!
!DAMessageSendDependency methodsFor: 'testing' stamp: ''!
isMessageSendDependency
	^ true ! !

!DAMessageSendDependency methodsFor: '*Tool-DependencyAnalyser-UI' stamp: ''!
nodeClass
	^ DAMissingMethodNode! !

!DAMessageSendDependency methodsFor: 'accessing' stamp: ''!
users
	^  (source rPackage methods
		select: [ :method | method messages includesAny: implementedMethods ]
		thenCollect: [ :method | method -> (method messages intersection: implementedMethods) ])! !

!DAMessageSendDependency methodsFor: 'setting' stamp: ''!
implementedMethods: aListOfSelectors
	implementedMethods := aListOfSelectors! !

!DAMessageSendDependencyNode commentStamp: ''!
I'm a tree node representing a specific message send in the package under analysis.!
!DAMessageSendDependencyNode methodsFor: 'setting' stamp: ''!
sentMessages: aListOfSelectors 
	sentMessages := aListOfSelectors! !

!DAMessageSendDependencyNode methodsFor: 'displaying' stamp: ''!
label
	^ String streamContents: [ :stream |
		stream
			nextPutAll: self content methodClass asString;
			nextPutAll: '>>';
			nextPutAll: self content selector;
			nextPutAll: ' sends #'.
		sentMessages do: [ :message |
			stream nextPutAll: message ] ]! !

!DAMessageSendNode commentStamp: ''!
I'm a tree node representing a specific message send in the package under analysis.!
!DAMessageSendNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #smallLanguageIcon! !

!DAMessageSendNode methodsFor: 'displaying' stamp: ''!
label
	^ String streamContents: [ :stream |
		stream
			nextPutAll: 'Sent in ';
			nextPutAll: self content methodClass asString;
			nextPutAll: '>>';
			nextPutAll: self content selector ]! !

!DAMethodDependencyNode commentStamp: ''!
A PDMethodNode is the superclass node for PDReferenceDependencyNode and PDExtensionDependencyNode. 
Indeed these two nodes have the same behavior to browse the dependency in the browser
!
!DAMethodDependencyNode methodsFor: 'browse-nautilus' stamp: ''!
selectInBrowser
	self selectMethod: self content method! !

!DAMethodImplementationNode commentStamp: ''!
I'm a tree node representing a method implementation!
!DAMethodImplementationNode methodsFor: 'building-menu' stamp: ''!
addMenuEntriesOn: aMenuGroup
	| method |
	method := self content.
	aMenuGroup
		addMenuItem:
			(MenuItemPresenter new
				name: 'Select this package as the right dependency';
				action:
					[(TheManifestBuilder of: self packageUnderAnalysis packageManifest)
						addManuallyResolvedDependency: method package name.
					"TODO: run the analysis again" ])! !

!DAMethodImplementationNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #packageIcon! !

!DAMethodImplementationNode methodsFor: 'displaying' stamp: ''!
label
	^ String streamContents: [ :stream |
		stream
			nextPutAll: 'Implemented in ';
			nextPutAll: self content package name;
			nextPutAll: ': #';
			nextPutAll: self content methodClass name ]! !

!DAMissingMethodNode commentStamp: ''!
I'm a tree node representing a message send, at least one time, in the package under analysis having no implementor in this package and its dependencies. !
!DAMissingMethodNode methodsFor: 'api' stamp: ''!
messageSendNodes
	^ self messageSendAnalysis rPackage methods
		select: [ :method | method sendsSelector: self content ]
		thenCollect: [ :method | 
			DAMessageSendNode new
				content: method;
				parentNode: self;
				yourself ]! !

!DAMissingMethodNode methodsFor: 'accessing' stamp: ''!
messageSendAnalysis
	^ self parentNode messageSendAnalysis! !

!DAMissingMethodNode methodsFor: 'api' stamp: ''!
methodImplementationNodes
	^ (self content implementors collect: 
		[ :method | 
		DAMethodImplementationNode new
			content: method;
			parentNode: self;
			yourself ])
		sorted: [ :a :b | a content package name < b content package name ]! !

!DAMissingMethodNode methodsFor: 'api' stamp: ''!
hasChildren
	^ true! !

!DAMissingMethodNode methodsFor: 'api' stamp: ''!
buildChildren
	^ self messageSendNodes 
		addAll: self methodImplementationNodes;
		yourself! !

!DAMissingMethodNode methodsFor: 'private' stamp: ''!
packageMethods
	^ self messageSendAnalysis rPackage methods! !

!DAMissingMethodNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #testNotRunIcon! !

!DAMissingMethodNode methodsFor: 'browse-nautilus' stamp: ''!
selectInBrowser
	"Nothing to browse"! !

!DAMissingMethodNode methodsFor: 'displaying' stamp: ''!
label
	^ 'Missing method: #', self content! !

!DANode commentStamp: ''!
This is an abstract class for to display nodes in a tree.!
!DANode methodsFor: 'browse-nautilus' stamp: ''!
browseClass: classToBrowse
	Smalltalk tools browser openOnClass: classToBrowse! !

!DANode methodsFor: 'accessing' stamp: ''!
cycle: anObject
	cycle := anObject! !

!DANode methodsFor: 'testing' stamp: ''!
isPackageNode
 	^ false! !

!DANode methodsFor: 'browse-nautilus' stamp: ''!
selectMethod: aMethod
	| classToBrowse aBrowser compiledMethod |
	aBrowser := self rootNode browser.
	classToBrowse := aMethod methodClass.
	compiledMethod := classToBrowse>>aMethod selector.
	aBrowser selectMethod: compiledMethod! !

!DANode methodsFor: 'building-menu' stamp: ''!
addMenuEntriesOn: aMenuGroup
	"overide this method to add contextual menu on nodes"! !

!DANode methodsFor: 'testing' stamp: ''!
isCycle
	^ cycle! !

!DANode methodsFor: 'accessing' stamp: ''!
packageUnderAnalysis
	^ self rootNode daPackage rPackageSet packages first! !

!DANode methodsFor: 'browse-nautilus' stamp: ''!
spawnNewBrowser
	"do nothing by default"! !

!DANode methodsFor: 'testing' stamp: ''!
isCycleNode
	^ false! !

!DANode methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!DANode methodsFor: 'accessing' stamp: ''!
treeModelParent: anObject
	treeModelParent := anObject! !

!DANode methodsFor: 'browse-nautilus' stamp: ''!
selectClass: aClass
	| aBrowser |
	
	aBrowser := self rootNode browser.
	aBrowser selectClass: aClass! !

!DANode methodsFor: 'testing' stamp: ''!
isClassToDependencyNode
	^ false! !

!DANode methodsFor: 'browse-nautilus' stamp: ''!
selectInBrowser
	^ self subclassResponsibility! !

!DANode methodsFor: 'testing' stamp: ''!
isReferenceNode
	^ false! !

!DANode methodsFor: 'browse-nautilus' stamp: ''!
selectPackage: aPackage
	| aBrowser |
	aBrowser := self rootNode browser.
	aBrowser selectPackage: aPackage! !

!DANode methodsFor: 'accessing' stamp: ''!
treeModelParent
	^ treeModelParent! !

!DANode methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!DANode methodsFor: 'displaying' stamp: ''!
label
	^ self content displayString! !

!DANode methodsFor: 'private' stamp: ''!
rootNode
	| rootNode currentNode |
	currentNode := self.
	rootNode := currentNode parentNode.
	[ rootNode isNil ]
		whileFalse: [ 
			currentNode := rootNode.
			rootNode := currentNode parentNode ].
	^ currentNode.! !

!DANode class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == DANode! !

!DAPackage commentStamp: ''!
I am a PDPackage and i represent a package (RPackageSet) and all his dependencies (PDPackageDependency).

Instance variables :

	- dependencies : a collection of PDPackageDependency (actually the nodes of a graph dependency, from a source PDPackage to a target PDPackage)
	- included : says if the PDPackage is included or not in the set of packages at the beginning.
	- rpackage : the instance of asRPackageSet 	
	- inStack : useful for tarjan algorithm and cycle algorithm. It avoid stack access
	- tarjanIndex and tarjanLowLink : integer for the tarjan algorithm.
	- bfsParent : see cycle algorithm
	- seen : says if all dependencies have been added to the Package!
!DAPackage methodsFor: 'tarjan' stamp: ''!
tarjanIndex
	^ tarjanIndex ! !

!DAPackage methodsFor: 'accessing' stamp: ''!
rPackageSet: anObject
	rPackageSet := anObject! !

!DAPackage methodsFor: 'comparing' stamp: ''!
= aPackage
	(aPackage isKindOf: self class)
		ifFalse: [ ^ false ].
	^ self packageName = aPackage packageName! !

!DAPackage methodsFor: 'adding' stamp: ''!
add: aDependency
	^ dependencies add: aDependency! !

!DAPackage methodsFor: 'accessing' stamp: ''!
beSeen
	seen := true! !

!DAPackage methodsFor: 'accessing' stamp: ''!
dependencies: anObject
	dependencies := anObject! !

!DAPackage methodsFor: 'comparing' stamp: ''!
hash
	^ self packageName hash! !

!DAPackage methodsFor: 'dependencies' stamp: ''!
dependenciesSizeTo: aPackage
	| dependency |
	dependency := dependencies detect: [ :each | each target packageName = aPackage packageName ].
	^ dependency ifNotNil: [ dependency numberOfDependencies ] ifNil: [ 0 ]! !

!DAPackage methodsFor: 'tarjan' stamp: ''!
tarjanIndex: aTarjanIndex
	tarjanIndex := aTarjanIndex! !

!DAPackage methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream
		nextPutAll: 'Dependencies on: ';
		nextPutAll: self packageName! !

!DAPackage methodsFor: 'tarjan' stamp: ''!
tarjanLowLink: aTarjanLowLink
	tarjanLowLink := aTarjanLowLink.! !

!DAPackage methodsFor: 'accessing' stamp: ''!
rPackage
	^ self rPackageSet packages first! !

!DAPackage methodsFor: 'testing' stamp: ''!
isIncluded
	^ included! !

!DAPackage methodsFor: 'accessing' stamp: ''!
dependencies
	^ dependencies! !

!DAPackage methodsFor: 'accessing' stamp: ''!
dependenciesFrom: aClass
	| dependenciesFrom |
	dependenciesFrom := OrderedCollection new.
	self dependencies
		do: [ :compositeDependency | 
				dependenciesFrom addAll: (compositeDependency dependenciesFrom: aClass) ].
	^ dependenciesFrom! !

!DAPackage methodsFor: 'accessing' stamp: ''!
packageName
	^ self rPackageSet packageName! !

!DAPackage methodsFor: 'accessing' stamp: ''!
included: anObject
	included := anObject! !

!DAPackage methodsFor: 'removing' stamp: ''!
remove: aDependency
	^ dependencies remove: aDependency! !

!DAPackage methodsFor: 'tarjan' stamp: ''!
isTarjanUndefined
	^ tarjanIndex = -1! !

!DAPackage methodsFor: 'tarjan' stamp: ''!
tarjanLowLink
	^ tarjanLowLink! !

!DAPackage methodsFor: 'printing' stamp: ''!
displayString
	| numberOfExtension |
	numberOfExtension := self extensionDependenciesSize.
	^ String streamContents: [ :stream | 
		stream
			nextPutAll: self packageName;
			nextPutAll: ' --> Dependent packages : ';
			nextPutAll: self dependentPackagesSize asString;
			nextPutAll: ' | Dependencies : ';
			nextPutAll: (self dependenciesSize - numberOfExtension) asString;
			nextPutAll: ' (+ ';
			nextPutAll: numberOfExtension asString;
			nextPutAll: ' extension dependencies)' ]! !

!DAPackage methodsFor: 'dependencies' stamp: ''!
compositeDependencyTo: aPackage
	^ self dependencies detect: [ :dependency | dependency target = aPackage ] ifNone: [ nil ]! !

!DAPackage methodsFor: 'converting' stamp: ''!
asDependentPackageWrapperOn: relationGraph
	^ DADependentPackageWrapper newWith: self on: relationGraph! !

!DAPackage methodsFor: 'accessing' stamp: ''!
extensionDependenciesSize
	^ self dependencies
		inject: 0
		into: [ :sum :each | sum + each extensionDependenciesSize ]! !

!DAPackage methodsFor: 'accessing' stamp: ''!
referenceDependenciesFrom: aClass

	^ (self dependenciesFrom: aClass) select: [ :each | each isReferenceDependency ]! !

!DAPackage methodsFor: 'initialization' stamp: ''!
clearDependencies
	dependencies := OrderedCollection new! !

!DAPackage methodsFor: 'dependencies' stamp: ''!
dependenciesTo: aPackage
	^ dependencies select: [ :each | each target packageName = aPackage ].! !

!DAPackage methodsFor: 'accessing' stamp: ''!
dependenciesSize

	^ self dependencies 
			inject: 0
			into: [ :sum :dependency |
					sum + dependency numberOfDependencies
				]! !

!DAPackage methodsFor: 'dependencies' stamp: ''!
dependentPackagesSize
	^ dependencies size! !

!DAPackage methodsFor: 'accessing' stamp: ''!
inStack: aBoolean
	inStack := aBoolean! !

!DAPackage methodsFor: 'accessing' stamp: ''!
bfsParent: aBfsParent
	bfsParent := aBfsParent! !

!DAPackage methodsFor: 'dependencies' stamp: ''!
extensionDependenciesSizeTo: aPackage
	^ (self compositeDependencyTo: aPackage) extensionDependenciesSize ! !

!DAPackage methodsFor: 'testing' stamp: ''!
isInStack
	^ inStack! !

!DAPackage methodsFor: 'converting' stamp: ''!
asPackageDependencyWrapper
	^ DAPackageDependencyWrapper newWith: self.! !

!DAPackage methodsFor: 'testing' stamp: ''!
isSeen

	^ seen! !

!DAPackage methodsFor: 'accessing' stamp: ''!
beIncluded
	included := true! !

!DAPackage methodsFor: 'accessing' stamp: ''!
rPackageSet
	^ rPackageSet! !

!DAPackage methodsFor: 'accessing' stamp: ''!
bfsParent
	^ bfsParent! !

!DAPackage methodsFor: 'dependencies' stamp: ''!
dependentPackages
	^ self dependencies 
			inject: Set new 
			into: [ :dependents :each | dependents add: each target; yourself ].! !

!DAPackage methodsFor: 'dependencies' stamp: ''!
removeAllInternal
	dependencies := dependencies reject: [ :each | each isInternal ]! !

!DAPackage methodsFor: 'comparing' stamp: ''!
<= aPackage
	^ (self packageName asString) <= (aPackage packageName asString)! !

!DAPackage methodsFor: 'initialization' stamp: ''!
initializeWithPackage: aRPackageSet
	self initialize.
	self clearDependencies.
	rPackageSet := aRPackageSet.
	included := false.
	inStack := false.
	seen := false.
	tarjanIndex := -1.
	tarjanLowLink := -1.
! !

!DAPackage class methodsFor: 'instance creation' stamp: ''!
new
	self shouldNotImplement! !

!DAPackage class methodsFor: 'instance creation' stamp: ''!
on: aRPackageSet
	^ self basicNew initializeWithPackage: aRPackageSet; yourself! !

!DAPackage class methodsFor: 'instance creation' stamp: ''!
onPackageNamed: aString
	^ self on: (RPackageSet named: aString)! !

!DAPackageAnalyzerCycleDetectionWindow commentStamp: ''!
UI merging SpecTreeModel package dependencies and browser!
!DAPackageAnalyzerCycleDetectionWindow methodsFor: 'initialization - union' stamp: ''!
initializeWithPackageNames: aCollection
	packageAnalyzerTreeModel  := DAPackageCycleDetectionTreePresenter  onPackagesNamed: aCollection.
	self buildandAddAllMorph ! !

!DAPackageAnalyzerCycleDetectionWindow methodsFor: 'update' stamp: ''!
updateWithFilter: aCollectionOfPDPackages
	self packageAnalyzerTreeModel filterWithPackages: aCollectionOfPDPackages.! !

!DAPackageAnalyzerCycleDetectionWindow methodsFor: 'initialization - filter' stamp: ''!
initializeCycleDetectionTreeModelWith: aCollection

	self initializeWithSystemCycles.
	packageAnalyzerTreeModel filterWithPackages: aCollection! !

!DAPackageAnalyzerCycleDetectionWindow methodsFor: 'initialization - filter' stamp: ''!
initializeWithSystemCycles
	packageAnalyzerTreeModel := DAPackageCycleDetectionTreePresenter system.! !

!DAPackageAnalyzerCycleDetectionWindow methodsFor: 'initialization - filter' stamp: ''!
initializeWithFilter: aCollection
	self initializeCycleDetectionTreeModelWith: aCollection.
	self buildandAddAllMorph! !

!DAPackageAnalyzerCycleDetectionWindow class methodsFor: 'instance creation' stamp: ''!
onPackagesMatch: match
	^ (self onPackagesNamed:	self systemPackages) 
		open! !

!DAPackageAnalyzerCycleDetectionWindow class methodsFor: 'examples' stamp: ''!
collections
	^ (self onPackagesMatch: '*Collections*')
		open! !

!DAPackageAnalyzerCycleDetectionWindow class methodsFor: 'examples' stamp: ''!
system
	^ (self new initializeWithFilter: self systemPackages) 
		open! !

!DAPackageAnalyzerDiffTreePresenter commentStamp: ''!
A PDPackageAnalyzerDiffTreeModel is to watch what are the difference between two analysis of dependencies.!
!DAPackageAnalyzerDiffTreePresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	
	treeDiff := self newTree
		multiSelection: true;
		yourself.! !

!DAPackageAnalyzerDiffTreePresenter methodsFor: 'instance creation' stamp: ''!
open	
	^ self openWithSpec! !

!DAPackageAnalyzerDiffTreePresenter methodsFor: 'protocol' stamp: ''!
extent
	^ 900@900! !

!DAPackageAnalyzerDiffTreePresenter methodsFor: 'accessing' stamp: ''!
treeDiff
	^ treeDiff! !

!DAPackageAnalyzerDiffTreePresenter methodsFor: 'initialization' stamp: ''!
initializeWith: oldRelationGraph on: newRelationGraph
	packageRelationGraphDiff := DAPackageRelationGraphDiff new
		oldRelationGraph: oldRelationGraph;
		newRelationGraph: newRelationGraph.
	packageRelationGraphDiff make.
	
	self buildRoots
	
	! !

!DAPackageAnalyzerDiffTreePresenter methodsFor: 'initialization' stamp: ''!
buildRoots
	self treeDiff roots: packageRelationGraphDiff packagesDiffToDisplay.
	self treeDiff whenBuiltDo: [ treeDiff rootNodeHolder: [ :item | DAPackageItemDiffNode new content: item ] ]! !

!DAPackageAnalyzerDiffTreePresenter methodsFor: 'protocol' stamp: ''!
title
	^ 'Package Dependencies Analysis Diff'
	! !

!DAPackageAnalyzerDiffTreePresenter class methodsFor: 'instance creation' stamp: ''!
newWith: oldRelationGraph on: newRelationGraph
	^ self new
		initializeWith: oldRelationGraph on: newRelationGraph;
		yourself.! !

!DAPackageAnalyzerDiffTreePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed newColumn: [ :col | col add: #treeDiff ] yourself! !

!DAPackageAnalyzerPackageDependenciesWindow commentStamp: ''!
UI merging SpecTreeModel cycles and browser!
!DAPackageAnalyzerPackageDependenciesWindow methodsFor: 'initialization' stamp: ''!
initializeWithPackageNames: aCollection
	packageAnalyzerTreeModel := DAPackageAnalyzerTreePresenter onPackagesNamed: aCollection.
	self buildandAddAllMorph ! !

!DAPackageAnalyzerPackageDependenciesWindow methodsFor: 'initialization' stamp: ''!
initializeWithRelationGraph: aRelationGraph
	packageAnalyzerTreeModel := DAPackageAnalyzerReverseTreePresenter onRelationGraph: aRelationGraph.
	self buildandAddAllMorph ! !

!DAPackageAnalyzerPackageDependenciesWindow class methodsFor: 'instance creation' stamp: ''!
onPackagesMatch: match
	^ (self onPackagesNamed:
			(RPackageOrganizer default packages
				select: [ :package | match match: package packageName asString ]
				thenCollect: [ :package | package packageName ]) ) ! !

!DAPackageAnalyzerPackageDependenciesWindow class methodsFor: 'examples' stamp: ''!
collections
	^ (self onPackagesMatch: '*Collections*') open! !

!DAPackageAnalyzerPackageDependenciesWindow class methodsFor: 'examples' stamp: ''!
system
	^ (self onPackagesNamed: self systemPackages) open ! !

!DAPackageAnalyzerReverseTreePresenter commentStamp: ''!
A PDPackageAnalyzerReverseTreeModel shows all users from a set of packages. Also you can see all type of the dependency, and browse them.

The window is initialized with a relation graph of package dependencies, with all the dependencies already compute.!
!DAPackageAnalyzerReverseTreePresenter methodsFor: 'private' stamp: ''!
updatePackageLabel
	self packageLabel label: 'Analysis of ' , self tree roots size asString , ' package(s)'! !

!DAPackageAnalyzerReverseTreePresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	super initializeWidgets.
	
	packageLabel := self newLabel label: 'Analysis of packages'.! !

!DAPackageAnalyzerReverseTreePresenter methodsFor: 'actions' stamp: ''!
refresh
		self isOpen ifTrue: [  
			self relationGraph refreshGraph.
			self buildRoots].! !

!DAPackageAnalyzerReverseTreePresenter methodsFor: 'accessing' stamp: ''!
relationGraph
	^ relationGraph! !

!DAPackageAnalyzerReverseTreePresenter methodsFor: 'private' stamp: ''!
buildRoots
	| collectionOfWrapper |
	collectionOfWrapper := relationGraph allDependentPackagesFromSeenPackages
		collect: [ :package | package asDependentPackageWrapperOn: relationGraph ].
	
	self tree roots: (self nodesFor: collectionOfWrapper asSortedCollection).
	self updatePackageLabel.! !

!DAPackageAnalyzerReverseTreePresenter methodsFor: 'initialization' stamp: ''!
initializeWithRelationGraph: aRelationGraph
	relationGraph := aRelationGraph.
	self buildRoots.! !

!DAPackageAnalyzerReverseTreePresenter methodsFor: 'private' stamp: ''!
nodesFor: anItemList
	^ anItemList collect: 
		[ :each | 
		DAReversePackageNode new
						content: each;
						treeModelParent: self;
						browser: self browser;
						cycle: false;
						yourself ]! !

!DAPackageAnalyzerReverseTreePresenter methodsFor: 'accessing' stamp: ''!
packageLabel
	^ packageLabel! !

!DAPackageAnalyzerReverseTreePresenter methodsFor: 'api' stamp: ''!
title
	^ 'Package Dependencies Reverse Analysis'! !

!DAPackageAnalyzerReverseTreePresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	super initializePresenter.
	
	tree
		whenSelectedItemChanged: [ :item | 
			item
				ifNotNil: [ 
					self tree selectedItem selectInBrowser.
					tree menu: [ :aMenu | self loadMenuFor: item in: aMenu ] ] ].! !

!DAPackageAnalyzerReverseTreePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newColumn:
			[ :col | 
			col
				newRow: [ :row | row add: #buttonRefresh ] height: 30;
				newRow: [ :row | 
							row
								add: #packageLabel ]
					height: 30;
				add: #tree ] yourself! !

!DAPackageAnalyzerReverseTreePresenter class methodsFor: 'instance creation' stamp: ''!
onRelationGraph: aRelationGraph
	^ self new
		initializeWithRelationGraph: aRelationGraph;
		yourself! !

!DAPackageAnalyzerTreePresenter commentStamp: ''!
A PDPackageAnalyzerTreeModel shows all dependent packages from a set of packages. Also you can see all type of the dependency, and browse them.!
!DAPackageAnalyzerTreePresenter methodsFor: 'actions' stamp: ''!
resetFilter
	^ self filter: nil! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
treeRoots
	^ self tree roots! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
actionOnDefaultSettings
	self buttonDefault
		action: [ 
			self resetDefaultSettings.
			self buildRoots ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
seenPackagesName
	^ self relationGraph seenPackagesName! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
sizeOfRoots
	^ self treeRoots size! !

!DAPackageAnalyzerTreePresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	super initializeWidgets.
	packageLabel := self newLabel label: 'Analysis of packages'.
	textPackageField := self newTextInput
		ghostText: 'Enter a package name';
		entryCompletion: self packagesEntryCompletion.
	self initializeButtons! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
actionOnButtons

	self
		actionOnBrowseCycles;
		actionWhenTextFieldChanged;
		actionOnDefaultSettings;
		actionOnRemovePackage;
		actionOnAddPackage;
		 actionOnGenerateGraphViz;
		actionOnReverseAnalysis;
		actionOnSave.! !

!DAPackageAnalyzerTreePresenter methodsFor: 'actions' stamp: ''!
refresh
	self isOpen ifTrue: [  
			self relationGraph refreshGraph.
			self buildRoots].
		! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
actionOnReverseAnalysis
	buttonReverseAnalysis action: [ 
		(DAPackageAnalyzerPackageDependenciesWindow new 
						initializeWithRelationGraph: self relationGraph) 
					open ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'saving' stamp: ''!
defaultDirectory
	^ 'saving'! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
actionOnBrowseCycles
	buttonBrowseCycles action: [ self actionOnFindCycles ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
actionOnSave
	self buttonSave 
		action: [ self saveCurrentRelationGraph ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
filter: aString
	filter := aString! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
relationGraph
	^ relationGraph! !

!DAPackageAnalyzerTreePresenter methodsFor: 'saving' stamp: ''!
createDirectoryForSaving
	| dir |
	dir := FileSystem workingDirectory / self defaultDirectory.
	dir ensureCreateDirectory! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
filter
	^ filter! !

!DAPackageAnalyzerTreePresenter methodsFor: 'initialization' stamp: ''!
initializeButtons
	buttonBrowseCycles := self newButton
		help: 'Find all the cycles where the package is in the system';
		label: 'Find cycles'.
	buttonDefault := self newButton
		help: 'Back to the default settings';
		label: 'Default settings'.
	buttonAddPackage := self newButton
		help: 'Add package to the current analysis';
		label: 'Add packages';
		icon: (Smalltalk ui icons iconNamed: #addIcon).
	buttonRemovePackage := self newButton
		help: 'Remove package to the current analysis';
		label: 'Remove packages';
		icon: (self iconNamed: #removeIcon).
	buttonGenerateGraphViz := self newButton
		help: 'Open the graph in world';
		label: 'Open the graph'.
	buttonReverseAnalysis := self newButton
		help: 'Reverse the analysis : set the dependent packages as root packages';
		label: 'Reverse the analysis'.
	buttonSave := self newButton
		help: 'Serialize the current object relation graph dependencies';
		label: 'Save current analysis'.
	buttonMakeDiff := self newButton 
		label: 'Make diff'! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
buttonSave
	^ buttonSave! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
textPackageField
	^ textPackageField! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
buttonGenerateGraphViz
	^ buttonGenerateGraphViz! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
relationGraph: anObject
	| warnings alertMessage |
	warnings := Set new.
	relationGraph := anObject.

	[ self relationGraph build ]
		on: PotentialOutDatedDependencyWarning 
		do: [ :ex | warnings add: ex. ex resume ].
	self buildRoots.
	alertMessage := 'Some dependencies declared in ' ,
		self relationGraph packagesName first,
		' Manifest as manuallyResolvedDependencies not detected as a dependency!! Please check :' , String cr.
	warnings 	ifNotEmpty: [ 
		UIManager default 
			alert: alertMessage , (String cr join: (warnings collect: #dependency ))
			title: 'Potential outdated dependencies' ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
actionWhenTextFieldChanged
	textPackageField
		whenTextChanged: [ textPackageField text
				ifEmpty: [ self resetFilter ]
				ifNotEmpty: [ self filter: textPackageField text ].
			self buildRoots ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
buttonMakeDiff
	^ buttonMakeDiff! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
actionOnRemovePackage
	| packagesToRemove |
	self buttonRemovePackage
		action: [ 
			self selectedItemsFromTree
				ifNotEmpty: [ 
					packagesToRemove := self selectedItemsFromTree.
					packagesToRemove do: [ :item | self relationGraph removePackage: item content packageName ].
					self buildRoots ] ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
buttonAddPackage
	^ buttonAddPackage! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
packageLabel
	^ packageLabel! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
buttonBrowseCycles
	^ buttonBrowseCycles! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
packagesEntryCompletion
	| applicants |
	applicants := (RPackageOrganizer default packages collect: [ :package | package packageName asString ]).

	^ EntryCompletion new
				dataSourceBlock: [:currText | applicants];
				filterBlock: [:currApplicant :currText | currText size > 3
						and: [currApplicant asUppercase includesSubstring: currText asString asUppercase]].! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
title
	^ 'Dependencies analysis'! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
updatePackageLabel
	self packageLabel label: 'Analysis of ' , self sizeOfRoots asString , ' package(s)'! !

!DAPackageAnalyzerTreePresenter methodsFor: 'saving' stamp: ''!
saveCurrentRelationGraph
	self createDirectoryForSaving.
	^  FLSerializer serialize: relationGraph toFileNamed: self defaultName. ! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
initializeWithRPackageSet: aCollection
	self relationGraph: (DAPackageRelationGraph onPackages: (aCollection collect: [ :each | DAPackage on: each ]))! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
relationGraphOnReverse: anObject
	relationGraph := anObject.
	self relationGraph build.
	self buildReverseRoots! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
extent
	^ 700@500! !

!DAPackageAnalyzerTreePresenter methodsFor: 'actions' stamp: ''!
resetDefaultSettings
	self resetFilter.
	self textPackageField text: ''! !

!DAPackageAnalyzerTreePresenter methodsFor: 'actions' stamp: ''!
buildRoots
	| matching roots |
	roots := self filter
		ifNotNil: [ :f | 
			matching := '*' , f , '*'.
			self nodesFor: (relationGraph seenPackagesWithFilter: matching) ]
		ifNil: [ self nodesFor: relationGraph seenPackages ].
	self tree roots: roots.
	self updatePackageLabel! !

!DAPackageAnalyzerTreePresenter methodsFor: 'saving' stamp: ''!
defaultName
	^ self defaultDirectory, '/relationGraph.FL'! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
actionOnAddPackage
	self buttonAddPackage action: [ (DAAddPackagePresenter 
					new 
					packageAnalyzerTreeModel: self)
					open ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
actionOnFindCycles
	| selectedPackages selectedItems |
	selectedItems := self selectedItemsFromTree.
	(self arePackageNodes: selectedItems)
		ifTrue: [ 
			self notify: 'This could take a while, confirm?'.
			selectedPackages := self pdPackagesFrom: selectedItems.
			systemCycles ifNil: [ systemCycles := DAPackageAnalyzerCycleDetectionWindow  system ].
			systemCycles
				updateWithFilter: selectedPackages;
				open ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
buttonRemovePackage
	^ buttonRemovePackage! !

!DAPackageAnalyzerTreePresenter methodsFor: 'private' stamp: ''!
nodesFor: anItemList 
	^ anItemList sorted collect: 
		[ :each | 
		DAPackageUnderAnalysisNode new
			content: each;
			cycle: false;
			treeModelParent: self;
			browser: self browser;
			yourself ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'protocol' stamp: ''!
actionOnGenerateGraphViz
	| graphvizGenerator |
	buttonGenerateGraphViz
		action: [  
			self ifGraphVizAbsent: [ self error: 'Please install Graphviz Support' ].
			graphvizGenerator := DAPackageRelationGraphGenerator newWith: self relationGraph named: 'PackageDependencyGraph'.
			self saveGraphAndOpenWith: graphvizGenerator ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
buttonReverseAnalysis
	^ buttonReverseAnalysis! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
pdPackagesFrom: selectedItems
	^ selectedItems collect: [ :item | DAPackage on: (RPackageSet named: item content packageName asString) ]! !

!DAPackageAnalyzerTreePresenter methodsFor: 'accessing' stamp: ''!
buttonDefault
	^ buttonDefault! !

!DAPackageAnalyzerTreePresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	super initializePresenter.
	self actionOnButtons.
	tree
		whenSelectedItemChanged: [ :item |
			item
				ifNil: [ buttonBrowseCycles enabled: false ]
				ifNotNil: [ 
					buttonBrowseCycles enabled: true.
					tree menu: [ :aMenu | self loadMenuFor: item in: aMenu ].
					self tree selectedItem selectInBrowser ] ]! !

!DAPackageAnalyzerTreePresenter class methodsFor: 'examples' stamp: ''!
onPackagesMatch: match
	^ (self onPackagesNamed:
			(RPackageOrganizer default packages
				select: [ :package | match match: package packageName asString ]
				thenCollect: [ :package | package packageName ]) )! !

!DAPackageAnalyzerTreePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newColumn:
			[ :col | 
			col
				newRow: [ :row | 
							row
								add: #textPackageField;
								add: #buttonBrowseCycles;
								add: #buttonRefresh;
								add: #buttonDefault
								 ]
					height: 30;
				newRow: [ :row | 
							row
								add: #packageLabel ]
					height: 20;
				add: #tree;
				newRow: [ :row | 
							row
								add: #buttonAddPackage;
								add: #buttonRemovePackage;
								"add: #buttonGenerateGraphViz;"
								"add: #buttonMakeDiff;"
								add: #buttonReverseAnalysis
								 ]
					height: 30 ]	
					  yourself! !

!DAPackageAnalyzerTreePresenter class methodsFor: 'instance creation' stamp: ''!
onPackagesNamed: aCollection
	^ self onPackages: (aCollection collect: [ :each | RPackageSet named: each ])! !

!DAPackageAnalyzerTreePresenter class methodsFor: 'instance creation' stamp: ''!
onPackages: aCollection
	^ self new
		initializeWithRPackageSet: aCollection;
		yourself! !

!DAPackageAnalyzerWindow commentStamp: ''!
A DAPackageAnalyzerWindow class is an abstract class.
It represents the UI merging the SpecTreeModel (package dependencies or cycles) and browser.

The main feature is to browse automatically in the browser when you click on a node (package or dependency).
!
!DAPackageAnalyzerWindow methodsFor: 'open/close' stamp: ''!
delete
	self packageAnalyzerTreeModel close.
	^ super delete! !

!DAPackageAnalyzerWindow methodsFor: 'accessing' stamp: ''!
packageAnalyzerTreeModel
	^ packageAnalyzerTreeModel! !

!DAPackageAnalyzerWindow methodsFor: 'building' stamp: ''!
buildMorphWindowForTreeModel
	| specWindow |
	packageAnalyzerTreeModel
		open;
		delete.
	
	specWindow := self specWindowFrom: packageAnalyzerTreeModel.
	^ specWindow! !

!DAPackageAnalyzerWindow methodsFor: 'morphic ui' stamp: ''!
initialExtent
	^ (1500@800)! !

!DAPackageAnalyzerWindow methodsFor: 'accessing' stamp: ''!
open
	^ self openInWorld.
	! !

!DAPackageAnalyzerWindow methodsFor: 'building' stamp: ''!
buildBrowserWindow

	^browser buildWindow! !

!DAPackageAnalyzerWindow methodsFor: 'building' stamp: ''!
specWindowFrom: aSpec
	| windowPresenter specWindow |
	windowPresenter := aSpec window.
	specWindow := windowPresenter window.
	^ specWindow! !

!DAPackageAnalyzerWindow methodsFor: 'adding' stamp: ''!
panelMorphFrom: aSpecWindow
	aSpecWindow submorphs
		do: [ :submorph | 
			(submorph isKindOf: PanelMorph)
				ifTrue: [ ^ submorph ] ].
	^ nil! !

!DAPackageAnalyzerWindow methodsFor: 'initialization - filter' stamp: ''!
buildandAddAllMorph
	browser := packageAnalyzerTreeModel browser.
	self addAllMorph! !

!DAPackageAnalyzerWindow methodsFor: 'adding' stamp: ''!
addAllMorph
	| browserWindow  windowTreeModel |
	browserWindow := self buildBrowserWindow.	
	windowTreeModel := self buildMorphWindowForTreeModel.
	self
		addMorph: browserWindow frame: (0.4 @ 0 corner: 1 @ 1);
		addMorph:  (self panelMorphFrom: windowTreeModel) frame: (0 @ 0 corner: 0.4 @ 1).! !

!DAPackageAnalyzerWindow methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^ 'Package Dependencies Analysis'! !

!DAPackageAnalyzerWindow class methodsFor: 'accessing' stamp: ''!
selectedPackagesFrom: aBuilder
	| target selectedPackages |
	target := aBuilder model.
	selectedPackages := target selectedPackages collect: [ :rpackage | rpackage packageName asString ].
	^ selectedPackages! !

!DAPackageAnalyzerWindow class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == DAPackageAnalyzerWindow! !

!DAPackageAnalyzerWindow class methodsFor: 'examples' stamp: ''!
systemPackages
	^ RPackageOrganizer default packages collect: [ :package | package packageName asString ]! !

!DAPackageAnalyzerWindow class methodsFor: 'instance creation' stamp: ''!
onPackagesNamed: aCollection
	^ self new 
		initializeWithPackageNames: aCollection;
		yourself! !

!DAPackageCycle commentStamp: ''!
A PDPackageCycle is used to represent a cycle among packages. 	
All the packages in the cycle are stored in a Collection, in the their name alphabetical order.

As soon as possible, they will be stored in the order they have been found.!
!DAPackageCycle methodsFor: 'displaying' stamp: ''!
displayString
	^ String streamContents: [ :stream |
		stream
			nextPutAll: 'A cycle of ';
			print: self size;
			nextPutAll: ' packages : '.
		packages
			do: [ :package | stream nextPutAll: package packageName ]
			separatedBy: [ stream space ] ]! !

!DAPackageCycle methodsFor: 'accessing' stamp: ''!
packages: anObject
	packages := anObject! !

!DAPackageCycle methodsFor: 'private' stamp: ''!
removeOutgoingDependencies: aPackage
	
	| removals |
	packages := packages copy.
	removals := aPackage dependencies reject: [ :dependency | self packages includes: (dependency target) ].
	
	removals do: [ :each | aPackage remove: each ].! !

!DAPackageCycle methodsFor: 'comparing' stamp: ''!
= aPDPackageCycle
	(aPDPackageCycle isKindOf: self class) ifFalse: [ ^ false ]. 
	^ self size = aPDPackageCycle size and: [ self packages includesAll: aPDPackageCycle packages ].! !

!DAPackageCycle methodsFor: 'accessing' stamp: ''!
dependentPackagesFrom: aPackage
	"only the dependent packages from the cycle"
	^ aPackage dependentPackages select: [ :package |
		self packages includes: package
		 ]! !

!DAPackageCycle methodsFor: 'comparing' stamp: ''!
hash
	^ self packages hash.! !

!DAPackageCycle methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	packages := OrderedCollection new.! !

!DAPackageCycle methodsFor: 'adding' stamp: ''!
addPackage: aPDPackage
	packages add: aPDPackage! !

!DAPackageCycle methodsFor: 'actions' stamp: ''!
removeOutgoingDependencies
	self packages do: [ :package | self removeOutgoingDependencies: package ].! !

!DAPackageCycle methodsFor: 'testing' stamp: ''!
hasOutgoingDependencies: aPackage
	^ aPackage dependencies anySatisfy: [ :dependency | (self packages includes: (dependency target)) not ].! !

!DAPackageCycle methodsFor: 'accessing' stamp: ''!
packageAt: anInteger
	^ packages at: anInteger! !

!DAPackageCycle methodsFor: 'accessing' stamp: ''!
packages
	^ packages! !

!DAPackageCycle methodsFor: 'accessing' stamp: ''!
size
	^ packages size! !

!DAPackageCycle methodsFor: 'accessing' stamp: ''!
reversedCycle
	packages := packages reversed! !

!DAPackageCycle methodsFor: 'comparing' stamp: ''!
> aPDPackageCycle
	^ (self size) > (aPDPackageCycle size)
! !

!DAPackageCycle methodsFor: 'testing' stamp: ''!
isAtLeastInCycle: aCollectionOfPDPackage
	^ aCollectionOfPDPackage anySatisfy: [ :package | self isInCycle: package ]! !

!DAPackageCycle methodsFor: 'adding' stamp: ''!
addAllPackages: aCollection
	
	aCollection do: [ :package | self addPackage: package].! !

!DAPackageCycle methodsFor: 'comparing' stamp: ''!
<= aPDPackageCycle
	^ (self size) <= (aPDPackageCycle size)
! !

!DAPackageCycle methodsFor: 'testing' stamp: ''!
isInCycle: aPackage
	^ packages includes: aPackage! !

!DAPackageCycle class methodsFor: 'instance creation' stamp: ''!
new
	^ self basicNew initialize; yourself.! !

!DAPackageCycleDetectionTreePresenter commentStamp: ''!
A PDPackageDetectCycleTreeModel shows all cycles among packages from a graph of dependencies.!
!DAPackageCycleDetectionTreePresenter methodsFor: 'protocol' stamp: ''!
title
	^ 'Cycles analysis'! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'accessing' stamp: ''!
analysis: anObject
	analysis := anObject! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'filtering' stamp: ''!
filterWithPackages: aCollectionOfPDPackage
	filter := aCollectionOfPDPackage.
	self cycles: (self analysis cyclesWithAtLeast: filter)! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	super initializeWidgets.
	
	cyclesLabel := self newLabel
			label: 'Analysis of cycles'.
	
	buttonReversed := self newButton
			help: 'Reversed the order of cycles';
			label: 'Sort by length'.
	
		
	
	
		! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'accessing' stamp: ''!
cyclesLabel
	^ cyclesLabel! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'accessing' stamp: ''!
cycles: aCollectionOfCycles
	cycles := aCollectionOfCycles sorted: [ :a :b | a size > b size ].
	self buildRoots.! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'actions' stamp: ''!
refresh
	self analysis refresh.
	self filter ifNil: [ self cycles: self analysis cycles ]
		ifNotNil: [ self cycles: (self analysis cyclesWithAtLeast: filter) ].
	self buildRoots! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'protocol' stamp: ''!
extent
	^ 1000@600! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'accessing' stamp: ''!
filter
	^ filter! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'initialization' stamp: ''!
initializeWithPackageName: aCollection
	
	self analysis:  (DAPackageCycleDetector onPackagesNamed: aCollection) runAlgorithm.
	
	self cycles: self analysis cycles.! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'accessing' stamp: ''!
buildRoots
	self tree
		roots: cycles;
		whenBuiltDo: [ 
					tree
						rootNodeHolder: [ :item | 
							DACycleNode new
								content: item;
								treeModelParent: self;
								browser: self browser;
								cycle: true ] ].
	self cyclesLabel
		label:
			'Analysis of ' , self cycles size asString , ' cycles'.! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'accessing' stamp: ''!
cycles
	^ cycles! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'accessing' stamp: ''!
buttonReversed
	^ buttonReversed! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'accessing' stamp: ''!
reversedRoots
	self tree roots: (self tree roots reversed).! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'accessing' stamp: ''!
analysis
	^ analysis! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'filtering' stamp: ''!
filterWithPackages
	
	self cycles: (self analysis cyclesWithAtLeast: filter)! !

!DAPackageCycleDetectionTreePresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	super initializePresenter.
	
	buttonReversed action: [ self reversedRoots  ].
	
	
	
	tree
		whenSelectedItemChanged: [ :item | 
			item
				ifNotNil: [ 
					self tree selectedItem selectInBrowser.
					tree menu: [ :aMenu | self loadMenuFor: item in: aMenu ] ] ]! !

!DAPackageCycleDetectionTreePresenter class methodsFor: 'instance creation' stamp: ''!
system
	^ self onPackagesNamed: 
		(RPackageOrganizer default packages collect: [ :package | package packageName asString ])! !

!DAPackageCycleDetectionTreePresenter class methodsFor: 'instance creation' stamp: ''!
onPackagesMatch: match
	^ (self onPackagesNamed:
			(RPackageOrganizer default packages
				select: [ :package | match match: package packageName asString ]
				thenCollect: [ :package | package packageName ]) ) ! !

!DAPackageCycleDetectionTreePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newColumn:
			[ :col | 
			col
				newRow: [ :row | 
							row
								add: #buttonReversed;
								add: #buttonRefresh ]
					height: 30;
				newRow: [ :row | 
							row
								add: #cyclesLabel ]
					height: 30;
				add: #tree ] yourself! !

!DAPackageCycleDetectionTreePresenter class methodsFor: 'instance creation' stamp: ''!
onPackagesNamed: aCollection
	^ self new 
		initializeWithPackageName: aCollection;
		yourself! !

!DAPackageCycleDetector commentStamp: ''!
I'm able to detect all the cycles in a package dependency graph.

Analysis is done in three steps: build the dependency graph, isolating the strongly connected components (SCC), and for each SCC detect all the elementary cycles.

Use the message runAlgorithm to run the algorithm to retrieve the elementary cycles in the package dependency graph.

 At the end, all the cycles are in the collection "cycles".!
!DAPackageCycleDetector methodsFor: 'initialization' stamp: ''!
initializeQueueWith: package

	package bfsParent: nil.	
	package inStack: true.
	queue := WaitfreeQueue new.
	queue nextPut: package! !

!DAPackageCycleDetector methodsFor: 'actions' stamp: ''!
enqueue: aNode
	queue nextPut: aNode! !

!DAPackageCycleDetector methodsFor: 'accessing' stamp: ''!
refresh
	self relationGraph refreshGraph.
	self 
		reset;
		runAlgorithm.! !

!DAPackageCycleDetector methodsFor: 'accessing' stamp: ''!
cyclesWithAtLeast: aCollectionOfPDPackage
	^ cycles select: [ :cycle | cycle isAtLeastInCycle: aCollectionOfPDPackage ]! !

!DAPackageCycleDetector methodsFor: 'actions' stamp: ''!
buildCycleUntil: children
	| aPackageCycle currentNode |
	aPackageCycle := DAPackageCycle new.
	currentNode := children.
	[ currentNode isNil ]
		whileFalse: [ 
			aPackageCycle addPackage: currentNode.
			currentNode := currentNode bfsParent ].
	(self cycleAlreadyFound: aPackageCycle)
		ifFalse: [ 
			aPackageCycle reversedCycle.
			self addCycle: aPackageCycle ]! !

!DAPackageCycleDetector methodsFor: 'accessing' stamp: ''!
stronglyConnectedComponents
	^ sccs! !

!DAPackageCycleDetector methodsFor: 'accessing' stamp: ''!
relationGraph
	^ relationGraph! !

!DAPackageCycleDetector methodsFor: 'actions' stamp: ''!
findCycles: stronglyConnectedComponents
	stronglyConnectedComponents packages
		do: [ :package | 
			self findAllCyclesFrom: stronglyConnectedComponents for: package 
			]! !

!DAPackageCycleDetector methodsFor: 'actions' stamp: ''!
findAllCyclesFrom: stronglyConnectedComponents for: package
	| parents |
	self initializeVisitedNodes.
	parents := self parentsFrom: stronglyConnectedComponents For: package.
	self initializeQueueWith: package.
	 [ parents isEmpty ] whileFalse: [ self startBfsFrom: stronglyConnectedComponents For: parents ]! !

!DAPackageCycleDetector methodsFor: 'adding' stamp: ''!
addCycle: aPDPackageCycle
	cycles add: aPDPackageCycle! !

!DAPackageCycleDetector methodsFor: 'initialization' stamp: ''!
reset
	cycles := SortedCollection new.
	visitedNodes := nil.
	queue := nil! !

!DAPackageCycleDetector methodsFor: 'initialization' stamp: ''!
initializeVisitedNodes
	
	visitedNodes := Set new.
! !

!DAPackageCycleDetector methodsFor: 'accessing' stamp: ''!
visitedNodes
	^ visitedNodes! !

!DAPackageCycleDetector methodsFor: 'actions' stamp: ''!
startBfsFrom: stronglyConnectedComponents For: parents
	| dequeue childrens |
	dequeue := self dequeue.
	childrens := self childrensFrom: stronglyConnectedComponents for: dequeue.
	childrens
		do: [ :children | 
			(self isVisitedOrInQueue: children)
				ifFalse: [ 
					children bfsParent: dequeue.
					self enqueue: children ].
			(parents includes: children)
				ifTrue: [ 
					self buildCycleUntil: children.
					parents remove: children ] ].
	self addVisitedNodes: dequeue! !

!DAPackageCycleDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	cycles := SortedCollection new.
	sccs := OrderedCollection new.! !

!DAPackageCycleDetector methodsFor: 'actions' stamp: ''!
runAlgorithm
	self stronglyConnectedComponents
		do: [ :scc | self findCycles: scc ]
		displayingProgress: 'finding cycles'! !

!DAPackageCycleDetector methodsFor: 'testing' stamp: ''!
cycleAlreadyFound: aPackageCycle
	^ cycles anySatisfy: [ :cycle | cycle = aPackageCycle ]! !

!DAPackageCycleDetector methodsFor: 'accessing' stamp: ''!
cycles: anObject
	cycles := anObject! !

!DAPackageCycleDetector methodsFor: 'accessing' stamp: ''!
cyclesWith: aPDPackage
	^ cycles select: [ :cycle |
			cycle isInCycle: aPDPackage
		 ]! !

!DAPackageCycleDetector methodsFor: 'initialization' stamp: ''!
initializeWithRPackageSet: aCollection
	relationGraph := DAPackageRelationGraph onPackages: (aCollection collect: [ :each | DAPackage on: each ]).
	cycles := OrderedCollection new.
	self relationGraph build.
	sccs := DATarjanAlgorithm new
		run: self relationGraph;
		stronglyConnectedComponents! !

!DAPackageCycleDetector methodsFor: 'accessing' stamp: ''!
parentsFrom: stronglyConnectedComponents For: aNode
	^ stronglyConnectedComponents predecessors: aNode! !

!DAPackageCycleDetector methodsFor: 'accessing' stamp: ''!
cycles
	^ cycles sorted: [ :a :b | a size < b size ]! !

!DAPackageCycleDetector methodsFor: 'testing' stamp: ''!
isVisitedOrInQueue: aNode
	^ (visitedNodes includes: aNode) or: [ aNode isInStack ]! !

!DAPackageCycleDetector methodsFor: 'adding' stamp: ''!
addVisitedNodes: aNode 
	visitedNodes add: aNode! !

!DAPackageCycleDetector methodsFor: 'accessing' stamp: ''!
childrensFrom: stronglyConnectedComponents for: aNode
	^ stronglyConnectedComponents successors: aNode! !

!DAPackageCycleDetector methodsFor: 'actions' stamp: ''!
dequeue
	| aNode |
	aNode := queue nextOrNil.
	aNode ifNotNil: [ aNode inStack: false ].
	^ aNode! !

!DAPackageCycleDetector class methodsFor: 'instance creation' stamp: ''!
new
	^ self onPackagesNamed: #()! !

!DAPackageCycleDetector class methodsFor: 'instance creation' stamp: ''!
collections
	^ (self onPackagesNamed: #('Collections-Abstract' 'Collections-Arithmetic' 'Collections-Arrayed' 'Collections-Atomic' 'Collections-Native' 'Collections-Sequenceable' 'Collections-Stack' 'Collections-Streams' 'Collections-Strings' 'Collections-Support' 'Collections-Traits' 'Collections-Unordered' 'Collections-Weak')) runAlgorithm.! !

!DAPackageCycleDetector class methodsFor: 'instance creation' stamp: ''!
morphic
	^ (self onPackagesNamed: #('Morphic-Base' 'Morphic-Core' 'Morphic-Examples' 'MorphicTests' 'Spec-MorphicAdapters')) runAlgorithm.! !

!DAPackageCycleDetector class methodsFor: 'instance creation' stamp: ''!
system
	^ (self onPackagesNamed: 
		(RPackageOrganizer default packages collect: [ :package | package packageName asString ])) runAlgorithm.! !

!DAPackageCycleDetector class methodsFor: 'instance creation' stamp: ''!
onPackagesNamed: aCollection
	^ self onPackages: (aCollection collect: [ :each | RPackageSet named: each ])! !

!DAPackageCycleDetector class methodsFor: 'instance creation' stamp: ''!
onPackages: aCollection
	^ self basicNew 
		initializeWithRPackageSet: aCollection;
		yourself! !

!DAPackageCycleDetectorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	aPackageCycleDetection := DAPackageCycleDetector new.
	packageA := DAPackage on: (RPackageSet named: 'A').
	packageB := DAPackage on: (RPackageSet named: 'B').
	packageC := DAPackage on: (RPackageSet named: 'C').
	packageD := DAPackage on: (RPackageSet named: 'D').
	packageE := DAPackage on: (RPackageSet named: 'E').
	cycleA := DAPackageCycle new.
	cycleB := DAPackageCycle new.
	cycleC := DAPackageCycle new.! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testBuildCycleUntil
	| cycle |
	packageA bfsParent: packageB.
	packageB bfsParent: packageC.
	packageC bfsParent: packageD.
	aPackageCycleDetection buildCycleUntil: packageA.
	self assert: self cyclesSize equals: 1.
	aPackageCycleDetection buildCycleUntil: packageA.
	"cycle already present"
	self assert: self cyclesSize equals: 1.
	cycle := aPackageCycleDetection cycles first.
	self assert: (cycle isInCycle: packageA).
	self assert: (cycle isInCycle: packageB).
	self assert: (cycle isInCycle: packageC).
	self assert: (cycle isInCycle: packageD)! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testReset
	| aPDPackageRelation |
	aPDPackageRelation := self graphWithThreeCycles.
	aPackageCycleDetection findCycles: aPDPackageRelation.
	self assert: aPackageCycleDetection cycles size equals: 3.
	aPackageCycleDetection reset.
	self assertEmpty: aPackageCycleDetection cycles! !

!DAPackageCycleDetectorTest methodsFor: 'utilities' stamp: ''!
graphWithThreeCycles
	| anArray |
	anArray := Array new: 3.
	anArray at: 1 put: packageA.
	anArray at: 2 put: packageB.
	anArray at: 3 put: packageC.
	packageA add: (DAPackageDependency from: packageA to: packageB).
	packageB add: (DAPackageDependency from: packageB to: packageA).
	packageA add: (DAPackageDependency from: packageA to: packageC).
	packageC add: (DAPackageDependency from: packageB to: packageA).
	packageC add: (DAPackageDependency from: packageB to: packageB).
	^ DAPackageRelationGraph onPackages: anArray! !

!DAPackageCycleDetectorTest methodsFor: 'utilities' stamp: ''!
cyclesSize
	^ aPackageCycleDetection cycles size! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testAddVisitedNodes
	aPackageCycleDetection initializeVisitedNodes.
	aPackageCycleDetection addVisitedNodes: packageA.
	self assert: aPackageCycleDetection visitedNodes size equals: 1.
	self assert: (aPackageCycleDetection visitedNodes includes: packageA)! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testDequeue
	| dequeue |
	aPackageCycleDetection initializeQueueWith: packageA.
	dequeue := aPackageCycleDetection dequeue.
	self assert: dequeue equals: packageA.
	self assertEmpty: self queue! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testfindCycles
	"the graph test is the SCC 1 from the paper"
	| aPDPackageRelation anArray |
	anArray := Array new: 5.
	anArray at: 1 put: packageA.
	anArray at: 2 put: packageB.
	anArray at: 3 put: packageC.
	anArray at: 4 put: packageD.
	anArray at: 5 put: packageE.
	(packageA) add: (DAPackageDependency from: (packageA) to: (packageB)).
	(packageB) add: (DAPackageDependency from: (packageB) to: (packageC)).
	(packageB) add: (DAPackageDependency from: (packageB) to: (packageA)).
	(packageB) add: (DAPackageDependency from: (packageB) to: (packageD)).
	(packageC) add: (DAPackageDependency from: (packageC) to: (packageD)).
	(packageD) add: (DAPackageDependency from: (packageD) to: (packageE)).
	(packageD) add: (DAPackageDependency from: (packageD) to: (packageB)).
	(packageE) add: (DAPackageDependency from: (packageE) to: (packageA)).
	aPDPackageRelation := DAPackageRelationGraph onPackages: anArray.
	aPackageCycleDetection findCycles: aPDPackageRelation.
	self assert: (aPackageCycleDetection  cycles anySatisfy: [ :cycle | ((cycle size = 2) or: (cycle size= 4)) or: (cycle size = 3) ]).
	! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testFindCyclesThreeNodes
	| aPDPackageRelation |
	aPDPackageRelation := self graphWithThreeCycles.
	aPackageCycleDetection findCycles: aPDPackageRelation.
	self assert: aPackageCycleDetection cycles size equals: 3! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testAddCycle
	aPackageCycleDetection addCycle: DAPackageCycle new.
	self assert: aPackageCycleDetection cycles size equals: 1! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testIsVisitedOrInStack
	aPackageCycleDetection initializeVisitedNodes.
	aPackageCycleDetection initializeQueueWith: packageA.
	self assert: (aPackageCycleDetection isVisitedOrInQueue: packageA).
	aPackageCycleDetection dequeue.
	self deny: (aPackageCycleDetection isVisitedOrInQueue: packageA).
	aPackageCycleDetection addVisitedNodes: packageA.
	self assert: (aPackageCycleDetection isVisitedOrInQueue: packageA)! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testInitializeQueueWith
	| dequeue |
	aPackageCycleDetection initializeQueueWith: packageA.
	self assert: self queue isNotNil.
	self assert: self queue size equals: 1.
	dequeue := aPackageCycleDetection dequeue.
	self assert: dequeue equals: packageA! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testCycleAlreadyFound
	| cycle otherCycle |
	cycle := DAPackageCycle new.
	cycle addPackage: packageA.
	cycle addPackage: packageB.
	aPackageCycleDetection addCycle: cycle.
	otherCycle := DAPackageCycle new.
	otherCycle addPackage: packageA.
	self deny: (aPackageCycleDetection cycleAlreadyFound: otherCycle).
	otherCycle addPackage: packageB.
	self assert: (aPackageCycleDetection cycleAlreadyFound: otherCycle).! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testCyclesWithAtLeast
	| aCollectionOfPDPackage |
	aCollectionOfPDPackage := OrderedCollection new.
	aCollectionOfPDPackage
		add: packageA;
		add: packageB.

	cycleA
		addPackage: packageA;
		addPackage: packageB.

	cycleB
		addPackage: packageC;
		addPackage: packageD;
		addPackage: packageE.

	cycleC addPackage: packageE.

	aPackageCycleDetection
		addCycle: cycleA;
		addCycle: cycleB;
		addCycle: cycleC.

	self assert: (aPackageCycleDetection cyclesWithAtLeast: aCollectionOfPDPackage) size equals: 1! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testCyclesWith
	cycleA
		addPackage: packageA;
		addPackage: packageB.

	cycleB
		addPackage: packageC;
		addPackage: packageD;
		addPackage: packageE.

	cycleC
		addPackage: packageA;
		addPackage: packageE.

	aPackageCycleDetection
		addCycle: cycleA;
		addCycle: cycleB;
		addCycle: cycleC.

	self assert: (aPackageCycleDetection cyclesWith: packageA) size equals: 2.
	self assert: (aPackageCycleDetection cyclesWith: packageC) size equals: 1.
	self assert: (aPackageCycleDetection cyclesWith: packageE) size equals: 2! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testFindCyclesOne
	"we must find 1 cycles in this acyclic graph"

	| aPDPackageRelation anArray |
	anArray := Array new: 3.
	anArray at: 1 put: packageA.
	anArray at: 2 put: packageB.
	anArray at: 3 put: packageC.
	packageA add: (DAPackageDependency from: packageA to: packageB).
	packageB add: (DAPackageDependency from: packageB to: packageC).
	packageC add: (DAPackageDependency from: packageC to: packageA).
	aPDPackageRelation := DAPackageRelationGraph onPackages: anArray.
	aPackageCycleDetection findCycles: aPDPackageRelation.
	self assert: aPackageCycleDetection cycles size equals: 1! !

!DAPackageCycleDetectorTest methodsFor: 'utilities' stamp: ''!
visitedNodes
	^ aPackageCycleDetection instVarNamed: 'visitedNodes'! !

!DAPackageCycleDetectorTest methodsFor: 'tests' stamp: ''!
testEnqueue
	aPackageCycleDetection initializeQueueWith: packageA.
	self assert: self queue size equals: 1.
	aPackageCycleDetection enqueue: packageB.
	self assert: self queue size equals: 2! !

!DAPackageCycleDetectorTest methodsFor: 'utilities' stamp: ''!
queue
	^ aPackageCycleDetection instVarNamed: 'queue'! !

!DAPackageCycleGenerator commentStamp: ''!
A class able to generate a dot file from a package cycle (DAPackageCycle)!
!DAPackageCycleGenerator methodsFor: 'build items' stamp: ''!
buildNodes
	
	packageCycle packages 	
		do: [ :package |
			graphviz add: package packageName.
			 ] displayingProgress: 'Building nodes'! !

!DAPackageCycleGenerator methodsFor: 'accessing' stamp: ''!
packageCycle: anObject
	packageCycle := anObject! !

!DAPackageCycleGenerator methodsFor: 'accessing' stamp: ''!
packageCycle
	^ packageCycle! !

!DAPackageCycleGenerator methodsFor: 'build items' stamp: ''!
buildEdges
	packageCycle packages
		do: [ :package | 
			(packageCycle dependentPackagesFrom: package)
				do: [ :dependentPackage | graphviz add: package packageName -> dependentPackage packageName with: { #label -> (package dependenciesSizeTo: dependentPackage) } ] ]
		displayingProgress: 'Building edges'! !

!DAPackageCycleGenerator class methodsFor: 'instance creation' stamp: ''!
newWith: aPackageCycle named: aString
	
	| generator |
	generator := self new.
	generator packageCycle: aPackageCycle.
	generator nameOfGraph: aString.
	generator buildGraphViz.
	^ generator
	! !

!DAPackageCycleTest methodsFor: 'tests' stamp: ''!
testIsAtLeastInCycle
	| aCollectionOfPDPackage |
	aCollectionOfPDPackage  := OrderedCollection new.
	aCollectionOfPDPackage 
		add: packageA;
		add: packageB;
		add: packageC.
	
	aPDPackageCycle
		addPackage: packageA;
		addPackage: packageB.
	
	self assert: (aPDPackageCycle isAtLeastInCycle: aCollectionOfPDPackage).
	aCollectionOfPDPackage remove: packageA; remove: packageB.
	self deny: (aPDPackageCycle isAtLeastInCycle: aCollectionOfPDPackage).! !

!DAPackageCycleTest methodsFor: 'tests' stamp: ''!
testIsInCycle
	aPDPackageCycle addPackage: packageA.
	self assert: (aPDPackageCycle isInCycle: packageA).! !

!DAPackageCycleTest methodsFor: 'running' stamp: ''!
testRemoveOutgoingDependencies
	| firstPackage secondPackage outgoingPackage otherOutgoingPackage |
	firstPackage := DAPackage on: (RPackageSet named: 'A').
	secondPackage := DAPackage on: (RPackageSet named: 'B').
	outgoingPackage := DAPackage on: (RPackageSet named: 'C').
	otherOutgoingPackage := DAPackage on: (RPackageSet named: 'D').
	firstPackage add: (DACompositeDependency from: firstPackage to: secondPackage).
	firstPackage add: (DACompositeDependency from: firstPackage to: outgoingPackage).
	firstPackage add: (DACompositeDependency from: firstPackage to: otherOutgoingPackage).
	secondPackage add: (DACompositeDependency from: secondPackage to: firstPackage).
	secondPackage add: (DACompositeDependency from: secondPackage to: outgoingPackage).
	aPDPackageCycle addPackage: firstPackage; addPackage: secondPackage.
	aPDPackageCycle removeOutgoingDependencies.
	"at this point, package A and B does not have dependency with C and D, because C is not in the cycle"
	"self halt."
	self deny: (aPDPackageCycle hasOutgoingDependencies: firstPackage).
	self deny: (aPDPackageCycle hasOutgoingDependencies: secondPackage).! !

!DAPackageCycleTest methodsFor: 'tests' stamp: ''!
testSizeOfCycles
	self assert: aPDPackageCycle size equals: 0.
	aPDPackageCycle addPackage: (DAPackage on: (RPackageSet named: 'Kernel')).
	aPDPackageCycle addPackage: (DAPackage on: (RPackageSet named: 'Collections-Abstract')).
	self assert: aPDPackageCycle size equals: 2! !

!DAPackageCycleTest methodsFor: 'tests' stamp: ''!
testReversedCycle
	aPDPackageCycle
		addPackage: packageA;
		addPackage: packageB;
		addPackage: packageC;
		yourself.
	aPDPackageCycle reversedCycle.
	self assert: (aPDPackageCycle packageAt: 1) equals: packageC.
	self assert: (aPDPackageCycle packageAt: 2) equals: packageB.
	self assert: (aPDPackageCycle packageAt: 3) equals: packageA! !

!DAPackageCycleTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	aPDPackageCycle := DAPackageCycle new.
	packageA := DAPackage on: (RPackageSet named:'A').
	packageB := DAPackage on: (RPackageSet named:'B').
	packageC := DAPackage on: (RPackageSet named:'C').! !

!DAPackageDependenciesWelcome commentStamp: ''!
Welcome user interface to browse dependencies packages. Availaible via tools menu.!
!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
buttonAddAll
	^ buttonAddAll! !

!DAPackageDependenciesWelcome methodsFor: 'initialization' stamp: ''!
filterPackageList
	| match itemsMatching |
	textPackageField text
		ifEmpty: [ self packageList items: self systemPackages ]
		ifNotEmpty: [ 
			match := '*' , textPackageField text , '*'.
			itemsMatching := self systemPackages select: [ :package | match match: package ].
			self packageList items: itemsMatching asSortedCollection ]! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
packageList
	^ packageList! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
buttonOpen
	^ buttonOpen! !

!DAPackageDependenciesWelcome methodsFor: 'initialization' stamp: ''!
initializeWidgets
	self
		initializeLists;
		initializeLabels;
		initializeButtons;
		buildList.
		
	textPackageField := self newTextInput
		ghostText: 'Filter package by name';
		entryCompletion: self packagesEntryCompletion.! !

!DAPackageDependenciesWelcome methodsFor: 'initialization' stamp: ''!
initializeLabels
	packageLabel := self newLabel.
	packageChosenLabel := self newLabel! !

!DAPackageDependenciesWelcome methodsFor: 'actions' stamp: ''!
open
	^ self openWithSpec! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
selectedItemsFromPackageList
	^ self packageList selectedItems! !

!DAPackageDependenciesWelcome methodsFor: 'initialization' stamp: ''!
initializeButtons
	buttonOpen := self newButton
		help: 'Open the package dependencies analysis';
		label: 'Browse dependencies';
		icon: (self iconNamed: #packageIcon).
	buttonAddPackage := self newButton
		help: 'Add package to browse';
		label: 'Add package';
		icon: (self iconNamed: #addIcon).
	buttonAddAll := self newButton
		help: 'Add all packages';
		label: 'Add all';
		icon: (self iconNamed: #addIcon).
	buttonRemovePackage := self newButton
		help: 'Remove package to browse';
		label: 'Remove package';
		icon: (self iconNamed: #deleteIcon).
	buttonRemoveAll := self newButton
		help: 'Remove all selected packages';
		label: 'Remove all';
		icon: (self iconNamed: #deleteIcon)! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
packageChosenList
	^ packageChosenList! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
textPackageField
	^ textPackageField! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
buttonAddPackage
	^ buttonAddPackage! !

!DAPackageDependenciesWelcome methodsFor: 'protocol' stamp: ''!
actionOnRemovePackage
	| itemsAdded |
	buttonRemovePackage
		action: [ 
			self selectedItemsFromPackageChosenList
				ifNotEmpty: [ 
					itemsAdded := self itemsFromPackageChosenList.
					self selectedItemsFromPackageChosenList do: [ :each | itemsAdded remove: each ].
					self packageChosenList items: itemsAdded.
					self packageChosenList resetSelection.
					self updatePackageChosenLabel ] ]! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
packageLabel
	^ packageLabel! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
packagesEntryCompletion
	| applicants |
	applicants := self systemPackages.

	^ EntryCompletion new
				dataSourceBlock: [:currText | applicants];
				filterBlock: [:currApplicant :currText | currText size > 3
						and: [currApplicant asUppercase includesSubstring: currText asString asUppercase]].! !

!DAPackageDependenciesWelcome methodsFor: 'morphic ui' stamp: ''!
title
	^ 'Package Dependencies Browser'! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
systemPackages
	^ (RPackageOrganizer default packages collect: [ :package | package packageName asString ] )asSortedCollection! !

!DAPackageDependenciesWelcome methodsFor: 'protocol' stamp: ''!
actionOnOpen
	buttonOpen
		action: [ 
			self itemsFromPackageChosenList
				ifNotEmpty: [ 
					(DAPackageAnalyzerPackageDependenciesWindow onPackagesNamed: self itemsFromPackageChosenList) open.
					 ] ]! !

!DAPackageDependenciesWelcome methodsFor: 'actions' stamp: ''!
buildList
	self packageList items: self systemPackages.
	self updateLabels! !

!DAPackageDependenciesWelcome methodsFor: 'morphic ui' stamp: ''!
initialExtent
	^ (800@800)! !

!DAPackageDependenciesWelcome methodsFor: 'protocol' stamp: ''!
updatePackageLabel
	self packageLabel 
			label: 'Choose your packages (', self packageList listSize asString, ' packages available)'.! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
selectedItemsFromPackageChosenList
	^ self packageChosenList selectedItems! !

!DAPackageDependenciesWelcome methodsFor: 'protocol' stamp: ''!
updatePackageChosenLabel
	self packageChosenLabel 
			label: packageChosenList listSize asString, ' package(s) chosen'.! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
itemsFromPackageChosenList
	^ self packageChosenList listItems! !

!DAPackageDependenciesWelcome methodsFor: 'protocol' stamp: ''!
updateLabels
	self
		updatePackageLabel;
		updatePackageChosenLabel! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
packageChosenLabel
	^ packageChosenLabel! !

!DAPackageDependenciesWelcome methodsFor: 'protocol' stamp: ''!
actionOnAddPackage
	| itemsToAdd itemsChosen itemsAdded |
	buttonAddPackage
		action: [ 
			self selectedItemsFromPackageList
				ifNotEmpty: [ 
					itemsToAdd := self selectedItemsFromPackageList asOrderedCollection.
					itemsAdded := self itemsFromPackageChosenList asOrderedCollection.
					itemsChosen := self merge: itemsToAdd With: itemsAdded.
					self packageChosenList items: itemsChosen asSortedCollection.
					self updatePackageChosenLabel ] ]! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
buttonRemovePackage
	^ buttonRemovePackage! !

!DAPackageDependenciesWelcome methodsFor: 'initialization' stamp: ''!
initializeLists
	packageList := self newList
		multiSelection: true;
		yourself.
	packageChosenList := self newList
		multiSelection: true;
		yourself! !

!DAPackageDependenciesWelcome methodsFor: 'accessing' stamp: ''!
buttonRemoveAll
	^ buttonRemoveAll! !

!DAPackageDependenciesWelcome methodsFor: 'merging' stamp: ''!
merge: aCollection With: anOtherCollection
	^ aCollection asSet
		addAll: anOtherCollection;
		yourself! !

!DAPackageDependenciesWelcome methodsFor: 'initialization' stamp: ''!
initializePresenter
	self actionOnOpen;
		actionOnAddPackage;
		actionOnRemovePackage.
	
	self buttonAddAll action: [ self packageChosenList items: self packageList listItems. self updatePackageChosenLabel ].
	self buttonRemoveAll action: [ self packageChosenList items: #().  self updatePackageChosenLabel ].
		
	packageChosenList whenSelectedItemChanged: [ packageList resetSelection ].
	
	textPackageField
		whenTextChanged: [ self filterPackageList ]! !

!DAPackageDependenciesWelcome class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newColumn:
			[ :col | 
			col
				newRow: [ :row | 
							row
								add: #packageLabel;
								add: #packageChosenLabel ]
					height: 30;
				newRow: [ :row | 
							row
								add: #textPackageField;
								add: #buttonOpen ]
					height: 30;
				newRow: [ :row | 
							row
								add: #packageList;
								add: #packageChosenList ];
				newRow: [ :row | 
							row
								add: #buttonAddAll;
								add: #buttonAddPackage;
								add: #buttonRemoveAll;
								add: #buttonRemovePackage ]
					height: 30 ] yourself! !

!DAPackageDependenciesWelcome class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>

	(aBuilder item: #PackageDependencies)
		order: 2;
		parent: #Packaging;
		label: 'Dependency Analyser';
		icon: (self iconNamed: #packageIcon);
		help: 'Analyze dependencies between different packages in the image.';
		action: [ self new open ]! !

!DAPackageDependency commentStamp: ''!
A PDPackageDependency is a dependency between two packages.

	source:		the source PDPackage 
	target:	      the target PDPackage
!
!DAPackageDependency methodsFor: 'printing' stamp: ''!
displayString
	^ String streamContents: [ :stream | self printReasonOn: stream ]! !

!DAPackageDependency methodsFor: 'comparing' stamp: ''!
hash
	^ source hash bitXor: target hash! !

!DAPackageDependency methodsFor: 'testing' stamp: ''!
isInternal
	^ self source = self target! !

!DAPackageDependency methodsFor: 'initialization' stamp: ''!
initializeFrom: aSourcePackage to: aTargetPackage
	source := aSourcePackage.
	target := aTargetPackage! !

!DAPackageDependency methodsFor: 'testing' stamp: ''!
isMessageSendDependency
	^ false ! !

!DAPackageDependency methodsFor: 'testing' stamp: ''!
isTraitDependency
	^ false! !

!DAPackageDependency methodsFor: 'printing' stamp: ''!
printShortReasonOn: aStream
	self printReasonOn: aStream! !

!DAPackageDependency methodsFor: 'accessing' stamp: ''!
reason
	^ String streamContents: [ :stream | self printReasonOn: stream ]! !

!DAPackageDependency methodsFor: 'testing' stamp: ''!
isExternal
	^ self isInternal not! !

!DAPackageDependency methodsFor: 'printing' stamp: ''!
printOn: aStream
	self printReasonOn: aStream! !

!DAPackageDependency methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!DAPackageDependency methodsFor: 'testing' stamp: ''!
isReferenceDependency
	^ false! !

!DAPackageDependency methodsFor: 'accessing' stamp: ''!
numberOfDependencies
	^ 1! !

!DAPackageDependency methodsFor: 'accessing' stamp: ''!
packageName
	^ target packageName! !

!DAPackageDependency methodsFor: 'testing' stamp: ''!
isExtensionDependency
	^ false! !

!DAPackageDependency methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!DAPackageDependency methodsFor: 'printing' stamp: ''!
printReasonOn: aStream
	aStream 
		nextPutAll: source packageName;
		nextPutAll: ' -> ';
		nextPutAll: target packageName! !

!DAPackageDependency methodsFor: 'testing' stamp: ''!
isInheritanceDependency
	^ false ! !

!DAPackageDependency class methodsFor: 'instance creation' stamp: ''!
from: aSourcePackage to: aDestinationPackage
	^ self new initializeFrom: aSourcePackage to: aDestinationPackage! !

!DAPackageDependencyTest methodsFor: 'running' stamp: ''!
inheritanceDependency: aClass
	^ (DAInheritanceDependency from: packageA to: packageB)
		theClass: aClass;
		superclass: nil;
		yourself! !

!DAPackageDependencyTest methodsFor: 'tests' stamp: ''!
testExtensionDependencies
	| aCompositeDependency |
	aCompositeDependency := DACompositeDependency
		from: (packageA)
		to: (packageB).
	aCompositeDependency
		add:
			(DAExtensionDependency from: (packageA) to: (packageB));
		add:
			(DAInheritanceDependency from: (packageA) to: (packageB)).
	self assert: (aCompositeDependency extensionDependencies allSatisfy: [ :each | each isExtensionDependency ]).! !

!DAPackageDependencyTest methodsFor: 'tests' stamp: ''!
testIsInternal
	self assert: (anInternalPackageDependency isInternal)! !

!DAPackageDependencyTest methodsFor: 'tests' stamp: ''!
testEquals
	self assert: aPackageDependency equals: aPackageDependency! !

!DAPackageDependencyTest methodsFor: 'tests' stamp: ''!
testIsExternal
	self assert: (aPackageDependency isExternal)! !

!DAPackageDependencyTest methodsFor: 'tests' stamp: ''!
testDependenciesSize
	| aCompositeDependency |
	aCompositeDependency := DACompositeDependency from: packageA to: packageB.
	aCompositeDependency
		add: (DAInheritanceDependency from: packageA to: packageB);
		add: (DAInheritanceDependency from: packageA to: packageB).
	self assert: aCompositeDependency extensionDependenciesSize equals: 0.
	aCompositeDependency add: (DAExtensionDependency from: packageA to: packageB).
	self assert: aCompositeDependency extensionDependenciesSize equals: 1! !

!DAPackageDependencyTest methodsFor: 'tests' stamp: ''!
testReferenceDependencies
	| aCompositeDependency |
	aCompositeDependency := DACompositeDependency from: packageA to: packageB.
	aCompositeDependency
		add: (self referenceDependency: String);
		add: (self referenceDependency: Object);
		add: (DAInheritanceDependency from: packageA to: packageB).

	self assert: aCompositeDependency referenceDependencies size equals: 2! !

!DAPackageDependencyTest methodsFor: 'tests' stamp: ''!
testDependenciesWithoutExtensionDependency
	| aCompositeDependency |
	aCompositeDependency := DACompositeDependency from: packageA to: packageB.
	aCompositeDependency
		add: (DAInheritanceDependency from: packageA to: packageB);
		add: (DAInheritanceDependency from: packageA to: packageB);
		add: (DAExtensionDependency from: packageA to: packageB).
	self assert: aCompositeDependency dependenciesWithoutExtensionDependency size equals: 2! !

!DAPackageDependencyTest methodsFor: 'running' stamp: ''!
referenceDependency: aClass
	^ (DAReferenceDependency from: packageA to: packageB)
		theClass: aClass;
		selector: nil;
		reference: nil;
		method: nil;
		yourself! !

!DAPackageDependencyTest methodsFor: 'tests' stamp: ''!
testReferenceDependenciesFrom
	| aCompositeDependency |
	aCompositeDependency := DACompositeDependency from: packageA to: packageB.
	aCompositeDependency
		add: (self referenceDependency: String);
		add: (self referenceDependency: Object);
		add: (self referenceDependency: String).

	self assert: (aCompositeDependency referenceDependenciesFrom: String) size equals: 2! !

!DAPackageDependencyTest methodsFor: 'tests' stamp: ''!
testContainsOnlyExtensionDependency
	| aCompositeDependency |
	aCompositeDependency := DACompositeDependency
		from: (packageA)
		to: (packageB).
	aCompositeDependency
		add:
			(DAInheritanceDependency from: (packageA) to: (packageB));
		add:
			(DAInheritanceDependency from: (packageA) to: (packageB)).
	self deny: (aCompositeDependency containsOnlyExtensionDependency).
	aCompositeDependency dependencies removeAll.
		aCompositeDependency
		add:
			(DAExtensionDependency from: (packageA) to: (packageB));
		add:
			(DAExtensionDependency from: (packageA) to: (packageB)).
	self assert: (aCompositeDependency containsOnlyExtensionDependency).
		! !

!DAPackageDependencyTest methodsFor: 'tests' stamp: ''!
testDependenciesFrom
	| aCompositeDependency |
	aCompositeDependency := DACompositeDependency from: packageA to: packageB.
	aCompositeDependency
		add: (self referenceDependency: String);
		add: (self referenceDependency: Object);
		add: (self referenceDependency: String);
		add: (self inheritanceDependency: Stack).
	self assert: (aCompositeDependency referenceDependenciesFrom: String) size equals: 2! !

!DAPackageDependencyTest methodsFor: 'running' stamp: ''!
setUp
	| source target |
	super setUp.
	source := DAPackage on: (RPackageSet named:'Kernel').
	target := DAPackage on: (RPackageSet named:'Collections-Abstract').
	aPackageDependency := DAPackageDependency from:source to:target.
	anInternalPackageDependency := DAPackageDependency from:source to:source.
	packageA := DAPackage on: (RPackageSet named:'A').
	packageB := DAPackage on: (RPackageSet named:'B').! !

!DAPackageDependencyWrapper commentStamp: ''!
Wrapper for dependent package (use in TreePresenter)!
!DAPackageDependencyWrapper methodsFor: 'accessing' stamp: ''!
daPackage: anObject
	daPackage := anObject! !

!DAPackageDependencyWrapper methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: self packageName! !

!DAPackageDependencyWrapper methodsFor: 'accessing' stamp: ''!
daPackage
	^ daPackage! !

!DAPackageDependencyWrapper methodsFor: 'accessing' stamp: ''!
packageName
	^ daPackage packageName! !

!DAPackageDependencyWrapper methodsFor: 'accessing' stamp: ''!
rPackageSet
	^ daPackage rPackageSet! !

!DAPackageDependencyWrapper methodsFor: 'initialization' stamp: ''!
initializeFrom: aPackage
	super initialize.
	self daPackage: aPackage.! !

!DAPackageDependencyWrapper methodsFor: 'comparing' stamp: ''!
<= other
	^ self daPackage <= other daPackage! !

!DAPackageDependencyWrapper class methodsFor: 'instance creation' stamp: ''!
newWith: aPackage
	^ self new initializeFrom: aPackage! !

!DAPackageDependencyWrapperTest methodsFor: 'tests' stamp: ''!
testInitializeFrom
	aPDPackageDependencyWrapper := DAPackageDependencyWrapper newWith: packageA.
	self assert: aPDPackageDependencyWrapper daPackage equals: packageA! !

!DAPackageDependencyWrapperTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	packageA := DAPackage on: (RPackageSet named:'A').! !

!DAPackageItemDiff commentStamp: ''!
A PDAbstractItemDiff is a object which represent a package who added/modified/removed from an old analysis.!
!DAPackageItemDiff methodsFor: 'testing' stamp: ''!
hasChanged
	^ diff dependentPackagesDiff
		detect: [ :each | each parent = self content and: [ each hasChanged ] ]
		ifFound: [ true ]
		ifNone: [ false ]! !

!DAPackageItemDiff methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		nextPutAll: content packageName.! !

!DAPackageItemDiff methodsFor: 'accessing' stamp: ''!
dependencies
	 ^ self content dependentPackages ! !

!DAPackageItemDiffNode commentStamp: ''!
A PDPackageNode is used to display a package diff in a tree.!
!DAPackageItemDiffNode methodsFor: 'accessing' stamp: ''!
icon
	self content isNew ifTrue: [ ^ self iconNamed: #changeAddIcon ].
	self content isRemoved ifTrue: [^ self iconNamed: #smallCancelIcon ].
	^ self iconNamed: #forwardIcon! !

!DAPackageRelationGraph commentStamp: ''!
I'm a package dependency graph. 
To build the dependency graph among packages, you have just to give a set of PDPackage on entry. Then :

	- use the message computeStaticDependencies messages to retrieve all the dependency among the packages.
	- use the message removeInternalDependencies if you want to remove all the internal dependency.
	- finally use combineDependencies to combine each dependency which have the same source and the target into 	composite dependency.
		!
!DAPackageRelationGraph methodsFor: 'computing' stamp: ''!
allExtensionDependencies
	| aCollectionOfExtensionDependency |
	aCollectionOfExtensionDependency := OrderedCollection new.
	
	self seenPackages do: [ :each |
		each dependencies do: [ :dependency |
			aCollectionOfExtensionDependency addAll: dependency extensionDependencies.
			 ]
		 ].
	^ aCollectionOfExtensionDependency! !

!DAPackageRelationGraph methodsFor: 'queries' stamp: ''!
systemPackageContaining: aClass
	| info |
	info := (RPackageOrganizer default packageOf: aClass) packageName.
	^ info
		ifNil: [ self error: 'Package for ' , aClass name , ' not found.' ]
		ifNotNil: [ DAPackage on: (RPackageSet named: info asString) ]! !

!DAPackageRelationGraph methodsFor: 'private' stamp: ''!
combineDependencies: aPackage
	| grouped composite |
	grouped := aPackage dependencies
		groupedBy: [ :each | each target ]
		having: [ :each | true ].
	
	aPackage clearDependencies.
	
	grouped keysAndValuesDo: [ :target :dependencies |
		composite := DACompositeDependency from: aPackage to: target.
		dependencies do: [ :each | composite add: each ].
		aPackage add: composite ]! !

!DAPackageRelationGraph methodsFor: 'actions' stamp: ''!
combineDependencies
	"Combine all dependencies with the same source and target into one composite
	dependency."
	self packages 
		do: [ :each | self combineDependencies: each ]
		displayingProgress: 'Combining Dependencies'! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
methodsFor: aPackage
	^ aPackage rPackageSet methods! !

!DAPackageRelationGraph methodsFor: 'actions' stamp: ''!
removeOutgoingDependencies
	"Remove all dependencies to packages not included in this relation"
	
	self includedPackages
		do: [ :each | self removeOutgoingDependencies: each ]
		displayingProgress: 'Removing outgoing Dependencies'! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
packagesName

	^ packages keys! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
packageAt: aPackageName
	"answer a PDPackage"
	(packages keys includes: aPackageName) ifTrue: [  
	^ packages at: aPackageName ].
	^ nil! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
addExtensionDependencies: aPDPackage	
	aPDPackage rPackageSet extensionMethods
		do: [ :method | | packageOfExtendedClass |
			packageOfExtendedClass := self packageForBehavior: method methodClass.
			self addPackage: packageOfExtendedClass.
			aPDPackage
				add:
					((DAExtensionDependency from: aPDPackage to: packageOfExtendedClass)
						theClass: method methodClass;
						selector: method selector asSymbol;
						method: method).
			 ]! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
successors: aPackage
	"answer a collection with the successors of aPackage in the graph"

	| aCollection |
	aCollection := OrderedCollection new.
	(packages at: aPackage packageName) dependencies
		do: [ :dependency | 
			(self packagesName includes: dependency target packageName)
				ifTrue: [ aCollection add: dependency target ] ].
	^ aCollection! !

!DAPackageRelationGraph methodsFor: 'removing' stamp: ''!
removePackage: packageName
	^ packages removeKey: packageName! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
dependenciesFrom: aPackage
	"Answer all seen packages."

	^ (packages at: aPackage) dependencies! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
addInheritanceDependencies: aPackage
	| package |
	self package: aPackage
		classesDo: [ :class | 
			class superclass ifNotNil: [ 
					package := self packageForBehavior: class superclass.
					aPackage
						add:
							((DAInheritanceDependency from: aPackage to: package)
								theClass: class;
								superclass: class superclass).
					self addPackage: package ] ]! !

!DAPackageRelationGraph methodsFor: 'initialization' stamp: ''!
initializeWithPackages: aCollection
	self initialize.
	packages := Dictionary new.
	aCollection do: [ :each | self addPackage: each ].
	classToPackage := IdentityDictionary new! !

!DAPackageRelationGraph methodsFor: 'actions' stamp: ''!
seenPackagesWithoutExtension
	^ self packages select: [ :each | each isSeen ]! !

!DAPackageRelationGraph methodsFor: 'actions' stamp: ''!
removeInternalDependencies
	"Remove all dependencies from a package to itself"
	
	self includedPackages
		do: [ :each | each removeAllInternal ]
		displayingProgress: 'Removing internal Dependencies'! !

!DAPackageRelationGraph methodsFor: 'actions' stamp: ''!
seenPackages
	^ self packages 
		select: [ :each | each isSeen ]! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
addPackage: aPDPackage
	aPDPackage beIncluded.
	packages 
		at: aPDPackage packageName
		put: aPDPackage! !

!DAPackageRelationGraph methodsFor: 'updating' stamp: ''!
clearPackages
	packages := Dictionary new! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
classToPackage: aClass
	^ (classToPackage at: aClass) packageName! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
addMessageSendDependencies: aPackage
	| analyser |
	analyser := (DAMessageSendAnalyzer basicNew
		initializeWith: aPackage;
		yourself).

	analyser manuallyResolvedDependencies do: 
		[ :packageName |
		(analyser missingMethodsImplementedIn: packageName) 
			ifEmpty: [ PotentialOutDatedDependencyWarning signalDependency: packageName on: aPackage packageName ]
			ifNotEmpty: 	[ :implementedMethods |
				aPackage add: ((DAMessageSendDependency from: aPackage to: (self daPackageWith: packageName))
					implementedMethods: implementedMethods;
					yourself) ] ]! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
classToPackage
	^ classToPackage! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
addPoolDictionaryDependencies: aPackage
	"Iterate all classes in the package.
	Add a pool dictionary dependency for each pool dictionary used in the package."

	self package: aPackage
		classesDo: [ :class | 
			class sharedPoolsDo: [ :each | | targetPackage |
				targetPackage := self packageForBehavior: each.
				aPackage
					add: ((DAPoolDictionaryDependency from: aPackage to: targetPackage)
						theClass: class;
						poolDictionary: each).
				self addPackage: targetPackage ] ]! !

!DAPackageRelationGraph methodsFor: 'testing' stamp: ''!
allSeen
	
	^ self packages allSatisfy: [ :each | each isSeen ].! !

!DAPackageRelationGraph methodsFor: 'computing' stamp: ''!
usersOf: aPackage
	| users |
	users := OrderedCollection new.
	self seenPackages
		do: [ :package | 
			(package dependentPackages includes: aPackage)
				ifTrue: [ users add: package ] ].
	^ users! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
findReferencesIn: aMethod for: aPackage
	| package compiledMethod allCompiledCode |

	compiledMethod := aMethod compiledMethod.
	compiledMethod ifNil: [ ^ self ].
	
	allCompiledCode := compiledMethod withAllBlocks.	
	
	allCompiledCode do: [ :aCompiledCode | 
			aCompiledCode literals do: [ :literal | 
					(self isReference: literal)
						ifTrue: [ 
							package := self packageForBehavior: literal value.
							self addPackage: package.
							aPackage
								add:
									((DAReferenceDependency from: aPackage to: package)
										theClass: aMethod methodClass;
										selector: aMethod method selector asSymbol;
										reference: literal value;
										method: aMethod;
										yourself) ] ] ].! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
seenPackagesName
	"Answer all seen packages name."

	^ self seenPackages collect: [ :package | package packageName ]! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
addTraitDependencies: aPackage
	| package |
	self package: aPackage
		classesDo: [ :class | 
			class traits
				do: [ :trait |
					package := self packageForBehavior: trait.
					aPackage
						add:
							((DATraitDependency from: aPackage to: package)
								theClass: class;
								trait: trait).
					self addPackage: package ] ]! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
allDependentPackagesFromSeenPackages
	| aSet |
	aSet := Set new.
	self seenPackages do: [ :seenPackage |
		aSet addAll: (seenPackage dependentPackages) ].
	
	^ aSet	
! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
includesSeenPackage: aPackage	
	^ self seenPackages includes: aPackage! !

!DAPackageRelationGraph methodsFor: 'enumerating' stamp: ''!
package: aPackage classesDo: aBlock 
	aPackage rPackageSet classes do: aBlock! !

!DAPackageRelationGraph methodsFor: 'queries' stamp: ''!
packageForBehavior: aClass
	"return a PDPackage and put in classToPackage"

	^ classToPackage
		at: aClass
		ifAbsentPut: [ 
			self packages
				detect: [ :each | each rPackageSet includesClass: aClass ]
				ifNone: [ self systemPackageContaining: aClass ] ]! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
packages

	^ packages values! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
outgoing
	"Answer a collection of all dependencies that point out of the current package set."

	^ self includedPackages
		inject: Bag new
		into: [ :outgoing :package |
			package dependencies do: [ :each |
				(each isInternal or: [ each target isIncluded ])
					ifFalse: [ outgoing add: each ] ].
			outgoing ]! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
classesFor: aPackage
	^ aPackage rPackageSet classes! !

!DAPackageRelationGraph methodsFor: 'building' stamp: ''!
build
	"build the dependency graph"
	self 
		computeStaticDependencies;
		removeInternalDependencies;
		combineDependencies! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
addPackages: aCollection
	aCollection
		do: [ :package | 
			self addPackage: package ]! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
computeStaticDependencies
	self packages
		do: [ :each | 
			each isSeen
				ifFalse: [ 
					self computeStaticDependencies: each.
					each beSeen ] ] ! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
packageNamed: aString ifAbsent: aBlock
	^ packages at: aString ifAbsent: aBlock! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
daPackageWith: packageName
	^ DAPackage on: (RPackageSet named: packageName)! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
includedPackages
	"Answer the currently analyzed set of packages."

	^ self packages select: [ :each | each isIncluded ]! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
addReferenceDependencies: aPackage
	(self methodsFor: aPackage) 
		do: [ :method | self findReferencesIn: method for: aPackage ]! !

!DAPackageRelationGraph methodsFor: 'updating' stamp: ''!
refreshGraph
	| olderPackages refreshPackage |
	classToPackage := IdentityDictionary new.
	olderPackages := self seenPackagesName.
	self clearPackages.
	olderPackages
		do: [ :packageName | 
			refreshPackage := self daPackageWith: packageName.
			self addPackage: refreshPackage ].
	self build! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
predecessors: aPackage
	"returns a Collection with the predecessors of the package"

	| aCollection |
	aCollection := OrderedCollection new.
	self packages
		do: [ :package | 
			package dependencies
				do: [ :dependency | 
					dependency target = aPackage
						ifTrue: [ aCollection add: package ] ] ].
	^ aCollection! !

!DAPackageRelationGraph methodsFor: 'actions' stamp: ''!
clearAllDependencies
	packages do: [ :package | package clearDependencies ]! !

!DAPackageRelationGraph methodsFor: 'computing' stamp: ''!
allReferenceDependencies
	| aCollectionOfReferenceDependency |
	aCollectionOfReferenceDependency := OrderedCollection new.
	
	self seenPackages do: [ :each |
		each dependencies do: [ :dependency |
			aCollectionOfReferenceDependency addAll: dependency referenceDependencies.
			 ]
		 ].
	^ aCollectionOfReferenceDependency! !

!DAPackageRelationGraph methodsFor: 'testing' stamp: ''!
isReference: aLiteral
	^ aLiteral isVariableBinding and: [ aLiteral value isBehavior and: [ aLiteral key = aLiteral value name ] ]! !

!DAPackageRelationGraph methodsFor: 'adding' stamp: ''!
computeStaticDependencies: aPackage
	
	self addInheritanceDependencies: aPackage.
	self addExtensionDependencies: aPackage.
	self addReferenceDependencies: aPackage.
	self addPoolDictionaryDependencies: aPackage.
	self addTraitDependencies: aPackage.
	self addMessageSendDependencies: aPackage! !

!DAPackageRelationGraph methodsFor: 'accessing' stamp: ''!
pdPackageFrom: aClass
	^ packages detect: [ :package | package rPackageSet includesClass: aClass ]! !

!DAPackageRelationGraph methodsFor: 'updating' stamp: ''!
refreshPackageDependencies: aPackage
	aPackage clearDependencies.
	self computeStaticDependencies: aPackage.
	self combineDependencies: aPackage.
	aPackage removeAllInternal.
	aPackage beSeen.
	! !

!DAPackageRelationGraph methodsFor: 'private' stamp: ''!
removeOutgoingDependencies: aPackage
	| removals |
	removals := aPackage dependencies reject: [ :each | each target isIncluded ].
	removals do: [ :each | aPackage remove: each ]! !

!DAPackageRelationGraph methodsFor: 'actions' stamp: ''!
seenPackagesWithFilter: aFilter
	^ self packages 
		select: [ :each | each isSeen and: [ aFilter match: each packageName ] ].! !

!DAPackageRelationGraph class methodsFor: 'instance creation' stamp: ''!
new
	^ self onPackages: OrderedCollection new! !

!DAPackageRelationGraph class methodsFor: 'instance creation' stamp: ''!
onPackagesNamed: packageNames
	^ self basicNew
		initializeWithPackages: (packageNames collect: [ :each | DAPackage onPackageNamed: each ]);
		yourself! !

!DAPackageRelationGraph class methodsFor: 'instance creation' stamp: ''!
onPackages: aCollection
	^ self basicNew
		initializeWithPackages: aCollection;
		yourself! !

!DAPackageRelationGraphDiff commentStamp: ''!
A PDPackageRelationGraphDiff do the diff between two PDPackageRelationGraph (an older and a newer) to detect :

 - which packages added/removed : packagesDiff.
 - which dependent packages added/removed from a package : dependentPackagesDiff.
 - which dependencies added/removed from a dependent package.!
!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
packagesDiff
	^ packagesDiff! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
packagesDiffToDisplay
	^ packagesDiff select: [ :each | each canBeDisplay ]! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
packageDiffNamed: aName
	^ self packagesDiff detect: [ :item | item content packageName = aName ]! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
dependentPackagesDiffRemoved
	^ dependentPackagesDiff select: [ :each | each isRemoved ]! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
packagesDiffNew
	^ packagesDiff select: [ :each | each isNew ]! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
packagesDiffUnderteminateSize
	^ self packagesDiffUnderteminate size! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
makeDependenciesDiff! !

!DAPackageRelationGraphDiff methodsFor: 'adding' stamp: ''!
addRemovedDependentPackage: package from: parent
	^ dependentPackagesDiff
		add:
			((DADependentPackageItemDiff
				newWith: package)
				beRemoved;
				parent: parent;
				diff: self);
		yourself! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
newRelationGraph
	^ newRelationGraph! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
oldRelationGraph
	^ oldRelationGraph! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
packagesDiffRemoved
	^ packagesDiff select: [ :each | each isRemoved ]! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
lookUpForUndeterminatePackages
	| undeterminates |
	undeterminates := oldRelationGraph seenPackages reject: [ :package | self removedPackagesIncludes: package ].
	undeterminates do: [ :each | self addUndeterminatePackage: each ]! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
packagesDiffRemovedSize
	^ self packagesDiffRemoved size! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
makeDependentPackagesDiffOn: aPackage
	
	| oldDependentPackages newDependentPackages  |
	
	oldDependentPackages := (oldRelationGraph packageAt: aPackage packageName) dependentPackages.
	newDependentPackages := (newRelationGraph packageAt: aPackage packageName) dependentPackages.
	
	self lookUpForRemovedDependentPackages: oldDependentPackages with: newDependentPackages from: aPackage.
	self lookUpForNewDependentPackages: newDependentPackages with: oldDependentPackages from: aPackage.
	self lookUpForUndeterminateDependentPackagesFrom: aPackage.! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
makePackagesDiff
	"lookUp for new and remove packages"

	self
		lookUpForRemovedPackages;
		lookUpForNewPackages;
		 lookUpForUndeterminatePackages.! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
lookUpForUndeterminateDependentPackagesFrom: parent
	| oldDependentPackages undeterminates |
	oldDependentPackages := (oldRelationGraph packageAt: parent packageName) dependentPackages.
	undeterminates := oldDependentPackages reject: [ :package | self removedDependentPackagesIncludes: package from: parent ].
	
	
	undeterminates do: [ :each | self addUndeterminateDependentPackage: each from: parent ].
! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
lookUpForRemovedPackages
	| old |
	old := oldRelationGraph seenPackages reject: [ :each |  newRelationGraph includesSeenPackage: each ].	
	old do: [ :each |
		self addRemovedPackage: each
		 ]! !

!DAPackageRelationGraphDiff methodsFor: 'testing' stamp: ''!
removedPackagesIncludes: seenPackage

	^ self packagesDiffRemoved detect: [ :each | each content = seenPackage ]
			ifFound: [ true ]
			ifNone: [ false ]
! !

!DAPackageRelationGraphDiff methodsFor: 'adding' stamp: ''!
addUndeterminateDependentPackage: aPackage from: parent
	^ dependentPackagesDiff
		add:
				((DADependentPackageItemDiff newWith: aPackage)
						beUnderteminate;
						parent: parent;
						diff: self);
		yourself! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
makeDependentPackagesDiff
	"we're just looking at the package undeterminate"
	"every dependent packages are removed or new in older or new packages"
	self packagesDiffUnderteminate do: [ :item |
			self makeDependentPackagesDiffOn: item content.
		 ]
	! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
oldRelationGraph: anObject
	oldRelationGraph := anObject! !

!DAPackageRelationGraphDiff methodsFor: 'testing' stamp: ''!
removedDependentPackagesIncludes: aPackage from: parent
	^ self dependentPackagesDiffRemoved
		detect: [ :package | package content = aPackage and: [ package parent = parent ] ]
		ifFound: [ true ]
		ifNone: [ false ]! !

!DAPackageRelationGraphDiff methodsFor: 'initialization' stamp: ''!
initialize
	packagesDiff := OrderedCollection new.
	dependentPackagesDiff := OrderedCollection new.! !

!DAPackageRelationGraphDiff methodsFor: 'adding' stamp: ''!
addNewPackage: seenPackage
	^ packagesDiff
		add:
			((DAPackageItemDiff newWith: seenPackage)
				beNew;
				diff: self);
		yourself! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
dependentPackagesDiff
	^ dependentPackagesDiff! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
lookUpForNewPackages
			
	| newPackages |
	newPackages := newRelationGraph seenPackages reject: [ :package | oldRelationGraph includesSeenPackage: package ].
	newPackages do: [ :each | self addNewPackage: each ].! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
lookUpForRemovedDependentPackages: oldDependentPackages with: newDependentPackages from: aPackage

	| removed |
	removed := oldDependentPackages reject: [ :package | newDependentPackages includes: package ].
	removed do: [ :each | self addRemovedDependentPackage: each from: aPackage ].! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
lookUpForNewDependentPackages: newDependentPackages with: oldDependentPackages from: aPackage
	
	| newDependent |
	newDependent := newDependentPackages reject: [ :package | oldDependentPackages includes: package ].
	newDependent do: [ :each | self addNewDependentPackage: each from: aPackage ].! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
newRelationGraph: anObject
	newRelationGraph := anObject! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
packagesDiffUnderteminate
	^ packagesDiff select: [ :each | each isUnderteminate  ]! !

!DAPackageRelationGraphDiff methodsFor: 'adding' stamp: ''!
addNewDependentPackage: package from: parent
	^ dependentPackagesDiff
		add:
			((DADependentPackageItemDiff
				newWith: package)
				beNew;
				parent: parent;
				diff: self);
		yourself! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
dependentPackagesDiffNew
	^ dependentPackagesDiff select: [ :each | each isNew ]! !

!DAPackageRelationGraphDiff methodsFor: 'adding' stamp: ''!
addRemovedPackage: seenPackage
	^ packagesDiff
		add:
			((DAPackageItemDiff newWith: seenPackage)
				beRemoved;
				diff: self);
		yourself! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
dependentPackagesDiffUnderteminate
	^ dependentPackagesDiff select: [ :each | each isUnderteminate ]! !

!DAPackageRelationGraphDiff methodsFor: 'accessing' stamp: ''!
packagesDiffNewSize
	^ self packagesDiffNew size! !

!DAPackageRelationGraphDiff methodsFor: 'adding' stamp: ''!
addUndeterminatePackage: aPackage
	^ packagesDiff
		add:
			((DAPackageItemDiff newWith: aPackage)
				beUnderteminate;
				diff: self);
				yourself! !

!DAPackageRelationGraphDiff methodsFor: 'searching' stamp: ''!
make
	self 
		makePackagesDiff;	
		makeDependentPackagesDiff
		! !

!DAPackageRelationGraphDiff class methodsFor: 'private' stamp: ''!
loadFrom: aSerializeFile with: newRelationGraph
	^ self new
		oldRelationGraph: (FLMaterializer materializationFromFileNamed: aSerializeFile);
		newRelationGraph: newRelationGraph! !

!DAPackageRelationGraphDiff class methodsFor: 'private' stamp: ''!
loadFrom: aSerializeFile 
	^ self new
		oldRelationGraph: (FLMaterializer materializationFromFileNamed: aSerializeFile).! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testMakeDependentPackagesDifferentOnDifferentGraph
	| oldSize |
	oldSize := newRelationGraph seenPackages first dependentPackages size.
	newRelationGraph seenPackages first clearDependencies.

	packageRelationGraphDiff make.

	self assert: packageRelationGraphDiff dependentPackagesDiffRemoved size equals: oldSize.
	self assert: packageRelationGraphDiff dependentPackagesDiffUnderteminate size equals: newRelationGraph seenPackages last dependentPackages size! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testMakePackagesDiffOnDifferentGraph
	newRelationGraph removePackage: 'Collections-Abstract'.
	packageRelationGraphDiff makePackagesDiff.

	self assert: packageRelationGraphDiff packagesDiffRemovedSize equals: 1.
	self assert: packageRelationGraphDiff packagesDiffUnderteminateSize equals: 1! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testRemovedDependentPackagesIncludesFrom
	| dependentPackages package |
	package := newRelationGraph seenPackages first.
	dependentPackages := package dependentPackages.
	
	package clearDependencies.
	
	packageRelationGraphDiff make.
			
	self assert: (packageRelationGraphDiff removedDependentPackagesIncludes: dependentPackages anyOne from: package).
			
	
	
! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testPackagesDiffToDisplayOnSameGraph
	packageRelationGraphDiff make.
	self assertEmpty: packageRelationGraphDiff packagesDiffToDisplay! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testHasChangedForPackageItemDiff
	| first second |
	first := newRelationGraph seenPackages first.
	second := newRelationGraph seenPackages last.
	
	first clearDependencies.
	
	packageRelationGraphDiff make.
			
	self assert: ((packageRelationGraphDiff packageDiffNamed: first packageName) hasChanged).
	self deny: ((packageRelationGraphDiff packageDiffNamed: second packageName) hasChanged).
! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testMakePackagesDiffOnSameGraph
	packageRelationGraphDiff makePackagesDiff.

	self assert: packageRelationGraphDiff packagesDiff size equals: oldRelationGraph seenPackages size.
	self assert: (packageRelationGraphDiff packagesDiff allSatisfy: [ :item | item isUnderteminate ])! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testRemovedPackagesIncludes
	newRelationGraph clearPackages .
	packageRelationGraphDiff makePackagesDiff.
	
	self assert: (packageRelationGraphDiff removedPackagesIncludes: (DAPackage on: (RPackageSet named: 'Collections-Abstract'))).
	self assert: (packageRelationGraphDiff removedPackagesIncludes: (DAPackage on: (RPackageSet named: 'Collections-Strings'))).
	! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testMakeDependentPackagesDiffOnSameGraph
	packageRelationGraphDiff makePackagesDiff.
	self assertEmpty: packageRelationGraphDiff dependentPackagesDiff! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testPackagesDiffToDisplayBis
	| first |
	first := newRelationGraph seenPackages first.
	first clearDependencies.
	packageRelationGraphDiff make.

	self assert: packageRelationGraphDiff packagesDiffToDisplay size equals: 1! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testHasChangedForPackageItemDiffOnOneDependentPackageRemoved
	| first |
	first := newRelationGraph seenPackages first.
	first dependencies remove: (first dependencies anyOne).
	
	packageRelationGraphDiff make.
			
	self assert: ((packageRelationGraphDiff packageDiffNamed: first packageName) hasChanged).
	! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
testPackagesDiffToDisplay
	| first second |
	first := newRelationGraph seenPackages first.
	second := newRelationGraph seenPackages last.

	first clearDependencies.
	second dependencies remove: second dependencies anyOne.

	packageRelationGraphDiff make.
	self assert: packageRelationGraphDiff packagesDiffToDisplay size equals: 2! !

!DAPackageRelationGraphDiffTest methodsFor: 'running' stamp: ''!
setUp
	| packageCollectionsAbstract packageCollectionsString |
	super setUp.
	packageA := DAPackage on: (RPackageSet named: 'A').
	packageB := DAPackage on: (RPackageSet named: 'B').
	packageCollectionsAbstract := DAPackage on: (RPackageSet named: 'Collections-Abstract').
	packageCollectionsString := DAPackage on: (RPackageSet named: 'Collections-Strings').
	oldRelationGraph := DAPackageRelationGraph onPackages: (Array with: packageCollectionsAbstract with: packageCollectionsString ).
	newRelationGraph := DAPackageRelationGraph
		onPackages: (Array with: (DAPackage on: (RPackageSet named: 'Collections-Abstract')) with: (DAPackage on: (RPackageSet named: 'Collections-Strings'))).
	oldRelationGraph build.
	newRelationGraph build.
	
	packageRelationGraphDiff := DAPackageRelationGraphDiff new
		oldRelationGraph: oldRelationGraph;
		newRelationGraph: newRelationGraph! !

!DAPackageRelationGraphGenerator commentStamp: ''!
A class able to generate a dot file from a relationGraph (PDPackageRelationGraph)!
!DAPackageRelationGraphGenerator methodsFor: 'build items' stamp: ''!
buildNodes
	relationGraph seenPackages do: [ :package | graphviz add: package packageName ] displayingProgress: 'Building nodes'! !

!DAPackageRelationGraphGenerator methodsFor: 'accessing' stamp: ''!
relationGraph
	^ relationGraph! !

!DAPackageRelationGraphGenerator methodsFor: 'build items' stamp: ''!
buildEdges
	relationGraph packages
		do: [ :package | 
			package dependencies
				do: [ :dependency | 
					graphviz
						add: dependency source packageName -> dependency target packageName
						with: {(#label -> dependency numberOfDependencies)} ] ]
		displayingProgress: 'Building edges'! !

!DAPackageRelationGraphGenerator methodsFor: 'accessing' stamp: ''!
relationGraph: anObject
	relationGraph := anObject! !

!DAPackageRelationGraphGenerator class methodsFor: 'instance creation' stamp: ''!
newWith: aRelationGraph named: aString

	| generator |
	generator := self new.
	generator relationGraph: aRelationGraph.
	generator nameOfGraph: aString.
	generator buildGraphViz.
	^ generator! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testRemovePackage
	self assertEmpty: aPackageRelationGraph packages.
	aPackageRelationGraph addPackage: packageCollectionAbstract.
	self assert: aPackageRelationGraph packages size equals: 1.
	aPackageRelationGraph removePackage: packageCollectionAbstract packageName.
	self assertEmpty: aPackageRelationGraph packages! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testAllDependentPackages
	
		packageA add: (DAPackageDependency from: packageA to: packageB).
! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testIncludedPackages
	| aCollection |
	aCollection := Bag new.
	"we add 2 packages in the relation"
	aCollection add: packagePackageDependencies.
	aCollection add: packageKernel.
	aCollection do: [ :each | aPackageRelationGraph addPackage: each ].
	self assert: aPackageRelationGraph includedPackages size equals: 2! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testSystemPackageContaining
	self assert: (aPackageRelationGraph systemPackageContaining: Collection) packageName equals: 'Collections-Abstract'.
	self assert: (aPackageRelationGraph systemPackageContaining: DAPackageRelationGraph) packageName equals: #'Tool-DependencyAnalyser'! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testAddExtensionDependencies
	aPackageRelationGraph addExtensionDependencies: packageCollectionAbstract.
	"self assert: (packageStrings  dependentPackages includes: packageCollectionAbstract)."
	"self assert: (packageCollectionAbstract dependentPackages includes: packageKernel).
	self assert: (packageCollectionAbstract dependentPackages includes: packageRegexCore).
	self assert: (packageCollectionAbstract dependentPackages includes: packageCollectionsSequenceable)."

	
! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testPackageAt

	aPackageRelationGraph addPackage: packageKernel.
	self assert: ( (aPackageRelationGraph packageAt: 'Kernel') isNotNil).! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testComputeDependencies
	aPackageRelationGraph computeStaticDependencies: packageCollectionAbstract.
	self deny: (packageCollectionAbstract dependencies isEmpty)! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testCombineDependencies
	| aSet |
	aSet := Set new.
	aPackageRelationGraph computeStaticDependencies:packageCollectionAbstract.
	packageCollectionAbstract removeAllInternal.
	"we collect all the target PDPackage"
	packageCollectionAbstract dependencies do: [ :dependency |
		aSet add: dependency target.
	  ].
	aPackageRelationGraph combineDependencies: packageCollectionAbstract.
	aSet do: [ :each | self assert: (packageCollectionAbstract dependentPackages includes: each) ]
	

	
	
	
	
	! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testSeenPackagesName
	aPackageRelationGraph addPackage: packageKernel.
	self deny: (aPackageRelationGraph seenPackagesName includes: 'Kernel').
	aPackageRelationGraph computeStaticDependencies.
	self assert: (aPackageRelationGraph seenPackagesName includes: 'Kernel').! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testPredecessors
	| aCollection |
	"A -> B, C, D ; B -> D, C"
	aCollection := OrderedCollection new.
	aCollection add: packageA.
	aCollection add: packageB.
	aCollection add: packageC.
	aCollection add: packageD.
	packageA add: (DAPackageDependency from: packageA to: packageB).
	packageA add: (DAPackageDependency from: packageA to: packageC).
	packageA add: (DAPackageDependency from: packageA to: packageD).
	packageB add: (DAPackageDependency from: packageB to: packageC).
	packageB add: (DAPackageDependency from: packageB to: packageD).
	aCollection do: [ :package | aPackageRelationGraph addPackage: package ].
	self assert: (aPackageRelationGraph predecessors: packageC) size equals: 2.
	self assertEmpty: (aPackageRelationGraph predecessors: (aCollection at: 1)).
	self assert: (aPackageRelationGraph predecessors: packageB) size equals: 1.
	self assert: (aPackageRelationGraph predecessors: packageD) size equals: 2! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testDependenciesFrom
	| aCollection |
	aCollection := OrderedCollection new.
	aCollection add: packageA.
	aCollection add: packageB.
	aCollection add: packageC.
	(aCollection at: 1) add: (DAPackageDependency from: packageA to: packageB).
	(aCollection at: 1) add: (DAPackageDependency from: packageA to: packageC).
	(aCollection at: 2) add: (DAPackageDependency from: packageB to: packageC).
	aCollection do: [ :package | aPackageRelationGraph addPackage: package ].
	self assert: (aPackageRelationGraph dependenciesFrom: 'A') size equals: 2.
	self assert: (aPackageRelationGraph dependenciesFrom: 'B') size equals: 1.
	self assertEmpty: (aPackageRelationGraph dependenciesFrom: 'C')! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testPdPackageFrom
	aPackageRelationGraph addPackage: packageCollectionAbstract.
	self assert: (aPackageRelationGraph pdPackageFrom: Collection) equals: packageCollectionAbstract! !

!DAPackageRelationGraphTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	aPackageRelationGraph := DAPackageRelationGraph new.
	packageCollectionAbstract := DAPackage on: (RPackageSet named: 'Collections-Abstract').
	packageStrings := DAPackage on:(RPackageSet named: 'Collections-Strings').
	packageKernel := DAPackage on:(RPackageSet named: 'Kernel').
	packageMorphicBase := DAPackage on: (RPackageSet named: 'Morphic-Base').
	packageTextCore := DAPackage on: (RPackageSet named: 'Text-Core').
	packageRegexCore := DAPackage on:(RPackageSet named: 'Regex-Core').
	packageCollectionsSequenceable := DAPackage on: (RPackageSet named: 'Collections-Sequenceable').
	packagePackageDependencies := DAPackage on: (RPackageSet named:  #'Tool-DependencyAnalyser').
	packageA := DAPackage on: (RPackageSet named: 'A').
	packageB := DAPackage on: (RPackageSet named: 'B').
	packageC := DAPackage on: (RPackageSet named: 'C').
	packageD := DAPackage on: (RPackageSet named: 'D').! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testAllDependentPackagesFromSeenPackages
	packageA
		add: (self packageDependencyFrom: packageA to: packageB);
		add: (self packageDependencyFrom: packageA to: packageC).
	packageB add: (self packageDependencyFrom: packageB to: packageC).
	packageB add: (self packageDependencyFrom: packageB to: packageA).

	packageA beSeen.
	packageB beSeen.
	aPackageRelationGraph
		addPackage: packageA;
		addPackage: packageB.
	self assert: aPackageRelationGraph allDependentPackagesFromSeenPackages size equals: 3! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testAddInheritanceDependencies
	aPackageRelationGraph addInheritanceDependencies: packageCollectionAbstract.
	"Collections-Abstract has one dependency with Error and Object by Inheritance"
	self assert: (packageCollectionAbstract dependentPackages includes: packageKernel).! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testPackages
	| aCollection |
	self assertEmpty: aPackageRelationGraph packages.
	aCollection := Bag new.
	aCollection add: packagePackageDependencies.
	aCollection add: packageKernel.
	aCollection do: [ :each | aPackageRelationGraph addPackage: each ].
	self assert: aPackageRelationGraph packages size equals: 2! !

!DAPackageRelationGraphTest methodsFor: 'utilities' stamp: ''!
packageDependencyFrom: aPackage to: anOtherPackage
	^ DAPackageDependency from: aPackage to: anOtherPackage! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testAddPackages
	| array |
	self assertEmpty: aPackageRelationGraph packages.
	array := Array with: packageCollectionAbstract with: packageCollectionsSequenceable with: packageKernel.
	aPackageRelationGraph addPackages: array.
	self assert: aPackageRelationGraph packages size equals: 3! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testSuccessors
	| aCollection |
	"A -> B, C, D ; B -> D, C"
	aCollection := OrderedCollection new.
	aCollection add: packageA.
	aCollection add: packageB.
	aCollection add: packageC.
	aCollection add: packageD.
	packageA add: (DAPackageDependency from: packageA to: packageB).
	packageA add: (DAPackageDependency from: packageA to: packageC).
	packageA add: (DAPackageDependency from: packageA to: packageD).
	packageB add: (DAPackageDependency from: packageB to: packageC).
	packageB add: (DAPackageDependency from: packageB to: packageD).
	aCollection do: [ :package | aPackageRelationGraph addPackage: package ].
	self assert: (aPackageRelationGraph successors: (aCollection at: 1)) size equals: 3.
	self assertEmpty: (aPackageRelationGraph successors: (aCollection at: 4)).
	self assert: (aPackageRelationGraph successors: (aCollection at: 2)) size equals: 2.
	self assertEmpty: (aPackageRelationGraph successors: (aCollection at: 3))! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testUsersOf
	packageA
		add: (self packageDependencyFrom: packageA to: packageB);
		add: (self packageDependencyFrom: packageA to: packageC);
		beSeen.
	packageB
		add: (self packageDependencyFrom: packageA to: packageC);
		beSeen.

	aPackageRelationGraph
		addPackage: packageA;
		addPackage: packageB.

	self assert: (aPackageRelationGraph usersOf: packageC) size equals: 2.
	self assert: ((aPackageRelationGraph usersOf: packageC) includes: packageB)! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testAddPackage
	self assertEmpty: aPackageRelationGraph packages.
	aPackageRelationGraph addPackage: packageCollectionAbstract.
	self assert: aPackageRelationGraph packages size equals: 1.
	aPackageRelationGraph addPackage: packageCollectionsSequenceable.
	self assert: aPackageRelationGraph packages size equals: 2! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testRemoveOutgoingDependencies
	aPackageRelationGraph computeStaticDependencies.
	aPackageRelationGraph removeOutgoingDependencies.
	
	aPackageRelationGraph packages do: [ :package |
			package dependencies do: [ :dependency |
				self assert: (dependency target isIncluded)
				]
		 ].! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testSeenPackages
	aPackageRelationGraph addPackage: packageKernel.
	aPackageRelationGraph addPackage: packageCollectionAbstract.
	self assertEmpty: aPackageRelationGraph seenPackages.
	aPackageRelationGraph computeStaticDependencies.
	self assert: aPackageRelationGraph seenPackages size equals: 2! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testAllSeen
	aPackageRelationGraph addPackage: packageKernel.
	self deny: (aPackageRelationGraph allSeen).
	aPackageRelationGraph computeStaticDependencies.
	self deny: (aPackageRelationGraph allSeen)! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testRemoveInternalDependencies
	aPackageRelationGraph computeStaticDependencies.
	aPackageRelationGraph removeInternalDependencies.
	
	aPackageRelationGraph packages do: [ :value |
				value dependencies do: 
					[ :dependency |
					self assert: (dependency isExternal).
					 ] ].! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testAddReferenceDependencies
	aPackageRelationGraph addReferenceDependencies: packagePackageDependencies.
	packagePackageDependencies removeAllInternal.
	self assert: (packagePackageDependencies  dependentPackages includes: packageStrings).! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testClearAllDependencies
	| aRelationGraph packagesFromGraph |
	aRelationGraph := DAPackageRelationGraph
		onPackages:
			(#('Collections-Abstract' 'Collections-Sequenceable') collect: [ :each | DAPackage on: (RPackageSet named: each) ]).
	aRelationGraph
		build;
		clearAllDependencies.
	packagesFromGraph := aRelationGraph seenPackages.
	self assert: (packagesFromGraph anySatisfy: [ :package | package dependencies isEmpty ])! !

!DAPackageRelationGraphTest methodsFor: 'tests' stamp: ''!
testAddPoolDictionaryDependencies
	aPackageRelationGraph addPoolDictionaryDependencies: packageMorphicBase.
 
	self assert: (packageMorphicBase dependentPackages includes: packageTextCore).! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testBeIncluded
	aPackage beIncluded.
	self assert: (aPackage isIncluded)! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testNumberOfDependentPackage
	self assert: aPackage dependentPackagesSize equals: 1.
	aPackage add: (DAPackageDependency from: aPackage to: packageA).
	self assert: aPackage dependentPackagesSize equals: 2! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testPackageName
	self assert: packageA packageName equals: 'A'! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testDependenciesSize
	| aCompositeDependency |
	aCompositeDependency := DACompositeDependency from: packageA to: packageB.
	aCompositeDependency add: (DAInheritanceDependency from: aPackage to: packageB).
	aCompositeDependency add: (DAInheritanceDependency from: aPackage to: packageB).
	self assert: aPackage dependenciesSize equals: 1.
	aPackage add: aCompositeDependency.
	self assert: aPackage dependenciesSize equals: 3! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testAdd
	| aDependency |
	aDependency := DAPackageDependency from: aPackage to: aSecondPackage.
	aPackage add: aDependency.

	self assert: aPackage dependencies size equals: 2.
	self assert: (aPackage dependencies includes: aDependency)! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testDependenciesTo
	self assert: (aPackage dependenciesTo: aSecondPackage packageName) size equals: 1.
	self assertEmpty: (aPackage dependenciesTo: 'Test')! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testCleardependencies
	aPackage clearDependencies.
	self assertEmpty: aPackage dependencies! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testDependentPackages
	self assert: aPackage dependentPackages size equals: 1.
	self assert: (aPackage dependentPackages anySatisfy: [ :package | package = aSecondPackage ]).
	self assertEmpty: aSecondPackage dependentPackages! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testDependentPackagesSize
	| dependency |
	self assert: aPackage dependentPackagesSize equals: 1.
	dependency := DAPackageDependency from: aPackage to: packageA.
	aPackage add: dependency.
	self assert: aPackage dependentPackagesSize equals: 2! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testRemoveAllInternal
	aPackage clearDependencies.
	aPackage add: (DAPackageDependency from: aPackage to: aPackage).
	aPackage add: (DAPackageDependency from: aSecondPackage to: aSecondPackage).
	aPackage removeAllInternal.
	self assertEmpty: aPackage dependencies! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testReferenceDependenciesFrom
	| aRelationGraph |
	aRelationGraph := DAPackageRelationGraph new.
	[ aRelationGraph
		computeStaticDependencies: aPackage;
		combineDependencies: aPackage ]
	on: PotentialOutDatedDependencyWarning
	do: [ :ex | ex resume "ignore" ].
	self
		assert:
			((aPackage referenceDependenciesFrom: Collection) allSatisfy: [ :dependency | dependency isReferenceDependency ]).
	self
		assert:
			((aPackage referenceDependenciesFrom: Collection) allSatisfy: [ :dependency | dependency theClass = Collection ])! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testDependantPackages
	| aCollection |
	aPackage add: (DAPackageDependency from: aPackage to: packageA).

	aCollection := aPackage dependentPackages.
	self assert: (aCollection includes: packageA).
	self assert: (aCollection includes: aSecondPackage).
	self assert: aCollection size equals: 2! !

!DAPackageTest methodsFor: 'tests' stamp: ''!
testDependenciesFrom
	| aRelationGraph |
	aRelationGraph := DAPackageRelationGraph new.
	[ aRelationGraph
		computeStaticDependencies: aPackage;
		combineDependencies: aPackage ]
		on: PotentialOutDatedDependencyWarning
		do: [ :ex | ex resume "ignore" ].
	self
		assert:
			((aPackage dependenciesFrom: Collection) allSatisfy: [ :dependency | dependency theClass = Collection ])! !

!DAPackageTest methodsFor: 'running' stamp: ''!
testDependenciesSizeTo
	packageA
		add: (DAInheritanceDependency from: packageA to: packageB);
		add: (DAInheritanceDependency from: packageA to: packageC).
	self assert: (packageA dependenciesSizeTo: packageB) equals: 1! !

!DAPackageTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	aPackage := DAPackage on: (RPackageSet named: 'Collections-Abstract'). 
	aSecondPackage := DAPackage on: (RPackageSet named: 'Collections-Arithmetic').
	packageA := DAPackage on: (RPackageSet named: 'A').
	packageB := DAPackage on: (RPackageSet named: 'B').
	packageC := DAPackage on: (RPackageSet named: 'C').
	aPackage add: (DAInheritanceDependency from:aPackage to:aSecondPackage).! !

!DAPackageTreePresenter commentStamp: ''!
A DAPackageTreeModel is an abstract class. It's a the superclass of the two tree model vizualisations (package dependency and cycle detection).!
!DAPackageTreePresenter methodsFor: 'testing' stamp: ''!
areClassToDependencyNodes: aCollectionOfItem
	^ aCollectionOfItem allSatisfy: [ :node |  node isClassToDependencyNode ].! !

!DAPackageTreePresenter methodsFor: 'testing' stamp: ''!
arePackageNodes: aCollectionOfItem
	^ aCollectionOfItem allSatisfy: [ :node |  node isPackageNode ].! !

!DAPackageTreePresenter methodsFor: 'accessing' stamp: ''!
buttonRefresh
	^ buttonRefresh! !

!DAPackageTreePresenter methodsFor: 'testing' stamp: ''!
ifGraphVizAbsent: aBlock
	Smalltalk at: #GVGraphViz ifAbsent: aBlock! !

!DAPackageTreePresenter methodsFor: 'accessing' stamp: ''!
selectedItemsFromTree
	^ self tree selectedItems! !

!DAPackageTreePresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	tree := self newTree
		multiSelection: true;
		bindKeyCombination: $b meta toAction: [ self selectedItemFromTree spawnNewBrowser ];
		columns: {(TreeColumnPresenter new displayBlock: [ :node | node label ])};
		yourself.
	buttonRefresh := self newButton
		icon: (self iconNamed: #refreshIcon);
		help: 'Refresh the TreePresenter';
		label: 'Refresh';
		yourself.
	browser := Smalltalk tools browser onDefaultEnvironment! !

!DAPackageTreePresenter methodsFor: 'instance creation' stamp: ''!
open
	open := true.
	^ self openWithSpec ! !

!DAPackageTreePresenter methodsFor: 'actions' stamp: ''!
addPackageOptionsFor: selectedNodes on: menuGroup
	| selectedPackageNames |
	(self arePackageNodes: selectedNodes)
		ifTrue: [ 
			selectedPackageNames := selectedNodes collect: [ :packageNode | packageNode packageName ].
			menuGroup
				addMenuItem:
					(MenuItemPresenter new
						name: 'Browse scoped dependencies';
						action: [ (DAPackageAnalyzerPackageDependenciesWindow onPackagesNamed: selectedPackageNames) open ]).
			selectedNodes size > 1
				ifTrue: [ 
					menuGroup
						addMenuItem:
							(MenuItemPresenter new
								name: 'Find cycles among packages';
								action: [ (DAPackageAnalyzerCycleDetectionWindow onPackagesNamed: selectedPackageNames) open ]) ] ]! !

!DAPackageTreePresenter methodsFor: 'actions' stamp: ''!
refresh
	self subclassResponsibility ! !

!DAPackageTreePresenter methodsFor: 'actions' stamp: ''!
selectedItemFromTree
	^ self tree selectedItem! !

!DAPackageTreePresenter methodsFor: 'accessing' stamp: ''!
tree
	^ tree! !

!DAPackageTreePresenter methodsFor: 'initialization' stamp: ''!
browseReference
	self selectedItemFromTree isReferenceNode ifTrue: [ 
			self selectedItemFromTree browseReference
		 ]! !

!DAPackageTreePresenter methodsFor: 'private' stamp: ''!
buildRoots
	self subclassResponsibility.! !

!DAPackageTreePresenter methodsFor: 'actions' stamp: ''!
addDependenciesOptionsFor: selectedNodes on: menuGroup
	| namesOfSelected |
	(self areClassToDependencyNodes: selectedNodes)
		ifTrue: [ 
			namesOfSelected := selectedNodes collect: [ :package | package content theClass ].
			menuGroup
				addMenuItem:
					(MenuItemPresenter new
						name: 'Browse dependencies from class';
						action: [ self openTreeFor: namesOfSelected ]) ]! !

!DAPackageTreePresenter methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!DAPackageTreePresenter methodsFor: 'protocol' stamp: ''!
defaultFormat
	^ #png! !

!DAPackageTreePresenter methodsFor: 'actions' stamp: ''!
openTreeFor: namesOfSelected
	| treeToOpen relationGraph |
	treeToOpen := TreePresenter new.
	relationGraph := self tree owner relationGraph.
	^ treeToOpen
		roots: namesOfSelected;
		whenBuiltDo: [ 
					treeToOpen
						rootNodeHolder: [ :item | 
							DAClassToDependencyNode new
								content: item;
								package: (relationGraph pdPackageFrom: item) ] ];
		title: 'Class dependencies';
		extent: 700 @ 500;
		openWithSpec! !

!DAPackageTreePresenter methodsFor: 'actions' stamp: ''!
close
	open := false.
	browser windowIsClosing! !

!DAPackageTreePresenter methodsFor: 'testing' stamp: ''!
isOpen
	^ open! !

!DAPackageTreePresenter methodsFor: 'protocol' stamp: ''!
saveGraphAndOpenWith: graphvizGenerator
	graphvizGenerator saveDotFileAndGenerateForType: self defaultFormat.
	^ graphvizGenerator openWith: self defaultFormat! !

!DAPackageTreePresenter methodsFor: 'private' stamp: ''!
actionOnRefresh
	buttonRefresh action: [ self refresh ]! !

!DAPackageTreePresenter methodsFor: 'actions' stamp: ''!
loadMenuFor: item in: aMenu
	| menuGroup selectedNodes |
	selectedNodes := self selectedItemsFromTree.
	menuGroup := MenuGroupPresenter new.
	self addPackageOptionsFor: selectedNodes on: menuGroup.
	self addDependenciesOptionsFor: selectedNodes asSet on: menuGroup.
	(selectedNodes size = 1)
		ifTrue: [ selectedNodes first addMenuEntriesOn: menuGroup ].
	
	aMenu addMenuGroup: menuGroup.
	^ aMenu! !

!DAPackageTreePresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	self actionOnRefresh! !

!DAPackageTreePresenter class methodsFor: 'testing' stamp: ''!
isAbstract

	^self == DAPackageTreePresenter! !

!DAPackageUnderAnalysisNode commentStamp: ''!
A DAPackageNode is used to display a package in a tree.!
!DAPackageUnderAnalysisNode methodsFor: 'testing' stamp: ''!
isPackageNode
	^ true! !

!DAPackageUnderAnalysisNode methodsFor: 'accessing' stamp: ''!
children
	^ (self packageDependencies"GroupedByAssembly" sort: [ :a :b | a packageName < b packageName])
		copyWith: DAPotentialDependenciesNode new! !

!DAPackageUnderAnalysisNode methodsFor: 'testing' stamp: ''!
hasChildren
	^ [ true ]! !

!DAPackageUnderAnalysisNode methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	self content printOn: aStream.
	aStream nextPut: $)
! !

!DAPackageUnderAnalysisNode methodsFor: '*Deprecated10' stamp: ''!
wrappedPackageDependenciesGroupedByAssembly
	| assemblyNodes |
	self deprecated: 'Deprecated together with assembly mechanism. See issue #9670'.
	assemblyNodes := self assemblyNodesFor: { CollectionsAssembly . PharoKernelAssembly }.
	^ ((self packageDependencies
		reject: [ :dependency | 
			assemblyNodes anySatisfy: [ :assemblyNode | assemblyNode includes: dependency packageName ] ]
		thenCollect: #asPackageDependencyWrapper) sorted asOrderedCollection)
		addAll: assemblyNodes;
		yourself! !

!DAPackageUnderAnalysisNode methodsFor: 'dependencies' stamp: ''!
wrappedPackageDependencies
	^ (self packageDependencies
		collect: #asPackageDependencyWrapper 
		as: OrderedCollection) sorted! !

!DAPackageUnderAnalysisNode methodsFor: 'accessing' stamp: ''!
daPackage
	^ self content! !

!DAPackageUnderAnalysisNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #packageIcon! !

!DAPackageUnderAnalysisNode methodsFor: 'accessing' stamp: ''!
manuallyResolvedDependencies
	^ self packageUnderAnalysis manuallyResolvedDependencies
		collect: [ :packageName | DAManuallyAddedDependentPackageNode new content: packageName ]! !

!DAPackageUnderAnalysisNode methodsFor: 'accessing' stamp: ''!
packageName
	^ self daPackage packageName! !

!DAPackageUnderAnalysisNode methodsFor: 'dependencies' stamp: ''!
assemblyNodeFor: anAssemblyManifest
	^ (DAAssemblyNode newWith: (self packageDependencies 
			select: [ :dependency | anAssemblyManifest includes: dependency packageName ]
			thenCollect: #asPackageDependencyWrapper))
		content: anAssemblyManifest packageName;
		yourself! !

!DAPackageUnderAnalysisNode methodsFor: 'dependencies' stamp: ''!
packageDependencies
	^ self rootNode isCycle
		ifTrue: [ self rootNode content dependentPackagesFrom: self content ]
		ifFalse: [ self content dependencies ]! !

!DAPackageUnderAnalysisNode methodsFor: 'browse-nautilus' stamp: ''!
selectInBrowser
	self selectPackage: self content rPackage! !

!DAPackageUnderAnalysisNode methodsFor: 'dependencies' stamp: ''!
assemblyNodesFor: aListOfAssemblyManifest
	^ aListOfAssemblyManifest 
		collect: [ :each | self assemblyNodeFor: each ]
		as: OrderedCollection! !

!DAPackageUnderAnalysisNode methodsFor: 'api' stamp: ''!
childNodeClassFor: anItem
	 ^ anItem nodeClass! !

!DAPackageUnderAnalysisNode methodsFor: 'comparing' stamp: ''!
<= aDANode 
	^ (aDANode class respondsTo: #packageName) and: [ self packageName <= aDANode packageName ]! !

!DAPoolDictionaryDependency commentStamp: ''!
I am a dependency produced by a pool Dictionary.
For example the following class CharacterBlock depends on the Text package because it uses TextConstants that is defined in it.

Rectangle subclass: #CharacterBlock
	instanceVariableNames: 'stringIndex text textLine'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	package: 'Text-Scanning-Base'!
!DAPoolDictionaryDependency methodsFor: 'accessing' stamp: ''!
poolDictionary: aClass
	poolDictionary := aClass! !

!DAPoolDictionaryDependency methodsFor: '*Tool-DependencyAnalyser-UI' stamp: ''!
nodeClass
	^ DAPoolDictionaryDependencyNode! !

!DAPoolDictionaryDependency methodsFor: 'accessing' stamp: ''!
poolDictionary
	^ poolDictionary! !

!DAPoolDictionaryDependency methodsFor: 'printing' stamp: ''!
printReasonOn: aStream
	aStream
		nextPutAll: self theClass name;
		nextPutAll: ' uses pool dictionary ';
		nextPutAll: self poolDictionary name! !

!DAPoolDictionaryDependencyNode commentStamp: ''!
I am a tree node showing pool dictionary dependencies.
I define an icon for pool dictionaries and spawn a new browser on the pool dictionary when browsing the dependency.!
!DAPoolDictionaryDependencyNode methodsFor: 'browse-nautilus' stamp: ''!
spawnNewBrowser
	self browseClass: self content poolDictionary! !

!DAPoolDictionaryDependencyNode methodsFor: 'accessing' stamp: ''!
icon

	^ self iconNamed: #classVarsSelected! !

!DAPotentialDependenciesNode commentStamp: ''!
I'm a node allowing to compute and browse potential dependencies of a package, i.e. messages sent in the package but with no corresponding method in the package or in its dependencies.!
!DAPotentialDependenciesNode methodsFor: 'accessing' stamp: ''!
extensionDependenciesSize
	^ 0! !

!DAPotentialDependenciesNode methodsFor: 'testing' stamp: ''!
isPackageNode
	^ false! !

!DAPotentialDependenciesNode methodsFor: 'accessing' stamp: ''!
messageSendAnalysis
	[ messageSendAnalysis ifNil: [ messageSendAnalysis := DAMessageSendAnalyzer on: self parentNode content packageName ] ]
		on: PotentialOutDatedDependencyWarning 
		do: [ :ex | ex resume. "ignore. We already got an alert box" ].
	^ messageSendAnalysis! !

!DAPotentialDependenciesNode methodsFor: 'accessing' stamp: ''!
hasChildren
	^ true! !

!DAPotentialDependenciesNode methodsFor: 'api' stamp: ''!
buildChildren
	^ (self messageSendAnalysis unimplementedCallsInAllDependencies
		collect: [ :selector | 
						(DAMissingMethodNode new
								content: selector;
								parentNode: self;
								yourself) ]
		as: Array) 
			sort: [ :a :b | a content < b content ]! !

!DAPotentialDependenciesNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #smallHelpIcon! !

!DAPotentialDependenciesNode methodsFor: 'accessing' stamp: ''!
content
	^ 'Potential dependencies'! !

!DAPotentialDependenciesNode methodsFor: 'compatibility' stamp: ''!
numberOfDependencies
	^ 0! !

!DAPotentialDependenciesNode methodsFor: 'browse-nautilus' stamp: ''!
selectInBrowser
	self selectMethod:
		([ self packageUnderAnalysis packageManifest class methodNamed: #manuallyResolvedDependencies ]
			on: KeyNotFound
			do: [ PackageManifest class>>#manuallyResolvedDependencies ])! !

!DAPotentialDependenciesNode methodsFor: 'displaying' stamp: ''!
label
	^ self content! !

!DAReferenceDependency commentStamp: ''!
A PDReferenceDependency is a reference dependency between two packages. 

Instance Variables
	reference:		the reference class
	selector:		the selector that references the class
	method : 		the CompiledMethod
!
!DAReferenceDependency methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!DAReferenceDependency methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!DAReferenceDependency methodsFor: '*Tool-DependencyAnalyser-UI' stamp: ''!
nodeClass
	^ DAReferenceDependencyNode! !

!DAReferenceDependency methodsFor: 'accessing' stamp: ''!
reference: aClass
	reference := aClass! !

!DAReferenceDependency methodsFor: 'accessing' stamp: ''!
selector: aSymbol
	selector := aSymbol! !

!DAReferenceDependency methodsFor: 'testing' stamp: ''!
isReferenceDependency
	^ true! !

!DAReferenceDependency methodsFor: 'accessing' stamp: ''!
method: anObject
	method := anObject! !

!DAReferenceDependency methodsFor: 'accessing' stamp: ''!
reference
	^ reference! !

!DAReferenceDependency methodsFor: 'printing' stamp: ''!
printReasonOn: aStream
	aStream
		nextPutAll: self theClass name;
		nextPutAll: '>>';
		print: self selector;
		nextPutAll: ' references ';
		print: self reference! !

!DAReferenceDependencyNode commentStamp: ''!
A PDCycleNode is used to display a reference dependency in a tree.!
!DAReferenceDependencyNode methodsFor: 'browse-nautilus' stamp: ''!
spawnNewBrowser
	| classToBrowse |
	classToBrowse := self content reference.
	self browseClass: classToBrowse! !

!DAReferenceDependencyNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #classIcon! !

!DAReferenceDependencyNode methodsFor: 'testing' stamp: ''!
isClassToDependencyNode
	^ true! !

!DAReferenceDependencyNode methodsFor: 'testing' stamp: ''!
isReferenceNode
	  ^ true! !

!DAReferenceDependencyNode methodsFor: 'testing' stamp: ''!
browseSendersOrUsers
	! !

!DAReverseDependentPackageNode commentStamp: ''!
A DAReverseDependentPackageNode is used to display a dependent package in a reverse tree.!
!DAReverseDependentPackageNode methodsFor: 'accessing' stamp: ''!
children
	^ self dependenciesToParentNode dependencies! !

!DAReverseDependentPackageNode methodsFor: 'testing' stamp: ''!
hasChildren
	^ self dependenciesToParentNode isNotNil! !

!DAReverseDependentPackageNode methodsFor: 'accessing' stamp: ''!
rPackage
	^ self content rPackageSet! !

!DAReverseDependentPackageNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #backIcon! !

!DAReverseDependentPackageNode methodsFor: 'private' stamp: ''!
dependenciesToParentNode
	^ self content daPackage 
		compositeDependencyTo: (self parentNode content daPackage)! !

!DAReverseDependentPackageNode methodsFor: 'api' stamp: ''!
childNodeClassFor: anItem
	^ anItem nodeClass! !

!DAReversePackageNode commentStamp: ''!
A DAReversePackageNode is a node to display a package in the tree during a reverse analysis.!
!DAReversePackageNode methodsFor: 'accessing' stamp: ''!
children
	^ (self content usersOfPackage 
		collect: [ :each | each asPackageDependencyWrapper ]) asSortedCollection! !

!DAReversePackageNode methodsFor: 'testing' stamp: ''!
hasChildren
	^ true! !

!DAReversePackageNode methodsFor: 'accessing' stamp: ''!
rPackage
	^ self content rPackageSet! !

!DAReversePackageNode methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #packageIcon! !

!DAReversePackageNode methodsFor: 'api' stamp: ''!
childNodeClassFor: anItem
	^ DAReverseDependentPackageNode ! !

!DASomeClass commentStamp: ''!
A simple class to test dependency analyzer!
!DASomeClass methodsFor: 'tests - test data' stamp: ''!
method4: x
	"a message send not in Kernel package used in a block"
	[ x copyFrom: 1 to: 2 ] value! !

!DASomeClass methodsFor: 'tests - test data' stamp: ''!
method1
	self unimplementedMethod! !

!DASomeClass methodsFor: 'tests - test data' stamp: ''!
method3
	"We refer a class indirectly in a block"
	^ [ EncoderForSistaV1 new ] value! !

!DASomeClass methodsFor: 'tests - test data' stamp: ''!
method2
	"a message send not in Kernel package"
	(1 to: 3) 
		collect: [ :i | i * 2 ] 
		as: (self class environment at: #Array) "avoid a direct reference to Array"! !

!DATarjanAlgorithm commentStamp: ''!
A class to do Tarjan Algorithm on a PDPackageRelation, in order to detect strongly connected components.
Give a package dependency graph (PDPackageRelationGraph)  in entry of the message run to run the Tarjan algorithm and retrieve all the strongly connected components graph.!
!DATarjanAlgorithm methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	stronglyConnectedComponents := OrderedCollection new.
	stack := Stack new.
	runningIndex := 0
! !

!DATarjanAlgorithm methodsFor: 'private' stamp: ''!
startNewSCC
	^ DAPackageRelationGraph new! !

!DATarjanAlgorithm methodsFor: 'accessing' stamp: ''!
stronglyConnectedComponents
	^ stronglyConnectedComponents! !

!DATarjanAlgorithm methodsFor: 'private' stamp: ''!
popStackAndUpdateCurrentSCC: aRelation until: aPDPackage
	| currentNode |	
	[ currentNode := stack pop.
	currentNode
		inStack: false;
		beIncluded.
	aRelation addPackage: currentNode ] doWhileFalse: [ currentNode = aPDPackage ].
	stronglyConnectedComponents add: aRelation! !

!DATarjanAlgorithm methodsFor: 'adding' stamp: ''!
push: aPDPackage
	stack push: aPDPackage.
	aPDPackage inStack: true. "use a flag to avoid stack access"! !

!DATarjanAlgorithm methodsFor: 'private' stamp: ''!
isRootNode: aPDPackage
	^ aPDPackage tarjanLowLink = aPDPackage tarjanIndex! !

!DATarjanAlgorithm methodsFor: 'private' stamp: ''!
traverse: aPDPackage
	| aRelation |
	aPDPackage tarjanIndex: runningIndex.
	aPDPackage tarjanLowLink: runningIndex.
	runningIndex := runningIndex + 1.
	self push: aPDPackage.
	self traverseChildrenOf: aPDPackage.
	(self isRootNode: aPDPackage)
		ifTrue: [ 
			aRelation := self startNewSCC.
			self popStackAndUpdateCurrentSCC: aRelation until: aPDPackage ]! !

!DATarjanAlgorithm methodsFor: 'private' stamp: ''!
traverseChildrenOf: aPDPackage
	aPDPackage dependencies
		do: [ :dependency | 
			dependency target isTarjanUndefined
				ifTrue: [ 
					self traverse: dependency target.
					aPDPackage tarjanLowLink: (aPDPackage tarjanLowLink min: dependency target tarjanLowLink) ]
				ifFalse: [ 
					dependency target isInStack
						ifTrue: [ aPDPackage tarjanLowLink: (aPDPackage tarjanLowLink min: dependency target tarjanIndex) ] ] ]! !

!DATarjanAlgorithm methodsFor: 'running' stamp: ''!
run: aPDPackageRelation
	aPDPackageRelation packages
		do: [ :package | 
			package isTarjanUndefined
				ifTrue: [ self traverse: package ] ]
		displayingProgress: 'Finding SCCs'! !

!DATarjanAlgorithmTest methodsFor: 'utilities' stamp: ''!
stackSize
	^ (tarjanPackage instVarNamed: 'stack') size! !

!DATarjanAlgorithmTest methodsFor: 'tests' stamp: ''!
testNoOutgoingDependenciesAfterTarjan
	"test if we have 0 outgoing dependencies in each SCC after the algorithm"

	| aRelation aCollection |
	aCollection := OrderedCollection
		withAll:
			(RPackageOrganizer default packages
				select: [ :package | '*Collections*' match: package packageName asString ]
				thenCollect: [ :package | package packageName ]).
	aRelation := DAPackageRelationGraph
		onPackages: (aCollection collect: [ :each | DAPackage on: (RPackageSet named: each) ]).
	aRelation
		computeStaticDependencies;
		removeInternalDependencies;
		removeOutgoingDependencies;
		combineDependencies.
	tarjanPackage run: aRelation.
	self assert: (tarjanPackage stronglyConnectedComponents anySatisfy: [ :scc | scc outgoing isEmpty ])! !

!DATarjanAlgorithmTest methodsFor: 'tests' stamp: ''!
testRunTarjan
	"test the Tarjan algorithm on a simple graph with 8 nodes"
	| aPDPackageRelation  |
	packageA add: (DAPackageDependency from: packageA to: packageB).
	packageB add: (DAPackageDependency from: packageB to: packageC).
	packageC add: (DAPackageDependency from: packageC to: packageD).
	packageD add: (DAPackageDependency from: packageD to: packageE).
	packageE add: (DAPackageDependency from: packageE to: packageA).
	packageC add: (DAPackageDependency from: packageC to: packageF).
	packageF add: (DAPackageDependency from: packageF to: packageG).
	packageG add: (DAPackageDependency from: packageG to: packageH).
	packageH add: (DAPackageDependency from: packageH to: packageG).
	aPDPackageRelation := DAPackageRelationGraph onPackages: anArray.
	tarjanPackage run: aPDPackageRelation.
	"we must find 3 sccs, five two and one nodes"
	self assert: tarjanPackage stronglyConnectedComponents size equals: 3.
	self assert: (tarjanPackage stronglyConnectedComponents anySatisfy: [ :each | each packages size = 5 ]).
	self assert: (tarjanPackage stronglyConnectedComponents anySatisfy: [ :each | each packages size = 2 ]).
	self assert: (tarjanPackage stronglyConnectedComponents anySatisfy: [ :each | each packages size = 1 ]).
	
	
	
	

	
	! !

!DATarjanAlgorithmTest methodsFor: 'tests' stamp: ''!
testPush
	self assert: self stackSize equals: 0.
	self deny: packageA isInStack.
	tarjanPackage push: packageA.
	self assert: self stackSize equals: 1.
	self assert: packageA isInStack! !

!DATarjanAlgorithmTest methodsFor: 'tests' stamp: ''!
testRunTarjanWikipedia
	"test the Tarjan algorithm on the Wikipedia graph (page Tarjan's strongly connected components algorithm"
	| aPDPackageRelation |
	packageA add: (DAPackageDependency from: packageA to: packageB).
	packageB add: (DAPackageDependency from: packageB to: packageC).
	packageC add: (DAPackageDependency from: packageC to: packageA).
	packageD add: (DAPackageDependency from: packageD to: packageB).
	packageD add: (DAPackageDependency from: packageD to: packageC).
	packageD add: (DAPackageDependency from: packageD to: packageF).
	packageE add: (DAPackageDependency from: packageE to: packageC).
	packageE add: (DAPackageDependency from: packageE to: packageG).
	packageF add: (DAPackageDependency from: packageF to: packageD).
	packageF add: (DAPackageDependency from: packageF to: packageE).
	packageG add: (DAPackageDependency from: packageG to: packageE).
	"packageG add: (PDPackageDependency from: packageG to: packageF)."
	packageH add: (DAPackageDependency from: packageH to: packageH).
	packageH add: (DAPackageDependency from: packageH to: packageF).
	packageH add: (DAPackageDependency from: packageH to: packageG).
	
	aPDPackageRelation := DAPackageRelationGraph onPackages: anArray.
	tarjanPackage run: aPDPackageRelation.
	"we must find 4 sccs"
	self assert: tarjanPackage stronglyConnectedComponents size equals: 4.
	self assert: (tarjanPackage stronglyConnectedComponents anySatisfy: [ :each | each packages size = 3 ]).
	self assert: (tarjanPackage stronglyConnectedComponents anySatisfy: [ :each | each packages size = 2 ]).
	self assert: (tarjanPackage stronglyConnectedComponents anySatisfy: [ :each | each packages size = 1 ]).! !

!DATarjanAlgorithmTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	tarjanPackage := DATarjanAlgorithm new.
	anArray := Array new: 8.
	packageA := DAPackage on: (RPackageSet named: 'A').
	packageB := DAPackage on: (RPackageSet named: 'B').
	packageC := DAPackage on: (RPackageSet named: 'C').
	packageD := DAPackage on: (RPackageSet named: 'D').
	packageE := DAPackage on: (RPackageSet named: 'E').
	packageF := DAPackage on: (RPackageSet named: 'F').
	packageG := DAPackage on: (RPackageSet named: 'G').
	packageH := DAPackage on: (RPackageSet named: 'H').
	anArray at: 1 put: packageA.
	anArray at: 2 put: packageB.
	anArray at: 3 put: packageC.
	anArray at: 4 put: packageD.
	anArray at: 5 put: packageE.
	anArray at: 6 put: packageF.
	anArray at: 7 put: packageG.
	anArray at: 8 put:packageH.! !

!DATraitDependency commentStamp: ''!
A PDTraitDependency is a trait dependency between two packages. 


Instance Variable
	trait:		the trait!
!DATraitDependency methodsFor: 'testing' stamp: ''!
isTraitDependency
	^ true! !

!DATraitDependency methodsFor: '*Tool-DependencyAnalyser-UI' stamp: ''!
nodeClass
	^ DATraitDependencyNode! !

!DATraitDependency methodsFor: 'accessing' stamp: ''!
trait
	^ trait! !

!DATraitDependency methodsFor: 'printing' stamp: ''!
printReasonOn: aStream
	aStream
		nextPutAll: self theClass name;
		nextPutAll: ' uses ';
		print: self trait name! !

!DATraitDependency methodsFor: 'accessing' stamp: ''!
trait: aTrait
	trait := aTrait! !

!DATraitDependencyNode commentStamp: ''!
A node used to display a trait dependency in a tree.!
!DATraitDependencyNode methodsFor: 'browse-nautilus' stamp: ''!
spawnNewBrowser
	self browseClass: self content trait! !

!DATraitDependencyNode methodsFor: 'accessing' stamp: ''!
icon
	^  Smalltalk ui icons iconNamed: #traitIcon! !

!DTAbstractTreeNode commentStamp: ''!
I am the abstract superclass for all classes that are nodes or leafs used to show results.!
!DTAbstractTreeNode methodsFor: 'accessing' stamp: ''!
subResults
	^ #()! !

!DTAbstractTreeNode methodsFor: 'testing' stamp: ''!
isLeaf
	^ false! !

!DTAbstractTreeNode methodsFor: 'accessing' stamp: ''!
drTestsName
	"Returns the name to display for this object in DrTestsUI."
	^ self subclassResponsibility! !

!DTAbstractTreeNode methodsFor: 'testing' stamp: ''!
canBeBrowsed
	^ self subclassResponsibility! !

!DTAbstractTreeNode methodsFor: 'menu' stamp: ''!
drTestsBuildContextMenu: menu
	"Builds the contextual menu to display in DrTests results tree when a node of the tree is right-clicked.
	 Does nothing by default."! !

!DTAbstractTreeNode methodsFor: 'actions' stamp: ''!
drTestsBrowse
	"Actions to perform in order to browse the result.
	 Does nothing by default."! !

!DTBrowseSelectedItemCommand commentStamp: ''!
I browse the item selected in middle list of DrTests.!
!DTBrowseSelectedItemCommand methodsFor: 'executing' stamp: ''!
execute

	self context browseSelectedItem! !

!DTBrowseSelectedItemCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self selectedItems size = 1! !

!DTBrowseSelectedItemCommand class methodsFor: 'defaults' stamp: ''!
defaultName 
	"Return the default name of the command"
	
	^ 'Browse'! !

!DTCommand commentStamp: ''!
I am an abstract command concerning DrTests.!
!DTCommand methodsFor: 'accessing' stamp: ''!
plugin
	^ self context plugin! !

!DTCommand class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self name = #DTCommand! !

!DTCommentTestConfiguration commentStamp: ''!
I know the items to create a testSuite that will be analysed by a DrTestsPlugin.!
!DTCommentTestConfiguration methodsFor: 'converting' stamp: ''!
asTestSuite

	| suite classes methods |
	suite := TestSuite named: 'Test Generated From Comments'.
	classes := self items addAll: (self items collect: [ :each | each class ]).
	methods := classes flatCollect: [ :each | each methods ].
	methods do: [ :method | 
		method pharoDocCommentNodes do: [ :docComment | 
			suite addTest: (CommentTestCase for: docComment) ] ].
	^ suite! !

!DTCommentToTestPlugin commentStamp: ''!
I am a DrTestPlugin.
I create tests from executable comments and run these tests.!
!DTCommentToTestPlugin methodsFor: 'api' stamp: ''!
startButtonHelp
	^ 'Run selected tests.'! !

!DTCommentToTestPlugin methodsFor: 'api' stamp: ''!
runTestSuites: testSuites
	| result |
	result := TestAsserter classForTestResult new.
	CurrentExecutionEnvironment
		runTestsBy: [ testSuites
				do: [ :testSuite | self runSuite: testSuite withResult: result ]
				displayingProgress: 'Running Tests' ].
	^ result! !

!DTCommentToTestPlugin methodsFor: 'api' stamp: ''!
packagesAvailableForAnalysis
	^ RPackage organizer packages
		select: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase not ] ]! !

!DTCommentToTestPlugin methodsFor: 'api' stamp: ''!
itemsToBeAnalysedFor: packagesSelected

	^ packagesSelected flatCollect: [ :package | 
		  package definedClasses select: [ :class | class hasDocComment ] ]! !

!DTCommentToTestPlugin methodsFor: 'configuration building' stamp: ''!
buildConfigurationFrom: aDrTests
	^ DTCommentTestConfiguration items: aDrTests selectedItems packages: aDrTests packagesSelected! !

!DTCommentToTestPlugin methodsFor: 'api' stamp: ''!
runForConfiguration: aDTpluginConfiguration
	^ self pluginResultClass new
			testResults: (self runTestSuites: {aDTpluginConfiguration asTestSuite});
			yourself! !

!DTCommentToTestPlugin methodsFor: 'api' stamp: ''!
secondListLabel
	^ 'Classes'! !

!DTCommentToTestPlugin methodsFor: 'api' stamp: ''!
firstListLabel
	^ 'Packages'! !

!DTCommentToTestPlugin methodsFor: 'api' stamp: ''!
startButtonLabel
	^ 'Run Tests' translated! !

!DTCommentToTestPlugin methodsFor: 'accessing' stamp: ''!
pragmaForResultTrees
	^ #'dtCommentToTestResultTreeNamed:order:'! !

!DTCommentToTestPlugin methodsFor: 'api' stamp: ''!
resultButtonHelp
	^ 'Browse the test selected in the result list.'! !

!DTCommentToTestPlugin methodsFor: 'api' stamp: ''!
runSuite: aTestSuite withResult: aResult
	aTestSuite
		when: TestAnnouncement
		do: [ :testAnnouncement | 
			self announceStatusChanged: ('Running test {1}.' format: {testAnnouncement test asString}) ].
	[ aTestSuite run: aResult ]
		ensure: [ aTestSuite unsubscribe: TestAnnouncement ]! !

!DTCommentToTestPlugin class methodsFor: 'api - accessing' stamp: ''!
weight
	"The lighter is a plugin, the higher it is displayed in the drop list for plugin selection."
	^ 10! !

!DTCommentToTestPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginResultClass
	^ DTCommentToTestResult! !

!DTCommentToTestPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginName
	"The name of the plugin to be displayed in DrTests UI."
	^ 'Executable comments checker'! !

!DTCommentToTestResult commentStamp: ''!
I build a tree with the testsResult created by comments listed in groups: 
- Errors
- Failures
- Passed test
I am used in DrTestsUI to show the results in a orderly manner.!
!DTCommentToTestResult methodsFor: 'accessing' stamp: ''!
testResults
	^ testsResult! !

!DTCommentToTestResult methodsFor: 'accessing' stamp: ''!
buildTreeForUI
	<dtCommentToTestResultTreeNamed: 'Grouped by type of result' order: 1>
	^ DTTreeNode new
		subResults:
			{(DTTreeNode new
				name: 'Errors';
				subResults: (self testResults errors collect: [:each | each asResultForDrTest ]);
				yourself).
			(DTTreeNode new
				name: 'Failures';
				subResults:
					(self testResults failures collect:  [:each | each asResultForDrTest] )
						asOrderedCollection;
				yourself).
			(DTTreeNode new
				name: 'Passed tests';
				subResults: (self testResults passed collect:  [:each | each asResultForDrTest] );
				yourself)};
		yourself! !

!DTCommentToTestResult methodsFor: 'accessing' stamp: ''!
testResults: anObject
	testsResult := anObject! !

!DTCoverageMockTest methodsFor: 'running' stamp: ''!
testMethod2forMock

	self
		assert: 5
		equals: 5! !

!DTCoverageMockTest methodsFor: 'running' stamp: ''!
testMethod1forMock

	self assert: mockObj method1ForMock equals: 2! !

!DTCoverageMockTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	mockObj := MockForCoverage new.! !

!DTDebugTestCommand commentStamp: ''!
I am the command allowing one to debug a failing test.!
!DTDebugTestCommand methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		name: 'Debug';
		description:
			'Re-run the test selected and opens a debugger when an assertion fails.'! !

!DTDebugTestCommand methodsFor: 'hooks' stamp: ''!
execute
	self resultSelected content debug! !

!DTDebugTestCommand methodsFor: 'hooks' stamp: ''!
canBeRun
	^ super canBeRun and: [ self resultSelected type isPass not ]! !

!DTDefaultPluginPresenter methodsFor: 'private - initialization' stamp: ''!
initializeResultsTreeAndLabel

	resultLabel := self newLabel label: 'Results:'.
	resultsList := self newTreeTable.
	resultsList
		addColumn: (SpStringTableColumn evaluated: #drTestsName);
		children: [ :node | node subResults ];
		contextMenu: [ (self rootCommandsGroup / 'Results tools') beRoot asMenuPresenter ].

	self resultTree: DTTreeNode empty.! !

!DTDefaultPluginPresenter methodsFor: 'actions' stamp: ''!
browseSelectedItem
	"Because of DTBrowseSelectedItem>>#canBeExecuted, we know there is a single item in the selection.
	 Thus, we take the first one and browse it.
	"
	
	self selectedItems first drTestsBrowse! !

!DTDefaultPluginPresenter methodsFor: 'accessing' stamp: ''!
resultSelected

	^ self resultsList selectedItem! !

!DTDefaultPluginPresenter methodsFor: 'private' stamp: ''!
packagesSelected

	^ self packagesList ifNil: [ #(  ) ] ifNotNil: #selectedItems! !

!DTDefaultPluginPresenter methodsFor: 'initialization' stamp: ''!
updatePresenter

	super updatePresenter.

	self updatePackagesList.
	self updateResultViewsDropList.
	
	startButton label: plugin startButtonLabel.
	startButton help: plugin startButtonHelp.! !

!DTDefaultPluginPresenter methodsFor: 'private' stamp: ''!
whenItemsSelectionChanged: itemsSelected
	
	self updateItemsListLabel.
	drTests updateSwitchButton: itemsSelected! !

!DTDefaultPluginPresenter methodsFor: 'api' stamp: ''!
selectAllInPackageList

	packagesList selectAll! !

!DTDefaultPluginPresenter methodsFor: 'accessing' stamp: ''!
subwidgetsToLock
	
	^ { packagesList. itemsList. resultsList. startButton}! !

!DTDefaultPluginPresenter methodsFor: 'accessing' stamp: ''!
itemsList
	^ itemsList! !

!DTDefaultPluginPresenter methodsFor: 'private - updating' stamp: ''!
updatePackagesListLabel
	self packagesList
		label:
			(self
				buildLabelString: plugin firstListLabel
				numberOfItemsSelected: self packagesSelected size)! !

!DTDefaultPluginPresenter methodsFor: 'accessing' stamp: ''!
setModelBeforeInitialization: aPair

	plugin := aPair first.
	drTests := aPair second! !

!DTDefaultPluginPresenter methodsFor: 'updating' stamp: ''!
updateResultViewsDropList
	| newPragmas |
	newPragmas := plugin resultTreeViews.
	
	(resultViewsDropList listItems = newPragmas
		and: [ newPragmas isNotEmpty ])
		ifTrue: [ 
			"Trigger action attached to selection change."
			resultViewsDropList selectedIndex: resultViewsDropList selectedIndex.
			^ self ].
	
	self resultViewsDropList selectedItem
		ifNotNil: [ self resultViewsDropList resetSelection ].
	self resultViewsDropList items: newPragmas.
	newPragmas isNotEmpty
		ifTrue: [ self resultViewsDropList selectIndex: 1 ]! !

!DTDefaultPluginPresenter methodsFor: 'widgets' stamp: ''!
newFilterableListPresenter

	^ self instantiate: DTFilterableListPresenter! !

!DTDefaultPluginPresenter methodsFor: 'accessing' stamp: ''!
packagesList
	^ packagesList! !

!DTDefaultPluginPresenter methodsFor: 'private' stamp: ''!
whenPackagesSelectionChanged: packagesSelected

	itemsList
		items: (plugin itemsToBeAnalysedFor: packagesSelected);
		selectAll.
	self updatePackagesListLabel! !

!DTDefaultPluginPresenter methodsFor: 'accessing' stamp: ''!
startButton
	^ startButton! !

!DTDefaultPluginPresenter methodsFor: 'accessing' stamp: ''!
plugin
	^ plugin! !

!DTDefaultPluginPresenter methodsFor: 'private - initialization' stamp: ''!
initializeItemsListAndLabel

	itemsList := self newFilterableListPresenter.
	itemsList
		help: 'Select the classes to analyze. Cmd+A or Ctrl+A to select all classes.';
		sortingBlock: #name ascending;
		displayBlock: [ :item | item name ];
		whenSelectionChangedDo: [ self whenItemsSelectionChanged: self selectedItems ];
		beMultipleSelection;
		contextMenu: [ (self rootCommandsGroup / 'List items menu') beRoot asMenuPresenter ].
	packagesList
		whenSelectionChangedDo: [ self whenPackagesSelectionChanged: self packagesSelected ]! !

!DTDefaultPluginPresenter methodsFor: 'updating' stamp: ''!
updateWithResults: someResults
	lastResults := someResults.

	self resultTree: lastResults buildTreeForUI.
	self updateResultViewsDropList.
	self updateResultLabel.
	resultsList
		contextMenu: [ (self rootCommandsGroup / 'Results tools') beRoot asMenuPresenter ]! !

!DTDefaultPluginPresenter methodsFor: 'private - initialization' stamp: ''!
initializePackagesListAndLabel

	packagesList := self newFilterableListPresenter.
	packagesList
		help: 'Select the packages to analyze. Cmd+A or Ctrl+A to select all packages.';
		sortingBlock: #name ascending;
		displayBlock: [ :package | package name ];
		beMultipleSelection;
		contextMenu: [ (self rootCommandsGroup / 'Package menu') beRoot asMenuPresenter ]! !

!DTDefaultPluginPresenter methodsFor: 'actions' stamp: ''!
browseSelectedResult

	self resultSelected drTestsBrowse! !

!DTDefaultPluginPresenter methodsFor: 'private - initialization' stamp: ''!
initializeResultViewsDropList

	resultViewsDropList := self newDropList.
	self resultViewsDropList
		help: 'Select the different views for results';
		display: [ :resultTreeView | resultTreeView name ]! !

!DTDefaultPluginPresenter methodsFor: 'accessing' stamp: ''!
resultsList
	^ resultsList! !

!DTDefaultPluginPresenter methodsFor: 'api' stamp: ''!
resultTree: aResultGroup

	aResultGroup
		ifNotNil: [ resultsList roots: aResultGroup subResults ]! !

!DTDefaultPluginPresenter methodsFor: 'accessing' stamp: ''!
resultViewsDropList
	^ resultViewsDropList! !

!DTDefaultPluginPresenter methodsFor: 'accessing' stamp: ''!
selectedItems

	^ itemsList selectedItems! !

!DTDefaultPluginPresenter methodsFor: 'updating' stamp: ''!
updateResultLabel
	resultLabel
		label: 'Results: ■';
		color: lastResults backgroundColor! !

!DTDefaultPluginPresenter methodsFor: 'api' stamp: ''!
selectNoneInPackageList

	packagesList unselectAll! !

!DTDefaultPluginPresenter methodsFor: 'private - updating' stamp: ''!
updatePackagesList
	packagesList unselectAll.
	itemsList beEmpty.
	packagesList items: plugin packagesAvailableForAnalysis.
	packagesList label: plugin firstListLabel.
	itemsList label: plugin secondListLabel.
	plugin setSelectionModeOfPackageList: packagesList.
	plugin setSelectionModeOfItemsList: itemsList! !

!DTDefaultPluginPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
		
	self
		initializePackagesListAndLabel;
		initializeItemsListAndLabel;
		initializeResultsTreeAndLabel;
		initializeResultViewsDropList.
		
	startButton := self newButton.
	startButton action: [ drTests runPlugin ]! !

!DTDefaultPluginPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters

	super connectPresenters.
	
	self resultViewsDropList
		whenSelectedItemChangedDo: [ :resultTreeViewOrNil | 
			resultTreeViewOrNil
				ifNotNil: [ resultsList
						roots: (resultTreeViewOrNil resultTreeFor: drTests pluginResult) subResults ] ].! !

!DTDefaultPluginPresenter methodsFor: 'private - updating' stamp: ''!
updateItemsListLabel

	itemsList label: (self
			 buildLabelString: plugin secondListLabel
			 numberOfItemsSelected: self selectedItems size)! !

!DTDefaultPluginPresenter methodsFor: 'utilities' stamp: ''!
buildLabelString: nameOfItems numberOfItemsSelected: aInt
	^ String
		streamContents: [ :s | 
			s
				<< nameOfItems;
				nextPut: $(;
				<< aInt asString;
				<< ' selected):' ]! !

!DTDefaultPluginPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom 
		add: (SpPanedLayout newHorizontal
		  add: (SpPanedLayout newHorizontal
				   add: (SpBoxLayout newVertical
						    add: #packagesList;
						    yourself);
				   add: (SpBoxLayout newVertical
						    add: #itemsList;
						    yourself);
				   yourself);
		  add: (SpBoxLayout newVertical
				   add: #resultViewsDropList
				   withConstraints: [ :constraints | constraints expand: false ];
				   add: #resultLabel
				   withConstraints: [ :constraints | 
					   constraints height: self labelHeight ];
				   add: #resultsList;
				   yourself);
		  yourself);
		add: #startButton
			withConstraints: [ :constraints | constraints width: self buttonWidth ]! !

!DTDefaultPluginPresenter class methodsFor: 'commands' stamp: ''!
buildCommandsGroupWith: presenterInstance forRoot: rootCommandGroup

	rootCommandGroup
		register: (self buildContextualPackageGroupWith: presenterInstance);
		register: (self buildItemsListGroupWith: presenterInstance);
		register: (self buildResultGroupWith: presenterInstance)! !

!DTDefaultPluginPresenter class methodsFor: 'private - commands' stamp: ''!
buildContextualPackageGroupWith: presenterInstance

	^ (CmCommandGroup named: 'Package menu') asSpecGroup
		register: (self buildPackageGroupWith: presenterInstance);
		yourself! !

!DTDefaultPluginPresenter class methodsFor: 'private - commands' stamp: ''!
buildPackageGroupWith: presenterInstance

	|group|
	group := (CmCommandGroup named: 'Package tools') asSpecGroup.
	group description: 'Commands related to packages list.'.
	
	DTPackagesCommand allSubclasses do: [:each | 
		group register: (each forSpec context: presenterInstance) ].
	
	^group 
		beDisplayedAsGroup;
		yourself! !

!DTDefaultPluginPresenter class methodsFor: 'private - commands' stamp: ''!
buildResultGroupWith: presenterInstance

	| commandGroup pluginCommands |
	commandGroup := (CmCommandGroup named: 'Results tools') asSpecGroup
		description: 'Commands related to result.';
		register:
			(DTResultBrowseCommand forSpec context: presenterInstance)
				beHiddenWhenCantBeRun;
		yourself.
	pluginCommands := presenterInstance plugin
		buildContextualMenuGroupWith: presenterInstance.
	pluginCommands entries ifEmpty: [ ^ commandGroup ].
	^ commandGroup
		register: pluginCommands beDisplayedAsGroup;
		yourself! !

!DTDefaultPluginPresenter class methodsFor: 'private - commands' stamp: ''!
buildItemsListGroupWith: presenterInstance

	^ (CmCommandGroup named: 'List items menu') asSpecGroup
		register: (DTBrowseSelectedItemCommand forSpec context: presenterInstance);
		yourself! !

!DTErrorResultType commentStamp: ''!
I model the fact that a test generated an error.!
!DTErrorResultType methodsFor: 'accessing' stamp: ''!
name
	^ 'Error'! !

!DTErrorResultType methodsFor: 'testing' stamp: ''!
isError
	^ true! !

!DTErrorResultType class methodsFor: 'factory' stamp: ''!
backgroundColor
	^ TestResult defaultColorBackGroundForErrorTest! !

!DTFailResultType commentStamp: ''!
I model the fact that a test failed.!
!DTFailResultType methodsFor: 'testing' stamp: ''!
isFail
	^ true! !

!DTFailResultType methodsFor: 'accessing' stamp: ''!
name
	^ 'Failure'! !

!DTFailResultType class methodsFor: 'factory' stamp: ''!
backgroundColor
	^ TestResult defaultColorBackGroundForFailureTest! !

!DTFilterableListPresenter commentStamp: ''!
I am a list presenter that can be filtered.

I also have a label.!
!DTFilterableListPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets

	labelPresenter := self newLabel.
	listPresenter := self newList.
	filterTextInput := self newTextInput
								placeholder: 'Filter...';
								whenTextChangedDo: [ self filterList ];
								autoAccept: true;
								yourself! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
visibleItems

	^ self listPresenter items! !

!DTFilterableListPresenter methodsFor: 'actions' stamp: ''!
selectAll

	^ self listPresenter selectAll! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
contextMenu: aBlock

	^ self listPresenter contextMenu: aBlock! !

!DTFilterableListPresenter methodsFor: 'private' stamp: ''!
filterList
	"Filters the list according to the filterTextInput."

	self unselectAll.
	self filterStrings
		ifEmpty: [ 
			self listPresenter
				items: initialItems.
			^ self ].
	self listPresenter
		items:
			(initialItems
				select: [ :each | 
					self filterStrings
						anySatisfy: [ :any | any match: (self listPresenter display value: each) ] ])! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
label

	^ labelPresenter label! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
beEmpty

	self items: #()! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
help

	^ labelPresenter help! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
allItems

	^ initialItems! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
beMultipleSelection

	^ self listPresenter beMultipleSelection! !

!DTFilterableListPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	initialItems := #().! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
label: aString

	labelPresenter label: aString! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
listPresenter

	^ listPresenter! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
selectItems: aBlock

	^ self listPresenter selectItems: aBlock! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
sortingBlock: aBlock

	^ self listPresenter sortingBlock: aBlock! !

!DTFilterableListPresenter methodsFor: 'events' stamp: ''!
whenSelectionChangedDo: aBlock

	^ self listPresenter whenSelectionChangedDo: aBlock! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
help: aString

	labelPresenter help: aString! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
labelPresenter

	^ labelPresenter! !

!DTFilterableListPresenter methodsFor: 'actions' stamp: ''!
unselectAll

	^ self listPresenter unselectAll! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
items: items

	initialItems := items.
	self listPresenter items: items! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
selectedItems

	^ self listPresenter selectedItems! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
filterStrings

	^ (self filterTextInput text splitOn: $|)
		reject: #isEmpty
		thenCollect: [ :pattern | pattern , '*' ]! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
items

	^ self visibleItems! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
beSingleSelection

	^ self listPresenter beSingleSelection! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
filterTextInput

	^ filterTextInput! !

!DTFilterableListPresenter methodsFor: 'accessing' stamp: ''!
displayBlock: aBlock

	^ self listPresenter display: aBlock! !

!DTFilterableListPresenter methodsFor: 'actions' stamp: ''!
resetFilter

	self filterTextInput text: ''.
	self listPresenter items: initialItems.! !

!DTFilterableListPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: #labelPresenter withConstraints: [ :constraints | constraints height: self labelHeight ];
		add: #listPresenter;
		add: #filterTextInput withConstraints: [ :constraints | constraints height: self inputTextHeight ];
		yourself! !

!DTFilterableListPresenterTest commentStamp: ''!
A DTFilterableListPresenterTest is a test class for testing the behavior of DTFilterableListPresenter!
!DTFilterableListPresenterTest methodsFor: 'tests' stamp: ''!
testFilterStrings
	filterableList filterTextInput text: 'foo|bar'.
	
	self assertCollection: filterableList filterStrings hasSameElements: #('foo*' 'bar*').
	
	filterableList filterTextInput text: '|bar'.
	
	self assertCollection: filterableList filterStrings hasSameElements: #('bar*').
	
	filterableList filterTextInput text: 'foo|'.
	
	self assertCollection: filterableList filterStrings hasSameElements: #('foo*').! !

!DTFilterableListPresenterTest methodsFor: 'running' stamp: ''!
testLabel
	self assert: filterableList label equals: ''.
	
	filterableList label: 'title'.
	
	self assert: filterableList label equals: 'title'.! !

!DTFilterableListPresenterTest methodsFor: 'tests' stamp: ''!
testFilterWorks
	self assertCollection: filterableList allItems equals: (1 to: 20).
	self assertCollection: filterableList visibleItems equals: (1 to: 20).
	
	filterableList filterTextInput text: '2'.
	
	self assertCollection: filterableList allItems equals: (1 to: 20).
	self assertCollection: filterableList visibleItems equals: #(2 20).
	
	filterableList filterTextInput text: ''.
	
	self assertCollection: filterableList allItems equals: filterableList visibleItems. "We want to show everything if no filter is written."! !

!DTFilterableListPresenterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	filterableList := DTFilterableListPresenter new
							items: (1 to: 20);
							displayBlock: #asString;
							yourself.! !

!DTLeafResultCommand commentStamp: ''!
I am an abstract command concerning DrTests' results tree but I can only be executed if a leaf is selected by user.!
!DTLeafResultCommand methodsFor: 'hooks' stamp: ''!
canBeRun
	^ self resultSelected isLeaf! !

!DTLeafResultCommand class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self name = #DTLeafResultCommand! !

!DTLeavesCollector commentStamp: ''!
I am a visitor that collect the leaves of the DTTreeNode I visit.

If there are multiple levels of DTTreeNode, no problem, I traverse them until I find the leaves.!
!DTLeavesCollector methodsFor: 'accessing' stamp: ''!
leaves: anObject
	leaves := anObject! !

!DTLeavesCollector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	leaves := OrderedCollection new.! !

!DTLeavesCollector methodsFor: 'accessing' stamp: ''!
leaves
	^ leaves! !

!DTLeavesCollector methodsFor: 'visiting' stamp: ''!
visitDTTreeLeaf: aDTTreeLeaf
	self leaves add: aDTTreeLeaf! !

!DTLeavesCollector class methodsFor: 'instance creation' stamp: ''!
collectLeavesOf: aDTTreeNode
	^ self new
		visit: aDTTreeNode;
		leaves! !

!DTMiddleListCommand commentStamp: ''!
I am an abstract command concerning DrTests' middle list.!
!DTMiddleListCommand methodsFor: 'accessing' stamp: ''!
selectedItems

	^ self context selectedItems! !

!DTMiddleListCommand class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self name = #DTMiddleListCommand! !

!DTMockPlugin commentStamp: ''!
A Mock object used in test!
!DTMockPlugin methodsFor: 'accessing' stamp: ''!
hasBeenRun
	^ hasBeenRun! !

!DTMockPlugin methodsFor: 'api' stamp: ''!
initialize

	super initialize.
	hasBeenRun := false.! !

!DTMockPlugin methodsFor: 'api' stamp: ''!
packagesAvailableForAnalysis
	"This is a seleciton only for tests"

	^ {self class package}! !

!DTMockPlugin methodsFor: 'api' stamp: ''!
runForConfiguration: aDTpluginConfiguration
	hasBeenRun := true.
	^ DTMockPluginResult new! !

!DTMockPlugin methodsFor: 'api' stamp: ''!
startButtonLabel
	
	^ 'Mock start'! !

!DTMockPlugin methodsFor: 'accessing' stamp: ''!
pragmaForResultTrees
	^ #'pragmaForTest:order:'! !

!DTMockPlugin methodsFor: 'api' stamp: ''!
resultButtonHelp
	
	^ 'Result help?'! !

!DTMockPlugin methodsFor: 'api' stamp: ''!
startButtonHelp
	
	^ 'Help me!!'! !

!DTMockPlugin class methodsFor: 'api - accessing' stamp: ''!
weight
	^ 40! !

!DTMockPlugin class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = DTMockPlugin! !

!DTMockPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginResultClass
	^ DTMockPluginResult! !

!DTMockPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginName
	
	^ 'Mock plugin for test'! !

!DTMockPluginResult commentStamp: ''!
A Mock object used in test!
!DTMockPluginResult methodsFor: 'accessing' stamp: ''!
backgroundColor
  " Backgournd color, although untested is used by updateResultLabel, which is called after a test suite is runned "
  " It is untested, so we return a random color"
  ^ Color black! !

!DTMockPluginResult methodsFor: 'accessing' stamp: ''!
buildAnotherTreeForUI
	<pragmaForTest: 'for other tests' order: 2>
	^ DTTreeNode new
		subResults: {};
		yourself! !

!DTMockPluginResult methodsFor: 'accessing' stamp: ''!
buildTreeForUI
	<pragmaForTest: 'for tests' order: 1>
	^ DTTreeNode new
		subResults: {};
		yourself! !

!DTMockPluginTest commentStamp: ''!
A DTMockPluginTest is a test class for testing the behavior of DTMockPlugin!
!DTMockPluginTest methodsFor: 'tests' stamp: ''!
testResultTreeViews
	| plugin treeViews |
	plugin := DTMockPlugin new.
	
	treeViews := plugin resultTreeViews.
	
	self assert: treeViews size equals: 2.
	
	self assert: treeViews first name equals: 'for tests'.
	self assert: treeViews second name equals: 'for other tests'.! !

!DTNullPluginPresenter methodsFor: 'updating' stamp: ''!
updateUI! !

!DTNullPluginPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newHorizontal! !

!DTPackagesCommand commentStamp: ''!
I am an abstract command concerning DrTests' package list.!
!DTPackagesCommand class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self name = #DTPackagesCommand! !

!DTPackagesSelectAllCommand commentStamp: ''!
I select all packages in the package list of DrTests.!
!DTPackagesSelectAllCommand methodsFor: 'hooks' stamp: ''!
execute

	self context selectAllInPackageList! !

!DTPackagesSelectAllCommand class methodsFor: 'defaults' stamp: ''!
defaultName

	^ 'Select all'! !

!DTPackagesSelectNoneCommand commentStamp: ''!
I deselect all packages in the package list of DrTests.!
!DTPackagesSelectNoneCommand methodsFor: 'executing' stamp: ''!
execute

	self context selectNoneInPackageList! !

!DTPackagesSelectNoneCommand class methodsFor: 'defaults' stamp: ''!
defaultName

	^ 'Select none'! !

!DTPassResultType commentStamp: ''!
I model the fact that a test passed.!
!DTPassResultType methodsFor: 'testing' stamp: ''!
isPass
	^ true! !

!DTPassResultType methodsFor: 'accessing' stamp: ''!
name
	^ 'Passing test'! !

!DTPassResultType class methodsFor: 'factory' stamp: ''!
backgroundColor
	^ TestResult defaultColorBackGroundForPassingTest! !

!DTPluginConfiguration commentStamp: ''!
I hold the information that would be used by a DrTestPlugin.!
!DTPluginConfiguration methodsFor: 'accessing' stamp: ''!
testSuite
	^ testSuite! !

!DTPluginConfiguration methodsFor: 'accessing' stamp: ''!
packagesSelected: packages
	packagesSelected := packages! !

!DTPluginConfiguration methodsFor: 'converting' stamp: ''!
asTestSuite
	| suite |
	suite := TestSuite new.
	self items
		reject: #isAbstract
		thenDo: [ :s | suite addTest: s suite ].
	^ suite! !

!DTPluginConfiguration methodsFor: 'accessing' stamp: ''!
packagesSelected
	^ packagesSelected! !

!DTPluginConfiguration methodsFor: 'result handling' stamp: ''!
handleResults: aPluginResult for: aPlugin
	^ aPluginResult! !

!DTPluginConfiguration methodsFor: 'accessing' stamp: ''!
items: anObject
	items := anObject! !

!DTPluginConfiguration methodsFor: 'accessing' stamp: ''!
items
	^ items! !

!DTPluginConfiguration methodsFor: 'accessing' stamp: ''!
items: anObject packages: packages
	items := anObject.
	packagesSelected := packages! !

!DTPluginConfiguration methodsFor: 'accessing' stamp: ''!
testSuite: anObject
	testSuite := anObject! !

!DTPluginConfiguration class methodsFor: 'tests' stamp: ''!
items: aCollectionOfClasses
	^ self new
		items: aCollectionOfClasses;
		yourself! !

!DTPluginConfiguration class methodsFor: 'tests' stamp: ''!
items: aCollectionOfClasses packages: aCollectionOfPackages
	^ self new
		items: aCollectionOfClasses;
		packagesSelected: aCollectionOfPackages;
		yourself.! !

!DTPluginResult commentStamp: ''!
I am the abstract superclass for all classes that are results of a plugin in DrTests.!
!DTPluginResult methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ Color named: 'gray'! !

!DTPluginResult methodsFor: 'accessing' stamp: ''!
textColor
	^ TestResult defaultColorText! !

!DTPluginResult methodsFor: 'accessing' stamp: ''!
theme
	^ Smalltalk ui theme! !

!DTPluginResult methodsFor: 'accessing' stamp: ''!
buildTreeForUI
	^ self subclassResponsibility! !

!DTPluginResult methodsFor: 'accessing' stamp: ''!
summarizeInfo
	"Text showed in miniDrTests with info of the result "

	^ self asString! !

!DTReRunConfiguration commentStamp: ''!
I am a configuration that re-run a part of the result of a previously-run configuration.!
!DTReRunConfiguration methodsFor: 'accessing' stamp: ''!
previousResult: anObject
	previousResult := anObject! !

!DTReRunConfiguration methodsFor: 'converting' stamp: ''!
asTestSuite
	^ self configurationToRun asTestSuite! !

!DTReRunConfiguration methodsFor: 'accessing' stamp: ''!
configurationToRun
	^ configurationToRun! !

!DTReRunConfiguration methodsFor: 'accessing' stamp: ''!
originalConfiguration
	^ originalConfiguration! !

!DTReRunConfiguration methodsFor: '*DrTests-TestsRunner' stamp: ''!
handleResults: aPluginResult for: aPlugin
	^ aPlugin handleReRunResult: aPluginResult forConfiguration: self! !

!DTReRunConfiguration methodsFor: 'accessing' stamp: ''!
previousResult
	^ previousResult! !

!DTReRunConfiguration methodsFor: 'accessing' stamp: ''!
originalConfiguration: anObject
	originalConfiguration := anObject! !

!DTReRunConfiguration methodsFor: 'accessing' stamp: ''!
configurationToRun: anObject
	configurationToRun := anObject! !

!DTReRunConfiguration methodsFor: 'accessing' stamp: ''!
items
	^ { self testToReRun }! !

!DTRerunCommand commentStamp: ''!
I am the command allowing one to rerun a subparts of the results of a test-run.!
!DTRerunCommand methodsFor: 'hooks' stamp: ''!
initialize
	super initialize.
	self name: 'Re-run tests'! !

!DTRerunCommand methodsFor: 'hooks' stamp: ''!
execute
	self context runPluginFor: (self plugin buildReRunConfigurationFrom: self context)! !

!DTResultBrowseCommand commentStamp: ''!
I browse the result selected by user of DrTests.!
!DTResultBrowseCommand methodsFor: 'hooks' stamp: ''!
execute
	self context browseSelectedResult! !

!DTResultBrowseCommand methodsFor: 'testing' stamp: ''!
canBeExecuted
	^ self resultSelected canBeBrowsed! !

!DTResultBrowseCommand class methodsFor: 'defaults' stamp: ''!
defaultName

	^ 'Browse'! !

!DTResultCommand commentStamp: ''!
I am an abstract command concerning DrTests' results tree.!
!DTResultCommand methodsFor: 'hooks' stamp: ''!
resultSelected
	^ self context resultSelected! !

!DTResultCommand class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self name = #DTResultCommand! !

!DTResultTreeView commentStamp: ''!
I model a tree view that can be created on a DTPluginResult.!
!DTResultTreeView methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!DTResultTreeView methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!DTResultTreeView methodsFor: 'accessing' stamp: ''!
resultTreeFor: result
	result ifNil: [ 
		^ DTTreeNode empty ].
	^ self blockToExtractViewFromResult value: result! !

!DTResultTreeView methodsFor: 'accessing' stamp: ''!
blockToExtractViewFromResult
	^ blockToExtractViewFromResult! !

!DTResultTreeView methodsFor: 'accessing' stamp: ''!
blockToExtractViewFromResult: anObject
	blockToExtractViewFromResult := anObject! !

!DTResultTreeView class methodsFor: 'instance creation' stamp: ''!
name: aString blockToExtractViewFromResult: blockToExtractViewFromResult
	^ self new
		name: aString;
		blockToExtractViewFromResult: blockToExtractViewFromResult;
		yourself! !

!DTResultsTreeVisitor commentStamp: ''!
I am an abstract visitor for the results tree of DrTests.!
!DTResultsTreeVisitor methodsFor: 'visiting' stamp: ''!
visitDTTreeNode: aDTTreeNode
	^ aDTTreeNode subResults collect: [ :subResult | self visit: subResult ]! !

!DTResultsTreeVisitor methodsFor: 'visiting' stamp: ''!
visitDTTreeLeaf: aDTTreeLeaf
	^ self subclassResponsibility! !

!DTResultsTreeVisitor methodsFor: 'visiting' stamp: ''!
visit: anObject
	^ anObject acceptVisitor: self! !

!DTSkippedResultType commentStamp: ''!
I model the fact that a test was skipped.!
!DTSkippedResultType methodsFor: 'accessing' stamp: ''!
name
	^ 'Skipped test'! !

!DTSkippedResultType methodsFor: 'testing' stamp: ''!
isSkipped
	^ true! !

!DTSkippedResultType class methodsFor: 'factory' stamp: ''!
backgroundColor
	^ TestResult defaultColorBackGroundForPassingTest! !

!DTStatusUpdate commentStamp: ''!
I am an announcement to force the UI to refresh the status bar.
This is useful when the results are handled in a asynchronous way!
!DTStatusUpdate methodsFor: 'accessing' stamp: ''!
message: anObject
	message := anObject! !

!DTStatusUpdate methodsFor: 'accessing' stamp: ''!
message

	^ message! !

!DTStatusUpdate class methodsFor: 'instance creation' stamp: ''!
message: aString

	^ self new
		  message: aString;
		  yourself! !

!DTTestCaseProfilingData commentStamp: ''!
I stores the information for every test.
I have the duration that is the times it takes when a test is executed. 
I also have the testCase ande the testResult.!
!DTTestCaseProfilingData methodsFor: 'accessing' stamp: ''!
testCase
	^ testCase! !

!DTTestCaseProfilingData methodsFor: 'accessing' stamp: ''!
duration: anObject
	duration := anObject! !

!DTTestCaseProfilingData methodsFor: 'accessing' stamp: ''!
testCase: anObject
	testCase := anObject! !

!DTTestCaseProfilingData methodsFor: 'accessing' stamp: ''!
testResult: anObject
	testResult := anObject! !

!DTTestCaseProfilingData methodsFor: 'accessing' stamp: ''!
duration
	^ duration! !

!DTTestCaseProfilingData methodsFor: 'accessing' stamp: ''!
drTestsName
	^ self testCase asString , ' : ', self duration asString! !

!DTTestCaseProfilingData methodsFor: 'accessing' stamp: ''!
testResult
	^ testResult! !

!DTTestCaseProfilingData methodsFor: 'actions' stamp: ''!
drTestsBrowse
	Smalltalk tools browser openOnClass:testCase class selector:testCase selector! !

!DTTestCaseProfilingData class methodsFor: 'instance creation' stamp: ''!
testCase: testCase duration: aDuration testResult: aTestResult
	^ self new
		testCase: testCase;
		duration: aDuration;
		testResult: aTestResult;
		yourself! !

!DTTestCaseProfilingData class methodsFor: 'instance creation' stamp: ''!
testCase: testCase duration: aDuration
	^ self new
		testCase: testCase;
		duration: aDuration;
		yourself! !

!DTTestCoverageConfiguration commentStamp: ''!
I know the items to create a testSuite that will be analysed by a DrTestsPlugin.!
!DTTestCoverageConfiguration methodsFor: 'tests' stamp: ''!
testMethods
	^ (packagesSelected
		flatCollect:
			[ :p | p definedClasses select: [ :c | c allSuperclasses includes: TestCase ] ])
		flatCollect: 
		[ :c | c methods select:[:m| m isTestMethod ] ]! !

!DTTestCoveragePlugin commentStamp: ''!
I am a DrTestPlugin.
I show the percentage of covered methods with tests and show the list of the uncovered methods.!
!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
startButtonHelp
	^ 'Run test coverage in selected packages' translated! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
allowMiniDrTests
	^ true! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
suiteFor: classesSelected

	"Return the suite for all the selected test case classes"

	^ TestSuite new in: [ :suite | 
		  classesSelected do: [ :each | 
			  each isAbstract ifFalse: [ 
				  each isTestCase ifTrue: [ each addToSuiteFromSelectors: suite ] ] ].
		  suite name: 'Test' ]! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
runTestSuites: testSuites
	| result |
	result := TestAsserter classForTestResult new.
	CurrentExecutionEnvironment
		runTestsBy: [ testSuites
				do: [ :testSuite | self runSuite: testSuite withResult: result ]
				displayingProgress: 'Running Tests' ].! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
defineData: aDTpluginConfiguration

	methods := aDTpluginConfiguration items flatCollect: [ :p | 
		           p methods reject: [ :meth | 
			           meth isTestMethod or: [meth methodClass isTestCase] ] ].
	methods := methods reject: [ :meth | meth isSubclassResponsibility ].
	testClasses := aDTpluginConfiguration packagesSelected flatCollect: [ 
		               :p | p classes ].
	link := MetaLink new
		        selector: #tagExecuted;
		        metaObject: #node! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
itemsToBeAnalysedFor: packagesSelected
	^ RPackage organizer packages
		select: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase not ] ]! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
runForConfiguration: aDTpluginConfiguration
	| suite notExecuted result |
	result := self pluginResultClass new.
	self defineData: aDTpluginConfiguration.
	suite := self suiteFor: testClasses.
	[ methods do: [ :meth | meth ast link: link ].
	[ self runTestSuites: {suite} ]
		ensure: [ link uninstall ] ] valueUnpreemptively.
	notExecuted := methods reject: [ :each | each ast hasBeenExecuted ].
	notExecuted isEmpty
		ifTrue: [ result percent: 1s2 ]
		ifFalse: [ result
				percent: 1s2 - (notExecuted size / methods size asScaledDecimal: 2);
				methodList: notExecuted ].	"cleanup the annotations"
	methods
		do: [ :each | each ast removeProperty: #tagExecuted ifAbsent: [  ] ].
	^ result! !

!DTTestCoveragePlugin methodsFor: 'accessing' stamp: ''!
secondListLabel
	^ 'Package under coverage'! !

!DTTestCoveragePlugin methodsFor: 'accessing' stamp: ''!
firstListLabel
	^ 'Test Packages'! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
setSelectionModeOfItemsList: aListPresenter
	aListPresenter
		beSingleSelection;
		unselectAll! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
startButtonLabel
	^ 'Run Coverage' translated! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
allowMultipleSelectionInSecondList
	^ false! !

!DTTestCoveragePlugin methodsFor: 'accessing' stamp: ''!
pragmaForResultTrees
	^ #'dtTestCoverageResultTreeNamed:order:'! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
resultButtonHelp
	^ 'Browse the method selected in the results list.' translated! !

!DTTestCoveragePlugin methodsFor: 'api' stamp: ''!
runSuite: aTestSuite withResult: aResult

	aTestSuite when: TestAnnouncement do: [ :testAnnouncement | 
		self announceStatusChanged: ('Running test {1}.' format: { testAnnouncement test asString }) ].
	[ aTestSuite run: aResult ] ensure: [ 
		aTestSuite unsubscribe: TestAnnouncement ]! !

!DTTestCoveragePlugin class methodsFor: 'api - accessing' stamp: ''!
weight
	^ 3! !

!DTTestCoveragePlugin class methodsFor: 'api - accessing' stamp: ''!
pluginResultClass
	^ DTTestCoverageResult! !

!DTTestCoveragePlugin class methodsFor: 'api - accessing' stamp: ''!
pluginName
	^ 'Test Coverage'! !

!DTTestCoverageResult commentStamp: ''!
I build a tree with information: 
-percent of covered methods in the selected packages
-List of the uncovered methods
I am used in DrTestsUI to show the results in a orderly manner.!
!DTTestCoverageResult methodsFor: 'accessing' stamp: ''!
percent: anObject
	percent := anObject! !

!DTTestCoverageResult methodsFor: 'accessing' stamp: ''!
methodList
	^methodList! !

!DTTestCoverageResult methodsFor: 'accessing' stamp: ''!
methodList: aCollectionOfMethods
	methodList := aCollectionOfMethods! !

!DTTestCoverageResult methodsFor: 'accessing' stamp: ''!
buildTreeForUI
	<dtTestCoverageResultTreeNamed: 'List of uncovered methods' order: 1>
	^ DTTreeNode new
		subResults:
			{(DTTreeNode new
				name: (percent * 100 printShowingDecimalPlaces: 2) , ' % Code Coverage';
				subResults: {};
				yourself).
			(DTTreeNode new
				name: 'Uncovered methods';
				subResults: (self methodList collect: [:each | each asResultForDrTest]);
				yourself)}! !

!DTTestCoverageResult methodsFor: 'accessing' stamp: ''!
percent
	^ percent! !

!DTTestCoverageResult methodsFor: 'accessing' stamp: ''!
summarizeInfo
	"Text showed in miniDrTests with info of the result "

	^ String
		streamContents: [ :s | 
			s
				<< (percent*100 printShowingDecimalPlaces: 2);
				<< ' % Code Coverage';
				<< String cr;
				<< 'Uncovered methods:';
				<< String cr;
				<< self methodList size asString ]! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
testPackagesAvailableInTestCoveragePlugin
	| items |
	items := plugin packagesAvailableForAnalysis.
	self
		assert:
			(items
				allSatisfy: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase ] ])! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
testCoveragePercentForMock

	| result |
	result := plugin runForConfiguration: pluginConfiguration.
	self assert: result percent class equals: ScaledDecimal! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResultTheSecondNodeSubResultsAreLeafs

	| resultTree leafs |
	resultTree := (plugin runForConfiguration: pluginConfiguration) buildTreeForUI.
	leafs := resultTree subResults at: 2.
	self
		assert: (leafs subResults allSatisfy: #isLeaf )! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResultBuildTreeForUIContainsNodes

	| resultTree |
	resultTree := (plugin runForConfiguration: pluginConfiguration) buildTreeForUI.
	self
		assert:
			(resultTree subResults
				allSatisfy: [ :subResult | subResult class = DTTreeNode ])! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
testNotExecutedMethodList

	| result notExecutedMethodList |
	result := plugin runForConfiguration: pluginConfiguration.
	notExecutedMethodList := {(MockForCoverage >> #method2ForMock:)}.
	self
		assert:
			(notExecutedMethodList
				allSatisfy: [ :expectedNotExecutedMethod | 
					result methodList
						anySatisfy: [ :anyMethod | 
							anyMethod methodClass = expectedNotExecutedMethod methodClass
								and: [ anyMethod selector = expectedNotExecutedMethod selector ] ] ])! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
testCoverageResultIsAnInstanceOfDTTestCoverageResult

	| result |
	result := plugin runForConfiguration: pluginConfiguration.
	self assert: result class equals: DTTestCoverageResult! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
testItemsAvailableInTestCoveragePlugin
	| items |
	items := plugin itemsToBeAnalysedFor: package.
	self
		assert:
			(items
				allSatisfy: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase not ] ])! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResultAsResultForDrTests
	"the packages contains at least one test class"

	| items |
	items := plugin packagesAvailableForAnalysis.
	self
		assert:
			(items
				allSatisfy: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase ] ])! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResultHas2Nodes

	| resultTree |
	resultTree := (plugin runForConfiguration: pluginConfiguration) buildTreeForUI.
	self assert: resultTree subResults size equals: 2! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResultTheFirstNodeIsPercent

	| resultTree |
	resultTree := (plugin runForConfiguration: pluginConfiguration) buildTreeForUI.
	self
		assert:
			((resultTree subResults at: 1) name
				includesSubstring: '% Code Coverage')! !

!DTTestCoverageTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	package := RPackage organizer
		packageNamed: 'DrTests-TestCoverage-Tests-Mocks'.
	"The test classes are in the same package as classes under test."
	pluginConfiguration := DTPluginConfiguration items: {package} packages: {package}.
	plugin := DTTestCoveragePlugin new! !

!DTTestLeafNode commentStamp: ''!
I am a leaf of the results tree for the test-runner plugin.

Additionally to my superclass, I store the type of the result.!
!DTTestLeafNode methodsFor: 'accessing' stamp: ''!
type: anObject
	type := anObject! !

!DTTestLeafNode methodsFor: 'accessing' stamp: ''!
type
	^ type! !

!DTTestLeafNode class methodsFor: 'instance creation' stamp: ''!
content: anObject type: aTestResultType
	^ (self content: anObject)
		type: aTestResultType;
		yourself! !

!DTTestProfilingTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResultTheThirdNodeSubResultsLeafsContentsAreDTTestCaseProfilingData
	| resultTree leafs |
	resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI.
	leafs := resultTree subResults at: 3.
	self
		assert:
			(leafs subResults
				allSatisfy: [ :subResult | subResult content class = DTTestCaseProfilingData  ])! !

!DTTestProfilingTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResulLeafsContentHaveDuration
	| resultTree leafs |
	resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI.
	leafs := resultTree subResults at: 4.
	self
		assert:
			(leafs subResults
				allSatisfy: [ :subResult | subResult content duration class = Duration ])! !

!DTTestProfilingTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResultHas4Nodes
	| resultTree |
	resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI.
	self assert: resultTree subResults size equals: 4! !

!DTTestProfilingTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResultTheSecondNodeSubResultsAreLeafs
	| resultTree leafs |
	resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI.
	leafs := resultTree subResults at: 3.
	self
		assert:
			(leafs subResults
				allSatisfy: [ :subResult | subResult class = DTTreeLeafNode  ])! !

!DTTestProfilingTest methodsFor: 'running' stamp: ''!
testCoverageResultIsAnInstanceOfDTTestProfilingResult
	| result |
	result := plugin runForConfiguration: dTconf.
	self assert: result class equals: DTTestsProfilingResult! !

!DTTestProfilingTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResulLeafsContentHaveATestResult
	| resultTree leafs |
	resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI.
	leafs := resultTree subResults at: 4.
	self
		assert:
			(leafs subResults
				allSatisfy: [ :subResult | subResult content testResult isKindOf: TestResult ])! !

!DTTestProfilingTest methodsFor: 'running' stamp: ''!
testDTTestCoverageResulLeafsContentHaveATestCase
	| resultTree leafs |
	resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI.
	leafs := resultTree subResults at: 4.
	self
		assert:
			(leafs subResults
				allSatisfy: [ :subResult | subResult content testCase isKindOf: TestCase])! !

!DTTestProfilingTest methodsFor: 'running' stamp: ''!
testItemsAvailableInTestProfilerPlugin
	| items |
	items := plugin itemsToBeAnalysedFor: {package}.
	self
		assert:
			(items
				allSatisfy: [ :p | p methods anySatisfy: [ :m | m isTestMethod ] ])! !

!DTTestProfilingTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	plugin := DTTestsProfilingPlugin  new.
	package := RPackage organizer
		packageNamed: 'DrTests-TestCoverage-Tests-Mocks'.
	classes := plugin itemsToBeAnalysedFor: {package}.
	dTconf := DTPluginConfiguration items: classes packages: {package}! !

!DTTestResultType commentStamp: ''!
I model an abstract type of result for the run of a test case.!
!DTTestResultType methodsFor: 'testing' stamp: ''!
isFail
	^ false! !

!DTTestResultType methodsFor: 'testing' stamp: ''!
isPass
	^ false! !

!DTTestResultType methodsFor: 'accessing' stamp: ''!
pluralName
	^ self name , 's'! !

!DTTestResultType methodsFor: 'accessing' stamp: ''!
name
	^ self subclassResponsibility! !

!DTTestResultType methodsFor: 'testing' stamp: ''!
isError
	^ false! !

!DTTestResultType methodsFor: 'testing' stamp: ''!
isSkipped
	^ false! !

!DTTestResultType class methodsFor: 'factory' stamp: ''!
pass
	^ DTPassResultType new! !

!DTTestResultType class methodsFor: 'factory' stamp: ''!
backgroundColor
	^ self subclassResponsibility! !

!DTTestResultType class methodsFor: 'factory' stamp: ''!
error
	^ DTErrorResultType new! !

!DTTestResultType class methodsFor: 'factory' stamp: ''!
textColor
	^ TestResult defaultColorText! !

!DTTestResultType class methodsFor: 'factory' stamp: ''!
skipped
	^ DTSkippedResultType new! !

!DTTestResultType class methodsFor: 'factory' stamp: ''!
fail
	^ DTFailResultType new! !

!DTTestsProfilerVisitor commentStamp: ''!
I collect the time for every executed test.
I create a DTTestCaseProfilingData for each test and store all of them in a collection.!
!DTTestsProfilerVisitor methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self profilingData: OrderedCollection new! !

!DTTestsProfilerVisitor methodsFor: 'accessing' stamp: ''!
profilingData: anObject
	profilingData := anObject! !

!DTTestsProfilerVisitor methodsFor: 'visiting' stamp: ''!
visitTestCase: aTestCase
	"Defines the behaviour while visiting a TestCase.
	 This method must be overriden by concrete subclasses.
	"

	| aTestresult |
	self profilingData
		add:
			(DTTestCaseProfilingData
				testCase: aTestCase
				duration: [ aTestresult := aTestCase run ] timeToRun
				testResult: aTestresult)! !

!DTTestsProfilerVisitor methodsFor: 'accessing' stamp: ''!
profilingData
	^ profilingData! !

!DTTestsProfilingPlugin commentStamp: ''!
I am a DrTestPlugin.
I show the time that takes execute the test and the result of the tests.!
!DTTestsProfilingPlugin methodsFor: 'api' stamp: ''!
runForConfiguration: aDTpluginConfiguration
	| results profilerVisitor |
	profilerVisitor := DTTestsProfilerVisitor new.
	aDTpluginConfiguration asTestSuite
		acceptSUnitVisitor: profilerVisitor.
	results := self pluginResultClass new
		testResults: profilerVisitor profilingData;
		yourself.
	^ results! !

!DTTestsProfilingPlugin methodsFor: 'api' stamp: ''!
secondListLabel
	^ 'Tests Cases'! !

!DTTestsProfilingPlugin methodsFor: 'api' stamp: ''!
firstListLabel
	^ 'Packages'! !

!DTTestsProfilingPlugin methodsFor: 'api' stamp: ''!
startButtonLabel
	^ 'Profile Tests' translated! !

!DTTestsProfilingPlugin methodsFor: 'accessing' stamp: ''!
pragmaForResultTrees
	^ #'drTestsProfilingResultTreeNamed:order:'! !

!DTTestsProfilingPlugin methodsFor: 'api' stamp: ''!
resultButtonHelp
	^ 'Browse the test selected in the results list.' translated! !

!DTTestsProfilingPlugin methodsFor: 'api' stamp: ''!
startButtonHelp
	^ 'Run tests selected.' translated! !

!DTTestsProfilingPlugin class methodsFor: 'api - accessing' stamp: ''!
weight
 ^ 5! !

!DTTestsProfilingPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginResultClass
	^ DTTestsProfilingResult! !

!DTTestsProfilingPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginName
	^ 'Tests Profiler'! !

!DTTestsProfilingResult commentStamp: ''!
I build a tree with DTTestCaseProfilingData objects listed in groups: 
-Errors
-Failures
-Skipped tests
-Passed test
Each group has in adition the total execution time for each test.
I am used in DrTestsUI to show the results in a orderly manner.!
!DTTestsProfilingResult methodsFor: 'private' stamp: ''!
buildTreeNode
	"Returns a node with the sub-results aggregator initialized in a way that it sum the durations of sub results."

	^ DTTreeNode new
		subResultsAggregator: [ :subResults | 
			subResults
				inject: 0 milliSecond
				into: [ :totalDuration :dtTreeLeaf | totalDuration + dtTreeLeaf content duration ] ];
		yourself! !

!DTTestsProfilingResult methodsFor: 'accessing' stamp: ''!
testResults
	^ testsResult! !

!DTTestsProfilingResult methodsFor: 'accessing' stamp: ''!
buildTreeForUI
	<dtTestsProfilingResultTreeNamed: 'Grouped by type of result' order: 1>
	^ DTTreeNode new
		subResults:
			{(self buildTreeNode
				name: 'Errors';
				subResults:
					((self testResults
						select:
							[ :testCaseToTimeTaken | testCaseToTimeTaken testResult errors isNotEmpty ])
						collect: [ :testCaseToTimeTaken | 
							DTTreeLeafNode new
								content: testCaseToTimeTaken;
								yourself ]);
				yourself).
			(self buildTreeNode
				name: 'Failures';
				subResults:
					((self testResults
						select:
							[ :testCaseToTimeTaken | testCaseToTimeTaken testResult failures isNotEmpty ])
						collect: [ :testCaseToTimeTaken | 
							DTTreeLeafNode new
								content: testCaseToTimeTaken;
								yourself ]);
				yourself).
			(self buildTreeNode
				name: 'Skipped tests';
				subResults:
					((self testResults
						select:
							[ :testCaseToTimeTaken | testCaseToTimeTaken testResult skipped isNotEmpty ])
						collect: [ :testCaseToTimeTaken | 
							DTTreeLeafNode new
								content: testCaseToTimeTaken;
								yourself ]);
				yourself).
			(self buildTreeNode
				name: 'Passed tests';
				subResults:
					((self testResults
						select:
							[ :testProfilerResult | testProfilerResult testResult passed isNotEmpty ])
						collect: [ :testCaseToTimeTaken | 
							DTTreeLeafNode new
								content: testCaseToTimeTaken;
								yourself ]);
				yourself)};
		yourself! !

!DTTestsProfilingResult methodsFor: 'accessing' stamp: ''!
testResults: anObject
	testsResult := anObject! !

!DTTestsProfilingResult methodsFor: 'accessing' stamp: ''!
buildTreeGroupedByClass
	<dtTestsProfilingResultTreeNamed: 'Grouped by class' order: 2>
	^ self buildTreeNode
		subResults: ((self testResults groupedBy: [ :d | d testCase class ]) associations collect: [ :assoc |
			self buildTreeNode
					name: assoc key name;
					subResults: (assoc value collect: [ :t | DTTreeLeafNode content: t ]);
					yourself ]);
		yourself! !

!DTTestsRunnerConfiguration commentStamp: ''!
I am a configuration for the tests runner plugin.

I can be converted as a test suite via #asTestSuite.!
!DTTestsRunnerConfiguration methodsFor: 'converting' stamp: ''!
asTestSuite
	|newTestSuite|
	newTestSuite := TestSuite new.
	self items
		reject: #drTestsIsAbstract "This method allows to either test a test case instance or a test suite depending on kind of item."
		thenDo: [ :item | newTestSuite addTest: item drTestsSuite "This method allows to either add a test case instance or a test suite depending on kind of item." ].
	^ newTestSuite! !

!DTTestsRunnerPlugin commentStamp: ''!
I am the plugin implementing test runner for DrTests.!
!DTTestsRunnerPlugin methodsFor: 'api' stamp: ''!
startButtonHelp
	^ 'Run tests selected.' translated! !

!DTTestsRunnerPlugin methodsFor: 'api' stamp: ''!
allowMiniDrTests
	^ true! !

!DTTestsRunnerPlugin methodsFor: 'private' stamp: ''!
runTestSuites: testSuites

	| result |
	result := TestAsserter classForTestResult new.
	CurrentExecutionEnvironment runTestsBy: [ 
		testSuites
			do: [ :testSuite | 
				| specificResult |
				specificResult := testSuite resultClass new.
				self runSuite: testSuite withResult: specificResult.
				result mergeWith: specificResult ]
			displayingProgress: 'Running Tests' ].
	^ result! !

!DTTestsRunnerPlugin methodsFor: 'api' stamp: ''!
buildContextualMenuGroupWith: presenterInstance
	^ (CmCommandGroup named: 'TestRunnerResult context menu') asSpecGroup
		description: 'Commands related to re-run a result.';
		register:
			(DTRerunCommand forSpec context: presenterInstance)
				beHiddenWhenCantBeRun;
		register:
			(DTDebugTestCommand forSpec context: presenterInstance)
				beHiddenWhenCantBeRun;
		beDisplayedAsGroup;
		yourself! !

!DTTestsRunnerPlugin methodsFor: 'configuration building' stamp: ''!
buildConfigurationFrom: aDrTests
	"Builds a configuration from the plugin by reading the information held by the UI (aDrTests)."
	^ DTTestsRunnerConfiguration
		items: aDrTests selectedItems
		packages: aDrTests packagesSelected! !

!DTTestsRunnerPlugin methodsFor: 'private' stamp: ''!
removeTests: aCollectionOfTest from: aTestResult
	aCollectionOfTest do: [ :test |
		self removeTest: test from: aTestResult ].
	^ aTestResult! !

!DTTestsRunnerPlugin methodsFor: 'api' stamp: ''!
runForConfiguration: aDTpluginConfiguration
	| results |
	results := self pluginResultClass new
		testResults: (self runTestSuites: { aDTpluginConfiguration asTestSuite });
		yourself.
	^ aDTpluginConfiguration handleResults: results for: self! !

!DTTestsRunnerPlugin methodsFor: 'private' stamp: ''!
removeTest: aTest from: aTestResult
	aTestResult
		passed: (aTestResult passed copyWithout: aTest).
	aTestResult
		failures: (aTestResult failures copyWithout: aTest).
	aTestResult
		errors: (aTestResult errors copyWithout: aTest).
	^ aTestResult! !

!DTTestsRunnerPlugin methodsFor: 'api' stamp: ''!
secondListLabel
	^ 'Tests Cases'! !

!DTTestsRunnerPlugin methodsFor: 'api' stamp: ''!
firstListLabel
	^ 'Packages'! !

!DTTestsRunnerPlugin methodsFor: 'api' stamp: ''!
handleReRunResult: rerunnedResult forConfiguration: aDTRerunConfiguration
	| oldResult |
	oldResult := self
		removeTests: aDTRerunConfiguration configurationToRun items
		from: aDTRerunConfiguration previousResult testResults.
	^ self pluginResultClass new
		testResults: (self joinTestResult: oldResult with: rerunnedResult testResults);
		yourself! !

!DTTestsRunnerPlugin methodsFor: 'api' stamp: ''!
startButtonLabel
	^ 'Run Tests' translated! !

!DTTestsRunnerPlugin methodsFor: 'tests' stamp: ''!
testSuiteOf: aSetOfTest withName: aString
	^ aSetOfTest
		collect: [ :each | 
			TestSuite new
				in: [ :suite | 
					suite
						addTest: each;
						name: (self label: aString forSuite: suite) ];
				yourself ]! !

!DTTestsRunnerPlugin methodsFor: 'tests' stamp: ''!
label: aString forSuite: aTestSuite
	^ String streamContents: [ :stream |
		stream nextPutAll: 'Running '; print: aTestSuite tests size; space; nextPutAll: aString.
		aTestSuite tests size > 1 ifTrue: [ stream nextPut: $s ] ].! !

!DTTestsRunnerPlugin methodsFor: 'private' stamp: ''!
joinTestResult: aTestResult with: partialResult
	| newResult |
	newResult := aTestResult.
	partialResult passed do: [ :each | newResult addPass: each ].
	partialResult errors do: [ :each | newResult addError: each ].
	partialResult failures do: [ :each | newResult addFailure: each ].
	partialResult skipped do: [ :each | newResult addSkip: each ].
	^ newResult! !

!DTTestsRunnerPlugin methodsFor: 'accessing' stamp: ''!
pragmaForResultTrees
	^ #'dtTestRunnerResultTreeNamed:order:'! !

!DTTestsRunnerPlugin methodsFor: 'api' stamp: ''!
resultButtonHelp
	^ 'Browse the test selected in the results list.' translated! !

!DTTestsRunnerPlugin methodsFor: 'private' stamp: ''!
runSuite: aTestSuite withResult: aResult
	aTestSuite
		when: TestAnnouncement
		do: [ :testAnnouncement | 
			self flag: #TODO. "Dirty"
			testAnnouncement test class = TestSuite
				ifTrue: [ 
					self announceStatusChanged: ('Running test {1}.' format: {testAnnouncement test name}) ] ].
	[ aTestSuite run: aResult ]
		ensure: [ aTestSuite unsubscribe: TestAnnouncement ]! !

!DTTestsRunnerPlugin class methodsFor: 'api - accessing' stamp: ''!
weight
	^ 0! !

!DTTestsRunnerPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginResultClass
	^ DTTestsRunnerResult! !

!DTTestsRunnerPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginName
	^ 'Tests Runner'! !

!DTTestsRunnerResult commentStamp: ''!
I build a tree with the testsResult listed in groups: 
-Errors
-Failures
-Skipped tests
-Passed test
I am used in DrTestsUI to show the results in a orderly manner.!
!DTTestsRunnerResult methodsFor: 'tree building' stamp: ''!
buildLeavesFrom: aCollection type: testResultType
	^ aCollection collect: [ :t | DTTestLeafNode content: t type: testResultType ]! !

!DTTestsRunnerResult methodsFor: 'accessing' stamp: ''!
backgroundColor
	testsResult errors ifNotEmpty: [ ^ DTErrorResultType backgroundColor ].
	testsResult failures ifNotEmpty: [ ^ DTFailResultType backgroundColor  ].
	^ DTPassResultType backgroundColor! !

!DTTestsRunnerResult methodsFor: 'tree building' stamp: ''!
buildNodeGroupedByTypeClassAndProtocol: anOrderedColletion type: testResultType
	^ DTTreeNode new
			name: testResultType pluralName;
			subResults: ((anOrderedColletion groupedBy: #class) associations collect: [ :assoc |
				DTTreeNode new
					name: assoc key name;
					subResults: ((assoc value groupedBy: [ :testCase | (testCase class lookupSelector: testCase selector) protocol ]) associations collect: [ :protocolToTest |
						DTTreeNode new
							name: protocolToTest key;
							subResults: (self buildLeavesFrom: protocolToTest value type: testResultType) ]);
					yourself ]);
			yourself! !

!DTTestsRunnerResult methodsFor: 'accessing' stamp: ''!
textColor
	testsResult errors ifNotEmpty: [ ^ DTErrorResultType textColor ].
	testsResult failures ifNotEmpty: [ ^ DTFailResultType textColor  ].
	^ DTPassResultType textColor! !

!DTTestsRunnerResult methodsFor: 'tree building' stamp: ''!
buildNodeGroupedByTypeAndClass: anOrderedColletion type: testResultType
	^ DTTreeNode new
			name: testResultType pluralName;
			subResults: ((anOrderedColletion groupedBy: #class) associations collect: [ :assoc |
				DTTreeNode new
					name: assoc key name;
					browseBlock: [ assoc key drTestsBrowse ];
					subResults: (self buildLeavesFrom: assoc value type: testResultType);
					yourself ]);
			yourself! !

!DTTestsRunnerResult methodsFor: 'accessing' stamp: ''!
testResults
	^ testsResult! !

!DTTestsRunnerResult methodsFor: 'accessing' stamp: ''!
buildTreeForUIByClassesAndProtocol
	<dtTestRunnerResultTreeNamed: 'Grouped by type of result, classes, and protocol' order: 3>

	| errors failures skipped passed |
	errors := self buildNodeGroupedByTypeClassAndProtocol: self testResults errors type: DTTestResultType error.
	failures := self buildNodeGroupedByTypeClassAndProtocol: self testResults failures asOrderedCollection type: DTTestResultType fail.
	skipped := self buildNodeGroupedByTypeClassAndProtocol: self testResults skipped type: DTTestResultType skipped.
	passed := self buildNodeGroupedByTypeClassAndProtocol: self testResults passed type: DTTestResultType pass.
	^ DTTreeNode new
		subResults:
			{errors.
			failures.
			skipped.
			passed};
		yourself! !

!DTTestsRunnerResult methodsFor: 'accessing' stamp: ''!
buildTreeForUI
	<dtTestRunnerResultTreeNamed: 'Grouped by type of result' order: 1>
	^ DTTreeNode new
		subResults:
			{DTTreeNode new
				name: DTTestResultType error pluralName;
				subResults: (self buildLeavesFrom: self testResults errors asOrderedCollection type: DTTestResultType error);
				yourself.
			DTTreeNode new
				name: DTTestResultType fail pluralName;
				subResults: (self buildLeavesFrom: self testResults failures asOrderedCollection type: DTTestResultType fail).
			DTTreeNode new
				name: DTTestResultType skipped pluralName;
				subResults: (self buildLeavesFrom: self testResults skipped asOrderedCollection type: DTTestResultType skipped).
			DTTreeNode new
				name: DTTestResultType pass pluralName;
				subResults: (self buildLeavesFrom: self testResults passed asOrderedCollection type: DTTestResultType pass)
		};
		yourself! !

!DTTestsRunnerResult methodsFor: 'accessing' stamp: ''!
buildTreeForUIByClasses
	<dtTestRunnerResultTreeNamed: 'Grouped by type of result and classes' order: 2>

	| errors failures skipped passed |
	errors := self buildNodeGroupedByTypeAndClass: self testResults errors type: DTTestResultType error.
	failures := self buildNodeGroupedByTypeAndClass: self testResults failures asOrderedCollection type: DTTestResultType fail.
	skipped := self buildNodeGroupedByTypeAndClass: self testResults skipped type: DTTestResultType skipped.
	passed := self buildNodeGroupedByTypeAndClass: self testResults passed type: DTTestResultType pass.
	^ DTTreeNode new
		subResults:
			{errors.
			failures.
			skipped.
			passed};
		yourself! !

!DTTestsRunnerResult methodsFor: 'accessing' stamp: ''!
testResults: anObject
	testsResult := anObject! !

!DTTestsRunnerResult methodsFor: 'accessing' stamp: ''!
summarizeInfo
	"Text showed in miniDrTests with info of the result "

	^ String
		streamContents: [ :s | 
			s
				print: self testResults passed size;
				<< ' passed';
				cr;
				print: self testResults failures size;
				<< ' failures';
				cr;
				print: self testResults errors size;
				<< ' errors';
				cr;
				print: self testResults skipped size;
				<< ' skipped' ]! !

!DTTreeLeafNode commentStamp: ''!
I am a leaf of a Result Tree.
I have te content and I know the way to browse myself. !
!DTTreeLeafNode methodsFor: 'accessing' stamp: ''!
contentForReRun
	^ { self content }! !

!DTTreeLeafNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aDTResultsTreeVisitor
	^ aDTResultsTreeVisitor visitDTTreeLeaf: self! !

!DTTreeLeafNode methodsFor: 'accessing' stamp: ''!
content: anObject
	content := anObject! !

!DTTreeLeafNode methodsFor: 'testing' stamp: ''!
isLeaf
	^ true! !

!DTTreeLeafNode methodsFor: 'accessing' stamp: ''!
content
	^ content! !

!DTTreeLeafNode methodsFor: 'testing' stamp: ''!
canBeBrowsed
	^ true! !

!DTTreeLeafNode methodsFor: 'accessing' stamp: ''!
drTestsName
	^ self content drTestsName! !

!DTTreeLeafNode methodsFor: 'menu' stamp: ''!
drTestsBuildContextMenu: menu
	self content drTestsBuildContextMenu: menu! !

!DTTreeLeafNode methodsFor: 'actions' stamp: ''!
drTestsBrowse
	self content drTestsBrowse! !

!DTTreeLeafNode class methodsFor: 'instance creation' stamp: ''!
content: aRottenTest 
	^ self new
		content: aRottenTest;
		yourself! !

!DTTreeNode commentStamp: ''!
I am a node from a tree used to show results in DrTestUI.
!
!DTTreeNode methodsFor: 'accessing' stamp: ''!
contentForReRun
	^ (DTLeavesCollector collectLeavesOf: self) flatCollect: #contentForReRun! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
contextMenuBlock: anObject
	contextMenuBlock := anObject! !

!DTTreeNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		contextMenuBlock: [ :menu | ]. "Does nothing by default."
	self subResultsAggregator: [ :subRes | (DTLeavesCollector collectLeavesOf: self) size ].! !

!DTTreeNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aDTResultsTreeVisitor
	^ aDTResultsTreeVisitor visitDTTreeNode: self! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
subResults
	^ subResults! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
browseBlock
	^ browseBlock! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
subResults: anObject
	subResults := anObject! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
contextMenuBlock
	^ contextMenuBlock! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
drTestsName
	^ String streamContents: [ :s |
		s
			<< self name;
			<< $(;
			<< (self subResultsAggregator value: self subResults) asString;
			<< $) ]! !

!DTTreeNode methodsFor: 'testing' stamp: ''!
canBeBrowsed
	^ self browseBlock isNotNil! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
browseBlock: anObject
	browseBlock := anObject! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
subResultsAggregator
	^ subResultsAggregator! !

!DTTreeNode methodsFor: 'accessing' stamp: ''!
subResultsAggregator: anObject
	subResultsAggregator := anObject! !

!DTTreeNode methodsFor: 'menu' stamp: ''!
drTestsBuildContextMenu: menu
	self contextMenuBlock value: menu! !

!DTTreeNode methodsFor: 'actions' stamp: ''!
drTestsBrowse
	"Browse the tree node according to what is specified by my #browseBlock.
	 If my #browseBlock is nil, does nothing."
	self canBeBrowsed
		ifFalse: [ ^ self ].
	
	self browseBlock cull: self! !

!DTTreeNode class methodsFor: 'instance creation' stamp: ''!
empty
	^ self new
		subResults: #();
		yourself! !

!DTUpdateResults commentStamp: ''!
I am an announcement to force the UI to refresh the results.
This is useful when the results are handled in a asynchronous way!
!DTUpdateResults methodsFor: 'accessing' stamp: ''!
results

	^ results! !

!DTUpdateResults methodsFor: 'accessing' stamp: ''!
results: anObject

	results := anObject! !

!DailyNonInteractiveTranscript commentStamp: ''!
I am DailyNonInteractiveTranscript, a NonInteractiveTranscript that writes to a dated file, switching to a new file each day.

	(DailyNonInteractiveTranscript onFileNamed: 'server-{1}.log') install.
!
!DailyNonInteractiveTranscript methodsFor: 'private' stamp: ''!
initializeStream
	"Open the file stream that I write to or connect to #stdout/#stderr.
	I will use the platform line end convention.
	I will append to regular files.
	Overwrtitten to use #fileNameWithDate"
	
	^ stream := self isStdout 
		ifTrue: [ Stdio stdout ]
		ifFalse: [ 
			self isStderr
				ifTrue: [ Stdio stderr ]
				ifFalse: [ (File named: self fileNameWithDate) openForAppend ] ]! !

!DailyNonInteractiveTranscript methodsFor: 'accessing' stamp: ''!
fileNameWithDate
	| newName |
	newName := self fileName format: { date yyyymmdd }.
	self 
		assert: self fileName ~= newName 
		description: 'The filename should include a {1} slot for the date'.
	^ newName! !

!DailyNonInteractiveTranscript methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	date := Date today! !

!DailyNonInteractiveTranscript methodsFor: 'accessing' stamp: ''!
stream 
	"Overwritten to check if the date changed on each access"
	
	Date today > date
		ifTrue: [ 
			"The date changed: close the old file and advance the date"
			self close.
			date := Date today ].
	"Since stream is now nil, #initializeStream will be called"
	^ super stream! !

!DailyNonInteractiveTranscript class methodsFor: 'constants' stamp: ''!
defaultLogFileName
	"The default file name that will be used to write to.
	This needs to have a slot where the date will come."
	
	^ 'PharoTranscript-{1}.log'! !

!DamageRecorder commentStamp: ''!
Recording damages to repair by repainting!
!DamageRecorder methodsFor: 'recording' stamp: ''!
doFullRepaint
	"Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset."

	^ totalRepaint := true! !

!DamageRecorder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self reset! !

!DamageRecorder methodsFor: 'recording' stamp: ''!
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: 'testing' stamp: ''!
updateIsNeeded
	"Return true if the display needs to be updated."

	^totalRepaint or: [invalidRects notEmpty]! !

!DamageRecorder methodsFor: 'recording' stamp: ''!
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 setPoint: (rect origin min: newRect origin) truncated
				point: (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: 'initialization' stamp: ''!
reset
	"Clear the damage list."

	invalidRects := OrderedCollection new: 15.
	totalRepaint := false! !

!DangerousClassNotifier commentStamp: ''!
Some classes have special importance to the core system.  DangerousClassNotifier notifies users which class defiitions should not be modified. 

This class is refactored from the following Pharo2 methods:

* Behaviour>>shouldNotBeRedefined

* ClassBuilder>>tooDangerousClasses

* ClassBuilder>>name:  inEnvironment:  subclassOf:  type:  instanceVariableNames:  classVariableNames:  poolDictionaries:  category:  unsafe: 

Instance Variables
	enabled:		<Boolean>
	restoreState:		<Boolean>

enabled
	- Specifies whether this checking is performed. Some system tests that check "dangerous" behaviour need this turned off. 

restoreState
	- After disabling for testing, need to restore the previous state. 
!
!DangerousClassNotifier class methodsFor: 'accessing' stamp: ''!
shouldNotBeRedefined: classSymbol
	(self tooDangerousClasses includes: classSymbol) ifTrue: [ ^true ].
	^Smalltalk globals
		at: classSymbol 
		ifPresent: [ :class | (Smalltalk specialObjectsArray includes: class) or: [class isKindOf: class]]
		ifAbsent: false .
! !

!DangerousClassNotifier class methodsFor: 'accessing' stamp: ''!
initialize
	enabled := true.! !

!DangerousClassNotifier class methodsFor: 'validation' stamp: ''!
check: classSymbol

	self enabled ifFalse: [ ^false ].
	
	(self shouldNotBeRedefined: classSymbol)		
			ifTrue: [ self notify: '"' , classSymbol , '" should not be redefined as its structure is known to the VM. \Only proceed if you know what you are doing!!' withCRs ].

! !

!DangerousClassNotifier class methodsFor: 'accessing' stamp: ''!
disable
	enabled := false.
	
	! !

!DangerousClassNotifier class methodsFor: 'accessing' stamp: ''!
enable
	enabled := true.
	
	! !

!DangerousClassNotifier class methodsFor: 'accessing' stamp: ''!
enabled
	^enabled ifNil: [  enabled := false ]
! !

!DangerousClassNotifier class methodsFor: 'accessing' stamp: ''!
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 #Context #BlockClosure #CompiledMethod #CompiledCode #CompiledBlock
		"UndefinedObject crashes the VM"
		#UndefinedObject
		"Variables"
		#Slot #Variable
	)! !

!DangerousClassNotifier class methodsFor: 'accessing' stamp: ''!
disableDuring: aBlock
	"execute a block with me disabled. Works even nested and restores the old state"
	| oldState |
	oldState := enabled.
	enabled := false.
	aBlock value.
	enabled := oldState.! !

!DashedBorder commentStamp: ''!
Border style supporting dashed lines of configurable patterns and colours.!
!DashedBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!DashedBorderStyle commentStamp: ''!
Border style supporting dashed lines of configurable patterns and colours.!
!DashedBorderStyle methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		dashColors: {Color black. Color white};
		dashLengths: #(1 1)! !

!DashedBorderStyle methodsFor: 'accessing' stamp: ''!
dashColors
	"Answer the value of dashColors"

	^ dashColors! !

!DashedBorderStyle methodsFor: 'accessing' stamp: ''!
style
	"Answer #dashed."
	
	^#dashed! !

!DashedBorderStyle methodsFor: '*Athens-Morphic' stamp: ''!
asAthensPaintOn: anAthensCanvas
	^ AthensCompositeStrokePaint new fromDashedBorderStyle: self on: anAthensCanvas! !

!DashedBorderStyle methodsFor: 'accessing' stamp: ''!
dashLengths
	"Answer the value of dashLengths"

	^ dashLengths! !

!DashedBorderStyle methodsFor: 'accessing' stamp: ''!
dashColors: anObject
	"Set the value of dashColors"

	dashColors := anObject! !

!DashedBorderStyle methodsFor: 'accessing' stamp: ''!
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! !

!DashedBorderStyle methodsFor: 'accessing' stamp: ''!
dashLengths: anObject
	"Set the value of dashLengths"

	dashLengths := anObject! !

!DashedBorderStyle methodsFor: 'drawing' stamp: ''!
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! !

!DashedBorderStyle class methodsFor: 'instance creation' stamp: ''!
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! !

!Date commentStamp: ''!
Instances of Date are Timespans with duration of 1 day.
Their default creation assumes a start of midnight in the local time zone.

Comparing Dates

We tend to use dates in one of two modes:

- Time zone dependent
- Time zone independent

In the first instance, dates are only the same if they are in the same
time zone (otherwise they are two different 24 hour periods).  This is
the default behaviour of Date.

In the second, we are only interested in whether the day, month
and year are the same.

As an example, take someone's birthday.  If I want to know whether we
were born on the same day (and the same age), I will want to compare dates without time zones.  If I want to know if it is currently their birthday where they
are, I'll want to use time zones.

To compare two dates with time zones use #<, #<=, #=, #>= and #>.

To compare two dates ignoring time zones use #isBefore:, #isOnOrBefore:, #equals:, #isOnOrAfter: and #isAfter:.

| birthday1 birthday2 |

birthday1 := (DateAndTime fromString: '2018/01/01T00:00:00+10') asDate.
birthday2 := (DateAndTime fromString: '2018/01/01T00:00:00+01') asDate.

"Do person 1 and person 2 have the same birthday?"
birthday1 equals: birthday2.   "true"

"Do birthday1 and birthday2 represent the same 24 hour period of time?"
birthday1 = birthday2.  "false"

birthday1 < birthday2.  "true"
birthday1 isBefore: birthday2.  "false"
birthday1 isOnOrBefore: birthday2.  "true"
!
!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
subtractDays: dayCount 
	"((Date year: 2018 month: 9 day: 28) subtractDays: 1) printString >>> '27 September 2018'"

	^ (self asDateAndTime - (dayCount days)) asDate! !

!Date methodsFor: 'private' stamp: ''!
species

	^Timespan! !

!Date methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^ aGeneralMapper visitHookPrimitive: self
! !

!Date methodsFor: 'printing' stamp: ''!
printOn: aStream
 
 	self printOn: aStream format: #(1 2 3 $  3 1 )! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
isBefore: aDate
	"Answer a boolean indicating whether the receiver is earlier than aDate (ignoring time zones).
	To compare with time zones, use #<"

	| otherDate |

	otherDate := aDate asDate.
	^self year < otherDate year or: [ 
		self year = otherDate year and: [ 
			self monthIndex < otherDate monthIndex or: [ 
				self monthIndex = otherDate monthIndex and: [ 
					self dayOfMonth < otherDate dayOfMonth ] ] ] ]! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
weekday
	"Answer the name of the day of the week on which the receiver falls."
	"(Date year: 2018 month: 9 day: 28) weekday >>> #Friday"

	^ self dayOfWeekName! !

!Date methodsFor: '*EpiceaBrowsers' stamp: ''!
epiceaBrowsersAsString

	| numberOfDaysAgo |
	numberOfDaysAgo := self class today subtractDate: self.

	numberOfDaysAgo < 2 ifTrue: [
		^ String streamContents: [:stream | 
			stream nextPutAll: (numberOfDaysAgo = 0 
				ifTrue: [ 'Today' ]
				ifFalse: [ 'Yesterday'] ) ]].

	(numberOfDaysAgo between: 2 and: 7) ifTrue: [ 
		^ numberOfDaysAgo asString, ' days ago' ].

	^ self asDate asString! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
monthIndex
	"(Date year: 2018 month: 9 day: 28) monthIndex >>> 9"
		
	^ super month! !

!Date methodsFor: 'comparing - ignore timezone' stamp: ''!
equals: aDate
	"Perform a time zone independent comparison of the dates, i.e. only compare day, month and year.
	To compare with time zones, use #="
	"(Date today equals: Date yesterday) >>> false"

    ^self year = aDate year and: [
        self monthIndex = aDate monthIndex and:
        [ self dayOfMonth = aDate dayOfMonth ] ]! !

!Date methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"Use an ISO style YYYY-MM-DD representation.
	Since my current implementation is time zone offset sensitive, the offset has to be included."

	| representation |
	representation := self offset isZero
		ifTrue: [ 
			String new: 11 streamContents: [ :out | 
				self printOn: out format: #(3 2 1 $- 1 1 2).
				out nextPut: $Z ] ]
		ifFalse: [ 
			String new: 32 streamContents: [ :out | 
				self printOn: out format: #(3 2 1 $- 1 1 2).
				out nextPut: (self offset positive ifTrue: [ $+ ] ifFalse: [ $- ]).
				self offset hours abs printOn: out base: 10 length: 2 padded: true.
				out nextPut: $:.
				self offset minutes abs printOn: out base: 10 length: 2 padded: true.
				self offset seconds = 0 
					ifFalse:[ 
						out nextPut: $:; print: self offset seconds abs truncated ] ] ].
	stonWriter writeObject: self listSingleton: representation! !

!Date methodsFor: 'printing' stamp: ''!
printOn: aStream format: formatArray 
	
	BasicDatePrinter default printDate: self format: formatArray on: aStream! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
addDays: dayCount 
	"((Date year: 2018 month: 9 day: 28) addDays: 3) printString >>> '1 October 2018'"

	^ (self asDateAndTime + (dayCount days)) asDate! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
isOnOrAfter: aDate
	"Answer a boolean indicating whether the receiver is on or later than aDate (ignoring time zones).
	To compare with time zones, use #>="

	^(self equals: aDate) or: [ self isAfter: aDate ]! !

!Date methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects 
	^ false! !

!Date methodsFor: '*Fuel-Core' stamp: ''!
serializeOn: anEncoder
	start serializeOn: anEncoder! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
weekdayIndex
	"Sunday=1, ... , Saturday=7"
	"(Date year: 2018 month: 9 day: 28) weekdayIndex >>> 6"
	
	^ self dayOfWeek! !

!Date methodsFor: 'accessing' stamp: ''!
asDate
	"(Date year: 2018 month: 9 day: 28) asDate printString >>> '28 September 2018'"

	^ self! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
onPreviousMonth
	"(Date year: 2018 month: 9 day: 28) onPreviousMonth printString >>> '28 August 2018'"

	^ self addMonths: -1! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
yyyymmdd
 	"Format the date in ISO 8601 standard like '2002-10-22'
	The result is of fixed size 10 characters long.."
 	"(Date year: 2018 month: 9 day: 28) yyyymmdd >>> '2018-09-28'"
	
 	^ String new: 10 streamContents: [ :aStream |
		self printOn: aStream format: #(3 2 1 $- 1 1 2) ]! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
previous: dayName 
	"Answer the previous date whose weekday name is dayName."
	"((Date year: 2018 month: 9 day: 28) previous: 'Sunday') printString >>> '23 September 2018'"

	| days |
	days := 7 + self weekdayIndex - (self class dayOfWeek: dayName) \\ 7.
	days = 0 ifTrue: [ days := 7 ].
	^ self subtractDays: days! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
addMonths: monthCount 
	"((Date year: 2018 month: 9 day: 28) addMonths: 3) printString>>> '28 December 2018'"
	
	|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 min: maxDaysInMonth.
	^ Date year: year month: month day: day! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
subtractDate: aDate 
	"Answer the number of days between self and aDate"
	"((Date year: 2018 month: 9 day: 28) subtractDate: '27 September 2018') >>> 1"

	^ (self start - aDate asDateAndTime) days! !

!Date methodsFor: 'accessing' stamp: ''!
dayMonthYearDo: aBlock 
	"Supply integers for day, month and year to aBlock and return the result"

	^ start dayMonthYearDo: aBlock! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
isOnOrBefore: aDate
	"Answer a boolean indicating whether the receiver is on or earlier than aDate (ignoring time zones).
	To compare with time zones, use #<="

	^(self equals: aDate) or: [ self isBefore: aDate ]! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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"
	"(Date year: 2018 month: 9 day: 28) mmddyyyy >>> '9/28/2018'"

	^ self printFormat: #(2 1 3 $/ 1 1)! !

!Date methodsFor: 'printing' stamp: ''!
printFormat: formatArray 
	"Answer a String describing the receiver using the argument formatArray."

	^ String new: 16 streamContents: [ :aStream |
		self printOn: aStream format: formatArray ]! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
onNextMonth
	"(Date year: 2018 month: 9 day: 28) onNextMonth printString >>> '28 October 2018'"

	^ self addMonths: 1! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
isAfter: aDate
	"Answer a boolean indicating whether the receiver is later than aDate (ignoring time zones).
	To compare with time zones, use #>"

	| otherDate |

	otherDate := aDate asDate.
	^self year > otherDate year or: [ 
		self year = otherDate year and: [ 
			self monthIndex > otherDate monthIndex or: [ 
				self monthIndex = otherDate monthIndex and: [ 
					self dayOfMonth > otherDate dayOfMonth ] ] ] ]! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
ddmmyyyy
	"Print the receiver  in standard French format dd/mm/yyyy."
	"(Date year: 2018 month: 9 day: 28) ddmmyyyy >>> '28/9/2018'"

	^ self printFormat: #(1 2 3 $/ 1 1)! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
storeOn: aStream
 
 	aStream print: self printString; nextPutAll: ' asDate'! !

!Date methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
month
	"(Date year: 2018 month: 9 day: 28) month printString >>> 'September 2018'"

	^ self asMonth! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
firstWeekdayOfMonth: month year: year
	"Answer the weekday index of the first day in <month> in the <year>."

	^ (self year: year month: month day: 1) weekdayIndex! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
dayNames
	"Return a collection of english day names"
	^ DayNames copy! !

!Date class methodsFor: '*Fuel-Core' stamp: ''!
materializeFrom: aDecoder
	^ self 
		starting: (DateAndTime materializeFrom: aDecoder) midnight 
		duration: (Duration days: 1)! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
year: year week: week day: dayOfWeek

	^ self starting: (Week year: year week: week) start + (dayOfWeek - 1) days! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
julianDayNumber: aJulianDayNumber

	^ self starting: (DateAndTime julianDayNumber: aJulianDayNumber)! !

!Date class methodsFor: 'instance creation' stamp: ''!
starting: aDateAndTime

	^ super starting: (aDateAndTime midnight) duration: (Duration days: 1)! !

!Date class methodsFor: 'instance creation' stamp: ''!
today

	^ self current! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
newDay: dayCount year: yearInteger

	^ self year: yearInteger day: dayCount! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
nameOfMonth: anIndex 

	^ Month nameOfMonth: anIndex.! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
daysInYear: yearInteger 

	^ Year daysInYear: yearInteger.! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
daysInMonth: monthName forYear: yearInteger 

	^ Month daysInMonth: monthName forYear: yearInteger.! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
readFrom: aStream 
	"Read a Date from the stream in any of the forms:  
		<day> <month> <year>		(15 April 1982; 15-APR-82; 15.4.82; 15APR82)  
		<month> <day> <year>		(April 15, 1982; 4/15/82)
		<year>-<month>-<day>			(1982-04-15) (ISO8601)"
	| day month year parsedNumber prefix |
	aStream peek = $-
		ifTrue: [prefix := -1]
		ifFalse: [prefix := 1].
	[aStream peek isAlphaNumeric]
		whileFalse: [aStream skip: 1].
	aStream peek isDigit
		ifTrue: [
			parsedNumber := (Integer readFrom: aStream) * prefix.
			(parsedNumber < 0 or: [parsedNumber > 31])
				ifTrue: [year := parsedNumber]].
	[aStream peek isAlphaNumeric]
		whileFalse: [aStream skip: 1].
	aStream peek isLetter
		ifTrue: ["MM-DD-YY or DD-MM-YY or YY-MM-DD"
			month := (String new: 10) writeStream.
			[aStream peek isLetter]
				whileTrue: [month nextPut: aStream next].
			month := month contents.
			[aStream peek isAlphaNumeric]
				whileFalse: [aStream skip: 1].
			parsedNumber 
				ifNil: ["MM DD YY"
					day := Integer readFrom: aStream]
				ifNotNil: [
					year 
						ifNil: ["DD MM YY"
							day := parsedNumber]]]
		ifFalse: ["MM-DD-YY or DD-MM-YY or YY-MM-DD"
			year 
				ifNil: ["MM-DD-YY or DD-MM-YY"
					parsedNumber > 12
						ifTrue: ["DD-MM-YY"
							Error signal: 'Month out of bounds: ', parsedNumber asString, '.'.
							day := parsedNumber.
							month := Month nameOfMonth: (Integer readFrom: aStream) ]
						ifFalse: ["MM-DD-YY"
							month := Month nameOfMonth: parsedNumber.
							day := Integer readFrom: aStream]]
				ifNotNil: ["YY-MM-DD"
					month := Month nameOfMonth: (Integer readFrom: aStream)]].
	[aStream peek isAlphaNumeric]
		whileFalse: [aStream skip: 1].
	year 
		ifNil: [year := Integer readFrom: aStream]
		ifNotNil: [day := Integer readFrom: aStream].
	(year < 100 and: [year >= 0]) 
		ifTrue: [
			year < 69 
				ifTrue: [year := 2000 + year]
				ifFalse: [year := 1900 + year]].

	^ self
		year: year
		month: month
		day: day! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
fromString: aString
	"Answer an instance of created from a string with format mm.dd.yyyy or mm-dd-yyyy or mm/dd/yyyy"

	^ self readFrom: aString readStream.! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
year: year month: month day: day

	^ self starting: (DateAndTime year: year month: month day: day)! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
monthNames
	"Return a collection of english month names"
	^ MonthNames copy! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
indexOfMonth: aMonthName 

	^ Month indexOfMonth: aMonthName.! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
newDay: day month: month year: year 

	^ self year: year month: month day: day! !

!Date class methodsFor: 'instance creation' stamp: ''!
fromDays: dayCount 
	"Days since 1 January 1901"

	^ self julianDayNumber: SqueakEpoch + dayCount! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
daysInMonth
	"Return a collection representing the days in each month"
	^ DaysInMonth copy! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
dayOfWeek: dayName 

	^ Week indexOfDay: dayName! !

!Date class methodsFor: 'instance creation' stamp: ''!
fromSeconds: seconds
	"Answer an instance of me which is 'seconds' seconds after January 1, 1901."

	^ self starting: (DateAndTime fromSeconds: seconds)! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
tomorrow

	^ self today next! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
julianDayNumber: aJulianDayNumber offset: aTimeZoneOffset

	^ self starting: (DateAndTime julianDayNumber: aJulianDayNumber offset: aTimeZoneOffset)! !

!Date class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Read a ISO YYYY-MM-DD format.
	Since my current implementation is time zone offset sensitive, the offset has to be taken into account.
	A missing offset results in the local timezone offset to be used"
	
	| readStream date |
	readStream := stonReader parseListSingleton readStream.
	date := self readFrom: readStream.
	readStream atEnd
		ifFalse: [ | offset |
			offset := DateAndTime readTimezoneOffsetFrom: readStream.
			offset = date offset 
				ifFalse: [ date start: (date start translateTo: offset) ] ].
	^ date! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
week: week day: dayOfWeek

	^ self starting: (Week week: week) start + (dayOfWeek - 1) days! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
year: year day: dayOfYear

	^ self starting: (DateAndTime year: year day: dayOfYear)! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
nameOfDay: dayIndex 

	^ Week nameOfDay: dayIndex! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
yesterday

	^ self today previous! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asMonth: aMonthNumber inYear: aYearNumber
      "Returns the month corresponding the month number"
    
        ^ Month year: aYearNumber month: aMonthNumber! !

!Date class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
readFrom: aStringOrStream pattern: pattern
	"See 
	DateParser comment"

	^ (DateParser readingFrom: aStringOrStream readStream pattern: pattern) parse! !

!DateAndTime commentStamp: ''!
I am DateAndTime.
I represent a point in time or timestamp as defined by ISO 8601. 
I am a Magnitude. 
I have nanosecond precision.
I am TimeZone aware. 
I have zero duration.

  DateAndTime now.
  DateAndTime now asUTC rounded.
  DateAndTime fromString: '1969-07-20T20:17:40.123+02:00'.
  DateAndTime fromString: '1969-07-20T20:17:40Z'.

My implementation uses three SmallIntegers and a Duration:
  julianDayNumber - julian day number (starting at midnight UTC rather than noon GMT).
  seconds - number of seconds since midnight UTC. Always positive, between 0 and 86399.
  nanos	 - the number of nanoseconds since the second. Always positive, between 0 and 999999999.
  offset	- duration from UTC.

The offset is used to print the date and time in a local time zone, but the date and time are handled in UTC internally.
The nanosecond attribute is often zero but it defined for full ISO compliance and is suitable for timestamping.
!
!DateAndTime methodsFor: 'arithmetic' stamp: ''!
+ operand
	"operand conforms to protocol Duration"

	| durationTicks |
	durationTicks := operand asDuration ticks.
	^ self class basicNew
		setJdn: julianDayNumber + durationTicks first
			seconds: seconds + durationTicks second
			nano: nanos + durationTicks third
			offset: self offset;
		yourself! !

!DateAndTime methodsFor: 'arithmetic' stamp: ''!
< comparand
	"comparand conforms to protocol DateAndTime,
	or can be converted into something that conforms."

	| other |
	other := comparand asDateAndTime.
	^ julianDayNumber = other julianDayNumberUTC
		ifTrue: [ 
			seconds = other secondsSinceMidnightUTC
				ifTrue: [ nanos < other nanoSecond ]
				ifFalse: [ seconds < other secondsSinceMidnightUTC ] ]
		ifFalse: [ julianDayNumber < other julianDayNumberUTC ]! !

!DateAndTime methodsFor: 'private' stamp: ''!
ticks: ticks offset: utcOffset
	"ticks is {julianDayNumber. secondCount. nanoSeconds}"

	self setJdn: (ticks at: 1) seconds: (ticks at: 2) nano: (ticks at: 3) offset: utcOffset! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
daysInYear
 
 	"Answer the number of days in the year represented by the receiver."
 
 	^ self asYear daysInYear! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
nanoSecond

	^ nanos! !

!DateAndTime methodsFor: 'converting' stamp: ''!
asTimeUTC

	^ Time seconds: self secondsSinceMidnightUTC nanoSeconds: nanos! !

!DateAndTime methodsFor: 'comparing' stamp: ''!
hash
	^ (julianDayNumber hashMultiply bitXor: seconds) bitXor: nanos! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asNanoSeconds
	"Answer the number of nanoseconds since midnight"

	^ self asDuration asNanoSeconds! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
firstDayOfMonth
 
 	^ self asMonth start day! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asFileNameCompatibleString
	| stream |
	stream := String new writeStream.
	self printYMDOn: stream.
	stream << '.'.
	self printHMSWithDashesOn: stream.
	^ stream contents! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
monthAbbreviation

	^ self monthName copyFrom: 1 to: 3! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
dayOfMonth
	"Answer which day of the month is represented by the receiver."

	^ self dayMonthYearDo: [ :d :m :y | d ]! !

!DateAndTime methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^ aGeneralMapper visitHookPrimitive: self
! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
hours
 
 	^ self hour! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
dayOfWeek
	"Sunday=1, ... , Saturday=7"

	^ (self julianDayNumber + 1 rem: 7) + 1! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
julianDayNumberUTC
	
	^ julianDayNumber! !

!DateAndTime methodsFor: 'converting' stamp: ''!
asUnixTime
	"answer number of seconds since unix epoch (midnight Jan 1, 1970, UTC)"
	^((self offset: Duration zero) - self class unixEpoch) asSeconds! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
timeZone
	^ TimeZone offset: self offset! !

!DateAndTime methodsFor: 'converting' stamp: ''!
asUTC

	^ offset isZero
		ifTrue: [ self ]
		ifFalse: [ self offset: 0 ]! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
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."
   "(DateAndTime fromString: ' 2004-02-29T13:33:12+02:00') second >>> 12" 

 	^ self localSeconds \\ 60! !

!DateAndTime methodsFor: 'arithmetic' stamp: ''!
- operand
	"operand conforms to protocol DateAndTime or protocol Duration"

	^ (operand respondsTo: #asDateAndTime)
		ifTrue: [ 
			| other |
			other := operand asDateAndTime.
			Duration
				seconds: (SecondsInDay * (julianDayNumber - other julianDayNumberUTC))
							+ (seconds - other secondsSinceMidnightUTC)
				nanoSeconds: nanos - other nanoSecond ]
		ifFalse: [ self + operand negated ]! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
isLeapYear

	^ Year isLeapYear: self year.! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
asSeconds
 	"Return the number of seconds since the epoch"
 
 	^ (self - (self class epoch)) asSeconds! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
withoutOffset

	^ self offset: 0! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
timeZoneName

	^ self timeZone name! !

!DateAndTime methodsFor: '*Metacello-Core' stamp: ''!
setTimestampInMetacelloConfig: aMetacelloConfig
    aMetacelloConfig setTimestampWithString: self printString! !

!DateAndTime methodsFor: 'converting' stamp: ''!
asDate
    "Convert the receiver in a date object."
    "(DateAndTime fromString: ' 2019-08-17T13:33:00+02:00') asDate printString >>> (Date newDay: 17 month: 8 year: 2019) printString"
    ^ Date starting: self! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asWeek

	^ Week starting: self! !

!DateAndTime methodsFor: '*Fuel-Core' stamp: ''!
fuelSet: julianDay nanoSecond: nanoSeconds seconds: numberOfSeconds offset: anOffset
	self setJdn: julianDay seconds: numberOfSeconds nano: nanoSeconds offset: anOffset! !

!DateAndTime methodsFor: '*Fuel-Core' stamp: ''!
serializeOn: anEncoder

	anEncoder 
		encodeUint32: self julianDayNumberUTC;
		encodeUint32: self nanoSecond;
		encodeInt24: self secondsSinceMidnightUTC;
		encodeInt24: self offset asSeconds;
		encodeInt32: self offset nanoSeconds.! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
offset: anOffset
	"Answer a <DateAndTime> equivalent to the receiver but with its local time 
	being offset from UTC by offset.
	Unlike #translateTo: this will NOT change the absolute in UTC "

	^ self class basicNew 
		ticks: self ticks offset: anOffset asDuration;
		yourself! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
seconds
 
 	^ self second! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
printHMSOn: aStream separatedBy: aSeparator
	
	BasicDatePrinter default printHMS: self separatedBy: aSeparator on: aStream! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
daysInMonth
	"Answer the number of days in the month represented by the receiver."


	^ self asMonth daysInMonth! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
hour24
	"Answer a number that represents the number of complete hours in the receiver's time part,
	 after the number of complete days has been removed."
 
 	^ self localSeconds // SecondsInHour \\ 24! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
julianDayOffset
	"Return the offset in julian days possibly introduced by the timezone offset"
	
	^ ((seconds + self offset asSeconds) / SecondsInDay) floor! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asMonth

	^ Month starting: self! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
rounded
	"Answer a date and time to the nearest whole second"

	^ self species basicNew
		ticks:
			{ julianDayNumber.
			nanos *2 >= NanosInSecond
				ifTrue: [seconds + 1]
				ifFalse: [seconds].
			0 }
		offset: offset! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
midnight
	"Answer a DateAndTime starting at midnight (towards the end of the day) local time"

	self dayMonthYearDo: [ :day :month :year | 
			^ self class
				basicYear: year
				month: month
				day: day
				hour: 0
				minute: 0
				second: 0
				nanoSecond: 0
				offset: offset ]! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
timeZoneAbbreviation

	^ self timeZone abbreviation! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
truncated
	"Answer a date and time to the nearest preceding whole second"
	
	^ self species basicNew ticks: { julianDayNumber. seconds. 0 } offset: offset! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
minutes
 
 	^ self minute! !

!DateAndTime methodsFor: '*Network-Mail' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
hour12
	"Answer an <integer> 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: '*Metacello-Core' stamp: ''!
setTimestampInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setTimestamp: 
		(aMetacelloVersionSpec project valueHolderSpec
			value: self printString;
			yourself)! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
printSeparateDateAndTimeOn: stream
	"Print the receiver as separate Date and Time to stream.
	See also #readSeparateDateAndTimeFrom:"

	stream
		print: self asDate;
		space;
		print: self asTime! !

!DateAndTime methodsFor: 'converting' stamp: ''!
asDuration
	"Answer the duration since midnight."

	^ Duration seconds: self secondsSinceMidnightLocalTime nanoSeconds: nanos! !

!DateAndTime methodsFor: 'comparing' stamp: ''!
= other 
	self == other ifTrue: [ ^ true ].
	(self species = other species) ifFalse: [ ^ false ].
	^ self hasEqualTicks: other! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
day
 
 	^ self dayOfYear! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
printHMSOn: aStream
	"Print just hh:mm:ss"

	self printHMSOn: aStream separatedBy: $:! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
duration

	^ Duration zero! !

!DateAndTime methodsFor: 'printing' stamp: ''!
printOn: aStream withLeadingSpace: printLeadingSpaceToo
	
	BasicDatePrinter default printDateAndTime: self withLeadingSpace: printLeadingSpaceToo on: aStream! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
dayOfWeekName

	^ Week nameOfDay: self dayOfWeek! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
to: anEnd
	"Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan"

	^ Timespan starting: self ending: (anEnd asDateAndTime).! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
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: 'private' stamp: ''!
setJdn: julDays seconds: secs nano: nanoSecs offset: anOffset
	julianDayNumber := julDays.
	seconds := secs.
	nanos := nanoSecs.
	offset := anOffset.
	self normalizeSecondsAndNanos! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
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."
	"(DateAndTime fromString: ' 2004-02-29T13:33:00+02:00') minute >>> 33"
		
 	^ self localSeconds // SecondsInMinute \\ 60! !

!DateAndTime methodsFor: 'printing' stamp: ''!
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: '*EpiceaBrowsers' stamp: ''!
epiceaBrowsersAsString

	^ String streamContents: [ :stream |
		stream 
			nextPutAll: self asDate epiceaBrowsersAsString;
			nextPutAll: ', '.
		self asTime 
			print24: false
			showSeconds: false 
			on: stream ]! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
secondsSinceMidnightLocalTime
	^ self localSeconds \\ SecondsInDay! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asYear

	^ Year starting: self! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
monthIndex
 
 
 	^ self month! !

!DateAndTime methodsFor: '*Iceberg' stamp: ''!
asLocalStringYMDHM
	^ self asLocal asStringYMDHM! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
offset

	^ offset! !

!DateAndTime methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"Use an ISO representation with all details YYYY-MM-DDTHH:MM:SS.N+TZ (with optional nanoseconds and timezone offset)"
	
	stonWriter writeObject: self listSingleton: 
		(String streamContents: [ :stream |
			self printOn: stream withLeadingSpace: false ])! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
localSeconds
	" Return the seconds since the epoch in local time."
	^ seconds + self offset asSeconds! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
printHMSWithDashesOn: aStream
	"Print just hh-mm-ss"

	self printHMSOn: aStream separatedBy: $-! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
secondsSinceMidnightUTC

	^ seconds! !

!DateAndTime methodsFor: '*Iceberg' stamp: ''!
asStringYMDHM
	^ String streamContents: [ :aStream |
		self printYMDOn: aStream.
		aStream nextPut: Character space.
		self hour printOn: aStream base: 10 length: 2 padded: true.
		aStream nextPut: $:.
		self minute printOn: aStream base: 10 length: 2 padded: true ]! !

!DateAndTime methodsFor: 'private' stamp: ''!
ticks
	"Private - answer an array with our instance variables. Assumed to be UTC "

	^ Array with: julianDayNumber with: seconds with: nanos.! !

!DateAndTime methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects 
	^ false! !

!DateAndTime methodsFor: 'converting' stamp: ''!
asDateAndTime

	^ self! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
daysLeftInYear
 	"Answer the number of days in the year after the date of the receiver."
 
 	^ self daysInYear - self dayOfYear! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
meridianAbbreviation

	^ self asTime meridianAbbreviation! !

!DateAndTime methodsFor: 'converting' stamp: ''!
asTime

	^ Time seconds: self secondsSinceMidnightLocalTime nanoSeconds: nanos! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
hour

	^ self hour24! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
translateToUTC
	" Move this represenation to UTC"
	^ self translateTo: 0 asDuration! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asDosTimestamp

	^ (DosTimestamp fromDateAndTime: self) value.! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
monthName

	^ Month nameOfMonth: self month! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
dayOfWeekAbbreviation

	^ self dayOfWeekName copyFrom: 1 to: 3! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asLocal
	
	^ (self offset = self class localOffset)
		ifTrue: [self]
		ifFalse: [self offset: self class localOffset]! !

!DateAndTime methodsFor: 'initialization' stamp: ''!
normalizeSecondsAndNanos
	(NanosInSecond <= nanos or: [ nanos < 0 ])
		ifTrue: [
			seconds := seconds + (nanos // NanosInSecond).
			nanos := nanos \\ NanosInSecond].
	(SecondsInDay <= seconds or: [ seconds < 0 ])
		ifTrue: [
			julianDayNumber := julianDayNumber + (seconds // SecondsInDay).
			seconds := seconds \\ SecondsInDay].! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
year
	^ self dayMonthYearDo: [:d :m :y | y ]! !

!DateAndTime methodsFor: 'accessing' stamp: ''!
julianDayNumber
	
	^ julianDayNumber + self julianDayOffset! !

!DateAndTime methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
month

	^ self dayMonthYearDo: [ :d :m :y | m ].! !

!DateAndTime methodsFor: 'private' stamp: ''!
hasEqualTicks: aDateAndTime
	
	^ (self julianDayNumberUTC = aDateAndTime julianDayNumberUTC)
		and: [ (seconds = aDateAndTime secondsSinceMidnightUTC)
			and: [ nanos = aDateAndTime nanoSecond ] ]! !

!DateAndTime class methodsFor: 'instance creation' stamp: ''!
new
	"Answer a DateAndTime representing the epoch: 1 January 1901"

	^ self epoch offset: self localOffset! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
fromDosTimestamp: anInteger

	^ (DosTimestamp on: anInteger) asDateAndTime.! !

!DateAndTime class methodsFor: 'instance creation queries' stamp: ''!
current

	^ self now! !

!DateAndTime class methodsFor: 'instance creation' stamp: ''!
fromInternalTime: anInteger
	"Answer an instance of the receiver with the time represented by anInteger. Pharo internal time is an integer representing time in the local timezone with an epoch of 1 Jan. 1901"

	^(self fromSeconds: anInteger offset: 0) translateTo: self localOffset.! !

!DateAndTime class methodsFor: 'instance creation' stamp: ''!
julianDayNumber: aJulianDayNumber

	^ self basicNew
		ticks: aJulianDayNumber days ticks offset: Duration new;
		yourself! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
readFrom: aStream defaultOffset: defaultOffset
	"Parse and return a new DateAndTime instance from stream, 
	as a Date, an optional Time and an optional TimeZone offset.
	The time defaults to midnight, the timezone to defaultOffset"
	"self readFrom: '2013-03-04T23:47:52.876+01:00' readStream"

	| date time offset |
	date := Date readFrom: aStream.
	[ aStream atEnd or: [ '0123456789Z+-' includes: aStream peek ] ] 
		whileFalse: [ aStream next ].
  	('0123456789' includes: aStream peek)
		ifTrue: [ time := Time readFrom: aStream ]
		ifFalse: [ time := Time midnight ].
	aStream skipSeparators.
	offset := self readTimezoneOffsetFrom: aStream default: defaultOffset.
	^ self
		year: date year
		month: date monthIndex
		day: date dayOfMonth
		hour: time hour
		minute: time minute
		second: time second
		nanoSecond: time nanoSecond
		offset: offset! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
totalSeconds
	"Answer the total seconds ellapsed since the epoch: 1 January 1901"

	^ self clock totalSeconds! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
readTwoDigitIntegerFrom: stream
	"Parse and return a decimal number of 2 digits from stream.
	Fail if that is not possible"

	| integer |
	integer := 0.
	2 timesRepeat: [ | char |
		char := stream next.
		('0123456789' includes: char) ifFalse: [ self error: 'Decimal digit expected' ].
		integer := (integer * 10) + char digitValue ].
	^ integer! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
fromMethodTimeStamp: aString
	| stream |
	stream := aString readStream.
	stream
		skipSeparators;
		skipTo: Character space.
	^ self readSeparateDateAndTimeFrom: stream! !

!DateAndTime class methodsFor: 'initialize-release' stamp: ''!
initialize
	ClockProvider := Time! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
noon

	^ self now noon! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
fromSeconds: secondsSinceEpochUTC
	"Answer a DateAndTime since the epoch: 1 January 1901 for the seconds in UTC time"
	^ self fromSeconds: secondsSinceEpochUTC offset: self localOffset! !

!DateAndTime class methodsFor: 'primitives' stamp: ''!
millisecondClockValue

	^ self clock millisecondClockValue! !

!DateAndTime class methodsFor: 'instance creation' stamp: ''!
midnight

	^ self now midnight! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
fromSeconds: utcSecondsSinceEpoch offset: aUTCOffset
	"Answer a DateAndTime since the epoch: 1 January 1901 for the given timeZone"

	| integerSeconds nanos |
	integerSeconds := utcSecondsSinceEpoch truncated.
	nanos := integerSeconds = utcSecondsSinceEpoch
		ifTrue: [ 0 ]
		ifFalse: [ ((utcSecondsSinceEpoch - integerSeconds) * NanosInSecond) asInteger ].
	^ self basicNew ticks: {SqueakEpoch . integerSeconds . nanos} offset: aUTCOffset asDuration! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
readTimezoneOffsetFrom: stream
	"Read and return an optional timezone offset in the form of 
	[+|-]hh[[separator]mm[[separator]ss]] or Z from stream as a duration.
	If there is no offset, return the local offset."

	^self readTimezoneOffsetFrom: stream default: self localOffset! !

!DateAndTime class methodsFor: 'instance creation queries' stamp: ''!
unixEpoch
	"Answer a DateAndTime representing the Unix epoch (1 January 1970, midnight UTC)"
	^ self basicNew
		ticks: #(2440588 0 0) offset: Duration zero;
		yourself.! !

!DateAndTime class methodsFor: 'instance creation' stamp: ''!
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: 'clock provider' stamp: ''!
year: aYearInteger month: aMonthNumber
    "Return a date starting the first day of the month"

    ^ self
        year: aYearInteger
        month: aMonthNumber
        day: 1
        hour: 0
        minute: 0! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
readTimezoneOffsetFrom: stream default: defaultOffset
	"Read and return an optional timezone offset in the form of 
	[+|-]hh[[separator]mm[[separator]ss]] or Z from stream as a duration.
	If there is no offset, return the defaultOffset."

	| sign hour minute second |
	(stream peekFor: $Z) ifTrue: [ ^ Duration zero ].
	hour := minute := second := 0.
	^ ('+-' includes: stream peek)
		ifTrue: [
			sign := stream next = $- ifTrue: [ -1 ] ifFalse: [ 1 ].
			hour := self readTwoDigitIntegerFrom: stream.
			(self readOptionalSeparatorFrom: stream)
				ifNotNil: [ 
					minute := self readTwoDigitIntegerFrom: stream.
					(self readOptionalSeparatorFrom: stream)
						ifNotNil: [ 
							second := Integer readFrom: stream ] ].
			Duration seconds: sign * ((hour * 3600) + (minute * 60) + second) ]
		ifFalse: [ defaultOffset ]! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
year: year day: dayOfYear
	"Return a DateAndTime"

	^ self
		year: year
		day: dayOfYear
		hour: 0
		minute: 0
		second: 0! !

!DateAndTime class methodsFor: 'instance creation' stamp: ''!
fromUnixTime: anInteger
	^ self fromSeconds: anInteger + 2177452800 "unix epoch constant"! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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 ].
	(monthIndex between: 1 and: 12) ifFalse: [ DateError signal: 'There is no ', monthIndex printString, 'th month' ].
	daysInMonth := Month
		daysInMonth: monthIndex
		forYear: year.
	day < 1 ifTrue: [ DateError signal: 'day may not be zero or negative' ].
	day > daysInMonth ifTrue: [ DateError signal: '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: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Fuel-Core' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
today

	^ self midnight! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
year: year month: month day: day hour: hour minute: minute second: second offset: offset

	^ self
		year: year
		month: month
		day: day
		hour: hour
		minute: minute
		second: second
		nanoSecond: 0
		offset: offset! !

!DateAndTime class methodsFor: 'system queries' stamp: ''!
clockPrecision
	"One nanosecond precision"

	^ Duration seconds: 0 nanoSeconds: 1! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
readSeparateDateAndTimeFrom: stream
	"Read a separate Date and Time from stream to instanciate the receiver.
	See also #printSeparateDateAndTimeOn:"
	
	| date time |
	stream skipSeparators.
	date := Date readFrom: stream.
	stream skipSeparators.
	time := Time readFrom: stream.
	^ self 
		date: date
		time: time! !

!DateAndTime class methodsFor: 'time zones' stamp: ''!
localTimeZone
	"Answer the local time zone"

	^ LocalTimeZoneCache ifNil: [ LocalTimeZoneCache := TimeZone default ]! !

!DateAndTime class methodsFor: 'system queries' stamp: ''!
localOffset
	"Answer the duration we are offset from UTC"

	^ self localTimeZone offset! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
readFrom: aStream
	"Parse and return a new DateAndTime instance from stream, 
	as a Date, an optional Time and an optional TimeZone offset.
	The time defaults to midnight, the timezone to the local offset"
	"self readFrom: '2013-03-04T23:47:52.876+01:00' readStream"

	^self readFrom: aStream defaultOffset: self localOffset.! !

!DateAndTime class methodsFor: 'input' stamp: ''!
fromString: aString 
	^ self readFrom: aString readStream! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: 'clock provider' stamp: ''!
clock 
	 "the provider of real time seconds/milliseconds."

	^ ClockProvider! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: 'private' stamp: ''!
basicYear: 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)"

	| p q r s julianDayNumber localSeconds utcSeconds|

	p := (month - 14) quo: 12.
	q := year + 4800 + p.
	r := month - 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: '*Kernel-Chronology-Extras' stamp: ''!
tomorrow

	^ self today asDate next asDateAndTime! !

!DateAndTime class methodsFor: 'instance creation' stamp: ''!
now 
	"Answer the current date and time expressed in local time.
	[ 10000 timesRepeat: [ self now. ] ] timeToRun / 10000.0 . "

	| nanoTicks |
	nanoTicks := self clock microsecondClockValue * 1000.
	^ self basicNew
		setJdn: SqueakEpoch 
		seconds: 0
		nano: nanoTicks
		offset: self localOffset! !

!DateAndTime class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	^ self readFrom: stonReader parseListSingleton readStream! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
date: aDate time: aTime

	^ self 
		year: aDate year
		month: aDate monthName
		day: aDate dayOfMonth 
		hour: aTime hour 
		minute: aTime minute 
		second: aTime second
		nanoSecond: aTime nanoSecond
		offset: self localOffset.! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
yesterday

	^ self today asDate previous asDateAndTime! !

!DateAndTime class methodsFor: 'instance creation queries' stamp: ''!
epoch
  "Answer a DateAndTime representing the epoch: 1 January 1901"

  ^ (self julianDayNumber: SqueakEpoch) offset: 0.! !

!DateAndTime class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
readOptionalSeparatorFrom: stream
	"Read an optional separator (non decimal digit) from stream and return it.
	Return nil if nothing was read"

	| isDigit |
	stream atEnd
		ifTrue: [ ^ nil ].
	isDigit := '0123456789' includes: stream peek.
	(isDigit or: [ ':' includes: stream peek ])
		ifFalse: [ ^ nil ].
	isDigit
		ifFalse: [ stream next ]! !

!DateAndTime class methodsFor: 'time zones' stamp: ''!
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').
	"

	LocalTimeZoneCache := aTimeZone! !

!DateAndTimeDosEpochTest commentStamp: ''!
SUnit test for dos epoch (see DateAndTime)!
!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testYesterday
	self deny: aDateAndTime equals: DateAndTime yesterday! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testAsSeconds
	self assert: aDateAndTime asSeconds equals: 2492985600! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testDaysLeftInYear
	self assert: aDateAndTime daysLeftInYear equals: 365! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testToBy
	self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days) equals: 
				((DateAndTime year: 1980 month: 1 day: 1) to:
				 (DateAndTime year: 1980 month: 1 day: 1) + 10 days by: 5 days)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testFirstDayOfMonth
	self assert: aDateAndTime firstDayOfMonth equals: 1! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testTicksOffset
	self assert: aDateAndTime equals: (aDateAndTime ticks:  #(2444240 0 0) offset: DateAndTime localOffset)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testFromSeconds
	self assert: aDateAndTime equals: (DateAndTime fromSeconds: 2492985600)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testHour12
	self assert: aDateAndTime hour12 equals: DateAndTime new hour12.
	self assert: aDateAndTime hour12 equals: 12! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testDayOfWeek
	self assert: aDateAndTime dayOfWeek equals: 3.
	self assert: aDateAndTime dayOfWeekAbbreviation equals: 'Tue'.
	self assert: aDateAndTime dayOfWeekName equals: 'Tuesday'! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testSeconds
	self assert: aDateAndTime seconds equals: 0! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testAsDuration
	self assert: aDateAndTime asDuration equals: 0 asDuration! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testHash
	self assert: aDateAndTime hash equals: (DateAndTime year: 1980 month: 1 day: 1) hash! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testNow
	self deny: aDateAndTime equals: (DateAndTime now)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testMeridianAbbreviation
	self assert: aDateAndTime meridianAbbreviation equals: 'AM'! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testNoon
	self assert: aDateAndTime noon equals: '1980-01-01T12:00:00+00:00' asDateAndTime! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testLessThan
	self assert: aDateAndTime  < (aDateAndTime + '1:00:00:00').
	self assert: aDateAndTime + -1 < aDateAndTime! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testPrintOn
	self assert: (String streamContents: [ :str | aDateAndTime printOn: str ]) equals: '1980-01-01T00:00:00+00:00'.
	self assert: (String streamContents: [ :str | aTimeZone printOn: str ]) equals: 'a TimeZone(DTZ)'! !

!DateAndTimeDosEpochTest methodsFor: 'running' stamp: ''!
tearDown
     "wish I could remove the time zones I added earlier, but there is no method for that"

     DateAndTime localTimeZone: localTimeZoneToRestore.
	  super tearDown! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testDayOfYear
	self assert: aDateAndTime dayOfYear equals: 1! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testJulianDayNumber
	self assert: aDateAndTime equals: (DateAndTime julianDayNumber: 2444240).
	self assert: aDateAndTime julianDayNumber equals: 2444240! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testMidnight
	self assert: aDateAndTime midnight equals: aDateAndTime! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testCurrent
	self deny: aDateAndTime equals: (DateAndTime current)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testToday
	self deny: aDateAndTime equals: DateAndTime today! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testHour
	self assert: aDateAndTime hour equals: aDateAndTime hour24.
	self assert: aDateAndTime hour equals: 0.
	self assert: aDateAndTime hour equals: aDateAndTime hours! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testFromString
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1980-01-01T00:00:00+00:00').
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1980-01-01T00:00:00').
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1980-01-01T00:00').
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1980-01-01T00:00:00+00:00')! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testEpoch
	self assert: aDateAndTime equals: '1980-01-01T00:00:00+00:00' asDateAndTime! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testMinus
	self assert: aDateAndTime - aDateAndTime equals: '0:00:00:00' asDuration.
	self assert: aDateAndTime - '0:00:00:00' asDuration equals: aDateAndTime.
	self assert: aDateAndTime - aDuration equals: (DateAndTime year: 1979 month: 12 day: 30 hour: 21 minute: 56 second: 55 nanoSecond: 999999995 offset: 0 hours)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testTo
	self assert: (aDateAndTime to: aDateAndTime) equals: ((DateAndTime year: 1980 month: 1 day: 1) to: (DateAndTime year: 1980 month: 1 day: 1))! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testYear
	self assert: aDateAndTime year equals: 1980! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testSecond
	self assert: aDateAndTime second equals: 0! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testYearMonthDay
	self assert: aDateAndTime equals: (DateAndTime year: 1980 month: 1 day: 1)! !

!DateAndTimeDosEpochTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsWeek
	self assert: aDateAndTime asWeek equals: (Week starting: '12-31-1979' asDate)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testAsDate
	self assert: aDateAndTime asDate equals: 'January 1, 1980' asDate! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testAsNanoSeconds
	self assert: aDateAndTime asNanoSeconds equals: 0 asDuration asNanoSeconds! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testDateTime
	self assert: aDateAndTime equals: (DateAndTime date: '01-01-1980' asDate time: '00:00:00' asTime)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testAsDateAndTime
	self assert: aDateAndTime asDateAndTime equals: aDateAndTime! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testMonth
	self assert: aDateAndTime month equals: 1.
	self assert: aDateAndTime monthAbbreviation equals: 'Jan'.
	self assert: aDateAndTime monthName equals: 'January'.
	self assert: aDateAndTime monthIndex equals: 1! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testDaysInYear
	self assert: aDateAndTime daysInYear equals: 366! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testDay
	self assert: aDateAndTime day equals: DateAndTime new day! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testAsLocal
	self assert: aDateAndTime asLocal equals: aDateAndTime.
	self assert: aDateAndTime asLocal equals: (aDateAndTime offset: aDateAndTime class localOffset)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testYearMonthDayHourMinuteSecond
	self assert: aDateAndTime equals: (DateAndTime year: 1980 month: 1 day: 1 hour: 0 minute: 0 second: 0)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testAsUTC
	self assert: aDateAndTime asUTC equals: aDateAndTime! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testUtcOffset
     self assert: (aDateAndTime offset: '0:12:00:00')  equals: '1980-01-01T12:00:00+12:00' asDateAndTime! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testNanoSecond
	self assert: aDateAndTime nanoSecond equals: 0! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testToByDo
	| schedule |
	schedule := aDateAndTime to: aDateAndTime + 10 days by: 5 days do: [:i | ].
	self 
		assert: schedule notNil;
		assert: schedule duration equals: 10 days! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testTimeZone
	self assert: aDateAndTime timeZoneName equals: 'Universal Time'.
	self assert: aDateAndTime timeZoneAbbreviation	 equals: 'UTC'! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testPlus
	self assert: aDateAndTime + '0:00:00:00' equals: aDateAndTime.
	self assert: aDateAndTime + 0 equals: aDateAndTime.
	self assert: aDateAndTime + aDuration equals: (DateAndTime year: 1980 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours)! !

!DateAndTimeDosEpochTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsYear
	self assert: aDateAndTime asYear equals: (Year starting: '01-01-1980' asDate)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testMiddleOf
	self assert: (aDateAndTime middleOf: '2:00:00:00' asDuration) 
	     equals: (Timespan starting: '12-31-1979' asDate duration: 2 days)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testIsLeapYear
	self assert: aDateAndTime isLeapYear! !

!DateAndTimeDosEpochTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	localTimeZoneToRestore := DateAndTime localTimeZone.
	aDateAndTime :=  DateAndTime localTimeZone: TimeZone default; dosEpoch.
	aTimeZone := TimeZone offset: (Duration minutes: 135) name: 'DOS Epoch Test Time Zone' abbreviation: 'DTZ'.
	aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testYearDay
	self assert: aDateAndTime equals: (DateAndTime year: 1980 day: 1)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testAsTime
	self assert: aDateAndTime asTime equals: Time midnight! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testMinute
	self assert: aDateAndTime minute equals: 0! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testTommorrow
	self assert: DateAndTime today + 24 hours equals: DateAndTime tomorrow.
	self deny: aDateAndTime equals: DateAndTime tomorrow! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testYearDayHourMinuteSecond
	self assert: aDateAndTime equals: (DateAndTime year: 1980 day: 1 hour: 0 minute: 0 second: 0)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testDayMonthYearDo
	|iterations|
	iterations := 0.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  iterations := iterations + 1]) equals: 1.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachYear]) equals: 1980.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachMonth]) equals: 1.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachDay]) equals: 1! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testOffset

	self assert: aDateAndTime offset equals: '0:00:00:00' asDuration.
	self assert: (aDateAndTime offset: '-0:12:00:00') equals: '1979-12-31T12:00:00-12:00' asDateAndTime.
	self assert: (aDateAndTime offset: '0:12:00:00') equals: '1980-01-01T12:00:00+12:00' asDateAndTime! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testMinutes
	self assert: aDateAndTime minutes equals: 0! !

!DateAndTimeDosEpochTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsMonth
	self
		assert: aDateAndTime asMonth 
		equals: (Month year: 1980 month: 'January')! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testDaysInMonth
	self assert: aDateAndTime daysInMonth equals: 31! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testDuration
	self assert: aDateAndTime duration equals: 0 asDuration! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testDayOfMonth
	self assert: aDateAndTime dayOfMonth equals: 1! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testTicks
	self assert: aDateAndTime ticks equals: (DateAndTime julianDayNumber: 2444240) ticks.
	self assert: aDateAndTime ticks equals: #(2444240 0 0)! !

!DateAndTimeDosEpochTest methodsFor: 'tests' stamp: ''!
testYearMonthDayHourMinuteSecondNanosSecondOffset
	self assert: aDateAndTime equals: (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) ) equals:  	
				(DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours)! !

!DateAndTimeEpochTest commentStamp: ''!
I represent one of several Sunit test Cases intentended to provide complete coverage  for the Chronology set of classes as part of the external testing. The other Chronology sunit test cases are:
 DateTestCase
 DateAndTimeLeapTestCase,
 DurationTestCase,
 ScheduleTestCase
 TimeStampTestCase
 TimespanDoTestCase, 
 TimespanDoSpanAYearTestCase, 
 TimespanTestCase, 
 YearMonthWeekTestCase.  
These tests attempt to exercise all public and private methods.  Except, they do not explicitly depreciated methods. tlk
My fixtures are:
aDateAndTime = January 01, 1901 midnight (the start of the Squeak epoch) with localTimeZone = Grenwhich Meridian (local offset = 0 hours)
aDuration = 1 day, 2 hours, 3, minutes, 4 seconds and 5 nano seconds.
aTimeZone =  'Epoch Test Time Zone', 'ETZ' , offset: 12 hours, 15 minutes. !
!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testYesterday
	self deny: aDateAndTime equals: DateAndTime yesterday! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testAsSeconds
	self assert: aDateAndTime asSeconds equals: 0 asDuration asSeconds! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testDaysLeftInYear
	self assert: aDateAndTime daysLeftInYear equals: 364! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testToBy
	self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days) equals: (DateAndTime new to: DateAndTime new + 10 days by: 5 days)
	"MessageNotUnderstood: UndefinedObject>>starting:ending:  where UndefinedObject is Timespan "! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testFirstDayOfMonth
	self assert: aDateAndTime firstDayOfMonth equals: 1! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testTicksOffset
	self assert: aDateAndTime equals: (aDateAndTime ticks: #(2415386 0 0) offset: DateAndTime localOffset)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testFromSeconds
	self assert: aDateAndTime equals: (DateAndTime fromSeconds: 0)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testHour12
	self assert: aDateAndTime hour12 equals: DateAndTime new hour12.
	self assert: aDateAndTime hour12 equals: 12! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testDayOfWeek
	self assert: aDateAndTime dayOfWeek equals: 3.
	self assert: aDateAndTime dayOfWeekAbbreviation equals: 'Tue'.
	self assert: aDateAndTime dayOfWeekName equals: 'Tuesday'! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testSeconds
	self assert: aDateAndTime seconds equals: 0! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testAsDuration
	self assert: aDateAndTime asDuration equals: 0 asDuration! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testHash
	self assert: aDateAndTime hash equals: DateAndTime new hash! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testNow
	self deny: aDateAndTime equals: DateAndTime now! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testMeridianAbbreviation
	self assert: aDateAndTime meridianAbbreviation equals: 'AM'! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testNoon
	self assert: aDateAndTime noon equals: '1901-01-01T12:00:00+00:00' asDateAndTime! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testLessThan
	self assert: aDateAndTime  < (aDateAndTime + '1:00:00:00').
	self assert: aDateAndTime + -1 < aDateAndTime.! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testPrintOn
	self assert: (String streamContents: [ :str | aDateAndTime printOn: str ]) equals: '1901-01-01T00:00:00+00:00'.
	self assert: (String streamContents: [ :str | aTimeZone printOn: str ]) equals: 'a TimeZone(ETZ)'! !

!DateAndTimeEpochTest methodsFor: 'running' stamp: ''!
tearDown
     DateAndTime localTimeZone: localTimeZoneToRestore.
     super tearDown! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testDayOfYear
	self assert: aDateAndTime dayOfYear equals: 1! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testJulianDayNumber
	self assert: aDateAndTime equals: (DateAndTime julianDayNumber: 2415386).
	self assert: aDateAndTime julianDayNumber equals: 2415386! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testMidnight
	self assert: aDateAndTime midnight equals: aDateAndTime! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testCurrent
	self deny: aDateAndTime equals: DateAndTime current! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testToday
	self deny: aDateAndTime equals: DateAndTime today! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testHour
	self assert: aDateAndTime hour equals: aDateAndTime hour24.
	self assert: aDateAndTime hour equals: 0.
	self assert: aDateAndTime hour equals: aDateAndTime hours! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testFromString
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00').
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1901-01-01T00:00:00').
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1901-01-01T00:00').
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00')! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testEpoch
	self assert: aDateAndTime equals: '1901-01-01T00:00:00+00:00' asDateAndTime! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testMinus
	self assert: aDateAndTime - aDateAndTime equals: '0:00:00:00' asDuration.
	self assert: aDateAndTime - '0:00:00:00' asDuration equals: aDateAndTime.
	self
		assert: aDateAndTime - aDuration
		equals:
			(DateAndTime
				year: 1900
				month: 12
				day: 30
				hour: 21
				minute: 56
				second: 55
				nanoSecond: 999999995
				offset: 0 hours)
	" I believe this Failure is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testTo
	self assert: (aDateAndTime to: aDateAndTime) equals: (DateAndTime new to: DateAndTime new)
	"MessageNotUnderstood: UndefinedObject>>starting:ending:  where UndefinedObject is Timespan "! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testYear
	self assert: aDateAndTime year equals: 1901! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testSecond
	self assert: aDateAndTime second equals: 0! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testYearMonthDay
	self assert: aDateAndTime equals: (DateAndTime year: 1901 month: 1 day: 1)! !

!DateAndTimeEpochTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsWeek
	self assert: aDateAndTime asWeek equals: (Week starting: '12-31-1900' asDate)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testAsDate
	self assert: aDateAndTime asDate equals: 'January 1, 1901' asDate! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testAsNanoSeconds
	self assert: aDateAndTime asNanoSeconds equals: 0 asDuration asNanoSeconds! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testDateTime
	self assert: aDateAndTime equals: (DateAndTime date: '01-01-1901' asDate time: '00:00:00' asTime)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testAsDateAndTime
	self assert: aDateAndTime asDateAndTime equals: aDateAndTime! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testMonth
	self assert: aDateAndTime month equals: 1.
	self assert: aDateAndTime monthAbbreviation equals: 'Jan'.
	self assert: aDateAndTime monthName equals: 'January'.
	self assert: aDateAndTime monthIndex equals: 1! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testDaysInYear
	self assert: aDateAndTime daysInYear equals: 365! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testNew
	self assert: aDateAndTime equals: DateAndTime new! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testDay
	self assert: aDateAndTime day equals: DateAndTime new day! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testAsLocal
	self assert: aDateAndTime asLocal equals: aDateAndTime.
	self assert: aDateAndTime asLocal equals: (aDateAndTime offset: aDateAndTime class localOffset)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testYearMonthDayHourMinuteSecond
	self
		assert: aDateAndTime
		equals:
			(DateAndTime
				year: 1901
				month: 1
				day: 1
				hour: 0
				minute: 0
				second: 0)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testAsUTC
	self assert: aDateAndTime asUTC equals: aDateAndTime! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testUtcOffset
	self assert: (aDateAndTime offset: '0:12:00:00') equals: '1901-01-01T12:00:00+12:00' asDateAndTime! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testNanoSecond
	self assert: aDateAndTime nanoSecond equals: 0! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testToByDo
	"self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days do: []) =  "
	"MessageNotUnderstood: UndefinedObject>>starting:ending:  where UndefinedObject is Timespan "! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testTimeZone
	self assert: aDateAndTime timeZoneName equals: 'Universal Time'.
	self assert: aDateAndTime timeZoneAbbreviation equals: 'UTC'! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testPlus
	self assert: aDateAndTime + '0:00:00:00' equals: aDateAndTime.
	self assert: aDateAndTime + 0 equals: aDateAndTime.
	self
		assert: aDateAndTime + aDuration
		equals:
			(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: '*Kernel-Tests-Extended' stamp: ''!
testAsYear
	self assert: aDateAndTime asYear equals: (Year starting: '01-01-1901' asDate)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testMiddleOf
	self assert: (aDateAndTime middleOf: '2:00:00:00' asDuration) equals: (Timespan starting: '12-31-1900' asDate duration: 2 days)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testIsLeapYear
	self deny: aDateAndTime isLeapYear! !

!DateAndTimeEpochTest methodsFor: 'running' stamp: ''!
setUp
 	super setUp.  
	localTimeZoneToRestore := DateAndTime localTimeZone.
	aDateAndTime :=  DateAndTime localTimeZone: TimeZone default; epoch.
	aTimeZone := TimeZone offset: (Duration minutes: 135) name: 'Epoch Test Time Zone' abbreviation: 'ETZ'.
	aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testYearDay
	self assert: aDateAndTime equals: (DateAndTime year: 1901 day: 1)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testAsTime
	self assert: aDateAndTime asTime equals: Time midnight! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testMinute
	self assert: aDateAndTime minute equals: 0! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testTommorrow
	self assert: DateAndTime today + 24 hours equals: DateAndTime tomorrow.
	self deny: aDateAndTime equals: DateAndTime tomorrow
	"MessageNotUnderstood: Date class>>starting:"! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testYearDayHourMinuteSecond
	self
		assert: aDateAndTime
		equals:
			(DateAndTime
				year: 1901
				day: 1
				hour: 0
				minute: 0
				second: 0)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testDayMonthYearDo
	| iterations |
	iterations := 0.
	self assert: (aDateAndTime dayMonthYearDo: [ :eachDay :eachMonth :eachYear | iterations := iterations + 1 ]) equals: 1.
	self assert: (aDateAndTime dayMonthYearDo: [ :eachDay :eachMonth :eachYear | eachYear ]) equals: 1901.
	self assert: (aDateAndTime dayMonthYearDo: [ :eachDay :eachMonth :eachYear | eachMonth ]) equals: 1.
	self assert: (aDateAndTime dayMonthYearDo: [ :eachDay :eachMonth :eachYear | eachDay ]) equals: 1! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testOffset
	self assert: aDateAndTime offset equals: '0:00:00:00' asDuration.
	self assert: (aDateAndTime offset: '-0:12:00:00') equals: '1900-12-31T12:00:00-12:00' asDateAndTime.
	self assert: (aDateAndTime offset: '0:12:00:00') equals: '1901-01-01T12:00:00+12:00' asDateAndTime! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testMinutes
	self assert: aDateAndTime minutes equals: 0! !

!DateAndTimeEpochTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsMonth
	self 
		assert: aDateAndTime asMonth
		equals: (Month year: 1901 month: 'January').! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testDaysInMonth
	self assert: aDateAndTime daysInMonth equals: 31! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testDuration
	self assert: aDateAndTime duration equals: 0 asDuration! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testDayOfMonth
	self assert: aDateAndTime dayOfMonth equals: 1! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testTicks
	self assert: aDateAndTime ticks equals: (DateAndTime julianDayNumber: 2415386) ticks.
	self assert: aDateAndTime ticks equals: #(2415386 0 0)! !

!DateAndTimeEpochTest methodsFor: 'tests' stamp: ''!
testYearMonthDayHourMinuteSecondNanosSecondOffset
	self
		assert: aDateAndTime
		equals:
			(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)
		equals:
			(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:)"! !

!DateAndTimeLeapTest commentStamp: ''!
I represent one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes. 

My fixtures are:
aDateAndTime = February 29, 2004 1:33 PM with offset: 2 hours
aDuration = 15 days, 14 hours, 13 minutes, 12 seconds and 11 nano seconds.
aTimeZone = Grenwhich Meridian (local offset = 0 hours) !
!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testAsLocal
	self assert: aDateAndTime asLocal equals: aDateAndTime.
	self assert: aDateAndTime asLocal equals: (aDateAndTime offset: aDateAndTime class localOffset)! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testYearMonthDayHourMinuteSecond
	self assert: aDateAndTime equals: (DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0 offset: 2 hours)! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testAsSeconds
	self assert: aDuration asSeconds equals: 48780.
	self assert: aDateAndTime asSeconds equals: 3255507180.! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testDaysLeftInYear
	self assert: aDateAndTime daysLeftInYear equals: 306! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testAsUTC
	self assert: aDateAndTime asUTC equals: aDateAndTime! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testUtcOffset
     self assert: (aDateAndTime offset: '0:02:00:00') equals: '2004-02-29T13:33:00+02:00' asDateAndTime! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testNanoSecond
	self assert: aDateAndTime nanoSecond equals: 0! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testFirstDayOfMonth
	self deny: aDateAndTime firstDayOfMonth equals: 1.
	self assert: aDateAndTime firstDayOfMonth equals: 32! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testTimeZone
	aDateAndTime := '2004-02-29T13:33:00+00:00' asDateAndTime.
	self assert: aDateAndTime timeZone name equals: 'Universal Time'.
	self assert: aDateAndTime timeZone abbreviation 	equals: 'UTC'! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testTicksOffset
	self assert: aDateAndTime equals: (aDateAndTime ticks:  #(2453065 48780 0) offset: DateAndTime localOffset)! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testHour12
	self assert: aDateAndTime hour12 equals: 1! !

!DateAndTimeLeapTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsYear
	"A year always starts at January 1"
	self 
		assert: aDateAndTime asYear
		equals: ((Year starting: '02-29-2004' asDate) translateTo: 2 hours ).  
	self
		assert: aDateAndTime asYear
		equals: ((Year starting: '01-01-2004' asDate) translateTo: 2 hours)! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testMiddleOf
	self assert: (aDateAndTime middleOf: aDuration) 
		  equals: 
	 (Timespan starting: (DateAndTime year: 2004 month: 2 day: 29 hour: 6 minute: 46 second: 30 offset: 2 hours)
				  duration: (Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 ))! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testDayOfWeek
	self assert: aDateAndTime dayOfWeek equals: 1.
	self assert: aDateAndTime dayOfWeekAbbreviation equals: 'Sun'.
	self assert: aDateAndTime dayOfWeekName equals: 'Sunday'! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testSeconds
	self assert: aDateAndTime seconds equals: 0! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testAsDuration
	self assert: aDateAndTime asDuration equals: aDuration! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testMeridianAbbreviation
	self assert: aDateAndTime meridianAbbreviation equals: 'PM'! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testIsLeapYear
	self assert: aDateAndTime isLeapYear! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testLessThan
	self assert: aDateAndTime < (aDateAndTime + '1:00:00:00').
	self assert: aDateAndTime + -1 < aDateAndTime! !

!DateAndTimeLeapTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	aDateAndTime := (DateAndTime 
		year: 2004 month: 2 day: 29 
		hour: 13 minute: 33 second: 0 
		offset: 2 hours).
	aTimeZone := TimeZone default.
	aDuration := Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testNoon
	self assert: aDateAndTime noon equals: '2004-02-29T12:00:00+02:00' asDateAndTime! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testAsTime
	self assert: aDateAndTime asTime equals: (Time hour: 13 minute: 33 second: 0)! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testDayOfYear
	self assert: aDateAndTime dayOfYear equals: 60! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testMidnight
	self assert: aDateAndTime midnight equals: '2004-02-29T00:00:00+02:00' asDateAndTime! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testMinute
	self assert: aDateAndTime minute equals: 33! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testPrintOn
	self assert: (String streamContents: [:str | aDateAndTime printOn: str ]) equals: '2004-02-29T13:33:00+02:00'.
	self assert: (String streamContents: [:str | aTimeZone printOn: str ]) equals: 'a TimeZone(UTC)'! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testHour
	self assert: aDateAndTime hour equals: aDateAndTime hour24.
	self assert: aDateAndTime hour equals: 13.
	self assert: aDateAndTime hour equals: aDateAndTime hours! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testFromString
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 2004-02-29T13:33:00+02:00')! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testYear
	self assert: aDateAndTime year equals: 2004! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testYearDayHourMinuteSecond
	self assert: aDateAndTime equals: (DateAndTime year: 2004 day: 60 hour: 13 minute: 33 second: 0 offset: 2 hours).! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testSecond
	self assert: aDateAndTime second equals: 0! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testDayMonthYearDo
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachYear]) equals: 2004.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachMonth]) equals: 2.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachDay]) equals: 29! !

!DateAndTimeLeapTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsWeek
	self assert: aDateAndTime asWeek equals: ((Week starting: '02-29-2004' asDate) translateTo: 2 hours).! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testOffset

	self assert: aDateAndTime offset equals: '0:02:00:00' asDuration.
	self assert: (aDateAndTime offset: '-0:12:00:00') equals: '2004-02-28T23:33:00-12:00' asDateAndTime.
	self assert: (aDateAndTime offset: '0:12:00:00') equals:  '2004-02-29T23:33:00+12:00' asDateAndTime! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testAsDate
	self assert: aDateAndTime asDate equals:  ('February 29, 2004' asDate translateTo: 2 hours).! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testAsNanoSeconds
	self assert: aDateAndTime asNanoSeconds equals: aDuration asNanoSeconds.
	self assert: aDateAndTime asNanoSeconds equals: 48780000000000! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testMinutes
	self assert: aDateAndTime minutes equals: 33! !

!DateAndTimeLeapTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsMonth
	self
		assert: aDateAndTime asMonth
		equals: ((Month year: 2004 month: 'February') translateTo: 2 hours).! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testDaysInMonth
	self assert: aDateAndTime daysInMonth equals: 29! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testMonth
	self assert: aDateAndTime month equals: 2.
	self assert: aDateAndTime monthAbbreviation equals: 'Feb'.
	self assert: aDateAndTime monthName equals: 'February'.
	self assert: aDateAndTime monthIndex equals: 2! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testDayOfMonth
	self assert: aDateAndTime dayOfMonth equals: 29! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testDaysInYear
	self assert: aDateAndTime daysInYear equals: 366! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testTicks
	self 
		assert: aDateAndTime ticks  
		equals: ((DateAndTime julianDayNumber: 2453065) + 41580 seconds) ticks.
	self 
		assert: aDateAndTime ticks 
		equals:  #(2453065 41580 0)! !

!DateAndTimeLeapTest methodsFor: 'tests' stamp: ''!
testDay
	self assert: aDateAndTime day equals: 60. 
	self deny: aDateAndTime day equals: 29! !

!DateAndTimeTest commentStamp: ''!
SUnit tests for date and time!
!DateAndTimeTest methodsFor: 'tests' stamp: ''!
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 equals: localMoscowTimeFromDenotation! !

!DateAndTimeTest methodsFor: 'helpers' stamp: ''!
useNonUtcTimeZoneDuring: aBlock

	self useTimeZone: 'EDT' during: aBlock.! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
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 equals: 0.
	self assert: twoPmInLondon equals: nineAmInDetroit! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
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 - offset' stamp: ''!
testReadTimeZoneOffsetRFC822
	"See https://pharo.manuscript.com/f/cases/17693
	 See RFC822 : https://www.w3.org/Protocols/rfc822"

	self
		assert: (DateAndTime readTimezoneOffsetFrom: '+0530' readStream) printString
		equals: '0:05:30:00'! !

!DateAndTimeTest methodsFor: 'tests - instance' stamp: ''!
testInstanceCreationFromADateAndATime

	| date time instance |
	date := Date today.
	time := Time now.
	instance := DateAndTime date: date time: time.
	self assert: instance asDate equals: date.
	self assert: instance asTime equals: time.! !

!DateAndTimeTest methodsFor: 'coverage' stamp: ''!
selectorsToBeIgnored

	| private | 
	private := #( #printOn: ).
	^ super selectorsToBeIgnored, private! !

!DateAndTimeTest methodsFor: 'tests - instance' stamp: ''!
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 equals: 1721427;
		assert: t offset equals: 6 hours;
		assert: t hour equals: 2;
		assert: t minute equals: 3;
		assert: t second equals: 4;
		assert: t nanoSecond equals: 5! !

!DateAndTimeTest methodsFor: 'tests - offset' stamp: ''!
testReadFromUTCOffset	
	self assert: (DateAndTime readFrom: '2010-01-05T20:33:14.321Z' readStream) offset isZero.
	self assert: (DateAndTime readFrom: '2010-01-05T20:33:14.321+00' readStream) offset isZero.
	self assert: (DateAndTime readFrom: '2010-01-05T20:33:14.321+0000' readStream) offset isZero.
	self assert: (DateAndTime readFrom: '2010-01-05T20:33:14.321+00:00' readStream) offset isZero.! !

!DateAndTimeTest methodsFor: 'tests - offset' stamp: ''!
testReadTimeZoneOffsetRFC822WithOtherCharactersAfter
	"See https://pharo.manuscript.com/f/cases/17693"
	
	self
		assert: (DateAndTime readTimezoneOffsetFrom: '+0530 CommiterName' readStream) printString
		equals: '0:05:30:00'! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
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: ''!
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 equals: '2004-11-02T14:03:05.000012345+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:45+00:00' asDateAndTime 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 printString equals: '2002-05-16T17:20:45-02:34'.
	self assert: '2002-05-16T17:20:45+00:00' asDateAndTime printString equals: '2002-05-16T17:20:45+00:00'.
	self assert: '1997-04-26T01:02:03+01:02:3' asDateAndTime printString equals: '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 - epoch' stamp: ''!
testDosEpoch
	self
		useNonUtcTimeZoneDuring: [ | localEpoch |
			localEpoch := '1 January 1980 00:00' asDateAndTime.
			self deny: DateAndTime dosEpoch equals: localEpoch ].

	self
		useTimeZone: 'UTC'
		during: [ | localEpoch |
			localEpoch := '1 January 1980 00:00' asDateAndTime.
			self assert: DateAndTime dosEpoch equals: localEpoch ].

	self assert: DateAndTime dosEpoch equals: '1980-01-01T00:00:00+00:00' asDateAndTime! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
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 equals: nineAmInDetroit! !

!DateAndTimeTest methodsFor: 'helpers' stamp: ''!
restoreLocalTimeZoneAfter: aBlock

	| realTimeZone |
	realTimeZone := DateAndTime localTimeZone.
	aBlock ensure: [ DateAndTime localTimeZone: realTimeZone ].! !

!DateAndTimeTest methodsFor: 'tests - under design' stamp: ''!
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
		equals: ('2002-05-16T17:20:00{1}{2}:{3}' format: {signString . localOffsetHours . localOffsetMinutes}).
	self
		assert: '2002-05-16T17:20:45' asDateAndTime printString
		equals: ('2002-05-16T17:20:45{1}{2}:{3}' format: {signString . localOffsetHours . localOffsetMinutes})! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
testFromString
	| fromString fromStringNoOffset |
	fromString := DateAndTime fromString: '-1199-01-05T20:33:14.321-05:00'.
	self assert: fromString printString equals: '-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 equals: DateAndTime localOffset! !

!DateAndTimeTest methodsFor: 'tests - epoch' stamp: ''!
testPharoEpoch
	self
		useNonUtcTimeZoneDuring: [ | localEpoch |
			localEpoch := '1901-01-01T00:00:00' asDateAndTime.
			self deny: DateAndTime epoch equals: localEpoch.
			self deny: ((DateAndTime fromSeconds: 0) offset: 0) equals: localEpoch ].

	self
		useTimeZone: 'UTC'
		during: [ | localEpoch |
			localEpoch := '1901-01-01T00:00:00' asDateAndTime.
			self assert: DateAndTime epoch equals: localEpoch.
			self assert: ((DateAndTime fromSeconds: 0) offset: 0) equals: localEpoch ].

	self assert: DateAndTime epoch equals: '1901-01-01T00:00:00+00:00' asDateAndTime.
	self assert: ((DateAndTime fromSeconds: 0) offset: 0) equals: '1901-01-01T00:00:00+00:00' asDateAndTime! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
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 equals: 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: ''!
testSecondsRoundTrip
	| now now2 |
	now := DateAndTime fromSeconds: 0.
	now2 := DateAndTime fromSeconds: now asSeconds.
	self assert: now equals: now2.! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
testYearMonth
	
	self assert: ((DateAndTime year: 2018 month: 9) asDate asString) equals: '1 September 2018'.! !

!DateAndTimeTest methodsFor: 'tests - under design' stamp: ''!
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 equals: t2.
	self deny: t2 equals: t1! !

!DateAndTimeTest methodsFor: 'tests - offset' stamp: ''!
testReadFromDefaultOffsetNotSpecified

	self assert: (DateAndTime readFrom: '2016-07-03T21:16:16.708241' readStream defaultOffset: Duration zero) offset equals: Duration zero.! !

!DateAndTimeTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ DateAndTime! !

!DateAndTimeTest methodsFor: 'tests - under design' stamp: ''!
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 equals: t1.
	self assert: t1 equals: t2! !

!DateAndTimeTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsDateAndTime
	| localOffset localOffsetSuffix |
	#('-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+01:57' 
		'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+00:00'		 
 		'2002-05-16T17:20:45-02:34'
		'1997-04-26T01:02:03+01:02:3') do: [ :each | 
			self assert: each asDateAndTime printString equals: each ].
		
	localOffset := DateAndTime localOffset.
	localOffsetSuffix := String streamContents: [ :out |
		out nextPut: (localOffset positive ifTrue: [ $+ ] ifFalse: [ $- ]).
		localOffset hours abs printOn: out base: 10 length: 2 padded: true.
		out nextPut: $:.
		localOffset minutes abs printOn: out base: 10 length: 2 padded: true.
		localOffset seconds = 0 ifFalse: [ out nextPut: $: ; print: localOffset seconds rounded abs ] ].
	
	#('2002-05-16T17:20:45.00005' 
		'2002-05-16T17:20:00' 
		'2002-05-16T17:20:45') do: [ :each | 
			self assert: each asDateAndTime printString equals: each , localOffsetSuffix ].! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
testFromDos
	
	| aDateAndTime |
	aDateAndTime := DateAndTime fromDosTimestamp: 16r40B57856.
	self assert: aDateAndTime equals:  '21 May 2012 3:02:44 pm' asDateAndTime.
	
	"DOS times are in local time per http://blogs.msdn.com/b/oldnewthing/archive/2003/09/05/54806.aspx"
	self assert: aDateAndTime offset equals: DateAndTime localOffset! !

!DateAndTimeTest methodsFor: 'tests - bogus date' stamp: ''!
testErrorWhenDayIsBeforeMonthStart
	self should: [ DateAndTime year: 2004 month: 2 day: -1 ] raise: Error.
	self should: [ DateAndTime year: 2004 month: 2 day: 0 ] raise: Error.
	DateAndTime year: 2004 month: 2 day: 1! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
testSecondsSinceMidnightLocalTime
	| dateAndTime |
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 0 minute: 0 second: 56 offset: 0 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: 56.
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 0 minute: 1 second: 56 offset: 0 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: 60+56.
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 0 second: 56 offset: 0 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: 3600+56.
	
	"1 hour offset"
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 0 minute: 0 second: 56 offset: 1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: 56.
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 0 minute: 1 second: 56 offset: 1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: 60+56.
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 0 second: 56 offset: 1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: 3600+56.
	
	"-1 hour offset"
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 0 minute: 0 second: 56 offset: -1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: 56.
	
	dateAndTime := DateAndTime year: 1001 day: 101 hour: 0 minute: 1 second: 56 offset: -1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: 60+56.
	
	dateAndTime := DateAndTime year: 1002 day: 102 hour: 1 minute: 0 second: 56 offset: -1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: 3600+56.! !

!DateAndTimeTest methodsFor: 'tests - offset' stamp: ''!
testReadTimeZoneOffsetISO822WithOtherCharactersAfter
	"See https://pharo.manuscript.com/f/cases/17693/"

	self assert: (DateAndTime readTimezoneOffsetFrom: '+05:30 CommiterName' readStream) printString equals: '0:05:30:00'! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
testSecondsSinceMidnightLocalTimeNormalization
	| dateAndTime|
	
	"Check offset: changes from times defined in UTC"
	dateAndTime := DateAndTime year: 1001 day: 101 hour: 0 minute: 1 second: 56 offset: 0 hours.
	dateAndTime := dateAndTime offset: 1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: (1*3600) + (1*60) + 56.
	"-1 hours will switch to the previous day"
	dateAndTime := dateAndTime offset: -1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: (23*3600) + (1*60) + 56.
	
	dateAndTime := DateAndTime year: 1001 day: 101 hour: 23 minute: 1 second: 56 offset: 0 hours.
	dateAndTime := dateAndTime offset: 1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: (0*3600) + (1*60) + 56.
	"-1 hours will switch to the next day"
	dateAndTime := dateAndTime offset: -1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: 22*3600 + (1*60) + 56.	
		
		
	
	"Check offset: changes from times defined in +1"
	dateAndTime := DateAndTime year: 1001 day: 101 hour: 0 minute: 1 second: 56 offset: 1 hours.
	dateAndTime := dateAndTime offset: 2 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: (1*3600) + (1*60) + 56.
	"0 hours will switch to the previous day"
	dateAndTime := dateAndTime offset: 0 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: (23*3600) + (1*60) + 56.
	dateAndTime := dateAndTime offset: -1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: (22*3600) + (1*60) + 56.
	
	
	dateAndTime := DateAndTime year: 1001 day: 101 hour: 23 minute: 1 second: 56 offset: 1 hours.
	"+2 hours will switch to the next day"
	dateAndTime := dateAndTime offset: 2 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: (0*3600) + (1*60) + 56.
	dateAndTime := dateAndTime offset: 0 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: (22*3600) + (1*60) + 56.
	dateAndTime := dateAndTime offset: -1 hours.
	self assert: dateAndTime secondsSinceMidnightLocalTime equals: (21*3600) + (1*60) + 56.! !

!DateAndTimeTest methodsFor: 'tests - arithmetic' stamp: ''!
testSubstracting

	| t |
	t := '2004-01-07T11:55:00+00:00' asDateAndTime. 
	self assert: t - 5 equals: '2004-01-07T11:54:55+00:00' asDateAndTime! !

!DateAndTimeTest methodsFor: 'tests - offset' stamp: ''!
testReadTimeZoneOffsetISO
	"See https://pharo.manuscript.com/f/cases/17693 
	 See ISO 8601 offset format"

	self
		assert: (DateAndTime readTimezoneOffsetFrom: '+05:30' readStream) printString
		equals: '0:05:30:00'! !

!DateAndTimeTest methodsFor: 'tests - epoch' stamp: ''!
testUnixEpoch

	self assert: DateAndTime unixEpoch equals: '1 January 1970 00:00+00:00' asDateAndTime.! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
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: ''!
testDayOfWeekWithUTC
	| date |
	"Calculating the day of week should take into account the UTC offset"
	date := DateAndTime julianDayNumber: 2456385 offset:(Duration hours:2).
	"Internally, this date gets represented as the julian day 2456384 with seconds 79200 and offset 2 hours"
	"When asking for the day of week, the offset should be taken into account to return the correct day of week"
	self assert: date dayOfWeek equals: 3.! !

!DateAndTimeTest methodsFor: 'tests - under design' stamp: ''!
testPrintStringSecond	

	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:45+01:57' asDateAndTime printString equals: '2002-05-16T17:20:45+01:57'.
	self assert: ' 2002-05-16T17:20:45-02:34' asDateAndTime printString equals: '2002-05-16T17:20:45-02:34'.
	self assert: '2002-05-16T17:20:45+00:00' asDateAndTime printString equals: '2002-05-16T17:20:45+00:00'.
	self assert: '1997-04-26T01:02:03+01:02:3' asDateAndTime printString equals: '1997-04-26T01:02:03+01:02:3'! !

!DateAndTimeTest methodsFor: 'tests - offset' stamp: ''!
testReadFromDefaultOffsetSpecified

	self assert: (DateAndTime readFrom: '2016-07-03T21:16:16.708241+02:00' readStream defaultOffset: Duration zero) offset equals: (Duration hours: 2).! !

!DateAndTimeTest methodsFor: 'helpers' stamp: ''!
useTimeZone: abbreviation during: aBlock

  | timeZone |
  timeZone := TimeZone abbreviated: abbreviation.
  self restoreLocalTimeZoneAfter: [ 
    DateAndTime localTimeZone: timeZone. 
    aBlock cull: timeZone ].! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
testReadFromFoolProofExtension
	"Convenient extension without a time, only a date"

	self assert: (DateAndTime fuzzyReadFrom: '2008' readStream) printString equals: '2008-01-01T00:00:00+00:00'.
	self assert: (DateAndTime fuzzyReadFrom: '2008-08' readStream) printString equals: '2008-08-01T00:00:00+00:00'.
	self assert: (DateAndTime fuzzyReadFrom: '2006-08-28' readStream) printString equals: '2006-08-28T00:00:00+00:00'.
	"Regular nanoseconds"
	self assert: (DateAndTime fuzzyReadFrom: '2006-08-28T00:00:00.123456789' readStream) printString equals: '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 equals: '2006-08-28T00:00:00.123456789+00:00'! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
testAsTimeUTC
	| dateAndTime |
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: 0 asDuration.
	self assert: dateAndTime asTimeUTC equals: (Time hour: 1 minute: 2 second: 3).
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: -5 hours.
	self assert: dateAndTime asTimeUTC equals: (Time hour: 6 minute: 2 second: 3).
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: 5 hours.
	self assert: dateAndTime asTimeUTC equals: (Time hour: 24+1-5 minute: 2 second: 3).! !

!DateAndTimeTest methodsFor: 'tests - instance' stamp: ''!
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 equals: t hours;
		assert: t minutes equals: t minute;
		assert: t seconds equals: t second! !

!DateAndTimeTest methodsFor: 'tests - under design' stamp: ''!
testReadFromNoOffset
	
	self assert: (DateAndTime readFrom: '2010-01-05T20:33:14.321' readStream) offset equals: DateAndTime localOffset! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
testReadFromDateOnly
	self 
		assert: '2014-02-19' asDateAndTime translateToUTC printString
		equals: '2014-02-19T00:00:00+00:00'.
	self 
		assert: '2014-02-19Z' asDateAndTime printString
		equals: '2014-02-19T00:00:00+00:00'.
	self 
		assert: '2014-02-19T+07:00' asDateAndTime printString
		equals:  '2014-02-19T00:00:00+07:00'.
	self 
		assert: '2014-02-19 -05:00' asDateAndTime printString
		equals:  '2014-02-19T00:00:00-05:00'.! !

!DateAndTimeTest methodsFor: 'tests - offset' stamp: ''!
testReadTimeWithOtherCharactersAfter
	"See https://pharo.manuscript.com/f/cases/17693/"
	self
		assert:
			(DateAndTime
				readFrom:
					'2016-02-03 19:23:48 +0131 By: Esteban Lorenzano <estebanlm@gmail.com> Jenkins build #547'
						readStream) printString
		equals: '2016-02-03T19:23:48+01:31'! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
testAsTime
	| dateAndTime |
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: 0 asDuration.
	self assert: dateAndTime asTime equals: (Time hour: 1 minute: 2 second: 3).
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: 5 hours.
	self assert: dateAndTime asTime equals: (Time hour: 1 minute: 2 second: 3).
	
	dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: -5 hours.
	self assert: dateAndTime asTime equals: (Time hour: 1 minute: 2 second: 3).! !

!DateAndTimeTest methodsFor: 'tests - under design' stamp: ''!
testReflexive

	| t |
	t := DateAndTime 
			year: 1 month: 1 day: 2 
			hour: 2 minute: 3 second: 4 nanoSecond: 5 
			offset: 6 hours.
	self assert: t equals: t.! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
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 - offset' stamp: ''!
testReadFromOffset
		
	self assert: (DateAndTime readFrom: '-1199-01-05T20:33:14.321-05:00' readStream) offset printString equals: '-0:05:00:00'.! !

!DateAndTimeTest methodsFor: 'tests - offset' stamp: ''!
testReadFromSpaceBeforeOffset
	self assert: '2012-07-26 16:38:48 +0200' asDateAndTime offset equals: 2 hour.
	self assert: '2012-07-26 16:38:48 +02' asDateAndTime offset equals: 2 hour.! !

!DateAndTimeTest methodsFor: 'tests - under design' stamp: ''!
testTransitive	
	| t1 t2 t3 |
	t1 := DateAndTime 
			year: 1 month: 1 day: 2 
			hour: 2 minute: 3 second: 4 nanoSecond: 5 
			offset: 6 hours.
	t2 := DateAndTime 
			year: 1 month: 1 day: 2 
			hour: 2 minute: 3 second: 4 nanoSecond: 5 
			offset: 6 hours.
	t3 := DateAndTime 
			year: 1 month: 1 day: 2 
			hour: 2 minute: 3 second: 4 nanoSecond: 5 
			offset: 6 hours.
	self assert: ((t1 = t2) & (t2 = t3) ==> (t1 = t3)).! !

!DateAndTimeTest methodsFor: 'tests - bogus date' stamp: ''!
testErrorWhenDayIsAfterMonthEnd
	self should: [ DateAndTime year: 2004 month: 2 day: 30 ] raise: Error.
	DateAndTime year: 2004 month: 2 day: 29! !

!DateAndTimeTest methodsFor: 'tests - under design' stamp: ''!
testReadFromSecond
	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 printString equals: '2002-05-16T17:20:45-02:34'.
	self assert: '2002-05-16T17:20:45+00:00' asDateAndTime printString equals: '2002-05-16T17:20:45+00:00'.
	self assert: '1997-04-26T01:02:03+01:02:3' asDateAndTime printString equals: '1997-04-26T01:02:03+01:02:3'! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
testOffset
	| dateAndTime1 dateAndTime2 |
	dateAndTime1 := DateAndTime
		year: 1000
		day: 100
		hour: 1
		minute: 2
		second: 3
		offset: 1 hours.
	dateAndTime2 := dateAndTime1 offset: 1 hour.
	self assert: dateAndTime1 equals: dateAndTime2.
	self assert: dateAndTime1 localSeconds equals: dateAndTime2 localSeconds.

	dateAndTime2 := dateAndTime1 offset: -1 hour.
	self assert: dateAndTime1 equals: dateAndTime2.
	self deny: dateAndTime1 localSeconds identicalTo: dateAndTime2 localSeconds.

	dateAndTime2 := dateAndTime1 offset: -2 hour.
	self assert: dateAndTime1 equals: dateAndTime2.
	self deny: dateAndTime1 localSeconds identicalTo: dateAndTime2 localSeconds! !

!DateAndTimeTest methodsFor: 'tests - arithmetic' stamp: ''!
testArithmeticAcrossDateBoundary
	| t1 t2 |
	t1 := '2004-01-07T11:55:00+00:00' asDateAndTime.
	t2 := t1 - (42900 + 1) seconds.
	self assert: t2 equals: '2004-01-06T23:59:59+00:00' asDateAndTime! !

!DateAndTimeTest methodsFor: 'tests' stamp: ''!
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 equals: 0.
	self assert: thisMoment equals: thisMomentInMoscow! !

!DateAndTimeTest methodsFor: 'tests - arithmetic' stamp: ''!
testSubstracting02

	| t |
	t := '2004-01-07T11:55:00+00:00' asDateAndTime. 
	self assert: t - '2004-01-07T1:00:00+00:00' equals: (Duration fromString: '0:10:55:00')! !

!DateAndTimeTest methodsFor: 'tests - epoch' stamp: ''!
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 ].! !

!DateAndTimeUnixEpochTest commentStamp: ''!
Tests for unix epoch of DateAndTime!
!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testYesterday
	self deny: aDateAndTime equals: DateAndTime yesterday! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testAsSeconds
	self assert: aDateAndTime asSeconds equals: 2177452800! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testDaysLeftInYear
	self assert: aDateAndTime daysLeftInYear equals: 364! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testToBy
	self
		assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days)
		equals: ((DateAndTime year: 1970 month: 1 day: 1) to: (DateAndTime year: 1970 month: 1 day: 1) + 10 days by: 5 days)
	"MessageNotUnderstood: UndefinedObject>>starting:ending:  where UndefinedObject is Timespan "! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testFirstDayOfMonth
	self assert: aDateAndTime firstDayOfMonth equals: 1! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testTicksOffset
	self assert: aDateAndTime equals: (aDateAndTime ticks: #(2415386 0 0) offset: DateAndTime localOffset)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testFromSeconds
	self assert: aDateAndTime equals: (DateAndTime fromSeconds: 2177452800)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testHour12
	self assert: aDateAndTime hour12 equals: DateAndTime new hour12.
	self assert: aDateAndTime hour12 equals: 12! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testDayOfWeek
	self assert: aDateAndTime dayOfWeek equals: 5.
	self assert: aDateAndTime dayOfWeekAbbreviation equals: 'Thu'.
	self assert: aDateAndTime dayOfWeekName equals: 'Thursday'! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testSeconds
	self assert: aDateAndTime seconds equals: 0! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testAsDuration
	self assert: aDateAndTime asDuration equals: 0 asDuration! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testHash
	self assert: aDateAndTime hash equals: (DateAndTime year: 1970 month: 1 day: 1) hash! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testNow
	self deny: aDateAndTime equals: DateAndTime now! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testMeridianAbbreviation
	self assert: aDateAndTime meridianAbbreviation equals: 'AM'! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testNoon
	self assert: aDateAndTime noon equals: '1970-01-01T12:00:00+00:00' asDateAndTime! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testLessThan
	self assert: aDateAndTime  < (aDateAndTime + '1:00:00:00').
	self assert: aDateAndTime + -1 < aDateAndTime.! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testPrintOn
	self assert: (String streamContents: [ :str | aDateAndTime printOn: str ]) equals: '1970-01-01T00:00:00+00:00'.
	self assert: (String streamContents: [ :str | aTimeZone printOn: str ]) equals: 'a TimeZone(UTZ)'! !

!DateAndTimeUnixEpochTest methodsFor: 'running' stamp: ''!
tearDown
     DateAndTime localTimeZone: localTimeZoneToRestore.
     super tearDown! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testDayOfYear
	self assert: aDateAndTime dayOfYear equals: 1! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testJulianDayNumber
	self assert: aDateAndTime equals: (DateAndTime julianDayNumber: 2440588).
	self assert: aDateAndTime julianDayNumber equals: 2440588! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testMidnight
	self assert: aDateAndTime midnight equals: aDateAndTime! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testCurrent
	self deny: aDateAndTime equals: DateAndTime current! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testToday
	self deny: aDateAndTime equals: DateAndTime today! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testHour
	self assert: aDateAndTime hour equals: aDateAndTime hour24.
	self assert: aDateAndTime hour equals: 0.
	self assert: aDateAndTime hour equals: aDateAndTime hours! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testFromString
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1970-01-01T00:00:00+00:00').
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1970-01-01T00:00:00').
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1970-01-01T00:00').
	self assert: aDateAndTime equals: (DateAndTime fromString: ' 1970-01-01T00:00:00+00:00')! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testEpoch
	self assert: aDateAndTime equals: '1970-01-01T00:00:00+00:00' asDateAndTime! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testMinus
	self assert: aDateAndTime - aDateAndTime equals: '0:00:00:00' asDuration.
	self assert: aDateAndTime - '0:00:00:00' asDuration equals: aDateAndTime.
	self
		assert: aDateAndTime - aDuration
		equals:
			(DateAndTime
				year: 1969
				month: 12
				day: 30
				hour: 21
				minute: 56
				second: 55
				nanoSecond: 999999995
				offset: 0 hours)
	" I believe this Failure is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testTo
	self assert: (aDateAndTime to: aDateAndTime) equals: ((DateAndTime year: 1970 month: 1 day: 1) to: (DateAndTime year: 1970 month: 1 day: 1))
	"MessageNotUnderstood: UndefinedObject>>starting:ending:  where UndefinedObject is Timespan "! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testYear
	self assert: aDateAndTime year equals: 1970! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testSecond
	self assert: aDateAndTime second equals: 0! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testYearMonthDay
	self assert: aDateAndTime equals: (DateAndTime year: 1970 month: 1 day: 1)! !

!DateAndTimeUnixEpochTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsWeek
	self assert: aDateAndTime asWeek equals: (Week starting: '12-31-1969' asDate)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testAsDate
	self assert: aDateAndTime asDate equals: 'January 1, 1970' asDate! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testAsNanoSeconds
	self assert: aDateAndTime asNanoSeconds equals: 0 asDuration asNanoSeconds! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testDateTime
	self assert: aDateAndTime equals: (DateAndTime date: '01-01-1970' asDate time: '00:00:00' asTime)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testAsDateAndTime
	self assert: aDateAndTime asDateAndTime equals: aDateAndTime! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testMonth
	self assert: aDateAndTime month equals: 1.
	self assert: aDateAndTime monthAbbreviation equals: 'Jan'.
	self assert: aDateAndTime monthName equals: 'January'.
	self assert: aDateAndTime monthIndex equals: 1! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testDaysInYear
	self assert: aDateAndTime daysInYear equals: 365! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testDay
	self assert: aDateAndTime day equals: DateAndTime new day! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testAsLocal
	self assert: aDateAndTime asLocal equals: aDateAndTime.
	self assert: aDateAndTime asLocal equals: (aDateAndTime offset: aDateAndTime class localOffset)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testYearMonthDayHourMinuteSecond
	self
		assert: aDateAndTime
		equals:
			(DateAndTime
				year: 1970
				month: 1
				day: 1
				hour: 0
				minute: 0
				second: 0)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testAsUTC
	self assert: aDateAndTime asUTC equals: aDateAndTime! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testUtcOffset
	self assert: (aDateAndTime offset: '0:12:00:00') equals: '1970-01-01T12:00:00+12:00' asDateAndTime! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testNanoSecond
	self assert: aDateAndTime nanoSecond equals: 0! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testToByDo
	"self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days do: []) =  "
	"MessageNotUnderstood: UndefinedObject>>starting:ending:  where UndefinedObject is Timespan "! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testTimeZone
	self assert: aDateAndTime timeZoneName equals: 'Universal Time'.
	self assert: aDateAndTime timeZoneAbbreviation equals: 'UTC'! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testPlus
	self assert: aDateAndTime + '0:00:00:00' equals: aDateAndTime.
	self assert: aDateAndTime + 0 equals: aDateAndTime.
	self
		assert: aDateAndTime + aDuration
		equals:
			(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: '*Kernel-Tests-Extended' stamp: ''!
testAsYear
	self assert: aDateAndTime asYear equals: (Year starting: '01-01-1970' asDate)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testMiddleOf
	self assert: (aDateAndTime middleOf: '2:00:00:00' asDuration) equals: (Timespan starting: '12-31-1969' asDate duration: 2 days)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testIsLeapYear
	self deny: aDateAndTime isLeapYear! !

!DateAndTimeUnixEpochTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
   localTimeZoneToRestore := DateAndTime localTimeZone.
	aDateAndTime :=  DateAndTime localTimeZone: TimeZone default; unixEpoch.
	aTimeZone := TimeZone offset: (Duration minutes: 135) name: 'Unix Epoch Test Time Zone' abbreviation: 'UTZ'.
	aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testYearDay
	self assert: aDateAndTime equals: (DateAndTime year: 1970 day: 1)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testAsTime
	self assert: aDateAndTime asTime equals: Time midnight! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testMinute
	self assert: aDateAndTime minute equals: 0! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testTommorrow
	self assert: DateAndTime today + 24 hours equals: DateAndTime tomorrow.
	self deny: aDateAndTime equals: DateAndTime tomorrow
	"MessageNotUnderstood: Date class>>starting:"! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testYearDayHourMinuteSecond
	self
		assert: aDateAndTime
		equals:
			(DateAndTime
				year: 1970
				day: 1
				hour: 0
				minute: 0
				second: 0)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testDayMonthYearDo
	| iterations |
	iterations := 0.
	self assert: (aDateAndTime dayMonthYearDo: [ :eachDay :eachMonth :eachYear | iterations := iterations + 1 ]) equals: 1.
	self assert: (aDateAndTime dayMonthYearDo: [ :eachDay :eachMonth :eachYear | eachYear ]) equals: 1970.
	self assert: (aDateAndTime dayMonthYearDo: [ :eachDay :eachMonth :eachYear | eachMonth ]) equals: 1.
	self assert: (aDateAndTime dayMonthYearDo: [ :eachDay :eachMonth :eachYear | eachDay ]) equals: 1! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testOffset
	self assert: aDateAndTime offset equals: '0:00:00:00' asDuration.
	self assert: (aDateAndTime offset: '0:12:00:00') equals: '1970-01-01T12:00:00+12:00' asDateAndTime! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testMinutes
	self assert: aDateAndTime minutes equals: 0! !

!DateAndTimeUnixEpochTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsMonth
	self 
		assert: aDateAndTime asMonth
		equals: (Month year: 1970 month: 'January').! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testDaysInMonth
	self assert: aDateAndTime daysInMonth equals: 31! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testDuration
	self assert: aDateAndTime duration equals: 0 asDuration! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testDayOfMonth
	self assert: aDateAndTime dayOfMonth equals: 1! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testTicks
	self assert: aDateAndTime ticks equals: (DateAndTime julianDayNumber: 2440588) ticks.
	self assert: aDateAndTime ticks equals: #(2440588 0 0)! !

!DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: ''!
testYearMonthDayHourMinuteSecondNanosSecondOffset
	self
		assert: aDateAndTime
		equals:
			(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)
		equals:
			(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:)"! !

!DateError commentStamp: ''!
A generic error raised when try to instantiate dates.!
!DateParser commentStamp: ''!
Read a Date from the stream based on the pattern which can include the tokens:
	
		y = A year with 1 to n digits (after 2000)
		yy = A year with 2 digits (after 2000)
		yyyy = A year with 4 digits
		m = A month with 1 or 2 digits
		mm = A month with 2 digits
		d = A day with 1 or 2 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'!
!DateParser methodsFor: 'private - parsing' stamp: ''!
isEscape

	^ char = $\! !

!DateParser methodsFor: 'private - parsing day' stamp: ''!
parseVariableDigitDay

	day := self parse: 'day'! !

!DateParser methodsFor: 'private - parsing day' stamp: ''!
parseTwoDigitDay
	day := self parse: 'day' expectedSize: 2! !

!DateParser methodsFor: 'parsing' stamp: ''!
parse
	^ self parseIfError: [ DateError signal ]! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
parse: aTimeUnitName
	^ Integer readFrom: inputStream ifFail: [ DateError signal: 'Expecting a ',aTimeUnitName ]! !

!DateParser methodsFor: 'private - parsing month' stamp: ''!
parseVariableDigitMonth

	month := self parse: 'month'! !

!DateParser methodsFor: 'private - parsing month' stamp: ''!
parseTwoDigitMonth

	month := self parse: 'month' expectedSize: 2! !

!DateParser methodsFor: 'private - parsing year' stamp: ''!
parseFourDigitYear

	year := self parse: 'year' expectedSize: 4! !

!DateParser methodsFor: 'private - parsing month' stamp: ''!
parseMonth

	self isTwoDigitMonthPattern ifTrue: [ ^self parseTwoDigitMonth ].
	self parseVariableDigitMonth! !

!DateParser methodsFor: 'private - parsing day' stamp: ''!
parseDay

	self isTwoDigitDayPattern ifTrue: [ ^ self parseTwoDigitDay ].
	self parseVariableDigitDay! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
currentMillenium
	^ (Date current year / 100) asInteger * 100! !

!DateParser methodsFor: 'private - parsing year' stamp: ''!
parseVariableDigitYear

	year := self parse: 'year'! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
convertTwoDigitsYear

	(year between: 0 and: 99) ifTrue: [ year := self currentMillenium + year ]! !

!DateParser methodsFor: 'private - parsing year' stamp: ''!
isFourDigitYearPattern

	^ patternStream nextMatchAll: 'yyy'! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
initializeParsing

	invalidPattern := false.
	patternStream := pattern readStream! !

!DateParser methodsFor: 'private - parsing year' stamp: ''!
parseTwoDigitYear

	year := self parse: 'year' expectedSize: 2! !

!DateParser methodsFor: 'private - parsing day' stamp: ''!
isDayPattern

	^ char = $d! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
isDoneParsing

	^ patternStream atEnd or: [ inputStream atEnd or: [  invalidPattern  ]]! !

!DateParser methodsFor: 'private - parsing month' stamp: ''!
isMonthPattern

	^ char = $m! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
createDate

	^ Date year: year month: month day: day! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
parseNextPattern

	self readNextChar.

	self isEscape ifTrue: [ ^ self parseEscapePattern ].
	self isYearPattern ifTrue: [ ^ self parseYear ].
	self isMonthPattern ifTrue: [ ^ self parseMonth ].
	self isDayPattern ifTrue: [ ^ self parseDay ].
	
	self parseSameChar! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
isInvalidPattern

	^ year isNil or: [ month isNil or: [ day isNil or: [ invalidPattern ]]]! !

!DateParser methodsFor: 'private - parsing month' stamp: ''!
isTwoDigitMonthPattern

	^ patternStream peekFor: $m! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
parse: timeUnitName expectedSize: anInteger
	| extractedString result |
	extractedString := inputStream next: anInteger.
	result := extractedString asInteger.
	(result isNil or: [ extractedString size ~= anInteger ]) 
		ifTrue: [ DateError signal: ' Expect a two digit ', timeUnitName, ', got ', extractedString ].
	^ result! !

!DateParser methodsFor: 'private - parsing year' stamp: ''!
parseYear

	self isFourDigitYearPattern ifTrue: [ ^ self parseFourDigitYear ].
	self isTwoDigitYearPattern ifTrue: [ ^ self parseTwoDigitYear ].
	self parseVariableDigitYear! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
parseEscapePattern

	inputStream next = patternStream next ifFalse: [ invalidPattern := true ]! !

!DateParser methodsFor: 'private - parsing day' stamp: ''!
isTwoDigitDayPattern

	^ patternStream peekFor: $d! !

!DateParser methodsFor: 'parsing' stamp: ''!
parseIfError: aBlock
	"Parse the date according to the given pattern"
	self initializeParsing.
	
	[ self isDoneParsing ] whileFalse: [ self parseNextPattern ].

	self isInvalidPattern ifTrue: aBlock.
	self convertTwoDigitsYear.
	
	(inputStream atEnd and: [ patternStream atEnd ]) ifFalse: [ DateError signal: 'Input doesn''t match given pattern.' ].
	
	^ self createDate! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
parseSameChar

	inputStream next = char ifFalse: [ invalidPattern := true ]! !

!DateParser methodsFor: 'private - parsing year' stamp: ''!
isTwoDigitYearPattern

	^ patternStream peekFor: $y! !

!DateParser methodsFor: 'private - parsing year' stamp: ''!
isYearPattern

	^ char = $y! !

!DateParser methodsFor: 'initialization' stamp: ''!
initializeReadingFrom: anInputStream pattern: aPattern

	inputStream := anInputStream.
	pattern := aPattern.! !

!DateParser methodsFor: 'private - parsing' stamp: ''!
readNextChar

	char := patternStream next! !

!DateParser class methodsFor: 'instance creation' stamp: ''!
readingFrom: anInputStream pattern: aPattern

	"See class comment for pattern description
	self comment"
	
	^self new initializeReadingFrom: anInputStream pattern: aPattern! !

!DateParsingTest commentStamp: ''!
SUnit tests for date parsing!
!DateParsingTest methodsFor: 'tests - m pattern' stamp: ''!
testParsingMPatternWithSingleDigitSucceeds 
	| date |
	date := Date year: 2013 month: 2 day: 11.
	self assertReading: '11.2.2013' as: 'dd.m.yyyy' equals: date.
	self assertReading: '2.2013.11' as: 'm.yyyy.dd' equals: date.
	self assertReading: '11.2013.2' as: 'dd.yyyy.m' equals: date! !

!DateParsingTest methodsFor: 'tests - d pattern' stamp: ''!
testParsingDPatternWithIncorrectDayFails 
	self assertReading: '0.11.2013' as: 'd.mm.yyyy' raise: DateError.
	self assertReading: '32.2013.29' as: 'd.mm.yyyy' raise: DateError.! !

!DateParsingTest methodsFor: 'tests - m pattern' stamp: ''!
testParsingMPatternWithIncorrectMonthFails 
	self assertReading: '1.0.2013' as: 'dd.m.yyyy' raise: DateError.
	self assertReading: '22.13.2013' as: 'dd.m.yyyy' raise: DateError.! !

!DateParsingTest methodsFor: 'tests - yyyy pattern' stamp: ''!
testParsingYYYYPatternWithWrongNumberOrDigitsShouldFails
	self assertReading: '02.11.3' as: 'dd.mm.yyyy' raise: DateError.
	self assertReading: '02.11.13' as: 'dd.mm.yyyy' raise: DateError.
	self assertReading: '02.11.113' as: 'dd.mm.yyyy' raise: DateError.
	self assertReading: '02.11.10113' as: 'dd.mm.yyyy' raise: DateError! !

!DateParsingTest methodsFor: 'tests - d pattern' stamp: ''!
testParsingDPatternWithTwoDigitSucceeds 
	self assertReading: '29.11.2013' as: 'd.mm.yyyy' equals: (Date year: 2013 month: 11 day: 29).! !

!DateParsingTest methodsFor: 'tests' stamp: ''!
testCanEscapeSpecialCharacters
	"Checks that reserved pattern characters $d $m and $y can be escaped in patterns"
	self assertReading: '4d\2m\2345y' as: 'd\d\\m\m\\y\y' equals: (Date year: 2345 month: 2 day: 4)! !

!DateParsingTest methodsFor: 'tests - dd pattern' stamp: ''!
testParsingDDPatternWithSingleDigitFails
	self assertReading: '4.02.2345' as: 'dd.mm.yyyy' raise: DateError! !

!DateParsingTest methodsFor: 'asserting' stamp: ''!
reading: aPattern pattern: aString
	^ (self dateParserClass readingFrom: aString readStream pattern: aPattern) parse! !

!DateParsingTest methodsFor: 'asserting' stamp: ''!
assertReading: aString as: aPattern raise: anErrorClass

	self
		should: [ self reading: aPattern pattern: aString ]
		raise: anErrorClass! !

!DateParsingTest methodsFor: 'tests - dd pattern' stamp: ''!
testParsingDDPatternWithIncorrectDaysFails 
	self assertReading: '02.00.2013' as: 'dd.mm.yyyy' raise: DateError.
	self assertReading: '02.13.2013' as: 'dd.mm.yyyy' raise: DateError.! !

!DateParsingTest methodsFor: 'tests - d pattern' stamp: ''!
testParsingDPatternWithSingleDigitSucceeds
	self assertReading: '2.11.2013' as: 'd.mm.yyyy' equals: (Date year: 2013 month: 11 day: 2)! !

!DateParsingTest methodsFor: 'tests - y pattern' stamp: ''!
testParsingYPatternWithSingleDigitReturnsASecondMillenaryYear
	self assertReading: '2.11.3' as: 'd.mm.y' equals: (Date year: 2003 month: 11 day: 2)! !

!DateParsingTest methodsFor: 'asserting' stamp: ''!
assertReading: aString as: aPattern equals: aDate
	self assert: (self reading: aPattern pattern: aString) equals: aDate! !

!DateParsingTest methodsFor: 'tests - y pattern' stamp: ''!
testParsingYPatternWithTwoDigitsReturnsASecondMillenaryYear
	self assertReading: '2.11.13' as: 'd.mm.y' equals: (Date year: 2013 month: 11 day: 2)! !

!DateParsingTest methodsFor: 'accessing' stamp: ''!
dateParserClass
	^ DateParser! !

!DateParsingTest methodsFor: 'tests - yy pattern' stamp: ''!
testParsingYYPatternReturnsASecondMillenaryYear
	self assertReading: '2.11.13' as: 'd.mm.yy' equals: (Date year: 2013 month: 11 day: 2)! !

!DateParsingTest methodsFor: 'tests - m pattern' stamp: ''!
testParsingMPatternWithTwoDigitSucceeds 
	| date |
	date := Date year: 2013 month: 11 day: 29.
	self assertReading: '29.11.2013' as: 'dd.m.yyyy' equals: date.
	self assertReading: '11.2013.29' as: 'm.yyyy.dd' equals: date.
	self assertReading: '29.2013.11' as: 'dd.yyyy.m' equals: date.! !

!DateParsingTest methodsFor: 'tests' stamp: ''!
testDefaultParsingSucceeds 
	| date |
	date := Date year: 2013 month: 11 day: 29.
	self assertReading: '29.11.2013' as: 'dd.mm.yyyy' equals: date.
	self assertReading: '29.11.2013' as: 'd.m.y' equals: date.
	self assertReading: '29.11.13' as: 'd.m.y' equals: date! !

!DateParsingTest methodsFor: 'tests' stamp: ''!
testParsingPatternWithExtraCharacter

	self assertReading: 'a4.2.2345' as: 'ad.m.y' equals: (Date year: 2345 month: 2 day: 4). 
	self assertReading: '4.2.2345' as: 'ad.m.y' raise: DateError.
	self assertReading: 'a4.2.2345' as: 'd.m.y' raise: DateError.! !

!DateParsingTest methodsFor: 'tests' stamp: ''!
testParsingPatternWithTrailingCharacterFails

	self assertReading: '04.02.2013trailing' as: 'd.m.y' raise: DateError! !

!DateParsingTest methodsFor: 'tests - yy pattern' stamp: ''!
testParsingYYPatternWithWrongNumberOrDigitsShouldFails
	self assertReading: '02.11.3' as: 'dd.mm.yy' raise: DateError.
	self assertReading: '02.11.113' as: 'dd.mm.yy' raise: DateError! !

!DateParsingTest methodsFor: 'tests - y pattern' stamp: ''!
testParsingYPatternWithFiveDigits
	self assertReading: '2.11.10000' as: 'd.mm.y' equals: (Date year: 10000 month: 11 day: 2)! !

!DateParsingTest methodsFor: 'tests - mm pattern' stamp: ''!
testParsingMMPatternWithSingleDigitFails
	self assertReading: '04.2.2345' as: 'dd.mm.yyyy' raise: DateError! !

!DateParsingTest methodsFor: 'tests - mm pattern' stamp: ''!
testParsingMMPatternWithIncorrectMonthFails 
	self assertReading: '02.00.2013' as: 'dd.mm.yyyy' raise: DateError.
	self assertReading: '02.13.2013' as: 'dd.mm.yyyy' raise: DateError! !

!DatePresenter commentStamp: ''!
A DatePresenter 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 DatePresenter in your UI, and send #date when you want its value.
- or, register to be notified when the date changes:
	DatePresenter new
		date: self date;
		whenDateChanged: [ :newDate | self date: newDate ].

As it is Spec-based, it can be easily adapted and composed into a larger UI.!
!DatePresenter methodsFor: 'private' stamp: ''!
chooseDate

	| calendar defaultDate |
	defaultDate := self date ifNil: [ self defaultDate ].
	calendar := CalendarMorph openOn: defaultDate.
	calendar
		center: calendar cursorPoint;
		fitInWorld;
		onChoiceSend: #onDateChosen: to: self.! !

!DatePresenter methodsFor: 'api' stamp: ''!
displayBlock
	"<api: #inspect>"
	"Return the one argument block used to wrap your domain specific items.
	The block should return something that can be displayed in a list - like a String or a Text"
	
	^ displayBlockHolder value! !

!DatePresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	displayBlockHolder := [ :object | object ifNotNil: [ object asStringOrText ] ifNil: '' ] asValueHolder.
	displayBlockHolder whenChangedDo: [ self date: self date ].
	self date: self defaultDate.! !

!DatePresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets

	dateModel := self newTextInput.
	chooseDateButton := self newButton.
	
	dateModel
		isCodeCompletionAllowed: false.
	
	chooseDateButton
		icon: self iconMorph;
		action: [ self chooseDate ];
		extent: self iconMorph extent.! !

!DatePresenter methodsFor: 'accessing - widgets' stamp: ''!
dateModel

	^ dateModel.! !

!DatePresenter methodsFor: 'accessing' stamp: ''!
date: aDate

	| dateString |
	date := aDate.
	dateString := self displayBlock value: date.
	self dateModel text: dateString.! !

!DatePresenter methodsFor: 'private' stamp: ''!
iconMorph

	^ ImageMorph new form: (self iconNamed: #calendarIcon)! !

!DatePresenter methodsFor: 'private' stamp: ''!
onDateChosen: aChoseDate

	aChoseDate calendar delete.
	self date: aChoseDate date! !

!DatePresenter methodsFor: 'defaults' stamp: ''!
defaultDate
	^ Date today ! !

!DatePresenter methodsFor: 'accessing - widgets' stamp: ''!
chooseDateButton

	^ chooseDateButton.! !

!DatePresenter methodsFor: 'api - events' stamp: ''!
whenDateChanged: aBlock

	dateModel whenTextChanged: [ :newText :oldText :announcement :anAnnouncer |
		| oldDate |
		oldDate := date.
		date := newText
			ifNotEmpty: [ Date readFrom: newText readStream ]
			ifEmpty: [ nil ].
		aBlock cull: date cull: oldDate cull: announcement cull: anAnnouncer ]! !

!DatePresenter methodsFor: 'accessing' stamp: ''!
date

	^ date! !

!DatePresenter methodsFor: 'api' stamp: ''!
displayBlock: aBlock
	"<api: #block getter:#displayBlock registration: #whenDisplayBlockChanged:>"
	"Set the one argument block used to transform your date into a string"
	
	displayBlockHolder value: aBlock! !

!DatePresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new openDialogWithSpec! !

!DatePresenter class methodsFor: 'examples' stamp: ''!
exampleModal
	<sampleInstance>
	^ self new openDialogWithSpec modalRelativeTo: self currentWorld! !

!DatePresenter class methodsFor: 'accessing' stamp: ''!
spec
	<spec: #default>

	^ SpecLayout composed
			newRow: [ :row | 
				row 
					newRow: [:ugly | 
						ugly
							add: #dateModel;  
							add: #chooseDateButton width: 50 ]] height: 25
			yourself.! !

!DateTest commentStamp: ''!
SUnit tests for class Date!
!DateTest methodsFor: 'tests' stamp: ''!
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: ''!
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: ''!
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: 'helpers' stamp: ''!
useNonUtcTimeZoneDuring: aBlock

	self useTimeZone: 'EDT' during: aBlock.! !

!DateTest methodsFor: 'tests' stamp: ''!
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: ''!
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: ''!
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.
	self assert: (self dateClass readFrom: s2) equals: june2nd1973.
	self assert: (self dateClass readFrom: s3) equals: june2nd1973.
	self assert: (self dateClass readFrom: s4) equals: june2nd1973.
	self assert: (self dateClass readFrom: s5) equals: june2nd1973! !

!DateTest methodsFor: 'tests' stamp: ''!
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: ''!
testIsOnOrAfter

	| tzm8 tzp10 |
	
	tzm8 := january23rd2004 translateTo: -8 hours.
	tzp10 := january23rd2004 translateTo: 10 hours.

	self
		assert: (tzp10 isOnOrAfter: tzm8);
		assert: (june2nd1973 isOnOrAfter: january23rd2004) not;
		assert: (june2nd1973 isOnOrAfter: june2nd1973);
		assert: (january23rd2004 isOnOrAfter: june2nd1973).! !

!DateTest methodsFor: 'coverage' stamp: ''!
selectorsToBeIgnored

	 | deprecated private special |
	deprecated := #().
	private := #().
	special := #( #< #= #new #next #previous #printOn: #printOn:format: #storeOn: #fromString: ).

	^ super selectorsToBeIgnored, deprecated, private, special! !

!DateTest methodsFor: 'tests' stamp: ''!
testAsMonthInYear
	
	self assert: ((Date asMonth: 9 inYear: 2018) asString) equals: 'September 2018'.! !

!DateTest methodsFor: 'tests' stamp: ''!
testFromSeconds

	| d |
	d := self dateClass fromSeconds: june2nd1973 asSeconds. 
	self assert: d equals: june2nd1973.! !

!DateTest methodsFor: 'tests' stamp: ''!
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: ''!
testNewDayMonthYear

	self assert: (Date year: 2004 month: 1 day: 23) equals: january23rd2004.! !

!DateTest methodsFor: 'tests' stamp: ''!
testPrevious

	| previousDay |
	previousDay := june2nd1973 previous.
	self assert: previousDay equals: '1 June, 1973' asDate.! !

!DateTest methodsFor: 'tests' stamp: ''!
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: ''!
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: ''!
testBasicPrinting
	| printer |
	printer := BasicDatePrinter new.
	self
		assert: (String streamContents: [ :s | printer printDate: january23rd2004 format: #() on: s ])
		equals: '2004-01-23'.
	self
		assert: (String streamContents: [ :s | printer printDate: june2nd1973 format: #() on: s ])
		equals: '1973-06-02'! !

!DateTest methodsFor: 'tests' stamp: ''!
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: ''!
testPrintOn
	self assert: (String streamContents: [ :str | january23rd2004 printOn: str ]) equals: '23 January 2004'! !

!DateTest methodsFor: 'tests' stamp: ''!
testPrintOnFormat
	self assert: (String streamContents: [ :str | january23rd2004 printOn: str format: #(3 2 1 $* 2 2) ]) equals: '04*Jan*23'! !

!DateTest methodsFor: 'helpers' stamp: ''!
restoreLocalTimeZoneAfter: aBlock

	| realTimeZone |
	realTimeZone := DateAndTime localTimeZone.
	aBlock ensure: [ DateAndTime localTimeZone: realTimeZone ].! !

!DateTest methodsFor: 'tests' stamp: ''!
testJulianDayNumber

	self assert: (january23rd2004 translateTo: 0) equals: (Date julianDayNumber: ((4713+2004)*365 +1323) offset: 0 hour).! !

!DateTest methodsFor: 'tests' stamp: ''!
testEquals

	| tzm8 tzp10 |
	
	tzm8 := january23rd2004 translateTo: -8 hours.
	tzp10 := january23rd2004 translateTo: 10 hours.

	self
		assert: (january23rd2004 equals: tzm8);
		assert: (january23rd2004 equals: tzp10);
		assert: (tzm8 equals: tzp10);
		assert: (january23rd2004 equals: june2nd1973) not.! !

!DateTest methodsFor: 'tests' stamp: ''!
testNext

	| nextDay |
	nextDay := june2nd1973 next.
	self assert: nextDay equals: '3 June, 1973' asDate.! !

!DateTest methodsFor: 'tests' stamp: ''!
testFromString
 	"The fromString method requires month, day and year delemited by a valid date delimiter"
	
	| d |
	d := self dateClass fromString: '06.02.1973'. 
	self assert: d equals: june2nd1973.
 
	d := self dateClass fromString: '06-02-1973'. 
	self assert: d equals: june2nd1973.

	d := self dateClass fromString: '06/02/1973'. 
	self assert: d equals: june2nd1973.! !

!DateTest methodsFor: 'tests' stamp: ''!
testYyyymmdd

	self assert: january23rd2004 yyyymmdd equals: '2004-01-23'! !

!DateTest methodsFor: 'tests' stamp: ''!
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: ''!
testAsDate

	self assert: january23rd2004 asDate equals: january23rd2004.! !

!DateTest methodsFor: 'tests' stamp: ''!
testStarting

	| aDateAndTime anyTime |
	anyTime := '13:12' asTime.
	aDateAndTime := DateAndTime date: january23rd2004 time: anyTime.
	self assert: (Date starting: aDateAndTime) equals: january23rd2004.! !

!DateTest methodsFor: 'tests' stamp: ''!
testFirstWeekdayOfMonthYear

	self assert: (Date firstWeekdayOfMonth: 'January' year: 2004) equals: 5.! !

!DateTest methodsFor: 'tests' stamp: ''!
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: 'coverage' stamp: ''!
classToBeTested

	^ self dateClass! !

!DateTest methodsFor: 'tests' stamp: ''!
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: ''!
testNew
	| instance epoch |
	instance := self dateClass new.
	epoch := self epoch.
	"We have to be careful, since #new creates a Date for midnight in the local timezone, whereas #epoch is based on a fixed time in UTC"
	instance offset negative 
		ifTrue: [ epoch := epoch - 1 day ]. 
	self
		assert: instance
		equals: epoch.! !

!DateTest methodsFor: 'private' stamp: ''!
dateClass

	^ Date! !

!DateTest methodsFor: 'tests' stamp: ''!
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: ''!
testEqual
	self assert: january23rd2004 equals: 'January 23, 2004' asDate! !

!DateTest methodsFor: 'tests' stamp: ''!
testNewDayYear

	self assert: (Date year: 2004 day: 23) equals: january23rd2004! !

!DateTest methodsFor: 'tests' stamp: ''!
testSubtractDays

	self assert: (january23rd2004 subtractDays: 0) equals: '2004-01-23' asDate.	
	self assert: (january23rd2004 subtractDays: 30) equals: '2003-12-24' asDate.! !

!DateTest methodsFor: 'helpers' stamp: ''!
useTimeZone: abbreviation during: aBlock

  | timeZone |
  timeZone := TimeZone abbreviated: abbreviation.
  self restoreLocalTimeZoneAfter: [ 
    DateAndTime localTimeZone: timeZone. 
    aBlock cull: timeZone ].! !

!DateTest methodsFor: 'tests' stamp: ''!
testIsLeapYear 

	| dateInLeapYear dateInNonLeapYear |
	dateInLeapYear := january23rd2004.
	dateInNonLeapYear := dateInLeapYear + 365 days.
	self assert: dateInLeapYear isLeapYear equals: true.
	self assert: dateInNonLeapYear isLeapYear equals: false.! !

!DateTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	june2nd1973 := self dateClass year: 1973 day: 153.
	january23rd2004 := Date readFrom: '01-23-2004' readStream.
	aTime := Time readFrom: '12:34:56 pm' readStream! !

!DateTest methodsFor: 'tests' stamp: ''!
testIsAfter

	| tzm8 tzp10 |
	
	tzm8 := january23rd2004 translateTo: -8 hours.
	tzp10 := january23rd2004 translateTo: 10 hours.

	self
		assert: (tzp10 isAfter: tzm8) not;
		assert: (january23rd2004 isAfter: june2nd1973);
		assert: (june2nd1973 isAfter: june2nd1973) not.! !

!DateTest methodsFor: 'tests' stamp: ''!
testAccessing

	self	
		assert: june2nd1973 day equals: 153;
		assert: june2nd1973 julianDayNumber equals: 2441836;
		assert: june2nd1973 monthIndex equals: 6;
		assert: june2nd1973 monthName equals: #June;
		assert: june2nd1973 weekday equals: #Saturday;
		assert: june2nd1973 weekdayIndex equals: 7;
		assert: june2nd1973 year equals: 1973.! !

!DateTest methodsFor: 'tests' stamp: ''!
testIsOnOrBefore

	| tzm8 tzp10 |
	
	tzm8 := january23rd2004 translateTo: -8.
	tzp10 := january23rd2004 translateTo: 10.

	self
		assert: (tzm8 isOnOrBefore: tzp10);
		assert: (june2nd1973 isOnOrBefore: january23rd2004);
		assert: (june2nd1973 isOnOrBefore: june2nd1973);
		assert: (january23rd2004 isOnOrBefore: june2nd1973) not.! !

!DateTest methodsFor: 'tests' stamp: ''!
testPreviousByName

	self assert: (january23rd2004 previous: #Friday) equals: '2004-01-16' asDate.! !

!DateTest methodsFor: 'tests' stamp: ''!
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: '*Kernel-Tests-WithCompiler' stamp: ''!
testStoring

	| expected actual |
	expected := '''2 June 1973'' asDate'.
	actual := june2nd1973 storeString.
	self	
		assert: actual equals: expected;
		assert: (Smalltalk compiler evaluate: expected) equals: june2nd1973. "Evaluating expected to avoid surprises when evaluating"! !

!DateTest methodsFor: 'tests' stamp: ''!
testStoreOn
	self assert: (String streamContents: [ :str | january23rd2004 storeOn: str ]) equals: '''23 January 2004'' asDate'! !

!DateTest methodsFor: 'tests' stamp: ''!
testIsBefore

	| tzm8 tzp10 |
	
	tzm8 := january23rd2004 translateTo: -8 hours.
	tzp10 := january23rd2004 translateTo: 10 hours.

	self
		assert: (tzm8 isBefore: tzp10) not;
		assert: (june2nd1973 isBefore: january23rd2004);
		assert: (june2nd1973 isBefore: june2nd1973) not.! !

!DateTest methodsFor: 'tests' stamp: ''!
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: ''!
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: ''!
testWeekday

	self assert: january23rd2004 weekday equals: #Friday.	
	self assert: january23rd2004 weekdayIndex equals: 6.! !

!DateTest methodsFor: 'tests' stamp: ''!
testMmddyyyy
	self assert: january23rd2004 mmddyyyy equals: '1/23/2004'! !

!DateTest methodsFor: 'tests' stamp: ''!
testDuration

	self assert: january23rd2004 duration equals: 24 hours.! !

!DateTest methodsFor: 'tests' stamp: ''!
testPrintFormat
	| printFormat printedDate |
	printFormat := { 1 . 2 . 3 . $/ . 1 . 1 }.
	self assert: (january23rd2004 printFormat: printFormat) equals: '23/1/2004'.

	printFormat at: 4 put: $-.
	printedDate := january23rd2004 printFormat: printFormat.
	self assert: printedDate equals: '23-1-2004'.

	"Month type 1 should print the index of the month."
	printFormat at: 5 put: 1.
	self assert: ((printedDate splitOn: $-) at: 2) equals: '1'.

	"Month type 2 should print the abbreviation of the month name."
	printFormat at: 5 put: 2.
	printedDate := january23rd2004 printFormat: printFormat.
	self assert: ((printedDate splitOn: $-) at: 2) equals: 'Jan'.

	"Month type 2 should print the full month name."
	printFormat at: 5 put: 3.
	printedDate := january23rd2004 printFormat: printFormat.
	self assert: ((printedDate splitOn: $-) at: 2) equals: 'January'.

	"Month type 4 should not print the month."
	printFormat at: 5 put: 4.
	printedDate := january23rd2004 printFormat: printFormat.
	self assert: ((printedDate splitOn: $-) at: 2) equals: ''.

	"Year type 1 should print the full year."
	printFormat at: 6 put: 1.
	printedDate := january23rd2004 printFormat: printFormat.
	self assert: ((printedDate splitOn: $-) at: 3) equals: '2004'.

	"Year type 2 should print the year abbreviation."
	printFormat at: 6 put: 2.
	printedDate := january23rd2004 printFormat: printFormat.
	self assert: ((printedDate splitOn: $-) at: 3) equals: '04'.

	"Year type 2 should print the year abbreviation."
	printFormat at: 6 put: 2.
	printedDate := january23rd2004 printFormat: printFormat.
	self assert: ((printedDate splitOn: $-) at: 3) equals: '04'.

	"Out of range year types -> short year."
	printFormat at: 6 put: 3.
	printedDate := january23rd2004 printFormat: printFormat.
	self assert: ((printedDate splitOn: $-) at: 3) equals: '04'.

	"Usage examples"
	self
		assert: june2nd1973 mmddyyyy equals: '6/2/1973';
		assert: june2nd1973 yyyymmdd equals: '1973-06-02';
		assert: (june2nd1973 printFormat: #(3 1 2 $!! 2 1 1)) equals: '1973!!2!!Jun';
		assert: (june2nd1973 printFormat: #(1 2 3 0 1 1 2)) equals: '02061973';
		assert: (june2nd1973 printFormat: #(2 1 3 0 1 1 2)) equals: '06021973';
		assert: (june2nd1973 printFormat: #(3 2 1 0 1 1 2)) equals: '19730602';
		assert: (june2nd1973 printFormat: #(1 2 3 0 1 1 1)) equals: '261973'! !

!DateTest methodsFor: 'helpers' stamp: ''!
epoch

	^ Date year: 1901 month: 1 day: 1! !

!DebugAction commentStamp: ''!
A DebugAction is the entry point for creating debugging actions.

A new debugging action is created by subclassing it and implementing, by default, the method executeAction (This can be configured by using the method actionSelector).  An id must also be provided uniquely identifying the action among all the others.

The initialize method should only set default values or initialize attributes that are independent of the debugger or session. The others must be initilized in the method forDebugger:.

A debugging action has the following lifecycle: 
	- the action is created using #new and #initialized is called
	- #appliesToDebugger:, and for contextual actions #appliesToContext: are called
	- if the actions applies to the current situation #forDebugger: is used to set the debugger
	- #execute is called when the user triggers the action.
	- when the debugger updates its action this process is repeated.!
!DebugAction methodsFor: 'testing' stamp: ''!
appliesToDebugger: aDebugger

	^ true! !

!DebugAction methodsFor: 'accessing' stamp: ''!
defaultCategory
	"Return the default kind of debugger action. It has nothing to do with class category or the old method category now method protocol."
	^ nil! !

!DebugAction methodsFor: 'actions' stamp: ''!
executeAction
	"By default do nothing."! !

!DebugAction methodsFor: 'accessing' stamp: ''!
debugger: anObject

	debugger := anObject! !

!DebugAction methodsFor: 'accessing' stamp: ''!
debugger

	^ debugger! !

!DebugAction methodsFor: 'accessing' stamp: ''!
needsUpdate: aBoolean

	needsUpdate := aBoolean! !

!DebugAction methodsFor: 'accessing' stamp: ''!
needsSeparatorAfter: aBoolean

	needsSeparatorAfter := aBoolean! !

!DebugAction methodsFor: 'actions' stamp: ''!
preAction

	self notifyDebuggingActionAboutToExecute! !

!DebugAction methodsFor: 'accessing' stamp: ''!
needsSeparatorAfter

	^ needsSeparatorAfter ifNil: [ false ]! !

!DebugAction methodsFor: 'actions' stamp: ''!
precondition

	^ self needsValidation not or: [ self debugger okToChange ]! !

!DebugAction methodsFor: 'accessing' stamp: ''!
category: anObject
	"Set the kind of debugger action. It has nothing to do with class category or the old method category now method protocol."
	category := anObject! !

!DebugAction methodsFor: 'accessing - context' stamp: ''!
selectedContext
	
	^ self debugger selectedContext! !

!DebugAction methodsFor: 'accessing' stamp: ''!
session

	^ self debugger session! !

!DebugAction methodsFor: 'testing' stamp: ''!
appliesToContext: aContext

	^ true! !

!DebugAction methodsFor: 'actions' stamp: ''!
execute

	self precondition ifTrue: [ 
		self preAction.
		self perform: self actionSelector.
		self postAction ]! !

!DebugAction methodsFor: 'initialization' stamp: ''!
forDebugger: aDebugger

	self debugger: aDebugger! !

!DebugAction methodsFor: 'accessing' stamp: ''!
icon

	^ icon ifNil: [ self defaultIcon ]! !

!DebugAction methodsFor: 'accessing - context' stamp: ''!
interruptedContext
	
	^ self debugger interruptedContext! !

!DebugAction methodsFor: 'accessing' stamp: ''!
needsValidation

	^ needsValidation ifNil: [ true ]! !

!DebugAction methodsFor: 'actions' stamp: ''!
notifyDebuggingActionExecuted
	
	self debugger announce: (DebugActionExecuted forDebuggingAction: self)! !

!DebugAction methodsFor: 'actions' stamp: ''!
postAction

	self notifyDebuggingActionExecuted! !

!DebugAction methodsFor: 'accessing - context' stamp: ''!
currentContext

	^ self debugger currentContext! !

!DebugAction methodsFor: 'accessing' stamp: ''!
id

	^ nil! !

!DebugAction methodsFor: 'accessing' stamp: ''!
icon: anObject

	icon := anObject! !

!DebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 0! !

!DebugAction methodsFor: 'accessing' stamp: ''!
defaultKeymap

	^ nil! !

!DebugAction methodsFor: 'accessing' stamp: ''!
help
	^ self subclassResponsibility! !

!DebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ ''! !

!DebugAction methodsFor: 'accessing' stamp: ''!
keymap

	^ keymap ifNil: [ 
		self defaultKeymap ifNil: [ 
			"Code to ensure backwards compatibility with the previous
			solution that used #defaultKeyText."
			self defaultKeyText ifNotNil: [ :aString |
				aString first isUppercase 
					ifTrue: [ aString first meta shift ]
					ifFalse: [ aString first meta ] ] ] ]! !

!DebugAction methodsFor: 'accessing' stamp: ''!
label

	^ label ifNil: [ self defaultLabel ]! !

!DebugAction methodsFor: 'accessing' stamp: ''!
label: aString

	label := aString! !

!DebugAction methodsFor: 'accessing' stamp: ''!
order: anInteger

	order := anInteger! !

!DebugAction methodsFor: 'actions' stamp: ''!
actionSelector

	^ actionSelector ifNil: [ self defaultActionSelector ]! !

!DebugAction methodsFor: 'actions' stamp: ''!
notifyDebuggingActionAboutToExecute
	
	self debugger announce: (DebugActionAboutToExecute forDebuggingAction: self)! !

!DebugAction methodsFor: 'accessing' stamp: ''!
order

	^ order ifNil: [ self defaultOrder ]! !

!DebugAction methodsFor: 'actions' stamp: ''!
defaultActionSelector

	^ #executeAction! !

!DebugAction methodsFor: 'accessing' stamp: ''!
withSeparatorAfter

	self needsSeparatorAfter: true! !

!DebugAction methodsFor: 'accessing' stamp: ''!
category
	"Return the kind of debugger action. It has nothing to do with class category or the old method category now method protocol."
	^ category ifNil: [ self defaultCategory ]! !

!DebugAction methodsFor: 'accessing' stamp: ''!
defaultKeyText
	"I return a string based on which a default shortcut is created for this action.
	
	I am still present to ensure backwards compatibility.
	The method #defaultKeymap should be overridden instead."
	self flag: 'Enable the deprecation once all usages of #defaultKeyText are removed.'.
	"self
		deprecated: 'Override #defaultKeymap instead to set a keymap object as shortcut.'
		on: '2016-09-05'
		in: #Pharo6."
	
	^ nil! !

!DebugAction methodsFor: 'accessing' stamp: ''!
needsUpdate

	^ needsUpdate ifNil: [ true ]! !

!DebugAction methodsFor: 'accessing' stamp: ''!
enabled

	^ true! !

!DebugAction methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
value
	self execute! !

!DebugAction methodsFor: 'testing' stamp: ''!
appliesToCurrentContext

	^ self appliesToContext: self currentContext! !

!DebugAction methodsFor: 'accessing' stamp: ''!
asDebugAction

	^ self! !

!DebugAction methodsFor: 'accessing' stamp: ''!
keymap: aKeymap

	keymap := aKeymap! !

!DebugAction methodsFor: 'accessing' stamp: ''!
defaultIcon

	^ self class defaultIcon! !

!DebugAction methodsFor: 'accessing' stamp: ''!
keyText
	"I return the character associated with this shortcut.
	I return an uppercase character if the keymap has shift as a modifier."

	^  self keymap 
		ifNil: [ 
			"Backwards compatibility."
			self defaultKeyText ]
		ifNotNil: [ |currentCharacter|
			"Needed as current menus display 'Shift' only if the charater is in uppercase."
			currentCharacter := self keymap currentCharacter.
			(self keymap printString includesSubstring: 'Shift')
				ifTrue: [  currentCharacter asString asUppercase ]
				ifFalse: [ currentCharacter asString ] ]! !

!DebugAction methodsFor: 'accessing' stamp: ''!
needsValidation: anObject

	needsValidation := anObject! !

!DebugAction class methodsFor: 'instance creation' stamp: ''!
forDebugger: aDebugger

	^ self new forDebugger: aDebugger! !

!DebugAction class methodsFor: 'accessing' stamp: ''!
asDebugAction

	^ self new! !

!DebugAction class methodsFor: 'accessing' stamp: ''!
defaultIcon

	^ nil! !

!DebugActionAboutToExecute commentStamp: ''!
A DebugActionAboutToExecute is an event send to the debugger before a debugging action is executed.!
!DebugActionAboutToExecute methodsFor: 'accessing' stamp: ''!
action: aDebuggingAction

	debuggingAction := aDebuggingAction! !

!DebugActionAboutToExecute methodsFor: 'accessing' stamp: ''!
action

	^ debuggingAction! !

!DebugActionAboutToExecute class methodsFor: 'instance creation' stamp: ''!
forDebuggingAction: anAction

	^ self new
		action: anAction! !

!DebugActionExecuted commentStamp: ''!
A DebugActionExecuted is an event send to the debugger after a debugging action is executed.

Instance Variables
	actionId:		<Object>

actionId
	- xxxxx
!
!DebugActionExecuted methodsFor: 'accessing' stamp: ''!
action: aDebuggingAction

	debuggingAction := aDebuggingAction! !

!DebugActionExecuted methodsFor: 'accessing' stamp: ''!
action

	^ debuggingAction! !

!DebugActionExecuted class methodsFor: 'instance creation' stamp: ''!
forDebuggingAction: anAction

	^ self new
		action: anAction! !

!DebugContext commentStamp: ''!
A DebugContext is a helper that complements DebugSession. It is meant to be created dynamically on a context when the session wants to access the provided services.

To create instances first call forContext: to set the current context, and then if
the interrupted is different use topContext:

Not sure if it is still a good idea to have this class. 

Instance Variables
	context:		<Object>
	method:		<Object>
	methodNode:		<Object>
	ranges:		<Object>
	topContext:		<Object>

context
	- xxxxx

method
	- xxxxx

methodNode
	- xxxxx

ranges
	- xxxxx

topContext
	- xxxxx
!
!DebugContext methodsFor: 'evaluating actions' stamp: ''!
recompileCurrentMethodTo: aText notifying: aNotifyer
	| classOrTraitOfMethod selector |
	
	selector := self selectedClass compiler parseSelector: aText.
	(self checkSelectorUnchanged: selector) ifFalse: [ ^ nil ].
	classOrTraitOfMethod := self confirmOnTraitOverwrite: selector inClass: self selectedClass.
	
	classOrTraitOfMethod ifNil:[ ^ nil].
		
	selector := classOrTraitOfMethod 
		compile: aText 
		classified: self selectedMessageCategoryName 
		notifying: aNotifyer.
	^ selector 
		ifNotNil: [ classOrTraitOfMethod compiledMethodAt: selector ]! !

!DebugContext methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!DebugContext methodsFor: 'accessing' stamp: ''!
selectedMessageName
	"Answer the message selector of the current context.
	 If the method is unbound we can still usefully answer its old selector."

	^ context methodSelector! !

!DebugContext methodsFor: 'accessing' stamp: ''!
selectedClass
	"Answer the class in which the current context's method was found."

	^ context methodClass! !

!DebugContext methodsFor: 'private' stamp: ''!
checkSelectorUnchanged: aSelector
	| unchanged |
	unchanged := aSelector == self selectedMessageName
		or: [ self selectedMessageName isDoIt and: [ aSelector numArgs = self selectedMessageName numArgs ] ].
	unchanged
		ifFalse: [ self inform: 'can''t change selector' ].
	^ unchanged! !

!DebugContext methodsFor: 'accessing' stamp: ''!
receiver
	^ context receiver! !

!DebugContext methodsFor: 'evaluating actions' stamp: ''!
evaluate: expression
	^ Smalltalk compiler
		source: expression;
		context: context;
		receiver: context receiver;
		evaluate! !

!DebugContext methodsFor: 'private' stamp: ''!
blockNotFoundDialog: aMethod with: aText

	| message result newMethod |
	
	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: 'Compile and Browse'
						falseChoice: 'Cancel'.
						
	"possible return values are true | false | nil"
	result ifFalse: [ ^ self ].
		
	newMethod := self recompileCurrentMethodTo: aText notifying: nil.
	newMethod ifNotNil: [newMethod browse]! !

!DebugContext methodsFor: 'initialization' stamp: ''!
topContext: aContext
	topContext := aContext! !

!DebugContext methodsFor: 'private' stamp: ''!
source
	"Answer the source code of the currently selected context."
	^ context sourceCode! !

!DebugContext methodsFor: 'private' stamp: ''!
confirmOnTraitOverwrite: aSelector inClass: aClass
	"test if method originates from a trait and let the user choose which one should be change"

	| target method |
	target := self selectedClass.
	method := aClass methodNamed: aSelector.
	method isFromTrait ifTrue: [ |trait|
		trait := method origin.
		target := UIManager default
			chooseFrom: {('Create copy in ' , aClass name). 
			('Compile Trait method in ' , trait name)}
			values: {aClass. trait }
			title: 'Where do you want to compile this trait method?' ].
	^ target! !

!DebugContext methodsFor: 'initialization' stamp: ''!
forContext: aContext 
	context := aContext.
	topContext := aContext! !

!DebugContext methodsFor: 'accessing' stamp: ''!
selectedMessageCategoryName
	"Answer the name of the message category of the message of the current context."

	^ self selectedClass organization categoryOfElement: self selectedMessageName! !

!DebugContext methodsFor: 'accessing' stamp: ''!
locateClosureHomeWithContent: aText
	"In case the current context is a BlockContext locate the closureHome and ask the
	user to validate the new context. If closureHome is not found or the user does not 
	validate the new context, return nil. aText is the new content of the current context.
	If the current context is not a BlockContext return it."
	| closureHome |
	
	context isBlockContext ifTrue: [
		closureHome := context activeHome.
		closureHome ifNil: [
			self blockNotFoundDialog: context compiledCode method with: aText.
		 	^ nil ].
		 (self confirm: 'I will have to revert to the method from\which this block originated.  Is that OK?' withCRs) 
			ifFalse: [ ^ nil ].
		^ closureHome].
	
	^ context! !

!DebugContext methodsFor: 'accessing' stamp: ''!
receiverClass
	"Answer the class of the receiver. 
	It may differ from 'self selectedClass' "
	
	^ context receiver class! !

!DebugContext class methodsFor: 'instance creation' stamp: ''!
forContext: aContext 
	^ self new forContext: aContext! !

!DebugSession commentStamp: ''!
A DebugSession models a debugging session. It contains the interrupted context and process. Its main goal is to handle debugger actions such as restart or stepInto, as well as recompilation of methods. It is the model used as an input to a ui.

As it is just a model it does not contain any information related to the ui. For example, it does not know what a selection in the ui is. It is the job of the ui to maintain the selection and call this session with the proper context.

To create sessions use the method 'process: aProcess context: aContext'. aContext must be a context belonging to aProcess, and aProcess must be an interrupted process.

Instance Variables
	name:
	interruptedContext: Context
	interruptedProcess: Process
	errorWasInUIProcess: Boolean
	
interruptedContext
is the context which sent the signal message that eventually raised the exception that invoked the debugger. It can be different from the suspendedContext of the interruptedProcess, which is the top (“hot”) context the interruptedProcess’s context chain.
Why interruptedContext is different from the suspendedContext of the interruptedProcess:
Because the exception system is implemented in Pharo, the handling of the initial signal (eg in Object>>#halt), all the way to opening a debugger, is itself Pharo code, and exists as activations from suspendedContext to interruptedContext.  The debugger, with help from the exception system, carefully hides this processing from the programmer.  If it did not we would have to wade through many activations before we found where the exception occurred. When a process is interrupted by control period things are different.  Here, another process handles opening the debugger and suspendedContext and interruptedContext are the same.


!
!DebugSession methodsFor: 'private' stamp: ''!
prepareTestToRunAgain

	self interruptedContext receiver prepareToRunAgain! !

!DebugSession methodsFor: 'context' stamp: ''!
contextChanged

	self triggerEvent: #contextChanged! !

!DebugSession methodsFor: 'context' stamp: ''!
isLatestContext: aContext
  	^ interruptedProcess suspendedContext == aContext! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
stepOver: aContext
	"Send the selected message in selectedContext, and regain control 
	after the invoked method returns."
	
	| newContext |
	aContext stepIntoQuickMethod: false.
	(self isContextPostMortem: aContext) ifTrue: [^ self].
	
	newContext := interruptedProcess completeStep: aContext.
	self updateContextTo:  
		(newContext == aContext
			ifTrue: [ (self stepToFirstInterestingBytecodeIn: interruptedProcess) ]
			ifFalse: [ newContext ]).

	self triggerEvent: #stepOver! !

!DebugSession methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
shortStackSize
	^ 20! !

!DebugSession methodsFor: '*NewTools-Debugger' stamp: ''!
spanNewSession

	^ (self class 
		named: self name 
		on: self interruptedProcess 
		startedAt: self interruptedContext)
			errorWasInUIProcess: self errorWasInUIProcess;
			yourself! !

!DebugSession methodsFor: 'private' stamp: ''!
installAlarm: aSelector withArgument: args
	
	self currentWorld
		addAlarm: aSelector
		withArguments: args
		for: self
		at: Time millisecondClockValue + 200! !

!DebugSession methodsFor: 'testing' stamp: ''!
isAboutUIProcess

	^errorWasInUIProcess! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
restart: aContext
	"Proceed from the initial state of selectedContext." 
	"Closing now depends on a setting (RestartAlsoProceeds class variable) --> not supported in this version"

	(self isContextPostMortem: aContext) ifTrue: [^ self].

	"Issue 3015 - Hernan"
	self isInterruptedContextATest ifTrue: [ self prepareTestToRunAgain ].
	self unwindAndRestartToContext: aContext.	

	self triggerEvent: #restart! !

!DebugSession methodsFor: 'accessing' stamp: ''!
stack

	^ interruptedContext stack! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
resume
	"Proceed execution of the receiver's model, starting after the expression at 
	which an interruption occurred."

	"If the user of this session does not plan to reuse it, it should call 'self clean' "

	Smalltalk okayToProceedEvenIfSpaceIsLow
		ifFalse: [ ^ self ].
	(self isContextPostMortem: self interruptedContext)
		ifTrue: [ ^ self ].
	self resumeProcess.
	self triggerEvent: #resume! !

!DebugSession methodsFor: 'logging' stamp: ''!
signalDebuggerError: anError

	DebuggerSettings emergencyDebugger
		debugError: anError
		fromSession: self! !

!DebugSession methodsFor: 'private' stamp: ''!
installAlarm: aSelector 
	
	self installAlarm: aSelector withArgument: #()! !

!DebugSession methodsFor: 'accessing' stamp: ''!
createModelForContext: aContext

	^ (DebugContext forContext: aContext) topContext: interruptedContext! !

!DebugSession methodsFor: 'accessing' stamp: ''!
interruptedContext

	^ interruptedContext! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
stepThrough

	self stepThrough: interruptedContext! !

!DebugSession methodsFor: 'accessing' stamp: ''!
exception: anObject
	exception := anObject! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
runToSelection: selectionInterval inContext: aContext 
	"Attempt to step over instructions in selectedContext until the 
	execution reaches the selected instruction. This happens when the
	program counter passes the begining of selectionInterval.
	
	A not nill and valid interval is expected." 
	
	(self pcRangeForContext: aContext) first >= selectionInterval first 
		ifTrue: [ ^self ].
	self stepOver: aContext.
	[ aContext == self interruptedContext and: [ (self pcRangeForContext: aContext) first < selectionInterval first ] ] 
		whileTrue: [ self stepOver: aContext ]! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
stepInto: aContext
	"Send the selected message in selectedContext, and take control in 
	the method invoked to allow further step or send."

	(self isContextPostMortem: aContext) ifTrue: [^ self].

	interruptedProcess step: aContext.
	self updateContextTo: (self stepToFirstInterestingBytecodeIn: interruptedProcess).
	
	self triggerEvent: #stepInto! !

!DebugSession methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
browse: aContext

	aContext method browse! !

!DebugSession methodsFor: 'testing' stamp: ''!
isTestObject: anObject

	"I'm not sure this is the best way to doit because it creates a coupling with TestCase, but due that SUnit is part of the core I think it is not bad after all - Hernan'"
	^ anObject isKindOf: TestCase! !

!DebugSession methodsFor: 'accessing' stamp: ''!
interruptedProcess

	^ interruptedProcess! !

!DebugSession methodsFor: 'testing' stamp: ''!
shouldDisplayContext: aContext basedOnFilters: stackFilters
	"Return true if all filters match the given context, or false otherwise.
	True is returned if there are no filters."
		
	^stackFilters allSatisfy: [ :aFilter | aFilter shouldDisplay: aContext ]! !

!DebugSession methodsFor: 'evaluating' stamp: ''!
unwindAndRestartToContext: aContext

	| ctx |
	ctx := interruptedProcess popTo: aContext.
	ctx == aContext ifTrue: [ "Only restart the process if the stack was unwind"
		interruptedProcess restartTop.
		self stepToFirstInterestingBytecodeIn: interruptedProcess ].
	self flag: 'Should a warning be displayed if the the unwind failed?'.
	self updateContextTo: aContext! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
clear
	"If after resuming the process the user does plan to reuse this session with
	the same process, it should call this method."
	exception := nil.
	interruptedProcess := nil.
	self updateContextTo: nil! !

!DebugSession methodsFor: '*NewTools-Debugger' stamp: ''!
application: anApplication! !

!DebugSession methodsFor: 'accessing' stamp: ''!
errorWasInUIProcess
	
	^ errorWasInUIProcess! !

!DebugSession methodsFor: '*Sindarin' stamp: ''!
asSindarinDebugSession
	^ SindarinDebugSession new debugSession: self! !

!DebugSession methodsFor: 'accessing' stamp: ''!
process
	^ interruptedProcess! !

!DebugSession methodsFor: 'initialization' stamp: ''!
process: aProcess context: aContext
	"aProcess stepToSendOrReturn"
	"aProcess isSuspended ifTrue: [ aProcess stepToSendOrReturn ]"

	interruptedProcess := aProcess.
	interruptedContext ifNil: [ interruptedContext := aContext ]! !

!DebugSession methodsFor: 'testing' stamp: ''!
isInterruptedContextATest

	^ (self isTestObject: self interruptedContext receiver) and: [ self isTestMethod: self interruptedContext method of: self interruptedContext receiver ]! !

!DebugSession methodsFor: 'evaluating' stamp: ''!
rewindContextToMethod: aMethod fromContext: aContext
	"this method is typically to be used after a hot compilation of a method from the stack.
	in order to return to the context containg the compiled method."
	| ctxt |
	ctxt :=  interruptedProcess popTo: aContext.
	
	ctxt == aContext
		ifFalse: [
			self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withCRs ]
		ifTrue: [
			interruptedProcess restartTopWith: aMethod.
			self stepToFirstInterestingBytecodeIn: interruptedProcess ].
	self updateContextTo:  ctxt.
	
	"Issue 3015 - Hernan"
	self isInterruptedContextATest ifTrue: [ self prepareTestToRunAgain ]! !

!DebugSession methodsFor: 'context' stamp: ''!
updateContextTo: aContext

	interruptedContext := aContext! !

!DebugSession methodsFor: 'accessing' stamp: ''!
context

	^ interruptedContext! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
returnValue: anObject from: aContext
	"Force a return of a given value to the previous context!!"

	| previous |
	self flag: 'should be called only on the selected context. WHY?'.	
	(self isContextPostMortem: aContext) ifTrue: [^ self].

	previous := aContext sender.
	"self resetContext: previous."
	interruptedProcess popTo: previous value: anObject.
	self updateContextTo: previous.
	self contextChanged! !

!DebugSession methodsFor: 'context' stamp: ''!
pcRangeForContext: aContext
	"Answer the indices in the source code for the method corresponding to 
	aContext's program counter value."

	(aContext isNil or: [ aContext isDead ])
		ifTrue: [ ^ 1 to: 0 ].
	^ aContext pcRangeContextIsActive: (self isLatestContext: aContext)! !

!DebugSession methodsFor: 'private' stamp: ''!
resumeProcess
	"Make sure the interrupted process is restored properly and restart the low space handler"
	
	interruptedProcess isTerminated
		ifFalse: [ 
			errorWasInUIProcess
				ifTrue: [ UIManager default resumeUIProcess: interruptedProcess ]
				ifFalse: [ interruptedProcess resume ]].

	"restart low space handler"
	Smalltalk installLowSpaceWatcher! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
peelToFirstLike: aContext
	"Peel the stack back to the second occurance of the currently selected message.  Very useful for an infinite recursion.  Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning.  Also frees a lot of space!!"

	| ctxt |
	self flag: 'should be called only on the selected context'.	
	(self isContextPostMortem: aContext) ifTrue: [^ self].

	ctxt := interruptedProcess popTo: aContext findSecondToOldestSimilarSender.
	self updateContextTo: ctxt.
	self contextChanged! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
stepInto

	self stepInto: interruptedContext! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
stepIntoUntil: aBlock
	[ aBlock cull: interruptedContext ]
		whileFalse: [ self stepInto: interruptedContext ]! !

!DebugSession methodsFor: 'accessing' stamp: ''!
exception 
	^ exception! !

!DebugSession methodsFor: 'accessing' stamp: ''!
name: aString
	name := aString! !

!DebugSession methodsFor: 'private' stamp: ''!
resumeProcessWithValue: aValue
	"Make sure the interrupted process is restored properly and restart the low space handler"
	
	self returnValue: aValue from: interruptedProcess suspendedContext.
	self resumeProcess! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
terminate
	"Action that needs to be executed after the window containing this debug session is closed, 
	in order to terminate the right process."
	
	self interruptedProcess 
		ifNotNil: [ 
			"Assume the user closed the debugger. Simply kill the interrupted process."
			self interruptedProcess terminate.
			self clear.
			Smalltalk installLowSpaceWatcher.  "restart low space handler" ]
		ifNil: [ 
			"Assume the interrupted process was resumed."
			"Kill the active process if the error was in the UI as there should be only one UI process."
			self isAboutUIProcess
				ifTrue: [Processor terminateActive] ]! !

!DebugSession methodsFor: '*NewTools-Debugger' stamp: ''!
application

	^ nil! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
stepThrough: aContext
	"Send messages until you return to selectedContext.
	 Used to step into a block in the method."
	aContext stepIntoQuickMethod: false.
	(self isContextPostMortem: aContext) ifTrue: [^ self].
	
	interruptedProcess stepToHome: aContext.
	self updateContextTo: (self stepToFirstInterestingBytecodeIn: interruptedProcess).
			
	self triggerEvent: #stepThrough! !

!DebugSession methodsFor: 'updating' stamp: ''!
updateWithContext: newContext fromProcess: aProcess

	self process: aProcess context: newContext! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
resume: aValue
	"Proceed execution of the receiver's model, starting after the expression at 
	which an interruption occurred."

	"If the user of this session does not plan to reuse it, it should call 'self clean' "

	Smalltalk okayToProceedEvenIfSpaceIsLow
		ifFalse: [ ^ self ].
	(self isContextPostMortem: self interruptedContext)
		ifTrue: [ ^ self ].
	self resumeProcessWithValue: aValue.
	self triggerEvent: #resume! !

!DebugSession methodsFor: 'testing' stamp: ''!
isContextPostMortem: selectedContext
	"return whether we're inspecting a frozen exception without a process attached"
	| suspendedContext |
	suspendedContext := interruptedProcess suspendedContext.
	suspendedContext ifNil: [ ^ false ].
	^ (suspendedContext hasContext: selectedContext) not.! !

!DebugSession methodsFor: 'logging' stamp: ''!
logStackToFileIfNeeded
	self class logDebuggerStackToFile ifFalse: [ ^self ].
	
	[[Smalltalk logError: name inContext: interruptedContext  ] onErrorDo: [ ]]
		valueWithin: 100 milliSeconds onTimeout: [  ]! !

!DebugSession methodsFor: 'evaluating' stamp: ''!
implement: aMessage classified: aSymbol inClass: aClass forContext: aContext
	
	aClass
		compile: (DynamicMessageImplementor for: aMessage in: aClass) value
		classified: aSymbol.

	aContext privRefreshWith: (aClass lookupSelector: aMessage selector).
	aContext method numArgs > 0 ifTrue:
		[aMessage arguments withIndexDo:
			[:arg :index|
				aContext tempAt: index put: arg]].
		
	self updateContextTo: aContext.
	self contextChanged! !

!DebugSession methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!DebugSession methodsFor: 'accessing' stamp: ''!
selectedCodeRangeForContext: selectedContext

	^ self pcRangeForContext: selectedContext! !

!DebugSession methodsFor: 'accessing' stamp: ''!
stackOfSize: size

	^ interruptedContext stackOfSize: size! !

!DebugSession methodsFor: 'accessing' stamp: ''!
stackOfSize: limit usingFilters: stackFilters
	"Answer an OrderedCollection of the top 'limit' contexts on the receiver's sender chain, according to the given filters.
	
	Consider the following stack:   
		a <-- top of the stack
		b
		a
		c
		a
		b
		d
		e
		a <-- bottom of the stack
		
	If the given filters do not match context 'a' and 'b' the following stack will be returned:
		a <-- top of the stack
		b
		a
		c
		d
		e <-- bottom of the stack
		
	First all consecutive contexts starting from the top of the stack for which a filter does not match are 
	added to the result (a b a in the example). Then from the remaining stack only the context for which all
	filters match are added to the  result.
	"

	| stack context |
	stack := OrderedCollection new.
	context := interruptedContext.
	
	"Starting from the top of the stack add all consecutive contexts that should not be displayed."
	[ context ~~ nil
	 	and: [(stack size < limit)
			and: [ (self shouldDisplayContext: context basedOnFilters:  stackFilters) not ] ] ]  whileTrue: [
				stack addLast: context.
				context := context sender ].

	"Add all contexts that should be displayed. (the current context is checked again)"
	[context ~~ nil
		and: [stack size < limit ] ] whileTrue: [
			(self shouldDisplayContext: context basedOnFilters: stackFilters) 
				ifTrue: [ stack addLast: context ].
			context := context sender ].
	^ stack! !

!DebugSession methodsFor: 'initialization' stamp: ''!
detectUIProcess

	errorWasInUIProcess := UIManager default uiProcess == interruptedProcess! !

!DebugSession methodsFor: 'testing' stamp: ''!
isTestMethod: aCompiledMethod of: aTestCase

	^ aCompiledMethod selector = aTestCase selector! !

!DebugSession methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
shortStack
	^self stackOfSize: self shortStackSize! !

!DebugSession methodsFor: 'private' stamp: ''!
stepToFirstInterestingBytecodeIn: aProcess
	"After a restart of a method activation step to the first 
	bytecode instruction that is of interest for the debugger.
	
	In this case step until a bytecode that causes a context switch,
	as otherwise one will have to press may time step into without 
	seeing any visible results."
	
	"If we are are stepping into a quick method,
	make sure that we step correctly over the first primitive bytecode"
	| suspendedContext |
	suspendedContext := aProcess suspendedContext.
	suspendedContext method isQuick
		ifTrue: [ ^ suspendedContext updatePCForQuickPrimitiveRestart ].
	
	^ aProcess stepToSendOrReturn! !

!DebugSession methodsFor: 'initialization' stamp: ''!
errorWasInUIProcess: aBoolean

	errorWasInUIProcess := aBoolean! !

!DebugSession methodsFor: 'testing' stamp: ''!
isInterruptedContextDoesNotUnderstand	
	
	^ self interruptedContext selector == #doesNotUnderstand:! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
recompileMethodTo: text inContext: aContext notifying: aNotifyer
	"The retrieved information has changed and its source must now be updated.
	 In this case, the retrieved information is the method of the given context."

	| newMethod recompilationContext canRewind |
	canRewind := (self isContextPostMortem: self interruptedContext) not.
	"Do not try to recompile a doIt method"
	aContext method isDoIt
		ifTrue: [ UIManager default alert:  'Can not modify a DoIt-Method.'.
			^ false ].
	(recompilationContext := (self createModelForContext: aContext) locateClosureHomeWithContent: text) ifNil: [ ^ false ].
	canRewind
		ifFalse: [ (self confirm: 'Can not rewind post mortem context for new method.\ Accept anyway ?' withCRs) or: [ ^ false ] ].
	
	newMethod := (self createModelForContext: recompilationContext) recompileCurrentMethodTo: text notifying: aNotifyer.
	newMethod ifNil: [ ^ false ].
		
	(self isContextPostMortem: self interruptedContext)
		ifFalse: [ self rewindContextToMethod: newMethod fromContext: recompilationContext ].

	"Use an alarm instead of triggering the notification directly, as the content of
	the editor can still be unaccepted. "
	self installAlarm: #contextChanged.
	^ true! !

!DebugSession methodsFor: 'debugging actions' stamp: ''!
stepOver

	self stepOver: interruptedContext! !

!DebugSession class methodsFor: 'settings' stamp: ''!
logDebuggerStackToFile
	^ LogDebuggerStackToFile ifNil: [LogDebuggerStackToFile := true]! !

!DebugSession class methodsFor: 'instance creation' stamp: ''!
named: aString on: aProcess startedAt: aContext
	^ self new
		name: aString;
		process: aProcess context: aContext;
		detectUIProcess! !

!DebugSession class methodsFor: 'settings' stamp: ''!
logDebuggerStackToFile: aBoolean
	LogDebuggerStackToFile := aBoolean! !

!DebugSessionContexts2Test methodsFor: 'tests' stamp: ''!
testInterruptedContext
	"Checks that the interruptedContext of the debug session is the last context the execution went through that contains the user's code and not the debugging machinery."

	"With fullblocks the method of the suspended context is a compiledBlock, not the method having it"
	| expectedMethod |
	expectedMethod := (self class >> #setUp) literalAt: 2.

	self assert: (session interruptedContext method) equals: expectedMethod.! !

!DebugSessionContexts2Test methodsFor: 'tests' stamp: ''!
testContextsAfterStepInto
	"Checks that after one step into of the debug session, the suspendedContext of its interruptedProcess is at the user's code (not in the debugging machinery) and is the same object as the interruptedContext of the DebugSession."

	| expectedMethod |

	session stepInto.
	expectedMethod := (self class >> #setUp) literalAt: 2.

	self
		assert: session interruptedProcess suspendedContext method
		equals: expectedMethod.

	self
		assert: session interruptedProcess suspendedContext
		identicalTo: session interruptedContext! !

!DebugSessionContexts2Test methodsFor: 'tests' stamp: ''!
testSuspendedContext
	"Checks that the suspendedContext of the interruptedProcess of a DebugSession is the last context the execution was at when its process was suspended."
	self assert: (session interruptedProcess suspendedContext method) equals: MyHalt>>#defaultAction.! !

!DebugSessionContexts2Test methodsFor: 'running' stamp: ''!
setUp
	"Creates a debugSession in a way that mimicks the real way DebugSessions are created normally in the image (in a process, a halt is raised, the process creates a debugSession and gets suspended). Note that this isn't a perfect replica of the normal way a debugSession gets created, because the normal way involves the UIManager and would create a pre-debug window."
	super setUp.
	process := [ 1 + 1.
	MyHalt signal ] fork.
	"The line under is a bit dirty. It is to make sure that the debugged process has suspended itself before it is being examined by the test methods."
	[process isSuspended] whileFalse: [ 100 milliSeconds wait. ].
	session := self class debugSession.! !

!DebugSessionContexts2Test class methodsFor: 'instance creation' stamp: ''!
debugSession: aValue
	debugSession := aValue! !

!DebugSessionContexts2Test class methodsFor: 'accessing' stamp: ''!
debugSession
	^ debugSession! !

!DebugSessionContextsTest methodsFor: 'tests' stamp: ''!
testInitialContentOfInterruptedContext
	"Checks that the interruptedContext of the DebugSession is the thisContext of the code where the DebugSession was created"
	self assert: ((process suspendedContext readVariableNamed: #debugSession) interruptedContext ) identicalTo: debuggedThisContext.! !

!DebugSessionContextsTest methodsFor: 'tests' stamp: ''!
testInitialContentOfSuspendedContext
	"Checks that the interruptedContext of the DebugSession is the thisContext of the code where the DebugSession was created"
	self assert: ((process suspendedContext readVariableNamed: #debugSession) interruptedProcess suspendedContext) identicalTo: debuggedThisContext.! !

!DebugSessionContextsTest methodsFor: 'running' stamp: ''!
setUp
	"Creates a debugSession in a way that mimicks the real way DebugSessions are created normally in the image (in a process, a halt is raised, the process creates a debugSession and gets suspended). Note that this isn't a perfect replica of the normal way a debugSession gets created, because the normal way involves the UIManager and would create a pre-debug window."

	super setUp.
	process := [ | debugSession |
	debugSession := Processor activeProcess newDebugSessionNamed: 'test' startedAt: (debuggedThisContext := thisContext).
	Processor activeProcess suspend ] fork.
	"The line under is a bit dirty. It is to make sure that the debugged process has suspended itself before it is being examined by the test methods."
	[ process isSuspended ] whileFalse: [ 100 milliSeconds wait ]! !

!DebuggedExecutionException methodsFor: 'testing' stamp: ''!
isExceptionSignalledForDebuggedExecution
	^ true! !

!DebuggerEmmergencyLogger commentStamp: ''!
I am a simple logger dedicated to handle errors that could not be handled by any other tool in the system.

I log this error by:
- informing you that this error could not be handled
- using the `Smalltalk` log api to write in the _PharoDebug.log_ file
!
!DebuggerEmmergencyLogger methodsFor: 'API' stamp: ''!
debugError: anError fromSession: aDebugSession

	self logError: anError forSession: aDebugSession! !

!DebuggerEmmergencyLogger methodsFor: 'API' stamp: ''!
logError: anError forSession: aDebugSession

	| errDescription errStream |
	errDescription := [ anError description ]
		                  on: Error
		                  do: [ 'a ' , anError class printString ].
	errStream := WriteStream on: String new.
	errStream cr.
	errStream << ('Original error: ' , aDebugSession name asString , '.').
	errStream cr.
	errStream << ('Debugger error: ' , errDescription).
	errStream cr.

	self inform: '**Debugger opening error** ' , errStream contents.
	[ 
	Smalltalk
		logError: errStream contents
		inContext: aDebugSession interruptedContext ]
		on: Error
		do: [ :err | 
			self inform:
				'Cannot log error: ' , anError printString , 'due to error: '
				, err printString ]! !

!DebuggerMethodMapOpal commentStamp: ''!
I provide helper methods deadling with

-> pc to text mapping
-> temporary variables for contexts
-> reading and setting tempary variables

All methods here habe been moved to Context!
!DebuggerMethodMapOpal methodsFor: 'initialization' stamp: ''!
forMethod: aCompiledMethod
	self deprecated: 'please use the reflactive API directly to read variables!!'.
	methodNode := aCompiledMethod ast! !

!DebuggerMethodMapOpal class methodsFor: 'instance creation' stamp: ''!
forMethod: aMethod "<CompiledMethod>"
	"Answer a DebuggerMethodMap suitable for debugging activations of aMethod"
	^self new forMethod: aMethod
	
				! !

!DebuggerModelTest commentStamp: ''!
SUnit tests for the debugger model!
!DebuggerModelTest methodsFor: 'tests' stamp: ''!
testUnwindAndRestartToContext
	
	context := [ 2 squared ] asContext.
	process := Process 
		forContext: context 
		priority: Processor userInterruptPriority.
		
	session:= process newDebugSessionNamed: 'test session' startedAt: context.
	
	context := context step.
	context := context step.
	process suspendedContext: context.
	session updateContextTo: context.		
	
	session unwindAndRestartToContext: session interruptedContext.
	self assert: session interruptedContext method equals: (Number >> #squared).
	"After restarting a context, we step to the first interesting bytecode, that is either a send or a return.
	In the (Number >> #squared) method, the first send is the third bytecode.
	So, after restarting, the context's pc should be equal to the initialPC (first bytecode) + 2 (third bytecode = send)"
	self assert: session interruptedContext pc equals: (Number >> #squared) initialPC + 2! !

!DebuggerModelTest methodsFor: 'tests' stamp: ''!
testClearDebugSession

	session clear.
	self assert: session exception equals: nil.
	self assert: session interruptedContext equals: nil.
	self assert: session interruptedProcess equals: nil! !

!DebuggerModelTest methodsFor: 'tests' stamp: ''!
testStepOver

	self assert: session interruptedContext equals: context.
	self assert: session interruptedContext printString equals: '[ Set new ] in DebuggerModelTest>>setUp' .

	session stepOver.

	self assert: session interruptedContext printString equals: '[ Set new ] in DebuggerModelTest>>setUp'.! !

!DebuggerModelTest methodsFor: 'tests' stamp: ''!
testStepInto

	self deny: (session isContextPostMortem: context).
	self assert: session interruptedContext equals: context.
	self assert: session interruptedContext printString equals: '[ Set new ] in DebuggerModelTest>>setUp' .

	session 
		stepInto;
		stepInto.

	self assert: session interruptedContext printString equals: 'Set class(HashedCollection class)>>new'.! !

!DebuggerModelTest methodsFor: 'tests' stamp: ''!
testUnwindAndRestartToQuickMethodContext
	
	context := [ #foo asSymbol ] asContext.
	process := Process 
		forContext: context 
		priority: Processor userInterruptPriority.
		
	session:= process newDebugSessionNamed: 'test session' startedAt: context.
	
	context := context step.			
	context stepIntoQuickMethod: true.
	context := context step.
	process suspendedContext: context.
	session updateContextTo: context.	
	
	session unwindAndRestartToContext: session interruptedContext.
	self assert: session interruptedContext method equals: (Symbol >> #asSymbol).
	self assert: session interruptedContext pc equals: (Symbol >> #asSymbol) endPC! !

!DebuggerModelTest methodsFor: 'tests' stamp: ''!
testCorrectlyCreateDebugSession

	self assert: session isNotNil.	
	self assert: process isSuspended.
	self assert: session interruptedContext equals: context.
	self assert: session interruptedContext printString equals: '[ Set new ] in DebuggerModelTest>>setUp'.! !

!DebuggerModelTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	context := [ Set new ] asContext.
	process := Process 
		forContext: context 
		priority: Processor userInterruptPriority.
		
	session:= process newDebugSessionNamed: 'test session' startedAt: context.! !

!DebuggerSettings commentStamp: ''!
General debugger settings with default values for TDebugger users!
!DebuggerSettings class methodsFor: 'settings' stamp: ''!
generalDebuggingSettingsOn: aBuilder

	<systemsettings>
	(aBuilder group: #debugging)
		label: 'Debugging';
		parent: #tools;
		description: 'All Debugger settings';
		with: [ 
			(aBuilder group: #deprecationHandling)
				label: 'Deprecation handling';
				description: 'How deprecation are handled';
				target: Deprecation;
				with: [ 
					(aBuilder setting: #activateTransformations)
						label:
							'Performs automatic transformations on deprecated methods';
						default: true;
						description:
							'If true, then the caller will be rewritten for each deprecated method invocation'.
					(aBuilder setting: #raiseWarning)
						label: 'Raise a blocking dialog';
						default: true;
						description:
							'If true, then a dialog is popup for each deprecated method invocation'.
					(aBuilder setting: #showWarning)
						label: 'Transcript message';
						default: true;
						description:
							'If true, then a message is send to the Transcript for each deprecated method invocation' ].

			(aBuilder setting: #logDebuggerStackToFile)
				label: 'Write message to debug log file when fall into debugger';
				target: DebugSession;
				default: true;
				description:
					'If true, whenever you fall into a debugger a summary of its stack will be written to a file named'.


			(aBuilder setting: #logFileName)
				label: 'Log file name';
				target: Smalltalk;
				default: 'PharoDebug.log';
				description:
					'A name of the file, which will be used for logging all errors and notifications' ]! !

!DebuggerSettings class methodsFor: 'accessing' stamp: ''!
defaultAvailability
	^true! !

!DebuggerSettings class methodsFor: 'accessing' stamp: ''!
emergencyDebugger

	^ self environment
		  at: #EDEmergencyDebugger
		  ifAbsent: [ DebuggerEmmergencyLogger new ]! !

!DebuggerSettings class methodsFor: 'settings' stamp: ''!
availableDebuggers

	^ (self systemDebuggers select: [ :dbgClass | 
		   dbgClass availableAutomatically ]) asOrderedCollection! !

!DebuggerSettings class methodsFor: 'settings' stamp: ''!
debuggerRankSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #debuggers)
		label: 'Debuggers';
		parent: #debugging.
	self systemDebuggers do: [ :debuggerClass | 
		(aBuilder group: debuggerClass name asSymbol)
			label: debuggerClass name;
			parent: #debuggers;
			with: [ 
				(aBuilder pickOne: #rank)
					label: 'Priority';
					target: debuggerClass;
					default: debuggerClass defaultDebuggerRank;
					domainValues: (1 to: 10);
					description:
						'Debugger priority: a debugger with a high priority will be chosen for debugging over a debugger with a low priority. 
Lowest priority: 1. Highest priority: 10'.
				(aBuilder setting: #availableAutomatically)
					label: 'Available';
					target: debuggerClass;
					default: self defaultAvailability;
					description:
						'(De)activates the debugger. A deactivated debugger will not be used by the system.' ] ]! !

!DebuggerSettings class methodsFor: 'settings' stamp: ''!
systemDebuggers

	^ (TDebugger users flatCollect: [ :class | class withAllSubclasses ]) 
		  reject: [ :class | class isTestCase ]! !

!DebuggerSettings class methodsFor: 'accessing' stamp: ''!
defaultDebuggerRank
	^1! !

!DebuggerTest commentStamp: ''!
Superclass for classes containing debugger tests.
Provides the ability to send #debuggerOnSetUpSession to a debugger test class to obtain a debugger opened on the debug session set up by that class for its tests.!
!DebuggerTest methodsFor: 'accessing' stamp: ''!
session
	^ session! !

!DebuggerTest methodsFor: 'utilities' stamp: ''!
settingUpSessionAndProcessAndContextForBlock: aBlock
	process := aBlock newProcess.
	[process step closure == aBlock] whileFalse.

	"We need to do an additional step to enter the execution of the block"
	process step.

	context := process suspendedContext.
	session := process newDebugSessionNamed: 'test session' startedAt: context.! !

!DebuggerTest methodsFor: 'utilities' stamp: ''!
inspectCurrentNode: aDebugSession
	context := aDebugSession interruptedContext.
	(context method sourceNodeForPC: context pc) inspect.! !

!DebuggerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	context := nil.
	process := nil.
	session := nil.! !

!DebuggerTestCaseForRestartTest methodsFor: 'running' stamp: ''!
testPushingValuesOnActivation

	| oldValue |
	"Test case to test the debugger restart.
	
	This test will run ok if run normally.
	However, if we step into this method and restart it, the debugger will re-execute the setUp, changing the value of testedValue.
	The test should be also be green after restarting."

	oldValue := testedValue.
	self assert: oldValue == testedValue.! !

!DebuggerTestCaseForRestartTest methodsFor: 'running' stamp: ''!
testedValue

	^ testedValue! !

!DebuggerTestCaseForRestartTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	"Initialize the test with some object.
	This value will change if the test is restarted.
	We use just a new object because we care about its identity"
	testedValue := Object new.! !

!DecoratorStream commentStamp: ''!
I am a basic decorator stream that will wrap a stream and forward messages to my decoree.

Subclass me to write a decorator that reuses some methods.!
!DecoratorStream methodsFor: 'decorating' stamp: ''!
position
	
	^ decoratedStream position! !

!DecoratorStream methodsFor: 'accessing' stamp: ''!
nextPut: anObject 
	"Insert the argument, anObject, as the next object accessible by the 
	receiver. Answer anObject."
	
	decoratedStream nextPut: anObject.
	^anObject! !

!DecoratorStream methodsFor: 'accessing' stamp: ''!
peek

	^ decoratedStream peek! !

!DecoratorStream methodsFor: 'accessing' stamp: ''!
next

	^ decoratedStream next! !

!DecoratorStream methodsFor: 'accessing' stamp: ''!
contents
	"Answer all of the contents of the receiver."

	^decoratedStream contents! !

!DecoratorStream methodsFor: 'storing' stamp: ''!
store: anObject

	anObject storeOn: self! !

!DecoratorStream methodsFor: 'testing' stamp: ''!
atEnd
	^ decoratedStream atEnd! !

!DecoratorStream methodsFor: 'initialize - release' stamp: ''!
on: aStream

	self initialize.
	decoratedStream := aStream.! !

!DecoratorStream class methodsFor: 'instance creation' stamp: ''!
on: aStream

	^ self basicNew
		on: aStream;
		yourself.! !

!DeepCopier commentStamp: ''!
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: ''!
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 	"

	<script: 'DeepCopier new checkDeep'>
	Warning signal:
			(String
				streamContents: [ :stream | 
					stream
						nextPutAll: '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: [ stream cr; tab.
												aClass name printOn: stream.
												stream space.
												(aClass allInstVarNames at: index) printOn: stream ] ] ] ] ])! !

!DeepCopier methodsFor: 'like fullCopy' stamp: ''!
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: 'checking' stamp: ''!
basicCheckClass: aClass
	"Every class that implements veryDeepInner: or veryDeepCopyWith: must copy all its inst vars.
	The danger is that a user will add a new instance variable and forget to copy it.
	
	This method will check those conditions on a class and return a collection of methods that looked suspicious.
	If you get a non-empty collection, an implementation of veryDeepCopyWith: or veryDeepInner: needs to be updated (check inside the collection).
	The idea is to catch a change while it is still in the system of the programmer who made it.
		
	This is an old method. We do not know why it is checking for the size of the method > 20, or the inclusion of the selector in the literals.
	May require a further refactor."
	| warnings |
	warnings := Set new.
	
	(aClass includesSelector: #veryDeepInner:) ifTrue: [ | veryDeepInnerMethod |
		veryDeepInnerMethod := aClass >> #veryDeepInner:.
		((self doesMethod: #veryDeepInner: writeAllInstanceVariablesOfClass: aClass)) ifFalse: [
			warnings add: veryDeepInnerMethod ]].
	
	(aClass includesSelector: #veryDeepCopyWith:) ifTrue: [ | veryDeepCopyWithMethod |
		veryDeepCopyWithMethod := aClass >> #veryDeepCopyWith:.
		(veryDeepCopyWithMethod size > 20) & (veryDeepCopyWithMethod literals includes: #veryDeepCopyWith:) not ifTrue: [
			(self doesMethod: #veryDeepCopyWith: writeAllInstanceVariablesOfClass: aClass) ifFalse: [
				warnings add: veryDeepCopyWithMethod]]].
	
	^ warnings! !

!DeepCopier methodsFor: 'checking' stamp: ''!
checkClass: aClass
	(self basicCheckClass: aClass)
		ifNotEmpty: [ :warnings | 
			Warning new
				messageText:
					'VeryDeepCopy out of sync in some classes. Some classes contain veryDeepCopyWith: or veryDeepInner: methods that are not in sync with their instance variables. Check the exception #tag for a list of them';
				tag: warnings;
				signal ]! !

!DeepCopier methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self initialize: 4096.! !

!DeepCopier methodsFor: 'like fullCopy' stamp: ''!
references
	^ references! !

!DeepCopier methodsFor: 'checking' stamp: ''!
doesMethod: aSelector writeAllInstanceVariablesOfClass: aClass

	"This method returns true if the method of the given selector writes all instance variables of the given class.
	As an optimization, this method only checks that the last instance variable is written, assuming that all the rest are being written if the last one is."
 
	| lastFieldIndex method hasNoInstanceVariables |
	hasNoInstanceVariables := aClass instSize = 0.
	
	lastFieldIndex := aClass instSize.
	method := aClass compiledMethodAt: aSelector. 
	^ hasNoInstanceVariables or: [ method writesField: lastFieldIndex ]! !

!DeepCopier methodsFor: 'checking' stamp: ''!
checkAllClasses

	| warnings |
	warnings := ((self systemNavigation allClassesImplementing: #veryDeepInner:),
		(self systemNavigation allClassesImplementing: #veryDeepCopyWith:)) flatCollect: [ :aClass |
			 self basicCheckClass: aClass ].
	
	self raiseWarningsIfAny: warnings! !

!DeepCopier methodsFor: 'initialization' stamp: ''!
initialize: size

	references := IdentityDictionary new: size.! !

!DeepCopier methodsFor: 'checking' stamp: ''!
raiseWarningsIfAny: warnings

	warnings ifNotEmpty: [
		Warning new
			messageText: 'VeryDeepCopy out of sync in some classes. Some classes contain veryDeepCopyWith: or veryDeepInner: methods that are not in sync with their instance variables. Check the exception #tag for a list of them';
			tag: warnings;
			signal ]! !

!DefaultExecutionEnvironment commentStamp: ''!
I am default execution environment which used when nothing special is installed on process.

I am singleton:
	DefaultExecutionEnvironment instance
	
Tools which define specific environments could add polymorphic behaviour to me!
!DefaultExecutionEnvironment methodsFor: '*SUnit-Core' stamp: ''!
maxTimeForTest: aDuration

	"just for compatibility with TestExecutionEnvironment, do nothing"! !

!DefaultExecutionEnvironment methodsFor: 'controlling' stamp: ''!
prepareForNewProcess: aProcess! !

!DefaultExecutionEnvironment methodsFor: '*SUnit-Core' stamp: ''!
runTestCase: aTestCase

	| testEnv |
	testEnv := TestExecutionEnvironment new.
	
	testEnv beActiveDuring: [
		testEnv runTestCase: aTestCase]! !

!DefaultExecutionEnvironment methodsFor: '*SUnit-Core' stamp: ''!
runTestsBy: aBlock

	TestExecutionEnvironment new beActiveDuring: aBlock! !

!DefaultExecutionEnvironment class methodsFor: 'accessing' stamp: ''!
instance
	^instance ifNil: [ instance := self new ]! !

!DefaultExecutionEnvironment class methodsFor: 'controlling' stamp: ''!
beActive

	CurrentExecutionEnvironment restoreDefault! !

!DefaultExecutionEnvironment class methodsFor: 'controlling' stamp: ''!
beActiveDuring: aBlock

	^self instance beActiveDuring: aBlock! !

!DefaultExternalDropHandler commentStamp: ''!
An alternative default handler that uses the file-list services to process files.
!
!DefaultExternalDropHandler methodsFor: 'private' stamp: ''!
unwantedSelectors
	"private - answer a collection well known unwanted selectors "
	^ #(#removeLineFeeds: #compressFile: )! !

!DefaultExternalDropHandler methodsFor: 'private' stamp: ''!
chooseServiceFrom: aCollection
	"private - choose a service from aCollection asking the user if  
	needed"
	aCollection size = 1
		ifTrue: [^ aCollection anyOne].
	^ UIManager default chooseFrom: (aCollection collect: [:each | each label]) values: aCollection.! !

!DefaultExternalDropHandler methodsFor: '*Morphic-Base' stamp: ''!
handle: aFileReference in: pasteUp dropEvent: anEvent
	"the file was just droped, let's do our job"

	| fileName services theOne |
	fileName := aFileReference fullName.
	services := self servicesForFileNamed: fileName.

	"no service, default behavior"
	services isEmpty
		ifTrue: [ aFileReference inspect.
			^ self ].
	theOne := self chooseServiceFrom: services.
	theOne ifNotNil: [ theOne performServiceFor: aFileReference ]! !

!DefaultExternalDropHandler methodsFor: 'private' stamp: ''!
servicesForFileNamed: aString 
	"private - answer a collection of file-services for the file named  
	aString"
	| allServices |
	allServices := FileServices itemsForFile: aString.
	^ allServices
		reject: [:svc | self unwantedSelectors includes: svc selector]! !

!DefaultExternalDropHandler class methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the receiver"
	ExternalDropHandler defaultHandler: self new! !

!DefaultExternalDropHandler class methodsFor: 'initialization' stamp: ''!
unload
	"initialize the receiver"
	ExternalDropHandler defaultHandler: nil! !

!DefaultSortFunction commentStamp: ''!
A DefaultSortFunction is a collator using the default threeWayCompareTo: operator.
It is known to work on String and Magnitude.

It is generally not useful to create a new instance, and the recommended pattern is to use the single instance available by sending the message  SortFunction default .

For other objects  that don't understand threeWayCompareTo: it is necessary to use a custom SortFunction rather than the default one.!
!DefaultSortFunction methodsFor: 'evaluating' stamp: ''!
collate: anObject with: anotherObject
	^anObject threeWayCompareTo: anotherObject! !

!DefaultSortFunction class methodsFor: 'class initialization' stamp: ''!
initialize
	Default := self new! !

!DefaultSortFunction class methodsFor: '*STON-Extensions' stamp: ''!
fromSton: stonReader
	"Overwritten to always return the default"
	
	self assert: stonReader parseMap isEmpty.
	^ SortFunction default! !

!DeflateStream commentStamp: ''!
I'm the base class for "stream compressor". For example, my subclass `GZipWriteStream` can compress a stream contents using gzip algorithm.

### Examples

```
gzData := String streamContents: [:aStream|
         (GZipWriteStream on: aStream)
                nextPutAll: 'Some data to be gzipped';
                close. ].
Transcript 
        show: gzData; 
        cr;
        show: (GZipReadStream on: gzData) upToEnd;
        cr.
```
See `InflateStream`!
!DeflateStream methodsFor: 'deflating' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
pastEndPut: anObject
	self deflateBlock.
	^self nextPut: anObject! !

!DeflateStream methodsFor: 'accessing' stamp: 'nil'!
goodMatchLength
	"Return the length that is considered to be a 'good' match.
	Higher values will result in better compression but take more time."
	^MaxMatch "Best compression"! !

!DeflateStream methodsFor: 'deflating' stamp: 'nil'!
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: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	blockPosition := 0.
	hashValue := 0.
	self initializeHashTables! !

!DeflateStream methodsFor: 'deflating' stamp: 'nil'!
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 + 1 > writeLimit)
			ifTrue:[lastIndex := writeLimit - MaxMatch - 1]
			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: 'private' stamp: 'nil'!
updateHashTable: table delta: delta
	| pos |
	<primitive: 'primitiveDeflateUpdateHashTable' module: 'ZipPlugin'>
	1 to: table size do:[:i|
		"Discard entries that are out of range"
		(pos := table at: i) >= delta
			ifTrue:[table at: i put: pos - delta]
			ifFalse:[table at: i put: 0]].! !

!DeflateStream methodsFor: 'deflating' stamp: 'nil'!
findMatch: here lastLength: lastLength lastMatch: lastMatch chainLength: maxChainLength goodMatch: goodMatch
	"Find the longest match for the string starting at here.
	If there is no match longer than lastLength return lastMatch/lastLength.
	Traverse at most maxChainLength entries in the hash table.
	Stop if a match of at least goodMatch size has been found."
	| matchResult matchPos distance chainLength limit bestLength length |
	"Compute the default match result"
	matchResult := (lastLength bitShift: 16) bitOr: lastMatch.

	"There is no way to find a better match than MaxMatch"
	lastLength >= MaxMatch ifTrue:[^matchResult].

	"Start position for searches"
	matchPos := hashHead at: (self updateHashAt: here + MinMatch) + 1.

	"Compute the distance to the (possible) match"
	distance := here - matchPos.

	"Note: It is required that 0 < distance < MaxDistance"
	(distance > 0 and:[distance < MaxDistance]) ifFalse:[^matchResult].

	chainLength := maxChainLength.	"Max. nr of match chain to search"
	here > MaxDistance	"Limit for matches that are too old"
		ifTrue:[limit := here - MaxDistance]
		ifFalse:[limit := 0].

	"Best match length so far (current match must be larger to take effect)"
	bestLength := lastLength.

	["Compare the current string with the string at match position"
	length := self compare: here with: matchPos min: bestLength.
	"Truncate accidental matches beyound stream position"
	(here + length > position) ifTrue:[length := position - here].
	"Ignore very small matches if they are too far away"
	(length = MinMatch and:[(here - matchPos) > (MaxDistance // 4)])
		ifTrue:[length := MinMatch - 1].
	length > bestLength ifTrue:["We have a new (better) match than before"
		"Compute the new match result"
		matchResult := (length bitShift: 16) bitOr: matchPos.
		bestLength := length.
		"There is no way to find a better match than MaxMatch"
		bestLength >= MaxMatch ifTrue:[^matchResult].
		"But we may have a good, fast match"
		bestLength > goodMatch ifTrue:[^matchResult].
	].
	(chainLength := chainLength - 1) > 0] whileTrue:[
		"Compare with previous entry in hash chain"
		matchPos := hashTail at: (matchPos bitAnd: WindowMask) + 1.
		matchPos <= limit ifTrue:[^matchResult]. "Match position is too old"
	].
	^matchResult! !

!DeflateStream methodsFor: 'encoding' stamp: 'nil'!
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: 'deflating' stamp: 'nil'!
flushBlock
	"Flush a deflated block"! !

!DeflateStream methodsFor: 'initialization' stamp: 'nil'!
on: aCollection
	self initialize.
	super on: (aCollection species new: WindowSize * 2).! !

!DeflateStream methodsFor: 'deflating' stamp: 'nil'!
updateHashAt: here
	"Update the hash value at position here (one based)"
	^self updateHash: (collection byteAt: here)! !

!DeflateStream methodsFor: 'accessing' stamp: 'nil'!
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: 'nil'!
hashChainLength
	"Return the max. number of hash chains to traverse.
	Higher values will result in better compression but take more time."
	^4096 "Best compression"! !

!DeflateStream methodsFor: 'deflating' stamp: 'nil'!
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: 'initialization' stamp: 'nil'!
initializeHashTables
	hashHead := WordArray new: 1 << HashBits.
	hashTail := WordArray new: WindowSize.! !

!DeflateStream methodsFor: 'encoding' stamp: 'nil'!
encodeLiteral: literal
	"Encode the given literal.
	Return true if the current block needs to be flushed."
	^false! !

!DeflateStream methodsFor: 'initialization' stamp: 'nil'!
flush
	"Force compression"
	self deflateBlock.! !

!DeflateStream methodsFor: 'private' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
nextPutAll: aCollection
	^ self next: aCollection size putAll: aCollection startingAt: 1! !

!DeflateStream methodsFor: 'initialization' stamp: 'nil'!
on: aCollection from: firstIndex to: lastIndex
	"Not for DeflateStreams please"
	^self shouldNotImplement! !

!DeflateStream methodsFor: 'deflating' stamp: 'nil'!
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: 'deflating' stamp: 'nil'!
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! !

!Delay commentStamp: ''!
I am the main way that a process may pause for some amount of time.  
The simplest usage is like...
	(Delay forSeconds: 5) wait.   
or...
	5 seconds asDelay 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.  Delays work across  clock roll-overs.

The maximum possible delay depends on which delay ticker is used:
  * DelayMillisecondTicker uses a 32-bit value that rolls over about every six days, or SmallInteger maxVal // 2 milliseconds.
  * DelayMicrosecondTicker is 64-bit and rolls over every 50,000 years. 

A delay in progress when an image snapshot is suspended and resumed when the snapshot is re-started. 
i.e. from the image perspective of timing, the image snapshot never happened.
!
!Delay methodsFor: 'public' stamp: ''!
millisecondDelayDuration
	^millisecondDelayDuration! !

!Delay methodsFor: 'delaying' stamp: ''!
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: 'public' stamp: ''!
resumptionTick
	"The tick semantics (e.g. millisecond/microsecond) depends on the ticker its derived from."
	
	^resumptionTick! !

!Delay methodsFor: 'private - timing priority process' stamp: ''!
timingPriorityScheduleTicker: aDelayTicker
	beingWaitedOn ifTrue: [ ^false ]. "Already scheduled"
	beingWaitedOn := true.
	ticker := aDelayTicker. "To help Delay >> printOn: interpret resumptionTick"
	resumptionTick := ticker tickAfterMilliseconds: millisecondDelayDuration.
	^true! !

!Delay methodsFor: 'private - timing priority process' stamp: ''!
timingPriorityUnschedule
	""

	beingWaitedOn := false.

	"Important!! Must only be called from the single timing priority process e.g...
		DelayScheduler>>handleEventTimer."! !

!Delay methodsFor: 'public' stamp: ''!
resumptionTickAdjustFrom: oldBaseTick to: newBaseTick
	resumptionTick := resumptionTick - oldBaseTick + newBaseTick.! !

!Delay methodsFor: 'public' stamp: ''!
delaySemaphore

	^ delaySemaphore! !

!Delay methodsFor: 'private - timing priority process' stamp: ''!
timingPrioritySignalExpired
	"The delay time has elapsed; signal the waiting process."

	beingWaitedOn := false.
	delaySemaphore signal.

	"Important!! Must only be called from the single timing priority process e.g...
		DelayScheduler>>handleEventTimer."! !

!Delay methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll: '(';
		print: millisecondDelayDuration;
		nextPutAll: ' msecs'.
	beingWaitedOn
		ifTrue: [ 
			aStream
				nextPutAll: '; ';
				print: self millisecondsToGo;
				nextPutAll: ' msecs remaining' ].
	aStream nextPutAll: ')'.! !

!Delay methodsFor: 'private' stamp: ''!
unschedule
	self class scheduler unschedule: self.! !

!Delay methodsFor: 'private' stamp: ''!
setDelay: milliseconds
	"Private!! Initialize this delay to signal the given semaphore after the given number of milliseconds."

	millisecondDelayDuration := milliseconds asInteger! !

!Delay methodsFor: 'delaying' stamp: ''!
isExpired

	^delaySemaphore isSignaled.! !

!Delay methodsFor: 'private' stamp: ''!
schedule
	"Schedule this delay."
	
	self class scheduler schedule: self.! !

!Delay methodsFor: 'public' stamp: ''!
millisecondsToGo
	^ ticker millisecondsUntilTick: resumptionTick! !

!Delay methodsFor: 'private' stamp: ''!
setDelay: milliseconds forSemaphore: aSemaphore
	"Private!! Initialize this delay to signal the given semaphore after the given number of milliseconds."

	millisecondDelayDuration := milliseconds asInteger.
	millisecondDelayDuration < 0 ifTrue: [self error: 'delay times cannot be negative'].
	delaySemaphore := aSemaphore.
	beingWaitedOn := false.! !

!Delay methodsFor: 'public' stamp: ''!
beingWaitedOn
	"Answer whether this delay is currently scheduled, e.g., being waited on"
	^beingWaitedOn! !

!Delay class methodsFor: 'testing' stamp: ''!
anyActive
	"Return true if there is any delay currently active"
		^self scheduler anyActive! !

!Delay class methodsFor: 'snapshotting' stamp: ''!
startUp
	"Restart active delay, if any, when resuming a snapshot."

	self scheduler startUp.! !

!Delay class methodsFor: 'initialize-release' stamp: ''!
initialize
	"Delay initialize"
	self scheduler ifNotNil: [ self scheduler stopTimerEventLoop ].
	self scheduler: DelaySemaphoreScheduler new.
	self scheduler startTimerEventLoop. 
	SessionManager default 
		registerSystemClassNamed: self name 
		atPriority: 20.! !

!Delay class methodsFor: 'settings' stamp: ''!
delaySchedulerClass
	^self scheduler class! !

!Delay class methodsFor: 'settings' stamp: ''!
delaySchedulerClass: aSchedulerClass 
	| newScheduler oldScheduler |
	self delaySchedulerClass = aSchedulerClass ifTrue:[ ^self ].
	newScheduler := aSchedulerClass new.
	(newScheduler respondsTo: #startTimerEventLoop) 
		ifFalse: [ self error: 'New delay scheduler must respond to #startTimerEventLoop' ].
	newScheduler startTimerEventLoop.
	"To avoid lockup if a higher priority process preempts this method to schedule a delay,
	the newScheduler needs to be in place before oldScheduler is stopped"
	oldScheduler := self scheduler.
	self scheduler: newScheduler.
	oldScheduler stopTimerEventLoop.
	self inform: 'Delay scheduler set to ' , aSchedulerClass printString.! !

!Delay class methodsFor: 'timer process' stamp: ''!
stopTimerEventLoop

	^ self scheduler stopTimerEventLoop.! !

!Delay class methodsFor: 'instance creation' stamp: ''!
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; yourself! !

!Delay class methodsFor: 'scheduler' stamp: ''!
scheduler

	^ Scheduler.! !

!Delay class methodsFor: 'snapshotting' stamp: ''!
shutDown

	self scheduler shutDown.! !

!Delay class methodsFor: 'timer process' stamp: ''!
startTimerEventLoop

	self scheduler startTimerEventLoop.! !

!Delay class methodsFor: 'timer process' stamp: ''!
schedulingProcess

	^ self scheduler schedulingProcess.! !

!Delay class methodsFor: 'settings' stamp: ''!
systemSettingOn: aBuilder
	<systemsettings>
	
	(aBuilder pickOne: #delaySchedulerClass)
		parent: #pharoSystem ;
		target: self;
		label: 'Delay Scheduler' ;
		domainValues: DelayNullScheduler allSubclasses ;
		default: DelaySemaphoreScheduler;
		description: 'Choose the class to use for Delay scheduling.' , 
			String crlf, 'You can observe which is running from Tools > Process Browser.'! !

!Delay class methodsFor: 'timer process' stamp: ''!
restartTimerEventLoop
	self stopTimerEventLoop.
	self startTimerEventLoop.! !

!Delay class methodsFor: 'instance creation' stamp: ''!
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.
	
	WARNING: There may be a minimal delay time that depends on the system activity and setting of the idle process. See ProcessorScheduler class >> idleTime "

	^ self new setDelay: aNumber forSemaphore: Semaphore new! !

!Delay class methodsFor: 'scheduler' stamp: ''!
scheduler: anObject

	Scheduler := anObject.! !

!Delay class methodsFor: 'instance creation' stamp: ''!
forDuration: aDuration
 	"Return a new Delay for the given duration."
 	^ self forMilliseconds: aDuration asMilliSeconds! !

!Delay class methodsFor: 'testing' stamp: ''!
nextWakeUpTime

	^ self scheduler nextWakeUpTime.! !

!Delay class methodsFor: 'instance creation' stamp: ''!
forSeconds: aNumber
	"Return a new Delay for the given number of Seconds"
	^ self forMilliseconds: aNumber * 1000! !

!DelayBasicScheduler commentStamp: ''!
I schedule delays in a basic way independent of any particular time-base
and without any special multi-threaded synchronisation protection. 

I provide the delay scheduling loop running as the system's highest priority process 
waiting for user delay scheduling events or VM events indicating a delay needs to be expired.
I manage suspendedDelays as a Heap sorted by the resumption time of the delay.

My main collaborators are:
Delay - holds the resumptionTick calculated by the ticker
Delay{time-base}Ticker - time-base specific interaction with VM and calculation of resumptionTicks 

USER-API 
#schedule: aDelay
	Forwards delay from user-thread to #timingPrioritySchedule: thread (via signalling #timingPriorityRunEventLoop) 

#unschedule: aDelay
	Forwards delay from user-thread to #timingPriorityUnschedule: thread (via signalling #timingPriorityRunEventLoop) 
	

SYSTEM-API
#startTimerEventLoop{Priority:}
	creates a process runnning the delay scheduling loop, customisable priority to help unit testing

#stopTimeEventLoop
	flags the delay scheduling loop to execute and expire all suspended delays

#shutDown
	suspend the delay scheduling loop to facilite clean snapshot 

#startUp
	unsuspend delay scheduling loop when snapshot resumes


INTERNAL - TIMING PRIORITY FACILITIES
timingPriority is the highest priority process in the system

#timingPriorityRunEventLoop 
	outer loop uses the ticker to wait for VM or user signals
	handles suspend-loop requests from #shutDown 
	invokes the main event handler
	when loop exits, signals all remaining suspendedDelays

#timingPriorityHandleEvent
	the main event handler
	hands delays to the next two methods...

#timingPrioritySchedule: aDelay
   inserts into suspendedDelays and determines activeDelay

#timingPriorityUnSchedule: aDelay
   deletes from suspendedDelays and determines activeDelay


INTERNAL - SYNCHRONISATION
Lacking synchronisation protection I rely solely on the implict semantics of process scheduling.
Specifically, in #schedule:/#unschedule there can be no suspension point between 
the variable assignment and the following #signal which transfers execution to the highest priority process that consumes and clears the variable. In practice this currently works quite well,
but is fragile wrt changing process scheduling semantics.  Subclasses add specific synchronisation
protection.!
!DelayBasicScheduler methodsFor: 'private - timing priority process' stamp: ''!
unscheduleAtTimingPriority
	"Private!! Invoke only from the timing-priority process.
	 This is the back-half of unscheduling a delay. For front-half see #unschedule:"
	
	delayToStop beingWaitedOn ifFalse:[ ^self ].
	
	activeDelay == delayToStop 
		ifTrue: [ activeDelay := suspendedDelays removeFirstOrNil ] 
		ifFalse:[ suspendedDelays remove: delayToStop ifAbsent: [] ].
	
	delayToStop timingPriorityUnschedule.
	delayToStop := nil.! !

!DelayBasicScheduler methodsFor: 'testing' stamp: ''!
anyActive
	"Return true if there is any delay currently active"
	^activeDelay notNil! !

!DelayBasicScheduler methodsFor: 'support - test cases' stamp: ''!
simulate_vmMilliseconds: milliseconds 
	"This method is only called from tests which make use of the 'simulation' tickers 
	which implement the next method."
	ticker simulate_vmMilliseconds: milliseconds.! !

!DelayBasicScheduler methodsFor: 'initialization' stamp: ''!
initialize
	"Default configuration."

	self initializeTicker: (DelayMicrosecondTicker new) 
		  suspendedDelaysHeap: DelayBasicScheduler defaultSuspendedDelaysHeap.! !

!DelayBasicScheduler methodsFor: 'system-api' stamp: ''!
startUp
	self resume! !

!DelayBasicScheduler methodsFor: 'system-api' stamp: ''!
stopTimerEventLoop
	"Stop the timingpriority event loop"	
		
	runTimerEventLoop := false.
	"Transfer execution to #timingPriorityWaitForUserOrDelay:"
	timingSemaphore signal. 
	
	"In normal operation the timingpriority event loop process should already have terminated, 
	but things can get out of order with multi-threaded debuggin. Ensure its terminated." 
	timerEventLoop isTerminated  
		ifFalse: [ 
			self error: 'Expected timing priority event loop terminated already'.
			timerEventLoop terminate ].
	timerEventLoop := nil.! !

!DelayBasicScheduler methodsFor: 'user-api' stamp: ''!
suspend
	"This is the front-half for suspending the delay scheduler to prevent
	 wake-up of delayed threads in the middle of snapshotting.
	 For back-half see #suspendAtTimingPriority"

	suspendSemaphore := Semaphore new.
	timingSemaphore signal.	
		
	"That #signal transfers execution to timingPriorityRunEventLoop 
	 which then waits for suspendSemaphore to be signalled from #startup"! !

!DelayBasicScheduler methodsFor: 'initialization' stamp: ''!
initializeTicker: aDelayTicker suspendedDelaysHeap: aHeap
	ticker := aDelayTicker.
	suspendedDelays := aHeap.
	timingSemaphore := Semaphore new! !

!DelayBasicScheduler methodsFor: 'user-api' stamp: ''!
unschedule: aDelay
	"This is the front-half of unscheduling a delay. Invoked from user processes. 
	 For back-half see #unscheduleAtTimingPriority"

	"The basic scheduler is highly dependant on semantics of cooperative multitasking and 
	 bytecode inlining such that interruption *cannot* occur between the assignment and the signal.
	 The #signal immediately transfers execution to timing-priority #runTimerEventLoop
	 such that no other thread can overwrite our value until consumed by timing-priority thread.
	 Subclasses add protection against this."
	delayToStop := aDelay.
	timingSemaphore signal. "Transfer execution to #unscheduleAtTimingPriority"! !

!DelayBasicScheduler methodsFor: 'user-api' stamp: ''!
schedule: aDelay
	"This is the front-half of scheduling a delay. Invoked from user processes. 
	 For back-half see #scheduleAtTimingPriority"
	
	"Only one signal is sent when delay expires, and if that is already spoken for"
	aDelay beingWaitedOn ifTrue: [^self error: 'This Delay has already been scheduled.'].
	
	"The basic scheduler is highly dependant on semantics of cooperative multitasking and 
	 bytecode inlining such that interruption *cannot* occur between the following assignment and signal.
	 The #signal immediately transfers execution to timing-priority #runTimerEventLoop
	 such that no other thread can overwrite our value until consumed by timing-priority thread.
	 Subclasses provide addition protections to lessen the importance of these semantics."
	delayToStart := aDelay.
	timingSemaphore signal. "Transfer execution to back-end #scheduleAtTimingPriority"! !

!DelayBasicScheduler methodsFor: 'system-api' stamp: ''!
shutDown
	self suspend! !

!DelayBasicScheduler methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream 
		nextPutAll: '(';
		print: self identityHash ;
		nextPutAll: ') on ' ;
		nextPutAll: ticker className.! !

!DelayBasicScheduler methodsFor: 'user-api' stamp: ''!
resume
	"Unsuspend the timing-priority delay scheduling loop when resuming a snapshot."
	
	suspendSemaphore
		ifNil:[ ^self error: 'Not suspended' ].
	suspendSemaphore signal. 
	"signal transfers execution to #suspendAtTimingPriority, 
	 which does... suspendSemaphore := nil."! !

!DelayBasicScheduler methodsFor: 'system-api' stamp: ''!
schedulingProcess
	^ timerEventLoop! !

!DelayBasicScheduler methodsFor: 'system-api' stamp: ''!
startTimerEventLoop
	"Start the timer event loop"
	"Delay restartTimerEventLoop"
	
	self startTimerEventLoopPriority: Processor timingPriority! !

!DelayBasicScheduler methodsFor: 'system-api' stamp: ''!
startTimerEventLoopPriority: processorPriority
	"Start the timer event loop"
	"Delay restartTimerEventLoop"
	
	timerEventLoop ifNotNil: [ self error: 'Timer event loop has already been started.' ].
	
	runTimerEventLoop := true.
	
	timerEventLoop := [ self runBackendLoopAtTimingPriority ] newProcess.
	timerEventLoop 
		name: self className , '(' , ticker className, ')';
		priority: processorPriority.
	timerEventLoop resume.! !

!DelayBasicScheduler methodsFor: 'system-api' stamp: ''!
restartTimerEventLoop
	"Start the timer event loop"
	"Delay restartTimerEventLoop"
	self stopTimerEventLoop.
	self startTimerEventLoop.! !

!DelayBasicScheduler methodsFor: 'private - timing priority process' stamp: ''!
suspendAtTimingPriority
	"Private!! This is the front-half for suspending the delay scheduler to prevent
	 wake-up of delayed threads in the middle of snapshotting. For front-half see #suspend"
	
	ticker saveResumptionTimes: suspendedDelays asArray, {activeDelay}.
	"Warning!! Stepping <Over> the following line may lock the Image. Use <Proceed>."
	suspendSemaphore wait.
	
	ticker restoreResumptionTimes: suspendedDelays asArray, {activeDelay}.  
	suspendSemaphore := nil! !

!DelayBasicScheduler methodsFor: 'private - timing priority process' stamp: ''!
runBackendLoopAtTimingPriority
	"Private!! Outer loop for the timing priority timer event loop.
	 Invoked by api-system #startTimerEventLoop"

	"Unit tests may run this at a lower priority" 
	[  [runTimerEventLoop] whileTrue: 
		[	|nowTick|
			"Warning!! Stepping <Over> the following line may lock the Image. Use <Into> or <Proceed>."
		 	ticker waitForUserSignalled: timingSemaphore orExpired: activeDelay. 

			"Invoke the api back-ends, which set the transfer-variable to nil" 		
			suspendSemaphore ifNotNil: [ self suspendAtTimingPriority    ].
			delayToStart     ifNotNil: [ self scheduleAtTimingPriority   ].
			delayToStop      ifNotNil: [ self unscheduleAtTimingPriority ].

			"Signal any expired delays"
			nowTick := ticker nowTick.
			[ 	activeDelay notNil and: [nowTick >= activeDelay resumptionTick] ] 
					whileTrue: [
						activeDelay timingPrioritySignalExpired.
						activeDelay := suspendedDelays removeFirstOrNil ].
		]
	] ensure: [ "When timer event loop exits, expire remaining delays."
		[activeDelay notNil] whileTrue: [
				activeDelay timingPrioritySignalExpired.
				activeDelay := suspendedDelays removeFirstOrNil ]].! !

!DelayBasicScheduler methodsFor: 'testing' stamp: ''!
nextWakeUpTime
	^ activeDelay 
			ifNil: [ 0 ]
			ifNotNil: [ :delay | delay resumptionTick ]! !

!DelayBasicScheduler methodsFor: 'system-api' stamp: ''!
ticker
	^ticker! !

!DelayBasicScheduler methodsFor: 'private - timing priority process' stamp: ''!
scheduleAtTimingPriority
	"Private!! Invoke only from the timing-priority process.
	 This is the back-half of scheduling a delay. For front-half see #schedule:"
	
	(delayToStart timingPriorityScheduleTicker: ticker) ifFalse:[ ^self ]. "Already scheduled"

	activeDelay 
		ifNil: [ activeDelay := delayToStart ]
		ifNotNil: [
			delayToStart resumptionTick < activeDelay resumptionTick
				ifTrue: [
					suspendedDelays add: activeDelay.
					activeDelay := delayToStart ]
				ifFalse: [ suspendedDelays add: delayToStart ]].
	delayToStart := nil! !

!DelayBasicScheduler class methodsFor: 'accessing' stamp: ''!
defaultSuspendedDelaysHeap
	 ^ Heap 
			sortBlock: [ :delay1 :delay2 | 
				delay1 resumptionTick <= delay2 resumptionTick ]! !

!DelayBasicScheduler class methodsFor: 'instance creation' stamp: ''!
onTicker: aDelayTicker suspendedDelaysHeap: aHeap
	"Facilitates unit tests examining the otherwise hidden suspendedDelays variable"
	^self basicNew initializeTicker: aDelayTicker suspendedDelaysHeap: aHeap! !

!DelayBasicSchedulerMicrosecondTickerTest commentStamp: ''!
I specify the tests for the delay scheduler system. My subclasses inherit 
these tests to run against various combinations of scheduler and ticker.   

The scheduler is specified by #classForScheduler.
The ticker is specified by #classForTicker.

I specifically test...
  scheduler DelayBasicScheduler together with its default 
  ticker DelayMicrosecondTicker.

My #setUp method starts a new scheduler process running at a priority slightly higher than 
the tests, so that it will preempt the tests similar to how the system's current delay scheduler
running at timingPriority will normally preempt all other processes.  This is provided
to tests in the /scheduler/ variable.!
!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testMillisecondsToGoExpired
	| delay |
	delay := Delay forMilliseconds: 100.
	
	scheduler simulate_vmMilliseconds: 1.
	scheduler schedule: delay.

	scheduler simulate_vmMilliseconds: 200.
	"self assert: delay millisecondsToGo equals: 0."! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testDelayWaitTimeoutTimedOut
	| completed delay status |
	completed := Semaphore new.
	delay := DelayWaitTimeout new setDelay: 100 forSemaphore: completed.

	delay waitOnCompletion: [ status := #completed ] onTimeout: [ status := #timedOut ].
	self assert: status equals: #timedOut! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testSimpleOneDelay
	"
	Event loop priority takes So it takes priority over following code"
	|delay|
	delay := Delay new setDelay: 2"ms" forSemaphore: Semaphore new.
	 
	scheduler simulate_vmMilliseconds: 10.
	self deny: delay beingWaitedOn.
	scheduler schedule: delay.
	self assert: delay beingWaitedOn.

	scheduler simulate_vmMilliseconds: 11.
	self deny: delay isExpired. 
	
	scheduler simulate_vmMilliseconds: 12.
	self assert: delay isExpired! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
classForScheduler
	^ DelayBasicScheduler! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
classForTicker
	^ DelayMicrosecondTickerSimulation! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testDelayWaitTimeoutCompleted
	| completed delay status |
	completed := Semaphore new.
	delay := DelayWaitTimeout new setDelay: 100 forSemaphore: completed.
	completed signal.
	
	delay waitOnCompletion: [ status := #completed ] onTimeout: [ status := #timedOut ].
	self assert: status equals: #completed! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testDurationMoreThanMaxTicks
	"In #handleTimerEvent the maximum tick is hardcoded as 1000 milliseconds.
	 Test when delay duration is less than this.
		- duration is in milliseconds.
		- ticks are in microseconds"
	| delay |
	delay := Delay new setDelay: 1234"ms" forSemaphore: Semaphore new.

	scheduler simulate_vmMilliseconds: 100.
	scheduler schedule: delay.
	self assert: ticker vmSimNextWakeupMilliseconds equals: 100 + 1000! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testStartStop
	|error|
	error := false.
	"scheduler previously started in #setUp"
	[scheduler stopTimerEventLoop] on: Error do: [ error := true ].
	self deny: error! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testHeapForwards
	|delay1 delay2 delay3 delay4|
	delay1 := Delay forMilliseconds: 1.
	delay2 := Delay forMilliseconds: 2.
	delay3 := Delay forMilliseconds: 3.
	delay4 := Delay forMilliseconds: 4.
	
	scheduler schedule: delay1. 	"activeDelay=delay1, suspendedDelays=()"
	scheduler schedule: delay2.		"activeDelay=delay1, suspendedDelays=(delay2)"
	scheduler schedule: delay3.		"activeDelay=delay1, suspendedDelays=(delay2,delay3)"
	scheduler schedule: delay4.		"activeDelay=delay1, suspendedDelays=(delay2,delay3,delay4)"

	self assert: suspendedDelaysHeap removeFirstOrNil equals: delay2.
	self assert: suspendedDelaysHeap removeFirstOrNil equals: delay3.
	self assert: suspendedDelaysHeap removeFirstOrNil equals: delay4.
	self assert: suspendedDelaysHeap removeFirstOrNil equals: nil.! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testHeapBackwards
	|delay1 delay2 delay3 delay4|
	delay1 := Delay forMilliseconds: 1.
	delay2 := Delay forMilliseconds: 2.
	delay3 := Delay forMilliseconds: 3.
	delay4 := Delay forMilliseconds: 4.
	
	scheduler schedule: delay4.		"activeDelay=delay4, suspendedDelays=()"
	scheduler schedule: delay3.		"activeDelay=delay3, suspendedDelays=(delay4)"
	scheduler schedule: delay2.		"activeDelay=delay2, suspendedDelays=(delay3,delay4)"
	scheduler schedule: delay1. 	"activeDelay=delay1, suspendedDelays=(delay2,delay3,delay4)"

	self assert: suspendedDelaysHeap removeFirstOrNil equals: delay2.
	self assert: suspendedDelaysHeap removeFirstOrNil equals: delay3.
	self assert: suspendedDelaysHeap removeFirstOrNil equals: delay4.
	self assert: suspendedDelaysHeap removeFirstOrNil equals: nil.! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testStoppedSchedulerExpiresRemainingDelays
	"Event loop priority takes So it takes priority over following code"
	|delay1 delay2 delay3|

	delay1 := Delay new setDelay: 9 forSemaphore: Semaphore new.
	delay2 := Delay new setDelay: 99 forSemaphore: Semaphore new.
	delay3 := Delay new setDelay: 999 forSemaphore: Semaphore new.

	scheduler simulate_vmMilliseconds: 10.	
	scheduler schedule: delay1.
	scheduler schedule: delay2.
	scheduler schedule: delay3.
	self assert: delay2 beingWaitedOn.
	self assert: delay1 beingWaitedOn.
	self assert: delay3 beingWaitedOn.

	scheduler simulate_vmMilliseconds: 25.
	self assert: delay1 isExpired.
	self deny: delay2 isExpired. 
	self deny: delay3 isExpired. 

	scheduler stopTimerEventLoop.
	self assert: delay2 isExpired.
	self assert: delay3 isExpired! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testMillisecondsToGo
	| delay |
	delay := Delay forMilliseconds: 100.
	
	scheduler simulate_vmMilliseconds: 100.
	scheduler schedule: delay.

	scheduler simulate_vmMilliseconds: 160.
	self assert: delay millisecondsToGo equals: 40.! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testMultiSchedule
	| delay anotherDelay |
	"Ensure that scheduling the same delay twice raises an error"
	delay := Delay forSeconds: 1000.
	scheduler schedule: delay.
	self assert: delay beingWaitedOn.
	self should:[ scheduler schedule: delay ] raise: Error.
	
	"Check that after that error, still accepting new items to schedule."
	"Run in a separate process in case #schedule: blocks"
	[	anotherDelay := Delay forMilliseconds: 1000.
		scheduler schedule: anotherDelay.
		] forkAt: Processor activePriority + 1.
	self assert: anotherDelay beingWaitedOn.! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testDurationLessThanMaxTicks
	"In #timingPriorityHandleEvent the maximum tick is hardcoded as 1000 milliseconds.
	 Test when delay duration is less than this.
		- duration is in milliseconds.
		- ticks are in microseconds"
	| delay |
	delay := Delay new setDelay: 789"ms" forSemaphore: Semaphore new.
	

	scheduler simulate_vmMilliseconds: 100.
	scheduler schedule: delay.
	self assert: ticker vmSimNextWakeupMilliseconds equals: 100 + 789! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testForSeconds
	| delay |
	delay := Delay forSeconds: 1.
	
	scheduler simulate_vmMilliseconds: 100.
	scheduler schedule: delay.

	scheduler simulate_vmMilliseconds: 1099.
	self deny: delay isExpired.
	
	scheduler simulate_vmMilliseconds: 1100.
	self assert: delay isExpired.! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testSimpleTwoDelays
	"Event loop priority takes so it takes priority over following code"
	|delay1 delay2|
	delay1 := Delay new setDelay: 2"ms" forSemaphore: Semaphore new.
	delay2 := Delay new setDelay: 4"ms" forSemaphore: Semaphore new.

	scheduler simulate_vmMilliseconds: 10.	
	self deny: delay1 beingWaitedOn.
	self deny: delay2 beingWaitedOn.
	scheduler schedule: delay1.
	scheduler schedule: delay2.
	self assert: delay1 beingWaitedOn.
	self assert: delay2 beingWaitedOn.
	
	scheduler simulate_vmMilliseconds: 11.
	self deny: delay1 isExpired. 
	self deny: delay2 isExpired. 
	
	scheduler simulate_vmMilliseconds: 12.
	self assert: delay1 isExpired.
	self deny: delay2 isExpired. 
	
	scheduler simulate_vmMilliseconds: 13.
	self deny: delay2 isExpired. 
	
	scheduler simulate_vmMilliseconds: 14.
	self assert: delay2 isExpired.! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testSuspendForSnapshot
	"
	Event loop priority takes So it takes priority over following code"
	|delay|
	delay := Delay new setDelay: 2"ms" forSemaphore: Semaphore new.
	 
	scheduler simulate_vmMilliseconds: 10.
	self deny: delay beingWaitedOn.
	scheduler schedule: delay.
	self assert: delay beingWaitedOn.
	self assert: delay millisecondsToGo equals: 2.
	
	scheduler shutDown. "e.g. by snapshot"

	self assert: delay millisecondsToGo equals: 0.	
	scheduler simulate_vmMilliseconds: 20.
	self assert: delay millisecondsToGo equals: 0.
	self deny: delay isExpired.
	
	scheduler startUp.
	self assert: delay millisecondsToGo equals: 2.
	self deny: delay isExpired.
	scheduler simulate_vmMilliseconds: 23.
	self assert: delay isExpired.! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
testForMilliseconds
	| delay |
	delay := Delay forMilliseconds: 1000.
	
	scheduler simulate_vmMilliseconds: 100.
	scheduler schedule: delay.

	scheduler simulate_vmMilliseconds: 1099.
	self deny: delay isExpired.
	
	scheduler simulate_vmMilliseconds: 1100.
	self assert: delay isExpired.! !

!DelayBasicSchedulerMicrosecondTickerTest methodsFor: 'running' stamp: ''!
setUp
	"Event loop priority takes So it takes priority over following code"
	super setUp.
	ticker := self classForTicker new.
	suspendedDelaysHeap := self classForScheduler defaultSuspendedDelaysHeap.
	scheduler := self classForScheduler onTicker: ticker suspendedDelaysHeap: suspendedDelaysHeap.
	scheduler startTimerEventLoopPriority: Processor activePriority + 1. "So its slightly above normal priority of tests"! !

!DelayBasicSchedulerMillisecondTickerTest commentStamp: ''!
I inherit delay scheduler system tests 
and run them for the specific combination of...
  scheduler DelayBasicScheduler
  ticker DelayMillisecondTicker.

!
!DelayBasicSchedulerMillisecondTickerTest methodsFor: 'tests' stamp: ''!
classForTicker
	^ DelayMillisecondTickerSimulation! !

!DelayBenchmark commentStamp: ''!
The delay scheduling loop 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.

DelayBenchmark provides a means for evaluating modifications.  This is fairly basic, providing only Transcript output of results.

Over a number of trials the amount of concurrent delays is increased.  The durations are randomly pre-generated into an array to avoid that overhead in the trials.  A fixed seed is used to try and improve comparisons between runs. Uncomment the additional seeds to provide better averaging of results.!
!DelayBenchmark methodsFor: 'benchmarks' stamp: ''!
bench: aDelaySchedulerClass
	| schedulerClassToRestore |
	
	self assert: (aDelaySchedulerClass inheritsFrom: DelayNullScheduler).
	schedulerClassToRestore := Delay delaySchedulerClass.
	
	[	Delay delaySchedulerClass: aDelaySchedulerClass.
		self bench.
	] ensure: [ Delay delaySchedulerClass: schedulerClassToRestore].! !

!DelayBenchmark methodsFor: 'benchmarks' stamp: ''!
bench
	"DelayBenchmark runAll."

	"DelayBenchmark run."

	| sampleSetSeeds trialOfNumberConcurrent completed |
	sampleSetSeeds := #(42).	"5975 13746 22634 44022"	"uncomment items to get a better average"
	trialOfNumberConcurrent := #(1000 2000 3000 4000 5000 6000 7000 8000 9000 10000).
	completed := Semaphore new.
	self
		crTrace: String cr , 'Benchmarking ' , Delay delaySchedulerClass printString.
	[ trialOfNumberConcurrent
		do: [ :numberConcurrent | 
			self
				crTrace: '#ConcurrentDelays: ' , numberConcurrent printString , String space.
			EnterCount := ExitCount := 0.
			sampleSetSeeds
				do: [ :seed | 
					self trace: '.'.
					self
						trialConcurrent: numberConcurrent
						priority: Processor userSchedulingPriority + 1
						maxDuration: 50
						fromSeed: seed ].
			self trace: String space.
			self
				trace:
					'EnterCount: ' , (EnterCount // sampleSetSeeds size) printString
						, String space.
			self
				trace: 'ExitCount: ' , (ExitCount // sampleSetSeeds size) printString ].
	completed signal ] forkAt: Processor userSchedulingPriority + 2.	"To avoid UI loop influencing result"
	completed wait! !

!DelayBenchmark methodsFor: 'support' stamp: ''!
trialConcurrent: numberConcurrentDelays priority: priority maxDuration: maxDuration fromSeed: seed 

	| delayProcesses |
	delayProcesses := self 
		generateDelayProcesses: numberConcurrentDelays 
		priority: priority 
		maxDuration: maxDuration 
		fromSeed: seed.
	
	Running := false.			
	
	[	Running := true. 
		delayProcesses do: [  :process | process resume ]. "Start counting delays"
		(Delay forSeconds: 1) wait. "Count the number of delays in one second"
	] ensure: [ Running := false ].  "All processes should exit cleanly here."
	(Delay forSeconds: 1) wait.	 "but give some time for clean exit"	
	delayProcesses do: [  :process | process terminate ]. "and cleanup any deadlocks."
	
	Smalltalk garbageCollect. Smalltalk garbageCollect. Smalltalk garbageCollect.! !

!DelayBenchmark methodsFor: 'support' stamp: ''!
generateDelayProcesses: numberConcurrent priority: priority maxDuration: maxDuration fromSeed: seed 
	| randomGenerator sampleDurations sampleIndex | 
	"Pre-generate a series of random durations to remove such time for such generation from trial" 
	"Seed to help reproducability between trials."
	randomGenerator := Random seed: seed.
	sampleDurations := Array new: 1000.  
	1 to: sampleDurations size do:
	[  	:index | 
		sampleDurations at: index put: (randomGenerator nextInteger: maxDuration).
	].
	sampleIndex := 0.

	"Avoid instantiating new Delay objects inside the inner whileTrue loop, to eliminate such time from trial. 
	Reuse Delay object with modified duration each loop."
    ^ (1 to: numberConcurrent) collect: 
			[ 	:each | 
				[					
					[	| delay | 	
						sampleIndex := (sampleIndex rem: sampleDurations size) + 1.
						delay := Delay forMilliseconds: (sampleDurations at: sampleIndex).
						EnterCount := EnterCount + 1. 	
						delay wait.
						ExitCount := ExitCount + 1.
						Running.  "Repeat until not running." 
					] whileTrue.
 				] newProcess priority: priority
			]! !

!DelayBenchmark class methodsFor: 'action' stamp: ''!
run
	"DelayBenchmark run"
	self new bench.! !

!DelayBenchmark class methodsFor: 'action' stamp: ''!
runAll
	"DelayBenchmark runAll"

	DelayNullScheduler allSubclasses
		do: [ :delaySchedulerClass | self new bench: delaySchedulerClass ]! !

!DelayMicrosecondTicker commentStamp: ''!
I interface to the microsecond based VM primitives.!
!DelayMicrosecondTicker methodsFor: 'api-system' stamp: ''!
tickAfterMilliseconds: milliseconds
	^self nowTick "microseconds" + (1000 * milliseconds)! !

!DelayMicrosecondTicker methodsFor: 'api-system' stamp: ''!
millisecondsUntilTick: microsecondsTick
	^((microsecondsTick - self nowTick) max: 0) / 1000! !

!DelayMicrosecondTicker methodsFor: 'api-system' stamp: ''!
nowTick
	 "Copied from Time class >> primUTCMicrosecondsClock.
	 Answer the number of micro-seconds ellapsed since epoch.
	 That is since 00:00 on the morning of January 1, 1901 UTC.
	 At least a 60-bit unsigned integer is used internally which is enough for dates up to year 38435.
	 Essential. See Object documentation whatIsAPrimitive. "

	<primitive: 240>
	self primitiveFailed! !

!DelayMicrosecondTicker methodsFor: 'private - primitives' stamp: ''!
primSignal: aSemaphore atUTCMicroseconds: aLargePositiveInteger
	"Signal the semaphore when the microsecond clock reaches the value of the second argument. Fail if the first argument is neither a Semaphore nor nil. Essential. See Object documentation whatIsAPrimitive."
	<primitive: 242>
	^ self primitiveFailed
	
"primitiveSignalAtUTCMicroseconds
	Cause the time semaphore, if one has been registered, to be
	 signalled when the microsecond clock is greater than or equal to
	 the given tick value. A tick value of zero turns off timer interrupts.
	| usecsObj sema usecs |
	<var: #usecs type: #usqLong>
	usecsObj := self stackTop.
	sema := self stackValue: 1.
	usecs := self positive64BitValueOf: usecsObj.
	self successful ifTrue:
		[(objectMemory isSemaphoreOop: sema) ifTrue:
			[objectMemory splObj: TheTimerSemaphore put: sema.
			 nextWakeupUsecs := usecs.
			 ^self pop: 2].
		 sema = objectMemory nilObject ifTrue:
			[objectMemory
				storePointer: TheTimerSemaphore
				ofObject: objectMemory specialObjectsOop
				withValue: objectMemory nilObject.
			 nextWakeupUsecs := 0.
			 ^self pop: 2]].
	self primitiveFailFor: PrimErrBadArgument"! !

!DelayMicrosecondTicker methodsFor: 'api-system' stamp: ''!
waitForUserSignalled: timingSemaphore orExpired: activeDelay
	|nextTick|
	"Sleep until the active delay is due, or timingSemaphore signalled by DelayScheduler user-api."
	
	"We sleep at most 1sec here as a soft busy-loop so that we don't accidentally miss signals."
	nextTick := self nowTick + (1"sec" * 1000"msecs" * 1000"usecs").
	activeDelay ifNotNil: [
		nextTick := nextTick min: activeDelay resumptionTick ].
		
	timingSemaphore initSignals.
	self primSignal: timingSemaphore atUTCMicroseconds: nextTick.
	"WARNING!! Stepping <Over> the following line may lock the Image. Use <Proceed>."
	timingSemaphore wait.! !

!DelayMicrosecondTickerSimulation commentStamp: ''!
To facilitate unit tests without interferring with the live VM interface,
I simulate the VM code for the microsecond primitives.!
!DelayMicrosecondTickerSimulation methodsFor: 'api-system' stamp: ''!
simulate_vmMilliseconds: milliseconds 
	
	vmSimNextWakeupTick ~= 0 ifTrue: [ 
		vmSimNow := milliseconds * 1000.
		vmSimNow >= vmSimNextWakeupTick ifTrue: [ 
			vmSimNextWakeupTick := 0. 
			vmSimTheTimerSemaphore signal.
			].
 		].

"Extract from VM code... 
StackInterpreter>>checkForEventsMayContextSwitch:
	nextWakeupUsecs ~= 0 ifTrue:
		[now >= nextWakeupUsecs ifTrue:
			[nextWakeupUsecs := 0.
			 ...set timer interrupt to 0 for 'no timer'...
			 sema := objectMemory splObj: TheTimerSemaphore.
			 (sema ~= objectMemory nilObject
			  and: [self synchronousSignal: sema]) ifTrue:
				[switched := true]]].
"! !

!DelayMicrosecondTickerSimulation methodsFor: 'api-system' stamp: ''!
vmSimNextWakeupMilliseconds
	^vmSimNextWakeupTick / 1000! !

!DelayMicrosecondTickerSimulation methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	vmSimTheTimerSemaphore := Semaphore new.
	vmSimNow := 0.! !

!DelayMicrosecondTickerSimulation methodsFor: 'api-system' stamp: ''!
nowTick
	^vmSimNow! !

!DelayMicrosecondTickerSimulation methodsFor: 'private - primitives' stamp: ''!
primSignal: sempahore atUTCMicroseconds: nextTick 
	"This is a simulation of the primitive, working hand-in-hand with #simulate_vmMilliseconds:"
	(sempahore isKindOf: Semaphore) ifTrue: [ 
		vmSimTheTimerSemaphore := sempahore.
		vmSimNextWakeupTick := nextTick ].
	(sempahore = nil) ifTrue: [ 
		vmSimTheTimerSemaphore := nil.
		vmSimNextWakeupTick := 0] 
	
"Extract from VM code...
StackInterpreterPrimitives >> primitiveSignalAtUTCMicroseconds
	...Cause the time semaphore, if one has been registered, to be
	 signalled when the microsecond clock is greater than or equal to
	 the given tick value. A tick value of zero turns off timer interrupts...
	| usecsObj sema usecs |
	<var: #usecs type: #usqLong>
	usecsObj := self stackTop.
	sema := self stackValue: 1.
	usecs := self positive64BitValueOf: usecsObj.
	self successful ifTrue:
		[(objectMemory isSemaphoreOop: sema) ifTrue:
			[objectMemory splObj: TheTimerSemaphore put: sema.
			 nextWakeupUsecs := usecs.
			 ^self pop: 2].
		 sema = objectMemory nilObject ifTrue:
			[objectMemory
				storePointer: TheTimerSemaphore
				ofObject: objectMemory specialObjectsOop
				withValue: objectMemory nilObject.
			 nextWakeupUsecs := 0.
			 ^self pop: 2]].
	self primitiveFailFor: PrimErrBadArgument
"! !

!DelayMicrosecondUncappedTicker commentStamp: ''!
In contrast to the traditional ticker (DelayMicrosecondTicker) 
I am not capped at a maximum sleep of 1 second, making a quieter idle image.
When there is no scheduled delay, the VM will sleep indefinitely until woken 
by another mechanism (which is what?)!
!DelayMicrosecondUncappedTicker methodsFor: 'api-system' stamp: ''!
waitForUserSignalled: timingSemaphore orExpired: activeDelay
	|nextTick|
	"Sleep until the active delay is due, or timingSemaphore signalled by DelayScheduler user-api."
	
	"Signal when the next request is due. We trust our VM and will sleep as long as needed. 
	 If there is no activeDelay, nextTick = 0 will turn off the timer interrupt."
	nextTick := 0.
	activeDelay ifNotNil: [
		nextTick := nextTick min: activeDelay resumptionTick ].
		
	timingSemaphore initSignals.
	self primSignal: timingSemaphore atUTCMicroseconds: nextTick.
	"WARNING!! Stepping <Over> the following line may lock the Image. Use <Proceed>."
	timingSemaphore wait.! !

!DelayMillisecondTicker commentStamp: ''!
I interface to the millisecond based VM primitives.!
!DelayMillisecondTicker methodsFor: 'api-system' stamp: ''!
tickAfterMilliseconds: milliseconds
	^self nowTick "milliseconds" + milliseconds! !

!DelayMillisecondTicker methodsFor: 'api-system' stamp: ''!
millisecondsUntilTick: microsecondsTick
	^((microsecondsTick - self nowTick) max: 0)! !

!DelayMillisecondTicker methodsFor: 'api-system' stamp: ''!
nowTick
	"Copied from Time class >> primMillisecondClock."
	"Primitive. Answer the number of milliseconds since the millisecond clock
	 was last reset or rolled over. Answer zero if the primitive fails."

	<primitive: 135>
	^ 0! !

!DelayMillisecondTicker methodsFor: 'api-system' stamp: ''!
waitForUserSignalled: timingSemaphore orExpired: activeDelay
	|nextTick|
	"Sleep until the active delay is due, or timingSemaphore signalled by DelayScheduler user-api."
	
	"We sleep at most 1sec here as a soft busy-loop so that we don't accidentally miss signals."
	nextTick := self nowTick + (1"sec" * 1000"msecs").
	activeDelay ifNotNil: [
		nextTick := nextTick min: activeDelay resumptionTick ].
		
	timingSemaphore initSignals.
	self primSignal: timingSemaphore atMilliseconds: nextTick.
	"WARNING!! Stepping <Over> the following line may lock the Image. Use <Proceed>."
	timingSemaphore wait.! !

!DelayMillisecondTicker methodsFor: 'private - primitives' stamp: ''!
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."
	<primitive: 136>
	^self primitiveFailed! !

!DelayMillisecondTickerSimulation commentStamp: ''!
To facilitate unit tests without interferring with the live VM interface,
I simulate the VM code for the millisecond primitives.!
!DelayMillisecondTickerSimulation methodsFor: 'api-system' stamp: ''!
simulate_vmMilliseconds: milliseconds 
	
	vmSimNextWakeupTick ~= 0 ifTrue: [ 
		vmSimNow := milliseconds.
		vmSimNow >= vmSimNextWakeupTick ifTrue: [ 
			vmSimNextWakeupTick := 0. 
			vmSimTheTimerSemaphore signal.
			].
 		].! !

!DelayMillisecondTickerSimulation methodsFor: 'api-system' stamp: ''!
vmSimNextWakeupMilliseconds
	^vmSimNextWakeupTick! !

!DelayMillisecondTickerSimulation methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	vmSimTheTimerSemaphore := Semaphore new.
	vmSimNow := 0.! !

!DelayMillisecondTickerSimulation methodsFor: 'api-system' stamp: ''!
nowTick
	^vmSimNow! !

!DelayMillisecondTickerSimulation methodsFor: 'private - primitives' stamp: ''!
primSignal: sempahore atMilliseconds: nextTick
	"This is a simulation of the primitive, working hand-in-hand with #simulate_vmMilliseconds:"
	(sempahore isKindOf: Semaphore) ifTrue: [ 
		vmSimTheTimerSemaphore := sempahore.
		vmSimNextWakeupTick := nextTick ].
	(sempahore = nil) ifTrue: [ 
		vmSimTheTimerSemaphore := nil.
		vmSimNextWakeupTick := 0]! !

!DelayMutexScheduler commentStamp: ''!
I add shared-resource based synchronization to the basic scheduler.!
!DelayMutexScheduler methodsFor: 'initialization' stamp: ''!
initializeTicker: aDelayTicker suspendedDelaysHeap: aHeap
	super initializeTicker: aDelayTicker suspendedDelaysHeap: aHeap.
	accessProtect := Semaphore forMutualExclusion.! !

!DelayMutexScheduler methodsFor: 'initialization' stamp: ''!
schedule: aDelay
	accessProtect critical: [ super schedule: aDelay].! !

!DelayMutexScheduler methodsFor: 'initialization' stamp: ''!
unschedule: aDelay
	accessProtect critical: [ super unschedule: aDelay].! !

!DelayMutexSchedulerMicrosecondTickerTest commentStamp: ''!
I inherit delay scheduler system tests 
and run them for the specific combination of...
  scheduler DelayMutexScheduler
  ticker DelayMicrosecondTicker.

!
!DelayMutexSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
classForScheduler 
	^ DelayMutexScheduler! !

!DelayMutexSchedulerMillisecondTickerTest commentStamp: ''!
I inherit delay scheduler system tests 
and run them for the specific combination of...
  scheduler DelayMutexScheduler
  ticker DelayMillisecondTicker.

!
!DelayMutexSchedulerMillisecondTickerTest methodsFor: 'tests' stamp: ''!
classForTicker
	^DelayMillisecondTickerSimulation! !

!DelayNullScheduler commentStamp: ''!
I represent the simplest delay scheduler.  I'm so simple I actually don't schedule delays,
but signal them to continue immediately so there is no delay. 
My purpose is provide the minimum interface required to avoid DNU errors in the rest of the system.

My responsibilities are: 
1. Facilitate image shutdown/startup   
2. Facilitate the start/stop in transitioning between delay schedulers 
3. Immediately signal delays to continue to avoid user code blocking forever on unscheduled delays 

My main collaborators are:
Delay - has a class variable "Scheduler" storing the current delay scheduler
      - changes Scheduler by stopping old timer event loop and starting new timer event loop
      - invokes #schedule: and #unschedule: on current Scheduler
      - forwards system #startUp and #shutDown to current Scheduler


USER-API 

#schedule: aDelay
	Immediately signals the delaySemaphore to continue.
	Required by Delay>>schedule & Delay>>wait. 

#unschedule: aDelay
	Empty method body 
 	Required by Delay>>unschedule.


SYSTEM-API
	
#startTimerEventLoop
	Empty method body 
	Required by Delay-class>>#delaySchedulerClass: 
	
#stopTimerEventLoop
	Empty method body 
 	Required by Delay-class>>#delaySchedulerClass: 
		
#startUp
	Empty method body 
	Required by Delay-class>>#startup 
					
#shutDown
	Empty method body 
	Required by Delay-class>>#shutdown!
!DelayNullScheduler methodsFor: 'system-api' stamp: ''!
startTimerEventLoop
	"Nothing to do for DelayNullScheduler"! !

!DelayNullScheduler methodsFor: 'system-api' stamp: ''!
startUp
	Warning signal: 'Delay scheduler is NOT RUNNING!!'.
	
	"To get delays working again, go to System > Settings > System > Delay scheduler. "! !

!DelayNullScheduler methodsFor: 'system-api' stamp: ''!
stopTimerEventLoop
	"Nothing to do for DelayNullScheduler"! !

!DelayNullScheduler methodsFor: 'user-api' stamp: ''!
schedule: aDelay
	"Invoked from user code Delay>>schedule:
	 DelayNullScheduler does not schedule delays, but need to avoid user code blocking.
	 Signal its semaphore immediately, so effectively there is no delay.
	 For example,  [1 second asDelay wait] timeToRun  ==> 0:00:00:00.000 instead of 0:00:00:01.000"
	
	aDelay delaySemaphore signal.! !

!DelayNullScheduler methodsFor: 'user-api' stamp: ''!
unschedule: aDelay
	"Nothing to do for DelayNullScheduler"! !

!DelayNullScheduler methodsFor: 'system-api' stamp: ''!
shutDown
	"Nothing to do for DelayNullScheduler"! !

!DelaySchedulerBackgroundWorkerMorph commentStamp: ''!
I provide the support to test Pharo Case 13755. Not quite sure how to plug this into the testing framewok.  Currently just run this test manually like this...
    DelaySchedulerBackgroundWorkerMorph new openInWorld

which will FREEZE THE UI when using the following...
  * DelayMillisecondScheduler
  * DelayMicrosecondScheduler

but won't freeze when using  the following...
  * DelayExperimentalSemaphoreScheduler
  * DelayExperimentalSpinScheduler
  * DelayExperimentalCourageousScheduler

Close my instance morphs via halos, or evaluate the following...
    DelaySchedulerBackgroundWorkerMorph allInstances do: #delete.

!
!DelaySchedulerBackgroundWorkerMorph methodsFor: 'action' stamp: ''!
delete
    morphDeleted := true.
    super delete.! !

!DelaySchedulerBackgroundWorkerMorph methodsFor: 'initialization' stamp: ''!
initialize
    "DelaySchedulerBackgroundWorkerMorph new openInWorld"
    | workerProcess controllerProcess |
    super initialize.
    self extent: (300@50).
    self color: Color red.
    self addMorphBack:  (stringMorph := StringMorph new).
    morphDeleted := false.      "see #delete"

    workerProcess :=  
    [     work := 0.
        [    10 milliSeconds asDelay wait.
            work := work + 1.
            morphDeleted.
        ] whileFalse.
    ] newProcess name: 'Background worker'.

    controllerProcess :=
    [     [    workerProcess resume. self color: Color green.
            10 milliSeconds asDelay wait.
            workerProcess suspend. self color: Color red.
            10 milliSeconds asDelay wait.
            morphDeleted.
        ] whileFalse.
    ] newProcess name: 'Controller'.

    controllerProcess resume.! !

!DelaySchedulerBackgroundWorkerMorph methodsFor: 'stepping' stamp: ''!
step
    stringMorph contents: work printString! !

!DelaySchedulerBackgroundWorkerMorph methodsFor: 'stepping' stamp: ''!
stepTime
    ^ 50! !

!DelaySemaphoreScheduler commentStamp: ''!
I add multi-producer/single-consumer semaphore based syncronization to the basic scheduler.!
!DelaySemaphoreScheduler methodsFor: 'initialization' stamp: ''!
initializeTicker: aDelayTicker suspendedDelaysHeap: aHeap
	super initializeTicker: aDelayTicker suspendedDelaysHeap: aHeap.
	readyToSchedule := Semaphore new signal.
	readyToUnschedule := Semaphore new signal.! !

!DelaySemaphoreScheduler methodsFor: 'initialization' stamp: ''!
unscheduleAtTimingPriority
	"Private!! Invoke only from the timing-priority process.
	 This is the back-half of scheduling a delay. For front-half see #schedule:"

	readyToUnschedule signal. "But this timingPriority method completes first"
	super 	unscheduleAtTimingPriority.! !

!DelaySemaphoreScheduler methodsFor: 'initialization' stamp: ''!
schedule: aDelay
	"This is the front-half of scheduling a delay. For back-half see #timingPrioritySchedule:"

	"Only one signal is sent when delay expires. Check if that is already spoken for"
	aDelay beingWaitedOn ifTrue: [^self error: 'This Delay has already been scheduled.'].
	
	readyToSchedule wait.  "Starts signalled. Resignalled from back-end #scheduleAtTimingPriority"
	delayToStart := aDelay.
	timingSemaphore signal. "Transfer execution to back-end #scheduleAtTimingPriority"! !

!DelaySemaphoreScheduler methodsFor: 'initialization' stamp: ''!
scheduleAtTimingPriority
	"Private!! Invoke only from the timing-priority process.
	 This is the back-half of scheduling a delay. For front-half see #schedule:"

	readyToSchedule signal. "But this timingPriority method completes first"
	super 	scheduleAtTimingPriority.! !

!DelaySemaphoreScheduler methodsFor: 'initialization' stamp: ''!
unschedule: aDelay
	readyToUnschedule  wait.  "Starts signalled. Resignalled from back-end #unscheduleAtTimingPriority"
	delayToStop := aDelay.
	timingSemaphore signal. "Transfer execution to back-end #unscheduleAtTimingPriority"! !

!DelaySemaphoreSchedulerMicrosecondTickerTest commentStamp: ''!
I inherit delay scheduler system tests 
and run them for the specific combination of...
  scheduler DelaySemaphoreScheduler
  ticker DelayMicrosecondTicker.

!
!DelaySemaphoreSchedulerMicrosecondTickerTest methodsFor: 'tests' stamp: ''!
classForScheduler 
	^ DelaySemaphoreScheduler! !

!DelaySemaphoreSchedulerMillisecondTickerTest commentStamp: ''!
I inherit delay scheduler system tests 
and run them for the specific combination of...
  scheduler DelaySemaphoreScheduler
  ticker DelayMillisecondTicker.

!
!DelaySemaphoreSchedulerMillisecondTickerTest methodsFor: 'tests' stamp: ''!
classForTicker
	^DelayMillisecondTickerSimulation! !

!DelayTest commentStamp: ''!
SUnit tests for class Delay!
!DelayTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testSemaphoreTimeout
	"When we provide our own semaphore for a Delay, it should be used"
	
	| 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: '*Kernel-Tests-Extended' stamp: ''!
testSemaphoreNoTimeout
	| sem process |
	sem := Semaphore new.
	[ | delay |
		process := [ delay := Delay timeoutSemaphore: sem afterMSecs: 1000. sem wait] newProcess.
		process priority: Processor highIOPriority.
		process resume.
		delay unschedule.
		self deny: process isTerminated.
	] ensure: [sem signal].
	self assert: process isTerminated.! !

!DelayTest methodsFor: 'tests' stamp: ''!
testBounds

	self should: [ Delay forMilliseconds: -1 ] raise: Error.
	Delay forMilliseconds: SmallInteger maxVal // 2 + 1.
	Delay forMilliseconds: SmallInteger maxVal + 1.
	(Delay forMilliseconds: Float pi) wait	"Wait 3ms"! !

!DelayTest methodsFor: 'tests - limits' stamp: ''!
testMultiSchedule
	"Ensure that scheduling the same delay twice raises an error"
	| delay |
	delay := Delay forSeconds: 1.
	delay schedule.
	self should:[delay schedule] raise: Error.! !

!DelayTest methodsFor: 'tests - limits' stamp: ''!
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.! !

!DelayWaitTimeout commentStamp: ''!
DelayWaitTimeout is a special kind of Delay used in waitTimeoutMSecs: to avoid signaling the underlying semaphore when the wait times out.!
!DelayWaitTimeout methodsFor: 'waiting' stamp: ''!
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: ''!
setDelay: anInteger forSemaphore: aSemaphore
	super setDelay: anInteger forSemaphore: aSemaphore.
	process := Processor activeProcess.
	expired := false.! !

!DelayWaitTimeout methodsFor: 'testing' stamp: ''!
isExpired
	"Did this timeout fire before the associated semaphore was signaled?"
	^expired! !

!DelayWaitTimeout methodsFor: 'waiting' stamp: ''!
waitOnCompletion: completionBlock onTimeout: timeoutBlock
	"Wait until either the semaphore is signaled or the delay times out.
	If the delay times out execute timeoutBlock, otherwise if the semaphore is signaled execute completionBlock.
	Return the value returned by the executed block."
	^ self wait
		ifTrue: [ timeoutBlock value ]
		ifFalse: [ completionBlock value]! !

!DelayWaitTimeout methodsFor: 'private' stamp: ''!
timingPrioritySignalExpired
	"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.
		].! !

!DeleteVisitor commentStamp: ''!
I delete the directory tree that I visit. I use the PostorderGuide so that I can delete files before deleting their containing directories.

I don't follow symbolic links (so files outside the receiver's tree will not be deleted).!
!DeleteVisitor methodsFor: 'visiting' stamp: ''!
visitReference: anEntry
	anEntry reference delete! !

!DeleteVisitor methodsFor: 'visiting' stamp: ''!
visit: aReference
	"Don't follow symbolic links:
	- We shouldn't delete files outside the root's tree.
	- Symbolic links that point to the containing directory create an infinite loop"
	PostorderGuide 
		show: aReference 
		to: self 
		selecting: [ :entry | entry isSymlink not ]! !

!DeleteVisitor class methodsFor: 'instance creation' stamp: ''!
delete: aReference
	^ self new visit: aReference! !

!DeleteVisitorTest commentStamp: ''!
SUnit tests for class DeleteVisitor!
!DeleteVisitorTest methodsFor: 'tests' stamp: ''!
testBeta
	self setUpGreek.
	DeleteVisitor delete: (filesystem / 'alpha' / 'beta').
	self assert: (filesystem isDirectory: '/alpha').
	self assert: (filesystem isDirectory: '/alpha/epsilon').
	self deny: (filesystem exists: '/alpha/beta')! !

!DenyDialogWindow commentStamp: ''!
Dialog window displaying a message with a single OK button. Escape/return will close. Icon is a themed lock icon.!
!DenyDialogWindow methodsFor: 'visual properties' stamp: ''!
icon
	"Answer an icon for the receiver."

	^ self iconNamed: #lockIcon! !

!DenyDialogWindow class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallLockIcon! !

!DependentsArray commentStamp: ''!
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: ''!
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: 'accessing' stamp: ''!
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: 'private' stamp: ''!
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."
	<primitive: 105>
	start to: stop do: [:i |
		self basicAt: i put: (replacement basicAt: repStart - start + i)]! !

!DependentsArray methodsFor: 'enumerating' stamp: ''!
do: aBlock
	"Evaluate a Block on non nil elements of the receiver"
	| dep |
	1 to: self basicSize do:[:i|
		(dep := self basicAt: i) ifNotNil:[aBlock value: dep]].! !

!DependentsArray methodsFor: 'accessing' stamp: ''!
first
	self do: [:dep | ^dep].
	self error: 'this collection is empty'! !

!DependentsArray methodsFor: 'accessing' stamp: ''!
last
	self reverseDo: [:dep | ^dep].
	self error: 'this collection is empty'! !

!DependentsArray methodsFor: 'accessing' stamp: ''!
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: 'enumerating' stamp: ''!
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: 'enumerating' stamp: ''!
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: ''!
reverseDo: aBlock
	"Refer to the comment in Collection|do:."
	| dep |
	self basicSize to: 1 by: -1 do: [:i |
		(dep := self basicAt: i) ifNotNil: [aBlock value: dep]]! !

!DependentsArray methodsFor: 'converting' stamp: ''!
writeStream
	^ WriteStream on: self! !

!DependentsArray methodsFor: 'copying' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
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: ''!
withAll: aCollection
	| newInstance |
	newInstance := self basicNew: aCollection size.
	1 to: aCollection size do: [:i |
		newInstance basicAt: i put: (aCollection at: i)].
	^newInstance! !

!DependentsArray class methodsFor: 'instance creation' stamp: ''!
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: ''!
with: anObject
	^(self basicNew: 1) basicAt: 1 put: anObject; yourself! !

!DependentsArray class methodsFor: 'instance creation' stamp: ''!
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: ''!
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: ''!
with: firstObject with: secondObject 
	^(self basicNew: 2)
		basicAt: 1 put: firstObject;
		basicAt: 2 put: secondObject;
		yourself! !

!DependentsArrayTest commentStamp: ''!
SUnit tests for class  DependentsArray!
!DependentsArrayTest methodsFor: 'tests' stamp: ''!
testSize
	self
		assert: (DependentsArray with: nil) size equals: 0;
		assert: (DependentsArray with: nil with: 1 with: nil) size equals: 1;
		assert: (DependentsArray with: 1 with: 3) size equals: 2;
		assert: (DependentsArray with: nil with: nil with: nil) size equals: 0! !

!DeprecatedSlot commentStamp: ''!
Description
--------------------

I am a slot used when the usage of an instance variable should be deprecated.

Examples
--------------------

	FamixMetamodelGenerator subclass: #FamixBasicInfrastructureGenerator
	slots: { #entity => DeprecatedSlot message: 'Do not use'. 
				#sourceAnchor. #sourceLanguage. #sourcedEntity. #comment. #namedEntity. #sourceTextAnchor. #unknownSourceLanguage }
	classVariables: {  }
	package: 'Famix-BasicInfrastructure'
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	message:		<aString>		The deprecation message to show.
!
!DeprecatedSlot methodsFor: 'accessing' stamp: ''!
message: anObject
	message := anObject! !

!DeprecatedSlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	SlotDeprecation new
		context: thisContext;
		explanation: self message;
		signal.
	super read: anObject! !

!DeprecatedSlot methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream
		store: self name;
		nextPutAll: ' => ';
		nextPutAll: self class name.
	aStream
		nextPutAll: ' message: ';
		store: self message! !

!DeprecatedSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
	SlotDeprecation new
		context: thisContext;
		explanation: self message;
		signal.
	super write: aValue to: anObject! !

!DeprecatedSlot methodsFor: 'accessing' stamp: ''!
message
	^ message! !

!DeprecatedSlot class methodsFor: 'accessing' stamp: ''!
message: aString
	^ self new
		message: aString;
		yourself! !

!Deprecation commentStamp: ''!
This Warning is signalled by methods which are deprecated.

Idiom: Imagine I want to deprecate the message #foo.

foo
	^ 'foo'

I can replace it with:

foo
	self 
		deprecated:   'The method #foo was not good. Use Bar>>newFoo instead.'
		on:  'here add date'
		in:  'here add version'
		 transformWith:   '`@receiver foo' -> '`@receiver newFoo'.	
	^self newFoo
	
	
The  transformWith:  part is optional. It allows to transform the deprecated method automatically when called.
If the transformation is defined, the Warning will not signalled.

!
!Deprecation methodsFor: 'settings' stamp: ''!
showWarning
	^ self class showWarning! !

!Deprecation methodsFor: 'private' stamp: ''!
deprecatedMethodName
	^self contextOfDeprecatedMethod compiledCode method printString! !

!Deprecation methodsFor: 'comparing' stamp: ''!
= anObject
	^self class == anObject class
	  and: [context = anObject context
	  and: [context
			ifNil: [explanationString = anObject explanationString]
			ifNotNil: [true]]]! !

!Deprecation methodsFor: 'accessing' stamp: ''!
contextOfDeprecatedMethod
	^context! !

!Deprecation methodsFor: 'comparing' stamp: ''!
hash
	^(context ifNil: [explanationString]) hash! !

!Deprecation methodsFor: 'accessing' stamp: ''!
date: aDate
	deprecationDate := aDate! !

!Deprecation methodsFor: 'accessing' stamp: ''!
context: aContext
	context := aContext! !

!Deprecation methodsFor: 'accessing' stamp: ''!
explanation: aString
	explanationString := aString! !

!Deprecation methodsFor: 'accessing' stamp: ''!
versionString

	^ versionString ifNil: [ 'unknown' ]! !

!Deprecation methodsFor: 'handling' stamp: ''!
signal
	| pragma |
	(context compiledCode method hasPragmaNamed: #transform:to:) ifFalse: [ ^super signal ].

	pragma := context compiledCode method pragmaAt: #transform:to:.
	self rule: pragma arguments first -> pragma arguments second.
	self transform! !

!Deprecation methodsFor: '*SUnit-Core' stamp: ''!
manageTestProcessBy: aProcessMonitorTestService
	"Deprecation is not considered as a test failure.
	So we are ignoring it here just like any other notification"! !

!Deprecation methodsFor: 'accessing' stamp: ''!
messageText
	^String streamContents: [ :str |
		self shouldTransform ifTrue: [ 
			str nextPutAll:  'Automatic deprecation code rewrite: '].
		str 
			nextPutAll: 'The method ';
			nextPutAll: self deprecatedMethodName;
			nextPutAll: ' called from ';
			nextPutAll: self sendingMethodName;
			nextPutAll: ' has been deprecated. ';
		 	nextPutAll: explanationString]! !

!Deprecation methodsFor: 'accessing' stamp: ''!
explanationString

	^ explanationString! !

!Deprecation methodsFor: 'handling' stamp: ''!
transform
	| node rewriteRule aMethod |
	self shouldTransform ifFalse: [ ^ self signal].
	self rewriterClass ifNil:[ ^ self signal ].
	aMethod := self contextOfSender compiledCode method.
	aMethod isDoIt ifTrue:[ ^ self signal ]. "no need to transform doits"
	node := self contextOfSender sourceNodeExecuted.
	RecursionStopper during: [
		rewriteRule := self rewriterClass new 
			replace: rule key with: rule value.
		(rewriteRule executeTree: node)
			ifFalse: [ ^ self signal ].
		node replaceWith: rewriteRule tree. 
		Author 
			useAuthor: 'AutoDeprecationRefactoring'
			during: [aMethod origin compile: aMethod ast formattedCode classified: aMethod protocol].	
		Log  ifNotNil: [:log | log add: self].
		self logTranscript]! !

!Deprecation methodsFor: 'handling' stamp: ''!
defaultAction
	Log 
		ifNotNil: [:log | log add: self].
	self logTranscript.
	self raiseWarning 
		ifTrue: [super defaultAction]! !

!Deprecation methodsFor: 'private' stamp: ''!
rewriterClass
	^ self class environment at: #RBParseTreeRewriter ifAbsent: [ nil ]! !

!Deprecation methodsFor: 'accessing' stamp: ''!
version: aString
	versionString := aString! !

!Deprecation methodsFor: 'private' stamp: ''!
sendingMethodName
	^self contextOfSender compiledCode method printString! !

!Deprecation methodsFor: 'accessing' stamp: ''!
condition: aBlock
	condition := aBlock! !

!Deprecation methodsFor: 'handling' stamp: ''!
shouldTransform
	self class activateTransformations ifFalse: [ ^false  ].
	(condition isNil or: [ condition cull: self ]) ifFalse: [ ^false ].
	^rule isNotNil! !

!Deprecation methodsFor: 'private' stamp: ''!
logTranscript
	self showWarning
		ifTrue: [ DeprecationPerformedNotification signal: self messageText ]! !

!Deprecation methodsFor: 'settings' stamp: ''!
raiseWarning
	^ self class raiseWarning! !

!Deprecation methodsFor: '*SUnit-Core' stamp: ''!
sunitAnnounce: aTestCase toResult: aTestResult
	self resume! !

!Deprecation methodsFor: 'accessing' stamp: ''!
rule: aRule
	rule := aRule! !

!Deprecation methodsFor: 'accessing' stamp: ''!
contextOfSender
	^context sender! !

!Deprecation methodsFor: 'accessing' stamp: ''!
deprecationDate

	^ deprecationDate ifNil: [ 'unknown' ]! !

!Deprecation class methodsFor: 'settings' stamp: ''!
showWarning
	"If true, then a message is send to the Transcript for each deprecated method invocation"
	^ ShowWarning ifNil: [ShowWarning := true]! !

!Deprecation class methodsFor: 'class initialization' stamp: ''!
initialize
	Log := nil "#deprecationsWhile: logs all deprecations here"! !

!Deprecation class methodsFor: 'logging' stamp: ''!
deprecationsWhile: aBlock
	"returns a log of all deprecated methods seen while executing 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: ''!
showWarning: aBoolean
	ShowWarning := aBoolean! !

!Deprecation class methodsFor: 'settings' stamp: ''!
raiseWarning: aBoolean
	RaiseWarning := aBoolean! !

!Deprecation class methodsFor: 'logging' stamp: ''!
activateTransformations

	^ Active ifNil: [ Active := true ]! !

!Deprecation class methodsFor: 'settings' stamp: ''!
raiseWarning
	"If true, then a dialog is popup for each deprecated method invocation"
	^ RaiseWarning ifNil: [RaiseWarning := true]! !

!Deprecation class methodsFor: 'logging' stamp: ''!
activateTransformations: aBoolean

	Active := aBoolean! !

!DeprecationPerformedNotification commentStamp: ''!
I am a notificaton about an operation that was performed as reaction of a Deprecation warning. I inform user about a method rewrite and so on. Usual reaction is to write related description to Transcript.!
!DerivedSlot commentStamp: ''!
A derived slot is a virtual slot that stores its value in a hidden base slot.!
!DerivedSlot methodsFor: 'testing' stamp: ''!
isReadIn: aMethod
	(baseSlot isReadIn: aMethod) ifFalse: [ ^false ].
	^super isReadIn: aMethod! !

!DerivedSlot methodsFor: 'testing' stamp: ''!
isWrittenIn: aMethod
	(baseSlot isWrittenIn: aMethod) ifFalse: [ ^false ].
	^super isWrittenIn: aMethod! !

!DerivedSlot methodsFor: 'testing' stamp: ''!
isAccessedIn: aMethod
	^ (baseSlot isAccessedIn: aMethod)
		  ifTrue: [ super isAccessedIn: aMethod ]
		  ifFalse: [ false ]! !

!DialogItemsChooser commentStamp: ''!
Dialog for choosing from a list of items!
!DialogItemsChooser methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	selection := OrderedCollection new.
	unselectedItems := OrderedCollection new.
	selectedItems := OrderedCollection new! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
selectedItemsSetterSelector
	^selectedItemsSetterSelector! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
selectedLabel
	^selectedLabel! !

!DialogItemsChooser methodsFor: 'display' stamp: ''!
open
	<script: 'self new open'>
	
	^(DialogItemsChooserUI on: self)
			title: self title;
			openInWorld! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
title: aFinderUI
	title := aFinderUI! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
selectedLabel: anObject

	selectedLabel := anObject! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
selection
	^selection! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
selectedItemsSetterSelector: aSelector
	selectedItemsSetterSelector := aSelector! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
unselectedItems: anObject

	unselectedItems := anObject! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
unselectedItems

	^ unselectedItems! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
unselectedLabel: anObject

	unselectedLabel := anObject! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
model: aModel
	model := aModel! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
selectedItems

	^ selectedItems! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
unselectedLabel
	^unselectedLabel! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
model
	^model! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
title
		^title! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
sendSelection
	^self model perform: self selectedItemsSetterSelector with: self selectedItems! !

!DialogItemsChooser methodsFor: 'accessing' stamp: ''!
selectedItems: anObject

	selectedItems := anObject! !

!DialogItemsChooser class methodsFor: 'opening' stamp: ''!
open
	<script>
	
	^self new open! !

!DialogItemsChooser class methodsFor: 'instance creation' stamp: ''!
on: aModel unselectedItems: unselectedItems selectedItems: selectedItems selectedItemsSetterSelector: anotherSelector title: aString unselectedItemsLabel: unselectedLabel selectedItemsLabel: selectedLabel
	| instance |
	instance := self new 
					model: aModel;
					unselectedItems: unselectedItems;
					selectedItems: selectedItems;
					selectedItemsSetterSelector: anotherSelector;
					title: aString;
					unselectedLabel: unselectedLabel;
					selectedLabel: selectedLabel.
	^instance! !

!DialogItemsChooserUI commentStamp: ''!
unselectedItems is the original list to search in

selectItems is the list of the selected items!
!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
addButtonAction
	self addSelectedItems! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
removeAllButtonAction
	self removeAllItems! !

!DialogItemsChooserUI methodsFor: 'actions' stamp: ''!
newContentMorph
	| trees unselectedItemsCol selectedItemsCol buttons |
	buttons := (self newGroupboxFor: (
		(self newColumn: {
			self buildAddAllButton.
			self buildAddButton.
			self buildRemoveButton.
			self buildRemoveAllButton})
			vResizing: #shrinkWrap))
		vResizing: #shrinkWrap.
	
	unselectedItemsCol := self newGroupbox: self unselectedLabel for: (self newColumn: {
							self buildUnselectedItemsSearchingTextArea: self.
							self buildUnselectedItemsList.}).
	selectedItemsCol := self newGroupbox: self selectedLabel for: (self newColumn: {
							self buildSelectedItemsSearchingTextArea: self.
							self buildSelectedItemsList.}).
	trees := self newRow: {
					unselectedItemsCol.
					"self newGroupboxFor: self buildUnselectedItemsTree."
					buttons hResizing: #shrinkWrap.
					selectedItemsCol}.
	^trees vResizing: #spaceFill
! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
removeButtonAction
	self removeSelectedItems! !

!DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: ''!
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 creations' stamp: ''!
removeButtonState
	^ false! !

!DialogItemsChooserUI methodsFor: 'unselectedList' stamp: ''!
unselectedSelectionAt: index

	^unselectedSelectionList at: index ifAbsent: [false]! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
unselectedItemsSearchingString: anObject

	unselectedItemsSearchingString := anObject.
	unselectedSelectionList removeAll.
	self unselectedSelectionIndex: 0.
	self
		changed: #unselectedItemsProbablyRestricted;
		changed: #unselectedSelectionAt:;
		changed: #unselectedSelectionIndex;
		changed: #hasUnselectedSelections! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
searchButtonLabel
	^'Search'! !

!DialogItemsChooserUI methodsFor: 'selectedList' stamp: ''!
hasSelectedItems
	"Answer whether the selected list has items."

	^self selectedItems notEmpty! !

!DialogItemsChooserUI methodsFor: 'display' stamp: ''!
centering

	self left: ((ActiveWorld width / 2) - (self width /2)) rounded.
	self top: ((ActiveWorld height / 2) - (self height /2)) rounded! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
searchButtonState
	^ false! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
dialogItemsChooser
	^ dialogItemsChooser! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
removeButtonLabel
	^ '<'! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
unselectedLabel

	^ self dialogItemsChooser
		ifNil: [ 'Unselected Items' translated ]
		ifNotNil: [ self dialogItemsChooser unselectedLabel ]! !

!DialogItemsChooserUI methodsFor: 'private' stamp: ''!
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: 'build items' stamp: ''!
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: ''!
buildUnselectedItemsList

	^(PluggableListMorph
		on: self 
		list: #unselectedItemsProbablyRestricted 
		primarySelection: #unselectedSelectionIndex
		changePrimarySelection: #unselectedSelectionIndex:
		listSelection: #unselectedSelectionAt:
		changeListSelection: #unselectedSelectionAt:put:
		menu: nil)
			hResizing: #spaceFill;
			vResizing: #spaceFill! !

!DialogItemsChooserUI methodsFor: 'initialization' stamp: ''!
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: ''!
selectedSelectionAt: index

	^selectedSelectionList at: index ifAbsent: [false]! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
selectedLabel

	^ self dialogItemsChooser
		ifNil: [ 'Selected Items' translated ]
		ifNotNil: [ self dialogItemsChooser selectedLabel ]! !

!DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: ''!
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: 'build items' stamp: ''!
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: 'buttons creations' stamp: ''!
addButtonLabel
	^'>'! !

!DialogItemsChooserUI methodsFor: 'display' stamp: ''!
isResizeable
	^true! !

!DialogItemsChooserUI methodsFor: 'build items' stamp: ''!
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: 'selectedList' stamp: ''!
hasSelectedSelections
	"Answer whether the selected list has selected items."

	^selectedSelectionList anySatisfy: [:selected | selected]! !

!DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: ''!
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: 'selectedList' stamp: ''!
selectedSelectionIndex
	^ selectedSelectionIndex ifNil: [selectedSelectionIndex := 0]! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
addAllButtonState
	^false! !

!DialogItemsChooserUI methodsFor: 'private' stamp: ''!
selectedItemsProbablyRestricted

	| matcher string |
	string := self selectedItemsSearchingString.
	matcher := string
					ifEmpty: ['*']
					ifNotEmpty: [
						(string last = $*) 
							ifTrue: [string]
							ifFalse:[string, '*']].
	^self selectedItems select: [:each | matcher asString match: each].! !

!DialogItemsChooserUI methodsFor: 'build items' stamp: ''!
buildSelectedItemsSearchingTextArea: aWindow

	^aWindow
		newAutoAcceptTextEntryFor: self
		get: #selectedItemsSearchingString
		set: #selectedItemsSearchingString:
		class: String
		getEnabled: nil
		help: 'Enter the name of a package' translated! !

!DialogItemsChooserUI methodsFor: 'unselectedList' stamp: ''!
unselectedSelectionIndex
	^unselectedSelectionIndex ifNil: [unselectedSelectionIndex := 0]! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
removeAllButtonState
	^false! !

!DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: ''!
unselectedSelectionItems

	| result |
	result := OrderedCollection new.
	self unselectedItemsProbablyRestricted doWithIndex: [:item :index |
		(self unselectedSelectionAt: index)
			ifTrue: [result add: item]].
	^result! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
removeAllButtonLabel
	^'<<'! !

!DialogItemsChooserUI methodsFor: 'build items' stamp: ''!
buildSelectedItemsList

	^(PluggableListMorph
		on: self 
		list: #selectedItemsProbablyRestricted 
		primarySelection: #selectedSelectionIndex
		changePrimarySelection: #selectedSelectionIndex:
		listSelection: #selectedSelectionAt:
		changeListSelection: #selectedSelectionAt:put:
		menu: nil)
			hResizing: #spaceFill;
			vResizing: #spaceFill! !

!DialogItemsChooserUI methodsFor: 'unselectedList' stamp: ''!
unselectedSelectionIndex: anObject

	unselectedSelectionIndex := anObject.
	self changed: #unselectedSelectionIndex! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
addAllButtonAction
	self addAllItems! !

!DialogItemsChooserUI methodsFor: 'unselectedList' stamp: ''!
hasUnselectedItems
	"Answer whether the unselected list has items."

	^self unselectedItems notEmpty! !

!DialogItemsChooserUI methodsFor: 'private' stamp: ''!
applyChanges
	self valid! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
selectedItems: aList
	selectedItems := aList.! !

!DialogItemsChooserUI methodsFor: 'unselectedList' stamp: ''!
unselectedSelectionAt: index put: aBoolean
	"Mark the item as selected or not."
	
	unselectedSelectionList at: index put: aBoolean.
	self changed: #hasUnselectedSelections! !

!DialogItemsChooserUI methodsFor: 'selectedList' stamp: ''!
selectedSelectionAt: index put: aBoolean
	"Mark the item as selected or not."
	
	selectedSelectionList at: index put: aBoolean.
	self changed: #hasSelectedSelections! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
addButtonState
	^false! !

!DialogItemsChooserUI methodsFor: 'opening' stamp: ''!
preOpenInWorld: aWorld

	self width: 500.
	self height: 400.
	self centering! !

!DialogItemsChooserUI methodsFor: 'buttons creations' stamp: ''!
addAllButtonLabel
	^'>>'! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
selectedItemsSearchingString: anObject

	selectedItemsSearchingString := anObject.
	selectedSelectionList removeAll.
	self selectedSelectionIndex: 0.
	self
		changed: #selectedItemsProbablyRestricted;
		changed: #selectedSelectionAt:;
		changed: #selectedSelectionIndex;
		changed: #hasSelectedSelections! !

!DialogItemsChooserUI methodsFor: 'private' stamp: ''!
valid
	self dialogItemsChooser sendSelection! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
selectedItemsSearchingString

	^ selectedItemsSearchingString! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
unselectedItems: anOrderedCollection 
	
	unselectedItems := anOrderedCollection.! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
unselectedItems
	^unselectedItems! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
unselectedItemsSearchingString

	^ unselectedItemsSearchingString! !

!DialogItemsChooserUI methodsFor: 'unselectedList' stamp: ''!
hasUnselectedSelections
	"Answer whether the unselected list has selected items."

	^unselectedSelectionList anySatisfy: [:selected | selected ]! !

!DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: ''!
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: 'build items' stamp: ''!
buildUnselectedItemsSearchingTextArea: aWindow

	^aWindow
		newAutoAcceptTextEntryFor: self
		get: #unselectedItemsSearchingString
		set: #unselectedItemsSearchingString:
		class: String
		getEnabled: nil
		help: 'Enter the name of a package' translated! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
selectedItems
	^ selectedItems! !

!DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: ''!
selectedSelectionItems

	| result |
	result := OrderedCollection new.
	self selectedItemsProbablyRestricted doWithIndex: [:item :index |
		(self selectedSelectionAt: index)
			ifTrue: [result add: item]].
	^result! !

!DialogItemsChooserUI methodsFor: 'build items' stamp: ''!
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: 'selectedList' stamp: ''!
selectedSelectionIndex: anObject

	selectedSelectionIndex := anObject.
	self changed: #selectedSelectionIndex! !

!DialogItemsChooserUI methodsFor: 'accessing' stamp: ''!
dialogItemsChooser: aDialogItemsChooser
	dialogItemsChooser := aDialogItemsChooser! !

!DialogItemsChooserUI class methodsFor: 'instance creation' stamp: ''!
on: aDialogItemsChooser
	^self basicNew 
		unselectedItems: aDialogItemsChooser unselectedItems;
		selectedItems: aDialogItemsChooser selectedItems;
		dialogItemsChooser: aDialogItemsChooser;
		initialize.! !

!DialogWindow commentStamp: ''!
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 class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!DialogWindowMorph commentStamp: ''!
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.!
!DialogWindowMorph methodsFor: 'actions' stamp: ''!
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]]! !

!DialogWindowMorph methodsFor: 'theme' stamp: ''!
preferredCornerStyle
	"Answer the preferred corner style."

	^self theme dialogWindowPreferredCornerStyleFor: self! !

!DialogWindowMorph methodsFor: 'event handling' stamp: ''!
doubleClick: event
	"Handle a double click. Maximize/restore the window.
	Not for dialogs if not resizeable..."
	
	self isResizeable ifTrue: [super doubleClick: event]! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
newContentMorph
	"Answer a new content morph."

	^Morph new
		color: Color transparent;
		hResizing: #spaceFill;
		vResizing: #spaceFill! !

!DialogWindowMorph methodsFor: 'keymapping' stamp: ''!
closeWindowAction
"closed by keyboard shortcut - act like 'cancel' "
	self cancel! !

!DialogWindowMorph methodsFor: 'event handling' stamp: ''!
keyboardFocusChange: aBoolean
	"Set the focus to the default button."
	super keyboardFocusChange: aBoolean.
	aBoolean ifTrue: [
		self defaultFocusMorph ifNotNil: [:b |
			b takeKeyboardFocus]]! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
setLabelWidgetAllowance
	"Set the extra space required, in general, apart from the label.
	No extra needed for dialogs."
	
	^labelWidgetAllowance :=  0! !

!DialogWindowMorph methodsFor: 'theme' stamp: ''!
inactiveFillStyle
	"Return the active fillStyle for the receiver."
	
	^self theme dialogWindowInactiveFillStyleFor: self! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
ok
	"Apply the changes and close."

	self
		cancelled: false;
		applyChanges;
		delete! !

!DialogWindowMorph methodsFor: 'theme' stamp: ''!
wantsRoundedCorners
	"Answer whether rounded corners are wanted."
	
	^(self theme dialogWindowPreferredCornerStyleFor: self) == #rounded! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
buttons
	"Answer the buttons in the button row"

	^self paneMorphs last lastSubmorph submorphs! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
escapePressed
	"Default is to cancel."

	self cancel! !

!DialogWindowMorph methodsFor: 'accessing' stamp: ''!
cancelled: anObject
	"Set the value of cancelled"

	cancelled := anObject! !

!DialogWindowMorph methodsFor: 'event handling' stamp: ''!
keyDown: evt
	"Check for return and escape keys."

	super keyDown: evt.
	(self defaultButton notNil and: [evt key = KeyboardKey enter or: [evt key = KeyboardKey keypadEnter]]) 
		ifTrue: [self returnPressed. ^true].
	
	evt key = KeyboardKey escape ifTrue: [self escapePressed. ^true].
	^false! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self newOKButton isDefault: true. self newCancelButton}! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
close
	"Close the window."

	self delete! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
applyChanges
	"Apply the changes."

	self acceptTextMorphs! !

!DialogWindowMorph methodsFor: 'theme' stamp: ''!
activeFillStyle
	"Return the active fillStyle for the receiver."
	
	^self theme dialogWindowActiveFillStyleFor: self! !

!DialogWindowMorph methodsFor: 'testing' stamp: ''!
canBeMaximized
	"Answer whether we are not we can be maximised."

	^self isResizeable
		ifTrue: [super canBeMaximized]
		ifFalse: [false]! !

!DialogWindowMorph methodsFor: 'top window' stamp: ''!
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]]! !

!DialogWindowMorph methodsFor: 'theme' stamp: ''!
animateClose
	"Animate closing."! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
defaultButton
	"Answer the default button."

	^self
		findDeepSubmorphThat: [:m |
			(m isKindOf: PluggableButtonMorph) and: [m isDefault]]
		ifAbsent: []! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
defaultLabel
	"Answer the default label for the receiver."

	^'Dialog' translated! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
cancel
	"Cancel and close."

	self close! !

!DialogWindowMorph methodsFor: 'initialization' stamp: ''!
setFramesForLabelArea
	"Delegate to theme."
	
	self theme configureDialogWindowLabelAreaFrameFor: self! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
addMainPanel
	"Add the main panel."

	self addMorph: self newMainPanel frame: (0@0 corner: 1@1)! !

!DialogWindowMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		cancelled: true;
		addInitialPanel! !

!DialogWindowMorph methodsFor: 'open/close' stamp: ''!
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! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
returnPressed
	"Default is to do the default button."

	(self defaultButton ifNil: [^self]) performAction! !

!DialogWindowMorph methodsFor: 'focus handling' stamp: ''!
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]]! !

!DialogWindowMorph methodsFor: 'controls' stamp: ''!
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)! !

!DialogWindowMorph methodsFor: 'initialization' stamp: ''!
initializeLabelArea
	"Initialize the label area (titlebar) for the window."
	
	super initializeLabelArea.
	self removeBoxes.
	self replaceBoxes! !

!DialogWindowMorph methodsFor: 'testing' stamp: ''!
defaultIsResizeable

	^ false! !

!DialogWindowMorph methodsFor: 'event handling' stamp: ''!
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])]! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
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! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
newMainPanel
	"Answer a new main panel."

	^self newDialogPanel
		addMorphBack: self newContentMorph;
		addMorphBack: self newButtonRow;
		yourself! !

!DialogWindowMorph methodsFor: 'accessing' stamp: ''!
cancelled
	"Answer the value of cancelled"

	^ cancelled! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
addInitialPanel
	"Add the panel."

	self addMainPanel! !

!DialogWindowMorph methodsFor: 'actions' stamp: ''!
mainPanel
	"Anwer the main panel morph or nil if not yet present."

	^self paneMorphs isEmpty
		ifFalse: [self paneMorphs first]! !

!DialogWindowPresenter commentStamp: ''!
A DialogWindowPresenter is a presenter used to describe a DialogWindow!
!DialogWindowPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	toolbar := OkCancelToolbar new asValueHolder.
	toolbar whenChangedDo: [ :t | self changed: #toolbar: with: { t } ]! !

!DialogWindowPresenter methodsFor: 'api' stamp: ''!
toolbar

	^ toolbar value! !

!DialogWindowPresenter methodsFor: 'api' stamp: ''!
triggerCancelAction

	self changed: #triggerCancelAction with: #()! !

!DialogWindowPresenter methodsFor: 'api' stamp: ''!
cancelAction: aBlock

	^ self changed: #cancelAction: with: { aBlock }! !

!DialogWindowPresenter methodsFor: 'api' stamp: ''!
okAction: aBlock

	^ self changed: #okAction: with: { aBlock }! !

!DialogWindowPresenter methodsFor: 'api' stamp: ''!
toolbar: aBar

	toolbar value: aBar! !

!DialogWindowPresenter methodsFor: 'api' stamp: ''!
cancelled

	^ self toolbar cancelled! !

!DialogWindowPresenter methodsFor: 'accessing' stamp: ''!
contents

	^ contents! !

!DialogWindowPresenter methodsFor: 'private' stamp: ''!
buildWithSpecLayout: aSpec
	"Build the widget using the spec name provided as argument"
	| widget |
	
	(self spec notNil and: [ self needRebuild not ])
		ifTrue: [ widget := self spec instance ]
		ifFalse: [ 
			contents := self model buildWithSpecLayout: aSpec.
			widget := self privateAdapterFromModel: self withSpec: self defaultSpecSelector.
			contents := nil ].

	self extent ifNotNil: [:ex | 
		(widget respondsTo: #extent:)
			ifTrue: [ widget extent: ex ]].
		
	^ widget! !

!DialogWindowPresenter methodsFor: 'api' stamp: ''!
triggerOkAction

	self changed: #triggerOkAction with: #()! !

!DialogWindowPresenter methodsFor: 'api' stamp: ''!
okButtonEnabled: aBoolean

	self changed: #okButtonEnabled: with: { aBoolean }! !

!DialogWindowPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(DialogWindowAdapter
		adapt: #(model))! !

!DialogWindowPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #DialogWindowAdapter! !

!Dictionary commentStamp: ''!
I am a collection of elements that associate a key object with a value object.

## Description


I  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.
I use the #= method to locate a key. If you want a collection that use the #== method (same pointers) you can use an IdentityDictionary.

I'm used when we need a collection of objects which I can access with a key. For example if you associate some words with a definition, the word will be the key and the definition will be the value. Both of them can be any kind of objects.

Internally I use Associations. The Association class can help to use me. (See examples lower)

## Public API and Key Messages

### Initializing and Adding

A `Dictionary` can be created with values using the `Collection class>>#withAll:` class selector which will add the 
values of a collection as the values of the `Dictionary` using numeric keys.

```
d := Dictionary withAll: #(1 2 3 4 5)  "a Dictionary(1->1, 2->2, 3->3, 4->4, 5->5)"
```

Alternatively, both the keys and values can be supplied using the `Dictionary class>>#newFromKeys:andValues:` selector,
which requires two collections of the same length, or the `Dictionary class>>#newFromPairs:` selector, which 
uses every odd numbered index as a key and even numbered index as a value for the dictionary.

Once a `Dictionary` has been created, the basic method for adding new keys is the `Dictionary>>#at:put:` selector.

```
d at: 99 put: 89  "a Dictionary(1->1, 2->2, 3->3, 4->4, 5->5, 99->89)"
```

### Accessing 

Get the value of a key using the `Dictionary>>#at:` selector.

```
d := Dictionary withAll: #(5 4 3 2 1)  "a Dictionary(1->5, 2->4, 3->3, 4->2, 5->1)"
d at: 1  "5"
```
However accessing a key that does not exist will result in an error. In which case use
the selectors `Dictionary>>#at:ifAbsent:`

```
d at: 100 ifAbsent: [ "execute code in the block if the key is not found" ]
```

A common operation is to add in a value for a key if it is absent using the `Dictionary>>#at:ifAbsentPut:` selector. Note that unlike the regular `Dictionary>>#at:put:` selector, this message uses the value of a block. 

```
d at: 100 ifAbsentPut: [ 100 ]
```

Alternatively, if you want to change the value of a key use `Dictionary>>#at:update:` selector,
which uses the value of a block.

```
d at: 5 update: [ 12 ]
"a Dictionary(1->5,2->4,3->3,4->2,5->12,100->100)"
```

### Iterating / Enumerating

It's possible to iterate over all of the values, keys, and associations of a `Dictionary` using 
the `Dictionary>>#valuesDo:`, `Dictionary>>#keysDo:`, and `Dictionary>>#associationsDo:` selectors. These selectors evaluate a block for
each of the items

```
"do: is an alias for valuesDo:"
d valuesDo: [ :eachValue | "do something with the value" ].
d keysDo: [ :eachKey | "do something with the key" ].
d associationsDo: [ :eachAssociation | "do something with a key-value pair" ]
```

The `Dictionary>>#select:` selector is also implemented to return a subset of the `Dictionary` where the
block evaluates to true using the value.

```
d select: [:each | each > 5]  "a Dictionary(5->12,100->100)"
``` 
		
### Removing

Use the `Dictionary>>#removeKey:` selector to remove the association from the `Dictionary`, which will cause
an error if the key is not found. Use the `Dictionary>>#removeKey:ifAbsent:` selector to control this behavior.

```
d removeKey: 5.
d removeKey: 1200.  "Error"
d removeKey: 1200 ifAbsent: [ "do something" ].
```

### Testing

Check if a value or key is present in a `Dictionary` using the `Dictionary>>#includes:` or `Dictionary>>#includesKey:` selectors.

```
"Look if 12 is the value of any key in the Dictionary"
d includes: 12.

"Look if 100 is a key in the Dictionary"
d includesKey: 100.
```
## Examples 


To create a dictionary with indexes as key: 

```
	Dictionary withAll: #(7 3 1 3)   		"returns:  a Dictionary(1->7 2->3 3->1 4->3 "
```

To use Objects as key (here symbols): 

```
	colors := Dictionary new 
				at: #yellow put: Color yellow; 
				at: #blue put: Color blue;
				at: #red put: Color red;
				yourself.
				
	colors at: #yellow. 	"returns:  Color yellow"
	colors keys          "returns: a Set(#blue #yellow #red)"
	colors values       "returns:  {Color blue. Color yellow. Color red}" 
```

You can also directly use Associations: 

```
	colors := Dictionary with: #yellow -> Color yellow with: #blue -> Color blue.
	colors add: #red -> Color red.
	
	colors associations  	"returns: {#yellow->Color yellow. #red->Color red. #blue->Color blue}"
```
	
Here some more examples: 

```
	colors := Dictionary newFrom: { #blue->Color blue . #red->Color red . #yellow->Color yellow }. 
	colors removeKey: #blue. 
	colors at: #red ifPresent: [ :color |  color darker] ifAbsent: [ Error signal: 'The red color should be here.' ] .		"return: (Color r: 0.92 g: 0.0 b: 0.0 alpha: 1.0)"
	colors associations 		 "{#yellow->Color yellow. #red->Color red}"
```

## Internal Representation and Key Implementation Points.

I am just a collection of associations. If I need my keys I will just return the keys of my associations. Idem for my values.
I use the #= method in order to manipulate my keys. I cannot have two associations that are equals with the #= method.!
!Dictionary methodsFor: 'removing' stamp: ''!
remove: anObject ifAbsent: exceptionBlock

	self shouldNotImplement! !

!Dictionary methodsFor: 'removing' stamp: ''!
keysAndValuesRemove: keyValueBlock
	"Removes all entries for which keyValueBlock returns true."
	"When removing many items, you must not do it while iterating over the dictionary, since it may be changing.  This method takes care of tallying the removals in a first pass, and then performing all the deletions afterward.  Many places in the sytem could be simplified by using this method."

	| removals |
	removals := OrderedCollection new.
	self associationsDo:
		[:assoc | (keyValueBlock value: assoc key value: assoc value)
			ifTrue: [removals add: assoc key]].
 	removals do:
		[:aKey | self removeKey: aKey]! !

!Dictionary methodsFor: 'accessing' stamp: ''!
associationAt: key ifPresent: aBlock
	"Answer the value of evaluating aBlock optionally with the association
	for the given key. If the key is not found, return nil."

	^ (array at: (self findElementOrNil: key))
		ifNotNil: [ :assoc | aBlock cull: assoc ]! !

!Dictionary methodsFor: 'flat collect' stamp: ''!
flatCollect: aBlock 
	"Evaluate aBlock for each of the receiver's values (by opposition to keys) and answer the
	list of all resulting values flatten one level. Assumes that aBlock returns some kind
	of collection for each element. Equivalent to the lisp's mapcan"
	"If you want to have keys use associations collect: or associations flatCollect: "
	
	^ self flatCollect: aBlock as: OrderedCollection! !

!Dictionary methodsFor: 'testing' stamp: ''!
includes: anObject

	"Check if anObject is one of the values in the dictionary"

	self do: [ :each | anObject = each ifTrue: [ ^ true ] ].
	^ false! !

!Dictionary methodsFor: 'testing' stamp: ''!
includesAssociation: anAssociation
  ^ (self   
      associationAt: anAssociation key
      ifAbsent: [ ^ false ]) value = anAssociation value! !

!Dictionary methodsFor: 'accessing' stamp: ''!
at: key ifPresent: aBlock
	"Lookup the given key in the receiver. If it is present, answer the
	value of evaluating the given block optionally with the value associated
	with the key.
	Otherwise, answer nil."

	^(array at: (self findElementOrNil: key))
		ifNotNil: [:assoc | aBlock cull: assoc value]! !

!Dictionary methodsFor: 'testing' stamp: ''!
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: ''!
isDictionary
	^true! !

!Dictionary methodsFor: 'adding' stamp: ''!
declare: key from: aDictionary 
	"Add key to the receiver. If key already exists, do nothing. If aDictionary 
	includes key, then remove it from aDictionary and use its association as 
	the element of the receiver."

	(self includesKey: key) ifTrue: [^ self].
	(aDictionary includesKey: key)
		ifTrue: 
			[self add: (aDictionary associationAt: key).
			aDictionary removeKey: key]
		ifFalse: 
			[self add: key -> nil]! !

!Dictionary methodsFor: 'accessing' stamp: ''!
associationAt: key 
	"Returns the association for the given key."

	^ self associationAt: key ifAbsent: [self errorKeyNotFound: key]! !

!Dictionary methodsFor: 'private' stamp: ''!
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: '*Fuel-Core' stamp: ''!
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-Core' stamp: ''!
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: 'accessing' stamp: ''!
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: 'enumerating' stamp: ''!
do: aBlock

	"An alias for valuesDo:. Evaluate aBlock for each of my values."

	^ self valuesDo: aBlock! !

!Dictionary methodsFor: 'accessing' stamp: ''!
at: key ifAbsentPut: aBlock
	"Return the value at the given key.
	If the key is not included in the receiver store and return the result 
	of evaluating aBlock as the new value."

	^ self at: key ifAbsent: [self at: key put: aBlock value]! !

!Dictionary methodsFor: 'enumerating' stamp: ''!
keysAndValuesDo: aBlock

	"
	Evaluate aBlock for each of the receiver's keys and values. The block must accept two 
	inputs, the first being the key and the second being the value. See keysDo: or valuesDo: 
	if you only need to evaluate one or the other. Also see associationsDo: for a similar 
	selector where the block accepts a single agrument.
	
	```
	d := Dictionary withAll: #(4 5 9 6 76).
	a := OrderedCollection new.
	d keysAndValuesDo: [ :k :v | a add: v. a add: k ]. ""an OrderedCollection(75 5 8 3 3 1 5 4 4 2)""
	```
	"

	^ self associationsDo: [ :assoc | 
		  aBlock value: assoc key value: assoc value ]! !

!Dictionary methodsFor: 'accessing' stamp: ''!
at: key update: updateBlock initial: initBlocktOrValue
	"I am used to update the value at a given key. The updateBlock is passed 
	the existing value, and the result of the block is stored back.
	If the key does not exist, store the value of the initBlocktOrValue.
	initBlocktOrValue can be a block in case the initial value is expencive to compute.
	I use findElementOrNil: to avoid looking up the key twice."
	| index |
	index := self findElementOrNil: key.
	(array at: index)
		ifNil: [ self atNewIndex: index put: key -> initBlocktOrValue value]
		ifNotNil: [ :assoc | assoc value: (updateBlock value: assoc value) ]! !

!Dictionary methodsFor: 'enumerating' stamp: ''!
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: 'private' stamp: ''!
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' stamp: ''!
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: 'testing' stamp: ''!
isHealthy
	"Test that object hashes match their positions stored in set's array,
	answer true if everything ok, false otherwise
	
	Dictionary allInstances select: [:dict |
		dict isHealthy not ]
	Dictionary allSubInstances select: [:dict |
		dict isHealthy not ]
	"
	array withIndexDo: [:elem :i |
		elem ifNotNil: [
			(self scanFor: elem key) == i ifFalse: [ ^ false ]
			]
	].
	^ true! !

!Dictionary methodsFor: 'removing' stamp: ''!
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: '*STON-Core' stamp: ''!
stonPostReferenceResolution
	"When references were resolved in me, the hash of my keys might have changed.
	Check if I am still healthy and rehash me if not."
	
	self isHealthy ifFalse: [ self rehash ]! !

!Dictionary methodsFor: 'accessing' stamp: ''!
associationAt: key ifAbsent: aBlock
	"Answer the association with the given key.
	If the key is not found, return the result of evaluating aBlock."

	^ (array at: (self findElementOrNil: key))
		ifNil: [ aBlock value ]
		ifNotNil: [ :assoc | assoc ]! !

!Dictionary methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionItems: aBuilder
	<inspectorPresentationOrder: 0 title: 'Items'> 
	
	^ aBuilder newTable 
		addColumn: (SpStringTableColumn 
			title: 'Key'
			evaluated: [ :each | StObjectPrinter asTruncatedTextFrom: each key ])
			beSortable;
		addColumn: (SpStringTableColumn 
			title: 'Value' 
			evaluated: [ :each | StObjectPrinter asTruncatedTextFrom: each value ])
			beSortable;
		items: (self associations collect: [:e | StInspectorAssociationNode hostObject: e ]);
		yourself! !

!Dictionary methodsFor: 'accessing' stamp: ''!
associationAt: key ifPresent: aPresentBlock ifAbsent: anAbsentBlock
	"Lookup the given key in the receiver. If it is present, answer the
	value of evaluating the first block optionally with the association for the key.
	Otherwise answer the value of the second block."

	self associationAt: key ifPresent: [:assoc | ^ aPresentBlock cull: assoc].
	^ anAbsentBlock value! !

!Dictionary methodsFor: 'accessing' stamp: ''!
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: ''!
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: 'copying' stamp: ''!
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: ''!
valuesDo: aBlock

	"Evaluate aBlock for each of the receiver's values.  Implemented with == checks
	merely for the sake of maximum efficiency

	
	The result of any transformation of each value is not reflected in the dictionary.
	If you wish to do this use the select: message.
	
	```
	d := Dictionary withAll: #(1 2 3 4 5).
	d valuesDo: [ :each | each * 7 ].  ""a Dictionary(1->1 2->2 3->3 4->4 5->5 )""
	```
	
	However you can assign results to another collection in the block if you want.
	(Note that the ordering isn't guarenteed)
	
	```
	a := OrderedCollection new.
	d valuesDo: [ :each | a add: each * 7 ].  ""an OrderedCollection(35 21 7 28 14)""
	```
	"

	tally = 0 ifTrue: [ ^ self ].
	1 to: array size do: [ :eachIndex | 
		| eachAssociation |
		eachAssociation := array at: eachIndex.
		nil == eachAssociation ifFalse: [ 
			aBlock value: eachAssociation value ] ]! !

!Dictionary methodsFor: 'nested dictionaries' stamp: ''!
at: firstKey at: secondKey put: aValue
	"Set a value at secondKey in the dictionary returned by firstKey."

	| subDictionary |
	subDictionary := self at: firstKey ifAbsentPut: [ self species new ].
	^ subDictionary at: secondKey put: aValue! !

!Dictionary methodsFor: 'accessing' stamp: ''!
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: 'removing' stamp: ''!
removeKey: key 
	"Remove key from the receiver.
	If key is not in the receiver, notify an error."

	^ self removeKey: key ifAbsent: [self errorKeyNotFound: key]! !

!Dictionary methodsFor: 'undeclared' stamp: ''!
unreferencedKeys
	"This is private code for the Undeclared handling"

	^self keys select: [ :key | 
			(self systemNavigation allReferencesTo: (self associationAt: key)) isEmpty ]! !

!Dictionary methodsFor: 'private' stamp: ''!
errorValueNotFound: value

	ValueNotFound signalFor: value! !

!Dictionary methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForKeysFor: aStep
	<stSpotterOrder: 15>
	aStep listProcessor
			title: 'Keys';
			allCandidates: [ self keys ];
			candidatesLimit: 5;
			filter: StFilterSubstring! !

!Dictionary methodsFor: 'accessing' stamp: ''!
at: key ifPresent: aPresentBlock ifAbsent: anAbsentBlock
	"Lookup the given key in the receiver. If it is present, answer the
	value of evaluating the first block optionally with the value associated
	with the key.
	Otherwise answer the value of the second block."

	self at: key ifPresent: [:v | ^ aPresentBlock cull: v].
	^ anAbsentBlock value! !

!Dictionary methodsFor: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
includesKey: key 
	"Answer whether the receiver has a key equal to the argument, key."
	
	^ (array at: (self scanFor: key)) ~~ nil 
	"We could use #notNil here, but ProtoObject doesn't understand it."! !

!Dictionary methodsFor: 'nested dictionaries' stamp: ''!
at: firstKey at: secondKey ifAbsentPut: aZeroArgBlock
	"Return the object stored in the second dictionary at secondKey. The second dictionary is accessed via the key firstKey. If firstKey is not defined, set a new dictionary for the second key and set the value of aZeroArgBlock execution. If firstKey is defined and not second key set the value of aZeroArgBlock execution. See NestedDictionaryTest for examples."

	| subDictionary |
	subDictionary := self at: firstKey ifAbsentPut: [ self species new ].
	^ subDictionary at: secondKey ifAbsentPut: aZeroArgBlock! !

!Dictionary methodsFor: 'nested dictionaries' stamp: ''!
at: firstKey at: secondKey
	"Return the object stored in the second dictionary at secondKey. The second dictionary is accessed via the key firstKey."

	"
	(Dictionary new
		at: #top at: #below1 put: 1;
		at: #top at: #below1 put: 2;
		at: #top at: #below1)
	>>>
	2"

	^ self at: firstKey at: secondKey ifAbsent: [self errorKeyNotFound: secondKey]! !

!Dictionary methodsFor: 'private' stamp: ''!
rehash
	"Smalltalk rehash."
	| newSelf |
	newSelf := self species new: self size.
	self associationsDo: [:each | newSelf noCheckAdd: each].
	array := newSelf array! !

!Dictionary methodsFor: 'enumerating' stamp: ''!
associationsDo: aBlock

	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations). See keysDo: or valuesDo: if you only need to evaluate
	one or the other. Also see keysAndValuesDo: for a similar 
	selector where the block accepts a two agruments.

	```
	d := Dictionary withAll: #(4 5 9 6 76).
	a := OrderedCollection new.
	d keysAndValuesDo: [ :assoc | a add: assoc value. a add: assoc key ].
	a. ""an OrderedCollection(75 5 8 3 3 1 5 4 4 2)""
	```
	"

	tally = 0 ifTrue: [ ^ self ].
	array do: [ :each | each ifNotNil: [ aBlock value: each ] ]! !

!Dictionary methodsFor: 'comparing' stamp: ''!
= 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.
	See issue 16760 before changing"

	self == aDictionary ifTrue: [^true].
	self species == aDictionary species ifFalse: [^false].
	self size = aDictionary size ifFalse: [^false].
	self associationsDo: [:assoc|
		(aDictionary at: assoc key ifAbsent: [^false]) = assoc value
			ifFalse: [^false]].
	^true! !

!Dictionary methodsFor: 'adding' stamp: ''!
add: anAssociation

	"Add anAssociation to the dictionary. If the key is already in the dictionary then the value 
	will overwrite the one currently present.
	
	```
	d := Dictionary new at: 5 put: 1; yourself.  ""a Dictionary(5->1)""
	d add: 5-> 12.  ""a Dictionary(5->12)""
	a add: 4->4. ""a Dictionary(5->12,4->4)""
	```
	"
	
	| index element |
	index := self findElementOrNil: anAssociation key.
	element := array at: index.
	element
		ifNil: [ self atNewIndex: index put: anAssociation ]
		ifNotNil: [ element value: anAssociation value ].
	^ anAssociation! !

!Dictionary methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
errorKeyNotFound: aKey

	KeyNotFound signalFor: aKey! !

!Dictionary methodsFor: 'accessing' stamp: ''!
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: ''!
keys
	"Answer an Array containing the receiver's keys."
	
	^Array new: self size streamContents: [:s| self keysDo: [:key| s nextPut: key]]! !

!Dictionary methodsFor: 'enumerating' stamp: ''!
keysDo: aBlock

	"Evaluate aBlock for each of the receiver's keys.

	
	Iterating through the keys does not create a new dictionary but you can save the results
	to another collection 
	
	```
	d := Dictionary withAll: #(4 5 9 6 76).
	a := OrderedCollection new.
	d keysDo: [ :each |  a add: each ]. ""an OrderedCollection(5 3 1 4 2)""
	```
	
	It's also possible to modify the dictionary while iterating through the keys
	
	```
	d := Dictionary withAll: #(4 5 9 6 76).
	d keysDo: [ :each | d at: each put: (d at: each) - 1 ]  ""a Dictionary(1->3 2->4 3->8 4->5 5->75 )""
	```
	"

	self associationsDo: [ :association | aBlock value: association key ]! !

!Dictionary methodsFor: 'enumerating' stamp: ''!
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.

	```	
	d := Dictionary withAll: #(1 2 3 4 5). ""a Dictionary(1->1 2->2 3->3 4->4 5->5 )""
	d select: [ :each | each even ]. ""a Dictionary(2->2 4->4 )""
	```
	"

	| newCollection |
	newCollection := self copyEmpty.
	self associationsDo: [ :each | 
		(aBlock value: each value) ifTrue: [ newCollection add: each copy ] ].
	^ newCollection! !

!Dictionary methodsFor: 'accessing' stamp: ''!
bindingOf: varName
	^self associationAt: varName ifAbsent:[nil]! !

!Dictionary methodsFor: '*NewValueHolder-Core' stamp: ''!
asValueHolder

	^ DictionaryValueHolder value: self! !

!Dictionary methodsFor: 'accessing' stamp: ''!
at: key 
	"Answer the value associated with the key."

	^ self at: key ifAbsent: [self errorKeyNotFound: key]! !

!Dictionary methodsFor: 'accessing' stamp: ''!
at: key ifPresent: aPresentBlock ifAbsentPut: anAbsentBlock
	"Lookup the given key in the receiver. If it is present, answer the
	value of evaluating the first block optionally with the value associated
	with the key.
	Otherwise store and return the result of evaluating the second block as the
	new value of the key."

	^ self
		at: key
		ifPresent: aPresentBlock
		ifAbsent: [self at: key put: anAbsentBlock value]! !

!Dictionary methodsFor: 'accessing' stamp: ''!
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: 'removing' stamp: ''!
remove: anObject

	self shouldNotImplement! !

!Dictionary methodsFor: 'nested dictionaries' stamp: ''!
at: firstKey at: secondKey ifAbsent: aZeroArgBlock
		"Return the object stored in the second dictionary at secondKey. The second dictionary is accessed via the key firstKey. Execute aZeroArgBlock in case one of the key is wrong."
		
	| subDictionary |
	subDictionary := self at: firstKey ifAbsent: [ ^ aZeroArgBlock value ].
	^ subDictionary at: secondKey ifAbsent: aZeroArgBlock! !

!Dictionary methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"Instances of STON mapClass will be encoded directly, without a class tag.
	Other (sub)classes will be encoded with a class tag and will use a map representation. "
	
	self class == STON mapClass
		ifTrue: [ 
			stonWriter writeMap: self ]
		ifFalse: [ 
			stonWriter 
				writeObject: self 
				do: [ stonWriter encodeMap: self ] ]! !

!Dictionary methodsFor: 'enumerating' stamp: ''!
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: 'testing' stamp: ''!
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: 'printing' stamp: ''!
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: 'private' stamp: ''!
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: 'accessing' stamp: ''!
at: key update: updateBlock 
	"I am used to update the value at a given key, or if the key does not exist, to throw an error"
	self at: key update: updateBlock initial: [ self errorKeyNotFound: key ].! !

!Dictionary methodsFor: 'undeclared' stamp: ''!
removeUnreferencedKeys
	"This is private code for the Undeclared handling, not a general API." 
	"Undeclared removeUnreferencedKeys"

	^ self unreferencedKeys do: [ :key | self removeKey: key ]! !

!Dictionary methodsFor: 'enumerating' stamp: ''!
bindingsDo: aBlock

	"An alias for associationsDo:"

	self associationsDo: aBlock! !

!Dictionary methodsFor: 'private' stamp: ''!
valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary 
	"Support for coordinating class variable and global declarations
	with variables that have been put in Undeclared so as to
	redirect all references to the undeclared variable."

	(aDictionary includesKey: aKey)
		ifTrue: 
			[self atNewIndex: index 
				put: ((aDictionary associationAt: aKey) value: anObject).
			aDictionary removeKey: aKey]
		ifFalse: 
			[self atNewIndex: index put: (Association key: aKey value: anObject)]! !

!Dictionary methodsFor: 'accessing' stamp: ''!
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 <obj, string, num> 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: 'adding' stamp: ''!
addAll: aKeyedCollection

	"Add all of the keys and values from aKeyedCollection to the dictionary.
	If the key already exists then the value is overwritten.
	
	```
	d1 := Dictionary new at: 1 put: 2; at: 2 put: 5; yourself.
	d2 := Dictionary new at: 1 put: 4; at: 100 put 6; yourself.
	d1 addAll: d2.  ""d1 now a Dictionary(1->4,2->5,100->6)""
	```
	"

	aKeyedCollection == self ifFalse: [ 
		aKeyedCollection keysAndValuesDo: [ :key :value | 
			self at: key put: value ] ].
	^ aKeyedCollection! !

!Dictionary methodsFor: 'accessing' stamp: ''!
values
	"Answer a Collection containing the receiver's values."
	^Array 
		new: self size 
		streamContents: [ :out | self valuesDo: [:value | out nextPut: value]]! !

!Dictionary methodsFor: 'enumerating' stamp: ''!
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: 'printing' stamp: ''!
storeOn: aStream
	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new)'.
	noneYet := true.
	self associationsDo: 
			[:each | 
			noneYet
				ifTrue: [noneYet := false]
				ifFalse: [aStream nextPut: $;].
			aStream nextPutAll: ' add: '.
			aStream store: each].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !

!Dictionary methodsFor: '*TaskIt' stamp: ''!
removeKeyAtValue: aValue
	| key |
	key := self keyAtValue: aValue ifAbsent: [ nil ].
	key ifNotNil: [ self removeKey: key ].
	^ key! !

!Dictionary class methodsFor: '*Microdown-MicrodownRichTextComposer' stamp: ''!
newFromAssociations: anAssocCollection
	"Return a dictionary with the Associations in anAssocCollection.
	If the same key appears twice in anAssocCollection, the last one enumerated will win"
	
	^ anAssocCollection 
		inject: Dictionary new 
		into: [ :dict :assoc | dict add: assoc. dict ]! !

!Dictionary class methodsFor: 'instance creation' stamp: ''!
newFromKeys: keys andValues: values
	"Create a dictionary from the keys and values arguments which should have the same length."
	"(Dictionary newFromKeys: #(#x #y) andValues: #(3 6)) >>> (Dictionary new at: #x put: 3; at: #y put: 6 ;yourself)"
	
	| dict |
	dict := self new.
	keys with: values do: [ :k :v | dict at: k put: v ].
	^ dict! !

!Dictionary class methodsFor: 'instance creation' stamp: ''!
newFromPairs: anArray
	"Answer an instance of me associating (anArray at: i) to (anArray at: i+1)
	 for each odd i.  anArray must have an even number of entries."

	"Dictionary newFromPairs: {'Red' . Color red . 'Blue' . Color blue . 'Green' . Color green}."

	| 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 class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Instances of STON mapClass will be read directly and won't arrive here.
	Other (sub)classes will use this method."
	
	| dictionary |
	dictionary := self new.
	stonReader parseMapDo: [ :key :value |
		dictionary at: key put: value ].
	^ dictionary! !

!Dictionary class methodsFor: 'instance creation' stamp: ''!
newFrom: aDict 
	"Answer an instance of me containing the same associations as aDict.
	 Error if any key appears twice."
	| newDictionary |
	newDictionary := self new: aDict size.
	aDict associationsDo:
		[:x |
		(newDictionary includesKey: x key)
			ifTrue: [self error: 'Duplicate key: ', x key printString]
			ifFalse: [newDictionary add: x]].
	^ newDictionary

"	NewDictionary newFrom: {1->#a. 2->#b. 3->#c}
	{1->#a. 2->#b. 3->#c} as: NewDictionary
	NewDictionary newFrom: {1->#a. 2->#b. 1->#c}
	{1->#a. 2->#b. 1->#c} as: NewDictionary
"! !

!DictionaryTest commentStamp: ''!
SUnit tests for dictionaries!
!DictionaryTest methodsFor: 'requirements' stamp: ''!
collection
	^ self nonEmptyDict! !

!DictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne).! !

!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |

	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream  do:
		[:each1 |
		self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ]
		 ].! !

!DictionaryTest methodsFor: 'tests - comparing' stamp: ''!
testEquality
	| nonEmptyDict2 |
	nonEmptyDict2 := self nonEmpty class new.
	self nonEmpty keysAndValuesDo:  [ :key :value | nonEmptyDict2 at: key put: value  ].
	
	self assert: (self nonEmptyDict = nonEmptyDict2)! !

!DictionaryTest methodsFor: 'tests - dictionary key access' stamp: ''!
testKeyAtIdentityValue
	
	
	| dict value result |
	dict := self nonEmpty .
	value := dict values anyOne.
	
	result := dict keyAtIdentityValue: value.
	self assert: (dict at: result) = value.
		
	self should: [dict keyAtIdentityValue: self valueNotIn ] raise: Error! !

!DictionaryTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!DictionaryTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index key between bounds of 'nonEmpty'"

	^ #a! !

!DictionaryTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!DictionaryTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!DictionaryTest methodsFor: 'tests - removing' stamp: ''!
testKeysAndValuesRemove
	| oldSize collection keyIn |
	
	collection := self nonEmptyDict .
	oldSize := collection  size.
	keyIn := collection keys anyOne.
	
	collection  keysAndValuesRemove: [:key :value | key == self keyNotInNonEmptyDict ].
	self assert: (collection  size = (oldSize )).
	
	collection  keysAndValuesRemove: [:key :value | key == keyIn ].
	self assert: (collection  size = (oldSize - 1)).
	self should: [ collection at: keyIn  ] raise: Error.! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!DictionaryTest methodsFor: 'tests - copy' stamp: ''!
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 - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!DictionaryTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter
	
	| result allElementsAsString tmp |
	
	result := String streamContents: [ :aStream |
		tmp := OrderedCollection new.
		self nonEmpty do: [:each | tmp add: each asString].
		self nonEmpty printOn: aStream delimiter: ', ' ].
	
	allElementsAsString := (result findBetweenSubstrings: ', ').
	
	1 to: allElementsAsString size do:
		[:i | 
		self assert: (tmp occurrencesOf:(allElementsAsString at:i)) equals: (allElementsAsString  occurrencesOf:(allElementsAsString at:i)) ].! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithoutEqualsValues
" return a dictionary that doesn't include equal values'"
^nonEmpty5ElementsNoDuplicates! !

!DictionaryTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printElementsOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	1 to: allElementsAsString size do:
		[:i | 
		self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString  occurrencesOf:(allElementsAsString at:i)).
			].! !

!DictionaryTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!DictionaryTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtIfAbsentPut
	"self run: #testAtIfAbsentPut"

	| collection association |
	collection := self nonEmpty.
	association := collection associations anyOne.
	self
		assert:
			(collection at: association key ifAbsentPut: [ Error signal ])
				= association value.
	self assert: (collection at: association key) = association value.
	self
		assert:
			(collection at: self keyNotIn ifAbsentPut: [ self valueNotIn ])
				= self valueNotIn.
	self assert: (collection at: self keyNotIn) = self valueNotIn! !

!DictionaryTest methodsFor: 'tests - flatCollect' stamp: ''!
testFlatCollect2

	| res |
 	res := {#first -> #(-2 3). #second -> #(-4 5)} asDictionary flatCollect: [:e | e collect: [:each | each abs]].
 	self assert: res asSet equals: #(2 3 4 5) asSet.! !

!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty
	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testValuesDo
	| collection values |
	collection := self nonEmptyDict .
	values := OrderedCollection new.
	collection valuesDo: [ :value  | 
		values add: value.
		].
	
	collection values do: [ :value | self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]! !

!DictionaryTest methodsFor: 'tests - comparing' stamp: ''!
testOtherDictionaryEquality
	self otherDictionaryClasses
		do: [ :each | 
			| nonEmptyDict2 |
			nonEmptyDict2 := each new.
			self deny: self empty equals: nonEmptyDict2.
			self deny: nonEmptyDict2 equals: self empty.

			self nonEmptyDict keysAndValuesDo: [ :key :value | nonEmptyDict2 at: key put: value ].
			self deny: self nonEmptyDict equals: nonEmptyDict2.
			self deny: nonEmptyDict2 equals: self nonEmptyDict ]! !

!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringOne
	
	self nonEmpty1Element do: 
		[:each | 
		self assert: each asString =self nonEmpty1Element  asCommaString.
		self assert: each asString=self nonEmpty1Element  asCommaStringAnd.].! !

!DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testCollect
	| collection values result |
	collection := self nonEmptyDict .
	values := OrderedCollection new.
	result := collection collect: [ :value  | 
		values add: value.
		].
	
	collection values do: [ :value | self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)].
	self assert: result = collection.! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
canBeUnhealthy
	^ true! !

!DictionaryTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	
	^ associationNotIn! !

!DictionaryTest methodsFor: 'tests - adding' stamp: ''!
testAddAll
	
	| collectionToAdd collection result oldSize |
	collection := self nonEmptyDict .
	oldSize := collection size.
	collectionToAdd := self collectionClass new 
		add: self associationWithKeyAlreadyInToAdd ; 
		add: self associationWithKeyNotInToAdd ; 
		yourself.
	
	result := collection addAll: collectionToAdd .
	
	self assert: result = collectionToAdd .
	"  the association with the key already in should have replaced the oldest :"
	self assert: collection  size = (oldSize + 1).
	
	result associationsDo: [:assoc | self assert: (collection at:  (assoc key) ) = assoc value].! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
anotherElementNotIn
	
	^ 42! !

!DictionaryTest methodsFor: 'tests - dictionary assocition access' stamp: ''!
testAssociationAtIfPresentifAbsent
	| collection keyIn found |
	found := false.
	collection := self nonEmpty.
	keyIn := collection keys anyOne.
	collection associationAt: keyIn ifPresent: [ found := true ] ifAbsent: [ 888 ].
	self assert: found.

	self assert: (collection associationAt: self keyNotIn ifAbsent: [ 888 ]) = 888.

	self assert: (collection associationAt: self keyNotIn ifPresent: [ 666 ] ifAbsent: [ 888 ]) = 888! !

!DictionaryTest methodsFor: 'tests - copying' stamp: ''!
testDictionaryConcatenationWithCommonKeysDifferentValues

	| dictionary1 dictionary2 result value |
	
	dictionary1 := self nonEmptyDict.
	value := self nonEmptyDifferentFromNonEmptyDict   values anyOne.
	dictionary2 := dictionary1 copy.
	dictionary2 keys do: [ :key | dictionary2 at: key put: value ].
	
	
	result := dictionary1 , dictionary2.
	self assert: result size = ( dictionary2 size).
	
	dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! !

!DictionaryTest methodsFor: 'tests - testing' stamp: ''!
testIncludeAssociation
	self assert: (nonEmptyDict includesAssociation: #a -> self elementTwiceIn).
	self assert: (nonEmptyDict includesAssociation: (nonEmptyDict associations first)).! !

!DictionaryTest methodsFor: 'tests - flatCollect' stamp: ''!
testFlatCollect3

	| res |
 	res := {#first -> #(-2 3). #second -> #(-4 5)} asDictionary flatCollect: [:e | {e collect: [:each | each abs]}].
 	self assert: res asSet equals: #(#(2 3) #(4 5)) asSet.! !

!DictionaryTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
collectionClass
	"Return the class to be used to create instances of the class tested"

	^ self classToBeTested! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
newEmptyDict
	^ self emptyDict copy! !

!DictionaryTest methodsFor: 'tests - adding' stamp: ''!
testAddWithKeyAlreadyIn
	| dictionary result association |
	dictionary := self nonEmptyDict.
	association := self associationWithKeyNotInToAdd.
	result := dictionary add: association.
	self assert: result equals: association.
	self assert: (dictionary at: association key) equals: association value! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtIfAbsent
	"self run: #testAtIfAbsent"

	| collection association |
	collection := self nonEmpty.
	association := collection associations anyOne.
	self
		assert:
			(collection at: association key ifAbsent: [ Error signal ])
				= association value.
	self
		assert:
			(collection at: self keyNotIn ifAbsent: [ self valueNotIn ])
				= self valueNotIn! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryAssocitionAccess
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self keyNotIn.
	self deny: (self nonEmpty keys includes: self keyNotIn)! !

!DictionaryTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!DictionaryTest methodsFor: 'tests - converting' stamp: ''!
testAsByteArray

	| res |
	self integerCollectionWithoutEqualElements.
	self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ].
	res := true.
	self integerCollectionWithoutEqualElements
		detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
elementNotIn
	"return an element not included in 'nonEmpty' "
	^ valueNotIn! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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: 'requirements' stamp: ''!
keyNotInNonEmpty
	" return a key not included in nonEmpty"
	^ keyNotIn! !

!DictionaryTest methodsFor: 'tests - dictionary key access' stamp: ''!
testKeyAtIdentityValueIfAbsent
	"self run: #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] ) = nil.! !

!DictionaryTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result:=''.
	aStream:= ReadWriteStream on: result.
	self nonEmpty printNameOn: aStream.
	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ]
		ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutTest
	self aValue.
	self anotherValue.

	self anIndex.
	self nonEmpty isDictionary ifFalse: [ self assert: (self anIndex >= 1 & self anIndex) <= self nonEmpty size ].

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
" return a collection elements that can be sorte ( understanding message ' < '  or ' > ')"
	^ nonEmpty5ElementsNoDuplicates! !

!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtIfPresent
	"self run: #testAtIfPresent"

	| collection association arg |
	collection := self nonEmpty.
	association := collection associations anyOne.
	arg := nil.
	self
		assert:
			(collection
				at: association key
				ifPresent: [ :value | 
					arg := value.
					#present ]) = #present.
	self assert: arg = association value.

	"ensure cull: is used to support blocks that take no args"
	self
		assert: (collection at: association key ifPresent: [ #present ]) = #present.
	self
		assert:
			(collection
				at: self keyNotIn
				ifPresent: [ :value | Error signal ]) isNil! !

!DictionaryTest methodsFor: 'tests' stamp: ''!
testRemoveAll
	"Allows one to remove all elements of a collection"

	| dict1 dict2 s2 |
	dict1 := self collectionClass new.
	dict1
		at: #a put: 1;
		at: #b put: 2.

	dict2 := dict1 copy.
	s2 := dict2 size.

	dict1 removeAll.

	self assert: dict1 size equals: 0.
	self assert: dict2 size = s2 description: 'the copy has not been modified'! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!DictionaryTest methodsFor: 'tests' stamp: ''!
testCollectAsWithParenthesis

	| array dict |
	array := { 1. 2. 3 }.
	dict := (array collect: [ :each | each -> each asString ]) as:
		        Dictionary.
	self assert: dict equals: { 
			(1 -> '1').
			(2 -> '2').
			(3 -> '3') } asDictionary! !

!DictionaryTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!DictionaryTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesComportementForDictionnary
	| valueIn collection keyIn |
	collection := self nonEmpty.
	valueIn := collection values anyOne.
	keyIn := collection keys anyOne.
	self assert: (collection includes: valueIn).
	self deny: (collection includes: self valueNotInNonEmpty).
	" testing that includes take only care of values :"
	self deny: (collection includes: keyIn)! !

!DictionaryTest methodsFor: 'tests - integrity' stamp: ''!
testIsHealthy
	| dict |
	self canBeUnhealthy
		ifFalse: [
			self assert: self nonEmpty isHealthy.
			^ self ].
	dict := self emptyDict.
	[ | a1 a2 |
	"we use associations as keys on purpose, because they change their
	hash depending on the key"
	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 deny: dict isHealthy ]
		ensure: [ dict removeAll ]! !

!DictionaryTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesKey

	| collection keyIn nonExistantKey |

	collection := self nonEmpty .
	keyIn := collection keys anyOne.
	nonExistantKey := self keyNotInNonEmpty. 

	self assert: ( collection includesKey: keyIn ).
	self deny: ( collection includesKey: nonExistantKey ).! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
keyNotIn
" return a key not included in nonEmpty"
^ keyNotIn! !

!DictionaryTest methodsFor: 'tests - dictionary assocition access' stamp: ''!
testAssociationAtIfPresent

	| collection keyIn result |
	collection := self nonEmpty.
	keyIn := collection keys anyOne.

	result := collection associationAt: keyIn ifPresent: [:assoc | {#present. assoc}].
	self
		assert: result isArray;
		assert: result size = 2;
		assert: result first = #present;
		assert: result second key = keyIn;
		assert: result second value = (collection at: keyIn).

	"test that cull: is used to support zero-arg blocks"
	result := collection associationAt: keyIn ifPresent: [#present].
	self assert: result = #present.

	result := collection associationAt: self keyNotIn ifPresent: [:assoc | {#present. assoc}].
	self assert: result isNil.! !

!DictionaryTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!DictionaryTest methodsFor: 'tests - testing' stamp: ''!
testIsDictionary
	self deny: Object new isDictionary.
	self assert: nonEmptyDict isDictionary.
	self assert: emptyDict isDictionary.! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self collection associations anyOne.! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	^ nonEmptyDict! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryCopyingTest
	| duplicateKey |
	self nonEmptyDict.
	self denyEmpty: self nonEmptyDict.
	self nonEmptyDifferentFromNonEmptyDict.
	self denyEmpty: self nonEmptyDifferentFromNonEmptyDict.
	duplicateKey := true.
	self nonEmptyDict keys detect: [ :key | self nonEmptyDifferentFromNonEmptyDict includes: key ] ifNone: [ duplicateKey := false ].
	self deny: duplicateKey! !

!DictionaryTest methodsFor: 'tests - copy' stamp: ''!
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 - adding' stamp: ''!
testDeclareFrom
	| newDict v dictionary keyIn associationKeyNotIn |
	dictionary := self nonEmptyDict.
	keyIn := dictionary keys anyOne.
	associationKeyNotIn := self associationWithKeyNotInToAdd.
	newDict := self collectionClass new
		add: associationKeyNotIn;
		yourself.

	"if the key already exist, nothing changes"
	v := dictionary at: keyIn.
	dictionary declare: keyIn from: newDict.
	self assert: (dictionary at: keyIn) equals: 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) equals: associationKeyNotIn value.
	self assert: newDict size equals: 0! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
supportsNilKey
	^ true! !

!DictionaryTest methodsFor: 'tests - testing' stamp: ''!
testKeyForIdentity
	self assert: (nonEmptyDict keyForIdentity: 30) equals: #b.

	"The value 20 is associated to two different associations"
	self assert: (#(a c) includes: (nonEmptyDict keyForIdentity: self elementTwiceIn))! !

!DictionaryTest methodsFor: 'helpers' stamp: ''!
anotherValue

	^ 66! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
valueNotInNonEmpty
	" return a value not included in nonEmpty"
	^ valueNotIn! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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: 'coverage' stamp: ''!
classToBeTested 

	^ Dictionary! !

!DictionaryTest methodsFor: 'tests' stamp: ''!
testDictionaryPublicProtocolCompatibility
	"Tests that other dictionaries and their classes respond to the messages
	in the public protocols (ignoring extensions, private, printing, copying,
	and comparing) that Dictionary and its metaclass implement."

	| dict |
	self collectionClass == Dictionary
		ifTrue: [ ^ self ].
	dict := self emptyDict.
	{(dict -> Dictionary).
	(dict class -> Dictionary class)}
		do: [ :assoc | 
			assoc value protocols
				reject: [ :protocol | 
					#('private' 'print' 'undeclared' 'copy' 'compar' '*')
						anySatisfy: [ :each | protocol asString beginsWith: each ] ]
				thenDo: [ :protocol | 
					(assoc value selectorsInProtocol: protocol)
						do: [ :each | self assert: (assoc key respondsTo: each) ] ] ]! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
result
	^ self collectionClass newFromPairs: {
		#a . SmallInteger .
		#b . SmallInteger .
		#c . SmallInteger .
		#d . SmallInteger }! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
nonEmptyDict
	^ nonEmptyDict! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
empty
	^ emptyDict! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!DictionaryTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty

	| result |
	result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne).
	self assert: result equals: 0! !

!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |
	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream  do:
		[:each1 |
		self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ]
		 ].! !

!DictionaryTest methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testValues
	
	| collection result |
	collection := self nonEmpty .
	result := collection values.
	
	self assert: result size = collection size.
	result do: [:each | self assert: (collection occurrencesOf:each ) = (result occurrencesOf: each) ].! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
element
	^ 30! !

!DictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	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' stamp: ''!
testAtUpdateInitial
	| dict |
	dict := {2->10. 100->5} asDictionary.
	dict at: 5 update: [ :v | v+1 ] initial: [17].
	dict at: 2 update: [ :v | v+10 ] initial: [0].
	self assert: (dict at: 5) equals: 17.
	self assert: (dict at: 2) equals: 20! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
expectedElementByDetect
	^ 30! !

!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtPutNil
	"self run: #testAtPutNil"

	| collection keyIn newValue |
	collection := self nonEmpty.
	keyIn := collection keys anyOne.
	newValue := self valueNotIn.
	self assert: (collection at: nil put: newValue) == newValue.
	self supportsNilKey
		ifTrue: [ self assert: (collection at: nil) == newValue ]
		ifFalse: [ self deny: (collection includesKey: nil) ].
	self assert: (collection at: keyIn put: nil) isNil.
	self assert: (collection at: keyIn) isNil.
	self assert: (collection at: self keyNotIn put: nil) isNil.
	self assert: (collection at: self keyNotIn) isNil.
	self assert: (collection at: nil put: nil) isNil.
	self supportsNilKey
		ifTrue: [ self assert: (collection at: nil) isNil ]
		ifFalse: [ self deny: (collection includesKey: nil) ]! !

!DictionaryTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!DictionaryTest methodsFor: 'tests - testing' stamp: ''!
testIncludes
	| o1 o2 newDict |
	self assert: (nonEmptyDict includes: self element).

	o1 := 2 @ 3.
	o2 := 2 @ 3.
	self deny: o1 identicalTo: o2.
	self assert: o1 equals: o2.
	newDict := self collectionClass new.
	newDict at: #a put: o1.

	self assert: (newDict includes: o2)! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
" return a collection of size 1 including one element"
	^ nonEmpty1Element! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryIncludes
	| in |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self valueNotInNonEmpty.
	in := false.
	self nonEmpty valuesDo: [ :assoc | assoc = self valueNotInNonEmpty ifTrue: [ in := true ] ].
	self deny: in.
	self keyNotInNonEmpty.
	in := false.
	self nonEmpty keysDo: [ :assoc | assoc = self keyNotInNonEmpty ifTrue: [ in := true ] ].
	self deny: in! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesForMultiplinessTest
	| cpt |
	self collectionWithEqualElements.
	self collectionWithEqualElements.
	self elementTwiceInForOccurrences.
	self elementTwiceInForOccurrences.
	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' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryKeysValuesAssociationsAccess
	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!DictionaryTest methodsFor: 'tests - removing' stamp: ''!
testRemoveKeyIfAbsent
	
	| collection oldSize keyIn value result |
	collection := self nonEmptyDict .
	oldSize := collection size.
	keyIn := collection  keys anyOne.
	value := collection at: keyIn .
	
	result := collection removeKey: keyIn ifAbsent: [888].
	
	self assert: result = value.
	self assert: (collection  size = (oldSize - 1)).
	self should: [ (collection  at: keyIn )] raise: Error.
	
	self assert: (collection removeKey: self keyNotInNonEmptyDict ifAbsent: [888] ) = 888.! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest
	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!DictionaryTest methodsFor: 'tests - printing' stamp: ''!
testStoreOnWithNegativeInteger
	| dictionary |
	dictionary := { 'x' -> -1 } as: self classToBeTested.
	
	self
		assert: (String streamContents: [ :s | dictionary storeOn: s ])
		equals: '((',self classToBeTested name,' new) add: (''x''-> -1); yourself)'! !

!DictionaryTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!DictionaryTest methodsFor: 'tests - new' stamp: ''!
testNewFromPairs
	| assocs pairs |
	assocs := self nonEmptyDict associations.
	pairs := OrderedCollection new.
	assocs
		do: [ :each | 
			pairs
				add: each key;
				add: each value ].
	0 to: pairs size do: [ :i | 
		| dictFromPairs dictFromAssocs |
		dictFromPairs := self classToBeTested newFromPairs: (pairs copyFrom: 1 to: i).
		dictFromAssocs := self classToBeTested newFrom: (assocs copyFrom: 1 to: (i / 2) floor).
		self assert: dictFromPairs equals: dictFromAssocs ]! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
valueNotIn
" return a value not included in nonEmpty "
^valueNotIn! !

!DictionaryTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!DictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString tmp |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	tmp := self nonEmpty collect: [:each | each asString].
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	tmp do:[:each |
		self assert: (tmp occurrencesOf: each) = (allElementsAsString occurrencesOf: each)].
	self assert: ((allElementsAsString at: (allElementsAsString size - 1))=('and'))! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithCopyNonIdentical
" return a collection including elements for wich copy is not identical to the initial element ( this is not the cas of Integer )"
^nonEmptyWithString! !

!DictionaryTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesIdentitySpecificComportement

| valueIn collection |
collection := self nonEmptyWithCopyNonIdentical  .
valueIn := collection  values anyOne.

self assert: (collection includesIdentity: valueIn ) .
self deny: (collection includesIdentity: valueIn copy ) .! !

!DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
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' stamp: ''!
testAtUpdate
	| dict |
	dict := {2->10. 100->5} asDictionary.
	dict at: 2 update: [ :v | v+10 ].
	self assert: (dict at: 2) equals: 20.
	self should: [ dict at: 5 update: [ :v | v+1 ] ] raise: KeyNotFound .! !

!DictionaryTest methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testAssociations

	| collection result  |
	collection := self nonEmpty .
	result := collection associations.
	
	self assert: result size = collection size.
	result do: [:assoc | self assert: (assoc value) = (collection at: assoc key) ].
	"keys do: [ :key | self assert: ( result at: key ) = ( collection at: key )] ."! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryAddingTest
	self nonEmptyDict.
	self denyEmpty: self nonEmptyDict.
	self associationWithKeyNotInToAdd.
	self deny: (self nonEmptyDict keys includes: self associationWithKeyNotInToAdd key).
	self associationWithKeyAlreadyInToAdd.
	self assert: (self nonEmptyDict keys includes: self associationWithKeyAlreadyInToAdd key)! !

!DictionaryTest methodsFor: 'tests - adding' stamp: ''!
testAddWithKeyNotIn
	| dictionary result association |
	dictionary := self nonEmptyDict.
	association := self associationWithKeyNotInToAdd.
	result := dictionary add: association.
	self assert: result equals: association.
	self assert: (dictionary at: association key) equals: association value! !

!DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testReject
	"Ensure that Dictionary>>reject: answers a dictionary not something else"
	
	| collection result |
	collection := self nonEmptyDict .
	result := collection reject: [ :each | false].
	
	self assert: result = collection.! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
otherCollection
	"Returns a collection that does not include what is returned by #element."
	^ nonEmpty5ElementsNoDuplicates! !

!DictionaryTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!DictionaryTest methodsFor: 'tests - dictionary key access' stamp: ''!
testKeyAtValue
	"self run: #testKeyAtValue"
	
	| dict value result |
	dict := self nonEmpty .
	value := dict values anyOne.
	
	result := dict keyAtValue: value.
	self assert: (dict at: result) = value.
		
	self should: [dict keyAtValue: self valueNotIn ] raise: Error! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
" return a collection for wich each element is not included in 'nonEmpty' "
	^collectionNotIncluded! !

!DictionaryTest methodsFor: 'tests - new' stamp: ''!
testNewFrom
	| assocs |
	self assert: (self classToBeTested newFrom: {}) equals: self emptyDict.

	self assert: (self classToBeTested newFrom: nonEmptyDict copy) equals: self nonEmptyDict.

	assocs := self nonEmptyDict associations collect: [ :each | each copy ].
	self assert: (self classToBeTested newFrom: assocs) equals: self nonEmptyDict! !

!DictionaryTest methodsFor: 'tests - new' stamp: ''!
testNewFromKeysAndValues
 
	| keys values newDict |
	keys := self nonEmptyDict keys.
	values := self nonEmptyDict values.
	newDict := self classToBeTested newFromKeys: keys andValues: values.
	self nonEmptyDict keysAndValuesDo: [:k :v|
		self assert: (newDict at: k) equals: v ].! !

!DictionaryTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesIdentityBasicComportement

| valueIn collection |
collection := self nonEmpty .
valueIn := collection  values anyOne.

self assert: (collection includesIdentity: valueIn ) .
self deny: (collection includesIdentity: self valueNotInNonEmpty ).! !

!DictionaryTest methodsFor: 'tests - new' stamp: ''!
testNewFromKeysAndValues2
 
	| dict newDict |
	dict := self classToBeTested new
		at: #a put: 1;
		at: #b put: 2;
		at: #c put: 3; yourself.
	newDict := self classToBeTested newFromKeys: dict keys andValues: dict values.
	dict keysAndValuesDo: [:k :v|
		self assert: (newDict at: k) equals: v ].! !

!DictionaryTest methodsFor: 'tests - adding' stamp: ''!
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 equals: self associationWithKeyNotInToAdd! !

!DictionaryTest methodsFor: 'tests - dictionary assocition access' stamp: ''!
testAssociationAtError

	| collection nonExistantKey |
	collection := self nonEmpty.
	nonExistantKey := self keyNotIn .

	self should: [collection associationAt: nonExistantKey] raise: Error.! !

!DictionaryTest methodsFor: 'tests - dictionary key access' stamp: ''!
testKeyAtValueIfAbsent
 
	| dict value result |
	dict := self nonEmpty.
	value := dict values anyOne.
	result := dict keyAtValue: value ifAbsent: [ nil ].
	self assert: (dict at: result) equals: value.
	self assert: (dict keyAtValue: self valueNotIn ifAbsent: [ nil ]) isNil! !

!DictionaryTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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 - DictionaryIndexAccessing' stamp: ''!
testAtIfPresentIfAbsent
	"self run: #testAtIfPresentIfAbsent"

	| collection association arg |
	collection := self nonEmpty.
	association := collection associations anyOne.
	arg := nil.
	self
		assert:
			(collection
				at: association key
				ifPresent: [ :value | 
					arg := value.
					#present ]
				ifAbsent: [ Error signal ]) = #present.
	self assert: arg = association value.

	"ensure cull: is used to support blocks that take no args"
	self
		assert:
			(collection
				at: association key
				ifPresent: [ #present ]
				ifAbsent: [ Error signal ]) = #present.
	self
		assert:
			(collection
				at: self keyNotIn
				ifPresent: [ :value | Error signal ]
				ifAbsent: [ self valueNotIn ]) = self valueNotIn! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
elementToAdd
" return an element of type 'nonEmpy' elements'type'"
	^ #u->5.! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
nonEmptyDifferentFromNonEmptyDict
" return a dictionary for which all keys are not included in nonEmptyDict"
^ dictionaryNotIncluded! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryIncludesIdentity
	self nonEmptyWithCopyNonIdentical.
	self denyEmpty: self nonEmptyWithCopyNonIdentical.
	self nonEmptyWithCopyNonIdentical do: [ :each | self deny: each == each copy ]! !

!DictionaryTest methodsFor: 'tests' stamp: ''!
testCollectAsWithoutParenthesis

	| array dict |
	array := { 1. 2. 3 }.
	dict := array
		        collect: [ :each | each -> each asString ]
		        as: Dictionary.
	self assert: dict equals: { 
			(1 -> '1').
			(2 -> '2').
			(3 -> '3') } asDictionary! !

!DictionaryTest methodsFor: 'tests - new' stamp: ''!
testNew
	| d |
	d := self classToBeTested new: 10.
	self assert: d size equals: 0

	"Why 14? Mysterious"
	"self assert: d capacity = 14"! !

!DictionaryTest methodsFor: 'tests - copying' stamp: ''!
testDictionaryConcatenationWithCommonKeys

	| dictionary1 dictionary2 result |
	dictionary1 := self nonEmptyDict.
	dictionary2 := self nonEmptyDict.
	result := dictionary1 , dictionary2.
	self assert: result size = ( dictionary2 size).
	
	dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! !

!DictionaryTest methodsFor: 'tests' stamp: ''!
testAsSet
	
	| aDictionary aSet assoc0 assoc1 |
	aDictionary := Dictionary new.
	aSet := aDictionary asSet.
	"Add two associations to it"	
	assoc0 := #first -> 0.
	assoc1 := #first -> 1.
	aSet add: assoc0 copy; add: assoc1.
	
	"Check if the two associations were added (that should happen if they are different)"
	self
		assert: (assoc0 copy ~= assoc1) ==> (aSet size > 1)
		description:
  			'When adding two different elements, the set size should be greater than one'! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryRemovingTest
	self nonEmptyDict.
	self denyEmpty: self nonEmptyDict.
	self keyNotInNonEmptyDict.
	self deny: (self nonEmptyDict keys includes: self keyNotInNonEmptyDict)! !

!DictionaryTest methodsFor: 'tests - at put' stamp: ''!
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 - occurrencesOf for multipliness' stamp: ''!
testOccurrencesOfForMultipliness

	| collection elem |
	collection := self collectionWithEqualElements.
	elem := self elementTwiceInForOccurrences.

	self assert: (collection occurrencesOf: elem ) equals: 2.! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!DictionaryTest methodsFor: 'tests - at put' stamp: ''!
testAtPut
	
	self nonEmpty at: self anIndex put: self aValue.
	self assert: (self nonEmpty at: self anIndex) = self aValue.! !

!DictionaryTest methodsFor: 'tests - dictionary assocition access' stamp: ''!
testAssociationAtIfAbsent

	| collection keyIn result |
	collection := self nonEmpty.
	keyIn := collection keys anyOne.

	result := collection associationAt: keyIn ifAbsent: [888]. 

	self assert: (result key) = keyIn.
	self assert: (result value ) = (collection at: keyIn ).

	self assert: (collection associationAt: self keyNotIn  ifAbsent: [888] ) = 888! !

!DictionaryTest methodsFor: 'tests - flatCollect' stamp: ''!
testFlatCollect

	| res |
 	res := {#first -> -1. #second -> 5 . #three -> -33} asDictionary flatCollect: [:e | { e abs } ].
 	self assert: res asSet equals: #(1 5 33) asSet.! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
integerCollectionWithoutEqualElements
" return a collection of integer without equal elements"
	^ nonEmpty5ElementsNoDuplicates! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
collectionWithElement
	"Returns a collection that already includes what is returned by #element."
	^ nonEmpty5ElementsNoDuplicates add: self element ;yourself.! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
keyNotInNonEmptyDict
" return a key not included in nonEmptyDict"
	^ keyNotIn! !

!DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testKeysDo
	| collection keys |
	collection := self nonEmptyDict .
	keys := OrderedCollection new.
	collection keysDo: [ :key  | 
		keys add: key.
		].
	
	collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
associationWithKeyAlreadyInToAdd
	" return an association that will be used to add to nonEmptyDict (the key of this association is already included in nonEmptyDict)"
	^ (self nonEmptyDict keys anyOne)->valueNotIn .! !

!DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testAssociationsSelect
	| collection keys result |
	collection := self nonEmptyDict .
	keys := OrderedCollection new.
	result := collection associationsSelect: [ :assoc  | 
		keys add: assoc key.
		true].
	
	collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)].
	self assert: result = collection.! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
elementNotInForOccurrences
	^ 666! !

!DictionaryTest methodsFor: 'helpers' stamp: ''!
anIndex

	^ #GG! !

!DictionaryTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesAssociation

	|  nonExistantAssociation associationIn keyIn valueIn |

	keyIn := self nonEmpty keys anyOne.
	valueIn := self nonEmpty values anyOne. 
	nonExistantAssociation := self keyNotInNonEmpty -> self valueNotInNonEmpty .
	associationIn := self nonEmpty associations anyOne.	

	self assert:  (self nonEmpty includesAssociation: associationIn ).
	self deny:  (self nonEmpty includesAssociation: nonExistantAssociation ).
	" testing the case where key is included but not with the same value :"
	self deny: (self nonEmpty includesAssociation: (keyIn-> self valueNotInNonEmpty )).
	" testing the case where value is included but not corresponding key :"
	self deny: (self nonEmpty includesAssociation: (self keyNotInNonEmpty -> valueIn  )).! !

!DictionaryTest methodsFor: 'running' stamp: ''!
setUp
	super 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.
	nonEmptyWithString := Dictionary new add: #A->'foo'; add: #b->'bar' ; yourself.
	duplicateValue := 2.5.
	dictionaryWithDuplicateValues := 	Dictionary new add: #A->duplicateValue ; add: #b->3.5 ; add: #C->duplicateValue  ; yourself.! !

!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringMore

	| result resultAnd allElementsAsString tmp |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
	tmp :=OrderedCollection new. 
	self nonEmpty do: [ :each | tmp add: each asString].

	"verifying result  :"
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString do:
		[:each |
		self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each).
		].
	
	"verifying esultAnd :"
	allElementsAsString:=(resultAnd findBetweenSubstrings: ', ' ).
	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 - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAt
	"self run: #testAt"

	| collection association |
	collection := self nonEmpty.
	association := collection associations anyOne.
	self assert: (collection at: association key) = association value.
	self should: [ collection at: self keyNotIn ] raise: Error! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
associationWithKeyNotInToAdd
	" return an association that will be used to add to nonEmptyDict"
	^ associationNotIn! !

!DictionaryTest methodsFor: 'tests - removing' stamp: ''!
testRemoveKey
	
	| collection oldSize keyIn |
	collection := self nonEmptyDict .
	oldSize := collection size.
	keyIn := collection  keys anyOne.
	
	collection removeKey: keyIn .
	self assert: (collection  size = (oldSize - 1)).
	self should: [ (collection  at: keyIn )] raise: Error.
	
	self should: [collection removeKey: self keyNotInNonEmptyDict ] raise: Error! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!DictionaryTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testDo
	| t collection |
	collection := self nonEmptyDict .
	t := OrderedCollection new.
	collection do: [:
		value | t add: value
		].
	
	t do: [ :each | self assert: (t occurrencesOf: each ) = ( collection values occurrencesOf: each) ].! !

!DictionaryTest methodsFor: 'helpers' stamp: ''!
aValue

	^ 33! !

!DictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty ).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
" return a collection of elements included in 'nonEmpty'  "
	^ collectionIncluded! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryEnumeratingTest
	self nonEmptyDict.
	self denyEmpty: self nonEmptyDict! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
emptyDict
	^ emptyDict! !

!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtPutDict
	"Do not rename to testAtPut, will conflict with TPutBasicTest>>#testAtPut"

	"self run: #testAtPutDict"

	| collection keyIn newValue |
	collection := self nonEmpty.
	keyIn := collection keys anyOne.
	newValue := self valueNotIn.

	"use == to ensure the exact object argument to put: is stored and returned"
	self assert: (collection at: keyIn put: newValue) == newValue.
	self assert: (collection at: keyIn) == newValue.

	newValue := self valueNotIn -> self valueNotIn.
	self assert: (collection at: keyIn put: newValue) == newValue.
	self assert: (collection at: keyIn) == newValue.

	newValue := {self valueNotIn.
	self valueNotIn.
	self valueNotIn}.
	self assert: (collection at: self keyNotIn put: newValue) == newValue.
	self assert: (collection at: self keyNotIn) == newValue! !

!DictionaryTest methodsFor: 'tests - removing' stamp: ''!
testRemove

	self should: [self nonEmptyDict remove: nil] raise: Error.
	self should: [self nonEmptyDict remove: nil ifAbsent: ['What ever here']] raise: Error.! !

!DictionaryTest methodsFor: 'tests' stamp: ''!
testNilHashCollision

	"Ensures that fixCollisionsFrom: does the right thing in the presence of a nil key.
	To do that, we must have a key with the same hash as nil."

	| dict key |
	self supportsNilKey ifFalse: [ ^ self ].
	dict := self collectionClass new.
	key := ObjectWithSettableHash new.
	key hash: nil hash.
	self assert: key hash equals: nil hash.
	dict at: key put: 1.
	dict at: nil put: 2.
	self assert: (dict includesKey: nil).
	dict removeKey: key.
	self assert: (dict includesKey: nil)! !

!DictionaryTest methodsFor: 'tests - testing' stamp: ''!
testHasBindingThatBeginsWith
	| newDict |
	newDict := self collectionClass new 
		at: #abc put: 10; 
		at: #abcd put: 100; 
		at: #def put: 20; 
		yourself.
	self assert: (newDict hasBindingThatBeginsWith: 'ab').
	self assert: (newDict hasBindingThatBeginsWith: 'def').
	self deny: (newDict hasBindingThatBeginsWith: 'defg').! !

!DictionaryTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn
	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	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 - fixture' stamp: ''!
test0FixtureDictionaryKeyAccess
	| collection equals |
	self nonEmptyWithoutEqualsValues.
	self denyEmpty: self nonEmptyWithoutEqualsValues.
	equals := true.
	collection := self nonEmptyWithoutEqualsValues values.
	collection detect: [ :each | (collection occurrencesOf: each) > 1 ] ifNone: [ equals := false ].
	self deny: equals.
	self valueNotIn.
	self deny: (self nonEmptyWithoutEqualsValues values includes: self valueNotIn)! !

!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtIfPresentIfAbsentPut
	"self run: #testAtIfPresentIfAbsentPut"

	| collection association arg |
	collection := self nonEmpty.
	association := collection associations anyOne.
	arg := nil.
	self
		assert:
			(collection
				at: association key
				ifPresent: [ :value | 
					arg := value.
					#present ]
				ifAbsentPut: [ Error signal ]) = #present.
	self assert: arg = association value.

	"ensure cull: is used to support blocks that take no args"
	self
		assert:
			(collection
				at: association key
				ifPresent: [ #present ]
				ifAbsentPut: [ Error signal ]) = #present.
	self
		assert:
			(collection
				at: self keyNotIn
				ifPresent: [ :value | Error signal ]
				ifAbsentPut: [ self valueNotIn ]) = self valueNotIn.
	self assert: (collection at: self keyNotIn) = self valueNotIn! !

!DictionaryTest methodsFor: 'tests - testing' stamp: ''!
testIncludesAssociationWithValue
	| association dictionary |
	association := Association key: #key value: 1.
	dictionary := self collectionClass new.
	dictionary add: association.

	self assert: (dictionary at: #key) equals: 1! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
otherDictionaryClasses
	"(DictionaryTest withAllSubclasses collect: [:each | each new classToBeTested]) asArray"
	^ {SmallDictionary. IdentityDictionary. PluggableDictionary.
		WeakValueDictionary. SystemDictionary. WeakKeyDictionary. SmallIdentityDictionary.
		WeakIdentityKeyDictionary. WeakKeyToCollectionDictionary. Dictionary}
			reject: [:each | each new species == self classToBeTested new species]! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	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 - dictionnary enumerating' stamp: ''!
testKeysAndValuesDo

	
	| collection keys |
	collection := self nonEmptyDict .
	keys := OrderedCollection new.
	collection keysAndValuesDo: [ :key :value | 
		keys add: key.
		self assert: (collection at: key) = value ].
	
	collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	^nonEmpty5ElementsNoDuplicates! !

!DictionaryTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ' ).
	1 to: allElementsAsString size do:
		[:i | 
		i<(allElementsAsString size-1 )
			ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString  occurrencesOf: (allElementsAsString at:i))].
		i=(allElementsAsString size-1)
			ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString].
		i=(allElementsAsString size)
			ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString  occurrencesOf: (allElementsAsString at:i))].
			].! !

!DictionaryTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''.! !

!DictionaryTest methodsFor: 'tests - dictionary assocition access' stamp: ''!
testAssociationAt
	| collection keyIn result |
	collection := self nonEmpty.
	keyIn := collection keys anyOne.

	result := collection associationAt: keyIn.

	self assert: result key equals: keyIn.
	self assert: result value equals: (collection at: keyIn)! !

!DictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result allElementsAsString tmp |
	
	
	delim := ', '.
	result:=''.
	tmp:= self nonEmpty collect:[:each | each asString].
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	allElementsAsString := (result findBetweenSubstrings: delim ).
	tmp do:
		[:each |
		self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each).
		].! !

!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty
	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryElementAccess
	| in |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self keyNotIn.
	in := true.
	self nonEmpty keys detect: [ :key | key = self keyNotIn ] ifNone: [ in := false ].
	self deny: in! !

!DictionaryTest methodsFor: 'tests - testing' stamp: ''!
testIncludesAssociationNoValue

	| association dictionary |
	
	association := Association key: #key.
	
	self assert: association value isNil.
	
	dictionary := self collectionClass new.
	
	dictionary add: association.
	
	self assert: (dictionary at: #key) isNil! !

!DictionaryTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
collectionWithEqualElements
" return a collecition including atLeast two elements equal"

^ dictionaryWithDuplicateValues! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
elementTwiceInForOccurrences
" return an element included exactly two time in # collectionWithEqualElements"
^ duplicateValue! !

!DictionaryTest methodsFor: 'tests - copying' stamp: ''!
testDictionaryConcatenationWithoutCommonKeys

	| dictionary1 dictionary2 result |
	dictionary1 := self nonEmptyDict.
	dictionary2 := self nonEmptyDifferentFromNonEmptyDict.
	result := dictionary1 , dictionary2.
	self assert: result size = (dictionary1 size + dictionary2 size).
	dictionary1 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ].
	dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! !

!DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testAssociationsDo

	| collection keys |
	collection := self nonEmptyDict .

	keys := OrderedCollection new.
	
	collection associationsDo: [ :assoc | 
		keys add: assoc key.
		self assert: ( collection at: assoc key ) = assoc value.		
		].
	
	collection keys do: [:key | self assert: ( keys occurrencesOf: key ) = (collection keys occurrencesOf: key)].! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!DictionaryTest methodsFor: 'tests - copy' stamp: ''!
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 - testing' stamp: ''!
testOccurrencesOf
	
	| dict |
	dict := self collectionClass new.
	dict at: #a put: 1.
	dict at: #b put: 2.
	dict at: #c put: 1.
	dict at: #d put: 3.
	dict at: nil put: nil.
	dict at: #z put: nil.
		
	self assert: (dict occurrencesOf: 1 ) equals: 2.
	self supportsNilKey 
		ifTrue: [ self assert: (dict occurrencesOf: nil ) equals: 2 ]
		ifFalse: [ self assert: (dict occurrencesOf: nil ) equals: 1 ]! !

!DictionaryTest methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testKeys
	| collection result |
	collection := self nonEmpty.
	result := collection keys.
	result do: [ :key | collection at: key ].
	self assert: result size = collection size.
	self should: [ result detect: [ :each | (result occurrencesOf: each) > 1 ] ] raise: Error! !

!DictionaryTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!DictionaryTest methodsFor: 'tests' stamp: ''!
testSelectIsNotShallowCopy
		
	| original even |
	original := self collectionClass new.
	original at: #one put: 1.
	original at: #two put: 2.

	even := original select: [:value |value even].
	even at: #two put: 'deux'.

	self assert: (original at: #two) = 2
 	   description: 'modifying a selection should not modify the original'! !

!DictionaryTest methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testKeysSortedSafely
	| collection result |
	collection := self nonEmpty.
	result := collection keysSortedSafely.
	result do: [ :key | collection at: key ].
	self assert: result size = collection size.
	self should: [ result detect: [ :each | (result occurrencesOf: each) > 1 ] ] raise: Error.
	self assert: result asArray isSorted! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
speciesClass
	^ Dictionary! !

!DictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsNotThere
	
	self deny: (self nonEmpty includes: self elementNotInForOccurrences).
	self assert: (self nonEmpty includes: self nonEmpty anyOne).
	self deny: (self empty includes: self elementNotInForOccurrences)! !

!DictionaryTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
sizeCollection
	^ nonEmptyDict! !

!DictionaryTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
" return a collection without equal elements"
	^ nonEmpty5ElementsNoDuplicates! !

!DictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!DictionaryValueHolder commentStamp: ''!
I am designed specifically for dictionaries.!
!DictionaryValueHolder methodsFor: 'protocol' stamp: ''!
fillFrom: aCollection with: aBlock
	"Evaluate aBlock with each of aCollections's elements as the argument.  
	Collect the resulting values into self. Answer self."

	aCollection keysAndValuesDo: [ :key :aValue |
		self at: key put: (aBlock value: aValue) ]! !

!DictionaryValueHolder methodsFor: 'protocol' stamp: ''!
doesNotUnderstand: aMessage

	^ (value respondsTo: aMessage selector)
		ifTrue: [ value perform: aMessage selector withEnoughArguments: aMessage arguments ]
		ifFalse: [ super doesNotUnderstand: aMessage ]! !

!DictionaryValueHolder methodsFor: 'private' stamp: ''!
errorKeyNotFound: aKey

	KeyNotFound signalFor: aKey! !

!DictionaryValueHolder methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	self value: Dictionary new.! !

!DictionaryValueHolder methodsFor: 'protocol' stamp: ''!
at: key put: anObject

	value at: key put: anObject.
	self valueChanged: anObject.
	^ anObject! !

!DictionaryValueHolder methodsFor: 'protocol' stamp: ''!
atNewIndex: index put: anObject
	
	value atNewIndex: index put: anObject.
	self valueChanged: anObject.! !

!DictionaryValueHolder methodsFor: 'protocol' stamp: ''!
removeAll
	
	value removeAll.
	self valueChanged.! !

!DictionaryValueHolder methodsFor: 'protocol' stamp: ''!
removeKey: key 
	"Remove key from the receiver.
	If key is not in the receiver, notify an error."
	
	^ self removeKey: key ifAbsent: [self errorKeyNotFound: key].! !

!DictionaryValueHolder methodsFor: 'override' stamp: ''!
at: anObject

	^ value at: anObject! !

!DictionaryValueHolder methodsFor: 'override' stamp: ''!
size 

	^ value size! !

!DictionaryValueHolder methodsFor: 'protocol' stamp: ''!
at: key ifAbsentPut: aBlock 

	^ value at: key ifAbsent: [self at: key put: aBlock value]! !

!DictionaryValueHolder methodsFor: 'protocol' stamp: ''!
valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary 
	
	value valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary.
	self valueChanged.! !

!DictionaryValueHolder methodsFor: 'protocol' stamp: ''!
removeKey: key ifAbsent: aBlock 
	| result |
	
	result := value removeKey: key ifAbsent: aBlock.
	self valueChanged.
	^ result! !

!DictionaryValueHolder methodsFor: 'initialization' stamp: ''!
initialize: n
	
	value initialize: n.
	self valueChanged.! !

!DiffBuilder methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self comparator: [ :a :b | a = b ]! !

!DiffBuilder methodsFor: 'creating patches' stamp: ''!
diffFrom: origin to: dest

	^ self 
		diffSource: origin 
		dest: dest 
		posSource: 0
		posDest: 0! !

!DiffBuilder methodsFor: 'private' stamp: ''!
applyDiff2: diff origin: source dest: dest
	| deleteByPosition insertByPosition |
	
	deleteByPosition := (diff 
		select: [ :each | each isDelete ])
		collect: [ :each | each oldPosition -> each ] 
		as: Dictionary.
	
	insertByPosition := (diff
		select: [ :each | each isInsert ])
		collect: [ :each | each newPosition -> each ] 
		as: Dictionary.	
	
	^ source species streamContents: [ :stream |
		source withIndexDo: [ :eachLine :index | 
			deleteByPosition 
				at: index 
				ifPresent: [ :old |
					old element: (source at: index).
					stream nextPut: old.
					insertByPosition 
						at: index 
						ifPresent: [ :new |
							new element: (dest at: index). 
							stream nextPut: new ] ]
				ifAbsent: [ 	
					stream nextPut: ((DiffMatch newOldPosition: index) 
						element: eachLine;
						yourself) ] ] ]! !

!DiffBuilder methodsFor: 'accessing' stamp: ''!
comparator: aBlock

	compareBlock := aBlock! !

!DiffBuilder methodsFor: 'private' stamp: ''!
applyDiff: diff origin: source dest: dest
	| sequence i |
	
	sequence := OrderedCollection new.
	i := 1.
	
	diff do: [ :each | 
		[ each oldPosition > i ] 
		whileTrue: [ 
			i < source size 
				ifTrue: [ sequence add: (DiffMatch newOldPosition: i element: (source at: i)) ].
			i := i + 1 ].
		each oldPosition = i
			ifTrue: [
				each isDelete ifTrue: [ 
					sequence add: (each 
						element: (source at: each oldPosition);
						yourself).
					i := i + 1 ].
				each isInsert ifTrue: [ 
					sequence add: (each 
						element: (dest at: each newPosition);
						yourself) ].
				self flag: #TODO. "Here goes 'change' operation (not done yet)" ]
			ifFalse: [ 
				self error: 'Should not happen.' ] ].
		
	[ i <= source size ]
	whileTrue: [ 
		sequence add: (DiffMatch newOldPosition: i element: (source at: i)).
		i := i + 1 ].
	
	^ sequence! !

!DiffBuilder methodsFor: 'private' stamp: ''!
diffSource: source dest: dest posSource: posSource posDest: posDest
	| sourceLength destLength totalLength matrixLength |

	"
	Z := no idea :)
	"
	sourceLength := source size.
	destLength := dest size.
	totalLength := sourceLength + destLength.
	matrixLength := ((sourceLength min: destLength)*2)+2.

	(sourceLength>0 and: [ destLength>0 ]) 
		ifTrue: [ 
			| w g p |
			w := sourceLength-destLength. 
			g := Array new: matrixLength withAll: 0.
			p := Array new: matrixLength withAll: 0. 
			
			0 to: ((totalLength//2)+((totalLength%2) = 0 ifTrue: [0] ifFalse: [1])) do: [ :h |
				0 to: 1 do: [ :r |
					| c d o m |
					r = 0 
						ifTrue: [ c := g. d := p. o := 1. m := 1 ]
						ifFalse: [ c := p. d := g. o := 0. m := -1 ].
					(h-(2*((h-destLength) max: 0))) negated 
						to: (h-(2*((h-sourceLength) max: 0)))+1 
						by: 2
						do: [ :k | 
							| a b s t z |
							a := (k=(h negated)
								or: [ (k~=h) and: [ (c at: ((k-1)%matrixLength)+1) < (c at: ((k+1)%matrixLength)+1) ] ])
								ifTrue: [ c zAt: ((k+1)%matrixLength) ]
								ifFalse: [ (c zAt: ((k-1)%matrixLength))+1 ]. 
							b := a-k.
							s := a.
							t := b.
							[ a<sourceLength 
								and: [ b<destLength 
								and: [ 
									self 
										compare: (source zAt: (((1-o)*sourceLength)+(m*a)+(o-1))) 
										with: (dest zAt: (((1-o)*destLength)+(m*b)+(o-1))) ] ] ]
								whileTrue: [ 
									a := a + 1.
									b := b + 1 ].
							c zAt: (k%matrixLength) put: a. 
							z := (k-w) negated.
							((totalLength%2)=o 
								and: [ z >= (h-o) negated 
								and: [ z <= (h-o) 
								and: [ (c zAt: k%matrixLength) + (d zAt: z%matrixLength) >= sourceLength ] ] ]) 
								ifTrue: [  
									| D x y u v |
									o = 1 
										ifTrue: [ D := (2*h)-1. x := s. y := t. u := a. v := b ]
										ifFalse: [ D := 2*h. x := sourceLength-a. y := destLength-b. u := sourceLength-s. v := destLength-t ].
									^ (D > 1 or: [ (x ~= u) and: [ y ~= v ] ])
										ifTrue: [
											(self 
												diffSource: (source zCopyFrom: 0 to: x)  
												dest: (dest zCopyFrom: 0 to: y) 
												posSource: posSource 
												posDest: posDest),
											(self 
												diffSource: (source zCopyFrom: u to: sourceLength)  
												dest: (dest zCopyFrom: v to: destLength) 
												posSource: posSource+u
												posDest: posDest+v) ]
										ifFalse: [ 
											destLength > sourceLength 
												ifTrue: [
													self 
														diffSource: #()
														dest: (dest zCopyFrom: sourceLength to: destLength)
														posSource: posSource+sourceLength 
														posDest: posDest+sourceLength ]
												ifFalse: [ 
													destLength < sourceLength 
														ifTrue: [
															self 
																diffSource: (source zCopyFrom: destLength to: sourceLength) 
																dest: #()
																posSource: posSource+destLength 
																posDest: posDest+destLength ]
														ifFalse: [ 
															#() ] 
													] 
											]
								]
						]
					] 
				] 
			]
		ifFalse: [  
			sourceLength > 0 
				ifTrue: [ 
					^ (1 to: sourceLength) collect: [ :index | DiffDelete newOldPosition: (posSource+index) ] ]
				ifFalse: [ 
					^ (1 to: destLength) collect: [ :index | DiffInsert newOldPosition: posSource+1 newPosition: (posDest+index) ] ] ]! !

!DiffBuilder methodsFor: 'creating patches' stamp: ''!
buildPatchFrom: source to: dest
	| diff |

	diff := self diffFrom: source to: dest.
	^ DiffPatch newElements: (self 
		applyDiff: diff 
		origin: source 
		dest: dest)! !

!DiffBuilder methodsFor: 'private' stamp: ''!
compare: a with: b

	^ compareBlock value: a value: b! !

!DiffBuilder class methodsFor: 'building' stamp: ''!
buildPatchFrom: source to: destination

	^ self new 
		buildPatchFrom: source 
		to: destination! !

!DiffBuilderTest methodsFor: 'tests' stamp: ''!
testDiffIRecordsLastLineWhenMatching
	| patch fileA fileB |

	fileA := 'newSourceView
			
	^ GtkSourceView new
		beWrapWord;
		showLineNumbers: true;
		autoIndent: true;
		yourself'.

	fileB := 'newSourceView

	^ GtkSourceView new
		beWrapWord;
		monospace: true;
		showLineNumbers: "self presenter hasLineNumbers" false;
		showLineMarks: true;
		autoIndent: true;
		indentOnTab: true;
		tabWidth: 4;
		yourself'.

	patch := DiffBuilder 
		buildPatchFrom: fileA lines
		to: fileB lines.
	
	self assert: patch elements last element equals: '		yourself'! !

!DiffBuilderTest methodsFor: 'tests' stamp: ''!
testDiffFromTo
	| fileA fileB patch |
	
	fileA := 'ABCABBA'.
	fileB := 'CBABAC'.
	
	patch := DiffBuilder new 
		diffFrom: fileA 
		to: fileB.
	
	self assert: patch size equals: 5. 
	self 
		assert: (patch collect: #class as: Array)  
		equals: { DiffDelete. DiffInsert . DiffDelete. DiffDelete. DiffInsert }.
	self 
		assert: (patch collect: #oldPosition as: Array) 
		equals: {1. 2. 3. 6. 8}.
	self assert: (patch at: 2) newPosition equals: 1.
	self assert: (patch at: 5) newPosition equals: 6! !

!DiffBuilderTest methodsFor: 'tests' stamp: ''!
testDiffWithLinesRecordsDelete
	| fileA fileB patch |
	
	fileA := 'a
b
c'.
	fileB := 'a
b
d'.
	
	patch := DiffBuilder new 
		diffFrom: fileA lines
		to: fileB lines.
	
	self assert: patch size equals: 2. 
	self 
		assert: (patch collect: #class) 
		equals: { DiffDelete. DiffInsert }.
	self assert: (patch collect: #oldPosition as: Array) equals: #(3 4).
	self assert: (patch at: 2) newPosition equals: 3! !

!DiffBuilderTest methodsFor: 'tests' stamp: ''!
testDiffWithLines
	| fileA fileB patch |
	
	fileA := 'test
with lines
that will change'.
	fileB := 'test
with LINES
that will change
'.
	
	patch := DiffBuilder new 
		diffFrom: fileA lines
		to: fileB lines.
	
	self assert: patch size equals: 2. 
	self 
		assert: (patch collect: #class) 
		equals: { DiffDelete. DiffInsert }.
	self assert: (patch collect: #oldPosition as: Array) equals: #(2 3).
	self assert: (patch at: 2) newPosition equals: 2! !

!DiffChangeMorph commentStamp: ''!
A morph to display text differences!
!DiffChangeMorph methodsFor: 'accessing' stamp: ''!
diffMorph
	"Answer the value of diffMorph"

	^ diffMorph! !

!DiffChangeMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self buildUI! !

!DiffChangeMorph methodsFor: 'user interface' stamp: ''!
initialExtent
	"Answer the initial extent for the receiver."

	^RealEstateAgent standardWindowExtent! !

!DiffChangeMorph methodsFor: 'hooks' stamp: ''!
diffMorphClass
	"Answer a the class to use for a new diff morph."

	^DiffMorph! !

!DiffChangeMorph methodsFor: 'actions' stamp: ''!
fromDescriptionMorph
	"Answer the morph for the source description."

	^self descriptionMorph firstSubmorph firstSubmorph! !

!DiffChangeMorph methodsFor: 'actions' stamp: ''!
updateDescriptionFillStyle: aColor
	"Change the colours on the descriptions."
	
	self descriptionMorph fillStyle: aColor.
	self fromDescriptionMorph owner color: (aColor alpha: 0.5).
	self toDescriptionMorph owner color: (aColor alpha: 0.3).! !

!DiffChangeMorph methodsFor: 'accessing' stamp: ''!
defaultTitle
	"Answer the default title label for the receiver."

	^'Change Diff' translated! !

!DiffChangeMorph methodsFor: 'accessing' stamp: ''!
diffMorph: anObject
	"Set the value of diffMorph"

	diffMorph := anObject! !

!DiffChangeMorph methodsFor: 'accessing' stamp: ''!
descriptionMorph: anObject
	"Set the value of descriptionMorph"

	descriptionMorph := anObject! !

!DiffChangeMorph methodsFor: 'actions' stamp: ''!
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: ''!
newDiffMorph
	"Answer a new morph for the source difference."

	^self diffMorphClass new
		borderStyle: (BorderStyle inset width: 1);
		addDependent: self;
		yourself! !

!DiffChangeMorph methodsFor: 'accessing' stamp: ''!
descriptionMorph
	"Answer the value of descriptionMorph"

	^ descriptionMorph! !

!DiffChangeMorph methodsFor: 'initialization' stamp: ''!
buildUI

	|descriptionHeight|

	self
		diffMorph: self newDiffMorph;
		descriptionMorph: self newDescriptionMorph.
	descriptionHeight := self descriptionMorph minExtent y.
	self
		changeProportionalLayout;
		addMorph: self descriptionMorph
		fullFrame: ((0@0 corner: 1@0) asLayoutFrame bottomOffset: descriptionHeight);
		addMorph: self diffMorph
		fullFrame: (LayoutFrame identity topOffset: descriptionHeight).
	self
		extent: self initialExtent;
		updateDescriptionFillStyle: self paneColor! !

!DiffChangeMorph methodsFor: 'actions' stamp: ''!
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: ''!
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: ''!
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: ''!
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: ''!
toDescriptionMorph
	"Answer the morph for the destination description."

	^self descriptionMorph lastSubmorph firstSubmorph! !

!DiffChangeMorph class methodsFor: 'instance creation' stamp: ''!
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! !

!DiffChangeMorph class methodsFor: 'examples' stamp: ''!
example
	<example>
	(DiffChangeMorph
		from: 'foo
			^bar'
		label: 'Left'
		to: 'foo
			^bar2'
		label: 'Right'
		contextClass: nil) openInWindow! !

!DiffChangeRecordConverter commentStamp: ''!
A DiffChangeRecordConverter is a converter used to show the diff between two methodreferences!
!DiffChangeRecordConverter methodsFor: 'private' stamp: ''!
priorVersionOfAMethod: aChangeRecord
	| index mylist |
	
	mylist := referencesList sorted: [:a :b | a timeStamp > b timeStamp ].
	index := mylist indexOf: aChangeRecord .
	^ mylist at: index+1 ifAbsent: [ aChangeRecord ]! !

!DiffChangeRecordConverter methodsFor: 'private' stamp: ''!
internalGetText

	^ TextDiffBuilder
		  buildDisplayPatchFrom: (self priorVersionOfAMethod: method) sourceCode
		  to: method sourceCode
		  inClass: method className! !

!DiffChangeRecordConverter methodsFor: 'updating' stamp: ''!
updateContent: content on: aVersionBrowser 
	
	aVersionBrowser updateDiff: content! !

!DiffDelete methodsFor: 'testing' stamp: ''!
isDelete

	^ true! !

!DiffDelete methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	aVisitor visitDelete: self! !

!DiffElement commentStamp: ''!
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:		<Integer>
	match:		<DiffElement>
	string:		<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: ''!
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: ''!
= anObject

	^anObject class == self class and: [
		anObject hash = hash and: [
			anObject string = string ] ]! !

!DiffElement methodsFor: 'comparing' stamp: ''!
hash

	^hash! !

!DiffElement methodsFor: 'testing' stamp: ''!
hasMatch

	^match notNil! !

!DiffElement methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream
		nextPut: $(;
		print: hash;
		nextPutAll: ', ';
		print: string;
		nextPutAll: ', ';
		print: (match class == self class);
		nextPut: $)! !

!DiffElement methodsFor: 'accessing' stamp: ''!
string

	^string! !

!DiffElement methodsFor: 'accessing' stamp: ''!
match

	^match! !

!DiffElement methodsFor: 'accessing' stamp: ''!
matches: aDiffMatch

	match := aDiffMatch.
	aDiffMatch match: self! !

!DiffElement methodsFor: 'accessing' stamp: ''!
match: aDiffMatch

	match := aDiffMatch
	! !

!DiffElement class methodsFor: 'instance creation' stamp: ''!
string: aString

	^self new
		string: aString;
		yourself! !

!DiffInsert methodsFor: 'accessing' stamp: ''!
newPosition: anObject

	newPosition := anObject! !

!DiffInsert methodsFor: 'testing' stamp: ''!
isInsert

	^ true! !

!DiffInsert methodsFor: 'printing' stamp: ''!
printPositionOn: stream
	
	super printPositionOn: stream.
	stream << ', new='; print: self newPosition	! !

!DiffInsert methodsFor: 'accessing' stamp: ''!
newPosition

	^ newPosition! !

!DiffInsert methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	aVisitor visitInsert: self! !

!DiffInsert class methodsFor: 'instance creation' stamp: ''!
newOldPosition: oldNumber newPosition: newNumber

	^ self new 
		oldPosition: oldNumber; 
		newPosition: newNumber! !

!DiffJoinMorph commentStamp: ''!
Morph to display a diff join!
!DiffJoinMorph methodsFor: 'accessing' stamp: ''!
dstOffset: anInteger
	"Set the dstOffset."

	dstOffset := anInteger.
	self mappings do: [:j |
		j dstOffset: anInteger]! !

!DiffJoinMorph methodsFor: 'drawing' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		mappings: OrderedCollection new;
		srcOffset: 0@0;
		dstOffset: 0@0! !

!DiffJoinMorph methodsFor: 'accessing' stamp: ''!
mappings
	"Answer the value of mappings"

	^ mappings! !

!DiffJoinMorph methodsFor: 'accessing' stamp: ''!
srcOffset
	"Answer the value of srcOffset"

	^ srcOffset! !

!DiffJoinMorph methodsFor: 'accessing' stamp: ''!
srcOffset: anInteger
	"Set the srcOffset."

	srcOffset := anInteger.
	self mappings do: [:j |
		j srcOffset: anInteger]! !

!DiffJoinMorph methodsFor: 'layout' stamp: ''!
layoutBounds: aRectangle
	"Set the bounds for laying out children of the receiver."
	
	super layoutBounds: aRectangle.
	self updateMappings! !

!DiffJoinMorph methodsFor: 'accessing' stamp: ''!
mappings: anObject
	"Set the value of mappings"

	mappings := anObject.
	self updateMappings.
	self changed! !

!DiffJoinMorph methodsFor: 'actions' stamp: ''!
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: 'event handling' stamp: ''!
mouseDown: evt
	"Check for a click."

	self mappings
		detect: [ :j | j containsPoint: evt position - self topLeft ]
		ifFound: [ :cj | 
			cj clicked.
			self triggerEvent: #joinClicked ].
	super mouseDown: evt! !

!DiffJoinMorph methodsFor: 'accessing' stamp: ''!
dstOffset
	"Answer the value of dstOffset"

	^ dstOffset! !

!DiffJoinMorph methodsFor: 'initialize' stamp: ''!
defaultColor
	"Answer the default color for the receiver."

	^Color transparent! !

!DiffJoinMorph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"Draw the indicators for the mappings."

	super drawOnAthensCanvas: anAthensCanvas. 
	(anAthensCanvas asCanvasWrapper ) translateBy: self topLeft clippingTo: self clippingBounds during: [:c |
		self mappings do: [:j | j drawOn: c]]! !

!DiffJoinMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	"Update the shapes of the joins."
	
	super extent: aPoint.
	self updateMappings! !

!DiffJoinMorph methodsFor: 'private - updating' stamp: ''!
updateMappings
	"Update the shapes of the joins."
	
	self mappings do: [:j |
		j width: self width]! !

!DiffJoinMorph class methodsFor: 'accessing - defaults' stamp: ''!
splitterWidth
	"Answer the width of splitter to use for dif joins."
	
	^7! !

!DiffLineChangeRecordConverter commentStamp: ''!
A method converter to be used in version browser to show a line diff (a traditional diff).
It can update the code panel through a double dispatch (see `DiffLineChangeRecordConverter>>#updateContent:on:`)
!
!DiffLineChangeRecordConverter methodsFor: 'updating' stamp: ''!
updateContent: content on: aVersionBrowser
	
	aVersionBrowser updateDiffLine: content! !

!DiffMapMorph commentStamp: ''!
A morph to display a map of join mappings!
!DiffMapMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Draw the indicators for the mappings."
	
	|b f|
	b := self innerBounds insetBy: 2.
	super drawOn: aCanvas.
	b height < 1 ifTrue: [^self].
	f := self mappingsHeight.
	f < 1 ifTrue: [^self].
	f := b height / f.
	aCanvas clipBy: self clippingBounds during: [:c |
		self mappings do: [:j |
			j drawMapOn: c in: b scale: f]]! !

!DiffMapMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		mappings: #()! !

!DiffMapMorph methodsFor: 'private - accessing' stamp: ''!
mappingsHeight
	"Answer the maximum y of all the mappings."
	
	self mappings ifEmpty: [^0].
	^self mappings last dst range last ! !

!DiffMapMorph methodsFor: 'accessing' stamp: ''!
mappings
	"Answer the value of mappings"

	^ mappings! !

!DiffMapMorph methodsFor: 'accessing' stamp: ''!
mappings: anObject
	"Set the value of mappings"

	mappings := anObject.
	self changed! !

!DiffMapMorph methodsFor: 'event handling' stamp: ''!
mouseDown: event
	"Trigger a 0..1 range based on location."
	
	|b|
	b := self innerBounds insetBy: 2.
	self
		triggerEvent: #mapClicked
		with: (((event cursorPoint y asFloat - b top / b height) 
				min: 1) max: 0)! !

!DiffMapMorph methodsFor: 'accessing' stamp: ''!
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: ''!
adoptPaneColor: paneColor
	"Change our border color too."
	
	|c|
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	c := paneColor alphaMixed: 0.1 with: self theme diffMapColor.
	self borderStyle baseColor: paneColor! !

!DiffMapMorph methodsFor: 'accessing' stamp: ''!
defaultColor
	"Answer the default color for the receiver."
	^ self theme diffMapColor! !

!DiffMapMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: anEvent
	"Answer true to report mouse down activity."
	
	^true! !

!DiffMapMorph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"Draw the indicators for the mappings."
	
	|b f|
	b := self innerBounds insetBy: 2.
	super drawOnAthensCanvas: anAthensCanvas.
	b height < 1 ifTrue: [^self].
	f := self mappingsHeight.
	f < 1 ifTrue: [^self].
	f := b height / f.
	anAthensCanvas asCanvasWrapper clipBy: self clippingBounds during: [:c |
		self mappings do: [:j |
			j drawMapOn: c in: b scale: f]]! !

!DiffMapMorph methodsFor: 'accessing' stamp: ''!
extent: newExtent
	"Update the gradient."
	
	super extent: newExtent.
	(self fillStyle notNil and: [self fillStyle isOrientedFill])
		ifTrue: [self fillStyle direction: 0@self height]! !

!DiffMatch methodsFor: 'testing' stamp: ''!
isMatch

	^ true! !

!DiffMatch methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	aVisitor visitMatch: self! !

!DiffMatch class methodsFor: 'instance creation' stamp: ''!
newOldPosition: index element: element

	^ (self newOldPosition: index) 
		element: element;
		yourself! !

!DiffMorph commentStamp: ''!
I am a morph useful for visualising differences between two strings.

When a classContext: is setted, the strings are highlighted using such contextual information.!
!DiffMorph methodsFor: 'protocol' stamp: ''!
removeOptionsPanel

	showOptions := false.
	self removeAllMorphs.
	self addMorphsWithoutOptions! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
scrollbarMorph: anObject
	"Set the value of scrollbarMorph"

	scrollbarMorph := anObject! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
beWrapped

	^ beWrapped! !

!DiffMorph methodsFor: 'accessing - colors' stamp: ''!
additionHighlightColor
	"Answer the color used to show addition highlights."
	^ self theme diffAdditionalTextInLineBackgroundColor! !

!DiffMorph methodsFor: 'actions' stamp: ''!
applyPrettyPrinter
	"Apply pretty printer if check box is on"

	(self prettyPrint and: [ self contextClass notNil ])
		ifTrue: [ 
			self sourceTextModel getString isEmpty
				ifFalse: [ self sourceTextModel formatSourceCodeInView ].
			self destTextModel getString isEmpty
				ifFalse: [ self destTextModel formatSourceCodeInView ] ]! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
joinMappings
	"Answer the join parameters between src and dst."

	^joinMappings ifNil: [self calculateJoinMappings]! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
showOptions: aBoolean

	showOptions = aBoolean ifTrue: [ ^ self ].
	showOptions := aBoolean.
	aBoolean
		ifTrue: [ self addOptionsPanel ]
		ifFalse: [ self removeOptionsPanel ]! !

!DiffMorph methodsFor: 'accessing - colors' stamp: ''!
additionColor
	"Answer the color used to show additions."

	^ self theme diffAdditionalLineBackgroundColor ! !

!DiffMorph methodsFor: 'accessing - colors' stamp: ''!
removalHighlightColor
	"Answer the color used to show removal highligths."
	^ self theme diffRemovalHighlightColor! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
joinMappings: aCollection
	"Set the join parameters between src and dst."

	joinMappings := aCollection! !

!DiffMorph methodsFor: 'updating' stamp: ''!
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: 'protocol' stamp: ''!
addOptionsPanel

	showOptions := true.
	self removeAllMorphs.
	self addMorphsWithOptions! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
showOnlyDestination: aBoolean

	showOnlyDestination = aBoolean ifTrue: [ ^ self ].
	self showOnlySource: false.
	showOnlyDestination := aBoolean.
	self updateMorphs! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
showOnlySource

	^ showOnlySource! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
newHighlight
	"Anewser a new highlight."

	^TextHighlightByBounds new
		color: self modificationColor;
		borderWidth: 1;
		borderColor: self edgeColor! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
prettyPrint
	"Answer the value of prettyPrint"

	^ prettyPrint! !

!DiffMorph methodsFor: 'event handling' stamp: ''!
horizontalSourceScroll: anAnnouncement
	self dstMorph scrollPane hScrollbarValueWithoutAnnouncement: anAnnouncement scrollValue! !

!DiffMorph methodsFor: 'actions' stamp: ''!
joinSectionClass
	"Answer the class to use for a new join section."

	^JoinSection! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
scrollbarMorph
	"Answer the value of scrollbarMorph"

	^ scrollbarMorph! !

!DiffMorph methodsFor: 'actions' stamp: ''!
applyHighlights
	"Apply the relevant highlights to src and dst."

	self srcMorph highlights: (self joinMappings flatCollect: [:j | j src highlights]).
	self dstMorph highlights: (self joinMappings flatCollect: [:j | j dst highlights])! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
showOnlySource: aBoolean

	showOnlySource = aBoolean ifTrue: [ ^ self ].
	self showOnlyDestination: false.
	showOnlySource := aBoolean.
	self updateMorphs! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
dstMorph
	"Answer the value of dstMorph"

	^ dstMorph! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
destTextModel
	^ destTextModel ifNil: [ destTextModel := RubScrolledTextModel new interactionModel: self ].! !

!DiffMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	showOnlyDestination := false.
	showOnlySource := false.
	showOptions := true.
	beWrapped := false.
	self
		srcMorph: self newSrcMorph;
		joinMorph: self newJoinMorph;
		dstMorph: self newDstMorph;
		scrollbarMorph: self newScrollbarMorph;
		mapMorph: self newMapMorph;
		changeProportionalLayout.
	self prettyPrint: TextDiffBuilder diffsWithPrettyPrint.
	self addMorphsWithOptions.
	self srcMorph scrollPane announcer 
		when: RubVerticalScrolled send: #verticalScroll: to: self;
		when: RubHorizontalScrolled send: #horizontalSourceScroll: to: self.
	self dstMorph scrollPane announcer 
		when: RubVerticalScrolled send: #verticalScroll: to: self;
		when: RubHorizontalScrolled send: #horizontalDestScroll: to: self.
	self
		linkSubmorphsToSplitters;
		extent: self initialExtent! !

!DiffMorph methodsFor: 'user interface' stamp: ''!
initialExtent
	"Answer the initial extent for the receiver."

	^RealEstateAgent standardWindowExtent! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
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: 'accessing' stamp: ''!
selectedClassOrMetaClass
	^ self contextClass ! !

!DiffMorph methodsFor: 'user interface' stamp: ''!
shoutAboutToStyle: aPluggableShoutMorphOrView
	aPluggableShoutMorphOrView classOrMetaClass: self contextClass.
	^ self contextClass notNil ! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
mapMorph
	"Answer the value of mapMorph"

	^ mapMorph! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
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: 'accessing' stamp: ''!
joinMorph
	"Answer the value of joinMorph"

	^ joinMorph! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
newHighlight: type
	"Anewser a new highlight."

	^TextHighlightByBounds new
		color: (self colorForType: type);
		borderWidth: 1;
		borderColor: self edgeColor;
		fillWidth: true! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
defaultTitle
	"Answer the default title label for the receiver."

	^'Diff' translated! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
showOptions

	^ showOptions! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
leftLabel: aLeftLabel rightLabel: aRigthLabel

	leftCaption := aLeftLabel.
	rightCaption := aRigthLabel.
	
	self updateMorphs! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
beWrapped: aBoolean

	beWrapped = aBoolean ifTrue: [ ^ self ].
	beWrapped := aBoolean.
	aBoolean
		ifTrue: [ self dstMorph beWrapped. self srcMorph beWrapped ]
		ifFalse: [ self dstMorph beNotWrapped. self srcMorph beNotWrapped ]! !

!DiffMorph methodsFor: 'private' stamp: ''!
setOptionsPanel: aBoolean
	"This is a private method. The implementation is based on the fact the options are set by default"
	
	aBoolean ifFalse: [ self removeOptionsPanel ]! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
mapMorph: anObject
	"Set the value of mapMorph"

	mapMorph := anObject! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
newScrollbarMorph
	"Answer a new scrollbar morph."

	^ RubScrollBar new
		model: self;
		setValueSelector: #vScroll:;
		vResizing: #spaceFill;
		width: self theme scrollbarThickness! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Change our border color too."
	
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	self borderStyle baseColor: paneColor! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
difference
	"Answer the value of difference"

	^ difference! !

!DiffMorph methodsFor: 'accessing - colors' stamp: ''!
edgeColor
	"Answer the color used to show the border of the changes."
	^ self theme diffEdgeColor! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
from: old to: new
	"Set the old (src) and new (dst) text."

	self sourceTextModel setText: old.
	self destTextModel setText: new.
	self
		applyPrettyPrinter;
		calculateDifference;
		calculateJoinMappings;
		calibrateScrollbar;
		applyHighlights;
		applyJoin;
		applyMap! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
showOnlyDestination

	^ showOnlyDestination! !

!DiffMorph methodsFor: 'event handling' stamp: ''!
horizontalDestScroll: anAnnouncement
	self srcMorph scrollPane hScrollbarValueWithoutAnnouncement: anAnnouncement scrollValue! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
srcMorph: anObject
	"Set the value of srcMorph"

	srcMorph := anObject! !

!DiffMorph methodsFor: 'private' stamp: ''!
hideOrShowScrollBar
	"Do nothing"
	! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
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: 'updating' stamp: ''!
update: aSymbol with: aValue

	aSymbol == #showOnlyDestination
		ifTrue: [ ^ self showOnlyDestination: aValue ].
	aSymbol == #showOptions	
		ifTrue: [ ^ self showOptions: aValue ].
		
	^ super update: aSymbol with: aValue! !

!DiffMorph methodsFor: 'user interface' stamp: ''!
updateText
	"Reset the text if we have some."

	(self sourceTextModel getString notNil and: [ self destTextModel getString notNil ])
		ifTrue: [ self from: self sourceTextModel getString to: self destTextModel getString ]! !

!DiffMorph methodsFor: 'accessing - colors' stamp: ''!
matchColor
	"Answer the color used to show matches."

	^ Color transparent! !

!DiffMorph methodsFor: 'accessing - colors' stamp: ''!
modificationColor
	"Answer the color used to show changes."
	^ self theme diffModificatedLineBackgroundColor! !

!DiffMorph methodsFor: 'accessing - colors' stamp: ''!
colorForType: type
	"Anwser the color to use for the given change type."

	^ {self matchColor. self additionColor. self removalColor. self modificationColor}
		at: (#(match addition removal modification) indexOf: type)! !

!DiffMorph methodsFor: 'initialization' stamp: ''!
addTitlePanel: initialOffset

	"Add the title panel and returns the top offset for the rest of the window."

	| titlePanel titleRow rightLabel |
	(leftCaption isNotNil and: [ rightCaption isNotNil ]) ifFalse: [ ^ initialOffset ].
	
	"If we are showing only one panel there is no need for title"
	showOnlyDestination ifTrue: [ ^ initialOffset ].
	showOnlySource ifTrue: [ ^ initialOffset ].
	
	titlePanel := self newPanel. 	
	
	titleRow := self newPanel.
	
	titleRow changeProportionalLayout.
	titleRow hResizing: #spaceFill.
	titleRow vResizing: #shrinkWrap.	
	
	rightLabel := (self newRow: { self newLabel: rightCaption }) listCentering: #bottomRight; yourself.
	titleRow addMorph: rightLabel fullFrame: (LayoutFrame identity leftFraction: 0.5; rightOffset: mapMorph width negated - 5). 
	titleRow addMorph: (self newLabel: leftCaption) fullFrame: (LayoutFrame identity leftFraction: 0; rightFraction: 0.5; leftOffset: 10). 

		
	titlePanel addMorph: titleRow.
	titleRow extent: titlePanel minExtent.

	titlePanel vResizing: #shrinkWrap.
	titlePanel hResizing: #spaceFill.
				
	self addMorph: titlePanel
		fullFrame:(LayoutFrame identity
			topOffset: initialOffset;
			bottomFraction: 0;
			bottomOffset: titlePanel height + initialOffset).

	titlePanel extent: titlePanel minExtent.	
				
	^ initialOffset + titlePanel height.
				
! !

!DiffMorph methodsFor: 'updating' stamp: ''!
update: aSymbol

	aSymbol == #addOptions
		ifTrue: [ ^ self addOptionsPanel ].
	aSymbol == #removeOptions	
		ifTrue: [ ^ self removeOptionsPanel ].
		
	^ super update: aSymbol! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
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: 'instance creation' stamp: ''!
newDstMorph
	"Answer a new dst text morph."

	^ self destTextModel newScrolledText
		vScrollbarShowNever;
		beForSmalltalkCode;
		beNotWrapped;
		beReadOnly;
		yourself! !

!DiffMorph methodsFor: 'updating' stamp: ''!
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 scrollPane scroller offset y negated;
		dstOffset: 0 @ self dstMorph scrollPane scroller offset y negated;
		changed! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
doItReceiver
	^nil! !

!DiffMorph methodsFor: 'event handling' stamp: ''!
verticalScroll: anAnnouncement
	"Called from src when scrolled by keyboard etc.."

	self srcMorph scrollPane vScrollbarValueWithoutAnnouncement: anAnnouncement scrollValue.
	self dstMorph scrollPane vScrollbarValueWithoutAnnouncement: anAnnouncement scrollValue.
	self scrollbarMorph value: anAnnouncement scrollValue.
	self updateJoinOffsets! !

!DiffMorph methodsFor: 'protocol' stamp: ''!
updateMorphs

	self removeAllMorphs.
	
	showOptions
		ifTrue: [ self addMorphsWithOptions ]
		ifFalse: [ self addMorphsWithoutOptions ]! !

!DiffMorph methodsFor: 'actions' stamp: ''!
calibrateScrollbar
	"Set the scrollbar parameters to match the texts."

	| maxY range delta innerH |
	self fullBounds.
	maxY := self srcMorph textArea extent y max: self dstMorph extent y.
	innerH := self dstMorph innerBounds extent y.
	delta := 91.	"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 scrollPane scroller offset y max: self dstMorph scrollPane scroller offset y) / range
				min: 1.0) asFloat! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
dstMorph: anObject
	"Set the value of dstMorph"

	dstMorph := anObject! !

!DiffMorph methodsFor: 'actions' stamp: ''!
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: 'initialization' stamp: ''!
addMorphsWithoutOptions
	self addMainMorphsWith: 0! !

!DiffMorph methodsFor: 'updating' stamp: ''!
vScroll: scrollValue
	"Called from standalone scroolbar.
	Scroll the srcMorph and redo the join."

	self srcMorph scrollPane vScrollbarValue: scrollValue.
	self dstMorph scrollPane vScrollbarValue: scrollValue.
	self updateJoinOffsets! !

!DiffMorph methodsFor: 'actions' stamp: ''!
calculateDifference
	"Calculate the difference of the src and dst.
	Use src/dest morphs text, because we may want to compare the pretty printed text"

	self difference: ((TextDiffBuilder
		from: self srcMorph getText to: self dstMorph getText)
			buildPatchSequence)! !

!DiffMorph methodsFor: 'actions' stamp: ''!
calculatedJoinMappings
	"Calculate the join parameters between src and dst and answer"

	| sourceLine destinationLine joins destinationRunStart sourceRunStart destinationRunEnd sourceRunEnd matchDestinationStart matchSourceStart |
	sourceLine := destinationLine := 0.
	joins := OrderedCollection new.
	destinationRunStart := destinationRunEnd := sourceRunStart := sourceRunEnd := matchSourceStart := matchDestinationStart := 0.
	self difference
		do: [ :p | 
			p key = #match
				ifTrue: [ 
					sourceLine := sourceLine + 1.
					destinationLine := destinationLine + 1.
					matchSourceStart = 0
						ifTrue: [ 
							matchSourceStart := sourceLine.
							matchDestinationStart := destinationLine ].
					(destinationRunStart > 0 or: [ sourceRunStart > 0 ])
						ifTrue: [ 
							sourceRunStart = 0
								ifTrue: [ sourceRunStart := sourceLine ].
							destinationRunStart = 0
								ifTrue: [ destinationRunStart := destinationLine ].
							sourceRunEnd = 0
								ifTrue: [ sourceRunEnd := sourceRunStart - 1 ].
							destinationRunEnd = 0
								ifTrue: [ destinationRunEnd := destinationRunStart - 1 ].
							joins
								add:
									(self newJoinSectionFrom: (sourceRunStart to: sourceRunEnd) to: (destinationRunStart to: destinationRunEnd)).
							destinationRunStart := destinationRunEnd := sourceRunStart := sourceRunEnd := 0 ] ].
			p key = #remove
				ifTrue: [ 
					matchSourceStart > 0
						ifTrue: [ 
							joins
								add:
									(self newMatchJoinSectionFrom: (matchSourceStart to: sourceLine) to: (matchDestinationStart to: destinationLine)).
							matchSourceStart := matchDestinationStart := 0 ].
					sourceLine := sourceLine + 1.
					sourceRunStart = 0
						ifTrue: [ sourceRunStart := sourceLine ].
					sourceRunEnd := sourceLine ].
			p key = #insert
				ifTrue: [ 
					matchSourceStart > 0
						ifTrue: [ 
							joins
								add:
									(self newMatchJoinSectionFrom: (matchSourceStart to: sourceLine) to: (matchDestinationStart to: destinationLine)).
							matchSourceStart := matchDestinationStart := 0 ].
					destinationLine := destinationLine + 1.
					sourceRunStart > 0
						ifTrue: [ 
							sourceRunEnd = 0
								ifTrue: [ sourceRunEnd := sourceRunStart ].
							destinationRunEnd = 0
								ifTrue: [ destinationRunEnd := destinationRunStart ].
							joins
								add:
									(self newJoinSectionFrom: (sourceRunStart to: sourceRunEnd) to: (destinationRunStart to: destinationRunEnd)).
							destinationRunStart := destinationRunEnd := sourceRunStart := sourceRunEnd := 0 ].
					destinationRunStart = 0
						ifTrue: [ destinationRunStart := destinationLine ].
					destinationRunEnd := destinationLine ] ].
	sourceLine := sourceLine + 1.
	destinationLine := destinationLine + 1.
	(destinationRunStart > 0 or: [ sourceRunStart > 0 ])
		ifTrue: [ 
			sourceRunStart = 0
				ifTrue: [ sourceRunStart := sourceLine ].
			destinationRunStart = 0
				ifTrue: [ destinationRunStart := destinationLine ].
			sourceRunEnd = 0
				ifTrue: [ sourceRunEnd := sourceRunStart - 1 ].
			destinationRunEnd = 0
				ifTrue: [ destinationRunEnd := destinationRunStart - 1 ].
			joins
				add: (self newJoinSectionFrom: (sourceRunStart to: sourceRunEnd) to: (destinationRunStart to: destinationRunEnd)) ].
	matchSourceStart > 0
		ifTrue: [ 
			joins
				add:
					(self newMatchJoinSectionFrom: (matchSourceStart to: sourceLine - 1) to: (matchDestinationStart to: destinationLine - 1)) ].
	^ joins! !

!DiffMorph methodsFor: 'initialization' stamp: ''!
addMorphsWithOptions

	self createOptionsPanel.

	self 
		addMainMorphsWith: optionsPanel height.

	self
		addMorph: optionsPanel 
		fullFrame: (LayoutFrame identity
			bottomFraction: 0;
			bottomOffset: optionsPanel height)! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
contextClass: aClass
	"Set the value of contextClass"

	contextClass := aClass! !

!DiffMorph methodsFor: 'initialization' stamp: ''!
addMainMorphsWith: initialOffset 
	| halfWidth leftFraction leftOffset rightFraction rightOffset topOffset |

	topOffset := self addTitlePanel: initialOffset.
	
	halfWidth := self joinMorph width / 2.
	leftFraction := showOnlyDestination
		ifTrue: [ 0 ]
		ifFalse: [ 0.5 ].
		
	leftOffset := showOnlyDestination
		ifTrue: [ 0 ]
		ifFalse: [ halfWidth ].
		
	rightFraction := showOnlySource
		ifTrue: [ 1 ]
		ifFalse: [ 0.5 ].
		
	rightOffset := showOnlySource
		ifTrue: [ 0 ]
		ifFalse: [ halfWidth negated ].
		 
	showOnlyDestination ifFalse: [
		self
			addMorph: self srcMorph
			fullFrame: (LayoutFrame identity
				rightFraction: rightFraction;
				topOffset: topOffset;
				rightOffset: rightOffset).
	showOnlySource ifFalse: [
		self		
			addMorph: self joinMorph
			fullFrame: (LayoutFrame identity
				leftFraction: 0.5;
				rightFraction: 0.5;
				leftOffset: halfWidth negated;
				rightOffset: halfWidth;
				topOffset: topOffset).
		] ].
	showOnlySource ifFalse: [
		self
			addMorph: self dstMorph
			fullFrame: (LayoutFrame identity
				leftFraction: leftFraction;
				topOffset: topOffset;
				leftOffset: leftOffset;
				rightOffset: (self scrollbarMorph width + self mapMorph width) negated) ].
				
	self				
		addMorph: self scrollbarMorph
		fullFrame: (LayoutFrame identity
			leftFraction: 1;
			leftOffset: self scrollbarMorph width negated - self mapMorph width;
			rightOffset: self mapMorph width negated;
			topOffset: topOffset).
	self					
		addMorph: self mapMorph
		fullFrame: (LayoutFrame identity
			leftFraction: 1;
			leftOffset: self mapMorph width negated;
			topOffset: topOffset).
! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
newJoinSection
	"Answer a new join section."

	^self joinSectionClass new
		srcColor: self modificationColor;
		dstColor: self modificationColor;
		borderWidth: 1;
		borderColor: self edgeColor;
		additionHighlightColor: self additionHighlightColor;
		removalHighlightColor: self removalHighlightColor;
		addDependent: self;
		yourself! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
doItContext

	^ nil! !

!DiffMorph methodsFor: 'event handling' stamp: ''!
mapClicked: aFloat
	"Update the scrollbar value to match a click in the map."

	self scrollbarMorph setValue: aFloat! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
showBoth

	showOnlyDestination ifTrue: [ showOnlyDestination := false ].
	showOnlySource ifTrue: [ showOnlySource := false ].
	
	self updateMorphs! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
sourceTextModel
	^ sourceTextModel ifNil: [ sourceTextModel := RubScrolledTextModel new interactionModel: self ].! !

!DiffMorph methodsFor: 'initialization' stamp: ''!
createOptionsPanel

	| ppCheckbox |
	ppCheckbox := self newPrettyPrintCheckboxMorph.

	optionsPanel := self newPanel
		addMorph: ((self newRow: {ppCheckbox}) listCentering: #bottomRight);
		color: self defaultColor.
		
	optionsPanel vResizing: #shrinkWrap.
	optionsPanel extent: optionsPanel minExtent.
! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
contextClass
	"Answer the value of contextClass"

	^ contextClass ! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
prettyPrint: aBoolean
	"Set the value of prettyPrint"

	prettyPrint == aBoolean ifTrue: [^self].
	prettyPrint := aBoolean.
	self updateText
	! !

!DiffMorph methodsFor: 'protocol' stamp: ''!
on: aModel

	aModel addDependent: self! !

!DiffMorph methodsFor: 'accessing - colors' stamp: ''!
removalColor
	"Answer the color used to show removals."
	^ self theme diffRemovedLinesBackgroundColor! !

!DiffMorph methodsFor: 'accessing - colors' stamp: ''!
joinColor
	"Answer the color used for the join bar."
	^ self theme diffJoinColor! !

!DiffMorph methodsFor: 'actions' stamp: ''!
calculateJoinMappings
	"Calculate the join parameters between src and dst
	and store in joinMappings."

	self joinMappings: self calculatedJoinMappings! !

!DiffMorph methodsFor: 'accessing - colors' stamp: ''!
diffMapColor
	"Answer the color used for the mapping bar on the left side."
	^ self theme diffMapColor! !

!DiffMorph methodsFor: 'actions' stamp: ''!
applyMap
	"Apply the join mappings to the map morph."

	self mapMorph mappings: self joinMappings! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
from: old to: new contextClass: aClass
	"Set the old (src) and new (dst) text."

	self contextClass: aClass.
	self sourceTextModel setText: old.
	self destTextModel setText: new.
	self
		applyPrettyPrinter;
		calculateDifference;
		calculateJoinMappings;
		calibrateScrollbar;
		applyHighlights;
		applyJoin;
		applyMap! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
newJoinSectionFrom: srcRange to: dstRange
	"Answer a new join section."

	|sourceParagraphLines destinationParagraphLines sourceTopPixelPosition sourceBottomPixelPosition destinationTopPixelPosition destinationBottomPixelPosition type rectangleColor|
	sourceParagraphLines := self srcMorph textMorph paragraph lines.
	destinationParagraphLines := self dstMorph textMorph paragraph lines.
	type := #modification.
	sourceTopPixelPosition := srcRange first > sourceParagraphLines size
		ifTrue: [type := #addition.
				sourceParagraphLines last bottom truncated - 1]
		ifFalse: [(sourceParagraphLines at: srcRange first) top truncated - 1].
	sourceBottomPixelPosition := srcRange size < 1
		ifTrue: [type := #addition.
				 sourceTopPixelPosition + 3]
		ifFalse: [srcRange last > sourceParagraphLines size
				ifTrue: [sourceParagraphLines last bottom truncated + 3]
				ifFalse: [(sourceParagraphLines at: srcRange last) bottom truncated - 1]].
	destinationTopPixelPosition := dstRange first > destinationParagraphLines size
		ifTrue: [type := #removal.
				destinationParagraphLines last bottom truncated - 1]
		ifFalse: [(destinationParagraphLines at: dstRange first) top truncated - 1].
	destinationBottomPixelPosition := dstRange size < 1
		ifTrue: [type := #removal.
				destinationTopPixelPosition + 3]
		ifFalse: [dstRange last > destinationParagraphLines size
				ifTrue: [destinationParagraphLines last bottom truncated + 3]
				ifFalse: [(destinationParagraphLines at: dstRange last) bottom truncated - 1]].
	rectangleColor := self colorForType: type.
	^self newJoinSection
		type: type;
		srcColor: rectangleColor;
		dstColor: rectangleColor;
		srcLineRange: srcRange;
		dstLineRange: dstRange;
		srcRange: (sourceTopPixelPosition to: sourceBottomPixelPosition);
		dstRange: (destinationTopPixelPosition to: destinationBottomPixelPosition);
		createHighlightsFrom: self srcMorph textMorph paragraph
		to: self dstMorph textMorph paragraph! !

!DiffMorph methodsFor: 'instance creation' stamp: ''!
newSrcMorph
	"Answer a new src text morph."

	^ self sourceTextModel newScrolledText
		vScrollbarShowNever;
		beForSmalltalkCode;
		beNotWrapped;
		beReadOnly;
		yourself! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
joinMorph: anObject
	"Set the value of joinMorph"

	joinMorph := anObject! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
srcMorph
	"Answer the value of srcMorph"

	^ srcMorph! !

!DiffMorph methodsFor: 'accessing' stamp: ''!
difference: anObject
	"Set the value of difference"

	difference := anObject! !

!DiffMorph methodsFor: 'actions' stamp: ''!
applyJoin
	"Apply the join mappings to the join morph."

	self joinMorph mappings: self joinMappings! !

!DiffMorph class methodsFor: 'instance creation' stamp: ''!
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: 'instance creation' stamp: ''!
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! !

!DiffPatch methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	elements := OrderedCollection new! !

!DiffPatch methodsFor: 'accessing' stamp: ''!
elements: anObject

	elements := anObject! !

!DiffPatch methodsFor: 'accessing' stamp: ''!
elements

	^ elements! !

!DiffPatch methodsFor: 'generating' stamp: ''!
reply
	
	^ DiffReplyVisitor new
		visitPatch: self;
		contents ! !

!DiffPatch methodsFor: 'generating' stamp: ''!
patch
	
	^ DiffPatchVisitor new
		visitPatch: self;
		contents! !

!DiffPatch methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	^ aVisitor visitPatch: self! !

!DiffPatch class methodsFor: 'instance creation' stamp: ''!
newElements: aCollection

	^ self new elements: aCollection	! !

!DiffPatchElement methodsFor: 'testing' stamp: ''!
isMatch

	^ false! !

!DiffPatchElement methodsFor: 'testing' stamp: ''!
isInsert

	^ false! !

!DiffPatchElement methodsFor: 'accessing' stamp: ''!
oldPosition: anObject

	oldPosition := anObject! !

!DiffPatchElement methodsFor: 'accessing' stamp: ''!
element

	^ element! !

!DiffPatchElement methodsFor: 'printing' stamp: ''!
printOn: stream

	super printOn: stream.
	stream << '('.
	self printPositionOn: stream.
	stream << ')'! !

!DiffPatchElement methodsFor: 'printing' stamp: ''!
printPositionOn: stream
	
	stream << 'old='; print: self oldPosition! !

!DiffPatchElement methodsFor: 'testing' stamp: ''!
isDelete

	^ false! !

!DiffPatchElement methodsFor: 'accessing' stamp: ''!
element: anObject

	element := anObject! !

!DiffPatchElement methodsFor: 'visiting' stamp: ''!
accept: aVisitor
! !

!DiffPatchElement methodsFor: 'accessing' stamp: ''!
oldPosition

	^ oldPosition! !

!DiffPatchElement class methodsFor: 'instance creation' stamp: ''!
newOldPosition: aNumber

	^ self new oldPosition: aNumber ! !

!DiffPatchTest methodsFor: 'tests' stamp: ''!
testReply
	| fileA fileB patch |

	fileA := 'test
with lines
that will change
one time'.
	fileB := 'test
with Lines
that will change
	ONE time
	with indent?

'.

	patch := DiffBuilder
		buildPatchFrom: fileA lines 
		to: fileB lines.

	self assert: patch reply equals: fileB	
! !

!DiffPatchTest methodsFor: 'as yet unclassified' stamp: ''!
mockAST2

	^ 42 - 1! !

!DiffPatchTest methodsFor: 'tests' stamp: ''!
testPatch
	| fileA fileB patch patchString |

	fileA := 'test
with lines
that will change
one time'.
	fileB := 'test
with Lines
that will change
	ONE time
	with indent?

'.

	patchString := ' test
-with lines
+with Lines
 that will change
-one time
+	ONE time
+	with indent?
+
'.

	patch := DiffBuilder
		buildPatchFrom: fileA lines 
		to: fileB lines.

	self assert: patch patch equals: patchString	
! !

!DiffPatchVisitor methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	stream := String new writeStream! !

!DiffPatchVisitor methodsFor: 'accessing' stamp: ''!
contents

	^ stream contents! !

!DiffPatchVisitor methodsFor: 'visiting' stamp: ''!
visitDelete: aDelete

	stream << '-' << aDelete element << String cr! !

!DiffPatchVisitor methodsFor: 'visiting' stamp: ''!
visitMatch: aMatch

	stream << ' ' << aMatch element << String cr! !

!DiffPatchVisitor methodsFor: 'visiting' stamp: ''!
visitInsert: anInsert

	stream << '+' << anInsert element << String cr! !

!DiffPresenter commentStamp: ''!
I am a Spec widget useful for visualising differences between two strings.

When a classContext: is set, the strings are highlighted using such contextual information.

Examples:

self exampleWithoutOptions.
self exampleWithOptions.!
!DiffPresenter methodsFor: 'accessing' stamp: ''!
rightLabel: anObject

	rightLabelHolder value: anObject ! !

!DiffPresenter methodsFor: 'accessing' stamp: ''!
rightText: anObject

	rightTextHolder value: anObject ! !

!DiffPresenter methodsFor: 'api' stamp: ''!
showBoth

	showOnlySource rawValue: false.
	showOnlyDestination rawValue: false.
	self changed: #showBoth with: { }! !

!DiffPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	leftTextHolder := '' asValueHolder.
	rightTextHolder := '' asValueHolder.
	contextClassHolder := nil asValueHolder.
	showOptions := true asValueHolder.
	showOnlyDestination := false asValueHolder.
	showOnlySource := false asValueHolder.	
	leftLabelHolder := nil asValueHolder.
	rightLabelHolder := nil asValueHolder.
		
	leftTextHolder whenChangedDo: [ :newText | self changed: #leftText: with: { newText } ].
	rightTextHolder whenChangedDo: [ :newText | self changed: #rightText: with: { newText } ].
	contextClassHolder whenChangedDo: [ :newClass | self changed: #contextClass: with: { newClass } ].	
	showOptions whenChangedDo: [ :aBoolean | self changed: #showOptions: with: { aBoolean }].	
	showOnlyDestination whenChangedDo: [:aBoolean | self changed: #showOnlyDestination: with: { aBoolean } ].
	showOnlySource whenChangedDo: [:aBoolean | self changed: #showOnlySource: with: { aBoolean } ].
	
	leftLabelHolder whenChangedDo: [:newText | self changed: #leftLabel: with: { newText } ].
	rightLabelHolder whenChangedDo: [:newText | self changed: #rightLabel: with: { newText } ].
! !

!DiffPresenter methodsFor: 'accessing' stamp: ''!
rightLabel

	^ rightLabelHolder value! !

!DiffPresenter methodsFor: 'accessing' stamp: ''!
contextClass

	^ contextClassHolder value! !

!DiffPresenter methodsFor: 'accessing' stamp: ''!
leftLabel

	^ leftLabelHolder value! !

!DiffPresenter methodsFor: 'api' stamp: ''!
showOptions: aBoolean

	showOptions value: aBoolean! !

!DiffPresenter methodsFor: 'accessing' stamp: ''!
leftLabel: anObject

	leftLabelHolder value: anObject ! !

!DiffPresenter methodsFor: 'api' stamp: ''!
showOptions

	^ showOptions value! !

!DiffPresenter methodsFor: 'undo-redo' stamp: ''!
clearUndoManager
	"The diff presenter does not allow edition, it does not have undo history. But this message is added to have polimorphism in the Message Browser"! !

!DiffPresenter methodsFor: 'api' stamp: ''!
showOnlyDestination: aBoolean

	showOnlyDestination rawValue: false.
	showOnlyDestination value: aBoolean.! !

!DiffPresenter methodsFor: 'api' stamp: ''!
showOnlyDestination

	^ showOnlyDestination value! !

!DiffPresenter methodsFor: 'api' stamp: ''!
showOnlySource

	^ showOnlySource value! !

!DiffPresenter methodsFor: 'accessing' stamp: ''!
leftText

	^ leftTextHolder value! !

!DiffPresenter methodsFor: 'accessing' stamp: ''!
rightText

	^ rightTextHolder value! !

!DiffPresenter methodsFor: 'api' stamp: ''!
showOnlySource: aBoolean

	showOnlyDestination rawValue: false.
	showOnlySource value: aBoolean! !

!DiffPresenter methodsFor: 'accessing' stamp: ''!
leftText: anObject

	leftTextHolder value: anObject ! !

!DiffPresenter methodsFor: 'accessing' stamp: ''!
contextClass: anObject

	contextClassHolder value: anObject ! !

!DiffPresenter class methodsFor: 'examples' stamp: ''!
exampleWithoutOptions
	"
	self exampleWithoutOptions
	"
	<sampleInstance>
	
	^ self new
		showOptions: false;
		leftText: 'Old text';
		rightText: 'New text';
		openWithSpec
! !

!DiffPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(MorphicDiffAdapter
		adapt: #(model))! !

!DiffPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #DiffAdapter! !

!DiffPresenter class methodsFor: 'examples' stamp: ''!
exampleWithOptions
	"
	self exampleWithOptions
	"
	<sampleInstance>
	^ self new
		showOptions: true;
		leftText: (True >> #and:) sourceCode;
		rightText: (True >> #or:) sourceCode;
		contextClass: True;
		openWithSpec! !

!DiffReplyVisitor methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	stream := String new writeStream! !

!DiffReplyVisitor methodsFor: 'accessing' stamp: ''!
contents

	^ stream contents! !

!DiffReplyVisitor methodsFor: 'visiting' stamp: ''!
visitMatch: aMatch

	stream << aMatch element << String cr! !

!DiffReplyVisitor methodsFor: 'visiting' stamp: ''!
visitInsert: anInsert

	stream << anInsert element << String cr! !

!DiffSideBySideChangeRecordConverter commentStamp: ''!
A method converter to be used in version browser to show a side by side diff.
It can update the code panel through a double dispatch (see `DiffSideBySideChangeRecordConverter>>#updateContent:on:`)
!
!DiffSideBySideChangeRecordConverter methodsFor: 'updating' stamp: ''!
updateContent: content on: aVersionBrowser 
	
	aVersionBrowser updateDiff: content! !

!DiffSourceMethodConverter commentStamp: ''!
A source method converted to be used in version browser.
It can update the code panel through a double dispatch (see `DiffSourceMethodConverter>>#updateContent:on:`)!
!DiffSourceMethodConverter methodsFor: 'updating' stamp: ''!
updateContent: content on: aVersionBrowser 
	
	aVersionBrowser updateSource: content! !

!DiffVersionChangeRecordConverter commentStamp: ''!
A converter used to show the diff between two Method references.!
!DiffVersionChangeRecordConverter methodsFor: 'private' stamp: ''!
priorVersionOfAMethod: aChangeRecord
	| index |
	index := referencesList identityIndexOf: aChangeRecord .
	^ referencesList at: index+1 ifAbsent: [ nil ]! !

!DiffVersionChangeRecordConverter methodsFor: 'private' stamp: ''!
internalGetText
	| priorSource |
	priorSource := (self priorVersionOfAMethod: method) ifNotNil: [ :m | m sourceCode ] ifNil: [ '' ].
	^ Array with: priorSource with: method sourceCode! !

!DiffVersionChangeRecordConverter methodsFor: 'updating' stamp: ''!
updateContent: content on: aVersionBrowser

	self subclassResponsibility! !

!DiffVisitor methodsFor: 'visiting' stamp: ''!
visitPatch: aPatch

	aPatch elements 
		do: [ :each | each accept: self ]! !

!DiffVisitor methodsFor: 'visiting' stamp: ''!
visitDelete: anElement! !

!DiffVisitor methodsFor: 'visiting' stamp: ''!
visitMatch: anElement! !

!DiffVisitor methodsFor: 'visiting' stamp: ''!
visitInsert: anElement! !

!DigitalSignatureAlgorithm commentStamp: ''!
This class implements the Digital Signature Algorithm (DSA) of the U.S. government's "Digital Signature Standard" (DSS). The DSA algorithm was proposed in 1991 and became a standard in May 1994. The official description is available as a Federal Information Processing Standards Publication (FIPS PUB 186, May 19, 1994). A companion standard, the Secure Hash Standard, or SHS (FIPS PUB 180-1, April 17, 1995), describes a 160-bit message digest algorithm known as the Secure Hash Algorithm (SHA). This message digest is used to compute the document signature.

Here's how to use it:

  1. The "signer" creates a pair of keys. One of these must be kept private. The other may be freely distributed. For example, it could be built into the signature checking code of an application.

  2. When the signer wishes to sign a packet of data (a "message") , he uses the secure hash algorithm to create a 160-bit message digest (hash) which is used as the input to DSA. The result of this is a pair of large numbers called a "signature" that is attached to the original message.

  3. When someone receives a signed message purported to have come from the signer, they compute the 160-bit hash of the message and pass that, along with the message signature and the signer's public key, to the signature verification algorithm. If the signature checks, then it is virtually guaranteed that the message originated from someone who had the signer's private key. That is, the message is not a forgery and has not been modified since it was signed. For example, if the message contains a program, and the recipient trusts the signer, then the recipient can run the program with the assurance that it won't do anything harmful. (At least, not intentionally. A digital signature is no guarantee against bugs!! :->)

The signer must keep the private key secure, since anyone who has the private key can forge the signer's signature on any message they like. As long as the secret key is not stolen, cryptographers believe it to be virtually impossible either to forge a signature, to find a message that matches an existing sigature, or to discover the signer's private key by analyzing message signatures. Knowing the public key (which, for example, could be recovered from an application that had it built in), does not weaken the security at all.

An excellent reference work on digital signatures and cryptography in general is:

  Schneier, Bruce
  "Applied Cryptography: Protocols, Algorithms, and Source Code in C"
  John Wiley and Sons, 1996.

I used this book as a guide to implementing many of the numerical algorithms required by DSA.

Patents and Export Restrictions:

Many digital signature technologies are patented. DSA is also patented, but the patent is owned by the U.S. government which has made DSA available royalty-free. There is a claim that the government patent infringes on an earlier patent by Schnorr, but the government is requiring the use of DSA, so they apparently believe this claim is not strong enough to be a serious threat to their own patent.

Most cryptography technology, including digital signature technology, requires an export license for it to be distributed outside the U.S. Recent legislation may have relaxed the export license requirements, but it would be prudent to check the current regulations before exporting this code.!
!DigitalSignatureAlgorithm methodsFor: 'public' stamp: ''!
stringToSignature: aString 
	"Answer the signature stored in the given string. A signature string has the format:

		 '[DSA digital signature <r> <s>]'

	where <r> and <s> are large positive integers represented by strings of hexadecimal 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: 'private' stamp: ''!
generateSandQ
	"Generate a 160-bit random seed s and an industrial grade prime q."

	| hasher s sPlusOne u q |
	hasher := SHA1 new.
	[true] whileTrue: [
		s := self nextRandom160.
		sPlusOne := s + 1.
		sPlusOne highBit > 160 ifTrue: [sPlusOne := sPlusOne \\ (2 raisedTo: 160)].
		u := (hasher hashInteger: s) bitXor: (hasher hashInteger: sPlusOne).
		q := u bitOr: ((1 bitShift: 159) bitOr: 1).
		(self isProbablyPrime: q) ifTrue: [^ Array with: s with: q]].
! !

!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: ''!
initRandomFromUser
	"Ask the user to type a long random string and use the result to seed the secure random number generator."

	| s |
	s := UIManager default request: 'Enter a long random string to seed the random generator.'.
	s ifNil: [s := '']. 
	^self initRandomFromString: s! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: ''!
generateKeySet
	"Generate and answer a key set for DSA. The result is a pair (<private key><public key>). 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: 'private' stamp: ''!
generateRandomLength: bitLength s: s n: n
	"Answer a random number of bitLength bits generated using the secure hash algorithm."

	| sha out count extraBits v |
	sha := SHA1 new.
	out := 0.
	count := (bitLength // 160).
	extraBits := bitLength - (count * 160).
	0 to: count do: [:k |
		v := sha hashInteger: (s + n + k).
		k = count ifTrue: [
			v := v - ((v >> extraBits) << extraBits)].
		out := out bitOr: (v bitShift: (160 * k))].
	^ out
! !

!DigitalSignatureAlgorithm methodsFor: 'large integer arithmetic' stamp: ''!
isProbablyPrime: p
	"Answer true if p is prime with very high probability. Such a number is sometimes called an 'industrial grade prime'--a large number that is so extremely likely to be prime that it can assumed that it actually is prime for all practical purposes. This implementation uses the Rabin-Miller algorithm (Schneier, p. 159)."

	| iterations pMinusOne b m r a j z couldBePrime |
	iterations := 50.	
	"Note: The DSA spec requires >50 iterations; Schneier says 5 are enough (p. 260)"	"quick elimination: check for p divisible by a small prime"
	SmallPrimes
		ifNil: [ 
			"generate list of small primes > 2"
			SmallPrimes := Integer primesUpTo: 2000.
			SmallPrimes := SmallPrimes copyFrom: 2 to: SmallPrimes size ].
	SmallPrimes detect: [ :f | p \\ f = 0 ] ifFound: [ :factor | ^ p = factor ].
	pMinusOne := p - 1.
	b := self logOfLargestPowerOfTwoDividing: pMinusOne.
	m := pMinusOne bitShift: b negated.	
	"Assert: pMinusOne = m * (2 raisedTo: b) and m is odd"
	"Transcript show: '      Prime test pass '."
	r := Random new.
	1 to: iterations do: [ :i | 
		"Transcript show: i printString; space."
		a := (r next * 16rFFFFFF) truncated.
		j := 0.
		z := (a raisedTo: m modulo: p) normalize.
		couldBePrime := z = 1.
		[ couldBePrime ]
			whileFalse: [ 
				z = 1
					ifTrue: [ 
						"Transcript show: 'failed!!'; cr."
						^ false ].	"not prime"
				z = pMinusOne
					ifTrue: [ couldBePrime := true ]
					ifFalse: [ 
						(j := j + 1) < b
							ifTrue: [ z := z * z \\ p ]
							ifFalse: [ 
								"Transcript show: 'failed!!'; cr."
								^ false ] ] ] ].	"not prime"
	"Transcript show: 'passed!!'; cr."
	^ true	 "passed all tests; probably prime"! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: ''!
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: 'private' stamp: ''!
nextRandom160
	"Answer a newly generated 160-bit random number in the range [1..(2^160 - 1)]."
	"Details: Try again in the extremely unlikely chance that zero is encountered."

	| result |
	result := 0.
	[result = 0] whileTrue: [
		result := SHA1 new hashInteger: randKey seed: randSeed.
		randKey := randKey + result + 1].
	^ result
! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: ''!
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: 'initialization' stamp: ''!
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 bytesCount to: 1 by: -1 do: [:i |
		k byteAt: 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: ''!
initRandomNonInteractively

 	self initRandomFromString: 
 		Time millisecondClockValue printString, 
 		Date today printString, 
 		Smalltalk os platformName printString! !

!DigitalSignatureAlgorithm methodsFor: 'large integer arithmetic' stamp: ''!
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: 'public' stamp: ''!
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: ''!
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: ''!
generateQandP
	"Generate the two industrial-grade primes, q (160-bits) and p (512-bit) needed to build a key set. Answer the array (q, p, s), where s is the seed that from which q and p were created. This seed is normally discarded, but can be used to verify the key generation process if desired."

	| pBits halfTwoToTheP chunkCount sAndq q twoQ n c w x p s |
	pBits := 512.  "desired size of p in bits"
	halfTwoToTheP := 2 raisedTo: (pBits - 1).
	chunkCount := pBits // 160.

	"Transcript show: 'Searching for primes q and p...'; cr."
	[true] whileTrue: [
		sAndq := self generateSandQ.
		"Transcript show: '  Found a candidate q.'; cr."
		s := sAndq first.
		q := sAndq last.
		twoQ := q bitShift: 1.
		n := 2.
		c := 0.
		[c < 4096] whileTrue: [
			w := self generateRandomLength: pBits s: s n: n.
			x := w + halfTwoToTheP.
			p := (x - ( x \\ twoQ)) + 1.
			p highBit = pBits ifTrue: [
				"Transcript show: '    Testing potential p ', (c + 1) printString, '...'; cr."
				(self isProbablyPrime: p) ifTrue: [
					"Transcript show: '  Found p!!'; cr."
					^ Array with: q with: p with: s]].
			n := n + chunkCount + 1.
			c := c + 1]].
! !

!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: ''!
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 class methodsFor: 'examples' stamp: ''!
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: 'public' stamp: ''!
generateKeySet
 	"Generate and answer a key set for code signing. The result is a pair (<private key><public key>). 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 time?')
 		ifTrue: [dsa initRandomNonInteractively]
 		ifFalse: [dsa initRandomFromUser].
 	^ dsa generateKeySet
 ! !

!DigitalSignatureAlgorithm class methodsFor: 'initialization' stamp: ''!
initialize
	"DigitalSignatureAlgorithm initialize"

	"SmallPrimes is a list of small primes greater than two."
	SmallPrimes := Integer primesUpTo: 2000.
	SmallPrimes := SmallPrimes copyFrom: 2 to: SmallPrimes size.

	"HighBitOfByte maps a byte to the index of its top non-zero bit."
	HighBitOfByte := (0 to: 255) collect: [:byte | byte highBit].
! !

!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: ''!
timeDecode: count
	"Example of signing a message and verifying its signature."
	"Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature."
	"DigitalSignatureAlgorithm timeDecode: 20"

	| dsa |

	dsa := self new.
	dsa initRandomFromUser.

	#(1 10 100 1000 10000 100000) do: [ :extraLen | | s msg keys sig |
		s := String new: extraLen.
		1 to: s size do: [ :i | s at: i put: (Character value: 200 atRandom)].
		msg := 'This is a test...',s.
		keys := self testKeySet.
		sig := self sign: msg privateKey: keys first dsa: dsa.
		"self inform: 'Signature created'."
		self timeDirect: [
			count timesRepeat: [
				(self verify: sig isSignatureOf: msg publicKey: keys last)
					ifFalse: [self error: 'ERROR!! Signature verification failed'].
			].
		] as: 'verify msgLen = ',msg size printString count: count
	].
! !

!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: ''!
verify: signatureString isSignatureOf: aStringOrStream publicKey: publicKey 
	"Answer true if the given signature string signs the given message (a stream or string)."
	"Note: Random numbers are not needed for signature verification; thus, there is no need to call initRandomFromUser before verifying a signature."
	| dsa hasher h sig |
	dsa := self new.
	hasher := SHA1 new.
	h := aStringOrStream class isBytes 
		ifTrue: [ hasher hashMessage: aStringOrStream ]
		ifFalse: [ hasher hashStream: aStringOrStream ].
	sig := dsa stringToSignature: signatureString.
	^ dsa 
		verifySignature: sig
		ofMessageHash: h
		publicKey: publicKey! !

!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: ''!
sign: aStringOrStream privateKey: privateKey 
	"Sign the given message (a stream or string) and answer a signature string."
	"Note: Unguessable random numbers are needed for message signing. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before signing a message. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams."
	| dsa hasher h sig |
	dsa := self new.
	dsa initRandomFromUser.
	hasher := SHA1 new.
	h := aStringOrStream class isBytes 
		ifTrue: [ hasher hashMessage: aStringOrStream ]
		ifFalse: [ hasher hashStream: aStringOrStream ].
	sig := dsa 
		computeSignatureForMessageHash: h
		privateKey: privateKey.
	^ dsa signatureToString: sig! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: ''!
timeDirect: aBlock as: aString count: anInteger
	self trace: (String streamContents: [ :stream | 
			 stream
				 nextPutAll: anInteger asStringWithCommas;
				 nextPutAll: '  ';
				 nextPutAll: aString;
				 nextPutAll: ' took ';
				 nextPutAll: (Time millisecondsToRun: aBlock) asStringWithCommas;
				 nextPutAll: ' ms';
				 cr ])! !

!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: ''!
testKeySet
	"Answer a pair of keys for testing. The first key is the private key, the second one is the public key."
	"WARNING: This test key set is public should be used only for testing!! In a real application, the user would create a set of keys using generateKeySet and would keep the private key secret."

	^ #(
		(8343811888543852523216773185009428259187948644369498021763210776677854991854533186365944349987509452133156416880596803846631577352387751880552969116768071 1197175832754339660404549606408619548226315875117 1433467472198821951822151391684734233265646022897503720591270330985699984763922266163182803556189497900262038518780931942996381297743579119123094520048965 957348690772296812)
		(8343811888543852523216773185009428259187948644369498021763210776677854991854533186365944349987509452133156416880596803846631577352387751880552969116768071 1197175832754339660404549606408619548226315875117 1433467472198821951822151391684734233265646022897503720591270330985699984763922266163182803556189497900262038518780931942996381297743579119123094520048965 4645213122572190617807944614677917601101008235397095646475699959851618402406173485853587185431290863173614335452934961425661774118334228449202337038283799))
! !

!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: ''!
sign: aStringOrStream privateKey: privateKey dsa: dsa 
	"Sign the given message (a stream or string) and answer a signature string."
	"Note: Unguessable random numbers are needed for message signing. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before signing a message. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams."
	| hasher h sig |
	hasher := SHA1 new.
	h := aStringOrStream class isBytes 
		ifTrue: [ hasher hashMessage: aStringOrStream ]
		ifFalse: [ hasher hashStream: aStringOrStream ].
	sig := dsa 
		computeSignatureForMessageHash: h
		privateKey: privateKey.
	^ dsa signatureToString: sig! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: ''!
time: aBlock as: aString count: anInteger

	^{anInteger. aString. (Time millisecondsToRun: aBlock)}! !

!DirectoryDoesNotExist commentStamp: ''!
I am raised when I an operation is attempted inside a directory that does not exist. !
!DirectoryEntryTest commentStamp: ''!
SUnit tests for FileSystemDirectoryEntry!
!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
testIsDirectory
	| ref entry |
	ref := FileLocator imageDirectory resolve.
	entry := ref entry.
	self assert: entry isDirectory.
	self assert: FileLocator imageDirectory resolve equals: Smalltalk imageDirectory! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
testIsNotDirectory
	self deny: self entry isDirectory! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
testIfAbsent
	| reference entry |
	reference := FileLocator temp / 'plonk'.
	reference ensureCreateFile.
	entry := reference entry.
	[ entry ifAbsent: [ :file | self fail ].
	reference delete.
	self assert: (entry ifAbsent: [ 'plonk' ]) equals: 'plonk' ]
		ensure: [ reference ensureDelete ]! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
testSize
	self assert: self entry size isInteger! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
testIfExists
	| reference entry |
	reference := FileLocator temp / 'plonk'.
	reference ensureCreateFile.
	entry := reference entry.
	[ self assert: (entry ifExists: [ :file | file basename ]) equals: 'plonk'.
	reference delete.
	entry ifExists: [ :file | self fail ] ]
		ensure: [ reference ensureDelete ]! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
testIfExistsIfAbsent
	| reference entry |
	reference := FileLocator temp / 'plonk'.
	reference ensureCreateFile.
	entry := reference entry.
	[ self assert: (entry ifExists: [ true ] ifAbsent: [ false ]).
	reference delete.
	self assert: (entry ifExists: [ false ] ifAbsent: [ true ]) ]
		ensure: [ reference ensureDelete ]! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
testReference
	| ref entry |
	ref := FileLocator image resolve.
	entry := ref entry.
	self assert: entry reference equals: ref! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
testIsFile
	self assert: self entry isFile.
	self deny: self entry isDirectory! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
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 equals: DateAndTime! !

!DirectoryEntryTest methodsFor: 'accessing' stamp: ''!
entry
	^ FileLocator image resolve entry! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
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 equals: DateAndTime! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
testIsNotFile
	| ref |
	ref := FileLocator imageDirectory resolve.
	self deny: ref entry isFile! !

!DirectoryEntryTest methodsFor: 'tests' stamp: ''!
testRootEntry
	"Check that the root entry contains sensible values.
	On Windows this requires a pseudo entry to be available."

	| rootEntry |

	rootEntry := (FileReference fileSystem: FileSystem disk path: Path root) entry.

	self assert: rootEntry isDirectory.
	self deny: rootEntry isFile.
	self assert: rootEntry size equals: 0.
	self assert: rootEntry isReadable.
	self assert: rootEntry isExecutable.
	self deny: rootEntry isWritable.! !

!DirectoryExists commentStamp: ''!
I am raised on an attempt to create a directory that already exists.!
!DirectoryIsNotEmpty commentStamp: ''!
I am raised on an attempt to delete a directory when is not empty.!
!DirtyTestError commentStamp: ''!
I am a root of hierarchy of errors which represent the dirty state of system produced by test.
For example the test can left the running background process or background process can raise an error.

TestExecutionEnvironment checks the system state at the end of test and concrete error is raised if dirty state is detected. 
Those errors are signalled even if test was failed due to domain error. In that case when domain error is handled by SUnit (marking the test result as failed) the another error is signaled to notify about bad system state!
!DirtyTestError methodsFor: 'accessing' stamp: ''!
executionEnvironment

	^ executionEnvironment! !

!DirtyTestError methodsFor: 'accessing' stamp: ''!
executionEnvironment: anObject

	executionEnvironment := anObject! !

!DirtyTestError methodsFor: 'exception handling' stamp: ''!
manageTestProcessBy: aProcessMonitorTestService
	"Do nothing because I am not an error during actual test execution.
	My subclasses only represent the dirty system state at the end of test"! !

!DirtyTestError methodsFor: 'exception handling' stamp: ''!
sunitAnnounce: aTestCase toResult: aTestResult

	executionEnvironment isMainTestProcessFailed ifTrue: [ 
		"The main test process errors are handled by SUnit using same message.
		So the actual domain test error is already counted in result" 
		^ self ].

	"If main test process was completed successfully
	we should mark test as failed due to dirty system state"
	aTestResult addError: aTestCase! !

!DirtyTestError class methodsFor: 'instance creation' stamp: ''!
signalFrom: aTestExecutionEnvironment
	^self new 
		executionEnvironment: aTestExecutionEnvironment;
		signal! !

!DisabledBreakpointIconStyler commentStamp: ''!
I'm in charge to style an ast when there are breakpoints that are disabled!
!DisabledBreakpointIconStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	 ^ [ :seg | 
	   aNode breakpoints do: [ :breakpoint | breakpoint enable ].
	   seg delete ]! !

!DisabledBreakpointIconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^(Color darkGray alpha: 0.1)! !

!DisabledBreakpointIconStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode
	^ 'Breakpoint (disabled)'! !

!DisabledBreakpointIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^aNode hasBreakpoint and: [ aNode breakpoints noneSatisfy: [:brkpt | brkpt isEnabled ]]! !

!DisabledBreakpointIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #smallInfo ! !

!DiskDirectoryEntry commentStamp: ''!
DiskDirectoryEntry holds attributes for a single file / directory on the disk.

The actual attributes are held in two arrays which are returned directly from the #fileAttributes:mask: primitive.  See statAttributes and accessAttributes, below.

DiskDirectoryEntry's are not normally created directly, but are returned as a result of sending the #entry or #entries messages to a FileReference.

If the receiver's file is a symbolic link, the information contained in the receiver is for the target file, not the symbolic link.  See also DiskSymlinkDirectoryEntry.

 
Internal Representation and Key Implementation Points.

    Instance Variables
	accessAttributes:		<Array>  An array of booleans indicating whether the image has read, write and execute access to the file.
	statAttributes:		<Array>  See File class>>primFileAttributes:mask: for the list of attributes.


    Implementation Points

- statAttributes mostly corresponds with the information returned by the posix stat() call, thus its name.
- accessAttributes mostly corresponds with the information returned by the posix array() call, thus its name.

accessAttributes is relatively expensive to retrieve, so is loaded lazily only if requested.
!
!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
modificationTime
	"Answer the receiver's modification time"

	^DateAndTime fromInternalTime: (self statAttributes at: 10)! !

!DiskDirectoryEntry methodsFor: 'private - accessing' stamp: ''!
statAttributes: anArray

	statAttributes := anArray! !

!DiskDirectoryEntry methodsFor: 'private - accessing' stamp: ''!
accessAttributes
	"Answer the access attributes of the receiver, i.e. whether the receiver is readable, writable and executable"

	^ accessAttributes ifNil: [ self getAccessAttributes ]! !

!DiskDirectoryEntry methodsFor: 'inspecting' stamp: ''!
gtInspectAttributesIn: composite
	<gtInspectorPresentationOrder: 2>

	| attrDictionary |

	attrDictionary := Dictionary new.
	self class methodsDo: [ :method |
		method methodNode arguments size = 0 ifTrue:
			[ attrDictionary at: method selector put:
				([ (method selector value: self) ]
					on: Error
					do: [ 'N/A' translated ]) ] ].
	^(attrDictionary gtInspectorItemsIn: composite)
		when: [ attrDictionary isNotEmpty ];
		title: 'Attributes' translated;
		yourself.! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isCharacter
	"Answer true if the receiver is a character device"
	
	^self primitives modeIsCharacter: self mode! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isReadable
	"Answer a boolean indicating whether the VM can read the receivers file"

	^self accessAttributes at: 1! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
creationTime
	"Answer the receivers creation time.  If this is not available, answer the change time, i.e. the time at which the receivers metadata was last updated."

	^DateAndTime fromInternalTime: ((self statAttributes at: 12) ifNil: [ self statAttributes at: 11 ])! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
deviceId
	"Answer the device ID of the receiver"
	
	^self statAttributes at: 4! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
asFilePluginNode
	"Backward compatibility: Answer an array of file attributes matching that returned by FilePlugin"

	^{
		self basename.
		(self statAttributes at: 12) ifNil: [ self statAttributes at: 11 ].
		self statAttributes at: 10.
		self isDirectory.
		self size.
		self posixPermissions.
		self isSymlink.
	}! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
permissions
	"Answer the receivers permissions"
	
	^FileSystemPermission posixPermissions: self posixPermissions! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
posixPermissions
	"Answer the receivers posix permissions"
	
	^self mode bitAnd: 8r777! !

!DiskDirectoryEntry methodsFor: 'private - accessing' stamp: ''!
allAttributeMask
	"Answer the mask used to retrieve all attributes"

	^self accessAttributeMask bitOr: self statAttributeMask! !

!DiskDirectoryEntry methodsFor: 'initialization' stamp: ''!
initializeWithReference: aFileReference statAttributes: anArray

	super initialize.	
	reference := aFileReference.
	statAttributes := anArray! !

!DiskDirectoryEntry methodsFor: 'cache management' stamp: ''!
getAccessAttributes
	"Store the receivers access() attributes for future reference"

	^accessAttributes := self primitives fileAttributes: self pathString mask: self accessAttributeMask! !

!DiskDirectoryEntry methodsFor: 'private - accessing' stamp: ''!
accessAttributes: anArray

	accessAttributes := anArray! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
uid
	"Answer the UID of the owner of the receiver"
	
	^self statAttributes at: 6! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
inode
	"Answer the index number of the receiver"
	
	^self statAttributes at: 3! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isBlock
	"Answer true if the receiver is a block device"
	
	^self primitives modeIsBlock: self mode.! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isHidden
	"Answer a boolean indicating whether the receiver is hidden"

	^reference fileSystem isHidden: reference attributes: self statAttributes! !

!DiskDirectoryEntry methodsFor: 'private - accessing' stamp: ''!
statAttributeMask
	"Answer the mask used to retrieve stat() attributes"

	^2r1! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isDirectory
	"Answer true if the receiver is a directory"

	reference isRoot ifTrue: [ ^true ].
	^[ self primitives modeIsDirectory: self mode ]
		on: FileDoesNotExistException
		do: [ false ].! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isFile
	"Answer true if the receiver is a file (exists and is not a directory)"
	
	reference isRoot ifTrue: [ ^false ].
	^[ (self primitives modeIsDirectory: self mode) not ]
		on: FileDoesNotExistException
		do: [ false ].! !

!DiskDirectoryEntry methodsFor: 'cache management' stamp: ''!
getStatAttributes
	"Store the receivers stat() attributes for future reference"

	^statAttributes := self primitives fileAttributes: self pathString mask: self statAttributeMask.! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
creationUnixTime
	"Answer the receiver's creation time in Unix time_t format"

	^self creationTime asUnixTime! !

!DiskDirectoryEntry methodsFor: 'private - accessing' stamp: ''!
primitives
	"Answer the attribute primitives to be used by the receiver."

	^File! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
changeTime
	"Answer the time the receivers metadata was last changed.
	On platforms that don't support change time, use the modification time"

	^DateAndTime fromInternalTime: ((self statAttributes at: 11) ifNil: [ self statAttributes at: 12 ])! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
accessTime

	^DateAndTime fromInternalTime: (self statAttributes at: 9)! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isSymlink
	"Answer true if the receiver is a symbolic link"

	reference path isRoot ifTrue: [ ^false ].
	"Don't use cached information as the values might reflect a target file accessed from a symlink."
	^self primitives isSymlink: self pathString! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isSocket
	"Answer true if the receiver is a socket"
	
	^self primitives modeIsSocket: self mode! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
gid
	"Answer the GID of the owner of the receiver"
	
	^self statAttributes at: 7! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isFIFO
	"Answer true if the receiver is FIFO"

	^self primitives modeIsFIFO: self mode! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isExecutable
	"Answer a boolean indicating whether the VM can execute the receivers file"

	^self accessAttributes at: 3! !

!DiskDirectoryEntry methodsFor: 'private - accessing' stamp: ''!
accessAttributeMask
	"Answer the mask used to retrieve access attributes"

	^2r10! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
mode
	"Answer the mode of the receiver"
	
	^self statAttributes at: 2! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
modificationUnixTime
	"Answer the receiver's modification time in Unix time_t format"

	^self modificationTime asUnixTime! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
accessUnixTime
	"Answer the receivers access time in Unix time_t format"

	^self accessTime asUnixTime! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
size
	"Answer the number of bytes in the receiver"
	
	^self statAttributes at: 8! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isRegular
	"Answer true if the receiver is a regular file"
	
	^self primitives modeIsRegular: self mode! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
changeUnixTime
	"Answer the receiver's change time in Unix time_t format"

	^self changeTime asUnixTime! !

!DiskDirectoryEntry methodsFor: 'cache management' stamp: ''!
getAllAttributes
	"Store all the receivers attributes for future reference"

	| allAttributes |
	
	allAttributes := self primitives fileAttributes: self pathString mask: self allAttributeMask.
	statAttributes := allAttributes at: 1.
	accessAttributes := allAttributes at: 2.! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
isWritable
	"Answer a boolean indicating whether the VM can write to the receivers file"

	^self accessAttributes at: 2! !

!DiskDirectoryEntry methodsFor: 'private - accessing' stamp: ''!
statAttributes
	^ statAttributes ifNil: [ self getStatAttributes ]! !

!DiskDirectoryEntry methodsFor: 'testing' stamp: ''!
hasCreationTime
	"Answer a boolean indicating whether the receiver has a creation timestamp, or is just using the change timestamp."

	^(self statAttributes at: 12) isNotNil! !

!DiskDirectoryEntry methodsFor: 'accessing' stamp: ''!
numberOfHardLinks
	"Answer the number of hard links to the receiver"
	
	^(self statAttributes at: 5) ifNil:
		[ FileAttributeNotSupported signalWith: reference ]! !

!DiskDirectoryEntry class methodsFor: 'instance creation' stamp: ''!
reference: aFileReference statAttributes: anArray
	"Answer an instance of the receiver pre-loaded with the supplied attributes"

	^self new initializeWithReference: aFileReference statAttributes: anArray! !

!DiskDirectoryEntry class methodsFor: 'testing' stamp: ''!
exists: aPath in: aStore
	"Answer a boolean indicating whether the supplied path exists"

	^aStore exists: aPath.! !

!DiskDirectoryEntry class methodsFor: 'instance creation' stamp: ''!
store: aDiskStore path: aPath node: aNode

	^(super store: aDiskStore path: aPath)
		statAttributes: (aNode at: 2);
		yourself.! !

!DiskDirectoryEntry class methodsFor: 'instance creation' stamp: ''!
fileSystem: aFilesystem path: aPath
	"Create a directory entry given a filesystem and a path in such filesystem."

	^ self reference: (aFilesystem referenceTo: aPath)! !

!DiskFileAttributesTest commentStamp: ''!
Try and test the file attributes primitives.

As Pharo doesn't yet provide a mechanism to set the attributes, pick a few well known files and make sure they have reasonable attributes, e.g. the VM is executable, it isn't older than when the classes were first created or newer than today, etc.
!
!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsDirectory

	| file |

	self collectionAssert: [ :each | each isDirectory ] equals: false.
	file := FileLocator temp resolve.
	self assert: (DiskDirectoryEntry reference: file) isDirectory.! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsRegular

	self collectionAssert: [ :each | each isRegular ]! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testSymlinkUidGid

	| fileReference oldUid oldGid |

	fileReference := FileLocator temp / ('FileAttributesTests-', UUIDGenerator next asString, '.txt').
	fileReference createFile.
	[ 
		oldUid := fileReference uid.
		oldGid := fileReference gid.

		"Setting ownership isn't supported on Windows"
		OSPlatform current isWindows ifTrue: [ 
			self should: [ fileReference symlinkUid: nil gid: nil ] raise: Error ]
		ifFalse: [ 
			"Since we can't reliably determine new test ids, call the method without changing values.
			This will at least test that the primitive can be called and doesn't do something unexpected."
			fileReference symlinkUid: nil gid: nil.
			self assert: fileReference uid equals: oldUid.
			self assert: fileReference gid equals: oldGid ].
	] ensure: [ fileReference delete ]! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testCreationTime

	| resource creationTime |
	resource := self tempFileResource.
	self attributesCollectionDo: [ :each |
		creationTime := each creationTime.
		self assert: resource beforeCreationTime <= creationTime.
		self assert: resource afterCreationTime >= creationTime.
		].! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsCharacter

	self collectionAssert: [ :each | each isCharacter ] equals: false.! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testPermissions

	| fileReference oldPermissions newPermissions |

	fileReference := (FileLocator temp / ('FileAttributesTests-', UUIDGenerator next asString, '.txt')) resolve.

	fileReference createFile.
	[ 
		oldPermissions := self tempFileEntry permissions.
		newPermissions := FileSystemPermission posixPermissions: 8r007.
		"Check that the existing permissions don't happen to match the test permissions"
		self assert: oldPermissions ~= newPermissions.

		"Setting permissions aren't supported on Windows"
		OSPlatform current isWindows ifTrue: [ 
			self should: [ fileReference permissions: newPermissions ] raise: Error ]
		ifFalse: [ 
			fileReference permissions: newPermissions.
			self assert: fileReference permissions equals: newPermissions ].
	] ensure: [ fileReference delete ]! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsFIFO

	self collectionAssert: [ :each | each isFIFO ] equals: false.! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testModificationTime

	| resource modificationTime |
	resource := self tempFileResource.
	self attributesCollectionDo: [ :each |
		modificationTime := each modificationTime.
		self assert: resource beforeCreationTime <= modificationTime.
		self assert: resource afterCreationTime >= modificationTime.
		].! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testNLink
	"Assume that there is only one hard link to the just created temporary file"

	OSPlatform current name = #'Win32' ifTrue: 
		[ self should: [ self tempFileResource file numberOfHardLinks ] raise: FileAttributeNotSupported ]
	ifFalse:
		[ self collectionAssert: [ :each | each numberOfHardLinks ] equals: 1 ].! !

!DiskFileAttributesTest methodsFor: 'private - helpers' stamp: ''!
collectionAssert: aBlock
	"Evaluate the assertion block for each of the FileAttribute cache modes"

	self attributesCollectionDo:
		[ :each | self assert: (aBlock value: each) ].! !

!DiskFileAttributesTest methodsFor: 'private - helpers' stamp: ''!
collectionAssert: aBlock equals: expected
	"Evaluate the assertion block for each of the FileAttribute cache modes"

	self attributesCollectionDo:
		[ :each | self assert: (aBlock value: each) equals: expected ].! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testFromPlatformPath

	| testString platformByteArray nativeByteArray |

	testString := '1234žřč'.
	platformByteArray := { 
		#Win32 -> #[49 0 50 0 51 0 52 0 126 1 89 1 13 1].
		#Win64 -> #[49 0 50 0 51 0 52 0 126 1 89 1 13 1].
		#unix -> testString utf8Encoded.
		#'Mac OS' -> #[49 50 51 52 122 204 140 114 204 140 99 204 140].
	 } asDictionary at: OSPlatform current platformName asSymbol.
	nativeByteArray := File fromPlatformPath: platformByteArray.
	self assert: nativeByteArray utf8Decoded equals: testString.! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testFileSize

	self collectionAssert: [ :each | each size ] equals: 72.! !

!DiskFileAttributesTest methodsFor: 'private - helpers' stamp: ''!
attributesCollection
	"Answer an array of FileAttributes for the test resource file.
	This is currently a single entry, but leaving the infrastructure in place in case it is extended."
	
	^{
		self tempFileEntry.
	}! !

!DiskFileAttributesTest methodsFor: 'private - helpers' stamp: ''!
tempFileEntry

	| file |
	
	file := self tempFileResource file resolve.
	^DiskDirectoryEntry reference: file.! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsReadable

	self collectionAssert: [ :each | each isReadable ].! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsSymlink

	self collectionAssert: [ :each | each isSymlink ] equals: false.! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsWriteable

	self collectionAssert: [ :each | each isWritable ].! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testTargetFile

	"The temporary file isn't a symbolic link, so the targetFile is not supported"
	self attributesCollectionDo: [ :each |
		self should: [ each targetFileReference ] raise: FileAttributeNotSupported ].! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testExistsNot

	| file |
	file := '/thisfileshouldnot.exist' asFileReference.
	self deny: (DiskDirectoryEntry exists: file path in: file fileSystem).! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsSocket

	self collectionAssert: [ :each | each isSocket ] equals: false.! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsExecutable
	| file |
	file := FileLocator vmBinary resolve.
	self assert: (DiskDirectoryEntry reference: file) isExecutable! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testAccessTime

	| resource accessTime |
	resource := self tempFileResource.
	self attributesCollectionDo: [ :each |
		accessTime := each accessTime.
		self assert: resource beforeCreationTime <= accessTime.
		self assert: resource afterCreationTime >= accessTime.
		].! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsHidden

	self collectionAssert: [ :each | each isHidden ] equals: false.! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testUidGid

	| fileReference oldUid oldGid |

	fileReference := FileLocator temp / ('FileAttributesTests-', UUIDGenerator next asString, '.txt').
	fileReference createFile.
	[ 
		oldUid := fileReference uid.
		oldGid := fileReference gid.

		"Setting ownership isn't supported on Windows"
		OSPlatform current isWindows ifTrue: [ 
			self should: [ fileReference uid: nil gid: nil ] raise: Error ]
		ifFalse: [ 
			"Since we can't reliably determine new test ids, call the method without changing values.
			This will at least test that the primitive can be called and doesn't do something unexpected."
			fileReference uid: nil gid: nil.
			self assert: fileReference uid equals: oldUid.
			self assert: fileReference gid equals: oldGid ].
	] ensure: [ fileReference delete ]! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testExists

	| file |
	file := self tempFileResource file resolve.
	self assert: (DiskDirectoryEntry exists: file path in: file fileSystem)! !

!DiskFileAttributesTest methodsFor: 'private - helpers' stamp: ''!
attributesCollectionDo: aBlock
	"Evaluate the supplied block for each of the attribute cache modes"

	^self attributesCollection do: aBlock! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testToPlatformPath

	| testString platformByteArray expectedByteArray |

	testString := '1234žřč'.
	platformByteArray := File toPlatformPath: testString.
	expectedByteArray := { 
		#Win32 -> #[49 0 50 0 51 0 52 0 126 1 89 1 13 1].
		#Win64 -> #[49 0 50 0 51 0 52 0 126 1 89 1 13 1].
		#unix -> testString utf8Encoded.
		#'Mac OS' -> #[49 50 51 52 122 204 140 114 204 140 99 204 140].
	 } asDictionary at: OSPlatform current platformName asSymbol.
	self assert: platformByteArray equals: expectedByteArray.! !

!DiskFileAttributesTest methodsFor: 'tests' stamp: ''!
testIsBlock

	self collectionAssert: [ :each | each isBlock ] equals: false.! !

!DiskFileAttributesTest methodsFor: 'private - helpers' stamp: ''!
tempFileResource

	^DiskFileAttributesTestsResource current! !

!DiskFileAttributesTest class methodsFor: 'accessing' stamp: ''!
resources

	^Array with: DiskFileAttributesTestsResource.! !

!DiskFileAttributesTestsResource commentStamp: ''!
DiskFileAttributesTestsResources provides a file with known attributes that can be used to test attribute retrieval in the File System.

DiskFileAttributesTestsResources is currently used by FileReferenceAttributeTests.

    Instance Variables
	afterCreationTime:	The time just after file was created	<DateAndTime>
	beforeCreationTime:	The time just before file was created	<DateAndTime>
	file:					The name of the file (with known attributes)	<FileReference>


    Implementation Points!
!DiskFileAttributesTestsResource methodsFor: 'running' stamp: ''!
tearDown

	super tearDown.
	file delete.! !

!DiskFileAttributesTestsResource methodsFor: 'accessing' stamp: ''!
beforeCreationTime
	^ beforeCreationTime! !

!DiskFileAttributesTestsResource methodsFor: 'accessing' stamp: ''!
file
	^ file! !

!DiskFileAttributesTestsResource methodsFor: 'accessing' stamp: ''!
afterCreationTime
	^ afterCreationTime! !

!DiskFileAttributesTestsResource methodsFor: 'running' stamp: ''!
setUp

	| ws |

	super setUp.
	file := FileLocator temp / ('FileAttributesTests-žřč-', UUIDGenerator next asString, '.txt').
	beforeCreationTime := DateAndTime now.
	"Remove the nanoseconds"
	beforeCreationTime := DateAndTime
		date: beforeCreationTime asDate
		time: (Time seconds: beforeCreationTime secondsSinceMidnightLocalTime nanoSeconds: 0).
	ws := file writeStream.
	[
		ws nextPutAll: 'Created by FileAttributesTestsResources>>setUp '.
		beforeCreationTime printOn: ws.
	] ensure: [ ws close ].
	afterCreationTime := DateAndTime now rounded.
	"Round up to the next second"
	afterCreationTime := DateAndTime
		date: beforeCreationTime asDate
		time: (Time seconds: afterCreationTime secondsSinceMidnightLocalTime + 1 nanoSeconds: 0).! !

!DiskFileSystemTest commentStamp: ''!
SUnit tests for the disk filesystem!
!DiskFileSystemTest methodsFor: 'tests' stamp: ''!
testIsDirectory
	self assert: (filesystem isDirectory: FileLocator imageDirectory resolve path)! !

!DiskFileSystemTest methodsFor: 'tests' stamp: ''!
testLongFilename
	"Test that long file names (in Win32 terms, i.e. < 260 characters) are working"

	| dir1 dir2 file contents |

	dir1 := FileLocator workingDirectory / (String new: 130 withAll: $a).
	[ self deny: dir1 exists.
	dir1 ensureCreateDirectory.

	dir2 := dir1 / (String new: 130 withAll: $b).
	self deny: dir2 exists.
	dir2 ensureCreateDirectory.

	file := dir2 / 'hello.txt'.
	self deny: file exists.
	contents := 'hello world'.
	file writeStreamDo: [ :stream | stream << contents ].

	self assert: file exists.
	self assert: file contents equals: contents ]
		ensure: [ dir1 ensureDeleteAll ]! !

!DiskFileSystemTest methodsFor: 'initialization' stamp: ''!
createFileSystem
	^ FileSystem store: (DiskStore activeClass createDefault)! !

!DiskFileSystemTest methodsFor: 'tests' stamp: ''!
testIsDiskFileSystem
	self assert: filesystem isDiskFileSystem.! !

!DiskFileSystemTest methodsFor: 'tests' stamp: ''!
testDefaultWorkingDirectory
	| ref |
	ref := filesystem workingDirectory.
	self assert: ('File @ ' , OSPlatform current currentWorkingDirectoryPath beginsWith: ref asString)! !

!DiskFileSystemTest methodsFor: 'tests' stamp: ''!
testEqual
	| other |
	other := self createFileSystem.
	self assert: filesystem equals: other! !

!DiskFileSystemTest methodsFor: 'tests' stamp: ''!
testEntriesHaveAttributes
	"Disk entries returned by FileReference>>entries should be pre-loaded with statAttributes"

	| entries |

	entries := FileLocator imageDirectory resolve entries.
	"Ensure that we are actually checking entries"
	self assert: entries isNotEmpty.
	"We can't use the accessor method to get the statAttributes since does lazy initialization"
	self assert: (entries select: [ :each | (each instVarNamed: 'statAttributes') isNil ]) isEmpty.! !

!DiskFileSystemTest methodsFor: 'tests' stamp: ''!
testMoveMemoryToDisk
	"Test moving a file from the memory filesystem to the disk filesystem.
	This ensures that the copyAndDelete:to: is called correctly."
	| memfs out testString old new |
	[
		memfs := FileSystem memory.
		old := memfs / 'testMoveMemoryToDisk_old'.
		out := old writeStream.
		testString := 'To be moved to disk'.
		[ out nextPutAll: testString ] ensure: [ out close ].
		
		new := FileLocator imageDirectory / 'testMoveMemoryToDisk_new'.
		old moveTo: new.
		
		self deny: (memfs / 'testMoveMemoryToDisk_old') exists.
		self assert: new exists.
		self assert: new contents equals: testString.
	] ensure: [ 
		old ensureDelete.
		new ensureDelete.
	]! !

!DiskStore commentStamp: ''!
I am an abstract superclass for disk store implementations. My subclasses provide access to the actual data storage of a particular kind of filesystem. 
!
!DiskStore methodsFor: 'testing' stamp: ''!
isDiskFileSystem
	^ true! !

!DiskStore methodsFor: 'printing' stamp: ''!
forReferencePrintOn: aStream
	aStream nextPutAll: 'File @ '! !

!DiskStore methodsFor: 'comparing' stamp: ''!
hash
	^ self species hash! !

!DiskStore methodsFor: 'testing' stamp: ''!
isBlock: aPath
	"Answer a boolean indicating whether the supplied path is a Block file"
	^File isBlock: (self stringFromPath: aPath)! !

!DiskStore methodsFor: 'private' stamp: ''!
basicSizeOf: anEntry
	^ (anEntry at: 5)! !

!DiskStore methodsFor: 'private' stamp: ''!
basicEntry: directoryEntry path: aPath nodesDo: aBlock
	| encodedPathString index entry pathString |
		
	index := 1.
	pathString := self stringFromPath: aPath.
	encodedPathString := File encodePathString: pathString.
	entry := File lookupEntryIn: encodedPathString index: index.
	entry = #badDirectoryPath ifTrue: [ ^ self signalDirectoryDoesNotExist: aPath ].
	
	[ entry isNil ]
		whileFalse: [ 
			entry at: 1 put: (File decodePathString: entry first).
			aBlock value: entry.
			index := index + 1.
			entry := File lookupEntryIn: encodedPathString index: index ].! !

!DiskStore methodsFor: 'public' stamp: ''!
asWritableStore

	^ self class writableVariant createDefault! !

!DiskStore methodsFor: 'testing' stamp: ''!
isFile: aPath
	"Answer a boolean indicating whether the supplied path is a file, i.e. not a directory"

	aPath isRoot ifTrue: [ ^false ].
	^File isFile: (self stringFromPath: aPath)! !

!DiskStore methodsFor: 'accessing' stamp: ''!
inodeOf: aPath
	"Return the inode number of the File described by aPath"
	^File fileAttribute: (self stringFromPath: aPath) number: 3! !

!DiskStore methodsFor: 'public' stamp: ''!
exists: aPath

	aPath isRoot ifTrue: [ ^true ].
	^File exists: (self stringFromPath: aPath).! !

!DiskStore methodsFor: 'private' stamp: ''!
basicPosixPermissions: anEntry
	^ (anEntry size >= 6)
		ifTrue: [ anEntry at: 6 ]
		ifFalse: [ nil ].! !

!DiskStore methodsFor: 'private' stamp: ''!
basicIsFile: anEntry
	^ (anEntry at: 4) not! !

!DiskStore methodsFor: 'private' stamp: ''!
basicModificationTimeOf: anEntry
	"The entry contains the seconds since the epoch in local time"
	^ (DateAndTime fromSeconds: (anEntry at: 3) offset: 0) translateTo: DateAndTime localOffset! !

!DiskStore methodsFor: 'public' stamp: ''!
directoryAt: aPath ifAbsent: absentBlock nodesDo: aBlock

	^[ self directoryAt: aPath nodesDo: aBlock ]
		on: DirectoryDoesNotExist, FileDoesNotExistException
		do: [ absentBlock value ].! !

!DiskStore methodsFor: 'public' stamp: ''!
maxFileNameLength
	^ maxFileNameLength! !

!DiskStore methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	maxFileNameLength := Smalltalk vm maxFilenameLength ifNil: [ 255 ].! !

!DiskStore methodsFor: 'accessing' stamp: ''!
uidOf: aPath
	"Return the uid of the File described by aPath"
	^File fileAttribute: (self stringFromPath: aPath) number: 6! !

!DiskStore methodsFor: 'public' stamp: ''!
basicOpen: aPath writable: aBoolean
	| string encoded |
	string := self stringFromPath: aPath.
	encoded := File encodePathString: string.
	^ File open: encoded writable: aBoolean! !

!DiskStore methodsFor: 'public' stamp: ''!
isSymlink: aPath
	"Answer a boolean indicating whether aPath is a symbolic link"

	aPath isRoot ifTrue: [ ^false ].
	^File isSymlink: (self stringFromPath: aPath)! !

!DiskStore methodsFor: 'private' stamp: ''!
directoryAt: aPath nodesDo: aBlock

	| pathString openDir dirPointer entryData fileName attributes targetName |
	
	pathString := File encodePathString: (self stringFromPath: aPath).
	(self isDirectory: aPath) ifFalse:
		[ ^self signalDirectoryDoesNotExist: aPath ].

	openDir := File primOpendir: pathString.
	openDir ifNil: [ ^nil ].
	(openDir isArray and: [openDir size = 3]) ifTrue: [ 
		"New VM (FileAttributesPlugin > 1.4)"
		dirPointer := openDir at: 3.
		entryData := openDir. ]
	ifFalse: [ 
		"Old VM (FileAttributesPlugin <= 1.4.x)"
		dirPointer := openDir.
		entryData := File primReaddir: dirPointer ].
	[
		[ entryData notNil ] whileTrue:
			[
				fileName := entryData first.
				entryData at: 1 put: (File decodePathString: fileName).
				attributes := entryData at: 2.
				attributes ifNotNil: 
					[ targetName := attributes at: 1.
					targetName ifNotNil: [ attributes at: 1 put: (File decodePathString: targetName) ] ].
				aBlock value: entryData.
				entryData := File primReaddir: dirPointer.
			]
	] ensure: [ File primClosedir: dirPointer ].! !

!DiskStore methodsFor: 'public' stamp: ''!
directoryAt: aPath  directoryNodesDo: aBlock
	^ self 
		directoryAt: aPath 
		nodesDo: [ :node |
			(self basicIsDirectory: node) 
				ifTrue: [ aBlock value: node ]].! !

!DiskStore methodsFor: 'public' stamp: ''!
rename: sourcePath to: destinationPath

	| sourcePathString encodedSourcePathString targetPathString encodedTargetPathString |
	sourcePathString := self stringFromPath: sourcePath.
	encodedSourcePathString := File encodePathString: sourcePathString.
	targetPathString := self stringFromPath: destinationPath.
	encodedTargetPathString := File encodePathString: targetPathString.
	^ File rename: encodedSourcePathString to: encodedTargetPathString.! !

!DiskStore methodsFor: 'accessing' stamp: ''!
sizeOf: aPath
	"Return the size of the File described by aPath"
	^File fileAttribute: (self stringFromPath: aPath) number: 8.! !

!DiskStore methodsFor: 'public' stamp: ''!
basicEntryAt: aPath
	| encodedPath encodedBasename |
	
	encodedPath := File encodePathString: (self stringFromPath: aPath parent).
	encodedBasename := File encodePathString: aPath basename.
	
	^ (File lookupDirectory: encodedPath filename: encodedBasename)
		ifNil: [ #badDirectoryPath ].! !

!DiskStore methodsFor: 'testing' stamp: ''!
isRegular: aPath
	"Answer a boolean indicating whether the supplied path is a Regular file"
	^File isRegular: (self stringFromPath: aPath)! !

!DiskStore methodsFor: 'public' stamp: ''!
delete: path
	| pathString |

	((self exists: path) or: [ self isSymlink: path ])
		ifFalse: [ ^ FileDoesNotExistException signalWith: path ].

	pathString := self stringFromPath: path.

	(self isDirectory: path) ifTrue: 
		[ File deleteDirectory: (File encodePathString: pathString) ]
	ifFalse: 
		[ File deleteFile: pathString ]! !

!DiskStore methodsFor: 'testing' stamp: ''!
isSocket: aPath
	"Answer a boolean indicating whether the supplied path is a Socket file"
	^File isSocket: (self stringFromPath: aPath)! !

!DiskStore methodsFor: 'accessing' stamp: ''!
handleClass
	^ FileHandle! !

!DiskStore methodsFor: 'private' stamp: ''!
basicCreationTimeOf: anEntry
	"The entry contains the seconds since the epoch in local time"

	^ (DateAndTime fromSeconds: (anEntry at: 2) offset: 0) translateTo: DateAndTime localOffset! !

!DiskStore methodsFor: 'testing' stamp: ''!
isFIFO: aPath
	"Answer a boolean indicating whether the supplied path is a FIFO file (pipe)"
	^File isFIFO: (self stringFromPath: aPath)! !

!DiskStore methodsFor: 'testing' stamp: ''!
isWritable: aPath

	^File isWritable: (self stringFromPath: aPath)! !

!DiskStore methodsFor: 'testing' stamp: ''!
isCharacter: aPath
	"Answer a boolean indicating whether the supplied path is a Character file"
	^File isCharacter: (self stringFromPath: aPath)! !

!DiskStore methodsFor: 'testing' stamp: ''!
isExecutable: aPath
	"Answer a boolean indicating whether the supplied path is executable"

	^File isExecutable: (self stringFromPath: aPath)! !

!DiskStore methodsFor: 'public' stamp: ''!
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: 'comparing' stamp: ''!
= other
	^ self species = other species! !

!DiskStore methodsFor: 'public' stamp: ''!
entryFromNode: node path: path for: aFileSystem

	| entryPath |
	entryPath := path / (self basenameFromEntry: node).
	^DiskDirectoryEntry 
		reference: (FileReference fileSystem: aFileSystem path: entryPath)
		statAttributes: (node at: 2).! !

!DiskStore methodsFor: 'accessing' stamp: ''!
modificationTimeOf: aPath
	"Return the date of last modification of the File described by aPath"

	^DateAndTime fromInternalTime: (File fileAttribute: (self stringFromPath: aPath) number: 10)! !

!DiskStore methodsFor: 'private' stamp: ''!
nodeAt: aPath ifPresent: presentBlock ifAbsent: absentBlock
	"FileSystemStore provides a general implementation of the attributes originally supported by FilePlugin.  This assumes always retrieving a set of attributes and accessing the required attribute.  However this is expensive for the disk system (one or more Arrays has to be instantiated and garbage collected for a single attribute).  FileAttributesPlugin allows file attributes to be retrieved one at a time, so this method should never be used for DiskStore"

	^self shouldNotImplement! !

!DiskStore methodsFor: 'accessing' stamp: ''!
isDirectory: aPath
	"Answer a boolean indicating whether the supplied path is a Directory file"
	^aPath isRoot or: [File isDirectory: (self stringFromPath: aPath)]! !

!DiskStore methodsFor: 'accessing' stamp: ''!
gidOf: aPath
	"Return the gid of the File described by aPath"
	^File fileAttribute: (self stringFromPath: aPath) number: 7! !

!DiskStore methodsFor: 'private' stamp: ''!
rootEntry
	"Answer a pseudo Directory Entry for the root directory"

	^(DiskDirectoryEntry
		reference: (FileReference fileSystem: FileSystem disk path: Path root)
		statAttributes: #(nil 8r40775 0 0 0 0 0 0 0 0 nil 0 22))
			accessAttributes: #(true false true);
			yourself! !

!DiskStore methodsFor: 'accessing' stamp: ''!
changeTimeOf: aPath
	"Answer the time the metadata of aPath was last changed.
	On platforms that don't support change time, use the modification time."

	| pathString time |
	pathString := self stringFromPath: aPath.
	time := (File fileAttribute: pathString number: 11) ifNil: 
			[ File fileAttribute: pathString number: 12 ].
	^DateAndTime fromInternalTime: time! !

!DiskStore methodsFor: 'private' stamp: ''!
basicIsDirectory: aNode
	| mask statAttributes |

	statAttributes := aNode at: 2.
	statAttributes ifNil: [ ^false ].
	mask := statAttributes at: 2.
	^(mask bitAnd: File s_IFMT) = File s_IFDIR! !

!DiskStore methodsFor: 'accessing' stamp: ''!
numberOfHardLinks: aPath
	"Return the number of hard links for the File described by aPath"
	^File fileAttribute: (self stringFromPath: aPath) number: 5! !

!DiskStore methodsFor: 'private' stamp: ''!
rootNode
	^ #('' 0 0 true 0 8r555)! !

!DiskStore methodsFor: 'accessing' stamp: ''!
defaultWorkingDirectory
	"Answer the default working directory, which is defined as the directory where the image resides."

	^ DefaultWorkingDirectory
		ifNil: [ self class defaultWorkingDirectory ]! !

!DiskStore methodsFor: 'accessing' stamp: ''!
deviceIdOf: aPath
	"Return the device id of the file at aPath"
	^File fileAttribute: (self stringFromPath: aPath) number: 4! !

!DiskStore methodsFor: 'public' stamp: ''!
file: path symlinkUid: uidInteger gid: gidInteger
	"Set the owner and group of path by numeric id."

	^File file: (self stringFromPath: path) symlinkUid: uidInteger gid: gidInteger! !

!DiskStore methodsFor: 'testing' stamp: ''!
isReadable: aPath

	^File isReadable: (self stringFromPath: aPath)! !

!DiskStore methodsFor: 'accessing' stamp: ''!
permissions: aPath
	"Answer the FileSystemPermissions for the supplied path"

	^FileSystemPermission posixPermissions: (File posixPermissions: (self stringFromPath: aPath))! !

!DiskStore methodsFor: 'private' stamp: ''!
basenameFromEntry: entry
	^ entry at: 1! !

!DiskStore methodsFor: 'public' stamp: ''!
file: path posixPermissions: anInteger
	"Set the mode of pathString to anInteger (as defined by chmod())"

	^File file:(self stringFromPath: path) posixPermissions: anInteger! !

!DiskStore methodsFor: 'public' stamp: ''!
file: path uid: uidInteger gid: gidInteger
	"Set the owner and group of path by numeric id."

	^File file: (self stringFromPath: path) uid: uidInteger gid: gidInteger! !

!DiskStore methodsFor: 'public' stamp: ''!
directoryAt: aPath fileNodesDo: aBlock
	^ self 
		directoryAt: aPath 
		nodesDo: [ :node |
			(self basicIsDirectory: node) 
				ifFalse: [ aBlock value: node ]].! !

!DiskStore methodsFor: 'public' stamp: ''!
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 := File encodePathString: pathString.
	result := File 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: 'accessing' stamp: ''!
creationTimeOf: aPath
	"Answer the creation time of aPath.  If the platform doesn't support creation time, use change time"
	
	| pathString time |
	pathString := self stringFromPath: aPath.
	time := (File fileAttribute: pathString number: 12) ifNil: [ File fileAttribute: pathString number: 11 ].
	^DateAndTime fromInternalTime: time! !

!DiskStore methodsFor: 'public' stamp: ''!
asReadOnlyStore

	^ self class readOnlyVariant createDefault! !

!DiskStore methodsFor: 'accessing' stamp: ''!
accessTimeOf: aPath
	"Return the date of last access of the File described by aPath"

	^DateAndTime fromInternalTime: (File fileAttribute: (self stringFromPath: aPath) number: 9)! !

!DiskStore methodsFor: 'testing' stamp: ''!
isWritable

	^ true! !

!DiskStore class methodsFor: 'public' stamp: ''!
writableVariant

	"return a class variant for read-only store. It should be properly defined in my subclasses"

	^ self! !

!DiskStore class methodsFor: 'public' stamp: ''!
maxFileNameLength
	self subclassResponsibility! !

!DiskStore class methodsFor: 'system startup' stamp: ''!
shutDown: quitting
	"Force to detect filesystem after image restart"
	self reset! !

!DiskStore class methodsFor: 'current' stamp: ''!
current
	^ self currentFileSystem store! !

!DiskStore class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default
		registerSystemClassNamed: self name! !

!DiskStore class methodsFor: 'current' stamp: ''!
resetAsWritable

	self currentFileSystem beWritable! !

!DiskStore class methodsFor: 'public' stamp: ''!
delimiter
	^ self current delimiter! !

!DiskStore class methodsFor: 'current' stamp: ''!
activeClass

	| writableClass |
	
	writableClass := self allSubclasses detect: [:each | 
		each isActiveClass ] ifNone: [ ^ self ].
	
	^ SessionManager default currentSession isReadOnlyAccessMode
		ifFalse: [ writableClass ]
		ifTrue: [ writableClass readOnlyVariant ].! !

!DiskStore class methodsFor: 'current' stamp: ''!
currentFileSystem
	^ CurrentFS ifNil: [
		CurrentFS := FileSystem store: self activeClass createDefault]! !

!DiskStore class methodsFor: 'current' stamp: ''!
resetAsReadOnly

	self currentFileSystem beReadOnly! !

!DiskStore class methodsFor: 'system startup' stamp: ''!
checkVMVersion
	"Display a warning if the VM is too old"
	| displayError |
	displayError := [ ^ self inform: 'Your VM is too old for this image. Please download the latest VM.' ].
	[(Smalltalk vm interpreterSourceDate >= '2019-01-05' asDate)
		ifFalse: displayError
	] on: Error do: [ :e| displayError value ].! !

!DiskStore class methodsFor: 'current' stamp: ''!
createDefault
	^ self new! !

!DiskStore class methodsFor: 'system startup' stamp: ''!
startUp: resuming
	self checkVMVersion.
	resuming 
		ifTrue: [ self reset ].
	DefaultWorkingDirectory := self defaultWorkingDirectory.! !

!DiskStore class methodsFor: 'current' stamp: ''!
isActiveClass
	^ self delimiter = File delimiter! !

!DiskStore class methodsFor: 'class initialization' stamp: ''!
reset
	DefaultWorkingDirectory := nil.
	CurrentFS := nil! !

!DiskStore class methodsFor: 'public' stamp: ''!
readOnlyVariant

	"return a class variant for read-only store. It should be properly defined in my subclasses"

	^ self subclassResponsibility! !

!DiskStore class methodsFor: 'accessing' stamp: ''!
defaultWorkingDirectory
	"Ask the VM for the default working directory.
	Clients should normally use the instance side method which caches this value."
	| pathString |

	pathString := OSPlatform current currentWorkingDirectoryPath.
	^(Path from: pathString delimiter: self delimiter).! !

!DiskSymlinkDirectoryEntry commentStamp: ''!
DiskSymlinkDirectoryEntry provides the same information as DiskDirectoryEntry, but for the symbolic link (and not the target file).

See DiskDirectoryEntry for more information.!
!DiskSymlinkDirectoryEntry methodsFor: 'accessing' stamp: ''!
targetPath
	"Answer the Path pointing to the real file.
	If the receiver is a symbolic link, answer a file reference of the target.
	If not, answer the receivers file"

	| fileString |
	fileString := self statAttributes first.
	^fileString
		ifNil: [ reference path ]
		ifNotNil: [ fileString asPath ].! !

!DiskSymlinkDirectoryEntry methodsFor: 'private - accessing' stamp: ''!
statAttributeMask
	"Answer the mask used to retrieve lstat() attributes"

	^2r101! !

!DisplayMedium commentStamp: ''!
I am a display object which can both paint myself on a medium (displayOn: messages), and can act as a medium myself. My chief subclass is Form.!
!DisplayMedium methodsFor: 'coloring' stamp: ''!
reverse
	"Change all the bits in the receiver that are white to black, and the ones 
	that are black to white."

"
Display reverse: (10@10 extent: 100@100)
"

	self fill: self boundingBox rule: Form reverse fillColor: (self quickHighLight: self depth)! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
fillBlack: aRectangle 
	"Set all bits in the receiver's area defined by aRectangle to black (ones)."

	self fill: aRectangle rule: Form over fillColor: Color black! !

!DisplayMedium methodsFor: 'bordering' stamp: ''!
border: aRectangle margins: 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: (insets insetRectangle: aRectangle )) do:
		[:edgeStrip | self fill: edgeStrip rule: combinationRule fillColor: aHalfTone]! !

!DisplayMedium methodsFor: 'bordering' stamp: ''!
border: aRectangle width: borderWidth rule: combinationRule fillColor: aHalfTone 
	"Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses aHalfTone for drawing the border."

	self border: aRectangle
		margins: 
			(Margin
				left: borderWidth
				right: borderWidth
				top: borderWidth
				bottom: borderWidth)
		rule: combinationRule
		fillColor: aHalfTone! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
fillGray
	"Set all bits in the receiver to gray."

	self fill: self boundingBox fillColor: Color gray! !

!DisplayMedium methodsFor: 'private' stamp: ''!
quickHighLight: aDepth
	^ self highLightBitmaps at: aDepth! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
reverse: aRectangle
	"Change all the bits in the receiver's area that intersects with aRectangle 
	that are white to black, and the ones that are black to white."

	self fill: aRectangle rule: Form reverse fillColor: (self quickHighLight: self depth)! !

!DisplayMedium methodsFor: 'private' stamp: ''!
initializeHighLights 
	
	"Create a set of Bitmaps for quickly reversing areas of the screen without converting colors. "
	
	HighLightBitmaps := Array new: 32.
	^HighLightBitmaps
		at: 1 put: (Bitmap with: 4294967295);
		at: 2 put: (Bitmap with: 4294967295);
		at: 4 put: (Bitmap with: 1431655765);
		at: 8 put: (Bitmap with: 117901063);
		at: 16 put: (Bitmap with: 4294967295);
		at: 32 put: (Bitmap with: 4294967295);
		yourself.! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
fillShape: aShapeForm fillColor: aColor at: location
	"Fill a region corresponding to 1 bits in aShapeForm with aColor"

	((BitBlt destForm: self sourceForm: aShapeForm fillColor: aColor
		combinationRule: Form paint
		destOrigin: location + aShapeForm offset sourceOrigin: 0@0
		extent: self extent clipRect: self boundingBox)
		colorMap: (Bitmap with: 0 with: 16rFFFFFFFF))
		copyBits! !

!DisplayMedium methodsFor: 'displaying' stamp: ''!
drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Draw line by copying the argument, sourceForm, starting at location 
	beginPoint and ending at endPoint, clipped by the rectangle, clipRect. 
	The rule and mask for copying are the arguments anInteger and aForm."

	self subclassResponsibility! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
fillWhite: aRectangle
	"Set all bits in the receiver's area defined by aRectangle to white."

	self fill: aRectangle rule: Form over fillColor: Color white.! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
fillWithColor: aColor
	"Fill the receiver's bounding box with the given color."

	self fill: self boundingBox fillColor: aColor.! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
fillShape: aShapeForm fillColor: aColor
	"Fill a region corresponding to 1 bits in aShapeForm with aColor"

	^ self fillShape: aShapeForm fillColor: aColor at: 0@0! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
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' stamp: ''!
fill: aRectangle fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by 
	aForm according to the rule over."

	self fill: aRectangle rule: Form over fillColor: aForm! !

!DisplayMedium methodsFor: '*Morphic-Core' stamp: ''!
border: aRectangle width: borderWidth 
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of the border of each side is borderWidth. Uses theme borderColor for 
	drawing the border."

	self 
		border: aRectangle 
		width: borderWidth 
		fillColor: Smalltalk ui theme borderColor.! !

!DisplayMedium methodsFor: 'displaying' stamp: ''!
deferUpdatesIn: aRectangle while: aBlock
	"DisplayScreen overrides with something more involved..."
	^aBlock value! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
fillBlack
	"Set all bits in the receiver to black (ones)."

	self fill: self boundingBox fillColor: Color black! !

!DisplayMedium methodsFor: 'bordering' stamp: ''!
border: aRectangle width: borderWidth fillColor: aHalfTone 
	"Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses aHalfTone for drawing the border."

	self border: aRectangle
		width: borderWidth
		rule: Form over
		fillColor: aHalfTone! !

!DisplayMedium methodsFor: 'displaying' stamp: ''!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm 
	"Make up a BitBlt table and copy the bits."

	self subclassResponsibility! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
fillWhite
	"Set all bits in the form to white."

	self fill: self boundingBox fillColor: Color white.! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
fill: aRectangle rule: anInteger fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by 
	aForm according to the rule anInteger."

	self subclassResponsibility! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
fillColor: aColor
	"Set all pixels in the receiver to the color.  Must be a correct color for this depth of medium.  TK 1 Jun 96"

	self fill: self boundingBox fillColor: aColor! !

!DisplayMedium methodsFor: 'private' stamp: ''!
highLightBitmaps
	"Quickly return a Bitblt-ready raw colorValue for highlighting areas."
	^HighLightBitmaps ifNil: [self initializeHighLights ].! !

!DisplayMedium methodsFor: 'coloring' stamp: ''!
reverse: aRectangle fillColor: aMask	
	"Change all the bits in the receiver's area that intersects with aRectangle 
	according to the mask. Black does not necessarily turn to white, rather it 
	changes with respect to the rule and the bit in a corresponding mask 
	location. Bound to give a surprise."

	self fill: aRectangle rule: Form reverse fillColor: aMask! !

!DisplayObject commentStamp: ''!
The abstract protocol for most display primitives that are used by Views for presenting information on the screen.!
!DisplayObject methodsFor: 'accessing - display box' stamp: ''!
center

	^ self boundingBox center! !

!DisplayObject methodsFor: 'displaying - generic' stamp: ''!
displayOn: aDisplayMedium at: aDisplayPoint rule: ruleInteger
	"Display the receiver located at aPoint with default setting for the 
	halftone and clippingBox."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: aDisplayMedium boundingBox
		rule: ruleInteger
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying - generic' stamp: ''!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle 
	"Display the receiver located at aDisplayPoint with default settings for 
	rule and halftone. Information to be displayed must be confined to the 
	area that intersects with clipRectangle."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: clipRectangle
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying - display' stamp: ''!
display 
	"Display the receiver on the Display at location 0,0."

	self displayOn: Display! !

!DisplayObject methodsFor: 'displaying - generic' stamp: ''!
displayOn: aDisplayMedium at: aDisplayPoint 
	"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: 'transforming' stamp: ''!
translateBy: aPoint 
	"Translate the receiver's offset."

	self offset: (self offset translateBy: aPoint)! !

!DisplayObject methodsFor: 'displaying - generic' stamp: ''!
displayOn: aDisplayMedium
	"Simple default display in order to see the receiver in the upper left 
	corner of screen."

	self displayOn: aDisplayMedium at: 0 @ 0! !

!DisplayObject methodsFor: 'transforming' stamp: ''!
align: alignmentPoint with: relativePoint 
	"Translate the receiver's offset such that alignmentPoint aligns with 
	relativePoint."

	self offset: (self offset translateBy: relativePoint - alignmentPoint)! !

!DisplayObject methodsFor: 'displaying - display' stamp: ''!
isTransparent
	^ false! !

!DisplayObject methodsFor: 'accessing' stamp: ''!
offset
	"Answer the amount by which the receiver should be offset when it is 
	displayed or its position is tested."

	self subclassResponsibility! !

!DisplayObject methodsFor: 'displaying - generic' stamp: ''!
displayOnPort: port at: location rule: rule

	port copyForm: self to: location rule: rule.! !

!DisplayObject methodsFor: 'accessing - display box' stamp: ''!
computeBoundingBox
	"Answer the rectangular area that represents the boundaries of the 
	receiver's area for displaying information. This is the primitive for 
	computing the area if it is not already known."

	self subclassResponsibility! !

!DisplayObject methodsFor: 'displaying - generic' stamp: ''!
displayAt: aDisplayPoint 
	"Display the receiver located at aDisplayPoint with default settings for 
	the displayMedium, rule and halftone."

	self displayOn: Display
		at: aDisplayPoint
		clippingBox: Display boundingBox
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'accessing - display box' stamp: ''!
boundingBox
	"Answer the rectangular area that represents the boundaries of the 
	receiver's space of information."

	^self computeBoundingBox! !

!DisplayObject methodsFor: 'displaying - display' stamp: ''!
slideFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs
	"Slide this object across the display over the given number of steps, pausing for the given number of milliseconds after each step."
	"Note: Does not display at the first point, but does at the last."

	| i p delta |
	i := 0.
	p := startPoint.
	delta := (stopPoint - startPoint) / nSteps asFloat.
	^ self
		follow: [
			p := p + delta.
			p truncated]
		while: [
			(Delay forMilliseconds: milliSecs) wait.
			(i := i + 1) < nSteps]! !

!DisplayObject methodsFor: 'transforming' stamp: ''!
scaleBy: aPoint 
	"Scale the receiver's offset by aPoint."

	self offset: (self offset scaleBy: aPoint)! !

!DisplayObject methodsFor: 'accessing - display box' stamp: ''!
initialExtent
	"Included here for when a FormView is being opened
	as a window.  (4@4) covers border widths."

	^ self extent + (4@4)! !

!DisplayObject methodsFor: 'accessing' stamp: ''!
width
	"Answer the number that represents the width of the receiver's bounding 
	box."

	^self boundingBox width! !

!DisplayObject methodsFor: 'accessing' stamp: ''!
offset: aPoint 
	"Set the amount by which the receiver's position is offset."

	^self! !

!DisplayObject methodsFor: 'displaying - display' stamp: ''!
follow: locationBlock while: durationBlock bitsBehind: initialBitsBehind startingLoc: loc
   "Move an image around on the Display. Restore the background continuously without causing flashing. The argument, locationBlock, supplies each new location, and the argument, durationBlock, supplies true to continue or false to stop. This variant takes the bitsBehind as an input argument, and returns the final saved saved bits as method value."

   | location rect1 save1 save1Blt buffer bufferBlt newLoc rect2 bothRects |
   location := loc.
   rect1 := location extent: self extent.
   save1 := initialBitsBehind.
   save1Blt := BitBlt toForm: save1.
   buffer := Form extent: self extent*2 depth: Display depth.  "Holds overlapping region"
   bufferBlt := BitBlt toForm: buffer.

   Display deferUpdates: true.
   self displayOn: Display at: location rule: Form paint.
   Display deferUpdates: false.

   [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]
				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].
			location := newLoc.
			rect1 := rect2]].

	^ save1 displayOn: Display at: location! !

!DisplayObject methodsFor: 'truncation and round off' stamp: ''!
rounded
	"Convert the offset of the receiver to integer coordinates."

	self offset: self offset rounded! !

!DisplayObject methodsFor: 'accessing' stamp: ''!
extent
	"Answer the point that represents the width and height of the receiver's 
	bounding box."

	^self boundingBox extent! !

!DisplayObject methodsFor: 'displaying - generic' stamp: ''!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"This is the basic display primitive for graphic display objects. Display 
	the receiver located at aDisplayPoint with rule, ruleInteger, and mask, 
	aForm. Information to be displayed must be confined to the area that 
	intersects with clipRectangle."

	self subclassResponsibility! !

!DisplayObject methodsFor: 'accessing' stamp: ''!
height
	"Answer the number that represents the height of the receiver's 
	bounding box."

	^self boundingBox height! !

!DisplayObject methodsFor: 'displaying - display' stamp: ''!
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 - display' stamp: ''!
follow: locationBlock while: durationBlock
   "Move an image around on the Display. Restore the background
   continuously without causing flashing. The argument, locationBlock,
   supplies each new location, and the argument, durationBlock, supplies
   true to continue, and then false to stop."
 
   | bitsBehind loc |
	loc := locationBlock value.
   bitsBehind := Form fromDisplay: (loc extent: self extent).
   ^ self follow: locationBlock while: durationBlock bitsBehind: bitsBehind startingLoc: loc! !

!DisplayObject methodsFor: 'accessing' stamp: ''!
relativeRectangle
	"Answer a Rectangle whose top left corner is the receiver's offset position 
	and whose width and height are the same as the receiver."

	^Rectangle origin: self offset extent: self extent! !

!DisplayScanner commentStamp: ''!
A DisplayScanner is an abstract class for displaying characters.
It is splitting text into elementary chunks of displayable String/Font pairs (see scanning protocol).
Subclasses responsibility is to handle the effective rendering of these chunks on various backends.

Instance Variables
	backgroundColor:		<Color>
	defaultTextColor:		<Color>
	foregroundColor:		<Color>
	ignoreColorChanges:		<Boolean>
	lastDisplayableIndex:		<Integer>
	lineY:		<Number>
	morphicOffset:		<Point>
	stopConditionsMustBeReset:		<Boolean>

backgroundColor
	- the background color for displaying next chunk of text.
	Note that this can be set to Color transparent, in which case no background is displayed.

defaultTextColor
	- the default foreground color for displaying text in absence of other text attributes specification 

foregroundColor
	- the foreground color for displaying next chunk of text

ignoreColorChanges
	- indicates that any change of color specified in text attributes shall be ignored.
	This is used for displaying text in a shadow mode, when dragging text for example.

lastDisplayableIndex
	- the index of last character to be displayed.
	A different index than lastIndex is required in order to avoid display of control characters.
	This variable must be updated by the stop condition at each inner scan loop.

lineY
	- the distance between destination form top and current line top

morphicOffset
	- an offset for positionning the embedded morphs.
	THE EXACT SPECIFICATION YET REMAINS TO BE WRITTEN

stopConditionsMustBeReset
	- indicates that it's necessary to call setStopConditions in next scan loop.

Notes:
In order to correctly set the lastDisplayableIndex, the display scanner performs the stopCondition BEFORE displaying the string being scanned.
This explains why the stopCondition must not reset the font immediately, but differ this reset AFTER the display, thanks to stopConditionsMustBeReset.
!
!DisplayScanner methodsFor: 'displaying' stamp: ''!
displayEmbeddedForm: aForm
	self subclassResponsibility! !

!DisplayScanner methodsFor: 'stop conditions' stamp: ''!
paddedSpace
	"Each space is a stop condition when the alignment is right justified. 
	Padding must be added to the base width of the space according to 
	which space in the line this space is and according to the amount of 
	space that remained at the end of the line when it was composed."

	lastDisplayableIndex := lastIndex - 1.
	spaceCount := spaceCount + 1.
	destX := destX + spaceWidth + kern + (line justifiedPadFor: spaceCount font: font).
	lastIndex := lastIndex + 1.
	pendingKernX := 0.
	^ false! !

!DisplayScanner methodsFor: 'displaying' stamp: ''!
displayString: string from: startIndex  to: stopIndex at: aPoint
	self subclassResponsibility! !

!DisplayScanner methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	ignoreColorChanges := false.! !

!DisplayScanner methodsFor: 'displaying' stamp: ''!
fillTextBackground
	self subclassResponsibility! !

!DisplayScanner methodsFor: 'private' stamp: ''!
placeEmbeddedObject: anchoredMorphOrForm

	anchoredMorphOrForm relativeTextAnchorPosition ifNotNil:[:relativeTextAnchorPosition |
		anchoredMorphOrForm position: 
			relativeTextAnchorPosition +
			(anchoredMorphOrForm owner textBounds origin x @ (lineY - morphicOffset y)).
		^true
	].
	anchoredMorphOrForm isMorph ifTrue: [
		anchoredMorphOrForm position: (destX@(lineY + line baseline - anchoredMorphOrForm height)) - morphicOffset
	] ifFalse: [
		self displayEmbeddedForm: anchoredMorphOrForm
	].
	destX := destX + anchoredMorphOrForm width + kern.
	^ true! !

!DisplayScanner methodsFor: 'text attributes' stamp: ''!
textColor: textColor
	ignoreColorChanges ifTrue: [^ self].
	foregroundColor := textColor! !

!DisplayScanner methodsFor: 'private' stamp: ''!
text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode
	text := t.
	textStyle := ts. 
	foregroundColor := defaultTextColor := foreColor.
	backgroundColor := backColor.
	ignoreColorChanges := shadowMode! !

!DisplayScanner methodsFor: 'private' stamp: ''!
setStopConditions
	super setStopConditions.
	stopConditionsMustBeReset := false! !

!DisplayScanner methodsFor: 'stop conditions' stamp: ''!
endOfRun
	"The end of a run in the display case either means that there is actually 
	a change in the style (run code) to be associated with the string or the 
	end of this line has been reached."
	| runLength |
	lastDisplayableIndex := lastIndex.
	lastIndex = line last ifTrue: [^true].
	runLength := text runLengthFor: (lastIndex := lastIndex + 1).
	runStopIndex := lastIndex + (runLength - 1) min: line last.
	"differ reset of stopConditions and font AFTER the dispaly of last scanned string"
	stopConditionsMustBeReset := true.
	^ false! !

!DisplayScanner methodsFor: 'scanning' stamp: ''!
displayLine: textLine offset: offset leftInRun: leftInRun
	"The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated).  leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions."

	| stopCondition nowLeftInRun startIndex string lastPos lineHeight stop |
	line := textLine.
	morphicOffset := offset.
	lineY := line top + offset y.
	lineHeight := line lineHeight.
	rightMargin := line rightMargin + offset x.
	lastIndex := line first.
	leftInRun <= 0 ifTrue: [ self setStopConditions ].
	leftMargin := (line leftMarginForAlignment: alignment) + offset x.
	destX := leftMargin.
	self fillTextBackground.
	lastDisplayableIndex := lastIndex := line first.
	nowLeftInRun := leftInRun <= 0
		ifTrue: [ text runLengthFor: lastIndex ]
		ifFalse: [ leftInRun ].
	destY := lineY + line baseline - font ascent.
	runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last.
	spaceCount := 0.
	string := text string.
	[ "reset the stopping conditions of this displaying loop, and also the font."
	stopConditionsMustBeReset ifTrue: [ self setStopConditions ].

	"remember where this portion of the line starts"
	startIndex := lastIndex.
	lastPos := destX @ destY.

	"find the end of this portion of the line"
	stopCondition := self
		scanCharactersFrom: lastIndex
		to: runStopIndex
		in: string
		rightX: rightMargin.
	"handle the stop condition - this will also set lastDisplayableIndex"
	stop := self perform: stopCondition.

	"display that portion of the line"
	lastDisplayableIndex >= startIndex
		ifTrue: [ self
				displayString: string
				from: startIndex
				to: lastDisplayableIndex
				at: lastPos ].

	"if the stop condition were true, stop the loop"
	stop ] whileFalse.
	^ runStopIndex - lastIndex	"Number of characters remaining in the current run"! !

!DisplayScanner methodsFor: 'stop conditions' stamp: ''!
tab
	lastDisplayableIndex := lastIndex - 1.
	destX := self plainTab.
	lastIndex := lastIndex + 1.
	^ false! !

!DisplayScanner methodsFor: 'private' stamp: ''!
defaultTextColor
	^ defaultTextColor ifNil:[ defaultTextColor := Smalltalk ui theme textColor ]! !

!DisplayScanner methodsFor: 'private' stamp: ''!
defaultTextColor: color
	defaultTextColor := color.! !

!DisplayScanner methodsFor: 'private' stamp: ''!
setFont 
	foregroundColor := self defaultTextColor.
	super setFont.  "Sets font and emphasis bits, and maybe foregroundColor"
	text ifNotNil:[destY := lineY + line baseline - font ascent]! !

!DisplayScanner methodsFor: 'stop conditions' stamp: ''!
crossedX
	"This condition will sometimes be reached 'legally' during display, when, 
	for instance the space that caused the line to wrap actually extends over 
	the right boundary. This character is allowed to display, even though it 
	is technically outside or straddling the clipping rectangle since it is in 
	the normal case not visible and is in any case appropriately clipped by 
	the scanner."

	self advanceIfFirstCharOfLine.
	lastDisplayableIndex := lastIndex - 1.
	^ true ! !

!DisplayScanner methodsFor: 'stop conditions' stamp: ''!
cr
	"When a carriage return is encountered, simply increment the pointer 
	into the paragraph."

	pendingKernX := 0.
	lastDisplayableIndex := lastIndex - 1.
	(lastIndex < text size and: [(text at: lastIndex) = CR and: [(text at: lastIndex+1) = Character lf]])
		ifTrue: [lastIndex := lastIndex + 2]
		ifFalse: [lastIndex := lastIndex + 1].
	^false! !

!DisplayScanner class methodsFor: 'instance creation' stamp: ''!
new
	"Use default concrete class"
	^(self == DisplayScanner
		ifTrue: [BitBltDisplayScanner]
		ifFalse: [self]) basicNew initialize! !

!DisplayScanner class methodsFor: 'queries' stamp: ''!
defaultFont
	^ TextStyle defaultFont! !

!DisplayScreen commentStamp: ''!
There is only one instance of me, Display. It is a global and is used to handle general user requests to deal with the whole display screen. 
	Although I offer no protocol, my name provides a way to distinguish this special instance from all other Forms. This is useful, for example, in dealing with saving and restoring the system.
	To change the depth of your Display...
		Display newDepth: 16.
		Display newDepth: 8.
		Display newDepth: 1.
Valid display depths are 1, 2, 4, 8, 16 and 32.  It is suggested that you run with your monitors setting the same, for better speed and color fidelity.  Note that this can add up to 4Mb for the Display form.  Finally, note that newDepth: ends by executing a 'ControlManager restore' which currently terminates the active process, so nothing that follows in the doit will get executed.

Depths 1, 2, 4 and 8 bits go through a color map to put color on the screen, but 16 and 32-bit color use the pixel values directly for RGB color (5 and 8 bits per, respectivlely).  The color choice an be observed by executing Color fromUser in whatever depth you are using.
!
!DisplayScreen methodsFor: 'other' stamp: ''!
restore
	
	UIManager default restoreDisplay! !

!DisplayScreen methodsFor: 'testing' stamp: ''!
isDisplayScreen
	^true! !

!DisplayScreen methodsFor: 'displaying' stamp: ''!
flash: aRectangle andWait: msecs
	"Flash the area of the screen defined by the given rectangle."

	self reverse: aRectangle.

	(Delay forMilliseconds: msecs) wait.
	self reverse: aRectangle.

	(Delay forMilliseconds: msecs) wait.! !

!DisplayScreen methodsFor: 'displaying' stamp: ''!
flash: aRectangle 
	"Flash the area of the screen defined by the given rectangle."

	self reverse: aRectangle.
	(Delay forMilliseconds: 100) wait.
	self reverse: aRectangle.! !

!DisplayScreen methodsFor: 'other' stamp: ''!
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: ''!
displayChangeSignature

	^DisplayChangeSignature! !

!DisplayScreen methodsFor: 'private' stamp: ''!
findAnyDisplayDepthIfNone: aBlock
	"Return any display depth that is supported on this system.
	If there is none, evaluate aBlock.
	First check higher values to avoid depth 1 to be always returned."
	^ #(32 16 8 4 2 1 -32 -16 -8 -4 -2 -1) 
		detect:[ :bpp| self supportsDisplayDepth: bpp ]
		ifNone: [ aBlock value ]! !

!DisplayScreen methodsFor: 'screen managing' stamp: ''!
toggleFullscreen
	self fullscreen: self isFullscreen not! !

!DisplayScreen methodsFor: 'other' stamp: ''!
supportsDisplayDepth: pixelDepth
	"Return true if this pixel depth is supported on the current host platform.
	Primitive. Optional."
	<primitive: 91>
	^#(1 2 4 8 16 32) includes: pixelDepth! !

!DisplayScreen methodsFor: 'other' stamp: ''!
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: ''!
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: 'screen managing' stamp: ''!
fullscreenOff

	self fullscreen: false! !

!DisplayScreen methodsFor: 'other' stamp: ''!
restoreAfter: aBlock
	"Evaluate the block, wait for a mouse click, and then restore the screen."

	UIManager default restoreDisplayAfter: aBlock! !

!DisplayScreen methodsFor: 'deferring' stamp: ''!
deferUpdates: aBoolean
	^self class deferUpdates: aBoolean! !

!DisplayScreen methodsFor: 'deferring' stamp: ''!
deferUpdatesIn: aRectangle while: aBlock
	| result |
	(self class deferUpdates: true) ifTrue: [^aBlock value].
	result := aBlock value.
	self class deferUpdates: false.
	^result! !

!DisplayScreen methodsFor: '*Morphic-Core' stamp: ''!
boundingBox

	self currentWorld ifNil: [ ^ 0@0 corner: 0@0 ].
	^ self currentWorld bounds! !

!DisplayScreen methodsFor: 'other' stamp: ''!
width
	^ self boundingBox width! !

!DisplayScreen methodsFor: 'private' stamp: ''!
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 ] ]) 
		ifTrue: [ ^ self ].
	
	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 ] ]! !

!DisplayScreen methodsFor: 'screen managing' stamp: ''!
lastScreenModeSelected
	^ LastScreenModeSelected
		ifNil: [LastScreenModeSelected := false]! !

!DisplayScreen methodsFor: 'other' stamp: ''!
fullBoundingBox
	^ super boundingBox! !

!DisplayScreen methodsFor: 'screen managing' stamp: ''!
isFullscreen
	^ self lastScreenModeSelected.! !

!DisplayScreen methodsFor: 'private' stamp: ''!
newDepthNoRestore: pixelSize
	
	UIManager default newDisplayDepthNoRestore: pixelSize! !

!DisplayScreen methodsFor: 'other' stamp: ''!
usableArea
	"Answer the usable area of the receiver."

	^ self boundingBox deepCopy! !

!DisplayScreen methodsFor: 'displaying' stamp: ''!
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: 'screen managing' stamp: ''!
fullscreen: aBoolean

	SystemAnnouncer uniqueInstance announce: (FullscreenAnnouncement new 
		displayScreen: self;
		fullscreen: (LastScreenModeSelected := aBoolean))! !

!DisplayScreen methodsFor: 'other' stamp: ''!
fullscreen
	"Display fullscreen"

	ScreenSave ifNil: [ ^ self ].
	Display := ScreenSave! !

!DisplayScreen methodsFor: 'screen managing' stamp: ''!
fullscreenOn

	self fullscreen: true! !

!DisplayScreen methodsFor: 'other' stamp: ''!
height
	^ self boundingBox height! !

!DisplayScreen methodsFor: 'initialization' stamp: ''!
shutDown 
	"Minimize Display memory saved in image"
	self setExtent: 240@120 depth: depth! !

!DisplayScreen methodsFor: 'private' stamp: ''!
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: 'other' stamp: ''!
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"

	<primitive: 233>
	self primitiveFailed! !

!DisplayScreen methodsFor: 'displaying' stamp: ''!
flashAll: rectangleList andWait: msecs
	"Flash the areas of the screen defined by the given rectangles."

	rectangleList do: [:aRectangle | self reverse: aRectangle].

	(Delay forMilliseconds: msecs) wait.
	rectangleList do: [:aRectangle | self reverse: aRectangle].

	(Delay forMilliseconds: msecs) wait.! !

!DisplayScreen class methodsFor: 'initialize-release' stamp: ''!
initialize
	| display |
	display := self new.
	display
		setExtent: 0@0
		depth: 32. 
	Smalltalk globals at: #Display put: display.
	
	self deferUpdates: false.! !

!DisplayScreen class methodsFor: 'accessing' stamp: ''!
actualScreenSize
	"Delegates to active world because it can be something else than the one provided by the VM"

	self flag: #pharoTodo. "The method should be modified to use currentWorld, but the dependency is not possible. We have to remodularize it."
	^ self currentWorld ifNil: [ 0 @ 0 ] ifNotNil: #actualScreenSize! !

!DisplayScreen class methodsFor: '*Deprecated10' stamp: ''!
hostWindowTitle: aString

	self
		deprecated:
		'Use World worldState worldRenderer windowTitle: aTitle instead'
		transformWith: '`@rec hostWindowTitle: `@arg'
			-> 'self currentWorld worldState worldRenderer windowTitle: `@arg'.

	self currentWorld worldState worldRenderer windowTitle: aString! !

!DisplayScreen class methodsFor: 'settings' stamp: ''!
displaySettingsOn: aBuilder 
	<systemsettings>
	(aBuilder setting: #displayFullscreen)
		label: 'Fullscreen mode';
		parent: #desktopSettings;
		target: #Display;
		getSelector: #isFullscreen;
		setSelector: #fullscreen:;
		description: 'On platforms that support it, set fullscreen mode';
		default: false.! !

!DisplayScreen class methodsFor: 'accessing' stamp: ''!
actualScreenDepth

	^ Display depth! !

!DisplayScreen class methodsFor: 'display box access' stamp: ''!
boundingBox
	"Answer the bounding box for the form representing the current display 
	screen."

	^Display boundingBox! !

!DisplayScreen class methodsFor: 'deferring' stamp: ''!
deferUpdates: aBoolean
	| wasDeferred |

	wasDeferred := DeferringUpdates == true.
	DeferringUpdates := aBoolean.
	^ wasDeferred! !

!DisplayTransform commentStamp: ''!
This class represents a base for generic transformations of 2D points between different coordinate systems (including scaling and rotation). The transformations map objects between one coordinate system and another where it is assumed that a nested hierarchy of transformations can be defined.

It is assumed that transformations deal with Integer points. All transformations should return Integer coordinates (even though float points may be passed in as argument).

Compositions of transformations MUST work in the following order. A 'global' transformation (the argument in #composedWithGlobal:) is defined as a transformation that takes place between the receiver (the 'local') transformation and any 'global' point computations, whereas a 'local' transformation (e.g., the argument in #composedWithLocal:) takes place between the receiver ('global') and any 'local' points. For the transformation methods this means that combining a global and a local transformation will result in the following order:

		globalPointToLocal: globalPoint
			"globalPoint -> globalTransform -> localTransform -> locaPoint"
			^localTransform globalPointToLocal:
				(globalTransform globalPointToLocal: globalPoint)

		localPointToGlobal: localPoint
			"localPoint -> localTransform -> globalTransform -> globalPoint"
			^globalTransform localPointToGlobal:
				(localTransform localPointToGlobal: localPoint)

!
!DisplayTransform methodsFor: 'accessing' stamp: ''!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'transforming points' stamp: ''!
localPointsToGlobal: inArray
	"Transform all the points of inArray from local into global coordinates"
	^inArray collect:[:pt| self localPointToGlobal: pt]! !

!DisplayTransform methodsFor: 'transforming points' stamp: ''!
localPointToGlobal: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'composing' stamp: ''!
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: 'testing' stamp: ''!
isMatrixTransform2x3
	"Return true if the receiver is 2x3 matrix transformation"
	^false! !

!DisplayTransform methodsFor: 'transforming rects' stamp: ''!
sourceQuadFor: aRectangle
	^ aRectangle innerCorners collect: 
		[:p | self globalPointToLocal: p]! !

!DisplayTransform methodsFor: 'converting' stamp: ''!
asMatrixTransform2x3
	"Represent the receiver as a 2x3 matrix transformation"
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'transforming rects' stamp: ''!
localBoundsToGlobal: aRectangle
	"Transform aRectangle from local coordinates into global coordinates"
	^Rectangle encompassing: (self localPointsToGlobal: aRectangle corners)! !

!DisplayTransform methodsFor: 'testing' stamp: ''!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'transforming points' stamp: ''!
invertBoundsRect: aRectangle
	"Return a rectangle whose coordinates have been transformed
	from local back to global coordinates."

	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'transforming points' stamp: ''!
globalPointsToLocal: inArray
	"Transform all the points of inArray from global into local coordinates"
	^inArray collect:[:pt| self globalPointToLocal: pt]! !

!DisplayTransform methodsFor: 'testing' stamp: ''!
isMorphicTransform
	"Return true if the receiver is a MorphicTransform, that is specifies the transformation values explicitly."
	^false! !

!DisplayTransform methodsFor: 'testing' stamp: ''!
isCompositeTransform
	"Return true if the receiver is a composite transformation.
	Composite transformations may have impact on the accuracy."
	^false! !

!DisplayTransform methodsFor: 'transforming rects' stamp: ''!
globalBoundsToLocal: aRectangle
	"Transform aRectangle from global coordinates into local coordinates"
	^Rectangle encompassing: (self globalPointsToLocal: aRectangle corners)! !

!DisplayTransform methodsFor: 'composing' stamp: ''!
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: 'transforming points' stamp: ''!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'converting' stamp: ''!
asCompositeTransform
	"Represent the receiver as a composite transformation"
	^CompositeTransform new
		globalTransform: self
		localTransform: self species identity! !

!DisplayTransform methodsFor: 'testing' stamp: ''!
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: 'initialize' stamp: ''!
setIdentity
	"Initialize the receiver to the identity transformation (e.g., not affecting points)"
	^self subclassResponsibility! !

!DisplayTransform class methodsFor: 'instance creation' stamp: ''!
identity
	^self new setIdentity! !

!DisplayableObject commentStamp: ''!
I'm a simple object superclass for objects that need to access information to be better displayed. 
In particular I offer to access to a ui theme and icon. 

For now I do not hold state but in the future it may make sense that I get an instance variable for the default theme and the icon manager. !
!DisplayableObject methodsFor: 'accessing' stamp: 'nil'!
theme
	
	^ Smalltalk ui theme! !

!DoItChunk commentStamp: ''!
I represent the declaration of some code to evaluate.  My contents are the code to evaluate.

Sending me the message #import makes me evaluate the code and return the result of the computation.

Be careful, my #import method also handles ChangeSet interaction so far, handling Changeset preambles and Postscripts.!
!DoItChunk methodsFor: 'testing' stamp: ''!
isDoItDeclaration

	^ true! !

!DoItChunk methodsFor: 'accessing' stamp: ''!
description

	^ 'DoIt (', (contents first: (40 min: contents size)), ')'! !

!DoItChunk methodsFor: 'importing' stamp: ''!
importFor: requestor logSource: logSource
	
	(contents beginsWith: '----') ifTrue: [ ^self ].
	
	SystemAnnouncer uniqueInstance announce: (DoItChunkImported new
		contents: contents; 
		requestor: requestor;
		logSource: logSource;
		yourself). 
	
	^Smalltalk compiler class new
		source: contents;
		requestor: requestor;
		logged: logSource;
		evaluate.! !

!DoItChunk methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	^ aVisitor visitDoItChunk: self! !

!DoItChunkImported commentStamp: ''!
I'm announced in case when CodeImporter is about to evaluate a DoIt!
!DoItChunkImported methodsFor: 'accessing' stamp: ''!
logSource
	^ logSource! !

!DoItChunkImported methodsFor: 'accessing' stamp: ''!
requestor: anObject
	requestor := anObject! !

!DoItChunkImported methodsFor: 'accessing' stamp: ''!
requestor
	^ requestor! !

!DoItChunkImported methodsFor: 'accessing' stamp: ''!
logSource: anObject
	logSource := anObject! !

!DoItChunkImported methodsFor: 'accessing' stamp: ''!
contents
	^ contents! !

!DoItChunkImported methodsFor: 'accessing' stamp: ''!
contents: anObject
	contents := anObject! !

!DoItVariable commentStamp: ''!
I model an access to variables from DoIt scripts. Following example demonstrates an idea:

	| temp |
	temp := 100.
	doItVar := DoItVariable named: #temp fromContext: thisContext.	
	Smalltalk compiler
		bindings: {doItVar};
		evaluate: '1+temp'.

I capture a given variable and a context and compile a method nodes using unified reflective API as:

	doItVariable read.
	doItVariable write: newValue.
	
This way variables visible from one context are indirectly accessible from another environment (from doit expressions).

For example in "debugIt expressions" in Debugger the temp variables from original context are shown as normal variables without any tricks.

To create my instances use following messages:

	DoItVariable named: #temp fromContext: thisContext.
	DoItVariable fromContext: thisContext variable: aVariable.

Or use a variable message: 

	aVariable asDoItVariableFrom: aContext
 
Internal Representation and Key Implementation Points.

    Instance Variables
	actualVariable:		<Variable>
	doItContext:		<Context>!
!DoItVariable methodsFor: 'accessing' stamp: ''!
actualVariable: aVariable
	actualVariable := aVariable.
	name := actualVariable name! !

!DoItVariable methodsFor: 'accessing' stamp: ''!
doItContext: anObject
	doItContext := anObject! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isClassVariable
	^actualVariable isClassVariable! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isWorkspaceVariable
	^actualVariable isWorkspaceVariable! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isSelfVariable
	^actualVariable isSelfVariable! !

!DoItVariable methodsFor: 'printing' stamp: ''!
printOn: aStream 
	super printOn: aStream.
	
	aStream nextPut: $(.
	actualVariable printOn: aStream.
	aStream nextPut: $)! !

!DoItVariable methodsFor: 'debugging' stamp: ''!
write: aValue inContext: aContext
	self write: aValue! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isTempVariable
	^actualVariable isTempVariable! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isUninitialized
	^actualVariable isUninitialized! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isLocalVariable
	^actualVariable isLocalVariable! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isLiteralVariable
	^actualVariable isLiteralVariable! !

!DoItVariable methodsFor: 'queries' stamp: ''!
usingMethods
	^actualVariable usingMethods! !

!DoItVariable methodsFor: 'accessing' stamp: ''!
doItContext
	^ doItContext! !

!DoItVariable methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue
	^actualVariable write: aValue inContext: doItContext! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isUndeclaredVariable
	^actualVariable isUndeclaredVariable! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isArgumentVariable
	^actualVariable isArgumentVariable! !

!DoItVariable methodsFor: 'accessing' stamp: ''!
key 
	^self name! !

!DoItVariable methodsFor: 'debugging' stamp: ''!
readInContext: aContext
	^self read! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isThisContextVariable
	^actualVariable isThisContextVariable! !

!DoItVariable methodsFor: 'accessing' stamp: ''!
actualVariable
	^ actualVariable! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isReservedVariable
	^actualVariable isReservedVariable! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isInstanceVariable
	^actualVariable isInstanceVariable! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isSuperVariable
	^actualVariable isSuperVariable! !

!DoItVariable methodsFor: 'testing' stamp: ''!
isGlobalVariable
	^actualVariable isGlobalVariable! !

!DoItVariable methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	aMethodBuilder
		pushLiteral: self;
		send: #read! !

!DoItVariable methodsFor: 'code generation' stamp: ''!
emitStore: aMethodBuilder
	"generate bytecode to call the reflective write method of the Slot"
	| tempName |
	tempName := '0slotTempForStackManipulation'.  
	aMethodBuilder
		addTemp: tempName;
		storeTemp: tempName;
		popTop;
		pushLiteral: self;
		pushTemp: tempName;
		send: #write:! !

!DoItVariable methodsFor: 'meta-object-protocol' stamp: ''!
read
	^actualVariable readInContext: doItContext! !

!DoItVariable methodsFor: 'accessing' stamp: ''!
scope 
	^ actualVariable scope! !

!DoItVariable class methodsFor: 'instance creation' stamp: ''!
fromContext: aContext variable: aVariable

	^self new 
		doItContext: aContext;
		actualVariable: aVariable! !

!DoItVariable class methodsFor: 'instance creation' stamp: ''!
named: aString fromContext: aContext 
	^self 
		fromContext: aContext 
		variable: (aContext lookupVar: aString)! !

!DoItVariableTest methodsFor: 'tests' stamp: ''!
testFromTempVariable

	| temp var |
	temp := 100.
	var := DoItVariable named: #temp fromContext: thisContext.
	
	self assert: var name equals: #temp.
	self assert: var read equals: 100.
	var write: 200.
	self assert: var read equals: 200.
	self assert: temp equals: 200! !

!DoItVariableTest methodsFor: 'tests' stamp: ''!
testCreationFromAnotherVariable
	| temp var targetTemp |
	temp := 100.
	targetTemp := thisContext lookupVar: #temp.
	var := targetTemp asDoItVariableFrom: thisContext.
	
	self assert: var class equals: DoItVariable.
	self assert: var doItContext identicalTo: thisContext.
	self assert: var actualVariable identicalTo: targetTemp! !

!DoItVariableTest methodsFor: 'tests' stamp: ''!
testReadCompilation
	| temp var ast doIt |
	temp := 100.
	var := DoItVariable named: #temp fromContext: thisContext.
	[ast := [ temp + 2 ] sourceNode body asDoit doSemanticAnalysis]
		on: OCUndeclaredVariableWarning 
		do: [ :ex |  ex resume: ex declareUndefined].
	ast variableNodes first variable: var.
	doIt := ast generateWithSource.
	
	self assert: (doIt valueWithReceiver: self arguments: #()) equals: 102! !

!DoItVariableTest methodsFor: 'tests' stamp: ''!
testConvertingToDoItVariable

	| temp var |
	temp := 100.
	var := DoItVariable named: #temp fromContext: thisContext.
	
	self assert: (var asDoItVariableFrom: #anyContext) identicalTo: var! !

!DoItVariableTest methodsFor: 'tests' stamp: ''!
testFromInstVarVariable

	| var |
	instVarForTest := 100.
	var := DoItVariable named: #instVarForTest fromContext: thisContext.
	
	self assert: var name equals: #instVarForTest.
	self assert: var read equals: 100.
	var write: 200.
	self assert: var read equals: 200.
	self assert: instVarForTest equals: 200! !

!DoItVariableTest methodsFor: 'tests' stamp: ''!
testDoItCompilation
	| temp var doIt |
	temp := 100.
	var := DoItVariable named: #temp fromContext: thisContext.	
	doIt := thisContext class compiler
		source: 'temp + 2';
		context: thisContext;
		noPattern: true;
		bindings: { var };
		compile.
	self assert: (doIt valueWithReceiver: self arguments: {thisContext}) equals: 102! !

!DoItVariableTest methodsFor: 'helpers' stamp: ''!
writeVarInDifferentContext: aVar value: aValue
	| temp | 
	self assert: aVar name equals: #temp.
	
	temp := #thisTemp.
	aVar write: aValue inContext: thisContext.
	self assert: temp equals: #thisTemp! !

!DoItVariableTest methodsFor: 'tests' stamp: ''!
testUsingMethods

	| temp var |
	temp := 100.
	var := DoItVariable named: #temp fromContext: thisContext.
	
	self assert: var usingMethods equals: { thisContext method }! !

!DoItVariableTest methodsFor: 'tests' stamp: ''!
testWriteInGivenContextShouldIgnoreIt
	| temp var |
	temp := 100.
	var := DoItVariable named: #temp fromContext: thisContext.

	self writeVarInDifferentContext: var value: 200.
	self assert: temp equals: 200! !

!DoItVariableTest methodsFor: 'helpers' stamp: ''!
readVarInDifferentContext: aVar
	| temp | 
	self assert: aVar name equals: #temp.
	
	temp := #thisTemp.
	^aVar readInContext: thisContext ! !

!DoItVariableTest methodsFor: 'tests' stamp: ''!
testWriteCompilation
	| temp var ast doIt |
	temp := 100.
	var := DoItVariable named: #temp fromContext: thisContext.
	[ast := [ temp := 500 ] sourceNode body asDoit doSemanticAnalysis] 
		on: OCUndeclaredVariableWarning 
		do: [ :ex |  ex resume: ex declareUndefined].
	ast variableNodes first variable: var.
	doIt := ast generateWithSource.
	doIt valueWithReceiver: self arguments: #().
	
	self assert: temp equals: 500! !

!DoItVariableTest methodsFor: 'tests' stamp: ''!
testReadInGivenContextShouldIgnoreIt
	| temp var actual |
	temp := 100.
	var := DoItVariable named: #temp fromContext: thisContext.

	actual := self readVarInDifferentContext: var.
	self assert: actual equals: 100! !

!DoOnlyOnceIconStyler commentStamp: ''!
I render an icon to control the state of #doOnlyOnce: !
!DoOnlyOnceIconStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	^[ :arg | self rearmOneShot]! !

!DoOnlyOnceIconStyler methodsFor: 'defaults' stamp: ''!
iconLabelBlock: aNode

	^ [Smalltalk globals 
			at: #OneShotArmed
			ifPresent: [ :val | val ifTrue: ['active' ] ifFalse: ['disabled, click to activate' ]]
			ifAbsent: [ 'active' ]
		]! !

!DoOnlyOnceIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^aNode isMessage and: [ aNode selector = #doOnlyOnce: ]! !

!DoOnlyOnceIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #smallWarningIcon ! !

!DocCommentIconStyler commentStamp: ''!
IconStyler for highlight example expressions in method documents (seee PharoDocCommentNode). Enabled / Disabled by a Setting in group "Code Browsing"!
!DocCommentIconStyler methodsFor: 'private' stamp: ''!
runExampleBlock: aNode
	^ [ | examples |
		examples := aNode pharoDocCommentNodes.
		(examples
			collect: [ :example | 
			{ example expression expressionCode formattedCode . example expression evaluate . example result expressionCode formattedCode}]) inspect]! !

!DocCommentIconStyler methodsFor: 'private' stamp: ''!
exampleIsFaulty: aNode
	^ aNode comments
		anySatisfy: [ :commentNode | commentNode pharoDocCommentNodes anySatisfy: [ :node |
				node expression expressionCode isFaulty ]]! !

!DocCommentIconStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	^ (self exampleIsFaulty: aNode)
		ifTrue: [ self notifySourceError: aNode ]
		ifFalse: [ self runExampleBlock: aNode ]! !

!DocCommentIconStyler methodsFor: 'private' stamp: ''!
notifySourceError: aNode
	"If a code in an example is faulty notify the user"
	
	^ [ | examples faultyExample |
		examples := aNode pharoDocCommentNodes.
		faultyExample := examples detect: [ :example | example expression expressionCode isFaulty ].
		RBParser parseExpression: faultyExample expression expression ]! !

!DocCommentIconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^ (Color green alpha: 0.8)! !

!DocCommentIconStyler methodsFor: 'private' stamp: ''!
stylingEnabled
	^ PharoDocCommentNode docCommentEnabled! !

!DocCommentIconStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode
	^ (self exampleIsFaulty: aNode)
		ifTrue: [ 'Faulty Example' ]
		ifFalse: [ 'Runnable Example' ]! !

!DocCommentIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^ self stylingEnabled
		and: [ aNode isMethod
				and: [ aNode comments anySatisfy: [ :commentNode | commentNode hasDocComment ] ] ]! !

!DocCommentIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ (self exampleIsFaulty: aNode)
		ifTrue: [ self iconNamed: #smallWarning ]
		ifFalse: [ self iconNamed: #smallInfo ]! !

!DocCommentsReleaseTest commentStamp: ''!
This test class builds a test suite from all the doc comments in the system.

See #buildSuite on the class side.!
!DocCommentsReleaseTest class methodsFor: 'building suites' stamp: ''!
buildSuite
	| suite methods |
	suite := TestSuite named: 'Test Generated From Comments'.
	"we do not run examples in tests (as they are used just for testing and might be broken by
	design"
	methods := self environment allMethods reject: [ :method | method methodClass isTestCase ].
	"for now skip all class side methods to be in sync with DrTests"
	methods do: [ :method | 
		method pharoDocCommentNodes do: [ :docComment | 
			suite addTest: (CommentTestCase for: docComment) ] ].
	"make sure to clean up the AST Cache to allow the GC to clean up"
	ASTCache reset.
	^ suite! !

!DockingBarMenuItemMorph commentStamp: ''!
A DockingBarMenuItemMorph is a specialized version of its superclass for DockingBar behavior.
!
!DockingBarMenuItemMorph methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph 
	"I have just been added as a submorph of aMorph"
	super noteNewOwner: aMorph.

	self updateLayoutInDockingBar! !

!DockingBarMenuItemMorph methodsFor: 'events' stamp: ''!
mouseEnter: evt
	"The mouse entered the receiver"

	owner ifNotNil: [owner stayUp ifFalse: [self mouseEnterDragging: evt]].
	(owner selectedItem notNil
				and: [owner selectedItem ~~ self])
			ifTrue: [owner selectItem: self event: evt.].! !

!DockingBarMenuItemMorph methodsFor: 'selecting' stamp: ''!
adjacentTo
	| verticalMargin |
	verticalMargin := 4 + owner borderWidth.
	owner isFloating
		ifTrue: [^ {self bounds bottomLeft + (5 @ verticalMargin)}].
	owner isAdheringToTop
		ifTrue: [^ {self bounds bottomLeft + (5 @ verticalMargin)}].
	owner isAdheringToLeft
		ifTrue: [^ {self bounds topRight + (5 @ verticalMargin)}].
	owner isAdheringToBottom
		ifTrue: [^ {self bounds topLeft + (5 @ verticalMargin)}].
	owner isAdheringToRight
		ifTrue: [^ {self bounds topLeft + (5 @ verticalMargin negate)}].
	^ {self bounds bottomLeft + (3 @ verticalMargin)}! !

!DockingBarMenuItemMorph methodsFor: 'events' stamp: ''!
deselectTimeOut: evt
	"Deselect timout. Now really deselect"

	owner selectedItem == self
		ifTrue: [ 
			evt hand releaseMouseFocus: owner.
			owner selectItem: nil event: evt ]! !

!DockingBarMenuItemMorph methodsFor: 'private' stamp: ''!
subMenuMarker
	"private - answer the form to be used as submenu marker"

	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! !

!DockingBarMenuItemMorph methodsFor: 'private' stamp: ''!
updateLayoutInDockingBar

	owner isVertical
		ifTrue: [
			self hResizing: #spaceFill.
			self vResizing: #shrinkWrap]
		ifFalse: [
			self hResizing: #shrinkWrap.
			self vResizing: #spaceFill].
	self extent: self minWidth @ self minHeight! !

!DockingBarMenuItemMorph methodsFor: 'events' stamp: ''!
activateOwnerMenu: evt
	^ self owner ifNil: [ false ] ifNotNil: [ :o | o activate: evt. true]! !

!DockingBarMenuItemMorph methodsFor: 'change reporting' stamp: ''!
ownerChanged
	"The receiver's owner, some kind of a pasteup, has changed its 
	layout."
	super ownerChanged.
	self updateLayoutInDockingBar! !

!DockingBarMenuItemMorph methodsFor: 'rounding' stamp: ''!
wantsRoundedCorners
	^self theme currentSettings preferRoundCorner! !

!DockingBarMenuItemMorph methodsFor: 'events' stamp: ''!
mouseDown: evt
	"Handle a mouse down event. Menu items get activated when the mouse is over them."

	(evt shiftPressed and: [ self isEditable ])
		ifTrue: [^ super mouseDown: evt].  "enable label editing"
	isSelected
		ifTrue: [ owner selectItem: nil event: evt ]
		ifFalse: [ owner activate: evt.	"Redirect to menu for valid transitions"
			owner selectItem: self event: evt ]! !

!DockingBarMenuItemMorph methodsFor: 'events' stamp: ''!
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].
	owner rootMenu selectItem: nil event: evt.
	self invokeWithEvent: evt.! !

!DockingBarMenuItemMorph methodsFor: 'submorphs - accessing' stamp: ''!
roundedCorners
	"Return a list of those corners to round"
	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 )! !

!DockingBarMenuLineMorph commentStamp: ''!
A DockingBarMenuLineMorph is specialized version of its superclass for DockingBar behavior.
!
!DockingBarMenuLineMorph methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph 
	"I have just been added as a submorph of aMorph"
	super noteNewOwner: aMorph.
	self updateLayoutInDockingBar! !

!DockingBarMenuLineMorph methodsFor: 'layout' stamp: ''!
minWidth
	"Answer the receiver's minWidth"

	^ owner isVertical
		ifTrue: [ 10 ]
		ifFalse: [ self theme menuBorderWidth ]! !

!DockingBarMenuLineMorph methodsFor: 'private' stamp: ''!
updateLayoutInDockingBar

	owner isVertical
		ifFalse: [
			self hResizing: #shrinkWrap.
			self vResizing: #spaceFill]
		ifTrue: [
			self hResizing: #spaceFill.
			self vResizing: #shrinkWrap].
	self extent: self minWidth @ self minHeight! !

!DockingBarMenuLineMorph methodsFor: 'change reporting' stamp: ''!
ownerChanged
	"The receiver's owner, some kind of a pasteup, has changed its layout."
	super ownerChanged.
	self updateLayoutInDockingBar! !

!DockingBarMenuLineMorph methodsFor: 'layout' stamp: ''!
minHeight
	"Answer the receiver's minHeight"
	
	^owner isVertical
				ifTrue: [ self theme menuBorderWidth ]
				ifFalse: [10]! !

!DockingBarMenuMorph methodsFor: 'copying' stamp: ''!
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.
	activatorDockingBar := activatorDockingBar.  "Weakly copied"! !

!DockingBarMenuMorph methodsFor: 'accessing' stamp: ''!
activatedFromDockingBar: aDockingBar 
	activatorDockingBar := aDockingBar! !

!DockingBarMenuMorph methodsFor: 'control' stamp: ''!
activeSubmenu: aSubmenu 
	super activeSubmenu: aSubmenu.
	aSubmenu
		ifNotNil: [activeSubMenu activatedFromDockingBar: nil]! !

!DockingBarMenuMorph methodsFor: 'rounding' stamp: ''!
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! !

!DockingBarMenuMorph methodsFor: 'accessing' stamp: ''!
wasActivatedFromDockingBar
	"answer true if the receiver was activated from a docking bar"
	^ activatorDockingBar notNil! !

!DockingBarMorph commentStamp: ''!
I'm a kind of container which adhere to one edge of the screen. See me in action with: 

DockingBarMorph new 
	addMorph: (SimpleButtonMorph new
                                           label: 'Say hello';
                                           target: [UIManager inform: 'Hello'];
                                           actionSelector: #value);
	addMorph: (SimpleButtonMorph new
                                           label: 'Say bonjour';
                                           target: [UIManager inform: 'Bonjour'];
                                           actionSelector: #value);
	addMorph: (SimpleButtonMorph new
                                           label: 'Close';
                                           target: [DockingBarMorph allInstances last delete];
                                           actionSelector: #value);
	adhereToBottom;
	openInWorld.!
!DockingBarMorph methodsFor: 'accessing' stamp: ''!
color: aColor 
	"Set the receiver's color."
	super color: aColor.
	originalColor := aColor asColor.
	self updateColor! !

!DockingBarMorph methodsFor: 'menu' stamp: ''!
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: ''!
avoidVisibleBordersAtEdgeString
	"Answer the string to be shown in a menu to represent the visible status"
	^ (self avoidVisibleBordersAtEdge) ->  'avoid visible borders at edge' translated! !

!DockingBarMorph methodsFor: 'construction' stamp: ''!
addLine
	"Append a divider line to this menu. Suppress duplicate lines."

	submorphs isEmpty ifTrue: [^ self].
	(self lastSubmorph isKindOf: DockingBarMenuLineMorph)
		ifFalse: [self addMorphBack: DockingBarMenuLineMorph new].! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
beFloating
	"Instract the receiver to be floating"
	self adhereTo: #none! !

!DockingBarMorph methodsFor: 'testing' stamp: ''!
stayUp
	^ false! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
originalColor
	"Answer the original color."
	
	^originalColor! !

!DockingBarMorph methodsFor: 'construction' stamp: ''!
add: wordingString icon: aForm help: helpString subMenu: aMenuMorph action: anAction keyText: aText
	"Append the given submenu with the given label."

	| item |
	item := self newMenuItem
		contents: wordingString;
		subMenu: aMenuMorph;
		icon: aForm;
		keyText: aText;
		yourself.
	anAction
		ifNotNil: [ :act | 
			item
				target: act receiver;
				selector: act selector;
				arguments: act arguments ].
	helpString ifNotNil: [ item setBalloonText: helpString ].
	self addMorphBack: item! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
fillsOwner: aBoolean 
	"Instruct the receiver to fill the owner or not"
	fillsOwner := aBoolean.
self updateLayoutProperties! !

!DockingBarMorph methodsFor: 'construction' stamp: ''!
snapToEdgeIfAppropriate
	(self owner isNil
			or: [self owner isHandMorph])
		ifTrue: [^ self].
	self updateBounds! !

!DockingBarMorph methodsFor: 'testing' stamp: ''!
isAdheringToBottom
	"Answer true if the receiver is adhering to bottom"
	^ self edgeToAdhereTo == #bottom! !

!DockingBarMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	^ self theme dockingBarBorderWidth! !

!DockingBarMorph methodsFor: 'testing' stamp: ''!
isAdheringToRight
	"Answer true if the receiver is adhering to right"
	^ self edgeToAdhereTo == #right! !

!DockingBarMorph methodsFor: 'menu' stamp: ''!
toggleFillsOwner
	self fillsOwner: self fillsOwner not! !

!DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
themeChanged
	self
		color: self defaultColor;
		borderColor: self defaultBorderColor;
		borderWidth: self defaultBorderWidth.
	super themeChanged! !

!DockingBarMorph methodsFor: 'private - accessing' stamp: ''!
usedWidthByPredominantDockingBarsOfChastes: predominantChastes 
	"Private - convenience"
	^(self predominantDockingBarsOfChastes: predominantChastes)
		ifEmpty: [0]
		ifNotEmpty: [:predominants | (predominants collect: [:each | each width]) sum]! !

!DockingBarMorph methodsFor: 'events-processing' stamp: ''!
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 mouseUp: evt ].

	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: 'testing' stamp: ''!
isFloating
	"Answer true if the receiver has a float layout"
	^ self isHorizontal not
		and: [self isVertical not]! !

!DockingBarMorph methodsFor: 'construction' stamp: ''!
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: 'testing' stamp: ''!
isHorizontal
	"Answer true if the receiver has a horizontal layout"
	^ self isAdheringToTop
		or: [self isAdheringToBottom]! !

!DockingBarMorph methodsFor: 'construction' stamp: ''!
add: wordingString icon: aForm help: helpString subMenu: aMenuMorph
	"Append the given submenu with the given label."
	
	self add: wordingString icon: aForm help: helpString subMenu: aMenuMorph action: nil keyText: nil! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
fillsOwner
	"Answer if the receiver is in fillOwner mode"
	^ fillsOwner! !

!DockingBarMorph methodsFor: 'construction' stamp: ''!
addSpace: sizePointOrNumber 
	"Add a new space of the given size to the receiver."
	| space |
	space := Morph new.
	space extent: sizePointOrNumber asPoint.
	space color: Color transparent.
	space borderWidth: 0.
	self addMorphBack: space! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
adhereToTop
	"Instract the receiver to adhere to top"
	self adhereTo: #top! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
adhereToLeft
	"Instract the receiver to adhere to left"
	self adhereTo: #left! !

!DockingBarMorph methodsFor: 'submorphs - add/remove' stamp: ''!
delete
	activeSubMenu
		ifNotNil: [activeSubMenu delete].
	^ super delete! !

!DockingBarMorph methodsFor: 'testing' stamp: ''!
wantsToBeTopmost
	"Answer if the receiver want to be one of the topmost objects in 
	its owner"
	^ true! !

!DockingBarMorph methodsFor: 'construction' stamp: ''!
add: wordingString icon: aForm help: helpString action: anAction keyText: aText
	"Append the given submenu with the given label."

	| item |
	item := self newMenuItem.
	item contents: wordingString.
	item keyText: aText.
	anAction
		ifNotNil: [ :act | 
			item
				target: act receiver;
				selector: act selector;
				arguments: act arguments ].
	item icon: aForm.
	helpString ifNotNil: [ item setBalloonText: helpString ].
	self addMorphBack: item! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
adhereToBottom
	"Instract the receiver to adhere to bottom"
	 self adhereTo:#bottom! !

!DockingBarMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the receiver"

	super initialize.
	""
	fillsOwner := true.
	avoidVisibleBordersAtEdge := true.
	autoGradient := self wantsGradientByDefault.
	self color: self defaultColor.	"<= This is done in the super initialize but we need to use the setter in this class"
	""
	self beFloating.
	""
	self layoutInset: 0! !

!DockingBarMorph methodsFor: 'private' stamp: ''!
selectedItem

	selectedItem ifNil: [ ^ nil ].
	^ selectedItem isSelected
		ifTrue: [ selectedItem ]
		ifFalse: [ nil ]! !

!DockingBarMorph methodsFor: 'menu' stamp: ''!
add: wordingString font: aFont icon: aForm help: helpString subMenu: aMenuMorph

	"Append the given submenu with the given label."

	| item |

	item := DockingBarToggleMenuItemMorph new.
	item
		font: aFont;
		contents: wordingString;
		subMenu: aMenuMorph;
		icon: aForm.
	helpString ifNotNil: [ item setBalloonText: helpString ].
	self addMorphBack: item! !

!DockingBarMorph methodsFor: 'events-processing' stamp: ''!
moveSelectionRight: direction event: anEvent
	"Move the current selection left or right by one, presumably under keyboard control.
	direction = +/-1"

	| index |
	index := (submorphs indexOf: selectedItem ifAbsent: [ 1 - direction ]) + direction.
	submorphs
		do: [ :unused | 
			"Ensure finite"
			| m |
			m := submorphs atWrap: index.
			(m isMenuItemMorph and: [ m isEnabled ])
				ifTrue: [ ^ self selectItem: m event: anEvent ].
			"Keep looking for an enabled item"
			index := index + direction sign ].
	^ self selectItem: nil event: anEvent! !

!DockingBarMorph methodsFor: 'testing' stamp: ''!
isDockingBar
	"Return true if the receiver is a docking bar"
	^ true! !

!DockingBarMorph methodsFor: 'menu' stamp: ''!
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 selector: #toggleAutoGradient.
	self isFloating
		ifFalse: [
			aMenu addUpdating: #fillsOwnerString selector: #toggleFillsOwner.
			aMenu addUpdating: #avoidVisibleBordersAtEdgeString selector: #toggleAvoidVisibleBordersAtEdge]! !

!DockingBarMorph methodsFor: 'change reporting' stamp: ''!
displayExtentChanged

	self updateBounds! !

!DockingBarMorph methodsFor: 'private - accessing' stamp: ''!
usedHeightByPredominantDockingBarsOfChastes: predominantChastes 
	"Private - convenience"
	^(self predominantDockingBarsOfChastes: predominantChastes)
		ifEmpty: [0]
		ifNotEmpty: [:predominants | (predominants collect: [:each | each height]) sum]! !

!DockingBarMorph methodsFor: 'private - layout' stamp: ''!
gradientRamp
	^ gradientRamp ifNil:[{0.0 -> originalColor muchLighter. 1.0 -> originalColor twiceDarker}]! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
popUpOwner
	"For compatibility with other menu"
	
	^ nil! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Change our color too."
	
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	originalColor :=  paneColor.
	self borderStyle baseColor: paneColor.
	self updateColor! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
autoGradient
	"Answer if the receiver is in autoGradient mode"
	^ autoGradient! !

!DockingBarMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	^ self theme menuBorderColor! !

!DockingBarMorph methodsFor: 'control' stamp: ''!
activeSubmenu: aSubmenu

	activeSubMenu ifNotNil: [ activeSubMenu delete ].
	activeSubMenu := aSubmenu.
	aSubmenu ifNil: [ ^ self ].
	activeSubMenu selectItem: nil event: nil.
	activeSubMenu borderColor: self borderColor.
	activeSubMenu beSticky.
	activeSubMenu resistsRemoval: true.
	activeSubMenu removeMatchString! !

!DockingBarMorph methodsFor: 'events-processing' stamp: ''!
mouseUp: evt
	"If we click on a selected item with an action we want to execute the action and deselect the menu item."
	
	super mouseUp: evt.
	
	self selectedItem ifNil: [ ^ self ]. "No selected item"
	self selectedItem selector ifNil: [ ^ self ]. "No action for the selected item"
	(self selectedItem containsPoint: evt cursorPoint) ifFalse: [ ^ self ]. "The user did not clicked on the selected menu item"

	"Execute the action of the menu item and deselect it"
	self selectedItem invokeWithEvent: evt.
	self selectItem: nil event: evt! !

!DockingBarMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^ self theme settings derivedMenuColor! !

!DockingBarMorph methodsFor: 'events-processing' stamp: ''!
handlesMouseDown: evt
	^ true! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
rootMenu
	^ self! !

!DockingBarMorph methodsFor: 'menu' stamp: ''!
toggleAvoidVisibleBordersAtEdge
	self avoidVisibleBordersAtEdge: self avoidVisibleBordersAtEdge not! !

!DockingBarMorph methodsFor: 'private - layout' stamp: ''!
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: 'initialization' stamp: ''!
wantsGradientByDefault
	^ self theme preferGradientFill! !

!DockingBarMorph methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph 
	"I have just been added as a submorph of aMorph"
	super noteNewOwner: aMorph.

	self submorphs
		do: [:each | each adjustLayoutBounds].! !

!DockingBarMorph methodsFor: 'control' stamp: ''!
deleteIfPopUp: evt 
	evt
		ifNotNil: [evt hand releaseMouseFocus: self]! !

!DockingBarMorph methodsFor: 'private - accessing' stamp: ''!
edgeToAdhereTo
	"private - answer the edge where the receiver is adhering to"
	^ self
		valueOfProperty: #edgeToAdhereTo
		ifAbsent: [#none]! !

!DockingBarMorph methodsFor: 'private - layout' stamp: ''!
gradientRamp: colorRamp 
	gradientRamp := colorRamp.
	self updateColor! !

!DockingBarMorph methodsFor: 'testing' stamp: ''!
isAdheringToTop
	"Answer true if the receiver is adhering to top"
	^ self edgeToAdhereTo == #top! !

!DockingBarMorph methodsFor: 'menu' stamp: ''!
autoGradientString
	"Answer the string to be shown in a menu to represent the  'resistsRemoval' status"
	
	^ (self autoGradient) ->  'auto gradient' translated! !

!DockingBarMorph methodsFor: 'dropping/grabbing' stamp: ''!
justDroppedInto: aMorph event: anEvent

	| ownerBounds leftRegion droppedPosition rightRegion topRegion bottomRegion |

	super justDroppedInto: aMorph event: anEvent.

	self owner ifNil: [ ^ 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: 'change reporting' stamp: ''!
ownerChanged
"The receiver's owner has changed its layout. "
	self updateBounds.
	^ super ownerChanged! !

!DockingBarMorph methodsFor: 'testing' stamp: ''!
isVertical
	"Answer true if the receiver has a vertical layout"
	^ self isAdheringToLeft
		or: [self isAdheringToRight]! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
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: 'construction' stamp: ''!
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: 'accessing' stamp: ''!
adhereToRight
	"Instract the receiver to adhere to right"
	self adhereTo: #right! !

!DockingBarMorph methodsFor: 'events-processing' stamp: ''!
keyDown: anEvent
	"Handle menu navigation"
	
	"Left arrow key"
	anEvent keyValue = 28 ifTrue: [ self moveSelectionRight: -1 event: anEvent ].
	"Right arrow key"
	anEvent keyValue = 29 ifTrue: [ self moveSelectionRight: 1 event: anEvent ].
	"Bottom key"
	anEvent keyValue = 31 ifTrue: [ (selectedItem ifNotNil: [ selectedItem subMenu ifNotNil: [ :subMenu | subMenu activateFromKeyboard: anEvent ] ] )].
	^ super keyDown: anEvent! !

!DockingBarMorph methodsFor: 'events-processing' stamp: ''!
activate: evt 
	"Receiver should be activated; e.g., so that control passes  
	correctly."
	evt hand newMouseFocus: self.
	self takeKeyboardFocus! !

!DockingBarMorph methodsFor: 'private - layout' stamp: ''!
updateLayoutProperties
	"private - update the layout properties based on adhering,  
	fillsOwner and avoidVisibleBordersAtEdge preferencs"

	(self isHorizontal or: [self isFloating])
		ifTrue: [self listDirection: #leftToRight]
		ifFalse: [self listDirection: #topToBottom].

	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self fillsOwner ifTrue: [
			self isHorizontal ifTrue: [self hResizing: #spaceFill].
			self isVertical ifTrue: [self vResizing: #spaceFill]].! !

!DockingBarMorph methodsFor: 'private - layout' stamp: ''!
updateBounds
	"private - update the receiver's bounds"
	self updateExtent.
	self isFloating
		ifFalse: [self updatePosition]! !

!DockingBarMorph methodsFor: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
avoidVisibleBordersAtEdge: aBoolean 
	"Instruct the receiver to avoid showing the borders at edge"
	avoidVisibleBordersAtEdge := aBoolean.
self updateLayoutProperties.! !

!DockingBarMorph methodsFor: 'testing' stamp: ''!
isAdheringToLeft
	"Answer true if the receiver is adhering to left"
	^ self edgeToAdhereTo == #left! !

!DockingBarMorph methodsFor: 'private - layout' stamp: ''!
updatePosition
	"private - update the receiver's position.
	Fixed so as not to keep changing position!!
	(called twice if adhereing)"

	self owner
		ifNotNil: [ :anOwner | 
			| edgeSymbol margin usedHeight |
			edgeSymbol := self edgeToAdhereTo.
			edgeSymbol == #none
				ifTrue: [ self perform: (edgeSymbol , ':') asSymbol with: (anOwner perform: edgeSymbol) ].

			margin := (self avoidVisibleBordersAtEdge ifTrue: [ self borderWidth ] ifFalse: [ 0 ]) asPoint.

			self isAdheringToTop
				ifTrue: [ usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top).
					self topLeft: anOwner topLeft - margin + (0 @ usedHeight) ].

			self isAdheringToBottom
				ifTrue: [ usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#bottom).
					self bottomLeft: anOwner bottomLeft + (-1 @ 1 * margin) - (0 @ usedHeight) ].

			self isAdheringToLeft
				ifTrue: [ | usedWidth |
					usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top).
					usedWidth := self usedWidthByPredominantDockingBarsOfChastes: #(#left).
					self topLeft: anOwner topLeft - margin + (usedWidth @ usedHeight) ].

			self isAdheringToRight
				ifTrue: [ | usedWidth |
					usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top).
					usedWidth := self usedWidthByPredominantDockingBarsOfChastes: #(#right).
					self topRight: anOwner topRight + (1 @ -1 * margin) + (usedWidth negated @ usedHeight) ] ]! !

!DockingBarMorph methodsFor: 'construction' stamp: ''!
newMenuItem
	
	^ DockingBarMenuItemMorph new! !

!DockingBarMorph methodsFor: 'dropping/grabbing' stamp: ''!
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: 'accessing' stamp: ''!
autoGradient: aBoolean 
	"Instruct the receiver to fill the owner or not"
	autoGradient := aBoolean.
	self updateColor! !

!DockingBarMorph methodsFor: 'control' stamp: ''!
selectItem: aMenuItem event: anEvent 
	selectedItem
		ifNotNil: [selectedItem deselect: anEvent].
	selectedItem := aMenuItem.
	selectedItem
		ifNotNil: [selectedItem select: anEvent]! !

!DockingBarMorph methodsFor: 'menu' stamp: ''!
toggleAutoGradient
	self autoGradient: self autoGradient not! !

!DockingBarMorph methodsFor: 'private - layout' stamp: ''!
updateExtent
	"private - update the receiver's extent"

	| margin usedHeight |
	self fullBounds.
	self fillsOwner ifFalse: [ ^ self ].
	
	"Nil check because there is probably a race condition here making the CI fail a lot."
	self owner
		ifNotNil: [ :anOwner | 
			margin := self avoidVisibleBordersAtEdge ifTrue: [ self borderWidth * 2 ] ifFalse: [ 0 ].
			self isHorizontal ifTrue: [ self width: anOwner width + margin ].
			self isVertical
				ifTrue: [ usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top #bottom).
					self height: anOwner height + margin - usedHeight ] ]! !

!DockingBarMorph methodsFor: 'menu' stamp: ''!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu.
	Fixed for when defaultYellowButtonMenuEnabled setting is off"
	
	^ self defaultYellowButtonMenuEnabled! !

!DockingBarMorph methodsFor: 'events-processing' stamp: ''!
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: 'events-processing' stamp: ''!
handlesKeyboard: evt
	^ true! !

!DockingBarMorph methodsFor: 'construction' stamp: ''!
add: aString subMenu: aMenuMorph 
	"Append the given submenu with the given label."
	self add: aString icon: nil subMenu: aMenuMorph! !

!DockingBarMorph methodsFor: 'private - accessing' stamp: ''!
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: ''!
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: 'rounding' stamp: ''!
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: 'accessing' stamp: ''!
avoidVisibleBordersAtEdge
"Answer if the receiver is in avoidVisibleBordersAtEdge mode"
	^ avoidVisibleBordersAtEdge! !

!DockingBarMorph methodsFor: 'wiw support' stamp: ''!
morphicLayerNumber
	"helpful for insuring some morphs always appear in front of or 
	behind others. smaller numbers are in front"
	^ 11! !

!DockingBarMorph class methodsFor: 'examples' stamp: ''!
example
	"self example"
	
	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 class methodsFor: 'examples' stamp: ''!
exampleWithMenu
	"self exampleWithMenu"
	
	DockingBarMorph new 
		add: 'Foo' 
		font:  StandardFonts defaultFont 
		icon: MenuMorph pushPinImage
		help: 'No idea' subMenu: nil;
		add: 'Bar' 
		font:  StandardFonts defaultFont 
		icon: MenuMorph pushPinImage
		help: 'No idea' subMenu: nil;
	adhereToTop;
	openInWorld.! !

!DockingBarToggleMenuItemMorph commentStamp: ''!
A DockingBarToggleMenuItemMorph is a specialized version of its superclass for DockingBar behavior.

There is a bit of duplication between 
DockingBarToggleMenuItemMorph and DockingBarMenuItemMorph because iof single inheritance limit: 

DockingBarToggleMenuItemMorph inherits from ToggleMenuItemMorph (and also from DockingBarMenuItemMorph).

One of the problem is that in addition, the use of toggleMenuItem or simple menuItem looks random.

DockingBarMenuItemMorph is created by
	add: wordingString icon: aForm help: helpString subMenu: aMenuMorph 
	
and DockingBarToggleMenuItemMorph is created by
	add: wordingString font: aFont icon: aForm help: helpString subMenu: aMenuMorph 
!
!DockingBarToggleMenuItemMorph methodsFor: 'private - drawing' stamp: ''!
drawSubMenuMarker: aForm on: aCanvas in: aRectangle
	"Draw the submenu marker on the canvas within the given bounds."
	
	|markerRect| 
	markerRect := aRectangle topRight + (aForm width negated @ (aRectangle height - aForm height // 2)) extent: aForm extent.
	markerRect translateBy: -4@1.
	self drawIcon: aForm on: aCanvas in: markerRect! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
drawOn: aCanvas
	| stringColor stringBounds |
	stringColor := (isSelected and: [ isEnabled ])
		ifTrue: [ aCanvas fillRectangle: self bounds fillStyle: self selectionFillStyle.
			color negated ]
		ifFalse: [ color ].
	stringBounds := bounds.
	stringBounds := stringBounds left: stringBounds left + 4.
	self hasIcon
		ifTrue: [ | iconForm |
			iconForm := self iconForm.
			aCanvas translucentImage: iconForm at: stringBounds left @ (self top + ((self height - iconForm height) // 2)).
			stringBounds := stringBounds left: stringBounds left + iconForm width + 2 ].
	self hasMarker ifTrue: [ stringBounds := stringBounds left: stringBounds left + self submorphBounds width + 8 ].
	stringBounds := stringBounds top: (stringBounds top + stringBounds bottom - self fontToUse height) // 2.
	aCanvas
		drawString: self contents
		in: stringBounds
		font: self fontToUse
		color: stringColor.
	self hasSubMenu
		ifTrue: [ | subMenuMarker subMenuMarkerPosition |
			subMenuMarker := self subMenuMarker.
			subMenuMarkerPosition := (self right - subMenuMarker width) @ ((self top + self bottom - subMenuMarker height) // 2).
			subMenuMarkerPosition := subMenuMarkerPosition - (4 @ -1).
			aCanvas paintImage: subMenuMarker at: subMenuMarkerPosition ]! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
noteNewOwner: aMorph 
	"I have just been added as a submorph of aMorph"
	super noteNewOwner: aMorph.

	self updateLayoutInDockingBar! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
selectionBorderStyle
	"Answer the border style to use with the receiver is the selected element."
	
	^ self theme menuItemInDockingBarSelectedBorderStyleFor: self! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
mouseEnter: evt
	"The mouse entered the receiver"

	owner ifNotNil: [owner stayUp ifFalse: [self mouseEnterDragging: evt]].
	(owner selectedItem notNil
				and: [owner selectedItem ~~ self])
			ifTrue: [owner selectItem: self event: evt.].! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
stringBoundsToUse
	"Answer the bounds to use when drawing the item text."
	
	^self bounds left: self left + 4! !

!DockingBarToggleMenuItemMorph methodsFor: 'selecting' stamp: ''!
adjacentTo
	"Adjusted to line up more nicely."
	self owner isFloating
		ifTrue: [^ {self bounds bottomLeft + (3 @ 3).  self bounds bottomRight + (5 @ 3)}].
	self owner isAdheringToTop
		ifTrue: [^ {self bounds bottomLeft + (5 @ 5)}].
	self owner isAdheringToLeft
		ifTrue: [^ {self bounds topRight + (5 @ 5)}].
	self owner isAdheringToBottom
		ifTrue: [^ {self bounds topLeft + (5 @ 5)}].
	self owner isAdheringToRight
		ifTrue: [^ {self bounds topLeft + (5 @ -5)}].
	^ {self bounds bottomLeft + (3 @ 5)}! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
deselectTimeOut: evt
	"Deselect timout. Now really deselect"

	owner selectedItem == self
		ifTrue: [ 
			evt hand releaseMouseFocus: owner.
			owner selectItem: nil event: evt ]! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
subMenuMarker
	"private - answer the form to be used as submenu marker"

	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! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
updateLayoutInDockingBar

	owner isVertical
		ifTrue: [
			self hResizing: #spaceFill.
			self vResizing: #shrinkWrap]
		ifFalse: [
			self hResizing: #shrinkWrap.
			self vResizing: #spaceFill].
	self extent: self minWidth @ self minHeight! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
ownerChanged
	"The receiver's owner, some kind of a pasteup, has changed its 
	layout."
	super ownerChanged.
	self updateLayoutInDockingBar! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
wantsRoundedCorners
	^self theme currentSettings preferRoundCorner! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
mouseDown: evt
	"Handle a mouse down event. Menu items get activated when the mouse is over them."

	(evt shiftPressed and: [self isEditable ]) 
		ifTrue: [ ^ super mouseDown: evt ].  "enable label editing"

	isSelected
		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. ]! !

!DockingBarToggleMenuItemMorph methodsFor: 'private' stamp: ''!
selectionFillStyle
	"Answer the fill style to use with the receiver is the selected element."
	
	^self theme menuItemInDockingBarSelectedFillStyleFor: self! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
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].
	owner rootMenu selectItem: nil event: evt.
	self invokeWithEvent: evt.! !

!DockingBarToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
roundedCorners
	"Return a list of those corners to round"
	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 )! !

!DoesNotUnderstandDebugAction commentStamp: ''!
A DoesNotUnderstandDebugAction is a debugging action that can create a method if the debugger was opened as a result of a #doesNotUnderstand mesage send.
!
!DoesNotUnderstandDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^  'Create'! !

!DoesNotUnderstandDebugAction methodsFor: 'testing' stamp: ''!
appliesToDebugger: aDebugger

	^ aDebugger session isInterruptedContextDoesNotUnderstand! !

!DoesNotUnderstandDebugAction methodsFor: 'private' stamp: ''!
closeWindow
	"Safely close the debugger window without destroying the debugger context and stack"
	| modelWindow |
	modelWindow := self debugger window.
	modelWindow
		model: nil;
		close! !

!DoesNotUnderstandDebugAction methodsFor: 'private' stamp: ''!
askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock
	| classes chosenClassIndex |
	classes := aClass withAllSuperclasses addAll: (aClass traits sort: [ :t1 :t2 | t1 asString < t2 asString ]); yourself.
	chosenClassIndex := UIManager default 
		chooseFrom: (classes collect: [:c | c name])
		title: 'Define #', aSelector, ' in which class?'.
	chosenClassIndex = 0 ifTrue: [^ cancelBlock value].
	^ classes at: chosenClassIndex! !

!DoesNotUnderstandDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 1! !

!DoesNotUnderstandDebugAction methodsFor: 'actions' stamp: ''!
executeAction
	"Should only be called when the debugger was created in response to a
	MessageNotUnderstood exception. Create a stub for the method that was
	missing and proceed into it, or create a class if it was missing instead"
	
	| msg msgCategory chosenClass exception |
	
	msg := self interruptedContext tempAt: 1.
	exception := self interruptedContext tempAt: 2.
	
	(exception class == VariableNotDeclared) ifTrue: [ 
		self createMissingClassWith: exception variableNode in: self interruptedContext ].
	
	chosenClass := self 
		askForSuperclassOf: self interruptedContext receiver class
		toImplement: msg selector
		ifCancel: [^self].
	"we do not ask for the category here as it breaks flow"
	msgCategory := 'as yet unclassified'.
	self  session
		implement: msg 
		classified: msgCategory 
		inClass: chosenClass 
		forContext: self interruptedContext.
	self debugger selectTopContext! !

!DoesNotUnderstandDebugAction methodsFor: 'accessing' stamp: ''!
help
    ^ 'Create the missing class or method in the user prompted class, and restart the debugger at the location where it can be edited.'! !

!DoesNotUnderstandDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #doesNotUnderstand! !

!DoesNotUnderstandDebugAction methodsFor: 'private' stamp: ''!
createMissingClassWith: variableNode in: aContext
	|  previousContext  |
		
	OCUndeclaredVariableWarning new
		node: variableNode;
		defineClass: variableNode name.
		
	previousContext := aContext sender.
	
	self closeWindow.
	
	previousContext restart! !

!DoesNotUnderstandDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<debuggingAction>! !

!DomainError commentStamp: ''!
I am DomainError, an ArithmeticException indicating that some argument falls outside an expected domain, [from, to]

When my valid interval is left- or right-open, use signal: creation protocol to provide a custom messageText rather than the default [from, to] notation.!
!DomainError methodsFor: 'accessing' stamp: ''!
to
	^ to! !

!DomainError methodsFor: 'accessing' stamp: ''!
to: end
	to := end! !

!DomainError methodsFor: 'accessing' stamp: ''!
from
	^ from! !

!DomainError methodsFor: 'accessing' stamp: ''!
from: start
	from := start! !

!DomainError class methodsFor: 'signaling' stamp: ''!
signal: signallerText from: start
	^ self signal: signallerText from: start to: Float infinity! !

!DomainError class methodsFor: 'signaling' stamp: ''!
signalTo: end
	^ self signalFrom: Float infinity negated to: end! !

!DomainError class methodsFor: 'signaling' stamp: ''!
signal: signallerText from: start to: end
	^ self new
		from: start;
		to: end;
		signal: signallerText! !

!DomainError class methodsFor: 'signaling' stamp: ''!
signalFrom: start
	^ self signalFrom: start to: Float infinity! !

!DomainError class methodsFor: 'signaling' stamp: ''!
signal: signallerText to: end
	^ self signal: signallerText from: Float infinity negated to: end! !

!DomainError class methodsFor: 'signaling' stamp: ''!
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! !

!DosTimestamp commentStamp: ''!
DOS stores timestamps, in local time, as 32 bit integers with the following format:
	32 bits (low to high):
		Low 16 bits:
			Bits 0-4: seconds / 2
	 		Bits 5-10: minutes 0-59
			Bits 11-15: hours 0-23
		High 16 bits:
			16-20: day of month 1-31
	 		21-24: month 1-12
			25-31: year offset from 1980 (e.g. 1981 -> 1)

References (with visual aids): http://blogs.msdn.com/b/oldnewthing/archive/2003/09/05/54806.aspx & http://mindprod.com/jgloss/zip.html!
!DosTimestamp methodsFor: 'converting' stamp: ''!
asDateAndTime

	^ DateAndTime date: self date time: self time.! !

!DosTimestamp methodsFor: 'comparing' stamp: ''!
= rhs

	^ self value = rhs value.! !

!DosTimestamp methodsFor: 'comparing' stamp: ''!
hash

	^ self value hash.! !

!DosTimestamp methodsFor: 'private' stamp: ''!
low16Bits
	
	^ value & 2r1111111111111111.! !

!DosTimestamp methodsFor: 'private' stamp: ''!
time
	"See class comment for format details"
	
	| encodedTime hours minutes secondsHalved seconds |
	encodedTime := self low16Bits.
	hours := encodedTime >> 11. "High 5 bits"
	minutes := encodedTime >> 5 & 2r111111. "Middle 6 bits"
	secondsHalved := encodedTime & 2r11111. "Low 5 bits"
	seconds := (secondsHalved * 2) floor.
	^ Time hour: hours minute: minutes second: seconds.! !

!DosTimestamp methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		print: self asDateAndTime ;
		nextPutAll: ' (';
		print: self value ;
		nextPut: $).! !

!DosTimestamp methodsFor: 'private' stamp: ''!
high16Bits

	^ value >> 16.! !

!DosTimestamp methodsFor: 'accessing' stamp: ''!
value

	^ value.! !

!DosTimestamp methodsFor: 'private' stamp: ''!
initializeValue: anInteger 

	value := anInteger.
	^ self.! !

!DosTimestamp methodsFor: 'private' stamp: ''!
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: ''!
epoch

	^ self class epoch.! !

!DosTimestamp class methodsFor: 'instance creation' stamp: ''!
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: ''!
on: anInteger

	^ self new initializeValue: anInteger.! !

!DosTimestamp class methodsFor: 'private' stamp: ''!
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: ''!
timeValueFrom: aTime

	| dosHours dosMinutes dosSeconds |
	dosHours := aTime hour << 11.
	dosMinutes := aTime minute << 5.
	dosSeconds := (aTime second / 2) floor.
	^ dosHours + dosMinutes + dosSeconds.! !

!DosTimestamp class methodsFor: 'accessing' stamp: ''!
epoch

	^ DateAndTime dosEpoch! !

!DosTimestampTest commentStamp: ''!
SUnit tests for class  DosTimeStamp!
!DosTimestampTest methodsFor: 'tests' stamp: ''!
testTimesAreLocal

	| remoteDateAndTime remoteTimestamp localTimestamp |
	remoteDateAndTime := DateAndTime current offset: DateAndTime localOffset + 2 hours.
	remoteTimestamp := DosTimestamp fromDateAndTime: remoteDateAndTime.
	localTimestamp := DosTimestamp fromDateAndTime: remoteDateAndTime asLocal.
	self assert: remoteTimestamp equals: localTimestamp.! !

!DosTimestampTest methodsFor: 'tests' stamp: ''!
testFromDateAndTime

	| timestamp |
	timestamp := DosTimestamp fromDateAndTime: '21 May 2012 3:02:44 pm' asDateAndTime.
	
	self assert: timestamp value equals: 16r40B57856.! !

!DosTimestampTest methodsFor: 'tests' stamp: ''!
testAsDateAndTime
	
	| timestamp |
	timestamp := DosTimestamp on: 16r40B57856.
	self assert: timestamp asDateAndTime equals: '21 May 2012 3:02:44 pm' asDateAndTime.! !

!DoubleByteArray commentStamp: ''!
DoubleByteArrays store 16-bit unsigned Integer values.

For further comments read comments of `WordArray`.!
!DoubleByteArray methodsFor: 'private' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !

!DoubleByteArray methodsFor: 'accessing' stamp: ''!
bytesPerElement
	"Number of bytes in each item.  This multiplied by (self size)*8 gives the number of bits stored."
	^ 2! !

!DoubleByteArray methodsFor: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	self pinInMemory.
	^ PointerUtils oopForObject: self
! !

!DoubleByteArray methodsFor: 'accessing' stamp: ''!
byteSize
	^self size * 2! !

!DoubleByteArray methodsFor: 'private' stamp: ''!
atAllPut: value
	"Fill the receiver with the given value"

	<primitive: 145>
	super atAllPut: value! !

!DoubleByteArray methodsFor: 'accessing' stamp: ''!
defaultElement
	"Return the default element of the receiver"
	^0! !

!DoubleByteLayout commentStamp: ''!
I am a raw data layout that holds double bytes (16 bits).!
!DoubleByteLayout methodsFor: 'accessing' stamp: ''!
bytesPerSlot

	^ 2! !

!DoubleByteLayout methodsFor: 'extending' stamp: ''!
extendDoubleByte
	^ DoubleByteLayout new! !

!DoubleByteLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	^ 12! !

!DoubleByteLayout methodsFor: 'testing' stamp: ''!
isDoubleBytes
	^ true! !

!DoubleByteLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGDoubleByteLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)]! !

!DoubleByteLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else!!"
	^#variableDoubleByteSubclass:! !

!DoubleByteLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass
	^ superLayout extendDoubleByte
		host: aClass;
		yourself! !

!DoubleLink commentStamp: ''!
I am DoubleLink, the elementary part of a DoubleLinkedList.

I hold a value, as well as a link to my successor (nextLink) and to my predecessor (previousLink) - both can be nil.!
!DoubleLink methodsFor: 'accessing' stamp: ''!
value: anObject
	value := anObject! !

!DoubleLink methodsFor: 'testing' stamp: ''!
hasPredecessor
	^ previousLink notNil! !

!DoubleLink methodsFor: 'initialize' stamp: ''!
clearLinks
	nextLink := previousLink := nil! !

!DoubleLink methodsFor: 'converting' stamp: ''!
asDoubleLink
	^ self! !

!DoubleLink methodsFor: 'evaluating' stamp: ''!
value
	^ value! !

!DoubleLink methodsFor: 'accessing' stamp: ''!
previousLink
	^ previousLink! !

!DoubleLink methodsFor: 'accessing' stamp: ''!
nextLink
	^ nextLink! !

!DoubleLink methodsFor: 'accessing' stamp: ''!
nextLink: anObject
	nextLink := anObject! !

!DoubleLink methodsFor: 'testing' stamp: ''!
hasSuccessor
	^ nextLink notNil! !

!DoubleLink methodsFor: 'accessing' stamp: ''!
previousLink: anObject
	previousLink := anObject! !

!DoubleLink class methodsFor: 'instance creation' stamp: ''!
value: anObject
	^ self new
		value: anObject;
		yourself! !

!DoubleLinkedList commentStamp: ''!
I am DoubleLinkedList, an ordered list data structure consisting of objects, most likely DoubleLinks or something compatible, connected to each other by forward and backwards links.

Note that some of my API deals with the elements that I hold, like any other collection, while some of my API references the links that I use internally (those usually have the word link in the selector name). Some methods accepts both values or links as argument (like #add:). Because I expose some if my internal structure, I can be broken quite easily.

!
!DoubleLinkedList methodsFor: 'testing' stamp: ''!
isEmpty
	"Return true when I contain no elements, false otherwise."

	^ head isNil and: [ tail isNil ]! !

!DoubleLinkedList methodsFor: 'removing' stamp: ''!
removeFirst
	"Remove my first element.
	Signal a CollectionIsEmpty exception when I am empty.
	Return the removed internal link."
	
	| link |
	self emptyCheck.
	link := head.
	head := head nextLink.
	head 
		ifNil: [ tail := nil ]
		ifNotNil: [ head previousLink: nil ].
	link clearLinks.
	^ link! !

!DoubleLinkedList methodsFor: 'adding' stamp: ''!
add: anObjectOrLink
	"Add anObjectOrLink at the end of me.
	Return the internal link object."
	
	^ self addLast: anObjectOrLink! !

!DoubleLinkedList methodsFor: 'testing' stamp: ''!
includes: object
	"Return true when I hold object as a value, false otherwise."
	
	self do: [ :each |
		each = object ifTrue: [ ^ true ] ].
	^ false! !

!DoubleLinkedList methodsFor: 'adding' stamp: ''!
add: anObjectOrLink afterLink: otherLink
	"Add anObjectOrLink right after otherLink in me.
	When otherLink is not part of me, the result is undefined.
	Return the internal link object."

	| link otherLinkSuccessor |
	otherLink = tail
		ifTrue: [ ^ self addLast: anObjectOrLink ].
	link := anObjectOrLink asDoubleLink.
	otherLinkSuccessor := otherLink nextLink.
	otherLink nextLink: link.
	link previousLink: otherLink.
	link nextLink: otherLinkSuccessor.
	otherLinkSuccessor previousLink: link.
	^ link! !

!DoubleLinkedList methodsFor: 'private' stamp: ''!
emptyCheck

	self isEmpty
		ifTrue: [ CollectionIsEmpty signalWith: self ]! !

!DoubleLinkedList methodsFor: 'enumerating' stamp: ''!
linksDo: block
	"Execute block for each of the links that I hold internally."
	
	| current |
	current := head.
	[ current isNil ] 
		whileFalse: [ 
	 		block value: current.
			current := current nextLink ]! !

!DoubleLinkedList methodsFor: 'enumerating' stamp: ''!
reverseDo: block
	"Execute block for each of my elements, in reverse order."

	self reverseLinksDo: [ :each | block value: each value ]! !

!DoubleLinkedList methodsFor: 'enumerating' stamp: ''!
select: block
	"Execute block for each of my elements and return a new instance of me 
	containing those elements for which the block returned true."

	| result |
	result := self class new.
	self do: [ :each |
		(block value: each)
			ifTrue: [ result add: each ] ].
	^ result! !

!DoubleLinkedList methodsFor: 'removing' stamp: ''!
removeLink: link
	"Remove the specified link.
	When otherLink is not part of me, the result is undefined.
	Return the removed internal link."

	| predecessor successor |
	predecessor := link previousLink.
	successor := link nextLink.
	predecessor
		ifNil: [ head := successor ]
		ifNotNil: [ predecessor nextLink: successor ].
	successor
		ifNil: [ tail := predecessor ]
		ifNotNil: [ successor previousLink: predecessor ].
	link clearLinks.
	^ link! !

!DoubleLinkedList methodsFor: 'converting' stamp: ''!
asArray
	"Return a new Array containing my elements"
	
	^ Array streamContents: [ :out |
		self do: [ :each | out nextPut: each ] ]! !

!DoubleLinkedList methodsFor: 'enumerating' stamp: ''!
do: block
	"Execute block for each of my elements."

	self linksDo: [ :each | block value: each value ]! !

!DoubleLinkedList methodsFor: 'accessing' stamp: ''!
first
	"Return the first element that I hold, also known as my head value.
	Signal a CollectionIsEmpty exception when I am empty."
	
	self emptyCheck.
	^ head value! !

!DoubleLinkedList methodsFor: 'accessing' stamp: ''!
last
	"Return the last element that I hold, also known as my tail value.
	Signal a CollectionIsEmpty excpetion when I am empty."
	
	self emptyCheck.
	^ tail value! !

!DoubleLinkedList methodsFor: 'enumerating' stamp: ''!
collect: block
	"Execute block for each of my elements and return a new instance of me containing the results."
	
	| result |
	result := self class new.
	self do: [ :each |
		result add: (block value: each) ].
	^ result! !

!DoubleLinkedList methodsFor: 'private' stamp: ''!
errorEmptyCollection
	"Signal a CollectionIsEmpty exception"
	
	CollectionIsEmpty signalWith: self! !

!DoubleLinkedList methodsFor: 'enumerating' stamp: ''!
reject: block
	"Execute block for each of my elements and return a new instance of me 
	containing those elements for which the block returned false."

	| result |
	result := self class new.
	self do: [ :each |
		(block value: each)
			ifFalse: [ result add: each ] ].
	^ result! !

!DoubleLinkedList methodsFor: 'removing' stamp: ''!
removeLast
	"Remove my last element.
	Signal a CollectionIsEmpty exception when I am empty.
	Return the removed internal link."

	| link |
	self emptyCheck.
	link := tail.
	tail := tail previousLink.
	tail 
		ifNil: [ head := nil ]
		ifNotNil: [ tail nextLink: nil ].
	link clearLinks.
	^ link! !

!DoubleLinkedList methodsFor: 'adding' stamp: ''!
addLast: anObjectOrLink
	"Add anObjectOrLink to me, so that it becomes the last one.
	Return the internal link object."

	| link |
	link := anObjectOrLink asDoubleLink.
	link previousLink: tail.
	tail ifNotNil: [ tail nextLink: link ].
	head ifNil: [ head := link ].
	tail := link.
	^ link! !

!DoubleLinkedList methodsFor: 'enumerating' stamp: ''!
reverseLinksDo: block
	"Execute block for each of the links that I hold internally, in reverse order."

	| current |
	current := tail.
	[ current isNil ] 
		whileFalse: [ 
	 		block value: current.
			current := current previousLink ]! !

!DoubleLinkedList methodsFor: 'accessing' stamp: ''!
lastLink
	"Return the last link that I hold, also known as my tail.
	Signal a CollectionIsEmpty excpetion when I am empty."
	
	self emptyCheck.
	^ tail! !

!DoubleLinkedList methodsFor: 'accessing' stamp: ''!
firstLink
	"Return the first link that I hold, also known as my head.
	Signal a CollectionIsEmpty excpetion when I am empty."
	
	self emptyCheck.
	^ head! !

!DoubleLinkedList methodsFor: 'adding' stamp: ''!
addFirst: anObjectOrLink
	"Add anObjectOrLink to me, so that it becomes the first one.
	Return the internal link object."
	
	| link |
	link := anObjectOrLink asDoubleLink.
	link nextLink: head.
	head ifNotNil: [ head previousLink: link ].
	tail ifNil: [ tail := link ].
	head := link.
	^ link! !

!DoubleLinkedList methodsFor: 'adding' stamp: ''!
add: anObjectOrLink beforeLink: otherLink
	"Add anObjectOrLink right before otherLink in me.
	When otherLink is not part of me, the result is undefined.
	Return the internal link object."

	| link otherLinkPredeccessor |
	otherLink = head
		ifTrue: [ ^ self addFirst: anObjectOrLink ].
	link := anObjectOrLink asDoubleLink.
	otherLinkPredeccessor := otherLink previousLink.
	otherLink previousLink: link.
	link nextLink: otherLink.
	link previousLink: otherLinkPredeccessor.
	otherLinkPredeccessor nextLink: link.
	^ link! !

!DoubleLinkedList methodsFor: '*NewTools-Spotter' stamp: ''!
stTail

	^ tail! !

!DoubleLinkedList methodsFor: 'removing' stamp: ''!
removeAll
	"Remove all the elements that I hold."
	
	head := tail := nil! !

!DoubleLinkedList methodsFor: '*NewTools-Spotter' stamp: ''!
stRemoveCycledLink: link
	| predecessor successor |
	predecessor := link previousLink.
	successor := link nextLink.
	predecessor
		ifNil: [ head := successor ]
		ifNotNil: [ predecessor nextLink: successor ].
	successor
		ifNil: [ tail := predecessor ]
		ifNotNil: [ successor previousLink: predecessor ].
	link clearLinks.
	
	"I'm the only one left, clear linked list and return"
	(link = head & (link = tail)) ifTrue: [ head := nil. tail := nil. ^ link ].
	
	link = head ifTrue: [ head := successor ].
	link = tail ifTrue: [ tail := predecessor ].
	
	^ link! !

!DoubleLinkedList methodsFor: '*NewTools-Spotter' stamp: ''!
stNoneSatisfy: 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! !

!DoubleLinkedList methodsFor: 'adding' stamp: ''!
addAll: collection
	"Add all elements of collection to me, in order.
	Each can be either a value object or a link."
	
	collection do: [ :each | self add: each ]! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testOne
	| list |
	list := DoubleLinkedList new.
	list add: #one.
	self deny: list isEmpty.
	self assert: list first equals: #one.
	self assert: list last equals: #one.
	self assert: list asArray equals: #( one )! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testAddLast
	| list |
	list := DoubleLinkedList new.
	1 to: 3 do: [ :each | list add: each ].
	list addLast: 0.
	self deny: list isEmpty.
	self assert: list first equals: 1.
	self assert: list last equals: 0.
	self assert: list asArray equals: #( 1 2 3 0 )! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testIncludes
	| list |
	list := DoubleLinkedList new.
	list addAll: (1 to: 10).
	self assert: (list includes: 5).
	self deny: (list includes: 0)! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testReject
	| list even |
	list := DoubleLinkedList new.
	list addAll: (1 to: 10).
	even := list reject: [ :each | each odd ].
	self assert: even asArray equals: #(2 4 6 8 10)! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testDo
	| list value |
	list := DoubleLinkedList new.
	list addAll: (1 to: 10).
	value := 1.
	list do: [ :each |
		self assert: each equals: value.
		value := value + 1 ]! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testAddAfterLink
	| list link |
	list := DoubleLinkedList new.
	list add: 1.
	link := list add: 2.
	list add: 3.
	list add: 0 afterLink: link.
	self assert: list asArray equals: #( 1 2 0 3 )! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testThreeRemoveFirst
	| list link |
	list := DoubleLinkedList new.
	1 to: 3 do: [ :each | list add: each ].
	link := list removeFirst.
	self assert: link value equals: 1.
	self assert: list first equals: 2.
	self assert: list last equals: 3.
	self assert: list asArray equals: #( 2 3 )! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testThreeRemoveLast
	| list link |
	list := DoubleLinkedList new.
	1 to: 3 do: [ :each | list add: each ].
	link := list removeLast.
	self assert: link value equals: 3.
	self assert: list first equals: 1.
	self assert: list last equals: 2.
	self assert: list asArray equals: #( 1 2 )! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testReverseDo
	| list value |
	list := DoubleLinkedList new.
	list addAll: (1 to: 10).
	value := 10.
	list reverseDo: [ :each |
		self assert: each equals: value.
		value := value - 1 ]! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testEmpty
	| list |
	list := DoubleLinkedList new.
	self assertEmpty: list.
	self should: [ list first ] raise: CollectionIsEmpty.
	self should: [ list last ] raise: CollectionIsEmpty.
	list do: [ :each | self fail ]! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testOneRemoveLast
	| list |
	list := DoubleLinkedList new.
	list add: #one.
	list removeLast.
	self assertEmpty: list.
	list add: #one.
	list removeLast.
	self assertEmpty: list! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testThree
	| list |
	list := DoubleLinkedList new.
	1 to: 3 do: [ :each | list add: each ].
	self deny: list isEmpty.
	self assert: list first equals: 1.
	self assert: list last equals: 3.
	self assert: list asArray equals: #( 1 2 3 )! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testLinksDo
	| list links index |
	list := DoubleLinkedList new.
	links := OrderedCollection new.
	1 to: 10 do: [ :each |
		links add: (list add: each) ].
	index := 1.
	list linksDo: [ :each |
		self assert: each equals: (links at: index).
		self assert: each value equals: index.
		index := index + 1 ]! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testSelect
	| list even |
	list := DoubleLinkedList new.
	list addAll: (1 to: 10).
	even := list select: [ :each | each even ].
	self assert: even asArray equals: #(2 4 6 8 10)! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testAddFirst
	| list |
	list := DoubleLinkedList new.
	1 to: 3 do: [ :each | list add: each ].
	list addFirst: 0.
	self deny: list isEmpty.
	self assert: list first equals: 0.
	self assert: list last equals: 3.
	self assert: list asArray equals: #( 0 1 2 3 )! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testFirstAndLastLink
	| list firstLink secondLink |
	list := DoubleLinkedList new.
	self should: [ list firstLink ] raise: CollectionIsEmpty.
	self should: [ list lastLink ] raise: CollectionIsEmpty.
	self should: [ list first ] raise: CollectionIsEmpty.
	self should: [ list last ] raise: CollectionIsEmpty.
	firstLink := list add: #one.
	self assert: list firstLink equals: firstLink.
	self assert: list first equals: list last.
	self assert: list firstLink equals: list lastLink.
	self assert: list firstLink value equals: #one.
	secondLink := list add: #two.
	self assert: list firstLink equals: firstLink.
	self assert: list lastLink equals: secondLink.
	self deny: list first equals: list last.
	self deny: list firstLink equals: list lastLink.
	self assert: list firstLink value equals: #one.
	self assert: list lastLink value equals: #two! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testCollect
	| list doubles |
	list := DoubleLinkedList new.
	list addAll: #(1 2 3).
	doubles := list collect: [ :each | each * 2 ].
	self assert: doubles asArray equals: #(2 4 6)! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testReverseLinksDo
	| list links index |
	list := DoubleLinkedList new.
	links := OrderedCollection new.
	1 to: 10 do: [ :each |
		links add: (list add: each) ].
	index := 10.
	list reverseLinksDo: [ :each |
		self assert: each equals: (links at: index).
		self assert: each value equals: index.
		index := index - 1 ]! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testAddBeforeLink
	| list link |
	list := DoubleLinkedList new.
	list add: 1.
	link := list add: 2.
	list add: 3.
	list add: 0 beforeLink: link.
	self assert: list asArray equals: #( 1 0 2 3 )! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testOneRemoveFirst
	| list |
	list := DoubleLinkedList new.
	list add: #one.
	list removeFirst.
	self assertEmpty: list.
	list add: #one.
	list removeLast.
	self assertEmpty: list! !

!DoubleLinkedListTest methodsFor: 'testing' stamp: ''!
testThreeRemoveLink
	| list link |
	list := DoubleLinkedList new.
	list add: 1.
	link := list add: 2.
	list add: 3.
	list removeLink: link.
	self assert: list first equals: 1.
	self assert: list last equals: 3.
	self assert: list asArray equals: #( 1 3 )! !

!DoubleWordArray commentStamp: ''!
DoubleWordArrays store 64-bit unsigned Integer values.

For further comments read comments of `WordArray`.!
!DoubleWordArray methodsFor: 'private' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !

!DoubleWordArray methodsFor: 'accessing' stamp: ''!
bytesPerElement
	"Number of bytes in each item.  This multiplied by (self size)*8 gives the number of bits stored."
	^ 8! !

!DoubleWordArray methodsFor: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	self pinInMemory.
	^ PointerUtils oopForObject: self
! !

!DoubleWordArray methodsFor: 'accessing' stamp: ''!
byteSize
	^self size * 8! !

!DoubleWordArray methodsFor: 'private' stamp: ''!
atAllPut: value
	"Fill the receiver with the given value"

	<primitive: 145>
	super atAllPut: value! !

!DoubleWordArray methodsFor: 'accessing' stamp: ''!
defaultElement
	"Return the default element of the receiver"
	^0! !

!DoubleWordLayout commentStamp: ''!
I am a raw data layout that holds double words (64 bit).!
!DoubleWordLayout methodsFor: 'testing' stamp: ''!
isDoubleWords
	^ true! !

!DoubleWordLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGDoubleWordLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)]! !

!DoubleWordLayout methodsFor: 'extending' stamp: ''!
extendDoubleWord
	^ DoubleWordLayout new! !

!DoubleWordLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	^ 9! !

!DoubleWordLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else!!"
	^#variableDoubleWordSubclass:! !

!DoubleWordLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass
	^ superLayout extendDoubleWord
		host: aClass;
		yourself! !

!DrTests commentStamp: ''!
I provide the ability to: 
* select a plugin to create/run tests
* select sets of items to analyze
* obtain a detailed log of the results 

UI Description 
___________ 

The droplist contains all the plugins available to start the analysis. 

My left-most pane lists all of the categories that contain items (could subclasses of TestCase, executable comments, etc.); Once items are selected, the items that can be analyzed appear in the pane to right.
The right-most pane shows the results in different groups, depends the plugin's analysis. 

Run and browse buttons behaviour are defined by the current plugin selected.

!
!DrTests methodsFor: 'accessing' stamp: ''!
pluginPresenter
	^ pluginPresenter! !

!DrTests methodsFor: 'accessing' stamp: ''!
testsConfiguration

	testsConfiguration := self currentPlugin buildConfigurationFrom: self.
	^ testsConfiguration! !

!DrTests methodsFor: 'updating' stamp: ''!
updateSwitchButton: itemsSelected
	currentPlugin allowMiniDrTests
		ifTrue: [ switchButton enabled: itemsSelected isNotEmpty ]
		ifFalse: switchButton disable! !

!DrTests methodsFor: 'accessing' stamp: ''!
packagesSelected
	
	^ pluginPresenter packagesSelected! !

!DrTests methodsFor: 'private - initialization' stamp: ''!
initializePluginsDropList

	pluginsDropList := self newDropList.
	self pluginsDropList
		help: 'Select the plugin used by Dr Tests UI.';
		items: self plugins;
		display: [ :pluginClass | pluginClass pluginName ];
		iconBlock: [ :pluginClass | pluginClass pluginIcon ];
		whenSelectedItemChangedDo: [ :pluginClass | self currentPlugin: pluginClass new ]! !

!DrTests methodsFor: 'private - initialization' stamp: ''!
initializeButtons

	super initializeButtons.

	switchButton
		label: 'Minimize';
		disable.! !

!DrTests methodsFor: 'private' stamp: ''!
dateAndTimeString

	^ DateAndTime now asStringYMDHM! !

!DrTests methodsFor: 'api - locking' stamp: ''!
subwidgetsToLock

	^ pluginPresenter subwidgetsToLock! !

!DrTests methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aDomainObject

	plugins := aDomainObject! !

!DrTests methodsFor: 'accessing' stamp: ''!
currentPlugin: aPlugin

	super currentPlugin: aPlugin.
	pluginPresenter := self instantiate: aPlugin pluginPresenterClass on: {aPlugin. self}.
	
	self rebuildLayout.
	
	self updateStatus: aPlugin pluginName , ' plugin is ready to work!!' translated! !

!DrTests methodsFor: 'actions' stamp: ''!
switchUI

	super switchUI.
	self switchToMiniDrTest! !

!DrTests methodsFor: 'accessing' stamp: ''!
title

	^ 'Dr Tests - ' , currentPlugin pluginName! !

!DrTests methodsFor: 'private' stamp: ''!
menuForSelectedResult: menu

	self resultSelected ifNil: [ ^ self ].
	self resultSelected content drTestsBuildContextMenu: menu! !

!DrTests methodsFor: 'accessing' stamp: ''!
plugins

	^ plugins ifNil: [ DrTestsPlugin availablePlugins ]! !

!DrTests methodsFor: 'updating' stamp: ''!
updateStatus: aString
	self statusLabel
		label: ('{1}: {2}' format: { self dateAndTimeString . aString }).! !

!DrTests methodsFor: 'accessing - subwidgets' stamp: ''!
statusLabel

	^ statusLabel! !

!DrTests methodsFor: 'updating' stamp: ''!
updateWithResults: results

	pluginResult := results.
	pluginPresenter updateWithResults: results! !

!DrTests methodsFor: 'accessing' stamp: ''!
testsConfiguration: aDTTestsConfiguration

	self pluginPresenter packagesList selectItems: aDTTestsConfiguration packagesSelected.
	self pluginPresenter itemsList selectItems: aDTTestsConfiguration items! !

!DrTests methodsFor: 'accessing - subwidgets' stamp: ''!
pluginsDropList

	^ pluginsDropList! !

!DrTests methodsFor: 'private - initialization' stamp: ''!
initializeStatusLabel

	statusLabel := self newLabel! !

!DrTests methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter
		title:  self title;
		initialExtent: 700 @ 500;
		statusBar: statusLabel! !

!DrTests methodsFor: 'accessing' stamp: ''!
selectedItems
	
	^ pluginPresenter selectedItems! !

!DrTests methodsFor: 'updating' stamp: ''!
updateUI
	super updateUI.
	
	pluginPresenter updateUI.! !

!DrTests methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
		
	self
		initializeStatusLabel;
		initializePluginsDropList;
		initializePluginPresenter! !

!DrTests methodsFor: 'initialization' stamp: ''!
connectPresenters

	super connectPresenters.
	self pluginsDropList selectIndex: 1! !

!DrTests methodsFor: 'private - initialization' stamp: ''!
initializePluginPresenter

	pluginPresenter := self instantiate: DTNullPluginPresenter! !

!DrTests methodsFor: 'private - actions' stamp: ''!
switchToMiniDrTest

	(MiniDrTests new
		testsConfiguration: self testsConfiguration;
		currentPlugin: self currentPlugin;
		updateWithPluginResult:self pluginResult ;
		yourself) openWithSpec! !

!DrTests class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #pluginsDropList;
				add: #switchButton
					withConstraints: [ :constraints | constraints width: self buttonWidth * 2 ];
				yourself)
			withConstraints: [ :constraints | 
				constraints
					expand: false;
					height: self toolbarHeight ];
		add: #pluginPresenter;
		yourself! !

!DrTests class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	"Note: For now, DrTests is only available for preview, thus the following code is commented."
	
	"Add DrTests to registry to replace the old test runner." 
	"registry register: self as: #testRunner"! !

!DrTests class methodsFor: 'tools registry' stamp: ''!
beDefaultTestRunner
	<script>
	
	self registerToolsOn: Smalltalk tools! !

!DrTests class methodsFor: 'instance creation' stamp: ''!
reloadConfiguration: aDTPluginConfiguration withResults: aDTPluginResult andPlugin: aDTPlugin

	self open
		updateStatus: 'Tests finished.';
		currentPlugin: aDTPlugin;
		testsConfiguration: aDTPluginConfiguration;
		updateWithPluginResult: aDTPluginResult! !

!DrTests class methodsFor: 'api' stamp: ''!
open
	<script>
	
	^ self new
		openWithSpec;
		yourself! !

!DrTests class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	
	(aBuilder item: #'Dr Test (Preview)')
		parent: #Testing;
		action: [ self open ];
		order: 2;
		"keyText: 'o, u';" "Note: Removed the shortcut to not clash with SUnitRunner keybinding."
		help: '(Preview) Let you run and debug SUnit tests.';
		icon: self taskbarIcon;
		withSeparatorAfter! !

!DrTestsPlugin commentStamp: ''!
I am a Plugin used to execute an analysis

To run, I need a DTPluginConfiguration that contains the items I will analyse. I define the way to execute the analysis and create a result (could be a TestResult). !
!DrTestsPlugin methodsFor: 'api' stamp: ''!
allowMiniDrTests
	^ false! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
buildContextualMenuGroupWith: presenterInstance
	^ CmCommandGroup new! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
packagesAvailableForAnalysis
	^ RPackage organizer packages
		select: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase ] ]! !

!DrTestsPlugin methodsFor: 'ui' stamp: ''!
pluginPresenterClass
	
	^ DTDefaultPluginPresenter! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
itemsToBeAnalysedFor: packagesSelected
	"This method returns the items to be analysed by the plugin.
	For most plugins it will be TestCases but some plugins will return other objects like comments."

	^ packagesSelected
		flatCollect:
			[ :p | p definedClasses select: [ :c | c isTestCase ] ]! !

!DrTestsPlugin methodsFor: 'configuration building' stamp: ''!
buildConfigurationFrom: aDrTests
	"Builds a configuration from the plugin by reading the information held by the UI (aDrTests)."
	^ DTPluginConfiguration
		items: aDrTests selectedItems
		packages: aDrTests packagesSelected! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
runForConfiguration: aDTpluginConfiguration
	self subclassResponsibility! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
reRunForConfiguration: aDTpluginConfiguration! !

!DrTestsPlugin methodsFor: 'accessing' stamp: ''!
secondListLabel
	^ 'items'! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
unconfigureUI: aDrTestsUI
	"This hook is used by plugins to unconfigure the UI (e.g. unregister announcers).
	 It is called just before the UI switch to another plugin.
	 By default it does nothing.
	"
	self announcer unsubscribe: aDrTestsUI! !

!DrTestsPlugin methodsFor: '*DrTests-TestsRunner' stamp: ''!
buildReRunConfigurationFrom: aDrTests
	"Builds a configuration for the plugin by reading the information held by the UI (aDrTests) and the last value of results."

	^ DTReRunConfiguration new
		originalConfiguration: aDrTests testsConfiguration;
		previousResult: aDrTests pluginResult;
		configurationToRun: (DTTestsRunnerConfiguration items: aDrTests resultSelected contentForReRun);
		yourself! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
startButtonLabel
	^ self subclassResponsibility! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
announceStatusChanged: aMessage

	self announcer announce: (DTStatusUpdate message: aMessage)! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
setSelectionModeOfPackageList: aListPresenter
	aListPresenter beMultipleSelection! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
title
	^ self pluginName! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
pluginName
	^ self class pluginName! !

!DrTestsPlugin methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer ifNil: [ announcer := Announcer new ]! !

!DrTestsPlugin methodsFor: 'accessing' stamp: ''!
firstListLabel
	^ 'items'! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
setSelectionModeOfItemsList: aListPresenter
	aListPresenter beMultipleSelection! !

!DrTestsPlugin methodsFor: 'ui' stamp: ''!
announceResultsChanged: someResults

	self announcer announce: (DTUpdateResults new
			 results: someResults;
			 yourself)! !

!DrTestsPlugin methodsFor: 'accessing' stamp: ''!
resultTreeViews
	"Return result tree views available."
	
	| pragmas |
	pragmas := Pragma allNamed: self pragmaForResultTrees in: self pluginResultClass.

	^ ((pragmas sorted: [ :p | p argumentAt: 2 ] asSortFunction) collect: [ :pragma |
		DTResultTreeView name: (pragma argumentAt: 1) blockToExtractViewFromResult: pragma methodSelector ])! !

!DrTestsPlugin methodsFor: 'accessing' stamp: ''!
pragmaForResultTrees
	"Returns the selector of the pragma to gather result trees."
	^ self subclassResponsibility! !

!DrTestsPlugin methodsFor: 'accessing' stamp: ''!
pluginResultClass
	^ self class pluginResultClass! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
resultButtonHelp
	^ self subclassResponsibility! !

!DrTestsPlugin methodsFor: 'api' stamp: ''!
startButtonHelp
	^ self subclassResponsibility! !

!DrTestsPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginIcon
	^ self iconNamed: #blank! !

!DrTestsPlugin class methodsFor: 'api - plugins' stamp: ''!
availablePlugins
	^ (self allSubclasses reject: #isAbstract)
			sort: [ :a :b | a weight < b weight ]! !

!DrTestsPlugin class methodsFor: 'api - accessing' stamp: ''!
weight
	"The lighter is a plugin, the higher it is displayed in the drop list for plugin selection."
	^ self subclassResponsibility! !

!DrTestsPlugin class methodsFor: 'testing' stamp: ''!
isAbstract
	"Should return true if the plugin is abstract and should not be instantiated."
	^ self = DrTestsPlugin! !

!DrTestsPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginResultClass
	"Returns the class that this plugin instantiate for its results."
	^ self subclassResponsibility! !

!DrTestsPlugin class methodsFor: 'api - accessing' stamp: ''!
pluginName
	"The name of the plugin to be displayed in DrTests UI."
	^ self subclassResponsibility! !

!DrTestsTestRunnerTest commentStamp: ''!
A DrTestsUITest is a test class for testing the behavior of DrTests-TestRunner!
!DrTestsTestRunnerTest methodsFor: 'tests' stamp: ''!
testReRunResultIsDTTestRunnerResult
	| pluginResult |
	pluginResult := plugin runForConfiguration: conf.
	reRunconf := DTReRunConfiguration new
		previousResult: pluginResult;
		configurationToRun: (DTTestsRunnerConfiguration items: { testToReRun });
		yourself.
	self
		assert: (plugin runForConfiguration: reRunconf) class
		equals: DTTestsRunnerResult! !

!DrTestsTestRunnerTest methodsFor: 'tests' stamp: ''!
testRunResultBuildTreeForUI
	self
		assert: (plugin runForConfiguration: conf) buildTreeForUI class
		equals: DTTreeNode! !

!DrTestsTestRunnerTest methodsFor: 'tests' stamp: ''!
testAllSelectedClassesAreTestCases

	| thePackage |
	thePackage := plugin packagesAvailableForAnalysis anyOne.
	self assert: ((plugin itemsToBeAnalysedFor: {thePackage}) flattened allSatisfy: [ :each | each isTestCase ])! !

!DrTestsTestRunnerTest methodsFor: 'tests' stamp: ''!
testSelectedPackagesContainTestCases

	self assert: (plugin packagesAvailableForAnalysis allSatisfy: [ :pkg |
		pkg definedClasses anySatisfy: [ :class |
			class isTestCase ] ])! !

!DrTestsTestRunnerTest methodsFor: 'tests' stamp: ''!
testRunResultIsDTTestRunnerResult
	self
		assert: (plugin runForConfiguration: conf) class
		equals: DTTestsRunnerResult! !

!DrTestsTestRunnerTest methodsFor: 'tests' stamp: ''!
testTestResultIsNotEmpty
	self
		deny: (plugin runForConfiguration: conf) testResults passed isEmpty! !

!DrTestsTestRunnerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	package := RPackage organizer
		packageNamed: 'DrTests-TestCoverage-Tests-Mocks'.
	testToReRun := DTCoverageMockTest
		selector: #testMethod1forMock.
	testCase := DTCoverageMockTest.
	conf := DTPluginConfiguration
		items:
			({package}
				flatCollect:
					[ :p | p definedClasses select: [ :c | c allSuperclasses includes: TestCase ] ])
		packages: {package}.
	reRunconf := DTReRunConfiguration new.
	plugin := DTTestsRunnerPlugin new! !

!DrTestsTestRunnerUITest commentStamp: ''!
A DrTestsUITest is a test class for testing the behavior of DrTests-TestRunner UI!
!DrTestsTestRunnerUITest methodsFor: 'tests' stamp: ''!
testRunTestsUpdatesUIWithResults

	drTest pluginPresenter startButton performAction.
	self assert: drTest pluginPresenter resultsList roots notEmpty! !

!DrTestsTestRunnerUITest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	drTest := DrTests on: { DTTestsRunnerPlugin }.! !

!DrTestsUITest commentStamp: ''!
A DrTestsUITest is a test class for testing the behavior of DrTestsUI!
!DrTestsUITest methodsFor: 'tests' stamp: ''!
testInitialWindowTitleIsInitialPluginWindowTitle

	self
		assert: drTestsUI title
		equals: 'Dr Tests - ' , drTestsUI currentPlugin pluginName! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testPluginsAreConfiguredPluginsOnly
	self
		assert: drTestsUI pluginsDropList listItems asArray
		equals: plugins! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testInitialResultListIsEmpty

	self assert: drTestsUI pluginPresenter resultsList roots isEmpty! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testInitialStatusIsInitialStatusPluginName
	|status|
	status:= (drTestsUI currentPlugin pluginName , ' plugin is ready to work!!') translated.
			
	self
		assert: drTestsUI statusLabel label
		equals: ('{1}: {2}' format: { (drTestsUI  dateAndTimeString ). status }).! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testSelectingPackageWillUpdateTheClassesList
	| newPackagesSelected |
	newPackagesSelected := {drTestsUI pluginPresenter packagesList items
		anyOne}.
	drTestsUI pluginPresenter whenPackagesSelectionChanged: newPackagesSelected.
	self
		assertCollection: drTestsUI pluginPresenter itemsList items
		hasSameElements: (drTestsUI currentPlugin itemsToBeAnalysedFor: newPackagesSelected)! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testInitialPackagesAreInitialPluginPackages
	self
		assertCollection: drTestsUI pluginPresenter packagesList items
		hasSameElements: drTestsUI currentPlugin packagesAvailableForAnalysis! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testSelectingPluginWillUpdatePackagesList
	drTestsUI pluginsDropList selectItem: plugin2.
	self
		assertCollection: drTestsUI pluginPresenter packagesList items
		hasSameElements:
		drTestsUI currentPlugin packagesAvailableForAnalysis! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testInitialSelectedPluginIsFirstPluginInList

	self assert: drTestsUI currentPlugin class equals: plugins first! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testCurrentPluginIsSelectedInDropDown
	| currentPluginSelected  |
	currentPluginSelected := drTestsUI pluginsDropList selectedItem.
	self
		assert: drTestsUI currentPlugin class
		equals: currentPluginSelected! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testStartButtonLabelIsCurrentPluginStartButtonLabel
	
	self
		assert: drTestsUI pluginPresenter startButton label
		equals: drTestsUI currentPlugin startButtonLabel! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testClickButtonRunCallsPluginRun
	drTestsUI pluginsDropList selectItem: DTMockPlugin.
	drTestsUI pluginPresenter startButton performAction.
	self assert: drTestsUI currentPlugin hasBeenRun! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testNoPackageSelected
	self
		assertCollection: drTestsUI pluginPresenter itemsList items
		hasSameElements: #()! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testSelectingPluginWillUpdateCurrentPluginInstanceVariable
	drTestsUI pluginsDropList selectItem: plugin2.
	self assert: drTestsUI currentPlugin class equals: plugin2! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testSelectingPluginWillUpdateWindowTitle
	drTestsUI pluginsDropList selectItem: plugin2.
	self
		assert: drTestsUI title
		equals: 'Dr Tests - ' , drTestsUI currentPlugin pluginName! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testMultipleSelectingPackagesWillUpdateTheClassesList
	| currentPluginSelected randomPackage newPackagesSelected classesList packageSelected |
	currentPluginSelected := drTestsUI pluginsDropList selectedItem.
	newPackagesSelected := OrderedCollection new.
	packageSelected := drTestsUI pluginPresenter packagesList items anyOne.
	randomPackage := (drTestsUI pluginPresenter packagesList items
		\ {packageSelected}) anyOne.
	newPackagesSelected add: packageSelected.
	newPackagesSelected add: randomPackage.
	drTestsUI pluginPresenter whenPackagesSelectionChanged: newPackagesSelected.
	classesList := currentPluginSelected new
		itemsToBeAnalysedFor: newPackagesSelected.
	self
		assertCollection: drTestsUI pluginPresenter itemsList items
		hasSameElements: classesList flattened! !

!DrTestsUITest methodsFor: 'tests' stamp: ''!
testStartButtonHelpIsCurrentPluginStartButtonHelp
	
	self
		assert: drTestsUI pluginPresenter startButton help
		equals: drTestsUI currentPlugin startButtonHelp! !

!DrTestsUITest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."

	super setUp.
	plugin1 := DTTestsRunnerPlugin.
	plugin2 := DTMockPlugin.
	plugins := {plugin1. plugin2}.
	drTestsUI := DrTests on: plugins! !

!DraggableCallback commentStamp: ''!
I represent a callback to make the window draggable from any chosen rectangle. Useful for undecorated windows.

Warning : Only available with SDL 2.0.4 or higher !!!
!DraggableCallback class methodsFor: 'callback spec' stamp: ''!
fnSpec

	^'int ( SDL_Window aWindow, SDL_Point* pt, void* data )'! !

!DraggableCallback class methodsFor: 'instance creation' stamp: ''!
on: aBlock
	^ self 
		signature: self fnSpec
		block: aBlock! !

!DropEvent commentStamp: ''!
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: ''!
position
	^position! !

!DropEvent methodsFor: 'testing' stamp: ''!
isDropEvent
	^true! !

!DropEvent methodsFor: 'accessing' stamp: ''!
wasHandled
	^wasHandled! !

!DropEvent methodsFor: 'accessing' stamp: ''!
wasHandled: aBool
	wasHandled := aBool.! !

!DropEvent methodsFor: 'dispatching' stamp: ''!
sentTo: anObject
	"Dispatch the receiver into anObject"
	^anObject handleDropMorph: self! !

!DropEvent methodsFor: 'transforming' stamp: ''!
transformBy: aMorphicTransform
	"Transform the receiver into a local coordinate system."
	position :=  aMorphicTransform globalPointToLocal: position.! !

!DropEvent methodsFor: 'initialize' stamp: ''!
copyHandlerState: anEvent
	"Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
	wasHandled := anEvent wasHandled.! !

!DropEvent methodsFor: 'accessing' stamp: ''!
cursorPoint
	"For compatibility with mouse events"
	^position! !

!DropEvent methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPut: $[.
	aStream print: self position ; space.
	aStream nextPutAll: self type; space.
	aStream print: self windowIndex .
	aStream nextPut: $].! !

!DropEvent methodsFor: 'private' stamp: ''!
setPosition: pos contents: aMorph hand: aHand
	position := pos.
	contents := aMorph.
	source := aHand.
	wasHandled := false.! !

!DropEvent methodsFor: 'initialize' stamp: ''!
resetHandlerFields
	"Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"
	wasHandled := false.! !

!DropEvent methodsFor: 'accessing' stamp: ''!
contents
	^contents! !

!DropEvent methodsFor: 'transforming' stamp: ''!
transformedBy: aMorphicTransform
	"Return the receiver transformed by the given transform into a local coordinate system."
	^self shallowCopy transformBy: aMorphicTransform! !

!DropEvent methodsFor: 'accessing' stamp: ''!
type
	^#dropEvent! !

!DropFilesEvent commentStamp: ''!
This event is sent when an external file is dropped into the image itself.

The event can be used by any Morph implementing:

#wantsDropFiles: anEvent 
#dropFiles: anEvent 



!
!DropFilesEvent methodsFor: 'dispatching' stamp: ''!
sentTo: anObject
	"Dispatch the receiver into anObject"
	^anObject handleDropFiles: self! !

!DropFilesEvent methodsFor: 'accessing' stamp: ''!
fileNames
	^ fileNames! !

!DropFilesEvent methodsFor: 'dispatching' stamp: ''!
requestDropReference: i

	| fileName |	
	fileName := self fileNames at: i.
	^ fileName asFileReference! !

!DropFilesEvent methodsFor: 'accessing' stamp: ''!
fileNames: anObject
	fileNames := anObject! !

!DropFilesEvent methodsFor: 'accessing' stamp: ''!
type
	^#dropFilesEvent! !

!DropListButton commentStamp: ''!
I am an elementary Spec widget that associates a DropListPresenter and a ButtonPresenter.

self example

I provide accessors dropList and input and shortcuts for the most common methods of their api.!
!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
label
	self button label! !

!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
action: aBlock
	self button action: aBlock! !

!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
emptyList
	self dropList emptyList! !

!DropListButton methodsFor: 'events - shortcuts' stamp: ''!
whenSelectedItemChanged: aBlock
	self dropList
		whenSelectedItemChanged: aBlock! !

!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
selectedItem
	self dropList selectedItem! !

!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
label: aStringOrImageMorph
	self button label: aStringOrImageMorph! !

!DropListButton methodsFor: 'initialization' stamp: ''!
initializeWidgets
	dropList := self instantiate: DropListPresenter.
	button := self instantiate: ButtonPresenter.
	self focusOrder
		add: dropList;
		add: button! !

!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
setIndex: anIndex
	self dropList setIndex: anIndex! !

!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
listSize
	self dropList listSize! !

!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
resetSelection
	self dropList resetSelection! !

!DropListButton methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionIndexChanged: aBlock
	self dropList
		whenSelectionIndexChanged: aBlock! !

!DropListButton methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionChanged: aBlock
	self dropList
		whenSelectionChanged: aBlock! !

!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
items: aList
	self dropList items: aList! !

!DropListButton methodsFor: 'accessing' stamp: ''!
button
	^ button! !

!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
displayBlock: aBlock
	self dropList displayBlock: aBlock! !

!DropListButton methodsFor: 'accessing' stamp: ''!
dropList
	^ dropList! !

!DropListButton methodsFor: 'api - shortcuts' stamp: ''!
icon: anIcon
	self button icon: anIcon! !

!DropListButton class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	
	example := self new.
	example
		displayBlock: [ :item | item asString ];
		items: {'Swordian' . 'Gardian' . 'Wizard' . 'Sniper'};
		label: 'Add';
		extent: 300 @ 70;
		title: 'DropListButton example';
		openWithSpec.
	^ example! !

!DropListButton class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newRow: [ :row | 
			row
				add: #dropList origin: 0 @ 0 corner: 0.8 @ 1;
				add: #button origin: 0.8 @ 0 corner: 1 @ 1 ];
		yourself! !

!DropListItem commentStamp: ''!
A DropListItem is an item (wrapper) designed to fit into a DropList!
!DropListItem methodsFor: 'protocol' stamp: ''!
action: aBlock

	actionHolder value: aBlock! !

!DropListItem methodsFor: 'comparing' stamp: ''!
= another

	self species = another species ifFalse: [ ^ false ].
	^ self label = another label and: [ self actionHolder = another actionHolder ]! !

!DropListItem methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	actionHolder := [  ] asValueHolder.
	displayBlock := [ :e | e printString ]! !

!DropListItem methodsFor: 'accessing' stamp: ''!
label: anObject
	"For compatibility with old raw-string usage. Send #display: instead"
	
	displayBlock := [ anObject ].! !

!DropListItem methodsFor: 'accessing' stamp: ''!
actionHolder
	
	^ actionHolder! !

!DropListItem methodsFor: 'protocol' stamp: ''!
display: aBlock
	"aBlock - 1 optional argument, which is the underlying item; returns the string to be displayed"

	displayBlock := aBlock.! !

!DropListItem methodsFor: 'execution' stamp: ''!
value
	"This way, I am polymorphic with nil"

	actionHolder value cull: self label cull: self! !

!DropListItem methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!DropListItem methodsFor: 'private' stamp: ''!
model: anObject

	model := anObject.! !

!DropListItem methodsFor: 'accessing' stamp: ''!
model

	^ model.! !

!DropListItem methodsFor: 'accessing' stamp: ''!
icon: anObject
	icon := anObject! !

!DropListItem methodsFor: 'accessing' stamp: ''!
label
	
	^ displayBlock cull: model.! !

!DropListItem class methodsFor: 'instance creation' stamp: ''!
named: label do: aBlock

	^ self new
		action: aBlock;
		model: label;
		display: [ :e | e ];
		yourself! !

!DropListItem class methodsFor: 'instance creation' stamp: ''!
on: anObject do: aBlock

	^ self new
		action: aBlock;
		model: anObject;
		yourself! !

!DropListMorph commentStamp: ''!
Displays a selected item and a drop button. When pressed will popup a list to enable changing of the selection. Supports enablement.!
!DropListMorph methodsFor: 'font accessing' stamp: ''!
listFont
	"Answer the list font"

	^self listMorph font! !

!DropListMorph methodsFor: 'protocol' stamp: ''!
popList

	"Hide / show the list."

	self enabled
		ifFalse: [ ^ self ].
	self listMorph owner ifNil: [ self showList ] ifNotNil: [ self hideList ]! !

!DropListMorph methodsFor: 'private' stamp: ''!
defaultContents
	"needs nothing to activate the ghostText"
	^ ''! !

!DropListMorph methodsFor: 'event handling' stamp: ''!
listMouseDown: evt
	"Click outside the list."

	(self listMorph fullContainsPoint: evt position)
		ifTrue: [ self listMorph changeModelSelection: (self listMorph rowAtLocation: evt position) ].
	self hideList! !

!DropListMorph methodsFor: 'drawing' stamp: ''!
newContentMorph
	"Answer a new content morph"

	^ RubTextFieldArea new
		vResizing: #shrinkWrap;
		hResizing: #spaceFill;
		beReadOnly;
		lock;
		yourself! !

!DropListMorph methodsFor: 'event handling' stamp: ''!
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: 'protocol' stamp: ''!
showList

	"Show the list."

	self listMorph owner
		ifNil: [ 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: 'drawing' stamp: ''!
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: 'wiw support' stamp: ''!
morphicLayerNumber
	"Answer the layer number."

	^self listVisible ifTrue: [10] ifFalse: [super morphicLayerNumber]! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
contentMorph
	"Answer the value of contentMorph"

	^ contentMorph! !

!DropListMorph methodsFor: 'private' stamp: ''!
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: 'drawing' stamp: ''!
newListMorph
	"Answer a new list morph"

	|m|
	m := (self listMorphClass
		on: self
		list: #list
		selected: #listSelectionIndex
		changeSelected: #listSelectionIndex:
		menu: nil
		keystroke: nil)
			autoDeselect: false;
			wrapSelector: #wrapItem:index:;
			roundedCorners: #(2 3);
			setProperty: #morphicLayerNumber toValue: 5;
			"color: self color;"
			borderStyle: (self theme dropListNormalListBorderStyleFor: self);
			on: #mouseDown send: #listMouseDown: to: self.
	^m! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
getListSelector: anObject
	"Set the value of getListSelector"

	getListSelector := anObject! !

!DropListMorph methodsFor: 'updating' stamp: ''!
themeChanged
	"Update the selection colour."
	
	self color: self defaultColor.
	self selectionColor ifNotNil: [
		self selectionColor: self theme selectionColor].
	self layoutInset: self layoutInsetToUse.
	self buttonMorph extent: self buttonExtent.
	self buttonMorph cornerStyle: self cornerStyle.
	self buttonMorph label: self buttonLabel.
	self updateContentColor: nil.
	self listMorph themeChanged.
	super themeChanged.! !

!DropListMorph methodsFor: 'private' stamp: ''!
buttonHeight
	"Answer based on theme."
	
	^self theme buttonMinHeight! !

!DropListMorph methodsFor: 'enablement' stamp: ''!
toggleEnabled
	"Toggle the enabled state."

	self enabled: self enabled not! !

!DropListMorph methodsFor: 'private' stamp: ''!
listHeight
	"Answer the height for the list."

	^(self listMorph listMorph height + 6 max: 38) min: (15 * self listFont height)! !

!DropListMorph methodsFor: 'updating' stamp: ''!
updateEnabled
	"Update the enablement state."

	self model ifNotNil: [
		self getEnabledSelector ifNotNil: [
			self enabled: (self model perform: self getEnabledSelector)]]! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
useSelectionIndex: anObject
	"Set the value of useSelectionIndex"

	useSelectionIndex := anObject! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
allowKeyboardFocus
	"Answer whether or not keyboard focus will be allowed."

	^self valueOfProperty: #allowKeyboardFocus ifAbsent: [true]! !

!DropListMorph methodsFor: 'drawing' stamp: ''!
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: 'accessing' stamp: ''!
listSelectionIndex: anInteger
	"Set the list selection."

	self hideList.
	anInteger = 0 ifTrue: [^self].
	listSelectionIndex := anInteger.
	self
		changed: #listSelectionIndex;
		updateContents;
		triggerEvent: #selectionIndex with: anInteger.
	self model ifNotNil: [:m | 
		self setIndexSelector ifNotNil: [:s |
			self useSelectionIndex
				ifTrue: [m perform: s with: anInteger]
				ifFalse: [m perform: s with: self selectedItem]]]! !

!DropListMorph methodsFor: 'private' stamp: ''!
buttonLabel
	"Answer the label for the button."

	^self theme dropListButtonLabelFor: self! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
listMorph: anObject
	"Set the value of listMorph"

	listMorph := anObject.
	anObject 
			on: #keyStroke 
			send: #keyStroke: 
			to: self.! !

!DropListMorph methodsFor: 'drawing' stamp: ''!
newButtonMorph
	"Answer a new button morph"

	^(ControlButtonMorph
		on: self
		getState: nil
		action: #popList
		label: #buttonLabel)
			roundedCorners: #(3 4);
			getEnabledSelector: #enabled;
			label: self buttonLabel; 
			vResizing: #spaceFill;
			hResizing: #rigid;
			extent: self buttonExtent;
			setProperty: #wantsKeyboardFocusNavigation toValue: false;
			cornerStyle: self cornerStyle.! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
selectionColor: aColor
	"Set the selection color for the receiver."

	self listMorph selectionColor: aColor! !

!DropListMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	listSelectionIndex := 0.
	enabled := true.
	list := #().
	self
		useSelectionIndex: true;
		clipSubmorphs: true;
		layoutPolicy: RowLayout new;
		layoutInset: self layoutInsetToUse;
		cellPositioning: #center;
		listMorph: self newListMorph;
		contentMorph: self newContentMorph;
		buttonMorph: self newButtonMorph;
		fillStyle: self fillStyleToUse;
		borderStyle: self borderStyleToUse;
		addMorphBack: self contentMorph;
		addMorphBack: (self addDependent: self buttonMorph);
		on: #mouseDown send: #popList to: self;
		vResizing: #rigid;
		hResizing: #spaceFill;
		height: self font height + 10.
	self listMorph fillStyle: (self theme dropListNormalListFillStyleFor: self)! !

!DropListMorph methodsFor: 'protocol' stamp: ''!
selectedItem
	"Answer the selected list item."

	^(self listSelectionIndex between: 1 and: self list size) ifTrue: [
		self list at: self listSelectionIndex]! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
focusIndicatorCornerRadius
	"Answer the corner radius preferred for the focus indicator
	for the receiver for themes that support this."

	^self theme dropListFocusIndicatorCornerRadiusFor: self! !

!DropListMorph methodsFor: 'updating' stamp: ''!
updateListSelectionIndex

	"Update the list selection."

	| i |

	self useSelectionIndex
		ifTrue: [ i := self getCurrentSelectionIndex.
			listSelectionIndex = i
				ifTrue: [ ^ self ].
			listSelectionIndex := i
			]
		ifFalse: [ i := self getCurrentSelection.
			listSelectionIndex := i ifNil: [ 0 ] ifNotNil: [ self list indexOf: i ]
			].
	self
		changed: #listSelectionIndex;
		updateContents;
		triggerEvent: #selectionIndex with: i! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
contentMorph: anObject
	"Set the value of contentMorph"

	contentMorph := anObject! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
font: aFont
	"Set the content font"

	self contentMorph font: aFont! !

!DropListMorph methodsFor: 'protocol' stamp: ''!
enable
	"Enable the receiver."
	
	self enabled: true! !

!DropListMorph methodsFor: 'event handling' stamp: ''!
keyStroke: event
	"Pass on to the list."
	| indexToSelect |
	indexToSelect := self listMorph keyStroke: event.
	
	"If the returned value is not an integer, do not handle it"
	indexToSelect isInteger ifFalse: [ ^ self ].
	
	"If nothing found, do nothing"
	indexToSelect == 0 ifTrue: [ ^ self ].
	
	self listSelectionIndex: indexToSelect! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
enabled
	"Answer the value of enabled"

	^ enabled! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
getIndexSelector: anObject
	"Set the value of getIndexSelector"

	getIndexSelector := anObject! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
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: ''!
getListSelector
	"Answer the value of getListSelector"

	^ getListSelector! !

!DropListMorph methodsFor: 'stepping' stamp: ''!
wantsSteps
	"Step is very very time consuming..."
	^ false! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
setIndexSelector: anObject
	"Set the value of setIndexSelector"

	setIndexSelector := anObject! !

!DropListMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"Answer the default color of the receiver."

	^ self theme backgroundColor! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector: anObject
	"Set the value of getEnabledSelector"

	getEnabledSelector := anObject.
	self updateEnabled! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
listSelectionIndex
	"Answer the list selection."

	^listSelectionIndex! !

!DropListMorph methodsFor: 'protocol' stamp: ''!
useSelection
	"Use the model as returning the selected item rather than index."

	self useSelectionIndex: false! !

!DropListMorph methodsFor: 'private' stamp: ''!
layoutInsetToUse
	"Answer the layout inset that should be used."

	^self theme dropListInsetFor: self! !

!DropListMorph methodsFor: 'rounding' stamp: ''!
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: 'protocol' stamp: ''!
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: 'private' stamp: ''!
listMorphClass
	"Answer the class for a new list morph"

	^PluggableListMorph! !

!DropListMorph methodsFor: 'initialize' stamp: ''!
outOfWorld: aWorld
	"Get rid of the list if visible."

	self hideList.
	^super outOfWorld: aWorld! !

!DropListMorph methodsFor: 'stepping' stamp: ''!
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: 'wrapping' stamp: ''!
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: 'accessing' stamp: ''!
font
	"Answer the content font"

	^self contentMorph font! !

!DropListMorph methodsFor: 'updating' stamp: ''!
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: 'protocol' stamp: ''!
useIndex
	"Use the model as returning the selected index rather than item."

	self useSelectionIndex: true! !

!DropListMorph methodsFor: 'private' stamp: ''!
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: 'protocol' stamp: ''!
ghostText: aStringOrText
	self contentMorph ghostText: aStringOrText! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
allowKeyboardFocus: aBoolean
	"Set whether or not keyboard focus will be allowed."

	self setProperty: #allowKeyboardFocus toValue: aBoolean! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
focusBounds
	"Answer the bounds for drawing the focus indication."

	^self theme dropListFocusBoundsFor: self! !

!DropListMorph methodsFor: 'protocol' stamp: ''!
getCurrentSelectionIndex
	"Answer the index of the current selection."

	self getIndexSelector ifNil: [^0].
	^self model perform: self getIndexSelector! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
setIndexSelector
	"Answer the value of setIndexSelector"

	^ setIndexSelector! !

!DropListMorph methodsFor: 'event handling' stamp: ''!
keyDown: event
	
	event keyCharacter = Character escape ifTrue: [ self hideList ].
	(self navigationKey: event) ifTrue: [^self].
	
	event keyCharacter == Character cr
		ifTrue: [ ^ self listSelectionIndex: self listSelectionIndex ].

	^ false! !

!DropListMorph methodsFor: 'protocol' stamp: ''!
hideList
	"Hide the list."

	self listMorph ifNil: [^self].
	self listVisible ifFalse: [^self].
	self listMorph delete.
	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: 'testing' stamp: ''!
updateContents
	"Update the contents."

	self updateContentMorphWith:
		(self listSelectionIndex > 0
			ifTrue: [self listMorph wrapItem: (self list at: self listSelectionIndex) index: self listSelectionIndex ]
			ifFalse: [ '' ])! !

!DropListMorph methodsFor: 'updating' stamp: ''!
updateContentColor: paneColor
	"Change the content text color."
	
	self enabled
		ifTrue: [self contentMorph textColor: self theme textColor ]
		ifFalse: [self contentMorph textColor: self theme disabledColor ]! !

!DropListMorph methodsFor: 'wrapping' stamp: ''!
wrapSelector
	
	^ wrapSelector! !

!DropListMorph methodsFor: 'wrapping' stamp: ''!
wrapSelector: aSymbol
	
	wrapSelector := aSymbol.

	self updateList.
	self updateContents! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
drawSubmorphsOnAthensCanvas: anAthensCanvas
	super 	drawSubmorphsOnAthensCanvas: anAthensCanvas.
	self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOnAthensCanvas: anAthensCanvas].! !

!DropListMorph methodsFor: 'geometry' stamp: ''!
extent: newExtent
	"Update the gradient."
	
	super extent: newExtent.
	(self fillStyle notNil and: [self fillStyle isSolidFill not])
		ifTrue: [self fillStyle: self fillStyleToUse]! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
list
	"Answer the list contents."
	^list! !

!DropListMorph methodsFor: 'private' stamp: ''!
buttonExtent
	"Answer based on theme and preferences."
	
	^self buttonWidth @ self buttonHeight! !

!DropListMorph methodsFor: 'enablement' stamp: ''!
enabledString
	"Answer the string to be shown in a menu to represent the 'enabled' status"
	
	^ (self enabled) -> 'enabled' translated! !

!DropListMorph methodsFor: 'protocol' stamp: ''!
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: 'accessing' stamp: ''!
selectionColor
	"Answer the selection color for the receiver."

	^self listMorph selectionColor! !

!DropListMorph methodsFor: 'stepping' stamp: ''!
stepTime
	"Answer the desired time between steps in milliseconds."

	^100! !

!DropListMorph methodsFor: 'testing' stamp: ''!
wantsKeyboardFocus
	"Answer whether the receiver would like keyboard focus
	in the general case (mouse action normally)."

	^super wantsKeyboardFocus and: [
		self allowKeyboardFocus]! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
buttonMorph
	"Answer the value of buttonMorph"

	^ buttonMorph! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
roundedCorners: anArray
	"Set the corners to round."

	super roundedCorners: anArray.
	self buttonMorph ifNotNil: [:b |
		b roundedCorners: (anArray copyWithoutAll: #(1 2))]! !

!DropListMorph methodsFor: 'private' stamp: ''!
buttonWidth
	"Answer based on scrollbar size."
	
	^ (self theme scrollbarThickness + 3)
		max: self theme dropListControlButtonWidth! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
useSelectionIndex
	"Answer the value of useSelectionIndex"

	^ useSelectionIndex! !

!DropListMorph methodsFor: 'protocol' stamp: ''!
disable
	"Disable the receiver."
	
	self enabled: false! !

!DropListMorph methodsFor: 'menu & halo' stamp: ''!
addToggleItemsToHaloMenu: aCustomMenu 
	"Add toggle-items to the halo menu"
	
	super addToggleItemsToHaloMenu: aCustomMenu.
	aCustomMenu
		addUpdating: #enabledString
		target: self
		selector: #toggleEnabled! !

!DropListMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	"Return true if the receiver wishes to handle the given keyboard event."
	
	^true! !

!DropListMorph methodsFor: 'private' stamp: ''!
updateContentMorphWith: aString

	self contentMorph setTextWith: aString asString! !

!DropListMorph methodsFor: 'private' stamp: ''!
listVisible
	"Answer whether the list is visible."

	^self listMorph owner notNil! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
buttonMorph: anObject
	"Set the value of buttonMorph"

	buttonMorph := anObject! !

!DropListMorph methodsFor: '*Keymapping-Settings' stamp: ''!
initializeShortcuts: aKMDispatcher
	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #MorphFocusNavigation! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector
	"Answer the value of getEnabledSelector"

	^ getEnabledSelector! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
listMorph
	"Answer the value of listMorph"

	^ listMorph! !

!DropListMorph methodsFor: 'private' stamp: ''!
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: 'updating' stamp: ''!
updateList
	"Refresh the list."

	self getListSelector isSymbol ifTrue: [
		self list: (self model perform: self getListSelector).
		listSelectionIndex := 0]! !

!DropListMorph methodsFor: 'font creation' stamp: ''!
listFont: aFont
	"Set the list font"

	self listMorph font: aFont! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
getIndexSelector
	"Answer the value of getIndexSelector"

	^ getIndexSelector! !

!DropListMorph methodsFor: 'protocol' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!DropListMorph methodsFor: 'accessing' stamp: ''!
list: aCollection
	"Set the list contents."

	list := aCollection.
	self changed: #list! !

!DropListMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!DropListMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!DropListMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!DropListMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!DropListMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!DropListMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!DropListMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!DropListMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!DropListMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!DropListMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!DropListMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!DropListMorph class methodsFor: 'instance creation' stamp: ''!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel useIndex: useIndex
	"Answer a new instance of the receiver on the given model using
	the given selectors as the interface."

	^self new
		useSelectionIndex: useIndex;
		on: anObject 
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel! !

!DropListMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!DropListMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!DropListMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!DropListMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!DropListMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!DropListMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!DropListMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!DropListMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!DropListMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!DropListMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!DropListMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!DropListMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!DropListMorph class methodsFor: 'instance creation' stamp: ''!
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: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!DropListMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!DropListMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!DropListMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!DropListMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!DropListMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!DropListPresenter commentStamp: ''!
A DropListPresenter is a Spec presenter 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!
!DropListPresenter methodsFor: 'api' stamp: ''!
iconHolder

	^ iconHolder value! !

!DropListPresenter methodsFor: 'private' stamp: ''!
internalResetSelection

	selectionHolder reset.
	self getList ifNotEmpty: [ self silentlySetSelectedIndex: 1 ]! !

!DropListPresenter methodsFor: 'api' stamp: ''!
addItemLabeled: aString do: aBlock icon: anIcon

	| item |
	item := DropListItem named: aString do: aBlock.
	item icon: anIcon.
	"If you add directly in the contents, the update is not triggered from the value holder"
	listHolder add: item.! !

!DropListPresenter methodsFor: 'api' stamp: ''!
getIndex

	^ selectionHolder index value! !

!DropListPresenter methodsFor: 'api' stamp: ''!
getIconFor: anItem

	^ self iconHolder cull: anItem! !

!DropListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionIndexChanged: aBlock
	"Set a block to perform when the selected index is changed"

	selectionHolder index whenChangedDo: aBlock! !

!DropListPresenter methodsFor: 'private' stamp: ''!
selectedItemHolder

	^ selectionHolder selection! !

!DropListPresenter methodsFor: 'api' stamp: ''!
getList

	^ listHolder value! !

!DropListPresenter methodsFor: 'api' stamp: ''!
emptyList
	
	listHolder value: OrderedCollection new! !

!DropListPresenter methodsFor: 'api' stamp: ''!
displayBlock
	
	^ displayBlock value! !

!DropListPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	listHolder := OrderedCollection new asValueHolder.
	selectionHolder := SelectionValueHolder new.
	
	listHolder whenChangedDo: [ 
					self changed: #getList.
					self changed: #getIconFor:.
					self internalResetSelection.].
				
	selectionHolder whenChangedDo: [ self changed: #getIndex ].
	displayBlock := [ :model :item | item label ] asValueHolder.
	iconHolder := [ :model :item | item icon ] asValueHolder.
	
	self whenSelectedItemChanged: [:item | item value ]! !

!DropListPresenter methodsFor: 'api' stamp: ''!
selectedIndex
	"<api: #inspect>"
	"Useless method but it provides a better and more consistent API"

	^ self getIndex! !

!DropListPresenter methodsFor: 'private' stamp: ''!
selectedIndexHolder

	^ selectionHolder index! !

!DropListPresenter methodsFor: 'api' stamp: ''!
selectedItem
	"<api: #inspect>"

	^ self selectedItemHolder value model! !

!DropListPresenter methodsFor: 'api' stamp: ''!
setIndex: anIndex
	| item |

	selectionHolder index value: anIndex.
	item := (listHolder value at: anIndex ifAbsent: [ nil ]).
	item value.
	selectionHolder selection value: item.
	self changed: #getIndex! !

!DropListPresenter methodsFor: 'api' stamp: ''!
displayForItem: anItem
	"The order of the arguments may look weird, but then it seems more natural while using the widget"
	
	^ self displayBlock cull: anItem model cull: anItem! !

!DropListPresenter methodsFor: 'api' stamp: ''!
listSize
	"<api: #inspect>"
	"Return the size of the list of choices"

	^ self listItems size! !

!DropListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectedItemChanged: aBlock
	"Set a block to perform when the selected item is changed"

	selectionHolder selection whenChangedDo: [ :new :old :announcement :ann | 
		aBlock cull: (new ifNotNil: [ :item | item model ]) cull: old cull: announcement cull: ann ]! !

!DropListPresenter methodsFor: 'api' stamp: ''!
resetSelection
	"<api: #do>"
	"Reset the current selection state"

	selectionHolder reset! !

!DropListPresenter methodsFor: 'api' stamp: ''!
iconHolder: aBlock
	
	iconHolder value: aBlock! !

!DropListPresenter methodsFor: 'api - events' stamp: ''!
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.! !

!DropListPresenter methodsFor: 'api' stamp: ''!
addItemLabeled: aString do: aBlock

	| item |
	item := DropListItem named: aString do: aBlock.
	
	"If you add directly in the contents, the update is not triggered from the value holder"
	listHolder add: item.! !

!DropListPresenter methodsFor: 'api' stamp: ''!
items: aList
	"Populate the drop list with a list of ui specific items"
	"aList is a list of domain specific objects. If you want to specify more precisely the item actions, see #addItemLabeled:do:"
	"<api: #st getter: #listItems>"
	
	| dropListItems |
	dropListItems := aList collect: [ :e | DropListItem on: e do: [] ].
	listHolder value: dropListItems! !

!DropListPresenter methodsFor: 'api' stamp: ''!
setSelectedIndex: anIndex
	"<api: #integer min:1 max:#listSize getter: #selectedIndex>"
	"Force the selection of the item at index anIndex"
	| selection |

	selection := listHolder value at: anIndex ifAbsent: [ ^ self ].
	selection value.
	selectionHolder index value: anIndex.
	selectionHolder selection value: selection! !

!DropListPresenter methodsFor: 'private' stamp: ''!
silentlySetSelectedIndex: anIndex
	"Force the selection of the item at index anIndex"
	| selection |

	selection := listHolder value at: anIndex ifAbsent: [ ^ self ].
	selectionHolder index value: anIndex.
	selectionHolder selection value: selection.! !

!DropListPresenter methodsFor: 'api' stamp: ''!
listItems
	"<api: #inspect>"
	"Return the list used to populate the drop list"
	
	^ listHolder value collect: [ :e | e model ].! !

!DropListPresenter methodsFor: 'api' stamp: ''!
setSelectedItem: anItem
	"Force the selection of the item anItem"
	"<api: #st getter: #selectedItem>"
	| index realItem |
	index := self listItems indexOf: anItem ifAbsent: [ ^ self ].
	realItem := listHolder at: index.
	selectionHolder index value: index.
	selectionHolder selection value: realItem.! !

!DropListPresenter methodsFor: 'api' stamp: ''!
displayBlock: aBlock
	
	displayBlock value: aBlock 
	"listHolder replace: [ :e | e display: aBlock; yourself  ]."! !

!DropListPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(DropListAdapter
		adapt: #(model))! !

!DropListPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #DropListAdapter! !

!DropListPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Drop List'! !

!DummyBreakpointObserver commentStamp: ''!
I am a dummy breakpoint observer.
I am also an example observer.
I receives update notifications from the Breakpoint class whenever a breakpoint is added, modified or removed.!
!DummyBreakpointObserver methodsFor: 'updating' stamp: ''!
update: anAspect
	tag := anAspect ! !

!DummyBreakpointObserver methodsFor: 'accessing' stamp: ''!
tag
	^ tag! !

!DummySignal commentStamp: ''!
This signal is solely used for testing purposes.!
!DummySoundSystem commentStamp: ''!
A BeepingSoundSystem is a simple sound system just doing beep and niling everything else. !
!DummySoundSystem methodsFor: 'playing' stamp: ''!
playSoundNamed: soundName ifAbsentReadFrom: aifFileName
	"Do nothing."! !

!DummySoundSystem methodsFor: 'private' stamp: ''!
beepPrimitive
	"Make a primitive beep. Not to be called directly.
	It is much better to use SoundSystem current beep
	since this method does not if sound is enabled"

	<primitive: 140>
	self primitiveFailed! !

!DummySoundSystem methodsFor: 'playing' stamp: ''!
playSoundNamed: soundName
	"Do nothing."! !

!DummySoundSystem methodsFor: 'misc' stamp: ''!
sampledSoundChoices
	"No choices other than this."

	^ #('silence')! !

!DummySoundSystem methodsFor: 'beep' stamp: ''!
beep
	"Make a primitive beep if possible."

	self soundEnabled 
		ifTrue: [ self beepPrimitive ]! !

!DummySoundSystem methodsFor: 'playing' stamp: ''!
playSampledSound: samples rate: rate
	"Do nothing."
	! !

!DummySoundSystem methodsFor: 'misc' stamp: ''!
randomBitsFromSoundInput: bitCount
 	"I'm not sure what the right thing to do here is."

 	self error: 'Can not provide random data.'
	"in the future we should propose a simple random generator to be 
	for the DummySoundSystem."! !

!DummySoundSystem methodsFor: 'playing' stamp: ''!
playSoundNamedOrBeep: soundName 
	"There is no sound support, so we make the beep."

	self beep! !

!DummySoundSystem methodsFor: 'query' stamp: ''!
soundNamed: soundName
	"There are no sounds to look up."

	^ nil! !

!DummySystemProgressItem commentStamp: ''!
A dummy for a system progress item!
!DummySystemProgressItem methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage! !

!DummyUIManager commentStamp: ''!
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: 'default actions' stamp: ''!
unhandledErrorDefaultAction: anException
	self traceCr: '*** EXCEPTION ***'.
	self traceCr: anException.
	self
		trace:
			(String
				streamContents: [ :stream | anException signalerContext errorReportOn: stream ]).
	Smalltalk exitFailure! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
multiLineRequest: queryString initialAnswer: defaultAnswer answerHeight: answerHeight! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
informUserDuring: aBlock

	aBlock value: DummySystemProgressItem new.! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
merge: merger informing: aString! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString

	(ProvideAnswerNotification signal: queryString) ifNotNil: [:answer |
		^answer].

	self error: 'No user response possible'! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
fontFromUser: priorFont

	self error: 'No user response possible'! !

!DummyUIManager methodsFor: 'accessing' stamp: ''!
progressBarEnabled: aBoolean

  ProgressBarEnabled := aBoolean! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
chooseDirectory: label from: dir

	^ nil! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: labelList values: valueList lines: linesArray title: aString

	^ valueList first! !

!DummyUIManager methodsFor: 'display' stamp: ''!
restoreDisplay! !

!DummyUIManager methodsFor: 'default actions' stamp: ''!
warningDefaultAction: anException

	^ self unhandledErrorDefaultAction: anException! !

!DummyUIManager methodsFor: '*Graphics-Display Objects' stamp: ''!
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: 'error handling' stamp: ''!
handleError: anError log: shouldLog

	"NOOP"! !

!DummyUIManager methodsFor: 'debug' stamp: ''!
debugProcess: process context: context label: title fullView: bool notification: notificationString
	Warning signal: 'Trying to debug the process ', title! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
request: queryString initialAnswer: defaultAnswer 

	^ self request: queryString initialAnswer: defaultAnswer title: 'Provide the following information' entryCompletion: nil
! !

!DummyUIManager methodsFor: 'display' stamp: ''!
restoreDisplayAfter: aBlock

	aBlock value.
	self restoreDisplay.! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList lines: linesArray title: aString

	^ aList first! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
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: ''!
inform: aString
	"Nothing to be done here"! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
requestPassword: queryString
	
	^ self request: queryString initialAnswer: ''! !

!DummyUIManager methodsFor: 'default actions' stamp: ''!
traceCr: aString

	Smalltalk logStdOutDuring: [:logger |
		logger nextPutAll: aString;
				 cr ].! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
edit: aText label: labelString accept: aBlockOrNil

	^ nil! !

!DummyUIManager methodsFor: '*Files-Prompt' stamp: ''!
fileExistsDefaultAction: anException! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
request: aStringOrText initialAnswer: defaultAnswer entryCompletion: anEntryCompletion
	
	^ self request: aStringOrText initialAnswer: defaultAnswer title: 'Information Required' entryCompletion: anEntryCompletion
! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
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: '*Files-Prompt' stamp: ''!
fileDoesNotExistsDefaultAction: anException! !

!DummyUIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString label: title trueChoice: trueChoice falseChoice: falseChoice cancelChoice: cancelChoice default: defaultOption
	(ProvideAnswerNotification signal: queryString) ifNotNil: [:answer | ^ answer].

	self error: 'No user response possible'! !

!DummyUIManager methodsFor: 'default actions' stamp: ''!
syntaxErrorNotificationDefaultAction: anException
	self traceCr: '*** SYNTAX ERROR ***'.
	self traceCr: anException.
	self
		traceCr: (thisContext stack first: (20 min: thisContext stack size)).
	anException return! !

!DummyUIManager methodsFor: 'default actions' stamp: ''!
lowSpaceWatcherDefaultAction

	self traceCr: '*** LOW SPACE ***'.
! !

!DummyUIManager methodsFor: 'accessing' stamp: ''!
progressBarEnabled

  ^ ProgressBarEnabled ifNil: [ ProgressBarEnabled := true ].! !

!DuplicatedSlotName commentStamp: ''!
I am signaled when trying to build a class with a duplicated slot.!
!DuplicatedSlotName methodsFor: 'accessing' stamp: ''!
newSlot: anObject
	newSlot := anObject! !

!DuplicatedSlotName methodsFor: 'accessing' stamp: ''!
newSlot
	^ newSlot! !

!DuplicatedSlotName methodsFor: 'accessing' stamp: ''!
oldSlot: anObject
	oldSlot := anObject! !

!DuplicatedSlotName methodsFor: 'accessing' stamp: ''!
host
	^ host! !

!DuplicatedSlotName methodsFor: 'accessing' stamp: ''!
oldSlot
	^ oldSlot! !

!DuplicatedSlotName methodsFor: 'accessing' stamp: ''!
host: anObject
	host := anObject! !

!DuplicatedSlotName methodsFor: 'accessing' stamp: ''!
messageText
	^ 'Slot #''', oldSlot name, ''' appeared twice in ', host name! !

!DuplicatedVariableError commentStamp: ''!
I am an error signalled when a variable is redeclared. For instance when a method is created wich has a temporary or argument with the same name as an instance variable.!
!DuplicatedVariableError methodsFor: 'testing' stamp: ''!
isResumable
        ^true! !

!DuplicatedVariableError methodsFor: 'accessing' stamp: ''!
superclass
        "The superclass in which the variable is defined"
        ^superclass! !

!DuplicatedVariableError methodsFor: 'accessing' stamp: ''!
superclass: aSuperclass
        "The superclass in which the variable is defined"
        superclass := aSuperclass! !

!DuplicatedVariableError methodsFor: 'accessing' stamp: ''!
variable
        "Name of the duplicate variable"
        ^variable! !

!DuplicatedVariableError methodsFor: 'accessing' stamp: ''!
variable: aVariable
        "Name of the duplicate variable"
        variable := aVariable! !

!DuplicatedVariableError class methodsFor: 'signalling' stamp: ''!
signalWith: existingVariable 
	^self new 
		variable: existingVariable;
		signal: existingVariable name , ' is defined in ', existingVariable definingClass printString! !

!Duration commentStamp: ''!
I represent a duration of time. I have nanosecond precision!
!Duration methodsFor: 'operations' stamp: ''!
wait

	self asDelay wait! !

!Duration methodsFor: 'arithmetic' stamp: ''!
< comparand
 
 	^ self asNanoSeconds < comparand asNanoSeconds! !

!Duration methodsFor: 'converting' stamp: ''!
asDuration
 
 	^ self! !

!Duration methodsFor: 'comparing' stamp: ''!
= comparand 
 	"Answer whether the argument is a <Duration> 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: 'arithmetic' stamp: ''!
* operand
	"operand is a Number"
	^ self class nanoSeconds: ( (self asNanoSeconds * operand) asInteger)! !

!Duration methodsFor: 'converting' stamp: ''!
asMilliSeconds
 
 
 	^ ((seconds * NanosInSecond) + nanos) // (10 raisedToInteger: 6)! !

!Duration methodsFor: 'converting' stamp: ''!
asNanoSeconds
 
 	^ (seconds * NanosInSecond) + nanos! !

!Duration methodsFor: 'comparing' stamp: ''!
hash
	^seconds bitXor: nanos! !

!Duration methodsFor: 'printing' stamp: ''!
printHumanReadableOn: stream
	| outputWritten count |
	outputWritten := false.
	self negative 
		ifTrue: [ 
			stream << '- '. 
			^ self abs printHumanReadableOn: stream ].
	#( (days 'day') 
		(hours 'hour') 
		(minutes 'minute') 
		(seconds 'second') 
		(wholeMilliseconds 'millisecond') 
		(wholeMicroseconds 'microsecond') 
		(wholeNanoseconds 'nanosecond')) do: [ :each |
		count := (self perform: each first) truncated.
		count > 0 
			ifTrue: [
				outputWritten ifTrue: [ stream space ].				
				count printWithCommasOn: stream.
				stream space; << (each second asPluralBasedOn: count).
				outputWritten := true ] ].
	outputWritten ifFalse: [ stream << '0 seconds' ]! !

!Duration methodsFor: 'arithmetic' stamp: ''!
/ 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: 'private' stamp: ''!
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: 'converting' stamp: ''!
asDelay
 
 	^ Delay forDuration: self! !

!Duration methodsFor: 'accessing' stamp: ''!
wholeMilliseconds
	"Answer the number of whole milliseconds in me after whole seconds are removed"

	"1002003004 nanoSeconds wholeMilliseconds"
	
	^ nanos quo: 1e6! !

!Duration methodsFor: 'operations' stamp: ''!
truncateTo: aDuration
 	"e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 4 minutes."
 
 	^ self class
 		nanoSeconds: (self asNanoSeconds truncateTo: aDuration asNanoSeconds)! !

!Duration methodsFor: 'accessing' stamp: ''!
positive
 
 
 	^ seconds = 0 ifTrue: [ nanos positive ] ifFalse: [ seconds positive ]! !

!Duration methodsFor: 'converting' stamp: ''!
asHours
 	"Answer the number of hours in the receiver."
 	^ self asMinutes / 60.0! !

!Duration methodsFor: 'printing' stamp: ''!
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 asString padLeftTo: 9 with: $0. 
		z := ps findLast: [ :c | c asciiValue > $0 asciiValue ].
		ps from: 1 to: z do: [ :c | aStream nextPut: c ] ].! !

!Duration methodsFor: 'testing' stamp: ''!
isZero

	^ seconds = 0 and: [ nanos = 0 ]! !

!Duration methodsFor: 'accessing' stamp: ''!
days
 	"Answer a number that represents the number of complete days in the receiver"
	^ seconds quo: SecondsInDay! !

!Duration methodsFor: 'operations' stamp: ''!
\\ 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: 'converting' stamp: ''!
asSeconds
 	"Answer the number of seconds in the receiver."
 	^ seconds! !

!Duration methodsFor: 'converting' stamp: ''!
nanoSeconds
 
 
 	^ nanos! !

!Duration methodsFor: 'arithmetic' stamp: ''!
- operand
	"operand is a Duration"
	^ self + operand negated! !

!Duration methodsFor: 'private' stamp: ''!
ticks
	"Answer an array {days. seconds. nanoSeconds}. Used by DateAndTime and Time."

	| days |
	days := self days.
	^ Array 
		with: days
		with: seconds - (days * SecondsInDay)
		with: nanos! !

!Duration methodsFor: 'accessing' stamp: ''!
totalSeconds
	"Return the total number of seconds in me.
	If I have zero nano seconds, the result is equivalent to #seconds. 
	If I have nanoseconds, the result will contain fractional seconds."
	
	"1500 milliSeconds totalSeconds"

	^ nanos = 0
		ifTrue: [ seconds ]
		ifFalse: [ self asNanoSeconds / 1e9 ]! !

!Duration methodsFor: 'accessing' stamp: ''!
wholeMicroseconds
	"Answer the number of whole microseconds in me after whole seconds and milliseconds are removed"
	
	"1002003004 nanoSeconds wholeMicroseconds"

	^ (nanos rem: 1e6) quo: 1e3! !

!Duration methodsFor: 'converting' stamp: ''!
asMicroseconds
 
 
 	^ ((seconds * NanosInSecond) + nanos) // (10 raisedToInteger: 3)! !

!Duration methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self seconds: 0 nanoSeconds: 0.! !

!Duration methodsFor: 'converting' stamp: ''!
asMinutes
 	"Answer the number of minutes in the receiver."
 	^ self asNanoSeconds  / 60000000000.0! !

!Duration methodsFor: 'accessing' stamp: ''!
abs
 
 	^ self class seconds: seconds abs nanoSeconds: nanos abs! !

!Duration methodsFor: 'accessing' stamp: ''!
negated
 
 	^ self class seconds: seconds negated nanoSeconds: nanos negated! !

!Duration methodsFor: 'accessing' stamp: ''!
seconds
 	"Answer a number that represents the number of complete seconds in the receiver, after the number of complete minutes has been removed."
	
	"1002003004 nanoSeconds seconds"
 
 	^ (seconds rem: SecondsInMinute)! !

!Duration methodsFor: 'converting' stamp: ''!
asDays
 	"Answer the number of days in the receiver."
 	^ self asHours / 24! !

!Duration methodsFor: '*Network-Mail' stamp: ''!
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: ''!
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: ''!
wholeNanoseconds
	"Answer the number of whole nanoseconds in me after whole seconds, milli & microseconds are removed"

	"1002003004 nanoSeconds wholeNanoseconds"

	^ nanos rem: 1e3! !

!Duration methodsFor: 'operations' stamp: ''!
// operand
 
 	"operand is a Duration or a Number"
 
 
 	^ operand isNumber
 		ifTrue: [ self class nanoSeconds: (self asNanoSeconds // operand) asInteger ]
 		ifFalse: [ self asNanoSeconds // operand asDuration asNanoSeconds ]! !

!Duration methodsFor: 'accessing' stamp: ''!
negative
 
 
 	^ self positive not! !

!Duration methodsFor: 'operations' stamp: ''!
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: 'printing' stamp: ''!
humanReadablePrintString
	"Return a String with a human readable representation of me"

	"99999 atRandom seconds humanReadablePrintString"
	"99999999 atRandom milliSeconds humanReadablePrintString"	
	"99999999999999 atRandom nanoSeconds humanReadablePrintString"
	
	^ String streamContents: [ :out | 
		self printHumanReadableOn: out ]! !

!Duration methodsFor: 'private' stamp: ''!
storeOn: aStream
 
 	aStream
 		nextPut: $(;
 		nextPutAll: self className;
 		nextPutAll: ' seconds: ';
 		print: seconds;
 		nextPutAll: ' nanoSeconds: ';
 		print: nanos;
 		nextPut: $).! !

!Duration methodsFor: 'arithmetic' stamp: ''!
+ operand
  	"operand is a Duration"
	^ self class nanoSeconds: (self asNanoSeconds + operand asNanoSeconds)! !

!Duration methodsFor: 'accessing' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
fromString: aString

	^ self readFrom: aString readStream! !

!Duration class methodsFor: 'instance creation simple' stamp: ''!
hours: aNumber

	^ self seconds: aNumber * SecondsInHour nanoSeconds: 0! !

!Duration class methodsFor: 'instance creation' stamp: ''!
days: days seconds: seconds

	^ self basicNew seconds: days * SecondsInDay + seconds nanoSeconds: 0! !

!Duration class methodsFor: 'instance creation simple' stamp: ''!
days: aNumber

	^ self seconds: aNumber * SecondsInDay nanoSeconds: 0! !

!Duration class methodsFor: 'instance creation' stamp: ''!
seconds: seconds nanoSeconds: nanos
	^ self basicNew
		seconds: seconds truncated
		nanoSeconds: seconds fractionPart * NanosInSecond + nanos! !

!Duration class methodsFor: 'instance creation simple' stamp: ''!
milliSeconds: milliCount
     
	^ self
		seconds: (milliCount quo: 1000)
		nanoSeconds: (milliCount rem: 1000) * NanosInMillisecond! !

!Duration class methodsFor: 'instance creation simple' stamp: ''!
weeks: aNumber

	^ self days: (aNumber * 7) seconds: 0! !

!Duration class methodsFor: 'instance creation simple' stamp: ''!
years: aNumber

	^ self days: (aNumber * 365) seconds: 0! !

!Duration class methodsFor: 'instance creation' stamp: ''!
days: days hours: hours minutes: minutes seconds: seconds

	^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: 0! !

!Duration class methodsFor: 'instance creation simple' stamp: ''!
zero

	^ self basicNew seconds: 0 nanoSeconds: 0! !

!Duration class methodsFor: 'instance creation simple' stamp: ''!
minutes: aNumber

	^ self seconds: aNumber * SecondsInMinute nanoSeconds: 0! !

!Duration class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
month: aMonth
	"aMonth is an Integer or a String"
	
	^ (Month month: aMonth) duration! !

!Duration class methodsFor: 'instance creation' stamp: ''!
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: ''!
days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos	

 	^ self seconds: ((days * SecondsInDay) 
						+ (hours * SecondsInHour)
							+ (minutes * SecondsInMinute) 
								+ seconds)
		nanoSeconds: nanos! !

!Duration class methodsFor: 'instance creation simple' stamp: ''!
nanoSeconds: nanos
	"This method is slow. If you have nanos less than 10^6 you should use #seconds:nanoSeconds: instead."

	| quo |
	quo := nanos quo: NanosInSecond.
	^ self basicNew
		seconds: quo
		nanoSeconds: nanos - (quo * NanosInSecond)! !

!Duration class methodsFor: 'instance creation simple' stamp: ''!
seconds: seconds

	^ self seconds: seconds nanoSeconds: 0! !

!DurationTest commentStamp: ''!
SUnit tests for class  Duration!
!DurationTest methodsFor: 'tests' stamp: ''!
testQuotient
	| d1 d2 q |
	d1 := 11.5 seconds.
	d2 := d1 // 3.
	self assert: d2 equals: (Duration seconds: 3 nanoSeconds: 833333333).

	q := d1 // 3 seconds.
	self assert: q equals: 3! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsSeconds
	self assert: (Duration nanoSeconds: 1000000000) asSeconds equals: 1.
	self assert: (Duration seconds: 1) asSeconds equals: 1.
	self assert: aDuration asSeconds equals: 93784.
	self assert: 1 asSeconds equals: (Duration seconds: 1).
	self assert: (1 / 2) asSeconds equals: (Duration milliSeconds: 500)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testDays
	self assert: aDuration days equals: 1.
	self assert: (Duration days: 1) days equals: 1! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsSecond
	| full half quarter |
	full := Duration seconds: 1.
	half := Duration seconds: 0.5.
	quarter := Duration seconds: 0.25.
	self
		assert: 1 second equals: full;
		assert: 1.0 second equals: full;
		assert: 0.5 second equals: half;
		assert: (1 / 2) second equals: half;
		assert: (1 / 4) second equals: quarter.
	self assert: 0.4 second + 0.6 second equals: 1 second! !

!DurationTest methodsFor: 'tests' stamp: ''!
testReadFrom
	self assert: aDuration equals: (Duration readFrom: '1:02:03:04.000000005' readStream)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testNanoSeconds
	self assert: aDuration nanoSeconds equals: 5.
	self assert: (Duration nanoSeconds: 5) nanoSeconds equals: 5! !

!DurationTest methodsFor: 'coverage' stamp: ''!
selectorsToBeIgnored

	| private | 
	private := #( #printOn: ).

	^ super selectorsToBeIgnored, private! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsDelay
	self deny: aDuration asDelay equals: aDuration
	"want to come up with a more meaningful test"! !

!DurationTest methodsFor: 'tests' stamp: ''!
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 equals: d1;
		assert: d1 equals: d2;
		deny: d1 equals: d3;
		assert: d1 < d3! !

!DurationTest methodsFor: 'tests' stamp: ''!
testMilliSeconds
	#(#(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 equals: each second.
			self assert: duration nanoSeconds equals: each third ]
	"argument (milliseconds)        seconds nanoseconds"! !

!DurationTest methodsFor: 'tests' stamp: ''!
testModulo
	| d1 d2 d3 |
	d1 := 11.5 seconds.
	d2 := d1 \\ 3.
	self assert: d2 equals: (Duration nanoSeconds: 1).

	d3 := d1 \\ 3 seconds.
	self assert: d3 equals: (Duration seconds: 2 nanoSeconds: 500000000).

	self
		assert: aDuration \\ aDuration
		equals:
			(Duration
				days: 0
				hours: 0
				minutes: 0
				seconds: 0
				nanoSeconds: 0).
	self
		assert: aDuration \\ 2
		equals:
			(Duration
				days: 0
				hours: 0
				minutes: 0
				seconds: 0
				nanoSeconds: 1)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testPositive
	self assert: (Duration nanoSeconds: 0) positive.
	self assert: aDuration positive.
	self deny: aDuration negated positive! !

!DurationTest methodsFor: 'tests' stamp: ''!
testSeconds
	self assert: aDuration seconds equals: 4.
	self assert: (Duration nanoSeconds: 2) seconds equals: 0.
	self assert: (Duration seconds: 2) seconds equals: 2.
	self
		assert:
			(Duration
				days: 1
				hours: 2
				minutes: 3
				seconds: 4) seconds
		equals: 4.
	self
		deny:
			(Duration
				days: 1
				hours: 2
				minutes: 3
				seconds: 4) seconds
		equals: 1 * 24 * 60 * 60 + (2 * 60 * 60) + (3 * 60) + 4! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsDuration
	self assert: aDuration asDuration equals: aDuration! !

!DurationTest methodsFor: 'tests' stamp: ''!
testHash
	self
		assert: aDuration hash
		equals:
			(Duration
				days: 1
				hours: 2
				minutes: 3
				seconds: 4
				nanoSeconds: 5) hash! !

!DurationTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testMonthDurations
	| jan feb dec |
	jan := Duration month: #January.
	feb := Duration month: #February.
	dec := Duration month: #December.

	self
		assert: jan equals: Year current months first duration;
		assert: feb equals: Year current months second duration;
		assert: dec equals: Year current months last duration! !

!DurationTest methodsFor: 'tests' stamp: ''!
testRoundTo
	self assert: (5 minutes + 37 seconds roundTo: 2 minutes) equals: 6 minutes.

	self
		assert: (aDuration roundTo: (Duration days: 1))
		equals:
			(Duration
				days: 1
				hours: 0
				minutes: 0
				seconds: 0
				nanoSeconds: 0).
	self
		assert: (aDuration roundTo: (Duration hours: 1))
		equals:
			(Duration
				days: 1
				hours: 2
				minutes: 0
				seconds: 0
				nanoSeconds: 0).
	self
		assert: (aDuration roundTo: (Duration minutes: 1))
		equals:
			(Duration
				days: 1
				hours: 2
				minutes: 3
				seconds: 0
				nanoSeconds: 0)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testPrintOn
	self assert: (String streamContents: [ :str | aDuration printOn: str ]) equals: '1:02:03:04.000000005'! !

!DurationTest methodsFor: 'tests' stamp: ''!
testHumanReadablePrintString
	self assert: 0 seconds humanReadablePrintString equals: '0 seconds'.
	self assert: 1 second humanReadablePrintString equals: '1 second'.
	self assert: 1 second negated humanReadablePrintString equals: '- 1 second'.
	self 
		assert: 1002003004 nanoSeconds humanReadablePrintString 
		equals: '1 second 2 milliseconds 3 microseconds 4 nanoseconds'.
	self 
		assert: (Duration days: 1 hours: 1 minutes: 1 seconds: 1) humanReadablePrintString 
		equals: '1 day 1 hour 1 minute 1 second'.
	self 
		assert: (Duration days: 2 hours: 4 minutes: 8 seconds: 16) humanReadablePrintString 
		equals: '2 days 4 hours 8 minutes 16 seconds'.
		
	self shouldnt: [ 17.6782 years humanReadablePrintString ] raise: MessageNotUnderstood .! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsYears
	self
		assert: 2 years days equals: 730;
		assert: 0.5 year asHours equals: 364 / 2 * 24 + 12! !

!DurationTest methodsFor: 'tests' stamp: ''!
testLessThan
	self assert: aDuration  < (aDuration + 1 day ).
	self deny: aDuration < aDuration.! !

!DurationTest methodsFor: 'tests' stamp: ''!
testTruncateTo
	self assert: (5 minutes + 37 seconds truncateTo: 2 minutes) equals: 4 minutes.
	self
		assert: (aDuration truncateTo: (Duration days: 1))
		equals:
			(Duration
				days: 1
				hours: 0
				minutes: 0
				seconds: 0
				nanoSeconds: 0).
	self
		assert: (aDuration truncateTo: (Duration hours: 1))
		equals:
			(Duration
				days: 1
				hours: 2
				minutes: 0
				seconds: 0
				nanoSeconds: 0).
	self
		assert: (aDuration truncateTo: (Duration minutes: 1))
		equals:
			(Duration
				days: 1
				hours: 2
				minutes: 3
				seconds: 0
				nanoSeconds: 0)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testZero
	self assert: Duration zero equals: (Duration seconds: 0)! !

!DurationTest methodsFor: 'tests' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
testAsHour
	| full half quarter |
	full := Duration minutes: 60.
	half := Duration minutes: 30.
	quarter := Duration minutes: 15.
	self
		assert: 1 hour equals: full;
		assert: 1.0 hour equals: full;
		assert: 0.5 hour equals: half;
		assert: (1 / 2) hour equals: half;
		assert: (1 / 4) hour equals: quarter! !

!DurationTest methodsFor: 'tests' stamp: ''!
testFromString
	self assert: aDuration equals: (Duration fromString: '1:02:03:04.000000005')! !

!DurationTest methodsFor: 'tests' stamp: ''!
testMinus
	self assert: aDuration - aDuration equals: (Duration seconds: 0).
	self
		assert:
			aDuration
				-
					(Duration
						days: -1
						hours: -2
						minutes: -3
						seconds: -4
						nanoSeconds: -5)
		equals:
			(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)
		equals:
			(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)
		equals:
			(Duration
				days: 0
				hours: 23
				minutes: 2
				seconds: 59
				nanoSeconds: 5)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAbs
	self assert: aDuration abs equals: aDuration.
	self assert: (Duration nanoSeconds: -5) abs equals: (Duration nanoSeconds: 5)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsWeeks
	| full half quarter |
	full := Duration days: 7.
	half := Duration weeks: 0.5.
	quarter := Duration weeks: 0.25.
	self
		assert: 1 weeks equals: full;
		assert: 1.0 weeks equals: full;
		assert: 0.5 weeks equals: half;
		assert: (1 / 2) weeks equals: half;
		assert: (1 / 4) weeks equals: quarter.
	self assert: 1.4 weeks + 1.6 weeks equals: 3 weeks! !

!DurationTest methodsFor: 'tests' stamp: ''!
testPrintHumanReadableOn
	self testHumanReadablePrintString! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsWeek
	| full half quarter |
	full := Duration days: 7.
	half := Duration weeks: 0.5.
	quarter := Duration weeks: 0.25.
	self
		assert: 1 week equals: full;
		assert: 1.0 week equals: full;
		assert: 0.5 week equals: half;
		assert: (1 / 2) week equals: half;
		assert: (1 / 4) week equals: quarter.
	self assert: 0.4 week + 0.6 week equals: 1 week! !

!DurationTest methodsFor: 'tests' stamp: ''!
testWholeMicroseconds
	self assert: 0 seconds wholeMicroseconds equals: 0.
	self assert: 1 second wholeMicroseconds equals: 0.
	self assert: 1002003004 nanoSeconds wholeMicroseconds equals: 3! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsNanoSeconds
	self assert: (Duration nanoSeconds: 1) asNanoSeconds equals: 1.
	self assert: (Duration seconds: 1) asNanoSeconds equals: 1000000000.
	self assert: aDuration asNanoSeconds equals: 93784000000005! !

!DurationTest methodsFor: 'tests' stamp: ''!
testNegative
	self deny: aDuration negative.
	self assert: aDuration negated negative! !

!DurationTest methodsFor: 'tests' stamp: ''!
testWholeNanoseconds
	self assert: 0 seconds wholeNanoseconds equals: 0.
	self assert: 1 second wholeNanoseconds equals: 0.
	self assert: 1002003004 nanoSeconds wholeNanoseconds equals: 4! !

!DurationTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ Duration! !

!DurationTest methodsFor: 'tests' stamp: ''!
testNew
	"self assert: Duration new =  (Duration seconds: 0)."
    "new is not valid as a creation method: MessageNotUnderstood: UndefinedObject>>quo:, where Duration seconds is nil"! !

!DurationTest methodsFor: 'tests' stamp: ''!
testIntegerDivision
	self assert: aDuration // aDuration equals: 1.
	self assert: aDuration // 2 equals: aDuration / 2
	"is there ever a case where this is not true, since precision is always to the nano second?"! !

!DurationTest methodsFor: 'tests' stamp: ''!
testMultiply
	self
		assert: aDuration * 2
		equals:
			(Duration
				days: 2
				hours: 4
				minutes: 6
				seconds: 8
				nanoSeconds: 10)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testIsZero
	self assert: Duration zero isZero.
	self assert: (Duration seconds: 0) isZero! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsMinute
	| full half quarter |
	full := Duration seconds: 60.
	half := Duration seconds: 30.
	quarter := Duration seconds: 15.
	self
		assert: 1 minute equals: full;
		assert: 1.0 minute equals: full;
		assert: 0.5 minute equals: half;
		assert: (1 / 2) minute equals: half;
		assert: (1 / 4) minute equals: quarter.
	self assert: 0.4 minute + 0.6 minute equals: 1 minute! !

!DurationTest methodsFor: 'tests' stamp: ''!
testNanoSecond
	self
		assert: (Duration nanoSeconds: 5) equals: 5 nanoSecond;
		assert: 0.5 nanoSecond equals: (Duration nanoSeconds: 0.5);
		assert: (1 / 2) nanoSecond equals: (Duration nanoSeconds: 0.5)! !

!DurationTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsMinutes
	self assert: (Duration seconds: 60) asMinutes equals: 1.
	self assert: (Duration hours: 1) asMinutes equals: 60.
	self assert: (aDuration asMinutes closeTo: 1563.0666).
	self assert: ((Duration milliSeconds: 100) asMinutes closeTo: 1 / 600)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testNegated
	self assert: aDuration + aDuration negated equals: (Duration seconds: 0)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testDivide
	self assert: aDuration / aDuration equals: 1.
	self
		assert: aDuration / 2
		equals:
			(Duration
				days: 0
				hours: 13
				minutes: 1
				seconds: 32
				nanoSeconds: 2).
	self
		assert: aDuration / (1 / 2)
		equals:
			(Duration
				days: 2
				hours: 4
				minutes: 6
				seconds: 8
				nanoSeconds: 10)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testTotalSeconds
	self assert: 0 seconds totalSeconds equals: 0.
	self assert: 1 second totalSeconds equals: 1.
	self assert: 100 second totalSeconds equals: 100.
	self assert: 500 milliSeconds totalSeconds equals: 1/2.
	self assert: 1500 milliSeconds totalSeconds equals: 3/2.
	self assert: 2500 milliSeconds totalSeconds equals: 5/2.
	self assert: 1 second negated totalSeconds equals: -1! !

!DurationTest methodsFor: 'tests' stamp: ''!
testReadFromBogus

	self should: [Duration readFrom: '+0:01:02' readStream] raise: Error.
	"Seconds should be supplied as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]"! !

!DurationTest methodsFor: 'tests' stamp: ''!
testSecondsNanoSeconds
	self assert: (Duration seconds: 0 nanoSeconds: 5) equals: (Duration nanoSeconds: 5).
	"not sure I should include in sunit since its Private "
	self assert: (aDuration seconds: 0 nanoSeconds: 1) equals: (Duration nanoSeconds: 1)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testPlus
	self assert: aDuration + 0 hours equals: aDuration.
	self
		assert: aDuration + aDuration
		equals:
			(Duration
				days: 2
				hours: 4
				minutes: 6
				seconds: 8
				nanoSeconds: 10)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testWeeks
	self assert: (Duration weeks: 1) days equals: 7! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsYear
	self
		assert: 1 year days equals: 365;
		assert: 0.5 year asHours equals: 364 / 2 * 24 + 12! !

!DurationTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsDays
	self assert: (Duration days: 2) asDays equals: 2.
	self assert: (Duration weeks: 1) asDays equals: 7.
	self assert: (aDuration asDays closeTo: 1.08546)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testReadFromMillisecond
	self assert: (Duration readFrom: '0:00:00:00.001 ' readStream) nanoSeconds equals: 1000000! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsMilliSeconds
	self assert: (Duration nanoSeconds: 1000000) asMilliSeconds equals: 1.
	self assert: (Duration seconds: 1) asMilliSeconds equals: 1000.
	self assert: (Duration nanoSeconds: 1000000) asMilliSeconds equals: 1.
	self assert: (Duration nanoSeconds: 1000000) asMilliSeconds equals: 1.
	self assert: aDuration asMilliSeconds equals: 93784000.
	self assert: (Duration milliSeconds: 3775) asSeconds equals: 3.
	self assert: (Duration milliSeconds: 3775) nanoSeconds equals: 775000000.
	self assert: (Duration milliSeconds: -3775) asSeconds equals: -3.
	self assert: (Duration milliSeconds: -3775) nanoSeconds equals: -775000000! !

!DurationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsDay
	| full half quarter |
	full := Duration minutes: 60 * 24.
	half := Duration minutes: 60 * 12.
	quarter := Duration minutes: 60 * 6.
	self
		assert: 1 day equals: full;
		assert: 1.0 day equals: full;
		assert: 0.5 day equals: half;
		assert: (1 / 2) day equals: half;
		assert: (1 / 4) day equals: quarter.
	self assert: 0.4 day + 0.6 day equals: 1 day! !

!DurationTest methodsFor: 'tests' stamp: ''!
testWholeMilliseconds
	self assert: 0 seconds wholeMilliseconds equals: 0.
	self assert: 1 second wholeMilliseconds equals: 0.
	self assert: 1002003004 nanoSeconds wholeMilliseconds equals: 2! !

!DurationTest methodsFor: 'tests' stamp: ''!
testHours
	self assert: aDuration hours equals: 2.
	self assert: (Duration hours: 2) hours equals: 2! !

!DurationTest methodsFor: 'tests' stamp: ''!
testStoreOn
	| stream |
	aDuration storeOn: (stream := (String new: 20) writeStream).
	self assert: stream contents equals: '(Duration seconds: 93784 nanoSeconds: 5)'! !

!DurationTest methodsFor: 'tests' stamp: ''!
testNumberConvenienceMethods
	self
		assert: 1 week equals: (Duration days: 7);
		assert: -1 week equals: (Duration days: -7);
		assert: 1 day equals: (Duration days: 1);
		assert: -1 day equals: (Duration days: -1);
		assert: 1 hours equals: (Duration hours: 1);
		assert: -1 hour equals: (Duration hours: -1);
		assert: 1 minute equals: (Duration seconds: 60);
		assert: -1 minute equals: (Duration seconds: -60);
		assert: 1 second equals: (Duration seconds: 1);
		assert: -1 second equals: (Duration seconds: -1);
		assert: 1 milliSecond equals: (Duration milliSeconds: 1);
		assert: -1 milliSecond equals: (Duration milliSeconds: -1);
		assert: 1 nanoSecond equals: (Duration nanoSeconds: 1);
		assert: -1 nanoSecond equals: (Duration nanoSeconds: -1)! !

!DurationTest methodsFor: 'tests' stamp: ''!
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 equals: 0.
	self assert: d nanoSeconds equals: 100000000.
	self assert: d asString equals: '0:00:00:00.1'.
	"Verify that other combinations produces reasonable printString values"
	self assert: (Duration seconds: 1 nanoSeconds: 100000000) printString equals: '0:00:00:01.1'.
	self assert: (Duration seconds: -1 nanoSeconds: -100000000) printString equals: '-0:00:00:01.1'.
	self assert: (Duration seconds: 1 nanoSeconds: -100000000) printString equals: '0:00:00:00.9'.
	self assert: (Duration seconds: -1 nanoSeconds: 100000000) printString equals: '-0:00:00:00.9'! !

!DurationTest methodsFor: 'tests' stamp: ''!
testAsMilliSecond
	self
		assert: 1 milliSecond equals: (1 / 1000) second;
		assert: (1 / 2) milliSecond equals: (1 / 2000) second;
		assert: 0.5 milliSecond equals: (1 / 2000) second;
		assert: 500 milliSecond equals: (1 / 2) second! !

!DurationTest methodsFor: 'tests' stamp: ''!
testMinutes
	self assert: aDuration minutes equals: 3.
	self assert: (Duration minutes: 3) minutes equals: 3! !

!DurationTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testAsHours
	self assert: (Duration hours: 2) asHours equals: 2.
	self assert: (Duration days: 1) asHours equals: 24.
	self assert: (aDuration asHours closeTo: 26.0511)! !

!DurationTest methodsFor: 'tests' stamp: ''!
testTicks
	self assert: aDuration ticks equals: #(1 7384 5)! !

!DynamicComposablePresenter commentStamp: ''!
I'm a CompsableModel with a dynamic behavior for managing subwidgets and the value holder communicates with them.

The idea is that instead of having a fix set of valueHolders controlling various aspects of the model. I have a dictionary to hold such elements.

You can also have a look at DynamicalPopup for an example.

I provide the following variables and its accessors
- layout to put a layout created dynamically.
- widget is a Dictionary containing my dynamics widgets.

I'm specializing
- doesNotUnderstand:  to search in my dictionary before rise an exception, so that the programmer can simply use accessors to access my dynamic elements. 
- openWithSpec to use the layout in my variable if it is not nil.

I provide the following messages
- instantiateModels: to create instances of subwidgets. It takes a collection of pair, first of each pair is the string to use as key in the dictionary, second is the class name to instantiate.
- assign:to: to put in the dictionary a widget already instantiated.

todo
- needFullRebuild:
- retrieveSpec:!
!DynamicComposablePresenter methodsFor: 'error handling' stamp: ''!
doesNotUnderstand: aMessage
	"To make sure that we can use accessors to access the dynamically managed subcomponents."
	
	^ widgets 
			at: aMessage selector 
			ifAbsent: [ super doesNotUnderstand: aMessage ]! !

!DynamicComposablePresenter methodsFor: 'instance creation' stamp: ''!
instantiateModels: aCollectionOfPairs
 
	aCollectionOfPairs pairsDo: [ :k :v |
		widgets at: k asSymbol put: (self createInstanceFor: v) ]! !

!DynamicComposablePresenter methodsFor: 'accessing' stamp: ''!
layout

	^ layout value! !

!DynamicComposablePresenter methodsFor: 'initialization' stamp: ''!
initialize

	widgets := OrderedIdentityDictionary new asValueHolder.
	layout := nil asValueHolder.
	super initialize.	! !

!DynamicComposablePresenter methodsFor: 'accessing' stamp: ''!
layout: aLayout

	layout value: aLayout! !

!DynamicComposablePresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets! !

!DynamicComposablePresenter methodsFor: 'instance creation' stamp: ''!
instantiatePresenters: aCollectionOfPairs
 
	^ self instantiateModels: aCollectionOfPairs! !

!DynamicComposablePresenter methodsFor: 'api' stamp: ''!
retrieveSpec: aSelector

	self layout ifNil: [ ^ super retrieveSpec: aSelector ].

	^ self layout
		selector: aSelector;
		yourself! !

!DynamicComposablePresenter methodsFor: 'accessing' stamp: ''!
widgets

	^ widgets! !

!DynamicComposablePresenter methodsFor: 'api' stamp: ''!
openWithSpec

	self layout ifNil: [ ^ super openWithSpec ].
	^ self openWithSpecLayout: self layout! !

!DynamicComposablePresenter methodsFor: 'accessing' stamp: ''!
widgetsDo: aBlock

	self widgets do: aBlock ! !

!DynamicComposablePresenter methodsFor: 'api' stamp: ''!
needFullRebuild: aBoolean

	self needRebuild: aBoolean.
	self widgetsDo: [:e | e needRebuild: aBoolean ]! !

!DynamicComposablePresenter methodsFor: 'instance creation' stamp: ''!
assign: aModel to: anInstVarName

	widgets 
		at: anInstVarName
		put: aModel.
		
	aModel owner: self! !

!DynamicLeftToRightColumnsLayout commentStamp: ''!
I am the layout for which you define the number of columns to store you presenters and set them from left to right in these rows.!
!DynamicLeftToRightColumnsLayout methodsFor: 'accessing' stamp: ''!
columnsCount: anObject
	(anObject isInteger and: [ anObject > 0 ])
		ifFalse: [ self error: 'A positive integer is expected as parameter.' ].
	
	columnsCount := anObject! !

!DynamicLeftToRightColumnsLayout methodsFor: 'building' stamp: ''!
nullPresentersNeededFor: aDynamicPresentersListBuilder
	"Compute the number of empty presenters required to fill additional space if the number of model objects modulo the number of columns/rows is not equals to 0."
	^ self columnsCount - (((aDynamicPresentersListBuilder modelObjects size - 1) % self columnsCount) + 1)! !

!DynamicLeftToRightColumnsLayout methodsFor: 'building' stamp: ''!
buildLayoutFor: aDynamicPresentersListBuilder
	^ SpecLayout composed
		newColumn: [ :mainColumn | 
			(self instVarNamesFrom: aDynamicPresentersListBuilder)
				groupsOf: self columnsCount
				atATimeDo: [ :group | 
					mainColumn
						newRow: [ :row | group do: [ :instVar | row newColumn: instVar ] ] ] ]! !

!DynamicLeftToRightColumnsLayout methodsFor: 'accessing' stamp: ''!
columnsCount
	^ columnsCount! !

!DynamicLeftToRightColumnsLayout class methodsFor: 'instance creation' stamp: ''!
columns: anInteger
	^ self new
		columnsCount: anInteger;
		yourself! !

!DynamicLeftToRightRowsLayout commentStamp: ''!
I am the layout for which you define the number of rows to store you presenters and set them from left to right in these rows.!
!DynamicLeftToRightRowsLayout methodsFor: 'building' stamp: ''!
instVarNamesFrom: aDynamicPresentersListBuilder
	| names streams |
	names := super instVarNamesFrom: aDynamicPresentersListBuilder.
	streams := names groupsOf: names size / self rowsCount atATimeCollect: [ :a | a readStream ].
	
	^ OrderedCollection streamContents: [ :s |
		[ streams noneSatisfy: #atEnd ]
			whileTrue: [ 
				streams do: [ :subS |
					s nextPut: subS next ] ] ]! !

!DynamicLoader commentStamp: ''!
I'm a class to load libraries and symbols from system.
I provide dlopen in linux and mac and LoadLibrary in windows.!
!DynamicLoader methodsFor: 'misc' stamp: ''!
lastError
	^ self subclassResponsibility! !

!DynamicLoader methodsFor: 'misc' stamp: ''!
loadSymbolFrom: handle name: symbol
	^ self subclassResponsibility! !

!DynamicLoader methodsFor: 'misc' stamp: ''!
loadLibrary: path
	^ self subclassResponsibility! !

!DynamicLoader methodsFor: 'accessing - platform' stamp: ''!
unixLibraryName
	^ 'libdl.so'! !

!DynamicLoader methodsFor: 'accessing - platform' stamp: ''!
macLibraryName
	^ 'libc.dylib'! !

!DynamicLoader class methodsFor: 'misc' stamp: ''!
lastError
	^ self forCurrentPlatform lastError! !

!DynamicLoader class methodsFor: 'misc' stamp: ''!
loadLibrary: path
	^ self forCurrentPlatform loadLibrary: path! !

!DynamicLoader class methodsFor: 'misc' stamp: ''!
loadLibrary: path flag: flag
	^ self forCurrentPlatform 
		loadLibrary: path 
		flag: flag! !

!DynamicLoader class methodsFor: 'accessing' stamp: ''!
forCurrentPlatform
	^ (self allSubclasses 
		detect: [ :each | each isAvailable ])
		uniqueInstance
		! !

!DynamicLoader class methodsFor: 'testing' stamp: ''!
isAvailable
	^ self subclassResponsibility! !

!DynamicMessageImplementor commentStamp: ''!
Called in the debugger to generate methods when you click on the create button!
!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
writeGetterSourceCodeIfNecessary

	self isMessageAGetter ifTrue: [ self writeGetterSourceCode ]! !

!DynamicMessageImplementor methodsFor: 'testing' stamp: ''!
hasParameter: aKeyword

	^ aKeyword last = $: or: [ message selector isInfix ]! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
writeArgumentNameIfNecessaryOf: aKeyword at: anIndex

	(self hasParameter: aKeyword) ifTrue: [ self writeArgumentNameAt: anIndex ]! !

!DynamicMessageImplementor methodsFor: 'testing' stamp: ''!
isMessageAGetter
	
	^ message numArgs = 0 and: [ class instVarNames includes: message selector ]! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
write: aKeyword of: anIndex

	stream nextPutAll: aKeyword.
	self writeArgumentNameIfNecessaryOf: aKeyword at: anIndex! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
writeMethodName

	message selector keywords doWithIndex: [ :aKeyword :anIndex | self write: aKeyword of: anIndex ]! !

!DynamicMessageImplementor methodsFor: 'evaluating' stamp: ''!
value

	argumentNames := Set new.
	stream := WriteStream on: String new.
	self writeSourceCode.
	
	^ stream contents! !

!DynamicMessageImplementor methodsFor: 'testing' stamp: ''!
isMessageASetter
	
	^ message numArgs = 1 and: [ class instVarNames includes: message selector allButLast ]! !

!DynamicMessageImplementor methodsFor: 'testing' stamp: ''!
messageShouldBeImplemented
	
	^ (self isMessageAGetter | self isMessageASetter) not! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
writeSetterSourceCodeIfNecessary

	self isMessageASetter ifTrue: [ self writeSetterSourceCode ]! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
argumentNameAt: anIndex

	| argumentName argument |
	
	argument := message arguments at: anIndex.
	argumentName := argument class canonicalArgumentName.
	
	[ argumentNames includes: argumentName ] whileTrue: [ argumentName := argumentName , anIndex asString ].
	argumentNames add: argumentName.

	^ argumentName! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
writeArgumentNameAt: anIndex

	| argumentName |
	
	argumentName := self argumentNameAt: anIndex.
	stream
		nextPutAll: ' ';
		nextPutAll: argumentName;
		space! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
writeShouldBeImplemented

	stream
		cr;
		tab;
		nextPutAll: 'self ';
		nextPutAll: #shouldBeImplemented;
		nextPut: $.! !

!DynamicMessageImplementor methodsFor: 'initialization' stamp: ''!
initializeFor: aMessage in: aClass

	message := aMessage.
	class := aClass! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
writeSetterSourceCode

	stream 
		cr;
		tab;
		nextPutAll: message selector allButLast;
		nextPutAll: ' := ';
		nextPutAll: argumentNames anyOne! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
writeGetterSourceCode

	stream 
		cr;
		tab;
		nextPutAll: '^ ';
		nextPutAll: message selector! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
writeShouldBeImplementedIfNecessary

	self messageShouldBeImplemented ifTrue: [ self writeShouldBeImplemented ]! !

!DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: ''!
writeSourceCode

	self writeMethodName.
	self writeShouldBeImplementedIfNecessary.
	self writeGetterSourceCodeIfNecessary.
	self writeSetterSourceCodeIfNecessary! !

!DynamicMessageImplementor class methodsFor: 'instance creation' stamp: ''!
for: aMessage in: aClass

	^ self new initializeFor: aMessage in: aClass! !

!DynamicMessageImplementorTest commentStamp: ''!
SUnit tests for class DynamicMessageImplementor!
!DynamicMessageImplementorTest methodsFor: 'testing' stamp: ''!
testGenerateSetter

	| messageImplementor sourceCode |		
	
	messageImplementor := DynamicMessageImplementor
		for: (Message selector: #instVar: argument: 1)
		in: self class.	
	sourceCode := messageImplementor value.	
	self
		assert: sourceCode withSeparatorsCompacted
		equals: 'instVar: anInteger instVar := anInteger' withSeparatorsCompacted! !

!DynamicMessageImplementorTest methodsFor: 'testing' stamp: ''!
testBinaryMessage

	| messageImplementor sourceCode |		
	
	messageImplementor := DynamicMessageImplementor for: (Message selector: #+ argument: 1) in: self class.	
	sourceCode := messageImplementor value.	
	self assert: sourceCode withSeparatorsCompacted equals: '+ anInteger self shouldBeImplemented.' withSeparatorsCompacted! !

!DynamicMessageImplementorTest methodsFor: 'testing' stamp: ''!
testConflictingArgumentNames

	| messageImplementor sourceCode |		
	
	messageImplementor := DynamicMessageImplementor for: (Message selector: #m1:m2:m3: arguments: #(1 2 3)) in: self class.	
	sourceCode := messageImplementor value.	
	self assert: sourceCode withSeparatorsCompacted equals: 'm1: anInteger m2: anInteger2 m3: anInteger3 self shouldBeImplemented.' withSeparatorsCompacted! !

!DynamicMessageImplementorTest methodsFor: 'accessing' stamp: ''!
instVar
	"Only required so that instVar is referenced as we do not want unreferenced ivars in the image"
	
	^ instVar! !

!DynamicMessageImplementorTest methodsFor: 'testing' stamp: ''!
testGenerateBooleanArgumentNameForFalse

	| messageImplementor sourceCode |		
	
	messageImplementor := DynamicMessageImplementor for: (Message selector: #iReceiveABoolean: arguments: #(false)) in: self class.
	sourceCode := messageImplementor value.
	self assert: sourceCode withSeparatorsCompacted equals: 'iReceiveABoolean: aBoolean self shouldBeImplemented.' withSeparatorsCompacted! !

!DynamicMessageImplementorTest methodsFor: 'testing' stamp: ''!
testOneArgumentNotMatchingAnInstanceVariable

	| messageImplementor sourceCode |		
	
	messageImplementor := DynamicMessageImplementor for: (Message selector: #m1: argument: 1) in: self class.	
	sourceCode := messageImplementor value.	
	self assert: sourceCode withSeparatorsCompacted equals: 'm1: anInteger self shouldBeImplemented.' withSeparatorsCompacted! !

!DynamicMessageImplementorTest methodsFor: 'testing' stamp: ''!
testGenerateBooleanArgumentNameForTrue

	| messageImplementor sourceCode |		
	
	messageImplementor := DynamicMessageImplementor for: (Message selector: #iReceiveABoolean: arguments: #(true)) in: self class.
	sourceCode := messageImplementor value.
	self assert: sourceCode withSeparatorsCompacted equals: 'iReceiveABoolean: aBoolean self shouldBeImplemented.' withSeparatorsCompacted! !

!DynamicMessageImplementorTest methodsFor: 'testing' stamp: ''!
testUnaryMessageNotMatchingAnInstanceVariable

	| messageImplementor sourceCode |		
	
	messageImplementor := DynamicMessageImplementor for: (Message selector: #m1) in: self class.	
	sourceCode := messageImplementor value.	
	self assert: sourceCode withSeparatorsCompacted equals: 'm1 self shouldBeImplemented.' withSeparatorsCompacted! !

!DynamicMessageImplementorTest methodsFor: 'testing' stamp: ''!
testGenerateGetter

	| messageImplementor sourceCode |		
	
	messageImplementor := DynamicMessageImplementor 
		for: (Message selector: #instVar) 
		in: self class.	
	sourceCode := messageImplementor value.	
	self 
		assert: sourceCode withSeparatorsCompacted 
		equals: 'instVar	^ instVar' withSeparatorsCompacted! !

!DynamicMessageImplementorTest methodsFor: 'testing' stamp: ''!
testNonConflictingArgumentNames

	| messageImplementor sourceCode |		
	
	messageImplementor := DynamicMessageImplementor for: (Message selector: #m1:m2:m3: arguments: #(1 $a 'string')) in: self class.	
	sourceCode := messageImplementor value.	
	self assert: sourceCode withSeparatorsCompacted equals: 'm1: anInteger m2: aCharacter m3: aString self shouldBeImplemented.' withSeparatorsCompacted! !

!DynamicPresentersListBuilder commentStamp: ''!
I allow to build a list of spec presenters into a DynamicComposablePresenter depending on an arbitrary number of objects.

I also allow to specify the layout to use for these presenters.

See
[[[
	self example.
]]]!
!DynamicPresentersListBuilder methodsFor: 'accessing' stamp: ''!
modelObjects: aCollectionOfObjects
	instVarToModelObject := aCollectionOfObjects collect: [ :o |
		self generateUniqueInstanceVariableName -> o ]! !

!DynamicPresentersListBuilder methodsFor: 'accessing' stamp: ''!
presenterBlock: anObject
	presenterBlock := anObject! !

!DynamicPresentersListBuilder methodsFor: 'private' stamp: ''!
instVarToModelObjectDo: aBlock
	"Iterates on inst. var. names and model object and provides them as argument to the aBlock."
	self instVarToModelObject do: [ :assoc |
		aBlock value: assoc key value: assoc value ]! !

!DynamicPresentersListBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	instVarCount := 0.
	nullPresentersInstVarNames := #()! !

!DynamicPresentersListBuilder methodsFor: 'private' stamp: ''!
nullPresentersInstVarNames
	^ nullPresentersInstVarNames! !

!DynamicPresentersListBuilder methodsFor: 'accessing' stamp: ''!
layoutBuilder
	^ layoutBuilder! !

!DynamicPresentersListBuilder methodsFor: 'private' stamp: ''!
generateNullPresentersInstVarNames: anInteger
	^ (1 to: anInteger)
		collect: [ :i | self generateUniqueInstanceVariableName ]! !

!DynamicPresentersListBuilder methodsFor: 'api' stamp: ''!
presenterProvidedBy: blockReturningPresenter configuredAs: blockConfiguringThePresenter
	"Configure the builder: 1. provide a block returning presenter classes to instantiate; and 2. specify how to configure them.
	 I do a job similar to #presenter:configuredAs: but I provide more flexibility since model objects can be shown as different presenters.
	 - blockReturningPresenter is a block returning the presenter class to instantiate for each model object. It has one argument which the model object that needs to be shown on the UI.
	 - twoArgumentsBlock will be called to configure instances of aPresenterClass. The first argument of this block is the presenter instance and the second the model object."
	self
		presenterBlock: blockReturningPresenter;
		configurationBlock: blockConfiguringThePresenter
	! !

!DynamicPresentersListBuilder methodsFor: 'accessing' stamp: ''!
presenterBlock
	^ presenterBlock! !

!DynamicPresentersListBuilder methodsFor: 'building' stamp: ''!
buildLayout
	^ self layoutBuilder buildFor: self! !

!DynamicPresentersListBuilder methodsFor: 'accessing' stamp: ''!
configurationBlock
	^ configurationBlock! !

!DynamicPresentersListBuilder methodsFor: 'accessing' stamp: ''!
configurationBlock: anObject
	configurationBlock := anObject! !

!DynamicPresentersListBuilder methodsFor: 'private' stamp: ''!
instVarToModelObject
	^ instVarToModelObject! !

!DynamicPresentersListBuilder methodsFor: 'accessing' stamp: ''!
layoutBuilder: anObject
	layoutBuilder := anObject! !

!DynamicPresentersListBuilder methodsFor: 'building' stamp: ''!
build
	^ self buildDynamicPresenter
		layout: self buildLayout;
		yourself! !

!DynamicPresentersListBuilder methodsFor: 'private' stamp: ''!
generateUniqueInstanceVariableName
	instVarCount := instVarCount + 1.
	^ (#var , instVarCount asString) asSymbol! !

!DynamicPresentersListBuilder methodsFor: 'private' stamp: ''!
instVarNames
	^ self instVarToModelObject collect: #key! !

!DynamicPresentersListBuilder methodsFor: 'accessing' stamp: ''!
modelObjects
	^ instVarToModelObject collect: #value! !

!DynamicPresentersListBuilder methodsFor: 'private' stamp: ''!
instVarNamesAndPresenterNamesArray
	^ (self instVarToModelObject
		inject: OrderedCollection new
		into: [ :col :instVarToModelObjectAssoc |
			col
				add: instVarToModelObjectAssoc key;
				add: (self presenterBlock value: instVarToModelObjectAssoc value) name;
				yourself ]) asArray! !

!DynamicPresentersListBuilder methodsFor: 'private' stamp: ''!
nullPresentersInstVarNamesAndPresenterNamesArray
	^ (self nullPresentersInstVarNames
		inject: OrderedCollection new
		into: [ :col :instVar |
			col
				add: instVar;
				add: NullPresenter name;
				yourself ]) asArray! !

!DynamicPresentersListBuilder methodsFor: 'building' stamp: ''!
buildDynamicPresenter
	dynamicPresenter := DynamicComposablePresenter new.
	dynamicPresenter instantiatePresenters: self instVarNamesAndPresenterNamesArray.
	
	"Apply configuration block."
	self instVarToModelObjectDo: [ :instVarName :object |
		self configurationBlock value: (instVarName value: dynamicPresenter) value: object ].
	^ dynamicPresenter! !

!DynamicPresentersListBuilder methodsFor: 'private' stamp: ''!
createNullPresenters: anInteger
	nullPresentersInstVarNames := self generateNullPresentersInstVarNames: anInteger.

	dynamicPresenter
		instantiatePresenters: self nullPresentersInstVarNamesAndPresenterNamesArray! !

!DynamicPresentersListBuilder methodsFor: 'api' stamp: ''!
presenter: aPresenterClass configuredAs: twoArgumentsBlock
	"Configure the builder: 1. provide the presenter class to instantiate; and 2. specify how to configure it.
	 - aPresenterClass is a the presenter class to instantiate for each model object.
	 - twoArgumentsBlock will be called to configure instances of aPresenterClass. The first argument of this block is the presenter instance and the second the model object."
	self presenterProvidedBy: [ :modelObject | aPresenterClass ] configuredAs: twoArgumentsBlock! !

!DynamicPresentersListBuilder class methodsFor: 'examples' stamp: ''!
example
	| dynamicPresenter |
	dynamicPresenter := DynamicPresentersListBuilder new
		modelObjects: {1 . 2 . 3 . 4 . 5};
		presenter: CheckBoxPresenter
			configuredAs: [ :presenter :modelObject | 
			presenter
				label: modelObject asString;
				whenActivatedDo: [ UIManager default inform: modelObject asString , ' activated.' ];
				whenDeactivatedDo: [ UIManager default inform: modelObject asString , ' deactivated.' ] ];
		layoutBuilder: (DynamicTopToBottomColumnsLayout columns: 2);
		build.
	
	^ dynamicPresenter
		openWithSpec;
		yourself! !

!DynamicPresentersListBuilder class methodsFor: 'examples' stamp: ''!
example2
	| dynamicPresenter |
	dynamicPresenter := DynamicPresentersListBuilder new
		modelObjects: {1 . 2 . 3 . 4 . 5};
		presenterProvidedBy: [ :integer |
			integer odd "In your real code, avoid conditionals, use dispatch."
				ifTrue: [ CheckBoxPresenter ]
				ifFalse: [ LabelPresenter ] ]
			configuredAs: [ :presenter :modelObject | 
			presenter
				label: modelObject asString ];
		layoutBuilder: (DynamicTopToBottomColumnsLayout columns: 2);
		build.
	
	^ dynamicPresenter
		openWithSpec;
		yourself! !

!DynamicPresentersListLayout commentStamp: ''!
I am an abstract layout builder for a DynamicComposablePresenter built using DynamicPresentersListBuilder.!
!DynamicPresentersListLayout methodsFor: 'building' stamp: ''!
instVarNamesFrom: aDynamicPresentersListBuilder
	^ aDynamicPresentersListBuilder instVarNames , aDynamicPresentersListBuilder nullPresentersInstVarNames! !

!DynamicPresentersListLayout methodsFor: 'building' stamp: ''!
nullPresentersNeededFor: aDynamicPresentersListBuilder
	"Compute the number of empty presenters required to fill additional space if the number of model objects modulo the number of columns/rows is not equals to 0."
	^ self subclassResponsibility! !

!DynamicPresentersListLayout methodsFor: 'building' stamp: ''!
buildFor: aDynamicPresentersListBuilder
	aDynamicPresentersListBuilder
		createNullPresenters: (self nullPresentersNeededFor: aDynamicPresentersListBuilder).
	^ self buildLayoutFor: aDynamicPresentersListBuilder! !

!DynamicPresentersListLayout methodsFor: 'building' stamp: ''!
buildLayoutFor: aDynamicPresentersListBuilder
	^ self subclassResponsibility! !

!DynamicTopToBottomColumnsLayout commentStamp: ''!
I am the layout for which you define the number of columns to store you presenters and set them from top to bottom in these rows.!
!DynamicTopToBottomColumnsLayout methodsFor: 'building' stamp: ''!
instVarNamesFrom: aDynamicPresentersListBuilder
	| names streams |
	names := super instVarNamesFrom: aDynamicPresentersListBuilder.
	streams := names groupsOf: names size / self columnsCount atATimeCollect: [ :a | a readStream ].
	
	^ OrderedCollection streamContents: [ :s |
		[ streams noneSatisfy: #atEnd ]
			whileTrue: [ 
				streams do: [ :subS |
					s nextPut: subS next ] ] ]! !

!DynamicTopToBottomRowsLayout commentStamp: ''!
I am the layout for which you define the number of rows to store you presenters and set them from top to bottom in these rows.!
!DynamicTopToBottomRowsLayout methodsFor: 'accessing' stamp: ''!
rowsCount: anObject
	(anObject isInteger and: [ anObject > 0 ])
		ifFalse: [ self error: 'A positive integer is expected as parameter.' ].
	rowsCount := anObject! !

!DynamicTopToBottomRowsLayout methodsFor: 'building' stamp: ''!
nullPresentersNeededFor: aDynamicPresentersListBuilder
	"Compute the number of empty presenters required to fill additional space if the number of model objects modulo the number of columns/rows is not equals to 0."
	^ self rowsCount - ((aDynamicPresentersListBuilder modelObjects size - 1 % self rowsCount) + 1)! !

!DynamicTopToBottomRowsLayout methodsFor: 'building' stamp: ''!
buildLayoutFor: aDynamicPresentersListBuilder
	^ SpecLayout composed
		newRow: [ :mainRow | 
			(self instVarNamesFrom: aDynamicPresentersListBuilder)
				groupsOf: self rowsCount
				atATimeDo: [ :group | 
					mainRow newColumn: [ :column |
						group do: [ :instVar | column newRow: instVar ] ] ] ]! !

!DynamicTopToBottomRowsLayout methodsFor: 'accessing' stamp: ''!
rowsCount
	^ rowsCount! !

!DynamicTopToBottomRowsLayout class methodsFor: 'instance creation' stamp: ''!
rows: anInteger
	^ self new
		rowsCount: anInteger;
		yourself! !

!DynamicVariable commentStamp: ''!
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: ''!
value: anObject during: aBlock
	| activeProcess oldValue |
	activeProcess := Processor activeProcess.
	"oldValue will be nil if the variable has not yet been set"
	oldValue := activeProcess psValueAt: index.
	^ [ activeProcess
			psValueAt: index
			put: anObject.
		aBlock value ] ensure: [ 
			activeProcess
				psValueAt: index
				put: oldValue ]! !

!DynamicVariable class methodsFor: 'accessing' stamp: ''!
value: anObject during: aBlock

	^ self soleInstance value: anObject during: aBlock! !

!EDDebuggingAPI commentStamp: ''!
I am the default ED Debugging interface.
I return a set of CmCommands exposing my interface.!
!EDDebuggingAPI methodsFor: 'API - Stack' stamp: ''!
stackSize
	^ self longStack size! !

!EDDebuggingAPI methodsFor: 'API - Context' stamp: ''!
restartContextAt: anIndex
	session restart: (self contextAt: anIndex).
	self resetStack! !

!EDDebuggingAPI methodsFor: 'API - Context' stamp: ''!
methodAt: index
	^(self contextAt: index) method! !

!EDDebuggingAPI methodsFor: 'accessing' stamp: ''!
debugger: anObject
	debugger := anObject! !

!EDDebuggingAPI methodsFor: 'accessing' stamp: ''!
debugger
	^debugger! !

!EDDebuggingAPI methodsFor: 'API - Stack' stamp: ''!
dumpStack

	| str |
	str := String new writeStream.
	self stack printOn: str delimiter: String cr.
	^ str contents! !

!EDDebuggingAPI methodsFor: 'accessing' stamp: ''!
session
	^session! !

!EDDebuggingAPI methodsFor: 'API - Stack' stamp: ''!
stack 	
	^self longStack! !

!EDDebuggingAPI methodsFor: 'API - Stack' stamp: ''!
stackAt: index
	^self stack at: index! !

!EDDebuggingAPI methodsFor: 'API - Debugging support' stamp: ''!
resume
	self closeEmergencySession.
	session resume! !

!EDDebuggingAPI methodsFor: 'API - Processes' stamp: ''!
terminateAllProcesses
	self terminateSession.
	self class terminateAllProcesses! !

!EDDebuggingAPI methodsFor: 'API - Context' stamp: ''!
contextAt: index
	^self stackAt: index! !

!EDDebuggingAPI methodsFor: 'API - Stack' stamp: ''!
longStackSize
	^self class longStackSize! !

!EDDebuggingAPI methodsFor: 'API - Revert' stamp: ''!
methodVersionAt: index
	^ self versionsForMethod: (self methodAt: index)! !

!EDDebuggingAPI methodsFor: 'API - Stack' stamp: ''!
resetStack
	longStack := nil! !

!EDDebuggingAPI methodsFor: 'initialization' stamp: ''!
initialize
	changesForMethods := Dictionary new! !

!EDDebuggingAPI methodsFor: 'API - Stack' stamp: ''!
displayStackSize
	^self class displayStackSize! !

!EDDebuggingAPI methodsFor: 'API - Stack' stamp: ''!
longStack
	^ longStack
		ifNil: [ longStack := session stackOfSize: self longStackSize ]! !

!EDDebuggingAPI methodsFor: 'API - Debugging support' stamp: ''!
tryReopenSessionWithDebugger

	self closeEmergencySession.

	(OupsDebugRequest newForContext: session interruptedContext)
		process: session interruptedProcess;
		submit! !

!EDDebuggingAPI methodsFor: 'API - Revert' stamp: ''!
changeRecordsForMethod: aCompiledMethod
	^ SourceFiles
		changeRecordsFrom: aCompiledMethod sourcePointer
		className: aCompiledMethod methodClass name
		isMeta: aCompiledMethod methodClass isMeta! !

!EDDebuggingAPI methodsFor: 'API - Context' stamp: ''!
nodeAt: index
	^ self nodeForContext: (self contextAt: index)! !

!EDDebuggingAPI methodsFor: 'API - Debugging support' stamp: ''!
closeEmergencySession

	debugger terminate! !

!EDDebuggingAPI methodsFor: 'API - Debugging support' stamp: ''!
terminateSession
	self closeEmergencySession.
	session terminate! !

!EDDebuggingAPI methodsFor: 'accessing' stamp: ''!
changesForMethods
	^changesForMethods! !

!EDDebuggingAPI methodsFor: 'accessing' stamp: ''!
session: anObject
	session := anObject! !

!EDDebuggingAPI methodsFor: 'API - Revert' stamp: ''!
revert: aCompiledMethod to: aChangeRecord
	"Reverts the given method to the given change record"

	aCompiledMethod methodClass
		compile: aChangeRecord sourceCode
		classified: aChangeRecord category
		withStamp: aChangeRecord stamp
		notifying: nil! !

!EDDebuggingAPI methodsFor: 'API - Stack' stamp: ''!
stackFrom: start to: stop
	^ self longStack copyFrom: (start max: 0) to: (stop min: session stack size)! !

!EDDebuggingAPI methodsFor: 'API - Revert' stamp: ''!
revert: aCompiledMethod to: aChangeRecord inContext: aContext
	"Reverts the given method to the given change record in the given context. 
	The cached stack is updated."

	session
		recompileMethodTo: aChangeRecord sourceCode
		inContext: aContext
		notifying: nil.
	longStack := nil! !

!EDDebuggingAPI methodsFor: 'API - Revert' stamp: ''!
versionsForMethod: aCompiledMethod
	^ changesForMethods
		at: aCompiledMethod
		ifAbsentPut: [ self changeRecordsForMethod: aCompiledMethod ]! !

!EDDebuggingAPI methodsFor: 'API - Revert' stamp: ''!
methodVersionSizeAt: index
	^ (self versionsForMethod: (self methodAt: index)) size! !

!EDDebuggingAPI methodsFor: 'API - Context' stamp: ''!
nodeForContext: aContext
	^ aContext method sourceNodeForPC: aContext pc! !

!EDDebuggingAPI class methodsFor: 'API - Processes' stamp: ''!
allRunningProcesses
	^ Process allSubInstances
		reject: [ :each | 
			each isTerminated
				or: [ self forbiddenProcesses anySatisfy: [ :block | block value == each ] ] ]! !

!EDDebuggingAPI class methodsFor: 'accessing' stamp: ''!
longStackSize
	^100! !

!EDDebuggingAPI class methodsFor: 'accessing' stamp: ''!
displayStackSize
	^5! !

!EDDebuggingAPI class methodsFor: 'API - Processes' stamp: ''!
forbiddenProcesses
	^ {[  ].
	[ Smalltalk lowSpaceWatcherProcess ].
	[ WeakArray runningFinalizationProcess ].
	[ Processor backgroundProcess ].
	[ UIManager default uiProcess ].
	[ Delay schedulingProcess ]}! !

!EDDebuggingAPI class methodsFor: 'start' stamp: ''!
attachTo: aDebugSession
	^ self new
		session: aDebugSession;
		yourself! !

!EDDebuggingAPI class methodsFor: 'API - Processes' stamp: ''!
terminateProcesses: processes
	processes do: [ :process | process ifNotNil: [ process terminate ] ]! !

!EDDebuggingAPI class methodsFor: 'API - Processes' stamp: ''!
terminateAllProcesses
	self terminateProcesses: self allRunningProcesses! !

!EDDebuggingAPITest methodsFor: 'tests - stack' stamp: ''!
testStack 
	self assert: debugAPI stack identicalTo: debugAPI longStack! !

!EDDebuggingAPITest methodsFor: 'tests - stack' stamp: ''!
testDumpStack
	| dump splittedDump |
	dump := debugAPI dumpStack.
	splittedDump := dump splitOn: Character cr.
	self
		assertCollection: splittedDump
		equals: (session shortStack collect: [ :ctx | ctx printString ])! !

!EDDebuggingAPITest methodsFor: 'tests - stack' stamp: ''!
testLongStackSize
	self
		assert: debugAPI longStackSize
		equals: debugAPI class longStackSize! !

!EDDebuggingAPITest methodsFor: 'tests - debugging support' stamp: ''!
testTerminateSession

	|process|
	ed := EDEmergencyDebugger new.
	ed basicDebug: session.
	process := ed debugAPI session interruptedProcess.
	ed debugAPI terminateSession.
	self assert: ed debugAPI session interruptedProcess isNil.
	self assert: process isTerminated! !

!EDDebuggingAPITest methodsFor: 'tests - processes' stamp: ''!
testForbiddenProcesses
	EDDebuggingAPI forbiddenProcesses
		with: self forbiddenProcesses
		do:
			[ :actualProcess :expectedProcess | self assert: actualProcess value identicalTo: expectedProcess value ]! !

!EDDebuggingAPITest methodsFor: 'tests - stack' stamp: ''!
testLongStack
	self
		assertCollection: debugAPI longStack
		equals: (session stackOfSize: debugAPI longStackSize)! !

!EDDebuggingAPITest methodsFor: 'tests - initialization' stamp: ''!
testInitialize
	self assert: debugAPI debugger isNil.
	self assertEmpty: debugAPI changesForMethods! !

!EDDebuggingAPITest methodsFor: 'tests - reverting methods' stamp: ''!
testChangeRecordsForMethod
	| changes |
	self prepareMethodVersionTest.
	changes := debugAPI
		changeRecordsForMethod: (EDMockObjectForTests >> #mWithVersion) asHistoricalRingDefinition.
	self assert: changes size equals: 2.
	self assert: changes first sourceCode equals: self sampleMethodSourceCodeVersion2.
	self assert: changes second sourceCode equals: self sampleMethodSourceCodeVersion1! !

!EDDebuggingAPITest methodsFor: 'tests - reverting methods' stamp: ''!
testMethodVersionSizeAt
	self injectContextWithMethodWithChanges.
	self assert: (debugAPI methodVersionAt: 1) size equals: 2! !

!EDDebuggingAPITest methodsFor: 'tests - context' stamp: ''!
testContextAt
	1 to: session stack size do: [ :i | 
		self
			assert: (debugAPI contextAt: i)
			identicalTo: (session stack at: i) ]! !

!EDDebuggingAPITest methodsFor: 'tests - processes' stamp: ''!
testAllRunningProcesses
	| processes |
	processes := EDDebuggingAPI allRunningProcesses.
	self assertCollection: Process allSubInstances includesAll: processes.
	self
		denyCollection: processes
		includesAny: EDDebuggingAPI forbiddenProcesses.
	processes do: [ :p | self deny: p isTerminated ]! !

!EDDebuggingAPITest methodsFor: 'tests - context' stamp: ''!
testNodeForContext
	| context |
	context := session stack first.
	self
		assert: (debugAPI nodeForContext: context)
		identicalTo: (context method sourceNodeForPC: context pc)! !

!EDDebuggingAPITest methodsFor: 'tests - initialization' stamp: ''!
testAttachTo
	self assert: debugAPI session identicalTo: session! !

!EDDebuggingAPITest methodsFor: 'tests - reverting methods' stamp: ''!
testVersionsForMethod
	|changes|
	self prepareMethodVersionTest.
	changes := debugAPI versionsForMethod: (EDMockObjectForTests >> #mWithVersion).	
	self assert: debugAPI changesForMethods size equals: 1.
	self assert: (debugAPI changesForMethods at: (EDMockObjectForTests >> #mWithVersion))
			identicalTo: changes! !

!EDDebuggingAPITest methodsFor: 'tests - context' stamp: ''!
testRestartContextAt
	| secondContext |
	secondContext := debugAPI longStack second.
	debugAPI restartContextAt: 2.
	self assert: debugAPI longStack first identicalTo: secondContext! !

!EDDebuggingAPITest methodsFor: 'tests - stack' stamp: ''!
testDisplayStackSize
	self
		assert: debugAPI displayStackSize
		equals: debugAPI class displayStackSize! !

!EDDebuggingAPITest methodsFor: 'helpers' stamp: ''!
injectContextWithMethodWithChanges
	| context |
	self prepareMethodVersionTest.
	context := Context
		newForMethod: EDMockObjectForTests >> #mWithVersion.
	context
		setSender: nil
		receiver: nil
		method: EDMockObjectForTests >> #mWithVersion
		closure: nil
		startpc: nil.
	debugAPI stack addFirst: context! !

!EDDebuggingAPITest methodsFor: 'tests - context' stamp: ''!
testNodeAt
	1 to: session stack size do: [ :i | 
		| context |
		context := session stack at: i.
		self
			assert: (debugAPI nodeAt: i)
			identicalTo: (context method sourceNodeForPC: context pc) ]! !

!EDDebuggingAPITest methodsFor: 'tests - stack' stamp: ''!
testStackFromTo
	| stack stackExtract |
	stack := session stack.
	stackExtract := (stack copyFrom: 5 to: 10).
	self
		assertCollection: (debugAPI stackFrom: 5 to: 10)
		equals: stackExtract.
		
	stackExtract := (stack copyFrom: (stack size - 2) to: (stack size)).
	self
		assertCollection: (debugAPI stackFrom: (stack size - 2) to: (stack size + 5))
		equals: stackExtract.! !

!EDDebuggingAPITest methodsFor: 'tests - stack' stamp: ''!
testStackAt
	1 to: session stack size do:
		[ :i | self assert: (debugAPI stackAt: i) equals: (session stack at: i) ]! !

!EDDebuggingAPITest methodsFor: 'helpers' stamp: ''!
forbiddenProcesses
	self flag: 'This is a fixed list of processes we do not want to kill if they exist. This is too magickal, but we lack tools to have such information and we do not want to depend on process browser packages (information is taken from there).'.
	^ {[  ].
	[ Smalltalk lowSpaceWatcherProcess ].
	[ WeakArray runningFinalizationProcess ].
	[ Processor backgroundProcess ].
	[ UIManager default uiProcess ].
	[ Delay schedulingProcess ]}! !

!EDDebuggingAPITest methodsFor: 'tests - stack' stamp: ''!
testResetStack
	debugAPI longStack removeAll.
	debugAPI resetStack.
	self
		assertCollection: debugAPI longStack
		equals: (session stackOfSize: debugAPI longStackSize)! !

!EDDebuggingAPITest methodsFor: 'tests - context' stamp: ''!
testMethodAt
	1 to: session stack size do: [ :i | 
		self
			assert: (debugAPI methodAt: i)
			identicalTo: (session stack at: i) method ]! !

!EDDebuggingAPITest methodsFor: 'tests - reverting methods' stamp: ''!
testRevertTo
	|method changes|
	self prepareMethodVersionTest.
	method := (EDMockObjectForTests >> #mWithVersion).
	changes := debugAPI changeRecordsForMethod: method.
		
	self assert: method sourceCode equals: self sampleMethodSourceCodeVersion2.
	debugAPI revert: (EDMockObjectForTests >> #mWithVersion) to: changes second.
	
	"Method version is now the reverted one"
	method := (EDMockObjectForTests >> #mWithVersion).
	self assert: method sourceCode equals: self sampleMethodSourceCodeVersion1.
	
	"Changes now include new version, equals to the first one"
	changes := debugAPI changeRecordsForMethod: method. 
	self assert: changes size equals: 3.
	self assert: changes first sourceCode equals: self sampleMethodSourceCodeVersion1.
	self assert: changes second sourceCode equals: self sampleMethodSourceCodeVersion2.
	self assert: changes third sourceCode equals: self sampleMethodSourceCodeVersion1.
	
	"Changes cache should be updated: 
	we test for source code version, as changes cannot compare otherwise than using identity check =="
	self assert: (debugAPI versionsForMethod: method) size equals: 3.
	self assertCollection: ((debugAPI versionsForMethod: method) collect:[:c| c sourceCode])
				equals: (changes collect:[:c| c sourceCode])! !

!EDDebuggingAPITest methodsFor: 'tests - processes' stamp: ''!
testTerminateProcesses
	|processes|
	processes := { [  ] newProcess.  [  ] newProcess.}.
	processes do:[:p| self deny: p isTerminated].
	
	EDDebuggingAPI terminateProcesses: processes.
	processes do:[:p| self assert: p isTerminated].! !

!EDDebuggingAPITest methodsFor: 'tests - reverting methods' stamp: ''!
testRevertToInContext
	|method changes|
	self prepareMethodVersionTest.
	method := (EDMockObjectForTests >> #mWithVersion).
	changes := debugAPI changeRecordsForMethod: method.
		
	self assert: method sourceCode equals: self sampleMethodSourceCodeVersion2.
	debugAPI revert: (EDMockObjectForTests >> #mWithVersion) 
				to: changes second 
				inContext: debugAPI stack first.
	
	"Method version is now the reverted one"
	method := (EDMockObjectForTests >> #mWithVersion).
	self assert: method sourceCode equals: self sampleMethodSourceCodeVersion1.
	
	"Stack is updated"
	self assertCollection: debugAPI longStack 
		  equals: (debugAPI session stackOfSize: debugAPI longStackSize).
	
	"Changes now include new version, equals to the first one"
	changes := debugAPI changeRecordsForMethod: method. 
	self assert: changes size equals: 3.
	self assert: changes first sourceCode equals: self sampleMethodSourceCodeVersion1.
	self assert: changes second sourceCode equals: self sampleMethodSourceCodeVersion2.
	self assert: changes third sourceCode equals: self sampleMethodSourceCodeVersion1.
	
	"Changes cache should be updated: 
	we test for source code version, as changes cannot compare otherwise than using identity check =="
	self assert: (debugAPI versionsForMethod: method) size equals: 3.
	self assertCollection: ((debugAPI versionsForMethod: method) collect:[:c| c sourceCode])
				equals: (changes collect:[:c| c sourceCode])! !

!EDDebuggingAPITest methodsFor: 'tests - reverting methods' stamp: ''!
testMethodVersionAt
	self injectContextWithMethodWithChanges.
	self
		assert: (debugAPI methodVersionAt: 1)
		equals: (debugAPI changesForMethods at: EDMockObjectForTests >> #mWithVersion)! !

!EDDebuggingAPITest methodsFor: 'tests - debugging support' stamp: ''!
testCloseEmergencySession
	ed := EDEmergencyDebugger new.
	ed basicDebug: session.
	ed debugAPI closeEmergencySession.
	self deny: ed isRunning! !

!EDDebuggingAPITest methodsFor: 'tests - stack' stamp: ''!
testStackSize
	self
		assert: debugAPI stackSize
		equals: debugAPI stack size! !

!EDDisplayEventHandler commentStamp: ''!
An event handler for the emergency debugger, it will just handle a few things: 
- character entries, and
- the window close button!
!EDDisplayEventHandler methodsFor: 'visiting' stamp: ''!
visitTextInputEvent: anEvent
	| char mods |

	anEvent text ifNil: [ ^ nil ].

	char := anEvent text first.
	char ifNil: [ ^ nil ].
	mods := anEvent modifiers.
	"If a modifier key is pressed the keystroke event is handled by #visitMouseDownEvent:"
	(mods alt or: [ mods ctrl or: [ mods cmd ] ])
		ifTrue: [ ^ nil ].

	interface pushChar: char! !

!EDDisplayEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowCloseEvent: anEvent

	anEvent suppressDefaultAction.
	interface closeWindow! !

!EDDisplayEventHandler methodsFor: 'visiting' stamp: ''!
visitKeyDownEvent: event

	event character ifNil: [ ^ self ].	
	interface pushChar: event character! !

!EDDisplayEventHandler methodsFor: 'accessing' stamp: ''!
interface

	^ interface! !

!EDDisplayEventHandler methodsFor: 'accessing' stamp: ''!
interface: anObject

	interface := anObject! !

!EDDisplayEventHandler class methodsFor: 'instance creation' stamp: ''!
on: anInterface

	^ self new 
		interface: anInterface;
		yourself! !

!EDDisplayInterface commentStamp: ''!
I am a simple interface to the Display screen canvas to draw text.!
!EDDisplayInterface methodsFor: 'accessing' stamp: ''!
terminateWindow

	window ifNil: [ ^ self ].
	window destroy! !

!EDDisplayInterface methodsFor: 'private - display' stamp: ''!
closeWindow

	windowClosedAction 
		ifNotNil: [ windowClosedAction value ]
		ifNil: [ self terminateWindow ]! !

!EDDisplayInterface methodsFor: 'private - text' stamp: ''!
pushChar: char

	characterReceivedAction ifNil: [ ^ self ].
	characterReceivedAction value: char! !

!EDDisplayInterface methodsFor: 'private - text' stamp: ''!
composeParagraphWith: aText inFrame: aRect
	| paragraph |

	paragraph := Paragraph new.
	paragraph
		compose: aText
		style: self textStyle
		from: 1
		in: ((aRect insetBy: 4) withHeight: aRect height).
	
	^ paragraph! !

!EDDisplayInterface methodsFor: 'accessing - properties' stamp: ''!
black
	^ Color black! !

!EDDisplayInterface methodsFor: 'private - text' stamp: ''!
textStyle
	^ TextStyle default! !

!EDDisplayInterface methodsFor: 'private - display' stamp: ''!
ensureWindowOpen
	| attrs |
	
	window ifNotNil: [ 
		window isVisible ifFalse: [ window show ].
		^ self ].
	
	attrs := OSWindowAttributes new.
	attrs 
		title: 'Emergency Debugger';
		extent: self extent;
		resizable: false.
		
	window := OSWindow 
		createWithAttributes: attrs
		eventHandler: (EDDisplayEventHandler on: self).
	renderer := window newFormRenderer: (Form extent: self extent depth: 32).! !

!EDDisplayInterface methodsFor: 'events' stamp: ''!
whenWindowClosedDo: aBlock
	"informs when window was closed from buttons"

	windowClosedAction := aBlock! !

!EDDisplayInterface methodsFor: 'private - display' stamp: ''!
drawDuring: aBlock

	self ensureWindowOpen.
	renderer deferUpdatesWhile: [
		renderer drawDuring: aBlock.
		renderer present ]! !

!EDDisplayInterface methodsFor: 'private - display' stamp: ''!
frame

	^ 0@0 corner: self extent! !

!EDDisplayInterface methodsFor: 'events' stamp: ''!
whenCharacterReceivedDo: aBlock

	characterReceivedAction := aBlock! !

!EDDisplayInterface methodsFor: 'accessing - properties' stamp: ''!
white
	^ Color white! !

!EDDisplayInterface methodsFor: 'accessing - properties' stamp: ''!
red
	^ Color red! !

!EDDisplayInterface methodsFor: 'private - display' stamp: ''!
extent

	^ extent ifNil: [ 
		extent := DisplayScreen actualScreenSize min: (650@700) ]! !

!EDDisplayInterface methodsFor: 'accessing' stamp: ''!
show: aText
	
	self
		display: (self 
			composeParagraphWith: aText 
			inFrame: self frame)
		in: self frame! !

!EDDisplayInterface methodsFor: 'accessing' stamp: ''!
clear
	
	self drawDuring: [ :canvas | 
		canvas
			frameAndFillRectangle: self frame
			fillColor: self white
			borderWidth: 2
			borderColor: self red ]! !

!EDDisplayInterface methodsFor: 'accessing - properties' stamp: ''!
gray
	^ Color gray! !

!EDDisplayInterface methodsFor: 'private - display' stamp: ''!
display: aParagraph in: aRect

	self drawDuring: [ :canvas |
		canvas
			paragraph: aParagraph
			bounds: aRect
			color: self black ]! !

!EDEmergencyDebugger commentStamp: ''!
I am a REPL debugger and I provide an access to the Sindarin debugging API.
I do not depend on morphic, and while I depend on Color, I can work without it.

I use a `ReadWriteStream` to handle user input and output my results.
I use `Display` and `DisplayScreen` to show my results.

To invoke me, use my class method `debugError: anError fromSession: aDebugSession`.
This method takes as input an error and a debug session.
The error is used to display information about what brought you to ED.
It is not mandatory, if you only have a debug session you can invoke me by doing:
`EDEmergencyDebugger new emergencyDebug: aDebugSession`.
The debug session contains all information necessary to debug.

For example, execute the following as an example:
```
|context process session|
context := [ EDMockObjectForTests new m: 20 ] asContext.
	process := Process
		forContext: context
		priority: Processor userInterruptPriority.
	session := DebugSession
		named: 'test session'
		on: process
		startedAt: context.
	session stepThrough.
	session stepOver.
	session stepInto.
	session stepOver.
	session stepOver.
	session stepInto.
	EDEmergencyDebugger new emergencyDebug: session.
```
	
Navigate the stack with up/down arrows.
When you are on a method (in the stack), use left/right arrow to navigate the versions of that method.
To revert the selected method (in the stack) to the selected version (displayed in the middle text pane), type `revert` and press enter.

Don't forget to read the help text, type `h` or `help` to display the help text.
!
!EDEmergencyDebugger methodsFor: 'stack' stamp: ''!
shiftDownShortStack
	"rebuilds the short stack that is displayed by shitfing down the stack view by debugAPI displayStackSize elements"

	| start stop |
	shortStackIndex := 1.
	start := stackSelectionIndex.
	stop := stackSelectionIndex + debugAPI displayStackSize - 1
		min: debugAPI stackSize.
	shortStack := debugAPI stackFrom: start to: stop! !

!EDEmergencyDebugger methodsFor: 'stack' stamp: ''!
moveDownInStack
	stackSelectionIndex = debugAPI stackSize
		ifTrue: [ ^ self ].
	stackSelectionIndex := stackSelectionIndex + 1.
	shortStackIndex := shortStackIndex + 1.
	shortStackIndex > debugAPI displayStackSize
		ifTrue: [ self shiftDownShortStack ].
	methodVersionSelectionIndex := 0.
	self composeStackText.
	self composeMethodText.
	self composeHelpText! !

!EDEmergencyDebugger methodsFor: 'initialization' stamp: ''!
debug: aDebugSession

	self basicDebug: aDebugSession.
	self composeTitleText.
	self composeStackText.
	self composeMethodText.
	self composeHelpText.
	self composePromptWith: ''.
	self updateDisplay.
	repl readEvalPrint! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
shortStackIndex: newIndex
	shortStackIndex := newIndex! !

!EDEmergencyDebugger methodsFor: 'actions' stamp: ''!
descriptionFromPromptCommand: aString
	|key|
	key := self availableActionsDescriptionsMap at: aString.
	^self availableActionsDescriptions at: key! !

!EDEmergencyDebugger methodsFor: 'testing' stamp: ''!
isRunning
	^isRunning! !

!EDEmergencyDebugger methodsFor: 'text - composing' stamp: ''!
composeTitleText
	titleText := 'Hi, I''m ED - What is the nature of your debugging emergency?' asText allBold! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
debugAPI: aDebugAPI
	debugAPI := aDebugAPI! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
methodVersionSelectionIndex
	^methodVersionSelectionIndex! !

!EDEmergencyDebugger methodsFor: 'methods' stamp: ''!
revertCurrentMethodToSelectedVersion
	"should:
		- revert method from the current selected context to the selected method version
		- restart the context
		- update texts"
	|method methodVersion|
	method := debugAPI methodAt: stackSelectionIndex.
	methodVersion := (debugAPI methodVersionAt: stackSelectionIndex) at: methodVersionSelectionIndex.
	debugAPI revert: method to: methodVersion inContext: (debugAPI contextAt: stackSelectionIndex).
	shortStack := nil.
	
	stackSelectionIndex := 1.
	shortStackIndex := 1.
	self composeStackText.
	self composeMethodText.
	methodVersionSelectionIndex := 1.
	self showSelectedMethodVersion! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
titleText
	^titleText! !

!EDEmergencyDebugger methodsFor: 'evaluation' stamp: ''!
evalCommand: aString
	| action |
	
	action := self availableActions at: aString ifAbsent: [ ^ false ].
	[ action value ]
		on: Exception
		do:
			[ :e | self handleEmergencyDebuggerError: e description: aString ].
	self updateDisplay.
	^ true! !

!EDEmergencyDebugger methodsFor: 'methods' stamp: ''!
showMoreRecentMethodVersion
	methodVersionSelectionIndex := methodVersionSelectionIndex - 1 max: 1.
	self showSelectedMethodVersion! !

!EDEmergencyDebugger methodsFor: 'error handling' stamp: ''!
errorDescriptionFrom: anError
	^ [ anError description ]
		on: Error
		do: [ 'a ' , anError class printString ]! !

!EDEmergencyDebugger methodsFor: 'text - helpers' stamp: ''!
writeSectionTitle: aString on: aStream
	self writeSeparatorOn: aStream.
	aStream << (aString asText makeAllColor: rawDisplay gray).
	aStream cr.
	self writeSeparatorOn: aStream! !

!EDEmergencyDebugger methodsFor: 'actions' stamp: ''!
availableActionsDescriptionsMap
	^self buildDefaultActionsDescriptionsMap! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
debugAPI
	^debugAPI! !

!EDEmergencyDebugger methodsFor: 'initialization' stamp: ''!
initialize

	repl := EDREPLInterface forDebugger: self.
	rawDisplay := EDDisplayInterface new
		whenCharacterReceivedDo: [ :aChar | repl pushChar: aChar ];
		whenWindowClosedDo: [ self terminate ].
	
	stackSelectionIndex := 1.
	shortStackIndex := 1.
	methodVersionSelectionIndex := 0.
	input := Text new.
	self composeResult: Text new title: self defaultResultText.
	isRunning := false.
	errorText := Text new! !

!EDEmergencyDebugger methodsFor: 'text - helpers' stamp: ''!
newTextStream
	^WriteStream on: Text new! !

!EDEmergencyDebugger methodsFor: 'private' stamp: ''!
showDebuggerError
	| context text |
	error
		ifNil: [ self composeResult: '' title: 'No error.'.
			^ self updateDisplay ].
	context := error signalerContext.
	text := String
		streamContents: [ :s | 
			20
				timesRepeat: [ context == nil
						ifFalse: [ s
								cr;
								print: (context := context sender) ] ] ].
	self composeResult: text title: error description.
	self updateDisplay! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
stackText
	^stackText! !

!EDEmergencyDebugger methodsFor: 'text - composing' stamp: ''!
composeMethodText
	| str method node text |
	str := self newTextStream.
	self writeSectionTitle: 'SOURCE' on: str.
	method := debugAPI methodAt: stackSelectionIndex.
	node := debugAPI nodeAt: stackSelectionIndex.	
	text := method sourceCode asText.
	text makeColor: rawDisplay red from: node start to: node stop.
	str << method methodClass name.
	str << '>>'.
	str << text.
	str cr.
	methodText := str contents! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
displayInterface: aDisplayInterface
	rawDisplay := aDisplayInterface! !

!EDEmergencyDebugger methodsFor: 'text - helpers' stamp: ''!
writeSeparatorOn: aStream
	aStream << self separator.
	aStream cr! !

!EDEmergencyDebugger methodsFor: 'text - composing' stamp: ''!
composeDisplayText
	^(titleText , (self composeSessionTitle), stackText, methodText, input, result )! !

!EDEmergencyDebugger methodsFor: 'initialization' stamp: ''!
basicDebug: aDebugSession
	debugAPI := self class debugAPI attachTo: aDebugSession.
	debugAPI debugger: self.
	isRunning := true! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
shortStackIndex
	^shortStackIndex! !

!EDEmergencyDebugger methodsFor: 'text - composing' stamp: ''!
composeResult: text title: title
	| str |
	str := self newTextStream.
	str cr.
	self writeSectionTitle: title on: str.
	str << text.
	result := str contents! !

!EDEmergencyDebugger methodsFor: 'text - helpers' stamp: ''!
defaultResultText
	^ 'TYPE h FOR HELP' asText! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
errorText
	^errorText! !

!EDEmergencyDebugger methodsFor: 'updating' stamp: ''!
updatePrompt: aString
	self composePromptWith: aString.
	self updateDisplay! !

!EDEmergencyDebugger methodsFor: 'initialization' stamp: ''!
emergencyDebug: aDebugSession

	[ self debug: aDebugSession ]
		on: Error
		do: [ :err | 
			DebuggerEmmergencyLogger new
				logError: err
				forSession: aDebugSession ]! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
input
	^input! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
methodText
	^methodText! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
result
	^result! !

!EDEmergencyDebugger methodsFor: 'evaluation' stamp: ''!
performActionForChar: aCharacter
	^self evalCommand: aCharacter! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
methodVersionSelectionIndex: anInteger
	methodVersionSelectionIndex := anInteger! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
resultText
	^ result! !

!EDEmergencyDebugger methodsFor: 'private' stamp: ''!
debugDebuggerError
	self terminate.
	error debug! !

!EDEmergencyDebugger methodsFor: 'updating' stamp: ''!
updateDisplay
	rawDisplay clear.
	rawDisplay show: self composeDisplayText! !

!EDEmergencyDebugger methodsFor: 'text - composing' stamp: ''!
composeSessionTitle
	| errStream |
	errStream := WriteStream on: Text new.
	errStream cr.
	self writeSeparatorOn: errStream.
	errStream << debugAPI session name.
	^errStream contents! !

!EDEmergencyDebugger methodsFor: 'methods' stamp: ''!
selectedMethodVersionsSize
	^ debugAPI methodVersionSizeAt: stackSelectionIndex! !

!EDEmergencyDebugger methodsFor: 'actions' stamp: ''!
availableActionsDescriptions 
	^actionsDescriptions ifNil:[actionsDescriptions := self buildDefaultActionsDescriptions]! !

!EDEmergencyDebugger methodsFor: 'private' stamp: ''!
dumpStackAndQuit
	| stackStrace |
	stackStrace := debugAPI dumpStack.
	debugAPI terminateSession.
	stackStrace inspect! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
stackSelectionIndex
	^stackSelectionIndex! !

!EDEmergencyDebugger methodsFor: 'stack' stamp: ''!
moveUpInStack
	stackSelectionIndex = 1
		ifTrue: [ ^ self ].
	stackSelectionIndex := stackSelectionIndex - 1.
	shortStackIndex := shortStackIndex - 1.
	shortStackIndex = 0
		ifTrue: [ self shiftUpShortStack ].
	methodVersionSelectionIndex := 0.
	self composeStackText.
	self composeMethodText.
	self composeHelpText! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
resetDisplay

	rawDisplay destroyWindow! !

!EDEmergencyDebugger methodsFor: 'methods' stamp: ''!
showOlderMethodVersion
	methodVersionSelectionIndex := methodVersionSelectionIndex + 1
		min: self selectedMethodVersionsSize.
	self showSelectedMethodVersion! !

!EDEmergencyDebugger methodsFor: 'methods' stamp: ''!
revertCurrentMethodToSelectedVersionAndQuit
	"should:
		- revert method from the current selected context to the selected method version
		- quit the emergency debugger"
	|method methodVersion|
	method := debugAPI methodAt: stackSelectionIndex.
	methodVersion := (debugAPI methodVersionAt: stackSelectionIndex) at: methodVersionSelectionIndex.
	debugAPI revert: method to: methodVersion inContext: (debugAPI contextAt: stackSelectionIndex).
	debugAPI terminateSession! !

!EDEmergencyDebugger methodsFor: 'methods' stamp: ''!
showSelectedMethodVersion
	| selectedVersion text |
	selectedVersion := self selectedMethodVersion.
	text := selectedVersion sourceCode asText.
	text makeBoldFrom: 1 to: selectedVersion methodSelector size.
	self
		composeResult: text
		title:
			'VERSIONS (' , methodVersionSelectionIndex printString , '/'
				, self selectedMethodVersionsSize printString , ')'.
	self updateDisplay! !

!EDEmergencyDebugger methodsFor: 'actions' stamp: ''!
availableActions 
	^actions ifNil:[actions := self buildDefaultActions]! !

!EDEmergencyDebugger methodsFor: 'actions' stamp: ''!
buildDefaultActionsDescriptions
	|dic|
	dic := Dictionary new.
	dic at: 'exit/q' put: 'Exit the emergency debugger'.
	dic at: 'help' put: 'Show this help.'.
	dic at: 'retry' put: 'Retry opening a graphical debugger'.
	dic at: '<UP/DOWN> arrows' put: 'Move up/down in the stack'.
	dic at: '<RIGHT/LEFT> arrows' put: 'Navigate the current method versions'.
	dic at: 'revert' put: 'Revert the current method to the selected method version in the current context'.
	dic at: 'forceRevert' put: 'Recompiles the current method to the selected method version and quits the emergency debugger'.
	dic at: 'terminateAll' put: 'Terminate all non-essential processes (will terminate Ed)'.
	dic at: 'proceed' put: 'Proceeds the execution'.
	dic at: 'showDebuggerError' put: 'Display debugger error stack, i.e., why you are here.'.
	dic at: 'debug' put: 'Debug the debugger error.'.
	dic at: 'dump' put: 'Dump a printed representation of the stack, quits the debugger and inspects the dump.'.
	dic at: 'inspect' put: 'Quits the debugger and inspects the stack.'.
	^dic! !

!EDEmergencyDebugger methodsFor: 'initialization' stamp: ''!
terminate

	isRunning := false.
	rawDisplay terminateWindow.
	repl terminateREPL! !

!EDEmergencyDebugger methodsFor: 'error handling' stamp: ''!
handleEmergencyDebuggerError: e description: commandString
	self
		composeResult:
			('Cannot ' , (self descriptionFromPromptCommand: commandString))
				asText allBold
		title: 'ERROR: ' , (self errorDescriptionFrom: e)
	"isRunning := false.
	[ [ e debug ]
		on: Error
		do: [ :err | self signalDebuggerError: err forSession: debugAPI session ] ]
		ensure: [ isRunning := true.
			repl readEvalPrint ]"! !

!EDEmergencyDebugger methodsFor: 'actions' stamp: ''!
buildDefaultActionsDescriptionsMap
	|dic|
	dic := Dictionary new.	
	dic at: 'exit' put: 'exit/q'.
	dic at: 'q' put: 'exit/q'.
	dic at: 'retry' put: 'retry'.
	dic at: Character arrowUp put: '<UP/DOWN> arrows'.
	dic at: Character arrowDown put: '<UP/DOWN> arrows'.
	dic at: Character arrowLeft put: '<RIGHT/LEFT> arrows'.
	dic at: Character arrowRight put: '<RIGHT/LEFT> arrows'.
	dic at: 'revert' put: 'revert'.
	dic at: 'forceRevert' put: 'forceRevert'.	
	dic at: 'help' put: 'help'.
	dic at: 'terminateAll' put: 'terminateAll'.
	dic at: 'proceed' put: 'proceed'.
	dic at: 'showDebuggerError' put: 'showDebuggerError'.	
	dic at: 'debug' put: 'debug'.
	dic at: 'dump' put: 'dump'.
	dic at: 'inspect' put: 'inspect'.
	^dic! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
originalError
	^error! !

!EDEmergencyDebugger methodsFor: 'text - composing' stamp: ''!
composeErrorTextFrom: anError
	| errStream |
	errStream := WriteStream on: Text new.
	errStream cr.
	self writeSeparatorOn: errStream.
	errStream << anError description.
	errorText := errStream contents! !

!EDEmergencyDebugger methodsFor: 'text - composing' stamp: ''!
composePromptWith: aString
	| str  |
	str := self newTextStream.	
	str cr.
	self writeSeparatorOn: str.
	str << '> ' asText allBold.
	str << aString trim asText.
	input := str contents! !

!EDEmergencyDebugger methodsFor: 'actions' stamp: ''!
buildDefaultActions
	|dic|
	
	dic := Dictionary new.
	dic at: 'q!!' 						put: [ debugAPI closeEmergencySession ].
	dic at: 'q' 							put: [ debugAPI terminateSession ].
	dic at: 'showDebuggerError' 	put: [ self showDebuggerError ].
	dic at: 'exit' 						put: [ debugAPI terminateSession ].
	dic at: 'retry' 					put: [ debugAPI tryReopenSessionWithDebugger ].
	dic at: Character arrowUp 		put: [ self moveUpInStack ].
	dic at: Character arrowDown 	put: [ self moveDownInStack ].
	dic at: Character arrowLeft 	put: [ self showMoreRecentMethodVersion ].
	dic at: Character arrowRight 	put: [ self showOlderMethodVersion ].
	dic at: 'help' 						put: [ self composeHelpText ].
	dic at: 'revert' 					put: [ self revertCurrentMethodToSelectedVersion ].
	dic at: 'forceRevert' 			put: [ self revertCurrentMethodToSelectedVersionAndQuit ].
	dic at: 'terminateAll' 			put: [ debugAPI terminateAllProcesses ].
	dic at: 'proceed' 					put: [ debugAPI resume ].
	dic at: 'debug' 					put: [ self debugDebuggerError ].
	dic at: 'dump' 						put: [ self dumpStackAndQuit ].
	dic at: 'inspect' 					put: [ self inspectStackAndQuit ].
	
	^ dic! !

!EDEmergencyDebugger methodsFor: 'evaluation' stamp: ''!
eval: command

	self evalCommand: command.
	self composePromptWith: ''.
	self updateDisplay! !

!EDEmergencyDebugger methodsFor: 'private' stamp: ''!
inspectStackAndQuit
	debugAPI terminateSession.
	debugAPI longStack inspect! !

!EDEmergencyDebugger methodsFor: 'stack' stamp: ''!
shiftUpShortStack
	"rebuilds the short stack that is displayed by shitfing up the stack view by debugAPI displayStackSize elements"

	stackSelectionIndex = 1
		ifTrue: [ ^ shortStack := debugAPI stackFrom: 1 to: debugAPI displayStackSize ].
	shortStackIndex := debugAPI displayStackSize.
	^ shortStack := debugAPI
		stackFrom: (stackSelectionIndex - debugAPI displayStackSize max: 1)
		to: stackSelectionIndex! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
errorText: aText
	errorText := aText! !

!EDEmergencyDebugger methodsFor: 'text - composing' stamp: ''!
composeHelpText
	| str |
	str := self newTextStream.
	self availableActionsDescriptions
		keysAndValuesDo: [ :cmd :desc | 
			|text|
			text := (cmd, ': ') asText allBold, desc asText.
			text makeAllColor: rawDisplay gray.
			str << text.		
			str cr ].
	^ self composeResult: str contents title: 'HELP'! !

!EDEmergencyDebugger methodsFor: 'text - composing' stamp: ''!
composeStackText
	| str stack |
	str := self newTextStream.
	stack := self shortStack.
	str cr.
	self
		writeSectionTitle:
			'STACK (' , stackSelectionIndex printString , '/'
				, debugAPI stackSize printString , ')'
		on: str.
	1 to: stack size do: [ :i | 
		| textStream text |
		textStream := self newTextStream.
		(stack at: i) printWithArgsValueOn: textStream.
		text := textStream contents.
		i = shortStackIndex
			ifTrue: [ text allBold ].
		str << text.
		str cr ].
	stackText := str contents! !

!EDEmergencyDebugger methodsFor: 'text - helpers' stamp: ''!
separator 
	^'--------------------' asText makeAllColor: rawDisplay gray! !

!EDEmergencyDebugger methodsFor: 'initialization' stamp: ''!
fromError: anError
	self composeErrorTextFrom: anError.
	error := anError! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
repl: aREPLInterface
	repl := aREPLInterface! !

!EDEmergencyDebugger methodsFor: 'stack' stamp: ''!
shortStack
	^ shortStack
		ifNil: [ shortStack := debugAPI stackFrom: 1 to: debugAPI displayStackSize ]! !

!EDEmergencyDebugger methodsFor: 'methods' stamp: ''!
selectedMethodVersion
	|versions |	
	versions := debugAPI methodVersionAt: stackSelectionIndex.
	^versions at: methodVersionSelectionIndex.! !

!EDEmergencyDebugger methodsFor: 'accessing' stamp: ''!
stackSelectionIndex: newIndex
	stackSelectionIndex := newIndex! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EDEmergencyDebugger class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EDEmergencyDebugger class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EDEmergencyDebugger class methodsFor: 'instance creation' stamp: ''!
debugSession: aDebugSession

	^ self debug: aDebugSession! !

!EDEmergencyDebugger class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EDEmergencyDebugger class methodsFor: 'instance creation' stamp: ''!
debug: aDebugSession
	self flag: 'Not good, must add and test the error too!!'.
	^ self new emergencyDebug: aDebugSession! !

!EDEmergencyDebugger class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EDEmergencyDebugger class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
debugAPI: aDebugAPIClass
	DefaultDebugAPI := aDebugAPIClass! !

!EDEmergencyDebugger class methodsFor: 'instance creation' stamp: ''!
debugError: anError fromSession: aDebugSession
	^ self new
		fromError: anError;
		emergencyDebug: aDebugSession! !

!EDEmergencyDebugger class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EDEmergencyDebugger class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
debugAPI
	^self defaultDebugAPI! !

!EDEmergencyDebugger class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EDEmergencyDebugger class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EDEmergencyDebugger class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EDEmergencyDebugger class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EDEmergencyDebugger class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
rank
	^rank ifNil:[rank := self defaultDebuggerRank]! !

!EDEmergencyDebugger class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EDEmergencyDebugger class methodsFor: 'utilities api' stamp: ''!
closeAllDebuggers
	"Do nothing, because this message does not make sense for the Emergency Debugger. If the emergencyDebugger  is open, it has the focus so the user cannot right-click on the taskbar and click on the 'close all debuggers' button anyway"

	^ self! !

!EDEmergencyDebugger class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EDEmergencyDebugger class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
availableAutomatically: anObject
	availableAutomatically := anObject! !

!EDEmergencyDebugger class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!EDEmergencyDebugger class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
defaultDebuggerRank

	^ DebuggerSettings defaultDebuggerRank! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!EDEmergencyDebugger class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
availableAutomatically
	^ true! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
defaultDebugAPI
	^ DefaultDebugAPI ifNil: [ DefaultDebugAPI := EDDebuggingAPI ]! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EDEmergencyDebugger class methodsFor: 'debugging' stamp: ''!
handlesContext: aContext
	^true! !

!EDEmergencyDebugger class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EDEmergencyDebugger class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EDEmergencyDebugger class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EDEmergencyDebugger class methodsFor: 'accessing' stamp: ''!
rank: anInteger
	rank := anInteger! !

!EDEmergencyDebuggerTest methodsFor: 'api - stack' stamp: ''!
testShiftDownShortStack
	ed stackSelectionIndex: debugAPI displayStackSize.
	ed shortStackIndex: debugAPI displayStackSize.
	ed moveDownInStack.
	self assert: ed shortStackIndex equals: 1.
	self
		assertCollection: ed shortStack
		hasSameElements:
			(session stack
				copyFrom: debugAPI displayStackSize + 1
				to: debugAPI displayStackSize * 2)! !

!EDEmergencyDebuggerTest methodsFor: 'debug API' stamp: ''!
testDebugAPI
	|api|
	api := EDMockObjectForTests new.
	EDEmergencyDebugger debugAPI: api.
	self assert: EDEmergencyDebugger debugAPI identicalTo: api! !

!EDEmergencyDebuggerTest methodsFor: 'debug API' stamp: ''!
testBasicDebug
	ed := EDEmergencyDebugger new.
	ed basicDebug: session.
	self assert: ed debugAPI debugger identicalTo: ed.
	self assert: ed isRunning! !

!EDEmergencyDebuggerTest methodsFor: 'methods version' stamp: ''!
testSelectedMethodVersion! !

!EDEmergencyDebuggerTest methodsFor: 'text - composition' stamp: ''!
testComposePromptWith
	| rs |
	ed composePromptWith: 'prompt'.
	rs := ed input asString readStream.
	self assert: rs next equals: Character cr.
	self assert: (rs upTo: Character cr) equals: ed separator asString.
	self assert: rs next equals: $>.
	self assert: rs next equals: Character space.
	self assert: rs upToEnd equals: 'prompt'.! !

!EDEmergencyDebuggerTest methodsFor: 'helpers' stamp: ''!
resultTextStringExample
	| expectedTextStream |
	expectedTextStream := WriteStream on: Text new.
	expectedTextStream cr.
	ed writeSectionTitle: 'RES' on: expectedTextStream.
	expectedTextStream << 'result'.
	^ expectedTextStream contents asString! !

!EDEmergencyDebuggerTest methodsFor: 'setup' stamp: ''!
testIsRunning
	
	"This is a new Ed, we did not call #debug: so it is not running"
	self deny: EDEmergencyDebugger new isRunning.
	"This Ed, we called #debug: in the test setup so it is running"
	self assert: ed isRunning! !

!EDEmergencyDebuggerTest methodsFor: 'api - stack' stamp: ''!
testMoveUpInStack 
	ed stackSelectionIndex: debugAPI stackSize.
	ed shortStackIndex: debugAPI stackSize.
	ed moveUpInStack.
	self assert: ed stackSelectionIndex equals: (debugAPI stackSize - 1).
	self assert: ed shortStackIndex equals: (debugAPI stackSize - 1).
	self assert: ed methodVersionSelectionIndex equals: 0! !

!EDEmergencyDebuggerTest methodsFor: 'text - composition' stamp: ''!
testComposeResultTitle
	ed composeResult: 'result' title: 'RES'.
	self assert: ed result asString equals: self resultTextStringExample! !

!EDEmergencyDebuggerTest methodsFor: 'updating' stamp: ''!
testUpdatePrompt
	| promptUpdate rs |
	promptUpdate := 'PROMPT UPDATE'.
	ed updatePrompt: promptUpdate.
	rs := ed input readStream.
	rs upTo: $>.
	rs upTo: Character space.
	self assert: (rs upTo: Character cr) equals: promptUpdate! !

!EDEmergencyDebuggerTest methodsFor: 'text - helpers' stamp: ''!
testWriteSeparatorOn
	| expectedTextStream actualTextStream |
	
	expectedTextStream := WriteStream on: Text new.
	expectedTextStream << ed separator.
	expectedTextStream cr.
	
	actualTextStream := WriteStream on: Text new.	
	ed writeSeparatorOn: actualTextStream.

	self assert: actualTextStream contents asString 
		  equals: expectedTextStream contents asString! !

!EDEmergencyDebuggerTest methodsFor: 'methods version' stamp: ''!
testShowMoreRecentMethodVersion
	self prepareMethodVersionTest.
	ed showMoreRecentMethodVersion.
	self assert: ed methodVersionSelectionIndex equals: 1.
	ed showOlderMethodVersion.
	ed showMoreRecentMethodVersion.
	self assert: ed methodVersionSelectionIndex equals: 1! !

!EDEmergencyDebuggerTest methodsFor: 'debug API' stamp: ''!
testDefaultDebugAPI
	
	self assert: EDEmergencyDebugger debugAPI identicalTo: EDDebuggingAPI! !

!EDEmergencyDebuggerTest methodsFor: 'text - helpers' stamp: ''!
testWriteSectionTitleOn
	| expectedTextStream actualTextStream |
	
	expectedTextStream := WriteStream on: Text new.
	ed writeSeparatorOn: expectedTextStream.
	expectedTextStream << 'TEST'.
	expectedTextStream cr.
	ed writeSeparatorOn: expectedTextStream. 
	
	actualTextStream := WriteStream on: Text new.	
	ed writeSectionTitle: 'TEST' on: actualTextStream.

	self assert: actualTextStream contents asString 
		  equals: expectedTextStream contents asString! !

!EDEmergencyDebuggerTest methodsFor: 'updating' stamp: ''!
testUpdateDisplay
	ed updateDisplay.
	self assert: mockDisplayAPI isCleared.
	self assert: mockDisplayAPI displayData equals: ed composeDisplayText! !

!EDEmergencyDebuggerTest methodsFor: 'api - stack' stamp: ''!
testUpdateShortStackForDisplay! !

!EDEmergencyDebuggerTest methodsFor: 'text - composition' stamp: ''!
testComposeMethodText
	ed composeMethodText.
	self
		assert: ed methodText asString
		equals: self methodDisplayTextStringExample! !

!EDEmergencyDebuggerTest methodsFor: 'text - helpers' stamp: ''!
testSeparator

	self assert: ed separator asString equals: '--------------------'! !

!EDEmergencyDebuggerTest methodsFor: 'methods version' stamp: ''!
testShowOlderMethodVersion
	self prepareMethodVersionTest.
	ed showOlderMethodVersion.
	self assert: ed methodVersionSelectionIndex equals: 1.
	ed showOlderMethodVersion.
	self assert: ed methodVersionSelectionIndex equals: 2! !

!EDEmergencyDebuggerTest methodsFor: 'helpers' stamp: ''!
titleDisplayTextStringExample
	^ 'Hi, I''m ED - What is the nature of your debugging emergency?'! !

!EDEmergencyDebuggerTest methodsFor: 'api - stack' stamp: ''!
testShiftUpShortStack
	ed stackSelectionIndex: debugAPI displayStackSize + 1.
	ed shortStackIndex: 1.
	ed moveUpInStack.
	self assert: ed shortStackIndex equals: debugAPI displayStackSize.
	self
		assertCollection: ed shortStack
		hasSameElements: (session stack copyFrom: 1 to: debugAPI displayStackSize)! !

!EDEmergencyDebuggerTest methodsFor: 'setup' stamp: ''!
testTerminate
	
	ed terminate.
	self deny: ed isRunning! !

!EDEmergencyDebuggerTest methodsFor: 'helpers' stamp: ''!
zeroDivideErrorInstance
	[ 1 / 0 ]
		on: Error
		do: [ :err | ^ err ]! !

!EDEmergencyDebuggerTest methodsFor: 'helpers' stamp: ''!
methodDisplayTextStringExample
	| method expectedTextStream |
	method := debugAPI methodAt: ed stackSelectionIndex.
	expectedTextStream := WriteStream on: Text new.
	ed writeSectionTitle: 'SOURCE' on: expectedTextStream.
	expectedTextStream << method methodClass name.
	expectedTextStream << '>>'.
	expectedTextStream << method sourceCode.
	expectedTextStream cr.
	^expectedTextStream contents asString! !

!EDEmergencyDebuggerTest methodsFor: 'text - composition' stamp: ''!
testComposeTitleText
	ed composeMethodText.
	self
		assert: ed titleText
		equals: self titleDisplayTextStringExample! !

!EDEmergencyDebuggerTest methodsFor: 'text - composition' stamp: ''!
testComposeErrorTextFrom
	|error rs|
	error := self zeroDivideErrorInstance.
	ed composeErrorTextFrom: error.
	rs := ed errorText readStream.
	self assert: rs next equals: Character cr.
	self assert: (rs next: ed separator asString size) equals: ed separator asString.
	self assert: rs next equals: Character cr.
	self assert: (rs next: error description size) equals: error description.
	self assert: rs atEnd! !

!EDEmergencyDebuggerTest methodsFor: 'text - helpers' stamp: ''!
testNewTextStream
	|str|
	str := ed newTextStream.
	self assert: str isStream.
	self assert: str contents equals: Text new! !

!EDEmergencyDebuggerTest methodsFor: 'methods version' stamp: ''!
testRevertCurrentMethodToSelectedVersion
	|secondContext originalPC newContext| 
	secondContext := ed shortStack second.
	originalPC := secondContext pc.	
	ed stackSelectionIndex: 2.
	ed shortStackIndex: 2.
	ed methodVersionSelectionIndex: 1.
	ed revertCurrentMethodToSelectedVersion.
	newContext := ed shortStack first.
	self assert: newContext identicalTo: secondContext.
	self assert: ed stackSelectionIndex equals: 1.
	self assert: ed shortStackIndex equals: 1.
	self assert: ed methodVersionSelectionIndex equals: 1.
	self assert: newContext pc < originalPC.
	self assert: newContext method sourceCode equals: secondContext method sourceCode.
	
	"When the context is restarted, the interpreter automatically steps over
	so-called uninteresting bytecodes, i.e., bytecodes that are not sends nor returns.
	The test method, originally EDMockObjectForTests>>#m:, starts with an equality check
	that is 2 bytecodes long, then the interpreter stops on the first send.
	The PC should be equal to the method's initial PC + 2."  
	self assert: ed shortStack first pc 
	     equals: ed shortStack first method initialPC + 2! !

!EDEmergencyDebuggerTest methodsFor: 'api - stack' stamp: ''!
testShortStack 
	self assert: ed shortStack size equals: 5.	
	self assertCollection: (session stackOfSize: 5) hasSameElements: ed shortStack! !

!EDEmergencyDebuggerTest methodsFor: 'methods version' stamp: ''!
testSelectedMethodVersionsSize
	self prepareMethodVersionTest.
	self assert: ed selectedMethodVersionsSize equals: 2! !

!EDEmergencyDebuggerTest methodsFor: 'api - stack' stamp: ''!
testMoveDownInStackFromLastElement 
	|selectionIndexBefore shortStackIndexBefore|
	ed stackSelectionIndex: debugAPI stackSize.
	selectionIndexBefore := ed stackSelectionIndex.
	shortStackIndexBefore := ed shortStackIndex.
	ed moveDownInStack.
	self assert: ed stackSelectionIndex equals: selectionIndexBefore.
	self assert: ed shortStackIndex equals: shortStackIndexBefore! !

!EDEmergencyDebuggerTest methodsFor: 'helpers' stamp: ''!
errorText: error 	
	| errStream |
	errStream := WriteStream on: Text new.
	errStream cr.
	ed writeSeparatorOn: errStream.
	errStream << error description.
	^errStream contents! !

!EDEmergencyDebuggerTest methodsFor: 'text - composition' stamp: ''!
testComposeStackText
	| rs ws stack |
	ed composeStackText.
	rs := ed stackText asString readStream.
	
	self assert: rs next equals: Character cr.
	self assert: (rs upTo: Character cr) equals: ed separator asString.
	self
		assert: (rs upTo: Character cr)
		equals:
			'STACK (' , ed stackSelectionIndex printString , '/'
				, debugAPI stackSize printString , ')'.				
	self assert: (rs upTo: Character cr) equals: ed separator asString.
	
	
	stack := debugAPI stack copyFrom: 1 to: debugAPI displayStackSize.
	
	ws := WriteStream on: String new.
	(stack at: 1) printWithArgsValueOn: ws.
	self assert: (rs upTo: Character cr) equals: ws contents.
	
	ws := WriteStream on: String new.
	(stack at: 2) printWithArgsValueOn: ws.
	self assert: (rs upTo: Character cr) equals: ws contents.
	
	ws := WriteStream on: String new.
	(stack at: 3) printWithArgsValueOn: ws.
	self assert: (rs upTo: Character cr) equals: ws contents.
	
	ws := WriteStream on: String new.
	(stack at: 4) printWithArgsValueOn: ws.
	self assert: (rs upTo: Character cr) equals: ws contents.
	
	ws := WriteStream on: String new.
	(stack at: 5) printWithArgsValueOn: ws.
	self assert: (rs upTo: Character cr) equals: ws contents.
	
	self assert: rs atEnd! !

!EDEmergencyDebuggerTest methodsFor: 'api - stack' stamp: ''!
testMoveUpInStackFromFirstElement 
	|selectionIndexBefore shortStackIndexBefore|
	selectionIndexBefore := ed stackSelectionIndex.
	shortStackIndexBefore := ed shortStackIndex.
	ed moveUpInStack.
	self assert: ed stackSelectionIndex equals: selectionIndexBefore.
	self assert: ed shortStackIndex equals: shortStackIndexBefore.
	self assert: ed methodVersionSelectionIndex equals: 0! !

!EDEmergencyDebuggerTest methodsFor: 'methods version' stamp: ''!
testShowSelectedMethodVersion! !

!EDEmergencyDebuggerTest methodsFor: 'text - composition' stamp: ''!
testComposeDisplayText
	| displayText |
	displayText := ed titleText , ed composeSessionTitle, ed stackText , ed methodText , ed input
		, ed result.
	self assert: ed composeDisplayText equals: displayText! !

!EDEmergencyDebuggerTest methodsFor: 'text - helpers' stamp: ''!
testDefaultResultText

	self assert: ed defaultResultText equals: 'TYPE h FOR HELP'! !

!EDEmergencyDebuggerTest methodsFor: 'setup' stamp: ''!
testFromError
	|error|
	error := self zeroDivideErrorInstance.
	self assert: ed originalError isNil.
	self assert: ed errorText equals: Text new.	
	ed fromError: error.
	self assert: ed originalError identicalTo: error.
	self assert: ed errorText equals: (self errorText: error)! !

!EDEmergencyDebuggerTest methodsFor: 'api - stack' stamp: ''!
testMoveDownInStack 
	|selectionIndexBefore shortStackIndexBefore|
	selectionIndexBefore := ed stackSelectionIndex.
	shortStackIndexBefore := ed shortStackIndex.
	ed moveDownInStack.
	self assert: ed stackSelectionIndex 
			equals: ((selectionIndexBefore + 1) min: debugAPI stackSize).
	self assert: ed shortStackIndex equals: (shortStackIndexBefore + 1).
	self assert: ed methodVersionSelectionIndex equals: 0! !

!EDEmergencyDebuggerTest methodsFor: 'methods version' stamp: ''!
testInitialMethodVersion
	self assert: ed methodVersionSelectionIndex equals: 0! !

!EDEmergencyDebuggerTest methodsFor: 'text - composition' stamp: ''!
testComposeStackTest
	| rs ws stack |
	ed composeStackText.
	rs := ed stackText asString readStream.
	
	self assert: rs next equals: Character cr.
	self assert: (rs upTo: Character cr) equals: ed separator asString.
	self
		assert: (rs upTo: Character cr)
		equals:
			'STACK (' , ed stackSelectionIndex printString , '/'
				, debugAPI stackSize printString , ')'.				
	self assert: (rs upTo: Character cr) equals: ed separator asString.
	
	
	stack := debugAPI stack copyFrom: 1 to: debugAPI displayStackSize.
	
	ws := WriteStream on: String new.
	(stack at: 1) printWithArgsValueOn: ws.
	self assert: (rs upTo: Character cr) equals: ws contents.
	
	ws := WriteStream on: String new.
	(stack at: 2) printWithArgsValueOn: ws.
	self assert: (rs upTo: Character cr) equals: ws contents.
	
	ws := WriteStream on: String new.
	(stack at: 3) printWithArgsValueOn: ws.
	self assert: (rs upTo: Character cr) equals: ws contents.
	
	ws := WriteStream on: String new.
	(stack at: 4) printWithArgsValueOn: ws.
	self assert: (rs upTo: Character cr) equals: ws contents.
	
	ws := WriteStream on: String new.
	(stack at: 5) printWithArgsValueOn: ws.
	self assert: (rs upTo: Character cr) equals: ws contents.
	
	self assert: rs atEnd! !

!EDMockDisplayInterface commentStamp: ''!
I am a null display interface for testing the Ed debugger.
I catch all message through DNU and just do nothing.!
!EDMockDisplayInterface methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	
	"self inform: 'Ed display: ', aMessage printString"! !

!EDMockDisplayInterface methodsFor: 'API - mock' stamp: ''!
isCleared
	^clear ifNil:[false]! !

!EDMockDisplayInterface methodsFor: 'API - mock' stamp: ''!
show: aText
	displayData := aText! !

!EDMockDisplayInterface methodsFor: 'API - mock' stamp: ''!
clear
	clear := true! !

!EDMockDisplayInterface methodsFor: 'API - mock' stamp: ''!
displayData
	^displayData ifNil:['']! !

!EDMockObjectForTests commentStamp: ''!
I implement method to build execution stacks and errors to test the Ed debugger!
!EDMockObjectForTests methodsFor: 'helper methods' stamp: ''!
m: i
	i = 1 ifTrue:[^1].
	^i + (self m: i - 1)! !

!EDMockREPLInterface commentStamp: ''!
I am a null REPL interface for testing the Ed debugger.
I just implement a repl method that does nothing.!
!EDMockREPLInterface methodsFor: 'command line' stamp: ''!
readEvalPrint! !

!EDMockREPLInterface methodsFor: 'command line' stamp: ''!
terminateREPL! !

!EDREPLInterface commentStamp: ''!
I am a simple REPL interface for the ED emergency debugger.
Basically I am a readwrite stream that reads character pressed events to:
- forward them to the debugger in case it must perform special actions
- put them in myself to build a line
When I read the Character cr event, I send my contents (the line) to the debugger, then I reinitialize myself.!
!EDREPLInterface methodsFor: 'command line' stamp: ''!
readEvalPrint
	
	[ debugger isRunning ]
	whileTrue: [ 
		debugger eval: self requestLine.
		self resetREPL ].
	
	self terminateREPL! !

!EDREPLInterface methodsFor: 'accessing' stamp: ''!
pushChar: aChar

	self inputBufferStream nextPut: aChar.
	self waitSemaphore signal! !

!EDREPLInterface methodsFor: 'accessing' stamp: ''!
debugger: anObject
	debugger := anObject! !

!EDREPLInterface methodsFor: 'private' stamp: ''!
inputBufferStream

	^ inputBufferStream ifNil: [ inputBufferStream := String new writeStream ]! !

!EDREPLInterface methodsFor: 'private' stamp: ''!
resetREPL

	self on: (String new: 100).
	inputBufferStream := nil! !

!EDREPLInterface methodsFor: 'private' stamp: ''!
waitSemaphore

	^ waitSemaphore ifNil: [ waitSemaphore := Semaphore new ]! !

!EDREPLInterface methodsFor: 'command line' stamp: ''!
requestLine
	| startPos char contents |
	
	startPos := position.
	[ 	
		self waitSemaphore wait.
		(char := self inputBufferStream peekLast) = Character cr ] 
	whileFalse: [ 
		(debugger performActionForChar: char)
			ifFalse: [ 
				char = Character backspace
					ifTrue: [ readLimit := position := position - 1 max: startPos ]
					ifFalse: [ self nextPut: char ].
				debugger updatePrompt: self contents ] ].
	
	contents := self contents.
	^ contents 
		copyFrom: startPos + 1 
		to: contents size! !

!EDREPLInterface methodsFor: 'command line' stamp: ''!
terminateREPL

	self waitSemaphore signal.
	waitSemaphore := nil! !

!EDREPLInterface class methodsFor: 'instance creation' stamp: ''!
forDebugger: aSindarinDebugger
	^ (self on: (String new: 100))
		debugger: aSindarinDebugger;
		yourself! !

!EDTest methodsFor: 'methods version' stamp: ''!
prepareMethodVersionTest
	| context process |
	EDMockObjectForTests compile: self sampleMethodSourceCodeVersion1.
	EDMockObjectForTests compile: self sampleMethodSourceCodeVersion2.

	context := [ EDMockObjectForTests new mWithVersion] asContext.
	process := Process
		forContext: context
		priority: Processor userInterruptPriority.
	session := DebugSession
		named: 'test session'
		on: process
		startedAt: context.
	session stepThrough.
	session stepOver.
	session stepInto.
	session stepOver.
	debugAPI session: session.
	self newEd! !

!EDTest methodsFor: 'instance creation' stamp: ''!
newEd
	ed := EDEmergencyDebugger new.
	ed repl: EDMockREPLInterface new.
	ed displayInterface: (mockDisplayAPI := EDMockDisplayInterface new).
	ed debugAPI: debugAPI.
	ed debug: session! !

!EDTest methodsFor: 'running' stamp: ''!
tearDown
	EDEmergencyDebugger debugAPI: currentDebuggingAPI.
	session terminate.
	EDMockObjectForTests removeSelector: #mWithVersion.
	super tearDown! !

!EDTest methodsFor: 'methods version' stamp: ''!
sampleMethodSourceCodeVersion2
	^ 'mWithVersion |i| i := 0. ^i + 2'! !

!EDTest methodsFor: 'running' stamp: ''!
configureDebugSession

	"Configure a debug session and moves it to the following stack:
	EDMockObjectForTests>>m: 5
	EDMockObjectForTests>>m: 6
	EDMockObjectForTests>>m: 7
	EDMockObjectForTests>>m: 8
	EDMockObjectForTests>>m: 9
	EDMockObjectForTests>>m: 10
	EDMockObjectForTests>>m: 11
	EDMockObjectForTests>>m: 12
	EDMockObjectForTests>>m: 13
	EDMockObjectForTests>>m: 14
	EDMockObjectForTests>>m: 15
	EDMockObjectForTests>>m: 16
	EDMockObjectForTests>>m: 17
	EDMockObjectForTests>>m: 18
	EDMockObjectForTests>>m: 19
	EDMockObjectForTests>>m: 20
	[ EDMockObjectForTests new m: 20 ] in UndefinedObject>>DoIt"
	
	session stepThrough.
	session stepOver.
	session stepInto.
	session stepOver.
	session stepOver.
	session stepInto.
	session stepOver.
	session stepOver.
	session stepInto.	
	session stepOver.
	session stepOver.
	session stepInto.
	
	session stepOver.
	session stepOver.
	session stepInto.
	session stepOver.
	session stepOver.
	session stepInto.	
	session stepOver.
	session stepOver.
	session stepInto.
	
	session stepOver.
	session stepOver.
	session stepInto.
	session stepOver.
	session stepOver.
	session stepInto.	
	session stepOver.
	session stepOver.
	session stepInto.
	
	session stepOver.
	session stepOver.
	session stepInto.
	session stepOver.
	session stepOver.
	session stepInto.	
	session stepOver.
	session stepOver.
	session stepInto.
	
	session stepOver.
	session stepOver.
	session stepInto.
	session stepOver.
	session stepOver.
	session stepInto.	
	session stepOver.
	session stepOver.
	session stepInto.! !

!EDTest methodsFor: 'methods version' stamp: ''!
sampleMethodSourceCodeVersion1
	^ 'mWithVersion |i| i := 0. ^i + 1'! !

!EDTest methodsFor: 'running' stamp: ''!
setUp
	|context process|
	super setUp.
	currentDebuggingAPI := EDEmergencyDebugger debugAPI.
	context := [ EDMockObjectForTests new m: 20 ] asContext.
	process := Process
		forContext: context
		priority: Processor userInterruptPriority.
	session := DebugSession
		named: 'test session'
		on: process
		startedAt: context.
	self configureDebugSession.
	debugAPI := EDDebuggingAPI attachTo: session.
	EDEmergencyDebugger debugAPI: nil.
	self newEd! !

!EDTest class methodsFor: 'testing' stamp: ''!
isAbstract 	
	^self == EDTest! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testToLongNewLineWithSpaceBefore
	| source |
	configurationSelector := #maxLineLengthConfigurationWithSpaceBefore.
	source := self formatExpression: '{VeryLongExpression. 1}'.
	self
		assert: source
		equals:
'{
	VeryLongExpression .
	1}'! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testPeriodAtEndOfMethodWithMultipleElementArrayShouldNotHavePeriodAtEnd
	| source |
	configurationSelector := #periodAtEndOfMethod.
	source := self formatExpression: '{ a := 2 . a := 2 }'.
	self assert: source equals:  '{
	(a := 2).
	(a := 2)}'! !

!EFArrayExpressionTest methodsFor: 'configurations' stamp: ''!
threeSpacesBeforeDotInArrayConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		maxLineLength: 50;
		numberOfSpacesInsideParentheses: 0;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentStyle: #tabulation;
		indentExtraSpaces: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		numberOfSpacesInsideArray: 0;
		numberOfSpacesBeforeDotInDynamicArray: 3! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testThreeSpacesBeforePeriod
	| source |
	configurationSelector := #threeSpacesBeforeDotInArrayConfiguration.
	source := self formatExpression: '{1. 2. 3}'.
	self assert: source equals: '{1   . 2   . 3}'! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testPeriodAtEndOfMethod
	| source |
	configurationSelector := #periodAtEndOfMethod.
	source := self formatExpression: '{1 factorial}'.
	self assert: source equals: '{1 factorial}'! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testToLongNewLine
	| source |
	configurationSelector := #maxLineLengthConfiguration.
	source := self formatExpression: '{VeryLongExpression. 1}'.
	self
		assert: source
		equals:
'{
	VeryLongExpression.
	1}'! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testPeriodAtEndOfMethodWithMultipleElementArrayShouldNotHavePointAtTheEnd
	| source |
	configurationSelector := #periodAtEndOfMethod.
	source := self formatExpression: '{1 factorial . 3 + 2}'.
	self assert: source equals: 
 '{
	1 factorial.
	(3 + 2)}' "we should not have a point at the end."! !

!EFArrayExpressionTest methodsFor: 'configurations' stamp: ''!
maxLineLengthConfigurationWithSpaceBefore
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		maxLineLength: 12;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentStyle: #tabulation;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		indentExtraSpaces: 0;
		numberOfSpacesInsideArray: 0;
		numberOfSpacesBeforeDotInDynamicArray: 1.
		"here since we shortcut the initialize method we have to set the numberOfSpace...
		manually so that the spacesBefore string is correctly computed."! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testNoSpaceAroundBrackets
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: ' { 1. 2. 3 } '.
	self assert: source equals: '{1. 2. 3}'! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testSpaceAroundPeriod
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '{1. 2. 3}'.
	self assert: source equals: '{1. 2. 3}'! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testEmptyArray
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '{}'.
	self assert: source equals: '{}'! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testSpaceInside
	| source |
	configurationSelector := #spaceInsideArrayConfiguration.
	source := self formatExpression: ' { 1. 2. 3 } '.
	self assert: source equals: '{     1. 2. 3     }'! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testFiveSpaceAroundBrackets
	| source |
	configurationSelector := #fiveSpacesInsideArrayConfiguration.
	source := self formatExpression: ' { 1. 2. 3 } '.
	self assert: source equals: '{     1. 2. 3     }'! !

!EFArrayExpressionTest methodsFor: 'configurations' stamp: ''!
maxLineLengthConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		maxLineLength: 12;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentStyle: #tabulation;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		indentExtraSpaces: 0;
		numberOfSpacesInsideArray: 0;
		numberOfSpacesBeforeDotInDynamicArray: 0.
		"here since we shortcut the initialize method we have to set the numberOfSpace...
		manually so that the spacesBefore string is correctly computed."! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testOneSpaceAroundBrackets
	| source |
	configurationSelector := #oneSpaceInsideArrayConfiguration.
	source := self formatExpression: ' { 1. 2. 3 } '.
	self assert: source equals: '{ 1. 2. 3 }'! !

!EFArrayExpressionTest methodsFor: 'configurations' stamp: ''!
multiLineConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		maxLineLength: 50;
		numberOfSpacesInsideParentheses: 0;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentStyle: #tabulation;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		numberOfSpacesInsideParentheses: 0;
		multiLineMessages: #();
		oneLineMessages: #();
		numberOfArgumentsForMultiLine: 4;
		indentsForKeywords: 1;
		keepBlockInMessage: true;
		indentExtraSpaces: 0;
		numberOfSpacesInsideArray: 0;
		numberOfSpacesBeforeDotInDynamicArray: 0! !

!EFArrayExpressionTest methodsFor: 'configurations' stamp: ''!
oneSpaceInsideArrayConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		maxLineLength: 50;
		numberOfSpacesInsideParentheses: 0;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentStyle: #tabulation;
		indentExtraSpaces: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		numberOfSpacesInsideArray: 1;
		numberOfSpacesBeforeDotInDynamicArray: 0.
		"here since we shortcut the initialize method we have to set the numberOfSpace...
		manually so that the spacesBefore string is correctly computed."! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testSpaceBeforePeriod
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '{1 . 2 . 3}'.
	self assert: source equals: '{1. 2. 3}'! !

!EFArrayExpressionTest methodsFor: 'configurations' stamp: ''!
spaceInsideArrayConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		maxLineLength: 50;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentStyle: #tabulation;
		indentExtraSpaces: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		numberOfSpacesInsideArray: 5;
		numberOfSpacesBeforeDotInDynamicArray: 0.
		"here since we shortcut the initialize method we have to set the numberOfSpace...
		manually so that the spacesBefore string is correctly computed."! !

!EFArrayExpressionTest methodsFor: 'configurations' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		maxLineLength: 50;
		numberOfSpacesInsideParentheses: 0;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentStyle: #tabulation;
		indentExtraSpaces: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		numberOfSpacesInsideArray: 0;
		numberOfSpacesBeforeDotInDynamicArray: 0.
		"here since we shortcut the initialize method we have to set the numberOfSpace...
		manually so that the spacesBefore string is correctly computed."! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testFormatElement
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: ' { a:=1. b:=2 } '.
	self assert: source equals:
'{
	(a := 1).
	(b := 2)}'! !

!EFArrayExpressionTest methodsFor: 'configurations' stamp: ''!
fiveSpacesInsideArrayConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		maxLineLength: 50;
		numberOfSpacesInsideParentheses: 0;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentStyle: #tabulation;
		indentExtraSpaces: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		numberOfSpacesInsideArray: 5;
		numberOfSpacesBeforeDotInDynamicArray: 0.
		"here since we shortcut the initialize method we have to set the numberOfSpace...
		manually so that the spacesBefore string is correctly computed."! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testNoExtraSpaceAroundPeriod
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '{1.    2.        3}'.
	self assert: source equals: '{1. 2. 3}'! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineAfterBracesWhenMultiline
	| source |
	configurationSelector := #multiLineConfiguration.
	source := self formatExpression: '{(self + (1 @ 0)).
	(self + (1 @ 1)).
	(self + (0 @ 1)).
	(self + (-1 @ 1)).
	(self + (-1 @ 0)).
	(self + (-1 @ -1)).
	(self + (0 @ -1)).
	(self + (1 @ -1))}'.
	self
		assert: source
		equals:
'{
	(self + (1 @ 0)).
	(self + (1 @ 1)).
	(self + (0 @ 1)).
	(self + (-1 @ 1)).
	(self + (-1 @ 0)).
	(self + (-1 @ -1)).
	(self + (0 @ -1)).
	(self + (1 @ -1))}'! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testToLongNewLine2WithSpaceBefore
	| source |
	configurationSelector := #maxLineLengthConfigurationWithSpaceBefore.
	source := self formatExpression: '{1. 2. 3. 4. 5. 6. 7. 1}'.
	self
		assert: source
		equals:
			'{1 . 2 . 3 . 4 .
5 . 6 . 7 . 1}'! !

!EFArrayExpressionTest methodsFor: 'configurations' stamp: ''!
periodAtEndOfMethod
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		maxLineLength: 12;
		indentsForKeywords: 0;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentStyle: #tabulation;
		indentExtraSpaces: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: true;
		multiLineMessages: #();
		oneLineMessages: #();
		numberOfSpacesInsideParentheses: 0;
		numberOfArgumentsForMultiLine: 2;
		newLineBeforeFirstKeyword: false;
		numberOfSpacesInsideArray: 0;
		numberOfSpacesBeforeDotInDynamicArray: 0! !

!EFArrayExpressionTest methodsFor: 'tests' stamp: ''!
testToLongNewLine2
	| source |
	configurationSelector := #maxLineLengthConfiguration.
	source := self formatExpression: '{1. 2. 3. 4. 5. 6. 7. 1}'.
	self
		assert: source
		equals:
			'{1. 2. 3. 4.
5. 6. 7. 1}'! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testExtraIndentationWhenMultiline3
	| source |
	configurationSelector := #multilineConfiguration.
	source := self
		formatExpression:
	'a:= b := p2-x - p0-x * ( p3-y - p0-y ) - ( p3-x - p0-x * ( p2-y - p0-y ) )
	  * b0'.
	self
		assert: source
		equals:
'a := b := p2 - x - p0 - x * ( p3 - y - p0 - y )
          - ( p3 - x - p0 - x * ( p2 - y - p0 - y ) ) * b0'! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testExtraIndentationWhenMultilineResetTheIndentWhenFinish
	| source |
	configurationSelector := #multilineConfiguration.
	source := self formatExpression: 'a := p2-x - p0-x * ( p3-y - p0-y ) - ( p3-x - p0-x * ( p2-y - p0-y ) ) * b0. a:=1'.
	self assert: source equals:
'a := p2 - x - p0 - x * ( p3 - y - p0 - y )
     - ( p3 - x - p0 - x * ( p2 - y - p0 - y ) ) * b0.
a := 1'! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testMultipleAssignmentHasNoExtraSpaceInside
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '   a    :=    b :=  1   '.
	self assert: source equals: 'a := b := 1'! !

!EFAssignmentExpressionTest methodsFor: 'configurations' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:false;
		maxLineLength: 70;
		indentExtraSpaces: 0! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testExtraIndentationWhenKeywordMessageIsMultiline
	| source |
	configurationSelector := #multilineConfiguration.
	source := self
		formatExpression:
'abcdefghijklmnop:= aBoolean
	ifTrue: [ self indentsForKeywords ]
	ifFalse: [ 0 ]'.
	self
		assert: source
		equals:
'abcdefghijklmnop := aBoolean
	                    ifTrue: [ self indentsForKeywords ]
	                    ifFalse: [ 0 ]'! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testAssignmentHasNoExtraSpaceInside
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '   a    :=    1   '.
	self assert: source equals: 'a := 1'! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testExtraIndentationWhenMultiline2
	| source |
	configurationSelector := #multilineConfiguration.
	source := self
		formatExpression:
			'1 to: 4 do: [a:= p2-x - p0-x * ( p3-y - p0-y ) - ( p3-x - p0-x * ( p2-y - p0-y ) )
	  * b0]'.
	self
		assert: source
		equals:
'1 to: 4 do: [ 
	a := p2 - x - p0 - x * ( p3 - y - p0 - y )
	     - ( p3 - x - p0 - x * ( p2 - y - p0 - y ) ) * b0
	]'! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testAssignmentFormatValue
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'a:= b:=1'.
	self assert: source equals: 'a := b := 1'! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testExtraIndentationWhenMultiline
	| source |
	configurationSelector := #multilineConfiguration.
	source := self
		formatExpression:
			'abcdefghijklmnop:= p2-x - p0-x * ( p3-y - p0-y ) - ( p3-x - p0-x * ( p2-y - p0-y ) ) * b0'.
	self
		assert: source
		equals:
'abcdefghijklmnop := p2 - x - p0 - x * ( p3 - y - p0 - y )
                    - ( p3 - x - p0 - x * ( p2 - y - p0 - y ) ) * b0'! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testAssignmentHasNoExtraSpace
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '   a:=1   '.
	self assert: source equals: 'a := 1'! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testAssignment
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'a:=1'.
	self assert: source equals: 'a := 1'! !

!EFAssignmentExpressionTest methodsFor: 'tests' stamp: ''!
testAssignmentFormatVariable
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: ' a   := 1'.
	self assert: source equals: 'a := 1'! !

!EFAssignmentExpressionTest methodsFor: 'configurations' stamp: ''!
multilineConfiguration
	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		maxLineLength: 70;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 4;
		indentsForKeywords: 1;
		keepBlockInMessage: true;
		numberOfSpacesInsideParentheses: 1;
		indentStyle: #tabulation;
		retainBlankLinesBetweenStatements: true;
		minimumNewLinesBetweenStatements: 1;
		periodAtEndOfMethod: false;
		periodAtEndOfBlock: false;
		numberOfSpacesInsideBlock: 1;
		lineUpBlockBrackets: true;
		newLineBeforeFirstKeyword: true;
		indentExtraSpaces: 0! !

!EFBenchTest commentStamp: ''!
This class contains just some benchs.!
!EFBenchTest methodsFor: 'resources' stamp: ''!
longNestedMethodShort
  | b0 |
  self value: [:b1 |  b0 value: [:b2 |  b1 value: [:b3 |  b2 value: [:b4 |  b3 value: [:b5 |  b4 value: [:b6 |  b5 value: [:b7 |  b7 value: 2 ] ] ] ] ] ] ]! !

!EFBenchTest methodsFor: 'tests' stamp: ''!
testBasicEF2
	self skip.
	EFFormatter format: (EFBenchTest >> #basicMethod2) ast! !

!EFBenchTest methodsFor: 'tests' stamp: ''!
testEF
	self skip.
  "
	[ EFFormatter format: (EFBenchTest >> #longNestedMethodShort) ast ] bench  '0.159 per second'

  [ RBSimpleFormatter format: (EFBenchTest >> #longNestedMethodShort) ast ] bench 
	>>>'15597.361 per second'
	
  [ BIConfigurableFormatter  format: (EFBenchTest >> #longNestedMethodShort) ast ] bench  '7341.000 per second'

	"! !

!EFBenchTest methodsFor: 'resources' stamp: ''!
longNestedMethod

	self foo: [ :b1 | 
		b1 value: [ :b2 |  
			b2 value: [ :b3 |  
				b2 value: [ :b4 |  
				b3 value: [ :b5 |  
				b4 value: [ :b6 |  
				b5 value:  [ :b7 |  
				b6 value: [ :b8|  
				b7 value: [ :b9 |  
				b8 value: [ :b10 |  
				b9 value:  2] ] ] ]] ] ] ] ] ]! !

!EFBenchTest methodsFor: 'tests' stamp: ''!
testBasicEF
	self skip.
	[ EFFormatter format: (EFBenchTest >> #basicMethod) ast ] bench! !

!EFBenchTest methodsFor: 'tests' stamp: ''!
basicMethod3
	"a method with many similar expressions."
	| x y |
	x to: y do: [:i | Transcript show:i ; cr ;cr].
	x to: y do: [:i | Transcript show:i ; cr ;cr].
	x to: y do: [:i | Transcript show:i ; cr: x ; cr: x ].! !

!EFBenchTest methodsFor: 'tests' stamp: ''!
basicMethod
	[[[[[ [ 
		[ :y :z |
		[ :x | 1 to: 10 do: [:i | Transcript show:i ; cr ;cr] ]]]
 ]]]]]! !

!EFBenchTest methodsFor: 'tests' stamp: ''!
basicMethod2
	<sampleInstance>
	
	1 to: 10 do: [:i | Transcript show:i ; cr ;cr]! !

!EFBlockExpressionOnlyTest methodsFor: 'configuration' stamp: ''!
dontFormatCommentWithStatementConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock:1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		indentStyle: #tabulation;
		keepBlockInMessage:false;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:false;
		maxLineLength:50;
		retainBlankLinesBeforeComments: false;
		useBasicCommentFormat: false;
		indentExtraSpaces:0! !

!EFBlockExpressionOnlyTest methodsFor: 'tests' stamp: ''!
testNewLineAfterComment

	| source |
	configurationSelector := #dontFormatCommentWithStatementConfiguration.
	source := self formatExpression: '["aComment"1. 2]'.
	self assert: source equals: '[ "aComment"
1.
2 ]'! !

!EFBlockExpressionOnlyTest methodsFor: 'configuration' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock:1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		indentStyle: #tabulation;
		keepBlockInMessage:false;
		retainBlankLinesBetweenStatements:false;
		retainBlankLinesBeforeComments:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		useBasicCommentFormat:false;
		indentExtraSpaces:0! !

!EFBlockExpressionOnlyTest methodsFor: 'tests' stamp: ''!
testSpaceAfterComment

	| source |
	configurationSelector := #dontFormatCommentWithStatementConfiguration.
	source := self formatExpression: '["aComment"1]'.
	self assert: source equals: '[ "aComment" 1 ]'! !

!EFBlockExpressionOnlyTest methodsFor: 'tests' stamp: ''!
testformatComment

	| source |
	configurationSelector := #dontFormatCommentWithStatementConfiguration.
	source := self formatExpression: '["  c1   " "   c2 " 2 factorial "c3"]'.
	self assert: source equals: '[ "  c1   " "   c2 " 2 factorial "c3" ]'! !

!EFBlockExpressionOnlyTest methodsFor: 'tests' stamp: ''!
testDontFormatCommentWithStatement2
	| source |
	configurationSelector := #dontFormatCommentWithStatementConfiguration.
	source := self formatExpression: '[ "aComment" 1 factorial.  2 factorial]'.
	self assert: source equals: '[ "aComment"
1 factorial.
2 factorial ]'! !

!EFBlockExpressionTest methodsFor: 'helpers' stamp: ''!
validate: stringInsideBlock isFormattedAs: expectedStringInsideBlock with: aConfiguration

	| expr source |
	expr := self parserClass parseExpression: self openBracket , stringInsideBlock, self closeBracket.
	configurationSelector := aConfiguration.
	source := self formatter format: expr.
	self assert: source equals: self openBracket , expectedStringInsideBlock , self closeBracket! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testArgumentsAreFormated
	
	self 
		validate:':i :j| i '
		isFormattedAs:' :i :j | i '.! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testArgumentsComments
	
	self 
		validate:':i "aComment" :j "anotherComment"| i '
		isFormattedAs:
' :i "aComment" :j "anotherComment" | i '! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
noNewLineBeforeEndBracketConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		numberOfSpacesInsideBlock:1;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		indentStyle: #tabulation;
		keepBlockInMessage: true;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 5;
		indentsForKeywords: 1;
		newLineBeforeFirstKeyword: false;
		formatCommentCloseToStatements: true;
		maxLineLength: 50;
		indentExtraSpaces:0! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
numberOfSpaceChangedAfterIndentCharacterConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock: 1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		keepBlockInMessage:true;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages:#(#to:do:);
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		newLineAfterCascade:true;
		newLineBeforeFirstCascade: true;
		numberOfSpacesInIndent: 1;
		indentStyle: #space;
		numberOfSpacesInIndent: 2;
		indentExtraSpaces:0! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testNoExtraSpaceAroundBlock

	| expr source |
	expr := self parserClass parseExpression: '   ', self openBracket, '2', self closeBracket, '   '.
	configurationSelector := #basicConfiguration.
	source := self formatter format: expr.
	self assert: source equals: self openBracket, ' 2 ', self closeBracket! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
configurationWithThreeSpaces

	^ self contextClass basicNew
		numberOfSpacesInsideBlock: 3;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		indentStyle: #tabulation;
		keepBlockInMessage:false;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		indentExtraSpaces:0! !

!EFBlockExpressionTest methodsFor: 'helpers' stamp: ''!
openBracket
	^ '['! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testFourSpaceIndent
	self
		validate: ':i | i to: 10 do: [:j | Transcript show:i; show: j]'
		isFormattedAs:
' :i | 
i to: 10 do: [ :j | 
    Transcript
        show: i;
        show: j ] '
		with: #fourSpaceIndentConfiguration! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
newLineBeforeEndBracketConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		numberOfSpacesInsideBlock:1;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: true;
		indentStyle: #tabulation;
		keepBlockInMessage: true;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 5;
		indentsForKeywords: 1;
		newLineBeforeFirstKeyword: false;
		formatCommentCloseToStatements: true;
		maxLineLength: 50;
		indentExtraSpaces:0! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testOneSpaceIndent
	
	self validate: ':i | i to: 10 do: [:j | Transcript show:i; show: j]'
		isFormattedAs: ' :i | 
i to: 10 do: [ :j | 
 Transcript
  show: i;
  show: j ] '
	with: #oneSpaceIndentConfiguration.! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testDoNotKeepBlockInMessageConfiguration
	
	self validate: ':i | i to: 10 do: [:j | Transcript show:i. Transcript show: j]'
		isFormattedAs: ' :i | 
i to: 10 do:
	[ :j | 
	Transcript show: i.
	Transcript show: j ] '
	with: #doNotKeepBlockInMessageConfiguration.! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
doNotKeepBlockInMessageConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock: 1;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		indentStyle: #tabulation;
		keepBlockInMessage: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 5;
		indentsForKeywords: 1;
		newLineBeforeFirstKeyword: false;
		formatCommentCloseToStatements: true;
		maxLineLength: 50;
		indentExtraSpaces: 0! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testnumberOfSpaceChangedAfterIndentCharacter

	self validate: ':i | i to: 10 do: [:j | Transcript show:i; show: j]'
	isFormattedAs: ' :i | 
i to: 10 do: [ :j | 
  Transcript
    show: i;
    show: j ] '
	with: #numberOfSpaceChangedAfterIndentCharacterConfiguration! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testTooLongBlockBodyWithArgument
	self validate: ':i | tooLongStatement' isFormattedAs:
' :i | 
tooLongStatement ' with: #tooLongStatementConfiguration! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
tabIndentConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock: 1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		keepBlockInMessage:true;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages:#(#to:do:);
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		newLineAfterCascade:true;
		newLineBeforeFirstCascade: true;
		indentStyle: #tabulation;
		indentExtraSpaces:0! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testTabIndent
	self validate: ':i | i to: 10 do: [:j | Transcript show:i; show: j]'
	isFormattedAs: ' :i | 
i to: 10 do: [ :j | 
	Transcript
		show: i;
		show: j ] '
	 with: #tabIndentConfiguration! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineAfterFirstBracketWhenMultilineWithTemporaries

	self 
		validate: '| tmp | 1+3. 6 factorial '
		isFormattedAs: 
' 
| tmp |
1 + 3.
6 factorial '
with: #blockWithTemporariesConfiguration! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testTooLongBlockBody
	self validate: 'tooLongStatement' isFormattedAs:
' 
tooLongStatement ' with: #tooLongStatementConfiguration! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testNotTooLongBlockBody
	self validate: 'short' isFormattedAs: ' short ' with: #tooLongStatementConfiguration! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
oneSpaceIndentConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock: 1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		keepBlockInMessage:true;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages:#(#to:do:);
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		newLineAfterCascade:true;
		newLineBeforeFirstCascade: true;
		numberOfSpacesInIndent: 1;
		indentStyle: #space;
		indentExtraSpaces:0! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
formatCommentWithStatementConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock:1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		indentStyle: #tabulation;
		keepBlockInMessage:true;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		retainBlankLinesBeforeComments: false;
		useBasicCommentFormat: false;
		indentExtraSpaces: 0! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineBeforeEndBrackets

	self 
		validate:'3. 4'  
		isFormattedAs:
' 
3.
4
'  		with: #newLineBeforeEndBracketConfiguration.! !

!EFBlockExpressionTest methodsFor: 'helpers' stamp: ''!
closeBracket
	^']'! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testLongSingleArgument
	self skip.
	self 
		validate: ' [:superlonglonglong | Transcript show:i; show: j]'
		isFormattedAs: 
'[ :superlonglonglong | 
	Transcript show:i; show: j]'
		with: #numberOfSpaceChangedAfterIndentCharacterConfiguration! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testEndPeriodInside
	
	self 
		validate:'2.'
		isFormattedAs:' 2. '
		with: #periodAtEndConfiguration! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
periodAtEndConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		numberOfSpacesInsideBlock:1;
		periodAtEndOfBlock: true;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		indentStyle: #tabulation;
		keepBlockInMessage: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 5;
		indentsForKeywords: 1;
		newLineBeforeFirstKeyword: false;
		formatCommentCloseToStatements: true;
		maxLineLength: 50;
		indentExtraSpaces:0! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
tabIndentIsnotAffectedConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock: 1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		keepBlockInMessage:true;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages:#(#to:do:);
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		newLineAfterCascade:true;
		newLineBeforeFirstCascade: true;
		indentStyle: #tabulation;
		numberOfSpacesInIndent: 37;
		indentExtraSpaces:0! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
dontFormatCommentWithStatementConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock:1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		indentStyle: #tabulation;
		keepBlockInMessage:true;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:false;
		maxLineLength:50;
		retainBlankLinesBeforeComments: false;
		useBasicCommentFormat: false;
		indentExtraSpaces:0! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testMultiline

	self 
		validate: '1+3. 6 factorial '
		isFormattedAs: 
' 
1 + 3.
6 factorial '! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
blockWithTemporariesConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock: 1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		keepBlockInMessage:true;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages:#(#to:do:);
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		newLineAfterCascade:true;
		newLineBeforeFirstCascade: true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries: 1;
		indentExtraSpaces:0! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testFormatCommentWithStatement
	self
		validate: '1 factorial. "aComment" 2 factorial'
		isFormattedAs:
			' 
1 factorial. "aComment"
2 factorial '
		with: #formatCommentWithStatementConfiguration! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testLongMultipleArguments
	self skip.
	self 
		validate: ' :superlong :longlong :long | Transcript show: longlong ; show: long'
		isFormattedAs: 
' :superlong :longlong :long | 
Transcript
	show: longlong;
	show: long '
		with: #numberOfSpaceChangedAfterIndentCharacterConfiguration! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
multiLineWithThreeSpacesInsideBlockConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock:3;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		indentStyle: #tabulation;
		keepBlockInMessage:false;
		retainBlankLinesBetweenStatements:false;
		retainBlankLinesBeforeComments:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		useBasicCommentFormat:false;
		indentExtraSpaces:0;
		newLineBeforeFirstCascade: true;
		newLineAfterCascade: true! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
tooLongStatementConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock: 1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		indentStyle: #tabulation;
		keepBlockInMessage:true;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:10;
		indentExtraSpaces: 0! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
fourSpaceIndentConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock: 1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		keepBlockInMessage:true;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages:#(#to:do:);
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		newLineAfterCascade:true;
		newLineBeforeFirstCascade: true;
		numberOfSpacesInIndent: 4;
		indentStyle: #space;
		indentExtraSpaces: 0! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testNoExtraSpaceInside

	self validate: '    2     ' isFormattedAs: ' 2 '! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
multiLineConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock:1;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		indentStyle: #tabulation;
		keepBlockInMessage:false;
		retainBlankLinesBetweenStatements:false;
		retainBlankLinesBeforeComments:false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		useBasicCommentFormat:false;
		indentExtraSpaces:0;
		newLineBeforeFirstCascade: true;
		newLineAfterCascade: true! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testSpace

	self validate: '2' isFormattedAs: ' 2 '! !

!EFBlockExpressionTest methodsFor: 'configurations' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideBlock: 1;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		indentStyle: #tabulation;
		keepBlockInMessage: true;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements:1;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 5;
		indentsForKeywords:1;
		newLineBeforeFirstKeyword:false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		indentExtraSpaces: 0! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineAfterFirstBracketWhenMultilineWithArguments

	self 
		validate: ':i | i+3. i factorial '
		isFormattedAs: 
' :i | 
i + 3.
i factorial '! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLineBeforeEndBrackets

	self 
		validate: '3. 4'  
		isFormattedAs:
' 
3.
4 '  with: #noNewLineBeforeEndBracketConfiguration.! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testArgumentIsFormated
	self validate: ':i|i' isFormattedAs: ' :i | i '! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testDontFormatCommentWithStatement
	self
		validate: '1 factorial. "aComment" 2 factorial'
		isFormattedAs:
			' 
1 factorial "aComment".
2 factorial '
		with: #dontFormatCommentWithStatementConfiguration! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testNoEndPeriodInside

	self validate: '2.' isFormattedAs: ' 2 '! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testNumberOfSpaces

	self validate: '2' isFormattedAs: '   2   ' with: #configurationWithThreeSpaces! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testTabIndentIsNotAffectedByNumberOfSpace

	self validate: ':i | i to: 10 do: [:j | Transcript show:i; show: j]'
	 isFormattedAs: ' :i | 
i to: 10 do: [ :j | 
	Transcript
		show: i;
		show: j ] '
	 with: #tabIndentIsnotAffectedConfiguration! !

!EFBlockExpressionTest methodsFor: 'tests' stamp: ''!
testFormatBody
	self
		validate: ' [1]. [ a:=1] '
		isFormattedAs:
			' 
[ 1 ].
[ a := 1 ] '! !

!EFBlockExpressionTest methodsFor: 'helpers' stamp: ''!
validate: stringInsideBlock isFormattedAs: expectedStringInsideBlock
	self 
		validate: stringInsideBlock 
		isFormattedAs: expectedStringInsideBlock 
		with: #basicConfiguration! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testTooLongArgument2
	| source |
	configurationSelector := #tooLongArgumentConfigurationWithNewLineAfterCascade.
	source := self formatExpression: 'foo a;b: toLongArgument'.
	self
		assert: source
		equals:
'foo a;
	b:
		toLongArgument'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testCommentBeforeMessage
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'Transcript show:1; "cr" cr'.
	self flag: #tocheck. "the comment is glued and this is ugly"
	self
		assert: source
		equals:
			'Transcript show: 1; "cr"cr'! !

!EFCascadeExpressionTest methodsFor: 'configurations' stamp: ''!
newLineBeforeAndAfterCascadeConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		newLineAfterCascade: true;
		newLineBeforeFirstCascade: true;
		formatCommentCloseToStatements:false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:3;
		maxLineLength:50;
		keepBlockInMessage:false;
		indentStyle: #tabulation;
		newLineBeforeFirstKeyword:false;
		indentExtraSpaces:0! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineBeforeCascade
	| source |
	configurationSelector := #newLineBeforeCascadeConfiguration.
	source := self formatExpression: 'Foo a;b;c'.
	self
		assert: source
		equals:
			'Foo
	a; b; c'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLineBeforeCascade2
	| source |
	configurationSelector := #noNewLineBeforeCascadeConfiguration.
	source := self
		formatExpression: 'OrderedCollection new add: #a;add:#b;yourself'.
	self
		assert: source
		equals: 'OrderedCollection new add: #a; add: #b; yourself'! !

!EFCascadeExpressionTest methodsFor: 'configurations' stamp: ''!
noNewLineAfterCascadeConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		newLineAfterCascade: false;
		newLineBeforeFirstCascade: false;
		formatCommentCloseToStatements:false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:3;
		maxLineLength:50;
		keepBlockInMessage:false;
		indentStyle: #tabulation;
		newLineBeforeFirstKeyword:false;
		indentExtraSpaces: 0! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testFormatReceiver
	| source |
	configurationSelector := #noNewLineAfterCascadeConfiguration.
	source := self formatExpression: 'a:=1 factorial; +1'.
	self assert: source equals: 'a := 1 factorial; + 1'! !

!EFCascadeExpressionTest methodsFor: 'configurations' stamp: ''!
newLineBeforeCascadeConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"		

	^ self contextClass basicNew
		newLineAfterCascade: false;
		newLineBeforeFirstCascade: true;
		formatCommentCloseToStatements:false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:3;
		maxLineLength:50;
		keepBlockInMessage:false;
		indentStyle: #tabulation;
		newLineBeforeFirstKeyword:false;
		indentExtraSpaces:0! !

!EFCascadeExpressionTest methodsFor: 'configurations' stamp: ''!
multilineMessageConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		newLineAfterCascade: true;
		newLineBeforeFirstCascade: true;
		formatCommentCloseToStatements:false;
		multiLineMessages:#(#multi:line:);
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:3;
		maxLineLength:50;
		keepBlockInMessage:true;
		indentStyle: #tabulation;
		newLineBeforeFirstKeyword:false;
		numberOfSpacesInsideBlock:1;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:1;
		indentsForKeywords:0;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets:false;
		indentExtraSpaces:0! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineAfterCascade2
	| source |
	configurationSelector := #newLineAfterCascadeConfiguration.
	source := self
		formatExpression: 'OrderedCollection new add: #a;add:#b;yourself'.
	self
		assert: source
		equals:
			'OrderedCollection new add: #a;
	add: #b;
	yourself'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineAfterCascade
	| source |
	configurationSelector := #newLineAfterCascadeConfiguration.
	source := self formatExpression: 'Foo a;b;c'.
	self
		assert: source
		equals:
			'Foo a;
	b;
	c'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testOneSpaceIndent
	| source |
	configurationSelector := #spaceIndentConfiguration.
	source := self
		formatExpression:
			'Transcript show:1; cr; cr'.
	self
		assert: source
		equals:
'Transcript
 show: 1;
 cr;
 cr'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testFormatArgument
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '1 between:2 + 2 and:5*5; +1'.
	self assert: source equals: '1 between: 2 + 2 and: 5 * 5; + 1'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testTooLongArgument
	| source |
	configurationSelector := #tooLongArgumentConfiguration.
	source := self formatExpression: 'foo a;b: toLongArgument'.
	self
		assert: source
		equals:
'foo a; b:
		toLongArgument'! !

!EFCascadeExpressionTest methodsFor: 'configurations' stamp: ''!
spaceIndentConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:false;
		newLineAfterCascade:true;
		newLineBeforeFirstCascade: true;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:3;
		maxLineLength:50;
		keepBlockInMessage:false;
		numberOfSpacesInIndent: 1;
		indentStyle: #space;
		indentExtraSpaces:0! !

!EFCascadeExpressionTest methodsFor: 'configurations' stamp: ''!
tooLongArgumentConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:true;
		newLineBeforeFirstCascade: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:3;
		maxLineLength:10;
		keepBlockInMessage:false;
		newLineAfterCascade:false;
		indentStyle: #tabulation;
		indentExtraSpaces:0! !

!EFCascadeExpressionTest methodsFor: 'configurations' stamp: ''!
noNewLineBeforeCascadeConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		newLineAfterCascade: false;
		newLineBeforeFirstCascade: false;
		formatCommentCloseToStatements:false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:3;
		maxLineLength:50;
		keepBlockInMessage:false;
		indentStyle: #tabulation;
		newLineBeforeFirstKeyword:false! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testCommentAfterMessages
	| source |
	self flag: #tocheck. "We do we lose the first comment."
	configurationSelector := #basicConfiguration.
	source := self
		formatExpression:
			'Transcript show:1 "firstComment";
	cr "secondComment";
	cr "thirdComment"'.
	self
		assert: source
		equals:
'Transcript show: 1; "secondComment"cr; "thirdComment"
		cr'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLineAfterCascade
	| source |
	configurationSelector := #noNewLineAfterCascadeConfiguration.
	source := self formatExpression: 'Foo a;b;c'.
	self assert: source equals: 'Foo a; b; c'! !

!EFCascadeExpressionTest methodsFor: 'configurations' stamp: ''!
tooLongArgumentConfigurationWithNewLineAfterCascade
	^ self contextClass basicNew
		formatCommentCloseToStatements:true;
		newLineBeforeFirstCascade: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:3;
		maxLineLength:10;
		keepBlockInMessage:false;
		newLineAfterCascade:true;
		indentStyle: #tabulation;
		indentExtraSpaces:0! !

!EFCascadeExpressionTest methodsFor: 'configurations' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:true;
		newLineBeforeFirstCascade: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:3;
		maxLineLength:50;
		keepBlockInMessage:false;
		newLineAfterCascade:false;
		indentStyle: #tabulation;
		indentExtraSpaces:0;
		indentsForKeywords: 1! !

!EFCascadeExpressionTest methodsFor: 'configurations' stamp: ''!
newLineAfterCascadeConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

"	^ self contextClass new

"

	^ self contextClass basicNew
		newLineAfterCascade: true;
		newLineBeforeFirstCascade: false;
		formatCommentCloseToStatements:false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:3;
		maxLineLength:50;
		keepBlockInMessage:false;
		indentStyle: #tabulation;
		newLineBeforeFirstKeyword:false;
		indentExtraSpaces: 0! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineBeforeCascade2
	| source |
	configurationSelector := #newLineBeforeCascadeConfiguration.
	source := self
		formatExpression: 'OrderedCollection new add: #a;add:#b;yourself'.
	self
		assert: source
		equals:
			'OrderedCollection new
	add: #a; add: #b; yourself'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLineAfterCascade2
	| source |
	configurationSelector := #noNewLineAfterCascadeConfiguration.
	source := self
		formatExpression: 'OrderedCollection new add: #a;add:#b;yourself'.
	self
		assert: source
		equals: 'OrderedCollection new add: #a; add: #b; yourself'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineBeforeAndAfterCascade
	| source |
	configurationSelector := #newLineBeforeAndAfterCascadeConfiguration.
	source := self formatExpression: 'Transcript cr;cr;cr'.
	self
		assert: source
		equals:
			'Transcript
	cr;
	cr;
	cr'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testFormatMessage
	| source |
	configurationSelector := #noNewLineAfterCascadeConfiguration.
	source := self formatExpression: '1 *4; +1'.
	self assert: source equals: '1 * 4; + 1'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLineBeforeCascade
	| source |
	configurationSelector := #noNewLineBeforeCascadeConfiguration.
	source := self formatExpression: 'Foo a;b;c'.
	self assert: source equals: 'Foo a; b; c'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testFormatMultilineMessage
	| source |
	configurationSelector := #multilineMessageConfiguration.
	source := self
		formatExpression: '1 between:2 and:5; to:4 do:[:each| each factorial. each + 1]'.
	self
		assert: source
		equals:
'1
	between: 2 and: 5;
	to: 4 do: [ :each | 
		each factorial.
		each + 1 ]'! !

!EFCascadeExpressionTest methodsFor: 'tests' stamp: ''!
testFormatMultilineMessage2
	| source |
	configurationSelector := #multilineMessageConfiguration.
	source := self formatExpression: '1 factorial; multi:1 line:2'.
	self
		assert: source
		equals:
'1
	factorial;
	multi: 1
	line: 2'! !

!EFContext commentStamp: ''!
I represent all the parameters that can modify a pretty printer. 

The goal is to make sure that we can have a better prettyprinter and replace the Basic pretty printer (configurationFormatter)!
!EFContext methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodSignature: aBoolean
	newLinesAfterMethodSignature := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideParentheses
	^ numberOfSpacesInsideParentheses! !

!EFContext methodsFor: 'accessing' stamp: ''!
maxLineLength: anInteger
	maxLineLength := anInteger! !

!EFContext methodsFor: 'initialization' stamp: ''!
defaultMultiLineMessages

	^ #(#ifTrue:ifFalse: #ifFalse:ifTrue: #ifTrue: #ifFalse: #on:do: #ensure: #ifCurtailed:)! !

!EFContext methodsFor: 'accessing' stamp: ''!
methodSignatureOnMultipleLines
	^ methodSignatureOnMultipleLines! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesAfterCaretSymbolInReturn
	^ numberOfSpacesAfterCaretSymbolInReturn! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesInIndent
	^ numberOfSpacesInIndent! !

!EFContext methodsFor: 'accessing' stamp: ''!
minimumNewLinesBetweenStatements
	^ minimumNewLinesBetweenStatements! !

!EFContext methodsFor: 'accessing' stamp: ''!
keepBlockInMessage: aBoolean
	keepBlockInMessage := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
indentExtraSpaces
	^ indentExtraSpaces! !

!EFContext methodsFor: 'accessing' stamp: ''!
maxLineLength
	^ maxLineLength! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterTemporaries: anInteger
	newLinesAfterTemporaries := anInteger! !

!EFContext methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstCascade: anInteger
	newLineBeforeFirstCascade := anInteger! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfArgumentsForMultiLine
	^ numberOfArgumentsForMultiLine! !

!EFContext methodsFor: 'accessing' stamp: ''!
indentStyle: aSymbol
	"Indent style can be either #tabulation or #space."
	
	indentStyle := aSymbol.
	indentString := aSymbol = #space
		ifTrue: [ self stringFromSpaceNumber: numberOfSpacesInIndent ]
		ifFalse: [ String tab ]! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesAfterCaretSymbolInReturn: aNumber
	spacesAfterCaretSymbolInReturn := self stringFromSpaceNumber: aNumber.
	numberOfSpacesAfterCaretSymbolInReturn := aNumber! !

!EFContext methodsFor: 'accessing' stamp: ''!
indentsForKeywords
	^ indentsForKeywords! !

!EFContext methodsFor: 'accessing' stamp: ''!
spacesAfterCaretSymbolInReturnString
	^ spacesAfterCaretSymbolInReturn! !

!EFContext methodsFor: 'accessing' stamp: ''!
indentExtraSpaces: anInteger
	"To set the number of spaces that represent an indent"

	indentExtraSpaces := self stringFromSpaceNumber: anInteger! !

!EFContext methodsFor: 'accessing' stamp: ''!
indentsForKeywords: anInteger
	indentsForKeywords := anInteger! !

!EFContext methodsFor: 'accessing' stamp: ''!
spacesInsideBlocksString
	^ spacesInsideBlocks! !

!EFContext methodsFor: 'accessing' stamp: ''!
multiLineMessages
	^ multiLineMessages! !

!EFContext methodsFor: 'accessing' stamp: ''!
retainBlankLinesBeforeComments: aBoolean
	retainBlankLinesBeforeComments := aBoolean! !

!EFContext methodsFor: 'initialization' stamp: ''!
initialize
  super initialize.
  self useBasicCommentFormat: true.
  self formatCommentCloseToStatements: true.
  indentsForKeywords := 1.
  keepBlockInMessage := true.
  lineUpBlockBrackets := false.
  maxLineLength := 70.
  methodSignatureOnMultipleLines := false.
  minimumNewLinesBetweenStatements := 1.
  self configureMultiLineMessages.
  newLineAfterCascade := true.
  newLineBeforeFirstCascade := true.
  newLineBeforeFirstKeyword := true.
  numberOfNewLinesAfterMethodComment := 2.
  newLinesAfterMethodSignature := 2.
  newLinesAfterTemporaries := 1.
  numberOfArgumentsForMultiLine := 4.
  self configureOneLineMessages.
  self periodAtEndOfBlock: false.
  self periodAtEndOfMethod: false.
  self retainBlankLinesBetweenStatements: true.
  self retainBlankLinesBeforeComments: true.
  self selectorAndArgumentCombinedMaxSize: 40.
  self numberOfSpacesInsideBlock: 1.
  self numberOfSpacesInsideParentheses: 0.
  self numberOfSpacesAfterCaretSymbolInReturn: 1.
  self indentStyle: #tabulation.
  self numberOfSpacesInIndent: 3.
  self numberOfSpacesBeforeDotInDynamicArray: 0.
  self indentExtraSpaces: 0.
  self numberOfSpacesInsideArray: 1! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideArray: anInteger
	spacesInsideArray := self stringFromSpaceNumber: anInteger.
	numberOfSpacesInsideArray := anInteger! !

!EFContext methodsFor: 'accessing' stamp: ''!
methodSignatureOnMultipleLines: aBoolean
	methodSignatureOnMultipleLines := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfArgumentsForMultiLine: anInteger
	numberOfArgumentsForMultiLine := anInteger! !

!EFContext methodsFor: 'accessing' stamp: ''!
spacesInsideParenthesesString
	^ spacesInsideParentheses! !

!EFContext methodsFor: 'accessing' stamp: ''!
lineUpBlockBrackets
	"When true place a new line before closing a multiline block.
	1 to: 4 do: [ Transcript
		show: i;
		cr
	]
	"
	
	^ lineUpBlockBrackets! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesBeforeDotInDynamicArray
	^ numberOfSpacesBeforeDotInDynamicArray! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesBeforeDotInDynamicArray: anInteger

	spacesBeforeDotInDynamicArray := self stringFromSpaceNumber: anInteger.
	numberOfSpacesBeforeDotInDynamicArray := anInteger! !

!EFContext methodsFor: 'accessing' stamp: ''!
stringFromSpaceNumber: aNumber
	
	^ String new: aNumber withAll: Character space! !

!EFContext methodsFor: 'accessing' stamp: ''!
useBasicCommentFormat
	^ useBasicCommentFormat! !

!EFContext methodsFor: 'accessing' stamp: ''!
newLineAfterCascade: anInteger
	newLineAfterCascade := anInteger! !

!EFContext methodsFor: 'accessing' stamp: ''!
useBasicCommentFormat: aBoolean
	useBasicCommentFormat := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
retainBlankLinesBetweenStatements: aBoolean
	retainBlankLinesBetweenStatements := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
oneLineMessages
	^ oneLineMessages! !

!EFContext methodsFor: 'accessing' stamp: ''!
selectorAndArgumentCombinedMaxSize: anInteger
	selectorAndArgumentCombinedMaxSize := anInteger! !

!EFContext methodsFor: 'initialization' stamp: ''!
defaultOneLineMessages
  ^#(#to: #to:do: #to:by: #to:by:do:)! !

!EFContext methodsFor: 'accessing' stamp: ''!
indentStyle
	^ indentStyle! !

!EFContext methodsFor: 'accessing' stamp: ''!
spacesInsideArray
	^ spacesInsideArray! !

!EFContext methodsFor: 'accessing' stamp: ''!
minimumNewLinesBetweenStatements: anInteger
	minimumNewLinesBetweenStatements := anInteger! !

!EFContext methodsFor: 'initialization' stamp: ''!
configureMultiLineMessages

	multiLineMessages := self defaultMultiLineMessages! !

!EFContext methodsFor: 'accessing' stamp: ''!
multiLineMessages: anArray
	"In case the user entered a string representing array we convert it into array."
	self flag: #tocheck. "we should change this logic. It is terrible, the UI should give us an array and not a string!!"
	multiLineMessages := self class compiler evaluate: anArray asString! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideBlock
	^ numberOfSpacesInsideBlock! !

!EFContext methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstKeyword
	^ newLineBeforeFirstKeyword! !

!EFContext methodsFor: 'accessing' stamp: ''!
formatCommentCloseToStatements: aBoolean
	formatCommentWithStatements := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
newLineAfterCascade
	^ newLineAfterCascade! !

!EFContext methodsFor: 'accessing' stamp: ''!
periodAtEndOfMethod: aBoolean
	periodAtEndOfMethod := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
retainBlankLinesBeforeComments
	^ retainBlankLinesBeforeComments! !

!EFContext methodsFor: 'accessing' stamp: ''!
indentString
	"My value is set using numberOfSpacesInIndent: "
	
	^ indentString! !

!EFContext methodsFor: 'accessing' stamp: ''!
formatCommentCloseToStatements
	^ formatCommentWithStatements! !

!EFContext methodsFor: 'accessing' stamp: ''!
lineUpBlockBrackets: aBoolean
	lineUpBlockBrackets := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
retainBlankLinesBetweenStatements
	^ retainBlankLinesBetweenStatements! !

!EFContext methodsFor: 'accessing' stamp: ''!
oneLineMessages: anArray
	"To be revisited latter. Apparently this trick is to convert strings into an array."
	oneLineMessages := self class compiler evaluate: anArray asString! !

!EFContext methodsFor: 'accessing' stamp: ''!
keepBlockInMessage
	^ keepBlockInMessage! !

!EFContext methodsFor: 'accessing' stamp: ''!
periodsAtEndOfBlock
	^ periodAtEndOfBlock! !

!EFContext methodsFor: 'accessing' stamp: ''!
spacesBeforeDotInDynamicArray 
	^ spacesBeforeDotInDynamicArray! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodComment: aBoolean
	numberOfNewLinesAfterMethodComment := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideParentheses: aNumber
	spacesInsideParentheses := self stringFromSpaceNumber: aNumber.
	numberOfSpacesInsideParentheses := aNumber! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesInIndent: anInteger
	numberOfSpacesInIndent := anInteger.
	indentString := self indentStyle = #space 
		ifTrue: [ self stringFromSpaceNumber: anInteger ]
		ifFalse: [ String tab ]! !

!EFContext methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstKeyword: aBoolean
	newLineBeforeFirstKeyword := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
selectorAndArgumentCombinedMaxSize
	^ selectorAndArgumentCombinedMaxSize! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideArray
	^ numberOfSpacesInsideArray! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodSignature
	^ newLinesAfterMethodSignature! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterTemporaries
	^ newLinesAfterTemporaries! !

!EFContext methodsFor: 'accessing' stamp: ''!
periodAtEndOfBlock: aBoolean
	periodAtEndOfBlock := aBoolean! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodComment
	^ numberOfNewLinesAfterMethodComment! !

!EFContext methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstCascade
	^ newLineBeforeFirstCascade! !

!EFContext methodsFor: 'initialization' stamp: ''!
configureOneLineMessages
	oneLineMessages := self defaultOneLineMessages! !

!EFContext methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideBlock: aNumber
	spacesInsideBlocks := self stringFromSpaceNumber: aNumber.
	numberOfSpacesInsideBlock := aNumber! !

!EFContext methodsFor: 'accessing' stamp: ''!
periodsAtEndOfMethod
	^ periodAtEndOfMethod! !

!EFContext methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream
		nextPutAll: self class name;
		nextPutAll: ' new';
		cr.
	self class instVarNames sorted
		do: [ :each | 
			aStream tab;
				nextPutAll: each;
				nextPutAll: ': '.
			aStream print: (self instVarNamed: each asSymbol) ]
		separatedBy: [ aStream
				nextPutAll: ';';
				cr ]! !

!EFContextTest methodsFor: 'tests' stamp: ''!
testNumberOfSpaces

	| context |
	context := EFContext new. 
	self assert: context indentExtraSpaces equals: ''! !

!EFContextTest methodsFor: 'tests' stamp: ''!
testOneLineMessage

	| context |
	context := EFContext new. 
	self assert: (context oneLineMessages includes: #to:).
	self assert: (context oneLineMessages includes: #to:do:).! !

!EFContextTest methodsFor: 'tests' stamp: ''!
testOneLineMessageClassSide

	self assert: (EFFormatter oneLineMessages includes: #to:).  
	self assert: (EFFormatter oneLineMessages includes: #to:do:).! !

!EFFormatter commentStamp: ''!
Enlumineur is a replacement of BlueInk pretty printer (now packaged in pharo-contributions/configurableFormatter).

It was developed by Hugo Lasnier during 6 months internship within RMOD and supervised by S. Ducasse and G. Polito during 2019.
The code was revisited and cleaned but there are probably more glitches left. 

Enlumineur enhancements compared to BlueInk are:

- systematic test coverage with more than 270 tests
- full revisiting of settings with description and examples
- no way to break the code by entering a non space character to indent code
- support for {.....} long list
- cleaning coupled settings
- support for to:do: block like statement (multiline arguments)
- removal of "traditional parentheses" whatever it meant.
- new line and more indentations after the opening bracket
- A dedicated UI was in preparation but should be redone before introduced in Pharo.
 See package Enlumineur-UI (https://github.com/Ducasse/enlumineur)

Enlumineur should be improved to be able to reformat the full code of Pharo.
The tests are a first step to make sure that we understand what is impacted by a change.

Implementation remarks
	  - willBeMultiline: too costly because it formats the code to see if it fits.
	We should have other heuristics.
	- formatBlock: should be improved and speed up. 
	formatBlock2: is a first alternative but it broke some tests that should be evaluated. 
	- Some Node extensions should be pushed to the packages their belong to. 
!
!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodSignature: anInteger
	context numberOfNewLinesAfterMethodSignature: anInteger! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode 
	codeStream nextPutAll: aVariableNode name! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideParentheses
	^ context numberOfSpacesInsideParentheses! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode
	self
		bracketWith: '[]'
		around: [ self formatBlock: aBlockNode ]! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode
	self formatTemporariesFor: aSequenceNode.
	aSequenceNode comments
		ifNotEmpty: [ self formatCommentsFor: aSequenceNode;
						newLine ].
	self formatSequenceNodeStatementsFor: aSequenceNode! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfSpacesInIndent
	^ context numberOfSpacesInIndent! !

!EFFormatter methodsFor: 'private' stamp: ''!
indentAround: aBlock 
	self indent: 1 around: aBlock! !

!EFFormatter methodsFor: 'private' stamp: ''!
isLineTooLongWithNewCharacters: aNumber
	"Is the length of the current line + the length of the first fragment of code until a new line is >= the max line length"
	
	^ self currentLineLength + aNumber >= self maxLineLength! !

!EFFormatter methodsFor: 'private' stamp: ''!
isLineTooLongWithString: aString
	"Is the length of the current line + the length of the first fragment of code until a new line is >= the max line length"
	
	^ self currentLineLength + (aString indexOf: Character cr ifAbsent: [ aString size ])
		>= self maxLineLength! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatMethodPatternFor: aMethodNode
	aMethodNode arguments isEmpty
		ifTrue: [ codeStream nextPutAll: aMethodNode selector ]
		ifFalse: [ 
			(self needsMethodSignatureOnMultipleLinesFor: aMethodNode)
				ifTrue: [ self privateFormatMethodPatternMultiLineFor: aMethodNode ]
				ifFalse: [ self privateFormatMethodPatternMonoLineFor: aMethodNode ] ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
indentExtraSpaces
	^ context indentExtraSpaces! !

!EFFormatter methodsFor: 'private' stamp: ''!
privateFormatMethodPatternMultiLineFor: aMethodNode
	| selectors arguments |
	arguments := aMethodNode arguments.
	selectors := aMethodNode selectorParts.
	codeStream nextPutAll: selectors first.
	self space.
	self visitNode: arguments first.
	codeStream nextPut: Character cr.
	self
		with: selectors allButFirst
		and: arguments allButFirst
		do: [ :key :arg | 
			codeStream nextPutAll: self indentString.
			codeStream nextPutAll: key.
			self space.
			self visitNode: arg ]
		separatedBy: [ self characterSeparatorMethodSignatureFor: aMethodNode].
	self newLines: 1! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitLiteralNode: aLiteralNode
	aLiteralNode value isLiteral
		ifFalse: [ self writeString: '''<an unprintable nonliteral value>''' ]
		ifTrue: [ self writeString: aLiteralNode sourceText ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstCascade: aBoolean
	context newLineBeforeFirstCascade: aBoolean! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitNode: aNode
	| needsParenthesis |
	needsParenthesis := self needsParenthesisFor: aNode.
	self
		bracketWith:
			(needsParenthesis
				ifTrue: [ '()' ]
				ifFalse: [ '' ])
		around: [ 
			needsParenthesis
				ifTrue: [ codeStream nextPutAll: self spacesInsideParenthesesString ].
			super visitNode: aNode.
			(self formatCommentCloseToStatements or: [ aNode isMethod or: [ aNode isSequence or: [ aNode isBlock ] ] ])
				ifFalse: [  self spaceAndFormatComments: aNode. ].
			needsParenthesis
				ifTrue: [ codeStream nextPutAll: self spacesInsideParenthesesString ] ]
		indentExtraSpaces: (needsParenthesis ifTrue: [ 1 + self numberOfSpacesInsideParentheses ] ifFalse:[ 0 ])! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
spacesAfterCaretSymbolInReturnString
	^ context spacesAfterCaretSymbolInReturnString! !

!EFFormatter methodsFor: 'private' stamp: ''!
bracketWith: bracketString around: aBlock
	bracketString isEmpty
		ifTrue: [ ^ aBlock value ].
	codeStream nextPut: bracketString first.
	^ aBlock
		ensure: [ codeStream nextPut: bracketString last ]! !

!EFFormatter methodsFor: 'private' stamp: ''!
addSpaceIfNeededForLastArgument: aPragmaNode
	aPragmaNode isUnary
		ifTrue: [ ^ self ].
	(self pragmaArgumentNeedsSeparator: aPragmaNode arguments last)
		ifTrue: [ self space ]! !

!EFFormatter methodsFor: 'private' stamp: ''!
privateFormatMethodPatternMonoLineFor: aMethodNode
	self
		with: aMethodNode selectorParts
		and: aMethodNode arguments
		do: [ :key :arg | 
			codeStream nextPutAll: key.
			self space.
			self visitNode: arg ]
		separatedBy: [ self characterSeparatorMethodSignatureFor: aMethodNode ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
spacesInsideBlocksString
	^ context spacesInsideBlocksString! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatSelectorAndArguments: aMessageNode
	"We are formatting a message and here we are about to format the message selector and its arguments."
	
	| isMultilineMessage hasMultiLineArguments multilineArgumentBeforeAnotherArgument |
	multilineArgumentBeforeAnotherArgument := self messageHasMultilineArgumentBeforeAnotherArgument: aMessageNode.
	isMultilineMessage := (self isMultiLineMessage: aMessageNode) or:[multilineArgumentBeforeAnotherArgument].
	hasMultiLineArguments := self hasAMultiLineMessageArgument: aMessageNode arguments.
	self
		indent:
			(((isMultilineMessage or:[hasMultiLineArguments]) and:[aMessageNode isKeyword])
				ifTrue: [ self indentsForKeywords ]
				ifFalse: [ 0 ])
		around: [ self
				formatSelectorAndArguments: aMessageNode
				firstSeparator:
					(((self firstSeparatorShouldNotPassLine: aMessageNode) and:[multilineArgumentBeforeAnotherArgument not])
						ifTrue: [ self space ]
						ifFalse: [ isMultilineMessage
								ifTrue: [ [ self newLine ] ]
								ifFalse: [ [ self space ] ] ])
				restSeparator:
					((isMultilineMessage)
						ifTrue: [ [ self newLine ] ]
						ifFalse: [ [ self space ] ]) ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
retainBlankLinesBeforeComments: aBoolean
	context retainBlankLinesBeforeComments: aBoolean! !

!EFFormatter methodsFor: 'visiting - patterns' stamp: ''!
visitPatternWrapperBlockNode: aRBPatternWrapperBlockNode
	self visitNode: aRBPatternWrapperBlockNode wrappedNode.
	codeStream nextPut: $`.
	self 
		bracketWith: '{}' 
		around: [self formatBlock: aRBPatternWrapperBlockNode]! !

!EFFormatter methodsFor: 'private' stamp: ''!
formattedSourceFor: aNode

	^ lookAheadCode at: aNode ifAbsentPut: [ 
		  self class new
			indent: self indent;
			installNewContext: context;
			lookAheadCode: lookAheadCode;
			format: aNode ]! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aRBArrayLiteralNode
	| brackets current |
	codeStream nextPut: $#.
	brackets := aRBArrayLiteralNode isForByteArray
		ifTrue: [ '[]' ]
		ifFalse: [ '()' ].
	self
		bracketWith: brackets
		around: [ self
				indentExtraSpaces: '#(' size + self numberOfSpacesInsideArray
				around: [ codeStream nextPutAll: self spacesInsideArray.
					aRBArrayLiteralNode contents
						do: [ :each | 
							current := each.
							self visitNode: each ]
						separatedBy: [ (self isLineTooLongWithNode: current)
								ifTrue: [ self newLine ]
								ifFalse: [ self space ] ].
					codeStream nextPutAll: self spacesInsideArray ] ]! !

!EFFormatter methodsFor: 'private' stamp: ''!
addNewLinesBeforeStatementStartingAt: anInteger 
	| newLines |
	newLines := self minimumNewLinesBetweenStatements 
				max: (self retainBlankLinesBetweenStatements 
						ifTrue: [ self newLinesBeforeStartingAt: anInteger ]
						ifFalse: [ 0 ]).
	newLines = 0 
		ifTrue: [ self space ] 
		ifFalse: [ self newLines: newLines ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
methodSignatureOnMultipleLines: aBoolean
	context methodSignatureOnMultipleLines: aBoolean! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfArgumentsForMultiLine: anInteger
	context numberOfArgumentsForMultiLine: anInteger! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
spacesInsideParenthesesString
	"Set via numberOfSpacesInsideParentheses: "
	^ context spacesInsideParenthesesString! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
isInCascadeNode: aBoolean
	isInCascadeNode := aBoolean! !

!EFFormatter methodsFor: 'private' stamp: ''!
newLines: anInteger
	"Add a number of new lines and in addition store the position of the latest new lines in the stream so that latter we can compute the current line length."
	
	anInteger + self indentString size = 0
		ifTrue: [ codeStream space ].
	anInteger timesRepeat: [ codeStream cr ].
	lineStart := codeStream position.
	self indentTimesRepeat: self indent! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
useBasicCommentFormat 
	^ context useBasicCommentFormat! !

!EFFormatter methodsFor: 'private' stamp: ''!
willBeMultiline: aNode
  ^(self formattedSourceFor: aNode) includes: Character cr! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
oneLineMessages
	^ context oneLineMessages! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitArrayNode: anArrayNode
	self bracketWith: '{}' around: [ self formatArray: anArrayNode ]! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
spaceAndFormatComments: aNode
	aNode comments ifNotEmpty: [ self space ].
	self formatCommentsFor: aNode! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
spacesInsideArray
	^ context spacesInsideArray! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
minimumNewLinesBetweenStatements: anInteger
	context minimumNewLinesBetweenStatements: anInteger! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitMessageNode: aMessageNode
	self visitNode: aMessageNode receiver.
	self formatSelectorAndArguments: aMessageNode! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstKeyword
	^ context newLineBeforeFirstKeyword! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideBlock
	^ context numberOfSpacesInsideBlock! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatMethodBodyFor: aMethodNode
	self
		indentAround:
			[ 
			self newLines: self numberOfNewLinesAfterMethodSignature.
			self formatMethodCommentFor: aMethodNode.
			self formatPragmasFor: aMethodNode.
			self visitNode: aMethodNode body ]! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
shouldPassNewLineAfterHeadOfBlock: aBlockNode
	^  aBlockNode headIsNotEmpty or: [ self keepBlockInMessage ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
periodAtEndOfMethod: aBoolean
	context periodAtEndOfMethod: aBoolean! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
retainBlankLinesBeforeComments
	^ context retainBlankLinesBeforeComments! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
indentString
	^ context indentString! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
formatCommentCloseToStatements
	^ context formatCommentCloseToStatements! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitCascadeNode: aCascadeNode
	self isInCascadeNode: true.
	self visitNode: aCascadeNode receiver.
	self
		indentAround: [ 
			self newLineBeforeFirstCascade
				ifTrue: [ self newLine ]
				ifFalse: [ self space ].
			aCascadeNode messages
				do: [ :each | 
							self formatCommentsFor: each;
								formatSelectorAndArguments: each
								firstSeparator: [  ]
								restSeparator:
									((self isMultiLineMessage: each)
										ifTrue: [ [ self newLine ] ]
										ifFalse: [ [ self space ] ])]
				separatedBy: [ 
					codeStream nextPut: $;.
					self newLineAfterCascade
						ifTrue: [ self newLine ]
						ifFalse: [ self space ] ]
					].
	self isInCascadeNode: false! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
lineUpBlockBrackets: aBoolean
	context lineUpBlockBrackets: aBoolean! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
oneLineMessages: anArray
	context oneLineMessages: anArray! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitPragmaNode: aPragmaNode
	codeStream nextPut: $<.
	self 
		formatSelectorAndArguments: aPragmaNode 
		firstSeparator: [ 
			aPragmaNode selector isInfix
				ifTrue: [ self space ] ]
		restSeparator: [ self space ].
	self addSpaceIfNeededForLastArgument: aPragmaNode.
	codeStream nextPut: $>! !

!EFFormatter methodsFor: 'utilities' stamp: ''!
resizeCommentFor: aComment startingAt: anIndex
	codeStream nextPut: $".
	"Hack to keep the right comment in pop up like cmd n, cmd m..."
	self maxLineLength < 50
		ifTrue: [ codeStream nextPutAll: aComment contents ]
		ifFalse:
			[ 
			aComment contents
				ifNotEmpty:
					[ 
					(anIndex = 0 or: [ anIndex >= self maxLineLength ])
						ifTrue: [ self resizeStringDependingOnWindowSizeFor: aComment ]
						ifFalse: [ self resizeComment: aComment withFirstLineShorterOf: anIndex ] ] ].
	codeStream nextPut: $"! !

!EFFormatter methodsFor: 'public interface' stamp: ''!
installNewContext: aContext
	
	context := aContext! !

!EFFormatter methodsFor: 'private' stamp: ''!
formatTemporariesFor: aSequenceNode
	aSequenceNode hasTemporaries
		ifFalse: [ ^ self ].
	self
		bracketWith: '|'
		around:
			[ 
			self space.
			aSequenceNode temporaries
				do:
					[ :each | 
					self visitNode: each.
					self formatCommentCloseToStatements
						ifTrue: [ self formatStatementCommentsFor: each ].
					self space ] ].
	self newLines: self numberOfNewLinesAfterTemporaries! !

!EFFormatter methodsFor: 'private' stamp: ''!
isLineTooLongWithNode: aNode
  ^self isLineTooLongWithString: (self formattedSourceFor: aNode)! !

!EFFormatter methodsFor: 'private' stamp: ''!
newLinesBeforeStartingAt: anIndex
	| count cr lf index char |
	originalSource ifNil: [ ^ 0 ].
	(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! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideParentheses: anInteger
	context numberOfSpacesInsideParentheses: anInteger! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
selectorAndArgumentCombinedMaxSize
	^ context selectorAndArgumentCombinedMaxSize! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatArrayBody: aSequenceNode
	| statements |
	statements := aSequenceNode statements.
	statements isEmpty
		ifTrue: [ ^ self ].
	statements withIndexDo: [:statement :i | 
		self visitNode: statement.
		i < statements size
			ifTrue: [ codeStream nextPutAll: self spacesBeforeDotInDynamicArray ; nextPut: $. ].
		self formatStatementCommentsFor: statement.
		i < statements size
			ifTrue: [ self addNewLinesBeforeStatementStartingAt: (statements at: i + 1) start ] ]! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatSingleArrayElement: aRBNode 
	"Imagine that you have {1 factorial}, you do not want an ending period. This method is only invoked on the last array element."
	
	self visitNode: aRBNode! !

!EFFormatter methodsFor: 'private' stamp: ''!
space
	codeStream space! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodSignature
	^ context numberOfNewLinesAfterMethodSignature! !

!EFFormatter methodsFor: 'utilities' stamp: ''!
resizeComment: aComment withFirstLineShorterOf: anIndex
	| cutComment firstLine currentCharPos |
	currentCharPos := 1.
	firstLine := (aComment contents
		withNoLineLongerThan: self maxLineLength - anIndex) lineNumber: 1.
	[ currentCharPos > firstLine size ]
		whileFalse: [ codeStream nextPut: (firstLine at: currentCharPos).
			currentCharPos := currentCharPos + 1 ].
	currentCharPos > aComment contents size
		ifTrue: [ ^ self ].
	self newLine.
	cutComment := aComment contents allButFirst: currentCharPos.
	self resizeStringDependingOnWindowSizeFor: cutComment! !

!EFFormatter methodsFor: 'private' stamp: ''!
bracketWith: bracketString around: aBlock indentExtraSpaces: anInteger
	bracketString isEmpty
		ifTrue: [ ^ aBlock value ].
	codeStream nextPut: bracketString first.
	^ [ self indentExtraSpaces: anInteger  around: aBlock ]
		ensure: [ codeStream nextPut: bracketString last ]! !

!EFFormatter methodsFor: 'private' stamp: ''!
messageHasMultilineArgumentBeforeAnotherArgument: aMessageNode
  aMessageNode arguments doWithIndex: [:each :i |  (self willBeMultiline: each) ifTrue: [ ^i < aMessageNode arguments size ] ].
  ^false! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
periodAtEndOfBlock: aBoolean
	context periodAtEndOfBlock: aBoolean! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatSelectorAndArguments: aMessageNode firstSeparator: firstBlock restSeparator: restBlock
  | separatorBlock i |
  i := 0.
  separatorBlock := firstBlock.
  aMessageNode isUnary ifTrue: [ self indentAround: [ self handleLineForSelector: aMessageNode selector withSeparatorBlock: separatorBlock.
              codeStream nextPutAll: aMessageNode selector ] ] ifFalse: [ aMessageNode selectorParts with: aMessageNode arguments do: [:selector :argument |  i := i + 1.
              self handleLineForSelector: selector withSeparatorBlock: separatorBlock.
              separatorBlock := restBlock.
              self indent: ((((self willBeMultiline: argument) and: [ i < aMessageNode selectorParts size or: [ self newLineBefore ] ]) or: [ self isInCascadeNode ]) ifTrue: [ 1 ] ifFalse: [ 0 ]) around: [ codeStream nextPutAll: selector.
                    self handleLineForArgument: argument ].
              ((self willBeMultiline: argument) and: [ i < aMessageNode selectorParts size ]) ifTrue: [ separatorBlock := self newLine ] ] ]! !

!EFFormatter methodsFor: 'private' stamp: ''!
needsMethodSignatureOnMultipleLinesFor: aMethodNode
	| cpt |
	cpt := 0.
	^ self methodSignatureOnMultipleLines
		ifTrue: [ aMethodNode selectorParts
				with: aMethodNode arguments
				do: [ :key :arg | key size + arg name size > self selectorAndArgumentCombinedMaxSize ifTrue: [ cpt := cpt + 1 ] ].
			cpt > 1 ]
		ifFalse: [ false ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideBlock: anInteger
	context numberOfSpacesInsideBlock: anInteger! !

!EFFormatter methodsFor: 'private' stamp: ''!
handleLineForArgument: anArgument
  | isLineTooLong |
  isLineTooLong := self isLineTooLongWithNode: anArgument.
  anArgument isBlock ifTrue: [ ((self willBeMultiline: anArgument) and: [ self keepBlockInMessage not ]) ifTrue: [ self newLine ] ifFalse: [ self space ] ] ifFalse: [ (self isInCascadeNode and: [ isLineTooLong ]) ifTrue: [ self newLine ] ifFalse: [ isLineTooLong ifTrue: [ self newLine ] ifFalse: [ self space ] ] ].
  self visitNode: anArgument! !

!EFFormatter methodsFor: 'private' stamp: ''!
hasAMultiLineMessageArgument: anArgumentsCollection
  ^anArgumentsCollection anySatisfy: [:each |  self isInCascadeNode ifTrue: [ self indent: 0 around: [ self willBeMultiline: each ] ] ifFalse: [ self indent: self indentsForKeywords + 1 around: [ self willBeMultiline: each ] ] ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
lineStart: anObject
	lineStart := anObject! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
maxLineLength: anInteger
	context maxLineLength: anInteger! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
indent
	^ indent! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
methodSignatureOnMultipleLines
	^ context methodSignatureOnMultipleLines! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfSpacesAfterCaretSymbolInReturn
	^ context numberOfSpacesAfterCaretSymbolInReturn! !

!EFFormatter methodsFor: 'private' stamp: ''!
writeString: aString
	"Write the argument in the code stream and in addition maintent the line start position so that we can later compute the current line length."
	| index |
	index := aString lastIndexOf: Character cr ifAbsent: [ 0 ].
	codeStream nextPutAll: aString.
	index > 0
		ifTrue: [ lineStart := codeStream position - (aString size - index) ]! !

!EFFormatter methodsFor: 'private' stamp: ''!
indent: anInteger around: aBlock 
	self indent: self indent + anInteger.
	^aBlock ensure: [self indent: self indent - anInteger]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
minimumNewLinesBetweenStatements
	^ context minimumNewLinesBetweenStatements! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatArray: anArrayNode
	| current |
	codeStream nextPutAll: self spacesInsideArray.
	(anArrayNode statements
		reject: [ :each | each class = RBLiteralValueNode ])
		ifEmpty: [ anArrayNode statements
				do: [ :each | 
					current := each.
					self visitNode: each ]
				separatedBy: [ (self isLineTooLongWithNode: current)
						ifTrue: [ codeStream nextPutAll: self spacesBeforeDotInDynamicArray; nextPut: $..
							self newLine ]
						ifFalse: [ codeStream nextPutAll: self spacesBeforeDotInDynamicArray ; nextPutAll: '. ' ] 
						"here there is something wrong since we should also be able to put a space in front"] ]
		ifNotEmpty: [ anArrayNode statements size > 1
				ifTrue: [ self
						indentAround: [ 
							"I do not get why we do not have a property to decide if we emit or not the line" 
							"with the introduction of formatArrayBody: we may remove formatSingleArrayElement"
							self
								newLine;
								formatArrayBody: anArrayNode ] ]
				ifFalse: [ self formatSingleArrayElement: anArrayNode statements first ] ].
	codeStream nextPutAll: self spacesInsideArray! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatBlock: aBlockNode
 	" see formatBlock2: for a possible alternate and faster definition."
	
	| isMultiline |
	isMultiline := self willBeMultiline: aBlockNode body.
  
	codeStream nextPutAll: self spacesInsideBlocksString.
	
	self formatBlockArgumentsFor: aBlockNode.
	self formatBlockCommentFor: aBlockNode.
	((isMultiline or: [ self isLineTooLongWithNode: aBlockNode body ]) 
		and: [ self shouldPassNewLineAfterHeadOfBlock: aBlockNode ]) 
			ifTrue: [ self newLine ].
  
	self visitSequenceNode: aBlockNode body.
	
	(self lineUpBlockBrackets and: [ isMultiline ]) 
		ifTrue: [ self newLine ] 
		ifFalse: [ codeStream nextPutAll: self spacesInsideBlocksString ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
keepBlockInMessage: aBoolean
	context keepBlockInMessage: aBoolean! !

!EFFormatter methodsFor: 'private' stamp: ''!
handleLineForSelector: selector withSeparatorBlock: aBlock
	(self isLineTooLongWithString: selector)
		ifTrue: [ self newLine ]
		ifFalse: [ aBlock value ]! !

!EFFormatter methodsFor: 'private' stamp: ''!
isMultiLineMessage: aMessageNode
	(self multiLineMessages includes: aMessageNode selector)
		ifTrue: [ ^ true ].
	(self oneLineMessages includes: aMessageNode selector)
		ifTrue: [ ^ false ].
	self numberOfArgumentsForMultiLine <= aMessageNode arguments size
		ifTrue: [ ^ true ].
	aMessageNode isUnary
		ifTrue: [ ^ self isLineTooLongWithString: aMessageNode selector ].
	^ self isLineTooLongWithString: (self formatMessageNode: aMessageNode) contents! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
lookAheadCode: anObject
	lookAheadCode := anObject! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
codeStream: anObject
	codeStream := anObject! !

!EFFormatter methodsFor: 'private' stamp: ''!
indentExtraSpaces: anInteger around: aBlock
	| previousIndentExtraSpacesSize |
	previousIndentExtraSpacesSize := self indentExtraSpaces size.
	self indentExtraSpaces: anInteger + previousIndentExtraSpacesSize.
	aBlock
		ensure: [ self indentExtraSpaces: previousIndentExtraSpacesSize ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
maxLineLength
	^ context maxLineLength! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
indentStyle: aSymbole
	context indentStyle: aSymbole! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatBlockArgumentsFor: aBlockNode

	| onAnotherLine args |
	args := aBlockNode arguments.
	args isEmpty
		ifTrue: [ ^ self ].
	onAnotherLine := self areArgumentsTooLong: args. 
	args
		do: [ :each | 
			onAnotherLine ifTrue: [self newLine ].
			codeStream nextPut: $:.
			self visitVariableNode: each.
			self formatCommentCloseToStatements
				ifTrue:
					[ self spaceAndFormatComments: each ].
			self space ].
	codeStream nextPutAll: '| '.! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
indentsForKeywords
	^ context indentsForKeywords! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfArgumentsForMultiLine
	^ context numberOfArgumentsForMultiLine! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
indentExtraSpaces: anInteger
	context indentExtraSpaces: anInteger! !

!EFFormatter methodsFor: 'public interface' stamp: ''!
format: aParseTree
	
	self initializeCodeStream.
	originalSource := aParseTree source.
	self visitNode: aParseTree.
	^ codeStream contents! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
indentsForKeywords: anInteger
	context indentsForKeywords: anInteger! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterTemporaries: anInteger
	context numberOfNewLinesAfterTemporaries: anInteger! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfSpacesAfterCaretSymbolInReturn: anInteger
	context numberOfSpacesAfterCaretSymbolInReturn: anInteger! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: anAssignmentNode
	| var |
	var := anAssignmentNode variable.
	self visitVariableNode: var.
	codeStream nextPutAll: ' := '.
	self
		indentExtraSpaces: var name size + ' := ' size
		around: [ self visitNode: anAssignmentNode value ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
multiLineMessages
	^ context multiLineMessages! !

!EFFormatter methodsFor: 'initialization' stamp: ''!
initializeTemporaryLookAheadCode

	lookAheadCode := IdentityDictionary new
	"this is strange because using an identity should normally produce more entries in the cache
	since each node is a different object. 
	However on simple methods it is still faster than using a Dictionary."! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitParseErrorNode: aNode
	self writeString: aNode value! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitReturnNode: aReturnNode
	codeStream
		nextPut: $^;
		nextPutAll: self spacesAfterCaretSymbolInReturnString.
	self
		indentExtraSpaces: 1 + self numberOfSpacesAfterCaretSymbolInReturn
		around: [ self visitNode: aReturnNode value ]! !

!EFFormatter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	lineStart := 0.
	self indent: 0.
	self isInCascadeNode: false.
	self initializeCodeStream.
	context := DefaultPrettyPrintContext.
	self initializeTemporaryLookAheadCode! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitEnglobingErrorNode: aNode
	self writeString: aNode value.
	aNode children do: [ :e |
		codeStream space.
		self visitNode: e ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideArray: anInteger
	context numberOfSpacesInsideArray: anInteger! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatPragmasFor: aMethodNode
	
	aMethodNode pragmas do: [ :each | self visitPragmaNode: each; newLine ]! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatStatementCommentsFor: aStatementNode
	self formatCommentCloseToStatements
		ifFalse: [ ^ self ].
	aStatementNode statementComments
		do:
			[ :each | 
			| count |
			count := self newLinesBeforeStartingAt: each start.
			self retainBlankLinesBeforeComments & (count > 0)
				ifTrue: [ self newLines: count ]
				ifFalse: [ self space ].
			self useBasicCommentFormat
				ifTrue: [ self basicFormatCommentFor: each ]
				ifFalse: [ self resizeCommentFor: each startingAt: self currentLineLength ]]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
lineUpBlockBrackets
	"Return whether a new line should be added before closing a multiline block.
	1 to: 4 do: [ Transcript
		show: i;
		cr
	]
	"
	^ context lineUpBlockBrackets! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
indentTimesRepeat: anInteger
	
	anInteger timesRepeat: 
			[ codeStream nextPutAll: self indentString ].
	codeStream nextPutAll: self indentExtraSpaces! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
useBasicCommentFormat: aBoolean
	context useBasicCommentFormat: aBoolean! !

!EFFormatter methodsFor: 'private' stamp: ''!
basicFormatCommentFor: aComment
	codeStream
		nextPut: $";
		nextPutAll: aComment contents;
		nextPut: $"! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
newLineAfterCascade: aBoolean
	context newLineAfterCascade: aBoolean! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
retainBlankLinesBetweenStatements: aBoolean
	context retainBlankLinesBetweenStatements: aBoolean! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatCommentsFor: aNode
  aNode comments do: [:each |  self basicFormatCommentFor: each ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
selectorAndArgumentCombinedMaxSize: anInteger
	context selectorAndArgumentCombinedMaxSize: anInteger! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
isInCascadeNode
	^ isInCascadeNode! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
indentStyle
	^ context indentStyle! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
indent: anInteger

	indent := anInteger! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
multiLineMessages: anArray
	context multiLineMessages: anArray! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatSequenceNodeStatementsFor: aSequenceNode
	| statements |
	statements := aSequenceNode statements.
	statements isEmpty
		ifTrue: [ ^ self ].
	statements withIndexDo: [:statement :i | 
		self visitNode: statement.
		(i < statements size
			or: [ 
				aSequenceNode parent
					ifNil: [ self periodsAtEndOfBlock or:[ self periodsAtEndOfMethod ] ]
					ifNotNil: [ :parent | 
						parent isBlock
							ifTrue: [ self periodsAtEndOfBlock ]
							ifFalse: [ self periodsAtEndOfMethod ] ] ])
			ifTrue: [ codeStream nextPut: $. ].
		self formatStatementCommentsFor: statement.
		i < statements size
			ifTrue: [ self addNewLinesBeforeStatementStartingAt: (statements at: i + 1) start ] ]! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatMethodCommentFor: aMethodNode
  aMethodNode comments do: [:each |  
				self useBasicCommentFormat 
					ifTrue: [ self basicFormatCommentFor: each ] 
					ifFalse: [ self resizeCommentFor: each startingAt: 0 ].
        		self newLines: self numberOfNewLinesAfterMethodComment ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
formatCommentCloseToStatements: aBoolean
	context formatCommentCloseToStatements: aBoolean! !

!EFFormatter methodsFor: 'private' stamp: ''!
formatMessageNode: aMessageNode
  ^String streamContents: [:messageStream |  self with: aMessageNode selectorParts and: aMessageNode arguments do: [:selector :arg |  messageStream
                 nextPutAll: selector;
                 space;
                 nextPutAll: (self formattedSourceFor: arg) ] separatedBy: [ messageStream space ] ]! !

!EFFormatter methodsFor: 'private' stamp: ''!
newLine
	self newLines: 1! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
newLineAfterCascade
	^ context newLineAfterCascade! !

!EFFormatter methodsFor: 'initialization' stamp: ''!
initializeCodeStream

  codeStream := WriteStream on: (String new: 256)! !

!EFFormatter methodsFor: 'utilities' stamp: ''!
with: firstCollection and: secondCollection do: aBlock separatedBy: separatorBlock
	firstCollection isEmpty
		ifTrue: [ ^ self ].
	aBlock value: firstCollection first value: secondCollection first.
	2 to: firstCollection size do: [ :i | 
		separatorBlock value.
		aBlock value: (firstCollection at: i) value: (secondCollection at: i) ]! !

!EFFormatter methodsFor: 'utilities' stamp: ''!
resizeStringDependingOnWindowSizeFor: aComment
	| resizedComment |
	resizedComment := aComment contents withNoLineLongerThan: self maxLineLength.
	resizedComment do: [ :each | 
		codeStream nextPut: each.
		each = Character cr
			ifTrue: [ self indentTimesRepeat: self indent  ] ]! !

!EFFormatter methodsFor: 'private' stamp: ''!
areArgumentsTooLong: anArray

	| size |
	size := anArray sum: [ :each | each name size ].
	^ self isLineTooLongWithNewCharacters: size! !

!EFFormatter methodsFor: 'private' stamp: ''!
needsParenthesisFor: aNode
	| parent grandparent |
	aNode ifNil: [ ^ false ].
	aNode isValue
		ifFalse: [ ^ false ].
	aNode isParseError
		ifTrue: [ ^ false ].
	parent := aNode parent ifNil: [ ^ false ].
	(aNode isMessage
		and: [ parent isMessage
				and: [ parent receiver == aNode and: [ aNode selector isUnary not ] ] ])
		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 isUnary
		ifTrue: [ ^ false ].
	aNode isKeyword
		ifTrue: [ ^ true ].
	(parent isMessage and: [ parent receiver == aNode ])
		ifFalse: [ ^ true ].
	aNode precedence = parent precedence
		ifFalse: [ ^ true ].
	^ false! !

!EFFormatter methodsFor: 'private' stamp: ''!
pragmaArgumentNeedsSeparator: anArgumentNode
	^ anArgumentNode value isSymbol and: [ anArgumentNode value isBinary ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
retainBlankLinesBetweenStatements
	^ context retainBlankLinesBetweenStatements! !

!EFFormatter methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode 
	self formatMethodPatternFor: aMethodNode.
	self formatMethodBodyFor: aMethodNode! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
keepBlockInMessage
	"Return a boolean for 
		1 to: 4 do: [ :i | 
			
	vs. 
	
		1 to: 4 do: 
			[ :i |"
			
	^ context keepBlockInMessage! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
periodsAtEndOfBlock
	^ context periodsAtEndOfBlock! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
spacesBeforeDotInDynamicArray 
	^ context spacesBeforeDotInDynamicArray! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
lookAheadCode
	^ lookAheadCode! !

!EFFormatter methodsFor: 'private' stamp: ''!
newLineBefore
	"predicate which return true if there where a newLine in the code stream just before the current position"

	| currentIndentationString |
	currentIndentationString := WriteStream on: (String new: self maxLineLength).
	1 to: self indent do: [ :i | 
		currentIndentationString nextPutAll: self indentString ].
	currentIndentationString nextPutAll: self indentExtraSpaces.
	^ self codeStream contents lines last = currentIndentationString contents! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodComment: anInteger
	context numberOfNewLinesAfterMethodComment: anInteger! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatBlock2: aBlockNode
 
	"This is a change to speed up and avoid the use of willBeMultiline: 
	Now it breaks many tests and we should investigate why
	For example 
	
	we obtain
		hkjhjkh 
			ifTrue: [ self foo
				 ]
	
	and not 
		hkjhjkh 
			ifTrue: [ self foo ]
	"

	| doesFirstStatementFit |
	codeStream nextPutAll: self spacesInsideBlocksString.
	self formatBlockArgumentsFor: aBlockNode.
	self formatBlockCommentFor: aBlockNode.
	
	doesFirstStatementFit := self isLineTooLongWithNode: aBlockNode body statements first.
	
	((self shouldPassNewLineAfterHeadOfBlock: aBlockNode)
		and: [ (aBlockNode body statements size > 1) or: [ doesFirstStatementFit ] ])
					ifTrue: [ self newLine ].
  
	self visitSequenceNode: aBlockNode body.
	
	(self lineUpBlockBrackets and: [ (aBlockNode body statements size > 1) 
													or: [ doesFirstStatementFit ] ])
		ifTrue: [ self newLine ]
		ifFalse: [ codeStream nextPutAll: self spacesInsideBlocksString ]! !

!EFFormatter methodsFor: 'visiting - patterns' stamp: ''!
visitPatternBlockNode: aRBPatternBlockNode 
	codeStream nextPut: $`.
	self 
		bracketWith: '{}' 
		around: [self formatBlock: aRBPatternBlockNode]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfSpacesInIndent: anInteger
	context numberOfSpacesInIndent: anInteger! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstKeyword: aBoolean
	context newLineBeforeFirstKeyword: aBoolean! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
formatBlockCommentFor: aBlockNode
  aBlockNode comments do: [:each |  self basicFormatCommentFor: each.
        (self isNonEmptySingleLineBlock: aBlockNode) ifTrue: [ self space ] ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideArray
	^ context numberOfSpacesInsideArray! !

!EFFormatter methodsFor: 'private' stamp: ''!
characterSeparatorMethodSignatureFor: aMethodNode
	^ (self needsMethodSignatureOnMultipleLinesFor: aMethodNode)
			ifTrue: [ self newLine ]
			ifFalse: [ self space ]! !

!EFFormatter methodsFor: 'private' stamp: ''!
currentLineLength
	^ codeStream position - lineStart! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterTemporaries
	^ context numberOfNewLinesAfterTemporaries! !

!EFFormatter methodsFor: 'private' stamp: ''!
isNonEmptySingleLineBlock: aBlockNode
  ^((self willBeMultiline: aBlockNode body) or: [ aBlockNode body statements isEmpty ]) not! !

!EFFormatter methodsFor: 'private - formatting' stamp: ''!
firstSeparatorShouldNotPassLine: aMessageNode
	"predicate that tells if the keyword should be forced to be on the same line."

	^ aMessageNode isKeyword
		and: [ aMessageNode arguments size <= 1
				or: [ self newLineBeforeFirstKeyword not ] ]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodComment
	^ context numberOfNewLinesAfterMethodComment! !

!EFFormatter methodsFor: 'private' stamp: ''!
headOfBlockNotEmpty: aBlockNode

	^ aBlockNode arguments isNotEmpty or: [aBlockNode comments isNotEmpty]! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstCascade
	^ context newLineBeforeFirstCascade! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
codeStream
	^ codeStream! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
periodsAtEndOfMethod
	^ context periodsAtEndOfMethod! !

!EFFormatter methodsFor: 'accessing' stamp: ''!
lineStart
	^ lineStart! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodSignature: anInteger
	DefaultPrettyPrintContext numberOfNewLinesAfterMethodSignature: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideParentheses
	^ DefaultPrettyPrintContext numberOfSpacesInsideParentheses! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesInIndent
	^ DefaultPrettyPrintContext numberOfSpacesInIndent! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsNewLineBeforeFirstKeyword: aBuilder

	(aBuilder setting: #newLineBeforeFirstKeyword)
		label: 'New line before first keyword';
		default: true;
		description: 'To add a new line before the first keyword parameter of a message. This can be useful combined with other settings.

When newLineBeforeFirstKeyword is set to true

1
between: 0 and: 4


When newLineBeforeFirstKeyword is set to false

1 between: 0 and: 4

'! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsCommentCloseToStatement: aBuilder
	
	(aBuilder setting: #formatCommentCloseToStatements)
		label: 'Place comment close to expression';
		default: true;
		description: 'This setting places a comment close to an expression before the separator. 
	
When formatCommentCloseToStatements is set to true
 1+1."We do an addition" 2+2

When formatCommentCloseToStatements is set to false
 1+1"We do an addition". 2+2'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstCascade: aBoolean
	DefaultPrettyPrintContext newLineBeforeFirstCascade: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	
	(aBuilder group: self settingGroup)
		target: self;
		parent: #codeFormatters;
		label: 'Enlumineur Pretty Printer';
		description: 'Settings related to automatic code formatting';
		with: [ self settingsMaxLineLength: aBuilder.
			self settingsCommentCloseToStatement: aBuilder.
			self settingsIndentStyle: aBuilder.
			self settingsNumberOfSpacesInIndent: aBuilder.
			self settingsIndentsForKeywords: aBuilder.
			self settingsKeepBlockInMessage: aBuilder.
			self settingsAlignBlockBrackets: aBuilder.
			self settingsMethodSignatureOnMultipleLines: aBuilder.
			self settingsOneLineMessages: aBuilder.
			self settingsMultiLineMessages: aBuilder.
			self settingsMinimumNewLinesBetweenStatements: aBuilder.
			self settingsNewLineAfterCascade: aBuilder.
			self settingsNewLineBeforeFirstCascade: aBuilder.
			self settingsNewLineBeforeFirstKeyword: aBuilder.
			self settingsNewLinesAfterMethodComment: aBuilder.
			self settingsNewLinesAfterMethodSignature: aBuilder.
			self settingsNewLinesAfterTemporaries: aBuilder.
			self settingsNumberOfArgumentsForMultiLine: aBuilder.
			self settingsPeriodsAtEndOfBlock: aBuilder.
			self settingsPeriodsAtEndOfMethod: aBuilder.
			self settingsRetainBlankLinesBeforeComments: aBuilder.
			self settingsRetainBlankLinesBetweenStatements: aBuilder.
			self settingsSelectorAndArgumentCombinedMaxSize: aBuilder.
			self settingsSpacesAfterCaretSymbolInReturn: aBuilder.
			self settingsSpacesInsideBlocks: aBuilder.
			self settingsSpacesInsideParentheses: aBuilder.
			self settingsSpacesInsideArray: aBuilder.
			self settingsUseBasicCommentFormat: aBuilder]! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
spacesAfterCaretSymbolInReturnString
	^ DefaultPrettyPrintContext spacesAfterCaretSymbolInReturnString! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
spacesInsideBlocksString
	^ DefaultPrettyPrintContext spacesInsideBlocksString! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
retainBlankLinesBeforeComments: aBoolean
	DefaultPrettyPrintContext retainBlankLinesBeforeComments: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsSpacesBeforeDotInDynamicArray: aBuilder

	(aBuilder setting: #numberOfSpacesBeforeDotInDynamicArray)
		label: 'Spaces before separating period in dynamic array';
		description: 'To set the number of spaces before the separating period in dynamic array { 1here. 2})
for example, when set to one space: {1 . 2 . 3}, 

when set to zero space: {1. 2. 3}'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
defaultPrettyPrintContext: aContext 
	DefaultPrettyPrintContext := aContext! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsMaxLineLength: aBuilder

	(aBuilder setting: #maxLineLength)
		label: 'Max line length';
		default: 70;
		description: 'Set the maximum possible length of a line.
For example:
1 + 2 + 3 + 4
	+ 5 + 6
is the result for 14'! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsSpacesInsideBlocks: aBuilder

	(aBuilder setting: #numberOfSpacesInsideBlock)
		label: 'Spaces inside blocks [ here ]';
		default: 1;
		description: 'Set the number of spaces after the opening and before the closing brackets.

For example, when set to 3 spaces we get
[   :i | Transcript show: i   ]'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
methodSignatureOnMultipleLines: aBoolean
	DefaultPrettyPrintContext methodSignatureOnMultipleLines: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfArgumentsForMultiLine: anInteger
	DefaultPrettyPrintContext numberOfArgumentsForMultiLine: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
spacesInsideParenthesesString
	^ DefaultPrettyPrintContext spacesInsideParenthesesString! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesBeforeDotInDynamicArray
	^ DefaultPrettyPrintContext numberOfSpacesBeforeDotInDynamicArray! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
useBasicCommentFormat
	^ DefaultPrettyPrintContext useBasicCommentFormat! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsPeriodsAtEndOfBlock: aBuilder

	(aBuilder setting: #periodsAtEndOfBlock)
		label: 'Period at end of block body';
		default: false;
		description: 'This settings puts a period after the last expression of a block.

Example: when set to true

	1 to:10 do: [:i | i+1.]

'.! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
oneLineMessages
	^ DefaultPrettyPrintContext oneLineMessages! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsMultiLineMessages: aBuilder

	(aBuilder setting: #multiLineMessages)
		label: 'Multi line messages';
		default: '#(#ifTrue:ifFalse: #ifFalse:ifTrue: #ifTrue: #ifFalse: #on:do: #ensure: #ifCurtailed:)';
		description: 'An array containing all the messages that should be written on multiple lines.
		
Example:
aBoolean
	ifTrue: [ 1 ]
	ifFalse: [ 0 ]
is the result if #ifTrue:ifFalse is in the array'! !

!EFFormatter class methodsFor: 'private' stamp: ''!
announceASettingChange
	SystemAnnouncer uniqueInstance announce: EFSettingChanged! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
minimumNewLinesBetweenStatements: anInteger
	DefaultPrettyPrintContext minimumNewLinesBetweenStatements: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsNewLineBeforeFirstCascade: aBuilder

	(aBuilder setting: #newLineBeforeFirstCascade)
		label: 'New line before cascade';
		default: true;
		description: 'To add a new line before the messages participating in a cascade.

When newLineBeforeFirstCascade set to false

OrderedCollection new add: 1;
	add: 2;
	add: 3

When newLineBeforeFirstCascade set to true

OrderedCollection new
	add: 1;
	add: 2;
	add: 3
'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstKeyword
	^ DefaultPrettyPrintContext newLineBeforeFirstKeyword! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideBlock
	^ DefaultPrettyPrintContext numberOfSpacesInsideBlock! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsMethodSignatureOnMultipleLines: aBuilder

	(aBuilder setting: #methodSignatureOnMultipleLines)
		label: 'Method signature on multiple lines';
		default: false;
		description: 'Write a multiline method signature on multiple lines only if set to true.
Pay attention the fact that a method signature is considered multilined depends of the setting selectorAndArgumentCombinedMaxSize).

For example: the method myMethod:foo: will be shown as 

myMethod: arg1
	foo: arg2

is the result of having methodSignatureOnMultipleLines set to true and selectorAndArgumentCombinedMaxSize set to 6'! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsRetainBlankLinesBeforeComments: aBuilder

	(aBuilder setting: #retainBlankLinesBeforeComments)
		label: 'Retain blank lines before comments';
		default: true;
		description: 'Keep blank lines which are before comments. 

For example, when set to true the formatter will not change the following

	|a b|
	a :=1.
	
	"Comment"
	b :=2
'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
periodAtEndOfMethod: aBoolean
	DefaultPrettyPrintContext periodAtEndOfMethod: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
retainBlankLinesBeforeComments
	^ DefaultPrettyPrintContext retainBlankLinesBeforeComments! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
indentString
	^ DefaultPrettyPrintContext indentString! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
formatCommentCloseToStatements
	^ DefaultPrettyPrintContext formatCommentCloseToStatements! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsNewLinesAfterMethodComment: aBuilder

	(aBuilder setting: #numberOfNewLinesAfterMethodComment)
		label: 'New lines after method comment';
		default: 2;
		description: 'Set the number of new lines after the comment of a method.
		
When numberOfNewLinesAfterMethodComment is set to 2

myMethod
	"myComment"

	^ true
'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
lineUpBlockBrackets: aBoolean
	DefaultPrettyPrintContext lineUpBlockBrackets: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsMinimumNewLinesBetweenStatements: aBuilder

	(aBuilder setting: #minimumNewLinesBetweenStatements)
		label: 'Minimum new lines between statements';
		default: 1;
		description: 'Set the number of new lines between each statement. Its value is usually 0 or 1.

The following is obtained by setting minimumNewLinesBetweenStatements to 2.
	1+1.
	
	2+2.
	
	3+3
'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
oneLineMessages: aString
	DefaultPrettyPrintContext oneLineMessages: (self compiler evaluate: aString).
	self announceASettingChange! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsKeepBlockInMessage: aBuilder
	
	(aBuilder setting: #keepBlockInMessage)
		label: 'Keep block in message';
		default: true;
		description: 'Keep the begining of the block on the line of the message

When keepBlockInMessage is true: 
1 to: 4 do: [ :i | 
		Transcript
			show: i;cr]
		

When keepBlockInMessage is false: 		
1 to: 4 do:
	[ :i | 
	Transcript
		show: i;
		cr ]
'! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsIndentsForKeywords: aBuilder 
	
	(aBuilder setting: #indentsForKeywords)
		default: 1;
		label: 'Indents for keywords';
		description: 'Number of indentations before each keyword of a multiline message. 
For example:
aBoolean:
		ifTrue:[^1]
		ifFalse:[^0]
is the result for 2 indents'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideParentheses: anInteger
	DefaultPrettyPrintContext numberOfSpacesInsideParentheses: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
settingGroup
	^ #Enlumineur! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
selectorAndArgumentCombinedMaxSize
	^ DefaultPrettyPrintContext selectorAndArgumentCombinedMaxSize! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodSignature
	^ DefaultPrettyPrintContext numberOfNewLinesAfterMethodSignature! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
periodAtEndOfBlock: aBoolean
	DefaultPrettyPrintContext periodAtEndOfBlock: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsNewLinesAfterTemporaries: aBuilder

	(aBuilder setting: #numberOfNewLinesAfterTemporaries)
		label: 'New lines after temporaries';
		default: 1;
		description: 'To set the number of new lines after the temporaries declaration.

For example setting numberOfNewLinesAfterTemporaries to 2 produces
myMethod
	| a |

	a := 1
'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
formatAsYouReadPolicy
	^ FormatAsYouReadPolicy! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideBlock: anInteger
	DefaultPrettyPrintContext numberOfSpacesInsideBlock: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsNumberOfArgumentsForMultiLine: aBuilder 
	
	(aBuilder setting: #numberOfArgumentsForMultiLine)
		label: 'Number of arguments for multiLine';
		default: 4;		
		description: 'To set the number of argument that a message must have to be considered as a multiline message. 

For example when set to 2 we obtain

1
	between: 0
	and: 5
'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
maxLineLength: anInteger
	DefaultPrettyPrintContext maxLineLength: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
methodSignatureOnMultipleLines
	^ DefaultPrettyPrintContext methodSignatureOnMultipleLines! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsIndentStyle: aBuilder

	(aBuilder pickOne: #indentStyle)
		label: 'Indent Style';
		domainValues:#(#tabulation #space);
		description: 'Set the character used for an indentation, it can be space or tabulation. When a space is used you can decide how many spaces are used using numberOfSpacesInIndent.		
Exemple:
aBoolean
	ifTrue:[^1]
	ifFalse:[^0] is the result for tabulation.'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesAfterCaretSymbolInReturn
	^ DefaultPrettyPrintContext numberOfSpacesAfterCaretSymbolInReturn! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsUseBasicCommentFormat: aBuilder

	(aBuilder setting: #useBasicCommentFormat)
		label: 'Use basic comment format';
		default: true;
		description: 'Leave the comment unchanged and do not resize comment.'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
minimumNewLinesBetweenStatements
	^ DefaultPrettyPrintContext minimumNewLinesBetweenStatements! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsNewLinesAfterMethodSignature: aBuilder

	(aBuilder setting: #numberOfNewLinesAfterMethodSignature)
		label: 'New lines after method signature';
		default: 2;
		description: 'To set the number of new lines directly after the method signature.
When numberOfNewLinesAfterMethodSignature is set to 2 new lines

myMethod: arg

	^ true
'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
keepBlockInMessage: aBoolean
	DefaultPrettyPrintContext keepBlockInMessage: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
maxLineLength
	^ DefaultPrettyPrintContext maxLineLength! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterTemporaries: anInteger
	DefaultPrettyPrintContext numberOfNewLinesAfterTemporaries: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfArgumentsForMultiLine
	^ DefaultPrettyPrintContext numberOfArgumentsForMultiLine! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
indentStyle: aSymbole
	DefaultPrettyPrintContext indentStyle: aSymbole.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesAfterCaretSymbolInReturn: anInteger
	DefaultPrettyPrintContext numberOfSpacesAfterCaretSymbolInReturn: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
indentsForKeywords
	^ DefaultPrettyPrintContext indentsForKeywords! !

!EFFormatter class methodsFor: 'public' stamp: ''!
format: aParseTree 
	^self format: aParseTree withIndents: 0! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
indentsForKeywords: anInteger
	DefaultPrettyPrintContext indentsForKeywords: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
multiLineMessages
	^ DefaultPrettyPrintContext multiLineMessages printString! !

!EFFormatter class methodsFor: 'initialization' stamp: ''!
initialize
	"self initialize"

	FormatAsYouReadPolicy := false.
	DefaultPrettyPrintContext := EFContext new! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideArray: anInteger
	DefaultPrettyPrintContext numberOfSpacesInsideArray: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
formatAsYouReadPolicy: anObject
	FormatAsYouReadPolicy := anObject! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsNumberOfSpacesInIndent:aBuilder

	(aBuilder setting: #numberOfSpacesInIndent)
		label: 'Number of spaces in indent';
		default: 3;
		description: 'Set the number of spaces representing an indentation if indentStyle is set to space.

The following is the result for 5.

aBoolean
     ifTrue:[ 1 ]
     ifFalse:[ 0 ]
'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
lineUpBlockBrackets
	^ DefaultPrettyPrintContext lineUpBlockBrackets! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
useBasicCommentFormat: aBoolean
	DefaultPrettyPrintContext useBasicCommentFormat: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
newLineAfterCascade: aBoolean
	DefaultPrettyPrintContext newLineAfterCascade: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
retainBlankLinesBetweenStatements: aBoolean
	DefaultPrettyPrintContext retainBlankLinesBetweenStatements: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
selectorAndArgumentCombinedMaxSize: anInteger
	DefaultPrettyPrintContext selectorAndArgumentCombinedMaxSize: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsSpacesInsideParentheses: aBuilder

	(aBuilder setting: #numberOfSpacesInsideParentheses)
		label: 'Spaces inside parentheses ( here )';
		default: 0;
		description: 'Sets the number of spaces after the opening and before the closing parentheses.
For example: (   1 + 2   ) is the result for 3 spaces'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
indentStyle
	^ DefaultPrettyPrintContext indentStyle! !

!EFFormatter class methodsFor: 'private' stamp: ''!
isPrettyPrinter
	^ true! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
multiLineMessages: aString
	DefaultPrettyPrintContext multiLineMessages: (self compiler evaluate: aString).
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
formatCommentCloseToStatements: aBoolean
	DefaultPrettyPrintContext formatCommentCloseToStatements: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsAlignBlockBrackets: aBuilder

	(aBuilder setting: #lineUpBlockBrackets)
		label: 'Align block brackets';
		default: false;
		description: 'Place a new line before closing a multiline block.
This gives a C-like syntax in Pharo .

When lineUpBlockBrackets is set to true

1 to: 4 do: [ Transcript
		show: i;
		cr
	]

When lineUpBlockBrackets is set to false
1 to: 4 do: [ Transcript
		show: i;
		cr ]
'! !

!EFFormatter class methodsFor: 'private' stamp: ''!
defaultPrettyPrintContext
	^ DefaultPrettyPrintContext! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
newLineAfterCascade
	^ DefaultPrettyPrintContext newLineAfterCascade! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
retainBlankLinesBetweenStatements
	^ DefaultPrettyPrintContext retainBlankLinesBetweenStatements! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsOneLineMessages: aBuilder

	(aBuilder setting: #oneLineMessages)
		label: 'One line messages';
		default: #(#to: #to:do: #to:by: #to:by:do:);
		description: 'All the messages listed in this setting will be formatted on one single line. 
		
If we include #todo: in the oneLineMessages we get 

1 to: 4 do: [ :i | Transcript show: i ]'! !

!EFFormatter class methodsFor: 'public' stamp: ''!
format: aParseTree withIndents: anInteger 
	^ self new
		indent: anInteger;
		format: aParseTree! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsSpacesAfterCaretSymbolInReturn: aBuilder 

	(aBuilder setting: #numberOfSpacesAfterCaretSymbolInReturn)
		label: 'Spaces following caret symbol in return';
		default: 1;
		description: 'Number of spaces expressed that is put just after the caret (^) of a return expression. 
For example: ^   self is the result for 3 spaces'.! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
keepBlockInMessage
	"Return a boolean for 
		1 to: 4 do: [ :i | 
			
	vs. 
	
		1 to: 4 do: 
			[ :i |"
		
	^ DefaultPrettyPrintContext keepBlockInMessage! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
periodsAtEndOfBlock
	^ DefaultPrettyPrintContext periodsAtEndOfBlock! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodComment: anInteger
	DefaultPrettyPrintContext numberOfNewLinesAfterMethodComment: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesInIndent: anInteger
	DefaultPrettyPrintContext numberOfSpacesInIndent: anInteger.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsPeriodsAtEndOfMethod: aBuilder

	(aBuilder setting: #periodsAtEndOfMethod)
		label: 'Period at end of method';
		default: false;
		description: 'This setting puts a period after the last expression of a method.
		
For example: when set to true

myMethod
	^ true.

'! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsRetainBlankLinesBetweenStatements: aBuilder

	(aBuilder setting: #retainBlankLinesBetweenStatements)
		label: 'Retain blank lines between statements';
		default: true;
		description: 'Keep blank lines which are between statements.
		
For example: when set to true the formatter will not change the following: 
| a b c |
a := 1.


b := 2.

c := a + b
'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstKeyword: aBoolean
	DefaultPrettyPrintContext newLineBeforeFirstKeyword: aBoolean.
	self announceASettingChange! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfSpacesInsideArray
	^ DefaultPrettyPrintContext numberOfSpacesInsideArray! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsSpacesInsideArray: aBuilder

	(aBuilder setting: #numberOfSpacesInsideArray)
		label: 'Spaces inside arrays #( here ) or { there }';
		default: 1;
		description: 'Set the number of spaces after the opening and before the closing symbols of an array.
		
For example, we get the following wehn set to 3 spaces: 
#(   1 2 3   )
{   1. 2. 3.   }
'! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsSelectorAndArgumentCombinedMaxSize: aBuilder

	(aBuilder setting: #selectorAndArgumentCombinedMaxSize)
		label: 'Selector and argument combined in method signature max size';
		default: 40;
		description: 'the maximum length a selector and his argument can be before the message is considered multiline
		(depends of the setting methodSignatureOnMultipleLines 
		which will write the message on multiple lines only if is set to true)
		
Example:
myMethod: argument1
	and: argument2
	is the result if the max size settings is 12 or less
	and methodSignatureOnMultipleLines is set to true'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterTemporaries
	^ DefaultPrettyPrintContext numberOfNewLinesAfterTemporaries! !

!EFFormatter class methodsFor: 'settings' stamp: ''!
settingsNewLineAfterCascade: aBuilder

	(aBuilder setting: #newLineAfterCascade)
		label: 'New line after cascade';
		default: true;
		description: 'To add to a new line after each message in a cascade.

When newLineAfterCascade is set to false.

OrderedCollection new
	add: 1; add: 2; add: 3
	
When newLineAfterCascade is set to true.

OrderedCollection new
	add: 1;
	add: 2;
	add: 3
'! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
numberOfNewLinesAfterMethodComment
	^ DefaultPrettyPrintContext numberOfNewLinesAfterMethodComment! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
newLineBeforeFirstCascade
	^ DefaultPrettyPrintContext newLineBeforeFirstCascade! !

!EFFormatter class methodsFor: 'accessing' stamp: ''!
periodsAtEndOfMethod
	^ DefaultPrettyPrintContext periodsAtEndOfMethod! !

!EFInternalTest methodsFor: 'tests' stamp: ''!
testLineStartIsCorrectAfterIndent
	
	| formatter |
	formatter := EFFormatter new.
	formatter numberOfSpacesInIndent: 5.
	formatter indent: 4.
	self assert: formatter indentString equals:   '	'.	
	formatter newLines: 3.
	self assert: formatter lineStart equals: 3
	"indeed the lineStart in the beginning of the last line."! !

!EFInternalTest methodsFor: 'tests' stamp: ''!
testLineStartIsOkAfterWriteString
	
	| formatter |
	formatter := EFFormatter new.
	self assert: formatter lineStart equals: 0.
	formatter writeString: 'abdef'.
	self assert: formatter lineStart equals: 0.! !

!EFInternalTest methodsFor: 'tests' stamp: ''!
testCurrentLineLengthWithStringContainingCR

	| formatter |
	formatter := EFFormatter new.
	formatter writeString: 'abdef' , String cr , 'ef'.
	self assert: formatter currentLineLength equals: 'ef' size! !

!EFInternalTest methodsFor: 'tests' stamp: ''!
testLineStartIsCorrectAfterNewLines
	
	| formatter |
	formatter := EFFormatter new.
	formatter newLines: 3.
	self assert: formatter lineStart equals: 3! !

!EFInternalTest methodsFor: 'tests' stamp: ''!
testLineStartIsInitializedToZero
	
	| formatter |
	formatter := EFFormatter new.
	self assert: formatter lineStart equals: 0.! !

!EFInternalTest methodsFor: 'tests' stamp: ''!
testLineStartStringContainingCR

	| formatter |
	formatter := EFFormatter new.
	formatter writeString: 'abdef' , String cr , 'ef'.
	self assert: formatter lineStart equals: 'abdef' size + 1! !

!EFInternalTest methodsFor: 'tests' stamp: ''!
testCurrentLineLength
	
	| formatter |
	formatter := EFFormatter new.
	formatter writeString: 'abdef'.
	self assert: formatter currentLineLength equals: 'abdef' size.
	formatter newLines: 2.
	self assert: formatter currentLineLength equals: 0.! !

!EFLiteralArrayExpressionTest methodsFor: 'tests' stamp: ''!
testOneSpaceInsideArray
	| source |
	configurationSelector := #oneSpaceConfiguration.
	source := self formatExpression: '#(1 2 3)'.
	self assert: source equals: '#( 1 2 3 )'! !

!EFLiteralArrayExpressionTest methodsFor: 'tests' stamp: ''!
testBigArrayWithExtraSpaces
	| source |
	configurationSelector := #oneSpaceConfiguration.
	source := self formatExpression:
'#( #( #expr0 #expr1 #expr2 #expr3     #expr4      #expr5 #expr6 #expr7 #expr8     #expr9             #expr10 #expr11 #expr12 #expr13 #expr14 #expr15 #expr16 #expr17 #expr18 #expr19 #expr20 #expr21 #expr22 #expr23 #expr24 ) #(            #expr25 #expr26 #expr27 #expr28 #expr29 #expr30 #expr31 #expr32 #expr33 #expr34 #expr35 #expr36 #expr37 #expr38 #expr39 #expr40 #expr41 #expr42 #expr43 #expr44 #expr45 #expr46 #expr47 #expr48 #expr49 ) )'.
	
	self assert: source equals:
'#( #( #expr0 #expr1 #expr2 #expr3 #expr4 #expr5 #expr6 #expr7 #expr8
      #expr9 #expr10 #expr11 #expr12 #expr13 #expr14 #expr15 #expr16
      #expr17 #expr18 #expr19 #expr20 #expr21 #expr22 #expr23 #expr24 )
   #( #expr25 #expr26 #expr27 #expr28 #expr29 #expr30 #expr31 #expr32
      #expr33 #expr34 #expr35 #expr36 #expr37 #expr38 #expr39 #expr40
      #expr41 #expr42 #expr43 #expr44 #expr45 #expr46 #expr47 #expr48
      #expr49 ) )'! !

!EFLiteralArrayExpressionTest methodsFor: 'configurations' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:false;
		numberOfSpacesInsideArray: 0;
		indentStyle: #tabulation;
		indentExtraSpaces: 0;
		maxLineLength: 70! !

!EFLiteralArrayExpressionTest methodsFor: 'tests' stamp: ''!
testNoExtraSpaceArroundParenthesis
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '#(  1 2 3    )  '.
	self assert: source equals: '#(1 2 3)'! !

!EFLiteralArrayExpressionTest methodsFor: 'tests' stamp: ''!
testNoExtraSpaceBetweenValue2
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '#[1     2       3]'.
	self assert: source equals: '#[1 2 3]'! !

!EFLiteralArrayExpressionTest methodsFor: 'tests' stamp: ''!
testTwoSpacesInsideArray
	| source |
	configurationSelector := #twoSpacesConfiguration.
	source := self formatExpression: '#(1 2 3)'.
	self assert: source equals: '#(  1 2 3  )'! !

!EFLiteralArrayExpressionTest methodsFor: 'configurations' stamp: ''!
oneSpaceConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:false;
		numberOfSpacesInsideArray: 1;
		indentStyle: #tabulation;
		indentExtraSpaces: 0;
		maxLineLength: 70! !

!EFLiteralArrayExpressionTest methodsFor: 'tests' stamp: ''!
testByteArrayParenthesis
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '#[1 2 3]'.
	self assert: source equals: '#[1 2 3]'! !

!EFLiteralArrayExpressionTest methodsFor: 'configurations' stamp: ''!
twoSpacesConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:false;
		numberOfSpacesInsideArray: 2;
		indentStyle: #tabulation;
		indentExtraSpaces: 0;
		maxLineLength: 70! !

!EFLiteralArrayExpressionTest methodsFor: 'tests' stamp: ''!
testNoExtraSpaceArroundParenthesis2
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '#[  1 2 3    ]  '.
	self assert: source equals: '#[1 2 3]'! !

!EFLiteralArrayExpressionTest methodsFor: 'tests' stamp: ''!
testNoExtraSpaceBetweenValue
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '#(1     2       3)'.
	self assert: source equals: '#(1 2 3)'! !

!EFLiteralArrayExpressionTest methodsFor: 'tests' stamp: ''!
testBigArray
	| source |
	configurationSelector := #oneSpaceConfiguration.
	source := self formatExpression:
'#( #( #expr0 #expr1 #expr2 #expr3 #expr4 #expr5 #expr6 #expr7 #expr8 #expr9 #expr10 #expr11 #expr12 #expr13 #expr14 #expr15 #expr16 #expr17 #expr18 #expr19 #expr20 #expr21 #expr22 #expr23 #expr24 ) #( #expr25 #expr26 #expr27 #expr28 #expr29 #expr30 #expr31 #expr32 #expr33 #expr34 #expr35 #expr36 #expr37 #expr38 #expr39 #expr40 #expr41 #expr42 #expr43 #expr44 #expr45 #expr46 #expr47 #expr48 #expr49 ) )'.
	
	self assert: source equals:
'#( #( #expr0 #expr1 #expr2 #expr3 #expr4 #expr5 #expr6 #expr7 #expr8
      #expr9 #expr10 #expr11 #expr12 #expr13 #expr14 #expr15 #expr16
      #expr17 #expr18 #expr19 #expr20 #expr21 #expr22 #expr23 #expr24 )
   #( #expr25 #expr26 #expr27 #expr28 #expr29 #expr30 #expr31 #expr32
      #expr33 #expr34 #expr35 #expr36 #expr37 #expr38 #expr39 #expr40
      #expr41 #expr42 #expr43 #expr44 #expr45 #expr46 #expr47 #expr48
      #expr49 ) )'! !

!EFLiteralValueExpressionTest methodsFor: 'tests' stamp: ''!
testNumbers
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: ' 3.141592653589793 '.
	self assert: source equals: '3.141592653589793'! !

!EFLiteralValueExpressionTest methodsFor: 'tests' stamp: ''!
testString
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: ' ''Pharo'' '.
	self assert: source equals: '''Pharo'''! !

!EFLiteralValueExpressionTest methodsFor: 'configurations' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements: false! !

!EFLiteralValueExpressionTest methodsFor: 'tests' stamp: ''!
testNotLitteral

	| expr source |
	expr := RBLiteralValueNode value: Transcript. 
	configurationSelector := #basicConfiguration.
	source := self formatter format: expr.
	self assert: source equals: '''<an unprintable nonliteral value>'''! !

!EFLiteralValueExpressionTest methodsFor: 'tests' stamp: ''!
testSpaces
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '2'.
	self assert: source equals: '2'! !

!EFLiteralValueExpressionTest methodsFor: 'tests' stamp: ''!
testNoExtraSpaces
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '    2     '.
	self assert: source equals: '2'! !

!EFLiteralValueExpressionTest methodsFor: 'tests' stamp: ''!
testTrue
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: ' true '.
	self assert: source equals: 'true'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
blockAndCascadeInMessageConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 1;
		maxLineLength: 70;
		newLineBeforeFirstKeyword: false;
		keepBlockInMessage: true;
		numberOfSpacesInsideBlock: 1;
		numberOfSpacesAfterCaretSymbolInReturn: 1;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentExtraSpaces:0;
		newLineBeforeFirstCascade: true;
		numberOfSpacesInsideParentheses: 0 ;
		newLineAfterCascade: true! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNoTraditionalBinaryPrecedence2
	| source |
	configurationSelector := #noTraditionalBinaryPrecedenceConfiguration.
	source := self formatExpression: '(2 + 3) * 4'.
	self assert: source equals: '2 + 3 * 4'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
oneArgumentPerLineConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 1;
		indentsForKeywords: 0;
		maxLineLength: 50;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: false;
		indentExtraSpaces: 0;
		numberOfSpacesInsideParentheses: 0! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testKeepBlockInMessage
	| source |
	configurationSelector := #keepBlockInMessageConfiguration.
	source := self
		formatExpression:
			'aBoolean ifTrue:[ :i | i := i factorial. Transcript show:i ]'.
	self
		assert: source
		equals:
'aBoolean ifTrue: [ :i | 
	i := i factorial.
	Transcript show: i ]'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNoTraditionalBinaryPrecedence3
	| source |
	configurationSelector := #noTraditionalBinaryPrecedenceConfiguration.
	source := self formatExpression: '2+3*4+5 * 2'.
	self assert: source equals: '2 + 3 * 4 + 5 * 2'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLineBetweenVariableAndIfTrue
	| source |
	configurationSelector := #blockInMessageConfiguration.
	source := self formatExpression: 'x
		ifTrue: [ 
			  aBitBlt copyBitsColor: foreColorVal
				  alpha: foreColorAlpha
				  gammaTable: gammaTable
				  ungammaTable: gammaInverseTable ]'.
	self assert: source equals: 
'x ifTrue: [ 
	aBitBlt
		copyBitsColor: foreColorVal
		alpha: foreColorAlpha
		gammaTable: gammaTable
		ungammaTable: gammaInverseTable ]'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testMultiLineMessage
	| source |
	configurationSelector := #multiLineMessageConfiguration.
	source := self formatExpression: 'foo multi:1 line:2 '.
	self
		assert: source
		equals:
'foo
	multi: 1
	line: 2'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
formatStatementsWithCommentsConfiguration

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:true;
		multiLineMessages:Array new;
		oneLineMessages:Array new;
		numberOfArgumentsForMultiLine:10;
		indentsForKeywords: 0;
		maxLineLength: 50;
		newLineBeforeFirstKeyword:false;
		keepBlockInMessage:false! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
simpleConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 0;
		maxLineLength: 50;
		newLineBeforeFirstKeyword: false;
		keepBlockInMessage: false;
		numberOfSpacesInsideParentheses: 0;
		indentExtraSpaces: 0! !

!EFMessageExpressionTest methodsFor: 'tests - block arg' stamp: ''!
testBlockParameterWhenTheLineWillBeTooLong2
	| source |
	configurationSelector := #blockInMessageTooLongConfiguration.
	source := self formatExpression: 'aMessage take:[ :iiiiiiiiiiiiiii | i factorial]'.
	self
		assert: source
		equals:
'aMessage take: [ 
	:iiiiiiiiiiiiiii | 
	i factorial ]'! !

!EFMessageExpressionTest methodsFor: 'tests - binary' stamp: ''!
testBinaryOneArgumentPerLine2
	| source |
	configurationSelector := #oneArgumentPerLineConfiguration.
	source := self formatExpression: '(1+2)*3'.
	self
		assert: source
		equals:
			'1
+ 2
* 3'! !

!EFMessageExpressionTest methodsFor: 'tests - binary' stamp: ''!
testBinaryNoExtraSpacesBefore
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '   1+2'.
	self assert: source equals: '1 + 2'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOneArgumentPerLine
	| source |
	configurationSelector := #oneArgumentPerLineConfiguration.
	source := self formatExpression: '2      between:     1   and:    3'.
	self
		assert: source
		equals:
'2
between: 1
and: 3'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine12
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression:
'foo
	bar3: 5
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar3: 5'.
	self assert: source equals:
'foo
	bar3: 5
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar3: 5'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
newLineBeforeFirstKeywordConfiguration

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		multiLineMessages:Array new;
		oneLineMessages:Array new;
		numberOfArgumentsForMultiLine:10;
		indentsForKeywords: 0;
		maxLineLength: 50;
		newLineBeforeFirstKeyword:true;
		keepBlockInMessage:false;
		indentExtraSpaces:0! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnTheSameLine2
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression: '1 to: 100 by: 2 do: [ :i | Transcript show: i]'.
	self assert: source equals: '1 to: 100 by: 2 do: [ :i | Transcript show: i ]'! !

!EFMessageExpressionTest methodsFor: 'tests - unary' stamp: ''!
testUnaryNoExtraSpacesAfter2
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'Transcript cr cr cr       '.
	self assert: source equals: 'Transcript cr cr cr'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordNoExtraSpacesAfter
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '2 between: 1 and: 3          '.
	self assert: source equals: '2 between: 1 and: 3'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
keepBlockInMessageConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 1;
		maxLineLength: 70;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: true;
		numberOfSpacesInsideBlock: 1;
		numberOfSpacesAfterCaretSymbolInReturn: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentExtraSpaces:0! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
blockInMessageTooLongConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 1;
		maxLineLength: 20;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: true;
		numberOfSpacesInsideBlock: 1;
		numberOfSpacesAfterCaretSymbolInReturn: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentExtraSpaces: 0! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordFormatReceiver
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '2 between: 4-2 and: 3     factorial'.
	self assert: source equals: '2 between: 4 - 2 and: 3 factorial'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
oneIdentsForKeyWordConfiguration

	^ self contextClass new
		newLineBeforeFirstKeyword: true;
		numberOfArgumentsForMultiLine: 1;
		indentsForKeywords: 1! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testKeepBlockInMessageMutlilineSpace
	| source |
	configurationSelector := #keepBlockInMessageConfiguration.
	source := self
		formatExpression:
			'aBoolean ifTrue:[ 12 factorial. 12 factorial. 3
	factorial]'.
	self
		assert: source
		equals:
'aBoolean ifTrue: [ 
	12 factorial.
	12 factorial.
	3 factorial ]'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testOneLineMessage
	| source |
	configurationSelector := #oneLineMessageConfiguration.
	source := self formatExpression: 'foo one:1 line:2 message:3'.
	self assert: source equals: 'foo one: 1 line: 2 message: 3'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testSpacesInsideParentheses
	| source |
	configurationSelector := #twoSpacesInsideParenthesesConfiguration.
	source := self formatExpression: '1+(2*3)'.
	self assert: source equals: '1 + (  2 * 3  )'! !

!EFMessageExpressionTest methodsFor: 'tests - unary' stamp: ''!
testUnaryMessageComments
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '1 factorial "aComment"'.
	self assert: source equals: '1 factorial "aComment"'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testDontKeepBlockInMessage
	| source |
	configurationSelector := #dontKeepBlockInMessageConfiguration.
	source := self
		formatExpression:
			'aBoolean ifTrue:[ :i | i := i factorial. Transcript show:i ]'.
	self
		assert: source
		equals:
'aBoolean ifTrue:
	[ :i | 
	i := i factorial.
	Transcript show: i ]'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
extraIndentWithThreeSpacesInsideParenthesesConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 0;
		maxLineLength: 70;
		newLineBeforeFirstKeyword: false;
		keepBlockInMessage: true;
		numberOfSpacesInsideBlock: 1;
		numberOfSpacesAfterCaretSymbolInReturn: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentExtraSpaces:0;
		newLineBeforeFirstCascade: true;
		numberOfSpacesInsideParentheses: 3 ;
		newLineAfterCascade: true! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLineForBeginingOfATooLongArgument
	| source |
	configurationSelector := #basicConfiguration.
	source := self
		formatExpression: 'self parseMethod: 	''a
b'''.
	self assert: source equals: 'self parseMethod: ''a
b'''! !

!EFMessageExpressionTest methodsFor: 'tests - unary' stamp: ''!
testUnaryFormatReceiver
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'a:=1 factorial'.
	self assert: source equals: 'a := 1 factorial'! !

!EFMessageExpressionTest methodsFor: 'tests - block arg' stamp: ''!
testBlockParameterOnTheMethodLineWhenMultiline
	| source |
	configurationSelector := #keepBlockInMessageConfiguration.
	source := self
		formatExpression: '1 to: 10 do:[ :i | Transcript show:i. Transcript cr. Transcript cr]'.
	self
		assert: source
		equals:
'1 to: 10 do: [ :i | 
	Transcript show: i.
	Transcript cr.
	Transcript cr ]'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineBeforeFirstKeywordDoesntAffectBinary
	| source |
	configurationSelector := #newLineBeforeFirstKeywordConfiguration.
	source := self formatExpression: '1+1'.
	self
		assert: source
		equals:'1 + 1'! !

!EFMessageExpressionTest methodsFor: 'tests - binary' stamp: ''!
testBinaryNoExtraSpacesBetween
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '1     +     2'.
	self assert: source equals: '1 + 2'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordNoExtraSpacesBefore
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '   2 between: 1 and: 3'.
	self assert: source equals: '2 between: 1 and: 3'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression: '1 to: 100 by: 2 do: [ :i | transcript show: i;cr; cr]'.
	self assert: source equals:
'1 to: 100 by: 2 do: [ :i | 
	transcript
		show: i;
		cr;
		cr ]'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineBeforeStatementsWhenMultilineBlock
	| source |
	configurationSelector := #keepBlockInMessageConfiguration.
	source := self
		formatExpression:
			'x = 0 ifFalse: [ tan := y asFloat / x asFloat.
	theta := tan arcCos ]'.
	self
		assert: source
		equals:
'x = 0 ifFalse: [ 
	tan := y asFloat / x asFloat.
	theta := tan arcCos ]'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
twoSpacesInsideParenthesesConfiguration

	^ self contextClass basicNew
		numberOfSpacesInsideParentheses: 2;
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		multiLineMessages:Array new;
		oneLineMessages:Array new;
		numberOfArgumentsForMultiLine:10;
		indentsForKeywords: 0;
		maxLineLength: 50;
		newLineBeforeFirstKeyword:false;
		keepBlockInMessage:false;
		indentExtraSpaces: 0! !

!EFMessageExpressionTest methodsFor: 'tests - binary' stamp: ''!
testBinaryFormatParameter
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '1 + (3     factorial)'.
	self assert: source equals: '1 + 3 factorial'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		multiLineMessages:Array new;
		oneLineMessages:Array new;
		numberOfArgumentsForMultiLine:10;
		indentsForKeywords: 0;
		maxLineLength: 70;
		newLineBeforeFirstKeyword:false;
		keepBlockInMessage:false;
		indentExtraSpaces: 0! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
multiLineMessageConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: #(#multi:line:);
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 1;
		maxLineLength: 50;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: false;
		indentExtraSpaces:0! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
oneLineMessageConfiguration

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		multiLineMessages:Array new;
		oneLineMessages:#(#one:line:message:);
		numberOfArgumentsForMultiLine:2;
		indentsForKeywords: 0;
		maxLineLength: 50;
		newLineBeforeFirstKeyword:false;
		keepBlockInMessage:false;
		indentExtraSpaces: 0! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine10
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression:
'foo
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar3: 5.'.
	self assert: source equals:
'foo
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar3: 5'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
twoIdentsForKeyWordConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 1;
		indentsForKeywords: 2;
		maxLineLength: 50;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: false;
		indentExtraSpaces:0! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNoTraditionalBinaryPrecedence
	| source |
	configurationSelector := #noTraditionalBinaryPrecedenceConfiguration.
	source := self formatExpression: '2+3*4'.
	self assert: source equals: '2 + 3 * 4'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testKeepBlockInMessageMutlilineNewLine
	| source |
	configurationSelector := #keepBlockInMessageConfiguration.
	source := self
		formatExpression: 'aBoolean  ifTrue:[ Transcript cr. Transcript cr. Transcript cr]'.
	self
		assert: source
		equals:
'aBoolean ifTrue: [ 
	Transcript cr.
	Transcript cr.
	Transcript cr ]'! !

!EFMessageExpressionTest methodsFor: 'tests - unary' stamp: ''!
testUnaryNoExtraSpacesBefore
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '   Transcript cr'.
	self assert: source equals: 'Transcript cr'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testTraditionalBinaryPrecedence
	| source |
	configurationSelector := #simpleConfiguration.
	source := self formatExpression: '2+3*4'.
	self assert: source equals: '2 + 3 * 4'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLineForBeginingOfATooLongArgument2
	| source |
	configurationSelector := #basicConfiguration.
	source := self
		formatExpression: 'self
		parseMethod:
			''foo: abd bar: cde  
^ abd + cde'''.
	self assert: source equals:
'self parseMethod: ''foo: abd bar: cde  
^ abd + cde'''! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testIndentsForKeywords2
	| source |
	configurationSelector := #twoIdentsForKeyWordConfiguration.
	source := self formatExpression: 'a k1:1 k2:2 k3:3'.
	self
		assert: source
		equals:
			'a
		k1: 1
		k2: 2
		k3: 3'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testKeepBlockInMessageNotMutlilineNewLine
	| source |
	configurationSelector := #littleMaxLineLengthConfiguration.
	source := self
		formatExpression: 'aBoolean ifTrue:[LongLongLongExpression]'.
	self
		assert: source
		equals:
			'aBoolean ifTrue: [ 
	LongLongLongExpression ]'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineBeforeFirstKeyword
	| source |
	configurationSelector := #newLineBeforeFirstKeywordConfiguration.
	source := self formatExpression: '2 between: 1 and: 3'.
	self
		assert: source
		equals:
			'2 between: 1 and: 3'! !

!EFMessageExpressionTest methodsFor: 'tests - unary' stamp: ''!
testUnaryNoExtraSpacesBetween
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'Transcript        cr'.
	self assert: source equals: 'Transcript cr'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testTraditionalBinaryPrecedence3
	| source |
	configurationSelector := #simpleConfiguration.
	source := self formatExpression: '2+3*4+5 * 2'.
	self assert: source equals: '2 + 3 * 4 + 5 * 2'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
blockAndParenthesesInMessageConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 1;
		maxLineLength: 70;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: true;
		numberOfSpacesInsideBlock: 1;
		numberOfSpacesAfterCaretSymbolInReturn: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentExtraSpaces:0;
		newLineBeforeFirstCascade: true;
		numberOfSpacesInsideParentheses: 1 ;
		newLineAfterCascade: true! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine6
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression:
'foo 
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar2: [ 
		1 + 1.
		2 + 2 ]
	bar3: 5'.
	self assert: source equals:
'foo
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar2: [ 
		1 + 1.
		2 + 2 ]
	bar3: 5'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine7
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression:
'foo 
	bar3: 5
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar2: [ 
		1 + 1.
		2 + 2 ]'.
	self assert: source equals:
'foo
	bar3: 5
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar2: [ 
		1 + 1.
		2 + 2 ]'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNoIndentsForKeywords
	| source |
	configurationSelector := #noIdentsForKeyWordConfiguration.
	source := self formatExpression: 'a k1:1 k2:2 k3:3'.
	self
		assert: source
		equals:
			'a
k1: 1
k2: 2
k3: 3'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine8
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression:
'foo
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar3: 5
	bar2: [ 
		1 + 1.
		2 + 2 ]'.
	self assert: source equals:
'foo
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar3: 5
	bar2: [ 
		1 + 1.
		2 + 2 ]'.! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testTooLongArgument
	| source |
	configurationSelector := #shortMaxLineLengthConfiguration.
	source := self formatExpression: 'foo message: TooLongArgument'.
	self
		assert: source
		equals:
'foo message:
	TooLongArgument'! !

!EFMessageExpressionTest methodsFor: 'tests - binary' stamp: ''!
testBinaryNoExtraSpacesAfter
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '1+2          '.
	self assert: source equals: '1 + 2'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordFormatReceiver2
	| source |
	configurationSelector := #parentheseConfiguration.
	source := self formatExpression: '(2 between: 4-2 and: 3)     factorial'.
	self assert: source equals: '(2 between: 4 - 2 and: 3) factorial'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine4
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression: 'aBoolean ifTrue:[ tmp := tmp + a. ^ tmp] ifFalse:[ tmp := tmp + a. ^tmp]'.
	self assert: source equals:
'aBoolean
	ifTrue: [ 
		tmp := tmp + a.
		^ tmp ]
	ifFalse: [ 
		tmp := tmp + a.
		^ tmp ]'! !

!EFMessageExpressionTest methodsFor: 'tests - binary' stamp: ''!
testBinaryFormatReceiver
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'a:=''abc'' + 2'.
	self assert: source equals: 'a := ''abc'' + 2'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineWhenSelectorAndBeginingOfParametersWillBeTooLong
	| source |
	configurationSelector := #blockAndParenthesesInMessageConfiguration.
	source := self formatExpression:
'(newLineBetweenArguments and: [ aMessageNode isKeyword ]) ifTrue: [ self
	indentsForKeywords ]
	ifFalse: [ 0 ]'.
	self assert: source equals:
'( newLineBetweenArguments and: [ aMessageNode isKeyword ] )
	ifTrue: [ self indentsForKeywords ]
	ifFalse: [ 0 ]'.! !

!EFMessageExpressionTest methodsFor: 'tests - unary' stamp: ''!
testUnaryNoExtraSpacesAfter
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'Transcript cr        '.
	self assert: source equals: 'Transcript cr'! !

!EFMessageExpressionTest methodsFor: 'tests - binary' stamp: ''!
testBinaryMessageFormatCommentsWithStatement
	| source |
	self flag: #toCheck. "Why would we lose the comment?"
	configurationSelector := #formatStatementsWithCommentsConfiguration.
	source := self formatExpression: '1 + 1 "aComment"'.
	self assert: source equals: '1 + 1'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordComments
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '1 between: 2"firstComment" and: 3 "secondComment"'.
	self assert: source equals: '1 between: 2 "firstComment" and: 3 "secondComment"'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine9
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression:
'foo
	bar3: 5
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar2: [ 
		1 + 1.
		2 + 2 ]
	bar3: 5'.
	self assert: source equals:
'foo
	bar3: 5
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar2: [ 
		1 + 1.
		2 + 2 ]
	bar3: 5'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine13
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression:
'foo bar3: 5 bar3: 5 bar2: [ 
	1 + 1.
	2 + 2 ]'.
	self assert: source equals:
'foo bar3: 5 bar3: 5 bar2: [ 
	1 + 1.
	2 + 2 ]'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordFormatReceiver3
	| source |
	configurationSelector := #parentheseConfiguration.
	source := self formatExpression: '(d at: 2)factorial'.
	self assert: source equals: '(d at: 2) factorial'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
noIdentsForKeyWordConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		maxLineLength: 50;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: false;
		numberOfArgumentsForMultiLine: 1;
		indentsForKeywords: 0;
		indentExtraSpaces:0! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnTheSameLine
	| source |
	configurationSelector := #blockInMessageConfiguration.
	source := self formatExpression: '1 to: 100 do: [ :i | Transcript show: i ]'.
	self assert: source equals: '1 to: 100 do: [ :i | Transcript show: i ]'! !

!EFMessageExpressionTest methodsFor: 'tests - unary' stamp: ''!
testUnaryFormatReceiver2
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'a:=1 factorial foo bar'.
	self assert: source equals: 'a := 1 factorial foo bar'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testTooLongLineWithArgument
	| source |
	configurationSelector := #shortMaxLineLengthConfiguration.
	source := self formatExpression: 'foo message: argument'.
	self
		assert: source
		equals:
'foo message:
	argument'! !

!EFMessageExpressionTest methodsFor: 'tests - unary' stamp: ''!
testUnaryNoExtraSpacesBetween2
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'Transcript        cr cr       cr     cr'.
	self assert: source equals: 'Transcript cr cr cr cr'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine2
	| source |
	configurationSelector := #ifTrueIfFalseMutlilineMessageConfiguration.
	source := self formatExpression: 'aBoolean ifTrue:[ ^ 1] ifFalse:[ tmp := tmp + a. ^tmp]'.
	self assert: source equals:
'aBoolean
	ifTrue: [ ^1 ]
	ifFalse: [ 
		tmp := tmp + a.
		^tmp ]'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordFormatReceiverAssignment
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'a:=''abc'' at: 2'.
	self assert: source equals: 'a := ''abc'' at: 2'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
littleMaxLineLengthConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 1;
		maxLineLength: 20;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: true;
		numberOfSpacesInsideBlock: 1;
		numberOfSpacesAfterCaretSymbolInReturn: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentExtraSpaces:0! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine3
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression: 'aBoolean ifTrue:[ tmp := tmp + a. ^ tmp] ifFalse:[ ^ 0 ]'.
	self assert: source equals:
'aBoolean
	ifTrue: [ 
		tmp := tmp + a.
		^ tmp ]
	ifFalse: [ ^ 0 ]'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testDontKeepBlockInMessage2
	| source |
	configurationSelector := #dontKeepBlockInMessageConfiguration.
	source := self
		formatExpression:
			'aBoolean ifTrue:[ :i | i ]'.
	self
		assert: source
		equals:
'aBoolean ifTrue: [ :i | i ]'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordNoExtraSpacesBetween
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '2      between:     1   and:    3'.
	self assert: source equals: '2 between: 1 and: 3'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine11
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression:
'foo bar3: 5 bar2: [ 
	1 + 1.
	2 + 2 ]'.
	self assert: source equals:
'foo bar3: 5 bar2: [ 
	1 + 1.
	2 + 2 ]'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testExtraIndentInParentheses
	| source |
	configurationSelector := #blockAndParenthesesInMessageConfiguration.
	source := self formatExpression: '( [ :i | 	i factorial; +3 ] value: 15 )*3'.
	self assert: source equals:
'( [ :i | 
  i
	  factorial;
	  + 3 ] value: 15 ) * 3'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testTraditionalBinaryPrecedence2
	| source |
	configurationSelector := #simpleConfiguration.
	source := self formatExpression: '2*3+4'.
	self assert: source equals: '2 * 3 + 4'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
ifTrueIfFalseMutlilineMessageConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages:#(#ifTrue:ifFalse:);
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 1;
		maxLineLength: 70;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: true;
		numberOfSpacesInsideBlock: 1;
		numberOfSpacesAfterCaretSymbolInReturn: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentExtraSpaces:0;
		newLineBeforeFirstCascade: true;
		numberOfSpacesInsideParentheses: 1 ;
		newLineAfterCascade: true! !

!EFMessageExpressionTest methodsFor: 'tests - block arg' stamp: ''!
testBlockParameterWhenTheLineWillNotBeTooLong
	| source |
	configurationSelector := #blockInMessageConfiguration.
	source := self formatExpression: 'aMessage take:[ :i | i]'.
	self assert: source equals: 'aMessage take: [ :i | i ]'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testKeepBlockInMessageNotMultilineSpace
	| source |
	configurationSelector := #keepBlockInMessageConfiguration.
	source := self formatExpression: 'aBoolean ifTrue:[^1]'.
	self
		assert: source
		equals:
			'aBoolean ifTrue: [ ^1 ]'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordCommentsFormatCommentsWithStatement
	| source |
	self flag: #toCheck. "why no more comment." 
	configurationSelector := #formatStatementsWithCommentsConfiguration.
	source := self formatExpression: '1 between: 2"firstComment" and: 3 "secondComment"'.
	self assert: source equals: '1 between: 2 and: 3'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnTheSameLine3
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression: 'aBoolean ifTrue:[ ^ 1] ifFalse:[ ^ 0 ]'.
	self assert: source equals: 'aBoolean ifTrue: [ ^ 1 ] ifFalse: [ ^ 0 ]'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
shortMaxLineLengthConfiguration

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		multiLineMessages:Array new;
		oneLineMessages:Array new;
		numberOfArgumentsForMultiLine:10;
		indentsForKeywords: 1;
		maxLineLength: 13;
		newLineBeforeFirstKeyword:false;
		keepBlockInMessage:false;
		indentExtraSpaces:0! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testIndentsForKeywords1
	| source |
	configurationSelector := #oneIdentsForKeyWordConfiguration.
	source := self formatExpression: 'a k1:1 k2:2 k3:3'.
	self
		assert: source
		equals:
			'a
	k1: 1
	k2: 2
	k3: 3'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine14
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression:
'foo
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar3: 5 
	bar3: 5'.
	self assert: source equals:
'foo
	bar: [ 
		1 + 2.
		2 + 2 ]
	bar3: 5
	bar3: 5'.! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testDontKeepBlockInMessage3
	| source |
	configurationSelector := #dontKeepBlockInMessageConfiguration.
	source := self
		formatExpression:
			'aBoolean ifTrue:[ Transcript cr. Transcript cr ]'.
	self
		assert: source
		equals:
'aBoolean ifTrue:
	[ Transcript cr.
	Transcript cr ]'! !

!EFMessageExpressionTest methodsFor: 'tests - unary' stamp: ''!
testUnaryTooLongArgument
	| source |
	configurationSelector := #shortMaxLineLengthConfiguration.
	source := self formatExpression: 'foo messageTooLongUnaryyyy'.
	self
		assert: source
		equals:
'foo
	messageTooLongUnaryyyy'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordFormatParameter
	| source |
	configurationSelector := #basicConfiguration.
	source := self
		formatExpression: '3 between:2      factorial and: 4+5'.
	self assert: source equals: '3 between: 2 factorial and: 4 + 5'! !

!EFMessageExpressionTest methodsFor: 'tests - unary' stamp: ''!
testUnaryMessageFormatCommentsWithStatement
	| source |
	self flag: #toCheck. "why do we lose this comment"
	configurationSelector := #formatStatementsWithCommentsConfiguration.
	source := self formatExpression: '1 factorial "aComment"'.
	self assert: source equals: '1 factorial'! !

!EFMessageExpressionTest methodsFor: 'tests - block arg' stamp: ''!
testBlockParameterWhenTheLineWillBeTooLong
	| source |
	configurationSelector := #blockInMessageTooLongConfiguration.
	source := self formatExpression: 'aMessage take:[ :i | i factorial]'.
	self
		assert: source
		equals: 
'aMessage take: [ :i | 
	i factorial ]'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
parentheseConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 0;
		maxLineLength: 70;
		newLineBeforeFirstKeyword: false;
		keepBlockInMessage: false;
		indentExtraSpaces: 0;
		numberOfSpacesInsideParentheses: 0! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine5
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression: 'aBoolean ifTrue:[ ^ 1] ifFalse:[ tmp := tmp + a. ^tmp]'.
	self assert: source equals:
'aBoolean ifTrue: [ ^ 1 ] ifFalse: [ 
	tmp := tmp + a.
	^ tmp ]'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
blockInMessageConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 1;
		maxLineLength: 70;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: true;
		numberOfSpacesInsideBlock: 1;
		numberOfSpacesAfterCaretSymbolInReturn: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentExtraSpaces:0! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
noTraditionalBinaryPrecedenceConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 0;
		maxLineLength: 50;
		newLineBeforeFirstKeyword: false;
		keepBlockInMessage: false;
		numberOfSpacesInsideParentheses: 0;
		indentExtraSpaces: 0! !

!EFMessageExpressionTest methodsFor: 'tests - binary' stamp: ''!
testBinaryMessageComments
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '1 + 1 "aComment"'.
	self assert: source equals: '1 + 1 "aComment"'! !

!EFMessageExpressionTest methodsFor: 'configurations' stamp: ''!
dontKeepBlockInMessageConfiguration
	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 10;
		indentsForKeywords: 1;
		maxLineLength: 70;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: false;
		numberOfSpacesInsideBlock: 1;
		numberOfSpacesAfterCaretSymbolInReturn: 0;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		lineUpBlockBrackets: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		indentExtraSpaces:0! !

!EFMessageExpressionTest methodsFor: 'tests - binary' stamp: ''!
testBinaryOneArgumentPerLine
	| source |
	configurationSelector := #oneArgumentPerLineConfiguration.
	source := self formatExpression: '1+2'.
	self
		assert: source
		equals:
'1
+ 2'! !

!EFMessageExpressionTest methodsFor: 'tests' stamp: ''!
testExtraIndentInParenthesesWhenThreeSpacesInsideParentheses
	| source |
	configurationSelector := #extraIndentWithThreeSpacesInsideParenthesesConfiguration.
	source := self formatExpression:'( [ :i | 	i factorial; +3 ] value: 15 )*3'.
	self assert: source equals:
'(   [ :i | 
    i
	    factorial;
	    + 3 ] value: 15   ) * 3'! !

!EFMessageExpressionTest methodsFor: 'tests - keyword' stamp: ''!
testKeywordOnMultipleLine15
	| source |
	configurationSelector := #blockAndCascadeInMessageConfiguration.
	source := self formatExpression:
'self
		indent:
			(self do:[1. 2])
		around: [ 1. 2 ]'.
	self assert: source equals:
'self
	indent: (self do: [ 
			 1.
			 2 ])
	around: [ 
		1.
		2 ]'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testNewLinesAfterComment
	| expr source |
	expr := RBParser parseMethod: 'aMethode "aComment"'.
	configurationSelector := #oneNewLineAfterCommentConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	"aComment"

	'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
basicCommentFormatConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		useBasicCommentFormat: true;
		numberOfNewLinesAfterMethodSignature: 1;
		numberOfNewLinesAfterMethodComment: 1;
		indentExtraSpaces: 0! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testPragma
	| expr source |
	expr := RBParser parseMethod: 'aMethode <pragma>'.
	configurationSelector := #notBasicCommentFormatConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	<pragma>
	'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testBasic
	| expr source |
	expr := RBParser parseMethod: 'aMethod <pragma> "aComment" body'.
	configurationSelector := #basicConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethod
	"aComment"
	<pragma>
	body'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testTwoNewLinesAfterSignature
	| expr source |
	expr := RBParser parseMethod: 'aMethode'.
	configurationSelector := #twoNewLinesAfterSignatureConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode


	'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testBasicSpaceIndent
	| expr source |
	expr := RBParser parseMethod: 'aMethod <pragma> "aComment" body'.
	configurationSelector := #spaceIndentConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethod
          "aComment"
          <pragma>
          body'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLinesAfterGluedComment
	| expr source |
	expr := RBParser parseMethod: 'aMethode "aComment""anotherComment"'.
	configurationSelector := #noNewLinesAfterCommentConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	"aComment""anotherComment"
	'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLinesBetweenTopComments
	| expr source |
	expr := RBParser parseMethod: 'aMethode "aComment" "anotherComment"'.
	configurationSelector := #noNewLineBetweenTopCommentsConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	"aComment"	"anotherComment"	'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
oneNewLinesAfterSignatureConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLinesAfterSignature
	| expr source |
	expr := RBParser parseMethod: 'aMethode'.
	configurationSelector := #signatureConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
signatureOnMultipleLinesConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		methodSignatureOnMultipleLines: true;
		selectorAndArgumentCombinedMaxSize: 2;
		numberOfNewLinesAfterMethodSignature: 0;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
noNewLinesAfterCommentConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		useBasicCommentFormat: true;
		numberOfNewLinesAfterMethodSignature: 1;
		numberOfNewLinesAfterMethodComment: 1;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
signatureNotOnMultipleLinesConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		methodSignatureOnMultipleLines: false;
		numberOfNewLinesAfterMethodSignature: 1;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testNewLinesAfterComment2
	| expr source |
	expr := RBParser parseMethod: 'aMethode "aComment" "anotherComment"'.
	configurationSelector := #oneNewLineAfterCommentConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	"aComment"

	"anotherComment"

	'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testSignatureWithArgument
	| expr source |
	expr := RBParser parseMethod: 'aMethode:arg'.
	configurationSelector := #signatureNotOnMultipleLinesConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode: arg
	'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
oneNewLineAfterCommentConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		useBasicCommentFormat:false;
		maxLineLength:50;
		numberOfNewLinesAfterMethodSignature: 1;
		numberOfNewLinesAfterMethodComment: 2;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
noNewLineBetweenTopCommentsConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		useBasicCommentFormat: true;
		numberOfNewLinesAfterMethodSignature: 1;
		numberOfNewLinesAfterMethodComment: 0;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testIndentCascade
	| expr source |
	expr := RBParser parseMethod: 'aMethode	Transcript cr; show: ''foo'';	cr. Transcript cr;cr'.
	configurationSelector := #cascadeConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	Transcript
		cr;
		show: ''foo'';
		cr.
	Transcript
		cr;
		cr'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
newLineBetweenTopCommentsConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		useBasicCommentFormat: false;
		maxLineLength: 50;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		numberOfNewLinesAfterMethodSignature: 1;
		numberOfNewLinesAfterMethodComment: 1;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
spaceIndentConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		numberOfSpacesInIndent: 10; "pay attention since there are dependency."
		indentStyle: #space;
		formatCommentCloseToStatements:false;
		useBasicCommentFormat: false;
		maxLineLength: 50;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		numberOfNewLinesAfterMethodSignature: 1;
		numberOfNewLinesAfterMethodComment: 1;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testCommentBasicFormat
	| expr source |
	expr := RBParser parseMethod: 'aMethode "   aComment   "'.
	configurationSelector := #basicCommentFormatConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	"   aComment   "
	'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testMethodWithMessageArgument
	| expr source |
	expr := RBParser parseMethod: 
'aMethod

	1 to: 10 do: [:i | Transcript show:i ; cr ;cr]
	'.
	configurationSelector := #bigMethodeConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethod
	1 to: 10 do: [:i | 
		Transcript
			show: i;
			cr;
			cr
		]'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
twoNewLinesAfterSignatureConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		numberOfNewLinesAfterMethodSignature: 3;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testSignatureOnMultipleLines
	| expr source |
	expr := RBParser parseMethod: 'aMethode: arg1 foo:arg2'.
	configurationSelector := #signatureOnMultipleLinesConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode: arg1
	foo: arg2
	'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
cascadeConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		useBasicCommentFormat: false;
		maxLineLength: 50;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		newLineBeforeFirstCascade:true;
		newLineAfterCascade:true;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine:10;
		keepBlockInMessage:true;
		retainBlankLinesBetweenStatements:false;
		numberOfNewLinesAfterMethodSignature:1;
		minimumNewLinesBetweenStatements: 1;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testBasic2
	| expr source |
	expr := RBParser parseMethod: 'aMethod <pragma1> <pragma2> "aComment1" "aComment2"  body'.
	configurationSelector := #newLineBetweenTopCommentsConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethod
	"aComment1"
	"aComment2"
	<pragma1>
	<pragma2>
	body'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
basicConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		useBasicCommentFormat: false;
		maxLineLength: 50;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		numberOfNewLinesAfterMethodSignature: 1;
		numberOfNewLinesAfterMethodComment: 1;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testSignatureNotOnMultipleLines
	| expr source |
	expr := RBParser parseMethod: 'aMethode:arg1 foo:arg2'.
	configurationSelector := #signatureNotOnMultipleLinesConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode: arg1 foo: arg2
	'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
signatureConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		numberOfNewLinesAfterMethodSignature: 1;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testSignatureWithoutArgument
	| expr source |
	expr := RBParser parseMethod: 'aMethode'.
	configurationSelector := #basicConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testOneNewLinesAfterSignature
	| expr source |
	expr := RBParser parseMethod: 'aMethode'.
	configurationSelector := #oneNewLineAfterCommentConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testNewLinesAfterGluedComment
	| expr source |
	expr := RBParser parseMethod: 'aMethode"aComment""anotherComment"'.
	configurationSelector := #oneNewLineAfterCommentConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	"aComment""anotherComment"

	'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
bigMethodeConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements: false;
		useBasicCommentFormat: false;
		maxLineLength: 50;
		periodAtEndOfBlock: false;
		periodAtEndOfMethod: false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		indentsForKeywords: 1;
		keepBlockInMessage: true;
		retainBlankLinesBetweenStatements: false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements: 1;
		newLineBeforeFirstCascade: true;
		newLineAfterCascade: true;
		numberOfArgumentsForMultiLine: 4;
		numberOfNewLinesAfterTemporaries: 1;
		numberOfSpacesInsideBlock: 0;
		lineUpBlockBrackets: true;
		numberOfNewLinesAfterMethodSignature: 1;
		numberOfNewLinesAfterMethodComment: 1;
		newLineBeforeFirstKeyword:true;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testNewLinesBetweenTopComments
	| expr source |
	expr := RBParser parseMethod: 'aMethode "aComment" "anotherComment"'.
	configurationSelector := #newLineBetweenTopCommentsConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	"aComment"
	"anotherComment"
	'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testFormatBody
	| expr source |
	expr := RBParser parseMethod: 'aMethode a:=1'.
	configurationSelector := #basicConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	a := 1'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testBigMethod
	| expr source |
	expr := RBParser parseMethod: 
	'aMethode
	"aComment"
	"anotherComment"
	<pragma>
	| tmp |
	tmp := 1.
	tmp to: 10 do: [:i | Transcript show:i ; cr ;cr]
	'.
	configurationSelector := #bigMethodeConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	"aComment"
	"anotherComment"
	<pragma>
	| tmp |
	tmp := 1.
	tmp to: 10 do: [:i | 
		Transcript
			show: i;
			cr;
			cr
		]'! !

!EFMethodExpressionTest methodsFor: 'configurations' stamp: ''!
notBasicCommentFormatConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		indentStyle: #tabulation;
		formatCommentCloseToStatements:false;
		useBasicCommentFormat: false;
		maxLineLength: 50;	
		numberOfNewLinesAfterMethodSignature: 1;
		numberOfNewLinesAfterMethodComment: 1;
		indentExtraSpaces:0! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testCommentNotBasicFormat
	| expr source |
	expr := RBParser parseMethod: 'aMethode "   aComment   "'.
	configurationSelector := #notBasicCommentFormatConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	"aComment   "
	'! !

!EFMethodExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLinesAfterComment
	| expr source |
	expr := RBParser parseMethod: 'aMethode "aComment"'.
	configurationSelector := #basicCommentFormatConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
'aMethode
	"aComment"
	'! !

!EFParseErrorExpressionTest methodsFor: 'configuration' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:false;
		retainBlankLinesBetweenStatements: false;
		minimumNewLinesBetweenStatements:0;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false! !

!EFParseErrorExpressionTest methodsFor: 'tests' stamp: ''!
testParseError2

	| expr source |
	expr := RBParser parseFaultyExpression: '1 := '.
	configurationSelector := #basicConfiguration.
	source := self formatter format: expr.
	self assert: source equals:
' 1. :='! !

!EFParseErrorExpressionTest methodsFor: 'tests' stamp: ''!
testParseError

	| expr source |
	expr := RBParser parseFaultyExpression: '#(1 3 4'.
	configurationSelector := #basicConfiguration.
	source := self formatter format: expr.
	self assert: source equals: '#( 1 3 4'! !

!EFPatternBlockExpressionTest methodsFor: 'hooks' stamp: ''!
openBracket
	^'`{'! !

!EFPatternBlockExpressionTest methodsFor: 'hooks' stamp: ''!
closeBracket
	^'}'! !

!EFPatternBlockExpressionTest methodsFor: 'hooks' stamp: ''!
parserClass
	^ RBPatternParser! !

!EFPragmaExpressionTest methodsFor: 'configuration' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:false;
		maxLineLength: 50;
		keepBlockInMessage: true! !

!EFPragmaExpressionTest methodsFor: 'tests' stamp: ''!
testPragmaNoExtraSpace
	| expr source |
	expr := RBParser parsePragma:'<   Pragma   >'.
	configurationSelector := #basicConfiguration.
	source := self formatter format: expr.
	self assert: source equals: '<Pragma>'! !

!EFPragmaExpressionTest methodsFor: 'tests' stamp: ''!
testPragmaNoExtraSpace2
	| expr source |
	expr := RBParser parsePragma:'<func:     ''(3+4)''       res:      7>'.
	configurationSelector := #basicConfiguration.
	source := self formatter format: expr.
	self assert: source equals: '<func: ''(3+4)'' res: 7>'! !

!EFPragmaExpressionTest methodsFor: 'tests' stamp: ''!
testPragmaNoExtraSpaceBetweenMethodeAndArgument
	| expr source |
	expr := RBParser parsePragma:'<primitive:    41>'.
	configurationSelector := #basicConfiguration.
	source := self formatter format: expr.
	self assert: source equals: '<primitive: 41>'! !

!EFReturnExpressionTest methodsFor: 'tests' stamp: ''!
testReturnHasNoExtraSpaceInside
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: ' ^    a'.
	self assert: source equals: '^ a'! !

!EFReturnExpressionTest methodsFor: 'tests' stamp: ''!
testReturnHasNoPeriod
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '^a.'.
	self assert: source equals: '^ a'! !

!EFReturnExpressionTest methodsFor: 'tests' stamp: ''!
testReturnHasSpaceBetween
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '^a'.
	self assert: source equals: '^ a'! !

!EFReturnExpressionTest methodsFor: 'configuration' stamp: ''!
basicConfiguration
	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		numberOfSpacesAfterCaretSymbolInReturn: 1;
		maxLineLength: 70;
		indentExtraSpaces: 0! !

!EFReturnExpressionTest methodsFor: 'tests' stamp: ''!
testReturnExtraSpacesInIndentWhenMultilneWithThreeSpacesAfterCaretSymbol
	| source |
	configurationSelector := #multilineWithThreeSpacesAfterCaretSymbolConfiguration.
	source := self formatExpression: '^ Array with: self leftRotated with: self negated with: self rightRotated with: self'.
	self assert: source equals:
'^   Array
	    with: self leftRotated
	    with: self negated
	    with: self rightRotated
	    with: self'! !

!EFReturnExpressionTest methodsFor: 'tests' stamp: ''!
testReturnExtraSpacesInIndentWhenMultilne
	| source |
	configurationSelector := #multilineConfiguration.
	source := self formatExpression: '^ Array with: self leftRotated with: self negated with: self rightRotated with: self'.
	self assert: source equals:
'^ Array
	  with: self leftRotated
	  with: self negated
	  with: self rightRotated
	  with: self'! !

!EFReturnExpressionTest methodsFor: 'tests' stamp: ''!
testReturnHasNoExtraSpace
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '    ^a   '.
	self assert: source equals: '^ a'! !

!EFReturnExpressionTest methodsFor: 'tests' stamp: ''!
testReturnFormatValue
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '    ^a:=1   '.
	self assert: source equals: '^ a := 1'! !

!EFReturnExpressionTest methodsFor: 'configuration' stamp: ''!
multilineWithThreeSpacesAfterCaretSymbolConfiguration
	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		numberOfSpacesAfterCaretSymbolInReturn: 3;
		maxLineLength: 70;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 4;
		indentStyle: #tabulation;
		indentsForKeywords: 1;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: true;
		indentExtraSpaces: 0! !

!EFReturnExpressionTest methodsFor: 'configuration' stamp: ''!
multilineConfiguration
	^ self contextClass basicNew
		formatCommentCloseToStatements: false;
		numberOfSpacesAfterCaretSymbolInReturn: 1;
		maxLineLength: 70;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 4;
		indentStyle: #tabulation;
		indentsForKeywords: 1;
		newLineBeforeFirstKeyword: true;
		keepBlockInMessage: true;
		indentExtraSpaces: 0! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
dontFormatCommentWithStatementConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:false;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		retainBlankLinesBeforeComments:false;
		useBasicCommentFormat:false;
		maxLineLength:50;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:0;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 5;
		indentsForKeywords: 0;
		keepBlockInMessage: false;
		newLineBeforeFirstKeyword:false;
		indentExtraSpaces: 0! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testDontRetainBlankLinesBeforeComments
	| source |
	configurationSelector := #dontRetainBlankLinesBeforeCommentsConfiguration.
	source := self
		formatExpression:
			'|a b|
	a :=1.
	"Comment" b :=2'.
	self assert: source equals: '| a b |a := 1. "Comment" b := 2'! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testRetainBlankLinesBeforeComments
	| source |
	configurationSelector := #retainBlankLinesBeforeCommentsConfiguration.
	source := self
		formatExpression:
			'|a b|
	a :=1.
	"Comment"
	b :=2'.
	self
		assert: source
		equals:
			'| a b |a := 1.
"Comment" b := 2'! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
newLineAfterStatementConfiguration

	^ self contextClass basicNew
		minimumNewLinesBetweenStatements:1;
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		retainBlankLinesBeforeComments:false;
		useBasicCommentFormat:false;
		maxLineLength:50;
		retainBlankLinesBetweenStatements:false;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false;
		indentExtraSpaces:0! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
noPeriodAtEndOfMethodConfiguration 

	^ self contextClass basicNew
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false;
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		retainBlankLinesBeforeComments:false;
		useBasicCommentFormat:false;
		maxLineLength:50;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:0;
		numberOfSpacesInsideBlock:1;
		lineUpBlockBrackets: false;
		multiLineMessages:Array new;
		oneLineMessages:Array new;
		numberOfArgumentsForMultiLine:2;
		newLineBeforeFirstKeyword:false;
		indentExtraSpaces:0! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
dontRetainBlankLinesBeforeCommentsConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"


		
	^ self contextClass basicNew
		retainBlankLinesBeforeComments:false;
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		useBasicCommentFormat:false;
		maxLineLength:50;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:0;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false;
		indentExtraSpaces:0! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLineBetweenVariableAndIfTrue
	| source |
	configurationSelector := #formatBlockConfiguration.
	source := self formatExpression: 
'| x aBitBlt foreColorVal foreColorAlpha gammaTable gammaInverseTable |
	"x ifTrue: [ 
		aBitBlt
			copyBitsColor: foreColorVal
			alpha: foreColorAlpha
			gammaTable: gammaTable
			ungammaTable: gammaInverseTable ]		
"
	x ifTrue: [ 
			aBitBlt
				copyBitsColor: foreColorVal
				alpha: foreColorAlpha
				gammaTable: gammaTable
				ungammaTable: gammaInverseTable ]'.
	self assert: source equals: 
'| x aBitBlt foreColorVal foreColorAlpha gammaTable gammaInverseTable |
"x ifTrue: [ 
		aBitBlt
			copyBitsColor: foreColorVal
			alpha: foreColorAlpha
			gammaTable: gammaTable
			ungammaTable: gammaInverseTable ]		
"
x ifTrue: [ 
	aBitBlt
		copyBitsColor: foreColorVal
		alpha: foreColorAlpha
		gammaTable: gammaTable
		ungammaTable: gammaInverseTable ]'! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testFormatCommentWithStatement
	| source |
	configurationSelector := #formatCommentWithStatementConfiguration.
	source := self formatExpression: '1+1 "We do an addition". 2'.
	self assert: source equals: 
'1 + 1. "We do an addition" 2'! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testRetainBlankLinesBetweenStatements3
	| source |
	configurationSelector := #retainBlankLinesBetweenStatementsConfiguration.
	source := self
		formatExpression:
			'|a b| 
	
	a:=1.
	b:=a'.
	self
		assert: source
		equals:
			'| a b |a := 1.
b := a'! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
newLineAfterTemporariesConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:1;
		indentExtraSpaces:0! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testPeriodAtEndOfMethode
	| source |
	configurationSelector := #periodAtEndOfMethodConfiguration.
	source := self formatExpression: '|a b| 6 factorial'.
	self assert: source equals: '| a b |6 factorial.'! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
formatBlockConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:false;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:1;
		retainBlankLinesBeforeComments:false;
		useBasicCommentFormat:false;
		maxLineLength:50;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:0;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 5;
		indentsForKeywords: 1;
		keepBlockInMessage: true;
		newLineBeforeFirstKeyword:true;
		indentExtraSpaces: 0;
		numberOfSpacesInsideBlock: 1;
		lineUpBlockBrackets: false! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testCommentBetweenStatements
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '|a b| a := 1."comment"b := 2'.
	self assert: source equals: '| a b |a := 1. "comment" b := 2'! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testRetainBlankLinesBetweenStatements
	| source |
	configurationSelector := #retainBlankLinesBetweenStatementsConfiguration.
	source := self
		formatExpression:
			'|a b| 
	
	a:=1.
	
	b:=a'.
	self
		assert: source
		equals:
			'| a b |a := 1.

b := a'! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
dontRetainBlankLinesBetweenStatementsConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		retainBlankLinesBetweenStatements: false;
		retainBlankLinesBeforeComments:false;
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		useBasicCommentFormat:false;
		maxLineLength:50;
		minimumNewLinesBetweenStatements:0;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false;
		indentExtraSpaces:0! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testFormatEachStatement
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '|a b|a:=1.b:=a'.
	self assert: source equals: '| a b |a := 1. b := a'! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testRetainBlankLinesBetweenStatements2
	| source |
	configurationSelector := #retainBlankLinesBetweenStatementsConfiguration.
	source := self
		formatExpression:
			'|a b| 
	
	a:=1.
	
	
	b:=a'.
	self
		assert: source
		equals:
			'| a b |a := 1.


b := a'! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
basicConfiguration 

	^ self contextClass basicNew
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		retainBlankLinesBeforeComments:false;
		useBasicCommentFormat:false;
		maxLineLength:50;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:0;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false;
		indentExtraSpaces:0! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testNoPeriodAtEndOfMethode
	| source |
	configurationSelector := #noPeriodAtEndOfMethodConfiguration.
	source := self formatExpression: '|a b| 6 factorial'.
	self assert: source equals: '| a b |6 factorial'! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
formatCommentWithStatementConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		retainBlankLinesBeforeComments:false;
		useBasicCommentFormat:false;
		maxLineLength:50;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:0;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false;
		multiLineMessages: Array new;
		oneLineMessages: Array new;
		numberOfArgumentsForMultiLine: 5;
		indentsForKeywords: 0;
		keepBlockInMessage: false;
		newLineBeforeFirstKeyword: false! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testLineBetweenTemporariesAndComment
	| source |
	configurationSelector := #newLineAfterTemporariesConfiguration.
	source := self formatExpression: '|a b| "comment"'.
	self
		assert: source
		equals:
			'| a b |
"comment"
'! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
retainBlankLinesBetweenStatementsConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		retainBlankLinesBetweenStatements: true;
		retainBlankLinesBeforeComments:false;
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		useBasicCommentFormat:false;
		maxLineLength:50;
		minimumNewLinesBetweenStatements:0;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false;
		indentExtraSpaces:0! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testDontRetainBlankLinesBetweenStatements
	| source |
	configurationSelector := #dontRetainBlankLinesBetweenStatementsConfiguration.
	source := self
		formatExpression:
			'|a b| 
	
	a:=1.
	
	b:=a'.
	self assert: source equals: '| a b |a := 1. b := a'! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testDontFormatCommentWithStatement
	| source |
	configurationSelector := #dontFormatCommentWithStatementConfiguration.
	source := self formatExpression: '1+3 "We do an addition". 2'.
	self assert: source equals:
 '1 + 3 "We do an addition". 2'! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testCommentBetweenTemporariesAndStatement
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '|a b| "comment" a := 1'.
	self
		assert: source
		equals:
'| a b |"comment"
a := 1'! !

!EFSequenceExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineBetweenStatement
	| source |
	configurationSelector := #newLineAfterStatementConfiguration.
	source := self formatExpression: '|a b| a := 1. b := a'.
	self
		assert: source
		equals:
			'| a b |a := 1.
b := a'! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
retainBlankLinesBeforeCommentsConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		retainBlankLinesBeforeComments:true;
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		useBasicCommentFormat:false;
		maxLineLength:50;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:0;
		periodAtEndOfBlock:false;
		periodAtEndOfMethod:false;
		indentExtraSpaces:0! !

!EFSequenceExpressionTest methodsFor: 'configurations' stamp: ''!
periodAtEndOfMethodConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		periodAtEndOfBlock:true;
		periodAtEndOfMethod:true;
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		retainBlankLinesBeforeComments:false;
		useBasicCommentFormat:false;
		maxLineLength:50;
		retainBlankLinesBetweenStatements:false;
		minimumNewLinesBetweenStatements:0;
		numberOfSpacesInsideBlock:1;
		lineUpBlockBrackets: true;
		multiLineMessages:Array new;
		oneLineMessages:Array new;
		numberOfArgumentsForMultiLine:2;
		newLineBeforeFirstKeyword:false;
		indentExtraSpaces:0! !

!EFSettingChanged commentStamp: ''!
A simple announcement that is raised when a setting changes.!
!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testCommentBasicFormat
	| source |
	configurationSelector := #basicCommentFormatConfiguration.
	source := self formatExpression: ' | d "    comment     " e |'.
	self assert: source equals: '| d "    comment     " e |'! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testDontRetainBlankLinesBeforeComments
	| source |
	configurationSelector := #dontRetainBlankLinesBeforeComments.
	source := self
		formatExpression:
			' | d 
	"comment"e |'.
	self
		assert: source
		equals:
			'| d "comment" e |'! !

!EFTemporariesExpressionTest methodsFor: 'configurations' stamp: ''!
basicCommentFormatConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
	useBasicCommentFormat: true;
	formatCommentCloseToStatements:true;
	indentStyle: #tabulation;
	numberOfNewLinesAfterTemporaries:0;
	retainBlankLinesBeforeComments:false;
	indentExtraSpaces:0! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testRetainBlankLinesBeforeComments
	| source |
	configurationSelector := #retainBlankLinesBeforeComments.
	source := self
		formatExpression:
			' | d 
	"comment"e |'.
	self
		assert: source
		equals:
			'| d
"comment" e |
'! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testSpaceBetweenTemporaries2
	| source |
	configurationSelector := #noNewLinesAfterTemporariesConfiguration.
	source := self formatExpression: '|a b|'.
	self assert: source equals: '| a b |'! !

!EFTemporariesExpressionTest methodsFor: 'configurations' stamp: ''!
twoLinesAfterTemporariesConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"
		
	^ self contextClass basicNew
		numberOfNewLinesAfterTemporaries: 2;
		useBasicCommentFormat: false;
		formatCommentCloseToStatements:false;
		indentStyle: #tabulation;
		retainBlankLinesBeforeComments:false;
		indentExtraSpaces:0! !

!EFTemporariesExpressionTest methodsFor: 'configurations' stamp: ''!
dontRetainBlankLinesBeforeComments
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		retainBlankLinesBeforeComments: false;
		useBasicCommentFormat: false;
		formatCommentCloseToStatements:false;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		indentExtraSpaces:0! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testTwoLinesAfterTemporaries
	| source |
	configurationSelector := #twoLinesAfterTemporariesConfiguration.
	source := self formatExpression: ' |d e|'.
	self
		assert: source
		equals:
			'| d e |

'! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testSpaceBetweenTemporaries
	| source |
	configurationSelector := #noNewLinesAfterTemporariesConfiguration.
	source := self formatExpression: '|a|'.
	self assert: source equals: '| a |'! !

!EFTemporariesExpressionTest methodsFor: 'configurations' stamp: ''!
noNewLinesAfterTemporariesConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		numberOfNewLinesAfterTemporaries: 0;
		useBasicCommentFormat: false;
		formatCommentCloseToStatements:false;
		indentStyle: #tabulation;
		retainBlankLinesBeforeComments:false;
		indentExtraSpaces:0! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testDontRetainBlankLinesBeforeComments2
	| source |
	configurationSelector := #dontRetainBlankLinesBeforeComments.
	source := self
		formatExpression:
			' | d 
	
	"comment"
	e |'.
	self
		assert: source
		equals: '| d "comment" e |'! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testRetainBlankLinesBeforeComments3
	| source |
	configurationSelector := #retainBlankLinesBeforeComments.
	source := self formatExpression: ' | d "comment" e |'.
	self
		assert: source
		equals:
			'| d "comment" e |
'! !

!EFTemporariesExpressionTest methodsFor: 'configurations' stamp: ''!
retainBlankLinesBeforeComments
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"
	^ self contextClass basicNew
		numberOfNewLinesAfterTemporaries: 1;
		useBasicCommentFormat: false;
		formatCommentCloseToStatements:true;
		maxLineLength:50;
		indentStyle: #tabulation;
		retainBlankLinesBeforeComments:true;
		indentExtraSpaces:0! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testSpaceBetweenVarAndComment
	| source |
	configurationSelector := #commentWithStatementsConfiguration.
	source := self formatExpression: ' | d "comment" |'.
	self assert: source equals: '| d "comment" |'! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testNoNewLineAfterTemporaries
	| source |
	configurationSelector := #noNewLinesAfterTemporariesConfiguration.
	source := self formatExpression: ' |d e|'.
	self assert: source equals: '| d e |'! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testNewLineAfterTemporaries
	| source |
	configurationSelector := #newLinesAfterTemporariesConfiguration.
	source := self formatExpression: ' |d e|'.
	self
		assert: source
		equals: '| d e |
'! !

!EFTemporariesExpressionTest methodsFor: 'configurations' stamp: ''!
newLinesAfterTemporariesConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"
		
	^ self contextClass basicNew
		numberOfNewLinesAfterTemporaries: 1;
		useBasicCommentFormat: false;
		formatCommentCloseToStatements:false;
		indentStyle: #tabulation;
		retainBlankLinesBeforeComments:false;
		indentExtraSpaces:0! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testRetainBlankLinesBeforeComments2
	| source |
	configurationSelector := #retainBlankLinesBeforeComments.
	source := self
		formatExpression:
			' | d 
	
	"comment"e |'.
	self
		assert: source
		equals:
			'| d

"comment" e |
'! !

!EFTemporariesExpressionTest methodsFor: 'configurations' stamp: ''!
notBasicCommentFormatConfiguration
	"Here we can control explicitely the configuration we want."

	" String streamContents: [:s |
			BIPrettyPrinterContext new storeOn: s]"

	^ self contextClass basicNew
		useBasicCommentFormat: false;
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		retainBlankLinesBeforeComments:false;
		maxLineLength: 50;
		indentExtraSpaces:0! !

!EFTemporariesExpressionTest methodsFor: 'tests' stamp: ''!
testCommentNotBasicFormat
	| source |
	configurationSelector := #notBasicCommentFormatConfiguration.
	source := self formatExpression: ' | d "    comment     " e |'.
	self
		assert: source
		equals:
			'| d "comment     
" e |'! !

!EFTemporariesExpressionTest methodsFor: 'configurations' stamp: ''!
commentWithStatementsConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:true;
		indentStyle: #tabulation;
		numberOfNewLinesAfterTemporaries:0;
		retainBlankLinesBeforeComments:false;
		useBasicCommentFormat:false;
		maxLineLength:50;
		indentExtraSpaces:0! !

!EFTest commentStamp: ''!
There is a big warning about the design of these tests. 
The context is not initialized so that we are sure about the configuration we are building. 
!
!EFTest methodsFor: 'hooks' stamp: ''!
formatterClass

	^ formatterClass! !

!EFTest methodsFor: 'accessing' stamp: ''!
contextClass
	^ contextClass! !

!EFTest methodsFor: 'hooks' stamp: ''!
formatterClass: aFormatterClass
	formatterClass := aFormatterClass! !

!EFTest methodsFor: 'hooks' stamp: ''!
formatter
	^ self formatterClass new
		installNewContext: (self perform: configurationSelector)
		yourself! !

!EFTest methodsFor: 'hooks' stamp: ''!
formatExpression: anExpression

	| expr |
	expr := self parseExpression: anExpression.
	^ self formatter format: expr.! !

!EFTest methodsFor: 'hooks' stamp: ''!
parserClass
	^ RBParser! !

!EFTest methodsFor: 'hooks' stamp: ''!
parseExpression: anExpression

	^ self parserClass parseExpression: anExpression! !

!EFTest methodsFor: 'accessing' stamp: ''!
contextClass: anObject
	contextClass := anObject! !

!EFTest class methodsFor: 'building suites' stamp: ''!
testParameters

	^ ParametrizedTestMatrix new
			addCase: { #formatterClass -> EFFormatter. #contextClass -> EFContext };
		yourself.! !

!EFVariableExpressionTest methodsFor: 'configuration' stamp: ''!
basicConfiguration

	^ self contextClass basicNew
		formatCommentCloseToStatements:false! !

!EFVariableExpressionTest methodsFor: 'tests' stamp: ''!
testSpaces
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: 'a'.
	self assert: source equals: 'a'! !

!EFVariableExpressionTest methodsFor: 'tests' stamp: ''!
testNoExtraSpaces
	| source |
	configurationSelector := #basicConfiguration.
	source := self formatExpression: '    a     '.
	self assert: source equals: 'a'! !

!EdgeGripMorph commentStamp: ''!
Similar to a ProportionalSplitterMorph but designed to attach to an edge of a single morph only.!
!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
targetPoint
	"Answer the reference point of the target."

	^self target bounds pointAtSideOrCorner: self edgeName! !

!EdgeGripMorph methodsFor: 'accessing - layouts' stamp: ''!
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: 'accessing' stamp: ''!
targetPoint: aPoint
	"Set the reference point of the target."

	|minExt rect |
	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: 'accessing' stamp: ''!
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: 'accessing - layouts' stamp: ''!
gripLayoutFrame
	"Answer the layout frame depending on our edge."
	
	self edgeName == #top ifTrue: [^self topLayoutFrame].
	self edgeName == #bottom ifTrue: [^self bottomLayoutFrame].
	self edgeName == #left ifTrue: [^self leftLayoutFrame].
	^self rightLayoutFrame! !

!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
fitTargetOwner

	^ fitTargetOwner! !

!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
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: 'actions' stamp: ''!
resizeCursor

	^ Cursor resizeForEdge: self edgeName! !

!EdgeGripMorph methodsFor: 'theme' stamp: ''!
themeChanged
	"Update the fill style."

	self fillStyle: self normalFillStyle.
	super themeChanged! !

!EdgeGripMorph methodsFor: 'testing' stamp: ''!
isHorizontal
	"Answer true if the receiver has a horizontal layout."
	
	^self edgeName == #top
		or: [self edgeName == #bottom]! !

!EdgeGripMorph methodsFor: 'accessing - layouts' stamp: ''!
bottomLayoutFrame
	"Answer the layout frame for a bottom edge."
	
	^ (0 @ 1 corner: 1 @ 1) asLayoutFrame 
		topLeftOffset: 22 @ SystemWindow borderWidth negated ;
		rightOffset: -22! !

!EdgeGripMorph methodsFor: 'event handling' stamp: ''!
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: 'defaults' stamp: ''!
defaultHeight
	"Answer the default height for the receiver."
	
	^ProportionalSplitterMorph splitterWidth! !

!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
normalFillStyle
	"Return the normal fillStyle of the receiver."
	
	^self theme splitterNormalFillStyleFor: self! !

!EdgeGripMorph methodsFor: 'testing' stamp: ''!
splitsTopAndBottom
	"Answer true if the receiver has a horizontal layout."
	
	^self isHorizontal! !

!EdgeGripMorph methodsFor: 'geometry' stamp: ''!
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: 'accessing' stamp: ''!
target: aMorph
	"Set the value of target"

	target := aMorph! !

!EdgeGripMorph methodsFor: 'accessing - layouts' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."
	
	super initialize.
	self
		fitTargetOwner: false;
		edgeName: #right;
		extent: self defaultWidth @ self defaultHeight;
		hResizing: #spaceFill;
		vResizing: #spaceFill! !

!EdgeGripMorph methodsFor: 'event handling' stamp: ''!
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: 'accessing - layouts' stamp: ''!
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: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Change our color too."
	
	super adoptPaneColor: paneColor.
	self fillStyle: self normalFillStyle! !

!EdgeGripMorph methodsFor: 'defaults' stamp: ''!
defaultWidth
	"Answer the default width for the receiver."
	
	^ProportionalSplitterMorph splitterWidth! !

!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
setTargetBounds: aRect
	"Set the target bounds, taking owner into account if required."

	self target bounds: aRect.
	self fitTargetOwner ifTrue: [
		self fitTargetBoundsInOwner: aRect]! !

!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
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: 'event handling' stamp: ''!
mouseUp: anEvent
	"Change the cursor back to normal if necessary and change the color back to normal."
	
	(self bounds containsPoint: anEvent cursorPoint)
		ifFalse: [anEvent hand showTemporaryCursor: nil].
	self adoptPaneColor: self paneColor! !

!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
pressedFillStyle
	"Return the pressed fillStyle of the receiver."
	
	^self theme splitterPressedFillStyleFor: self! !

!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
edgeName
	"Answer the value of edgeName"

	^ edgeName! !

!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
setLayoutSizingFor: aSymbol
	"Adjust the sizing for use within table layouts."

	(aSymbol = #left or: [aSymbol = #right])
		ifTrue: [self hResizing: #rigid; vResizing: #spaceFill].
	(aSymbol = #top or: [aSymbol = #bottom])
		ifTrue: [self hResizing: #spaceFill; vResizing: #rigid]! !

!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
fitTargetOwner: anObject

	fitTargetOwner := anObject! !

!EdgeGripMorph methodsFor: 'accessing' stamp: ''!
target
	"Answer the value of target"

	^ target! !

!EditableDropListMorph commentStamp: ''!
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: 'private' stamp: ''!
layoutInsetToUse
	"Answer the layout inset that should be used."

	^ 0! !

!EditableDropListMorph methodsFor: 'private' stamp: ''!
addToListSel: aSelector
	addToListSel := aSelector! !

!EditableDropListMorph methodsFor: 'drawing' stamp: ''!
newContentMorph
	"Answer a new content morph"
	| pt | 
	pt := RubPluggableTextFieldMorph new
		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;
		setBalloonText: nil.
		^ pt! !

!EditableDropListMorph methodsFor: 'accessing' stamp: ''!
content: anObject 
	content := anObject.
	self model perform: addToListSel with: content.
	self listSelectionIndex: (self list indexOf: content).
	self updateList! !

!EditableDropListMorph methodsFor: 'accessing' stamp: ''!
font: aFont
	"Set the list and content font"

	self listMorph font: aFont.
	self contentMorph font: aFont! !

!EditableDropListMorph methodsFor: 'private' stamp: ''!
updateContentMorphWith: aString

	content := aString.
	self contentMorph setText: aString! !

!EditableDropListMorph methodsFor: 'private' stamp: ''!
listHeight
	"Answer the height for the list."
	^(self listMorph listMorph height + 12) min: 200! !

!EditableDropListMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Clear the fill style of the text."
	
	super adoptPaneColor: paneColor.
	self contentMorph fillStyle: Color transparent! !

!EditableDropListMorph methodsFor: 'public accessing' stamp: ''!
beReadOnly 
	self contentMorph beReadOnly! !

!EditableDropListMorph methodsFor: 'accessing' stamp: ''!
content
	^ content! !

!EditableDropListMorph methodsFor: 'accessing' stamp: ''!
converter
	^ self contentMorph converter! !

!EditableDropListMorph methodsFor: 'layout' stamp: ''!
minHeight
	"Answer the minimum height for the drop list."
	
	^self theme textFont height! !

!EditableDropListMorph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	"Set the value of enabled"
	
	super enabled: aBoolean.
	self
		contentMorph enabled: aBoolean;
		fillStyle: Color transparent! !

!EditableDropListMorph methodsFor: 'private' stamp: ''!
objectAsString: anObject
	^ self converter objectAsString: anObject! !

!EditableDropListMorph methodsFor: 'private' stamp: ''!
default: anObject 
	self contentMorph default: anObject! !

!EditableDropListMorph methodsFor: 'private' stamp: ''!
convertTo: aClass 
	self contentMorph convertTo: aClass! !

!EditableDropListMorph methodsFor: 'protocol' stamp: ''!
wantsFrameAdornments: aBoolean
	self contentMorph wantsFrameAdornments: aBoolean! !

!EditableDropListMorph class methodsFor: 'instance creation' stamp: ''!
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: 'instance creation' stamp: ''!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel useIndex: useIndex addToList: addToListSel class: aClass getEnabled: getEnabledSel default: aDefaultValue
	^ (super
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		useIndex: useIndex) convertTo: aClass;
		 getEnabledSelector: getEnabledSel;
		 addToListSel: addToListSel;
		 default: aDefaultValue;
		 yourself! !

!EditableList commentStamp: ''!
This widget allows you to edit a list of items :
- add / remove an item to/from the list 
- order the list by moving elements up/down/top/bottom.

The default behavior is to do a copy of the list. The widget works with its internal copy. It allows the user to accept / reject changes (for example by opening the widget in a DialogWindow) before affecting the original list. It is your responsibility to copy EditableList items back to the original list.

The addItemBlock is used to provide a way to give the item to add (e.g. a UIManager default chooseFrom: values:).

Example:
self example!
!EditableList methodsFor: 'accessing' stamp: ''!
upButton
	^ upButton! !

!EditableList methodsFor: 'accessing' stamp: ''!
addButton
	^ addButton! !

!EditableList methodsFor: 'accessing' stamp: ''!
bottomButton
	^ bottomButton! !

!EditableList methodsFor: 'initialization' stamp: ''!
initialize
	"Initialization code for EditableList"

	title := 'Title' asValueHolder.
	
	super initialize.
	okBlock := [ ].! !

!EditableList methodsFor: 'initialization' stamp: ''!
initializeWidgets
	list := self instantiate: FastTablePresenter.
	addButton := self newButton.
	removeButton := self newButton.
	upButton := self newButton.
	downButton := self newButton.
	topButton := self newButton.
	bottomButton := self newButton.
	addButton
		icon: (self iconNamed: #addIcon);
		help: 'Add a new item to the list'.
	removeButton
		icon: (self iconNamed: #deleteIcon);
		help: 'Remove a item from the list'.
	upButton
		icon: (self iconNamed: #upIcon);
		help: 'Move this item up from one element'.
	downButton
		icon: (self iconNamed: #downIcon);
		help: 'Move this item down from one element'.
	topButton
		icon: (self iconNamed: #topIcon);
		help: 'Move this item on the first position of the list'.
	bottomButton
		icon: (self iconNamed: #bottomIcon);
		help: 'Move this item on the last position of the list'! !

!EditableList methodsFor: 'private' stamp: ''!
moveElementAt: index to: newIndex
	| elementToMove orderedList |
	
	(newIndex < 1 or: [ newIndex > list listItems size ]) ifTrue: [ ^self ].
	
	elementToMove := list listItems at: index.	
	orderedList := list listItems asOrderedCollection
		removeAt: index;
		add: elementToMove beforeIndex: newIndex;
		yourself.
	self list: orderedList.
	self list setSelectedIndex: newIndex.! !

!EditableList methodsFor: 'accessing' stamp: ''!
title: aTitle
	title := aTitle ! !

!EditableList methodsFor: 'api' stamp: ''!
addItemBlock: aBlock
	addItemBlock := aBlock.! !

!EditableList methodsFor: 'private' stamp: ''!
performOkAction

	okBlock value! !

!EditableList methodsFor: 'accessing' stamp: ''!
downButton
	^ downButton! !

!EditableList methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aWindow
	super initializeDialogWindow: aWindow.
	aWindow okAction: [ self performOkAction ]! !

!EditableList methodsFor: 'api' stamp: ''!
okAction: aBlock

	okBlock := aBlock! !

!EditableList methodsFor: 'accessing' stamp: ''!
removeButton
	^ removeButton! !

!EditableList methodsFor: 'accessing' stamp: ''!
topButton
	^ topButton! !

!EditableList methodsFor: 'private' stamp: ''!
list: aList
	list items: aList.! !

!EditableList methodsFor: 'accessing' stamp: ''!
title
	^ title value! !

!EditableList methodsFor: 'accessing' stamp: ''!
list
	^ list! !

!EditableList methodsFor: 'initialization' stamp: ''!
initializePresenter
	super initializePresenter
	
	addButton action: [ | requirement | 
						requirement := addItemBlock value.
						requirement ifNotNil: [ 
							self list: (self list listItems copyWith: requirement) ] ].

	removeButton
		action: [ self list: (list listItems copyWithoutIndex: list selectedIndex) ].
		
	topButton
		action: [ self moveElementAt: list selectedIndex to: 1 ].
	bottomButton
		action: [ self moveElementAt: list selectedIndex to: list listItems size ].
	upButton
		action: [ self moveElementAt: list selectedIndex to: list selectedIndex - 1].
	downButton
		action: [ self moveElementAt: list selectedIndex to: list selectedIndex + 1].
! !

!EditableList class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^self new
	
		title: 'Selectors list';
		list: self selectors;
	 openWithSpec! !

!EditableList class methodsFor: 'instance creation' stamp: ''!
new: aCollection
	^ self new list: aCollection copy.
		! !

!EditableList class methodsFor: 'spec' stamp: ''!
spec
	<spec: #default>
	^ SpecLayout composed
		newColumn:
			[ :column | 
			column
				newRow: [ :menuRow | 
							menuRow
								add: #addButton;
								add: #removeButton ]
					height: 25;
				newRow: [ :listRow | 
							listRow
								newColumn: [ :c1 | c1 add: #list ];
								newColumn: [ :c2 | 
											c2
												add: #topButton;
												add: #upButton;
												add: #downButton;
												add: #bottomButton ]
									width: 24 ] ] 
		yourself! !

!EditingState commentStamp: ''!
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 <Array of TextAttribute>
   pointBlock <CharacterBlock>
   markBlock <CharacterBlock>
   startOfTyping <Integer>
   previousInterval <Interval>
   previousSelection <Text>
   undoManager <HistoryIterator>
   lastParenLocation <Integer>
   mouseDownInterval <Interval>

- 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: ''!
lastParenLocation
	^ lastParenLocation! !

!EditingState methodsFor: 'accessing' stamp: ''!
undoManager

	^ undoManager ifNil: [ undoManager := HistoryIterator new].
! !

!EditingState methodsFor: 'accessing' stamp: ''!
mouseDownInterval
	^ mouseDownInterval! !

!EditingState methodsFor: 'events' stamp: ''!
keystroke: aKeyboardEvent from: aTextMorph
! !

!EditingState methodsFor: 'accessing' stamp: ''!
unselect
	self markBlock: self pointBlock copy! !

!EditingState methodsFor: 'accessing' stamp: ''!
pointBlock
	^ pointBlock! !

!EditingState methodsFor: 'accessing' stamp: ''!
pointBlock: aCharacterBlock
	pointBlock := aCharacterBlock.
! !

!EditingState methodsFor: 'accessing' stamp: ''!
markBlock
	^ markBlock! !

!EditingState methodsFor: 'accessing' stamp: ''!
emphasisHere
	^ emphasisHere! !

!EditingState methodsFor: 'accessing' stamp: ''!
startOfTyping
	^ startOfTyping! !

!EditingState methodsFor: 'accessing' stamp: ''!
previousInterval

	^ previousInterval ifNil: [previousInterval := 1 to: 0]! !

!EditingState methodsFor: 'accessing' stamp: ''!
markBlock: aCharacterBlock
	markBlock := aCharacterBlock! !

!EditingState methodsFor: 'accessing' stamp: ''!
emphasisHere: aListOfTextAttribute 
	emphasisHere := aListOfTextAttribute
				ifNotNil: [:l | l reject: [:a | TextSelectionColor = a class]]! !

!EditingState methodsFor: 'accessing' stamp: ''!
previousSelection

	^ previousSelection ifNil: [previousSelection := '' asText]! !

!EditingState methodsFor: 'undo - redo' stamp: ''!
undo
	^ self undoManager undo ! !

!EditingState methodsFor: 'undo - redo' stamp: ''!
redoArray: doArray undoArray: undoArray
	self undoManager isPlugged 
		ifTrue: [self undoManager redoArray: doArray undoArray: undoArray]! !

!EditingState methodsFor: 'accessing' stamp: ''!
startOfTyping: anIntegerIndex
	startOfTyping := anIntegerIndex! !

!EditingState methodsFor: 'accessing' stamp: ''!
mouseDownInterval: anInterval
	mouseDownInterval := anInterval! !

!EditingState methodsFor: 'accessing' stamp: ''!
lastParenLocation: anIntegerIndex
	lastParenLocation := anIntegerIndex! !

!EditingState methodsFor: 'events' stamp: ''!
handlesKeyboard: evt from: aTextMorph
	^ false! !

!EditingState methodsFor: 'events' stamp: ''!
mouseDown: anEvent from: aTextMorph
	self mouseDownInterval: aTextMorph editor selectionInterval.
	self focused: true from: aTextMorph
! !

!EditingState methodsFor: 'events' stamp: ''!
focused: aBoolean from: aTextMorph
	(aBoolean and: [aTextMorph sharesFindReplace])
		ifTrue: [[(EditorFindReplaceDialogWindow on: aTextMorph) comeToFront] on: Error do: []].! !

!EditingState methodsFor: 'private - debugging' stamp: ''!
exploreUndoManager: aKeyboardEvent
	self undoManager inspect.
	^ true! !

!EditingState methodsFor: 'undo - redo' stamp: ''!
redo
	^ self undoManager redo ! !

!EditingState methodsFor: 'accessing' stamp: ''!
previousInterval: anInterval selection: aSelection

	previousInterval := anInterval.
	previousSelection := aSelection.
! !

!EditingState methodsFor: 'undo - redo' stamp: ''!
clearUndoManager: aKeyboardEvent
	self undoManager reset.
	^ true! !

!EditorFindReplaceDialogWindow commentStamp: ''!
A find/replace dialog window for editors!
!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
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' selector: #showAbout.
	aMenu lastItem icon: (self iconNamed: #smallHelpIcon).
	^ aMenu! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
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: 'action' stamp: ''!
replace
	self newReplacement.
	self state replaceInTextMorph: self model.
	self find! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
replaceText
	^ self state replaceText! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
newFindButton
	^(self theme
			newButtonIn: self
			for: self
			getState: nil
			action: #find
			arguments: nil
			getEnabled: #findEnabled
			label: 'Find' translated
			help: 'Find the next occurrence' translated)
		hResizing: #rigid;
		vResizing: #rigid! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
prevFinds
	^ self class finds! !

!EditorFindReplaceDialogWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
removeBoxes
	"Remove all label area boxes."

	expandBox ifNotNil: [expandBox delete. expandBox := nil].
	collapseBox ifNotNil: [collapseBox delete. collapseBox := nil]! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
newReplaceAllButton
	^ (self theme
		newButtonIn: self
		for: self
		getState: nil
		action: #replaceAll
		arguments: nil
		getEnabled: #replaceAllEnabled
		label: 'Replace all' translated
		help: 'Replace all occurrences' translated) hResizing: #rigid;
		 vResizing: #rigid! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
defaultButton
	"Answer the default button."
	^self
		findDeepSubmorphThat: [:m |
			(m isKindOf: PluggableButtonMorph) and: [m actionSelector = #find]]
		ifAbsent: [] ! !

!EditorFindReplaceDialogWindow methodsFor: 'updating' stamp: ''!
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: 'icons' stamp: ''!
taskbarIcon
	^ self iconNamed: #smallFindIcon! !

!EditorFindReplaceDialogWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
initialize
	"Set the initial position based on usable screen area."

	super initialize.
	self position: RealEstateAgent maximumUsableArea topLeft! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
initialExtent 
	^ 400 @ super initialExtent y! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
findText: aStringOrText
	self state findText: aStringOrText.
	^ true
! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
isResizeable
	"Answer whether we are not we can be resized."

	^true! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
newReplaceButton
	^ (self theme
		newButtonIn: self
		for: self
		getState: nil
		action: #replace 
		arguments: nil
		getEnabled: #replaceEnabled
		label: 'Replace' translated
		help: 'Replace the next occurrence' translated) hResizing: #rigid;
		 vResizing: #rigid! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
replaceText: aStringOrText
	self state replaceText: aStringOrText asString.
	^ true

! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
maxPreviousListSize
	^ self class maxPreviousListSize! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
prevReplacements
	^ self class replacements! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
caseSensitive
	^ self state caseSensitive! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
state
	^ state ifNil: [self state: (self defaultFindReplaceServiceClass newFor: self)]! !

!EditorFindReplaceDialogWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
aboutTitle
	^ 'Find & replace dialog'! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
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.
	textFieldMorph := pt. 
	^ pt
! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
isRegex: aBoolean
	self state isRegex: aBoolean.
! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
entireWordsOnly
	^ self state entireWordsOnly! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
entireWordsOnly: aBoolean
	self state entireWordsOnly: aBoolean.
! !

!EditorFindReplaceDialogWindow methodsFor: 'action' stamp: ''!
open
	self openInWorld.
	self extent: self extent.
	self activate
! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
taskbarButtonFor: aTaskBar
	"No taskbar button because always on top"
	^nil! !

!EditorFindReplaceDialogWindow methodsFor: 'updating' stamp: ''!
update: aSymbol
	 
	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: 'updating' stamp: ''!
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: 'action' stamp: ''!
replaceAll
	self model takeKeyboardFocus.
	self state replaceAllInTextMorph: self model! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
searchBackwards: aBoolean
	self searchBackwards = aBoolean
		ifFalse: [self state searchBackwards: aBoolean.
			self state updateFindStartIndexForTextMorph: self model]! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self newFindButton isDefault: true. self newReplaceButton. self newReplaceAllButton. self newCancelButton}! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
replaceEnabled
	^ self model notNil
		and: [self findText notEmpty]! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
findTextFieldMorph
	^ textFieldMorph! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
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
! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
caseSensitive: aBoolean
	self state caseSensitive: aBoolean.
! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
findText
	^ self state findText! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
extent: anExtent
	^ super extent: anExtent x @ self initialExtent y! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
replaceAllEnabled
	^ self model notNil
		and: [self findText notEmpty]! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
title
	^ 'Find & Replace' translated.
! !

!EditorFindReplaceDialogWindow methodsFor: 'action' stamp: ''!
cancel
	self state findText: ''.
	super cancel! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
wrapAround
	^ self state wrapAround ! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
defaultFocusMorph
	^ self findTextFieldMorph textMorph! !

!EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
findEnabled
	^ self findString isEmptyOrNil not ! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
state: aFindReplaceService
	state ifNotNil: [state removeDependent: self].
	state := aFindReplaceService.
	state ifNotNil: [state addDependent: self].
! !

!EditorFindReplaceDialogWindow methodsFor: 'updating' stamp: ''!
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: 'action' stamp: ''!
find
	self newFinding.
	^ self state findInTextMorph: self model! !

!EditorFindReplaceDialogWindow methodsFor: 'updating' stamp: ''!
newReplacement
	| t |
	(t := self replaceText asString) ifEmpty: [^ self ].
	(self prevReplacements includes: t)
		ifFalse: [self prevReplacements addFirst: t].
	self prevReplacements size > self maxPreviousListSize
		ifTrue: [self prevReplacements removeLast]! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
defaultFindReplaceServiceClass

	^ self class defaultFindReplaceServiceClass! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
wrapAround: aBoolean
	self state wrapAround: aBoolean.
! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
isRegex
	^ self state isRegex! !

!EditorFindReplaceDialogWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
aboutText
	^ 'This dialog can be opened with <cmd-f> 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 <cmd-h> 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 <cmd-g> shortcut. 
In order to get rid of the current find token, just enter <cmd-h> 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: 'accessing' stamp: ''!
findString
	^ self state findString! !

!EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
searchBackwards
	^ self state searchBackwards! !

!EditorFindReplaceDialogWindow class methodsFor: 'accessing' stamp: ''!
finds
	^ Finds ifNil: [Finds := OrderedCollection new]! !

!EditorFindReplaceDialogWindow class methodsFor: 'initializing' stamp: ''!
initialize
	"EditorFindReplaceDialogWindow initialize"
	Singleton := nil.! !

!EditorFindReplaceDialogWindow class methodsFor: 'accessing' stamp: ''!
maxPreviousListSize
	^ 15! !

!EditorFindReplaceDialogWindow class methodsFor: 'accessing' stamp: ''!
replacements
	^ Replacements ifNil: [Replacements := OrderedCollection new]! !

!EditorFindReplaceDialogWindow class methodsFor: 'instance creation' stamp: ''!
on: aTextView
	^ self singleton on: aTextView! !

!EditorFindReplaceDialogWindow class methodsFor: 'accessing' stamp: ''!
defaultFindReplaceServiceClass

	^ defaultFindReplaceServiceClass ifNil: [ FindReplaceService ]! !

!EditorFindReplaceDialogWindow class methodsFor: 'instance creation' stamp: ''!
singleton 
	^ Singleton ifNil: [Singleton := self new].
! !

!EditorFindReplaceDialogWindow class methodsFor: 'initializing' stamp: ''!
cleanUp
	Singleton ifNotNil: [ 
			Singleton close.
			Singleton := nil ]! !

!EllipseMidpointTracer commentStamp: ''!
Utility class for calculating!
!EllipseMidpointTracer methodsFor: 'initialize' stamp: ''!
on: aRectangle
	a := aRectangle width // 2.
	b := aRectangle height // 2.
	x := 0.
	y := b.
	aSquared := a * a.
	bSquared := b * b.
	d1 := bSquared - (aSquared * b) + (0.25 * aSquared).
	d2 := nil.
	inFirstRegion := true.! !

!EllipseMidpointTracer methodsFor: 'computing' stamp: ''!
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! !

!EllipseMorph commentStamp: ''!
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: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!EllipseMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	
	aCanvas 
		fillOval: bounds 
		fillStyle: self fillStyle 
		borderWidth: borderWidth  
		borderColor: borderColor.! !

!EllipseMorph methodsFor: 'rounding' stamp: ''!
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: 'geometry' stamp: ''!
bottomRightCorner
	^self intersectionWithLineSegmentFromCenterTo: bounds bottomRight! !

!EllipseMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!EllipseMorph methodsFor: 'geometry' stamp: ''!
closestPointTo: aPoint
	^self intersectionWithLineSegmentFromCenterTo: aPoint! !

!EllipseMorph methodsFor: 'geometry' stamp: ''!
topRightCorner
	^self intersectionWithLineSegmentFromCenterTo: bounds topRight! !

!EllipseMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!EllipseMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!EllipseMorph methodsFor: 'geometry' stamp: ''!
bottomLeftCorner
	^self intersectionWithLineSegmentFromCenterTo: bounds bottomLeft! !

!EllipseMorph methodsFor: 'testing' stamp: ''!
canDrawBorder: aBorderStyle
	^aBorderStyle style == #simple! !

!EllipseMorph methodsFor: 'accessing' stamp: ''!
doesBevels
	^ false! !

!EllipseMorph methodsFor: 'geometry' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
asAthensShapeOn: anAthensCanvas
	| halfWidth halfHeight |
	self bounds area > 0
		ifFalse: [ ^ self ].
	halfWidth := self bounds width / 2 asFloat.
	halfHeight := self bounds height / 2 asFloat.
	^ anAthensCanvas
		createPath: [ :builder | 
			builder
				absolute;
				moveTo: self bounds center;
				relative;
				moveTo: halfWidth negated @ 0;
				curveVia: 0 @ (halfHeight negated * 0.55)
					and: (0.45 * halfWidth) @ halfHeight negated
					to: halfWidth @ halfHeight negated;
				curveVia: (halfWidth * 0.55) @ 0 and: halfWidth @ (0.45 * halfHeight) to: halfWidth @ halfHeight;
				curveVia: 0 @ (halfHeight * 0.55) and: (0.45 * halfWidth negated) @ halfHeight to: halfWidth negated @ halfHeight;
				curveVia: (halfWidth negated * 0.55) @ 0
					and: halfWidth negated @ (halfHeight negated * 0.45)
					to: halfWidth negated @ halfHeight negated ]! !

!EllipseMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	| border ellipse |
	self bounds area > 0
		ifFalse: [ ^ self ].
	border := self borderStyle.
	ellipse := self asAthensShapeOn: anAthensCanvas.
	anAthensCanvas setPaint: self fillStyle.
	anAthensCanvas setShape: ellipse.
	anAthensCanvas draw.
	(anAthensCanvas setStrokePaint: border color) width: border width.
	anAthensCanvas draw! !

!EllipseMorph methodsFor: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!EllipseMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!EllipseMorph methodsFor: 'drawing' stamp: ''!
drawDropShadowOn: aCanvas 

	aCanvas fillOval: bounds fillStyle: self shadowColor borderWidth: 0 borderColor: nil! !

!EllipseMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!EllipseMorph methodsFor: 'accessing' stamp: ''!
couldHaveRoundedCorners
	^ false! !

!EllipseMorph methodsFor: 'geometry' stamp: ''!
topLeftCorner
	^self intersectionWithLineSegmentFromCenterTo: bounds topLeft! !

!EllipseMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!EllipseMorph methodsFor: 'drawing' stamp: ''!
areasRemainingToFill: aRectangle
	"Could be improved by quick check of inner rectangle"

	^ Array with: aRectangle! !

!EllipseMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color yellow! !

!EllipseMorph methodsFor: 'geometry testing' stamp: ''!
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 class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EllipseMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EllipseMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EllipseMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EllipseMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EllipseMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EllipseMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EllipseMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EllipseMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EllipseMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EllipseMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EllipseMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EllipseMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EllipseMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EllipseMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EllipseMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EllipseMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EllipseMorph class methodsFor: 'examples' stamp: ''!
example

	EllipseMorph new
		extent: 90 @ 50;
		position: 100@100;
		color: Color green;
		openInWorld! !

!EllipseMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EllipseMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EllipseMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EllipseMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EllipseMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!EllipseMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!EllipseMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!EllipseMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EllipseMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EllipseMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EllipseMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EllipseMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EmbeddedFreeTypeFontDescription commentStamp: ''!
An abstract superclass for all font descriptions of embedded free type fonts!
!EmbeddedFreeTypeFontDescription class methodsFor: 'accessing' stamp: ''!
fontContents
	self subclassResponsibility! !

!EmbeddedFreeTypeFontDescription class methodsFor: 'accessing' stamp: ''!
originalFileName
	self subclassResponsibility! !

!EmbeddedFreeTypeFontDescription class methodsFor: 'testing' stamp: ''!
canBeInstalled
	"By default, concrete font descriptions can be installed anywhere"
	^ self isAbstract not! !

!EmbeddedFreeTypeFontDescription class methodsFor: 'accessing' stamp: ''!
installAllFontsIn: provider
	self allSubclasses do: [ :each | each installFontsIn: provider ]! !

!EmbeddedFreeTypeFontDescription class methodsFor: 'testing' stamp: ''!
isAbstract 
	^self name = #EmbeddedFreeTypeFontDescription! !

!EmbeddedFreeTypeFontDescription class methodsFor: 'accessing' stamp: ''!
installFontsIn: provider
	self canBeInstalled ifFalse: [ ^ self ].
	provider
		addFromFileContents: self fontContents 
		baseName: self originalFileName! !

!EmbeddedFreeTypeFontInstaller commentStamp: ''!
An EmbeddedFreeTypeFontInstaller installs embedded free type fonts in a provider.
It registers itself as a font installer to FreeTypeFontProvider. And when someone asks to update fonts from system, EmbeddedFreeTypeFontInstaller installs corresponding fonts.

Instance Variables
	embeddedFileInfoCache:		<Dictionary>
	provider:		<FreeTypeFontProvider>

embeddedFileInfoCache
	- internal cache

provider
	- a provider which asks for installing the embedded fonts.!
!EmbeddedFreeTypeFontInstaller methodsFor: 'accessing' stamp: ''!
embedFilesInDirectory: aDirectory
	"embed all the files in aDirectory
	EmbeddedFreeTypeFontInstaller new 
		provider: 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]! !

!EmbeddedFreeTypeFontInstaller methodsFor: 'error handling' stamp: ''!
failedToOpen: face index: index
	"Transcript cr; show: 'Failed : ', path asString, '[', i asString,']'."
	"remove all cache entries for path with index >= i"! !

!EmbeddedFreeTypeFontInstaller methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	embeddedFileInfoCache := Dictionary new: 10. "keyed by file size"! !

!EmbeddedFreeTypeFontInstaller methodsFor: 'accessing' stamp: ''!
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 newFaceFromExternalMemory: externalMem index: i.
	face loadFields] 
		on: FT2Error, PrimitiveFailed 
		do:[:e | 
			self failedToOpen:face index: i.
			^ self].
	(face height notNil  and:[face hasFamilyName and:[face hasStyleName and:[face isValid]]])
		ifFalse:[
			self failedToOpen:face index: i.
			^ self]
		ifTrue:[ 
			numFaces ifNil: [numFaces := face numFaces].
			info := FreeTypeEmbeddedFileInfo new
				baseName: originalFileBaseName;
				fileContents: bytes;
				index: i;
				familyName: face familyName;
				styleName: face styleName;
				postscriptName: face postscriptName;
				bold: face isBold;
				italic: face isItalic;
				fixedWidth: face isFixedWidth;
				numFaces: numFaces;
				extractAttributesFromNames;
				yourself.
			self addFirstFileInfo: info index: i.
			self cacheEmbeddedFileInfo: info index: i.
			"Transcript show: 'from file : ', info asString."].
	i := i + 1.
	i < numFaces "note, we use < rather than <= , because i is zero based"] whileTrue:[].! !

!EmbeddedFreeTypeFontInstaller methodsFor: 'accessing' stamp: ''!
provider: aProvider
	provider := aProvider! !

!EmbeddedFreeTypeFontInstaller methodsFor: 'adding' stamp: ''!
addFirstFileInfo: aFreeTypeEmbeddedFileInfo index: anInteger 
	provider addFirstFileInfo: aFreeTypeEmbeddedFileInfo index: anInteger! !

!EmbeddedFreeTypeFontInstaller methodsFor: 'accessing' stamp: ''!
installAllFontsIn: aProvider
	self provider: aProvider.
	EmbeddedFreeTypeFontDescription installAllFontsIn: self.	
	embeddedFileInfoCache valuesDo: [ :eachSet | eachSet do: [ :each | provider addFileInfo: each ] ]! !

!EmbeddedFreeTypeFontInstaller methodsFor: 'accessing' stamp: ''!
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! !

!EmbeddedFreeTypeFontInstaller methodsFor: 'accessing' stamp: ''!
cacheEmbeddedFileInfo: aFreeTypeEmbeddedFileInfo index: i

	(embeddedFileInfoCache at:{aFreeTypeEmbeddedFileInfo fileSize. i} ifAbsentPut:[ Set new ])
		add: aFreeTypeEmbeddedFileInfo! !

!EmbeddedFreeTypeFontInstaller class methodsFor: 'class initialization' stamp: ''!
initialize

	self
		resetCurrent;
		current! !

!EmbeddedFreeTypeFontInstaller class methodsFor: 'accessing' stamp: ''!
current
	current ifNil: [ 
		current := self new 
			provider: FreeTypeFontProvider current; 
			yourself.
		FreeTypeFontProvider current addFontInstaller: self current ].
	^ current.! !

!EmbeddedFreeTypeFontInstaller class methodsFor: 'accessing' stamp: ''!
resetCurrent
	| tmpCurrent |
	current ifNil: [ ^ self ].
	tmpCurrent := current.
	current := nil.
	FreeTypeFontProvider current removeFontInstaller: tmpCurrent.! !

!EmbeddedFreeTypeFontInstaller class methodsFor: 'extra fonts registration' stamp: ''!
registerFont: aClassWithFont
	"Do nothing if freetype is disabled currently"
	FreeTypeSystemSettings loadFt2Library 
		ifTrue: [  aClassWithFont installFontsIn: self current ]! !

!EmbeddedFreeTypeFontInstallerTest commentStamp: ''!
An EmbeddedFreeTypeFontInstallerTest is a test class for testing the behavior of EmbeddedFreeTypeFontInstaller!
!EmbeddedFreeTypeFontInstallerTest methodsFor: 'tests' stamp: ''!
testinstallAllFontsIn

	| provider fileInfos families |
	provider := self currentProviderOrError 
								updateEmbeddedFreeTypeFonts;
								yourself.
	fileInfos := provider fileInfosByFamilyAndGroup.

	self 
		assert: fileInfos keys size > 1;
		assert: (fileInfos includesKey: 'Source Sans Pro');
		assert: (fileInfos includesKey: 'Source Code Pro').

	families := provider families.
	
	self 
		assert: (families includesKey: 'Source Sans Pro');
		assert: (families includesKey: 'Source Code Pro').! !

!EmbeddedFreeTypeFontInstallerTest methodsFor: 'tests' stamp: ''!
testIsRegistred
	| installer provider |
	installer := self currentInstallerOrError.
	provider := self currentProviderOrError.
	self assert: (provider includesInstaller: installer)! !

!EmbeddedFreeTypeFontInstallerTest methodsFor: 'accessing' stamp: ''!
currentInstallerOrError
	| installer |
	installer := EmbeddedFreeTypeFontInstaller readSlotNamed: #current.
	self assert: installer notNil.
	^ installer! !

!EmbeddedFreeTypeFontInstallerTest methodsFor: 'accessing' stamp: ''!
currentProviderOrError
	| provider |
	provider := FreeTypeFontProvider readSlotNamed: #current.
	self assert: provider notNil.
	^ provider! !

!EmbeddedMenuMorph commentStamp: ''!
Menu designed to be embedded in another morph rather than popped up directly.!
!EmbeddedMenuMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Draw the receiver on the canvas."

	self perform: #drawOn: withArguments: {aCanvas} inSuperclass: Morph.
	self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! !

!EmbeddedMenuMorph methodsFor: 'keyboard control' stamp: ''!
keyboardFocusChange: aBoolean
	"Nasty hack for scrolling upon keyboard focus."

	super keyboardFocusChange: aBoolean.
	aBoolean
		ifTrue: [(self ownerThatIsA: GeneralScrollPaneMorph) ifNotNil: [:sp |
					sp scrollToShow: self bounds]]
		ifFalse: [self selectItem: nil event: nil]! !

!EmbeddedMenuMorph methodsFor: 'control' stamp: ''!
selectItem: aMenuItem event: anEvent
	"Deselect any sibling menus."
	
	self owner ifNotNil: [
		|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: 'selecting' stamp: ''!
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: 'accessing' stamp: ''!
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: 'keyboard control' stamp: ''!
handlesKeyboard: evt
	"Answer whether the receiver handles the keystroke represented by the event"

	^true! !

!EmbeddedMenuMorph methodsFor: 'events' stamp: ''!
keyDown: evt
	"Handle tabbing and arrows and cr/space."

	| key |
		
	key := evt key.
	(key isArrowLeft or: [ key isArrowRight ])
		ifTrue: [ (selectedItem notNil and: [ selectedItem hasSubMenu ])
				ifTrue: [ evt hand newMouseFocus: selectedItem subMenu.
					selectedItem subMenu moveSelectionDown: 1 event: evt.
					^ evt hand newKeyboardFocus: selectedItem subMenu ] ].
	
	key isArrowUp ifTrue: [ ^ self moveSelectionDown: -1 event: evt ].	"up arrow key"
	key isArrowDown ifTrue: [ ^ self moveSelectionDown: 1 event: evt ].	"down arrow key"
	key = KeyboardKey pageUp ifTrue: [ ^ self moveSelectionDown: -5 event: evt ].	"page up key"
	key = KeyboardKey pageDown ifTrue: [ ^ self moveSelectionDown: 5 event: evt ].	"page down key"

	self window ifNotNil: [:win |
		(win handlesKeyDown: evt) ifTrue: [
			(win keyDown: evt) ifTrue: [^true]]].! !

!EmbeddedMenuMorph methodsFor: 'events' stamp: ''!
keyStroke: event
	"Handle tabbing and arrows and cr/space."

	| selectable |

	self window ifNotNil: [:win |
		(win handlesKeyStroke: event) ifTrue: [
			(win keyStroke: event) ifTrue: [^true]]].
	event key = KeyboardKey space
		ifTrue: [ selectedItem
			ifNotNil: [ ^ selectedItem hasSubMenu
					ifTrue: [ event hand newMouseFocus: selectedItem subMenu.
						selectedItem subMenu takeKeyboardFocus ]
					ifFalse: [ selectedItem invokeWithEvent: event ] ].
		(selectable := self items) size = 1 ifTrue: [ ^ selectable first invokeWithEvent: event ].
		^ self ].! !

!EmbeddedMenuMorph methodsFor: 'keyboard control' stamp: ''!
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 isMenuItemMorph) 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: 'selecting' stamp: ''!
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: 'accessing' stamp: ''!
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: 'selecting' stamp: ''!
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: 'selecting' stamp: ''!
selectPrefix: aString
	"Answer the first subitem that has text that matches the given prefix.
	Answer nil if none.
	Disable non-matching items and enable matching items."

	| firstMatch|
	self items do: [:item | | match |
		match := aString isEmpty or: [item contents asString asLowercase beginsWith: aString].
		item isEnabled: match.
		(match and: [firstMatch isNil]) ifTrue: [firstMatch := item]].
	^firstMatch! !

!EmbeddedMenuMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"Draw the receiver on the canvas."

	self perform: #drawOnAthensCanvas: withArguments: {anAthensCanvas} inSuperclass: Morph.
	self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOnAthensCanvas: anAthensCanvas]! !

!EmbossedStringMorph commentStamp: ''!
A label that underdraws to the top-left and/or bottom-right with a lighter and/or darker colour to the receiver.!
!EmbossedStringMorph methodsFor: 'drawing' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."
	
	super initialize.
	self
		style: #inset;
		trackPaneColor: true! !

!EmbossedStringMorph methodsFor: 'accessing' stamp: ''!
style
	"Answer the value of style"

	^ style! !

!EmbossedStringMorph methodsFor: 'initialization' stamp: ''!
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: 'accessing' stamp: ''!
style: anObject
	"Set the value of style"

	style := anObject.
	self changed! !

!EmbossedStringMorph methodsFor: 'accessing' stamp: ''!
styleSymbols
	"Answer the valid styles."

	^#(plain inset insetNoHighlight raised raisedNoHighlight)! !

!EmbossedStringMorph methodsFor: 'accessing' stamp: ''!
measureContents
	"Measure the contents for fitting. Add 2@2 for hi/lowlights."

	^super measureContents + 2! !

!EmbossedStringMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Set the color."
	
	(paneColor notNil and: [self trackPaneColor])
		ifTrue: [self color: paneColor].
	super adoptPaneColor: paneColor! !

!EmbossedStringMorph methodsFor: 'accessing' stamp: ''!
trackPaneColor: anObject
	"Set the value of trackPaneColor"

	trackPaneColor := anObject! !

!EmbossedStringMorph methodsFor: 'accessing' stamp: ''!
trackPaneColor
	"Answer the value of trackPaneColor"

	^ trackPaneColor! !

!EmptyLayout commentStamp: ''!
Empty top-level layout used to delimit the layout chains.!
!EmptyLayout methodsFor: 'extending' stamp: ''!
extend: someSlots
	^ FixedLayout new
		slotScope: (LayoutEmptyScope instance extend: someSlots)! !

!EmptyLayout methodsFor: 'extending' stamp: ''!
extendVariable: someSlots
	^ VariableLayout new
		slotScope: (LayoutEmptyScope extend: someSlots)! !

!EmptyLayout methodsFor: 'extending' stamp: ''!
extendDoubleByte
	^ DoubleByteLayout new! !

!EmptyLayout methodsFor: 'extending' stamp: ''!
extendByte
	^ ByteLayout new! !

!EmptyLayout methodsFor: 'extending' stamp: ''!
extendWord
	^ WordLayout new! !

!EmptyLayout methodsFor: 'extending' stamp: ''!
extendWeak
	^ WeakLayout new! !

!EmptyLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	| aHost |
	
	aHost := self host 
		ifNotNil: [ :foundHost | foundHost asRingMinimalDefinitionIn: anRGEnvironment ]
		ifNil: [ self error: 'Cannot create model for an empty layout without a host'].

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGEmptyLayout parent: aHost]
! !

!EmptyLayout methodsFor: 'extending' stamp: ''!
extendDoubleWord
	^ DoubleWordLayout new! !

!EmptyLayout class methodsFor: 'instance creation' stamp: ''!
instance
	^ instance ifNil: [ instance := self new ]! !

!EncodedCharSet commentStamp: ''!
An abstract superclasss of the classes that represent encoded character sets.  In the old implementation, the charsets had more important role.  However, in the current implementation, the subclasses are used only for keeping the backward compatibility.

	The other confusion comes from the name of "Latin1" class.  It used to mean the Latin-1 (ISO-8859-1) character set, but now it primarily means that the "Western European languages that are covered by the characters in Latin-1 character set.
!
!EncodedCharSet class methodsFor: 'character classification' stamp: ''!
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: 'class methods' stamp: ''!
leadingChar

	self subclassResponsibility.! !

!EncodedCharSet class methodsFor: 'accessing - displaying' stamp: ''!
printingDirection

	self subclassResponsibility.! !

!EncodedCharSet class methodsFor: 'class methods' stamp: ''!
charsetAt: encoding

	^ EncodedCharSets at: encoding + 1 ifAbsent: [Unicode].! !

!EncodedCharSet class methodsFor: 'character classification' stamp: ''!
canBeGlobalVarInitial: char

	| leadingChar |
	leadingChar := char leadingChar.

	leadingChar = 0 ifTrue: [^ self isUppercase: char].
	^ self isLetter: char.! !

!EncodedCharSet class methodsFor: 'initialize' stamp: ''!
initialize
	"self initialize"
	
	EncodedCharSets := Array new: 256.
	self allSubclassesDo: [:each | each initialize]! !

!EncodedCharSet class methodsFor: 'accessing - displaying' stamp: ''!
scanSelector
	^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern:! !

!EncodedCharSet class methodsFor: 'class methods' stamp: ''!
ucsTable

	^ ucsTable! !

!EncodedCharSet class methodsFor: '*Text-Scanning' stamp: ''!
scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX font: aFont
	"the default for scanning multibyte characters- other more specific encodings may do something else"
	^aFont scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX! !

!EncodedCharSet class methodsFor: 'character classification' stamp: ''!
isDigit: char
	"Answer whether the receiver is a digit."

	| value |
	value := char asciiValue.
	^ value >= 48 and: [value <= 57].! !

!EncodedCharSet class methodsFor: 'class methods' stamp: ''!
isCharset

	^ true.! !

!EncodedCharSet class methodsFor: 'class methods' stamp: ''!
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: 'character classification' stamp: ''!
canBeNonGlobalVarInitial: char

	| leadingChar |
	leadingChar := char leadingChar.

	leadingChar = 0 ifTrue: [^ self isLowercase: char].
	^ self isLetter: char.! !

!EncodedCharSet class methodsFor: 'character classification' stamp: ''!
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: ''!
nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	self subclassResponsibility.! !

!EncodedCharSet class methodsFor: 'initialize' stamp: ''!
declareEncodedCharSet: anEncodedCharSetOrLanguageEnvironmentClass atIndex: aNumber
	
	EncodedCharSets at: aNumber put: anEncodedCharSetOrLanguageEnvironmentClass
	
	"this method is used to modularize the old initialize method: 
	EncodedCharSets at: 0+1 put: Unicode.
	EncodedCharSets at: 1+1 put: JISX0208.
	EncodedCharSets at: 2+1 put: GB2312.
	EncodedCharSets at: 3+1 put: KSX1001.
	EncodedCharSets at: 4+1 put: JISX0208.
	EncodedCharSets at: 5+1 put: JapaneseEnvironment.
	EncodedCharSets at: 6+1 put: SimplifiedChineseEnvironment.
	EncodedCharSets at: 7+1 put: KoreanEnvironment.
	EncodedCharSets at: 8+1 put: GB2312.
	EncodedCharSets at: 12+1 put: KSX1001.
	EncodedCharSets at: 13+1 put: GreekEnvironment.
	EncodedCharSets at: 14+1 put: Latin2Environment.
	EncodedCharSets at: 15+1 put: RussianEnvironment.
	EncodedCharSets at: 17+1 put: Latin9Environment.
	EncodedCharSets at: 256 put: Unicode.

	"! !

!EncodedCharSet class methodsFor: 'character classification' stamp: ''!
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: 'accessing - displaying' stamp: ''!
isBreakableAt: index in: text

	self subclassResponsibility.! !

!EncoderForSistaV1 commentStamp: ''!
EncoderForSistaV1 encodes a bytecode set for Sista, the Speculative Inlining Smalltalk Architecture, a project by Clément Bera and Eliot Miranda.  Sista is an optimizer that exists in the Smalltalk image, /not/ in the VM,  and optimizes by substituting normal bytecoded methods by optimized bytecoded methods that may use special bytecodes for which the Cogit can generate faster code.  These bytecodes eliminate overheads such as bounds checks or polymorphic code (indexing Array, ByteArray, String etc).  But the bulk of the optimization performed is in inlining blocks and sends for the common path.  This bytecode set therefore differs from a normal Smalltalk set in providing a set of inlined primitives that do not validate their arguments that the compiler generates only when it can prove that the primitives' arguments are valid.

The basic scheme is that the Cogit generates code containing performance counters.  When these counters trip, a callback into the image is performed, at which point Sista analyses some portion of the stack, looking at performance data for the methods on the stack, and optimises based on the stack and performance data.  Execution then resumes in the optimized code.

The Sista Cogit (e.g. SistaStackToRegisterMappingCogit) adds counters to conditional branches.  Each branch has an executed and a taken count.  On execution the executed count is decremented and if the count goes below zero the VM sends a message at a special index in the specialObjectsArray (as of writing, conditionalCounterTrippedOn:).  Then if the branch is taken the taken count is decremented.  The two counter values allow the Sista optimizer to collect basic block execution paths and to know what are the "hot" paths through execution that are worth agressively optimizing.  Since conditional branches are about 1/6 as frequent as sends, and since they can be used to determine the hot path through code, they are a better choice to count than, for example, method or block entry.

The VM provides a primitive that fills an Array with the state of the counters, and the state of each linked send in a method.  Tthe optimizer obtains the branch and send data for a method via this primitive.

This bytecde set encodes a bytecode set for Smalltalk that lifts limits on the number of literals and branch distances, and extended push integer and push character bytecodes.  Bytecodes are ordered by length to make decoding easier.  Bytecodes marked with an * are extensible via a prefix bytecode.

N.B.  Extension bytecodes can only come before extensible bytecodes, and only if valid (one cannot extend a bytecode extensible by Ext A with an Ext B).  An extensible bytecode consumes (and zeros) its extension(s).  Hence the hidden implicit variables holding extensions are always zero except after a valid sequence of extension bytecodes.

Instance Variables (inherited)

1 Byte Bytecodes
	code	(note)	binary			name
	0-15			0000 iiii 				Push Receiver Variable #iiii
	16-31		0001 iiii				Push Literal Variable #iiii
	32-63		001 iiiii				Push Literal #iiiii
	64-71		01000 iii				Push Temp #iii
	72-75		010010 ii				Push Temp #ii + 8
	76			01001100			Push Receiver
	77			01001101			Push true
	78			01001110			Push false
	79			01001111			Push nil
	80			01010000			Push 0
	81			01010001			Push 1
*	82			01010010			Push thisContext, (then Extend B = 1 => push thisProcess)
	83			01010011			Duplicate Stack Top
	84-87		010101 ii				UNASSIGNED
	88-91		010110 ii				Return Receiver/true/false/nil
	92			01011100			Return top
	93			01011101			BlockReturn nil
*	94			01011110			BlockReturn Top [* return from enclosing block N, N = Extend A, then jump by Ext B ]
*	95			01011111			Nop
	96-111		0110 iiii				Send Arithmetic Message #iiii #(#+ #- #< #> #<= #>= #= #~= #* #/ #\\ #@ #bitShift: #// #bitAnd: #bitOr:)
	112-127	0111 iiii					Send Special Message #iiii #(#at: #at:put: #size #next #nextPut: #atEnd #== class #~~ #value #value: #do: #new #new: #x #y)
	128-143	1000 iiii					Send Literal Selector #iiii With 0 Argument
	144-159	1001 iiii					Send Literal Selector #iiii With 1 Arguments
	160-175	1010 iiii					Send Literal Selector #iiii With 2 Arguments
	176-183	10110 iii					Jump iii + 1 (i.e., 1 through 8)
	184-191	10111 iii					Pop and Jump 0n True iii +1 (i.e., 1 through 8)
	192-199	11000 iii					Pop and Jump 0n False iii +1 (i.e., 1 through 8)
	200-207	11001 iii					Pop and Store Receiver Variable #iii
	208-215	11010 iii					Pop and Store Temporary Variable #iii
	216		11011000				Pop Stack Top
	217		11011001				Unconditional trap [Sista specific]
	218-219	1101101 i				UNASSIGNED
	220-223	110111 ii					UNASSIGNED

2 Byte Bytecodes
*	224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A) A is an unsigned extension.
*	225		11100001	bbbbbbbb	Extend B (Ext B = Ext B prev * 256 + Ext B) B is a signed extension.
*	226		11100010	iiiiiiii		Push Receiver Variable #iiiiiiii (+ Extend A * 256)
*	227		11100011	iiiiiiii		Push Literal Variable #iiiiiiii (+ Extend A * 256)
*	228		11100100	iiiiiiii		Push Literal #iiiiiiii (+ Extend A * 256)
	229		11100101	iiiiiiii		Push Temporary Variable #iiiiiiii
	230		11100110	iiiiiiii		UNASSIGNED (was pushNClosureTemps)
	231		11100111	jkkkkkkk	Push (Array new: kkkkkkk) (j = 0)
									&	Pop kkkkkkk elements into: (Array new: kkkkkkk) (j = 1)
*	232		11101000	iiiiiiii		Push Integer #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)
*	233		11101001	iiiiiiii		Push Character #iiiiiiii (+ Extend B * 256)
**	234		11101010	iiiiijjj		Send Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments
**	235	(1)	11101011	iiiiijjj	ExtendB < 64
										ifTrue: [Send To Superclass Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments]
										ifFalse: [Send To Superclass of Stacked Class Literal Selector #iiiii (+ Extend A * 32) with jjj (+ (Extend B bitAnd: 63) * 8) Arguments]
	236		11101100	iiiiiiii		Call Mapped inlined primitive #iiiiiiii [Sista specific]
*	237		11101101	iiiiiiii		Jump #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)
**	238		11101110	iiiiiiii		Pop and Jump 0n True #iiiiiiii (+ Extend B * 256, where Extend B >= 0) 
**	239		11101111	iiiiiiii		Pop and Jump 0n False #iiiiiiii (+ Extend B * 256, where Extend B >= 0)
*	240		11110000	iiiiiiii		Pop and Store Receiver Variable #iiiiiii (+ Extend A * 256) 
*	241		11110001	iiiiiiii		Pop and Store Literal Variable #iiiiiiii (+ Extend A * 256) 
	242		11110010	iiiiiiii		Pop and Store Temporary Variable #iiiiiiii
*	243		11110011	iiiiiiii		Store Receiver Variable #iiiiiii (+ Extend A * 256) 
*	244		11110100	iiiiiiii		Store Literal Variable #iiiiiiii (+ Extend A * 256) 
	245		11110110	iiiiiiii		Store Temporary Variable #iiiiiiii
	246-247	1111011 i	xxxxxxxx	UNASSIGNED

3 Byte Bytecodes
	248	(2)	11111000 	iiiiiiii	mssjjjjj		Call Primitive #iiiiiiii + (jjjjj * 256) 
								m=1 means inlined primitive, no hard return after execution. 
								ss defines the unsafe operation set used to encode the operations. 
								(ss = 0 means sista unsafe operations, ss = 01 means lowcode operations, other numbers are not used) [Sista specific]
	249		11111001 	xxxxxxxx	siyyyyyy	push Closure Compiled block literal index xxxxxxxx (+ Extend A * 256) numCopied yyyyyy receiverOnStack: s = 1 ignoreOuterContext: i = 1
**	250		11111010 	eeiiikkk		jjjjjjjj		Push Closure Num Copied iii (+ExtA//16*8) Num Args kkk (+ ExtA\\16*8) BlockSize jjjjjjjj (+ExtB*256). ee = num extensions
	251		11111011 	kkkkkkkk	jjjjjjjj		Push Temp At kkkkkkkk In Temp Vector At: jjjjjjjj
*	252	(3)	11111100 	kkkkkkkk	jjjjjjjj		Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj
*	253	(3)	11111101 	kkkkkkkk	jjjjjjjj		Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj
	254		11111110	kkkkkkkk	jjjjjjjj		UNASSIGNED
	255		11111111	xxxxxxxx	jjjjjjjj			UNASSIGNED

(1) Bytecode 235 is a super send bytecode that starts the lookup in the superclass of some class.  It has two forms, "normal" and "directed". In the normal form, the class is the value of the method's methodClassAssociation which must be the last literal.  In the directed form the class is the class on top of stack.

(2) The Call Primitive Bytecode specifies either a primitive in the primitive table (m=0) or an inlined primitive (m=1). Non-inlined primtiives from the primitive table have index (jjjjjjj * 256) + iiiiiiii and return from the method if they succeed.  This bytecode is only valid as the first bytecode of a method.  Inline primitives have index (jjjjjjj * 256) + iiiiiiii, cannot fail, and do not return when they succeed, yielding a result (typically on top of stack after popping their arguments, but possibly in a byte data stack, for example for unboxed floating-point primitives).

[Sista specific] The 3 bytecodes with this annotations are not used in the default Pharo runtime but only in specific circumstances (Sista runtime, etc.)

Here is the specification of the sista unsafe instructions (unsafe operations, set 00). The lowcode set uses external specifications.

We sort the inline primitive operations by arity.  Nullary primitives occupy the 0-999 range. Unary primitives occupy the 1-1999 range, up until 5 args. Primitives starting at 6000 are jumps. 6000-6999 are 1 parameter jump (the distance), 7000-7999 are 2 parameters jump and jumps over 8000 have 3 parameters.

All jumps encoded as inlined primitives (mapped or not) use the pushIntegerLong: scheme to push their jump size on stack.

We define the following *non-mapped* inlined primitives:
1000	rawClass
not a forwarder => Behavior (Same as class special send, but receiver is not a forwarder)
1001	numSlots
pointer object => Smi between 0 and SmallInteger maxVal // 4 - 1 (Answers total size in pointer-sized slots)
1002	numBytes
byte object => Smi between 0 and SmallInteger maxVal - 9 (Includes compiled code)
1003	numShorts
short object => Smi between 0 and SmallInteger maxVal - 9
1004	numWords
word object => Smi between 0 and SmallInteger maxVal - 9
1005	numDoubleWords
double word object => Smi between 0 and SmallInteger maxVal - 9
1011	rawNew
literal which is a fixed-sized behavior => instance of the receiver with fields nilled out
1012	rawNewNoInit
literal which is a fixed-sized behavior => instance of the receiver (Fields of returned value contain undefined data)
1020	objectIdentityHash
non-immediate and non-behavior => 22 bits strictly positive Smi
1021	smiIdentityHash
Smi => Smi
1022	charIdentityHash
Character => 22 bits strictly positive Smi
1023	smallfloatIdentityHash
SmallFloat => Smi
1024	behaviorIdentityHash
Behavior => 22 bits strictly positive Smi
1030	characterAsInteger
Character => 22 bits strictly positive Smi (Unicode)
1031	smallFloatAsInteger
SmallFloat => Smi
1032	smiAsFloat
Smi => SmallFloat
1039	unforwardNonImmediate
non immediate => Not a forwarder
1040	unforward
Anything => Not a forwarder
1041	possibleRoot
non-immediate, not a forwarder => receiver is returned (should be effect-only) (If old, becomes gray and remembered to allow many unchecked stores in a row afterwards)

2000	smiAdd:
Smi, Smi => Smi (no overflow, optimised if one operand is a constant)
2001	smiSub:
Smi, Smi => Smi (no overflow, optimised if one operand is a constant)
2002	smiMul:
Smi, Smi => Smi (no overflow, optimised if one operand is a constant)
2003	smiDivide:
Smi, Smi => Smi (no overflow, optimised if one operand is a constant)
2004	smiDiv:
Smi, Smi => Smi (no overflow, optimised if one operand is a constant)
2005	smiMod:
Smi, Smi => Smi (no overflow, optimised if one operand is a constant)
2006	smiQuo:
Smi, Smi => Smi (no overflow, optimised if one operand is a constant)
2016	smiBitAnd:
Smi, Smi => Smi (optimised if one operand is a constant)
2017	smiBitOr:
Smi, Smi => Smi (optimised if one operand is a constant)
2018	smiBitXor:
Smi, Smi => Smi (optimised if one operand is a constant)
2019	smiBitShiftLeft:
Smi greater or equal to 0, Smi greater or equal to 0 => Smi (no overflow, optimised if arg1 is a constant)
2020	smiBitShiftRight:
Smi, Smi greater or equal to 0 => Smi (optimised if arg1 is a constant)
2032	smiGreater:
Smi, Smi => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)
2033	smiLess:
Smi, Smi => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)
2034	smiGreaterOrEqual:
Smi, Smi => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)
2035	smiLessOrEqual:
Smi, Smi => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)
2036	smiEquals:
Smi, Smi => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)
2037	smiNotEquals:
Smi, Smi => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)
2038	rawEqualsEquals:
not a forwarder, not a forwarder => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)
2039	rawNotEqualsEquals:
not a forwarder, not a forwarder => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)
2048	rawNewColon:
literal which is a variable-sized behavior, Smi => instance of receiver, fields nilled/zeroed out (optimised if arg1 is a constant)
2049	rawNewColonNoInit:
literal which is a variable-sized behavior, Smi => instance of receiver (Fields of returned value contain undefined data, optimised if arg1 is a constant)
2064	pointerAt:
Pointer object (Fixed sized or not) and not a context, Smi =>  (1-based, optimised if arg1 is a constant)
2065	maybeContextPointerAt:
Pointer object (Fixed sized or not), Smi =>  (1-based, optimised if arg1 is a constant)
2066	byteAt:
byte object, Smi => 8 bits unsigned Smi (1-based, optimised if arg1 is a constant)
2067	shortAt:
short object, Smi => 16 bits unsigned Smi (1-based, optimised if arg1 is a constant)
2068	wordAt:
word object, Smi => 32 bits unsigned Smi (1-based, optimised if arg1 is a constant)
2069	doubleWordAt:
double word object, Smi => 64 bits unsigned Smi or LargePositiveInteger (1-based, optimised if arg1 is a constant)

3000	pointerAt:put:
Mutable pointer object (Fixed sized or not) and not a context, Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)
3001	storeCheckPointerAt:put:
Mutable pointer object (Fixed sized or not) and not a context, Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)
3002	maybeContextPointerAt:put:
Mutable pointer object (Fixed sized or not), Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)
3003	maybeContextStoreCheckPointerAt:put:
Mutable pointer object (Fixed sized or not), Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)
3004	byteAt:put:
Mutable byte object, Smi, 8 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)
3005	shortAt:put:
Mutable short object, Smi, 16 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)
3006	wordAt:put:
Mutable word object, Smi, 32 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)
3007	doubleWordAt:put:
Mutable double word object, Smi, 64 bits unsigned Smi or LargePositiveInteger => arg2 (1-based, optimised if arg1 is a constant)

6000	backjumpNoInterrupt
literal which is a Smi
7016	jumpWritable:
Not a forwarder, literal which is a Smi
7017	jumpReadOnly:
Not a forwarder, literal which is a Smi
7018	jumpYoung:
Not a forwarder, literal which is a Smi
7019	jumpOld:
Not a forwarder, literal which is a Smi

8000	instanceOf:jumpTrue:
Anything, literal which is a Behavior, literal which is a Smi
8001	instanceOf:jumpFalse:
Anything, literal which is a Behavior, literal which is a Smi
8002	instanceOfOneOf:jumpTrue:
Anything, Array of behaviors, literal which is a Smi
8003	instanceOfOneOf:jumpFalse:
Anything, Array of behaviors, literal which is a Smi

Mapped primitives are a bit different. They're sorting by arity up to 3 parameters (0-49 is nullary, 50-99 is binary, etc.). 200 and over are variable number of parameter instructions. 250 and over are mapped jumped. 

We define the folloing mapped primitives:
50	ensureEnoughSlots
literal which is a Smi => ret value is receiver
150	immCheckPointerAt:put:
pointer object (Fixed sized or not) and not a context, Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)
151	immCheckStoreCheckPointerAt:put:
pointer object (Fixed sized or not) and not a context, Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)
152	immCheckMaybeContextPointerAt:put:
pointer object (Fixed sized or not), Smi, Anything => arg2 (1-based, optimised if arg1 is a constant (Concept-only, contexts are mutable right now))
153	immCheckMaybeContextStoreCheckPointerAt:put:
pointer object (Fixed sized or not), Smi, Anything => arg2 (1-based, optimised if arg1 is a constant (Concept-only, contexts are mutable right now))
154	immCheckByteAt:put:
byte object, Smi, 8 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)
155	immCheckShortAt:put:
short object, Smi, 16 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)
156	immCheckWordAt:put:
word object, Smi, 32 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)
157	immCheckDoubleWordAt:put:
double word object, Smi, 64 bits unsigned Smi or LargePositiveInteger => arg2 (1-based, optimised if arg1 is a constant)
200	withArgs:executeMethod:
literal index of the method to call on top of stack =>  (variable number of parameters (on contrary to what the selector suggests, no array), the index and not the method is pushed for efficient inline caches.)
250	backjumpAlwaysInterrupt
literal which is a Smi
!
!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genReturnTop
	"92		1011100		Return Stack Top From Message"
	stream nextPut: 92! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushLiteral: literalIndex
	| extendedIndex |
	(literalIndex < 0 or: [literalIndex > 32768]) ifTrue:
		[^self outOfRangeError: 'index' index: literalIndex range: 0 to: 32768].
	literalIndex < 32 ifTrue: 
		["32-63 	001iiiii 	Push Literal #iiiii"
		 stream nextPut: 32 + literalIndex.
		 ^self].
	"228		11100100	i i i i i i i i	Push Literal #iiiiiiii (+ Extend A * 256)"
	(extendedIndex := literalIndex) > 255 ifTrue:
		[self genUnsignedSingleExtendA: extendedIndex // 256.
		 extendedIndex := extendedIndex \\ 256].
	stream
		nextPut: 228;
		nextPut: extendedIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genSend: selectorLiteralIndex numArgs: nArgs
	| extendedIndex extendedNArgs |
	(selectorLiteralIndex < 0 or: [selectorLiteralIndex > 65535]) ifTrue:
		[^self outOfRangeError: 'selectorLiteralIndex' index: selectorLiteralIndex range: 0 to: 65535].
	(nArgs < 0 or: [nArgs > 31]) ifTrue:
		[^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"].
	(selectorLiteralIndex < 16 and: [nArgs < 3]) ifTrue: 
	 	["128-143	1000 iiii			Send Literal Selector #iiii With 0 Argument
		  144-159	1001 iiii			Send Literal Selector #iiii With 1 Arguments
		  160-175	1010 iiii			Send Literal Selector #iiii With 2 Arguments"
		 stream nextPut: 128 + (nArgs * 16) + selectorLiteralIndex.
		 ^self].
	(extendedIndex := selectorLiteralIndex) > 31 ifTrue:
		[self genUnsignedSingleExtendA: extendedIndex // 32.
		 extendedIndex := extendedIndex \\ 32].
	(extendedNArgs := nArgs) > 7 ifTrue:
		[self genUnsignedSingleExtendB: extendedNArgs // 8.
		 extendedNArgs := extendedNArgs \\ 8].
	"234		11101010	i i i i i j j j	Send Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"
	stream
		nextPut: 234;
		nextPut: extendedNArgs + (extendedIndex * 8)! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushTemp: tempIndex
	(tempIndex < 0 or: [tempIndex > 63]) ifTrue:
		[^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63].
	tempIndex < 12 ifTrue: 
		["64-71		01000 i i i		Push Temporary Variable #iii
		   72-75	010010 i i		Push Temporary Variable #ii + 8"
		 stream nextPut: 64 + tempIndex.
		 ^self].
	"229		11100101	i i i i i i i i	Push Temporary Variable #iiiiiiii"
	stream
		nextPut: 229;
		nextPut: tempIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genStoreRemoteTemp: tempIndex inVectorAt: tempVectorIndex
	"*252	(3)	11111100 	kkkkkkkk	sjjjjjjj		Store Temp At kkkkkkkk In Temp Vector At: jjjjjjj s = 1 implies remote inst var access instead of remote temp vector access"
	(tempIndex < 0 or: [tempIndex >= 256]) ifTrue:
		[^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255].
	(tempVectorIndex < 0 or: [tempVectorIndex >= 128]) ifTrue:
		[^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 127].
	stream
		nextPut: 252;
		nextPut: tempIndex;
		nextPut: tempVectorIndex! !

!EncoderForSistaV1 methodsFor: 'special literal encodings' stamp: ''!
isSpecialLiteralForPush: literal
	^literal == false
	  or: [literal == true
	  or: [literal == nil
	  or: [(literal isInteger and: [literal between: -32768 and: 32767])
	  or: [(literal isCharacter and: [literal asInteger between: 0 and: 65535])]]]]! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushThisContext
	"82			01010010			Push thisContext, (then e.g. Extend B 1 = push thisProcess)"
	stream nextPut: 82! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushInstVar: instVarIndex
	(instVarIndex between: 0 and: 15) ifTrue:
		["0-15 	0000iiii 	Push Receiver Variable #iiii"
		 stream nextPut: 0 + instVarIndex.
		 ^self].
	self genPushInstVarLong: instVarIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genStoreLiteralVar: literalIndex
	"244		11110100	iiiiiiii		Store Literal Variable #iiiiiiii (+ Extend A * 256)"
	(literalIndex < 0 or: [literalIndex > 32768]) ifTrue:
		[^self outOfRangeError: 'index' index: literalIndex range: 0 to: 32768].
	literalIndex > 255 ifTrue: 
		[self genUnsignedSingleExtendA: literalIndex // 256].
	stream
		nextPut: 244;
		nextPut: literalIndex \\ 256! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushReceiver
	"76			01001100		Push Receiver"
	stream nextPut: 76! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genStorePopInstVarLong: instVarIndex
	"240		11110000	iiiiiiii		Pop and Store Receiver Variable #iiiiiii (+ Extend A * 256)"
	(instVarIndex < 0 or: [instVarIndex > 65535]) ifTrue:
		[^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 65535].
	instVarIndex > 255 ifTrue:
		[self genUnsignedSingleExtendA: instVarIndex // 256].
	stream
		nextPut: 240;
		nextPut: instVarIndex \\ 256! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genStorePopTemp: tempIndex
	"208-215	11010 iii			Pop and Store Temporary Variable #iii
	 242		11110010	iiiiiiii	Pop and Store Temporary Variable #iiiiiiii"
	(tempIndex < 0 or: [tempIndex > 63]) ifTrue:
		[^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63].
	tempIndex < 8 ifTrue:
		[stream nextPut: 208 + tempIndex.
		 ^self].
	stream
		nextPut: 242;
		nextPut: tempIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushThisProcess
	"82			01010010			Push thisContext, (then e.g. Extend B 1 = push thisProcess)"
	stream nextPut: 225.
	stream nextPut: 1.
	stream nextPut: 82.! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushCharacter: aCharacterOrCode
	"233		11101001	i i i i i i i i	Push Character #iiiiiiii (+ Extend B * 256)"
	"Why restrict the range to 16 bits when we could encode arbitrarily 32-bit Characters?
	 Well, 16 bits requires 4 bytes (extB + byte, 78 + byte) and so beyond this range we
	 lose space verses a single-byte pushLiteral and a 4 byte Character literal on 32-bits.
	 And generating the same bytecode on 64-bit and 32-bit is important if we want to be
	 able to load binary code from one to the other (e.g. via Fuel)."
	| code |
	code := aCharacterOrCode isInteger ifTrue: [aCharacterOrCode] ifFalse: [aCharacterOrCode asInteger].
	(code < 0 or: [code > 65535]) ifTrue:
		[^self outOfRangeError: 'character' index: code range: 0 to: 65535].
	(code > 255) ifTrue:
		[self genUnsignedSingleExtendB: (code bitShift: -8)].
	stream
		nextPut: 233;
		nextPut: (code bitAnd: 255)! !

!EncoderForSistaV1 methodsFor: 'special literal encodings' stamp: ''!
sizePushFullClosure: compiledBlockLiteralIndex numCopied: numCopied receiverOnStack: rcvrOnStack ignoreOuterContext: ignoreOuterContext
	^self sizeOpcodeSelector: #genPushFullClosure:numCopied:receiverOnStack:ignoreOuterContext: withArguments: {compiledBlockLiteralIndex.numCopied.rcvrOnStack.ignoreOuterContext}! !

!EncoderForSistaV1 methodsFor: 'extended bytecode generation' stamp: ''!
genPushFullClosure: compiledBlockLiteralIndex numCopied: numCopied receiverOnStack: receiverOnStack outerContextNeeded: outerContextNeeded
	"*	249		11111001 	xxxxxxxx	siyyyyyy	push Closure Compiled block literal index xxxxxxxx (+ Extend A * 256) numCopied yyyyyy receiverOnStack: s = 1 ignoreOuterContext: i = 1"
	| extendedIndex |
	(numCopied < 0 or: [numCopied > 64]) ifTrue:
		[self outOfRangeError: 'num copied' index: numCopied range: 0 to: 64].
	(compiledBlockLiteralIndex < 0 or: [compiledBlockLiteralIndex > 32768]) ifTrue:
		[^self outOfRangeError: 'index' index: compiledBlockLiteralIndex range: 0 to: 32768].
	(extendedIndex := compiledBlockLiteralIndex) > 255 ifTrue:
		[self genUnsignedSingleExtendA: extendedIndex // 256.
		 extendedIndex := extendedIndex \\ 256].
	stream
		nextPut: 249;
		nextPut: extendedIndex;
		nextPut: receiverOnStack asBit << 7 + (outerContextNeeded not asBit << 6) + numCopied! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genJump: distance
	(distance > 0 and: [distance < 9]) ifTrue:
		["176-183	10110 iii			Jump iii + 1 (i.e., 1 through 8)"
		 stream nextPut: 175 + distance.
		 ^self].
	"237		11101101	iiiiiiii		Jump #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)"
	^self genJumpLong: distance! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genSignedSingleExtendB: extendedIndex
	(extendedIndex between: -128 and: 127) ifFalse:
		[^self outOfRangeError: 'index' index: extendedIndex range: -128 to: 127].
	"225		11100001	sbbbbbbb	Extend B (Ext B = Ext B prev * 256 + Ext B)"
	stream
		nextPut: 225;
		nextPut: (extendedIndex >= 0 ifTrue: [extendedIndex] ifFalse: [extendedIndex + 256])! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushInteger: anInteger
	"80			01010000				Push 0
	 81			01010001				Push 1
	 232		11101000	i i i i i i i i	Push Integer #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)"
	anInteger = 0 ifTrue:
		[stream nextPut: 80.
		 ^self].
	anInteger = 1 ifTrue:
		[stream nextPut: 81.
		 ^self].
	(anInteger < 0 or: [anInteger > 255]) ifTrue:
		[^self genPushIntegerLong: anInteger].
	stream
		nextPut: 232;
		nextPut: (anInteger bitAnd: 255)! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genReturnTopToCaller
	"94		01011110		Return Stack Top From Block [* return from enclosing block N, ExtA]"
	"If extended, the least significant bit of the extension determines if we return to the caller or not
	 and the most significant bits determine how many levels of the static chain to return from.
		ExtA = iiiiiiij
		iiiiiii=0,j=0	=>	return to caller
		iiiiiii=0,j=1	=>	illegal
		iiiiiii=1,j=0	=>	return to outerContext
		iiiiiii=1,j=1	=>	return to outerContext sender/return from outerContext
		iiiiiii=2,j=0	=>	return to outerContext outerContext
		iiiiiii=2,j=1	=>	return to outerContext outerContext sender/return from outerContext outerContext
		etc"

	stream nextPut: 94! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genUnsignedSingleExtendA: extendedIndex
	(extendedIndex between: 0 and: 255) ifFalse:
		[^self outOfRangeError: 'index' index: extendedIndex range: 0 to: 255].
	"224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)"
	stream
		nextPut: 224;
		nextPut: extendedIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genCallPrimitive: primitiveIndex
	"248		11111000	i i i i i i i i	0jjjjjjj		Call Primitive #iiiiiiii + (jjjjjjj * 256)"
	"N.B. We could have made CallPrimitive a 2-byte code taking an extension, but that would
	 complicate the VM's determination of the primitive number and the primitive error code
	 store since the extension, being optional, would make the sequence variable length."
	(primitiveIndex < 1 or: [primitiveIndex > 65535]) ifTrue:
		[self outOfRangeError: 'primitive index' index: primitiveIndex range: 1 to: 65535].
	stream
		nextPut: 248;
		nextPut: (primitiveIndex bitAnd: 255);
		nextPut: (primitiveIndex bitShift: -8)! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genBranchPopTrue: distance
	(distance > 0 and: [distance < 9]) ifTrue:
		["184-191	10111 iii			Pop and Jump 0n True iii + 1 (i.e., 1 through 8)"
		 stream nextPut: 183 + distance.
		 ^self].
	^self genBranchPopTrueLong: distance! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genReturnReceiver
	"88-91		010110 ii			Return Receiver/true/false/nil"
	stream nextPut: 88! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genReturnSpecialLiteral: aLiteral
	"88-91		010110 ii			Return Receiver/true/false/nil"
	| 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: 88 + index! !

!EncoderForSistaV1 methodsFor: 'special literal encodings' stamp: ''!
sizePushFullClosure: compiledBlockLiteralIndex numCopied: numCopied
	^self sizeOpcodeSelector: #genPushFullClosure:numCopied: withArguments: {compiledBlockLiteralIndex.numCopied}! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genJumpLong: distance
	"237		11101101	iiiiiiii		Jump #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)"
	(distance between: -32768 and: 32767) ifFalse:
		[^self outOfRangeError: 'index' index: distance range: -32768 to: 32767].
	(distance < 0 or: [distance > 255]) ifTrue:
		[self genSignedSingleExtendB: (distance bitShift: -8)].
	stream
		nextPut: 237;
		nextPut: (distance bitAnd: 255)! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genStoreInstVarLong: instVarIndex
	"Only one instruction for inst var store, so there is no long encoding. However this is used only for MaybeContext object, there is no storeInstVar in the image for those and it is very unlikely that anyone would add some. So I did not add a different bytecode for such an uncommon case."
	self genStorePopInstVarLong: instVarIndex.
	self genPushInstVarLong: instVarIndex.! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushNewArray: size
	(size < 0 or: [size > 127]) ifTrue:
		[^self outOfRangeError: 'size' index: size range: 0 to: 127].
	"231		11100111	jkkkkkkk	Push (Array new: kkkkkkk) (j = 0)
									&	Pop kkkkkkk elements into: (Array new: kkkkkkk) (j = 1)"
	stream
		nextPut: 231;
		nextPut: size! !

!EncoderForSistaV1 methodsFor: 'extended bytecode generation' stamp: ''!
genPushIntegerLong: anInteger
	"232		11101000	i i i i i i i i	Push Integer #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)"
	"Why restrict the range to 16 bits when we could encode arbitrarily large integers?
	 Well, 16 bits requires 4 bytes (extB + byte, 78 + byte) and so beyond this range we lose space
	 verses a single-byte pushLiteral and a 4 byte integer literal on 32-bits.  And generating the same
	 bytecode on 64-bit and 32-bit is important if we want to be able to load binary code from one to
	 the other (e.g. via Fuel)."
	(anInteger < -32768 or: [anInteger > 32767]) ifTrue:
		[^self outOfRangeError: 'integer' index: anInteger range: -32768 to: 32767].
	self genSignedSingleExtendB: (anInteger bitShift: -8).
	stream
		nextPut: 232;
		nextPut: (anInteger bitAnd: 255)! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushRemoteTemp: tempIndex inVectorAt: tempVectorIndex
	"251		11111011 	kkkkkkkk	sjjjjjjj		Push Temp At kkkkkkkk In Temp Vector At: jjjjjjj, s = 1 implies remote inst var access instead of remote temp vector access"
	(tempIndex < 0 or: [tempIndex >= 256]) ifTrue:
		[^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255].
	(tempVectorIndex < 0 or: [tempVectorIndex >= 128]) ifTrue:
		[^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 127].
	stream
		nextPut: 251;
		nextPut: tempIndex;
		nextPut: tempVectorIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genSendSpecial: specialSelectorIndex numArgs: nArgs
	self assert: (specialSelectorIndex between: 1 and: Smalltalk specialSelectorSize).
	self assert: nArgs = (Smalltalk specialNargsAt: specialSelectorIndex).
	"Special selector sends.
		96-111		0110 iiii			Send Arithmetic Message #iiii #(#+ #- #< #> #'<=' #'>=' #= #'~=' #* #/ #'\\' #@ #bitShift: #'//' #bitAnd: #bitOr:)
		112-119	01110 iii			Send Special Message #iii #(#at: #at:put: #size ? ? ? #'==' class ? value value: ? ? ? ? ?)"

	stream nextPut: specialSelectorIndex + 95! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genUnsignedMultipleExtendA: extendedIndex
	"224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)"
	extendedIndex > 255 ifTrue:
		[self genUnsignedMultipleExtendA: extendedIndex // 256].
	stream
		nextPut: 224;
		nextPut: extendedIndex \\ 256! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushSpecialLiteral: aLiteral
	"77			01001101			Push true
	 78			01001110			Push false
	 79			01001111			Push nil
	 80			01010000			Push 0
	 81			01010001			Push 1
	 232		11101000	iiiiiiii		Push Integer #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)"
	| index |
	aLiteral isInteger ifTrue:
		[aLiteral == 0 ifTrue:
			[stream nextPut: 80.
			 ^self].
		 aLiteral == 1 ifTrue:
			[stream nextPut: 81.
			 ^self].
		 ^self genPushInteger: aLiteral].
	index := #(true false nil)
					indexOf: aLiteral
					ifAbsent: [^self error: 'push special literal: ', aLiteral printString,  ' is not one of true false nil'].
	stream nextPut: 76 + index! !

!EncoderForSistaV1 methodsFor: 'extended bytecode generation' stamp: ''!
genNop
	"95			01011111			Nop"
	stream nextPut: 95! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genBranchPopFalse: distance
	(distance > 0 and: [distance < 9]) ifTrue:
		["192-199	11000 iii			Pop and Jump 0n False iii + 1 (i.e., 1 through 8)"
		 stream nextPut: 191 + distance.
		 ^self].
	^self genBranchPopFalseLong: distance! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushConsArray: size
	(size < 0 or: [size > 127]) ifTrue:
		[^self outOfRangeError: 'size' index: size range: 0 to: 127].
	"231		11100111	jkkkkkkk	Push (Array new: kkkkkkk) (j = 0)
									&	Pop kkkkkkk elements into: (Array new: kkkkkkk) (j = 1)"
	stream
		nextPut: 231;
		nextPut: size + 128! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushLiteralVar: literalIndex
	| extendedIndex |
	(literalIndex < 0 or: [literalIndex > 32768]) ifTrue:
		[^self outOfRangeError: 'index' index: literalIndex range: 0 to: 32768].
	literalIndex < 16 ifTrue: 
		["16-31		0001 i i i i		Push Literal Variable #iiii"
		 stream nextPut: 16 + literalIndex.
		 ^self].
	"227		11100011	i i i i i i i i	Push Literal Variable #iiiiiiii (+ Extend A * 256)"
	(extendedIndex := literalIndex) > 255 ifTrue:
		[self genUnsignedSingleExtendA: extendedIndex // 256.
		 extendedIndex := extendedIndex \\ 256].
	stream
		nextPut: 227;
		nextPut: extendedIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genBranchPopFalseLong: distance
	"239		11101111	iiiiiiii		Pop and Jump 0n False #iiiiiiii (+ Extend B * 256, where Extend B >= 0)	"
	| distanceMod256 |
	(distance < 0 or: [distance > 32767]) ifTrue:
		[^self outOfRangeError: 'distance' index: distance range: 0 to: 32767].
	distanceMod256 := (distance < 0 or: [distance > 255])
							ifTrue:
								[self genUnsignedSingleExtendB: (distance bitShift: -8).
								 distance bitAnd: 255]
							ifFalse: [distance].
	stream
		nextPut: 239;
		nextPut: distanceMod256! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genUnsignedSingleExtendB: extendedIndex
	(extendedIndex between: 0 and: 255) ifFalse:
		[^self outOfRangeError: 'index' index: extendedIndex range: 0 to: 255].
	"225		11100001	sbbbbbbb	Extend B (Ext B = Ext B prev * 256 + Ext B)"
	stream
		nextPut: 225;
		nextPut: extendedIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPushInstVarLong: instVarIndex
	"226		11100010	i i i i i i i i	Push Receiver Variable #iiiiiiii (+ Extend A * 256)"
	"See also MaybeContextInstanceVariableNode"
	(instVarIndex < 0 or: [instVarIndex > 65535]) ifTrue:
		[^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 65535].
	instVarIndex > 255 ifTrue:
		[self genUnsignedSingleExtendA: instVarIndex // 256].
	stream
		nextPut: 226;
		nextPut: instVarIndex \\ 256! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genPop
	"216		11011000			Pop Stack Top"
	stream nextPut: 216! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genStoreInstVar: instVarIndex
	"243		11110011	iiiiiiii		Store Receiver Variable #iiiiiii (+ Extend A * 256)"
	(instVarIndex < 0 or: [instVarIndex > 65535]) ifTrue:
		[^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 65535].
	instVarIndex > 255 ifTrue:
		[self genUnsignedSingleExtendA: instVarIndex // 256].
	stream
		nextPut: 243;
		nextPut: instVarIndex \\ 256! !

!EncoderForSistaV1 methodsFor: 'extended bytecode generation' stamp: ''!
genCallMappedInlinedPrimitive: primIndex
	"236		11101100	iiiiiiii		callMappedInlinedPrimitive [Sista specific]"
	(primIndex < 0 or: [primIndex > 255]) ifTrue:
		[self outOfRangeError: 'primitive index' index: primIndex range: 1 to: 32767].
	stream
		nextPut: 236;
		nextPut: primIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genDup
	"83			01010011			Duplicate Stack Top"
	stream nextPut: 83! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genBranchPopTrueLong: distance
	"238		11101110	iiiiiiii		Pop and Jump 0n True #iiiiiiii (+ Extend B * 256, where Extend B >= 0)"
	| distanceMod256 |
	(distance < 0 or: [distance > 32767]) ifTrue:
		[^self outOfRangeError: 'distance' index: distance range: 0 to: 32767].
	(distance > 0 and: [distance < 9]) ifTrue:
		["184-191	10111 iii			Pop and Jump 0n True iii + 1 (i.e., 1 through 8)"
		 stream nextPut: 183 + distance.
		 ^self].
	distanceMod256 := (distance < 0 or: [distance > 255])
							ifTrue:
								[self genUnsignedSingleExtendB: (distance bitShift: -8).
								 distance bitAnd: 255]
							ifFalse: [distance].
	stream
		nextPut: 238;
		nextPut: distanceMod256! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genSendDirectedSuper: selectorLiteralIndex numArgs: nArgs
	| extendedIndex |
	(selectorLiteralIndex < 0 or: [selectorLiteralIndex > 65535]) ifTrue:
		[^self outOfRangeError: 'selectorLiteralIndex' index: selectorLiteralIndex range: 0 to: 65535].
	(nArgs < 0 or: [nArgs > 31]) ifTrue:
		[^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"].
	(extendedIndex := selectorLiteralIndex) > 31 ifTrue:
		[self genUnsignedSingleExtendA: extendedIndex // 32.
		 extendedIndex := extendedIndex \\ 32].
	"Bit 6 of the ExtB byte is the directed send flag.  Bit 6 allows for future expansion to up to 255 args."
	self genUnsignedSingleExtendB: nArgs // 8 + 64.
	"235		11101011	iiiiijjj		Send To Superclass Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"
	stream
		nextPut: 235;
		nextPut: nArgs \\ 8 + (extendedIndex * 8)! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genStorePopRemoteTemp: tempIndex inVectorAt: tempVectorIndex
	"*	253	(3)	11111101 	kkkkkkkk	sjjjjjjj		Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjj s = 1 implies remote inst var access instead of remote temp vector access"
	(tempIndex < 0 or: [tempIndex >= 256]) ifTrue:
		[^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255].
	(tempVectorIndex < 0 or: [tempVectorIndex >= 128]) ifTrue:
		[^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 127].
	stream
		nextPut: 253;
		nextPut: tempIndex;
		nextPut: tempVectorIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genStoreTemp: tempIndex
	"245		11110110	iiiiiiii		Store Temporary Variable #iiiiiiii"
	(tempIndex < 0 or: [tempIndex > 63]) ifTrue:
		[^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63].
	stream
		nextPut: 245;
		nextPut: tempIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genTrapIfNotInstanceOf: literalIndex
	"*	236		11101100	iiiiiiii		Trap If Not Instance Of Behavior/Array Of Behavior #iiiiiiii (+ Extend A * 256, where Extend A >= 0)"

	| extendedIndex |
	(literalIndex < 0 or: [literalIndex > 65535]) ifTrue:
		[^self outOfRangeError: 'index' index: literalIndex range: 0 to: 65536].
	(extendedIndex := literalIndex) > 255 ifTrue:
		[self genUnsignedSingleExtendA: extendedIndex // 256.
		 extendedIndex := extendedIndex \\ 256].
	stream
		nextPut: 236;
		nextPut: extendedIndex! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genStorePopLiteralVar: literalIndex
	"241		11110001	iiiiiiii		Pop and Store Literal Variable #iiiiiiii (+ Extend A * 256)"
	(literalIndex < 0 or: [literalIndex > 32768]) ifTrue:
		[^self outOfRangeError: 'index' index: literalIndex range: 0 to: 32768].
	literalIndex > 255 ifTrue: 
		[self genUnsignedSingleExtendA: literalIndex // 256].
	stream
		nextPut: 241;
		nextPut: literalIndex \\ 256! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genSendSuper: selectorLiteralIndex numArgs: nArgs
	| extendedIndex extendedNArgs |
	(selectorLiteralIndex < 0 or: [selectorLiteralIndex > 65535]) ifTrue:
		[^self outOfRangeError: 'selectorLiteralIndex' index: selectorLiteralIndex range: 0 to: 65535].
	(nArgs < 0 or: [nArgs > 31]) ifTrue:
		[^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"].
	(extendedIndex := selectorLiteralIndex) > 31 ifTrue:
		[self genUnsignedSingleExtendA: extendedIndex // 32.
		 extendedIndex := extendedIndex \\ 32].
	(extendedNArgs := nArgs) > 7 ifTrue:
		[self genUnsignedSingleExtendB: extendedNArgs // 8.
		 extendedNArgs := extendedNArgs \\ 8].
	"235		11101011	iiiiijjj		Send To Superclass Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"
	stream
		nextPut: 235;
		nextPut: extendedNArgs + (extendedIndex * 8)! !

!EncoderForSistaV1 methodsFor: 'bytecode generation' stamp: ''!
genStorePopInstVar: instVarIndex
	"200-207	11001 iii			Pop and Store Receiver Variable #iii
	 240		11110000	iiiiiiii	Pop and Store Receiver Variable #iiiiiii (+ Extend A * 256)"
	(instVarIndex < 0 or: [instVarIndex > 7]) ifTrue:
		[^self genStorePopInstVarLong: instVarIndex].
	stream nextPut: 200 + instVarIndex! !

!EncoderForSistaV1 methodsFor: 'extended bytecode generation' stamp: ''!
genTrap
	"217		11011001			Unconditionnal trap"
	stream nextPut: 217! !

!EncoderForSistaV1 class methodsFor: 'block closure support' stamp: ''!
methodReturnBytecodes
	^ 88 to: 92! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isPushTempAt: pc in: method
	"64-71		01000 iii			Push Temp #iii
	 72-75		010010 ii			Push Temp #ii + 8
	 229		11100101	iiiiiiii	Push Temporary Variable #iiiiiiii"

	| byte |
	((byte := method at: pc) between: 64 and: 75) ifTrue: [ ^ true ].
	^ byte = 229! !

!EncoderForSistaV1 class methodsFor: 'accessing' stamp: ''!
literalMethodBytecodes
	"#[32 92] means pushConstant: x, returnTop" 
	
	^ #[32 92]! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isRealSendAt: pc in: method
	"Answer whether the bytecode at pc is a real message-send, not blockCopy:."

	^self isSendAt: pc in: method! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isCreateFullBlockAt: pc in: code
	^ self
		  extensionsAt: pc
		  in: code
		  into: [ :extA :extB :nExtBytes | 
		  (code at: pc + nExtBytes) = 16rF9 ]! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isJumpAt: pc in: method
	"Answer whether the bytecode at pc is an (unconditional) jump."

	"	176-183	10110 iii				Jump iii + 1 (i.e., 1 through 8)
	 *	225		11100001	bbbbbbbb	Extend B (Ext B = Ext B prev * 256 + Ext B)
	 *	237		11101101	iiiiiiii		Jump #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)"
	| byte |
	byte := self nonExtensionBytecodeAt: pc in: method.
	^byte >= 176 and: [byte <= 183 or: [byte = 237]]! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isExtension: bytecode
	"Answer if the bytecode is an extension bytecode, i.e. one that extends
	 the range of the following bytecode."
	^bytecode >= 16rE0 and: [bytecode <= 16rE1]! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isJustPopAt: pc in: method
	"Answer whether the bytecode at pc is a pop."

	^(method at: pc) = 216 "216		11011000			Pop Stack Top"! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isBranchIfFalseAt: pc in: method
	"Answer whether the bytecode at pc is a conditional branch-if-false."

	"	192-199	11000 iii				Pop and Jump 0n False iii +1 (i.e., 1 through 8)
	 *	239		11101111	iiiiiiii		Pop and Jump 0n False #iiiiiiii (+ Extend B * 256, where Extend B >= 0)"
	| byte |
	byte := self nonExtensionBytecodeAt: pc in: method.
	^byte >= 192 and: [byte <= 199 or: [byte = 239]]! !

!EncoderForSistaV1 class methodsFor: 'block closure support' stamp: ''!
isCreateFullBlock: compiledBlock code: code at: pc
	^self extensionsAt: pc in: code into:
		[:extA :extB :nExtBytes| 
			(code at: pc + nExtBytes) = 16rF9 and: [ 
				compiledBlock = (code literalAt: (code at: pc + nExtBytes + 1) + (extA bitShift: 8) + 1)] ]! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
nonExtensionBytecodeAt: pc in: method
	"Answer the actual bytecode at pc in method, skipping past any preceeding extensions."
	| scanpc byte |
	scanpc := pc.
	[ byte := method at: scanpc.
	 byte >= 224 and: [byte <= 225]] whileTrue: [ scanpc := scanpc + 2 ].
	^ byte! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
superSendScanBlockUsing: scanner
	"Answer a block argument for InstructionStream>>scanFor:
	 that answers true for super sends."

	"*	224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)
	 *	225		11100001	sbbbbbbb	Extend B (Ext B = Ext B prev * 256 + Ext B)
	 **	235		11101011	iiiiijjj		Send To Superclass Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"
					
	^[:instr | instr = 235]! !

!EncoderForSistaV1 class methodsFor: 'bytecode decoding' stamp: ''!
unusedBytecode
	"Answer the opcode of a single-byte unused bytecode, if it exists in the encoder's bytecode set, or nil if not."
	^ 84! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
instVarReadScanBlockFor: varIndexCode using: scanner
	"Answer a block argument for InstructionStream>>scanFor: that answers true
	 for reads of the inst var with zero-relative index varIndexCode.
	 N.B. Don't assume the compiler uses the most compact encoding available."

	"	0-15		0000 i i i i 				Push Receiver Variable #iiii
	*	224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)
	*	226		11100010	i i i i i i i i	Push Receiver Variable #iiiiiiii (+ Extend A * 256)"
	| extension |
	extension := 0.
	^[:b| | prevext |
	   prevext := extension.
	   extension := b = 224 ifTrue: [scanner secondByte bitShift: 8] ifFalse: [0].
	   (b < 16 and: [b = varIndexCode])
	    or: [b = 226
			and: [scanner secondByte + prevext = varIndexCode]]]! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
instVarWriteScanBlockFor: varIndexCode using: scanner
	"Answer a block argument for InstructionStream>>scanFor: that answers true
	 for writes of the inst var with zero-relative index varIndexCode.
	 N.B. Don't assume the compiler uses the most compact encoding available."

	"	200-207	11001 iii			Pop and Store Receiver Variable #iii
	*	224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)
	*	240		11110000	iiiiiiii		Pop and Store Receiver Variable #iiiiiii (+ Extend A * 256)
	*	243		11110011	iiiiiiii		Store Receiver Variable #iiiiiii (+ Extend A * 256)"
	| extension |
	extension := 0.
	^[:b| | prevext |
	   prevext := extension.
	   extension := b = 224 ifTrue: [scanner secondByte bitShift: 8] ifFalse: [0].
	   (b >= 200
	    and: [b < 208
	    and: [b - 200 = varIndexCode]])
	   or: [(b = 240 or: [b = 243])
		  and: [scanner secondByte + prevext = varIndexCode]]]! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isReturnAt: pc in: method
	"Answer whether the bytecode at pc is a return from block."
	"	88-91		010110 ii			Return Receiver/true/false/nil
		92			01011100			Return top
		93			01011101			BlockReturn nil
	 *	94			01011110			BlockReturn Top [* return from enclosing block N, N = Extend A, then jump by Ext B ]"
	^(self nonExtensionBytecodeAt: pc in: method) between: 88 and: 94! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
interpretNextInstructionFor: aClient in: anInstructionStream
	"Double-dispatch through the encoder to select the correct instruction set decoder."
	^anInstructionStream interpretNextSistaV1InstructionFor: aClient! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
bytecodeSize: bytecode
	"Answer the number of bytes in the bytecode."
	bytecode < 224 ifTrue: [^1].
	bytecode < 248 ifTrue: [^2].
	^3! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isBlockReturnAt: pc in: method
	"Answer whether the bytecode at pc is a return from block."
	"	93			01011101			BlockReturn nil
	 *	94			01011110			BlockReturn Top [* return from enclosing block N, N = Extend A, then jump by Ext B ]"
	^(self nonExtensionBytecodeAt: pc in: method) between: 93 and: 94! !

!EncoderForSistaV1 class methodsFor: 'block closure support' stamp: ''!
numLocalTempsForBlockAt: startpc in: method
	"**	250		11111010 	eeiiikkk		jjjjjjjj		Push Closure Num Copied iii (+ExtA//16*8) Num Args kkk (+ ExtA\\16*8) BlockSize jjjjjjjj (+ExtB*256). ee = num extensions"
	^ BlockLocalTempCounter
		tempCountForBlockAt: startpc - 3 - (((method at: startpc - 2) >> 6) * 2)
		in: method! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
readsSelfFor: compiledMethod
	"Answer whether compiledMethod reads self"
	| scanner |
	scanner := InstructionStream on: compiledMethod.
	^ scanner scanFor: 
		[:instr |  instr = 76 or: [ instr = 88 ] ]! !

!EncoderForSistaV1 class methodsFor: 'bytecode decoding' stamp: ''!
selectorToSendOrItselfFor: anInstructionStream in: method at: pc
	"If anInstructionStream is at a send bytecode then answer the send's selector,
	 otherwise answer anInstructionStream itself.  The rationale for answering
	 anInstructionStream instead of, say, nil, is that potentially any existing object
	 can be used as a selector, but since anInstructionStream postdates the method,
	 it can't be one of them.
	 The complication is that for convenience we allow the pc to point to the
	 raw send bytecode after its extension(s), or at the extension(s) preceeding it.
	96-111		0110 iiii			Send Arithmetic Message #iiii (+ - < > <= >= = ~= * / \\ @ bitShift: // bitAnd: bitOr:)
	112-119	01110 iii			Send Special Message #iii + 0 (at: at:put: size next nextPut: atEnd == class)
	120-127	01111 iii			Send Special Message #iii + 8 (~~ value value: do: new new: x y)
	128-143	1000 iiii			Send Literal Selector #iiii With 0 Argument
	144-159	1001 iiii			Send Literal Selector #iiii With 1 Arguments
	160-175	1010 iiii			Send Literal Selector #iiii With 2 Arguments
	*	224	11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)
	*	225	11100001	bbbbbbbb	Extend B (Ext B = Ext B prev * 256 + Ext B)
	**	234	11101010	iiiiijjj		Send Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments
	**	235	11101011	iiiiijjj	ExtendB < 64
										ifTrue: [Send To Superclass Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments]
										ifFalse: [Send To Superclass of Stacked Class Literal Selector #iiiii (+ Extend A * 32) with jjj (+ (Extend B "

	| byte |
	byte := method at: pc.
	byte < 96 ifTrue:
		[^anInstructionStream].
	byte <= 175 ifTrue: 
		["special byte or short send"
		 ^byte >= 128
			ifTrue: [method literalAt: (byte bitAnd: 15) + 1]
			ifFalse: [Smalltalk specialSelectorAt: byte - 95]].
	byte < 234 ifTrue: "need to check for either extension cuz order of extensions is not restricted. so extB could preceed extA"
		[(byte >= 224 and: [byte <= 225]) ifTrue:
			[^self extensionsAt: pc in: method into:
				[:extA :extB :nExtBytes| | byteAfter index |
				byteAfter := method at: pc + nExtBytes.
				(byteAfter >= 234 and: [byteAfter <= 235])
					ifTrue:
						[index := ((method at: pc + nExtBytes + 1) bitShift: -3) + (extA bitShift: 5).
						 method literalAt: index + 1]
					ifFalse: [anInstructionStream]]].
		^anInstructionStream].
	byte > 235 ifTrue:
		[^anInstructionStream].
	"they could be extended..."
	^self extensionsFor: pc in: method into:
		[:extA :extB :nExtBytes| | index |
		 index := ((method at: pc + 1) bitShift: -3) + (extA bitShift: 5).
		 method literalAt: index + 1]! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
firstSpecialSelectorByte
	^ 16r5F! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
bindingReadScanBlockFor: litVarIndex using: scanner
	"Answer a block argument for InstructionStream>>scanFor: that answers true
	 for reads of the value of the binding with zero-relative index litVarIndex.
	 N.B. Don't assume the compiler uses the most compact encoding available."

	"	16-31		0001 i i i i				Push Literal Variable #iiii
	 *	224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)
	 *	227		11100011	i i i i i i i i	Push Literal Variable #iiiiiiii (+ Extend A * 256)"
	| extension |
	extension := 0.
	^[:b| | prevext |
	   prevext := extension.
	   extension := b = 224 ifTrue: [scanner secondByte bitShift: 8] ifFalse: [0].
	   (b < 32 and: [b >= 16 and: [b - 16 = litVarIndex]])
	    or: [b = 227
			and: [scanner secondByte + prevext = litVarIndex]]]! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isReturnTopFromMethodAt: pc in: method
	"Answer whether the bytecode at pc is a return stack top from method."

	^(method at: pc) = 92! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
prepareMethod: compiledMethod forSimulationWith: numArgs
	self shouldBeImplemented! !

!EncoderForSistaV1 class methodsFor: 'bytecode decoding' stamp: ''!
backJumpBytecodeSize
	^ 4! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
sendsToSuperFor: compiledMethod
	"Answer whether the receiver sends any message to super."
	| scanner |
	scanner := InstructionStream on: compiledMethod.
	^ scanner scanFor: [:instr |  instr = 235 ]! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isBranchIfTrueAt: pc in: method
	"Answer whether the bytecode at pc is a conditional branch-if-true."

	"	184-191	10111 iii				Pop and Jump 0n True iii +1 (i.e., 1 through 8)
	 *	238		11101110	iiiiiiii		Pop and Jump 0n True #iiiiiiii (+ Extend B * 256, where Extend B >= 0))"
	| byte |
	byte := self nonExtensionBytecodeAt: pc in: method.
	^byte >= 184 and: [byte <= 191 or: [byte = 238]]! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
bindingWriteScanBlockFor: litVarIndex using: scanner
	"Answer a block argument for InstructionStream>>scanFor: that answers true
	 for writes of the value of the binding with zero-relative index litVarIndex.
	 N.B. Don't assume the compiler uses the most compact encoding available."

	"*	224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)
	 *	241		11110001	iiiiiiii		Pop and Store Literal Variable #iiiiiiii (+ Extend A * 256)
	 *	244		11110100	iiiiiiii		Store Literal Variable #iiiiiiii (+ Extend A * 256)"
	| extension |
	extension := 0.
	^[:b| | prevext |
	   prevext := extension.
	   extension := b = 224 ifTrue: [scanner secondByte bitShift: 8] ifFalse: [0].
	   (b = 241 or: [b = 244])
	   and: [scanner secondByte + prevext = litVarIndex]]! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isStorePopAt: pc in: method
	"Answer whether the bytecode at pc is a store or store-pop."

	"	200-207	11001 iii						Pop and Store Receiver Variable #iii
		208-215	11010 iii						Pop and Store Temporary Variable #iii
	 *	224		11100000	aaaaaaaa			Extend A (Ext A = Ext A prev * 256 + Ext A)
	 *	240		11110000	iiiiiiii				Pop and Store Receiver Variable #iiiiiii (+ Extend A * 256)
	 *	241		11110001	iiiiiiii				Pop and Store Literal Variable #iiiiiiii (+ Extend A * 256)
		242		11110010	iiiiiiii				Pop and Store Temporary Variable #iiiiiiii

		253		11111101 	kkkkkkkk	jjjjjjjj	Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj"

	| byte |
	byte := self nonExtensionBytecodeAt: pc in: method.
	^byte >= 200
	  and: [byte <= 215
		 or: [(byte between: 240 and: 242)
		 or: [byte = 253]]]! !

!EncoderForSistaV1 class methodsFor: '*Flashback-Decompiler' stamp: ''!
skipTemps: numTemps for: aDecompiler
	numTemps > 0 ifTrue: [ aDecompiler goToNextInstruction ]! !

!EncoderForSistaV1 class methodsFor: 'bytecode decoding' stamp: ''!
pushNilByte
	^ 79! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
markerOrNilFor: aMethod
	"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 <D0> send: <literal 1>
		11 <87> pop
		12 <78> returnSelf

	for the first form, or 

		9 <70> self
		10 <D0> send: <literal 1>
		11 <7C> returnTop

	for the second form."
	| expectedHeaderPlusLliteralSize e |
  	expectedHeaderPlusLliteralSize := Smalltalk wordSize * 4.
  	^(((e := aMethod endPC - expectedHeaderPlusLliteralSize) = 3 or: [e = 4]) 
    	and: [aMethod numLiterals = 3
    	and: [(aMethod at:  expectedHeaderPlusLliteralSize + 1) = 76 "push self"
    	and: [(aMethod at: expectedHeaderPlusLliteralSize + 2) = 128]]])  "send <literal 1>"
    	ifTrue: [aMethod literalAt: 1]! !

!EncoderForSistaV1 class methodsFor: 'bytecode decoding' stamp: ''!
specialLiterals
	^ #(true false nil 0 1)! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isCreateBlockAt: pc in: method
	"Answer whether the bytecode at pc is a block creation bytecode."
	
	"250		11111010 	eeiiikkk		jjjjjjjj		Push Closure Num Copied iii (+ExtA//16*8) Num Args kkk (+ ExtA\\16*8) BlockSize jjjjjjjj (+ExtB*256). ee = num extensions"

	| byte |
	byte := self nonExtensionBytecodeAt: pc in: method.
	^ byte = 250! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
readsThisContextFor: compiledMethod
	"Answer whether compiledMethod reads thisContext"
	| scanner |
	scanner := InstructionStream on: compiledMethod.
	^ scanner scanFor: 
		[:instr |  instr = 82 ]! !

!EncoderForSistaV1 class methodsFor: 'scanning' stamp: ''!
method: method refersInBytecodeToLiteral: aLiteral specialSelectorIndex: specialOrNil
	"Answer if method refers to the literal aLiteral in the bytecode, as opposed to in its literal frame."

	"	77			01001101				Push true
		78			01001110				Push false
		79			01001111				Push nil
		80			01010000				Push 0
		81			01010001				Push 1
		88-91		010110 ii				Return Receiver/true/false/nil
		93			01011101				BlockReturn nil
		96-111		0110 iiii				Send Arithmetic Message #iiii #(#+ #- #< #> #'<=' #'>=' #= #'~=' #* #/ #'\\' #@ #bitShift: #'//' #bitAnd: #bitOr:)
		112-119	01110 iii				Send Special Message #iii #(#at: #at:put: #size #next #nextPut: #atEnd #'==' class)
		120		01111000				UNASSIGNED (was: blockCopy:)
		121		01111001				Send Special Message #value
		122-123	0111101 i				Send Special Message #i #(#value: #do:)
		124-127	011111 ii				Send Special Message #ii #(#new #new: #x #y))
	*	224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)
	*	225		11100001	sbbbbbbb	Extend B (Ext B = Ext B prev * 256 + Ext B)
	*	232		11101000	iiiiiiii		Push Integer #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)
	*	233		11101001	iiiiiiii		Push Character #iiiiiiii (+ Extend B * 256)
		249		11111001 	xxxxxxxx	syyyyyyy	Reserved for Push Float"
	| byte extended scanner |
	specialOrNil ifNotNil:
		[byte := specialOrNil + 95.
		^(InstructionStream on: method) scanFor: [:b| b = byte]].
	extended := false.
	aLiteral isInteger ifTrue:
		[(aLiteral >= -32768 and: [aLiteral <= 32767]) ifFalse: [^false].
		 scanner := InstructionStream on: method.
		 (aLiteral >= 0 and: [aLiteral <= 255]) ifTrue:
			[aLiteral <= 1 ifTrue:
				[byte := aLiteral + 80.
				 ^scanner scanFor: [:b| b = byte]].
			 ^scanner scanFor:
				[:b|
				(b = 232
				 and: [extended not
				 and: [scanner secondByte = aLiteral]])
				or: [extended := b = 225.
					false]]].
		 byte := (aLiteral bitShift: -8) bitAnd: 255.
		^scanner scanFor:
			[:b|
			(b = 232
			 and: [extended
			 and: [scanner secondByte = (aLiteral bitAnd: 255)]])
			or: [extended := b = 225 and: [scanner secondByte = byte].
				false]]].
	aLiteral isCharacter ifTrue:
		[aLiteral asciiValue <= 65535 ifFalse: [^false].
		 scanner := InstructionStream on: method.
		 aLiteral asciiValue <= 255 ifTrue:
			[^scanner scanFor:
				[:b|
				(b = 233
				 and: [extended not
				 and: [scanner secondByte = aLiteral]])
				or: [extended := b = 225.
					false]]].
		 byte := (aLiteral bitShift: -8) bitAnd: 255.
		^scanner scanFor:
			[:b|
			(b = 233
			 and: [extended
			 and: [scanner secondByte = (aLiteral bitAnd: 255)]])
			or: [extended := b = 225 and: [scanner secondByte = byte].
				false]]].
	aLiteral == nil ifTrue:
		[^(InstructionStream on: method) scanFor: [:b| b = 79 or: [b = 91 or: b = 93]]].
	aLiteral == true ifTrue:
		[^(InstructionStream on: method) scanFor: [:b| b = 77 or: [b = 89]]].
	aLiteral == false ifTrue:
		[^(InstructionStream on: method) scanFor: [:b| b = 78 or: [b = 90]]].
	
	^false! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isSendAt: pc in: method
	"Answer whether the bytecode at pc is a message-send."

	"	96-111		0110 iiii			Send Arithmetic Message #iiii #(#+ #- #< #> #'<=' #'>=' #= #'~=' #* #/ #'\\' #@ #bitShift: #'//' #bitAnd: #bitOr:)
		112-119	01110 iii			Send Special Message #iii #(#at: #at:put: #size #next #nextPut: #atEnd #'==' class)
		120		01111000			UNASSIGNED (was: blockCopy:)
		121		01111001			Send Special Message #value
		122-123	0111101 i			Send Special Message #i #(#value: #do:)
		124-127	011111 ii			Send Special Message #ii #(#new #new: #x #y))
		128-143	1000 iiii			Send Literal Selector #iiii With 0 Argument
		144-159	1001 iiii			Send Literal Selector #iiii With 1 Arguments
		160-175	1010 iiii			Send Literal Selector #iiii With 2 Arguments
	 **	234		11101010	iiiiijjj	Send Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments
	 **	235		11101011	iiiiijjj	Send To Superclass Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"

	| byte |
	byte := self nonExtensionBytecodeAt: pc in: method.
	^byte >= 96
	  and: [byte <= 175
		 or: [byte >= 234 and: [byte <= 235]]]! !

!EncoderForSistaV1 class methodsFor: 'instruction stream support' stamp: ''!
isStoreAt: pc in: method
	"Answer whether the bytecode at pc is a store or store-pop."

	"	200-207	11001 iii						Pop and Store Receiver Variable #iii
		208-215	11010 iii						Pop and Store Temporary Variable #iii
	 *	224		11100000	aaaaaaaa			Extend A (Ext A = Ext A prev * 256 + Ext A)
	 *	240		11110000	iiiiiiii				Pop and Store Receiver Variable #iiiiiii (+ Extend A * 256)
	 *	241		11110001	iiiiiiii				Pop and Store Literal Variable #iiiiiiii (+ Extend A * 256)
		242		11110010	iiiiiiii				Pop and Store Temporary Variable #iiiiiiii
	 *	243		11110011	iiiiiiii				Store Receiver Variable #iiiiiii (+ Extend A * 256)
	 *	244		11110100	iiiiiiii				Store Literal Variable #iiiiiiii (+ Extend A * 256)
		245		11110110	iiiiiiii				Store Temporary Variable #iiiiiiii

		252		11111100 	kkkkkkkk	jjjjjjjj	Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj
		253		11111101 	kkkkkkkk	jjjjjjjj	Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj"

	| byte |
	byte := self nonExtensionBytecodeAt: pc in: method.
	^byte >= 200
	  and: [byte <= 215
		 or: [(byte between: 240 and: 245)
		 or: [(byte between: 252 and: 253)]]]! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
extensionsAt: bcpc in: method into: aTrinaryBlock
	"If the bytecode at pc is an extension then evaluate aBinaryBlock with the values of extA and extB and number of extension *bytes*.
	 If the bytecode at pc is not extended then evaluate aBinaryBlock with 0 and 0.
	224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)
	225		11100001	bbbbbbbb	Extend B (Ext B = Ext B prev * 256 + Ext B)"
 
	| scanpc byte extByte extA extB |
	scanpc := bcpc.
	"There may be an extension (it could be a false positive).  We must scan as fast as possible..."
	extA := extB := 0.
	[byte := method at: scanpc.
	 byte >= 224 and: [byte <= 225]] whileTrue: 
		[extByte := method at: scanpc + 1.
		 scanpc := scanpc + 2.
		 byte = 224
			ifTrue:
				[extA := (extA bitShift: 8) + extByte]
			ifFalse:
				[extB := (extB = 0 and: [extByte > 127])
					ifTrue: [extByte - 256]
					ifFalse: [(extB bitShift: 8) + extByte]]].
	^aTrinaryBlock value: extA value: extB value: scanpc - bcpc


"Why use
	byte >= 224 and: [byte <= 225]
 and not
	(byte bitAnd: 16rFE) = 16rE0
 ?
 | n |
 n := 100000000.
 #(0 224) collect:
	[:byte|
	{ Time millisecondsToRun: [1 to: n do: [:i| (byte >= 224 and: [byte <= 225]) ifTrue: []]].
	   Time millisecondsToRun: [1 to: n do: [:i| (byte bitAnd: 16rFE) = 16rE0 ifTrue: []]] }] #(#(297 599) #(702 671))"! !

!EncoderForSistaV1 class methodsFor: 'bytecode decoding' stamp: ''!
callPrimitiveCode
	"Answer the call primitive bytecode, if it exists in the encoder's bytecode set, or nil if not.
	 248	11111000 	iiiiiiii	mjjjjjjj	Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution."
	^248! !

!EncoderForSistaV1 class methodsFor: 'compiled method support' stamp: ''!
literalIndexOfBytecodeAt: pc in: aCompiledMethod
	"	16-31		0001 i i i i				Push Literal Variable #iiii
	 	32-63		001 i i i i i				Push Literal #iiiii
	 *	224		11100000	aaaaaaaa	Extend A (Ext A = Ext A prev * 256 + Ext A)
	 *	227		11100011	i i i i i i i i	Push Literal Variable #iiiiiiii (+ Extend A * 256)
	 *	228		11100100	i i i i i i i i	Push Literal #iiiiiiii (+ Extend A * 256)
	 *	241		11110001	iiiiiiii		Pop and Store Literal Variable #iiiiiiii (+ Extend A * 256)
	 *	244		11110100	iiiiiiii		Store Literal Variable #iiiiiiii (+ Extend A * 256)"
	| byte |
	byte := aCompiledMethod at: pc.
	byte <= 63 ifTrue:
		[byte >= 32 ifTrue:
			[^byte bitAnd: 16r1F].
		 ^byte >= 16 ifTrue:
			[byte bitAnd: 16rF]].
	(#(227 228 241 244) includes: byte) ifTrue:
		[^aCompiledMethod at: pc + 1].
	(byte = 224 "Ext A"
	 and: [#(227 228 241 244) includes: (aCompiledMethod at: pc + 2)]) ifTrue:
		[^(aCompiledMethod at: pc + 1) * 256 + (aCompiledMethod at: pc + 3)].
	^nil! !

!EncoderForSistaV1 class methodsFor: 'accessing' stamp: ''!
instructionSizeAt: pc of: aMethod

	| tempPc bytecode accumulatedSize |
	tempPc := pc.
	bytecode := aMethod at: tempPc.
	accumulatedSize := 0.
	[ self isExtension: bytecode ] whileTrue: [ 
		accumulatedSize := accumulatedSize + (self bytecodeSize: bytecode).
		tempPc := tempPc + (self bytecodeSize: bytecode).
		bytecode := aMethod at: tempPc ].
	^ accumulatedSize := accumulatedSize + (self bytecodeSize: bytecode)! !

!EncoderForSistaV1 class methodsFor: 'bytecode decoding' stamp: ''!
stackDeltaForPrimitive: primitiveIndex in: method
	"Answer the stack delta for the callPrimitive: bytecode (see my class comment).
	 There is no delta for non-inlined primitives (its implicitly 0 - method numArgs).
	 Inlined primitives are grouped by the thousand by argument count, 32 args max ;-)."
	^primitiveIndex < 32678
		ifTrue: [0]
		ifFalse: [primitiveIndex - 32768 // 1000]! !

!EndianDetector commentStamp: ''!
I am EndianDetector, a class responsible of detecting the endianess in the current machine.

I do so in my #calcEndianess method, which works as follows:

 - it creates a float object, whose endianess is managed automatically by the VM.
 - copy the raw data of that float object into a bytes object (instance of my class)
 - then, we can check in the raw copy if the data of the float is in the least or more significant word of the object.

Internally, I do the raw data copy by changing the class of the float into me. To do that I have the following properties:
- I'm a compact class (required to change the class)
- I'm in the startup list to check this on every startup!
!EndianDetector class methodsFor: 'private' stamp: ''!
calcEndianness
	"Store the least significant word of the float with 1; on big endian machines 
	 this is the second word"

	| float |
	float := Float new: 2.
	float at: 2 put: 1.
	self adoptInstance: float.
	^ (float at: 1) = 1
		  ifTrue: [ #little ]
		  ifFalse: [ #big ]! !

!EndianDetector class methodsFor: 'accessing' stamp: ''!
endianness

	EndianCache ifNil: [EndianCache := self calcEndianness].
	^ EndianCache
! !

!EndianDetector class methodsFor: 'class initialization' stamp: ''!
initialize

	SessionManager default
		registerSystemClassNamed: self name! !

!EndianDetector class methodsFor: 'testing' stamp: ''!
isBigEndian
	
	^ self isLittleEndian not! !

!EndianDetector class methodsFor: 'testing' stamp: ''!
isLittleEndian
	
	^ self endianness == #little! !

!EndianDetector class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting

	isImageStarting ifFalse: [ ^ self ].
	EndianCache := nil! !

!EntryCompletion commentStamp: ''!
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:		<Block>
	chooser:		<IdentifierChooserMorph>
	dataSourceBlock:		<Block>
	filterBlock:		<Block>
	previousToken:		<String>

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: ''!
setChooserWith: aToken labels: labels
	chooser 
		ifNil: [chooser := IdentifierChooserMorph 
							labels: labels
							chooseBlock: [:token | self choose: token].
					chooser on: #keyStroke send: #keystrokeInChooser: to: self].
	^ chooser! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
dataSourceBlock: aBlock
	dataSourceBlock := aBlock! !

!EntryCompletion methodsFor: 'events - handling' stamp: ''!
keystroke: anEvent from: aMorph
	(self handlesKeyboard: anEvent)
		ifFalse: [ ^ false ].
	(anEvent keyCharacter = Character escape)
		ifTrue: [ chooser
				ifNotNil: [ self closeChooser.
					aMorph takeKeyboardFocus ]
				ifNil: [ self openChooserWith: aMorph textMorph text string from: aMorph ].
			^ true ].
	(chooser isNil and: [ anEvent keyCharacter = Character arrowDown ])
		ifTrue: [ self openChooserWith: aMorph textMorph text string from: aMorph ].
	^ chooser ifNil: [ false ] ifNotNil: [ chooser keyStroke: anEvent ]! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
chooserWith: aToken
	| applicants |
	applicants  := self filteredValuesWith: aToken.
	aToken 
		ifNil: [applicants isEmpty 
			ifFalse: [self setChooserWith: nil labels: applicants]]
		ifNotNil: [ | meaningfulApplicants | 
			meaningfulApplicants := (applicants copyWithout: nil) asSet.
			meaningfulApplicants isEmpty 
				ifFalse: [(meaningfulApplicants size = 1 and: [aToken = meaningfulApplicants anyOne])
					ifFalse: [self setChooserWith: aToken labels: applicants]]].
	^ chooser! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
closeChooser
	chooser 
		ifNotNil: [chooser close.
			chooser := nil].! !

!EntryCompletion methodsFor: 'events - handling' stamp: ''!
keystrokeInChooser: anEvent
	anEvent keyCharacter = Character escape
		ifTrue: [ chooser := nil ]! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
filterBlock: aBlock

	filterBlock := aBlock! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
choose: aToken
	chooseBlock 
		ifNotNil: [self closeChooser.
			chooseBlock value: aToken]! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
chooseBlock: aBlock

	chooseBlock := aBlock! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
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 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 open ].
	^ chooser! !

!EntryCompletion methodsFor: 'events - handling' stamp: ''!
handlesKeyboard: anEvent
	^ anEvent keyCharacter = Character arrowDown
		or: [anEvent keyCharacter = Character escape]! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
chooseBlock

	^ chooseBlock! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
filteredValuesWith: aToken
	^ (self dataSourceBlock value: aToken) 
		select: [:v | aToken isNil or: [aToken isEmpty or: [v isNil or: [self filterBlock value: v value: aToken]]]]! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
chooser
	^ chooser! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
filterBlock

	^ filterBlock ifNil: [filterBlock := [:currApplicant  :currText | true]]! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
openChooserWithAllOrCloseFrom: aFieldMorph 
	chooser 
		ifNotNil: [self closeChooser]
		ifNil: [
			self openChooserWith: aFieldMorph getText asString from: aFieldMorph].
	^ chooser! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
dataSourceBlock
	^ dataSourceBlock ifNil: [dataSourceBlock := [:token | #()]]! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
positionChooser
	"Position the chooser to fit on the display."! !

!EntryCompletion methodsFor: 'accessing' stamp: ''!
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: 'events - handling' stamp: ''!
closeIfNotNeeded: aMorph

	(chooser isNotNil and:[ chooser hasKeyboardFocus or: [ aMorph hasKeyboardFocus ] ]) ifFalse: [ self closeChooser ]! !

!EntryCompletion methodsFor: 'events - handling' stamp: ''!
mouseDownFromTextMorph: anEvent
	self closeChooser! !

!EntryCompletion class methodsFor: 'examples' stamp: ''!
exampleTextEntryWithCompletionDialog
	"self exampleTextEntryWithCompletionDialog"
	<sampleInstance>
	| applicants entryCompletion |
	applicants := (Array
		streamContents: [ :strm | 
			Symbol
				allSymbolTablesDo: [ :each | 
					(each notEmpty and: [ each first canBeGlobalVarInitial and: [ Smalltalk globals includesKey: each ] ])
						ifTrue: [ strm nextPut: each ] ] ]) sort.
	entryCompletion := EntryCompletion new
		dataSourceBlock: [ :currText | applicants ];
		filterBlock: [ :currApplicant :currText | currText size > 3 and: [ currApplicant asUppercase includesSubstring: currText asString asUppercase ] ].
	^ UIManager default
		request: 'Enter a class name fragment (at least 4 characters)'
		initialAnswer: ''
		title: 'Text entry with completion example: simple find a class'
		entryCompletion: entryCompletion! !

!EpAndFilter commentStamp: ''!
A TrAndFilter is a chain of AND filters.!
!EpAndFilter methodsFor: 'comparing' stamp: ''!
= other 
	^ self class = other class and: [ self subFilters = other subFilters ]! !

!EpAndFilter methodsFor: 'comparing' stamp: ''!
hash
	^ self class hash bitXor: self subFilters hash! !

!EpAndFilter methodsFor: 'accessing' stamp: ''!
subFilters
	^ subFilters! !

!EpAndFilter methodsFor: 'filtering' stamp: ''!
accepts: anEntry
	^ self subFilters allSatisfy: [ :aFilter | aFilter accepts: anEntry ]! !

!EpAndFilter methodsFor: 'accessing' stamp: ''!
subFilters: aCollectionOfFilters
	subFilters := aCollectionOfFilters! !

!EpAndFilter class methodsFor: 'instance creation' stamp: ''!
withAll: aCollection 
	^ self new 
		subFilters: aCollection;
		yourself! !

!EpAnnouncementsTest methodsFor: 'tests' stamp: ''!
testMonitorAnnouncesUpdateWhenDisabled

	self assertMonitorAnnouncesUpdateWhen: [ monitor disable ].! !

!EpAnnouncementsTest methodsFor: 'tests' stamp: ''!
assertMonitorAnnouncesUpdateWhen: aBlock

	| wasAnnounced |
	wasAnnounced := false.

	monitor announcer
		when: EpMonitorStateUpdated
		do: [ :announcement | wasAnnounced := true ].
	
	aBlock
		ensure: [ monitor announcer unsubscribe: self ].

	self assert: wasAnnounced! !

!EpAnnouncementsTest methodsFor: 'tests' stamp: ''!
testMonitorAnnouncesUpdateWhenRedundantlyDisabled

	monitor disable.
	self assertMonitorAnnouncesUpdateWhen: [ monitor disable ].! !

!EpAnnouncementsTest methodsFor: 'tests' stamp: ''!
testMonitorAnnouncesUpdateWhenEnabled

	self assertMonitorAnnouncesUpdateWhen: [ monitor enable ]! !

!EpAnnouncementsTest methodsFor: 'tests' stamp: ''!
testMonitorAnnouncesUpdateWhenRedundantlyEnabled

	monitor enable.
	self assertMonitorAnnouncesUpdateWhen: [ monitor enable ].! !

!EpApplyPreviewer commentStamp: ''!
I take as input a collection of  EpCodeChange instances and output the equivalent of such changes as if they were applied in current image.!
!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aChange

	self
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior |
			^ behavior category = aChange behaviorAffected category
				ifTrue: [ #() ]
				ifFalse: [ {
					EpBehaviorCategoryChange
						oldCategory: aChange oldCategory
						newCategory: aChange newCategory
						class: behavior 
					}
				]
			].
			
	^ #()! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitClassAddition: aChange
	^ self visitClassChange: aChange! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitMethodChange: aChange
	"Addition and Modification come here"

	self
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior | 
			^ behavior
				compiledMethodAt: aChange methodAffectedSelector
				ifPresent: [ :method | 
					(method protocol ~= aChange methodAffectedProtocol
						or: [ method sourceCode ~= aChange methodAffectedSourceCode ])
						ifTrue: [ {(EpMethodModification
								oldMethod: method
								newMethod: aChange methodAffected)} ]
						ifFalse: [ #() ] ]
				ifAbsent: [ {(EpMethodAddition method: aChange methodAffected)} ] ].
	^ {aChange}! !

!EpApplyPreviewer methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aChange

	self 
		behaviorNamed: aChange oldName
		ifPresent: [ :behavior | 
			^ { EpBehaviorNameChange 
					oldName: aChange oldName
					newName: aChange newName
					class: behavior } ].

	^ #()! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aChange

	^ (self includesCategory: aChange categoryName)
			ifTrue: [ { aChange } ]
			ifFalse: [ #() ]! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aChange

	self 
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior |
			^(behavior organization protocolOrganizer hasProtocolNamed: aChange protocol)
				ifTrue: [ #() ]
				ifFalse: [ { EpProtocolAddition behavior: behavior protocol: aChange protocol } ] ].

	^ #()! !

!EpApplyPreviewer methodsFor: 'accessing' stamp: ''!
environment

	^ environment ifNil: [ self class environment ]! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitCodeChange: aChange
	"Default behavior for any change."
		
	self error: 'Shouldn''t happen'. ^ {aChange}! !

!EpApplyPreviewer methodsFor: 'private' stamp: ''!
behaviorNamed: aSymbol ifPresent: presentBlock

	^ (self environment classOrTraitNamed: aSymbol) 
		ifNil: [ self ]
		ifNotNil: presentBlock! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aChange
	^ self visitTraitChange: aChange! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitEvent: aChange
	"Generic events do not apply any code change"

	^ #()! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange

	self
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :aBehavior | 
			(aBehavior organization classComment = aChange newComment) ifFalse: [ 
				^ { 
					EpBehaviorCommentChange 
						newWithBehavior: aBehavior
						oldComment: aBehavior organization classComment
						newComment: aChange newComment 
						oldStamp: aBehavior organization commentStamp
						newStamp: aChange newStamp 
				} ] ].

	^ #()! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitTraitModification: aChange
	^ self visitTraitChange: aChange! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitTraitChange: aChange

	self
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :aTrait |
			^ { EpTraitModification oldTrait: aTrait newTrait: aChange behaviorAffected } ].
	
	^ { EpTraitAddition trait: aChange behaviorAffected }! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitClassChange: aChange

	self
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :aClass | 
			^ aClass definitionString = aChange behaviorAffected definition
				  ifTrue: [ #(  ) ]
				  ifFalse: [ 
					  { (EpClassModification
						   oldClass: aClass
						   newClass: aChange behaviorAffected) } ] ].

	^ { (EpClassAddition class: aChange behaviorAffected) }! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aChange

	self 
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior |
			"If method comes from trait, removing has no impact."
			^ behavior 
				compiledMethodAt: aChange methodAffectedSelector
				ifPresent: [ :method | method isFromTrait not
					ifTrue: [ { EpMethodRemoval method: method } ]
					ifFalse: [ #() ] ]
				ifAbsent: [ #() ] ].

	^ #() "No impact if container does not exist"! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aChange
	^ self visitMethodChange: aChange! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aChange

	^ (self includesCategory: aChange oldCategoryName)
		ifTrue: [ { aChange } ]
		ifFalse: [ #() ]! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitCategoryChange: aChange
	^ self visitCodeChange: aChange! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aChange

	^ (self includesCategory: aChange categoryName)
			ifTrue: [ #() ]
			ifFalse: [ { aChange } ]! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitMethodModification: aChange
	^ self visitMethodChange: aChange! !

!EpApplyPreviewer methodsFor: 'private' stamp: ''!
includesCategory: aString

	^ self environment organization includesCategory: aString! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitBehaviorChange: aChange
	^ self visitCodeChange: aChange! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitTraitRemoval: aChange

	self 
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior | ^ { EpTraitRemoval trait: behavior } ].

	^ #()! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitProtocolChange: aProtocolAddition
	^ self visitBehaviorChange: aProtocolAddition.! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aChange

	self 
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior | ^ { EpClassRemoval class: behavior } ].

	^ #()! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aChange

	self 
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior |
			^(behavior organization protocolOrganizer hasProtocolNamed: aChange protocol)
				ifTrue: [ { EpProtocolRemoval behavior: behavior protocol: aChange protocol } ]
				ifFalse: [ #() ] ].

	^ #()! !

!EpApplyPreviewer methodsFor: 'visitor' stamp: ''!
visitClassModification: aChange
	^ self visitClassChange: aChange! !

!EpApplyPreviewer class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EpApplyPreviewer class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EpApplyPreviewer class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EpApplyPreviewer class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EpApplyPreviewer class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EpApplyPreviewer class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EpApplyPreviewer class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EpApplyPreviewer class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EpApplyPreviewer class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpApplyPreviewer class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EpApplyPreviewer class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EpApplyPreviewer class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EpApplyPreviewer class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EpApplyPreviewer class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EpApplyPreviewer class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EpApplyPreviewer class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EpApplyPreviewer class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EpApplyPreviewer class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpApplyPreviewer class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EpApplyPreviewer class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EpApplyPreviewer class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EpApplyPreviewer class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!EpApplyPreviewer class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!EpApplyPreviewer class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!EpApplyPreviewer class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EpApplyPreviewer class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EpApplyPreviewer class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EpApplyPreviewer class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EpApplyPreviewer class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testKeepChangeWhenMethodModificationWithAbsentBehavior

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass compile: 'fortyTwo ^nil' classified: 'number'.
	self setHeadAsInputEntry.
	aClass removeFromSystem.

	self assertOutputsAnEventWith: [:output | 
		self assert: output class equals: EpMethodModification ]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantBehaviorCommentChange

	| aClass |
	aClass := classFactory newClass.
	aClass classComment: 'before'.
	aClass classComment: 'after'.
	aClass classComment: 'before'.
	self setHeadAsInputEntry.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testTraitModification
	<expectedFailure>
	
	self fail. "Missing test/feature"! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantProtocolRemoval

	| aClass |
	aClass := classFactory newClass.
	aClass organization addCategory: 'protocol'.
	aClass removeProtocol: 'protocol'.
	self setHeadAsInputEntry.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testCategoryAdditionWithCategoryRemoved

	self class environment organization addCategory: classFactory defaultCategory.
	self setHeadAsInputEntry.
	self class environment organization removeCategory: classFactory defaultCategory.

	self assertOutputsAnEventWith: [:output |
		self assert: output class equals: EpCategoryAddition.
		self assert: output categoryName equals: classFactory defaultCategory.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests - multiple changes' stamp: ''!
testSequenceOfMethodModifications

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass compile: 'fortyTwo ^43' classified: 'number'.
	aClass compile: 'fortyTwo ^44' classified: 'number'.
	self setMonitorLogAsInputEntries.

	aClass removeSelector: #fortyTwo.
	aClass removeFromSystem.

	self assertOutputsEventsWith: [:output | 
		| outputClasses |
		outputClasses := output collect: #class as: Array.
		self assert: outputClasses equals: { EpClassAddition. EpMethodModification }.
		self assert: output last methodAffectedSourceCode equals: 'fortyTwo ^44'.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantProtocolAddition

	| aClass |
	aClass := classFactory newClass.
	aClass organization addCategory: 'protocol'.
	self setHeadAsInputEntry.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testBehaviorCommentChange

	| aClass |
	aClass := classFactory newClass.
	aClass classComment: 'before'.
	self setHeadAsInputEntry.
	aClass classComment: 'after'.

	self assertOutputsAnEventWith: [:output |
		self assert: output class equals: EpBehaviorCommentChange.
		self assert: output oldComment equals: 'after'.
		self assert: output newComment equals: 'before'.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testClassAdditionWithInstanceVariablesChanged

	| aClass classDefinition |
	aClass := classFactory newClass.
	classDefinition := aClass definitionString.
	self setHeadAsInputEntry.
	aClass addInstVarNamed: #x.

	self assertOutputsAnEventWith: [ :output | 
		self assert: output class equals: EpClassModification.
		self
			assert: output oldClass definitionSource
			equals: aClass definitionString.
		self
			assert: output newClass definitionSource
			equals: classDefinition ]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testMethodAdditionWithSourceCodeChanged

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	self setHeadAsInputEntry.
	aClass compile: 'fortyTwo ^nil'.

	self assertOutputsAnEventWith: [:output | 
		self assert: output class equals: EpMethodModification.
		self assert: output oldSourceCode equals: 'fortyTwo ^nil'.
		self assert: output oldProtocol equals: 'number'.
		self assert: output newSourceCode equals: 'fortyTwo ^42'.
		self assert: output newProtocol equals: 'number'.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testCategoryRemovalWithCategoryAdded

	self class environment organization addCategory: classFactory defaultCategory.
	self class environment organization removeCategory: classFactory defaultCategory.
	self setHeadAsInputEntry.

	self class environment organization addCategory: classFactory defaultCategory.

	self assertOutputsAnEventWith: [:output |
		self assert: output class equals: EpCategoryRemoval.
		self assert: output categoryName equals: classFactory defaultCategory.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testClassAdditionWithClassRemoved

	| aClass classDefinition |
	aClass := classFactory newClass.
	classDefinition := aClass definitionString.
	self setHeadAsInputEntry.

	aClass removeFromSystem.

	self assertOutputsAnEventWith: [ :output | 
		self assert: output class equals: EpClassAddition.
		self
			assert: output behaviorAffected definitionSource
			equals: classDefinition ]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantMethodRemoval

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass removeSelector: #fortyTwo.
	self setHeadAsInputEntry.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantCategoryRemoval

	self class environment organization addCategory: classFactory defaultCategory.
	self class environment organization removeCategory: classFactory defaultCategory.
	self setHeadAsInputEntry.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantCategoryRenameWithAbsentCategory

	| organization aCategory anotherCategory |
	organization := self class environment organization.
	aCategory := classFactory defaultCategory.
	anotherCategory := aCategory, '2'.
	organization addCategory: aCategory.
	organization renameCategory: aCategory toBe: anotherCategory.
	self setHeadAsInputEntry.

	self assertEmptyPreviewLog! !

!EpApplyPreviewerTest methodsFor: 'tests - multiple changes' stamp: ''!
testSequenceOfClassAndMethodAddition

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	self setMonitorLogAsInputEntries.

	aClass removeSelector: #fortyTwo.
	aClass removeFromSystem.

	self assertOutputsEventsWith: [:output | 
		| outputClasses |
		outputClasses := output collect: #class as: Array.
		self assert: outputClasses equals: { EpClassAddition. EpMethodAddition }.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantClassAddition
	classFactory newClass.
	self setHeadAsInputEntry.

	self assertEmptyPreviewLog! !

!EpApplyPreviewerTest methodsFor: 'resources' stamp: ''!
assertEmptyPreviewLog

	self 
		assert: self outputEvents isEmpty 
		description: 'Shouldn''t find anything to apply'! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testClassRemovalWithClassAdded

	| aClass className |
	aClass := classFactory newClass.
	className := aClass name.
	aClass removeFromSystem.

	self setHeadAsInputEntry.

	aClass := classFactory newClass.
	aClass rename: className.

	self assertOutputsAnEventWith: [ :output | 
		self assert: output class equals: EpClassRemoval.
		self
			assert: output behaviorAffected definitionSource
			equals: aClass definitionString ]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testBehaviorNameChange

	| aClass oldName newName |
	aClass := classFactory newClass.
	oldName := aClass name.
	newName := oldName, '2'.
	aClass rename: newName.
	self setHeadAsInputEntry.

	aClass rename: oldName. "Rollback"

	self assertOutputsAnEventWith: [:output |
		self assert: output class equals: EpBehaviorNameChange.
		self assert: output oldName equals: oldName.
		self assert: output newName equals: newName.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantBehaviorCommentChangeWithAbsentBehavior

	| aClass |
	aClass := classFactory newClass.
	aClass classComment: 'before'.
	self setHeadAsInputEntry.
	aClass removeFromSystem.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantMethodRemovalWithAbsentBehavior

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass removeSelector: #fortyTwo.
	self setHeadAsInputEntry.
	aClass removeFromSystem.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'resources' stamp: ''!
assertOutputsEventsWith: aBlock

	| logBrowserModel outputLog |
	logBrowserModel := EpLogBrowserPresenter newWithLog: monitor log.
	
	outputLog :=
		EpLogBrowserOperationFactory new
			logBrowserModel: logBrowserModel;
			entries: inputEntries;
			errorHandlerBlock: [:error | error signal ];
			newApplyPreviewLog.
	
	aBlock value: (outputLog entries collect: [:each | each content]).! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testMethodRemovalWithMethodAdded

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass removeSelector: #fortyTwo.
	self setHeadAsInputEntry.
	aClass compile: 'fortyTwo ^42' classified: 'number'.

	self assertOutputsAnEventWith: [:output | 
		self assert: output class equals: EpMethodRemoval.
		self assert: output methodAffectedSourceCode equals: 'fortyTwo ^42'.
		self assert: output methodAffectedProtocol equals: 'number'.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testNonCodeChangeEvent

	monitor logEntryCommented:
		(EpLogEntriesComment 
			entryReferences: #()
			oldComment: ''
			newComment: '42').

	self setHeadAsInputEntry.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testMethodAdditionWithMethodRemoved

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	self setHeadAsInputEntry.
	aClass removeSelector: #fortyTwo.

	self assertOutputsAnEventWith: [:output | 
		self assert: output class equals: EpMethodAddition.
		self assert: output methodAffectedSourceCode equals: 'fortyTwo ^42'.
		self assert: output methodAffectedProtocol equals: 'number'.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testProtocolRemovalWithProtocolAdded

	| aClass |
	aClass := classFactory newClass.
	aClass organization addCategory: 'protocol'.
	aClass removeProtocol: 'protocol'.
	self setHeadAsInputEntry.
	aClass organization addCategory: 'protocol'.

	self assertOutputsAnEventWith: [:output |
		self assert: output class equals: EpProtocolRemoval.
		self assert: output protocol equals: 'protocol'.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testClassAdditionWithSuperclassChanged

	| aClass classDefinition |
	aClass := classFactory newClass.
	classDefinition := aClass definitionString.
	self setHeadAsInputEntry.
	aClass superclass: Array.

	self assertOutputsAnEventWith: [ :output | 
		self assert: output class equals: EpClassModification.
		self
			assert: output oldClass definitionSource
			equals: aClass definitionString.
		self
			assert: output newClass definitionSource
			equals: classDefinition ].

	aClass superclass: Object "Restore original superclass else something in hierarchy stays wrong (and ClassHierarchyTest>>testSubclassInstVar fails)"! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testTraitAdditionWithTraitRemoved

	| aTrait traitDefinition |
	aTrait := classFactory newTrait.
	traitDefinition := aTrait definitionString.
	self setHeadAsInputEntry.

	aTrait removeFromSystem.

	self assertOutputsAnEventWith: [ :output | 
		self assert: output class equals: EpTraitAddition.
		self
			assert: output behaviorAffected definitionSource
			equals: traitDefinition ]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantClassRemoval

	| aClass |
	aClass := classFactory newClass.
	aClass removeFromSystem.
	self setHeadAsInputEntry.
	
	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testTraitRemovalWithTraitAdded

	| aTrait traitName traitDefinition |
	aTrait := classFactory newTrait.
	traitName := aTrait name.
	traitDefinition := aTrait definitionString.
	aTrait removeFromSystem.
	self setHeadAsInputEntry.

	aTrait := classFactory newTrait.
	aTrait rename: traitName.

	self assertOutputsAnEventWith: [ :output | 
		self assert: output class equals: EpTraitRemoval.
		self
			assert: output behaviorAffected definitionSource
			equals: traitDefinition ]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testBehaviorCategoryChange

	| aClass aCategory anotherCategory |
	aClass := classFactory newClass.
	aCategory := aClass category.
	anotherCategory := aCategory, '2'.
	aClass category: anotherCategory.
	self setHeadAsInputEntry.

	aClass category: aCategory.
	
	self assertOutputsAnEventWith: [:output |
		self assert: output class equals: EpBehaviorCategoryChange.
		self assert: output oldCategory equals: aCategory.
		self assert: output newCategory equals: anotherCategory.
		]! !

!EpApplyPreviewerTest methodsFor: 'resources' stamp: ''!
assertOutputsAnEventWith: aBlock

	| outputEvents |
	outputEvents := self outputEvents.

	self assert: outputEvents size equals: 1.
	
	aBlock value: outputEvents anyOne.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testCategoryRenameWithPreviousRollback

	| organization aCategory anotherCategory |
	organization := self class environment organization.
	aCategory := classFactory defaultCategory.
	anotherCategory := aCategory, '2'.
	organization addCategory: aCategory.
	organization renameCategory: aCategory toBe: anotherCategory.
	self setHeadAsInputEntry.
	organization renameCategory: anotherCategory toBe: aCategory. "Rollback"

	self assertOutputsAnEventWith: [:output |
		self assert: output class equals: EpCategoryRename.
		self assert: output oldCategoryName equals: aCategory.
		self assert: output newCategoryName equals: anotherCategory.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testKeepChangeWhenMethodAdditionWithAbsentBehavior

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	self setHeadAsInputEntry.
	aClass removeFromSystem.

	self assertOutputsAnEventWith: [:output | 
		self assert: output class equals: EpMethodAddition ]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantMethodAddition

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	self setHeadAsInputEntry.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testMethodAdditionWithProtocolChanged

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	self setHeadAsInputEntry.
	(aClass>>#fortyTwo) protocol: 'none'.

	self assertOutputsAnEventWith: [:output | 
		self assert: output class equals: EpMethodModification.
		self assert: output oldSourceCode equals: 'fortyTwo ^42'.
		self assert: output oldProtocol equals: 'none'.
		self assert: output newSourceCode equals: 'fortyTwo ^42'.
		self assert: output newProtocol equals: 'number'.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testMethodModificationWithMethodRemoved

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass compile: 'fortyTwo ^nil' classified: 'number'.
	self setHeadAsInputEntry.
	aClass removeSelector: #fortyTwo.

	self assertOutputsAnEventWith: [:output | 
		self assert: output class equals: EpMethodAddition.
		self assert: output methodAffectedSourceCode equals: 'fortyTwo ^nil'.
		self assert: output methodAffectedProtocol equals: 'number'.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantMethodModification

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass compile: 'fortyTwo ^nil' classified: 'number'.
	self setHeadAsInputEntry.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantCategoryAddition

	self class environment organization addCategory: classFactory defaultCategory.
	self setHeadAsInputEntry.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests - multiple changes' stamp: ''!
testRedundantSequenceOfMethodModifications

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass compile: 'fortyTwo ^43' classified: 'number'.
	aClass compile: 'fortyTwo ^44' classified: 'number'.
	self setMonitorLogAsInputEntries.

	self assertEmptyPreviewLog! !

!EpApplyPreviewerTest methodsFor: 'resources' stamp: ''!
outputEvents

	| outputLog logBrowserModel |
	logBrowserModel := EpLogBrowserPresenter newWithLog: monitor log.
	
	outputLog :=
		EpLogBrowserOperationFactory new
			logBrowserModel: logBrowserModel;
			entries: inputEntries;
			errorHandlerBlock: [:error | error signal ];
			newApplyPreviewLog.
	
	^ outputLog entries collect: [:each | each content]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testProtocolAdditionWithProtocolRemoved

	| aClass |
	aClass := classFactory newClass.
	aClass organization addCategory: 'protocol'.
	self setHeadAsInputEntry.
	aClass removeProtocol: 'protocol'.

	self assertOutputsAnEventWith: [:output |
		self assert: output class equals: EpProtocolAddition.
		self assert: output protocol equals: 'protocol'.
		]! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantBehaviorCategoryChangeWithAbsentBehavior

	| aClass aCategory anotherCategory |
	aClass := classFactory newClass.
	aCategory := aClass category.
	anotherCategory := aCategory, '2'.
	aClass category: anotherCategory.
	aClass category: aCategory. "Rollback"
	self setHeadAsInputEntry.
	aClass removeFromSystem.

	self assertEmptyPreviewLog.! !

!EpApplyPreviewerTest methodsFor: 'tests' stamp: ''!
testRedundantBehaviorCategoryChange

	| aClass aCategory anotherCategory |
	aClass := classFactory newClass.
	aCategory := aClass category.
	anotherCategory := aCategory, '2'.
	aClass category: anotherCategory.
	aClass category: aCategory. "Rollback"
	self setHeadAsInputEntry.
	
	self assertEmptyPreviewLog.! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testClassRemovalWithClassAdded

	| aClass className |
	aClass := classFactory newClass.
	className := aClass name.
	aClass removeFromSystem.
	self setHeadAsInputEntry.

	aClass := classFactory newClass.
	aClass rename: className.

	self assert: (inputEntry content isKindOf: EpClassRemoval).
	self assert: (self class environment hasClassNamed: className).
	self applyInputEntry.
	self deny: (self class environment hasClassNamed: className).! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testBehaviorNameChange

	| aClass oldName newName |
	aClass := classFactory newClass.
	oldName := aClass name.
	newName := oldName, '2'.
	aClass rename: newName.
	self setHeadAsInputEntry.

	aClass rename: oldName. "Rollback"

	self assert: aClass name equals: oldName.
	self applyInputEntry.
	self assert: aClass name equals: newName.! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testCategoryRename

	| organization aCategory anotherCategory |
	organization := self class environment organization.
	aCategory := classFactory defaultCategory.
	anotherCategory := aCategory, '2'.
	organization addCategory: aCategory.
	organization renameCategory: aCategory toBe: anotherCategory.
	self setHeadAsInputEntry.
	organization renameCategory: anotherCategory toBe: aCategory. "Rollback"

	self assert: inputEntry content class equals: EpCategoryRename.
	self assert: (organization includesCategory: aCategory).
	self deny: (organization includesCategory: anotherCategory).
	self applyInputEntry.
	self deny: (organization includesCategory: aCategory).
	self assert: (organization includesCategory: anotherCategory).! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testTraitAdditionWithTraitRemoved

	| aTrait traitName |
	aTrait := classFactory newTrait.
	traitName := aTrait name.
	self setHeadAsInputEntry.
	
	aTrait removeFromSystem.

	self deny: (self class environment includesKey: traitName).
	self applyInputEntry.
	self assert: (self class environment includesKey: traitName).! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testClassModificationWithClassRemoved

	| aClass className |
	aClass := classFactory newClass.
	className := aClass name.
	aClass addInstVarNamed: #x.
	self setHeadAsInputEntry.
	
	aClass removeFromSystem.
	
	self assert: (inputEntry content isKindOf: EpClassModification).
	self deny: (self class environment hasClassNamed: className).
	self applyInputEntry.
	self assert: (self class environment hasClassNamed: className).
	self assert: aClass instVarNames equals: #(x).! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testMethodRemovalWithMethodAdded

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass removeSelector: #fortyTwo.
	self setHeadAsInputEntry.

	aClass compile: 'fortyTwo ^42' classified: 'number'.

	self assert: (inputEntry content isKindOf: EpMethodRemoval).
	self assert: (aClass includesSelector: #fortyTwo).
	self applyInputEntry.
	self deny: (aClass includesSelector: #fortyTwo).! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testProtocolAddition

	| aClass |
	aClass := classFactory newClass.
	aClass organization addCategory: 'protocol'.
	self setHeadAsInputEntry.
	aClass removeProtocol: 'protocol'.

	self assert: inputEntry content class equals: EpProtocolAddition.
	self deny: (aClass organization protocolOrganizer hasProtocolNamed: 'protocol').
	self applyInputEntry.
	self assert: (aClass organization protocolOrganizer hasProtocolNamed: 'protocol').! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testCategoryAdditionWithCategoryRemoved

	| organization aCategory |
	organization := self class environment organization.
	aCategory := classFactory defaultCategory.
	organization addCategory: aCategory.
	self setHeadAsInputEntry.
	organization removeCategory: aCategory.

	self assert: inputEntry content class equals: EpCategoryAddition.
	self deny: (organization includesCategory: aCategory).
	self applyInputEntry.
	self assert: (organization includesCategory: aCategory).! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testMethodAdditionWithMethodRemoved

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	self setHeadAsInputEntry.

	aClass removeSelector: #fortyTwo.
	
	self assert: (inputEntry content isKindOf: EpMethodAddition).
	self deny: (aClass includesSelector: #fortyTwo).
	self applyInputEntry.
	self assert: (aClass includesSelector: #fortyTwo).
	self assert: (aClass>>#fortyTwo) protocol equals: 'number'.! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testClassAdditionWithSuperclassChanged

	| aClass |
	aClass := classFactory newClass.
	self setHeadAsInputEntry.
	
	aClass superclass: Array.
	
	self assert: aClass superclass equals: Array.
	self applyInputEntry.
	self assert: aClass superclass equals: Object! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testClassAdditionWithCategoryChanged

	| aClass aCategory anotherCategory |
	aClass := classFactory newClass.
	self setHeadAsInputEntry.

	aCategory := aClass category.
	anotherCategory := aCategory, '2'.
	aClass category: anotherCategory.
	
	self assert: aClass category equals: anotherCategory.
	self applyInputEntry.
	self assert: aClass category equals: aCategory! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testTraitModification
	| aTrait traitName anotherTrait |
	aTrait := classFactory newTrait.
	anotherTrait := classFactory newTrait.
	traitName := aTrait name.
	aTrait setTraitComposition: anotherTrait asTraitComposition.

	"That should trigger a EpTraitModification and do not trigger many method events."


	self setHeadAsInputEntry.

	self assert: inputEntry content class equals: EpTraitModification.
	self applyInputEntry.
	self assert: (self class environment includesKey: traitName).! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testTraitRemovalWithTraitAdded

	| aTrait traitName |
	aTrait := classFactory newTrait.
	traitName := aTrait name.
	aTrait removeFromSystem.
	self setHeadAsInputEntry.

	aTrait := classFactory newTrait.
	aTrait rename: traitName.

	self assert: (inputEntry content isKindOf: EpTraitRemoval).
	self assert: (self class environment includesKey: traitName).
	self applyInputEntry.
	self deny: (self class environment includesKey: traitName).! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testMethodAdditionWithSourceCodeChanged

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42'.
	self setHeadAsInputEntry.

	aClass compile: 'fortyTwo ^nil'.
	
	self assert: (aClass>>#fortyTwo) sourceCode equals: 'fortyTwo ^nil'.
	self applyInputEntry.
	self assert: (aClass>>#fortyTwo) sourceCode equals: 'fortyTwo ^42'.! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testClassAdditionWithInstanceVariablesChanged

	| aClass |
	aClass := classFactory newClass.
	self setHeadAsInputEntry.
	
	aClass addInstVarNamed: #x.
	
	self assert: aClass instVarNames equals: #(x).
	self applyInputEntry.
	self assert: aClass instVarNames equals: #()! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
applyInputEntry

	EpLogBrowserOperationFactory new
		logBrowserModel: (EpLogBrowserPresenter newWithLog: monitor log);
		entries: { inputEntry };
		errorHandlerBlock: [:error | error signal ];
		applyCodeChanges! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testProtocolRemoval

	| aClass |
	aClass := classFactory newClass.
	aClass organization addCategory: 'protocol'.
	aClass removeProtocol: 'protocol'.
	self setHeadAsInputEntry.
	aClass organization addCategory: 'protocol'.

	self assert: inputEntry content class equals: EpProtocolRemoval.
	self assert: (aClass organization protocolOrganizer hasProtocolNamed: 'protocol').
	self applyInputEntry.
	self deny: (aClass organization protocolOrganizer hasProtocolNamed: 'protocol').! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testCategoryRemovalWithCategoryAdded

	| organization aCategory |
	organization := self class environment organization.
	aCategory := classFactory defaultCategory.
	organization addCategory: aCategory.
	organization removeCategory: aCategory.
	self setHeadAsInputEntry.
	organization addCategory: aCategory.

	self assert: inputEntry content class equals: EpCategoryRemoval.
	self assert: (organization includesCategory: aCategory).
	self applyInputEntry.
	self deny: (organization includesCategory: aCategory).! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testClassAdditionWithClassRemoved

	| aClass className |
	aClass := classFactory newClass.
	className := aClass name.
	self setHeadAsInputEntry.
	
	aClass removeFromSystem.
	
	self deny: (self class environment hasClassNamed: className).
	self applyInputEntry.
	self assert: (self class environment hasClassNamed: className).! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testMethodAdditionWithProtocolChanged

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	self setHeadAsInputEntry.

	(aClass>>#fortyTwo) protocol: 'none'.
	
	self assert: (aClass>>#fortyTwo) protocol equals: 'none'.
	self applyInputEntry.
	self assert: (aClass>>#fortyTwo) protocol equals: 'number'.! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testMethodModificationWithMethodRemoved

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass compile: 'fortyTwo ^nil' classified: 'number'.
	self setHeadAsInputEntry.

	aClass removeSelector: #fortyTwo.

	self assert: (inputEntry content isKindOf: EpMethodModification).
	self deny: (aClass includesSelector: #fortyTwo).
	self applyInputEntry.
	self assert: (aClass includesSelector: #fortyTwo).
	self assert: (aClass>>#fortyTwo) protocol equals: 'number'.! !

!EpApplyTest methodsFor: 'tests' stamp: ''!
testClassAdditionWithMetaclassInstanceVariablesChanged

	| aClass |
	aClass := classFactory newClass.
	self setHeadAsInputEntry.
	
	aClass classSide instanceVariableNames: 'x'.
	
	self assert: aClass classSide instVarNames equals: #(x).
	self applyInputEntry.
	self assert: aClass classSide instVarNames equals: #()! !

!EpApplyVisitor commentStamp: ''!
I implement how to redo EpCodeChange instances.!
!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aChange

	self
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [:aClassOrTrait | aClassOrTrait category: aChange newCategory ]! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitClassAddition: aClassCreation
	"this is a hack for the moment. Because fluid class definition return a builder and not the old syntax."
	
	('*<<*' match: aClassCreation classAdded definitionSource )
		ifTrue: [ 
			(self compiler evaluate: aClassCreation classAdded definitionSource) install.
			(self compiler evaluate: aClassCreation classAdded classSide definitionSource) install ]
		ifFalse: [self compiler
			evaluate: aClassCreation classAdded definitionSource;
			evaluate: aClassCreation classAdded classSide definitionSource ]! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aChange

	environment organization
		renameCategory: aChange oldCategoryName
		toBe: aChange newCategoryName! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aMethodCreated

	self 
		behaviorNamed: aMethodCreated behaviorAffectedName
		ifPresent: [ :behavior | 
			behavior
				compile: aMethodCreated sourceCode 
				classified: aMethodCreated protocol ]! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitMethodChange: aChange
	^ self visitCodeChange: aChange! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryChange: aChange
	^ self visitCodeChange: aChange! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aPackageCreated
	environment organization addCategory: aPackageCreated categoryName! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aMethodModified

	self 
		behaviorNamed: aMethodModified behaviorAffectedName
		ifPresent: [ :behavior | 
			behavior
				compile: aMethodModified newSourceCode 
				classified: aMethodModified newProtocol ]! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aClassRenameChange
	(environment classOrTraitNamed: aClassRenameChange oldName)
		rename: aClassRenameChange newName! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aPackageRemoved
	environment organization removeCategory: aPackageRemoved categoryName! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aProtocolAddition
	self 
		behaviorNamed: aProtocolAddition behaviorAffectedName
		ifPresent: [ :behavior | 
			behavior organization addCategory: aProtocolAddition protocol ]! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitCodeChange: aChange
	"Default behavior for any change."
		
	^ self visitEvent: aChange! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorChange: aChange
	^ self visitCodeChange: aChange! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aChange

	self compiler evaluate: aChange traitAdded definitionSource! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange

	self
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :aClass | 
			aClass 
				classComment: aChange newComment
				stamp: aChange newStamp ]! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolChange: aProtocolAddition
	^ self visitBehaviorChange: aProtocolAddition.! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aChange

	self compiler evaluate: aChange newTrait definitionSource! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoval: aTraitRemoval

	environment removeClassNamed: aTraitRemoval behaviorAffectedName! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitTraitChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitClassChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aClassRemoval
	environment removeClassNamed: aClassRemoval behaviorAffectedName! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aMethodRemoval

	self 
		behaviorNamed: aMethodRemoval behaviorAffectedName
		ifPresent: [ :behavior | 
			behavior removeSelector: aMethodRemoval selector ]! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aProtocolRemoved
	self 
		behaviorNamed: aProtocolRemoved behaviorAffectedName
		ifPresent: [ :behavior | 
			behavior removeProtocol: aProtocolRemoved protocol ]! !

!EpApplyVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aModifiedClassChange
	self compiler
		evaluate: aModifiedClassChange newClass definitionSource;
		evaluate: aModifiedClassChange newClass classSide definitionSource! !

!EpApplyVisitor class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EpApplyVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EpApplyVisitor class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EpApplyVisitor class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EpApplyVisitor class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EpApplyVisitor class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EpApplyVisitor class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EpApplyVisitor class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EpApplyVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpApplyVisitor class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EpApplyVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EpApplyVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EpApplyVisitor class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EpApplyVisitor class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EpApplyVisitor class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EpApplyVisitor class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EpApplyVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EpApplyVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpApplyVisitor class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EpApplyVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EpApplyVisitor class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EpApplyVisitor class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!EpApplyVisitor class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!EpApplyVisitor class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!EpApplyVisitor class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EpApplyVisitor class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EpApplyVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EpApplyVisitor class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EpApplyVisitor class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EpAsEpiceaRingDefinitionTest methodsFor: 'tests' stamp: ''!
testPackageIsString

	self definitions do: [ :each |
		self assert: each package isString.
		self assert: each package isNotEmpty ]! !

!EpAsEpiceaRingDefinitionTest methodsFor: 'running' stamp: ''!
definitions
	"FIX: it should not have this external dependency to Fuel code entities."

	^ {	(FLSerializer >> #serialize:on:).
		(Object >> #fuelAccept:).
		FLSerializer.
		FLSerializer class. 
		FLTGlobalClassOrTraitSerializationTest.
		FLTGlobalClassOrTraitSerializationTest classTrait.
		} collect: [:each | each asEpiceaRingDefinition]! !

!EpBehaviorCategoryChange commentStamp: ''!
I represent a change in the category of a class or a trait.!
!EpBehaviorCategoryChange methodsFor: 'accessing' stamp: ''!
behaviorAffectedName
	^ self classAffected name! !

!EpBehaviorCategoryChange methodsFor: 'accessing' stamp: ''!
classAffected

	^ class! !

!EpBehaviorCategoryChange methodsFor: 'accessing' stamp: ''!
newCategory

	^ newCategory! !

!EpBehaviorCategoryChange methodsFor: 'initialize' stamp: ''!
initializeOldCategory: anOldCategory newCategory: aNewCategory class: aClass

	self initialize.
	oldCategory := anOldCategory.
	newCategory := aNewCategory.
	class := aClass asEpiceaRingDefinition.! !

!EpBehaviorCategoryChange methodsFor: 'accessing' stamp: ''!
behaviorAffected
	^ self classAffected! !

!EpBehaviorCategoryChange methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitBehaviorCategoryChange: self! !

!EpBehaviorCategoryChange methodsFor: 'accessing' stamp: ''!
oldCategory

	^ oldCategory! !

!EpBehaviorCategoryChange class methodsFor: 'instance creation' stamp: ''!
oldCategory: anOldCategory newCategory: aNewCategory class: aClass

	^ self basicNew 
		initializeOldCategory: anOldCategory newCategory: aNewCategory class: aClass;
		yourself! !

!EpBehaviorChange commentStamp: ''!
I represent a change in a class or a trait.!
!EpBehaviorChange methodsFor: 'comparing' stamp: ''!
= other

	^ self class = other class and: [ self behaviorAffected = other behaviorAffected ]! !

!EpBehaviorChange methodsFor: 'accessing' stamp: ''!
behaviorAffectedName
	^ self shouldBeImplemented! !

!EpBehaviorChange methodsFor: 'comparing' stamp: ''!
hash

	^ self class hash bitXor: self behaviorAffected hash! !

!EpBehaviorChange methodsFor: 'testing' stamp: ''!
doesOverride: aCodeChange 
	
	^ aCodeChange class = self class and: [ 
		aCodeChange behaviorAffectedName = self behaviorAffectedName ]! !

!EpBehaviorChange methodsFor: 'accessing' stamp: ''!
behaviorAffected
	^ self shouldBeImplemented! !

!EpBehaviorChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.

	aStream 
		nextPut: $(;
		nextPutAll: self behaviorAffectedName;
		nextPut: $)! !

!EpBehaviorChange methodsFor: 'testing' stamp: ''!
isEpBehaviorChange
	^true! !

!EpBehaviorChange methodsFor: 'accessing' stamp: ''!
affectedPackageName
	
	^  self behaviorAffected package! !

!EpBehaviorCommentChange commentStamp: ''!
I represent a change in the comment of a class or a trait.!
!EpBehaviorCommentChange methodsFor: 'accessing' stamp: ''!
behaviorAffectedName
	^ behavior name! !

!EpBehaviorCommentChange methodsFor: 'accessing' stamp: ''!
newComment
	^ newComment! !

!EpBehaviorCommentChange methodsFor: 'accessing' stamp: ''!
oldStamp
	^ oldStamp! !

!EpBehaviorCommentChange methodsFor: 'accessing' stamp: ''!
behaviorAffected
	^ behavior! !

!EpBehaviorCommentChange methodsFor: 'accessing' stamp: ''!
newStamp
	^ newStamp! !

!EpBehaviorCommentChange methodsFor: 'accessing' stamp: ''!
oldComment
	^ oldComment! !

!EpBehaviorCommentChange methodsFor: 'initialization' stamp: ''!
initializeWithBehavior: aBehavior oldComment: anOldComment newComment: aNewComment oldStamp: anOldStamp newStamp: aNewStamp

	self initialize.
	behavior := aBehavior.
	oldComment := anOldComment.
	newComment := aNewComment.
	oldStamp := anOldStamp.
	newStamp := aNewStamp.! !

!EpBehaviorCommentChange methodsFor: 'visitor' stamp: ''!
accept: aChangeVisitor 
	^ aChangeVisitor visitBehaviorCommentChange: self! !

!EpBehaviorCommentChange class methodsFor: 'instance creation' stamp: ''!
newWithBehavior: aBehavior oldComment: anOldComment newComment: aNewComment oldStamp: anOldStamp newStamp: aNewStamp

	^ self basicNew
		initializeWithBehavior:aBehavior
		oldComment: anOldComment
		newComment: aNewComment
		oldStamp: anOldStamp
		newStamp: aNewStamp;
		yourself! !

!EpBehaviorCommentChange class methodsFor: 'instance creation' stamp: ''!
newWith: aClassCommentedAnnouncement 

	^self
		newWithBehavior: aClassCommentedAnnouncement classCommented asEpiceaRingDefinition
		oldComment: aClassCommentedAnnouncement oldComment asString
		newComment: aClassCommentedAnnouncement newComment asString
		oldStamp: aClassCommentedAnnouncement oldStamp
		newStamp: aClassCommentedAnnouncement newStamp! !

!EpBehaviorCopy commentStamp: ''!
I represent a copy of a class or a trait .!
!EpBehaviorCopy methodsFor: 'accessing' stamp: ''!
newName
	
	^ newName! !

!EpBehaviorCopy methodsFor: 'initialize' stamp: ''!
initializeWithBehavior: aClass newName: aName
	self initialize.
	
	definition := aClass asEpiceaRingDefinition.
	newName := aName asSymbol! !

!EpBehaviorCopy methodsFor: 'accessing' stamp: ''!
definition
	
	^ definition! !

!EpBehaviorCopy methodsFor: 'visitor' stamp: ''!
accept: aVisitor 
	^ aVisitor visitBehaviorCopy: self! !

!EpBehaviorCopy class methodsFor: 'instance creation' stamp: ''!
fromBehavior: aClass newName: aName 

	^ self basicNew
		initializeWithBehavior: aClass 
		newName: aName;
		yourself! !

!EpBehaviorNameChange commentStamp: ''!
I represent a rename of a class or a trait.!
!EpBehaviorNameChange methodsFor: 'accessing' stamp: ''!
oldName

	^ oldName! !

!EpBehaviorNameChange methodsFor: 'accessing' stamp: ''!
behaviorAffectedName
	^ self classAffected name! !

!EpBehaviorNameChange methodsFor: 'accessing' stamp: ''!
classAffected

	^ behavior! !

!EpBehaviorNameChange methodsFor: 'initialization' stamp: ''!
initializeOldName: anOldName newName: aNewName class: aBehavior

	self initialize.
	behavior := aBehavior asEpiceaRingDefinition.
	oldName := anOldName.
	newName := aNewName.! !

!EpBehaviorNameChange methodsFor: 'accessing' stamp: ''!
newName

	^ newName! !

!EpBehaviorNameChange methodsFor: 'accessing' stamp: ''!
behaviorAffected
	^ self classAffected! !

!EpBehaviorNameChange methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitBehaviorNameChange: self! !

!EpBehaviorNameChange class methodsFor: 'instance creation' stamp: ''!
oldName: anOldName newName: aNewName class: aClass

	^ self basicNew 
		initializeOldName: anOldName newName: aNewName class: aClass;
		yourself! !

!EpBrowseVisitor commentStamp: ''!
I implement how to browse EpCodeChange instances.!
!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitClassAddition: aChange
	^ self visitClassChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aChange
	^ self visitCategoryChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aChange
	^ self visitMethodChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitMethodChange: aChange

	self 
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior | 
			behavior 
				compiledMethodAt: aChange methodAffectedSelector 
				ifPresent: #browse 
				ifAbsent: [ 
					self inform: 
						'Cannot find ', behavior asString, '>>', aChange methodAffectedSelector.
					behavior browse ] ].! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryChange: aChange

	| package |
	package := RPackageOrganizer default packageNamed: aChange affectedPackageName.
	package classTags
		detect: [ :tag |
			tag categoryName = aChange categoryName
		]
		ifFound: [ :tag | Smalltalk tools browser openOnPackage: tag ]
		ifNone: [ self inform: 'Category ' , aChange categoryName , ' not found.' ].! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aChange
	^ self visitCategoryChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aChange
	^ self visitMethodChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aChange
	^ self visitCategoryChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aProtocolAddition
	^ self visitProtocolChange: aProtocolAddition! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitCodeChange: aChange
	^ self error: 'Should not be reached'.! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorChange: aChange

	self 
		behaviorNamed: aChange behaviorAffectedName 
		ifPresent: #browse! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aChange
	^ self visitTraitChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolChange: aProtocolAddition
	^ self visitBehaviorChange: aProtocolAddition.! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aChange
	^ self visitTraitChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoval: aChange
	^ self visitTraitChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitTraitChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitClassChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aChange
	^ self visitClassChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aChange
	^ self visitMethodChange: aChange! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aProtocolRemoved
	^ self visitProtocolChange: aProtocolRemoved! !

!EpBrowseVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aChange
	^ self visitClassChange: aChange! !

!EpBrowseVisitor class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EpBrowseVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EpBrowseVisitor class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EpBrowseVisitor class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EpBrowseVisitor class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EpBrowseVisitor class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EpBrowseVisitor class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EpBrowseVisitor class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EpBrowseVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpBrowseVisitor class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EpBrowseVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EpBrowseVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EpBrowseVisitor class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EpBrowseVisitor class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EpBrowseVisitor class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EpBrowseVisitor class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EpBrowseVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EpBrowseVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpBrowseVisitor class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EpBrowseVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EpBrowseVisitor class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EpBrowseVisitor class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!EpBrowseVisitor class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!EpBrowseVisitor class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!EpBrowseVisitor class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EpBrowseVisitor class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EpBrowseVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EpBrowseVisitor class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EpBrowseVisitor class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EpCategoryAddition commentStamp: ''!
I represent the creation of a category in a package.!
!EpCategoryAddition methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitCategoryAddition: self! !

!EpCategoryChange commentStamp: ''!
I represent a change in the categories of a package.!
!EpCategoryChange methodsFor: 'testing' stamp: ''!
doesOverride: aCodeChange 

	^ aCodeChange isEpCategoryChange and: [
		aCodeChange affectedPackageName = self affectedPackageName ]! !

!EpCategoryChange methodsFor: 'testing' stamp: ''!
isEpCategoryChange

	^ true! !

!EpCategoryChange methodsFor: 'initialization' stamp: ''!
initializeNamed: aName packageName: aPackageName

	self initialize.
	classCategoryName := aName.
	affectedPackageName := aPackageName.! !

!EpCategoryChange methodsFor: 'accessing' stamp: ''!
affectedPackageName 

	^ affectedPackageName! !

!EpCategoryChange methodsFor: 'accessing' stamp: ''!
categoryName

	^ classCategoryName! !

!EpCategoryChange class methodsFor: 'instance creation' stamp: ''!
named: aName packageName: aPackageName

	^ self basicNew 
		initializeNamed: aName packageName: aPackageName;
		yourself! !

!EpCategoryChange class methodsFor: 'instance creation' stamp: ''!
named: aName

	^ self named: aName packageName: (self packageNameFromCategoryName: aName)! !

!EpCategoryChange class methodsFor: 'private' stamp: ''!
packageNameFromCategoryName: aName
	^ (RPackage organizer packageMatchingExtensionName: aName) ifNotNil: [ :package | package name ] ifNil: [ aName ]! !

!EpCategoryRemoval commentStamp: ''!
I represent the removal of a category in a package.!
!EpCategoryRemoval methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitCategoryRemoval: self! !

!EpCategoryRename commentStamp: ''!
I represent the rename of a category in a package.!
!EpCategoryRename methodsFor: 'accessing' stamp: ''!
initializeOldName: theOldName newName: theNewName packageName: aPackageName

	self initializeNamed: theNewName packageName: aPackageName.
	oldCategoryName := theOldName.! !

!EpCategoryRename methodsFor: 'accessing' stamp: ''!
newCategoryName

	^ self categoryName! !

!EpCategoryRename methodsFor: 'accessing' stamp: ''!
oldCategoryName

	^ oldCategoryName! !

!EpCategoryRename methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitCategoryRename: self.! !

!EpCategoryRename class methodsFor: 'instance creation' stamp: ''!
oldName: oldName newName: newName packageName: packageName

	^ self basicNew
		initializeOldName: oldName newName: newName packageName: packageName;
		yourself! !

!EpCategoryRename class methodsFor: 'instance creation' stamp: ''!
oldName: oldName newName: newName

	^self
		oldName: oldName
		newName: newName
		packageName: (self packageNameFromCategoryName: newName)! !

!EpClassAddition commentStamp: ''!
I represent the creation of a class.!
!EpClassAddition methodsFor: 'accessing' stamp: ''!
behaviorAffectedName

	^ class name! !

!EpClassAddition methodsFor: 'accessing' stamp: ''!
behaviorAffected

	^ class! !

!EpClassAddition methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitClassAddition: self! !

!EpClassAddition methodsFor: 'accessing' stamp: ''!
classAdded

	^ class! !

!EpClassAddition methodsFor: 'initialization' stamp: ''!
initializeClass: aClass
	self initialize.
	class := aClass asEpiceaRingDefinition! !

!EpClassAddition class methodsFor: 'instance creation' stamp: ''!
class: aClass

	^ self basicNew 
		initializeClass: aClass;
		yourself! !

!EpClassChange commentStamp: ''!
I represent a change in the definition of a class.!
!EpClassChange methodsFor: 'testing' stamp: ''!
doesOverride: aCodeChange

	^ aCodeChange isEpClassChange and: [
		aCodeChange behaviorAffectedName = self behaviorAffectedName ]! !

!EpClassChange methodsFor: 'testing' stamp: ''!
isEpClassChange

	^ true! !

!EpClassModification commentStamp: ''!
I represent the modification of a class.!
!EpClassModification methodsFor: 'testing' stamp: ''!
hasNonMetaclassChanges

	^ oldClass classVarNames ~= newClass classVarNames
		or: [ oldClass instVarNames ~= newClass instVarNames
				or: [ oldClass sharedPoolNames ~= newClass sharedPoolNames
						or: [ oldClass superclassName ~= newClass superclassName ] ] ]! !

!EpClassModification methodsFor: 'initialization' stamp: ''!
initializeOldClass: anOldClass newClass: aNewClass

	self initialize.
	oldClass := anOldClass asEpiceaRingDefinition instanceSide.
	newClass := aNewClass asEpiceaRingDefinition instanceSide.! !

!EpClassModification methodsFor: 'accessing' stamp: ''!
behaviorAffectedName
	^ newClass name! !

!EpClassModification methodsFor: 'accessing' stamp: ''!
oldClass

	^ oldClass! !

!EpClassModification methodsFor: 'testing' stamp: ''!
hasMetaclassChanges
	"FIX should compare metaclasses as a whole"

	^ oldClass classSide instVarNames ~= newClass classSide instVarNames! !

!EpClassModification methodsFor: 'accessing' stamp: ''!
newClass

	^ newClass! !

!EpClassModification methodsFor: 'accessing' stamp: ''!
behaviorAffected
	^ newClass! !

!EpClassModification methodsFor: 'testing' stamp: ''!
hasChanges
	^ oldClass definitionSource ~= newClass definitionSource or: [ 
		oldClass classSide definitionSource ~= newClass classSide definitionSource ]! !

!EpClassModification methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitClassModification: self! !

!EpClassModification class methodsFor: 'instance creation' stamp: ''!
oldClass: anOldClass newClass: aNewClass

	^ self basicNew
		initializeOldClass: anOldClass
		newClass: aNewClass;
		yourself! !

!EpClassRemoval commentStamp: ''!
I represent the removal of a class.!
!EpClassRemoval methodsFor: 'accessing' stamp: ''!
behaviorAffectedName

	^ self behaviorAffected ifNotNil: #name! !

!EpClassRemoval methodsFor: 'testing' stamp: ''!
doesOverride: aCodeChange

	^ (super doesOverride: aCodeChange) or: [
		(aCodeChange isEpBehaviorChange or: [ aCodeChange isEpMethodChange ]) and: [
		aCodeChange behaviorAffectedName = self behaviorAffectedName ]]! !

!EpClassRemoval methodsFor: 'accessing' stamp: ''!
behaviorAffected
	^ classRemoved! !

!EpClassRemoval methodsFor: 'initialization' stamp: ''!
initializeClassRemoved: aRemovedClass

	self initialize.
	classRemoved := aRemovedClass asEpiceaRingDefinition.! !

!EpClassRemoval methodsFor: 'accessing' stamp: ''!
classRemoved

	^ classRemoved! !

!EpClassRemoval methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitClassRemoval: self! !

!EpClassRemoval class methodsFor: 'instance creation' stamp: ''!
class: aClassRemoved

	^ self basicNew 
		initializeClassRemoved: aClassRemoved;
		yourself! !

!EpCodeChange commentStamp: ''!
I represent a change in a code entity.!
!EpCodeChange methodsFor: '*EpiceaBrowsers' stamp: ''!
previewedApplyEvents

	^ self accept: EpApplyPreviewer new! !

!EpCodeChange methodsFor: 'testing' stamp: ''!
doesOverride: aCodeChange 

	^ self subclassResponsibility! !

!EpCodeChange methodsFor: 'testing' stamp: ''!
isCodeChange

	^ true! !

!EpCodeChange methodsFor: '*EpiceaBrowsers' stamp: ''!
applyCodeChange
	"Apply this code change in current image"

	^ self accept: EpApplyVisitor new! !

!EpCodeChange methodsFor: '*EpiceaBrowsers' stamp: ''!
asRevertedCodeChange
	"Answer a code change that represents my inverse operation. For example, a class addition will answer a class removal."

	^ self accept: EpInverseVisitor new! !

!EpCodeChange methodsFor: 'accessing' stamp: ''!
affectedPackageName

	^ self subclassResponsibility! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testClassRemovalWithMethods

	| events category |
	aClass := classFactory newClass.
	category := aClass category.
	1 to: 7 do: [:index |
		aClass compile: 'inst', index asString.
		aClass classSide compile: 'class', index asString ].
	aClass removeFromSystem.
	
	events := self allLogEventsWith: EpMethodRemoval.
	self assert: events size equals: 14.
	self assert: (events allSatisfy: [ :each | each affectedPackageName = category ])! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testRedundantClassDefinition

	aClass := classFactory newClass.
	self assert: (self countLogEventsWith: EpClassModification) equals: 0.
	self class compiler evaluate: aClass definitionString.

	self assert: (self countLogEventsWith: EpClassModification) equals: 0.
	self class compiler evaluate: aClass classSide definitionString.

	self assert: (self countLogEventsWith: EpClassModification) equals: 0.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testTraitRemoval

	| trait category events event |
	trait := classFactory newTrait.
	category := trait category.
	trait removeFromSystem.
	
	events := self allLogEventsWith: EpTraitRemoval.
	self assert: events size equals: 1.
	event := events anyOne.
	self assert: event behaviorAffected category equals: category.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testInstanceVariableRemoval

	aClass := classFactory 
		newSubclassOf: Object 
		instanceVariableNames: 'x' 
		classVariableNames: ''.

	self assert: (self countLogEventsWith: EpClassModification) equals: 0.
	aClass removeInstVarNamed: #x.

	self assert: (self countLogEventsWith: EpClassModification) equals: 1.
	self assert: (self allLogEventsWith: EpClassModification) first hasNonMetaclassChanges! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testMethodProtocolChange

	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: #accessing.
	aClass compile: 'fortyTwo ^42' classified: #testing.

	self assert: (self countLogEventsWith: EpMethodModification) equals: 2! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testBehaviorCommentChange

	aClass := classFactory newClass.
	self assert: (self countLogEventsWith: EpBehaviorCommentChange) equals: 0.
	
	aClass classComment: 'hey!!' stamp: DateAndTime now.
	self assert: (self countLogEventsWith: EpBehaviorCommentChange) equals: 1.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testTraitAddition

	| trait category events event |
	trait := classFactory newTrait.
	category := trait category.
	
	events := self allLogEventsWith: EpTraitAddition.
	self assert: events size equals: 1.
	event := events anyOne.
	self assert: event behaviorAffected category equals: category! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testCategoryRemoval

	self class environment organization addCategory: self categoryNameForTesting.
	self assert: (self countLogEventsWith: EpCategoryRemoval) equals: 0.

	self class environment organization removeCategory: self categoryNameForTesting.	
	self assert: (self countLogEventsWith: EpCategoryRemoval) equals: 1.
	self 
		assert: (self allLogEventsWith: EpCategoryRemoval) first affectedPackageName 
		equals: self categoryNameForTesting! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testInstanceVariableAddition

	aClass := classFactory newClass.
	self assert: (self countLogEventsWith: EpClassModification) equals: 0.
		
	aClass addInstVarNamed: #x.
	self assert: (self countLogEventsWith: EpClassModification) equals: 1.
	self assert: (self allLogEventsWith: EpClassModification) first hasNonMetaclassChanges! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testMethodModificationOfSourceCode

	| events event |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42'.
	aClass compile: 'fortyTwo ^nil'.

	events := self allLogEventsWith: EpMethodModification.
	self assert: events size equals: 1.
	event := events anyOne.
	self assert: event oldMethod sourceCode equals: 'fortyTwo ^42'.
	self assert: event newMethod sourceCode equals: 'fortyTwo ^nil'.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testRemoveTraitFromComposition

	aClass := classFactory newClassUsing: TSizeTest.
	self 
		shouldnt: [ 
			self class classInstaller make: [ :aBuilder | 
				aBuilder 
					name: aClass name;
					traitComposition: {};
					package: aClass category]] 
		raise: MessageNotUnderstood! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testClassModificationWithHierarchy
	
	| modifications |
	aClass := classFactory newClass.
	classFactory newSubclassOf: aClass using: {}.
	aClass addSlot: #i asSlot.

	modifications := (self allLogEntriesWith: EpClassModification) collect: [:each | each content].
	self assert: modifications size equals: 1.
	self assert: modifications first behaviorAffectedName equals: aClass name.! !

!EpCodeChangeIntegrationTest methodsFor: 'running' stamp: ''!
tearDown
	
	self class environment organization removeCategory: self categoryNameForTesting.
	super tearDown.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testProtocolAddition

	aClass := classFactory newClass.
	aClass organization addCategory: #testing42.

	self assert: (self countLogEventsWith: EpProtocolAddition) equals: 1! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testTraitModificationOfTraitComposition
	
	| aTrait |
	aClass := classFactory newTrait.
	aTrait := classFactory newTrait.
	aClass setTraitComposition: aTrait asTraitComposition.

	self assert: (self countLogEventsWith: EpTraitModification) equals: 1.
	self assert: (self countLogEventsWith: EpMethodAddition) equals: 0.
	self assert: (self countLogEventsWith: EpMethodModification) equals: 0.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testClassInstanceVariableAddition

	aClass := classFactory newClass.
	self assert: (self countLogEventsWith: EpClassModification) equals: 0.
		
	aClass class addInstVarNamed: #x.
	self assert: (self countLogEventsWith: EpClassModification) equals: 1.
	self assert: (self allLogEventsWith: EpClassModification) first hasMetaclassChanges! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testClassModificationOfTraitComposition
	
	| aTrait |
	aClass := classFactory newClass.
	aTrait := classFactory newTrait.
	aClass setTraitComposition: aTrait asTraitComposition.

	self assert: (self countLogEventsWith: EpClassModification) equals: 1.
	self assert: (self countLogEventsWith: EpMethodAddition) equals: 0.
	self assert: (self countLogEventsWith: EpMethodModification) equals: 0.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testMethodRecompilationShouldNotLog

	| headBeforeRecompiling |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42'.
	headBeforeRecompiling := monitor log head.
	aClass compile: 'fortyTwo ^42'.

	self assert: monitor log head identicalTo: headBeforeRecompiling! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testCategoryAddition

	self assert: (self countLogEventsWith: EpCategoryAddition) equals: 0.

	self class environment organization addCategory: self categoryNameForTesting.
	
	self assert: (self countLogEventsWith: EpCategoryAddition) equals: 1.
	self 
		assert: (self allLogEventsWith: EpCategoryAddition) first affectedPackageName 
		equals: self categoryNameForTesting! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testMethodModificationWithWideString

	aClass := classFactory newClass.
	aClass compile: self wideStringSourceCode.
	aClass compile: self wideStringSourceCode, ' '.

	self assert: (self countLogEventsWith: EpMethodModification) equals: 1! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testProtocolRemoval

	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: #testing42.
	aClass removeProtocol: #testing42.

	self assert: (self countLogEventsWith: EpProtocolRemoval) equals: 1! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testMethodAddition

	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42'.

	self assert: (self countLogEventsWith: EpMethodAddition) equals: 1! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testClassInstanceVariableRemoval

	aClass := classFactory newClass.
	aClass class addInstVarNamed: #x.
	self assert: (self countLogEventsWith: EpClassModification) equals: 1.
		
	aClass class removeInstVarNamed: #x.
	self assert: (self countLogEventsWith: EpClassModification) equals: 2.
	self assert: ((self allLogEventsWith: EpClassModification) allSatisfy: #hasMetaclassChanges)! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testProtocolRemovalOfUnclassifiedProtocol
	"This protocol is not relevant then it's not logged."

	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: Protocol unclassified.
	aClass removeProtocol: Protocol unclassified.

	self assert: (self countLogEventsWith: EpProtocolRemoval) equals: 0! !

!EpCodeChangeIntegrationTest methodsFor: 'running' stamp: ''!
wideStringSourceCode
	
	^ 
'pangrams
	^ OrderedCollection new
		add: ''English'' -> ''the quick brown fox jumps over the lazy dog'';
		add: ''Bulgarian'' -> ''Под южно дърво, цъфтящо в синьо, бягаше малко пухкаво зайче.'';
		add: ''Czech'' -> ''Příliš žluťoučký kůň úpěl ďábelské ódy.'';
		add: ''Chinese'' -> ''視野無限廣，窗外有藍天
    微風迎客，軟語伴茶'';
		add: ''Danish'' -> ''Quizdeltagerne spiste jordbær med fløde, mens cirkusklovnen Walther spillede på xylofon.'';
		add: ''Dutch'' -> ''Pa''''s wijze lynx bezag vroom het fikse aquaduct'';
		add: ''Esperanto'' -> ''Eĥoŝanĝo ĉiuĵaŭde'';
		add: ''Estonian'' -> ''See väike mölder jõuab rongile hüpata'';
		add: ''Finnish'' -> ''Viekas kettu punaturkki laiskan koiran takaa kurkki'';
		add: ''French'' -> ''Voix ambiguë d''''un cœur qui au zéphyr préfère les jattes de kiwis'';
		add: ''German'' -> ''Zwölf Boxkämpfer jagen Viktor quer über den großen Sylter Deich'';
		add: ''Greek'' -> ''Θέλει αρετή και τόλμη η ελευθερία. (Ανδρέας Κάλβος)'';
		add: ''Hebrew'' -> ''דג סקרן שט לו בים זך אך לפתע פגש חבורה נחמדה שצצה כך'';
		add: ''Hungarian'' -> ''Egy hűtlen vejét fülöncsípő, dühös mexikói úr Wesselényinél mázol Quitóban'';
		add: ''Italian'' -> ''Ma la volpe, col suo balzo, ha raggiunto il quieto Fido.'';
		add: ''Japanese'' -> ''いろはにほへと ちりぬるを わかよたれそ つねならむ うゐのおくやま けふこえて あさきゆめみし ゑひもせす'';
		add: ''Korean'' -> ''다람쥐 헌 쳇바퀴에 타고파'';
		add: ''Latvian'' -> ''Sarkanās jūrascūciņas peld pa jūru.'';
		add: ''Norwegian'' -> ''En god stil må først og fremst være klar. Den må være passende. Aristoteles.'';
		add: ''Portugese'' -> ''A rápida raposa castanha salta por cima do cão lento.'';
		add: ''Brazilian portugese'' -> ''A ligeira raposa marrom ataca o cão preguiçoso'';
		add: ''Polish'' -> ''Pchnąć w tę łódź jeża lub ośm skrzyń fig'';
		add: ''Romanian'' -> ''Agera vulpe maronie sare peste câinele cel leneş'';
		add: ''Russian'' -> ''Съешь ещё этих мягких французских булок да выпей же чаю'';
		add: ''Serbian (cyrillic)'' -> ''Чешће цeђење мрeжастим џаком побољшава фертилизацију генских хибрида.'';
		add: ''Serbian (latin)'' -> ''Češće ceđenje mrežastim džakom poboljšava fertilizaciju genskih hibrida.'';
		add: ''Slovak'' -> ''Kŕdeľ šťastných ďatľov učí pri ústí Váhu mĺkveho koňa obhrýzať kôru a žrať čerstvé mäso.'';
		add: ''Slovene'' -> ''V kožuščku hudobnega fanta stopiclja mizar in kliče 0619872345.'';
		add:
				''Spanish''
						->
							''El veloz murciélago hindú comía feliz cardillo y kiwi. La cigüeña tocaba el saxofón detrás del palenque de paja.'';
		add: ''Swedish'' -> ''Flygande bäckasiner söka hwila på mjuka tuvor'';
		add:
				''Thai''
						->
							''เป็นมนุษย์สุดประเสริฐเลิศคุณค่า
    กว่าบรรดาฝูงสัตว์เดรัจฉาน
    จงฝ่าฟันพัฒนาวิชาการ อย่าล้างผลาญฤๅเข่นฆ่าบีฑาใคร
    ไม่ถือโทษโกรธแช่งซัดฮึดฮัดด่า
    หัดอภัยเหมือนกีฬาอัชฌาสัย
    ปฏิบัติประพฤติกฎกำหนดใจ
    พูดจาให้จ๊ะ ๆ จ๋า ๆ น่าฟังเอยฯ'';
		add: ''Turkish'' -> ''Pijamalı hasta, yağız şoföre çabucak güvendi'';
		yourself'! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testClassAddition

	self assert: (self countLogEventsWith: EpClassAddition) equals: 0.

	classFactory newClass.
	self assert: (self countLogEventsWith: EpClassAddition) equals: 1.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testMetaclassInstanceVariableAdditionWithTrait

	| aTrait |
	aClass := classFactory newClass.
	aTrait := classFactory newTrait.

	self assert: (self countLogEventsWith: EpClassModification) equals: 0.
	aClass classSide uses: aTrait asTraitComposition instanceVariableNames: 'x'.	
	self assert: (self countLogEventsWith: EpClassModification) equals: 1.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testMethodModificationOfProtocol

	| events event |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'old'.
	(aClass>>#fortyTwo) protocol: 'new'.

	events := self allLogEventsWith: EpMethodModification.
	self assert: events size equals: 1.
	event := events anyOne.
	self assert: event oldMethod protocol equals: 'old'.
	self assert: event newMethod protocol equals: 'new'.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
categoryNameForTesting

	^ #'EpiceaTestingWith-A-Really-WeirdCategoryName'! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testMetaclassInstanceVariableAddition

	aClass := classFactory newClass.

	self assert: (self countLogEventsWith: EpClassModification) equals: 0.
	aClass classSide instanceVariableNames: 'x'.	
	self assert: (self countLogEventsWith: EpClassModification) equals: 1.! !

!EpCodeChangeIntegrationTest methodsFor: 'tests' stamp: ''!
testClassRemoval

	| className events |
	aClass := classFactory newClass.
	className := aClass name.
	aClass removeFromSystem.
	
	events := self allLogEventsWith: EpClassRemoval.
	self assert: events size equals: 1.
	"It shouldn't begin with AnObsolete"
	self assert: events anyOne behaviorAffectedName equals: className.! !

!EpCommentTest methodsFor: 'tests' stamp: ''!
testComment

	| presentComment |
	classFactory newClass.
	self setHeadAsInputEntry.
	
	monitor logEntryCommented:
		(EpLogEntriesComment 
			entryReferences: { monitor log referenceTo: inputEntry }
			oldComment: ''
			newComment: '42').
			
	self assert: (self countLogEventsWith: EpLogEntriesComment) equals: 1.
	
	monitor log 
		commentAt: inputEntry
		ifAbsent: [ self fail: 'it should answer the comment' ].
		
	presentComment := nil.
	monitor log 
		commentAt: inputEntry
		ifPresent: [ :comment | presentComment := comment ].
	self assert: presentComment equals: '42'.! !

!EpCompositeRefactoring commentStamp: ''!
I represent a refactoring that is composed of other refactorings.!
!EpCompositeRefactoring methodsFor: 'converting' stamp: ''!
asRBRefactoring
	^ RBCompositeRefactoryChange new
		changes: (childrenRefactorings collect: [:each | each asRBRefactoring]);
		yourself! !

!EpCompositeRefactoring methodsFor: 'accessing' stamp: ''!
childrenRefactorings
	^ childrenRefactorings! !

!EpCompositeRefactoring methodsFor: 'initializing' stamp: ''!
initializeWith: someRefactorings 
	self initialize.
	childrenRefactorings := someRefactorings collect: [:each | each asEpiceaEvent]! !

!EpCompositeRefactoring methodsFor: '*EpiceaBrowsers' stamp: ''!
summaryOn: aWriteStream
	"Write a string summarizing myself."
	
	childrenRefactorings
		do: [:each | each summaryOn: aWriteStream ]
		separatedBy: [ aWriteStream nextPutAll: ', ' ]! !

!EpCompositeRefactoring class methodsFor: 'instance creation' stamp: ''!
withAll: someRefactorings
	^ self basicNew 	
		initializeWith: someRefactorings;
		yourself! !

!EpContentStringVisitor commentStamp: ''!
I am an abstract superclass for some visitors that answer Strings describing EpEvent instances.!
!EpContentStringVisitor methodsFor: 'visitor' stamp: ''!
visitEvent: anEvent
	"By default display an empty string"

	^ ''! !

!EpContentStringVisitor methodsFor: 'private' stamp: ''!
printProtocol: protocol sourceCode: sourceCode

	^ String streamContents: [ :stream |
		stream
			nextPutAll: '"protocol: '; 
			nextPutAll: protocol printString;
			nextPut: $"; cr; cr;
			nextPutAll: sourceCode ]! !

!EpContentStringVisitor methodsFor: 'visitor' stamp: ''!
stringForBehavior: aClassOrTrait

	^ String streamContents: [ :stream |
		stream
			nextPutAll: aClassOrTrait definitionSource;
			nextPut: $.;
			cr; cr;
			nextPutAll: aClassOrTrait classSide definitionSource ]! !

!EpContentStringVisitor methodsFor: 'private' stamp: ''!
displayBrowserOperation: aBrowserOperationEvent

	^ String streamContents: [ :stream |
		stream 
			print: aBrowserOperationEvent entryReferences size;
			nextPutAll: ' code changes produced' ]! !

!EpDashboardPresenter commentStamp: ''!
I'm a Spec model to manage the global state of Epicea.

Open with:
self open!
!EpDashboardPresenter methodsFor: 'actions' stamp: ''!
openSettingsBrowser
	"Inspired on Glamour's code"

	| settingsBrowser settingsWindow |
	settingsBrowser := SettingBrowser new 
		changePackageSet: (RPackage organizer packageNamed: 'EpiceaBrowsers') asOrderedCollection;
		yourself.
	settingsWindow := settingsBrowser open.
	settingsWindow position: Display extent - settingsWindow extent // 2.
	settingsBrowser expandAll.! !

!EpDashboardPresenter methodsFor: 'initialization' stamp: ''!
initializeRefreshEnableMonitorButtonModelOnMonitorUpdate
	self monitor announcer weak when: EpMonitorStateUpdated send: #refreshEnableMonitorButtonPresenter to: self! !

!EpDashboardPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	currentSessionInfoPresenter := self newText.
	enableMonitorButton := self newButton.
	openSettingsButton := self newButton.
	createLogButton := self newButton.

	self initializeCreateLogButton.
	self initializeEnableMonitorButton.
	self initializeOpenSettingsButton.

	currentSessionInfoPresenter enabled: false! !

!EpDashboardPresenter methodsFor: 'accessing' stamp: ''!
monitor
	
	^ monitor ifNil: [ EpMonitor current ]! !

!EpDashboardPresenter methodsFor: 'refreshing' stamp: ''!
refresh
	self refreshEnableMonitorButtonPresenter.
	self refreshCurrentSessionInfoPresenter! !

!EpDashboardPresenter methodsFor: 'refreshing' stamp: ''!
refreshCurrentSessionInfoPresenter
	| sessionStore text |
	sessionStore := self monitor sessionStore.

	text := String
		streamContents: [ :stream | 
			stream
				nextPutAll: 'Current Log: ';
				cr;
				nextPutAll: sessionStore writingFileReference basename;
				cr;
				cr;
				nextPutAll: 'Directory: ';
				cr;
				nextPutAll: sessionStore writingFileReference parent fullName ].

	currentSessionInfoPresenter text: text! !

!EpDashboardPresenter methodsFor: 'actions' stamp: ''!
createNewSessionLog
	
	| fileNameOrNil sessionStore |
	sessionStore := self monitor sessionStore.

	fileNameOrNil := UIManager default
		request: 'Enter a file name (without extension) for the new log.'
		initialAnswer: sessionStore nextStoreName.
	fileNameOrNil ifNil: [ ^ self ].

	(self monitor sessionStore existsStoreNamed: fileNameOrNil)
		ifTrue: [ 
			self inform: 'Invalid name: Already used' ]
		ifFalse: [
			self monitor sessionStore resetWithStoreNamed: fileNameOrNil.
			self refresh ]! !

!EpDashboardPresenter methodsFor: 'accessing' stamp: ''!
monitor: anEpMonitor

	monitor := anEpMonitor.
	self refreshEnableMonitorButtonPresenter! !

!EpDashboardPresenter methodsFor: 'initialization' stamp: ''!
updatePresenter

	self refresh! !

!EpDashboardPresenter methodsFor: 'refreshing' stamp: ''!
refreshEnableMonitorButtonPresenter
	enableMonitorButton
		state: self monitor isEnabled;
		label: self monitor statusString;
		icon: (self iconNamed: self monitor statusIcon)! !

!EpDashboardPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	aWindowPresenter
		title: 'Epicea - Dashboard';
		initialExtent: 450 @ 200;
		whenClosedDo: [ self monitor announcer unsubscribe: self ]! !

!EpDashboardPresenter methodsFor: 'initialization' stamp: ''!
initializeOpenSettingsButton
	openSettingsButton
		help: 'Open Epicea''s system settings';
		icon: (self iconNamed: #config);
		label: 'More settings...';
		action: [ self openSettingsBrowser ]! !

!EpDashboardPresenter methodsFor: 'initialization' stamp: ''!
initializeCreateLogButton
	createLogButton
		icon: (self iconNamed: #addIcon);
		help: 'Start recording into new Log';
		label: 'New session';
		action: [ self createNewSessionLog ]! !

!EpDashboardPresenter methodsFor: 'initialization' stamp: ''!
initializeEnableMonitorButton
	enableMonitorButton
		help: 'Enable/disable the Epicea Monitor. When enabled, it logs code changes (and some IDE events such as MC load/save and refactorings) performed in this Pharo session.';
		action: [ self monitor enabled: enableMonitorButton state not ]! !

!EpDashboardPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter 
	super initializePresenter.

	"Listen announcers"
	self initializeRefreshEnableMonitorButtonModelOnMonitorUpdate.! !

!EpDashboardPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #currentSessionInfoPresenter;
		add:
			(SpBoxLayout newLeftToRight
					add: #enableMonitorButton;
					add: #createLogButton;
					add: #openSettingsButton;
					yourself)
			expand: false
			fill: false
			padding: 0;
		yourself! !

!EpDashboardPresenter class methodsFor: 'instance creation' stamp: ''!
open
	^ self new
		refresh;
		openWithSpec;
		yourself! !

!EpDashboardPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Epicea - Dashboard'! !

!EpDashboardPresenter class methodsFor: 'icons' stamp: ''!
taskbarIconName
	^ #config! !

!EpDisabledIntegrationTest methodsFor: 'tests' stamp: ''!
testDisableDuringWithInterruption

	monitor enable.
	self assert: monitor isEnabled.
	
	[ monitor
		disableDuring: [ self deny: monitor isEnabled.
			self error ] ]
		on: Error
		do: [ "We just want to test the case with an error." ].
		
	self assert: monitor isEnabled! !

!EpDisabledIntegrationTest methodsFor: 'tests' stamp: ''!
testWhenDisabledShouldNotLog
	classFactory newClass.

	self assert: (self countLogEventsWith: EpClassAddition) equals: 0! !

!EpDisabledIntegrationTest methodsFor: 'tests' stamp: ''!
testWhenEnabledShouldLog
	monitor enable.

	classFactory newClass.

	self assert: (self countLogEventsWith: EpClassAddition) equals: 1! !

!EpDisabledIntegrationTest methodsFor: 'tests' stamp: ''!
testDisableDuring
	monitor enable.
	self assert: monitor isEnabled.
	monitor disableDuring: [ self deny: monitor isEnabled ].
	self assert: monitor isEnabled.
	monitor disable.
	self deny: monitor isEnabled.
	monitor disableDuring: [ self deny: monitor isEnabled ].
	self deny: monitor isEnabled.! !

!EpDisabledIntegrationTest methodsFor: 'tests' stamp: ''!
testIsEnabled
	self deny: monitor isEnabled.
	monitor enable.
	self assert: monitor isEnabled.
	monitor disable.
	self deny: monitor isEnabled.! !

!EpDisabledIntegrationTest methodsFor: 'tests' stamp: ''!
testWhenEnabledTwiceShouldNotDuplicateEntries
	2 timesRepeat: [ monitor enable ].

	classFactory newClass.

	self assert: (self countLogEventsWith: EpClassAddition) equals: 1! !

!EpDisabledIntegrationTest methodsFor: 'tests' stamp: ''!
testEnable
	monitor enable.
	
	self assert: (self countLogEventsWith: EpClassAddition) equals: 0.
	
	classFactory newClass.

	self assert: (self countLogEventsWith: EpClassAddition) equals: 1.! !

!EpEnabledIntegrationTest commentStamp: ''!
I test EpMonitor integration (with change recording actually enabled).!
!EpEnabledIntegrationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	monitor enable.! !

!EpEntryAdded commentStamp: ''!
I announce that an entry has been added to a log.!
!EpEntryAdded methodsFor: 'initialization' stamp: ''!
initializeWith: anEntry

	self initialize.
	entry := anEntry.! !

!EpEntryAdded methodsFor: 'accessing' stamp: ''!
entry
	^ entry! !

!EpEntryAdded class methodsFor: 'instance creation' stamp: ''!
for: anEntry

	^ self basicNew
		initializeWith: anEntry;
		yourself! !

!EpEntryContentVisitor commentStamp: ''!
I am an abstract superclass for some visitors that answer objects describing EpEvent instances.!
!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitClassAddition: aChange
	^ self visitClassChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitMethodChange: aChange
	^ self visitCodeChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitRedo: aRedoEvent
	^ self visitEvent: aRedoEvent! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitRefactoring: anEvent 
	^ self visitEvent: anEvent! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitMonticelloVersionsLoad: anEvent
	^ self visitEvent: anEvent! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitSessionSnapshot: anEvent
	^ self visitEvent: anEvent! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitMonticelloVersionSave: anEvent
	^ self visitEvent: anEvent! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aChange
	^ self visitCategoryChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aProtocolAddition
	^ self visitProtocolChange: aProtocolAddition! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aChange
	^ self visitClassChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitCodeChange: aChange
	"Default behavior for any change."
		
	^ self visitEvent: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoved: aChange
	^ self visitTraitChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aChange
	^ self visitTraitChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitEvent: aChange
	^ self error: 'Should not be reached'.! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aChange
	^ self visitTraitChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitTraitChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCopy: anEvent
	^ self visitEvent: anEvent! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitSessionEnd: anEvent
	^ self visitEvent: anEvent! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitClassChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aChange
	^ self visitMethodChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitLogCommentModification: anEvent 
	^ self visitEvent: anEvent! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aChange
	^ self visitMethodChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aChange
	^ self visitCategoryChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryChange: aChange
	^ self visitCodeChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aChange
	^ self visitCategoryChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aChange
	^ self visitMethodChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorChange: aChange
	^ self visitCodeChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoval: aChange
	^ self visitTraitChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolChange: aProtocolAddition
	^ self visitBehaviorChange: aProtocolAddition.! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitUndo: anUndoEvent
	^ self visitEvent: anUndoEvent! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitExpressionEvaluation: anExpressionEvaluation
	^ self visitEvent: anExpressionEvaluation! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitSessionStart: anEvent 
	^ self visitEvent: anEvent! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aChange
	^ self visitClassChange: aChange! !

!EpEntryContentVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aProtocolRemoved
	^ self visitProtocolChange: aProtocolRemoved! !

!EpEntryContentVisitor class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EpEntryContentVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EpEntryContentVisitor class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EpEntryContentVisitor class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EpEntryContentVisitor class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EpEntryContentVisitor class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EpEntryContentVisitor class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EpEntryContentVisitor class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EpEntryContentVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpEntryContentVisitor class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EpEntryContentVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EpEntryContentVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EpEntryContentVisitor class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EpEntryContentVisitor class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EpEntryContentVisitor class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EpEntryContentVisitor class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EpEntryContentVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EpEntryContentVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpEntryContentVisitor class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EpEntryContentVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EpEntryContentVisitor class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EpEntryContentVisitor class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!EpEntryContentVisitor class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!EpEntryContentVisitor class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!EpEntryContentVisitor class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EpEntryContentVisitor class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EpEntryContentVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EpEntryContentVisitor class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EpEntryContentVisitor class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EpEntryItem commentStamp: ''!
I am a log browser item that represents an entry.!
!EpEntryItem methodsFor: 'accessing' stamp: ''!
event

	^ entry content! !

!EpEntryItem methodsFor: 'accessing' stamp: ''!
log
	^ browser log! !

!EpEntryItem methodsFor: 'comparing' stamp: ''!
= other
	^ self species = other species and: [ self entry = other entry ]! !

!EpEntryItem methodsFor: 'comparing' stamp: ''!
hash
	^ self species hash bitXor: self entry hash! !

!EpEntryItem methodsFor: 'private' stamp: ''!
eventMorphs
	
	^ self eventAccept: EpMorphVisitor new! !

!EpEntryItem methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.

	aStream nextPut: $(.
	self entry printOn: aStream.
	aStream nextPut: $).! !

!EpEntryItem methodsFor: 'accessing' stamp: ''!
entry: anObject
	entry := anObject! !

!EpEntryItem methodsFor: 'accessing' stamp: ''!
browser
	^ browser! !

!EpEntryItem methodsFor: 'private' stamp: ''!
icon

	^ self eventAccept: EpIconVisitor new! !

!EpEntryItem methodsFor: 'accessing' stamp: ''!
triggerItems
	^ triggerItems! !

!EpEntryItem methodsFor: 'accessing' stamp: ''!
triggerItems: anObject
	triggerItems := anObject! !

!EpEntryItem methodsFor: 'operations' stamp: ''!
oldComment

	^ browser commentsLog commentAt: entry ifAbsent: [ '' ]! !

!EpEntryItem methodsFor: 'accessing' stamp: ''!
entry
	^ entry! !

!EpEntryItem methodsFor: 'operations' stamp: ''!
browseItem 
	self eventAccept: EpBrowseVisitor new! !

!EpEntryItem methodsFor: 'private' stamp: ''!
commentMorphs
	
	browser commentsLog
		commentAt: entry 
		ifPresent: [ :comment |
			comment trim ifNotEmpty: [:trimmedComment |
				^ { self morphFactory pillWith: trimmedComment } ] ].
	^ #()! !

!EpEntryItem methodsFor: 'private' stamp: ''!
triggerMarkMorphs

	^ self triggerItems collect: [:item |
		self morphFactory semiTransparent: item icon ]! !

!EpEntryItem methodsFor: 'converting' stamp: ''!
asMorph

	| morphs |
	morphs := OrderedCollection new.
	morphs addAll: self triggerMarkMorphs.
	morphs add: self icon asMorph.
	morphs addAll: self eventMorphs.
	morphs add: self morphFactory smallGap.
	morphs addAll: self timeMorphs.
	morphs addAll: self commentMorphs.

	^ self morphFactory rowWithAll: morphs! !

!EpEntryItem methodsFor: 'private' stamp: ''!
newStateString

	^ self eventAccept: EpNewStateVisitor new! !

!EpEntryItem methodsFor: 'operations' stamp: ''!
timeString
	| aDateTime |
	aDateTime := self log timeAt: entry ifAbsent: [ ^ '' ].
	
	^ aDateTime epiceaBrowsersAsString! !

!EpEntryItem methodsFor: 'private' stamp: ''!
eventAccept: aVisitor

	^ entry content accept: aVisitor! !

!EpEntryItem methodsFor: 'private' stamp: ''!
oldStateString

	^ entry content accept: EpOldStateVisitor new! !

!EpEntryItem methodsFor: 'accessing' stamp: ''!
reference
	^ self log referenceTo: entry! !

!EpEntryItem methodsFor: 'accessing' stamp: ''!
browser: anObject
	browser := anObject! !

!EpEntryItem methodsFor: 'private' stamp: ''!
morphFactory

	^ EpMorphFactory default! !

!EpEntryItem methodsFor: 'private' stamp: ''!
timeMorphs
	
	^ self timeString
		ifEmpty: [ #() ]
		ifNotEmpty: [:aString | { self morphFactory secondaryStringFor: aString } ]! !

!EpEntryReferencesFilter commentStamp: ''!
This filter rejects an arbitrary collection of log entries.!
!EpEntryReferencesFilter methodsFor: 'comparing' stamp: ''!
= other

	^ self class = other class and: [ 
		self rejectedEntryReferences = other rejectedEntryReferences ]! !

!EpEntryReferencesFilter methodsFor: 'comparing' stamp: ''!
hash

	^ self class hash bitXor: self rejectedEntryReferences hash! !

!EpEntryReferencesFilter methodsFor: 'accessing' stamp: ''!
rejectedEntryReferences: anObject
	rejectedEntryReferences := anObject! !

!EpEntryReferencesFilter methodsFor: 'accessing' stamp: ''!
theLog: anObject
	theLog := anObject! !

!EpEntryReferencesFilter methodsFor: 'accessing' stamp: ''!
rejectedEntryReferences
	^ rejectedEntryReferences! !

!EpEntryReferencesFilter methodsFor: 'testing' stamp: ''!
accepts: anOmEntry

	| reference |
	reference := theLog referenceTo: anOmEntry.

	^ (rejectedEntryReferences includes: reference) not! !

!EpEntryReferencesFilter methodsFor: 'accessing' stamp: ''!
theLog
	^ theLog! !

!EpEntryReferencesFilter methodsFor: 'accessing' stamp: ''!
title

	^ self class title! !

!EpEntryReferencesFilter class methodsFor: 'accessing' stamp: ''!
title

	^ 'Hide selected entries'! !

!EpEvent commentStamp: ''!
I am an abstract class that represents a system event.!
!EpEvent methodsFor: 'testing' stamp: ''!
isEpEvent

	^ true! !

!EpEvent methodsFor: '*EpiceaBrowsers' stamp: ''!
previewedApplyEvents

	^ #()! !

!EpEvent methodsFor: 'testing' stamp: ''!
isEpMethodChange

	^ false! !

!EpEvent methodsFor: 'testing' stamp: ''!
isCodeChange
	^ false! !

!EpEvent methodsFor: 'testing' stamp: ''!
isEpProtocolChange

	^ false! !

!EpEvent methodsFor: 'testing' stamp: ''!
isEpCategoryChange

	^ false! !

!EpEvent methodsFor: 'testing' stamp: ''!
isEpBehaviorChange

	^ false! !

!EpEvent methodsFor: 'testing' stamp: ''!
isEpTestResultSet

	^ false! !

!EpEvent methodsFor: 'testing' stamp: ''!
isMonticelloVersionSave

	^ false! !

!EpEvent methodsFor: 'testing' stamp: ''!
isMonticelloVersionsLoad

	^ false! !

!EpEvent methodsFor: 'testing' stamp: ''!
isEpRefactoring

	^ false! !

!EpEvent methodsFor: 'testing' stamp: ''!
isEpClassChange

	^ false! !

!EpEvent methodsFor: 'testing' stamp: ''!
isEpTraitChange

	^ false! !

!EpEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	self subclassResponsibility! !

!EpEvent methodsFor: 'testing' stamp: ''!
isEpLogEntriesComment

	^ false! !

!EpEvent class methodsFor: 'announcements' stamp: ''!
handlesAnnouncement: anAnnouncement
	"The receiver acts as a filter to determine whether subscribers who used the receiver as signaling tag (event identifier class or symbol) should receive incoming announcement. In particular, registering to a superclass will receive the announcements from all subclasses."

	^ anAnnouncement class includesBehavior: self! !

!EpExpressionEvaluation commentStamp: ''!
I represent a expression evaluation. For example, a 'Do It' or an 'Inspect It'.!
!EpExpressionEvaluation methodsFor: 'comparing' stamp: ''!
= other

	^ self class = other class 
		and: [ self expression = other expression ]! !

!EpExpressionEvaluation methodsFor: 'comparing' stamp: ''!
hash

	^ self class hash bitXor: self expression hash! !

!EpExpressionEvaluation methodsFor: 'initialize' stamp: ''!
initializeExpression: anExpression

	self initialize.
	expression := anExpression.! !

!EpExpressionEvaluation methodsFor: 'accessing' stamp: ''!
expression

	^ expression! !

!EpExpressionEvaluation methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream 
		nextPut: $(;
		print: self expression;
		nextPut: $)! !

!EpExpressionEvaluation methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitExpressionEvaluation: self! !

!EpExpressionEvaluation class methodsFor: 'instance creation' stamp: ''!
expression: anExpression 
	^ self basicNew 
		initializeExpression: anExpression;
		yourself! !

!EpFileLogNode commentStamp: ''!
I am a node in a tree of Epicea logs that represents a log file. Read more in my superclass comment.!
!EpFileLogNode methodsFor: 'accessing' stamp: ''!
modificationTime

	^ directoryEntry modificationTime! !

!EpFileLogNode methodsFor: 'accessing' stamp: ''!
modificationTimeString

	^ self modificationTime asDate epiceaBrowsersAsString! !

!EpFileLogNode methodsFor: 'accessing' stamp: ''!
log

	^ log ifNil: [ 
		log := EpLog newWithStore: self ombuStore ]! !

!EpFileLogNode methodsFor: 'initialization' stamp: ''!
initializeWithEntry: aDirectoryEntry

	directoryEntry := aDirectoryEntry.

	self initialize.! !

!EpFileLogNode methodsFor: 'accessing' stamp: ''!
fileReference

	^ directoryEntry asFileReference! !

!EpFileLogNode methodsFor: 'private' stamp: ''!
ombuStore

	^ OmStoreFactory current fromFile: self fileReference! !

!EpFileLogNode methodsFor: 'accessing' stamp: ''!
globalName

	^ globalName ifNil: [
		globalName := OmFileStore globalNameFrom: directoryEntry ]! !

!EpFileLogNode class methodsFor: 'convenience' stamp: ''!
fromAllLogsIn: directory
	
	| nodes |
	nodes := directory entries 
		select: [ :each | each basename endsWith: OmFileStore defaultFileSuffix ]
		thenCollect: [ :entry | self withEntry: entry ].
		
	^ nodes! !

!EpFileLogNode class methodsFor: 'instance creation' stamp: ''!
withEntry: aDirectoryEntry

	^ self basicNew 
		initializeWithEntry: aDirectoryEntry;
		yourself! !

!EpFilter commentStamp: ''!
My instances decide if an OmEntry is accepted.!
!EpFilter methodsFor: 'filtering' stamp: ''!
accepts: anEntry
	^ self subclassResponsibility! !

!EpFilterTest methodsFor: 'resources' stamp: ''!
methodAddition
	^ self entryWith: (EpMethodAddition method: Object >> #printOn:)! !

!EpFilterTest methodsFor: 'tests' stamp: ''!
testAnd
	| aFilter |
	aFilter := EpAndFilter withAll: { 
		EpPluggableFilter codeChangeFilter. 
		EpPluggableFilter methodFilter }.
	
	self 
		assert: aFilter
		accepts: self methodAddition
		rejects: self classAddition! !

!EpFilterTest methodsFor: 'running' stamp: ''!
entryWith: anEvent
	^ OmEntry content: anEvent! !

!EpFilterTest methodsFor: 'tests' stamp: ''!
testEquality
	self 
		assert: EpPluggableFilter methodFilter
		equals: EpPluggableFilter methodFilter.
	
	self 
		assert: (EpOrFilter withAll: EpPluggableFilter allFilters)
		equals: (EpOrFilter withAll: EpPluggableFilter allFilters).! !

!EpFilterTest methodsFor: 'resources' stamp: ''!
classAddition
	^ self entryWith: (EpClassAddition class: Object)! !

!EpFilterTest methodsFor: 'tests' stamp: ''!
testLogBrowserOperation
	self
		assert: EpPluggableFilter logBrowserOperationFilter
		accepts: self redo
		rejects: self methodAddition! !

!EpFilterTest methodsFor: 'tests' stamp: ''!
testNoTrigger
	| expressionEvaluationWithTrigger |
	expressionEvaluationWithTrigger := self classAddition.
	expressionEvaluationWithTrigger tags 
		at: EpLog triggererReferenceKey 
		put: (OmReference globalName: 'test' localName: '1').
				
	self
		assert: EpPluggableFilter noTriggerFilter
		accepts: self classAddition
		rejects: expressionEvaluationWithTrigger! !

!EpFilterTest methodsFor: 'tests' stamp: ''!
testMethod	
	self 
		assert: EpPluggableFilter methodFilter
		accepts: self methodAddition
		rejects: self classAddition! !

!EpFilterTest methodsFor: 'running' stamp: ''!
assert: aFilter accepts: anEvent rejects: anotherEvent
	self assert: (aFilter accepts: anEvent).
	self deny: (aFilter accepts: anotherEvent).! !

!EpFilterTest methodsFor: 'resources' stamp: ''!
refactoring
	^ self entryWith: (EpRenameClassRefactoring rename: Object to: #Object42)! !

!EpFilterTest methodsFor: 'resources' stamp: ''!
redo
	^ self entryWith: (EpRedo forAll: #())! !

!EpGenericRefactoring commentStamp: ''!
I represent a generic refactoring, which can be reconstructed via it's #storeString.!
!EpGenericRefactoring methodsFor: 'converting' stamp: ''!
asRBRefactoring
	^ self class compiler evaluate: storeString! !

!EpGenericRefactoring methodsFor: 'initialization' stamp: ''!
initializeWith: aRBRefactoring
	self initialize.
	storeString := aRBRefactoring storeString! !

!EpGenericRefactoring methodsFor: '*EpiceaBrowsers' stamp: ''!
summaryOn: aWriteStream
	"Write a string summarizing myself."
	
	aWriteStream 
		nextPutAll: storeString! !

!EpGenericRefactoring class methodsFor: 'instance creation' stamp: ''!
for: aRBRefactoring
	^ self basicNew
		initializeWith: aRBRefactoring;
		yourself! !

!EpGenericRefactoring class methodsFor: 'testing' stamp: ''!
canAccept: aRBRefactoring 

	^ (aRBRefactoring class whichClassIncludesSelector: #storeOn:) ~= Object! !

!EpHasImpactFilterTest methodsFor: 'tests' stamp: ''!
testCommentWithoutImpact
	| anEvent aClass |
	aClass := classFactory newClass.
	aClass comment: 'a'.
	anEvent := OmEntry content: (EpBehaviorCommentChange 
		newWithBehavior: aClass asEpiceaRingDefinition
		oldComment: 'a'
		newComment: 'b'
		oldStamp: aClass organization commentStamp
		newStamp: aClass organization commentStamp).
	aClass comment: 'c'.
	aClass comment: 'b'.
	self deny: (impactFilter accepts: anEvent)! !

!EpHasImpactFilterTest methodsFor: 'running' stamp: ''!
tearDown
	classFactory cleanUp.
	super tearDown.! !

!EpHasImpactFilterTest methodsFor: 'tests' stamp: ''!
testMethodWithoutImpact
	| anEvent aClass |
	aClass := classFactory newClass.
	aClass compile: 'a ^1'.
	anEvent := OmEntry content: (EpMethodAddition method: aClass >> #a).
	self deny: (impactFilter accepts: anEvent)! !

!EpHasImpactFilterTest methodsFor: 'tests' stamp: ''!
testMethodWithImpact
	| anEvent aClass |
	aClass := classFactory newClass.
	aClass compile: 'a ^1'.
	anEvent := OmEntry content: (EpMethodAddition method: aClass >> #a).
	aClass compile: 'a ^2'.
	self assert: (impactFilter accepts: anEvent)! !

!EpHasImpactFilterTest methodsFor: 'tests' stamp: ''!
testClassWithClassSideImpact
	| anEvent aClass |
	aClass := classFactory newClass.
	anEvent := OmEntry content: (EpClassAddition class: aClass).
	aClass classSide addSlot: #a.
	self assert: (impactFilter accepts: anEvent)! !

!EpHasImpactFilterTest methodsFor: 'tests' stamp: ''!
testClassWithoutImpact
	| anEvent aClass |
	aClass := classFactory newClass.
	anEvent := OmEntry content: (EpClassAddition class: aClass).
	self deny: (impactFilter accepts: anEvent)! !

!EpHasImpactFilterTest methodsFor: 'tests' stamp: ''!
testClassWithInstanceSideImpact
	| anEvent aClass |
	aClass := classFactory newClass.
	anEvent := OmEntry content: (EpClassAddition class: aClass).
	aClass addSlot: #a.
	self assert: (impactFilter accepts: anEvent)! !

!EpHasImpactFilterTest methodsFor: 'tests' stamp: ''!
testCommentWithImpact
	| anEvent aClass |
	aClass := classFactory newClass.
	aClass comment: 'a'.
	aClass comment: 'b'.
	anEvent := OmEntry content: (EpBehaviorCommentChange 
		newWithBehavior: aClass asEpiceaRingDefinition
		oldComment: 'a'
		newComment: 'b'
		oldStamp: aClass organization commentStamp
		newStamp: aClass organization commentStamp).
	aClass comment: 'c'.
	self assert: (impactFilter accepts: anEvent)! !

!EpHasImpactFilterTest methodsFor: 'tests' stamp: ''!
testClassSideMethodWithImpact
	| anEvent aClass |
	aClass := classFactory newClass classSide.
	aClass compile: 'a ^1'.
	anEvent := OmEntry content: (EpMethodAddition method: aClass >> #a).
	aClass compile: 'a ^2'.
	self assert: (impactFilter accepts: anEvent)! !

!EpHasImpactFilterTest methodsFor: 'tests' stamp: ''!
testClassSideMethodWithoutImpact
	| anEvent aClass |
	aClass := classFactory newClass classSide.
	aClass compile: 'a ^1'.
	anEvent := OmEntry content: (EpMethodAddition method: aClass >> #a).
	self deny: (impactFilter accepts: anEvent)! !

!EpHasImpactFilterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	classFactory := ClassFactoryForTestCase new.
	impactFilter := EpImpactCodeChangeFilter new
		environment: self class environment;
		yourself.! !

!EpHasImpactVisitor commentStamp: ''!
I answer a boolean that indicates if a EpCodeChange would actually produce a change in current image if applied with EpApplyVisitor.!
!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aChange

	self
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior |
			^ behavior category ~= aChange behaviorAffected category ].
			
	^ true! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitClassAddition: aChange
	^ self visitClassChange: aChange! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitMethodChange: aChange
	"Addition and Modification come here"

	self 
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior | 
			^ behavior 
				compiledMethodAt: aChange methodAffectedSelector
				ifPresent: [ :method |
					method protocol ~= aChange methodAffectedProtocol or: [
					method sourceCode ~= aChange methodAffectedSourceCode ] ]
				ifAbsent: [ true ] ].
			
	^ true "If class is not present"! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aChange

	self 
		behaviorNamed: aChange oldName
		ifPresent: [ :behavior | ^ true ].

	^ false! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aChange
	
	^ environment organization includesCategory: aChange categoryName! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aProtocolAddition

	self 
		behaviorNamed: aProtocolAddition behaviorAffectedName
		ifPresent: [ :behavior |
			^ (behavior organization protocolOrganizer hasProtocolNamed: aProtocolAddition protocol) not ].
		
	^ true! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitCodeChange: aChange
	^ self error: 'shouldn''t happen'! !

!EpHasImpactVisitor methodsFor: 'private' stamp: ''!
behaviorNamed: aSymbol ifPresent: presentBlock

	^ (environment classOrTraitNamed: aSymbol) 
		ifNil: [ self ]
		ifNotNil: presentBlock! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aChange
	^ self visitTraitChange: aChange! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange

	self
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :aClass | 
			^ aClass comment ~= aChange newComment or: [
			aClass organization commentStamp ~= aChange newStamp ] ].

	^ true! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aChange
	^ self visitTraitChange: aChange! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitTraitChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitClassChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aChange

	self 
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior |
			"If method comes from trait, removing has no impact."
			^ behavior 
				compiledMethodAt: aChange methodAffectedSelector
				ifPresent: [ :method | method isFromTrait not ]
				ifAbsent: [ false ] ].

	^ false "No impact if container does not exist"! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aChange
	^ self visitMethodChange: aChange! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aChange

	^ environment organization includesCategory: aChange oldCategoryName! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryChange: aChange
	^ self visitCodeChange: aChange! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aChange

	^ (environment organization includesCategory: aChange categoryName) not! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aChange
	^ self visitMethodChange: aChange! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorChange: aChange
	self behaviorNamed: aChange behaviorAffectedName ifPresent: [ :behavior | 
		^ behavior definitionString ~= aChange behaviorAffected definitionSource or: [
			behavior classSide definitionString ~= aChange behaviorAffected classSide definitionSource ] ].

	^ true! !

!EpHasImpactVisitor methodsFor: 'initialization' stamp: ''!
initializeWith: anEnvironment

	self initialize.
	environment := anEnvironment.! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoval: aChange

	self 
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior | ^ true ].

	^ false! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolChange: aProtocolAddition
	^ self visitBehaviorChange: aProtocolAddition.! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aChange

	self 
		behaviorNamed: aChange behaviorAffectedName
		ifPresent: [ :behavior | ^ true ].

	^ false! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aProtocolRemoved

	self 
		behaviorNamed: aProtocolRemoved behaviorAffectedName
		ifPresent: [ :behavior | 
			^ behavior organization protocolOrganizer hasProtocolNamed: aProtocolRemoved protocol ].
		
	^ true! !

!EpHasImpactVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aChange
	^ self visitClassChange: aChange! !

!EpHasImpactVisitor class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EpHasImpactVisitor class methodsFor: 'instance creation' stamp: ''!
inEnvironment: anEnvironment

	^ self basicNew 
		initializeWith: anEnvironment;
		yourself! !

!EpHasImpactVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EpHasImpactVisitor class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EpHasImpactVisitor class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EpHasImpactVisitor class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EpHasImpactVisitor class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EpHasImpactVisitor class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EpHasImpactVisitor class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EpHasImpactVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpHasImpactVisitor class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EpHasImpactVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EpHasImpactVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EpHasImpactVisitor class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EpHasImpactVisitor class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EpHasImpactVisitor class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EpHasImpactVisitor class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EpHasImpactVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EpHasImpactVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpHasImpactVisitor class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EpHasImpactVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EpHasImpactVisitor class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EpHasImpactVisitor class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!EpHasImpactVisitor class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!EpHasImpactVisitor class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!EpHasImpactVisitor class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EpHasImpactVisitor class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EpHasImpactVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EpHasImpactVisitor class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EpHasImpactVisitor class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EpHelp commentStamp: ''!
Help for Epicea project.!
!EpHelp class methodsFor: 'documentation' stamp: ''!
monitor
	^ HelpTopic
		title: 'Monitor & Ombu Files'
		contents: '
MONITOR & OMBU FILES

Epicea Monitor logs code changes and other IDE events. Such data is placed in .ombu files in a local directory. Each time a Pharo image opens, Epicea Monitor logs code changes into a new ombu file. This avoids the risk of loosing the data in an ombu file: two Pharo images will always write into different ombu files. 

Logging the code changes into different files can have a negative consequence: the changes of a single development session might be segmented into several log files. This will happen in the case where the developer had to close and open several times the Pharo image.
'! !

!EpHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(overview monitor browsers)! !

!EpHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Epicea'! !

!EpHelp class methodsFor: 'documentation' stamp: ''!
overview
	^ HelpTopic
		title: 'Overview'
		contents: '
OVERVIEW
		
Epicea is a tool that records code changes enriched with IDE events.

Epicea extends and could replace the traditional .changes logging mechanism, where the recorded code changes are incomplete and are not properly reified and thus it can be difficult to recover lost code after an image crash.'! !

!EpHelp class methodsFor: 'documentation' stamp: ''!
browsers
	^ HelpTopic
		title: 'Browsers'
		contents: '
BROWSERS

Epicea provides browsers to visualize and manipulate the code changes and IDE events that the Monitor logs.


SESSION CHANGES

It shows the code changes since Epicea started to log. This means it shows changes placed in potentially several ombu files.


ALL CHANGES

The windows shows:
- all the logs in the local directory on the left panel, and 
- the content of the selected log in the right panel.

This window visually connects the logs to help user to understand how the ombu files are related. Note that the code changes displayed on the right panel belong to only one log (different than in the Monitor UI, that might show changes in several logs).
'! !

!EpIconVisitor commentStamp: ''!
I answer an icon for each EpEvent.!
!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aClassRecategorizationChange
	^ self modificationIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitClassAddition: aClassCreatedChange
	^ self additionIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitSessionStart: anEvent
	^ self iconNamed: #smallDoItIcon! !

!EpIconVisitor methodsFor: 'private' stamp: ''!
emptyIcon
	^ self iconNamed: #emptyIcon! !

!EpIconVisitor methodsFor: 'private' stamp: ''!
modificationIcon
	^ self iconNamed: #changeUpdateIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitMonticelloVersionsLoad: aMonticelloVersionLoaded
	^ self iconNamed: #packageIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitRedo: aRedoEvent
	^ self iconNamed: #smallRedoIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitRefactoring: aRefactoring
	^ self iconNamed: #configurationIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aClassRenamedChange
	^ self modificationIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aCategoryChange
	^ self removalIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aProtocolChange
	^ self additionIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitSessionSnapshot: aSnapshotChange
	^ self iconNamed: #smallSaveIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitUndo: anUndoEvent
	^ self iconNamed: #smallUndoIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitEvent: anEvent 
	^ self emptyIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aTraitCreation
	^ self additionIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange
	^ self modificationIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aTraitModificationChange
	^ self modificationIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCopy: anEvent
	^ self iconNamed: #configurationIcon! !

!EpIconVisitor methodsFor: 'private' stamp: ''!
removalIcon
	^ self iconNamed: #changeRemoveIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitSessionEnd: anEvent
	^ self iconNamed: #smallQuitIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aMethodRemoved
	^ self removalIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitLogCommentModification: aLogCommentModification
	^ self iconNamed: #announcementIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aMethodCreatedChange
	^ self additionIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aCategoryChange
	^ self modificationIcon.! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aCategoryChange
	^ self additionIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aMethodModified
	^ self modificationIcon! !

!EpIconVisitor methodsFor: 'private' stamp: ''!
additionIcon
	^ self iconNamed: #changeAddIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoval:  aTraitRemoval
	^ self removalIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitExpressionEvaluation: anExpressionEvaluation
	^ self iconNamed: #workspaceIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aClassRemovedChange
	^ self removalIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aProtocolChange
	^ self removalIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitMonticelloVersionSave: aChange
	^ self iconNamed: #packageIcon! !

!EpIconVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aModificationClassChange
	^ self modificationIcon! !

!EpImpactCodeChangeFilter commentStamp: ''!
This filter only accepts code changes that would produce a change if applied in current image.!
!EpImpactCodeChangeFilter methodsFor: 'accessing' stamp: ''!
environment: anEnvironment
	
	environment := anEnvironment! !

!EpImpactCodeChangeFilter methodsFor: 'comparing' stamp: ''!
= other

	^ self class = other class! !

!EpImpactCodeChangeFilter methodsFor: 'comparing' stamp: ''!
hash

	^ self class hash! !

!EpImpactCodeChangeFilter methodsFor: 'filtering' stamp: ''!
accepts: anOmEntry

	anOmEntry content isCodeChange ifFalse: [ ^false ].

	^ anOmEntry content accept: (EpHasImpactVisitor inEnvironment: environment)! !

!EpImpactCodeChangeFilter methodsFor: 'accessing' stamp: ''!
title
	
	^ self class title! !

!EpImpactCodeChangeFilter class methodsFor: 'accessing' stamp: ''!
title

	^ 'Hide changes if apply operation is redundant'! !

!EpInverseVisitor commentStamp: ''!
I convert a code change to it's inverse operation. For example, a class addition into a class removal.!
!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aChange

	^ EpBehaviorCategoryChange
			oldCategory: aChange newCategory
			newCategory: aChange oldCategory
			class: aChange behaviorAffected! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitClassAddition: aChange

	^ EpClassRemoval class: aChange behaviorAffected! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aChange

	^ EpCategoryRename
			oldName: aChange newCategoryName
			newName: aChange oldCategoryName
			packageName: aChange affectedPackageName! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aChange

	^ EpMethodRemoval method: aChange methodAffected! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitMethodChange: aChange
	^ self visitCodeChange: aChange! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryChange: aChange
	^ self visitCodeChange: aChange! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aChange

	^ EpCategoryRemoval 
			named: aChange categoryName
			packageName: aChange affectedPackageName! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aChange

	^ EpMethodModification oldMethod: aChange newMethod newMethod: aChange oldMethod! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aChange

	^ EpBehaviorNameChange
			oldName: aChange newName
			newName: aChange oldName
			class: aChange behaviorAffected! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aChange
	
	^ EpCategoryAddition
			named: aChange categoryName
			packageName: aChange affectedPackageName! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aChange

	^ EpProtocolRemoval behavior: aChange behaviorAffected protocol: aChange protocol! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitCodeChange: aChange
	^ self error: 'Should not be reached'! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorChange: aChange
	^ self visitCodeChange: aChange! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aChange
	
	^ EpTraitRemoval trait: aChange behaviorAffected! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange

	^ EpBehaviorCommentChange
			newWithBehavior: aChange behaviorAffected
			oldComment: aChange newComment
			newComment: aChange oldComment
			oldStamp: aChange newStamp
			newStamp: aChange oldStamp! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolChange: aProtocolAddition
	^ self visitBehaviorChange: aProtocolAddition.! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aTraitModification

	self notYetImplemented! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoval: aChange

	^ EpTraitAddition trait: aChange behaviorAffected! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitTraitChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitClassChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aChange

	^ EpClassAddition class: aChange behaviorAffected! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aChange

	^ EpMethodAddition method: aChange methodAffected! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aChange

	^ EpProtocolAddition behavior: aChange behaviorAffected protocol: aChange protocol! !

!EpInverseVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aChange

	^ EpClassModification oldClass: aChange newClass newClass: aChange oldClass.! !

!EpInverseVisitor class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EpInverseVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EpInverseVisitor class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EpInverseVisitor class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EpInverseVisitor class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EpInverseVisitor class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EpInverseVisitor class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EpInverseVisitor class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EpInverseVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpInverseVisitor class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EpInverseVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EpInverseVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EpInverseVisitor class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EpInverseVisitor class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EpInverseVisitor class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EpInverseVisitor class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EpInverseVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EpInverseVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpInverseVisitor class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EpInverseVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EpInverseVisitor class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EpInverseVisitor class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!EpInverseVisitor class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!EpInverseVisitor class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!EpInverseVisitor class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EpInverseVisitor class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EpInverseVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EpInverseVisitor class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EpInverseVisitor class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EpLatestCodeChangeFilter commentStamp: ''!
This filter only accepts code changes that are latest, i.e. that aren't overridden by other changes in the log more recently.!
!EpLatestCodeChangeFilter methodsFor: 'comparing' stamp: ''!
= other

	^ self class = other class! !

!EpLatestCodeChangeFilter methodsFor: 'comparing' stamp: ''!
hash

	^ self class hash! !

!EpLatestCodeChangeFilter methodsFor: 'accessing' stamp: ''!
logBrowserModel
	^ logBrowserModel! !

!EpLatestCodeChangeFilter methodsFor: 'accessing' stamp: ''!
logBrowserModel: anEpLogBrowserModel 
	
	logBrowserModel := anEpLogBrowserModel! !

!EpLatestCodeChangeFilter methodsFor: 'filtering' stamp: ''!
accepts: anOmEntry

	| finalReference log |
	log := logBrowserModel log.
	finalReference := log referenceTo: anOmEntry.
	anOmEntry content isCodeChange ifFalse: [ ^ false ].

	logBrowserModel cachedLogEntries reverseDo: [:each |
		(log referenceTo: each) = finalReference ifTrue: [ ^ true ].
		(each content isCodeChange and: [
			each content doesOverride: anOmEntry content ]) ifTrue: [ ^ false ].
	].

	^ false "shouldn't happen"! !

!EpLatestCodeChangeFilter methodsFor: 'accessing' stamp: ''!
title

	^ self class title! !

!EpLatestCodeChangeFilter class methodsFor: 'accessing' stamp: ''!
title

	^ 'Show only latest changes'! !

!EpLog commentStamp: ''!
I am a log of system events (EpEvent), stored into entries (OmEntry).

A user of my instances is EpMonitor, who adds instances of EpEvent into me when certain system announcements happen.

My #entries contain the events ordered as "the oldest first".
 
Examples:

EpLog freshFromFile: 'path/to/ombu/file.ombu' asFileReference.!
!EpLog methodsFor: 'accessing' stamp: ''!
entries
	"Answer the entries of this log."

	^ store entries! !

!EpLog methodsFor: 'testing' stamp: ''!
isEmpty

	self entriesDo: [ :each | ^false ].
	^true! !

!EpLog methodsFor: 'accessing' stamp: ''!
commentAt: anEntry ifPresent: aBlock 
	"Answer the String comment corresponding to anEntry, and evaluate aBlock with it."

	^ commentByEntryReference
		at: (self referenceTo: anEntry)
		ifPresent: aBlock! !

!EpLog methodsFor: 'accessing' stamp: ''!
entriesForAll: references

	^ references collect: [ :each | self entryFor: each ]! !

!EpLog methodsFor: 'accessing' stamp: ''!
nullReference

	^ OmNullReference uniqueInstance! !

!EpLog methodsFor: 'enumerating' stamp: ''!
fromHeadDetect: aBlockReturningBoolean ifNotFound: notFoundBlock

	^ self
		from: self headReference
		detect: aBlockReturningBoolean
		ifNotFound: notFoundBlock! !

!EpLog methodsFor: 'refreshing' stamp: ''!
refresh
	store refresh.
	commentByEntryReference := Dictionary new.! !

!EpLog methodsFor: 'accessing' stamp: ''!
authorAt: anEntry

	^ self 
		authorAt: anEntry 
		ifAbsent: [ self error ]! !

!EpLog methodsFor: 'enumerating' stamp: ''!
priorEntriesFrom: aReference do: aBlock

	| nextReference |
	nextReference := aReference.
	[ nextReference isNull ] whileFalse: [
		self 
			entryFor: nextReference 
			ifPresent: [ :entry | 
				aBlock value: entry.		
				nextReference := self priorReferenceAt: entry ]
			ifAbsent: [ ^ self ] ]! !

!EpLog methodsFor: 'accessing' stamp: ''!
store

	^ store! !

!EpLog methodsFor: 'private' stamp: ''!
updateEntriesCache

	store entriesDo: [ :each | self cacheEntry: each ]! !

!EpLog methodsFor: 'accessing' stamp: ''!
authorAt: anEntry ifAbsent: aBlock

	^ anEntry tags 
		at: self class authorKey
		ifAbsent: aBlock! !

!EpLog methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream 
		nextPut: $(;
		print: self headReference;
		nextPut: $).! !

!EpLog methodsFor: 'accessing' stamp: ''!
priorReferenceAt: anEntry

	^ anEntry tagAt: self class priorReferenceKey! !

!EpLog methodsFor: 'accessing' stamp: ''!
referencesToAll: aCollectionOfEntries

	^ aCollectionOfEntries collect: [ :each | self referenceTo: each ]! !

!EpLog methodsFor: 'accessing' stamp: ''!
entryReferences
	
	^ store entryReferences! !

!EpLog methodsFor: 'accessing' stamp: ''!
events

	^ self entries collect: [:each | each content]! !

!EpLog methodsFor: 'accessing' stamp: ''!
entryFor: aReference
	"Answer the entry corresponding to aReference"

	^ store entryFor: aReference! !

!EpLog methodsFor: 'private' stamp: ''!
cacheEntry: newEntry
	"Update caches with a new entry"

	newEntry content isEpLogEntriesComment ifTrue: [ 
		(newEntry content entryReferences) do: [ :each |
			commentByEntryReference 
				at: each
				put: newEntry content comment 
		] ]! !

!EpLog methodsFor: 'accessing' stamp: ''!
head

	^ self entryFor: self headReference! !

!EpLog methodsFor: 'private' stamp: ''!
announceAdded: anEntry

	self announcer announce: (EpEntryAdded for: anEntry)! !

!EpLog methodsFor: 'enumerating' stamp: ''!
from: aReference detect: aBlockReturningBoolean ifNotFound: notFoundBlock

	self
		priorEntriesFrom: aReference
		do: [ :entry |
			(aBlockReturningBoolean value: entry)
				ifTrue: [ ^ entry ] ].
	^ notFoundBlock cull: aReference! !

!EpLog methodsFor: 'accessing' stamp: ''!
triggererReferenceOf: anEntry ifPresent: presentBlock ifAbsent: absentBlock

	^ anEntry tags 
		at: self class triggererReferenceKey 
		ifPresent: presentBlock 
		ifAbsent: absentBlock! !

!EpLog methodsFor: 'accessing' stamp: ''!
announcer

	^ announcer ifNil: [ announcer := Announcer new ]! !

!EpLog methodsFor: 'accessing' stamp: ''!
entriesCount
	
	^ store entriesCount! !

!EpLog methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlockClosure
	"Evaluate aBlockClosure on every entry"

	^ store entriesDo: aBlockClosure! !

!EpLog methodsFor: 'enumerating' stamp: ''!
priorEntriesFromHead

	^ self priorEntriesFrom: self headReference! !

!EpLog methodsFor: '*EpiceaBrowsers' stamp: ''!
browseVersionsOf: aMethod
	"Browse all versions of aMethod from my head."
	
	^ (EpLogBrowserPresenter newWithLog: self)
			addFilter: (EpPluggableFilter isMethod: aMethod);
			refresh;
			openWithSpec! !

!EpLog methodsFor: 'enumerating' stamp: ''!
fromHeadDetect: aBlockReturningBoolean

	^ self
		from: self headReference
		detect: aBlockReturningBoolean! !

!EpLog methodsFor: 'accessing' stamp: ''!
firstEntryIfAbsent: absentBlock
	"Answer the first entry of the log, or evaluate the absentBlock."

	^ store firstEntryIfAbsent: absentBlock! !

!EpLog methodsFor: 'accessing' stamp: ''!
commentAt: anEntry ifAbsent: aBlock 
	"Answer the String comment corresponding to anEntry, or evaluate aBlock if absent."

	^ commentByEntryReference
		at: (self referenceTo: anEntry)
		ifAbsent: aBlock! !

!EpLog methodsFor: 'testing' stamp: ''!
hasAuthor: anEntry

	self 
		authorAt: anEntry 
		ifAbsent: [ ^ false ].
		
	^ true! !

!EpLog methodsFor: 'accessing' stamp: ''!
addEntryWith: anEvent tags: blockClosureForCustomTags
	"Add an event with the specified tags"

	| newEntry |
	newEntry := OmEntry content: anEvent.

	"add tags"
	newEntry tags 
		at: self class priorReferenceKey put: self headReference;
		in: blockClosureForCustomTags.

	"write the new entry"
	store newEntry: newEntry.

	"update caches with the new entry"
	self cacheEntry: newEntry.

	self announceAdded: newEntry.

	^ newEntry! !

!EpLog methodsFor: 'accessing' stamp: ''!
referenceTo: anEntry

	^ store referenceTo: anEntry! !

!EpLog methodsFor: 'accessing' stamp: ''!
headReference
	"Answer a OmReference to the head of this log"

	^ store headReference! !

!EpLog methodsFor: 'enumerating' stamp: ''!
priorEntriesFrom: aReference

	^ Array streamContents: [  :stream |
		self priorEntriesFrom: aReference do: [ :anEntry |
			stream nextPut: anEntry ] ]! !

!EpLog methodsFor: 'accessing' stamp: ''!
timeAt: anEntry ifAbsent: aBlock

	^ anEntry tags 
		at: self class timeKey
		ifAbsent: aBlock! !

!EpLog methodsFor: 'accessing' stamp: ''!
entryFor: aReference ifPresent: presentBlockClosure ifAbsent: absentBlockClosure
	"Answer an entry, evaluating either the first block closure if present or the second if absent."
	
	^ store 
		entryFor: aReference
		ifPresent: presentBlockClosure
		ifAbsent: absentBlockClosure! !

!EpLog methodsFor: '*EpiceaBrowsers' stamp: ''!
browseEvents
	"Browse all events from my head."
	
	^ EpLogBrowserPresenter openWithLog: self! !

!EpLog methodsFor: 'initialization' stamp: ''!
initializeWith: aStore 

	self initialize.
	store := aStore.
	commentByEntryReference := Dictionary new.! !

!EpLog methodsFor: 'enumerating' stamp: ''!
from: aReference detect: aBlockReturningBoolean

	^ self
		from: aReference
		detect: aBlockReturningBoolean
		ifNotFound: [ :ref | KeyNotFound signalFor: aReference ]! !

!EpLog methodsFor: 'enumerating' stamp: ''!
priorEntriesFrom: initialReference upTo: finalReference

	| result |
	result := OrderedCollection new.
	
	self 
		priorEntriesFrom: initialReference 
		do: [ :anEntry |
			result add: anEntry.
			(self referenceTo: anEntry) = finalReference ifTrue: [ ^ result ].			
		].
	
	^ result! !

!EpLog methodsFor: 'accessing' stamp: ''!
timeAt: anEntry

	^ self 
		timeAt: anEntry 
		ifAbsent: [ self error ]! !

!EpLog methodsFor: 'enumerating' stamp: ''!
priorEntriesFromHeadDo: aBlock

	self priorEntriesFrom: self headReference do: aBlock! !

!EpLog methodsFor: 'testing' stamp: ''!
hasTime: anEntry

	self 
		timeAt: anEntry 
		ifAbsent: [ ^ false ].
		
	^ true! !

!EpLog class methodsFor: 'instance creation' stamp: ''!
newNull

	^ self newWithStore: OmNullStore new.! !

!EpLog class methodsFor: 'instance creation' stamp: ''!
new

	^ self newWithSessionStore! !

!EpLog class methodsFor: 'instance creation' stamp: ''!
newWithStore: aStore 

	^ self basicNew
		initializeWith: aStore;
		yourself! !

!EpLog class methodsFor: 'tag keys' stamp: ''!
timeKey
	^ #time! !

!EpLog class methodsFor: 'instance creation' stamp: ''!
freshFromFile: aFileReference

	^ (self fromFile: aFileReference)
		refresh;
		yourself! !

!EpLog class methodsFor: 'tag keys' stamp: ''!
authorKey
	^ #author! !

!EpLog class methodsFor: 'instance creation' stamp: ''!
fromFile: aFileReference 

	^ self newWithStore: (OmStoreFactory current fromFile: aFileReference)! !

!EpLog class methodsFor: 'tag keys' stamp: ''!
priorReferenceKey

	^ #prior! !

!EpLog class methodsFor: 'instance creation' stamp: ''!
newWithSessionStore

	^ self newWithStore: OmSessionStore new.! !

!EpLog class methodsFor: 'instance creation' stamp: ''!
newWithEvents: eventsTheOldestFirst
	^ self
		newWithStore:
			(OmMemoryStore withAllContents: eventsTheOldestFirst)! !

!EpLog class methodsFor: 'tag keys' stamp: ''!
triggererReferenceKey

	^ #trigger! !

!EpLog class methodsFor: 'instance creation' stamp: ''!
newWithEntries: entriesTheOldestFirst
	^ self
		newWithStore: (OmMemoryStore withAllEntries: entriesTheOldestFirst)! !

!EpLogBrowserOperation commentStamp: ''!
I represent an operation done in a EpLogBrowser.!
!EpLogBrowserOperation methodsFor: 'triggering' stamp: ''!
doInJob: aBlock
	"Evaluate the block. This is a workaround to make Job consider me as the Job's owner."

	^ [ aBlock value ] asJob
		title: '';
		run! !

!EpLogBrowserOperation methodsFor: 'triggering' stamp: ''!
asEpiceaEvent

	^ self! !

!EpLogBrowserOperation methodsFor: 'triggering' stamp: ''!
isEpiceaInterestingJobOwner

	^ true! !

!EpLogBrowserOperation methodsFor: 'initializing' stamp: ''!
initializeWith: aCollectionOfEntryReferences
	self initialize.
	entryReferences := aCollectionOfEntryReferences! !

!EpLogBrowserOperation methodsFor: 'accessing' stamp: ''!
entryReferences
	^ entryReferences! !

!EpLogBrowserOperation methodsFor: 'copying' stamp: ''!
copyWithEntryReferences: aCollectionOfEntryReferences
	^self subclassResponsibility! !

!EpLogBrowserOperationFactory commentStamp: ''!
I implement behavior to apply and revert code changes. 

Important Note: My #entries are expected to be ordered as "the oldest first" (as in EpLog>>entries).!
!EpLogBrowserOperationFactory methodsFor: 'accessing' stamp: ''!
entries: aCollection
	"Important Note: My #entries must be sorted the oldest first."

	entries := aCollection! !

!EpLogBrowserOperationFactory methodsFor: 'accessing' stamp: ''!
errorHandlerBlock
	^ errorHandlerBlock! !

!EpLogBrowserOperationFactory methodsFor: 'private' stamp: ''!
newRevertEvent

	^ EpUndo forAll: (self theLog referencesToAll: self entries)! !

!EpLogBrowserOperationFactory methodsFor: 'public' stamp: ''!
applyCompleteRefactoring

	| refactoringEntry refactoring |
	refactoringEntry := self entries first. "Refactorings are applied one at time"
	refactoring := refactoringEntry content asRBRefactoring.
	
	self applyRBRefactoring: refactoring! !

!EpLogBrowserOperationFactory methodsFor: 'public' stamp: ''!
newRevertPreviewLog

	| events |
	events := self latestEventsFrom: self events reversed.

	events := events flatCollect: [:each | 
		each asRevertedCodeChange previewedApplyEvents ].

	^ EpLog newWithEvents: events! !

!EpLogBrowserOperationFactory methodsFor: 'private' stamp: ''!
trigger: aBlock with: anEpLogBrowserOperation

	^ anEpLogBrowserOperation doInJob: aBlock! !

!EpLogBrowserOperationFactory methodsFor: 'accessing' stamp: ''!
logBrowserModel
	^ logBrowserModel! !

!EpLogBrowserOperationFactory methodsFor: 'private' stamp: ''!
latestEventsFrom: previewEventsTheOldestFirst
	"TODO: move method"
	
	| aLog filter |
	aLog := EpLog newWithStore: (OmMemoryStore withAllContents: previewEventsTheOldestFirst).
	logBrowserModel := EpLogBrowserPresenter newWithLog: aLog.
	filter := EpLatestCodeChangeFilter new
		logBrowserModel: logBrowserModel;
		yourself.
	^ aLog entries 
		select: [ :each | filter accepts: each ] 
		thenCollect: [ :each | each content ]! !

!EpLogBrowserOperationFactory methodsFor: 'public' stamp: ''!
newApplyPreviewLog

	| events |
	events := self latestEventsFrom: self events.

	events := events flatCollect: [:each | 
		each previewedApplyEvents ].
	
	^ EpLog newWithEvents: events! !

!EpLogBrowserOperationFactory methodsFor: 'accessing' stamp: ''!
logBrowserModel: aBrowser
	logBrowserModel := aBrowser! !

!EpLogBrowserOperationFactory methodsFor: 'accessing' stamp: ''!
errorHandlerBlock: aBlock
	errorHandlerBlock := aBlock! !

!EpLogBrowserOperationFactory methodsFor: 'public' stamp: ''!
revertCodeChanges

	self
		trigger: [ 
			self entries reverseDo: [:each | 
				self handleErrorDuring: [ 
					each content asRevertedCodeChange applyCodeChange ]]]
		with: self newRevertEvent! !

!EpLogBrowserOperationFactory methodsFor: 'private' stamp: ''!
handleErrorDuring: aBlock
	"TODO: do not catch *all* Errors.
	This error handler exists as a workaround to skip any unexpected error when applying or reverting a code change from GUI.
	For example, when user reverts the protocol addition of a protocol that is already not present, and such action signals an unexpected error. The error in such case should be avoided via testing API."
	
	aBlock
		on: Error
		do: self errorHandlerBlock! !

!EpLogBrowserOperationFactory methodsFor: 'public' stamp: ''!
revertCodeChangesInPreviewMode
	"Note: This method is intended to be used from EpLogBrowser's preview mode, where the code changes were previously transformed at #newRevertPreviewLog. That's why here the transformed code changes are simply applied as if was a redo (apply) operation and not as an undo (revert)."

	self
		trigger: [ 
			self entries do: [:each |
				self handleErrorDuring: [ 
					each content applyCodeChange ]]] 
		with: self newRevertEvent! !

!EpLogBrowserOperationFactory methodsFor: 'private' stamp: ''!
applyRBRefactoring: aRBRefactoring

	self error: 'This function is currently not supported'! !

!EpLogBrowserOperationFactory methodsFor: 'accessing' stamp: ''!
theLog

	^ logBrowserModel theLog! !

!EpLogBrowserOperationFactory methodsFor: 'accessing' stamp: ''!
events

	^ self entries collect: [:each | each content ]! !

!EpLogBrowserOperationFactory methodsFor: 'public' stamp: ''!
applyPropagateRefactoring

	| refactoringEntry refactoring |
	refactoringEntry := self entries first. "Refactorings are applied one at time"
	refactoring := EpRBPropagateRefactoring target: refactoringEntry content asRBRefactoring.

	self applyRBRefactoring: refactoring! !

!EpLogBrowserOperationFactory methodsFor: 'private' stamp: ''!
newApplyEvent

	^ EpRedo forAll: (self theLog referencesToAll: self entries)! !

!EpLogBrowserOperationFactory methodsFor: 'public' stamp: ''!
applyCodeChanges
	"Note: This method is intended to be used from EpLogBrowser's preview mode, where the code changes were previously transformed at #newApplyPreviewLog."
	
	self
		trigger: [ 
			self entries do: [:each |
				self handleErrorDuring: [
					each content applyCodeChange ]]] 
		with: self newApplyEvent! !

!EpLogBrowserOperationFactory methodsFor: 'accessing' stamp: ''!
entries
	^ entries! !

!EpLogBrowserOperationFactoryTest commentStamp: ''!
My subclasses test EpLogBrowserModel operations.!
!EpLogBrowserOperationFactoryTest methodsFor: 'tests' stamp: ''!
setMonitorLogAsInputEntries

	inputEntries := monitor log entries.
	inputEntry := nil. "Not used"! !

!EpLogBrowserOperationFactoryTest methodsFor: 'tests' stamp: ''!
setHeadAsInputEntry

	inputEntry := monitor log head.
	inputEntries := { monitor log head }! !

!EpLogBrowserOperationVisitor commentStamp: ''!
I am an abstract superclass useful for visitors of EpLogBrowserOperation.!
!EpLogBrowserOperationVisitor methodsFor: 'private' stamp: ''!
behaviorNamed: aSymbol ifPresent: presentBlock

	^ (environment classOrTraitNamed: aSymbol) 
		ifNil: [ self inform: 'Cannot find ', aSymbol ]
		ifNotNil: presentBlock! !

!EpLogBrowserOperationVisitor methodsFor: 'private' stamp: ''!
compiler 

	^ self class compiler! !

!EpLogBrowserOperationVisitor methodsFor: 'initialize' stamp: ''!
initializeWith: anEnvironment

	self initialize.
	environment := anEnvironment! !

!EpLogBrowserOperationVisitor class methodsFor: 'instance creation' stamp: ''!
new
	^ self inEnvironment: self environment! !

!EpLogBrowserOperationVisitor class methodsFor: 'instance creation' stamp: ''!
inEnvironment: anEnvironment

	^ self basicNew 
		initializeWith: anEnvironment;
		yourself! !

!EpLogBrowserPresenter commentStamp: ''!
I am a Spec browser for an EpLog.

For example, open with:

self open
!
!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
entries

	^ log entryReferences collect: [:each | log entryFor: each ]! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
filteredEntries
	
	^ self filteredEntryReferences collect: [:each | log entryFor: each ]! !

!EpLogBrowserPresenter methodsFor: 'menu - filters' stamp: ''!
filterAfter

	self selectedEntryItems ifNotEmpty: [ :items |
		| time |
		time := items first entry tags at: EpLog timeKey.
		self addFilter: (EpPluggableFilter after: time) ]! !

!EpLogBrowserPresenter methodsFor: 'menu - filters' stamp: ''!
filterLatestCodeChanges

	self addFilter: (EpLatestCodeChangeFilter new logBrowserModel: self; yourself)! !

!EpLogBrowserPresenter methodsFor: 'menu' stamp: ''!
refactoringMenuActions

	^ {
		{ 'Apply refactoring'.
		#applyCompleteRefactoringInSelection.
		'Apply selected refactoring'.
		#smallRedoIcon.
		$y command }.
		{ 'Apply secondary effects of refactoring'.
		#applyPropagateRefactoringInSelection.
		'Apply only the secondary effects of the selected refactoring'.
		#smallRedoIcon.
		$s command }
	}! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
operationsErrorHandlerBlock

	^ [ :error | | message |
		message := self title, ' error on operation: ', error asString.
		message traceCr.
		self inform: message. ]! !

!EpLogBrowserPresenter methodsFor: 'refreshing' stamp: ''!
refresh
	"Refresh log"

	itemsPresenter items: self filteredEntryReferences reversed.
	toolbarPresenter refresh! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
commentsLog: anEpLog
	
	commentsLog := anEpLog! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
logOffEvent: anEvent

	self commentsLog 
		addEntryWith: anEvent
		tags: [ :tags |
			tags at: EpLog authorKey put: self monitor author.
			tags at: EpLog timeKey put: self monitor time ].! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
commentSelection

	| items newCommentOrNil oldComment entryReferences |
	items := self selectedEntryItems.
	entryReferences := items collect: [:each | each reference].
	oldComment := items anyOne oldComment.
		
	newCommentOrNil := UIManager default
		multiLineRequest: 'Enter a comment for the selection' 
		initialAnswer: oldComment
		answerHeight: 250.

	newCommentOrNil ifNil: [ ^ self ].
	
	self logOffEvent:
		(EpLogEntriesComment 
			entryReferences: entryReferences 
			oldComment: oldComment 
			newComment: newCommentOrNil)! !

!EpLogBrowserPresenter methodsFor: 'private' stamp: ''!
morphForItemAt: entryReference

	^ [ (self itemForEntryReference: entryReference) asMorph ]
			on: NotFound do: [:error | error asString asMorph ] "Enforce... remove it?"! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
revertSelectedChanges

	self revertChangesIn: self selectedCodeChanges! !

!EpLogBrowserPresenter methodsFor: 'menu' stamp: ''!
menuMorphForSelectedItems
	| aMenu |
	aMenu := self newMenu.

	showEntryItemMenu ifTrue: [ self addMenuItemsForSelectedItemsIn: aMenu ].

	^ aMenu! !

!EpLogBrowserPresenter methodsFor: 'refreshing' stamp: ''!
refreshEntryContent
	self refreshEntryContentWith: self selectedEntryItems! !

!EpLogBrowserPresenter methodsFor: 'modes' stamp: ''!
beHistoryMode
	self withWindowDo: [ :window | window title: 'Epicea - Log Browser' ].
	toolbarPresenter beHistoryMode.
	showEntryItemMenu := true! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
ombuFileSaveSelection

	| entries |
	entries := self selectedEntryItems collect: [ :each | each entry ].
	
	EpOmbuExporter askFileNameAndFileOut: entries in: FileLocator workingDirectory.! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
entryItems

	^ log entryReferences collect: [:each |
		self itemForEntryReference: each ]! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
itemsPresenter
	^ itemsPresenter! !

!EpLogBrowserPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	andFilter := EpAndFilter withAll: #()! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
monitor
	
	^ EpMonitor current! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
applyPropagateRefactoringInSelection

	| entries |
	entries := self selectedEntries.
	entries size = 1 ifFalse: [ 
		^ self inform: 'Please select one refactoring' ]. "Only implemented for one"
	
	EpLogBrowserOperationFactory new
		logBrowserModel: self;
		entries: entries;
		errorHandlerBlock: self operationsErrorHandlerBlock;
		applyPropagateRefactoring.! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
openPreviewToApplySelectedChanges

	| entries previewLog |
	entries := self selectedCodeChanges.
	entries ifEmpty: [ ^ self inform: 'No changes to preview apply' ].

	previewLog := EpLogBrowserOperationFactory new
		logBrowserModel: self;
		entries: entries;
		errorHandlerBlock: self operationsErrorHandlerBlock;
		newApplyPreviewLog.

	previewLog isEmpty
		ifTrue: [ self inform: 'Preview is empty (no changes to apply in current image)' ]
		ifFalse: [ previewLog browseEvents beApplyMode ]! !

!EpLogBrowserPresenter methodsFor: 'menu' stamp: ''!
addMenuItemsForSelectedItemsIn: aMenu

	aMenu addGroup: [ :aGroup | 
		self menuActionsForSelectedItems do: [ :oldStyleMenuItemArray | 
			aGroup addItem: [ :anItem | 
				anItem
					name: oldStyleMenuItemArray first;
					description: oldStyleMenuItemArray third;
					icon: (self iconNamed: oldStyleMenuItemArray fourth);
					action: [ self perform: oldStyleMenuItemArray second ] ] ] ].

	aMenu addGroup: [ :aGroup | 
		aGroup addItem: [ :anItem | 
			anItem
				name: 'Filters';
				icon: (self iconNamed: #smallFindIcon);
				subMenu: self filtersSubMenu ] ].

	aMenu addGroup: [ :aGroup | 
		aGroup addItem: [ :anItem | 
			anItem
				name: 'Write Ombu file';
				description: 'Write selected entries to an Ombu file';
				icon: (self iconNamed: #smallSaveAsIcon);
				action: [ self ombuFileSaveSelection ] ] ].! !

!EpLogBrowserPresenter methodsFor: 'refreshing' stamp: ''!
refreshEntryContentDeferrer
		
	^ selectionDeferrer ifNil: [
		selectionDeferrer := OmDeferrer 
			send: #refreshEntryContent
			to: self
			after: 150 milliSeconds ]! !

!EpLogBrowserPresenter methodsFor: 'menu - filters' stamp: ''!
filterBefore

	self selectedEntryItems ifNotEmpty: [ :items |
		| time |
		time := items last entry tags at: EpLog timeKey.
		self addFilter: (EpPluggableFilter before: time) ]! !

!EpLogBrowserPresenter methodsFor: 'menu' stamp: ''!
filtersSubMenu
	
	| aMenu |
	aMenu := SpMenuPresenter new.
	
	aMenu addGroup: [ :aGroup |
		aGroup addItem: [ :anItem |
			anItem
				name: 'Clean filters (', self filters size asString, ' active)';
				icon: (self iconNamed: #smallDelete);
				action: [ self removeAllFilters ] ].
		].

	aMenu addGroup: [ :aGroup |

		aGroup addItem: [ :anItem |
			anItem 
				name: EpLatestCodeChangeFilter title;
				description: EpLatestCodeChangeFilter comment;
				icon: (self iconNamed: #smallFind);
				action: [ self filterLatestCodeChanges ] ].

		aGroup addItem: [ :anItem |
			anItem 
				name: EpImpactCodeChangeFilter title;
				description: EpImpactCodeChangeFilter comment;
				icon: (self iconNamed: #smallFind);
				action: [ self filterImpactCodeChanges ] ].
	].

	aMenu addGroup: [ :aGroup |

		aGroup addItem: [ :anItem |
			anItem 
				name: EpEntryReferencesFilter title;
				icon: (self iconNamed: #smallFind);
				action: [ self filterSelection ] 
			].
		
		aGroup addItem: [ :anItem |
			anItem 
				name: 'Show only changes to this method';
				description: 'Show only additions, modifications or removals of this method.';
				icon: (self iconNamed: #smallFind);
				action: [ self filterAllChangesToSelection ] ].

		aGroup addItem: [ :anItem |
			anItem 
				name: 'Show only changes to this class or trait';
				description: 'Show only changes in the scope of this class or trait.';
				icon: (self iconNamed: #smallFind);
				action: [ self filterAllChangesToSelectionBehavior ]
			].
				
		aGroup addItem: [ :anItem |
			anItem 
				name: 'Show only changes in this package';
				description: 'Show only additions, modifications or removals of this package.';
				icon: (self iconNamed: #smallFind);
				action: [ self filterAllChangesToSelectionPackage ]
			].
	].


	aMenu addGroup: [ :aGroup |

		aGroup addItem: [ :anItem |
			anItem 
				name: 'Show only if done today';
				icon: (self iconNamed: #calendar);
				action: [ self filterToday ] ].

		aGroup addItem: [ :anItem |
			anItem 
				name: 'Hide events done after';
				icon: (self iconNamed: #calendar);
				action: [ self filterBefore ] ].

		aGroup addItem: [ :anItem |
			anItem 
				name: 'Hide events done before';
				icon: (self iconNamed: #calendar);
				action: [ self filterAfter ] ].
	].

	aMenu addGroup: [ :aGroup |
		EpPluggableFilter allFilters do: [ :aFilter |
			aGroup addItem: [ :anItem |
				anItem 
					name: aFilter title;
					icon: (self iconNamed: #smallFind);
					description: aFilter title;
					action: [ self addFilter: aFilter ] ] ]
		].

	^ aMenu! !

!EpLogBrowserPresenter methodsFor: 'private' stamp: ''!
triggerItemsFor: anEntry

	^ self log 
		triggererReferenceOf: anEntry 
		ifPresent: [ :triggerEntryReference | 
			| triggerItem |
			triggerItem := self itemForEntryReference: triggerEntryReference.
			triggerItem triggerItems, { triggerItem } ]
		ifAbsent: [ #() ]! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
applySelectedChanges

	self applyChangesIn: self selectedCodeChanges! !

!EpLogBrowserPresenter methodsFor: 'modes' stamp: ''!
beApplyMode
	self withWindowDo: [ :window | window title: 'Epicea - Apply Changes' ].
	toolbarPresenter beApplyMode.
	showEntryItemMenu := false! !

!EpLogBrowserPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	itemsPresenter := self newList.
	itemsPresenter
		beMultipleSelection;
		display: [ :entryReference | self morphForItemAt: entryReference ];
		whenSelectionChangedDo: [ self refreshEntryContentDeferrer schedule ];
		contextMenu: [ self menuMorphForSelectedItems ].

	toolbarPresenter := self instantiate: EpLogBrowserToolbarPresenter.
	toolbarPresenter logBrowserPresenter: self.

	entryContentPresenter := self newDiff.
	entryContentPresenter showOptions: false.

	self beHistoryMode.! !

!EpLogBrowserPresenter methodsFor: 'menu' stamp: ''!
eventsMenuActions 

	^ {
		{ 'Comment'. 
		#commentSelection.
		'Edit comment of selected entries'.
		#announcementIcon. 
		$c command }.
	}! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
browseSelection

	| selectionSize |
	selectionSize := self selectedEntryReferences size.	
	selectionSize > 3 ifTrue: [
		(self confirm: 'Do you want to open a browser for each code changes? (', selectionSize asString, ' items selected)')
			ifFalse: [ ^self ] ].

	self selectedEntryItems 
		select: [ :each | each entry content isCodeChange ] 
		thenDo: [ :each | each browseItem ]! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
log
	^ log! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
applyAllChangesAndCloseWindow

	self applyChangesIn: self entriesWithCodeChanges.
	self window close.! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
revertAllChangesAndCloseWindow

	self revertChangesIn: self entriesWithCodeChanges.
	self window close.! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
applyChangesIn: entries
	
	entries ifEmpty: [ ^ self inform: 'No code changes to apply' ].

	EpLogBrowserOperationFactory new
		logBrowserModel: self;
		entries: entries;
		errorHandlerBlock: self operationsErrorHandlerBlock;
		applyCodeChanges.! !

!EpLogBrowserPresenter methodsFor: 'modes' stamp: ''!
beRevertMode
	self withWindowDo: [ :window | window title: 'Epicea - Revert Changes' ].
	toolbarPresenter beRevertMode.
	showEntryItemMenu := false! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
filters

	^ andFilter subFilters! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
removeAllFilters

	andFilter := EpAndFilter withAll: #().
	self refresh.! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
inspectSelection

	self selectedEntryItems do: #inspect! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
applyCompleteRefactoringInSelection

	| entries |
	entries := self selectedEntries.
	entries size = 1 ifFalse: [ 
		^ self inform: 'Please select one refactoring' ]. "Only implemented for one"
	
	EpLogBrowserOperationFactory new
		logBrowserModel: self;
		entries: entries;
		errorHandlerBlock: self operationsErrorHandlerBlock;	
		applyCompleteRefactoring.! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
commentsLog
	
	^ commentsLog ifNil: [ self monitor log ]! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
theLog
	^ log! !

!EpLogBrowserPresenter methodsFor: 'private' stamp: ''!
addFilter: aFilter

	(andFilter subFilters includes: aFilter) ifTrue: [ ^self ].
	
	andFilter := EpAndFilter withAll: (andFilter subFilters copyWith: aFilter).
	self refresh.! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
entriesWithCodeChanges

	^ self entries select: [:each | each content isCodeChange ]! !

!EpLogBrowserPresenter methodsFor: 'menu' stamp: ''!
codeChangesMenuActions

	^ { 
		{ 'Apply...'.
		#openPreviewToApplySelectedChanges.
		'Preview the application of selected code changes (open a new window to show the effect of re-applying the changes in current image)'.
		#smallRedoIcon.
		$p command }.
		{ 'Revert...'.
		#openPreviewToRevertSelectedChanges.
		'Preview the reversion of selected code changes (open a new window to show the effect of reverting the changes in current image)'.
		#smallUndoIcon.
		$r command }.
		{ 'Browse current'.
		#browseSelection.
		'Browse working copy of entity affected in the selected event(s)'.
		#nautilusIcon.
		$b command }.
	}! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
openPreviewToRevertSelectedChanges

	| entries previewLog |
	entries := self selectedCodeChanges.
	entries ifEmpty: [ ^ self inform: 'No changes to preview revert' ].

	previewLog := EpLogBrowserOperationFactory new
		logBrowserModel: self;
		entries: entries;
		errorHandlerBlock: self operationsErrorHandlerBlock;
		newRevertPreviewLog.

	previewLog isEmpty
		ifTrue: [ self inform: 'Preview is empty (no changes to revert in current image)' ]
		ifFalse: [ previewLog browseEvents beRevertMode ]! !

!EpLogBrowserPresenter methodsFor: 'menu - filters' stamp: ''!
filterAllChangesToSelectionBehavior

	| changes |
	changes := self selectedEntryItems collect: [ :each | each entry content ].

	changes size = 1 ifFalse: [ ^ self inform: 'Should select a single change, either to a class or a trait' ]. 
	changes anyOne isEpMethodChange ifFalse: [ ^ self inform: 'Should select a method' ]. 

	self addFilter: (EpPluggableFilter isBehaviorNamed: changes anyOne behaviorAffectedName).! !

!EpLogBrowserPresenter methodsFor: 'refreshing' stamp: ''!
cleanEntryContent
	self refreshEntryContentWith: #()! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
cachedLogEntries
	"Answer log entries.
	Check size since the log might be current Monitor's, so it can grow."

	^ (cachedLogEntries isNotNil and: [ cachedLogEntries size = log entriesCount ])
		ifTrue: [ cachedLogEntries ]
		ifFalse: [
			'Reading log'
				displayProgressFrom: 0 to: 1 
				during: [ cachedLogEntries := log entries ]
			]! !

!EpLogBrowserPresenter methodsFor: 'menu - filters' stamp: ''!
filterToday

	self addFilter: EpPluggableFilter todayFilter! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
filteredEntriesCount

	^ self filteredEntryReferences size! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
filteredEntryReferences

	^ andFilter subFilters 
		ifEmpty: [ log entryReferences ]
		ifNotEmpty: [
			self cachedLogEntries
				select: [:each | andFilter accepts: each ]
				thenCollect: [:each | log referenceTo: each ] ].! !

!EpLogBrowserPresenter methodsFor: 'menu - operations' stamp: ''!
revertChangesIn: entries

	entries ifEmpty: [ ^ self inform: 'No code changes to revert' ].

	EpLogBrowserOperationFactory new
		logBrowserModel: self;
		entries: entries;
		errorHandlerBlock: self operationsErrorHandlerBlock;
		revertCodeChangesInPreviewMode.! !

!EpLogBrowserPresenter methodsFor: 'menu - accessing' stamp: ''!
selectedEntryReferences
	"Before there was a workaround here to reject nils because it used a FastTablePresenter instead of a list presenter. I have the impression that the workaround is not needed with ListPresenter and I removed the workaround. In case you find a bug were we get nils here, just report it and we will add back the workaround to reject nils with a better comment."

	^ self itemsPresenter selectedItemsSorted reversed! !

!EpLogBrowserPresenter methodsFor: 'refreshing' stamp: ''!
refreshEntryContentWith: selectedItems
	selectedItems size = 1
		ifTrue: [ | item |
			item := selectedItems anyOne.
			entryContentPresenter
				showOnlyDestination: item oldStateString isEmptyOrNil;
				showOnlySource: item newStateString isEmptyOrNil;
				leftText: item oldStateString;
				rightText: item newStateString ]
		ifFalse: [ entryContentPresenter
				leftText: '';
				rightText: '';
				showOnlyDestination: true ]! !

!EpLogBrowserPresenter methodsFor: 'menu - filters' stamp: ''!
filterAllChangesToSelection

	| changes |
	changes := (self selectedEntryItems collect: [ :each | each entry content ]).

	changes size = 1 ifFalse: [ ^ self inform: 'Should select a single method change' ]. 
	changes anyOne isEpMethodChange ifFalse: [ ^ self inform: 'Should select a method' ]. 

	self addFilter: (EpPluggableFilter isMethod: changes anyOne methodAffected).! !

!EpLogBrowserPresenter methodsFor: 'private' stamp: ''!
itemForEntryReference: entryReference

	^ self cachedItems
		at: entryReference
		ifPresent: [:item | item ]
		ifAbsentOrNil: [ 
			| newItem |
			newItem := self newItemForEntryReference: entryReference.
			self cachedItems at: entryReference put: newItem.
			newItem ]! !

!EpLogBrowserPresenter methodsFor: 'menu - filters' stamp: ''!
filterSelection

	| references |
	references := self selectedEntryReferences.

	references ifEmpty: [ ^self inform: 'Selection is empty' ].

	self addFilter: (EpEntryReferencesFilter new
		theLog: log; 
		rejectedEntryReferences: references; 
		yourself).! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
removeFilter: aFilter

	andFilter := EpAndFilter withAll: (andFilter subFilters copyWithout: aFilter).
	self refresh.! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
theLog: aLog

	cachedItems := nil.
	cachedLogEntries := nil.
	log := aLog.! !

!EpLogBrowserPresenter methodsFor: 'menu - accessing' stamp: ''!
selectedEntryItems

	^ self selectedEntryReferences collect: [:each |
		self itemForEntryReference: each ]! !

!EpLogBrowserPresenter methodsFor: 'menu - accessing' stamp: ''!
selectedEntries

	^ self selectedEntryItems collect: [:each | each entry]! !

!EpLogBrowserPresenter methodsFor: 'menu - filters' stamp: ''!
filterAllChangesToSelectionPackage

	| changes |
	changes := (self selectedEntryItems collect: [ :each | each entry content ]).

	changes size = 1 ifFalse: [ ^ self inform: 'Should select a single change' ]. 

	self addFilter: (EpPluggableFilter isPackageNamed: changes anyOne affectedPackageName).! !

!EpLogBrowserPresenter methodsFor: 'private' stamp: ''!
newItemForEntryReference: entryReference

	| entry triggers|
	entry := log entryFor: entryReference.
	
	triggers := [ self triggerItemsFor: entry ] 
		on: NotFound 
		do: [ #() ]. "Just hide it... not an esential information"
	
	^ EpEntryItem new
		browser: self;
		entry: entry;
		triggerItems: triggers;
		yourself! !

!EpLogBrowserPresenter methodsFor: 'menu - filters' stamp: ''!
filterImpactCodeChanges

	self addFilter: (EpImpactCodeChangeFilter new environment: self class environment; yourself)! !

!EpLogBrowserPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	aWindowPresenter initialExtent: 550 @ 700! !

!EpLogBrowserPresenter methodsFor: 'menu' stamp: ''!
menuActionsForSelectedItems

	| selectedReferences |
	selectedReferences := self selectedEntryReferences.

	selectedReferences isEmpty ifTrue: [ ^#() ].
	
	selectedReferences size = 1 ifTrue: [
		| event |
		event := (self itemForEntryReference: selectedReferences anyOne) event.
		(event isEpRefactoring and: [ event canBuildRBRefactoring ])
			ifTrue: [ ^ self refactoringMenuActions, self eventsMenuActions ]].

	^ self codeChangesMenuActions, self eventsMenuActions! !

!EpLogBrowserPresenter methodsFor: 'accessing' stamp: ''!
totalEntriesCount

	^ self theLog entriesCount! !

!EpLogBrowserPresenter methodsFor: 'menu - accessing' stamp: ''!
selectedCodeChanges

	^ self selectedEntryItems 
		select: [ :each | each entry content isCodeChange ]
		thenCollect: [ :each | each entry ]! !

!EpLogBrowserPresenter methodsFor: 'private' stamp: ''!
cachedItems

	^ cachedItems ifNil: [ cachedItems := WeakValueDictionary new ]! !

!EpLogBrowserPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newTopToBottom
		  positionOfSlider: 0.6;
		  add: #itemsPresenter;
		  add: (SpBoxLayout newTopToBottom
				   add: #toolbarPresenter
				   expand: false
				   fill: false
				   padding: 2;
				   add: #entryContentPresenter
				   expand: true
				   fill: true
				   padding: 2;
				   yourself);
		  yourself! !

!EpLogBrowserPresenter class methodsFor: 'instance creation' stamp: ''!
newWithLog: aLog

	^ self new
		theLog: aLog;
		yourself! !

!EpLogBrowserPresenter class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	^ self openWithLog: self defaultLog! !

!EpLogBrowserPresenter class methodsFor: 'instance creation' stamp: ''!
openWithLog: aLog
	^ (self newWithLog: aLog)
		refresh;
		openWithSpec;
		yourself! !

!EpLogBrowserPresenter class methodsFor: 'accessing' stamp: ''!
defaultLog

	^ EpMonitor current log! !

!EpLogBrowserToolbarPresenter commentStamp: ''!
I am a toolbar to be used in the EpLogBrowserModel.!
!EpLogBrowserToolbarPresenter methodsFor: 'refreshing' stamp: ''!
refresh
	filtersButton label: self activeFiltersString.
	statusLabel label: self statusString! !

!EpLogBrowserToolbarPresenter methodsFor: 'accessing' stamp: ''!
beRevertMode
	filtersButton
		icon: (self iconNamed: #smallUndoIcon);
		label: 'Confirm All Changes';
		action: [ logBrowserPresenter revertAllChangesAndCloseWindow ]! !

!EpLogBrowserToolbarPresenter methodsFor: 'private' stamp: ''!
activeFiltersString
	^ 'Filters (' , logBrowserPresenter filters size asString , ')'! !

!EpLogBrowserToolbarPresenter methodsFor: 'refreshing' stamp: ''!
statusString
	^ String
		streamContents: [ :stream | 
			| filtered total |
			filtered := logBrowserPresenter filteredEntriesCount.
			total := logBrowserPresenter totalEntriesCount.

			stream
				print: filtered;
				nextPutAll: ' events'.

			filtered = total
				ifFalse: [ stream
						nextPutAll: ' (';
						print: total;
						nextPutAll: ' total)' ] ]! !

!EpLogBrowserToolbarPresenter methodsFor: 'accessing' stamp: ''!
beApplyMode
	filtersButton
		icon: (self iconNamed: #smallRedoIcon);
		label: 'Confirm All Changes';
		action: [ logBrowserPresenter applyAllChangesAndCloseWindow ]! !

!EpLogBrowserToolbarPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	filtersButton := self newButton.
	statusLabel := self newLabel! !

!EpLogBrowserToolbarPresenter methodsFor: 'accessing' stamp: ''!
beHistoryMode
	filtersButton
		icon: (self iconNamed: #smallFindIcon);
		action: [
			logBrowserPresenter filtersSubMenu
				openWithSpecAt: self currentWorld activeHand position ]! !

!EpLogBrowserToolbarPresenter methodsFor: 'accessing' stamp: ''!
logBrowserPresenter: anObject
	logBrowserPresenter := anObject! !

!EpLogBrowserToolbarPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newLeftToRight
		add: #statusLabel;
		addLast: #filtersButton;
		yourself! !

!EpLogEntriesComment commentStamp: ''!
I represent a comment to Epicea entries  performed in an EpLogBrowser.!
!EpLogEntriesComment methodsFor: 'accessing' stamp: ''!
newComment
	^ newComment! !

!EpLogEntriesComment methodsFor: 'accessing' stamp: ''!
comment
	^ self newComment! !

!EpLogEntriesComment methodsFor: 'initialization' stamp: ''!
initializeWithEntryReferences: aCollection oldComment: theOldComment newComment: theNewComment 
	self initializeWith: aCollection.
	oldComment := theOldComment.
	newComment := theNewComment.! !

!EpLogEntriesComment methodsFor: 'accessing' stamp: ''!
oldComment
	^ oldComment! !

!EpLogEntriesComment methodsFor: 'copying' stamp: ''!
copyWithEntryReferences: aCollection
	^ self class
		entryReferences: aCollection
		oldComment: self oldComment
		newComment: self newComment! !

!EpLogEntriesComment methodsFor: 'visitor' stamp: ''!
accept: aVisitor 
	^ aVisitor visitLogCommentModification: self! !

!EpLogEntriesComment methodsFor: 'testing' stamp: ''!
isEpLogEntriesComment

	^ true! !

!EpLogEntriesComment class methodsFor: 'instance creation' stamp: ''!
entryReferences: aCollection oldComment: aString newComment: anotherString
	^ self basicNew
		initializeWithEntryReferences: aCollection 
		oldComment: aString 
		newComment: anotherString;
		yourself! !

!EpLogNode commentStamp: ''!
I am a node in a tree of Epicea logs, in a particular refresh of the browser. The nodes of such tree are Epicea files and an edge between a node A and another B exist when A contains an entry whose prior node is in B.!
!EpLogNode methodsFor: 'accessing' stamp: ''!
modificationTime

	^ self subclassResponsibility! !

!EpLogNode methodsFor: 'accessing' stamp: ''!
modificationTimeString

	self subclassResponsibility! !

!EpLogNode methodsFor: 'accessing' stamp: ''!
log

	^ self subclassResponsibility! !

!EpLogNode methodsFor: 'initialization' stamp: ''!
populateReferencedNodesWith: nodes

	self referencedGlobalNames do: [ :referencedGlobalName |
		nodes
			detect: [:each | each globalName = referencedGlobalName ]
			ifFound: [ :referencedNode | referencedNodes add: referencedNode ] ]! !

!EpLogNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	referencedNodes := Set new.! !

!EpLogNode methodsFor: 'testing' stamp: ''!
isMonitor

	^ false! !

!EpLogNode methodsFor: 'accessing' stamp: ''!
referencedGlobalNames

	| firstEntry priorReference |
	firstEntry := self log firstEntryIfAbsent: [ ^ self referencedGlobalNamesIfEmptyLog ].
	priorReference := firstEntry tags at: EpLog priorReferenceKey ifAbsent: [ ^ #() ].
	priorReference isNull ifTrue: [ ^ #() ].
	
	"Could happen when monitor's ombu file is removed externally"
	priorReference globalName = self globalName ifTrue: [ ^ #() ].

	^ { priorReference globalName }! !

!EpLogNode methodsFor: 'accessing' stamp: ''!
smallName

	^ self globalName contractTo: 25! !

!EpLogNode methodsFor: 'accessing' stamp: ''!
globalName

	^ self subclassResponsibility! !

!EpLogNode methodsFor: 'accessing' stamp: ''!
referencedGlobalNamesIfEmptyLog

	^ #()! !

!EpLogNode methodsFor: 'accessing' stamp: ''!
referencedNodes
	"Answer the referenced nodes, that were populated previously by #populateReferencedNodesWith:"
	
	^ referencedNodes! !

!EpLogNodeGraphPresenter commentStamp: ''!
I am a browser for Epicea logs in a directory.

Usage:

self open.!
!EpLogNodeGraphPresenter methodsFor: 'refreshing' stamp: ''!
refreshLogNodesTreePresenter
	| nodes |
	nodes := #().
	[ nodes := EpFileLogNode fromAllLogsIn: self directory.
	nodes := nodes sorted: [ :a :b | a modificationTime >= b modificationTime ] ]
		on: FileSystemError
		do: [ :error | self inform: error asString ].

	self isMonitorDirectory
		ifTrue: [ | currentGlobalName |
			currentGlobalName := self monitor sessionStore store globalName.
			nodes := nodes reject: [ :each | each globalName = currentGlobalName ].
			nodes := {(EpMonitorLogNode for: self monitor)} , nodes ].

	"Obtain the references between nodes only if the checkbox is selected since it's a potentially expensive process."
	hiedraCheckBox state ifTrue: [ nodes do: [ :node | node populateReferencedNodesWith: nodes ] displayingProgress: 'Analyzing ' , directory asString ].

	hiedraColumnController ruler: (HiRulerBuilder newRulerValues: nodes linksBlock: [ :node | node referencedNodes asArray ]).
	hiedraColumnController reset.
	logNodesTable items: nodes! !

!EpLogNodeGraphPresenter methodsFor: 'accessing' stamp: ''!
monitor
	
	^ monitor ifNil: [ EpMonitor current ]! !

!EpLogNodeGraphPresenter methodsFor: 'private' stamp: ''!
selectDirectory
	(UIManager default chooseDirectoryFrom: self directory)
		ifNotNil: [ :selectedDirectory | self directory: selectedDirectory ]! !

!EpLogNodeGraphPresenter methodsFor: 'refreshing' stamp: ''!
refresh
	self refreshLogNodesTreePresenter! !

!EpLogNodeGraphPresenter methodsFor: 'initialization' stamp: ''!
initializeLogNodesTable
	self initializeHiedraController.

	logNodesTable
		beMultipleSelection;
		addColumn: ((SpImageTableColumn evaluated: [ :item | hiedraColumnController cellMorphAtValue: item ])
			width: 50;
			yourself);
		addColumn: (SpStringTableColumn 
			title: 'Modified' 
			evaluated: [ :item | item modificationTimeString ])
			beNotExpandable;
		addColumn: (SpStringTableColumn 
			title: 'File'
			evaluated: [ :item | item smallName ])! !

!EpLogNodeGraphPresenter methodsFor: 'refreshing' stamp: ''!
isMonitorDirectory

	^ self monitor sessionStore directory asFileReference = self directory asFileReference! !

!EpLogNodeGraphPresenter methodsFor: 'accessing' stamp: ''!
directory: aFileReference

	directory := aFileReference.
	
	self refresh.! !

!EpLogNodeGraphPresenter methodsFor: 'initialization' stamp: ''!
initializeHiedraController

	hiedraColumnController := HiColumnController new.	
	hiedraColumnController pageSize: 100.
	hiedraColumnController renderer
		rowHeight: self rowHeight;
		cellWidth: self rowHeight // 3;
		arrowSize: 1.0;
		nodeConnectionOffset: 2.5.

	hiedraColumnController renderer rowHeight: FTTableMorph defaultRowHeight floor.! !

!EpLogNodeGraphPresenter methodsFor: 'accessing' stamp: ''!
selectedLogNodes
	^ logNodesTable selection selectedItems! !

!EpLogNodeGraphPresenter methodsFor: 'accessing' stamp: ''!
monitor: anEpMonitor

	monitor := anEpMonitor! !

!EpLogNodeGraphPresenter methodsFor: 'accessing' stamp: ''!
directory

	^ directory ifNil: [ 
		directory := self monitor sessionStore baseLocator ]! !

!EpLogNodeGraphPresenter methodsFor: 'initialization' stamp: ''!
initializeHiedraCheckBox
	hiedraCheckBox
		help: 'Analyze and display connections between log files.';
		label: 'Link logs';
		state: false;
		whenChangedDo: [ self refresh ]! !

!EpLogNodeGraphPresenter methodsFor: 'accessing' stamp: ''!
rowHeight

	^ 23! !

!EpLogNodeGraphPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionChangedDo: aBlock
	logNodesTable whenSelectionChangedDo: aBlock! !

!EpLogNodeGraphPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpBoxLayout newTopToBottom
		add: (logNodesTable := self newTable);
		add: (SpBoxLayout newLeftToRight
				add: (hiedraCheckBox := self newCheckBox);
				yourself)
			expand: false;
		yourself).

	self initializeLogNodesTable.
	self initializeHiedraCheckBox! !

!EpLogNodeGraphPresenter class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	^ self new
		refresh;
		openWithSpec;
		yourself! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testFromHeadDetectIfNotFound

	" Assert for getting 42 when entry is not found. "
	self
		assert: (log
			fromHeadDetect: [ :dummy | false ]
			ifNotFound: [ 42 ])
		equals: 42.! !

!EpLogTest methodsFor: 'running' stamp: ''!
tearDown
		
	logBuilder cleanUp.
	super tearDown.! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testShouldKeepHeadReferenceAfterReOpen
	| anotherLog |

	anotherLog := EpLog newWithStore: log store copy refresh.

	self assert: anotherLog headReference equals: log headReference.! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testHeadReference
	self deny: log headReference isNull! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testFromNullReferenceDetectNotFound

	self
		should: [ log from: log nullReference detect: [ :entry | true ] ]
		raise: KeyNotFound! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testShouldKeepHeadReferenceAfterRefresh
	| headReference |
	headReference := log headReference.

	log refresh.

	self assert: log headReference equals: headReference.! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testPriorEntriesFromNullReferenceIsEmpty
	| priorEntries |
	priorEntries := log priorEntriesFrom: log nullReference.
	self assertEmpty: priorEntries! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testFromHeadDetect

	" Assert for head "
	self
		assert: (log fromHeadDetect: [ :dummy | true ])
		equals: log head.! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testEntriesCount
	self assert: log entriesCount equals: 5! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testEntryReferences

	| entryReferences entries |
	entryReferences := log entryReferences.
	entries := log entries.
	
	entryReferences withIndexDo: [:each :index |
		log
			entryFor: each
			ifPresent: [:entry | self assert: entry equals: (entries at: index) ]
			ifAbsent: [ self fail ] ].

	self assert: entryReferences size equals: 5.! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testFromDetect
	| reference isPrior entry |
	reference := log priorReferenceAt: log head.
	entry := log entryFor: reference.
	isPrior := false.
	" Assert for entry "
	self
		assert: (log from: reference detect: [ :dummy | true ])
		equals: entry.
	" Assert for the entry before 'entry' "
	self
		assert: (log
			from: reference
			detect: [ :dummy |
				isPrior
					ifFalse: [ isPrior := true. false ]
					ifTrue: [ true ] ])
		equals: (log entryFor: (log priorReferenceAt: entry)).! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testFromDetectIfNotFound
	| reference |
	reference := log priorReferenceAt: log head.
	" Assert for getting 42 when entry is not found. "
	self
		assert: (log
			from: reference
			detect: [ :dummy | false ]
			ifNotFound: [ 42 ])
		equals: 42.! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testEntries
	self assert: log entries size equals: 5! !

!EpLogTest methodsFor: 'tests' stamp: ''!
testFirstEntryIfAbsent
	self 
		assert: (log firstEntryIfAbsent: [ self fail ]) 
		equals: log entries first! !

!EpLogTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	logBuilder := EpTestLogBuilder new.
	log := logBuilder oneTriggerWithFourChildrenLog.! !

!EpLostChangesDetector commentStamp: ''!
I check on image startup that there is lost logs for current image and I open browser on it to show changes to user.
I super usefull for recovering lost changes after image crash!
!EpLostChangesDetector methodsFor: 'accessing' stamp: ''!
lostChanges

	| freshLog lastSessionHeadReference entries |
	self hasLostChanges ifFalse: [ ^ #() ]. "Start by fastest available check: file size"
	lastSessionHeadReference := lastSessionFileStore headReference.
	lastSessionFileStore refresh.
	freshLog := EpLog newWithStore: lastSessionFileStore.
	freshLog headReference = lastSessionHeadReference ifTrue: [ ^ #() ]. "Just no lost events"

	"Then, there are lost events"
	entries := freshLog priorEntriesFrom: freshLog headReference upTo: lastSessionHeadReference.

	^ entries ifNotEmpty: [ entries allButLast reversed ]! !

!EpLostChangesDetector methodsFor: 'testing' stamp: ''!
hasLostChanges
	
	^ hasLostChanges! !

!EpLostChangesDetector methodsFor: 'accessing' stamp: ''!
openBrowserIfLostChanges

	| lostChanges lostChangesLog browser |
	lostChanges := self lostChanges collect: [:each | each content].
	lostChanges ifEmpty: [ ^ self ].
	lostChangesLog := EpLog newWithStore: (OmMemoryStore withAllContents: lostChanges).

	browser := EpLogBrowserPresenter newWithLog: lostChangesLog.
	browser refresh.
	browser withWindowDo: [ :w | w title: 'Epicea - Lost Changes Detected'].
	browser openWithSpec.! !

!EpLostChangesDetector methodsFor: 'initialization' stamp: ''!
initializeWithLog: aLog

	self initialize.
	
	lastSessionFileStore := aLog store lowLevelFileStoreIfNone: [ nil ]. "Never nil?"
	hasLostChanges :=
		lastSessionFileStore
			ifNil: [ false ]
			ifNotNil: [ lastSessionFileStore isOutdated ].! !

!EpLostChangesDetector class methodsFor: 'instance creation' stamp: ''!
new

	^ self newWithLog: EpMonitor current log! !

!EpLostChangesDetector class methodsFor: 'initialization' stamp: ''!
initialize
	"
	self initialize
	"
	SessionManager default registerToolClassNamed: self name! !

!EpLostChangesDetector class methodsFor: 'testing' stamp: ''!
isEnabled

	^ enabled ifNil: [ enabled := true ]! !

!EpLostChangesDetector class methodsFor: 'instance creation' stamp: ''!
newWithLog: aLog

	^ self basicNew
		initializeWithLog: aLog;
		yourself! !

!EpLostChangesDetector class methodsFor: 'accessing' stamp: ''!
enabled: aBoolean

	enabled := aBoolean! !

!EpLostChangesDetector class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting

	| detector |
	(isImageStarting and: [ 
		self isEnabled and: [ "Detector can be disabled via system settings"
		EpMonitor hasCurrent and: [ "Nothing to recover if wasn't recording"
		EpMonitor current isEnabled and: [ 
		Smalltalk isHeadless not ]]]])  "Can't browse if UI disabled"
			ifFalse: [ ^ self ].

	detector := self new.
	
	SessionManager default addDeferredStartupAction: [
		(detector hasLostChanges and: [ self confirm: 'It seems your last Pharo session exited without saving some code. Do you want to recover it?' ])
			ifTrue: [ detector openBrowserIfLostChanges ] ]! !

!EpLostChangesDetectorTest commentStamp: ''!
An EpLostChangesDetectorTest is a test class for testing the behavior of EpLostChangesDetector!
!EpLostChangesDetectorTest methodsFor: 'tests' stamp: ''!
testDetectThreeChanges

	| logWithLostChanges numberOfLostChanges expectedLostClassNames detectedLostChanges |

	"Build a log with several lost changes (class additions)"
	numberOfLostChanges := 3.
	logWithLostChanges := EpLog newWithStore: monitor sessionStore store flush copyReopened refresh.
	expectedLostClassNames := (1 to: numberOfLostChanges) collect: [ :each | classFactory newClass name ] as: Array.
	monitor sessionStore flush.

	"At this moment, the log meets the conditions of opening an image after a crash."
	detector := EpLostChangesDetector newWithLog: logWithLostChanges.

	detectedLostChanges := detector lostChanges.
	detectedLostChanges do: [ :each | self assert: each content isEpClassChange ].

	self assert: detectedLostChanges size equals: numberOfLostChanges.
	self
		assert: (detectedLostChanges collect: [ :each | each content behaviorAffectedName ]) asArray
		equals: expectedLostClassNames.! !

!EpLostChangesDetectorTest methodsFor: 'tests' stamp: ''!
testDetectNoChange
	classFactory newClass.
	monitor log store flush.
	detector := EpLostChangesDetector newWithLog: monitor log.
	self deny: detector hasLostChanges.
	self assertEmpty: detector lostChanges.

	self assert: monitor log entriesCount equals: 2	"Just to be sure of the assumed precondition: category and only one class created"! !

!EpLostChangesDetectorTest methodsFor: 'tests' stamp: ''!
testDetectInEmptyLog
	detector := EpLostChangesDetector newWithLog: monitor log.
	self deny: detector hasLostChanges.
	self assertEmpty: detector lostChanges.

	self assertEmpty: monitor log entries	"Just to be sure of the assumed precondition"! !

!EpLostChangesDetectorTest methodsFor: 'tests' stamp: ''!
testDetectOneChangeDetectedAndOneIgnored

	| logWithALostChange |
	"Create an initial change that will be ignored by the detector (read below)"
	classFactory newClass.
	
	"Simulate the image session starts here (then previous change shouldn't be detected as lost... that's how it works)."
	logWithALostChange := EpLog newWithStore: monitor sessionStore store flush copyReopened refresh.
	classFactory newClass.
	monitor sessionStore flush.
	
	"At this moment, the log meets the conditions of opening an image after a crash."
	detector := EpLostChangesDetector newWithLog: logWithALostChange.

	self assert: detector hasLostChanges.
	self assert: detector lostChanges size equals: 1.
	self assert: monitor log entriesCount > 1. "Just to ensure assumptions of this test"! !

!EpLostChangesDetectorTest methodsFor: 'tests' stamp: ''!
testDetectNoChangeBecauseLogFileWasDeleted

	| logWithALostChange |
	"Build a fake log with a lost change"
	classFactory newClass.
	logWithALostChange := EpLog newWithStore: monitor sessionStore store flush copyReopened refresh.
	classFactory newClass.
	monitor sessionStore flush.

	"Delete the file"
	monitor sessionStore store ensureDeleteFile.

	detector := EpLostChangesDetector newWithLog: logWithALostChange.
	self deny: detector hasLostChanges.
	self assertEmpty: detector lostChanges.! !

!EpMethodAddition commentStamp: ''!
I represent a addition of a method in a class or a trait.!
!EpMethodAddition methodsFor: 'accessing' stamp: ''!
selector

	^ method selector! !

!EpMethodAddition methodsFor: 'initialization' stamp: ''!
initializeMethod: aCompiledMethod

	self initialize.
	method := aCompiledMethod asEpiceaRingDefinition.! !

!EpMethodAddition methodsFor: 'accessing' stamp: ''!
methodAdded

	^ method! !

!EpMethodAddition methodsFor: 'accessing' stamp: ''!
protocol

	^ method protocol! !

!EpMethodAddition methodsFor: 'accessing' stamp: ''!
affectedPackageName

	^ method package! !

!EpMethodAddition methodsFor: 'accessing' stamp: ''!
methodAffected

	^ self methodAdded! !

!EpMethodAddition methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitMethodAddition: self! !

!EpMethodAddition methodsFor: 'accessing' stamp: ''!
sourceCode

	^ method sourceCode! !

!EpMethodAddition class methodsFor: 'instance creation' stamp: ''!
method: aCompiledMethod
	
	^ self basicNew
		initializeMethod: aCompiledMethod;
		yourself! !

!EpMethodChange commentStamp: ''!
I represent a change in the method dictionary of a class or a trait.!
!EpMethodChange methodsFor: 'accessing' stamp: ''!
behaviorAffectedName

	^ self methodAffected className! !

!EpMethodChange methodsFor: 'accessing' stamp: ''!
methodAffectedSourceCode

	^ self methodAffected sourceCode! !

!EpMethodChange methodsFor: 'testing' stamp: ''!
isEpMethodChange

	^ true! !

!EpMethodChange methodsFor: 'accessing' stamp: ''!
methodAffectedSelector

	^ self methodAffected selector! !

!EpMethodChange methodsFor: 'testing' stamp: ''!
doesOverride: aCodeChange

	^ aCodeChange isEpMethodChange and: [
		aCodeChange behaviorAffectedName = self behaviorAffectedName and: [ 
		aCodeChange methodAffectedSelector = self methodAffectedSelector ] ]! !

!EpMethodChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.

	aStream 
		nextPut: $(;
		nextPutAll: self behaviorAffectedName;
		nextPutAll: '>>';
		nextPutAll: self methodAffectedSelector;
		nextPut: $)! !

!EpMethodChange methodsFor: 'accessing' stamp: ''!
methodAffectedProtocol

	^ self methodAffected protocol! !

!EpMethodChange methodsFor: 'accessing' stamp: ''!
methodAffected
	
	^ self subclassResponsibility! !

!EpMethodModification commentStamp: ''!
I represent a modification of a method in a class or a trait.!
!EpMethodModification methodsFor: 'initialization' stamp: ''!
initializeWithOldMethod: anOldMethod newMethod: aNewMethod

	self initialize.
	oldMethod := anOldMethod asEpiceaRingDefinition.
	newMethod := aNewMethod asEpiceaRingDefinition.! !

!EpMethodModification methodsFor: 'accessing' stamp: ''!
oldSourceCode

	^ oldMethod sourceCode! !

!EpMethodModification methodsFor: 'accessing' stamp: ''!
oldMethod

	^ oldMethod! !

!EpMethodModification methodsFor: 'accessing' stamp: ''!
newMethod

	^ newMethod! !

!EpMethodModification methodsFor: 'accessing' stamp: ''!
oldProtocol

	^ oldMethod protocol! !

!EpMethodModification methodsFor: 'accessing' stamp: ''!
newSourceCode

	^ newMethod sourceCode! !

!EpMethodModification methodsFor: 'accessing' stamp: ''!
affectedPackageName

	^ self newMethod package! !

!EpMethodModification methodsFor: 'accessing' stamp: ''!
methodAffected
	
	^ newMethod! !

!EpMethodModification methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitMethodModification: self! !

!EpMethodModification methodsFor: 'accessing' stamp: ''!
newProtocol

	^ newMethod protocol! !

!EpMethodModification class methodsFor: 'instance creation' stamp: ''!
oldMethod: anOldMethod newMethod: aNewMethod

	^ self basicNew
		initializeWithOldMethod: anOldMethod
		newMethod: aNewMethod;
		yourself! !

!EpMethodRemoval commentStamp: ''!
I represent a removal of a method in a class or a trait.!
!EpMethodRemoval methodsFor: 'accessing' stamp: ''!
methodRemoved

	^ method! !

!EpMethodRemoval methodsFor: 'accessing' stamp: ''!
selector

	^ method selector! !

!EpMethodRemoval methodsFor: 'initialization' stamp: ''!
initializeWithMethod: aCompiledMethod

	self initialize.
	method := aCompiledMethod asEpiceaRingDefinition.! !

!EpMethodRemoval methodsFor: 'accessing' stamp: ''!
protocol

	^ method protocol! !

!EpMethodRemoval methodsFor: 'accessing' stamp: ''!
affectedPackageName

	^ method package! !

!EpMethodRemoval methodsFor: 'accessing' stamp: ''!
methodAffected

	^ method! !

!EpMethodRemoval methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitMethodRemoval: self! !

!EpMethodRemoval methodsFor: 'accessing' stamp: ''!
sourceCode

	^ method sourceCode! !

!EpMethodRemoval class methodsFor: 'instance creation' stamp: ''!
method: aCompiledMethod

	^ self basicNew
		initializeWithMethod: aCompiledMethod;
		yourself! !

!EpMonitor commentStamp: ''!
I am a system monitor.

I subscribe to the system announcer to translate announcements to Epicea events (ie. subclasses of EpEvent), and record them into a log.!
!EpMonitor methodsFor: 'accessing' stamp: ''!
basicLog
	"Answer a new EpLog with a OmFileStore (not a OmSessionStore as #log)."

	^ EpLog newWithStore: self sessionStore store! !

!EpMonitor methodsFor: 'private' stamp: ''!
announceMonitorStateUpdated

	self announcer announce: EpMonitorStateUpdated new.! !

!EpMonitor methodsFor: 'private' stamp: ''!
handleAnyErrorDuring: aBlock

	aBlock on: Error do: [:error | self handleError: error ]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
classModified: aClassModifiedAnnouncement

	^ EpClassModification
		oldClass: aClassModifiedAnnouncement oldClassDefinition
		newClass: aClassModifiedAnnouncement newClassDefinition! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
protocolAdded: aProtocolAdded

	self handleAnyErrorDuring: [
		self addEvent: 
			(EpProtocolAddition 
				behavior: aProtocolAdded classAffected
				protocol: aProtocolAdded protocol)]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
methodAdded: aMethodAddedAnnouncement

	self handleAnyErrorDuring: [
		self addEvent: (EpMethodAddition method: aMethodAddedAnnouncement methodAffected) ]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
behaviorModified: aClassModifiedClassDefinitionAnnouncement

	self handleAnyErrorDuring: [
		| event |
		event := aClassModifiedClassDefinitionAnnouncement classAffected isTrait
			ifTrue: [ self traitModified: aClassModifiedClassDefinitionAnnouncement ]
			ifFalse: [ self classModified: aClassModifiedClassDefinitionAnnouncement ].

		event hasChanges ifTrue: [ self addEvent: event ]
	]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
classCommented: anAnnouncement

	self addEvent: (EpBehaviorCommentChange newWith: anAnnouncement)! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
sessionEnd
	self addEvent: EpSessionEnd new! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
jobStarted: aJobStart

	| aJob |
	aJob := aJobStart job.

	"We only care in these cases"
	aJob owner isEpiceaInterestingJobOwner ifFalse: [ ^ self ].

	self 
		addEvent: aJob owner asEpiceaEvent 
		newEntryDo: [ :newEntry |
			entryReferenceByEvent
				at: aJob
				put: (log referenceTo: newEntry) ]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
classRecategorized: aClassRecategorizedAnnouncement

	self handleAnyErrorDuring: [
		aClassRecategorizedAnnouncement newCategory = aClassRecategorizedAnnouncement oldCategory
			ifTrue: [ ^ self ].
			
		self addEvent: (EpBehaviorCategoryChange
			oldCategory: aClassRecategorizedAnnouncement oldCategory
			newCategory: aClassRecategorizedAnnouncement newCategory
			class: aClassRecategorizedAnnouncement classAffected)]! !

!EpMonitor methodsFor: 'initialization' stamp: ''!
initializeWithLog: aLog

	self initialize.

	log := aLog.
	systemAnnouncer := SystemAnnouncer uniqueInstance.
	jobAnnouncer := Job jobAnnouncer.
	
	entryReferenceByEvent := IdentityDictionary new.! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
logEntryCommented: aCommentModification

	self addEvent: aCommentModification! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
sessionStart
	self addEvent: EpSessionStart new! !

!EpMonitor methodsFor: 'accessing' stamp: ''!
debugMode: aBoolean
	debugMode := aBoolean! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
categoryRenamed: aCategoryRenamed

	self handleAnyErrorDuring: [
		self addEvent: (EpCategoryRename
			oldName: aCategoryRenamed oldCategoryName
			newName: aCategoryRenamed newCategoryName) ]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
protocolRemoved: aProtocolRemoved 

	"Skip an irrelevant case"
	aProtocolRemoved protocol = Protocol unclassified ifTrue: [ ^self ].

	self handleAnyErrorDuring: [
		self addEvent: 
			(EpProtocolRemoval
				behavior: aProtocolRemoved classAffected
				protocol: aProtocolRemoved protocol)]! !

!EpMonitor methodsFor: 'accessing' stamp: ''!
debugMode
	^ debugMode ifNil: [ false ]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
methodRecategorized: aMethodRecategorized

	self handleAnyErrorDuring: [
		| oldMethod newMethod |
		"Workaround: When a trait is removed from the trait composition, 
		then this announcement is wrongly announced."
		
		aMethodRecategorized methodRecategorized ifNil: [ ^ self ].
		oldMethod := aMethodRecategorized methodRecategorized asEpiceaRingDefinition
			protocol: aMethodRecategorized oldProtocol;
			yourself.
		newMethod := aMethodRecategorized methodRecategorized asEpiceaRingDefinition
			protocol: aMethodRecategorized newProtocol;
			yourself.
			
		self addEvent: (EpMethodModification oldMethod: oldMethod newMethod: newMethod)]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
traitRemoved: classRemoved

	self addEvent: (EpTraitRemoval trait: classRemoved)! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
categoryAdded: aCategoryAdded

	self handleAnyErrorDuring: [
		self addEvent: (EpCategoryAddition named: aCategoryAdded categoryName) ]! !

!EpMonitor methodsFor: 'enabling' stamp: ''!
enable
	"Enable monitoring IDE announcements."
	
	self isEnabled ifFalse: [ 			
		self subscribeToSystemAnnouncer.
		self subscribeToJobAnnouncer. ].

	self announceMonitorStateUpdated.! !

!EpMonitor methodsFor: 'private' stamp: ''!
addEvent: anEvent newEntryDo: aBlock triggerReference: triggerReference

	| newEntry |
	newEntry := log 
		addEntryWith: anEvent
		tags: [ :tags |
			triggerReference isNull ifFalse: [
				tags 
					at: EpLog triggererReferenceKey
					put: triggerReference ].
			
			tags at: EpLog authorKey put: self author.
			tags at: EpLog timeKey put: self time ].
		
	aBlock value: newEntry.! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
behaviorAdded: aClassAddedAnnouncement
	self
		handleAnyErrorDuring: [ aClassAddedAnnouncement classAdded isTrait
				ifTrue: [ self traitAdded: aClassAddedAnnouncement ]
				ifFalse: [ self classAdded: aClassAddedAnnouncement ] ]! !

!EpMonitor methodsFor: 'accessing' stamp: ''!
writingDeferDuration: aDuration

	^ self sessionStore writingDeferDuration: aDuration! !

!EpMonitor methodsFor: 'private' stamp: ''!
addEvent: anEvent 

	self addEvent: anEvent newEntryDo: [ :newEntry | ]! !

!EpMonitor methodsFor: 'private' stamp: ''!
currentTriggerReference

	Job current 	
		ifNil: [ ^ log nullReference ]
		ifNotNil: [ :currentJob |
			currentJob 
				lookup: [ :job | 
					entryReferenceByEvent at: job 
						ifPresent: [ :reference | ^ reference ] 
						ifAbsent: [ false ] ]
				ifNone: [ ^ log nullReference ].
			].! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
behaviorRemoved: aClassRemovedAnnouncement

	self handleAnyErrorDuring: [
		"Workaround: the announcement occurs after class is renamed to AnObsolete 
		and removed from package."
		
		| classRemoved |
		classRemoved := aClassRemovedAnnouncement classRemoved asEpiceaRingDefinition.

		"Fix class name (remove AnObsolete prefix)"
		classRemoved definitionSource: 
			(classRemoved definitionSource
				copyReplaceAll: aClassRemovedAnnouncement classRemoved name printString
				with: aClassRemovedAnnouncement classRemoved originalName printString).

		"Fix class name in the metaclass"
		classRemoved classSide definitionSource: 
			(classRemoved classSide definitionSource
				copyReplaceAll: aClassRemovedAnnouncement classRemoved name
				with: aClassRemovedAnnouncement classRemoved originalName).

		"Fix category"
		classRemoved definitionSource: 
			(classRemoved definitionSource
				copyReplaceAll: 'package: ', 'Unclassified' printString
				with: 'package: ', aClassRemovedAnnouncement categoryName printString).

		classRemoved name: aClassRemovedAnnouncement classRemoved originalName.
		classRemoved category: aClassRemovedAnnouncement categoryName.
		classRemoved package: aClassRemovedAnnouncement packageAffected name.

		(aClassRemovedAnnouncement classRemoved methods, aClassRemovedAnnouncement classRemoved classSide methods) 
			do: [:each | self behaviorRemovedImpliesMethodRemoved: each defaultPackageName: classRemoved package ].

		aClassRemovedAnnouncement classAffected isTrait
			ifTrue:  [ self traitRemoved: classRemoved ]
			ifFalse: [ self classRemoved: classRemoved ] ]! !

!EpMonitor methodsFor: 'accessing' stamp: ''!
log
	^ log! !

!EpMonitor methodsFor: 'testing' stamp: ''!
isEnabled
	^ systemAnnouncer hasSubscriber: self! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
traitAdded: aClassAddedAnnouncement

	self addEvent: (EpTraitAddition trait: aClassAddedAnnouncement classAdded)! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
classAdded: aClassAddedAnnouncement

	self addEvent: (EpClassAddition class: aClassAddedAnnouncement classAdded)! !

!EpMonitor methodsFor: 'private' stamp: ''!
subscribeToSystemAnnouncer

	{	CategoryAdded -> #categoryAdded:. 
		CategoryRemoved -> #categoryRemoved:.
		CategoryRenamed -> #categoryRenamed:.
		ClassAdded-> #behaviorAdded:.
		ClassRemoved->#behaviorRemoved:.
		MethodAdded -> #methodAdded:.
		MethodRemoved -> #methodRemoved:.
		ProtocolAdded -> #protocolAdded:.
		ProtocolRemoved -> #protocolRemoved:.
		ClassModifiedClassDefinition -> #behaviorModified:.
		MethodModified -> #methodModified:.
		ClassRecategorized -> #classRecategorized:.
		ClassRenamed -> #classRenamed:.
		ClassCommented -> #classCommented:.
		MethodRecategorized -> #methodRecategorized:.
		
	} do: [ :pair |
		systemAnnouncer weak
			when: pair key 
			send: pair value 
			to: self ].! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
jobEnded: aJobEnd

	| aJob |
	aJob := aJobEnd job.

	"We only care in these cases"
	aJob owner isEpiceaInterestingJobOwner ifFalse: [ ^ self ].

	entryReferenceByEvent
		removeKey: aJob
		ifAbsent: [ "Should not happen, but we do not care :)" ]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
classRemoved: classRemoved

	self addEvent: (EpClassRemoval class: classRemoved)! !

!EpMonitor methodsFor: 'private' stamp: ''!
addEvent: anEvent newEntryDo: aBlock

	self 
		addEvent: anEvent
		newEntryDo: aBlock
		triggerReference: self currentTriggerReference! !

!EpMonitor methodsFor: 'enabling' stamp: ''!
enabled: aBoolean

	aBoolean 
		ifTrue: [ self enable ]
		ifFalse: [ self disable ]! !

!EpMonitor methodsFor: 'private' stamp: ''!
handleError: error

	self debugMode 
		ifTrue: [ error pass ]
		ifFalse: [ 'EpMonitor could not log a change. You can enable debugging with "EpMonitor current debugMode: true".' traceCr ]! !

!EpMonitor methodsFor: 'private' stamp: ''!
subscribeToJobAnnouncer

	{	JobStart -> #jobStarted:.
		JobEnd -> #jobEnded:.
	} do: [ :pair |
		jobAnnouncer
			when: pair key 
			send: pair value 
			to: self ].! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
classRenamed: aClassRenamed

	self handleAnyErrorDuring: [
		self addEvent: (EpBehaviorNameChange
			oldName: aClassRenamed oldName
			newName: aClassRenamed  newName
			class: aClassRenamed classAffected) ]! !

!EpMonitor methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer ifNil: [ announcer := Announcer new ]! !

!EpMonitor methodsFor: 'accessing' stamp: ''!
writingDeferDuration

	^ self sessionStore writingDeferDuration! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
traitModified: aClassModifiedClassDefinitionAnnouncement

	^ EpTraitModification
		oldTrait: aClassModifiedClassDefinitionAnnouncement oldClassDefinition
		newTrait: aClassModifiedClassDefinitionAnnouncement newClassDefinition! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
sessionSnapshot
	self addEvent: EpSessionSnapshot new! !

!EpMonitor methodsFor: 'private' stamp: ''!
author
	^ Author uniqueInstance 
		ifUnknownAuthorUse: 'Unknown' 
		during: [ Author uniqueInstance fullName ]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
categoryRemoved: aPackageCategoryRemoved

	self handleAnyErrorDuring:[
		self addEvent: (EpCategoryRemoval named: aPackageCategoryRemoved categoryName) ]! !

!EpMonitor methodsFor: 'enabling' stamp: ''!
disable

	self sessionStore flush.

	{ systemAnnouncer. jobAnnouncer }
		do: [ :each | each ifNotNil: [ :a | a unsubscribe: self ] ].

	self announceMonitorStateUpdated.! !

!EpMonitor methodsFor: 'private' stamp: ''!
time
	^ DateAndTime now! !

!EpMonitor methodsFor: '*EpiceaBrowsers' stamp: ''!
statusIcon
	^ self isEnabled
		ifTrue: [ #testGreen ]
		ifFalse: [ #testNotRun ]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
methodModified: aMethodModified

	self handleAnyErrorDuring: [
		(aMethodModified oldMethod sourceCode = aMethodModified newMethod sourceCode 
			and: [ aMethodModified oldProtocol = aMethodModified newProtocol ])
			ifTrue: [ ^self ].
			
		self addEvent: 
			(EpMethodModification
				oldMethod: aMethodModified oldMethod
				newMethod: aMethodModified newMethod) ]! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
methodRemoved: aMethodRemovedAnnouncement
	"RPackage already unregistered the method so we have to workaround protocol and package."

	self handleAnyErrorDuring: [
		self addEvent: 
			(EpMethodRemoval method: 
				(aMethodRemovedAnnouncement methodAffected asEpiceaRingDefinition
					protocol: aMethodRemovedAnnouncement protocol;
					package: (RPackageOrganizer default 
						packageForProtocol: aMethodRemovedAnnouncement protocol 
						inClass: aMethodRemovedAnnouncement methodAffected methodClass) name;
					yourself))]! !

!EpMonitor methodsFor: '*EpiceaBrowsers' stamp: ''!
statusString
	^ self isEnabled
		ifTrue: [ 'Monitor enabled' ]
		ifFalse: [ 'Monitor disabled' ]! !

!EpMonitor methodsFor: 'accessing' stamp: ''!
sessionStore

	^ self log store! !

!EpMonitor methodsFor: 'announcement handling' stamp: ''!
behaviorRemovedImpliesMethodRemoved: aMethodInAnObsoleteBehavior defaultPackageName: aSymbol
	| packageName |
	packageName := (RPackageOrganizer default 
		packageForProtocol: aMethodInAnObsoleteBehavior protocol 
		inClass: aMethodInAnObsoleteBehavior methodClass) name.

	"If the method is local, (belongs to the class being removed) then the package was wrong,  and we fix it"
	packageName = RPackage defaultPackageName 
		ifTrue: [ packageName := aSymbol ].
		
	self addEvent: 
		(EpMethodRemoval method: 
			(aMethodInAnObsoleteBehavior asEpiceaRingDefinition
				parentName: aMethodInAnObsoleteBehavior methodClass originalName;
				protocol: aMethodInAnObsoleteBehavior protocol;
				package: packageName;
				yourself))! !

!EpMonitor methodsFor: 'enabling' stamp: ''!
disableDuring: aBlock
	"Disable all logging during the execution of a block.
	
	Example:
		EpMonitor current disableDuring: [ self generateApplicationTemplate ]"

	| currentStatus |
	currentStatus := self isEnabled.
	self disable.
	[ aBlock value ]
		ensure: [ self enabled: currentStatus ]! !

!EpMonitor class methodsFor: 'instance creation' stamp: ''!
new

	^ self newWithLog: EpLog newWithSessionStore! !

!EpMonitor class methodsFor: 'testing' stamp: ''!
hasCurrent
	"Answer if there is an instance of this class that is #current (without creating the instance if one not already exists)."

	^ current isNotNil! !

!EpMonitor class methodsFor: 'accessing' stamp: ''!
current

	current ifNil: [
		current := self new ].
	
	^ current! !

!EpMonitor class methodsFor: 'accessing' stamp: ''!
current: aMonitor

	current := aMonitor! !

!EpMonitor class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default registerToolClassNamed: self name! !

!EpMonitor class methodsFor: 'system startup' stamp: ''!
shutDown: isImageQuitting
	(isImageQuitting not
		and: [ self hasCurrent
		and: [ self current isEnabled ] ])
			ifTrue: [
				self current sessionSnapshot.
				self current sessionStore flush. ]! !

!EpMonitor class methodsFor: 'accessing' stamp: ''!
logsDirectory
	self flag: #pharoFixMe.	"The base locator could have a wrong fileSystem"
	^ self current sessionStore baseLocator asFileReference! !

!EpMonitor class methodsFor: 'instance creation' stamp: ''!
newWithLog: aLog

	^ self basicNew 
		initializeWithLog: aLog;
		yourself! !

!EpMonitor class methodsFor: 'initialization' stamp: ''!
restart
	"
	self restart
	"

	self reset.
	self current enable.! !

!EpMonitor class methodsFor: 'class initialization' stamp: ''!
reset
	"
	self reset
	"

	self hasCurrent ifTrue: [ 
		self current disable.
		self current: nil ]! !

!EpMonitor class methodsFor: 'enabling' stamp: ''!
disableDuring: aBlock
	"Disable the default monitor during the execution of a block"
	
	self current disableDuring: aBlock! !

!EpMonitorIntegrationTest commentStamp: ''!
I test EpMonitor integration (either enabled or disabled).!
!EpMonitorIntegrationTest methodsFor: 'running' stamp: ''!
tearDown

	monitor disable.	
	classFactory cleanUp.
	logBuilder cleanUp.

	super tearDown.! !

!EpMonitorIntegrationTest methodsFor: 'running' stamp: ''!
allLogEntriesWith: aClass
	
	^ monitor log entries select: [ :each | each content class = aClass ]! !

!EpMonitorIntegrationTest methodsFor: 'running' stamp: ''!
countLogEventsWith: aClass

	^ (self allLogEntriesWith: aClass) size! !

!EpMonitorIntegrationTest methodsFor: 'running' stamp: ''!
allLogEventsWith: aClass

	^ (self allLogEntriesWith: aClass) collect: [:each | each content]! !

!EpMonitorIntegrationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	logBuilder := EpTestLogBuilder new
		useLogWithSessionStore;
		yourself.
	classFactory := ClassFactoryForTestCase new.
	monitor := EpMonitor newWithLog: logBuilder log.! !

!EpMonitorLogNode commentStamp: ''!
I am a node in a tree of Epicea logs that represent the EpMonitor current log. Read more in my superclass comment.!
!EpMonitorLogNode methodsFor: 'accessing' stamp: ''!
modificationTime

	^ DateAndTime now! !

!EpMonitorLogNode methodsFor: 'accessing' stamp: ''!
modificationTimeString

	^ '*'! !

!EpMonitorLogNode methodsFor: 'accessing' stamp: ''!
log
	^ theLog! !

!EpMonitorLogNode methodsFor: 'testing' stamp: ''!
isMonitor

	^ true! !

!EpMonitorLogNode methodsFor: 'accessing' stamp: ''!
headReference: anObject
	headReference := anObject! !

!EpMonitorLogNode methodsFor: 'accessing' stamp: ''!
theLog: anObject
	theLog := anObject! !

!EpMonitorLogNode methodsFor: 'accessing' stamp: ''!
headReference
	^ headReference! !

!EpMonitorLogNode methodsFor: 'accessing' stamp: ''!
globalName

	^ theLog store globalName! !

!EpMonitorLogNode methodsFor: 'accessing' stamp: ''!
referencedGlobalNamesIfEmptyLog

	^ headReference isNull
		ifTrue: [ #() ] 
		ifFalse: [ { headReference globalName } ]! !

!EpMonitorLogNode methodsFor: 'accessing' stamp: ''!
theLog
	^ theLog! !

!EpMonitorLogNode class methodsFor: 'instance creation' stamp: ''!
for: anEpMonitor
	self flag: #pharoFixMe.	"note: this is a workaround given this information is needed to build the references graph, but it's not available from 'theLog' when it's empty"

	^ self new
		theLog: anEpMonitor basicLog;
		headReference: anEpMonitor log headReference;
		yourself! !

!EpMonitorStateUpdated commentStamp: ''!
The execution of either EpMonitor>>#enable or #disable will result in the announcement of one of my instances.!
!EpMonticelloVersionSave commentStamp: ''!
I represent a Monticello "Save Version" operation performed in the system.!
!EpMonticelloVersionSave methodsFor: 'accessing' stamp: ''!
versionName
	^ versionName! !

!EpMonticelloVersionSave methodsFor: 'comparing' stamp: ''!
= another

	^ self class = another class
		and: [ self versionName = another versionName
		and: [ self repositoryDescription = another repositoryDescription ] ]! !

!EpMonticelloVersionSave methodsFor: 'comparing' stamp: ''!
hash

	^ (self class hash
		bitXor: self versionName hash)
		bitXor: self repositoryDescription hash! !

!EpMonticelloVersionSave methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	
	aStream 
		nextPut: $(;
		nextPutAll: repositoryDescription;
		nextPut: $/;
		nextPutAll: versionName;
		nextPut: $).! !

!EpMonticelloVersionSave methodsFor: 'initialization' stamp: ''!
initializeWithVersionName: aVersionName repositoryDescription: aRepositoryDescription 
	self initialize.
	
	versionName := aVersionName.
	repositoryDescription := aRepositoryDescription.! !

!EpMonticelloVersionSave methodsFor: 'accessing' stamp: ''!
packageName

	^ versionName copyUpToLast: $-! !

!EpMonticelloVersionSave methodsFor: 'testing' stamp: ''!
isMonticelloVersionSave

	^ true! !

!EpMonticelloVersionSave methodsFor: 'accessing' stamp: ''!
repositoryDescription
	^ repositoryDescription! !

!EpMonticelloVersionSave methodsFor: 'accessing' stamp: ''!
affectedPackageName
	
	^ self packageName! !

!EpMonticelloVersionSave methodsFor: 'visitor' stamp: ''!
accept: aChangeVisitor 
	^ aChangeVisitor visitMonticelloVersionSave: self! !

!EpMonticelloVersionSave class methodsFor: 'instance creation' stamp: ''!
version: aMCVersion repository: aMCRepository 
	^ self 
		versionName: aMCVersion info name 
		repositoryDescription: aMCRepository description! !

!EpMonticelloVersionSave class methodsFor: 'instance creation' stamp: ''!
versionName: aVersionName repositoryDescription: aRepositoryDescription 
	^ self basicNew
		initializeWithVersionName: aVersionName
		repositoryDescription: aRepositoryDescription;
		yourself! !

!EpMonticelloVersionsLoad commentStamp: ''!
I represent a Monticello "Load Versions" operation performed in the system.!
!EpMonticelloVersionsLoad methodsFor: 'comparing' stamp: ''!
= anObject

	^ (self class = anObject class)
		and: [ self versionNames = anObject versionNames ]! !

!EpMonticelloVersionsLoad methodsFor: 'comparing' stamp: ''!
hash

	^ self class hash
		bitXor: self versionNames hash! !

!EpMonticelloVersionsLoad methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	versionNames printElementsOn: aStream.! !

!EpMonticelloVersionsLoad methodsFor: 'initializing' stamp: ''!
initializeWith: aCollectionOfVersionNames
	self initialize.
	versionNames := aCollectionOfVersionNames! !

!EpMonticelloVersionsLoad methodsFor: 'accessing' stamp: ''!
packageNames

	^ versionNames collect: [ :each | each copyUpToLast: $- ]! !

!EpMonticelloVersionsLoad methodsFor: 'accessing' stamp: ''!
versionNames
	^ versionNames! !

!EpMonticelloVersionsLoad methodsFor: 'testing' stamp: ''!
isMonticelloVersionsLoad

	^ true! !

!EpMonticelloVersionsLoad methodsFor: 'accessing' stamp: ''!
affectedPackageName
	self flag: #pharoFixMe.	"FIX: imprecise answer"

	^ self packageNames first! !

!EpMonticelloVersionsLoad methodsFor: 'visitor' stamp: ''!
accept: aChangeVisitor 
	^ aChangeVisitor visitMonticelloVersionsLoad: self! !

!EpMonticelloVersionsLoad class methodsFor: 'instance creation' stamp: ''!
versions: aCollectionOfVersions 

	^ self versionNames: (aCollectionOfVersions collect: [ :version | version info name ])! !

!EpMonticelloVersionsLoad class methodsFor: 'instance creation' stamp: ''!
versionNames: aCollectionOfVersionNames

	^ self basicNew
		initializeWith: aCollectionOfVersionNames;
		yourself! !

!EpMorphFactory commentStamp: ''!
I provide convenience methods to create morphs.!
!EpMorphFactory methodsFor: 'generic' stamp: ''!
rowWithAll: someMophs

	^ Morph new
		changeTableLayout;
		color: Color transparent;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		listDirection: #leftToRight;
		cellInset: 2;
		addAllMorphs: someMophs;
		yourself! !

!EpMorphFactory methodsFor: 'generic' stamp: ''!
smallGap

	^ self wrapping: ''! !

!EpMorphFactory methodsFor: 'colors' stamp: ''!
secondaryTextColor

	^ Smalltalk ui theme caretColor mixed: 0.5 with: Color gray! !

!EpMorphFactory methodsFor: 'colors' stamp: ''!
softerTextColor

	^ self textColor mixed: 0.1 with: Color gray! !

!EpMorphFactory methodsFor: 'strings' stamp: ''!
emphasizedStringFor: aString

	| morph |
	morph := aString asMorph
		emphasis: 1;
		yourself.

	"Hack: emphazised string has 3 blank pixels at the end"
	morph width: (morph width - 3). "pffff"
		
	^ morph! !

!EpMorphFactory methodsFor: 'colors' stamp: ''!
textColor

	^ Smalltalk ui theme textColor! !

!EpMorphFactory methodsFor: 'strings' stamp: ''!
secondaryStringFor: aString

	^ self stringFor: aString color: self secondaryTextColor! !

!EpMorphFactory methodsFor: 'strings' stamp: ''!
wrapping: aMorphOrString

	^ Morph new
		changeTableLayout;
		color: Color transparent;
		addMorphBack: aMorphOrString asMorph;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		layoutInset: 2@0;
		yourself! !

!EpMorphFactory methodsFor: 'generic' stamp: ''!
semiTransparent: aForm 

	^ AlphaImageMorph new 
		image: aForm; 
		alpha: 0.5; 
		yourself! !

!EpMorphFactory methodsFor: 'strings' stamp: ''!
stringFor: aString color: aColor

	^ aString asMorph
		color: aColor;
		yourself! !

!EpMorphFactory methodsFor: 'strings' stamp: ''!
pillWith: aString 
	
	^ (self wrapping: aString)
		borderWidth: 1;
		borderColor: (self textColor alpha: 0.5);
		useRoundedCorners;
		yourself! !

!EpMorphFactory class methodsFor: 'accessing' stamp: ''!
default
	^ defaultInstance ifNil: [ defaultInstance := self new ]! !

!EpMorphVisitor commentStamp: ''!
I answer a morph for each EpEvent.!
!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aClassRecategorizationChange

	^	(self displayOperation: 'Move'),
		(self displayBehavior: aClassRecategorizationChange behaviorAffectedName), 
		(self displayOperation: 'from tag'),
		(self displayString: aClassRecategorizationChange oldCategory), 
		(self displayOperation: 'to'), 
		(self displayString: aClassRecategorizationChange newCategory)! !

!EpMorphVisitor methodsFor: 'private' stamp: ''!
displayBrowserOperation: aBrowserOperationEvent

	^ self displayOperation: (
		String streamContents: [ :stream |
			stream nextPutAll: aBrowserOperationEvent title ])! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitSessionStart: anEvent

	^ (self displayOperation: 'Start:'), 
		(self displayString: anEvent imageName)! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitRedo: aRedoEvent

	^ self displayBrowserOperation: aRedoEvent! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitRefactoring: aRefactoring 

	^  (self displayOperation: 'Refactoring: '), 
		(self displayString: (String streamContents: [ :aStream | 
			aRefactoring summaryOn: aStream ]))! !

!EpMorphVisitor methodsFor: 'private' stamp: ''!
displayCategory: aCategoryName

	^ (self displayOperation: 'Package tag'), (self displayString: aCategoryName asString)! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitMonticelloVersionsLoad: aMonticelloVersionLoaded 

	^	(self displayOperation: 'MC load'), 
		(self displayString: aMonticelloVersionLoaded versionNames asCommaStringAnd)! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitSessionSnapshot: anEvent

	^ (self displayOperation: 'Snapshot:'), 
		(self displayString: anEvent imageName)! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aClassRenamedChange

	^	(self displayOperation: 'Rename'), 
		(self displayBehavior: aClassRenamedChange oldName), 
		(self displayOperation: 'as'), 
		(self displayString: aClassRenamedChange newName)! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aCategoryChange

	^ self displayCategory: aCategoryChange categoryName! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aProtocolChange

	^ self 
		displayClass: aProtocolChange behaviorAffectedName
		protocol: aProtocolChange protocol asString! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitUndo: anUndoEvent

	^ self displayBrowserOperation: anUndoEvent! !

!EpMorphVisitor methodsFor: 'private' stamp: ''!
displayString: aString color: aColor

	^ { self morphFactory stringFor: aString color: aColor }! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitEvent: anEvent

	^ self displayString: ''! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange

	^ self displayBehaviorComment: aChange behaviorAffectedName! !

!EpMorphVisitor methodsFor: 'private' stamp: ''!
displayBehaviorComment: aClassName

	^ (self displayBehavior: aClassName), (self displayOperation: 'comment')! !

!EpMorphVisitor methodsFor: 'private' stamp: ''!
displayClass: aClassName protocol: aProtocolName

	^ (self displayBehavior: aClassName), (self displayOperation: 'protocol'), (self displayString: aProtocolName)! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCopy: aClassCopy

	^ (self displayBehavior: aClassCopy definition name), (self displayOperation: 'copyNamed:'), (self displayBehavior: '#', aClassCopy newName)! !

!EpMorphVisitor methodsFor: 'private' stamp: ''!
displayBehavior: aString 

	^ { self morphFactory emphasizedStringFor: aString }! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitSessionEnd: anEvent

	^ (self displayOperation: 'End:'), 
		(self displayString: anEvent imageName)! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitClassChange: aChange

	^ self displayBehavior: aChange behaviorAffectedName! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitTraitChange: aChange

	^ self displayBehavior: aChange behaviorAffectedName! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aMethodRemoved

	^ self 
		displayBehavior: aMethodRemoved behaviorAffectedName
		method: aMethodRemoved methodRemoved selector! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitLogCommentModification: aLogCommentModification 

	^ self displayString: aLogCommentModification comment printString! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aMethodCreatedChange

	^ self 
		displayBehavior: aMethodCreatedChange behaviorAffectedName
		method: aMethodCreatedChange methodAdded selector! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aCategoryChange

	^	(self displayOperation: 'Rename tag'),
		(self displayString: aCategoryChange oldCategoryName),
		(self displayOperation: 'as'),
		(self displayString: aCategoryChange newCategoryName )! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aCategoryChange

	^ self displayCategory: aCategoryChange categoryName! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aMethodModified

	^ self 
		displayBehavior: aMethodModified behaviorAffectedName
		method: aMethodModified oldMethod selector! !

!EpMorphVisitor methodsFor: 'private' stamp: ''!
displayBehavior: aClassName method: aSelector

	^ (self displayBehavior: aClassName), (self displayOperation: '»'), (self displayString: aSelector)! !

!EpMorphVisitor methodsFor: 'private' stamp: ''!
displayString: aString

	^ { aString asMorph }! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitExpressionEvaluation: anExpressionEvaluation

	^ (self displayOperation: 'DoIt:'), (self displayString:
		(anExpressionEvaluation expression printStringLimitedTo: 50) 
			withSeparatorsCompacted)! !

!EpMorphVisitor methodsFor: 'private' stamp: ''!
displayOperation: aString 

	^ self 
		displayString: aString 
		color: self morphFactory softerTextColor! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aProtocolChange

	^ self 
		displayClass: aProtocolChange behaviorAffectedName
		protocol: aProtocolChange protocol asString! !

!EpMorphVisitor methodsFor: 'visitor' stamp: ''!
visitMonticelloVersionSave: aChange

	^	(self displayOperation: 'MC save'), 
		(self displayString: aChange versionName asString), 
		(self displayOperation: 'on'), 
		(self displayString: aChange repositoryDescription asString)! !

!EpMorphVisitor methodsFor: 'private' stamp: ''!
morphFactory

	^ EpMorphFactory default! !

!EpNewStateVisitor commentStamp: ''!
I answer a String that represents the new state of an EpEvent.!
!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aRecategorizationChange

	^ aRecategorizationChange newCategory! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitClassAddition: aClassCreatedChange

	^ self stringForBehavior: aClassCreatedChange classAdded! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aClassCategoryRenamedChange

	^ aClassCategoryRenamedChange newCategoryName! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitLogCommentModification: anEvent 
	^ anEvent newComment! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aMethodCreatedChange
	^ self 
		printProtocol: aMethodCreatedChange protocol
		sourceCode: aMethodCreatedChange sourceCode! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitRedo: aRedoEvent

	^ self displayBrowserOperation: aRedoEvent! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aClassCategoryCreatedChange

	^ aClassCategoryCreatedChange categoryName! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aMethodModification

	^ self 
		printProtocol: aMethodModification newProtocol
		sourceCode: aMethodModification newSourceCode! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aClassRenameChange

	^ aClassRenameChange newName! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aProtocolAddition

	^ aProtocolAddition protocol! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aTraitCreation

	^ self stringForBehavior: aTraitCreation traitAdded! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange

	^ aChange newComment asString! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aTraitModificationChange

	^ self stringForBehavior: aTraitModificationChange newTrait! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitExpressionEvaluation: anExpressionEvaluation

	^ anExpressionEvaluation expression! !

!EpNewStateVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aModificationClassChange

	^ self stringForBehavior: aModificationClassChange newClass! !

!EpOldStateVisitor commentStamp: ''!
I answer a String that represents the old state of an EpEvent.!
!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aRecategorizationChange

	^ aRecategorizationChange oldCategory! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitLogCommentModification: anEvent

	^ anEvent oldComment! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aClassCategoryRenamedChange

	^ aClassCategoryRenamedChange oldCategoryName! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aMethodModification

	^ self 
		printProtocol: aMethodModification oldProtocol  
		sourceCode: aMethodModification oldSourceCode! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aClassRenameChange

	^ aClassRenameChange oldName! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aClassCategoryRemovedChange

	^ aClassCategoryRemovedChange categoryName! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange

	^ aChange oldComment asString! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aTraitModificationChange

	^ self stringForBehavior: aTraitModificationChange oldTrait! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoval:  aTraitRemoval

	^ self stringForBehavior: aTraitRemoval traitRemoved! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitUndo: anUndoEvent

	^ self displayBrowserOperation: anUndoEvent! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aClassRemovalChange

	^ self stringForBehavior: aClassRemovalChange classRemoved! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aMethodRemoval

	^ self 
		printProtocol: aMethodRemoval protocol
		sourceCode: aMethodRemoval sourceCode! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aProtocolRemoval

	^ aProtocolRemoval protocol! !

!EpOldStateVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aModificationClassChange

	^ self stringForBehavior: aModificationClassChange oldClass! !

!EpOmbuExporter commentStamp: ''!
I know how to export Epicea entries from one log to a new one.!
!EpOmbuExporter methodsFor: 'accessing' stamp: ''!
outputLog: anObject
	outputLog := anObject! !

!EpOmbuExporter methodsFor: 'accessing' stamp: ''!
outputLog
	^ outputLog! !

!EpOmbuExporter methodsFor: 'tests' stamp: ''!
fileOut: epiceaEntries

	| originalReference anEvent exportedReference visitor map |	
	map := Dictionary new.
	visitor := EpReferenceFixerVisitor newWithMap: map.
	
	epiceaEntries do: [ :anEntry | 
		originalReference := (anEntry tagAt: OmStore selfReferenceKey).

		anEvent := anEntry content accept: visitor.
		
		exportedReference := outputLog addEntryWith: anEvent tags: [ :tags |  ].
		
		map at: originalReference put: exportedReference.
		].
	
	outputLog store flush.! !

!EpOmbuExporter class methodsFor: 'convenience' stamp: ''!
askFileNameAndFileOut: entries in: aDirectory

	| fileNameOrNil outputLog |
	fileNameOrNil := UIManager default
		request: 'Enter a file name (without extension)'
		initialAnswer: 'FileOut_', (UUID new asString36 first: 3).

	fileNameOrNil ifNil: [ ^ self ].

	(OmFileStore existsStoreNamed: fileNameOrNil inDirectory: aDirectory)
		ifTrue: [ ^ self inform: 'File already exists' ].

	outputLog := EpLog newWithStore: 
		(OmStoreFactory current named: fileNameOrNil inDirectory: aDirectory).

	self new 
		outputLog: outputLog;
		fileOut: entries.! !

!EpOmbuExporterTest methodsFor: 'tests' stamp: ''!
testBasicExport

	| selection outputResult |
	selection := inputLog1 entries.
	
	EpOmbuExporter new 
		outputLog: outputLog;
		fileOut: selection.
	
	outputResult := outputLog events.
	
	self assert: outputResult size equals: selection size.
	self 
		assert: outputResult asSet 
		equals: (selection collect: [ :each | each content ]) asSet! !

!EpOmbuExporterTest methodsFor: 'running' stamp: ''!
tearDown
	
	logBuilder1 cleanUp.
	logBuilder2 cleanUp.
	super tearDown.! !

!EpOmbuExporterTest methodsFor: 'tests' stamp: ''!
testRoundtrip

	| outputLogReopened |
	EpOmbuExporter new 
		outputLog: outputLog;
		fileOut: inputLog1 entries.

	"Open a fresh log with the exported entries. 
	(fresh, to be sure it was correctly written to disk)"
	outputLogReopened := EpLog newWithStore: outputLog store flush copyReopened refresh.

	self
		assert: outputLogReopened entries size
		equals: inputLog1 entries size! !

!EpOmbuExporterTest methodsFor: 'tests' stamp: ''!
testCommentExportWithDependencyFix
	| selection oldComment newComment |
	oldComment := nil.
	selection := inputLog2 entries.

	inputLog2 store entriesDo: [ :entry | entry content isEpLogEntriesComment ifTrue: [ oldComment := entry ] ].

	EpOmbuExporter new
		outputLog: outputLog;
		fileOut: selection.

	self assert: outputLog entries size equals: selection size.

	outputLog store entriesDo: [ :entry | entry content isEpLogEntriesComment ifTrue: [ newComment := entry ] ].

	self deny: (oldComment tagAt: EpLog priorReferenceKey) equals: (newComment tagAt: EpLog priorReferenceKey).
	self deny: (oldComment tagAt: OmStore selfReferenceKey) equals: (newComment tagAt: OmStore selfReferenceKey).
	self deny: oldComment content entryReferences equals: newComment content entryReferences! !

!EpOmbuExporterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.

	logBuilder1 := EpTestLogBuilder new.
	logBuilder2 := EpTestLogBuilder new.

	"Create 2 logs in different directories"
	inputLog1 := logBuilder1 oneTriggerWithFourChildrenLog.
	inputLog2 := logBuilder2 oneTriggerWithOneChildLog.

	outputDirectory := logBuilder2 directory.
	outputLog := EpLog
		newWithStore: (OmFileStore named: 'exported' inDirectory: outputDirectory)! !

!EpOmbuFileReaderService commentStamp: ''!
I implement a service for browsing Epicea logs.!
!EpOmbuFileReaderService class methodsFor: 'System-FileRegistry' stamp: ''!
fileReaderServicesForFile: fullName suffix: suffix
	<fileService>

	(fullName endsWith: self fileSuffix)
		ifFalse: [ ^ #() ].

	^ { self service }! !

!EpOmbuFileReaderService class methodsFor: 'System-FileRegistry' stamp: ''!
service
	^ SimpleServiceEntry 
		provider: self 
		label: 'Browse Epicea Log'
		selector: #browseLogInFileNamed:
		description: 'Browse the Epicea log.'
		buttonLabel: 'Browse Epicea Log'! !

!EpOmbuFileReaderService class methodsFor: 'private' stamp: ''!
browseLogInFileNamed: fileName
	(EpLog freshFromFile: fileName asFileReference) browseEvents! !

!EpOmbuFileReaderService class methodsFor: 'private' stamp: ''!
fileSuffix
	^ OmFileStore defaultFileSuffix! !

!EpOrFilter commentStamp: ''!
My instances decide if an OmEntry is accepted applying an "or" logic operation with sub filters.!
!EpOrFilter methodsFor: 'comparing' stamp: ''!
= other 
	^ self class = other class and: [ self subFilters = other subFilters ]! !

!EpOrFilter methodsFor: 'comparing' stamp: ''!
hash
	^ self class hash bitXor: self subFilters hash! !

!EpOrFilter methodsFor: 'accessing' stamp: ''!
subFilters
	^ subFilters! !

!EpOrFilter methodsFor: 'filtering' stamp: ''!
accepts: anEntry
	^ self subFilters anySatisfy: [ :aFilter | aFilter accepts: anEntry ]! !

!EpOrFilter methodsFor: 'accessing' stamp: ''!
subFilters: aCollectionOfFilters
	subFilters := aCollectionOfFilters! !

!EpOrFilter class methodsFor: 'instance creation' stamp: ''!
withAll: aCollection 
	^ self new 
		subFilters: aCollection;
		yourself! !

!EpPlatform commentStamp: ''!
My API has methods whose implementation might depend on the Pharo image version.!
!EpPlatform methodsFor: 'convenience' stamp: ''!
packageNameFor: aClassOrTrait

	^ (RPackage organizer packageOfClassNamed: aClassOrTrait name)
		ifNotNil: [ :package | package name ]
		ifNil: [ 'nil' ]! !

!EpPlatform class methodsFor: 'accessing' stamp: ''!
current

	^ current ifNil: [ current := self new ]! !

!EpPluggableFilter commentStamp: ''!
My instances decide if an OmEntry is accepted applying a pluggable block closure.!
!EpPluggableFilter methodsFor: 'accessing' stamp: ''!
condition
	^ condition! !

!EpPluggableFilter methodsFor: 'comparing' stamp: ''!
= other

	^ self class = other class and: [ self title = other title ]! !

!EpPluggableFilter methodsFor: 'comparing' stamp: ''!
hash
	^ self class hash bitXor: self title hash! !

!EpPluggableFilter methodsFor: 'accessing' stamp: ''!
title: aString 
	title := aString! !

!EpPluggableFilter methodsFor: 'accessing' stamp: ''!
condition: aBlockClosure 
	condition := aBlockClosure! !

!EpPluggableFilter methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream 
		nextPut: $(;
		nextPutAll: self title;
		nextPut: $)! !

!EpPluggableFilter methodsFor: 'filtering' stamp: ''!
accepts: anEntry
	^ self condition value: anEntry! !

!EpPluggableFilter methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!EpPluggableFilter class methodsFor: 'special filters' stamp: ''!
todayFilter
	^ self
		title: 'today'
		condition: [ :e | DateAndTime today < (e tags at: EpLog timeKey ifAbsent: [ DateAndTime epoch ])  ]! !

!EpPluggableFilter class methodsFor: 'well-known filters' stamp: ''!
noTriggerFilter
	^ self
		title: 'Hide non-manual changes (e.g. changes produced by Monticello)'
		condition: [ :e | 
			e content isCodeChange and: [
			(e tags includesKey: EpLog triggererReferenceKey) not ] ]! !

!EpPluggableFilter class methodsFor: 'well-known filters' stamp: ''!
codeChangeFilter
	^ self
		title: 'Show only code changes'
		condition: [ :e | e content isCodeChange ]! !

!EpPluggableFilter class methodsFor: 'special filters' stamp: ''!
after: aDateAndTime

	^ self
		title: 'after ', aDateAndTime printString
		condition: [ :e | (e tags at: EpLog timeKey) > aDateAndTime ]! !

!EpPluggableFilter class methodsFor: 'well-known filters' stamp: ''!
methodFilter
	^ self
		title: 'Show only changes to methods'
		condition: [ :e | e content isEpMethodChange ]! !

!EpPluggableFilter class methodsFor: 'special filters' stamp: ''!
before: aDateAndTime

	^ self
		title: 'before ', aDateAndTime printString
		condition: [ :e | (e tags at: EpLog timeKey) < aDateAndTime ]! !

!EpPluggableFilter class methodsFor: 'instance creation' stamp: ''!
title: aString condition: aBlockClosure 
	^ self new
		title: aString;
		condition: aBlockClosure;
		yourself! !

!EpPluggableFilter class methodsFor: 'accessing' stamp: ''!
allFilters
	^ self allFilterSelectors collect: [ :selector | self perform: selector ]! !

!EpPluggableFilter class methodsFor: 'special filters' stamp: ''!
isPackageNamed: packageName 

	^ self
		title: 'belongs to package named ', packageName
		condition: [ :e | 
			e content isCodeChange and: [ 
			e content affectedPackageName = packageName ] ]! !

!EpPluggableFilter class methodsFor: 'well-known filters' stamp: ''!
logBrowserOperationFilter
	^ self
		title: 'Show only apply, revert or comment events'
		condition: [ :e | e content isKindOf: EpLogBrowserOperation ]! !

!EpPluggableFilter class methodsFor: 'special filters' stamp: ''!
isMethod: aMethod

	^ self
		title: 'is ', aMethod printString
		condition: [ :e | 
			e content isEpMethodChange and: [ 
			e content behaviorAffectedName = aMethod parentName and: [ 
			e content methodAffectedSelector = aMethod selector ] ] ]! !

!EpPluggableFilter class methodsFor: 'accessing' stamp: ''!
allFilterSelectors
	^ self class allSelectorsInProtocol: #'well-known filters'! !

!EpPluggableFilter class methodsFor: 'special filters' stamp: ''!
isBehaviorNamed: aString

	| instanceSideBehaviorName |
	instanceSideBehaviorName := aString asInstanceSideBehaviorName.

	^ self
		title: 'is change to ', instanceSideBehaviorName
		condition: [ :entry |
			| event |
			event := entry content.
			(event isEpBehaviorChange or: [ event isEpMethodChange ]) and: [ 
			event behaviorAffectedName asInstanceSideBehaviorName = instanceSideBehaviorName ] ]! !

!EpPropagateRefactoring commentStamp: ''!
I represent a refactoring that consists in the propagation (i.e. the "redo") of another refactoring.!
!EpPropagateRefactoring methodsFor: 'accessing' stamp: ''!
targetRefactoring
	^ targetRefactoring! !

!EpPropagateRefactoring methodsFor: 'converting' stamp: ''!
asRBRefactoring
	^ EpRBPropagateRefactoring target: targetRefactoring asRBRefactoring! !

!EpPropagateRefactoring methodsFor: 'initialization' stamp: ''!
initializeWith: aTargetRefactoring
	self initialize.
	
	targetRefactoring := aTargetRefactoring.! !

!EpPropagateRefactoring methodsFor: '*EpiceaBrowsers' stamp: ''!
summaryOn: aWriteStream
	"Write a string summarizing myself."
	
	aWriteStream 
		nextPutAll: 'Propagate '.
		
	targetRefactoring summaryOn: aWriteStream! !

!EpPropagateRefactoring class methodsFor: 'instance creation' stamp: ''!
target: aTargetRefactoring
	^ self basicNew
		initializeWith: aTargetRefactoring;
		yourself! !

!EpProtocolAddition commentStamp: ''!
I represent the addition of a protocol of a class or a trait.!
!EpProtocolAddition methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitProtocolAddition: self! !

!EpProtocolChange commentStamp: ''!
I represent a change in the protocols of a class.!
!EpProtocolChange methodsFor: 'accessing' stamp: ''!
behaviorAffectedName

	^ behavior name! !

!EpProtocolChange methodsFor: 'testing' stamp: ''!
doesOverride: aCodeChange 

	^ aCodeChange isEpProtocolChange and: [
		aCodeChange behaviorAffectedName = self behaviorAffectedName and: [ 
		aCodeChange protocol = self protocol ] ]! !

!EpProtocolChange methodsFor: 'accessing' stamp: ''!
behaviorAffected
	^ behavior! !

!EpProtocolChange methodsFor: 'testing' stamp: ''!
isEpProtocolChange

	^ true! !

!EpProtocolChange methodsFor: 'accessing' stamp: ''!
protocol
	^ protocol! !

!EpProtocolChange methodsFor: 'initialize-release' stamp: ''!
initializeWithBehavior: aBehavior protocol: aProtocol
	self initialize.
	behavior := aBehavior asEpiceaRingDefinition.
	protocol := aProtocol asSymbol.! !

!EpProtocolChange class methodsFor: 'instance creation' stamp: ''!
behavior: aBehavior protocol: aProtocol 
	^ self basicNew 
		initializeWithBehavior: aBehavior
		protocol: aProtocol;
		yourself! !

!EpProtocolRemoval commentStamp: ''!
I represent the removal of a protocol of a class or a trait.!
!EpProtocolRemoval methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitProtocolRemoval: self! !

!EpRBPropagateRefactoring commentStamp: ''!
I am a RBRefactoring intended for prepagating another refactoring. We call to propagate a refactoring to redo just the secondary effects of such refactoring. 

For example, the propagation of a 'message rename' is to change the senders of the old selector to use the new selector. !
!EpRBPropagateRefactoring methodsFor: 'accessing' stamp: ''!
setOption: aString toUse: aBlockClosure 
	targetRefactoring setOption: aString toUse: aBlockClosure! !

!EpRBPropagateRefactoring methodsFor: 'converting' stamp: ''!
asEpiceaEvent
	^ EpPropagateRefactoring target: targetRefactoring asEpiceaEvent! !

!EpRBPropagateRefactoring methodsFor: 'initialization' stamp: ''!
initializeWith: aRefactoring 
	self initialize.
	targetRefactoring := aRefactoring! !

!EpRBPropagateRefactoring methodsFor: 'accessing' stamp: ''!
whatToDisplayIn: aNautilusChangesBrowser 
	^ targetRefactoring whatToDisplayIn: aNautilusChangesBrowser! !

!EpRBPropagateRefactoring methodsFor: 'private' stamp: ''!
primitiveExecute
	targetRefactoring propagateTransformation.! !

!EpRBPropagateRefactoring class methodsFor: 'instance creation' stamp: ''!
target: aRefactoring 
	^ self basicNew 
		initializeWith: aRefactoring;
		yourself! !

!EpRedo commentStamp: ''!
I represent a ReDo operation performed in a EpLogBrowser.!
!EpRedo methodsFor: 'copying' stamp: ''!
copyWithEntryReferences: aCollection
	^ self class forAll: aCollection! !

!EpRedo methodsFor: 'visitor' stamp: ''!
accept: aChangeVisitor
	^ aChangeVisitor visitRedo: self! !

!EpRedo methodsFor: 'accessing' stamp: ''!
title
	^ 'Apply changes'! !

!EpRedo class methodsFor: 'instance creation' stamp: ''!
forAll: aCollectionOfEntryReferences
	^ self basicNew
		initializeWith: aCollectionOfEntryReferences;
		yourself! !

!EpRefactoring commentStamp: ''!
I represent a refactoring performed in the system. !
!EpRefactoring methodsFor: 'testing' stamp: ''!
canBuildRBRefactoring
	^ false "should be true but this function is currently broken so let's not expose it to the users"! !

!EpRefactoring methodsFor: 'converting' stamp: ''!
asRBRefactoring
	"Answer the RBRefactoring corresponding to myself."
	
	^ self subclassResponsibility! !

!EpRefactoring methodsFor: '*EpiceaBrowsers' stamp: ''!
summaryOn: aWriteStream
	"Write a string summarizing myself."
	
	self subclassResponsibility! !

!EpRefactoring methodsFor: 'testing' stamp: ''!
isEpRefactoring

	^ true! !

!EpRefactoring methodsFor: 'visitor' stamp: ''!
accept: aChangeVisitor 
	^ aChangeVisitor visitRefactoring: self! !

!EpReferenceFixerVisitor commentStamp: ''!
I fix references from Epicea events to Epicea entries.!
!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitClassAddition: aChange
	^ self visitClassChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitMethodChange: aChange
	^ self visitCodeChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitRedo: aRedoEvent
	^ aRedoEvent copyWithEntryReferences: referencesMap values.! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitRefactoring: anEvent 
	^ self visitEvent: anEvent! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitMonticelloVersionsLoad: anEvent
	^ self visitEvent: anEvent! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitSessionSnapshot: anEvent
	^ self visitEvent: anEvent! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitMonticelloVersionSave: anEvent
	^ self visitEvent: anEvent! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aChange
	^ self visitCategoryChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aProtocolAddition
	^ self visitProtocolChange: aProtocolAddition! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aChange
	^ self visitClassChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitCodeChange: aChange
	"Default behavior for any change."
		
	^ self visitEvent: aChange! !

!EpReferenceFixerVisitor methodsFor: 'initialization' stamp: ''!
initializeWithMap: aReferencesMap

	self initialize.
	
	referencesMap := aReferencesMap! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aChange
	^ self visitTraitChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitEvent: anEvent
	"No transformation in the general case"
	
	^ anEvent! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aChange
	^ self visitTraitChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitTraitChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCopy: anEvent
	^ self visitEvent: anEvent! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitSessionEnd: anEvent
	^ self visitEvent: anEvent! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitClassChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aChange
	^ self visitMethodChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitLogCommentModification: anEvent 
	^ anEvent copyWithEntryReferences: referencesMap values.! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aChange
	^ self visitMethodChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aChange
	^ self visitCategoryChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryChange: aChange
	^ self visitCodeChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aChange
	^ self visitCategoryChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aChange
	^ self visitMethodChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorChange: aChange
	^ self visitCodeChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoval: aChange
	^ self visitTraitChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolChange: aProtocolAddition
	^ self visitBehaviorChange: aProtocolAddition.! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitUndo: anUndoEvent
	^ anUndoEvent copyWithEntryReferences: referencesMap values.! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitExpressionEvaluation: anExpressionEvaluation
	^ self visitEvent: anExpressionEvaluation! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitSessionStart: anEvent 
	^ self visitEvent: anEvent! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aChange
	^ self visitClassChange: aChange! !

!EpReferenceFixerVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aProtocolRemoved
	^ self visitProtocolChange: aProtocolRemoved! !

!EpReferenceFixerVisitor class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EpReferenceFixerVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EpReferenceFixerVisitor class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EpReferenceFixerVisitor class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EpReferenceFixerVisitor class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EpReferenceFixerVisitor class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EpReferenceFixerVisitor class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EpReferenceFixerVisitor class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EpReferenceFixerVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpReferenceFixerVisitor class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EpReferenceFixerVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EpReferenceFixerVisitor class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EpReferenceFixerVisitor class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EpReferenceFixerVisitor class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EpReferenceFixerVisitor class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EpReferenceFixerVisitor class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EpReferenceFixerVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EpReferenceFixerVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpReferenceFixerVisitor class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EpReferenceFixerVisitor class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EpReferenceFixerVisitor class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EpReferenceFixerVisitor class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!EpReferenceFixerVisitor class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!EpReferenceFixerVisitor class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!EpReferenceFixerVisitor class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EpReferenceFixerVisitor class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EpReferenceFixerVisitor class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EpReferenceFixerVisitor class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EpReferenceFixerVisitor class methodsFor: 'instanceCreation' stamp: ''!
newWithMap: aMap 

	^ self basicNew
		initializeWithMap: aMap;
		yourself! !

!EpReferenceFixerVisitor class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EpRenameClassRefactoring commentStamp: ''!
I represent the execution of a "rename class" (RBRenameClassRefactoring) refactoring.!
!EpRenameClassRefactoring methodsFor: 'accessing' stamp: ''!
oldName
	^ oldName! !

!EpRenameClassRefactoring methodsFor: 'initialization' stamp: ''!
initializeFrom: anOldName to: aNewName
	self initialize.
	
	oldName := anOldName.
	newName := aNewName.! !

!EpRenameClassRefactoring methodsFor: 'converting' stamp: ''!
asRBRefactoring

	^ RBRenameClassRefactoring new 
		className: oldName 
		newName: newName! !

!EpRenameClassRefactoring methodsFor: 'accessing' stamp: ''!
newName
	^ newName! !

!EpRenameClassRefactoring methodsFor: '*EpiceaBrowsers' stamp: ''!
summaryOn: aWriteStream
	"Write a string summarizing myself."
	
	aWriteStream 
		nextPutAll: 'Rename ';
		nextPutAll: oldName;
		nextPutAll: ' into ';
		nextPutAll: newName.! !

!EpRenameClassRefactoring class methodsFor: 'instance creation' stamp: ''!
rename: oldName to: newName
	^ self basicNew
		initializeFrom: oldName
		to: newName;
		yourself! !

!EpRenameInstanceVariableRefactoring commentStamp: ''!
I represent the execution of a "rename instance variable" (RBRenameInstanceVariableRefactoring) refactoring.!
!EpRenameInstanceVariableRefactoring methodsFor: 'accessing' stamp: ''!
oldName
	^ oldName! !

!EpRenameInstanceVariableRefactoring methodsFor: 'converting' stamp: ''!
asRBRefactoring
	^ RBRenameInstanceVariableRefactoring 
		rename: oldName 
		to: newName 
		in: affectedClassName! !

!EpRenameInstanceVariableRefactoring methodsFor: 'accessing' stamp: ''!
newName
	^ newName! !

!EpRenameInstanceVariableRefactoring methodsFor: 'accessing' stamp: ''!
affectedClassName
	^ affectedClassName! !

!EpRenameInstanceVariableRefactoring methodsFor: 'initialize' stamp: ''!
initializeIn: aClassName from:  anOldName to: aNewName
	self initialize.

	affectedClassName := aClassName.
	newName := aNewName.
	oldName := anOldName.! !

!EpRenameInstanceVariableRefactoring methodsFor: '*EpiceaBrowsers' stamp: ''!
summaryOn: aWriteStream
	"Write a string summarizing myself."
	
	aWriteStream 
		nextPutAll: 'Rename instance variable ';
		print: oldName;
		nextPutAll: ' into ';
		print: newName;
		nextPutAll: ' in ';		
		nextPutAll: affectedClassName.! !

!EpRenameInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
rename: oldName to: newName in: affectedClassName
	^ self basicNew 
		initializeIn: affectedClassName
		from: oldName 
		to: newName;
		yourself! !

!EpRenameMethodRefactoring commentStamp: ''!
I represent the execution of a "rename method" (RBRenameMethodRefactoring) refactoring.!
!EpRenameMethodRefactoring methodsFor: 'accessing' stamp: ''!
newSelector
	^ newSelector! !

!EpRenameMethodRefactoring methodsFor: 'converting' stamp: ''!
asRBRefactoring
	^ RBRenameMethodRefactoring
		renameMethod: oldSelector 
		in: affectedClassName 
		to: newSelector 
		permutation: #()! !

!EpRenameMethodRefactoring methodsFor: 'initialization' stamp: ''!
initializeFrom: anOldSelector to: aNewSelector in: aClassName
	self initialize.
	
	oldSelector := anOldSelector.
	newSelector := aNewSelector.
	affectedClassName := aClassName! !

!EpRenameMethodRefactoring methodsFor: '*EpiceaBrowsers' stamp: ''!
summaryOn: aWriteStream
	"Write a string summarizing myself."
	
	aWriteStream
		nextPutAll: 'Rename ';
		nextPutAll: oldSelector printString;
		nextPutAll: ' into ';
		nextPutAll: newSelector printString.! !

!EpRenameMethodRefactoring methodsFor: 'accessing' stamp: ''!
oldSelector
	^ oldSelector! !

!EpRenameMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
renameMethod: oldSelector in: affectedClassName to: newSelector
	^ self basicNew
		initializeFrom: oldSelector 
		to: newSelector 
		in: affectedClassName;
		yourself! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testBehaviorNameChange

	| aClass className |
	aClass := classFactory newClass.
	className := aClass name.
	aClass rename: className, '2'.
	self setHeadAsInputEntry.

	self revertInputEntry.
	
	self assert: aClass name equals: className.! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testCategoryRename

	| organization aCategory anotherCategory |
	organization := self class environment organization.
	aCategory := classFactory defaultCategory.
	anotherCategory := aCategory, '2'.
	organization addCategory: aCategory.
	organization renameCategory: aCategory toBe: anotherCategory.
	self setHeadAsInputEntry.

	self assert: inputEntry content class equals: EpCategoryRename.
	self deny: (organization includesCategory: aCategory).
	self assert: (organization includesCategory: anotherCategory).
	self revertInputEntry.
	self assert: (organization includesCategory: aCategory).
	self deny: (organization includesCategory: anotherCategory).! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testMethodAdditionWithMethodAlreadyRemoved

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42'.
	self setHeadAsInputEntry.

	aClass removeSelector: #fortyTwo.
	
	self assert: (inputEntry content isKindOf: EpMethodAddition).
	self deny: (aClass includesSelector: #fortyTwo).
	self revertInputEntry.
	self deny: (aClass includesSelector: #fortyTwo).! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testClassModificationWithClassRemoved

	| aClass className |
	aClass := classFactory newClass.
	className := aClass name.
	aClass addInstVarNamed: #x.
	self setHeadAsInputEntry.
	
	aClass removeFromSystem.
	
	self assert: (inputEntry content isKindOf: EpClassModification).
	self deny: (self class environment hasClassNamed: className).
	self revertInputEntry.
	self 
		assert: (self class environment hasClassNamed: className)
		description: 'Revert of a modification of a class that was removed will add it back with the original look'.
	self
		assert: (self class environment classNamed: className) instVarNames isEmpty
		description: 'The old class of the modification had no instance variables'.! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testMethodModification

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42'.
	aClass compile: 'fortyTwo ^nil'.
	self setHeadAsInputEntry.
	
	self assert: (aClass>>#fortyTwo) sourceCode equals: 'fortyTwo ^nil'.
	self revertInputEntry.
	self assert: (aClass>>#fortyTwo) sourceCode equals: 'fortyTwo ^42'.! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testMethodRemoval

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass removeSelector: #fortyTwo.
	self setHeadAsInputEntry.

	self assert: (inputEntry content isKindOf: EpMethodRemoval).
	self deny: (aClass includesSelector: #fortyTwo).
	self revertInputEntry.
	self assert: (aClass includesSelector: #fortyTwo).
	self assert: (aClass>>#fortyTwo) sourceCode equals: 'fortyTwo ^42'.
	self assert: (aClass>>#fortyTwo) protocol equals: 'number'.! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testCategoryAdditionWithCategoryRemoved

	| organization aCategory |
	organization := self class environment organization.
	aCategory := classFactory defaultCategory.
	organization addCategory: aCategory.
	self setHeadAsInputEntry.

	self assert: (organization includesCategory: aCategory).
	self revertInputEntry.
	self deny: (organization includesCategory: aCategory).! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testProtocolAddition

	| aClass |
	aClass := classFactory newClass.
	aClass organization addCategory: 'protocol'.
	self setHeadAsInputEntry.

	self assert: inputEntry content class equals: EpProtocolAddition.
	self assert: (aClass organization protocolOrganizer hasProtocolNamed: 'protocol').
	self revertInputEntry.
	self deny: (aClass organization protocolOrganizer hasProtocolNamed: 'protocol').! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testClassAdditionWithClassAlreadyRemoved

	| aClass className |
	aClass := classFactory newClass.
	className := aClass name.
	self setHeadAsInputEntry.
	
	aClass removeFromSystem.
	
	self deny: (self class environment hasClassNamed: className).
	self revertInputEntry.
	self deny: (self class environment hasClassNamed: className).! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testTraitRemoval

	| aTrait traitName |
	aTrait := classFactory newTrait.
	traitName := aTrait name.
	aTrait removeFromSystem.
	self setHeadAsInputEntry.

	self deny: (self class environment includesKey: traitName).
	self revertInputEntry.
	self assert: (self class environment includesKey: traitName).
	"---> Fails to create trait with Unclassified category"! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testBehaviorCategoryChange

	| aClass aCategory anotherCategory |
	aClass := classFactory newClass.
	aCategory := aClass category.
	anotherCategory := aCategory, '2'.
	aClass category: anotherCategory.
	self setHeadAsInputEntry.
	
	self assert: (inputEntry content isKindOf: EpBehaviorCategoryChange).
	self assert: aClass category equals: anotherCategory.
	self revertInputEntry.
	self assert: aClass category equals: aCategory.! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testBehaviorCommentChange

	| aClass |
	aClass := classFactory newClass.
	aClass classComment: 'before'.
	aClass classComment: 'after'.
	self setHeadAsInputEntry.

	self revertInputEntry.
	
	self assert: aClass organization classComment equals: 'before'.! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testProtocolRemoval

	| aClass |
	aClass := classFactory newClass.
	aClass organization addCategory: 'protocol'.
	aClass removeProtocol: 'protocol'.
	self setHeadAsInputEntry.

	self assert: inputEntry content class equals: EpProtocolRemoval.
	self deny: (aClass organization protocolOrganizer hasProtocolNamed: 'protocol').
	self revertInputEntry.
	self assert: (aClass organization protocolOrganizer hasProtocolNamed: 'protocol').! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testTraitAddition

	| aTrait traitName |
	aTrait := classFactory newTrait.
	traitName := aTrait name.
	self setHeadAsInputEntry.

	self assert: (self class environment includesKey: traitName).
	self revertInputEntry.
	self deny: (self class environment includesKey: traitName).! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testTraitAdditionWithTraitAlreadyRemoved

	| aTrait traitName |
	aTrait := classFactory newTrait.
	traitName := aTrait name.
	self setHeadAsInputEntry.
	
	aTrait removeFromSystem.

	self deny: (self class environment includesKey: traitName).
	self revertInputEntry.
	self deny: (self class environment includesKey: traitName).! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testCategoryRemovalWithCategoryAdded

	| organization aCategory |
	organization := self class environment organization.
	aCategory := classFactory defaultCategory.
	organization addCategory: aCategory.
	organization removeCategory: aCategory.
	self setHeadAsInputEntry.

	self deny: (organization includesCategory: aCategory).
	self revertInputEntry.
	self assert: (organization includesCategory: aCategory).! !

!EpRevertTest methodsFor: 'private' stamp: ''!
revertInputEntry

	EpLogBrowserOperationFactory new
		logBrowserModel: (EpLogBrowserPresenter newWithLog: monitor log);
		entries: { inputEntry };
		errorHandlerBlock: [:error | error signal ];
		revertCodeChanges! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testTraitRemovalWithTraitAlreadyAdded

	| aTrait traitName |
	aTrait := classFactory newTrait.
	traitName := aTrait name.
	aTrait removeFromSystem.
	self setHeadAsInputEntry.

	"Restore trait"
	aTrait := classFactory newTrait.
	aTrait rename: traitName.

	self assert: (self class environment includesKey: traitName).
	self revertInputEntry.
	self assert: (self class environment includesKey: traitName).! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testMethodAddition

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42'.
	self setHeadAsInputEntry.

	self assert: (inputEntry content isKindOf: EpMethodAddition).
	self assert: (aClass includesSelector: #fortyTwo).
	self revertInputEntry.
	self deny: (aClass includesSelector: #fortyTwo).! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testMethodModificationWithProtocolChanged

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'one'.
	(aClass>>#fortyTwo) protocol: 'two'.
	self setHeadAsInputEntry.

	(aClass>>#fortyTwo) protocol: 'three'.
	
	self assert: (aClass>>#fortyTwo) protocol equals: 'three'.
	self revertInputEntry.
	self assert: (aClass>>#fortyTwo) protocol equals: 'one'.! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testClassAddition

	| aClass className |
	aClass := classFactory newClass.
	className := aClass name.
	self setHeadAsInputEntry.
	
	self assert: (self class environment hasClassNamed: className).
	self revertInputEntry.
	self deny: (self class environment hasClassNamed: className).! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testMethodRemovalWithMethodAlreadyAdded

	| aClass |
	aClass := classFactory newClass.
	aClass compile: 'fortyTwo ^42' classified: 'number'.
	aClass removeSelector: #fortyTwo.
	self setHeadAsInputEntry.

	aClass compile: 'fortyTwo ^nil' classified: 'none'.

	self assert: (inputEntry content isKindOf: EpMethodRemoval).
	self assert: (aClass includesSelector: #fortyTwo).
	self revertInputEntry.
	self assert: (aClass includesSelector: #fortyTwo).
	self assert: (aClass>>#fortyTwo) sourceCode equals: 'fortyTwo ^42'.
	self assert: (aClass>>#fortyTwo) protocol equals: 'number'.! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testClassRemoval

	| aClass className category |
	aClass := classFactory newClass.
	aClass classSide instanceVariableNames: 'hey'.
	className := aClass name.
	category := aClass category.
	aClass removeFromSystem.
	self setHeadAsInputEntry.

	self assert: (inputEntry content isKindOf: EpClassRemoval).
	self deny: (self class environment hasClassNamed: className).
	self revertInputEntry.
	self assert: (self class environment hasClassNamed: className).
	self assert: (self class environment classNamed: className) category equals: category.
	self assert: (self class environment classNamed: className) classSide instVarNames equals: #('hey').! !

!EpRevertTest methodsFor: 'tests' stamp: ''!
testClassRemovalWithClassAlreadyAdded

	| aClass className |
	aClass := classFactory newClass.
	className := aClass name.
	aClass removeFromSystem.
	self setHeadAsInputEntry.

	aClass := classFactory newClass.
	aClass rename: className.

	self assert: (inputEntry content isKindOf: EpClassRemoval).
	self assert: (self class environment hasClassNamed: className).
	self revertInputEntry.
	self assert: (self class environment hasClassNamed: className).! !

!EpSessionEnd commentStamp: ''!
When an image is launched, a session starts. When it is quit, the session ends. I represent the end of a session.!
!EpSessionEnd methodsFor: 'visitor' stamp: ''!
accept: aVisitor 
	^ aVisitor visitSessionEnd: self! !

!EpSessionEvent commentStamp: ''!
When an image is launched, a session starts. When quits, the session ends. In the middle, it could be snapshoted multiple times. My subclasses represent such events.!
!EpSessionEvent methodsFor: 'accessing' stamp: ''!
imageName
	^ imageName! !

!EpSessionEvent methodsFor: 'initialization' stamp: ''!
initializeWith: anImageName
	self initialize.
	
	imageName := anImageName! !

!EpSessionEvent class methodsFor: 'instance creation' stamp: ''!
new 
	^ self imageName: Smalltalk image imagePath! !

!EpSessionEvent class methodsFor: 'instance creation' stamp: ''!
imageName: anImageName
	^ self basicNew
		initializeWith: anImageName;
		yourself! !

!EpSessionSnapshot commentStamp: ''!
When an image is launched, a session starts. After that, the session can be snapshoted multiple times. I represent the snapshot of a session.!
!EpSessionSnapshot methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitSessionSnapshot: self! !

!EpSessionStart commentStamp: ''!
When an image is launched, a session starts. I represent the start of a session.!
!EpSessionStart methodsFor: 'visitor' stamp: ''!
accept: aVisitor 
	^ aVisitor visitSessionStart: self! !

!EpSettings commentStamp: ''!
My class-side protocol initializes System Settings' stuff.!
!EpSettings class methodsFor: 'system settings' stamp: ''!
lostEventsDetectorEnabledSettingOn: aBuilder

	<systemsettings>
	(aBuilder setting: #lostEventsDetectorEnabled)
		label: 'Detect lost events on start-up';
		default: true;
		description: 'Check if current Epicea log has events that were not applied in this image (useful for recovegin changes when the image crashed)';
		parent: #epicea;
		target: self.! !

!EpSettings class methodsFor: 'system settings' stamp: ''!
storeNameStrategySettingsOn: aBuilder

	<systemsettings>
	(aBuilder pickOne: #storeNameStrategyClass)
		label: 'File Naming Strategy';
		description: 'Choose how will be the Epicea logs named.';
		parent: #epicea;
		target: self;
		default: OmRandomSuffixStrategy;
		domainValues: OmSessionStoreNamingStrategy availableStrategies.! !

!EpSettings class methodsFor: 'accessing' stamp: ''!
monitorEnabled: aBoolean

	EpMonitor current enabled: aBoolean! !

!EpSettings class methodsFor: 'accessing' stamp: ''!
storeNameStrategyClass: aStrategyClass

	OmSessionStore storeNameStrategy: aStrategyClass new! !

!EpSettings class methodsFor: 'accessing' stamp: ''!
monitorEnabled

	^ EpMonitor current isEnabled! !

!EpSettings class methodsFor: 'system settings' stamp: ''!
monitorEnabledSettingOn: aBuilder

	<systemsettings>
	(aBuilder setting: #monitorEnabled)
		label: 'Monitor enabled';
		default: true;
		description: 'The Epicea Monitor listens events in the system such as class added and method modified, and records them to the current Epicea log.';
		parent: #epicea;
		target: self.! !

!EpSettings class methodsFor: 'accessing' stamp: ''!
lostEventsDetectorEnabled: aBoolean

	EpLostChangesDetector enabled: aBoolean! !

!EpSettings class methodsFor: 'accessing' stamp: ''!
lostEventsDetectorEnabled

	^ EpLostChangesDetector isEnabled! !

!EpSettings class methodsFor: 'accessing' stamp: ''!
storeNameStrategyClass

	^ OmSessionStore storeNameStrategy class! !

!EpSettings class methodsFor: 'accessing' stamp: ''!
writingDeferDuration: aSmallInteger

	^ EpMonitor current writingDeferDuration: aSmallInteger milliSeconds! !

!EpSettings class methodsFor: 'system settings' stamp: ''!
groupSettingsOn: aBuilder

	<systemsettings>
	(aBuilder group: #epicea)
		label: 'Epicea';
		description: 'Epicea is a tool that records code changes enriched with IDE events. Epicea extends and could replace the traditional .changes logging mechanism, where the recorded code changes are incomplete and are not properly reified and thus it can be difficult to recover lost code after an image crash.';
		parent: #tools.! !

!EpSettings class methodsFor: 'accessing' stamp: ''!
writingDeferDuration

	^ EpMonitor current writingDeferDuration asMilliSeconds! !

!EpSettings class methodsFor: 'system settings' stamp: ''!
writingDeferDurationSettingOn: aBuilder

	<systemsettings>
	(aBuilder setting: #writingDeferDuration)
		label: 'Writing defer duration';
		default: 250;
		description: 'Time to wait before write. When Epicea listens new events, it does not write them immediately. Instead, the new events are buffered until there were not new events during the time specified by this setting. The goal is to optimize I/O operations by batching them. 
		
Consecuences of a high defer duration: 
- Pros: For example, when a project is loaded into the image, many events happen in a small window of time.
- Cons: Code changes can be lost if the vm crashes.';
		parent: #epicea;
		target: self.! !

!EpTCodeChangeVisitor commentStamp: ''!
I am a visitor for EpCodeChange subinstances.!
!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitClassAddition: aChange
	^ self visitClassChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aChange
	^ self visitCategoryChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aChange
	^ self visitMethodChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitMethodChange: aChange
	^ self visitCodeChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryChange: aChange
	^ self visitCodeChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aChange
	^ self visitCategoryChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aChange
	^ self visitMethodChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aChange
	^ self visitCategoryChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aProtocolAddition
	^ self visitProtocolChange: aProtocolAddition! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitCodeChange: aChange
	^ self explicitRequirement! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorChange: aChange
	^ self visitCodeChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aChange
	^ self visitTraitChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolChange: aProtocolAddition
	^ self visitBehaviorChange: aProtocolAddition.! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aChange
	^ self visitTraitChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoval: aChange
	^ self visitTraitChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitTraitChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitClassChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aChange
	^ self visitClassChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aChange
	^ self visitMethodChange: aChange! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aProtocolRemoved
	^ self visitProtocolChange: aProtocolRemoved! !

!EpTCodeChangeVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aChange
	^ self visitClassChange: aChange! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EpTCodeChangeVisitor classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EpTCodeChangeVisitor classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EpTCodeChangeVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EpTCodeChangeVisitor classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EpTCodeChangeVisitor classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EpTCodeChangeVisitor classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpTCodeChangeVisitor classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EpTCodeChangeVisitor classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EpTCodeChangeVisitor classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EpTCodeChangeVisitor classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpTCodeChangeVisitor classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EpTCodeChangeVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EpTCodeChangeVisitor classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EpTCodeChangeVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EpTCodeChangeVisitor classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EpTCodeChangeVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EpTEventVisitor commentStamp: ''!
I am a visitor for EpEvent subinstances.!
!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCategoryChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitClassAddition: aChange
	^ self visitClassChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitMethodChange: aChange
	^ self visitCodeChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitRedo: aRedoEvent
	^ self visitEvent: aRedoEvent! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitRefactoring: anEvent 
	^ self visitEvent: anEvent! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitMonticelloVersionsLoad: anEvent
	^ self visitEvent: anEvent! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitSessionSnapshot: anEvent
	^ self visitEvent: anEvent! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitSessionStart: anEvent 
	^ self visitEvent: anEvent! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorNameChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRemoval: aChange
	^ self visitCategoryChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolAddition: aProtocolAddition
	^ self visitProtocolChange: aProtocolAddition! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitUndo: anUndoEvent
	^ self visitEvent: anUndoEvent! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitCodeChange: aChange
	"Default behavior for any change."
		
	^ self visitEvent: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitTraitAddition: aChange
	^ self visitTraitChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitEvent: aChange
	^ self explicitRequirement! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCommentChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitTraitModification: aChange
	^ self visitTraitChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitTraitChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorCopy: anEvent
	^ self visitEvent: anEvent! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitSessionEnd: anEvent
	^ self visitEvent: anEvent! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitClassChange: aChange
	^ self visitBehaviorChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitMethodRemoval: aChange
	^ self visitMethodChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitLogCommentModification: anEvent 
	^ self visitEvent: anEvent! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitMethodAddition: aChange
	^ self visitMethodChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryRename: aChange
	^ self visitCategoryChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryChange: aChange
	^ self visitCodeChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitCategoryAddition: aChange
	^ self visitCategoryChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitMethodModification: aChange
	^ self visitMethodChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitBehaviorChange: aChange
	^ self visitCodeChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitTraitRemoval: aChange
	^ self visitTraitChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolChange: aProtocolAddition
	^ self visitBehaviorChange: aProtocolAddition.! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitExpressionEvaluation: anExpressionEvaluation
	^ self visitEvent: anExpressionEvaluation! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitClassRemoval: aChange
	^ self visitClassChange: aChange! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitProtocolRemoval: aProtocolRemoved
	^ self visitProtocolChange: aProtocolRemoved! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitMonticelloVersionSave: anEvent
	^ self visitEvent: anEvent! !

!EpTEventVisitor methodsFor: 'visitor' stamp: ''!
visitClassModification: aChange
	^ self visitClassChange: aChange! !

!EpTEventVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!EpTEventVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!EpTEventVisitor classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!EpTEventVisitor classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!EpTEventVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!EpTEventVisitor classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!EpTEventVisitor classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!EpTEventVisitor classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!EpTEventVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpTEventVisitor classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!EpTEventVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!EpTEventVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!EpTEventVisitor classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!EpTEventVisitor classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!EpTEventVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!EpTEventVisitor classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!EpTEventVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!EpTEventVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!EpTEventVisitor classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!EpTEventVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!EpTEventVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!EpTEventVisitor classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!EpTEventVisitor classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!EpTEventVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!EpTEventVisitor classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!EpTEventVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!EpTestLogBuilder commentStamp: ''!
I am a helper for creating toy logs.!
!EpTestLogBuilder methodsFor: 'samples' stamp: ''!
oneTriggerWithFourChildrenLog

	| triggerReference |
	self logInitial.
	
	triggerReference := self logHeadReference.

	self
		logChildren: 2 
		triggerReference: triggerReference.

	self
		logEvent: (EpClassAddition class: Integer)
		triggerReference: triggerReference.

	self
		logChildren: 1
		triggerReference: triggerReference.

	^ self log! !

!EpTestLogBuilder methodsFor: 'accessing' stamp: ''!
log

	^ log ifNil: [ log := self newLog ]! !

!EpTestLogBuilder methodsFor: 'initialization' stamp: ''!
newLog

	^ EpLog newWithStore: self newStore! !

!EpTestLogBuilder methodsFor: 'initialization' stamp: ''!
useLogWithSessionStore

	log := self newLogWithSessionStore! !

!EpTestLogBuilder methodsFor: 'building' stamp: ''!
logChildren: anInteger 
	self
		logChildren: anInteger 
		triggerReference: self logHeadReference! !

!EpTestLogBuilder methodsFor: 'initialization' stamp: ''!
newDirectory

	^ FileReference newTempFilePrefix: 'epicea-tests-' suffix: ''! !

!EpTestLogBuilder methodsFor: 'initialization' stamp: ''!
newStore

	^ OmFileStore 
		named: 'tmp', UUID new asString36
		inDirectory: self directory ensureCreateDirectory! !

!EpTestLogBuilder methodsFor: 'samples' stamp: ''!
oneTriggerWithOneChildLog

	| triggerReference |
	self logInitial.
	
	triggerReference := self logHeadReference.

	self
		logChildren: 2 
		triggerReference: triggerReference.

	self
		logEvent: (EpClassAddition class: Integer)
		triggerReference: triggerReference.
		
	self
		logEvent: (EpLogEntriesComment entryReferences: { self logHeadReference } oldComment: '' newComment: 'Passed Code Review')
		triggerReference: triggerReference.

	^ self log! !

!EpTestLogBuilder methodsFor: 'initialization' stamp: ''!
newLogWithSessionStore

	^ EpLog newWithStore: self newSessionStore! !

!EpTestLogBuilder methodsFor: 'accessing' stamp: ''!
directory

	^ directory ifNil: [ directory := self newDirectory ]! !

!EpTestLogBuilder methodsFor: 'building' stamp: ''!
logInitial
	self
		logEvent: (EpExpressionEvaluation expression: '0')
		triggerReference: self log nullReference! !

!EpTestLogBuilder methodsFor: 'building' stamp: ''!
logChildren: anInteger triggerReference: triggerReference

	1 to: anInteger do: [ :index |
		self 
			logEvent: (EpExpressionEvaluation expression: index asString)
			triggerReference: triggerReference ].! !

!EpTestLogBuilder methodsFor: 'initialization' stamp: ''!
newSessionStore

	^ OmSessionStore newWithBaseLocator: self directory ensureCreateDirectory! !

!EpTestLogBuilder methodsFor: 'building' stamp: ''!
logEvent: anEvent triggerReference: triggerReference
	self log 
		addEntryWith: anEvent 
		tags: [ :tags |
			tags at: EpLog authorKey put: 'TestAuthor'.
			tags at: EpLog timeKey put: DateAndTime now.
						
			triggerReference isNull ifFalse: [
				tags 
					at: EpLog triggererReferenceKey
					put: triggerReference ] ].
	self log store flush.! !

!EpTestLogBuilder methodsFor: 'building' stamp: ''!
logEvent: anEvent

	^ self 
		logEvent: anEvent 
		triggerReference: self log nullReference! !

!EpTestLogBuilder methodsFor: 'releasing' stamp: ''!
cleanUp

	self directory ensureDeleteAll! !

!EpTestLogBuilder methodsFor: 'accessing' stamp: ''!
logHeadReference
	^ self log headReference! !

!EpTraitAddition commentStamp: ''!
I represent the creation of a trait.!
!EpTraitAddition methodsFor: 'accessing' stamp: ''!
behaviorAffectedName

	^ self traitAdded name! !

!EpTraitAddition methodsFor: 'initialization' stamp: ''!
initializeWithTrait: aTrait

	self initialize.
	trait := aTrait asEpiceaRingDefinition.! !

!EpTraitAddition methodsFor: 'accessing' stamp: ''!
behaviorAffected
	^ self traitAdded! !

!EpTraitAddition methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitTraitAddition: self! !

!EpTraitAddition methodsFor: 'accessing' stamp: ''!
traitAdded

	^ trait! !

!EpTraitAddition class methodsFor: 'instance creation' stamp: ''!
trait: aTrait

	^ self basicNew
		initializeWithTrait: aTrait;
		yourself! !

!EpTraitChange commentStamp: ''!
I represent a change in the definition of a trait.!
!EpTraitChange methodsFor: 'testing' stamp: ''!
doesOverride: aCodeChange

	^ aCodeChange isEpTraitChange and: [
		aCodeChange behaviorAffectedName = self behaviorAffectedName ]! !

!EpTraitChange methodsFor: 'testing' stamp: ''!
isEpTraitChange

	^ true! !

!EpTraitModification commentStamp: ''!
I represent the modification of a trait.!
!EpTraitModification methodsFor: 'accessing' stamp: ''!
behaviorAffectedName

	^ newTrait name! !

!EpTraitModification methodsFor: 'accessing' stamp: ''!
oldTrait

	^ oldTrait! !

!EpTraitModification methodsFor: 'accessing' stamp: ''!
behaviorAffected
	^ newTrait! !

!EpTraitModification methodsFor: 'testing' stamp: ''!
hasChanges
	^ oldTrait definitionSource ~= newTrait definitionSource or: [ 
		oldTrait classSide definitionSource ~= newTrait classSide definitionSource ]! !

!EpTraitModification methodsFor: 'initialize' stamp: ''!
initializeOldTrait: anOldTrait newTrait: aNewTrait

	self initialize.
	oldTrait := anOldTrait asEpiceaRingDefinition.
	newTrait := aNewTrait asEpiceaRingDefinition.! !

!EpTraitModification methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitTraitModification: self! !

!EpTraitModification methodsFor: 'accessing' stamp: ''!
newTrait

	^ newTrait! !

!EpTraitModification class methodsFor: 'instance creation' stamp: ''!
oldTrait: anOldTrait newTrait: aNewTrait

	^ self basicNew 
		initializeOldTrait: anOldTrait newTrait: aNewTrait;
		yourself! !

!EpTraitRemoval commentStamp: ''!
I represent the removal of a trait.!
!EpTraitRemoval methodsFor: 'accessing' stamp: ''!
behaviorAffectedName

	^ self traitRemoved name! !

!EpTraitRemoval methodsFor: 'accessing' stamp: ''!
traitRemoved

	^ trait! !

!EpTraitRemoval methodsFor: 'initialization' stamp: ''!
initializeWithTrait: aTrait

	self initialize.
	trait := aTrait asEpiceaRingDefinition.! !

!EpTraitRemoval methodsFor: 'accessing' stamp: ''!
behaviorAffected

	^ self traitRemoved! !

!EpTraitRemoval methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	^ aVisitor visitTraitRemoval: self! !

!EpTraitRemoval class methodsFor: 'instance creation' stamp: ''!
trait: aTrait

	^ self basicNew 
		initializeWithTrait: aTrait;
		yourself! !

!EpTriggeringIntegrationTest methodsFor: 'accessing' stamp: ''!
monticelloRepository

	^ GoferResource current monticelloRepository! !

!EpTriggeringIntegrationTest methodsFor: 'accessing' stamp: ''!
changesBrowserOpenedWindows

	^ ChangesBrowser allSubInstances reject: [ :each | each window isClosed ]! !

!EpTriggeringIntegrationTest methodsFor: 'tests' stamp: ''!
testNoTrigger
	
	classFactory newClass.
	[ classFactory newClass ] asJob run.

	"Check EpMonitor logged them correctly"
	self assert: (self countLogEventsWith: EpClassAddition) equals: 2.

	(self allLogEntriesWith: EpClassAddition) do: [ :anEntry |
		self deny: (anEntry tags includesKey: EpLog triggererReferenceKey) ]! !

!EpTriggeringIntegrationTest methodsFor: 'tests' stamp: ''!
testMCVersionLoad
	
	| gofer anEntry |
	gofer := Gofer new.
	gofer disablePackageCache.
	gofer 
		repository: self monticelloRepository;
		package: 'GoferFoo'.
	gofer load.
	gofer unload.

	"Check EpMonitor logged it correctly"
	self assert: (self countLogEventsWith: EpClassAddition) equals: 1.

	anEntry := (self allLogEntriesWith: EpClassAddition) anyOne.

	self 
		assert: (anEntry tags includesKey: EpLog triggererReferenceKey) 
		description: 'It did not recognize that the code change was triggered by other event.'! !

!EpTriggeringIntegrationTest methodsFor: 'accessing' stamp: ''!
resources

	^ super resources copyWith: GoferResource! !

!EpUndo commentStamp: ''!
I represent a Undo operation performed in a EpLogBrowser.!
!EpUndo methodsFor: 'copying' stamp: ''!
copyWithEntryReferences: aCollection
	^ self class forAll: aCollection! !

!EpUndo methodsFor: 'visitor' stamp: ''!
accept: aChangeVisitor
	^ aChangeVisitor visitUndo: self! !

!EpUndo methodsFor: 'accessing' stamp: ''!
title
	^ 'Revert changes'! !

!EpUndo class methodsFor: 'instance creation' stamp: ''!
forAll: aCollectionOfEntryReferences
	^ self basicNew
		initializeWith: aCollectionOfEntryReferences;
		yourself! !

!EpUnifiedBrowserPresenter commentStamp: ''!
I'm a Spec model for the main tool to browse Epicea logs.

Open with:
self open!
!EpUnifiedBrowserPresenter methodsFor: 'initialization' stamp: ''!
updatesAnnouncer
	^ EpMonitor current sessionStore announcer! !

!EpUnifiedBrowserPresenter methodsFor: 'actions' stamp: ''!
selectDirectory

	logNodesPresenter selectDirectory! !

!EpUnifiedBrowserPresenter methodsFor: 'initialization' stamp: ''!
monitorLogAnnouncer
	^ EpMonitor current log announcer! !

!EpUnifiedBrowserPresenter methodsFor: 'refreshing' stamp: ''!
refresh
	logNodesPresenter refresh! !

!EpUnifiedBrowserPresenter methodsFor: 'initialization' stamp: ''!
initializeToolbar
	
	toolbarPresenter 
		add: (self newToolbarButton 
			icon: (self application iconNamed: #refresh);
			label: 'Refresh';
			help: 'Refresh logs from this directory';
			action: [ self refreshLogs ];
			yourself);
		add: (self newToolbarButton 
			icon: (self application iconNamed: #openIcon);
			label: 'Directory';
			help: 'Select directory to browse logs (i.e. files with ombu extension)';
			action: [ self selectDirectory ];
			yourself);			
		add: (self newToolbarButton 
			icon: (self application iconNamed: #config);
			label: 'Dashboard';
			help: 'Open epicea dashboard';
			action: [ self openDashboard ];
			yourself)! !

!EpUnifiedBrowserPresenter methodsFor: 'actions' stamp: ''!
openDashboard

	(EpDashboardPresenter newApplication: self application) openWithSpec! !

!EpUnifiedBrowserPresenter methodsFor: 'refreshing' stamp: ''!
refreshIfMonitorLogSelected
	"See initializeWorkaroundToRefreshOnMonitorLogAnnouncement"

	(logNodesPresenter selectedLogNodes anySatisfy: [ :item | item isMonitor ])
		ifTrue: [ logPresenter refresh ]! !

!EpUnifiedBrowserPresenter methodsFor: 'initialization' stamp: ''!
initializeRefreshOnSessionUpdate
	self updatesAnnouncer weak when: OmSessionStoreUpdated send: #refresh to: self! !

!EpUnifiedBrowserPresenter methodsFor: 'actions' stamp: ''!
refreshLogs

	logNodesPresenter refresh! !

!EpUnifiedBrowserPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	aWindowPresenter
		title: 'Epicea - Code Changes';
		initialExtent: 950 @ 650;
		whenClosedDo: [ self updatesAnnouncer unsubscribe: self ]! !

!EpUnifiedBrowserPresenter methodsFor: 'refreshing' stamp: ''!
refreshWithLogSelection: selection

	logPresenter
		theLog: (self freshLogFromSelection: selection);
		refresh;
		cleanEntryContent! !

!EpUnifiedBrowserPresenter methodsFor: 'initialization' stamp: ''!
initializeWorkaroundToRefreshOnMonitorLogAnnouncement
	refreshDeferrer := OmDeferrer send: #refreshIfMonitorLogSelected to: self after: 500 milliSeconds.

	self monitorLogAnnouncer weak when: EpEntryAdded send: #schedule to: refreshDeferrer.

	self whenWindowChanged: [ :windowModel |
		windowModel whenClosedDo: [
			self monitorLogAnnouncer unsubscribe: refreshDeferrer ] ]! !

!EpUnifiedBrowserPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpBoxLayout newTopToBottom
		add: (toolbarPresenter := self newToolbar) expand: false;
		add: (SpPanedLayout newLeftToRight
			positionOfSlider: 35 percent;
			add: (logNodesPresenter := self instantiate: EpLogNodeGraphPresenter);
			add: (logPresenter := self instantiate: EpLogBrowserPresenter);
			yourself);
		yourself).
		
	logNodesPresenter whenSelectionChangedDo: [ :selection |
		self refreshWithLogSelection: selection ].

	self initializeToolbar.
	self initializeRefreshOnSessionUpdate.
	self initializeWorkaroundToRefreshOnMonitorLogAnnouncement! !

!EpUnifiedBrowserPresenter methodsFor: 'refreshing' stamp: ''!
freshLogFromSelection: selection
	^ selection selectedItems
		ifEmpty: [ EpLog newNull ]
		ifNotEmpty: [ :items | 
			| entries |
			"Needed to reverse the selected logs to have the expected order (as user)."
			entries := items reversed flatCollect: [:each | each log entries ].
			EpLog newWithEntries: entries ].! !

!EpUnifiedBrowserPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	super initializePresenter.
	logNodesPresenter whenSelectionChangedDo: [ :selection | self refreshWithLogSelection: selection ].
	self initializeRefreshOnSessionUpdate.
	self initializeWorkaroundToRefreshOnMonitorLogAnnouncement! !

!EpUnifiedBrowserPresenter class methodsFor: 'accessing' stamp: ''!
worldMenuItemOn: aBuilder
	<worldMenu>

	(aBuilder item: 'Code Changes')
		parent: #Changes;
		action: [ self open ]; 
		icon: self taskbarIcon;
		help: 'Browse recorded change logs during from Pharo coding sessions and replay changes.';
		order: 1! !

!EpUnifiedBrowserPresenter class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	^ self new
		refresh;
		openWithSpec;
		yourself! !

!EpUnifiedBrowserPresenter class methodsFor: 'accessing' stamp: ''!
taskbarIconName

	^ #recoverLostChangesIcon! !

!EpUnknownRefactoring commentStamp: ''!
I represent a refactoring which it's not possible to reconstruct because the original information is lost.!
!EpUnknownRefactoring methodsFor: 'converting' stamp: ''!
asRBRefactoring
	"The original refactoring cannot be recreated."
	
	^ self shouldNotImplement! !

!EpUnknownRefactoring methodsFor: 'initialization' stamp: ''!
initializeWith: aRBRefactoring
	self initialize.
	printString := aRBRefactoring printString! !

!EpUnknownRefactoring methodsFor: '*EpiceaBrowsers' stamp: ''!
summaryOn: aWriteStream
	"Write a string summarizing myself."
	
	aWriteStream 
		nextPutAll: printString! !

!EpUnknownRefactoring class methodsFor: 'instance creation' stamp: ''!
for: aRBRefactoring
	^ self basicNew
		initializeWith: aRBRefactoring;
		yourself! !

!Ephemeron commentStamp: ''!
I represent ephemeric key-value objects. Ephemerons are key-value objects (subclasses of Association) with special semantics during garbage collection.  My special behavior can resumed as follows:

- The garbage collection will iterate my instances only if the key is not referenced strongly by another object.
- Then, if no strong references to the key are found, then the values of this ephemeron are hold weakly.
- Otherwise, the values are hold strongly.

In this implementation, an Ephemeron can hold more than one value, which are all treated in the same manner. This ephemeron instance knows its container, which allows the ephemeron to remove itself from a container (such as a Dictionary) upon finalization.

!!!! Example usages

In general terms, do not use myself directly. Use instead an Ephemeric container like EphemeronRegistry. An Ephemeron registry will guarantee the collection of keys and values of the object inside the Ephemeron.

Otherwise, if you want to use it, you can create an Ephemeron as any association:

ephemeron := Ephemeron key: aKey value: aValue.
ephemeron container: aContainer.

!!!! Ephemeron Finalization

When an ephemeron's key is hold strongly just by the ephemeron itself, the Ephemeron will be mourned (finalized). That means that the VM will:
- put the Ephemeron in the mourning queue waiting for the image to take care of mourning
- make the Ephemeron non ephemeric. That is, the ephemeron instance cannot be reused.

On the image side, the finalization process will send the message #mourn to an Ephemeron.  #mourn will #finalize the Ephemeron's key, and remove the Ephemeron from it's container to allow its collection during a subsequent garbage collection.

!!!! More Documentation

You can read the associated paper to understand better the semantics of ephemerons:

Ephemerons: A New Finalization Mechanism. Barry Hayes. OOPSLA '97!
!Ephemeron methodsFor: 'mourning' stamp: ''!
mourn
	"The key is only referenced by myself.
	Finalize the key and remove myself from my container.
	
	This Ephemeron instance is not ephemeric anymore: it cannot be reused."

	key finalize.
	container ifNotNil: [ container removeEphemeron: self ].! !

!Ephemeron methodsFor: 'accessing' stamp: ''!
container: anEphemeronContainer

	container := anEphemeronContainer! !

!Ephemeron class methodsFor: 'instance creation' stamp: ''!
key: key value: value container: aContainer

	^ self new
		key: key;
		value: value;
		container: aContainer;
		yourself! !

!EphemeronLayout commentStamp: ''!
A layout for ephemeron objects!
!EphemeronLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	^ 5! !

!EphemeronLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGEphemeronLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)]
! !

!EphemeronLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else!!"
	^#ephemeronSubclass:! !

!EphemeronLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass 
	
	^ (superLayout extendEphemeron: aScope)
		host: aClass;
		yourself! !

!EphemeronLayout class methodsFor: '*Monticello' stamp: 'nil'!
mcTypeSymbol 
	^ #ephemeron! !

!EphemeronRegistry commentStamp: ''!
I'm a registry of Ephemerons. My main responsibility is to hold Ephemeron instances to avoid that they are collected, and thus, guarantee their finalization.

As soon as an Ephemeron receives the #mourn message, it will tell me to remove himself from me using the #removeEphemeron: message.


!!!! Example of usage 

An ephemeron registry can be simply used by instantiating it and putting objects inside it:

registry := EphemeronRegistry new.
registry at: objectThatMayBeCollected put: somePropertyThatWouldBeHoldWeaklyDependingOnTheKey.

Notice that the key is the object that is important from the finalization point of view. As soon as the key is only reachable by the ephemeron registry, two things will happen:

- The key will be sent #finalize, giving the user the opportunity to override the hook and provide an application specific finalization
- They registry will forget the ephemeron. If the value of the ephemeron is only referenced by this ephemeron it will then be collected.

Ephemerons are created by the registry itself, and retrieved by the ephemeron registry in case the user needs to manipulate the ephemeron manually:

ephemeron := registry at: key put: value.


!!!! Implementation Details

This Ephemeron registry is implemented using an IdentitySet to hold the remembered Ephemeron instances. This avoid to scan for keys, and allows the usage of several ephemerons for the same object.!
!EphemeronRegistry methodsFor: 'registration' stamp: ''!
at: key put: value

	^ self registerEphemeron: (Ephemeron key: key value: value container: self)! !

!EphemeronRegistry methodsFor: 'testing' stamp: ''!
isEmpty

	^ ephemeronCollection isEmpty! !

!EphemeronRegistry methodsFor: 'accessing' stamp: ''!
size

	^ ephemeronCollection size! !

!EphemeronRegistry methodsFor: 'registration' stamp: ''!
registerEphemeron: anEphemeron

	^ ephemeronCollection add: anEphemeron! !

!EphemeronRegistry methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	ephemeronCollection := IdentitySet new.! !

!EphemeronRegistry methodsFor: 'registration' stamp: ''!
removeEphemeron: anEphemeron

	ephemeronCollection remove: anEphemeron! !

!EphemeronTest methodsFor: 'tests' stamp: ''!
testEphemeronIsRemovedFromRegistryUponFinalization

	| finalized theKey registry |

	Smalltalk supportsQueueingFinalization ifFalse: [ ^ self skip ].

	finalized := false.
	theKey := ObjectFinalizer receiver: [ finalized := true ] selector: #value.

	registry := EphemeronRegistry new.
	registry at: theKey put: nil.	"Nil theKey to remove all strong references to it. Then Garbage collect to force mourning"
	theKey := nil.
	Smalltalk garbageCollect.

	self
		assertEmpty: registry;
		assert: finalized! !

!EphemeronTest methodsFor: 'tests' stamp: ''!
testEphemeronKeyIsFinalizedWhenKeyIsNotHoldStrongly

	| finalized theKey ephemeron |
	Smalltalk supportsQueueingFinalization ifFalse: [ ^ self skip ].

	finalized := false.
	theKey := ObjectFinalizer receiver: [ finalized := true ] selector: #value.
	
	ephemeron := Ephemeron key: theKey value: nil.
	
	"Remove the only strong reference to the key and garbage collect to force mourning"
	theKey := nil.
	2 timesRepeat: [ Smalltalk garbageCollect ].
	
	self assert: finalized.! !

!EphemeronTest methodsFor: 'tests' stamp: ''!
testEphemeronAreNotFinalizedIfCollected

	| finalized theKey ephemeron |
	Smalltalk supportsQueueingFinalization ifFalse: [ ^ self skip ].

	finalized := false.
	theKey := ObjectFinalizer receiver: [ finalized := true ] selector: #value.
	
	ephemeron := Ephemeron key: theKey value: nil.
	
	"Remove the only strong reference to the key and garbage collect to force mourning"
	theKey := ephemeron := nil.
	Smalltalk garbageCollect.
	
	self deny: finalized.! !

!EphemeronTest methodsFor: 'tests' stamp: ''!
testInterconnectedEphemeronsAreCollectedIfKeysAreNotReferencedFromTheOutside

	| finalized1 finalized2 theKey theValue ephemeron1 ephemeron2 |
	Smalltalk supportsQueueingFinalization ifFalse: [ ^ self skip ].

	finalized1 := finalized2 := false.
	theKey := ObjectFinalizer receiver: [ finalized1 := true ] selector: #value.
	theValue := ObjectFinalizer receiver: [ finalized2 := true ] selector: #value.
		
	ephemeron1 := Ephemeron key: theKey value: theValue.
	ephemeron2 := Ephemeron key: theValue value: theKey.
	
	"Remove the only strong reference to the key and garbage collect to force mourning"
	theKey := theValue := nil.
	2 timesRepeat: [ Smalltalk garbageCollect ].
	
	self assert: (finalized1 and: finalized2).! !

!EphemeronTest methodsFor: 'tests' stamp: ''!
testInterconnectedEphemeronsAreNotCollectedIfAKeyIsReferencedFromTheOutside

	| finalized1 finalized2 theKey theValue ephemeron1 ephemeron2 |
	Smalltalk supportsQueueingFinalization ifFalse: [ ^ self skip ].

	finalized1 := finalized2 := false.
	theKey := ObjectFinalizer receiver: [ finalized1 := true ] selector: #value.
	theValue := ObjectFinalizer receiver: [ finalized2 := true ] selector: #value.
		
	ephemeron1 := Ephemeron key: theKey value: theValue.
	ephemeron2 := Ephemeron key: theValue value: theKey.
	
	"Remove only the strong reference to the first key and garbage collect to force mourning"
	theValue := nil.
	Smalltalk garbageCollect.
	
	self deny: finalized1.
	self deny: finalized2.! !

!EphemeronTest methodsFor: 'tests' stamp: ''!
testInterconnectedEphemeronsAreNotCollectedIfTheOtherKeyIsReferencedFromTheOutside

	| finalized1 finalized2 theKey theValue ephemeron1 ephemeron2 |
	Smalltalk supportsQueueingFinalization ifFalse: [ ^ self skip ].

	finalized1 := finalized2 := false.
	theKey := ObjectFinalizer receiver: [ finalized1 := true ] selector: #value.
	theValue := ObjectFinalizer receiver: [ finalized2 := true ] selector: #value.
		
	ephemeron1 := Ephemeron key: theKey value: theValue.
	ephemeron2 := Ephemeron key: theValue value: theKey.
	
	"Remove only the strong reference to the second key and garbage collect to force mourning"
	theKey := nil.
	Smalltalk garbageCollect.
	
	self deny: finalized1.
	self deny: finalized2.! !

!EphemeronTest methodsFor: 'tests' stamp: ''!
testEphemeronIsNotRemovedFromRegistryUponFinalizationIfKeyIsReferenced

	| finalized theKey registry |

	Smalltalk supportsQueueingFinalization ifFalse: [ ^ self skip ].

	finalized := false.
	theKey := ObjectFinalizer receiver: [ finalized := true ] selector: #value.

	registry := EphemeronRegistry new.
	registry at: theKey put: nil.	
	"Nil theKey to remove all strong references to it. Then Garbage collect to force mourning"
	Smalltalk garbageCollect.

	self
		assert: registry size equals: 1;
		assert: finalized! !

!EphemeronTest methodsFor: 'tests' stamp: ''!
testEphemeronKeyIsNotFinalizedWhenKeyIsHoldStrongly

	| finalized theKey ephemeron |
	Smalltalk supportsQueueingFinalization ifFalse: [ ^ self skip ].

	finalized := false.
	theKey := ObjectFinalizer receiver: [ finalized := true ] selector: #value.
	
	ephemeron := Ephemeron key: theKey value: nil.
	
	"Garbage collect to force mourning"
	Smalltalk garbageCollect.
	
	self deny: finalized.! !

!EqualityTester commentStamp: ''!
I provide a simple way to test the equality properties of any object.!
!EqualityTester methodsFor: 'operation' stamp: ''!
resultFor: runs
	"Test that equality is the same over runs and answer the result"

	1 to: runs do: [ :i |  self prototype = self prototype ifFalse: [ ^ false ] ].
	^ true! !

!Error commentStamp: ''!
>From the ANSI standard:
This protocol describes the behavior of instances of class Error. These are used to represent error conditions that prevent the normal continuation of processing. Actual error exceptions used by an application may be subclasses of this class.
As Error is explicitly specified  to be subclassable, conforming implementations must implement its behavior in a non-fragile manner.

Additional notes:
Error>defaultAction uses an explicit test for the presence of the Debugger class to decide whether or not it is in development mode.  In the future, TFEI hopes to enhance the semantics of #defaultAction to improve support for pluggable default handlers.!
!Error methodsFor: '*SUnit-Core' stamp: ''!
sunitAnnounce: aTestCase toResult: aTestResult
	aTestResult addError: aTestCase.! !

!Error methodsFor: 'private' stamp: ''!
isResumable
	"Determine whether an exception is resumable."

	^ false! !

!Error methodsFor: '*JenkinsTools-Core' stamp: ''!
recordResultOf: aTestCase inHDTestReport: aHDTestReport
	
	aHDTestReport recordError: self duringTest: aTestCase! !

!Error class methodsFor: 'testing' stamp: ''!
captureIfSignalledWhenStepping
	^self == Error! !

!ErrorDialogWindow commentStamp: ''!
A message dialog with an error icon.!
!ErrorDialogWindow methodsFor: 'accessing' stamp: ''!
icon
	"Answer an icon for the receiver."

	^ self iconNamed: #errorIcon! !

!ErrorDialogWindow class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallErrorIcon! !

!ErrorNodeStyler methodsFor: 'visiting' stamp: ''!
visitEnglobingErrorNode: anEnglobingNode

	| conf |
	conf := RubConfigurationChange new.
	conf configurationBlock: [ :text | 
		| r |
		r := self segmentMorphClass from: anEnglobingNode stop to: anEnglobingNode stop + 1.
		text addSegment: r.
		r label: (self iconLabelBlock: anEnglobingNode).
		r icon: (self iconFor: anEnglobingNode).
		r iconBlock: (self iconBlock: anEnglobingNode).
		r color: self highlightColor.
		r borderColor: self borderColor ].
	textModel announce: conf.

	anEnglobingNode content do: [ :each | self visitNode: each ]! !

!ErrorNodeStyler methodsFor: 'hooks' stamp: ''!
segmentMorphClass

	^ RubUnderlinedSegmentMorph! !

!ErrorNodeStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^nil! !

!ErrorNodeStyler methodsFor: 'visiting' stamp: ''!
visitUnreachableStatement: anUnreachableStatement
	"self overrides visitEnglobingErrorNode:"
	^ super visitEnglobingErrorNode: anUnreachableStatement! !

!ErrorNodeStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode
	^ aNode errorMessage.! !

!ErrorNodeStyler methodsFor: 'visiting' stamp: ''!
shouldStyleNode: aNode
	^ aNode isParseError! !

!ErrorNodeStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #error! !

!ErrorNonInteractive commentStamp: ''!
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: ''!
exception

	^ exception! !

!ErrorNonInteractive methodsFor: 'accessing' stamp: ''!
exception: anError

	exception := anError! !

!ErrorNonInteractive methodsFor: 'accessing' stamp: ''!
description
	^ String streamContents: [ :s |
		s nextPutAll: 'An attempt to use interactive tools detected, while in non-interactive mode'. 
		self messageText  ifNotEmpty: [ :message| 
			s cr; tab; nextPutAll: message ].
		self exception ifNotNil: [ :ex |
			s cr; tab; print: ex ]].! !

!ErrorNonInteractive methodsFor: 'exceptiondescription' stamp: ''!
defaultAction
	" log error and quit "
	
	^ UIManager default 
		quitFrom: self signalerContext 
		withMessage: self description! !

!ErrorNonInteractive class methodsFor: 'signalling' stamp: ''!
signalForException: anError

	^ self new
		exception: anError;
		signal! !

!ErrorWasInUIProcessTest methodsFor: 'tests' stamp: ''!
testErrorWasInUIProcessIsTrueWhenDebugSessionWasCreatedByTheUIProcess
	"Test that errorWasInUIProcess is true when the DebugSession was created by the UI process"
	
	self skipOnPharoCITestingEnvironment.
	SmalltalkImage current isHeadless ifFalse: [ ^ true ].
	context := [ 1+1] asContext.
	"Instead of creating a new process like the other debugger tests, we ask the default ui process to create the DebugSession"
	session := UIManager default uiProcess newDebugSessionNamed: 'test session' startedAt: context.
	self assert: (session errorWasInUIProcess)! !

!ErrorWasInUIProcessTest methodsFor: 'tests' stamp: ''!
testErrorWasInUIProcessIsFalseWhenDebugSessionWasCreatedByANewProcess
	"Test that errorWasInUIProcess is false if the DebugSession was created by a new process"
	self settingUpSessionAndProcessAndContextForBlock: [ 1+1].
	self assert: (session errorWasInUIProcess not)! !

!EvaluateCommandLineHandler commentStamp: ''!
Usage: eval [--help] [--save] [ --no-quit ] <smalltalk expression>
	--help                   list this help message
	--save                   save the image after evaluation of the expression
	--no-quit                if specified, the image continues runing after
	                         evaluating the <smalltalk expression>
	<smallltalk expression>  a valid Smalltalk expression which is evaluated and 
	                         the result is printed on stdout

Documentation:
A CommandLineHandler that reads a string from the command line, outputs the evaluated result and quits the image. 

This handler either evaluates the arguments passed to the image:
	pharo Pharo.image eval  1 + 2
	
or it can read directly from stdin:

	echo "1+2" | $PHARO_VM my.image eval

Important: don't manually save the image at the end of the expression by calling something like 'Smalltalk snapshot: true andSave: true'!! Instead, use the safer --save option.!
!EvaluateCommandLineHandler methodsFor: 'activation' stamp: ''!
argumentString
	| arguments skipArguments |
	
	"Now this is ugly... Coral would be nice here!! Basically we strip skipArguments if, and only if they appear at the beginning of arguments"
	skipArguments := #( '--no-quit' '--save' '-e' '--evaluate').

	arguments := (skipArguments includes: self arguments first)
		ifFalse: [ self arguments ]
		ifTrue: [
			(self arguments size >= 2 and: [ skipArguments includes: self arguments second ])
				ifTrue: [ self arguments allButFirst: 2 ]
				ifFalse: [ self arguments allButFirst ]].
		
	^ arguments joinUsing: Character space.! !

!EvaluateCommandLineHandler methodsFor: 'activation' stamp: ''!
evaluateArguments
	| argumentString |
	argumentString :=  self argumentString.
	argumentString ifEmpty: [ ^ self ].
	self evaluate: argumentString! !

!EvaluateCommandLineHandler methodsFor: 'activation' stamp: ''!
evaluateStdIn
	| stdin |
	stdin := Stdio stdin ifNil: [ ^ self ].
	stdin atEnd ifTrue: [ ^ self ].

	self flag: #pharoFixMe.	"the whole compilation machinery does not work with stdin directly, hence we load everything a buffer first"
	self evaluate: (String streamContents: [ :s | [ stdin atEnd ] whileFalse: [ stdin next ifNotNil: [ :char | s nextPut: char ] ] ])! !

!EvaluateCommandLineHandler methodsFor: 'commands' stamp: ''!
evaluate: aStream
	| result |
	[ 
	result := Smalltalk compiler evaluate: aStream.
	self hasSessionChanged
		ifFalse: [ 
			self stdout
				print: result;
				lf ] ]
		on: Error
		do: [ :error | self handleError: error ]! !

!EvaluateCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self activateHelp
		ifTrue: [  ^ self ].
		
	self arguments 
		ifEmpty: [ ^ self evaluateStdIn ].
		
	self evaluateArguments.
	
	(self hasOption: 'save')
		ifTrue: [ 
			^ Smalltalk 
				snapshot: true 
				andQuit: (self hasOption: 'no-quit') not ].
	
	(self hasOption: 'no-quit')
		ifFalse: [ self quit ]! !

!EvaluateCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'eval'! !

!EvaluateCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Directly evaluates passed in one line scripts'! !

!EvaluateCommandLineHandler class methodsFor: 'handler selection' stamp: ''!
isResponsibleFor: commandLineArguments
	"directly handle top-level -e and --evaluate options"
	commandLineArguments withFirstArgument: [ :arg| 
		(#('-e' '--evaluate') includes: arg)
			ifTrue: [ ^ true ]].
	
	^ commandLineArguments includesSubCommand: self commandName! !

!EventManager commentStamp: ''!
An EventManager is used to registers a 'observer' object's interest in in changes to an 'observed' object.  Then when the observed object is changed,  EventManager broadcasts an update message to all objects with a registered interest.  Finally, the EventManager 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 MorphicModel as examples.!
!EventManager methodsFor: 'accessing' stamp: ''!
actionMap
	^ actionMap
		ifNil:  [ self createActionMap ]
		ifNotNil: [ actionMap ]! !

!EventManager methodsFor: 'dependents access' stamp: ''!
removeDependent: anObject
	"Remove the given object as one of the receiver's dependents."

	self 
		removeActionsWithReceiver: anObject
		forEvent: self changedEventSelector.
	^ anObject! !

!EventManager methodsFor: 'copying' stamp: ''!
postCopy

	super postCopy.
	self releaseActionMap.! !

!EventManager methodsFor: 'accessing' stamp: ''!
updateableActionMap
	actionMap 
		ifNil: [ actionMap := self createActionMap ].
	^actionMap 
	! !

!EventManager methodsFor: 'dependents access' stamp: ''!
addDependent: anObject
	"Make the given object one of the receiver's dependents."

	self
		when: self changedEventSelector
		send: self updateEventSelector
		to: anObject.
	^anObject! !

!EventManager methodsFor: 'accessing' stamp: ''!
changedEventSelector

	^#changed:! !

!EventManager methodsFor: 'dependents access' stamp: ''!
dependents

	^(self actionSequenceForEvent: self changedEventSelector) asSet
		collect:
			[:each | each receiver]! !

!EventManager methodsFor: 'updating' stamp: ''!
changed: aParameter 
	"Receiver changed. The change is denoted by the argument aParameter. 
	Usually the argument is a Symbol that is part of the dependent's change 
	protocol. Inform all of the dependents."

	self 
		triggerEvent: self changedEventSelector
		with: aParameter! !

!EventManager methodsFor: 'dependents access' stamp: ''!
breakDependents
	"Remove all of the receiver's dependents."

	self removeActionsForEvent: self changedEventSelector! !

!EventManager methodsFor: 'accessing' stamp: ''!
releaseActionMap

    actionMap := nil! !

!EventManager methodsFor: 'accessing' stamp: ''!
updateEventSelector

	^#update:! !

!EventManager class methodsFor: 'accessing' stamp: ''!
updateableActionMapFor: anObject

    ^self actionMaps
        at: anObject
        ifAbsentPut: [self createActionMap]! !

!EventManager class methodsFor: 'initialization' stamp: ''!
initialize

	"self initialize."
	
	SessionManager default registerSystemClassNamed: self name! !

!EventManager class methodsFor: 'releasing' stamp: ''!
releaseActionMapFor: anObject

	self actionMaps
		removeKey: anObject
		ifAbsent: []! !

!EventManager class methodsFor: 'cleanup' stamp: ''!
cleanUp: aggressive
	"Dump all ActionMaps but only when we're aggressively cleaning"

	aggressive ifTrue: [ActionMaps := nil].! !

!EventManager class methodsFor: 'system startup' stamp: ''!
shutDown	
	self flushEvents.! !

!EventManager class methodsFor: 'cleanup' stamp: ''!
flushEvents
	"EventManager flushEvents"
	
	self actionMaps keysAndValuesDo:[:rcvr :evtDict| rcvr ifNotNil:[
		"make sure we don't modify evtDict while enumerating"
		evtDict keysDo: [:evtName| | msgSet |
			msgSet := evtDict at: evtName ifAbsent:[nil].
			(msgSet == nil) ifTrue:[rcvr removeActionsForEvent: evtName]]]].
	EventManager actionMaps finalizeValues. ! !

!EventManager class methodsFor: 'accessing' stamp: ''!
actionMapFor: anObject

    ^self actionMaps
        at: anObject
        ifAbsent: [self createActionMap]! !

!EventManager class methodsFor: 'accessing' stamp: ''!
actionMaps

	^ActionMaps ifNil: [ActionMaps := WeakIdentityKeyDictionary new]! !

!EventManagerTest methodsFor: 'private' stamp: ''!
addArg1: arg1
addArg2: arg2

	eventListener
		add: arg1;
		add: arg2! !

!EventManagerTest methodsFor: 'running - dependent action supplied arguments' stamp: ''!
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: 'private' stamp: ''!
getFalse

	^false! !

!EventManagerTest methodsFor: 'running - dependent action' stamp: ''!
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: ''!
testOneArgumentEvent

	eventSource when: #anEvent: send: #add: to: eventListener.
	eventSource triggerEvent: #anEvent: with: 9.
	self should: [eventListener includes: 9]! !

!EventManagerTest methodsFor: 'running - dependent action supplied arguments' stamp: ''!
testNoArgumentEventDependentSuppliedArgument

	eventSource when: #anEvent send: #add: to: eventListener with: 'boundValue'.
	eventSource triggerEvent: #anEvent.
	self should: [eventListener includes: 'boundValue']! !

!EventManagerTest methodsFor: 'running - dependent action' stamp: ''!
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 - broadcast query' stamp: ''!
testSingleValueSupplier

	eventSource
		when: #needsValue
		send: #getTrue
		to: self.
	succeeded := eventSource triggerEvent: #needsValue.
	self should: [succeeded]! !

!EventManagerTest methodsFor: 'running - broadcast query' stamp: ''!
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 - dependent action' stamp: ''!
testNoArgumentEvent

	eventSource when: #anEvent send: #heardEvent to: self.
	eventSource triggerEvent: #anEvent.
	self should: [succeeded]! !

!EventManagerTest methodsFor: 'private' stamp: ''!
heardEvent

	succeeded := true! !

!EventManagerTest methodsFor: 'running - copying' stamp: ''!
testCopy
	"Ensure that the actionMap is zapped when
	you make a copy of anEventManager"

	eventSource when: #blah send: #yourself to: eventListener.
	self denyEmpty: eventSource actionMap keys.
	self assertEmpty: eventSource copy actionMap keys! !

!EventManagerTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	eventSource := EventManager new.
	eventListener := Bag new.
	succeeded := false! !

!EventManagerTest methodsFor: 'running - remove actions' stamp: ''!
testRemoveActionsTwiceForEvent

	eventSource
		when: #anEvent send: #size to: eventListener;
		when: #anEvent send: #getTrue to: self;
		when: #anEvent: send: #fizzbin to: self.
	eventSource removeActionsForEvent: #anEvent.
	self assert: (eventSource hasActionForEvent: #anEvent) not.
	eventSource removeActionsForEvent: #anEvent.
	self assert: (eventSource hasActionForEvent: #anEvent) not.! !

!EventManagerTest methodsFor: 'running - dependent value' stamp: ''!
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' stamp: ''!
tearDown

	eventSource releaseActionMap.
	eventSource := nil.
	eventListener := nil.
	super tearDown.
! !

!EventManagerTest methodsFor: 'running - dependent action' stamp: ''!
testBlockReceiverNoArgs
	eventSource when: #anEvent evaluate:[self heardEvent].
	eventSource triggerEvent: #anEvent.
	self should: [succeeded]! !

!EventManagerTest methodsFor: 'private' stamp: ''!
getTrue: anArg

	^true! !

!EventManagerTest methodsFor: 'running - dependent action' stamp: ''!
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 - broadcast query' stamp: ''!
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 - dependent value' stamp: ''!
testReturnValueWithOneListener

	| value |
	eventSource
		when: #needsValue
		send: #yourself
		to: eventListener.
	value := eventSource triggerEvent: #needsValue.
	self should: [value == eventListener]! !

!EventManagerTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ EventManager! !

!EventManagerTest methodsFor: 'running - remove actions' stamp: ''!
testRemoveActionsForEvent

	eventSource
		when: #anEvent send: #size to: eventListener;
		when: #anEvent send: #getTrue to: self;
		when: #anEvent: send: #fizzbin to: self.
	eventSource removeActionsForEvent: #anEvent.
	self shouldnt: [eventSource hasActionForEvent: #anEvent]! !

!EventManagerTest methodsFor: 'private' stamp: ''!
getTrue

	^true! !

!EventManagerTest methodsFor: 'private' stamp: ''!
getFalse: anArg

	^false! !

!EventManagerTest methodsFor: 'running - remove actions' stamp: ''!
testRemoveActionsWithReceiver

	| action |
	eventSource
		when: #anEvent send: #size to: eventListener;
		when: #anEvent send: #getTrue to: self;
		when: #anEvent: send: #fizzbin to: self.
	self assert: (eventSource hasActionsWithReceiver: self).
	eventSource removeActionsWithReceiver: self.
	action := eventSource actionForEvent: #anEvent.
	self assert: (action respondsTo: #receiver).
	self assert: ((action receiver == self) not).
	self assert: ((eventSource hasActionsWithReceiver: self) not)! !

!EventManagerTest methodsFor: 'running - dependent value' stamp: ''!
testReturnValueWithNoListeners

	| value |
	value := eventSource triggerEvent: #needsValue.
	self should: [value == nil]! !

!ExactFloatPrintPolicy commentStamp: ''!
I am ExactFloatPrintPolicy.

Through FloatPrintPolicy and double dispatch I force Float>>#printOn:base: to dynamically use the slower but accurate way to print Floats using Float>>#absPrintExactlyOn:base:!
!ExactFloatPrintPolicy methodsFor: 'printing' stamp: ''!
absPrint: float on: stream base: base
	"Doube dispatch to the slower but accurate way to print"

	^ float absPrintExactlyOn: stream base: base! !

!ExampleBuilderMorph commentStamp: ''!
Morph with an inset border by default and theme access. Overrides openModal: to allow multiple free example dialogs to be presented.!
!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		icon: iconSelector
		getEnabled: enabledSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newAlphaImage: aForm help: helpText
	"Answer an alpha image morph."

	^self theme
		newAlphaImageIn: self
		image: aForm
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText
	"Answer a morph list for the given model."

	^self
		newMorphListFor: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: nil
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
deny: aStringOrText title: aString
	"Open a denial dialog."

	^self theme
		denyIn: self
		text: aStringOrText
		title: aString! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
question: aStringOrText
	"Open a question dialog."

	^self question: aStringOrText title: 'Question' translated! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
message: aStringOrText title: aString
	"Open a message dialog."

	^self theme
		messageIn: self
		text: aStringOrText
		title: aString! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: aModel
		label: aString
		offset: offset
		alpha: alpha
		getEnabled: enabledSel! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newString: aStringOrText style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: aStyle! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newColorPresenterFor: aModel getColor: getSel help: helpText
	"Answer a color presenter with the given selectors."

	^self theme
		newColorPresenterIn: self
		for: aModel
		getColor: getSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: #bottomLeft! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newImage: aForm
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newSeparator
	"Answer an horizontal separator."

	^self theme
		newSeparatorIn: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newScrollPaneFor: aMorph
	"Answer a new scroll pane morph to scroll the given morph."
	
	^self theme
		newScrollPaneIn: self
		for: aMorph! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newStack: controls
	"Answer a morph laid out with a stack of controls."

	^self theme
		newStackIn: self
		for: controls! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newLabelGroup: labelsAndControls
	"Answer a morph laid out with a column of labels and a column of associated controls.
	Controls having a vResizing value of #spaceFill will
	cause their row to use #spaceFill also, otherwise #shrinkWrap."

	^self theme
		newLabelGroupIn: self
		for: labelsAndControls! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newGroupboxForAll: controls
	"Answer a plain groupbox with the given controls."

	^self theme
		newGroupboxIn: self
		forAll: controls! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
message: aStringOrText
	"Open a message dialog."

	^self message: aStringOrText title: 'Information' translated! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newCancelButton
	"Answer a new cancel button."

	^self newCancelButtonFor: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newVerticalSeparator
	"Answer a vertical separator."

	^self theme
		newVerticalSeparatorIn: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText
	"Answer a list for the given model."

	^self
		newListFor: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: nil
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newNoButton
	"Answer a new No button."

	^self newNoButtonFor: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newYesButtonFor: aModel
	"Answer a new yes button."

	^self theme
		newYesButtonIn: self
		for: aModel! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
textEntry: aStringOrText
	"Open a text entry dialog."

	^self textEntry: aStringOrText title: 'Entry' translated! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title for: contentMorph
	"Answer a new pluggable dialog with the given content."

	^self theme
		newPluggableDialogWindowIn: self
		title: title
		for: contentMorph! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newToolbar
	"Answer a toolbar."

	^self theme
		newToolbarIn: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText
	"Answer a bracket slider with the given selectors."

	^self
		newBracketSliderFor: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum 
		getEnabled: nil
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: aClass
		default: defaultValue
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseColor
	"Answer the result of a color selector dialog ."

	^self chooseColor: Color black! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText
		entryCompletion: anEntryCompletion! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newGroupbox: aString
	"Answer a groupbox with the given label."

	^self theme
		newGroupboxIn: self
		label: aString! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title
	"Answer a new pluggable dialog with the given content."

	^self
		newPluggableDialogWindow: title
		for: nil! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel help: helpText
	"Answer a text entry for the given model."

	^self
		newTextEntryFor: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: nil 
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a bracket slider with the given selectors."

	^self theme
		newBracketSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseFont
	"Answer the result of a font selector dialog."

	^self chooseFont: nil! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newExpander: aString forAll: controls
	"Answer an expander with the given label and controls."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: controls! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
chooseExistingFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseExistingFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText
	"Open a question dialog."

	^self questionWithoutCancel: aStringOrText title: 'Question' translated! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseColor: aColor 
	"Answer the result of a color selector dialog with the given color."

	^self theme
		chooseColorIn: self
		title: 'Colour Selector' translated
		color: aColor! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseDirectory: title 
	"Answer the result of a file dialog with the given title, answer a directory."

	^self
		chooseDirectory: title
		path: nil! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText list: aList
	"Open a drop list chooser dialog."

	^self
		chooseDropList: aStringOrText
		title: 'Choose' translated
		list: aList! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel ghostText: ghostText getEnabled: enabledSel help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: String
		default: ''
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: false
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
chooseForSaveFileReference: 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
		chooseForSaveFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector
	"Answer a new tree morph."
	
	^self theme
		newTreeIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newWindowFor: aModel title: titleString
	"Answer a new window morph."
	
	^self theme
		newWindowIn: self
		for: aModel
		title: titleString! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newToolbar: controls
	"Answer a toolbar with the given controls."

	^self theme
		newToolbarIn: self
		for: controls! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newOKButtonFor: aModel getEnabled: enabledSel
	"Answer a new OK button."

	^self theme
		newOKButtonIn: self
		for: aModel
		getEnabled: enabledSel! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newStack
	"Answer a morph laid out as a stack."

	^self theme
		newStackIn: self
		for: #()! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newToolSpacer
	"Answer a tool spacer."

	^self theme
		newToolSpacerIn: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newTitle: aString for: control
	"Answer a morph laid out with a column with a title."

	^self theme
		newTitleIn: self
		label: aString
		for: control! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion

	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel 
		help: helpText
		entryCompletion: anEntryCompletion! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText
	"Answer an inremental slider with the given selectors."

	^self theme
		newIncrementalSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: min
		max: max
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newOKButtonFor: aModel
	"Answer a new OK button."

	^self
		newOKButtonFor: aModel
		getEnabled: nil! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newCancelButtonFor: aModel
	"Answer a new cancel button."

	^self theme
		newCancelButtonIn: self
		for: aModel! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector
	"Answer a text editor for the given model."

	^self theme
		newTextEditorIn: self
		for: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: menuSelector! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newSVSelector: aColor help: helpText
	"Answer a saturation-volume selector with the given color."

	^self theme
		newSVSelectorIn: self
		color: aColor
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newButtonLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new button text label."

	^self theme
		newButtonLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseFont: aFont 
	"Answer the result of a font selector dialog with the given initial font."

	^self theme
		chooseFontIn: self
		title: 'Font Selector' translated
		font: aFont! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString
	"Open an alert dialog."

	^self
		alert: aStringOrText
		title: aString
		configure: [:d | ]! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newString: aStringOrText
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: #plain! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newTabGroup: labelsAndPages
	"Answer a tab group with the given tab labels associated with pages."

	^self theme
		newTabGroupIn: self
		for: labelsAndPages! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newButtonLabel: aString
	"Answer a new button text label."

	^self
		newButtonLabelFor: nil
		label: aString
		getEnabled: nil! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString entryText: defaultEntryText
	"Open a text entry dialog."

	^self theme
		textEntryIn: self
		text: aStringOrText
		title: aString
		entryText: defaultEntryText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: cornerSymbol! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newLabelGroup: labelsAndControls font: aFont labelColor: aColor
	"Answer a morph laid out with a column of labels and a column of associated controls.
	Controls having a vResizing value of #spaceFill will
	cause their row to use #spaceFill also, otherwise #shrinkWrap."

	^self theme
		newLabelGroupIn: self
		for: labelsAndControls
		font: aFont
		labelColor: aColor! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseForSaveFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseForSaveFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow
	"Answer a new pluggable dialog."

	^self
		newPluggableDialogWindow: 'Dialog'! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newExpander: aString for: aControl
	"Answer an expander with the given label and control."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: {aControl}! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newExpander: aString
	"Answer an expander with the given label."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: #()! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseExistingFileReference: 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
		chooseExistingFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self theme
		newRadioButtonIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
question: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionIn: self
		text: aStringOrText
		title: aString! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newCloseButtonFor: aModel
	"Answer a new close button."

	^self theme
		newCloseButtonIn: self
		for: aModel! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newFuzzyLabel: aString
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: nil
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: nil! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newRow
	"Answer a morph laid out as a row."

	^self theme
		newRowIn: self
		for: #()! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
abort: aStringOrText title: aString
	"Open an error dialog."

	^self theme
		abortIn: self
		text: aStringOrText
		title: aString! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		alertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText
		entryCompletion: anEntryCompletion! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newNoButtonFor: aModel
	"Answer a new No button."

	^self theme
		newNoButtonIn: self
		for: aModel! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newOverflowRowForAll: aCollectionOfMorphs
	"Answer a new overflow row morph that provides a drop down for
	the given contents that are unable to fit the bounds."
	
	^self theme
		newOverflowRowIn: self
		forAll: aCollectionOfMorphs! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a morph list for the given model."

	^self theme
		newMorphListIn: self
		for: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText title: aString list: aList
	"Open a drop list chooser dialog."

	^self theme
		chooseDropListIn: self
		text: aStringOrText
		title: aString
		list: aList! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newYesButton
	"Answer a new Yes button."

	^self newYesButtonFor: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newHSVSelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVSelectorIn: self
		color: aColor
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: nil
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		getLabel: labelSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newPanel
	"Answer a new panel."

	^self theme
		newPanelIn: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newGroupbox: aString forAll: controls
	"Answer a groupbox with the given label and controls."

	^self theme
		newGroupboxIn: self
		label: aString
		forAll: controls! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
proceed: aStringOrText
	"Open a proceed dialog."

	^self proceed: aStringOrText title: 'Proceed' translated! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a drop list for the given model."

	^self theme
		newDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newToolbarHandle
	"Answer a toolbar handle."

	^self theme
		newToolbarHandleIn: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newLabel: aString
	"Answer a new text label."

	^self
		newLabelFor: nil
		label: aString
		getEnabled: nil! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
longMessage: aStringOrText title: aString
	"Open a (long) message dialog."

	^self theme
		longMessageIn: self
		text: aStringOrText
		title: aString! !

!ExampleBuilderMorph methodsFor: 'theme' stamp: ''!
theme
	"Answer the ui theme that provides controls."

	^ Smalltalk ui theme! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
centeredAlert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		centeredAlertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newToolDockingBar
	"Answer a tool docking bar."

	^self theme
		newToolDockingBarIn: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseColor: aColor title: label
	"Answer the user choice of a colour."
	
	^ self theme 
		chooseColorIn: self modalMorph
		title: (label ifNil: ['Choose Color' translated])
		color: aColor! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newMultistateButton
	"Answer a new multistate button morph.
	To be usable it needs to have fill styles assigned to various states along
	with mouse-up/down actions."
	
	^self theme
		newMultistateButtonIn: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newOKButton
	"Answer a new OK button."

	^self newOKButtonFor: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newHueSelector: aModel getHue: getSel setHue: setSel help: helpText
	"Answer a hue selector with the given selectors."

	^self theme
		newHueSelectorIn: self
		for: aModel
		getHue: getSel
		setHue: setSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		getLabel: labelSel
		getEnabled: enabledSel! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a morph drop list for the given model."

	^self theme
		newMorphDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newGroupbox
	"Answer a plain groupbox."

	^self theme
		newGroupboxIn: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newEmbeddedMenu
	"Answer a new menu."

	^self theme
		newEmbeddedMenuIn: self
		for: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newHSVASelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVASelectorIn: self
		color: aColor
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 
	"Answer a text editor for the given model."

	^self 
		newTextEditorFor: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: nil! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newGroupboxFor: control
	"Answer a plain groupbox with the given control."

	^self theme
		newGroupboxIn: self
		for: control! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newDialogPanel
	"Answer a new main dialog panel."

	^self theme
		newDialogPanelIn: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newImageFor: aModel get: getSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newImageIn: self
		for: aModel
		get: getSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newGroupbox: aString for: control
	"Answer a groupbox with the given label and control."

	^self theme
		newGroupboxIn: self
		label: aString
		for: control! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newMenuFor: aModel
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: aModel! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newString: aStringOrText font: aFont style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: aFont
		style: aStyle! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel 
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newMenu
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText
	"Answer an alpha channel selector with the given selectors."

	^self theme
		newAlphaSelectorIn: self
		for: aModel
		getAlpha: getSel
		setAlpha: setSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: enabledSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
deny: aStringOrText
	"Open a denial dialog."

	^self deny: aStringOrText title: 'Access Denied' translated! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: aModel
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: enabledSel! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionWithoutCancelIn: self
		text: aStringOrText
		title: aString! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString
	"Open a text entry dialog."

	^self
		textEntry: aStringOrText
		title: aString
		entryText: ''! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newText: aStringOrText
	"Answer a new text."

	^self theme
		newTextIn: self
		text: aStringOrText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self
		newRadioButtonFor: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newRow: controls
	"Answer a morph laid out with a row of controls."

	^self theme
		newRowIn: self
		for: controls! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		getLabel: labelSel
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newColumn: controls
	"Answer a morph laid out with a column of controls."

	^self theme
		newColumnIn: self
		for: controls! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newSliderFor: aModel getValue: getSel setValue: setSel help: helpText
	"Answer a slider with the given selectors."

	^self theme
		newSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: 0
		max: 1
		quantum: nil
		getEnabled: nil
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
chooseDirectory: title path: path
	"Answer the result of a file dialog with the given title, answer a directory."

	^self theme
		chooseDirectoryIn: self
		title: title
		path: path! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
alert: aStringOrText
	"Open an alert dialog."

	^self alert: aStringOrText title: 'Alert' translated! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
proceed: aStringOrText title: aString
	"Open a proceed dialog and answer true if not cancelled, false otherwise."

	^self theme
		proceedIn: self
		text: aStringOrText
		title: aString! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newCloseControlFor: aModel action: aValuable help: helpText
	"Answer a new cancel button."

	^self theme
		newCloseControlIn: self
		for: aModel
		action: aValuable
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel action: actionSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: nil 
		label: stringOrText
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newCloseButton
	"Answer a new close button."

	^self newCloseButtonFor: self! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newImage: aForm size: aPoint
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm
		size: aPoint! !

!ExampleBuilderMorph methodsFor: 'services' stamp: ''!
abort: aStringOrText
	"Open an error dialog."

	^self abort: aStringOrText title: 'Error' translated! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		useIndex: true
		help: helpText! !

!ExampleBuilderMorph methodsFor: 'controls' stamp: ''!
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 class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ExampleBuilderMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ExampleBuilderMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ExampleBuilderMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ExampleBuilderMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ExampleBuilderMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ExampleBuilderMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ExampleBuilderMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ExampleBuilderMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ExampleBuilderMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ExampleBuilderMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ExampleBuilderMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ExampleBuilderMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ExampleBuilderMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ExampleBuilderMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ExampleBuilderMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ExampleBuilderMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ExampleBuilderMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ExampleBuilderMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ExampleBuilderMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ExampleBuilderMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ExampleBuilderMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ExampleBuilderMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ExampleBuilderMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ExampleBuilderMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ExampleBuilderMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ExampleBuilderMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ExampleBuilderMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ExampleBuilderMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ExampleClassVariableTest commentStamp: ''!
Test for class variables!
!ExampleClassVariableTest methodsFor: 'tests' stamp: ''!
testMigrateClassVar
	"Add class variable using the builder interface and change it to another kind"
	
	| classVar |
	
	classVar := #ClassVar => ExampleClassVariableWithState.
	
	aClass := self make: [ :builder |
		builder 
			sharedVariables: {#ClassVar}
		].
	
	self assert: (aClass hasClassVarNamed: 'ClassVar').
	self assert: (aClass classVariableNamed: #ClassVar) class equals: ClassVariable.
	
	aClass classVarNamed: 'ClassVar' put: 5.
	
	aClass := self make: [ :builder |
		builder 
			sharedVariables: {classVar}
		].
	
	self assert: (aClass hasClassVarNamed: 'ClassVar').
	self assert: (aClass classVariableNamed: #ClassVar) class equals: ExampleClassVariableWithState.
	self assert: (aClass classVariableNamed: #ClassVar) read equals: 5.
	self assert: (aClass classVariableNamed: #ClassVar) definingClass equals: aClass.
	self assert: (aClass classVariableNamed: #ClassVar) owningClass equals: aClass! !

!ExampleClassVariableTest methodsFor: 'tests' stamp: ''!
testCreateClassWithClassVariable
	"Add class variable using the builder interface"
	
	| classVar |
	
	classVar := #ClassVar => ExampleClassVariableWithState.
	
	aClass := self make: [ :builder |
		builder 
			sharedVariables: {classVar}
		].
	
	self assert: (aClass hasClassVarNamed: 'ClassVar')


! !

!ExampleClassVariableTest methodsFor: 'tests' stamp: ''!
testCreateClassWithTwoClassVariable
	"Add class variable using the builder interface"
	
	| classVar1 classVar2 |
	
	classVar1 := #ClassVar1 => ExampleClassVariableWithState.
	classVar2 := #ClassVar2 => ExampleClassVariableWithState.
	
	aClass := self make: [ :builder |
		builder 
			sharedVariables: {classVar1. classVar2}
		].
	
	self assert: (aClass hasClassVarNamed: 'ClassVar1').
	self assert: (aClass hasClassVarNamed: 'ClassVar2')


! !

!ExampleClassVariableWithState commentStamp: ''!
I am an example for a class variable that stores the value in the variable. It behaves thus the same as a normal class variable, but the state is not stored in the class pool but in the variable itself.

Read and write is done via #read and #write:.!
!ExampleClassVariableWithState methodsFor: 'meta-object-protocol' stamp: ''!
write:	 anObject
	state := anObject
	 ! !

!ExampleClassVariableWithState methodsFor: 'meta-object-protocol' stamp: ''!
read
	^state! !

!ExampleForTest1 commentStamp: ''!
An example class at level 1 (directly below Object) used for testing class hierarchy!
!ExampleForTest1 methodsFor: 'accessing' stamp: ''!
aSuperclassVariable

	^ aSuperclassVariable! !

!ExampleForTest1 methodsFor: 'accessing' stamp: ''!
aSuperclassVariable: anObject

	aSuperclassVariable := anObject! !

!ExampleForTest11 commentStamp: ''!
An example class at level 2 (indirectly below Object) used for testing class hierarchy!
!ExampleForTest11 methodsFor: 'accessing' stamp: ''!
aSubclassVariable

	^ aSubclassVariable! !

!ExampleForTest11 methodsFor: 'accessing' stamp: ''!
aSubclassVariable: anObject

	aSubclassVariable := anObject! !

!ExampleForTest111 commentStamp: ''!
An example class at level 3 (indirectly below Object) used for testing class hierarchy!
!ExampleForTest112 commentStamp: ''!
An example class at level 3 (indirectly below Object) used for testing class hierarchy!
!ExampleForTest12 commentStamp: ''!
An example class at level 2 (indirectly below Object) used for testing class hierarchy!
!ExampleForTestWithSharedPool commentStamp: ''!
I am class for testing!
!ExampleRadioButtonModel class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!ExampleSetTest commentStamp: ''!
SUnit tests for example set!
!ExampleSetTest methodsFor: 'testing' stamp: ''!
testIncludes
	self assert: (full includes: 5).
	self assert: (full includes: #abc)! !

!ExampleSetTest methodsFor: 'testing' stamp: ''!
testGrow
	empty addAll: (1 to: 100).
	self assert: empty size equals: 100! !

!ExampleSetTest methodsFor: 'testing' stamp: ''!
testAdd
	empty add: 5.
	self assert: (empty includes: 5)! !

!ExampleSetTest methodsFor: 'testing' stamp: ''!
testOccurrences
	self assert: (empty occurrencesOf: 0) equals: 0.
	self assert: (full occurrencesOf: 5) equals: 1.
	full add: 5.
	self assert: (full occurrencesOf: 5) equals: 1! !

!ExampleSetTest methodsFor: 'testing' stamp: ''!
testRemove
	full remove: 5.
	self assert: (full includes: #abc).
	self deny: (full includes: 5)! !

!ExampleSetTest methodsFor: 'testing' stamp: ''!
testIllegal
	self 
		should: [empty at: 5] 
		raise: self defaultTestError.
	self 
		should: [empty at: 5 put: #abc] 
		raise: self defaultTestError! !

!ExampleSetTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	empty := Set new.
	full := Set with: 5 with: #abc! !

!ExampleSlotWithState commentStamp: ''!
I am a simple example for a Slot.

Instead of mapping to a field, I store the value myself. This means that all instances share the
slot, similar to a class variable.

I just override the methods for reflective read and write (#read and #write:to:), I do not bother to emit bytecode myself but rely on the fallback that the compiler will generate code for reflective read and write (see the emit* method of my superclass).

Smalltalk classInstaller make: [ :builder |
	builder name: #A;
	slots: { ExampleSlotWithState named: #iv };
	category: #Playground ].


In class A we can implement accessors:

iv
	^iv

iv: anObject
	iv := anObject


They look like normal ivar accesses, but in the background, the compiler delegated to the Slot the code generation, calling emit*, which leads
to the bytecode e.g. for the read:

21 <20> pushConstant: iv => TestSlot
22 <70> self
23 <E1> send: read:
24 <7C> returnTop

you could override the emit* methods to generate faster code, but to get something running it is not needed.

To test, e.g. you can set the slot from one object and read it from another:

A new iv: 6
A new iv 

Then inspect the slot: 

(A slotNamed: #iv) inspect!
!ExampleSlotWithState methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	^ value! !

!ExampleSlotWithState methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
	^value := aValue! !

!ExampleSlotWithStateTest methodsFor: 'tests' stamp: ''!
testExampleTwoSlotWithState
	" add two, remove one"
	aClass := self make: [ :builder | builder 
		slots: {#slot1 =>ExampleSlotWithState . #slot2 =>ExampleSlotWithState}].

	self assert: (aClass hasSlotNamed: #slot1).
	self assert: (aClass hasSlotNamed: #slot2).
	
	aClass := self make: [ :builder | builder  slots: {#slot2 =>ExampleSlotWithState}].
	self deny: (aClass hasSlotNamed: #slot1).
	self assert: (aClass hasSlotNamed: #slot2)! !

!ExampleSlotWithStateTest methodsFor: 'tests' stamp: ''!
testExampleSlotWithState
	| slot |
	slot := #slot1 => ExampleSlotWithState.
	aClass := self make: [ :builder | builder slots: {slot} ].
	self assert: (aClass hasSlotNamed: #slot1).

	"test reflective write and read"
	slot write: 5 to: aClass new.
	self assert: (slot read: aClass new) equals: 5.
	"test compiled read and write"
	self compileAccessorsFor: slot.
	aClass new slot1: 10.
	self assert: aClass new slot1 equals: 10! !

!ExampleSlotWithStateTest methodsFor: 'tests' stamp: ''!
testExampleClassSide
	" can we install a slot on the class side?"
	| slot |
	aClass := self make: [ :builder | builder classSlots: {#slot1 =>ExampleSlotWithState}].

	slot := aClass class slotNamed: #slot1.
	self assert: slot class equals: ExampleSlotWithState! !

!Exception commentStamp: ''!
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 Context>>valueUninterruptably (and by extension, #ensure: and #ifCurtailed:), and we imported the following methods with little or no modification:

Context>>terminateTo:
Context>>terminate
Context>>receiver:
Context>>answer:

Thanks, Craig!!!
!Exception methodsFor: 'handling' stamp: ''!
pass
	"Yield control to the enclosing exception action for the receiver."

	| nextHandler |
	nextHandler := handlerContext nextHandlerContext.
	handlerContext := nil.
	nextHandler handleSignal: self! !

!Exception methodsFor: 'testing' stamp: ''!
isDebuggerFailure
	^false! !

!Exception methodsFor: 'private' stamp: ''!
completeProcess: aProcess with: aContext
	"I am a hook during process completion in case one of my subclass wants to plug a special behavior.
	
	By default I return my signal context"

	^ self signalContext! !

!Exception methodsFor: '*SUnit-Core' stamp: ''!
sunitExitWith: aValue
 
	self return: aValue! !

!Exception methodsFor: 'handling' stamp: ''!
outer
	"Evaluate the enclosing exception action and return to here instead of signal if it resumes (see #resumeUnchecked:)."
	| prevOuterContext currentHandler |
	self isResumable 
		ifTrue: [
			prevOuterContext := outerContext. "required and accessed in resumeUnchecked:"
			outerContext := thisContext contextTag ].
	currentHandler := handlerContext.
	[self pass] ensure: [handlerContext := currentHandler].! !

!Exception methodsFor: '*JenkinsTools-Core' stamp: ''!
recordBackgroundFailureOf: aTestCase inHDTestReport: aHDTestReport
	
	"Here is a hook for specific reporting of background failures 
	triggered from processes forked during the test.
	
	By default exceptions just use a regular reporting logic"
	
	self recordResultOf: aTestCase inHDTestReport: aHDTestReport! !

!Exception methodsFor: 'private' stamp: ''!
defaultResumeValue
	"Answer the value that by default should be returned if the exception is resumed"
	
	^ nil! !

!Exception methodsFor: 'private' stamp: ''!
privHandlerContext

	^handlerContext! !

!Exception methodsFor: 'accessing' stamp: ''!
receiver
	^ self signalerContext receiver! !

!Exception methodsFor: 'accessing' stamp: ''!
signalerContext
	"Find the first sender of signal(:), the first context which is neither for an instance method nor for a class side method of Exception (or subclass).
	This will make sure that the same context is found for both, `Error signal` and `Error new signal`"

	^ signalContext findContextSuchThat: [ :context |
		(context receiver == self 
		or: [ context receiver == self class ]) not ]! !

!Exception methodsFor: 'accessing' stamp: ''!
description

	"Returns a textual description of the exception."

	"Must be overriden to return a specialized description "

	^ self defaultDescription! !

!Exception methodsFor: 'handling' stamp: ''!
freeze
	"Freeze the context stack to keep the exception usable outside the catch blocks"

	self freezeUpTo: thisContext! !

!Exception methodsFor: 'accessing' stamp: ''!
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: 'printing' stamp: ''!
printOn: stream

	stream nextPutAll: self description! !

!Exception methodsFor: 'handling' stamp: ''!
resume
	"Return from the message that signaled the receiver."

	self resume: self defaultResumeValue! !

!Exception methodsFor: 'handling' stamp: ''!
unhandledErrorAction
	"No one has handled this error, then I gave them a chance to decide how to debug it and I raise an UnhandledError. But it was not handled by anybody so that we are here (see nhandedError-defaultAction).
	It is the final action an exception can do which is normally a debugger in interactive image"

 	^ UIManager default unhandledErrorDefaultAction: self! !

!Exception methodsFor: '*Debugging-Core' stamp: ''!
retry
	"Abort an exception handler and re-evaluate its protected block."

	handlerContext restart! !

!Exception methodsFor: 'signaling' stamp: ''!
messageText: signalerText
	"Set an exception's message text."

	messageText := signalerText! !

!Exception methodsFor: '*JenkinsTools-Core' stamp: ''!
recordResultOf: aTestCase inHDTestReport: aHDTestReport
	
	"By default exceptions are not accounted in test result and just propogate the signal further.
	But subclasses should decide here how to record them in test result.

	This default logic is in SUnit for a long time 
	but in past it was in senders of this method which handles a predefined set of known exceptions"	
	self pass! !

!Exception methodsFor: 'signaling' stamp: ''!
signal
	"Ask ContextHandlers in the sender chain to handle this signal.  The default is to execute and return my defaultAction."
	<debuggerCompleteToSender>
	signalContext := thisContext contextTag.
	signaler ifNil: [ signaler := self receiver ].
	^ signalContext nextHandlerContext handleSignal: self! !

!Exception methodsFor: 'private' stamp: ''!
defaultReturnValue
	"Answer the value that by default should be returned if the exception is returned"
	
	^ nil! !

!Exception methodsFor: 'handling' stamp: ''!
resignalAs: replacementException
	"Signal an alternative exception in place of the receiver."
	signalContext resumeEvaluating: [replacementException signal]! !

!Exception methodsFor: 'handling' stamp: ''!
raiseUnhandledError
	"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! !

!Exception methodsFor: 'handling' stamp: ''!
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: '*SUnit-Core' stamp: ''!
manageTestProcessBy: aProcessMonitorTestService
	"By default we are recording any exception in the process monitor"
	
	aProcessMonitorTestService recordTestFailure: self! !

!Exception methodsFor: 'accessing' stamp: ''!
messageText
	"Return an exception's message text."

	^ messageText ifNil: [ String empty ]! !

!Exception methodsFor: '*Commander-Core' stamp: ''!
notifyUserOfCommand: aCommand

	self pass! !

!Exception methodsFor: 'handling' stamp: ''!
return: returnValue
	"Return the argument as the value of the block protected by the active exception handler."

	handlerContext return: returnValue! !

!Exception methodsFor: 'handling' stamp: ''!
defaultAction
	"No one has handled this error, but now give them a chance to decide how to debug it. 
	If none handles this either then open debugger (see UnhandedError-defaultAction).
	
	Note about naming here: 
	Even if not all exceptions are errors the absence of a handler for signaled exception is considered as an error by default. Therefore #defaultAction for Exception raises an error, an UnhandledError"

	^ self raiseUnhandledError! !

!Exception methodsFor: 'default' stamp: ''!
defaultDescription
	"Return a textual description of the exception."

	^ String streamContents: [ :stream | | mt |
		stream << self class name.
		(mt := self messageText) isEmptyOrNil
			ifFalse: [ stream << ': ' << mt ] ]! !

!Exception methodsFor: 'testing' stamp: ''!
isNested
	"Determine whether the current exception handler is within the scope of another handler for the same exception."

	^ handlerContext nextHandlerContext canHandleSignal: self! !

!Exception methodsFor: 'handling' stamp: ''!
return
	"Return nil as the value of the block protected by the active exception handler."

	self return: self defaultReturnValue! !

!Exception methodsFor: 'handling' stamp: ''!
resume: resumptionValue
	"Return resumptionValue as the value of the signal message."

	self isResumable ifFalse: [ IllegalResumeAttempt signal ].
	self resumeUnchecked: resumptionValue! !

!Exception methodsFor: 'accessing' stamp: ''!
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: '*Debugging-Core' stamp: ''!
retryUsing: alternativeBlock
	"Abort an exception handler and evaluate a new block in place of the handler's protected block."

	handlerContext restartWithNewReceiver: alternativeBlock! !

!Exception methodsFor: 'testing' stamp: ''!
isHandleableBy: aDebugger
	^ true! !

!Exception methodsFor: 'handling' stamp: ''!
searchFrom: aContext
	"Set the context where the handler search will start. "

	signalContext := aContext contextTag! !

!Exception methodsFor: 'signaling' stamp: ''!
signal: signalerText
	"Signal the occurrence of an exceptional condition with a specified textual description."

	self messageText: signalerText.
	^ self signal! !

!Exception methodsFor: 'handling' stamp: ''!
debug

	"requests a debugger on myself"

	<debuggerCompleteToSender>
	UIManager default requestDebuggerOpeningFor: self! !

!Exception methodsFor: 'accessing' stamp: ''!
tag
	"Return an exception's tag value."

	^ tag 
		ifNil: [ self messageText ]
		ifNotNil: [ tag ]! !

!Exception methodsFor: 'signaling' stamp: ''!
signalIn: context
	"Ask ContextHandlers in the sender chain starting at the given context to handle this signal. 
	The default is to execute and return my defaultAction."

	signalContext := context.
	signaler ifNil: [ signaler := self receiver ].
	^ signalContext nextHandlerContext handleSignal: self! !

!Exception methodsFor: 'private' stamp: ''!
privHandlerContext: aContextTag

	handlerContext := aContextTag! !

!Exception methodsFor: 'accessing' stamp: ''!
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: '*NewTools-Debugger-Extensions' stamp: ''!
stDebuggerInspectorNodesFor: aStDebuggerContext

	^ aStDebuggerContext exceptionNodesFor: self! !

!Exception methodsFor: 'testing' stamp: ''!
isResumable
	"Determine whether an exception is resumable."

	^ true! !

!Exception methodsFor: 'accessing' stamp: ''!
originException
	^ self! !

!Exception methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
signalContext

	^ signalContext! !

!Exception methodsFor: 'handling' stamp: ''!
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 class methodsFor: 'exceptioninstantiator' stamp: ''!
signal: message in: context
	"Signal the occurrence of an exceptional condition with a specified textual description in the given context."

	^ self new 
		messageText: message;
		signalIn: context! !

!Exception class methodsFor: 'exceptionselector' stamp: ''!
handles: exception
	"Determine whether an exception handler will accept a signaled exception."

	^ exception isKindOf: self! !

!Exception class methodsFor: 'testing' stamp: ''!
captureIfSignalledWhenStepping
	^false! !

!Exception class methodsFor: 'exceptioninstantiator' stamp: ''!
signal: message
	"Signal the occurrence of an exceptional condition with a specified textual description."

	^ self new signal: message! !

!Exception class methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
systemIconName

	^ #exceptionIcon! !

!Exception class methodsFor: 'exceptioninstantiator' stamp: ''!
signalIn: context
	"Signal the occurrence of an exceptional condition in the given context."

	^ self new signalIn: context! !

!Exception class methodsFor: 'exceptionselector' stamp: ''!
, anotherException
	"Create an exception set containing the receiver and anotherException"

	^ ExceptionSet new
		add: self;
		add: anotherException;
		yourself! !

!Exception class methodsFor: 'exceptioninstantiator' stamp: ''!
signal
	"Signal the occurrence of an exceptional condition."

	^ self new signal! !

!Exception class methodsFor: 'exceptionselector' stamp: ''!
- anotherException
	"Create an exception set containing the receiver and anotherException as exclusion."

	^ ExceptionSetWithExclusions new
		add: self;
		addExclusion: anotherException;
		yourself! !

!Exception class methodsFor: 'exceptioninstantiator' stamp: ''!
signal: message withTag: aTag
	"Signal the occurrence of an exceptional condition with a specified textual description including a tag for the exception."

	^ self new 
		messageText: message;
		tag: aTag; 
		signal! !

!ExceptionSet commentStamp: ''!
An ExceptionSet is a grouping of exception handlers which acts as a single handler.  Within the group, the most recently added handler will be the last handler found during a handler search (in the case where more than one handler in the group is capable of handling a given exception). !
!ExceptionSet methodsFor: 'exceptionselector' stamp: ''!
handles: anException
	"Determine whether an exception handler will accept a signaled exception."

	^ exceptions anySatisfy: [ :exception | exception handles: anException ]! !

!ExceptionSet methodsFor: 'exceptionselector' stamp: ''!
- anotherException
	"Create an exception set containnig the receiver
	and anotherException as an exclusion."

	^ ExceptionSetWithExclusions new
		add: self;
		addExclusion: anotherException;
		yourself! !

!ExceptionSet methodsFor: 'private' stamp: ''!
add: anException
	"Add anException to the exceptions that I handle"
	
	^ exceptions add: anException! !

!ExceptionSet methodsFor: 'exceptionselector' stamp: ''!
, anException
	"Return an exception set that contains the receiver and the argument exception. This is commonly used to specify a set of exception selectors for an exception handler."

	self add: anException! !

!ExceptionSet methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	exceptions := OrderedCollection new! !

!ExceptionSetWithExclusions commentStamp: ''!
I am ExceptionSetWithExclusions, an ExceptionSet that explicitely does not handle a number of exclusion Exceptions.!
!ExceptionSetWithExclusions methodsFor: 'private' stamp: ''!
addExclusion: exception
	"Add exception as an exclusion to me.
	I will explicitly not handle my exclusion exceptions."
	
	^ exclusions add: exception! !

!ExceptionSetWithExclusions methodsFor: 'exceptionselector' stamp: ''!
- exception
	"Add exception as an exclusion to me.
	I will explicitly not handle my exclusion exceptions."
	
	self addExclusion: exception! !

!ExceptionSetWithExclusions methodsFor: 'exceptionselector' stamp: ''!
handles: exception
	"Return true when I will handled exception.
	I extend my superclass behavior by explicitly 
	not handling a number of exclusion exceptions."

	^ (super handles: exception) 
			and: [ exclusions noneSatisfy: [ :each | each handles: exception ] ]! !

!ExceptionSetWithExclusions methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	exclusions := OrderedCollection new! !

!ExceptionTest commentStamp: ''!
SUnit tests for exceptions

Some of these tests are of the form:
`self assertSuccess: (ExceptionTester new runTest: <<<aSelector>>> )`
For example:
	The code of ExceptionTests>>#testDoubleOuterPass is `self assertSuccess: (ExceptionTester new runTest: #doubleOuterPassTest )`.
	In this example, <<<aSelector>>> = #doubleOuterPassTest.

Here is how these tests are performed:
- ExceptionTester has instance variables 'log' and 'suiteLog' of type OrderedCollection
- ExceptionTester>>#runTest: adds <<<aSelector>>> as a string to 'suiteLog' and clears 'log'
- ExceptionTester>>#runTest: performs the method named <<<aSelector>>>.
  <<<aSelector>>> has an exception-based control flow, and calls methods like #doSomething, #doSomethingElse etc... at some points of it. These methods just add specific strings to 'log' to build a sort of trace of where the execution went.
- If a MyTestError exception would leave method <<<aSelector>>> uncaught, it is caught, the incident is added to 'log', and <<<aSelector>>>'s execution is stopped
- After performing <<<aSelector>>>, ExceptionTester>>#runTest: performs its twin method: <<<aSelector>>>Results (In the example from above, it would be #doubleOuterPassTestResults). This twin method builds the expected value of 'log' by creating an OrderedCollection and filling it with the  right specific strings in the expected order.
- ExceptionTester>>#runTest: compares 'log' and the expected value of 'log'. If they are the same, it appends the 'succeeded' string to the '<<<aSelector>>>' string that was stored in 'suiteLog' earlier. If they are different, it appends the 'failed' string instead.
- Finally, ExceptionTests>>#assertSuccess: asserts that the first element of 'suiteLog' ends with the 'suceeded' string

!
!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testUnhandledExceptionShouldAllowToCatchWarning
	
	| warning caughtException |
	warning := Warning new.
	self runWithNoHandlers: [
		[ warning signal ] on: UnhandledException do: [ :err | caughtException := err ]
	].
	self assert: caughtException class equals: UnhandledError.
	self assert: caughtException exception equals: warning! !

!ExceptionTest methodsFor: 'private' stamp: ''!
runWithNoHandlers: aBlock
	"Executing the given block directly would go through all handlers of SUnit machinery.
	Here we simulate the clean environment with no outer handlers for possible block errors"
	| synchSemaphore result |
	synchSemaphore := Semaphore new. 
	[result := aBlock ensure: [synchSemaphore signal]] forkNamed: 'Test process'.
	"we should not wait forever in case of wrong behaviour 
	(general test timeout is disabled in #runCaseManaged)"
	(synchSemaphore wait: 2 seconds)
		ifTrue: [ self error: 'Timeout for block execution' ].
	^result! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testHandlingWhenThereIsSomeExclusionButDontApplies

	| wasHandled result |

	wasHandled := false.

	result := [ 
	ZeroDivide signalWithDividend: 1.
	2 ]
		on: Error - MessageNotUnderstood
		do: [ :exception | 
			wasHandled := true.
			exception return ].

	self
		assert: wasHandled;
		assert: result isNil! !

!ExceptionTest methodsFor: 'private' stamp: ''!
runCaseManaged
	"We should disable TestEnvironment to avoid any logic for unhandled errors from background processes.
	Some tests fork processes to ensure clean no handlers (SUnit catches errors for example)"
	
	^DefaultExecutionEnvironment beActiveDuring: [ self runCase]! !

!ExceptionTest methodsFor: 'private' stamp: ''!
assertSuccess: anExceptionTester
	self should: [ ( anExceptionTester suiteLog first) endsWith:  'succeeded'].! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testDoublePassOuter
	self assertSuccess: (ExceptionTester new runTest: #doublePassOuterTest )! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testHandlingWithExclusion

	| wasHandled  |

	wasHandled := false.

	self
		should: [ 
			[ ZeroDivide signalWithDividend: 1 ]
				on: Error - ZeroDivide
				do: [ :exception | 
					wasHandled := true.
					exception return ] ]
		raise: ZeroDivide.
	
	self deny: wasHandled! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSimpleEnsureTestWithUparrow
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithUparrow )! !

!ExceptionTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testSimpleRetry
	self assertSuccess: (ExceptionTester new runTest: #simpleRetryTest)! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testHandlingExceptionSetWithExclusion

	| wasHandled  |

	wasHandled := false.

	self
		should: [ 
			[ ZeroDivide signalWithDividend: 1 ]
				on: Error, ArithmeticError - ZeroDivide
				do: [ :exception | 
					wasHandled := true.
					exception return ] ]
		raise: ZeroDivide.
	
	self deny: wasHandled! !

!ExceptionTest methodsFor: 'tests - resignal' stamp: ''!
testResignalExceptionThatHasBeenSignaledTwice

	| shouldBe17 |
	shouldBe17 := nil.

	[ shouldBe17 := self methodSignallingZeroDivide ]
		on: ZeroDivide
		do: [ :e | e resume: 17 ].

	self assert: shouldBe17 notNil! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testHandlingWithSeveralExclusions
	| wasHandled |
	wasHandled := false.
	self
		should: [ 
			[ ZeroDivide signalWithDividend: 1 ]
				on: Error - Warning - ZeroDivide
				do: [ :exception | 
					wasHandled := true.
					exception return ] ]
		raise: ZeroDivide.
	self deny: wasHandled.
	
	self
		should: [ 
			[ ZeroDivide signalWithDividend: 1 ]
				on: Error - (Warning , ZeroDivide)
				do: [ :exception | 
					wasHandled := true.
					exception return ] ]
		raise: ZeroDivide.
	self deny: wasHandled.! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testHandlingWithSeveralExclusionsAndExceptionSetsHandling

	| wasHandled result |

	wasHandled := false.

	result := [ 
	ZeroDivide signalWithDividend: 1.
	2 ]
		on: Error - MessageNotUnderstood - Warning
		do: [ :exception | 
			wasHandled := true.
			exception return ].

	self
		assert: wasHandled;
		assert: result isNil.
		
	wasHandled := false.

	result := [ 
	ZeroDivide signalWithDividend: 1.
	2 ]
		on: Error - (MessageNotUnderstood , Warning)
		do: [ :exception | 
			wasHandled := true.
			exception return ].

	self
		assert: wasHandled;
		assert: result isNil.! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testResumableFallOffTheEndHandler
	self assertSuccess: (ExceptionTester new runTest: #resumableFallOffTheEndHandler )! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSignalFromHandlerActionTest
	self assertSuccess: (ExceptionTester new runTest: #signalFromHandlerActionTest )! !

!ExceptionTest methodsFor: 'tests' stamp: ''!
testResumeNonresumableUnhandledError

	"Ensure that the resuming an UnhandledError results in
	an IllegalResumeAttempt."

	| signalOccurred |
	self
		runWithNoHandlers: [ 
			[[ MyTestError signal ]
				on: UnhandledError
				do: [ :ex | ex resume: nil ]]
			on: IllegalResumeAttempt
			do: [:ex | signalOccurred := true. ex return ]].
	self assert: signalOccurred! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testUnhandledExceptionShouldAllowToCatchError
	
	| error caughtException |
	error := Error new.
	self runWithNoHandlers: [ 
		[ error signal ] on: UnhandledException do: [ :err | caughtException := err ]
	].
	self assert: caughtException class equals: UnhandledError.
	self assert: caughtException exception equals: error! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testUnhandledErrorWhenHandlerPassesOriginalException
	| executed |
	executed := false.
	self runWithNoHandlers: [
		[ 
			[ 1/0 ] on: UnhandledError do: [ :e | executed := true ]
		] on: ZeroDivide do: [:z | z pass].
	].
	self assert: executed! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSimpleResume
	self assertSuccess: (ExceptionTester new runTest: #simpleResumeTest )! !

!ExceptionTest methodsFor: 'tests' stamp: ''!
testDescription
   |anException|
	anException := Exception new.
	self assert: anException description isNotNil.
	self assert: anException description isString.
	"If the default exception desciption changes, this test will be broken"
	self assert: anException description equals: 'Exception'! !

!ExceptionTest methodsFor: 'tests - resignal' stamp: ''!
testResignalAs

	| answer |
	answer := [
		[3 zork]
			on: ZeroDivide
			do: [:ex | ex return: 5]
	] on: Error do: [:ex | ex resignalAs: ZeroDivide].
	self assert: answer == 5! !

!ExceptionTest methodsFor: 'tests' stamp: ''!
testDefaultDescription
   "Tests that the description of an Exception, is the defaultDescription"
   |anException|
	anException := Exception new.
	self assert: anException description equals: anException defaultDescription! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testDoubleResume
	self assertSuccess: (ExceptionTester new runTest: #doubleResumeTest )! !

!ExceptionTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testSimpleRetryUsing
	self assertSuccess: (ExceptionTester new runTest: #simpleRetryUsingTest)! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSimpleReturn
	self assertSuccess: (ExceptionTester new runTest: #simpleReturnTest )! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testCaptureIfSignalledWhenStepping
	self deny: Exception captureIfSignalledWhenStepping.
	self assert: Error captureIfSignalledWhenStepping.
	self deny: (Error allSubclasses anySatisfy: [ :c| c  captureIfSignalledWhenStepping]).
	self assert: (UnhandledException withAllSubclasses select:[:c| c captureIfSignalledWhenStepping]) size equals: 1.
	self assert: (UnhandledException withAllSubclasses select:[:c| c captureIfSignalledWhenStepping]) first identicalTo: Halt.! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSimpleOuter
	self assertSuccess: (ExceptionTester new runTest: #simpleOuterTest )! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSimpleEnsure
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTest )! !

!ExceptionTest methodsFor: 'tests - outer' stamp: ''!
testNonResumablePass

	self should: [
		[Error signal. 4] 
			on: Error 
			do: [:ex | ex pass. ex return: 5]
		] raise: Error! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testUnhandledExceptionShouldAllowToCatchHalt
	
	| halt caughtException |
	halt := Halt new.
	self runWithNoHandlers: [
		[ halt signal ] on: UnhandledException do: [ :err | caughtException := err ]
	].
	self assert: caughtException equals: halt! !

!ExceptionTest methodsFor: 'tests - resignal' stamp: ''!
testResignalAsUnwinds

	| unwound answer |
	unwound := false.
	answer := [
		[3 zork]
			on: ZeroDivide do: [:ex | self assert: unwound.  ex return: 5]
	] on: Error do: [:ex | [ex resignalAs: ZeroDivide] ifCurtailed: [unwound := true]].
	self assert: answer == 5! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testHandlerContext
	"A test ensuring that when evaluating the action block the exception environment is set to the handler context."

	| result |
	result := [ 
	[ 
	[ MyResumableTestError signal ]
		on: MyTestError
		do: [ 'handler 2' ] ]
		on: MyResumableTestError
		do: [ MyTestError signal ] ]
		on: MyTestError
		do: [ 'handler 1' ].
	self assert: 'handler 1' = result description: 'Incorrect handler'! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSimplePass
	self assertSuccess: (ExceptionTester new runTest: #simplePassTest )! !

!ExceptionTest methodsFor: 'tests - outer' stamp: ''!
testNonResumableOuter

	self should: [
		[Error signal. 4] 
			on: Error 
			do: [:ex | ex outer. ex return: 5]
		] raise: Error! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testUnhandledWarningShouldBeProcessedAsUnhandledError
	
	| warning caughtException |
	warning := Warning new.
	self runWithNoHandlers: [
		[ warning signal ] on: UnhandledError do: [ :err | caughtException := err ]
	].
	self assert: caughtException exception equals: warning! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSimpleEnsureTestWithNotification
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithNotification )! !

!ExceptionTest methodsFor: 'utilities' stamp: ''!
methodSignallingZeroDivide

	^ [ 1 / 0 ]
		  on: ZeroDivide
		  do: [ :e | e signal ]! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSimpleIsNested
	self assertSuccess: (ExceptionTester new runTest: #simpleIsNestedTest )! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testUnhandledErrorWhenNoHandlers
	| executed |
	executed := false.
	self runWithNoHandlers: [
		[ 1/0 ] on: UnhandledError do: [ :e | executed := true ]
	].
	self assert: executed! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testDoubleOuterPass
	self assertSuccess: (ExceptionTester new runTest: #doubleOuterPassTest )! !

!ExceptionTest methodsFor: 'tests - outer' stamp: ''!
testResumableOuter

	| result |
	result := [Notification signal. 4] 
		on: Notification 
		do: [:ex | ex outer. ex return: 5].
	self assert: result equals: 5! !

!ExceptionTest methodsFor: 'tests' stamp: ''!
testDefaultAction
	"Ensure that the resuming an UnhandledError when the underlying
	Exception is resumable, results in the resumption value serving
	as the result of the original #signal."

	| expected result |
	expected := #marker.
	self runWithNoHandlers: [ 
		[ result := MyResumableTestError signal ]
			on: UnhandledError
			do: [ :ex | ex resume: expected ] ].
	self assert: result equals: expected! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testNonResumableFallOffTheEndHandler
	self assertSuccess: (ExceptionTester new runTest: #nonResumableFallOffTheEndHandler )! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testUnhandledErrorWhenTwoHandlersPassOriginalException
	| executed |
	executed := false.
	self runWithNoHandlers: [
		[ [  
				[ 1/0 ] on: UnhandledError do: [ :e | executed := true ]
			] on: ZeroDivide do: [:z | z pass]
		] on: ZeroDivide do: [:z | z pass]
	].
	self assert: executed! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testNoTimeout
	self assertSuccess: (ExceptionTester new runTest: #simpleNoTimeoutTest )! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSimpleResignalAs
	self assertSuccess: (ExceptionTester new runTest: #simpleResignalAsTest )! !

!ExceptionTest methodsFor: 'tests - outer' stamp: ''!
testResumablePass
	| result |
	result := [ Notification signal.
	4 ]
		on: Notification
		do: [ :ex | 
			ex pass.
			ex return: 5 ].
	self assert: result equals: 4! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSignalWithTag
	| aTag |
	aTag := Object new.
	
	[ 
		DomainError signal: 'aMessage' withTag: aTag.
		self fail: 'The exception was not signaled'. 
	] on: DomainError do: [ :e | 
		self assert: e messageText equals: 'aMessage'.
		self assert: e tag equals: aTag.
	]! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testTimeoutWithZeroDuration
	self assertSuccess: (ExceptionTester new runTest: #simpleTimeoutWithZeroDurationTest )! !

!ExceptionTest methodsFor: 'tests - handling' stamp: ''!
testHandlerFromAction
	"A test ensuring that nested exceptions work as expected."

	| result |
	result := [ 
	[ 
	[ self error: 'trigger error' ]
		on: ZeroDivide
		do: [ :ex | 'inner' ] ]
		on: Error
		do: [ :ex | 3 / 0 ] ]
		on: ZeroDivide
		do: [ :ex | 'outer' ].
	self assert: 'outer' = result description: 'Incorrect handler'! !

!ExceptionTest methodsFor: 'tests - exceptiontester' stamp: ''!
testSimpleEnsureTestWithError
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithError )! !

!ExceptionTester commentStamp: ''!
Utility class to test exceptions

For a partial explaination of how this class is used, look at the comment of class ExceptionTests.!
!ExceptionTester methodsFor: 'tests' stamp: ''!
simpleEnsureTestWithNotification

	[self doSomething.
	self methodWithNotification.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
simplePassTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex |
			self doYetAnotherThing.
			ex pass "expecting handler in #runTest:"]! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
simpleResignalAsTest
	"ExceptionTester new simpleResignalAsTest"

	[self doSomething.
	MyTestNotification signal.
	self doSomethingElse]
		on: MyTestNotification
		do:
			[:ex | ex resignalAs: MyTestError new]! !

!ExceptionTester methodsFor: 'signaledexception results' stamp: ''!
simpleResignalAsTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
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 results' stamp: ''!
simpleOuterTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'suites' stamp: ''!
runBasicANSISignaledExceptionTests

	self basicANSISignaledExceptionTestSelectors
		do:
			[:eachTestSelector |
			self runTest: eachTestSelector]! !

!ExceptionTester methodsFor: 'results' stamp: ''!
signalFromHandlerActionTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: ''!
simpleNoTimeoutTestResults

	^OrderedCollection new
		add: self doSomethingString;
		yourself! !

!ExceptionTester methodsFor: 'tests' stamp: ''!
signalFromHandlerActionTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[self doYetAnotherThing.
			MyTestError signal]! !

!ExceptionTester methodsFor: 'tests' stamp: ''!
warningTest

	self log: 'About to signal warning.'.
	Warning signal: 'Ouch'.
	self log: 'Warning signal handled and resumed.'! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
iterationsBeforeTimeout

	^ iterationsBeforeTimeout! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
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 results' stamp: ''!
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: ''!
doublePassOuterTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'tests' stamp: ''!
simpleTimeoutTest

	| n |
	[1 to: 1000000 do: [ :i | n := i. self doSomething ] ]
		valueWithin: 50 milliSeconds onTimeout:
			[ self iterationsBeforeTimeout: n.
			self doSomethingElse ]! !

!ExceptionTester methodsFor: 'logging' stamp: ''!
contents

	^( self log
		inject: (String new: 80) writeStream
		into: 
			[:result :item |
			result 
				cr; 
				nextPutAll: item;
				yourself] ) contents! !

!ExceptionTester methodsFor: 'testing' stamp: ''!
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: ''!
simpleTimeoutWithZeroDurationTest

	[ self doSomething ]
		valueWithin: 0 seconds onTimeout:
			[ self doSomethingElse ].! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
doSomethingString

	^'Do something.'! !

!ExceptionTester methodsFor: 'results' stamp: ''!
simpleEnsureTestWithUparrowResults

	^OrderedCollection new
		add: self doSomethingString;
"		add: self doSomethingElseString;"
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
simpleIsNestedTest
	"uses resignalAs:"

	[ self doSomething.
	MyTestError signal.
	self doSomethingElse 
	] on: MyTestError do: [ :exception |
		"expecting to detect handler in #runTest:"
		exception isNested 
			ifTrue: [
				self doYetAnotherThing.
				exception resignalAs: MyTestNotification new ]]! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
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: 'logging' stamp: ''!
logTestResult: aString

	| index |
	index := self suiteLog size.
	self suiteLog 
		at: index
		put: ((self suiteLog at: index), ' ', aString)! !

!ExceptionTester methodsFor: 'results' stamp: ''!
resumableFallOffTheEndHandlerResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingExceptionalString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'tests' stamp: ''!
nonResumableFallOffTheEndHandler
	
	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do: [:ex | self doSomethingExceptional].
	self doYetAnotherThing! !

!ExceptionTester methodsFor: 'results' stamp: ''!
simpleEnsureTestWithNotificationResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingElseString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
doSomethingElseString

	^'Do something else.'! !

!ExceptionTester methodsFor: 'signaledexception results' stamp: ''!
simpleRetryTestResults

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			add: self doSomethingString;
			add: self doSomethingElseString;
			yourself! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
doSomethingExceptionalString

	^'Do something exceptional.'! !

!ExceptionTester methodsFor: 'tests' stamp: ''!
simpleNoTimeoutTest

	[ self doSomething ]
		valueWithin: 1 day onTimeout:
			[ self doSomethingElse ].! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
simpleReturnTest

	| it |
	it :=
		[self doSomething.
		MyTestError signal.
		self doSomethingElse]
			on: MyTestError
			do: [:ex | ex return: 3].
	it = 3 ifTrue: [self doYetAnotherThing]! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
basicANSISignaledExceptionTestSelectors

	^#( simpleIsNestedTest simpleOuterTest doubleOuterTest doubleOuterPassTest doublePassOuterTest simplePassTest simpleResignalAsTest simpleResumeTest simpleRetryTest simpleRetryUsingTest simpleReturnTest)! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: ''!
doYetAnotherThing

	self log: self doYetAnotherThingString! !

!ExceptionTester methodsFor: 'results' stamp: ''!
simpleEnsureTestWithErrorResults

	^OrderedCollection new
		add: self doSomethingString;
		add: 'Unhandled Exception';
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'logging' stamp: ''!
clearLog

	log := nil! !

!ExceptionTester methodsFor: 'results' stamp: ''!
nonResumableFallOffTheEndHandlerResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingExceptionalString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: ''!
doSomethingElse

	self log: self doSomethingElseString! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
log
	^ log ifNil: [ log := OrderedCollection new ]! !

!ExceptionTester methodsFor: 'tests' stamp: ''!
simpleEnsureTest

	[self doSomething.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
testString

	^'This is only a test.'! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: ''!
methodWithNotification

	MyTestNotification signal: self testString! !

!ExceptionTester methodsFor: 'logging' stamp: ''!
log: aString

	self log add: aString! !

!ExceptionTester methodsFor: 'tests' stamp: ''!
simpleEnsureTestWithUparrow

	[self doSomething.
	true ifTrue: [^nil].
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].! !

!ExceptionTester methodsFor: 'results' stamp: ''!
doubleResumeTestResults

       ^OrderedCollection new
               add: self doSomethingString;
               add: self doSomethingElseString;
               add: self doYetAnotherThingString;
               yourself! !

!ExceptionTester methodsFor: 'signaledexception results' stamp: ''!
simplePassTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
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: 'pseudo actions' stamp: ''!
doSomethingExceptional

	self log: self doSomethingExceptionalString! !

!ExceptionTester methodsFor: 'results' stamp: ''!
simpleTimeoutTestResults

	| things |
	things := OrderedCollection new: self iterationsBeforeTimeout.

	self iterationsBeforeTimeout timesRepeat: [ things add: self  doSomethingString ].
	things add: self doSomethingElseString.

	^ things! !

!ExceptionTester methodsFor: 'suites' stamp: ''!
runBasicTests

	self basicTestSelectors
		do:
			[:eachTestSelector |
			self runTest: eachTestSelector]! !

!ExceptionTester methodsFor: 'signaledexception results' stamp: ''!
simpleReturnTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: ''!
simpleEnsureTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingElseString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'signaledexception results' stamp: ''!
doubleOuterPassTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'signaledexception results' stamp: ''!
simpleRetryUsingTestResults

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			yourself! !

!ExceptionTester methodsFor: 'signaledexception results' stamp: ''!
simpleIsNestedTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: ''!
simpleTimeoutWithZeroDurationTestResults

	^OrderedCollection new
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
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: 'pseudo actions' stamp: ''!
methodWithError

	MyTestError signal: self testString! !

!ExceptionTester methodsFor: 'tests' stamp: ''!
simpleEnsureTestWithError

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: ''!
doSomething

	self log: self doSomethingString! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
iterationsBeforeTimeout: anInteger

	iterationsBeforeTimeout := anInteger! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
doYetAnotherThingString

	^'Do yet another thing.'! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
simpleRetryUsingTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex | ex retryUsing: [self doYetAnotherThing]]! !

!ExceptionTester methodsFor: 'logging' stamp: ''!
logTest: aSelector

	self suiteLog add: aSelector! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
suiteLog

	suiteLog == nil
		ifTrue: [suiteLog := OrderedCollection new].
	^suiteLog! !

!ExceptionTester methodsFor: 'suites' stamp: ''!
runAllTests
	"ExceptionTester new runAllTests"

	self
		runBasicTests;
		runBasicANSISignaledExceptionTests! !

!ExceptionTester methodsFor: 'accessing' stamp: ''!
basicTestSelectors
	^ #(#simpleEnsureTest #simpleEnsureTestWithNotification #simpleEnsureTestWithUparrow #simpleEnsureTestWithError #signalFromHandlerActionTest #resumableFallOffTheEndHandler #nonResumableFallOffTheEndHandler #doubleResumeTest #simpleTimeoutWithZeroDurationTest #simpleTimeoutTest simpleNoTimeoutTest)! !

!ExceptionTester methodsFor: 'tests' stamp: ''!
resumableFallOffTheEndHandler

	[self doSomething.
	MyTestNotification signal.
	self doSomethingElse]
		on: MyTestNotification
		do: [:ex | self doSomethingExceptional].
	self doYetAnotherThing! !

!ExceptionTester methodsFor: 'signaledexception tests' stamp: ''!
doublePassOuterTest
	"uses #resume"

	[[[self doSomething.
	MyTestNotification signal.
	self doSomethingExceptional]
		on: MyTestNotification
		do: [:ex | ex pass.
			self doSomethingExceptional]]
			on: MyTestNotification
			do: [:ex | ex outer.
				self doSomethingElse]]
				on: MyTestNotification
				do: [:ex | self doYetAnotherThing. ex resume]! !

!ExceptionTester methodsFor: 'tests' stamp: ''!
doubleResumeTest

       [self doSomething.
       MyResumableTestError signal.
       self doSomethingElse.
       MyResumableTestError signal.
       self doYetAnotherThing]
               on: MyResumableTestError
               do: [:ex | ex resume].! !

!ExecutionCounter commentStamp: ''!
I am a meta-object that can be put on any AST node to count execution

To install a watchpoint in a node: 
	ExecutionCounter installOn: aNode
	
Class CounterIconStyler then renders an icon in the editor, mouse over it to see the current counter value.!
!ExecutionCounter methodsFor: 'counter' stamp: ''!
increase
	count := count + 1! !

!ExecutionCounter methodsFor: 'accessing' stamp: ''!
node: anObject
	node := anObject! !

!ExecutionCounter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	count := 0.! !

!ExecutionCounter methodsFor: 'accessing' stamp: ''!
link
	^ link! !

!ExecutionCounter methodsFor: 'add/remove' stamp: ''!
install

	link := MetaLink new 
				metaObject: self;
				selector: #increase;
				options: #(+ optionAnnounce).
	node link: link.
	self class allCounters at: node put: self.! !

!ExecutionCounter methodsFor: 'accessing' stamp: ''!
node
	^ node! !

!ExecutionCounter methodsFor: 'accessing' stamp: ''!
count
	^ count! !

!ExecutionCounter methodsFor: 'initialization' stamp: ''!
reset
	count := 0! !

!ExecutionCounter methodsFor: 'add/remove' stamp: ''!
uninstall
	node hasExecutionCounter ifFalse: [ ^self ].
	link uninstall.
	self class allCounters removeKey: node.! !

!ExecutionCounter class methodsFor: 'all' stamp: ''!
debugWorldMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #'Reset Counters')
		order: 1;
		parent: #Counters;
		help: 'Reset the counters on the executions counters.';
		action: [ ExecutionCounter resetAll ]! !

!ExecutionCounter class methodsFor: 'class initialization' stamp: ''!
initialize
	self registerInterestToSystemAnnouncement ! !

!ExecutionCounter class methodsFor: 'system annoucements' stamp: ''!
handleMethodRemoved: anAnnouncement
	self removeFromMethod: anAnnouncement method! !

!ExecutionCounter class methodsFor: 'cleanup' stamp: ''!
resetAll
	self allCounters values do: [ :counter | counter reset ].
	Counters := nil! !

!ExecutionCounter class methodsFor: 'accessing' stamp: ''!
allCounters
	^ Counters ifNil: [ Counters := WeakKeyDictionary new ]! !

!ExecutionCounter class methodsFor: 'system annoucements' stamp: ''!
handleMethodModified: anAnnouncement
	self removeFromMethod: anAnnouncement oldMethod! !

!ExecutionCounter class methodsFor: 'cleanup' stamp: ''!
removeAll
	self allCounters values do: [ :aWatchpoint| aWatchpoint uninstall].
	Counters := nil.! !

!ExecutionCounter class methodsFor: 'system annoucements' stamp: ''!
handleClassRemoved: anAnnouncement
	self allCounters copy do: [ :breakpoint |
		breakpoint link methods
			detect: [ :m | m methodClass = anAnnouncement classRemoved ]
			ifFound: [ self allCounters remove: breakpoint ] ]! !

!ExecutionCounter class methodsFor: 'instance creation' stamp: ''!
installOn: aRBProgramNode
	^self new
		node: aRBProgramNode;
		install.! !

!ExecutionCounter class methodsFor: 'cleanup' stamp: ''!
removeFromMethod: aMethod 
	self allCounters copy do: [ :counter |
		counter link methods
			detect: [ :m | m == aMethod ]
			ifFound: [ counter uninstall] ]! !

!ExecutionCounter class methodsFor: 'class initialization' stamp: ''!
registerInterestToSystemAnnouncement
	<systemEventRegistration>

	SystemAnnouncer uniqueInstance unsubscribe: self.
	SystemAnnouncer uniqueInstance weak when: MethodRemoved send: #handleMethodRemoved: to: self.
	SystemAnnouncer uniqueInstance weak when: MethodModified send: #handleMethodModified: to: self.
	SystemAnnouncer uniqueInstance weak when: ClassRemoved send: #handleClassRemoved: to: self! !

!ExecutionCounter class methodsFor: 'cleanup' stamp: ''!
removeFrom: aNode

	(self allCounters at: aNode ifAbsent: [ ^self ]) uninstall! !

!ExecutionCounterTest methodsFor: 'counting' stamp: ''!
testCounting
	counter := ExecutionCounter installOn: node.
	10 timesRepeat:[ReflectivityExamples new exampleAssignment].
	self assert: counter count equals: 10! !

!ExecutionCounterTest methodsFor: 'removing' stamp: ''!
testUninstallCounter
	counter := ExecutionCounter installOn: node.
	counter uninstall.
	self deny: node hasExecutionCounter ! !

!ExecutionCounterTest methodsFor: 'running' stamp: ''!
tearDown 	
	counter ifNotNil:[counter uninstall].
	counter2 ifNotNil:[counter2 uninstall].
	super tearDown! !

!ExecutionCounterTest methodsFor: 'adding' stamp: ''!
testGlobalCounterReferenceAfterInstallation
	counter := ExecutionCounter installOn: node.
	self assert: (ExecutionCounter allCounters includesKey: node).
	self assert: (ExecutionCounter allCounters at: node) identicalTo: counter.
	self assert: (counter link methods includes: node methodNode compiledMethod)! !

!ExecutionCounterTest methodsFor: 'removing' stamp: ''!
testGlobalCounterReferenceAfterRemovingFromMethod
	counter := ExecutionCounter installOn: node.
	counter2 := ExecutionCounter installOn: node2.
	ExecutionCounter removeFromMethod: node methodNode compiledMethod.
	self deny: (ExecutionCounter allCounters includesKey: node).
	self deny: (ExecutionCounter allCounters includesKey: node2).
	self assertEmpty: counter link methods.
	self assertEmpty: counter2 link methods! !

!ExecutionCounterTest methodsFor: 'adding' stamp: ''!
testInstallCounter
	counter := ExecutionCounter installOn: node.
	self assert: node hasExecutionCounter! !

!ExecutionCounterTest methodsFor: 'removing' stamp: ''!
testRemoveCounterFromMethod
	counter := ExecutionCounter installOn: node.
	ExecutionCounter removeFromMethod: node methodNode compiledMethod.
	self deny: node hasExecutionCounter! !

!ExecutionCounterTest methodsFor: 'counting' stamp: ''!
testReseting
	counter := ExecutionCounter installOn: node.
	10 timesRepeat:[ReflectivityExamples new exampleAssignment].
	counter reset.
	self assert: counter count equals: 0! !

!ExecutionCounterTest methodsFor: 'counting' stamp: ''!
testCountingAfterReset
	counter := ExecutionCounter installOn: node.
	10 timesRepeat:[ReflectivityExamples new exampleAssignment].
	counter reset.
	ReflectivityExamples new exampleAssignment.
	self assert: counter count equals: 1! !

!ExecutionCounterTest methodsFor: 'removing' stamp: ''!
testGlobalCounterReferenceAfterUninstallInstallation
	counter := ExecutionCounter installOn: node.
	counter uninstall.
	self deny: (ExecutionCounter allCounters includesKey: node).
	self assertEmpty: counter link methods! !

!ExecutionCounterTest methodsFor: 'counting' stamp: ''!
testMultipleCounters
	counter := ExecutionCounter installOn: node.
	counter2 := ExecutionCounter installOn: node2.
	10 timesRepeat:[ReflectivityExamples new exampleAssignment].
	self assert: counter count equals: 10.
	self assert: counter2 count equals: 10! !

!ExecutionCounterTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
	super setUp.
	node := (ReflectivityExamples >> #exampleAssignment) ast body children second.
	node2 := (ReflectivityExamples >> #exampleAssignment) ast body children last! !

!ExecutionEnvironment commentStamp: ''!
I am  special meta object  represent current execution environment for active process.
I allow to manage new forked child processes.

When I am installed on process I will receive message #prepareForNewProcess: for every forked child process.

By default I am not installed on any process. And  DefaultExecutionEnvironment instance is returned for callers which does nothing. 

Tools could define specific environment to provide specific hooks for code execution in context of them.
For example SUnit installs special TestExecutionEnvironment to manage all forked processes during test!
!ExecutionEnvironment methodsFor: 'controlling' stamp: ''!
deactivated
	"Method is called just after uninstallation when current environment become different.
	Any cleanup logic could be here"! !

!ExecutionEnvironment methodsFor: 'controlling' stamp: ''!
prepareForNewProcess: aProcess
	self subclassResponsibility! !

!ExecutionEnvironment methodsFor: 'controlling' stamp: ''!
beActiveDuring: aBlock

	CurrentExecutionEnvironment activate: self for: aBlock! !

!ExecutionEnvironment methodsFor: 'controlling' stamp: ''!
activated
	"Method is called just after installation as current environment.
	Any preparation logic could be here"! !

!ExecutionEnvironment methodsFor: '*SUnit-Core' stamp: ''!
runTestCase: aTestCase

	self subclassResponsibility ! !

!ExecutionEnvironment methodsFor: 'testing' stamp: ''!
isTest
	^false! !

!ExecutionEnvironment methodsFor: '*SUnit-Core' stamp: ''!
runTestsBy: aBlock

	self subclassResponsibility ! !

!ExecutionEnvironmentStub commentStamp: ''!
I am stub to test ExecutionEnvironment's!
!ExecutionEnvironmentStub methodsFor: 'accessing' stamp: ''!
forkedProcesses
	^ forkedProcesses! !

!ExecutionEnvironmentStub methodsFor: 'controlling' stamp: ''!
prepareForNewProcess: aProcess 
	forkedProcesses add: aProcess! !

!ExecutionEnvironmentStub methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	forkedProcesses := OrderedCollection new! !

!ExecutionEnvironmentStub methodsFor: 'accessing' stamp: ''!
forkedProcesses: anObject
	forkedProcesses := anObject! !

!Exit commentStamp: ''!
An Exit is an exception that quit the image without saving with a given success status.

Exit signalFaillure: 'something went wrong'!
!Exit methodsFor: 'accessing' stamp: ''!
status
	^ status! !

!Exit methodsFor: 'accessing' stamp: ''!
status: anInteger
	status := anInteger .! !

!Exit methodsFor: 'accessing' stamp: ''!
defaultAction
 	self messageText isEmpty
		ifFalse: [ self printMessage ].
	Smalltalk exit: self status! !

!Exit methodsFor: 'accessing' stamp: ''!
printMessage
	|stderr|
	stderr := VTermOutputDriver stderr.
	self isSuccess ifFalse: [ stderr red ].
	stderr
		nextPutAll: self messageText; lf;
		clear.! !

!Exit methodsFor: 'testing' stamp: ''!
isSuccess
	^self status = 0! !

!Exit methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream space print: self status.! !

!Exit class methodsFor: 'signalling' stamp: ''!
signalSuccess: aMessage 
 	^self success signal: aMessage! !

!Exit class methodsFor: 'instance creation' stamp: ''!
failure
	^ self status: 1! !

!Exit class methodsFor: 'signalling' stamp: ''!
signalFailure: aMessage
 	^ self failure signal: aMessage! !

!Exit class methodsFor: 'signalling' stamp: ''!
signalSuccess
 	^self success signal! !

!Exit class methodsFor: 'instance creation' stamp: ''!
success
	^ self status: 0! !

!Exit class methodsFor: 'instance creation' stamp: ''!
status: aPositiveInteger
	^ self new
		status: aPositiveInteger;
		yourself! !

!Exit class methodsFor: 'signalling' stamp: ''!
signalFailure
 	^ self failure signal! !

!ExpanderMorph commentStamp: ''!
A morph that can expand or collapse to show its contents.!
!ExpanderMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		changeTableLayout;
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		titleMorph: self defaultTitleMorph;
		expanded: false! !

!ExpanderMorph methodsFor: 'operations' stamp: ''!
addedMorph: aMorph
	"Notify the receiver that the given morph was just added."

	aMorph == self titleMorph ifFalse: [
		self titleMorph ifNotNil: [
			aMorph
				visible: self expanded;
				disableTableLayout: self expanded not]]! !

!ExpanderMorph methodsFor: 'accessing' stamp: ''!
expanded: aBoolean
	"Set whether the title is expanded."
	
	self titleMorph expanded: aBoolean! !

!ExpanderMorph methodsFor: 'accessing' stamp: ''!
titleMorph
	"Answer the value of titleMorph"

	^ titleMorph! !

!ExpanderMorph methodsFor: 'accessing' stamp: ''!
font
	"Answer the title font"

	^self titleMorph font! !

!ExpanderMorph methodsFor: 'accessing' stamp: ''!
font: aFont
	"Set the title font"

	self titleMorph font: aFont! !

!ExpanderMorph methodsFor: 'operations' stamp: ''!
showMorphs: aBoolean
	"Hide/Show the other morphs."

	self submorphs do: [:m |
		m == self titleMorph ifFalse: [
			m
				visible: aBoolean;
				disableTableLayout: aBoolean not]]! !

!ExpanderMorph methodsFor: 'operations' stamp: ''!
fixLayout
	"Fix the owner layout, nasty!!"

	self owner ifNil: [ ^ self ].
	self owner
		allMorphsDo: [ :m | 
			(m respondsTo: #resetExtent)
				ifTrue: [ 
					self defer: (MessageSend receiver: m selector: #resetExtent).
					self defer: (MessageSend receiver: m selector: #setScrollDeltas) ].
			(m isKindOf: self class)
				ifTrue: [ self defer: (MessageSend receiver: m selector: #adoptPaneColor) ] ].
	self defer: (MessageSend receiver: self owner selector: #changed)! !

!ExpanderMorph methodsFor: 'updating' stamp: ''!
update: aspect
	"Update the receiver."

	aspect = #expanded
		ifTrue: [self spaceFillWeight: (self expanded
					ifTrue: [1]
					ifFalse: [0]).
				self showMorphs: self expanded.
				self fixLayout.
				self expanded
					ifTrue: [self announce: (ExpanderMorphExpanded on: self)]
					ifFalse: [self announce: (ExpanderMorphContracted on: self)]]! !

!ExpanderMorph methodsFor: 'accessing' stamp: ''!
expanded
	"Answer whether the title is expanded."
	
	^self titleMorph expanded! !

!ExpanderMorph methodsFor: 'operations' stamp: ''!
announce: anAnnouncement
	"see Announcements packages.
	No need to announce if no subscribers."
	
	announcer ifNotNil: [announcer announce: anAnnouncement]! !

!ExpanderMorph methodsFor: 'accessing' stamp: ''!
titleMorph: aMorph
	"Set the value of titleMorph"

	titleMorph ifNotNil: [titleMorph delete; removeDependent: self].
	titleMorph := aMorph.
	aMorph ifNotNil: [
		aMorph addDependent: self.
		 self addMorph: aMorph]! !

!ExpanderMorph methodsFor: 'accessing' stamp: ''!
announcer: anObject

	announcer := anObject! !

!ExpanderMorph methodsFor: 'operations' stamp: ''!
titleText: aStringOrText

	self titleMorph titleText: aStringOrText! !

!ExpanderMorph methodsFor: 'initialization' stamp: ''!
defaultTitleMorph
	"Answer a default title morph for the receiver."

	^ExpanderTitleMorph basicNew
		basicTheme: self theme;
		initialize;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		basicTheme: nil! !

!ExpanderMorph methodsFor: 'operations' stamp: ''!
expandedSizingRigid
	"Set the vResizing to be (temporarily) #rigid."

	self expanded ifTrue: [self vResizing: #rigid]! !

!ExpanderMorph methodsFor: 'accessing' stamp: ''!
announcer
	"Answer the receiver's announcer, creating if required."
	
	^ announcer ifNil: [ announcer := Announcer new ]! !

!ExpanderMorph class methodsFor: 'instance creation' stamp: ''!
titleText: aStringOrText
	"Answer a new instance of the receiver with the given title text."

	^self new titleText: aStringOrText! !

!ExpanderMorphAnnouncement commentStamp: ''!
Common superclass for expander announcements!
!ExpanderMorphAnnouncement methodsFor: 'accessing' stamp: ''!
expanderMorph: anObject

	expanderMorph := anObject! !

!ExpanderMorphAnnouncement methodsFor: 'accessing' stamp: ''!
expanderMorph

	^ expanderMorph! !

!ExpanderMorphAnnouncement class methodsFor: 'instance creation' stamp: ''!
on: anExpanderMorph
	"Answer a new announcement for the given expander."

	^self new expanderMorph: anExpanderMorph! !

!ExpanderMorphAnnouncement class methodsFor: 'testing' stamp: ''!
isAbstract 

	 ^self == ExpanderMorphAnnouncement! !

!ExpanderMorphContracted commentStamp: ''!
I am an Announcement that occurs when an ExpanderMorph is contracted (rolled-up).!
!ExpanderMorphExpanded commentStamp: ''!
I am an Announcement that occurs when an ExpanderMorph is expanded (rolled-down).!
!ExpanderTitleMorph commentStamp: ''!
The titlebar area for and ExpanderMorph. Includes title label and expand/collapse button.!
!ExpanderTitleMorph methodsFor: 'accessing' stamp: ''!
labelMorph
	"Answer the value of labelMorph"

	^ labelMorph! !

!ExpanderTitleMorph methodsFor: 'accessing' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		expanded: false;
		changeTableLayout;
		borderStyle: self defaultBorderStyle;
		layoutInset: (self theme expanderTitleInsetFor: self);
		listDirection: #leftToRight;
		listCentering: #center;
		wrapCentering: #center;
		buttonMorph: self newExpandButtonMorph;
		addMorph: self buttonMorph;
		labelMorph: self newLabelMorph;
		on: #mouseUp send: #toggleExpanded to: self! !

!ExpanderTitleMorph methodsFor: 'accessing' stamp: ''!
buttonMorph
	"Answer the value of buttonMorph"

	^ buttonMorph! !

!ExpanderTitleMorph methodsFor: 'accessing' stamp: ''!
expanded: aBoolean
	"Set the value of expanded"

	expanded := aBoolean.
	self
		changed: #expanded;
		changed: #expandLabel! !

!ExpanderTitleMorph methodsFor: 'private' stamp: ''!
buttonWidth
	"Answer based on scrollbar size."
	
	^(self theme scrollbarThickness + 3)
		max: self theme expanderTitleControlButtonWidth! !

!ExpanderTitleMorph methodsFor: 'accessing' stamp: ''!
font
	"Answer the label font"

	^((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph])
		ifTrue: [self labelMorph font]! !

!ExpanderTitleMorph methodsFor: 'accessing' stamp: ''!
font: aFont
	"Set the label font"

	((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph])
		ifTrue: [self labelMorph font: aFont]! !

!ExpanderTitleMorph methodsFor: 'instance creation' stamp: ''!
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: 'instance creation' stamp: ''!
newLabelMorph
	"Answer a new label morph for the receiver."

	^LabelMorph new
		hResizing: #spaceFill;
		vResizing: #shrinkWrap! !

!ExpanderTitleMorph methodsFor: 'operations' stamp: ''!
expandLabel
	"Answer the label for the expand button."

	^AlphaImageMorph new image: (
		ScrollBarMorph
			arrowOfDirection: (self expanded ifTrue: [#top] ifFalse: [#bottom])
			size: self buttonWidth - 3
			color: self paneColor darker)! !

!ExpanderTitleMorph methodsFor: 'operations' stamp: ''!
toggleExpanded
	"Toggle the expanded state."

	self expanded: self expanded not! !

!ExpanderTitleMorph methodsFor: 'accessing' stamp: ''!
expanded
	"Answer the value of expanded"

	^ expanded! !

!ExpanderTitleMorph methodsFor: 'style' stamp: ''!
themeChanged
	"Update the button corner style from default
	to match the receiver."
	
	super themeChanged.
	self buttonMorph cornerStyle: self cornerStyle! !

!ExpanderTitleMorph methodsFor: 'accessing' stamp: ''!
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 contrastingBlackAndWhiteColor.
	self changed: #expandLabel! !

!ExpanderTitleMorph methodsFor: 'accessing' stamp: ''!
buttonMorph: anObject
	"Set the value of buttonMorph"

	buttonMorph := anObject! !

!ExpanderTitleMorph methodsFor: 'operations' stamp: ''!
titleText: aStringOrText
	"Set the text if the title morph is capable."

	((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph])
		ifTrue: [self labelMorph contents: aStringOrText]! !

!ExpanderTitleMorph methodsFor: 'accessing' stamp: ''!
defaultBorderStyle
	"Answer the default border style for the receiver."

	^BorderStyle raised width: 1! !

!ExpanderTitleMorph methodsFor: 'protocol' stamp: ''!
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: 'geometry' stamp: ''!
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: 'style' stamp: ''!
normalFillStyle
	"Return the normal fillStyle of the receiver."
	
	^self theme expanderTitleNormalFillStyleFor: self! !

!ExpressionEvaluated commentStamp: ''!
This announcement correspond to code evaluation.  For example, a DoIt or PrintIt evaluated in a workspace raises one of this announcements.!
!ExpressionEvaluated methodsFor: 'accessing' stamp: ''!
expressionEvaluated: anObject
	
	expressionEvaluated := anObject! !

!ExpressionEvaluated methodsFor: 'accessing' stamp: ''!
context
	
	^ context! !

!ExpressionEvaluated methodsFor: 'accessing' stamp: ''!
expressionEvaluated
	
	^ expressionEvaluated! !

!ExpressionEvaluated methodsFor: 'temporal for remove' stamp: ''!
item
	^expressionEvaluated! !

!ExpressionEvaluated methodsFor: '*Calypso-SystemQueries' stamp: ''!
shouldBeConsideredByCalypsoEnvironment
	^false! !

!ExpressionEvaluated methodsFor: 'accessing' stamp: ''!
context: anObject
	
	context := anObject! !

!ExpressionEvaluated methodsFor: 'temporal for remove' stamp: ''!
expression
	^self expressionEvaluated! !

!ExpressionEvaluated class methodsFor: 'instance creation' stamp: ''!
expression: theEvaluatedExpression
	^self expression: theEvaluatedExpression context: nil! !

!ExpressionEvaluated class methodsFor: 'instance creation' stamp: ''!
expression: theEvaluatedExpression context: anExecutionContext
	^self new
			expressionEvaluated: theEvaluatedExpression;
			context: anExecutionContext;
			yourself! !

!ExtendedDatePrinter commentStamp: ''!
I extend the behavior of BasicDatePrinter with the whole format supported in Pharo!
!ExtendedDatePrinter methodsFor: 'printing' stamp: ''!
printDate: aDate format: formatArray on: aStream

	"Print a description of aDate 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 either 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 |
	aDate 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 ] ] ]! !

!ExternalAddress commentStamp: ''!
An ExternalAddress is an opaque handle to objects outside Pharo memory (e.g., a pointer).!
!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
uint32AtOffset: zeroBasedOffset
	<primitive: 635>
	^ self integerAt: zeroBasedOffset + 1 size: 4 signed: false! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
int8AtOffset: zeroBasedOffset
	<primitive: 632>
	^ self integerAt: zeroBasedOffset + 1 size: 1 signed: true! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
signedLongAt: byteIndex put: value
	^ self int32AtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
doubleAt: byteIndex put: value
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self float64AtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
char16AtOffset: zeroBasedOffset
	<primitive: 641>
	^ (self integerAt: zeroBasedOffset + 1 size: 2 signed: false) asCharacter! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
int16AtOffset: zeroBasedOffset
	<primitive: 634>
	^ self integerAt: zeroBasedOffset + 1 size: 2 signed: true! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
uint64AtOffset: zeroBasedOffset
	<primitive: 637>
	^ self integerAt: zeroBasedOffset + 1 size: 8 signed: false! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
unsignedLongLongAt: byteIndex put: value
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self uint64AtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
int32AtOffset: zeroBasedOffset
	<primitive: 636>
	^ self integerAt: zeroBasedOffset + 1 size: 4 signed: true! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
boolean8AtOffset: zeroBasedOffset put: value
	<primitive: 645>
	^ self integerAt: zeroBasedOffset + 1 put: (value ifTrue:[1] ifFalse:[0]) size: 1 signed: false! !

!ExternalAddress methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper
	aGeneralMapper visitExternalAddress: self! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
unsignedCharAt: byteIndex put: aCharacter
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self char8AtOffset: byteIndex - 1 put: aCharacter! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
signedShortAt: byteIndex
	^ self int16AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
unsignedLongLongAt: byteIndex
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self uint64AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
char8AtOffset: zeroBasedOffset put: value
	<primitive: 655>
	^ self integerAt: zeroBasedOffset + 1 put: value asInteger size: 1 signed: false! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
fromAddress: aNumber
	^ self fromInteger: aNumber! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
pointerAutoRelease
	"Same as #pointer (see its comment for detals), but contents are garbage collected automatically"
	^ self pointer autoRelease! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
char32AtOffset: zeroBasedOffset
	<primitive: 642>
	^ (self integerAt: zeroBasedOffset + 1 size: 4 signed: false) asCharacter! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
char16AtOffset: zeroBasedOffset put: value
	<primitive: 656>
	^ self integerAt: zeroBasedOffset + 1 put: value asInteger size: 2 signed: false! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
float64AtOffset: zeroBasedOffset
	<primitive: 644>
	
	^ FFIBackend current on: self float64At: zeroBasedOffset + 1
! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
pointerAtOffset: zeroBasedOffset put: value
	<primitive: 654>
	"Store a pointer object at the given byte address"
	value isExternalAddress ifFalse:
		[^self error:'Only external addresses can be stored'].
	1 to: ExternalAddress wordSize do:
		[:i|
		self unsignedByteAt: zeroBasedOffset+i put: (value basicAt: i)].
	^value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
unsignedByteAt: byteIndex
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self uint8AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
signedCharAt: byteIndex put: aCharacter
	^ self char8AtOffset: byteIndex - 1 put: aCharacter! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
uint32AtOffset: zeroBasedOffset put: value
	<primitive: 650>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 4 signed: false! !

!ExternalAddress methodsFor: 'private' stamp: ''!
asByteArrayPointer
	"Answer a ByteArray containing a copy of pointer to the contents of the receiver."
	| sz |
	^(ByteArray basicNew: (sz := self size))
		replaceFrom: 1 to: sz with: self startingAt: 1 "answers self"! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
getHandle
	
	^ self! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
float32AtOffset: zeroBasedOffset
	<primitive: 643>
	
	^ FFIBackend current on: self float32At: zeroBasedOffset + 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
pointerAt: byteIndex put: value
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self pointerAtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	| dstAddress srcAddress repSize |
	
	self flag: #pharoTodo. "Maybe replace it with a primitive (like the one at Alien)?"
	repSize := stop - start + 1.
	dstAddress := start = 1 
		ifTrue: [ self ] 
		ifFalse: [ self + (start - 1) ].
	srcAddress := repStart = 1 
		ifTrue: [ replacement ] 
		ifFalse: [ replacement copyFrom: repStart to: repStart + repSize ].	
	LibC memCopy: srcAddress to: dstAddress size: repSize! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
uint16AtOffset: zeroBasedOffset
	<primitive: 633>
	^ self integerAt: zeroBasedOffset + 1 size: 2 signed: false! !

!ExternalAddress methodsFor: 'private' stamp: ''!
asExternalPointer
	"No need to convert."
	^self! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
boolean8AtOffset: zeroBasedOffset
	<primitive: 630>
	^ (self integerAt: zeroBasedOffset + 1 size: 1 signed: false) ~= 0! !

!ExternalAddress methodsFor: '*UnifiedFFI-private' stamp: ''!
packToArity: arity
	"This will 'pack' a pointer to a certain arity. 
	What does this means? Let's say I have a method who will be called with a ** arity (that's 'arity 2'): 
	
	method: aPointer
		self ffiCall: #( method ( MyExternalObjectClass **aPointer) )
		
	This usually means that method will put a pointer in the address of aPointer. 
	And what I actually want is this pointer. So I do Something like this: 
	
	p := MyExternalObjectClass new.
	self mehod: p.
	
	And I expect to have 'p' correctly initialized on return. 
	Well... tha's not so simple :)
	
	When compiling #method:, UnifiedFFI needs to first 'pack' the pointer (which means to 
	take a pointer of a pointer of a pointer... as many pointers as arity solicited), and then, 
	after call, it needs to 'unpack' all this pointers (see #unpackFromArity: method)  
	"
	| rolledPointer |
		
	rolledPointer := self.
	"Start in 2 because first pointer is self"
	2 to: arity do: [ :index | rolledPointer := rolledPointer pointerAutoRelease ].
	^ rolledPointer! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
uint16AtOffset: zeroBasedOffset put: value
	<primitive: 648>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 2 signed: false! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
int8AtOffset: zeroBasedOffset put: value
	<primitive: 647>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 1 signed: true! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
doubleAt: byteIndex
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self float64AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
readArrayOf: aType until: aBlock
	"Reads an array of aType until aBlock returns true.
	 this is an util to extract arrays from answers style char ** or int*, etc. 
	 Example: 
	
		someAddress readArrayOf: #uint32 until: [ :each | each isZero ].
		someAddress readArrayOf: #'void *' until: [ :each | each isNull ].
	"

	| externalType |
	"resolve type if needed"
	externalType := aType isString
		ifTrue: [ FFIExternalType resolveType: aType ]
		ifFalse: [ aType ].

	"then build the array"
	^ Array
		streamContents: [ :array | 
			| address last count |
			address := self.
			count := 0.
			[ address isNull
				or: [ last := externalType handle: address at: 1.
					count := count + 1.
					aBlock cull: last cull: count ] ]
				whileFalse: [ array nextPut: last.
					address := address + externalType typeSize ] ]! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
copyFrom: startIndex to: endIndex
	| result size |
	size := endIndex - startIndex + 1.
	result := ByteArray new: size. 
	LibC memCopy: (self + (startIndex - 1)) to: result size: size.
	^ result! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
unsignedCharAt: byteIndex
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self char8AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: 'accessing' stamp: ''!
isExternalAddress
	"Return true if the receiver describes the address of an object in the outside world"
	^true! !

!ExternalAddress methodsFor: '*UnifiedFFI-private' stamp: ''!
adoptAddress: anExternalAddress
	anExternalAddress = 0 ifTrue: [ ^ self beNull ].
	1 to: self size do: [ :index | 
		self basicAt: index put: (anExternalAddress at: index) ]! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
int32AtOffset: zeroBasedOffset put: value
	<primitive: 651>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 4 signed: true! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
signedLongAt: byteIndex
	^ self int32AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
signedLongLongAt: byteIndex put: value
	^ self int64AtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
signedShortAt: byteIndex put: value
	^ self int16AtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
uint8AtOffset: zeroBasedOffset
	<primitive: 631>
	^ self integerAt: zeroBasedOffset + 1 size: 1 signed: false! !

!ExternalAddress methodsFor: '*UnifiedFFI-private' stamp: ''!
unpackFromArity: arity
	"This will 'unpack' a pointer from a certain arity. See #unpackToArity: for a better explanation."
	| rolledPointer |
		
	rolledPointer := self.
	"Start in 2 because first pointer is self"
	2 to: arity do: [ :index | rolledPointer := rolledPointer pointerAt: 1 ].
	^ rolledPointer	! !

!ExternalAddress methodsFor: 'finalization' stamp: ''!
finalize
	"I am an executor (a copy) of an ExternalAddress that was just garbage collected.
	I must finalize. my mission is to free memory"
	self isNull ifTrue: [^self].
	self free! !

!ExternalAddress methodsFor: 'initialization' stamp: ''!
free

	^ FFIBackend current free: self! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
asExternalAddress

	^ self! !

!ExternalAddress methodsFor: 'accessing' stamp: ''!
byteAt: byteOffset
	"Go through a different primitive since the receiver describes data in the outside world"
	^self unsignedByteAt: byteOffset! !

!ExternalAddress methodsFor: 'comparing' stamp: ''!
= other

	self == other ifTrue: [ ^ true ].
	self species == other species ifFalse: [ ^ false ].
	1 to: self size do: [ :index | 
		(self at: index) = (other at: index) ifFalse: [ ^ false ] ].
	
	^ true! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
int16AtOffset: zeroBasedOffset put: value
	<primitive: 649>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 2 signed: true! !

!ExternalAddress methodsFor: 'converting' stamp: ''!
fromInteger: address
	"set my handle to point at address."
	"Do we really need this? bf 2/21/2001 23:48"

	| sz pointer |
	sz := self size.
	pointer := ByteArray new: sz.
	pointer integerAt: 1 put: address size: sz signed: false.
	self basicAt: 1 put: (pointer byteAt: 1);
		basicAt: 2 put: (pointer byteAt: 2);
		basicAt: 3 put: (pointer byteAt: 3);
		basicAt: 4 put: (pointer byteAt: 4).
	sz = 8 ifTrue:
		[self basicAt: 5 put: (pointer byteAt: 5);
			basicAt: 6 put: (pointer byteAt: 6);
			basicAt: 7 put: (pointer byteAt: 7);
			basicAt: 8 put: (pointer byteAt: 8)]! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
float32AtOffset: zeroBasedOffset put: value
	<primitive: 658>
	
	^ FFIBackend current on: self float32At: zeroBasedOffset + 1 put: value! !

!ExternalAddress methodsFor: 'copying' stamp: ''!
shallowCopy
	"Re-implemented to avoid superclass call to #new:"
	"But superclass's shallowCopy sends basicNew: and basicNew: is ok. eem 2/21/2016 15:31"
	^self clone! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
signedLongLongAt: byteIndex
	^ self int64AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
float64AtOffset: zeroBasedOffset put: value

	<primitive: 659>
	^ FFIBackend current
		  on: self
		  float64At: zeroBasedOffset + 1
		  put: value! !

!ExternalAddress methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
thunk
	^ self! !

!ExternalAddress methodsFor: 'printing' stamp: ''!
printOn: aStream
	"print this as a hex address ('@ 16rFFFFFFFF') to distinguish it from ByteArrays"

	aStream nextPutAll: '@ '; nextPutAll: (self asInteger storeStringBase: 16 length: 11 padded: true)! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
booleanAt: byteIndex
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self boolean8AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
signedCharAt: byteOffset
	^ self char8AtOffset: byteOffset - 1! !

!ExternalAddress methodsFor: 'converting' stamp: ''!
asInteger
	"convert address to integer"
	^ self asByteArrayPointer integerAt: 1 size: self size signed: false! !

!ExternalAddress methodsFor: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	^ self! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
copyFromOffset: startZeroBasedOffset to: endZeroBasedOffset
	^ self copyFrom: startZeroBasedOffset + 1 to: endZeroBasedOffset + 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
int64AtOffset: zeroBasedOffset put: value
	<primitive: 653>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 8 signed: true! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
int64AtOffset: zeroBasedOffset
	<primitive: 638>
	^ self integerAt: zeroBasedOffset + 1 size: 8 signed: true! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
floatAt: byteIndex
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self float32AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
pointerAt: byteIndex
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self pointerAtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
unsignedByteAt: byteIndex put: value
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self uint8AtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
booleanAt: byteIndex put: value
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self boolean8AtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
pointerAtOffset: zeroBasedOffset
	<primitive: 639>
	"Answer a pointer object stored at the given byte address"
	| addr |
	addr := ExternalAddress new.
	1 to: ExternalAddress wordSize do:
		[:i|
		addr basicAt: i put: (self unsignedByteAt: zeroBasedOffset+i)].
	^addr! !

!ExternalAddress methodsFor: 'converting' stamp: ''!
fromCString
	| index aByte |

	^ (ByteArray streamContents: [ :aStream |
			index := 1.
			[(aByte := self unsignedByteAt: index) = 0] 
				whileFalse: [
					aStream nextPut: aByte.
					index := index + 1]]) utf8Decoded! !

!ExternalAddress methodsFor: 'accessing' stamp: ''!
byteAt: byteOffset put: value
	"Go through a different primitive since the receiver describes data in the outside world"
	^self unsignedByteAt: byteOffset put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
uint64AtOffset: zeroBasedOffset put: value
	<primitive: 652>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 8 signed: false! !

!ExternalAddress methodsFor: '*UnifiedFFI-private' stamp: ''!
unpackHandleFromArity: arity
	^ (self unpackFromArity: arity) unsignedLongAt: 1
	! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
unsignedShortAt: byteIndex
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self uint16AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: 'testing' stamp: ''!
isNull
	"Answer true if I am a null pointer"
	1 to: self size do:[:i| (self at: i) = 0 ifFalse:[^false]].
	^true! !

!ExternalAddress methodsFor: 'initialization' stamp: ''!
beNull
	"Make the receiver a NULL pointer"
	self atAllPut: 0.! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
autoRelease
	^ self class finalizationRegistry add: self! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
unsignedShortAt: byteIndex put: value
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self uint16AtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
unsignedLongAt: byteIndex put: value
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self uint32AtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: 'copying' stamp: ''!
clone

	<primitive: 148>
	self primitiveFailed! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
floatAt: byteIndex put: value
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self float32AtOffset: byteIndex - 1 put: value! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
value
	^ self asInteger! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
pointer
	"Answers a pointer to the this address. 
	 Sometimes, an ExternalAddress represents a pointer, so you do not need this, but some others 
	 it represents just an address. Yes, I know, difference is subtle. 
	 Take this as an example:
		
		SQSurfaceDispatch externalNew. 

	 This will answer an instance if FFIExternalStructure with an ExternalAddress as handle, but 
	 this handle WILL NOT represent a pointer address, just an address. 
	 This is why, later in a call where I use the surface: 
	
		AthensCairoSurface>>#initializeForNewSession
	
	... I need to keep a pointer to the surface, just the external address is not enough."
	^ (ExternalAddress allocate: self size)
		pointerAt: 1 put: self;
		yourself! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
uint8AtOffset: zeroBasedOffset put: value
	<primitive: 646>
	^ self integerAt: zeroBasedOffset + 1 put: value size: 1 signed: false! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
unsignedLongAt: byteIndex
	"This method is duplicated in this subclass with the purpose of ensuring a monomorphic inline cache in the following message send."
	^ self uint32AtOffset: byteIndex - 1! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
char8AtOffset: zeroBasedOffset
	<primitive: 640>
	^ (self integerAt: zeroBasedOffset + 1 size: 1 signed: false) asCharacter! !

!ExternalAddress methodsFor: 'arithmetic' stamp: ''!
+ offset
	"Create an address that is offset by the given number of bytes.
	More tricky than one would think due to the FFI's handling of ExternalAddress
	as pointer to an object so that 'self unsignedLongAt: ' would dereference."

	| bytes |
	"Convert xaddr -> bytes"
	bytes := self asByteArrayPointer.
	"Update bytes using platform dependent accessors"
	self size = 4
		ifTrue: [bytes unsignedLongAt: 1 put: (bytes unsignedLongAt: 1) + offset]
		ifFalse: [bytes unsignedLongLongAt: 1 put: (bytes unsignedLongLongAt: 1) + offset].
	"Convert bytes -> xaddr"
	^bytes asExternalPointer! !

!ExternalAddress methodsFor: '*UnifiedFFI' stamp: ''!
char32AtOffset: zeroBasedOffset put: value
	<primitive: 657>
	^ self integerAt: zeroBasedOffset + 1 put: value asInteger size: 4 signed: false! !

!ExternalAddress class methodsFor: '*UnifiedFFI' stamp: ''!
fromString: aString
	| result |
	
	result := self allocate: aString size + 1.
	(self assert: result notNil).
	result writeString: aString.
	result unsignedByteAt: aString size + 1 put: 0.
	^ result! !

!ExternalAddress class methodsFor: 'instance creation' stamp: ''!
new
	"External addresses are either four or eight bytes long."
	^super new: self wordSize! !

!ExternalAddress class methodsFor: '*UnifiedFFI' stamp: ''!
null
	^ self new! !

!ExternalAddress class methodsFor: 'instance creation' stamp: ''!
allocate: byteSize
	
	^ FFIBackend current allocate: byteSize! !

!ExternalAddress class methodsFor: '*UnifiedFFI' stamp: ''!
loadSymbol: moduleSymbol
	"Load global symbol (one that you can find in current VM binary)"
	^ self 
		loadSymbol: moduleSymbol 
		module: nil! !

!ExternalAddress class methodsFor: 'instance creation' stamp: ''!
new: n
	"Only create ExternalAddresses of the right size."
	^n = self wordSize
		ifTrue: [super new: n]
		ifFalse: [self shouldNotImplement]! !

!ExternalAddress class methodsFor: '*UnifiedFFI' stamp: ''!
fromAddress: aNumber
	"Answers an external address who points to aNumber"
	^ self new fromAddress: aNumber! !

!ExternalAddress class methodsFor: 'instance creation' stamp: ''!
gcallocate: byteSize
	"Primitive. Allocate an object on the external heap.
	The external memory will be freed when i am garbage collected.
	BEWARE: there should be no copy of self, nor any pointer to a sub part..."
	
	| externalAddress |
	externalAddress := self allocate: byteSize.
	self finalizationRegistry add: externalAddress.
	^externalAddress! !

!ExternalAddress class methodsFor: 'system startup' stamp: ''!
startUp: resuming
	"If starting the image afresh all external addresses should be zero.
	 In addition, if the word size has changed then external addresses shoiuld be resized.
	 The two steps are combined for efficiency."
	resuming ifTrue: [
		self allInstancesDo: [ :each | each beNull ]]! !

!ExternalAddress class methodsFor: 'instance creation' stamp: ''!
allocate: byteSize bytesDuring: aBlock

	| address |
	address := self allocate: byteSize.
	^ [ aBlock value: address ] ensure: [ address free ]! !

!ExternalAddress class methodsFor: 'accessing' stamp: ''!
wordSize
	^wordSize ifNil: [ wordSize := Smalltalk wordSize ]! !

!ExternalAddress class methodsFor: '*UnifiedFFI' stamp: ''!
loadSymbol: moduleSymbol from: moduleNameOrClass 
	^ self 
		loadSymbol: moduleSymbol 
		module: moduleNameOrClass asFFILibrary libraryName.
	! !

!ExternalAddress class methodsFor: '*UnifiedFFI' stamp: ''!
newPointer
	^ self allocate: self wordSize ! !

!ExternalAddress class methodsFor: 'instance creation' stamp: ''!
loadSymbol: moduleSymbol module: module 

	^ FFIBackend current loadSymbol: moduleSymbol module: module! !

!ExternalBrowser commentStamp: ''!
Browser the current image:

	ExternalBrowser openOn: Smalltalk image.

Browse a FileOut

	| internalStream |
	internalStream := (String new: 1000) writeStream.
	SystemOrganization 
		fileOutCategory: 'Tool-ExternalBrowser'
		on: internalStream.
	ExternalBrowser browseStream: internalStream contents readStream.!
!ExternalBrowser methodsFor: 'selection operation' stamp: ''!
resetSelectorSelection

	self selectors resetSelection! !

!ExternalBrowser methodsFor: 'structure accessing' stamp: ''!
showClassDefinition
	method text: (self classes selectedItem definition  ifNil:[''])! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
initializeWidgets
	self initializePackageList.
	self initializeClassList.
	self initializeProtocolList.
	self initializeSelectorList.
	self initializeMethodBodyPane.
	
	showClassSide := self newCheckBox.
	showClassSide label: 'Class side'.
	showClassSide state: false.
	
	self focusOrder
		add: packages;
		add: classes;
		add: protocols;
		add: selectors;
		add: method! !

!ExternalBrowser methodsFor: 'structure accessing' stamp: ''!
methodFor: aSelector

	^ (self classes selectedItem methodNamed: aSelector) sourceCode
			! !

!ExternalBrowser methodsFor: 'selection operation' stamp: ''!
resetClassSelection

	self classes resetSelection! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
wireClasses
	classes
		whenSelectedItemChanged: [ :class | 
			self resetProtocolSelection.
			class 
				ifNil: [ protocols items: #() ] 
				ifNotNil: [ protocols items: (self protocolsOfClass: class).
					         self showClassDefinition ] ]! !

!ExternalBrowser methodsFor: 'accessing' stamp: ''!
packages

	^ packages! !

!ExternalBrowser methodsFor: 'structure accessing' stamp: ''!
classesOfPackage: aPackage
	| theClasses |
	theClasses := aPackage classes.
	^ self showClassSide state
		ifTrue: [ theClasses collect: [:each | each classSide] ]
		ifFalse: [ theClasses ]! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
wireProtocols
	protocols
		whenSelectedItemChanged: [ :protocol | 
			self resetSelectorSelection.
			protocol 
				ifNil: [ selectors items: #() ] 
				ifNotNil: [ selectors items: (self selectorsOfProtocol: protocol) ] ]! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
initializeSelectorList

	selectors := self newList.
	! !

!ExternalBrowser methodsFor: 'selection operation' stamp: ''!
resetProtocolSelection

	self protocols resetSelection! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
initializePackageList
	packages := self newList.
	self populatePackages.
	packages displayBlock: [ :m | m name ]! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
refreshClasses: pack
	self resetClassSelection.
	pack 
		ifNil: [ classes items: #() ] 
		ifNotNil: [ classes items: (self classesOfPackage: pack)]. 
! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
wirePackages
	packages whenSelectedItemChanged: [ :pack | 
		self refreshClasses: pack ].


	! !

!ExternalBrowser methodsFor: 'accessing' stamp: ''!
title 
	^ 'External Package Browser'! !

!ExternalBrowser methodsFor: 'selection operation' stamp: ''!
populatePackages

	packages items: model packages.! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
initializeProtocolList
	protocols := self newList! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
initializeClassList
	classes := self newList! !

!ExternalBrowser methodsFor: 'structure accessing' stamp: ''!
protocolsOfClass: aClass

	^ aClass protocols! !

!ExternalBrowser methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!ExternalBrowser methodsFor: 'accessing' stamp: ''!
selectors
	^ selectors! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
initialExtent

	^ 800@600! !

!ExternalBrowser methodsFor: 'accessing' stamp: ''!
selectors: anObject
	selectors := anObject! !

!ExternalBrowser methodsFor: 'accessing' stamp: ''!
classes

	^ classes! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
wireSelectors
	selectors
		whenSelectedItemChanged: [ :selector | 
			selector 
				ifNil: [ self resetMethodBodyPane ] 
				ifNotNil: [ method text:  (self methodFor: selector) ]]! !

!ExternalBrowser methodsFor: 'accessing' stamp: ''!
showClassSide

	^ showClassSide! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
initializeMethodBodyPane
	method := self newCode! !

!ExternalBrowser methodsFor: 'accessing' stamp: ''!
model: aModel

	model := aModel! !

!ExternalBrowser methodsFor: 'accessing' stamp: ''!
method: anObject
	method := anObject! !

!ExternalBrowser methodsFor: 'accessing' stamp: ''!
protocols

	^ protocols! !

!ExternalBrowser methodsFor: 'structure accessing' stamp: ''!
selectorsOfProtocol: aProtocol 
	
	| theSelectedClass |
	theSelectedClass := self showClassSide state
		ifFalse: [ self classes selectedItem ]
		ifTrue: [ self classes selectedItem classSide ].
	^ (theSelectedClass 
		methodsInProtocol: self protocols selectedItem) collect: [:each | each selector]! !

!ExternalBrowser methodsFor: 'selection operation' stamp: ''!
resetMethodBodyPane
	self method text: ''
	! !

!ExternalBrowser methodsFor: 'initialize' stamp: ''!
initializePresenter
	self wirePackages.
	self wireClasses.
	self wireProtocols.
	self wireSelectors.
	
	showClassSide 
		whenChangedDo: [ self refreshClasses: self packages selectedItem ].! !

!ExternalBrowser class methodsFor: 'System-FileRegistry' stamp: ''!
sourceFileSuffixes

	^#('st' 'cs')

! !

!ExternalBrowser class methodsFor: 'System-FileRegistry' stamp: ''!
fileReaderServicesForFile: fullName suffix: suffix
	<fileService>

	^ (self sourceFileSuffixes includes: suffix)
		ifTrue: [ Array with: self serviceBrowseCode]
		ifFalse: [ #() ]! !

!ExternalBrowser class methodsFor: 'examples' stamp: ''!
example
	<example>

	self openOn: Smalltalk image! !

!ExternalBrowser class methodsFor: 'instance creation' stamp: ''!
openOn: model

	self basicNew
		model: model;
		initialize;
		openWithSpec! !

!ExternalBrowser class methodsFor: 'System-FileRegistry' stamp: ''!
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: [ :file| file readStream]! !

!ExternalBrowser class methodsFor: 'System-FileRegistry' stamp: ''!
services
	"Answer potential file services associated with this class"

	^ {self serviceBrowseCode}.! !

!ExternalBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ SpecLayout composed 
		newColumn: [ :col | 
			col newRow: [ :row | 
					row newColumn: [ :subcolumn |
						subcolumn add: #packages.
						subcolumn add: #showClassSide height: 16  ].
					row 
						add: #classes;
						add: #protocols;
						add: #selectors ] ;
			newRow: [ :row | 
					row add: #method ]]; 
		yourself! !

!ExternalBrowser class methodsFor: 'public access' stamp: ''!
browseStream: aStream

	self openOn: (RingChunkImporter fromStream: aStream)! !

!ExternalBrowserTest methodsFor: 'running' stamp: ''!
tearDown 
	| newWindows |
	file deleteIfAbsent: [ ].
	testingEnvironment at: self classNameForTest ifPresent: [ : cl | cl removeFromSystem ].
	newWindows := self currentWorld windowsSatisfying: [ : each | (initialWindows includes: each) not ].
	newWindows do: #delete.
	super tearDown.! !

!ExternalBrowserTest methodsFor: 'running' stamp: ''!
testDropStFile
	self initFileWithSuffix: 'st'.
	self assert: ExternalBrowser dropFileWithSuffix: 'st'
! !

!ExternalBrowserTest methodsFor: 'running' stamp: ''!
assert: serviceProvider dropFileWithSuffix: suffix
	| allMatchingServices service |
	allMatchingServices := serviceProvider fileReaderServicesForFile: file pathString suffix: suffix.
	self deny: allMatchingServices isEmpty.
	service := allMatchingServices anyOne.
	self shouldnt: [service performServiceFor: file] raise: MessageNotUnderstood.
! !

!ExternalBrowserTest methodsFor: 'running' stamp: ''!
fileForTestContent
	^'''From Pharo7.0.0rc1 of 4 December 2018 [Build information: Pharo-7.0.0+rc1.build.1435.sha.4cd23cf7be1a90c7c52e9f8786860a6290b7c2a6 (64 Bit)] on 5 December 2018 at 9:30:34.922838 am''!!
Object subclass: #', self classNameForTest,'
	instanceVariableNames: ''some iv''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: #MyCategory!!
!!', self classNameForTest,' commentStamp: ''NouryBouraqadi 12/4/2018 17:19'' prior: 0!!
My unique and explicit comment!!


!!', self classNameForTest,' methodsFor: ''protocol'' stamp: ''NouryBouraqadi 12/4/2018 17:12''!!
myMethod
	!! !!
'! !

!ExternalBrowserTest methodsFor: 'running' stamp: ''!
initFileWithSuffix: suffix
	file := FileSystem workingDirectory / self fileNameForTest, '.', suffix.
	file
		writeStreamDo: [ :stream | stream nextPutAll: self fileForTestContent ].
	initialWindows := self currentWorld windowsSatisfying: [: each| true ].! !

!ExternalBrowserTest methodsFor: 'running' stamp: ''!
classNameForTest
	^#MyWonderfulClass! !

!ExternalBrowserTest methodsFor: 'running' stamp: ''!
fileNameForTest
	^ 'fileForExternalBrowserTest'! !

!ExternalBrowserTest methodsFor: 'running' stamp: ''!
testDropChangeFile
	self initFileWithSuffix: 'changes'.
	self assert: ExternalChangesBrowser dropFileWithSuffix: 'changes'
! !

!ExternalBrowserTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	initialWindows := self currentWorld windowsSatisfying: [: each| true ].! !

!ExternalChangesBrowser commentStamp: ''!
I'm a simple changes browser. When the user drop a .cs or .st files and select to view them, I display a sequenceable and simple list of changes and a way to file in the code. 

!!!! Examples

[[[
ExternalChangesBrowser new openWithSpec.

ExternalChangesBrowser openOn: Smalltalk changesFile fullName
]]]!
!ExternalChangesBrowser methodsFor: 'initialization' stamp: ''!
initializePresenter
	changes whenSelectedItemChanged: [ :change | change ifNotNil: [ codePane text: change contents ] ].
	changes menu: [ :menu :shifted | self buildMenu: menu ].
	selectAllButton action: [ changes selectAll ].
	deselectAllButton action: [ changes resetSelection ].
	fileInSelectedButton action: [ self fileIn: changes selectedItemsSorted ]! !

!ExternalChangesBrowser methodsFor: 'initialization' stamp: ''!
changeDescription: change

	^ change description! !

!ExternalChangesBrowser methodsFor: 'private' stamp: ''!
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.! !

!ExternalChangesBrowser methodsFor: 'initialization' stamp: ''!
initialExtent

	^ 500@600! !

!ExternalChangesBrowser methodsFor: 'initialization' stamp: ''!
initializeWidgets

	self title: 'Changes Browser'.

	changes := self newList.
	changes displayBlock: [ :elem | self changeDescription: elem ].
	changes beMultipleSelection.

	selectAllButton := self newButton.
	selectAllButton
		label: 'select all'.

	deselectAllButton := self newButton.
	deselectAllButton
		label: 'deselect all'.
		
	fileInSelectedButton := self newButton.
	fileInSelectedButton
		label: 'file in selected'.

	codePane := self newCode.! !

!ExternalChangesBrowser methodsFor: 'initialization' stamp: ''!
changeSetName: aFileName

	changeSet := CodeImporter fileNamed: aFileName.
	changeSet parseChunks.
	changes items: changeSet codeDeclarations.! !

!ExternalChangesBrowser methodsFor: 'accessing' stamp: ''!
fileInSelectedButton

	^ fileInSelectedButton! !

!ExternalChangesBrowser methodsFor: 'menu' stamp: ''!
fileIn: aCodeDeclaration

	aCodeDeclaration do: #import.! !

!ExternalChangesBrowser methodsFor: 'accessing' stamp: ''!
changes

	^ changes! !

!ExternalChangesBrowser methodsFor: 'private' stamp: ''!
openComparisonFrom: targetMethodSource
					to: originalMethodSource
					belongingTo: aClass
					from: aChange 
					labeled: aLabel 
					inWindowLabeled: aWindowLabel 

	| diffBuilder difference  |

	PSMCPatchMorph usedByDefault 
		ifTrue: [ ^ self openPolymorphComparisonFrom: originalMethodSource 
					to: targetMethodSource
					belongingTo: aClass
					from: aChange
					labeled: aLabel
					inWindowLabeled: aWindowLabel   ].

	diffBuilder :=  TextDiffBuilder
			from: originalMethodSource 
			to: targetMethodSource.

	difference := diffBuilder buildDisplayPatch.
	
	UIManager default edit: difference label: aLabel.
				! !

!ExternalChangesBrowser methodsFor: 'menu' stamp: ''!
buildMenu: aMenu

	aMenu
		add: 'File in all selected'
		target: self
		selector: #fileIn:
		argumentList: { changes selectedItems }.
	
	aMenu
		addToggle: 'Compare method to current'
		target: self
		selector: #compareToCurrent:
		getStateSelector:nil
		enablementSelector: #canCompareToCurrent
		argumentList: { changes selectedItem }.

	^ aMenu! !

!ExternalChangesBrowser methodsFor: 'menu' stamp: ''!
compareToCurrent: aMethodDeclaration

	| class sourceString |
	class := aMethodDeclaration targetClass.
	sourceString := (class >> aMethodDeclaration methodSelector) sourceCode.
	
	self
		openComparisonFrom: aMethodDeclaration contents
		to: sourceString
		belongingTo: class
		from: aMethodDeclaration
		labeled: 'Current'
		inWindowLabeled: 'Comparison to Current Version'! !

!ExternalChangesBrowser methodsFor: 'accessing' stamp: ''!
selectAllButton

	^ selectAllButton! !

!ExternalChangesBrowser methodsFor: 'accessing' stamp: ''!
deselectAllButton

	^ deselectAllButton! !

!ExternalChangesBrowser methodsFor: 'menu' stamp: ''!
canCompareToCurrent

	| aMethodDeclaration |
	(changes selectedItems size = 1) ifFalse: [ ^ false ].
	((aMethodDeclaration := changes selectedItem) isMethodDeclaration) ifFalse: [  ^ false ].
	
	( aMethodDeclaration existsBehavior) ifFalse: [ ^ false ].
	^ aMethodDeclaration targetClass includesSelector: aMethodDeclaration methodSelector
	! !

!ExternalChangesBrowser methodsFor: 'accessing' stamp: ''!
codePane

	^ codePane! !

!ExternalChangesBrowser class methodsFor: 'file service' stamp: ''!
fileReaderServicesForFile: fullName suffix: suffix
	<fileService>
	| services |
	services := OrderedCollection new.
	(ExternalBrowser sourceFileSuffixes includes: suffix) |
	('changes' = suffix) | (suffix = '*')
		ifTrue: [ services add: self serviceBrowseCSOrSTFile ].
	^services! !

!ExternalChangesBrowser class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallSaveIcon! !

!ExternalChangesBrowser class methodsFor: 'examples' stamp: ''!
example1
	<example>
	
	self new openWithSpec
! !

!ExternalChangesBrowser class methodsFor: 'instance creation' stamp: ''!
openOn: changeSetName

	self new
		changeSetName: changeSetName;
		openWithSpec! !

!ExternalChangesBrowser class methodsFor: 'file service' stamp: ''!
services
	"Answer potential file services associated with this class"

	^ { self serviceBrowseCSOrSTFile }! !

!ExternalChangesBrowser class methodsFor: 'examples' stamp: ''!
browseRecentLog
	<example>
	
	^ self openOnStream: SourceFiles changesFileStream! !

!ExternalChangesBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ SpecLayout composed 
		newColumn: [ :col | 
			col
				add: #changes;
				newRow: [ :row | 
					row
						add: #selectAllButton;
						add: #deselectAllButton;
						add: #fileInSelectedButton ] height: 32;
				add: #codePane ]; 
		yourself! !

!ExternalChangesBrowser class methodsFor: 'instance creation' stamp: ''!
openOnFileName: aFileName

	self new
		changeSetName: aFileName;
		openWithSpec! !

!ExternalChangesBrowser class methodsFor: 'tool registry' stamp: ''!
registerToolsOn: registry

	registry register: self as: #changeList ! !

!ExternalChangesBrowser class methodsFor: 'instance creation' stamp: ''!
openOnStream: aStream

	| widget |
	widget := self new.
	widget changes items: (CodeImporter chunksFromStream: aStream).
	widget openWithSpec	! !

!ExternalChangesBrowser class methodsFor: 'file service' stamp: ''!
serviceBrowseCSOrSTFile
	"Answer a service for opening a changelist browser on a file"

	^ (SimpleServiceEntry 
		provider: self 
		label: 'Changelist browser'
		selector: #openOnStream:
		description: 'Open a changelist tool on this file'
		buttonLabel: 'Changes')
		argumentGetter: [ :stream | stream readStream ]! !

!ExternalChangesBrowser class methodsFor: 'examples' stamp: ''!
example2
	<example>
	
	self openOn: Smalltalk changesFile fullName! !

!ExternalData commentStamp: ''!
Instances of ExternalData explicitly describe objects with associated type. They can be used for describing atomic C types like arrays of atomic types (e.g., 'int[]') or pointer to atomic types (e.g., 'int *').

Instance variables:
	type	<Integer | Behavior>	The basic type of the receiver.

The encoding of type is equivalent to that of the basic type in class ExternalType. The interpretation of whether the receiver describes an array of data or a pointer to data depends on the contents of the instance variable 'handle'. If handle contains an ExternalAddress the receiver is treated as pointer to type. If the handle contains a ByteArray the receiver is interpreted as describing an array of type. Note that both interpretations are treated equivalent in external calls, e.g., if one describes an argument to an external call as taking 'int*' then, depending on the type of handle either the actual contents (if ExternalAddress) or a pointer to the contents (if ByteArray) is passed.

!
!ExternalData methodsFor: '*UnifiedFFI' stamp: ''!
readStringUTF8
	"Assume that the receiver represents a C string containing UTF8 characters and convert 
	 it to a Smalltalk string."
	| stream index char |
	
	self isNull ifTrue: [ ^ nil ].
	
	type isPointerType ifFalse: [self error: 'External object is not a pointer type.'].
	stream := WriteStream on: ByteArray new.
	index := 1.
	[(char := handle unsignedByteAt: index) = 0 ] whileFalse: [
		stream nextPut: char.
		index := index + 1].
	^ ZnCharacterEncoder utf8 decodeBytes: stream contents! !

!ExternalData methodsFor: 'private' stamp: ''!
setHandle: aHandle type: aType
	handle := aHandle.
	type := aType.! !

!ExternalData methodsFor: 'converting' stamp: ''!
fromCString
	"Assume that the receiver represents a C string and convert it to a Smalltalk string. hg 2/25/2000 14:18"

	type isPointerType ifFalse: [self error: 'External object is not a pointer type.'].

	^ handle fromCString! !

!ExternalData methodsFor: '*UnifiedFFI' stamp: ''!
copyFrom: start to: stop
	^ self getHandle copyFrom: start to: stop! !

!ExternalData methodsFor: 'converting' stamp: ''!
fromCStrings
	"Assume that the receiver represents a set of C strings and is terminated by a empty string and convert it to a Smalltalk ordered collection of strings"

	| stream index char strings str |
	type isPointerType ifFalse: [self error: 'External object is not a pointer type.'].
	strings := OrderedCollection new.
	index := 1.
	[
		stream := WriteStream on: String new.
		[(char := handle unsignedCharAt: index) = 0 asCharacter]
			whileFalse: [
				stream nextPut: char.
				index := index + 1
			].
		str := stream contents.
		strings addLast: str.
		str isEmpty
	] whileFalse.
	^strings! !

!ExternalData methodsFor: '*UnifiedFFI' stamp: ''!
value
	^ self asInteger! !

!ExternalData methodsFor: '*UnifiedFFI' stamp: ''!
asInteger
	^ self getHandle asInteger! !

!ExternalData methodsFor: '*UnifiedFFI' stamp: ''!
beNull
	^ self getHandle beNull! !

!ExternalData methodsFor: '*UnifiedFFI' stamp: ''!
readString
	self isNull ifTrue: [ ^ nil ].
	^ self fromCString! !

!ExternalData methodsFor: '*UnifiedFFI' stamp: ''!
+ offset 
	"Pointer aritmetic, it allows to move the pointer as in C.
	 But obviously, it only applies to actual external addresses."
	self getHandle isExternalAddress 
		ifFalse: [ self error: 'You cannot apply pointer aritmetic to a non external address' ].
	^ self species
		fromHandle: (self getHandle + offset)
		type: type! !

!ExternalData methodsFor: 'printing' stamp: ''!
printOn: stream

	stream 
		nextPut: $(;
		print: type; 
		nextPut: $). 
	self getHandle printOn: stream.! !

!ExternalData class methodsFor: 'instance creation' stamp: ''!
new
	"You better not..."
	^self shouldNotImplement! !

!ExternalData class methodsFor: 'instance creation' stamp: ''!
fromHandle: aHandle type: aType
	"Create a pointer to the given type"
	"ExternalData fromHandle: ExternalAddress new type: ExternalType float"
	^self basicNew setHandle: aHandle type: aType! !

!ExternalData class methodsFor: 'field definition' stamp: ''!
fields
	"ExternalData defineFields"
	"Note: The definition is for completeness only.
	ExternalData is treated specially by the VM."
	^#(nil 'void*')! !

!ExternalData class methodsFor: 'class initialization' stamp: ''!
compileFields
	"Ensure proper initialization of ExternalType when first loading"
	ExternalType initialize.
	^super compileFields! !

!ExternalDropHandler commentStamp: ''!
Handle a number of dropped files from the OS!
!ExternalDropHandler methodsFor: 'accessing' stamp: ''!
extension
	^extension! !

!ExternalDropHandler methodsFor: 'accessing' stamp: ''!
handle: dropStream in: pasteUp dropEvent: anEvent
	
	^action cull: dropStream 
			cull: pasteUp 
			cull: anEvent! !

!ExternalDropHandler methodsFor: 'testing' stamp: ''!
matchesTypes: types
	(self type isNil or: [types isNil])
		ifTrue: [^false].
	^types anySatisfy: [:mimeType | mimeType beginsWith: self type]! !

!ExternalDropHandler methodsFor: 'initialize' stamp: ''!
type: aType extension: anExtension action: anAction 
	action := anAction.
	type := aType.
	extension := anExtension! !

!ExternalDropHandler methodsFor: 'testing' stamp: ''!
matchesExtension: aExtension
	(self extension isNil or: [ aExtension isNil ]) ifTrue: [ ^ false ].
	^ FileSystem disk isCaseSensitive
		ifTrue: [ extension = aExtension ]
		ifFalse: [ extension sameAs: aExtension ]! !

!ExternalDropHandler methodsFor: 'accessing' stamp: ''!
type
	^type! !

!ExternalDropHandler class methodsFor: 'initialization' stamp: ''!
initialize
	"ExternalDropHandler initialize"

	self resetRegisteredHandlers.! !

!ExternalDropHandler class methodsFor: 'private' stamp: ''!
unwantedSelectors
	"private - answer a collection well known unwanted selectors "
	^ #(#removeLineFeeds: #compressFile:)! !

!ExternalDropHandler class methodsFor: 'accessing' stamp: ''!
defaultHandler
	DefaultHandler ifNil: [DefaultHandler := ExternalDropHandler type: nil extension: nil action: [:dropStream | dropStream edit]].
	^DefaultHandler! !

!ExternalDropHandler class methodsFor: 'accessing' stamp: ''!
lookupExternalDropHandler: aFileReference

	| types serviceHandler |
	types := aFileReference mimeTypes.

	types ifNotNil: [
		self registeredHandlers do: [:handler | 
			(handler matchesTypes: types)
				ifTrue: [^handler]]].

	self registeredHandlers do: [:handler | 
		(handler matchesExtension: aFileReference extension)
				ifTrue: [^handler]].
	serviceHandler := self lookupServiceBasedHandler: aFileReference.
	^serviceHandler
		ifNil: [self defaultHandler]! !

!ExternalDropHandler class methodsFor: 'private' stamp: ''!
chooseServiceFrom: aCollection
	"private - choose a service from aCollection asking the user if  
	needed"
	aCollection size = 1 ifTrue: [^ aCollection anyOne].
	^ UIManager default chooseFrom: (aCollection collect: [:each | 
			each label]) values: aCollection.! !

!ExternalDropHandler class methodsFor: 'accessing' stamp: ''!
defaultHandler: externalDropHandler
	DefaultHandler := externalDropHandler! !

!ExternalDropHandler class methodsFor: 'accessing' stamp: ''!
registerHandler: aHandler
	self registeredHandlers add: aHandler! !

!ExternalDropHandler class methodsFor: 'instance creation' stamp: ''!
type: aType extension: anExtension action: anAction 
	^self new type: aType extension: anExtension action: anAction! !

!ExternalDropHandler class methodsFor: 'private' stamp: ''!
registeredHandlers
	RegisteredHandlers ifNil: [RegisteredHandlers := OrderedCollection new].
	^RegisteredHandlers! !

!ExternalDropHandler class methodsFor: 'accessing' stamp: ''!
lookupServiceBasedHandler: aFileReference
	"the file was just droped, let's do our job"
	| services theOne |

	services := (Smalltalk tools fileList itemsForFile: aFileReference)
		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: aFileReference]]! !

!ExternalDropHandler class methodsFor: 'cleanup' stamp: ''!
cleanUp
	self resetRegisteredHandlers.! !

!ExternalDropHandler class methodsFor: 'private' stamp: ''!
resetRegisteredHandlers
	RegisteredHandlers := nil! !

!ExternalObject commentStamp: ''!
External objects represent entities that are not part of the Pharo universe. They are accessed using a unique handle which is interpreted depending on the actual entity that is represented. 

Instance variables:
	handle	<ByteArray | ExternalAddress>!
!ExternalObject methodsFor: 'private' stamp: ''!
setHandle: anObject
	"Private. Set the handle used to represent the external entity."
	handle := anObject! !

!ExternalObject methodsFor: 'private' stamp: ''!
getHandle
	"Private. Return the handle used to represent the external entitiy."
	^handle! !

!ExternalObject methodsFor: 'testing' stamp: ''!
isExternalAddress
	"Return true if the receiver describes the address of an object in the outside world"
	^false! !

!ExternalObject methodsFor: '*UnifiedFFI' stamp: ''!
pointer 
	^ self getHandle pointer! !

!ExternalObject methodsFor: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	^ self getHandle tfPointerAddress! !

!ExternalObject methodsFor: 'testing' stamp: ''!
isNull
	"Answer true if the receiver currently is a NULL pointer"
	^handle == nil or:[handle isNull]! !

!ExternalObject methodsFor: '*UnifiedFFI' stamp: ''!
autoRelease
	self isExternalAddress ifFalse: [ ^ self ].
	^ self getHandle autoRelease! !

!ExternalObject class methodsFor: 'class initialization' stamp: ''!
initialize

	SessionManager default
				registerSystemClassNamed: self name
				atPriority: 60.
				
	Smalltalk recreateSpecialObjectsArray! !

!ExternalObject class methodsFor: 'instance creation' stamp: ''!
null
	
	^ self fromHandle: (ExternalAddress null).! !

!ExternalObject class methodsFor: 'system startup' stamp: ''!
install
	"Notify all instances of the receiver that we're coming up on a new platform.
	Note: The default implementation does nothing since the general external
	objects are cleaned up by ExternalAddress>>startUp: but subclasses may
	implement this method so that the appropriate action for existing instances can
	be taken."! !

!ExternalObject class methodsFor: 'system startup' stamp: ''!
installSubclasses
	"Notify all the subclasses of ExternalObject that we are starting up on a new platform."
	self withAllSubclassesDo:[:cls| cls install].! !

!ExternalObject class methodsFor: 'system startup' stamp: ''!
startUp: resuming
	"The system is coming up. If it is on a new platform, clear out the existing handles."
	ExternalAddress startUp: resuming. "Make sure handles are invalid"
	resuming ifTrue:[self installSubclasses].! !

!ExternalSemaphoreTable commentStamp: ''!
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 delegate the responsibility here versus adding more code and another class variable to SystemDictionary 

Note that in Smalltalk recreateSpecialObjectsArray we still directly play with the table.

Henrik Sperre Johansen
The name is somewhat of a misnomer; the table can be used for any objects, not just semaphores.
That is its main usage though, so a split which deals with semaphores and other external objects differently 
(In the same underlying table) is not currently worth it.
Therefore, while in general not all users will care if the table is above a certain size, we still guard  against adding more objects than the limit above which external signals would be lost (on some VMs.)
!
!ExternalSemaphoreTable class methodsFor: 'private' stamp: ''!
unprotectedExternalObjects: aCollection
	^Smalltalk specialObjectsArray at: 39 put: aCollection! !

!ExternalSemaphoreTable class methodsFor: 'private' stamp: ''!
freedSlotsIn: externalObjects ratherThanIncreaseSizeTo: newSize
	"In some VM's, the external object table has a max size, which has to be increased for vm to reference them correctly."
	"In that case, try to gc to free slots first before actually increasing the max size"
	"Return whether I ended up freeing slots by GC'ing, or one should increase the size of "
	^Smalltalk vm maxExternalSemaphores
		ifNotNil: [:maxSize |
			(maxSize < newSize) and: 
				[| needToGrow |
				Smalltalk garbageCollect.
				"Do we have free slots now? If not, performing the GC didn't help and we still have to grow."
				needToGrow := externalObjects includes: nil.
				
				needToGrow 
					ifTrue: ["If we did GC, warn we had to gc so actions could be taken if appropriate."
						self traceCr: DateAndTime now printString;
							traceCr:  'WARNING:  Had to GC to make room for more external objects.';
							traceCr: 'If this happens often, it would be a good idea to either:';
							traceCr: '- Raise the maxExternalSemaphores 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: 'initialize' stamp: ''!
initialize
	ProtectAdd := Semaphore forMutualExclusion.
	ProtectRemove := Semaphore forMutualExclusion! !

!ExternalSemaphoreTable class methodsFor: 'private' stamp: ''!
unprotectedExternalObjects
	^Smalltalk specialObjectsArray at: 39! !

!ExternalSemaphoreTable class methodsFor: 'private' stamp: ''!
privateUnregisterExternalObject: anObject
	"Unregister the given object in the external objects array. Do nothing if it isn't registered.
	Calls to this method must be guarded against simultaneous removes from multiple threads."

	| 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: ''!
unregisterExternalObject: anObject
	ProtectRemove critical: [self privateUnregisterExternalObject: anObject]
! !

!ExternalSemaphoreTable class methodsFor: 'private' stamp: ''!
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. 
			"This is only called when adding objects, so caller is responsible for holding ProtectAdd lock.
			Obtain the remove lock as well while swapping the list with a new one, so we don't end up with dead semaphores in newObjects that are removed from externalObjects simultaneously by other threads."
			ProtectRemove critical: [
				newObjects replaceFrom: 1 to:  externalObjects size with: externalObjects startingAt: 1.	
			self unprotectedExternalObjects: newObjects].].
	^newObjects! !

!ExternalSemaphoreTable class methodsFor: 'private' stamp: ''!
privateRegisterExternalObject: anObject
	"Register the given object in the external objects array and return its index. If it is already there, just return its index.
	Calls to this method must be guarded against simultaneous removes from multiple threads."

	| objects firstEmptyIndex |
	objects := self unprotectedExternalObjects.

	"find the first empty slot"
	firstEmptyIndex := 
		(self slotFor: anObject in: objects) 
			ifNil: ["if object has no empty slots,  we need to get a collection which does"
				objects := self collectionBasedOn: objects withRoomFor: anObject.
				self slotFor: anObject in: objects.].
	objects at: firstEmptyIndex put: anObject.
	^ firstEmptyIndex
! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: ''!
registerExternalObject: anObject
	^ ProtectAdd critical: [self privateRegisterExternalObject: anObject]
! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: ''!
clearExternalObjects
	"Clear the array of objects that have been registered for use in non-Smalltalk code."
	"Only lock additions, removals executing in parallel would have little effect on the resulting array"

	ProtectAdd critical: [
		self unprotectedExternalObjects: Array new].
! !

!ExternalSemaphoreTable class methodsFor: 'private' stamp: ''!
slotFor: anObject in: aCollection
	"find the first empty slot, or nil if there is none"

	"The following was written in an atomic fashion using special methods with no suspension points, not sure if on purpose, but keeping it that way for now.
	Uses should be protected by the ProtectTable semaphore anyhow, but... it's too much work to reason 100% about it"

	| firstEmptyIndex |
	1 to: aCollection size do: [ :i | 
		| obj |
		obj := aCollection at: i.
		obj == anObject
			ifTrue: [ ^ i ].	"object already there, just return its index"
		(firstEmptyIndex isNil and: [ obj isNil ])
			ifTrue: [ firstEmptyIndex := i ] ].
	^ firstEmptyIndex! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: ''!
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].! !

!ExternalStructure commentStamp: ''!
An ExternalStructure is for representing external data that is
- either a structure composed of different fields (a struct of C language)
- or an alias for another type (like a typedef of C language)

It reserves enough bytes of data for representing all the fields.

The data is stored into the handle instance variable which can be of two different types:
	- ExternalAddress
		If the handle is an external address then the object described does not reside in the Smalltalk object memory.
	- ByteArray
		If the handle is a byte array then the object described resides in Smalltalk memory.

A specific structure is defined by subclassing ExternalStructure and specifying its #fields via a class side method.
For example if we define a subclass:
	ExternalStructure subclass: #StructExample
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'garbage'.
Then declare the fields like this:
    StructExample class compile: 'fields  ^#( (name ''char*'') (color ''ulong'') )' classified: 'garbage'.

It means that this type is composed of two different fields:
- a string (accessed thru the field #name)
- and an unsigned 32bit integer (accessed thru the field #color).
It represents the following C type:
   struct StructExample {char *name; uint32_t color; };

The accessors for those fields can be generated automatically like this:
	StructExample defineFields.
As can be verified in a Browser:
	StructExample browse.
We see that name and color fields are stored sequentially in different zones of data.

The total size of the structure can be verified with:
	StructExample byteSize = (Smalltalk wordSize + 4).

An ExternalStructure can also be used for defining an alias.
The fields definition must contain only 2 elements: an eventual accessor (or nil) and the type.
For example, We can define a machine dependent 'unsigned long' like this:
	ExternalStructure subclass: #UnsignedLong
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'garbage'.
Then set the fields like this:
    UnsignedLong class compile: 'fields  ^(Smalltalk wordSize=4 or: [Smalltalk platformName=''Win64''])
		ifTrue: [#(nil ''ulong'')] ifFalse: [#(nil ''ulonglong'')]' classified: 'garbage'.
And verify the size on current platform:
	UnsignedLong byteSize.
	
Then, the class names 'UnsignedLong' and 'StructExamples' acts as a type specification.
They can be used for composing other types, and for defining prototype of external functions:

LibraryExample>>initMyStruct: aStructExample name: name color: anInteger
	<cdecl: void 'init_my_struct'( StructExample * char * UnsignedLong )>
	self externalCallFailed


!
!ExternalStructure methodsFor: 'finalization' stamp: ''!
free
	"Free the handle pointed to by the receiver"
	(handle notNil and:[handle isExternalAddress]) ifTrue:[handle free].
	handle := nil.! !

!ExternalStructure methodsFor: 'printing' stamp: ''!
compositeName
	^self class compositeName! !

!ExternalStructure methodsFor: 'printing' stamp: ''!
longPrintOn: aStream 
	"Append to the argument, aStream, the names and values of all the record's variables."
	| fields |
	fields := self class fields.
	(fields isEmpty or: [fields first isNil])
		ifTrue: [fields := #()]
		ifFalse: [fields first isArray ifFalse: [fields := Array with: fields]].
	fields do: [ :field |
		field first ifNotNil:
			[aStream nextPutAll: field first; nextPut: $:; space; tab.
			(self perform: field first) printOn: aStream.
			aStream cr]].! !

!ExternalStructure class methodsFor: 'class management' stamp: ''!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool
	super fileOutOn: aFileStream
		moveSource: moveSource
		toFile: fileIndex
		initializing: aBool.
	(aBool and:[moveSource not]) ifTrue: 
		[aFileStream cr.
		aFileStream cr.
		aFileStream nextChunkPut: self name , ' compileFields'.
		aFileStream cr]! !

!ExternalStructure class methodsFor: 'instance creation' stamp: ''!
new
	^self fromHandle: (ByteArray new: self byteSize)! !

!ExternalStructure class methodsFor: 'class management' stamp: ''!
obsolete
	"The receiver is becoming obsolete. 
	NOTE: You if you remove the whole class category at once, you cannot
	assume that the ExternalType class is still present."

	self environment at: #ExternalType ifPresent: [:class | class noticeRemovalOf: self].
	^ super obsolete! !

!ExternalStructure class methodsFor: 'instance creation' stamp: ''!
externalNew
	"Create an instance of the receiver on the external heap"
	^self fromHandle: (ExternalAddress allocate: self byteSize)! !

!ExternalStructure class methodsFor: 'class management' stamp: ''!
rename: aString
	| oldName |
	oldName := name.
	super rename: aString.
	oldName = name ifFalse:[ExternalType noticeRenamingOf: self from: oldName to: name].! !

!ExternalStructure class methodsFor: 'system startup' stamp: ''!
install
	"Resuming the image on another architecture may require a re-compilation of structure layout."
	| newPlatform |
	newPlatform := Smalltalk platformName.
	PreviousPlatform = newPlatform
		ifFalse:
			[self recompileStructures.
			PreviousPlatform := newPlatform]! !

!ExternalStructure class methodsFor: 'class management' stamp: ''!
fileOutInitializerOn: aFileStream
	super fileOutInitializerOn: aFileStream.
	aFileStream cr.
	aFileStream cr.
	aFileStream nextChunkPut: self name , ' compileFields'.
	aFileStream cr.! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
defineFieldAccessorsFor: fieldName startingAt: byteOffset type: type
	"Define read/write accessors for the given field"
	| comment |
	(type isVoid and: [type isPointerType not]) ifTrue:[^self].
	comment := String streamContents: [:strm |
		strm crtab; nextPutAll: '"This method was automatically generated. See '; nextPutAll: self class name; nextPutAll: '>>fields."'; crtab.
		strm nextPut: $<; nextPutAll: #generated; nextPut: $>; crtab.].
	self maybeCompileAccessor: fieldName, comment, (type readFieldAt: byteOffset)
		withSelector: fieldName asSymbol.
	self maybeCompileAccessor: fieldName,': anObject', comment, (type writeFieldAt: byteOffset with: 'anObject')
		withSelector: (fieldName, ':') asSymbol! !

!ExternalStructure class methodsFor: 'class management' stamp: ''!
doneCompiling
	"I have been recompiled. Update any types that reference me."
	ExternalType noticeModificationOf: self.! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
byteSize
	"Return the size in bytes of this structure."
	^self compiledSpec first bitAnd: FFIStructSizeMask! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
compileFields: fieldSpec
	"Compile the field definition of the receiver.
	Return the newly compiled spec."
	compiledSpec := self compileFields: fieldSpec withAccessors: #never.
	ExternalType noticeModificationOf: self.
	^compiledSpec! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
fields
	"Return the fields defining the receiver"
	^#()! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
compileFields: specArray withAccessors: aSymbol 
	"Compile a type specification for the FFI machinery.
	Return the newly compiled spec.
	Eventually generate the field accessors according to following rules:
	- aSymbol = #always always generate the accessors
	- aSymbol = #never never generate the accessors
	- aSymbol = #generated only generate the auto-generated accessors
	- aSymbol = #absent only generate the absent accessors"
	| byteOffset typeSpec newCompiledSpec |
	(specArray size > 0 and: [specArray first class ~~ Array]) ifTrue:
		[^ self compileAlias: specArray withAccessors: aSymbol].
	byteOffset := 1.
	typeSpec := WriteStream on: (WordArray new: 10).
	typeSpec nextPut: FFIFlagStructure.
	"dummy for size"
	specArray do:
		[:spec | | fieldName fieldType isPointerField externalType typeSize selfRefering |
		fieldName := spec first.
		fieldType := spec second.
		isPointerField := fieldType last = $*.
		fieldType := (fieldType findTokens: ' *') first.
		externalType := ExternalType atomicTypeNamed: fieldType.
		selfRefering := isPointerField and: [externalType isNil and: [fieldType = self asString]].
		selfRefering ifTrue: [
			externalType := ExternalType void asPointerType
		] ifFalse:[
			externalType == nil ifTrue: ["non-atomic"
				Symbol
					hasInterned: fieldType
					ifTrue: [:sym | externalType := ExternalType structTypeNamed: sym].
			].
			externalType == nil ifTrue:[
				self trace: '(' , fieldType , ' is void)'.
				externalType := ExternalType void.
			].
			isPointerField ifTrue: [externalType := externalType asPointerType: self pointerSize]].
			typeSize := externalType byteSize.
			spec size > 2 ifTrue: ["extra size"
				spec third < typeSize
					ifTrue: [^ self error: 'Explicit type size is less than expected'].
				typeSize := spec third.
			].
			(fieldName notNil and: [self shouldGenerate: fieldName policy: aSymbol]) ifTrue: [
				self defineFieldAccessorsFor: fieldName startingAt: byteOffset type: externalType.
			].
			typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
			byteOffset := byteOffset + typeSize.
		].
	newCompiledSpec := typeSpec contents.
	newCompiledSpec at: 1 put: (byteOffset - 1 bitOr: FFIFlagStructure).
	^ newCompiledSpec! !

!ExternalStructure class methodsFor: 'compiling' stamp: ''!
maybeCompileAccessor: aString withSelector: selector
	(self compiledMethodAt: selector ifAbsent: []) ifNotNil:
		[:existingMethod|
		existingMethod getSourceFromFile asString = aString ifTrue:
			[^self]].
	self compile: aString classified: #accessing! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
compiledSpec
	"Return the compiled spec of the receiver"
	^compiledSpec ifNil:[self compileFields].! !

!ExternalStructure class methodsFor: 'converting' stamp: ''!
compositeName
	^'struct'! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
defineAliasAccessorsFor: fieldName type: type
	"Define read/write accessors for the given field"
	| code refClass argName |
	(type isVoid and:[type isPointerType not]) ifTrue:[^self].
	refClass := type referentClass.
	code := String streamContents:[:s|
		s 
			nextPutAll: fieldName; crtab;
			nextPutAll:'"This method was automatically generated"'; crtab;
			nextPut: $<; nextPutAll: #generated; nextPut: $>; crtab.
		refClass == nil 
			ifTrue:[(type isAtomic and:[type isPointerType not]) 
				ifTrue:[s nextPutAll:'^handle']
				ifFalse:[s nextPutAll:'^ExternalData fromHandle: handle'.
						type isPointerType ifTrue:[s nextPutAll:' asExternalPointer'].
						s nextPutAll:' type: ';
						nextPutAll: type externalTypeName]]
			ifFalse:[s nextPutAll:'^', refClass name,' fromHandle: handle'.
					type isPointerType ifTrue:[s nextPutAll:' asExternalPointer']]].
	self compile: code classified: 'accessing'.

	code := String streamContents:[:s|
		argName := refClass == nil 
			ifTrue:[(type isAtomic and:[type isPointerType not])
				ifTrue:['anObject']
				ifFalse:['anExternalData']]
			ifFalse:['a',refClass name].
		s
			nextPutAll: fieldName,': '; nextPutAll: argName; crtab;
			nextPutAll:'"This method was automatically generated"'; crtab;
			nextPut: $<; nextPutAll: #generated; nextPut: $>; crtab.
		(refClass == nil and:[type isAtomic and:[type isPointerType not]])
			ifTrue:[s nextPutAll:'handle := ', argName]
			ifFalse:[s nextPutAll:'handle := ', argName,' getHandle'.
					type isPointerType ifTrue:[s nextPutAll:' asByteArrayPointer']]].
	self compile: code classified: 'accessing'.! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
compileAllFields
	"ExternalStructure compileAllFields"
	self withAllSubclassesDo:[:cls|
		cls compileFields.
	].! !

!ExternalStructure class methodsFor: 'accessing' stamp: ''!
pointerSize
	"Answer the size of pointers for this class.  By default answer nil.
	 Subclasses that contain pointers must define the size of a pointer if the code is to operate on 64-bit and 32-bit platforms.
	 Currently we have no way of converting a type between 32- and 64- bit versions beyond recompiling it."
	^nil! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
defineFields
	"Define all the fields in the receiver"
	self defineFields: self fields.! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
sortStructs: structureClasses into: sortedClasses 
	"Sort the structure definitions so as to obtain a correct initialization order."
	
	[| structClass prevStructClass dependsOnOtherTypes |
	structureClasses isEmpty ifTrue: [^ self].
	structClass := structureClasses anyOne.
	
	[dependsOnOtherTypes := structClass typeNamesFromWhichIDepend.
	prevStructClass := structureClasses detect: [:c | c ~~ structClass and: [dependsOnOtherTypes includes: c name]] ifNone: [nil].
	prevStructClass isNil]
		whileFalse: [structClass := prevStructClass].

	"we found a structure/alias which does not depend on other structures/aliases
	add the corresponding class to the initialization list"
	sortedClasses add: (structureClasses remove: structClass)] repeat! !

!ExternalStructure class methodsFor: 'converting' stamp: ''!
typedef
	^self externalType typedef! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
defineFields: fieldSpec
	"Define all the fields in the receiver"
	compiledSpec := self compileFields: fieldSpec withAccessors: #always.
	ExternalType noticeModificationOf: self.
	^compiledSpec! !

!ExternalStructure class methodsFor: 'system startup' stamp: ''!
recompileStructures
	"Check and update the layout of all subclasses for host machine dependency.
	Arrange to check the inner nested structures first."
	
	"ExternalStructure recompileStructures"
	| sorted unsorted |
	unsorted := self withAllSubclasses.
	sorted := OrderedCollection new: unsorted size.
	self sortStructs: unsorted into: sorted.
	sorted do: [:e | e checkFieldLayoutChange]! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
shouldGenerate: fieldname policy: aSymbol 
	"Answer true if the field accessors must be compiled.
	Do so according to the following rules:
	- aSymbol = #always always generate the accessors
	- aSymbol = #never never generate the accessors
	- aSymbol = #generated only re-generate the auto-generated accessors
	- aSymbol = #absent only generate the absent accessors"
	aSymbol = #never ifTrue: [^ false].
	aSymbol = #always ifTrue: [^ true].
	aSymbol = #absent ifTrue: [^ (self methodDictionary includesKey: fieldname) not].
	aSymbol = #generated
		ifTrue: [^ (self methodDictionary includesKey: fieldname)
				and: [(self methodDictionary at: fieldname) pragmas
						anySatisfy: [:p | p selector = #generated]]].
	self error: 'unknow generation policy'! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
compileFields
	"Compile the field definition of the receiver.
	Return the newly compiled spec."
	^self compileFields: self fields! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
compileAlias: spec withAccessors: aSymbol

	"Define all the fields in the receiver.
	Return the newly compiled spec."

	| fieldName fieldType isPointerField externalType newCompiledSpec |

	fieldName := spec first.
	fieldType := spec second.
	isPointerField := fieldType last = $*.
	fieldType := fieldType copyWithout: $*.
	externalType := ExternalType atomicTypeNamed: fieldType.
	externalType
		ifNil:
			[ "non-atomic" Symbol hasInterned: fieldType ifTrue: [ :sym | externalType := ExternalType structTypeNamed: sym ] ].
	externalType
		ifNil: [ self trace: '(' , fieldType , ' is void)'.
			externalType := ExternalType void
			].
	isPointerField
		ifTrue: [ externalType := externalType asPointerType ].
	( fieldName notNil and: [ self shouldGenerate: fieldName policy: aSymbol ] )
		ifTrue: [ self defineAliasAccessorsFor: fieldName type: externalType ].
	newCompiledSpec := isPointerField
		ifTrue: [ WordArray with: ( ExternalType structureSpec bitOr: ExternalType pointerSpec ) ]
		ifFalse: [ externalType compiledSpec ].
	^ newCompiledSpec! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
checkFieldLayoutChange
	"Recompile the spec and field accessors if the layout changed.
	Answer true if the layout changed.
	This is usefull at system startup if some structure are machine dependent.
	No provision is made for correct initialization order of nested structures.
	The correct order of invocation is left at upper responsibility."
	
	| newCompiledSpec oldCompiledSpec |
	oldCompiledSpec := compiledSpec.
	newCompiledSpec := self compileFields: self fields withAccessors: #never.
	oldCompiledSpec = newCompiledSpec ifTrue: [^false].
	"only regenerate the automatically generated fields: the others are under user responsibility"
	compiledSpec := self compileFields: self fields withAccessors: #generated.
	ExternalType noticeModificationOf: self.
	^true! !

!ExternalStructure class methodsFor: 'field definition' stamp: ''!
typeNamesFromWhichIDepend
	"Answer the set of type names of my fields (including pointer stars)"
	| f |
	(f := self fields) isEmpty ifTrue: [^Set new].
	f first isArray ifFalse: [^Set with: f second].
	^f collect: [:e | e second] as: Set! !

!ExternalStructure class methodsFor: 'instance creation' stamp: ''!
fromHandle: aHandle
	^self basicNew setHandle: aHandle! !

!ExternalStructure class methodsFor: 'converting' stamp: ''!
externalType
	"Return an external type describing the receiver as a structure"
	^ExternalType structTypeNamed: self name! !

!ExternalType commentStamp: ''!
An external type represents the type of external objects.

Instance variables:
	compiledSpec	<WordArray>		Compiled specification of the external type
	referentClass	<Behavior | nil>	Class type of argument required
	referencedType	<ExternalType>	Associated (non)pointer type with the receiver

Compiled Spec:
The compiled spec defines the type in terms which are understood by the VM. Each word is defined as:
	bits 0...15 	- byte size of the entity
	bit 16		- structure flag (FFIFlagStructure)
				  This flag is set if the following words define a structure
	bit 17		- pointer flag (FFIFlagPointer)
				  This flag is set if the entity represents a pointer to another object
	bit 18		- atomic flag (FFIFlagAtomic)
				  This flag is set if the entity represents an atomic type.
				  If the flag is set the atomic type bits are valid.
	bits 19...23	- unused
	bits 24...27	- atomic type (FFITypeVoid ... FFITypeDoubleFloat)
	bits 28...31	- unused

Note that all combinations of the flags FFIFlagPointer, FFIFlagAtomic, and FFIFlagStructure are invalid, EXCEPT from the following:

	FFIFlagPointer + FFIFlagAtomic:
		This defines a pointer to an atomic type (e.g., 'char*', 'int*').
		The actual atomic type is represented in the atomic type bits.

	FFIFlagPointer + FFIFlagStructure:
		This defines a structure which is a typedef of a pointer type as in
			typedef void* VoidPointer;
			typedef Pixmap* PixmapPtr;
		It requires a byte size of four (e.g. a 32bit pointer) to work correctly.

[Note: Other combinations may be allowed in the future]
!
!ExternalType methodsFor: 'converting' stamp: ''!
asPointerType
	"convert the receiver into a pointer type"
	self isPointerType
		ifTrue:[^self]
		ifFalse:[^referencedType]! !

!ExternalType methodsFor: 'testing' stamp: ''!
isUnsigned
	"Return true if the receiver is an unsigned type.
	Note: Only useful for integer types."
	^self isSigned not! !

!ExternalType methodsFor: 'private' stamp: ''!
newReferentClass: aClass

	"The class I'm referencing has changed. Update my spec."

	referentClass := aClass.
	self isPointerType
		ifTrue: [ ^ self ].	"for pointers only the referentClass changed"
	compiledSpec := referentClass
		ifNil: [ "my class has been removed - make me 'struct { void }'" WordArray with: FFIFlagStructure ]
		ifNotNil: [ "my class has been changed - update my compiledSpec" referentClass compiledSpec ]! !

!ExternalType methodsFor: 'testing' stamp: ''!
isPointerType
	"Return true if the receiver represents a pointer type"
	^self isStructureType not and:[self headerWord anyMask: FFIFlagPointer]! !

!ExternalType methodsFor: 'accessing' stamp: ''!
byteSize
	"Return the size in bytes of this type"
	^self headerWord bitAnd: FFIStructSizeMask! !

!ExternalType methodsFor: 'testing' stamp: ''!
isSigned
	"Return true if the receiver is a signed type.
	Note: Only useful for integer types."
	^self atomicType anyMask: 1! !

!ExternalType methodsFor: 'printing' stamp: ''!
printOn: aStream

	referentClass
		ifNil: [ aStream nextPutAll: ( AtomicTypeNames at: self atomicType ) ]
		ifNotNil: [ aStream nextPutAll: referentClass name ].
	self isPointerType
		ifTrue: [ aStream nextPut: $* ]! !

!ExternalType methodsFor: '*UnifiedFFI' stamp: ''!
offsetReadFieldAt: offsetVariableName
	"Answer a string defining the accessor to an entity of the receiver type starting at the 
	 given byte offset. 
	 Private. Used for field definition only.
	 NOTE: This is used on UFFI to define field accessors that depends on a class variable 
	 (this works like this to allow mapping 32bits and 64bits structures)"
	self isPointerType ifTrue:
		[| accessor |
		accessor := self pointerSize caseOf: {
						[nil]	->	[#pointerAt:].
						[4]	->	[#shortPointerAt:].
						[8]	->	[#longPointerAt:] }.
		 ^String streamContents:
			[:s|
			 referentClass
				ifNil:
					[s nextPutAll: '^ExternalData fromHandle: (handle ', accessor, ' ';
						nextPutAll: offsetVariableName;
						nextPutAll: ') type: ExternalType ';
						nextPutAll: (AtomicTypeNames at: self atomicType);
						nextPutAll: ' asPointerType']
				ifNotNil:
					[s nextPutAll: '^';
						print: referentClass;
						nextPutAll: ' fromHandle: (handle ', accessor, ' ';
						nextPutAll: offsetVariableName;
						nextPut: $)]]].

	self isAtomic ifFalse: "structure type"
		[^ self offsetReadStructFieldAt: offsetVariableName ].

	"Atomic non-pointer types"
	^String streamContents:
		[:s|
		s nextPutAll:'^handle ';
			nextPutAll: (AtomicSelectors at: self atomicType);
			space; nextPutAll: offsetVariableName].! !

!ExternalType methodsFor: 'private' stamp: ''!
readFieldAt: byteOffset
	"Answer a string defining the accessor to an entity of the receiver type starting at the given byte offset. 
	 Private. Used for field definition only."
	self isPointerType ifTrue:
		[| accessor |
		accessor := self pointerSize caseOf: {
						[nil]	->	[#pointerAt:].
						[4]	->	[#shortPointerAt:].
						[8]	->	[#longPointerAt:] }.
		 ^String streamContents:
			[:s|
			 referentClass
				ifNil:
					[s nextPutAll: '^ExternalData fromHandle: (handle ', accessor, ' ';
						print: byteOffset;
						nextPutAll: ') type: ExternalType ';
						nextPutAll: (AtomicTypeNames at: self atomicType);
						nextPutAll: ' asPointerType']
				ifNotNil:
					[s nextPutAll: '^';
						print: referentClass;
						nextPutAll: ' fromHandle: (handle ', accessor, ' ';
						print: byteOffset;
						nextPut: $)]]].

	self isAtomic ifFalse: "structure type"
		[^String streamContents:[:s|
			s nextPutAll:'^';
				print: referentClass;
				nextPutAll:' fromHandle: (handle structAt: ';
				print: byteOffset;
				nextPutAll:' length: ';
				print: self byteSize;
				nextPutAll:')']].

	"Atomic non-pointer types"
	^String streamContents:
		[:s|
		s nextPutAll:'^handle ';
			nextPutAll: (AtomicSelectors at: self atomicType);
			space; print: byteOffset].! !

!ExternalType methodsFor: 'accessing' stamp: ''!
compiledSpec
	"Return the compiled spec of the receiver"
	^compiledSpec! !

!ExternalType methodsFor: 'private' stamp: ''!
embeddedSpecWithSize: typeSize
	"Return a compiled spec for embedding in a new compiled spec."
	| spec header |
	spec := self compiledSpec copy.
	header := spec at: 1.
	header := (header bitAnd: FFIStructSizeMask bitInvert32) bitOr: typeSize.
	spec at: 1 put: header.
	(self isStructureType and:[self isPointerType not])
		ifTrue:[spec := spec copyWith: self class structureSpec].
	^spec! !

!ExternalType methodsFor: 'converting' stamp: ''!
asPointerType: anotherPointerSize
	"convert the receiver into a pointer type"
	| type |
	type := self asPointerType.
	^type pointerSize = anotherPointerSize
		ifTrue: [type]
		ifFalse:
			[type copy pointerSize: anotherPointerSize; yourself]! !

!ExternalType methodsFor: 'printing' stamp: ''!
printAtomicType: spec on: aStream
	self assert: (spec anyMask: FFIFlagAtomic).
	aStream nextPutAll: (#(	'void' 'unsigned char' 'unsigned char' 'signed char'
							'unsigned short' 'short' 'unsigned long' 'long'
							'unsigned long long' 'long long' 'char' 'signed char'
							'float' 'double') at: ((spec bitAnd: FFIAtomicTypeMask) bitShift: FFIAtomicTypeShift negated) + 1).
	aStream space.
	(spec anyMask: FFIFlagPointer) ifTrue:
		[aStream nextPut: $*]! !

!ExternalType methodsFor: 'private' stamp: ''!
headerWord
	"Return the compiled header word"
	^compiledSpec at: 1! !

!ExternalType methodsFor: 'private' stamp: ''!
pointerSize: anInteger
	| spec |
	pointerSize := anInteger.
	(((spec := compiledSpec at: 1) anyMask: FFIFlagPointer)
	 and: [(spec bitAnd: FFIStructSizeMask) ~= anInteger]) ifTrue:
		[compiledSpec := compiledSpec shallowCopy.
		 compiledSpec at: 1 put: (spec bitClear: FFIStructSizeMask) + anInteger]! !

!ExternalType methodsFor: 'private' stamp: ''!
setReferencedType: aType
	referencedType := aType! !

!ExternalType methodsFor: '*UnifiedFFI' stamp: ''!
atomicSelector
	^ AtomicSelectors at: self atomicType! !

!ExternalType methodsFor: '*UnifiedFFI' stamp: ''!
offsetReadStructFieldAt: offsetVariableName
	^ '^ {1} fromHandle: (handle structAt: {2} length: {1} byteSize)' 
		format: { 
			referentClass name.
			offsetVariableName }
! !

!ExternalType methodsFor: '*UnifiedFFI' stamp: ''!
offsetWriteStructFieldAt: offsetVariableName with: valueName
	^ 'handle structAt: {1} put: {2} getHandle length: {3} byteSize' 
		format: {
			offsetVariableName. 
			valueName. 
			referentClass name }! !

!ExternalType methodsFor: 'testing' stamp: ''!
isStructureType
	"Return true if the receiver represents a structure type"
	^self headerWord anyMask: FFIFlagStructure! !

!ExternalType methodsFor: 'accessing' stamp: ''!
atomicType
	^(self headerWord bitAnd: FFIAtomicTypeMask) >> FFIAtomicTypeShift! !

!ExternalType methodsFor: 'accessing' stamp: ''!
pointerSize
	"Answer the pointer size of the receiver, if specified."
	^pointerSize! !

!ExternalType methodsFor: 'testing' stamp: ''!
isVoid
	"Return true if the receiver describes a plain 'void' type"
	^self isAtomic and:[self atomicType = 0]! !

!ExternalType methodsFor: 'testing' stamp: ''!
isAtomic
	"Return true if the receiver describes a built-in type"
	^self headerWord anyMask: FFIFlagAtomic! !

!ExternalType methodsFor: 'private' stamp: ''!
compiledSpec: aWordArray
	compiledSpec := aWordArray.! !

!ExternalType methodsFor: 'testing' stamp: ''!
isIntegerType
	"Return true if the receiver is a built-in integer type"
	| type |
	type := self atomicType.
	^type > FFITypeBool and:[type <= FFITypeUnsignedLongLong]! !

!ExternalType methodsFor: 'accessing' stamp: ''!
referentClass
	"Return the class specifying the receiver"
	^referentClass! !

!ExternalType methodsFor: 'printing' stamp: ''!
typedef
	^String streamContents: [:s| self printTypedefOn: s]! !

!ExternalType methodsFor: 'private' stamp: ''!
externalTypeName
	^'ExternalType ', (AtomicTypeNames at: self atomicType), ' asPointerType'! !

!ExternalType methodsFor: 'converting' stamp: ''!
asNonPointerType
	"convert the receiver into a non pointer type"
	self isPointerType
		ifTrue:[^referencedType]
		ifFalse:[^self]! !

!ExternalType methodsFor: 'private' stamp: ''!
writeFieldAt: byteOffset with: valueName
	"Answer a string defining the accessor to an entity of the receiver type starting at the given byte offset. 
	 Private. Used for field definition only."
	self isPointerType ifTrue:
		[| accessor |
		accessor := self pointerSize caseOf: {
						[nil]	->	[#pointerAt:].
						[4]	->	[#shortPointerAt:].
						[8]	->	[#longPointerAt:] }.
		^String streamContents:
			[:s|
			s nextPutAll:'handle ', accessor, ' ';
				print: byteOffset;
				nextPutAll:' put: ';
				nextPutAll: valueName;
				nextPutAll:' getHandle.']].

	self isAtomic ifFalse:[
		^String streamContents:[:s|
			s nextPutAll:'handle structAt: ';
				print: byteOffset;
				nextPutAll:' put: ';
				nextPutAll: valueName;
				nextPutAll:' getHandle';
				nextPutAll:' length: ';
				print: self byteSize;
				nextPutAll:'.']].

	^String streamContents:[:s|
		s nextPutAll:'handle ';
			nextPutAll: (AtomicSelectors at: self atomicType);
			space; print: byteOffset;
			nextPutAll:' put: ';
			nextPutAll: valueName].! !

!ExternalType methodsFor: '*UnifiedFFI' stamp: ''!
offsetWriteFieldAt: offsetVariableName with: valueName
	"Answer a string defining the accessor to an entity of the receiver type starting at the given byte offset. 
	 Private. Used for field definition only."
	self isPointerType ifTrue:
		[| accessor |
		accessor := self pointerSize caseOf: {
						[nil]	->	[#pointerAt:].
						[4]	->	[#shortPointerAt:].
						[8]	->	[#longPointerAt:] }.
		^String streamContents:
			[:s|
			s nextPutAll:'handle ', accessor, ' ';
				nextPutAll: offsetVariableName;
				nextPutAll:' put: ';
				nextPutAll: valueName;
				nextPutAll:' getHandle.']].

	self isAtomic ifFalse:[
		^ self offsetWriteStructFieldAt: offsetVariableName with: valueName ].

	^String streamContents:[:s|
		s nextPutAll:'handle ';
			nextPutAll: (AtomicSelectors at: self atomicType); space; 
			nextPutAll: offsetVariableName;
			nextPutAll:' put: ';
			nextPutAll: valueName].! !

!ExternalType methodsFor: 'printing' stamp: ''!
printTypedefOn: s
	s nextPutAll: 'typedef '.
	(referentClass notNil
	 and: [(compiledSpec first bitClear: FFIStructSizeMask) = FFIFlagStructure])
		ifTrue:
			[| next |
			 next := 2.
			 s
				nextPutAll: referentClass compositeName;
				nextPutAll: ' {'.
			 referentClass fields withIndexDo:
				[:tuple :i|
				s cr.
				next := self printStructureFieldStartingAt: next
							withName: tuple first
							inClass: referentClass
							on: s
							indent: 1.
				s nextPut: $;].
			 s cr; nextPutAll: '} '.
			 self assert: (next - 1 = compiledSpec size or: [(compiledSpec at: next) = FFIFlagStructure])]
		ifFalse:
			[self printAtomicType: compiledSpec first on: s].
	s nextPutAll: (referentClass ifNotNil: [referentClass name] ifNil: ['foo'])! !

!ExternalType methodsFor: 'printing' stamp: ''!
storeOn: aStream

	referentClass
		ifNil: [ aStream
				nextPutAll: ExternalType name;
				space;
				nextPutAll: ( AtomicTypeNames at: self atomicType )
			]
		ifNotNil: [ aStream
				nextPut: $(;
				nextPutAll: ExternalType name;
				space;
				nextPutAll: #structTypeNamed:;
				space;
				store: referentClass name;
				nextPut: $)
			].
	self isPointerType
		ifTrue: [ aStream
				space;
				nextPutAll: #asPointer
			]! !

!ExternalType methodsFor: '*UnifiedFFI' stamp: ''!
withPointerArity: aNumber
	self flag: #pharoTodo. "FFI does not understand arity>1 (for now), so I will ignore it and return 
	 the #referencedType in case I want a pointer... this needs to be fixed."
	^ aNumber > 0  
		ifTrue: [ self asPointerType  ]
		ifFalse: [ self ]! !

!ExternalType methodsFor: 'printing' stamp: ''!
printStructureFieldStartingAt: initialSpecIndex withName: name inClass: structureClass on: aStream indent: indent
	"Print the structure's field starting at initialSpecIndex and answer the index in compiledSpec of the subsequent type."
	| spec subStructureClassBinding |
	aStream tab: indent.
	spec := compiledSpec at: initialSpecIndex.
	(spec anyMask: FFIFlagAtomic) ifTrue:
		[self printAtomicType: spec on: aStream.
		 aStream nextPutAll: (name ifNotNil: [name] ifNil: ['foo']).
		 ^initialSpecIndex + 1].
	 subStructureClassBinding := (structureClass >> name) literals detect:
									[:l| l isVariableBinding and: [l value inheritsFrom: ExternalStructure]].
	(spec bitClear: FFIStructSizeMask) = FFIFlagStructure ifTrue:
		[| next |
		 next := initialSpecIndex + 1.
		 aStream
			nextPutAll: subStructureClassBinding value compositeName;
			nextPutAll: ' {'.
		 subStructureClassBinding value fields withIndexDo:
			[:tuple :i|
			aStream cr.
			next := self printStructureFieldStartingAt: next
						withName: tuple first
						inClass: subStructureClassBinding value
						on: aStream
						indent: indent + 1.
			aStream nextPut: $;].
		 aStream crtab: indent; nextPut: $}.
		 name ifNotNil: [aStream space; nextPutAll: name].
		 self assert: (next - 1 = compiledSpec size or: [(compiledSpec at: next) = FFIFlagStructure]).
		 ^next <= compiledSpec size ifTrue: [next + 1] ifFalse: [next]].
	self assert: (spec anyMask: FFIFlagPointer).
	(subStructureClassBinding value isKindOf: ExternalUnion)
			ifTrue: [aStream nextPutAll: 'union ']
			ifFalse: [aStream nextPutAll: 'struct '].
	aStream nextPutAll: subStructureClassBinding value name; nextPutAll: ' *'; nextPutAll: name.
	^initialSpecIndex + 1! !

!ExternalType class methodsFor: 'housekeeping' stamp: ''!
noticeModificationOf: aClass
	"A subclass of ExternalStructure has been redefined.
	Clean out any obsolete references to its type."
	| type |
	aClass isBehavior ifFalse:[^nil]. "how could this happen?"
	aClass withAllSubclassesDo:[:cls|
		type := StructTypes at: cls name ifAbsent:[nil].
		type == nil ifFalse:[
			type newReferentClass: cls.
			type asPointerType newReferentClass: cls].
	].! !

!ExternalType class methodsFor: 'class initialization' stamp: ''!
initializeAtomicTypes
	"ExternalType initialize"
	| atomicType byteSize type typeName |
	#(
		"name		atomic id		byte size"
		('void' 		0 				0)
		('bool' 		1 				1)
		('byte' 		2 				1)
		('sbyte' 	3 				1)
		('ushort' 	4 				2)
		('short' 		5 				2)
		('ulong' 	6 				4)
		('long' 		7 				4)
		('ulonglong' 8 				8)
		('longlong' 	9 				8)
		('char' 		10 				1)
		('schar' 	11 				1)
		('float' 		12 				4)
		('double' 	13 				8)
	) do:[:typeSpec| | compiled |
		typeName := typeSpec first.
		atomicType := typeSpec second.
		byteSize := typeSpec third.
		compiled := WordArray with: ((byteSize bitOr: FFIFlagAtomic) bitOr:
				(atomicType bitShift: FFIAtomicTypeShift)).
		type := (AtomicTypes at: typeName).
		type compiledSpec: compiled.
		compiled := WordArray with: ((self pointerSpec bitOr: FFIFlagAtomic) bitOr:
				(atomicType bitShift: FFIAtomicTypeShift)).
		type asPointerType compiledSpec: compiled.
	].! !

!ExternalType class methodsFor: 'instance creation' stamp: ''!
new
	"Use either the type constants or #externalType for creating external types"
	^self shouldNotImplement! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
bool
	^AtomicTypes at: 'bool'! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
unsignedShort
	^AtomicTypes at: 'ushort'! !

!ExternalType class methodsFor: 'private' stamp: ''!
newTypeNamed: aString force: aBool
	| sym type referentClass pointerType |
	sym := aString asSymbol.
	type := StructTypes at: aString ifAbsent:[nil].
	type == nil ifFalse:[^type].
	referentClass := self environment at: sym ifAbsent:[nil].
	(referentClass isBehavior and:[referentClass includesBehavior: ExternalStructure])
		ifFalse:[referentClass := nil].
	"If we don't have a referent class and are not forced to create a type get out"
	(referentClass == nil and:[aBool not]) ifTrue:[^nil].
	type := self basicNew compiledSpec: 
		(WordArray with: self structureSpec).
	pointerType := self basicNew compiledSpec: 
		(WordArray with: self pointerSpec).
	type setReferencedType: pointerType.
	pointerType setReferencedType: type.
	type newReferentClass: referentClass.
	pointerType newReferentClass: referentClass.
	StructTypes at: sym put: type.
	^type! !

!ExternalType class methodsFor: 'housekeeping' stamp: ''!
cleanupUnusedTypes
	<script>
	
	| value |
	StructTypes keysDo: [:key|
		value := StructTypes at: key.
		value ifNil: [ StructTypes removeKey: key ifAbsent:[] ]]! !

!ExternalType class methodsFor: 'housekeeping' stamp: ''!
noticeRemovalOf: aClass
	"A subclass of ExternalStructure is being removed.
	Clean out any obsolete references to its type."
	| type |
	type := StructTypes at: aClass name ifAbsent:[nil].
	type == nil ifFalse:[
		type newReferentClass: nil.
		type asPointerType newReferentClass: nil].! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
signedShort
	^AtomicTypes at: 'short'! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
float
	^AtomicTypes at: 'float'! !

!ExternalType class methodsFor: 'private' stamp: ''!
atomicTypeNamed: aString
	^AtomicTypes at: aString ifAbsent:[nil]! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
string
	^(AtomicTypes at: 'char') asPointerType! !

!ExternalType class methodsFor: 'class initialization' stamp: ''!
initializeStructureTypes
	"ExternalType initialize"
	| referentClass pointerType |
	self cleanupUnusedTypes.
	StructTypes keysAndValuesDo:[:referentName :type|
		referentClass := (self environment at: referentName ifAbsent:[nil]).
		(referentClass isBehavior and:[
			referentClass includesBehavior: ExternalStructure])
				ifFalse:[referentClass := nil].
		type compiledSpec: 
			(WordArray with: self structureSpec).
		type newReferentClass: referentClass.
		pointerType := type asPointerType.
		pointerType compiledSpec: 
			(WordArray with: self pointerSpec).
		pointerType newReferentClass: referentClass.
	].! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
ushort
	^self unsignedShort! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
void
	^AtomicTypes at: 'void'! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
double
	^AtomicTypes at: 'double'! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
sbyte
	^self signedByte! !

!ExternalType class methodsFor: 'private' stamp: ''!
pointerSpec
	^(Smalltalk wordSize bitOr: FFIFlagPointer)! !

!ExternalType class methodsFor: 'private' stamp: ''!
forceTypeNamed: aString
	^self newTypeNamed: aString force: true! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
ulong
	^self unsignedLong! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
unsignedLong
	^AtomicTypes at: 'ulong'! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
unsignedChar
	^AtomicTypes at: 'char'! !

!ExternalType class methodsFor: 'class initialization' stamp: ''!
initialize
	"ExternalType initialize"
	self initializeFFIConstants.
	self initializeDefaultTypes.! !

!ExternalType class methodsFor: 'private' stamp: ''!
structureSpec
	^FFIFlagStructure! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
char
	"char defaults to unsigned char"
	^self unsignedChar! !

!ExternalType class methodsFor: 'class initialization' stamp: ''!
initializeFFIConstants
	"ExternalType initialize"
	FFIConstants initialize. "ensure proper initialization"
	AtomicTypeNames := IdentityDictionary new.
	AtomicSelectors := IdentityDictionary new.
	AtomicTypeNames
		at: FFITypeVoid put: 'void';
		at: FFITypeBool put: 'bool';
		at: FFITypeUnsignedByte put: 'byte';
		at: FFITypeSignedByte put: 'sbyte';
		at: FFITypeUnsignedShort put: 'ushort';
		at: FFITypeSignedShort put: 'short';
		at: FFITypeUnsignedInt put: 'ulong';
		at: FFITypeSignedInt put: 'long';
		at: FFITypeUnsignedLongLong put: 'ulonglong';
		at: FFITypeSignedLongLong put: 'longlong';
		at: FFITypeUnsignedChar put: 'char';
		at: FFITypeSignedChar put: 'schar';
		at: FFITypeSingleFloat put: 'float';
		at: FFITypeDoubleFloat put: 'double';
	yourself.

	AtomicSelectors
		at: FFITypeVoid put: #voidAt:;
		at: FFITypeBool put: #booleanAt:;
		at: FFITypeUnsignedByte put: #unsignedByteAt:;
		at: FFITypeSignedByte put: #signedByteAt:;
		at: FFITypeUnsignedShort put: #unsignedShortAt:;
		at: FFITypeSignedShort put: #signedShortAt:;
		at: FFITypeUnsignedInt put: #unsignedLongAt:;
		at: FFITypeSignedInt put: #signedLongAt:;
		at: FFITypeUnsignedLongLong put: #unsignedLongLongAt:;
		at: FFITypeSignedLongLong put: #signedLongLongAt:;
		at: FFITypeUnsignedChar put: #unsignedCharAt:;
		at: FFITypeSignedChar put: #signedCharAt:;
		at: FFITypeSingleFloat put: #floatAt:;
		at: FFITypeDoubleFloat put: #doubleAt:;
	yourself! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
unsignedByte
	^AtomicTypes at: 'byte'! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
signedLongLong
	^AtomicTypes at: 'longlong'! !

!ExternalType class methodsFor: 'private' stamp: ''!
structTypeNamed: aSymbol
	aSymbol == nil ifTrue:[^nil].
	^self newTypeNamed: aSymbol force: false! !

!ExternalType class methodsFor: 'class initialization' stamp: ''!
initializeDefaultTypes
	"ExternalType initialize"
	| type pointerType |
	AtomicTypes = nil ifTrue:[
		"Create new atomic types and setup the dictionaries"
		AtomicTypes := Dictionary new.
		StructTypes := WeakValueDictionary new.
		AtomicTypeNames valuesDo:[:k|
			type := self basicNew.
			pointerType := self basicNew.
			AtomicTypes at: k put: type.
			type setReferencedType: pointerType.
			pointerType setReferencedType: type.
		].
	].
	self initializeAtomicTypes.
	self initializeStructureTypes.
	"AtomicTypes := nil"! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
short
	^self signedShort! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
signedByte
	^AtomicTypes at: 'sbyte'! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
byte
	"byte defaults to unsigned byte"
	^self unsignedByte! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
unsignedLongLong
	^AtomicTypes at: 'ulonglong'! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
signedChar
	^AtomicTypes at: 'schar'! !

!ExternalType class methodsFor: 'housekeeping' stamp: ''!
noticeRenamingOf: aClass from: oldName to: newName
	"An ExternalStructure has been renamed from oldName to newName.
	Keep our type names in sync."
	| type |
	type := StructTypes at: oldName ifAbsent:[nil].
	type == nil ifFalse:[StructTypes at: newName put: type].
	StructTypes removeKey: oldName ifAbsent:[].! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
signedLong
	^AtomicTypes at: 'long'! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
long
	^self signedLong! !

!ExternalType class methodsFor: 'type constants' stamp: ''!
schar
	^self signedChar! !

!ExternalUnion commentStamp: ''!
An ExternalUnion is for representing external data that is a union of possible fields.
It corresponds to the C type union.
It reserves enough bytes of data for representing the largest field.

A specific union is defined by subclassing ExternalUnion and specifying its #fields via a class side.

For example if we define a subclass:
	ExternalUnion subclass: #UnionExample
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'garbage'.
Then set the fields like this:
    UnionExample class compile: 'fields  ^#( (name ''char*'') (color ''ulong'') )' classified: 'garbage'.

It means that this type will represent
- either a string (accessed through the field #name)
- or an unsigned 32bit integer (accessed thru the field #color).

It represents the following C type:
   union UnionExample {char *name; uint32_t color; };

The accessors for those fields can be generated automatically like this:
	UnionExample defineFields.
As can be verified in a Browser:
	UnionExample browse.
We see that color and name fields both interpret the same zone of data (starting at 1st byte), but with a different interpretation.
The size of the union can be verified with:
	UnionExample byteSize = (Smalltalk wordSize max: 4).!
!ExternalUnion class methodsFor: 'field definition' stamp: ''!
compileFields: specArray withAccessors: aSymbol 
	"Compile a type specification for the FFI machinery.
	Return the newly compiled spec.
	Eventually generate the field accessors according to the policy defined in aSymbol."
	| byteOffset maxByteSize typeSpec newCompiledSpec |
	(specArray size > 0 and: [specArray first class ~~ Array]) ifTrue:
		[^ self error: 'unions must have fields defined by sub-Array'].
	byteOffset := 1.
	maxByteSize := 0.
	typeSpec := WriteStream on: (WordArray new: specArray size + 1).
	typeSpec nextPut: FFIFlagStructure.
	"dummy for size"
	specArray do:
		[:spec |
		| fieldName fieldType isPointerField externalType typeSize selfRefering |
		fieldName := spec first.
		fieldType := spec second.
		isPointerField := fieldType last = $*.
		fieldType := (fieldType findTokens: ' *') first.
		externalType := ExternalType atomicTypeNamed: fieldType.
		selfRefering := isPointerField and: [externalType isNil and: [fieldType = self asString]].
		selfRefering ifTrue: [
			externalType := ExternalType void asPointerType
		] ifFalse:[
			externalType == nil ifTrue: ["non-atomic"
				Symbol
					hasInterned: fieldType
					ifTrue: [:sym | externalType := ExternalType structTypeNamed: sym].
			].
			externalType == nil ifTrue:[
				self trace: '(' , fieldType , ' is void)'.
				externalType := ExternalType void.
			].
			isPointerField ifTrue: [externalType := externalType asPointerType: self pointerSize]].
			typeSize := externalType byteSize.
			spec size > 2 ifTrue: ["extra size"
				spec third < typeSize
					ifTrue: [^ self error: 'Explicit type size is less than expected'].
				typeSize := spec third.
			].
			(fieldName notNil and: [self shouldGenerate: fieldName policy: aSymbol]) ifTrue: [
				self defineFieldAccessorsFor: fieldName startingAt: byteOffset type: externalType.
			].
			typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
			maxByteSize := maxByteSize max: typeSize.
		].
	newCompiledSpec := typeSpec contents.
	newCompiledSpec at: 1 put: (maxByteSize bitOr: FFIFlagStructure).
	^ newCompiledSpec! !

!ExternalUnion class methodsFor: 'converting' stamp: ''!
compositeName
	^'union'! !

!FBDASTBuilder commentStamp: ''!
I am used to create AST nodes. This class is reserved for the RBAST. 

methodClass <Behavior> behavior where the compiled method is installed.!
!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeBlock: body arguments: args
	^ RBBlockNode arguments: args body: body! !

!FBDASTBuilder methodsFor: 'constructor' stamp: ''!
codeAnyLitInd: anAssociation
	| varName |
	"class binding on the class side has nil as key"
	varName := anAssociation key ifNil: [ 'class binding' ] ifNotNil: [ anAssociation key ].
	^ (RBVariableNode named: varName)
		binding: anAssociation;
		yourself! !

!FBDASTBuilder methodsFor: 'accessing' stamp: ''!
methodClass
	^ methodClass! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeArgument: tempName
	^ RBVariableNode named: tempName! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeMessage: selector receiver: rcvr arguments:args
	^ RBMessageNode receiver: rcvr selector: selector arguments: args! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeLiteral: lit
	^ RBLiteralNode value: lit! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeSequence: temps
	^ RBSequenceNode temporaries: temps statements: OrderedCollection new! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeRepeatNode: body
	^ (self
		codeMessage: #repeat
		receiver: (self codeBlock: body)
		arguments: #() ) 
			propertyAt: #reconstructed put: true;
			yourself! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeEmptySequence
	^ self codeSequence: #()! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeBlockFromStatements: statements
	^ self codeBlock: ((self codeSequence: #()) statements: statements; yourself)! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeSelf
	^ RBVariableNode selfNode! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeReturn: value
	^ RBReturnNode value: value! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeArray: array
	^ RBArrayNode statements: array! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeSuper
	^ RBVariableNode superNode! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeLoopNode: bool condition: seq1 body: seq2
	^ (self
		codeMessage: (#while , bool class name , ':') asSymbol
		receiver: (self codeBlock: seq1)
		arguments: {self codeBlock: seq2})
		propertyAt: #reconstructed put: true;
		yourself! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeEmptyBlock
	^ RBBlockNode body: (self codeSequence: #())! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeThisContext
	^ RBVariableNode thisContextNode! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeConditionalNode: expr trueSequence: seq1 falseSequence: seq2
	^ (self
		codeMessage: #ifTrue:ifFalse:
		receiver: expr
		arguments:
			{self codeBlock: seq1.
			self codeBlock: seq2})
		propertyAt: #reconstructed put: true;
		yourself! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeVariable: variable
	^ RBVariableNode named: variable! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeAssignment: value to: variable
	^ RBAssignmentNode variable: variable value: value! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeCascade: messages
	^ RBCascadeNode messages: messages! !

!FBDASTBuilder methodsFor: 'accessing' stamp: ''!
methodClass: anObject
	methodClass := anObject! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeBlock: body
	^ self codeBlock: body arguments: #()! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeReceiver
	^ RBVariableNode selfNode! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeInstanceVariable: offset
	^ RBVariableNode named: (methodClass allInstVarNames at: offset)! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeMethod: selector arguments: args body: body pragmas: pragmas class: class
	^ ((RBMethodNode selector: selector arguments: args body: body)
		pragmas: pragmas;
		methodClass: class;
		yourself) doSemanticAnalysis! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeLiteralValue: lit
	^ RBLiteralValueNode value: lit! !

!FBDASTBuilder methodsFor: 'building' stamp: ''!
codeTemp: tempName
	^ RBVariableNode named: tempName! !

!FBDASTBuilder class methodsFor: 'instance creation' stamp: ''!
newFor: class
	^ self new
		methodClass: class;
		yourself! !

!FBDConditionalLoop commentStamp: ''!
I represent a conditional loop (typically, a for or while loop). In addition to my superclass I hold the pc of the conditional jump that exits the loop body.

exitCondition <Smi> pc of the conditional jump where the execution flows exits the loop body.!
!FBDConditionalLoop methodsFor: 'testing' stamp: ''!
isConditionalLoop
	^ true! !

!FBDConditionalLoop methodsFor: 'accessing' stamp: ''!
exitCondition
	^ exitCondition! !

!FBDConditionalLoop methodsFor: 'accessing' stamp: ''!
exitCondition: anObject
	exitCondition := anObject! !

!FBDDecompiler commentStamp: ''!
I am the main class of FBD package.
My job is to decompile a compiledMethod to get valid Abstract Syntax Tree (AST).

The first step of decompilation is to give the byte code to the FBDLoopScanner, to annotate it. This will be important to detect all the loops in the method and handle it correctly in the Decompiler.

The second step of decompilation is to interpret the byte code to create corresponding AST nodes. The decompiler will call the right ASTBuilder method and create a full AST. 

Then the AST is returned. The Flashback Decompiler's job stops there, because there are already some frameworks to generate Smalltalk code from an AST.

The returned AST does not take optimized messages into account. Use FBDOptimizedMessagesRewriter to recover the optimized messages.

Instance Variables
	simulatedStack <OrderedCollection> Simulates the bytecode stack, pushing AST nodes instead of concrete values
	builder <FBDASTBuilder> change to another builder to build another AST than RB. By default, use a builder building RB nodes 
	instructionStream <InstructionStream> used to decode the bytecode.
	currentSequence <RBSequence> current AST sequence being decompiled
	argCount <SmallInteger> counter to create args into the current sequence with a valid name
	tempCount <SmallInteger> counter to create temps into the current sequence with a valid name
	jumpSize <SmallInteger> used to remember a jump size during a dual branch message decompilation
	loopsArray <Array> is the array containing informations about loops that the loop scanner gave me
!
!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
pushConsArrayWithElements: numElements
	| array |
	array := Array new: numElements.
	numElements to: 1 by: -1 do: [ :i | array at: i put: simulatedStack removeLast ].
	simulatedStack addLast: (builder codeArray: array)! !

!FBDDecompiler methodsFor: 'private' stamp: ''!
interpretMethod: aCompiledMethod
	self maybeSkipCallPrimitiveBytecode: aCompiledMethod.
	aCompiledMethod isQuick
		ifTrue: [ self quickMethod ]
		ifFalse: [ 
			self initializeErrorCode: aCompiledMethod.
			self interpret: aCompiledMethod endPC ]! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
pragmasForMethod: aCompiledMethod
	^ aCompiledMethod pragmas collect: [ :each |
		RBPragmaNode 
			selector: each selector 
			arguments: (each arguments collect: [ :arg | RBLiteralNode value: arg ]) ]! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
send: selector numArgs: numberArguments
	| args |
	args := self popFromStack: numberArguments.
	simulatedStack addLast: (builder codeMessage: selector receiver: simulatedStack removeLast arguments: args)! !

!FBDDecompiler methodsFor: 'control flow instructions' stamp: ''!
decodeLoops: loops
	"There are multiple loops if all their backjumps target the same pc.
	In this case the loops are ordereed from innerMost to outerMost, and we decompile them in the correct order so the inner loop is decompiled inside the outerloop"
	self decodeLoop: loops removeLast nextLoops: loops! !

!FBDDecompiler methodsFor: 'public api' stamp: ''!
decompile: aCompiledMethod
	"Main API. Works only if the method holds a reference to the class it is installed in and its selector. Answers an AST"
	^ self
		decompile: aCompiledMethod selector
		in: aCompiledMethod methodClass
		method: aCompiledMethod! !

!FBDDecompiler methodsFor: 'control flow instructions' stamp: ''!
interpret: endPC nextLoops: loops
	loops 
		ifNotEmpty: [ self decodeLoops: loops ]
		ifEmpty: [ self pc > endPC ifFalse: [ instructionStream interpretNextInstructionFor: self ] ].
	self interpret: endPC! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
popIntoLiteralVariable: association
	self storeIntoLiteralVariable: association.
	self doPop.! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
send: selector super: supered numArgs: numberArguments
	supered 
		ifTrue:[ self superSend: selector numArgs: numberArguments ]
		ifFalse: [ self send: selector numArgs: numberArguments ]! !

!FBDDecompiler methodsFor: 'private' stamp: ''!
interpret: endPC
	[ self pc > endPC ]
		whileFalse: [ 
			(loopsArray at: self pc)
				ifNotNil: [ :ls | self decodeLoops: ls ]
				ifNil: [ instructionStream interpretNextInstructionFor: self ] ].! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
initializeErrorCode: cm
	| index |
	cm isPrimitive
		ifFalse: [ ^ self ].
	instructionStream willStore
		ifFalse: [ ^ self ].
	index := instructionStream decodeNextInstruction arguments first.
	currentSequence removeTemporaryNamed: (simulatedStack at: index + 1) name.
	simulatedStack at: index + 1 put: (builder codeTemp: (self errorCodeNameFor: cm))! !

!FBDDecompiler methodsFor: 'private' stamp: ''!
incrArgCount
	argCount := argCount + 1! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
pushReceiver
	simulatedStack addLast: builder codeReceiver! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
goToNextInstruction
	instructionStream advanceToFollowingPc! !

!FBDDecompiler methodsFor: 'control flow instructions' stamp: ''!
decodeLoop: loop nextLoops: loops
	loop isConditionalLoop
		ifTrue: [ self decodeConditionalLoop: loop nextLoops: loops ]
		ifFalse: [ self decodeRepeatLoop: loop nextLoops: loops ]! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
pushNewArrayOfSize: numElements
	"tempVector"

	| tempVect |
	tempVect := self createNTemps: numElements.
	currentSequence addTemporariesNamed: (tempVect collect: [ :e | e name ]).
	simulatedStack addLast: tempVect! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
pushLiteralVariable: anAssociation
	simulatedStack addLast: (builder codeAnyLitInd: anAssociation)! !

!FBDDecompiler methodsFor: 'asserting' stamp: ''!
shouldUseOriginalMethod: aCompiledMethod
	^ aCompiledMethod hasProperty: #ffiNonCompiledMethod! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
initializeStack
	argCount := 0.
	tempCount := 0.
	self
		initializeStackNumArgs: method numArgs
		copied: #()
		numTemps: method numTemps - method numArgs! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
methodReturnTop
	^ currentSequence addNode: (builder codeReturn: simulatedStack removeLast)! !

!FBDDecompiler methodsFor: 'private' stamp: ''!
popFromStack: numElements
	^ ((1 to: numElements) collect: [ :i | simulatedStack removeLast ]) reverse! !

!FBDDecompiler methodsFor: 'instruction decoding forward' stamp: ''!
methodReturnReceiver
	self pushReceiver.
	self methodReturnTop! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
pushActiveContext
	simulatedStack addLast: builder codeThisContext! !

!FBDDecompiler methodsFor: 'closure support' stamp: ''!
pushCleanClosure: aCompiledBlock

	| savedSimStack savedSequence |

	savedSimStack := simulatedStack.
	savedSequence := currentSequence.

	simulatedStack addLast: (self
		extractFullBlock: aCompiledBlock numCopied: 0).

	simulatedStack := savedSimStack.
	currentSequence := savedSequence.! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
popIntoReceiverVariable: offset 
	self storeIntoReceiverVariable: offset.
	self doPop.! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
superSend: selector numArgs: numberArguments
	| args |
	args := self popFromStack: numberArguments.
	simulatedStack removeLast.
	simulatedStack addLast: (builder codeMessage: selector receiver: builder codeSuper arguments: args ).! !

!FBDDecompiler methodsFor: 'private' stamp: ''!
newTemp	
	self incrTempCount.
	^ builder codeTemp: 'tmp' , tempCount printString! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
initializeForMethod: aCompiledMethod
	method := aCompiledMethod.
	loopsArray := FBDLoopScanner scan: method.
	instructionStream := InstructionStream on: method.
	self initializeStack.
	jumpSize := 0! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
popIntoTemporaryVariable: offset
	simulatedStack last class = Array
		ifTrue: [ 
			"Temp vector"
			currentSequence removeTemporaryNamed: (simulatedStack at: offset + 1) name.
			simulatedStack at: offset + 1 put: simulatedStack removeLast ]
		ifFalse: [ 
			simulatedStack
				addLast: (builder codeAssignment: simulatedStack removeLast to: (simulatedStack at: offset + 1)). self doPop ]! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
blockReturnTop
	self doPop! !

!FBDDecompiler methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	| newMethod |
	newMethod := oldClass compiler
		source: (self decompile: oldClass >> selector) formattedCode;
		class: oldClass;
		failBlock: [ ^ self ];
		compiledMethodTrailer: CompiledMethodTrailer empty;
		compile.	"Assume OK after proceed from SyntaxError"
	selector == newMethod selector
		ifFalse: [ self error: 'selector changed!!' ].
	oldClass 	addSelector: selector withRecompiledMethod: newMethod.! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
isPrimitiveNativeCall: aCompiledMethod
	aCompiledMethod isPrimitive
		ifFalse: [ ^ false ].
	^ (aCompiledMethod pragmas anySatisfy: [ :aPragma | aPragma arguments isNotEmpty and: [ (aPragma argumentAt: 1) = 'primitiveNativeCall' ] ])! !

!FBDDecompiler methodsFor: 'control flow instructions' stamp: ''!
interpret: seq1 then: seq2 distance: distance
	| hasPopped hasPopped2 jmpSz topValue stackSize |
	"If next instruction will pop, skip it and pop the element from the stack"
	instructionStream willJustPop ifTrue: [ 
			topValue := simulatedStack removeLast.
			instructionStream advanceToFollowingPc ].

	stackSize := simulatedStack size.
	hasPopped := self interpretSeq: seq1 baseStackSize: stackSize distance: distance - topValue notNil asBit.
	jmpSz := jumpSize.
	jumpSize := 0.
	topValue ifNotNil: [:e | simulatedStack addLast: e ].
	hasPopped2 := self interpretSeq: seq2 baseStackSize: stackSize distance: jmpSz.
	^ hasPopped2 or: [hasPopped]! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
createNArgs: numArgs
	
	| argName |
	^ (1 to: numArgs)
		collect: [ :i | 
			self incrArgCount.
			argName := (method propertyAt: #argumentNames)
				ifNil: [ 'arg' , argCount printString ]
				ifNotNil: [ :args | args at: argCount ].
			builder codeArgument: argName ]! !

!FBDDecompiler methodsFor: 'recompilation' stamp: ''!
decompileThenRecompileClass: aClass
	{aClass.
	aClass class}
		do: [ :class | 
			class localSelectors
				do: [ :aMethod | self recompile: aMethod from: class ]
				displayingProgress: [ :aMethod | 'Decompiling ' , class name , '>>#' , aMethod asString ] ]! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
storeIntoReceiverVariable: offset 
	simulatedStack addLast: (builder codeAssignment: simulatedStack removeLast to: (builder codeInstanceVariable: offset + 1)).! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
errorCodeNameFor: cm
	"Assumes the method holds a primitive with error code"
	| primitivePragma selectorParts |
	primitivePragma := cm pragmas detect: [ :pragma | 
		selectorParts := pragma selector separateKeywords splitOn: '  '.
		selectorParts first = 'primitive:' ].
	^ primitivePragma argumentAt: (selectorParts indexOf: 'error:')! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
	simulatedStack addLast: ((simulatedStack at: tempVectorIndex + 1) at: remoteTempIndex + 1)! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
	simulatedStack addLast: (builder codeAssignment: simulatedStack removeLast to: ((simulatedStack at: tempVectorIndex + 1) at: remoteTempIndex + 1))! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
	self storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex.
	self doPop.! !

!FBDDecompiler methodsFor: 'public api' stamp: ''!
decompile: aSelector in: aClass method: anInitialCompiledMethod
	| aCompiledMethod |
	builder := FBDASTBuilder newFor: aClass.
	(self canDecompile: anInitialCompiledMethod)
		ifFalse: [ ^ self generateNativeBoostCallErrorMethodFrom: anInitialCompiledMethod ].
	aCompiledMethod := (self shouldUseOriginalMethod: anInitialCompiledMethod)
		ifTrue: [ anInitialCompiledMethod propertyAt: #ffiNonCompiledMethod ]
		ifFalse: [ anInitialCompiledMethod ].
	self initializeForMethod: aCompiledMethod.
	self interpretMethod: aCompiledMethod.
	^ FBDOptimizedMessagesRewriter new
		rewriteAST:
			(builder
				codeMethod: aSelector
				arguments: (simulatedStack first: aCompiledMethod numArgs)
				body: currentSequence
				pragmas: (self pragmasForMethod: aCompiledMethod)
				class: aClass)! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
pushConstant: value
	value isEmbeddedBlock ifTrue: [ ^self pushCleanClosure: value compiledBlock  ].
	simulatedStack addLast: (builder codeLiteral: value)! !

!FBDDecompiler methodsFor: 'public api' stamp: ''!
decompileAll
	Smalltalk globals allClassesAndTraits
		do: [ :classOrTrait | self decompileThenRecompileClass: classOrTrait ]
		displayingProgress: 'Decompiling all classes and traits'! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
quickMethod
	instructionStream method isReturnSelf
		ifTrue: [ ^ self methodReturnReceiver ].
	instructionStream method isReturnSpecial
		ifTrue: [ 
			^ self
				methodReturnConstant:
					(instructionStream method encoderClass quickPrimSpecialConstants at: instructionStream method primitive - 256) ].
	instructionStream method isReturnField
		ifTrue: [ 
			self pushReceiverVariable: instructionStream method returnField.
			^ self methodReturnTop ].
	self error: 'quick method inconsistency'! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
doPop
	currentSequence addNode: simulatedStack removeLast! !

!FBDDecompiler methodsFor: 'control flow instructions' stamp: ''!
decodeRepeatLoop: loop nextLoops: loops
	| pastSequence  |
	
	pastSequence := currentSequence.
	
	currentSequence := builder codeEmptySequence.
	self interpret: loop backjump - 1 nextLoops: loops.
	instructionStream advanceToFollowingPc. "skip backjump"
	
	simulatedStack addLast:  (builder codeRepeatNode:  currentSequence).
	currentSequence := pastSequence.
	self doPop.! !

!FBDDecompiler methodsFor: 'control flow instructions' stamp: ''!
interpretSeq: seq baseStackSize: stackSize distance: distance
	currentSequence := seq.
	self interpret: self pc + distance - 1.
	^ stackSize = simulatedStack size 
		ifFalse: [ self doPop. true ]
		ifTrue: [ false ]! !

!FBDDecompiler methodsFor: 'instruction decoding forward' stamp: ''!
blockReturnConstant: value 
	self pushConstant: value.
	self blockReturnTop! !

!FBDDecompiler methodsFor: 'instruction decoding forward' stamp: ''!
methodReturnConstant: value 
	self pushConstant: value.
	self methodReturnTop! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
skipTemps: numTemps
	instructionStream method encoderClass skipTemps: numTemps for: self! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
createNTemps: numTemps
	^ (1 to: numTemps) collect: [ :i | self newTemp ]! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
doDup
	| dupTemp |
	simulatedStack last class == RBVariableNode
		ifTrue: [ ^ simulatedStack addLast: simulatedStack last ].
	self incrTempCount.
	dupTemp := self newTemp.
	currentSequence addNode: (builder codeAssignment: simulatedStack removeLast to: dupTemp).
	currentSequence addTemporaryNamed: 'tmp' , tempCount printString.
	simulatedStack 
		addLast: dupTemp;
		addLast: dupTemp.! !

!FBDDecompiler methodsFor: 'closure support' stamp: ''!
extractFullBlock: aCompiledBlock numCopied: numCopied

	| oldInstructionStream oldLoops|

	self
		initializeStackNumArgs: aCompiledBlock numArgs
		copied: (self popFromStack: numCopied)
		numTemps: aCompiledBlock numTemps - aCompiledBlock numArgs - numCopied.

	oldLoops := loopsArray.
	oldInstructionStream := instructionStream.

	loopsArray := FBDLoopScanner scan: aCompiledBlock.
	instructionStream := InstructionStream on: aCompiledBlock.

	self interpret: aCompiledBlock endPC.

	instructionStream := oldInstructionStream.
	loopsArray := oldLoops.

	^ builder
		codeBlock: currentSequence
		arguments: (simulatedStack first: aCompiledBlock numArgs)! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
initializeStackNumArgs: numArgs copied: copiedVars numTemps: numTemps
	| args temps |
	simulatedStack := OrderedCollection new.
	args := self createNArgs: numArgs.
	temps := self createNTemps: numTemps.
	args , copiedVars , temps do: [ :arg | simulatedStack addLast: arg ].
	currentSequence := builder codeSequence: temps! !

!FBDDecompiler methodsFor: 'control flow instructions' stamp: ''!
jump: distance if: boolean
	"If we reach this code, this means this is a condition (if) and not a loop."

	| expr trueSeq falseSeq pastSequence hasPopped |
	pastSequence := currentSequence.
	expr := simulatedStack removeLast.
	trueSeq := builder codeEmptySequence.
	falseSeq := builder codeEmptySequence.
	hasPopped := boolean
		ifTrue: [ self interpret: falseSeq then: trueSeq distance: distance ]
		ifFalse: [ self interpret: trueSeq then: falseSeq distance: distance ].
	currentSequence := pastSequence.
	simulatedStack addLast: (builder codeConditionalNode: expr trueSequence: trueSeq falseSequence: falseSeq).
	hasPopped
		ifFalse: [ self doPop ]! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
storeIntoTemporaryVariable: offset
	| val |
	simulatedStack addLast: (builder codeAssignment: (val := simulatedStack removeLast) to: (simulatedStack at: offset +1)).	
	(loopsArray at: self pc) ifNotNil: [ self doPop. simulatedStack addLast: val ]! !

!FBDDecompiler methodsFor: 'initialize' stamp: ''!
canDecompile: aCompiledMethod
	"Answers false if aCompiledMethod can't be decompiled due to framework specific constraints."
	^ (self isPrimitiveNativeCall: aCompiledMethod) not! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
directedSuperSend: selector numArgs: numberArguments

	| args currentClass |

	currentClass := self popFromStack: 1. 
	args := self popFromStack: numberArguments.
	simulatedStack removeLast.
	simulatedStack addLast: (builder codeMessage: selector receiver: builder codeSuper arguments: args ).! !

!FBDDecompiler methodsFor: 'private' stamp: ''!
maybeSkipCallPrimitiveBytecode: aCompiledMethod
	"If the method's bytecode set uses the callPrimitive bytecode, ignore it.
	The primitive is handled specifically before bytecode interpretation."
	instructionStream peekByte = aCompiledMethod encoderClass callPrimitiveCode 
		ifTrue: [ instructionStream advanceToFollowingPc ]! !

!FBDDecompiler methodsFor: 'private' stamp: ''!
pc
	^ instructionStream pc! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
storeIntoLiteralVariable: association
	simulatedStack addLast: (builder codeAssignment: simulatedStack removeLast to: (builder codeVariable: association key))! !

!FBDDecompiler methodsFor: 'private' stamp: ''!
generateNativeBoostCallErrorMethodFrom: aCompiledMethod
	| seq args |
	seq := RBSequenceNode
		statements:
			{RBMessageNode receiver: (RBVariableNode named: #CannotDecompileNativeBoostCalls) selector: #signal arguments: #()}.
	args := OrderedCollection new.
	1 to: aCompiledMethod numArgs do: [ :i | args add: (RBVariableNode named: 'arg' , i asString) ].
	^ builder
		codeMethod: aCompiledMethod selector
		arguments: args
		body: seq
		pragmas: (self pragmasForMethod: aCompiledMethod)
		class: aCompiledMethod methodClass! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
pushTemporaryVariable: offset
	simulatedStack addLast: (simulatedStack at: offset + 1)! !

!FBDDecompiler methodsFor: 'control flow instructions' stamp: ''!
decodeConditionalLoop: loop nextLoops: loops
	| condSeq pastSequence boolean |
	
	pastSequence := currentSequence.
	
	condSeq := builder codeEmptySequence.
	currentSequence := condSeq.
	self interpret: loop exitCondition - 1 nextLoops: loops.
	self doPop.
	boolean := instructionStream willJumpIfFalse.
	instructionStream advanceToFollowingPc. "skip the conditional jump exiting the loop"
	
	currentSequence := builder codeEmptySequence.
	self interpret: loop backjump - 1.
	instructionStream advanceToFollowingPc. "skip the backjump"
	
	simulatedStack addLast:  (builder 
		codeLoopNode: boolean
		condition: condSeq
		body: currentSequence).
	currentSequence := pastSequence.
	self doPop.! !

!FBDDecompiler methodsFor: 'private' stamp: ''!
incrTempCount
	tempCount := tempCount + 1! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
pushFullClosure: aCompiledBlock numCopied: numCopied receiverOnStack: receiverOnStack ignoreOuterContext: ignoreOuterContext 

	| savedSimStack savedSequence |

	savedSimStack := simulatedStack.
	savedSequence := currentSequence.

	receiverOnStack ifTrue: [ self error: 'not yet supported, please open issue' ].

	simulatedStack addLast: (self
		extractFullBlock: aCompiledBlock numCopied: numCopied).

	simulatedStack := savedSimStack.
	currentSequence := savedSequence.! !

!FBDDecompiler methodsFor: 'data flow instructions' stamp: ''!
pushReceiverVariable: offset 
	simulatedStack addLast: (builder codeInstanceVariable: offset + 1)! !

!FBDDecompiler methodsFor: 'control flow instructions' stamp: ''!
jump: distance
	distance < 0 ifTrue: [ ^ self error: 'should have been detected by the scanner and skipped' ].
	jumpSize := distance.! !

!FBDDecompilerTest commentStamp: ''!
SUnit tests for FBSDecompiler!
!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToByDoNegativeLoop

	self decompileThenRecompile:
		(self getMethod: #exampleToByDoNegativeLoop)! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileModificationBefore

	self checkCorrectDecompilation: #exampleWhileModificationBefore! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testClassVar

	self checkCorrectDecompilation: #exampleClassVar! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSuper

	self checkCorrectDecompilation: #exampleSuper! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testBlockNested

	self checkCorrectDecompilation: #exampleBlockNested! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascadeIntoBlockWithTempIntoCascade

	self checkCorrectDecompilation:
		#exampleCascadeIntoBlockWithTempIntoCascade! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoOutsideTemp

	self checkCorrectDecompilation: #exampleToDoOutsideTemp! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCaseOf4
	self checkCorrectDecompilation: #exampleCaseOf4.! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIV

	self checkCorrectDecompilation: #exampleIV! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockArgument5

	self checkCorrectDecompilation: #exampleSimpleBlockArgument5! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockEmpty

	self checkCorrectDecompilation: #exampleSimpleBlockEmpty! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascadeNested

	self checkCorrectDecompilation: #exampleCascadeNested! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascadeIfFalse

	self checkCorrectDecompilation: #exampleCascadeIfFalse! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testBlockWithArg

	self checkCorrectDecompilation: #exampleBlockWithArg! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testAndOr6

	self checkCorrectDecompilation: #exampleAndOr6! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueIfFalse3

	self checkCorrectDecompilation: #exampleIfTrueIfFalse3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testPrimitiveErrorCodeModule

	self decompileThenRecompile:
		(self getMethod: #examplePrimitiveErrorCodeModule)! !

!FBDDecompilerTest methodsFor: 'verification' stamp: ''!
compare: originalMethod with: newMethod

	| gp1 gp2 gp1Result gp2Result |
	gp1 := self exampleClass new.
	gp2 := self exampleClass new.
	gp1Result := gp1 withArgs: #(  ) executeMethod: newMethod.
	gp2Result := gp2 withArgs: #(  ) executeMethod: originalMethod.
	self compareResult: gp1Result with: gp2Result.
	self comparePigs: gp1 with: gp2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testDoubleRemoteAnidatedBlocks

	self checkCorrectDecompilation: #doubleRemoteAnidatedBlocks! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockArgument3

	self checkCorrectDecompilation: #exampleSimpleBlockArgument3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockLocal

	self checkCorrectDecompilation: #exampleSimpleBlockLocal! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueForEffectNested

	self checkCorrectDecompilation: #exampleIfTrueForEffectNested! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testThisContext

	self checkCorrectDecompilation: #exampleThisContext! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testTimesRepeatEffect

	self checkCorrectDecompilation: #exampleTimesRepeatEffect! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueIfFalse2

	self checkCorrectDecompilation: #exampleIfTrueIfFalse2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testOptimizedBlockWrittenAfterClosedOverCase1

	self checkCorrectDecompilation:
		#optimizedBlockWrittenAfterClosedOverCase1! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDo4

	self checkCorrectDecompilation: #exampleToDo4! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoValueLimitExpression
	self checkCorrectDecompilation: #exampleToDoValueLimitExpression! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileNoModification

	self checkCorrectDecompilation: #exampleWhileNoModification! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockLocalIf

	self checkCorrectDecompilation: #exampleSimpleBlockLocalIf! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSend

	self checkCorrectDecompilation: #exampleSend! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testPrimitiveErrorCodeModule2

	self decompileThenRecompile:
		(self getMethod: #examplePrimitiveErrorCodeModule2)! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfNilClosure

	self checkCorrectDecompilation: #exampleIfNilClosure! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
test2Loops2

	self checkCorrectDecompilation: #example2Loops2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockLocalIfNested

	self checkCorrectDecompilation: #exampleSimpleBlockLocalIfNested! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testAndOr5

	self checkCorrectDecompilation: #exampleAndOr5! !

!FBDDecompilerTest methodsFor: 'verification' stamp: ''!
compareResult: result1 with: result2

	self assert: result1 class equals: result2 class! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testBlockExternalArg

	self checkCorrectDecompilation: #exampleBlockExternalArg! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoInsideTempNotInlined

	self checkCorrectDecompilation: #exampleToDoInsideTempNotInlined! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoInsideTemp

	self checkCorrectDecompilation: #exampleToDoInsideTemp! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testAndOr4

	self checkCorrectDecompilation: #exampleAndOr4! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockArgument1

	self checkCorrectDecompilation: #exampleSimpleBlockArgument1! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testPushArray

	self checkCorrectDecompilation: #examplePushArray! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfFalseIfTrue5

	self checkCorrectDecompilation: #exampleIfFalseIfTrue5! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockArgument2

	self checkCorrectDecompilation: #exampleSimpleBlockArgument2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testAnd

	self checkCorrectDecompilation: #exampleAnd! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testMethodWithOptimizedBlocksA

	self checkCorrectDecompilation: #exampleMethodWithOptimizedBlocksA! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testRepeatValue
	self checkCorrectDecompilation: #exampleRepeatValue! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testReturn42

	self checkCorrectDecompilation: #exampleReturn42! !

!FBDDecompilerTest methodsFor: 'accessing' stamp: ''!
exampleClass

	^ FBDExamples! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testNestedBlocksRemoteInBlockCase1

	self checkCorrectDecompilation: #nestedBlocksRemoteInBlockCase1! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCaseOf8

	self checkCorrectDecompilation: #exampleCaseOf8! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfFalseIfTrue3

	self checkCorrectDecompilation: #exampleIfFalseIfTrue3! !

!FBDDecompilerTest methodsFor: 'private' stamp: ''!
decompileThenRecompile: originalMethod

	| methodNode |
	methodNode := FBDDecompiler new decompile: originalMethod.
	methodNode ifNil: [ ^ nil ].
	^ self exampleClass compiler compile: methodNode formattedCode! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testInlineBlockCollectionLR3

	self checkCorrectDecompilation: #exampleInlineBlockCollectionLR3! !

!FBDDecompilerTest methodsFor: 'private' stamp: ''!
getMethod: selector

	^ self exampleClass >> selector! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileTrue

	self checkCorrectDecompilation: #exampleWhileTrue! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testNoRemoteReadInBlock

	self checkCorrectDecompilation: #noRemoteReadInBlock! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testOptimizedBlockWrittenAfterClosedOverCase2

	self checkCorrectDecompilation:
		#optimizedBlockWrittenAfterClosedOverCase2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockNested

	self checkCorrectDecompilation: #exampleSimpleBlockNested! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWithArgsAnd

	self decompileThenRecompile: (self getMethod: #exampleWithArgs:and:)! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileTrue2

	self checkCorrectDecompilation: #exampleWhileTrue2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrue

	self checkCorrectDecompilation: #exampleIfTrue! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascadeIfTrueIfFalse

	self checkCorrectDecompilation: #exampleCascadeIfTrueIfFalse! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testNestedBlocksRemoteInBlockCase3

	self checkCorrectDecompilation: #nestedBlocksRemoteInBlockCase3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileModificationBeforeNotInlined

	self checkCorrectDecompilation:
		#exampleWhileModificationBeforeNotInlined! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testBlockInternal

	self checkCorrectDecompilation: #exampleBlockInternal! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSend2Args

	self checkCorrectDecompilation: #exampleSend2Args! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testNestedBlockScoping

	self checkCorrectDecompilation: #exampleNestedBlockScoping! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testOr

	self checkCorrectDecompilation: #exampleOr! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueWithNilAssertion

	self checkCorrectDecompilation: #exampleIfTrueWithNilAssertion! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfNotNilReturnNil

	self checkCorrectDecompilation: #exampleIfNotNilReturnNil! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testBlockExternal

	self checkCorrectDecompilation: #exampleBlockExternal! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoArgumentNotInlined

	self checkCorrectDecompilation: #exampleToDoArgumentNotInlined! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCaseOf5
	self checkCorrectDecompilation: #exampleCaseOf5.! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockArgument4

	self checkCorrectDecompilation: #exampleSimpleBlockArgument4! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCaseOf7

	self checkCorrectDecompilation: #exampleCaseOf7! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfFalse

	self checkCorrectDecompilation: #exampleIfFalse! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfNilDup

	self checkCorrectDecompilation: #exampleIfNilDup! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueIfFalse

	self checkCorrectDecompilation: #exampleIfTrueIfFalse! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfFalse3

	self checkCorrectDecompilation: #exampleIfFalse3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueIfFalseNested2

	self checkCorrectDecompilation: #exampleIfTrueIfFalseNested2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testAndOr3

	self checkCorrectDecompilation: #exampleAndOr3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testNestedBlocksRemoteInBlockCase2

	self checkCorrectDecompilation: #nestedBlocksRemoteInBlockCase2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlock

	self checkCorrectDecompilation: #exampleSimpleBlock! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWithArgsAndTempsAnd

	self decompileThenRecompile:
		(self getMethod: #exampleWithArgsAndTemps:and:)! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testFullBlock

	self checkCorrectDecompilation: #exampleFullBlock! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDo2

	self checkCorrectDecompilation: #exampleToDo2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfNilIfNotNil

	self checkCorrectDecompilation: #exampleIfNilIfNotNil! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testNewArray

	self checkCorrectDecompilation: #exampleNewArray! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDo3

	self checkCorrectDecompilation: #exampleToDo3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDo5

	self checkCorrectDecompilation: #exampleToDo5! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileTrueSameJumpTarget2

	self checkCorrectDecompilation: #exampleWhileTrueSameJumpTarget2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testTimesRepeatValue

	self checkCorrectDecompilation: #exampleTimesRepeatValue! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockiVar

	self checkCorrectDecompilation: #exampleSimpleBlockiVar! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCaseOf2

	self checkCorrectDecompilation: #exampleCaseOf2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfFalseIfTrue2

	self checkCorrectDecompilation: #exampleIfFalseIfTrue2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascade4

	self checkCorrectDecompilation: #exampleCascade4! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrue2

	self checkCorrectDecompilation: #exampleIfTrue2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueWithOr

	self checkCorrectDecompilation: #exampleIfTrueWithOr! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueIfFalseNested3

	self checkCorrectDecompilation: #exampleIfTrueIfFalseNested3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueIfFalseLikeAnd

	self checkCorrectDecompilation: #exampleIfTrueIfFalseLikeAnd! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testEffectValues

	self checkCorrectDecompilation: #exampleEffectValues! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascade2

	self checkCorrectDecompilation: #exampleCascade2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileTrueSameJumpTarget

	self checkCorrectDecompilation: #exampleWhileTrueSameJumpTarget! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockReturn

	self checkCorrectDecompilation: #exampleSimpleBlockReturn! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSelf

	self checkCorrectDecompilation: #exampleSelf! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfNil

	self checkCorrectDecompilation: #exampleIfNil! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testBlockIntoCascade

	self checkCorrectDecompilation: #exampleBlockIntoCascade! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCaseOf6

	self checkCorrectDecompilation: #exampleCaseOf6! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testBlockNumCopied

	self checkCorrectDecompilation: #exampleBlockNumCopied! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSimpleBlockLocalWhile

	self checkCorrectDecompilation: #exampleSimpleBlockLocalWhile! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testBlockExternalNested

	self checkCorrectDecompilation: #exampleBlockExternalNested! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testPushBigArray

	self checkCorrectDecompilation: #examplePushBigArray! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascadeIntoBlockWithTempIfTrueIfFalse

	self checkCorrectDecompilation:
		#exampleCascadeIntoBlockWithTempIfTrueIfFalse! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfFalseIfTrue4

	self checkCorrectDecompilation: #exampleIfFalseIfTrue4! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileTrue3

	self checkCorrectDecompilation: #exampleWhileTrue3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfFalse2

	self checkCorrectDecompilation: #exampleIfFalse2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testPrimitiveErrorCode

	self checkCorrectDecompilation: #examplePrimitiveErrorCode! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfNotNilArg

	self checkCorrectDecompilation: #exampleIfNotNilArg! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testNoRemoteBlockTemp

	self checkCorrectDecompilation: #noRemoteBlockTemp! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCaseOf

	self checkCorrectDecompilation: #exampleCaseOf! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
test2Loops

	self checkCorrectDecompilation: #example2Loops! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoArgument

	self checkCorrectDecompilation: #exampleToDoArgument! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascade

	self checkCorrectDecompilation: #exampleCascade! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testAnd2

	self checkCorrectDecompilation: #exampleAnd2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testMethodTempInNestedBlock

	self checkCorrectDecompilation: #exampleMethodTempInNestedBlock! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testAndOr2

	self checkCorrectDecompilation: #exampleAndOr2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascadeIntoBlockIntoCascade

	self checkCorrectDecompilation: #exampleCascadeIntoBlockIntoCascade! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testDoublePrimitive
	self checkCorrectDecompilation: #exampleDoublePrimitive! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileFalse

	self checkCorrectDecompilation: #exampleWhileFalse! !

!FBDDecompilerTest methodsFor: 'verification' stamp: ''!
checkCorrectMethodDecompilation: originalMethod

	| newMethod |
	newMethod := self decompileThenRecompile: originalMethod.
	self compare: originalMethod with: newMethod! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfFalseIfTrue

	self checkCorrectDecompilation: #exampleIfFalseIfTrue! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testBlockExternal2

	self checkCorrectDecompilation: #exampleBlockExternal2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCopyingBlock

	self checkCorrectDecompilation: #exampleCopyingBlock! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToByDo

	self decompileThenRecompile: (self getMethod: #exampleToByDo)! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueNested

	self checkCorrectDecompilation: #exampleIfTrueNested! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSuperCallInBlock

	self checkCorrectDecompilation: #superCallInBlock! !

!FBDDecompilerTest methodsFor: 'verification' stamp: ''!
comparePigs: gp1 with: gp2

	self assert: gp1 iVar equals: gp2 iVar! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrueIfFalseNested

	self checkCorrectDecompilation: #exampleIfTrueIfFalseNested! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testRepeatEffect

	self checkCorrectDecompilation: #exampleRepeatEffect! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileWithTempNotInlined

	self checkCorrectDecompilation: #exampleWhileWithTempNotInlined! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testReturn1

	self checkCorrectDecompilation: #exampleReturn1! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testSuperCallInBlockClassSide

	self checkCorrectDecompilationClassSide: #superCallInBlock! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testAndOr

	self checkCorrectDecompilation: #exampleAndOr! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileModificationAfterNotInlined

	self checkCorrectDecompilation:
		#exampleWhileModificationAfterNotInlined! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoInsideBlock

	self checkCorrectDecompilation: #exampleToDoInsideBlock! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCaseOf3

	self checkCorrectDecompilation: #exampleCaseOf3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testEmptyMethod

	self checkCorrectDecompilation: #exampleEmptyMethod! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfTrue3

	self checkCorrectDecompilation: #exampleIfTrue3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascade3

	self checkCorrectDecompilation: #exampleCascade3! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoWithMessage

	self checkCorrectDecompilation: #exampleToDoWithMessage! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCaseOfOtherwise

	self checkCorrectDecompilation: #exampleCaseOfOtherwise! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfFalseIfTrue6

	self checkCorrectDecompilation: #exampleIfFalseIfTrue6! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testIfNotNilDup

	self checkCorrectDecompilation: #exampleIfNotNilDup! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileFalse2

	self checkCorrectDecompilation: #exampleWhileFalse2! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testReturn1plus2

	self checkCorrectDecompilation: #exampleReturn1plus2! !

!FBDDecompilerTest methodsFor: 'verification' stamp: ''!
checkCorrectDecompilationClassSide: aSelector

	self checkCorrectMethodDecompilation: (self getMethodClassSide: aSelector)! !

!FBDDecompilerTest methodsFor: 'private' stamp: ''!
getMethodClassSide: selector

	^ self exampleClass class >> selector! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testNoRemoteBlockArgument

	self checkCorrectDecompilation: #noRemoteBlockArgument! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDo

	self checkCorrectDecompilation: #exampleToDo! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoOutsideTempNotInlined

	self checkCorrectDecompilation: #exampleToDoOutsideTempNotInlined! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testCascadeIfNil

	self checkCorrectDecompilation: #exampleCascadeIfNil! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoValue

	self checkCorrectDecompilation: #exampleToDoValue! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testWhileWithTemp

	self checkCorrectDecompilation: #exampleWhileWithTemp! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testBlockArgument

	self checkCorrectDecompilation: #exampleBlockArgument! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testToDoArgumentLimitIsExpression

	self checkCorrectDecompilation: #exampleToDoArgumentLimitIsExpression! !

!FBDDecompilerTest methodsFor: 'verification' stamp: ''!
checkCorrectDecompilation: aSelector

	self checkCorrectMethodDecompilation: (self getMethod: aSelector)! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testNestedIfNilIfNotNil

	self checkCorrectDecompilation: #exampleNestedIfNilIfNotNil! !

!FBDDecompilerTest methodsFor: 'tests' stamp: ''!
testNoRemoteReadNestedBlocks

	self checkCorrectDecompilation: #noRemoteReadNestedBlocks! !

!FBDExamples commentStamp: ''!
The method of this class in the protocols named examples are supposed to represent all the possible smalltalk semantics in the point of view of the Decompiler!
!FBDExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteInNestedBlockCase3

	| t1 |
	[(true) ifTrue: [ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ] ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfFalse2
	<sampleInstance>
	
	^ true ifFalse: [ ^ 'result' ]! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleCopyingBlock
	<sampleInstance>
	
	| t |
	t := true.
	^ [ t ifTrue: [ 5 + t asBit ]. t ].! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleToDo4
	<sampleInstance>
	
	| tmp1 tmp2 |
	tmp1 := {true . true . true }.
	tmp2 := tmp1 size.
	1 to: tmp2 do: [ :index | tmp1 at: index put: false ].
	1 to: tmp2 do: [ :index | tmp1 at: index put: true ].
	^ tmp1! !

!FBDExamples methodsFor: 'examples' stamp: ''!
singleRemoteTempVar

	| index block theCollection |
	index := 0.
	block := [ 
		theCollection add: [ index ].
		index := index + 1 ].
	[ index < 5 ] whileTrue: block.
	self assertValues: #(5 5 5 5 5)! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
example2Loops

	| t |
	t := 1.
	[ t < 5 ] whileTrue: [ t := t + 1 ].
	[ t > 10 ] whileFalse: [ t := t * 2 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfFalseIfTrue5
	<sampleInstance>
	
	| a |
	a := true.
	a ifFalse: [ ^1 ] ifTrue: [ 1 + 2 ]! !

!FBDExamples methodsFor: 'examples' stamp: ''!
exampleWithArgs: arg1 and: arg2
	<sampleInstance>
	
	^ arg1! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileWithTemp
	<sampleInstance>
	
	| index |
	index := 0.
	[ index < 5 ] whileTrue: [
		| temp |
		temp := index := index + 1.
		collection add: [ temp ] ].
	^collection "#(1 2 3 4 5)"! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCaseOf2
	<sampleInstance>
	
	^ 5 caseOf: {([ 5 ] -> [ #CAIRO_FONT_SLANT_OBLIQUE ])}! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockLocal
	<sampleInstance>
	
	^[ :each | | t |  t:= each. t   ] value: 5! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoInsideBlock

	| tmp1 block |
	tmp1 := {1.2 . 3.4} asOrderedCollection.
	block := [ (tmp1 at: 1) to: (tmp1 at: 4) do: [ :arg1 | self trace: arg1 ] ]! !

!FBDExamples methodsFor: 'examples' stamp: ''!
noRemoteBlockArgument

	| block block1 block2 |
	block := [ :arg | | temp | temp := arg. [ temp ] ].
	block1 := block value: 1.
	block2 := block value: 2! !

!FBDExamples methodsFor: 'examples' stamp: ''!
noRemoteReadNestedBlocks

	 [ |a| a := 1.
       [ a ]]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoOutsideTemp
	<sampleInstance>
	
	| temp |
	1 to: 5 do: [ :index | 
		temp := index. 
		collection add: [ temp ] ].
	^collection "#(5 5 5 5 5)"! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfFalseIfTrue
	<sampleInstance>
	
	true ifFalse: [^1] ifTrue: [^2]! !

!FBDExamples methodsFor: 'examples - simple' stamp: ''!
exampleNewArray
	<sampleInstance>

	| temp |	
	temp := Array new: 3.
	^temp! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfNilIfNotNil3
	<sampleInstance>
	
	| tmp1 |
	tmp1:= true.
	^ tmp1 ifNil: [  5 ] ifNotNil: [ 6 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrueNested
	<sampleInstance>
	
	true ifTrue: [ 
		false ifTrue: [ ^ false ].
		^ true ].
	^ false! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleToDo
	<sampleInstance>
	
	| tmp1 tmp2 tmp3 |
	tmp1 := {true.
	true.
	true}.
	tmp2 := tmp1 size.
	tmp3 := 1.
	[ tmp3 <= tmp2 ]
		whileTrue: [ 
			tmp1 at: tmp3 put: false.
			tmp3 := tmp3 + 1 ].
	^ 1! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfFalse
	<sampleInstance>
	
	true
		ifTrue: [  ]
		ifFalse: [ ^ 1 ].
	^ 2! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleTimesRepeatValue
	<sampleInstance>
	
	^ 5 timesRepeat: [ 1 + 2 ]! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockMethodArgument: arg
	<sampleInstance>
	
	|  block |
	block := [ :blockarg | blockarg + arg].
	self assert: ((block value: 2) = (arg + 2)).
	^block value: 2! !

!FBDExamples methodsFor: 'examples - cascades' stamp: ''!
exampleCascadeIfTrueIfFalse2
	<sampleInstance>
	
	^ { true } asOrderedCollection
		size;
		add:
				(1=1
						ifTrue: [ 'A' ]
						ifFalse: [ 'B' ])! !

!FBDExamples methodsFor: 'examples' stamp: ''!
noRemoteReadInBlock

	| a |
	a := 1.
	[ a ]! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlock
	<sampleInstance>
	
	^[1]! !

!FBDExamples methodsFor: 'examples - simple' stamp: ''!
exampleEmptyMethod! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleAndOr6
	<sampleInstance>
	
	| t1 t2 |
	t1 := true.
	t2 := false.  
	^ t1 and: [ t2 or: [ t1 ] ]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileNoModification
	"tempvars aren't modified in the loop, therefore they don't need to be in a indirection vector.
	  number of temps = declared temps "

	| a b c |
	a := 1.
	b := 2.
	c := 3.
	[ false ]
		whileTrue: [ 
			[ a class.
			  b class.
			  c class ]	"<- block in optimized loop" ]! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleWhileTrue3

	| t1 t2 |
	t2 := 5.
	t1 := 1.
	t1 := t1+1.
	[ t1 <= t2 ]
		whileTrue: [ 
			t1 + 2.
			t1 := t1 + 1 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCascade4
	<sampleInstance>
	| t1 |
	t1 := true
		asBit;
		xor: false.
	^ t1! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleToDo2
	<sampleInstance>
	
	| t |
	t := {true.true.true}.
	1 to: t size do: [ :index | t at: index put: false ].
	^ t! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrueIfFalse2

	| a |
	a := true.
	a ifTrue: [ a:= 1 + 2 ] ifFalse: [ a := 2 + 3 ]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleAndOr5
	<sampleInstance>
	
	| t1 t2 |
	t1 := true.
	t2 := false.  
	^ t2 or: [ t1 and: [ t2 ] ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfNil
	<sampleInstance>
	
	true ifNil: [ ^ 5 ]. ^ 6! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockIntoCascade
	<sampleInstance>
	
	| t |
	t := {true.
	true.
	false}.
	^ t
		size;
		collect: [ :aBoolean | 
					| tmp2 |
					tmp2 := true.
					aBoolean and: [ tmp2 ] ];
		yourself! !

!FBDExamples methodsFor: 'examples' stamp: ''!
singleRemoteDifferentBlocksSameArgumentName

	| b c z |
	b := [:a | 
		z := 2.
		z + a].
	c := [:a |
		z + a].
	^ (b value: 2) + (c value: 1)! !

!FBDExamples methodsFor: 'examples' stamp: ''!
writtenAfterClosedOver

	| a |      
	[ a ].
	a := 1! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCaseOf3
	<sampleInstance>
	
	| t1 |
	5
		caseOf:
			{([ 1 ] -> [ t1 := #CAIRO_FONT_SLANT_NORMAL ]).
			([ 3 ] -> [ t1 := #CAIRO_FONT_SLANT_ITALIC ]).
			([ 5 ] -> [ t1 := #CAIRO_FONT_SLANT_OBLIQUE ])}.
	^ t1! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleToByDo
	<sampleInstance>
	
	| tmp1 |
	tmp1 := {true.	true.	true}.
	1 to: 9 by: 3 do: [ :index | tmp1 at: index / 3  put: false ].
	^ tmp1! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
example2Loops2

	| t |
	t := 1.
	[ t < 5 ] whileTrue: [ [ t > 10 ] whileFalse: [ t := t * 2 ]. t := t + 1 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCascadeNested
	<sampleInstance>
	
	| tmp1 tmp2 |
	tmp1 := 1.
	tmp2 := #(1 2 3) copy.
	tmp2 at: 2 put: 5.
	tmp1
		+ tmp2 size;
		- 4;
		min: 6.
	^ tmp1 yourself! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfNotNilReturnNil
	<sampleInstance>
	
	^nil ifNotNil: [ :arg | arg not ]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfTrueAssign
	<sampleInstance>
	| a |
	a := 1 <2 ifTrue: [1] ifFalse: [2].
	^a! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIV
	<sampleInstance>
	
	iVar := 5.
	^ iVar! !

!FBDExamples methodsFor: 'examples - simple' stamp: ''!
exampleReturn1
	<sampleInstance>
	
	^1! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockiVar
	<sampleInstance>
	
	^[iVar] value! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockArgument2
	<sampleInstance>
	
	^[:a :b | a + b ] value: 1 value: 1! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoArgumentNotInlined
	<sampleInstance>
	
	| block |
	block := [ :index |
		collection add: [ index ] ].
	1 to: 5 do: block.
	^collection "#(1 2 3 4 5)"! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleFullBlock
	<sampleInstance>
	
	| t |
	t := true.
	^ [ t := false ]! !

!FBDExamples methodsFor: 'examples' stamp: ''!
exampleWithArgsAndTemps: arg1 and: arg2
	<sampleInstance>
	
	| tmp1 tmp2 |
	tmp1 := 1.
	tmp2 := tmp1 + arg1.
	^ { tmp2 . arg2 }! !

!FBDExamples methodsFor: 'examples - misc' stamp: ''!
examplePushArray
	<sampleInstance>
	| t |

	{1. t := 1}.
	^t! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockInternal
	<sampleInstance>
	
	^[ | t | t := 1. t ] value! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfNotNilArg
	<sampleInstance>
	
	^1 even ifNotNil: [ :arg | arg not ]! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleWhileTrue4

	| tmp1 tmp2 |
	tmp1 := 1.
	[ tmp1 <= 5 ]
		whileTrue: [ 
			tmp1 + 2.
			tmp1 := tmp1 + 1 ].
	tmp2 := 1.
	[ tmp2 <= 5 ]
		whileTrue: [ 
			tmp1 := tmp2.
			tmp2 := tmp2 + 1 ]! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockExternalNested
	<sampleInstance>
	
	| t s |
	t := s := 1.
	^[ [s] value + t ] value! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleAndOr4
	<sampleInstance>
	
	| tmp1 tmp2 |
	tmp1 := true.
	tmp2 := false.
	^ tmp2
		ifTrue: [ true ]
		ifFalse: [ tmp1 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfNotNilDup
	<sampleInstance>
	
	^ true ifNotNil: [ 5 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleClassVar
	<sampleInstance>
	
	CVar := 1.
	^ CVar! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockArgument1
	<sampleInstance>
	
	^[:a | a ] value: 1! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleToDo3
	<sampleInstance>
	
	| t |
	t := Array new:3.
	1 to: 3 do: [ :index | t at: index put: false ].
	^ t! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockLocalIfNested
	<sampleInstance>
	
	^true ifTrue: [| hallo | [  hallo := 1 . hallo] value]! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockExternal2
	<sampleInstance>
	
	| t1 t2 |
	t1 :=  t2 := 1.
	^[t1 + t2] value! !

!FBDExamples methodsFor: 'examples - misc' stamp: ''!
exampleToDoValueLimitExpression
	<sampleInstance>

	^ 2 to: 3+4 do: [:each | each]! !

!FBDExamples methodsFor: 'examples - cascades' stamp: ''!
exampleCascadeIntoBlockIntoCascade
	<sampleInstance>
	
	| t |
	t := {true.
			true.
			false}.
	^ t
		size;
		collect: [ :aBoolean | aBoolean not; value ]! !

!FBDExamples methodsFor: 'examples - simple' stamp: ''!
exampleReturn42
	<sampleInstance>
	
	^42! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrueWithOr
	<sampleInstance>
	
	false | true
		ifTrue: [ ^ true ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfNilClosure
	<sampleInstance>
	
	^ iVar ifNil: [ 1 + ({1.2} at: 2 ifAbsent: [ ^ nil ]) ]! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockExternal
	<sampleInstance>
	
	| t |
	t := 1.
	^[t] value! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoWithMessage2

	| t t1 t2 |
	t := {true.true.true}.
	t1 := 1.
	t2 := t size.
	t1 to: t2 do: [ :index | t at: index put: false ]! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockArgument4
	<sampleInstance>
	
	^[:a :b :c :d | a + b + c  + d] value: 1 value: 1 value: 1 value: 1! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoArgument
	<sampleInstance>
	
	collection := OrderedCollection new.
	1 to: 5 do: [ :index |
		collection add:  [index]  ].
	 ^collection collect: [:each | each value]. 
	"#(1 2 3 4 5)"! !

!FBDExamples methodsFor: 'accessing' stamp: ''!
iVar

	^ iVar! !

!FBDExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteInNestedBlock

	| t1 |
	^[ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrueIfFalseNested
	<sampleInstance>
	
	^ true ifTrue: [ false ifFalse: [ ^ 4 ] ]! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleRepeatValue
	<sampleInstance>
	<compilerOptions: #(+ #optionInlineRepeat)>
	
	| i |
	i := 1.
	^ [ 
	i := i + 1.
	i = 10
		ifTrue: [ ^ true ] ] repeat! !

!FBDExamples methodsFor: 'examples' stamp: ''!
singleRemoteMethodArgument

	| temp block |
	temp := 0.
	block := [ [ temp ] ].
	temp := 1.
	block := block value.
	temp := 2! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockArgument5
	<sampleInstance>
	
	^[:a :b :c :d :e| a + b + c  + d + e] valueWithArguments: #(1 1 1 1 1)! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockEmpty
	<sampleInstance>
	
	^[] value! !

!FBDExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteInBlock

	| t1 |
	[ t1 < 5 ] whileTrue: [ t1 := 1 ]! !

!FBDExamples methodsFor: 'examples - simple' stamp: ''!
exampleReturn1plus2
	<sampleInstance>
	
	^1+2! !

!FBDExamples methodsFor: 'examples' stamp: ''!
superCallInBlock

	^ [ super yourself ] value! !

!FBDExamples methodsFor: 'examples - cascades' stamp: ''!
exampleCascadeIfNil
	<sampleInstance>
	
	^ { true } asOrderedCollection
		size;
		add: (true ifNil: [ false ]);
		yourself! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleWhileTrue

	| array t |
	array := {true.	true.true}.
	t := 1.
	[ t < 4 ]
		whileTrue: [ 
			array at: t put: false.
			t := t + 1 ]! !

!FBDExamples methodsFor: 'examples' stamp: ''!
noRemoteBlockTemp

	| block block1 block2 |
	block := [ :arg | [ arg ] ].
	block1 := block value: 1.
	block2 := block value: 2! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfFalseIfTrue4
	<sampleInstance>
	
	| a |
	a := true.
	a ifFalse: [ 1 + 2 ] ifTrue: [ ^1 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCaseOf7
	<sampleInstance>
	
	| t1 |
	5
		caseOf:
			{([ 1 ]
				-> [ 
					t1 := 2.
					t1 := t1 + 1 ]).
			([ 3 ] -> [ t1 := {#CAIRO_FONT_SLANT_ITALIC} first ]).
			([ 5 ] -> [ t1 := #CAIRO_FONT_SLANT_OBLIQUE ])}
		otherwise: [ t1 := #NIL ].
	^ t1! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfFalseIfTrue2

	| a |
	a := true.
	a ifFalse: [ a := 1 + 2 ] ifTrue: [ a := 2 + 3 ]! !

!FBDExamples methodsFor: 'examples - pragmas' stamp: ''!
examplePrimitiveErrorCode
	<sampleInstance>
	<primitive: 60 error: code >
	
	^ code! !

!FBDExamples methodsFor: 'examples' stamp: ''!
nestedBlocksRemoteInBlockCase1

	| block |
	self flag: 'Not well decompiled'.
	block := [ | a b |
		[ a := b ].
		[ b := a ] ]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfTrueIfFalse
	<sampleInstance>
	
	 1 <2 ifTrue: [^'result'] ifFalse: [2].! !

!FBDExamples methodsFor: 'examples - variables' stamp: ''!
exampleiVar
	<sampleInstance>
	
	iVar := 1.
	^iVar! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCaseOf6
	<sampleInstance>
	
	| t1 |
	5
		caseOf:
			{([ 1 ] -> [ t1 := {#CAIRO_FONT_SLANT_NORMAL} first]).
			([ 3 ] -> [ t1 := #CAIRO_FONT_SLANT_ITALIC ]).
			([ 5 ] -> [ t1 := #CAIRO_FONT_SLANT_OBLIQUE ])}
		otherwise: [ t1 := #NIL ].
	^ t1! !

!FBDExamples methodsFor: 'examples - variables' stamp: ''!
exampleSelf
	<sampleInstance>
	
	| t |
	t := self.
	^self.! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleNestedIfNilIfNotNil
	<sampleInstance>
	^ true
		ifNotNil: [ 1 ]
		ifNil: [ false 
			ifNotNil: [ 2 ] 
			ifNil: [ ^ true ] ]! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockReturn
	<sampleInstance>
	
	[^1] value! !

!FBDExamples methodsFor: 'examples' stamp: ''!
nestedBlocksRemoteInBlockCase3

	| block |
	self flag: 'Not well decompiled'.
	block := [ 
		[ |a| block := [ a := 1] ].
		[ |b| block := [ b := 2] ] ]! !

!FBDExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteReadInBlock

	| t1 |
	[ t1 < 5 ] whileTrue: [ t1 := 1. [ t1 ] ]! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleMethodTempInNestedBlock
	<sampleInstance>
	
	| temp block |
	temp := 0.
	block := [ [ temp ] ].
	temp := 1.
	block := block value.
	temp := 2.
	"self assert: block value = 2."
	^block value! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfFalse3
	<sampleInstance>
	
	1 < 2 ifFalse: [ ^ 'result' ].
	1+2.
	^ nil! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleSimpleBlockLocalIf
	<sampleInstance>
	
	^true ifTrue: [ | hallo |  hallo := 1 . hallo]! !

!FBDExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteInNestedBlockCase2

	| t1 |
	(true) ifTrue: [ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrue2
	<sampleInstance>
	
	^ 1 < 2 ifTrue: [ ^ 'result' ]! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleWhileFalse2

	| t |
	t := 1.
	[ t := t + 1. 1 + 2. t > 10 ] whileFalse! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockNested
	<sampleInstance>
	
	| a match dict | 
	a  := #(a b c d).
	dict := Dictionary new.

	a doWithIndex: [:each :index |
		(match := a indexOf: each) > 0 ifTrue:
			[dict at: index put: (a at: match)]].

	^ dict! !

!FBDExamples methodsFor: 'examples - pragmas' stamp: ''!
examplePrimitiveErrorCodeModule2
	"Primitive. Attempt to load a module of the given name.
	Fail if module cannot be found, or cannot be loaded,
	or failed to initialize"
	<sampleInstance>
	<primitive: 'primLoadModule'  module: '' error: errorCode >
	
	^ self primitiveFailed! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleRepeatEffect
	<sampleInstance>
	<compilerOptions: #(+ #optionInlineRepeat)>
	
	| i |
	i := 1.
	[ 
	i := i + 1.
	i = 10
		ifTrue: [ ^ true ] ] repeat! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockArgument3
	<sampleInstance>
	
	^[:a :b :c | a + b + c ] value: 1 value: 1 value: 1! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockNested
	<sampleInstance>
	
	^[ [1] value ] value! !

!FBDExamples methodsFor: 'examples' stamp: ''!
singleRemoteReadNestedBlocks
   
	|a| 
	[ a := 1.
       [ a ]]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleMethodWithOptimizedBlocksA
	<sampleInstance>
	
	| s c |
	s := self isNil
			ifTrue: [| a | a := 'isNil'. a]
			ifFalse: [| a | a := 'notNil'. a].
	c := String new: s size.
	1 to: s size do:
		[:i| c at: i put: (s at: i)].
	^c. "notNil"! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleTimesRepeatEffect
	<sampleInstance>
	
	| foo |
	foo := 1.
	5 timesRepeat: [ foo := foo + 3 ]. 
	^ foo! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileWithTempNotInlined
	<sampleInstance>
	
	| index block |
	index := 0.
	block := [
		| temp |
		temp := index := index + 1.
		collection add: [ temp ] ].
	[ index < 5 ] whileTrue: block.
	^collection "#(1 2 3 4 5)"! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleAndOr2
	<sampleInstance>
	
	| tmp1 tmp2 |
	tmp1 := true.
	tmp2 := false.
	tmp2
		ifTrue: [ ]
		ifFalse: [ '2' traceCr ].
	^ self! !

!FBDExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteInNestedBlockCase4

	| t1 |
	[(true) whileTrue: [ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ] ]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoOutsideTempNotInlined
	<sampleInstance>
	
	| block temp |
	block := [ :index | 
		temp := index. 
		collection add: [ temp ] ].
	1 to: 5 do: block.
	^collection "#(5 5 5 5 5)"! !

!FBDExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWrittenAfterClosedOverCase2

	| index |
	index := 0.
	[ index < 5 ] whileTrue: [
		| temp |
		temp := index := index + 1.
		 [ temp ] ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfNilIfNotNil
	<sampleInstance>
	
	true ifNil: [ ^ 5 ] ifNotNil: [ ^ 6 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCascade3
	<sampleInstance>
	
	^ true
		asBit;
		xor: false! !

!FBDExamples methodsFor: 'examples - simple' stamp: ''!
exampleSend2Args

	self instVarAt: 1 put: #banana! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfNilIfNotNil2
	<sampleInstance>
	
	^ true ifNil: [  5 ] ifNotNil: [ 6 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleAnd2

	| tmp1 |
	tmp1 := true.
	tmp1 and: [ tmp1 not ]! !

!FBDExamples methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	collection := OrderedCollection new! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfTrue

	[ 1 < 2
		ifTrue: [ ^ 'result' ]] value! !

!FBDExamples methodsFor: 'examples' stamp: ''!
nestedBlocksRemoteInBlockCase2

	| block |
	self flag: 'Not well decompiled'.
	block := [ 
		[ |a| [ a := 1] ].
		[ |b| [ b := 2] ] ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfFalseIfTrue6
	<sampleInstance>
	
	| a |
	a := true.
	^ a ifFalse: [ ] ifTrue: [ ^1 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCaseOfOtherwise
	<sampleInstance>
	
	^ 5
		caseOf:
			{([ 1 ] -> [ #CAIRO_FONT_SLANT_NORMAL ]).
			([ 3 ] -> [ #CAIRO_FONT_SLANT_ITALIC ]).
			([ 5 ] -> [ #CAIRO_FONT_SLANT_OBLIQUE ])}
		otherwise: [ #NULL ]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoInsideTemp
	<sampleInstance>
	
	1 to: 5 do: [ :index | 
		| temp | 
		temp := index. 
		collection add: [ temp ] ].
	^collection "#(1 2 3 4 5)"! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockExternalArg

	<sampleInstance>
	| t  |
	t := 1.
	^[:a | t + a] value: 1! !

!FBDExamples methodsFor: 'accessing' stamp: ''!
iVar: anObject

	iVar := anObject! !

!FBDExamples methodsFor: 'examples - misc' stamp: ''!
examplePushBigArray
	<sampleInstance>
	"This array should have a size more than 127 elements"
	self flag: 'needs a fix'.
	{ 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 .  255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 }.
	^ 1! !

!FBDExamples methodsFor: 'examples - cascades' stamp: ''!
exampleCascadeIntoBlockWithTempIfTrueIfFalse

	| t |
	t := OrderedCollection new.
	t yourself
		add: {1};
		add: {2};
		add: {3};
		collect: [ :anArray | 
					anArray
						collect: [ :aNumber | 
									aNumber isNumber
										ifFalse: [ anArray first ] ];
						collect: [ :aNumber | 
									aNumber isNumber
										ifTrue: [ 
											aNumber even
												ifTrue: [ #('even') ]
												ifFalse: [ #('odd') ] ]
										ifFalse: [ 0 ] ] ]! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockNumCopied
	<sampleInstance>
	
	| t1 |
	t1 := OrderedCollection new.
	iVar := {(1 -> 2.3 -> 4.5 -> 6)}.
	^ iVar keysAndValuesDo: [ :key :value | t1 add: (value -> key) ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleOr
	<sampleInstance>
	
	| t1 |
	t1 := false.
	^ t1 or: [ t1 not ]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleSimpleBlockLocalWhile
	<sampleInstance>
	
	|a|
	a := true.
	^[: b | [a] whileTrue: [ | hallo |  a := false. hallo := 1 . hallo]] value: 1! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleToDo5
	<sampleInstance>
	
	| tmp1 |
	tmp1 := {true.
				true.
				true}.
	[ 1 to: 3 do: [ :index | tmp1 at: index put: false ] ] valueWithin: 50 milliSeconds onTimeout: [ ].
	^ tmp1! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrue3
	<sampleInstance>
	
	1 < 2 ifTrue: [ ^ 'result' ].
	^ nil! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoArgumentLimitIsExpression
	<sampleInstance>
	
	| count sum |
	count := 10.
	sum := 0.
	1 to: count - 1 do: [ :each | sum := sum + each].
	^sum! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleAndOr3
	<sampleInstance>
	
	| t1 t2 |
	t1 := true.
	t2 := false.  
	^ t1 and: [ t2 ] "value"! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockArgument
	<sampleInstance>
	
	| block block1 block2 |
	block := [ :arg | | temp | temp := arg. [ temp ] ].
	block1 := block value: 1.
	block2 := block value: 2.
	self assert: block1 value = 1.
	self assert: block2 value = 2.
	^block1 value + block2 value! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrueIfFalseNested2
	<sampleInstance>
	
	true ifFalse: [ false ifTrue: [ ^ false ]. ^ true ]. ^ nil! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleNestedBlockScoping
	<sampleInstance>

	| b c z |
	b := [:a | 
			z := 2.
			z + a].
	c := [:a |
			z + a].
	^ (b value: 2) + (c value: 1)! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileModificationBefore
	<sampleInstance>
	
	| index |
	collection := OrderedCollection new.
	index := 0.
	[ index < 5 ] whileTrue: [ 
		index := index + 1.
		collection add: [ index ] ].
	 ^ collection collect: [:each | each value].
	"#(5 5 5 5 5)"! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleWhileTrue2
	| t |
	t := 1.
	[ 
	t := t + 1.
	1 + 2.
	t < 10 ] whileTrue! !

!FBDExamples methodsFor: 'examples' stamp: ''!
doubleRemoteAnidatedBlocks

	| val last |	
	val := 0. 
	1 to: 10 do: [ :i |
		[ :continue |
			i = 4 ifTrue: [continue value].
			val := val + 1.
			last := i
		] valueWithExit.
	].
	self assert: val = 9.
	self assert: last = 10! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrueIfFalseLikeAnd
	<sampleInstance>
	
	| t1 |
	t1 := true.
	^ t1 ifTrue: [ t1 not ] ifFalse: [ false ]! !

!FBDExamples methodsFor: 'examples - pragmas' stamp: ''!
examplePrimitiveErrorCodeModule
	"Primitive. Attempt to load a module of the given name.
	Fail if module cannot be found, or cannot be loaded,
	or failed to initialize"
	<sampleInstance>
	<primitive: 'primLoadModule'  module: '' error: #errorCode >
	
	^ self primitiveFailed! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleToDoWithMessage
	<sampleInstance>
	
	| t |
	t := {true.true.true}.
	^ 1 yourself to: t size do: [ :index | t at: index put: false ]! !

!FBDExamples methodsFor: 'examples - pragmas' stamp: ''!
exampleDoublePrimitive
	<primitive: 1>! !

!FBDExamples methodsFor: 'examples' stamp: ''!
singleRemoteTempVarWrittenAfterClosedOver

	| index block |
	index := 0.
	block := [ index ].
	index := index + 1! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleAnd
	<sampleInstance>
	
	| tmp1 tmp2 |
	tmp1 := true.
	tmp2 := false.
	tmp1 and: tmp2.
	^ tmp2 and: tmp1! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleInlineBlockCollectionLR3
	<sampleInstance>
	
	| col |
	col := OrderedCollection new.
	1 to: 11 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ].
	^ (col collect: [ :each | each value ]) asArray "= (2 to: 12) asArray"! !

!FBDExamples methodsFor: 'examples - variables' stamp: ''!
exampleSuper
	<sampleInstance>
	
	| t |
	t := super.
	^super! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleEffectValues

	#getMe.
	#( got that ? ).
	Class.! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrueForEffectNested
	<sampleInstance>
	
	| tmp1 |
	true
		ifTrue: [ 
			tmp1 := true.
			false
				ifTrue: [ 
					tmp1 := false.
					^ tmp1 ] ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCaseOf8
	<sampleInstance>
	
	9
		caseOf:
			{([ 0 ] -> [ 0 @ 0 ]).
			([ 9 ] -> [ 1 @ 1 ]).
			([ 3 ] -> [ -1 @ 1 ])}.
	^ true! !

!FBDExamples methodsFor: 'examples - cascades' stamp: ''!
exampleCascadeIfTrueIfFalse
	<sampleInstance>
	^ true 
		not;
		ifTrue: [ 'A' ];
		or: [ true ];
		yourself! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoInsideTempNotInlined
	<sampleInstance>
	
	| block |
	block := [ :index | 
		| temp | 
		temp := index. 
		collection add: [ temp ] ].
	1 to: 5 do: block.
	^collection "#(1 2 3 4 5)"! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileTrueSameJumpTarget2

	| tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 |
	"need body + triple nested loop with same start"
	tmp1 := 1.
	tmp2 := 10.
	tmp3 := 3.
	tmp4 := 5.
	tmp5 := 7.
	tmp6 := 6.
	[ 
	[ 
	[ 
	[ 
	tmp5 := tmp5 * 2.
	tmp5 < 14 ] whileTrue.
	tmp4 := tmp4 + 1.
	tmp4 < 10 ] whileTrue.
	[ 
	[ 
	tmp1 := tmp1 + 1.
	tmp1 < 10 ] whileTrue.
	tmp6 := tmp6 + 3.
	tmp6 < 20 ] whileTrue.
	tmp2 := tmp2 - 1.
	tmp2 > 0 ] whileTrue.
	tmp3 := tmp1 + 1.
	tmp1 < 10 ] whileTrue! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCascade
	<sampleInstance>
	
	^ 1 
		+ 2;
		- 4;
		min: 6;
		yourself! !

!FBDExamples methodsFor: 'examples - simple' stamp: ''!
exampleSend
	self basicSize! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleToByDoNegativeLoop
	<sampleInstance>
	
	| tmp1 |
	tmp1 := {true.	true.	true}.
	tmp1 size to: 10-9 by: -1 do: [ :index | tmp1 at: index put: false ].
	^ tmp1! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileModificationAfterNotInlined
	<sampleInstance>
	
	| index block |
	index := 0.
	block := [ 
		collection add: [ index ].
		index := index + 1 ].
	[ index < 5 ] whileTrue: block.
	^collection "#(5 5 5 5 5)"! !

!FBDExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWrittenAfterClosedOverCase1

	| index |
	index := 0.
	[ index < 5 ] whileTrue: [
		| temp |
		[ temp ].
		temp := index := index + 1].
	^index! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCascadeIfFalse
	<sampleInstance>
	
	| tmp1 |
	tmp1 := true value
		not;
		and: [ false ];
		yourself.
	tmp1
		ifFalse: [ ^ false ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCaseOf4
	<sampleInstance>
	
	| t1 |
	5
		caseOf:
			{([ 1 ] -> [ t1 := {#CAIRO_FONT_SLANT_NORMAL} first ]).
			([ 3 ] -> [ t1 := #CAIRO_FONT_SLANT_ITALIC ]).
			([ 5 ] -> [ t1 := #CAIRO_FONT_SLANT_OBLIQUE ])}
		otherwise: [ t1 := #NIL ].
	^ t1! !

!FBDExamples methodsFor: 'examples - loops' stamp: ''!
exampleWhileFalse

	| t |
	t := 1.
	[ t > 10 ] whileFalse: [ t := t + 1. 1 + 2 ]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleAndOr

	| t1 t2 |
	t1 := true.
	t2 := false.
	t1 and: [ t2. '1' traceCr ] "effect"! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCascade2
	<sampleInstance>
	
	^ true
		ifTrue: [ 1 + 2 ];
		and: [ false ]! !

!FBDExamples methodsFor: 'examples - variables' stamp: ''!
exampleThisContext
	<sampleInstance>
	
	| t |
	t := thisContext.
	^thisContext! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfFalseIfTrue3
	<sampleInstance>
	
	| a |
	a := true.
	a ifFalse: [ a := false  ] ifTrue: [ ^1 ].
	^ 2! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfNilNested
	<sampleInstance>
	
	^ true ifNil: [ (false ifNil: [ ^ true ]) not ]! !

!FBDExamples methodsFor: 'examples - cascades' stamp: ''!
exampleCascadeIntoBlockWithTempIntoCascade
	<sampleInstance>
	
	| t |
	t := {{true}.
			{true}.
			{false}}.
	^ t
		size;
		collect: [ :aBooleanArray | 
					aBooleanArray
						size;
						collect: [ :aBoolean | 
									| aSecondBoolean aThirdBoolean |
									aSecondBoolean := true.
									aThirdBoolean := false.
									aBoolean
										not;
										or: [ aSecondBoolean ];
										and: [ aThirdBoolean ];
										value ] ]! !

!FBDExamples methodsFor: 'examples - misc' stamp: ''!
exampleToDoValue
	<sampleInstance>

	^ 1 to: 2 do: [:each | each]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrueWithNilAssertion

	| tmp1 |
	tmp1 := 1.
	tmp1 > 2
		ifTrue: [ tmp1 := nil ]! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileTrueSameJumpTarget

	| tmp1 tmp2 |
	tmp1 := 1.
	tmp2 := 10.
	[ 
	[ 
	tmp1 := tmp1 + 1.
	tmp1 < 10 ] whileTrue.
	tmp2 := tmp2 - 1.
	tmp2 > 0 ] whileTrue! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrueIfFalse3
	<sampleInstance>
	
	| a |
	a := true.
	a ifTrue: [ ^ 1 ] ifFalse: [ a := false ].
	^ 2! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCaseOf
	<sampleInstance>
	
	^ 5
		caseOf:
			{([ 1 ] -> [ #CAIRO_FONT_SLANT_NORMAL ]).
			([ 3 ] -> [ #CAIRO_FONT_SLANT_ITALIC ]).
			([ 5 ] -> [ #CAIRO_FONT_SLANT_OBLIQUE ])}! !

!FBDExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockWithArg
	<sampleInstance>
	
	^ {1.2.3} collect: [:aNumber | aNumber + 1 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleCaseOf5
	<sampleInstance>
	
	| t1 |
	5
		caseOf:
			{([ 1 ] -> [ t1 := #CAIRO_FONT_SLANT_NORMAL ]).
			([ 3 ] -> [ t1 := #CAIRO_FONT_SLANT_ITALIC ]).
			([ 5 ] -> [ t1 := #CAIRO_FONT_SLANT_OBLIQUE ])}
		otherwise: [ ].
	^ t1! !

!FBDExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileModificationBeforeNotInlined
	<sampleInstance>
	
	| index block |
	index := 0.
	block := [ 
		index := index + 1.
		collection add: [ index ] ].
	[ index < 5 ] whileTrue: block.
	^collection.
	"#(5 5 5 5 5)"! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfNilDup
	<sampleInstance>
	
	^ true ifNil: [ 1+2. 5 ]! !

!FBDExamples methodsFor: 'examples - branches' stamp: ''!
exampleIfTrueIfFalseNested3
	<sampleInstance>
	
	^ {1.2.3.4}
		collect: [ :aNumber | 
			aNumber isNumber
				ifTrue: [ 
					aNumber even
						ifTrue: [ #('even') ]
						ifFalse: [ #('odd') ] ]
				ifFalse: [ 0 ] ]! !

!FBDExamples class methodsFor: 'examples' stamp: ''!
superCallInBlock

	^ [ super yourself ] value! !

!FBDLoop commentStamp: ''!
I represent a loop in the bytecode.

My instances represent an unconditional loop. These loops can't fall through the code right after as it's infinite, however, it can finish if there is a return inside.

Conditional loops are instances of my subclass.

backjump <Smi> pc of the backjump instruction!
!FBDLoop methodsFor: 'accessing' stamp: ''!
backjump
	^ backjump! !

!FBDLoop methodsFor: 'testing' stamp: ''!
isConditionalLoop
	^ false! !

!FBDLoop methodsFor: 'accessing' stamp: ''!
backjump: anObject
	backjump := anObject! !

!FBDLoopScanner commentStamp: ''!
I scan compiled method to detect loops. I answer an array or the size of the compiled method I scanned, which holds a FBDLoop at the pc where a loop starts and nil for any other pc. The FBDLoop describes the loop.

instructionStream <InstructionStream> allows me to decode the method's bytecode
branchTargets <Array of (Smi | nil)> at any pc where a conditional jump goes, I put an annotation in this array. This is used to know if a loop is conditional or unconditional.
loops <Array of (FBDLoop | nil)> array answered by the scanner. it holds a FBDLoop at the pc where a loop starts and nil for any other pc.
currentPC <Smi> by opposition to self pc which holds the pc just *after* the instruction being decoded, currentPC holds the pc of the instruction being decoded. This is useful as you can't read the bytecode backward due to multiple bytecodes instructions.
!
!FBDLoopScanner methodsFor: 'instruction decoding' stamp: ''!
jump: offset if: bool
	branchTargets at: self pc + offset put: currentPC! !

!FBDLoopScanner methodsFor: 'instruction decoding' stamp: ''!
interpretMethod: method
	[ instructionStream pc > method endPC ]
		whileFalse: [ 
			currentPC := self pc.
			instructionStream interpretNextInstructionFor: self ]! !

!FBDLoopScanner methodsFor: 'accessing' stamp: ''!
pc
	^ instructionStream pc! !

!FBDLoopScanner methodsFor: 'instruction decoding' stamp: ''!
jump: offset
	| loop backjumpTarget |
	offset < 0 ifFalse: [ ^ self ].
	loop := (branchTargets at: self pc)
		ifNotNil: [ :exitPC | FBDConditionalLoop new exitCondition: exitPC; yourself ]
		ifNil: [ FBDLoop new ].
	backjumpTarget := self pc + offset.
	loop backjump: currentPC.
	(loops at: backjumpTarget) 
		ifNil: [ loops at: backjumpTarget put: (OrderedCollection with: loop) ]
		ifNotNil: [ :col | col add: loop ].! !

!FBDLoopScanner methodsFor: 'public api' stamp: ''!
scan: method
	loops := Array new: method endPC.
	branchTargets := Array new: method endPC.
	instructionStream := InstructionStream on: method.
	self interpretMethod: method.
	^ loops! !

!FBDLoopScanner class methodsFor: 'public api' stamp: ''!
scan: method
	^ self new scan: method! !

!FBDOptimizedMessagesRewriter commentStamp: ''!
I am a tool that allows you to reoptimize messages into a decompiled method.

I receive an AST and I replace non-optimized message nodes that have been reconstructed by the AST builder into optimized message nodes, then I return the AST.

Public API : use rewriteAST: to transform it with optimized messages.

example: FBDOptimizedMessagesRewriter rewriteAST: (Object >> #asString ) ast.

I only rewrite nodes with "reconstructed" property to ensure that I reoptimize only the messages that were optimized in the non-decompiled method.!
!FBDOptimizedMessagesRewriter methodsFor: 'converting' stamp: ''!
convertToIfNotNil: msgNode
	msgNode selector: #ifNotNil:.
	msgNode arguments: {msgNode arguments last}! !

!FBDOptimizedMessagesRewriter methodsFor: 'visiting' stamp: ''!
visitBlockNode: block
	super visitBlockNode: block.
	block body statements ifEmpty: [  ^ self ].
	block body statements last isLiteralNode ifFalse: [ ^self ].
	block body statements last value ifNotNil: [ ^self ].
	block body statements removeLast! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isIfNil: msgNode
	^ msgNode arguments second = msgNode receiver! !

!FBDOptimizedMessagesRewriter methodsFor: 'visiting' stamp: ''!
visitSequenceNode: seq
	self analyseSeq: seq .
	super visitSequenceNode: seq.
	(self isLastStatementReturnSelf: seq) ifTrue: [ seq statements removeLast ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'rewriting' stamp: ''!
rewriteSeq: seq with: currentCascade
	currentCascade size > 1
		ifTrue: [ self rewriteStatements: currentCascade in: seq ].
		currentCascade removeAll! !

!FBDOptimizedMessagesRewriter methodsFor: 'rewriting' stamp: ''!
rewriteStatements: statements in: seq
"You have to remove the first statement from the collection before removing all nodes in the sequence.
RemoveNode first uses == to detect the node , then =
So if you don't remove the first statement of the collection (which has been replaced by the cascade and no longer exists), then this will remove all nodes = to first node (and not ==).
So if you have the same node twice in the sequence, and this node is the first message of a cascade, then all occurrences of this node would be removed"
	seq replaceNode: statements first withNode: (RBCascadeNode messages: statements copy).
	(statements
		removeFirst;
		yourself) do: [ :each | seq removeNode: each ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'converting' stamp: ''!
convertToAnd: msgNode
	msgNode selector: #and:.
	msgNode arguments: {msgNode arguments first}! !

!FBDOptimizedMessagesRewriter methodsFor: 'converting' stamp: ''!
convertToIfNil: msgNode
	msgNode selector: #ifNil:.
	msgNode arguments: {msgNode arguments first}! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isAnd: msgNode
	| stmts |
	stmts := msgNode arguments second body statements.
	^ stmts size = 1 and: [ stmts first value = false ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'converting' stamp: ''!
convertToIfFalse: msgNode
	msgNode selector: #ifFalse:.
	msgNode arguments: {msgNode arguments second}! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isBigArray: msgNode
	^ (msgNode selector = #braceStream:) and: [ msgNode receiver isVariable and: [ msgNode receiver name = #Array ] ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isIfTrue: msgNode
	^ msgNode arguments second body statements isEmpty! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isOr: msgNode
	| stmts |
	stmts := msgNode arguments first body statements.
	^ stmts size = 1 and: [ stmts first value = true ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'handling' stamp: ''!
handleIfFalse: msgNode
	(self isIfNilIfNotNil: msgNode)
		ifTrue: [ 
			msgNode receiver: msgNode receiver receiver.
			msgNode selector: #ifNotNil: ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'handling' stamp: ''!
handleIfTrue: msgNode
	(self isIfNilIfNotNil: msgNode)
		ifTrue: [ 
			msgNode receiver: msgNode receiver receiver.
			msgNode selector: #ifNil: ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'handling' stamp: ''!
handleIfTrueIfFalse: msgNode
	(self areArgumentsBlocks: msgNode) ifFalse: [ ^ self ].
	(self isIfFalse: msgNode) ifTrue: [ ^ self convertToIfFalse: msgNode ].
	(self isIfTrue: msgNode) ifTrue: [ ^ self convertToIfTrue: msgNode ].
 	(self isAnd: msgNode) ifTrue: [ ^self convertToAnd: msgNode ].
	(self isOr: msgNode) ifTrue: [ ^ self convertToOr: msgNode ].
	(self isIfNilIfNotNil: msgNode) ifTrue: [ ^ self convertToIfNilIfNotNil: msgNode ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isReconstructed: msg
	^ msg hasProperty: #reconstructed! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isIfNotNil: msgNode
	| stmts |
	stmts := msgNode arguments first body statements.
	^ stmts size = 1 and: [ stmts first = msgNode receiver ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'handling' stamp: ''!
handleBigArray: msgNode
	| seq cascade |
	seq := msgNode parent parent.
	cascade := seq statements at: (seq statements indexOf: msgNode parent) +1 .
	seq removeNode: msgNode parent.
	seq replaceNode: cascade withNode: (RBArrayNode statements: (cascade  messages removeLast; collect: [ :msg | msg arguments first ]))! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isReceiver1StatementBlock: msgNode
	msgNode receiver isBlock
		ifFalse: [ ^ false ].
	^ msgNode receiver body statements size = 1! !

!FBDOptimizedMessagesRewriter methodsFor: 'public api' stamp: ''!
rewriteAST: aMethodNode
	self visitNode: aMethodNode.
	^ aMethodNode! !

!FBDOptimizedMessagesRewriter methodsFor: 'converting' stamp: ''!
convertToOr: msgNode
	msgNode selector: #or:.
	msgNode arguments: {msgNode arguments second}! !

!FBDOptimizedMessagesRewriter methodsFor: 'private' stamp: ''!
extractStartValue: msgNode startTemp: startTemp
	| assignement indexOfMsg |
	indexOfMsg := msgNode parent statements indexOf: msgNode.
	indexOfMsg = 1
		ifTrue: [ ^ nil ].
	assignement := msgNode parent statements at: indexOfMsg - 1.
	(assignement isAssignment and: [ assignement variable = startTemp])
		ifFalse: [ ^ nil ].
	^ assignement value! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
hasCorrectIncrInstruction: msgNode startTemp: startTemp isPositiveLoop: isPositiveLoop
	| incrInstruction |
	incrInstruction := msgNode arguments first body statements last.
	incrInstruction isAssignment
		ifFalse: [ ^ false ].
	incrInstruction variable = startTemp
		ifFalse: [ ^ false ].
	incrInstruction value isMessage
		ifFalse: [ ^ false ].
	incrInstruction value selector = #+
		ifFalse: [ ^ false ].
	incrInstruction value receiver = startTemp
		ifFalse: [ ^ false ].
	incrInstruction value arguments first value isLiteral
		ifFalse: [ ^ false ].
	^ incrInstruction value arguments first value positive = isPositiveLoop! !

!FBDOptimizedMessagesRewriter methodsFor: 'private' stamp: ''!
removeTempFromSequence: seq temp: temp
	| temps |
	seq ifNil: [ ^self "2 to:do: in the same method, temp has already  been removed" ].
	seq isSequence ifFalse: [ ^ self removeTempFromSequence: seq parent temp: temp ].
	temps := seq temporaries reject: [ :tmp | tmp = temp ].
	temps size = seq temporaries size
		ifTrue: [ self removeTempFromSequence: seq parent temp: temp ]
		ifFalse: [ seq temporaries: temps ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isReceiverCorrectCondition: msgNode
	| condition |
	(self isReceiver1StatementBlock: msgNode ) ifFalse: [ ^ false ].
	condition := msgNode receiver body statements first.
	^ condition isMessage and: [ condition isBinary ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isLastStatementReturnSelf: seq
	^ seq parent isMethod and: [ seq statements last isReturn and: [ seq statements last value isSelfVariable ] ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'converting' stamp: ''!
convertToIfTrue: msgNode
	msgNode selector: #ifTrue:.
	msgNode arguments: {msgNode arguments first}! !

!FBDOptimizedMessagesRewriter methodsFor: 'converting' stamp: ''!
convertWhileTrueToToByDo: msgNode start: start end: end by: incrValue incrVariable: incrVar assignement: assignement
	| selector arguments loopBlock |
	loopBlock := msgNode arguments last.
	loopBlock arguments: {incrVar}.
	loopBlock statements removeLast.
	incrValue value = 1
		ifTrue: [ 
			selector := #to:do: .
			arguments := {end . loopBlock} ]
		ifFalse: [ 
			selector := #to:by:do: .
			arguments := {end . incrValue . loopBlock} ].
	msgNode
		receiver: start;
		selector: selector;
		arguments: arguments.
	self removeTempFromSequence: msgNode parent temp: incrVar.
	msgNode parent removeNode: assignement! !

!FBDOptimizedMessagesRewriter methodsFor: 'handling' stamp: ''!
handleIfNilIfNotNil: msgNode
	(self isIfNil: msgNode)
		ifTrue: [ ^ self convertToIfNil: msgNode ].
	(self isIfNotNil: msgNode)
		ifTrue: [ ^ self convertToIfNotNil: msgNode ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isPositiveLoopOrNil: rcvr
	rcvr selector = #<=
		ifTrue: [ ^ true ].
	rcvr selector = #>=
		ifTrue: [ ^ false ].
	^ nil! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isIfFalse: msgNode
	^ msgNode arguments first body statements isEmpty! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
isIfNilIfNotNil: msgNode
	msgNode receiver isMessage
		ifFalse: [ ^ false ].
	msgNode receiver selector = #==
		ifFalse: [ ^ false ].
	^ msgNode receiver arguments first value isNil! !

!FBDOptimizedMessagesRewriter methodsFor: 'converting' stamp: ''!
convertToIfNilIfNotNil: msgNode
	msgNode receiver: msgNode receiver receiver.
	msgNode selector: #ifNil:ifNotNil:! !

!FBDOptimizedMessagesRewriter methodsFor: 'visiting' stamp: ''!
visitMessageNode: msgNode
	"Do not add return statements. 
	ifTrue:ifFalse: handling may change the current message node into an ifTrue: , an ifFalse: or an ifNil:ifNotNil: message. 
	whileTrue are used to detect to:do: and to: by: do."

	super visitMessageNode: msgNode.
	(self isReconstructed: msgNode)
		ifFalse: [ ^ self ].
	msgNode selector = #ifTrue:ifFalse:
		ifTrue: [ self handleIfTrueIfFalse: msgNode ].
	msgNode selector = #ifNil:ifNotNil:
		ifTrue: [ self handleIfNilIfNotNil: msgNode ].
	msgNode selector = #ifTrue:
		ifTrue: [ self handleIfTrue: msgNode ].
	msgNode selector = #ifFalse:
		ifTrue: [ self handleIfFalse: msgNode ].
	msgNode selector = #whileTrue:
		ifTrue: [ self handleWhileTrue: msgNode ].
	(self isBigArray: msgNode)
		ifTrue: [ self handleBigArray: msgNode ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'testing' stamp: ''!
areArgumentsBlocks: msgNode
	^ msgNode arguments allSatisfy: [ :arg | arg isBlock ]! !

!FBDOptimizedMessagesRewriter methodsFor: 'handling' stamp: ''!
handleWhileTrue: msgNode
	| startTemp start end incrValue rcvr |
	(self isReceiverCorrectCondition: msgNode)
		ifFalse: [ ^ self ].
	rcvr := msgNode receiver body statements first.
	startTemp := rcvr receiver.
	start := (self extractStartValue: msgNode startTemp: startTemp) ifNil: [ ^ self ].
	end := rcvr arguments first.
	(self
		hasCorrectIncrInstruction: msgNode
		startTemp: startTemp
		isPositiveLoop: ((self isPositiveLoopOrNil: rcvr) ifNil: [ ^ self ]))
		ifFalse: [ ^ self ].
	incrValue := msgNode arguments first body statements last value arguments first.
	^ self
		convertWhileTrueToToByDo: msgNode
		start: start
		end: end
		by: incrValue
		incrVariable: startTemp
		assignement: (msgNode parent statements at: (msgNode parent statements indexOf: msgNode) - 1)! !

!FBDOptimizedMessagesRewriter methodsFor: 'private' stamp: ''!
analyseSeq: seq
	"Checks if consecutive messages have the same receiver. If not, creates a cascade"

	| currentCascade |
	currentCascade := OrderedCollection new.
	seq statements
		do: [ :each | 
			(each isMessage and: [ each selector ~= #ifTrue:ifFalse: ])
				ifFalse: [ self rewriteSeq: seq with: currentCascade ]
				ifTrue: [ 
					currentCascade
						ifNotEmpty: [ 
							currentCascade last receiver = each receiver
								ifFalse: [ self rewriteSeq: seq with: currentCascade ] ].
					currentCascade add: each ] ].
	self rewriteSeq: seq with: currentCascade! !

!FBDOptimizedMessagesRewriter class methodsFor: 'public api' stamp: ''!
rewriteAST: ast
	self new rewriteAST: ast! !

!FFIAbstract64BitsArgumentReader commentStamp: ''!
I implement the common behavior of the processing of arguments for 64 bits platforms.
The 64 bits platforms uses the registers to pass parameters.
The integer parameters are passed in the general purpose parameters (the address of the copy of them is in #integerRegisterPointer) and the float parameters are passed in the set of registers XMM0-XMM8. This float point registers are accessible through the #floatRegisterPointer.

As the different calling conventions uses the registers in different ways and also they use different number of registers I only have limited reused code.!
!FFIAbstract64BitsArgumentReader methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	currentRegisterIndex := 1.	! !

!FFIAbstract64BitsArgumentReader methodsFor: 'accessing' stamp: ''!
integerRegisterPointer
	
	^ callbackContext intregargsp! !

!FFIAbstract64BitsArgumentReader methodsFor: 'accessing' stamp: ''!
numberOfRegisters

	^ self subclassResponsibility! !

!FFIAbstract64BitsArgumentReader methodsFor: 'accessing' stamp: ''!
floatRegisterPointer
	
	^ callbackContext floatregargsp! !

!FFIAbstractTest methodsFor: 'private' stamp: ''!
ffiBindingOf: aString
	
	aString = '_test_type_int'
		ifTrue: [ ^ aString -> intType ].
	aString = '_test_type_bool'
		ifTrue: [ ^ aString -> int32Type ].
	aString = '_test_type_uint32'
		ifTrue: [ ^ aString -> int32Type ].
	aString = '_test_type_int32'
		ifTrue: [ ^ aString -> int32Type ].
	aString = '_test_type_void'
		ifTrue: [ ^ aString -> voidType ].
	aString = '_test_type_char'
		ifTrue: [ ^ aString -> charType ].
	self error: 'Type not recognized: ', aString! !

!FFIAbstractTest methodsFor: 'private' stamp: ''!
externalTypeAlias: aTypeName

	"Prefix the type so we have control over it.
	If it is already prefixed, do not prefix it (otherwise this loops)."
	(aTypeName beginsWith: '_test_type_')
		ifTrue: [ ^ aTypeName ].
	^ '_test_type_', aTypeName! !

!FFIAbstractTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	intType := FFIInt32.
	int32Type := FFIInt32.
	uint32Type := FFIUInt32.
	voidType := FFIVoid.
	charType := FFICharacterType.! !

!FFIAbstractTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == FFIAbstractTest! !

!FFIArchitecture commentStamp: ''!
I'm a base class for different kind of architectures. 
My children implement different architecture-dependent functionality.!
!FFIArchitecture methodsFor: '*ThreadedFFI-UFFI-Overrides' stamp: ''!
tfBitType

	^ TFBasicType sint8! !

!FFIArchitecture methodsFor: 'types' stamp: ''!
bitTypeSize

	^ self externalBitType byteSize! !

!FFIArchitecture methodsFor: 'types' stamp: ''!
externalSizeTType
	^ ExternalType ulong! !

!FFIArchitecture methodsFor: 'types' stamp: ''!
externalULongType
	^ ExternalType ulong! !

!FFIArchitecture methodsFor: 'types' stamp: ''!
bitTypeAlignment

	^ 1! !

!FFIArchitecture methodsFor: 'types' stamp: ''!
longTypeSize
	^ self externalLongType byteSize! !

!FFIArchitecture methodsFor: 'types' stamp: ''!
externalBitType

	^ ExternalType signedByte! !

!FFIArchitecture methodsFor: 'types' stamp: ''!
sizeTTypeSize
	^ self externalSizeTType byteSize! !

!FFIArchitecture methodsFor: '*ThreadedFFI-UFFI-Overrides' stamp: ''!
tfexternalSizeTType
	^ TFBasicType uint32! !

!FFIArchitecture methodsFor: 'types' stamp: ''!
externalLongType
	^ ExternalType long! !

!FFIArchitecture methodsFor: 'types' stamp: ''!
externalUBitType

	^ ExternalType unsignedByte! !

!FFIArchitecture methodsFor: '*ThreadedFFI-UFFI-Overrides' stamp: ''!
tfUBitType

	^ TFBasicType uint8! !

!FFIArchitecture methodsFor: 'default abi' stamp: ''!
returnSingleFloatsAsDoubles
	self subclassResponsibility! !

!FFIArchitecture class methodsFor: 'testing' stamp: ''!
isActive
	^ false! !

!FFIArchitecture class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #forCurrentArchitecture'! !

!FFIArchitecture class methodsFor: 'instance creation' stamp: ''!
forCurrentArchitecture
	^ (self allSubclasses detect: #isActive) uniqueInstance! !

!FFIArchitecture class methodsFor: 'private' stamp: ''!
uniqueInstance
	self isAbstract  
		ifTrue: [ self error: 'I''m an abstract class, use one of my children instead.' ].
	^ uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! !

!FFIArchitecture class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self name = #FFIArchitecture! !

!FFIArchitectureTest commentStamp: ''!
Unit tests for FFI architectures!
!FFIArchitectureTest methodsFor: 'tests' stamp: ''!
testConcreteArchitectures

	self deny: FFI_i386 isAbstract.
	self deny: FFI_x86_64_SystemV isAbstract.
	self deny: FFI_x86_64_Windows isAbstract.! !

!FFIArchitectureTest methodsFor: 'tests' stamp: ''!
testAbstractArchitectures

	self assert: FFIArchitecture isAbstract.
	self assert: FFI_x86_64 isAbstract.! !

!FFIArchitectureTest methodsFor: 'tests' stamp: ''!
testArchitectureProvided

	self assert: FFIArchitecture forCurrentArchitecture isNotNil ! !

!FFIArray commentStamp: ''!
I represent a C array with fixed size.

## Creating instances

To create an instance of myself, use the ==newType:size:== or the  ==externalNewType:size:== instance creation methods. The former will allocate an array in the Pharo heap, while the latter one will allocate the array in the C heap.

"In the pharo heap"
array := FFIArray newType: #char size: 10.
"In the C heap"
array := FFIArray externalNewType: #char size: 10.

Arrays allocated in the C heap are not moved and their memory is not released automatically.
It is the developer's responsibility to free it.
On the other hand, Arrays allocated in the Pharo heap can be moved by the garbage collector, so they should be pinned in memory before being safely used in FFI calls.
Also, arrays in the Pharo heap are managed by Pharo's garbage collector, and will be collected if no other Pharo objects reference it. Be careful, an Array in the Pharo heap referenced from the C heap will still be garbage collected making the pointer in the C heap a dangling pointer.

## Accessing my instances

You can access my elements using the #at: and #at:put: methods, and ask my size using the #size method, using 1-based indexes like in Pharo.

array at: 1 "for the first element".
array at: n "for the nth element".

If the array is allocated in the Pharo heap, array accesses will be bound checked and throw an exception in case of out-of-bounds access.
Otherwise, if the array is allocated in the C heap, array accesses may run into buffer over/underflows.

## Reusable Array types

I can be used to create array types with the ==newArrayType:size:== method, which yields a new array type knowing the element types and the array size. An array type created this way can be then be allocated using the new or externalNew messages.

char128Type := FFIArray newArrayType: #char size: 128.

"In Pharo heap"
newArrayOf128Chars := char128Type new.

"In C heap"
newArrayOf128Chars := char128Type externalNew.

My main purpose is to be used in structures, for example:

struct {
	int field[4];
}

can be modeled like this: 

TheStruct class>>initialize
	Int4 := FFIArray newArrayType: #int size: 4.

TheStruct class>>fieldsDesc 
	^ #(
	Int4 field;
	)

Of course this is not the best way to do it (parser needs to be adapted to do this automatically), but is a good and fast way to provide the functionality. !
!FFIArray class methodsFor: 'instance creation' stamp: ''!
new 
	^ self basicNew 
		initializeType: self type size: self numberOfElements;
		yourself! !

!FFIArray class methodsFor: 'instance creation' stamp: ''!
externalNew 
	"Create a new array in the C heap. 
	 This array needs to be disposed (using #free method)... or you can declare it #autoRelease"
	^ self basicNew 
		initializeExternalType: self type size: self numberOfElements;
		yourself! !

!FFIArray class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator 
	^ FFITypeArrayType objectClass: self! !

!FFIArray class methodsFor: 'class factory' stamp: ''!
ofType: aTypeName size: elements
	^ FFIArray newAnonymousSubclass 
		type: (FFIExternalType resolveType: aTypeName)	
		size: elements! !

!FFIArray class methodsFor: 'private' stamp: ''!
type: aType 	size: elements
	type := aType.
	numberOfElements := elements
		! !

!FFIArray class methodsFor: 'private' stamp: ''!
numberOfElements
	^ numberOfElements! !

!FFIArray class methodsFor: 'class factory' stamp: ''!
newArrayTypeOf: aTypeName size: elements
	^ FFIArray newAnonymousSubclass 
		type: (FFIExternalType resolveType: aTypeName)	
		size: elements! !

!FFIArray class methodsFor: 'private' stamp: ''!
type 
	^ type! !

!FFIArray class methodsFor: 'instance creation' stamp: ''!
fromHandle: aHandle
	^ self basicNew 
		initializeHandle: aHandle type: self type size: self numberOfElements;
		yourself! !

!FFIBackend commentStamp: ''!
I am an strategy to implement different backends for FFI.!
!FFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float32At: offset put: value

	^ self subclassResponsibility! !

!FFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float32At: offset

	^ self subclassResponsibility! !

!FFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float64At: offset put: value

	^ self subclassResponsibility! !

!FFIBackend methodsFor: 'instance creation' stamp: ''!
allocate: byteSize
	"Primitive. Allocate an object on the external heap."
	^self subclassResponsibility! !

!FFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float64At: offset

	^ self subclassResponsibility! !

!FFIBackend methodsFor: '*UnifiedFFI' stamp: ''!
calloutAPIClass
	
	^ FFICalloutAPI ! !

!FFIBackend methodsFor: 'instance creation' stamp: ''!
free: anExternalAddress

	^ self subclassResponsibility! !

!FFIBackend methodsFor: 'accessing' stamp: ''!
integerOfObject: anObject at: byteOffset put: value size: nBytes signed: aBoolean

	^ self subclassResponsibility! !

!FFIBackend methodsFor: 'accessing' stamp: ''!
integerOfObject: anObject at: byteOffset size: nBytes signed: aBoolean

	^ self subclassResponsibility! !

!FFIBackend methodsFor: 'instance creation' stamp: ''!
loadSymbol: moduleSymbol module: module 

	^ self subclassResponsibility! !

!FFIBackend class methodsFor: 'accessing' stamp: ''!
initialize

	SessionManager default
		registerSystemClassNamed: self name
		atPriority: 60! !

!FFIBackend class methodsFor: 'accessing' stamp: ''!
current

	^ Current ifNil: [ Current := self detectFFIBackend]! !

!FFIBackend class methodsFor: 'accessing' stamp: ''!
detectFFIBackend

	^ ((self subclasses sorted: [ :a :b | a priority > b priority ])
		detect: [ :e | e isAvailable ]
		ifNone: [ ^ NullFFIBackend ]) new! !

!FFIBackend class methodsFor: 'testing' stamp: ''!
isAvailable

	^ self subclassResponsibility! !

!FFIBackend class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting
	
	isImageStarting ifFalse: [ ^ self ].
	
	Current := nil! !

!FFIBackend class methodsFor: 'class initialization' stamp: ''!
reset

	Current := nil.! !

!FFIBit commentStamp: ''!
I'm a signed bit type. 
See my superclass for an explanation on why this exits.!
!FFIBit methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ FFIArchitecture forCurrentArchitecture tfBitType! !

!FFIBit methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle platformBitAt: index! !

!FFIBit methodsFor: 'private - emitting code' stamp: ''!
offsetPointerReadFieldAt: offsetVariableName
	^ '^ExternalData 
		fromHandle: (handle {1}: {2})
		type: FFIArchitecture forCurrentArchitecture externalBitType asPointerType'
	format: { 
		self emitSelector.
		offsetVariableName }! !

!FFIBit methodsFor: 'private - emitting code' stamp: ''!
emitSelector
	^ 'platformBitAt'! !

!FFIBit methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value 
	^ aHandle platformBitAt: index put: value! !

!FFIBit class methodsFor: 'accessing' stamp: ''!
externalType 
	^ FFIArchitecture forCurrentArchitecture externalLongType! !

!FFIBool commentStamp: ''!
Bool type.
Represented as single byte on C side.!
!FFIBool methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFDerivedType boolean! !

!FFIBool methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle booleanAt: index! !

!FFIBool methodsFor: 'accessing' stamp: ''!
defaultReturnOnError

	^ false! !

!FFIBool methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle booleanAt: index put: value! !

!FFIBool methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ #integer! !

!FFIBool class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ 1! !

!FFIBool class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 1! !

!FFIBool class methodsFor: 'accessing' stamp: ''!
externalType
	^ ExternalType bool! !

!FFIBoolean32 commentStamp: ''!
!! FFIBoolean32

Booleans in C are a convenience construction, and because of that each library chooses the definition of boolean they want. The most general convention is the one provided by *class:FFIBool*, and is equivalent to ushort (8bit), but time to time we need another.
 
The second most frequent boolean definition is the one provided by this class: uint32 (32bit).!
!FFIBoolean32 methodsFor: 'accessing' stamp: ''!
tfExternalType
	
	^ TFDerivedType boolean32! !

!FFIBoolean32 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index

	^ (aHandle signedLongAt: index) ~~ 0! !

!FFIBoolean32 methodsFor: 'accessing' stamp: ''!
defaultReturnOnError

	^ false! !

!FFIBoolean32 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value

	^ aHandle signedLongAt: index put: value asBit! !

!FFIBoolean32 methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ #integer! !

!FFIBoolean32 class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ 1! !

!FFIBoolean32 class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 1! !

!FFIBoolean32 class methodsFor: 'accessing' stamp: ''!
externalType
	^ ExternalType bool! !

!FFICallback commentStamp: ''!
I define a callback for an external function call.
I allow blocks to be evaluated when an external block funtion needs it. 

	cb := FFICallback
			signature:  #(int (const void *a, const void *b))
			block: [ :arg1 :arg2 | ((arg1 doubleAt: 1) - (arg2 doubleAt: 1)) sign].

argument types are calculated and converted using same parsing logic than FFICallout!
!FFICallback methodsFor: 'private' stamp: ''!
returnOnError

	^ functionSpec returnType defaultReturnOnError
! !

!FFICallback methodsFor: 'accessing' stamp: ''!
calloutAPIClass: anObject
	calloutAPIClass := anObject! !

!FFICallback methodsFor: 'private' stamp: ''!
ffiBindingOf: aName
	^ self class ffiBindingOf: aName! !

!FFICallback methodsFor: 'accessing' stamp: ''!
getHandle
	^ self thunk! !

!FFICallback methodsFor: 'initialization' stamp: ''!
signature: signature block: aBlock
	| parser |
	parser := self newParser.
	functionSpec := parser parseAnonymousFunction: signature.
	functionSpec resolveUsing: parser requestor.
	block := aBlock.
! !

!FFICallback methodsFor: '*ThreadedFFI' stamp: ''!
beFailed

	^ self backendCallback beFailed! !

!FFICallback methodsFor: 'private' stamp: ''!
ffiInstVarArgument: argName generator: generator
	"Load the instance variable with given name. 
	 It will be ignored anyway in a callback" 
	^ FFIInstVarArgument new 
		argName: argName;
		yourself! !

!FFICallback methodsFor: '*ThreadedFFI' stamp: ''!
beSuccess

	^ self backendCallback beSuccess! !

!FFICallback methodsFor: 'accessing' stamp: ''!
functionSpec
	^ functionSpec! !

!FFICallback methodsFor: 'accessing' stamp: ''!
beNull

	self backendCallback beNull! !

!FFICallback methodsFor: 'accessing' stamp: ''!
backendCallback
	"declare the backend callback"
	^ backendCallback ifNil: [ backendCallback := self calloutAPIClass newCallbackBackendFor: self ].
! !

!FFICallback methodsFor: 'private' stamp: ''!
newParser 
	^ FFIFunctionParser new
		requestor: (FFICallout new
			requestor: self;
			yourself);
		yourself! !

!FFICallback methodsFor: 'accessing' stamp: ''!
ffiLibraryName

	^ (library ifNil: [ 'default' ]) asFFILibrary! !

!FFICallback methodsFor: 'accessing' stamp: ''!
thunk

	(block isNil or: [functionSpec isNil])
		ifTrue: [ ^ ExternalAddress null ].

	^ self backendCallback thunk! !

!FFICallback methodsFor: 'private' stamp: ''!
shouldDebugExceptions

	^ true! !

!FFICallback methodsFor: '*ThreadedFFI' stamp: ''!
isSuccess

	^ self backendCallback isSuccess! !

!FFICallback methodsFor: 'accessing' stamp: ''!
ffiLibrary: aFFILibrary

	library := aFFILibrary! !

!FFICallback methodsFor: 'accessing' stamp: ''!
calloutAPIClass

	^ calloutAPIClass ifNil: [ super calloutAPIClass ]! !

!FFICallback methodsFor: 'evaluating' stamp: ''!
valueWithArguments: args

	^ [ block valueWithArguments: args ]
		on: Error
		fork: [ :e | 
			self shouldDebugExceptions ifTrue: [ e debug ] ]
		return: [ self returnOnError ].! !

!FFICallback methodsFor: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	^ self getHandle tfPointerAddress! !

!FFICallback methodsFor: '*ThreadedFFI' stamp: ''!
tfPrintString

	^ block printString! !

!FFICallback methodsFor: 'invoking' stamp: ''!
invokeAsFunctionWithArguments: aCollection 

	^ self backendCallback invokeAsFunctionWithArguments: aCollection! !

!FFICallback class methodsFor: 'instance creation' stamp: ''!
signature: aSignature block: aBlock
	^ self new signature: aSignature block: aBlock! !

!FFICallback class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator 
	^ FFICallbackType objectClass: self! !

!FFICallback class methodsFor: 'examples' stamp: ''!
exampleCqsort
	<sampleInstance>
	| cb rand values orig sort |

	rand := Random new.
	
	values := FFIExternalArray externalNewType: 'double' size: 100.
	1 to: 100 do: [ :i| values at: i put: rand next ].
	orig := (1 to: 100) collect: [:i| values at: i] as: Array.
	cb := FFICallback
		signature:  #(int (const void *arg1, const void *arg2))
		block: [ :arg1 :arg2 | ((arg1 doubleAt: 1) - (arg2 doubleAt: 1)) sign ].
	[
		self primQsort: values with: 100 with: values type typeSize with: cb.
		sort := values asArray ]
	ensure: [ values free ].
	
	^orig -> sort! !

!FFICallback class methodsFor: 'private - primitives' stamp: ''!
primQsort: array with: count with: size with: compare
	self
		ffiCall: #(void qsort (FFIExternalArray array, size_t count, size_t size, FFICallback compare)) 
		module: LibC! !

!FFICallback class methodsFor: 'instance creation' stamp: ''!
forAddress: address 
	"Reconstructs a callback from an address (an integer). 
	 This is useful for reading callbacks from a structure. 
	 WARNING: 
		Of course, the callback needs to exist before :)
		And the callback needs to be created with FFICallback (not plain Alien callbacks), then 
		we can be sure block in fact contains the FFICallback instance"
	^ FFIBackend current lookupCallbackByAddress: address! !

!FFICallbackArgumentReader commentStamp: ''!
I am an abstract class that is responsible for extracting the arguments of a callback.
The callbacks provides the arguments in different forms depending of the architecture.
Each of my subclasses implements special behavior for the given architectures.
I have the common behavior for all the architectures.

Basically, I am a stateful object that is used during the process of extraction.
I am created with a callback and a callback context.
A new instance of myself is created in each callback invocation, and it should not be reused.

From the callback I extract the type of return of the callback and the type of the parameters.

I am used in the method FFICallback >> #argumentsFor: stackPointer context: callbackContext.
Each of the architectures is able to create the correct subclass of me.

My users just use the #extractArguments method and then access teh arguments through #arguments.

In the extractArguments, I take the arguments from the FFICallback and send my message extractNext: with the type of the arguments.

The #extractNext: method checks if the type represents a pointer or a value type. 
If it is a pointer the message #extractPointerOfType: is used. If it is a value,
there is a double dispatch with the type. The message #extractFromCallbackOn: is sent to the type.

Then the type use one of the following methods to indicate its type: 

#extractCharacterType
#extractDouble
#extractFloat
#extractIntegerType 
#extractExternalString: 
#extractStructType:

Each of this methods calculates the base address and the correct offset to extract the value or the pointer. For this calculation the messages #nextBaseAddressFor: aType and #nextBaseAddressForStructure: aStructType are used.

My base implementation extracts all the parameters from the stack. So the base address is always the stack pointer and the offset is updated according to the type.

Once the base address is opteined, the type objects is used with the message #handle:at: to get the value from the stack.

These methods all modify the collection of extracted elements.

Note: 

When a callback should return a struct by copy, the caller function allocates the returning struct. 
The pointer to this struct is stored in a new first parameter to the callback. This hidden parameter is extracted in the #initialize if it is required.
The callback can access to the pointer through the returnValueHolder instance variable.!
!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
extractExternalString: type 
	
	| pair baseAddressToRead offsetOfBaseAddress |
	pair := self nextBaseAddressFor: type.
	baseAddressToRead := pair first.
	offsetOfBaseAddress := pair second.

	self addArgument: (type handle: baseAddressToRead at: offsetOfBaseAddress).! !

!FFICallbackArgumentReader methodsFor: 'accessing' stamp: ''!
callback
	^ callback! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
basicExtractUnsignedInteger
	
	| baseAddressToRead offsetOfBaseAddress type pair |
	
	type := self stackUnsignedIntegerType.
	pair := self nextBaseAddressFor: type.
	baseAddressToRead := pair first.
	offsetOfBaseAddress := pair second.
	
	^ type handle: baseAddressToRead at: offsetOfBaseAddress.! !

!FFICallbackArgumentReader methodsFor: 'types' stamp: ''!
stackIntegerType
	
	"Depending of the architecture there are different types used in the stack for the integers."
	
	^ self subclassResponsibility! !

!FFICallbackArgumentReader methodsFor: 'initialization' stamp: ''!
initialize
	
	| returnType |

	super initialize.

	currentStackOffset := 1.
	extractedArguments := Array new: callback functionSpec arguments size.
	nextArgumentIndex := 1.
	
	"If the function returns an struct by copy there is a hidden parameter with a pointer storing it".
	returnType := callback functionSpec returnType resolvedType.
	(returnType isExternalStructure and: [ returnType isPointer not ]) ifTrue: [ 
		returnValueHolder := self stackPointer pointerAt: 1.
		currentStackOffset := currentStackOffset + Smalltalk wordSize.
	]! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
basicExtractInteger
	
	| baseAddressToRead offsetOfBaseAddress type pair |
	
	type := self stackIntegerType.
	pair := self nextBaseAddressFor: type.
	baseAddressToRead := pair first.
	offsetOfBaseAddress := pair second.
	
	^ type handle: baseAddressToRead at: offsetOfBaseAddress.! !

!FFICallbackArgumentReader methodsFor: 'accessing' stamp: ''!
arguments
	
	^ extractedArguments! !

!FFICallbackArgumentReader methodsFor: 'accessing' stamp: ''!
addArgument: anArgument

	extractedArguments at: nextArgumentIndex put: anArgument.
	nextArgumentIndex := nextArgumentIndex + 1 ! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
extractPointerOfType: aType

	| pair baseAddressToRead offsetOfBaseAddress |
	pair := self nextBaseAddressFor: aType.
	baseAddressToRead := pair first.
	offsetOfBaseAddress := pair second.

	self addArgument: (aType handle: baseAddressToRead at: offsetOfBaseAddress).
! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
extractDouble

	| type pair baseAddressToRead offsetOfBaseAddress |
	type := FFIFloat64 new.
	pair := self nextBaseAddressFor: type.
	baseAddressToRead := pair first.
	offsetOfBaseAddress := pair second.

	self addArgument: (type handle: baseAddressToRead at: offsetOfBaseAddress).
! !

!FFICallbackArgumentReader methodsFor: 'calculating-offsets' stamp: ''!
nextBaseAddressForStructure: type

	"I calculate the base address to read an struct argument.
	The handling of structs is different in the subclases, but in myself the handle of 
	structs is performed in the stack, so the calculation of addresses is perform in the same
	way as non-struct arguments."


	^ self nextBaseAddressFor: type! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
extractNext: aFFIType

	aFFIType isPointer
		ifTrue: [ self extractPointerOfType: aFFIType ]
		ifFalse: [ aFFIType extractFromCallbackOn: self ]! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
extractFloat

	| type pair baseAddressToRead offsetOfBaseAddress |
	type := FFIFloat32 new.
	pair := self nextBaseAddressFor: type.
	baseAddressToRead := pair first.
	offsetOfBaseAddress := pair second.

	self addArgument: (type handle: baseAddressToRead at: offsetOfBaseAddress).! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
extractIntegerType

	self addArgument: self basicExtractInteger! !

!FFICallbackArgumentReader methodsFor: 'accessing' stamp: ''!
callback: anObject
	callback := anObject! !

!FFICallbackArgumentReader methodsFor: 'accessing' stamp: ''!
callbackContext
	^ callbackContext! !

!FFICallbackArgumentReader methodsFor: 'types' stamp: ''!
stackUnsignedIntegerType
	
	"Depending of the architecture there are different types used in the stack for the unsigned integers."

	^ self subclassResponsibility! !

!FFICallbackArgumentReader methodsFor: 'accessing' stamp: ''!
callbackContext: anObject
	callbackContext := anObject.
! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
extractArguments

	callback functionSpec arguments do: [ :type | self extractNext: type resolvedType ].
! !

!FFICallbackArgumentReader methodsFor: 'accessing' stamp: ''!
stackPointer
	^ callbackContext stackp! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
basicExtractPointer
	
	^ ExternalAddress fromAddress: (self basicExtractUnsignedInteger)! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
extractCharacterType

	self addArgument: self basicExtractUnsignedInteger asCharacter! !

!FFICallbackArgumentReader methodsFor: 'calculating-offsets' stamp: ''!
nextBaseAddressFor: type

	"I calculate the base address to read an argument from a callback context.
	In my implementation all the arguments are read from the stack.
	The space of each type depends of its own size."

	| baseAddressToRead offsetOfBaseAddress typeSize |

	typeSize := type isPointer ifTrue: [ Smalltalk wordSize ] ifFalse: [ type externalTypeSize ].

	baseAddressToRead := self stackPointer.
	offsetOfBaseAddress := currentStackOffset.
	currentStackOffset := currentStackOffset + typeSize.

	^ {baseAddressToRead. offsetOfBaseAddress}! !

!FFICallbackArgumentReader methodsFor: 'extracting' stamp: ''!
extractStructType: type 
	
	| pair baseAddressToRead offsetOfBaseAddress |
	
	pair := self nextBaseAddressForStructure: type.
	baseAddressToRead := pair first.
	offsetOfBaseAddress := pair second.

	self addArgument: (type handle: baseAddressToRead at: offsetOfBaseAddress).! !

!FFICallbackArgumentReader class methodsFor: 'instance creation' stamp: ''!
forCallback: aCallback inContext: aCallbackContext

	^ self basicNew
		callbackContext: aCallbackContext;
		callback: aCallback;
		initialize;
		yourself.! !

!FFICallbackFunctionResolution commentStamp: ''!
I install callbacks as functions (to be used with ffiCall: later)

I can register any callback with a name, the callback thunk will be used as an entry point for this function.

I implement the option:  optCallbackCall 
	
Example: 
========
callAbsoluteMethod
	 |  callback |

	callback := FFICallback 
		signature: #(double (double x)) 
		block: [ :x | x abs ].
	FFICallbackFunctionResolution register:  callback as:  #absolute.
	self absolute: 42.0.

absolute: aNumber
	self ffiCall: #(double absolute (double aNumber)) options: #(+optCallbackCall)	
!
!FFICallbackFunctionResolution methodsFor: 'testing' stamp: ''!
isApplicableFor: aRequestor
	^ aRequestor optionAt: #optCallbackCall! !

!FFICallbackFunctionResolution methodsFor: 'resolving' stamp: ''!
resolveFunction: anExternalFunction
	| callback |
	callback := self class 
		callbackNamed: anExternalFunction name
		ifAbsent: [ self error: 'Callback #', anExternalFunction name, ' not registered!!' ].
	^ callback thunk asExternalAddress ! !

!FFICallbackFunctionResolution class methodsFor: 'registration' stamp: ''!
registerCallback: aCallback as: functionName
	self callbackRegistry 
		at: functionName asSymbol 
		put: aCallback.
! !

!FFICallbackFunctionResolution class methodsFor: 'private' stamp: ''!
callbackNamed: functionName ifAbsent: aBlock 
	^ self callbackRegistry 
		at: functionName asSymbol
		ifAbsent: aBlock! !

!FFICallbackFunctionResolution class methodsFor: 'private' stamp: ''!
callbackRegistry 
	^ CallbackRegistry ifNil: [ CallbackRegistry := Dictionary new ]! !

!FFICallbackFunctionResolution class methodsFor: 'cleanup' stamp: ''!
cleanUp
	self reset! !

!FFICallbackFunctionResolution class methodsFor: 'class initialization' stamp: ''!
reset
	CallbackRegistry := nil! !

!FFICallbackFunctionResolution class methodsFor: 'registration' stamp: ''!
unregister: functionName
	self callbackRegistry removeKey: functionName asSymbol 
		! !

!FFICallbackParametersTest commentStamp: ''!
This TestSuite evaluates the correct implementation of the callback parameter extraction.!
!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testIntegerPointerParameters 
	
	| params |
	params := {
		ExternalAddress fromAddress: 1.
		ExternalAddress fromAddress: 2.
		ExternalAddress fromAddress: 3.
		ExternalAddress fromAddress: 4.
		ExternalAddress fromAddress: 5.
		ExternalAddress fromAddress: 6.}.	
	
	callback := FFICallback 
		signature: #(void (void* a, void* b, int* c, int* d, int* e, float* f))
		block: [ :a :b :c :d :e :f  | 
			self assert: a value equals: 1.
			self assert: b value equals: 2.
			self assert: c value equals: 3.
			self assert: d value equals: 4.
			self assert: e value equals: 5.
			self assert: f value equals: 6.
		].

	self callCallback: callback withArgs: params! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testCharacterParameters
	
	| params |
	params := (1 to: 6) collect: [ :i | i asCharacter ].	
	
	callback := FFICallback 
		signature: #(int (char, char, char, char, char, char))
		block: [ :a :b :c :d :e :f  |
			self assert: a value equals: 1 asCharacter.
			self assert: b value equals: 2 asCharacter.
			self assert: c value equals: 3 asCharacter.
			self assert: d value equals: 4 asCharacter.
			self assert: e value equals: 5 asCharacter.
			self assert: f value equals: 6 asCharacter.
			$z asInteger
		].

	self assert: (self callCallback: callback withArgs: params) equals: $z asInteger! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testPassing2DoubleStructureInTheStack 
			
	| param |
	callback := FFICallback 
		signature: #(int (FFITestStructure2DoubleStructure a))
		block: [ :a |
			self assert: a x equals: 2.0. 
			self assert: a y equals: 3.0. 

			99
		].

	param := FFITestStructure2DoubleStructure externalNew
		x: 2.0;
		y: 3.0;
		autoRelease;
		yourself.

	self assert: (self callCallback: callback withArgs: { param }) equals: 99! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testPassingStructureInTheStack 
	
	| param |
	callback := FFICallback 
		signature: #(int (FFITestStructureSmallIntFloatStructure a))
		block: [ :a |
			self assert: a x equals: 2.0. 
			self assert: a y equals: 3. 
			self assert: a w equals: 5.0. 
			self assert: a z equals: 7.0. 

			a x: 3.0.
			a y: 4.
			a w: 5.0.
			a z: 7.0. 

			77 
		].

	param := FFITestStructureSmallIntFloatStructure externalNew
		x: 2.0;
		y: 3;
		w: 5.0;
		z: 7.0;
		autoRelease;
		yourself.
		
	self assert: (self callCallback: callback withArgs: { param }) equals: 77! !

!FFICallbackParametersTest methodsFor: 'executing' stamp: ''!
callCallback: aFFICallback withArgs: aCollection 

	self assert: aCollection isArray.
	^ aFFICallback invokeAsFunctionWithArguments: aCollection.! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testFloatParameters 
	
	callback := FFICallback 
		signature: #(double (double a, double b, float c, float d, double e, float f))
		block: [ :a :b :c :d :e :f  | 
			self assert: a value equals: 1.0.
			self assert: b value equals: 2.0.
			self assert: c value equals: 3.0.
			self assert: d value equals: 4.0.
			self assert: e value equals: 5.0.
			self assert: f value equals: 6.0.
			7.0
		].

	self assert: (self callCallback: callback withArgs: {1.0. 2.0. 3.0. 4.0. 5.0. 6.0}) equals: 7.0! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testIntegerParameters 
	
	callback := FFICallback 
		signature: #(int (int, int, int, int, int, int))
		block: [ :a :b :c :d :e :f  | 
			self assert: a equals: 1.
			self assert: b equals: 2.
			self assert: c equals: 3.
			self assert: d equals: 4.
			self assert: e equals: 5.
			self assert: f equals: 6.
			7
		].

	self assert: (self callCallback: callback withArgs: #(1 2 3 4 5 6)) equals: 7

! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testPassing2Int64StructureInTheStack 
			
	| param |
	callback := FFICallback 
		signature: #(int (FFITestStructure2Int64Structure a))
		block: [ :a |
			self assert: a x equals: 2. 
			self assert: a y equals: 3. 

			99
		].

	param := FFITestStructure2Int64Structure externalNew
		x: 2;
		y: 3;
		autoRelease;
		yourself.

	self assert: (self callCallback: callback withArgs: { param }) equals: 99! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testIdentityStruct 
	
	| param result |
	
	"This is ugly, but the tests are not running with Alien callbacks"
	true ifTrue: [ ^ self skip. ].
	
	callback := FFICallback 
		signature: #(FFITestStructureSmallIntFloatStructure (FFITestStructureSmallIntFloatStructure a))
		block: [ :a |
			self assert: a x equals: 2.0. 
			self assert: a y equals: 3. 
			self assert: a w equals: 5.0. 
			self assert: a z equals: 7.0. 

			a x: 3.0.
			a y: 4.
			a w: 6.0.
			a z: 8.0. 
						
			a
		].

	param := FFITestStructureSmallIntFloatStructure new
		x: 2.0;
		y: 3;
		w: 5.0;
		z: 7;
		yourself.

	result := self callCallback: callback withArgs: { param }.

	"They are passed and returned by copy, so they should not be the same"	
	self deny: param equals: result.
	
	self assert: result x equals: 3.0. 
	self assert: result y equals: 4. 
	self assert: result w equals: 6.0. 
	self assert: result z equals: 8.0. 
! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testPassing4DoubleStructureInTheStack 
			
	| param |
	callback := FFICallback 
		signature: #(int (FFITestStructureDoubleStructure a))
		block: [ :a |
			self assert: a x equals: 2.0. 
			self assert: a y equals: 3.0. 
			self assert: a w equals: 5.0. 
			self assert: a z equals: 7.0. 

			a x: 3.0.
			a y: 4.0.
			a w: 5.0.
			a z: 7.0. 

			99
		].

	param := FFITestStructureDoubleStructure externalNew
		x: 2.0;
		y: 3.0;
		w: 5.0;
		z: 7.0;
		autoRelease;
		yourself.

	self assert: (self callCallback: callback withArgs: { param }) equals: 99! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testPassing4Int64StructureInTheStack 
			
	| param |
	callback := FFICallback 
		signature: #(int (FFITestStructure4Int64Structure a))
		block: [ :a |
			self assert: a x equals: 2. 
			self assert: a y equals: 3. 
			self assert: a w equals: 5. 
			self assert: a z equals: 7. 

			99
		].

	param := FFITestStructure4Int64Structure externalNew
		x: 2;
		y: 3;
		w: 5;
		z: 7;
		autoRelease;
		yourself.

	self assert: (self callCallback: callback withArgs: { param }) equals: 99! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testMixingParameters 
	
	callback := FFICallback 
		signature: #(void (int a, float b, char c, int d, double e, int f, char g))
		block: [ :a :b :c :d :e :f :g | 
			self assert: a value equals: 1.
			self assert: b value equals: 2.0.
			self assert: c value equals: $c.
			self assert: d value equals: 4.
			self assert: e value equals: 5.0.
			self assert: f value equals: 6.
			self assert: g value equals: $g.
		].

	self callCallback: callback withArgs: {1. 2.0. $c. 4. 5.0. 6. $g}! !

!FFICallbackParametersTest methodsFor: 'running' stamp: ''!
testPassing4IntStructureInTheStack 
			
	| param |
	callback := FFICallback 
		signature: #(int (FFITestStructureIntStructure a))
		block: [ :a |
			self assert: a x equals: 2. 
			self assert: a y equals: 3. 
			self assert: a w equals: 5. 
			self assert: a z equals: 7. 

			99
		].

	param := FFITestStructureIntStructure externalNew
		x: 2;
		y: 3;
		w: 5;
		z: 7;
		autoRelease;
		yourself.

	self assert: (self callCallback: callback withArgs: { param }) equals: 99! !

!FFICallbackTest commentStamp: ''!
Tests for callbacks!
!FFICallbackTest methodsFor: 'accessing' stamp: ''!
intregargsp
	^ nil! !

!FFICallbackTest methodsFor: 'running' stamp: ''!
runCaseManaged
	^ self runCase! !

!FFICallbackTest methodsFor: 'accessing' stamp: ''!
floatregargsp
	^ nil! !

!FFICallbackTest methodsFor: 'tests' stamp: ''!
testCqsort
	| unsorted expected values callback results |
		
	unsorted := (10.0 to: 1.0 by: -0.5) asArray.
	expected := (1.0 to: 10.0 by: 0.5) asArray.
	
	values := FFIExternalArray externalNewType: 'double' size: unsorted size.
	unsorted withIndexDo: [ :each :index | values at: index put: each ].
	callback := FFICallback
		signature:  #(int (const void *arg1, const void *arg2))
		block: [ :arg1 :arg2 | ((arg1 doubleAt: 1) - (arg2 doubleAt: 1)) sign ].
	[
		FFICallback 
			primQsort: values 
			with: unsorted size 
			with: values type typeSize 
			with: callback.
		results := values asArray ]
	ensure: [ values free ].
	
	self assert: results equals: expected! !

!FFICallbackTest methodsFor: 'support' stamp: ''!
wordResult: anInteger
	"For testEnumerationReturnValue, simulate a method invoked 
	from FFICallback>>valueInContext, so that I can be passed as a fake context."
	^anInteger! !

!FFICallbackTest methodsFor: 'tests' stamp: ''!
testCqsortWithByteArray
	| unsorted expected values callback results |
	
	unsorted := (10.0 to: 1.0 by: -0.5) asArray.
	expected := (1.0 to: 10.0 by: 0.5) asArray.
	
	values := FFIExternalArray newType: 'double' size: unsorted size.
	values getHandle pinInMemory.
	unsorted withIndexDo: [ :each :index | values at: index put: each ].
	callback := FFICallback
		signature:  #(int (const void *arg1, const void *arg2))
		block: [ :arg1 :arg2 | ((arg1 doubleAt: 1) - (arg2 doubleAt: 1)) sign ].
	[
		FFICallback 
			primQsort: values 
			with: unsorted size 
			with: values type typeSize 
			with: callback.
		results := values asArray ]
	ensure: [ values free ].
	
	self assert: results equals: expected! !

!FFICallbackType commentStamp: ''!
I'm a FFICallback type. 
I can handle callback type parameters.

What I actually do is to pass the content of #thunk instVar of the objectClass as parameter. 
Thunk needs to be a callback thunk (and then an ExternalAddress).
The C side of a callback is void* (because is a pointer to a function)!
!FFICallbackType methodsFor: 'emitting code' stamp: ''!
basicEmitArgument: aBuilder context: aContext inCallout: aCallout

 	self loader emitArgument: aBuilder context: aContext.

	aBuilder send: self instanceVariableName
! !

!FFICallbackType methodsFor: 'emitting code' stamp: ''!
emitReturn: aBuilder resultTempVar: resultVar context: aContext

	^ aBuilder 
		addTemp: #tmpResult;
		"keep invoke result into the tmpResult var"
		storeTemp: resultVar;
		popTop;
		"return := self objectClass basicNew"
		pushLiteralVariable: self objectClass binding;
		send: #basicNew;
		storeTemp: #tmpResult;
		popTop;
		"return instVarAt: (index of argName) put: result"
		pushTemp: #tmpResult;
		pushTemp: resultVar;
		send: self instanceVariableName asMutator;
		popTop;
		pushTemp: #tmpResult;
		returnTop	! !

!FFICallbackType methodsFor: 'emitting code' stamp: ''!
offsetReadFieldAt: offsetVariableName
	^ String streamContents: [ :stream | 
		stream << '^' << self objectClass name << ' forAddress: ((handle pointerAt: ' << offsetVariableName asString << ') asInteger)' ]! !

!FFICallbackType methodsFor: 'emitting code' stamp: ''!
writeFieldAt: byteOffset with: valueName
	^ String streamContents: [ :stream | 
		stream << 'handle pointerAt: ' << byteOffset asString << ' put: (ExternalAddress fromAddress: anObject thunk address)' ]! !

!FFICallbackType methodsFor: 'emitting code' stamp: ''!
readFieldAt: byteOffset
	^ String streamContents: [ :stream | 
		stream << '^' << self objectClass name << ' forAddress: ((handle pointerAt: ' << byteOffset asString << ') asInteger)' ]! !

!FFICallbackType methodsFor: 'emitting code' stamp: ''!
offsetWriteFieldAt: offsetVariableName with: valueName
	| cr tab |
	cr := String cr.
	tab := String tab.
	^ String streamContents: [ :stream | 
		stream 
			<< 'handle ' << cr 
			<< tab << tab << 'pointerAt: ' << offsetVariableName << cr 
			<< tab << tab << 'put: (anObject ' << cr 
			<< tab << tab << tab << 'ifNotNil: [ anObject thunk asExternalAddress ]' << cr
			<< tab << tab << tab << 'ifNil: [ ExternalAddress null ])' ]! !

!FFICallbackType methodsFor: 'accessing' stamp: ''!
instanceVariableName

	^ #thunk! !

!FFICallout commentStamp: ''!
I'm implement a callout mechanism to be used with nb calls formatting.

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 #asExternalTypeOn:

Options: 
Options may change the execution/compilation of ffi calls. 
Not many are predefined, here a small explanation of them: 

optIndirectCall 		This will perform an "indirect function call" as explained here: https://en.wikipedia.org/wiki/Function_pointer
!
!FFICallout methodsFor: 'accessing' stamp: ''!
requestor: aRequestor
	requestor := aRequestor! !

!FFICallout methodsFor: 'spec parsing' stamp: ''!
resolveUntypedArgument: anArgument

	^ self resolutionMode resolveUndeclaredTypeForArgument: anArgument withResolver: self! !

!FFICallout methodsFor: 'accessing' stamp: ''!
newSpecParser
	^ FFIFunctionParser new requestor: self
! !

!FFICallout methodsFor: 'private' stamp: ''!
aliasForType: aTypeName
	| alias |

	alias := aTypeName.
	(requestor notNil and: [ requestor respondsTo: #externalTypeAlias: ]) 
		ifTrue: [ 
			alias := requestor externalTypeAlias: aTypeName.
			alias ifNil: [ alias := aTypeName ] ].
	" internal aliases "
	^ TypeAliases at: alias ifAbsent: [ alias ]! !

!FFICallout methodsFor: 'configuration' stamp: ''!
beNonStrict

	self beStrict: false! !

!FFICallout methodsFor: 'accessing' stamp: ''!
optionAt: optionName
	^ self options 
		at: optionName 
		ifAbsent: false! !

!FFICallout methodsFor: 'accessing' stamp: ''!
resolutionMode
	
	^ (self optionAt: #optStrict)
		ifTrue: [ FFIStrictResolutionMode new ]
		ifFalse: [ FFIInferenceResolutionMode new ]! !

!FFICallout methodsFor: 'accessing' stamp: ''!
fnSpec
	^ fnSpec! !

!FFICallout methodsFor: 'accessing' stamp: ''!
receiver
	^ receiver! !

!FFICallout methodsFor: 'accessing' stamp: ''!
parseOptions: optionsArray
	"parse an array, which is a sequence of options in a form of: 
	
	#( + option1 option2 option3: param3  - option5 -option6: ... )
	
	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.
	
	If in inclusion mode, non-unary options will put the following element as its unary symbols counterparts value, rather than true.
	"

	| include option rs |
	include := true.
	rs := optionsArray readStream.
	[(option := rs next) isNil]
		whileFalse: [ 
			option
				caseOf:
					{(#+ -> [ include := true ]).
					(#- -> [ include := false ])}
				otherwise: [ 
					(option beginsWith: 'opt') not
						ifTrue: [ ^ self error: 'Invalid option name ' , option , ', must begin with ''opt''' ].
					option numArgs > 1
						ifTrue: [ ^ self error: 'Does not support setting options with more than one parameter' ].
					options at: (option allButLast: option numArgs) asSymbol put: (include and: [ option isUnary or: [ rs next ] ]) ] ]! !

!FFICallout methodsFor: 'accessing' stamp: ''!
resolveExternalType: anObject 
	^ (self resolveType: anObject) externalType ! !

!FFICallout methodsFor: 'accessing' stamp: ''!
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 asString trimRight.
		newName := self aliasForType: name.
		newName last = $* ifTrue: [ 
			ptrArity := ptrArity + 1.
			newName := newName allButLast ].
		name = newName 
	] whileFalse.

	resolver := requestor 
		ifNotNil: [ 
			requestor isClass
				ifTrue: [ requestor instanceSide ]
				ifFalse: [ requestor ] ]
		ifNil: [ self class ].
		
	binding := resolver ffiBindingOf: name asSymbol.
	binding ifNotNil: [ 
		^ (binding value asExternalTypeOn: self) pointerArity: ptrArity ].

	^ self error: 'Unable to resolve external type: ' , aTypeName asString! !

!FFICallout methodsFor: 'private' stamp: ''!
typeName: aName pointerArity: ptrArity
	^ (self resolveType: aName) pointerArity: ptrArity! !

!FFICallout methodsFor: 'accessing' stamp: ''!
methodArgs
	^ methodArgs! !

!FFICallout methodsFor: 'private' stamp: ''!
receiverArgumentLoader
	^ FFISelfArgument new! !

!FFICallout methodsFor: 'configuration' stamp: ''!
resolveStringEncodingStrategy

	| encodingOptions |
	encodingOptions := (self options associations
		select: [ :e | (e key beginsWith: 'optStringEncoding') and: [ e value ] ]
		thenCollect: [ :e | e key allButFirst: 'optStringEncoding' size ]) asSet.
	
	"Do not take into account optStringEncodingMandatory as an encoding"
	encodingOptions remove: 'Mandatory' ifAbsent: [  ].
	
	encodingOptions size > 1 ifTrue: [ self error: 'Conflicting string encoding options' ].
	
	(self isMandatoryStringEncoding and: [ encodingOptions isEmpty ])
		ifTrue: [ self error: 'String encoding option not specified' ].
	
	^ encodingOptions isEmpty
		ifTrue: [ FFILegacyStringEncodingStrategy new ]
		ifFalse: [ FFIStringEncodingStrategy forEncoding: encodingOptions anyOne ]! !

!FFICallout methodsFor: 'testing' stamp: ''!
isStrict

	^ self resolutionMode isStrict! !

!FFICallout methodsFor: 'configuration' stamp: ''!
beStrict: aBoolean
	
	self options at: #optStrict put: aBoolean! !

!FFICallout methodsFor: 'errors' stamp: ''!
unsupportedUntypedLiteral: aLiteral
	
	FFIUnsupportedUntypedLiteral signalFor: aLiteral! !

!FFICallout methodsFor: 'configuration' stamp: ''!
isMandatoryStringEncoding

	^ self optionAt: #optStringEncodingMandatory! !

!FFICallout methodsFor: 'accessing' stamp: ''!
options: anObject
	self parseOptions: anObject! !

!FFICallout methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!FFICallout methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	options := Dictionary new.! !

!FFICallout methodsFor: 'accessing' stamp: ''!
methodArgs: anArray
	methodArgs := anArray! !

!FFICallout methodsFor: 'accessing' stamp: ''!
requestor
	^ requestor! !

!FFICallout methodsFor: 'argument loaders' stamp: ''!
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 ffiInstVarArgument: argName generator: self.
			loader ifNil: [ | binding |
				binding := requestor ffiBindingOf: argName.
				binding ifNil: [ FFIVariableNameNotFound signalFor: argName].
				loader := FFIClassVariableArgument new 
					argName: argName;
					yourself ] ] ].
	^ loader! !

!FFICallout methodsFor: 'configuration' stamp: ''!
beStrict
	
	self beStrict: true! !

!FFICallout methodsFor: 'configuration' stamp: ''!
stringEncodingStrategy

	^ stringEncodingStrategy ifNil: [ 
		stringEncodingStrategy := self resolveStringEncodingStrategy ]! !

!FFICallout methodsFor: 'accessing' stamp: ''!
sender: aSenderContext
	| nArgs |
	self requestor: aSenderContext compiledCode method methodClass.
	nArgs := aSenderContext compiledCode method numArgs.
	methodArgs := aSenderContext compiledCode method argumentNames.
	self receiver: aSenderContext receiver.
	self assert: (methodArgs size = nArgs).
! !

!FFICallout methodsFor: 'argument loaders' stamp: ''!
loaderFromMethodArgsNamed: argName
	| index |
	methodArgs ifNil: [ ^ nil ].
	index := methodArgs indexOf: argName ifAbsent: [ nil ].
	^ index ifNotNil: [ 
		"ok, this is a method argument"
		^ FFIMethodArgument new 
			argName: argName;
			index: index;
			yourself ].
! !

!FFICallout methodsFor: 'accessing' stamp: ''!
receiver: anObject
	receiver := anObject! !

!FFICallout methodsFor: 'accessing' stamp: ''!
method: aMethod
	method := aMethod! !

!FFICallout methodsFor: 'accessing' stamp: ''!
namedFnSpec: namedFn
	fnSpec := self newSpecParser parseNamedFunction: namedFn.
	! !

!FFICallout methodsFor: 'configuration' stamp: ''!
stringEncodingStrategy: aStringEncodingStrategy

	stringEncodingStrategy := aStringEncodingStrategy! !

!FFICallout methodsFor: 'argument loaders' stamp: ''!
loaderForArgNamed: argName indirectIndex: anIndex
	| loader |
	loader := self loaderForArgNamed: argName.
	anIndex ifNotNil: [ loader := self indirectLoader: loader byIndex: anIndex ].
	^ loader! !

!FFICallout methodsFor: 'accessing' stamp: ''!
options
	^ options! !

!FFICallout methodsFor: 'argument loaders' stamp: ''!
indirectLoader: aLoader byIndex: anIndex
	"I do not have a case where it is used, so I don't know how to implement it. 
	 I will wait until an use case emerge..."
	^ self notYetImplemented! !

!FFICallout class methodsFor: 'class initialization' stamp: ''!
initialize
	self initializeTypeAliases! !

!FFICallout class methodsFor: 'accessing' stamp: ''!
typeAliases
	^ TypeAliases! !

!FFICallout class methodsFor: 'class initialization' stamp: ''!
initializeTypeAliases
	"self initializeTypeAliases"
	TypeAliases := Dictionary newFromPairs:
	#(
		"not really a type, useful only as return type or with pointers "
		void 				FFIVoid
		"0/!!0  <-> false/true "
		bool 				FFIBool
		"fixed size integer types, byte order is platform dependent "
		int8 				FFIInt8
		uint8 				FFIUInt8
		int16 				FFIInt16
		uint16 			FFIUInt16
		int32 				FFIInt32
		uint32 			FFIUInt32
		int64 				FFIInt64
		uint64 			FFIUInt64
		" aliases to common C compiler types.. some of them are platform dependent, 
		  some is not.. to be sorted out later "		
		signedByte 		int8
		unsignedByte 	uint8
		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 				FFILong
		ulong 				FFIULong
		longlong 			int64
		ulonglong 		uint64
		uint 				uint32
		int 				int32
		"unsigned for sizes.. usually same size as platform's word size"
		size_t 			FFISizeT
		"character type. uint8 <-> accepts Character/Smallint as argument, converts 
		 return to Character "
		Character 		FFICharacterType
		char 				FFICharacterType
		"Floats fixed-size. platform-dependent byte order"
		float16 			FFIFloat16
		float32 			FFIFloat32
		float64 			FFIFloat64
		float128 			FFIFloat128
		"Floats, C type name aliases"
		float 				float32
		double 			float64
		shortFloat 		float16
		"Special types"
		oop 				FFIOop
		ByteArray       FFIOop
		ExternalAddress FFIOop)
	! !

!FFICalloutAPI commentStamp: ''!
I'm a façade to perform ffi nb calls.!
!FFICalloutAPI methodsFor: 'accessing' stamp: ''!
context
	^ senderContext! !

!FFICalloutAPI methodsFor: 'initialization' stamp: ''!
initialize

	callingConvention := #cdecl.
	options := #().
	fixedArgumentCount := 0.

	super initialize! !

!FFICalloutAPI methodsFor: 'initialization' stamp: ''!
initializeContext: aContext
	senderContext := aContext.
	self initialize! !

!FFICalloutAPI methodsFor: 'accessing' stamp: ''!
fixedArgumentCount: anObject

	fixedArgumentCount := anObject! !

!FFICalloutAPI methodsFor: 'private' stamp: ''!
callingConvention
	^ callingConvention! !

!FFICalloutAPI methodsFor: 'accessing' stamp: ''!
fixedArgumentCount

	^ fixedArgumentCount! !

!FFICalloutAPI methodsFor: 'accessing' stamp: ''!
convention: aCallingConvention
	"It can be #cdecl or #stdcall"
	callingConvention := aCallingConvention! !

!FFICalloutAPI methodsFor: 'call conventions' stamp: ''!
stdcall
	callingConvention := #stdcall! !

!FFICalloutAPI methodsFor: 'accessing' stamp: ''!
uFFIEnterMethodSelector
	
	"Return the selector of the uffiEnterContext.
	That is, the selector that was called by client code to invoke uffi.
	If we got here from a context not controlled by uffi, return nil, as we have found no method"
	
	^ self findUffiEnterContext ifNotNil: [ :ctx | ctx compiledCode method selector ]! !

!FFICalloutAPI methodsFor: 'initialization' stamp: ''!
initializeUFFIContext: aUFFIEntryPointContext
	uFFIEntryPointContext := aUFFIEntryPointContext.
	self initialize! !

!FFICalloutAPI methodsFor: 'configuration' stamp: ''!
findUffiEnterContext
	"Finds the initial context where entering the uffi framework.
	That is, the context that was marked with the #ffiCalloutTranslator pragma, whose caller was not.
	The found context determines how uffi was called. Its sender context is the client context.
	If no context is found, return nil"
	
	| pragmaName uffiEnterContext |
	pragmaName := #ffiCalloutTranslator.
	
	uffiEnterContext := (uFFIEntryPointContext ifNil: [ thisContext ]) findContextSuchThat: [ :ctx |
		(ctx compiledCode method hasPragmaNamed: pragmaName)
			and: [ (ctx sender compiledCode method hasPragmaNamed: pragmaName) not] ].
	^ uffiEnterContext! !

!FFICalloutAPI methodsFor: 'action' stamp: ''!
newBuilder
	^ FFICalloutMethodBuilder calloutAPI: self! !

!FFICalloutAPI methodsFor: 'accessing' stamp: ''!
senderContext
	
	senderContext ifNotNil: [ ^ senderContext ].
	^ self findUffiEnterContext sender! !

!FFICalloutAPI methodsFor: 'call conventions' stamp: ''!
cdecl
	callingConvention := #cdecl! !

!FFICalloutAPI methodsFor: 'action' stamp: ''!
newCallbackWithSignature: signature block: aBlock library: aLibrary

	^ (FFICallback signature: signature block: aBlock)
		calloutAPIClass: self class;
		ffiLibrary: aLibrary;
		yourself! !

!FFICalloutAPI methodsFor: 'backward compatibility' stamp: ''!
function: aCollection module: aClass 
	
	^ self function: aCollection library: aClass! !

!FFICalloutAPI methodsFor: 'accessing' stamp: ''!
options
	^ options! !

!FFICalloutAPI methodsFor: 'action' stamp: ''!
function: functionSignature library: moduleNameOrLibrary
	| sender ffiMethod ffiMethodSelector |
	sender := self senderContext.
	ffiMethodSelector := self uFFIEnterMethodSelector.	"Build new method"
	ffiMethod := self newBuilder
		build: [ :builder | 
			builder
				signature: functionSignature;
				sender: sender;
				fixedArgumentCount: fixedArgumentCount;
				library: moduleNameOrLibrary ].
	ffiMethod
		selector: sender selector;
		methodClass: sender methodClass.	"Replace with generated ffi method, but save old one for future use"
	ffiMethod
		propertyAt: #ffiNonCompiledMethod
		put: (sender methodClass methodDict at: sender selector).	"For senders search, one need to keep the selector in the properties"
	ffiMethod propertyAt: #ffiMethodSelector put: ffiMethodSelector.
	sender methodClass methodDict at: sender selector put: ffiMethod.	"Register current method as compiled for ffi"
	FFIMethodRegistry uniqueInstance registerMethod: ffiMethod.	"Resend"
	sender
		return: (sender receiver withArgs: sender arguments executeMethod: ffiMethod).
	^ self! !

!FFICalloutAPI methodsFor: 'accessing' stamp: ''!
options: anObject
	options := anObject! !

!FFICalloutAPI class methodsFor: 'accessing' stamp: ''!
calloutAPIClass: aClass
	CalloutAPIClass := aClass! !

!FFICalloutAPI class methodsFor: 'accessing' stamp: ''!
defaultCalloutAPIClass
	
	^ FFIBackend current calloutAPIClass ! !

!FFICalloutAPI class methodsFor: 'instance creation' stamp: ''!
new 
	self error: 'use #inFFIContext:'! !

!FFICalloutAPI class methodsFor: 'instance creation' stamp: ''!
inContext: aContext
	"Should not be used. For backwards compatibility only"
	^ self basicNew 
		initializeContext: aContext;
		yourself! !

!FFICalloutAPI class methodsFor: 'private' stamp: ''!
newCallbackBackendFor: aCallback

	^ self subclassResponsibility! !

!FFICalloutAPI class methodsFor: 'accessing' stamp: ''!
calloutAPIClass
	^ CalloutAPIClass ifNil: [ self defaultCalloutAPIClass ]
	! !

!FFICalloutAPI class methodsFor: 'instance creation' stamp: ''!
inUFFIContext: aContext
	^ self basicNew 
		initializeUFFIContext: aContext;
		yourself! !

!FFICalloutAPITest commentStamp: ''!
Tests for FFICalloutAPI!
!FFICalloutAPITest methodsFor: 'tests pointer' stamp: ''!
testVoidPointer
	| result dest |
	
	result := self 
		primMemMoveFrom: 'Hello, World' asByteArray 
		to: (dest := ByteArray new: 12) 
		size: 12.
		
	self deny: result isNull.	
	self assert: dest asString equals: 'Hello, World'! !

!FFICalloutAPITest methodsFor: 'tests object' stamp: ''!
testCallWithObjectParameter
	"Test a call of the form: 
	
		self nbCall: #( void function ( self ) )
		
		(passing self as parameter)
	"
	| object text |
	
	text := 'Hello, World'.
	object := FFICalloutObjectForTest new
		handle: (ByteArray new: text size + 1);
		yourself. 
	
	self 
		shouldnt: [ FFICalloutObjectForTest primObject: object strcpy: text ] 
		raise: Error.
	self assert: object handle asString equals: (text copyWith: (Character value: 0))! !

!FFICalloutAPITest methodsFor: 'primitives atomic' stamp: ''!
ffiLongLongAbs: number
	^ self ffiCall: #( longlong llabs (longlong number) )! !

!FFICalloutAPITest methodsFor: 'primitives atomic' stamp: ''!
ffiCopyString: aString to: dest
	^ self ffiCall: #( String strcpy ( void* dest, String aString ) )! !

!FFICalloutAPITest methodsFor: 'tests context' stamp: ''!
testSenderLookupsMethodInSenderChain
	| api |
	
	api := FFICalloutAPI inUFFIContext: uffiCtx.
	self assert: api senderContext equals: senderCtx! !

!FFICalloutAPITest methodsFor: 'accessing' stamp: ''!
ffiLibraryName
	^ LibC! !

!FFICalloutAPITest methodsFor: 'running' stamp: ''!
resetFFIMethods
	| ffiMethods |
	ffiMethods := FFICalloutAPITest methodDict select: [ :method | (method selector beginsWith: 'ffi') or: [method selector beginsWith: 'prim'] ].
	ffiMethods do: #recompile! !

!FFICalloutAPITest methodsFor: 'tests constant' stamp: ''!
testCallWithConstParameter
	"Tests a function in the form: 
	
	self nbCall: #( long ffiTestInts ( 65, 65, 65, long aNumber ) )
	
	(passing constants as parameters)
	"
	| result buffer |

	self skipOnAppleARM.

	buffer := (ByteArray new: 100)
		pinInMemory; yourself.
	
	result := self ffiTestContantFormat: '%d, %d and %d' value: true to: buffer.
	self assert: result equals: 12.
	self assert: (buffer first: result) asString equals: '65, 65 and 1'! !

!FFICalloutAPITest methodsFor: 'tests pointer' stamp: ''!
testCharPointer
	| result buffer |
	
	buffer := ByteArray new: 512.
	buffer writeString: 'Hello, '.
		
	result := self 
		primStr:  buffer
		cat: 'World'.
				
	self assert: result equals: 'Hello, World'.! !

!FFICalloutAPITest methodsFor: 'tests object' stamp: ''!
testCallWithObjectCreation
	"Test a call of the form: 
	
		self nbCall: #( NBFFICalloutVMObjectForTest malloc ( size_t size ) )
		
		(obtaining an object as result)
	"
	| object |
	
	[
		self shouldnt: [ object := FFICalloutObjectForTest primCreate: 1 ] raise: Error.
		self assert: object notNil.
		self assert: object class equals: FFICalloutObjectForTest.
		self assert: object handle notNil.
		self deny: object handle isNull ]
	ensure: [ 
		object ifNotNil: [ object free ] ]! !

!FFICalloutAPITest methodsFor: 'tests atomic' stamp: ''!
testPrintString
	"Test using generic FFI spec"
	| result buffer |
	
	buffer := (ByteArray new: 12)
			pinInMemory;
			yourself.
	result := self ffiCopyString: 'Hello World!!' to: buffer.
	self assert: result equals: 'Hello World!!'.
	self assert: buffer asString equals: 'Hello World!!'! !

!FFICalloutAPITest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	self resetFFIMethods.
	senderCtx := Context
		sender: nil
		receiver: nil
		method: Object>>#yourself
		arguments: #().
	
	uffiCtx := Context
		sender: senderCtx
		receiver: nil
		method: Object>>#ffiCall:
		arguments: #(1).
		
	lastUffiCtx := Context
		sender: uffiCtx
		receiver: nil
		method: Object>>#ffiCall:options:
		arguments: #(1 2).! !

!FFICalloutAPITest methodsFor: 'tests constant' stamp: ''!
testCallWithAllConstParameter
	"Tests a function in the form: 
	
	self nbCall: #( long ffiTestInts ( 65, 65, 65, long aNumber ) )
	
	(passing constants as parameters)
	"
	| result buffer |

	self skipOnAppleARM.

	buffer := (ByteArray new: 100)
		pinInMemory;
		yourself. 
	result := self ffiTestConstantFormat: '%d, %d and %d' to: buffer.
	self assert: result equals: 12.
	self assert: (buffer first: result) asString equals: '65, 65 and 1'! !

!FFICalloutAPITest methodsFor: 'primitives pointer' stamp: ''!
primFromByteArray: src toExternalAddress: dest size: n
	^ self 
		ffiCall: #( void *memcpy(void* dest, ByteArray src, size_t n) )
		module: LibC! !

!FFICalloutAPITest methodsFor: 'primitives atomic' stamp: ''!
ffiFloatAbs: number 
	^ self ffiCall: #( float FloatAbsolute (float number) ) options: #(+optCallbackCall)! !

!FFICalloutAPITest methodsFor: 'primitives pointer' stamp: ''!
primMemMoveFrom: src to: dest size: n
	^ self 
		ffiCall: #( void *memcpy(void *dest, const void *src, size_t n) )
		module: LibC! !

!FFICalloutAPITest methodsFor: 'running' stamp: ''!
tearDown
	FFICallbackFunctionResolution reset.
	super tearDown.! !

!FFICalloutAPITest methodsFor: 'tests atomic' stamp: ''!
testIntCall
	"Test using generic FFI spec"
	| result |
	
	result := self ffiIntAbs: 65.
	self assert: result equals: 65.
	
	result := self ffiIntAbs: 65.0.
	self assert: result equals: 65.

	result := self ffiIntAbs: $A.
	self assert: result equals: 65.

	result := self ffiIntAbs: true.
	self assert: result equals: 1.
! !

!FFICalloutAPITest methodsFor: 'tests context' stamp: ''!
testuFFIMethodSelectorLookupsFirstMethodInSenderChain
	| api selector |
	
	api := FFICalloutAPI inUFFIContext: lastUffiCtx.
	selector := api uFFIEnterMethodSelector.

	self assert: selector equals: uffiCtx method selector! !

!FFICalloutAPITest methodsFor: 'primitives constant' stamp: ''!
ffiTestContantFormat: format value: aNumber to: buffer
	^ self ffiCall: #( int sprintf ( ByteArray buffer, String format, 65, 65, long aNumber ) ) fixedArgumentCount: 2! !

!FFICalloutAPITest methodsFor: 'primitives atomic' stamp: ''!
ffiDoubleAbs: number 
	^ self ffiCall: #( double DoubleAbsolute (double number) ) options: #(+optCallbackCall)! !

!FFICalloutAPITest methodsFor: 'primitives constant' stamp: ''!
ffiTestConstantFormat: format to: buffer
	^ self ffiCall: #( int sprintf ( ByteArray buffer, String format, 65, 65, 1 ) ) fixedArgumentCount: 2! !

!FFICalloutAPITest methodsFor: 'tests context' stamp: ''!
testuFFIMethodSelectorInNonMarkedContextDoesNotFindAMethodEnterSelector
	| api selector |
	
	api := FFICalloutAPI inUFFIContext: senderCtx.
	selector := api uFFIEnterMethodSelector.

	self assert: selector equals: nil! !

!FFICalloutAPITest methodsFor: 'primitives atomic' stamp: ''!
ffiToLower: c
	^ self ffiCall: #( char tolower (char c) )! !

!FFICalloutAPITest methodsFor: 'accessing' stamp: ''!
method1 
	| object index |
	object := FFICalloutObjectForTest new.
	index := FFICalloutObjectForTest class instVarIndexFor: #handle ifAbsent: [ nil ].
	^ object instVarAt: index.! !

!FFICalloutAPITest methodsFor: 'running' stamp: ''!
ffiCalloutClass
	^ FFICalloutAPI! !

!FFICalloutAPITest methodsFor: 'primitives atomic' stamp: ''!
ffiIntAbs: number
	^ self ffiCall: #( int abs ( int number ) )! !

!FFICalloutAPITest methodsFor: 'tests pointer' stamp: ''!
testByteArrayToExternalAddress
	| result dest |
	

	result := self 
		primFromByteArray: ('Hello, World' asByteArray pinInMemory; yourself) 
		toExternalAddress: (dest := ExternalAddress allocate: 12) autoRelease 
		size: 12.
		
	self assert: (dest copyFrom: 1 to: 12) asString equals: 'Hello, World'.
	! !

!FFICalloutAPITest methodsFor: 'tests object' stamp: ''!
testCallWithSelfParameter
	"Test a call of the form: 
	
		self nbCall: #( void function ( self ) )
		
		(passing self as parameter)
	"
	| object |
	
	object := FFICalloutObjectForTest new. 
	self 
		shouldnt: [ object strcpy: 'Hello, World' ] 
		raise: Error.
	"Since is a strcpy it will answer a byte array terminated in zero"
	self assert: object handle asString equals: ('Hello, World' copyWith: (Character value: 0))! !

!FFICalloutAPITest methodsFor: 'tests atomic' stamp: ''!
testLongLongs
	"Test passing and returning longlongs"
	| long1 long2 result  |
	
	"This test fails in windows, but it is expected (is because the funtion used is in 
	 another library)"
	Smalltalk os isWindows ifTrue: [ ^ self skip ].		
	
	long1 := 16r123456789012.
	long2 := (-1 << 31).
		
	result := self ffiLongLongAbs: long1.
	self assert: result equals: long1.
	
	result := self ffiLongLongAbs: long2.
	self assert: result equals: long2 abs! !

!FFICalloutAPITest methodsFor: 'tests context' stamp: ''!
testuFFIMethodSelectorLookupsMethodInSenderChain
	| api selector |
	
	api := FFICalloutAPI inUFFIContext: uffiCtx.
	selector := api uFFIEnterMethodSelector.

	self assert: selector equals: uffiCtx method selector! !

!FFICalloutAPITest methodsFor: 'primitives pointer' stamp: ''!
primStr: aString cat: otherString  
	^ self 
		ffiCall: #( char *strcat ( void *aString, void *otherString ) )
		module: LibC
! !

!FFICalloutAPITest methodsFor: 'tests context' stamp: ''!
testSenderLookupsMethodInSenderChainWithManyUFFIMethods
	| api |
	
	api := FFICalloutAPI inUFFIContext: lastUffiCtx.

	self assert: api senderContext equals: senderCtx! !

!FFICalloutAPITest methodsFor: 'tests atomic' stamp: ''!
testCharCall
	"Test using generic FFI spec"
	| result  |
	
	result := self ffiToLower: $A.
	self assert: result equals: $a.
	 
	result := self ffiToLower: 65.
	self assert: result equals: $a.
	
	result := self ffiToLower: 65.0.
	self assert: result equals: $a.

	result := self ffiToLower: true.
	self assert: result equals: (Character value: 1)
! !

!FFICalloutAPITest methodsFor: 'tests pointer' stamp: ''!
testForwardedObjects
	| result dest |
	dest := ByteArray new: 12.
	"Pinning an object replaces it with a forwarded."
	"We want to force the object to be forwarded by the ffi call primitive"
	dest pinInMemory.
		
	result := self 
		primMemMoveFrom: 'Hello, World' asByteArray 
		to: dest 
		size: 12.
		
	self deny: result isNull.	
	self assert: dest asString equals: 'Hello, World'! !

!FFICalloutMethodBuilder commentStamp: ''!
I build FFI method bytecodes for a call. 
!
!FFICalloutMethodBuilder methodsFor: 'building' stamp: ''!
build: aBlock 
	aBlock value: self.
	^ self generate! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
requestor: anObject 
	"The object who made the request for FFI.
	 By default, NBFFICallout (check #requestor)"
	requestor := anObject! !

!FFICalloutMethodBuilder methodsFor: 'compatibility' stamp: ''!
extractLibrary
	"Obtain the library to use"
	| ffiLibrary |
	
	ffiLibrary := library ifNil: [sender receiver ffiLibrary].	
	ffiLibrary := ffiLibrary isClass 
		ifFalse: [ ffiLibrary asFFILibrary ]
		ifTrue: [ ffiLibrary uniqueInstance ].

	^ ffiLibrary! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
library: aLibrary
	"A module can be a string with a path to the library or a reference to a class who is child 
	 of FFILibrary.
	 Example: 'libc' or LibC"
	library := aLibrary! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
callingConvention
	^ self calloutAPI callingConvention! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
fixedArgumentCount

	^ fixedArgumentCount! !

!FFICalloutMethodBuilder methodsFor: 'private' stamp: ''!
argumentNames

	^ self method argumentNames! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
library
	^ library! !

!FFICalloutMethodBuilder methodsFor: 'private - factory' stamp: ''!
createFFICallout
	^ FFICallout new
		sender: self sender;
		options: self calloutAPI options;
		yourself! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
signature
	^ signature! !

!FFICalloutMethodBuilder methodsFor: 'private' stamp: ''!
generate
	^ self generateMethodFromSpec: (self parseSignature: self signature)! !

!FFICalloutMethodBuilder methodsFor: 'private - factory' stamp: ''!
createFFICalloutLiteralFromSpec: functionSpec

	^ self subclassResponsibility ! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
methodTrailer
	
	^ self method trailer! !

!FFICalloutMethodBuilder methodsFor: 'private' stamp: ''!
generateFFICallout: builder spec: functionSpec ffiLibrary: ffiLibrary

	"Builds a method call"
	"save ffi call as literal"
	builder pushLiteral: (self createFFICalloutLiteralFromSpec: functionSpec).
	"iterate arguments in order (in the function) to create the function call"
	functionSpec arguments do: [ :each | each emitArgument: builder context: sender inCallout: self requestor ].
	"create the array"
	builder pushConsArray: functionSpec arguments size.
	"send call and store into result"
	builder send: #invokeWithArguments:.
	functionSpec arguments do: [ :each | each emitReturnArgument: builder context: sender ].
	"convert in case return type needs it. And return reseult"
	^ functionSpec returnType
		emitReturn: builder
		resultTempVar: #result
		context: sender
		inCallout: self requestor! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
sender
	^ sender! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
method
	^ self sender compiledCode method! !

!FFICalloutMethodBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	functionResolutionStrategies := FFIFunctionResolutionStrategy allSubclasses collect: [:aClass | aClass new].
	fixedArgumentCount := 0.
		! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
calloutAPI
	^ calloutAPI! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
requestor
	^ requestor ifNil: [ requestor := self createFFICallout ]! !

!FFICalloutMethodBuilder methodsFor: 'private' stamp: ''!
generateMethodFromSpec: functionSpec
	| ir ffiLibrary properties |
	functionSpec resolveUsing: self requestor.

	ffiLibrary := self extractLibrary.

	ir := IRBuilder buildIR: [ :builder | | r |
		
		"Copy the properties of the old method"
		sender methodProperties
			ifNotNil: [ properties := sender methodProperties copy.
				properties method: nil.
				builder properties: properties ].

		builder
			numArgs: self argumentNames size;
			addTemps: (self argumentNames copyWith: #result).		
		
		ffiLibrary preMethodBuildContext: sender builder: builder spec: functionSpec.
		r := self generateFFICallout: builder spec: functionSpec ffiLibrary: ffiLibrary.
		ffiLibrary postMethodBuildContext: sender builder: builder spec: functionSpec.
		r].
	^ ir generate: self methodTrailer! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
fixedArgumentCount: anObject

	fixedArgumentCount := anObject! !

!FFICalloutMethodBuilder methodsFor: 'initialization' stamp: ''!
initializeCalloutAPI: aCalloutAPI
	calloutAPI := aCalloutAPI.
	self initialize! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
sender: anObject
	sender := anObject! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
signature: anObject
	signature := anObject! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
addFunctionResolveStrategy: aStrategy
	functionResolutionStrategies add: aStrategy! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
callType
	self callingConvention = #cdecl ifTrue: [ ^ 0 ].
	self callingConvention = #stdcall ifTrue: [ ^ 1 ].

	self error: 'Invalid call convention!!'! !

!FFICalloutMethodBuilder methodsFor: 'private' stamp: ''!
parseSignature: aSignature
	^ FFIFunctionParser new  
		requestor: self requestor;
		parseNamedFunction: aSignature! !

!FFICalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
libraryName
	"Answer the module name, who can come from a string with the path to the module or a 
	 reference to a class who is child of FFILibrary"
	self library ifNil: [ ^ nil ].
	^ self library asFFILibrary libraryName! !

!FFICalloutMethodBuilder class methodsFor: 'instance creation' stamp: ''!
calloutAPI: aCalloutAPI 
	^ self basicNew 
		initializeCalloutAPI: aCalloutAPI;
		yourself! !

!FFICalloutMethodBuilderTest commentStamp: ''!
Tests for FFICalloutMethodBuilder!
!FFICalloutMethodBuilderTest methodsFor: 'tests' stamp: ''!
testAllAtomicTypesCall
	| result tfFunction |
	
	result := self builder build: [ :builder |	
		builder 
			signature: #( void method1 (bool var1, byte var2, char var3, double var4, float var5, long var6, longlong var7, sbyte var8, schar var9, short var10, ulong var11, ulonglong var12, ushort var13) );
			sender: (FFICalloutMethodBuilderTestContext new
				selector: #methodV1:v2:v3:v4:v5:v6:v7:v8:v9:v10:v11:v12:v13:;
				argumentNames: #('var1' 'var2' 'var3' 'var4' 'var5' 'var6' 'var7' 'var8' 'var9' 'var10' 'var11' 'var12' 'var13');
				methodClass: Object;
				yourself )].
	
	self assert: result notNil.
	self assert: result isCompiledMethod.
	self assert: result primitive equals: 0.
	
	tfFunction := result literals second.
	
	self assert: tfFunction functionName equals: 'method1'.
	self assert: tfFunction definition parameterTypes asArray equals: { 
		TFDerivedType boolean.
		TFBasicType uint8.
		TFBasicType schar.
		TFBasicType double.
		TFBasicType float.
		TFBasicType slong. 
		TFBasicType sint64.
		TFBasicType sint8.
		TFBasicType sint8.
		TFBasicType sint16.
		TFBasicType ulong.
		TFBasicType uint64.
		TFBasicType uint16}! !

!FFICalloutMethodBuilderTest methodsFor: 'tests' stamp: ''!
testCallWithObject
	| result tfFunction |
	
	result := self builder build: [ :builder |	
		builder requestor requestor: FFICalloutObjectForTest.
		builder 
			signature: #( void method1 ( #FFICalloutObjectForTest var1, int *var2 ) );
			sender: (FFICalloutMethodBuilderTestContext new
				selector: #method1:value:;
				argumentNames: #('var1' 'var2');
				methodClass: FFICalloutObjectForTest;
				yourself )].

	self assert: result notNil.
	self assert: result isCompiledMethod.
	self assert: result primitive equals: 0.
	tfFunction := result literals second.
	
	self assert: tfFunction functionName equals: 'method1'.
	self assert: tfFunction definition returnType equals: TFBasicType void.
	self assert: tfFunction definition parameterTypes last equals: TFBasicType pointer! !

!FFICalloutMethodBuilderTest methodsFor: 'tests' stamp: ''!
testCallCreateObject
	| result |
	
	result := self builder build: [ :builder |	
		builder requestor requestor: FFICalloutObjectForTest.
		builder 
			signature: #( #FFICalloutObjectForTest method1( int var1 ) );
			sender: (FFICalloutMethodBuilderTestContext new
				selector: #method1:;
				argumentNames: #('var1');
				methodClass: FFICalloutObjectForTest;
				yourself )].

	self assert: result notNil.
	self assert: result isCompiledMethod.
	self assert: result primitive equals: 0.
	self assert: result literals second functionName equals: 'method1'.
	self assert: result literals second definition returnType equals: TFBasicType pointer.
	self assert: result literals second definition parameterTypes first equals: TFBasicType sint32.! !

!FFICalloutMethodBuilderTest methodsFor: 'tests' stamp: ''!
testCallWithConstant
	| result tfFunction |
	
	result := self builder build: [ :builder |	
		builder 
			signature: #( void method1 ( int var1, 42 ) );
			sender: (FFICalloutMethodBuilderTestContext new
				selector: #method1:value:;
				argumentNames: #('var1' 'var2');
				methodClass: Object;
				yourself )].

	self assert: result notNil.
	self assert: result isCompiledMethod.
	self assert: result primitive equals: 0.

	tfFunction := result literals second.
	
	self assert: tfFunction functionName equals: 'method1'.
	self assert: tfFunction definition returnType equals: TFBasicType void.
	self assert: tfFunction definition parameterTypes asArray equals: { TFBasicType sint32. TFBasicType uint32 }! !

!FFICalloutMethodBuilderTest methodsFor: 'tests' stamp: ''!
testCallWithPointer
	| result tfFunction |
	
	result := self builder build: [ :builder |	
		builder 
			signature: #( void method1 ( int var1, int *var2 ) );
			sender: (FFICalloutMethodBuilderTestContext new
				selector: #method1:value:;
				argumentNames: #('var1' 'var2');
				methodClass: Object;
				yourself )].

	self assert: result notNil.
	self assert: result isCompiledMethod.
	self assert: result primitive equals: 0.

	tfFunction := result literals second.
	
	self assert: tfFunction functionName equals: 'method1'.
	self assert: tfFunction definition returnType equals: TFBasicType void.
	self assert: tfFunction definition parameterTypes last equals: TFBasicType pointer! !

!FFICalloutMethodBuilderTest methodsFor: 'factory' stamp: ''!
builder 
	^ (TFCalloutAPI inUFFIContext: nil) newBuilder
		requestor: FFICalloutMethodBuilderTestRequestor new;
		yourself! !

!FFICalloutMethodBuilderTest methodsFor: 'tests' stamp: ''!
testCallReturningEnumeration
	| result tfFunction |
	
	result := self builder build: [ :builder |	
		builder requestor requestor: FFICalloutObjectForTest.
		builder 
			signature: #( #FFITestEnumeration method1( int var1 ) );
			sender: (FFICalloutMethodBuilderTestContext new
				selector: #method1:;
				argumentNames: #('var1');
				methodClass: FFICalloutObjectForTest;
				yourself )].

	self assert: result notNil.
	self assert: result isCompiledMethod.
	self assert: result primitive equals: 0.

	tfFunction := result literals second.

	self assert: tfFunction functionName equals: 'method1'.
	self assert: tfFunction definition returnType equals: TFBasicType uint32! !

!FFICalloutMethodBuilderTest methodsFor: 'tests' stamp: ''!
testCallWithPointerPointer
	| result tfFunction |
	
	result := self builder build: [ :builder |	
		builder 
			signature: #( void method1 ( long **var1 ) );
			sender: (FFICalloutMethodBuilderTestContext new
				selector: #method1:;
				argumentNames: #('var1');
				methodClass: Object;
				yourself )].

	self assert: result notNil.
	self assert: result isCompiledMethod.
	self assert: result primitive equals: 0.

	tfFunction := result literals second.
	
	self assert: tfFunction functionName equals: 'method1'.
	self assert: tfFunction definition returnType equals: TFBasicType void.
	self assert: tfFunction definition parameterTypes last equals: TFBasicType pointer.
! !

!FFICalloutMethodBuilderTest methodsFor: 'tests' stamp: ''!
testCallSimple
	| result tfFunction |
	
	result := self builder build: [ :builder |	
		builder 
			signature: #( void method1 ( int var1 ) );
			sender: (FFICalloutMethodBuilderTestContext new
				selector: #method1:;
				argumentNames: #('var1');
				methodClass: Object;
				yourself )].
	
	self assert: result notNil.
	self assert: result isCompiledMethod.
	self assert: result primitive equals: 0.
	tfFunction := result literals second.
	
	self assert: tfFunction functionName equals: 'method1'.
	self assert: tfFunction definition returnType equals: TFBasicType void.
	self assert: tfFunction definition parameterTypes asArray equals: { TFBasicType sint32 }! !

!FFICalloutMethodBuilderTest methodsFor: 'tests' stamp: ''!
testCallWithSelf
	| result tfFunction |
	
	result := self builder build: [ :builder |	
		builder requestor requestor: FFICalloutObjectForTest.
		builder 
			signature: #( void method1 ( self, int *var2 ) );
			sender: (FFICalloutMethodBuilderTestContext new
				selector: #method1:value:;
				argumentNames: #('var1' 'var2');
				methodClass: FFICalloutObjectForTest;
				yourself )].

	self assert: result notNil.
	self assert: result isCompiledMethod.
	self assert: result primitive equals: 0.
	
	tfFunction := result literals second.
	
	self assert: tfFunction functionName equals: 'method1'.
	self assert: tfFunction definition returnType equals: TFBasicType void.
	self assert: tfFunction definition parameterTypes asArray equals: { TFBasicType pointer. TFBasicType pointer }! !

!FFICalloutMethodBuilderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	architecture := FFIArchitecture forCurrentArchitecture! !

!FFICalloutMethodBuilderTestContext commentStamp: ''!
I'm a context for make tests run. 
I'm polymorphic with Context and in some way also with CompiledMethod (but just in the context of the execution of the tests for method builder).!
!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
methodClass
	^ methodClass! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
ffiLibrary 

	^ LibC! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
method
	^ self! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
methodProperties
	"stub"

	^ nil! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
compiledCode
	^ self! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
trailer
	^ CompiledMethodTrailer empty! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
methodClass: anObject
	methodClass := anObject! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
receiver
	^ self! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
argumentNames
	^ argumentNames! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
argumentNames: anObject
	argumentNames := anObject! !

!FFICalloutMethodBuilderTestContext methodsFor: 'accessing' stamp: ''!
compiledMethod
	^ self! !

!FFICalloutMethodBuilderTestRequestor commentStamp: ''!
I'm a callout for testing the method builder. 
Basically, I do not introspect any variable :P!
!FFICalloutMethodBuilderTestRequestor methodsFor: 'argument loaders' stamp: ''!
loaderFromMethodArgsNamed: argName
	(argName beginsWith: 'var')
		ifTrue: [ ^ 
			FFIMethodArgument new  
				argName: argName;
				index: (argName allButFirst: 3) asInteger ].
	^ nil! !

!FFICalloutObjectForTest commentStamp: ''!
A callout object for testing purposes!
!FFICalloutObjectForTest methodsFor: 'accessing' stamp: ''!
free
	handle ifNil: [ ^ self ].
	self primFree! !

!FFICalloutObjectForTest methodsFor: 'accessing' stamp: ''!
strcpy: aString
	handle := ByteArray new: aString size + 1.
	^ self primStrcpy: aString.! !

!FFICalloutObjectForTest methodsFor: 'accessing' stamp: ''!
handle
	^ handle! !

!FFICalloutObjectForTest methodsFor: 'primitives' stamp: ''!
primFree
	^ self 
		ffiCall: #( void free ( self ) )
		module: LibC! !

!FFICalloutObjectForTest methodsFor: 'primitives' stamp: ''!
primStrcpy: aString
	^ self 
		ffiCall: #( char *strcpy ( self, const char *aString ) )
		module: LibC! !

!FFICalloutObjectForTest methodsFor: 'accessing' stamp: ''!
handle: anObject
	handle := anObject! !

!FFICalloutObjectForTest methodsFor: 'primitives' stamp: ''!
primStrcpy: aString size: n
	^ self 
		ffiCall: #( char *strncpy ( self, const char *aString, size_t n ) )
		module: LibC! !

!FFICalloutObjectForTest class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator
	^ FFIExternalObjectType objectClass: self! !

!FFICalloutObjectForTest class methodsFor: 'primitives' stamp: ''!
primCreate: size
	self 
		ffiCall: #( FFICalloutObjectForTest malloc( size_t size ) )
		module: LibC	! !

!FFICalloutObjectForTest class methodsFor: 'primitives' stamp: ''!
primObject: anObject strcpy: aString
	self
		ffiCall: #( char *strcpy ( FFICalloutObjectForTest anObject, const char *aString ) )
		module: LibC! !

!FFICalloutTest commentStamp: ''!
Tests for FFICallout!
!FFICalloutTest methodsFor: 'private' stamp: ''!
checkType: type class: typeClass arity: ptrArity argument: arg 

	self assert: type resolvedType class equals: typeClass.
	self assert: type resolvedType pointerArity equals: ptrArity.
	self assert: type loader class equals: FFIMethodArgument.
	self assert: type loader argName equals: arg ! !

!FFICalloutTest methodsFor: 'binding' stamp: ''!
ffiBindingOf: aName
	^ self class ffiBindingOf: aName! !

!FFICalloutTest methodsFor: 'tests' stamp: ''!
testBuildingFnSpec
	| generator type s |

	generator := FFICallout new.
	
	CLASSVAR := 100.
	TYPEVAR := 'long'.
	
	generator
		requestor: self;
		methodArgs: #(arg1 arg2 arg3 arg11 arg12);
		namedFnSpec: #( long* fn (int self ,  String arg1, void**arg2, TYPEVAR arg1, char arg3, 0, (ulong)42, nil, NULL, true, false , CLASSVAR, ExternalAddress arg11, ByteArray arg12 ) ).

	generator fnSpec resolveUsing: generator.
	type := generator fnSpec returnType.
	self assert: type resolvedType class equals: FFILong.	
	self assert: type resolvedType pointerArity equals: 1.
	
	self assert: (generator fnSpec arguments size) equals: 14.
	s := generator fnSpec arguments readStream.

"int self"		self checkTypeSelf: s next class: FFIInt32 arity: 0.
"String arg1"	self checkType: s next class: FFIExternalString arity: 0 argument: 'arg1'.
"void**arg2"		self checkType: s next class: FFIVoid arity: 2 argument: 'arg2'.
"TYPEVAR arg1"	self checkType: s next class: FFILong arity: 0 argument: 'arg1'.
"char arg3"		self checkType: s next class: FFICharacterType arity: 0 argument: 'arg3'.
"0"					self checkType: s next class: FFIUInt32 value: 0.
"(ulong)42"		self checkType: s next class: FFIULong value: 42.
"nil"				self checkUntypedConstantType: s next class: FFIVoid arity: 1 value: ExternalAddress null.
"NULL"				self checkUntypedConstantType: s next class: FFIVoid arity: 1 value: ExternalAddress null.
"true"				self checkUntypedConstantType: s next class: FFIBool value: 1.
"false"			self checkUntypedConstantType: s next class: FFIBool value: 0.
"CLASSVAR"		self checkUntypedClassVariable: s next class: FFIConst value: 100.
"ExternalAddress"	self checkType: s next class: FFIOop arity: 0 argument: 'arg11'.
"ByteArray" 			self checkType: s next class: FFIOop arity: 0 argument: 'arg12'.! !

!FFICalloutTest methodsFor: 'tests' stamp: ''!
testParseOptions
	|generator|
	generator := FFICallout new.
	
	generator parseOptions: #(optStringOrNil).
	self assert: (generator optionAt: #optStringOrNil).
	generator parseOptions: #(- optStringOrNil).
	self deny: (generator optionAt: #optStringOrNil).
	
	"Lets move on to something a bit more advanced..."
	self deny: (generator optionAt: #optNotThere).
	generator parseOptions: #(+ optEncoding: utf8 optStringOrNil  - optNotThere).
	self assert: (generator optionAt: #optEncoding) equals: #utf8.
	self assert: (generator optionAt: #optStringOrNil).
	
	generator parseOptions: #(- optEncoding).
	self deny: (generator optionAt: #optEncoding)
	
	! !

!FFICalloutTest methodsFor: 'private' stamp: ''!
checkType: type class: typeClass value: const
	self assert: type resolvedType class equals: typeClass.
	self assert: type value equals: const! !

!FFICalloutTest methodsFor: 'tests' stamp: ''!
testStrictModeOptionOff
	|generator|
	generator := FFICallout new.
	
	generator parseOptions: #(- optStrict ).
	self deny: generator isStrict! !

!FFICalloutTest methodsFor: 'private' stamp: ''!
checkUntypedClassVariable: aFFIConstantArgument class: aTypeClass value: aValue 
	
	self assert: aFFIConstantArgument resolvedType class equals: aTypeClass.
	self assert: aFFIConstantArgument resolvedType value equals: aValue.! !

!FFICalloutTest methodsFor: 'tests' stamp: ''!
testStrictModeOptionOn
	|generator|
	generator := FFICallout new.
	
	generator parseOptions: #(+ optStrict ).
	self assert: generator isStrict! !

!FFICalloutTest methodsFor: 'private' stamp: ''!
checkUntypedConstantType: aFFIConstantArgument class: aTypeClass value: aValue
	
	self checkUntypedConstantType: aFFIConstantArgument class: aTypeClass arity: 0 value: aValue! !

!FFICalloutTest methodsFor: 'tests' stamp: ''!
testBeStrictTurnsOptionOn
	|generator|
	generator := FFICallout new.
	
	generator beStrict.
	self assert: generator isStrict! !

!FFICalloutTest methodsFor: 'tests' stamp: ''!
testBeNonStrictTurnsOptionOff
	|generator|
	generator := FFICallout new.
	
	generator beNonStrict.
	self deny: generator isStrict! !

!FFICalloutTest methodsFor: 'private' stamp: ''!
checkTypeSelf: type class: typeClass arity: ptrArity 

	self assert: type resolvedType class equals: typeClass.
	self assert: type resolvedType pointerArity equals: ptrArity.
	self assert: type loader class equals: FFISelfArgument.! !

!FFICalloutTest methodsFor: 'private' stamp: ''!
checkType: type class: typeClass arity: ptrArity value: anObject 

	self assert: type resolvedType class equals: typeClass.
	self assert: type resolvedType pointerArity equals: ptrArity.
	self assert: type loader class equals: FFIConst.
	self assert: type loader value equals: anObject ! !

!FFICalloutTest methodsFor: 'private' stamp: ''!
checkUntypedConstantType: aFFIConstantArgument class: aTypeClass arity: anInteger value: aValue

	self assert: aFFIConstantArgument resolvedType class equals: aTypeClass.
	self assert: aFFIConstantArgument resolvedType pointerArity equals: anInteger.
	self assert: aFFIConstantArgument loader value equals: aValue.! !

!FFICharacterType commentStamp: ''!
Character type.
Represented as single byte on C side.!
!FFICharacterType methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType schar! !

!FFICharacterType methodsFor: 'callbacks' stamp: ''!
extractFromCallbackOn: aCallbackArgumentReader 

	aCallbackArgumentReader extractCharacterType! !

!FFICharacterType methodsFor: 'testing' stamp: ''!
needsArityPacking
	">1 because it can be a 'char *', then just roll when is 'char**' or bigger"
	^ self pointerArity > 1! !

!FFICharacterType methodsFor: 'emitting code' stamp: ''!
emitReturn: aBuilder resultTempVar: resultVar context: aContext inCallout: aCallout

	| isString |
	isString := self pointerArity = 1.
	^ isString
		ifTrue: [
			aCallout stringEncodingStrategy
				emitIRForFunctionReturn: self inIRBuilder: aBuilder context: aContext ]
		ifFalse: [ super emitReturn: aBuilder resultTempVar: resultVar context: aContext inCallout: aCallout ]! !

!FFICharacterType methodsFor: 'emitting code' stamp: ''!
basicEmitArgument: aBuilder context: aContext inCallout: aCallout

	| isString |
	isString := self pointerArity = 1.
	isString
		ifTrue: [
			aCallout stringEncodingStrategy
				emitIRForFunctionArgument: self inIRBuilder: aBuilder context: aContext ]
		ifFalse: [ super basicEmitArgument: aBuilder context: aContext inCallout: aCallout ]! !

!FFICharacterType methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle signedCharAt: index! !

!FFICharacterType methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalTypeWithArity
	
	"If it is a char* we can assume it is a String"
	self pointerArity = 1 ifTrue: [ ^TFDerivedType string ]. 

	^ super tfExternalTypeWithArity! !

!FFICharacterType methodsFor: 'accessing' stamp: ''!
defaultReturnOnError

	^ Character null! !

!FFICharacterType methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle signedCharAt: index put: value! !

!FFICharacterType methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ #integer! !

!FFICharacterType methodsFor: 'testing' stamp: ''!
needsArityUnpacking
	"'char **' or bigger need to be unpacked"
	^ self needsArityPacking! !

!FFICharacterType class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ 1! !

!FFICharacterType class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 1! !

!FFICharacterType class methodsFor: 'accessing' stamp: ''!
externalType
	^ ExternalType char! !

!FFIClassVariableArgument commentStamp: ''!
I am a loader for class variables, pushing to the stack the class variable literal!
!FFIClassVariableArgument methodsFor: 'accessing' stamp: ''!
argName: anObject
	argName := anObject! !

!FFIClassVariableArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext
	aBuilder pushLiteralVariable: (aContext methodClass bindingOf: self argName).! !

!FFIClassVariableArgument methodsFor: 'private' stamp: ''!
rolledPointerTempName
	^ self rolledPointerTempNameFor: self argName! !

!FFIClassVariableArgument methodsFor: 'accessing' stamp: ''!
argName
	^ argName! !

!FFICompilerPlugin commentStamp: ''!
I am a FFICompilerPlugin - a compiler plugin for the OpalCompiler that makes the compiled method store the arguments names to be used for FFI when the sources are not loaded or unloaded.
I can be activated with the command 

  FFICompilerPlugin install

I am pragma-based to detect the methods where the arguments names should be remembered.
The pragma should be added in the FFI API methods, i.e., the methods that are called by the FFI methods where the arguments have to be remembered.
Example:

This FFI method should remember the name of the argument named config:

repository_config: config
	^ self
		call: #(#LGitReturnCodeEnum #git_repository_config #(#LGitConfig #* #config #, #self))
		options: #()

So, the FFI function should wear the pragma <ffiCalloutTranslator>:

call: fnSpec options: options
	<ffiCalloutTranslator>
	^ (self safeFFICalloutIn: thisContext sender)
		cdecl;
		options: options;
		function: fnSpec module: self ffiLibraryName

To remove to be able to remove the sources (.changes and .sources), you only have to activate the plugin, no recompilation is necessary. You can even import new FFI methods or change the FFI API.

N.B: Users that redefine the FFI API (like TLGitCalloutTrait >> call:options:) also have to wear the pragma. See also FFIAdditionalFFIMethodState and FDBDecompiler>>createNArgs:!
!FFICompilerPlugin methodsFor: 'api' stamp: ''!
transform
	"While plugin is used to compile every method we can use it for two purposes:
		- collect all ffiCallout selectors like ffiCall:, nbCall:
		- mark ffi methods which use collected selectors that they are FFI"
	self transformsFFIMethod ifFalse: [ ^ast].
	 
	ast ensureCachedArgumentNames.
	ast methodPropertyAt: #isFFIMethod put: true.
	^ast! !

!FFICompilerPlugin methodsFor: 'api' stamp: ''!
transformsFFIMethod
	
	(ast hasPragmaNamed: #ffiCalloutTranslator)
		ifTrue: [ ^ false ].
	ast nodesDo: [ :each | 
			each isMessage ifTrue: [
				(self ffiCalloutSelectors includes: each selector)
					ifTrue: [ ^ true ] ] ].
	^ false! !

!FFICompilerPlugin methodsFor: 'private - accessing' stamp: ''!
ffiCalloutSelectors

	^self class ffiCalloutSelectors! !

!FFICompilerPlugin class methodsFor: 'class initialization' stamp: ''!
initialize

	self 
		initializeFFICalloutSelectors;
		recompileSenders;
		install! !

!FFICompilerPlugin class methodsFor: 'installation' stamp: ''!
install
	<script>
	(CompilationContext defaultTransformationPlugins includes: self)
		ifTrue: [ ^ self ].
	CompilationContext addDefaultTransformationPlugin: self.
	self recompileSenders.! !

!FFICompilerPlugin class methodsFor: 'private' stamp: ''!
recompileSenders

	self ffiCalloutSelectors do: [ :selector | selector senders do: [ :sender | sender recompile ] ]! !

!FFICompilerPlugin class methodsFor: 'private' stamp: ''!
priority
	^ 2! !

!FFICompilerPlugin class methodsFor: 'accessing' stamp: ''!
ffiCalloutSelectors
	<script: 'self ffiCalloutSelectors inspect'>
	
	^FFICalloutSelectors ifNil: [ self initializeFFICalloutSelectors ]! !

!FFICompilerPlugin class methodsFor: 'installation' stamp: ''!
uninstall
	<script>
	CompilationContext removeDefaultTransformationPlugin: self.
	self recompileSenders! !

!FFICompilerPlugin class methodsFor: 'private' stamp: ''!
initializeFFICalloutSelectors

	FFICalloutSelectors := (Pragma allNamed: #ffiCalloutTranslator) collect: [ :pragma | pragma method selector ] as: IdentitySet! !

!FFICompilerPluginTest commentStamp: ''!
Tests for FFICompilerPlugin!
!FFICompilerPluginTest methodsFor: 'tests' stamp: ''!
testDecompilationOfFFIMethodShouldHaveNamedArgs
	| decompiledFFIMethod |
	decompiledFFIMethod := (FFICompilerPluginTest >> #ffiCopyString:to:) decompile.
	self assert: decompiledFFIMethod argumentNames equals: #(#aString #dest)! !

!FFICompilerPluginTest methodsFor: 'tests' stamp: ''!
ffiCopyStringWithError: aString to: destError
	"This method explicitly uses a non-matching variable dest in the FFI call to provoke an error"
	
	^ self ffiCall: #(String strcpy #(String dest , String aString)) ! !

!FFICompilerPluginTest methodsFor: 'tests' stamp: ''!
testExecutionOfWrongFFIMethodShouldRaiseAnError
	self
		should: [ | buffer |
			buffer := ByteArray new: 12.
			self ffiCopyStringWithError: 'Hello World!!' to: buffer ]
		raise: FFIVariableNameNotFound! !

!FFICompilerPluginTest methodsFor: 'tests' stamp: ''!
ffiCopyString: aString to: dest
	^ self ffiCall: #(String strcpy #(void* dest , String aString))! !

!FFICompilerPluginTest methodsFor: 'tests' stamp: ''!
ffiLibraryName
	^ LibC! !

!FFICompilerPluginTest methodsFor: 'tests' stamp: ''!
testThatFFIAdditionalStateIsFilledCorrectlyWith2Parameters
	| ffiCallMethod |
	ffiCallMethod := self class >> #ffiCopyString:to:.
	self assert: ffiCallMethod properties notNil.
	self assert: (ffiCallMethod propertyAt: #argumentNames) equals: #(#aString #dest)! !

!FFICompilerPluginTest methodsFor: 'tests' stamp: ''!
testMethodCall
	| buffer |
	buffer := ByteArray new: 12.
	self assert: (self ffiCopyString: 'Hello World!!' to: buffer) equals: 'Hello World!!'! !

!FFICompilerPluginTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self class recompile! !

!FFICompilerPluginTest class methodsFor: 'compiler' stamp: ''!
compiler
	"the example plugin is active for this class"

	^ super compiler addPlugin: FFICompilerPlugin! !

!FFIConst commentStamp: ''!
I'm a constant in an ffi call. 
Constants can be used while doing a call, under a very restrictive rule: it has to be possible to parse it to understand which basic type it is.
!
!FFIConst methodsFor: 'emitting code' stamp: ''!
emitReturnArgument: builder context: aContext
	"Nothing to do here"! !

!FFIConst methodsFor: 'accessing' stamp: ''!
value: anObject
	value := anObject! !

!FFIConst methodsFor: 'accessing' stamp: ''!
loader 
	^ self! !

!FFIConst methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType

	^ self type tfExternalType! !

!FFIConst methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
emitArgument: aBuilder context: aContext 

	aBuilder pushLiteral: self value! !

!FFIConst methodsFor: 'accessing' stamp: ''!
type: anObject
	type := anObject! !

!FFIConst methodsFor: 'emitting code' stamp: ''!
emitReturn: aBuilder resultTempVar: resultVar context: aContext 
	self error: 'Literals cannot be used as return'! !

!FFIConst methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!FFIConst methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ value isFloat ifTrue: [#float] ifFalse: [#integer]
! !

!FFIConst methodsFor: 'accessing' stamp: ''!
pointerArity: additionalArity
	additionalArity > 0 ifTrue: [ self error: 'passing pointer to constant' ]! !

!FFIConst methodsFor: 'accessing' stamp: ''!
externalTypeAlignment

	^ self externalType externalTypeAlignment! !

!FFIConst methodsFor: 'accessing' stamp: ''!
externalTypeSize

	^ self externalType byteSize! !

!FFIConst methodsFor: 'accessing' stamp: ''!
type
	^ type! !

!FFIConst methodsFor: 'unpacking' stamp: ''!
emitPointerArityUnpack: anIRBuilder type: aFFIVoid context: aContext 
	
	"Nothing to do here"! !

!FFIConst methodsFor: 'accessing' stamp: ''!
externalType 

	^ self type externalType! !

!FFIConst class methodsFor: 'instance creation' stamp: ''!
value: aValue
	^ self new value: aValue! !

!FFIConst class methodsFor: 'instance creation' stamp: ''!
value: anObject type: aType
	^ self new 
		value: anObject;
		type: aType;
		yourself! !

!FFIConstantArgument commentStamp: ''!
I am a function argument representing a literal value (in contrast to a variable).
The parser creates me when it finds other than symbols as arguments.

I am resolved by resolving my type.
The type knows how to resolve itself in a context.!
!FFIConstantArgument methodsFor: 'accessing' stamp: ''!
value: anObject
	value := anObject! !

!FFIConstantArgument methodsFor: 'private - emitting code' stamp: ''!
emitArgumentVariableAccesingPart: aBuilder context: aContext objectClass: objectClass instVarName: aName

	self shouldNotImplement! !

!FFIConstantArgument methodsFor: 'resolving' stamp: ''!
initialize

	super initialize.
	type := FFIUndefinedTypeDeclaration new.! !

!FFIConstantArgument methodsFor: 'resolving' stamp: ''!
resolveUsing: aResolver

	value = false ifTrue: [ 
		loader := FFILiteralArgument value: 0 type: (aResolver resolveType: #bool).
		resolvedType := type resolveUsing: aResolver forArgument: self.
		resolvedType loader: loader.
		^ self ].
	value = true ifTrue: [ 
		loader := FFILiteralArgument value: 1 type: (aResolver resolveType: #bool).
		resolvedType := type resolveUsing: aResolver forArgument: self.
		resolvedType loader: loader.
		^ self ].
	(value isNil or: [ value = 'NULL' ]) ifTrue: [ 
		loader := FFILiteralArgument value: ExternalAddress null type: (aResolver resolveType: #'void *').
		resolvedType := type resolveUsing: aResolver forArgument: self.
		resolvedType loader: loader.
		^ self ].
	value == #self ifTrue: [
		loader := resolvedType := type resolveUsing: aResolver forArgument: self.
		loader loader: FFISelfArgument new.
		^ self ].
	loader := FFILiteralArgument value: value.
	resolvedType := type resolveUsing: aResolver forArgument: self.
	resolvedType loader: loader.! !

!FFIConstantArgument methodsFor: 'accessing' stamp: ''!
value 

	^ value! !

!FFIConstantArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext objectClass: objectClass instVarName: aName
	
	self shouldNotImplement! !

!FFIConstantArgument methodsFor: 'converting' stamp: ''!
asOldArraySpec

	^ {
		nil .
		nil .
		value isNumber
			ifTrue: [ value ]
			ifFalse: [ value asString ] .
		0 }! !

!FFIConstantArgument class methodsFor: 'instance creation' stamp: ''!
value: aValue typeName: aTypeName arity: anInteger
	
	^ self new
		value: aValue;
		type: (FFITypeDeclaration typeName: aTypeName arity: anInteger);
		yourself! !

!FFIConstantHandle commentStamp: ''!
I represent a constant HANDLE, as described in  *Windows MSDN>https://msdn.microsoft.com/en-us/library/windows/desktop/ms724457(v=vs.85).aspx*

A ==HANDLE== is a special kind of external object who is accessed through numbers, therefore and ==ExternalAddress== is not appropriate to describe it (since they are constants and external addresses represents disposable spaces from memory).

Is not clear this is necessary outside Windows, but according to documentation they are somekind analogous to unix's File Descriptors (but with some remarkable diferences, as documented *here>http://lackingrhoticity.blogspot.fr/2015/05/passing-fds-handles-between-processes.html*.

Example: 
[[[
User32 class>>initialize 
	HWND := #FFIConstantHandle.

User32 class>>getActiveWindow
	^ self ffiCall: #(HWND GetActiveWindow()) module: 'User32.dll'
]]]!
!FFIConstantHandle methodsFor: 'initialization' stamp: ''!
createDefaultHandle
	^ 0! !

!FFIConstantHandle methodsFor: 'evaluating' stamp: ''!
value
	^ self getHandle! !

!FFIConstantHandle class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator
	^ FFIConstantHandleType objectClass: self! !

!FFIConstantHandle class methodsFor: 'instance creation' stamp: ''!
fromInteger: anIntegerValue
	anIntegerValue ifNil: [ self error: 'Invalid value for ' , self name , ' contant handle' ].
	^ self new 
		setHandle: anIntegerValue;
		yourself! !

!FFIConstantHandleTest commentStamp: ''!
Tests for FFIConstantHandle!
!FFIConstantHandleTest methodsFor: 'tests' stamp: ''!
testCall
	| object time |
	
	object := FFIConstantHandle new.
	time := self getTime: object.
	self assert: time equals: object handle! !

!FFIConstantHandleTest methodsFor: 'tests' stamp: ''!
testReturn
	| object time |
	
	TIME_T_PTR := FFIExternalValueHolder ofType: 'long'.
	
	object := TIME_T_PTR new value: 0.
	time := self getTimeReturnConstantHandle: object.
	self assert: time handle asInteger equals: object value asInteger! !

!FFIConstantHandleTest methodsFor: 'primitives' stamp: ''!
getTime: t
     ^self ffiCall: #(long time(FFIConstantHandle *t) ) module: LibC! !

!FFIConstantHandleTest methodsFor: 'primitives' stamp: ''!
getTimeReturnConstantHandle: t
     ^self ffiCall: #(FFIConstantHandle time(TIME_T_PTR t)) module: LibC! !

!FFIConstantHandleType commentStamp: ''!
I'm a constant handle type (see ==FFIConstantHandle==  comment).!
!FFIConstantHandleType methodsFor: 'emitting code' stamp: ''!
emitReturnArgument: builder context: aContext
	self loader 
		emitHandleArityUnpack: builder
		type: self
		context: aContext
		objectClass: self objectClass
		instVarName: self instanceVariableName! !

!FFIConstantHandleType methodsFor: 'emitting code' stamp: ''!
readHandleAt: byteOffset
	^ String streamContents:[ :stream|
		stream 
			nextPutAll:'^';
			print: self objectClass;
			nextPutAll:' fromInteger: (handle ', self externalType atomicSelector,' ';
			print: byteOffset;
			nextPutAll:')' ].
! !

!FFIConstantHandleType methodsFor: 'emitting code' stamp: ''!
offsetReadFieldAt: offsetVariableName
	"Return a string defining the accessor to an entity of the receiver type starting at the given byte offset. "
	self isPointer ifTrue: [ ^ super offsetReadFieldAt: offsetVariableName ].
	^ self offsetReadHandleAt: offsetVariableName! !

!FFIConstantHandleType methodsFor: 'emitting code' stamp: ''!
writeFieldAt: byteOffset with: valueName
	^ String streamContents: [ :stream | 
		stream << 'handle ' << self externalType atomicSelector << ' ' << byteOffset asString << ' put: anObject value' ]! !

!FFIConstantHandleType methodsFor: 'emitting code' stamp: ''!
readFieldAt: byteOffset
	"Return a string defining the accessor to an entity of the receiver type starting at the given byte offset. "
	self isPointer ifTrue: [ ^ super readFieldAt: byteOffset ].
	^ self readHandleAt: byteOffset! !

!FFIConstantHandleType methodsFor: 'emitting code' stamp: ''!
offsetReadHandleAt: offsetVariableName
	^ String streamContents:[ :stream|
		stream 
			nextPutAll:'^';
			print: self objectClass;
			nextPutAll:' fromInteger: (handle ', self externalType atomicSelector,' ';
			nextPutAll: offsetVariableName;
			nextPutAll:')' ].
! !

!FFIConstantHandleType methodsFor: 'emitting code' stamp: ''!
offsetWriteFieldAt: offsetVariableName with: valueName
	^ String streamContents: [ :stream | 
		stream << 'handle ' << self externalType atomicSelector << ' ' << offsetVariableName << ' put: anObject value' ]! !

!FFIConstantHandleType methodsFor: 'accessing' stamp: ''!
externalTypeSize 
	^ self externalType byteSize! !

!FFIConstantHandleType methodsFor: 'accessing' stamp: ''!
instanceVariableName
	^ #handle! !

!FFIConstantHandleType methodsFor: 'accessing' stamp: ''!
externalType
	^ ExternalType ulong! !

!FFIConstantHandleType class methodsFor: 'private' stamp: ''!
naturalPointerArity
	^ 0! !

!FFIConstants commentStamp: ''!
Constants definitions for FFI!
!FFIConstants class methodsFor: 'pool initialization' stamp: ''!
initialize
	"FFIConstants initialize"
	
	self 
		initializeTypeConstants;
		initializeErrorConstants;
		initializeCallingConventions! !

!FFIConstants class methodsFor: 'private - initialization' stamp: ''!
initializeTypeConstants
	"type void"
	FFITypeVoid := 0.

	"type bool"
	FFITypeBool := 1.

	"basic integer types.
	note: (integerType anyMask: 1) = integerType isSigned"

	FFITypeUnsignedByte := 2.
	FFITypeSignedByte := 3.
	FFITypeUnsignedShort := 4.
	FFITypeSignedShort := 5.
	FFITypeUnsignedInt := 6.
	FFITypeSignedInt := 7.

	"64bit types"
	FFITypeUnsignedLongLong := 8.
	FFITypeSignedLongLong := 9.

	"special integer types"
	FFITypeUnsignedChar := 10.
	FFITypeSignedChar := 11.

	"float types"
	FFITypeSingleFloat := 12.
	FFITypeDoubleFloat := 13.

	"type flags"
	FFIFlagAtomic := 16r40000. "type is atomic"
	FFIFlagPointer := 16r20000. "type is pointer to base type"
	FFIFlagStructure := 16r10000. "baseType is structure of 64k length"
	FFIStructSizeMask := 16rFFFF. "mask for max size of structure"
	FFIAtomicTypeMask := 16r0F000000. "mask for atomic type spec"
	FFIAtomicTypeShift := 24. "shift for atomic type"! !

!FFIConstants class methodsFor: 'private - initialization' stamp: ''!
initializeCallingConventions
	"These constants map onto the flags inst var of an ExternalFunction.
	 The first eight bits define the calling convention.  Attribute flags
	 occupy bits 8 on up."
	"FFIConstants initializeCallingConventions"
	FFICallTypesMask := 255.
	FFICallTypeCDecl := 0.
	FFICallTypeApi := 1.
	FFICallFlagThreaded := 256! !

!FFIConstants class methodsFor: 'private - initialization' stamp: ''!
initializeErrorConstants
	"FFIConstants initializeErrorConstants"

	"No callout mechanism available"
	FFINoCalloutAvailable := -1.
	"generic error"
	FFIErrorGenericError := 0.
	"primitive invoked without ExternalFunction"
	FFIErrorNotFunction := 1.
	"bad arguments to primitive call"
	FFIErrorBadArgs := 2.

	"generic bad argument"
	FFIErrorBadArg := 3.
	"int passed as pointer"
	FFIErrorIntAsPointer := 4.
	"bad atomic type (e.g., unknown)"
	FFIErrorBadAtomicType := 5.
	"argument coercion failed"
	FFIErrorCoercionFailed := 6.
	"Type check for non-atomic types failed"
	FFIErrorWrongType := 7.
	"struct size wrong or too large"
	FFIErrorStructSize := 8.
	"unsupported calling convention"
	FFIErrorCallType := 9.
	"cannot return the given type"
	FFIErrorBadReturn := 10.
	"bad function address"
	FFIErrorBadAddress := 11.
	"no module given but required for finding address"
	FFIErrorNoModule := 12.
	"function address not found"
	FFIErrorAddressNotFound := 13.
	"attempt to pass 'void' parameter"
	FFIErrorAttemptToPassVoid := 14.
	"module not found"
	FFIErrorModuleNotFound := 15.
	"external library invalid"
	FFIErrorBadExternalLibrary := 16.
	"external function invalid"
	FFIErrorBadExternalFunction := 17.
	"ExternalAddress points to ST memory (don't you dare to do this!!)"
	FFIErrorInvalidPointer := 18.
	"Stack frame required more than 16k bytes to pass arguments."
	FFIErrorCallFrameTooBig := 19! !

!FFIDereferencedOpaqueObjectError commentStamp: ''!
I indicate that user tried to access an opaque type in a derreferenced way.
Opaque types can just be accessed by reference (as a pointer to them). 

Example:
self ffiCall: #( void function(FFIOpaqueObject  *var)  "Correct"

self ffiCall: #( void function(FFIOpaqueObject  var)  "WRONG"

!
!FFIEnumeration commentStamp: ''!
Enumerations are data-types defining a finite set of named values.
For example, let's consider we want to create a data-type to identify the different positions of players inside a football match: goalkeeper, defender, midfielder, forward. Such data-type can be defined in C as an enumeration as follows:

[[[language=c
typedef enum {
  goalkeeper,
  defender,
  midfielder,
  forward
} position;
]]]

We can then use ==position== as a type, and the values defined within it as valid values for ==position==.


[[[language=c
position myPosition = defender;
]]]

!!!!!!!! The values of C enumerations

To better understand how to map C enumerations using uFFI, we must before understand how C assigns value to each of the elements in the enumeration.
Internally, C assigns to each of the elements of the enumeration a sequencial numeric value starting from 0 (zero).
In other words, ==goalkeeper== has a value of 0, ==defender== has a value of 1, and so on.
C allows developers to specify the values they want too, using an assignment-like syntax.

[[[language=c
typedef enum {
  goalkeeper = 42,
  defender,
  midfielder,
  forward
} position;
]]]

We can explicitly assign values to any of the elements of the enumeration.
We may leave values without explicit values, in which case they will be automatically assigned a value following its previous value. And finally, many elements in the enumeration may have the same value.
The example enumeration below shows these subtleties.

[[[language=c
#include <assert.h>
#include <limits.h>

enum example {
    example0,            /* will have value 0 */
    example1,            /* will have value 1 */
    example2 = 3,        /* will have value 3 */
    example3 = 3,        /* will have value 3 */
    example4,            /* will have value 4 */
    example5 = INT_MAX,  /* will have value INT_MAX */
    /* Defining a new value after this one will cause an overflow error */
};
]]]

!!!!!!!! Defining an enumeration using ==FFIEnumeration==

Enumerations are declared in uFFI as subclasses of the ==FFIEnumeration== class defining the same elements as defined in C, and with their same values.
For example, defining our example enumeration is done as follows, defining a subclass of ==FFIEnumeration==, a ==enumDecl== class-side method returning the specification of the enumeration elements, and finally sending the ==initialize== message to the enumeration class we created.

[[[language=smalltalk
FFIEnumeration subclass: #ExampleEnumeration
  instanceVariableNames: ''
  classVariableNames: ''
  package: 'FFITutorial'

ExampleEnumeration class >> enumDecl [
	^ #(
    example0 0
    example1 1
    example2 3
    example3 3
    example4 4
    example5 2147483647
		)
]

ExampleEnumeration initialize.
]]]

Doing this will automatically generate some boilerplate code to manipulate the enumeration.
You will see that the enumeration class gets redefined as follows creating and initializing a class variable for each of its elements.

[[[language=smalltalk
FFIEnumeration subclass: #ExampleEnumeration
  instanceVariableNames: ''
  classVariableNames: 'example0 example1 example2 example3 example4 example5'
  package: 'FFITutorial'
]]]

To use the values of enumerations in our code, it is enough to import it as a pool dictionary, since uFFI enumerations are shared pools.

[[[language=smalltalk
Object subclass: #FFITutorial
  ...
  poolDictionaries: 'ExampleEnumeration'
  ...
]]]

You can use your new enum in two ways:
	- add it to a client class poolDictionaries list (see  #FFIExternalEnumTests 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 --- FFITestEnumeration DDD

The FFIEnumeration 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 --- FFITestEnumeration includes: #AAA!
!FFIEnumeration methodsFor: 'accessing' stamp: ''!
value: anObject
	value := anObject ! !

!FFIEnumeration methodsFor: 'comparing' stamp: ''!
= anEnumInst
	^ self class == anEnumInst class 
		and: [ self value = anEnumInst value ]! !

!FFIEnumeration methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(;
		 print: self item ;
		 nextPut: $)! !

!FFIEnumeration methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!FFIEnumeration methodsFor: 'accessing' stamp: ''!
item
	^ self class itemAt: value! !

!FFIEnumeration class methodsFor: 'utilities' stamp: ''!
buildClassVariables
	self enumerationDictionary keysAndValuesDo: [ :eachName :eachValue | 
		| enumerationValue |	
		enumerationValue := (self enumClassForName: eachName) basicNew value: eachValue.
		self buildClassVarNamed: eachName with: enumerationValue ]! !

!FFIEnumeration class methodsFor: 'instance creation' stamp: ''!
new
	^ self shouldNotImplement! !

!FFIEnumeration class methodsFor: 'testing' stamp: ''!
includes: aSymbol
	^ self classPool includesKey: aSymbol! !

!FFIEnumeration class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator
	^ FFIExternalEnumerationType 
		objectClass: self 
		representationType: self representationType! !

!FFIEnumeration class methodsFor: 'utilities' stamp: ''!
enumNameSuffix: aName
	^ (aName substrings: '_')
	inject: ''
	into: [ :all :each | all, (each asLowercase capitalized) ]! !

!FFIEnumeration class methodsFor: 'private' stamp: ''!
defineEnumAccesorFor: enumName
	"Define accessors as class methods"
	| code |
	
	code := enumName, '
	"This method was automatically generated"
	^ ', enumName.
	
	self class 
		compile: code 
		classified: self generatedEnumProtocolName.! !

!FFIEnumeration class methodsFor: 'utilities' stamp: ''!
enumSelectorName: aName
	^ (self enumNameSuffix: aName) asValidSelector! !

!FFIEnumeration class methodsFor: 'accessing' stamp: ''!
fromInteger: anIntegerValue
	| theItem |
	theItem := self itemAt: anIntegerValue.
	theItem ifNil: [ self error: 'Invalid value for ' , self name , ' enumeration' ].
	^ self at: theItem! !

!FFIEnumeration class methodsFor: 'private' stamp: ''!
generatedEnumProtocolName
	^ 'accessing enum'! !

!FFIEnumeration class methodsFor: 'class initialization' stamp: ''!
initialize
	self initializeEnumeration! !

!FFIEnumeration class methodsFor: 'class initialization' stamp: ''!
initializeEnumeration
	| unsigned |
	unsigned := true.
	self enumerationDictionary keysAndValuesDo: [ :eachName :eachValue | 
		| enumerationValue |
		
		(unsigned and: [ eachValue < 0 ]) 
			ifTrue: [ unsigned := false ].
		
		enumerationValue := self basicNew value: eachValue.
		self buildClassVarNamed: eachName with: enumerationValue ].
					
	representationType := unsigned
		ifTrue: [ FFIUInt32 new ]
		ifFalse: [ FFIInt32 new ]! !

!FFIEnumeration class methodsFor: 'private' stamp: ''!
rebuildEnumAccessors
	self enumerationDictionary keysDo: [ :each | 
		self defineEnumAccesorFor: each ]! !

!FFIEnumeration class methodsFor: 'utilities' stamp: ''!
rebuildEnumHierarchyAccessors
	self enumerationDictionary keysDo: [ :each | 
		self defineEnumHierarchyAccesorFor: each ]! !

!FFIEnumeration class methodsFor: 'accessing' stamp: ''!
representationType
	^ representationType! !

!FFIEnumeration class methodsFor: 'accessing' stamp: ''!
itemAt: aValue ifAbsent: exceptionBlock

	self classPool associationsDo: [ :assoc | 
		aValue = assoc value value ifTrue: [ 
			^ assoc key ] ].

	^ exceptionBlock value! !

!FFIEnumeration class methodsFor: 'accessing' stamp: ''!
at: anItem
	^ self classPool at: anItem ifAbsent: [ nil ]! !

!FFIEnumeration class methodsFor: 'utilities' stamp: ''!
enumClassForName: aName
	| className |
	
	className := (self name, (self enumNameSuffix: aName)) asSymbol.
	^ self allSubclasses
		detect: [ :each | each name = className ]
		ifNone: [ 
			self class classInstaller make: [ :aBuilder | 
				aBuilder 
					name: className;
					package: self category ]]! !

!FFIEnumeration class methodsFor: 'utilities' stamp: ''!
defineEnumHierarchyAccesorFor: enumName
	"Define accessors as class methods"
	| code |
	
	code := (self enumSelectorName: enumName), '
	"This method was automatically generated"
	^ ', enumName.
	
	self class 
		compile: code 
		classified: self generatedEnumProtocolName! !

!FFIEnumeration class methodsFor: 'utilities' stamp: ''!
buildEnumHierarchy
	"This utility method will create a hierarchy based on enumDecl"
	<script>
	
	self buildClassVariables.
	self rebuildEnumHierarchyAccessors! !

!FFIEnumeration class methodsFor: 'enum declaration' stamp: ''!
enumDecl
	^ #()! !

!FFIEnumeration class methodsFor: 'accessing' stamp: ''!
itemAt: aValue

	^ self 
		itemAt: aValue 
		ifAbsent: [ nil ]! !

!FFIEnumeration class methodsFor: 'private' stamp: ''!
enumerationDictionary
	| decl |
	decl := self enumDecl.
	decl isDictionary
		ifTrue: [ ^ decl ].
	decl := Dictionary newFromPairs: decl.
	^ decl! !

!FFIEnumeration class methodsFor: 'utilities' stamp: ''!
buildClassVarNamed: aString with: enumerationValue
	
		| classBinding |
		classBinding := self classVariableNamed: aString ifAbsent: [ nil ].
		classBinding 
			ifNotNil: [ classBinding value: enumerationValue ]
			ifNil: [ 
				self addClassVariable: (ClassVariable key: aString asSymbol value: enumerationValue) ]! !

!FFIExternalArray commentStamp: ''!
I am class which provides a convenient interface to work with arrays which elements are values of some external (C) type.
This class uses double dispatch to solve #at: and #at:put: methods, if you need to achieve speed, is recommendable to subclass me and override this methods to avoid the indirection.!
!FFIExternalArray methodsFor: 'finalization' stamp: ''!
free
	handle ifNil: [ ^ self ]. 
	handle isExternalAddress 
		ifTrue: [ handle free ]
		ifFalse: [ handle := nil ]! !

!FFIExternalArray methodsFor: 'initialization' stamp: ''!
initializeType: aType size: aNumber handleProducer: aBlock 
	type := aType.
	size := aNumber.
	handle := aBlock value: (size 
		ifNotNil: [ size * type typeSize ]
		ifNil: [ 0 ]).
	handle isNull ifTrue: [ self error: 'External allocation failed' ].
	self initialize! !

!FFIExternalArray methodsFor: 'accessing' stamp: ''!
getHandle
	self flag: #pharoTodo. "I do not like the name 'getHandle' but I'm looking to unify the 
	API with FFI" 
	^ handle! !

!FFIExternalArray methodsFor: 'accessing' stamp: ''!
at: index put: anObject 
	^ type 
		handle: handle
		at: ((index - 1) * type typeSize) + 1
		put: anObject! !

!FFIExternalArray methodsFor: 'external resource management' stamp: ''!
autoRelease
	(handle isNil or: [ handle isExternalAddress not ]) ifFalse: [ ^ self ].
	handle autoRelease! !

!FFIExternalArray methodsFor: 'converting' stamp: ''!
asArray 
	| array |
	
	array := Array new: self size.
	1 to: self size do: [ :index | array at: index put: (self at: index) ].
	
	^ array ! !

!FFIExternalArray methodsFor: 'initialization' stamp: ''!
size
	^ size! !

!FFIExternalArray methodsFor: 'accessing' stamp: ''!
at: index 
	^ type 
		handle: handle
		at: ((index - 1) * type typeSize) + 1! !

!FFIExternalArray methodsFor: 'converting' stamp: ''!
pointer
	"Answers a pointer to this array. 
	 This is useful when translating an array pointer to a function (FFI requires to be passed as a
	 pointer, otherwise will be interpreted as a direct array and it will not work fine)
	
	 For an example, see FFICallback class>>#exampleCqsort
	
	 WARNING: Only valid for external address (you cannot have a pointer to an image side object)"
		
	self getHandle isExternalAddress ifFalse: [ 
		self error: 'Arrays need to be moved to external memory space before passing them as pointers.' ].
	^ self getHandle pointer	! !

!FFIExternalArray methodsFor: 'converting' stamp: ''!
pointerAutoRelease
	"Same as #pointer (see its comment for detals), but contents are garbage collected automatically"
	^ self pointer autoRelease! !

!FFIExternalArray methodsFor: 'initialization' stamp: ''!
initializeExternalType: aType size: aNumber
	self 
		initializeType: aType 
		size: aNumber 
		handleProducer: [ :totalSize | ExternalAddress allocate: (type typeSize * size) ]! !

!FFIExternalArray methodsFor: 'converting' stamp: ''!
tfPointerAddress
	
	^ handle tfPointerAddress! !

!FFIExternalArray methodsFor: 'accessing' stamp: ''!
typeAlignment 
	^ self type typeAlignment! !

!FFIExternalArray methodsFor: 'initialization' stamp: ''!
initializeHandle: aHandle type: aType size: aNumber
	self 
		initializeType: aType 
		size: aNumber 
		handleProducer: [ :totalSize | aHandle ]! !

!FFIExternalArray methodsFor: 'accessing' stamp: ''!
type
	^ type! !

!FFIExternalArray methodsFor: 'initialization' stamp: ''!
initializeType: aType size: aNumber
	self 
		initializeType: aType 
		size: aNumber 
		handleProducer: [ :totalSize | ByteArray new: totalSize ]
! !

!FFIExternalArray methodsFor: 'accessing' stamp: ''!
typeSize 
	^ self type typeSize! !

!FFIExternalArray class methodsFor: 'instance creation' stamp: ''!
externalNewType: aType size: aNumber
	"Create a new array in the C heap. 
	 This array needs to be disposed (using #free method)"
	^ self basicNew 
		initializeExternalType: (self resolveType: aType) size: aNumber;
		yourself! !

!FFIExternalArray class methodsFor: 'instance creation' stamp: ''!
fromPointer: aHandle type: aType size: aNumber
	"Creates an array of type aType and size aNumber.
	 aHandle is A REFERENCE an array already existing. 
	 For example, C: 
	 	
		byte[]	 array;
		void * aHandle = &array;
			
	 Which means first element of array will be found at ==aHandle pointerAt: 1=="
	^ self fromHandle: (aHandle pointerAt: 1) type: aType size: aNumber! !

!FFIExternalArray class methodsFor: 'instance creation' stamp: ''!
new 
	self error: 'should not create external arrays like this'! !

!FFIExternalArray class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator 
	^ FFIExternalArrayType objectClass: self! !

!FFIExternalArray class methodsFor: 'private' stamp: ''!
resolveType: aType
	 ^ FFICallout new 
		requestor: self;
		resolveType: aType.! !

!FFIExternalArray class methodsFor: 'instance creation' stamp: ''!
fromHandle: aHandle type: aType
	"Instantiating a handle as an array.
	 USE THIS WITH EXTREMELY CAUTION: You could have an overflow very easily, because you are 
	 not expliciting the size. 
	 I would prefer if you use #fromHandle:type:size: instead. "
	^ self fromHandle: aHandle type: aType size: nil! !

!FFIExternalArray class methodsFor: 'instance creation' stamp: ''!
newType: aType size: aNumber
	"Create a new array using internal memory."
	^ self basicNew 
		initializeType: (self resolveType: aType) size: aNumber;
		yourself! !

!FFIExternalArray class methodsFor: 'instance creation' stamp: ''!
fromPointer: aHandle type: aType 
	"Instantiating a pointer as an array is usefull, but then you do not have the size. 
	 USE THIS WITH EXTREMELY CAUTION: You could have an overflow very easily. 
	 I would prefer if you use #fromPointer:type:size: instead. "
	^ self fromPointer: aHandle type: aType size: nil! !

!FFIExternalArray class methodsFor: 'instance creation' stamp: ''!
fromHandle: aHandle type: aType size: aNumber
	"aHandle is the address to an array already existing. 
	 For example, C: 
	 	
		byte[]	 aHandle;
			
	 which means is a direct reference and array starts in same address as aHandle"
	^ self basicNew 
		initializeHandle: aHandle type: (self resolveType: aType) size: aNumber;
		yourself! !

!FFIExternalArrayTest commentStamp: ''!
Tests for FFIExternalArray!
!FFIExternalArrayTest methodsFor: 'tests' stamp: ''!
testExternalAtPutFloat
	| random array |
	random := Random new.
	[
		array := FFIExternalArray externalNewType: 'float' size: 10.
		1 to: 10 do: [ :index | array at: index put: random next ].
		1 to: 10 do: [ :index | self assert: (array at: index) isFloat ] ]
	ensure: [ array free ]! !

!FFIExternalArrayTest methodsFor: 'tests' stamp: ''!
testExternalAt
	| externalArray |
	
	[
	 	externalArray := FFIExternalArray externalNewType: 'int' size: 10.
		self assert: externalArray size equals: 10.
		"External is not initialized, so I cannot check for contents unless I assign them"
		1 to: 10 do: [ :index | externalArray at: index put: 0 ].
		"Testing accessing"
		1 to: 10 do: [ :index | self assert: (externalArray at: index) equals: 0 ].
	] ensure: [ 
		externalArray free ] 
! !

!FFIExternalArrayTest methodsFor: 'tests' stamp: ''!
testReadArrayOfUntil
	| n interval externalArray |
	n := 10.
	interval := 1 to: n.
	[ externalArray := FFIExternalArray externalNewType: #int size: n.
	interval do: [ :each | externalArray at: each put: n - each + 1 ].
	self
		assert:
			(externalArray getHandle readArrayOf: #int until: [ :each :i | i > n ])
		equals: interval reversed ]
		ensure: [ externalArray free ]! !

!FFIExternalArrayTest methodsFor: 'tests' stamp: ''!
testAt
	| externalArray |
	
	externalArray := FFIExternalArray newType: 'int' size: 10.
	self assert: externalArray size equals: 10.
	1 to: 10 do: [ :index | self assert: (externalArray at: index) equals: 0 ]
! !

!FFIExternalArrayTest methodsFor: 'tests' stamp: ''!
testAtPut
	| externalArray |
	
	externalArray := FFIExternalArray newType: 'int' size: 1.
	externalArray at: 1 put: 42.
	self assert: (externalArray at: 1) equals: 42! !

!FFIExternalArrayTest methodsFor: 'tests' stamp: ''!
testResolveType
	self assert: (FFIExternalArray resolveType: 'int') class equals: FFIInt32.
	self assert: (FFIExternalArray resolveType: 'String') class equals: FFIExternalString.
	self assert: (FFIExternalArray resolveType: 'char') class equals: FFICharacterType.
	self assert: (FFIExternalArray resolveType: 'void *') class equals: FFIVoid.
	self assert: (FFIExternalArray resolveType: 'void *') pointerArity equals: 1.
	self assert: (FFIExternalArray resolveType: FFIUInt16) class equals: FFIUInt16.
	self assert: (FFIExternalArray resolveType: String) class equals: FFIExternalString! !

!FFIExternalArrayTest methodsFor: 'tests' stamp: ''!
testExternalAtPut
	| externalArray |
	
	[	
		externalArray := FFIExternalArray externalNewType: 'int' size: 1.
		externalArray at: 1 put: 42.
		self assert: (externalArray at: 1) equals: 42 ]
	ensure: [ 
		externalArray free ]! !

!FFIExternalArrayType commentStamp: ''!
I define the type for FFIExternalArray objects.!
!FFIExternalArrayType methodsFor: 'accessing' stamp: ''!
instanceVariableName
	^ #handle! !

!FFIExternalEnumeration commentStamp: ''!
I am a deprecated class to add a backwards compatible API to FFIEnumeration.
FFIExternalEnumeration got renamed in favor of FFIEnumeration during Pharo8.0.

To see how to use myself, please check FFIEnumeration!
!FFIExternalEnumerationTest commentStamp: ''!
Tests for external enumerations!
!FFIExternalEnumerationTest methodsFor: 'tests' stamp: ''!
testCall
	| result buffer |

	self skipOnAppleARM.

	buffer := ByteArray new: 100. 
	result := self ffiTestCall: self enumClass DDD format: '%d' to: buffer.
	self assert: result equals: 4.
	self assert: (buffer first: result) asString equals: '2400'	! !

!FFIExternalEnumerationTest methodsFor: 'primitives' stamp: ''!
ffiTestCall: enumValue format: format to: buffer
	^ self 
		ffiCall: #( int sprintf ( void* buffer, String format, FFITestEnumeration enumValue ) )
		library: LibC
		fixedArgumentCount: 2! !

!FFIExternalEnumerationTest methodsFor: 'primitives' stamp: ''!
ffiTestReturn: aNumber format: format to: buffer
	^ self 
		ffiCall: #( FFITestEnumeration sprintf ( void* buffer, String format, int aNumber ) )
		library: LibC
		fixedArgumentCount: 2! !

!FFIExternalEnumerationTest methodsFor: 'accessing' stamp: ''!
enumClass
	^ FFITestEnumeration! !

!FFIExternalEnumerationTest methodsFor: 'tests' stamp: ''!
testEnumIncludes
	self assert: (self enumClass includes: #DDD).
	self deny: (self enumClass includes: #EEE)! !

!FFIExternalEnumerationTest methodsFor: 'tests' stamp: ''!
testReturn
	| result buffer |

	self skipOnAppleARM.

	buffer := ByteArray new: 100. 
	result := self ffiTestReturn: 123 format: '%d' to: buffer.
	self assert: result equals: self enumClass CCC.
	self assert: (buffer first: result value) asString equals: '123'	! !

!FFIExternalEnumerationTest methodsFor: 'tests' stamp: ''!
testNewError
	self should: [ self enumClass new ] raise: ShouldNotImplement! !

!FFIExternalEnumerationTest methodsFor: 'tests' stamp: ''!
testFromInteger
	self assert: (self enumClass fromInteger: 1) value equals: 1.
	self assert: (self enumClass fromInteger: 2) value equals: 2.
	self assert: (self enumClass fromInteger: 3) value equals: 3.
	self assert: (self enumClass fromInteger: 2400) value equals: 2400.
	self should: [ self enumClass fromInteger: 234 ] raise: Error! !

!FFIExternalEnumerationTest methodsFor: 'tests' stamp: ''!
testEnumIdents
	self assert: self enumClass AAA value equals: 1.
	self assert: self enumClass DDD value equals: 2400! !

!FFIExternalEnumerationType commentStamp: ''!
I define the type for FFIExternalEnumeration objects.!
!FFIExternalEnumerationType methodsFor: '*ThreadedFFI-UFFI-Overrides' stamp: ''!
tfExternalType

	^ self representationType tfExternalType! !

!FFIExternalEnumerationType methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ self objectClass fromInteger: (aHandle 
		perform: self externalType atomicSelector 
		with: index)! !

!FFIExternalEnumerationType methodsFor: 'accessing' stamp: ''!
representationType: anObject
	representationType := anObject! !

!FFIExternalEnumerationType methodsFor: 'emitting code' stamp: ''!
readEnumAt: byteOffset
	^ String streamContents:[ :stream|
		stream 
			nextPutAll:'^';
			print: self objectClass;
			nextPutAll:' fromInteger: (handle ', self externalType atomicSelector,' ';
			print: byteOffset;
			nextPutAll:')' ].
! !

!FFIExternalEnumerationType methodsFor: 'emitting code' stamp: ''!
emitReturn: aBuilder resultTempVar: resultVar context: aContext
	"| tmpResult |
	
	tmpResult := <returnValue>.
	^ self objectClass itemAt: tmpResult
	"

	^ aBuilder 
		"keep invoke result into the tmpResult var"
		storeTemp: resultVar;
		"return := self objectClass itemAt: tmpResult"
		pushLiteralVariable: self objectClass binding;
		pushTemp: resultVar;
		send: #fromInteger:;
		returnTop	! !

!FFIExternalEnumerationType methodsFor: 'emitting code' stamp: ''!
offsetReadEnumAt: offsetVariableName
	^ String streamContents:[ :stream|
		stream 
			nextPutAll:'^';
			print: self objectClass;
			nextPutAll:' fromInteger: (handle ', self externalType atomicSelector,' ';
			nextPutAll: offsetVariableName;
			nextPutAll:')' ].
! !

!FFIExternalEnumerationType methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle 
		perform: (self externalType atomicSelector,#put:) asSymbol
		with: index
		with: value getHandle! !

!FFIExternalEnumerationType methodsFor: 'emitting code' stamp: ''!
offsetReadFieldAt: offsetVariableName
	"Return a string defining the accessor to an entity of the receiver type starting at the given byte offset. "
	self isPointer ifTrue: [ ^ super offsetReadFieldAt: offsetVariableName ].
	^ self offsetReadEnumAt: offsetVariableName! !

!FFIExternalEnumerationType methodsFor: 'accessing' stamp: ''!
representationType
	^ representationType! !

!FFIExternalEnumerationType methodsFor: 'emitting code' stamp: ''!
writeFieldAt: byteOffset with: valueName
	^ String streamContents: [ :stream | 
		stream << 'handle ' << self externalType atomicSelector << ' ' << byteOffset asString << ' put: anObject value' ]! !

!FFIExternalEnumerationType methodsFor: 'emitting code' stamp: ''!
readFieldAt: byteOffset
	"Return a string defining the accessor to an entity of the receiver type starting at the given byte offset. "
	self isPointer ifTrue: [ ^ super readFieldAt: byteOffset ].
	^ self readEnumAt: byteOffset! !

!FFIExternalEnumerationType methodsFor: 'accessing' stamp: ''!
callbackReturnOn: callbackContext for: anObject
    ^ super callbackReturnOn: callbackContext for: anObject value! !

!FFIExternalEnumerationType methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ self representationType externalTypeAlignment! !

!FFIExternalEnumerationType methodsFor: 'emitting code' stamp: ''!
offsetWriteFieldAt: offsetVariableName with: valueName
	^ String streamContents: [ :stream | 
		stream << 'handle ' << self externalType atomicSelector << ' ' << offsetVariableName << ' put: anObject value' ]! !

!FFIExternalEnumerationType methodsFor: 'accessing' stamp: ''!
externalTypeSize 
	^ self representationType externalTypeSize! !

!FFIExternalEnumerationType methodsFor: 'accessing' stamp: ''!
instanceVariableName
	^ #value! !

!FFIExternalEnumerationType methodsFor: 'accessing' stamp: ''!
externalType
	^ self representationType externalType! !

!FFIExternalEnumerationType class methodsFor: 'private' stamp: ''!
naturalPointerArity
	^ 0! !

!FFIExternalEnumerationType class methodsFor: 'instance creation' stamp: ''!
objectClass: aClass representationType: anIntegerType
	^ self new
		objectClass: aClass;
		representationType: anIntegerType! !

!FFIExternalEnumerationType class methodsFor: 'instance creation' stamp: ''!
objectClass: aClass
	^ self objectClass: aClass representationType: FFIUInt32 new! !

!FFIExternalObject commentStamp: ''!
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:

FFIExternalObject subclass: #MyExternalObject

newObj := MyExternalObject new.

MyExternalObject class>>newObject
 ^ self ffiCall: #(MyExternalObject someExternalFunction() )

here, assume that someExternalFunction() returns some handle (or pointer) to some opaque external structure. By putting ==FFIExternalObject== 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 ffiCall: #( void compare ( self , MyExternalObject anotherExternalObject))

The main advantage of using ==FFIExternalObject== 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.

IMPORTANT: My instances represent a pointer in the C heap. If you need to represent an opaque type (https://en.wikipedia.org/wiki/Opaque_data_type), check ==FFIOpaqueObject==.!
!FFIExternalObject class methodsFor: 'instance creation' stamp: ''!
null
	^ self new! !

!FFIExternalObject class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator
	^ FFIExternalObjectType objectClass: self! !

!FFIExternalObjectForTest commentStamp: ''!
An external method used by FFI tests!
!FFIExternalObjectForTest methodsFor: 'tests' stamp: ''!
testMethod

	"Nothing, for test only"! !

!FFIExternalObjectType commentStamp: ''!
I'm en external object type (a pointer)!
!FFIExternalObjectType methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	pointerArity := self class naturalPointerArity! !

!FFIExternalObjectType methodsFor: 'accessing' stamp: ''!
instanceVariableName
	^ #handle! !

!FFIExternalPackedStructure commentStamp: ''!
I am a deprecated class to add a backwards compatible API to FFIPackedStructure.
FFIExternalPackedStructure got renamed in favor of FFIPackedStructure during Pharo8.0.

To see how to use myself, please check FFIPackedStructure!
!FFIExternalPackedStructureTest commentStamp: ''!
Tests for FFIExternalPackedStructure!
!FFIExternalPackedStructureTest methodsFor: 'tests' stamp: ''!
testStructAccess
	| struct |
	struct := FFITestPackedStructure new.
	self deny: struct getHandle class equals: ExternalAddress.
	self deny: struct isNull.

	struct byte: 10.
	struct short: -20.
	struct long: 100.
	struct float: 1.0.
	struct double: 2.0.
	self flag: #pharoTodo.	"This is not yet implemented"
	"struct int64: 123456789101112."

	self assert: struct byte equals: 10.
	self assert: struct short equals: -20.
	self assert: struct long equals: 100.
	self assert: struct float equals: 1.0.
	self assert: struct double equals: 2.0
	"self assert: (struct int64 = 123456789101112).	"! !

!FFIExternalPackedStructureTest methodsFor: 'tests' stamp: ''!
testExternallyAllocatedStructure
	| struct struct2 |
	
	struct := FFITestPackedStructure externalNew.
	self assert: struct getHandle isExternalAddress.

	self deny: struct isNull.
	[	struct byte: 10.
		struct short: -20.
		struct long: 100.
		struct float: 1.0.
		struct double: 2.0.
		"struct int64: 123456789101112."
	
		struct2 := FFITestPackedStructure fromHandle: struct getHandle.
	
		self assert: struct2 byte equals: 10.
		self assert: struct2 short equals: -20.	
		self assert: struct2 long equals: 100.	
		self assert: struct2 float equals: 1.0.	
		self assert: struct2 double equals: 2.0.	
		self flag: #pharoTodo. "This is not yet implemented"
		"self assert: (struct2 int64 = 123456789101112)."	 ] 
	ensure: [ struct free ]! !

!FFIExternalReference commentStamp: ''!
I represent a reference to some variable (a pointer, a memory space, an obscure structure) living in the C heap. 
I'm abstract, my children keep the real references.

A referenced type is  some variable that lives in the C heap and is seen in Pharo as an external  reference (an ==ExternalAddress==) .!
!FFIExternalReference methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self setHandle: self createDefaultHandle.! !

!FFIExternalReference methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
handle
	^ self getHandle! !

!FFIExternalReference methodsFor: 'external resource management' stamp: ''!
autoRelease
	"Note, subclasses should implement #resourceData
	and #finalizeResourceData: on class side"
	FFIExternalResourceManager addResource: self! !

!FFIExternalReference methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream 
		nextPut: $(;
		print: handle;
		nextPut: $)! !

!FFIExternalReference methodsFor: 'initialization' stamp: ''!
createDefaultHandle
	^ ExternalAddress new! !

!FFIExternalReference methodsFor: 'external resource management' stamp: ''!
resourceData
	^ self getHandle! !

!FFIExternalReference methodsFor: '*UnifiedFFI-Legacy' stamp: ''!
handle: anObject
	self setHandle: anObject! !

!FFIExternalReference class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: handle
	handle isNull ifTrue: [ ^ self ].
	handle free.
	handle beNull! !

!FFIExternalReference class methodsFor: 'instance creation' stamp: ''!
fromHandle: aHandle
	^ self new setHandle: aHandle! !

!FFIExternalReference class methodsFor: 'instance creation' stamp: ''!
newPointer
	^ self fromHandle: ExternalAddress newPointer! !

!FFIExternalReferenceType commentStamp: ''!
I'm a abstract type for "referenced" types. 
See ==FFIExternalReference== for details.!
!FFIExternalReferenceType methodsFor: 'emitting code' stamp: ''!
emitReturnArgument: builder context: aContext
	self loader 
		emitPointerArityUnpack: builder
		type: self
		context: aContext
		objectClass: self objectClass
		instVarName: self instanceVariableName! !

!FFIExternalReferenceType methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType pointer! !

!FFIExternalReferenceType methodsFor: 'comparing' stamp: ''!
= anExternalReferenceType

	^ (anExternalReferenceType isKindOf: self species)
		and: [ objectClass = anExternalReferenceType objectClass ]! !

!FFIExternalReferenceType methodsFor: 'comparing' stamp: ''!
hash

	^ objectClass hash! !

!FFIExternalReferenceType methodsFor: 'emitting code' stamp: ''!
basicEmitArgument: aBuilder context: aContext inCallout: aCallout
 	self loader
		emitArgument: aBuilder 
		context: aContext 
		objectClass: self objectClass	
		instVarName: self instanceVariableName! !

!FFIExternalReferenceType methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ self objectClass fromHandle: (aHandle pointerAt: index)! !

!FFIExternalReferenceType methodsFor: 'emitting code' stamp: ''!
basicEmitArgument: aBuilder context: aContext
 	self loader
		emitArgument: aBuilder 
		context: aContext 
		objectClass: self objectClass	
		instVarName: self instanceVariableName! !

!FFIExternalReferenceType methodsFor: 'accessing' stamp: ''!
defaultReturnOnError

	^ ExternalAddress null! !

!FFIExternalReferenceType methodsFor: 'emitting code' stamp: ''!
emitReturn: aBuilder resultTempVar: resultVar context: aContext
	^ aBuilder 
		addTemp: #tmpResult;
		"keep invoke result into the tmpResult var"
		storeTemp: resultVar;
		popTop;
		"return := self objectClass basicNew"
		pushLiteralVariable: self objectClass binding;
		send: #basicNew;
		storeTemp: #tmpResult;
		popTop;
		"return instVarAt: (index of argName) put: result"
		pushTemp: #tmpResult;
		pushLiteral: (self objectClass 
			instVarIndexFor: self instanceVariableName 
			ifAbsent: [ self error: 'No handle instVar' ]);
		pushTemp: resultVar;
		send: #instVarAt:put:;
		popTop;
		pushTemp: #tmpResult;
		returnTop	! !

!FFIExternalReferenceType methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	value getHandle isExternalAddress 
		ifFalse: [ self error: 'value needs to be an ExternalAddress' ].
	^ aHandle pointerAt: index put: value getHandle
! !

!FFIExternalReferenceType methodsFor: 'initialization' stamp: ''!
prepareAsSelfFromCalloutDeclaration! !

!FFIExternalReferenceType methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream << self className << '(' << objectClass name << ')'! !

!FFIExternalReferenceType methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ #integer! !

!FFIExternalReferenceType methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	"this is always a pointer"
	^ self pointerAlignment! !

!FFIExternalReferenceType methodsFor: 'testing' stamp: ''!
needsArityUnpacking
	"Referenced types by default can be ''unpacked'' if it needs also to be rolled"
	^ self needsArityPacking! !

!FFIExternalReferenceType methodsFor: 'accessing' stamp: ''!
objectClass
	^ objectClass! !

!FFIExternalReferenceType methodsFor: 'accessing' stamp: ''!
externalTypeSize
	"this is always a pointer"
	^ self pointerSize! !

!FFIExternalReferenceType methodsFor: 'accessing' stamp: ''!
instanceVariableName
	^ self subclassResponsibility! !

!FFIExternalReferenceType methodsFor: 'accessing' stamp: ''!
objectClass: aClass
	objectClass := aClass! !

!FFIExternalReferenceType class methodsFor: 'private' stamp: ''!
naturalPointerArity
	^ 1! !

!FFIExternalReferenceType class methodsFor: 'accessing' stamp: ''!
externalType
	^ ExternalType void asPointerType! !

!FFIExternalReferenceType class methodsFor: 'instance creation' stamp: ''!
objectClass: aClass
	^ self new objectClass: aClass! !

!FFIExternalResourceExecutor commentStamp: ''!
I am responsible for finalizing an external resource, registered using external resource manager.

When object, registered as external resource being garbage collected,
I tell 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:
     FFIExternalResourceManager 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" 
	FFIExternalResourceManager addResource: self 
"Another form of use is: 
	FFIExternalResourceManager 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. 
!
!FFIExternalResourceExecutor methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	session := Smalltalk session! !

!FFIExternalResourceExecutor methodsFor: 'initialization' stamp: ''!
resourceClass: aResourceClass data: aData
	resourceClass := aResourceClass.
	data := aData! !

!FFIExternalResourceExecutor methodsFor: 'finalization' stamp: ''!
finalize 
	session = Smalltalk session ifFalse: [ ^ self ].		
	resourceClass finalizeResourceData: data! !

!FFIExternalResourceManager commentStamp: ''!
I am responsible for managing a finalization of external resources.

When object, registered as external resource being garbage collected,
i telling an object's class to finalize it's associated data (by passing an object,
received from #resourceData message sent to an object at registration time).

I automatically keep tracking for session change (image save/boot), and ignore finalization of resources of old sessions (since they are not longer valid,
and cannot be freed since session changed).

Like that, a user of FFIExternalResourceManager don't need to implement a session checking logic, and need only to:

a) register object as external resource:
     FFIExternalResourceManager 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" 
	FFIExternalResourceManager addResource: self 
"Another form of use is: 
	FFIExternalResourceManager 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. 

!
!FFIExternalResourceManager methodsFor: 'external resource management' stamp: ''!
addResource: anObject executor: anExecutor
	registry add: anObject executor: anExecutor! !

!FFIExternalResourceManager methodsFor: 'external resource management' stamp: ''!
addResource: anObject
	^ self addResource: anObject data: anObject resourceData
! !

!FFIExternalResourceManager methodsFor: 'external resource management' stamp: ''!
addResource: anObject data: resourceData
	registry 
		add: anObject 
		executor: (FFIExternalResourceExecutor new 
			resourceClass: anObject class
			data: resourceData)! !

!FFIExternalResourceManager methodsFor: 'initialization' stamp: ''!
initialize 
	registry := WeakRegistry new! !

!FFIExternalResourceManager class methodsFor: 'resource management' stamp: ''!
addResource: anObject executor: anExecutor
	self uniqueInstance addResource: anObject executor: anExecutor! !

!FFIExternalResourceManager class methodsFor: 'resource management' stamp: ''!
addResource: anObject 
	self uniqueInstance addResource: anObject ! !

!FFIExternalResourceManager class methodsFor: 'resource management' stamp: ''!
addResource: anObject data: aData
	self uniqueInstance addResource: anObject data: aData! !

!FFIExternalResourceManager class methodsFor: 'accessing' stamp: ''!
uniqueInstance 
	^ uniqueInstance ifNil: [ uniqueInstance  := super new ]! !

!FFIExternalResourceManager class methodsFor: 'class initialization' stamp: ''!
reset
	uniqueInstance := nil! !

!FFIExternalString commentStamp: ''!
String type.
Represented as char* on C side.!
!FFIExternalString methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFDerivedType string! !

!FFIExternalString methodsFor: 'callbacks' stamp: ''!
extractFromCallbackOn: aFFICallbackArgumentReader 
	
	aFFICallbackArgumentReader extractExternalString: self! !

!FFIExternalString methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	| data |
	data := ExternalData 
		fromHandle: (aHandle pointerAt: index) 
		type: ExternalType string.
	data isNull ifTrue: [ ^ nil ].
	^ data fromCString! !

!FFIExternalString methodsFor: 'accessing' stamp: ''!
defaultReturnOnError

	^ ''! !

!FFIExternalString methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	self error: 'Not sure I want to do this.'! !

!FFIExternalString methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ #integer! !

!FFIExternalString methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ self pointerSize "i am live and die as a pointer (a char*)"! !

!FFIExternalString class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ self pointerSize! !

!FFIExternalString class methodsFor: 'accessing' stamp: ''!
externalType
	^ ExternalType string! !

!FFIExternalStructure commentStamp: ''!
I am a deprecated class to add a backwards compatible API to FFIStructure.
FFIExternalStructure got renamed in favor of FFIStructure during Pharo8.0.

To see how to use myself, please check FFIStructure!
!FFIExternalStructureFieldParser commentStamp: ''!
I'm a parser for fields in FFIExternalStructure!
!FFIExternalStructureFieldParser methodsFor: 'parsing' stamp: ''!
parseFields: fields structure: structClass
	| stream type fieldName generator anonFieldCount |
	
	stream := fields readStream.
	generator := FFICallout new requestor: structClass.
	anonFieldCount := 0.

	fieldSpec := FFIExternalStructureFieldSpec new.
	[ stream atEnd ] whileFalse: [ | arity |
		type := generator resolveType: stream next. 
		arity := 0.
		[stream peek beginsWith: '*' ] whileTrue: [
			stream next do: [ :eachStar | 
				eachStar = $* 
					ifTrue: [ arity := arity + 1 ]
					ifFalse: [ self error: 'I cannot parse structure.' ] ] ].
		type pointerArity: arity.
		stream peek ~= #';' ifTrue: [
			fieldName := stream next.
			fieldName isSymbol ifFalse: [ self error: 'invalid field name'].
			(fieldSpec fieldNames includes: fieldName) ifTrue: [ 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." 

			fieldSpec addField: fieldName type: type. 
		] ifFalse: [
			self flag: 'ToDO: Remove the ordered dictionary.'.
			fieldSpec addField: anonFieldCount type: type. 
			anonFieldCount := anonFieldCount + 1.
		].
		stream peek == #';' ifTrue: [ stream next ]].
	
	^ self fieldSpec
! !

!FFIExternalStructureFieldParser methodsFor: 'accessing' stamp: ''!
fieldSpec 
	^ fieldSpec! !

!FFIExternalStructureFieldParserTest commentStamp: ''!
Tests for FFIExternalStructureFieldParser!
!FFIExternalStructureFieldParserTest methodsFor: 'factory' stamp: ''!
newParser   
	^ FFIExternalStructureFieldParser new! !

!FFIExternalStructureFieldParserTest methodsFor: 'tests' stamp: ''!
testParseFieldsStructure
	| fieldSpec |
	
	fieldSpec := self newParser   
		parseFields: FFITestStructure fields 
		structure: FFITestStructure.
		
	self assert: fieldSpec notNil. 
	self assert: fieldSpec fieldNames equals: #(byte short long float double int64 ulong size_t).
	self assert: (fieldSpec typeFor: #byte) class equals: FFIUInt8.
	self assert: (fieldSpec typeFor: #short) class equals: FFIInt16.
	self assert: (fieldSpec typeFor: #long) class equals: FFILong.
	self assert: (fieldSpec typeFor: #float) class equals: FFIFloat32.
	self assert: (fieldSpec typeFor: #double) class equals: FFIFloat64.
	self assert: (fieldSpec typeFor: #int64) class equals: FFIInt64.
	self assert: (fieldSpec typeFor: #ulong) class equals: FFIULong.
	self assert: (fieldSpec typeFor: #size_t) class equals: FFISizeT
	! !

!FFIExternalStructureFieldParserTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	architecture := FFIArchitecture forCurrentArchitecture! !

!FFIExternalStructureFieldSpec commentStamp: ''!
I'm a field spec for fields in FFIExternalStructure!
!FFIExternalStructureFieldSpec methodsFor: 'compiling' stamp: ''!
compileSpec 
	"This will compile the structure spec into something ExternalStructure can understand"
	^ fields values 
		inject: WordArray new
		into: [ :all :each | all, (each externalTypeWithArity embeddedSpecWithSize: each externalTypeSize) ]! !

!FFIExternalStructureFieldSpec methodsFor: 'accessing' stamp: ''!
addField: aName type: anExternalType
	fields at: aName put: anExternalType! !

!FFIExternalStructureFieldSpec methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	fields := OrderedDictionary new! !

!FFIExternalStructureFieldSpec methodsFor: 'accessing' stamp: ''!
types
	^ fields values! !

!FFIExternalStructureFieldSpec methodsFor: 'accessing' stamp: ''!
fieldsAndTypesDo: aBlock
	^ fields keysAndValuesDo: aBlock! !

!FFIExternalStructureFieldSpec methodsFor: '*ThreadedFFI' stamp: ''!
fields
	^ fields! !

!FFIExternalStructureFieldSpec methodsFor: 'accessing' stamp: ''!
fieldNames
	^ fields keys! !

!FFIExternalStructureFieldSpec methodsFor: 'accessing' stamp: ''!
typeFor: aString 
	^ fields at: aString! !

!FFIExternalStructureFlatLayout commentStamp: ''!
I represent a flattened layout of a structure. I am use to compute whether a structure is passed in registers or not, and which registers are used for passing the structure.!
!FFIExternalStructureFlatLayout methodsFor: 'building' stamp: ''!
addMemoryFieldSize: fieldSize alignment: fieldAlignment
	self addField: #memory size: fieldSize alignment: fieldAlignment! !

!FFIExternalStructureFlatLayout methodsFor: 'accessing' stamp: ''!
floatRegisterCount: anObject
	^ floatRegisterCount := anObject! !

!FFIExternalStructureFlatLayout methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	fields := OrderedCollection new.
	size := 0.
	alignment := 1.
	integerRegisterCount := 0.
	floatRegisterCount := 0.! !

!FFIExternalStructureFlatLayout methodsFor: 'system v abi' stamp: ''!
combineSysVAMD64RegisterClass: leftClass with: rightClass

	"AMD64 SystemV eightbyte classification reduction"

	"Same class."
	leftClass == rightClass ifTrue: [ ^ leftClass ].

	"If one has no class, use the other."
	leftClass ifNil: [ ^ rightClass ].
	rightClass ifNil: [ ^ leftClass ].

	"If one is memory, the result is memory."
	( leftClass == #memory or: [ rightClass == #memory ] ) ifTrue: [ ^ #memory ].	

	"If one is integer, the result is integer."
	( leftClass == #integer or: [ rightClass == #integer ] ) ifTrue: [ ^ #integer ].

	"TODO: If one of the classes is X87, X87UP, COMPLEX_X87 class, #memory is used as class."	

	"Otherwise, use the SSE class"
	^ #float! !

!FFIExternalStructureFlatLayout methodsFor: 'building' stamp: ''!
countRegisters
	fields do: [ :field |
		field registerClass == #integer ifTrue: [ integerRegisterCount := integerRegisterCount + 1 ].
		field registerClass == #float ifTrue: [ floatRegisterCount := floatRegisterCount + 1 ].
	]! !

!FFIExternalStructureFlatLayout methodsFor: 'system v abi' stamp: ''!
reduce: sourceFields inGroupsOfSize: groupSize with: aBlock
	| reduced nextGroupOffset |
	reduced := nil.
	nextGroupOffset := groupSize.
	sourceFields do: [ :field |
		field offset < nextGroupOffset ifFalse: [ 
			reduced ifNotNil: [
				fields add: reduced.
				reduced := nil
			].
			nextGroupOffset := (field offset // groupSize + 1) * groupSize
		].
	
		reduced ifNotNil: [
			reduced
				registerClass: (aBlock value: reduced value: field);
				size: (reduced size alignedTo: field alignment) + field size;
				alignment: (reduced alignment max: field alignment)
		] ifNil: [
			reduced := field copy
		]
	].

	reduced ifNotNil: [ fields add: reduced ]
! !

!FFIExternalStructureFlatLayout methodsFor: 'system v abi' stamp: ''!
sysVAMD64PostProcess
	| result |
	result := self class new.
	result
		size: size;
		alignment: alignment.
	result reduce: fields inGroupsOfSize: 8 with: [ :left :right |
		self combineSysVAMD64RegisterClass: left registerClass with: right registerClass
	].

	"Post merger cleanup"
	
	"If there is any memory field, pass the whole structure in memory."
	result fields detect: [ :field | field registerClass == #memory] ifFound: [
		result fields: { FFIExternalStructureFlatLayoutField new
			registerClass: #memory;
			offset: 0;
			size: size;
			alignment: alignment;
			yourself
		}.
		^ result
	].

	result countRegisters.
	^ result
	! !

!FFIExternalStructureFlatLayout methodsFor: 'accessing' stamp: ''!
size: anObject
	size := anObject! !

!FFIExternalStructureFlatLayout methodsFor: 'accessing' stamp: ''!
floatRegisterCount
	^ floatRegisterCount! !

!FFIExternalStructureFlatLayout methodsFor: 'accessing' stamp: ''!
fields
	^ fields! !

!FFIExternalStructureFlatLayout methodsFor: 'accessing' stamp: ''!
alignment: anObject
	alignment := anObject! !

!FFIExternalStructureFlatLayout methodsFor: 'accessing' stamp: ''!
size
	^ size! !

!FFIExternalStructureFlatLayout methodsFor: 'building' stamp: ''!
addField: registerClass size: fieldSize alignment: fieldAlignment
	self alignTo: fieldSize.
	fields add: (FFIExternalStructureFlatLayoutField new
			registerClass: registerClass;
			size: fieldSize;
			alignment: fieldAlignment;
			offset: size
			yourself
		).
	size := size + fieldSize.! !

!FFIExternalStructureFlatLayout methodsFor: 'accessing' stamp: ''!
integerRegisterCount
	^ integerRegisterCount! !

!FFIExternalStructureFlatLayout methodsFor: 'testing' stamp: ''!
isPassedInMemory
	^ fields size = 1 and: [ fields first registerClass == #memory ]! !

!FFIExternalStructureFlatLayout methodsFor: 'accessing' stamp: ''!
alignment
	^ alignment! !

!FFIExternalStructureFlatLayout methodsFor: 'building' stamp: ''!
alignTo: anAlignment
	size := size alignedTo: anAlignment.
	alignment := alignment max: anAlignment.! !

!FFIExternalStructureFlatLayout methodsFor: 'accessing' stamp: ''!
fields: anObject
	fields := anObject! !

!FFIExternalStructureFlatLayout methodsFor: 'accessing' stamp: ''!
integerRegisterCount: anObject
	integerRegisterCount := anObject! !

!FFIExternalStructureFlatLayoutField commentStamp: ''!
I represent a field in a structure layout. I am used for computing which fields present in a structure are passed in registers, and which are not.!
!FFIExternalStructureFlatLayoutField methodsFor: 'accessing' stamp: ''!
registerClass
	^ registerClass! !

!FFIExternalStructureFlatLayoutField methodsFor: 'accessing' stamp: ''!
offset: anObject
	offset := anObject! !

!FFIExternalStructureFlatLayoutField methodsFor: 'accessing' stamp: ''!
registerClass: anObject
	registerClass := anObject! !

!FFIExternalStructureFlatLayoutField methodsFor: 'accessing' stamp: ''!
size
	^ size! !

!FFIExternalStructureFlatLayoutField methodsFor: 'accessing' stamp: ''!
size: anObject
	size := anObject! !

!FFIExternalStructureFlatLayoutField methodsFor: 'accessing' stamp: ''!
alignment: anObject
	alignment := anObject! !

!FFIExternalStructureFlatLayoutField methodsFor: 'accessing' stamp: ''!
offset
	^ offset! !

!FFIExternalStructureFlatLayoutField methodsFor: 'accessing' stamp: ''!
alignment
	^ alignment! !

!FFIExternalStructurePlatformTest commentStamp: ''!
Tests for external structures on platform!
!FFIExternalStructurePlatformTest methodsFor: 'private - testing' stamp: ''!
is64bit
	^ Smalltalk vm is64bit ! !

!FFIExternalStructurePlatformTest methodsFor: 'tests' stamp: ''!
testStructureHasCorrectSize32bits
	self is32bit ifFalse: [ ^ self skip ].
	
	self 
		assert: (FFIExternalType sizeOf: FFITestStructureByPlatform) 
		equals: 8! !

!FFIExternalStructurePlatformTest methodsFor: 'tests' stamp: ''!
testStructureHasCorrectSize64bits
	self is64bit ifFalse: [ ^ self skip ].
	
	self 
		assert: (FFIExternalType sizeOf: FFITestStructureByPlatform) 
		equals: 16! !

!FFIExternalStructurePlatformTest methodsFor: 'tests' stamp: ''!
testStructureHasCorrectOffsets32bits
	self is32bit ifFalse: [ ^ self skip ].
	
	FFITestStructureByPlatform compiledSpec. "Ensure fields are initialized"
	self assert: (FFITestStructureByPlatform classPool at: #OFFSET_LONG) equals: 1.
	self assert: (FFITestStructureByPlatform classPool at: #OFFSET_POINTER) equals: 5! !

!FFIExternalStructurePlatformTest methodsFor: 'private - testing' stamp: ''!
is32bit
	^ Smalltalk vm is32bit 
		! !

!FFIExternalStructurePlatformTest methodsFor: 'tests' stamp: ''!
testStructureHasCorrectOffsets64bits
	self is64bit ifFalse: [ ^ self skip ].
	
	FFITestStructureByPlatform compiledSpec. "Ensure fields are initialized"
	self assert: (FFITestStructureByPlatform classPool at: #OFFSET_LONG) equals: 1.
	self assert: (FFITestStructureByPlatform classPool at: #OFFSET_POINTER) equals: 9! !

!FFIExternalStructureReferenceHandle commentStamp: ''!
I'm an offset accessor for nested structures. 
The idea is that I remap the accessing to an offseted byte array, thus providing access to the inner structure without copying the values. 
This is useful when you have nested structures, something like this: 

struct StructNested {
	int value;
}

struct StructA {
	int one;
	struct StructNested theNest;
}

then you can do something like this: 

s := StructA new.
s theNest value: 42. 

And the value will be set in the StructA instance, not in a copy as before. !
!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
referenceStructAt: byteOffset length: length
	^ handle referenceStructAt: startOffset + byteOffset length: length! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
doubleAt: byteOffset put: value
	^ handle doubleAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
signedByteAt: byteOffset
	^ handle signedByteAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
signedLongAt: byteOffset put: value
	^ handle signedLongAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
structAt: byteOffset length: length
	^ handle structAt: startOffset + byteOffset length: length! !

!FFIExternalStructureReferenceHandle methodsFor: 'initialization' stamp: ''!
initializeHandle: aHandle offset: aNumber
	self initialize.
	handle := aHandle.
	startOffset := aNumber - 1 "starting offset is zero based"! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
unsignedLongLongAt: byteOffset put: value
	^ handle unsignedLongLongAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
voidAt: byteOffset put: value
	^ handle voidAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
structAt: byteOffset put: value length: length
	"Store a structure of the given length starting at the indicated byte offset."
	1 to: length do:[:i|
		self unsignedByteAt: byteOffset+i-1 put: (value unsignedByteAt: i)].
	^value	! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
unsignedCharAt: byteOffset put: value
	^ handle unsignedCharAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
signedShortAt: byteOffset
	^ handle signedShortAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
unsignedLongLongAt: byteOffset
	^ handle unsignedLongLongAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
signedByteAt: byteOffset put: value
	^ handle signedByteAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
unsignedByteAt: byteOffset
	^ handle unsignedByteAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
signedCharAt: byteOffset put: value
	^ handle signedCharAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
getHandle
	^ handle! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
platformLongAt: byteOffset put: value
	^ handle platformLongAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
pointerAt: byteOffset put: value
	^ handle pointerAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	^ handle replaceFrom: start + startOffset to: stop + startOffset with: replacement startingAt: repStart! !

!FFIExternalStructureReferenceHandle methodsFor: 'converting' stamp: ''!
asExternalPointer
	"Convert the receiver assuming that it describes a pointer to an object."
	^(ExternalAddress new)
		basicAt: 1 put: (self byteAt: startOffset + 1);
		basicAt: 2 put: (self byteAt: startOffset + 2);
		basicAt: 3 put: (self byteAt: startOffset + 3);
		basicAt: 4 put: (self byteAt: startOffset + 4);
	yourself! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
doubleAt: byteOffset
	^ handle doubleAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'copying' stamp: ''!
copyFrom: start to: stop
	^ handle copyFrom: start + startOffset to: stop + startOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
unsignedCharAt: byteOffset
	^ handle unsignedCharAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
integerAt: byteOffset size: nBytes signed: aBoolean
	^ handle integerAt: startOffset + byteOffset size: nBytes signed: aBoolean! !

!FFIExternalStructureReferenceHandle methodsFor: 'testing' stamp: ''!
isExternalAddress
	^ handle isExternalAddress! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
signedLongAt: byteOffset
	^ handle signedLongAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
signedLongLongAt: byteOffset put: value
	^ handle signedLongLongAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
signedShortAt: byteOffset put: value
	^ handle signedShortAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'compatibility' stamp: ''!
free
	"this is referenced so this operation does not has sense. 
	 Included to provide polymophism"! !

!FFIExternalStructureReferenceHandle methodsFor: '*FreeType' stamp: ''!
asExternalAddress
	^ handle + startOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
platformUnsignedLongAt: byteOffset put: value
	^ handle platformUnsignedLongAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
platformUnsignedLongAt: byteOffset
	^ handle platformUnsignedLongAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
platformSizeTAt: byteOffset put: aValue 
	^ handle platformSizeTAt: startOffset + byteOffset put: aValue! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
signedLongLongAt: byteOffset
	^ handle signedLongLongAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
booleanAt: byteOffset
	^ handle booleanAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
voidAt: byteOffset
	^ handle voidAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
signedCharAt: byteOffset
	^ handle signedCharAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
unsignedByteAt: byteOffset put: value
	^ handle unsignedByteAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
floatAt: byteOffset
	^ handle floatAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
pointerAt: byteOffset
	^ handle pointerAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
booleanAt: byteOffset put: value
	^ handle booleanAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
unsignedShortAt: byteOffset
	^ handle unsignedShortAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'testing' stamp: ''!
isNull
	self flag: #pharoTodo. "This is probably wrong"
	^ handle isNull! !

!FFIExternalStructureReferenceHandle methodsFor: 'compatibility' stamp: ''!
beNull
	"this is referenced so this operation does not has sense. 
	 Included to provide polymophism"! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
unsignedShortAt: byteOffset put: value
	^ handle unsignedShortAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
unsignedLongAt: byteOffset put: value
	^ handle unsignedLongAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
floatAt: byteOffset put: value
	^ handle floatAt: startOffset + byteOffset put: value! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
integerAt: byteOffset put: value size: nBytes signed: aBoolean
	^ handle integerAt: startOffset + byteOffset put: value size: nBytes signed: aBoolean! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
platformLongAt: byteOffset
	^ handle platformLongAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
platformSizeTAt: byteOffset 
	^ handle platformSizeTAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle methodsFor: 'accessing' stamp: ''!
unsignedLongAt: byteOffset
	^ handle unsignedLongAt: startOffset + byteOffset! !

!FFIExternalStructureReferenceHandle class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #handle:offset:'! !

!FFIExternalStructureReferenceHandle class methodsFor: 'instance creation' stamp: ''!
handle: aHandle offset: aNumber
	^ self basicNew 
		initializeHandle: aHandle offset: aNumber;
		yourself! !

!FFIExternalStructureTest commentStamp: ''!
Tests for external structures!
!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testFlatStructureLayoutSysVAMD64PostProcess
	| flatLayout |
	flatLayout := FFITestStructureSmallFloatStructure flatStructureLayout sysVAMD64PostProcess.
	self assert: flatLayout size equals: 16.
	self assert: flatLayout alignment equals: 4.
	self assert: flatLayout fields size equals: 2.
	self assert: flatLayout fields first registerClass equals: #float.
	self assert: flatLayout fields second registerClass equals: #float.
	self assert: flatLayout integerRegisterCount equals: 0.
	self assert: flatLayout floatRegisterCount equals: 2! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testNestedStructureWithArray
	| nestedStruct |	

	nestedStruct := FFITestNestingStructureWithArray new.
	self deny: nestedStruct nested getHandle isExternalAddress.
	self 
		assert: nestedStruct nested char5 asArray
		equals: {Character null. Character null. Character null. Character null. Character null }.
	self 
		assert: nestedStruct nested byte10 asArray 
		equals: #(0 0 0 0 0 0 0 0 0 0).
		
	nestedStruct nested char5: (FFITypeArray fromHandle: 'ABCDE' asByteArray).
	nestedStruct nested byte10: (FFITypeArray fromHandle: #[1 2 3 4 5 6 7 8 9 0]).
	self 
		assert: nestedStruct nested char5 asArray 
		equals: {$A. $B. $C. $D. $E}.
	self 
		assert: nestedStruct nested byte10 asArray 
		equals: #(1 2 3 4 5 6 7 8 9 0)! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testNestedStructure
	| s1 |

	s1 := FFITestNestingStructure new.
	s1 nested byte: 42.
	s1 nested float: 4.0.
	s1 nested double: 42.0.
	s1 nested size_t: 23.

	s1 nested long: -123456.
	s1 nested ulong: 123456.

	self assert: s1 nested byte equals: 42.	
	self assert: s1 nested float equals: 4.0.	
	self assert: s1 nested double equals: 42.0.	
	self assert: s1 nested long equals: -123456.
	self assert: s1 nested ulong equals: 123456.
	self assert: s1 nested size_t equals: 23
! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testStructWithPointerAccess
	| s1 s2 |	

	s1 := FFITestPointerStructure new.
	self assert: s1 getHandle isExternalAddress not.
	self assert: s1 pointer isNull.
	self assert: s1 nestedPointer isNull.
	
	s2 := FFITestStructure externalNew.
	s2 long: 42.
	s1 nestedPointer: s2.
	self deny: s1 nestedPointer isNull.
	self assert: s1 nestedPointer long equals: 42! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testStructAccess
	| struct |
	struct := FFITestStructure new.
	self deny: struct getHandle class equals: ExternalAddress.
	self deny: struct isNull.

	struct byte: 10.
	struct short: -20.
	struct long: 100.
	struct float: 1.0.
	struct double: 2.0.
	self flag: #pharoTodo.	"This is not yet implemented"
	"struct int64: 123456789101112."

	self assert: struct byte equals: 10.
	self assert: struct short equals: -20.
	self assert: struct long equals: 100.
	self assert: struct float equals: 1.0.
	self assert: struct double equals: 2.0
	"self assert: struct int64 equals: 123456789101112.	"! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testExternallyAllocatedNestedStructure
	| s1 |
	
	s1 := FFITestNestingStructure externalNew.
	self assert: s1 getHandle isExternalAddress.
	s1 nested byte: 42.	
	self assert: s1 nested byte equals: 42! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testFlatStructureLayout
	| flatLayout |
	flatLayout := FFITestStructureSmallFloatStructure flatStructureLayout.
	self assert: flatLayout size equals: 16.
	self assert: flatLayout alignment equals: 4.
	self assert: flatLayout fields size equals: 4.
	self assert: flatLayout fields first registerClass equals: #float.
	self assert: flatLayout fields second registerClass equals: #float.
	self assert: flatLayout fields third registerClass equals: #float.
	self assert: flatLayout fields fourth registerClass equals: #float
! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testExternalStructWithArray
	| structWithArrays structureSize |	

	structureSize := FFITestArrayStructure structureSize.
	structWithArrays := FFITestArrayStructure externalNew autoRelease.
	self assert: structWithArrays getHandle isExternalAddress.
	structWithArrays getHandle 
		replaceFrom: 1 to: structureSize with: (ByteArray new: structureSize). 
		
	structWithArrays char5: (FFITypeArray fromHandle: 'ABCDE' asByteArray).
	structWithArrays byte10: (FFITypeArray fromHandle: #[1 2 3 4 5 6 7 8 9 0]).
	self 
		assert: structWithArrays char5 asArray 
		equals: {$A. $B. $C. $D. $E}.
	self 
		assert: structWithArrays byte10 asArray 
		equals: #(1 2 3 4 5 6 7 8 9 0)! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testExternallyAllocatedStructure
	| struct struct2 |
	
	struct := FFITestStructure externalNew.
	self assert: struct getHandle isExternalAddress.

	self deny: struct isNull.
	[	struct byte: 10.
		struct short: -20.
		struct long: 100.
		struct float: 1.0.
		struct double: 2.0.
		"struct int64: 123456789101112."
	
		struct2 := FFITestStructure fromHandle: struct getHandle.
	
		self assert: struct2 byte equals: 10.
		self assert: struct2 short equals: -20.	
		self assert: struct2 long equals: 100.	
		self assert: struct2 float equals: 1.0.	
		self assert: struct2 double equals: 2.0.	
		self flag: #pharoTodo. "This is not yet implemented"
		"self assert: struct2 int64 equals: 123456789101112."	 ] 
	ensure: [  struct free ]! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testStructWithArray
	| structWithArrays |	

	structWithArrays := FFITestArrayStructure new.
	self deny: structWithArrays getHandle isExternalAddress.
	self 
		assert: structWithArrays char5 asArray
		equals: {Character null. Character null. Character null. Character null. Character null }.
	self 
		assert: structWithArrays byte10 asArray 
		equals: #(0 0 0 0 0 0 0 0 0 0).
		
	structWithArrays char5: (FFITypeArray fromHandle: 'ABCDE' asByteArray).
	structWithArrays byte10: (FFITypeArray fromHandle: #[1 2 3 4 5 6 7 8 9 0]).
	self 
		assert: structWithArrays char5 asArray 
		equals: {$A. $B. $C. $D. $E}.
	self 
		assert: structWithArrays byte10 asArray 
		equals: #(1 2 3 4 5 6 7 8 9 0)
	
	
! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testFlatStructureLayout2
	| flatLayout |
	flatLayout := FFITestStructureSmallIntFloatStructure flatStructureLayout.
	self assert: flatLayout size equals: 16.
	self assert: flatLayout alignment equals: 4.
	self assert: flatLayout fields size equals: 4.
	self assert: flatLayout fields first registerClass equals: #float.
	self assert: flatLayout fields second registerClass equals: #integer.
	self assert: flatLayout fields third registerClass equals: #float.
	self assert: flatLayout fields fourth registerClass equals: #float
! !

!FFIExternalStructureTest methodsFor: 'tests' stamp: ''!
testFlatStructureLayoutSysVAMD64PostProcess2
	| flatLayout |
	flatLayout := FFITestStructureSmallIntFloatStructure flatStructureLayout sysVAMD64PostProcess.
	self assert: flatLayout size equals: 16.
	self assert: flatLayout alignment equals: 4.
	self assert: flatLayout fields size equals: 2.
	self assert: flatLayout fields first registerClass equals: #integer.
	self assert: flatLayout fields second registerClass equals: #float.
	self assert: flatLayout integerRegisterCount equals: 1.
	self assert: flatLayout floatRegisterCount equals: 1
	! !

!FFIExternalStructureType commentStamp: ''!
I'm a type to handle structures. !
!FFIExternalStructureType methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	^ TFStructType
		forClass: objectClass
		withMembers:
			(objectClass fieldSpec fields values
				flatCollect: [ :aField | aField tfExternalTypeForStructureWithArity ])! !

!FFIExternalStructureType methodsFor: 'initialization' stamp: ''!
initializeObjectClass: aClass
	objectClass := aClass.
	self initialize! !

!FFIExternalStructureType methodsFor: 'extracting' stamp: ''!
extractFromCallbackOn: aCallbackArgumentReader 

	aCallbackArgumentReader extractStructType: self! !

!FFIExternalStructureType methodsFor: 'stack parameter classification' stamp: ''!
emitFlatStructureLayoutFieldInto: flatStructureLayout
	objectClass emitFlatStructureLayoutFieldInto: flatStructureLayout! !

!FFIExternalStructureType methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index

	^ self objectClass fromHandle: (aHandle referenceStructAt: index length: self externalTypeSize)
! !

!FFIExternalStructureType methodsFor: 'accessing' stamp: ''!
callbackValueFor: anAlien at: index
	"This is the value for a callback.
	since the callbacks comunicates as Aliens, I receive the struct, but with an Alien 
	reference (which does not work for UFFI structires, they needs to be ExternalAddress)"
	self isPointer ifTrue: [ ^ anAlien pointerAt: index ].
	^ self objectClass fromHandle: anAlien asExternalAddress! !

!FFIExternalStructureType methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalTypeWithArity

	self pointerArity = 1
		  ifTrue: [ 
			  ^ TFPointerToStructType new
				  targetClass: objectClass;
				  yourself ].
			
	^ self pointerArity > 1
		  ifTrue: [ TFBasicType pointer ]
		  ifFalse: [ self tfExternalType ]! !

!FFIExternalStructureType methodsFor: 'initialization' stamp: ''!
prepareAsSelfFromCalloutDeclaration
	"self starts with pointer arity 1 (regardless how is declared later)"
	self pointerArity: 1! !

!FFIExternalStructureType methodsFor: 'emitting code' stamp: ''!
offsetReadFieldAt: offsetVariableName
	"Return a string defining the accessor to an entity of the receiver type starting at the given byte offset. "
	self isPointer ifTrue: [ ^ super offsetReadFieldAt: offsetVariableName ].
	^ self offsetReadReferenceAt: offsetVariableName! !

!FFIExternalStructureType methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ LibC memCopy: value getHandle to: aHandle + (index - 1) size: self externalTypeSize! !

!FFIExternalStructureType methodsFor: 'emitting code' stamp: ''!
readReferenceAt: byteOffset
	^ '^ {1} fromHandle: (handle referenceStructAt: {2} length: {1} byteSize)'
		format: { 
			self objectClass name.
			byteOffset }! !

!FFIExternalStructureType methodsFor: 'emitting code' stamp: ''!
readFieldAt: byteOffset
	"Return a string defining the accessor to an entity of the receiver type starting at the given byte offset. "
	self isPointer ifTrue: [ ^ super readFieldAt: byteOffset ].
	^ self readReferenceAt: byteOffset! !

!FFIExternalStructureType methodsFor: 'callbacks' stamp: ''!
callbackReturnOn: callbackContext for: anObject

	^ self error: 'Cannot return an external structure by copy. It is not yet implemented'! !

!FFIExternalStructureType methodsFor: 'testing' stamp: ''!
isExternalStructure

	^ true! !

!FFIExternalStructureType methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ #structure! !

!FFIExternalStructureType methodsFor: 'accessing' stamp: ''!
externalTypeAlignment 
	^ self objectClass structureAlignment! !

!FFIExternalStructureType methodsFor: 'accessing' stamp: ''!
objectClass
	^ objectClass! !

!FFIExternalStructureType methodsFor: 'accessing' stamp: ''!
externalTypeSize 
	^ self objectClass structureSize! !

!FFIExternalStructureType methodsFor: 'emitting code' stamp: ''!
offsetReadReferenceAt: offsetVariableName
	^ '^ {1} fromHandle: (handle referenceStructAt: {2} length: {1} byteSize)'
		format: { self objectClass name. offsetVariableName }! !

!FFIExternalStructureType methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType structTypeNamed: self objectClass name! !

!FFIExternalStructureType class methodsFor: 'private' stamp: ''!
naturalPointerArity
	^ 1! !

!FFIExternalStructureType class methodsFor: 'instance creation' stamp: ''!
objectClass: aClass
	^ self basicNew 
		initializeObjectClass: aClass;
		yourself! !

!FFIExternalType commentStamp: ''!
I'm an abstract class to implement FFI external types (types who will later be mapped to something understandable for a C library)!
!FFIExternalType methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
		
	^ self subclassResponsibility! !

!FFIExternalType methodsFor: 'testing' stamp: ''!
isPointer
	^ self pointerArity > 0! !

!FFIExternalType methodsFor: 'accessing - array' stamp: ''!
handle: aHandle at: index put: value
	self isPointer ifTrue: [ ^ aHandle pointerAt: index put: value ].
	^ self basicHandle: aHandle at: index put: value! !

!FFIExternalType methodsFor: 'stack parameter classification' stamp: ''!
emitFlatStructureLayoutFieldInto: flatStructureLayout
	flatStructureLayout addField: self stackParameterClass size: self typeSize alignment: self typeAlignment! !

!FFIExternalType methodsFor: 'emitting code' stamp: ''!
basicEmitArgument: aBuilder context: aContext inCallout: aCallout
	self loader
		emitArgument: aBuilder 
		context: aContext! !

!FFIExternalType methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	self subclassResponsibility! !

!FFIExternalType methodsFor: 'callbacks' stamp: ''!
callbackValueFor: anObject at: index
	"This is the value for a callback. 
	 The callback parameters came from an external adress who can be treated as a ByteArray, so it 
	 works the same as an FFIExternalArray (at least for now)"
	^ self handle: anObject at: index! !

!FFIExternalType methodsFor: 'testing' stamp: ''!
isExternalType
	^ true! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
defaultReturnOnError
	"In case of a callback error, the image will try to show a debugger and that will most ot the 
	 time crashes the VM (because it will break the process and will let a C function waiting and 
	 and in incorrect state). 
	 To prevent that, we use #on:fork:return: (look for senders) and, while forking the error to 
	 allow user to debug his error, we also return a 'default' value, that may be also wrong."

	^ self subclassResponsibility! !

!FFIExternalType methodsFor: 'emitting code' stamp: ''!
emitReturn: aBuilder resultTempVar: resultVar context: aContext 
	^ aBuilder returnTop	! !

!FFIExternalType methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	self subclassResponsibility! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
externalTypeWithArity
	^ self pointerArity > 0 
		ifTrue: [ self externalType asPointerType ]
		ifFalse: [ self externalType ]! !

!FFIExternalType methodsFor: 'emitting code' stamp: ''!
offsetReadFieldAt: offsetVariableName
	^ self externalTypeWithArity offsetReadFieldAt: offsetVariableName! !

!FFIExternalType methodsFor: 'accessing - array' stamp: ''!
handle: aHandle at: index 
	self isPointer ifTrue: [ ^ aHandle pointerAt: index ].
	^ self basicHandle: aHandle at: index! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
loader: aLoader
	loader := aLoader! !

!FFIExternalType methodsFor: 'callbacks' stamp: ''!
callbackReturnOn: callbackContext for: anObject
	"By default, I answer an integral return (not a float)"
	^ callbackContext wordResult: anObject! !

!FFIExternalType methodsFor: 'testing' stamp: ''!
isExternalStructure

	^ false! !

!FFIExternalType methodsFor: 'instance creation' stamp: ''!
newBuffer
	"as its counterpart on class-side (newBuffer), this method get a memory segment that can be translated to C function as reference (to take later it's value). 
	For example:  

  ffi_getDimensions__width: width height: height
    ^ #( (void getDimensions( double *width, double *height) )

  testMain
        | widthBuffer heightBuffer width height |
        widthBuffer := (FFIExternalType resolveType: #double) newBuffer.
        heightBuffer := (FFIExternalType resolveType: #double) newBuffer.
        ffi_getDimensions__width: widthBuffer height: heightBuffer.
        width := widthBuffer doubleAt: 1.
        height := heightBuffer doubleAt: 1.
        Transcript crShow: width; tab; show: height.
==> 2.0 3.0
	"
	^ self class newBuffer! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
pointerArity: additionalArity
	pointerArity := pointerArity + additionalArity.! !

!FFIExternalType methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	pointerArity timesRepeat: [ aStream nextPut: $* ]! !

!FFIExternalType methodsFor: 'emitting code' stamp: ''!
readFieldAt: byteOffset
	^ self externalTypeWithArity readFieldAt: byteOffset! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
typeAlignment
	"Answer a number of bytes, which receiver type takes in memory"
	self pointerArity > 0 ifTrue: [ ^ self pointerAlignment ].
	^ self externalTypeAlignment! !

!FFIExternalType methodsFor: 'testing' stamp: ''!
validateAfterParse: typeAndArityTuple
	"After parse an argument or return, some times I need to validate arity is correct. 
	 This usually is ok, but since UFFI has types who do not have sense if they are not referenced as 
	 pointer (check my overrides), I act as an ''after parse'' validation."
! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
loader
	^ loader! !

!FFIExternalType methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalTypeForStructure

	^ {self tfExternalType}! !

!FFIExternalType methodsFor: 'emitting code' stamp: ''!
emitReturnArgument: builder context: aContext
	"Some times functions need some post-process (for example, to unpack pointers). 
	 This call MUST exit with result value in top of the stack (otherwise it will 
	interfere with emitReturn:resultTempVar:context:"
	self loader 
		emitPointerArityUnpack: builder 
		type: self
		context: aContext! !

!FFIExternalType methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext inCallout: aCallout
	self basicEmitArgument: aBuilder context: aContext inCallout: aCallout.
	self needsArityPacking 
		ifTrue: [ self  emitPointerArityRoll: aBuilder context: aContext ]! !

!FFIExternalType methodsFor: 'testing' stamp: ''!
needsArityPacking
	"Regular types needs to be ''rolled'' if they are passed as pointers to its calling functions. 
	 For example, executing consecutivelly this (simplified) two functions: 
	 [[[
	 	time := self ffiCall: #(time_t time(time_t* t) ). ""this will answer a long.""
	 	self ffiCall: #(tm* localtime(time_t* time) ) ""this requires a pointer to time."" 
	 ]]]
	 This mechanism allows UnifiedFFI to perform the roll of this pointers for you (it performs 
	 the equivallent of ==&time== in C). 
	
	 For packing/unpacking logic, arity needs to be bigger than inherent type arity. 
	 Means that if I have a type that is naturally a pointer (for example an ExternalAddress, who 
	 is a 'void*'), it will have a natural arity of 1, then I pack if arity is bigger. 
	 Other cases could need to be rolled when pointer arity is diffrent."
	^ self pointerArity > self class naturalPointerArity! !

!FFIExternalType methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	pointerArity := 0! !

!FFIExternalType methodsFor: 'emitting code' stamp: ''!
emitReturn: aBuilder resultTempVar: resultVar context: aContext inCallout: aCallout
	
	^ self emitReturn: aBuilder resultTempVar: resultVar context: aContext ! !

!FFIExternalType methodsFor: 'emitting code' stamp: ''!
emitPointerArityRoll: aBuilder context: aContext
	self loader 
		emitPointerArityPack: aBuilder 
		context: aContext 
		arity: self pointerArity! !

!FFIExternalType methodsFor: 'testing' stamp: ''!
isVoid
	^ false! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
pointerSize
	^ self class pointerSize! !

!FFIExternalType methodsFor: 'testing' stamp: ''!
isFloatType

	^ false! !

!FFIExternalType methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalTypeWithArity
	
	^ self pointerArity > 0 
		ifTrue: [ TFBasicType pointer ]
		ifFalse: [ self tfExternalType ]! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
pointerAlignment
	^ self class pointerAlignment! !

!FFIExternalType methodsFor: 'stack parameter classification' stamp: ''!
stackParameterClass
	^ self isPointer ifTrue: [ #integer ] ifFalse: [ self stackValueParameterClass ]! !

!FFIExternalType methodsFor: 'emitting code' stamp: ''!
writeFieldAt: byteOffset with: valueName
	^ self externalTypeWithArity 
		writeFieldAt: byteOffset 
		with: valueName! !

!FFIExternalType methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalTypeForStructureWithArity
	
	^ self pointerArity > 0 
		ifTrue: [ {TFBasicType pointer} ]
		ifFalse: [ self tfExternalTypeForStructure ]! !

!FFIExternalType methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	self subclassResponsibility! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ self class externalTypeAlignment! !

!FFIExternalType methodsFor: 'testing' stamp: ''!
needsArityUnpacking
	"Simple types do not need ''unpacking'' because they can not used as buffers (to receive values 
	 from C functions).
	 For instance, in case you have functions with the form:
	 [[[ 
		self ffiCall: #(void getPoint( double *x, double *y)) 
	 ]]]
	 you cannot use instances of Float (since they are immutable in Pharo)... in that case you will
	 need to use an FFIExternalValueHolder."
	^ false! !

!FFIExternalType methodsFor: 'emitting code' stamp: ''!
offsetWriteFieldAt: offsetVariableName with: valueName
	^ self externalTypeWithArity 
		offsetWriteFieldAt: offsetVariableName 
		with: valueName! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ self class externalTypeSize! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
typeSize
	"Answer a number of bytes, which receiver type takes in memory"
	self pointerArity > 0 ifTrue: [ ^ self pointerSize ].
	^ self externalTypeSize! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
externalType
	^ self class externalType! !

!FFIExternalType methodsFor: 'accessing' stamp: ''!
pointerArity
	^ pointerArity! !

!FFIExternalType class methodsFor: 'private' stamp: ''!
naturalPointerArity
	"Indicates 'natural' pointer artity of type (atomic types are zero while any kind of 
	 pointer/reference/etc. is one)"
	^ 0! !

!FFIExternalType class methodsFor: 'accessing' stamp: ''!
pointerSize
	"Answer a number of bytes, which takes a pointer value"
	^ Smalltalk vm wordSize! !

!FFIExternalType class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator
	^ self new! !

!FFIExternalType class methodsFor: 'public' stamp: ''!
resolveType: aTypeName
	^ FFICallout new resolveType: aTypeName
	! !

!FFIExternalType class methodsFor: 'accessing' stamp: ''!
pointerAlignment
	^ OSPlatform current ffiPointerAlignment! !

!FFIExternalType class methodsFor: 'public' stamp: ''!
sizeOf: aTypeName
	^ (self resolveType: aTypeName) typeSize! !

!FFIExternalType class methodsFor: 'instance creation' stamp: ''!
newBuffer
	"This method is used to provide convencience buffer accessor to types. 
	 This is useful when you need to pass a reference to an argument to take the value later. 
	 For example: 
	
  void getDimensions(double *width, double *height) {
    *width = 2.0;
    *height = 3.0;
  }
  int main() {
    double w, h;
    get_dimensions( &w, &h);
    printf(""%f %f"", w, h)
  }
==> 2.0 3.0

would have an FFI declaration...

  ffi_getDimensions__width: width height: height
    ^ #( (void getDimensions( double *width, double *height) )

  testMain
        | widthBuffer heightBuffer width height |
        widthBuffer := FFIFloat64 newBuffer.
        heightBuffer := FFIFloat64 newBuffer.
        ffi_getDimensions__width: widthBuffer height: heightBuffer.
        width := widthBuffer doubleAt: 1.
        height := heightBuffer doubleAt: 1.
        Transcript crShow: width; tab; show: height.
==> 2.0 3.0
	"
	^ ByteArray new: self externalTypeSize! !

!FFIExternalType class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	"Answer a number of bytes, which takes a value of given type
	(not a pointer to it)"
	self subclassResponsibility 	! !

!FFIExternalType class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	"Answer a number of bytes, which takes a value of given type
	(not a pointer to it)"
	self subclassResponsibility 	! !

!FFIExternalType class methodsFor: 'accessing' stamp: ''!
externalType
	^ self subclassResponsibility! !

!FFIExternalUnion commentStamp: ''!
I am a deprecated class to add a backwards compatible API to FFIUnion.
FFIExternalUnion got renamed in favor of FFIUnion during Pharo8.0.

To see how to use myself, please check FFIUnion!
!FFIExternalUnionTest commentStamp: ''!
Tests for external unions!
!FFIExternalUnionTest methodsFor: 'tests' stamp: ''!
testUnionAccess
	| union |
	union := FFITestUnion new.
	self deny: union getHandle class equals: ExternalAddress.
	self deny: union isNull.

	union long: 16r04030201.
	self assert: union byte equals: 16r01.
	self assert: union short equals: 16r0201.
	self assert: union long equals: 16r04030201.
	self assert: union float ~= 0.
	self assert: union double ~= 0.

	self flag: #pharoTodo	"This is not yet implemented"
	"struct int64: 123456789101112."! !

!FFIExternalValueHolder commentStamp: ''!
I am a generic meta class for creating a subclasses, which instances will hold a single value of specified C type.
To create a new class for some concrete C type you need to declare an anonnymous class and indicate the type you want to use:

[ [ [ 
floatHolderClass := FFIExternalValueHolder ofType: 'float'
 ] ] ]

Then you can use  given class(es) as a value holders for type you specified:

[ [ [ 
 float := floatHolderClass new.

float value:  1.5
float value
 ] ] ]

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 ==FFIExternalValueHolder== is done for. To define a binding to this function you can declare a subclass named SomeType
 
and then use it in function signature:

[ [ [ 
getFoo: value
  ^ self ffiCall: #(void getFoo ( SomeType *  value ))
] ] ]

and call it like: 

[ [ [ 
var := SomeType new.
self getFoo: var.

var value  "will read the value" 
]]]!
!FFIExternalValueHolder methodsFor: 'accessing' stamp: ''!
value: anObject 
	self type 
		handle: data 
		at: 1
		put: anObject! !

!FFIExternalValueHolder methodsFor: 'initialization' stamp: ''!
initialize
	data := ByteArray new: self type typeSize.
	super initialize! !

!FFIExternalValueHolder methodsFor: 'accessing' stamp: ''!
value 
	^ self type 
		handle: data 
		at: 1
		! !

!FFIExternalValueHolder methodsFor: 'converting' stamp: ''!
tfPointerAddress
	
	^ data tfPointerAddress! !

!FFIExternalValueHolder methodsFor: 'accessing' stamp: ''!
type 
	^ self class type! !

!FFIExternalValueHolder class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator
	^ FFIExternalValueHolderType 
		objectClass: self 
		representationType: self type! !

!FFIExternalValueHolder class methodsFor: 'accessing' stamp: ''!
typeDecl
	"Define the type for this value holder. 
	 It can be anything that FFIExternalType class>>resolveType: can resolve. 
	 If you need something different, you can override #representationType"
	^ self subclassResponsibility! !

!FFIExternalValueHolder class methodsFor: 'class factory' stamp: ''!
ofType: aTypeName
	^ FFIExternalValueHolder newAnonymousSubclass 
		type: (FFIExternalType resolveType: aTypeName)! !

!FFIExternalValueHolder class methodsFor: 'private' stamp: ''!
type: aType 
	type := aType! !

!FFIExternalValueHolder class methodsFor: 'class initialization' stamp: ''!
reset
	type := nil! !

!FFIExternalValueHolder class methodsFor: 'private' stamp: ''!
type
	^ type ifNil: [ type := FFIExternalType resolveType: self typeDecl ]! !

!FFIExternalValueHolderTest commentStamp: ''!
Tests for FFIExternalValueHolder!
!FFIExternalValueHolderTest methodsFor: 'tests' stamp: ''!
testCreateValueHolder
	| valueHolderClass object |
	
	valueHolderClass := FFIExternalValueHolder ofType: 'int'.
	object := valueHolderClass new.
	
	self assert: object type class equals: FFIInt32.
	self assert: object value equals: 0.
	
	object value: 42.
	self assert: object value equals: 42
! !

!FFIExternalValueHolderTest methodsFor: 'tests' stamp: ''!
testCall
	| object time |
	
	TIME_T_PTR := FFIExternalValueHolder ofType: 'uint32'.
	object := TIME_T_PTR new.

	time := self getTime: object.
	self assert: time equals: object value! !

!FFIExternalValueHolderTest methodsFor: 'primitives' stamp: ''!
getTime: t
     ^self ffiCall: #(long time(TIME_T_PTR t)) module: LibC
             ! !

!FFIExternalValueHolderType commentStamp: ''!
I'm an external value holder type (see ==FFIExternalValueHolder==  comment).!
!FFIExternalValueHolderType methodsFor: 'accessing' stamp: ''!
representationType: anObject
	representationType := anObject! !

!FFIExternalValueHolderType methodsFor: 'accessing' stamp: ''!
representationType
	^ representationType! !

!FFIExternalValueHolderType methodsFor: 'emitting code' stamp: ''!
offsetReadFieldAt: offsetVariableName
	^ self notYetImplemented! !

!FFIExternalValueHolderType methodsFor: 'emitting code' stamp: ''!
writeFieldAt: byteOffset with: valueName
	^ self notYetImplemented! !

!FFIExternalValueHolderType methodsFor: 'emitting code' stamp: ''!
readFieldAt: byteOffset	
	^ self notYetImplemented! !

!FFIExternalValueHolderType methodsFor: 'emitting code' stamp: ''!
offsetWriteFieldAt: offsetVariableName with: valueName
	^ self notYetImplemented! !

!FFIExternalValueHolderType methodsFor: 'accessing' stamp: ''!
instanceVariableName
	^ #data! !

!FFIExternalValueHolderType methodsFor: 'accessing' stamp: ''!
externalType
	^ self representationType externalType asPointerType! !

!FFIExternalValueHolderType class methodsFor: 'instance creation' stamp: ''!
objectClass: aClass representationType: anIntegerType
	^ self new
		objectClass: aClass;
		representationType: anIntegerType! !

!FFIExternalValueHolderType class methodsFor: 'instance creation' stamp: ''!
objectClass: aClass
	^ self objectClass: aClass representationType: FFIUInt32 new! !

!FFIFloat128 commentStamp: ''!
I'm a 128bits (cuadruple precision) float. 
It is usually not used, but some compiler modes support it (__float128 in gcc)

THIS IS NOT YET SUPPORTED!
!FFIFloat128 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	self error: 'Not yet supported!!'! !

!FFIFloat128 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	self error: 'Not yet supported!!'! !

!FFIFloat128 class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ 16! !

!FFIFloat128 class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 16! !

!FFIFloat128 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ self error: '128bits floats are not currently supported!!'! !

!FFIFloat16 commentStamp: ''!
I'm a 16bits (half precision) float. 
It is usually not used, but ARM processors support them (__fp16 in gcc). 

THIS IS NOT YET SUPPORTED!
!FFIFloat16 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	self error: 'Not yet supported!!'! !

!FFIFloat16 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	self error: 'Not yet supported!!'! !

!FFIFloat16 class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ 2! !

!FFIFloat16 class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 2! !

!FFIFloat16 class methodsFor: 'accessing' stamp: ''!
externalType
	self error: '16bits floats are not currently supported!!'! !

!FFIFloat32 commentStamp: ''!
Float type. 
Represented as float in C side.!
!FFIFloat32 methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType

	^ TFBasicType float! !

!FFIFloat32 methodsFor: 'callbacks' stamp: ''!
extractFromCallbackOn: aCallbackArgumentReader 
	
	aCallbackArgumentReader extractFloat! !

!FFIFloat32 methodsFor: 'emitting code' stamp: ''!
emitPointerArityRoll: aBuilder context: aContext
	self loader 
		emitPointerArityPack: aBuilder 
		context: aContext 
		arity: self pointerArity
		selector: #packAsFloatToArity:! !

!FFIFloat32 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle floatAt: index! !

!FFIFloat32 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle floatAt: index put: value! !

!FFIFloat32 methodsFor: 'accessing' stamp: ''!
callbackReturnOn: callbackContext for: aFloat
	^ FFIArchitecture forCurrentArchitecture returnSingleFloatsAsDoubles
		ifTrue: [ callbackContext floatResult: aFloat ]
		ifFalse: [ callbackContext singleFloatResult: aFloat ]! !

!FFIFloat32 class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ 4! !

!FFIFloat32 class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 4! !

!FFIFloat32 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType float! !

!FFIFloat64 commentStamp: ''!
Float type. 
Represented as double in C side.!
!FFIFloat64 methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType double! !

!FFIFloat64 methodsFor: 'callbacks' stamp: ''!
extractFromCallbackOn: aCallbackArgumentReader 
	
	aCallbackArgumentReader extractDouble! !

!FFIFloat64 methodsFor: 'emitting code' stamp: ''!
emitPointerArityRoll: aBuilder context: aContext
	self loader 
		emitPointerArityPack: aBuilder 
		context: aContext 
		arity: self pointerArity
		selector: #packAsDoubleToArity:! !

!FFIFloat64 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle doubleAt: index! !

!FFIFloat64 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle doubleAt: index put: value! !

!FFIFloat64 class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ OSPlatform current ffiFloat64Alignment! !

!FFIFloat64 class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 8! !

!FFIFloat64 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType double! !

!FFIFloatType commentStamp: ''!
A generic (abstract) float type.!
!FFIFloatType methodsFor: 'testing' stamp: ''!
isFloatType
	
	^ true! !

!FFIFloatType methodsFor: 'accessing' stamp: ''!
defaultReturnOnError

	^ 0.0! !

!FFIFloatType methodsFor: 'accessing' stamp: ''!
callbackReturnOn: callbackContext for: aFloat
	^ callbackContext floatResult: aFloat! !

!FFIFloatType methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ #float! !

!FFIFunctionArgument commentStamp: ''!
I am an abstract class representing a call-out argument, having a value and a type.
See my subclasses for the concrete kind of arguments.!
!FFIFunctionArgument methodsFor: 'resolution' stamp: ''!
emitReturnArgument: anIRBuilder context: aContext

	self resolvedType
		emitReturnArgument: anIRBuilder
		context: aContext! !

!FFIFunctionArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: anIRBuilder context: aContext inCallout: aCallout

	self resolvedType emitArgument: anIRBuilder context: aContext inCallout: aCallout! !

!FFIFunctionArgument methodsFor: 'resolution' stamp: ''!
resolveUsing: aResolver

	self subclassResponsibility! !

!FFIFunctionArgument methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalTypeWithArity
	
	^ self resolvedType tfExternalTypeWithArity! !

!FFIFunctionArgument methodsFor: 'accessing' stamp: ''!
type: anObject
	type := anObject! !

!FFIFunctionArgument methodsFor: 'accessing' stamp: ''!
defaultReturnOnError

	^ self resolvedType defaultReturnOnError! !

!FFIFunctionArgument methodsFor: 'accessing' stamp: ''!
externalTypeWithArity
	
	^ self resolvedType externalTypeWithArity! !

!FFIFunctionArgument methodsFor: 'accessing' stamp: ''!
resolvedType
	
	^ resolvedType! !

!FFIFunctionArgument methodsFor: 'resolution' stamp: ''!
asOldArraySpec

	self subclassResponsibility! !

!FFIFunctionArgument methodsFor: 'accessing' stamp: ''!
loader
	
	^ loader! !

!FFIFunctionArgument methodsFor: 'accessing' stamp: ''!
type
	
	^ type! !

!FFIFunctionArgumentLoader commentStamp: ''!
I'm an abstract class to implement the pushing strategy for method arguments. 
My children define different pushing strategies for the valid types or argument (usually an atomic type object, and external object or a "self" instruction)!
!FFIFunctionArgumentLoader methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext inCallout: aCallout
	
	self emitArgument: aBuilder context: aContext! !

!FFIFunctionArgumentLoader methodsFor: 'private - emitting code' stamp: ''!
emitArgumentVariableAccesingPart: aBuilder context: aContext objectClass: objectClass instVarName: aName
	"Emit access to calling variable (changes depending on the type)."
	self subclassResponsibility! !

!FFIFunctionArgumentLoader methodsFor: 'emitting code' stamp: ''!
emitPointerArityPack: aBuilder context: aContext arity: arity
	"I take into account complex arities (like **, ***). 
	 I'm called right after argument marshaling which means it is already in top of the stack"
	^ self 
		emitPointerArityPack: aBuilder 
		context: aContext 
		arity: arity
		selector: #packToArity:! !

!FFIFunctionArgumentLoader methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext
	self subclassResponsibility! !

!FFIFunctionArgumentLoader methodsFor: 'private - emitting code' stamp: ''!
emitPointerArityUnpack: aBuilder context: aContext objectClass: objectClass instVarName: aName arity: arity
	self emitArgument: aBuilder context: aContext objectClass: objectClass instVarName: aName.
	self addUnpack: aBuilder fromArity: arity! !

!FFIFunctionArgumentLoader methodsFor: 'private' stamp: ''!
rolledPointerTempName
	self subclassResponsibility! !

!FFIFunctionArgumentLoader methodsFor: 'private - emitting code' stamp: ''!
addUnpack: aBuilder fromArity: arity
	aBuilder
		pushTemp: self rolledPointerTempName;
		pushLiteral: arity;
		send: #unpackFromArity:;
		send: #adoptAddress:;
		popTop! !

!FFIFunctionArgumentLoader methodsFor: 'private' stamp: ''!
rolledPointerTempNameFor: aString
	^ ('_ptr_', aString) asSymbol! !

!FFIFunctionArgumentLoader methodsFor: 'emitting code' stamp: ''!
emitHandleArityUnpack: aBuilder type: aType context: aContext objectClass: objectClass instVarName: aName
	"This a special kind of arity-unpacking, that works with FFIConstantHandleType"

	aType needsArityUnpacking ifFalse: [ ^ self ].
	
	"Push accessing variable (this change depending on the argument type)"
	self 
		emitArgumentVariableAccesingPart: aBuilder 
		context: aContext 
		objectClass: objectClass 
		instVarName: aName.
	"Unpack argument"
	aBuilder
		pushTemp: self rolledPointerTempName;
		pushLiteral: aType pointerArity;
		send: #unpackHandleFromArity:.
	"Send assignment"
	aBuilder send: #instVarAt:put:.
	"... and return top"
	aBuilder popTop.! !

!FFIFunctionArgumentLoader methodsFor: 'emitting code' stamp: ''!
emitPointerArityPack: aBuilder context: aContext arity: arity selector: aSelector
	"I take into account complex arities (like **, ***). 
	 I'm called right after argument marshaling which means it is already in top of the stack"
	| ptrName |
	ptrName := self rolledPointerTempName.
	aBuilder 
		addTemp: ptrName;
		pushLiteral: arity;
		send: aSelector;
		storeTemp: ptrName! !

!FFIFunctionArgumentLoader methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext objectClass: objectClass instVarName: aName
	self subclassResponsibility! !

!FFIFunctionArgumentLoader methodsFor: 'emitting code' stamp: ''!
emitPointerArityUnpack: aBuilder type: aType context: aContext objectClass: objectClass instVarName: aName
	aType needsArityUnpacking ifFalse: [ ^ self ].
	self 
		emitPointerArityUnpack: aBuilder 
		context: aContext 
		objectClass: objectClass 
		instVarName: aName
		arity: aType pointerArity! !

!FFIFunctionArgumentLoader methodsFor: 'emitting code' stamp: ''!
emitPointerArityUnpack: aBuilder type: aType context: aContext
	aType needsArityUnpacking ifFalse: [ ^ self ].
	self 
		emitPointerArityUnpack: aBuilder 
		context: aContext 
		arity: aType pointerArity! !

!FFIFunctionArgumentLoader methodsFor: 'private - emitting code' stamp: ''!
emitPointerArityUnpack: aBuilder context: aContext arity: arity
	self emitArgument: aBuilder context: aContext.
	self addUnpack: aBuilder fromArity: arity! !

!FFIFunctionParser commentStamp: ''!
I parse function specs.!
!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
requestor: aRequestor
	requestor := aRequestor! !

!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
parseArgument
	| argument argName indirectIndex typeAndPtrArity next |
	" An argument can be:

 - nil , true , false
 - a class/pool variable name
 - integer literal

 - self , with optional **
 - type name *** arg name

"
	"constant conditions"
	(stream contents size = 1 and: [ 
		stream contents first ~= #void ]) ifTrue: [ 
		^ self integerConstantArgument: stream next ].
	stream peek isArray ifTrue: [ 
		^ self parseArgumentCastedType ].

	"none of them, parse type and name"
	typeAndPtrArity := self parseType.
	argName := stream next.
	next := stream peek.
	next = $@
		ifTrue: [ 
			stream next.
			argName := argName.
			indirectIndex := self parseInt ].	
	"for sole 'void' fake argument "
	(typeAndPtrArity = #('void' 0) and: [ argName isNil ])
		ifTrue: [ ^ nil ].
	argument := self
		argName: argName
		indirectIndex: indirectIndex
		type: typeAndPtrArity first
		ptrArity: typeAndPtrArity second.

	^ argument ! !

!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
parseNamedFunction: aFunctionDefinition
	"Parse a function definition in a form of: 

	 #( returnType functionName (arguments) )
	 
	 or

	 'returnType functionName (arguments)'

	 Answer an instance of FFIFunctionSpec class"
	| argsSpec typeAndName fnName |
	
	fnSpec := FFIFunctionSpec new.
	
	self setOn: aFunctionDefinition.
	
	argsSpec := stream contents last.
	typeAndName := stream contents allButLast.
		
	"Parse return type"
	stream := typeAndName readStream.
	fnSpec returnType: self parseReturn.

	"Function name"	
	fnName := stream next.
	fnName ifNil: [ self error: 'function name expected' ].
	fnSpec functionName: fnName.

	"Function arguments"	
	stream := argsSpec readStream.
	self parseArguments.

	^ fnSpec! !

!FFIFunctionParser methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	requestor := self! !

!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
parseAnonymousFunction: aFunctionDefinition
	"Parse a function definition in a form of: 
	
	 #( returnType (arguments) )
	
	 or

	 'returnType (arguments)'

	 Answer an instance of FFIFunctionSpec class"
	| argsSpec typeAndName |
	
	fnSpec := FFIFunctionSpec new.
	
	self setOn: aFunctionDefinition.
	
	argsSpec := stream contents last.
	typeAndName := stream contents allButLast.
		
	"Parse return type"
	stream := typeAndName readStream.
	fnSpec returnType: self parseReturn.

	stream atEnd ifFalse: [ self error: 'Nothing more expected after function type'].	

	"Function arguments"	
	stream := argsSpec readStream.
	self parseArguments.

	^ fnSpec! !

!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
requestor
	^ requestor! !

!FFIFunctionParser methodsFor: 'parsing' stamp: ''!
skipSpace
	| ch |

	[ 
		ch := stream peek.
		ch ifNil: [ ^ self ].
		ch isSeparator ] 
	whileTrue: [ stream next ]! !

!FFIFunctionParser methodsFor: 'requestor callbacks' stamp: ''!
integerConstantArgument: anInteger type: aTypeName

	^ FFIConstantArgument new
		value: anInteger;
		type: (FFITypeDeclaration typeName: aTypeName arity: 0);
		yourself! !

!FFIFunctionParser methodsFor: 'requestor callbacks' stamp: ''!
argName: argName indirectIndex: anIndex type: aTypeName ptrArity: arity

	argName ifNil: [ 
		"allow nil,true,false as untyped arguments"
		"Do not accept nil, true or false followed by *s"
		arity > 0 ifTrue: [ self error: 'missing argument name' ].
		^ FFIConstantArgument new
			value: aTypeName;
			yourself ].

	^ argName isSymbol ifTrue: [ 
		FFIVariableArgument
			name: argName
			typeName: aTypeName
			arity: arity ] ifFalse: [ 
		FFIConstantArgument
			value: argName
			typeName: aTypeName
			arity: arity ]! !

!FFIFunctionParser methodsFor: 'parsing' stamp: ''!
parseReturn

	^ self returnType: self parseType.! !

!FFIFunctionParser methodsFor: 'parsing' stamp: ''!
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 ] ]

! !

!FFIFunctionParser methodsFor: 'requestor callbacks' stamp: ''!
integerConstantArgument: aValue
	^ FFIConstantArgument new
		value: aValue;
		yourself! !

!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
setStream: aReadStream
	
	stream := aReadStream! !

!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
parseCastedType

	^ (String streamContents: [ :castedType |
		stream next do: [ :typepart |
			castedType
				nextPutAll: typepart;
				space ] ]) trimBoth! !

!FFIFunctionParser methodsFor: 'parsing' stamp: ''!
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! !

!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
parseArgumentCastedType
	| castedType number |

	castedType := self parseCastedType.
	number := stream next.
	^ self integerConstantArgument: number type: castedType! !

!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
parseType

	" parse type name and optional number of asterisks, following it"

	| typeName ptrArity |

	typeName := stream next.
	typeName ifNil: [ ^ self error: 'type name expected' ].	

	"skip 'const' , which is often used but has no any use for us "
	typeName = 'const'
		ifTrue: [
			typeName := stream next.
			typeName ifNil: [ ^ self error: 'type name expected' ]
			].

	ptrArity := 0.
	[ stream atEnd not and: [ stream peek isString and: [ stream peek beginsWith: '*' ] ] ] whileTrue: [ | pointerMarker |
		pointerMarker := stream next.
		self assert: (pointerMarker allSatisfy: [ :e | e = $* ]).
		ptrArity := ptrArity + pointerMarker size ].
	
	"Answer a tuple name, arity"
	^ {typeName. ptrArity}! !

!FFIFunctionParser methodsFor: 'requestor callbacks' stamp: ''!
returnType: aType
	^ FFITypeDeclaration typeName: aType first arity: aType second! !

!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
parseArguments
"
Parse a arguments spec in a form of: 

#( type1 name1 , type2 name2 , nil, true, false , 100 )
"
	| allThings |
	allThings := stream.
	[ allThings atEnd ] whileFalse: [
		stream := (allThings upTo: #,) readStream.
		self parseArgument ifNotNil: [ :arg | 
			fnSpec addArgument: arg ] ]! !

!FFIFunctionParser methodsFor: 'accessing' stamp: ''!
setOn: aStreamSource

	| functionDeclarationArray |
	functionDeclarationArray := aStreamSource isString ifTrue: [ | node |
			node := RBParser parseExpression: '#(', aStreamSource, ')'.
			node evaluate
		] ifFalse: [ aStreamSource ].
			
	stream := functionDeclarationArray readStream.! !

!FFIFunctionParserTest commentStamp: ''!
Tests for FFIFunctionParser!
!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedFalseArgumentIsFalse
	| argument |
	
	argument := self parseArgument: 'false'.
	self assertIsFalse: argument! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedTrueArgumentHasDefinedType
	| argument |
	argument := self parseArgument: 'int64 true'.
	self assertType: argument named: 'int64'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testCastedTypedConstantIntegerHasConstantValue
	| argument |
	argument := self parseArgument: '#(#ulong) 42'.
	self assertValue: argument is: 42! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedNilArgumentHasUndefinedType
	| argument |
	
	argument := self parseArgument: 'nil'.
	self assertUndefinedTypeOf: argument! !

!FFIFunctionParserTest methodsFor: 'asserting' stamp: ''!
assertIsFalse: anArgument
	
	self assert: anArgument value equals: false! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedNullArgumentHasUndefinedType
	| argument |
	argument := self parseArgument: 'NULL'.
	self assertUndefinedTypeOf: argument! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedConstantIntegerArgumentHasUndefinedType
	| argument |
	argument := self parseArgument: '1'.
	self assertUndefinedTypeOf: argument! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedStringSelfArgumentIsString
	| argument |
	argument := self parseArgument: 'stringy ''self'''.
	self assertValue: argument is: 'self'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
parseArgument: inputToParse
	| parser |
	
	parser := self newParser
		setOn: inputToParse;
		yourself.

	^ parser parseArgument! !

!FFIFunctionParserTest methodsFor: 'factory' stamp: ''!
newParser
	^ FFIFunctionParser new! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedFloatArgumentHasDefinedType
	| argument |
	argument := self parseArgument: 'int64 1.32'.
	self assertType: argument named: 'int64'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedFloatArgumentIsFloat
	| argument |
	argument := self parseArgument: 'int 1.32'.
	self assertValue: argument is: 1.32! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedNilArgumentIsNil
	| argument |
	
	argument := self parseArgument: 'nil'.
	self assertIsNil: argument! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedConstantIntegerArgumentHasConstantValue
	| argument |
	argument := self parseArgument: '1'.
	self assertValue: argument is: 1! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedPointerVariableArgumentHasArity
	| argument |
	argument := self parseArgument: 'arbitrary* a'.
	self assertType: argument arity: 1! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testParseFunction
	 | parser args |
	
	#((int * * #'function_n$a$m$e' ( 0, nil, -10, FOO_BAR , int a, int* _b, char** c, void* * * d_))
	  ' int * * #''function_n$a$m$e'' (0, nil, -10, FOO_BAR , int a, int* _b, char** c, void* * * d_ )' ) 
	do: [:spec |
		parser := self newParser parseNamedFunction: spec.
		
		self assert: parser functionName equals: 'function_n$a$m$e'.
		self assert: parser returnType asOldArraySpec equals: #('int' 2).
		
		args := parser arguments.
		self assert: args size equals: 8.

		self assert: (args at: 1) asOldArraySpec equals: #(nil nil 0 0). 
		self assert: (args at: 2) asOldArraySpec equals: #(nil nil 'nil' 0). 
		self assert: (args at: 3) asOldArraySpec equals: #(nil nil -10 0). 
		self assert: (args at: 4) asOldArraySpec equals: #(nil nil 'FOO_BAR' 0). 
		self assert: (args at: 5) asOldArraySpec equals: #('a' nil 'int' 0). 
		self assert: (args at: 6) asOldArraySpec equals: #('_b' nil 'int' 1). 
		self assert: (args at: 7) asOldArraySpec equals: #('c' nil 'char' 2). 
		self assert: (args at: 8) asOldArraySpec equals: #('d_' nil 'void' 3 )
	].
! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedFalseArgumentHasDefinedType
	| argument |
	argument := self parseArgument: 'int64 false'.
	self assertType: argument named: 'int64'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedConstantIntegerArgumentHasConstantValue
	| argument |
	argument := self parseArgument: 'int 1'.
	self assertValue: argument is: 1! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedStringSelfArgumentHasDefinedType
	| argument |
	argument := self parseArgument: 'stringy ''self'''.
	self assertType: argument named: 'stringy'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedVariableArgumentHasType
	| argument |
	argument := self parseArgument: 'arbitrary a'.
	self assertType: argument named: 'arbitrary'! !

!FFIFunctionParserTest methodsFor: 'helpers' stamp: ''!
ffiInstVarArgument: argName generator: aGenerator
	
	^ FFIInstVarArgument new 
		argName: argName;
		yourself! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testParseFunction2
	#((int * * #'function_n$a$m$e' ( self, 0, nil, -10, true, false, " FOO_BAR , "int a, int* _b, char** c, void* * * d_))
	 " ' int * * function_n$a$m$e (0, nil, -10, FOO_BAR , int a, int* _b, char** c, void* * * d_ )'" ) 
	do: [:spec | | functionSpec1 functionSpec2 method1 method2 builder |
		functionSpec1 := self newParser parseNamedFunction: spec.
		functionSpec1 resolveUsing: resolver.
		
		functionSpec2 := self newParserWithRequestor parseNamedFunction: spec.
		
		builder := (FFIBackend current calloutAPIClass inContext: nil) newBuilder
			sender: ctx;
			yourself.
			"signature: functionSignature;
			sender: sender."
		method1 := builder generateMethodFromSpec: functionSpec1.
		method2 := builder generateMethodFromSpec: functionSpec2.
		self assert: method1 bytecode equals: method2 bytecode.
		self assert: (method1 literals allButFirst: 2) equals: (method1 literals allButFirst: 2)].
! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedPointerVariableArgumentHasName
	| argument |
	argument := self parseArgument: 'arbitrary* a'.
	self assertIsVariable: argument named: 'a'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedConstantIntegerArgumentHasDefinedType
	| argument |
	argument := self parseArgument: 'int 1'.
	self assertType: argument named: 'int'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedStringArgumentHasDefinedType
	| argument |
	argument := self parseArgument: 'stringy ''a string'''.
	self assertType: argument named: 'stringy'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedPointerVariableArgumentHasType
	| argument |
	argument := self parseArgument: 'arbitrary* a'.
	self assertType: argument named: 'arbitrary'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedTrueArgumentIsTrue
	| argument |
	argument := self parseArgument: 'true'.
	self assertIsTrue: argument! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testEmptyArgumentReturnsNil
	| argument |
	argument := self parseArgument: 'void'.
	self assert: argument isNil! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testParseAnonymousFunctionNoArguments
	| parser args |
	
	#((int * * ( void ) )
	  ' int * * ( void ) ') 
	do: [:spec |
		parser := self newParser parseAnonymousFunction: spec.
		
		self assert: parser isAnonymous.
		self assert: parser functionName isNil.
		self assert: parser returnType asOldArraySpec equals: #('int' 2).
	
		args := parser arguments.
		self assert: args size equals: 0 ]! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedDoublePointerVariableArgumentHasName
	| argument |
	argument := self parseArgument: 'arbitrary** a'.
	self assertIsVariable: argument named: 'a'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedNullArgumentIsNULL
	| argument |
	argument := self parseArgument: 'NULL'.
	self assertUndefinedTypeOf: argument! !

!FFIFunctionParserTest methodsFor: 'factory' stamp: ''!
newParserWithRequestor
	
	^ self newParser
		requestor: resolver;
		yourself! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedDoublePointerVariableArgumentHasType
	| argument |
	argument := self parseArgument: 'arbitrary** a'.
	self assertType: argument named: 'arbitrary'! !

!FFIFunctionParserTest methodsFor: 'asserting' stamp: ''!
assertValue: aLiteralArgument is: aValue
	
	self assert: aLiteralArgument value equals: aValue! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testParseAnonymousFunction
	 | parser args |
	
	#((int * * ( 0, nil, -10, FOO_BAR , int a, int* _b, char** c, void* * * d_))
	  ' int * * (0, nil, -10, FOO_BAR , int a, int* _b, char** c, void* * * d_ )' ) 
	do: [:spec |
		parser := self newParser parseAnonymousFunction: spec.
		
		self assert: parser isAnonymous.
		self assert: parser functionName isNil.
		self assert: parser returnType asOldArraySpec equals: #('int' 2).
		
		args := parser arguments.
		self assert: args size equals: 8.

		self assert: (args at: 1) asOldArraySpec equals: #(nil nil 0 0).
		self assert: (args at: 2) asOldArraySpec equals: #(nil nil 'nil' 0).
		self assert: (args at: 3) asOldArraySpec equals: #(nil nil -10 0).
		self assert: (args at: 4) asOldArraySpec equals: #(nil nil 'FOO_BAR' 0). 
		self assert: (args at: 5) asOldArraySpec equals: #('a' nil 'int' 0). 
		self assert: (args at: 6) asOldArraySpec equals: #('_b' nil 'int' 1). 
		self assert: (args at: 7) asOldArraySpec equals: #('c' nil 'char' 2). 
		self assert: (args at: 8) asOldArraySpec equals: #('d_' nil 'void' 3 ) ]! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testParseFunctionNoArguments
	| parser args |
	
	#((int * * function_name ( void ) )
	  ' int * * function_name  ( void ) ') 
	do: [:spec |
		parser := self newParser parseNamedFunction: spec.
		
		self assert: parser functionName equals: 'function_name'.
		self assert: parser returnType asOldArraySpec equals: #('int' 2).
	
		args := parser arguments.
		self assert: args size equals: 0 ]! !

!FFIFunctionParserTest methodsFor: 'asserting' stamp: ''!
assertIsNil: anArgument
	
	self assert: anArgument value equals: nil! !

!FFIFunctionParserTest methodsFor: 'asserting' stamp: ''!
assertType: anArgument named: aTypeName
	
	self assert: anArgument type name equals: aTypeName! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedConstantNegativeIntegerArgumentHasConstantValue
	| argument |
	argument := self parseArgument: '-1'.
	self assertValue: argument is: -1! !

!FFIFunctionParserTest methodsFor: 'asserting' stamp: ''!
assertIsVariable: argument named: aName

	self assert: argument name equals: aName! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedTrueArgumentIsTrue
	| argument |
	argument := self parseArgument: 'int true'.
	self assertIsTrue: argument! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedStringArgumentIsString
	| argument |
	argument := self parseArgument: 'stringy ''a stringy'''.
	self assertValue: argument is: 'a stringy'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedVariableArgumentHasName
	| argument |
	argument := self parseArgument: 'arbitrary a'.
	self assertIsVariable: argument named: 'a'! !

!FFIFunctionParserTest methodsFor: 'asserting' stamp: ''!
assertIsSelf: anArgument
	
	self assert: anArgument value equals: 'self'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedTrueArgumentHasUndefinedType
	| argument |
	argument := self parseArgument: 'true'.
	self assertUndefinedTypeOf: argument! !

!FFIFunctionParserTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	ctx := Context
		sender: nil
		receiver: FFITestObject new
		method: FFITestObject>>#b:d:
		arguments: #( 25 17 ).
		
	resolver := FFICallout new
		sender: ctx;
		yourself! !

!FFIFunctionParserTest methodsFor: 'asserting' stamp: ''!
assertType: anArgument arity: anArity
	
	self assert: anArgument type arity equals: anArity! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testParseFunctionArrayHasFunctionName

	| spec |
	spec := self newParser parseNamedFunction: #( type f ( void ) ).
	self assert: spec functionName equals: 'f'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedConstantIntegerArgumentHasZeroArity
	| argument |
	argument := self parseArgument: 'int 1'.
	self assertType: argument arity: 0! !

!FFIFunctionParserTest methodsFor: 'asserting' stamp: ''!
assertUndefinedTypeOf: anFFIArgument
	
	self assert: anFFIArgument type isUndefined! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testParseFunctionArrayWithPointerReturnTypeHasFunctionName

	| spec |
	spec := self newParser parseNamedFunction: #( type * f ( void ) ).
	self assert: spec functionName equals: 'f'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedFalseArgumentHasUndefinedType
	| parser argument |
	
	parser := self newParser
		setOn: 'false';
		yourself.

	argument := parser parseArgument.
	self assertUndefinedTypeOf: argument! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testCastedTypedConstantIntegerHasType
	| argument |
	argument := self parseArgument: '#(#ulong) 42'.
	self assertType: argument named: 'ulong'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedSelfArgumentIsSelf
	| argument |
	argument := self parseArgument: 'self'.
	self assertIsSelf: argument! !

!FFIFunctionParserTest methodsFor: 'asserting' stamp: ''!
assertIsNULL: anArgument
	
	self assert: anArgument value equals: 'NULL'! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedFalseArgumentIsFalse
	| argument |
	argument := self parseArgument: 'int false'.
	self assertIsFalse: argument! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedSelfArgumentHasUndefinedType
	| argument |
	argument := self parseArgument: 'self'.
	self assertUndefinedTypeOf: argument! !

!FFIFunctionParserTest methodsFor: 'asserting' stamp: ''!
assertIsTrue: anArgument
	
	self assert: anArgument value equals: true! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testUntypedConstantNegativeIntegerArgumentHasUndefinedType
	| argument |
	
	argument := self parseArgument: '-1'.
	self assertUndefinedTypeOf: argument! !

!FFIFunctionParserTest methodsFor: 'tests' stamp: ''!
testTypedDoublePointerVariableArgumentHasArity
	| argument |
	argument := self parseArgument: 'arbitrary** a'.
	self assertType: argument arity: 2! !

!FFIFunctionResolutionStrategy commentStamp: ''!
I define a strategy of function resolution for doing callouts. 
By default, functions are obtained in first execution of it, in VM side (it just do a lookup of the symbol, and installs it in the ExternalLibraryFunction literal (no point in doing it every time). 
Sometimes we need to obtain this function pointers in different ways (for example when doing indirect calls: accessing functions installed in a global symbol, instead the real name of it). 

My children will implement different strategies to obtain this function pointers. They need to provide two methods: 

isApplicableFor:  "answers true if function should be resolved using this strategy"
resolveFunctionAddress: "answers the solved function address (an ExternalAddress)"!
!FFIFunctionResolutionStrategy methodsFor: 'testing' stamp: ''!
isApplicableFor: aRequestor
	"answers true if function should be resolved using this strategy"
	self subclassResponsibility! !

!FFIFunctionResolutionStrategy methodsFor: 'resolving' stamp: ''!
resolve: anExternalFunction
	anExternalFunction setHandle: (self resolveFunction: anExternalFunction)! !

!FFIFunctionResolutionStrategy methodsFor: 'resolving' stamp: ''!
resolveFunction: anExternalFunction
	"answers the solved function address (an ExternalAddress)"
	self subclassResponsibility! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantIntegerShouldBeInt32

	| argument |
	argument := FFIConstantArgument new
		value: 1;
		yourself.
	
	argument resolveUsing: FFICallout new.

	self assert: argument resolvedType class equals: uint32Type! !

!FFIFunctionResolutionTest methodsFor: 'helpers' stamp: ''!
pushTemp: aString 
	
	stack push: { #temp . aString }! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveArgumentVariableShouldSetArgumentVariableLoader

	| argument receiver context resolver |
	argument := FFIVariableArgument
		name: 'arg'
		typeName: 'int'
		arity: 0.

	receiver := 17@25.
	context := Context
		sender: nil
		receiver: receiver
		method: Point>>#*
		arguments: #().
	resolver := FFICallout new
		sender: context;
		yourself.
	
	argument resolveUsing: resolver.
	argument loader emitArgument: self context: context.

	self assert: stack pop equals: { #temp . 'arg' }! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantSelfStringShouldSetConstantLoader

	| argument |
	argument := FFIConstantArgument new
		value: 'self';
		type: (FFITypeDeclaration typeName: 'char' arity: 1);
		yourself.

	argument resolveUsing: FFICallout new.
	argument loader emitArgument: self context: nil inCallout: nil.

	self assert: stack pop equals: { #literal . 'self' }.! !

!FFIFunctionResolutionTest methodsFor: 'helpers' stamp: ''!
pushLiteral: aLiteral

	stack push: { #literal . aLiteral }! !

!FFIFunctionResolutionTest methodsFor: 'helpers' stamp: ''!
pushReceiver
	
	stack push: #( self )! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantNULLShouldSetConstantNullLoader

	| argument |
	argument := FFIConstantArgument new
		value: 'NULL';
		yourself.
	
	argument resolveUsing: FFICallout new.
	argument loader emitArgument: self context: nil inCallout: nil.

	self assert: stack pop equals: { #literal . ExternalAddress null}.! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantNilShouldBeVoidPointerType

	| argument |
	argument := FFIConstantArgument new
		value: nil;
		yourself.
	
	argument resolveUsing: FFICallout new.

	self assert: argument resolvedType class equals: voidType.
	self assert: argument resolvedType pointerArity equals: 1! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantNilShouldSetConstantNullLoader

	| argument |
	argument := FFIConstantArgument new
		value: nil;
		yourself.
	
	argument resolveUsing: FFICallout new.
	argument loader emitArgument: self context: nil inCallout: nil.

	self assert: stack pop equals: { #literal . ExternalAddress null }.! !

!FFIFunctionResolutionTest methodsFor: 'helpers' stamp: ''!
pushLiteralVariable: aClassVariable 
	
	stack push: { #classVariable . aClassVariable }! !

!FFIFunctionResolutionTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	stack := Stack new.! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantSelfStringInStrictResolverFails

	| argument resolver |
	argument := FFIConstantArgument new
		value: 17;
		yourself.

	resolver := FFICallout new.
	resolver beStrict.
	self should: [argument resolveUsing: resolver] raise: FFIUnsupportedUntypedLiteral! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantIntegerShouldSetConstantLoader

	| argument |
	argument := FFIConstantArgument new
		value: 1;
		yourself.
	
	argument resolveUsing: FFICallout new.
	argument loader emitArgument: self context: nil inCallout: nil.

	self assert: stack pop equals: { #literal . 1}.! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveArgumentVariableWithExplicitTypeResolvesType

	| argument receiver context resolver |
	argument := FFIVariableArgument
		name: 'arg'
		typeName: 'int'
		arity: 0.

	receiver := 17@25.
	context := Context
		sender: nil
		receiver: receiver
		method: Point>>#*
		arguments: #().
		
	resolver := FFICallout new
		sender: context;
		requestor: self;
		yourself.
	
	argument resolveUsing: resolver.

	self assert: argument resolvedType class equals: intType! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveClassVariableShouldSetClassVariableLoader

	| argument receiver context resolver |
	argument := FFIVariableArgument
		name: 'AsciiOrder'
		typeName: 'int'
		arity: 0.

	receiver := 'aString'.
	context := Context
		sender: nil
		receiver: receiver
		method: String>>#asDate
		arguments: #().
	resolver := FFICallout new
		sender: context;
		yourself.
	
	argument resolveUsing: resolver.
	argument loader emitArgument: self context: context.

	self assert: stack pop equals: { #classVariable . (String classPool bindingOf: #AsciiOrder )}.
	self assert: argument resolvedType class equals: int32Type! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantTrueShouldSetConstantOneLoader

	| argument |
	argument := FFIConstantArgument new
		value: true;
		yourself.
	
	argument resolveUsing: FFICallout new.
	argument loader emitArgument: self context: nil inCallout: nil.

	self assert: stack pop equals: { #literal . 1 }.! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantSelfOfExternalObjectShouldSetConstantFirstInstanceVariableLoader

	| argument receiver context resolver |
	argument := FFIConstantArgument new
		value: #self;
		yourself.
		
	receiver := FFIExternalObjectForTest new.
	context := Context
		sender: nil
		receiver: receiver
		method: FFIExternalObjectForTest>>#testMethod
		arguments: #().
		
	resolver := FFICallout new
		sender: context;
		yourself.
	
	argument resolveUsing: resolver.
	argument loader emitArgument: self context: context inCallout: nil.

	self assert: stack pop equals: #(#ivar 1).! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveClassVariableShouldBeInt32Type

	| argument receiver context resolver |
	argument := FFIVariableArgument
		name: 'AsciiOrder'
		typeName: 'int'
		arity: 0.

	receiver := 'aString'.
	context := Context
		sender: nil
		receiver: receiver
		method: String>>#asDate
		arguments: #().
	resolver := FFICallout new
		sender: context;
		yourself.
	
	argument resolveUsing: resolver.

	self assert: argument resolvedType class equals: int32Type! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantSelfShouldResolveToExternalObjectType

	| argument receiver context resolver |
	argument := FFIConstantArgument new
		value: #self;
		yourself.
		
	receiver := FFIExternalObjectForTest new.
	context := Context
		sender: nil
		receiver: receiver
		method: FFIExternalObjectForTest>>#testMethod
		arguments: #().
		
	resolver := FFICallout new
		sender: context;
		yourself.
	
	argument resolveUsing: resolver.

	self assert: argument resolvedType equals: (receiver class asExternalTypeOn: nil)! !

!FFIFunctionResolutionTest methodsFor: 'helpers' stamp: ''!
pushInstVar: anInteger 
	
	stack push: {#ivar . anInteger}! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantTrueShouldBeInt32Type

	| argument resolver |
	argument := FFIConstantArgument new
		value: true;
		yourself.
	
	resolver := FFICallout new
		requestor: self;
		yourself.
	
	argument resolveUsing: resolver.

	self assert: argument resolvedType class equals: int32Type! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantNULLShouldBeVoidPointerType

	| argument |
	argument := FFIConstantArgument new
		value: 'NULL';
		yourself.
	
	argument resolveUsing: FFICallout new.

	self assert: argument resolvedType class equals: voidType.
	self assert: argument resolvedType pointerArity equals: 1! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveInstanceVariableShouldSetInstanceVariableLoader

	| argument receiver context resolver |
	argument := FFIVariableArgument
		name: 'x'
		typeName: 'int'
		arity: 0.

	receiver := 17@25.
	context := Context
		sender: nil
		receiver: receiver
		method: Point>>#abs
		arguments: #().
	resolver := FFICallout new
		sender: context;
		yourself.
	
	argument resolveUsing: resolver.
	argument loader emitArgument: self context: context.

	self assert: stack pop equals: #(ivar 1)! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantFalseShouldSetConstantZeroLoader

	| argument |
	argument := FFIConstantArgument new
		value: false;
		yourself.
	
	argument resolveUsing: FFICallout new.
	argument loader emitArgument: self context: nil inCallout: nil.

	self assert: stack pop equals: { #literal . 0 }.! !

!FFIFunctionResolutionTest methodsFor: 'tests' stamp: ''!
testResolveConstantFalseShouldBeInt32Type

	| argument resolver |
	argument := FFIConstantArgument new
		value: false;
		yourself.
	
	resolver := FFICallout new
		requestor: self;
		yourself.
	
	argument resolveUsing: resolver.

	self assert: argument resolvedType class equals: int32Type! !

!FFIFunctionSpec commentStamp: ''!
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.!
!FFIFunctionSpec methodsFor: 'converting' stamp: ''!
printType: typeAndArity on: stream
	stream nextPutAll: typeAndArity first.
	typeAndArity second timesRepeat: [ stream nextPut: $* ].
! !

!FFIFunctionSpec methodsFor: 'converting' stamp: ''!
asArraySpecArrayedArgs
	^ String streamContents: [ :stream | |index|
		stream nextPutAll: '#( '.
		self printType: returnType on: stream.
		stream space.
		functionName ifNotNil: [
			stream 
				nextPutAll: functionName; 
				space ].
		stream nextPutAll: '( '.
		index := 1.
		arguments 
			do: [ :each | 
				stream nextPutAll: each second. "type name"
				each third 
					timesRepeat: [ stream nextPut: $* ].
				stream 
					space;
					nextPutAll: 'argsArray@', index printString;
					space.
				index := index + 1 ] 
			separatedBy: [ 
				stream nextPutAll: ', ' ].
		stream nextPutAll: '))' ]! !

!FFIFunctionSpec methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	arguments := OrderedCollection new! !

!FFIFunctionSpec methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!FFIFunctionSpec methodsFor: 'accessing' stamp: ''!
arguments: anObject
	arguments := anObject! !

!FFIFunctionSpec methodsFor: 'accessing' stamp: ''!
returnType
	^ returnType! !

!FFIFunctionSpec methodsFor: 'accessing' stamp: ''!
functionName: anObject
	functionName := anObject! !

!FFIFunctionSpec methodsFor: 'accessing' stamp: ''!
addArgument: anArgument
	^ arguments add: anArgument! !

!FFIFunctionSpec methodsFor: 'resolution' stamp: ''!
resolveUsing: aResolver
	
	returnType resolveUsing: aResolver.
	arguments do: [ :e | e resolveUsing: aResolver ]! !

!FFIFunctionSpec methodsFor: 'converting' stamp: ''!
asArraySpec
	^ String streamContents: [ :stream | 
		stream nextPutAll: '#( '.
		self printType: returnType on: stream.
		stream space.
		functionName ifNotNil: [
			stream 
				nextPutAll: functionName; 
				space ].
		stream nextPutAll: '( '.
		arguments 
			do: [ :each | 
				stream nextPutAll: each second. "type name"
				each third 
					timesRepeat: [ stream nextPut: $* ].
				stream 
					space;
					nextPutAll: each first;
					space ] 
			separatedBy: [ stream nextPutAll: ', ' ].
		stream nextPutAll: '))' ]! !

!FFIFunctionSpec methodsFor: 'converting' stamp: ''!
asMethodSelectorAndArguments
	^ String streamContents: [ :stream | 
		stream nextPutAll: functionName.
		arguments ifNotEmpty: [
			arguments size = 1 ifFalse: [
				stream
					nextPut: $_;
					nextPutAll: arguments first first ].
			stream
				nextPut: $:; 
				space;
				nextPutAll: arguments first first.
				
			arguments allButFirst 
				do: [:each | 
					stream 
						space;
						nextPutAll: each first; 
						nextPut: $:;
						space;
						nextPutAll: each first ]]]! !

!FFIFunctionSpec methodsFor: 'testing' stamp: ''!
isAnonymous
	^ self functionName isNil! !

!FFIFunctionSpec methodsFor: 'converting' stamp: ''!
asMethodSelectorAndArrayOfArguments
	^ String streamContents: [ :stream | 
		stream
			nextPutAll: functionName;
			nextPutAll: ': argsArray';
			cr;
			nextPut: $".
		arguments 
			do: [ :each | stream nextPutAll: each first ] 
			separatedBy: [ stream nextPutAll: ', ' ].
		stream nextPut: $" ]! !

!FFIFunctionSpec methodsFor: 'accessing' stamp: ''!
returnType: anObject
	returnType := anObject! !

!FFIFunctionSpec methodsFor: 'accessing' stamp: ''!
functionName
	^ functionName! !

!FFIIndirectFunctionResolution commentStamp: ''!
I will perform an "indirect function call" as explained here: https://en.wikipedia.org/wiki/Function_pointer

In summary: I take a function pointer kept in a global symbol and execute it. 

I implement the option:  optIndirectCall !
!FFIIndirectFunctionResolution methodsFor: 'testing' stamp: ''!
isApplicableFor: aRequestor
	^ aRequestor optionAt: #optIndirectCall! !

!FFIIndirectFunctionResolution methodsFor: 'resolving' stamp: ''!
resolveFunction: anExternalFunction
	^ (ExternalAddress 
		loadSymbol: anExternalFunction name
		module: anExternalFunction module)
		pointerAt: 1.! !

!FFIInferenceResolutionMode commentStamp: ''!
I resolve ffi call-out arguments in a non-strict way.
This is the backwards compatibility mode and should not be used unless you know what you do.

I try to guess what type to use for a literal.
For example, for a self reference I can guess it by looking at the type of the class of self.
However, some types are problematic. For example, ints and floats can have different size/precisions.!
!FFIInferenceResolutionMode methodsFor: 'resolution' stamp: ''!
resolveUndeclaredTypeForArgument: aFFIValueArgument withResolver: aResolver

	(aFFIValueArgument value isNil
		or: [aFFIValueArgument value = 'nil'
			or: [ aFFIValueArgument value = 'NULL' ]])
				ifTrue: [ ^ (aResolver resolveType: #'void *') ].
	(#(true false) includes: aFFIValueArgument value) 
		ifTrue: [ ^ aResolver resolveType: #bool ].
	aFFIValueArgument value isInteger
		ifTrue: [ ^ (aFFIValueArgument value >=0 
			ifTrue: [ aResolver resolveType: #uint32 ]
			ifFalse: [ aResolver resolveType: #int32 ]) ].
	(aFFIValueArgument value == #self) ifTrue: [ 
		^ (aResolver requestor asExternalTypeOn: aResolver) 
			prepareAsSelfFromCalloutDeclaration ].
	
	^ aFFIValueArgument value isSymbol
		ifTrue: [ 
			"This is actually a class variable with a value..."
			aResolver resolveType: aFFIValueArgument value ]
		ifFalse: [ aResolver unsupportedUntypedLiteral: aFFIValueArgument value ]! !

!FFIInferenceResolutionMode methodsFor: 'testing' stamp: ''!
isStrict
	
	^ false! !

!FFIInstVarArgument commentStamp: ''!
I implement the push strategy for method arguments who are  instance variables.!
!FFIInstVarArgument methodsFor: 'private - emitting code' stamp: ''!
emitArgumentVariableAccesingPart: aBuilder context: aContext objectClass: objectClass instVarName: aName
	aBuilder 
		pushInstVar: (aContext methodClass instVarIndexFor: self argName);
		pushLiteral: (objectClass 
			instVarIndexFor: aName 
			ifAbsent: [ self error: 'No ', aName, ' instVar' ]).
! !

!FFIInstVarArgument methodsFor: 'accessing' stamp: ''!
argName: anObject
	argName := anObject! !

!FFIInstVarArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext
	aBuilder pushInstVar: (aContext methodClass instVarIndexFor: self argName).! !

!FFIInstVarArgument methodsFor: 'private' stamp: ''!
rolledPointerTempName
	^ self rolledPointerTempNameFor: self argName! !

!FFIInstVarArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext objectClass: objectClass instVarName: aName
	"If argument is an object, I need to send value of instVar aName instead it self"
	aBuilder 
		pushInstVar: (aContext methodClass instVarIndexFor: self argName);
		pushLiteral: (objectClass 
			instVarIndexFor: aName 
			ifAbsent: [ self error: 'No ', aName, ' instVar' ]);
		send: #instVarAt:! !

!FFIInstVarArgument methodsFor: 'accessing' stamp: ''!
argName
	^ argName! !

!FFIInt16 commentStamp: ''!
I'm an signed short type.!
!FFIInt16 methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType sint16! !

!FFIInt16 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle signedShortAt: index! !

!FFIInt16 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value 
	^ aHandle signedShortAt: index put: value! !

!FFIInt16 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType short! !

!FFIInt32 commentStamp: ''!
I'm a signed int type (32 bits)!
!FFIInt32 methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType

	^ TFBasicType sint32! !

!FFIInt32 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle signedLongAt: index! !

!FFIInt32 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle signedLongAt: index put: value! !

!FFIInt32 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType long! !

!FFIInt64 commentStamp: ''!
I'm an signed int type (64bits)
I map to a longlong type. !
!FFIInt64 methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType sint64! !

!FFIInt64 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType signedLongLong! !

!FFIInt8 commentStamp: ''!
I'm an signed byte.!
!FFIInt8 methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType sint8! !

!FFIInt8 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle signedByteAt: index! !

!FFIInt8 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle signedByteAt: index put: value! !

!FFIInt8 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType signedByte! !

!FFIIntegerType commentStamp: ''!
A generic (abstract) integer type.!
!FFIIntegerType methodsFor: 'callbacks' stamp: ''!
extractFromCallbackOn: aCallbackArgumentReader
 
	^ aCallbackArgumentReader extractIntegerType! !

!FFIIntegerType methodsFor: 'accessing' stamp: ''!
defaultReturnOnError

	^ 0! !

!FFIIntegerType methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ #integer! !

!FFILegacyStringEncodingStrategy commentStamp: ''!
I am a string encoding strategy that sends strings as they are to the callout primitive.
I am used for the legacy and backwards compatibility behavior that just copies the bytes of the ByteString to the C string.!
!FFILegacyStringEncodingStrategy methodsFor: 'emitting' stamp: ''!
emitIRForFunctionArgument: aFFICharacterType inIRBuilder: anIRBuilder context: aContext 

	aFFICharacterType loader
		emitArgument: anIRBuilder
		context: aContext! !

!FFILegacyStringEncodingStrategy methodsFor: 'testing' stamp: ''!
isLegacy

	^ true! !

!FFILegacyStringEncodingStrategy methodsFor: 'emitting' stamp: ''!
emitIRForFunctionReturn: aFFICharacterType inIRBuilder: aBuilder context: aContext

	^ aBuilder returnTop! !

!FFILibrary commentStamp: ''!
I'm an util to answer module libraries that can have different names in different platforms. 
I just implement a double dispatch with platform.!
!FFILibrary methodsFor: 'accessing - platform' stamp: ''!
macLibraryName
	"Calling by default #macModuleName for backwards compatibility.
	The system complains that this method is not implemented as it will only exist
	in subclasses that use the old API.
	Please redefine #macLibraryName"
	^ self macModuleName! !

!FFILibrary methodsFor: 'extension - hooks' stamp: ''!
preMethodBuildContext: sender builder: builder spec: functionSpec! !

!FFILibrary methodsFor: 'extension - hooks' stamp: ''!
postMethodBuildContext: sender builder: builder spec: functionSpec! !

!FFILibrary methodsFor: 'accessing' stamp: ''!
ffiLibrary

	"This method returns the FFILibrary to use when executing a FFI call.
	As we are already in a FFILibrary, the ffi call can use myself!!"

	^ self! !

!FFILibrary methodsFor: '*ThreadedFFI' stamp: ''!
ffiCall: fnSpec
	<ffiCalloutTranslator>

	^ (self ffiCalloutIn: thisContext sender)
		convention: self ffiCallingConvention;
		options: self ffiLibrary options;
		function: fnSpec module: self! !

!FFILibrary methodsFor: '*ThreadedFFI' stamp: ''!
ffiCall: fnSpec options: callOptions
	<ffiCalloutTranslator>
	
	^ (self ffiCalloutIn: thisContext sender)
		convention: self ffiCallingConvention;
		options: (self ffiLibrary options), callOptions;
		function: fnSpec module: self! !

!FFILibrary methodsFor: 'accessing - platform' stamp: ''!
unix32LibraryName
	"Use to #unixLibraryName to keep backward compatibility." 
	^ self unixLibraryName! !

!FFILibrary methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
runner 
	
	^ TFSameThreadRunner uniqueInstance  ! !

!FFILibrary methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self libraryName! !

!FFILibrary methodsFor: 'converting' stamp: ''!
asFFILibrary 
	^ self! !

!FFILibrary methodsFor: 'accessing - platform' stamp: ''!
win32LibraryName
	"Calling by default #win32ModuleName for backwards compatibility.
	The system complains that this method is not implemented as it will only exist
	in subclasses that use the old API.
	Please redefine #win32LibraryName"
	^ self win32ModuleName! !

!FFILibrary methodsFor: 'accessing' stamp: ''!
uniqueInstance
	
	^ self! !

!FFILibrary methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
callbackRunningStrategy 
	
	^ TFCallbackForkRunStrategy new! !

!FFILibrary methodsFor: 'converting' stamp: ''!
calloutAPIClass

	^ FFICalloutAPI calloutAPIClass ! !

!FFILibrary methodsFor: 'accessing - platform' stamp: ''!
unixLibraryName
	"Kept for backward compatibility. 
	The system complains that this method is not implemented as it will only exist
	in subclasses that use the old API.
	 Users should use unix32* or unix64*"
	^ self unixModuleName! !

!FFILibrary methodsFor: 'accessing - platform' stamp: ''!
unix64LibraryName
	"Point to #unixLibraryName to keep backward compatibility." 
	^ self unixLibraryName! !

!FFILibrary methodsFor: 'accessing - platform' stamp: ''!
options
	
	^ self class options! !

!FFILibrary methodsFor: 'accessing' stamp: ''!
libraryName 
	^ Smalltalk platform ffiLibraryName: self! !

!FFILibrary class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #uniqueInstance'! !

!FFILibrary class methodsFor: 'converting' stamp: ''!
asFFILibrary
	^ self uniqueInstance! !

!FFILibrary class methodsFor: 'instance creation' stamp: ''!
uniqueInstance 
	self = FFILibrary 
		ifTrue: [ self error: 'I''m an abstract class, use one of my children.' ].
	^ uniqueInstance ifNil: [ uniqueInstance := super new ]! !

!FFILibrary class methodsFor: 'converting' stamp: ''!
calloutAPIClass

	^ self uniqueInstance calloutAPIClass ! !

!FFILibrary class methodsFor: 'options' stamp: ''!
options
	
	^ #()! !

!FFILibraryFinder commentStamp: ''!
I'm a tool to find paths in diverse platforms (since they have the tendency of put its libraries in diferent places).
You do not use FFILibraryFinder directly, but one of my children.

Example: 

FFIUnix64LibraryFinder findLibrary: 'libcairo.2.so'!
!FFILibraryFinder methodsFor: 'accessing' stamp: ''!
userPaths: anArray

	userPaths := anArray! !

!FFILibraryFinder methodsFor: 'accessing' stamp: ''!
knownPaths
		
	^ self subclassResponsibility! !

!FFILibraryFinder methodsFor: 'accessing' stamp: ''!
findLibrary: aString
	
	self paths do: [ :each | | path |
		path := each / aString.
		path exists 
			ifTrue: [ ^ path fullName ] ].
	
	self error: ('Cannot locate {1}. Please check if it installed on your system' format: { aString })! !

!FFILibraryFinder methodsFor: 'accessing' stamp: ''!
basePaths

	^ self subclassResponsibility! !

!FFILibraryFinder methodsFor: 'accessing' stamp: ''!
ldLibraryPaths

	^ (OSEnvironment current at: 'LD_LIBRARY_PATH' ifAbsent: [ '' ]) substrings: ':'! !

!FFILibraryFinder methodsFor: 'accessing' stamp: ''!
paths

	^ (Array streamContents: [ :stream | 
		stream 
			nextPutAll: self userPaths;
			nextPutAll: self basePaths;
			nextPutAll: self ldLibraryPaths;
			nextPutAll: self knownPaths ])
		collect: [ :each | each asFileReference ]! !

!FFILibraryFinder methodsFor: 'accessing' stamp: ''!
userPaths

	^ userPaths ifNil: [ #() ]! !

!FFILibraryFinder methodsFor: 'accessing' stamp: ''!
findAnyLibrary: aCollection
	
	aCollection do: [ :eachName | 
		self paths do: [ :each | | path |
			path := each / eachName.
			path exists 
				ifTrue: [ ^ path fullName ] ] ].
	
	self error: ('Cannot locate any of {1}. Please check if it installed on your system' format: { aCollection asString })! !

!FFILibraryFinder class methodsFor: 'accessing' stamp: ''!
findLibrary: aName

	^ self new findLibrary: aName! !

!FFILibraryFinder class methodsFor: 'accessing' stamp: ''!
findAnyLibrary: aCollection
	"When there are different versions/names of libraries we want to use."
	
	^ self new findAnyLibrary: aCollection! !

!FFILiteralArgument commentStamp: ''!
I implement the push strategy for literal objects specified in a callout.!
!FFILiteralArgument methodsFor: 'emitting code' stamp: ''!
emitReturnArgument: builder context: aContext
	"Nothing to do here"! !

!FFILiteralArgument methodsFor: 'accessing' stamp: ''!
value: anObject
	value := anObject! !

!FFILiteralArgument methodsFor: 'accessing' stamp: ''!
loader 
	^ self! !

!FFILiteralArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext

	aBuilder pushLiteral: self value! !

!FFILiteralArgument methodsFor: 'accessing' stamp: ''!
type: anObject
	type := anObject! !

!FFILiteralArgument methodsFor: 'emitting code' stamp: ''!
emitReturn: aBuilder resultTempVar: resultVar context: aContext 
	self error: 'Literals cannot be used as return'! !

!FFILiteralArgument methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!FFILiteralArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext objectClass: aClass instVarName: aString

	self emitArgument: aBuilder context: aContext! !

!FFILiteralArgument methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ value isFloat ifTrue: [#float] ifFalse: [#integer]
! !

!FFILiteralArgument methodsFor: 'accessing' stamp: ''!
pointerArity: additionalArity
	additionalArity > 0 ifTrue: [ self error: 'passing pointer to constant' ]! !

!FFILiteralArgument methodsFor: 'accessing' stamp: ''!
externalTypeAlignment

	^ self externalType externalTypeAlignment! !

!FFILiteralArgument methodsFor: 'accessing' stamp: ''!
externalTypeSize

	^ self externalType byteSize! !

!FFILiteralArgument methodsFor: 'accessing' stamp: ''!
type
	^ type! !

!FFILiteralArgument methodsFor: 'unpacking' stamp: ''!
emitPointerArityUnpack: anIRBuilder type: aFFIVoid context: aContext 
	
	"Nothing to do here"! !

!FFILiteralArgument methodsFor: 'accessing' stamp: ''!
externalType 

	^ self type externalType! !

!FFILiteralArgument class methodsFor: 'instance creation' stamp: ''!
value: aValue
	^ self new value: aValue! !

!FFILiteralArgument class methodsFor: 'instance creation' stamp: ''!
value: anObject type: aType
	^ self new 
		value: anObject;
		type: aType;
		yourself! !

!FFILong commentStamp: ''!
I'm a long. 
Longs are special, see FFIULong comment for details.!
!FFILong methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType slong! !

!FFILong methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle platformLongAt: index! !

!FFILong methodsFor: 'private - emitting code' stamp: ''!
offsetPointerReadFieldAt: offsetVariableName
	^ '^ExternalData 
		fromHandle: (handle {1}: {2})
		type: FFIArchitecture forCurrentArchitecture externalLongType asPointerType'
	format: { 
		self emitSelector.
		offsetVariableName }! !

!FFILong methodsFor: 'private - emitting code' stamp: ''!
emitSelector
	^ 'platformLongAt'! !

!FFILong methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value 
	^ aHandle platformLongAt: index put: value! !

!FFILong class methodsFor: 'accessing' stamp: ''!
externalType 
	^ FFIArchitecture forCurrentArchitecture externalLongType! !

!FFIMacLibraryFinder commentStamp: ''!
I find libraries in a MacOS (64bit) system.!
!FFIMacLibraryFinder methodsFor: 'accessing' stamp: ''!
findFramework: aName
	| path |
	
	path :=  ('/System/Library/Frameworks/', aName, '.framework/', aName) asFileReference.
	path exists ifTrue: [ ^ path fullName ].
	
	self error: ('Framework {1} not found.' format: { aName })! !

!FFIMacLibraryFinder methodsFor: 'accessing' stamp: ''!
knownPaths
		
	^ #(
	'/usr/lib'
	'/usr/local/lib'
	)! !

!FFIMacLibraryFinder methodsFor: 'accessing' stamp: ''!
basePaths

	^ {
	Smalltalk imageDirectory fullName.
	(Smalltalk vm binary parent / 'Plugins') fullName. 
	(Smalltalk vm binary parent parent / 'Resources' / 'lib') fullName }! !

!FFIMacLibraryFinder class methodsFor: 'accessing' stamp: ''!
findFramework: aName

	^ self new findFramework: aName! !

!FFIMethodArgument commentStamp: ''!
I implement the push strategy for method arguments who are simple variables.!
!FFIMethodArgument methodsFor: 'private - emitting code' stamp: ''!
emitArgumentVariableAccesingPart: aBuilder context: aContext objectClass: objectClass instVarName: aName
	aBuilder 
		pushTemp: self argName asSymbol;
		pushLiteral: (objectClass 
			instVarIndexFor: aName 
			ifAbsent: [ self error: 'No ', aName, ' instVar' ]).! !

!FFIMethodArgument methodsFor: 'accessing' stamp: ''!
argName: anObject
	argName := anObject! !

!FFIMethodArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext
	aBuilder pushTemp: self argName asSymbol! !

!FFIMethodArgument methodsFor: 'private' stamp: ''!
rolledPointerTempName
	^ self rolledPointerTempNameFor: self argName! !

!FFIMethodArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext objectClass: objectClass instVarName: aName
	"If argument is an object, I need to send value of instVar aName instead it self"
	aBuilder 
		pushTemp: self argName asSymbol;
		pushLiteral: (objectClass 
			instVarIndexFor: aName 
			ifAbsent: [ self error: 'No ', aName, ' instVar' ]);
		send: #instVarAt:! !

!FFIMethodArgument methodsFor: 'accessing' stamp: ''!
argName
	^ argName! !

!FFIMethodArgument methodsFor: 'accessing' stamp: ''!
index: anObject
	index := anObject! !

!FFIMethodArgument methodsFor: 'accessing' stamp: ''!
index
	"I am the index in the method. 
	 For example, method: arg1 withArg: arg2 will have arguments at index 1 and at index 2"
	^ index! !

!FFIMethodRegistry commentStamp: ''!
I keep a  registry of FFI prepared methods. 
Registry is used to know exactly which methods are executing FFI-NB calls and then which ones need to be recompiled when a platform has change.!
!FFIMethodRegistry methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	compiledMethods := WeakSet new.
	! !

!FFIMethodRegistry methodsFor: 'accessing' stamp: ''!
removeMethod: aMethod

	aMethod methodClass methodDict
		at: aMethod selector
		put: (aMethod propertyAt: #ffiNonCompiledMethod)! !

!FFIMethodRegistry methodsFor: 'reseting' stamp: ''!
resetSingleClass: aClass

	self compiledMethods
		select: [ :m | m methodClass = aClass ]
		thenDo: [ :aMethod | 
			self removeMethod: aMethod.
			compiledMethods remove: aMethod ]! !

!FFIMethodRegistry methodsFor: 'accessing' stamp: ''!
compiledMethods
	^ compiledMethods! !

!FFIMethodRegistry methodsFor: 'initialization' stamp: ''!
reset
	"FFI compiled methods will keep the old method as a property, making easy to replace it 
	 when changing platforms."
	self compiledMethods do: [ :each | self removeMethod: each].
	self compiledMethods removeAll! !

!FFIMethodRegistry methodsFor: 'accessing' stamp: ''!
registerMethod: aCompiledMethod
	compiledMethods add: aCompiledMethod.! !

!FFIMethodRegistry class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #uniqueInstance'! !

!FFIMethodRegistry class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default
		registerSystemClassNamed: self name
		atPriority: 60! !

!FFIMethodRegistry class methodsFor: 'system startup' stamp: ''!
shutDown: quitting
	quitting ifFalse: [ ^ self ].
	
	self resetAll! !

!FFIMethodRegistry class methodsFor: 'system startup' stamp: ''!
resetAll
	"I'm reseting each shutdown and startup because like that I can be sure a complete cleanup is done, 
	 because many things can change: 
		- platform change 
		- working directory change (and then libraries not found)
		- indirect functions needs to be recalculated.
	I am not supposed to be performed when image is just saved to avoid possible problem which can happen when we reset all caches and continue to work"
	self uniqueInstance reset.
	FFICallbackFunctionResolution reset.
	FFIStructure resetAllStructures.
	uniqueInstance := nil.! !

!FFIMethodRegistry class methodsFor: 'cleanup' stamp: ''!
cleanUp: aggressive
	"Only delete change sets when being aggressive"
	self uniqueInstance reset.
	uniqueInstance := nil
	! !

!FFIMethodRegistry class methodsFor: 'instance creation' stamp: ''!
uniqueInstance
	^ uniqueInstance ifNil: [ uniqueInstance := super new ]! !

!FFIMethodRegistry class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting
	isImageStarting ifFalse: [ ^ self ].
	
	self resetAll! !

!FFIMockCalloutMethodBuilder commentStamp: ''!
I am a callout method builder that creates a mock ExternalLibraryFunction invoking a block instead of a function.
Useful for testing, avoiding the actual external call.!
!FFIMockCalloutMethodBuilder methodsFor: 'type-resolution' stamp: ''!
ffiBindingOf: aString 
	
	^ self class ffiBindingOf: aString! !

!FFIMockCalloutMethodBuilder methodsFor: 'compatibility' stamp: ''!
method
	"To mock the creation of the IR..."
	^ block! !

!FFIMockCalloutMethodBuilder methodsFor: 'compatibility' stamp: ''!
methodProperties
	"To mock the creation of the IR..."
	^ nil! !

!FFIMockCalloutMethodBuilder methodsFor: 'compatibility' stamp: ''!
extractLibrary

	^ LibC uniqueInstance! !

!FFIMockCalloutMethodBuilder methodsFor: 'accessing' stamp: ''!
doing: aBlockClosure 
	
	block := aBlockClosure! !

!FFIMockCalloutMethodBuilder methodsFor: 'compatibility' stamp: ''!
createFFICalloutLiteralFromSpec: functionSpec

	^ self! !

!FFIMockCalloutMethodBuilder methodsFor: 'compatibility' stamp: ''!
methodTrailer

	^ CompiledMethodTrailer empty! !

!FFIMockCalloutMethodBuilder methodsFor: 'invoking' stamp: ''!
invokeWithArguments: aCollection 
	
	^ block valueWithArguments: aCollection! !

!FFIOop methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFDerivedType objectPointer! !

!FFIOop methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle pointerAt: index! !

!FFIOop methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	self error: 'Not sure I want to do this.'
	"But it would be like this:
	aHandle pointerAt: index put: value"! !

!FFIOop methodsFor: 'stack parameter classification' stamp: ''!
stackValueParameterClass
	^ #integer! !

!FFIOop methodsFor: 'testing' stamp: ''!
needsArityUnpacking
	"this represent kind of pointers, so it will be unpacked if they are also rolled."
	^ self needsArityPacking! !

!FFIOop methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ self pointerSize  ! !

!FFIOop class methodsFor: 'private' stamp: ''!
naturalPointerArity
	^ 1! !

!FFIOop class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ self pointerSize! !

!FFIOop class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ Smalltalk wordSize! !

!FFIOop class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType void asPointerType! !

!FFIOpaqueObject commentStamp: ''!
I represent an opaque type (https://en.wikipedia.org/wiki/Opaque_data_type) living in the C heap. 
This is usefull when working with obscure types (types we do not know its composition).
Take this as an example (taken from SQLite bindings): 

[ [ [ 
typedef struct sqlite3 sqlite3;
typedef struct sqlite3_stmt sqlite3_stmt;
 ] ] ]

this defines a type of a structure, and then is used along the api in this way: 

int sqlite3_open(char *filename, sqlite3 **handle);
char *sqlite3_column_name(sqlite3_stmt* aStatement, int aColumn)

this means we always access them through a reference. Now, we could declare the pointer to the structures, but then our declarations wouldn't be as close to C as we want. 

This i where I come to help. Instead using a FFIExternalObject, we use an FFIOpaqueObject. This means we will have a type reference (that we cannot use dereferenced, see ==FFIDereferencedOpaqueObjectError==).

In the case of the example, it would work like this: 

[ [ [ 
TypeMap := Dictionary newFromPairs: #(
	sqlite3		      	FFIOpaqueObject
	sqlite3_stmt		FFIOpaqueObject
).

self ffiCall: #(int sqlite3_open(String filename, sqlite3 **handle)).
...
 self ffiCall: #(const void *sqlite3_column_blob (sqlite3_stmt* aStatement, int aColumn))
 ] ] ]
!
!FFIOpaqueObject class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator
	^ FFIOpaqueObjectType objectClass: self! !

!FFIOpaqueObjectTest commentStamp: ''!
Tests for FFIOpaqueObjectType!
!FFIOpaqueObjectTest methodsFor: 'private' stamp: ''!
ffiBindingOf: aName
	^ self class ffiBindingOf: aName! !

!FFIOpaqueObjectTest methodsFor: 'private' stamp: ''!
ffiInstVarArgument: argName generator: generator
	^ argName! !

!FFIOpaqueObjectTest methodsFor: 'tests' stamp: ''!
testParseAsBigArityPointer
	 | fnSpec arg returnType |
	
	fnSpec := self newParser parseNamedFunction: #( void function ( FFIOpaqueObject **arg ) ). 
	fnSpec resolveUsing: self newParser requestor.
	arg := fnSpec arguments first.
	self assert: arg resolvedType class equals: FFIOpaqueObjectType.
	self assert: arg resolvedType pointerArity equals: 2.
	
	fnSpec := self newParser parseNamedFunction: #( FFIOpaqueObject **function ( ) ). 
	fnSpec resolveUsing: self newParser requestor.
	returnType := fnSpec returnType.
	self assert: returnType resolvedType class equals: FFIOpaqueObjectType.
	self assert: returnType resolvedType pointerArity equals: 2! !

!FFIOpaqueObjectTest methodsFor: 'tests' stamp: ''!
testDereferencedExternalObjectError
	| fnSpec |
	self 
		should: [ 
			fnSpec := self newParser parseNamedFunction: #( void function ( FFIOpaqueObject arg ) ).
			fnSpec resolveUsing: self newParser requestor. ]
		raise: FFIDereferencedOpaqueObjectError.
	self 
		should: [ 
			fnSpec := self newParser parseNamedFunction: #( FFIOpaqueObject function ( ) ).
			fnSpec resolveUsing: self newParser requestor. ]
		raise: FFIDereferencedOpaqueObjectError
		
! !

!FFIOpaqueObjectTest methodsFor: 'tests' stamp: ''!
newParser 
	^ FFIFunctionParser new
		requestor: (FFICallout new
			requestor: self;
			yourself);
		yourself! !

!FFIOpaqueObjectTest methodsFor: 'tests' stamp: ''!
testParseAsPointer
	 | fnSpec arg returnType |
	
	fnSpec := self newParser parseNamedFunction: #( void function ( FFIOpaqueObject *arg ) ). 
	fnSpec resolveUsing: self newParser requestor.
	arg := fnSpec arguments first.
	self assert: arg resolvedType class equals: FFIOpaqueObjectType.
	self assert: arg resolvedType pointerArity equals: 1.
	
	fnSpec := self newParser parseNamedFunction: #( FFIOpaqueObject *function ( ) ). 
	fnSpec resolveUsing: self newParser requestor.
	returnType := fnSpec returnType.
	self assert: returnType resolvedType class equals: FFIOpaqueObjectType.
	self assert: returnType resolvedType pointerArity equals: 1! !

!FFIOpaqueObjectType commentStamp: ''!
I'm  an opaque object type (see ==FFIOpaqueObject== comment)!
!FFIOpaqueObjectType methodsFor: 'testing' stamp: ''!
needsArityPacking
	">1 because first is this object, who is a reference (even if not a pointer, is 
	 represented like that because he lives in the C heap. So, we 'roll' if it is 
	 a 'type**' or bigger"
	^ self pointerArity > 1! !

!FFIOpaqueObjectType methodsFor: 'initialization' stamp: ''!
prepareAsSelfFromCalloutDeclaration
	"self starts with pointer arity 1 (regardless how is declared later)"
	self pointerArity: 1! !

!FFIOpaqueObjectType methodsFor: 'testing' stamp: ''!
validateAfterParse: typeAndArityTuple
	"external objects have a natural arity of zero but they MUST be called with some arity, 
	 because they are actually external addresses (pointers). 
	 That means, you need to always declare external objects as this example:
	 [[[
		self ffiCall: #( FFIExternalObject *c_function ( FFIExternalObject *handle ) )  
	 ]]] 
	"
	self pointerArity >= 1 ifTrue: [ ^ self ].
	typeAndArityTuple second >= 1 ifTrue: [ ^ self ].
	
	FFIDereferencedOpaqueObjectError signal! !

!FFIOpaqueObjectType methodsFor: 'accessing' stamp: ''!
instanceVariableName
	^ #handle! !

!FFIOpaqueObjectType class methodsFor: 'private' stamp: ''!
naturalPointerArity
	^ 0! !

!FFIPackedStructure commentStamp: ''!
I'm an extension of FFIExternalStructure.
I am packing tightly all of my fields.!
!FFIPackedStructure class methodsFor: 'accessing' stamp: ''!
packedStructureAlignment
	^ 1! !

!FFIPackedStructure class methodsFor: 'register marshalling' stamp: ''!
emitFlatStructureLayoutInto: flatStructureLayout
	flatStructureLayout addMemoryFieldSize: self structureSize alignment: self structureAlignment! !

!FFIPackedStructure class methodsFor: 'private' stamp: ''!
compileFields: specArray withAccessors: aSymbol
	| offset fieldSpec defineBoolean|
	defineBoolean := aSymbol = #always.
	fieldSpec := self fieldSpec.
	offset := 0.	
	externalStructureAlignment := self packedStructureAlignment.
	fieldSpec fieldsAndTypesDo: [ :fieldName :type | 
		self defineFieldOffset: fieldName value: offset + 1.  
		(defineBoolean and: [ fieldName isSymbol ]) ifTrue: [ 
			self defineFieldAccessorsFor: fieldName type: type ]. 
		offset := offset + type typeSize.
	].
	offset := offset alignedTo: externalStructureAlignment.
	
	"Real compiled spec is the compiled spec of fields plus a header with structure size and 
	 structure flag"
	"Temporal type to ensure cyclic (pointer) references will work (case of linked lists, 
	 for example). I do not like it, but it works :S"
	compiledSpec := {ExternalType pointerSpec}. 
	"Now I can reconsider it"
	compiledSpec := fieldSpec compileSpec copyWithFirst: (offset bitOr: FFIFlagStructure).
	ExternalType noticeModificationOf: self.
	^ compiledSpec! !

!FFISelfArgument commentStamp: ''!
I represent a "self" argument. 
This means a call on the form: 

#(void function ( self ) )

To be able to pass an object as "self " it need to accomplish one of this conditions: 

- it has to be an object mappable to an atomic type (that means: a number, a char, a string, ...)
- it class needs to have an instance variable 'handle', who will be taken as the real value to transmit (usually, this will be a en ExternalAddress)!
!FFISelfArgument methodsFor: 'private - emitting code' stamp: ''!
emitArgumentVariableAccesingPart: aBuilder context: aContext objectClass: objectClass instVarName: aName

	aBuilder 
		pushReceiver;
		pushLiteral: (objectClass 
			instVarIndexFor: aName 
			ifAbsent: [ self error: 'No ', aName, ' instVar' ])! !

!FFISelfArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext
	aBuilder pushReceiver! !

!FFISelfArgument methodsFor: 'private' stamp: ''!
rolledPointerTempName
	^ self rolledPointerTempNameFor: #self! !

!FFISelfArgument methodsFor: 'emitting code' stamp: ''!
emitArgument: aBuilder context: aContext objectClass: objectClass instVarName: aName
	"If argument is an object, I need to send value of instVar handle instead it self"
	aBuilder pushInstVar: (objectClass 
		instVarIndexFor: aName 
		ifAbsent: [ self error: 'No ', aName, ' instVar' ])! !

!FFISizeT commentStamp: ''!
I'm a size_t type. 
I can change in different architectures (32/64bits)
!
!FFISizeT methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType

	^ FFIArchitecture forCurrentArchitecture tfexternalSizeTType! !

!FFISizeT methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle platformSizeTAt: index! !

!FFISizeT methodsFor: 'accessing' stamp: ''!
offsetPointerReadFieldAt: offsetVariableName
	^ '^ExternalData 
		fromHandle: (handle {1}: {2})
		type: FFIArchitecture forCurrentArchitecture externalSizeTType asPointerType'
	format: { 
		self emitSelector.
		offsetVariableName }! !

!FFISizeT methodsFor: 'private - emitting code' stamp: ''!
emitSelector
	^ 'platformSizeTAt'! !

!FFISizeT methodsFor: 'accessing' stamp: ''!
offsetReadFieldAt: offsetVariableName
	self isPointer ifTrue: [ 
		^ self offsetPointerReadFieldAt: offsetVariableName ].
	
	^ String streamContents: [ :stream |
		stream << '^handle ' << self emitSelector << ': ' << offsetVariableName ]! !

!FFISizeT methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle platformSizeTAt: index put: value! !

!FFISizeT methodsFor: 'accessing' stamp: ''!
writeFieldAt: byteOffset with: valueName

	self isPointer ifTrue: [ 
		^ self externalTypeWithArity 
			writeFieldAt: byteOffset
			with: valueName ].

	^ String streamContents: [ :stream |
		stream 
			<< '^handle ' << self emitSelector << ': ' << byteOffset asString
			<< ' put: ' << valueName ]
! !

!FFISizeT methodsFor: 'accessing' stamp: ''!
readFieldAt: byteOffset
	self isPointer ifTrue: [ 
		^ self pointerReadFieldAt: byteOffset ].

	^ String streamContents: [ :stream |
		stream << '^handle ' << self emitSelector << ': ' << byteOffset asString ].
! !

!FFISizeT methodsFor: 'accessing' stamp: ''!
offsetWriteFieldAt: offsetVariableName with: valueName
	self isPointer ifTrue: [ 
		^ self externalTypeWithArity 
			offsetWriteFieldAt: offsetVariableName 
			with: valueName ].

	^ String streamContents: [ :stream |
		stream 
			<< '^handle ' << self emitSelector << ': ' << offsetVariableName 
			<< ' put: ' << valueName ]! !

!FFISizeT methodsFor: 'accessing' stamp: ''!
pointerReadFieldAt: byteOffset
	"since offsetPointerReadFieldAt: receives a variable no matter what we use the trick of 
	 just passing the offset as a string... it will work :)"
	^ self offsetPointerReadFieldAt: byteOffset asString! !

!FFISizeT class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ Smalltalk wordSize! !

!FFISizeT class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ Smalltalk wordSize! !

!FFISizeT class methodsFor: 'accessing' stamp: ''!
externalType 
	^ FFIArchitecture forCurrentArchitecture externalSizeTType! !

!FFIStrictResolutionMode commentStamp: ''!
I resolve arguments strictly: if they have no type declaration I throw an exception.!
!FFIStrictResolutionMode methodsFor: 'resolution' stamp: ''!
resolveUndeclaredTypeForArgument: aFFIValueArgument withResolver: aResolver

	aResolver unsupportedUntypedLiteral: aFFIValueArgument value! !

!FFIStrictResolutionMode methodsFor: 'testing' stamp: ''!
isStrict
	
	^ true! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testUtf8CalloutShouldReturnDecodeUtf8EncodedString
	| return method |
	"The FFI backend returns a byte string instead of a byte array. We should gracefully transform it to byte array and decode it"
	method := self
		newFFIMethodWithSignature: #( char* f ( ) )
		doing: [ 	ByteString withAll: 'les élèves français' utf8Encoded ]
		options: #( optStringEncodingUtf8 ).
	return := method valueWithReceiver: nil arguments: #( ).
	
	self assert: return equals: 'les élèves français'! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
newFFIMethodWithSignature: signature doing: aBlock
	
	^ self newFFIMethodWithSignature: signature doing: aBlock options: #()! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
newFFIMethodWithSignature: signature doing: aBlock options: options
	
	| calloutAPI methodBuilder |
	calloutAPI := FFICalloutAPI inUFFIContext: nil.
	methodBuilder := FFIMockCalloutMethodBuilder calloutAPI: calloutAPI.
	methodBuilder doing: aBlock.
	methodBuilder requestor: (FFICallout new
		methodArgs: aBlock argumentNames;
		requestor: methodBuilder;
		options: options;
		yourself).
	
	^ methodBuilder build: [ :builder | 
			builder
				signature: signature;
				sender: methodBuilder ]! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testMandatoryEncodingWithoutExplicitEncodingShouldRaiseError
	[self
		newFFIMethodWithSignature: #( void f (char* 'string') )
		doing: [ :aString | "nothing" ]
		options: #( optStringEncodingMandatory ).
	self fail]
		on: Error
		do: [ :error | self assert: error messageText equals: 'String encoding option not specified' ]! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testUtf8EncodedStringShouldHaveNullTerminator
	| ffiInvocationArgument method |
	
	method := self
		newFFIMethodWithSignature: #( void f (char* 'string') )
		doing: [ :aString | ffiInvocationArgument := aString ]
		options: #( optStringEncodingUtf8 ).
	method valueWithReceiver: nil arguments: #( nil ).
	
	self assert: ffiInvocationArgument utf8Decoded equals: 'string', Character null asString! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testLegacyCalloutShouldSendStringArgument
	| ffiInvocationArgument method |
	
	method := self
		newFFIMethodWithSignature: #( void f (char* aString) )
		doing: [ :aString | ffiInvocationArgument := aString ].	
	method valueWithReceiver: nil arguments: #( 'string' ).
	
	self assert: ffiInvocationArgument equals: 'string'! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testLegacyCalloutShouldReturnStringArgument
	| method return |
	
	method := self
		newFFIMethodWithSignature: #( char* f ( void ) )
		doing: [ 'string' ].	
	
	return := method valueWithReceiver: nil arguments: #( ).
	
	self assert: return equals: 'string'! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testEncodingOptionSetsStringEncodingStrategy
	|generator|
	generator := FFICallout new.
	generator options: #( optStringEncodingUtf8 ).
	self assert: generator stringEncodingStrategy encoding equals: 'Utf8'! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testStringReturnWithMandatoryEncodingWithoutExplicitEncodingShouldRaiseError
	[self
		newFFIMethodWithSignature: #( char* f (void) )
		doing: [ 'asd' utf8Encoded ]
		options: #( optStringEncodingMandatory ).
	self fail]
		on: Error
		do: [ :error | self assert: error messageText equals: 'String encoding option not specified' ]! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testUtf8CalloutShouldSendUtf8EncodedLiteralStringArgument
	| ffiInvocationArgument method |
	
	method := self
		newFFIMethodWithSignature: #( void f (char* 'string') )
		doing: [ :aString | ffiInvocationArgument := aString ]
		options: #( optStringEncodingUtf8 ).
	method valueWithReceiver: nil arguments: #( nil ).
	
	self assert: ffiInvocationArgument equals: ('string' nullTerminatedEncodeWith: #utf8)! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testStringEncodingWithMandatoryEncodingWithSpecifiedEncodingShouldNotFail
	| result method |
	
	method := self
		newFFIMethodWithSignature: #( char* f ( ) )
		doing: [ 'test' ]
		options: #( optStringEncodingUtf8 optStringEncodingMandatory ).
	result := method valueWithReceiver: nil arguments: #( ).

	self assert: result equals: 'test'! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testConflictingEncodingOptionShouldRaiseError
	|generator|
	generator := FFICallout new.
	generator options: #( optStringEncodingUtf8 optStringEncodingUtf16 ).

	[generator stringEncodingStrategy.
	self fail]
		on: Error
		do: [ :error | self assert: error messageText equals: 'Conflicting string encoding options' ]! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testCalloutShouldHaveLegacyStringEncodingStrategyByDefault
	|generator|
	generator := FFICallout new.
	
	self assert: generator stringEncodingStrategy isLegacy! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testUtf8CalloutShouldSendUtf8EncodedStringArgument
	| ffiInvocationArgument method |
	
	method := self
		newFFIMethodWithSignature: #( void f (char* aString) )
		doing: [ :aString | ffiInvocationArgument := aString ]
		options: #( optStringEncodingUtf8 ).
	method valueWithReceiver: nil arguments: #( 'string' ).
	
	self assert: ffiInvocationArgument equals: ('string' nullTerminatedEncodeWith: #utf8)! !

!FFIStringCalloutTest methodsFor: 'tests' stamp: ''!
testMandatoryEncodingWithSpecifiedEncodingShouldNotFail
	| ffiInvocationArgument method |
	
	method := self
		newFFIMethodWithSignature: #( void f (char* aString) )
		doing: [ :aString | ffiInvocationArgument := aString ]
		options: #( optStringEncodingUtf8 optStringEncodingMandatory ).
	method valueWithReceiver: nil arguments: #( 'string' ).
	
	self assert: ffiInvocationArgument equals: ('string' nullTerminatedEncodeWith: #utf8)! !

!FFIStringEncodingStrategy commentStamp: ''!
I am a string encoding strategy that explicitly encodes a string into bytes before sending it to the callout.
I know how to emit the necessary IR code to push a string argument and encode it.!
!FFIStringEncodingStrategy methodsFor: 'accessing' stamp: ''!
encoding: aString 
	encoding := aString! !

!FFIStringEncodingStrategy methodsFor: 'emitting' stamp: ''!
emitIRForFunctionArgument: aFFICharacterType inIRBuilder: anIRBuilder context: aContext 
	
	aFFICharacterType loader emitArgument: anIRBuilder context: aContext.
	anIRBuilder pushLiteral: encoding asSymbol.
	anIRBuilder send: #nullTerminatedEncodeWith:.! !

!FFIStringEncodingStrategy methodsFor: 'accessing' stamp: ''!
encoding
	^ encoding! !

!FFIStringEncodingStrategy methodsFor: 'emitting' stamp: ''!
emitIRForFunctionReturn: aFFICharacterType inIRBuilder: anIRBuilder context: aContext
	
	"The top of the stack should contain a ByteString with the bytes of the returned char*.
	The FFI backend assumes (correctly) that it is a null terminated string, and (incorrectly) that the encoding is the same of the image.
	We should transform the byte string into a byte array and then decode it"
	anIRBuilder send: #asByteArray.
	anIRBuilder pushLiteral: encoding asSymbol.
	anIRBuilder send: #decodeWith:.
	^ anIRBuilder returnTop! !

!FFIStringEncodingStrategy class methodsFor: 'instance creation' stamp: ''!
forEncoding: aString

	^ self new
		encoding: aString;
		yourself! !

!FFIStructure commentStamp: ''!
A structure is data-type that joins together a group of variables, so-called fields.
Each field of a structure has a name and a type.
Structures are often used to group related values, so they can be manipulated together.
For example, let's consider a structure that models a fraction, i.e., a number that has a numerator and a denominator. Both numerator and denominator can be defined as fields of type ==int==.
Such fraction structure data-type, and a function calculating a double precision floting point number from it, are defined in C as follows:

[[[language=c
typedef struct
{
	int numerator;
	int denominator;
} fraction;

double fraction_to_double(fraction* a_fraction){
  return a_fraction -> numerator / (double)(a_fraction -> denominator);
}
]]]

!!!!!!!! Defining a structure with ==FFIStructure==

Structures are declared in uFFI as subclasses of the ==FFIStructure== class defining the same fields as defined in C.
For example, defining our fraction structure is done as follows, defining a subclass of ==FFIStructure==, a ==fieldsDesc== class-side method returning the specification of the structure fields, and finally sending the ==rebuildFieldAccessors== message to the structure class we created.

[[[language=smalltalk
FFIStructure subclass: #FractionStructure
	instanceVariableNames: ''
	classVariableNames: ''
	package: 'FFITutorial'

FractionStructure class >> fieldsDesc [
	^ #(
		int numerator;
		int denominator;
		)
]

FractionStructure rebuildFieldAccessors.
]]]

Doing this will automatically generate some boilerplate code to manipulate the structure.
You will see that the structure class gets redefined as follows, containing some auto-generated accessors.

[[[language=smalltalk
FFIStructure subclass: #FractionStructure
	instanceVariableNames: ''
	classVariableNames: 'OFFSET_DENOMINATOR OFFSET_NUMERATOR'
	package: 'FFITutorial'

FractionStructure >> denominator [
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_DENOMINATOR
]

FractionStructure >> denominator: anObject [
	"This method was automatically generated"
	handle signedLongAt: OFFSET_DENOMINATOR put: anObject
]

FractionStructure >> numerator [
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_NUMERATOR
]

FractionStructure >> numerator: anObject [
	"This method was automatically generated"
	handle signedLongAt: OFFSET_NUMERATOR put: anObject
]
]]]

Once a structure type is defined, we can allocate structures from it using the ==new== and ==externalNew== messages, that will allocate it in the Pharo heap or the external C heap respectively.

[[[language=smalltalk
"In Pharo heap"
aFraction := FractionStructure new.

"In C heap"
aFraction := FractionStructure externalNew.
]]]

We read or write in our structure using the auto-generated accessors.

[[[language=smalltalk
aFraction numerator: 40.
aFraction denominator: 7.
]]]

And we can use it as an argument in a call\-out by using its type.

[[[language=smalltalk
FFITutorial >> fractionToDouble: aFraction [
  ^ self ffiCall: #(double fraction_to_double(FractionStructure* a_fraction))
]

FFITutorial new fractionToDouble: aFraction.
>>> 5.714285714285714
]]]

!!!!!!!! Implementation details

I'm an extension of ExternalStructure.
I extend my parent functionality by adding: 

- field description 
- field accessing implementation 
- ...!
!FFIStructure methodsFor: 'printing' stamp: ''!
printOn: aStream 
	"Append to the argument, aStream, the names and values of all the record's variables."
	super printOn: aStream. 

"	aStream nextPutAll: self class name; nextPutAll: ' ( '; cr.
	self class fieldSpec fieldNames do: [ :field |
		aStream nextPutAll: field; nextPut: $:; space; tab.
			(self perform: field ) printOn: aStream.
			] separatedBy: [ aStream cr ].
	aStream cr; nextPut: $)"! !

!FFIStructure methodsFor: 'converting' stamp: ''!
pointer
	self getHandle isExternalAddress 
		ifFalse: [ self error: 'Structures need to be moved to external memory space before passing them as pointers.' ].
	^ self getHandle pointer! !

!FFIStructure class methodsFor: 'instance creation' stamp: ''!
fromHandle: aHandle
	"Offsets are calculated when specs are compiled, but sometimes there is a possibility that 
	 user access them before actually using the compiled spec, so I need to be sure they are 
	 initialized before anything. This is why I send #compiledSpec here."
	
	self compiledSpec. 
	^ (super fromHandle: aHandle) initialize ! !

!FFIStructure class methodsFor: 'class management' stamp: ''!
resetStructureIfNotIn: alreadyReset
	"Reset myself by recompiling all my fields.
	
	Reset all my nested structures recursively if any.
	Stop recursing using a tracking collection of already reset structures."
	(alreadyReset includes: self)
		ifTrue: [ ^ self ].

	alreadyReset add: self.
	self nestedStructures do: [ :each | each resetStructureIfNotIn: alreadyReset ].
	self compileFields.! !

!FFIStructure class methodsFor: 'instance creation' stamp: ''!
externalNew
	"Create an instance of the receiver on the external heap"
	^self fromHandle: (ExternalAddress allocate: self structureSize)! !

!FFIStructure class methodsFor: 'accessing' stamp: ''!
nestedStructures

	"Retuns the direct nested structures of this structure"
	^ self fieldSpec types
		select: [ :each | each isExternalStructure and: [ each isPointer not ] ]
		thenCollect: [ :each | each objectClass ]! !

!FFIStructure class methodsFor: 'private' stamp: ''!
defineFieldAccessorsFor: fieldName startingAt: byteOffset type: type
	"Define read/write accessors for the given field. 
	 This method is equivallent to his parent, but it changes a couple of things: 
	 - type is FFIExternalType and not ExternalType
	 - it generates to another protocol, not accessing"
	| code |
	
	(type isVoid and: [ type isPointer not ]) ifTrue:[ ^ self ].
	
	code := fieldName,'
	"This method was automatically generated"
	', (type readFieldAt: byteOffset).
	self 
		compile: code 
		classified: self generatedFieldProtocolName.
	
	code := fieldName,': anObject
	"This method was automatically generated"
	', (type writeFieldAt: byteOffset with:'anObject').
	self 
		compile: code 
		classified: self generatedFieldProtocolName.! !

!FFIStructure class methodsFor: 'private' stamp: ''!
generatedFieldProtocolName
	^ 'accessing - structure variables'! !

!FFIStructure class methodsFor: 'private' stamp: ''!
rebuildFieldAccessors

	Author useAuthor: 'UFFIGenerator' during: [
		self removeAllOffsetVariables. 
		self 
			compileFields: self fields 
			withAccessors: #always]! !

!FFIStructure class methodsFor: 'field definition' stamp: ''!
fields
	^ self fieldsDesc! !

!FFIStructure class methodsFor: 'private' stamp: ''!
compileFields: specArray withAccessors: aSymbol
	| offset fieldSpec defineBoolean|
	defineBoolean := aSymbol = #always.
	fieldSpec := self fieldSpec.
	offset := 0.	
	externalStructureAlignment := 1.
	fieldSpec fieldsAndTypesDo: [ :fieldName :type |
		offset := offset alignedTo: type typeAlignment.
		self defineFieldOffset: fieldName value: offset + 1.  
		(defineBoolean and: [ fieldName isSymbol ]) ifTrue: [ 
			self defineFieldAccessorsFor: fieldName type: type ].
		offset := offset + type typeSize.
		externalStructureAlignment := externalStructureAlignment max: type typeAlignment  ].
	offset := offset alignedTo: externalStructureAlignment.
	
	"Real compiled spec is the compiled spec of fields plus a header with structure size and 
	 structure flag"
	"Temporal type to ensure cyclic (pointer) references will work (case of linked lists, 
	 for example). I do not like it, but it works :S"
	compiledSpec := {ExternalType pointerSpec}. 
	"Now I can reconsider it"
	compiledSpec := fieldSpec compileSpec copyWithFirst: (offset bitOr: FFIFlagStructure).
	ExternalType noticeModificationOf: self.
	^ compiledSpec! !

!FFIStructure class methodsFor: 'class initialization' stamp: ''!
reset
	"Reset this structure and all its nested structures"
	self resetStructureIfNotIn: Set new! !

!FFIStructure class methodsFor: 'private' stamp: ''!
defineFieldOffset: fieldName value: offset
	"Add offset values to classPool."
	| offsetVarName |
	offsetVarName := self offsetVariableNameFor: fieldName.
	"Is this field defined in a superclass?"
	(superclass bindingOf: offsetVarName)
		ifNil: [
			(self hasClassVarNamed: offsetVarName) 
				ifFalse: [ self addClassVarNamed: offsetVarName ].
			self classVarNamed: offsetVarName put: offset ].! !

!FFIStructure class methodsFor: 'register marshalling' stamp: ''!
flatStructureLayout
	| result |
	result := FFIExternalStructureFlatLayout new.
	self emitFlatStructureLayoutInto: result.
	^ result! !

!FFIStructure class methodsFor: 'private' stamp: ''!
fieldSpec
	^ FFIExternalStructureFieldParser new  
		parseFields: self fieldsDesc structure: self.
! !

!FFIStructure class methodsFor: 'converting' stamp: ''!
asExternalTypeOn: generator
	^ FFIExternalStructureType objectClass: self! !

!FFIStructure class methodsFor: 'accessing' stamp: ''!
structureSize
	^ self byteSize! !

!FFIStructure class methodsFor: 'class management' stamp: ''!
resetAllStructures
	"Reset the offsets of all structures.
	This is required when there is a platform change since type sizes and padding rules change.
	
	Manage nested structures with a recursive approach.
	Stop recursing using a tracking collection of already reset structures."
	
	| alreadyReset currentCompilationPlatform |
	currentCompilationPlatform := { OSPlatform current family . Smalltalk vm wordSize }.
	LastCompilationPlatform = currentCompilationPlatform
		ifTrue: [ ^ self ].
	
	LastCompilationPlatform := currentCompilationPlatform.
	alreadyReset := IdentitySet new.
	self allSubclassesDo: [ :each | each resetStructureIfNotIn: alreadyReset ].! !

!FFIStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"override this method in a subclass to get an automatically generated
	field accessors.
	
	The field description format is following:
	
	#( 
 		type1 name1;
		type2 name2;
		....
	)
	"
	^ #()! !

!FFIStructure class methodsFor: 'register marshalling' stamp: ''!
emitFlatStructureLayoutInto: flatStructureLayout
	flatStructureLayout alignTo: self structureAlignment.
	self fieldSpec fieldsAndTypesDo: [ :field :type |
		type emitFlatStructureLayoutFieldInto: flatStructureLayout
	].
	flatStructureLayout alignTo: self structureAlignment.! !

!FFIStructure class methodsFor: 'private' stamp: ''!
removeAllMethodsInProtocol: protocolName
	| protocol |
	
	protocol := self organization protocolNamed: protocolName.
	protocol ifNil: [ ^ self ].
	
	protocol methods do: [ :each | self removeSelector: each ]! !

!FFIStructure class methodsFor: 'private' stamp: ''!
removeAllOffsetVariables
	self classPool keys 
		select: [ :each | each beginsWith: 'OFFSET_' ]
		thenDo: [ :each | self removeClassVarNamed: each ]! !

!FFIStructure class methodsFor: 'accessing' stamp: ''!
structureAlignment
	externalStructureAlignment ifNil: [ self compileFields ].
	^ externalStructureAlignment! !

!FFIStructure class methodsFor: 'private' stamp: ''!
offsetVariableNameFor: fieldName
	^ (self offsetFieldPrefix, '_', fieldName asUppercase) asSymbol! !

!FFIStructure class methodsFor: 'private' stamp: ''!
offsetFieldPrefix
	^ 'OFFSET'! !

!FFIStructure class methodsFor: 'testing' stamp: ''!
isNormalAlignedStructure
	^ true! !

!FFIStructure class methodsFor: 'private' stamp: ''!
defineFieldAccessorsFor: fieldName type: type
	"Define read/write accessors for the given field. 
	 This method is equivallent to his parent, but it changes a couple of things: 
	 - type is FFIExternalType and not ExternalType
	 - it generates to another protocol, not accessing"
	| code |
	
	(type isVoid and: [ type isPointer not ]) ifTrue:[ ^ self ].
	
	code := fieldName,'
	"This method was automatically generated"
	', (type offsetReadFieldAt: (self offsetVariableNameFor: fieldName)).
	self 
		compile: code 
		classified: self generatedFieldProtocolName.
	
	code := fieldName,': anObject
	"This method was automatically generated"
	', (type offsetWriteFieldAt: (self offsetVariableNameFor: fieldName) with:'anObject').
	self 
		compile: code 
		classified: self generatedFieldProtocolName.! !

!FFISystemV64CallbackArgumentReader commentStamp: ''!
I represent the parsing of arguments in the SystemV 64 bits calling convention.
In this convention the passing of the parameters is done in the registers for the first 6 integers and the first 6 floats.
The count of the register used is indepent of the type. Ex: 

int f(int a, int b, float x, float y, int c)

a -> 1st int register.
b -> 2nd int register.
x -> 1st float register.
y -> 2nd float register.
c -> 3rd int register.

If there are more that 6 parameters of a given type, the seventh goes in the stack.

The structs in this calling convention are passed in the stack or in the registers.
If a struct occupies #maxStructureSizeToPassInRegisters bytes or less it is passed in the registers. Using the two next registers available.
If there are no available registers or the struct is bigger, the stack is used. 

All the integer types are promoted to Int64 or UInt64.!
!FFISystemV64CallbackArgumentReader methodsFor: 'updating' stamp: ''!
increateFloatRegisterIndex
	
	currentFloatRegisterIndex := currentFloatRegisterIndex + 1! !

!FFISystemV64CallbackArgumentReader methodsFor: 'types' stamp: ''!
stackIntegerType
	
	^ FFIInt64 new! !

!FFISystemV64CallbackArgumentReader methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	currentFloatRegisterIndex := 1.
! !

!FFISystemV64CallbackArgumentReader methodsFor: 'instance creation' stamp: ''!
maxStructureSizeToPassInRegisters

	"I am the max size of registers passed in the general purpouse registres.
	The structures that are bigger are passed through the stack"
	^ 16! !

!FFISystemV64CallbackArgumentReader methodsFor: 'accessing' stamp: ''!
currentIntegerRegisterIndex
	^ currentRegisterIndex! !

!FFISystemV64CallbackArgumentReader methodsFor: 'calculating-offsets' stamp: ''!
nextBaseAddressForStructure: type

	| baseOffset |

	"If the structure is maller than the max size, it is passed in the general purpouse registers."
	(type externalTypeSize > self maxStructureSizeToPassInRegisters)
		ifTrue: [ ^ super nextBaseAddressFor: type ].

	baseOffset := (currentRegisterIndex - 1) * Smalltalk wordSize + 1.
	"We have to increase the current register index used"
	currentRegisterIndex := currentRegisterIndex + (type externalTypeSize / Smalltalk wordSize) ceiling.
	 		
	^ { self integerRegisterPointer.  baseOffset}
	! !

!FFISystemV64CallbackArgumentReader methodsFor: 'updating' stamp: ''!
increateIntegerRegisterIndex
	
	currentRegisterIndex := currentRegisterIndex + 1! !

!FFISystemV64CallbackArgumentReader methodsFor: 'types' stamp: ''!
stackUnsignedIntegerType
	
	^ FFIUInt64 new! !

!FFISystemV64CallbackArgumentReader methodsFor: 'accessing' stamp: ''!
numberOfRegisters
	
	^ 6! !

!FFISystemV64CallbackArgumentReader methodsFor: 'accessing' stamp: ''!
currentFloatRegisterIndex
	^ currentFloatRegisterIndex! !

!FFISystemV64CallbackArgumentReader methodsFor: 'calculating-offsets' stamp: ''!
nextBaseAddressFor: type
	
	| baseAddressToRead offsetOfBaseAddress registerIndex |
	
	registerIndex := (type isFloatType and: [type isPointer not])  ifTrue: [ self currentFloatRegisterIndex ] ifFalse: [ self currentIntegerRegisterIndex ].
	
	^ registerIndex <= self numberOfRegisters 
		ifTrue:[ 
				"If the parameter is a floating point parameter it comes in the floating point set of registers, not in the general purpose ones."
				(type isFloatType and: [type isPointer not]) 
					ifTrue: [ 
						baseAddressToRead := self floatRegisterPointer.
						self increateFloatRegisterIndex ]
					ifFalse: [
						baseAddressToRead := self integerRegisterPointer.
						self increateIntegerRegisterIndex].
				
				offsetOfBaseAddress := (registerIndex - 1) * Smalltalk wordSize + 1.
				{ baseAddressToRead. offsetOfBaseAddress }] 
		ifFalse:[ super nextBaseAddressFor: type ].

! !

!FFITestArrayStructure commentStamp: ''!
An array  structure for test purposes!
!FFITestArrayStructure methodsFor: 'accessing - structure variables' stamp: ''!
char5: anObject
	"This method was automatically generated"
	handle replaceFrom: OFFSET_CHAR5 to: OFFSET_CHAR5 + 4 with: anObject getHandle startingAt: 1! !

!FFITestArrayStructure methodsFor: 'accessing - structure variables' stamp: ''!
char5
	"This method was automatically generated"
	^(FFITypeArray ofType: #FFICharacterType size: 5) fromHandle: (handle copyFrom: OFFSET_CHAR5 to: OFFSET_CHAR5 + 4)! !

!FFITestArrayStructure methodsFor: 'accessing - structure variables' stamp: ''!
byte10: anObject
	"This method was automatically generated"
	handle replaceFrom: OFFSET_BYTE10 to: OFFSET_BYTE10 + 9 with: anObject getHandle startingAt: 1! !

!FFITestArrayStructure methodsFor: 'accessing - structure variables' stamp: ''!
byte10
	"This method was automatically generated"
	^(FFITypeArray ofType: #FFIUInt8 size: 10) fromHandle: (handle copyFrom: OFFSET_BYTE10 to: OFFSET_BYTE10 + 9)! !

!FFITestArrayStructure class methodsFor: 'class initialization' stamp: ''!
initialize 
	Char5 := FFITypeArray ofType: 'char' size: 5.
	Byte10 := FFITypeArray ofType: 'byte' size: 10.! !

!FFITestArrayStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
" self rebuildFieldAccessors "
	^ #(
		Char5 char5;
		Byte10 byte10;
		)! !

!FFITestEnumeration commentStamp: ''!
An enumeration for test purposes!
!FFITestEnumeration class methodsFor: 'accessing enum' stamp: ''!
BBB
	"This method was automatically generated"
	^ BBB! !

!FFITestEnumeration class methodsFor: 'accessing enum' stamp: ''!
CCC
	"This method was automatically generated"
	^ CCC! !

!FFITestEnumeration class methodsFor: 'class initialization' stamp: ''!
initialize
	self initializeEnumeration! !

!FFITestEnumeration class methodsFor: 'accessing enum' stamp: ''!
AAA
	"This method was automatically generated"
	^ AAA! !

!FFITestEnumeration class methodsFor: 'enum declaration' stamp: ''!
enumDecl
	^ #(AAA 1
	BBB  2
	CCC 3
	DDD 2400) ! !

!FFITestEnumeration class methodsFor: 'accessing enum' stamp: ''!
DDD
	"This method was automatically generated"
	^ DDD! !

!FFITestNestingStructure commentStamp: ''!
A nesting structure for test purposes!
!FFITestNestingStructure methodsFor: 'accessing - structure variables' stamp: ''!
two
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_TWO! !

!FFITestNestingStructure methodsFor: 'accessing - structure variables' stamp: ''!
nested: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_NESTED put: anObject getHandle length: FFITestStructure byteSize! !

!FFITestNestingStructure methodsFor: 'accessing - structure variables' stamp: ''!
two: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_TWO put: anObject! !

!FFITestNestingStructure methodsFor: 'accessing - structure variables' stamp: ''!
one
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_ONE! !

!FFITestNestingStructure methodsFor: 'accessing - structure variables' stamp: ''!
nested
	"This method was automatically generated"
	^ FFITestStructure fromHandle: (handle referenceStructAt: OFFSET_NESTED length: FFITestStructure byteSize)! !

!FFITestNestingStructure methodsFor: 'accessing - structure variables' stamp: ''!
one: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_ONE put: anObject! !

!FFITestNestingStructure class methodsFor: 'class initialization' stamp: ''!
initialize
	"self rebuildFieldAccessors"! !

!FFITestNestingStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
" self rebuildFieldAccessors "
	^ #(
		byte one;
		long two;
		FFITestStructure nested;
		)! !

!FFITestNestingStructureWithArray commentStamp: ''!
A nesting structure with an array for test purposes!
!FFITestNestingStructureWithArray methodsFor: 'accessing - structure variables' stamp: ''!
nested: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_NESTED put: anObject getHandle length: 15.! !

!FFITestNestingStructureWithArray methodsFor: 'accessing - structure variables' stamp: ''!
nested
	"This method was automatically generated"
	^FFITestArrayStructure fromHandle: (handle referenceStructAt: OFFSET_NESTED length: 15)! !

!FFITestNestingStructureWithArray class methodsFor: 'field definition' stamp: ''!
fieldsDesc
" self rebuildFieldAccessors "
	^ #(
			FFITestArrayStructure nested;
		)! !

!FFITestObject commentStamp: ''!
A test object used in UFFI functional tests!
!FFITestObject methodsFor: 'accessing' stamp: ''!
c

	 ^c! !

!FFITestObject methodsFor: 'accessing' stamp: ''!
b: _b d: d_

	"some method to bind an ffi callout"! !

!FFITestObject methodsFor: 'library path' stamp: ''!
ffiLibraryName 
	
	^ 'testLibrary'! !

!FFITestObject methodsFor: 'accessing' stamp: ''!
a

	 ^a! !

!FFITestPackedStructure commentStamp: ''!
A packaged structure for test purposes!
!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
int64
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_INT64! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
short: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_SHORT put: anObject! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
double: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_DOUBLE put: anObject! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
float
	"This method was automatically generated"
	^handle floatAt: OFFSET_FLOAT! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
short
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_SHORT! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
byte
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BYTE! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
byte: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BYTE put: anObject! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
double
	"This method was automatically generated"
	^handle doubleAt: OFFSET_DOUBLE! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
float: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_FLOAT put: anObject! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
long
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_LONG! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
long: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_LONG put: anObject! !

!FFITestPackedStructure methodsFor: 'accessing - structure variables' stamp: ''!
int64: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_INT64 put: anObject! !

!FFITestPackedStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^ #(
		byte byte;
		short short;
		long long;
		float float;
		double double;
		int64 int64;
		)! !

!FFITestPointerStructure commentStamp: ''!
A pointer structure for test purposes!
!FFITestPointerStructure methodsFor: 'accessing - structure variables' stamp: ''!
two
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_TWO! !

!FFITestPointerStructure methodsFor: 'accessing - structure variables' stamp: ''!
two: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_TWO put: anObject! !

!FFITestPointerStructure methodsFor: 'accessing - structure variables' stamp: ''!
pointer
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_POINTER) type: ExternalType void asPointerType! !

!FFITestPointerStructure methodsFor: 'accessing - structure variables' stamp: ''!
one
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_ONE! !

!FFITestPointerStructure methodsFor: 'accessing - structure variables' stamp: ''!
pointer: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_POINTER put: anObject getHandle.! !

!FFITestPointerStructure methodsFor: 'accessing - structure variables' stamp: ''!
nestedPointer: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_NESTEDPOINTER put: anObject getHandle.! !

!FFITestPointerStructure methodsFor: 'accessing - structure variables' stamp: ''!
one: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_ONE put: anObject! !

!FFITestPointerStructure methodsFor: 'accessing - structure variables' stamp: ''!
nestedPointer
	"This method was automatically generated"
	^FFITestStructure fromHandle: (handle pointerAt: OFFSET_NESTEDPOINTER)! !

!FFITestPointerStructure class methodsFor: 'class initialization' stamp: ''!
initialize
	"self rebuildFieldAccessors"! !

!FFITestPointerStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
" self rebuildFieldAccessors "
	^ #(
		byte one;
		long two;
		void *pointer;
		FFITestStructure *nestedPointer;
		)! !

!FFITestStructure commentStamp: ''!
A structure for test purposes!
!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
int64
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_INT64! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
short: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_SHORT put: anObject! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
double: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_DOUBLE put: anObject! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
size_t: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_SIZE_T put: anObject! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
float
	"This method was automatically generated"
	^handle floatAt: OFFSET_FLOAT! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
short
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_SHORT! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
byte
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BYTE! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
ulong: anObject
	"This method was automatically generated"
	^handle platformUnsignedLongAt: OFFSET_ULONG put: anObject! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
byte: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BYTE put: anObject! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
size_t
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_SIZE_T! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
double
	"This method was automatically generated"
	^handle doubleAt: OFFSET_DOUBLE! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
float: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_FLOAT put: anObject! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
long
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_LONG! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
long: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_LONG put: anObject! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
int64: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_INT64 put: anObject! !

!FFITestStructure methodsFor: 'accessing - structure variables' stamp: ''!
ulong
	"This method was automatically generated"
	^handle platformUnsignedLongAt: OFFSET_ULONG! !

!FFITestStructure class methodsFor: 'class initialization' stamp: ''!
initialize
	"self rebuildFieldAccessors"! !

!FFITestStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
" self rebuildFieldAccessors "
	^ #(
		byte byte;
		short short;
		long long;
		float float;
		double double;
		int64 int64;
		ulong ulong;
		size_t size_t;
		)! !

!FFITestStructure2DoubleStructure commentStamp: ''!
A structure containing 2 double values as used by UFFI tests!
!FFITestStructure2DoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_Y put: anObject! !

!FFITestStructure2DoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle doubleAt: OFFSET_X! !

!FFITestStructure2DoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_X put: anObject! !

!FFITestStructure2DoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle doubleAt: OFFSET_Y! !

!FFITestStructure2DoubleStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
	double x;
	double y;
	)! !

!FFITestStructure2Int64Structure commentStamp: ''!
A structure containing 2 int64 values as used by UFFI tests!
!FFITestStructure2Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_Y put: anObject! !

!FFITestStructure2Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_X! !

!FFITestStructure2Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_X put: anObject! !

!FFITestStructure2Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_Y! !

!FFITestStructure2Int64Structure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
	int64 x;
	int64 y;
	)! !

!FFITestStructure4Int64Structure commentStamp: ''!
A structure containing 4 int64 values as used by UFFI tests!
!FFITestStructure4Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
z: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_Z put: anObject! !

!FFITestStructure4Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_Y put: anObject! !

!FFITestStructure4Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
w: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_W put: anObject! !

!FFITestStructure4Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
w
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_W! !

!FFITestStructure4Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_X! !

!FFITestStructure4Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_X put: anObject! !

!FFITestStructure4Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_Y! !

!FFITestStructure4Int64Structure methodsFor: 'accessing - structure variables' stamp: ''!
z
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_Z! !

!FFITestStructure4Int64Structure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
	int64 x;
	int64 y;
	int64 z;
	int64 w;
	)! !

!FFITestStructureByPlatform commentStamp: ''!
A structure for test purposes!
!FFITestStructureByPlatform methodsFor: 'accessing - structure variables' stamp: ''!
pointer
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_POINTER) type: ExternalType void asPointerType! !

!FFITestStructureByPlatform methodsFor: 'accessing - structure variables' stamp: ''!
pointer: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_POINTER put: anObject getHandle.! !

!FFITestStructureByPlatform methodsFor: 'accessing - structure variables' stamp: ''!
long
	"This method was automatically generated"
	^handle platformUnsignedLongAt: OFFSET_LONG! !

!FFITestStructureByPlatform methodsFor: 'accessing - structure variables' stamp: ''!
long: anObject
	"This method was automatically generated"
	^handle platformUnsignedLongAt: OFFSET_LONG put: anObject! !

!FFITestStructureByPlatform class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
	ulong long;
	void *pointer;
	)! !

!FFITestStructureDoubleStructure commentStamp: ''!
A structure containing double values as used by UFFI tests!
!FFITestStructureDoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
z: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_Z put: anObject! !

!FFITestStructureDoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_Y put: anObject! !

!FFITestStructureDoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
w: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_W put: anObject! !

!FFITestStructureDoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
w
	"This method was automatically generated"
	^handle doubleAt: OFFSET_W! !

!FFITestStructureDoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle doubleAt: OFFSET_X! !

!FFITestStructureDoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_X put: anObject! !

!FFITestStructureDoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle doubleAt: OFFSET_Y! !

!FFITestStructureDoubleStructure methodsFor: 'accessing - structure variables' stamp: ''!
z
	"This method was automatically generated"
	^handle doubleAt: OFFSET_Z! !

!FFITestStructureDoubleStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
	double x;
	double y;
	double z;
	double w;
	)! !

!FFITestStructureIntStructure commentStamp: ''!
A structure containing int values as used by UFFI tests!
!FFITestStructureIntStructure methodsFor: 'accessing - structure variables' stamp: ''!
z: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Z put: anObject! !

!FFITestStructureIntStructure methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Y put: anObject! !

!FFITestStructureIntStructure methodsFor: 'accessing - structure variables' stamp: ''!
w: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_W put: anObject! !

!FFITestStructureIntStructure methodsFor: 'accessing - structure variables' stamp: ''!
w
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_W! !

!FFITestStructureIntStructure methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_X! !

!FFITestStructureIntStructure methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_X put: anObject! !

!FFITestStructureIntStructure methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Y! !

!FFITestStructureIntStructure methodsFor: 'accessing - structure variables' stamp: ''!
z
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Z! !

!FFITestStructureIntStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
	int32 x;
	int32 y;
	int32 z;
	int32 w;
	)! !

!FFITestStructureSmallFloatStructure commentStamp: ''!
I am a structure that in the AMD64 SystemV ABI is passed in 2 float registers.!
!FFITestStructureSmallFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
z: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_Z put: anObject! !

!FFITestStructureSmallFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_Y put: anObject! !

!FFITestStructureSmallFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
w: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_W put: anObject! !

!FFITestStructureSmallFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
w
	"This method was automatically generated"
	^handle floatAt: OFFSET_W! !

!FFITestStructureSmallFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle floatAt: OFFSET_X! !

!FFITestStructureSmallFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_X put: anObject! !

!FFITestStructureSmallFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle floatAt: OFFSET_Y! !

!FFITestStructureSmallFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
z
	"This method was automatically generated"
	^handle floatAt: OFFSET_Z! !

!FFITestStructureSmallFloatStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
	float x;
	float y;
	float z;
	float w;
	)! !

!FFITestStructureSmallIntFloatStructure commentStamp: ''!
I am a structure that in the AMD64 SystemV ABI is passed in 1 integer register, and in 1 float register.!
!FFITestStructureSmallIntFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
z: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_Z put: anObject! !

!FFITestStructureSmallIntFloatStructure methodsFor: 'comparing' stamp: ''!
= another

	^ (self species = another species) and: [ self getHandle = another getHandle ]! !

!FFITestStructureSmallIntFloatStructure methodsFor: 'comparing' stamp: ''!
hash

	^ self getHandle hash! !

!FFITestStructureSmallIntFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Y put: anObject! !

!FFITestStructureSmallIntFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
w: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_W put: anObject! !

!FFITestStructureSmallIntFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
w
	"This method was automatically generated"
	^handle floatAt: OFFSET_W! !

!FFITestStructureSmallIntFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle floatAt: OFFSET_X! !

!FFITestStructureSmallIntFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_X put: anObject! !

!FFITestStructureSmallIntFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Y! !

!FFITestStructureSmallIntFloatStructure methodsFor: 'accessing - structure variables' stamp: ''!
z
	"This method was automatically generated"
	^handle floatAt: OFFSET_Z! !

!FFITestStructureSmallIntFloatStructure class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"self rebuildFieldAccessors"
	^ #(
	float x;
	int32 y;
	float z;
	float w;
	)! !

!FFITestType commentStamp: ''!
An example external type used in tests!
!FFITestType methodsFor: 'converting' stamp: ''!
asExternalTypeOn: aTypeResolver
	
	"FFI sends this to us expecting us to be a class most of the times, but for testing purposes, we use an instance."
	^ self copy! !

!FFITestType methodsFor: 'accessing' stamp: ''!
type: anObject
	type := anObject! !

!FFITestType methodsFor: 'accessing' stamp: ''!
externalType
	
	^ type externalType! !

!FFITestType class methodsFor: 'instance creation' stamp: ''!
of: aType

	^ self new type: aType; yourself! !

!FFITestUnion commentStamp: ''!
A union for test purposes!
!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
int64
	"This method was automatically generated"
	^handle signedLongLongAt: 1! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
short: anObject
	"This method was automatically generated"
	handle signedShortAt: 1 put: anObject! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
double: anObject
	"This method was automatically generated"
	handle doubleAt: 1 put: anObject! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
float
	"This method was automatically generated"
	^handle floatAt: 1! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
short
	"This method was automatically generated"
	^handle signedShortAt: 1! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
byte
	"This method was automatically generated"
	^handle unsignedByteAt: 1! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
byte: anObject
	"This method was automatically generated"
	handle unsignedByteAt: 1 put: anObject! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
double
	"This method was automatically generated"
	^handle doubleAt: 1! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
float: anObject
	"This method was automatically generated"
	handle floatAt: 1 put: anObject! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
long
	"This method was automatically generated"
	^handle platformLongAt: 1! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
long: anObject
	"This method was automatically generated"
	^handle platformLongAt: 1 put: anObject! !

!FFITestUnion methodsFor: 'accessing - structure variables' stamp: ''!
int64: anObject
	"This method was automatically generated"
	handle signedLongLongAt: 1 put: anObject! !

!FFITestUnion class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^ #(
		byte byte;
		short short;
		long long;
		float float;
		double double;
		int64 int64;
		)! !

!FFITypeArray commentStamp: ''!
I am a deprecated class to add a backwards compatible API to FFIArray.
FFITypeArray got renamed in favor of FFIArray during Pharo8.0.

To see how to use myself, please check FFIArray!
!FFITypeArrayTest commentStamp: ''!
Tests for FFITypeArray!
!FFITypeArrayTest methodsFor: 'tests' stamp: ''!
testExternalAtPutFloat
	| random array |
	random := Random new.
	[
		array := (FFITypeArray ofType: 'float' size: 10) externalNew.
		1 to: 10 do: [ :index | array at: index put: random next ].
		1 to: 10 do: [ :index | self assert: (array at: index) isFloat ] ]
	ensure: [ array free ]! !

!FFITypeArrayTest methodsFor: 'tests' stamp: ''!
testExternalAt
	| externalArray |
	
	[
	 	externalArray := (FFITypeArray ofType: 'int' size: 10) externalNew.
		self assert: externalArray size equals: 10.
		"External is not initialized, so I cannot check for contents unless I assign them"
		1 to: 10 do: [ :index | externalArray at: index put: 0 ].
		"Testing accessing"
		1 to: 10 do: [ :index | self assert: (externalArray at: index) equals: 0 ].
	] ensure: [ 
		externalArray free ] 
! !

!FFITypeArrayTest methodsFor: 'tests' stamp: ''!
testAt
	| externalArray |
	
	externalArray := (FFITypeArray ofType: 'int' size: 10) new.
	self assert: externalArray size equals: 10.
	1 to: 10 do: [ :index | self assert: (externalArray at: index) equals: 0 ]
! !

!FFITypeArrayTest methodsFor: 'tests' stamp: ''!
testAtPut
	| externalArray |
	
	externalArray := (FFITypeArray ofType: 'int' size: 1) new.
	externalArray at: 1 put: 42.
	self assert: (externalArray at: 1) equals: 42! !

!FFITypeArrayTest methodsFor: 'tests' stamp: ''!
testExternalAtPut
	| externalArray |
	
	[	
		externalArray := (FFITypeArray ofType: 'int' size: 1) externalNew.
		externalArray at: 1 put: 42.
		self assert: (externalArray at: 1) equals: 42 ]
	ensure: [ 
		externalArray free ]! !

!FFITypeArrayType commentStamp: ''!
I define the type for FFITypeArray objects.!
!FFITypeArrayType methodsFor: 'private' stamp: ''!
annonymousClassCreator
	^ String streamContents: [ :stream | 
		stream
			nextPutAll: '(FFITypeArray ofType: ';
			print: (self objectClass type isPointer
				ifTrue: [ self externalTypeWithArity printString ]
				ifFalse: [ self objectClass type class name ]);
			nextPutAll: ' size: ';
			print: self objectClass numberOfElements;
			nextPutAll: ')' ]! !

!FFITypeArrayType methodsFor: 'emitting code' stamp: ''!
readArrayAt: byteOffset
	^ String streamContents:[ :stream|
		stream 
			nextPutAll:'^'. 
		stream nextPutAll: self arrayClassName.
		stream
			nextPutAll:' fromHandle: (handle copyFrom: ';
			print: byteOffset;
			nextPutAll: ' to: ';
			print: byteOffset + self externalTypeSize - 1;
			nextPutAll:')' ].
! !

!FFITypeArrayType methodsFor: 'emitting code' stamp: ''!
offsetReadFieldAt: offsetVariableName
	"Return a string defining the accessor to an entity of the receiver type starting at the given byte offset. "
	self isPointer ifTrue: [ ^ super offsetReadFieldAt: offsetVariableName ].
	^ self offsetReadArrayAt: offsetVariableName! !

!FFITypeArrayType methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalTypeForStructure

	^ Array new: self objectClass numberOfElements withAll: self objectClass type tfExternalTypeWithArity ! !

!FFITypeArrayType methodsFor: 'emitting code' stamp: ''!
writeFieldAt: byteOffset with: valueName
	^ String streamContents:[ :stream|
		stream 
			nextPutAll:'handle replaceFrom: ';
			print: byteOffset;
			nextPutAll: ' to: ';
			print: byteOffset + self externalTypeSize - 1;
			nextPutAll: ' with: anObject getHandle startingAt: 1' ].! !

!FFITypeArrayType methodsFor: 'emitting code' stamp: ''!
readFieldAt: byteOffset
	"Return a string defining the accessor to an entity of the receiver type starting at the given byte offset. "
	self isPointer ifTrue: [ ^ super readFieldAt: byteOffset ].
	^ self readArrayAt: byteOffset! !

!FFITypeArrayType methodsFor: 'private' stamp: ''!
arrayClassName
	^ self objectClass isAnonymous 
			ifTrue: [ self annonymousClassCreator ]
			ifFalse: [ self objectClass name ]! !

!FFITypeArrayType methodsFor: 'private' stamp: ''!
externalTypeAlignment
	^ self objectClass type typeAlignment! !

!FFITypeArrayType methodsFor: 'emitting code' stamp: ''!
offsetWriteFieldAt: offsetVariableName with: valueName
	self flag: #pharoTodo. "This is not working in all cases for 32/64 bits (
	externalTypeSize could be different)"
	^ String streamContents:[ :stream|
		stream 
			nextPutAll:'handle replaceFrom: ';
			nextPutAll: offsetVariableName;
			nextPutAll: ' to: ';
			nextPutAll: (offsetVariableName, ' + ', (self externalTypeSize - 1) asString);
			nextPutAll: ' with: anObject getHandle startingAt: 1' ].! !

!FFITypeArrayType methodsFor: 'private' stamp: ''!
externalTypeSize
	^ self objectClass type typeSize * self objectClass numberOfElements! !

!FFITypeArrayType methodsFor: 'emitting code' stamp: ''!
offsetReadArrayAt: offsetVariableName
	self flag: #pharoTodo. "This is not working in all cases for 32/64 bits (
	externalTypeSize could be different)"
	^ String streamContents:[ :stream|
		stream 
			nextPutAll:'^';
			nextPutAll: self arrayClassName;
			nextPutAll:' fromHandle: (handle copyFrom: ';
			nextPutAll: offsetVariableName;
			nextPutAll: ' to: ';
			nextPutAll: (offsetVariableName, ' + ', (self externalTypeSize - 1) asString);
			nextPutAll:')' ].
! !

!FFITypeDeclaration commentStamp: ''!
I represent a type declaration in a FFI function signature. I have a type name and an arity (the number of indirections indicated by pointer marker stars *).
I am resolved as an external FFI type with my arity.!
!FFITypeDeclaration methodsFor: 'emitting code' stamp: ''!
emitReturn: anIRBuilder resultTempVar: aString context: aContext inCallout: aCallout
	
	^ resolvedType emitReturn: anIRBuilder resultTempVar: aString context: aContext inCallout: aCallout! !

!FFITypeDeclaration methodsFor: 'resolution' stamp: ''!
resolveUsing: aResolver

	resolvedType := (aResolver resolveType: name) pointerArity: arity.
	resolvedType isExternalType
		ifTrue: [ resolvedType validateAfterParse: self asOldArraySpec ].
	^ resolvedType! !

!FFITypeDeclaration methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalTypeWithArity
	
	^ self resolvedType tfExternalTypeWithArity! !

!FFITypeDeclaration methodsFor: 'accessing' stamp: ''!
arity: anObject
	arity := anObject! !

!FFITypeDeclaration methodsFor: 'accessing' stamp: ''!
defaultReturnOnError

	^ self resolvedType defaultReturnOnError! !

!FFITypeDeclaration methodsFor: 'accessing' stamp: ''!
externalTypeWithArity
	
	^ resolvedType externalTypeWithArity! !

!FFITypeDeclaration methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!FFITypeDeclaration methodsFor: 'accessing' stamp: ''!
arity
	^ arity! !

!FFITypeDeclaration methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!FFITypeDeclaration methodsFor: 'accessing' stamp: ''!
resolvedType
	^ resolvedType! !

!FFITypeDeclaration methodsFor: 'converting' stamp: ''!
asOldArraySpec
	
	^ { name . arity }! !

!FFITypeDeclaration methodsFor: 'resolution' stamp: ''!
resolveUsing: aResolver forArgument: aFFIVariableArgument 
	
	^ self resolveUsing: aResolver! !

!FFITypeDeclaration class methodsFor: 'instance creation' stamp: ''!
typeName: aString arity: anInteger 
	
	^ self new
		name: aString;
		arity: anInteger;
		yourself! !

!FFITypesTest commentStamp: ''!
Tests for different FFI types!
!FFITypesTest methodsFor: 'ranges' stamp: ''!
unsigned2ByteNumbers
	^ { 
		0.
		126.
		127.
		128.
		254.
		255.
		256.
		32766.
		32767.
		32768.
		65534.
		65535
 	}! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testSignedLong
	self signed4ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: FFIInt32 externalTypeSize.
		ref signedLongAt: 1 put: int.
		self assert: (ref signedLongAt: 1) equals: int ]! !

!FFITypesTest methodsFor: 'ranges' stamp: ''!
signed2ByteNumbers
	^ { 
		-32768.
		-32767.
		-129.
		-128.
		-127.
		0.
		126.
		127.
		128.
		254.
		255.
		256.
		32766.
		32767
 	}! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testSigned1ByteIntegers
	self signed1ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: 1.
		ref integerAt: 1 put: int size: 1 signed: true.
		self assert: (ref integerAt: 1 size: 1 signed: true) equals: int ]! !

!FFITypesTest methodsFor: 'ranges' stamp: ''!
unsigned1ByteNumbers
	^ { 
		0.
		126.
		127.
		128.
		254.
		255
 	}! !

!FFITypesTest methodsFor: 'ranges' stamp: ''!
signed8ByteNumbers
	^ {
		-9223372036854775808.
		-9223372036854775807.
		-2147483649.
		-2147483648.
		-2147483647.
		-32769.
		-32768.
		-32767.
		-129.
		-128.
		-127.
		0.
		126.
		127.
		128.
		254.
		255.
		256.
		32766.
		32767.
		32768.
		65534.
		65535.
		65536.
		2147483646.
		2147483647.
		2147483648.
		9223372036854775806.
		9223372036854775807
 	}! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testSignedLongLong
	self signed8ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: FFIInt64 externalTypeSize.
		ref signedLongLongAt: 1 put: int.
		self assert: (ref signedLongLongAt: 1) equals: int ]! !

!FFITypesTest methodsFor: 'ranges' stamp: ''!
signed1ByteNumbers
	^ { 
		-128.
		-127.
		0.
		126.
		127
 	}! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testSignedAtWithDiferentSizes
	"This is tests for issue 17757" 
	| ref|
	
	ref := ByteArray new: 4.
	ref integerAt: 1 put: -10 size: 1 signed: true.
	self assert: (ref integerAt: 1 size: 1 signed: true) equals: -10.
	
	ref := ByteArray new: 4.
	ref integerAt: 1 put: -10 size: 4 signed: true.
	self assert: (ref integerAt: 1 size: 4 signed: true) equals: -10.
	
	ref := ByteArray new: 8.
	ref integerAt: 1 put: -10 size: 8 signed: true.
	self assert: (ref integerAt: 1 size: 8 signed: true) equals: -10! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testSignedShortAtPutIntegers
	self signed2ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: 2.
		ref signedShortAt: 1 put: int.
		self assert: (ref signedShortAt: 1) equals: int ]! !

!FFITypesTest methodsFor: 'ranges' stamp: ''!
signed4ByteNumbers
	^ { 
		-2147483648.
		-2147483647.
		-32769.
		-32768.
		-32767.
		-129.
		-128.
		-127.
		0.
		126.
		127.
		128.
		254.
		255.
		256.
		32766.
		32767.
		32768.
		65534.
		65535.
		65536.
		2147483646.
		2147483647.
 	}! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testUnsigned1ByteIntegers
	self unsigned1ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: 1.
		ref integerAt: 1 put: int size: 1 signed: false.
		self assert: (ref integerAt: 1 size: 1 signed: false) equals: int ]! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testUnsignedLong
	self unsigned4ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: FFIUInt32 externalTypeSize.
		ref unsignedLongAt: 1 put: int.
		self assert: (ref unsignedLongAt: 1) equals: int ]! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testUnsignedLongLong
	self unsigned8ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: FFIUInt64 externalTypeSize.
		ref unsignedLongLongAt: 1 put: int.
		self assert: (ref unsignedLongLongAt: 1) equals: int ]! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testUnsigned2ByteIntegers
	self unsigned2ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: 2.
		ref integerAt: 1 put: int size: 2 signed: false.
		self assert: (ref integerAt: 1 size: 2 signed: false) equals: int ]! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testUnsignedShortAtPutIntegers
	self unsigned2ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: 2.
		ref unsignedShortAt: 1 put: int.
		self assert: (ref unsignedShortAt: 1) equals: int ]! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testSigned4ByteIntegers
	self signed4ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: 4.
		ref integerAt: 1 put: int size: 4 signed: true.
		self assert: (ref integerAt: 1 size: 4 signed: true) equals: int ]! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testSigned2ByteIntegers
	self signed2ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: 2.
		ref integerAt: 1 put: int size: 2 signed: true.
		self assert: (ref integerAt: 1 size: 2 signed: true) equals: int ]! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testUnsigned4ByteIntegers
	self unsigned4ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: 4.
		ref integerAt: 1 put: int size: 4 signed: false.
		self assert: (ref integerAt: 1 size: 4 signed: false) equals: int ]! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testSignedByteAtPutIntegers
	self signed1ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: 1.
		ref signedByteAt: 1 put: int.
		self assert: (ref signedByteAt: 1) equals: int ]! !

!FFITypesTest methodsFor: 'ranges' stamp: ''!
unsigned8ByteNumbers
	^ { 
		0.
		126.
		127.
		128.
		254.
		255.
		256.
		32766.
		32767.
		32768.
		65534.
		65535.
		65536.
		2147483646.
		2147483647.
		2147483648.
		4294967294.
		4294967295.
		9223372036854775806.
		9223372036854775807.
		9223372036854775808.
		18446744073709551614.
		18446744073709551615
 	}! !

!FFITypesTest methodsFor: 'ranges' stamp: ''!
unsigned4ByteNumbers
	^ { 
		0.
		126.
		127.
		128.
		254.
		255.
		256.
		32766.
		32767.
		32768.
		65534.
		65535.
		65536.
		2147483646.
		2147483647.
		2147483648.
		4294967294.
		4294967295
 	}! !

!FFITypesTest methodsFor: 'tests' stamp: ''!
testUnsignedByteAtPutIntegers
	self unsigned1ByteNumbers do: [ :int |
		|ref|
		ref := ByteArray new: 1.
		ref unsignedByteAt: 1 put: int.
		self assert: (ref unsignedByteAt: 1) equals: int ]! !

!FFIUBit commentStamp: ''!
I'm an unsigned bit.

Typically, you do not use this type directly but some struct implementations can be declared as one bit: 
struct GdkEventKey {
	...
 	guint is_modifier : 1;
};

the real problem is how platforms handle this field: 

macOS and linux take it as an uint8, windows takes it as a uint.
Then, you want to use this to model the case.!
!FFIUBit methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ FFIArchitecture forCurrentArchitecture tfUBitType! !

!FFIUBit methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle platformUnsignedBitAt: index! !

!FFIUBit methodsFor: 'private - emitting code' stamp: ''!
offsetPointerReadFieldAt: offsetVariableName
	^ '^ExternalData 
		fromHandle: (handle {1}: {2})
		type: FFIArchitecture forCurrentArchitecture externalUBitType asPointerType'
	format: { 
		self emitSelector.
		offsetVariableName }! !

!FFIUBit methodsFor: 'private - emitting code' stamp: ''!
emitSelector
	^ 'platformUnsignedBitAt'! !

!FFIUBit methodsFor: 'emitting code' stamp: ''!
offsetReadFieldAt: offsetVariableName
	self isPointer ifTrue: [ 
		^ self offsetPointerReadFieldAt: offsetVariableName ].
	
	^ String streamContents: [ :stream |
		stream << '^handle ' << self emitSelector << ': ' << offsetVariableName ]! !

!FFIUBit methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value 
	^ aHandle platformUnsignedBitAt: index put: value! !

!FFIUBit methodsFor: 'emitting code' stamp: ''!
writeFieldAt: byteOffset with: valueName
	self isPointer ifTrue: [ 
		^ self externalTypeWithArity 
			writeFieldAt: byteOffset
			with: valueName ].

	^ String streamContents: [ :stream |
		stream 
			<< '^handle ' << self emitSelector << ': ' << byteOffset asString
			<< ' put: ' << valueName ]
! !

!FFIUBit methodsFor: 'emitting code' stamp: ''!
readFieldAt: byteOffset
	self isPointer ifTrue: [ 
		^ self pointerReadFieldAt: byteOffset ].

	^ String streamContents: [ :stream |
		stream << '^handle ' << self emitSelector << ': ' << byteOffset asString ].
! !

!FFIUBit methodsFor: 'emitting code' stamp: ''!
offsetWriteFieldAt: offsetVariableName with: valueName
	self isPointer ifTrue: [ 
		^ self externalTypeWithArity 
			offsetWriteFieldAt: offsetVariableName 
			with: valueName ].

	^ String streamContents: [ :stream |
		stream 
			<< '^handle ' << self emitSelector << ': ' << offsetVariableName 
			<< ' put: ' << valueName ]! !

!FFIUBit methodsFor: 'private - emitting code' stamp: ''!
pointerReadFieldAt: byteOffset
	"since offsetPointerReadFieldAt: receives a variable no matter what we use the trick of 
	 just passing the offset as a string... it will work :)"
	^ self offsetPointerReadFieldAt: byteOffset asString! !

!FFIUBit class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment

	^ FFIArchitecture forCurrentArchitecture bitTypeAlignment! !

!FFIUBit class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ FFIArchitecture forCurrentArchitecture bitTypeSize! !

!FFIUBit class methodsFor: 'accessing' stamp: ''!
externalType 
	^ FFIArchitecture forCurrentArchitecture externalUBitType! !

!FFIUInt16 commentStamp: ''!
I'm an unsigned short type.!
!FFIUInt16 methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType uint16! !

!FFIUInt16 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle unsignedShortAt: index! !

!FFIUInt16 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle unsignedShortAt: index put: value! !

!FFIUInt16 class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ 2! !

!FFIUInt16 class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 2! !

!FFIUInt16 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType ushort	! !

!FFIUInt32 commentStamp: ''!
I'm an unsigned int type (32 bits)!
!FFIUInt32 methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType uint32! !

!FFIUInt32 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle unsignedLongAt: index! !

!FFIUInt32 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle unsignedLongAt: index put: value! !

!FFIUInt32 class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ 4! !

!FFIUInt32 class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 4! !

!FFIUInt32 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType ulong! !

!FFIUInt64 commentStamp: ''!
I'm an unsigned int type (64bits)
I map to a ulonglong type. !
!FFIUInt64 methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType uint64! !

!FFIUInt64 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle signedLongLongAt: index	
! !

!FFIUInt64 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value 
	^ aHandle signedLongLongAt: index	put: value
! !

!FFIUInt64 class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ OSPlatform current ffiInt64Alignment! !

!FFIUInt64 class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 8! !

!FFIUInt64 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType unsignedLongLong! !

!FFIUInt8 commentStamp: ''!
I'm an unsigned byte.!
!FFIUInt8 methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType uint8! !

!FFIUInt8 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle unsignedByteAt: index! !

!FFIUInt8 methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	^ aHandle unsignedByteAt: index put: value! !

!FFIUInt8 class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ 1! !

!FFIUInt8 class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ 1! !

!FFIUInt8 class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType unsignedByte! !

!FFIULong commentStamp: ''!
I'm an unsigned long.
Longs are different from other types because they can have different sizes depending on the architecture, reason why they need a special treatment (and we cannot reduce them to a int32 or int64 type). 
For example, this are the sizes according architecture: 

- i386: 4 bytes
- x86_64 SystemV: 8 bytes
- x86_64 Windows: 4 bytes

So we model long as a special type and we use platform speciphic settings.!
!FFIULong methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType ulong! !

!FFIULong methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	^ aHandle platformUnsignedLongAt: index	
! !

!FFIULong methodsFor: 'private - emitting code' stamp: ''!
offsetPointerReadFieldAt: offsetVariableName
	^ '^ExternalData 
		fromHandle: (handle {1}: {2})
		type: FFIArchitecture forCurrentArchitecture externalULongType asPointerType'
	format: { 
		self emitSelector.
		offsetVariableName }! !

!FFIULong methodsFor: 'private - emitting code' stamp: ''!
emitSelector
	^ 'platformUnsignedLongAt'! !

!FFIULong methodsFor: 'emitting code' stamp: ''!
offsetReadFieldAt: offsetVariableName
	self isPointer ifTrue: [ 
		^ self offsetPointerReadFieldAt: offsetVariableName ].
	
	^ String streamContents: [ :stream |
		stream << '^handle ' << self emitSelector << ': ' << offsetVariableName ]! !

!FFIULong methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value 
	^ aHandle platformUnsignedLongAt: index put: value
! !

!FFIULong methodsFor: 'emitting code' stamp: ''!
writeFieldAt: byteOffset with: valueName
	self isPointer ifTrue: [ 
		^ self externalTypeWithArity 
			writeFieldAt: byteOffset
			with: valueName ].

	^ String streamContents: [ :stream |
		stream 
			<< '^handle ' << self emitSelector << ': ' << byteOffset asString
			<< ' put: ' << valueName ]
! !

!FFIULong methodsFor: 'emitting code' stamp: ''!
readFieldAt: byteOffset
	self isPointer ifTrue: [ 
		^ self pointerReadFieldAt: byteOffset ].

	^ String streamContents: [ :stream |
		stream << '^handle ' << self emitSelector << ': ' << byteOffset asString ].
! !

!FFIULong methodsFor: 'emitting code' stamp: ''!
offsetWriteFieldAt: offsetVariableName with: valueName
	self isPointer ifTrue: [ 
		^ self externalTypeWithArity 
			offsetWriteFieldAt: offsetVariableName 
			with: valueName ].

	^ String streamContents: [ :stream |
		stream 
			<< '^handle ' << self emitSelector << ': ' << offsetVariableName 
			<< ' put: ' << valueName ]! !

!FFIULong methodsFor: 'private - emitting code' stamp: ''!
pointerReadFieldAt: byteOffset
	"since offsetPointerReadFieldAt: receives a variable no matter what we use the trick of 
	 just passing the offset as a string... it will work :)"
	^ self offsetPointerReadFieldAt: byteOffset asString! !

!FFIULong class methodsFor: 'accessing' stamp: ''!
externalTypeAlignment
	^ OSPlatform current ffiLongAlignment! !

!FFIULong class methodsFor: 'accessing' stamp: ''!
externalTypeSize
	^ FFIArchitecture forCurrentArchitecture longTypeSize! !

!FFIULong class methodsFor: 'accessing' stamp: ''!
externalType 
	^ FFIArchitecture forCurrentArchitecture externalULongType! !

!FFIUndefinedTypeDeclaration commentStamp: ''!
I represent the absense of a type declaration.
I delegate my resolution to the resolver with a double dispatch so it can choose how to resolve non-declared types.
A resolver (FFICallout) has two main resolution strategies: 
- strict does not accept resolving undefined types
- non strict is a backwards compatibility mode that tries to infer the type if possible (but can go wrong and should be used with care)!
!FFIUndefinedTypeDeclaration methodsFor: 'testing' stamp: ''!
isUndefined

	^ true! !

!FFIUndefinedTypeDeclaration methodsFor: 'resolution' stamp: ''!
resolveUsing: aResolver forArgument: aFFIFunctionArgument
	
	^ aResolver resolveUntypedArgument: aFFIFunctionArgument! !

!FFIUnion commentStamp: ''!
Unions are data-types defining a single value that can be interpreted with different internal representations.
For example, the next piece of C code defines a type ==float_or_int== that can be seen as a float or as an int.

[[[language=c
typedef union {
  float as_float;
  int as_int;
} float_or_int;

float_or_int number;
number.as_float = 3.14f;

printf("Integer representation of PI: %d\n", number.as_int);
]]]

producing the next output:

[[[
Integer representation of PI: 1078523331
]]]

!!!!!!!! Defining an union using ==FFIUnion==

Unions are declared in uFFI as subclasses of the ==FFIUnion== class defining the same fields as defined in C, similarly as structures.
For example, defining our ==float_or_int== union is done as follows, defining a subclass of ==FFIUnion==, a ==fieldsDesc== class-side method returning the specification of the union fields, and finally sending the ==rebuildFieldAccessors== message to the union class we created.

[[[language=smalltalk
FFIUnion subclass: #FloatOrIntUnion
	instanceVariableNames: ''
	classVariableNames: ''
	package: 'FFITutorial'

FloatOrIntUnion class >> fieldsDesc [
	^ #(
		float as_float;
		int as_int;
		)
]

FloatOrIntUnion rebuildFieldAccessors.
]]]

Doing this will automatically generate some boilerplate code to manipulate the values inside the union.
You will see that the union class gets redefined like structures did, containing some auto-generated accessors.

[[[language=smalltalk
FFIStructure subclass: #FloatOrIntUnion
	instanceVariableNames: ''
	classVariableNames: 'OFFSET_DENOMINATOR OFFSET_NUMERATOR'
	package: 'FFITutorial'

FloatOrIntUnion >> as_float [
	"This method was automatically generated"
	^handle floatAt: 1
]

FloatOrIntUnion >> as_float: anObject [
	"This method was automatically generated"
	handle floatAt: 1 put: anObject
]

FloatOrIntUnion >> as_int [
	"This method was automatically generated"
	^handle signedLongAt: 1
]

FloatOrIntUnion >> as_int: anObject [
	"This method was automatically generated"
	handle signedLongAt: 1 put: anObject
]
]]]

!!!!!!!! Using the defined union type

Once a union type is defined, we can allocate unions from it using the ==new== and ==externalNew== messages, that will allocate it in the Pharo heap or the external C heap respectively.

[[[language=smalltalk
"In Pharo heap"
aFloatOrInt := FloatOrIntUnion new.

"In C heap"
aFloatOrInt := FloatOrIntUnion externalNew.
]]]

We read or write in our union using the auto-generated accessors.

[[[language=smalltalk
foi as_float: 3.14.
foi as_int.
>>> 1078523331
]]]

And we can use it as an argument in a call\-out by using its type.

[[[language=smalltalk
FFITutorial >> firstByte: float_or_union [
  ^ self ffiCall: #(char float_or_int_first_byte(FloatOrIntUnion* float_or_union))
]
]]]

!!!!!!!! Implementation Details

I'm implemented as an extension of FFIStructure.
I put all of my fields at the same offset, which is zero.!
!FFIUnion class methodsFor: 'register marshalling' stamp: ''!
emitFlatStructureLayoutInto: flatStructureLayout
	flatStructureLayout addMemoryFieldSize: self structureSize alignment: self structureAlignment! !

!FFIUnion class methodsFor: 'private' stamp: ''!
compileFields: specArray withAccessors: aSymbol
	| fieldSpec defineBoolean totalSize|
	defineBoolean := aSymbol = #always.
	fieldSpec := self fieldSpec.
	totalSize := 0.	
	externalStructureAlignment := 1.
	fieldSpec fieldsAndTypesDo: [ :fieldName :type | 
		(defineBoolean and: [ fieldName isSymbol ]) ifTrue: [ 
			self defineFieldAccessorsFor: fieldName startingAt: 1 type: type ]. 
		totalSize := totalSize max: type typeSize.
		externalStructureAlignment := externalStructureAlignment max: type typeAlignment  ].
	totalSize := totalSize alignedTo: externalStructureAlignment.
	
	"Real compiled spec is the compiled spec of fields plus a header with structure size and 
	 structure flag"
	"Temporal type to ensure cyclic (pointer) references will work (case of linked lists, 
	 for example). I do not like it, but it works :S"
	compiledSpec := {ExternalType pointerSpec}. 
	"Now I can reconsider it"
	compiledSpec := fieldSpec compileSpec copyWithFirst: (totalSize bitOr: FFIFlagStructure).
	ExternalType noticeModificationOf: self.
	^ compiledSpec! !

!FFIUnix32LibraryFinder commentStamp: ''!
I find libraries in a unix (32bit) system.!
!FFIUnix32LibraryFinder methodsFor: 'accessing' stamp: ''!
knownPaths
		
	^ #( 
	'/usr/lib/i386-linux-gnu'
	'/usr/lib32'
	'/usr/lib')! !

!FFIUnix64LibraryFinder commentStamp: ''!
I find libraries in a unix (64bit) system.!
!FFIUnix64LibraryFinder methodsFor: 'accessing' stamp: ''!
knownPaths
		
	^ #(
	'/lib/x86_64-linux-gnu'
	'/lib64'
	'/usr/lib64'	
	'/usr/lib'
	'/usr/lib/x86_64-linux-gnu'
	'/usr/local/lib')! !

!FFIUnixLibraryFinder commentStamp: ''!
I'm a base library finder for unix distributions. 
I'm abstract, you need to use one of my children.!
!FFIUnixLibraryFinder methodsFor: 'accessing' stamp: ''!
basePaths
		
	^ { 
	Smalltalk imageDirectory fullName.
	Smalltalk vm directory }! !

!FFIUnknownLibrary commentStamp: ''!
I'm used when there is no defined library as a module. 
In case FFI users want to declare modules as simple strings, I'm used to model the access to that library.
I'm never used directly!! Instead, users will utilize Strings that will be converted to me thru #asFFILibrary method. 
That way, is completely the same to do a call this way: 

self ffiCall: #( void fn () ) module: 'libc'. 

and 

self ffiCall: #( void fn () ) module: LibC. 

(but of course recomended way is to use a module, in case you need a strategy to find libraries in different platforms. !
!FFIUnknownLibrary methodsFor: 'initialization' stamp: ''!
initializeName: aString 
	libraryName := aString.
	self initialize! !

!FFIUnknownLibrary methodsFor: 'accessing' stamp: ''!
libraryName
	^ libraryName! !

!FFIUnknownLibrary class methodsFor: 'instance creation' stamp: ''!
new 
	self error: 'Use #name:'! !

!FFIUnknownLibrary class methodsFor: 'instance creation' stamp: ''!
name: aString 
	^ self basicNew
		initializeName: aString;
		yourself! !

!FFIUnsupportedUntypedLiteral commentStamp: ''!
I am an error indicating that an unsupported untyped literal has been used.
I contain the unsupported literal so the user can query me.!
!FFIUnsupportedUntypedLiteral methodsFor: 'accessing' stamp: ''!
literal: anObject
	literal := anObject! !

!FFIUnsupportedUntypedLiteral methodsFor: 'accessing' stamp: ''!
literal
	^ literal! !

!FFIUnsupportedUntypedLiteral class methodsFor: 'signalling' stamp: ''!
signalFor: aLiteral

	self new
		literal: aLiteral;
		signal! !

!FFIVariableArgument commentStamp: ''!
I am a function argument representing a variable (in contrast to a literal value).
The parser creates me when it finds symbols as arguments.

I am resolved by resolving my type and my name.
The type knows how to resolve itself in a context.
To resolve my name, the resolver performs a semantic analysis in the calling context to define if the variable is an instance variable, a method argument or a class variable. The name resolution is represented by my loader.!
!FFIVariableArgument methodsFor: 'resolution' stamp: ''!
resolveUsing: aResolver

	loader := aResolver loaderForArgNamed: name indirectIndex: nil.
	resolvedType := type resolveUsing: aResolver forArgument: self.	
	resolvedType loader: loader.! !

!FFIVariableArgument methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!FFIVariableArgument methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!FFIVariableArgument methodsFor: 'converting' stamp: ''!
asOldArraySpec

	^ { name . nil . type name . type arity }! !

!FFIVariableArgument class methodsFor: 'instance creation' stamp: ''!
name: aString typeName: aTypeName arity: anInteger
	
	^ self new
		name: aString;
		type: (FFITypeDeclaration typeName: aTypeName arity: anInteger);
		yourself! !

!FFIVariableNameNotFound commentStamp: ''!
I am FFIVariableNameNotFound, an exception to indicate that a variable is not correctly used inside an ffi function!
!FFIVariableNameNotFound methodsFor: 'private' stamp: ''!
standardMessageText
	"Generate a standard textual description"

	^ String
		streamContents: [ :stream | 
			stream << 'Could not find accessor for variable named "'.
			stream print: self object.
			stream << '"' ]! !

!FFIVoid commentStamp: ''!
I'm a void type. 
I'm used always as pointer type, otherwise it does not have any sense. !
!FFIVoid methodsFor: '*ThreadedFFI-UFFI' stamp: ''!
tfExternalType
	
	^ TFBasicType void! !

!FFIVoid methodsFor: 'testing' stamp: ''!
needsArityPacking
	"Void just have sense if they are pointers, so the roll function just have sense for bigger
	 arities"
	^ self pointerArity > 1! !

!FFIVoid methodsFor: 'testing' stamp: ''!
isVoid
	^ true! !

!FFIVoid methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index
	self error: 'You can not access plain void types (it does not has sense)'! !

!FFIVoid methodsFor: 'accessing' stamp: ''!
defaultReturnOnError

	^ nil! !

!FFIVoid methodsFor: 'emitting code' stamp: ''!
emitReturn: aBuilder resultTempVar: resultVar context: aContext 
	self isPointer 
		ifTrue: [ ^ super emitReturn: aBuilder resultTempVar: resultVar context: aContext ].
	^ self emitSelfReturn: aBuilder! !

!FFIVoid methodsFor: 'private' stamp: ''!
basicHandle: aHandle at: index put: value
	self error: 'You can not access plain void types (it is meaningless)'! !

!FFIVoid methodsFor: 'emitting code' stamp: ''!
emitSelfReturn: aBuilder
	^ aBuilder 
		popTop;
		pushReceiver;
		returnTop! !

!FFIVoid methodsFor: 'accessing' stamp: ''!
callbackReturnOn: callbackContext for: anObject
	"Void returns does not set anything"
	self isPointer ifFalse: [ ^ nil ]. 
	^ callbackContext wordResult: anObject asInteger.
! !

!FFIVoid methodsFor: 'testing' stamp: ''!
needsArityUnpacking
	"Void just have sense if they are pointers, so the unpack function just have sense 
	 if they have been rolled before"
	^ self needsArityPacking! !

!FFIVoid methodsFor: 'emitting code' stamp: ''!
emitPointerReturn: aBuilder resultTempVar: resultVar context: aContext
	^ aBuilder 
		addTemp: #tmpResult;
		"keep invoke result into the tmpResult var"
		storeTemp: #tmpResult;
		popTop;
		"return := self objectClass basicNew"
		pushLiteralVariable: self objectClass binding;
		send: #basicNew;
		storeTemp: resultVar;
		popTop;
		"return instVarAt: (index of argName) put: tmpResult"
		pushTemp: resultVar;
		pushLiteral: (self objectClass 
			instVarIndexFor: #handle 
			ifAbsent: [ self error: 'No handle instVar' ]);
		pushTemp: #tmpResult;
		send: #instVarAt:put:;
		pushTemp: resultVar;
		returnTop	! !

!FFIVoid methodsFor: 'accessing' stamp: ''!
externalTypeSize 
	self pointerArity < 1 ifTrue: [ ^ self error: 'void has unknown size' ].
	^ self pointerSize ! !

!FFIVoid class methodsFor: 'accessing' stamp: ''!
externalType 
	^ ExternalType void! !

!FFIWin64CallbackArgumentReader commentStamp: ''!
I am the responsible to parse the callback arguments in Win64.
In Win64 the structures are always passed by reference. 
The first 4 parameters are passed in the registry. 
If the parameter is an integer, it is in the integer registers (general purpouse registers).
If the parameter is a float, it is in the float registers (SSE registers).

The first parameter is always in the first register of the set, the second always in the second register, etc. Following the type of arguments.

Ex: 

int f( int a, float b, char c)

The parameter a is in the first integer register, the parameter b is in the second float register, and the parameter c is in the third integer register.

The fifth and following parameters are passed in the stack.
If any of the four first parameters does not fit in the registers are passed in the stack.!
!FFIWin64CallbackArgumentReader methodsFor: 'types' stamp: ''!
stackIntegerType
	
	^ FFIInt64 new! !

!FFIWin64CallbackArgumentReader methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	currentParameterIndex := 1.! !

!FFIWin64CallbackArgumentReader methodsFor: 'calculating-offsets' stamp: ''!
nextBaseAddressForStructure: type

	self error: 'The structures all always pointers'! !

!FFIWin64CallbackArgumentReader methodsFor: 'initialization' stamp: ''!
extractNext: aType

	super extractNext: aType.
	currentParameterIndex := currentParameterIndex + 1.! !

!FFIWin64CallbackArgumentReader methodsFor: 'accessing' stamp: ''!
currentParameterIndex
	
	^ currentParameterIndex! !

!FFIWin64CallbackArgumentReader methodsFor: 'types' stamp: ''!
stackUnsignedIntegerType
	
	^ FFIUInt64 new! !

!FFIWin64CallbackArgumentReader methodsFor: 'accessing' stamp: ''!
integerRegisterPointer
	
	^ callbackContext intregargsp! !

!FFIWin64CallbackArgumentReader methodsFor: 'accessing' stamp: ''!
numberOfRegisters
	
	"Win64 only uses 4 registers (integer or float), but never more"
	^ 4! !

!FFIWin64CallbackArgumentReader methodsFor: 'extracting' stamp: ''!
extractStructType: type 
	
	| pointer |
	
	"The struct are always preallocated by the caller and they pass as a pointer."
	
	pointer := self basicExtractPointer.
	self addArgument: (type handle: pointer at: 1).! !

!FFIWin64CallbackArgumentReader methodsFor: 'calculating-offsets' stamp: ''!
nextBaseAddressFor: type
	
	| baseAddressToRead offsetOfBaseAddress |
	
	^ (self currentParameterIndex <= self numberOfRegisters and: [ type typeSize <= 8])
		ifTrue:[ 
				"If the parameter is a floating point parameter it comes in the floating point set of registers, not in the general purpose ones."
				baseAddressToRead := type isFloatType ifTrue: [self floatRegisterPointer] ifFalse: [self integerRegisterPointer].
				offsetOfBaseAddress := (self currentParameterIndex - 1) * Smalltalk wordSize + 1.
				currentStackOffset := currentStackOffset + Smalltalk wordSize.
				{ baseAddressToRead. offsetOfBaseAddress }] 
		ifFalse:[ super nextBaseAddressFor: type ].

! !

!FFIWin64CallbackArgumentReader methodsFor: 'accessing' stamp: ''!
floatRegisterPointer
	
	^ callbackContext floatregargsp! !

!FFIWindowsLibraryFinder commentStamp: ''!
I find libraries in a Windows system.!
!FFIWindowsLibraryFinder methodsFor: 'accessing' stamp: ''!
knownPaths
		
	^ (OSEnvironment current at: 'PATH' ifAbsent: [ '' ]) substrings: ';'! !

!FFIWindowsLibraryFinder methodsFor: 'accessing' stamp: ''!
basePaths

	^ {
	Smalltalk imageDirectory fullName.
	Smalltalk vm directory }! !

!FFI_i386 commentStamp: ''!
I represent i386 architectures.!
!FFI_i386 methodsFor: 'default abi' stamp: ''!
returnSingleFloatsAsDoubles
	^ true! !

!FFI_i386 methodsFor: 'callback' stamp: ''!
newCallbackArgumentReaderForCallback: aCallback inContext: aCallbackContext

	^ FFIi386CallbackArgumentReader
		forCallback: aCallback
		inContext: aCallbackContext! !

!FFI_i386 class methodsFor: 'testing' stamp: ''!
isActive
	^ Smalltalk vm wordSize = 4! !

!FFI_x86_64 commentStamp: ''!
I represent x86_64 architectures.!
!FFI_x86_64 methodsFor: 'types' stamp: ''!
externalSizeTType
	^ ExternalType unsignedLongLong! !

!FFI_x86_64 methodsFor: 'types' stamp: ''!
externalULongType
	^ ExternalType unsignedLongLong! !

!FFI_x86_64 methodsFor: '*ThreadedFFI-UFFI-Overrides' stamp: ''!
tfexternalSizeTType
	^ TFBasicType uint64! !

!FFI_x86_64 methodsFor: 'types' stamp: ''!
externalLongType
	^ ExternalType signedLongLong! !

!FFI_x86_64 methodsFor: 'default abi' stamp: ''!
returnSingleFloatsAsDoubles
	^ false! !

!FFI_x86_64 class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self name = #FFI_x86_64! !

!FFI_x86_64_SystemV commentStamp: ''!
I represent the X86_64 architecture, using the SystemV ABI.

Parameters passed in integer registers: RDI RSI RDX RCX R8 R9
Parameters passed in floating point registers: XMM0 to XXM7, inclusive
Some small structures are split and passed in registers, according to an algorithm described in the ABI.

These ABI details are very important to keep in mind for receiving callbacks.!
!FFI_x86_64_SystemV methodsFor: 'default abi' stamp: ''!
computeStructureRegisterPassingLayout: aStructureClass
	| layout |
	aStructureClass structureSize > self maxStructureSizeToPassInRegisters ifTrue: [ ^ nil ].
	layout := aStructureClass flatStructureLayout sysVAMD64PostProcess.
	^ layout isPassedInMemory ifTrue: [ nil ] ifFalse: [ layout ]! !

!FFI_x86_64_SystemV methodsFor: 'default abi' stamp: ''!
maxStructureSizeToPassInRegisters
	"Four eightbytes according to the ABI documentation."
	^ 16! !

!FFI_x86_64_SystemV methodsFor: 'callbacks' stamp: ''!
newCallbackArgumentReaderForCallback: aCallback inContext: aCallbackContext 

	^ FFISystemV64CallbackArgumentReader
		forCallback: aCallback
		inContext: aCallbackContext! !

!FFI_x86_64_SystemV class methodsFor: 'testing' stamp: ''!
isActive
	^ Smalltalk vm wordSize = 8 and: [ OSPlatform current isWindows not ]! !

!FFI_x86_64_Windows commentStamp: ''!
I represent the X86_64 architecture, using the Windows X64 ABI.

Parameters passed in integer registers: RCX RDX R8 R9
Parameters passed in floating point registers: XMM0 to XMM3, inclusive
Shadow space for spilling registers: 32 bytes.
Structures are never split into registers with this ABI.

These ABI details are very important to keep in mind for receiving callbacks.!
!FFI_x86_64_Windows methodsFor: '*ThreadedFFI-UFFI-Overrides' stamp: ''!
tfBitType

	^ TFBasicType sint32! !

!FFI_x86_64_Windows methodsFor: 'types' stamp: ''!
externalULongType
	^ ExternalType ulong! !

!FFI_x86_64_Windows methodsFor: 'types' stamp: ''!
bitTypeAlignment

	^ OSPlatform current ffiLongAlignment! !

!FFI_x86_64_Windows methodsFor: 'types' stamp: ''!
externalBitType

	^ ExternalType long! !

!FFI_x86_64_Windows methodsFor: 'types' stamp: ''!
externalLongType
	^ ExternalType long! !

!FFI_x86_64_Windows methodsFor: 'types' stamp: ''!
externalUBitType

	^ ExternalType ulong! !

!FFI_x86_64_Windows methodsFor: '*ThreadedFFI-UFFI-Overrides' stamp: ''!
tfUBitType

	^ TFBasicType uint32! !

!FFI_x86_64_Windows methodsFor: 'instance creation' stamp: ''!
newCallbackArgumentReaderForCallback: aCallback inContext: aCallbackContext 

	^ FFIWin64CallbackArgumentReader 
		forCallback: aCallback
		inContext: aCallbackContext! !

!FFI_x86_64_Windows class methodsFor: 'testing' stamp: ''!
isActive
	^ Smalltalk vm wordSize = 8 and: [ OSPlatform current isWindows ]! !

!FFIi386CallbackArgumentReader commentStamp: ''!
I am the subclass responsible of handling i386 parameter passing.
All the parameters in i386 are passed in the stack.
The integer types are promoted to Int32 or UInt32 depending if they are signed or unsigned.
The structs are always passed in the stack.

I do not modify the behavior of my superclass.!
!FFIi386CallbackArgumentReader methodsFor: 'types' stamp: ''!
stackIntegerType
	
	^ FFIInt32 new! !

!FFIi386CallbackArgumentReader methodsFor: 'types' stamp: ''!
stackUnsignedIntegerType
	
	^ FFIUInt32 new! !

!FIFOQueueTest commentStamp: ''!
SUnit tests for FIFO queues!
!FIFOQueueTest methodsFor: 'tests' stamp: ''!
testBasics
	| q |
	q := self newQueue.
	
	q nextPut: 5.
	
	self assert: q peek equals: 5.
	self assert: q nextOrNil equals: 5.
	
	q nextPut: 10.
	q nextPut: 15.
	
	self assert: q nextOrNil equals: 10.
	self assert: q peek equals: 15.
	self assert: q nextOrNil equals: 15.
	
	self assert: q nextOrNil isNil! !

!FIFOQueueTest methodsFor: 'tests' stamp: ''!
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 equals: 10! !

!FIFOQueueTest methodsFor: 'tests' stamp: ''!
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 isNil! !

!FIFOQueueTest methodsFor: 'tests' stamp: ''!
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 ]) equals: 5.	

	9 timesRepeat: [ 
		self assert: (q nextOrNil notNil) ].
	
	self assert: q nextOrNil isNil! !

!FIFOQueueTest methodsFor: 'instance creation' stamp: ''!
newQueue

	^ WaitfreeQueue new! !

!FIFOQueueTest methodsFor: 'tests' stamp: ''!
testContention1
	| q r1 r2 |
	q := AtomicSharedQueue new.
	q nextPut: 5.
	q nextPut: 10.

	self assert: q nextOrNil equals: 5.

	[ r1 := q next ] fork.
	[ r2 := q next ] fork.
	Processor  yield.   "let the above two threads block"
	
	q nextPut: 10.
	Processor yield.

	self assert: r1 equals: 10.
	self assert: r2 equals: 10.
	self assert: q nextOrNil isNil! !

!FIFOQueueTest methodsFor: 'tests' stamp: ''!
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 equals: 1000.
	self assert: q nextOrNil isNil! !

!FIFOQueueTest methodsFor: 'tests' stamp: ''!
testSize
	| q |
	q := self newQueue.
	
	#( 1 2 3 4 5 6 7 8 9 10 ) do: [:each |
		q nextPut: each ].

	self assert: q size equals: 10! !

!FIFOQueueTest methodsFor: 'running' stamp: ''!
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 ]
	]
"! !

!FIFOQueueTest methodsFor: 'running' stamp: ''!
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 equals: 1000! !

!FIFOQueueTest methodsFor: 'tests' stamp: ''!
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 equals: 1000.
	self assert: q nextOrNil isNil! !

!FIFOQueueTest methodsFor: 'tests' stamp: ''!
testNextOrNilSuchThat
	| q item |
	q := self newQueue.
	q nextPut: 5.
	q nextPut: 6.

	item := q nextOrNilSuchThat: [ :x | x even ].
	self assert: item equals: 6.

	self assert: q nextOrNil equals: 5.
	self should: q nextOrNil isNil! !

!FLAbstractCollectionCluster commentStamp: ''!
A FLAbstractCollectionCluster is the common behavior for all cluster collections. !
!FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesOf: anObject with: anEncoder
	| refs |
	refs := self references
		at: anObject
		ifAbsent: [ ^ self ].
	
	anEncoder encodeUint32: refs first.

	refs
		from: 2
		to: refs size
		do: [ :ref | anEncoder encodeReferenceTo: ref ]
	! !

!FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesStepWith: anEncoder

	objects do: [ :anObject | self serializeReferencesOf: anObject with: anEncoder ]! !

!FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesOf: anObject with: aDecoder
	"Hook method"

	self subclassResponsibility! !

!FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anObject with: anEncoder
	anEncoder encodeUint32: anObject size! !

!FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^theClass new: aDecoder nextEncodedUint32! !

!FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesStepWith: aDecoder

	objects do: [ :anObject | self materializeReferencesOf: anObject with: aDecoder ]! !

!FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: ''!
afterMaterializationStepWith: aDecoder  

	objects do: [ :anObject | anObject fuelAfterMaterialization ]! !

!FLAbstractCollectionCluster class methodsFor: 'analyzing' stamp: ''!
clusterBucketIn: aClusterization

	"During the materialization references step, we may send, for example, #hash to the newly materialized objects. #hash can be implemented delegating to OTHER objects which may not have been materialized yet (I mean, its references may not have been set yet). So in this case, we need to let these clusters at the end."
	^aClusterization postBaselevelBucket! !

!FLAnalysis commentStamp: ''!
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: 'mapping' stamp: ''!
privateMapAndTrace: anObject
	"Map an object to its cluster. Trace its references."

	privateFirstMapper mapAndTrace: anObject! !

!FLAnalysis methodsFor: 'accessing' stamp: ''!
clusterization

	^clusterization! !

!FLAnalysis methodsFor: 'hooks' stamp: ''!
fuelAccept: aGeneralMapper
	^ aGeneralMapper visitSubstitution: self by: nil! !

!FLAnalysis methodsFor: 'initialize-release' stamp: ''!
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: 'analyzing' stamp: ''!
run

	objectStack push: root.
	[ objectStack isEmpty ] 
		whileFalse: [ self mapAndTrace: objectStack pop ].
	[ privateObjectStack isEmpty ] 
		whileFalse: [ self privateMapAndTrace: privateObjectStack pop ].! !

!FLAnalysis methodsFor: 'tracing' stamp: ''!
trace: anObject

	objectStack push: anObject! !

!FLAnalysis methodsFor: 'mapping' stamp: ''!
mapAndTrace: anObject
	"Map an object to its cluster. Trace its references."

	firstMapper mapAndTrace: anObject fuelReplacement! !

!FLAnalysis methodsFor: 'tracing' stamp: ''!
privateTrace: anObject

	privateObjectStack push: anObject! !

!FLAnalysis class methodsFor: 'instance creation' stamp: ''!
newWith: aMapper private: privateMapper root: anObject

	^self basicNew
		initializeWith: aMapper private: privateMapper root: anObject;
		yourself.! !

!FLAnalyzer commentStamp: ''!
I am responsible of traversing the graph of references starting from a root object. I will produce a clusterization which the serializer will store on a stream.

An example of use is:

	(FLAnalyzer newDefault 
		clusterizationOf: (Array with: 1@2 with: 3@4))
		clusters.
!
!FLAnalyzer methodsFor: 'configuring' stamp: ''!
when: aCondition substituteBy: aFactory

	pluggableSubstitutions add: aCondition -> aFactory! !

!FLAnalyzer methodsFor: 'configuring' stamp: ''!
globalSymbols
	"Answer the collection of symbols whose associations and values in Smalltalk globals will be considered as globals by Fuel."
	
	^ globalSymbols! !

!FLAnalyzer methodsFor: 'initialization' stamp: ''!
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: 'analyzing' stamp: ''!
lightGlobalMappers

	^ globalSymbols isEmpty
		ifTrue: [ #() ]
		ifFalse: [ Array with: (FLLightGlobalMapper for: globalSymbols in: self globalEnvironment) ]! !

!FLAnalyzer methodsFor: 'protected' stamp: ''!
privateFirstInMapperChain

	^ self privateMappers first
! !

!FLAnalyzer methodsFor: 'protected' stamp: ''!
setDefaultAnalysis

	analysisFactory := [:anObject | 
		(FLAnalysis 
			newWith: self firstInMapperChain 
			private: self privateFirstInMapperChain
			root: anObject)
			run;
			yourself ]! !

!FLAnalyzer methodsFor: 'accessing' stamp: ''!
useLightMappers

	globalMappersFactory := [self lightGlobalMappers].
	generalMapperFactory := [FLLightGeneralMapper new].! !

!FLAnalyzer methodsFor: 'hooks' stamp: ''!
fuelAccept: aGeneralMapper
	^ aGeneralMapper visitSubstitution: self by: nil! !

!FLAnalyzer methodsFor: 'protected' stamp: ''!
mappers

	^ OrderedCollection new
		addAll: self pluggableSubstitutionMappers;
		addAll: self globalMappers;
		add: self generalMapper;
		reduceRight: [:left :right | left next: right ];
		yourself! !

!FLAnalyzer methodsFor: 'accessing' stamp: ''!
globalEnvironment: aDictionary 

	globalEnvironment := aDictionary ! !

!FLAnalyzer methodsFor: 'accessing' stamp: ''!
globalEnvironment
	"Answer a dictionary where the look up for global symbols will be done during serialization."
	
	^ globalEnvironment! !

!FLAnalyzer methodsFor: 'defaults' stamp: ''!
generalMapper

	^generalMapperFactory value! !

!FLAnalyzer methodsFor: 'protected' stamp: ''!
firstInMapperChain

	^ self mappers first
! !

!FLAnalyzer methodsFor: 'configuring' stamp: ''!
considerGlobal: aSymbol 

	globalSymbols add: aSymbol! !

!FLAnalyzer methodsFor: 'accessing' stamp: ''!
globalMappers
	
	^globalMappersFactory value! !

!FLAnalyzer methodsFor: 'analyzing' stamp: ''!
analysisFor: anObject

	^analysisFactory value: anObject! !

!FLAnalyzer methodsFor: 'protected' stamp: ''!
pluggableSubstitutionMappers

	^pluggableSubstitutions collect: [:aLink |
		FLPluggableSubstitutionMapper 
			when: aLink key
			substituteBy: aLink value]! !

!FLAnalyzer methodsFor: 'protected' stamp: ''!
privateMappers

	^ OrderedCollection new
		addAll: self globalMappers;
		add: self generalMapper;
		reduceRight: [:left :right | left next: right ];
		yourself! !

!FLAnalyzer class methodsFor: 'instance creation' stamp: ''!
newDefault
	"Returns an instance with default configuration."

	^self new! !

!FLAnalyzer class methodsFor: 'accessing' stamp: ''!
defaultGlobalSymbols

    ^ #(#Smalltalk #SourceFiles #Transcript #Undeclared #Display #TextConstants #ActiveWorld #ActiveHand #ActiveEvent #Sensor #Processor #SystemOrganization #World) select: [:each | self environment includesKey: each ]! !

!FLBadSignature commentStamp: ''!
I represent an error produced during materialization when the serialized signature doesn't match the materializer's signature (accessible via FLMaterializer>>signature). A signature is a byte prefix that should prefix a well-serialized stream.!
!FLBadSignature class methodsFor: 'signaling' stamp: ''!
signalCurrentSignature: currentSignature streamSignature: streamSignature

	^ self signal: 'Unexpected stream signature ', streamSignature asString, ' where it should be ', currentSignature asString, '.'! !

!FLBadVersion commentStamp: ''!
I represent an error produced during materialization when the serialized version doesn't match the materializer's version (accessible via FLMaterializer>>version). A version is encoded in 16 bits and is enconded heading the serialized stream, after the signature.!
!FLBadVersion class methodsFor: 'signaling' stamp: ''!
signalCurrentVersion: currentVersion streamVersion: streamVersion

	^ self signal: 'Unexpected stream version ', streamVersion asString, ' where it should be ', currentVersion asString, '.'
! !

!FLBasicSerializationTest commentStamp: ''!
SUnit tests for basic fuel serialization!
!FLBasicSerializationTest methodsFor: 'tests-collections-Pharo1.3' stamp: ''!
testSetWithCollectionElement
	(Smalltalk classNamed: #CollectionElement) ifNil: [ self skip ].
	
	self assertSerializationEqualityOf: (Set with: ((Smalltalk classNamed: #CollectionElement) with: 3))! !

!FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: ''!
testLargeNegativeInteger

	self assertSerializationEqualityOf: -354314316134313999999999.
	self assertSerializationEqualityOf: 0-100 factorial.! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testMethodDictionary
	self resultOfSerializeAndMaterializeMethodDictionary: FLPair methodDict.
	! !

!FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: ''!
testSmallIntegerNegative

	self assertSerializationIdentityOf: -42.! !

!FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: ''!
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-collections' stamp: ''!
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 equals: materialized.
	self assert: materialized size equals: 3.
	self assert: (materialized includes: 10).
	self assert: (materialized includes: 20).
	self assert: (materialized includes: 30)! !

!FLBasicSerializationTest methodsFor: 'tests-cycles' stamp: ''!
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' stamp: ''!
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 equals: aWideCharacter.
	self assert: materialized second identicalTo: aByteCharacter! !

!FLBasicSerializationTest methodsFor: 'tests-globals' stamp: ''!
testConsiderCustomGlobal
	"A custom global variable is treated as global by Fuel, when we explicitly specify this."
	
	| aPerson globalKey |
	
	globalKey := #FLGlobalVariableForTesting.
	self analyzer considerGlobal: globalKey.

	aPerson := FLPerson new.
	[ 
		testingEnvironment at: globalKey put: aPerson.
		self assertSerializationIdentityOf: aPerson.
	] ensure: [ testingEnvironment removeKey: globalKey ]
! !

!FLBasicSerializationTest methodsFor: 'tests-strings' stamp: ''!
testWideStringClassName
	| class className |
	className := 'Foox' asWideString
		at: 4 put: (Character value: 265);
		yourself.
	class := Class new setName: className; yourself.
	[
		testingEnvironment at: class name put: class.
		self
			shouldnt: [ self resultOfSerializeAndMaterialize: class ]
			raise: Error
	] ensure:[ testingEnvironment removeKey: class name ]! !

!FLBasicSerializationTest methodsFor: 'tests-fuelAfterMaterialization' stamp: ''!
testExecuteAfterMaterialization
	| anObject result aClass |
	aClass := self newClass
		addInstVarNamed: 'a';
		duringTestCompileSilently: 'fuelAfterMaterialization a := #A';
		yourself.
	anObject := aClass new.

	result := self resultOfSerializeAndMaterialize: anObject.

	self assert: #A equals: (result instVarNamed: 'a')! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
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-strings' stamp: ''!
testRemoteString
	"Tests that the materialized RemoteString has *the same* location on file."

	| aRemoteString materializedRemoteString |
	aRemoteString := SourceFiles remoteStringAt: thisContext method sourcePointer.

	materializedRemoteString := self resultOfSerializeAndMaterialize: aRemoteString.

	self assert: aRemoteString string equals: materializedRemoteString string.
	self assert: aRemoteString sourcePointer identicalTo: materializedRemoteString sourcePointer! !

!FLBasicSerializationTest methodsFor: 'tests-globals' stamp: ''!
testSmalltalkGlobals
	"Smalltalk globals should be global by default."

	self assertSerializationIdentityOf: Smalltalk globals! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
testTime

	self assertSerializationEqualityOf: (Time fromSeconds: 84072).
	self assertSerializationEqualityOf:
		(Time hour: 0 minute: 0 second: 0).
	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-cycles' stamp: ''!
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 identicalTo: materializedA! !

!FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: ''!
testSmallIntegerMinValue

	self assertSerializationIdentityOf: SmallInteger minVal ! !

!FLBasicSerializationTest methodsFor: 'tests-globals' stamp: ''!
testClassSideCompiledMethod
	"They should be considered as globals by default."
	
	self assertSerializationIdentityOf: FLGlobalSendMock class >> #newInstanceToSerialize
! !

!FLBasicSerializationTest methodsFor: 'tests-strings' stamp: ''!
testSymbol

	self assertSerializationIdentityOf: #testSymbol.
	self assertSerializationIdentityOf: #with:with:with:with:.
	self assertSerializationIdentityOf: #'hello there'.! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
testTrue

	self assertSerializationIdentityOf: true! !

!FLBasicSerializationTest methodsFor: 'failures' stamp: ''!
expectedFailures
	^ #(testConsiderCustomWideSymbolGlobal testWideStringGlobal testWideStringClassName)! !

!FLBasicSerializationTest methodsFor: 'running' stamp: ''!
tearDown
	DateAndTime localTimeZone: currentTimeZone.
	super tearDown! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
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-globals' stamp: ''!
testGlobalClass
	"A class should be global by default."
	
	self assertSerializationIdentityOf: Integer.
! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testRunArray

	self assertSerializationEqualityOf: (RunArray runs: #(1 2 1) values: #(1 2 3))
! !

!FLBasicSerializationTest methodsFor: 'tests-cycles' stamp: ''!
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 identicalTo: materializedA.
	self deny: materializedA nextLink identicalTo: materializedA.
	self deny: materializedA nextLink nextLink identicalTo: materializedA! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testArray
	self assertSerializationEqualityOf: #(1).
	self assertSerializationEqualityOf: #(10 20).
	self assertSerializationEqualityOf: #(1 2 3 #('Hello' 2 3)).
	

! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
testLotsOfNils

	self assertSerializationEqualityOf: (Array new: 1 << 16).! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
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: ''!
testColor

	self assertSerializationEqualityOf: Color blue.
	self assertSerializationEqualityOf: Color black.
	! !

!FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: ''!
testSmallIntegerMaxValue

	self assertSerializationIdentityOf: SmallInteger maxVal .
	! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
testPair

	self assertSerializationEqualityOf:
			(FLPair new
				left: 10;
				right: 20;
				yourself)! !

!FLBasicSerializationTest methodsFor: 'tests-globals' stamp: ''!
testDontConsiderCustomGlobal
	"A custom global variable is not treated as global by Fuel, unless we explicitly specify this."

	| aPerson globalName |
	aPerson := FLPerson new.
	globalName := #FLGlobalVariableForTesting.

	[ testingEnvironment at: globalName put: aPerson.
	self deny: (self resultOfSerializeAndMaterialize: aPerson) identicalTo: aPerson ]
		ensure: [ testingEnvironment removeKey: globalName ]! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
testFalse

	self assertSerializationIdentityOf: false! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
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-cycles' stamp: ''!
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 equals: 3.
	self assert: materializedA nextLink nextLink nextLink identicalTo: materializedA.
	self deny: materializedA nextLink identicalTo: materializedA.
	self deny: materializedA nextLink nextLink identicalTo: materializedA! !

!FLBasicSerializationTest methodsFor: 'tests-strings' stamp: ''!
testWideString
	self 
		shouldnt: [
			self assertSerializationEqualityOf: 'aString' asWideString.
			self assertSerializationEqualityOf: (WideString
				streamContents: [ :stream |
					2000 timesRepeat: [
						stream nextPut: (256 to: 1000) atRandom asCharacter ] ]) ]
		raise: Error! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
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-collections' stamp: ''!
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-globals' stamp: ''!
testCompiledMethod
	"They should be considered as globals by default."
	
	self assertSerializationIdentityOf: FLPair >> #left
! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testEmptySet

	self assertSerializationEqualityOf: Set new! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
testLotsOfCharacters

	| all |
	all := OrderedCollection new.
	(1 << 16) timesRepeat: [
	all add: (1 to: 255 ) atRandom asCharacter ].
	self assertSerializationEqualityOf: all.! !

!FLBasicSerializationTest methodsFor: 'tests-strings' stamp: ''!
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-collections' stamp: ''!
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) equals: 4324.
	self assert: (materialized at: 2) equals: 5674.
	self assert: (materialized at: 3) equals: 8978! !

!FLBasicSerializationTest methodsFor: 'tests-collections-Pharo1.3' stamp: ''!
testCollectionElement
	(Smalltalk classNamed: #CollectionElement) ifNil: [ self skip ].
	
	self assertSerializationEqualityOf: ((Smalltalk classNamed: #CollectionElement) with: 3)! !

!FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: ''!
testLargePositiveInteger

	self assertSerializationEqualityOf: 354314316134313999999999.
	self assertSerializationEqualityOf: 100 factorial.
	! !

!FLBasicSerializationTest methodsFor: 'tests-not-so-basic' stamp: ''!
testGradientFillStyle

	self assertSerializationEqualityOf: GradientFillStyle sample! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
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.
	
	FLPlatform current isSpur 
		ifTrue: [
			self assertSerializationIdentityOf: (Character value: 12345). "Japanese Hiragana 'A' " ]
		ifFalse: [
			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: ''!
testUUID

	self assertSerializationEqualityOf: (UUID fromString: 'a3b64357-377a-5b41-b575-1c653084a121').
	self assertSerializationEqualityOf: UUID nilUUID.
	self assertSerializationEqualityOf: UUID new.
	! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testWordArray

	self assertSerializationEqualityOf: (WordArray with: 10 with: 20)! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
testSharedReferences
	| sharedObject point1 point2 materialized array |
	sharedObject := SmallInteger maxVal + 1.
	point1 := Point x: sharedObject y: SmallInteger maxVal + 2.
	point2 := Point x: SmallInteger maxVal + 2 y: sharedObject.
	array := Array with: point1 with: point2.

	materialized := self resultOfSerializeAndMaterialize: array.
	self assert: array equals: materialized.
	self
		assert: materialized first x == materialized second y
		description: 'An object that is referenced twice by the graph must not be duplicated when materialized'.
	self deny: materialized first y == materialized second x description: 'Two (non-literal) objects must maintain different identity even if they are equal'! !

!FLBasicSerializationTest methodsFor: 'tests-globals' stamp: ''!
testSystemDictionary
	"We want to treat the <Smalltalk globals> instance of SystemDictionary
	specially but want to serialize all others"

	self assertSerializationEqualityOf: SystemDictionary new! !

!FLBasicSerializationTest methodsFor: 'tests-globals' stamp: ''!
testConsiderCustomWideSymbolGlobal
	"The same than #testConsiderCustomGlobal but with a WideSymbol."
	
	| aWideSymbol aPerson |
	aWideSymbol := (WideString streamContents: [ :stream |
		256 to: 280 do: [ :code | stream nextPut: code asCharacter ] ]) asSymbol.

	self analyzer considerGlobal: aWideSymbol.

	aPerson := FLPerson new.	
	[ 
		testingEnvironment at: aWideSymbol put: aPerson.
		self
			shouldnt: [ self resultOfSerializeAndMaterialize: aPerson ]
			raise: Error
	] ensure: [ 
		testingEnvironment removeKey: aWideSymbol ].
! !

!FLBasicSerializationTest methodsFor: 'tests-strings' stamp: ''!
testWideStringGlobal
	| global globalValue |
	global := 'Foox' asWideString
		at: 4 put: (Character value: 265);
		yourself.
	globalValue := global , 'value'.
	[ testingEnvironment at: global put: globalValue.
	self analyzer considerGlobal: global.

	self shouldnt: [ self serialize: 'bar' -> globalValue ] raise: Error.
	self assert: self materialized class equals: Association.
	self assert: self materialized value identicalTo: global ]
		ensure: [ testingEnvironment removeKey: global ]! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
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: ''!
testDateAndTimeOffsetNegative
	| edt now |
	edt := TimeZone timeZones last.
	
	DateAndTime localTimeZone: edt.
	now := DateAndTime now.
	self assert: now offset equals: -4 hours.
	self serialize: now.

	self assert: self materialized offset equals: -4 hours! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testEmptyArray
	self assertSerializationEqualityOf: #()! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testByteArrays

	self assertSerializationEqualityOf: { #[1 2 3 4 5 6]. #[1 2 3 4 5 6]. #[7 8 9 10 11 12]. #[7 8 9 10 11 12] }.
	self assertSerializationEqualityOf:  (ByteArray with: 10 with: 20 with: 30).
	self assertSerializationEqualityOf: ByteArray new.
	self assertSerializationEqualityOf: (ByteArray new: 100).
	self assertSerializationEqualityOf: (0 to: 255) asByteArray.! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
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-streams' stamp: ''!
testReadStream
	| aReadStream materialized |
	aReadStream := ReadStream on: 'A'.

	materialized := self resultOfSerializeAndMaterialize: aReadStream.

	self assert: $A equals: aReadStream next.

	self deny: materialized atEnd.
	self assert: $A equals: materialized next.
	self assert: materialized atEnd! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testOrderedCollection

	self assertSerializationEqualityOf: (OrderedCollection with: 10 with: 20)! !

!FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: ''!
testSmallInteger

	self assertSerializationIdentityOf: -1212.
	self assertSerializationIdentityOf: 7.
	self assertSerializationIdentityOf: 0.
	self assertSerializationIdentityOf: 1111.
	self assertSerializationIdentityOf: SmallInteger one.

! !

!FLBasicSerializationTest methodsFor: 'tests-collections-Pharo1.3' stamp: ''!
testSetWithNil

	self assertSerializationEqualityOf: (Set with: nil)! !

!FLBasicSerializationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	currentTimeZone := DateAndTime localTimeZone.! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testEmptyOrderedCollection

	self assertSerializationEqualityOf: OrderedCollection new! !

!FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: ''!
testAllRangeOfIntegers

	1 to: 100 do: [:shift |
		self assertSerializationEqualityOrIdentityOf: 1 << shift.
		self assertSerializationEqualityOrIdentityOf: 0 - (1 << shift) ]
! !

!FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: ''!
testFloat
	{180.0.
	0.0.
	-0.0.
	11.22321.
	-11.22321.
	-132311.22321.
	1234567890.123456789.
	-1234567890.123456789.
	Float e.
	Float infinity.
	Float halfPi.
	Float negativeZero.
	Float halfPi.
	Float pi} 
		do: [ :aFloat | self assertSerializationEqualityOrIdentityOf: aFloat ]! !

!FLBasicSerializationTest methodsFor: 'tests-streams' stamp: ''!
testWriteStream
	| aWriteStream materialized |
	aWriteStream := WriteStream on: (ByteArray new: 1).

	materialized := self resultOfSerializeAndMaterialize: aWriteStream.

	aWriteStream nextPut: 1.
	self assert: 1 equals: aWriteStream size.

	self assert: 0 equals: materialized size.
	materialized nextPut: 2.
	self assert: (Array with: 2) equals: materialized contents asArray! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
testDateAndTime

	| initialTime initialDate |
	initialTime := Time fromSeconds: 76020.
	initialDate := Date fromSeconds: 3492288000.
	self assertSerializationEqualityOf:
		(DateAndTime date: initialDate time: initialTime).

	initialTime := Time hour: 0 minute: 0 second: 0.
	initialDate := Date year: 3050 month: 12 day: 31.
	self assertSerializationEqualityOf:
		(DateAndTime date: initialDate time: initialTime).

	initialTime := Time hour: 0 minute: 0 second: 0.
	initialDate := Date year: 1600 month: 12 day: 31.
	self assertSerializationEqualityOf:
		(DateAndTime date: initialDate time: initialTime)! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testDictionary

	self assertSerializationEqualityOf: (Dictionary with: 1->2).! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
testNil

	self assertSerializationIdentityOf: nil! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
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-cycles' stamp: ''!
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 equals: 10.
	self assert: materialized second equals: 20.
	self assert: materialized third identicalTo: materialized! !

!FLBasicSerializationTest methodsFor: 'tests-not-so-basic' stamp: ''!
testNotSerializableObject

	self 
		should: [ self serialize: FLNotSerializableMock new ] 
		raise: FLNotSerializable
		whoseDescriptionIncludes: FLNotSerializableMock new printString
		description: 'User can prevent some objects from serialization.'! !

!FLBasicSerializationTest methodsFor: 'tests-graph-modification' stamp: ''!
testFuelReplacement
	| object |
	self 
		assert: (self resultOfSerializeAndMaterialize: FLReplacementClassMock)
		equals: nil.
		
	self
		assert: (self resultOfSerializeAndMaterialize: {FLReplacementClassMock})
		equals: { nil }.

	object := FLReplacementMock new
		ignoreMe;
		yourself.
	self 
		assert: (self resultOfSerializeAndMaterialize: {object})
		equals: { nil }.
		
	object dontIgnoreMe.
	self 
		assert: (self resultOfSerializeAndMaterialize: {object})
		equals: { object }! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
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 equals: materialized.
	self assert: materialized size equals: 4! !

!FLBasicSerializationTest methodsFor: 'tests-collections' stamp: ''!
testEmptyDictionary

	self assertSerializationEqualityOf: Dictionary new! !

!FLBasicSerializationTest methodsFor: 'tests-globals' stamp: ''!
testGlobalMetaclass
	"A metaclass should be global by default."
	
	self assertSerializationIdentityOf: Integer class.
! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
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: ''!
testDuration
	
	self assertSerializationEqualityOf: 123 seconds.
	self assertSerializationEqualityOf: -123 seconds.
	self assertSerializationEqualityOf: (
		Duration 
			seconds: 3 
			nanoSeconds: 35).
	
! !

!FLBasicSerializationTest methodsFor: 'tests' stamp: ''!
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-numbers' stamp: ''!
testSmallIntegerSerializationForAllBits
	1
		to: 64
		do: [ :exp |
			| integer |
			integer := 2 raisedTo: exp.
			integer isLarge ifFalse: [
				self assertSerializationIdentityOf: integer ].
			integer := 0 - integer.
			integer isLarge ifFalse: [
				self assertSerializationIdentityOf: integer ] ]

! !

!FLBasicSerializationTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors 
	^true! !

!FLBinaryFileStreamBasicSerializationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self useBinaryFileStream
! !

!FLBinaryFileStreamStrategy commentStamp: ''!
Specific to BinaryFileStream!
!FLBinaryFileStreamStrategy methodsFor: 'test support' stamp: ''!
tearDown
	FLPlatform current deleteFileNamed: self fileName! !

!FLBinaryFileStreamStrategy methodsFor: 'test support' stamp: ''!
fileName
	"Answer a filename to serialize and materialize using it."

	^ FLPlatform current absolutePathOf: (FLPlatform current imageName, '-tests.fuel')! !

!FLBinaryFileStreamStrategy methodsFor: 'writing' stamp: ''!
writeStreamDo: aValuable
	"Evaluates the argument with a write stream. Answers the result."

	^ FLPlatform current
		fileNamed: self fileName
		writeStreamDo: [ :aStream | 
			aValuable value: aStream binary ]! !

!FLBinaryFileStreamStrategy methodsFor: 'reading' stamp: ''!
readStreamDo: aValuable
	"Evaluates the argument with a read stream. Answers the result."
	
	^ FLPlatform current
		fileNamed: self fileName
		readStreamDo: [ :aStream |
			aValuable value: aStream binary ]! !

!FLBitsObjectCluster commentStamp: ''!
I have the common behavior for generic storing and loading variable bits objects.!
!FLBitsObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
registerIndexesOn: anEncoder

	self flag: #pharoTodo. "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: anEncoder! !

!FLBitsObjectCluster methodsFor: 'analyzing' stamp: ''!
newAnalyzingCollection
	"Answer a collection for the objects that correspond to this cluster."

	^OrderedCollection new! !

!FLBitsObjectCluster methodsFor: 'analyzing' stamp: ''!
add: anObject traceWith: aAnalysis
	"Add an object to the cluster. We know the object doesn't have references."

	objects addLast: anObject! !

!FLBlockClosureSerializationTest commentStamp: ''!
SUnit tests for fuel serialization of block closures!
!FLBlockClosureSerializationTest methodsFor: 'tests-unclean' stamp: ''!
testBlockClosureWithSelfSend
	| closure materializedClosure |
	closure := self class blockClosureWithSelfSend.
	materializedClosure := self resultOfSerializeAndMaterialize: closure.
	closure assertWellMaterializedInto: materializedClosure in: self.
	self assert: materializedClosure value equals: closure value! !

!FLBlockClosureSerializationTest methodsFor: 'tests-clean' stamp: ''!
testNestedBlockClosure
	| closure materializedClosure |
	closure := [ [ 42 ] ].
	materializedClosure := self resultOfSerializeAndMaterialize: closure.
	closure assertWellMaterializedInto: materializedClosure in: self.
	self assert: materializedClosure value value equals: 42! !

!FLBlockClosureSerializationTest methodsFor: 'tests-clean' stamp: ''!
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) equals: 6! !

!FLBlockClosureSerializationTest methodsFor: 'tests-clean' stamp: ''!
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: ''!
testBlockClosureWithGlobalVariable
	| closure materializedClosure |
	closure := [ Smalltalk ].
	materializedClosure := self resultOfSerializeAndMaterialize: closure.
	closure assertWellMaterializedInto: materializedClosure in: self.
	self assert: materializedClosure value equals: Smalltalk! !

!FLBlockClosureSerializationTest methodsFor: 'tests-clean' stamp: ''!
testBlockClosureWithTempVariableRead
	| closure materializedClosure |
	closure := self class blockClosureWithTempVariableRead.
	materializedClosure := self resultOfSerializeAndMaterialize: closure.
	closure assertWellMaterializedInto: materializedClosure in: self.
	self assert: materializedClosure value equals: 'TEST'! !

!FLBlockClosureSerializationTest methodsFor: 'tests-change' stamp: ''!
testBlockClosureMaterializesClassVariablesCorrectly
	| class closure method |
	class := (self
		newSubclassOf: Object
		instanceVariableNames: ''
		classVariableNames: 'ClassVariableForTesting')
			duringTestCompileSilently: 'methodWithClosure  ^ [ ClassVariableForTesting ]';
			yourself.
	"Make sure we don't use global clusters here, which would simply perform a lookup"
	method := class methodNamed: #methodWithClosure.
	closure := method
		valueWithReceiver: class new
		arguments: #().
	class removeSelectorSilently: #methodWithClosure.
	self deny: method isInstalled.
	self deny: closure compiledBlock isInstalled.
	
	self serialize: closure.
	
	self
		assert: (self materialized compiledBlock literalAt: 1)
		equals: (class bindingOf: 'ClassVariableForTesting').
	self
		deny: (self materialized compiledBlock literalAt: 1)
		identicalTo: (class bindingOf: 'ClassVariableForTesting')! !

!FLBlockClosureSerializationTest methodsFor: 'tests-change' stamp: ''!
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 equals: 42! !

!FLBlockClosureSerializationTest methodsFor: 'tests-change' stamp: ''!
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: ''!
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 class methodsFor: 'closures for testing' stamp: ''!
blockClosureWithTempVariableRead
	| string |
	string := 'test'.
	^ [ string asUppercase ].! !

!FLBlockClosureSerializationTest class methodsFor: 'closures for testing' stamp: ''!
blockClosureWithSelfSend
	^ [ self printString ]! !

!FLBufferedWriteStream commentStamp: ''!
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: ''!
bufferFreeSize
	^ buffer size - position! !

!FLBufferedWriteStream methodsFor: 'accessing' stamp: ''!
position
	^ position + stream position! !

!FLBufferedWriteStream methodsFor: 'initialize-release' stamp: ''!
initializeOn: writeStream bufferSize: aSize

	self initialize.
	self initializeStream: writeStream.
	self sizeBuffer: aSize.
	position := 0.! !

!FLBufferedWriteStream methodsFor: 'private' stamp: ''!
copyWordObjectToBuffer: aWordObject
	| blt |
	blt := (BitBlt
		toForm: (Form new hackBits: self buffer))
		sourceForm: (Form new hackBits: aWordObject).
	blt combinationRule: Form over. "store"
	blt 
		sourceX: 0;
		sourceY: 0;
		height: aWordObject byteSize // 4;
		width: 4.
	blt 
		destX: 0;
		destY:  position // 4.
	blt copyBits! !

!FLBufferedWriteStream methodsFor: 'initialize-release' stamp: ''!
initializeStream: aWriteStream
	stream := aWriteStream.
	"This is ugly, but it is an optimization for #flushBuffer"
	streamRespondsToNextPutAllStartingAt := (stream respondsTo: #next:putAll:startingAt:).! !

!FLBufferedWriteStream methodsFor: 'private' stamp: ''!
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: 'printing' stamp: ''!
printOn: aStream
	aStream 
		nextPutAll: 'a '; 
		nextPutAll: self class name! !

!FLBufferedWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: object
	self flushBufferIfFull.
	position := position + 1.
	self buffer at: position put: object ! !

!FLBufferedWriteStream methodsFor: 'writing' stamp: ''!
nextBytesPutAll: collection
	self flushBufferIfFull.
	collection size <= self bufferFreeSize
		ifTrue: [
			self buffer replaceFrom: position + 1 to: position + collection size with: collection.
			position := position + collection size ]
		ifFalse: [
			self flushBuffer.
			collection size > (self buffer size / 2)
				ifTrue: [ stream nextBytesPutAll: collection ]
				ifFalse: [ self nextBytesPutAll: collection ] ]
! !

!FLBufferedWriteStream methodsFor: 'accessing' stamp: ''!
sizeBuffer: size
    buffer ifNotNil: [self flushBuffer].
    buffer := (stream isBinary ifTrue: [ ByteArray ] ifFalse: [ String ]) new: size
! !

!FLBufferedWriteStream methodsFor: 'file open/close' stamp: ''!
close
	self flushBuffer.
	stream close! !

!FLBufferedWriteStream methodsFor: 'private' stamp: ''!
buffer
	buffer ifNil: [ self sizeBuffer: self defaultBufferSize ].
	^ buffer! !

!FLBufferedWriteStream methodsFor: 'accessing' stamp: ''!
flush
	self flushBuffer.
	stream flush! !

!FLBufferedWriteStream methodsFor: 'private' stamp: ''!
flushBufferIfFull
	position = buffer size 
		ifTrue: [ self flushBuffer ]
! !

!FLBufferedWriteStream methodsFor: 'accessing' stamp: ''!
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: 'writing' stamp: ''!
nextWordsPut: aWordObject

	| byteSize |
	byteSize := aWordObject basicSize * 4.

	"Ensure we are at bigger than the words added, with size next power-of-two"
	byteSize > buffer size ifTrue: [ self sizeBuffer: 1 << (byteSize highBit)].
	
	"BitBlt needs word-aligned access of object. Flushing the buffer is a very good idea because after the position will be zero, which is word aligned.  Word objects always have a full number of words of data to write. (otherwise they'd be variableByte objects or something :P) So as long as the size you write per instance also takes N words, the position will always be aligned (except when writing the first object of a cluster) . After that, we flush when an object larger than current buffer is encountered (statistically rare), or if the buffer is full (which we do anyways).
	Finally, we also need enough free space in the buffer"
	((position bitAnd: 3) = 0 and: [byteSize < self bufferFreeSize])
      	ifFalse: [self flushBuffer].

	self copyWordObjectToBuffer: aWordObject.
	position := position +  byteSize.! !

!FLBufferedWriteStream methodsFor: 'accessing' stamp: ''!
defaultBufferSize
	^ 8192 "2 raisedTo: 13  "
	

! !

!FLBufferedWriteStream class methodsFor: 'instance creation' stamp: ''!
on: writeStream 

	^ self on: writeStream bufferSize: self defaultBufferSize! !

!FLBufferedWriteStream class methodsFor: 'instance creation' stamp: ''!
on: writeStream bufferSize: aSize
	^ self basicNew
		initializeOn: writeStream 
		bufferSize: aSize;
		yourself! !

!FLBufferedWriteStream class methodsFor: 'accessing' stamp: ''!
defaultBufferSize 
	^ 4096! !

!FLByteArrayBasicSerializationTest commentStamp: ''!
SUnit tests for basic in memory serialization!
!FLByteArrayBasicSerializationTest methodsFor: 'failures' stamp: ''!
expectedFailures
	^ super expectedFailures, #(testConsiderCustomWideSymbolGlobal)! !

!FLByteArrayBasicSerializationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	self useByteArrayStream! !

!FLByteArrayStreamStrategy commentStamp: ''!
I am a strategy that emulate what we offer with FLSerializer class >> #serializeInMemory:  and  FLMaterializer class >> #materializeFromByteArray: !
!FLByteArrayStreamStrategy methodsFor: 'writing' stamp: ''!
writeStreamDo: aValuable
	"Evaluates the argument with a write stream. Answers the result."
	
	inMemoryStream := ByteArray new writeStream.
	^aValuable value: inMemoryStream binary
! !

!FLByteArrayStreamStrategy methodsFor: 'reading' stamp: ''!
readStreamDo: aValuable
	"Evaluates the argument with a read stream. Answers the result."
	
	^aValuable value: inMemoryStream contents readStream! !

!FLByteObjectCluster commentStamp: ''!
I am the generic cluster for storing and loading variable byte objects.!
!FLByteObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anObject with: anEncoder
	anEncoder
		encodeUint32: anObject basicSize;
		encodeBytes: anObject! !

!FLByteObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	| instance size |
	size := aDecoder nextEncodedUint32.
	instance := theClass basicNew: size.
	aDecoder nextEncodedBytesInto: instance.
	^ instance
! !

!FLCharacter32Cluster commentStamp: ''!
I'm a cluster for Unicode characters.!
!FLCharacter32Cluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: aCharacter with: anEncoder

	anEncoder encodeUint32: aCharacter asciiValue! !

!FLCharacter32Cluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^ Character value: aDecoder nextEncodedUint32! !

!FLClassNotFound commentStamp: ''!
I represent an error produced during materialization when a serialized class or trait name doesn't exist.!
!FLClassNotFound class methodsFor: 'signaling' stamp: ''!
signalWithName: className
	^ self signal: 'Class named ', className printString, ' not found.'! !

!FLClassSerializationTest commentStamp: ''!
I have the common behavior for testing class serialization.!
!FLClassSerializationTest methodsFor: 'running' stamp: ''!
newClassWithInstanceVariableNames: instanceVariableNames
	"Returns a class for testing, with the specified instance variables."

	^ self newClassWithInstanceVariableNames: instanceVariableNames superclass: Object! !

!FLClassSerializationTest methodsFor: 'running' stamp: ''!
newClassWithInstanceVariableNames: instanceVariableNames superclass: aSuperclass
	"Returns a class for testing, with the specified instance variables."

	^ self 
		newSubclassOf: aSuperclass
		instanceVariableNames: instanceVariableNames
		classVariableNames: ''! !

!FLClassSerializationTest methodsFor: 'tests' stamp: ''!
during: aBlock rename: aClass as: anotherClass

	[ testingEnvironment at: aClass name put: anotherClass.
	^aBlock value ] ensure: [ 
	testingEnvironment at: aClass name put: aClass ].! !

!FLClassSerializationTest methodsFor: 'running' stamp: ''!
newSecondaryTrait
	"Returns a trait for testing"

	^ self newTraitSuffixed: 'Secondary'! !

!FLClassSerializationTest methodsFor: 'tests' stamp: ''!
newClassOrTraitWithSuperClass: superclass
	"Returns a class for testing"

	^ self newClassWithInstanceVariableNames: '' superclass: superclass! !

!FLClassSerializationTest methodsFor: 'tests' stamp: ''!
newClassOrTrait
	"Returns a class for testing"

	^ self newClassWithInstanceVariableNames: ''! !

!FLClassSerializationTest methodsFor: 'tests' stamp: ''!
newInstanceFrom: aClass

	^ aClass new! !

!FLClassWithRecursiveSubstitution commentStamp: ''!
A test mock for a class with recursive substitution!
!FLClassWithRecursiveSubstitution methodsFor: 'serialization' stamp: ''!
fuelAccept: aGeneralMapper

	^ index < 10
		ifTrue: [
			aGeneralMapper 
				visitSubstitution: self 
				by: (self copy index: self index + 1)
				onRecursionDo: [ super fuelAccept: aGeneralMapper ] ]
		ifFalse: [
			super fuelAccept: aGeneralMapper ]! !

!FLClassWithRecursiveSubstitution methodsFor: 'accessing' stamp: ''!
index: anObject
	index := anObject ! !

!FLClassWithRecursiveSubstitution methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!FLCluster commentStamp: ''!
I represent a cluster of objects grouped by some specific similarity. I know how to serialize and materialize them all together.!
!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
registerIndexesOn: anEncoder
	"Maps objects with indexes in the dictionary."! !

!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
serializePostInstancesStepWith: anEncoder
! !

!FLCluster methodsFor: 'initialize-release' stamp: ''!
initializeMaterializing

	self initialize.! !

!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstancesStepWith: anEncoder
! !

!FLCluster methodsFor: 'initialize-release' stamp: ''!
initializeAnalyzing

	self initialize.! !

!FLCluster methodsFor: 'hooks' stamp: ''!
fuelAccept: aGeneralMapper
	^ aGeneralMapper visitSubstitution: self by: nil! !

!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
prepareObjectsStep
	"Prepare for Fuel serialization."! !

!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesStepWith: anEncoder
! !

!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
clusterMaterializeStepWith: aMaterialization
	"Materialize cluster stuff"
! !

!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
materializePostInstancesStepWith: aDecoder

! !

!FLCluster methodsFor: 'accessing' stamp: ''!
objects
	"Answer the objects that this cluster groups."

	self subclassResponsibility! !

!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
clusterSerializeStepWith: aSerialization
	"Serialize cluster stuff"! !

!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstancesStepWith: aDecoder
! !

!FLCluster methodsFor: 'analyzing' stamp: ''!
clusterReferencesDo: aBlock
	"Evaluate a block with each object referenced by the cluster"! !

!FLCluster methodsFor: 'analyzing' stamp: ''!
traceWith: anAnalysis 

	self clusterReferencesDo: [ :aChild | anAnalysis privateTrace: aChild ]! !

!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesStepWith: aDecoder
! !

!FLCluster methodsFor: 'serialize/materialize' stamp: ''!
afterMaterializationStepWith: aDecoder
! !

!FLCluster class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use another instance creation message.'! !

!FLCluster class methodsFor: 'analyzing' stamp: ''!
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: ''!
newMaterializing

	^ self basicNew
		initializeMaterializing;
		yourself.! !

!FLCluster class methodsFor: 'instance creation' stamp: ''!
newAnalyzing

	^ self basicNew
		initializeAnalyzing;
		yourself.! !

!FLClusterization commentStamp: ''!
I manage the clusters collected during the analysis step of serialization.!
!FLClusterization methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	primitivesBucket := IdentityDictionary new.
	baselevelBucket := IdentityDictionary new.
	globalsBucket := IdentityDictionary new.
	metalevelInstanceSideBucket := IdentityDictionary new.
	metalevelClassSideBucket := IdentityDictionary new.
	substitutionsBucket := IdentityDictionary new.
	postBaselevelBucket := IdentityDictionary new.
! !

!FLClusterization methodsFor: 'cluster buckets' stamp: ''!
metalevelInstanceSideBucket
	
	^ metalevelInstanceSideBucket ! !

!FLClusterization methodsFor: 'hooks' stamp: ''!
fuelAccept: aGeneralMapper
	^ aGeneralMapper visitSubstitution: self by: nil! !

!FLClusterization methodsFor: 'accessing' stamp: ''!
clusters
	
	^self clusterBuckets flatCollect: [:c | c ].
! !

!FLClusterization methodsFor: 'cluster buckets' stamp: ''!
postBaselevelBucket
	
	^ postBaselevelBucket! !

!FLClusterization methodsFor: 'accessing' stamp: ''!
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: 'cluster buckets' stamp: ''!
metalevelClassSideBucket
	
	^ metalevelClassSideBucket! !

!FLClusterization methodsFor: 'cluster buckets' stamp: ''!
substitutionsBucket
	
	^ substitutionsBucket! !

!FLClusterization methodsFor: 'cluster buckets' stamp: ''!
baselevelBucket
	
	^ baselevelBucket! !

!FLClusterization methodsFor: 'cluster buckets' stamp: ''!
globalsBucket
	
	^ globalsBucket ! !

!FLClusterization methodsFor: 'cluster buckets' stamp: ''!
primitivesBucket
	
	^ primitivesBucket! !

!FLClusterization methodsFor: 'accessing' stamp: ''!
objectCount

	^self clusterBuckets sum: [ :aClusterBucket | 
		aClusterBucket
			inject: 0 
			into: [ :sum :aCluster | sum + aCluster objects size ] ].! !

!FLCompiledBlockCluster commentStamp: ''!
I am a cluster for CompiledBlock instances.

Since Pharo 9 blocks can exist independently of an associated compiled method and, hence, require special treatment.!
!FLCompiledBlockCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: aCompiledBlock with: anEncoder
	| header bytecode |
	bytecode := aCompiledBlock bytecode.
	header := aCompiledBlock header.

	self
		encodeHeader: header
		with: anEncoder.
	anEncoder
		encodeUint32: bytecode basicSize;
		encodeBytes: bytecode! !

!FLCompiledBlockCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	| instance size header initialPC |
	header := self decodeHeaderWith: aDecoder.
	size := aDecoder nextEncodedUint32.

	instance := CompiledBlock
		newMethod: size
		header: header.
	initialPC := instance initialPC.
	initialPC
		to: initialPC + size - 1
		do: [ :index |
			instance
				at: index
				put: aDecoder nextEncodedByte ].
	^ instance! !

!FLCompiledCodeCluster commentStamp: ''!
I am the abstract cluster for CompiledCode classes. I implement shared serialization and materialization behavior.

See the class comment of CompiledCode for information on the format.!
!FLCompiledCodeCluster methodsFor: 'analyzing' stamp: ''!
referencesOf: compiledCode do: aBlock
	1
		to: compiledCode numLiterals
		do: [ :index | aBlock value: (compiledCode literalAt: index) ]! !

!FLCompiledCodeCluster methodsFor: 'protected' stamp: ''!
encodeHeader: aSmallInteger with: anEncoder
	"Store the sign bit separately. We can't encoded it within the 32 bit integer because the
	high bit will be truncated.
	See #encodeInt32:."
	anEncoder
		encodeByte: (aSmallInteger < 0
			ifTrue: [ 1 ]
			ifFalse: [ 0 ]);
		encodeInt32: aSmallInteger! !

!FLCompiledCodeCluster methodsFor: 'protected' stamp: ''!
materializeLiteralsTo: compiledCode with: aDecoder
	1
		to: compiledCode numLiterals 
		do: [ :index |
			compiledCode
				literalAt: index
				put: aDecoder nextEncodedReference ]! !

!FLCompiledCodeCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesStepWith: anEncoder
	objects do: [ :compiledCode |
		self
			serializeLiteralsOf: compiledCode
			with: anEncoder ]! !

!FLCompiledCodeCluster methodsFor: 'protected' stamp: ''!
decodeHeaderWith: aDecoder
	| signBit header |
	signBit := aDecoder nextEncodedByte.
	header := aDecoder nextEncodedInt32.

	^ signBit = 1
		ifTrue: [ header + SmallInteger minVal ]
		ifFalse: [ header ]
! !

!FLCompiledCodeCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesStepWith: aDecoder
	objects do: [ :compiledCode |
		self
			materializeLiteralsTo: compiledCode
			with: aDecoder ]! !

!FLCompiledCodeCluster methodsFor: 'protected' stamp: ''!
serializeLiteralsOf: aCompiledBlock with: anEncoder
	1
		to: aCompiledBlock numLiterals 
		do: [ :index |
			anEncoder encodeReferenceTo: (aCompiledBlock literalAt: index) ]! !

!FLCompiledCodeCluster class methodsFor: 'analyzing' stamp: ''!
clusterBucketIn: aClusterization

	^aClusterization primitivesBucket! !

!FLCompiledMethodCluster commentStamp: ''!
I am a cluster for CompiledMethod instances.

How CompiledMethod trailers are serialized can be established using methods in 'configurating' class-side protocol.!
!FLCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: ''!
prepareObjectsStep
	objects do: [ :compiledMethod |
		compiledMethod fuelPrepare ]! !

!FLCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: ''!
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.

	self
		encodeHeader: header
		with: anEncoder.
	anEncoder encodeUint16: bytecodesPlusTrailerSize.	

	cmInitialPC
		to: cmSize
		do: [ :index |	anEncoder encodeByte: (aCompiledMethod at: index) ]! !

!FLCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	| compiledMethod header bytecodesPlusTrailerSize |
	header := self decodeHeaderWith: aDecoder.
	bytecodesPlusTrailerSize := aDecoder nextEncodedUint16.

	compiledMethod := CompiledMethod
			newMethod: bytecodesPlusTrailerSize
			header: header.

	compiledMethod initialPC
		to: compiledMethod size
		do: [ :index |
			compiledMethod
				at: index
				put: aDecoder nextEncodedByte ].
		
	^ compiledMethod! !

!FLCompiledMethodCluster class methodsFor: 'class initialization' stamp: ''!
initialize 
	self setTrailerWithSourceCode! !

!FLCompiledMethodCluster class methodsFor: 'configuring' stamp: ''!
setTrailerWithNoChange
	"Make compiled methods be serialized as they are."

	^ self transformationForSerializing: [:aCompiledMethod | aCompiledMethod ]! !

!FLCompiledMethodCluster class methodsFor: 'accessing' stamp: ''!
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: ''!
transformationForSerializing: aBlockWithOneArgument 
	transformationForSerializing := aBlockWithOneArgument! !

!FLCompiledMethodCluster class methodsFor: 'configuring' stamp: ''!
setTrailerWithNoSource
	"Make compiled methods be serialized without source code."

	^ self transformationForSerializing: [:aCompiledMethod |
		aCompiledMethod copyWithTrailerBytes: CompiledMethodTrailer empty ]! !

!FLCompiledMethodCluster class methodsFor: 'configuring' stamp: ''!
setTrailerWithSourceCode
	"Make compiled methods be serialized with embedded source code."

	^ self transformationForSerializing: [:aCompiledMethod | 
		aCompiledMethod copyWithTrailerBytes: 
			(CompiledMethodTrailer new sourceCode: aCompiledMethod sourceCode) ]! !

!FLCompiledMethodCluster class methodsFor: 'cleanup' stamp: ''!
cleanUp
	self initialize ! !

!FLCompiledMethodSerializationTest methodsFor: 'tests' stamp: ''!
testNotInstalled
	| materialized |
	"Since Pharo 3.0 decompilation of compiled methods is no longer possible.
	That means we have to store the source too."
	self useNotInstalled.
	
	self deny: theCompiledMethod isInstalled.
	self deny: theCompiledMethod isDoIt.
	self deny: theCompiledMethod trailer hasSource.
	self assert: theCompiledMethod trailer isEmpty.
	self deny: theCompiledMethod trailer hasSourcePointer.
	
	materialized := self resultOfSerializeAndMaterialize: theCompiledMethod.
	self deny: materialized isInstalled.
	self deny: materialized isDoIt.
	"we serialized the source"
	self assert: materialized trailer hasSource.
	self deny: materialized trailer isEmpty.
	self deny: materialized trailer hasSourcePointer.
	
	self assert: (materialized isEqualRegardlessTrailerTo: theCompiledMethod)! !

!FLCompiledMethodSerializationTest methodsFor: 'helpers' stamp: ''!
useNotInstalled
	theClass 
		duringTestCompileSilently: 'm  ^ 42'
		storeSource: false.
	theCompiledMethod := theClass methodNamed: #m.
	theClass methodDict removeKey: #m! !

!FLCompiledMethodSerializationTest methodsFor: 'helpers' stamp: ''!
useInstalled
	theClass 
		duringTestCompileSilently: 'm  ^ 42'
		storeSource: true.
	theCompiledMethod := theClass methodNamed: #m! !

!FLCompiledMethodSerializationTest methodsFor: 'tests' stamp: ''!
testMethodAccessingAClassVariable
	| aClassWithVariable aMethod materializedMethod |
	aClassWithVariable := self
		newSubclassOf: Object 
		instanceVariableNames: '' 
		classVariableNames: 'A'.

	aClassWithVariable compileSilently: 'm1 A:= 3'.
	aMethod := aClassWithVariable >> #m1.
	aClassWithVariable classVarNamed: #A put: 7. 
	
	materializedMethod := self resultOfSerializeAndMaterialize: aMethod.
	
	self assertCollection: materializedMethod literals hasSameElements: aMethod literals.
	self assert: (materializedMethod literalAt: 2) identicalTo: (aMethod literalAt: 2).! !

!FLCompiledMethodSerializationTest methodsFor: 'tests' stamp: ''!
testInstalledModified
	| copy materialized |
	"Since Pharo 3.0 decompilation of compiled methods is no longer possible.
	That means we have to store the source too."
	self useInstalled.

	self assert: theCompiledMethod isInstalled.
	self deny: theCompiledMethod isDoIt.
	self deny: theCompiledMethod trailer hasSource.
	self deny: theCompiledMethod trailer isEmpty.
	self assert: theCompiledMethod trailer hasSourcePointer.

	copy := theCompiledMethod copy.
	"different instance can not be installed at the same time."
	self deny: copy isInstalled.
	self deny: copy isDoIt.
	self deny: copy trailer hasSource.
	self deny: copy trailer isEmpty.
	self assert: copy trailer hasSourcePointer.

	"if installed but not different, the installed instance will be answered"
	materialized := self resultOfSerializeAndMaterialize: copy.
	self deny: materialized identicalTo: theCompiledMethod.
	self deny: materialized identicalTo: copy.
	self deny: materialized isInstalled.
	self deny: materialized isDoIt.
	"we serialized the source"
	self assert: materialized trailer hasSource.
	self deny: materialized trailer isEmpty.
	self deny: materialized trailer hasSourcePointer! !

!FLCompiledMethodSerializationTest methodsFor: 'tests' stamp: ''!
testInstalled
	| materialized |
	"Since Pharo 3.0 decompilation of compiled methods is no longer possible.
	That means we have to store the source too."
	self useInstalled.

	self assert: theCompiledMethod isInstalled.
	self deny: theCompiledMethod isDoIt.
	self deny: theCompiledMethod trailer hasSource.
	self deny: theCompiledMethod trailer isEmpty.
	self assert: theCompiledMethod trailer hasSourcePointer.

	"if installed but not different, the installed instance will be answered"
	materialized := self resultOfSerializeAndMaterialize: theCompiledMethod.
	self assert: materialized identicalTo: theCompiledMethod! !

!FLCompiledMethodSerializationTest methodsFor: 'tests' stamp: ''!
testDoIt
	| materialized |
	"Since Pharo 3.0 decompilation of compiled methods is no longer possible.
	That means we have to store the source too."
	self useDoIt.

	theCompiledMethod selector: #DoIt.
	self assert: theCompiledMethod isDoIt.
	self assert: theCompiledMethod isInstalled.
	self deny: theCompiledMethod trailer hasSource.
	self assert: theCompiledMethod trailer isEmpty.
	self deny: theCompiledMethod trailer hasSourcePointer.

	materialized := self resultOfSerializeAndMaterialize: theCompiledMethod.
	"not possible since it's a different instance"
	self deny: materialized isInstalled.
	self assert: materialized isDoIt.
	"we serialized the source"
	self assert: materialized trailer hasSource.
	self deny: materialized trailer isEmpty.
	self deny: materialized trailer hasSourcePointer.

	self assert: (materialized isEqualRegardlessTrailerTo: theCompiledMethod)! !

!FLCompiledMethodSerializationTest methodsFor: 'tests' stamp: ''!
testMethodAccessingAClassVariableInADoit
	| aClassWithVariable aMethod materializedMethod |
	aClassWithVariable := self
		newSubclassOf: Object 
		instanceVariableNames: '' 
		classVariableNames: 'A'.

	aClassWithVariable compileSilently: 'DoIt A:= 3'.
	aMethod := aClassWithVariable >> #DoIt.
	aClassWithVariable classVarNamed: #A put: 7. 
	
	materializedMethod := self resultOfSerializeAndMaterialize: aMethod.
	
	self assertCollection: materializedMethod literals hasSameElements: aMethod literals.
	self assert: (materializedMethod literalAt: 2) equals: (aMethod literalAt: 2)! !

!FLCompiledMethodSerializationTest methodsFor: 'helpers' stamp: ''!
useDoIt
	theClass 
		duringTestCompileSilently: 'm  ^ 42'
		storeSource: false.
	theCompiledMethod := theClass methodNamed: #m.
	theClass methodDict
		at: #DoIt
		put: theCompiledMethod! !

!FLCompiledMethodSerializationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	theClass := self newClass class! !

!FLContextCluster commentStamp: ''!
I am a cluster for MethodContexts.!
!FLContextCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: aMethodContext with: anEncoder

	anEncoder encodeByte: aMethodContext method frameSize.
! !

!FLContextCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^ theClass newFromFrameSize: aDecoder nextEncodedByte
! !

!FLContextSerializationTest commentStamp: ''!
SUnit tests for fuel serialization of methods contexts!
!FLContextSerializationTest methodsFor: 'tests' stamp: ''!
testContextWithClosureContextWithOutPointerTesting
	"This test should be improved"

	| context1 materializedContext1 |
	context1 := self class blockClosureContextWithOutPointerTesting.
	self assert: (context1 tempNamed: 'string') equals: 'test'.
	materializedContext1 := self resultOfSerializeAndMaterialize: context1.
	self assert: (materializedContext1 tempNamed: 'string') equals: 'test'.
	context1 assertWellMaterializedInto: materializedContext1 in: self! !

!FLContextSerializationTest methodsFor: 'tests' stamp: ''!
testContextWithTemp
	"This test should be improved"

	| context1 materializedContext1 |
	context1 := Context newForMethod: FLPair >> #methodWithTemp.
	context1
		initializeWith: nil
		stackPtr: 1
		method: FLPair >> #methodWithTemp
		receiver:
			(FLPair new
				right: 4;
				left: 2)
		sender: nil.
	context1 tempNamed: 'string' put: 'capo'.

	materializedContext1 := self resultOfSerializeAndMaterialize: context1.
	self assert: (materializedContext1 tempNamed: 'string') equals: 'capo'.
	context1 assertWellMaterializedInto: materializedContext1 in: self! !

!FLContextSerializationTest methodsFor: 'tests' stamp: ''!
testContext
	"This test should be improved"
	| context1  materializedContext1  |
	context1 := (Context newForMethod: FLPair >> #method1).
	context1 
		initializeWith: 23 
		stackPtr: 1 
		method: FLPair >> #method1 
		receiver:  (FLPair new right: 4; left: 2) 
		sender: nil.
		
	materializedContext1 := self resultOfSerializeAndMaterialize: context1.
	context1 assertWellMaterializedInto: materializedContext1 in: self.! !

!FLContextSerializationTest methodsFor: 'tests' stamp: ''!
testContextWithClosureAndSender
	"This test should be improved"
	| context1  materializedContext2  context2 |
	
	context1 := (Context newForMethod: FLPair >> #method1).
	context1 
		initializeWith: 23 
		stackPtr: 1 
		method: FLPair >> #method1 
		receiver:  (FLPair new right: 4; left: 2) 
		sender: nil.
	
	context2 := self class blockClosureContextTestingWithSender: context1.
	materializedContext2 := self resultOfSerializeAndMaterialize: context2.
	context2 assertWellMaterializedInto: materializedContext2 in: self.
	
! !

!FLContextSerializationTest methodsFor: 'tests' stamp: ''!
testContextThisContext
	| materializedContext context |
	context := thisContextSample.
	materializedContext := self resultOfSerializeAndMaterialize: context.

	self deny: context identicalTo: materializedContext.
	"I cannot compare by = because MethodContext do not implement it and it will finally use the identity."
	self assert: context pc equals: materializedContext pc.
	self assert: context stackPtr equals: materializedContext stackPtr.
	self assert: context method equals: materializedContext method.
	self assert: context receiver equals: materializedContext receiver.
	"I cannot compare by = because MethodContext do not implement it and it will finally use the identity."
	self deny: context sender identicalTo: materializedContext sender.
	self assert: context sender pc identicalTo: materializedContext sender pc.
	self assert: context sender stackPtr equals: materializedContext sender stackPtr
	"etc...."! !

!FLContextSerializationTest methodsFor: 'tests' stamp: ''!
testContextWithNilPc
	"This test should be improved"
	| context1  materializedContext1  |
	context1 := (Context newForMethod: FLPair >> #method1).
	context1 
		initializeWith: nil 
		stackPtr: 1 
		method: FLPair >> #method1 
		receiver:  (FLPair new right: 4; left: 2) 
		sender: nil.
		
	materializedContext1 := self resultOfSerializeAndMaterialize: context1.
	context1 assertWellMaterializedInto: materializedContext1 in: self.! !

!FLContextSerializationTest methodsFor: 'tests' stamp: ''!
testContextWithSender
	"This test should be improved"
	| context1 context2 materializedContext1 |
	context1 := (Context newForMethod: FLPair >> #method1).
	context1 
		initializeWith: 23 
		stackPtr: 1 
		method: FLPair >> #method1 
		receiver:  (FLPair new right: 4; left: 2) 
		sender: nil.
		
	context2 := (Context newForMethod: FLPair >> #method2).
	context2 
		initializeWith: 18 
		stackPtr: 1 
		method: FLPair >> #method2 
		receiver:  (FLPair new right: 5; left: 6) 
		sender: nil.

	context1 privSender:  context2.
		
	materializedContext1 := self resultOfSerializeAndMaterialize: context1.
	context1 assertWellMaterializedInto: materializedContext1 in: self.! !

!FLContextSerializationTest methodsFor: 'tests' stamp: ''!
testDoIt
	"Serialization of DoIt methods should be possible by default.
	Note: we store the context as a global instead of using a local variabl
			to avoid the creation of a closure that will include the test instance.
			If that happened it can pull in most of the image, depending on how the
			test was executed.
	Note: we run the evaluation in a separate process to minimize the number of
			contexts that will be serialized (potentially pulling in a large number
			of additional objects)"

	[ [ Smalltalk compiler evaluate: 'self error' ]
		on: Error
		do: [ :error |
			self environmentOfTest
				at: #FLGlobalVariableForTesting
				put: error signalerContext copyStack ] ] forkAndWait.
		
	self serialize: (self environmentOfTest at: #FLGlobalVariableForTesting)! !

!FLContextSerializationTest methodsFor: 'tests' stamp: ''!
testContextWithClosure
	"This test should be improved"
	| context1  materializedContext1  |
	context1 := self class blockClosureContextTesting.
	materializedContext1 := self resultOfSerializeAndMaterialize: context1.
	context1 assertWellMaterializedInto: materializedContext1 in: self.
	
! !

!FLContextSerializationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	thisContextSample := self class thisContextSample.! !

!FLContextSerializationTest class methodsFor: 'closures for testing' stamp: ''!
blockClosureContextTesting
	^ [self class] asContext! !

!FLContextSerializationTest class methodsFor: 'closures for testing' stamp: ''!
blockClosureContextWithOutPointerTesting
	| string |
	string := 'test'.
	^ [self class. string asUppercase] asContext! !

!FLContextSerializationTest class methodsFor: 'closures for testing' stamp: ''!
blockClosureContextTestingWithSender: aSenderContext
	^ [self class] asContextWithSender: aSenderContext! !

!FLContextSerializationTest class methodsFor: 'running' stamp: ''!
thisContextSample
	^ thisContext copy! !

!FLDebuggerStackMaterialization commentStamp: ''!
I am signalled when a dead stack is materialized from Fuel. My default action is to directly request the opening of a debugger on the post-mortem stack.!
!FLDebuggerStackMaterialization methodsFor: 'handling' stamp: ''!
defaultAction 
	(OupsDebugRequest newForContext: interruptedContext)
		process: Processor activeProcess;
		label: 'External stack';
		submit! !

!FLDebuggerStackMaterialization methodsFor: 'accessing' stamp: ''!
interruptedContext: anObject
	interruptedContext := anObject! !

!FLDebuggerStackSerializer commentStamp: ''!
Serializes a debugger stack using fuel.!
!FLDebuggerStackSerializer methodsFor: 'private' stamp: ''!
encodeDebugInformation
	self
		at: #Timestamp putAdditionalObject: self timestampString;
		at: #VM putAdditionalObject: self vmInformationString;
		at: #Image putAdditionalObject: self imageInformationString! !

!FLDebuggerStackSerializer methodsFor: 'private' stamp: ''!
imageInformationString
	^ String streamContents: [ :stringStream |
		stringStream	
			nextPutAll: 'Image: ';
			nextPutAll:  SystemVersion current version asString;
			nextPutAll: ' [';
			nextPutAll: Smalltalk lastUpdateString asString;
			nextPutAll: ']' ]! !

!FLDebuggerStackSerializer methodsFor: 'private' stamp: ''!
vmInformationString
	^ String streamContents: [ :stringStream |
		stringStream
			nextPutAll: 'VM: ';
			nextPutAll: Smalltalk os name asString;
			nextPutAll: ' - ';	
			nextPutAll: Smalltalk os subtype asString;
			nextPutAll: ' - ';
			nextPutAll: Smalltalk os version asString;
			nextPutAll: ' - ';
			nextPutAll: Smalltalk vm version asString ]! !

!FLDebuggerStackSerializer methodsFor: 'serializing' stamp: ''!
serializeStackFromContext: aContext toFileNamed: aFileName
	self
		encodeDebugInformation;
		addPostMaterializationAction: [ :materialization | 
		FLDebuggerStackMaterialization new
			interruptedContext: materialization root;
			signal ];
		serialize: aContext copyStack toFileNamed: aFileName! !

!FLDebuggerStackSerializer methodsFor: 'accessing' stamp: ''!
fileName
	^ fileName! !

!FLDebuggerStackSerializer methodsFor: 'private' stamp: ''!
timestampString
	^ String streamContents: [ :stringStream |
		stringStream
			print: Date today;
			space;
			print: Time now ]! !

!FLDebuggerStackSerializer methodsFor: 'private' stamp: ''!
fileNameForContext: aContext
	| date |
	date := DateAndTime now.
	^ String streamContents: [ :s | 
		s << 'Debugger-Stack-'.
		s << aContext receiver class instanceSide name.
		s << '-'.
		date printYMDOn: s.
		s << '-'.
		s print: date hour24.
		s print: date minute.
		s print: date second.
		s << '.fuel' ]! !

!FLDebuggerStackSerializer methodsFor: 'serializing' stamp: ''!
serializeStackFromContext: aContext
	fileName := self fileNameForContext: aContext.
	self
		serializeStackFromContext: aContext
		toFileNamed: fileName! !

!FLDebuggerStackSerializer class methodsFor: 'serializing' stamp: ''!
serializeStackFromContext: aContext toFileNamed: aFileName
	self newDefault
		serializeStackFromContext: aContext
		toFileNamed: aFileName! !

!FLDebuggerStackSerializer class methodsFor: 'serializing' stamp: ''!
serializeStackFromContext: aContext
	self newDefault serializeStackFromContext: aContext! !

!FLDebuggerStackSerializerTest methodsFor: 'tests' stamp: ''!
testSerializeContextToFileNamed
	| context file |
	context := [  ] asContext.
	file := 'serialized-stack' asFileReference.
	FLDebuggerStackSerializer
		serializeStackFromContext: context
		toFileNamed: 'serialized-stack'.

	self assert: file exists.
	self
		should: [ 
		FLMaterializer materializeFromFileNamed: 'serialized-stack' ]
		raise: FLDebuggerStackMaterialization! !

!FLDebuggerStackSerializerTest methodsFor: 'tests' stamp: ''!
testSerializeStackFromContext
	| stackSerializer context |
	stackSerializer := FLDebuggerStackSerializer new.
	
	context := [  ] asContext.
	stackSerializer	serializeStackFromContext: context.

	self assert: stackSerializer fileName asFileReference exists.
	self
		should: [ 
		FLMaterializer materializeFromFileNamed: stackSerializer fileName ]
		raise: FLDebuggerStackMaterialization! !

!FLDebuggerStackSerializerTest methodsFor: 'tests' stamp: ''!
testFileNameForContext
	| stackSerializer context fileName |
	stackSerializer := FLDebuggerStackSerializer new.

	context := [  ] asContext.
	fileName := stackSerializer fileNameForContext: context.

	self deny: fileName equals: nil.
	self assert:
		('Debugger-Stack-' , context receiver class instanceSide name
		 , '-*.fuel' match: fileName)! !

!FLDecoder commentStamp: ''!
I am an abstraction used by the materialization algorithm to decode the graph from a stream.!
!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedUint24
	"Answer the next unsigned, 24-bit integer from this (binary) stream."

	| n |
	n := stream next.
	n := (n bitShift: 8) + stream next.
	^ (n bitShift: 8) + stream next
! !

!FLDecoder methodsFor: 'accessing' stamp: ''!
variablesMappingFor: aClass

	| variables |
	variables := FLVariablesMapping materializing: aClass from: self.
	
	migrations 
		select: [ :m | (m targetClass == aClass) or: [ aClass inheritsFrom: m targetClass ] ]
		thenDo: [ :m | m applyTo: variables ].
		
	^ variables
	! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedWordsInto: aWordsObject 
	stream fuelNextWordsInto: aWordsObject ! !

!FLDecoder methodsFor: 'initializing' stamp: ''!
initializeOn: aStream migrations: aCollection globalEnvironment: aDictionary 

	self initialize.
	stream := aStream.
	migrations := aCollection.
	globalEnvironment := aDictionary.! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedByte
	^stream next! !

!FLDecoder methodsFor: 'accessing' stamp: ''!
isBigEndian
	^ isBigEndian! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedUint8
	"Answer the next unsigned, 16-bit integer from this (binary) stream."
	^ stream next
	
! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedBytesInto: aBytesObject
	stream next: aBytesObject basicSize into: aBytesObject ! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedUint16
	"Answer the next unsigned, 16-bit integer from this (binary) stream."
	^ (stream next bitShift: 8) + (stream next).
	! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedUint64
	"Answer the next unsigned, 64-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 := (n bitShift: 8) + stream next.
	n := (n bitShift: 8) + stream next.
	n := (n bitShift: 8) + stream next.
	^ (n bitShift: 8) + stream next
! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedInt24
	"SmallInteger is 31 / 63 bits. Hence, we can store a full 24 bit signed integer.
	Look at the high bit to see whether this is actually a negative integer and then
	restore the remaining two's complement bits."
	| uInt |
	uInt := self nextEncodedUint24.
	^ (uInt bitShift: -23) = 1
		ifTrue: [ uInt + (-1 bitShift: 24) ]
		ifFalse: [ uInt ]! !

!FLDecoder methodsFor: 'accessing' stamp: ''!
classNamed: className 

	^ (migrations
		detect: [:m | m sourceClassName = className ]
		ifNone: [ ^ self globalClassNamed: className ])
		targetClass.
		! !

!FLDecoder methodsFor: 'accessing' stamp: ''!
registerAll: someObjects

	objectsWriteStream nextPutAll: someObjects.! !

!FLDecoder methodsFor: 'accessing' stamp: ''!
globalEnvironment
	"Answer a dictionary where the look up for global symbols will be done during materialization."
	
	^ globalEnvironment! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
decodeYourself
	| objectCount |
	objectCount := self nextEncodedUint32.
	indexStream := FLIndexStream
		on: stream
		digits: objectCount bytesCount.
	objects := Array new: objectCount.
	objectsWriteStream := WriteStream on: objects.
	isBigEndian := self nextEncodedUint32! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedBitmap

	^ Bitmap newFromStream: stream! !

!FLDecoder methodsFor: 'accessing' stamp: ''!
globalClassNamed: className

	^ globalEnvironment 
		at: className
		ifAbsent: [ FLClassNotFound signalWithName: className ]! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedInt32
	"SmallInteger is 31 / 63 bits.
	Look at the high bit (bit 30, not 31!!) to see whether this is actually a negative
	integer and then restore the remaining two's complement bits.
	Note: we don't dispatch to #nextEncodedUint32 to avoid overflow to large integers
			when decoding negative integers."
	| n |
	n := stream next.
	"See whether bit 7 of the byte is set (= bit 31)"
	(n bitAnd: 64) = 64 ifTrue: [
		n := n + (-1 bitShift: 7) ].
	n := (n bitShift: 8) + stream next.
	n := (n bitShift: 8) + stream next.
	^ (n bitShift: 8) + stream next! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedClusterClass

	^ self class environment at: self nextEncodedString asSymbol! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedReference 

	^ objects at: indexStream nextIndex! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
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: ''!
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 bitShift: 8) + stream next
! !

!FLDecoder methodsFor: 'accessing' stamp: ''!
objects
	^ objects! !

!FLDecoder methodsFor: 'decoding' stamp: ''!
nextEncodedInt64
	"SmallInteger is 31 / 63 bits.
	Look at the high bit (bit 61, not 63!!) to see whether this is actually a negative
	integer and then restore the remaining two's complement bits.
	Note: we don't dispatch to #nextEncodedUint64 to avoid overflow to large integers
			when decoding negative integers.
	Note: while the documentation says that SmallInteger uses 63 bits on 64 bit platforms
			`SmallInteger minVal` actually only uses 61 bits!!"
	| n |
	n := stream next.
	"See whether bit 5 of the byte is set (= bit 61)"
	(n bitAnd: 16) = 16 ifTrue: [
		n := n + (-1 bitShift: 5) ].
	n := (n bitShift: 8) + stream next.
	n := (n bitShift: 8) + stream next.
	n := (n bitShift: 8) + stream next.
	n := (n bitShift: 8) + stream next.
	n := (n bitShift: 8) + stream next.
	n := (n bitShift: 8) + stream next.
	^ (n bitShift: 8) + stream next! !

!FLDecoder class methodsFor: 'instance creation' stamp: ''!
on: aStream migrations: aCollection globalEnvironment: aDictionary
	
	^self basicNew
		initializeOn: aStream 
		migrations: aCollection 
		globalEnvironment: aDictionary;
		yourself.! !

!FLDecoderTest methodsFor: 'tests' stamp: ''!
testNextEncodedInt24
	stream 
		nextPutAll: #[0 0 0];
		reset.
	self assert: decoder nextEncodedInt24 equals: 0.
	
	stream
		resetToStart;
		nextPutAll: #[0 0 1];
		reset.
	self assert: decoder nextEncodedInt24 equals: 1.
	
	"-1 in two's complement"
	stream
		resetToStart;
		nextPutAll: #[255 255 255];
		reset.
	self assert: decoder nextEncodedInt24 equals: -1.
	
	"Maximum positive 24-bit integer in two's complement"
	stream
		resetToStart;
		nextPutAll: #[127 255 255];
		reset.
	self assert: decoder nextEncodedInt24 equals: (2 raisedTo: 23) - 1.
	
	"Minimum negative 24-bit integer in two's complement"
	stream
		resetToStart;
		nextPutAll: #[128 0 0 0];
		reset.
	self assert: decoder nextEncodedInt24 equals: 0 - (2 raisedTo: 23)! !

!FLDecoderTest methodsFor: 'tests' stamp: ''!
testNextEncodedInt32
	stream 
		nextPutAll: #[0 0 0 0];
		reset.
	self assert: decoder nextEncodedInt32 equals: 0.
	
	stream
		resetToStart;
		nextPutAll: #[0 0 0 1];
		reset.
	self assert: decoder nextEncodedInt32 equals: 1.
	
	"-1 on 32-bits systems"
	stream
		resetToStart;
		nextPutAll: #[127 255 255 255];
		reset.
	self assert: decoder nextEncodedInt32 equals: -1.
	
	"SmallInteger maxVal on 32-bits systems"
	stream
		resetToStart;
		nextPutAll: #[63 255 255 255];
		reset.
	self assert: decoder nextEncodedInt32 equals: (2 raisedTo: 30) - 1.
	
	"SmallInteger minVal on 32-bits systems"
	stream
		resetToStart;
		nextPutAll: #[64 0 0 0];
		reset.
	self assert: decoder nextEncodedInt32 equals: 0 - (2 raisedTo: 30)! !

!FLDecoderTest methodsFor: 'tests' stamp: ''!
testNextEncodedUint16
	stream 
		nextPutAll: #[0 0];
		reset.
	self assert: decoder nextEncodedUint16 equals: 0.
	
	stream
		resetToStart;
		nextPutAll: #[0 1];
		reset.
	self assert: decoder nextEncodedUint16 equals: 1.
	
	"Maximum positive 16-bit integer in two's complement"
	stream
		resetToStart;
		nextPutAll: #[255 255];
		reset.
	self assert: decoder nextEncodedUint16 equals: (2 raisedTo: 16) - 1! !

!FLDecoderTest methodsFor: 'tests' stamp: ''!
testNextEncodedUint64
	stream 
		nextPutAll: #[0 0 0 0 0 0 0 0];
		reset.
	self assert: decoder nextEncodedUint64 equals: 0.
	
	stream
		resetToStart;
		nextPutAll: #[0 0 0 0 0 0 0 1];
		reset.
	self assert: decoder nextEncodedUint64 equals: 1.
	
	"SmallInteger maxVal on 64-bits systems"
	stream
		resetToStart;
		nextPutAll: #[15 255 255 255 255 255 255 255];
		reset.
	self assert: decoder nextEncodedUint64 equals: (2 raisedTo: 60) - 1.
	
	"SmallInteger minVal on 64-bits systems"
	stream
		resetToStart;
		nextPutAll: #[16 0 0 0 0 0 0 0];
		reset.
	self assert: decoder nextEncodedUint64 equals: (2 raisedTo: 60)! !

!FLDecoderTest methodsFor: 'tests' stamp: ''!
testNextEncodedInt64
	stream 
		nextPutAll: #[0 0 0 0 0 0 0 0];
		reset.
	self assert: decoder nextEncodedInt64 equals: 0.
	
	stream
		resetToStart;
		nextPutAll: #[0 0 0 0 0 0 0 1];
		reset.
	self assert: decoder nextEncodedInt64 equals: 1.
	
	"-1 on 64-bits systems"
	stream
		resetToStart;
		nextPutAll: #[31 255 255 255 255 255 255 255];
		reset.
	self assert: decoder nextEncodedInt64 equals: -1.
	
	"SmallInteger maxVal on 64-bits systems"
	stream
		resetToStart;
		nextPutAll: #[15 255 255 255 255 255 255 255];
		reset.
	self assert: decoder nextEncodedInt64 equals: (2 raisedTo: 60) - 1.
	
	"SmallInteger minVal on 64-bits systems"
	stream
		resetToStart;
		nextPutAll: #[16 0 0 0 0 0 0 0];
		reset.
	self assert: decoder nextEncodedInt64 equals: 0 - (2 raisedTo: 60)! !

!FLDecoderTest methodsFor: 'tests' stamp: ''!
testNextEncodedUint32
	stream 
		nextPutAll: #[0 0 0 0];
		reset.
	self assert: decoder nextEncodedUint32 equals: 0.
	
	stream
		resetToStart;
		nextPutAll: #[0 0 0 1];
		reset.
	self assert: decoder nextEncodedUint32 equals: 1.
	
	"SmallInteger maxVal on 32-bits systems"
	stream
		resetToStart;
		nextPutAll: #[127 255 255 255];
		reset.
	self assert: decoder nextEncodedUint32 equals: (2 raisedTo: 31) - 1.
	
	"SmallInteger minVal on 64-bits systems"
	stream
		resetToStart;
		nextPutAll: #[64 0 0 0];
		reset.
	self assert: decoder nextEncodedUint32 equals: (2 raisedTo: 30)! !

!FLDecoderTest methodsFor: 'tests' stamp: ''!
testNextEncodedUint8
	stream 
		nextPutAll: #[0];
		reset.
	self assert: decoder nextEncodedUint8 equals: 0.
	
	stream
		resetToStart;
		nextPutAll: #[1];
		reset.
	self assert: decoder nextEncodedUint8 equals: 1.
	
	"Maximum positive 8-bit integer in two's complement"
	stream
		resetToStart;
		nextPutAll: #[255];
		reset.
	self assert: decoder nextEncodedUint8 equals: (2 raisedTo: 8) - 1! !

!FLDecoderTest methodsFor: 'tests' stamp: ''!
testNextEncodedUint24
	stream 
		nextPutAll: #[0 0 0];
		reset.
	self assert: decoder nextEncodedUint24 equals: 0.
	
	stream
		resetToStart;
		nextPutAll: #[0 0 1];
		reset.
	self assert: decoder nextEncodedUint24 equals: 1.
	
	"Maximum positive 24-bit integer in two's complement"
	stream
		resetToStart;
		nextPutAll: #[255 255 255];
		reset.
	self assert: decoder nextEncodedUint24 equals: (2 raisedTo: 24) - 1! !

!FLDecoderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	stream := ReadWriteStream on: ByteArray new.
	decoder := FLDecoder
		on: stream
		migrations: #()
		globalEnvironment: self class environment! !

!FLDelayedSerializationMock methodsFor: 'serializing' stamp: ''!
run
	"Serialize the graph starting at the root object."

	self analysisStep.
	self headerStep.
	self instancesStep.
	(Delay forMilliseconds: 100) wait.
	self referencesStep.
	self trailerStep.! !

!FLDelayedSerializerMock methodsFor: 'protected' stamp: ''!
setDefaultSerialization

	^ serializationFactory := [:anObject :anEncoder | 
		(FLDelayedSerializationMock 
			with: anEncoder
			root: anObject 
			analyzer: self analyzer)
			run;
			yourself ]! !

!FLDictionaryCollectionCluster commentStamp: ''!
A FLDictionaryCollectionCluster is a special optional cluster that rather than using the default (variable object) serialization, uses #keysAndValuesDo: to iterate objects and #add: during materialization. This way we avoid analyzing/serializing lots of nil. Also, the rehash is not needed. So far we use it for Dictionary, IdentityDictionary and MethodDictionary.!
!FLDictionaryCollectionCluster methodsFor: 'analyzing' stamp: ''!
referencesOf: anObject do: aBlock
	aBlock value: anObject size.
	anObject
		keysAndValuesDo: [ :key :value | 
			aBlock value: key. 
			aBlock value: value.  ]
! !

!FLDictionaryCollectionCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesOf: anObject with: aDecoder
	aDecoder nextEncodedUint32 timesRepeat: [
		anObject add: aDecoder nextEncodedReference -> aDecoder nextEncodedReference ]! !

!FLEncoder commentStamp: ''!
I am an abstraction used by the serialization algorithm to encode the graph in a stream.!
!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeUint16: aSmallInteger 
	"Append to the receiver an Integer as the next 2 bytes."
	stream
		nextPut: ((aSmallInteger bitShift: -8) bitAnd: 255);
		nextPut: (aSmallInteger bitAnd: 255)! !

!FLEncoder methodsFor: 'accessing' stamp: ''!
substitutionIndexes
	^ substitutionIndexes! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeBytes: aBytesObject
	stream nextBytesPutAll: aBytesObject ! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeClusterClass: aClusterClass 

	self encodeString: aClusterClass name! !

!FLEncoder methodsFor: 'hooks' stamp: ''!
fuelAccept: aGeneralMapper
	^ aGeneralMapper visitSubstitution: self by: nil! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeInt32: aSmallInteger
	"SmallInteger is 31 / 63 bits. We could encode 32 bit signed integers in theory but
	that would mean that we could receive large integers as input, which shouldn't happen.
	We have to assume that we are storing a SmallInteger with 31 bits of information here.
	We can store the SmallInteger as a uint and then take care to restore potential higher
	bits when we materialze.
	Note: we have to mask the top bit because we don't know what was in there. Since
		we store byte units but SmallInteger is only 31 bits, the top bit may be 1 if
		the argument is negative and we're on a 64 bit system."
	self encodeUint32: (aSmallInteger bitAnd: 16r7FFFFFFF)! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeReferenceToClusterObjectClass: aClass 
	indexStream nextIndexPut: (objectsIndexes
		at: aClass
		ifAbsent: [ FLObjectNotFound signalWith: aClass ])! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeUint32: aSmallInteger 
	"Append to the receiver an Integer as the next 4 bytes."
	stream		
		nextPut: ((aSmallInteger bitShift: -24) bitAnd: 255);
		nextPut: ((aSmallInteger bitShift: -16) bitAnd: 255);
		nextPut: ((aSmallInteger bitShift: -8) bitAnd: 255);
		nextPut: (aSmallInteger bitAnd: 255)
! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeString: aString
	| length |
	(length := aString size) < 192
		ifTrue: [ stream nextPut: length ]
		ifFalse: [ stream nextPut: (length byteAt: 4) + 192.
			stream nextPut: (length byteAt: 3).
			stream nextPut: (length byteAt: 2).
			stream nextPut: (length byteAt: 1) ].
	stream nextBytesPutAll: aString! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
flush

	^ stream flush.! !

!FLEncoder methodsFor: 'accessing' stamp: ''!
objectCount
	^ objectCount! !

!FLEncoder methodsFor: 'accessing' stamp: ''!
objectsIndexes
	^ objectsIndexes! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeUint64: aSmallInteger 
	"Append to the receiver an Integer as the next 8 bytes."
	stream	
		nextPut: ((aSmallInteger bitShift: -56) bitAnd: 255);
		nextPut: ((aSmallInteger bitShift: -48) bitAnd: 255);
		nextPut: ((aSmallInteger bitShift: -40) bitAnd: 255);
		nextPut: ((aSmallInteger bitShift: -32) bitAnd: 255);
		nextPut: ((aSmallInteger bitShift: -24) bitAnd: 255);
		nextPut: ((aSmallInteger bitShift: -16) bitAnd: 255);
		nextPut: ((aSmallInteger bitShift: -8) bitAnd: 255);
		nextPut: (aSmallInteger bitAnd: 255)
! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeBitmap: aBitmap 
	"Append to the receiver an Integer as the next two bytes."
	aBitmap writeOn: stream.
! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeWeakReferenceTo: anObject

	indexStream 
		nextIndexPut: (objectsIndexes at: anObject ifAbsent: [objectsIndexes at: nil]) 
! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeInt64: aSmallInteger
	"SmallInteger is 31 / 63 bits. We could encode 64 bit signed integers in theory but
	that would mean that we could receive large integers as input, which shouldn't happen.
	We have to assume that we are storing a SmallInteger with 63 bits of information here.
	We can store the SmallInteger as a uint and then take care to restore potential higher
	bits when we materialze.
	Note: we have to mask the top bit because we don't know what was in there. Since
		we store byte units but SmallInteger is only 63 bits, the top bit may be 1 if
		the argument is negative and we're on a system > 64 bits.
	Note: while the documentation says that SmallInteger uses 63 bits on 64 bit platforms
			`SmallInteger minVal` actually only uses 61 bits!!"
	self encodeUint64: (aSmallInteger bitAnd: 16r1FFFFFFFFFFFFFFF)! !

!FLEncoder methodsFor: 'initialize-release' stamp: ''!
initializeOn: aStream globalEnvironment: aDictionary
	
	self initialize.
	stream := FLBufferedWriteStream on: aStream.
	globalEnvironment := aDictionary.! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeByte: aSmallInteger 
	self encodeUint8: aSmallInteger! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeYourself
	self
		encodeUint32: objectCount;
		encodeUint32: FLPlatform current isBigEndian asBit! !

!FLEncoder methodsFor: 'accessing' stamp: ''!
globalEnvironment
	"Answer a dictionary where the look up for global symbols will be done during serialization."
	
	^ globalEnvironment! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
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: ''!
encodeInt24: aSmallInteger
	"SmallInteger is 31 / 63 bits. Hence, we can store a full 24 bit signed integer.
	We only have to restore the two's complement of the remaining higher bits when
	we materialize."
	self encodeUint24: aSmallInteger! !

!FLEncoder methodsFor: 'accessing' stamp: ''!
objectCount: aNumber
	objectCount := aNumber.
	objectsIndexes := FLLargeIdentityDictionary new.
	substitutionIndexes := FLLargeIdentityDictionary new.
	indexStream := FLIndexStream on: stream digits: aNumber bytesCount! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeUint8: aSmallInteger 
	"Append to the receiver an Integer as the next byte."
	stream nextPut: (aSmallInteger bitAnd: 255)! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeReferenceTo: anObject
	| index |
	index := substitutionIndexes
		at: anObject
		ifAbsent: [
			objectsIndexes
				at: anObject
				ifAbsent: [ FLObjectNotFound signalWith: anObject ] ].
	indexStream nextIndexPut: index! !

!FLEncoder methodsFor: 'encoding' stamp: ''!
encodeWords: aWordsObject
	stream nextWordsPut: aWordsObject! !

!FLEncoder class methodsFor: 'instance creation' stamp: ''!
on: aStream globalEnvironment: aDictionary do: aBlock
	
	| anEncoder |
	anEncoder := self on: aStream globalEnvironment: aDictionary.
	^ [ aBlock value: anEncoder ] ensure: [ anEncoder flush ]! !

!FLEncoder class methodsFor: 'instance creation' stamp: ''!
on: aStream globalEnvironment: aDictionary
	
	^self basicNew
		initializeOn: aStream
		globalEnvironment: aDictionary;
		yourself.! !

!FLEncoderDecoderTest methodsFor: 'running' stamp: ''!
assertIdentityOf: aSmallInteger using: anArray
	stream resetToStart.
	
	encoder
		perform: anArray first with: aSmallInteger;
		flush.
	stream reset.
	self assert: (decoder perform: anArray second) identicalTo: aSmallInteger! !

!FLEncoderDecoderTest methodsFor: 'tests' stamp: ''!
testSmallIntegerSerializationForAllBitsWith64Bits
	1
		to: 60
		do: [ :exp |
			| integer |
			integer := 2 raisedTo: exp.
			integer isLarge ifFalse: [
				self
					assertIdentityOf: integer
					using: #(encodeUint64: nextEncodedUint64).
			integer < (2 raisedTo: 60) ifTrue: [
				self
					assertIdentityOf: integer
					using: #(encodeInt64: nextEncodedInt64) ] ].
			integer := 0 - integer.
			integer isLarge ifFalse: [
				self
					assertIdentityOf: integer
					using: #(encodeInt64: nextEncodedInt64) ] ]! !

!FLEncoderDecoderTest methodsFor: 'tests' stamp: ''!
testSmallIntegerSerializationForAllBitsWith16Bits
	1
		to: 15
		do: [ :exp |
			| integer |
			integer := 2 raisedTo: exp.
			self
				assertIdentityOf: integer
				using: #(encodeUint16: nextEncodedUint16) ]! !

!FLEncoderDecoderTest methodsFor: 'tests' stamp: ''!
testSmallIntegerSerializationForAllBitsWith8Bits
	1
		to: 7
		do: [ :exp |
			| integer |
			integer := 2 raisedTo: exp.
			self
				assertIdentityOf: integer
				using: #(encodeUint8: nextEncodedUint8) ]! !

!FLEncoderDecoderTest methodsFor: 'tests' stamp: ''!
testSmallIntegerSerializationForAllBitsWith32Bits
	1
		to: 30
		do: [ :exp |
			| integer |
			integer := 2 raisedTo: exp.
			integer isLarge ifFalse: [
				self
					assertIdentityOf: integer
					using: #(encodeUint32: nextEncodedUint32).
			integer < (2 raisedTo: 30) ifTrue: [
				self
					assertIdentityOf: integer
					using: #(encodeInt32: nextEncodedInt32) ] ].
			integer := 0 - integer.
			integer isLarge ifFalse: [
				self
					assertIdentityOf: integer
					using: #(encodeInt32: nextEncodedInt32) ] ]! !

!FLEncoderDecoderTest methodsFor: 'tests' stamp: ''!
testSmallIntegerSerializationForAllBitsWith24Bits
	1
		to: 23
		do: [ :exp |
			| integer |
			integer := 2 raisedTo: exp.
			self
				assertIdentityOf: integer
				using: #(encodeUint24: nextEncodedUint24).
			integer < (2 raisedTo: 23) ifTrue: [
				self
					assertIdentityOf: integer
					using: #(encodeInt24: nextEncodedInt24) ].
			integer := 0 - integer.
			self
				assertIdentityOf: integer
				using: #(encodeInt24: nextEncodedInt24) ]! !

!FLEncoderDecoderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	stream := ReadWriteStream on: ByteArray new.
	encoder := FLEncoder
		on: stream
		globalEnvironment: self class environment.
	
	decoder := FLDecoder
		on: stream
		migrations: #()
		globalEnvironment: self class environment
	! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeUint24Truncated
	encoder encodeUint24: (2 raisedTo: 24).
	self assert: self getResult equals: #[0 0 0].
	
	encoder encodeUint24: (2 raisedTo: 24) - 1.
	self assert: self getResult equals: #[255 255 255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeUInt8
	encoder encodeUint8: 0.
	self assert: self getResult equals: #[0].
	
	encoder encodeUint8: 1.
	self assert: self getResult equals: #[1].
	
	"Maximum positive 8-bit integer"
	encoder encodeUint8: (2 raisedTo: 8) - 1.
	self assert: self getResult equals: #[255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeUInt8Truncated
	encoder encodeUint8: (2 raisedTo: 8).
	self assert: self getResult equals: #[0].
	
	encoder encodeUint8: (2 raisedTo: 16) - 1.
	self assert: self getResult equals: #[255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeUint32Truncated
	encoder encodeUint32: (2 raisedTo: 32).
	self assert: self getResult equals: #[0 0 0 0].
	
	encoder encodeUint32: (2 raisedTo: 64) - 1.
	self assert: self getResult equals: #[255 255 255 255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeUint16
	encoder encodeUint16: 0.
	self assert: self getResult equals: #[0 0].
	
	encoder encodeUint16: 1.
	self assert: self getResult equals: #[0 1].
	
	"Maximum positive 16-bit integer"
	encoder encodeUint16: (2 raisedTo: 16) - 1.
	self assert: self getResult equals: #[255 255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeUint16Truncated
	encoder encodeUint16: (2 raisedTo: 16).
	self assert: self getResult equals: #[0 0].
	
	encoder encodeUint16: (2 raisedTo: 32) - 1.
	self assert: self getResult equals: #[255 255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeInt32Truncated
	encoder encodeInt32: (2 raisedTo: 32).
	self assert: self getResult equals: #[0 0 0 0].
	
	encoder encodeInt32: (2 raisedTo: 64) - 1.
	self assert: self getResult equals: #[127 255 255 255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeInt32
	"Note: SmallInteger in Pharo is 31 / 63 bits wide and stored in two's complement format.
			 Hence, the largest positive values are 2^30 - 1 and 2^62 - 1, the smallest negative
			 values -2^30 and -2^63, respectively."
	encoder encodeInt32: 0.
	self assert: self getResult equals: #[0 0 0 0].
	
	encoder encodeInt32: 1.
	self assert: self getResult equals: #[0 0 0 1].
	
	"-1 on 32-bits systems"
	encoder encodeInt32: (2 raisedTo: 31) - 1.
	self assert: self getResult equals: #[127 255 255 255].
	
	"SmallInteger maxVal on 32-bits systems"
	encoder encodeInt32: (2 raisedTo: 30) - 1.
	self assert: self getResult equals: #[63 255 255 255].
	
	"SmallInteger minVal on 32-bits systems"
	encoder encodeInt32: (2 raisedTo: 30).
	self assert: self getResult equals: #[64 0 0 0]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeInt64Truncated
	encoder encodeInt64: (2 raisedTo: 64).
	self assert: self getResult equals: #[0 0 0 0 0 0 0 0].
	
	encoder encodeInt64: (2 raisedTo: 65) - 1.
	self assert: self getResult equals: #[31 255 255 255 255 255 255 255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeInt64
	"Note: SmallInteger in Pharo is 31 / 63 bits wide and stored in two's complement format.
			 Hence, the largest positive values are 2^30 - 1 and 2^62 - 1, the smallest negative
			 values -2^30 and -2^63, respectively."
	encoder encodeInt64: 0.
	self assert: self getResult equals: #[0 0 0 0 0 0 0 0].
	
	encoder encodeInt64: 1.
	self assert: self getResult equals: #[0 0 0 0 0 0 0 1].
	
	"-1 on 64-bits systems"
	encoder encodeInt64: -1.
	self assert: self getResult equals: #[31 255 255 255 255 255 255 255].
	
	"SmallInteger maxVal on 32-bits systems"
	encoder encodeInt64: (2 raisedTo: 60) - 1.
	self assert: self getResult equals: #[15 255 255 255 255 255 255 255].
	
	"SmallInteger minVal on 64-bits systems"
	encoder encodeInt64: 0 - (2 raisedTo: 60).
	self assert: self getResult equals: #[16 0 0 0 0 0 0 0]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeUint64
	encoder encodeUint64: 0.
	self assert: self getResult equals: #[0 0 0 0 0 0 0 0].
	
	encoder encodeUint64: 1.
	self assert: self getResult equals: #[0 0 0 0 0 0 0 1].
	
	"Maximum positive 64-bit integer"
	encoder encodeUint64: (2 raisedTo: 63) - 1.
	self assert: self getResult equals: #[127 255 255 255 255 255 255 255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeInt24Truncated
	encoder encodeInt24: (2 raisedTo: 24).
	self assert: self getResult equals: #[0 0 0].
	
	encoder encodeInt24: (2 raisedTo: 32) - 1.
	self assert: self getResult equals: #[255 255 255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeUint64Truncated
	encoder encodeUint64: (2 raisedTo: 64).
	self assert: self getResult equals: #[0 0 0 0 0 0 0 0].
	
	encoder encodeUint64: (2 raisedTo: 65) - 1.
	self assert: self getResult equals: #[255 255 255 255 255 255 255 255]! !

!FLEncoderTest methodsFor: 'helpers' stamp: ''!
getResult
	| contents|
	encoder flush.
	contents := stream contents.
	stream reset.
	^ contents! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeInt24
	encoder encodeInt24: 0.
	self assert: self getResult equals: #[0 0 0].
	
	encoder encodeInt24: 1.
	self assert: self getResult equals: #[0 0 1].
	
	"-1 in two's complement"
	encoder encodeInt24: (2 raisedTo: 23) - 1.
	self assert: self getResult equals: #[127 255 255].
	
	"Maximum positive 24-bit integer in two's complement"
	encoder encodeInt24: (2 raisedTo: 22) - 1.
	self assert: self getResult equals: #[63 255 255].
	
	"Minimum negative 24-bit integer in two's complement"
	encoder encodeInt24: (2 raisedTo: 22).
	self assert: self getResult equals: #[64 0 0]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeUint24
	encoder encodeUint24: 0.
	self assert: self getResult equals: #[0 0 0].
	
	encoder encodeUint24: 1.
	self assert: self getResult equals: #[0 0 1].
	
	"Maximum positive 24-bit integer"
	encoder encodeUint24: (2 raisedTo: 24) - 1.
	self assert: self getResult equals: #[255 255 255]! !

!FLEncoderTest methodsFor: 'tests' stamp: ''!
testEncodeUint32
	encoder encodeUint32: 0.
	self assert: self getResult equals: #[0 0 0 0].
	
	encoder encodeUint32: 1.
	self assert: self getResult equals: #[0 0 0 1].
	
	"Maximum positive 32-bit integer"
	encoder encodeUint32: (2 raisedTo: 32) - 1.
	self assert: self getResult equals: #[255 255 255 255]! !

!FLEncoderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	stream := WriteStream on: ByteArray new.
	encoder := FLEncoder
		on: stream
		globalEnvironment: self class environment! !

!FLError commentStamp: ''!
I represent an error produced during Fuel operation.!
!FLExtensionWrapper methodsFor: 'private' stamp: ''!
copyToTarget
	FLPlatform current
		addAndClassifySelector: self selector
		inClass: self targetClass
		withMethod: self method copy
		inProtocol: self extensionProtocolName! !

!FLExtensionWrapper methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!FLExtensionWrapper methodsFor: 'initialize-release' stamp: ''!
selector
	^ selector! !

!FLExtensionWrapper methodsFor: 'operations' stamp: ''!
install
	self targetClass ifNil: [ ^ self ].
	
	self isSource ifTrue: [ ^ self compileInTarget ].
	self selector = self method selector ifFalse: [ ^ self renameAndCompileInTarget ].
	
	self copyToTarget! !

!FLExtensionWrapper methodsFor: 'accessing' stamp: ''!
targetClass: aClass
	targetClass := aClass! !

!FLExtensionWrapper methodsFor: 'private' stamp: ''!
extensionProtocolName
	^ FLPlatform extensionProtocolName! !

!FLExtensionWrapper methodsFor: 'initialize-release' stamp: ''!
initializeWithPragma: aPragma
	| argumentNamesAndValues |
	argumentNamesAndValues := self readArgumentsFrom: aPragma.
	self
		method: aPragma method copy;
		selector: (self
			readSelectorFrom: aPragma
			argumentNames: argumentNamesAndValues first
			argumentValues: argumentNamesAndValues second);
		isSource: (self
			readIsSourceFrom: aPragma
			argumentNames: argumentNamesAndValues first
			argumentValues: argumentNamesAndValues second);
		targetClass: (self
			readTargetClassFrom: aPragma
			argumentNames: argumentNamesAndValues first
			argumentValues: argumentNamesAndValues second)! !

!FLExtensionWrapper methodsFor: 'accessing' stamp: ''!
selector: aSymbol
	selector := aSymbol! !

!FLExtensionWrapper methodsFor: 'private' stamp: ''!
compileInTarget
	| source |
	source := self method methodClass instanceSide
		perform: self method selector
		withArguments: (1 to: self method selector numArgs) asArray.
	self targetClass compile: source.
	self targetClass organization
		classify: self selector
		under: self extensionProtocolName! !

!FLExtensionWrapper methodsFor: 'private' stamp: ''!
copySelector: aSelector ofMethod: aCompiledMethod toClass: aClass

	aClass
		addAndClassifySelector: aSelector
		withMethod: aCompiledMethod copy
		inProtocol: self extensionProtocolName! !

!FLExtensionWrapper methodsFor: 'accessing' stamp: ''!
targetClass
	^ targetClass! !

!FLExtensionWrapper methodsFor: 'initialize-release' stamp: ''!
readArgumentsFrom: aPragma
	^ {
		aPragma key keywords.
		aPragma arguments }! !

!FLExtensionWrapper methodsFor: 'accessing' stamp: ''!
isSource: aBoolean
	isSource := aBoolean! !

!FLExtensionWrapper methodsFor: 'initialize-release' stamp: ''!
readTargetClassFrom: aPragma argumentNames: argumentNames argumentValues: argumentValues
	| class |
	class := Smalltalk
		at: (argumentValues at: (argumentNames indexOf: 'flExtensionOf:'))
		ifAbsent: [ ^ nil ].
		
	^ (aPragma method pragmas anySatisfy: [ :pragma |
		pragma key = #flExtensionClassSide ])
			ifTrue: [ class class ]
			ifFalse: [ class ]! !

!FLExtensionWrapper methodsFor: 'accessing' stamp: ''!
method: aCompiledMethod
	method := aCompiledMethod! !

!FLExtensionWrapper methodsFor: 'accessing' stamp: ''!
isSource
	^ isSource! !

!FLExtensionWrapper methodsFor: 'initialize-release' stamp: ''!
readSelectorFrom: aPragma argumentNames: argumentNames argumentValues: argumentValues
	| index |
	index := argumentNames
		indexOf: 'selector:'
		ifAbsent: [ ^ aPragma method selector ].
	
	^ argumentValues at: index! !

!FLExtensionWrapper methodsFor: 'private' stamp: ''!
renameAndCompileInTarget
	| newMethod |
	newMethod := FLPlatform current
		renamedMethodCopyOf: self method
		selector: self selector.
	FLPlatform current
		silentlyAddAndClassifySelector: self selector
		inClass: self targetClass
		withMethod: newMethod
		inProtocol: self extensionProtocolName! !

!FLExtensionWrapper methodsFor: 'initialize-release' stamp: ''!
readIsSourceFrom: aPragma argumentNames: argumentNames argumentValues: argumentValues
	| index |
	index := argumentNames
		indexOf: 'isSource:'
		ifAbsent: [ ^ false ].
	
	^ argumentValues at: index! !

!FLExtensionWrapper class methodsFor: 'instance creation' stamp: ''!
fromPragma: aPragma
	^ self new
		initializeWithPragma: aPragma;
		yourself! !

!FLExternalAddressCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anExternalAddress with: anEncoder
	anEncoder encodeUint32: anExternalAddress basicSize! !

!FLExternalAddressCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	| size |
	size := aDecoder nextEncodedUint32.
	^ (theClass basicNew: size)
		beNull;
		yourself
! !

!FLFileReferenceStreamBasicSerializationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	self useFileReferenceStream! !

!FLFileReferenceStreamStrategy commentStamp: ''!
I use binary read and write streams atop a memory filesystem.!
!FLFileReferenceStreamStrategy methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	reference := FileSystem memory / 'aFile'! !

!FLFileReferenceStreamStrategy methodsFor: 'writing' stamp: ''!
writeStreamDo: aValuable
	^ reference binaryWriteStreamDo: [ :stream | aValuable value: stream ]! !

!FLFileReferenceStreamStrategy methodsFor: 'reading' stamp: ''!
readStreamDo: aValuable
	^ reference binaryReadStreamDo: [ :stream | aValuable value: stream ]! !

!FLFixedObjectCluster commentStamp: ''!
I am a generic cluster for objects without indexable variables.!
!FLFixedObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstancesStepWith: anEncoder
	"Do nothing. I know my objects have nothing to serialize in this step."
! !

!FLFixedObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^theClass fuelNew! !

!FLFuelCommandLineHandler commentStamp: ''!
I handle .fuel files that are passed as arguments when starting the image. 

Usage: fuel [save] [quit] <fuelFile>
 
	save    save the image after loading <fuelFile>
	quit    Don't save the image and directly quit the image fater loading <fuelFile>
	
Documentation:
This command will load the <fuelFile> and materialize/install it's contents. If no argument is specified the image continues running with the loaded contents.


Example:

	#Load a fuel file and save and quit the image with the contents:
	pharo Pharo.image save quit path/to/foo.fuel

	#Load the contents of foo.fuel and save the image, but continue running:
	pharo Pharo.image save path/to/foo.fuel
	
	#Load the contents of foo.fuel and continue running without saving:
	pharo Pharo.image path/to/foo.fuel
!
!FLFuelCommandLineHandler methodsFor: 'manage' stamp: ''!
manageFiles
	"Load all the source files in the given array."
	files := (self commandLine allFilesWithExtension: self fileExtension)
		 collect: [ :each | (FileSystem disk resolve: each) asFileReference ].
	files ifNil: [ ^self ].
	files do: [ :reference | self manageFile: reference ] 
! !

!FLFuelCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self manageFiles.
	(self commandLine hasOption: 'save') ifTrue: [
		ThreadSafeTranscript install.
		SessionManager default addDeferredStartupAction: [
			Smalltalk snapshot: true andQuit: true.
			NonInteractiveTranscript new install ] ].
	(self commandLine hasOption: 'quit') ifTrue: [
		self exitSuccess ]! !

!FLFuelCommandLineHandler methodsFor: 'manage' stamp: ''!
manageFile: aFileReference
	Stdio stdout
		nextPutAll: 'Materializing from file: ';
		nextPutAll: aFileReference fullName;
		lf.
	aFileReference readStreamDo: [ :stream |
		stream binary.
		FLMaterializer new materializeFrom: stream ].
	Stdio stdout
		nextPutAll: 'Materialization finished';
		lf! !

!FLFuelCommandLineHandler methodsFor: 'accessing' stamp: ''!
fileExtension
	^ self class fileExtension! !

!FLFuelCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'Fuel'! !

!FLFuelCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Loads fuel files'! !

!FLFuelCommandLineHandler class methodsFor: 'handler selection' stamp: ''!
isResponsibleFor: aCommandLine
	"This handler is reponsible only for .fuel files"
	(aCommandLine hasFileWithExtension: self fileExtension)
		ifTrue: [ ^ true ].
	^ super isResponsibleFor: aCommandLine
	! !

!FLFuelCommandLineHandler class methodsFor: 'accessing' stamp: ''!
fileExtension
	^ '.fuel'! !

!FLGZipStrategy commentStamp: ''!
I am a strategy for using GZipStream.!
!FLGZipStrategy methodsFor: 'initialize-release' stamp: ''!
initializeWith: aStreamStrategy

	self initialize.
	targetStrategy := aStreamStrategy.! !

!FLGZipStrategy methodsFor: 'writing' stamp: ''!
writeStreamDo: aValuable
	"Evaluates the argument with a write stream. Answers the result."
	
	targetStrategy writeStreamDo: [:aStream |
		^ GZipWriteStream with: aStream do: aValuable]
! !

!FLGZipStrategy methodsFor: 'reading' stamp: ''!
readStreamDo: aValuable
	"Evaluates the argument with a read stream. Answers the result."
	
	targetStrategy readStreamDo: [:aStream |
		^ GZipReadStream with: aStream do: aValuable]
! !

!FLGZipStrategy class methodsFor: 'instance creation' stamp: ''!
newWithTarget: aStreamStrategy

	^self basicNew
		initializeWith: aStreamStrategy;
		yourself
		! !

!FLGZippedBasicSerializationTest commentStamp: ''!
SUnit tests for basic serialization that is zipped!
!FLGZippedBasicSerializationTest methodsFor: 'tests' stamp: ''!
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: ''!
testWideString

	| anObject |
	anObject := OrderedCollection new.
	600 timesRepeat: [
	       anObject add: (WideString
	               streamContents: [ :stream |
	                       600 timesRepeat: [
	                               stream nextPut: (256 to: 1000) atRandom asCharacter ] ] ) ].
	
	self
		shouldnt: [ self assertSerializationEqualityOf: anObject ]
		raise: Error! !

!FLGZippedBasicSerializationTest methodsFor: 'expected failures' stamp: ''!
expectedFailures

	^ super expectedFailures, #(testWideString)! !

!FLGZippedBasicSerializationTest methodsFor: 'tests' stamp: ''!
testPairs

	| pairs |
	pairs := (1 to: 1 << 14) 
		collect: [ :i | 
			FLPair new 
				left: i; 
				right: i+1;
				yourself ].

	self assertSerializationEqualityOf: pairs! !

!FLGZippedBasicSerializationTest methodsFor: 'tests' stamp: ''!
testByteArray

	self assertSerializationEqualityOf: #[1 2 3 4 5 6 7]! !

!FLGZippedBasicSerializationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self useGzipInMemoryStream.! !

!FLGlobalClassCluster commentStamp: ''!
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: ''!
serializeInstance: aClass with: anEncoder
	
	self serializeGlobalClass: aClass on: anEncoder! !

!FLGlobalClassCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^self materializeGlobalClassFrom: aDecoder ! !

!FLGlobalClassSerializationTest commentStamp: ''!
I test the serialization of classes as *global* objects, i.e. the classes has to be present in the image at materialization time.!
!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testPreservesIdentity
	"Tests that serialization of the class or trait preserves identity"
	
	self assertSerializationIdentityOf: self newClassOrTrait! !

!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testNotFoundAfterRemoval
	"Tests that serializer does not tolarate when the class was removed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	
	self serialize: classOrTrait.
	self removeFromSystem: classOrTrait.
	
	self should: [self materialized] raise: FLClassNotFound.! !

!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testObsolete
	"Tests that serializer does not serialize as global an obsolete class or trait."
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	self removeFromSystem: classOrTrait.

	self 
		should: [self serialize: classOrTrait ] 
		raise: FLObsolete
		whoseDescriptionIncludes: classOrTrait name
		description: 'Should raise an error when serializing as global an obsolete class or trait.' ! !

!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testInstanceOfAnObsoleteClass
	"Tests that serializer does not serialize an instance of an obsolete class."
	
	| aClass instance |
	aClass := self newClassOrTrait.
	instance := self newInstanceFrom: aClass.
	self removeFromSystem: aClass.

	self 
		should: [self serialize: instance ] 
		raise: FLObsolete
		whoseDescriptionIncludes: aClass name
		description: 'Should raise an error when serializing as global an obsolete class.' ! !

!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testClassSideMethodNotFoundAfterRemoval
	"Tests that serializer does not tolarate when the method was removed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait classSide duringTestCompileSilently: 'you'.
	
	self serialize: classOrTrait classSide >> #you.
	classOrTrait classSide removeSelectorSilently: #you.
	
	self 
		should: [self materialized] 
		raise: FLMethodNotFound
		whoseDescriptionIncludes: classOrTrait classSide printString 
		description: 'Should raise an error when method is not present.' 
	
! !

!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testClassSideObsolete
	"Tests that serializer does not serialize as global the class-side of an obsolete class or trait."
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	self removeFromSystem: classOrTrait.

	self 
		should: [self serialize: classOrTrait ] 
		raise: FLObsolete
		whoseDescriptionIncludes: classOrTrait name
		description: 'Should raise an error when serializing as global an obsolete class or trait.' ! !

!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testMethodNotFoundAfterRemoval
	"Tests that serializer does not tolarate when the method was removed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait duringTestCompileSilently: 'you'.
	
	self serialize: classOrTrait >> #you.
	classOrTrait removeSelectorSilently: #you.
	
	self 
		should: [self materialized] 
		raise: FLMethodNotFound
		whoseDescriptionIncludes: classOrTrait name, '>>#you' 
		description: 'Should raise an error when method is not present.' 
	
! !

!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testClassSidePreservesIdentity
	"Tests that serialization of the class side preserves identity"
	
	self assertSerializationIdentityOf: self newClassOrTrait classSide ! !

!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testMethodPreservesIdentity
	"Tests that serialization of a method in a class or trait preserves identity"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait duringTestCompileSilently: 'you'.
	self assertSerializationIdentityOf: classOrTrait >> #you! !

!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testClassSideMethodPreservesIdentity
	"Tests that serialization of a method in the class-side of a class or trait preserves identity"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait classSide duringTestCompileSilently: 'you'.
	self assertSerializationIdentityOf: classOrTrait classSide >> #you! !

!FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''!
testNotFoundAfterRename
	"Tests that serializer does not tolarate when the class was renamed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	
	self serialize: classOrTrait.
	classOrTrait renameSilently: (classOrTrait name, 'Renamed') asSymbol.
	
	self should: [self materialized] raise: FLClassNotFound.! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!FLGlobalClassSerializationTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!FLGlobalClassSerializationTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!FLGlobalClassSerializationTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!FLGlobalClassSerializationTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!FLGlobalClassSerializationTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!FLGlobalClassSerializationTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!FLGlobalClassSerializationTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!FLGlobalClassSerializationTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!FLGlobalClassSerializationTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!FLGlobalClassSerializationTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!FLGlobalClassSerializationTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!FLGlobalClassSerializationTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!FLGlobalClassSerializationTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!FLGlobalClassSerializationTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!FLGlobalClassSerializationTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!FLGlobalClassSerializationTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!FLGlobalClassSerializationTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!FLGlobalClassSerializationTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!FLGlobalClassSideCluster commentStamp: ''!
I am a cluster for those Metaclasses and ClassTrait who are not stored in detail.!
!FLGlobalClassSideCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: aClassOrTraitClassSide with: anEncoder

	self serializeGlobalClass: aClassOrTraitClassSide instanceSide on: anEncoder
! !

!FLGlobalClassSideCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^(self materializeGlobalClassFrom: aDecoder) classSide! !

!FLGlobalCluster commentStamp: ''!
I am a cluster for objects that are reachables from Smalltalk global dictionary.!
!FLGlobalCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeGlobalClassFrom: aDecoder

	| className |
	className := aDecoder nextEncodedString asSymbol.
	^ aDecoder classNamed: className! !

!FLGlobalCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeGlobalClass: aClass on: anEncoder
	
	aClass isObsolete ifTrue: [ FLObsolete signalWithName: aClass name ].
	anEncoder encodeString: aClass name ! !

!FLGlobalCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeGlobalAssociationFrom: aDecoder

	| globalName |
	globalName := aDecoder nextEncodedString asSymbol.
	^ aDecoder globalEnvironment
		associationAt: globalName
		ifAbsent: [ FLGlobalNotFound signalWithName: globalName ]
! !

!FLGlobalCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeGlobalAssociationKeyed: aSymbol on: anEncoder
	
	anEncoder encodeString: aSymbol! !

!FLGlobalCluster class methodsFor: 'analyzing' stamp: ''!
clusterBucketIn: aClusterization

	^aClusterization globalsBucket ! !

!FLGlobalCompiledBlockCluster commentStamp: ''!
I clusterize CompiledBlocks that belong to CompiledMethods that are considered global (see FLGlobalCompiledMethodCluster).

Before Pharo 9, the bytecode of blocks was stored in the associated CompiledMethod. As of Pharo 9, CompiledBlocks can
exist independantly of an associated CompiledMethod and store their own bytecode. Hence, when a CompiledMethod is considered global, all blocks must be treated equivalently. Otherwise, blocks would be serialized and materialized as normal and evaluating such a block may answer a result different from the actually installed block if the corresponding block was changed in the installed method in the mean time.

See FLBlockClosureSerializationTest>>testBlockClosureChangeDifferentBytecodes and #testBlockClosureChangeSameBytecodes.!
!FLGlobalCompiledBlockCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: aCompiledBlock with: anEncoder
	"The method will be looked up on the existing class upon materialization
	and the block will be compiled as part of that method (possibly with a different
	set of instructions than this one but that's expected behavior).
	
	See #testBlockClosureChangeDifferendBytecodes and #testBlockClosureChangeSameBytecodes
	on FLBlockClosureSerializationTest."
	| method literalIndex |
	method := aCompiledBlock method.
	literalIndex := method literals indexOf: aCompiledBlock.
	
	self
		serializeGlobalClass: aCompiledBlock methodClass
		on: anEncoder.
	anEncoder
		encodeString: method selector;
		encodeUint8: literalIndex
! !

!FLGlobalCompiledBlockCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	| methodClass selector method literalIndex |
	methodClass := self materializeGlobalClassFrom: aDecoder.
	selector := aDecoder nextEncodedString asSymbol.
	literalIndex := aDecoder nextEncodedUint8.
	
	"It's ok if the method was changed or removed."
	method := methodClass  
		compiledMethodAt: selector
		ifAbsent: [ ^ nil ].
	^ literalIndex > method numLiterals
		ifTrue: [ nil ]
		ifFalse: [ method literalAt: literalIndex ]! !

!FLGlobalCompiledCodeCluster commentStamp: ''!
I am the abstract global cluster for CompiledCode classes. I implement shared serialization and materialization behavior.

My instances are looked up in the image, not materialized.
!
!FLGlobalCompiledCodeCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeGlobalClassFrom: aDecoder
	| class |
	class := super materializeGlobalClassFrom: aDecoder.
	^ aDecoder nextEncodedByte = 1
		ifTrue: [ class classSide ]
		ifFalse: [ class instanceSide ]! !

!FLGlobalCompiledCodeCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeGlobalClass: aClass on: anEncoder
	super
		serializeGlobalClass: aClass instanceSide
		on: anEncoder. 
	anEncoder
		encodeByte: (aClass isClassSide
			ifTrue: [ 1 ]
			ifFalse: [ 0 ])! !

!FLGlobalCompiledMethodCluster commentStamp: ''!
I clusterize CompiledMethods that will be obtained on materialization accessing method dictionary of the corresponding class in Smalltalk globals.
!
!FLGlobalCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: aCompiledMethod with: anEncoder
	self
		serializeGlobalClass: aCompiledMethod methodClass
		on: anEncoder.
	anEncoder
		encodeString: aCompiledMethod selector;
		encodeUint16: aCompiledMethod bytecodesHash! !

!FLGlobalCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	| methodClass selector method serializedHash |
	methodClass := self materializeGlobalClassFrom: aDecoder.
	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! !

!FLGlobalEnvironmentTest commentStamp: ''!
SUnit tests for global fuel environment!
!FLGlobalEnvironmentTest methodsFor: 'tests' stamp: ''!
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 equals: (classB class >> #m) bytecodesHash.
	self deny: classA class >> #m identicalTo: classB class >> #m.

	materializationEnvironment at: classA name put: classB.

	self assert: (self resultOfSerializeAndMaterialize: classA class >> #m) identicalTo: classB class >> #m! !

!FLGlobalEnvironmentTest methodsFor: 'tests' stamp: ''!
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 equals: (classB >> #m) bytecodesHash.
	self deny: classA >> #m identicalTo: classB >> #m.

	materializationEnvironment at: classA name put: classB.

	self assert: (self resultOfSerializeAndMaterialize: classA >> #m) identicalTo: classB >> #m! !

!FLGlobalEnvironmentTest methodsFor: 'tests' stamp: ''!
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) identicalTo: FLPerson! !

!FLGlobalEnvironmentTest methodsFor: 'tests' stamp: ''!
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: ''!
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: ''!
testGlobalMetaclassNotFound
	"If a class is not defined in the materialization environment, a proper error should be raised."
	
	self serialize: Integer class.
	
	self should: [ self materialization ] 
		raise: FLClassNotFound 
		description: 'Raise an error since the class is not present in materialization global environment'! !

!FLGlobalEnvironmentTest methodsFor: 'tests' stamp: ''!
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: ''!
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) identicalTo: FLPerson class! !

!FLGlobalEnvironmentTest methodsFor: 'tests' stamp: ''!
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: ''!
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) identicalTo: anObject! !

!FLGlobalEnvironmentTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	serializationEnvironment := Dictionary new.
	materializationEnvironment := Dictionary new.
	
	self analyzer globalEnvironment: serializationEnvironment.
	self materializer globalEnvironment: materializationEnvironment.! !

!FLGlobalNotFound commentStamp: ''!
I represent an error produced during materialization when a serialized global name doesn't exist (at Smalltalk globals).!
!FLGlobalNotFound class methodsFor: 'signaling' stamp: ''!
signalWithName: aName
	^ self signal: 'Global named ', aName printString, ' not found.'! !

!FLGlobalSendCluster commentStamp: ''!
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: ''!
initializeAnalyzing
	super initializeAnalyzing.
	globalSends := IdentityDictionary new.! !

!FLGlobalSendCluster methodsFor: 'mapping' stamp: ''!
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: ''!
serializeInstance: anObject with: anEncoder
	
	| globalSend |
	globalSend := globalSends at: anObject.
	
	self serializeGlobalAssociationKeyed: globalSend key on: anEncoder.
	anEncoder encodeString: globalSend value.
! !

!FLGlobalSendCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	| global selector |
	global := (self materializeGlobalAssociationFrom: aDecoder) value.	
	selector := aDecoder nextEncodedString asSymbol.
	^ global perform: selector! !

!FLGlobalSendMock commentStamp: ''!
A mock for a global send!
!FLGlobalSendMock methodsFor: 'comparing' stamp: ''!
= 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: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ contents hash! !

!FLGlobalSendMock methodsFor: 'serialization' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitGlobalSend: self name: #FLGlobalSendMock selector: #newInstanceToMaterialize! !

!FLGlobalSendMock methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Append a sequence of characters to aStream that identify the receiver."

	super printOn: aStream.
	aStream
		nextPutAll: ' contents: ';
		print: contents! !

!FLGlobalSendMock methodsFor: 'initialization' stamp: ''!
initializeWith: aByteSymbol
	
	super initialize.
	contents := aByteSymbol ! !

!FLGlobalSendMock methodsFor: 'accessing' stamp: ''!
contents
	^ contents! !

!FLGlobalSendMock methodsFor: 'accessing' stamp: ''!
contents: anObject
	contents := anObject! !

!FLGlobalSendMock class methodsFor: 'instance creation' stamp: ''!
newInstanceToMaterialize
	
	^self newWith: #materializing! !

!FLGlobalSendMock class methodsFor: 'instance creation' stamp: ''!
newInstanceToSerialize
	
	^self newWith: #serializing! !

!FLGlobalSendMock class methodsFor: 'instance creation' stamp: ''!
newWith: aByteSymbol 
	
	^self basicNew
		initializeWith: aByteSymbol;
		yourself! !

!FLGlobalSendNotPresentMock commentStamp: ''!
A test mock where a global send is not present!
!FLGlobalSendNotPresentMock methodsFor: 'serialization' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitGlobalSend: self name: #FLKeyNotPresentInSmalltalks selector: #someSelector! !

!FLGlobalSendSerializationTest commentStamp: ''!
SUnit tests for fuel serialization of global sends!
!FLGlobalSendSerializationTest methodsFor: 'tests' stamp: ''!
testBasic
	| result |
	self deny: FLGlobalSendMock newInstanceToSerialize equals: FLGlobalSendMock newInstanceToMaterialize.

	result := self resultOfSerializeAndMaterialize: FLGlobalSendMock newInstanceToSerialize.
	self assert: FLGlobalSendMock newInstanceToMaterialize equals: result! !

!FLGlobalSendSerializationTest methodsFor: 'tests' stamp: ''!
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.' 
	
! !

!FLGlobalTraitSerializationTest commentStamp: ''!
I test the serialization of traits as *external* objects, i.e. the traits has to be present in the image at materialization time.!
!FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''!
testPreservesIdentity
	"Tests that serialization of the class or trait preserves identity"
	
	self assertSerializationIdentityOf: self newClassOrTrait! !

!FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''!
testNotFoundAfterRemoval
	"Tests that serializer does not tolarate when the class was removed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	
	self serialize: classOrTrait.
	self removeFromSystem: classOrTrait.
	
	self should: [self materialized] raise: FLClassNotFound.! !

!FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''!
testObsolete
	"Tests that serializer does not serialize as global an obsolete class or trait."
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	self removeFromSystem: classOrTrait.

	self 
		should: [self serialize: classOrTrait ] 
		raise: FLObsolete
		whoseDescriptionIncludes: classOrTrait name
		description: 'Should raise an error when serializing as global an obsolete class or trait.' ! !

!FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''!
testClassSideMethodNotFoundAfterRemoval
	"Tests that serializer does not tolarate when the method was removed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait classSide duringTestCompileSilently: 'you'.
	
	self serialize: classOrTrait classSide >> #you.
	classOrTrait classSide removeSelectorSilently: #you.
	
	self 
		should: [self materialized] 
		raise: FLMethodNotFound
		whoseDescriptionIncludes: classOrTrait classSide printString 
		description: 'Should raise an error when method is not present.' 
	
! !

!FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''!
testClassSideObsolete
	"Tests that serializer does not serialize as global the class-side of an obsolete class or trait."
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	self removeFromSystem: classOrTrait.

	self 
		should: [self serialize: classOrTrait ] 
		raise: FLObsolete
		whoseDescriptionIncludes: classOrTrait name
		description: 'Should raise an error when serializing as global an obsolete class or trait.' ! !

!FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''!
testMethodNotFoundAfterRemoval
	"Tests that serializer does not tolarate when the method was removed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait duringTestCompileSilently: 'you'.
	
	self serialize: classOrTrait >> #you.
	classOrTrait removeSelectorSilently: #you.
	
	self 
		should: [self materialized] 
		raise: FLMethodNotFound
		whoseDescriptionIncludes: classOrTrait name, '>>#you' 
		description: 'Should raise an error when method is not present.' 
	
! !

!FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''!
testClassSidePreservesIdentity
	"Tests that serialization of the class side preserves identity"
	
	self assertSerializationIdentityOf: self newClassOrTrait classSide ! !

!FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''!
testMethodPreservesIdentity
	"Tests that serialization of a method in a class or trait preserves identity"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait duringTestCompileSilently: 'you'.
	self assertSerializationIdentityOf: classOrTrait >> #you! !

!FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''!
testClassSideMethodPreservesIdentity
	"Tests that serialization of a method in the class-side of a class or trait preserves identity"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait classSide duringTestCompileSilently: 'you'.
	self assertSerializationIdentityOf: classOrTrait classSide >> #you! !

!FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''!
testNotFoundAfterRename
	"Tests that serializer does not tolarate when the class was renamed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	
	self serialize: classOrTrait.
	classOrTrait renameSilently: (classOrTrait name, 'Renamed') asSymbol.
	
	self should: [self materialized] raise: FLClassNotFound.! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!FLGlobalTraitSerializationTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!FLGlobalTraitSerializationTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!FLGlobalTraitSerializationTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!FLGlobalTraitSerializationTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!FLGlobalTraitSerializationTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!FLGlobalTraitSerializationTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!FLGlobalTraitSerializationTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!FLGlobalTraitSerializationTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!FLGlobalTraitSerializationTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!FLGlobalTraitSerializationTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!FLGlobalTraitSerializationTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!FLGlobalTraitSerializationTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!FLGlobalTraitSerializationTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!FLGlobalTraitSerializationTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!FLGlobalTraitSerializationTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!FLGlobalTraitSerializationTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!FLGlobalTraitSerializationTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!FLGlobalTraitSerializationTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!FLGlobalValueCluster commentStamp: ''!
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: ''!
serializeInstance: anObject with: anEncoder
	
	self serializeGlobalAssociationKeyed: (anEncoder globalEnvironment keyAtValue: anObject) on: anEncoder! !

!FLGlobalValueCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^(self materializeGlobalAssociationFrom: aDecoder) value! !

!FLHashedCollectionSerializationTest commentStamp: ''!
SUnit tests for fuel serialization of hashed collections!
!FLHashedCollectionSerializationTest methodsFor: 'tests' stamp: ''!
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) equals: person1.
	self assert: (aDictionary at: person2) equals: person2.
	self assert: (aDictionary at: person3) equals: 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. The VM 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: ''!
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. The VM 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).! !

!FLHeader commentStamp: ''!
An instance of FLHeader is serialized together with the orignal object graph to serialize. This header is useful to:

1) Attach additional state or metadata associated to the graph being serialized.
2) Attach pre and post materialization actions!
!FLHeader methodsFor: 'testing' stamp: ''!
isEmpty
	^ preMaterializationActions isEmpty 
		and: [ postMaterializationActions isEmpty
		and: [ additionalObjects isEmpty ] ]! !

!FLHeader methodsFor: 'accessing' stamp: ''!
materialization: aMaterialization
	"This is just set once the materialization had happened"
	materialization := aMaterialization ! !

!FLHeader methodsFor: 'executing' stamp: ''!
executePostMaterializationActions
	postMaterializationActions do: [:each | each cull: materialization]! !

!FLHeader methodsFor: 'initialization' stamp: ''!
initialize
	additionalObjects := IdentityDictionary new.
	preMaterializationActions := OrderedCollection new.
	postMaterializationActions := OrderedCollection new.! !

!FLHeader methodsFor: 'accessing' stamp: ''!
preMaterializationActions: listOfPreMaterializationActions
	preMaterializationActions := listOfPreMaterializationActions.
	! !

!FLHeader methodsFor: 'accessing' stamp: ''!
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: 'executing' stamp: ''!
executePreMaterializationActions
	preMaterializationActions do: [:each | each value]! !

!FLHeader methodsFor: 'accessing' stamp: ''!
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: ''!
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: ''!
additionalObjectAt: key
	^ additionalObjects at: key! !

!FLHeader methodsFor: 'accessing' stamp: ''!
postMaterializationActions: listOfPostMaterializationActions
	postMaterializationActions := listOfPostMaterializationActions.
	! !

!FLHeaderSerializationTest commentStamp: ''!
SUnit tests for header serialization in fuel!
!FLHeaderSerializationTest methodsFor: 'tests' stamp: ''!
testPreMaterializationActions
	| aClass |
	aClass := self
		newSubclassNamed: #FuelPreMaterializationTestClassToBeDeleted
		of: Object
		instanceVariableNames: ''
		classVariableNames: 'TestClassVariable TestClassVariable2'.
	aClass class
		duringTestCompileSilently: 'postLoadMethod  TestClassVariable := 1';
		duringTestCompileSilently: 'postLoadMethod2  TestClassVariable := 2';
		duringTestCompileSilently: 'classVariable  ^TestClassVariable '.

	aClass perform: #postLoadMethod.
	self assert: (aClass perform: #classVariable) equals: 1.
	"Cannot replace with testing environment for having clean blockClosure"
	self serializer addPreMaterializationAction: [ (Smalltalk at: #FuelPreMaterializationTestClassToBeDeleted) perform: #postLoadMethod2 ].
	self serialize: aClass.
	self assert: (aClass perform: #classVariable) equals: 1.
	self materialized.
	self assert: (aClass perform: #classVariable) equals: 2! !

!FLHeaderSerializationTest methodsFor: 'tests' stamp: ''!
testPostMaterializationActions
	| aClass |
	aClass := self
		newSubclassNamed: #FuelPostMaterializationTestClassToBeDeleted
		of: Object
		instanceVariableNames: ''
		classVariableNames: 'TestClassVariable TestClassVariable2'.
	aClass class
		duringTestCompileSilently: 'postLoadMethod  TestClassVariable := 1';
		duringTestCompileSilently: 'postLoadMethod2  TestClassVariable := 2';
		duringTestCompileSilently: 'classVariable  ^TestClassVariable '.

	aClass perform: #postLoadMethod.
	self assert: (aClass perform: #classVariable) equals: 1.
	"Cannot replace with testing environment for having clean blockClosure"
	self serializer addPostMaterializationAction: [ (Smalltalk at: #FuelPostMaterializationTestClassToBeDeleted) perform: #postLoadMethod2 ].
	self serialize: aClass.
	self assert: (aClass perform: #classVariable) equals: 1.
	self materialized.
	self assert: (aClass perform: #classVariable) equals: 2! !

!FLHeaderSerializationTest methodsFor: 'tests' stamp: ''!
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: ''!
testAdditionalObjects

	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.
	! !

!FLHookPrimitiveCluster commentStamp: ''!
I am a cluster for simple objects who define serialization and materialization via hooks on their classes.!
!FLHookPrimitiveCluster methodsFor: 'initialize-release' stamp: ''!
initializeAnalyzing: aClass

	self initializeAnalyzing.
	theClass := aClass! !

!FLHookPrimitiveCluster methodsFor: 'serialize/materialize' stamp: ''!
clusterMaterializeStepWith: aMaterialization

	super clusterMaterializeStepWith: aMaterialization.
	theClass := aMaterialization decoder nextEncodedReference.
! !

!FLHookPrimitiveCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anObject with: anEncoder

	anObject serializeOn: anEncoder! !

!FLHookPrimitiveCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	
	^theClass materializeFrom: aDecoder! !

!FLHookPrimitiveCluster methodsFor: 'serialize/materialize' stamp: ''!
clusterSerializeStepWith: aSerialization

	super clusterSerializeStepWith: aSerialization.
	aSerialization encoder encodeReferenceToClusterObjectClass: theClass.	! !

!FLHookPrimitiveCluster methodsFor: 'analyzing' stamp: ''!
clusterReferencesDo: aBlock

	aBlock value: theClass! !

!FLHookPrimitiveCluster methodsFor: 'printing' stamp: ''!
printNameOn: aStream
	"Append to the argument, aStream, a sequence of characters that  
	identifies the receiver."
	
	super printNameOn: aStream.
	aStream nextPut: $[.
	theClass printOn: aStream.
	aStream nextPut: $].! !

!FLHookPrimitiveCluster class methodsFor: 'instance creation' stamp: ''!
newAnalyzing: aClass

	^ self basicNew
		initializeAnalyzing: aClass;
		yourself.! !

!FLHookedSubstitutionTest commentStamp: ''!
SUnit tests for hooked serialization using fuel!
!FLHookedSubstitutionTest methodsFor: 'tests' stamp: ''!
testTransientByNil
	| result aClassOfTransientObjects | 
	aClassOfTransientObjects := self newClass
		duringTestCompileSilently: 'fuelAccept: aVisitor  ^aVisitor visitSubstitution: self by: nil';
		yourself.

	result := self resultOfSerializeAndMaterialize: aClassOfTransientObjects new.
	
	self assert: result isNil! !

!FLHookedSubstitutionTest methodsFor: 'tests' stamp: ''!
testAvoidRecursion
	| result original | 
	original := FLClassWithRecursiveSubstitution new index: 1.
	
	"Fail fast so the image doesn't crash if we end up in an endless loop"
	result := [ self resultOfSerializeAndMaterialize: original ]
		valueWithin: 1 second
		onTimeout: [ self fail ].
	
	self assert: result index equals: 2! !

!FLHookedSubstitutionTest methodsFor: 'tests' stamp: ''!
testSubstituteByItself
	| aRecursiveClass result | 
	aRecursiveClass := (self newSubclassOf: Object instanceVariableNames: '' classVariableNames: '') 
		duringTestCompileSilently: 'fuelAccept: aMapper  
			^aMapper 
				visitSubstitution: self by: self 
				onRecursionDo: [super fuelAccept: aMapper]';
		yourself.

	"Fail fast so the image doesn't crash if we end up in an endless loop"
	result := [ self resultOfSerializeAndMaterialize: aRecursiveClass new ]
		valueWithin: 1 second
		onTimeout: [ self fail ].
	
	"shouldn't lead to endless loop"
	self assert: result class identicalTo: aRecursiveClass! !

!FLHookedSubstitutionTest methodsFor: 'tests' stamp: ''!
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 equals: result! !

!FLHookedSubstitutionTest methodsFor: 'tests' stamp: ''!
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
		left: 6;
		right: 'foo'.

	original := aProxyClass new
		target: pair;
		yourself.

	pairRoot := FLPair new
		left: original;
		yourself.

	result := self resultOfSerializeAndMaterialize: pairRoot.

	self assert: result left left equals: 6.
	self assert: result left right equals: 'foo'.
	self assert: result right isNil! !

!FLHookedSubstitutionTest methodsFor: 'tests' stamp: ''!
testProxyByTargetAnalisysIsPropagated
	| aProxyClass result pair original |
	aProxyClass := (self newSubclassOf: Object instanceVariableNames: 'target' classVariableNames: '')
		duringTestCompileSilently: 'target: x  target := x';
		duringTestCompileSilently: 'fuelAccept: aVisitor  ^aVisitor visitSubstitution: self by: target';
		yourself.

	pair := FLPair new
		left: 6;
		right: 'foo';
		yourself.

	original := aProxyClass new
		target: pair;
		yourself.

	result := self resultOfSerializeAndMaterialize: original.

	self assert: result left equals: 6.
	self assert: result right equals: 'foo'! !

!FLHookedSubstitutionTest methodsFor: 'tests' stamp: ''!
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
		left: original;
		right: 'foo'.

	result := self resultOfSerializeAndMaterialize: pair.

	self assert: result left equals: 5.
	self assert: result right equals: 'foo'! !

!FLHookedSubstitutionTest methodsFor: 'tests' stamp: ''!
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 equals: result! !

!FLHookedSubstitutionTest methodsFor: 'tests' stamp: ''!
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.! !

!FLIgnoredVariablesTest commentStamp: ''!
SUnit tests for serialization with ignored variables!
!FLIgnoredVariablesTest methodsFor: 'tests' stamp: ''!
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: ''!
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 equals: (result instVarAt: 1).
	self assert: $B equals: (result instVarAt: 2).
	self assert: nil equals: (result instVarAt: 3)! !

!FLIgnoredVariablesTest methodsFor: 'tests' stamp: ''!
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: ''!
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 equals: (result instVarAt: 1).
	self assert: nil equals: (result instVarAt: 2).
	self assert: $C equals: (result instVarAt: 3)! !

!FLInMemoryBasicSerializationTest commentStamp: ''!
SUnit tests for basic in memory serialization!
!FLInMemoryBasicSerializationTest methodsFor: 'running' stamp: ''!
serialize: anObject

	byteArray := FLSerializer serializeToByteArray: anObject! !

!FLInMemoryBasicSerializationTest methodsFor: 'running' stamp: ''!
materialization

	self error: 'Disabled, instead use #materialized.'
! !

!FLInMemoryBasicSerializationTest methodsFor: 'tests' stamp: ''!
testConsiderCustomGlobal
	"Since FLSerializer class >> serializeToByteArray: does not allow customizing serialization, this test is disabled."! !

!FLInMemoryBasicSerializationTest methodsFor: 'tests' stamp: ''!
testConsiderCustomWideSymbolGlobal
	"Since FLSerializer class >> serializeToByteArray: does not allow customizing serialization, this test is disabled."
	self error "Since it's an expectedFailure"! !

!FLInMemoryBasicSerializationTest methodsFor: 'running' stamp: ''!
materialized

	^ FLMaterializer materializeFromByteArray: byteArray.
! !

!FLInMemoryBasicSerializationTest methodsFor: 'tests' stamp: ''!
testStringGlobalsAndClosure
	| materialized |
	materialized := self
		resultOfSerializeAndMaterialize:
			(Array
				with: 'a string'
				with: Smalltalk
				with: [ Smalltalk vm.
					'a string' ]).
	self assert: materialized first equals: 'a string'.
	self assert: materialized second identicalTo: Smalltalk! !

!FLIndexStream commentStamp: ''!
I am an optimized stream for writing and reading *indexes*, i.e. positive integers with a known upper bound. !
!FLIndexStream methodsFor: 'initialize-release' stamp: ''!
initializeOn: aStream digits: aNumberOfDigits

	self initialize.
	stream := aStream.
	digits := aNumberOfDigits! !

!FLIndexStream methodsFor: 'accessing' stamp: ''!
nextIndexPut: v
	1 to: digits do: [ :i | stream nextPut: (v byteAt: digits + 1 - i) ]! !

!FLIndexStream methodsFor: 'accessing' stamp: ''!
nextIndex
	
	| s |
	s := 0.
	1 to: digits do: 
		[:i | s := (s bitShift: 8) bitOr: stream next].
	^ s! !

!FLIndexStream class methodsFor: 'instance creation' stamp: ''!
on: aStream digits: aNumberOfDigits

	^ self basicNew 
		initializeOn: aStream 
		digits: aNumberOfDigits;
		yourself.

	! !

!FLIndexStreamTest commentStamp: ''!
SUnit tests for index streams!
!FLIndexStreamTest methodsFor: 'tests' stamp: ''!
testCreation
	self indexStreamOn: #() writeStream digits: 2! !

!FLIndexStreamTest methodsFor: 'running' stamp: ''!
indexStreamOn: aStream digits: aNumberOfDigits
	^ FLIndexStream 
		on: aStream
		digits: aNumberOfDigits! !

!FLIndexStreamTest methodsFor: 'tests' stamp: ''!
testNextIndexPut

	| indexStream targetStream |
	targetStream := #() writeStream.
	indexStream := self 
		indexStreamOn: targetStream
		digits: 1.
	
	indexStream nextIndexPut: 0.
	indexStream nextIndexPut: 1.! !

!FLIndexStreamTest methodsFor: 'tests' stamp: ''!
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 equals: x ]! !

!FLIteratingCluster commentStamp: ''!
I am a template class whose algorithm for serialize a collection of objects consists on delegate the serialization of each individual object to the subclass.!
!FLIteratingCluster methodsFor: 'serialize/materialize' stamp: ''!
registerIndexesOn: anEncoder
	| indexes |
	indexes := anEncoder objectsIndexes.
	self objects do: [ :instance |
		indexes
			at: instance
			put: indexes size + 1 ]! !

!FLIteratingCluster methodsFor: 'analyzing' stamp: ''!
referencesOf: anObject do: aBlock
	"Evaluate a block with each object referenced by anObject"! !

!FLIteratingCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstancesStepWith: anEncoder

	objects do: [ :instance | self serializeInstance: instance with: anEncoder ]! !

!FLIteratingCluster methodsFor: 'initialize-release' stamp: ''!
initializeAnalyzing

	super initializeAnalyzing.
	objects := self newAnalyzingCollection.! !

!FLIteratingCluster methodsFor: 'printing' stamp: ''!
printOn: aStream

	self printNameOn: aStream.
	aStream nextPutAll: '->'.
	objects printElementsOn: aStream! !

!FLIteratingCluster methodsFor: 'serialize/materialize' stamp: ''!
clusterMaterializeStepWith: aMaterialization

	super clusterMaterializeStepWith: aMaterialization.
	objects := Array new: aMaterialization decoder nextEncodedUint32! !

!FLIteratingCluster methodsFor: 'analyzing' stamp: ''!
newAnalyzingCollection
	"Answer a collection for the objects that correspond to this cluster."

	^ FLLargeIdentitySet new! !

!FLIteratingCluster methodsFor: 'accessing' stamp: ''!
references
	^ references ifNil: [  references := FLLargeIdentityDictionary new ]! !

!FLIteratingCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	"Hook method that each subclass should customize for its special way of materializing"

	^ self subclassResponsibility! !

!FLIteratingCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anObject with: anEncoder
	"Hook method that each subclass should customize for its special way of serializing"! !

!FLIteratingCluster methodsFor: 'analyzing' stamp: ''!
addReferencesFrom: anObject to: aCollection
	aCollection do: [ :ref |
		self addReferenceFrom: anObject to: ref ]! !

!FLIteratingCluster methodsFor: 'serialize/materialize' stamp: ''!
clusterSerializeStepWith: aSerialization

	super clusterSerializeStepWith: aSerialization.
	aSerialization encoder encodeUint32: objects size! !

!FLIteratingCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstancesStepWith: aDecoder

	1 to: objects size do: [ :index |
		objects 
			at: index 
			put: (self materializeInstanceWith: aDecoder) ].! !

!FLIteratingCluster methodsFor: 'accessing' stamp: ''!
objects

	^objects! !

!FLIteratingCluster methodsFor: 'analyzing' stamp: ''!
addReferenceFrom: anObject to: anotherObject
	| list |
	list := self references
		at: anObject
		ifAbsentPut: [ OrderedCollection new ].

	list add: anotherObject! !

!FLIteratingCluster methodsFor: 'printing' stamp: ''!
printNameOn: aStream

	super printOn: aStream! !

!FLIteratingCluster methodsFor: 'analyzing' stamp: ''!
add: anObject traceWith: aAnalysis
	"Add an object to the cluster and trace references."

	objects addIfNotPresent: anObject ifPresentDo: [ ^ self ].

	self 
		referencesOf: anObject 
		do: [ :aChild || actual |
			actual := aChild fuelReplacement.
			self addReferenceFrom: anObject to: actual.
			aAnalysis trace: actual ]! !

!FLLargeIdentityDictionary commentStamp: ''!
I am an IdentityDictionary optimized for including a large number of elements.!
!FLLargeIdentityDictionary methodsFor: 'private' stamp: ''!
errorKeyNotFound: aKey

	KeyNotFound signalFor: aKey! !

!FLLargeIdentityDictionary methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	keys := Array new: 4096.
	values := Array new: 4096! !

!FLLargeIdentityDictionary methodsFor: 'accessing' stamp: ''!
keys

	^Array new: tally streamContents: [ :stream |
		self keysDo: [ :key | stream nextPut: key ] ]! !

!FLLargeIdentityDictionary methodsFor: 'accessing' stamp: ''!
at: key put: value

	| hash |
	(keys at: (hash := key largeIdentityHash \\ 4096 + 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: 'enumerating' stamp: ''!
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: 'copying' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
at: key

	| hash |
	(keys at: (hash := key largeIdentityHash \\ 4096 + 1)) ifNotNil: [ :keyList | 
		1 to: (tallies at: hash) do: [ :index |
			(keyList at: index) == key ifTrue: [
				^(values at: hash) at: index ] ] ].
	self errorKeyNotFound: key! !

!FLLargeIdentityDictionary methodsFor: 'enumerating' stamp: ''!
do: aBlock

	^self valuesDo: aBlock! !

!FLLargeIdentityDictionary methodsFor: 'accessing' stamp: ''!
at: key ifAbsent: aBlock

	| hash |
	(keys at: (hash := key largeIdentityHash \\ 4096 + 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: ''!
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]! !

!FLLargeIdentityDictionary methodsFor: 'enumerating' stamp: ''!
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: 'accessing' stamp: ''!
values

	^Array new: tally streamContents: [ :stream |
		self valuesDo: [ :value | stream nextPut: value ] ]! !

!FLLargeIdentityDictionary methodsFor: 'removing' stamp: ''!
removeKey: key ifAbsent: aBlock

	| hash |
	(keys at: (hash := key largeIdentityHash \\ 4096 + 1)) ifNotNil: [ :keyList |
		| size |
		1 to: (size := tallies at: hash) do: [ :index |
			(keyList at: index) == key ifTrue: [
				| valueList |
				keyList
					at: index put: (keyList at: size);
					at: size put: nil.
				(valueList := values at: hash)
					at: index put: (valueList at: size);
					at: size put: nil.
				(size := size - 1) < (keyList size // 4) ifTrue: [
					| newList |
					newList := Array new: size * 2.
					newList
						replaceFrom: 1
						to: size
						with: keyList
						startingAt: 1.
					keys at: hash put: newList.
					newList := Array new: size * 2.
					newList
						replaceFrom: 1
						to: size
						with: valueList
						startingAt: 1.
					values at: hash put: newList ].
				tallies at: hash put: size.
				tally := tally - 1.
				^key ] ] ].
	^aBlock value! !

!FLLargeIdentityDictionary methodsFor: 'accessing' stamp: ''!
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 cull: ((values at: hash) at: index) ] ] ].
	^absentBlock value! !

!FLLargeIdentityDictionary methodsFor: 'testing' stamp: ''!
includesKey: key

	| hash |
	^(keys at: (hash := key largeIdentityHash \\ 4096 + 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 ] ]! !

!FLLargeIdentityHashedCollection commentStamp: ''!
I share behavior for special HashedCollections that are optimized for including a large number of elements.!
!FLLargeIdentityHashedCollection methodsFor: 'initialization' stamp: ''!
initialize

	tally := 0.
	tallies := Array new: 4096 withAll: 0! !

!FLLargeIdentityHashedCollection methodsFor: 'copying' stamp: ''!
postCopy

	tallies := tallies copy
! !

!FLLargeIdentityHashedCollection methodsFor: 'accessing' stamp: ''!
size

	^tally! !

!FLLargeIdentityHashedCollection class methodsFor: 'initialize-release' stamp: ''!
initialize

	| rng |
	rng := Random seed: 664399324.
	PermutationMap := (0 to: 4095) asArray shuffleBy: rng! !

!FLLargeIdentityHashedCollection class methodsFor: 'comparing' stamp: ''!
permuteHash: anInteger
	"Return an integer between 1 and 4096 when the argument is between 1 and 4096."

	^PermutationMap at: anInteger! !

!FLLargeIdentitySet commentStamp: ''!
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: ''!
add: anObject

	| hash |
	anObject ifNil: [ 
		includesNil ifFalse: [
			includesNil := true.
			tally := tally + 1 ].
		^anObject ].
	(array at: (hash := anObject largeIdentityHash \\ 4096 + 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: 'testing' stamp: ''!
includes: anObject

	anObject ifNil: [ ^includesNil ].
	^(array at: (anObject largeIdentityHash \\ 4096 + 1))
		ifNil: [ false ]
		ifNotNil: [ :list | list fuelPointsTo: anObject ]! !

!FLLargeIdentitySet methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	array := Array new: 4096.
	includesNil := false! !

!FLLargeIdentitySet methodsFor: 'copying' stamp: ''!
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: ''!
do: aBlock

	tally = 0 ifTrue: [ ^self ].
	includesNil ifTrue: [ aBlock value: nil ].
	1 to: 4096 do: [ :arrayIndex |
		| subArray |
		subArray := array at: arrayIndex.
		1 to: (tallies at: arrayIndex) do: [ :index |
			aBlock value: (subArray at: index) ] ]! !

!FLLargeIdentitySet methodsFor: 'adding' stamp: ''!
addIfNotPresent: anObject ifPresentDo: aBlock

	| hash |
	anObject ifNil: [ 
		includesNil ifFalse: [
			includesNil := true.
			tally := tally + 1 ].
		^anObject ].
	(array at: (hash := anObject largeIdentityHash \\ 4096 + 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: 'removing' stamp: ''!
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 \\ 4096 + 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! !

!FLLightGeneralMapper commentStamp: ''!
I know how to map an object to its default cluster. I can map every object.!
!FLLightGeneralMapper methodsFor: 'protected-mapping' stamp: ''!
clusterClassForSmallInteger: aSmallInteger

	aSmallInteger >= 0 ifTrue: [
		aSmallInteger <= 255 ifTrue: [^ FLPositive8SmallIntegerCluster].
		aSmallInteger <= 65535 ifTrue: [^ FLPositive16SmallIntegerCluster].
		aSmallInteger <= 16777215 ifTrue: [^ FLPositive24SmallIntegerCluster].
		aSmallInteger <= 4294967295 ifTrue: [^ FLPositive32SmallIntegerCluster].
		aSmallInteger <= 1152921504606846975 ifTrue: [^ FLPositive64SmallIntegerCluster].
	].
	aSmallInteger >= -128 ifTrue: [^ FLNegative8SmallIntegerCluster].
	aSmallInteger >= -32768 ifTrue: [^ FLNegative16SmallIntegerCluster].
	aSmallInteger >= -8388608 ifTrue: [^ FLNegative24SmallIntegerCluster].
	aSmallInteger >= -2147483648 ifTrue: [^ FLNegative32SmallIntegerCluster].
	aSmallInteger >= -1152921504606846976 ifTrue: [^ FLNegative64SmallIntegerCluster].

	self error: 'SmallInteger is out of range'
! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitWordsObject: anObject

	self mapAndTraceByObjectClass: anObject to: FLWordObjectCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitRectangle: aRectangle

	self mapAndTraceByClusterName: aRectangle to: FLRectangleCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitBytesObject: anObject

	self mapAndTraceByObjectClass: anObject to: FLByteObjectCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitFixedObject: anObject

	self mapAndTraceByObjectClass: anObject to: FLFixedObjectCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitSmallInteger: aSmallInteger

	self mapAndTraceByClusterName: aSmallInteger to: (self clusterClassForSmallInteger: aSmallInteger)! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitTrait: aTrait

	self mapAndTraceInstanceSideGlobal: aTrait! !

!FLLightGeneralMapper methodsFor: 'protected-mapping' stamp: ''!
mapAndTraceInstanceSideGlobal: aClassOrTrait

	(self clusterKeyedByClusterName: FLGlobalClassCluster)
		add: aClassOrTrait traceWith: analysis
! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
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: ''!
visitSubstitution: anObject by: anotherObject

	(self clusterKeyedByClusterName: FLSubstitutionCluster)
		add: anObject substitutedBy: anotherObject traceWith: analysis
! !

!FLLightGeneralMapper methodsFor: 'mapping' stamp: ''!
mapAndTrace: anObject

	anObject fuelAccept: self
! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitWeakObject: anObject

	self mapAndTraceByObjectClass: anObject to: FLWeakVariableObjectCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitMetaclass: aMetaclass

	self mapAndTraceByClusterName: aMetaclass to: FLGlobalClassSideCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitSimpleCollection: aCollection
	self mapAndTraceByObjectClass: aCollection to: FLSimpleCollectionCluster
! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitGlobalSend: anObject name: globalName selector: aSymbol

	(self clusterKeyedByClusterName: FLGlobalSendCluster)
		add: anObject name: globalName selector: aSymbol traceWith: analysis
! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitMethodContext: aMethodContext

	self mapAndTraceByObjectClass: aMethodContext to: FLContextCluster
! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitCompiledMethod: aCompiledMethod
	self
		mapAndTraceByClusterName: aCompiledMethod
		to: ((aCompiledMethod isInstalled not or: [aCompiledMethod isDoIt ])
			ifTrue: [ FLCompiledMethodCluster ]
			ifFalse: [ FLGlobalCompiledMethodCluster ])! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitMetaclassForTraits: aMetaclass
	self
		mapAndTraceByClusterName: aMetaclass
		to: FLGlobalClassSideCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitExternalAddress: anObject
	self
		mapAndTraceByObjectClass: anObject
		to: FLExternalAddressCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitNotSerializable: anObject
	FLNotSerializable signalWith: anObject! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitClassTrait: aClassTrait

	self mapAndTraceByClusterName: aClassTrait to: FLGlobalClassSideCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitHookPrimitive: anObject

	self mapAndTraceByObjectClass: anObject to: FLHookPrimitiveCluster
	! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitDictionary: aDictionary

	self mapAndTraceByObjectClass: aDictionary to: FLDictionaryCollectionCluster
! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitCompiledBlock: aCompiledBlock
	self
		mapAndTraceByClusterName: aCompiledBlock
		to: ((aCompiledBlock method isInstalled not or: [ aCompiledBlock method isDoIt ])
			ifTrue: [ FLCompiledBlockCluster ]
			ifFalse: [ FLGlobalCompiledBlockCluster ])! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitTraitedMetaclass: aMetaclass
	self
		mapAndTraceByClusterName: aMetaclass
		to: FLGlobalClassSideCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitPoint: aPoint

	self mapAndTraceByClusterName: aPoint to: FLPointCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitVariableObject: anObject

	self mapAndTraceByObjectClass: anObject to: FLVariableObjectCluster! !

!FLLightGeneralMapper methodsFor: 'visiting' stamp: ''!
visitClass: aClass

	self mapAndTraceInstanceSideGlobal: aClass! !

!FLLightGlobalMapper commentStamp: ''!
I map classes, traits, and global objects that belong to Smalltalk dictionary. I collaborate in serialization default behavior. 

For example, the global Transcript as well as any class in the image, are mapped by me.!
!FLLightGlobalMapper methodsFor: 'initialize-release' stamp: ''!
initializeWith: someObjects

	self initialize.
	globals := someObjects.! !

!FLLightGlobalMapper methodsFor: 'mapping' stamp: ''!
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 methodsFor: 'private' stamp: ''!
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! !

!FLLightGlobalMapper class methodsFor: 'instance creation' stamp: ''!
for: globalSymbols in: globalEnvironment

	^ self basicNew
		initializeWith: (self valuesFor: globalSymbols in: globalEnvironment);
		yourself.! !

!FLMapper commentStamp: ''!
The purpose of my hierarchy is to map objects with clusters.!
!FLMapper methodsFor: 'protected-mapping' stamp: ''!
clusterKeyedByClusterName: aClusterClass

	^ self
		clusterKeyedByClusterName: aClusterClass 
		factory:  [ aClusterClass newAnalyzing ]! !

!FLMapper methodsFor: 'accessing' stamp: ''!
analysis: anAnalysis

	analysis := anAnalysis.
	next ifNotNil: [ next analysis: anAnalysis ]! !

!FLMapper methodsFor: 'protected-mapping' stamp: ''!
mapAndTraceByClusterName: anObject to: aClusterClass

	(self clusterKeyedByClusterName: aClusterClass)
		add: anObject traceWith: analysis
! !

!FLMapper methodsFor: 'accessing' stamp: ''!
next: anObject
	next := anObject! !

!FLMapper methodsFor: 'protected-mapping' stamp: ''!
clusterInstanceOf: aClusterClass keyInBucket: clusterKey factory: clusterFactory

	| bucket |
	bucket := aClusterClass clusterBucketIn: analysis clusterization.
	^ bucket
		at: clusterKey
		ifAbsentPut: [ 
			clusterFactory value 
				traceWith: analysis;
				yourself ].
! !

!FLMapper methodsFor: 'hooks' stamp: ''!
fuelAccept: aGeneralMapper
	^ aGeneralMapper visitSubstitution: self by: nil! !

!FLMapper methodsFor: 'protected-mapping' stamp: ''!
clusterKeyedByObjectClass: clusterClass class: objectClass

	^ self 
		clusterInstanceOf: clusterClass 
		keyInBucket: objectClass 
		factory: [ clusterClass newAnalyzing: objectClass ]! !

!FLMapper methodsFor: 'protected-mapping' stamp: ''!
clusterKeyedByClusterName: aClusterClass factory: clusterFactory

	^ self
		clusterInstanceOf: aClusterClass
		keyInBucket: aClusterClass name
		factory: clusterFactory
! !

!FLMapper methodsFor: 'mapping' stamp: ''!
mapAndTrace: anObject

	self subclassResponsibility! !

!FLMapper methodsFor: 'protected-mapping' stamp: ''!
mapAndTraceByObjectClass: anObject to: aClusterClass

	(self clusterKeyedByObjectClass: aClusterClass class: anObject class)
		add: anObject traceWith: analysis
! !

!FLMaterialization commentStamp: ''!
I implement the algorithm for materializing an object graph on a stream. FLMaterializer known how to build instances of me.!
!FLMaterialization methodsFor: 'accessing' stamp: ''!
header: aHeader
	header := aHeader
	! !

!FLMaterialization methodsFor: 'private' stamp: ''!
referencesStep

	clusters do: [ :aCluster | aCluster materializeReferencesStepWith: decoder ]! !

!FLMaterialization methodsFor: 'private' stamp: ''!
headerStep

	decoder decodeYourself.
	clusterCount := decoder nextEncodedUint32.
	clusters := OrderedCollection new: clusterCount.
	clusters resetTo: 1. "Hack that avoids OrderedCollection>>makeRoomAtLast"! !

!FLMaterialization methodsFor: 'private' stamp: ''!
clusterInstancesStep

	| aCluster |
	aCluster := decoder nextEncodedClusterClass newMaterializing.
	aCluster clusterMaterializeStepWith: self.
	aCluster materializeInstancesStepWith: decoder.
	self registerAll: aCluster objects.
	aCluster materializePostInstancesStepWith: decoder.
	clusters add: aCluster.! !

!FLMaterialization methodsFor: 'accessing' stamp: ''!
decoder
	^ decoder! !

!FLMaterialization methodsFor: 'private' stamp: ''!
afterMaterializationStep

	clusters do: [ :aCluster | aCluster afterMaterializationStepWith: decoder ]! !

!FLMaterialization methodsFor: 'private' stamp: ''!
registerAll: materializedObjects
	
	decoder registerAll: materializedObjects ! !

!FLMaterialization methodsFor: 'initialize-release' stamp: ''!
initializeWith: aDecoder

	self initialize.
	decoder := aDecoder.
! !

!FLMaterialization methodsFor: 'header' stamp: ''!
additionalObjectAt: aKey
	^ header additionalObjectAt: aKey! !

!FLMaterialization methodsFor: 'accessing' stamp: ''!
root

	^ root ! !

!FLMaterialization methodsFor: 'private' stamp: ''!
instancesStep

	clusterCount timesRepeat: [ self clusterInstancesStep ]
! !

!FLMaterialization methodsFor: 'accessing' stamp: ''!
objects
	"Answer a collection with the materialized objects."

	^ decoder objects ! !

!FLMaterialization methodsFor: 'materializing' stamp: ''!
run

	self headerStep.
	self instancesStep.
	self referencesStep.
	self trailerStep.
	self afterMaterializationStep.! !

!FLMaterialization methodsFor: 'private' stamp: ''!
trailerStep

	root := decoder nextEncodedReference! !

!FLMaterialization class methodsFor: 'instance creation' stamp: ''!
with: aDecoder

	^self basicNew
		initializeWith: aDecoder;
		yourself
! !

!FLMaterializationError commentStamp: ''!
I represent an error happened during materialization.!
!FLMaterializationError methodsFor: 'testing' stamp: ''!
isResumable
	"Allow users to ignore errors if they know what they are doing"
	^ true! !

!FLMaterializationError class methodsFor: 'exceptioninstantiator' stamp: ''!
signal: signalerText

	^ super signal: 'Materialization error. ', signalerText
	! !

!FLMaterializer commentStamp: ''!
I am a binary object materializer. 

See an example of use in FLSerializer's documentation.

!
!FLMaterializer methodsFor: 'configuring-migration' stamp: ''!
migrateClassNamed: aSymbol toClass: aClass

	self 
		migrateClassNamed: aSymbol 
		toClass: aClass 
		variables: #()! !

!FLMaterializer methodsFor: 'configuring-migration' stamp: ''!
migrateClassNamed: aSymbol toClass: aClass variables: aDictionary 

	migrations
		at: aSymbol
		put: (FLMigration fromClassNamed: aSymbol toClass: aClass variables: aDictionary)! !

!FLMaterializer methodsFor: 'protected' stamp: ''!
setDefaultMaterialization

	materializationFactory := [:aDecoder | 
		(FLMaterialization 
			with: aDecoder)
			run; 
			yourself ]
	
	
! !

!FLMaterializer methodsFor: 'initialization' stamp: ''!
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: ''!
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: ''!
materializeHeaderFrom: aStream

	| aDecoder |
	aDecoder := 
		FLDecoder 
			on: aStream 
			migrations: migrations 
			globalEnvironment: globalEnvironment.
	self verifySignatureFrom: aDecoder.
	self verifyVersionFrom: aDecoder.
	^ self decodeHeaderWith: aDecoder! !

!FLMaterializer methodsFor: 'accessing' stamp: ''!
signature: anObject
	signature := anObject! !

!FLMaterializer methodsFor: 'hooks' stamp: ''!
fuelAccept: aGeneralMapper
	^ aGeneralMapper visitSubstitution: self by: nil! !

!FLMaterializer methodsFor: 'accessing' stamp: ''!
version: anObject
	version := anObject! !

!FLMaterializer methodsFor: 'accessing' stamp: ''!
globalEnvironment: aDictionary
	"Set the dictionary where the look up for global symbols will be done during materialization."
	
	globalEnvironment := aDictionary! !

!FLMaterializer methodsFor: 'accessing' stamp: ''!
globalEnvironment
	"Answer a dictionary where the look up for global symbols will be done during materialization."
	
	^ globalEnvironment! !

!FLMaterializer methodsFor: 'accessing' stamp: ''!
materializationFactory
	^ materializationFactory! !

!FLMaterializer methodsFor: 'accessing' stamp: ''!
signature
	^ signature! !

!FLMaterializer methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!FLMaterializer methodsFor: 'configuring-migration' stamp: ''!
migrateClassNamed: aSymbol variables: aDictionary 

	self 
		migrateClassNamed: aSymbol 
		toClass: (self class environment at: aSymbol)
		variables: aDictionary! !

!FLMaterializer methodsFor: 'protected' stamp: ''!
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: ''!
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: ''!
verifyVersionFrom: aDecoder

	| streamVersion |
	streamVersion := aDecoder nextEncodedUint16.
	(self version = streamVersion) ifFalse: [ 
		FLBadVersion 
			signalCurrentVersion: self version 
			streamVersion: streamVersion ]
! !

!FLMaterializer class methodsFor: '*NewTools-Fuel-FileRegistry' stamp: ''!
fileReaderServicesForFile: fullName suffix: suffix
	<fileService>
	suffix = 'fuel'
		ifFalse: [ ^ #() ].
	^ { self serviceFuelMaterialize }! !

!FLMaterializer class methodsFor: 'instance creation' stamp: ''!
newDefault

	^self new! !

!FLMaterializer class methodsFor: '*NewTools-Fuel-FileRegistry' stamp: ''!
serviceFuelMaterialize
	^ SimpleServiceEntry 
		provider: self 
		label: 'Materialize Fuel file'
		selector: #inspectMaterializationFromFileNamed:
		description: 'Materialize objects previously serialized with Fuel'
		buttonLabel: 'materialize'! !

!FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: ''!
materializeFromFileNamed: aFilename

	^ (self materializationFromFileNamed: aFilename) root
! !

!FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: ''!
materializeFromByteArray: byteArray

	^(self newDefault materializeFrom: byteArray readStream) root! !

!FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: ''!
materializeHeaderFromFileNamed: aFilename

	^ self materializationHeaderFromFileNamed: aFilename
! !

!FLMaterializer class methodsFor: 'protected' stamp: ''!
defaultSignature
	^ 'FUEL'! !

!FLMaterializer class methodsFor: '*NewTools-Fuel-FileRegistry' stamp: ''!
inspectMaterializationFromFileNamed: aString

	| result |
	result := self materializeFromFileNamed: aString.
	^ result inspect! !

!FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: ''!
materializationHeaderFromFileNamed: aFilename

	^ FLPlatform current
		fileNamed: aFilename 
		readStreamDo: [ :aFileStream | 
			self newDefault materializeHeaderFrom: aFileStream ]
! !

!FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: ''!
materializationFromFileNamed: aFilename
	^ FLPlatform current
		fileNamed: aFilename 
		readStreamDo: [ :aFileStream | 
			self newDefault materializeFrom: aFileStream ]
! !

!FLMaterializer class methodsFor: 'protected' stamp: ''!
currentVersion
	^ 303! !

!FLMethodChanged commentStamp: ''!
I represent an error produced during materialization when is detected a change in the bytecodes of a method serialized as global. 

This error was born when testing the materialization of a BlockClosure defined in a method that changed. The test produced a VM crash.!
!FLMethodChanged class methodsFor: 'signaling' stamp: ''!
signalWith: aGlobalName and: aSelector
	^ self signal: 'Method ', aGlobalName, '>>#', aSelector, ' changed its bytecodes.'! !

!FLMethodNotFound commentStamp: ''!
I represent an error produced during materialization when a serialized method in a class or trait name doesn't exist (at Smalltalk globals).!
!FLMethodNotFound class methodsFor: 'signaling' stamp: ''!
signalWith: aGlobalName and: aSelector
	^ self signal: 'Method ', aGlobalName, '>>#', aSelector, ' not found.'! !

!FLMigration commentStamp: ''!
I represent migration information about a class.

See 'configuring-migration' protocol in FLMaterializer.!
!FLMigration methodsFor: 'accessing' stamp: ''!
sourceClassName

	^ sourceClassName! !

!FLMigration methodsFor: 'initializing' stamp: ''!
initializeClassNamed: aSymbol toClass: aClass variables: anArray 
	
	self initialize.
	sourceClassName := aSymbol.
	targetClass := aClass.
	variables := anArray.! !

!FLMigration methodsFor: 'accessing' stamp: ''!
targetClass

	^ targetClass! !

!FLMigration methodsFor: 'evaluating' stamp: ''!
applyTo: aVariablesMapping 
	
	variables do: [:link |
		aVariablesMapping 
			map: link key 
			to: link value ]
	! !

!FLMigration class methodsFor: 'instance creation' stamp: ''!
fromClassNamed: aSymbol toClass: aClass variables: anArray 

	^self basicNew
		initializeClassNamed: aSymbol 
		toClass: aClass 
		variables: anArray;
		yourself.! !

!FLMigrationTest commentStamp: ''!
SUnit tests for migrations!
!FLMigrationTest methodsFor: 'tests-manual' stamp: ''!
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') equals: 7.
	self assert: (resultPoint instVarNamed: 'posY') equals: 11! !

!FLMigrationTest methodsFor: 'running' stamp: ''!
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-manual' stamp: ''!
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') equals: 7.
	self assert: (resultPoint instVarNamed: 'y') equals: 11! !

!FLMigrationTest methodsFor: 'tests-automatic' stamp: ''!
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 equals: (materializedInstance instVarNamed: 'd').
	self assert: $E equals: (materializedInstance instVarNamed: 'e').
	self should: [ materializedInstance instVarNamed: 'a' ] raise: Error.
	self should: [ materializedInstance instVarNamed: 'b' ] raise: Error.
	self assert: $C equals: (materializedInstance instVarNamed: 'c').
	self assert: (materializedInstance instVarNamed: 'x') isNil! !

!FLMigrationTest methodsFor: 'tests-automatic' stamp: ''!
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 equals: (resultPair instVarAt: 1).
	self assert: nil equals: (resultPair instVarAt: 2).
	self assert: $B equals: (resultPair instVarAt: 3)! !

!FLMigrationTest methodsFor: 'tests-manual' stamp: ''!
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: #pharoTodo "Assert an specific materialization error"! !

!FLMigrationTest methodsFor: 'tests-automatic' stamp: ''!
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 equals: (resultPair instVarAt: 1)! !

!FLMigrationTest methodsFor: 'tests-automatic' stamp: ''!
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 equals: 0! !

!FLMigrationTest methodsFor: 'tests-automatic' stamp: ''!
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 equals: (resultPair instVarAt: 1).
	self assert: $A equals: (resultPair instVarAt: 2)! !

!FLMigrationTest methodsFor: 'tests-automatic' stamp: ''!
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 equals: (materializedInstance instVarNamed: 'd').
	self assert: $E equals: (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-manual' stamp: ''!
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') equals: 7.
	self assert: (resultPoint instVarNamed: 'posY') equals: 11! !

!FLNegative16SmallIntegerCluster commentStamp: ''!
A cluster of unsigned int 16bit!
!FLNegative16SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anInteger with: anEncoder
	
	anEncoder encodeUint16: anInteger abs! !

!FLNegative16SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	
	^ aDecoder nextEncodedUint16 negated ! !

!FLNegative24SmallIntegerCluster commentStamp: ''!
A cluster of unsigned int 24bit!
!FLNegative24SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anInteger with: anEncoder
	
	anEncoder encodeUint24: anInteger abs! !

!FLNegative24SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	
	^ aDecoder nextEncodedUint24 negated ! !

!FLNegative32SmallIntegerCluster commentStamp: ''!
A cluster of unsigned int 32bit!
!FLNegative32SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anInteger with: anEncoder
	
	anEncoder encodeUint32: anInteger abs! !

!FLNegative32SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	
	^ aDecoder nextEncodedUint32 negated ! !

!FLNegative64SmallIntegerCluster commentStamp: ''!
A cluster of unsigned int 64bit!
!FLNegative64SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anInteger with: anEncoder
	
	anEncoder encodeUint64: anInteger abs! !

!FLNegative64SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	
	^ aDecoder nextEncodedUint64 negated ! !

!FLNegative8SmallIntegerCluster commentStamp: ''!
A cluster of unsigned int 8bit!
!FLNegative8SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anInteger with: anEncoder

	anEncoder encodeUint8: anInteger abs! !

!FLNegative8SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^ aDecoder nextEncodedUint8 negated! !

!FLNotSerializable commentStamp: ''!
I represent an error which may happen while tracing in the graph an object that is forbidden of being serialized.!
!FLNotSerializable class methodsFor: 'signaling' stamp: ''!
signalWith: anObject

 	self signal: 'Found a forbidden object in the graph: ', anObject printString.! !

!FLNotSerializableMock commentStamp: ''!
A test mock which is not serializable!
!FLNotSerializableMock methodsFor: 'hooks' stamp: ''!
fuelAccept: aGeneralMapper

	aGeneralMapper visitNotSerializable: self! !

!FLObjectCluster commentStamp: ''!
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: 'initialize-release' stamp: ''!
initializeAnalyzing: aClass

	self initializeAnalyzing.
	theClass := aClass! !

!FLObjectCluster methodsFor: 'printing' stamp: ''!
theClass 
	^ theClass! !

!FLObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
clusterMaterializeStepWith: aMaterialization

	super clusterMaterializeStepWith: aMaterialization.
	theClass := aMaterialization decoder nextEncodedReference.
! !

!FLObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
clusterSerializeStepWith: aSerialization

	super clusterSerializeStepWith: aSerialization.
	aSerialization encoder encodeReferenceToClusterObjectClass: theClass! !

!FLObjectCluster methodsFor: 'analyzing' stamp: ''!
clusterReferencesDo: aBlock

	aBlock value: theClass! !

!FLObjectCluster methodsFor: 'printing' stamp: ''!
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 class methodsFor: 'analyzing' stamp: ''!
clusterBucketIn: aClusterization

	^aClusterization baselevelBucket ! !

!FLObjectCluster class methodsFor: 'instance creation' stamp: ''!
newAnalyzing: aClass

	^ self basicNew
		initializeAnalyzing: aClass;
		yourself.! !

!FLObjectNotFound commentStamp: ''!
I represent an error which may happen during serialization, when trying to encode on the stream a reference to an object that should be encoded before, but it is not.

This usually happens when the graph changes during serialization. 

Another possible cause is a bug in the analysis step of serialization.!
!FLObjectNotFound class methodsFor: 'signaling' stamp: ''!
signalWith: anObject

 	self signal: (
		String streamContents: [ :stream |
			stream << 'Unexpected reference to '.
			stream print: anObject.
			stream << ' in the graph. This usually happens when the graph changes during serialization.'.
			]
	)! !

!FLObsolete commentStamp: ''!
I am an error produced during serialization, signaled when trying to serialize an obsolete class as global. It is a prevention, because such class is lekely to be absent during materialization.!
!FLObsolete class methodsFor: 'signaling' stamp: ''!
signalWithName: classOrTraitName
	^ self signal: classOrTraitName printString, ' can not be serialized as global because it is obsolete.'! !

!FLOptimizedObjectCluster commentStamp: ''!
I have shared behavior of some optional clusters.!
!FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesOf: anObject with: anEncoder
	(self references at: anObject ifAbsent: [ ^ self ]) do: [ :value |
		anEncoder encodeReferenceTo: value ]! !

!FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstancesStepWith: anEncoder
	"Do nothing. I know my objects have nothing to serialize in this step."
! !

!FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesStepWith: anEncoder

	objects do: [ :anObject | self serializeReferencesOf: anObject with: anEncoder ]! !

!FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesOf: anObject with: aDecoder
	"Hook method"

	self subclassResponsibility! !

!FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesStepWith: aDecoder

	objects do: [ :anObject | self materializeReferencesOf: anObject with: aDecoder ]! !

!FLOptimizedObjectCluster class methodsFor: 'analyzing' stamp: ''!
clusterBucketIn: aClusterization

	^aClusterization baselevelBucket ! !

!FLPair commentStamp: ''!
A test mock for pairs!
!FLPair methodsFor: 'accessing' stamp: ''!
methodWithTemp
	| string |
	string := 'test'.
	self name.
	self printString! !

!FLPair methodsFor: 'accessing' stamp: ''!
right: anObject
	right := anObject! !

!FLPair methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ self right = anObject right and: [ self left = anObject left ]! !

!FLPair methodsFor: 'accessing' stamp: ''!
left: anObject
	left := anObject! !

!FLPair methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ self right hash bitXor: self left hash! !

!FLPair methodsFor: 'accessing' stamp: ''!
right
	^ right! !

!FLPair methodsFor: 'accessing' stamp: ''!
left
	^ left! !

!FLPair methodsFor: 'accessing' stamp: ''!
method1
	self name.
	self printString.
	! !

!FLPair methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Append a sequence of characters to aStream that identify the receiver."

	super printOn: aStream.
	aStream
		nextPutAll: '(';
		print: left;
		space;
		print: right;
		nextPutAll: ')'! !

!FLPair methodsFor: 'accessing' stamp: ''!
method2
	self name.
	! !

!FLPerson commentStamp: ''!
FLPerson is a class just to be able to change the hash of an object and try to test problems with hash.!
!FLPerson methodsFor: 'comparing' stamp: ''!
= 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: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ id! !

!FLPerson methodsFor: 'accessing' stamp: ''!
id: anObject
	id := anObject! !

!FLPerson methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!FLPharo10Platform methodsFor: 'accessing-files' stamp: ''!
fileNamed: aFilename readStreamDo: aBlock
	^ ((Smalltalk at: #File) named: aFilename) readStreamDo: [ :stream |
		stream binary.
		aBlock value: stream ]! !

!FLPharo10Platform methodsFor: 'testing' stamp: ''!
isBigEndian
	^ (Smalltalk at: #EndianDetector) isBigEndian! !

!FLPharo10Platform methodsFor: 'accessing-kernel' stamp: ''!
withPragmasIn: aClass do: aBlock
	aClass pragmasDo: aBlock! !

!FLPharo10Platform methodsFor: 'accessing-compiler' stamp: ''!
addAndClassifySelector: aSymbol inClass: aClass withMethod: aCompiledMethod inProtocol: aString
	aClass
		addAndClassifySelector: aSymbol
		withMethod: aCompiledMethod
		inProtocol: aString! !

!FLPharo10Platform methodsFor: 'accessing-files' stamp: ''!
fileNamed: aFilename writeStreamDo: aBlock
	^ ((Smalltalk at: #File) named: aFilename) writeStreamDo: [ :stream |
		stream binary.
		aBlock value: stream ]! !

!FLPharo10Platform methodsFor: 'accessing-compiler' stamp: ''!
silentlyAddAndClassifySelector: aSymbol inClass: aClass withMethod: aCompiledMethod inProtocol: aString
	aClass
		addSelector: aSymbol
		withMethod: aCompiledMethod.
	aClass organization
		classify: aSymbol
		under: aString! !

!FLPharo10Platform methodsFor: 'accessing-files' stamp: ''!
deleteFileNamed: aFilename
	((Smalltalk at: #File) named: aFilename) delete! !

!FLPharo10Platform class methodsFor: 'operations' stamp: ''!
addHacks
	"no hacks for development platform"! !

!FLPharo10Platform class methodsFor: 'testing' stamp: ''!
isResponsibleForCurrentPlatform
	^ super isResponsibleForCurrentPlatform and: [
		(SystemVersion current type = 'Pharo')
			and: [ SystemVersion current major = 10 ] ]! !

!FLPharo9Platform methodsFor: 'accessing-files' stamp: ''!
fileNamed: aFilename readStreamDo: aBlock
	^ ((Smalltalk at: #File) named: aFilename) readStreamDo: [ :stream |
		stream binary.
		aBlock value: stream ]! !

!FLPharo9Platform methodsFor: 'testing' stamp: ''!
isBigEndian
	^ (Smalltalk at: #EndianDetector) isBigEndian! !

!FLPharo9Platform methodsFor: 'accessing-kernel' stamp: ''!
withPragmasIn: aClass do: aBlock
	aClass pragmasDo: aBlock! !

!FLPharo9Platform methodsFor: 'accessing-compiler' stamp: ''!
addAndClassifySelector: aSymbol inClass: aClass withMethod: aCompiledMethod inProtocol: aString
	aClass
		addAndClassifySelector: aSymbol
		withMethod: aCompiledMethod
		inProtocol: aString! !

!FLPharo9Platform methodsFor: 'accessing-files' stamp: ''!
fileNamed: aFilename writeStreamDo: aBlock
	^ ((Smalltalk at: #File) named: aFilename) writeStreamDo: [ :stream |
		stream binary.
		aBlock value: stream ]! !

!FLPharo9Platform methodsFor: 'accessing-compiler' stamp: ''!
silentlyAddAndClassifySelector: aSymbol inClass: aClass withMethod: aCompiledMethod inProtocol: aString
	aClass
		addSelector: aSymbol
		withMethod: aCompiledMethod.
	aClass organization
		classify: aSymbol
		under: aString! !

!FLPharo9Platform methodsFor: 'accessing-files' stamp: ''!
deleteFileNamed: aFilename
	((Smalltalk at: #File) named: aFilename) delete! !

!FLPharo9Platform class methodsFor: 'operations' stamp: ''!
addHacks
	"no hacks for development platform"! !

!FLPharo9Platform class methodsFor: 'testing' stamp: ''!
isResponsibleForCurrentPlatform
	^ super isResponsibleForCurrentPlatform and: [
		(SystemVersion current type = 'Pharo')
			and: [ SystemVersion current major = 9 ] ]! !

!FLPharoPlatform methodsFor: 'accessing - system' stamp: ''!
imageName
	^ Smalltalk image shortImageName! !

!FLPharoPlatform methodsFor: 'accessing - system' stamp: ''!
absolutePathOf: aString
	^ aString asFileReference fullName! !

!FLPharoPlatform methodsFor: 'accessing - tests' stamp: ''!
setTestTimeLimitFor: aTest to: aDuration
	aTest timeLimit: aDuration! !

!FLPharoPlatform methodsFor: 'accessing - system' stamp: ''!
useAuthor: aString during: aBlock
	(Smalltalk at: #Author)
		useAuthor: aString
		during: aBlock! !

!FLPharoPlatform methodsFor: 'testing' stamp: ''!
isPharo
	^ true! !

!FLPharoPlatform methodsFor: 'accessing - compiler' stamp: ''!
addAndClassifySelector: aSymbol inClass: aClass withMethod: aCompiledMethod inProtocol: aString

	aClass addAndClassifySelector: aSymbol withMethod: aCompiledMethod inProtocol: aString! !

!FLPharoPlatform methodsFor: 'accessing - compiler' stamp: ''!
renamedMethodCopyOf: aMethod selector: aSymbol
	| newMethod |
	newMethod := aMethod ast
		selector: aSymbol
		yourself.
	"#compiledMethod answers a new instance"
	^ newMethod compiledMethod! !

!FLPharoPlatform methodsFor: 'testing' stamp: ''!
isSpur
	^ true! !

!FLPharoPlatform class methodsFor: 'testing' stamp: ''!
isResponsibleForCurrentPlatform
	^ SystemVersion current version beginsWith: 'Pharo'! !

!FLPharoPlatform class methodsFor: 'private-extensions-znbufferedreadstream' stamp: ''!
fuelNextWordsInto: aWordObject
	<flExtensionOf: #ZnBufferedReadStream>
	"This method is the same as nextWordsInto: but the restoreEndianness is only done if needed"
	| byteSize source pos blt |
	byteSize := aWordObject byteSize.
	source := self next: byteSize.
	pos := 0.

	"Now use BitBlt to copy the bytes to the bitmap."
	blt := (BitBlt
				toForm: (Form new hackBits: aWordObject))
				sourceForm: (Form new hackBits: source).
	blt combinationRule: Form over. "store"
	blt sourceX: 0;
		 sourceY: pos // 4;
		 height: byteSize // 4;
		 width: 4.
	blt destX: 0;
		 destY: 0.
	blt copyBits.
	
	^ aWordObject! !

!FLPlatform methodsFor: 'accessing - compiler' stamp: ''!
silentlyAddAndClassifySelector: aSymbol inClass: aClass withMethod: aCompiledMethod inProtocol: aString
	self subclassResponsibility! !

!FLPlatform methodsFor: 'accessing - files' stamp: ''!
deleteFileNamed: aFilename
	self subclassResponsibility! !

!FLPlatform methodsFor: 'accessing - system' stamp: ''!
imageName
	^ self subclassResponsibility! !

!FLPlatform methodsFor: 'accessing' stamp: ''!
versionNumber
	^ ('\d+' asRegex matchesIn: self className) first asInteger! !

!FLPlatform methodsFor: 'accessing - files' stamp: ''!
fileNamed: aFilename readStreamDo: aBlock
	^ self subclassResponsibility! !

!FLPlatform methodsFor: 'testing' stamp: ''!
isBigEndian
	^ self subclassResponsibility! !

!FLPlatform methodsFor: 'testing' stamp: ''!
isSqueak
	^ false! !

!FLPlatform methodsFor: 'accessing - system' stamp: ''!
absolutePathOf: aString
	^ self subclassResponsibility! !

!FLPlatform methodsFor: 'accessing - tests' stamp: ''!
classFactoryForTestCaseClass
	^ ClassFactoryForTestCase! !

!FLPlatform methodsFor: 'accessing - tests' stamp: ''!
setTestTimeLimitFor: aTest to: aDuration
	self subclassResponsibility! !

!FLPlatform methodsFor: 'accessing - kernel' stamp: ''!
withPragmasIn: aClass do: aBlock
	self subclassResponsibility! !

!FLPlatform methodsFor: 'operations' stamp: ''!
addHacks
	self class addHacks! !

!FLPlatform methodsFor: 'accessing - system' stamp: ''!
useAuthor: aString during: aBlock
	self subclassResponsibility! !

!FLPlatform methodsFor: 'testing' stamp: ''!
isPharo
	^ false! !

!FLPlatform methodsFor: 'accessing - compiler' stamp: ''!
addAndClassifySelector: aSymbol inClass: aClass withMethod: aCompiledMethod inProtocol: aString
	self subclassResponsibility! !

!FLPlatform methodsFor: 'accessing - files' stamp: ''!
fileNamed: aFilename writeStreamDo: aBlock
	^ self subclassResponsibility! !

!FLPlatform methodsFor: 'accessing - compiler' stamp: ''!
renamedMethodCopyOf: aMethod selector: aSymbol
	^ self subclassResponsibility! !

!FLPlatform methodsFor: 'testing' stamp: ''!
isSpur
	^ true! !

!FLPlatform class methodsFor: 'private' stamp: ''!
detectPlatform
	| matches mostSpecific |
	matches := self allSubclasses 
		select: [ :class | class isResponsibleForCurrentPlatform ].
	mostSpecific := matches first.
	matches do: [ :class |
		class allSubclasses size < mostSpecific allSubclasses size ifTrue: [
			mostSpecific := class ] ].
	
	^ mostSpecific new! !

!FLPlatform class methodsFor: 'accessing' stamp: ''!
current
	^ Current ifNil: [ Current := self detectPlatform ]! !

!FLPlatform class methodsFor: 'accessing' stamp: ''!
extensionCategoryName
	^ 'FuelPlatformExtensions'! !

!FLPlatform class methodsFor: 'private - extensions' stamp: ''!
addExtensions
	self extensionPragmas do: [ :pragma |
		(FLExtensionWrapper fromPragma: pragma) install ]! !

!FLPlatform class methodsFor: 'accessing' stamp: ''!
extensionProtocolName
	^ '*', self extensionCategoryName! !

!FLPlatform class methodsFor: 'operations' stamp: ''!
addHacks
	self current
		useAuthor: 'Fuel'
		during: [ self basicAddHacks ]! !

!FLPlatform class methodsFor: 'private - hacks-metacello' stamp: ''!
fixMetacello! !

!FLPlatform class methodsFor: 'private - convenience' stamp: ''!
removeModifications
	((Smalltalk globals at: #(Smalltalk globals at: #PackageInfo)) named: self extensionProtocolName) extensionMethods do: [ :methodReference |
		methodReference actualClass removeSelector: methodReference selector ].
	((Smalltalk globals at: #(Smalltalk globals at: #PackageInfo)) named: self hacksCategoryName) in: [ :hacks |
		hacks classes do: [ :classOrTrait |
			classOrTrait removeFromSystem ].
		(Smalltalk globals at: #PackageOrganizer) default  unregisterPackage: hacks ].
	SystemOrganizer default removeCategory: self hacksCategoryName! !

!FLPlatform class methodsFor: 'testing' stamp: ''!
isResponsibleForCurrentPlatform
	^ self subclassResponsibility! !

!FLPlatform class methodsFor: 'private - hacks' stamp: ''!
basicAddHacks
	self
		fixMetacello;
		addExtensions! !

!FLPlatform class methodsFor: 'private - extensions' stamp: ''!
extensionPragmas
	| pragmas |
	pragmas := Dictionary new.
	#(
		flExtensionOf:
		flExtensionOf:selector:
		flExtensionOf:selector:isSource:
		flExtensionOf:isSource:) do: [ :selector |
			| stop |
			stop := false.
			self class withAllSuperclassesDo: [ :class |
				stop ifFalse: [
					self current
						withPragmasIn: class
						do: [ :pragma |
							(pragma selector = selector and: [
								"don't collect overridden methods"
								(pragmas includesKey: pragma methodSelector) not ]) ifTrue: [
									pragmas
										at: pragma methodSelector
										put: pragma ] ].
							FLPlatform class = class ifTrue: [ stop := true ] ] ] ].
			
	^ pragmas values! !

!FLPlatform class methodsFor: 'initialization' stamp: ''!
reset
	Current := nil! !

!FLPlatform class methodsFor: 'accessing' stamp: ''!
hacksCategoryName
	^ 'FuelPlatformHacks'! !

!FLPluggableSubstitutionMapper commentStamp: ''!
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: ''!
initializeWith: aCondition substitutionFactory: aBlock

	self initialize.
	condition := aCondition.
	substitutionFactory := aBlock.! !

!FLPluggableSubstitutionMapper methodsFor: 'mapping' stamp: ''!
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: ''!
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 methodsFor: 'instance creation' stamp: ''!
when: aCondition substituteBy: aFactory

	^self basicNew
		initializeWith: aCondition 
		substitutionFactory: aFactory;
		yourself! !

!FLPluggableSubstitutionTest commentStamp: ''!
SUnit tests for fuels pluggable substitutions!
!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
testPrivateExcluded
	| result |
	self analyzer when: [ :x | x isBehavior ] substituteBy: [ :x | FLWeakClassMock ].

	result := self resultOfSerializeAndMaterialize: {String new . FLPair}.

	self assert: result first class identicalTo: ByteString.
	self assert: result second identicalTo: FLWeakClassMock! !

!FLPluggableSubstitutionTest methodsFor: 'running' stamp: ''!
testSubstitute: anObject inPresenceOf: anotherObject

	| result |
	self analyzer when: [:x | x == anObject ] substituteBy: [:x | 424242 ].

	result := self resultOfSerializeAndMaterialize: {anObject. anotherObject}.
	
	self assert: result first equals: 424242.
	self assert: result second equals: anotherObject.
! !

!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
testAvoidRecursion
	| result |
	self analyzer when: [ :x | x < 10 ] substituteBy: [ :x | x + 1 ].

	result := self resultOfSerializeAndMaterialize: 1.

	self assert: result equals: 2! !

!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
testSubstituteByItself
	| result |
	self analyzer when: [ :x | true ] substituteBy: [ :x | x ].

	result := self resultOfSerializeAndMaterialize: 1.

	self assert: result equals: 1! !

!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
testSubstituteCharacterInPresenceOfSomeCharacter
	"See issues #209 and #217"

	self testSubstitute: Character inPresenceOf: $c
! !

!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
testSubstituteUndefinedObjectInPresenceOfNil
	"See issues #209 and #217"

	self testSubstitute: UndefinedObject inPresenceOf: nil
! !

!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
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: ''!
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 identicalTo: 1 printString.

	result := self resultOfSerializeAndMaterialize: (Array with: 1 with: 1).

	self assert: result first equals: '1'.
	self assert: result first identicalTo: result second! !

!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
testPrivateExcludedAndWithConflicts
	"Tests issue #209"

	| result |
	self analyzer when: [ :x | FLPair == x ] substituteBy: [ :x | FLWeakClassMock ].

	result := self resultOfSerializeAndMaterialize: {FLPair new . FLPair}.

	self assert: result first class identicalTo: FLPair.
	self assert: result second identicalTo: FLWeakClassMock! !

!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
testSimple
	| result |
	self analyzer when: [ :x | x < 0 ] substituteBy: [ :x | 0 ].

	result := self resultOfSerializeAndMaterialize: -1.

	self assert: result equals: 0! !

!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
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) equals: result! !

!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
testSubstituteTrueInPresenceOfTheTrueInstance
	"See issues #209 and #217"

	self testSubstitute: True inPresenceOf: true
! !

!FLPluggableSubstitutionTest methodsFor: 'tests' stamp: ''!
testTransientPair

	| result |
	self analyzer when: [:x | FLPair = x class] substituteBy: [:x | nil].

	result := self resultOfSerializeAndMaterialize: FLPair new.
	
	self assert: result isNil.! !

!FLPointCluster commentStamp: ''!
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: ''!
referencesOf: aPoint do: aBlock

	aBlock value: aPoint x.
	aBlock value: aPoint y.
	! !

!FLPointCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesOf: aPoint with: aDecoder

		aPoint setX: aDecoder nextEncodedReference setY: aDecoder nextEncodedReference.	
! !

!FLPointCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	"Since in Pharo #@ is associated with a special bytecode, it is faster than doing  Point basicNew"
	^ 0@0 
	! !

!FLPointerObjectCluster commentStamp: ''!
I have the common behavior for storing and loading pointer objects.!
!FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesOf: anObject with: anEncoder
	
	variablesMapping serializeReferencesOf: anObject with: anEncoder
! !

!FLPointerObjectCluster methodsFor: 'analyzing' stamp: ''!
referencesOf: anObject do: aBlock

	variablesMapping referencesOf: anObject do: aBlock! !

!FLPointerObjectCluster methodsFor: 'initialize-release' stamp: ''!
initializeAnalyzing: aClass

	super initializeAnalyzing: aClass.
	variablesMapping := FLVariablesMapping 
		newAnalyzing: theClass
		references: self references! !

!FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesStepWith: anEncoder

	objects do: [ :anObject | self serializeReferencesOf: anObject with: anEncoder ]! !

!FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
clusterMaterializeStepWith: aMaterialization

	super clusterMaterializeStepWith: aMaterialization.
	variablesMapping := aMaterialization decoder variablesMappingFor: theClass.! !

!FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesOf: anObject with: aDecoder

	variablesMapping materializeReferencesOf: anObject with: aDecoder! !

!FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
clusterSerializeStepWith: aSerialization

	super clusterSerializeStepWith: aSerialization.
	variablesMapping serializeOn: aSerialization encoder.! !

!FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesStepWith: aDecoder

	objects do: [ :anObject | self materializeReferencesOf: anObject with: aDecoder ]! !

!FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
afterMaterializationStepWith: aDecoder  

	objects do: [ :anObject | anObject fuelAfterMaterialization ]! !

!FLPositive16SmallIntegerCluster commentStamp: ''!
unsigned, 16-bit integer cluster!
!FLPositive16SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anInteger with: anEncoder
	
	anEncoder encodeUint16: anInteger! !

!FLPositive16SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	
	^ aDecoder nextEncodedUint16 ! !

!FLPositive24SmallIntegerCluster commentStamp: ''!
unsigned, 24-bit integer!
!FLPositive24SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anInteger with: anEncoder
	
	anEncoder encodeUint24: anInteger! !

!FLPositive24SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	
	^ aDecoder nextEncodedUint24 ! !

!FLPositive32SmallIntegerCluster commentStamp: ''!
unsigned, 32-bit integer!
!FLPositive32SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anInteger with: anEncoder

	anEncoder encodeUint32: anInteger! !

!FLPositive32SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^ aDecoder nextEncodedUint32! !

!FLPositive64SmallIntegerCluster commentStamp: ''!
unsigned, 64-bit integer!
!FLPositive64SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anInteger with: anEncoder

	anEncoder encodeUint64: anInteger! !

!FLPositive64SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^ aDecoder nextEncodedUint64! !

!FLPositive8SmallIntegerCluster commentStamp: ''!
unsigned, 8-bit integer!
!FLPositive8SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anInteger with: anEncoder

	anEncoder encodeUint8: anInteger! !

!FLPositive8SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^ aDecoder nextEncodedUint8! !

!FLPrimitiveCluster commentStamp: ''!
I am a cluster that serializes and materializes interacting directly with the stream.!
!FLPrimitiveCluster methodsFor: 'serialize/materialize' stamp: ''!
registerIndexesOn: anEncoder

	self flag: #pharoTodo. "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: anEncoder! !

!FLPrimitiveCluster methodsFor: 'analyzing' stamp: ''!
newAnalyzingCollection
	"Answer a collection for the objects that correspond to this cluster."

	^OrderedCollection new! !

!FLPrimitiveCluster methodsFor: 'analyzing' stamp: ''!
add: anObject traceWith: anAnalysis
	"Add an object to the cluster. We know the object doesn't have references."

	objects addLast: anObject! !

!FLPrimitiveCluster class methodsFor: 'analyzing' stamp: ''!
clusterBucketIn: aClusterization

	^aClusterization primitivesBucket ! !

!FLProcessBasicSerializationTest methodsFor: 'tests' stamp: ''!
testSerializingShortDelay
	| process |
	process := [ 2 timesRepeat: [ | d |
		d := Delay forMilliseconds: 50.
		d wait ] ] forkAt: Processor userBackgroundPriority.
	
	self 
		shouldnt: [ self serialize: process ]
		raise: FLObjectNotFound! !

!FLProcessBasicSerializationTest methodsFor: 'running' stamp: ''!
setUpSerializer
	^ serializer := FLDelayedSerializerMock newDefault! !

!FLProcessBasicSerializationTest class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit
	^ 1 minute! !

!FLProxyThatBecomesItsContent commentStamp: ''!
Used at #testObjectByProxyThatBecomesItsContent!
!FLProxyThatBecomesItsContent methodsFor: 'serialization' stamp: ''!
fuelAfterMaterialization 

	self become: contents! !

!FLProxyThatBecomesItsContent methodsFor: 'initialization' stamp: ''!
initializeWith: anObject
	
	super initialize.
	contents := anObject! !

!FLProxyThatBecomesItsContent class methodsFor: 'instance creation' stamp: ''!
newWith: aByteSymbol 
	
	^self basicNew
		initializeWith: aByteSymbol;
		yourself! !

!FLRectangleCluster commentStamp: ''!
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: ''!
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: ''!
materializeReferencesOf: aRectangle with: aDecoder
		
		aRectangle 
			fuelSetOrigin: aDecoder nextEncodedReference @ aDecoder nextEncodedReference	
		 	corner: aDecoder nextEncodedReference @ aDecoder nextEncodedReference! !

!FLRectangleCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder
	"Since in Pharo #@ is associated with a special bytecode, it is faster than doing  Point basicNew"
	^ Rectangle basicNew! !

!FLReplacementClassMock class methodsFor: 'accessing' stamp: ''!
fuelReplacement
	^ nil! !

!FLReplacementMock methodsFor: 'comparing' stamp: ''!
= anObject
	^ self class = anObject class! !

!FLReplacementMock methodsFor: 'accessing' stamp: ''!
fuelReplacement
	^ ignoreMe
		ifTrue: [ nil ]
		ifFalse: [ self ]! !

!FLReplacementMock methodsFor: 'accessing' stamp: ''!
ignoreMe
	^ ignoreMe := true! !

!FLReplacementMock methodsFor: 'accessing' stamp: ''!
dontIgnoreMe
	ignoreMe := false! !

!FLSerialization commentStamp: ''!
I implement the algorithm for serializing an object graph on a stream. FLSerializer known how to build instances of me.!
!FLSerialization methodsFor: 'initialize-release' stamp: ''!
initializeWith: anEncoder root: anObject analyzer: anAnalyzer
			
	self initialize.
	encoder := anEncoder.
	root := anObject fuelReplacement.
	analyzer := anAnalyzer.! !

!FLSerialization methodsFor: 'private' stamp: ''!
clusterInstancesStepOf: aCluster

	encoder encodeClusterClass: aCluster class.
	aCluster clusterSerializeStepWith: self.
	aCluster serializeInstancesStepWith: encoder.
	aCluster serializePostInstancesStepWith: encoder.
! !

!FLSerialization methodsFor: 'private' stamp: ''!
referencesStep

	clusters do: [ :aCluster | aCluster serializeReferencesStepWith: encoder ]! !

!FLSerialization methodsFor: 'private' stamp: ''!
headerStep
	encoder
		encodeYourself;
		encodeUint32: clusters size! !

!FLSerialization methodsFor: 'hooks' stamp: ''!
fuelAccept: aGeneralMapper
	^ aGeneralMapper visitSubstitution: self by: nil! !

!FLSerialization methodsFor: 'accessing' stamp: ''!
encoder
	^ encoder! !

!FLSerialization methodsFor: 'accessing' stamp: ''!
clusters
	^ clusters! !

!FLSerialization methodsFor: 'private' stamp: ''!
prepareObjectsStep
	clusters do: [ :aCluster |
		aCluster prepareObjectsStep ]! !

!FLSerialization methodsFor: 'accessing' stamp: ''!
root
	^ root! !

!FLSerialization methodsFor: 'private' stamp: ''!
instancesStep

	clusters do: [ :aCluster | aCluster registerIndexesOn: encoder ].
	clusters do: [ :aCluster | self clusterInstancesStepOf: aCluster ]! !

!FLSerialization methodsFor: 'accessing' stamp: ''!
objects
	"Answer a collection with the serialized objects."

	^ encoder objectsIndexes keys! !

!FLSerialization methodsFor: 'debugging' stamp: ''!
clustersSortedByAmountOfObjects
	^ self clusters sorted: [ :a :b | a objects size > b objects size ]! !

!FLSerialization methodsFor: 'serializing' stamp: ''!
run
	"Serialize the graph starting at the root object."

	self
		analysisStep;
		prepareObjectsStep;
		headerStep;
		instancesStep;
		referencesStep;
		trailerStep! !

!FLSerialization methodsFor: 'private' stamp: ''!
trailerStep

	encoder encodeReferenceTo: root! !

!FLSerialization methodsFor: 'private' stamp: ''!
analysisStep

	| anAnalysis |
	anAnalysis := analyzer analysisFor: root.
	clusters := anAnalysis clusterization clusters.
	encoder objectCount: anAnalysis clusterization objectCount
! !

!FLSerialization class methodsFor: 'instance creation' stamp: ''!
with: anEncoder root: anObject analyzer: anAnalyzer
	
	^ self basicNew
		initializeWith: anEncoder
		root: anObject
		analyzer: anAnalyzer;
		yourself! !

!FLSerializationError commentStamp: ''!
I represent an error happened during serialization.!
!FLSerializationError class methodsFor: 'exceptioninstantiator' stamp: ''!
signal: signalerText

	^ super signal: 'Serialization error. ', signalerText
	! !

!FLSerializationTest commentStamp: ''!
Superclass for serialization tests!
!FLSerializationTest methodsFor: 'stream-strategies' stamp: ''!
useFileReferenceStream

	streamFactory := FLFileReferenceStreamStrategy new! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
resultOfSerializeAndMaterializeMethodDictionary: aMethodDictionary
	| materialized |
	materialized := self resultOfSerializeAndMaterialize: aMethodDictionary.
	self assert: (materialized isEqualRegardlessMethodsTrailerTo: aMethodDictionary)! !

!FLSerializationTest methodsFor: 'accessing' stamp: ''!
classFactory
	^classFactory! !

!FLSerializationTest methodsFor: 'class-factory' stamp: ''!
newSubclassOf: aClass  instanceVariableNames: ivNamesString classVariableNames: classVarsString
	^ self classFactory silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames:  classVarsString! !

!FLSerializationTest methodsFor: 'stream-strategies' stamp: ''!
useBinaryFileStream

	streamFactory := FLBinaryFileStreamStrategy new! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
resultOfSerializeAndMaterialize: anObject

	self serialize: anObject.
	^ self materialized
! !

!FLSerializationTest methodsFor: 'accessing' stamp: ''!
serializer
	^serializer! !

!FLSerializationTest methodsFor: 'class-factory' stamp: ''!
newClass
	^ self newSubclassOf: Object 
		instanceVariableNames: '' 
		classVariableNames: ''
! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
resultOfSerializeAndMaterializeMethod: aCompiledMethod
	self analyzer considerInternalMethod: aCompiledMethod. 
	self serialize: aCompiledMethod.
	^ self materialized
! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
serializationOf: anObject 
	self streamFactory writeStreamDo: [:aStream |
	^ serializer serialize: anObject on: aStream. ].
! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
resultOfSerializeAndMaterializeCompiledMethod: aCompiledMethod
	| materialized |
	materialized := self resultOfSerializeAndMaterialize: aCompiledMethod.
	self assert: (materialized isEqualRegardlessTrailerTo: aCompiledMethod)! !

!FLSerializationTest methodsFor: 'class-factory' stamp: ''!
newClassInCategory: aCategory
	^ self classFactory silentlyNewClassInCategory: aCategory! !

!FLSerializationTest methodsFor: 'traits-factory' stamp: ''!
registerBehavior: aBehavior
	aBehavior isTrait
		ifTrue: [ self classFactory createdTraits add: aBehavior ]
		ifFalse: [ self classFactory createdClasses add: aBehavior ]! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
setUpMaterializer
	materializer := FLMaterializer newDefault! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
setUpClassFactory
	classFactory := FLPlatform current classFactoryForTestCaseClass new
! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
materializedObjects
	
	^ self materialization objects! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
setUpSerializer
	serializer := FLSerializer newDefault! !

!FLSerializationTest methodsFor: 'cleaning' stamp: ''!
removeFromSystem: aClassOrTrait
	aClassOrTrait removeFromSystem: false! !

!FLSerializationTest methodsFor: 'cleaning' stamp: ''!
deleteFileNamed: aFilename
	 FLPlatform current deleteFileNamed: aFilename! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self setUpClassFactory.
	self setUpSerializer.
	self setUpMaterializer.
	"You have several stream strategies available on 'stream-strategies' category."
	self useFileReferenceStream.

	"When rerunning tests from the test runner #initialize
	will not be sent to the instance but the previous run will
	have torn down the variable"
	testingEnvironment ifNil: [ 
		testingEnvironment := Smalltalk globals ]! !

!FLSerializationTest methodsFor: 'accessing' stamp: ''!
analyzer
	^serializer analyzer! !

!FLSerializationTest methodsFor: 'accessing' stamp: ''!
streamFactory
	^streamFactory! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
serialize: anObject

	self streamFactory writeStreamDo: [:aStream |
		self serializer serialize: anObject on: aStream ]! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
tearDown
	self
		tearDownClassFactory;
		tearDownGlobalVariables.
	self streamFactory tearDown.
	
	super tearDown! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
tearDownGlobalVariables
	testingEnvironment
		removeKey: #FLGlobalVariableForTesting
		ifAbsent: []! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
materialization
	
	self streamFactory readStreamDo: [:aStream |
		^ self materializer materializeFrom: aStream ]! !

!FLSerializationTest methodsFor: 'class-factory' stamp: ''!
withNotificationsNewClassWithInstanceVariableNames: instanceVariableNames
	"Returns a class for testing, with the specified instance variables."

	^ classFactory withNotificationsNewClassWithInstanceVariableNames: instanceVariableNames! !

!FLSerializationTest methodsFor: 'class-factory' stamp: ''!
withNotificationsNewClass
	^ self classFactory withNotificationsNewClass! !

!FLSerializationTest methodsFor: 'stream-strategies' stamp: ''!
useByteArrayStream 
	"This is a special factory to test what we offer with FLSerializer class >> #serializeInMemory:  and  FLMaterializer class >> #materializeFromByteArray: "
	streamFactory := FLByteArrayStreamStrategy new! !

!FLSerializationTest methodsFor: 'class-factory' stamp: ''!
newSubclassNamed: nameString of: aClass  instanceVariableNames: ivNamesString classVariableNames: classVarsString
	| class |
	SystemAnnouncer uniqueInstance suspendAllWhile: [
		class := self class classInstaller make: [ :aBuilder | 
			aBuilder 
				name: nameString;
				superclass: aClass;
				slots: ivNamesString asSlotCollection;
				sharedVariablesFromString: classVarsString ] ].
	self classFactory createdClasses add: class.
	^ class! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
serializationOf: anObject includes: anotherObject 
	| serialization |
	self streamFactory writeStreamDo: [:aStream |
	serialization := serializer serialize: anObject on: aStream.
	^ serialization objects includes: anotherObject ].! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
assertSerializationEqualityOf: anObject
	"Asserts that the original object and the materialized one are equal (but not the same)"

	| materialized |
	materialized := self resultOfSerializeAndMaterialize: anObject.
	self assert: anObject ~~ materialized description: 'The materialized object should not be the same as the serialized one'.
	self assert: anObject = materialized description: 'The materialized object should be equal to serialized one'.! !

!FLSerializationTest methodsFor: 'accessing' stamp: ''!
materializer
	^materializer! !

!FLSerializationTest methodsFor: 'stream-strategies' stamp: ''!
useGzipInMemoryStream

	streamFactory := FLGZipStrategy newWithTarget: FLByteArrayStreamStrategy new! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
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: ''!
tearDownClassFactory
	self classFactory cleanUp! !

!FLSerializationTest methodsFor: 'traits-factory' stamp: ''!
newTraitSuffixed: suffix
	^ self classFactory
		newTraitNamed: (self traitNamePrefix, suffix) asSymbol
		uses: Array new 
		tag: (self classFactory packageName, '-', self classFactory defaultTagPostfix) asSymbol! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
assertSerializationEqualityOrIdentityOf: anObject
	"Asserts that the original object and the materialized one are equal (may be the same)"

	| materialized |
	materialized := self resultOfSerializeAndMaterialize: anObject.
	self assert: anObject = materialized description: 'The materialized object should be equal to serialized one'.! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
materializationHeader
	
	self streamFactory readStreamDo: [:aStream |
		^ self materializer materializeHeaderFrom: aStream ]! !

!FLSerializationTest methodsFor: 'running' stamp: ''!
materialized
	
	^ self materialization root! !

!FLSerializationTest methodsFor: 'traits-factory' stamp: ''!
traitNamePrefix
	^'FLTraitForTesting'! !

!FLSerializationTest class methodsFor: 'accessing' stamp: ''!
packageNamesUnderTest
	^ #('Fuel')! !

!FLSerializer commentStamp: ''!
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: ''!
analyzer
	^ analyzer ifNil: [ analyzer := self defaultAnalyzer ]! !

!FLSerializer methodsFor: 'serializing' stamp: ''!
serialize: anObject
	"Serialize the graph starting at the root object received and answers the FLSerialization object"

	^ self serialize: anObject on: stream! !

!FLSerializer methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self signature: self class defaultSignature.
	self version: self class currentVersion.
	header := FLHeader new.! !

!FLSerializer methodsFor: 'protected' stamp: ''!
serializationFactory

	^ serializationFactory ifNil: [ 
		self setDefaultSerialization.
		serializationFactory ].! !

!FLSerializer methodsFor: 'accessing' stamp: ''!
header
	^ header! !

!FLSerializer methodsFor: 'header' stamp: ''!
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: 'protected' stamp: ''!
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: 'accessing' stamp: ''!
signature: anObject
	signature := anObject! !

!FLSerializer methodsFor: 'protected' stamp: ''!
encodeSignatureWith: anEncoder
	anEncoder encodeBytes: self signature asByteArray! !

!FLSerializer methodsFor: 'hooks' stamp: ''!
fuelAccept: aGeneralMapper
	^ aGeneralMapper visitSubstitution: self by: nil! !

!FLSerializer methodsFor: 'accessing' stamp: ''!
version: anObject
	version := anObject! !

!FLSerializer methodsFor: 'header' stamp: ''!
addPostMaterializationAction: aCleanBlockClosure
	header addPostMaterializationAction: aCleanBlockClosure! !

!FLSerializer methodsFor: 'accessing' stamp: ''!
stream: aStream
	stream := aStream! !

!FLSerializer methodsFor: 'accessing' stamp: ''!
signature
	^ signature! !

!FLSerializer methodsFor: 'header' stamp: ''!
addPreMaterializationAction: aCleanBlockClosure
	header addPreMaterializationAction: aCleanBlockClosure! !

!FLSerializer methodsFor: 'accessing' stamp: ''!
analyzer: anObject
	analyzer := anObject! !

!FLSerializer methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!FLSerializer methodsFor: 'serializing' stamp: ''!
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: 'protected' stamp: ''!
defaultAnalyzer

	^FLAnalyzer newDefault! !

!FLSerializer methodsFor: 'serializing' stamp: ''!
serialize: anObject toFileNamed: aFilename
	"Serialize the graph starting at the root object received and answers the FLSerialization object"
	FLPlatform current
		fileNamed: aFilename 
		writeStreamDo: [ :aFileStream |
			self serialize: anObject on: aFileStream ]
	! !

!FLSerializer methodsFor: 'protected' stamp: ''!
encodeVersionWith: anEncoder
	anEncoder encodeUint16: self version
! !

!FLSerializer methodsFor: 'protected' stamp: ''!
setDefaultSerialization

	^ serializationFactory := [:anObject :anEncoder | 
		(FLSerialization 
			with: anEncoder
			root: anObject 
			analyzer: self analyzer)
			run;
			yourself ]! !

!FLSerializer class methodsFor: 'instance creation' stamp: ''!
newLight

	^self new! !

!FLSerializer class methodsFor: 'instance creation' stamp: ''!
newDefault

	^self newLight! !

!FLSerializer class methodsFor: 'instance creation' stamp: ''!
on: aStream
	^ self newLight 
		stream: aStream;
		yourself! !

!FLSerializer class methodsFor: 'serializing-shortcuts' stamp: ''!
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! !

!FLSerializer class methodsFor: 'protected' stamp: ''!
defaultSignature
	^ 'FUEL'! !

!FLSerializer class methodsFor: 'serializing-shortcuts' stamp: ''!
serialize: anObject on: aStream

	self newDefault serialize: anObject on: aStream! !

!FLSerializer class methodsFor: 'serializing-shortcuts' stamp: ''!
serialize: anObject toFileNamed: aFilename

	self newDefault serialize: anObject toFileNamed: aFilename! !

!FLSerializer class methodsFor: 'protected' stamp: ''!
currentVersion
	^ 303! !

!FLSignatureTest commentStamp: ''!
SUnit tests for fuel serializations, here signatures!
!FLSignatureTest methodsFor: 'tests' stamp: ''!
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: ''!
testSameSignature

	serializer signature: 'FUELx'.
	materializer signature: 'FUELx'.
	self assertSerializationEqualityOf: 'content'! !

!FLSimpleCollectionCluster commentStamp: ''!
A FLSimpleCollectionCluster is a special optional cluster that rather than using the default (variable object) serialization, uses #do: to iterate objects and #add: during materialization. So far we use it for Set, IdentitySet and OrderedCollection.!
!FLSimpleCollectionCluster methodsFor: 'analyzing' stamp: ''!
referencesOf: anObject do: aBlock
	aBlock value: anObject size.
	anObject
		do: [ :each | aBlock value: each ]
! !

!FLSimpleCollectionCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesOf: anObject with: aDecoder
	aDecoder nextEncodedUint32 timesRepeat: [
		anObject add: aDecoder nextEncodedReference ]! !

!FLSimpleStack commentStamp: ''!
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: ''!
isEmpty

	^ 1 = slotIndex! !

!FLSimpleStack methodsFor: 'printing' stamp: ''!
printOn: aStream 
	"Append a sequence of characters that identify the receiver to aStream."

	super printOn: aStream.
	array printElementsOn: aStream
! !

!FLSimpleStack methodsFor: 'adding' stamp: ''!
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: 'accessing' stamp: ''!
capacity

	^ array size! !

!FLSimpleStack methodsFor: 'removing' stamp: ''!
pop
	"Returns the first element and remove it from the stack."

	slotIndex := slotIndex - 1.	
	^ array at: slotIndex ! !

!FLSimpleStack methodsFor: 'adding' stamp: ''!
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: 'initialize-release' stamp: ''!
initialize: hintSize

	array := Array new: hintSize.
	slotIndex := 1.! !

!FLSimpleStack class methodsFor: 'instance creation' stamp: ''!
new
	
	^ self new: self hintSize! !

!FLSimpleStack class methodsFor: 'instance creation' stamp: ''!
new: nElements
	"Create a Set large enough to hold nElements without growing"
	^ self basicNew initialize: nElements! !

!FLSimpleStack class methodsFor: 'instance creation' stamp: ''!
hintSize

	^64! !

!FLSimpleStackTest methodsFor: 'testing' stamp: ''!
testPop
	| stack |
	stack := FLSimpleStack new.
	stack push: 1.
	stack pop.
	self assert: stack isEmpty! !

!FLSimpleStackTest methodsFor: 'testing' stamp: ''!
testCapacity
	| stack |
	stack := FLSimpleStack new: 3.
	self assert: 3 equals: stack capacity.

	stack := FLSimpleStack new: 5.
	self assert: 5 equals: stack capacity! !

!FLSimpleStackTest methodsFor: 'tests-adding' stamp: ''!
testGrow
	| stack |
	stack := FLSimpleStack new: 1.
	self assert: 1 equals: stack capacity.
	stack push: #a.
	self assert: 1 < stack capacity! !

!FLSimpleStackTest methodsFor: 'testing' stamp: ''!
testIsEmpty
	self assert: FLSimpleStack new isEmpty! !

!FLSimpleStackTest methodsFor: 'testing' stamp: ''!
testPush

	| stack |
	stack := FLSimpleStack new.
	stack push: 1.
	self deny: stack isEmpty.! !

!FLSingletonMock commentStamp: ''!
A mock for a singleton!
!FLSingletonMock methodsFor: 'accessing' stamp: ''!
reference: anObject
	^ reference := anObject! !

!FLSingletonMock methodsFor: 'accessing' stamp: ''!
reference
	^ reference! !

!FLSingletonMock class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'I''m a singleton!!'! !

!FLSingletonMock class methodsFor: 'accessing' stamp: ''!
instance
	^ Instance ifNil: [ Instance := self basicNew ]! !

!FLSingletonMock class methodsFor: 'class initialization' stamp: ''!
reset
	Instance := nil! !

!FLSingletonMockEnforced commentStamp: ''!
A test mock where a new instance is enforced!
!FLSingletonMockEnforced class methodsFor: 'fuel' stamp: ''!
fuelNew
	^ self instance! !

!FLSingletonTest commentStamp: ''!
SUnit tests for fuel serialization of singletons!
!FLSingletonTest methodsFor: 'tests' stamp: ''!
testSingletonMaterialization
	| singleton materialized |
	singleton := FLSingletonMock instance.
	singleton reference: 'a reference'.
	self assert: singleton equals: FLSingletonMock instance.

	materialized := self resultOfSerializeAndMaterialize: singleton.
	self deny: materialized identicalTo: singleton.
	self deny: materialized reference isNil.
	self deny: materialized reference identicalTo: singleton reference.

	FLSingletonMock reset	"cannot do this in tearDown because that's used by some helper methods"! !

!FLSingletonTest methodsFor: 'tests' stamp: ''!
testSingletonMaterializationEnforced
	| singleton materialized |
	singleton := FLSingletonMockEnforced instance.
	singleton reference: 'a reference'.
	self assert: singleton equals: FLSingletonMockEnforced instance.

	materialized := self resultOfSerializeAndMaterialize: singleton.
	self assert: materialized identicalTo: singleton.
	self deny: materialized reference isNil.
	self assert: materialized reference identicalTo: singleton reference.

	FLSingletonMock reset	"cannot do this in tearDown because that's used by some helper methods"! !

!FLSingletonTest methodsFor: 'tests' stamp: ''!
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 identicalTo: singleton.
	self deny: materialized reference isNil.
	self assert: materialized reference equals: singleton reference.

	FLSingletonMock reset	"cannot do this in tearDown because that's used by some helper methods"! !

!FLSingletonTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	FLSingletonMock reset! !

!FLSmallIntegerCluster commentStamp: ''!
I don't have so much sense as a class.!
!FLSortedCollectionSerializationTest commentStamp: ''!
SUnit tests for fuel serialization of sorted collections!
!FLSortedCollectionSerializationTest methodsFor: 'tests' stamp: ''!
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 equals: materialized asArray! !

!FLSortedCollectionSerializationTest methodsFor: 'tests' stamp: ''!
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 compiledBlock index literalHolder |
	ClassVariableForTesting := false.
	
	aSortedCollection := self class sortedCollectionForTestingWithClassVariable.
	materialized := self resultOfSerializeAndMaterialize: aSortedCollection.
	"the class variable ClassVariableForTesting should be false"
	
	compiledBlock := materialized sortBlock.
	
	literalHolder := compiledBlock isFullBlock 
		ifTrue: [ compiledBlock method ] 
		ifFalse: [ materialized sortBlock outerContext method ].
	index := literalHolder literals indexOf: (self class bindingOf: #ClassVariableForTesting).
	
	self deny: (literalHolder literalAt: index) value.
	ClassVariableForTesting := true.
	"the class variable ClassVariableForTesting should be true"
	self assert: (literalHolder literalAt: index) value
	
! !

!FLSortedCollectionSerializationTest methodsFor: 'accessing' stamp: ''!
classVariableForTesting: anObject
	
	ClassVariableForTesting := anObject ! !

!FLSortedCollectionSerializationTest methodsFor: 'accessing' stamp: ''!
classVariableForTesting
	
	^ ClassVariableForTesting! !

!FLSortedCollectionSerializationTest methodsFor: 'running' stamp: ''!
sortedBlockClosureWithInstanceVariable
	^ SortedCollection
		sortBlock: [ :a :b | 
			instanceVariableForTesting
				ifTrue: [ a <= b ]
				ifFalse: [ a >= b ] ]! !

!FLSortedCollectionSerializationTest methodsFor: 'tests' stamp: ''!
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 equals: materialized asArray! !

!FLSortedCollectionSerializationTest methodsFor: 'tests' stamp: ''!
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 equals: materialized asArray.
	self assert: aSortedCollection asArray equals: #(3 2 1)! !

!FLSortedCollectionSerializationTest methodsFor: 'tests' stamp: ''!
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 equals: materialized asArray! !

!FLSortedCollectionSerializationTest class methodsFor: 'sorted collections for testing' stamp: ''!
sortedCollectionForTestingWithClassVariable
	^ SortedCollection sortBlock: [ :a :b | 
		ClassVariableForTesting 
			ifTrue: [ a <= b ] 
			ifFalse: [ a >= b ] ]! !

!FLStreamStrategy commentStamp: ''!
I am a strategy that help tests for writing (and then reading) on streams.!
!FLStreamStrategy methodsFor: 'test support' stamp: ''!
tearDown! !

!FLStreamStrategy methodsFor: 'serializing' stamp: ''!
fuelAccept: aGeneralMapper
	"Visit myself as a substitution. See #fuelSubstitution."

	^ aGeneralMapper visitSubstitution: self by: nil! !

!FLStreamStrategy methodsFor: 'writing' stamp: ''!
writeStreamDo: aValuable
	"Evaluates the argument with a write stream. Answer the result."
	
	self subclassResponsibility ! !

!FLStreamStrategy methodsFor: 'reading' stamp: ''!
readStreamDo: aValuable
	"Evaluates the argument with a read stream. Answer the result."
	
	self subclassResponsibility ! !

!FLSubstitutionCluster commentStamp: ''!
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: 'serialize/materialize' stamp: ''!
registerIndexesOn: anEncoder
	substitutions keysAndValuesDo: [ :anObject :theSubstitution | 
		| substitutionIndex |
		substitutionIndex := anEncoder objectsIndexes at: theSubstitution.
		anEncoder substitutionIndexes
			at: anObject
			put: substitutionIndex ]! !

!FLSubstitutionCluster methodsFor: 'accessing' stamp: ''!
substitutions
	^ substitutions ! !

!FLSubstitutionCluster methodsFor: 'analyzing' stamp: ''!
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: ''!
initializeAnalyzing

	super initializeAnalyzing.
	substitutions := IdentityDictionary new.
	substitutes := IdentitySet new.! !

!FLSubstitutionCluster methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '->'.
	substitutions printElementsOn: aStream! !

!FLSubstitutionCluster methodsFor: 'accessing' stamp: ''!
objects
	"This cluster does not have objects"
	
	^#()! !

!FLSubstitutionCluster methodsFor: 'accessing' stamp: ''!
isSubstitute: anObject

	^ substitutes identityIncludes: anObject! !

!FLSubstitutionCluster class methodsFor: 'analyzing' stamp: ''!
clusterBucketIn: aClusterization

	^aClusterization substitutionsBucket! !

!FLTGlobalClassOrTraitSerializationTest commentStamp: ''!
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: ''!
testPreservesIdentity
	"Tests that serialization of the class or trait preserves identity"
	
	self assertSerializationIdentityOf: self newClassOrTrait! !

!FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: ''!
testNotFoundAfterRemoval
	"Tests that serializer does not tolarate when the class was removed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	
	self serialize: classOrTrait.
	self removeFromSystem: classOrTrait.
	
	self should: [self materialized] raise: FLClassNotFound.! !

!FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: ''!
testObsolete
	"Tests that serializer does not serialize as global an obsolete class or trait."
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	self removeFromSystem: classOrTrait.

	self 
		should: [self serialize: classOrTrait ] 
		raise: FLObsolete
		whoseDescriptionIncludes: classOrTrait name
		description: 'Should raise an error when serializing as global an obsolete class or trait.' ! !

!FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: ''!
testClassSideMethodNotFoundAfterRemoval
	"Tests that serializer does not tolarate when the method was removed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait classSide duringTestCompileSilently: 'you'.
	
	self serialize: classOrTrait classSide >> #you.
	classOrTrait classSide removeSelectorSilently: #you.
	
	self 
		should: [self materialized] 
		raise: FLMethodNotFound
		whoseDescriptionIncludes: classOrTrait classSide printString 
		description: 'Should raise an error when method is not present.' 
	
! !

!FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: ''!
testClassSideObsolete
	"Tests that serializer does not serialize as global the class-side of an obsolete class or trait."
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	self removeFromSystem: classOrTrait.

	self 
		should: [self serialize: classOrTrait ] 
		raise: FLObsolete
		whoseDescriptionIncludes: classOrTrait name
		description: 'Should raise an error when serializing as global an obsolete class or trait.' ! !

!FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: ''!
testMethodNotFoundAfterRemoval
	"Tests that serializer does not tolarate when the method was removed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait duringTestCompileSilently: 'you'.
	
	self serialize: classOrTrait >> #you.
	classOrTrait removeSelectorSilently: #you.
	
	self 
		should: [self materialized] 
		raise: FLMethodNotFound
		whoseDescriptionIncludes: classOrTrait name, '>>#you' 
		description: 'Should raise an error when method is not present.' 
	
! !

!FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: ''!
testClassSidePreservesIdentity
	"Tests that serialization of the class side preserves identity"
	
	self assertSerializationIdentityOf: self newClassOrTrait classSide ! !

!FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: ''!
testMethodPreservesIdentity
	"Tests that serialization of a method in a class or trait preserves identity"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait duringTestCompileSilently: 'you'.
	self assertSerializationIdentityOf: classOrTrait >> #you! !

!FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: ''!
testClassSideMethodPreservesIdentity
	"Tests that serialization of a method in the class-side of a class or trait preserves identity"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	classOrTrait classSide duringTestCompileSilently: 'you'.
	self assertSerializationIdentityOf: classOrTrait classSide >> #you! !

!FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: ''!
testNotFoundAfterRename
	"Tests that serializer does not tolarate when the class was renamed between serialization and materialization"
	
	| classOrTrait |
	classOrTrait := self newClassOrTrait.
	
	self serialize: classOrTrait.
	classOrTrait renameSilently: (classOrTrait name, 'Renamed') asSymbol.
	
	self should: [self materialized] raise: FLClassNotFound.! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!FLTGlobalClassOrTraitSerializationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!FLTraitSerializationTest commentStamp: ''!
I have the common behavior for testing trait serialization.!
!FLTraitSerializationTest methodsFor: 'running' stamp: ''!
newSecondaryTrait
	"Returns a trait for testing"

	^ self newTraitSuffixed: 'Secondary'! !

!FLTraitSerializationTest methodsFor: 'running' stamp: ''!
newClassOrTrait
	"Returns a trait for testing"

	^ self newTraitSuffixed: 'Main'! !

!FLTraitSerializationTest methodsFor: 'running' stamp: ''!
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.  "
	testingEnvironment at: aTrait name put: aTrait.
	aClass addToComposition: aTrait.
	^ aClass new! !

!FLUserGuidesTest commentStamp: ''!
SUnit tests to guide users with fuel serialization!
!FLUserGuidesTest methodsFor: 'tests-Managing Globals' stamp: ''!
testConsiderGlobal
	
	| aSerializer anArray materializedArray |
	"Prepare an array whose two elements are system globals."
	anArray := Array with: Set new with: Set new.
	testingEnvironment at: #GlobalSet1 put: anArray first.
	testingEnvironment at: #GlobalSet2 put: anArray second.

	"Serialize considering *only first* as a global object."
	FLPlatform current
		fileNamed: 'demo.fuel'
		writeStreamDo: [ :aStream |
			aSerializer := FLSerializer newDefault.
			aSerializer analyzer considerGlobal: #GlobalSet1.
			aSerializer serialize: anArray on: aStream ].

	"Materialize"
	materializedArray := FLPlatform current
		fileNamed: 'demo.fuel'
		readStreamDo: [:aStream |
			(FLMaterializer newDefault 
				materializeFrom: aStream) root].
				
	"Check that second element is a new Set."
	[ (testingEnvironment at: #GlobalSet1) == materializedArray first ] assert.
	[ (testingEnvironment at: #GlobalSet2) ~~ materializedArray second ] assert! !

!FLUserGuidesTest methodsFor: 'tests-Customizing Graph' stamp: ''!
testPluggableSubstitution
	| objectToSerialize aSerializer materializedObject |
	objectToSerialize := Array with: 'hello' with: '' writeStream.
	FLPlatform current
		fileNamed: 'demo.fuel'
		writeStreamDo: [ :aStream | 
			aSerializer := FLSerializer newDefault.
			aSerializer analyzer
				when: [ :o | o isStream ]
				substituteBy: [ :o | nil ].
			aSerializer serialize: objectToSerialize on: aStream ].
	materializedObject := FLPlatform current
		fileNamed: 'demo.fuel'
		readStreamDo:
			[ :aStream | (FLMaterializer newDefault materializeFrom: aStream) root ].
	self
		assert: materializedObject
		equals: (Array with: 'hello' with: nil)! !

!FLUserGuidesTest methodsFor: 'running' stamp: ''!
tearDown
	#('demo.fuel' 'numbers.fuel' 'number.fuel.zip' 'example.FL')
		do: [ :each | self deleteFileNamed: each ].
	testingEnvironment removeKey: #GlobalSet1 ifAbsent: [  ].
	testingEnvironment removeKey: #GlobalSet2 ifAbsent: [  ].
	super tearDown! !

!FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: ''!
testFileShortcuts
	| materializedString |
	FLSerializer serialize: 'stringToSerialize' toFileNamed: 'demo.fuel'.
	materializedString := FLMaterializer
		materializeFromFileNamed: 'demo.fuel'.
	self assert: materializedString equals: 'stringToSerialize'! !

!FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: ''!
testMemoryStream
	| anArray materializedString |
	anArray := FLSerializer serializeToByteArray: 'stringToSerialize'.
	materializedString := FLMaterializer
		materializeFromByteArray: anArray.
	self assert: materializedString equals: 'stringToSerialize'! !

!FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: ''!
testShowingProgressBar
	(testingEnvironment includesKey: #FLProgressSerialization)
		ifFalse: [ " Needs:
		(ConfigurationOfFuel project latestVersion) load: 'FuelProgressUpdate'.
		" ^ self skip ].
	FLPlatform current
		fileNamed: 'numbers.fuel'
		writeStreamDo: [ :aStream | 
			FLSerializer newDefault
				showProgress;
				serialize: (1 to: 200000) asArray on: aStream ].
	FLPlatform current
		fileNamed: 'numbers.fuel'
		readStreamDo: [ :aStream | 
			FLMaterializer newDefault
				showProgress;
				materializeFrom: aStream ]! !

!FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: ''!
testFileStream
	| materializedString |
	FLPlatform current
		fileNamed: 'demo.fuel'
		writeStreamDo:
			[ :aStream | FLSerializer newDefault serialize: 'stringToSerialize' on: aStream ].
	materializedString := FLPlatform current
		fileNamed: 'demo.fuel'
		readStreamDo: [ :aStream | 
			(FLMaterializer newDefault
				materializeFrom: aStream) root ].
	self assert: materializedString equals: 'stringToSerialize'! !

!FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: ''!
testGZip
	| materialized |
	FLPlatform current
		fileNamed: 'demo.fuel'
		writeStreamDo: [ :aFileStream | 
			| gzip |
			gzip := GZipWriteStream on: aFileStream.
			FLSerializer newDefault serialize: 123 on: gzip.
			gzip finish ].
	materialized := FLPlatform current
		fileNamed: 'demo.fuel'
		readStreamDo: [ :aFileStream | 
			| gzip |
			gzip := GZipReadStream on: aFileStream.
			(FLMaterializer newDefault materializeFrom: gzip) root ].
	self assert: materialized equals: 123! !

!FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: ''!
testDemo
	| sourceArray loadedArray |
	sourceArray := Array
		with: 'a string'
		with: Smalltalk
		with: [
			Smalltalk vm.
			'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"
	self assert: sourceArray ~~ loadedArray.
	"The strings are not the same"
	self assert: sourceArray first ~~ loadedArray first.
	self assert: sourceArray first equals: loadedArray first.
	"The global instance Smalltalk is the same"
	self assert: sourceArray second identicalTo: loadedArray second.
	"Evaluating the loaded block prints a string"
	self assert: loadedArray third value equals: 'a string'! !

!FLVariableObjectCluster commentStamp: ''!
I am a generic cluster for objects with indexable variables.!
!FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesOf: anObject with: anEncoder

	super serializeReferencesOf: anObject with: anEncoder.
	self serializeReferencesVariablePartOf: anObject with: anEncoder. ! !

!FLVariableObjectCluster methodsFor: 'analyzing' stamp: ''!
addVariableReferenceFrom: anObject to: anotherObject
	| list |
	list := self variableReferences
		at: anObject
		ifAbsent: [ nil ].
	list ifNil: [ self variableReferences at: anObject put: (list := OrderedCollection new) ].	
	list add: anotherObject! !

!FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesVariablePartOf: anObject with: aDecoder

	1 to: anObject basicSize 
		do: [ :index | anObject basicAt: index put: aDecoder nextEncodedReference ]! !

!FLVariableObjectCluster methodsFor: 'analyzing' stamp: ''!
variablePartReferencesOf: anObject do: aBlock 

	1 to: anObject basicSize 
		do: [ :index | aBlock value: (anObject basicAt: index) ]! !

!FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeReferencesOf: anObject with: aDecoder

	super materializeReferencesOf: anObject with: aDecoder.
	self materializeReferencesVariablePartOf: anObject with: aDecoder.! !

!FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: anObject with: anEncoder
	anEncoder encodeUint32: anObject basicSize! !

!FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	^theClass fuelNew: aDecoder nextEncodedUint32! !

!FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesVariablePartOf: anObject with: anEncoder
	
	(self variableReferences at: anObject ifAbsent: [ ^ self ]) do: [ :value |
		anEncoder encodeReferenceTo: value ]! !

!FLVariableObjectCluster methodsFor: 'accessing' stamp: ''!
variableReferences
	^ variableReferences ifNil: [ variableReferences := FLLargeIdentityDictionary new ]! !

!FLVariableObjectCluster methodsFor: 'analyzing' stamp: ''!
add: anObject traceWith: aAnalysis
	"Add an object to the cluster and trace references."
	objects addIfNotPresent: anObject ifPresentDo: [ ^ self ].

	self 
		referencesOf: anObject 
		do: [ :aChild || actual |
			actual := aChild fuelReplacement.
			self addReferenceFrom: anObject to: actual.
			aAnalysis trace: actual ].
		
	self
		variablePartReferencesOf: anObject
		do: [ :aChild || actual |
			actual := aChild fuelReplacement.
			self addVariableReferenceFrom: anObject to: actual.
			aAnalysis trace: actual ]! !

!FLVariablesMapping commentStamp: ''!
I am used to materialize instance variables in an object, tolerating "class shape changing".

Cases tolerated are:
- instance variable added
- instance variable order change
- instance variable removed
!
!FLVariablesMapping methodsFor: 'serialize/materialize' stamp: ''!
serializeReferencesOf: anObject with: anEncoder 

	(self references at: anObject ifAbsent: [ ^ self ]) do: [ :value |
		anEncoder encodeReferenceTo: value ].! !

!FLVariablesMapping methodsFor: 'analyzing' stamp: ''!
referencesOf: anObject do: aBlock

	mapping do: [ :index | aBlock value: (anObject instVarAt: index) ].! !

!FLVariablesMapping methodsFor: 'initialize-release' stamp: ''!
initializeWithClass: aClass references: aCollection
	self initialize.
	theClass := aClass.
	references := aCollection! !

!FLVariablesMapping methodsFor: 'serialize/materialize' stamp: ''!
initializeAnalyzing

	notIgnoredVariables := self instanceVariableNamesToSerialize.
	
	mapping := notIgnoredVariables 
		collect: [ :name | theClass instVarIndexFor: name ].! !

!FLVariablesMapping methodsFor: 'serialize/materialize' stamp: ''!
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: ''!
materializeReferencesOf: anObject with: aDecoder 

	mapping do: [ :index | 
			| reference |
			reference := aDecoder nextEncodedReference.
			index ifNotNil: [
				anObject 
					instVarAt: index
					put: reference ]].! !

!FLVariablesMapping methodsFor: 'accessing' stamp: ''!
references
	^ references! !

!FLVariablesMapping methodsFor: 'private' stamp: ''!
instanceVariableNamesToSerialize

	| ignoredInstanceVariableNames instanceVariableNamesToSerialize |
	ignoredInstanceVariableNames := theClass fuelIgnoredInstanceVariableNames.
	instanceVariableNamesToSerialize := OrderedCollection new.

	theClass instanceVariableNamesDo: [:name | 
		(ignoredInstanceVariableNames includes: name) 
			ifFalse: [ instanceVariableNamesToSerialize add: name ]].

	^ instanceVariableNamesToSerialize! !

!FLVariablesMapping methodsFor: 'accessing' stamp: ''!
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: 'initialize-release' stamp: ''!
initializeWithClass: aClass
	self initialize.
	theClass := aClass! !

!FLVariablesMapping methodsFor: 'serialize/materialize' stamp: ''!
serializeOn: anEncoder

	anEncoder encodeByte: notIgnoredVariables size.	
	notIgnoredVariables do: [ :name | anEncoder encodeString: name ].! !

!FLVariablesMapping class methodsFor: 'instance creation' stamp: ''!
newAnalyzing: anAnalysis references: aCollection

	^ self basicNew
		initializeWithClass: anAnalysis references: aCollection;
		initializeAnalyzing;
		yourself! !

!FLVariablesMapping class methodsFor: 'instance creation' stamp: ''!
materializing: aClass from: aDecoder
	
	^ self basicNew
		initializeWithClass: aClass;
		initializeMaterializingFrom: aDecoder;
		yourself.! !

!FLVersionTest commentStamp: ''!
SUnit tests for fuel versioning!
!FLVersionTest methodsFor: 'tests' stamp: ''!
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: ''!
testSameVersion

	serializer version: 1.
	materializer version: 1.
	self assertSerializationEqualityOf: 'content'! !

!FLWeakClassMock commentStamp: ''!
Test mock for a weak class!
!FLWeakClassMock methodsFor: 'accessing' stamp: ''!
instVar1: anObject
	instVar1 := anObject! !

!FLWeakClassMock methodsFor: 'accessing' stamp: ''!
instVar1
	^ instVar1 ! !

!FLWeakObjectsTest commentStamp: ''!
SUnit tests for fuel serialization of weak objects!
!FLWeakObjectsTest methodsFor: 'tests' stamp: ''!
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 equals: obj2.

	self deny: (self serializationOf: graph includes: 11).
	self assert: (self serializationOf: graph includes: obj2)! !

!FLWeakObjectsTest methodsFor: 'tests' stamp: ''!
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 equals: #foo! !

!FLWeakObjectsTest methodsFor: 'tests' stamp: ''!
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 equals: #foo! !

!FLWeakObjectsTest methodsFor: 'tests' stamp: ''!
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: ''!
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 equals: obj2.

	self deny: (self serializationOf: graph includes: 11).
	self assert: (self serializationOf: graph includes: obj2)! !

!FLWeakVariableObjectCluster commentStamp: ''!
I am a cluster for objects with weak indexable variables.!
!FLWeakVariableObjectCluster methodsFor: 'analyzing' stamp: ''!
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: ''!
serializeReferencesVariablePartOf: anObject with: anEncoder
	
	1 to: anObject basicSize do: [ :index |
		anEncoder encodeWeakReferenceTo: (anObject basicAt: index) ]! !

!FLWeakVariableObjectCluster methodsFor: 'analyzing' stamp: ''!
clusterReferencesDo: aBlock
	"Ensures that nil could be encoded, later in references step."

	super clusterReferencesDo: aBlock.
	aBlock value: nil! !

!FLWordObjectCluster commentStamp: ''!
I am the generic cluster for storing and loading variable word objects. Most word-like objects are subclasses from ArrayedCollection. Hence, we may have used the method #writeOn: to serialize, and #newFromStream: to materialize. 

#writeOn: is slow because it ALWAYS encode wors in a big endian format. Most machines today are even little endian. Even worst, #newFromStream: has to always do a #restoreEndianness. 

#newFromStream: is fast because it uses the method #nextWordsInto: which is a hack but that is really fast. The problem is that #nextWordsInto: has to always do the #restoreEndianness when we are in little endian machines (most of the time).

Hence, this cluster provives the best of both worlds: the serialization is done with a platform-dependen way, that is, the endianness will be the same of the machine where we are serializing. In addition, we serialize with the same hack that #nextWordsInto: uses, that is, the Bitmap >> hackBits:
And the materialization will use a variation of #nextWordsInto:  (#fuelNextWordsInto:) that ONLY does the #restoreEndianness if the machine where we are materializing has a different endianness than where we have serialized the object. To do this, while serializing, we store in the header of the Fuel stream, the endianness. Then in materialization, we compare agains that. 

Conclusion: we only restore endianness when needed.

Notice, in addition, that the method #newFromStream: sends the message #restoreEndianness. This method EXPECTS that the object was serialized in big endian format, and it will only change the endianness if we are materializing in a little endian machine. This means that if you serialize in little endian and materialize in big endian, you are screw.  For this reason, this cluster uses a method that always change the endianness, Bitmap class >> swapBytesIn:from:to: 

Future work: maybe we can modify and use the Bitmap hackBits:   not only for materialization but also for serialization. 
!
!FLWordObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
serializeInstance: aWordObject with: anEncoder
	anEncoder
		encodeUint32: aWordObject basicSize;
		encodeWords: aWordObject

! !

!FLWordObjectCluster methodsFor: 'serialize/materialize' stamp: ''!
materializeInstanceWith: aDecoder

	| inst wideSize |
	wideSize := aDecoder nextEncodedUint32.
	inst := theClass basicNew: wideSize.	

	aDecoder nextEncodedWordsInto: inst. 

	(aDecoder isBigEndian = FLPlatform current isBigEndian asBit)
		ifTrue: [^ inst ]
		ifFalse: [ ^ self swapBytesOf: inst ] 
	! !

!FLWordObjectCluster methodsFor: 'endianness' stamp: ''!
swapBytesOf: aWordObject
	Bitmap
                swapBytesIn: aWordObject
                from: 1
                to: aWordObject basicSize.
	^ aWordObject! !

!FT2Constants commentStamp: ''!
The various flags from the Freetype/2 header.

The LoadXXXX flags can be used with `primitiveLoadGlyph:flags:` or with the Cairo `primCairoFtFontCreateForFtFace:flags:scale:` primitives.

#### `FT_LOAD_DEFAULT`
  Corresponding to 0, this value is used a default glyph load.  In this
  case, the following will happen:
                                                                        
1. FreeType looks for a bitmap for the glyph corresponding to the
   face's current size.  If one is found, the function returns.  The
   bitmap data can be accessed from the glyph slot (see note below).
                                                                        
2. If no embedded bitmap is searched or found, FreeType looks for a
   scalable outline.  If one is found, it is loaded from the font
   file, scaled to device pixels, then "hinted" to the pixel grid in
   order to optimize it.  The outline data can be accessed from the
   glyph slot (see note below).
                                                                        
Note that by default, the glyph loader doesn't render outlines into
bitmaps. The following flags are used to modify this default
behaviour to more specific and useful cases.
                                                                        
#### `FT_LOAD_NO_SCALE`
  Don't scale the vector outline being loaded to 26.6 fractional
  pixels, but kept in font units.  Note that this also disables
  hinting and the loading of embedded bitmaps.  You should only use it
  when you want to retrieve the original glyph outlines in font units.
                                                                        
#### `FT_LOAD_NO_HINTING`
  Don't hint glyph outlines after their scaling to device pixels.
  This generally generates "blurrier" glyphs in anti-aliased modes.
                                                                        
  This flag is ignored if `FT_LOAD_NO_SCALE` is set.
                                                                        
#### `FT_LOAD_RENDER` 
  Render the glyph outline immediately into a bitmap before the glyph
  loader returns.  By default, the glyph is rendered for the
  `FT_RENDER_MODE_NORMAL` mode, which corresponds to 8-bit anti-aliased
  bitmaps using 256 opacity levels.  You can use either
  `FT_LOAD_TARGET_MONO` or `FT_LOAD_MONOCHROME` to render 1-bit
  monochrome bitmaps.
                                                                        
  This flag is ignored if `FT_LOAD_NO_SCALE` is set.
                                                                        
####`FT_LOAD_NO_BITMAP`
  Don't look for bitmaps when loading the glyph.  Only scalable
  outlines will be loaded when available, and scaled, hinted, or
  rendered depending on other bit flags.
                                                                        
  This does not prevent you from rendering outlines to bitmaps
  with `FT_LOAD_RENDER`, however.
                                                                        
####`FT_LOAD_VERTICAL_LAYOUT`
  Prepare the glyph image for vertical text layout.  This basically
  means that `face.glyph.advance` will correspond to the vertical
  advance height (instead of the default horizontal advance width),
  and that the glyph image will be translated to match the vertical
  bearings positions.
                                                                        
####`FT_LOAD_FORCE_AUTOHINT`
  Force the use of the FreeType auto-hinter when a glyph outline is
  loaded.  You shouldn't need this in a typical application, since it
  is mostly used to experiment with its algorithm.
                                                                        
####`FT_LOAD_CROP_BITMAP`
  Indicates that the glyph loader should try to crop the bitmap (i.e.,
  remove all space around its black bits) when loading it.  This is
  only useful when loading embedded bitmaps in certain fonts, since
  bitmaps rendered with `FT_LOAD_RENDER` are always cropped by default.
                                                                        
####`FT_LOAD_PEDANTIC`
  Indicates that the glyph loader should perform pedantic
  verifications during glyph loading, rejecting invalid fonts.  This
  is mostly used to detect broken glyphs in fonts.  By default,
  FreeType tries to handle broken fonts also.
                                                                        
#### `FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH`
  Indicates that the glyph loader should ignore the global advance
  width defined in the font.  As far as we know, this is only used by
  the X-TrueType font server, in order to deal correctly with the
  incorrect metrics contained in DynaLab's TrueType CJK fonts.
                                                                        
####`FT_LOAD_NO_RECURSE`
  This flag is only used internally.  It merely indicates that the
  glyph loader should not load composite glyphs recursively.  Instead,
  it should set the `num_subglyph` and `subglyphs` values of the glyph
  slot accordingly, and set "glyph->format" to `FT_GLYPH_FORMAT_COMPOSITE`.
                                                                        
  The description of sub-glyphs is not available to client
  applications for now.
                                                                        
####`FT_LOAD_IGNORE_TRANSFORM`
  Indicates that the glyph loader should not try to transform the
  loaded glyph image.  This doesn't prevent scaling, hinting, or
  rendering.
                                                                        
####`FT_LOAD_MONOCHROME`
  This flag is used with `FT_LOAD_RENDER` to indicate that you want
  to render a 1-bit monochrome glyph bitmap from a vectorial outline.
                                                                        
  Note that this has no effect on the hinting algorithm used by the
  glyph loader.  You should better use `FT_LOAD_TARGET_MONO` if you
  want to render monochrome-optimized glyph images instead.
                                                                        
####`FT_LOAD_LINEAR_DESIGN`
  Return the linearly scaled metrics expressed in original font units
  instead of the default 16.16 pixel values.
                                                                        
####`FT_LOAD_NO_AUTOHINT`
  Indicates that the auto-hinter should never be used to hint glyph
  outlines.  This doesn't prevent native format-specific hinters from
  being used.  This can be important for certain fonts where unhinted
  output is better than auto-hinted one.

One of following flags (as LoadTargetXXX) can be used to further specify the result.

####`FT_RENDER_MODE_NORMAL`                                          
     This is the default render mode; it corresponds to 8-bit        
     anti-aliased bitmaps, using 256 levels of opacity.              
                                                                     
####`FT_RENDER_MODE_LIGHT`                                           
     This is similar to `FT_RENDER_MODE_NORMAL`, except that this     
     changes the hinting to prevent stem width quantization.  This   
     results in glyph shapes that are more similar to the original,  
     while being a bit more fuzzy ("better shapes", instead of       
     "better contrast" if you want :-).                              
                                                                     
####`FT_RENDER_MODE_MONO`                                            
     This mode corresponds to 1-bit bitmaps.                         
                                                                     
####`FT_RENDER_MODE_LCD`                                             
     This mode corresponds to horizontal RGB/BGR sub-pixel displays, 
     like LCD-screens.  It produces 8-bit bitmaps that are 3 times   
     the width of the original glyph outline in pixels, and which use
     the `FT_PIXEL_MODE_LCD` mode.                                    
                                                                     
####`FT_RENDER_MODE_LCD_V`                                         
     This mode corresponds to vertical RGB/BGR sub-pixel displays    
     (like PDA screens, rotated LCD displays, etc.).  It produces    
     8-bit bitmaps that are 3 times the height of the original       
     glyph outline in pixels and use the `FT_PIXEL_MODE_LCD_V` mode.  
                                                                     
####Note                                                              
  The LCD-optimized glyph bitmaps produced by `FT_Render_Glyph` are    
  _not filtered_ to reduce color-fringes.  It is up to the caller to 
  perform this pass.                                                 

!
!FT2Constants class methodsFor: 'class initialization' stamp: ''!
initialize
	"FT2Constants initialize"

	LoadDefault := 0.
	LoadNoScale := 1.
	LoadNoHinting := 2.
	LoadRender := 4.
	LoadNoBitmap := 8.
	LoadVerticalLayout := 16.
	LoadForceAutohint := 32.
	LoadCropBitmap := 64.
	LoadPedantic := 128.
	LoadIgnoreGlobalAdvanceWidth := 512.
	LoadNoRecurse := 1024.
	LoadIgnoreTransform := 2048.
	LoadMonochrome := 4096.
	LoadLinearDesign := 8192.
	LoadSbitsOnly := 16384.
	LoadNoAutohint := 32768.

	"One of these flags may be OR'd with the above."
	LoadTargetNormal := 0.
	LoadTargetLight := 1 bitShift: 16.
	LoadTargetMono := 2 bitShift: 16.
	LoadTargetLCD := 3 bitShift: 16.
	LoadTargetLCDV  := 4 bitShift: 16.

	"rendering mode constants"
	RenderModeNormal := 0.
	RenderModeLight := 1.
	RenderModeMono := 2.
	RenderModeLCD := 3.	
	RenderModeLCDV := 4.

	"pixel mode constants"
	PixelModeNone := 0.
	PixelModeMono := 1.
	PixelModeGray := 2.
	PixelModeGray2 := 3.
	PixelModeGray4 := 4.
	PixelModeLCD := 5.
	PixelModeLCDV := 6.
	
	StyleFlagItalic := 1.
	StyleFlagBold := 2.! !

!FT2Error commentStamp: ''!
This is an Error that knows how to get the Freetype2 error code and string.!
!FT2Error methodsFor: 'accessing' stamp: ''!
errorCode
	^ errorCode! !

!FT2Error methodsFor: 'accessing' stamp: ''!
errorString: anObject
	errorString := anObject! !

!FT2Error methodsFor: 'accessing' stamp: ''!
errorCode: anObject
	errorCode := anObject! !

!FT2Error methodsFor: 'accessing' stamp: ''!
errorString
	^ errorString! !

!FT2Error methodsFor: 'accessing' stamp: ''!
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: $] ]]! !

!FT2Error class methodsFor: 'instance creation' stamp: ''!
errorCode: code signal: message
	^ self new
		messageText: message;
		errorCode: code;
		errorString: (FT2FFILibrary translateErrorCode: code);
		signal! !

!FT2Error class methodsFor: 'instance creation' stamp: ''!
errorCode: code errorString: str signal: message
	^ self new
		messageText: message;
		errorCode: code;
		errorString: str;
		signal! !

!FT2FFILibrary commentStamp: ''!
I am the entry point to the FFILibrary.
I have definitions about the errors and the name of the modules in the different architectures.!
!FT2FFILibrary methodsFor: 'accessing - platform' stamp: ''!
win32LibraryName
	#('freetype.dll' 'libfreetype.dll' 'libfreetype-6.dll') 
		detect: [ :each | (FileLocator vmDirectory / each) exists ]
		ifFound: [ :each | ^ each ].
	
	self error: 'freetyle library not found!!'! !

!FT2FFILibrary methodsFor: 'accessing - platform' stamp: ''!
unixLibraryName
	^ 'libfreetype.so.6'! !

!FT2FFILibrary methodsFor: 'accessing - platform' stamp: ''!
macLibraryName 
	^ 'libfreetype.dylib'! !

!FT2FFILibrary class methodsFor: 'class initialization' stamp: ''!
initialize
	"self initialize"

	ErrorCodeTable := {
	(16r00 -> 'no error').
	(16r01 -> 'cannot open resource').
	(16r02 -> 'unknown file format').
	(16r03 -> 'broken file').
	(16r04 -> 'invalid FreeType version').
	(16r05 -> 'module version is too low').
	(16r06 -> 'invalid argument').
	(16r07 -> 'unimplemented feature').
	(16r08 -> 'broken table').
	(16r09 -> 'broken offset within table').
	(16r0A -> 'array allocation size too large').
	(16r0B -> 'missing module').
	(16r0C -> 'missing property').


	(16r10 -> 'invalid glyph index').
	(16r11 -> 'invalid character code').
	(16r12 -> 'unsupported glyph image format').
	(16r13 -> 'cannot render this glyph format').
	(16r14 -> 'invalid outline').
	(16r15 -> 'invalid composite glyph').
	(16r16 -> 'too many hints').
	(16r17 -> 'invalid pixel size').


	(16r20 -> 'invalid object handle').
	(16r21 -> 'invalid library handle').
	(16r22 -> 'invalid module handle').
	(16r23 -> 'invalid face handle').
	(16r24 -> 'invalid size handle').
	(16r25 -> 'invalid glyph slot handle').
	(16r26 -> 'invalid charmap handle').
	(16r27 -> 'invalid cache manager handle').
	(16r28 -> 'invalid stream handle').


	(16r30 -> 'too many modules').
	(16r31 -> 'too many extensions').


	(16r40 -> 'out of memory').
	(16r41 -> 'unlisted object').


	(16r51 -> 'cannot open stream').
	(16r52 -> 'invalid stream seek').
	(16r53 -> 'invalid stream skip').
	(16r54 -> 'invalid stream read').
	(16r55 -> 'invalid stream operation').
	(16r56 -> 'invalid frame operation').
	(16r57 -> 'nested frame access').
	(16r58 -> 'invalid frame read').


	(16r60 -> 'raster uninitialized').
	(16r61 -> 'raster corrupted').
	(16r62 -> 'raster overflow').
	(16r63 -> 'negative height while rastering').


	(16r70 -> 'too many registered caches').


	(16r80 -> 'invalid opcode').
	(16r81 -> 'too few arguments').
	(16r82 -> 'stack overflow').
	(16r83 -> 'code overflow').
	(16r84 -> 'bad argument').
	(16r85 -> 'division by zero').
	(16r86 -> 'invalid reference').
	(16r87 -> 'found debug opcode').
	(16r88 -> 'found ENDF opcode in execution stream').
	(16r89 -> 'nested DEFS').
	(16r8A -> 'invalid code range').
	(16r8B -> 'execution context too long').
	(16r8C -> 'too many function definitions').
	(16r8D -> 'too many instruction definitions').
	(16r8E -> 'SFNT font table missing').
	(16r8F -> 'horizontal header (hhea. table missing').
	(16r90 -> 'locations (loca. table missing').
	(16r91 -> 'name table missing').
	(16r92 -> 'character map (cmap. table missing').
	(16r93 -> 'horizontal metrics (hmtx. table missing').
	(16r94 -> 'PostScript (post. table missing').
	(16r95 -> 'invalid horizontal metrics').
	(16r96 -> 'invalid character map (cmap. format').
	(16r97 -> 'invalid ppem value').
	(16r98 -> 'invalid vertical metrics').
	(16r99 -> 'could not find context').
	(16r9A -> 'invalid PostScript (post. table format').
	(16r9B -> 'invalid PostScript (post. table').
	(16r9C -> 'found FDEF or IDEF opcode in glyf bytecode').
	(16r9D -> 'missing bitmap in strike').


	(16rA0 -> 'opcode syntax error').
	(16rA1 -> 'argument stack underflow').
	(16rA2 -> 'ignore').
	(16rA3 -> 'no Unicode glyph name found').
	(16rA4 -> 'glyph too big for hinting').


	(16rB0 -> 'STARTFONT field missing').
	(16rB1 -> 'FONT field missing').
	(16rB2 -> 'SIZE field missing').
	(16rB3 -> 'FONTBOUNDINGBOX field missing').
	(16rB4 -> 'CHARS field missing').
	(16rB5 -> 'STARTCHAR field missing').
	(16rB6 -> 'ENCODING field missing').
	(16rB7 -> 'BBX field missing').
	(16rB8 -> 'BBX too big').
	(16rB9 -> 'Font header corrupted or missing fields').
	(16rBA -> 'Font glyphs corrupted or missing fields')} asDictionary! !

!FT2FFILibrary class methodsFor: 'error handling' stamp: ''!
translateErrorCode: aCode
	^ ErrorCodeTable at: aCode ifAbsent: [ 'Unknown Error code' ].! !

!FT2Face commentStamp: ''!
Do not rearrange these fields!!
New fields should go at the end, because the plugin has to know about these indexes.

ByteArray representing a pointer to the malloc'd FT_Face struct:
handle

Copied from the FT_Face struct on creation:
numFaces faceIndex faceFlags styleFlags numGlyphs familyName styleName numFixedSizes availableSizes numCharmaps charmaps

Copied on creation, but only relevant to scalable outlines:
bbox unitsPerEm ascender descender height maxAdvanceWidth maxAdvanceHeight underlinePosition underlineThickness 

Working memory:
glyph -- FT2GlyphSlot, set by loadGlyph or loadChar
size -- the active size, set by activateSize, used by loadGlyph, getKerning, etc.
charmap -- set by setCharmap
!
!FT2Face methodsFor: 'accessing' stamp: ''!
bbox
	^ bbox! !

!FT2Face methodsFor: 'private - ffi' stamp: ''!
ffiSetPixelWidth: pixel_width height: pixel_height
	^ self ffiCall: #(long FT_Set_Pixel_Sizes(self,
                      FT_UInt  pixel_width,
                      FT_UInt  pixel_height ))! !

!FT2Face methodsFor: 'accessing' stamp: ''!
ascender
	^ascender! !

!FT2Face methodsFor: 'glyphs' stamp: ''!
loadCharacter: index flags: flags
	self primLoadCharacter: index flags: flags.
	glyph
		ifNil: [ glyph := FT2GlyphSlot fromFace: self ]
		ifNotNil: [ glyph loadFrom: self ].! !

!FT2Face methodsFor: 'accessing' stamp: ''!
faceIndex
	^faceIndex! !

!FT2Face methodsFor: 'private - ffi' stamp: ''!
ffiSelectCharmap: encoding_value
	self ffiCall: #(FT_Error FT_Select_Charmap(self, FT_Encoding  encoding_value ))! !

!FT2Face methodsFor: 'rendering' stamp: ''!
renderGlyphIntoForm: aForm
	"render the current glyph (selected by loadChar/loadGlyph into the given form (1 or 8 bpp)"
	self validate.
	self renderGlyphIntoForm: aForm pixelMode: nil! !

!FT2Face methodsFor: 'private - primitives' stamp: ''!
primGetKerningLeft: leftGlyphIndex right: rightGlyphIndex
	| result returnCode |
	result := FTVector new.

	returnCode := self
		ffiGetKerningLeft: leftGlyphIndex
		right: rightGlyphIndex
		result: result.

	returnCode ~= 0
		ifTrue: [ ^ 0 @ 0 ].
	
	^ result x @ result y! !

!FT2Face methodsFor: 'accessing' stamp: ''!
numCharmaps
	^numCharmaps! !

!FT2Face methodsFor: 'accessing' stamp: ''!
underlineThickness
	^underlineThickness! !

!FT2Face methodsFor: 'testing' stamp: ''!
isItalic
	styleFlags == nil ifTrue:[^false].
	^styleFlags allMask: StyleFlagItalic! !

!FT2Face methodsFor: 'accessing' stamp: ''!
styleFlags
	^styleFlags! !

!FT2Face methodsFor: 'rendering' stamp: ''!
translateOutlineBy: aPoint
	| delta|
	delta := IntegerArray new: 2.
	delta at: 1 put: (aPoint x * 64) rounded. 
	delta at: 2 put: (aPoint y * 64) rounded.
	self primTranslateGlyphSlotOutline: delta.! !

!FT2Face methodsFor: 'accessing' stamp: ''!
postscriptName
	self isValid ifFalse: [ ^ nil ].	
	^self ffiGetPostscriptName! !

!FT2Face methodsFor: 'private - ffi' stamp: ''!
ffiTranslateOutline: outline x: xOffset y: yOffset
	self ffiCall: #(void FT_Outline_Translate (FT_Outline * outline , FT_Pos xOffset , FT_Pos yOffset))! !

!FT2Face methodsFor: 'private - ffi' stamp: ''!
ffiLoadChar: char_code flags: load_flags
	^ self ffiCall: #(FT_Error FT_Load_Char(self, FT_ULong  char_code, FT_Int32  load_flags ))! !

!FT2Face methodsFor: 'private - ffi' stamp: ''!
ffiOutline: outline embolden: strength

	^ self ffiCall: #(FT_Error FT_Outline_Embolden(FT_Outline*  outline, FT_Pos strength ))! !

!FT2Face methodsFor: 'charmaps' stamp: ''!
getCharMap
	|faceRec|
	self isValid ifFalse: [ self error: 'The Face is not valid.' ].
	faceRec := FTFaceRec fromHandle: handle.
	
	faceRec charmap isNull ifTrue: [ ^ self ].
	encoding := faceRec charmap encoding asByteArray asString.
	platformId := faceRec charmap platform_id.
	encodingId := faceRec charmap encoding_id.! !

!FT2Face methodsFor: 'private - primitives' stamp: ''!
primLoadCharacter: index flags: flags
	| returnCode |
	self validate.
	returnCode := self ffiLoadChar: index flags: flags.
	returnCode ~= 0 ifTrue: [ FT2Error errorCode: returnCode signal: 'Error loading character' ].! !

!FT2Face methodsFor: 'glyphs' stamp: ''!
fillGlyph: aGlyphSlot
	| faceRec |
	
	self validate.
	
	aGlyphSlot face: self.	
	faceRec := FTFaceRec fromHandle: handle.
	aGlyphSlot fillFromGlyphSlotRec: faceRec glyph.! !

!FT2Face methodsFor: 'accessing' stamp: ''!
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: 'outlines' stamp: ''!
characterOutline: aCharacter
	^self loadCharacterOutline: aCharacter asUnicode flags: LoadIgnoreTransform! !

!FT2Face methodsFor: 'accessing' stamp: ''!
height
	^height! !

!FT2Face methodsFor: 'outlines' stamp: ''!
loadCharacterOutline: index flags: flags
	| em outline |
	em := unitsPerEm.
	self setPixelWidth: em height: em.
	self loadCharacter: index flags: flags.
	outline := FT2Outline new.
	outline primLoadSizesFrom: self.
	outline allocateArrays.
	outline primLoadArraysFrom: self.

	^outline! !

!FT2Face methodsFor: 'private - ffi' stamp: ''!
ffiGetPostscriptName
	self ffiCall: #(char* FT_Get_Postscript_Name(self))! !

!FT2Face methodsFor: 'private' stamp: ''!
loadFields
	| faceRect |
	self isValid 
		ifFalse: [ ^ self error: 'I cannot load face fields because face is not valid.' ].

	faceRect := FTFaceRec fromHandle: handle.
	
	numFaces := faceRect num_faces.	
	faceIndex := faceRect face_index.
	faceFlags := faceRect face_flags.
	styleFlags := faceRect style_flags.
	numGlyphs := faceRect num_glyphs.
	familyName := faceRect family_name readString.
	styleName := faceRect style_name readString. 
	
	numFixedSizes := faceRect num_fixed_sizes.
	numCharmaps := faceRect num_charmaps.
	charmaps := nil.
	encoding := nil.
	
	"FT_FACE_FLAG_SCALABLE = 1 "
	(faceRect face_flags bitAnd: 1) ~= 0 ifTrue: [  
		unitsPerEm := faceRect units_per_EM.
		ascender := faceRect ascender.
		descender := faceRect descender.
		height := faceRect height.
		maxAdvanceWidth := faceRect max_advance_width.
		maxAdvanceHeight := faceRect max_advance_height.
		underlinePosition := faceRect underline_position.
		underlineThickness := faceRect underline_thickness.
	].
	
	bbox := Rectangle 
		origin: ( Point x: faceRect bbox xMin y: faceRect bbox yMin )
		corner: ( Point x: faceRect bbox xMax y: faceRect bbox yMax ).! !

!FT2Face methodsFor: 'private - primitives' stamp: ''!
primTranslateGlyphSlotOutline:  anIntegerArray
	self ffiTranslateOutline: self outline x: (anIntegerArray at: 1) y: (anIntegerArray at: 2).! !

!FT2Face methodsFor: 'glyphs' stamp: ''!
setPixelWidth: x height: y
	| returnCode |
	self isValid ifFalse: [ self error: 'The Face is not valid' ].
	returnCode := self ffiSetPixelWidth: x height: y.
	
	returnCode ~= 0 ifTrue: [ FT2Error errorCode: returnCode signal: 'Error setting the pixel width and height.' ].! !

!FT2Face methodsFor: 'glyphs' stamp: ''!
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: 'testing' stamp: ''!
isRegular
	styleFlags == nil ifTrue:[^true].
	^styleFlags = 0! !

!FT2Face methodsFor: 'private - primitives' stamp: ''!
primTransformGlyphSlotOutline:  anIntegerArray
	| faceRec outline matrix |
	faceRec := FTFaceRec fromHandle: handle.
	matrix := FTMatrix new.
	
	matrix xx: (anIntegerArray at:1). 
	matrix xy: (anIntegerArray at:2). 
	matrix yx: (anIntegerArray at:3). 
	matrix yy: (anIntegerArray at:4).  
	
	"I need to obtain the real address of the struct inside the struct"
	outline := FTOutline fromHandle: faceRec glyph outline getHandle asExternalAddress.
	
	self ffiOutline: outline transformByMatrix: matrix.! !

!FT2Face methodsFor: 'rendering' stamp: ''!
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: 'testing' stamp: ''!
isBold
	styleFlags == nil ifTrue:[^false].
	^styleFlags allMask: StyleFlagBold! !

!FT2Face methodsFor: 'private - ffi' stamp: ''!
ffiLoadGlyph: glyph_index flags: load_flags
	^ self ffiCall: #(FT_Error FT_Load_Glyph(self, FT_UInt glyph_index,FT_Int32  load_flags ))! !

!FT2Face methodsFor: 'accessing' stamp: ''!
outline
	self validate.
	^ FTOutline fromHandle: (FTFaceRec fromHandle: handle) glyph outline getHandle asExternalAddress! !

!FT2Face methodsFor: 'private - primitives' stamp: ''!
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]
	"
	
	| matrix delta |
	matrix := FTMatrix new.
	delta := FTVector new.

	delta x: (deltaWordArray at: 1).
	delta y: (deltaWordArray at: 2).
	
	matrix xx: (matrixWordArray at: 1).
	matrix xy: (matrixWordArray at: 2).
	matrix yx: (matrixWordArray at: 3).
	matrix yy: (matrixWordArray at: 4).
		
	self ffiTransformMatrix: matrix delta: delta.! !

!FT2Face methodsFor: 'rendering' stamp: ''!
renderGlyphIntoForm: aForm pixelMode: pixelMode
	"render the current glyph (selected by loadChar/loadGlyph into the given form (1 or 8 bpp)
	with pixel mode anInteger "

	| ftBitmap buffer outline |
	ftBitmap := FTBitmap new.
	outline := self outline.

	buffer := ExternalAddress allocate: aForm bits byteSize.
	1 to: aForm bits byteSize do: [ :i | buffer byteAt: i put: 0 ].
	buffer autoRelease.

	ftBitmap setBuffer: buffer.
	ftBitmap initializeFromForm: aForm pixelMode: pixelMode.

	FT2Library current getBitmap: ftBitmap getHandle fromOutline: outline getHandle.

	aForm bits copyFromByteArray: (buffer copyFrom: 1 to: aForm bits byteSize)! !

!FT2Face methodsFor: 'charmaps' stamp: ''!
setCharMap: encodingString
	| returnCode |
	
	self validate.
	
	returnCode := self ffiSelectCharmap: encodingString asByteArray asInteger.
	returnCode ~= 0 ifTrue: [ FT2Error errorCode: returnCode signal: 'Error selecting charmap' ].	

	self getCharMap.! !

!FT2Face methodsFor: 'accessing' stamp: ''!
size
	^size! !

!FT2Face methodsFor: 'rendering' stamp: ''!
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: 'accessing' stamp: ''!
styleName
	^styleName! !

!FT2Face methodsFor: 'rendering' stamp: ''!
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: ''!
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: 'private - ffi' stamp: ''!
ffiGetKerningLeft: left_glyph right: right_glyph result: akerning
	self
		ffiCall: #(FT_Error FT_Get_Kerning(self, FT_UInt left_glyph, FT_UInt right_glyph, 2, FT_Vector  *akerning ))! !

!FT2Face methodsFor: 'accessing' stamp: ''!
unitsPerEm
	^unitsPerEm! !

!FT2Face methodsFor: 'initialization' stamp: ''!
newFaceFromFile: file index: anInteger
	| holder returnCode fileName |
	
	holder := PointerHolder new.
	fileName := file asFileReference pathString.
	
	FT2Library current checkLibrary.
	returnCode := FT2Library current ffiNewFace: holder fromFilename: fileName index: anInteger.
	returnCode ~= 0
		ifTrue: [ FT2Error errorCode: returnCode signal: 'Error reading new face from file'].
		
	handle := holder value.
	self autoRelease.! !

!FT2Face methodsFor: 'accessing' stamp: ''!
numFixedSizes
	^numFixedSizes! !

!FT2Face methodsFor: 'private - ffi' stamp: ''!
ffiTransformMatrix: matrix delta: delta
	self ffiCall: #(void FT_Set_Transform(self, FT_Matrix*  matrix, FT_Vector*  delta ))! !

!FT2Face methodsFor: 'rendering' stamp: ''!
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: 'printing' stamp: ''!
printOn: aStream 
	super printOn: aStream.
	handle ifNil: [^self].
	"self familyName isNil ifTrue: [ self loadFields ]."
	aStream
		nextPut: $[;
		nextPutAll: (self familyName ifNil: ['?']);
		space;
		nextPutAll: (self styleName ifNil: ['?']);
		nextPut: $]! !

!FT2Face methodsFor: 'rendering' stamp: ''!
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: 'private - ffi' stamp: ''!
ffiOutline: outline transformByMatrix: matrix
	^ self ffiCall: #(void FT_Outline_Transform( FT_Outline*  outline, FT_Matrix*   matrix ))! !

!FT2Face methodsFor: 'accessing' stamp: ''!
encoding
	encoding ifNil: [ self getCharMap ].
	^encoding! !

!FT2Face methodsFor: 'rendering' stamp: ''!
emboldenOutline: strength
	| returnCode outline faceRec |

	self validate.
	faceRec := FTFaceRec fromHandle: handle.
	outline := FTOutline fromHandle: faceRec glyph outline getHandle asExternalAddress.
	returnCode := self ffiOutline: outline embolden:  (strength * 64) rounded.

	returnCode ~= 0
		ifTrue: [ FT2Error errorCode: returnCode signal: 'Error embolding glyph' ]! !

!FT2Face methodsFor: 'charmaps' stamp: ''!
getCharMapsInto: array
	| faceRec charmap external |
	
	faceRec := FTFaceRec fromHandle: handle.

	external := FFIExternalArray fromHandle: faceRec charmaps getHandle type: 'void*' size: faceRec num_charmaps.
	
	1 to: faceRec num_charmaps do: [ :idx |
		charmap := FTCharMapRec fromHandle: (external at: idx).
		array at: idx put: charmap encoding asByteArray asString		
	].

	^ array.! !

!FT2Face methodsFor: 'accessing' stamp: ''!
faceFlags
	^faceFlags! !

!FT2Face methodsFor: 'testing' stamp: ''!
isFixedWidth
	styleFlags == nil ifTrue:[^false].
	^faceFlags allMask: 4 "FT_FACE_FLAG_FIXED_WIDTH"! !

!FT2Face methodsFor: 'accessing' stamp: ''!
glyph
	glyph ifNil: [ glyph := FT2GlyphSlot fromFace: self ].
	^glyph! !

!FT2Face methodsFor: 'glyphs' stamp: ''!
glyphOfCharacter: aCharacter
	"load a glyph with outline, glyph is not scaled "
	| em aGlyph |
	em := self unitsPerEm.
	self validate.
	self setPixelWidth: em height: em.
	self loadCharacter: aCharacter asInteger flags: LoadIgnoreTransform. "load glyph metrics"
	aGlyph := self glyph shallowCopy. " copy because 'face glyph' is only a slot"
	aGlyph outline: (self characterOutline: aCharacter).
	^aGlyph! !

!FT2Face methodsFor: 'accessing' stamp: ''!
underlinePosition
	^underlinePosition! !

!FT2Face methodsFor: 'glyphs' stamp: ''!
loadGlyph: index flags: flags
	| returnCode |
	
	returnCode := self ffiLoadGlyph: index flags: flags.
	returnCode ~= 0 ifTrue: [ FT2Error errorCode: returnCode signal: 'Loading glyph'  ].
	
	glyph
		ifNil: [ glyph := FT2GlyphSlot fromFace: self ]
		ifNotNil: [ glyph loadFrom: self ].! !

!FT2Face methodsFor: 'accessing' stamp: ''!
numFaces
	^numFaces! !

!FT2Face methodsFor: 'accessing' stamp: ''!
descender
	^descender! !

!FT2Face methodsFor: 'accessing' stamp: ''!
maxAdvanceWidth
	^maxAdvanceWidth! !

!FT2Face methodsFor: 'accessing' stamp: ''!
maxAdvanceHeight
	^maxAdvanceHeight! !

!FT2Face methodsFor: 'private - ffi' stamp: ''!
ffiGetCharIndex: charIndex
	^ self ffiCall: #(FT_UInt FT_Get_Char_Index(self, FT_ULong charIndex))! !

!FT2Face methodsFor: 'initialization' stamp: ''!
newFaceFromExternalMemory: aFreeTypeExternalMemory index: anInteger
	| memSize holder returnCode |

	aFreeTypeExternalMemory validate.
	memSize := aFreeTypeExternalMemory bytes size.
	holder := PointerHolder new.
	
	FT2Library current checkLibrary.
	returnCode := FT2Library current ffiNewFace: holder fromMemory: aFreeTypeExternalMemory handle size: memSize  index: anInteger.
	returnCode ~= 0
		ifTrue: [ FT2Error errorCode: returnCode signal: 'Error reading new face from memory'].
		
	handle := holder value.
	self autoRelease.! !

!FT2Face methodsFor: 'accessing' stamp: ''!
availableSizes
	^availableSizes! !

!FT2Face methodsFor: 'accessing' stamp: ''!
familyName
	^familyName! !

!FT2Face methodsFor: 'glyphs' stamp: ''!
glyphOfCharacter: aCharacter fontSize: fontSize
	^self glyphOfCharacter: aCharacter pixelSize: fontSize@fontSize! !

!FT2Face methodsFor: 'accessing' stamp: ''!
numGlyphs
	^numGlyphs! !

!FT2Face methodsFor: 'kerning' stamp: ''!
kerningLeft: leftCharacter right: rightCharacter
	^ self
		primGetKerningLeft: (self ffiGetCharIndex: leftCharacter asInteger)
		right: (self ffiGetCharIndex: rightCharacter asInteger)! !

!FT2Face class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: handle

	handle ifNil: [ ^ self ].
	handle isNull
		ifTrue: [ ^ self ].

	FT2Library current ffiDoneFace: handle.
	handle beNull! !

!FT2GlyphRenderer commentStamp: ''!
i am used to render freetype glyphs using balloon primitives.!
!FT2GlyphRenderer methodsFor: 'private' stamp: ''!
loadSurfaceTransform
	| m org xaxis yaxis sum xmin xmax ymin ymax formW formH fix face bbox |
	
	face := font face.

	face 
		setPixelWidth: pixelSize height: pixelSize.
	
	bbox := face bbox.
	m := surface pathTransform copy transposed.

	org := m transform: 0@0.
	xaxis := (m transform: bbox right - bbox left * pixelSize / face unitsPerEm @ 0) - org.
	yaxis := (m transform: 0 @ (bbox bottom - bbox top * pixelSize / face unitsPerEm)) - org.
	sum := xaxis + yaxis.
	
	xmin := 0 min: ((xaxis x min: yaxis x) min: sum x).
	ymin := 0 min: ((xaxis y min: yaxis y) min: sum y).
	xmax := 0 max: ((xaxis x max: yaxis x) max: sum x).
	ymax := 0 max: ((xaxis y max: yaxis y) max: sum y).

	formW := (xmax - xmin) ceiling + 1.
	formH := (ymax - ymin) ceiling  + 1.

" freetype 'zero' points to bottom-left point on form" 

	"calculate bitmap translation relative to top-left corner of glyph"
	bitmapX := (yaxis x negated + xmin * 64.0) rounded.
	bitmapY := (xaxis y negated + ymin * 64.0) rounded.

	descend := 0 @  ((face bbox height -  face bbox bottom  * pixelSize / face unitsPerEm) +1).
	descend := (m transform: descend) - org.
	descend := descend + (xmin negated@(ymin negated)).
	descend := (descend * 64 ) rounded.

	form := Form extent: formW @ formH depth: 8.

	blt 
		sourceForm: form;
		width: form width;
		height: form height.

	"prepare transformation matrix for freetype"
	
	matrix := IntegerArray new: 4.

	"values in matrix are 16.16 fixed point floating values" 
	fix := 65536. "(2 raisedTo: 16)."
	
	matrix 
		at: 1 put: (m sx * fix) rounded;
		at: 2 put: (m shx * fix) rounded;
		at: 3 put: (m shy * fix) rounded;
		at: 4 put: (m sy * fix) rounded! !

!FT2GlyphRenderer methodsFor: 'private' stamp: ''!
clearBitmap
	
	form bits atAllPut: 0! !

!FT2GlyphRenderer methodsFor: 'initialization' stamp: ''!
initForFont: aFont surface: aSurface

	self assert: (aFont class == FreeTypeFont).
	
	surface := aSurface.
	font := aFont.
	slot := SimpleTextGlyphInfo new.
	
	pixelSize := font pixelSize rounded.

	blt := BitBlt toForm: surface form.

	self loadSurfaceTransform.

	colorMap := Bitmap new: 256.
	
	blt 
		sourceForm: form;
		sourceX: 0;
		sourceY: 0;
		destOrigin: 0@0;
		sourceOrigin: 0@0;
		halftoneForm: nil;
		combinationRule: 24;
		width: form width;
		height: form height;
		colorMap: colorMap;
		clipRect: surface clipRect.
	
	translation := IntegerArray new: 2! !

!FT2GlyphRenderer methodsFor: 'accessing' stamp: ''!
form

	^ form! !

!FT2GlyphRenderer methodsFor: 'rendering' stamp: ''!
renderGlyphsIn: text from: start to: stop

	| face |
	face := font face.
"	face
		setPixelWidth: pixelSize height: pixelSize.
"
	start to: stop do: [:i | | bx by |
		
		bx := penX + bitmapX.
		by := penY + bitmapY.

		"add a small shift, to incorporate subpixel position"
		
		translation at: 1 put: descend x + (bx bitAnd: 2r111111).
		translation at: 2 put: descend y - (by bitAnd: 2r111111). 

		face primSetTransform: matrix delta: translation.

		self loadUnicode: (text at: i) asUnicode.
	
		self clearBitmap.
		face renderGlyphIntoForm: form.

		blt
			destX: bx >> 6;
			destY: by >> 6;
			copyBits.

	"increment x by horizontal advance"
		penX := penX + slot advanceX.
		penY := penY - slot advanceY
	].! !

!FT2GlyphRenderer methodsFor: 'accessing' stamp: ''!
setColor: color
	"Set the color which will be used to render glyphs."
	
	| clr rgb alpha |
	currentColor = color ifTrue: [ ^ self ].
	currentColor := color.
	clr := self pixelValue32Of: color. 
	rgb := clr bitAnd: 16rFFFFFF.
	alpha := clr >> 24.
	
 	0 to: 255 do:[:i | | a |
		a :=  (i+1) * alpha bitAnd: 16rFF00.
		colorMap at: i+1 put: ( (a<<16) + rgb ).
	]

"	colorMap at: 1 put: (Color red  alpha: 0.1) pixelValue32."! !

!FT2GlyphRenderer methodsFor: 'private' stamp: ''!
pixelValue32Of: aColor
 
	^ aColor pixelWordForDepth: 32! !

!FT2GlyphRenderer methodsFor: 'private' stamp: ''!
loadUnicode: unicode

	| flags face |
	
	face := font face.

"	hintingFlags := FreeTypeSettings current hintingFlags."
	flags :=  LoadNoBitmap bitOr: 2 "hintingFlags".
"	bitOr:( LoadIgnoreTransform  bitOr: 2 ). "
	face primLoadCharacter: unicode flags: flags.

	self loadSlotInfo! !

!FT2GlyphRenderer methodsFor: 'accessing' stamp: ''!
getAdvance
	"aPoint is a text origin in user's coordinate system,
	and anvance is accumulated advance came from another renderer instance, expressed in surface's coordinate system"

	| pt |
	pt := (penX/64.0) @ (penY/64.0) - origin.
	^ pt! !

!FT2GlyphRenderer methodsFor: 'private' stamp: ''!
setPosition: aPoint advance: advancePt baseline: baselineOffset
	"aPoint is a text origin in user's coordinate system,
	and andvance is accumulated advance came from another renderer instance, expressed in surface's coordinate system"

	| pt offset |
	
	offset :=  baselineOffset - font getPreciseAscent "(font face ascender  * pixelSize / font face unitsPerEm)".

	pt := aPoint + (0@offset).
	pt := surface pathTransform transform: pt.
	origin := pt.
	pt := pt + advancePt.
	
	"remember the origin, so on #getAdvance , we will answer the current advance for renderer in surface coordinate system"
	
"	2 raisedTo: 6 "
	penX := (pt x * 64) rounded.
	penY := (pt y * 64) rounded! !

!FT2GlyphRenderer methodsFor: 'private' stamp: ''!
loadSlotInfo

	slot loadFrom: font face! !

!FT2GlyphRenderer class methodsFor: 'instance creation' stamp: ''!
forFont: aFont surface: aSurface

	^ self new initForFont: aFont surface: aSurface! !

!FT2GlyphSlot commentStamp: ''!
Do not rearrange these fields!!

face -- the FT2Face that owns this FT2GlyphSlot.


Note that even when the glyph image is transformed, the metrics are not.

linearHoriAdvance -- For scalable formats only, this field holds the
linearly scaled horizontal advance width for the glyph (i.e. the scaled
and unhinted value of the hori advance).  This can be important to
perform correct WYSIWYG layout.

Note that this value is expressed by default in 16.16 pixels. However,
when the glyph is loaded with the FT_LOAD_LINEAR_DESIGN flag, this field
contains simply the value of the advance in original font units.

linearVertAdvance -- For scalable formats only, this field holds the
linearly scaled vertical advance height for the glyph.  See
linearHoriAdvance for comments.

advance -- This is the transformed advance width for the glyph.

format -- This field indicates the format of the image contained in the
glyph slot.  Typically FT_GLYPH_FORMAT_BITMAP, FT_GLYPH_FORMAT_OUTLINE,
and FT_GLYPH_FORMAT_COMPOSITE, but others are possible.

bitmap -- This field is used as a bitmap descriptor when the slot format
is FT_GLYPH_FORMAT_BITMAP.  Note that the address and content of the
bitmap buffer can change between calls of @FT_Load_Glyph and a few other
functions.

bitmap_left -- This is the bitmap's left bearing expressed in integer
pixels.  Of course, this is only valid if the format is
FT_GLYPH_FORMAT_BITMAP.

bitmap_top -- This is the bitmap's top bearing expressed in integer
pixels.  Remember that this is the distance from the baseline to the
top-most glyph scanline, upwards y-coordinates being *positive*.

outline -- The outline descriptor for the current glyph image if its
format is FT_GLYPH_FORMAT_OUTLINE.

num_subglyphs -- The number of subglyphs in a composite glyph.  This
field is only valid for the composite glyph format that should normally
only be loaded with the @FT_LOAD_NO_RECURSE flag.  For now this is
internal to FreeType.

subglyphs -- An array of subglyph descriptors for composite glyphs.
There are `num_subglyphs' elements in there.  Currently internal to
FreeType.

control_data -- Certain font drivers can also return the control data
for a given glyph image (e.g.  TrueType bytecode, Type 1 charstrings,
etc.).  This field is a pointer to such data.

control_len -- This is the length in bytes of the control data.

other -- Really wicked formats can use this pointer to present their own
glyph image to client apps.  Note that the app will need to know about
the image format.

width, height, hBearingX, hBearingY, hAdvance, vBearingX, vBearingY, vAdvance 
-- The metrics of the last loaded glyph in the slot.  The
returned values depend on the last load flags (see the @FT_Load_Glyph
API function) and can be expressed either in 26.6 fractional pixels or
font units.
!
!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
hBearingY
	^hBearingY! !

!FT2GlyphSlot methodsFor: 'accessing - convenience' stamp: ''!
advance
	^advanceX@advanceY! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
bitmapLeft
	^bitmapLeft! !

!FT2GlyphSlot methodsFor: 'accessing' stamp: ''!
face: aFreeTypeFace 
	face := aFreeTypeFace! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
width
	^width! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
format
	^format! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
linearVerticalAdvance
	^linearVerticalAdvance! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
advanceX
	^advanceX! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
advanceY
	^advanceY! !

!FT2GlyphSlot methodsFor: 'accessing - convenience' stamp: ''!
extent
	^width@height! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
hBearingX
	^hBearingX! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
bitmapTop
	^bitmapTop! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
linearHorizontalAdvance
	^linearHorizontalAdvance! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
fillFromGlyphSlotRec: aGlyphRec
	linearHorizontalAdvance := aGlyphRec linearHoriAdvance.
	linearVerticalAdvance := aGlyphRec linearVertAdvance.
	advanceX := aGlyphRec advance x.
	advanceY := aGlyphRec advance y.

	format := aGlyphRec format asByteArray.

	bitmapLeft := aGlyphRec bitmap_left.
	bitmapTop := aGlyphRec bitmap_top.

	width := aGlyphRec metrics width.
	height := aGlyphRec metrics height.
	hBearingX := aGlyphRec metrics horiBearingX.
	hBearingY := aGlyphRec metrics horiBearingY.
	hAdvance := aGlyphRec metrics horiAdvance.
	vBearingX := aGlyphRec metrics vertBearingX.
	vBearingY := aGlyphRec metrics vertBearingY.
	vAdvance := aGlyphRec metrics vertAdvance! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
height
	^height! !

!FT2GlyphSlot methodsFor: 'private' stamp: ''!
loadFrom: anFT2Face
	face := anFT2Face.
	anFT2Face fillGlyph: self.
	format := ((EndianDetector isLittleEndian) ifTrue: [ format reversed ] ifFalse: [ format ]) asString.
	linearHorizontalAdvance := linearHorizontalAdvance / 65536.0.
	linearVerticalAdvance isZero ifFalse: [ linearVerticalAdvance := linearVerticalAdvance / 65536.0 ].
	advanceX := advanceX bitShift: -6.
	advanceY isZero ifFalse: [ advanceY := advanceY bitShift: -6 ].
	width := width + 63 bitShift: -6. "round up"
	height := height + 63 bitShift: -6. "round up"
	hBearingX := hBearingX bitShift: -6.
	hBearingY := hBearingY bitShift: -6.
	hAdvance := hAdvance bitShift: -6.
	vBearingX := vBearingX bitShift: -6.
	vBearingY := vBearingY bitShift: -6.
	vAdvance := vAdvance bitShift: -6.! !

!FT2GlyphSlot methodsFor: 'accessing - convenience' stamp: ''!
linearAdvance
	^"("(linearHorizontalAdvance @ linearVerticalAdvance) "* 2540) rounded"! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
outline: anOutline
	outline := anOutline! !

!FT2GlyphSlot methodsFor: 'accessing - convenience' stamp: ''!
hBearing
	^hBearingX@hBearingY! !

!FT2GlyphSlot methodsFor: 'accessing - fields' stamp: ''!
outline
	^outline! !

!FT2GlyphSlot methodsFor: 'accessing - convenience' stamp: ''!
roundedPixelLinearAdvance
	"Answer the scaled linearAdvance, rounded to whole pixels"
	^linearHorizontalAdvance  rounded @ linearVerticalAdvance rounded! !

!FT2GlyphSlot class methodsFor: 'instance creation' stamp: ''!
fromFace: anFT2Face
	^(super new)
		loadFrom: anFT2Face;
		yourself.! !

!FT2Handle commentStamp: ''!
handle holds a (typically 32-bit) pointer to an externally managed object.!
!FT2Handle methodsFor: 'initialization' stamp: ''!
initialize
	self shouldNotImplement.! !

!FT2Handle methodsFor: 'initialization' stamp: ''!
beNull
	
	^ self handle beNull! !

!FT2Handle methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ FT2FFILibrary! !

!FT2Handle methodsFor: 'printing' stamp: ''!
printOn: aStream
	| handleHex |
	super printOn: aStream.
	handle ifNil: [ ^aStream nextPutAll: '<nil>' ].
	handleHex := (handle unsignedLongAt: 1 bigEndian: EndianDetector isBigEndian) printStringHex.
	aStream nextPutAll: '<0x'; nextPutAll: handleHex; nextPut: $>.! !

!FT2Handle methodsFor: 'error handling' stamp: ''!
errorCode
	^ FT2Library current errorCode! !

!FT2Handle methodsFor: 'testing' stamp: ''!
isValid
	^ self isNull not! !

!FT2Handle methodsFor: 'error handling' stamp: ''!
errorString
	^ FT2Library current errorString! !

!FT2Handle class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting
	isImageStarting ifFalse: [ ^self ].

	"Force the correct order of initialization of FTBindings"	
	FTBitmap compileFields.
	FTBitmapSize compileFields.
	FTGeneric compileFields.
	FTBBox compileFields.
	
	FTCharMapRec compileFields.
	FTGlyphSlotRec compileFields.
	FTFaceRec compileFields.! !

!FT2Library commentStamp: ''!
This is a wrapper for the global 'library' in the plugin.
It is provided for the use of Cairo APIs that take an FT_Library argument.!
!FT2Library methodsFor: 'private - ffi' stamp: ''!
ffiNewFace: aface fromMemory: file_base size: file_size index: face_index

self ffiCall: #(int FT_New_Memory_Face(self,
                      void*  			  file_base,
                      long         file_size,
                      long         face_index,
                      PointerHolder   *aface ))! !

!FT2Library methodsFor: 'private - ffi' stamp: ''!
ffiGetBitmap: abitmap fromOutline: outline
	self
		ffiCall:
			#(FT_Error FT_Outline_Get_Bitmap (self, void* outline , void* abitmap))! !

!FT2Library methodsFor: 'private - ffi' stamp: ''!
ffiOutline: outline getBitmap: abitmap
	self
		ffiCall: #(int FT_Outline_Get_Bitmap #(self , FT_Outline * outline , FT_Bitmap * abitmap))! !

!FT2Library methodsFor: 'private - ffi' stamp: ''!
ffiDoneFace: aHandle

	self ffiCall: #(int FT_Done_Face(void* aHandle))! !

!FT2Library methodsFor: 'private' stamp: ''!
checkLibrary
	| errorCode holder |
	"I have a valid address"
	self isNull ifFalse: [ ^ self ].

	"I try to get a valid address if I do not have one"
	holder := PointerHolder new.
	errorCode := self ffiInitFreeType: holder.
	errorCode ~= 0
		ifTrue: [ FT2Error errorCode: errorCode errorString: (FT2FFILibrary translateErrorCode: errorCode) signal: 'Error initializing FreeType Library: ' ].
	self setHandle: holder value! !

!FT2Library methodsFor: 'private - ffi' stamp: ''!
ffiNewFace: aface fromFilename: filepathname index: face_index

	self ffiCall: #(int FT_New_Face(self,
               String  filepathname,
               FT_Long face_index,
               PointerHolder *aface ))! !

!FT2Library methodsFor: 'reading' stamp: ''!
getBitmap: ftBitmap fromOutline: outline 
	|returnCode|
	self checkLibrary.
	returnCode := self ffiGetBitmap: ftBitmap fromOutline: outline.
	returnCode ~= 0 ifTrue: [ FT2Error errorCode: returnCode signal: 'Error reading bitmap from outline' ].! !

!FT2Library methodsFor: 'testing' stamp: ''!
isAvailable
	[self checkLibrary] on:Error do: [^ false].
	^ self isNull not! !

!FT2Library methodsFor: 'private - ffi' stamp: ''!
ffiLibraryVersionMajor: major minor: minor patch: patch
	self ffiCall: #(void FT_Library_Version #(self , IntHolder * major , IntHolder * minor , IntHolder* patch))! !

!FT2Library methodsFor: 'ffi-calls' stamp: ''!
ffiInitFreeType: aPointer

	self ffiCall: #(int FT_Init_FreeType(PointerHolder* aPointer))! !

!FT2Library methodsFor: 'version' stamp: ''!
libraryVersion
	| version major minor patch|
	major := IntHolder new.
	minor := IntHolder new.
	patch := IntHolder new.
	
	self checkLibrary.
	self ffiLibraryVersionMajor:major minor: minor patch: patch. 
	
	version := FT2Version new.
	version major: major value.
	version minor: minor value.
	version patch: patch value.
	^ version.! !

!FT2Library class methodsFor: 'instance creation' stamp: ''!
current
	^ Current ifNil: [ Current := self basicNew ].! !

!FT2Outline commentStamp: ''!
Instance variables 
- contoursSize - The number of contours in the outline.
- pointsSize - The number of points in the outline.
- points - an array of  26.6 fixed point integer pairs giving the outline's point coordinates.
- 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: ''!
pointCollection

	^(1 to: pointsSize * 2 by: 2) collect: [ :i | ((points at: i) / 64) @ ((points at: i + 1) / 64)]! !

!FT2Outline methodsFor: 'private' stamp: ''!
primLoadSizesFrom: anFT2Face
	
	contoursSize := anFT2Face outline n_contours.
	pointsSize := anFT2Face outline n_points.! !

!FT2Outline methodsFor: 'private' stamp: ''!
allocateArrays
	" allocate the arrays for the primLoadArraysFrom:"
	points := 	IntegerArray new: pointsSize * 2.
	tags := 		ByteArray new: pointsSize.
	contours := 	ShortIntegerArray new: contoursSize.! !

!FT2Outline methodsFor: 'accessing' stamp: ''!
contoursCollection
	"returns a list of contours with tag => points list pairs"
	| allPoints result start end |
	allPoints := self pointCollection.
	
	result := OrderedCollection new.
	start := 1.
	"no normal iteration because contours size can be bigger than contourSize"
	1 to: contoursSize do: [ :i |
		end := (contours at: i) + 1. "c converion"
		result add: ((tags copyFrom: start to: end) ->  (allPoints copyFrom: start to: end)).
		start := end + 1.
	].

	^result! !

!FT2Outline methodsFor: 'private' stamp: ''!
primLoadArraysFrom: anFT2Face
	| outline contoursArray pointsArray |
	outline := anFT2Face outline.
	contoursArray := FFIExternalArray externalNewType: 'short' size: outline n_contours.
	
	1 to: outline n_contours do: [ :idx |
		contours at: 1 put: (contoursArray at: 1).	
	].

	pointsArray := FFIExternalArray externalNewType: 'int' size: outline n_points * 2.

	1 to: (outline n_points * 2) do: [ :idx |
		points at: 1 put: (pointsArray at: 1).
	].! !

!FT2Types commentStamp: ''!
I am a shared pool with all the mapping to the types used from the FreeType library.!
!FT2Types class methodsFor: 'class initialization' stamp: ''!
initialize
	"self initialize"
	IntHolder := FFIExternalValueHolder ofType: 'int'.
	PointerHolder := FFIExternalValueHolder ofType: 'void*'.
	
	FT_Error := 'long'.
	FT_Long := 'long'.
	FT_ULong := 'ulong'.
	FT_UShort := 'ushort'.
	FT_Short := 'short'.
	FT_UInt := 'uint'.
	FT_Int32 := 'int32'.
	
	FT_Pos := 'long'.
	FT_Encoding := 'int'.
	
	FT_String := 'String'.
	FT_Int := 'int'.
	FT_Bitmap_Size := 'FTBitmapSize'.
	FT_CharMap := 'FTCharMapRec*'.
	FT_Generic := 'FTGeneric'.
	FT_BBox := 'FTBBox'.
	FT_GlyphSlot := 'FTGlyphSlotRec*'.
	FT_Driver := 'void*'.
	FT_Memory := 'void*'.
	FT_Stream := 'void*'.
	FT_ListRec := 'FTListRec'.
	FT_Face_Internal := 'void*'.
	FT_Face := 'FTFaceRec*'.
	
	FT_Library := 'void*'.
	FT_Glyph_Metrics := 'FTGlyphMetrics'.
	FT_Fixed := 'long'.
	FT_Vector := 'FTVector'.
	FT_Glyph_Format := 'long'.
	FT_Bitmap := 'FTBitmap'.
	FT_Outline := 'FTOutline'.
	FT_SubGlyph := 'void*'.
	FT_Slot_Internal := 'void*'.
	FT_Size := 'FTSizeRec*'.
	FT_Size_Metrics := 'FTSizeMetrics'.
	FT_Size_Internal := 'void*'.
	
	FT_ListNode := 'void*'.
	FT_Matrix := 'FTMatrix'.! !

!FT2Version commentStamp: ''!
Do not rearrange these fields!!

This is used to report FT2 version information. Its fields must remain unchanged, or you must change FT2Plugin>>primitiveVersion.!
!FT2Version methodsFor: 'accessing' stamp: ''!
minor
	^minor! !

!FT2Version methodsFor: 'accessing' stamp: ''!
patch: anObject
	patch := anObject! !

!FT2Version methodsFor: 'accessing' stamp: ''!
major: anObject
	major := anObject! !

!FT2Version methodsFor: 'accessing' stamp: ''!
major
	^major! !

!FT2Version methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream print: major; nextPut: $.; print: minor; nextPut:$.; print: patch.! !

!FT2Version methodsFor: 'accessing' stamp: ''!
patch
	^patch! !

!FT2Version methodsFor: 'accessing' stamp: ''!
minor: anObject
	minor := anObject! !

!FT2Version class methodsFor: 'instance creation' stamp: ''!
current
	
	^ FT2Library current libraryVersion! !

!FTAbstractColumnSortingStrategy commentStamp: ''!
Description
--------------------

I am an abstract classes to define the API of FastTable column sorting strategies. 

My subclasses will implement different way to sort a FastTable.

I am linked to a FTColumn implementing the Strategy design pattern.

Public API and Key Messages
--------------------

- #isSortingEnable 		Return a boolean to know if the sorting through this column is currently enabled.
- #sortDatasource: 		Sort a datasource depending on my state. This behavior will be defined by my subclasses.
- #sortingIcon 				Return an icon that can be displayed in the header cell to indicated in which state we are.
	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	column:		<aFTColumn>	 The column using me to sort its table.
!
!FTAbstractColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
morphicIconNamed: aString
	^ (self iconNamed: aString) asMorph! !

!FTAbstractColumnSortingStrategy methodsFor: 'testing' stamp: ''!
isSortingEnabled
	^ true! !

!FTAbstractColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
column
	^ column! !

!FTAbstractColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
column: anObject
	column := anObject! !

!FTAbstractColumnSortingStrategy methodsFor: 'sorting' stamp: ''!
sortDataSource: aDataSource
	self subclassResponsibility! !

!FTAbstractColumnSortingStrategy methodsFor: 'initialization' stamp: ''!
reset
	self subclassResponsibility! !

!FTAbstractColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
sortingIcon
	^ self subclassResponsibility! !

!FTAbstractColumnSortingStrategy class methodsFor: 'accessing' stamp: ''!
column: aColumn
	^ self new
		column: aColumn;
		yourself! !

!FTAbstractColumnSortingStrategyTest commentStamp: ''!
A FTAbstractColumnSortingStrategyTest is a test class for testing the behavior of FTAbstractColumnSortingStrategy!
!FTAbstractColumnSortingStrategyTest methodsFor: 'helpers' stamp: ''!
dataSourceForTesting
	^ FTTableMorph new
		dataSource: (FTSimpleDataSource elements: self elementsForTestDataSource);
		dataSource! !

!FTAbstractColumnSortingStrategyTest methodsFor: 'helpers' stamp: ''!
elementsForTestDataSource
	^ #(2 4 7 1 5 8 6 9 10 3)! !

!FTAbstractColumnSortingStrategyTest methodsFor: 'tests' stamp: ''!
testSortDataSource
	self subclassResponsibility! !

!FTAbstractColumnSortingStrategyTest methodsFor: 'accessing' stamp: ''!
actualClass
	self subclassResponsibility! !

!FTAbstractColumnSortingStrategyTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	strategy := self actualClass column: FTColumn new! !

!FTAbstractColumnSortingStrategyTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!FTAbstractColumnSortingStrategyTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = FTAbstractColumnSortingStrategyTest! !

!FTAbstractSortingState commentStamp: ''!
Description
--------------------

I am an abstract class defining the API of a sorting state.

I'll manage the behavior of a aTSortingStrategyWithState subclasses using me that is related to its state.	
	
I follow the State design pattern.
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	context:		<aTSortingStrategyWithState>	The context I am the state of.
!
!FTAbstractSortingState methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!FTAbstractSortingState methodsFor: 'sorting' stamp: ''!
executeSortingOn: aDataSource
	self subclassResponsibility! !

!FTAbstractSortingState methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!FTAbstractSortingState methodsFor: 'sorting' stamp: ''!
sort: aDataSource
	| nextState |
	nextState := self nextState.
	self context state: nextState.
	nextState executeSortingOn: aDataSource! !

!FTAbstractSortingState methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
isSorted 
	^ true! !

!FTAbstractSortingState methodsFor: 'accessing' stamp: ''!
nextState
	^ self subclassResponsibility! !

!FTAbstractSortingState methodsFor: 'accessing' stamp: ''!
sortingIcon
	^ self subclassResponsibility! !

!FTAbstractSortingState class methodsFor: 'instance creation' stamp: ''!
context: aContext
	^ self new
		context: aContext;
		yourself! !

!FTAbstractSortingStateTest commentStamp: ''!
A FTAbstractSortingStateTest is a test class for testing the behavior of FTAbstractSortingState!
!FTAbstractSortingStateTest methodsFor: 'helpers' stamp: ''!
dataSourceForTesting
	^ FTTableMorph new
		dataSource: (FTSimpleDataSource elements: self elementsForTestDataSource);
		dataSource! !

!FTAbstractSortingStateTest methodsFor: 'helpers' stamp: ''!
elementsForTestDataSource
	^ #(2 4 7 1 5 8 6 9 10 3)! !

!FTAbstractSortingStateTest methodsFor: 'tests' stamp: ''!
testSort
	| dataSource |
	dataSource := self dataSourceForTesting.
	self assert: state context state equals: state.
	state sort: dataSource.
	self deny: state context state equals: state! !

!FTAbstractSortingStateTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ self subclassResponsibility! !

!FTAbstractSortingStateTest methodsFor: 'tests' stamp: ''!
testExecuteSortingOn
	self subclassResponsibility! !

!FTAbstractSortingStateTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	state := self actualClass
		context:
			(FTPropertyColumnSortingStrategy new
				property: #yourself;
				yourself).
	state context state: state! !

!FTAbstractSortingStateTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!FTAbstractSortingStateTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = FTAbstractSortingStateTest! !

!FTActionFilterFunction commentStamp: ''!
I am a Filter widget that also have an action button.

Description
-------------------------------------------------
I am use as a FilterFunction but I also have a Button. I am use by FTTableMorph.

Public API and Key Messages
-------------------------------------------------

- #table: aTableMorph action: aBlock named: aString
	is my constructor. The block is the action to be executed by the button and the string is the name of the button.
	

Internal Representation and Key Implementation Points.
-------------------------------------------------

    Instance Variables
	actionBlock:		I am a block that need to be executed when the user press the button
	actionButton:		I am the button of the widget

The action block can takes 3 parameters:
- The filtered data source
- The pattern on the filter field 
- The selected element on the table!
!FTActionFilterFunction methodsFor: 'private' stamp: ''!
resizeField
	| topLeft bottomRight |
	self flag: #pharoTodo.	"Maybe it could be cool to let the user choose if the field need to be at the top or the bottom."
	topLeft := table bounds left @ (table bounds bottom - self fieldHeigh - table horizontalScrollBarHeight).
	bottomRight := (table bounds right - table verticalScrollBarWidth - (actionButton width + 5))
		@ (table bottom - table horizontalScrollBarHeight).
	field bounds: (topLeft corner: bottomRight)! !

!FTActionFilterFunction methodsFor: 'accessing' stamp: ''!
showWidget
	super showWidget.
	table addMorph: actionButton.
	table selectedIndex = 0 ifTrue: [ table selectIndex: 1 ]! !

!FTActionFilterFunction methodsFor: 'option' stamp: ''!
action: aBlockClosure named: aString
	actionBlock := aBlockClosure.
	self initializeActionButtonNamed: aString! !

!FTActionFilterFunction methodsFor: 'initialization' stamp: ''!
initializeActionButtonNamed: aString
	actionButton := PluggableButtonMorph
		newButtonFor: self
		action: #execute
		label: aString
		help: nil! !

!FTActionFilterFunction methodsFor: 'execute' stamp: ''!
execute
	actionBlock
		cull: table dataSource
		cull: field getTextFromModel asString
		cull:
			(table selectedIndex = 0
				ifFalse: [ table dataSource realElementAt: table selectedIndex ]
				ifTrue: [ nil ])! !

!FTActionFilterFunction methodsFor: 'private' stamp: ''!
resizeButton
	| topLeft bottomRight |
	self flag: #pharoTodo.	"Maybe it could be cool to let the user choose if the field need to be at the top or the bottom."
	bottomRight := (table bounds right - table verticalScrollBarWidth) @ (table bottom - table horizontalScrollBarHeight).
	topLeft := (bottomRight x - actionButton width) @ (table bounds bottom - self fieldHeigh - table horizontalScrollBarHeight).
	actionButton bounds: (topLeft corner: bottomRight)! !

!FTActionFilterFunction methodsFor: 'accessing' stamp: ''!
beExplicit
	super beExplicit.
	table addMorph: actionButton.
	table selectedIndex = 0
		ifTrue: [ table selectIndex: 1 ]! !

!FTActionFilterFunction methodsFor: 'private' stamp: ''!
resizeWidget
	self resizeField.
	self resizeButton! !

!FTActionFilterFunction class methodsFor: 'instance creation' stamp: ''!
table: aFTTableMorph action: aBlockClosure named: aString
	^ (self table: aFTTableMorph)
		action: aBlockClosure named: aString;
		yourself! !

!FTAllItemsStrategy commentStamp: ''!
I am a Strategy that will use the function on all the tree.
BE CAREFUL, do NOT use me if you are not sur that your tree is finish. If a branch is infinite I will go in an infinite loop.
 If you are sure about it, use this otherwise use other search strategies. 

Description
-----------------------

I will search in every item of the tree and I needed I will expand the items to show the results of the function.
As said in my superclass I am use by a FTTreeDataSource to help with a FTFunction.

Public API and Key Messages
-----------------------

- #realSearch 	is the method that will launch the search.

Example
-----------------------

	| ds |
	ds := FTTreeDataSource
		roots:
			((ProtoObject allSubclasses sort: [ :a :b | a asString < b asString ])
				reject: [ :e | e asString endsWith: 'class' ])
		children: [ :item | item subclasses sort: [ :a :b | a asString < b asString ] ].
	ds searchStrategy: #allItems. "This will say to the FTTreeDataSource to use me."
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		explicitFunction;
		openInWindow
 
Internal Representation and Key Implementation Points.
-----------------------

    Instance Variables
	index:		I am the index of tfe elements I am testing now. 
	result:		I am a collection of index that is the result of the search.
!
!FTAllItemsStrategy methodsFor: 'action' stamp: ''!
unexpandAllChildOf: anItem
	anItem children
		do: [ :item | 
			item isExpanded
				ifTrue: [ self unexpandAllChildOf: item ].
			item collapse ]  displayingProgress: [:each | 'Rearanging ' , each name]! !

!FTAllItemsStrategy methodsFor: 'action' stamp: ''!
matchingFilter: anItem
	((anItem children collect: [ :it | self matchingFilter: it ]) reject: #isNil)
		ifNotEmpty:
			[ :coll | 
			^ (self newStaticItemFrom: anItem)
				children: coll asArray;
				dataSource: anItem dataSource;
				expandWithoutChange;
				yourself ].
	^ (pattern matchesIn: (self dataSource toString: anItem)) ifEmpty: [ nil ] ifNotEmpty: [ self newStaticItemFrom: anItem ]! !

!FTAllItemsStrategy methodsFor: 'action' stamp: ''!
filter
	| items |
	items := OrderedCollection new.
	dataSource rootsItems do: [ :item | (self matchingFilter: item) ifNotNil: [ :itemNew | items add: itemNew ] ] displayingProgress: [ :each | 'Looking inside ' , each printString ].
	dataSource table selectIndex: 1.
	^ dataSource class
		root:
			(FTRootItem new
				children: items asArray;
				yourself)
		children: dataSource childrenBlock! !

!FTAllItemsStrategy methodsFor: 'action' stamp: ''!
searchIn: item
	| selfOrChildMatch |
	selfOrChildMatch := false.
	(self isMatching: item)
		ifTrue: [ result add: index.
			selfOrChildMatch := true ].
	index := index + 1.
	(item hasChildren and: [ dataSource canDisplayChildrenOf: item ])
		ifTrue:
			[ | itemIndex |
			itemIndex := index.	"I save this index because if there is no match inside this item I should not expand it."
			(item children select: [ :child | self searchIn: child ])
				ifNotEmpty: [ selfOrChildMatch := true.
					item expand ]
				ifEmpty: [ item collapse.
					index := itemIndex ] ].
	^ selfOrChildMatch! !

!FTAllItemsStrategy methodsFor: 'action' stamp: ''!
initializeNewSearch
	result := OrderedCollection new.
	index := 1! !

!FTAllItemsStrategy methodsFor: 'action' stamp: ''!
newStaticItemFrom: anItem
	^ FTStaticBasicItem new
		data: anItem data;
		depth: anItem depth;
		children: #();
		yourself! !

!FTAllItemsStrategy methodsFor: 'action' stamp: ''!
realSearch
	self initializeNewSearch.
	dataSource rootsItems do: [ :item | self searchIn: item ] displayingProgress: [ :each | 'Looking inside ' , each name ].
	^ result asArray! !

!FTAllItemsStrategy methodsFor: 'action' stamp: ''!
optionalOperations
	^ pattern isEmptyOrNil
		ifTrue: [ self unexpandAllChildOf: dataSource rootItem.
			#() ]
		ifFalse: [ nil ]! !

!FTAnnouncement commentStamp: ''!
I'm a base announcement for FastTable announces.!
!FTAnnouncement methodsFor: 'accessing' stamp: ''!
fastTable: aFastTable
	fastTable := aFastTable! !

!FTAnnouncement methodsFor: 'accessing' stamp: ''!
fastTable
	^ fastTable! !

!FTArrayIndexColumn commentStamp: ''!
I am a fast table column to represent item in array at particular index.
 
Internal Representation and Key Implementation Points.

This class has and extends API of FTColumn

    Instance Variables
	id:			An id for the column
	width:		An Integer that represent the width of a column.
	index:		<Number>!
!FTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
width: anObject
	width := anObject! !

!FTArrayIndexColumn methodsFor: 'layout' stamp: ''!
acquireWidth: anOwnerWidth
	^ self widthOrUndefined min: anOwnerWidth! !

!FTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!FTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
id: anObject
	id := anObject! !

!FTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
transform: anArray
	^ anArray at: self index! !

!FTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
index: anObject
	index := anObject! !

!FTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!FTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
widthOrUndefined
	^ self width ifNil: [ self class undefinedColumnWidth ]! !

!FTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!FTArrayIndexColumn class methodsFor: 'instance creation' stamp: ''!
id: anObject
	^ self new
		id: anObject;
		yourself! !

!FTArrayIndexColumn class methodsFor: 'instance creation' stamp: ''!
index: aNumber width: aNumber2
	^ (self index: aNumber) 
		width: aNumber2! !

!FTArrayIndexColumn class methodsFor: 'accessing' stamp: ''!
undefinedColumnWidth
	"This is a constant that defines a column width is undefined, then the layout will try to arrange 
	 it by itself."
	^ 0! !

!FTArrayIndexColumn class methodsFor: 'instance creation' stamp: ''!
index: aNumber
	^ self new 
		index: aNumber! !

!FTAscendingSortingState commentStamp: ''!
Description
--------------------

I am a sorting state for ascending sorted table.!
!FTAscendingSortingState methodsFor: 'sorting' stamp: ''!
executeSortingOn: aDataSource
	aDataSource sortWith: self context ascendingSortFunction! !

!FTAscendingSortingState methodsFor: 'accessing' stamp: ''!
nextState
	^ FTDescendingSortingState context: self context! !

!FTAscendingSortingState methodsFor: 'accessing' stamp: ''!
sortingIcon
	^ self context morphicIconNamed: #arrowUp! !

!FTAscendingSortingStateTest commentStamp: ''!
A FTAscendingSortingStateTest is a test class for testing the behavior of FTAscendingSortingState!
!FTAscendingSortingStateTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ FTAscendingSortingState! !

!FTAscendingSortingStateTest methodsFor: 'tests' stamp: ''!
testExecuteSortingOn
	| dataSource |
	dataSource := self dataSourceForTesting.
	state executeSortingOn: dataSource.
	self assert: dataSource elements equals: #(1 2 3 4 5 6 7 8 9 10).
	state executeSortingOn: dataSource.
	self assert: dataSource elements equals: #(1 2 3 4 5 6 7 8 9 10).! !

!FTBBox commentStamp: ''!
I represent the FT_BBox type!
!FTBBox methodsFor: 'accessing - structure variables' stamp: ''!
xMin: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_XMIN put: anObject! !

!FTBBox methodsFor: 'accessing - structure variables' stamp: ''!
xMax
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_XMAX! !

!FTBBox methodsFor: 'accessing - structure variables' stamp: ''!
yMin
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_YMIN! !

!FTBBox methodsFor: 'accessing - structure variables' stamp: ''!
yMin: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_YMIN put: anObject! !

!FTBBox methodsFor: 'accessing - structure variables' stamp: ''!
yMax
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_YMAX! !

!FTBBox methodsFor: 'accessing - structure variables' stamp: ''!
xMax: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_XMAX put: anObject! !

!FTBBox methodsFor: 'accessing - structure variables' stamp: ''!
xMin
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_XMIN! !

!FTBBox methodsFor: 'accessing - structure variables' stamp: ''!
yMax: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_YMAX put: anObject! !

!FTBBox class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
	 FT_Pos  xMin;
	 FT_Pos  yMin;
    FT_Pos  xMax; 
	 FT_Pos  yMax;
)! !

!FTBasicItem commentStamp: ''!
I am an Item of a tree that keep a data and know how to calculate the children of this data for a Fast Tree.

Description
-------------------------------------------------

I am created by a FTTreeDataSource or a FTItem and I hold a data. I can use a childrenBlock from my dataSource to generate the children of my data.
Myself I use some FTBasicItems to creale my children.
I also know how to generate a button for a FTTreeDataSource if needed. This button can be use to extand or unextand me.

Public API and Key Messages
-------------------------------------------------

- #expand/#unexpand
        Allow to expand me or unexpand me and update the Tree.. 
   
- #depth
        Return my depth in the tree.

Create me as as my superclass with an object as data.

Example
-------------------------------------------------

(FTBasicItem data: Object from: (FTTreeDataSource roots: {} children: [ :item | item subclasses ]))
		depth: 2;
		yourself
 
Internal Representation and Key Implementation Points.
-------------------------------------------------

    Instance Variables
	data:		I am an object hold by the item.
	depth:		I am the depth of the Item on the tree.
	isExpanded:		I am a Boolean that remember if I am expanded or not.
	recentlyChanged: 		I am a boolean that return true fi the item was really recently collapsed/expanded. Don't play with me, I am use to update the selection when we collapse/expand an item.
			
I calculate my children with a block that is inside my dataSource. I execute this block with my data, the roots items of the dataSource and my level as arguments.!
!FTBasicItem methodsFor: '*Iceberg-TipUI' stamp: ''!
toggle
	self isExpanded
		ifTrue: [ self collapseAndRefresh ]
		ifFalse: [ self expandAndRefresh ]! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
data: anObject
	data := anObject! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
children
	"I use a cache because my children can be call often."

	^ children ifNil: [ children := self calculateChildren ]! !

!FTBasicItem methodsFor: 'button' stamp: ''!
expandedButton
	^ IconicButtonMorph new
		target: self;
		actionSelector: #collapseAndRefresh;
		arguments: {};
		labelGraphic: self class expandedForm;
		color: Color transparent;
		helpText: 'Unexpand Item';
		borderWidth: 0! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
isExpanded
	^ isExpanded! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
depth
	^ depth ifNil: [ depth := 0 ]! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
isRootItem
	^ self depth = 0! !

!FTBasicItem methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $[;
		nextPutAll: (self dataSource toString: data);
		nextPut: $]! !

!FTBasicItem methodsFor: 'private' stamp: ''!
expandWithoutChange
	"I exist because in some rare case it's hard to keep the selection during the expension so I just expand myself don't update the selection :("

	isExpanded := true! !

!FTBasicItem methodsFor: 'expanding-collapsing' stamp: ''!
expand
	"I do not refresh the table. Use expandAndRefresh for that. I also do not 
	ensure that any selected element is visible after expanding the element."

	isExpanded := true.
	recentlyChanged := true.
	self dataSource
		updateSelectionWithCollectBlock: [ :indexOfCurrentSelection :indexOfCollapsedElement |
			indexOfCurrentSelection <= indexOfCollapsedElement 
				ifTrue: [ indexOfCurrentSelection ]
				ifFalse: [ indexOfCurrentSelection + self numberOfVisibleChildren ] ]! !

!FTBasicItem methodsFor: 'updating' stamp: ''!
refreshTable
	dataSource tableRefresh.
	dataSource table resetFunction! !

!FTBasicItem methodsFor: 'updating' stamp: ''!
updateData
	children := nil! !

!FTBasicItem methodsFor: 'button' stamp: ''!
collpasedButton
	^ IconicButtonMorph new
		target: self;
		actionSelector: #expandAndRefresh;
		arguments: {};
		labelGraphic: self class unexpandedForm;
		color: Color transparent;
		helpText: 'Expand Item';
		borderWidth: 0! !

!FTBasicItem methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
hasComputedChildren
	"I return true if I have computed children or if I don't have computed children."

	^ children ifNil: [ true ] ifNotNil: [ super hasComputedChildren ]! !

!FTBasicItem methodsFor: 'button' stamp: ''!
generateButton
	^ isExpanded
		ifTrue: [ self expandedButton ]
		ifFalse: [ self collpasedButton ]! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
getChildren
	^ dataSource childrenBlock isSymbol
		ifTrue: [ dataSource childrenBlock value: data ]
		ifFalse: [ dataSource childrenBlock cull: data cull: self ]! !

!FTBasicItem methodsFor: 'expanding-collapsing' stamp: ''!
collapseAll
	self children do: #collapseAll.
	self collapse! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
recentlyChanged
	"Since I must be true only if I collapsed recently, I change to false if someone get me."

	^ recentlyChanged
		ifFalse: [ false ]
		ifTrue: [ recentlyChanged := false.
			true ]! !

!FTBasicItem methodsFor: 'expanding-collapsing' stamp: ''!
expandAll
	self expand.
	self children do: #expandAll! !

!FTBasicItem methodsFor: 'initialization' stamp: ''!
initialize
	isExpanded := false.
	recentlyChanged := false! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
withExpandedChildren
	^ {self} , self expandedChildren! !

!FTBasicItem methodsFor: 'expanding-collapsing' stamp: ''!
collapse
	"I do not refresh the table. Use collapseAndRefresh for that. I also do not 
	ensure that any selected element is visible after collapsing the element.
	If any selected elements are within the childrens of the collapsed element,
	I select the collapsed element."

	self isExpanded ifFalse: [ ^ self ].
	
	recentlyChanged := true.
	self dataSource
		updateSelectionWithCollectBlock:
			[ :indexOfCurrentSelection :indexOfCollapsedElement | 
			| changedBy |
			changedBy := self numberOfVisibleChildren.
			(indexOfCurrentSelection between: indexOfCollapsedElement and: indexOfCollapsedElement + changedBy)
				ifTrue: [ indexOfCollapsedElement ]
				ifFalse: [ indexOfCurrentSelection < indexOfCollapsedElement
						ifTrue: [ indexOfCurrentSelection ]
						ifFalse: [ indexOfCurrentSelection - changedBy ] ] ].
	isExpanded := false! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
data
	^ data! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
depth: anObject
	depth := anObject! !

!FTBasicItem methodsFor: 'expanding-collapsing' stamp: ''!
expandAllTo: aDepth
	self expand.
	aDepth > self depth
		ifTrue: [ self children do: [ :each | each expandAllTo: aDepth ] ]! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
expandedChildren
	self isExpanded ifFalse: [ ^ {} ].
	^ self children flatCollect: #withExpandedChildren! !

!FTBasicItem methodsFor: 'expanding-collapsing' stamp: ''!
collapseAndRefresh
	self collapse.
	self refreshTable! !

!FTBasicItem methodsFor: 'expanding-collapsing' stamp: ''!
expandAndRefresh
	self expand.
	self refreshTable! !

!FTBasicItem methodsFor: 'accessing' stamp: ''!
calculateChildren
	^ self getChildren
		collect: [ :elem | 
			(self class data: elem from: dataSource)
				depth: self depth + 1;
				yourself ]! !

!FTBasicItem class methodsFor: 'expanding-collapsing' stamp: ''!
unexpandedForm
	^ self theme treeUnexpandedForm! !

!FTBasicItem class methodsFor: 'expanding-collapsing' stamp: ''!
expandedForm
	^ self theme treeExpandedForm! !

!FTBasicItem class methodsFor: 'accessing' stamp: ''!
theme
	^ Smalltalk ui theme! !

!FTBasicTreeListDataSource commentStamp: ''!
Simple tree list data source.

For example usage see methods on the class side under the protocol "examples". 

!
!FTBasicTreeListDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
	| item |
	
	"this is a bad way for tree; maybe list too. the morph should ask for the full collection from index start to n elements. 
	eps when elementAt: must traverse the tree to find each element: not only a basic at:
	"
	item := self elementAt: rowIndex.

	^item cellMorphFor: self.! !

!FTBasicTreeListDataSource methodsFor: 'accessing' stamp: ''!
childrenBlock

	^childrenBlock! !

!FTBasicTreeListDataSource methodsFor: 'accessing' stamp: ''!
displayBlock

	^displayBlock! !

!FTBasicTreeListDataSource methodsFor: 'private' stamp: ''!
elementAt: index
	| curr b |
	
	curr := 0.

	b := nil.
	b := [ :p | p do: [ :each | (curr := curr + 1) = index ifTrue: [ ^each ] ifFalse: [ b value: each children ] ] ].
	
	b value: rootItems.

	SubscriptOutOfBounds signal: index.! !

!FTBasicTreeListDataSource methodsFor: 'expanding-collapsing' stamp: ''!
expandAll

	self expand: SmallInteger maxVal! !

!FTBasicTreeListDataSource methodsFor: 'private' stamp: ''!
tableRefresh
	table ifNotNil: [ table refresh ]! !

!FTBasicTreeListDataSource methodsFor: 'construction' stamp: ''!
display: aBlock

	"aBlock -> [ :item :cell | cell addMorphBack: ... ]"

	displayBlock := aBlock! !

!FTBasicTreeListDataSource methodsFor: 'accessing' stamp: ''!
numberOfRows
	
	^availableRows! !

!FTBasicTreeListDataSource methodsFor: 'construction' stamp: ''!
children: aBlock

	"aBlock -> [ :item | aCollection ]"

	childrenBlock := aBlock! !

!FTBasicTreeListDataSource methodsFor: 'accessing' stamp: ''!
childrenFor: anItem
	
	| children |
	
	children := (childrenBlock value: anItem).
	
	^sortingBlock ifNil: [ children ] ifNotNil: [ children sort: sortingBlock ]! !

!FTBasicTreeListDataSource methodsFor: 'construction' stamp: ''!
root: anObject

	self roots: { anObject }! !

!FTBasicTreeListDataSource methodsFor: 'expanding-collapsing' stamp: ''!
expand: aNumber

	rootItems do: [ :each | each expandToDepth: aNumber ].! !

!FTBasicTreeListDataSource methodsFor: 'construction' stamp: ''!
sortChildrenBy: aBlock

	"aBLock -> [ :a :b | a something <= b something ] "

	sortingBlock := aBlock! !

!FTBasicTreeListDataSource methodsFor: 'private' stamp: ''!
updateAvailableRows: aNumber
	
	
	availableRows := availableRows + aNumber.

	aNumber isZero ifFalse: [ self tableRefresh ].! !

!FTBasicTreeListDataSource methodsFor: 'private' stamp: ''!
countAvailableRows

	availableRows := rootItems inject: 0 into: [ :sum :item | sum + item availableRows ]! !

!FTBasicTreeListDataSource methodsFor: 'construction' stamp: ''!
roots: aCollection

	rootItems := aCollection collect: [ :each | 
			FTBasicTreeListItem new 
				item: each;
				datasource: self
	].  

	self countAvailableRows! !

!FTBasicTreeListDataSource class methodsFor: 'examples' stamp: ''!
exampleProtoObjectClassTree

	| ds ft |

	ds := FTBasicTreeListDataSource new 
		root: ProtoObject;
		children: [ :item | item subclasses ];
		sortChildrenBy: [ :a :b | a name <= b name ];
		display: [ :item :cell | cell addMorphBack: item printString asMorph ];
		yourself.

	ft := FTTableMorph new 
		extent: 200@200;
		dataSource: ds.
	
	ft openInWindow position: 20@10! !

!FTBasicTreeListDataSource class methodsFor: 'examples' stamp: ''!
exampleInspect: anObject
	<sampleInstance>

	| ds ft |

	ds := FTBasicTreeListDataSource new .
	
	ds	root: #ROOT->anObject;
		children: [ :item | item value gtInspectorVariableValuePairs ];
		sortChildrenBy: [ :a :b | a key asString <= b key asString ];
		display: [ :item :cell | cell 
			addMorphBack: item value class systemIcon asMorph;
			addMorphBack: (item key asStringMorph emphasis: 1; yourself);
			addMorphBack: (Morph new color: Color transparent; height: 1; width: 10; yourself);
			addMorphBack: item value asStringMorph ];
		yourself.
	
	ds expand: 1.
	
	ft := FTTableMorph new 
		extent: 800@500;
		dataSource: ds.
	
	ft openInWindow position: 20@10.
	
	^ds! !

!FTBasicTreeListDataSource class methodsFor: 'examples' stamp: ''!
exampleSomeClassesSubclassesTree

	| ds ft |

	ds := FTBasicTreeListDataSource new 
		roots: { FTDataSource . String . Boolean } ;
		children: [ :item | item subclasses ];
		sortChildrenBy: [ :a :b | a methods size <= b methods size ];
		display: [ :item :cell | cell addMorphBack: (item name asString , ' (' , item methods size asString , ')') asMorph ];
		yourself.

	ft := FTTableMorph new 
		extent: 200@200;
		dataSource: ds.
	
	ft openInWindow position: 20@10! !

!FTBasicTreeListDataSource class methodsFor: 'examples' stamp: ''!
exampleBasicInspect: anObject
	<sampleInstance>

	| ds ft |

	ds := FTBasicTreeListDataSource new .
	
	ds	root: #ROOT->anObject;
		children: [ :item | item value gtInspectorVariableValuePairs ];
		sortChildrenBy: [ :a :b | a key asString <= b key asString ];
		display: [ :item :cell | cell addMorphBack: item printString asMorph ];
		yourself.
	
	ft := FTTableMorph new 
		extent: 600@500;
		dataSource: ds.
	
	ft openInWindow position: 20@10.
	
	^ds! !

!FTBasicTreeListDataSource class methodsFor: 'examples' stamp: ''!
exampleWorldSubmorphTree

	| ds ft |

	ds := FTBasicTreeListDataSource new 
		root: self currentWorld;
		children: [ :item | item submorphs ];
		expand: 2;
		display: [ :item :cell | cell addMorphBack: item printString asMorph ];
		yourself.

	ft := FTTableMorph new 
		extent: 400@500;
		dataSource: ds.
	
	ft openInWindow position: 20@10! !

!FTBasicTreeListDataSource class methodsFor: 'examples' stamp: ''!
exampleStateTree

	| ds ft |

	ds := FTBasicTreeListDataSource new .
	
	ds	roots: { #self -> ds } ;
		children: [ :item | item value gtInspectorVariableValuePairs ];
		sortChildrenBy: [ :a :b | a key asString <= b key asString ];
		display: [ :item :cell | cell 
			addMorphBack: item value systemIcon asMorph;
			addMorphBack: (item key printString asMorph emphasis: 1; yourself);
			addMorphBack: (Morph new color: Color transparent; height: 1; width: 10; yourself);
			addMorphBack: (item value printString) asMorph ];
		yourself.
		
	ds expand: 3.
	
	ft := FTTableMorph new 
		extent: 600@500;
		dataSource: ds.
	
	ft openInWindow position: 20@10! !

!FTBasicTreeListItem commentStamp: ''!
FTBasicTreeListItem holds the state of a element in FTBasicTreeListDataSource.

Instance variables: 

|< expanded >|< Private  >|< aBoolean >[ 
	remembers if this it is currently expanded or not.
}.

|< depth >|< Private  >|< aNumber >[
	The depth of this item from the root.
 ].

< item > [  anyObject. 
	The raw item which is wrapped by this class.	
].

< children > [ aCollection.
	cache for holding currently expaned children
 ].

< dataSource > [ aFBasicTreeListDataSource
	reference to the datasource
 ].!
!FTBasicTreeListItem methodsFor: 'button-interaction' stamp: ''!
treeItemFor: anItem

	^FTBasicTreeListItem new 
		datasource: dataSource;
		depth: depth + 1;
		item: anItem! !

!FTBasicTreeListItem methodsFor: 'interaction' stamp: ''!
expandToDepth: aNumber
	
	depth = aNumber ifTrue: [ ^self ].
	
	self expandItem.
	
	children do: [ :each | each expandToDepth: aNumber ].! !

!FTBasicTreeListItem methodsFor: 'initialization' stamp: ''!
initialize

	expanded := false.
	depth := 0.
	children := #()! !

!FTBasicTreeListItem methodsFor: 'accessing' stamp: ''!
cellMorphFor: aDataSource

	| morph |
	
	morph := FTIndentedCellMorph new.
	morph depthIndent: depth.
	
	self hasChildren 
		ifTrue: [ morph addMorphBack: self generateButton ]
		ifFalse: [ morph addIndendtation: 15 ].
	
	dataSource displayBlock value: item value: morph.
	
	^morph! !

!FTBasicTreeListItem methodsFor: 'querying' stamp: ''!
availableRows

	^expanded ifTrue: [ 
		children
			inject: 1 
			into: [ :sum :each | sum + each availableRows ] 
			
	] ifFalse: [ 1 ]! !

!FTBasicTreeListItem methodsFor: 'accessing' stamp: ''!
children

	^children! !

!FTBasicTreeListItem methodsFor: 'button' stamp: ''!
collapsedButton

	^self defaultButton
		actionSelector: #expandItem;
		labelGraphic: Smalltalk ui theme treeUnexpandedForm;
		helpText: 'Expand Item';
		yourself! !

!FTBasicTreeListItem methodsFor: 'button' stamp: ''!
expandedButton

	^self defaultButton
		actionSelector: #collapseItem;
		labelGraphic: Smalltalk ui theme treeExpandedForm;
		helpText: 'Collapse Item';
		yourself! !

!FTBasicTreeListItem methodsFor: 'querying' stamp: ''!
hasChildren

	^(dataSource childrenBlock value: item) isNotEmpty! !

!FTBasicTreeListItem methodsFor: 'button-interaction' stamp: ''!
expandItem

	expanded := true.
	
	children := (dataSource childrenFor: item) collect: [ :each | self treeItemFor: each ].
	
	dataSource updateAvailableRows: self availableRows - 1.! !

!FTBasicTreeListItem methodsFor: 'construction' stamp: ''!
item: anItem

	item := anItem! !

!FTBasicTreeListItem methodsFor: 'button-interaction' stamp: ''!
collapseItem

	dataSource updateAvailableRows: 1 - self availableRows.
	
	children := #().
	
	expanded := false.! !

!FTBasicTreeListItem methodsFor: 'construction' stamp: ''!
depth: aNumber

	depth := aNumber! !

!FTBasicTreeListItem methodsFor: 'button' stamp: ''!
defaultButton

	^IconicButtonMorph new
		target: self;
		color: Color transparent;
		borderWidth: 0;
		yourself.! !

!FTBasicTreeListItem methodsFor: 'button' stamp: ''!
generateButton
	^expanded 
		ifTrue: [ self expandedButton ]
		ifFalse: [ self collapsedButton ]! !

!FTBasicTreeListItem methodsFor: 'construction' stamp: ''!
datasource: aDS

	dataSource := aDS! !

!FTBasicTreeListItem methodsFor: 'accessing' stamp: ''!
item

	^item! !

!FTBitmap commentStamp: ''!
I represent the FT_Bitmap type!
!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
palette_mode: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PALETTE_MODE put: anObject! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
width: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WIDTH put: anObject! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
width
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WIDTH! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
buffer: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_BUFFER put: anObject getHandle.! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
palette
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PALETTE) type: ExternalType void asPointerType! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
pitch
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PITCH! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
palette: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PALETTE put: anObject getHandle.! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
rows: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_ROWS put: anObject! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
setBuffer: anAddress
	handle pointerAt: OFFSET_BUFFER put: anAddress! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
num_grays
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_NUM_GRAYS! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
pixel_mode
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PIXEL_MODE! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
pixel_mode: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PIXEL_MODE put: anObject! !

!FTBitmap methodsFor: 'initialization' stamp: ''!
initializeFromForm: aForm pixelMode: pixelMode
	| bitmapHeight width depth wordsPerRow numGrays pitch pixelModeToUse |
	self width: aForm width.
	bitmapHeight := aForm height.

	width := aForm width.
	depth := aForm depth.

	depth < 0
		ifTrue: [ depth := depth * -1 ].
	depth = 1
		ifTrue: [ wordsPerRow := ((width + 16r1F) / 32) floor.
			numGrays := 1 ]
		ifFalse: [ depth = 8
				ifFalse: [ self error: 'Invalid depth' ].
			wordsPerRow := ((width + 3) / 4) floor.
			numGrays := 256 ].

	"aForm depth: depth."

	pixelMode
		ifNil: [ depth = 1
				ifTrue: [ pixelModeToUse := 1	"FT_PIXEL_MODE_MONO" ]
				ifFalse: [ pixelModeToUse := 2	"FT_PIXEL_MODE_GRAY" ] ]
		ifNotNil: [ pixelModeToUse := pixelMode ].

	pitch := wordsPerRow * 4.
	self rows: bitmapHeight.
	self width: width.
	self pitch: pitch.
	self num_grays: numGrays.
	self pixel_mode: pixelModeToUse! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
buffer
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_BUFFER) type: ExternalType void asPointerType! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
pitch: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PITCH put: anObject! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
rows
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_ROWS! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
palette_mode
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PALETTE_MODE! !

!FTBitmap methodsFor: 'accessing - structure variables' stamp: ''!
num_grays: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_NUM_GRAYS put: anObject! !

!FTBitmap class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
    uint   rows;
    uint   width;
    int    pitch;
    void*  buffer;
    ushort num_grays;
    uchar  pixel_mode;
    uchar  palette_mode;
    void*  palette;	
)! !

!FTBitmapSize commentStamp: ''!
I represent the `FT_Bitmap_Size` type.!
!FTBitmapSize methodsFor: 'accessing - structure variables' stamp: ''!
width: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_WIDTH put: anObject! !

!FTBitmapSize methodsFor: 'accessing - structure variables' stamp: ''!
x_ppem
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_X_PPEM! !

!FTBitmapSize methodsFor: 'accessing - structure variables' stamp: ''!
width
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_WIDTH! !

!FTBitmapSize methodsFor: 'accessing - structure variables' stamp: ''!
y_ppem
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_Y_PPEM! !

!FTBitmapSize methodsFor: 'accessing - structure variables' stamp: ''!
x_ppem: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_X_PPEM put: anObject! !

!FTBitmapSize methodsFor: 'accessing - structure variables' stamp: ''!
size: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_SIZE put: anObject! !

!FTBitmapSize methodsFor: 'accessing - structure variables' stamp: ''!
size
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_SIZE! !

!FTBitmapSize methodsFor: 'accessing - structure variables' stamp: ''!
y_ppem: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_Y_PPEM put: anObject! !

!FTBitmapSize methodsFor: 'accessing - structure variables' stamp: ''!
height
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_HEIGHT! !

!FTBitmapSize methodsFor: 'accessing - structure variables' stamp: ''!
height: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_HEIGHT put: anObject! !

!FTBitmapSize class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
    FT_Short  height;
    FT_Short  width;

    FT_Pos    size;

    FT_Pos    x_ppem;
    FT_Pos    y_ppem;	
)! !

!FTCellMorph commentStamp: ''!
I represent a cell for the table. 

Description
------------------

I contains other Morph that need to be render. I should be answered in FTDataSource>>#cellTable:column:row:, with this method a FTTableContainer can display all the needed cells.

Technically, FTDataSource can answer  any kind of morph, but I'm better prepared  for the role so is recommendable  to  use me.

Public API and Key Messages
-------------------

- #withTopSeparator 		this is use to put a separator before the cell. (For exmple on a FTOutlineDataSource).

Example
-------------------

FTCellMorph new
		addMorphBack: 'Example' asMorph;
		withTopSeparator;
		openInWindow.
 
Internal Representation and Key Implementation Points.
-----------------

    Instance Variables
	topSeparator:		This is a boolean to know if the cell need a topSeparator.
!
!FTCellMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	super drawOn: aCanvas.
	topSeparator
		ifTrue: [ aCanvas line: bounds topLeft to: bounds topRight color: self seperatorColor ]! !

!FTCellMorph methodsFor: 'accessing' stamp: ''!
withTopSeparator
	topSeparator := true! !

!FTCellMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	topSeparator := false.
	self
		clipSubmorphs: true;
		layoutPolicy: TableLayout new;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		listDirection: #leftToRight;
		listCentering: #topLeft;
		wrapCentering: #center! !

!FTCellMorph methodsFor: 'drawing' stamp: ''!
seperatorColor
	^ self theme scrollbarColor! !

!FTCellMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt
	self table ifNotNil: [ :table | ^ table selectionModeStrategy allowsCellSelection ].
	^ false! !

!FTCellSelectionModeStrategy commentStamp: ''!
Description
--------------------

I am a strategy to manage the behaviour of a FTTableMorph in case we are in a cell selection mode.

My indexes are stored as tuples whose first element designate the selected row and second element the selected column.

Examples
--------------------

	FTCellSelectionModeStrategy table: aFTTableMorph!
!FTCellSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexBellow: anIndex
	^ {(anIndex first + 1) . anIndex second}! !

!FTCellSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexContainingPoint: aPoint
	^ self tableContainer rowAndColumnIndexContainingPoint: aPoint! !

!FTCellSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex beforeColumn: aColumnIndex
	^ anIndex second < aColumnIndex! !

!FTCellSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex afterColumn: aColumnIndex
	^ anIndex second > aColumnIndex! !

!FTCellSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexBefore: anIndex
	^ {anIndex first . (anIndex second - 1)}! !

!FTCellSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
nullIndex
	^ #(0 0)! !

!FTCellSelectionModeStrategy methodsFor: 'selection' stamp: ''!
selectAll
	self table selectIndexes: ((1 to: self table numberOfRows) flatCollect: [ :rowIndex | (1 to: self table numberOfColumns) collect: [ :columnIndex | {rowIndex . columnIndex} ] ]) asArray! !

!FTCellSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
indexForRow: aRowIndex
	^ {aRowIndex . self table selectedIndex second}! !

!FTCellSelectionModeStrategy methodsFor: 'selection' stamp: ''!
selectLast
	self table selectIndex: {self table numberOfRows . self table numberOfColumns}! !

!FTCellSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex bellowRow: aRowIndex
	^ anIndex first > aRowIndex! !

!FTCellSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
rowIndexFrom: anIndex
	^ anIndex first! !

!FTCellSelectionModeStrategy methodsFor: 'adding' stamp: ''!
selectablesToHighlightFromRow: aFTRow at: aRowIndex withHighlightedIndexes: highligtedIndexes andPrimaryIndex: primarySelectionIndex
	| selectablesToColorMap |
	selectablesToColorMap := Dictionary new.
	self flag: #pharoFixMe.	"Currently, the rows in FastTable have cells in submorphs, but the API should be improved to provide better cell iterations instead of letting external users touch row submorphs."
	aFTRow submorphs
		withIndexDo: [ :each :columnIndex | 
			| cellIndex |
			(highligtedIndexes includes: (cellIndex := {aRowIndex . columnIndex})) ifTrue: [ selectablesToColorMap at: each put: primarySelectionIndex = cellIndex ] ].
	^ selectablesToColorMap! !

!FTCellSelectionModeStrategy methodsFor: 'selection' stamp: ''!
selectFirst
	self table selectIndex: #(1 1)! !

!FTCellSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
indexesToSelectInMultipleSelectionFrom: firstIndex to: endIndex
	| stepV stepH |
	stepV := firstIndex first <= endIndex first ifTrue: [ 1 ] ifFalse: [ -1 ].
	stepH := firstIndex second <= endIndex second ifTrue: [ 1 ] ifFalse: [ -1 ].
	^ (firstIndex second to: endIndex second by: stepH) flatCollect: [ :v | (firstIndex first to: endIndex first by: stepV) collect: [ :h | {h . v} ] ]! !

!FTCellSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexAfter: anIndex
	^ {anIndex first . (anIndex second + 1)}! !

!FTCellSelectionModeStrategy methodsFor: 'testing' stamp: ''!
allowsCellSelection
	^ true! !

!FTCellSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex aboveRow: aRowIndex
	^ anIndex first < aRowIndex! !

!FTCellSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
indexFromPosition: aTuple
	^ aTuple! !

!FTCellSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexAbove: anIndex
	^ {(anIndex first - 1) . anIndex second}! !

!FTCellSelectionModeStrategyTest commentStamp: ''!
A FTCellSelectionModeStrategyTest is a test class for testing the behavior of FTCellSelectionModeStrategy!
!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectedRowIndex
	table selectIndex: #(3 5).
	self assert: strategy selectedRowIndex equals: 3.
	table selectIndex: #(4 5).
	self assert: strategy selectedRowIndex equals: 4! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIndexFromPosition
	self assert: (strategy indexFromPosition: #(3 7)) equals: #(3 7)! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexAbove
	self assert: (strategy selectableIndexAbove: #(2 3)) equals: #(1 3)! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexBellow
	self assert: (strategy selectableIndexBellow: #(2 3)) equals: #(3 3)! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectAll
	table beSingleSelection.
	table selectFirst.
	table selectAll.
	self assert: table selectedIndexes equals: #(#(1 1)).
	table beMultipleSelection.
	table selectFirst.
	table selectAll.
	self
		assert: table selectedIndexes
		equals:
			#(#(1 1) #(1 2) #(1 3) #(2 1) #(2 2) #(2 3) #(3 1) #(3 2) #(3 3) #(4 1) #(4 2) #(4 3) #(5 1) #(5 2) #(5 3) #(6 1) #(6 2) #(6 3) #(7 1) #(7 2) #(7 3) #(8 1) #(8 2) #(8 3) #(9 1) #(9 2) #(9 3) #(10 1) #(10 2) #(10 3))! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexBefore
	self assert: (strategy selectableIndexBefore: #(2 3)) equals: #(2 2)! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testRowIndexFrom
	self assert: (strategy rowIndexFrom: #(3 5)) equals: 3! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsAfterColumn
	self assert: (strategy is: #(3 7) afterColumn: 4).
	self deny: (strategy is: #(3 7) afterColumn: 9).
	self deny: (strategy is: #(3 7) afterColumn: 7)! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectFirst
	table selectFirst.
	self assert: table selectedIndexes equals: #(#(1 1))! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectLast
	table selectLast.
	self assert: table selectedIndexes equals: #(#(10 3))! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexAfter
	self assert: (strategy selectableIndexAfter: #(2 3)) equals: #(2 4)! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsBellowRow
	self assert: (strategy is: #(3 7) bellowRow: 2).
	self deny: (strategy is: #(3 7) bellowRow: 4).
	self deny: (strategy is: #(3 7) bellowRow: 3)! !

!FTCellSelectionModeStrategyTest methodsFor: 'running' stamp: ''!
setStrategy
	table beCellSelection! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsAboveRow
	self assert: (strategy is: #(3 7) aboveRow: 4).
	self deny: (strategy is: #(3 7) aboveRow: 2).
	self deny: (strategy is: #(3 7) aboveRow: 3)! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsBeforeColumn
	self assert: (strategy is: #(3 7) beforeColumn: 9).
	self deny: (strategy is: #(3 7) beforeColumn: 4).
	self deny: (strategy is: #(3 7) beforeColumn: 7)! !

!FTCellSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIndexesToSelectInMultipleSelectionFromTo
	self
		assert: (strategy indexesToSelectInMultipleSelectionFrom: #(8 1) to: #(21 3)) asArray
		equals:
			#(#(8 1) #(9 1) #(10 1) #(11 1) #(12 1) #(13 1) #(14 1) #(15 1) #(16 1) #(17 1) #(18 1) #(19 1) #(20 1) #(21 1) #(8 2) #(9 2) #(10 2) #(11 2) #(12 2) #(13 2) #(14 2) #(15 2) #(16 2) #(17 2) #(18 2) #(19 2) #(20 2) #(21 2) #(8 3) #(9 3) #(10 3) #(11 3) #(12 3) #(13 3) #(14 3) #(15 3) #(16 3) #(17 3) #(18 3) #(19 3) #(20 3) #(21 3))! !

!FTCharMapRec commentStamp: ''!
I implement the `FT_CharMap_Rec`!
!FTCharMapRec methodsFor: 'accessing - structure variables' stamp: ''!
encoding: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_ENCODING put: anObject! !

!FTCharMapRec methodsFor: 'accessing - structure variables' stamp: ''!
face
	"This method was automatically generated"
	^FTFaceRec fromHandle: (handle pointerAt: OFFSET_FACE)! !

!FTCharMapRec methodsFor: 'accessing - structure variables' stamp: ''!
face: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_FACE put: anObject getHandle.! !

!FTCharMapRec methodsFor: 'accessing - structure variables' stamp: ''!
platform_id
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PLATFORM_ID! !

!FTCharMapRec methodsFor: 'accessing - structure variables' stamp: ''!
platform_id: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PLATFORM_ID put: anObject! !

!FTCharMapRec methodsFor: 'accessing - structure variables' stamp: ''!
encoding_id: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_ENCODING_ID put: anObject! !

!FTCharMapRec methodsFor: 'accessing - structure variables' stamp: ''!
encoding
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_ENCODING! !

!FTCharMapRec methodsFor: 'accessing - structure variables' stamp: ''!
encoding_id
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_ENCODING_ID! !

!FTCharMapRec class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
    FT_Face      face;
    FT_Encoding  encoding;
    FT_UShort    platform_id;
    FT_UShort    encoding_id;
)! !

!FTColumn commentStamp: ''!
Description 
------------------
 
I'm a column definition for a fast table.

I keep an id and relevant informations of my behaviour, but this behaviour is better defined in FTDataSource>>#headerColumn:

I can have a sorting strategy, by default I uses a null sorting strategy. The datasource can ask to me informations from the current strategy such as an icon to display in the header cell. When the header is clicked, I'll give a datasource to the strategy and ask to sort it.

Examples
--------------------

	FTTableMorph new
		extent: 650 @ 500;
		addColumn:
			((FTColumn id: 'Icon')
				width: 40;
				yourself);
		addColumn:
			((FTColumn id: 'Name')
				sortableOnProperty: #name;
				yourself);
		addColumn:
			((FTColumn id: 'Number of methods')
				sortableOnProperty: #numberOfMethods;
				yourself);
		addColumn:
			((FTColumn id: 'Number of instance variables')
				sortableOnProperty: #numberOfInstanceVariables;
				yourself);
		dataSource: FTExampleClassInfoTableDataSource new;
		selectFirst;
		showFirstSelection;
		beResizable;
		openInWindow
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	id:							<aSymbol>							An id for the column
	sortingStrategy:		<aColumnSortingStrategy>		A subclass of FTAbstractColumnSortingStrategy that will manage all the behavior of the table sorting
	width:						<anInteger>						An Integer that represent the width of a column
!
!FTColumn methodsFor: 'accessing' stamp: ''!
width: anObject
	width := anObject! !

!FTColumn methodsFor: 'initialization' stamp: ''!
resetSorting
	self sortingStrategy reset! !

!FTColumn methodsFor: 'layout' stamp: ''!
acquireWidth: anOwnerWidth
	^ self widthOrUndefined min: anOwnerWidth! !

!FTColumn methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self disableSort! !

!FTColumn methodsFor: 'sorting' stamp: ''!
sortableOnProperty: aProperty
	self sortingStrategy: (FTPropertyColumnSortingStrategy column: self property: aProperty)! !

!FTColumn methodsFor: 'accessing' stamp: ''!
id: anObject
	id := anObject! !

!FTColumn methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!FTColumn methodsFor: 'accessing' stamp: ''!
sortingStrategy
	^ sortingStrategy! !

!FTColumn methodsFor: 'sorting' stamp: ''!
disableSort
	self sortingStrategy: (FTNullColumnSortingStrategy column: self)! !

!FTColumn methodsFor: 'testing' stamp: ''!
isSortEnabled
	^ self sortingStrategy isSortingEnabled! !

!FTColumn methodsFor: 'sorting' stamp: ''!
sortableUsing: aSortFunction
	self sortingStrategy: (FTSortFunctionColumnSortingStrategy column: self sortFunction: aSortFunction)! !

!FTColumn methodsFor: 'accessing' stamp: ''!
transform: anObject
	^ anObject! !

!FTColumn methodsFor: 'accessing' stamp: ''!
sortDataSource: aDataSource

	"If other columns are already sorted, we need to reset them."
	(aDataSource table columns copyWithout: self) do: #resetSorting.
	self sortingStrategy sortDataSource: aDataSource! !

!FTColumn methodsFor: 'accessing' stamp: ''!
sortingStrategy: anObject
	sortingStrategy := anObject! !

!FTColumn methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!FTColumn methodsFor: 'accessing' stamp: ''!
sortingIcon
	^ self sortingStrategy sortingIcon! !

!FTColumn methodsFor: 'accessing' stamp: ''!
widthOrUndefined
	^ self width ifNil: [ self class undefinedColumnWidth ]! !

!FTColumn class methodsFor: 'instance creation' stamp: ''!
id: anObject
	^ self new
		id: anObject;
		yourself! !

!FTColumn class methodsFor: 'accessing' stamp: ''!
undefinedColumnWidth
	"This is a contant that defines a column width is undefined, then the layout will try to arrange 
	 it by itself."
	^ 0! !

!FTColumnResizerMorph commentStamp: ''!
A resizer morph for a fast table.
I can be added to any place but in current implementation I'm used in table headers (because would be expensive to add to each cell).!
!FTColumnResizerMorph methodsFor: 'accessing' stamp: ''!
splitsTopAndBottom
	^ false! !

!FTColumnResizerMorph methodsFor: 'initialization' stamp: ''!
initializeContainer: aTableContainerMorph left: aColumn right: otherColumn
	self initialize.
	self width: self class resizerWidth.
	container := aTableContainerMorph.
	leftColumn := aColumn.
	rightColumn := otherColumn! !

!FTColumnResizerMorph methodsFor: 'submorphs - add/remove' stamp: ''!
delete
	super delete.
	self release.! !

!FTColumnResizerMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	(owner notNil and: [owner containsPoint: self position])
		ifTrue: [super drawOn: aCanvas]! !

!FTColumnResizerMorph methodsFor: 'event handling' stamp: ''!
mouseEnter: anEvent
	self canResizeColumn ifFalse: [^ self].
	(owner notNil and: [owner bounds containsPoint: anEvent position]) 
		ifTrue: [super mouseEnter: anEvent]! !

!FTColumnResizerMorph methodsFor: 'Polymorph-Widgets' stamp: ''!
shouldDraw
	^ true! !

!FTColumnResizerMorph methodsFor: 'private' stamp: ''!
setGrabbedColor
	"Set the color of the receiver when it is grabbed."
	self fillStyle: self theme fastTableColumnSplitterSelectedColor! !

!FTColumnResizerMorph methodsFor: 'event handling' stamp: ''!
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}! !

!FTColumnResizerMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: anEvent
	self canResizeColumn ifFalse: [^ self].
	super mouseLeave: anEvent! !

!FTColumnResizerMorph methodsFor: 'actions' stamp: ''!
resizeCursor
	^ Cursor resizeForEdge: #left! !

!FTColumnResizerMorph methodsFor: 'Polymorph-Widgets' stamp: ''!
themeChanged
	"Update the fill style."
	self fillStyle: self normalFillStyle.
	super themeChanged! !

!FTColumnResizerMorph methodsFor: 'event handling' stamp: ''!
updateFromEvent: anEvent 
	"Update the splitter and attached morph positions from
	the mouse event.
	Take into account the mouse down offset."
	| delta |
	
	delta := (anEvent cursorPoint - lastMouse first) x.
	"if positive, delta cannot be bigger than right width (plus a variation) 
	 to prevent column overlap."
	(delta > 0 and: [ delta > (rightColumn width - (self width) - 5) ])
		ifTrue: [ delta := rightColumn width - (self width) - 5 ].
	"if negative, -delta cannot be bigger than left width (plus a variation) 
	 to prevent column overlap."
	(delta < 0 and: [ delta negated > (leftColumn width - (self width) - 5) ])
		ifTrue: [ delta := (leftColumn width - (self width) - 5) negated ].

	leftColumn column width: (leftColumn column width ifNil: [ leftColumn width ]) + delta.
	rightColumn column width: (rightColumn column width ifNil: [ rightColumn width ]) - delta.	
	container changed! !

!FTColumnResizerMorph methodsFor: 'submorphs - add/remove' stamp: ''!
release
	traceMorph := nil.
	oldColor := nil.
	container := nil.
	self releaseActionMap. "we are not sure if we need it"
	super release.! !

!FTColumnResizerMorph methodsFor: 'private - testing' stamp: ''!
canResizeColumn
	^ container owner isResizable! !

!FTColumnResizerMorph methodsFor: 'Polymorph-Widgets' stamp: ''!
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 updateFromEvent: anEvent.
	traceMorph ifNotNil: [traceMorph delete. traceMorph := nil].
	self adoptPaneColor: self paneColor.
	self triggerEvent: #mouseUp! !

!FTColumnResizerMorph methodsFor: 'style' stamp: ''!
pressedFillStyle
	"Return the pressed fillStyle of the receiver."
	^ self theme morphTreeSplitterPressedFillStyleFor: self! !

!FTColumnResizerMorph methodsFor: 'event handling' stamp: ''!
mouseMove: anEvent 
	self canResizeColumn ifFalse: [^ self].
	anEvent hand temporaryCursor ifNil: [^ self].
	traceMorph ifNil: [
		traceMorph := Morph newBounds: (self bounds withHeight: container height).
		traceMorph color: self theme fastTableColumnResizingColor.
		traceMorph borderWidth: 0.
		container addMorph: traceMorph].
	traceMorph position: (anEvent cursorPoint x - lastMouse second x) @ traceMorph position y! !

!FTColumnResizerMorph methodsFor: 'style' stamp: ''!
normalFillStyle
	"Return the normal fillstyle for the receiver."
	^ self theme morphTreeSplitterNormalFillStyleFor: self! !

!FTColumnResizerMorph class methodsFor: 'instance creation' stamp: ''!
new
	^ self error: 'Use #container:left:right:'! !

!FTColumnResizerMorph class methodsFor: 'instance creation' stamp: ''!
container: aTableContainerMorph left: aColumn right: otherColumn
	^ self basicNew 
		initializeContainer: aTableContainerMorph 
			left: aColumn 
			right: otherColumn;
		yourself! !

!FTColumnResizerMorph class methodsFor: 'accessing' stamp: ''!
resizerWidth
	^ 8! !

!FTColumnTest commentStamp: ''!
A FTColumnTest is a test class for testing the behavior of FTColumn!
!FTColumnTest methodsFor: 'tests' stamp: ''!
testNoIconWithoutSorting
	column disableSort.
	self assert: column sortingIcon isNil! !

!FTColumnTest methodsFor: 'tests' stamp: ''!
testColumnHasIconWithSorting
	column sortableOnProperty: #name.
	self assert: column sortingIcon isNotNil! !

!FTColumnTest methodsFor: 'tests' stamp: ''!
testIsSortEnabled
	column disableSort.
	self deny: column isSortEnabled.
	column sortableOnProperty: #name.
	self assert: column isSortEnabled! !

!FTColumnTest methodsFor: 'tests' stamp: ''!
testDisableSort
	column disableSort.
	self deny: column isSortEnabled! !

!FTColumnTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ FTColumn! !

!FTColumnTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	column := self actualClass new! !

!FTDataSource commentStamp: ''!
I am an abtract class to define the basic implementation of a DataSource. A DataSource is a Model for a FTTableMorph. My purpose is to provide content to it .

Description
--------------------

My subclasses will store some values that will be use to feed a FTTableMorph.
 I work with a FTTableMorph so I store one.

Public API and Key Messages
--------------------

- #elementAt: anIndex 		return an object to display for an index in the table.
		
- #numberOfRows 			return the max number of rows inside the table.
			
- #cellColumn: index1 row: idex2 		return a Morph (probably a FTCellMorph) that will be display in the table. The Morph need to contains the object at index2 and everything the user want to display for a data.
		
- #newDataSourceMatching: aRegex / #searchText: aString 		these methods are use with a FTFunction. For more information see FTSeachFunction or FTFilterFunction for mone information.

Example
-------------------

This is an Abstract class, see subclasses for examples.
 
Internal Representation and Key Implementation Points.
-------------------

    Instance Variables
	table:		A FTTableMorph that use the dataSource.
!
!FTDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
	"Answer a morph with the cell view. I will probably return a FTCellMorph."

	self subclassResponsibility! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
newDataSourceMatching: aFTFilter
	"I am here to help the FTFilterFunction. I take a aFTFilter and I need to return a new dataSource with filtered elements. Each dataSource is responsible of his filtering in order to get a generic mechanism."
	
	"the default action is to just do nothing, return self"
	
	^self! !

!FTDataSource methodsFor: 'private' stamp: ''!
elementAt: rowIndex
	"I am a really important method for a DataSource. I take an index and I return an object 
	 that should be displayed in the table for the index."
	self subclassResponsibility! !

!FTDataSource methodsFor: 'private' stamp: ''!
readyToBeDisplayed
	"I am a method call when I am set to a FTTableMorph. I can be override, for example the dataSource of glamour send an announcement to update the dataSource of a Refderer."! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
toString: anObject
	"Override me if you expect something else."

	^ anObject asString! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
realElementAt: anIndex
	"I am here because some dataSource wrap there element into an other Object but we still want to access to the initial element. In that case a DataSource can override me to get the real element."

	^ self elementAt: anIndex! !

!FTDataSource methodsFor: 'drag and drop' stamp: ''!
passengerAt: rowIndex
	"Answer 'passenger' for drag&drop operation (a passenger is the object who will travel between 
	 drag and drop). By default, passenger is same as current element"
	^ self elementAt: rowIndex! !

!FTDataSource methodsFor: 'private' stamp: ''!
tableRefresh
	^ self table refresh! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString
	"search a text and answers a list of elements indexes matching condition. 
	 E.g,
	 	#() 		--> No match 
		#(1) 		--> match first element
		#(1 42) 	--> match elements 1 and 42
			
	Rows not in range will cause the end of the world as we know it :)"
	^ #()! !

!FTDataSource methodsFor: 'drag and drop' stamp: ''!
wantsDropElements: aCollection type: type index: rowIndex
	^ false! !

!FTDataSource methodsFor: 'testing' stamp: ''!
hasElementAt: index 

	^ self numberOfRows >= index! !

!FTDataSource methodsFor: 'sorting' stamp: ''!
unsort
	self unsortElements.
	self table refresh! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
rowHeight: roIndex

	^ self table rowHeight! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
numberOfRows
	"I return the number of elements I can display in the table when I am call."

	^ self subclassResponsibility! !

!FTDataSource methodsFor: 'sorting' stamp: ''!
unsortElements
	"This method should return the elements in their initial state."

	self subclassResponsibility! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
headerColumn: column
	"Answers a cell who will be the header of a column"

	^ nil! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	"Answer a menu for the (column, row) provided"

	^ nil! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
table: anObject
	table := anObject! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
basicHeaderCellFor: column
	| cell |
	column id ifNil: [ ^ nil ].
	cell := FTHeaderColumnCellMorph new
		listCentering: #center;
		column: column;
		cellInset: 5;
		addMorph: column id asStringMorph;
		yourself.

	column sortingIcon ifNotNil: [ :icon | cell addMorph: icon ].

	^ cell! !

!FTDataSource methodsFor: 'accessing' stamp: ''!
table
	"this the table binded to this dataSource"

	^ table! !

!FTDataSource methodsFor: 'drag and drop' stamp: ''!
dropElements: aCollection index: rowIndex
	^ false! !

!FTDataSource methodsFor: 'sorting' stamp: ''!
sortElements: aSortFunction
	"This method should sort the elements of the datasource using the sort function as parameter."

	self subclassResponsibility! !

!FTDataSource methodsFor: 'sorting' stamp: ''!
sortWith: aSortFunction
	self sortElements: aSortFunction.
	self table refresh! !

!FTDescendingSortingState commentStamp: ''!
Description
--------------------

I am a sorting state for descending sorted table.!
!FTDescendingSortingState methodsFor: 'sorting' stamp: ''!
executeSortingOn: aDataSource
	aDataSource sortWith: self context ascendingSortFunction reversed! !

!FTDescendingSortingState methodsFor: 'accessing' stamp: ''!
nextState
	^ FTUnsortedSortingState context: self context! !

!FTDescendingSortingState methodsFor: 'accessing' stamp: ''!
sortingIcon
	^ self context morphicIconNamed: #arrowDown! !

!FTDescendingSortingStateTest commentStamp: ''!
A FTDescendingSortingStateTest is a test class for testing the behavior of FTDescendingSortingState!
!FTDescendingSortingStateTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ FTDescendingSortingState! !

!FTDescendingSortingStateTest methodsFor: 'tests' stamp: ''!
testExecuteSortingOn
	| dataSource |
	dataSource := self dataSourceForTesting.
	state executeSortingOn: dataSource.
	self assert: dataSource elements equals: #(10 9 8 7 6 5 4 3 2 1).
	state executeSortingOn: dataSource.
	self assert: dataSource elements equals: #(10 9 8 7 6 5 4 3 2 1).! !

!FTDisplayColumn commentStamp: ''!
I'm a container for columns in the process of being shown in container. 
I have display column properties (that might or might not be in column it self).

Originally I'm used to send data outside container that might be used (for example, resizing).!
!FTDisplayColumn methodsFor: 'accessing' stamp: ''!
width: anObject
	width := anObject! !

!FTDisplayColumn methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!FTDisplayColumn methodsFor: 'accessing' stamp: ''!
column
	^ column! !

!FTDisplayColumn methodsFor: 'accessing' stamp: ''!
column: anObject
	column := anObject! !

!FTDisplayColumn class methodsFor: 'instance creation' stamp: ''!
column: aColumn width: aWidth
	^ self new 
		column: aColumn;
		width: aWidth;
		yourself! !

!FTEasyListDataSource commentStamp: ''!
I'm a datasource who works with FTEasyListMorph.
I receive blocks to provide my contents. !
!FTEasyListDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex 
	^ FTCellMorph new
		cellInset: 5;
		in: [ :me | 
			(self iconFor: rowIndex) 
				ifNotNil: [ :icon | me addMorphBack: icon asMorph ] ];
		addMorphBack: (self displayFor: rowIndex) asMorph;
		yourself! !

!FTEasyListDataSource methodsFor: 'accessing' stamp: ''!
menu: aBlock
	menuBlock := aBlock! !

!FTEasyListDataSource methodsFor: 'accessing' stamp: ''!
display: aBlock
	displayBlock := aBlock! !

!FTEasyListDataSource methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	menuBlock ifNil: [ ^ nil ].
	rowIndex = 0 ifTrue: [ 
		"I could answer a menu without selection, but in this case I will just answer nil, 
		 which means 'no menu'"
		^ nil ].
	^ menuBlock value: (self elementAt: rowIndex)! !

!FTEasyListDataSource methodsFor: 'accessing' stamp: ''!
icon: aBlock
	iconBlock := aBlock! !

!FTEasyListDataSource methodsFor: 'private' stamp: ''!
iconFor: rowIndex
	iconBlock ifNil: [ ^ nil ].
	^ iconBlock value: (self elementAt: rowIndex)! !

!FTEasyListDataSource methodsFor: 'private' stamp: ''!
displayFor: rowIndex
	| element |
	element := self elementAt: rowIndex.
	^ displayBlock 
		ifNotNil: [ displayBlock value: element ]
		ifNil: [ ^ element ].! !

!FTEasyListMorph commentStamp: ''!
I'm an easy list used to simplify the creation of lists.
My parent is too powerful, I'm just a simplification of it (and no, I will not go to the psy to deal with that).

 Example: 
=========
FTEasyListMorph new
	extent: 300@550;
	elements: Morph methods;
	display: [ :method | method selector ];		
	openInWindow.
	!
!FTEasyListMorph methodsFor: 'accessing' stamp: ''!
header: aString
	self ensureAtLeastOneColumn.
	self columns first id: aString! !

!FTEasyListMorph methodsFor: 'accessing' stamp: ''!
menu: aBlock
	self dataSource menu: aBlock! !

!FTEasyListMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self dataSource: FTEasyListDataSource new! !

!FTEasyListMorph methodsFor: 'accessing' stamp: ''!
elements: aSequenceableCollection
	self dataSource elements: aSequenceableCollection! !

!FTEasyListMorph methodsFor: 'accessing' stamp: ''!
display: aBlock
	self dataSource display: aBlock! !

!FTEasyListMorph methodsFor: 'accessing' stamp: ''!
icon: aBlock
	self dataSource icon: aBlock! !

!FTExampleClassInfoTableDataSource commentStamp: ''!
I'm an example of fast table, who will use a list of classes as data source elements.
!
!FTExampleClassInfoTableDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex 
	column id = 'Icon' ifTrue: [ ^ self iconColumn: column row: rowIndex ].
	column id = 'Name' ifTrue: [ ^ self nameColumn: column row: rowIndex ].
	column id = 'Number of methods' ifTrue: [ ^ self numberOfMethodsColumn: column row: rowIndex ].
	column id = 'Number of instance variables' ifTrue: [ ^ self numberOfInstanceVariablesColumn: column row: rowIndex ].
	
	self error: 'Invalid column'! !

!FTExampleClassInfoTableDataSource methodsFor: 'accessing' stamp: ''!
iconColumn: column row: rowIndex
	^ FTCellMorph new  
		addMorphBack: (self iconFor: rowIndex) asMorph;
		yourself! !

!FTExampleClassInfoTableDataSource methodsFor: 'accessing' stamp: ''!
numberOfMethodsColumn: column row: rowIndex
	^ FTCellMorph new
		addMorph: (self elementAt: rowIndex) numberOfMethods asStringMorph;
		yourself! !

!FTExampleClassInfoTableDataSource methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self elements: Smalltalk allClassesAndTraits shuffled! !

!FTExampleClassInfoTableDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString
	aString isEmptyOrNil ifTrue: [ ^ #() ].

	self elements withIndexDo: [ :each :index | (each name beginsWith: aString) ifTrue: [ ^ {index} ] ].
	^ #()! !

!FTExampleClassInfoTableDataSource methodsFor: 'accessing' stamp: ''!
nameColumn: column row: rowIndex
	^ FTCellMorph new  
		addMorphBack: (self elementAt: rowIndex) name asStringMorph;
		yourself! !

!FTExampleClassInfoTableDataSource methodsFor: 'accessing' stamp: ''!
numberOfInstanceVariablesColumn: column row: rowIndex
	^ FTCellMorph new 
		addMorph: (self elementAt: rowIndex) instSize asStringMorph;
		yourself! !

!FTExampleClassInfoTableDataSource methodsFor: 'private' stamp: ''!
iconFor: index
	| class |
	class := self elementAt: index.
	((class
		includesBehavior: (Smalltalk globals at: #TestCase ifAbsent: [ false ]))
		and: [ class isAbstract not ])
		ifTrue: [ class hasPassedTest
				ifTrue: [ ^ self iconNamed: #testGreenIcon ].
			class hasFailedTest
				ifTrue: [ ^ self iconNamed: #testYellowIcon ].
			class hasErrorTest
				ifTrue: [ ^ self iconNamed: #testRedIcon ].
			^ self iconNamed: #testNotRunIcon ].
	class organization classComment
		ifEmpty: [ ^ self iconNamed: #uncommentedClassIcon ].
	((class
		includesBehavior: (Smalltalk globals at: #TestCase ifAbsent: [ false ]))
		and: [ class isAbstract not ])
		ifTrue: [ class hasPassedTest
				ifTrue: [ ^ self iconNamed: #testGreenIcon ].
			class hasFailedTest
				ifTrue: [ ^ self iconNamed: #testYellowIcon ].
			class hasErrorTest
				ifTrue: [ ^ self iconNamed: #testRedIcon ].
			^ self iconNamed: #testNotRunIcon ].
	class organization classComment
		ifEmpty: [ ^ self iconNamed: #uncommentedClassIcon ].
	^ class systemIcon! !

!FTExampleDataSource commentStamp: ''!
I'm a simple example of fast table, who will use a list of classes and traits as data source elements.

FTExamples example1.
FTExamples example2.!
!FTExampleDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex 
	^ FTCellMorph new
		color: (self colorFor: rowIndex);
		cellInset: 5;
		addMorphBack: (self iconFor: rowIndex) asMorph;
		addMorphBack: (self elementAt: rowIndex) name asStringMorph;
		yourself! !

!FTExampleDataSource methodsFor: 'private' stamp: ''!
colorFor: index
	index odd ifTrue: [ ^ Smalltalk ui theme lightBackgroundColor ].
	^ Smalltalk ui theme backgroundColor! !

!FTExampleDataSource methodsFor: 'private' stamp: ''!
iconFor: index
	| class |
	class := self elementAt: index.
	((class
		includesBehavior: (Smalltalk globals at: #TestCase ifAbsent: [ false ]))
		and: [ class isAbstract not ])
		ifTrue: [ class hasPassedTest
				ifTrue: [ ^ self iconNamed: #testGreenIcon ].
			class hasFailedTest
				ifTrue: [ ^ self iconNamed: #testYellowIcon ].
			class hasErrorTest
				ifTrue: [ ^ self iconNamed: #testRedIcon ].
			^ self iconNamed: #testNotRunIcon ].
	class organization classComment
		ifEmpty: [ ^ self iconNamed: #uncommentedClassIcon ].
	((class
		includesBehavior: (Smalltalk globals at: #TestCase ifAbsent: [ false ]))
		and: [ class isAbstract not ])
		ifTrue: [ class hasPassedTest
				ifTrue: [ ^ self iconNamed: #testGreenIcon ].
			class hasFailedTest
				ifTrue: [ ^ self iconNamed: #testYellowIcon ].
			class hasErrorTest
				ifTrue: [ ^ self iconNamed: #testRedIcon ].
			^ self iconNamed: #testNotRunIcon ].
	class organization classComment
		ifEmpty: [ ^ self iconNamed: #uncommentedClassIcon ].
	^ class systemIcon! !

!FTExampleDropDataSource commentStamp: ''!
I'm a simple example of fast table who will accept drops of classes.

FTExamples exampleDragAndDrop1.
!
!FTExampleDropDataSource methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	self elements: #()! !

!FTExampleDropDataSource methodsFor: 'drag and drop' stamp: ''!
wantsDropElements: aCollection type: type index: rowIndex
	^ aCollection allSatisfy: #isClass! !

!FTExampleDropDataSource methodsFor: 'drag and drop' stamp: ''!
dropElements: aCollection index: rowIndex
	self elements: (rowIndex = 0
		ifTrue: [ self elements, aCollection ]
		ifFalse: [ (self elements first: rowIndex), aCollection, (self elements allButFirst: rowIndex) ]).! !

!FTExampleMethodListDataSource commentStamp: ''!
I'm an example of fast table, who will use a list of methods as data source elements.

self example1.
self example2.
self example3.
self example4.
self example5.
!
!FTExampleMethodListDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
 
	^ FTCellMorph new
		cellInset: 5;
		addMorphBack: (self iconFor: rowIndex) asMorph;
		addMorphBack: (self elementAt: rowIndex) name asMorph;
		yourself! !

!FTExampleMethodListDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString
	aString isEmptyOrNil ifTrue: [ ^ #() ].
	
	self elements withIndexDo: [ :each :index |
		( each name beginsWith: aString)
			ifTrue: [ ^ { index } ] ].
	^ #()! !

!FTExampleMethodListDataSource methodsFor: 'private' stamp: ''!
colorFor: index
	index odd ifTrue: [ ^ Smalltalk ui theme lightBackgroundColor ].
	^ Smalltalk ui theme backgroundColor! !

!FTExampleMethodListDataSource methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	| menu method |
	
	rowIndex = 0 ifTrue: [ 
		"I could answer a menu without selection, but in this case I will just answer nil, 
		 which means 'no menu'"
		^ nil ].
	
	method := (self elementAt: rowIndex) method.
	menu := UIManager default newMenuIn: self table for: self.
	menu add: ('Browse ', (method methodClass name), '>>#', method selector) 
		target: method
		selector: #browse.
	menu add: ('Inspect #', (method methodClass name), '>>#', method selector)
		target: method
		selector: #inspect.

	^ menu! !

!FTExampleMethodListDataSource methodsFor: 'initialization' stamp: ''!
initializeClass: aClass
	self initialize.
	self elements: ((aClass selectors sorted: [ :a :b | a < b ])
		collect: [ :each | FTExampleMethodModel method: aClass>>each ])! !

!FTExampleMethodListDataSource methodsFor: 'private' stamp: ''!
iconFor: rowIndex
	^ (self elementAt: rowIndex) actionOn: self! !

!FTExampleMethodListDataSource class methodsFor: 'instance creation' stamp: ''!
for: aClass
	^ self basicNew 
		initializeClass: aClass;
		yourself! !

!FTExampleMethodListGeneratorDataSource methodsFor: 'initialization' stamp: ''!
elementAt: anIndex

	^ self 
		elementAt: anIndex 
		ifAbsent: [ self error: 'Index not found' ]! !

!FTExampleMethodListGeneratorDataSource methodsFor: 'testing' stamp: ''!
hasElementAt: index

	self elementAt: index ifAbsent: [ ^ false ].
	^ true! !

!FTExampleMethodListGeneratorDataSource methodsFor: 'accessing' stamp: ''!
size

	^ size! !

!FTExampleMethodListGeneratorDataSource methodsFor: 'initialization' stamp: ''!
elementAt: index ifAbsent: aBlock

	[ elements size < index ] 
	whileTrue: [ 
		generator atEnd ifTrue: [ ^ aBlock value ].
		elements add: generator next.
		generator atEnd ifTrue: [ size := elements size ] ].
	^ elements at: index! !

!FTExampleMethodListGeneratorDataSource methodsFor: 'initialization' stamp: ''!
initializeClass: aClass
	
	self initialize.
	"Just a big number"
	size := 10000. 
	"where we are going to place the elements"
	elements := OrderedCollection new. 
	"the generator"
	generator := Generator on: [ :g |
		(aClass selectors sorted: [ :a :b | a < b ]) 
			do: [ :each | g yield: (FTExampleMethodModel method: aClass>>each) ] ]! !

!FTExampleMethodModel commentStamp: ''!
I'm a model for exposing method information.
I'm an example to be used in FTExampleMethodListDataSource and FTExampleMethodTableDataSource.!
!FTExampleMethodModel methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!FTExampleMethodModel methodsFor: 'accessing' stamp: ''!
actionOn: aBrowser
	^ actionIcon ifNil: [ actionIcon := self createActionIconOn: aBrowser ]! !

!FTExampleMethodModel methodsFor: 'accessing' stamp: ''!
origin
	^ self method origin! !

!FTExampleMethodModel methodsFor: 'initialization' stamp: ''!
initializeMethod: aMethod
	self initialize.
	method := aMethod! !

!FTExampleMethodModel methodsFor: 'accessing' stamp: ''!
protocol
	^ self method protocol! !

!FTExampleMethodModel methodsFor: 'factory' stamp: ''!
createActionIconOn: aBrowser
	^Smalltalk ui icons iconNamed: #scriptManagerIcon! !

!FTExampleMethodModel methodsFor: 'accessing' stamp: ''!
name
	^ self method selector! !

!FTExampleMethodModel class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #method:'! !

!FTExampleMethodModel class methodsFor: 'instance creation' stamp: ''!
method: aMethod
	^ self basicNew 
		initializeMethod: aMethod;
		yourself! !

!FTExampleMethodNotHomogeneousListDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
 
	^ FTCellMorph new
		cellInset: 5;
		addMorphBack: (self iconFor: rowIndex) asMorph;
		addMorphBack: (Morph new 
			changeTableLayout;
			hResizing: #shrinkWrap;
			listDirection: #topToBottom;
			color: Color transparent;
			addMorphBack: ((self elementAt: rowIndex) protocol asMorph emphasis: 2r10);
			addMorphBack: (self elementAt: rowIndex) name asMorph;
			yourself);
		yourself! !

!FTExampleMethodNotHomogeneousListDataSource methodsFor: 'accessing' stamp: ''!
rowHeight: rowIndex

	^ 50! !

!FTExampleMethodTableDataSource commentStamp: ''!
I'm an example of fast table, who will use a list of methods as data source elements.

self example1.
self example2.!
!FTExampleMethodTableDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex 
	column id = '#' ifTrue: [ ^ FTCellMorph new addMorph: rowIndex asMorph ].
	column id = 'Name' ifTrue: [ ^ self nameColumn: column row: rowIndex ].
	column id = 'Protocol' ifTrue: [ ^ self protocolColumn: column row: rowIndex ].
	column id = 'Origin' ifTrue: [ ^ self originColumn: column row: rowIndex ].
	
	self error: 'Invalid column'! !

!FTExampleMethodTableDataSource methodsFor: 'accessing' stamp: ''!
originColumn: column row: rowIndex
	^ FTCellMorph new 
		color: (self colorFor: rowIndex);
		addMorph: (self elementAt: rowIndex) origin name asMorph;
		yourself! !

!FTExampleMethodTableDataSource methodsFor: 'accessing' stamp: ''!
nameMenuColumn: column row: rowIndex
	| method menu |
	method := (self elementAt: rowIndex) method.
	menu := UIManager default newMenuIn: self table for: self.
	menu add: ('Browse ', (method methodClass name), '>>#', method selector) 
		target: method
		selector: #browse.
	menu add: ('Inspect #', (method methodClass name), '>>#', method selector)
		target: method
		selector: #inspect.

	^ menu! !

!FTExampleMethodTableDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString
	aString isEmptyOrNil ifTrue: [ ^ #() ].
	
	self elements withIndexDo: [ :each :index |
		( each name beginsWith: aString)
			ifTrue: [ ^ { index } ] ].
	^ #()! !

!FTExampleMethodTableDataSource methodsFor: 'accessing' stamp: ''!
nameColumn: column row: rowIndex
	^ FTCellMorph new  
		color: (self colorFor: rowIndex);
		cellInset: 5;
		addMorphBack: (self iconFor: rowIndex) asMorph;
		addMorphBack: (self elementAt: rowIndex) name asStringMorph;
		yourself! !

!FTExampleMethodTableDataSource methodsFor: 'private' stamp: ''!
colorFor: index
	"index odd ifTrue: [ ^ Smalltalk ui theme lightBackgroundColor ]."
	^Color transparent "Smalltalk ui theme backgroundColor"! !

!FTExampleMethodTableDataSource methodsFor: 'accessing' stamp: ''!
originMenuColumn: column row: rowIndex
	| method menu |
	method := (self elementAt: rowIndex) method.
	menu := UIManager default newMenuIn: self table for: self.
	menu add: ('Browse ', (method methodClass name)) 
		target: method methodClass
		selector: #browse.

	^ menu! !

!FTExampleMethodTableDataSource methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	rowIndex = 0 ifTrue: [ 
		"I could answer a menu without selection, but in this case I will just answer nil, 
		 which means 'no menu'"
		^ nil ].

	"protocols do not have associated menu"
	column id = 'Name' ifTrue: [ ^ self nameMenuColumn: column row: rowIndex ].
	column id = 'Origin' ifTrue: [ ^ self originMenuColumn: column row: rowIndex ].	

	^ nil! !

!FTExampleMethodTableDataSource methodsFor: 'initialization' stamp: ''!
initializeClass: aClass
	self initialize.
	self elements: ((aClass allSelectors sorted: [ :a :b | a < b ]) collect: [ :each | FTExampleMethodModel method: (aClass lookupSelector: each) ])! !

!FTExampleMethodTableDataSource methodsFor: 'private' stamp: ''!
iconFor: rowIndex
	^ (self elementAt: rowIndex) actionOn: self! !

!FTExampleMethodTableDataSource methodsFor: 'accessing' stamp: ''!
protocolColumn: column row: rowIndex
	^ FTCellMorph new
		color: (self colorFor: rowIndex);
		addMorph: (self elementAt: rowIndex) protocol asStringMorph;
		yourself! !

!FTExampleMethodTableDataSource class methodsFor: 'instance creation' stamp: ''!
for: aClass
	^ self basicNew 
		initializeClass: aClass;
		yourself! !

!FTExamples commentStamp: ''!
A list of examples. 
See class side.!
!FTExamples methodsFor: 'see class side' stamp: ''!
seeClassSide! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleEasyList3
	"Show an easy list with all Morph methods and a simple menu, with a list header"
	<example>
	<sampleInstance>
	| list |

	list := FTEasyListMorph new
		extent: 300@550;
		elements: Morph methods;
		header: 'Method list';
		icon: [ :method | (FTExampleMethodModel method: method) actionOn: nil ];
		display: [ :method | method selector ];		
		menu: [ :method | 
			MenuMorph new 
				add: ('Browse #', (method methodClass name), '>>#', method selector)
					target: method
					selector: #browse;
				add: ('Inspect #', (method methodClass name), '>>#', method selector)
					target: method
					selector: #inspect;
				yourself ];
		yourself.
		
	^ list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleOutline1
	<example>
	| list |
	list := FTTableMorph new
		extent: 200 @ 400;
		dataSource:
			(FTOutlineDataSource
				items:
					{(1 to: 10).
					(11 to: 20).
					(21 to: 30).
					(31 to: 40).
					(41 to: 50)}).
	list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleSortableList
	"Show a list with all Object methods with a header"

	<example>
	<sampleInstance>
	| list |
	list := FTTableMorph new
		extent: 300 @ 550;
		addColumn:
			((FTColumn id: 'Class name')
				sortableOnProperty: #printString;
				yourself);
		dataSource: (FTExampleDataSource elements: Smalltalk allClassesAndTraits shuffled);
		yourself.

	^ list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleList3
	"Show a list with all Object methods, 
		- preselects one element
	 	- responds to selection changes"

	<example>
	<sampleInstance>
	| list |
	list := FTTableMorph new
		extent: 300 @ 550;
		dataSource: (FTExampleMethodListDataSource for: Object);
		selectIndex: 42;
		showFirstSelection;
		onAnnouncement: FTSelectionChanged do: [ :ann | ('row selected: ' , ann newSelectedIndexes asString) crTrace ];
		yourself.

	^ list openInWindow! !

!FTExamples class methodsFor: 'tree examples' stamp: ''!
exampleTree2
	<example>
	| ds |
	ds := FTTreeDataSource
		roots: (1 to: 1000)
		children: [ :data :item | 
			item depth even
				ifTrue: [ 1 to: data / 2 ]
				ifFalse: [ 1 to: data - 1 ] ].
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
example1
	<example>
	| list |

	list := FTTableMorph new
		extent: 300@300;
		dataSource: (FTExampleDataSource elements: (Smalltalk allClassesAndTraits 
			sorted: [ :a :b | a name < b name]));
		yourself.
	list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleList2
	"Show a list with all Object methods and preselects one item"

	<example>
	<sampleInstance>
	| list |
	list := FTTableMorph new
		extent: 300 @ 550;
		dataSource: (FTExampleMethodListDataSource for: Object);
		selectIndex: 42;
		showFirstSelection;
		allowDeselection;
		yourself.

	^ list openInWindow! !

!FTExamples class methodsFor: 'function examples' stamp: ''!
exampleListWithExplicitFilter
	<example>
	| list |
	list := FTTableMorph new
		extent: 300 @ 300;
		dataSource: (FTExampleDataSource elements: (Smalltalk allClassesAndTraits sorted: [ :a :b | a name < b name ]));
		enableFilter;
		explicitFunction;
		yourself.
	list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleDragAndDrop2
	"Show drag&drop between two lists, multiple selection"
	<sampleInstance>
	<example>
	| list1 list2 |

	list1 := FTTableMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		addColumn: (FTColumn id: 'Drag from me!!');
		dataSource: (FTExampleDataSource elements: (Smalltalk allClassesAndTraits sorted: [ :a :b | a name < b name ]));
		dragEnabled: true;
		beMultipleSelection;
		yourself.
		
	list2 := FTTableMorph new 
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		addColumn: (FTColumn id: 'Drop into me!!');
		dataSource: FTExampleDropDataSource new;
		dropEnabled: true;
		yourself.
		
	^ PanelMorph new
		extent: 600@350;
		layoutPolicy: TableLayout new;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		listDirection: #leftToRight;
		cellPositioning: #topLeft;
		listCentering: #topLeft;
		wrapCentering: #topLeft;
		cellInset: 5;
		borderWidth: 0;
		addMorphBack: list1;
		addMorphBack: list2;
		openInWindow! !

!FTExamples class methodsFor: 'function examples' stamp: ''!
exampleListWithExplicitFilterAndActionButton2
	<example>
	| list |
	list := FTTableMorph new
		extent: 300 @ 300;
		dataSource: (FTExampleDataSource elements: (Smalltalk allClassesAndTraits sorted: [ :a :b | a name < b name ]));
		enableFilterWithAction: [ :dataSource :searchPattern :selectedRow | selectedRow browse ];
		yourself.
	list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleEasyList2
	"Show an easy list with all Morph methods and a simple menu"
	<example>
	<sampleInstance>
	| list |

	list := FTEasyListMorph new
		extent: 300@550;
		elements: Morph methods;
		icon: [ :method | (FTExampleMethodModel method: method) actionOn: nil ];
		display: [ :method | method selector ];		
		menu: [ :method | 
			MenuMorph new 
				add: ('Browse #', (method methodClass name), '>>#', method selector)
					target: method
					selector: #browse;
				add: ('Inspect #', (method methodClass name), '>>#', method selector)
					target: method
					selector: #inspect;
				yourself ];
		yourself.
		
	^ list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleListWithGenerator
	"Show a list with all Object methods"
	<example>
	<sampleInstance>
	| list |

	list := FTTableMorph new
		extent: 300@550;
		dataSource: (FTExampleMethodListGeneratorDataSource for: Object);
		yourself.
		
	^ list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleEditableList1
	<sampleInstance>
	<example>
	| list data |
	data := OrderedCollection with: 'A' with: 'B' with: 'C'.
	list := FTTableMorph new
		extent: 300 @ 550;
		dataSource: (FTExampleDropDataSource new elements: data);
		selectIndex: 1;
		showFirstSelection;
		onAnnouncement: FTStrongSelectionChanged
			do: [ :ann | 
			| index morph ed |
			index := ann selectedIndex.
			morph := list visibleRowMorphAtIndex: index.
			ed := RubFloatingEditorBuilder new
				customizeEditorWith: [ :editor | 
					editor scrollbarsShowNever.
					editor
						bounds:
							(morph bounds
								insetBy:
									(Margin
										left: -2
										top: 0
										right: 0
										bottom: 0)) ];
				withEditedContentsDo: [ :editedContents | 
					data at: index put: editedContents asString.
					list refresh ].
			ed openEditorWithContents: (data at: index) ];
		yourself.

	^ list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleSortableTable2
	"Show a table with all Object methods"

	<sampleInstance>
	<example>
	| table |
	table := FTTableMorph new
		extent: 650 @ 500;
		addColumn:
			((FTColumn id: 'Icon')
				width: 40;
				yourself);
		addColumn:
			((FTColumn id: 'Name')
				sortableOnProperty: #name;
				yourself);
		addColumn:
			((FTColumn id: 'Number of methods')
				sortableOnProperty: #numberOfMethods;
				yourself);
		addColumn:
			((FTColumn id: 'Number of instance variables')
				sortableOnProperty: #instSize;
				yourself);
		dataSource: FTExampleClassInfoTableDataSource new;
		selectFirst;
		showFirstSelection;
		beResizable;
		yourself.

	^ table openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleSortableTable1
	"Show a table with all Object methods"

	<sampleInstance>
	<example>
	| table |
	table := FTTableMorph new
		extent: 650 @ 500;
		addColumn:
			((FTColumn id: 'Name')
				sortableOnProperty: #name;
				yourself);
		addColumn:
			((FTColumn id: 'Protocol')
				sortableOnProperty: #protocol;
				yourself);
		addColumn:
			((FTColumn id: 'Origin')
				sortableOnProperty: [ :entity | entity origin name ];
				yourself);
		dataSource: (FTExampleMethodTableDataSource for: Object);
		selectFirst;
		showFirstSelection;
		onAnnouncement: FTSelectionChanged do: [ :ann | ('rows selected: ' , ann newSelectedIndexes asString) crTrace ];
		onAnnouncement: FTStrongSelectionChanged do: [ :ann | ('double-click on row: ' , ann selectedIndex asString) crTrace ];
		beMultipleSelection;
		beResizable;
		yourself.

	^ table openInWindow! !

!FTExamples class methodsFor: 'tree examples' stamp: ''!
exampleTreeWithRootFilter
	<example>
	| ds |
	ds := FTTreeDataSource
		roots: (1 to: 1000)
		children: [ :data :item | 
			item depth even
				ifTrue: [ 1 to: data / 2 ]
				ifFalse: [ 1 to: data - 1 ] ].
	ds searchStrategy: #rootsOnly.
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		enableFilter;
		explicitFunction;
		openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleList1
	"Show a list with all Object methods"
	<example>
	<sampleInstance>
	| list |

	list := FTTableMorph new
		extent: 300@550;
		dataSource: (FTExampleMethodListDataSource for: Object);
		yourself.
		
	^ list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleSortableList2
	"Show a list with all Object methods with a header"

	<example>
	<sampleInstance>
	| list |
	list := FTTableMorph new
		extent: 300 @ 550;
		addColumn:
			((FTColumn id: 'Class name')
				sortableUsing: #printString ascending;
				yourself);
		dataSource: (FTExampleDataSource elements: Smalltalk allClassesAndTraits shuffled);
		yourself.

	^ list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleDragAndDrop1
	"Show drag&drop between two lists"
	<sampleInstance>
	<example>
	| list1 list2 |

	list1 := FTTableMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		addColumn: (FTColumn id: 'Drag from me!!');
		dataSource: (FTExampleDataSource elements: (Smalltalk allClassesAndTraits sorted: [ :a :b | a name < b name ]));
		dragEnabled: true;
		yourself.
		
	list2 := FTTableMorph new 
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		addColumn: (FTColumn id: 'Drop into me!!');
		dataSource: FTExampleDropDataSource new;
		dropEnabled: true;
		yourself.
		
	^ PanelMorph new
		extent: 600@350;
		layoutPolicy: TableLayout new;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		listDirection: #leftToRight;
		cellPositioning: #topLeft;
		listCentering: #topLeft;
		wrapCentering: #topLeft;
		cellInset: 5;
		borderWidth: 0;
		addMorphBack: list1;
		addMorphBack: list2;
		openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleDragAndDrop3
	"Show drag&drop between two lists, multiple selection. 
	 Showing 50 elements, so we can test Cmd+A (select all)"
	<sampleInstance>
	<example>
	| list1 list2 |

	list1 := FTTableMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		addColumn: (FTColumn id: 'Drag from me!!');
		dataSource: (FTExampleDataSource elements: ((Smalltalk allClassesAndTraits sorted: [ :a :b | a name < b name ]) first: 50));
		dragEnabled: true;
		beMultipleSelection;
		yourself.
		
	list2 := FTTableMorph new 
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		addColumn: (FTColumn id: 'Drop into me!!');
		dataSource: FTExampleDropDataSource new;
		dropEnabled: true;
		yourself.
		
	^ PanelMorph new
		extent: 600@350;
		layoutPolicy: TableLayout new;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		listDirection: #leftToRight;
		cellPositioning: #topLeft;
		listCentering: #topLeft;
		wrapCentering: #topLeft;
		cellInset: 5;
		borderWidth: 0;
		addMorphBack: list1;
		addMorphBack: list2;
		openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
example2
	<example>
	| list |

	list := FTTableMorph new
		extent: 300@300;
		dataSource: (FTExampleDataSource elements: ((Smalltalk allClassesAndTraits 
			sorted: [ :a :b | a name < b name])
			first: 10));
		yourself.
	list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleTable4
	"Show a table with all Object methods, with a resizable header"

	<sampleInstance>
	<example>
	| table |
	table := FTTableMorph new
		extent: 650 @ 500;
		addColumn: ((FTColumn id: '#') width: 40);
		addColumn: ((FTColumn id: 'Name') width: 350);
		addColumn: (FTColumn id: 'Protocol');
		addColumn: (FTColumn id: 'Origin');
		hideColumnHeaders;
		beResizable;
		intercellSpacing: 8 @ 1;
		dataSource: (FTExampleMethodTableDataSource for: Morph);
		selectFirst;
		showFirstSelection;
		onAnnouncement: FTSelectionChanged do: [ :ann | ('rows selected: ' , ann newSelectedIndexes asString) crTrace ];
		onAnnouncement: FTStrongSelectionChanged do: [ :ann | ('double-click on row: ' , ann selectedIndex asString) crTrace ];
		beMultipleSelection;
		beResizable;
		yourself.

	^ table openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleTable5
	"Show a table with cell selection mode"

	<sampleInstance>
	<example>
	| table ds |
	ds := FTExampleMethodTableDataSource for: Object.
	table := FTTableMorph new
		extent: 650 @ 500;
		beCellSelection;
		addColumn: (FTColumn id: 'Name');
		addColumn: (FTColumn id: 'Protocol');
		addColumn: (FTColumn id: 'Origin');
		dataSource: ds;
		selectFirst;
		beMultipleSelection;
		showFirstSelection;
		yourself.
	^ table openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleTable1
	"Show a table with all Object methods"

	<sampleInstance>
	<example>
	| table |
	table := FTTableMorph new
		extent: 650 @ 500;
		addColumn: (FTColumn id: 'Name');
		addColumn: (FTColumn id: 'Protocol');
		addColumn: (FTColumn id: 'Origin');
		dataSource: (FTExampleMethodTableDataSource for: Object);
		selectFirst;
		showFirstSelection;
		onAnnouncement: FTSelectionChanged do: [ :ann | ('rows selected: ' , ann newSelectedIndexes asString) crTrace ];
		onAnnouncement: FTStrongSelectionChanged do: [ :ann | ('double-click on row: ' , ann selectedIndex asString) crTrace ];
		beMultipleSelection;
		beResizable;
		yourself.

	^ table openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleOutline2
	<example>
	| data list |
	data := OrderedCollection
		withAll:
			(Morph allSubclasses
				collect: [ :each | each allSubclasses sorted: [ :a :b | a name < b name ] ]).
	list := FTTableMorph new
		extent: 300 @ 300;
		dataSource: (FTOutlineDataSource items: data).
	list openInWindow! !

!FTExamples class methodsFor: 'tree examples' stamp: ''!
exampleexampleOneSubLevelTree
	<example>
	| ds |
	ds := FTTreeDataSource
		roots:
			((ProtoObject allSubclasses reject: [ :e | e name endsWith: 'class' ])
				sort: [ :a :b | a name < b name ])
		children: [ :item | item subclasses sort: [ :a :b | a name < b name ] ].
	ds maxDepth: 1.
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleList4
	"Show a list with all Object methods, 
		- preselects one element 
		- respond to selection changes
		- respond to strong selections (double click)"

	<sampleInstance>
	<example>
	| list |
	list := FTTableMorph new
		extent: 300 @ 550;
		dataSource: (FTExampleMethodListDataSource for: Object);
		selectIndex: 42;
		showFirstSelection;
		onAnnouncement: FTSelectionChanged
			do: [ :ann | ('row selected: ' , ann newSelectedIndexes asString) crTrace ];
		onAnnouncement: FTStrongSelectionChanged
			do:
				[ :ann | ('double-click on row: ' , ann selectedIndex asString) crTrace ];
		yourself.
	^ list openInWindow! !

!FTExamples class methodsFor: 'tree examples' stamp: ''!
exampleTree1
	<example>
	| ds |
	ds := FTTreeDataSource
		roots:
			((Collection allSubclasses reject: [ :e | e name endsWith: 'class' ])
				sort: [ :a :b | a name < b name ])
		children: [ :data | data subclasses sort: [ :a :b | a name < b name ] ].
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleDragAndDrop4
	"Show drag&drop in one list, with autoscroll"
	<sampleInstance>
	<example>
	| list |

	list := FTTableMorph new
		extent: 300@300;
		addColumn: (FTColumn id: 'Drag from & to me!!');
		dataSource: (FTExampleDropDataSource elements: (Smalltalk allClassesAndTraits sorted: [ :a :b | a name < b name ]));
		dragEnabled: true;
		dropEnabled: true;
		yourself.
		
	^ list openInWindowLabeled: 'Autoscrolling'! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleList5
	"Show a list with all Object methods, 
		- preselects one element 
		- respond to selection changes
		- respond to strong selections (double click)
		- allows multiple selection"

	<sampleInstance>
	<example>
	| list |
	list := FTTableMorph new
		extent: 300 @ 550;
		dataSource: (FTExampleMethodListDataSource for: Object);
		selectIndexes: #(42 43);
		showFirstSelection;
		onAnnouncement: FTSelectionChanged do: [ :ann | ('rows selected: ' , ann newSelectedIndexes asString) crTrace ];
		onAnnouncement: FTStrongSelectionChanged do: [ :ann | ('double-click on row: ' , ann selectedIndex asString) crTrace ];
		beMultipleSelection;
		yourself.

	^ list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleRowNotHomogeneousList1
	"Show a list with all Object methods"
	<example>
	| list |

	list := FTTableMorph new
		extent: 300@550;
		beRowNotHomogeneous;
		dataSource: (FTExampleMethodNotHomogeneousListDataSource for: Object);
		yourself.
		
	^ list openInWindow! !

!FTExamples class methodsFor: 'tree examples' stamp: ''!
exampleTreeWithVisibleItemsFilter
	<example>
	| ds |
	ds := FTTreeDataSource
		roots: (1 to: 1000)
		children: [ :data :item | 
			item depth even
				ifTrue: [ 1 to: data / 2 ]
				ifFalse: [ 1 to: data - 1 ] ].
	ds searchStrategy: #default.	"Optional"
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		enableFilter;
		explicitFunction;
		openInWindow! !

!FTExamples class methodsFor: 'tree examples' stamp: ''!
exampleTreeWithVisibleItemsSearch
	<example>
	| ds |
	ds := FTTreeDataSource
		roots: (1 to: 1000)
		children: [ :data :item | 
			item depth even
				ifTrue: [ 1 to: data / 2 ]
				ifFalse: [ 1 to: data - 1 ] ].
	ds searchStrategy: #default.	"Optional"
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		explicitFunction;
		openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleTable3
	"Show a table with all Object methods, with a header"

	<sampleInstance>
	<example>
	| table |
	table := FTTableMorph new
		extent: 650 @ 500;
		addColumn: ((FTColumn id: '#') width: 40);
		addColumn: ((FTColumn id: 'Name') width: 350);
		addColumn: (FTColumn id: 'Protocol');
		addColumn: (FTColumn id: 'Origin');
		intercellSpacing: 1;
		dataSource: (FTExampleMethodTableDataSource for: Morph);
		selectFirst;
		showFirstSelection;
		onAnnouncement: FTSelectionChanged do: [ :ann | ('rows selected: ' , ann newSelectedIndexes asString) crTrace ];
		onAnnouncement: FTStrongSelectionChanged do: [ :ann | ('double-click on row: ' , ann selectedIndex asString) crTrace ];
		beMultipleSelection;
		beResizable;
		yourself.

	^ table openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleEasyList1
	"Show an easy list with all Morph methods"
	<sampleInstance>
	<example>
	| list |

	list := FTEasyListMorph new
		extent: 300@550;
		elements: Morph methods;
		icon: [ :method | (FTExampleMethodModel method: method) actionOn: nil ];
		"display: [ :method | method selector ];	"	
		yourself.
		
	^ list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleListWithHeader
	"Show a list with all Object methods with a header"

	<example>
	<sampleInstance>
	| list |
	list := FTTableMorph new
		extent: 300 @ 550;
		addColumn: (FTColumn id: 'Method name');
		dataSource: (FTExampleMethodListDataSource for: Object);
		yourself.

	^ list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleSortableTree
	"Show a list with all Object methods with a header"

	<example>
	<sampleInstance>
	| ds |
	ds := FTTreeDataSource roots: (ProtoObject allSubclasses reject: [ :e | e isMeta ]) children: [ :data | data subclasses ].
	FTTableMorph new
		extent: 200 @ 400;
		addColumn:
			((FTColumn id: 'Class name')
				sortableOnProperty: #printString;
				yourself);
		dataSource: ds;
		openInWindow! !

!FTExamples class methodsFor: 'tree examples' stamp: ''!
exampleTreeWithRootSearch
	<example>
	| ds |
	ds := FTTreeDataSource
		roots: (1 to: 1000)
		children: [ :data :item | 
			item depth even
				ifTrue: [ 1 to: data / 2 ]
				ifFalse: [ 1 to: data - 1 ] ].
	ds searchStrategy: #rootsOnly.
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		explicitFunction;
		openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleFilterableList
	<example>
	| list |
	list := FTTableMorph new
		extent: 300 @ 300;
		dataSource:
			(FTExampleDataSource elements: (Smalltalk allClassesAndTraits sorted: [ :a :b | a name < b name ]));
		enableFilter;
		yourself.
	list openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleTableHorizontalScroll
	"Show a table with all Object methods, with a header,
	 all fixed width columns as horizontal scroll."

	"self exampleTableHorizontalScroll"

	<example>
	| table |
	table := FTTableMorph newWithHorizontalScrollBar
		extent: 650 @ 500;
		addColumn: ((FTColumn id: '#') width: 40);
		addColumn: ((FTColumn id: 'Name') width: 350);
		addColumn: ((FTColumn id: 'Protocol') width: 200);
		addColumn: ((FTColumn id: 'Origin') width: 200);
		intercellSpacing: 1;
		dataSource: (FTExampleMethodTableDataSource for: Morph);
		selectFirst;
		showFirstSelection;
		onAnnouncement: FTSelectionChanged do: [ :ann | ('rows selected: ' , ann newSelectedIndexes asString) crTrace ];
		onAnnouncement: FTStrongSelectionChanged do: [ :ann | ('double-click on row: ' , ann selectedIndex asString) crTrace ];
		beMultipleSelection;
		yourself.

	^ table openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleSortableTable3
	"Show a table with all Object methods"

	<sampleInstance>
	<example>
	| table |
	table := FTTableMorph new
		extent: 650 @ 500;
		addColumn:
			((FTColumn id: 'Icon')
				width: 40;
				yourself);
		addColumn:
			((FTColumn id: 'Name')
				sortableUsing: #name ascending;
				yourself);
		addColumn:
			((FTColumn id: 'Number of methods')
				sortableUsing: #numberOfMethods ascending , #name ascending; "Sort by number of methods, if the same, sort by name."
				yourself);
		addColumn:
			((FTColumn id: 'Number of instance variables')
				sortableUsing: #instSize ascending , #name ascending; "Sort by number of inst var, if the same, sort by name."
				yourself);
		dataSource: FTExampleClassInfoTableDataSource new;
		selectFirst;
		showFirstSelection;
		beResizable;
		yourself.

	^ table openInWindow! !

!FTExamples class methodsFor: 'function examples' stamp: ''!
exampleListWithExplicitSearch
	<example>
	| list |
	list := FTTableMorph new
		extent: 300 @ 300;
		dataSource:
			(FTExampleDataSource elements: (Smalltalk allClassesAndTraits sorted: [ :a :b | a name < b name ]));
		explicitFunction;
		yourself.
	list openInWindow! !

!FTExamples class methodsFor: 'tree examples' stamp: ''!
exampleTreeWithAllItemsFilter
	<example>
	| ds |
	ds := FTTreeDataSource
		roots: (1 to: 10)
		children: [ :data :item | 
			item depth even
				ifTrue: [ 1 to: data / 2 ]
				ifFalse: [ 1 to: data - 1 ] ].
	ds searchStrategy: #allItems.
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		enableFilter;
		explicitFunction;
		openInWindow! !

!FTExamples class methodsFor: 'tree examples' stamp: ''!
exampleTreeWithAllItemsSearch
	<example>
	| ds |
	ds := FTTreeDataSource
		roots: (1 to: 10)
		children: [ :data :item | 
			item depth even
				ifTrue: [ 1 to: data / 2 ]
				ifFalse: [ 1 to: data - 1 ] ].
	ds searchStrategy: #allItems.
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		explicitFunction;
		openInWindow! !

!FTExamples class methodsFor: 'examples' stamp: ''!
exampleTable2
	"Show a table with all Object methods, with a fixed width"

	<sampleInstance>
	<example>
	| table |
	table := FTTableMorph new
		extent: 650 @ 500;
		addColumn: ((FTColumn id: 'Name') width: 350);
		addColumn: (FTColumn id: 'Protocol');
		addColumn: (FTColumn id: 'Origin');
		dataSource: (FTExampleMethodTableDataSource for: Morph);
		selectFirst;
		showFirstSelection;
		onAnnouncement: FTSelectionChanged do: [ :ann | ('rows selected: ' , ann newSelectedIndexes asString) crTrace ];
		onAnnouncement: FTStrongSelectionChanged do: [ :ann | ('double-click on row: ' , ann selectedIndex asString) crTrace ];
		beMultipleSelection;
		beResizable;
		yourself.

	^ table openInWindow! !

!FTExamples class methodsFor: 'function examples' stamp: ''!
exampleListWithExplicitFilterAndActionButton
	<example>
	| list |
	list := FTTableMorph new
		extent: 300 @ 300;
		dataSource:
			(FTExampleDataSource
				elements: (Smalltalk allClassesAndTraits sorted: [ :a :b | a name < b name ]));
		enableFilterWithAction: [ :dataSource :searchPattern | self crTrace: searchPattern ]
			named: 'Show';
		yourself.
	list openInWindow! !

!FTFaceRec commentStamp: ''!
I implement the `FT_Face_Rec`, I am the main structure used by the library.!
!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
face_index
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_FACE_INDEX! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
bbox
	"This method was automatically generated"
	^ FTBBox fromHandle: (handle referenceStructAt: OFFSET_BBOX length: FTBBox byteSize)! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
max_advance_height: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_MAX_ADVANCE_HEIGHT put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
underline_thickness
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_UNDERLINE_THICKNESS! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
ascender: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_ASCENDER put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
ascender
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_ASCENDER! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
underline_position: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_UNDERLINE_POSITION put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
units_per_EM
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_UNITS_PER_EM! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
units_per_EM: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_UNITS_PER_EM put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
charmap: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_CHARMAP put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
bbox: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_BBOX put: anObject getHandle length: FTBBox byteSize! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
descender: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_DESCENDER put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
charmap
	"This method was automatically generated"
	^FTCharMapRec fromHandle: (handle pointerAt: OFFSET_CHARMAP)! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
num_faces: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_NUM_FACES put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
style_flags: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_STYLE_FLAGS put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
internal
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_INTERNAL) type: ExternalType void asPointerType! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
sizes_list
	"This method was automatically generated"
	^ FTListRec fromHandle: (handle referenceStructAt: OFFSET_SIZES_LIST length: FTListRec byteSize)! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
underline_thickness: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_UNDERLINE_THICKNESS put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
extensions
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_EXTENSIONS) type: ExternalType void asPointerType! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
num_fixed_sizes
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_NUM_FIXED_SIZES! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
generic: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_GENERIC put: anObject getHandle length: FTGeneric byteSize! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
style_flags
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_STYLE_FLAGS! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
internal: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_INTERNAL put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
charmaps
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_CHARMAPS) type: ExternalType void asPointerType! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
max_advance_width: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_MAX_ADVANCE_WIDTH put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
height
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_HEIGHT! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
size
	"This method was automatically generated"
	^FTSizeRec fromHandle: (handle pointerAt: OFFSET_SIZE)! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
stream: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_STREAM put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
glyph: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_GLYPH put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
style_name: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_STYLE_NAME put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
style_name
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_STYLE_NAME) type: ExternalType char asPointerType! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
face_index: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_FACE_INDEX put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
num_charmaps: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_NUM_CHARMAPS put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
num_charmaps
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_NUM_CHARMAPS! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
autohint: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_AUTOHINT put: anObject getHandle length: FTGeneric byteSize! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
num_glyphs: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_NUM_GLYPHS put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
max_advance_height
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_MAX_ADVANCE_HEIGHT! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
family_name: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_FAMILY_NAME put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
memory: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_MEMORY put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
memory
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_MEMORY) type: ExternalType void asPointerType! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
available_sizes
	"This method was automatically generated"
	^FTBitmapSize fromHandle: (handle pointerAt: OFFSET_AVAILABLE_SIZES)! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
driver: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_DRIVER put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
family_name
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_FAMILY_NAME) type: ExternalType char asPointerType! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
face_flags: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_FACE_FLAGS put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
extensions: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_EXTENSIONS put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
num_glyphs
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_NUM_GLYPHS! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
underline_position
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_UNDERLINE_POSITION! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
driver
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_DRIVER) type: ExternalType void asPointerType! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
glyph
	"This method was automatically generated"
	^FTGlyphSlotRec fromHandle: (handle pointerAt: OFFSET_GLYPH)! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
charmaps: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_CHARMAPS put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
num_fixed_sizes: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_NUM_FIXED_SIZES put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
num_faces
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_NUM_FACES! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
descender
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_DESCENDER! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
face_flags
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_FACE_FLAGS! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
size: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_SIZE put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
autohint
	"This method was automatically generated"
	^ FTGeneric fromHandle: (handle referenceStructAt: OFFSET_AUTOHINT length: FTGeneric byteSize)! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
height: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_HEIGHT put: anObject! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
sizes_list: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_SIZES_LIST put: anObject getHandle length: FTListRec byteSize! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
stream
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_STREAM) type: ExternalType void asPointerType! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
max_advance_width
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_MAX_ADVANCE_WIDTH! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
available_sizes: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_AVAILABLE_SIZES put: anObject getHandle.! !

!FTFaceRec methodsFor: 'accessing - structure variables' stamp: ''!
generic
	"This method was automatically generated"
	^ FTGeneric fromHandle: (handle referenceStructAt: OFFSET_GENERIC length: FTGeneric byteSize)! !

!FTFaceRec class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
    FT_Long           num_faces;
    FT_Long           face_index;

    FT_Long           face_flags;
    FT_Long           style_flags;

    FT_Long           num_glyphs;

    FT_String*        family_name;
    FT_String*        style_name;

    FT_Int            num_fixed_sizes;
    FT_Bitmap_Size*   available_sizes;

    FT_Int            num_charmaps;
    void*       		 charmaps;

    FT_Generic        generic;

    FT_BBox           bbox;

    FT_UShort         units_per_EM;
    FT_Short          ascender;
    FT_Short          descender;
    FT_Short          height;

    FT_Short          max_advance_width;
    FT_Short          max_advance_height;

    FT_Short          underline_position;
    FT_Short          underline_thickness;

    FT_GlyphSlot      glyph;
    FT_Size           size;
    FT_CharMap        charmap;

    FT_Driver         driver;
    FT_Memory         memory;
    FT_Stream         stream;

    FT_ListRec        sizes_list;

    FT_Generic        autohint;   
    void*             extensions; 

    FT_Face_Internal  internal;
	)! !

!FTFieldFunction commentStamp: ''!
I am an abstract class. My subclasses are some functions for a FastTable that need a field when they are use explicitely.

Description
-------------------------------------------------
I act as my superclass but I manage a field. When the user type in the field an Announcement will call #update:

Public API and Key Messages
-------------------------------------------------

- #update: anAnnoucement
	is call when the user type something into the field
	
Example (Should only be create by a FTTableMorph)
-------------------------------------------------

FTFunctionWithField table: (FTTableMorph with: (1 to: 200))

Internal Representation and Key Implementation Points.
-------------------------------------------------

    Instance Variables
	field:		I am the field to display at the bottom of the FTTableMorph!
!FTFieldFunction methodsFor: 'updating' stamp: ''!
textUpdated: anAnnouncement
	
	"do nothing by default"! !

!FTFieldFunction methodsFor: 'initialization' stamp: ''!
initializeMorph
	field := RubScrolledTextModel new newTextField
		hResizing: #spaceFill;
		autoAccept: true;
		withGhostText: self ghostText;
		yourself.
	field model announcer when: RubTextUpdatedInModel send: #textUpdated: to: self! !

!FTFieldFunction methodsFor: 'accessing' stamp: ''!
showWidget
	self initializeMorph.
	table
		addMorph: field;
		resizeAllSubviews! !

!FTFieldFunction methodsFor: 'protocol' stamp: ''!
disable
	field
		ifNotNil: [ field delete.
			field := nil ]! !

!FTFieldFunction methodsFor: 'private' stamp: ''!
resizeContainerFrom: topLeftPoint to: bottomLeftPoint
	^ topLeftPoint corner: bottomLeftPoint x @ (bottomLeftPoint y - self fieldHeigh)! !

!FTFieldFunction methodsFor: 'testing' stamp: ''!
isExplicit
	^ field isNotNil! !

!FTFieldFunction methodsFor: 'accessing' stamp: ''!
beExplicit
	self initializeMorph.
	table
		addMorph: field;
		resizeAllSubviews! !

!FTFieldFunction methodsFor: 'accessing' stamp: ''!
fieldHeigh
	^ StandardFonts defaultFont pixelSize + 10! !

!FTFieldFunction methodsFor: 'private' stamp: ''!
resizeWidget
	| topLeft bottomRight |
	self flag: #pharoTodo.	"Maybe it could be cool to let the user choose if the field need to be at the top or the bottom."
	topLeft := table bounds left @ (table bounds bottom - self fieldHeigh - table horizontalScrollBarHeight ).
	bottomRight := (table bounds right - table verticalScrollBarWidth) @ (table bottom - table horizontalScrollBarHeight).
	field bounds: (topLeft corner: bottomRight)! !

!FTFieldFunction methodsFor: 'widget API' stamp: ''!
ghostText
	self subclassResponsibility! !

!FTFieldFunction class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = FTFieldFunction! !

!FTFilter commentStamp: ''!
I am root of filter classes which are used by FTFilterFunction

My subclasses shoud implement method #matches: to filter given strings.

Public API and Key Messages

- matches: aString   
 
Internal Representation and Key Implementation Points.

    Instance Variables
	pattern:		<String>!
!FTFilter methodsFor: 'accessing' stamp: ''!
pattern: anObject
	pattern := anObject! !

!FTFilter methodsFor: 'matching' stamp: ''!
matches: aString

	self subclassResponsibility! !

!FTFilter methodsFor: 'accessing' stamp: ''!
pattern
	^ pattern! !

!FTFilter class methodsFor: 'instance creation' stamp: ''!
pattern: aString
	^self new 
		pattern: aString! !

!FTFilterFunction commentStamp: ''!
I define a filter function for a table. 
I respond to any alphanumeric element and I add a filter box to the  owner table. 

In general, my entry point is through #keyStroke:, because I intend to react to keyboard inputs in the owner table.

I save an initial data source if the user want to see some result already filter.

I use a semaphore in order to let a delay before I filter the table. With this the user is able to type more than 1 letter before I filter.

/!!\ To use me the data source must implement the method #newDataSourceMatching: aRegex!
!FTFilterFunction methodsFor: '*Calypso-Browser' stamp: ''!
initialDataSource
	^initialDataSource! !

!FTFilterFunction methodsFor: 'updating' stamp: ''!
textUpdated: anAnnouncement
	self filterWith: field getTextFromModel! !

!FTFilterFunction methodsFor: 'private' stamp: ''!
showFilterFieldFromKeystrokeEvent: anEvent
	| text ed |
	text := anEvent keyCharacter asString asText.
	self initializeFilter.
	self filterWith: text.
	ed := RubFloatingEditorBuilder new
		customizeEditorWith: [ :editor | editor bounds: (self table bottomLeft + (0 @ 2) corner: self table bottomRight + (0 @ (editor font height + 6))) ];
		withEditedContentsDo: [ :contents :editor | 
			self filterWith: contents.
			editor setTextWith: (self colorText: contents) ].
	ed autoAccept: true.
	ed whenEditorEscapedDo:[self reinitializeTable ].
	ed openEditorWithContents: (self colorText: text)! !

!FTFilterFunction methodsFor: '*Calypso-Browser' stamp: ''!
terminateFilterProcess
	isEditingSemaphore ifNotNil: [ isEditingSemaphore terminateProcess ]! !

!FTFilterFunction methodsFor: 'updating' stamp: ''!
filterWith: aStringOrText
	initialDataSource ifNil: [ self initializeFilter ].	"I do this in case the filter is use explicictly in the FT, at the first call the Filter will not be initialize."
	pattern := aStringOrText asString trimBoth.
	isEditingSemaphore signal! !

!FTFilterFunction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	filterClass := FTRegexFilter! !

!FTFilterFunction methodsFor: 'updating' stamp: ''!
patternFromString: aString
	" do not throw an error if the pattern is bad - important in case of auto-accepting"

	^ [ aString asRegexIgnoringCase ]
		on: RegexSyntaxError
		do: [ :ex |  ]! !

!FTFilterFunction methodsFor: '*Calypso-Browser' stamp: ''!
filterNowWith: patternString
	pattern := patternString.
	self field setText: pattern.
	self filterWith: pattern.
	self filter.! !

!FTFilterFunction methodsFor: 'updating' stamp: ''!
colorText: aText
	table dataSource numberOfRows ~= 0
		ifTrue: [ aText makeAllColor: self table theme textColor ]
		ifFalse: [ aText addAttribute: (TextColor new color: Color red) ].
	^ aText! !

!FTFilterFunction methodsFor: 'initialization' stamp: ''!
reinitializeTable
	table dataSource: initialDataSource.
	^ true! !

!FTFilterFunction methodsFor: 'updating' stamp: ''!
filter
	pattern ifNil: [ ^ self ].

	table dataSource: (pattern ifEmpty: [ initialDataSource ] ifNotEmpty: [ initialDataSource newDataSourceMatching: (filterClass pattern: pattern) ]).
	table refresh.
	table deselectAll.
		
	self isExplicit
		ifTrue: [ self resizeWidget ]! !

!FTFilterFunction methodsFor: '*Calypso-Browser' stamp: ''!
initialDataSource: aDataSource
	initialDataSource := aDataSource! !

!FTFilterFunction methodsFor: 'accessing' stamp: ''!
filterClass
	^filterClass! !

!FTFilterFunction methodsFor: 'event handling' stamp: ''!
keyStroke: anEvent
	self isExplicit ifTrue: [ ^false ].
	
	self showFilterFieldFromKeystrokeEvent: anEvent.
	^ true! !

!FTFilterFunction methodsFor: 'event handling' stamp: ''!
keyDown: anEvent
	self isExplicit ifTrue: [ ^false ].
	
	"If the user escape after a search, he want the full data source again so we reinitialize the table."
	(anEvent keyCharacter = Character escape and: [ initialDataSource isNotNil ])
		ifTrue: [ ^ self reinitializeTable ].
	^ false! !

!FTFilterFunction methodsFor: 'initialization' stamp: ''!
initializeFilter
	initialDataSource := table dataSource.
	isEditingSemaphore := Semaphore new.
	self spawnFilterUpdateThread! !

!FTFilterFunction methodsFor: '*Calypso-Browser' stamp: ''!
pattern
	^pattern! !

!FTFilterFunction methodsFor: 'initialization' stamp: ''!
reset
	"self filter"! !

!FTFilterFunction methodsFor: 'updating' stamp: ''!
spawnFilterUpdateThread
	"Runs in background, thank to Henrik Johansen for this"

	[ | oldPattern |
	oldPattern := nil.
	[ isEditingSemaphore wait.
	"If pattern has changed, see if we need to filter.
	If not, it's probably an extraneous signal received while we were waiting for 0.2 seconds, and we discard then till we end up waiting for filterChangeSemaphore again"
	oldPattern ~= pattern
		ifTrue: [ oldPattern := pattern.
			0.2 seconds wait.
			"Pattern still the same? If not, just loop again and end up waiting for another 0.2 secs"
			oldPattern = pattern
				ifTrue: [ self filter ] ] ] repeat ] forkAt: Processor userBackgroundPriority! !

!FTFilterFunction methodsFor: 'accessing' stamp: ''!
filterClass: aFTFilterClass
	filterClass := aFTFilterClass! !

!FTFilterFunction methodsFor: 'widget API' stamp: ''!
ghostText
	^ 'Filter...'! !

!FTFilterFunction methodsFor: '*Calypso-Browser' stamp: ''!
field
	^field! !

!FTFilterFunctionWithAction commentStamp: ''!
I am a Filter widget that also have an action button.

Description
-------------------------------------------------
I am use as a FilterFunction but I also have a Button. I am use by FTTableMorph.

Public API and Key Messages
-------------------------------------------------

- #table: aTableMorph action: aBlock named: aString
	is my constructor. The block is the action to be executed by the button and the string is the name of the button.
	

Internal Representation and Key Implementation Points.
-------------------------------------------------

    Instance Variables
	actionBlock:		I am a block that need to be executed when the user press the button
	actionButton:		I am the button of the widget

The action block can takes 3 parameters:
- The filtered data source
- The pattern on the filter field 
- The selected element on the table!
!FTFilterFunctionWithAction class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!FTFunction commentStamp: ''!
I am an abstract class. My subclasses are some functions for a FastTable as search or filter.

Description
-------------------------------------------------
I can be use in two way.  Implicitely I will not appear on the FastTable. Explicitely I can display a Widget on the FastTable.
I work with  a FTTableMorph. I cannot be use alone.

Public API and Key Messages
-------------------------------------------------

- #table: aTableMorph
	is my constructor
	
- #keyStroke: anEvent
	This is the method that will allow to use me implicitely. With this I will receive an event from the FastTable.
	
- #beExplicite
	This method will make my functionnality explicit. For example the FTFilterFunction will display a filter field.
	
Example (Should only be create by a FTTableMorph)
-------------------------------------------------

FTFunction table: (FTTableMorph with: (1 to: 200))


Internal Representation and Key Implementation Points.
-------------------------------------------------

    Instance Variables
	table 	I am a FTTableMorph that use this function.
!
!FTFunction methodsFor: 'accessing' stamp: ''!
showWidget
	"A FastTable can have a special function. Most of these functions are hidden by default. This method make them explicit. 
	For exemple a FastTable can have a search field. By default the user need to type to show it. With this method the widget should be alwayse visible.
	My subclasses should describe what to do to be explicit."

	self subclassResponsibility! !

!FTFunction methodsFor: 'protocol' stamp: ''!
disable
	"I am call when a FastTable disable a function."

	self subclassResponsibility! !

!FTFunction methodsFor: 'initialization' stamp: ''!
initializeTable: aTable
	table := aTable.
	self initialize! !

!FTFunction methodsFor: 'private' stamp: ''!
resizeContainerFrom: topLefPoint to: bottomRightPoint
	"I takes takes the bounds of the container of the Fast Table. I return a rectangle that is the bounds of the container."

	self subclassResponsibility! !

!FTFunction methodsFor: 'event handling' stamp: ''!
keyStroke: anEvent
	"If the widget is implicit this method will be call if the user want to communicate with the widget."

	self subclassResponsibility! !

!FTFunction methodsFor: 'event handling' stamp: ''!
keyDown: anEvent
	"If the widget is implicit this method will be call if the user want to communicate with the widget."

	"Do not handle the event by default"
	^ false! !

!FTFunction methodsFor: 'testing' stamp: ''!
isExplicit
	"See FTFunctionWithField to get an example."

	self subclassResponsibility! !

!FTFunction methodsFor: 'accessing' stamp: ''!
beExplicit
	"This method is call by the FastTable if the user want the widget to be explicit. Describe what to do to be explicit."

	self subclassResponsibility! !

!FTFunction methodsFor: 'accessing' stamp: ''!
table
	^ table! !

!FTFunction methodsFor: 'initialization' stamp: ''!
reset
	self subclassResponsibility! !

!FTFunction methodsFor: 'private' stamp: ''!
resizeWidget
	self subclassResponsibility! !

!FTFunction class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #table:'! !

!FTFunction class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = FTFunction! !

!FTFunction class methodsFor: 'instance creation' stamp: ''!
table: aFastTableMorph
	^ self basicNew
		initializeTable: aFastTableMorph;
		yourself! !

!FTFunctionWithField commentStamp: ''!
I am an abstract class. My subclasses are some functions for a FastTable that need a field when they are use explicitely.

Description
-------------------------------------------------
I act as my superclass but I manage a field. When the user type in the field an Announcement will call #update:

Public API and Key Messages
-------------------------------------------------

- #update: anAnnoucement
	is call when the user type something into the field
	
Example (Should only be create by a FTTableMorph)
-------------------------------------------------

FTFunctionWithField table: (FTTableMorph with: (1 to: 200))

Internal Representation and Key Implementation Points.
-------------------------------------------------

    Instance Variables
	field:		I am the field to display at the bottom of the FTTableMorph!
!FTFunctionWithField class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!FTGeneric commentStamp: ''!
I implement the FT_Generic type!
!FTGeneric methodsFor: 'accessing - structure variables' stamp: ''!
data: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_DATA put: anObject getHandle.! !

!FTGeneric methodsFor: 'accessing - structure variables' stamp: ''!
data
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_DATA) type: ExternalType void asPointerType! !

!FTGeneric methodsFor: 'accessing - structure variables' stamp: ''!
finalizer: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_FINALIZER put: anObject getHandle.! !

!FTGeneric methodsFor: 'accessing - structure variables' stamp: ''!
finalizer
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_FINALIZER) type: ExternalType void asPointerType! !

!FTGeneric class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
	 void*  data;
    void*  finalizer;)! !

!FTGlyphMetrics commentStamp: ''!
I Implement the `FT_Glyph_Metrics` type!
!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
width: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_WIDTH put: anObject! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
width
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_WIDTH! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
horiBearingY
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_HORIBEARINGY! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
vertAdvance: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_VERTADVANCE put: anObject! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
vertBearingY: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_VERTBEARINGY put: anObject! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
vertBearingX: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_VERTBEARINGX put: anObject! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
height
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_HEIGHT! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
height: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_HEIGHT put: anObject! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
horiBearingX: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_HORIBEARINGX put: anObject! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
horiBearingX
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_HORIBEARINGX! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
vertBearingY
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_VERTBEARINGY! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
vertBearingX
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_VERTBEARINGX! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
vertAdvance
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_VERTADVANCE! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
horiAdvance: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_HORIADVANCE put: anObject! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
horiAdvance
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_HORIADVANCE! !

!FTGlyphMetrics methodsFor: 'accessing - structure variables' stamp: ''!
horiBearingY: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_HORIBEARINGY put: anObject! !

!FTGlyphMetrics class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(    
	 FT_Pos  width;
    FT_Pos  height;

    FT_Pos  horiBearingX;
    FT_Pos  horiBearingY;
    FT_Pos  horiAdvance;

    FT_Pos  vertBearingX;
    FT_Pos  vertBearingY;
    FT_Pos  vertAdvance;)! !

!FTGlyphSlotRec commentStamp: ''!
I Implement the `FT_GlyphSlot_Rec`, I am the structure where the glyphs are stored when reading from a font.!
!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
other
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_OTHER) type: ExternalType void asPointerType! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
reserved
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_RESERVED! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
generic
	"This method was automatically generated"
	^ FTGeneric fromHandle: (handle referenceStructAt: OFFSET_GENERIC length: FTGeneric byteSize)! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
face: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_FACE put: anObject getHandle.! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
metrics
	"This method was automatically generated"
	^ FTGlyphMetrics fromHandle: (handle referenceStructAt: OFFSET_METRICS length: FTGlyphMetrics byteSize)! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
num_subglyphs: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_NUM_SUBGLYPHS put: anObject! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
next: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_NEXT put: anObject getHandle.! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
bitmap: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_BITMAP put: anObject getHandle length: FTBitmap byteSize! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
library: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_LIBRARY put: anObject getHandle.! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
subglyphs: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_SUBGLYPHS put: anObject getHandle.! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
num_subglyphs
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_NUM_SUBGLYPHS! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
library
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_LIBRARY) type: ExternalType void asPointerType! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
control_data: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_CONTROL_DATA put: anObject getHandle.! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
linearHoriAdvance
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_LINEARHORIADVANCE! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
bitmap_left
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_BITMAP_LEFT! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
reserved: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_RESERVED put: anObject! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
linearVertAdvance
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_LINEARVERTADVANCE! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
control_len
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_CONTROL_LEN! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
format: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_FORMAT put: anObject! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
internal
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_INTERNAL) type: ExternalType void asPointerType! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
bitmap_top: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_BITMAP_TOP put: anObject! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
advance
	"This method was automatically generated"
	^ FTVector fromHandle: (handle referenceStructAt: OFFSET_ADVANCE length: FTVector byteSize)! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
face
	"This method was automatically generated"
	^FTFaceRec fromHandle: (handle pointerAt: OFFSET_FACE)! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
metrics: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_METRICS put: anObject getHandle length: FTGlyphMetrics byteSize! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
advance: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_ADVANCE put: anObject getHandle length: FTVector byteSize! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
control_data
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_CONTROL_DATA) type: ExternalType void asPointerType! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
format
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_FORMAT! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
generic: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_GENERIC put: anObject getHandle length: FTGeneric byteSize! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
bitmap_left: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_BITMAP_LEFT put: anObject! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
lsb_delta
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_LSB_DELTA! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
next
	"This method was automatically generated"
	^FTGlyphSlotRec fromHandle: (handle pointerAt: OFFSET_NEXT)! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
linearHoriAdvance: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_LINEARHORIADVANCE put: anObject! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
bitmap
	"This method was automatically generated"
	^ FTBitmap fromHandle: (handle referenceStructAt: OFFSET_BITMAP length: FTBitmap byteSize)! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
internal: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_INTERNAL put: anObject getHandle.! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
outline: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_OUTLINE put: anObject getHandle length: FTOutline byteSize! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
other: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_OTHER put: anObject getHandle.! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
linearVertAdvance: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_LINEARVERTADVANCE put: anObject! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
control_len: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_CONTROL_LEN put: anObject! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
lsb_delta: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_LSB_DELTA put: anObject! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
rsb_delta
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_RSB_DELTA! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
rsb_delta: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_RSB_DELTA put: anObject! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
subglyphs
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_SUBGLYPHS) type: ExternalType void asPointerType! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
outline
	"This method was automatically generated"
	^ FTOutline fromHandle: (handle referenceStructAt: OFFSET_OUTLINE length: FTOutline byteSize)! !

!FTGlyphSlotRec methodsFor: 'accessing - structure variables' stamp: ''!
bitmap_top
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_BITMAP_TOP! !

!FTGlyphSlotRec class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
    FT_Library        library;
    FT_Face           face;
    FT_GlyphSlot      next;
    FT_UInt           reserved;
    FT_Generic        generic;

    FT_Glyph_Metrics  metrics;
    FT_Fixed          linearHoriAdvance;
    FT_Fixed          linearVertAdvance;
    FT_Vector         advance;

    FT_Glyph_Format   format;

    FT_Bitmap         bitmap;
    FT_Int            bitmap_left;
    FT_Int            bitmap_top;

    FT_Outline        outline;

    FT_UInt           num_subglyphs;
    FT_SubGlyph       subglyphs;

    void*             control_data;
    long              control_len;

    FT_Pos            lsb_delta;
    FT_Pos            rsb_delta;

    void*             other;

    FT_Slot_Internal  internal;)! !

!FTHeaderColumnCellMorph commentStamp: ''!
I represent a column header cell morph, i handle mouse click and double to trigger the needed functionalities.!
!FTHeaderColumnCellMorph methodsFor: 'accessing' stamp: ''!
column
	^ column! !

!FTHeaderColumnCellMorph methodsFor: 'event handling' stamp: ''!
mouseDown: event
	self column sortDataSource: self table dataSource! !

!FTHeaderColumnCellMorph methodsFor: 'accessing' stamp: ''!
column: aColumn
	column  := aColumn! !

!FTHeaderColumnCellMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: event
	^ false! !

!FTHeaderColumnCellMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: event
	^ true! !

!FTIndentedCellMorph commentStamp: ''!
FTCell with adjustable indentation in the X axis that can be configured so that children will be laid out from indentation to #right.

!
!FTIndentedCellMorph methodsFor: 'initialization' stamp: ''!
initialize
	
	indentation := 0. "must be before super"
	
	super initialize.
	
	self cellInset: 2.! !

!FTIndentedCellMorph methodsFor: 'layout' stamp: ''!
addIndendtation: aNumber

	indentation := indentation + aNumber + self cellInset! !

!FTIndentedCellMorph methodsFor: 'layout' stamp: ''!
layoutBounds

	| inner | 
	
	inner := self innerBounds.
	
	^indentation = 0 
		ifTrue: [ inner ]
		ifFalse: [ ((indentation@0)+inner origin) corner: inner corner ]! !

!FTIndentedCellMorph methodsFor: 'layout' stamp: ''!
depthIndent: aNumber

	aNumber timesRepeat: [ self addIndendtation: 16 ]! !

!FTIndentedCellMorph methodsFor: 'layout' stamp: ''!
indentBy: aNumber

	indentation := aNumber + self cellInset! !

!FTListRec commentStamp: ''!
I implement the `FT_LIST_REC`, I am used as a linked list inside the FT library.!
!FTListRec methodsFor: 'accessing - structure variables' stamp: ''!
head: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_HEAD put: anObject getHandle.! !

!FTListRec methodsFor: 'accessing - structure variables' stamp: ''!
tail: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_TAIL put: anObject getHandle.! !

!FTListRec methodsFor: 'accessing - structure variables' stamp: ''!
tail
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_TAIL) type: ExternalType void asPointerType! !

!FTListRec methodsFor: 'accessing - structure variables' stamp: ''!
head
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_HEAD) type: ExternalType void asPointerType! !

!FTListRec class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
    FT_ListNode  head;
    FT_ListNode  tail;
)! !

!FTMatrix commentStamp: ''!
I implement the FT_Matrix type, I am a matrix of 2x2 for transformations.!
!FTMatrix methodsFor: 'accessing - structure variables' stamp: ''!
yy: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_YY put: anObject! !

!FTMatrix methodsFor: 'accessing - structure variables' stamp: ''!
xy
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_XY! !

!FTMatrix methodsFor: 'accessing - structure variables' stamp: ''!
yx
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_YX! !

!FTMatrix methodsFor: 'accessing - structure variables' stamp: ''!
xy: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_XY put: anObject! !

!FTMatrix methodsFor: 'accessing - structure variables' stamp: ''!
xx: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_XX put: anObject! !

!FTMatrix methodsFor: 'accessing - structure variables' stamp: ''!
xx
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_XX! !

!FTMatrix methodsFor: 'accessing - structure variables' stamp: ''!
yy
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_YY! !

!FTMatrix methodsFor: 'accessing - structure variables' stamp: ''!
yx: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_YX put: anObject! !

!FTMatrix class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(    
		FT_Fixed  	xx
		FT_Fixed 	xy
    	FT_Fixed  	yx 
		FT_Fixed 	yy
)! !

!FTMultipleSelection class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!FTMultipleSelectionStrategy commentStamp: ''!
I define the multiple selection strategy. 
I allow tables using me to manage multiple selection rows.!
!FTMultipleSelectionStrategy methodsFor: 'private' stamp: ''!
selectAppendingIndex: index
	| currentSelection newSelection |
	currentSelection := self table selectedIndexes.
	
	newSelection := (currentSelection includes: index)
		ifTrue: [ currentSelection copyWithout: index ]
		ifFalse: [ currentSelection copyWithFirst: index].
		
	self table selectIndexes: newSelection! !

!FTMultipleSelectionStrategy methodsFor: 'testing' stamp: ''!
isMultiple
	^ true! !

!FTMultipleSelectionStrategy methodsFor: 'accessing' stamp: ''!
selectIndex: index event: event
	event shiftPressed ifTrue: [ ^ self selectIndexesUpTo: index ].
	OSPlatform current isMacOS
		ifTrue: [ event commandKeyPressed ifTrue: [ ^ self selectAppendingIndex: index ] ]
		ifFalse: [ event controlKeyPressed ifTrue: [ ^ self selectAppendingIndex: index ] ].
	self toggleIndex: index! !

!FTMultipleSelectionStrategy methodsFor: 'private' stamp: ''!
selectIndexes: index previous: oldSelection
	"I ensure the selected index is the first in selection range so I can handle it better. 
	 I do not like to assume and probably I will need the concept of 'selection', but for now 
	 let's not abuse :)"

	self table selectIndexes: (((oldSelection includes: index) ifTrue: [ oldSelection copyWithout: index ] ifFalse: [ oldSelection ]) copyWithFirst: index)! !

!FTMultipleSelectionStrategy methodsFor: 'private' stamp: ''!
selectIndexesUpTo: endIndex
	"Selects a range of selectables, from what is already selected to a new index. 
	 This is used in case of multiple selections (when holding shift)"

	| oldSelected firstIndex |
	oldSelected := self table selectedIndexes.
	firstIndex :=  oldSelected 
		ifNotEmpty: [ oldSelected first ]
		ifEmpty: [ endIndex ].

	self selectIndexes: endIndex previous: (oldSelected union: (self table selectionModeStrategy indexesToSelectInMultipleSelectionFrom: firstIndex to: endIndex))! !

!FTNilFunction commentStamp: ''!
I am a Function that do nothing to use a Null Object Pattern.
	
Example (Should only be create by a FTTableMorph)
-------------------------------------------------

FTNilFunction table: (FTTableMorph with: (1 to: 200))
!
!FTNilFunction methodsFor: 'accessing' stamp: ''!
showWidget
	"Do nothing"! !

!FTNilFunction methodsFor: 'protocol' stamp: ''!
disable
	"Do nothing"! !

!FTNilFunction methodsFor: 'private' stamp: ''!
resizeContainerFrom: topLefPoint to: bottomRightPoint
	"I do not change the size of the container."

	^ topLefPoint corner: bottomRightPoint! !

!FTNilFunction methodsFor: 'event handling' stamp: ''!
keyStroke: anEvent
	"Do nothing"
	^ false! !

!FTNilFunction methodsFor: 'testing' stamp: ''!
isExplicit
	^ false! !

!FTNilFunction methodsFor: 'accessing' stamp: ''!
beExplicit
	"Do nothing"! !

!FTNilFunction methodsFor: 'initialization' stamp: ''!
reset! !

!FTNilFunction methodsFor: 'private' stamp: ''!
resizeWidget
	"Do nothing"! !

!FTNullColumnSortingStrategy commentStamp: ''!
Description
--------------------

I am class managing the behavior of the sorting of a FastTable when the sorting is disabled.

By default I will display nothing in the header cell and do nothing we I am asked to sort the datasource of the table.!
!FTNullColumnSortingStrategy methodsFor: 'testing' stamp: ''!
isSortingEnabled
	^ false! !

!FTNullColumnSortingStrategy methodsFor: 'sorting' stamp: ''!
sortDataSource: aDataSource
	"Nothing to do here"! !

!FTNullColumnSortingStrategy methodsFor: 'initialization' stamp: ''!
reset
	"Nothing for this one"! !

!FTNullColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
sortingIcon
	^ nil! !

!FTNullColumnSortingStrategyTest commentStamp: ''!
A FTNullColumnSortingStrategyTest is a test class for testing the behavior of FTNullColumnSortingStrategy!
!FTNullColumnSortingStrategyTest methodsFor: 'tests' stamp: ''!
testSortDataSource
	| dataSource |
	dataSource := self dataSourceForTesting.
	self assert: dataSource elements equals: self elementsForTestDataSource.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: self elementsForTestDataSource! !

!FTNullColumnSortingStrategyTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ FTNullColumnSortingStrategy! !

!FTOutline commentStamp: ''!
I am the FT_Outline mapping.!
!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
contours
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_CONTOURS) type: ExternalType short asPointerType! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
points
	"This method was automatically generated"
	^FTVector fromHandle: (handle pointerAt: OFFSET_POINTS)! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
n_contours: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_N_CONTOURS put: anObject! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
tags
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_TAGS) type: ExternalType char asPointerType! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
points: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_POINTS put: anObject getHandle.! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
n_contours
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_N_CONTOURS! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
n_points: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_N_POINTS put: anObject! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
tags: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_TAGS put: anObject getHandle.! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
contours: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_CONTOURS put: anObject getHandle.! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
n_points
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_N_POINTS! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
flags: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_FLAGS put: anObject! !

!FTOutline methodsFor: 'accessing - structure variables' stamp: ''!
flags
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_FLAGS! !

!FTOutline class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
	 short       n_contours;
    short       n_points;

    FT_Vector*  points;
    char*       tags;
    short*      contours;

    int         flags;
)! !

!FTOutlineDataSource commentStamp: ''!
I'm a data source which will have many list of elements. My goal is to allow a FTOutlineTable to render me with separators between my differents items.

Users might want to subclass me to have better options.!
!FTOutlineDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
	| cell |
	cell := FTCellMorph new
		addMorphBack: (self elementAt: rowIndex) asMorph;
		yourself.
	(self needSeparatorBefore: rowIndex)
		ifTrue: [ cell withTopSeparator ].
	^ cell! !

!FTOutlineDataSource methodsFor: 'accessing' stamp: ''!
newDataSourceMatching: aFTFilter
	| newItems |
	newItems := items class withAll: (items collect: [ :coll | coll select: [ :each | aFTFilter matches: (self toString: each) ] ]).
	^ self class new items: newItems! !

!FTOutlineDataSource methodsFor: 'accessing' stamp: ''!
elementAt: index
	| tmpIndex |
	tmpIndex := index.
	self items
		do: [ :elements | 
			tmpIndex <= elements size
				ifTrue: [ ^ elements at: tmpIndex ]
				ifFalse: [ tmpIndex := tmpIndex - elements size ] ].
	self errorSubscriptBounds: index! !

!FTOutlineDataSource methodsFor: 'testing' stamp: ''!
needSeparatorBefore: index
	| tmpIndex |
	index <= 1
		ifTrue: [ ^ false ].
	tmpIndex := index.
	self items
		do: [ :elements | 
			elements size >= tmpIndex
				ifTrue: [ ^ tmpIndex = 1 ]
				ifFalse: [ tmpIndex := tmpIndex - elements size ] ].
	self errorSubscriptBounds: index! !

!FTOutlineDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString
	| index result |
	aString isEmptyOrNil
		ifTrue: [ ^ #() ].
	index := 0.
	result := OrderedCollection new.
	self items
		do: [ :elements | 
			elements
				do: [ :each | 
					index := index + 1.
					((self toString: each) beginsWith: aString)
						ifTrue: [ result add: index ] ] ].
	^ result asArray! !

!FTOutlineDataSource methodsFor: 'accessing' stamp: ''!
items: anObject
	items := anObject! !

!FTOutlineDataSource methodsFor: 'accessing' stamp: ''!
numberOfRows
	^ self items
		ifNotNil: [ | cpt |
			cpt := 0.
			self items do: [ :elements | cpt := cpt + elements size ].
			cpt ]
		ifNil: [ 0 ]! !

!FTOutlineDataSource methodsFor: 'accessing' stamp: ''!
headerColumn: column
	^ self basicHeaderCellFor: column! !

!FTOutlineDataSource methodsFor: 'accessing' stamp: ''!
items
	^ items! !

!FTOutlineDataSource class methodsFor: 'instance creation' stamp: ''!
items: aCollectionOfCollection
	" I take a collection of collection of elements."

	^ self new
		items: aCollectionOfCollection;
		yourself! !

!FTPClient commentStamp: ''!
A minimal FTP client program.  Could store all state in inst vars, and use an instance to represent the full state of a connection in progress.  But simpler to do all that in one method and have it be a complete transaction.

Always operates in passive mode (PASV).  All connections are initiated from client in order to get through firewalls.

See ServerDirectory openFTP, ServerDirectory getFileNamed:, ServerDirectory putFile:named: for examples of use.

See TCP/IP, second edition, by Dr. Sidnie Feit, McGraw-Hill, 1997, Chapter 14, p311.!
!FTPClient methodsFor: 'private' stamp: ''!
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: ''!
dataSocket
	^dataSocket! !

!FTPClient methodsFor: 'private - protocol' stamp: ''!
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: ''!
getDataInto: dataStream
	"Reel in all data until the server closes the connection.  At the same time, watch for errors on otherSocket.  Don't know how much is coming.  Put the data on the stream."

	| buf bytesRead |
	buf := String new: 4000.
	[self dataSocket isConnected or: [self dataSocket dataAvailable]]
		whileTrue: [
			self checkForPendingError.
			bytesRead := self dataSocket receiveDataWithTimeoutInto: buf.
			1 to: bytesRead do: [:ii | dataStream nextPut: (buf at: ii)]].
	dataStream reset.	"position: 0."
	^ dataStream! !

!FTPClient methodsFor: 'protocol' stamp: ''!
pwd
	| result |
	self sendCommand: 'PWD'.
	self lookForCode: 257.
	result := self lastResponse.
	^result copyFrom: (result indexOf: $")+1 to: (result lastIndexOf: $")-1! !

!FTPClient methodsFor: 'protocol' stamp: ''!
renameFileNamed: oldFileName to: newFileName
	self sendCommand: 'RNFR ' , oldFileName.
	self lookForCode: 350.
	self sendCommand: 'RNTO ' , newFileName.
	self lookForCode: 250! !

!FTPClient methodsFor: 'protocol' stamp: ''!
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: ''!
abortDataConnection
	self sendCommand: 'ABOR'.
	self closeDataSocket! !

!FTPClient methodsFor: 'protocol' stamp: ''!
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: ''!
putFileNamed: filePath as: fileNameOnServer
	"FTP a file to the server."

	filePath asFileReference readStreamDo: [ :fileStream |
		self putFileStreamContents: fileStream as: fileNameOnServer
	]! !

!FTPClient methodsFor: 'protocol' stamp: ''!
makeDirectory: newDirName
	self sendCommand: 'MKD ' , newDirName.
	self checkResponse.! !

!FTPClient methodsFor: 'private' stamp: ''!
sendStreamContents: aStream
	self dataSocket sendStreamContents: aStream checkBlock: [self checkForPendingError. true]! !

!FTPClient methodsFor: 'private' stamp: ''!
dataSocket: aSocket
	dataSocket := aSocket! !

!FTPClient methodsFor: 'protocol' stamp: ''!
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: ''!
loginUser: userName password: passwdString

	self user: userName.
	self password: passwdString.

	self login! !

!FTPClient methodsFor: 'protocol' stamp: ''!
quit
	self sendCommand: 'QUIT'.
	self close! !

!FTPClient methodsFor: 'protocol' stamp: ''!
ascii
	self sendCommand: 'TYPE A'.
	self lookForCode: 200! !

!FTPClient methodsFor: 'protocol' stamp: ''!
deleteFileNamed: fileName
	self sendCommand: 'DELE ' , fileName.
	self checkResponse.! !

!FTPClient methodsFor: 'private - protocol' stamp: ''!
getData

	| dataStream |
	dataStream := (String new: 4000) writeStream.
	self getDataInto: dataStream.
	self closeDataSocket.
	^dataStream contents! !

!FTPClient methodsFor: 'protocol' stamp: ''!
deleteDirectory: dirName
	self sendCommand: 'RMD ' , dirName.
	self checkResponse.! !

!FTPClient methodsFor: 'protocol' stamp: ''!
binary
	self sendCommand: 'TYPE I'.
	self lookForCode: 200! !

!FTPClient methodsFor: 'protocol' stamp: ''!
changeDirectoryTo: newDirName
	self sendCommand: 'CWD ' , newDirName.
	self checkResponse.! !

!FTPClient methodsFor: 'protocol' stamp: ''!
getDirectory
	| dirList |
	self openPassiveDataConnection.
	self sendCommand: 'LIST'.
	dirList := self getData.
	self checkResponse.
	self checkResponse.
	^dirList! !

!FTPClient methodsFor: 'private' stamp: ''!
closeDataSocket
	self dataSocket
		ifNotNil: [
			self dataSocket closeAndDestroy.
			self dataSocket: nil]! !

!FTPClient methodsFor: 'private - protocol' stamp: ''!
lookForCode: code ifDifferent: handleBlock 
	"We are expecting a certain numeric code next.  
	However, in the FTP protocol, multiple lines are allowed.  
	If the response is multi-line, the fourth character of the first line is a  
	$- and the last line repeats the numeric code but the code is followed by 
	a space. So it's possible that there are more lines left of the last response that 
	we need to throw away. We use peekForAll: so that we don't discard the
	next response that is not a continuation line."

	
	"check for multi-line response"
	(self lastResponse size > 3
			and: [(self lastResponse at: 4) = $-])
		ifTrue: ["Discard continuation lines."
			 | headToDiscard |
			headToDiscard := self lastResponse first: 4.
			[[self stream peekForAll: headToDiscard]
				whileTrue: [self stream nextLine]]
				on: Exception
				do: [:ex | ^handleBlock value: nil]].
	^ super lookForCode: code ifDifferent: handleBlock! !

!FTPClient methodsFor: 'protocol' stamp: ''!
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: ''!
openDataSocket: remoteHostAddress port: dataPort
	dataSocket := Socket new.
	dataSocket connectTo: remoteHostAddress port: dataPort! !

!FTPClient methodsFor: 'protocol' stamp: ''!
passive
	self sendCommand: 'PASV'.
	self lookForCode: 227! !

!FTPClient methodsFor: 'protocol' stamp: ''!
removeFileNamed: remoteFileName
	self sendCommand: 'DELE ', remoteFileName.
	self checkResponse.! !

!FTPClient methodsFor: 'protocol' stamp: ''!
getFileList
	| dirList |
	self openPassiveDataConnection.
	self sendCommand: 'NLST'.
	dirList := self getData.
	self checkResponse.
	self checkResponse.
	^dirList! !

!FTPClient methodsFor: 'private - protocol' stamp: ''!
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 methodsFor: 'accessing' stamp: ''!
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.')! !

!FTPClient class methodsFor: 'accessing' stamp: ''!
defaultPortNumber
	^21! !

!FTPClient class methodsFor: 'accessing' stamp: ''!
logFlag
	^#ftp! !

!FTPluggableIconListMorphAdaptor commentStamp: ''!
I'm an adaptor to adapt a PluggableIconListMorph into a FastTable. 
I implement all required methods, but transform them to serve a table through a FTDataSource.!
!FTPluggableIconListMorphAdaptor methodsFor: 'accessing' stamp: ''!
vScrollValue: aNumber
	self verticalScrollBar setValue: aNumber! !

!FTPluggableIconListMorphAdaptor methodsFor: 'initialization' stamp: ''!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel wrapSelector: wrapSel
	self model: anObject.
	self getListSelector: getListSel.
	self getIndexSelector: getSelectionSel.
	self setIndexSelector: setSelectionSel.
	self getMenuSelector: getMenuSel.
	self keystrokeActionSelector: keyActionSel.
	self basicWrapSelector: wrapSel! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getListSelector: aSelector
	self dataSource getListSelector: aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getSelectionListSelector
	^ getSelectionListSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'event handling' stamp: ''!
keyStrokeModifierAction: event
	| args character |
	character := event keyCharacter.
	args := self keystrokeActionSelector numArgs.
	args = 1 ifTrue: [ 
		^ self model perform: self keystrokeActionSelector with: character].
	args = 2 ifTrue: [
		^ self model 
				perform: self keystrokeActionSelector
				with: character
				with: self ].
			
	^self error: 'keystrokeActionSelector must be a 1- or 2-keyword symbol'! !

!FTPluggableIconListMorphAdaptor methodsFor: 'private' stamp: ''!
selectionChangedResetIfEmpty: ann
	self resetListSelector ifNil: [ ^ self ].
	ann newSelectedIndexes ifNotEmpty: [ ^ self ].

	self model perform: self resetListSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'private' stamp: ''!
selectionChangedUpdateIndex: ann
	self setIndexSelector ifNil: [ ^ self ].

	self model perform: self setIndexSelector with: (ann newSelectedIndexes ifNotEmpty: [ :indexes | indexes first ] ifEmpty: [ 0 ])! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getIconSelector: aSelector
	self dataSource getIconSelector: aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
setSelectionListSelector: aSelector
	setSelectionListSelector := aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
keystrokeActionSelector: aSelector
	keystrokeActionSelector := aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing' stamp: ''!
model
	^ self dataSource model! !

!FTPluggableIconListMorphAdaptor methodsFor: 'event handling' stamp: ''!
keyStrokeAction: event
	| result |
	
	result := self model
		perform: self keystrokeSelector
		withEnoughArguments: { event. self }.
		
	^ result = true! !

!FTPluggableIconListMorphAdaptor methodsFor: 'private' stamp: ''!
interactWithSelection
	| cell |
	
	self hasSelection ifFalse: [ ^ self ].
	"this is a horrible hack, but well... that's how it is implemented :("
	cell := (self container exposedRows at: self selectedIndex) submorphs first. "the cell is there"
	cell submorphsDo: [ :each | each update: #interact ]! !

!FTPluggableIconListMorphAdaptor methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self initializeSelections.
	self hideColumnHeaders.
	self dataSource: FTPluggableIconListMorphAdaptorDataSource new.! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
basicGetListElementSelector: aSelector
	self getListElementSelector: aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'drag and drop' stamp: ''!
acceptDroppingMorph: aMorph event: event
	"I need to more or less copy this from old pluggable list because there 
	 is much bad code around :("

	self dataSource dropItemSelector 
		ifNotNil: [ ^ super acceptDroppingMorph: aMorph event: event ].

	self model
		acceptDroppingMorph: aMorph
		event: event
		inMorph: self.
	self refresh! !

!FTPluggableIconListMorphAdaptor methodsFor: 'updating' stamp: ''!
basicUpdateSelectionIndex
	| rowIndex |
	self getIndexSelector ifNil: [ ^ self ].
	
	rowIndex := self model perform: self getIndexSelector.
	rowIndex = self selectedIndex ifTrue: [ ^ self ].
	rowIndex = 0
		ifTrue: [ self basicSelectIndexes: #() ]
		ifFalse: [ self basicSelectIndexes: { rowIndex } ]! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getListSizeSelector: aSelector
	self dataSource getListSizeSelector: aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'updating' stamp: ''!
updateSelectionIndex
	self basicUpdateSelectionIndex.
	self refresh! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing' stamp: ''!
scrollValue
	"x is always zero because horizontal scroll bar is not yet implemented"

	^ 0 @ self verticalScrollBar value! !

!FTPluggableIconListMorphAdaptor methodsFor: 'private' stamp: ''!
selectionChanged: ann
	self selectionChangedUpdateStatus: ann.
	self selectionChangedUpdateIndex: ann.
	self selectionChangedResetIfEmpty: ann! !

!FTPluggableIconListMorphAdaptor methodsFor: 'private' stamp: ''!
selectionChangedUpdateStatus: ann
	"Updates the status of selection (informs new selections and deselections)"

	self setSelectionListSelector ifNil: [ ^ self ].

	ann oldSelectedIndexes do: [ :each | self model perform: self setSelectionListSelector with: each with: false ].

	ann newSelectedIndexes do: [ :each | self model perform: self setSelectionListSelector with: each with: true ]! !

!FTPluggableIconListMorphAdaptor methodsFor: 'event handling' stamp: ''!
keyStroke: event
	(super keyStroke: event) ifTrue: [ ^ true ].
	self keystrokeSelector 
		ifNotNil: [ (self keyStrokeAction: event) ifTrue: [ ^ true ] ].
	(self keystrokeActionSelector notNil 
		and: [ event anyModifierKeyPressed ])
		ifTrue: [ (self keyStrokeModifierAction: event) ifTrue: [ ^ true ] ].
	
	^ false! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getIndexSelector: aSelector
	getIndexSelector := aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getListSelector
	^ self dataSource getListSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'initialization' stamp: ''!
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel
	"setup a whole load of pluggability options"
	
	self getSelectionListSelector: getListSel.
	self setSelectionListSelector: setListSel.
	self 
		on: anObject 
		list: listSel 
		selected: getSelectionSel 
		changeSelected: setSelectionSel 
		menu: getMenuSel 
		keystroke: keyActionSel.
	self beMultipleSelection! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
setIndexSelector: aSelector
	setIndexSelector := aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'ignored' stamp: ''!
searchedElement: index
	self highlightIndex: index! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getSelectionListSelector: aSelector
	getSelectionListSelector := aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getMenuSelector: aSelector
	self dataSource getMenuSelector: aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'updating' stamp: ''!
update: symbol
	(symbol == self getListSelector or: [ symbol == self getListElementSelector ]) 
		ifTrue: [ ^ self updateList ].
		
	symbol == self getIndexSelector
		ifTrue: [ ^ self updateSelectionIndex ].! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
setSelectionListSelector
	^ setSelectionListSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing' stamp: ''!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	self getIndexSelector ifNil: [ ^0 ].
	^self model perform: self getIndexSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
keystrokeSelector
	^ keystrokeSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getListElementSelector
	^ self dataSource getListElementSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
setIndexSelector
	^ setIndexSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
basicWrapSelector: aSelector
	self dataSource wrapSelector: aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
dropItemSelector: aSelector
	self dataSource dropItemSelector: aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
resetListSelector: aSelector
	resetListSelector := aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
doubleClickSelector
	^ doubleClickSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getListElementSelector: aSelector
	self dataSource getListElementSelector: aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'initialization' stamp: ''!
initializeSelections
	self 
		onAnnouncement: FTSelectionChanged  
		send: #selectionChanged: 
		to: self.
	self 
		onAnnouncement: FTStrongSelectionChanged  
		send: #strongSelectionChanged: 
		to: self.! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing' stamp: ''!
autoDeselect
	^ self resetListSelector 
		ifNotNil: [ true ]
		ifNil: [ self allowsDeselection ]! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
keystrokeSelector: aSelector
	keystrokeSelector := aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
doubleClickSelector: aSelector
	doubleClickSelector := aSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing' stamp: ''!
autoDeselect: aBoolean
	self allowsDeselection: aBoolean! !

!FTPluggableIconListMorphAdaptor methodsFor: '*Commander-SpecSupport' stamp: ''!
createCommandContextBy: aPresenter forDropAt: anEvent

	| dropElementIndex receiverElement |
	dropElementIndex := self container rowIndexContainingPoint: anEvent position.
	dropElementIndex ifNil: [ ^super createCommandContextBy: aPresenter forDropAt: anEvent ].
	
	receiverElement := dataSource elementAt: dropElementIndex.
	^aPresenter createCommandContextForSelection: { receiverElement }! !

!FTPluggableIconListMorphAdaptor methodsFor: 'initialization' stamp: ''!
initializeKeyBindings 
	super initializeKeyBindings.
	self 
		bindKeyCombination: Character space asKeyCombination
		toAction: [ self interactWithSelection ].! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing' stamp: ''!
model: anObject 
	| oldModel |
	oldModel := self dataSource model. 
	oldModel ifNotNil: [ oldModel removeDependent: self ].
	anObject ifNotNil: [ anObject addDependent: self ].
	self dataSource model: anObject! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
keystrokeActionSelector
	^ keystrokeActionSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
resetListSelector
	^ resetListSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'initialization' stamp: ''!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel 
	self model: anObject.
	self getListSelector: getListSel.
	self getIndexSelector: getSelectionSel.
	self setIndexSelector: setSelectionSel.
	self getMenuSelector: getMenuSel.
	self keystrokeActionSelector: keyActionSel! !

!FTPluggableIconListMorphAdaptor methodsFor: 'private' stamp: ''!
strongSelectionChanged: ann
	self doubleClickSelector ifNil: [ ^ self ].
	
	self model perform: self doubleClickSelector withEnoughArguments: { ann }! !

!FTPluggableIconListMorphAdaptor methodsFor: 'updating' stamp: ''!
updateList
	(showIndex < self dataSource numberOfRows and: [ self isIndexVisible: showIndex ])
		ifFalse: [ self resetPosition ].
	self basicUpdateSelectionIndex.
	(self hasSelection and: [ (self isIndexVisible: self selectedIndex) ])
		ifFalse: [ self resetPosition.
			self ensureVisibleFirstSelection ].
	self refresh! !

!FTPluggableIconListMorphAdaptor methodsFor: 'accessing - selectors' stamp: ''!
getIndexSelector
	^ getIndexSelector! !

!FTPluggableIconListMorphAdaptor methodsFor: 'drag and drop' stamp: ''!
wantsDroppedMorph: aMorph event: anEvent
	"I need to more or less copy this from old pluggable list because there 
	 is much bad code around :("

	^ aMorph dragTransferType == #dragTransfer 
		ifTrue: [ super wantsDroppedMorph: aMorph event: anEvent ]
		ifFalse: [ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self ]! !

!FTPluggableIconListMorphAdaptor class methodsFor: 'instance creation' stamp: ''!
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! !

!FTPluggableIconListMorphAdaptor class methodsFor: 'instance creation' stamp: ''!
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"! !

!FTPluggableIconListMorphAdaptor class methodsFor: 'instance creation' stamp: ''!
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! !

!FTPluggableIconListMorphAdaptor class methodsFor: 'instance creation' stamp: ''!
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! !

!FTPluggableIconListMorphAdaptor class methodsFor: 'instance creation' stamp: ''!
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! !

!FTPluggableIconListMorphAdaptor class methodsFor: 'instance creation' stamp: ''!
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"! !

!FTPluggableIconListMorphAdaptor class methodsFor: 'instance creation' stamp: ''!
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"! !

!FTPluggableIconListMorphAdaptorDataSource commentStamp: ''!
I'm a datasource to interpret messages in teh form provided for a PluggableIconListMorph.!
!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
	| object text icon |
	object := self elementAt: rowIndex.
	
	icon := self getIconSelector ifNotNil: [ :selector | 
		self model perform: selector with: object ].
	text := column transform: (self elementWrapped: object).
	
	^ self createCellText: text icon: icon.! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
getMenuSelector: anObject
	getMenuSelector := anObject! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'drag and drop' stamp: ''!
transferFor: passenger from: aMorph
    ^(self model transferFor: passenger from: self table) buildWithSpec! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'private' stamp: ''!
elementWrapped: object
	^ self wrapSelector 
		ifNotNil: [ :selector | self model perform: selector with: object ] 
		ifNil: [ object ]! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
wantsDropSelector
	^ wantsDropSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'drag and drop' stamp: ''!
wantsDropElements: aCollection type: type index: rowIndex
	self dropItemSelector ifNil: [ ^ false ].
	self wantsDropSelector ifNil: [ ^ true ].
	^ self model 
		perform: self wantsDropSelector 
		with: aCollection! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
getIconSelector
	^ getIconSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
getListSelector: anObject
	getListSelector := anObject! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
wrapSelector
	^ wrapSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
getListElementSelector
	^ getListElementSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing' stamp: ''!
numberOfRows
	^ self model 
		ifNotNil: [ 
			self getListSizeSelector 
				ifNotNil: [ self model perform: self getListSizeSelector ]
				ifNil: [ (self model perform: self getListSelector) size ] ]
		ifNil: [ 0 ]! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
getIconSelector: anObject
	getIconSelector := anObject! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
wrapSelector: anObject
	wrapSelector := anObject! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	| menu |
	
	self getMenuSelector ifNil: [ ^ nil ].
	
	menu := UIManager default newMenuIn: self table for: self model.
	self getMenuSelector numArgs = 1 ifTrue: [ 
		^ self model perform: self getMenuSelector with: menu ].
	^ self model 
		perform: self getMenuSelector
		with: menu
		with: false! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
dropItemSelector: aSelector
	dropItemSelector := aSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
getListElementSelector: anObject
	getListElementSelector := anObject! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing' stamp: ''!
newDataSourceMatching: aFTFilter
	| newElements wrappedItem text newDataSource modelCopy |
	newElements := self elements select: [ :each | 
		wrappedItem := self elementWrapped: each.
		table columns anySatisfy: [ :column | 
			text := column transform: wrappedItem.
			aFTFilter matches: text]].
	
	newDataSource := self copy.
	modelCopy := self model copy.
	modelCopy prepareForFilteredDataSourceWith: newElements.
	newDataSource model: modelCopy.
	
	^newDataSource! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing' stamp: ''!
elementAt: rowIndex
	^ self getListElementSelector 
		ifNotNil: [ 
			self model perform: self getListElementSelector with: rowIndex ]
		ifNil: [ 
			(self model perform: self getListSelector) at: rowIndex  ]! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
wantsDropSelector: aSelector
	wantsDropSelector := aSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
getListSizeSelector: anObject
	getListSizeSelector := anObject! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString
	| search text result |
	aString isEmptyOrNil ifTrue: [ ^ #() ].
	result := OrderedCollection new.
	search := aString trimBoth asLowercase.
	1 to: self numberOfRows do: [ :rowIndex | 
		text := (self elementWrapped: (self elementAt: rowIndex)) contents trimBoth asLowercase.
		(text beginsWith: search)
			ifTrue: [ result add: rowIndex ] ].
	^ result asArray! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing' stamp: ''!
dragTransferType
	^ self getListElementSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
getListSizeSelector
	^ getListSizeSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing' stamp: ''!
elements
	^self model getList! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
dropItemSelector
	^ dropItemSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
getListSelector
	^ getListSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'accessing - selectors' stamp: ''!
getMenuSelector
	^ getMenuSelector! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'drag and drop' stamp: ''!
dropElements: aCollection index: rowIndex
	self dropItemSelector ifNil: [ ^ self ].
	self model 
		perform: self dropItemSelector 
		with: aCollection
		with: rowIndex! !

!FTPluggableIconListMorphAdaptorDataSource methodsFor: 'private' stamp: ''!
createCellText: aString icon: anIcon 
	| text icon cell |
	text := aString.
	icon := anIcon.
	cell := FTCellMorph new
		cellInset: 5;
		yourself.
	icon
		ifNotNil:
			[ icon := icon asMorph.
			icon class = ImageMorph
				ifTrue: [ icon form: (icon form scaledToSize: 16 @ 16) ]
				ifFalse: [ icon bounds: (0 @ 0 corner: 16 @ 16) ].
			cell addMorphBack: icon ].
	cell addMorphBack: text asMorph.
	^ cell! !

!FTPropertyColumnSortingStrategy commentStamp: ''!
Description
--------------------

I am a strategy defining a sorting behavior of a FastTable based on the property of the row model. 

I'll have three step depending on the current sorting state: 
- Sort ascending
- Sort descending
- Unsort

To manage my state I uses a State design pattern. 	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	property:		<aValuable>			The property allowing to get the element on which applying the sorting.
	state:			<aSortingState> 	The state of the sorting (ascending, descending, unsorted).
!
!FTPropertyColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
ascendingSortFunction
	^ [ :entity | self property value: entity ] ascending! !

!FTPropertyColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
property: aString 
	property := aString! !

!FTPropertyColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
property
	^ property! !

!FTPropertyColumnSortingStrategy class methodsFor: 'instance creation' stamp: ''!
column: aColumn property: aValuable
	^ (self column: aColumn)
		property: aValuable;
		yourself! !

!FTPropertyColumnSortingStrategyTest commentStamp: ''!
A FTPropertyColumnSortingStrategyTest is a test class for testing the behavior of FTPropertyColumnSortingStrategy!
!FTPropertyColumnSortingStrategyTest methodsFor: 'tests' stamp: ''!
testReset
	| dataSource |
	dataSource := self dataSourceForTesting.
	strategy property: #yourself.
	self assert: dataSource elements equals: self elementsForTestDataSource.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(1 2 3 4 5 6 7 8 9 10).
	strategy reset.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(1 2 3 4 5 6 7 8 9 10)! !

!FTPropertyColumnSortingStrategyTest methodsFor: 'tests' stamp: ''!
testSortDataSource
	| dataSource |
	dataSource := self dataSourceForTesting.
	strategy property: #yourself.
	self assert: dataSource elements equals: self elementsForTestDataSource.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(1 2 3 4 5 6 7 8 9 10).
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(10 9 8 7 6 5 4 3 2 1).
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: self elementsForTestDataSource! !

!FTPropertyColumnSortingStrategyTest methodsFor: 'tests' stamp: ''!
testProperty
	| dataSource |
	dataSource := self dataSourceForTesting.
	strategy property: #yourself.
	self assert: dataSource elements equals: self elementsForTestDataSource.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(1 2 3 4 5 6 7 8 9 10).
	strategy reset.
	strategy property: #asString.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(1 10 2 3 4 5 6 7 8 9)! !

!FTPropertyColumnSortingStrategyTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ FTPropertyColumnSortingStrategy! !

!FTRegexFilter commentStamp: ''!
I am filter implemented by regex expressions

Internal Representation and Key Implementation Points.

    Instance Variables
	regex:		<RxMatcher>!
!FTRegexFilter methodsFor: 'accessing' stamp: ''!
patternFromString: aString
	" do not throw an error if the pattern is bad - important in case of auto-accepting"

	^ [ aString asRegexIgnoringCase ]
		on: RegexSyntaxError
		do: [ :ex |  ]! !

!FTRegexFilter methodsFor: 'accessing' stamp: ''!
pattern: aString
	super pattern: aString.

	regex := self patternFromString: aString! !

!FTRegexFilter methodsFor: 'matching' stamp: ''!
matches: aString
	^(regex matchesIn: aString) notEmpty! !

!FTRootItem commentStamp: ''!
I represent the root item node in a FTTreeDataSource.

Description
-------------------------------------------------

I am store by a FTTreeDataSource and my children are the roots elements of the dataSource.
I store the a collection of Items build from the data of the dataSource.


Example
-------------------------------------------------
 
FTRootItem data: Object allSubclasses from: aDataSource!
!FTRootItem methodsFor: 'expanding-collapsing' stamp: ''!
expandAll
	children do: #expandAll! !

!FTRootItem methodsFor: 'accessing' stamp: ''!
data: aCollection
	self children: (aCollection collect: [ :object | FTBasicItem data: object from: dataSource ]) asArray! !

!FTRootItem methodsFor: 'accessing' stamp: ''!
children
	^ children! !

!FTRootItem methodsFor: '*Iceberg-TipUI' stamp: ''!
isRoot
	^ true! !

!FTRootItem methodsFor: 'accessing' stamp: ''!
isExpanded
	^ true! !

!FTRootItem methodsFor: 'updating' stamp: ''!
updateData
	self children do: #updateData! !

!FTRootItem methodsFor: 'accessing' stamp: ''!
dataSource: anObject
	dataSource := anObject.
	children ifNotNil: [ children do: [ :item | item dataSource: anObject ] ]! !

!FTRootItem methodsFor: 'accessing' stamp: ''!
children: aCollectionOfItem 
	children := aCollectionOfItem! !

!FTRootItem methodsFor: 'expanding-collapsing' stamp: ''!
collapseAll
	children do: #collapseAll! !

!FTRootItem methodsFor: 'expanding-collapsing' stamp: ''!
expandAllTo: aDepth
	children do: [ :each | each expandAllTo: aDepth ]! !

!FTRootItem methodsFor: 'accessing' stamp: ''!
recentlyChanged
	"Cannot collapse root item."

	^ false! !

!FTRootItemsStrategy commentStamp: ''!
I am a Strategy that will use the function on the roots item only.

Description
-----------------------

I will search in the roots item of the tree.
As said in my superclass I am use by a FTTreeDataSource to help with a FTFunction.

Public API and Key Messages
-----------------------

- #realSearch 	is the method that will launch the search.

Example
-----------------------

	| ds |
	ds := FTTreeDataSource
		roots:
			((ProtoObject allSubclasses sort: [ :a :b | a asString < b asString ])
				reject: [ :e | e asString endsWith: 'class' ])
		children: [ :item | item subclasses sort: [ :a :b | a asString < b asString ] ].
	ds searchStrategy: #rootsOnly. "This will say to the FTTreeDataSource to use me."
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		explicitFunction;
		openInWindow
 !
!FTRootItemsStrategy methodsFor: 'action' stamp: ''!
filter
	^ dataSource class
		root:
			(FTRootItem new
				children: (dataSource rootsItems select: [ :each | (pattern matchesIn: (self dataSource toString: each)) notEmpty ]);
				yourself)
		children: dataSource childrenBlock! !

!FTRootItemsStrategy methodsFor: 'action' stamp: ''!
realSearch
	| result index |
	result := OrderedCollection new.
	index := 1.
	dataSource rootsItems
		do: [ :item | 
			(self isMatching: item)
				ifTrue: [ result add: index ].
			index := index + (item numberOfVisibleChildren + 1) ].
	^ result asArray! !

!FTRowLayout commentStamp: ''!
I'm a layout specifphic for rows in a fast table.
I simplify my parent (in an attept to achieve speed), but most important, Itake into account cells width.!
!FTRowLayout methodsFor: 'layouting' stamp: ''!
layout: aMorph in: bounds
	"Compute the layout for the given morph based on the new bounds.
	Supports submorph hResizing, vResizing, cellInset, cellPositioning
	(top, *center, bottom*) and listCentering."
	| props spare extra height inset fillCount x width |

	aMorph submorphs ifEmpty: [ ^ self ].
	props := aMorph assureTableProperties.
	width := (self minExtentOf: aMorph in: bounds) x.
	spare := bounds width - width max: 0.
	fillCount := 0.
	spare > 0 
		ifTrue: [
			fillCount := aMorph submorphs size.
			extra := (fillCount = 0) ifTrue: [0] ifFalse: [ spare // fillCount ].
			spare := spare - ((fillCount - 1) * extra) ]
		ifFalse: [ extra := 0 ].
		
	x := fillCount > 0
		ifTrue: [ bounds left ]
		ifFalse: [
			props listCentering == #center
				ifTrue: [ bounds center x - (width // 2) ]
				ifFalse: [
					props listCentering == #bottomRight
						ifTrue: [ bounds right - width ]
						ifFalse: [ bounds left ] ] ].
	
	height := bounds height.
	inset := props cellInset isPoint ifTrue: [ props cellInset x ] ifFalse: [ props cellInset ]. 
	aMorph submorphs withIndexDo: [ :eachMorph :index | | pos box cell |
		width := ((eachMorph width = 0) and: [ fillCount > 0 ]) 
			ifTrue: [ (bounds width + bounds left - x) / (fillCount - index + 1) ]
			ifFalse: [ eachMorph width ].
		cell := x@bounds top extent: width@height.
		box := cell origin extent: cell width @ cell height.		
		pos := props cellPositioning.
		box := box align: (box perform: pos) with: (cell perform: pos).
		eachMorph bounds: box.
		x := x + width + inset ]! !

!FTRowSelectionModeStrategy commentStamp: ''!
Description
--------------------

I am a strategy to manage the behaviour of a FTTableMorph in case we are in a row selection mode.

My indexes are integers defining the index of the selected row.

Examples
--------------------

	FTRowSelectionModeStrategy table: aFTTableMorph!
!FTRowSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexBellow: anIndex
	^ anIndex + 1! !

!FTRowSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexContainingPoint: aPoint
	^ self tableContainer rowIndexContainingPoint: aPoint! !

!FTRowSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex beforeColumn: aColumn
	"A row cannot be before or after a column."

	^ false! !

!FTRowSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex afterColumn: aColumnIndex
	"A row cannot be before or after a column."

	^ false! !

!FTRowSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexBefore: anIndex
	"Because rows cannot have something at the right or left."

	self shouldNotImplement! !

!FTRowSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
nullIndex
	^ 0! !

!FTRowSelectionModeStrategy methodsFor: 'selection' stamp: ''!
selectAll
	self table selectIndexes: (1 to: self table numberOfRows) asArray! !

!FTRowSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
indexForRow: aRowIndex
	^ aRowIndex! !

!FTRowSelectionModeStrategy methodsFor: 'selection' stamp: ''!
selectLast
	self table selectIndex: self table numberOfRows! !

!FTRowSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex bellowRow: aRowIndex
	^ anIndex > aRowIndex! !

!FTRowSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
rowIndexFrom: anIndex
	^ anIndex! !

!FTRowSelectionModeStrategy methodsFor: 'adding' stamp: ''!
selectablesToHighlightFromRow: aFTRow at: aRowIndex withHighlightedIndexes: highligtedIndexes andPrimaryIndex: primarySelectionIndex
	| selectablesToColorMap |
	selectablesToColorMap := Dictionary new.
	(highligtedIndexes includes: aRowIndex) ifTrue: [ selectablesToColorMap at: aFTRow put: primarySelectionIndex = aRowIndex ].
	^ selectablesToColorMap! !

!FTRowSelectionModeStrategy methodsFor: 'selection' stamp: ''!
selectFirst
	self table selectIndex: 1! !

!FTRowSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
indexesToSelectInMultipleSelectionFrom: firstIndex to: endIndex
	| step |
	step := firstIndex <= endIndex ifTrue: [ 1 ] ifFalse: [ -1 ].
	^ firstIndex to: endIndex by: step! !

!FTRowSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexAfter: anIndex
	"Because rows cannot have something at the right or left."

	self shouldNotImplement! !

!FTRowSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex aboveRow: aRowIndex
	^ anIndex < aRowIndex! !

!FTRowSelectionModeStrategy methodsFor: 'testing' stamp: ''!
allowsRowSelection
	^ true! !

!FTRowSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
indexFromPosition: aTuple
	^ aTuple first! !

!FTRowSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexAbove: anIndex
	^ anIndex - 1! !

!FTRowSelectionModeStrategyTest commentStamp: ''!
A FTRowSelectionModeStrategyTest is a test class for testing the behavior of FTRowSelectionModeStrategy!
!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectedRowIndex
	table selectIndex: 3.
	self assert: strategy selectedRowIndex equals: 3.
	table selectIndex: 4.
	self assert: strategy selectedRowIndex equals: 4! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIndexFromPosition
	self assert: (strategy indexFromPosition: #(3 7)) equals: 3! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexAbove
	self assert: (strategy selectableIndexAbove: 2) equals: 1! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexBellow
	self assert: (strategy selectableIndexBellow: 2) equals: 3! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectAll
	table beSingleSelection.
	table selectFirst.
	table selectAll.
	self assert: table selectedIndexes equals: #(1).
	table beMultipleSelection.
	table selectFirst.
	table selectAll.
	self assert: table selectedIndexes equals: #(1 2 3 4 5 6 7 8 9 10)! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexBefore
	self should: [ strategy selectableIndexBefore: 2 ] raise: Error! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testRowIndexFrom
	self assert: (strategy rowIndexFrom: 3) equals: 3! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsAfterColumn
	self deny: (strategy is: 3 afterColumn: 4).
	self deny: (strategy is: 3 afterColumn: 3).
	self deny: (strategy is: 3 afterColumn: 2)! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectFirst
	table selectFirst.
	self assert: table selectedIndexes equals: #(1)! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectLast
	table selectLast.
	self assert: table selectedIndexes equals: #(10)! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexAfter
	self should: [ strategy selectableIndexAfter: 2 ] raise: Error! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsBellowRow
	self assert: (strategy is: 3 bellowRow: 2).
	self deny: (strategy is: 3 bellowRow: 4).
	self deny: (strategy is: 3 bellowRow: 3)! !

!FTRowSelectionModeStrategyTest methodsFor: 'running' stamp: ''!
setStrategy
	table beRowSelection! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsAboveRow
	self assert: (strategy is: 3 aboveRow: 4).
	self deny: (strategy is: 3 aboveRow: 2).
	self deny: (strategy is: 3 aboveRow: 3)! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsBeforeColumn
	self deny: (strategy is: 3 beforeColumn: 9).
	self deny: (strategy is: 3 beforeColumn: 4).
	self deny: (strategy is: 3 beforeColumn: 7)! !

!FTRowSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIndexesToSelectInMultipleSelectionFromTo
	self assert: (strategy indexesToSelectInMultipleSelectionFrom: 3 to: 11) asArray equals: #(3 4 5 6 7 8 9 10 11).
	self assert: (strategy indexesToSelectInMultipleSelectionFrom: 11 to: 3) asArray equals: #(11 10 9 8 7 6 5 4 3).
	self assert: (strategy indexesToSelectInMultipleSelectionFrom: 3 to: 3) asArray equals: #(3)! !

!FTScrollingChanged methodsFor: 'accessing' stamp: ''!
newScrollingIndex
	^ newScrollingIndex! !

!FTScrollingChanged methodsFor: 'accessing' stamp: ''!
oldScrollingIndex: anObject
	oldScrollingIndex := anObject! !

!FTScrollingChanged methodsFor: 'accessing' stamp: ''!
newScrollingIndex: anObject
	newScrollingIndex := anObject! !

!FTScrollingChanged methodsFor: 'accessing' stamp: ''!
oldScrollingIndex
	^ oldScrollingIndex! !

!FTScrollingChanged class methodsFor: 'instance creation' stamp: ''!
from: oldIndex to: newIndex
	^ self new
		oldScrollingIndex: oldIndex;
		newScrollingIndex: newIndex;
		yourself! !

!FTSearchFunction commentStamp: ''!
I define a search function for a table. 
I respond to any alphanumeric element and I add a search box to the  owner table. 

I use FTDataSource>>#searchTable:text: as input for my searchs. 

In general, my entry point is through #keyStroke:, because I intend to react to keyboard inputs in the owner table.!
!FTSearchFunction methodsFor: 'updating' stamp: ''!
textUpdated: anAnnouncement
	self searchFor: field getTextFromModel! !

!FTSearchFunction methodsFor: 'private' stamp: ''!
showSearchFieldFromKeystrokeEvent: anEvent
	| s ed founds |
	s := anEvent keyCharacter asString asText.
	founds := self searchFor: s.
	ed := RubFloatingEditorBuilder new
		customizeEditorWith: [ :editor | editor bounds: (self table bottomLeft + (0 @ 2) corner: self table bottomRight + (0 @ (editor font height + 6))) ];
		withEditedContentsDo:
				[ :contents :editor | 
			contents
				ifEmpty: [ founds ifTrue: [self table selectIndex: currentSelIndex]. 
					self table highlightIndexes: currentHighlightedIndexes ]
				ifNotEmpty:
					[ founds := self searchFor: contents.
					founds
						ifTrue: [ editor
								setTextWith:
									(contents
										makeAllColor: self table theme textColor;
										yourself) ]
						ifFalse: [ editor
								setTextWith:
									(contents
										addAttribute: (TextColor new color: Color red);
										yourself) ] ] ];
		whenEditorEscapedDo: [ founds ifTrue: [self table selectIndex: currentSelIndex].
			self table highlightIndexes: currentHighlightedIndexes ].
	ed autoAccept: true.
	founds
		ifFalse: [ s addAttribute: (TextColor new color: Color red) ]
		ifTrue: [ s makeAllColor: self table theme textColor ].
	ed openEditorWithContents: s! !

!FTSearchFunction methodsFor: 'event handling' stamp: ''!
keyStroke: anEvent
	(anEvent keyCharacter isAlphaNumeric not)
		ifTrue: [ ^ false ].
	currentSelIndex := self table selectedIndex.
	currentHighlightedIndexes := self table highlightedIndexes.
	self showSearchFieldFromKeystrokeEvent: anEvent.
	^ true! !

!FTSearchFunction methodsFor: 'accessing' stamp: ''!
realSearch
	| founds |
	founds := self table dataSource searchText: pattern.

	founds ifNotEmpty: [ self table selectIndex: founds first ].
	self table highlightIndexes: founds.
	
	^ founds notEmpty! !

!FTSearchFunction methodsFor: 'accessing' stamp: ''!
searchFor: aStringOrText
	pattern := aStringOrText asString trim.
	^ self realSearch! !

!FTSearchFunction methodsFor: 'initialization' stamp: ''!
reset
	"self search"! !

!FTSearchFunction methodsFor: 'widget API' stamp: ''!
ghostText
	^ 'Search...'! !

!FTSelectableMorph commentStamp: ''!
Description
--------------------

I am a morph that can be selected by a user in a FastTable.

I manage the color changes when the user is doing a mouse over or a selection.!
!FTSelectableMorph methodsFor: 'initialization' stamp: ''!
selectionColor
	^ selectionColor! !

!FTSelectableMorph methodsFor: 'accessing' stamp: ''!
selectionColor: aColor
	selectionColor := aColor.
	self color: selectionColor! !

!FTSelectableMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	selectionColor := self defaultColor! !

!FTSelectableMorph methodsFor: 'event handling' stamp: ''!
mouseEnter: evt
	self color: (selectionColor isTransparent ifTrue: [ self mouseOverColor ] ifFalse: [ self mouseOverColor mixed: 0.5 with: selectionColor ])! !

!FTSelectableMorph methodsFor: 'accessing' stamp: ''!
mouseOverColor
	^ self theme lightBackgroundColor! !

!FTSelectableMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: evt
	self color: self selectionColor! !

!FTSelectableMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^ Color transparent! !

!FTSelectableMorph methodsFor: 'accessing' stamp: ''!
table
	^ self owner ifNotNil: #table! !

!FTSelectionChanged commentStamp: ''!
I announce a selection change (usually a click, but can also be done with arrows up and down).

Description
-------------------

I store the old selected rows and the new selected row. 
I should be use to act with the user when he interact with a Fast Table.

Public API and Key Messages
-------------------

- #from: arrayOfIndexes to: arrayOfIndexes 		is the commun constructor.
 
Internal Representation and Key Implementation Points.
------------------

    Instance Variables
	newSelectedRowIndexes:		An array of indexes that store the new selection.
	oldSelectedRowIndexes:		An array of indexes that store the old selection.
			
From the index you can get an object from the FTTableMorph with: 

aFTTableMorph dataSource elementAt: selectedRowIndex !
!FTSelectionChanged methodsFor: 'accessing' stamp: ''!
oldSelectedIndexes
	^ oldSelectedIndexes! !

!FTSelectionChanged methodsFor: 'accessing' stamp: ''!
newSelectedIndexes
	^ newSelectedIndexes! !

!FTSelectionChanged methodsFor: 'accessing' stamp: ''!
oldSelectedIndexes: anObject
	oldSelectedIndexes := anObject! !

!FTSelectionChanged methodsFor: 'accessing' stamp: ''!
newSelectedIndexes: anObject
	newSelectedIndexes := anObject! !

!FTSelectionChanged class methodsFor: 'instance creation' stamp: ''!
from: oldArray to: newArray
	^ self new
		oldSelectedIndexes: oldArray;
		newSelectedIndexes: newArray;
		yourself! !

!FTSelectionModeStrategy commentStamp: ''!
Description
--------------------


I manage the different selection modes of a FastTable.

I manage the different behaviours between row and cell selections. Maybe we could also add column selection later.

I am part of a Strategy design pattern and I am used by a FTTableMroph.

Examples
--------------------

	FTCellSelectionModeStrategy table: aFTTableMorph
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	table:		<aFTTableMorph>		The fast table whose selection I manage.
!
!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexBellow: anIndex
	"When getting in this method we should already know there is a selectable before this one."

	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexContainingPoint: aPoint
	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex beforeColumn: aColumn
	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
tableContainer
	^ self table container! !

!FTSelectionModeStrategy methodsFor: 'testing' stamp: ''!
allowsRowSelection
	^ false! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexBefore: anIndex
	"When getting in this method we should already know there is a selectable before this one."

	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
indexFromPosition: aTuple
	"I receive a tuple representing a row and a column index in my table and I should return the index of the selectable element that can be selected at this position."

	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex aboveRow: aRowIndex
	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex afterColumn: aColumnIndex
	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
nullIndex
	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectedRowIndex
	^ self rowIndexFrom: self table selectedIndex! !

!FTSelectionModeStrategy methodsFor: 'selection' stamp: ''!
selectAll
	"This method should select all elements of the table."

	self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
indexForRow: aRowIndex
	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'selection' stamp: ''!
selectLast
	"This method should select the first element of the table."

	self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'testing' stamp: ''!
is: anIndex bellowRow: aRowIndex
	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
rowIndexFrom: anIndex
	"From the index of the selectable I should return the row index."

	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'adding' stamp: ''!
selectablesToHighlightFromRow: aFTRow at: aRowIndex withHighlightedIndexes: highligtedIndexes andPrimaryIndex: primarySelectionIndex
	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
table: anObject
	table := anObject! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
table
	^ table! !

!FTSelectionModeStrategy methodsFor: 'selection' stamp: ''!
selectFirst
	"This method should select the first element of the table."

	self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
indexesToSelectInMultipleSelectionFrom: firstIndex to: endIndex
	"In case of multiple selection, I wust return the list of indexes to select when the user uses shift + click."

	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexAfter: anIndex
	"When getting in this method we should already know there is a selectable after this one."
	
	^ self subclassResponsibility! !

!FTSelectionModeStrategy methodsFor: 'testing' stamp: ''!
allowsCellSelection
	^ false! !

!FTSelectionModeStrategy methodsFor: 'accessing' stamp: ''!
selectableIndexAbove: anIndex
	"When getting in this method we should already know there is a selectable above this one."

	^ self subclassResponsibility! !

!FTSelectionModeStrategy class methodsFor: 'instance creation' stamp: ''!
table: aTable
	^ self new
		table: aTable;
		yourself! !

!FTSelectionModeStrategyTest commentStamp: ''!
A FTSelectionModeStrategyTest is a test class for testing the behavior of FTSelectionModeStrategy!
!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectedRowIndex
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIndexFromPosition
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexAbove
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexBellow
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectAll
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexBefore
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testRowIndexFrom
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsAfterColumn
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectFirst
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectLast
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testSelectableIndexAfter
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsBellowRow
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'running' stamp: ''!
setStrategy
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsAboveRow
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIsBeforeColumn
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'tests' stamp: ''!
testIndexesToSelectInMultipleSelectionFromTo
	self subclassResponsibility! !

!FTSelectionModeStrategyTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	table := FTTableMorph new
		addColumn: (FTColumn id: 'column1');
		addColumn: (FTColumn id: 'column2');
		addColumn: (FTColumn id: 'column3');
		dataSource: (FTSimpleDataSource elements: (1 to: 10));
		yourself.
	self setStrategy.
	strategy := table selectionModeStrategy! !

!FTSelectionModeStrategyTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!FTSelectionModeStrategyTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = FTSelectionModeStrategyTest! !

!FTSelectionStrategy commentStamp: ''!
I define a strategy to handle selections. 
The sense of this class is shown in my children: I allow to handle the case of multiple and simple selection in a well designed way, instead using ifs everywhere.!
!FTSelectionStrategy methodsFor: 'private' stamp: ''!
toggleIndex: index
	((self table selectedIndexes includes: index) and: [ self table selectedIndexes size = 1 and: [ self table allowsDeselection ]	"just one selected" ])
		ifTrue: [ self table deselectAll ]
		ifFalse: [ self table selectIndex: index ]! !

!FTSelectionStrategy methodsFor: 'testing' stamp: ''!
isMultiple
	^ self subclassResponsibility! !

!FTSelectionStrategy methodsFor: 'testing' stamp: ''!
isSimple
	^ self isMultiple not! !

!FTSelectionStrategy methodsFor: 'accessing' stamp: ''!
selectionModeStrategy
	^ self table selectionModeStrategy! !

!FTSelectionStrategy methodsFor: 'accessing' stamp: ''!
selectIndex: rowIndex event: event
	self subclassResponsibility! !

!FTSelectionStrategy methodsFor: 'accessing' stamp: ''!
table: aTable
	table := aTable! !

!FTSelectionStrategy methodsFor: 'accessing' stamp: ''!
table
	^ table! !

!FTSelectionStrategy class methodsFor: 'instance creation' stamp: ''!
table: aFastTableMorph
	^ self new
		table: aFastTableMorph;
		yourself! !

!FTSimpleDataSource commentStamp: ''!
I'm a simple datasource and just implement a direct-to-table provision of my elements.  I can work with the default implementation of FTTableMorph. 

Users might want to subclass me to have better options.!
!FTSimpleDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex 
	^ FTCellMorph new
		addMorphBack: (self elementAt: rowIndex) asMorph;
		yourself! !

!FTSimpleDataSource methodsFor: 'accessing' stamp: ''!
newDataSourceMatching: aFTFilter
	| newElements |
	newElements := Array withAll: (elements select: [ :each | 
		aFTFilter matches: (self toString: each) ]).
	^ self class new elements: newElements! !

!FTSimpleDataSource methodsFor: 'accessing' stamp: ''!
elementAt: index
	^ self elements at: index! !

!FTSimpleDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString
	| result |
	aString isEmptyOrNil ifTrue: [ ^ #() ].
	result := OrderedCollection new.
	self elements withIndexDo: [ :each :index |
		((self toString: each) beginsWith: aString)
			ifTrue: [ result add: index ] ].
	^ result asArray! !

!FTSimpleDataSource methodsFor: 'accessing' stamp: ''!
elements: anObject
	elements := anObject! !

!FTSimpleDataSource methodsFor: 'accessing' stamp: ''!
elements
	^ elements! !

!FTSimpleDataSource methodsFor: 'accessing' stamp: ''!
numberOfRows 
	^ self elements 
		ifNotNil: [ self elements size ]
		ifNil: [ 0 ]! !

!FTSimpleDataSource methodsFor: 'sorting' stamp: ''!
unsortElements
	unsortedElements ifNil: [ ^ self ].

	self elements: unsortedElements.
	unsortedElements := nil! !

!FTSimpleDataSource methodsFor: 'accessing' stamp: ''!
headerColumn: column
	^ self basicHeaderCellFor: column! !

!FTSimpleDataSource methodsFor: 'sorting' stamp: ''!
sortElements: aSortFunction
	unsortedElements ifNil: [ unsortedElements := self elements ].
	self elements: (self elements sorted: aSortFunction)! !

!FTSimpleDataSource class methodsFor: 'instance creation' stamp: ''!
elements: aCollection
	^ self new elements: aCollection! !

!FTSimpleSelection class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!FTSimpleSelectionStrategy commentStamp: ''!
I define the simple selection strategy. 
I allow tables using me to manage single selection rows.!
!FTSimpleSelectionStrategy methodsFor: 'testing' stamp: ''!
isMultiple
	^ false! !

!FTSimpleSelectionStrategy methodsFor: 'accessing' stamp: ''!
selectIndex: rowIndex event: event
	self toggleIndex: rowIndex! !

!FTSizeMetrics commentStamp: ''!
I map the FT_SizeMetrics type.!
!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
x_ppem
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_X_PPEM! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
y_ppem
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_Y_PPEM! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
y_scale
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_Y_SCALE! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
ascender: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_ASCENDER put: anObject! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
max_advance: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_MAX_ADVANCE put: anObject! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
x_ppem: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_X_PPEM put: anObject! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
max_advance
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_MAX_ADVANCE! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
descender
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_DESCENDER! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
ascender
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_ASCENDER! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
y_ppem: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_Y_PPEM put: anObject! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
x_scale
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_X_SCALE! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
height
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_HEIGHT! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
height: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_HEIGHT put: anObject! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
descender: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_DESCENDER put: anObject! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
x_scale: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_X_SCALE put: anObject! !

!FTSizeMetrics methodsFor: 'accessing - structure variables' stamp: ''!
y_scale: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_Y_SCALE put: anObject! !

!FTSizeMetrics class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
    FT_UShort  x_ppem;      
    FT_UShort  y_ppem;      

    FT_Fixed   x_scale;     
    FT_Fixed   y_scale;     

    FT_Pos     ascender;    
    FT_Pos     descender;   
    FT_Pos     height;      
    FT_Pos     max_advance; 
)! !

!FTSizeRec commentStamp: ''!
I map the FT_SizeRec type.!
!FTSizeRec methodsFor: 'accessing - structure variables' stamp: ''!
face
	"This method was automatically generated"
	^FTFaceRec fromHandle: (handle pointerAt: OFFSET_FACE)! !

!FTSizeRec methodsFor: 'accessing - structure variables' stamp: ''!
face: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_FACE put: anObject getHandle.! !

!FTSizeRec methodsFor: 'accessing - structure variables' stamp: ''!
metrics: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_METRICS put: anObject getHandle length: FTSizeMetrics byteSize! !

!FTSizeRec methodsFor: 'accessing - structure variables' stamp: ''!
metrics
	"This method was automatically generated"
	^ FTSizeMetrics fromHandle: (handle referenceStructAt: OFFSET_METRICS length: FTSizeMetrics byteSize)! !

!FTSizeRec methodsFor: 'accessing - structure variables' stamp: ''!
generic: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_GENERIC put: anObject getHandle length: FTGeneric byteSize! !

!FTSizeRec methodsFor: 'accessing - structure variables' stamp: ''!
internal: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_INTERNAL put: anObject getHandle.! !

!FTSizeRec methodsFor: 'accessing - structure variables' stamp: ''!
internal
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_INTERNAL) type: ExternalType void asPointerType! !

!FTSizeRec methodsFor: 'accessing - structure variables' stamp: ''!
generic
	"This method was automatically generated"
	^ FTGeneric fromHandle: (handle referenceStructAt: OFFSET_GENERIC length: FTGeneric byteSize)! !

!FTSizeRec class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(
	 FT_Face           face;
    FT_Generic        generic;
    FT_Size_Metrics   metrics;
    FT_Size_Internal  internal;	
)! !

!FTSortFunctionColumnSortingStrategy commentStamp: ''!
Description
--------------------

I am a strategy defining a sorting behavior of a FastTable based on a sort function to apply on the row model. 

I'll have three step depending on the current sorting state: 
- Sort ascending
- Sort descending
- Unsort

To manage my state I uses a State design pattern. 	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	sortFunction:		<aSortFunction>		The sortFunction to apply on the elements to sort them.
	state:					<aSortingState> 	The state of the sorting (ascending, descending, unsorted).
!
!FTSortFunctionColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
sortFunction: aString 
	sortFunction := aString! !

!FTSortFunctionColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
ascendingSortFunction
	^ self sortFunction! !

!FTSortFunctionColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
sortFunction
	^ sortFunction! !

!FTSortFunctionColumnSortingStrategy class methodsFor: 'instance creation' stamp: ''!
column: aColumn sortFunction: aValuable
	^ (self column: aColumn)
		sortFunction: aValuable;
		yourself! !

!FTSortFunctionColumnSortingStrategyTest commentStamp: ''!
A FTSortFunctionColumnSortingStrategyTest is a test class for testing the behavior of FTSortFunctionColumnSortingStrategy!
!FTSortFunctionColumnSortingStrategyTest methodsFor: 'tests' stamp: ''!
testReset
	| dataSource |
	dataSource := self dataSourceForTesting.
	strategy sortFunction: #yourself ascending.
	self assert: dataSource elements equals: self elementsForTestDataSource.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(1 2 3 4 5 6 7 8 9 10).
	strategy reset.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(1 2 3 4 5 6 7 8 9 10)! !

!FTSortFunctionColumnSortingStrategyTest methodsFor: 'helpers' stamp: ''!
complexElementsForTestDataSource
	^ #(3 80 29 10 20 28 70)! !

!FTSortFunctionColumnSortingStrategyTest methodsFor: 'helpers' stamp: ''!
complexDataSourceForTesting
	^ FTTableMorph new
		dataSource: (FTSimpleDataSource elements: self complexElementsForTestDataSource);
		dataSource! !

!FTSortFunctionColumnSortingStrategyTest methodsFor: 'tests' stamp: ''!
testSortDataSource
	| dataSource |
	dataSource := self dataSourceForTesting.
	strategy sortFunction: #yourself ascending.
	self assert: dataSource elements equals: self elementsForTestDataSource.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(1 2 3 4 5 6 7 8 9 10).
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(10 9 8 7 6 5 4 3 2 1).
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: self elementsForTestDataSource! !

!FTSortFunctionColumnSortingStrategyTest methodsFor: 'tests' stamp: ''!
testSortDataSourceWithChainedSortFunction
	| dataSource |
	dataSource := self complexDataSourceForTesting.
	strategy sortFunction: [ :element | element \\ 10 ] ascending , #yourself ascending.
	self assert: dataSource elements equals: self complexElementsForTestDataSource.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(10 20 70 80 3  28 29).
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(29 28 3 80 70 20 10).
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: self complexElementsForTestDataSource! !

!FTSortFunctionColumnSortingStrategyTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ FTSortFunctionColumnSortingStrategy! !

!FTSortFunctionColumnSortingStrategyTest methodsFor: 'tests' stamp: ''!
testSortFunction
	| dataSource |
	dataSource := self dataSourceForTesting.
	strategy sortFunction: #yourself ascending.
	self assert: dataSource elements equals: self elementsForTestDataSource.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(1 2 3 4 5 6 7 8 9 10).
	strategy reset.
	strategy sortFunction: #asString ascending.
	strategy sortDataSource: dataSource.
	self assert: dataSource elements equals: #(1 10 2 3 4 5 6 7 8 9)! !

!FTStateBasedColumnSortingStrategy commentStamp: ''!
Description
--------------------

I am an abstract class defining the state management of FTAbstractColumnSortingStrategy subclasses using a state to sort the table.

My subclasses should only define a sort function to be used by the state to sort the FastTable.
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	state:			<aSortingState> 	The state of the sorting (ascending, descending, unsorted).
!
!FTStateBasedColumnSortingStrategy methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self reset! !

!FTStateBasedColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
state: anObject
	state := anObject! !

!FTStateBasedColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
state
	^ state! !

!FTStateBasedColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
ascendingSortFunction
	^ self subclassResponsibility! !

!FTStateBasedColumnSortingStrategy methodsFor: 'sorting' stamp: ''!
sortDataSource: aDataSource
	self state sort: aDataSource! !

!FTStateBasedColumnSortingStrategy methodsFor: 'initialization' stamp: ''!
reset
	self state: (FTUnsortedSortingState context: self)! !

!FTStateBasedColumnSortingStrategy methodsFor: 'accessing' stamp: ''!
sortingIcon
	^ self state sortingIcon! !

!FTStaticBasicItem commentStamp: ''!
I am an Item of a tree that keep a data and I keep staticly my children. I cannot regenerate them. 

Description
-------------------------------------------------

I am created by a FTTreeFunctionStrategy for some filter. For example it is hard to be able to update a Tree when you filter all his elements. In that case the FTAllItemsStrategy create me during a filter.

Public API and Key Messages
-------------------------------------------------

- #children: 	allow to set my childrens 
   
Example
-------------------------------------------------

FTStaticBasicItem new
		data: 5;
		depth: 2;
		children: aCollectionOfItems;
		yourself.
 !
!FTStaticBasicItem methodsFor: 'accessing' stamp: ''!
children
	^ children! !

!FTStaticBasicItem methodsFor: 'updating' stamp: ''!
updateData
	"Static Item cannot do it."! !

!FTStaticBasicItem methodsFor: 'updating' stamp: ''!
dataSource: anObject
	dataSource := anObject.
	children do: [ :item | item dataSource: anObject ]! !

!FTStaticBasicItem methodsFor: 'accessing' stamp: ''!
children: aCollectionsOfItems
	children := aCollectionsOfItems! !

!FTStaticBasicItem methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
hasComputedChildren
	^ self hasChildren! !

!FTStaticBasicItem methodsFor: 'accessing' stamp: ''!
calculateChildren
	"Not for this item."! !

!FTStrongSelectionChanged commentStamp: ''!
I announce a strong selection happened (this is a double-click)

Description
-------------------

I store the index of the row and the event (doubleClick) the FTTableMorph received.
I should be use by the user to defined an action to execute when a DoubleClic happen on a Table.

Public API and Key Messages
-------------------

- #rowIndex: anIndex event: anEvent 		is the commun constructor.
 
Internal Representation and Key Implementation Points.
------------------

    Instance Variables
	event:		An event received by the FTTableMorph.
	selectedRowIndex:		The index of the row in the table that was selected. 

			
From the index you can get an object from the FTTableMorph with: 

aFTTableMorph dataSource elementAt: selectedRowIndex  
!
!FTStrongSelectionChanged methodsFor: 'accessing' stamp: ''!
event
	^ event! !

!FTStrongSelectionChanged methodsFor: 'accessing' stamp: ''!
selectedIndex
	^ selectedIndex! !

!FTStrongSelectionChanged methodsFor: 'accessing' stamp: ''!
selectedIndex: anObject
	selectedIndex := anObject! !

!FTStrongSelectionChanged methodsFor: 'accessing' stamp: ''!
selectedRowIndex
	self deprecated: 'Use #selectedIndex instead' transformWith: '`@receiver selectedRowIndex' -> '`@receiver selectedIndex'.
	^ self selectedIndex! !

!FTStrongSelectionChanged methodsFor: 'accessing' stamp: ''!
event: anEvent
	event := anEvent! !

!FTStrongSelectionChanged class methodsFor: 'instance creation' stamp: ''!
index: aNumber event: anEvent
	^ self new
		selectedIndex: aNumber;
		event: anEvent;
		yourself! !

!FTSubstringFilter commentStamp: ''!
I filter given strings by checking substrings inclusion!
!FTSubstringFilter methodsFor: 'matching' stamp: ''!
matches: aString
	^aString includesSubstring: pattern caseSensitive: false! !

!FTTableContainerMorph commentStamp: ''!
I am a Morph that contain visible rows in a FTTableMorph. 

Description 
------------------

I am the main Morph of the FastTable that is responsible of displaying all the rows of a Table. 
My owner need to be a FTTableMorph and I will use his dataSource to display the needed informations.

Public API and Key Messages
-----------------
		
- #updateAllRows 

- #updateExposedRows

- #ipdateHeaderRow
 
Internal Representation and Key Implementation Points.
----------------

    Instance Variables
	exposedRows:		A dictionary of index/row with all the exposed rows.
	headerRow:			When not nil contains the header row of the container.
	needsRefreshExposedRows:		A boolean that is true if the container need a refresh.
	startColumnIndex: An integer - first column to start drawing when scrolling horizontally, nil/0 - old behaviour (no scrolling)

The method #drawOn: is responsible of my rendering.!
!FTTableContainerMorph methodsFor: 'updating' stamp: ''!
changed
	self table ifNil: [ ^ self ].
	self setNeedsRefreshExposedRows.
	super changed! !

!FTTableContainerMorph methodsFor: 'geometry' stamp: ''!
outerBounds 
	^ self bounds! !

!FTTableContainerMorph methodsFor: 'drawing' stamp: ''!
drawOn: canvas

	super drawOn: canvas.
	self drawRowsOn: canvas! !

!FTTableContainerMorph methodsFor: 'accessing' stamp: ''!
startColumnIndex: anObject
	startColumnIndex := anObject! !

!FTTableContainerMorph methodsFor: 'updating' stamp: ''!
updateExposedRows
	"updated (as #updateHeaderRow also) to draw only subset of columns if horizontal scrolling in use, see #exposedColumnsRange:"
	| visibleRows columns columnWidths startIndex |
	
	self canRefreshValues ifFalse: [ ^ self ].

	visibleRows := self calculateMaxVisibleRows.
	startIndex := self calculateStartIndexWhenShowing: visibleRows.
	columns := self table columns. 
	columnWidths := self calculateColumnWidths.

	exposedRows := SmallDictionary new.
	startIndex to: (startIndex + visibleRows - 1) do: [ :rowIndex | 
		(self table dataSource hasElementAt: rowIndex) ifTrue: [ 
			| row |
			row := FTTableRowMorph table: self table.
			(self exposedColumnsRange: columnWidths) do: [ :columnIndex | | cell |
				cell := (self table dataSource 
					cellColumn: (columns at: columnIndex)
					row: rowIndex).  
				cell width: (columnWidths at: columnIndex).
				row addMorphBack: cell ].
			row privateOwner: self.
			exposedRows at: rowIndex put: row ] ]! !

!FTTableContainerMorph methodsFor: 'updating' stamp: ''!
updateAllRows

	self table isShowColumnHeaders 
		ifTrue: [ self updateHeaderRow ]
		ifFalse: [ headerRow := nil ].
	self updateExposedRows! !

!FTTableContainerMorph methodsFor: 'updating' stamp: ''!
updateHeaderRow
	"Recalculates the header row if they are defined. 
	 Please, note that If one of the headers is nil, I assume all are nil and I return. 
	 This is probably not the best approach, but like that I enforce people defines at least 
	 a default if they want headers."
	| columns columnHeaders columnWidths |

	self canRefreshValues ifFalse: [ ^ self ].

	headerRow := nil.
	columns := self table columns.	
	columnHeaders := OrderedCollection new.
	columnWidths := self calculateColumnWidths.
	
	(self exposedColumnsRange: columnWidths)  do: [ :index | | column headerCell columnWidth|
		column := columns at: index.
		columnWidth := columnWidths at: index.
		headerCell :=  self table dataSource headerColumn: column. 
		headerCell ifNil: [ ^ self ]. 
		headerCell 
			color: self table headerColor;
			width: columnWidth.
		columnHeaders addLast: headerCell.
		FTDisplayColumn column: column width: columnWidth ].
	 
	headerRow := (FTTableHeaderRowMorph table: self table)
		privateOwner: self;
		addAllMorphs: columnHeaders;
		yourself! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
calculateMinVisibleRows
	"Answer the minimal fully visible number of rows to shown in list"

	^ self calculateExactVisibleRows floor! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
needsRefreshExposedRows
	^ needsRefreshExposedRows! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
calculateStartIndexWhenShowing: visibleRows
	"Answer the first row to show when showing visibleRows rows. 
	 This works in case we are exceeding the available rows to show"
	| currentIndex startIndex oldIndex |
	
	currentIndex := self table showIndex.
	currentIndex + visibleRows - 1 > self table numberOfRows 
		ifTrue: [ currentIndex := self table numberOfRows - visibleRows + 2 ].
	startIndex := currentIndex max: 1.
	oldIndex := self table showIndex.
	self table basicMoveShowIndexTo: startIndex.
	self table announceScrollChangedFrom: oldIndex to: self table showIndex.
	^ startIndex! !

!FTTableContainerMorph methodsFor: 'accessing' stamp: ''!
firstVisibleRowIndex

	^ self exposedRows
		ifNotEmpty: [ :rows | rows keys first ]
		ifEmpty: [ 0 ]! !

!FTTableContainerMorph methodsFor: 'testing' stamp: ''!
isRowIndexExceding: rowIndex
	| headerPresentModificator nextRowIndexByPosition heightWithSpacing |
	
	headerPresentModificator := headerRow ifNotNil: [ 1 ] ifNil: [ 0 ].
	nextRowIndexByPosition := rowIndex - self table showIndex + 1 + headerPresentModificator.
	heightWithSpacing := self table rowHeight + self table intercellSpacing y.
	
	^ (nextRowIndexByPosition * heightWithSpacing) > self height! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
calculateExactVisibleRows
	"Answer the rows to show in list - with possible fraction"

	| visibleRows |
	visibleRows := self height / (self table rowHeight + self table intercellSpacing y).
	^ headerRow 
		ifNotNil: [ visibleRows - 1 ] 
		ifNil: [ visibleRows ]! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
columnOrderOfWidthDistribution
	"returns column indexes ordered by priority to get screenspace"
	| idxToLast idxToFirstReversed |
	self startColumnIndex isZero "a special case implementing default/current behaviour -- natural order of columns starting from the first one"
		ifTrue: [ ^(1 to: self table numberOfColumns) ].
	"new behaviour intended to garantee the visibility of columns around startColumnIndex
		first give width starting from startColumnIndex towards end,
		then from previous available column towards beginning"
	idxToLast := startColumnIndex to: self table numberOfColumns.
	idxToFirstReversed := startColumnIndex>1 ifTrue: [startColumnIndex-1 to: 1 by: -1] ifFalse: [#()].
	^idxToLast,idxToFirstReversed! !

!FTTableContainerMorph methodsFor: 'drawing' stamp: ''!
addResizeSplitters
	| columnWidths nextColumn delta |
	columnWidths := self calculateColumnWidths.
	nextColumn := self left.
	delta := FTColumnResizerMorph resizerWidth / 2.
	self table columns overlappingPairsWithIndexDo:  [ :leftColumn :rightColumn :index |
		nextColumn := nextColumn + (columnWidths at: index) + self table intercellSpacing x.
		self addMorph: ((FTColumnResizerMorph 
			container: self 
				left: (FTDisplayColumn column: leftColumn width: (columnWidths at: index))
				right: (FTDisplayColumn column: rightColumn width: (columnWidths at: (index + 1))))
			bounds: ((nextColumn - delta)@(self top) extent: delta@(self height));
			color: Color transparent;
			yourself)	 ]! !

!FTTableContainerMorph methodsFor: 'accessing' stamp: ''!
lastVisibleRowIndex

	^ self exposedRows
		ifNotEmpty: [ :rows | rows keys last ]
		ifEmpty: [ 0 ]! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
exposedColumnsRange: columnWidths
	"Return a subset of indexes for columns which are to be drawn.
	startColumnIndex=0 is default/current behaviour -- draw all, even if they will not fit
	otherwise, we select only indexes of columns having non-zero screen width"
	
	^self startColumnIndex isZero
		ifTrue: [1 to: self table numberOfColumns] 
		ifFalse: [(1 to: columnWidths size) select: [ :idx | (columnWidths at: idx)>0 ]  ]! !

!FTTableContainerMorph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	self drawOnCanvasWrapperFor: anAthensCanvas! !

!FTTableContainerMorph methodsFor: 'accessing' stamp: ''!
rowAndColumnIndexContainingPoint: aPoint
	"answer a tuple containing { rowIndex. columnNumber } to be used for menus, etc. 
	 (check senders for references)"

	self exposedRows keysAndValuesDo: [ :rowIndex :row | 
		(row bounds containsPoint: aPoint) ifTrue: [ 
			row submorphs withIndexDo: [ :each :columnIndex |
				 (each bounds containsPoint: aPoint) 
					ifTrue: [ ^ { rowIndex. columnIndex } ] ] ] ].
	^ {nil. nil}! !

!FTTableContainerMorph methodsFor: 'accessing' stamp: ''!
headerRow

	^ headerRow! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
calculateMaxVisibleRows
	"Answer the maximal number of rows to shown in list"

	^ self calculateExactVisibleRows ceiling! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
setNeedsRefreshExposedRows
	needsRefreshExposedRows := true! !

!FTTableContainerMorph methodsFor: 'accessing' stamp: ''!
table
	^ self owner! !

!FTTableContainerMorph methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	needsRefreshExposedRows := false.
	startColumnIndex :=0.! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
exposedRows
	"Answer a dictionary of rowIndex->row pairs"

	^ exposedRows! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
calculateVisibleRows
	"Answer the rows to show in list. 
	 Ensures we show the maximum amount possible"

	^ self calculateMaxVisibleRows min: self table numberOfRows! !

!FTTableContainerMorph methodsFor: 'testing' stamp: ''!
isRowIndexFullyVisible: rowIndex
	"Answer if a row is *fully* visible. That means row is completely visible (there is 
	 not hidden part)"
	^ (self isRowIndexVisible: rowIndex) 
		and: [ (self isRowIndexExceding: rowIndex) not ]! !

!FTTableContainerMorph methodsFor: 'accessing' stamp: ''!
startColumnIndex
	startColumnIndex ifNil: [ startColumnIndex := 0 ].
	^startColumnIndex! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
rowHeight: rowIndex default: aNumber

	^ aNumber! !

!FTTableContainerMorph methodsFor: 'drawing' stamp: ''!
clipSubmorphs

	^ true! !

!FTTableContainerMorph methodsFor: 'accessing' stamp: ''!
rowIndexContainingPoint: aPoint
	self exposedRows keysAndValuesDo: [ :rowIndex :row | 
		(row bounds containsPoint: aPoint)
			ifTrue: [ ^ rowIndex ] ].
	^ nil! !

!FTTableContainerMorph methodsFor: 'testing' stamp: ''!
isRowIndexVisible: rowIndex
	self exposedRows ifNil: [ ^ false ].
	^ self exposedRows includesKey: rowIndex! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
calculateColumnWidths
	"do three runs 
	- first collect defined columnwidth that fit
	- collect remaining undefined columnwidth 
	- return if all fit 
	  or collect and distribute remaining width.
	
   the method was adjusted to distribute space starting from startColumnIndex 
	to enable horizontal scrolling when columns do not fit the window,
	see #columnOrderOfWidthDistribution"
	| undefinedColumnWidths widths remainingWidth |
	
	remainingWidth := self table width - self table verticalScrollBarWidth.

	widths := Array new: self table numberOfColumns withAll: 0.
	self columnOrderOfWidthDistribution do: [ :idx || column columnWidth |
		column := self table columns at: idx. 
		columnWidth := column acquireWidth: remainingWidth.
		widths at: idx put: columnWidth.
		remainingWidth := remainingWidth - columnWidth ].

	undefinedColumnWidths := widths count: #isZero.
	undefinedColumnWidths isZero
		ifTrue: [ widths size > 1 ifTrue: [ "Set the remaining space to the last column" widths at: widths size put: widths last + remainingWidth ].
			^ widths ].


	"collect and distribute remaining space"
	self columnOrderOfWidthDistribution do: [ :idx | 
		(widths at: idx) = 0 	ifTrue: [ widths at: idx put: (remainingWidth / undefinedColumnWidths) ] ].
	^widths! !

!FTTableContainerMorph methodsFor: 'private' stamp: ''!
createResizableHeaderWith: aMorph between: leftColumn and: rightColumn
	"Create a wrapper morph with a resizable morph et the left (so we bind two columns). 
	 This morph will be completely transparent in all terms... it acts just as a container."
	^ Morph new 
		color: Color transparent;
		clipSubmorphs: true;
		layoutPolicy: FTRowLayout new;
		bounds: aMorph bounds;
		addMorphBack: (FTColumnResizerMorph 
			container: self 
			left: leftColumn 
			right: rightColumn);
		addMorphBack: aMorph;
		yourself! !

!FTTableContainerMorph methodsFor: 'initialization' stamp: ''!
defaultColor

	^Color transparent! !

!FTTableContainerMorph methodsFor: 'drawing' stamp: ''!
drawRowsOn: canvas
	| x y cellWidth cellHeight rowsToDisplay rowSubviews highligtedIndexes primarySelectionIndex |

	self canRefreshValues ifFalse: [ ^ self ].	"Nothing to update yet"

	x := self left + self class rowLeftMargin.
	y := self top.
	cellWidth := self width - self class rowLeftMargin.
	cellHeight := self table rowHeight rounded.
	highligtedIndexes := self table selectedIndexes, self table highlightedIndexes.
	primarySelectionIndex := self table selectedIndex.

	"For some superweird reason, calling #calculateExposedRows here instead in #changed (where
	 it should be called) is 10x faster. Since the whole purpose of this component is speed, for 
	 now I'm calling it here and adding the #setNeedRecalculateRows mechanism. 
	 History, please forgive me."
	self updateAllRows.

	rowsToDisplay := self exposedRows.
	rowSubviews := OrderedCollection new: rowsToDisplay size + 1.
	headerRow ifNotNil: [ 
		headerRow bounds: (self left @ y extent: self width @ cellHeight).
		y := y + cellHeight + self table intercellSpacing y.
		rowSubviews add: headerRow ].
	
	rowsToDisplay keysAndValuesDo: [ :rowIndex :row | 
		| visibleHeight |
		visibleHeight := (self rowHeight: rowIndex default: cellHeight) min: self bottom - y.
		row bounds: (x @ y extent: cellWidth @ visibleHeight).
		y := y + visibleHeight + self table intercellSpacing y.

		rowSubviews add: row.

		(self table selectionModeStrategy
				selectablesToHighlightFromRow: row
				at: rowIndex
				withHighlightedIndexes: highligtedIndexes
				andPrimaryIndex: primarySelectionIndex) 
			keysAndValuesDo: [ :morph :isPrimary | 
				morph selectionColor: (self table colorForSelection: isPrimary) ] ].

	"We should notify existing rows about deletion and new rows about insertion. 
	It is required to correctly manage stepping animation of cells"
	submorphs do: [ :each | 
		each
			privateOwner: nil;
			outOfWorld: self world ].
	submorphs := rowSubviews asArray.
	submorphs do: [ :each | each intoWorld: self world ].

	self table isResizable ifTrue: [ self addResizeSplitters ].

	needsRefreshExposedRows := false! !

!FTTableContainerMorph methodsFor: 'accessing' stamp: ''!
visibleRowMorphAtIndex: index
	^ self exposedRows at: index! !

!FTTableContainerMorph methodsFor: 'testing' stamp: ''!
canRefreshValues
	^ self needsRefreshExposedRows and: [ self table isNotNil and: [ self table hasDataSource ] ]! !

!FTTableContainerMorph methodsFor: 'updating' stamp: ''!
adjustToHorizontalScrollBarValue: aNumber 
	| newStartColumnIndex | 
	newStartColumnIndex := (self table numberOfColumns * aNumber) rounded 
		min: self table numberOfColumns 
		max: 1 .
	newStartColumnIndex ~= self startColumnIndex 
		ifTrue: [ 
			self startColumnIndex: newStartColumnIndex.
			self changed  ]! !

!FTTableContainerMorph class methodsFor: 'accessing' stamp: ''!
rowLeftMargin
	"I'm keeping a small margin beween the list and the begining of a row, to enhance visibility."
	^ 1! !

!FTTableContainerRowNotHomogeneousMorph commentStamp: ''!
I contain table rows, but opposite to my parent, I calculate my row heights allowing users to display tables with rows of different height.!
!FTTableContainerRowNotHomogeneousMorph methodsFor: 'drawing' stamp: ''!
rowHeight: rowIndex default: aNumber
	
	^ self table dataSource rowHeight: rowIndex! !

!FTTableContainerRowNotHomogeneousMorph methodsFor: 'private' stamp: ''!
calculateExactVisibleRows
	"Answer the rows to show in list - with possible fraction"
	| rowIndex maxHeight height |
	
	self table hasDataSource ifFalse: [
		^ super calculateExactVisibleRows ]. 
	
	rowIndex := self table showIndex max: 1.
	height := 0.
	maxHeight := self height.
	headerRow ifNotNil: [ maxHeight := maxHeight - headerRow height ].	
	
	[ (height < maxHeight) and: [ rowIndex <= self table dataSource numberOfRows ] ] 
	whileTrue: [ 
		height := height + (self table dataSource rowHeight: rowIndex).
		rowIndex := rowIndex + 1 ].
	
	^ rowIndex - self table showIndex! !

!FTTableHeaderRowMorph commentStamp: ''!
I'm a header for a table.
All my work is to keep header cells, but my behavior is slightly different to my parent (since I cannot be selected, for example)!
!FTTableHeaderRowMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: event

	^ false! !

!FTTableMorph commentStamp: ''!
I'm an implementation of a table, in a not-naive way. 

I assume I can have many rows, then I do not try to show all of them at once. Instead, I keep a datasource and I demand rows when needed (datasource implements a flyweight to fill the visible rows).

I should not be subclasse. An extension of FastTable should happen on a data source an not here. Extend me ONLY if it is impossible to do what you want on the data source.

Examples: 
-------------
FTTableMorph new
	extent: 200@400;
	dataSource: (FTSimpleDataSource elements: (1 to: 10000));
	openInWindow
	
You can check better examples in FTExamples

A FastTable have the possibility to be searchable, this is activate by default. 
You can disable this with the method #disableSearch.
But you also have the possibility to make your FastTable filterable with the method #enableFilter. But search and filter cannot be use in the same time.

I manage different kind of selections through a strategy design pattern. For example I have a strategy to manage simple or multiple selection and I have a strategy to manage cell or row selection.

Horizontal scrolling being a new feature is not enabled by default. Use #newWithHorizontalScrollBar or set horizontalScrollBar var to anything at early initialization stage (before #initializeScrollBars where it is being checked)


!
!FTTableMorph methodsFor: 'private' stamp: ''!
ensureVisibleFirstSelection
	| rowIndex |
	(self hasSelection not or: [ self container isRowIndexFullyVisible: (rowIndex := self selectionModeStrategy selectedRowIndex) ]) ifTrue: [ ^ self ].

	rowIndex < self showIndex
		ifTrue: [ self moveShowIndexTo: self selectedIndex ]
		ifFalse: [ self moveShowIndexTo: (self selectionModeStrategy indexForRow: rowIndex - self container calculateMinVisibleRows + 1) ]! !

!FTTableMorph methodsFor: 'private' stamp: ''!
rowIndexToVerticalScrollBarValue: aNumber
	| numberOfRows |
	numberOfRows := self numberOfRows - self container calculateMinVisibleRows.
	^ (numberOfRows = 0 or: [ aNumber <= 1 ])
		ifTrue: [ 0.0 ]
		ifFalse: [ ((aNumber / numberOfRows) asFloat max: 0.0) min: 1.0 ]! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
hideColumnHeaders
	showColumnHeaders ifFalse: [ ^ self ].
	showColumnHeaders := false.
	self refresh! !

!FTTableMorph methodsFor: 'private' stamp: ''!
resizeHorizontalScrollBar
	| width height corner |
	horizontalScrollBar ifNotNil: [ 
		width := self bounds width - (self borderWidth * 2) - self verticalScrollBarWidth.
		height := self scrollBarThickness.
		corner := self bounds bottomLeft - ((width + self borderWidth)@(0 - self borderWidth)).
		corner := self bounds bottomLeft - ((0 - self borderWidth)@(height+self borderWidth)).
		self horizontalScrollBar bounds: (corner extent: width@height).
		]! !

!FTTableMorph methodsFor: 'updating' stamp: ''!
refresh
	"Refreshes all internal values (forces an invalidate of all subviews)"
	self ensureAtLeastOneColumn.
	self recalculateVerticalScrollBar.
	self verticalScrollBar changed.
	horizontalScrollBar ifNotNil: [ self horizontalScrollBar changed ].
	self container changed! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
enableSearch
	"Enables search (this is the default option). Not compatible with the filter function.	"

	function := FTSearchFunction table: self! !

!FTTableMorph methodsFor: 'private' stamp: ''!
horizontalScrollBarHeight
	^horizontalScrollBar 
		ifNil: [ 0 ] 
		ifNotNil: [ 
			self isHorizontalScrollBarVisible ifFalse: [ ^ 0 ].
			self scrollBarThickness
			]! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
rowHeight: aNumber
	rowHeight := aNumber! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
enableFilter
	"Enables filtering. Not compatible with the search."

	function := FTFilterFunction table: self! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
highlightIndex: aNumber
	self highlightIndexes: { aNumber }! !

!FTTableMorph methodsFor: '*Iceberg-TipUI' stamp: ''!
useFunction: aFilterFunctionClass do: aBlock 
	function := aFilterFunctionClass table: self.
	aBlock cull: function cull: self! !

!FTTableMorph methodsFor: '*Calypso-Browser' stamp: ''!
filterString
	(function isKindOf: FTFilterFunction) ifFalse: [ ^'' ]. 
	^function pattern ifNil: [ '' ]! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
disableFunction
	"Disabling it just sets the funtion to nil, so I can safely skip it in #keyStrokeSearch:"

	function isExplicit
		ifTrue: [ function disable.
			self resizeAllSubviews	"This is call because now the container will take all the available space." ].
	function := FTNilFunction table: self! !

!FTTableMorph methodsFor: '*Calypso-Browser' stamp: ''!
activateFilterWith: patternString
	(function isKindOf: FTFilterFunction) ifFalse: [ ^self ].
	
	function filterNowWith: patternString! !

!FTTableMorph methodsFor: '*Calypso-Browser' stamp: ''!
cleanupFilter
	"it is ugly. but now it is easy to do like this. Normally it should be somehow supported by table package itself"
	(function isKindOf: FTFilterFunction)
		ifTrue: [ function terminateFilterProcess]! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
resetFunction
	function reset! !

!FTTableMorph methodsFor: 'testing' stamp: ''!
isResizable
	^ resizable! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
deselectAll 
	self selectIndexes: #()! !

!FTTableMorph methodsFor: 'menu' stamp: ''!
showMenuForIndex: aTuple
	| menu rowIndex columnIndex |
	
	rowIndex := aTuple first.
	columnIndex := aTuple second.

	(rowIndex notNil and: [ (self isIndexSelected: rowIndex) not ]) ifTrue: [ 
		self selectIndex: (self selectionModeStrategy indexFromPosition: aTuple) ].

	menu := self dataSource 
		menuColumn: (columnIndex ifNotNil: [self columns at: columnIndex])
		row: (rowIndex ifNil: [0]).
		
	(menu isNil or: [ menu isInWorld ]) ifTrue: [ ^ self ].
	
	menu popUpInWorld: self currentWorld! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
explicitFunction
	function showWidget! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
keyDownSearch: event
	^ function keyDown: event! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
beRowNotHomogeneous
	"by default, tables have homogeneous row heigths, taken from rowHeight variable. 
	 We can switch to variable size by sending this message. 
	 The resulting table will be less effcicient than the first, but probably not in a way users 
	 can notice"
	| oldContainer |

	oldContainer := container.
	container := FTTableContainerRowNotHomogeneousMorph new.
	self replaceSubmorph: oldContainer by: container.
	self resizeAllSubviews! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
keyStrokeSearch: event
	^ function keyStroke: event! !

!FTTableMorph methodsFor: 'event testing' stamp: ''!
handlesMouseDown: event
	^ true! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
beSingleSelection
	selectionStrategy := FTSimpleSelectionStrategy table: self! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
selectionModeStrategy: aStrategy
	(selectionModeStrategy = aStrategy) ifTrue: [ ^ self ].

	selectionModeStrategy := aStrategy.
	self initializeSelectedIndexes! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
selectRowIndex: aNumber
	self deprecated: 'Use #selectIndex: instead' transformWith: '`@receiver selectRowIndex: `@statements1' -> '`@receiver selectIndex: `@statements1'.
	self selectIndex: aNumber! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
intercellSpacing: aNumberOrPoint
	"Determines cell spacing 
		x: space between cells 
		y: space between rows"
	intercellSpacing := aNumberOrPoint asPoint! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
defaultContainer
	^ FTTableContainerMorph new! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
selectIndex: anArray
	self selectIndexes: {anArray}! !

!FTTableMorph methodsFor: 'private' stamp: ''!
ensureAtLeastOneColumn
	self columns ifNotEmpty: [ ^ self ].
	self addColumn: self class defaultColumn! !

!FTTableMorph methodsFor: 'initialization' stamp: ''!
initializeWithHorizontalScrollBar
	horizontalScrollBar := true.
	self initialize.! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
mouseWheel: event

	"I tried scrolling up/down with a calculated value (check #scrollUpByPageDelta implementor)
	 but the scrollbar proved been more intelligent than me... looks like hardcoded values 
	 work better :/"
	event isUp ifTrue: [ 
		self verticalScrollBar scrollRestrictedUp: 3.
		^ self
	].
	event isDown ifTrue: [ 
		self verticalScrollBar scrollRestrictedDown: 3.
		^ self
	].
	
	super mouseWheel: event! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
firstVisibleRowIndex
	
	^ self container firstVisibleRowIndex! !

!FTTableMorph methodsFor: '*Calypso-Browser' stamp: ''!
initialDataSource: aDataSource
	"it is ugly. but now it is easy to do like this. Normally it should be somehow supported by table package itself"
	(function isKindOf: FTFilterFunction)
		ifTrue: [ function initialDataSource: aDataSource]! !

!FTTableMorph methodsFor: 'private' stamp: ''!
basicSelectIndexes: anArray
	selectedIndexes := anArray asArray! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
selectAll
	self isMultipleSelection ifFalse: [ ^ self ].

	self selectionModeStrategy selectAll! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
keyDown: event
	self flag: #pharoTodo. "If the function is explicit this should be redirect to the function widget."
	((super keyDown: event) or: [ self navigationKey: event ])
		ifTrue: [ ^ true ].
		
	^ self keyDownSearch: event! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
beResizable
	resizable := true! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
numberOfRows
	self hasDataSource ifFalse: [ ^ 0 ]. 
	^ self dataSource numberOfRows! !

!FTTableMorph methodsFor: 'private' stamp: ''!
resizeAllSubviews
	self resizeVerticalScrollBar.
	horizontalScrollBar ifNotNil: [ self resizeHorizontalScrollBar ].
	"if we resized scrollbar, we need to recalculate it because values change (and now visibility 
	 can be toggled, shown items can change, etc.)"
	self recalculateVerticalScrollBar.
	self resizeContainer.
	self container setNeedsRefreshExposedRows.
	self container updateExposedRows.
	self verticalScrollBar value: (self rowIndexToVerticalScrollBarValue: showIndex).
	function isExplicit
		ifTrue: [ function resizeWidget ]! !

!FTTableMorph methodsFor: 'accessing - colors' stamp: ''!
secondarySelectionColor 
	^ secondarySelectionColor ifNil: [ self class defaultSecondarySelectionColor ]! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
selectFirst
	self selectionModeStrategy selectFirst! !

!FTTableMorph methodsFor: 'private' stamp: ''!
horizontalScrollBarValue: aNumber
	horizontalScrollBar ifNotNil: [ 
	self container adjustToHorizontalScrollBarValue: aNumber.
	].! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
lastVisibleRowIndex

	^ self container lastVisibleRowIndex! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
highlightIndexes: anArray
	anArray = self highlightedIndexes ifTrue: [ ^ self ].

	self basicHighlightIndexes: anArray.

	(self hasHighlighted and: [ (self isIndexVisible: self highlightedIndex) not ])
		ifTrue: [ self moveShowIndexTo: self highlightedIndexes first.
			^ self ].

	(self hasSelection and: [ (self isIndexVisible: self selectedIndex) not ])
		ifTrue: [ self moveShowIndexTo: self selectedIndex.
			^ self ].

	self refresh! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
mouseMove: event
	event isDraggingEvent ifFalse: [ ^ self ].
	event hand hasSubmorphs ifFalse: [ ^ self ].

	(self wantsDroppedMorph: event hand submorphs first event: event) ifFalse: [ ^ self ].

	(self container rowIndexContainingPoint: event position)
		ifNotNil: [ :rowIndex | 
			self basicHighlightIndexes: {rowIndex}.
			self refresh ].

	(self container bounds containsPoint: event position) ifFalse: [ ^ self ].

	event position y <= (self container top + self autoScrollHeightLimit) ifTrue: [ ^ self verticalScrollBar scrollUp: 1 ].
	event position y >= (self container bottom - self autoScrollHeightLimit) ifTrue: [ ^ self verticalScrollBar scrollDown: 1 ]! !

!FTTableMorph methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
clickOnColumnHeaderAt: anIndex
	| header |
	header := self container headerRow submorphs at: anIndex.
	header click: (MouseButtonEvent basicNew 
							setType: #mouseDown;
							yourself).
		! !

!FTTableMorph methodsFor: '*Calypso-Browser' stamp: ''!
initialDataSource
	"it is ugly. but now it is easy to do like this. Normally it should be somehow supported by table package itself"
	^(function isKindOf: FTFilterFunction)
		ifTrue: [ function initialDataSource]
		ifFalse: [ nil ]! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
addColumn: aColumn
	columns := columns copyWith: aColumn! !

!FTTableMorph methodsFor: 'event testing' stamp: ''!
handlesMouseOverDragging: event
	"Yes, for mouse down highlight."
	^true! !

!FTTableMorph methodsFor: 'accessing - colors' stamp: ''!
colorForSelection: primarySelection
	
	^primarySelection 
		ifTrue: [ self selectionColor ]
		ifFalse: [ self secondarySelectionColor ]! !

!FTTableMorph methodsFor: 'layout' stamp: ''!
minWidth

	^ 100! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
allowsDeselection: aBoolean
	allowsDeselection := aBoolean! !

!FTTableMorph methodsFor: 'private' stamp: ''!
isHorizontalScrollBarVisible
	^horizontalScrollBar 
		ifNil: [ false ] 
		ifNotNil: [ 
			self horizontalScrollBar owner isNotNil.
			]! !

!FTTableMorph methodsFor: 'private' stamp: ''!
isYellowButtonReallyPressed: anEvent
	anEvent yellowButtonPressed ifFalse: [ ^false ].
	"this is shitty fix for VM bug. 
	Now if you will press left mouse button together with pressed cmd (on Mac)
	then you will got right mouse button event.
	Interesting that it is not a problem in case of external SDL2 window.
	Try check it from OSWindowWorldMorph new open"
	^ (Smalltalk os isMacOS) 
		ifTrue: [ anEvent commandKeyPressed not]
		ifFalse: [ anEvent controlKeyPressed not]! !

!FTTableMorph methodsFor: 'private' stamp: ''!
scrollBarThickness
	^ self theme scrollbarThickness! !

!FTTableMorph methodsFor: 'private' stamp: ''!
resizeContainer 
	| topLeft bottomRight |
	topLeft := (self bounds left - self borderWidth) @ self bounds top - self borderWidth.
	bottomRight := (self bounds right  - self verticalScrollBarWidth    - self borderWidth) 
					 @ (self bounds bottom - self horizontalScrollBarHeight - self borderWidth).
	self container
		bounds:
			(function isExplicit
				ifTrue: [ function resizeContainerFrom: topLeft to: bottomRight ]
				ifFalse: [ topLeft corner: bottomRight ])! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
selectionModeStrategy
	^ selectionModeStrategy! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
mouseDown: event
	"perform the click"

	needToggleAtMouseUp ifTrue: [ ^ self ].

	(self selectionModeStrategy selectableIndexContainingPoint: event cursorPoint)
		ifNotNil: [ :index | 
			(self selectedIndexes includes: index)
				ifFalse: [ self selectIndex: index event: event ]
				ifTrue: [ needToggleAtMouseUp := true ] "If the cell is selected we let the mouse up toggle to avoid any problem with the drag and drop" ]
		ifNil: [ ^ self ].

	self wantsKeyboardFocus ifTrue: [ self takeKeyboardFocus ].
	event hand waitForClicksOrDrag: self event: event! !

!FTTableMorph methodsFor: 'event testing' stamp: ''!
handlesKeyboard: event
	^ true! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
highlightedIndexes
	^ highlightedIndexes! !

!FTTableMorph methodsFor: 'initialization' stamp: ''!
initializeKeyBindings
	"add keybindings used by table"

	self 
		bindKeyCombination: Character arrowUp shift | Character arrowUp asKeyCombination
		toAction: [ :target :morph :event | self keyStrokeArrowUp: event ].
	self 
		bindKeyCombination: Character arrowDown shift | Character arrowDown asKeyCombination
		toAction: [ :target :morph :event | self keyStrokeArrowDown: event ].
	self 
		bindKeyCombination: Character arrowLeft shift | Character arrowLeft asKeyCombination
		toAction: [ :target :morph :event | self keyStrokeArrowLeft: event ].
	self 
		bindKeyCombination: Character arrowRight shift | Character arrowRight asKeyCombination
		toAction: [ :target :morph :event | self keyStrokeArrowRight: event ].
	self 
		bindKeyCombination: Character home asKeyCombination
		toAction: [ self selectFirst ].
	self 
		bindKeyCombination: Character end asKeyCombination
		toAction: [ self selectLast ].
	self 
		bindKeyCombination: self shortcutProvider selectAllShortcut
		toAction: [ self selectAll ]! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
numberOfColumns 
	^ columns size! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
showFirstSelection
	self hasSelection ifFalse: [ ^ self ].
	self moveShowIndexTo: self selectedIndex! !

!FTTableMorph methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
hasFilter

	function ifNil: [ ^ false ].
	^ function isKindOf: FTFilterFunction! !

!FTTableMorph methodsFor: 'layout' stamp: ''!
minHeight 
	"Ceiling is required because there is strange behavior when this method return float.
	In that case table stop respond to any events like clicks"
	
	^ self 
		valueOfProperty: #minHeight
		ifAbsent:[ self class defaultRowHeight ceiling ]! !

!FTTableMorph methodsFor: 'private' stamp: ''!
container 
	^ container! !

!FTTableMorph methodsFor: 'private' stamp: ''!
selectionStrategy
	^ selectionStrategy! !

!FTTableMorph methodsFor: 'private' stamp: ''!
isVerticalScrollBarVisible
	^ self verticalScrollBar owner isNotNil! !

!FTTableMorph methodsFor: 'drag and drop' stamp: ''!
wantsDroppedMorph: aMorph event: event
	aMorph isTransferable ifFalse: [ ^false ].
	^ self dataSource 
		wantsDropElements: aMorph passenger
		type: aMorph dragTransferType
		index: ((self container rowIndexContainingPoint: event position) ifNil: [ 0 ])! !

!FTTableMorph methodsFor: 'testing' stamp: ''!
hasSelection
	^ self selectedIndexes isNotEmpty! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
setMultipleSelection: aBoolean

	aBoolean
		ifTrue: [ self beMultipleSelection ]
		ifFalse: [ self beSingleSelection ]! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
click: event
	"check for right click (menu)"

	(self isYellowButtonReallyPressed: event)
		ifTrue: [ self showMenuForPosition: event cursorPoint ]! !

!FTTableMorph methodsFor: '*Calypso-Browser' stamp: ''!
filterField
	^(function isKindOf: FTFilterFunction )
		ifTrue: [ function field]
		ifFalse: [ nil ]! !

!FTTableMorph methodsFor: 'private' stamp: ''!
verticalScrollBarValueToRowIndex: aNumber
	| startingIndex |
	startingIndex := self dataSource numberOfRows - self container calculateMinVisibleRows + 1.
	^ (startingIndex * aNumber) asInteger! !

!FTTableMorph methodsFor: 'private' stamp: ''!
showIndex 
	^ showIndex! !

!FTTableMorph methodsFor: 'private' stamp: ''!
announceScrollChangedFrom: oldIndex to: newIndex
	"If the index did not change, do nothing"
	oldIndex = newIndex ifTrue: [ ^ self ].
	self
		doAnnounce:
			((FTScrollingChanged from: oldIndex to: newIndex)
				fastTable: self;
				yourself)! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
columns
	^ columns! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
keyStrokeArrowLeft: event
	(self selectionModeStrategy is: self selectedIndex afterColumn: 1) ifFalse: [ ^ self ].
	self resetFunction.
	self selectIndex: (self selectionModeStrategy selectableIndexBefore: self selectedIndex) event: event! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
keyboardFocusChange: aBoolean
	"The message is sent to a morph when its keyboard focus changes.
	Update for focus feedback."
	super keyboardFocusChange: aBoolean.
	self focusChanged! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
enableFilterWithAction: aBlock named: aString
	"Enables filtering and add an Action button. Not compatible with the search. If I am use, the function must be explicit."

	function := FTActionFilterFunction table: self action: aBlock named: aString.
	self explicitFunction! !

!FTTableMorph methodsFor: 'private' stamp: ''!
moveShowIndexTo: arg
	"I move the showing index to a specific row, and perform a refresh of subviews. 
	 I should not be used directly, and most methods that need to move the 
	 showing pointer should do it directly. 
	 Use me just in case you need to force a refresh after settign the index"

	| index oldIndex |
	index := self selectionModeStrategy rowIndexFrom: arg.
	oldIndex := showIndex.
	self basicMoveShowIndexTo: index.
	self verticalScrollBar value: (self rowIndexToVerticalScrollBarValue: index).
	self refresh.
	
	self announceScrollChangedFrom: oldIndex to: index.! !

!FTTableMorph methodsFor: 'private' stamp: ''!
scrollToIndex: anIndex
	(self container isRowIndexFullyVisible: anIndex) ifTrue: [ ^ self ].

	anIndex <= self showIndex
		ifTrue: [ self moveShowIndexTo: anIndex ]
		ifFalse: [ self moveShowIndexTo: (self selectionModeStrategy indexForRow: anIndex - self container calculateMinVisibleRows + 1) ]! !

!FTTableMorph methodsFor: 'updating' stamp: ''!
themeChanged
	self color: self defaultColor.
	super themeChanged.
	self refresh! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
selectedIndexes
	^ selectedIndexes! !

!FTTableMorph methodsFor: 'private' stamp: ''!
recalculateVerticalScrollBarVisibilityIfHidden: aBlock
	self container calculateExactVisibleRows >= self dataSource numberOfRows
		ifTrue: [ 
			(self isVerticalScrollBarVisible)
				ifTrue: [ self removeMorph: self verticalScrollBar ].
			self resizeContainer. "it changed... I need to resize it immediately because 
			otherwise it does not work fine with first show... this can cause two sends to 
			#resizeContainer but the case is minimal and not expensive, so we can ignore it"
			aBlock value ]
		ifFalse: [ 
			(self isVerticalScrollBarVisible)
				ifFalse: [ 
					self resizeVerticalScrollBar.
					self addMorph: self verticalScrollBar ] ]! !

!FTTableMorph methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas 
	"Draw the focus here since we are using inset bounds
	for the focus rectangle."
	"1haltOnce."
	super drawSubmorphsOn: aCanvas.
	self hasKeyboardFocus ifTrue: [ self drawKeyboardFocusOn: aCanvas ]! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
enableFilterWithAction: aBlock
	"Enables filtering and add an Action button. Not compatible with the search."

	self enableFilterWithAction: aBlock named: 'Validate.'! !

!FTTableMorph methodsFor: 'testing' stamp: ''!
hasDataSource
	^ self dataSource notNil! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
showColumnHeaders
	"Indicates table will show column headers. 
	 See #hideColumnHeaders"
	showColumnHeaders ifTrue: [ ^ self ].
	showColumnHeaders := true.
	self refresh! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
keyStrokeArrowRight: event
	(self selectionModeStrategy is: self selectedIndex beforeColumn: self numberOfColumns) ifFalse: [ ^ self ].
	self resetFunction.
	self selectIndex: (self selectionModeStrategy selectableIndexAfter: self selectedIndex) event: event! !

!FTTableMorph methodsFor: 'private' stamp: ''!
verticalScrollBar
	^ verticalScrollBar! !

!FTTableMorph methodsFor: '*Iceberg-TipUI' stamp: ''!
selectFirstVisibleRow
	^ self
		selectIndex:
			(container exposedRows
				ifNotEmpty: [ :rows | rows keys first ]
				ifEmpty: [ 0 ])! !

!FTTableMorph methodsFor: 'event testing' stamp: ''!
handlesMouseWheel: event
	^self isVerticalScrollBarVisible and: [ self hasDataSource ]! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
selectIndexes: anArray
	self selectIndexes: anArray andMakeVisibleIf: true! !

!FTTableMorph methodsFor: 'initialization' stamp: ''!
initializeScrollBars
	verticalScrollBar := ScrollBarMorph new 
		model: self; 
		setValueSelector: #verticalScrollBarValue:;
		yourself.
	self addMorph: verticalScrollBar.

	"introducing horizontal scrolling gradually: 
	enable the feature only when the var is set during initialization"
	horizontalScrollBar ifNotNil: [ 	
		horizontalScrollBar := ScrollBarMorph new 
			model: self; 
			setValueSelector: #horizontalScrollBarValue:;
			yourself.
		self addMorph: horizontalScrollBar
		].! !

!FTTableMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	showIndex := 0.
	showColumnHeaders := true.
	columns := #().
	needToggleAtMouseUp := false.
	self beRowSelection.
	self beNotResizable.
	self beSingleSelection.
	self enableSearch.
	self initializeScrollBars.
	self initializeContainer.
	self initializeKeyBindings.

	self resizeAllSubviews! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
selectedIndex
	^ self selectedIndexes ifNotEmpty: #first ifEmpty: [ self selectionModeStrategy nullIndex ]! !

!FTTableMorph methodsFor: 'drag and drop' stamp: ''!
acceptDroppingMorph: aMorph event: event
	self dataSource dropElements: aMorph passenger index: ((self container rowIndexContainingPoint: event position) ifNil: [ 0 ]).
	self basicHighlightIndexes: #().
	self refresh! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
keyStrokeArrowUp: event
	(self selectionModeStrategy is: self selectedIndex bellowRow: 1) ifFalse: [ ^ self ].
	self resetFunction.
	self selectIndex: (self selectionModeStrategy selectableIndexAbove: self selectedIndex) event: event! !

!FTTableMorph methodsFor: 'private' stamp: ''!
basicMoveShowIndexTo: aNumber

	showIndex := aNumber! !

!FTTableMorph methodsFor: 'private' stamp: ''!
resizeVerticalScrollBar
	| width height corner |
	width := self scrollBarThickness.
	height := self bounds height - (self borderWidth * 2) - self horizontalScrollBarHeight.
	corner := self bounds topRight - ((width + self borderWidth)@(0 - self borderWidth)).
	self verticalScrollBar bounds: (corner extent: width@height)! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
columns: aCollection 
	columns := aCollection asArray! !

!FTTableMorph methodsFor: 'accessing - colors' stamp: ''!
selectionColor: aColor
	selectionColor := aColor! !

!FTTableMorph methodsFor: 'private' stamp: ''!
selectIndex: index event: event
	index
		ifNotNil: [ self selectionStrategy selectIndex: index event: event ]
		ifNil: [ self deselectAll ]! !

!FTTableMorph methodsFor: 'testing' stamp: ''!
allowsDeselection
	^ allowsDeselection ifNil: [ self class defaultAllowsDeselection ]! !

!FTTableMorph methodsFor: 'testing' stamp: ''!
isIndexVisible: anIndex
	^ self container isRowIndexVisible: anIndex! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
beCellSelection
	self selectionModeStrategy: (FTCellSelectionModeStrategy table: self)! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
keyStroke: event
	self flag: #pharoTodo. "If the function is explicit this should be redirect to the function widget."
	((super keyStroke: event) or: [ self navigationKey: event ])
		ifTrue: [ ^ true ].
		
	^ self keyStrokeSearch: event! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
rowHeight
	"This is the row height your rows will have. Cells answered in dataSource will be forced to have
	 this height number... We force it instead allowing lists to have any height because the logic to 
	 calculate rows becomes complicated. Possible, but complicated :)"
	^ rowHeight ifNil: [ rowHeight := self class defaultRowHeight ]! !

!FTTableMorph methodsFor: 'menu' stamp: ''!
showMenuForPosition: aPoint
	| tuple |
	tuple := self container rowAndColumnIndexContainingPoint: aPoint.
	self showMenuForIndex: tuple! !

!FTTableMorph methodsFor: 'drag and drop' stamp: ''!
startDrag: event

	| passengers transferMorph |

	event hand hasSubmorphs ifTrue: [^ self]. 
	self dragEnabled ifFalse: [^ self].
	"Here I ensure at least one element is selected "
	event hand anyButtonPressed ifFalse: [ ^self ].
	self hasSelection ifFalse: [ ^ self ].
			
	passengers := self selectedIndexes collect: [ :each | self dataSource passengerAt: each ].
	transferMorph := self dataSource transferFor: passengers from: self.
	transferMorph align: transferMorph draggedMorph topLeft with: event position.
	transferMorph dragTransferType: self dataSource dragTransferType.
	
	event hand grabMorph: transferMorph! !

!FTTableMorph methodsFor: 'private' stamp: ''!
resetPosition
	"Resets all values to original value"
	showIndex := 0.
	self verticalScrollBar value: 0.
	horizontalScrollBar ifNotNil: [	self horizontalScrollBar value: 0 ].
	self container setNeedsRefreshExposedRows.
	self container updateExposedRows.! !

!FTTableMorph methodsFor: 'testing' stamp: ''!
isRowIndexVisible: rowIndex
	self deprecated: 'Use #isIndexVisible: instead' transformWith: '`@receiver isRowIndexVisible: `@statements1' -> '`@receiver isIndexVisible: `@statements1'.
	^ self isIndexVisible: rowIndex! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
mouseUp: event
	needToggleAtMouseUp ifFalse: [ ^ self ].

	"perform the click if the mouse down didn't do it."
	(self selectionModeStrategy selectableIndexContainingPoint: event cursorPoint) ifNotNil: [ :index | self selectIndex: index event: event ].

	needToggleAtMouseUp := false! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
beNotResizable
	resizable := false! !

!FTTableMorph methodsFor: 'initialization' stamp: ''!
defaultColor

	^self class defaultBackgroundColor! !

!FTTableMorph methodsFor: 'testing' stamp: ''!
isMultipleSelection
	^ self selectionStrategy isMultiple! !

!FTTableMorph methodsFor: 'testing' stamp: ''!
hasHighlighted
	^ self highlightedIndexes notEmpty! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
selectIndexes: anArray andMakeVisibleIf: shouldEnsureVisibleSelection
	| oldSelectedIndexes |
	anArray = self selectedIndexes ifTrue: [ ^ self ].
	oldSelectedIndexes := self selectedIndexes.
	self basicSelectIndexes: anArray.
	shouldEnsureVisibleSelection ifTrue: [ self ensureVisibleFirstSelection ].
	self refresh.
	self
		doAnnounce:
			((FTSelectionChanged from: oldSelectedIndexes to: self selectedIndexes)
				fastTable: self;
				yourself)! !

!FTTableMorph methodsFor: 'private' stamp: ''!
verticalScrollBarValue: aNumber

	self hasDataSource ifFalse: [ ^ self ].
	
	showIndex := self verticalScrollBarValueToRowIndex: aNumber.
	
	self container changed! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
intercellSpacing 
	^ intercellSpacing ifNil: [ self class defaultIntercellSpacing ]! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
visibleRowMorphAtIndex: index
	^ container visibleRowMorphAtIndex: index! !

!FTTableMorph methodsFor: 'updating' stamp: ''!
autoScrollHeightLimit

	^20! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
doubleClick: event
	(self selectionModeStrategy selectableIndexContainingPoint: event cursorPoint) ifNotNil: [ :index | self doAnnounce: (FTStrongSelectionChanged index: index event: event) ]! !

!FTTableMorph methodsFor: 'private' stamp: ''!
verticalScrollBarWidth
	self isVerticalScrollBarVisible ifFalse: [  ^ 0 ].
	^ self scrollBarThickness! !

!FTTableMorph methodsFor: 'testing' stamp: ''!
isIndexSelected: rowIndex
	^ self selectedIndexes includes: rowIndex! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
mouseEnterDragging: event
	self enabled ifFalse: [ ^ self ].
	(event hand hasSubmorphs and: [ self dropEnabled ]) 
		ifFalse: [ "no d&d" ^ super mouseEnterDragging: event ].! !

!FTTableMorph methodsFor: 'updating' stamp: ''!
update: symbol
	symbol == #refresh ifTrue: [ ^ self refresh ].
	^ super update: symbol! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
allowDeselection
	self allowsDeselection: true! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
keyStrokeArrowDown: event
	(self selectionModeStrategy is: self selectedIndex aboveRow: self numberOfRows) ifFalse: [ ^ self ].
	self resetFunction.
	self selectIndex: (self selectionModeStrategy selectableIndexBellow: self selectedIndex) event: event! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
handleMouseMove: anEvent
	"Reimplemented because we really want #mouseMove when a morph is dragged around"
	anEvent wasHandled ifTrue:[^self]. "not interested"
	(anEvent anyButtonPressed) ifFalse:[^self].
	anEvent wasHandled: true.
	self mouseMove: anEvent! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
enableFilter: aFTFilterClass
	"Enables filtering. Not compatible with the search."

	self enableFilter.
	function filterClass: aFTFilterClass! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
dataSource
	"Answers a dataSource: the component responsible of providing data to the table. 
	 Check FTDataSource and subclasses as reference."
	^ dataSource! !

!FTTableMorph methodsFor: 'private' stamp: ''!
horizontalScrollBar
	^ horizontalScrollBar! !

!FTTableMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	super extent: aPoint.
	container extent: aPoint.
	self resizeAllSubviews! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
shortcutProvider
	^ PharoShortcuts current! !

!FTTableMorph methodsFor: 'accessing - colors' stamp: ''!
headerColor
	^ headerColor ifNil: [ self class defaultHeaderColor ]! !

!FTTableMorph methodsFor: 'initialization' stamp: ''!
initializeSelectedIndexes
	selectedIndexes := #().
	highlightedIndexes := #()! !

!FTTableMorph methodsFor: 'initialization' stamp: ''!
initializeContainer
	container := self defaultContainer.
	self addMorph: container! !

!FTTableMorph methodsFor: 'accessing - colors' stamp: ''!
selectionColor
	^ selectionColor ifNil: [ self class defaultSelectionColor ]! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
beMultipleSelection
	selectionStrategy := FTMultipleSelectionStrategy table: self! !

!FTTableMorph methodsFor: 'private' stamp: ''!
recalculateVerticalScrollBar
	| interval delta pageDelta visibleRows numberOfRows |
	
	self hasDataSource ifFalse: [ ^ self ].

	self recalculateVerticalScrollBarVisibilityIfHidden: [ ^ self ].
	 
	visibleRows := self container calculateExactVisibleRows.	
	numberOfRows := self dataSource numberOfRows.
	numberOfRows = 0 ifTrue: [ ^self ].
	interval := (visibleRows / numberOfRows) asFloat.
	delta := 1/numberOfRows.
	pageDelta := ((visibleRows-1) floor)*delta.
	self verticalScrollBar 
		scrollDelta: delta pageDelta: pageDelta;
		interval: interval! !

!FTTableMorph methodsFor: 'testing' stamp: ''!
isShowColumnHeaders
	^ showColumnHeaders! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
highlightedIndex
	^ self highlightedIndexes ifNotEmpty: #first ifEmpty: [ 0 ]! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
dataSource: anObject
	dataSource := anObject.
	dataSource table: self.
	dataSource readyToBeDisplayed.
	self resetPosition.
	self refresh! !

!FTTableMorph methodsFor: 'accessing - colors' stamp: ''!
secondarySelectionColor: aColor
	secondarySelectionColor := aColor! !

!FTTableMorph methodsFor: 'accessing - selection' stamp: ''!
selectLast
	self selectionModeStrategy selectLast! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
beRowSelection
	self selectionModeStrategy: (FTRowSelectionModeStrategy table: self)! !

!FTTableMorph methodsFor: 'accessing' stamp: ''!
denyDeselection
	self allowsDeselection: false! !

!FTTableMorph methodsFor: 'private' stamp: ''!
basicHighlightIndexes: anArray
	highlightedIndexes := anArray asArray! !

!FTTableMorph methodsFor: 'event testing' stamp: ''!
takesKeyboardFocus
	^ self enabled! !

!FTTableMorph methodsFor: 'event handling' stamp: ''!
mouseLeaveDragging: event
	"The mouse has left with a button down."

	(self dropEnabled and: [ event hand hasSubmorphs ]) ifFalse: [ "no d&d" ^ super mouseLeaveDragging: event ].

	self basicHighlightIndexes: #().
	self refresh! !

!FTTableMorph class methodsFor: 'accessing' stamp: ''!
defaultBackgroundColor
	^ self theme listBackgroundColor! !

!FTTableMorph class methodsFor: 'accessing' stamp: ''!
defaultHeaderColor
	self flag: #pharoFixMe.	"I think we should deprecate all this headerColor stuff. This is 
	responsibility of data source, after all.
	
	Cyril: I added a deprecation on #headerColor: explaining how to update the users of this method. In Pharo 9 we can remove all this."
	^ self theme fastTableHeaderColor! !

!FTTableMorph class methodsFor: 'accessing' stamp: ''!
defaultRowHeight
	^ StandardFonts defaultFont pixelSize + 7! !

!FTTableMorph class methodsFor: 'accessing' stamp: ''!
defaultColumn	
	^ FTColumn new! !

!FTTableMorph class methodsFor: 'accessing' stamp: ''!
defaultIntercellSpacing
	^ 0@0! !

!FTTableMorph class methodsFor: 'accessing' stamp: ''!
defaultSecondarySelectionColor
	^ self theme secondarySelectionColor! !

!FTTableMorph class methodsFor: 'temporary' stamp: ''!
newWithHorizontalScrollBar
	"This method is temporary to introduce horisontal scrolling gradually"
	"See GTExamples class >> exampleTableHorizontalScroll"
	^self basicNew initializeWithHorizontalScrollBar! !

!FTTableMorph class methodsFor: 'accessing' stamp: ''!
defaultSelectionColor
	^ self theme selectionColor! !

!FTTableMorph class methodsFor: 'accessing' stamp: ''!
defaultAllowsDeselection
	^ false! !

!FTTableRowMorph commentStamp: ''!
I'm a row for a table.
All my work is to keep cells.!
!FTTableRowMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		clipSubmorphs: true;
		layoutPolicy: FTRowLayout new! !

!FTTableRowMorph methodsFor: 'initialization' stamp: ''!
initializeTable: tableMorph 
	self initialize.
	self 
		cellInset: tableMorph intercellSpacing";
		layoutInset: tableMorph intercellSpacing".
	self flag: #pharoTodo. "Check if layout inset works better"! !

!FTTableRowMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt
	self table ifNotNil: [ :table | ^ table selectionModeStrategy allowsRowSelection ].
	^ false! !

!FTTableRowMorph class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #table:'! !

!FTTableRowMorph class methodsFor: 'instance creation' stamp: ''!
table: aTableMorph
	^ self basicNew
		initializeTable: aTableMorph;
		yourself! !

!FTTreeDataSource commentStamp: ''!
I am a data source to diplay tree in a FastTable.

Description
-------------------------------------------------

I receive  a collection of objects and a block. 
The collection of objects will be the base of the tree.

An  alternative is to pass a FTRootItem to myself.

The block is use to calculate the children of the nodes. (More detail at the bottom)
Since the search in Tree is can be complex you can customize it via the #searchStrateagy:. (See Public APIʦor more info.) 

I use FTTreeItem to manage my elements and I am use by a FTFastTable.

Public API and Key Messages
-------------------------------------------------

- #roots: aCollection children: aBlock 
        A constructor to build the FTTreeDataSource  
	
- #maxDepth 
        Set the maxDepth to diplay on the Tree.  Roots items are at depth 0.

- #searchStrategy: 
         Can take in parameter #default, #rootsOnly, #allItems.
                #default is selected by default, it will search/filter the tree for all visible rows.       
               #rootsOnly will search/filter only the first level of the tree
               #allItems will search/filter all the Tree and open the needed items. BEʃAREFUL !! YOUʓHOULDʎOTʕSEʔHISʉFʊYOURʔREEʃANʈAVEʁNʉNFINITYʏFʃHILDREN!! 

Example
-------------------------------------------------

	| ds |
	
	ds := FTTreeDataSource roots: (ProtoObject allSubclasses sort: [ :a :b | a asString < b asString ]) children: [ :item | item subclasses sort: [ :a :b | a asString < b asString ] ].
	
	ds maxDepth: 4;
	searchStrategy: #allItems.
	
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		explicitFunction;
		openInWindow
	
	
Internal Representation and Key Implementation Points.
-------------------------------------------------

    Instance Variables
	childrenBlock:		I am a block use to generate the children of the Items. I can have 3 arguments: the current Item,   the collection of roots items and the depth of the item.
	items:		I am a collection of FTTreeItem that old the items of the first level of the tree.
	maxDepth:		I am an Integer that represent the max depth to dispaly.  If I am nil I display everything
	searchStrategy: 	 	I am a symbole to know what kind of search/filter strategy I need to apply.
			
    Class Variables
	SearchStrategies 		I am a Dictionary that map a Symbole (see searchStrategy) with a class that can search through a dataSource.  
!
!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
	| item cell |
	item := self elementAt: rowIndex.
	cell := FTIndentedCellMorph new.
	cell indentBy: item depth * 16.
	
	cell addMorphBack: (self buttonFor: item).
	cell addMorphBack: (self toString: item data) asMorph.
	^ cell! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
childrenBlock: aBlockClosure
	childrenBlock := aBlockClosure! !

!FTTreeDataSource methodsFor: 'updating' stamp: ''!
updateData
	"I am here to reset the items in case someone updated them."

	self rootItem updateData.
	self tableRefresh! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
searchStrategy: anObject
	"Can be #default, #rootsOnly or #allItems. Use #allItems ONLY if the tree have not an infinit number of children, else you will get an infinit loop."

	searchStrategy := anObject! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
numberOfRows
	^ self rootItem numberOfVisibleChildren! !

!FTTreeDataSource methodsFor: 'updating' stamp: ''!
updateSelectionWithCollectBlock: aBlock
	"I take a block with two parameters, the index of a selected element and 
	the index of the item that collapsed/expanded. This block needs to return 
	the index of the new selected element. I do not ensure that any of the
	newly selected elements are visible. Use #ensureVisibleFirstSelection for that."

	| index |
	self table selectedIndexes ifEmpty: [ ^ self ].
	
	index := self indexOfChangedItem.
	self table 
		selectIndexes: ((self table selectedIndexes collect: [ :ind | 
			aBlock value: ind value: index ]) asSet) asArray 
		andMakeVisibleIf: false! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	rowIndex = 0
		ifTrue: [ ^ nil ].	"I could answer a menu without selection, but in this case I will just answer nil, which means 'no menu'"
			
	^ (UIManager default newMenuIn: self table for: self)
		add: 'Expand All ' target: self selector: #expandAll;
		add: 'Collapse All' target: self selector: #collapseAll;
		yourself! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
searchStrategy
	^ searchStrategy ifNil: [ #default ]! !

!FTTreeDataSource methodsFor: 'expanding-collapsing' stamp: ''!
collapseAll
	rootItem collapseAll.
	self tableRefresh! !

!FTTreeDataSource methodsFor: 'sorting' stamp: ''!
sortElements: aSortFunction
	unsortedElements ifNil: [ unsortedElements := self rootsItems ].
	self rootItem children: (self rootItem children sorted: aSortFunction)! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
rootItem: anObject
	rootItem := anObject! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
childrenBlock
	^ childrenBlock! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
maxDepth: anObject
	maxDepth := anObject! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
newDataSourceMatching: aFTFilter
	"I delegate the filter to a FTTreeFunctionStrategy."

	^ (self class searchStrategies at: self searchStrategy ifAbsent: [ self class searchStrategies at: #default ]) filterWith: aFTFilter pattern dataSource: self! !

!FTTreeDataSource methodsFor: 'updating' stamp: ''!
indexOfChangedItem
	"I should be call when the user of the Fast Tree collapse or extand an Item. I return the index of the changed item. I should not be used by an other method than #updateSelectionWithCollectBlock:."

	1 to: self numberOfRows do: [ :index | 
		(self elementAt: index) recentlyChanged
			ifTrue: [ ^ index ] ].
		
	^ self errorSubscriptBounds: self numberOfRows + 1! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
elementAt: index
	^ rootItem childAt: index! !

!FTTreeDataSource methodsFor: 'expanding-collapsing' stamp: ''!
expandAll
	rootItem expandAll.
	self tableRefresh! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
rootItem
	^ rootItem! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
realElementAt: anIndex
	^ (super realElementAt: anIndex) data! !

!FTTreeDataSource methodsFor: 'testing' stamp: ''!
canDisplayChildrenOf: item
	^ self maxDepth ifNil: [ true ] ifNotNil: [ self maxDepth > item depth ]! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString
	"I delegate the search to a FTTreeFunctionStrategy."

	^ (self class searchStrategies at: self searchStrategy ifAbsent: [ self class searchStrategies at: #default ]) searchWith: aString dataSource: self! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
rootsItems
	^ rootItem children! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
buttonFor: item
	^ ( (self canDisplayChildrenOf: item) and: [item children isNotEmpty])
		ifTrue: [ item generateButton ]
		ifFalse: [ self class emptyMorph ]! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
maxDepth
	^ maxDepth! !

!FTTreeDataSource methodsFor: 'updating' stamp: ''!
addSourceToRootItem
	rootItem dataSource: self! !

!FTTreeDataSource methodsFor: 'expanding-collapsing' stamp: ''!
expandRoots
	self rootsItems do: #expand.
	self tableRefresh! !

!FTTreeDataSource methodsFor: 'sorting' stamp: ''!
unsortElements
	self rootItem children: unsortedElements.
	unsortedElements := nil! !

!FTTreeDataSource methodsFor: 'accessing' stamp: ''!
headerColumn: column
	^ self basicHeaderCellFor: column! !

!FTTreeDataSource methodsFor: 'expanding-collapsing' stamp: ''!
expandAllTo: aDepth
	self rootItem expandAllTo: aDepth! !

!FTTreeDataSource class methodsFor: 'instance creation' stamp: ''!
root: aRootItem children: aBlock
	^ self new
		rootItem: aRootItem;
		childrenBlock: aBlock;
		addSourceToRootItem;
		yourself! !

!FTTreeDataSource class methodsFor: 'class initialization' stamp: ''!
initialize
	"self initialize"

	SearchStrategies := nil! !

!FTTreeDataSource class methodsFor: 'accessing' stamp: ''!
rootItemFor: aCollection
	^ FTRootItem new
		data: aCollection;
		yourself! !

!FTTreeDataSource class methodsFor: 'accessing' stamp: ''!
searchStrategies
	^ SearchStrategies ifNil: [ SearchStrategies := self defaultSearchStrategies ]! !

!FTTreeDataSource class methodsFor: 'accessing' stamp: ''!
defaultSearchStrategies
	^ Dictionary new
		at: #rootsOnly put: FTRootItemsStrategy;
		at: #default put: FTVisibleItemsStrategy;
		at: #allItems put: FTAllItemsStrategy;
		yourself! !

!FTTreeDataSource class methodsFor: 'utilities - morph creation' stamp: ''!
emptyMorph
	| icon |
	icon := (Smalltalk ui icons iconNamed: #emptyIcon) asMorph.
	icon form: (icon form scaledToSize: 16 @ 16).
	^ icon! !

!FTTreeDataSource class methodsFor: 'accessing' stamp: ''!
searchStrategies: anObject
	SearchStrategies := anObject! !

!FTTreeDataSource class methodsFor: 'instance creation' stamp: ''!
roots: aCollection children: aBlock
	^ self root: (self rootItemFor: aCollection) children: aBlock! !

!FTTreeFunctionStrategy commentStamp: ''!
I am an abstract class that describe a Strategy to search/filter a FTTreeDataSource.

Description
----------------------

I have a dataSource that I can use and I can have a seach pattern which I use to search/filter the dataSource if needed.

I am use by a FTTreeDataSource and I help it with the possible FTFunction of his FTTableMorph. 

Public API and Key Messages
----------------------

- #search    	activate a search of the dataSource with the current pattern.
	
- #filter    	activate the filter of the dataSource with the current pattern.
	
- #searchWith: aString dataSource: dataSource 	is one of my constructors, it return the result of a search.

-#filterWith: aRegex dataSource: dataSource 	is an other of my constructor, it returns a new dataSource filtered by the regex. 
	
Example
----------------------

I am an abstract class. I should not be use.
 
Internal Representation and Key Implementation Points.
----------------------

    Instance Variables
	dataSource:		The data source I need to search/filter.
	pattern:		The search pattern in need to use,  this is a String or a Regex.
!
!FTTreeFunctionStrategy methodsFor: 'action' stamp: ''!
filter
	"I need to return a new dataSource that filter my dataSource."

	self subclassResponsibility! !

!FTTreeFunctionStrategy methodsFor: 'accessing' stamp: ''!
dataSource: anObject
	dataSource := anObject! !

!FTTreeFunctionStrategy methodsFor: 'accessing' stamp: ''!
pattern: aStringOrRegex
	pattern := aStringOrRegex! !

!FTTreeFunctionStrategy methodsFor: 'accessing' stamp: ''!
isMatching: anItem
	^ (dataSource toString: anItem) beginsWith: pattern! !

!FTTreeFunctionStrategy methodsFor: 'action' stamp: ''!
realSearch
	"I need to return a collection of index that match the elements I find."

	self subclassResponsibility! !

!FTTreeFunctionStrategy methodsFor: 'accessing' stamp: ''!
dataSource
	^ dataSource! !

!FTTreeFunctionStrategy methodsFor: 'action' stamp: ''!
optionalOperations
	^ pattern isEmptyOrNil
		ifTrue: [ #() ]
		ifFalse: [ nil ]! !

!FTTreeFunctionStrategy methodsFor: 'action' stamp: ''!
search
	^ self optionalOperations 
		ifNotNil: [ :res | res ]
		ifNil: [ self realSearch]! !

!FTTreeFunctionStrategy class methodsFor: 'updating' stamp: ''!
patternFromString: aString
	" do not throw an error if the pattern is bad - important in case of auto-accepting"

	^ [ aString asRegexIgnoringCase ]
		on: RegexSyntaxError
		do: [ :ex | '' asRegexIgnoringCase ]! !

!FTTreeFunctionStrategy class methodsFor: 'instance creation' stamp: ''!
filterWith: aString dataSource: aDataSource
	^ self new
		pattern: (self patternFromString: aString);
		dataSource: aDataSource;
		filter! !

!FTTreeFunctionStrategy class methodsFor: 'instance creation' stamp: ''!
searchWith: aString dataSource: aDataSource
	^ self new pattern: aString; dataSource: aDataSource; search! !

!FTTreeItem commentStamp: ''!
I am an abstract class to define an Item use by a tree data source of Fast table.

Description
-------------------------------------------------

I define the basics methods needed by a FTTreeDataSource. 
I use FTTreeItem to manage my elements and I am use by a FTFastTable.

Public API and Key Messages
-------------------------------------------------

- #data. anObject from: aFTTreeDataSource
	This is my constructor that is use by FTTreeDataSource and myself
	
Example
-------------------------------------------------

Should not be instanciate.
 
Internal Representation and Key Implementation Points.
-------------------------------------------------

    Instance Variables
	dataSource:		I am the dataSource that holds this Item. 
	children:		I am a collection of Items calculate by the item. I contains the chldren of the Item.

!
!FTTreeItem methodsFor: 'updating' stamp: ''!
selectedRowsIndexesFrom: anInteger
	| index selfSelection |
	index := anInteger.
	self recentlyChanged
		ifTrue: [ ^ (self dataSource table selectedIndexes select: [ :each | each between: index and: index + self numberOfVisibleChildren ]) ifEmpty: [ {} ] ifNotEmpty: [ {index} ] ].
	selfSelection := (self dataSource table selectedIndexes includes: index)
		ifTrue: [ {index} ]
		ifFalse: [ {} ].
	self isExpanded
		ifFalse: [ ^ selfSelection ].
	index := index + 1.
	^ (self children
		flatCollect: [ :child | 
			| result |
			result := child selectedRowsIndexesFrom: index.
			index := index + 1 + child numberOfVisibleChildren.
			result ]) , selfSelection! !

!FTTreeItem methodsFor: 'expanding-collapsing' stamp: ''!
expandAll
	self subclassResponsibility! !

!FTTreeItem methodsFor: 'accessing' stamp: ''!
data: aData
	self subclassResponsibility! !

!FTTreeItem methodsFor: 'accessing' stamp: ''!
children
	self subclassResponsibility! !

!FTTreeItem methodsFor: '*Iceberg-TipUI' stamp: ''!
isRoot
	^ false! !

!FTTreeItem methodsFor: 'testing' stamp: ''!
hasChildren
	^ self children size ~= 0! !

!FTTreeItem methodsFor: 'updating' stamp: ''!
isExpanded
	^ self subclassResponsibility! !

!FTTreeItem methodsFor: 'updating' stamp: ''!
updateData
	self subclassResponsibility! !

!FTTreeItem methodsFor: 'accessing' stamp: ''!
dataSource: anObject
	dataSource := anObject! !

!FTTreeItem methodsFor: 'accessing' stamp: ''!
numberOfChildren
	^ self children
		ifEmpty: [ 0 ]
		ifNotEmpty: [ :children2 | children2 size + (children2 collect: [ :item | item numberOfChildren ]) sum ]! !

!FTTreeItem methodsFor: 'accessing' stamp: ''!
numberOfVisibleChildren
	^ (self isExpanded and: [ self children isNotEmpty ])
		ifTrue: [ self children size + (self children collect: [ :item | item numberOfVisibleChildren ]) sum ]
		ifFalse: [ 0 ]! !

!FTTreeItem methodsFor: 'accessing' stamp: ''!
selfOrChildAt: anIndex
	^ anIndex = 1
		ifTrue: [ self ]
		ifFalse: [ self childAt: anIndex - 1 ]! !

!FTTreeItem methodsFor: 'accessing' stamp: ''!
childAt: anIndex
	| tmpIndex |
	tmpIndex := anIndex.
	self children
		do:
			[ :item | 
			| size |
			size := item numberOfVisibleChildren + 1.
			tmpIndex <= size
				ifTrue: [ ^ item selfOrChildAt: tmpIndex ]
				ifFalse: [ tmpIndex := tmpIndex - size ] ].
	self errorSubscriptBounds: anIndex! !

!FTTreeItem methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
hasComputedChildren
	"I return true if I have computed children or if I don't have computed children."

	^ self hasChildren! !

!FTTreeItem methodsFor: 'expanding-collapsing' stamp: ''!
collapseAll
	self subclassResponsibility! !

!FTTreeItem methodsFor: 'accessing' stamp: ''!
dataSource
	^ dataSource! !

!FTTreeItem methodsFor: 'expanding-collapsing' stamp: ''!
expandAllTo: aDepth
	self subclassResponsibility! !

!FTTreeItem methodsFor: 'accessing' stamp: ''!
recentlyChanged
	"I return true if the item was recently collapsed. I am use to update the selection when we collapse an item."

	self subclassResponsibility! !

!FTTreeItem class methodsFor: 'instance creation' stamp: ''!
data: aData from: aDataSource
	^ self new
		dataSource: aDataSource;
		data: aData;
		yourself! !

!FTUnsortedSortingState commentStamp: ''!
Description
--------------------

I am a sorting state for unsorted table.!
!FTUnsortedSortingState methodsFor: 'sorting' stamp: ''!
executeSortingOn: aDataSource
	aDataSource unsort! !

!FTUnsortedSortingState methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
isSorted 
	^ false! !

!FTUnsortedSortingState methodsFor: 'accessing' stamp: ''!
nextState
	^ FTAscendingSortingState context: self context! !

!FTUnsortedSortingState methodsFor: 'accessing' stamp: ''!
sortingIcon
	^ self context morphicIconNamed: #arrowUpAndDown! !

!FTUnsortedSortingStateTest commentStamp: ''!
A FTUnsortedSortingStateTest is a test class for testing the behavior of FTUnsortedSortingState!
!FTUnsortedSortingStateTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ FTUnsortedSortingState! !

!FTUnsortedSortingStateTest methodsFor: 'tests' stamp: ''!
testExecuteSortingOn
	| dataSource |
	dataSource := self dataSourceForTesting.
	state executeSortingOn: dataSource.
	self assert: dataSource elements equals: self elementsForTestDataSource.
	state executeSortingOn: dataSource.
	self assert: dataSource elements equals: self elementsForTestDataSource! !

!FTVector commentStamp: ''!
I represent a 2D vector of type FT_Vector. I am used to do transformations.!
!FTVector methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_Y put: anObject! !

!FTVector methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_X! !

!FTVector methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_X put: anObject! !

!FTVector methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_Y! !

!FTVector class methodsFor: 'field definition' stamp: ''!
fieldsDesc

	"self rebuildFieldAccessors"

	^ #(    
	 FT_Pos  x;
    FT_Pos  y;)! !

!FTVisibleItemsStrategy commentStamp: ''!
I am a Strategy that will use the function on the visible items of the tree.

Description
-----------------------

I will search in the vsible items of the tree.
As said in my superclass I am use by a FTTreeDataSource to help with a FTFunction.

Public API and Key Messages
-----------------------

- #realSearch 	is the method that will launch the search.

Example
-----------------------

	| ds |
	ds := FTTreeDataSource
		roots:
			((ProtoObject allSubclasses sort: [ :a :b | a asString < b asString ])
				reject: [ :e | e asString endsWith: 'class' ])
		children: [ :item | item subclasses sort: [ :a :b | a asString < b asString ] ].
	ds searchStrategy: #default. "This will say to the FTTreeDataSource to use me, but since this is the default, this is optional."
	FTTableMorph new
		extent: 200 @ 400;
		dataSource: ds;
		explicitFunction;
		openInWindow
 !
!FTVisibleItemsStrategy methodsFor: 'action' stamp: ''!
matchingFilter: anItem
	anItem isExpanded
		ifTrue:
			[ ((anItem children collect: [ :each | self matchingFilter: each ]) reject: #isNil)
				ifNotEmpty: [ :coll | 
					^ (self newStaticItemFrom: anItem)
						children: coll asArray;
						expandWithoutChange;
						yourself ] ].
	^ (pattern matchesIn: (self dataSource toString: anItem))
		ifNotEmpty: [ anItem isExpanded
				ifTrue: [ self newStaticItemFrom: anItem ]
				ifFalse: [ anItem ] ]
		ifEmpty: [ nil ]! !

!FTVisibleItemsStrategy methodsFor: 'action' stamp: ''!
filter
	| items |
	items := OrderedCollection new.
	dataSource rootsItems do: [ :item | (self matchingFilter: item) ifNotNil: [ :itemNew | items add: itemNew ] ] displayingProgress: [ :each | 'Looking inside ' , each printString ].
	dataSource table selectIndex: 1.
	^ dataSource class
		root:
			(FTRootItem new
				children: items asArray;
				yourself)
		children: dataSource childrenBlock! !

!FTVisibleItemsStrategy methodsFor: 'action' stamp: ''!
newStaticItemFrom: anItem
	^ FTStaticBasicItem new
		data: anItem data;
		depth: anItem depth;
		children: #();
		yourself! !

!FTVisibleItemsStrategy methodsFor: 'action' stamp: ''!
realSearch
	| result cpt |
	result := OrderedCollection new.
	cpt := 0.
	dataSource rootsItems
		do:
			[ :item | 
			1 to: item numberOfVisibleChildren + 1 do: [ :index | 
				| elem |
				elem := item selfOrChildAt: index.
				(self isMatching: elem)
					ifTrue: [ result add: index + cpt ] ].
			cpt := cpt + (item numberOfVisibleChildren + 1) ].
	^ result asArray! !

!FadingMorph commentStamp: ''!
FadingMorph is a morph that fades out of existence after a certain time. The implementation uses a stepping event which reduces the visibility of the morph and its submorphs until they are no longer visible, when this happens the morph will delete itself.

Variables:
<alpha> holds the current alpha value. [ Float ]
<fadingFactor> a value of how much the alpha shall be reduced per step message send. [ Float ]
<resetable> boolean value used by #handleMouseMove: to descide whether or not to reset the alpha on mouse over.

The morph has a default layout, color, and borderstyle which can be changed after instance creation the same way other morphs can.

The morph itself updates its translucency per 100ms. One can change the variable fadingFactor to reduce or increase the time a FadingMorph is present in the world.

If the mouse is moved over a FadingMorph present in the world, it will reset the alpha, which means that the fading will start from the begining again, this can be turned off by sending #beUnResetable. 
!
!FadingMorph methodsFor: 'initialization' stamp: ''!
resetAlpha

	alpha := 1.0! !

!FadingMorph methodsFor: 'properties-setting' stamp: ''!
beUnResetable

	resetable := false! !

!FadingMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	self 
	initializeAppearance;
	initializeLayout;
	beResetable;
	resetAlpha.
	
	fadingFactor := self defaultFadingFactor.! !

!FadingMorph methodsFor: 'stepping' stamp: ''!
step

	alpha <= fadingFactor ifTrue: [ ^self delete ].

	alpha := alpha - fadingFactor.
	
	self changed.! !

!FadingMorph methodsFor: 'initialization' stamp: ''!
initializeLayout

	self 
	changeTableLayout;
	layoutInset: 6;
	listDirection: #topToBottom;
	cellPositioning: #topRight;
	hResizing: #shrinkWrap;
	vResizing: #shrinkWrap;
	cellInset: 0.! !

!FadingMorph methodsFor: 'properties-setting' stamp: ''!
beResetable

	resetable := true! !

!FadingMorph methodsFor: 'initialization' stamp: ''!
defaultFadingFactor
	"show the morph for 2.5 seconds"
	
	^0.04! !

!FadingMorph methodsFor: 'drawing' stamp: ''!
fullDrawOn: aCanvas

	super fullDrawOn: (aCanvas asAlphaBlendingCanvas: alpha)! !

!FadingMorph methodsFor: 'events-processing' stamp: ''!
handleMouseMove: anEvent

	(anEvent wasHandled or: [ resetable not ]) ifTrue:[ ^self ]. 
	
	self resetAlpha.

	anEvent wasHandled: true.! !

!FadingMorph methodsFor: 'drawing' stamp: ''!
areasRemainingToFill: aRectangle 
	
	"the whole rectangle is translucent"
	
	^Array with: aRectangle! !

!FadingMorph methodsFor: 'events-processing' stamp: ''!
rejectsEvent: anEvent

	^(anEvent isMouse and: [ anEvent isMouseDown ]) or: [ super rejectsEvent: anEvent ]! !

!FadingMorph methodsFor: 'stepping' stamp: ''!
wantsSteps
	^true! !

!FadingMorph methodsFor: 'initialization' stamp: ''!
initializeAppearance

	self 
	color: Color gray;
	borderStyle: (BorderStyle inset width: 3)! !

!FadingMorph methodsFor: 'stepping' stamp: ''!
stepTime

	^100! !

!FailingTestResourceTestCase commentStamp: ''!
SUnit tests for failing test resources!
!FailingTestResourceTestCase methodsFor: 'utilities' stamp: ''!
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]]! !

!FallbackMenu commentStamp: ''!
I appear when there is an error while trying to build a menu from pragmas.

I include items to:
* Debug: give the user an opportunity to see and correct the error
* Explain: why they're seeing a different menu
* Custom: clients can add items to me by implementing #fallbackMenuOn:. Browse implementors for examples.!
!FallbackMenu methodsFor: 'private' stamp: ''!
builder: aPragmaMenuBuilder

	builder := aPragmaMenuBuilder.! !

!FallbackMenu methodsFor: 'private' stamp: ''!
menu
	"Build the menu that is put up if something is going wrong with the menubuilder"

	| menu |
	menu := UIManager default newMenuIn: self currentWorld for: self.
	menu buildTitle: [ :menuTitle | menuTitle
		onlyCloseAndPinable
	].
	menu add: 'Why you see this menu'
		target: self
		selector: #fallbackMenuExplanations.
	menu add: 'Debug'
		target: self
		selector: #debug.
	menu addLine.
	client fallbackMenuOn: menu.
	^ menu! !

!FallbackMenu methodsFor: 'menu actions' stamp: ''!
debug

	"If we don't reset the builder after debugging, the fallback menu does not appear anymore"
	[ builder menuSpec asMenuMorph ] ensure: [ builder reset ].! !

!FallbackMenu methodsFor: 'private' stamp: ''!
client: anObject

	client := anObject.! !

!FallbackMenu methodsFor: 'private' stamp: ''!
fallbackMenuExplanations

	| workspace wsBindings |
	wsBindings := Dictionary newFrom: { #menu-> self }.
	workspace := Smalltalk tools workspace
		openContents: '"Something is wrong with this menu. 
To investigate just debug following expression:"
menu debug'.
	workspace
		label: 'Fallback menu explanations';
		setBindings: wsBindings.! !

!FallbackMenu class methodsFor: 'instance creation' stamp: ''!
when: aPragmaMenuBuilder fails: anObject
	
	^ self new
			builder: aPragmaMenuBuilder;
			client: anObject;
			menu.! !

!False commentStamp: ''!
False defines the behavior of its single instance, false -- logical negation. Notice how the truth-value checks become direct message sends, without the need for explicit testing.

Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.!
!False methodsFor: 'logical operations' stamp: ''!
& aBoolean 
	"Evaluating conjunction -- answer false since receiver is false."

	^self! !

!False methodsFor: 'controlling' stamp: ''!
and: alternativeBlock 
	"Nonevaluating conjunction -- answer with false since the receiver is false."
	"(false and: [ 1 error ])>>> false"
	
	^self! !

!False methodsFor: 'logical operations' stamp: ''!
| aBoolean 
	"Evaluating disjunction (OR) -- answer with the argument, aBoolean."

	^aBoolean! !

!False methodsFor: 'printing' stamp: ''!
printOn: aStream 

	aStream nextPutAll: 'false'! !

!False methodsFor: 'controlling' stamp: ''!
ifTrue: alternativeBlock 
	"Since the condition is false, answer the value of the false alternative, 
	which is nil. Execution does not actually reach here because the
	expression is compiled in-line."

	^nil! !

!False methodsFor: 'logical operations' stamp: ''!
xor: alternativeBlock
	"Nonevaluating conjunction. If the receiver is true, answer the opposite of the 
	the argument, alternativeBlock; otherwise answer the value of the alternativeBlock."
	"(false xor: [ true ]) >>> true"
	
	^ alternativeBlock value! !

!False methodsFor: 'controlling' stamp: ''!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock 
	"Answer the value of falseAlternativeBlock. Execution does not
	actually reach here because the expression is compiled in-line."

	^falseAlternativeBlock value! !

!False methodsFor: 'logical operations' stamp: ''!
not
	"Negation -- answer true since the receiver is false."

	^true! !

!False methodsFor: 'converting' stamp: ''!
asBit

	^ 0! !

!False methodsFor: 'controlling' stamp: ''!
or: alternativeBlock 
	"Nonevaluating disjunction -- answer value of alternativeBlock."
	" (false or: [ true ] )>>> true "
	
	^alternativeBlock value! !

!False methodsFor: '*UnifiedFFI' stamp: ''!
asInteger
	
	^ 0! !

!False methodsFor: 'controlling' stamp: ''!
ifFalse: alternativeBlock 
	"Answer the value of alternativeBlock. Execution does not actually
	reach here because the expression is compiled in-line."

	^alternativeBlock value! !

!False methodsFor: 'controlling' stamp: ''!
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 class methodsFor: '*Fuel-Core' stamp: ''!
materializeFrom: aDecoder
	"Answer my unique instance"

	^ false! !

!FalseTest commentStamp: ''!
SUnit tests for false/False class!
!FalseTest methodsFor: 'tests - logical operations' stamp: ''!
testXor
	self assert: (false xor: true) equals: true.
	self assert: (false xor: false) equals: false.
	self assert: (false xor: [ true ]) equals: true.
	self assert: (false xor: [ false ]) equals: false! !

!FalseTest methodsFor: 'tests - controlling' stamp: ''!
testAnd

	self deny: (false and: ['alternativeBlock']).! !

!FalseTest methodsFor: 'tests - converting' stamp: ''!
testAsBit

	self assert: false asBit equals: 0! !

!FalseTest methodsFor: 'tests - logical operations' stamp: ''!
testAND

	self deny: (false & true).
	self deny: (false & false).! !

!FalseTest methodsFor: 'tests - controlling' stamp: ''!
testOr
	self assert: (false or: [ 'alternativeBlock' ]) equals: 'alternativeBlock'! !

!FalseTest methodsFor: 'tests - controlling' stamp: ''!
testIfFalseIfTrue
	self assert: (false ifFalse: [ 'falseAlternativeBlock' ] ifTrue: [ 'trueAlternativeBlock' ]) equals: 'falseAlternativeBlock'! !

!FalseTest methodsFor: 'tests - logical operations' stamp: ''!
testNot

	self assert: (false not).! !

!FalseTest methodsFor: 'tests - logical operations' stamp: ''!
testOR

	self assert: (false | true).
	self deny: (false | false).! !

!FalseTest methodsFor: 'tests - controlling' stamp: ''!
testIfFalse
	self assert: (false ifFalse: [ 'alternativeBlock' ]) equals: 'alternativeBlock'! !

!FalseTest methodsFor: 'tests - controlling' stamp: ''!
testIfTrueIfFalse
	self assert: (false ifTrue: [ 'trueAlternativeBlock' ] ifFalse: [ 'falseAlternativeBlock' ]) equals: 'falseAlternativeBlock'! !

!FalseTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ False! !

!FalseTest methodsFor: 'tests - instance creation' stamp: ''!
testNew

	self should: [False new] raise: self defaultTestError! !

!FalseTest methodsFor: 'tests - controlling' stamp: ''!
testIfTrue
	self
		assert:
			(false
				ifTrue: [ 'alternativeBlock' ]) isNil! !

!FalseTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn
	self assert: (String streamContents: [ :stream | false printOn: stream ]) equals: 'false'! !

!FastDraggingFrameMorph commentStamp: ''!
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:		<Symbol>
	startGap:		<Point>
	target:		<SystemWindow>

location
	- The symbol representing the corner or the edge (#topLeft, #top, #topRight .... or #left). I'm set to nil for window dragging

startGap
	- For window dragging, keep track of the distance between the window top bar first click location and the window position

target
	- The window to be resized or dragged
!
!FastDraggingFrameMorph methodsFor: 'testing' stamp: ''!
isForDragging
	^ location isNil! !

!FastDraggingFrameMorph methodsFor: 'accessing' stamp: ''!
wantsToBeTopmost
	"Answer if the receiver want to be one of the topmost objects in 
	its owner"
	^ true! !

!FastDraggingFrameMorph methodsFor: 'event handling' stamp: ''!
reframedTo: aPoint 
	self
		bounds: (self bounds withSideOrCorner: location setToPoint: aPoint)! !

!FastDraggingFrameMorph methodsFor: 'accessing' stamp: ''!
location: aSymbol
	"The symbol wich represents the corner or the edge grip location (#topLeft, #top ..., #bottomLeft or #left)"
	location := aSymbol! !

!FastDraggingFrameMorph methodsFor: 'event handling' stamp: ''!
draggedTo: aPoint
	self position: aPoint + startGap! !

!FastDraggingFrameMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	^ 2.! !

!FastDraggingFrameMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	"Normally, should not be possible"
	self delete! !

!FastDraggingFrameMorph methodsFor: 'accessing' stamp: ''!
startGap: aPoint
	"APoint is the distance between the window position and the first click position" 
	startGap := aPoint! !

!FastDraggingFrameMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor 
	^ Color gray! !

!FastDraggingFrameMorph methodsFor: 'event handling' stamp: ''!
mouseUp: evt 
	target
		ifNotNil: [Display
				deferUpdatesIn: Display boundingBox
				while: [target bounds: self bounds]].
	self delete! !

!FastDraggingFrameMorph methodsFor: 'initialization' stamp: ''!
defaultColor 
	^ Color gray alpha: 0.15.! !

!FastDraggingFrameMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^ true! !

!FastDraggingFrameMorph methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!FastDraggingFrameMorph methodsFor: 'event handling' stamp: ''!
mouseMove: evt
	self isForDragging 
		ifTrue: [self draggedTo: evt position]
		ifFalse: [self reframedTo: evt position]! !

!FastDraggingFrameMorph methodsFor: 'accessing' stamp: ''!
target: aSystemWindow 
	target := aSystemWindow.
	self color: (target paneColor alpha: 0.35).
	self bounds: aSystemWindow bounds.
	self currentHand newMouseFocus: self! !

!FastDraggingFrameMorph class methodsFor: 'instance creation' stamp: ''!
forResizing: aWindow fromLocation: aSideOrCorner
	| b  |
	b := self new.	
	b target: aWindow.
	b location: aSideOrCorner.
	^ b! !

!FastDraggingFrameMorph class methodsFor: 'instance creation' stamp: ''!
forDragging: aWindow clickedAt: aPoint
	| b |
	b := self new.
	b target: aWindow.
	b startGap: aWindow topLeft - aPoint.
	^ b! !

!FastInflateStream commentStamp: ''!
This class adds the following optimizations to the basic Inflate decompression:

a) Bit reversed access
If we want to fetch the bits efficiently then we have them in the wrong bit order (e.g., when we should fetch 2r100 we would get 2r001). But since the huffman tree lookup determines the efficiency of the decompression, reversing the bits before traversal is expensive. Therefore the entries in each table are stored in REVERSE BIT ORDER. This is achieved by a reverse increment of the current table index in the huffman table construction phase (see method increment:bits:). According to my measures this speeds up the implementation by about 30-40%.

b) Inplace storage of code meanings and extra bits
Rather than looking up the meaning for each code during decompression of blocks we store the appropriate values directly in the huffman tables, using a pre-defined mapping. Even though this does not make a big difference in speed, it cleans up the code and allows easier translation into primitive code (which is clearly one goal of this implementation).

c) Precomputed huffman tables for fixed blocks
So we don't have to compute the huffman tables from scratch. The precomputed tables are not in our superclass to avoid double storage (and my superclass is more intended for documentation anyways).!
!FastInflateStream methodsFor: 'inflating' stamp: 'nil'!
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 |
	<primitive: 'primitiveInflateDecompressBlock' module: 'ZipPlugin'>
	[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
					with: collection 
					startingAt: readLimit - distance + 1.
			readLimit := readLimit + length.
		].
	].! !

!FastInflateStream methodsFor: 'huffman trees' stamp: 'nil'!
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: 'nil'!
distanceMap
	^DistanceMap! !

!FastInflateStream methodsFor: 'inflating' stamp: 'nil'!
processFixedBlock
	litTable := FixedLitTable.
	distTable := FixedDistTable.
	state := state bitOr: BlockProceedBit.
	self proceedFixedBlock.! !

!FastInflateStream methodsFor: 'bit access' stamp: 'nil'!
nextSingleBits: n
	"Fetch the bits all at once"
	^self nextBits: n.! !

!FastInflateStream methodsFor: 'huffman trees' stamp: 'nil'!
literalLengthMap
	^LiteralLengthMap! !

!FastInflateStream class methodsFor: 'initialization' stamp: 'nil'!
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.! !

!FastTablePresenter commentStamp: ''!
An FastTablePresenter is a spec presenter for a FastTable!
!FastTablePresenter methodsFor: 'api' stamp: ''!
handlesDoubleClick: aBoolean
	"<api: #block getter:#handlesDoubleClick registration: #whenHandlesDoubleClickChanged:>"
	"Enable or disable double click on the list."
	
	handlesDoubleClick value: aBoolean! !

!FastTablePresenter methodsFor: 'api' stamp: ''!
doubleClick: event

	doubleClick value cull: event! !

!FastTablePresenter methodsFor: 'api' stamp: ''!
icons
	"<api: #inspect>"
	"Return the block which takes an item as argument and returns the icon to display in the list"
	
	^ iconHolder value! !

!FastTablePresenter methodsFor: 'api' stamp: ''!
icons: aBlock
	"<api: #block getter: #icon registration: #whenIconsChanged: >"
	"Set a block which takes an item as argument and returns the icon to display in the list"
	iconHolder value: aBlock! !

!FastTablePresenter methodsFor: 'accessing' stamp: ''!
columns
	^ columns! !

!FastTablePresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	columns := {SpecFTColumn new}! !

!FastTablePresenter methodsFor: 'accessing' stamp: ''!
numberOfColumns: aNumber
	columns := ((1 to: aNumber) collect: [ :index | FTArrayIndexColumn index: index ] )! !

!FastTablePresenter methodsFor: 'initialization' stamp: ''!
initializeValueHolders

	super initializeValueHolders.

	iconHolder := [:item | nil ] asValueHolder.
	handlesDoubleClick := false asValueHolder.
	doubleClick := [  ] asValueHolder.
! !

!FastTablePresenter methodsFor: 'api' stamp: ''!
getIconFor: anItem

	^ iconHolder value cull: anItem cull: self! !

!FastTablePresenter methodsFor: 'accessing' stamp: ''!
numberOfColumns: aNumber withWidths: widths
	columns := ((1 to: aNumber) collect: [ :index | 
		FTArrayIndexColumn index: index width: (widths at: index) ] )! !

!FastTablePresenter methodsFor: 'api' stamp: ''!
handlesDoubleClick

	^ handlesDoubleClick value! !

!FastTablePresenter methodsFor: 'initialization' stamp: ''!
registerEvents
	super registerEvents.
	handlesDoubleClick whenChangedDo: [ :bool | self changed: { #handlesDoubleClick . bool } ].
! !

!FastTablePresenter methodsFor: 'api' stamp: ''!
doubleClickAction
	"<api: #inspect>"
	"Return the block evaluated on double click"
	
	^ doubleClick value! !

!FastTablePresenter methodsFor: 'private' stamp: ''!
prepareForFilteredDataSourceWith: items

	listHolder := items asValueHolder.
	listHolder whenChangedDo: [ self refreshListItems ].
	listItemsCache := nil! !

!FastTablePresenter methodsFor: 'api - events' stamp: ''!
whenIconsChanged: aBlock 
	
	iconHolder whenChangedDo: aBlock 

! !

!FastTablePresenter methodsFor: 'api' stamp: ''!
doubleClickAction: aBlock
	"<api: #block getter:#doubleClickAction registration: #whenDoubleClickActionChanged:>"
	"Set the block evaluated on double click."
	
	doubleClick value: aBlock! !

!FastTablePresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self new.
	example
		icons: [ :e | example iconNamed: #forwardIcon ];
		items: (1 to: 10) asArray;
		openWithSpec.
	^ example! !

!FastTablePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(FastTableAdapter
		adapt: #(model))! !

!FastTablePresenter class methodsFor: 'examples' stamp: ''!
exampleMultipleSelection
	<sampleInstance>
	| example |
	example := self new.
	example
		items: (1 to: 10);
		beMultipleSelection;
		whenSelectionChanged: [ :selection | selection traceCr ];
		openWithSpec.
	^ example! !

!FastTablePresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #FastTableAdapter! !

!File commentStamp: ''!
I represent a sequential binary File and provide primitives for various file operations.
I am also the entry point of the FilePlugin primitives.

### Examples of usage:

```
"Creating a file"
file := File named: 'asd.txt' asFileReference fullName.

"Opening / closing it"
file open.
file openForAppend.
file close.

"Accessing the file properties"
file size.
file position.
file position: 0.
file seekAbsolute: 10.
file seekRelative: 10.
file atEnd.

"Writing"
file nextPutAll: 'sdd'.

"Reading"
file next: 2.

"Buffered write"
file next: 2 putAll: 'abc' startingAt: 2.

"Buffered read"
buffer := ByteArray new: 5.
file readInto: buffer startingAt: 1 count: 5.
buffer asString.
```

# How to Migrate from FileStream

The following migration instructions were moved here from the `FileStream` class comment in Pharo 8.

Since the version 5, Pharo provides a new file streams API that makes the old one based on classes like FileStream or MultiByteBinaryOrTextStream deprecated. 
Pharo 7 makes the next important steps and removes usages of the old API from the kernel.

What you should remember:

- use file references as entry points to file streams 
- DO NOT USE FileStream class
- 'file.txt' asFileReference readStream and similar methods now return an instance of ZnCharacterReadStream instead of MultiByteFileStream
- 'file.txt' asFileReference writeStream and similar methods now return an instance of ZnCharacterWriteStream instead of MultiByteFileStream
- the new API has a clearer separation between binary and text files

## 1. Basic Files
By default files are binary. Not buffered.

Read UTF-8 text from an existing file

**Obsolete code:**

```
FileStream readOnlyFileNamed: '1.txt' do: [ :stream | 
    stream upToEnd ].
```

**New code:**

```
(File named: 'name') readStream.
(File named: 'name') readStreamDo: [ :stream | … ].
'1.txt' asFileReference readStreamDo: [ :stream | 
    stream upToEnd ].
```

## 2. Encoding
To add encoding, wrap a stream with a corresponding ZnCharacterRead/WriteStream.

**Reading:**

```
utf8Encoded := ZnCharacterReadStream on: aBinaryStream encoding: 'utf8'.
utf16Encoded := ZnCharacterReadStream on: aBinaryStream encoding: 'utf16'.
```

**Writing:**

```
utf8Encoded := ZnCharacterWriteStream on: aBinaryStream encoding: 'utf8'.
utf16Encoded := ZnCharacterWriteStream on: aBinaryStream encoding: 'utf16'.
```

Force creation of a new file and write a UTF-8 text

**Obsolete code:**

```
FileStream forceNewFileNamed: '1.txt' do: [ :stream | stream nextPutAll: 'a ≠ b' ].
```

**New code:**

```
(File named: 'name') writeStream.
(File named: 'name') writeStreamDo: [ :stream | ... ].
'1.txt' asFileReference ensureDelete; 
    writeStreamDo: [ :stream | stream nextPutAll: 'a ≠ b' ].
```

Get all content of existing UTF-8 file

**Obsolete code:**

```
(FileStream readOnlyFileNamed: '1.txt') contentsOfEntireFile.
```

**New code:**

```
'1.txt' asFileReference readStream upToEnd.
```

## 3. Buffering
To add buffering, wrap a stream with a corresponding ZnBufferedRead/WriteStream.

```
bufferedReadStream := ZnBufferedReadStream on: aStream.
bufferedWriteStream := ZnBufferedWriteStream on: aStream.
```

It is in general better to buffer the reading on the binary file and apply the encoding on the buffer in memory than the other way around. See

```
[file := Smalltalk sourcesFile fullName.
(File named: file) readStreamDo: [ :binaryFile |
(ZnCharacterReadStream on: (ZnBufferedReadStream on: binaryFile) encoding: 'utf8') upToEnd
]] timeToRun. "0:00:00:09.288"
```

```
[file := Smalltalk sourcesFile fullName.
(File named: file) readStreamDo: [ :binaryFile |
(ZnBufferedReadStream on: (ZnCharacterReadStream on: binaryFile encoding: 'utf8')) upToEnd
]] timeToRun. "0:00:00:14.189"
```

The MultiByteFileStream was buffered. If you create a stream using the expression

```
'file.txt' asFileReference readStream.
```

then the ZnCharacterReadStream is not created directly on top of the stream but on top of a buffered stream that uses the file stream internally.

If you create a ZnCharacterReadStream directly on the file stream, then the characters from the file are read one by one which may be about ten times slower!!

```
ZnCharacterReadStream on: (File openForReadFileNamed: 'file.txt').
```

## 4. File System
By default, file system files are buffered and utf8 encoded to keep backwards compatibility.

```
'name' asFileReference readStreamDo: [ :bufferedUtf8Stream | ... ].
'name' asFileReference writeStreamDo: [ :bufferedUtf8Stream | ... ].
```

FileStream also provides access to plain binary files using the #binaryRead/WriteStream messages. Binary streams are buffered by default too.

```
'name' asFileReference binaryReadStreamDo: [ :bufferedBinaryStream | ... ].
'name' asFileReference binaryWriteStreamDo: [ :bufferedBinaryStream | ... ].
```

If you want a file with another encoding (to come in the [PR #1134](https://github.com/pharo-project/pharo/pull/1134)), you can specify it while obtaining the stream:

```
'name' asFileReference
    readStreamEncoded: 'utf16'
    do: [ :bufferedUtf16Stream | ... ].
'name' asFileReference
    writeStreamEncoded: 'utf8'
    do: [ :bufferedUtf16Stream | ... ].
```

Force creation of a new file and write binary data into it

**Obsolete code:**

```
(FileStream forceNewFileNamed: '1.bin') 
    binary;
    nextPutAll: #[1 2 3].
```

**New code:**

```
'1.bin' asFileReference ensureDelete; 
    binaryWriteStreamDo: [ :stream | stream nextPutAll: #[1 2 3] ].
```

Read binary data from an existing file

**Obsolete code:**

```
(FileStream readOnlyFileNamed: '1.bin') binary; contentsOfEntireFile.
```

**New code:**

```
'1.bin' asFileReference binaryReadStream upToEnd.
```

Force creation of a new file with a different encoding

**Obsolete code:**

```
FileStream forceNewFileNamed: '2.txt' do: [ :stream | 
    stream converter: (TextConverter newForEncoding: 'cp-1250').
    stream nextPutAll: 'Příliš žluťoučký kůň úpěl ďábelské ódy.' ].
```

**New code:**

```
('2.txt' asFileReference) ensureDelete;
    writeStreamEncoded: 'cp-1250' do: [ :stream |
        stream nextPutAll: 'Příliš žluťoučký kůň úpěl ďábelské ódy.' ].
```

Read encoded text from an existing file

**Obsolete code:**

```
FileStream readOnlyFileNamed: '2.txt' do: [ :stream | 
    stream converter: (TextConverter newForEncoding: 'cp-1250').
    stream upToEnd ].
```

**New code:**

```
('2.txt' asFileReference)
    readStreamEncoded: 'cp-1250' do: [ :stream |
        stream upToEnd ].
```

Write a UTF-8 text to STDOUT

**Obsolete code:**

```
FileStream stdout nextPutAll: 'a ≠ b'; lf.
```

**New code:**

```
(ZnCharacterWriteStream on: Stdio stdout)
    nextPutAll: 'a ≠ b'; lf;
    flush.
```

Write CP-1250 encoded text to STDOUT

**Obsolete code:**

```
FileStream stdout 
    converter: (TextConverter newForEncoding: 'cp-1250');
    nextPutAll: 'Příliš žluťoučký kůň úpěl ďábelské ódy.'; lf.
```

**New code:**

```
(ZnCharacterWriteStream on: Stdio stdout encoding: 'cp1250')
    nextPutAll: 'Příliš žluťoučký kůň úpěl ďábelské ódy.'; lf;
    flush.
```

Read a UTF-8 text from STDIN
**CAUTION:** Following code will stop your VM until an input on STDIN will be provided!!

**Obsolete code:**

```
FileStream stdin upTo: Character lf.
```

**New code:**

```
(ZnCharacterReadStream on: Stdio stdin) upTo: Character lf.
```

Write binary data to STDOUT

**Obsolete code:**

```
FileStream stdout 
    binary
    nextPutAll: #[80 104 97 114 111 10 ].
```

**New code:**

```
Stdio stdout 
    nextPutAll: #[80 104 97 114 111 10 ].
```

Read binary data from STDIN
**CAUTION:** Following code will stop your VM until an input on STDIN will be provided!!

**Obsolete code:**

```
FileStream stdin binary upTo: 10.
```

**New code:**

```
Stdio stdin upTo: 10.
```

### Positionable streams
The message #position: always works on the binary level, not on the character level.

```
'1.txt' asFileReference readStreamDo: [ :stream | 
    stream position: 4.
    stream upToEnd ].
```

This will lead to an error _(ZnInvalidUTF8: Illegal leading byte for UTF-8 encoding)_ in case of the file created above because we set the position into the middle of a UTF-8 encoded character. To be safe, you need to read the file from the beginning.

```
'1.txt' asFileReference readStreamDo: [ :stream |
    3 timesRepeat: [ stream next ].
    stream upToEnd.].
```

## 5. Line Ending Conventions

If you want to write files following a specific line ending convention, use the ZnNewLineWriterStream.
This stream decorator will transform any line ending (cr, lf, crlf) into a defined line ending.
By default, it chooses the platform line ending convention.

```
lineWriter := ZnNewLineWriterStream on: aStream.
```

If you want to choose another line ending convention you can do:

```
lineWriter forCr.
lineWriter forLf.
lineWriter forCrLf.
lineWriter forPlatformLineEnding.
```!
!File methodsFor: 'private' stamp: 'nil'!
checkWritableFilesystem

	"We need to check if the image is in the read-only mode"

	SessionManager default currentSession isReadOnlyAccessMode ifTrue: [ 
		ReadOnlyFileException signal: 'Attempt to open file ', name, ' as writable on a read-only file system'].! !

!File methodsFor: 'open/close' stamp: 'nil'!
delete
	"Delete the receiver"

	^self class deleteFile: name.! !

!File methodsFor: 'testing' stamp: 'nil'!
exists

	| handle |
	"We open it for read. If the returned handle is nil, the file could not be opened"
	handle := self basicOpenForWrite: false.
	handle ifNil: [^ false].
	self class close: handle.
	^ true! !

!File methodsFor: 'open/close' stamp: 'nil'!
openForAppend

	| stream |
	stream := self openForWrite: true.
	^ stream setToEnd; yourself! !

!File methodsFor: 'open/close' stamp: 'nil'!
openForRead

	^ self openForWrite: false! !

!File methodsFor: 'streaming' stamp: 'nil'!
writeStream

	^ self openForWrite! !

!File methodsFor: 'open/close' stamp: 'nil'!
basicOpenForWrite: writeMode 
	"Open the file with the given name. If writeMode is true, allow writing, otherwise open the file in read-only mode."
	
	writeMode ifTrue: [ self checkWritableFilesystem ].

	^ self class
		retryWithGC: [ self class open: name utf8Encoded writable: writeMode ]
		until:[ :id | id notNil ] 
		forFileNamed: name! !

!File methodsFor: 'accessing' stamp: 'nil'!
basename
	^self name! !

!File methodsFor: 'testing' stamp: 'nil'!
checkDoesNotExist
	"This method implements a backwards compatible logic to #newFileNamed:
	
	If the file does not exist, this method has no effect, and returns self.
	
	If the file exists, it will throw a FileAlreadyExistsException.
	If unhandled, this will open a pop-up asking the user to enter a new name or to override the existing file.
	In this case, this method returns a new file with the options selected by the user.
	"
	self exists ifTrue: [
		^ FileAlreadyExistsException signalOnFile: self ]! !

!File methodsFor: 'accessing' stamp: 'nil'!
size

	^ self readStreamDo: [ :stream | stream size ]! !

!File methodsFor: 'instance creation' stamp: 'nil'!
named: fileName

	name := fileName! !

!File methodsFor: 'instance creation' stamp: 'nil'!
name

	^ name! !

!File methodsFor: 'registry' stamp: 'nil'!
unregister
	^self class unregister: self! !

!File methodsFor: 'open/close' stamp: 'nil'!
openForWrite: writeMode
	"Open the file with the given name. If writeMode is true, allow writing, otherwise open the file in read-only mode."

	| fileHandle |
	fileHandle := self basicOpenForWrite: writeMode.
	fileHandle ifNil: [
		"Opening the file failed.
		If the file does not exist, we throw an explicit FileDoesNotExistException.
		Otherwise, we throw a generic FileException."
		self exists
			ifFalse: [ ^ FileDoesNotExistException signalWithFile: self writeMode: writeMode ].
		CannotDeleteFileException signal: name
	].

	^ (BinaryFileStream handle: fileHandle file: self forWrite: writeMode)
		register;
		yourself! !

!File methodsFor: 'open/close' stamp: 'nil'!
openForWrite

	^ self openForWrite: true! !

!File methodsFor: 'streaming' stamp: 'nil'!
writeStreamDo: aBlock
	| stream |
	stream := self writeStream.
	^ [ aBlock value: stream ]
		ensure: [ stream close ]! !

!File methodsFor: 'streaming' stamp: 'nil'!
readStream
	
	^ self openForRead! !

!File methodsFor: 'streaming' stamp: 'nil'!
readStreamDo: aBlock
	| stream |
	stream := self readStream.
	^ [ aBlock value: stream ]
		ensure: [ stream close ]! !

!File class methodsFor: 'primitives - directory' stamp: 'nil'!
primClosedir: directoryPointerBytes
	"Close the directory stream associated with directoryPointerBytes.
	Caution: do not call this twice on the same externalAddress."

	"self primClosedir: (self primOpendir: '/etc')"
	"self primClosedir: (self primOpendir: '/no/such/directory')"

	<primitive: 'primitiveClosedir' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: 'primClosedir'! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
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."

	<primitive: 'primitiveFileWrite' module: 'FilePlugin'>
	self primitiveFailed! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
connectToFile: filePointer writable: writableFlag
	"Open the file with the supplied FILE* pointer, and return the file ID obtained.
	writeableFlag indicates whether to allow write operations and must be compatible with the way the file was opened.
	It is the responsibility of the caller to coordinate closing the file."

	<primitive: 'primitiveConnectToFile' module: 'FilePlugin' error: error>
	error = #'bad argument' ifTrue: [ 
		(filePointer isKindOf: ByteArray) ifFalse: 
			[ ^self error: 'filePointer must be a ByteArray' ].
		(writableFlag isKindOf: Boolean) ifFalse: 
			[ ^self error: 'writableFlag must be a boolean' ] ].
	^ self primitiveFailed! !

!File class methodsFor: 'primitives - path' stamp: 'nil'!
delimiter
	"Return the path delimiter for the underlying platform's file system."

 	<primitive: 'primitiveDirectoryDelimitor' module: 'FilePlugin'>
	self primitiveFailed! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
stdioIsAvailable
	"Answer a boolean indicating whether stdio is available on the current platform.
	stdio is considered available if any one of the three files (stdin, stdout, stderr) is available."

	^ (0 to: 2)
		anySatisfy: [ :fdNum | | res |
			res := self fileDescriptorType: fdNum.
			res between: 1 and: 3 ]! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
getAttributesFailed

	^-4! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
invalidArguments

	^-6! !

!File class methodsFor: 'file creation' stamp: 'nil'!
openForWriteFileNamed: aName

	^ (self named: aName) openForWrite! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
s_IFBLK
	^ S_IFBLK! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isFile: aPathString
	"Answer a boolean indicating whether the supplied path is a file, i.e. not a directory"

	^[ (self modeIsDirectory: (self modeOf: aPathString)) not ]
		on: FileDoesNotExistException
		do: [ false ].! !

!File class methodsFor: 'attributes' stamp: 'nil'!
fromPlatformPath: aByteArray
	"Convert the supplied platform encoded string to the native (UTF8) equivalent"

	^self primFromPlatformPath: aByteArray! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
modeIsRegular: aMode
	"Answer a boolean indicating whether the supplied mode has the Regular type bit set"

	^(aMode bitAnd: S_IFMT) = S_IFREG! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
s_IFSOCK
	^ S_IFSOCK! !

!File class methodsFor: 'testing' stamp: 'nil'!
exists: aString

	^self primExists: (self encodePathString: aString)! !

!File class methodsFor: 'registry' stamp: 'nil'!
register: anObject
	^self registry add: anObject! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
posixPermissions: aPath
	"Answer the posix permissions for the supplied path"

	^(self modeOf: aPath) bitAnd: 8r777! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
timeConversionFailed

	^-5! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
modeOf: aPathString
	"Answer the statBuf.st_mode for the supplied path"
	
	^self fileAttribute: aPathString number: 2! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isSymlink: aPath
	"Answer a boolean indicating whether the supplied path is a Symlink file"

	^self fileAttribute: aPath number: 16! !

!File class methodsFor: 'primitives - path' stamp: 'nil'!
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."

	<primitive: 'primitiveFileRename' module: 'FilePlugin'>
	^nil! !

!File class methodsFor: 'primitives - directory' stamp: 'nil'!
primReaddir: directoryPointerBytes
	"Read the next directory entry from the directory stream associated with
	directoryPointerBytes. Answer the name of the entry, ornil for end of directory stream."

	"self primReaddir: (self primOpendir: '/etc')"
	"self primReaddir: (self primOpendir: '/no/such/directory')"

	<primitive: 'primitiveReaddir' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: 'primReaddir:'! !

!File class methodsFor: 'attributes' stamp: 'nil'!
fileAttributeNumberMap
	"Answer a mapping of attribute number to name for #primFileAttribute:number:"
	
	^#(
		#targetName
		#mode
		#inode
		#deviceId
		#numberOfHardLinks
		#uid
		#gid
		#size
		#accessUnixTime
		#modificationUnixTime
		#changeUnixTime
		#creationUnixTime
		#isReadable
		#isWritable
		#isExecutable
		#isSymlink
		)! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isCharacter: aPath
	"Answer a boolean indicating whether the supplied path is a Character file"

	^self modeIsCharacter: (self modeOf: aPath)! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isExecutable: aPath
	"Answer a boolean indicating whether the supplied path is a executable file"

	^self fileAttribute: aPath number: 15! !

!File class methodsFor: 'registry' stamp: 'nil'!
registry
	^Registry ifNil: [Registry := WeakRegistry new]! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
s_IFLNK
	^ S_IFLNK! !

!File class methodsFor: 'file creation' stamp: 'nil'!
openForReadFileNamed: aName

	^ (self named: aName)
		openForRead! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
fileDescriptorIsAvailable: anInteger
	"Answer a boolean indicating whether the supplied file descriptor (anInteger) is available.
	A file descriptor is considered available if it is connected to a console / terminal, pipe or a file.  cygwin terminals are currently not supported (the pipe is created, but nothing appears in the terminal)"

	^ (self fileDescriptorType: anInteger) between: 1 and: 3! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
fileDescriptorType: fdNum
	"Allow to test if the standard input/output files are from a console or not
	Return values:
	* -1 - Error
	* 0 - no console (windows only)
	* 1 - normal terminal (unix terminal / windows console)
	* 2 - pipe
	* 3 - file
	* 4 - cygwin terminal (windows only)"

	<primitive: 'primitiveFileDescriptorType' module: 'FilePlugin' error: error>
	error = #'bad argument'
		ifTrue: [ fdNum isInteger
				ifFalse: [ ^ self error: 'File Descriptor must be an integer!!' ] ].
	^ self primitiveFailed! !

!File class methodsFor: 'primitives - file attributes' stamp: 'nil'!
primFileAttributes: aByteArray mask: attributeMask
	"Answer an array of attributes for the supplied file.  The size and contents of the array are determined by the attributeMask:

Bit 0: stat() information
Bit 1: access() information
Bit 2: use lstat() (instead of stat())

On error, answer an error code (Integer).

stat() information:
	
	1: name
	2: mode
	3: ino
	4: dev
	5: nlink
	6: uid
	7: gid
	8: size
	9: accessDate
	10: modifiedDate
	11: creationDate
	12: Windows File Attributes mask (https://docs.microsoft.com/en-us/windows/win32/fileio/file-attribute-constants)

access() information

	1: is readable
	2: is writeable
	3: is executable
	"
	<primitive: 'primitiveFileAttributes' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: aByteArray! !

!File class methodsFor: 'attributes' stamp: 'nil'!
fileAttribute: aString number: attributeNumber
	"Answer the attribute identified by attributeNumber for the specified file (aString).
	For backward compatibility (on Unix) with FileReference if the file doesn't exist, and the specified path is a (broken) symbolic link, answer the requested attribute for the symbolic link."

	^self primFileAttribute: (self encodePathString: aString) number: attributeNumber! !

!File class methodsFor: 'primitives - file attributes' stamp: 'nil'!
primFile: pathByteArray symlinkUid: uidInteger gid: gidInteger
	"Set the owner and group of path by numeric id."

	<primitive: 'primitiveSymlinkChangeOwner' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: pathByteArray! !

!File class methodsFor: 'class initialization' stamp: 'nil'!
reset
	"Initialize the receiver for the current platform"

	| masks |
	masks := self primFileMasks.
	S_IFMT := masks at: 1.
	S_IFSOCK := masks at: 2.
	S_IFLNK := masks at: 3.
	S_IFREG := masks at: 4.
	S_IFBLK := masks at: 5.
	S_IFDIR := masks at: 6.
	S_IFCHR := masks at: 7.
	S_IFIFO := masks at: 8! !

!File class methodsFor: 'registry' stamp: 'nil'!
unregister: anObject
	^self registry remove: anObject ifAbsent:[]! !

!File class methodsFor: 'primitives - version' stamp: 'nil'!
fileAttributesVersionString

	<primitive: 'primitiveVersionString' module: 'FileAttributesPlugin' error: error>
	^self primitiveFailed! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isReadable: aPath
	"Answer a boolean indicating whether the supplied path is a readable file"

	^self fileAttribute: aPath number: 13! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
close: id
	"Close this file."

	<primitive: 'primitiveFileClose' module: 'FilePlugin'>! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
modeIsDirectory: aMode
	"Answer a boolean indicating whether the supplied mode has the Directory type bit set"

	^(aMode bitAnd: S_IFMT) = S_IFDIR! !

!File class methodsFor: 'attributes' stamp: 'nil'!
file: pathString posixPermissions: anInteger
	"Set the mode of pathString to anInteger (as defined by chmod())"

	^self primFile: (self encodePathString: pathString) posixPermissions: anInteger! !

!File class methodsFor: 'primitives - directory' stamp: 'nil'!
primRewinddir: directoryPointerBytes
	"Rewind the directory stream associated with directoryPointerBytes. Answer
	anExternalAddress on success, or nil on failure."

	"self primRewinddir: (self primOpendir: '/etc')"
	"self primRewinddir: (self primOpendir: '/no/such/directory')"

	<primitive: 'primitiveRewinddir' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: 'primRewinddir:'! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
truncate: id to: anInteger
	"Truncate this file to the given position."

	<primitive: 'primitiveFileTruncate' module: 'FilePlugin'>
	self primitiveFailed! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
sync: id
	"On Unix, this syncs any written or flushed data still in the kernel file
	system buffers to disk. On Windows this and primFlush: do the same thing"

	<primitive: 'primitiveFileSync' module: 'FilePlugin'>

	"fsync() failing cannot be ignored"
	self primitiveFailed! !

!File class methodsFor: 'primitives - path' stamp: 'nil'!
lookupDirectory: fullPath filename: fileName

	"Look up <fileName> (a simple file name) in the directory identified by <fullPath> and return an array containing:

	<fileName> 			
	<creationTime> 			(in seconds since the start of the Smalltalk time epoch)
	<modificationTime> 	(in seconds since the start of the Smalltalk time epoch)
	<dirFlag> 				DirFlag is true if the entry is a directory
	<fileSize> 				FileSize the file size in bytes or zero for directories
	<posixPermissions> 	Numeric Notation 
	<symLinkFlag>			seemingly, symLinkFlag is true if the entry is a symLink

	On Unix, the empty path denotes '/'. 
   On Macs and PCs, it is the container of the system volumes."

 	<primitive: 'primitiveDirectoryEntry' module: 'FilePlugin'>
	
	^ #badDirectoryPath! !

!File class methodsFor: 'primitives - path' stamp: 'nil'!
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:

	<name> <creationTime> <modificationTime> <dirFlag> <fileSize>

	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."

 	<primitive: 'primitiveDirectoryLookup' module: 'FilePlugin' error: errorCode >
	
	^ #badDirectoryPath! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
unsupportedOperation
	"The requested operation is not supported on the current platform"

	^-13! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
sizeOrNil: id
	"Answer the size of this file."

	<primitive: 'primitiveFileSize' module: 'FilePlugin'>
	^ nil! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
statFailed
	"A call to stat() or lstat() failed"
	^-2! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
corruptValue

	^-7! !

!File class methodsFor: 'attributes' stamp: 'nil'!
fileAttributes: aString mask: attributeMask

	| attributes statAttributes mask |

	attributes := self primFileAttributes: (self encodePathString: aString) mask: attributeMask.
	mask := attributeMask bitAnd: 2r11.
	mask = 1 ifTrue: [ statAttributes := attributes ].
	mask = 3 ifTrue: [ statAttributes := attributes at: 1 ].
	(statAttributes isNotNil and: [ (statAttributes at: 1) isNotNil ]) ifTrue: 
		[ statAttributes at: 1 put: (self decodePathString: (statAttributes at: 1)) ].
	^attributes! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
modeIsBlock: aMode
	"Answer a boolean indicating whether the supplied mode has the Block type bit set"

	^(aMode bitAnd: S_IFMT) = S_IFBLK! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
s_IFIFO
	^ S_IFIFO! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isBlock: aPath
	"Answer a boolean indicating whether the supplied path is a Block file"

	^self modeIsBlock: (self modeOf: aPath)! !

!File class methodsFor: 'primitives - file attributes' stamp: 'nil'!
primToPlatformPath: aByteArray
	"Convert the supplied UTF8 encoded string to the platform encoded equivalent"

	<primitive: 'primitiveStToPlatPath' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: 'primToPlatformPath:'! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
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."

	<primitive: 'primitiveFileRead' module: 'FilePlugin'>
	(self closed: id)
		ifTrue: [ ^ self error: 'File is closed' ].
	self error: 'File read failed'! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
cantAllocateMemory

	^-10! !

!File class methodsFor: 'primitives - directory' stamp: 'nil'!
primOpendir: pathString
	"Answer an ExternalAddress for a directory stream on pathString, or nil if
	the directory cannot be opened"

	"self primOpendir: '/etc'"
	"self primOpendir: '.'"
	"self primOpendir: '/no/such/directory'"

	<primitive: 'primitiveOpendir' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: pathString! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
stringTooLong
	"String too long.  A file path name was longer than PATH_MAX"
	^-1! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
cantReadlink

	^-8! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
closed: id
	^ id isNil or: [ (self sizeOrNil: id) isNil ]! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
modeIsSymlink: aMode
	"Answer a boolean indicating whether the supplied mode has the Socket type bit set"

	^(aMode bitAnd: S_IFMT) = S_IFLNK! !

!File class methodsFor: 'primitives - file attributes' stamp: 'nil'!
primFromPlatformPath: aByteArray
	"Convert the supplied platform encoded string to the native (UTF8) equivalent"

	<primitive: 'primitivePlatToStPath' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: 'primToPlatformPath:'! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
s_IFREG
	^ S_IFREG! !

!File class methodsFor: 'attributes' stamp: 'nil'!
toPlatformPath: aString
	"Convert the supplied string to the platform encoded equivalent"

	^self primToPlatformPath: (self encodePathString: aString)! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
unexpectedError
	"This is normally used where a catch-all is placed, but not expected to be used"

	^-14! !

!File class methodsFor: 'primitives - path' stamp: 'nil'!
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."

 	<primitive: 'primitiveDirectoryDelete' module: 'FilePlugin'>
	self primitiveFailed! !

!File class methodsFor: 'class initialization' stamp: 'nil'!
initialize

	SessionManager default registerSystemClassNamed: self name.
	self reset.! !

!File class methodsFor: 'primitives - path' stamp: 'nil'!
primDeleteFile: aFileName
	"Delete the file of the given name. 
	Return self if the primitive succeeds, nil otherwise."

	<primitive: 'primitiveFileDelete' module: 'FilePlugin'>
	^ nil! !

!File class methodsFor: 'registry' stamp: 'nil'!
retryWithGC: execBlock until: testBlock forFileNamed: fullName
	"Some platforms, like Windows, will fail if we try to open a file twice.
	However, sometimes it may happen that a file was unreferenced and should be garbage-collected.
	The purpose of this method is to try to open the file, and if it fails, launch a garbage collection to try to close the unreferenced files.
	Then we will retry again to open the file"

	| blockValue foundIt |
	blockValue := execBlock value.
	(testBlock value: blockValue) ifTrue: [ ^ blockValue ].

	"Optimization: See if we have a file with the given name. Not really needed"
	foundIt := self registry keys "hold on strongly for now" 
		anySatisfy: [:file| file name sameAs: fullName].
	foundIt ifFalse:[^blockValue].

	Smalltalk garbageCollectMost.
	blockValue := execBlock value.
	(testBlock value: blockValue) ifTrue: [ ^ blockValue ].
	Smalltalk garbageCollect.
	^execBlock value.! !

!File class methodsFor: 'primitives - path' stamp: 'nil'!
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."

 	<primitive: 'primitiveDirectoryGetMacTypeAndCreator' module: 'FilePlugin'>! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
stdioHandles
	<primitive: 'primitiveFileStdioHandles' module: 'FilePlugin' error: ec>
	self primitiveFailed! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
modeIsSocket: aMode
	"Answer a boolean indicating whether the supplied mode has the Socket type bit set"

	^(aMode bitAnd: S_IFMT) = S_IFSOCK! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
sizeOf: id
	"Answer the size of this file."

	<primitive: 'primitiveFileSize' module: 'FilePlugin'>
	self primitiveFailed! !

!File class methodsFor: 'primitives - encoding' stamp: 'nil'!
encodePathString: aString

	^ ZnUTF8Encoder default encodeString: aString! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
atEnd: id
	"Answer true if the file position is at the end of the file."

	<primitive: 'primitiveFileAtEnd' module: 'FilePlugin'>
	self primitiveFailed! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isRegular: aPath
	"Answer a boolean indicating whether the supplied path is a Regular file"

	^self modeIsRegular: (self modeOf: aPath)! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isSocket: aPath
	"Answer a boolean indicating whether the supplied path is a Socket file"

	^self modeIsSocket: (self modeOf: aPath)! !

!File class methodsFor: 'primitives - file attributes' stamp: 'nil'!
primFileAttribute: aByteArray number: attributeNumber
	"Answer a single attribute for the supplied file.
	For backward compatibility (on Unix) with FileReference if the file doesn't exist, and the specified path is a (broken) symbolic link, answer the requested attribute for the symbolic link.

stat() information:
	
	1: name
	2: mode
	3: ino
	4: dev
	5: nlink
	6: uid
	7: gid
	8: size
	9: accessDate
	10: modifiedDate
	11: changeDate
	12: creationDate

access() information

	13: is readable
	14: is writeable
	15: is executable

symbolic link information

	16: is symbolic link
	"
	<primitive: 'primitiveFileAttribute' module: 'FileAttributesPlugin' error: error>
	"FilePlugin>>primitiveDirectoryEntry would return the symbolic link attributes if the symbolic link was broken.  This was due to the incorrect implementation of attempting to retrieve symbolic link information.
	If the old behaviour is required, the logic is:
	
		(error isPrimitiveError and: [attributeNumber ~= 16 and: [error errorCode = self cantStatPath and: [
					self platformSupportsSymbolicLinksEgUnix]]]) ifTrue:
						[DiskSymlinkDirectoryEntry fileSystem: DiskStore currentFileSystem path: aString asPath]"
	error isPrimitiveError ifTrue: [ 
		(attributeNumber = 16 and: [ error errorCode = self unsupportedOperation ]) ifTrue: 
			"If symlinks aren't supported, answer false"
			[ ^false ]].
	^self signalError: error for: aByteArray! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
s_IFCHR
	^ S_IFCHR! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isWritable: aPath
	"Answer a boolean indicating whether the supplied path is a writable file"

	^self fileAttribute: aPath number: 14! !

!File class methodsFor: 'primitives - encoding' stamp: 'nil'!
decodePathString: aByteArray

	^ ZnUTF8Encoder default decodeBytes: aByteArray asByteArray! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isFIFO: aPath
	"Answer a boolean indicating whether the supplied path is a FIFO file"

	^self modeIsFIFO: (self modeOf: aPath)! !

!File class methodsFor: 'primitives - file attributes' stamp: 'nil'!
primFile: pathByteArray uid: uidInteger gid: gidInteger
	"Set the owner and group of path by numeric id."

	<primitive: 'primitiveChangeOwner' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: pathByteArray! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
setPosition: id to: anInteger
	"Set this file to the given position."

	<primitive: 'primitiveFileSetPosition' module: 'FilePlugin'>
	self primitiveFailed! !

!File class methodsFor: 'primitives - directory' stamp: 'nil'!
primPathMax
	"Answer the VMs PATH_MAX value"
	<primitive: 'primitivePathMax' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: 'primPathMax'! !

!File class methodsFor: 'primitives - file attributes' stamp: 'nil'!
primExists: aByteArray
	"Answer a boolean indicating whether the supplied file exists."

	<primitive: 'primitiveFileExists' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: aByteArray.! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
s_IFDIR
	^ S_IFDIR! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
isDirectory: aPath
	"Answer a boolean indicating whether the supplied path is a Directory"

	^[ self modeIsDirectory: (self modeOf: aPath) ]
		on: FileDoesNotExistException
		do: [ false ].! !

!File class methodsFor: 'primitives - path' stamp: 'nil'!
deleteFile: fullPathString
	"Delete the supplied UTF8 encoded path.  Answer nil on failure."

	| utf8Path |

	utf8Path := fullPathString utf8Encoded.
	self
		retryWithGC: [ self primDeleteFile: utf8Path ]
		until: [ :result | result notNil ]
		forFileNamed: fullPathString.
	(self primExists: utf8Path) ifTrue: 
		[ (CannotDeleteFileException new messageText: 'Could not delete file ' , name,
			'. Check the file is not open.') signal ].! !

!File class methodsFor: 'file creation' stamp: 'nil'!
named: fileName
	"Open a file with the given name for reading and writing. If the name has no directory part, then the file will be created in the default directory. If the file already exists, its prior contents may be modified or replaced, but the file will not be truncated on close."

	^ self new named: fileName! !

!File class methodsFor: '*Deprecated10' stamp: ''!
openAndTruncateForWriteFileNamed: aName

	self deprecated: 'Use FileReference API for example ''filename'' asFileReference ensureDelete'.
	^ (self named: aName)
		delete;
		openForWrite! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
flush: id
	"On Unix, the FilePlugin uses stdio FILE* structs which maintain their
	own internal buffer to minimize write() syscalls. This flushes that buffer.
	On Windows this and primSync: do the same thing."

	<primitive: 'primitiveFileFlush' module: 'FilePlugin'>
	
	"We can't ignore fflush() failing, because it can fail for any of the
	reasons write() can."
	self primitiveFailed! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
modeIsCharacter: aMode
	"Answer a boolean indicating whether the supplied mode has the Character type bit set"

	^(aMode bitAnd: S_IFMT) = S_IFCHR! !

!File class methodsFor: 'primitives - file attributes' stamp: 'nil'!
primFile: pathByteArray posixPermissions: anInteger
	"Set the mode of pathByateArray to anInteger (as defined by chmod())"

	<primitive: 'primitiveChangeMode' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: pathByteArray! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
primitiveWaitForDataOn: id signalling: semaphoreIndex

	<primitive: 'primitiveWaitForDataWithSemaphore' module: 'FilePlugin' error: ec>

	self primitiveFailed! !

!File class methodsFor: 'attributes' stamp: 'nil'!
file: pathString symlinkUid: uidInteger gid: gidInteger
	"Set the owner and group of pathString by numeric id."

	^self primFile: (self encodePathString: pathString) 
		symlinkUid: (uidInteger ifNil: [ -1 ]) 
		gid: (gidInteger ifNil: [ -1 ])! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
connectToFileDescriptor: fileDescriptor writable: writableFlag
	"Connect to the file with fileDescriptor number, and return the file ID obtained.
	writeableFlag indicates whether to allow write operations and must be compatible with the way the file was opened.
	It is the responsibility of the caller to coordinate closing the file."

	<primitive: 'primitiveConnectToFileDescriptor' module: 'FilePlugin' error: error>
	error = #'bad argument' ifTrue: [ 
		fileDescriptor isInteger ifFalse: 
			[ ^self error: 'fileDescriptor must be an integer' ].
		(writableFlag isKindOf: Boolean) ifFalse: 
			[ ^self error: 'writableFlag must be a boolean' ] ].
	^ self primitiveFailed! !

!File class methodsFor: 'attributes' stamp: 'nil'!
file: pathString uid: uidInteger gid: gidInteger
	"Set the owner and group of pathString by numeric id.
	An id of nil leaves it unchanged."

	^self primFile: (self encodePathString: pathString) 
		uid: (uidInteger ifNil: [ -1 ])
		gid: (gidInteger ifNil: [ -1 ])! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
modeIsFIFO: aMode
	"Answer a boolean indicating whether the supplied mode has the FIFO type bit set"

	^(aMode bitAnd: S_IFMT) = S_IFIFO! !

!File class methodsFor: 'primitives - path' stamp: 'nil'!
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."

 	<primitive: 'primitiveDirectoryCreate' module: 'FilePlugin'>
	^ nil! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
cantStatPath
	"SecurityPlugin determined that the requested path cannot be accessed."
	^-3! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
getPosition: id
	"Get this files current position."

	<primitive: 'primitiveFileGetPosition' module: 'FilePlugin'>
	self primitiveFailed! !

!File class methodsFor: 'primitives - file' stamp: 'nil'!
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"

	<primitive: 'primitiveFileOpen' module: 'FilePlugin'>
	^ nil! !

!File class methodsFor: 'private' stamp: 'nil'!
primFileMasks
	"Answer an array of well known masks:
	
	1: S_IFMT
	2: S_IFSOCK
	3: S_IFLNK
	4: S_IFREG
	5: S_IFBLK
	6: S_IFDIR
	7: S_IFCHR
	8: S_IFIFO

	For more information, see: http://man7.org/linux/man-pages/man2/stat.2.html
	"
	<primitive: 'primitiveFileMasks' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: 'primFileMasks'! !

!File class methodsFor: 'primitives - windows' stamp: 'nil'!
primLogicalDrives
	"Answer the windows logical drive mask"
	<primitive: 'primitiveLogicalDrives' module: 'FileAttributesPlugin' error: error>
	^self signalError: error for: 'primLogicalDrives'! !

!File class methodsFor: 'private' stamp: 'nil'!
signalError: error for: aByteArray
	"Raise the appropriate signal for the supplied error"

	| errorNumber pathString |

	error ifNil: [ ^self primitiveFailed ].
	error isSymbol ifTrue: [ ^self primitiveFailed: error ].
	error isPrimitiveError ifFalse: [ 
		"We shouldn't ever get here"
		^self primitiveFailed. ].

	pathString := self decodePathString: aByteArray asByteArray.
	errorNumber := error errorCode.
	errorNumber = self stringTooLong ifTrue: 
		[ ^IllegalFileName signalWith: pathString ].
	errorNumber = self cantStatPath ifTrue: 
		[ ^FileDoesNotExistException signalWith: pathString ].
	errorNumber = self getAttributesFailed ifTrue: 
		[ ^FileDoesNotExistException signalWith: pathString ].
	errorNumber = self unsupportedOperation ifTrue: 
		[ ^FileAttributeNotSupported signalWith: pathString ].
	^FileException signalWith: pathString.! !

!File class methodsFor: 'primitives - file modes' stamp: 'nil'!
s_IFMT
	^ S_IFMT! !

!File class methodsFor: 'primitives - errors' stamp: 'nil'!
cantOpenDir

	^-9! !

!File class methodsFor: 'system startup' stamp: 'nil'!
startUp: isImageStarting
	"Update VM constants on startup"

	isImageStarting ifTrue: [ self reset ]! !

!FileAlreadyExistsException commentStamp: ''!
I am an exception that notifies that a file already exists.!
!FileAlreadyExistsException methodsFor: 'accessing' stamp: 'nil'!
messageText

	^ 'File already exists: ', file basename! !

!FileAlreadyExistsException methodsFor: 'accessing' stamp: 'nil'!
file
	^ file! !

!FileAlreadyExistsException methodsFor: 'accessing' stamp: 'nil'!
file: aFile
	
	file := aFile! !

!FileAlreadyExistsException methodsFor: '*Files-Prompt' stamp: ''!
defaultAction
	"The default action taken if the exception is signaled."

	^ UIManager default fileExistsDefaultAction: self! !

!FileAlreadyExistsException class methodsFor: 'instance creation' stamp: 'nil'!
signalOnFile: aFile 
	
	self new
		file: aFile;
		signal! !

!FileAttributeNotSupported commentStamp: ''!
FileAttributeNotSupported is signaled when an attempt is made to request an attribute that is not supported on the receiving file system.
!
!FileAttributesPluginPrimsTest commentStamp: ''!
FileAttributePluginPrimsTests mostly tests failure cases.  Functionality tests are contained in DiskFileAttributeTests and FileReferenceAttributeTests.!
!FileAttributesPluginPrimsTest methodsFor: 'tests' stamp: ''!
testPrimExistsNil
	"FileAttributesPluginPrims>>primClosedir: nil should raise a bad argument error"

	self
		should: [ primitives primExists: nil ]
		raise: PrimitiveFailed
		withExceptionDo: [ :exception | 
			self assert: exception selector equals: #'bad argument' ].! !

!FileAttributesPluginPrimsTest methodsFor: 'tests' stamp: ''!
testExistsPathTooLong

	| pathMax filename |
	pathMax := primitives primPathMax.
	filename := String new: pathMax * 2 withAll: $a.
	self 
		should: [ primitives exists: filename ]
		raise: IllegalFileName.! !

!FileAttributesPluginPrimsTest methodsFor: 'tests' stamp: ''!
testPrimCloseDirWrongLength
	"FileAttributesPluginPrims>>primClosedir: only accepts a ByteArray of size 'void *'"

	self
		should: [ primitives primClosedir: (ByteArray new: 1) ]
		raise: PrimitiveFailed
		withExceptionDo: [ :exception | 
			self assert: exception selector equals: #'bad argument' ].! !

!FileAttributesPluginPrimsTest methodsFor: 'tests' stamp: ''!
testPrimCloseDirNil
	"FileAttributesPluginPrims>>primClosedir: nil should raise a bad argument error"

	self
		should: [ primitives primClosedir: nil ]
		raise: PrimitiveFailed
		withExceptionDo: [ :exception | 
			self assert: exception selector equals: #'bad argument' ].! !

!FileAttributesPluginPrimsTest methodsFor: 'tests' stamp: ''!
testPrimCloseDirString
	"FileAttributesPluginPrims>>primClosedir: only accepts a ByteArray, anything else should raise an error"

	self
		should: [ primitives primClosedir: 'not a buffer' ]
		raise: PrimitiveFailed
		withExceptionDo: [ :exception | 
			self assert: exception selector equals: #'bad argument' ].! !

!FileAttributesPluginPrimsTest methodsFor: 'tests' stamp: ''!
testFileAttributeNumberOutOfRange
	"Check that the appropriate Bad Argument error is raised if an invalid attribute number is supplied"

	self 
		should: [ primitives fileAttribute: 'ignored' number: 0 ]
		raise: PrimitiveFailed.
	self 
		should: [ primitives fileAttribute: 'ignore' number: primitives fileAttributeNumberMap size + 1 ]
		raise: PrimitiveFailed.! !

!FileAttributesPluginPrimsTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	primitives := File.! !

!FileCompilerRequestor commentStamp: ''!
I am an Object used to interact with the OpalCompiler.
I keep a reference to the original input so that error messages can be properly analyzed later-on.!
!FileCompilerRequestor methodsFor: 'accessing' stamp: ''!
fileReference: anObject
	fileReference := anObject! !

!FileCompilerRequestor methodsFor: 'initialization' stamp: ''!
initialize
	interactive := false.! !

!FileCompilerRequestor methodsFor: 'interactive error protocol' stamp: ''!
notify: message at: location in: code
	| newSource |
	self flag: #hack.
	"Should use the new OPalWarnings directly instead of recreating a SyntaxErrorNotification"
	newSource := SyntaxErrorNotification 
		inClass: STCommandLineHandler
		withCode: code
		doitFlag: false
		errorMessage: message
		location: location.
		
	"If the syntax error notification is resumed, then the source was corrected and we have to announce that parsing can restart."					
	ReparseAfterSourceEditing signalWithNewSource: newSource! !

!FileCompilerRequestor methodsFor: 'accessing' stamp: ''!
fileReference
	^ fileReference! !

!FileCompilerRequestor methodsFor: 'testing' stamp: ''!
interactive
	^ interactive ifNil: [ false ]! !

!FileCompilerRequestor methodsFor: 'accessing' stamp: ''!
failBlock
	^ [ :exception | exception pass ]! !

!FileCompilerRequestor methodsFor: 'accessing' stamp: ''!
contents
	^ contents! !

!FileCompilerRequestor methodsFor: 'accessing' stamp: ''!
interactive: aBoolean
	interactive := aBoolean! !

!FileCompilerRequestor methodsFor: 'accessing' stamp: ''!
contents: anObject
	contents := anObject! !

!FileCompilerRequestor methodsFor: 'accessing' stamp: ''!
text
	"compatibility method for the method installer"
	^ self contents! !

!FileDialogWindow commentStamp: ''!
Dialog based file chooser for selecting 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: ''!
previewMorph
	"Answer the value of previewMorph"

	^ previewMorph! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
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: 'actions' stamp: ''!
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: 'update' stamp: ''!
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: 'accessing' stamp: ''!
defaultExtension: anObject
	"Set the value of defaultExtension"

	defaultExtension := anObject! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
fileSortBlock
	"Answer the value of fileSortBlock"

	^ fileSortBlock! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
deleteDirectoryEntry: entry
	entry asFileReference deleteAll.
	self
		clearEntryCache;
		updateDirectories! !

!FileDialogWindow methodsFor: 'instance creation' stamp: ''!
newImagePreviewMorph
	"Answer a new image preview morph."

	^ImagePreviewMorph new
		cornerStyle: self preferredCornerStyle;
		image: nil
		size: self previewSize! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
deleteFileEntry: entry
	entry asFileReference delete.
	self
		selectedFileIndex: 0;
		clearEntryCache;
		updateFiles ! !

!FileDialogWindow methodsFor: 'instance creation' stamp: ''!
newUpButton
	"Answer a new up one directory level button."

	^ self
		newButtonFor: self
		getState: nil
		action: #selectParentDirectory
		arguments: nil
		getEnabled: #hasParentDirectory
		labelForm: (self iconNamed: #smallUndoIcon)
		help: 'Press to switch to the parent of the current directory' translated! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
entryCache: anObject
	"Set the value of entryCache"

	entryCache := anObject! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
entryCacheDirectory
	"Answer the value of entryCacheDirectory"

	^ entryCacheDirectory! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
defaultFileSortBlock
	"Answer the default file stor block"

	^[:entry1 :entry2 |
		entry1 isDirectory = entry2 isDirectory
			ifTrue: [entry1 basename caseInsensitiveLessOrEqual: entry2 basename]
			ifFalse: [entry1 isDirectory
						ifTrue: [true]
						ifFalse: [entry2 isDirectory
									ifTrue: [false]
									ifFalse: [entry1 basename caseInsensitiveLessOrEqual: entry2 basename]]]]! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
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: 'actions' stamp: ''!
answerFileName
	"Set the receiver to answer the selected file name."
	
	self actionSelector: #selectedFileName.
	self changed: #okEnabled! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
isResizeable
	"Answer whether we are not we can be resized."

	^true! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
answerFileEntry
	"Set the receiver to answer the selected file entry."
	
	self actionSelector: #selectedFileEntry.
	self changed: #okEnabled! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
directories: anObject
	"Set the value of directories"

	directories := anObject! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
answer: anObject
	"Set the answer."
	
	answer := anObject! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
defaultFileSelectionBlock
	"Answer the default file selection block."

	^[:entry |
		entry isDirectory
			ifTrue: [self showDirectoriesInFileList]
			ifFalse: [self fileNamePattern match: entry basename]]! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
addInitialPanel
	super addInitialPanel.
	self selectDirectory: self preferredFileSystem workingDirectory! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
cache: dir
	"Cache the contents of the given directory and answer them."

	self entryCacheDirectory = dir
		ifFalse: [Cursor wait showWhile: [
					self
						entryCache: (self dirEntriesOrEmptyListFor: dir);
						entryCacheDirectory: dir]].
	^self entryCache! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
updateDirectories
	"Update the directory tree and reselect the current."

	|dir|
	dir := self selectedFileDirectory.
	self changed: #directories.
	self selectDirectory: dir.
	self updateFiles! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
selectedFileIndex: anObject
	"Set the value of selectedFileIndex"

	selectedFileIndex := anObject.
	self updateSelectedFile! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
updatePreview
	"Update the preview."

	self previewType == #image ifTrue: [self updateImagePreview].
	self previewType == #text ifTrue: [self updateTextPreview]! !

!FileDialogWindow methodsFor: 'testing' stamp: ''!
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: 'accessing' stamp: ''!
showDirectoriesInFileList
	"Answer the value of showDirectoriesInFileList"

	^ showDirectoriesInFileList! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
defaultExtension
	"Answer the value of defaultExtension"

	^ defaultExtension! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
directories
	^ directories! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
fileNamePattern
	"Answer the file name pattern to filter on."
	
	^self fileNameText trimBoth, '*'! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
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: 'actions' stamp: ''!
selectedFileEntry
	"Answer the selected file."

	self selectedFileIndex = 0 ifTrue: [^nil].
	^self files at: self selectedFileIndex ifAbsent: [nil]! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
entryCacheDirectory: anObject
	"Set the value of entryCacheDirectory"

	entryCacheDirectory := anObject! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
clearEntryCache
	"Clear the entry cache."

	self
		entryCache: nil;
		entryCacheDirectory: nil! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
actionSelector
	"Answer the value of actionSelector"

	^ actionSelector! !

!FileDialogWindow methodsFor: 'instance creation' stamp: ''!
newDirectoryTree
	"Answer a new directory tree."
	
	^(self newTreeFor: self
		list: #directories
		selected: #selectedDirectory
		changeSelected: #selectedDirectory:)
		minHeight: 200;
		minWidth: 180! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
validExtensions: aList
	"Set the filter for the files to be those with the given extensions."
	
	aList notEmpty
		ifTrue: [self defaultExtension: aList first].
	self fileSelectionBlock: [:de |
		de isDirectory
			ifTrue: [self showDirectoriesInFileList]
			ifFalse: [
				(self fileNamePattern match: de name) and: [
						aList includes: de extension asLowercase]]] ! !

!FileDialogWindow methodsFor: 'update' stamp: ''!
updateTextPreview
	"Update the text preview."

	|str text|
	str := self openSelectedFile.
	str ifNil: [^self].
	[[text := str next: 5000]
		on: Error do: []]
		ensure: [str close].
	text ifNil: [text := ''].
	self previewMorph
		setText: text! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
fileSelectionBlock: anObject
	"Set the value of fileSelectionBlock"

	fileSelectionBlock := anObject.
	self updateFiles! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
selectParentDirectory
	"Switch to the parent directory."

	self hasParentDirectory ifFalse: [^self].
	self selectDirectory: self selectedFileDirectory asFileReference parent! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
preferredFileSystem: aFileSystem
	preferredFileSystem := aFileSystem! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
fileSelectionBlock
	"Answer the value of fileSelectionBlock"

	^ fileSelectionBlock! !

!FileDialogWindow methodsFor: 'widget API' stamp: ''!
iconFor: anEntry
	"Answer the icon to use for the directory entry."

	^ anEntry isDirectory
		ifTrue: [ self iconNamed: #smallOpenIcon ]
		ifFalse: [ (self isImageFile: anEntry basename)
				ifTrue: [ self iconNamed: #smallPaintIcon ]
				ifFalse: [ self iconNamed: #smallLeftFlushIcon ] ]! !

!FileDialogWindow methodsFor: 'private' stamp: ''!
dirEntriesOrEmptyListFor: aDirectory
|entries|
	aDirectory isReadable ifFalse:[ ^ #()].
	entries := [aDirectory entries] on: DirectoryDoesNotExist do:[#()].
	^ entries! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
selectDirectory: aFileReference
	"Expand and select the given directory."

	| pathSegments |
	pathSegments := aFileReference isRoot
		ifTrue: [ Array with: aFileReference pathString ]
		ifFalse: [ aFileReference pathSegments ].
	self changed: #(openPath) , pathSegments! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
selectedDirectory: anObject
	selectedDirectory := anObject.
	self
		selectedFileIndex: 0;
		updateSelectedDirectory;
		updateFiles! !

!FileDialogWindow methodsFor: 'testing' stamp: ''!
hasSelectedFileOrDirectory
	"Answer whether a file or directopry is selected in the file list."

	^ self selectedFileIndex ~= 0! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
deleteFileOrDirectory

	"Delete the selected file or directory."

	| entry |
	self hasSelectedFileOrDirectory ifFalse: [ ^ self ].
	entry := self selectedFileEntry.
	entry isDirectory
		ifTrue: [ self confirmDeleteDirectoryEntry: entry	 ]
		ifFalse: [ self confirmDeleteFileEntry: entry ]! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
fileNameText
	"Answer the typed file name."

	^fileNameText! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
previewType: anObject
	"Set the value of previewType.
	See #updatePreview for supported types."

	previewType := anObject! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
selectedDirectory
	"Answer the value of selectedDirectory"

	^ selectedDirectory! !

!FileDialogWindow methodsFor: 'private' stamp: ''!
directoriesFor: item
	"Answer the filtered entries."
	
	^item directories! !

!FileDialogWindow methodsFor: 'instance creation' stamp: ''!
newPreviewMorph
	"Answer a new preview morph."

	self previewType == #image ifTrue: [^self newImagePreviewMorph].
	self previewType == #text ifTrue: [^self newTextPreviewMorph].
	^nil! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
previewSize
	"Answer the size of preview to use."

	self previewType == #text ifTrue: [^256@256].
	^128@128! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
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: 'actions' stamp: ''!
answerOpenFile
	"Set the receiver to answer a new file stream on an existing file."
	
	self actionSelector: #openSelectedFile.
	self changed: #okEnabled! !

!FileDialogWindow methodsFor: 'instance creation' stamp: ''!
newDeleteButton
	"Answer a new delete button."

	^ self
		newButtonFor: self
		getState: nil
		action: #deleteFileOrDirectory
		arguments: nil
		getEnabled: #hasSelectedFileOrDirectory
		labelForm: (self iconNamed: #smallDeleteIcon)
		help: 'Press to delete the selected file or directory' translated! !

!FileDialogWindow methodsFor: 'open/close' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	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: 'actions' stamp: ''!
answerSaveFile
	"Set the receiver to answer a new file stream."
	
	self actionSelector: #saveSelectedFile.
	self changed: #okEnabled! !

!FileDialogWindow methodsFor: 'initialization' stamp: ''!
initialExtent
	^ 750@550! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
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: 'accessing' stamp: ''!
selectedFileIndex
	"Answer the value of selectedFileIndex"

	^ selectedFileIndex! !

!FileDialogWindow methodsFor: 'instance creation' stamp: ''!
newActionButtonRow
	"Answer a new row with the action buttons."
	
	^(self newRow: {
		self newUpButton.
		self newNewDirectoryButton.
		self newDeleteButton})
		listCentering: #bottomRight! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
selectedFileName

	^ self selectedFileEntry ifNotNil: [ :dir | dir basename ]! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
preferredFileSystem
	^ preferredFileSystem ifNil: [ FileSystem disk ]! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
fileListMorph
	"Answer the value of fileListMorph"

	^ fileListMorph! !

!FileDialogWindow methodsFor: 'controls' stamp: ''!
newOKButton
	"Answer a new OK button."

	^self
		newOKButtonFor: self
		getEnabled: #okEnabled! !

!FileDialogWindow methodsFor: 'enumerating' stamp: ''!
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: 'actions' stamp: ''!
confirmDeleteFileEntry: entry
	(self
		 proceed: 'Are you sure you wish to delete the\file' withCRs translated , ' "' , entry name , '"?'
		 title: 'Delete File' translated) 
		ifTrue: [ self deleteFileEntry: entry ]! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
answer
	"Answer the result of performing the action selector."
	
	self cancelled ifTrue: [^nil].
	^answer! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
previewMorph: anObject
	"Set the value of previewMorph"

	previewMorph := anObject! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
showDirectoriesInFileList: anObject
	"Set the value of showDirectoriesInFileList"

	showDirectoriesInFileList := anObject.
	self updateFiles! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
directoryTreeMorph: anObject
	"Set the value of directoryTreeMorph"

	directoryTreeMorph := anObject! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
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: 'instance creation' stamp: ''!
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: 'actions' stamp: ''!
selectPath: aPathOrFileReference
	"Select the directory and set the file name text from the given path."

	| reference |
	reference := (self preferredFileSystem
		referenceTo: (self preferredFileSystem resolve: aPathOrFileReference)) asAbsolute.
	reference exists
		ifFalse: [ ^ self selectPath: reference parent ].
	reference isDirectory
		ifTrue: [ ^ self selectDirectory: reference ].

	"must be a file then"
	self selectDirectory: reference parent.
	self fileNameText: reference basename! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
actionSelector: anObject
	"Set the value of actionSelector"

	actionSelector := anObject! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
entryCache
	"Answer the value of entryCache"

	^ entryCache! !

!FileDialogWindow methodsFor: 'instance creation' stamp: ''!
newNewDirectoryButton
	"Answer a new 'new directory' button."

	^ self
		newButtonFor: self
		getState: nil
		action: #newDirectory
		arguments: nil
		getEnabled: nil
		labelForm: (self iconNamed: #smallOpenIcon)
		help:
			'Press to create a new directory within the current directory'
				translated! !

!FileDialogWindow methodsFor: 'update' stamp: ''!
updateSelectedDirectory
	"Notify that the selected directory has changed."

	self
		changed: #selectedDirectory;
		changed: #selectedFileDirectory;
		changed: #selectedPathName;
		changed: #hasParentDirectory! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
directoryFileSelectionBlock
	"Answer the directory file selection block."

	^[:de |
		de isDirectory
			ifTrue: [self showDirectoriesInFileList]
			ifFalse: [false]] ! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
fileListMorph: anObject
	"Set the value of fileListMorph"

	fileListMorph := anObject! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
initialDirectories
	"Answer the initial directories."

	| dirList |
	dirList := self preferredFileSystem root directories collect: [ :each | FileDirectoryWrapper with: each name: each basename model: self ] as: OrderedCollection.
	dirList add: (FileDirectoryWrapper with: self preferredFileSystem root name: self preferredFileSystem root basename model: self).
	dirList isEmpty
		ifTrue: [ | workingDirectory wrapper |
			workingDirectory := self preferredFileSystem workingDirectory.
			wrapper := FileDirectoryWrapper with: workingDirectory name: workingDirectory basename model: self.
			dirList := Array with: wrapper ].
	^ dirList! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
confirmDeleteDirectoryEntry: entry
	(self proceed: 'Are you sure you wish to delete the\selected directory along with its files?' withCRs translated
	      title: 'Delete Directory' translated)
		ifTrue: [ self deleteDirectoryEntry: entry ]! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
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 reject: [ :de | de isDirectory ].
	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: 'actions' stamp: ''!
defaultLabel
	"Answer the default label for the receiver."

	^'File' translated! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
fileSortBlock: anObject
	"Set the value of fileSortBlock"

	fileSortBlock := anObject! !

!FileDialogWindow methodsFor: 'testing' stamp: ''!
hasParentDirectory
	"Answer whether the selected directory in the tree part has a parent."

	^ self selectedFileDirectory ifNotNil: [ :dir | dir isRoot not ] ifNil: [ false ].! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
directoryTreeMorph
	"Answer the value of directoryTreeMorph"

	^ directoryTreeMorph! !

!FileDialogWindow methodsFor: 'instance creation' stamp: ''!
newDirectory
	"Create a new directory within the selected directory."

	|dir dirName title|
	dir := self selectedFileDirectory ifNil: [^self].
	title := 'Create Directory' translated.
	dirName := self
		textEntry: 'Enter directory name' translated
		title: title.
	dirName ifNil: [^self].
	
	[
		(dir / dirName) exists
			ifTrue: [
				^self
					alert: 'A file or directory already exists\with the name' withCRs translated, ' "', dirName, '"'
					title: title
		].
		(dir / dirName) ensureCreateDirectory
	]
	on: Error
	do: [:ex |
		^self
			alert: 'Invalid directory name' translated, ' "', dirName, '"'
			title: title
	].

	self
		clearEntryCache;
		updateDirectories! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
selectedFileDirectory
	"Answer the selected file directory in the tree part."

	^ (self selectedDirectory ifNil: [^nil]) item! !

!FileDialogWindow methodsFor: 'update' stamp: ''!
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: 'update' stamp: ''!
updateFiles
	"Notify that the files have changed."

	self changed: #files! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
answerDirectory
	"Set the receiver to answer a directory."
	
	self actionSelector: #selectedAnyFileDirectory.
	self fileSelectionBlock: self directoryFileSelectionBlock.
	self changed: #okEnabled! !

!FileDialogWindow methodsFor: 'actions' stamp: ''!
answerPathName
	"Set the receiver to answer the selected path name."
	
	self actionSelector: #selectedPathName.
	self changed: #okEnabled! !

!FileDialogWindow methodsFor: 'instance creation' stamp: ''!
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: 'instance creation' stamp: ''!
newTextPreviewMorph
	"Answer a new text preview morph."

	^(self newTextEditorFor: self getText: nil setText: nil getEnabled: nil)
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		extent: self previewSize;
		minWidth: self previewSize x;
		minHeight: self previewSize y;
		enabled: false! !

!FileDialogWindow methodsFor: 'accessing' stamp: ''!
previewType
	"Answer the value of previewType"

	^ previewType! !

!FileDialogWindow methodsFor: 'testing' stamp: ''!
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: 'initialization' stamp: ''!
initializeOn: aFileSystem
	self preferredFileSystem: aFileSystem.
	self initialize! !

!FileDialogWindow class methodsFor: 'initialize - release' stamp: ''!
onFileSystem: aFileSystem
	^ self basicNew
		initializeOn: aFileSystem;
		yourself! !

!FileDialogWindow class methodsFor: 'examples' stamp: ''!
example
	<example>
	(self onFileSystem: FileSystem disk) open! !

!FileDialogWindow class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallOpenIcon! !

!FileDialogWindowTest commentStamp: ''!
Unit tests for File dialog window!
!FileDialogWindowTest methodsFor: 'tests' stamp: ''!
testUsingMemoryFileSystemSelectInvalidDirectory
	"Tests that selecting a non existent directory defaults to selecting the working directory"
	| nonExistentDirectory dialog |
	nonExistentDirectory := 'cant-possibly-exist-for-testIssue6406'.
	dialog := self dialogOnMemFs selectPath: nonExistentDirectory; yourself.
	
	"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: memFs workingDirectory fullName asLowercase! !

!FileDialogWindowTest methodsFor: 'tests - helper' stamp: ''!
randomTestPathName

	^ 'FileDialogWindowTest-' , UUIDGenerator next asString! !

!FileDialogWindowTest methodsFor: 'tests' stamp: ''!
testDeleteFileOrDirectory
	| pathName aFolder dialog |
	
	pathName := self randomTestPathName.
	aFolder := (memFs workingDirectory / pathName) ensureCreateDirectory.
	
	"Make sure that aFolder is not empty"
	aFolder / 'make-directory-non-empty-issue-6331.txt' writeStreamDo: [ :stream | stream nextPutAll: 'foobar' ].
	
	"Select aFolder on the left side"
	dialog := self dialogOnMemFs selectPath: '/'; yourself.

	"Check that it is selected"
	self assert: dialog selectedFileDirectory fullName equals: '/'.
		
	"Check that there is only one directory in the selected directory, and that it is the one we created"
	self assert: dialog files size equals: 1.
	self assert: dialog files first fullName asLowercase equals: aFolder fullName asLowercase.
		
	"Select that one directory on the right side"
	dialog selectedFileIndex: 1.
		
	"Check that the selected directory is the one we created"
	self assert: dialog selectedFileName asLowercase equals: aFolder basename asLowercase.
					
	"Delete the selected directory"
	dialog deleteDirectoryEntry: dialog selectedFileEntry. 
		
	"Check that it has indeed been deleted"
	self deny: aFolder exists! !

!FileDialogWindowTest methodsFor: 'tests' stamp: ''!
testUsingMemoryFileSystemRelativePathCanBeSelected
	| pathName aFolder dialog |
	
	pathName := self randomTestPathName.
	aFolder := (memFs workingDirectory / pathName) ensureCreateDirectory.
	
	dialog := self dialogOnMemFs selectPath: (memFs referenceTo: pathName); yourself.
	
	"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.
! !

!FileDialogWindowTest methodsFor: 'tests - helper' stamp: ''!
dialogOnMemFs
	^ FileDialogWindow onFileSystem: memFs! !

!FileDialogWindowTest methodsFor: 'tests' stamp: ''!
testUsingMemoryFileSystemAbsolutePathCanBeSelected
	| pathName aFolder dialog |
	
	pathName := self randomTestPathName.
	aFolder := (memFs workingDirectory / pathName) ensureCreateDirectory.
	
	dialog := self dialogOnMemFs selectPath: aFolder; yourself.

	"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! !

!FileDialogWindowTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	memFs := FileSystem memory! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: ''!
setItem: anObject name: aString model: aModel

	item := anObject.
	model := aModel.
	itemName := aString.
	hasContents := nil.
! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: ''!
hasContents
	"Return whether this directory has subfolders. The value is cached to 
	avoid a performance penalty.	Also for performance reasons, the code 
	below will just assume that the directory does indeed have contents in a 
	few of cases:  
	1. If the item is not a FileDirectory (thus avoiding the cost 
	of refreshing directories that are not local) 
	2. If it's the root directory of a given volume 
	3. If there is an error computing the FileDirectory's contents
	"
	hasContents ifNil: [
		hasContents := [ 
				item isDirectory 
				and: [ item isReadable 
				and: [ item hasDirectories ]]
			] on: Error do: [ :error | false ]].
	^ hasContents! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: ''!
balloonText

	^balloonText! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: ''!
settingSelector

	^#setSelectedDirectoryTo:! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: ''!
balloonText: aStringOrNil

	balloonText := aStringOrNil! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: ''!
directoriesFor: anItem
	^model directoriesFor: anItem! !

!FileDirectoryWrapper methodsFor: 'converting' stamp: ''!
asString
	 ^itemName! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: ''!
icon
	"Answer a form to be used as icon"

	"^ item isRemoteDirectory
		ifTrue: [ Smalltalk ui icons smallRemoteOpenIcon]
		ifFalse: [Smalltalk ui icons smallOpenIcon]"

	^ self iconNamed: #smallOpenIcon! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: ''!
contents

	^((model directoriesFor: item) 
		sort: [ :a :b | a basename caseInsensitiveLessOrEqual: b basename]) 
		collect: [ :directory| 
			self class with: directory name: directory basename model: self ]
! !

!FileDirectoryWrapper class methodsFor: 'instance creation' stamp: ''!
with: anObject name: aString model: aModel

	^self new 
		setItem: anObject name: aString model: aModel! !

!FileDoesNotExistException commentStamp: ''!
I am raised when an operation is attempted on a file that does not exist.

The method used to signal the exception depends on the form the file name exists in:

- For strings: (FileDoesNotExistException file fileName: aString) signal 
- For Files: FileDoesNotExistException signalOnFile: aFile
- For FileReferences: FileDoesNotExistException signalWith: aFileReference


Applications that want to offer the user the opportunity to select a different file can use:

	UIManager default fileDoesNotExistsDefaultAction: exception
!
!FileDoesNotExistException methodsFor: 'accessing' stamp: 'nil'!
readOnly
	^readOnly == true! !

!FileDoesNotExistException methodsFor: 'accessing' stamp: 'nil'!
readOnly: aBoolean
	readOnly := aBoolean! !

!FileDoesNotExistException class methodsFor: 'signalling' stamp: 'nil'!
signalWithFile: aFile writeMode: writeMode

	^ (self fileName: aFile basename)
		readOnly: writeMode not;
		signal! !

!FileException commentStamp: ''!
Common superclass for exceptions while using file streams!
!FileException methodsFor: 'exceptiondescription' stamp: 'nil'!
isResumable
	"Determine whether an exception is resumable."

	^true! !

!FileException methodsFor: 'exceptionbuilder' stamp: 'nil'!
fileName: aFileName
	fileName := aFileName! !

!FileException methodsFor: 'exceptiondescription' stamp: 'nil'!
fileName
	^fileName! !

!FileException methodsFor: 'exceptiondescription' stamp: 'nil'!
messageText

	"Return an exception's message text."

	^ messageText ifNil: [ fileName printString ] ifNotNil: [ messageText ]! !

!FileException class methodsFor: 'instance creation' stamp: 'nil'!
signalWith: aReference
	"Signal a new instance of the receiver with the supplied reference.
	aReference is something that can be converted to a path, e.g. a String, Path or FileReference"

	^(self fileName: aReference asPath pathString) signal! !

!FileException class methodsFor: 'exceptioninstantiator' stamp: 'nil'!
fileName: aFileName
	^self new fileName: aFileName! !

!FileException class methodsFor: 'instance creation' stamp: 'nil'!
signalOnFile: aFile 
	
	(self fileName: aFile basename) signal! !

!FileExists commentStamp: ''!
I am raised on an attempt to create a file or directory over top of an existing file.!
!FileHandle commentStamp: ''!
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 implement the primitives on my class side.!
!FileHandle methodsFor: 'private' stamp: ''!
startUp
	"This functionality is disabled for now, to avoid doing lots of processing
	on start up."
	
	"We're starting up in a new OS process, so the file id will be invalid.
	Try to reopen the file, but fail silently: just leave the id as nil. #isOpen will
	answer false, and we'll raise an error if anyone tries to do IO."
	
	self basicOpen! !

!FileHandle methodsFor: 'public' stamp: ''!
binaryReadStream
	^ (File named: reference fullName) readStream! !

!FileHandle methodsFor: 'public' stamp: ''!
at: index write: buffer startingAt: start count: count
	
	self flag: 'TODO: remove once FileHandles are really used!!'.
	self assureOpen.
	
	File 
		setPosition: id to: index - 1;
		write: id from: buffer startingAt: start count: count! !

!FileHandle methodsFor: 'public' stamp: ''!
open
	self flag: 'TODO: for now we solely rely on the old FileStreams'
	"id := self basicOpen.
	id ifNil: 	[
		reference ifAbsent: [FileDoesNotExist signalWith: reference].
		self error: 'Unable to open file ' , reference printString]"! !

!FileHandle methodsFor: 'public' stamp: ''!
assureOpen
	"Compatibility method to make the FileHandle Tests pass"
	self isOpen ifFalse: [ id := self basicOpen ].! !

!FileHandle methodsFor: 'public' stamp: ''!
at: index read: buffer startingAt: start count: count
	
	self flag: 'TODO: remove once FileHandles are really used!!'.
	self assureOpen.
	
	^ File 
		setPosition: id to: index - 1;
		read: id into: buffer startingAt: start count: count! !

!FileHandle methodsFor: 'finalization' stamp: ''!
register
	"register the instance for proper clreanup on garbage collection"
	^self class register: self! !

!FileHandle methodsFor: 'public' stamp: ''!
truncateTo: anInteger
	File setPosition: id to: anInteger.
	File truncate: id to: anInteger.
	self reopen! !

!FileHandle methodsFor: 'public' stamp: ''!
size
	
	self flag: 'TODO: remove once FileHandles are really used!!'.
	self assureOpen.
	
	^ File sizeOf: id! !

!FileHandle methodsFor: 'public' stamp: ''!
sync
	
	self flag: 'TODO: remove once FileHandles are really used!!'.
	self assureOpen.
	
	File sync: id! !

!FileHandle methodsFor: 'testing' stamp: ''!
isOpen
	^ (File sizeOrNil: id) notNil! !

!FileHandle methodsFor: 'public' stamp: ''!
close
	File close: id.
	id := nil! !

!FileHandle methodsFor: 'public' stamp: ''!
flush
	
	self flag: 'TODO: remove once FileHandles are really used!!'.
	self assureOpen.
	
	File flush: id! !

!FileHandle methodsFor: 'public' stamp: ''!
binaryWriteStream
	^ (File named: reference fullName) writeStream! !

!FileHandle methodsFor: 'public' stamp: ''!
streamError
	reference exists
		ifFalse: [FileDoesNotExistException signalWith: reference].
	self error: 'Unable to open file ' , reference printString! !

!FileHandle methodsFor: 'finalization' stamp: ''!
finalize
	File close: id! !

!FileHandle class methodsFor: 'registry' stamp: ''!
registry
	^Registry ifNil: [Registry := WeakRegistry new]! !

!FileHandle class methodsFor: 'system startup' stamp: ''!
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: 'registry' stamp: ''!
register: aFileHandle
	"properly register the given FileHandle for being closed on garbage collection"
	^self registry add: aFileHandle! !

!FileHandleTest commentStamp: ''!
SUnit tests for file handles, the tests may be found in superclass!
!FileHandleTest methodsFor: 'running' stamp: ''!
createFileSystem
	^ FileSystem store: DiskStore activeClass createDefault! !

!FileList commentStamp: ''!
A FileList is a tool to deal with files.

FileList open				"open FileList"!
!FileList methodsFor: 'file list menu' stamp: ''!
fileListMenu: aMenu
	^ reference
		ifNil: [ self noFileSelectedMenu: aMenu ]
		ifNotNil: [ self fileSelectedMenu: aMenu ]! !

!FileList methodsFor: 'own services' stamp: ''!
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: 'private' stamp: ''!
okHit
	ok := true.
	self directory
		ifNil: [self inform: 'Missing directory']
		ifNotNil: [modalView delete]! !

!FileList methodsFor: 'private' stamp: ''!
postOpen

	reference ifNotNil: [
		self changed: #(openPath) , reference pathSegments. 
	].
! !

!FileList methodsFor: 'initialization' stamp: ''!
dynamicButtonServices
	"Answer services for buttons that may come and go in the button pane, depending on selection"

	^ reference isDirectory 
		ifTrue: [#()]
		ifFalse:
			[ | toReject |
				toReject := self buttonSelectorsToSuppress.
				(self itemsForFile: reference) reject:
					[:svc | toReject includes: svc selector]]! !

!FileList methodsFor: 'own services' stamp: ''!
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: 'utilities' stamp: ''!
addFullPanesTo: window from: aCollection

	aCollection do: [ :each | 
		window addMorph: each first fullFrame: each second ]! !

!FileList methodsFor: 'accessing' stamp: ''!
directory: dir
	^ self reference: dir! !

!FileList methodsFor: 'user interface' stamp: ''!
optionalButtonSpecs: aSpecArray
	optionalButtonSpecs := aSpecArray! !

!FileList methodsFor: 'private' stamp: ''!
put: aText
	"Private - put the supplied text onto the file"

	|  type |
	brevityState == #fullFile 
		ifTrue:[
			Cursor write showWhile: [reference writeStream truncate;nextPutAll: aText asString; close].
			^ true].

	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: ''!
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 binaryReadStreamDo: [:stream |	
		(brevityFlag not or: [(fileSize := stream size) <= 100000]) 
			ifTrue:[
				contents :=   self streamFullContentsFrom: stream.
				brevityState := #fullFile.   "don't change till actually read"
				^ contents].

		"if brevityFlag is true, don't display long files when first selected"
		 first5000 := self streamFirst5000BytesFrom: stream].
	
	contents := '{1}
------------------------------------------
... end of the first 5000 characters.' translated format: {first5000}.
	brevityState := #briefFile.   "don't change till actually read"
	^ contents.
! !

!FileList methodsFor: 'own services' stamp: ''!
serviceViewContents
	"Answer a service for viewing the contents of a file in a workspace"
	
	^ (SimpleServiceEntry 
		provider: self 
		label: 'Open contents' 
		selector: #viewContents)
		description: 'Open a text window whose contents are set to the contents of this file'! !

!FileList methodsFor: 'file list menu' stamp: ''!
suffixOfSelectedFile
	"Answer the file extension of the receiver's selected file"
	^ self class suffixOf: self fullName.! !

!FileList methodsFor: 'private' stamp: ''!
setSelectedDirectoryTo: aFileDirectoryWrapper
	self directory: aFileDirectoryWrapper withoutListWrapper.
	brevityState := #FileList.
	"self addPath: path."
	self changed: #fileList.
	self changed: #contents.
	self changed: #selectedDirectory.! !

!FileList methodsFor: 'accessing' stamp: ''!
getEncoding
	^ fileEncoding
		ifNil: [ 'utf-8' ]
		! !

!FileList methodsFor: 'own services' stamp: ''!
servicesForFolderSelector
	"Answer the ok and cancel servies for the folder selector"

	^ self okayAndCancelServices! !

!FileList methodsFor: 'volume list and pattern' stamp: ''!
veryDeepFixupWith: deepCopier
	super veryDeepFixupWith: deepCopier.
	volumeListIndex := 1.
	self directory: FileSystem disk workingDirectory.
	self updateFileList! !

!FileList methodsFor: 'file menu action' stamp: ''!
getEncodedText

	Cursor read showWhile: [
		self selectEncoding.
		self changed: #contents].
! !

!FileList methodsFor: 'own services' stamp: ''!
viewContentsInWorkspace
	"View the contents of my selected file in a new workspace"

	| aString |
	self reference streamWritable: false do: [ :stream | aString := stream upToEnd ].
	Smalltalk tools workspace
		openContents: aString
		label: 'Workspace from ' , self reference basename! !

!FileList methodsFor: 'accessing' stamp: ''!
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"
	
	self error: 'unknown state ' , brevityState printString! !

!FileList methodsFor: 'file list menu' stamp: ''!
fileContentsMenu: aMenu shifted: shifted
	"Construct aMenu to have items appropriate for the file browser's code pane, given the shift state provided"

	| services |
	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].
		(#('st' 'cs') includes: self suffixOfSelectedFile) ifTrue:
			[services addAll: (self itemsForFile: reference)].

		aMenu 
			addServices: services
			for: self reference
			extraLines: #()].

	aMenu addAllFromPragma: #fileListContentMenu target: self.

	^ aMenu
! !

!FileList methodsFor: 'private' stamp: ''!
isFileSelected
	"return if a file is currently selected"

	^ reference notNil and: [ reference isFile ].! !

!FileList methodsFor: 'private' stamp: ''!
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: 'updating' stamp: ''!
whenTextAccepted: anAnnouncement 
	self updateFileContents ! !

!FileList methodsFor: 'drag''n''drop' stamp: ''!
acceptDroppingMorph: aTransferMorph event: evt inMorph: dest
	| oldEntry destDirectory newEntry response |
	destDirectory := self dropDestinationDirectory: dest event: evt.
	oldEntry := FileSystem disk referenceTo: aTransferMorph passenger.
	newEntry := destDirectory / oldEntry basename.
	oldEntry = newEntry ifTrue: [ "Transcript nextPutAll: 'same as old name'; cr." ^ true ].
	newEntry ifNotNil: [ | msg |
		msg := String streamContents: [ :s |
			s nextPutAll: 'destination file ';
				nextPutAll: newEntry parent fullName;
				nextPutAll: ' exists already,';
				cr;
				nextPutAll: 'and is ';
				nextPutAll: (oldEntry modificationTime < newEntry modificationTime
					ifTrue: [ 'newer' ] ifFalse: [ 'not newer' ]);
				nextPutAll: ' than source file ';
				nextPutAll: oldEntry parent fullName;
				nextPut: $.;
				cr;
				nextPutAll: 'Overwrite file ';
				nextPutAll: newEntry basename;
				nextPut: $?
		].
		response := self confirm: msg.
		response ifFalse: [ ^false ].
	].

   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: 'own services' stamp: ''!
serviceGetHex

	^  (SimpleServiceEntry 
			provider: self 
			label: 'View as hex' 
			selector: #getHex
			description: 'View as hex')
			
! !

!FileList methodsFor: 'morphic ui' stamp: ''!
shoutAboutToStyle: aPluggableShoutMorphOrView 
	^ false! !

!FileList methodsFor: 'user interface' stamp: ''!
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:;
		getIndexSelector: #pattern;		
		searchList: self class searchList;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		yourself! !

!FileList methodsFor: 'menu messages' stamp: ''!
copyName

	listIndex = 0 ifTrue: [^ self].
	Clipboard clipboardText: self fullName asText.
! !

!FileList methodsFor: 'accessing' stamp: ''!
fileListIndex: anInteger
	"Select the file name having the given index, and display its contents."

	| item |
	self okToChange ifFalse: [^ self].
	listIndex := anInteger.
	listIndex = 0 
		ifFalse: [
			item := (list at: anInteger).
			item isDirectory
				ifTrue: [
					listIndex := 0.
					brevityState := #FileList.
					self addPath: item fullName.
					self directory: item ]
				ifFalse: [reference := item]].  "open the file selected"

	brevityState := #needToGetBrief.
	self changed: #fileListIndex.
	self changedContents.
	self updateButtonRow! !

!FileList methodsFor: 'volume list and pattern' stamp: ''!
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: 'initialization' stamp: ''!
updateDirectory
	"directory has been changed externally, by calling directory:.
	Now change the view to reflect the change."
	self changed: #directory.
	self changed: #initialDirectoryList.
	self postOpen.! !

!FileList methodsFor: 'file list menu' stamp: ''!
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 serviceViewContents.
	services add: self serviceViewContentsInWorkspace.
	^ services! !

!FileList methodsFor: 'updating' stamp: ''!
changedContents

	self sourceTextModel setText: self contents.! !

!FileList methodsFor: 'private' stamp: ''!
sortBlock
	"Answer block to decide what order to display the directory entries."

	^ sortBlock ifNil: [ sortBlock := self sortBlockBasename ]! !

!FileList methodsFor: 'drag''n''drop' stamp: ''!
isDirectoryList: aMorph
	^aMorph isKindOf: SimpleHierarchicalListMorph! !

!FileList methodsFor: 'accessing' stamp: ''!
pattern
	^ pattern 
! !

!FileList methodsFor: 'accessing' stamp: ''!
reference
	^ reference! !

!FileList methodsFor: 'own services' stamp: ''!
serviceOkay
	"Answer a service for hitting the okay button"

	^ (SimpleServiceEntry new
		provider: self 
		label: 'Okay' 
		selector: #okHit 
		description: 'Hit here to accept the current selection')
		buttonLabel: 'Ok'! !

!FileList methodsFor: 'private' stamp: ''!
getSelectedFolder
	"Answer the selected folder or nil if dialog was canceled"

	ok ifFalse: [ ^ nil ].
	^ self directory! !

!FileList methodsFor: 'drag''n''drop' stamp: ''!
dragTransferTypeForMorph: aMorph
	^#file! !

!FileList methodsFor: 'file list menu' stamp: ''!
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: 'own services' stamp: ''!
okayAndCancelServices
	"Answer ok and cancel services"

	^ {self serviceOkay. self serviceCancel}! !

!FileList methodsFor: 'accessing' stamp: ''!
doItReceiver
	^ nil! !

!FileList methodsFor: 'initialization' stamp: ''!
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: 'volume list and pattern' stamp: ''!
volumeList
	"Answer the current list of volumes."

	^ volumeList
! !

!FileList methodsFor: 'private' stamp: ''!
cancelHit

	modalView delete.! !

!FileList methodsFor: 'private' stamp: ''!
requestNewFileNameAndSave
	| newName |
	newName := UIManager default request: 'Enter a new file name' initialAnswer: reference fullName.
	newName ifNil: [ ^ self].
	reference := newName asFileReference.
	(reference asFileReference exists) ifTrue:[ ^ self updateFileContents ].
	self put: self sourceTextModel getText asString.
	self updateFileList! !

!FileList methodsFor: 'accessing' stamp: ''!
contents: someContents
	
	contents := someContents! !

!FileList methodsFor: 'file menu action' stamp: ''!
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: 'own services' stamp: ''!
addNewDirectory
	self 
		addNew: 'Directory'
		byEvaluating: [:newName | 
			(self directory / newName ) ensureCreateDirectory ]
! !

!FileList methodsFor: 'accessing' stamp: ''!
doItContext
	^ nil! !

!FileList methodsFor: 'user interface' stamp: ''!
setSortSelector: aByteSymbol 
	self sortBlock: (self perform: aByteSymbol).! !

!FileList methodsFor: 'drag''n''drop' stamp: ''!
dropDestinationDirectory: dest event: evt
	"Answer a FileDirectory representing the drop destination in the directory hierarchy morph dest"
	^ (dest itemFromPoint: evt position) withoutListWrapper! !

!FileList methodsFor: 'volume list and pattern' stamp: ''!
changeDirectoryTo: aFileDirectory
	"Change directory as requested."
	self directory: aFileDirectory.
	self updateDirectory! !

!FileList methodsFor: 'file menu action' stamp: ''!
addNewFile
	self 
		addNew: 'File'
		byEvaluating: [:newName | (self directory / newName) ensureCreateFile ]
! !

!FileList methodsFor: 'drag''n''drop' stamp: ''!
dragPassengerFor: item inMorph: dragSource
	^ item contents copy
! !

!FileList methodsFor: 'private' stamp: ''!
confirmOverwriteOrCreateNewFileOrAbort
	| choice  chooseList |
	chooseList := {'overwrite that file' translated.
	               'choose another name' translated . 
	               'cancel' translated. }.
	choice := UIManager default
		chooseFrom: chooseList
		title: 'Save contents' translated.
	^ choice! !

!FileList methodsFor: 'own services' stamp: ''!
serviceGetEncodedText

	^  (SimpleServiceEntry 
			provider: self 
			label: 'View as encoded text'
			selector: #getEncodedText
			description: 'View as encoded text')

! !

!FileList methodsFor: 'private' stamp: ''!
streamFirst5000BytesFrom: aBinaryReadStream
	^ [ self streamFirst5000BytesWithEncodingFrom: aBinaryReadStream ]
		on: Error
		do: [ :ex |(aBinaryReadStream next: 5000) asString ]! !

!FileList methodsFor: 'file list menu' stamp: ''!
noFileSelectedMenu: aMenu

	^ aMenu
		addServices: self itemsForNoFile 
		for: self
		extraLines: #()
		
! !

!FileList methodsFor: 'file menu action' stamp: ''!
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: 'private' stamp: ''!
sortBlockBasename
	"Answer block to decide what order to display the directory entries."

	^ [ :x :y | |xIsDir|
			((xIsDir := x isDirectory) = y isDirectory) 
				ifTrue: [   x basename <= y basename  ]
				ifFalse: [
					"directories always precede files"
					xIsDir ]]! !

!FileList methodsFor: 'private' stamp: ''!
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: #list.
	self changed: #pattern.
	self grid deselectAll.
	self grid updateList.
	self updateButtonRow! !

!FileList methodsFor: 'private' stamp: ''!
fileEncoding: aByteSymbol 
	fileEncoding := aByteSymbol.
	brevityState := #needToGetBrief.
	self changedContents! !

!FileList methodsFor: 'file list menu' stamp: ''!
itemsForFile: file
	"Answer a list of services appropriate for a file"
	^ (self class itemsForFile: file).! !

!FileList methodsFor: 'file list menu' stamp: ''!
itemsForNoFile

	| services |
	services := OrderedCollection new.
	services addAll: (self itemsForDirectory: (self isFileSelected ifFalse: [ self directory ] ifTrue: [])).
	^ services

		! !

!FileList methodsFor: 'morphic ui' stamp: ''!
morphicView

	^ self morphicViewOnDirectory: self directory! !

!FileList methodsFor: 'user interface' stamp: ''!
optionalButtonSpecs
	^ optionalButtonSpecs! !

!FileList methodsFor: 'private' stamp: ''!
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: #fileListIndex.
	self changed: #contents.
	self changed: #selectedDirectory.
	self changedContents! !

!FileList methodsFor: 'private' stamp: ''!
streamFullContentsFrom: aBinaryReadStream
	^ [ self streamFullContentsWithEncodingFrom: aBinaryReadStream ]
		on: Error
		do: [ :ex | aBinaryReadStream contents asString ]! !

!FileList methodsFor: 'menu messages' stamp: ''!
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 ) includes: selector)
				ifTrue: [self perform: selector]
				ifFalse: [super perform: selector orSendTo: otherTarget]! !

!FileList methodsFor: 'initialization' stamp: ''!
updateButtonRow
	"Dynamically update the contents of the button row, if any."

	self dependents
		detect: [ :m | m isSystemWindow and: [ m model == self ] ]
		ifFound: [ :aWindow | 
			| aRow |
			aRow := aWindow findDeepSubmorphThat: [ :m | m hasProperty: #buttonRow ] ifAbsent: [ ^ self ].
			aRow submorphs size - 1 timesRepeat: [ aRow submorphs last delete ].
			self dynamicButtonServices
				do: [ :service | 
					aRow addMorphBack: (service buttonToTriggerIn: self).
					service addDependent: self ] ]! !

!FileList methodsFor: 'volume list and pattern' stamp: ''!
volumeListIndex
	"Answer the index of the currently selected volume."

	^ volumeListIndex
! !

!FileList methodsFor: 'private' stamp: ''!
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: 'user interface' stamp: ''!
morphicFileContentsPane
	| scrolledText |
	scrolledText := self sourceTextModel newScrolledText
		beWrapped;
		beForSmalltalkComment;
		yourself.
	scrolledText menuProvider: self selector: #fileContentsMenu:shifted:.
	scrolledText announcer when: RubTextAccepted send: #whenTextAccepted: to: self.
	self sourceTextModel setText: self contents.
	^ scrolledText! !

!FileList methodsFor: 'user interface' stamp: ''!
morphicGrid
	grid := FileListGrid new
		parent: self.
	grid
		onSelectionChangeSend: #findFileListIndex: to: self ;
		menu: #fileListMenu  shifted: false.
	^ grid treeMorph
! !

!FileList methodsFor: 'volume list and pattern' stamp: ''!
volumeListIndex: index
	"Select the volume name having the given index."

	| delim path |
	volumeListIndex := index.
	index = 1 
		ifTrue: [self directory: FileSystem disk root ]
		ifFalse: [
			delim := reference fileSystem delimiter.
			path := String streamContents: [:stream |
				2 to: index do: [:i |
					stream nextPutAll: (volumeList at: i) trimBoth.
					i < index ifTrue: [stream nextPut: delim]]]].
	brevityState := #FileList.
	self addPath: path.
	self changed: #fileList.
	self changed: #contents.
	self updateButtonRow! !

!FileList methodsFor: 'modal dialogs' stamp: ''!
morphicViewFolderSelector: aDir
	"Answer a tool that allows the user to select a folder"
	|  window buttonRow fileListTopOffset |
	self directory: aDir.
	self optionalButtonSpecs: self servicesForFolderSelector.
	window := (SystemWindow labelled: aDir fullName) model: self.
	self modalView: window.
	buttonRow := self folderSelectButtonRow.
	self universalButtonServices do: 
			[:service |
				buttonRow addMorphBack: (service buttonToTriggerIn: self)].
	fileListTopOffset := (TextStyle defaultFont pointSize * 2) + 11.
	
	self addFullPanesTo: window from: {
		{self morphicDirectoryTreePane.  (LayoutFrame identity topOffset: fileListTopOffset) }.
		{buttonRow  . (LayoutFrame identity bottomFraction: 0; bottomOffset: fileListTopOffset-3)}.
	}.
	
	self postOpen.
	^ window ! !

!FileList methodsFor: 'accessing' stamp: ''!
directory
	
	^ reference isFile 
		ifTrue: [ reference parent ]
		ifFalse: [ reference ]! !

!FileList methodsFor: 'private' stamp: ''!
directoriesFor: directory
	"item may be file directory or server directory"
	| entries |
	entries := directory directories.
	dirSelectionBlock ifNotNil:[ entries := entries select: dirSelectionBlock ].
	^entries! !

!FileList methodsFor: 'file menu action' stamp: ''!
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 changedContents].
! !

!FileList methodsFor: 'morphic ui' stamp: ''!
morphicViewOnDirectory: aFileDirectory

	^ self morphicViewOnDirectory: aFileDirectory baseLabel: ''! !

!FileList methodsFor: 'private' stamp: ''!
selectedDirectory
	^ self directory! !

!FileList methodsFor: 'private' stamp: ''!
sortBlock: aBlockClosure 
	sortBlock := aBlockClosure.
	self updateFileList! !

!FileList methodsFor: 'accessing' stamp: ''!
fileListIndex
	"Answer the index of the currently selected file."
	^ listIndex! !

!FileList methodsFor: 'private' stamp: ''!
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.! !

!FileList methodsFor: 'file menu action' stamp: ''!
addNew: aString byEvaluating: aBlock
	"A parameterization of earlier versions of #addNewDirectory and
	#addNewFile.  Fixes the bug in each that pushing the cancel button
	in the FillInTheBlank dialog gave a walkback."

	| response newName index |
	self okToChange ifFalse: [^ self].
	(response := UIManager default
						request: ('New {1} Name?' translated format: {aString translated})
						initialAnswer: ('{1}Name' translated format: {aString translated}))
		isEmptyOrNil ifTrue: [^ self].
	newName := response asFileName.
	Cursor wait showWhile: [
		aBlock value: newName].
	self updateFileList.
	self updateDirectory.
	list ifNotNil:[
	index := list indexOf: newName.
	index = 0 ifTrue: [
		index := list findFirst: [:line | line basename endsWith: newName]].
	self fileListIndex: index.]
! !

!FileList methodsFor: 'own services' stamp: ''!
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].
	
	(ImageMorph withForm: image) openInWorld! !

!FileList methodsFor: 'own services' stamp: ''!
serviceRenameFile

	^ (SimpleServiceEntry 
		provider: self 
		label: 'Rename' 
		selector: #renameFile 
		description: 'Rename file')! !

!FileList methodsFor: 'private' stamp: ''!
streamFirst5000BytesWithEncodingFrom: aBinaryReadStream
	^ (ZnCharacterReadStream on: aBinaryReadStream encoding: self getEncoding) next: 5000! !

!FileList methodsFor: 'own services' stamp: ''!
deleteDirectory
	self basicDeleteDirectory.
	self updateFileList.
	self updateDirectory.
! !

!FileList methodsFor: 'private' stamp: ''!
findFileListIndex: aMorphTreeSelectionChanged 
	| node selectedPath |
	
	selectedPath := aMorphTreeSelectionChanged selection selectedNodePath.
	selectedPath ifNil: [^ self].
	node := selectedPath first.
	self fileListIndex: (self fileList indexOf: node item).
! !

!FileList methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	ok := false.
	sourceTextModel := RubScrolledTextModel new interactionModel: self.
	dirSelectionBlock := [ :dirName | true].
	baseLabel := ''.
	configuredServices := OrderedCollection new.
	self directory: FileSystem workingDirectory.! !

!FileList methodsFor: 'user interface' stamp: ''!
morphicDirectoryTreePane

	^self morphicDirectoryTreePaneFiltered: #initialDirectoryList
! !

!FileList methodsFor: 'accessing' stamp: ''!
fileSystem
	^ reference 
		ifNil: [ FileSystem disk ]
		ifNotNil: [ reference fileSystem ]! !

!FileList methodsFor: 'own services' stamp: ''!
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: 'accessing' stamp: ''!
getListIndex
	^ list indexOf: reference ifAbsent: [ 0 ]! !

!FileList methodsFor: 'initialization' stamp: ''!
universalButtonServices
	"Answer the services to be reflected in the receiver's buttons"

	^ self optionalButtonSpecs! !

!FileList methodsFor: 'own services' stamp: ''!
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: 'accessing' stamp: ''!
pattern: aStringOrNil
	pattern := aStringOrNil
		ifNotNil: [ :aString | 
			aString asString trimBoth
				ifEmpty: [ nil ]
				ifNotEmpty: [ :trimmed | trimmed ] ].
	self updateFileList! !

!FileList methodsFor: 'initialization' stamp: ''!
labelString
	reference ifNil: [ ^ '[]' ].
	^ baseLabel, reference basename contractTo: 50! !

!FileList methodsFor: 'private' stamp: ''!
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 ifNil: [ ^ '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: [ '{1}
------------------------------------------
... end of the first 5000 characters.' translated format: {hexData}
			]
		ifFalse: [ hexData ]! !

!FileList methodsFor: 'initialization' stamp: ''!
folderSelectButtonRow
	"Answer the button row used for folder selection"

	| aRow |
	aRow := AlignmentMorph newRow beSticky.
	aRow color: Color transparent.
	aRow clipSubmorphs: true.
	aRow layoutInset: 0@0; cellInset: 6.
	aRow setNameTo: 'buttons'.
	^ aRow! !

!FileList methodsFor: 'file list menu' stamp: ''!
itemsForDirectory: dir 
	| services |
	services := OrderedCollection new.
	dir ifNotNil: [
		services
			addAll: (self class itemsForDirectory: dir).
		services ifNotEmpty: [services last useLineAfter] ].
	services add: self serviceAddNewFile.
	services add: self serviceAddNewDirectory.
	services addAll: self configuredServices.
	^ services! !

!FileList methodsFor: 'morphic ui' stamp: ''!
morphicViewOnFile: aFile
	| window fileListBottom midLine fileListTopOffset buttonPane fileContentsView |
	window := (SystemWindow labelled: self labelString) model: self.
	fileListTopOffset := TextStyle defaultFont pointSize * 2 + 11.
	fileListBottom := 0.4.
	midLine := 0.2.
	buttonPane := self optionalButtonRow addMorph: self morphicPatternPane.
	self
		addFullPanesTo: window
		from:
			{{self morphicDirectoryTreePane.
			(LayoutFrame identity rightFraction: midLine )}.
			{buttonPane.
			(LayoutFrame identity leftFraction: midLine ; bottomFraction: 0 ; bottomOffset: fileListTopOffset - 3)}.
			{self morphicFileListPane.
			(LayoutFrame identity leftFraction: midLine ; bottomFraction: fileListBottom ; topOffset: fileListTopOffset)}.
			{(fileContentsView := self morphicFileContentsPane).
			(LayoutFrame identity leftFraction: midLine ; topFraction: fileListBottom)}.
			}.
	contents
		ifNotNil: [ fileContentsView setText: contents asText.
			fileContentsView hasUnacceptedEdits: true ].
	self postOpen.
	^ window! !

!FileList methodsFor: 'initialization' stamp: ''!
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: 'drag''n''drop' stamp: ''!
wantsDroppedMorph: aTransferMorph event: evt inMorph: dest
	| retval |
	retval := (aTransferMorph isTransferable)
		and: [ (aTransferMorph dragTransferType == #file)
				and: [ self isDirectoryList: dest ]].
	^retval! !

!FileList methodsFor: 'user interface' stamp: ''!
grid
	^ grid ifNil: [ grid := self morphicGrid ]! !

!FileList methodsFor: 'private' stamp: ''!
streamFullContentsWithEncodingFrom: aBinaryReadStream
	^ (ZnCharacterReadStream on: aBinaryReadStream encoding: self getEncoding) upToEnd! !

!FileList methodsFor: 'accessing' stamp: ''!
fileList
	"Answer the list of files in the current volume."

	^ list! !

!FileList methodsFor: 'private' stamp: ''!
knownEncodingIdentifiers
	^ ZnCharacterEncoder knownEncodingIdentifiers sort! !

!FileList methodsFor: 'updating' stamp: ''!
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: 'own services' stamp: ''!
viewContents
	"View the contents of my selected file in a new text window"

	| aString |
	self reference streamWritable: false do: [ :stream | aString := stream upToEnd ].
	UIManager default edit: aString label: 'Contents from ' , self reference basename! !

!FileList methodsFor: 'volume menu' stamp: ''!
volumeMenu: aMenu
	aMenu
		add: 'Delete directory...' translated
		selector: #deleteDirectory.
	aMenu addLine.
	aMenu
		addServices: (self itemsForDirectory: self directory)
		for: self
		extraLines: #().
	^aMenu.! !

!FileList methodsFor: 'own services' stamp: ''!
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: 'private' stamp: ''!
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: ''!
truncatedAndOverwriteFilecontents
	self put: self sourceTextModel getText asString! !

!FileList methodsFor: 'own services' stamp: ''!
serviceCopyName

	^ (SimpleServiceEntry 
		provider: self 
		label: 'Copy name to clipboard' 
		selector: #copyName 
		description: 'Copy name to clipboard' )! !

!FileList methodsFor: 'initialization' stamp: ''!
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: #pattern.
	self changed: #selectedDirectory.
! !

!FileList methodsFor: 'initialization' stamp: ''!
initialDirectoryList

	| dirList |
	dirList := self fileSystem root directories collect: [ :each |
		FileDirectoryWrapper with: each name: each basename model: self].
	
	dirList isEmpty ifTrue:[
		dirList := Array with: (FileDirectoryWrapper 
			with: self fileSystem workingDirectory
			name: self fileSystem workingDirectory basename 
			model: self)].
		
	^dirList! !

!FileList methodsFor: 'morphic ui' stamp: ''!
morphicViewOnDirectory: aFileDirectory baseLabel: aString

	^ self
		contents: nil;
		morphicViewOnFile: aFileDirectory! !

!FileList methodsFor: 'private' stamp: ''!
fullName
	"Answer the full name for the currently selected file; answer nil if no file is selected."
	^ reference fullName! !

!FileList methodsFor: 'file list' stamp: ''!
readStream
	"Answer a read-only stream on the selected file. For the various stream-reading services."
	^ self reference readStream! !

!FileList methodsFor: 'accessing' stamp: ''!
baseLabel: aString 

	baseLabel := aString! !

!FileList methodsFor: 'user interface' stamp: ''!
sourceTextModel
	^ sourceTextModel! !

!FileList methodsFor: 'user interface' stamp: ''!
morphicDirectoryTreePaneFiltered: aSymbol
	^(SimpleHierarchicalListMorph 
		on: self
		list: aSymbol
		selected: #selectedDirectory
		changeSelected: #selectedDirectory:
		menu: #volumeMenu:)
			autoDeselect: false;
			enableDrag: false;
			enableDrop: true;
			yourself
		
! !

!FileList methodsFor: 'user interface' stamp: ''!
morphicFileListPane
	^ grid ifNil: [ grid := self morphicGrid ].
! !

!FileList methodsFor: 'accessing' stamp: ''!
reference: dir
	| tmpReference |
	"Set the path of the volume to be displayed."
	self okToChange ifFalse: [^ self].
	
	tmpReference := dir 
		ifNotNil: [ :d| d asFileReference]
		ifNil: [ FileSystem disk workingDirectory ].
	tmpReference isReadable 
		ifFalse: [ ^ self inform: ('Cannot read {1}' translated format: { tmpReference})].
	reference := tmpReference.
	
	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: 'file menu action' stamp: ''!
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 changedContents
			 ]! !

!FileList methodsFor: 'own services' stamp: ''!
basicDeleteDirectory
	"Remove the currently selected directory"
	reference entries isEmpty
		 ifFalse:[^self inform:'Directory must be empty'].
	
	(self confirm: 'Really delete ' , reference basename , '?') 
		ifFalse: [^ self].
	
	self volumeListIndex: self volumeListIndex-1.

	reference delete.
	self directory: reference parent! !

!FileList methodsFor: 'private' stamp: ''!
updateFileContents
	| choice |
	choice := self confirmOverwriteOrCreateNewFileOrAbort.
	
	choice = 1 ifTrue:[ self truncatedAndOverwriteFilecontents].
	choice = 2 ifTrue:[ self requestNewFileNameAndSave].
! !

!FileList methodsFor: 'own services' stamp: ''!
serviceDeleteFile

	^ (SimpleServiceEntry 
		provider: self 
		label: 'Delete' 
		selector: #deleteFile)
		description: 'Delete the seleted item'! !

!FileList methodsFor: 'accessing' stamp: ''!
configuredServices

	^ configuredServices! !

!FileList methodsFor: 'private' stamp: ''!
filesMatching: aPattern
	"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 aRegex |
	files :=  [self directory files] on:DirectoryDoesNotExist do:[#()].
	aPattern ifNil:[^files].

	aRegex := aPattern asRegex.
	^ files select: [:entry | (aRegex search: entry basename)]! !

!FileList methodsFor: 'private' stamp: ''!
selectEncoding
	"self new selectEncoding"

	| ui |
	ui := ListDialogWindow new
		getList: [ :r | self knownEncodingIdentifiers select: [ :e | r search: e ] ];
		displayBlock: [ :e | e ];
		initialAnswer: '';
		acceptNewEntry: true;
		title: 'Encoding' translated;
		yourself.
	(ui chooseFromOwner: self currentWorld) ifNotNil: [ :encoding | self fileEncoding: encoding ]! !

!FileList methodsFor: 'private' stamp: ''!
defaultContents

	contents := list
		ifNil: [ String new ]
		ifNotNil: [ 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: ''!
modalView: aSystemWindowOrSuch

	modalView := aSystemWindowOrSuch! !

!FileList class methodsFor: 'utilities' stamp: ''!
itemsForFile: file
	"Answer a list of services appropriate for a file of the given full name"

	^ FileServices itemsForFile: file fullName! !

!FileList class methodsFor: 'accessing' stamp: ''!
searchList
	^ searchList ifNil: [ searchList := OrderedCollection new ].! !

!FileList class methodsFor: 'morphic ui' stamp: ''!
openMorphOn: aFileStream editString: editString 
	"Open a morphic view of a FileList on the given file."
	^ (self new setFileStream: aFileStream)
		contents: editString;
		morphicViewOnFile: aFileStream fullName asFileReference! !

!FileList class methodsFor: 'instance creation' stamp: ''!
newOnDirectory: aFileReference baseLabel: aTitle
	
	^ self newOnDirectory: aFileReference baseLabel: aTitle contents: nil! !

!FileList class methodsFor: 'morphic ui' stamp: ''!
open
	"Open a view of an instance of me on the default directory."
	"FileList open openInWorld"
	^ self new morphicView openInWorld! !

!FileList class methodsFor: 'morphic ui' stamp: ''!
openOn: aFileReference
	^self openOn: aFileReference titled: '' ! !

!FileList class methodsFor: 'utilities' stamp: ''!
addFullPanesTo: window from: aCollection

	aCollection do: [ :each | 
		window addMorph: each first fullFrame: each second ]! !

!FileList class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallOpenIcon! !

!FileList class methodsFor: 'instance creation' stamp: ''!
newOnDirectory: aFileReference baseLabel: aTitle contents: someContents
	
	^ self new
			directory: aFileReference;
			baseLabel: aTitle;
			contents: someContents;
			yourself! !

!FileList class methodsFor: 'morphic ui' stamp: ''!
morphicViewOnDirectory: aFileDirectory

	^ self 
		morphicViewOnFile: aFileDirectory 
		contents: nil
		fileList: (self new directory: aFileDirectory).! !

!FileList class methodsFor: 'morphic ui' stamp: ''!
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.
			(LayoutFrame identity rightFraction: midLine)}.
			{buttonPane.
			(LayoutFrame identity leftFraction: midLine; bottomFraction: 0;  bottomOffset: fileListTopOffset - 3)}.
			
			{aFileList morphicFileListPane.
			(LayoutFrame identity leftFraction: midLine; bottomFraction: fileListBottom; topOffset: fileListTopOffset)}.
			
			{(fileContentsView := aFileList morphicFileContentsPane).
			(LayoutFrame identity leftFraction: midLine; topFraction: fileListBottom)}}.
	contents
		ifNotNil: [ fileContentsView editString: contents.
			fileContentsView hasUnacceptedEdits: true ].
	aFileList postOpen.
	^ window! !

!FileList class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]" 
	registry register: self as: #fileList
! !

!FileList class methodsFor: 'utilities' stamp: ''!
itemsForDirectory: aFileDirectory
	"Answer a list of services appropriate when no file is selected."

	^ FileServices itemsForDirectory: aFileDirectory! !

!FileList class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #'File Browser')
		parent: #SystemTools;
		order: 2;
		action: [ self open ];
		help: 'Browse the files present on your system.';
		icon: self taskbarIcon! !

!FileList class methodsFor: 'morphic ui' stamp: ''!
openOn: aFileReference titled: aTitle
	
	| listView |
	listView := self newOnDirectory: aFileReference baseLabel: aTitle.
	listView morphicView openInWorld.
	^ listView! !

!FileList class methodsFor: 'menu' stamp: ''!
contentMenu: aBuilder
	<contextMenu>
	<fileListContentMenu>
	
	(aBuilder item: #'Find...' translated)
		keyText: 'f';
		selector: #find;
		iconName: #smallFindIcon.
	(aBuilder item: #'Find again' translated)
		keyText: 'g';
		selector: #findAgain;
		iconName: #smallFindIcon.
	(aBuilder item: #'Set search string' translated)
		keyText: 'h';
		selector: #setSearchString;
		withSeparatorAfter.
		
	(aBuilder item: #'Undo' translated)
		keyText: 'z';
		selector: #undo;
		iconName: #smallUndoIcon;
		withSeparatorAfter.
		
	(aBuilder item: #'Copy' translated)
		keyText: 'c';
		selector: #copySelection;
		iconName: #smallCopyIcon.
	(aBuilder item: #'Cut' translated)
		keyText: 'x';
		selector: #cut;
		iconName: #smallCutIcon.
	(aBuilder item: #'Paste' translated)
		keyText: 'v';
		selector: #paste;
		iconName: #smallPasteIcon.
	(aBuilder item: #'Paste Recent' translated)
		selector: #pasteRecent;
		iconName: #smallPasteIcon;
		withSeparatorAfter .
		
	(aBuilder item: #'Do it' translated)
		keyText: 'd';
		selector: #doIt;
		iconName: #smallDoItIcon.
	(aBuilder item: #'Print it' translated)
		keyText: 'p';
		selector: #printIt;
		iconName: #smallPrintItIcon.
	(aBuilder item: #'Inspect it' translated)
		keyText: 'i';
		selector: #inspectIt;
		iconName: #smallInspectItIcon.
	(aBuilder item: #'FileIn selection' translated)
		keyText: 'G';
		selector: #fileItIn;
		withSeparatorAfter.
		
	(aBuilder item: #'Accept' translated)
		keyText: 's';
		selector: #accept;
		iconName: #smallOkIcon.
	(aBuilder item: #'Cancel' translated)
		keyText: 'l';
		selector: #cancel;
		iconName: #smallCancelIcon;
		withSeparatorAfter.
! !

!FileList class methodsFor: 'morphic ui' stamp: ''!
openEditorOn: aFileStream editString: editString 
	"Open an editor on the given FileStream."
	^ (self openMorphOn: aFileStream editString: editString) openInWorld! !

!FileList class methodsFor: 'utilities' stamp: ''!
suffixOf: aName
	"Answer the file extension of the given file"
	^ aName
		ifNil: ['']
		ifNotNil: [ aName asFileReference extension asLowercase]! !

!FileList class methodsFor: 'instance creation' stamp: ''!
newOnDirectory: aFileReference
	
	^ self newOnDirectory: aFileReference baseLabel: ''! !

!FileListGrid commentStamp: ''!
A grid for a list of files!
!FileListGrid methodsFor: 'user interface' stamp: ''!
treeMorph
	treeMorph ifNil: [ 
		treeMorph := (self treeMorphClass on: self)
			columns: {
				MorphTreeColumn new
					rowMorphGetSelector: #fileName;
					startWidth: 300;
					headerButtonLabel: 'File name' translated 
						font: nil 
						target: self parent 
						actionSelector: #setSortSelector: arguments: { #sortBlockBasename }.
				MorphTreeColumn new
					rowMorphGetSelector: #fileSize;
					headerButtonLabel: 'Size' translated font: nil 
						target: self parent 
						actionSelector: #setSortSelector: arguments: { #sortBlockFilesize }.
				MorphTreeColumn new
					rowMorphGetSelector: #modificationDate;
					headerButtonLabel: 'Last mod.' translated font: nil  
						target: self parent 
						actionSelector: #setSortSelector: arguments: { #sortBlockTimestamp }.
				MorphTreeColumn new
					rowMorphGetSelector: #filePermissions;
					headerButtonLabel: 'Permissions' translated font: nil  
						target: self parent 
						actionSelector: #setSortSelector: arguments: { #sortBlockPermissions }}.
		treeMorph 
			hResizing: #spaceFill; 
			vResizing: #spaceFill; 
			columnInset: 3; 
			getMenuSelector: #fileListMenu:;
			makeLastColumnUnbounded.
		].

	^ treeMorph buildContents ! !

!FileListGrid methodsFor: 'accessing' stamp: ''!
parent: aFileList
	parent := aFileList! !

!FileListGrid methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!FileListGrid methodsFor: 'accessing' stamp: ''!
rootNodeClassFromItem: anItem
	^ FileListGridNode! !

!FileListGrid methodsFor: 'accessing' stamp: ''!
rootItems
	^ parent fileList! !

!FileListGrid methodsFor: 'menus' stamp: ''!
fileListMenu: aMenuMorph 
	^ parent fileListMenu: aMenuMorph! !

!FileListGridNode commentStamp: ''!
A node in the file list grid!
!FileListGridNode methodsFor: 'user interface' stamp: ''!
filePermissions
	^ self theme newTextIn: self text: item permissions asString! !

!FileListGridNode methodsFor: 'user interface' stamp: ''!
modificationDate
	^ self theme newTextIn: self text: item modificationTime asString! !

!FileListGridNode methodsFor: 'user interface' stamp: ''!
fileName
	^ self theme newTextIn: self text: item basename! !

!FileListGridNode methodsFor: 'user interface' stamp: ''!
fileSize
	^ self theme newTextIn: self text: item humanReadableSize asString! !

!FileLocator commentStamp: ''!
I am a late-bound reference. I refer to a file or directory in relation to a well-known location on the filesystem, called an origin. When asked to perform a concrete operation, I look up the current location of my origin, and resolve my path against it. To add your own origin(s), see FileSystemResolver.

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: 'error handling' stamp: ''!
doesNotUnderstand: aMessage
	"Redirect message to the resolved version of this FileLocator.
	If FileReference won't understand the message send a normal DNU."

	| resolved |
	
	resolved := self resolve.
	(resolved respondsTo: aMessage selector)
		ifTrue: [ ^ resolved perform: aMessage selector withArguments: aMessage arguments ].
	
	^ super doesNotUnderstand: aMessage.! !

!FileLocator methodsFor: 'streams' stamp: ''!
binaryReadStream
	^ self resolve binaryReadStream! !

!FileLocator methodsFor: 'comparing' stamp: ''!
= other
	^ self species = other species
		and: [origin = other origin
			and: [path = other path]]! !

!FileLocator methodsFor: 'comparing' stamp: ''!
hash
	^ origin hash bitXor: path hash! !

!FileLocator methodsFor: 'converting' stamp: ''!
asFileReference
	^ self resolve! !

!FileLocator methodsFor: 'streams' stamp: ''!
writeStream
	^ self resolve writeStream! !

!FileLocator methodsFor: 'accessing' stamp: ''!
absolutePath
	"Return the absolute path"
	^ self resolve path! !

!FileLocator methodsFor: '*System-Settings-Core' stamp: ''!
acceptSettings: aVisitor
	^ aVisitor visitFileLocator: self! !

!FileLocator methodsFor: 'testing' stamp: ''!
isAbsolute
	^ true! !

!FileLocator methodsFor: 'navigating' stamp: ''!
resolve
	^ (Resolver resolve: origin) resolve: path! !

!FileLocator methodsFor: 'converting' stamp: ''!
asAbsolute
	^ self! !

!FileLocator methodsFor: 'printing' stamp: ''!
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: 'navigating' stamp: ''!
resolveString: aString
	| filesystem thePath |
	filesystem := (Resolver resolve: origin) fileSystem.
	thePath := filesystem pathFromString: aString.
	^ self withPath: (path resolvePath: thePath)! !

!FileLocator methodsFor: 'accessing' stamp: ''!
fullPath
	^ self resolve path! !

!FileLocator methodsFor: 'accessing' stamp: ''!
origin
	^ origin! !

!FileLocator methodsFor: 'operations' stamp: ''!
renameTo: newBasename
	
	| result |
	result := self resolve renameTo: newBasename.
	path size > 0
		ifTrue: [ path basename: newBasename ]
		ifFalse: [ path := result path ]! !

!FileLocator methodsFor: 'converting' stamp: ''!
asPath
	"Answer the receiver's path"

	^self resolve asPath! !

!FileLocator methodsFor: 'initialization' stamp: ''!
initializeWithOrigin: aSymbol path: aPath
	self initialize.
	origin := aSymbol.
	path := aPath.! !

!FileLocator methodsFor: 'streams' stamp: ''!
binaryWriteStream
	"Answer a binary write stream on the receiver"

	^ self resolve binaryWriteStream! !

!FileLocator methodsFor: 'testing' stamp: ''!
isRelative
	^ false! !

!FileLocator methodsFor: 'streams' stamp: ''!
readStream
	^ self resolve readStream! !

!FileLocator methodsFor: 'copying' stamp: ''!
copyWithPath: newPath
	^ self class origin: origin path: newPath! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
L
	^ self driveNamed: #L! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
S
	^ self driveNamed: #S! !

!FileLocator class methodsFor: 'unix-origins' stamp: ''!
userData
	^ self origin: #userData! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
F
	^ self driveNamed: #F! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
H
	^ self driveNamed: #H! !

!FileLocator class methodsFor: 'origins' stamp: ''!
root
	^ FileSystem disk root! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
K
	^ self driveNamed: #K! !

!FileLocator class methodsFor: 'flushing' stamp: ''!
flushCaches
	Resolver flushCaches! !

!FileLocator class methodsFor: 'origins' stamp: ''!
workingDirectory
	^ FileSystem disk referenceTo: RelativePath new! !

!FileLocator class methodsFor: 'origins' stamp: ''!
home
	^ self origin: #home! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
U
	^ self driveNamed: #U! !

!FileLocator class methodsFor: 'adding' stamp: ''!
addResolver: aResolver
	Resolver addResolver: aResolver! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
C
	^ self driveNamed: #C! !

!FileLocator class methodsFor: 'mac-origins' stamp: ''!
systemApplicationSupport
	^ self origin: #systemApplicationSupport! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
Q
	^ self driveNamed: #Q! !

!FileLocator class methodsFor: 'class initialization' stamp: ''!
initialize
	"FileLocator is needed to initialize SystemSettingsPersistence (call to FileLocator>>#preferences),
	and could be useful for other classes.
	Let initialize FileLocator before other standard system classes."
	SessionManager default 
		registerSystemClassNamed: self name atPriority: 90.
	self startUp: true! !

!FileLocator class methodsFor: 'mac-origins' stamp: ''!
userApplicationSupport
	^ self origin: #userApplicationSupport! !

!FileLocator class methodsFor: 'origins' stamp: ''!
image
	^ self origin: #image! !

!FileLocator class methodsFor: 'origins' stamp: ''!
desktop
	^ self origin: #desktop! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
T
	^ self driveNamed: #T! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
E
	^ self driveNamed: #E! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
A
	^ self driveNamed: #A! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
Z
	^ self driveNamed: #Z! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
P
	^ self driveNamed: #P! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
driveNamed: driveName
	^ FileReference fileSystem: (FileSystem disk) path: Path / (driveName, ':')! !

!FileLocator class methodsFor: 'instance creation' stamp: ''!
fromPath: aPath ifNone: notFoundBlock
	"Returns a file locator if aPath is a reference to a supported origin or is a child of an origin.
	If no locator matches, return the result of the evaluation of notFoundBlock.
	Locators are sorted so that the deepest matching origin path is returned.
	Ex: '/Users/me/Documents/foo.txt' will return a locator 
		with #documents origin (path /Users/me/Documents) and not #home (path /Users/me).
	Should not be called direcly. Prefer the use of Path or String>>#asFileLocatorOrReference. "

	| locators locatorsPaths |
	locators := self supportedOrigins
		collect: [ :origin | self origin: origin ]
		as: OrderedCollection.
	locatorsPaths := (locators collect: [ :e | e -> e asPath ]) asDictionary.
	(locators sort:	[ :a :b | (locatorsPaths at: b) <= (locatorsPaths at: a) ])
		do: [ :locator | 
			((locatorsPaths at: locator) = aPath or: [ (locatorsPaths at: locator) containsPath: aPath ])
				ifTrue: [ ^ locator resolve: (aPath relativeToPath: (locatorsPaths at: locator)) ] ].
	^ notFoundBlock value! !

!FileLocator class methodsFor: 'origins' stamp: ''!
vmDirectory
	^ self origin: #vmDirectory! !

!FileLocator class methodsFor: 'origins' stamp: ''!
documents
	^ self origin: #documents! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
R
	^ self driveNamed: #R! !

!FileLocator class methodsFor: 'mac-origins' stamp: ''!
userLibrary
	^ self origin: #userLibrary! !

!FileLocator class methodsFor: 'origins' stamp: ''!
cwd
	^ self workingDirectory! !

!FileLocator class methodsFor: 'origins' stamp: ''!
cache
	^ self origin: #cache! !

!FileLocator class methodsFor: 'origins' stamp: ''!
changes
	^ self origin: #changes! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
Y
	^ self driveNamed: #Y! !

!FileLocator class methodsFor: 'origins' stamp: ''!
downloads
	^ self origin: #downloads! !

!FileLocator class methodsFor: 'origins' stamp: ''!
localDirectory
	^ self origin: #localDirectory! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
D
	^ self driveNamed: #D! !

!FileLocator class methodsFor: 'mac-origins' stamp: ''!
systemLibrary
	^ self origin: #systemLibrary! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
W
	^ self driveNamed: #W! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
J
	^ self driveNamed: #J! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
V
	^ self driveNamed: #V! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
M
	^ self driveNamed: #M! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
X
	^ self driveNamed: #X! !

!FileLocator class methodsFor: 'accessing' stamp: ''!
supportedOrigins
	| origins current |
	origins := IdentitySet new.
	current := Resolver.
	[current notNil] whileTrue:
		[origins addAll: current supportedOrigins.
		current := current next].
	^ origins! !

!FileLocator class methodsFor: 'origins' stamp: ''!
vmBinary
	^ self origin: #vmBinary! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
O
	^ self driveNamed: #O! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
I
	^ self driveNamed: #I! !

!FileLocator class methodsFor: 'instance creation' stamp: ''!
origin: aSymbol 
	^ self origin: aSymbol path: Path workingDirectory! !

!FileLocator class methodsFor: 'origins' stamp: ''!
temp
	^ self origin: #temp! !

!FileLocator class methodsFor: 'instance creation' stamp: ''!
fromString: aString ifNone: notFoundBlock
	"Returns a file locator if aString converted as path is a reference to a supported origin or is a child of an origin.
	If no locator matches, return the result of the evaluation of notFoundBlock.
	Should not be called direcly. Prefer the use of Path or String>>#asFileLocatorOrReference "
	
	^ self fromPath: aString asPath ifNone: notFoundBlock! !

!FileLocator class methodsFor: 'instance creation' stamp: ''!
origin: aSymbol path: aPath
	^ self basicNew 
			initializeWithOrigin: aSymbol path: aPath! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
B
	^ self driveNamed: #B! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
G
	^ self driveNamed: #G! !

!FileLocator class methodsFor: 'windows-origins' stamp: ''!
N
	^ self driveNamed: #N! !

!FileLocator class methodsFor: 'system startup' stamp: ''!
startUp: resuming
	resuming
		ifFalse: [ ^ self ].
	Resolver := InteractiveResolver new.
	Resolver addResolver: SystemResolver new.
	Resolver addResolver: PlatformResolver forCurrentPlatform! !

!FileLocator class methodsFor: 'origins' stamp: ''!
preferences
	^ self origin: #preferences! !

!FileLocator class methodsFor: 'origins' stamp: ''!
imageDirectory
	^ self origin: #imageDirectory! !

!FileLocatorStoredSetting commentStamp: ''!
I am responsible for storing information about FileLocator objects.!
!FileLocatorStoredSetting methodsFor: 'accessing' stamp: ''!
origin: anObject
	origin := anObject! !

!FileLocatorStoredSetting methodsFor: 'accessing' stamp: ''!
pathSegments: anObject
	pathSegments := anObject! !

!FileLocatorStoredSetting methodsFor: 'accessing' stamp: ''!
realValue
	^ FileLocator origin: origin path: (RelativePath withAll: pathSegments)! !

!FileLocatorTest commentStamp: ''!
SUnit test for FileLocator!
!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testCommaAddsExtension

	locator := FileLocator image / 'griffle'.
	self assert: (locator , 'plonk') basename equals: 'griffle.plonk'! !

!FileLocatorTest methodsFor: 'resolution tests' stamp: ''!
testResolveAbsoluteReference
	| result reference |
	locator := FileLocator image / 'plonk'.
	reference := FileSystem memory / 'griffle'.
	result := locator resolve: reference.
	self assert: result identicalTo: reference! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testIsRelative
	locator := FileLocator image.
	self deny: locator isRelative! !

!FileLocatorTest methodsFor: 'tests' stamp: ''!
testIfAbsent
	| reference |
	reference := FileLocator temp / 'plonk'.
	reference ensureCreateFile.
	[ reference ifAbsent: [ :file | self fail ].
	reference delete.
	self assert: (reference ifAbsent: [ 'plonk' ]) equals: 'plonk' ]
		ensure: [ reference ensureDelete ]! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testAsAbsolute
	locator := FileLocator image.
	self assert: locator asAbsolute equals: locator! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testSlash
	locator := FileLocator image / 'griffle'.
	self assert: locator equals: (FileLocator image / 'griffle')! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testEqual
	| a b |
	a := FileLocator image.
	b := FileLocator image.
	self deny: a identicalTo: b.
	self assert: a equals: b! !

!FileLocatorTest methodsFor: 'tests' stamp: ''!
testIfExists
	| reference |
	reference := FileLocator temp / 'plonk'.
	reference ensureCreateFile.
	[ self assert: (reference ifExists: [ :file | file basename ]) equals: 'plonk'.
	reference delete.
	reference ifExists: [ :file | self fail ] ]
		ensure: [ reference ensureDelete ]! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testExtension
	locator := FileLocator image, 'bak'.
	self assert: (locator basename endsWith: '.bak')! !

!FileLocatorTest methodsFor: 'resolution tests' stamp: ''!
testResolvePath
	| result path |
	locator := FileLocator image / 'plonk'.
	result := locator resolve: (Path * 'griffle').
	path := (Path * 'plonk') / 'griffle'.
	self assert: result class equals: locator class.
	self assert: result origin equals: locator origin.
	self assert: result path equals: path! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testWithExtensionReplacesExtension
	locator := FileLocator image / 'griffle.nurp'.
	self assert: (locator withExtension: 'plonk') basename equals: 'griffle.plonk'! !

!FileLocatorTest methodsFor: 'creation tests' stamp: ''!
testFromPathReturnsBlockValueIfPathNotPartOfAnOrigin
	| path |
	path := '/foo' asFileReference path.
	
	locator := FileLocator fromPath: path ifNone: [ nil ].
	
	self
		assert: locator
		equals: nil.! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testContainsPath
	
	locator := FileLocator image.
	self assert: (locator contains: (locator resolve / 'griffle') path)! !

!FileLocatorTest methodsFor: 'resolution tests' stamp: ''!
testResolveString
	| result path |
	locator := FileLocator image / 'plonk'.
	result := locator resolve: 'griffle'.
	path := (Path * 'plonk') / 'griffle'.
	self assert: result class equals: locator class.
	self assert: result origin equals: locator origin.
	self assert: result path equals: path! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testContainsReference

	locator := FileLocator image.
	self assert: (locator contains: (locator resolve / 'griffle'))! !

!FileLocatorTest methodsFor: 'resolution tests' stamp: ''!
testResolveCompoundString
	| result compound |
	locator := FileLocator image / 'plonk'.
	compound := 'griffle', locator fileSystem delimiter asString, 'nurp'.
	result := locator resolve: compound.
	self assert: result class equals: locator class.
	self assert: result origin equals: locator origin.
	self assert: result path equals: ((Path * 'plonk') / 'griffle' / 'nurp')! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testMoveTo
	| old new |
	[
		old := FileLocator imageDirectory / 'testMoveTo_old'.
		old ensureCreateFile.
		
		new := FileLocator home / 'testMoveTo_new'.
		old moveTo: new.
		
		self deny: old exists.
		self assert: new exists.
	] ensure: [ 
		old ensureDelete.
		new ensureDelete.
	]! !

!FileLocatorTest methodsFor: 'creation tests' stamp: ''!
testCanCreateLocatorFromStringWhenSamePath
	| path |
	path := FileLocator home fullName.
	
	locator := FileLocator fromString: path ifNone: [ nil ].
	
	self
		assert: locator
		equals: FileLocator home.
	self
		assert: locator fullName
		equals: path.! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testParent
	locator := FileLocator image.
	self assert: locator parent resolve equals: FileLocator imageDirectory resolve! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testCommaAddsExtensionAgain

	locator := FileLocator image / 'griffle.plonk'.
	self assert: (locator , 'nurp') basename equals: 'griffle.plonk.nurp'! !

!FileLocatorTest methodsFor: 'creation tests' stamp: ''!
testCanCreateLocatorFromStringWhenDirectChild
	| path |
	path := (FileLocator home / 'foo') fullName.
	
	locator := FileLocator fromString: path ifNone: [ nil ].
		
	self
		assert: locator origin
		equals: #home.
	self
		assert: locator fullName
		equals: path.! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testIsAbsolute
	locator := FileLocator image.
	self assert: locator isAbsolute! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testIsNotRoot
	locator := FileLocator image.
	self deny: locator isRoot! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testIsRoot
	locator := FileLocator image.
	(locator resolve path size) timesRepeat: [ locator := locator / '..' ].
	self assert: locator resolve canonicalize isRoot! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testWithExtensionAddsExtension
	locator := FileLocator image / 'griffle'.
	self assert: (locator withExtension: 'plonk') basename equals: 'griffle.plonk'! !

!FileLocatorTest methodsFor: 'resolution tests' stamp: ''!
testLocalDirectory
	locator := FileLocator localDirectory.
	self assert: locator resolve fullName equals: (FileLocator imageDirectory resolve / (SystemResolver defaultLocalDirectoryName)) fullName! !

!FileLocatorTest methodsFor: 'tests' stamp: ''!
testCPath
	| ref |
	ref := FileLocator C / 'WINDOWS'.
	self assert: (ref fileSystem isKindOf: FileSystem).
	self assert: ref path equals: (Path / 'C:' / 'WINDOWS')! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testBasename
	locator := FileLocator image / 'griffle'.
	self assert: locator basename equals: 'griffle'! !

!FileLocatorTest methodsFor: 'creation tests' stamp: ''!
testGetRightLocatorWhenCreatingFromString
	| path |
	path := (FileLocator documents / 'foo') fullName.

	locator := FileLocator fromString: path ifNone: [ nil ].

	self
		assert: locator origin
		equals: #documents.
	self
		assert: locator fullName
		equals: path.! !

!FileLocatorTest methodsFor: 'tests' stamp: ''!
testIfExistsIfAbsent
	| reference |
	reference := FileLocator temp / 'plonk'.
	reference ensureCreateFile.
	[ self assert: (reference ifExists: [ true ] ifAbsent: [ false ]).
	reference delete.
	self assert: (reference ifExists: [ false ] ifAbsent: [ true ]) ]
		ensure: [ reference ensureDelete ]! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testContainsLocator

	locator := FileLocator image.
	self assert: (locator contains: locator / 'griffle')! !

!FileLocatorTest methodsFor: 'resolution tests' stamp: ''!
testImageDirectory
	locator := FileLocator image.
	self assert: locator resolve equals: FileLocator image resolve! !

!FileLocatorTest methodsFor: 'creation tests' stamp: ''!
testCanCreateLocatorFromStringWhenDeepChild
	| path |
	path := (FileLocator home / 'foo' / 'bar' / 'bee' / 'see') fullName.
	
	locator := FileLocator fromString: path ifNone: [ nil ].
	
	self
		assert: locator origin
		equals: #home.
	self
		assert: locator fullName
		equals: path.! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testOriginBasename
	locator := FileLocator image.
	self assert: locator basename equals: FileLocator image resolve basename! !

!FileLocatorTest methodsFor: 'creation tests' stamp: ''!
testCananonicalize
	| fl canonicalized |

	fl := FileLocator home / 'foo' / 'bar'.
	self assert: fl path isRelative.
	self assert: fl path size equals: 2.

	canonicalized := fl canonicalize.
	self assert: canonicalized path isRelative.
	self assert: canonicalized path size equals: 2.! !

!FileLocatorTest methodsFor: 'compatibility tests' stamp: ''!
testFileSystem
	locator := FileLocator image.
	self assert: (locator fileSystem isKindOf: FileSystem)! !

!FileLocatorTest methodsFor: 'resolution tests' stamp: ''!
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 equals: locator class.
	self assert: result origin equals: locator origin.
	self assert: result path equals: reference path! !

!FileModifyingSimpleServiceEntry commentStamp: ''!
I represent a service that may change the contents of a directory.
Such changes include:
 - file creation
 - file deletion
 - file modification!
!FileModifyingSimpleServiceEntry methodsFor: 'performing service' stamp: ''!
performServiceFor: anObject
	| retval |
	retval := super performServiceFor: anObject.
	self changed: #fileListChanged.
	^retval	"is this used anywhere?"! !

!FilePathEncoder commentStamp: ''!
This class absorb the difference of internal and external representation of the file path.  The idea is to keep the internal one as much as possible, and only when it goes to a primitive, the encoded file path, i.e. the native platform representation is passsed to the primitive.

	The converter used is obtained by "LanguageEnvironment defaultFileNameConverter".
!
!FilePathEncoder class methodsFor: 'encoding' stamp: 'nil'!
decode: aString
	^ aString utf8Decoded! !

!FilePathEncoder class methodsFor: 'encoding' stamp: 'nil'!
encode: pathString
	^ pathString utf8Encoded! !

!FilePathEncoder class methodsFor: '*System-Settings-Core' stamp: ''!
settingInputWidgetForNode: aSettingNode
	^ aSettingNode  inputWidgetForFileOrDirectoryWithAction: #chooseFilePath.! !

!FileReference commentStamp: ''!
I combine a filesystem and path, which is sufficient to refer to a concrete file or directory. I provide methods for navigating my filesystem, performing filesystem operations and opening and closing files. 
I am the primary mechanism for working with files and directories. 

###Examples

```
| 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: 'comparing' stamp: ''!
hash
	^ path hash bitXor: filesystem hash! !

!FileReference methodsFor: 'utilities' stamp: ''!
nextNameFor: baseFileName extension: extension
  "Assumes a file name includes a version number encoded as '.' followed by digits 
   preceding the file extension, e.g., games.22.ston
   Increment the version number (of the largest one) and answer the new file name, e.g., games23.ston
   If a version number is not found, set the version to 1 and answer a new file name"

	"(FileSystem workingDirectory nextNameFor: 'games' extension: 'ston') asFileReference ensureCreateFile"

	| version |

	version := self versionNumberFor: baseFileName extension: extension.
	^version
		ifNil: [ baseFileName, '.1.', extension ]
		ifNotNil: [ baseFileName , '.' , (version+1) asString , '.' , extension ]! !

!FileReference methodsFor: 'testing' stamp: ''!
isReadable
	^ filesystem isReadable: path! !

!FileReference methodsFor: 'testing' stamp: ''!
hasFiles
	"Return whether the receiver has children that are files."
	"FileSystem workingDirectory hasFiles"
	
	^ filesystem hasFiles: path! !

!FileReference methodsFor: 'testing' stamp: ''!
isCharacter
	"Return a boolean indicating whether the File described by aPath is character based"
	^ filesystem isCharacter: path! !

!FileReference methodsFor: 'testing' stamp: ''!
isRoot
	^ path isRoot! !

!FileReference methodsFor: 'accessing' stamp: ''!
permissions
	^ filesystem permissions: self path! !

!FileReference methodsFor: 'accessing' stamp: ''!
fullPath
	^ self path! !

!FileReference methodsFor: 'resolving' stamp: ''!
resolveString: aString 
	| thePath |
	thePath := filesystem pathFromString: aString.
	^ filesystem referenceTo: (path resolve: thePath)! !

!FileReference methodsFor: 'operations' stamp: ''!
ensureCreateDirectory
	"Create if necessary a directory for the receiver."
	filesystem ensureCreateDirectory: path! !

!FileReference methodsFor: 'accessing' stamp: ''!
targetPath
	"Return the target file of the File described by aPath.  For a regular file, this is itself, for a symbolic link, it is the file pointed to by the symbolic link"
	^ self class fileSystem: filesystem path: (filesystem targetPath: path)! !

!FileReference methodsFor: 'operations' stamp: ''!
renameTo: newBasename
	
	| destinationPath |
	destinationPath := self fileSystem 
		rename: self 
		to: self parent / newBasename.
	
	destinationPath ifNotNil: [
		self 
			setFileSystem: filesystem 
			path: destinationPath ].
	^ self! !

!FileReference methodsFor: '*Zinc-Resource-Meta-Core' stamp: 'nil'!
mimeTypes
	"Return the possible mime types for the given path."
	^ filesystem mimeTypesAt: path! !

!FileReference methodsFor: 'versions' stamp: ''!
extractVersionNumberFrom: filename basename: basename extension: extension
	"Answer the version number written in filename considering 
	that it consists of basename and extension.
	For example filename=basename.10.extension will return 10.
	filename=basename.extension without number will return 0
	It returns nil if given file does not satisfy this pattern"

	"ensure prefix basename."
	| versionStart versionEnd |
	(filename beginsWith: basename) ifFalse: [^nil].
	(filename size > basename size and: [(filename at: basename size + 1) = $.]) 
		ifFalse: [ ^nil ].
	"ensure suffix .extension"
	(filename endsWith: extension) ifFalse: [^nil].
	(filename size > extension size and: [(filename at: filename size - extension size) = $.])
		 ifFalse: [ ^nil ].
	
	versionStart := basename size + 2.
	versionEnd := filename size - extension size - 1.
	versionStart to: versionEnd do: [:i | 
		(filename at: i) isDigit ifFalse: [ ^nil ] ].
	versionStart > versionEnd ifTrue: [ ^0]. "means pattern baseline.extension"
	^(filename copyFrom: versionStart to: versionEnd) asNumber! !

!FileReference methodsFor: 'accessing' stamp: ''!
entry
	"Return the entry (meta data) describing the receiver."
	^ filesystem entryAt: path! !

!FileReference methodsFor: 'accessing' stamp: ''!
uid
	"Return the gid of the file at aPath"
	^ filesystem uidOf: path! !

!FileReference methodsFor: 'testing' stamp: ''!
isBlock
	"Return a boolean indicating whether the File described by aPath is a block device"
	^ filesystem isBlock: path! !

!FileReference methodsFor: 'testing' stamp: ''!
isDirectory
	^ filesystem isDirectory: path! !

!FileReference methodsFor: 'testing' stamp: ''!
isRelative
	^ path isRelative! !

!FileReference methodsFor: 'testing' stamp: ''!
isFile
	^ filesystem isFile: path! !

!FileReference methodsFor: 'operations' stamp: ''!
copyTo: aFileReference
	"Copy the receiver and create the argument, a file reference."
	
	"If you want to copy a file from a folder into a given folder, the argument should not be the future parent folder
	but a file reference of the future location.  
	Therefore use 
		(folder1 / 'foo.txt') copyTo: (folder2 / 'bar.txt')"
		
	self isDirectory
		ifTrue: [ aFileReference ensureCreateDirectory ]
		ifFalse: [ filesystem copy: path toReference: aFileReference ]! !

!FileReference methodsFor: 'operations' stamp: ''!
delete
	"Deletes the referenced file or directory. If the directory is not empty, 
	raises an error. Use #deleteAll to delete with the children."

	(self isDirectory and:[self hasChildren]) 
		ifTrue:[DirectoryIsNotEmpty signalWith: self].
	filesystem delete: path! !

!FileReference methodsFor: 'printing' stamp: ''!
pathString
	"Return the full path name of the receiver."
	
	^ filesystem stringFromPath: (filesystem resolve: path)! !

!FileReference methodsFor: 'testing' stamp: ''!
exists
	"Answer a boolean indicating whether the receiver exists on the file system"
	^ filesystem exists: path! !

!FileReference methodsFor: 'accessing' stamp: ''!
accessTime 
	^ filesystem accessTimeOf: self path! !

!FileReference methodsFor: 'accessing' stamp: ''!
fileSystem
	"Return the filesystem to which the receiver belong."
	^ filesystem! !

!FileReference methodsFor: 'streams' stamp: ''!
writeStream
	
	^ self writeStreamEncoded: 'utf8'! !

!FileReference methodsFor: 'versions' stamp: ''!
versionNumberFor: basename extension: extension
	"Answer the latest (largest) version number for the specified file.
	0 = basename.extension exists, but nothing later.
	nil = no file exists"
	| maxVersion |
	maxVersion := 0.
	self fileSystem childNamesAt: self path do: [ :child | | childVersion |
		childVersion := self extractVersionNumberFrom: child basename: basename extension: extension.
		childVersion ifNotNil: [ maxVersion := maxVersion max: childVersion ]].
	^maxVersion = 0
		ifTrue: [ (self / (basename, '.', extension)) asFileReference exists 
			ifTrue: [ 0 ]
			ifFalse: [ nil ] ]
		ifFalse: [ maxVersion ]! !

!FileReference methodsFor: 'testing' stamp: ''!
isSocket
	"Return a boolean indicating whether the File described by aPath is a socket"
	^ filesystem isSocket: path! !

!FileReference methodsFor: 'operations' stamp: ''!
moveTo: aReference
	"Move the receiver in the location passed as argument.
	
	(FileSystem disk workingDirectory / 'paf' ) ensureCreateFile.
	(FileSystem disk workingDirectory / 'fooFolder') ensureCreateDirectory. 
	(FileSystem disk workingDirectory / 'paf' ) moveTo: (FileSystem disk workingDirectory / 'fooFolder' / 'paf')
	
	Note that the receiver is modified to point to the new location."
	
	| result |
	result := self fileSystem 
		move: self path
		to: aReference resolve.
	result ifNotNil: [
		self setFileSystem: result fileSystem path: result path ].! !

!FileReference methodsFor: 'accessing' stamp: ''!
symlinkUid: uid gid: gid
	"Set the owner and group of the receiver by numeric id.
	An id of nil leaves it unchanged."

	^filesystem file: self path symlinkUid: uid gid: gid.! !

!FileReference methodsFor: 'accessing' stamp: ''!
resolve
	^ self! !

!FileReference methodsFor: 'testing' stamp: ''!
isAbsolute
	^ path isAbsolute! !

!FileReference methodsFor: 'accessing' stamp: ''!
changeTime 
	^ filesystem changeTimeOf: self path! !

!FileReference methodsFor: 'accessing' stamp: ''!
size
	^ filesystem sizeOf: path! !

!FileReference methodsFor: 'testing' stamp: ''!
isExecutable
	"Answer a boolean indicating whether the receiver has the executable flag set"
	^ filesystem isExecutable: path! !

!FileReference methodsFor: 'converting' stamp: ''!
asAbsolute
	"Return the receiver as an absolute file reference."
	
	^ self isAbsolute
		ifTrue: [ self ]
		ifFalse: [ filesystem referenceTo: (filesystem resolve: path) ]! !

!FileReference methodsFor: 'accessing' stamp: ''!
gid
	"Return the gid of the file at aPath"
	^ filesystem gidOf: path! !

!FileReference methodsFor: 'utilities' stamp: ''!
nextVersion
	"Assumes a file (or folder) 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 basename nameWithoutExtension extension max index |

	self exists
		ifFalse: [ ^ self ].

	parent := self parent.
	extension := self extension.
	basename := self basename.
	nameWithoutExtension := basename copyFrom: 1 to: (basename size - extension size - 1).
	"At this stage nameWithoutExtension may still include a version number.  Remove it if necessary"
	index := nameWithoutExtension size.
	[ index > 0 and: [ (nameWithoutExtension at: index) isDigit ] ] whileTrue:
		[ index := index - 1 ].
	((index between: 1 and: nameWithoutExtension size - 1) and: [ (nameWithoutExtension at: index) = $. ]) ifTrue: 
		[ nameWithoutExtension := nameWithoutExtension copyFrom: 1 to: index-1 ].

	max := parent versionNumberFor: nameWithoutExtension extension: extension.
	^ parent / (nameWithoutExtension, '.', (max+1) asString) , self extension! !

!FileReference methodsFor: '*MonticelloFileTree-FileSystem-Utilities' stamp: ''!
fileTreeUtilityClass
    ^ MCFileTreeFileSystemUtils! !

!FileReference methodsFor: 'testing' stamp: ''!
isRegular
	"Return a boolean indicating whether the File described by aPath is a regular file"
	^ filesystem isRegular: path! !

!FileReference methodsFor: 'utilities' stamp: ''!
lastFileFor: baseFileName extension: extension
	"Assumes a file is named using a version number encoded as '.' followed by digits
  preceding the file extension, e.g., games.22.ston
  Answer the file name with the largest number.
  If a version number is not found, raises an error"

	"FileSystem workingDirectory lastFileFor: 'games' extension: 'ston'"

	| version |

	version := self versionNumberFor: baseFileName extension: extension.
	^(version
		ifNil: [ self error: 'No file with number pattern' ]
		ifNotNil: [ version = 0
			ifTrue: [ baseFileName, '.', extension ]
			ifFalse: [ baseFileName , '.' , version asString , '.' , extension ] ]) asFileReference! !

!FileReference methodsFor: 'accessing' stamp: ''!
numberOfHardLinks
	"Return the number of hard links to the File described by aPath"
	^ filesystem numberOfHardLinks: path! !

!FileReference methodsFor: 'accessing' stamp: ''!
modificationTime 
	"Returns the last date of modification of self"
	^ filesystem modificationTimeOf: self path! !

!FileReference methodsFor: 'operations' stamp: ''!
deleteIfAbsent: aBlock
	self exists 
		ifTrue: [ self delete ]
		ifFalse: aBlock! !

!FileReference methodsFor: 'comparing' stamp: ''!
= other
	"Two FileReferences are considered equal if they refer to the same file / directory.
	As paths can have multiple relative representations, compare the absolute paths."
	"Perform the path comparison last as conversion to absolute paths is relatively expensive"
	^ self species = other species
		and: [self fileSystem = other fileSystem
			and: [self absolutePath = other absolutePath]]! !

!FileReference methodsFor: 'testing' stamp: ''!
hasDirectories
	"Return whether the receiver has children that are directories."
	"FileSystem workingDirectory hasDirectories"
	
	^ filesystem hasDirectories: path! !

!FileReference methodsFor: 'accessing' stamp: ''!
creationTime
	"Answer the receivers creation time.
	Note that the interpretation varies by platform."
	^ filesystem creationTimeOf: self path! !

!FileReference methodsFor: 'accessing' stamp: ''!
deviceId
	"Return the device id of the file at aPath"
	^ filesystem deviceIdOf: path! !

!FileReference methodsFor: 'streams' stamp: ''!
openWritable: aBoolean 
	^ filesystem open: path writable: aBoolean! !

!FileReference methodsFor: 'accessing' stamp: ''!
symlinkEntry
	"Return the symlink entry (meta data) describing the receiver."
	^ filesystem symlinkEntryAt: path! !

!FileReference methodsFor: 'testing' stamp: ''!
hasChildren
	"Return whether the receiver has any children."
	"FileSystem workingDirectory hasChildren"
	
	^ filesystem hasChildren: path! !

!FileReference methodsFor: 'printing' stamp: ''!
displayStringOn: stream
	filesystem printPath: path on: stream! !

!FileReference methodsFor: 'printing' stamp: ''!
printOn: aStream
	filesystem forReferencePrintOn: aStream.
	filesystem printPath: path on: aStream! !

!FileReference methodsFor: '*metacello-platform' stamp: ''!
asRepositorySpecFor: aMetacelloMCProject
  ^ aMetacelloMCProject repositorySpec
    description: self fullName;
    type: 'directory';
    yourself! !

!FileReference methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	self fileSystem isDiskFileSystem
		ifTrue: [ | diskFilePath |
			"in order to get $/ as delimiter and $. as working directory on all platforms"
			diskFilePath := path isWorkingDirectory
				ifTrue: [ '.' ]
				ifFalse: [ path pathString ].
			stonWriter 
				writeObject: self 
				named: STONFileReference stonName 
				listSingleton: diskFilePath ]
		ifFalse: [ 
			super stonOn: stonWriter ]! !

!FileReference methodsFor: 'streams' stamp: ''!
binaryWriteStream
	"Answer a buffered binary write stream on the receiver"

	^ ZnBufferedWriteStream on: (filesystem binaryWriteStreamOn: self path)! !

!FileReference methodsFor: 'accessing' stamp: ''!
fullName
	"Return the full path name of the receiver."
	^ filesystem stringFromPath: (filesystem resolve: path)! !

!FileReference methodsFor: 'initialization' stamp: ''!
setFileSystem: aFilesystem path: aPath
	filesystem := aFilesystem.
	path := aPath! !

!FileReference methodsFor: 'streams' stamp: ''!
readStream

	^ self readStreamEncoded: 'utf8'! !

!FileReference methodsFor: 'accessing' stamp: ''!
inode
	"Return the inode of the file at aPath"
	^ filesystem inodeOf: path! !

!FileReference methodsFor: 'copying' stamp: ''!
copyWithPath: newPath
	^ filesystem referenceTo: newPath! !

!FileReference methodsFor: 'converting' stamp: ''!
asFileLocatorOrReference
	^ self path asFileLocatorOrReference! !

!FileReference methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects
	^ false! !

!FileReference methodsFor: 'streams' stamp: ''!
binaryReadStream
	"Answer a buffered binary read stream on the receiver"
	
	^ ZnBufferedReadStream on: (filesystem binaryReadStreamOn: self path)! !

!FileReference methodsFor: 'resolving' stamp: ''!
resolveReference: aReference
	
	^ (filesystem = aReference fileSystem or: [aReference isRelative])
		ifTrue: [filesystem referenceTo: (path resolvePath: aReference path)]
		ifFalse: [aReference]! !

!FileReference methodsFor: 'operations' stamp: ''!
permissions: permissions
	"Set the receivers mode to anInteger (as defined by chmod())"

	^filesystem file: self path posixPermissions: permissions posixPermission! !

!FileReference methodsFor: 'accessing' stamp: ''!
uid: uid gid: gid
	"Set the owner and group of the receiver by numeric id.
	An id of nil leaves it unchanged."

	^filesystem file: self path uid: uid gid: gid! !

!FileReference methodsFor: 'testing' stamp: ''!
isSymlink
	"Answer a boolean indicating whether the receiver is a symlink"
	^ filesystem isSymlink: path! !

!FileReference methodsFor: 'converting' stamp: ''!
asFileReference
	^ self! !

!FileReference methodsFor: 'accessing' stamp: ''!
absolutePath
	"Return the absolute of the receiver"
	^ self path isRelative
		ifFalse: [ self path ]
		ifTrue: [ filesystem resolve: self path ]! !

!FileReference methodsFor: 'comparing' stamp: ''!
containsReference: aReference
	^  aReference fileSystem = filesystem and: [path contains: aReference path]! !

!FileReference methodsFor: 'testing' stamp: ''!
isFIFO
	"Return a boolean indicating whether the File described by aPath is FIFO (i.e. a pipe)"
	^ filesystem isFIFO: path! !

!FileReference methodsFor: 'navigating' stamp: ''!
, extension
	^ self withPath: self path, extension! !

!FileReference methodsFor: 'converting' stamp: ''!
asPath
	"Answer the receivers path"

	^path! !

!FileReference methodsFor: 'streams' stamp: ''!
unbufferedBinaryWriteStream
	"Answer a binary read/write stream on the receiver"

	^ filesystem binaryWriteStreamOn: self path! !

!FileReference methodsFor: 'testing' stamp: ''!
isWritable
	^ filesystem isWritable: path! !

!FileReference methodsFor: 'resolving' stamp: ''!
resolvePath: anObject
	^ self withPath: (path resolve: anObject)! !

!FileReference methodsFor: 'navigating' stamp: ''!
entries
	"Return the entries (meta data - file description) of the direct children of the receiver"
	^ self fileSystem entriesAt: self path! !

!FileReference class methodsFor: 'cross platform' stamp: ''!
/ 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: ''!
fileSystem: aFilesystem path: aPath
	^ self new setFileSystem: aFilesystem path: aPath! !

!FileReference class methodsFor: 'instance creation' stamp: ''!
newTempFilePrefix: prefix suffix: suffix
	| tmpDir random fileName |
	
	tmpDir := FileLocator temp asFileReference.
	[ 
		random := UUID new asInteger asString.
		fileName := prefix , random , suffix.
		(tmpDir / fileName) exists ] whileTrue.
	^ tmpDir / fileName! !

!FileReferenceAttributeTest commentStamp: ''!
Try and test file attribute access from FileReference.

As Pharo doesn't provide a mechanism to set the attributes, pick a few well known files and make sure they have reasonable attributes, e.g. the VM is executable, it isn't older than when the classes were first created or newer than today, etc.
!
!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testFileSize

	self assert: self tempFileResource file size equals: 72.
	self assert: self tempFileResource file entry size equals: self tempFileResource file size.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsDirectory

	self assert: self tempFileResource file isDirectory equals: false.
	self assert: self tempFileResource file entry isDirectory equals: self tempFileResource file isDirectory.
	self assert: FileLocator temp isDirectory.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsRegular

	self assert: self tempFileResource file isRegular.
	self assert: self tempFileResource file entry isRegular equals: self tempFileResource file isRegular! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsReadable

	self assert: self tempFileResource file isReadable.
	self assert: self tempFileResource file entry isReadable equals: self tempFileResource file isReadable.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testCreationTime

	| resource creationTime |
	resource := self tempFileResource.
	creationTime := resource file creationTime.
	self assert: resource beforeCreationTime <= creationTime.
	self assert: resource afterCreationTime >= creationTime.
	self assert: resource file entry creationTime equals: creationTime.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsCharacter

	self deny: self tempFileResource file isCharacter.
	self assert: self tempFileResource file entry isCharacter equals: self tempFileResource file isCharacter.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsSymlink

	self assert: self tempFileResource file isSymlink equals: false.
	self assert: self tempFileResource file entry isSymlink equals: self tempFileResource file isSymlink.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsWriteable

	self assert: self tempFileResource file isWritable.
	self assert: self tempFileResource file entry isWritable equals: self tempFileResource file isWritable.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testTargetFile

	"The temporary file isn't a symbolic link, so the targetFile isn't supported"
	self should: [ self tempFileResource file targetPath ] raise: FileAttributeNotSupported.
	self should: [ self tempFileResource file entry targetPath ] raise: FileAttributeNotSupported.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testChangeTime

	| resource changeTime |
	resource := self tempFileResource.
	changeTime := resource file changeTime.
	self assert: resource beforeCreationTime <= changeTime.
	self assert: resource afterCreationTime >= changeTime.
	self assert: resource file entry changeTime equals: changeTime.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsSocket

	self assert: self tempFileResource file isSocket equals: false.
	self assert: self tempFileResource file entry isSocket equals: self tempFileResource file isSocket.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsFIFO

	self assert: self tempFileResource file isFIFO equals: false.
	self assert: self tempFileResource file entry isFIFO equals: self tempFileResource file isFIFO.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsExecutable

	self assert: FileLocator vmBinary isExecutable.
	self assert: FileLocator vmBinary entry isExecutable equals: FileLocator vmBinary isExecutable! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testAccessTime

	| resource accessTime |
	resource := self tempFileResource.
	accessTime := resource file accessTime.
	self assert: resource beforeCreationTime <= accessTime.
	self assert: resource afterCreationTime >= accessTime.
	self assert: resource file entry accessTime equals: accessTime.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testModificationTime

	| resource modificationTime |
	resource := self tempFileResource.
	modificationTime := resource file modificationTime.
	self assert: resource beforeCreationTime <= modificationTime.
	self assert: resource afterCreationTime >= modificationTime.
	self assert: resource file entry modificationTime equals: modificationTime.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testExists

	self assert: self tempFileResource file exists! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsFile

	self assert: self tempFileResource file isFile.
	self assert: self tempFileResource file entry isFile equals: self tempFileResource file isFile.
	self deny: FileLocator temp isFile.! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testNLink
	"Assume that there is only one hard link to the just created temporary file"

	OSPlatform current name = #'Win32' ifTrue: 
		[ self should: [ self tempFileResource file numberOfHardLinks ] raise: FileAttributeNotSupported ]
	ifFalse:
		[ self assert: self tempFileResource file numberOfHardLinks equals: 1.
		self assert: self tempFileResource file entry numberOfHardLinks equals: 1 ].! !

!FileReferenceAttributeTest methodsFor: 'tests' stamp: ''!
testIsBlock

	self deny: self tempFileResource file isBlock.
	self assert: self tempFileResource file entry isBlock equals: self tempFileResource file isBlock.! !

!FileReferenceAttributeTest methodsFor: 'private' stamp: ''!
tempFileResource

	^DiskFileAttributesTestsResource current! !

!FileReferenceAttributeTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	primitives := File.! !

!FileReferenceAttributeTest class methodsFor: 'resources' stamp: ''!
resources

	^Array with: DiskFileAttributesTestsResource.! !

!FileReferenceTest commentStamp: ''!
SUnit tests for file reference!
!FileReferenceTest methodsFor: 'tests' stamp: ''!
testIndicator
	| ref |
	ref := filesystem * 'plonk' / 'griffle'.
	self deny: ref exists.
	self assert: ref indicator equals: '?'.
	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: ''!
testReadStreamNotFound
	| ref  |
	ref := filesystem * 'plonk'.
	self
		should: [ref readStream]
		raise: FileDoesNotExistException! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testEnsureDeleteAll
	| reference childReference |
	reference := filesystem / 'plonk'.	"Deletes the file if it exists"
	reference ensureCreateDirectory.
	[ self assert: reference exists.
	childReference := reference / 'child'.
	childReference ensureCreateFile.
	self assert: childReference exists.
	reference ensureDeleteAll.
	self deny: childReference exists.
	self deny: reference exists ]
		ensure: [ reference ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWriteStreamDo
	| ref |
	ref := filesystem / 'plonk'.
	[ ref writeStreamDo: [ :stream | self deny: stream isNil ] ] ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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 equals: 2.
	childDirectories
		do: [ :each | 
			self assert: each class equals: FileReference.
			self
				assert: each isDirectory
				description: 'Collection should not contain references to files.' ] ]
		ensure: [ (filesystem / 'beta') ensureDeleteAll.
			(filesystem / 'gamma') ensureDeleteAll.
			(filesystem / 'delta') ensureDelete.
			(filesystem / 'epsilon') ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testHasChildren
	[ | ref |
	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 ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testReadStreamDoifAbsentNot
	| ref pass |
	pass := false.
	ref := filesystem * 'plonk'.
	ref 
		readStreamDo: [:stream]
		ifAbsent: [pass := true].
	self assert: pass! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testDoesNotContainReferenceWhenUsingDifferentInstancesOfMemoryFileSystem
	| ref other |
	ref := filesystem * 'griffle'.
	other := FileSystem memory / 'griffle' / 'nurp'.
	self deny: (ref contains: other)! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testRelativeToReference
	| parent child relative |
	parent := filesystem / 'griffle'.
	child := filesystem  / 'griffle' / 'plonk' / 'nurb'.
	relative := child relativeTo: parent.
	self assert: relative equals: (Path * 'plonk' / 'nurb')! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWriteStreamifPresentExists
	| ref pass path |
	pass := false.
	path := Path * 'plonk'.
	filesystem store createFile: path.
	ref := filesystem referenceTo: path.
	[ ref writeStreamIfPresent: [ pass := true ].
	self assert: pass ]
		ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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 identicalTo: 4.	"including root"
	children := ref glob: [ :node | node basename size > 1 ].
	self assert: children size identicalTo: 3.	"without root"
	children := ref glob: [ :node | node basename = #gamma ].
	self assert: children size identicalTo: 1.	"gamma"
	self assert: children first basename equals: #gamma ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests stream' stamp: ''!
testReadStreamDoNotFound
	| ref |
	ref := filesystem / 'plonk'.
	self
		should: [ref readStreamDo: [:s]]
		raise: FileDoesNotExistException! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testAllDirectories
	"allDirectories returns all folders recursively nested in a reference"
	| 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 equals: 4.
	children
		do: [ :child | 
			self assert: child class equals: FileReference.
			self assert: (ref = child or: [ ref contains: child ]) ].
	self assert: (children collect: [ :ea | ea basename ]) equals: #('alpha' 'beta' 'gamma' 'delta') ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWorkingDirectoryParent
	| wd |
	wd := filesystem referenceTo: Path workingDirectory.
	self assert: wd parent path size equals: 1.
	self assert: (wd parent path at: 1) equals: '..'.! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testParent
	| ref parent |
	ref := filesystem * 'plonk' / 'griffle'.
	parent := ref parent.
	self assert: parent class equals: ref class.
	self assert: (parent path at: 1) equals: 'plonk'! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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 equals: 'griffle'.
	self assert: simpleExtension extension equals: '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.taz'.
	self assert: complexExtension extension equals: 'txt'! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testAllChildren
	"allChildren returns all the files and folders recursively nested in a reference"
	| 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 equals: 4.
	children
		do: [ :child | 
			self assert: child class equals: FileReference.
			self assert: (ref = child or: [ ref contains: child ]) ].
	self assert: (children collect: [ :ea | ea basename ]) equals: #('alpha' 'beta' 'gamma' 'delta') ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWriteStreamExists
	| ref stream path |
	path := Path * 'plonk'.
	filesystem store createFile: path.
	ref := filesystem referenceTo: path.
	[ [ stream := ref writeStream ]
		ensure: [ stream ifNotNil: [ stream close ] ] ]
		ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testIsNotRelative
	self deny: (filesystem / 'plonk') isRelative! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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) equals: 'plonk'! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testChildOfPath
	| parent  child |
	parent := Path / 'griffle'.
	child := filesystem / 'griffle' / 'nurb'.
	self deny: (child isChildOf: parent).
	self deny: (parent isChildOf: child)! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testBasename
	| ref |
	ref := filesystem root.
	self assert: ref basename equals: '/'.
	ref := filesystem * 'plonk' / 'griffle'.
	self assert: ref basename equals: 'griffle'.
	ref := filesystem * 'plonk' / 'griffle.taz'.
	self assert: ref basename equals: 'griffle.taz'! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testEqualityRelativeVsAbsolute

	| f1 f2 |

	f1 := FileLocator workingDirectory / 'pharo-local'.
	f2 := f1 asAbsolute.
	self assert: f1 equals: f2! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWriteStreamDoifPresent
	| ref |
	ref := filesystem / 'plonk'.
	[ ref writeStreamDo: [ :stream | self deny: stream isNil ] ifPresent: [ self signalFailure: 'The file does not exist!!' ] ] ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testExists
	| reference |
	reference := filesystem / 'plonk'.
	reference ensureCreateFile.
	[ self assert: reference exists.
	reference delete.
	self deny: reference exists ]
		ensure: [ reference ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testParentUpTo
	| base a b c |
	[ 
		base := filesystem workingDirectory.
		(base / 'testParentUpTo') ensureCreateDirectory.
		a := (base / 'testParentUpTo' / 'A') ensureCreateDirectory.
		b := (base / 'testParentUpTo' / 'A' / 'B') ensureCreateDirectory.
		c := (base / 'testParentUpTo' / 'A' / 'B' / 'C') ensureCreateDirectory.
		self assert: b equals: (c parentUpTo: 'B').
		self assert: a equals: (c parentUpTo: 'A').
		self assert: (base / 'testParentUpTo') equals: (c parentUpTo: 'testParentUpTo').
		self assert: base equals: (c parentUpTo: 'notAParent') 
	] ensure: [ 
		(base / 'testParentUpTo') ensureDeleteAll 
	]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testAsReference
	| ref |
	ref := filesystem * 'plonk'.
	self assert: ref asFileReference identicalTo: ref! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testReadStreamDoifAbsent
	| ref path |
	path := Path * 'plonk'.
	filesystem store createFile: path.
	ref := filesystem referenceTo: path.
	[ ref readStreamDo: [ :stream | self deny: stream isNil ] ifAbsent: [ self signalFailure: 'The file exists!!' ] ]
		ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWithoutExtension
	| ref newRef |
	ref := filesystem * 'plonk' / 'griffle.txt'.
	newRef := ref withoutExtension.
	self assert: newRef parent equals: ref parent.
	self assert: newRef basename equals: 'griffle'! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testDoesntContainReferencePath
	| ref other |
	ref := filesystem * 'griffle'.
	other := filesystem * 'nurp'.
	self deny: (ref contains: other)! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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 equals: 2.
	childFiles
		do: [ :each | 
			self assert: each class equals: FileReference.
			self assert: each isFile description: 'Collection should not contain references to directories.' ] ]
		ensure: [ (filesystem / 'beta') ensureDeleteAll.
			(filesystem / 'gamma') ensureDeleteAll.
			(filesystem / 'delta') ensureDelete.
			(filesystem / 'epsilon') ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testIsRelative
	self assert: (filesystem * 'plonk') isRelative! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWithExtentionAddsExtension
	| ref result |
	ref := filesystem * 'plonk'.
	result := ref withExtension: 'griffle'.
	self assert: result isRelative.
	self assert: result basename equals: 'plonk.griffle'! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testDoesntContainPath
	| ref |
	ref := filesystem * 'griffle'.
	self deny: (ref contains: (Path * 'nurp'))! !

!FileReferenceTest methodsFor: 'tests - handy utils' stamp: ''!
testLastFilesForExtensionBrokenPattern
	"when a file does not follow the pattern name.number.extension, it should be filtered out."
	[ filesystem createDirectory: 'dir'.
	filesystem / 'dir' / 'games.51.ston' writeStreamDo: [ :stream | stream nextPutAll: '51' ].
	filesystem / 'dir' / 'games.ston' writeStreamDo: [ :stream | stream nextPutAll: 'nonumber' ].
	filesystem / 'dir' / 'games.stf' writeStreamDo: [ :stream | stream nextPutAll: 'wrong extension' ].
	filesystem / 'dir' / 'games.101.ston' writeStreamDo: [ :stream | stream nextPutAll: '101' ].
	filesystem / 'dir' / 'games.250.49.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	filesystem / 'dir' / 'games.1000.1000.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	filesystem / 'dir' / 'zorglub.500.ston' writeStreamDo: [ :stream | stream nextPutAll: '5' ].

	self assert: ((filesystem root / 'dir') lastFileFor: 'games' extension: 'ston') basename equals: 'games.101.ston'.
	] ensure: [ (filesystem / 'dir') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testHasFiles
	[ | ref |
	filesystem createDirectory: '/alpha'.
	filesystem createDirectory: '/alpha/beta'.
	(filesystem / 'alpha' / 'beta' / 'delta') ensureCreateFile.
	filesystem createDirectory: '/alpha/beta/eta'.
	filesystem createDirectory: '/alpha/gamma'.
	ref := filesystem / 'alpha'.
	self deny: ref hasFiles.
	self assert: (ref / 'beta') hasFiles.
	self deny: (ref / 'beta' / 'gamma') hasFiles ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testEqual
	| a b |
	a := filesystem * 'plonk'.
	b := filesystem * 'plonk'.
	self deny: a identicalTo: b.
	self assert: a equals: b! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testDeleteAllChildren
	"allChildren returns all the files and folders recursively nested in a reference"
	[ | ref |
	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 ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testUpToAll
	| testString filename  |
	testString := 'ße'.
	filename := 'test-file-' , 99 atRandom printString , '.txt'.

	[  
	filename asFileReference
		writeStreamEncoded: 'utf8' do: [ :stream | 
			stream nextPutAll: testString ].

	filename asFileReference
		readStreamDo: [ :stream |
			self assert: (stream upToAll: 'e') equals: 'ß'.
		] ]
	ensure: [ filename asFileReference ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testReadStream
	| ref stream path |
	path := Path * 'plonk'.
	filesystem store createFile: path.
	ref := filesystem referenceTo: path.
	[ [ stream := ref readStream ]
		ensure: [ stream ifNotNil: [ stream close ] ] ]
		ensure: [ ref delete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testSiblingOfReference
	| griffle  nurb |
	griffle := filesystem / 'griffle'.
	nurb := filesystem / 'nurb'.
	self deny: (griffle isChildOf: nurb).
	self deny: (nurb isChildOf: griffle).! !

!FileReferenceTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	filesystem := FileSystem memory! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWriteStreamifPresent
	| ref stream |
	ref := filesystem / 'plonk'.
	[ [ stream := ref writeStreamIfPresent: [ self signalFailure: 'Should not reach here' ] ]
		ensure: [ stream ifNotNil: [ stream close ] ] ]
		ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testBasenameWithoutExtension
	
	| ref |	
	ref := filesystem root.
	self assert: ref basename equals: '/'.
	
	ref := filesystem * 'plonk' / 'griffle'.
	self assert: ref basenameWithoutExtension equals: 'griffle'.
	self assert: (ref basenameWithoutExtension: 'griffle') equals: 'griffle'.
	self assert: (ref basenameWithoutExtension: 'taz') equals: 'griffle'.
	
	ref := filesystem * 'plonk' / 'griffle.taz'.
	self assert: ref basenameWithoutExtension equals: 'griffle'.
	self assert: (ref basenameWithoutExtension: 'taz') equals: 'griffle'.
	self assert: (ref basenameWithoutExtension: 'griffle.taz') equals: 'griffle.taz'.
	self assert: (ref basenameWithoutExtension: 'zork') equals: 'griffle.taz'.
	
	ref := filesystem * 'plonk' / 'griffle.taz.zork'.
	self assert: ref basenameWithoutExtension equals: 'griffle.taz'.
	self assert: (ref basenameWithoutExtension: 'zork') equals: 'griffle.taz'.
	self assert: (ref basenameWithoutExtension: 'taz.zork') equals: 'griffle'.
	self assert: (ref basenameWithoutExtension: 'griffle.taz.zork') equals: 'griffle.taz.zork'.
	self assert: (ref basenameWithoutExtension: 'taz') equals: 'griffle.taz.zork'.! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testAsFileLocatorOrReferenceReturnsALocatorWhenStringRefersToAKnownOrigin
	| fileRef locator |
	fileRef := (FileLocator home / 'foo') asFileReference.
	
	locator := fileRef asFileLocatorOrReference.
		
	self
		assert: locator origin
		equals: #home.
	self
		assert: locator fullName
		equals: fileRef fullName.! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testIsNotRoot
	self deny: (filesystem / 'plonk') isRoot! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testDeleteAll
	"allChildren returns all the files and folders recursively nested in a reference"
	[ | ref |
	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 ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testRootParent
	| root |
	root := filesystem root.
	self assert: root parent identicalTo: root! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testIfExistsIfAbsent
	| reference |
	reference := filesystem / 'plonk'.
	reference ensureCreateFile.
	[ self assert: (reference ifExists: [ true ] ifAbsent: [ false ]).
	reference delete.
	self assert: (reference ifExists: [ false ] ifAbsent: [ true ]) ]
		ensure: [ reference ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testRenameTargetExists

	| existingFile fileToRename |
	[
		existingFile := 'existingFile' asFileReference ensureCreateFile.
		fileToRename := 'fileToRename' asFileReference ensureCreateFile.
		self should: [ fileToRename renameTo: existingFile basename ] raise: FileExists ]
		ensure: [
			existingFile delete.
			fileToRename delete ].! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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 ]
		ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests - handy utils' stamp: ''!
testLastFilesForExtensionNegativeTesting
	"When there is no file with the given pattern, then an error should be raised."
	
	[ filesystem createDirectory: 'dir'.
	filesystem / 'dir' / 'games.51.ston' writeStreamDo: [ :stream | stream nextPutAll: '51' ].
	filesystem / 'dir' / 'games.4.ston' writeStreamDo: [ :stream | stream nextPutAll: '4' ].
	filesystem / 'dir' / 'games.101.ston' writeStreamDo: [ :stream | stream nextPutAll: '101' ].
	filesystem / 'dir' / 'games.49.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	filesystem / 'dir' / 'games.5.ston' writeStreamDo: [ :stream | stream nextPutAll: '5' ].
	
	self should: [((filesystem root / 'dir') lastFileFor: 'games' extension: 'stf')] raise: Error.
   self should: [((filesystem root / 'dir') lastFileFor: 'plouf' extension: 'ston')] raise: Error.
	] ensure: [ (filesystem / 'dir') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testIsNotAbsolute
	self deny: (filesystem * 'plonk') isAbsolute! !

!FileReferenceTest methodsFor: 'tests - handy utils' stamp: ''!
testNextNameForExtension
	
	| childFiles dir |

	[ filesystem createDirectory: 'dir'.
	dir := filesystem / 'dir'.
	dir / 'games.51.ston' writeStreamDo: [ :stream | stream nextPutAll: '51' ].
	dir / 'games.3.ston' writeStreamDo: [ :stream | stream nextPutAll: '3' ].
	dir / 'games.33.ston' writeStreamDo: [ :stream | stream nextPutAll: '33' ].
	dir / 'games.4.ston' writeStreamDo: [ :stream | stream nextPutAll: '4' ].
	dir / 'games.101.ston' writeStreamDo: [ :stream | stream nextPutAll: '101' ].
	dir / 'games.49.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	dir / 'games.5.ston' writeStreamDo: [ :stream | stream nextPutAll: '5' ].
	
	childFiles := dir files.
	self assert: childFiles size equals: 7.
	self assert: (dir nextNameFor: 'games' extension: 'ston') equals: 'games.102.ston' ]
		ensure: [ (filesystem / 'dir') ensureDeleteAll ].


	[ filesystem createDirectory: 'dir'.
	dir := filesystem / 'dir'.
	dir / 'foo.bar.51.ston' writeStreamDo: [ :stream | stream nextPutAll: '51' ].
	dir / 'foo.bar.3.ston' writeStreamDo: [ :stream | stream nextPutAll: '3' ].
	dir / 'foo.bar.33.ston' writeStreamDo: [ :stream | stream nextPutAll: '33' ].
	dir / 'foo.bar.4.ston' writeStreamDo: [ :stream | stream nextPutAll: '4' ].
	dir / 'foo.bar.101.ston' writeStreamDo: [ :stream | stream nextPutAll: '101' ].
	dir / 'foo.bar.49.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	dir / 'foo.bar.5.ston' writeStreamDo: [ :stream | stream nextPutAll: '5' ].
	
	childFiles := dir files.
	self assert: childFiles size equals: 7.
	self assert: (dir nextNameFor: 'foo.bar' extension: 'ston') equals: 'foo.bar.102.ston' ]
		ensure: [ (filesystem / 'dir') ensureDeleteAll ].! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testChildOfReference
	| parent  child |
	parent := filesystem / 'griffle'.
	child := filesystem / 'griffle' / 'nurb'.
	self assert: (child isChildOf: parent).
	self deny: (parent isChildOf: child)! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testAsFileLocatorOrReferenceReturnsAReferenceWhenStringDoesNotReferToAKnownOrigin
	| fileRef result |
	fileRef := '/foo' asFileReference.
	
	result := fileRef asFileLocatorOrReference.
	
	self
		assert: result
		equals: fileRef.! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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) equals: 'plonk'.
	self assert: (absolute path at: 2) equals: 'griffle'.
	self assert: (absolute path at: 3) equals: 'zonk'.! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testRelativeToPath
	| parentPath child relative |
	parentPath := Path / 'griffle'.
	child := filesystem / 'griffle' / 'plonk' / 'nurb'.
	relative := child relativeTo: parentPath.
	self assert: relative equals: (Path * 'plonk' / 'nurb')! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testRootReference
	"Check that the root entry contains sensible values.
	On Windows this requires a pseudo entry to be available."

	| rootReference |

	rootReference := FileReference fileSystem: FileSystem disk path: Path root.

	self assert: rootReference isDirectory.
	self deny: rootReference isFile.
	self assert: rootReference size equals: 0.
	self assert: rootReference isReadable.
	self assert: rootReference isExecutable.
	self deny: rootReference isWritable.! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testReadStreamDo
	| ref path |
	path := Path * 'plonk'.
	filesystem store createFile: path.
	ref := filesystem referenceTo: path.
	[ ref readStreamDo: [ :stream | self deny: stream isNil ] ]
		ensure: [ ref delete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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 equals: 4.
	entries do: [:entry |
		self assert: entry class equals: MemoryDirectoryEntry.
		self assert: (ref = entry reference or: [ref contains: entry reference])].
	self assert: (entries collect: [ :ea | ea basename ]) equals: #('alpha' 'beta' 'gamma' 'delta') ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testPathRelativeTo
	| parent childPath relative |
	parent := filesystem / 'griffle'.
	childPath := Path / 'griffle' / 'plonk' / 'nurb'.
	relative := childPath relativeTo: parent.
	self assert: relative equals: (Path * 'plonk' / 'nurb')! !

!FileReferenceTest methodsFor: 'tests - handy utils' stamp: ''!
testLastFilesForExtension
	"This test verifies that we have the following ordering: 3 4 5 33 49 51 101"
	| childFiles |
	[ filesystem createDirectory: 'dir'.
	filesystem / 'dir' / 'games.51.ston' writeStreamDo: [ :stream | stream nextPutAll: '51' ].
	filesystem / 'dir' / 'games.3.ston' writeStreamDo: [ :stream | stream nextPutAll: '3' ].
	filesystem / 'dir' / 'games.33.ston' writeStreamDo: [ :stream | stream nextPutAll: '33' ].
	filesystem / 'dir' / 'games.4.ston' writeStreamDo: [ :stream | stream nextPutAll: '4' ].
	filesystem / 'dir' / 'games.101.ston' writeStreamDo: [ :stream | stream nextPutAll: '101' ].
	filesystem / 'dir' / 'games.49.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	filesystem / 'dir' / 'games.5.ston' writeStreamDo: [ :stream | stream nextPutAll: '5' ].
	
	childFiles := (filesystem root / 'dir') files.
	self assert: childFiles size equals: 7.
	self assert: ((filesystem root / 'dir') lastFileFor: 'games' extension: 'ston') basename equals: 'games.101.ston'.

	
			]
			ensure: [ (filesystem / 'dir') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testContainsPath
	| ref |
	ref := filesystem  * 'griffle'.
	self assert: (ref contains: (ref / 'nurp') path)! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testContainsReference
	| ref |
	ref := filesystem * 'griffle'.
	self assert: (ref contains: ref / 'nurp')! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testAsAbsoluteIdentity
	| ref |
	ref := filesystem / 'plonk'.
	self assert: ref asAbsolute identicalTo: ref! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testCommaAddsExtensionAgain
	| ref result |
	ref := filesystem * 'plonk.griffle'.
	result := ref , 'nurp'.
	self assert: result basename equals: 'plonk.griffle.nurp'! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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 segments equals: #('plonk' 'pinto' '..' 'griffle' 'zonk').! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWithExtentionReplacesExtension
	| ref result |
	ref := filesystem * 'plonk.griffle'.
	result := ref withExtension: 'nurp'.
	self assert: result isRelative.
	self assert: result basename equals: 'plonk.nurp'! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testIsAbsolute
	self assert: (filesystem / 'plonk') isAbsolute! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testResolve
	| ref |
	ref := filesystem / 'griffle'.
	self assert: ref resolve identicalTo: ref! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testEnsureDeleteNonEmptyDirectory
	| reference childReference |
	reference := filesystem / 'plonk'.	"Deletes the file if it exists"
	reference ensureCreateDirectory.
	[ self assert: reference exists.
	childReference := reference / 'child'.
	childReference ensureCreateFile.
	self assert: childReference exists.
	self should: [ reference ensureDelete ] raise: DirectoryIsNotEmpty ]
		ensure: [ reference ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testTempFilePrefixSuffix
	| fileRef |
	fileRef := FileReference newTempFilePrefix: 'FileReference' suffix: 'Test'.
	self assert: (fileRef isKindOf: FileReference).
	self assert: fileRef exists not.! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testChildren
	| ref children |
	[ filesystem createDirectory: '/alpha'.
	filesystem createDirectory: '/alpha/beta'.
	filesystem createDirectory: '/alpha/gamma'.
	ref := filesystem / 'alpha'.
	children := ref children.
	self assert: children size equals: 2.
	children
		do: [ :child | 
			self assert: child class equals: FileReference.
			self assert: (child isChildOf: ref).
			self assert: (#('beta' 'gamma') includes: child basename) ] ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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 ] ] ]
		ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests - handy utils' stamp: ''!
testNextNameForExtensionBrokenPattern
	
	| childFiles |
	[ filesystem createDirectory: 'dir'.
filesystem / 'dir' / 'games.51.ston' writeStreamDo: [ :stream | stream nextPutAll: '51' ].
	filesystem / 'dir' / 'games.ston' writeStreamDo: [ :stream | stream nextPutAll: 'nonumber' ].
	filesystem / 'dir' / 'games.stf' writeStreamDo: [ :stream | stream nextPutAll: 'wrong extension' ].
	filesystem / 'dir' / 'games.101.ston' writeStreamDo: [ :stream | stream nextPutAll: '101' ].
	filesystem / 'dir' / 'games.250.49.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	filesystem / 'dir' / 'games.1000.1000.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	filesystem / 'dir' / 'zorglub.500.ston' writeStreamDo: [ :stream | stream nextPutAll: '5' ].
	
	childFiles := (filesystem root / 'dir') files.
	self assert: childFiles size equals: 7.
	self assert: ((filesystem root / 'dir') nextNameFor: 'games' extension: 'ston') equals: 'games.102.ston'.

	
			]
			ensure: [ (filesystem / 'dir') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testParentResolutionWithRemoteReference
	| base relative absolute |
	base := filesystem / 'plonk' / 'pinto'.
	relative := filesystem referenceTo: '../griffle/zonk'.
	absolute := base resolve: relative.
	self assert: absolute isAbsolute.
	self assert: absolute path segments equals: #('plonk' 'pinto' '..' 'griffle' 'zonk')! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testCommaAddsExtension
	| ref result |
	ref := filesystem * 'plonk'.
	result := ref , 'griffle'.
	self assert: result basename equals: 'plonk.griffle'! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testIfAbsent
	| reference |
	reference := filesystem / 'plonk'.
	reference ensureCreateFile.
	[ reference ifAbsent: [ :file | self fail ].
	reference delete.
	self assert: (reference ifAbsent: [ 'plonk' ]) equals: 'plonk' ]
		ensure: [ reference ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testEnsureDelete
	| reference |
	reference := filesystem / 'plonk'.	"Deletes the file if it exists"
	reference ensureCreateFile.
	[ self assert: reference exists.
	reference ensureDelete.
	self deny: reference exists	"No-op if file does not exist" ]
		ensure: [ reference ensureDelete ]! !

!FileReferenceTest methodsFor: 'support' stamp: ''!
createFile: aPath
	filesystem ensureCreateDirectory: aPath parent.
	(filesystem resolve: aPath) writeStream close! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testRename
	| file tmp originalFullName |
	[ file := (FileLocator imageDirectory / 'oldName') ensureCreateFile.
	originalFullName := file fullName.
	tmp := (FileLocator imageDirectory / 'tmp') ensureCreateDirectory.
	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 - handy utils' stamp: ''!
testNextNameForExtensionNegativeTesting
	"When there is no file with the given pattern, then we default patterned name should be returned."
	
	[ filesystem createDirectory: 'dir'.
	filesystem / 'dir' / 'games.51.ston' writeStreamDo: [ :stream | stream nextPutAll: '51' ].
	filesystem / 'dir' / 'games.4.ston' writeStreamDo: [ :stream | stream nextPutAll: '4' ].
	filesystem / 'dir' / 'games.101.ston' writeStreamDo: [ :stream | stream nextPutAll: '101' ].
	filesystem / 'dir' / 'games.49.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	filesystem / 'dir' / 'games.5.ston' writeStreamDo: [ :stream | stream nextPutAll: '5' ].

	self assert: ((filesystem root / 'dir') nextNameFor: 'games' extension: 'stf') equals: 'games.1.stf'.
   self assert: ((filesystem root / 'dir') nextNameFor: 'plouf' extension: 'ston') equals:  'plouf.1.ston'.
	] ensure: [ (filesystem / 'dir') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testSlash
	| ref result |
	ref := filesystem * 'plonk'.
	result := ref / 'griffle'.
	self assert: result class equals: ref class.
	self assert: result  isRelative.
	self assert: (result path at: 1) equals: 'plonk'.
	self assert: (result path at: 2) equals: 'griffle'.! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWriteStreamDoExists
	| ref path |
	path := Path * 'plonk'.
	filesystem store createFile: path.
	ref := filesystem referenceTo: path.
	[ ref writeStreamDo: [ :stream | self deny: stream isNil ] ]
		ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testIfExists
	| reference |
	reference := filesystem / 'plonk'.
	reference ensureCreateFile.
	[ self assert: (reference ifExists: [ :file | file basename ]) equals: 'plonk'.
	reference delete.
	reference ifExists: [ :file | self fail ] ]
		ensure: [ reference ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testUnequalContent
	| a b |
	a := filesystem * 'plonk'.
	b := filesystem * 'griffle'.
	self deny: a equals: b! !

!FileReferenceTest methodsFor: 'tests - handy utils' stamp: ''!
testVersionNumberForComplexFileName
	
	| dir |
	[
		dir := filesystem / 'dir'.
		(dir / 'test?*file.ston') ensureCreateFile.
	
		self assert: (dir versionNumberFor: 'test?*file' extension: 'ston') equals: 0
	
	] 	ensure: [ (filesystem / 'dir') ensureDeleteAll ].! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testWriteStream
	| ref stream |
	ref := filesystem / 'plonk'.
	[ [ stream := ref writeStream ]
		ensure: [ stream ifNotNil: [ stream close ] ] ]
		ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testUnequalSize
	| a b |
	a := filesystem * 'plonk'.
	b := filesystem / 'plonk' / 'griffle'.
	self deny: a equals: b! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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 segments equals: #('plonk' 'pinto' '..' 'griffle' 'zonk').! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testCanonicalization

	| ref |

	ref := 'a/b/c' asFileReference canonicalize.
	self assert: ref path segments equals: #('a' 'b' 'c').

	ref := '/a/b/c' asFileReference canonicalize.
	self assert: ref path segments equals: #('a' 'b' 'c').

	ref := '../a/b/c' asFileReference canonicalize.
	self assert: ref path segments equals: #('..' 'a' 'b' 'c').

	ref := 'a/b/c/..' asFileReference canonicalize.
	self assert: ref path segments equals: #('a' 'b').

	ref := '/a/b/c/..' asFileReference canonicalize.
	self assert: ref path segments equals: #('a' 'b').

	ref := 'a/b/../c' asFileReference canonicalize.
	self assert: ref path segments equals: #('a' 'c').

	ref := '/a/b/../c' asFileReference canonicalize.
	self assert: ref path segments equals: #('a' 'c').! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testContents
	| ref contents |
	contents := '12345 abcdf!!'.
	ref := filesystem * 'file'.
	[ ref writeStreamDo: [ :stream | stream nextPutAll: contents ].
	self assert: ref contents asString equals: contents ]
		ensure: [ ref ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testHasDirectories
	[ | ref |
	filesystem createDirectory: '/alpha'.
	filesystem createDirectory: '/alpha/beta'.
	(filesystem / 'alpha' / 'beta' / 'delta') ensureCreateFile.
	filesystem createDirectory: '/alpha/gamma'.
	ref := filesystem / 'alpha'.
	self assert: ref hasDirectories.
	self deny: (ref / 'beta') hasDirectories.
	self deny: (ref / 'beta' / 'gamma') hasDirectories ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testDoesntContainLocator
	| ref |
	ref := filesystem * 'griffle'. 
	self deny: (ref contains: FileLocator image)! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testMakeRelative

	| parent child relative |
	parent := filesystem / 'griffle'.
	child := filesystem / 'griffle' / 'plonk' / 'nurb'.
	relative := parent makeRelative: child.
	self assert: relative equals: (Path * 'plonk' / 'nurb')! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testNextVersion

	| fs file versions |

	fs := FileSystem memory.
	file := fs / 'file.name'.
	versions := Array streamContents: [ :stream |
		5 timesRepeat: [ 
			file createFile.
			stream nextPut: file basename.
			file := file nextVersion. ] ].
	self assert: versions equals: #('file.name' 'file.1.name' 'file.2.name' 'file.3.name' 'file.4.name').

	fs := FileSystem memory.
	file := fs / 'file123.name.ext'.
	versions := Array streamContents: [ :stream |
		5 timesRepeat: [ 
			file createFile.
			stream nextPut: file basename.
			file := file nextVersion. ] ].
	self assert: versions equals: #('file123.name.ext' 'file123.name.1.ext' 'file123.name.2.ext' 'file123.name.3.ext' 'file123.name.4.ext').

	fs := FileSystem memory.
	file := fs / '123.ext'.
	versions := Array streamContents: [ :stream |
		5 timesRepeat: [ 
			file createFile.
			stream nextPut: file basename.
			file := file nextVersion. ] ].
	self assert: versions equals: #('123.ext' '123.1.ext' '123.2.ext' '123.3.ext' '123.4.ext').! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testParentResolutionWithAbsoluteReference
	| base relative absolute |
	base := filesystem / '/plonk' / 'pinto'.
	relative := filesystem / 'griffle' / 'zonk'.
	absolute := base resolve: relative.
	self assert: absolute fileSystem identicalTo: relative fileSystem.
	self assert: absolute isAbsolute.
	self assert: (absolute path at: 1) equals: 'griffle'.
	self assert: (absolute path at: 2) equals: 'zonk'! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testIsRoot
	self assert: (filesystem root) isRoot! !

!FileReferenceTest methodsFor: 'tests - handy utils' stamp: ''!
testVersionNumberForExtension
	
	| childFiles dir |

	[ filesystem createDirectory: 'dir'.
	dir := filesystem / 'dir'.
	dir / 'games.51.ston' writeStreamDo: [ :stream | stream nextPutAll: '51' ].
	dir / 'games.3.ston' writeStreamDo: [ :stream | stream nextPutAll: '3' ].
	dir / 'games.33.ston' writeStreamDo: [ :stream | stream nextPutAll: '33' ].
	dir / 'games.4.ston' writeStreamDo: [ :stream | stream nextPutAll: '4' ].
	dir / 'games.101.ston' writeStreamDo: [ :stream | stream nextPutAll: '101' ].
	dir / 'games.49.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	dir / 'games.5.ston' writeStreamDo: [ :stream | stream nextPutAll: '5' ].
	
	childFiles := dir files.
	self assert: childFiles size equals: 7.
	self assert: (dir versionNumberFor: 'games' extension: 'ston') equals: 101 ]
		ensure: [ (filesystem / 'dir') ensureDeleteAll ].


	[ filesystem createDirectory: 'dir'.
	dir := filesystem / 'dir'.
	dir / 'foo.bar.51.ston' writeStreamDo: [ :stream | stream nextPutAll: '51' ].
	dir / 'foo.bar.3.ston' writeStreamDo: [ :stream | stream nextPutAll: '3' ].
	dir / 'foo.bar.33.ston' writeStreamDo: [ :stream | stream nextPutAll: '33' ].
	dir / 'foo.bar.4.ston' writeStreamDo: [ :stream | stream nextPutAll: '4' ].
	dir / 'foo.bar.101.ston' writeStreamDo: [ :stream | stream nextPutAll: '101' ].
	dir / 'foo.bar.49.ston' writeStreamDo: [ :stream | stream nextPutAll: '49' ].
	dir / 'foo.bar.5.ston' writeStreamDo: [ :stream | stream nextPutAll: '5' ].
	
	childFiles := dir files.
	self assert: childFiles size equals: 7.
	self assert: (dir versionNumberFor: 'foo.bar' extension: 'ston') equals: 101 ]
		ensure: [ (filesystem / 'dir') ensureDeleteAll ].! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testDoesContainReferenceFileSystem
	| ref other |
	ref := filesystem * 'griffle'.
	other := filesystem / 'griffle' / 'nurp'.
	self assert: (ref contains: other)! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testDeleteIfAbsent
	| flag reference |
	flag := false.
	reference := filesystem / 'plonk'.
	reference ensureCreateFile.
	[ reference exists
		ifFalse: [ self error ].
	reference deleteIfAbsent: [ flag := true ].
	self deny: flag.
	reference exists
		ifTrue: [ self error ].
	reference deleteIfAbsent: [ flag := true ].
	self assert: flag ]
		ensure: [ reference ensureDelete ]! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
testContainsLocator
	| ref |
	ref := FileLocator imageDirectory resolve parent.
	self assert: (ref contains: FileLocator image)! !

!FileReferenceTest methodsFor: 'tests' stamp: ''!
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: ''!
testEntries
	[ | ref entries |
	filesystem createDirectory: '/alpha'.
	filesystem createDirectory: '/alpha/beta'.
	filesystem createDirectory: '/alpha/gamma'.
	ref := filesystem / 'alpha'.
	entries := ref entries.
	self assert: entries size equals: 2.
	entries do: [:entry |
		self assert: entry class equals: MemoryDirectoryEntry.
		self assert: (entry reference isChildOf: ref).
		self assert: (#('beta' 'gamma') includes: entry reference basename)] ]
		ensure: [ (filesystem / 'alpha') ensureDeleteAll ]! !

!FileRegistryTest methodsFor: 'tests' stamp: ''!
testFilesAreRegisteredInWeakRegistry

	|  f |
	f := (File named: 'asd.txt') writeStream.
	[self assert: (File registry keys includes: f)]
		ensure: [ f ifNotNil: [ f close ] ]! !

!FileRegistryTest methodsFor: 'tests' stamp: ''!
testRegistryShouldBeCleaned

	| oldSize |
	"We force some garbage collection to avoid noise in the test"
	3 timesRepeat: [Smalltalk garbageCollect].
	oldSize := File registry size.

	(File named: 'asd.txt') writeStream.
	3 timesRepeat: [Smalltalk garbageCollect].
	
	self assert: oldSize equals: File registry size! !

!FileServices commentStamp: ''!
Registered file services for specific file types.

To use me you can register a class by adding a method as: 

MyClass class>>fileReaderServicesForFile: fullName suffix: suffix
	<fileService>
	
	^ (FileStream isSourceFileSuffix: suffix)
		ifTrue: [ { self mySimpleServiceEntry1 . self mySimpleServiceEntry2 }]
		ifFalse: [#()]!
!FileServices class methodsFor: 'accessing' stamp: ''!
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.
	(Pragma allNamed: #fileService)
		do: [ :each | 
			services
				addAll:
					(each methodClass soleInstance
						perform: each methodSelector
						withArguments:
							{fullName.
							suffix}) ].
	^ services! !

!FileServices class methodsFor: 'accessing' stamp: ''!
itemsForDirectory: aFileDirectory
	"Answer a list of services appropriate when no file is selected."

	| services |
	services := OrderedCollection new.
	(Pragma allNamed: #directoryService)
		do: [ :each | services addAll: (each methodClass soleInstance perform: each methodSelector with: aFileDirectory) ].
	^ services! !

!FileServices class methodsFor: 'helper' stamp: ''!
suffixOf: aName
	"Answer the file extension of the given file"
	^ aName
		ifNil: ['']
		ifNotNil: [  aName asFileReference extension asLowercase]! !

!FileSystem commentStamp: ''!
I present a low-level protocol for interacting with filesystems. I hold a reference to
a store (a subinstance of FileSystemStore) which takes care of the details of performing 
file and directory operations on the filesystem I represent. 

I 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: 'public' stamp: ''!
beWritable

	store := store asWritableStore! !

!FileSystem methodsFor: 'public' stamp: ''!
delimiter
	"Return path delimiter used by this filesystem."

	^ store delimiter! !

!FileSystem methodsFor: 'public' stamp: ''!
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: 'accessing' stamp: ''!
root
	"Returns the root of the receiver filesystem, i.e. / on unix"
	^ self referenceTo: Path root! !

!FileSystem methodsFor: 'private' stamp: ''!
copyDirectoryAndDelete: sourcePath to: destination
	"Copy the directory sourcePath to the destination referred as destPath.
	If destination exists (and is a directory), add sourcePath basename to it,
	otherwise create destination as a directory a copy the contents of sourcePath in to it.
	If there is no file at sourcePath, raise FileDoesNotExist.
	If destPath is a file, raise FileExists.
	If an error occurs during the operation, try and roll back to the original state."

	"The source must be a directory"
	(self isDirectory: sourcePath) ifFalse: 
		[ (FileException fileName: sourcePath pathString)
				message: 'not a directory';
				signal ].
	"The destination musn't exist yet"
	destination ifExists: [ FileAlreadyExistsException signalWith: destination ].

	[self copyDirectory: sourcePath toReference: destination] 
		on: Error 
		do: [ :error |
			destination delete.
			error signal].
	(FileReference fileSystem: self path: sourcePath) deleteAll.
	^destination! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
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' stamp: ''!
copy: aPath toReference: destinationReference

	^self = destinationReference fileSystem
		ifTrue: [ self copy: aPath to: destinationReference resolve path ]
		ifFalse: [ self copy: aPath toRemote: destinationReference ]! !

!FileSystem methodsFor: 'public' stamp: ''!
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: 'accessing' stamp: ''!
workingDirectory
	"Returns a reference to the directory from where the image was launched"

	^ self referenceTo: self workingDirectoryPath! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isCaseSensitive
	^ self store isCaseSensitive! !

!FileSystem methodsFor: 'converting' stamp: ''!
stringFromPath: aPath
	^ store stringFromPath: aPath! !

!FileSystem methodsFor: 'public' stamp: ''!
inodeOf: aResolvable
	"Returns the inode number of aResolvable"

	^ store inodeOf: (self resolve: aResolvable)! !

!FileSystem methodsFor: '*Zinc-Resource-Meta-Core' stamp: 'nil'!
mimeTypesAt: aResolvable
	"Return the possible mime types for the given path."
	^ store mimeTypesAt: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public' stamp: ''!
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: ''!
entryAt: aResolvable
	"Answer the FileSystemDirectoryEntry for aResolvable"

	^ store entryAt: (self resolve: aResolvable) fileSystem: self.! !

!FileSystem methodsFor: 'initialization' stamp: ''!
initializeWithStore: aStore
	store := aStore! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
fileNamesAt: aResolvable
	^ Array streamContents: [ :out | 
		self fileNamesAt: aResolvable do: [ :path|
			out nextPut: path ]].! !

!FileSystem methodsFor: 'accessing' stamp: ''!
workingDirectoryPath
	^ store defaultWorkingDirectory! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isSymlink: aResolvable
	"Resolve the argument, and answer true if the result refers
	to a directory, false if it refers to a file or doesn't exist."

	^ store isSymlink: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
targetPath: aResolvable
	"Return the target file of the File described by aPath.  For a regular file, this is itself, for a symbolic link, it is the file pointed to by the symbolic link"

	^ store targetPath: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
directoryNamesAt: aResolvable do: aBlock
	| path |
	path := self resolve: aResolvable.
	store
		directoryAt: path
		directoryNodesDo: [ :node | 
			aBlock value: (store basenameFromEntry: node) ]! !

!FileSystem methodsFor: 'public' stamp: ''!
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: 'private' stamp: ''!
copyFrom: inputStream to: destPath
	| buffer out |
	out := nil.
	(self exists: destPath)
		ifTrue: [ store signalFileExists: destPath ].
	^ [ 
	out := self binaryWriteStreamOn: destPath.
	buffer := ByteArray new: 1024.
	[ inputStream atEnd ]
		whileFalse: [ 
			buffer := inputStream nextInto: buffer.
			out nextPutAll: buffer ]] ensure: [ out ifNotNil: [ out close ]]! !

!FileSystem methodsFor: 'public' stamp: ''!
beReadOnly

	store := store asReadOnlyStore! !

!FileSystem methodsFor: 'public' stamp: ''!
delete: aResolvable
	store delete: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isCharacter: aResolvable
	"Return a boolean indicating whether the File described by aPath is character based"

	^ store isCharacter: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isExecutable: aResolvable
	"Resolve the argument, and answer true if the there is
	a file or directory that can be read from."
	
	^ store isExecutable: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public' stamp: ''!
checkName: aString fixErrors: fixErrors
	^ store checkName: aString fixErrors: fixErrors! !

!FileSystem methodsFor: 'public' stamp: ''!
modificationTimeOf: aResolvable
	"Returns the last date of modification of aResolvable"

	^ store modificationTimeOf: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'comparing' stamp: ''!
= other
	^ self species = other species and: [self store = other store]! !

!FileSystem methodsFor: 'public' stamp: ''!
extensionDelimiter
	^ $.! !

!FileSystem methodsFor: 'public' stamp: ''!
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' stamp: ''!
open
	"Some kinds of filesystems need to open connections to external resources. Does nothing by default."
	
	store open! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
filesAt: aResolvable do: aBlock
	| path |
	path := self resolve: aResolvable.
	store
		directoryAt: path
		fileNodesDo: [ :entry | 
			aBlock value: path / (store basenameFromEntry: entry) ]! !

!FileSystem methodsFor: 'accessing' stamp: ''!
store: aFileSystemStore
	store := aFileSystemStore! !

!FileSystem methodsFor: 'public' stamp: ''!
resolve: aResolvable
	^ aResolvable asResolvedBy: self! !

!FileSystem methodsFor: 'navigating' stamp: ''!
* anObject
	"Return a relative reference."
	
	^ self referenceTo:( Path * anObject)! !

!FileSystem methodsFor: 'public' stamp: ''!
gidOf: aResolvable
	"Returns the group id of aResolvable"

	^ store gidOf: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
fileNamesAt: aResolvable do: aBlock
	| path |
	path := self resolve: aResolvable.
	store
		directoryAt: path
		fileNodesDo: [ :entry | 
			aBlock value: (store basenameFromEntry: entry) ]! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
numberOfHardLinks: 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 numberOfHardLinks: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
filesAt: aResolvable
	^ Array streamContents: [ :out | 
		self filesAt: aResolvable do: [ :path|
			out nextPut: path ]].! !

!FileSystem methodsFor: 'private' stamp: ''!
copyDirectory: sourcePath toReference: destination
	"Copy the source directory to the (yet to be created) destination"

	destination createDirectory.
	store directoryAt: sourcePath nodesDo:
		[ :entry | | basename |
			basename := store basenameFromEntry: entry.
			(store basicIsDirectory: entry) ifTrue: 
				[ self copyDirectory: sourcePath / basename toReference: destination / basename ]
			ifFalse:
				[ self copy: sourcePath / basename toReference: destination / basename ] ]! !

!FileSystem methodsFor: 'converting' stamp: ''!
pathFromObject: anObject 
	^ anObject asPathWith: self! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
entriesAt: aResolvable
	^ Array
		streamContents: [ :out | 
			self entriesAt: aResolvable do: [ :entry | out nextPut: entry ]
		]! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isReadable: aResolvable
	"Resolve the argument, and answer true if the there is
	a file or directory that can be read from."
	
	^ store isReadable: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public' stamp: ''!
permissions: aResolvable
	"Resolve the argument and return the Permissions for this file or directory "

	^ store permissions: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public' stamp: ''!
file: aResolvable posixPermissions: anInteger
	"Set the mode of aResolvable to anInteger (as defined by chmod())"

	^store file: (self resolve: aResolvable) posixPermissions: anInteger! !

!FileSystem methodsFor: 'public' stamp: ''!
ensureCreateDirectory: aResolvable
	"Resolve the argument to an absolute path, then ask the store to make
	sure that all the directories contained in the argument path exist or are created."
	
	store ensureCreateDirectory: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public' stamp: ''!
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-testing' stamp: ''!
hasChildren: aResolvable
	"Returns whether aResolvable has children."
	store directoryAt: (self resolve: aResolvable)
			ifAbsent: [ ^false ]
			nodesDo:  [ :node | ^true ].
	^false! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
childrenAt: aResolvable
	^ Array streamContents: [ :out | 
		self childrenAt: aResolvable do: [ :path|
			out nextPut: path ]].! !

!FileSystem methodsFor: 'public' stamp: ''!
creationTimeOf: aResolvable
	"Returns the creation date of aResolvable"

	^ store creationTimeOf: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
entriesAt: aResolvable do: aBlock
	| path entry |
	path := self resolve: aResolvable.
	store
		directoryAt: path
		nodesDo: [ :node | 
			entry := store entryFromNode: node path: path for: self.
			aBlock value: entry ]! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isHidden: aResolvable attributes: statAttributesArray
	"Resolve the argument, and answer a boolean indicating whether the file is hidden or not.
	statAttributesArray is optional and may be supplied for performance.  It is the result of File>>fileAttributes:mask: or nil"

	^ store isHidden: (self resolve: aResolvable) attributes: statAttributesArray! !

!FileSystem methodsFor: 'navigating' stamp: ''!
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. "

	^ self workingDirectoryPath resolve: aPath! !

!FileSystem methodsFor: 'public' stamp: ''!
copyAndDelete: sourcePath to: destination
	"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.
	If an error occurs during the operation, try and roll back to the original state."

	^(self isDirectory: sourcePath) ifTrue: 
		[ self copyDirectoryAndDelete: sourcePath to: destination ]
	ifFalse:
		[ self copyFileAndDelete: sourcePath to: destination ].! !

!FileSystem methodsFor: '*FileSystem-Disk' stamp: ''!
isDiskFileSystem
	^ store isDiskFileSystem! !

!FileSystem methodsFor: 'public' stamp: ''!
binaryReadStreamOn: aResolvable
	"Resolve the argument into an absolute path and open a file handle on the file
	at that path. Ask the handle to give us a read stream for reading the file."

	^ (self open: aResolvable writable: false) binaryReadStream.! !

!FileSystem methodsFor: 'printing' stamp: ''!
forReferencePrintOn: aStream
	store forReferencePrintOn: aStream! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isBlock: aResolvable
	"Return a boolean indicating whether the File described by aPath is a block device"

	^ store isBlock: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'comparing' stamp: ''!
hash
	^ store hash! !

!FileSystem methodsFor: 'public' stamp: ''!
binaryWriteStreamOn: 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 binary write stream for reading the file."

	^ (self open: aResolvable writable: true) binaryWriteStream.! !

!FileSystem methodsFor: 'public' stamp: ''!
copy: aPath toRemote: destRef
	| inputStream path |
	path := self resolve: aPath.
	[ inputStream := self binaryReadStreamOn: path.
	inputStream ifNil: [ store signalFileDoesNotExist: path ].
	destRef fileSystem copyFrom: inputStream to: destRef path ]
		ensure: [ inputStream ifNotNil: [ inputStream close ] ]! !

!FileSystem methodsFor: 'navigating' stamp: ''!
/ anObject
	"Return the absolute reference obtained by resolving anObject against the
	root of this filesystem."
	
	^ self root / anObject! !

!FileSystem methodsFor: 'accessing' stamp: ''!
store
	^ store! !

!FileSystem methodsFor: 'navigating' stamp: ''!
resolveString: aString
	"Returns the root of the receiver filesystem, i.e. / on unix"
	
	^ self workingDirectoryPath resolvePath: (store pathFromString: aString)! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
directoriesAt: aResolvable
	^ Array streamContents: [ :out | 
		self directoriesAt: aResolvable do: [ :path|
			out nextPut: path ]].! !

!FileSystem methodsFor: 'private' stamp: ''!
copyFileAndDelete: sourcePath to: destination
	"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.
	If an error occurs during the operation, try and roll back to the original state."

	[self copy: sourcePath toReference: destination] 
		on: Error 
		do: [ :error |
			destination ensureDelete.
			error signal].
	self delete: sourcePath.
	^destination! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
childNamesAt: aResolvable do: aBlock
	| path |
	path := self resolve: aResolvable.
	store
		directoryAt: path
		nodesDo: [ :entry | 
			aBlock value: (store basenameFromEntry: entry) ]! !

!FileSystem methodsFor: 'public' stamp: ''!
symlinkEntryAt: aResolvable
	"Answer the DiskSymlinkDirectoryEntry for aResolvable"

	^ store symlinkEntryAt: (self resolve: aResolvable) fileSystem: self.! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
hasDirectories: aResolvable
	self
		entriesAt: aResolvable
		ifAbsent: [  ^ false ]
		do: [ :entry | 
			entry isDirectory ifTrue: [ ^true ] ].
	^false! !

!FileSystem methodsFor: 'printing' stamp: ''!
printPath: aPath on: aStream
	store printPath: aPath on: aStream! !

!FileSystem methodsFor: 'public' stamp: ''!
move: sourcePath to: destination
	"Move the file /directory 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.
	If destPath is a directory, move the sourcePath in to the directory"

	| fullDestination destinationPath |

	destination isFile ifTrue: [ FileExists signalWith: destination ].
	destination isDirectory
		ifTrue: [ fullDestination := destination / sourcePath basename ]
		ifFalse: [ fullDestination := destination ].
	self = destination fileSystem ifTrue: 
	[
		destinationPath := fullDestination resolve path.
		sourcePath = destinationPath ifTrue: [ ^fullDestination ].
		"Ideally we would test whether the source and destination are on the same filesystem from the OSs perspective.
		Since we can't do that, just try rename, and if that fails, copy and delete."
		[ self rename: sourcePath to: destinationPath ]
			on: Error
			do: [ :error | self copyAndDelete: sourcePath to: fullDestination ].
	] ifFalse:
		[ self copyAndDelete: sourcePath to: fullDestination ].
	^fullDestination! !

!FileSystem methodsFor: 'public' stamp: ''!
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: ''!
uidOf: aResolvable
	"Returns the user id of aResolvable"

	^ store uidOf: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
childrenAt: aResolvable do: aBlock
	| path |
	path := self resolve: aResolvable.
	store
		directoryAt: path
		nodesDo: [ :entry | 
			aBlock value: path / (store basenameFromEntry: entry) ]! !

!FileSystem methodsFor: 'public' stamp: ''!
sizeOf: aResolvable
	"Resolve the argument and return the size for this file or directory "

	^ store sizeOf: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isRegular: aResolvable
	"Return a boolean indicating whether the File described by aPath is a regular file"

	^ store isRegular: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isSocket: aResolvable
	"Return a boolean indicating whether the File described by aPath is a regular file"

	^ store isSocket: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
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."
	
	^ store isWritable: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isFIFO: aResolvable
	"Return a boolean indicating whether the File described by aPath is FIFO"

	^ store isFIFO: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
directoriesAt: aResolvable do: aBlock
	| path |
	path := self resolve: aResolvable.
	store
		directoryAt: path
		directoryNodesDo: [ :entry | 
			aBlock value: path / (store basenameFromEntry: entry) ]! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
hasFiles: aResolvable
	self
		entriesAt: aResolvable
		ifAbsent: [  ^ false ]
		do: [ :entry | entry isFile ifTrue: [ ^true ] ].
	^false! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isDirectory: aResolvable
	"Resolve the argument, and answer true if the result refers
	to a directory, false if it refers to a file or doesn't exist."

	^ store isDirectory: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
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: '*FileSystem-Memory' stamp: ''!
isMemoryFileSystem
	^ store isMemoryFileSystem! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
childNamesAt: aResolvable
	^ Array streamContents: [ :out | 
		self childNamesAt: aResolvable do: [ :path|
			out nextPut: path ]].! !

!FileSystem methodsFor: 'public' stamp: ''!
changeTimeOf: aResolvable
	"Returns the change time of aResolvable"

	^ store changeTimeOf: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public' stamp: ''!
close
	store close! !

!FileSystem methodsFor: 'public' stamp: ''!
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: ''!
deviceIdOf: aResolvable
	"Returns the device id of aResolvable"

	^ store deviceIdOf: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public' stamp: ''!
file: aResolvable symlinkUid: uidInteger gid: gidInteger
	"Set the owner and group of aResolvable by numeric id."

	^store file: (self resolve: aResolvable) symlinkUid: uidInteger gid: gidInteger.! !

!FileSystem methodsFor: 'navigating' stamp: ''!
resolveReference: aReference
	^ aReference fileSystem = self ifTrue:
		[self workingDirectoryPath resolvePath: aReference path]! !

!FileSystem methodsFor: 'converting' stamp: ''!
pathFromString: aString
	^ store pathFromString: aString! !

!FileSystem methodsFor: 'public' stamp: ''!
file: aResolvable uid: uidInteger gid: gidInteger
	"Set the owner and group of aResolvable by numeric id."

	^store file: (self resolve: aResolvable) uid: uidInteger gid: gidInteger.! !

!FileSystem methodsFor: 'public' stamp: ''!
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: ''!
createDirectory: aResolvable
	"Resolve aResolvable into an absolute path, then as the store to create a directory there. 
	The store is expected to raise an exception if it cannot do so."

	^ store createDirectory: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'accessing' stamp: ''!
separator
	"Return path separator used by this filesystem."

	^ store separator! !

!FileSystem methodsFor: 'public-enumerating' stamp: ''!
directoryNamesAt: aResolvable
	^ Array streamContents: [ :out | 
		self directoryNamesAt: aResolvable do: [ :name|
			out nextPut: name ]].! !

!FileSystem methodsFor: 'public' stamp: ''!
accessTimeOf: aResolvable
	"Returns the access date of aResolvable"

	^ store accessTimeOf: (self resolve: aResolvable)! !

!FileSystem methodsFor: 'public-testing' stamp: ''!
isWritable 

	^ self store isWritable! !

!FileSystem methodsFor: 'private' stamp: ''!
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 methodsFor: '*Filesystem-Disk' stamp: ''!
* aFileOrDirectoryName
	^ self disk * aFileOrDirectoryName! !

!FileSystem class methodsFor: 'instance creation' stamp: ''!
store: aStore
	^ self basicNew
		initializeWithStore: aStore;
		yourself! !

!FileSystem class methodsFor: '*Filesystem-Disk' stamp: ''!
/ aFileOrDirectoryName
	^ self disk / aFileOrDirectoryName! !

!FileSystem class methodsFor: '*Filesystem-Zip' stamp: ''!
zip: aReference
	^ self store: (ZipStore reference: aReference)! !

!FileSystem class methodsFor: '*Filesystem-Disk' stamp: ''!
disk
	"Answer a filesystem that represents the 'on-disk' filesystem used by the host operating system."

	^ DiskStore currentFileSystem! !

!FileSystem class methodsFor: '*Filesystem-Disk' stamp: ''!
root
	^ self disk root! !

!FileSystem class methodsFor: '*FileSystem-Memory' stamp: ''!
currentMemoryFileSystem
	^ MemoryStore currentFileSystem! !

!FileSystem class methodsFor: '*Filesystem-Disk' stamp: ''!
workingDirectory
	^ self disk workingDirectory! !

!FileSystem class methodsFor: '*FileSystem-Memory' stamp: ''!
memory
	^ self store: MemoryStore new! !

!FileSystem class methodsFor: 'system startup' stamp: ''!
startUp: aBoolean
	"This is only here to deal with migration from older versions of
	FileSystem that wanted to receive startup notifcations."
	
	SessionManager default unregisterClassNamed: self name! !

!FileSystem class methodsFor: '*LibGit-FileSystem' stamp: ' 1/5/2022 21:01:26'!
onGitCommit: aCommit
	^ self store: (LGitCommitStore on: aCommit)! !

!FileSystem class methodsFor: '*Filesystem-Disk' stamp: ''!
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! !

!FileSystemDirectoryEntry commentStamp: ''!
I am a cache for metadata about a file, symbolic link or directory.

The set of attributes supported is platform dependent.  See the class comments of my subclasses for the details.!
!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
isReadable

	^false! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
permissions

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
basename

	^ reference basename! !

!FileSystemDirectoryEntry methodsFor: 'printing' stamp: ''!
printAttribute: anAttribute on: aStream

	[ (anAttribute value: self) printOn: aStream ]
		on: FileAttributeNotSupported 
		do: [ aStream << '(not supported)' ]! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
targetPath

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'cache management' stamp: ''!
getAccessAttributes
	"Noop by default"
	
	^self! !

!FileSystemDirectoryEntry methodsFor: '*Iceberg-Core' stamp: ''!
packageName 
	^ self asFileReference basenameWithoutExtension
! !

!FileSystemDirectoryEntry methodsFor: '*Compression' stamp: 'nil'!
addArchiveMemberAs: aName in: anArchive

	self isDirectory
		ifTrue: [ anArchive addDirectory: self reference as: aName ]
		ifFalse: [ anArchive addFile: self reference as: aName ]! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
uid

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
isDirectory
	"Return whether the receiver is a directory"

	^false! !

!FileSystemDirectoryEntry methodsFor: '*MonticelloFileTree-FileSystem-Utilities' stamp: ''!
readStreamDo: aBlock
    ^ reference readStreamDo: aBlock! !

!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
isFile

	^false! !

!FileSystemDirectoryEntry methodsFor: 'delegate' stamp: ''!
ifAbsent: aBlock
	"Return self, or evaluate the block if I do not exist"

	^ self exists ifTrue: [ self ] ifFalse: [ aBlock cull: self ]! !

!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
exists
	"Answer a boolean indicating whether the receivers file exists"

	^self reference exists! !

!FileSystemDirectoryEntry methodsFor: 'delegate' stamp: ''!
pathString
	"Answer the full path name of the receiver"

	^reference pathString! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
changeTime
	"Answer the files change time"

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
accessTime

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'delegate' stamp: ''!
writeStream
	^ reference writeStream! !

!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
isSocket

	^false! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
gid

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'delegate' stamp: ''!
ifExists: aBlock
	"Evaluate the block, unless I do not exist. If the receiver exists, pass it as argument to the block."

	^ self exists ifTrue: [ aBlock cull: self ] ifFalse: [ self ]! !

!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
isExecutable

	^false! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
mode

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'printing' stamp: ''!
printAttributeNamed: attributeName on: aStream

	aStream
		tab; 
		<< attributeName;
		<< ':';
		tab.
	self printAttribute: attributeName on: aStream.
	aStream cr.! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
size

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'delegate' stamp: ''!
ifExists: aBlock ifAbsent: anotherBlock
	"If the receiver exists, pass it as argument to aBlock. Else execute anotherBlock "

	^ self exists ifTrue: [ aBlock cull: self ] ifFalse: [ anotherBlock cull: self ]! !

!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
isRegular

	^false! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
reference
	^ reference! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
numberOfHardLinks

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
modificationTime

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'initialization' stamp: ''!
initializeWithReference: ref 

	super initialize.	
	reference := ref.! !

!FileSystemDirectoryEntry methodsFor: 'printing' stamp: ''!
printLongFormOn: aStream

	reference path printOn: aStream.
	aStream cr.
	self
		printAttributeNamed: #accessTime on: aStream;
		printAttributeNamed: #modificationTime on: aStream;
		printAttributeNamed: #changeTime on: aStream;
		printAttributeNamed: #creationTime on: aStream;
		printAttributeNamed: #deviceId on: aStream;
		printAttributeNamed: #inode on: aStream;
		printAttributeNamed: #fileSize on: aStream;
		printAttributeNamed: #uid on: aStream;
		printAttributeNamed: #gid on: aStream;
		printAttributeNamed: #numberOfHardLinks on: aStream;
		printAttributeNamed: #permissions on: aStream;
		printAttributeNamed: #targetPath on: aStream;
		printAttributeNamed: #isBlock on: aStream;
		printAttributeNamed: #isCharacter on: aStream;
		printAttributeNamed: #isDirectory on: aStream;
		printAttributeNamed: #isExecutable on: aStream;
		printAttributeNamed: #isFIFO on: aStream;
		printAttributeNamed: #isFile on: aStream;
		printAttributeNamed: #isReadable on: aStream;
		printAttributeNamed: #isSocket on: aStream;
		printAttributeNamed: #isSymlink on: aStream;
		printAttributeNamed: #isWritable on: aStream.! !

!FileSystemDirectoryEntry methodsFor: 'delegate' stamp: ''!
pathSegments
	^ reference pathSegments! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
creationTime
	"Answer the files creation time.
	Different platforms will interpret this in different ways."

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
deviceId

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
targetFileReference
	"Answer a FileReference representing the receivers target file"
	
	^FileReference fileSystem: reference fileSystem path: self targetPath.! !

!FileSystemDirectoryEntry methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream << 'DirectoryEntry: '.
	reference ifNotNil: [:ref | ref printOn: aStream].! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
creation
	^ self creationTime! !

!FileSystemDirectoryEntry methodsFor: 'delegate' stamp: ''!
fullName
	^ reference fullName! !

!FileSystemDirectoryEntry methodsFor: 'delegate' stamp: ''!
readStream
	^ reference readStream! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
inode

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
isHidden
	"Return whether the receiver is hidden"

	^false! !

!FileSystemDirectoryEntry methodsFor: 'delegate' stamp: ''!
extension
	^ reference extension! !

!FileSystemDirectoryEntry methodsFor: 'cache management' stamp: ''!
getStatAttributes
	"Noop by default"
	
	^self! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
permissions: permissions

	^FileAttributeNotSupported signalWith: self! !

!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
isSymlink

	^false! !

!FileSystemDirectoryEntry methodsFor: 'converting' stamp: ''!
asFileReference
	^ reference! !

!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
isFIFO

	^false! !

!FileSystemDirectoryEntry methodsFor: '*MonticelloFileTree-FileSystem-Utilities' stamp: ''!
name
    ^ self basename! !

!FileSystemDirectoryEntry methodsFor: 'accessing' stamp: ''!
modification
	^ self modificationTime! !

!FileSystemDirectoryEntry methodsFor: 'cache management' stamp: ''!
getAllAttributes
	"Noop by default"
	
	^self! !

!FileSystemDirectoryEntry methodsFor: 'testing' stamp: ''!
isWritable

	^false! !

!FileSystemDirectoryEntry class methodsFor: 'accessing' stamp: ''!
allPosixPermissions 
	^8r777! !

!FileSystemDirectoryEntry class methodsFor: 'instance creation' stamp: ''!
reference: aFileReference

	^self new initializeWithReference: aFileReference! !

!FileSystemDirectoryEntry class methodsFor: 'instance creation' stamp: ''!
reference: ref creation: cTime modification: mTime isDir: aBoolean size: anInteger posixPermissions: posixNumber isSymlink: symlinkBoolean
	"Create a directory entry given a file reference.
	This method is here for backward compatibility.  All other file attributes are retrieved independently."

	^ ref store isDiskFileSystem ifTrue: 
		[ DiskDirectoryEntry reference: ref ]
	ifFalse:
		[ MemoryDirectoryEntry reference: ref ]! !

!FileSystemDirectoryEntry class methodsFor: 'instance creation' stamp: ''!
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.
	This method is here for backward compatibility.  All other file attributes are retrieved independently."

	^ aFilesystem store isDiskFileSystem ifTrue: 
		[ DiskDirectoryEntry reference: (aFilesystem referenceTo: aPath) ]
	ifFalse:
		[ MemoryDirectoryEntry reference: (aFilesystem referenceTo: aPath) ]! !

!FileSystemDirectoryEntry class methodsFor: 'instance creation' stamp: ''!
fileSystem: aFilesystem path: aPath
	"Create a directory entry given a filesystem and a path in such filesystem.
	This method is here for backward compatibility, the appropriate subclass should be called directly, and not rely on the switch statement here."

	^ aFilesystem store isDiskFileSystem ifTrue: 
		[ DiskDirectoryEntry reference: (aFilesystem referenceTo: aPath) ]
	ifFalse:
		[ MemoryDirectoryEntry reference: (aFilesystem referenceTo: aPath) ]! !

!FileSystemError commentStamp: ''!
I am an abstract superclass for errors that may occur during filesystem operations.!
!FileSystemError methodsFor: 'initialization' stamp: ''!
initializeWithReference: aReference
	reference := aReference.
	messageText := aReference printString! !

!FileSystemError methodsFor: 'testing' stamp: ''!
isResumable
	^ true! !

!FileSystemError methodsFor: 'accessing' stamp: ''!
reference
	^ reference! !

!FileSystemError class methodsFor: 'instance creation' stamp: ''!
signalWith: aReference
	^ (self reference: aReference) signal! !

!FileSystemError class methodsFor: 'instance creation' stamp: ''!
reference: aReference
	^ self basicNew initializeWithReference: aReference! !

!FileSystemGuide commentStamp: ''!
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: 'initialization' stamp: ''!
initialize

	super initialize.
	work := OrderedCollection new! !

!FileSystemGuide methodsFor: 'showing' stamp: ''!
whileNotDoneDo: aBlock
	[ work isEmpty ] whileFalse: [ aBlock value ]! !

!FileSystemGuide methodsFor: 'accessing' stamp: ''!
selectChildren: aBlock
	"With this block you can control how the guide spreads over directories.
	Example: 
		self selectChildren: [ :parentEntry | parentEntry isSymlink not ].
		This will prevent the outer visitor to see any children of symlinked directories.
		
	Since the guides essentially rearrange the files visited controlling which children
	you see is the main concern of the guide. All the other visiting aspects can be 
	controlled in the visitor."
	selectChildren := aBlock! !

!FileSystemGuide methodsFor: 'showing' stamp: ''!
pushAll: aCollection 
	aCollection do: [ :ea | self push: ea ]! !

!FileSystemGuide methodsFor: 'adding' stamp: ''!
push: anObject
	work add: anObject! !

!FileSystemGuide methodsFor: 'removing' stamp: ''!
pop
	^ work removeLast! !

!FileSystemGuide methodsFor: 'showing' stamp: ''!
show: aReference
	self subclassResponsibility! !

!FileSystemGuide methodsFor: 'accessing' stamp: ''!
top
	^ work removeFirst! !

!FileSystemGuide methodsFor: 'testing' stamp: ''!
shouldVisitChildrenOf: anEntry
	^ selectChildren 
		ifNil: [ true ]
		ifNotNil: [ selectChildren cull: anEntry ]! !

!FileSystemGuide methodsFor: 'accessing' stamp: ''!
selectChildren
	^ selectChildren! !

!FileSystemGuide methodsFor: 'initialization' stamp: ''!
initializeWithVisitor: aVisitor
	self initialize.
	visitor := aVisitor.! !

!FileSystemGuide class methodsFor: 'instance creation' stamp: ''!
for: aVisitor
	^ self basicNew initializeWithVisitor: aVisitor! !

!FileSystemGuide class methodsFor: 'instance creation' stamp: ''!
show: aReference to: aVisitor
	^ (self for: aVisitor) show: aReference! !

!FileSystemGuide class methodsFor: 'instance creation' stamp: ''!
show: aReference to: aVisitor selecting: aBlock
	^ (self for: aVisitor)
		selectChildren:  aBlock;
		show: aReference! !

!FileSystemHandle commentStamp: ''!
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: 'streams' stamp: ''!
binaryReadStream
	
	self subclassResponsibility! !

!FileSystemHandle methodsFor: 'private' stamp: ''!
basicOpen
	"get the raw stream description from the filesystem's store"
	^ self fileSystem 
		openStreamDescription: reference path
		writable: writable! !

!FileSystemHandle methodsFor: 'public' stamp: ''!
at: offset write: buffer startingAt: start count: count
	self subclassResponsibility! !

!FileSystemHandle methodsFor: 'public' stamp: ''!
reopen
	self close.
	self open! !

!FileSystemHandle methodsFor: 'accessing' stamp: ''!
fileSystem
	^ reference fileSystem! !

!FileSystemHandle methodsFor: 'public' stamp: ''!
at: offset read: buffer startingAt: start count: count
	self subclassResponsibility! !

!FileSystemHandle methodsFor: 'public' stamp: ''!
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: ''!
ensureClosed
	reference ifExists: [ self close ]! !

!FileSystemHandle methodsFor: 'public' stamp: ''!
open
	self subclassResponsibility! !

!FileSystemHandle methodsFor: 'public' stamp: ''!
truncateTo: anInteger
	self subclassResponsibility! !

!FileSystemHandle methodsFor: 'initialization' stamp: ''!
setReference: aReference writable: aBoolean
	reference := aReference resolve.
	writable := aBoolean! !

!FileSystemHandle methodsFor: 'public' stamp: ''!
at: index
	| buffer |
	buffer := ByteArray new: 1.
	self at: index read: buffer startingAt: 1 count: 1.
	^ buffer at: 1! !

!FileSystemHandle methodsFor: 'public' stamp: ''!
sync
	self subclassResponsibility! !

!FileSystemHandle methodsFor: 'testing' stamp: ''!
isOpen
	self subclassResponsibility! !

!FileSystemHandle methodsFor: 'public' stamp: ''!
close
	self subclassResponsibility! !

!FileSystemHandle methodsFor: 'public' stamp: ''!
flush
	self subclassResponsibility! !

!FileSystemHandle methodsFor: 'accessing' stamp: ''!
reference
	^ reference! !

!FileSystemHandle methodsFor: 'testing' stamp: ''!
isWritable
	^ writable! !

!FileSystemHandle methodsFor: 'accessing' stamp: ''!
fullName
	^ reference fullName! !

!FileSystemHandle methodsFor: 'streams' stamp: ''!
binaryWriteStream
	
	self subclassResponsibility! !

!FileSystemHandle class methodsFor: 'instance creation' stamp: ''!
on: aReference writable: aBoolean
	^ self new setReference: aReference writable: aBoolean! !

!FileSystemHandle class methodsFor: 'instance creation' stamp: ''!
open: aReference writable: aBoolean
	^ (self on: aReference writable: aBoolean) open! !

!FileSystemHandleTest commentStamp: ''!
SUnit tests for FileSystemHandle!
!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
testSizeAfterGrow
	| out |
	out := #(1 2 3) asByteArray.
	handle at: 1 write: out startingAt: 1 count: 3.
	self assert: handle size equals: 3! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
testEnsureClosed
	filesystem := self createFileSystem.
	reference := filesystem * 'plonk'.
	handle := reference openWritable: true.
	handle ensureClosed.
	self deny: handle isOpen.
	handle ensureClosed.
	reference ensureDelete.
	handle reference exists
		ifTrue: [ self error ].
	handle ensureClosed! !

!FileSystemHandleTest methodsFor: 'running' stamp: ''!
tearDown
	handle ensureClosed.
	reference ensureDelete.
	super tearDown! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
testAtPutBinaryAscii
	handle at: 1 put: 32.
	handle at: 1 put: Character space! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
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 equals: 3.
	self assert: in equals: #(9 1 2 3 9) asByteArray! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
testAt
	handle at: 1 write: (ByteArray with: 3) startingAt: 1 count: 1.
	self assert: (handle at: 1) equals: 3! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
testCreatedOpen
	
	
	self flag: 'TODO: activated once FileHandle is in use again!!'.
	"self assert: handle isOpen"! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
testAtPut
	| in |
	handle at: 1 put: 3.
	in := ByteArray new: 1.
	handle at: 1 read: in startingAt: 1 count: 1.
	self assert: in first equals: 3! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
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 equals: in! !

!FileSystemHandleTest methodsFor: 'running' stamp: ''!
createFileSystem
	self subclassResponsibility! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
testAtWriteBinaryAscii
	handle
		at: 1
		write: #[32]
		startingAt: 1
		count: 1.
	handle
		at: 1
		write: (String with: Character space)
		startingAt: 1
		count: 1! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
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: ''!
testReference
	self assert: handle reference equals: reference asAbsolute! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
testClose
	handle close.
	self deny: handle isOpen! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
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 equals: 4! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
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 equals: 3! !

!FileSystemHandleTest methodsFor: 'tests' stamp: ''!
testWriteStream
	| stream |
	stream := handle binaryWriteStream.
	self assert: (stream respondsTo: #nextPut:)! !

!FileSystemHandleTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	filesystem := self createFileSystem.
	reference := filesystem * 'plonk'.
	handle := reference openWritable: true! !

!FileSystemHandleTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors 
	^ true! !

!FileSystemHandleTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #FileSystemHandleTest! !

!FileSystemPermission commentStamp: ''!
I'm a set of permissions for a Directory Entry!
!FileSystemPermission methodsFor: 'accessing' stamp: ''!
ownerRead
	^ self permissionBitAt: 9! !

!FileSystemPermission methodsFor: 'comparing' stamp: ''!
< other
	^ posixPermission < other posixPermission! !

!FileSystemPermission methodsFor: 'accessing' stamp: ''!
otherRead
	^ self permissionBitAt: 3! !

!FileSystemPermission methodsFor: 'comparing' stamp: ''!
>= other
	^ other posixPermission <= posixPermission! !

!FileSystemPermission methodsFor: 'comparing' stamp: ''!
= other
	^ other posixPermission = posixPermission! !

!FileSystemPermission methodsFor: 'comparing' stamp: ''!
hash

	^posixPermission hash! !

!FileSystemPermission methodsFor: 'testing' stamp: ''!
isReadable
	^ self ownerRead! !

!FileSystemPermission methodsFor: 'accessing' stamp: ''!
groupExecute
	^ self permissionBitAt: 4! !

!FileSystemPermission methodsFor: 'accessing' stamp: ''!
ownerExecute
	^ self permissionBitAt: 7! !

!FileSystemPermission methodsFor: 'accessing' stamp: ''!
ownerWrite
	^ self permissionBitAt: 8! !

!FileSystemPermission methodsFor: 'accessing' stamp: ''!
otherWrite
	^ self permissionBitAt: 2! !

!FileSystemPermission methodsFor: 'accessing' stamp: ''!
otherExecute
	^ self permissionBitAt: 1! !

!FileSystemPermission methodsFor: 'accessing' stamp: ''!
groupRead
	^ self permissionBitAt: 6! !

!FileSystemPermission methodsFor: 'accessing' stamp: ''!
groupWrite
	^ self permissionBitAt: 5! !

!FileSystemPermission methodsFor: 'private' stamp: ''!
posixPermission
	^ posixPermission! !

!FileSystemPermission methodsFor: 'comparing' stamp: ''!
> other
	^ other posixPermission < posixPermission! !

!FileSystemPermission methodsFor: 'accessing' stamp: ''!
permissionBitAt: bitIndex
	^ (posixPermission bitAt: bitIndex) == 1! !

!FileSystemPermission methodsFor: 'printing' stamp: ''!
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: ''!
isWritable
	^ self ownerWrite! !

!FileSystemPermission methodsFor: 'comparing' stamp: ''!
<= other
	^ (posixPermission > other posixPermission) not! !

!FileSystemPermission methodsFor: 'initialization' stamp: ''!
initialize: aNumber
	posixPermission := aNumber.
	self initialize.! !

!FileSystemPermission class methodsFor: 'instance creation' stamp: ''!
posixPermissions: aNumber
	^self basicNew 
		initialize: aNumber;
		yourself! !

!FileSystemPermission class methodsFor: 'instance creation' stamp: ''!
new 
	self error: 'Should not be called. Use #posixPermission: instead'! !

!FileSystemPermission class methodsFor: 'instance creation' stamp: ''!
default
	^ self posixPermissions: 8r777! !

!FileSystemResolver commentStamp: ''!
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.

To add your own origin, implement a method in one of my subclasses, which is annotated with <origin> and returns aFileReference. See my subclasses' "origin" procotol for examples. If necessary, you could also create your own subclass and add it to the list with something like this:


```
MyCustomFileSystemResolver class >> initialize [
	SessionManager default registerSystemClassNamed: self name atPriority: 100. "After FileLocator"
	self startUp: true.
	]
```

```	
MyCustomFileSystemResolver class >> startUp: resuming [
	resuming ifFalse: [ ^ self ].
	FileLocator addResolver: self new
	]
```

### Implementation

next
	The next resolver in the list, or nil
!
!FileSystemResolver methodsFor: 'resolving' stamp: ''!
resolve: aSymbol
	^ (self canResolve: aSymbol)
		ifTrue: [self perform: aSymbol]
		ifFalse: [self unknownOrigin: aSymbol]! !

!FileSystemResolver methodsFor: 'accessing' stamp: ''!
next
	^ next! !

!FileSystemResolver methodsFor: 'resolving' stamp: ''!
supportedOrigins
	^ (Pragma allNamed: #origin from: self class to: FileSystemResolver) collect: [:each | each methodSelector]! !

!FileSystemResolver methodsFor: 'resolving' stamp: ''!
unknownOrigin: aSymbol
	^ next ifNotNil: [next resolve: aSymbol]! !

!FileSystemResolver methodsFor: 'accessing' stamp: ''!
flushLocalCache! !

!FileSystemResolver methodsFor: 'resolving' stamp: ''!
resolveString: aString
	| fs |
	fs := FileSystem disk.
	^ FileReference 
		fileSystem: fs 
		path: (fs pathFromString: aString)! !

!FileSystemResolver methodsFor: 'accessing' stamp: ''!
flushCaches
	self flushLocalCache.
	next ifNotNil: [next flushCaches]! !

!FileSystemResolver methodsFor: 'resolving' stamp: ''!
canResolve: aSymbol
	^ self supportedOrigins includes: aSymbol! !

!FileSystemResolver methodsFor: 'accessing' stamp: ''!
addResolver: aResolver
	next
		ifNil: [next := aResolver]
		ifNotNil: [next addResolver: aResolver]! !

!FileSystemResolverTest commentStamp: ''!
SUnit tests for FileSystemResolver!
!FileSystemResolverTest methodsFor: 'running' stamp: ''!
createResolver
	self subclassResponsibility! !

!FileSystemResolverTest methodsFor: 'asserting' stamp: ''!
assertOriginResolves: aSymbol
	| reference |
	reference := resolver resolve: aSymbol.
	self assert: (reference isKindOf: FileReference).
	self assert: reference isAbsolute.
	self assert: reference exists.
	^ reference! !

!FileSystemResolverTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	resolver := self createResolver! !

!FileSystemResolverTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = FileSystemResolverTest! !

!FileSystemStore commentStamp: ''!
I am an abstract superclass for store implementations. My subclasses provide access to the actual data storage of a particular kind of filesystem. 

The file system can be accessed via
	FileSystem disk 
	FileSystem memory
	
My associated filesystem can be accessed as follows:
      DiskStore currentFileSystem!
!FileSystemStore methodsFor: '*FileSystem-Disk' stamp: ''!
isDiskFileSystem
	^ false! !

!FileSystemStore methodsFor: 'testing' stamp: ''!
isBlock: aPath
	"Return a boolean indicating whether the File described by aPath is a block device"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'private' stamp: ''!
filename: aByteString matches: aByteString2
	^ aByteString = aByteString2! !

!FileSystemStore methodsFor: 'accessing' stamp: ''!
delimiter
	^ self class delimiter! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
basicSizeOf: aNode
	"Used to get the size of the low-level representation (node / entry) "
	self subclassResponsibility! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
basicEntry: directoryEntry path: aPath nodesDo: aBlock
	self subclassResponsibility! !

!FileSystemStore methodsFor: 'public' stamp: ''!
isFile: aPath
	"slow solution for big directories!! "
	^ self 
		nodeAt: aPath 
		ifPresent: [ :entry | ^ self basicIsFile: entry ] 
		ifAbsent: [ ^ false ]! !

!FileSystemStore methodsFor: '*Zinc-Resource-Meta-Core' stamp: 'nil'!
mimeTypesAt: aPath
	| mimeType |
	mimeType := ZnMimeType 
						forFilenameExtension: aPath extension 
						ifAbsent: [  ^ nil ].
	^ Array with: mimeType! !

!FileSystemStore methodsFor: 'accessing' stamp: ''!
isCaseSensitive
	^ self class isCaseSensitive! !

!FileSystemStore methodsFor: 'converting' stamp: ''!
stringFromPath: aPath
	^ String streamContents: [ :out | 
		self printPath: aPath on: out ]! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
inodeOf: aPath
	"Return the inode number of the File described by aPath"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
basicPosixPermissions: aNode
	"Used to get the posix permissions from a low-level filesystem entry / node"
	self subclassResponsibility! !

!FileSystemStore methodsFor: 'public' stamp: ''!
exists: aPath
	self 
		nodeAt: aPath 
		ifPresent: [ :entry | ^ true ] 
		ifAbsent: [ ^ false ].! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
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: 'converting' stamp: ''!
printPath: aPath on: out
	"Use the unix convention by default, since it's the most common."
	
	aPath isAbsolute ifTrue: [ out nextPut: self delimiter ].
	^ aPath printOn: out delimiter: self delimiter! !

!FileSystemStore methodsFor: 'public' stamp: ''!
directoryAt: aPath ifAbsent: absentBlock nodesDo: aBlock
	^ self
		nodeAt: aPath
		ifPresent: [ :entry | 
			(self basicIsDirectory: entry)
				ifTrue: [ self basicEntry: entry path: aPath nodesDo: aBlock ]
				ifFalse: [ DirectoryDoesNotExist signalWith: aPath ] ]
		ifAbsent: absentBlock! !

!FileSystemStore methodsFor: 'error signalling' stamp: ''!
basicOpen: aPath writable: aBoolean
	"open the file at the given path and return an identifier"
	self subclassResponsibility! !

!FileSystemStore methodsFor: 'private' stamp: ''!
copy: sourcePath ifAbsent: absentBlock to: destinationPath ifPresent: presentBlock fileSystem: aFilesystem

	| buffer out in |
	
	in := nil.
	out := nil.
	buffer := nil.
	[
		in := aFilesystem binaryReadStreamOn: sourcePath.
		in ifNil: [ ^ absentBlock value ].
		
		(self exists: destinationPath)
			ifTrue: [ "cannot overwrite destination"
				^ presentBlock value ].
			
		out := aFilesystem binaryWriteStreamOn: 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: 'public' stamp: ''!
isSymlink: aPath
	aPath isRoot ifTrue: [ ^ true ].
	self 
		nodeAt: aPath 
		ifPresent: [ :entry | ^ self basicIsSymlink: entry ] 
		ifAbsent: [ ^ false ].! !

!FileSystemStore methodsFor: 'accessing' stamp: ''!
targetPath: aPath
	"Return the target file of the File described by aPath.  For a regular file, this is itself, for a symbolic link, it is the file pointed to by the symbolic link"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'public' stamp: ''!
directoryAt: aPath nodesDo: aBlock
	^ self
		nodeAt: aPath
		ifPresent: [ :entry | 
			(self basicIsDirectory: entry)
				ifTrue: [ self basicEntry: entry path: aPath nodesDo: aBlock ]
				ifFalse: [ DirectoryDoesNotExist signalWith: aPath ] ]
		ifAbsent: [ self signalDirectoryDoesNotExist: aPath ]! !

!FileSystemStore methodsFor: 'public' stamp: ''!
directoryAt: aPath  directoryNodesDo: aBlock
	^ self 
		directoryAt: aPath 
		nodesDo: [ :entry|
			(self basicIsDirectory: entry) 
				ifTrue: [ aBlock value: entry ]].! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
rename: sourcePath to: destinationPath
	self subclassResponsibility! !

!FileSystemStore methodsFor: 'public' stamp: ''!
sizeOf: aPath
	"Return the size of the File described by aPath"
	^ self 
		nodeAt: aPath 
		ifPresent: [ :entry | self basicSizeOf: entry ] 
		ifAbsent: [ self signalFileDoesNotExist: aPath ]! !

!FileSystemStore methodsFor: 'testing' stamp: ''!
isRegular: aPath
	"Return a boolean indicating whether the File described by aPath is a regular file"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'testing' stamp: ''!
isSocket: aPath
	"Return a boolean indicating whether the File described by aPath is a socket"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
delete: aPath
	self subclassResponsibility! !

!FileSystemStore methodsFor: 'public' stamp: ''!
isWritable: aPath
	self nodeAt: aPath 
		ifPresent: [ :entry | ^ self basicIsWritable: entry ] 
		ifAbsent: [ ^ false ].! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
basicCreationTimeOf: 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: 'testing' stamp: ''!
isCharacter: aPath
	"Return a boolean indicating whether the File described by aPath is character based"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'public' stamp: ''!
entryFromNode: node path: path for: aFileystem
	^self subclassResponsibility! !

!FileSystemStore methodsFor: 'testing' stamp: ''!
isExecutable: aPath
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'public' stamp: ''!
checkName: aString fixErrors: fixErrors
	^ self subclassResponsibility! !

!FileSystemStore methodsFor: 'public' stamp: ''!
modificationTimeOf: aPath
	"Returns the last date of modification of the File described by aPath"
	^ self 
		nodeAt: aPath 
		ifPresent: [ :entry | self basicModificationTimeOf: entry ] 
		ifAbsent: [ self signalFileDoesNotExist: aPath ].! !

!FileSystemStore methodsFor: 'error signalling' stamp: ''!
signalDirectoryExists: aPath
	^ DirectoryExists signalWith: aPath! !

!FileSystemStore methodsFor: 'testing' stamp: ''!
isFIFO: aPath
	"Return a boolean indicating whether the File described by aPath is FIFO"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
open
	"Some kinds of filesystems need to open connections to external resources"! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
nodeAt: aPath ifPresent: presentBlock ifAbsent: absentBlock
	self subclassResponsibility! !

!FileSystemStore methodsFor: 'public' stamp: ''!
isDirectory: aPath
	aPath isRoot ifTrue: [ ^ true ].
	self 
		nodeAt: aPath 
		ifPresent: [ :entry | ^ self basicIsDirectory: entry ] 
		ifAbsent: [ ^ false ].! !

!FileSystemStore methodsFor: 'accessing' stamp: ''!
gidOf: aPath
	"Return the gid of the File described by aPath"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: '*FileSystem-Memory' stamp: ''!
isMemoryFileSystem
	^ false! !

!FileSystemStore methodsFor: 'error signalling' stamp: ''!
signalFileExists: aPath
	^ FileExists signalWith: aPath! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
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: 'accessing' stamp: ''!
uid: aPath
	"Return the uid of the File described by aPath"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
basicIsSymlink: aNode
	^self subclassResponsibility! !

!FileSystemStore methodsFor: 'testing' stamp: ''!
checkExists: aPath

	(self exists: aPath) ifFalse:
		[ FileDoesNotExistException signalWith: aPath ].! !

!FileSystemStore methodsFor: 'accessing' stamp: ''!
numberOfHardLinks: aPath
	"Return the number of hard links to the File described by aPath"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
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: ''!
close
	"Some kinds of filesystems need to open connections to external resources"! !

!FileSystemStore methodsFor: 'private' stamp: ''!
entryAt: aPath fileSystem: aFilesystem

	self checkExists: aPath.
	^ FileSystemDirectoryEntry
		fileSystem: aFilesystem
		path: aPath! !

!FileSystemStore methodsFor: 'accessing' stamp: ''!
defaultWorkingDirectory
	^ Path root! !

!FileSystemStore methodsFor: 'accessing' stamp: ''!
deviceIdOf: aPath
	"Return the device id of the File described by aPath"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'abstract' stamp: ''!
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: 'error signalling' stamp: ''!
signalFileDoesNotExist: aPath
	^ FileDoesNotExistException
		signalWithFile: (File named: aPath asPath pathString)
		writeMode: false! !

!FileSystemStore methodsFor: 'testing' stamp: ''!
isReadable: aPath
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore methodsFor: 'converting' stamp: ''!
pathFromString: aString
	"Use the unix convention by default, since many filesystems are based on it."
	
	^ Path from: aString delimiter: self delimiter! !

!FileSystemStore methodsFor: 'public' stamp: ''!
basenameFromEntry: aNode
	"Used to extract the basename from the low-level representation (node / entry) from the store."
	self subclassResponsibility! !

!FileSystemStore methodsFor: 'public' stamp: ''!
permissions: aPath
	self nodeAt: aPath 
		ifPresent: [ :entry | ^ FileSystemPermission posixPermissions: (self basicPosixPermissions: entry) ] 
		ifAbsent: [ ^ FileSystemPermission default ].! !

!FileSystemStore methodsFor: 'public' stamp: ''!
ensureCreateDirectory: aPath
	((self exists: aPath) and: [ self isDirectory: aPath]) ifTrue: [ ^ self ].
	self ensureCreateDirectory: aPath parent.
	self createDirectory: aPath! !

!FileSystemStore methodsFor: 'error signalling' stamp: ''!
signalDirectoryDoesNotExist: aPath
	^ DirectoryDoesNotExist signalWith: aPath! !

!FileSystemStore methodsFor: 'public' stamp: ''!
directoryAt: aPath fileNodesDo: aBlock
	^ self 
		directoryAt: aPath 
		nodesDo: [ :entry|
			(self basicIsDirectory: entry) 
				ifFalse: [ aBlock value: entry ]].! !

!FileSystemStore methodsFor: 'private' stamp: ''!
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: 'abstract' stamp: ''!
createDirectory: aPath
	self subclassResponsibility! !

!FileSystemStore methodsFor: 'public' stamp: ''!
directoryAt: aPath ifAbsent: absentBlock fileNodesDo: aBlock
	^ self 
		directoryAt: aPath 
		ifAbsent: absentBlock 
		nodesDo: [ :entry|
			(self basicIsDirectory: entry) 
				ifFalse: [ aBlock value: entry ]].! !

!FileSystemStore methodsFor: 'public' stamp: ''!
nodeAt: aPath
	^ self 
		nodeAt: aPath 
		ifPresent: [ :node| node ]
		ifAbsent: [ NotFound signalFor: aPath in: self ]! !

!FileSystemStore methodsFor: 'public' stamp: ''!
creationTimeOf: aPath
	"Return the date of creation of the File described by aPath"
	^ self 
		nodeAt: aPath 
		ifPresent: [ :entry | self basicCreationTimeOf: entry ] 
		ifAbsent: [ self signalFileDoesNotExist: aPath ].! !

!FileSystemStore methodsFor: 'private' stamp: ''!
symlinkEntryAt: aPath fileSystem: aFilesystem

	^ DiskSymlinkDirectoryEntry
		fileSystem: aFilesystem
		path: aPath! !

!FileSystemStore methodsFor: 'accessing' stamp: ''!
separator
	^ self class separator! !

!FileSystemStore methodsFor: 'public' stamp: ''!
directoryAt: aPath ifAbsent: absentBlock directoryNodesDo: aBlock
	^ self 
		directoryAt: aPath 
		ifAbsent: absentBlock 
		nodesDo: [ :entry|
			(self basicIsDirectory: entry) 
				ifTrue: [ aBlock value: entry ]].! !

!FileSystemStore methodsFor: 'accessing' stamp: ''!
accessTimeOf: aPath
	"Return the date of last access of the File described by aPath"
	^FileAttributeNotSupported signalWith: self! !

!FileSystemStore class methodsFor: 'accessing' stamp: ''!
delimiter
	^ self shouldBeImplemented! !

!FileSystemStore class methodsFor: 'accessing' stamp: ''!
separator
	self shouldBeImplemented! !

!FileSystemStore class methodsFor: 'accessing' stamp: ''!
isCaseSensitive
	^ self shouldBeImplemented! !

!FileSystemTest commentStamp: ''!
I am an abstract file system test. 
I directly test 
- the public interface of a FileSystem using these methods directly
- the FileSystem in general through the operation methods of the FileReference!
!FileSystemTest methodsFor: 'tests' stamp: ''!
testCopyDestExists
	| out |
	
	self 
		markForCleanup: 'gooly'; 
		markForCleanup: 'plonk'.
		
	out := (filesystem  workingDirectory / 'gooly') writeStream.
	[out nextPutAll: 'gooly'] ensure: [out close].

	(filesystem  workingDirectory / 'plonk') writeStream close.
	
	self 
		should: [filesystem copy: 'gooly' to: 'plonk']
		raise: FileExists! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testEnsureDirectory
	| path |
	
	path := Path * 'plonk'.
	self markForCleanup: path.
	
	filesystem ensureCreateDirectory: path.
	self assert: (filesystem isDirectory: path).! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testEnsureDirectoryCreatesParent
	| path |
	path := Path * 'plonk' / 'griffle'.
	self markForCleanup: path.
	self markForCleanup: path parent.
	filesystem ensureCreateDirectory: path.
	self assert: (filesystem isDirectory: Path * 'plonk').
	self assert: (filesystem isDirectory: path)! !

!FileSystemTest methodsFor: 'tests - streams' stamp: ''!
testReadStreamDo
	| reference |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self 
		should: [ reference readStreamDo: [ :stream | self assert: false ] ] 
		raise: FileDoesNotExistException.
	reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ].
	self 
		assert: (reference readStreamDo: [ :stream | stream contents asString ]) 
		equals: 'griffle'! !

!FileSystemTest methodsFor: 'tests - streams compatibility' stamp: ''!
testBinaryReadStream
	| reference stream |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self should: [ reference binaryReadStream ] raise: FileDoesNotExistException.
	reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ].
	stream := reference binaryReadStream.
	self assert: stream contents asString equals: 'griffle'.
	stream close! !

!FileSystemTest methodsFor: 'tests - streams' stamp: ''!
testReadStreamDoIfAbsent
	| reference |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self assert: (reference 
		readStreamDo: [ :stream | false ]
		ifAbsent: [ true ]).
	reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ].
	self assert: (reference 
		readStreamDo: [ :stream | stream contents asString = 'griffle' ]
		ifAbsent: [ false ])! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testRootIsNotAFile
	self deny: (filesystem isFile: Path root)! !

!FileSystemTest methodsFor: 'tests - streams' stamp: ''!
testWriteStreamDo
	| reference |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self assert: (reference writeStreamDo: [ :stream |
		stream nextPutAll: 'griffle'.
		true ]).
	self assert: (filesystem workingDirectory / 'griffle') isFile.
	self assert: (reference writeStreamDo: [ :stream | true ])! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testDelimiter
	self assert: filesystem delimiter isCharacter! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testEnsureDirectoryExists
	| path |
	path := Path * 'plonk'.
	self markForCleanup: path.
	filesystem createDirectory: path.
	filesystem ensureCreateDirectory: path! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testWorking
	self assert: filesystem workingDirectory fileSystem equals: filesystem.
	self assert: filesystem workingDirectory path equals: filesystem workingDirectoryPath! !

!FileSystemTest methodsFor: 'tests - streams' stamp: ''!
testReadingAfterWriting
	| reference stream |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self deny: reference exists.
	reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ].
	stream := reference readStream.
	self assert: stream contents equals: 'griffle'.
	stream close! !

!FileSystemTest methodsFor: 'tests - streams' stamp: ''!
testWriteStreamIfPresent
	| reference stream |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	stream := reference writeStreamIfPresent: [ false ].
	stream nextPutAll: 'griffle'.
	stream close.
	self assert: (filesystem workingDirectory / 'griffle') isFile.
	self assert: (reference writeStreamIfPresent: [ true ])! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testCopy
	| out in contents |
	
	self
		markForCleanup: 'gooly';
		markForCleanup: 'plonk'.
		
	out := (filesystem workingDirectory / 'gooly') writeStream.
	[ out nextPutAll: 'gooly' ] ensure: [ out close ].
	filesystem copy: 'gooly' to: 'plonk'.
	
	in := (filesystem workingDirectory / 'plonk') readStream.
	contents := [ in contents asString ] ensure: [ in close ].
	self assert: contents equals: 'gooly'! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testFileNames
	"Ensure that file name character encoding works properly"
	| reference |
	#('test one' 'test with two' 'test-äöü' 'test.äöü' 'test-žřč') do: [ :each |
		reference := filesystem workingDirectory / each.
		"Enclose assertion failure text in blocks so that the string manipulation 
		only occurs on failure (which should be uncommon).
		Convert the strings to byte arrays so that the encoding can be easily seen."
		self assert: reference basename = each
			description: [ 'basename ', reference basename asByteArray printString, ' ~= ', each asByteArray printString ].
		self deny: reference exists
			description: [ reference basename, ' exists but should not' ].
		reference
			writeStreamDo: [ :stream | stream nextPutAll: 'gooly' ]
			ifPresent: [ self fail ].
		[	self assert: reference exists
				description: [ reference basename, ' should exist but does not' ].
			self assert: (filesystem workingDirectory children
					anySatisfy: [ :ref | ref = reference ])
				description: [ | childrenByteArrays |
					childrenByteArrays := filesystem workingDirectory children collect: [ :child |
						child basename asByteArray ].
					 'children ', childrenByteArrays printString, ' does not include ', reference basename asByteArray printString ] ]
		ensure: [ reference delete ] ]! !

!FileSystemTest methodsFor: 'running' stamp: ''!
tearDown
	toDelete
		select: [ :path | filesystem exists: path ]
		thenDo: [ :path | filesystem delete: path ].
	super tearDown! !

!FileSystemTest methodsFor: 'tests - directory entries' stamp: ''!
testDirectoryEntrySizeForDirectory

	| path entry |
	path := Path * 'plonk'.
	self markForCleanup: path.
	
	filesystem ensureCreateDirectory: path.
	
	entry := filesystem workingDirectory entries detect: [:each | each basename = 'plonk' ] ifNone: [ self fail: 'plonk test folder missing' ].
	self assert: entry size equals: 0! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testChildrenSortingRoot
	| directory1 directory2 |
	"self skip."
	
	directory1 := Path * 'plonk1'.
	directory2 := Path * 'plonk2'.
	
	filesystem createDirectory: directory1.
	filesystem createDirectory: directory2.
	
	self markForCleanup: directory1.
	self markForCleanup: directory2.
	
	self 
		assert: filesystem workingDirectory children sorted size 
		equals: filesystem workingDirectory children size! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testCreateDirectory
	| path |
	path := filesystem workingDirectory / 'plonk' / 'griffle'.
	(filesystem workingDirectory / 'plonk') ensureCreateDirectory.
	self shouldnt: [path createDirectory] raise:Error.
	self assert: path exists.
	(filesystem workingDirectory / 'plonk' )deleteAll.! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testCreateFileNotCreateParent
	| path |
	path := '/plonk/griffles' asFileReference.
	self should:[path createFile] raise: DirectoryDoesNotExist .
	self assert: path exists not! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testCreateDirectoryExists
	| path |
	
	path := Path * 'griffle'.
	self markForCleanup: path.
	
	filesystem createDirectory: path.
	self 
		should: [filesystem createDirectory: path]
		raise: DirectoryExists.! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testDefaultWorkingDirectory
	self assert: filesystem workingDirectory isRoot! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testRootIsDirectory
	self assert: (filesystem isDirectory: Path root)! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testEntriesAt
	| directory entries |
	directory := Path * 'plonk'.
	
	filesystem createDirectory: directory.
	filesystem createDirectory: directory / 'griffle'.
	filesystem createDirectory: directory / 'bint'.
	
	self 
		markForCleanup: directory / 'griffle';
		markForCleanup: directory / 'bint';
		markForCleanup: directory.
	
	entries := filesystem entriesAt: directory.
	self assert: entries size equals: 2.
	entries do: [ :ea | 
		self assert: (ea isKindOf: FileSystemDirectoryEntry).
		self assert: ea reference parent path equals: (filesystem resolve: directory).
		self assert: (#('griffle' 'bint' ) includes: ea reference basename).
		self assert: ea isDirectory ]! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testCopyAndDelete
	"Check that FileSystem>>copyAndDelete:to: works within a filesystem.
	DiskFileSystemTest>>testMoveMemoryToDisk checks that #copyAndDelete:to: works across filesystems."
	| folder testString f1 f1s f2 |
	
	folder := filesystem workingDirectory.
	testString := 'To be copied and deleted'.

	f1 := folder / 'f1'.
	f1s := f1 writeStream.
	[ f1s nextPutAll: testString ] ensure: [ f1s close ].
	f2 := folder / 'f2'.
	
	"Cleanup after running"
	self 
		markForCleanup: f1;
		markForCleanup: f2.	
	
	filesystem copyAndDelete: f1 to: f2.
	self deny: f1 exists.
	self assert: f2 exists.
	self assert: f2 contents equals: testString.! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testCreateDirectoryNoParent
	| path |
	path := Path * 'griffle' / 'nurp'.
	self 
		should: [filesystem createDirectory: path]
		raise: DirectoryDoesNotExist.! !

!FileSystemTest methodsFor: 'tests - streams' stamp: ''!
testWriteStreamDoIfPresent
	| reference |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self assert: (reference 
		writeStreamDo: [ :stream |
			stream nextPutAll: 'griffle'.
			true ]
		ifPresent: [ false ]).
	self assert: (filesystem workingDirectory / 'griffle') isFile.
	self assert: (reference 
		writeStreamDo: [ :stream | true ]
		ifPresent: [ true ])! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testNonExistentFileSize
	| base file1 file2 |
	
	base := filesystem workingDirectory.
	file1 := (base / 'file1') ensureCreateFile.
	file2 := (base / 'file2').
	self markForCleanup: base / 'file1'.
	
	self shouldnt: [ file1 size ] raise: FileDoesNotExistException.
	self should: [ file2 size ] raise: FileDoesNotExistException! !

!FileSystemTest methodsFor: 'tests - streams' stamp: ''!
testReadStreamIfAbsent
	| reference stream |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self assert: (reference readStreamIfAbsent: [ true ]).
	reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ].
	stream := reference readStreamIfAbsent: [ false ].
	self assert: stream contents asString equals: 'griffle'.
	stream close! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testChildrenAt
	| directory entries |
	directory := Path * 'plonk'.
	
	filesystem createDirectory: directory.
	filesystem createDirectory: directory / 'griffle'.
	filesystem createDirectory: directory / 'bint'.
	
	self markForCleanup: directory / 'griffle'.
	self markForCleanup: directory / 'bint'.
	self markForCleanup: directory.
	
	entries := filesystem childrenAt: directory.
	
	self assert: entries size equals: 2.
	entries do: [ :ea | 
		self assert: (ea isKindOf: Path).
		self assert: ea parent equals: (filesystem resolve: directory).
		self assert: (#('griffle' 'bint' ) includes: ea basename) ]! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testChildrenSorting
	| directory sorted |
	
	directory := Path * 'plonk'.
	
	filesystem createDirectory: directory.
	filesystem createDirectory: directory / 'alfa'.
	filesystem createDirectory: directory / 'beta'.
	
	self markForCleanup: directory / 'alfa'.
	self markForCleanup: directory / 'beta'.
	self markForCleanup: directory.
	
	sorted := (filesystem childrenAt: directory) sorted.
	self assert: sorted size equals: 2.
	self assert: (sorted at: 1) basename equals: 'alfa'.
	self assert: (sorted at: 2) basename equals: 'beta'! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testRootExists
	self assert: (filesystem exists: Path root)! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testCopySourceDoesntExist
	self 
		should: [filesystem copy: 'plonk' to: 'griffle']
		raise: FileDoesNotExistException! !

!FileSystemTest methodsFor: 'initialization' stamp: ''!
createFileSystem
	self subclassResponsibility! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testMoveToFailingExistingDestination
	| base file folder |
	
	base := filesystem workingDirectory.
	
	folder := (base / 'folder') ensureCreateDirectory. 
	(folder / 'newFile') ensureCreateFile.
	file := (base / 'file') ensureCreateFile.
	
	"Cleanup after running"
	self 
		markForCleanup: (base / 'folder' / 'newFile');
		markForCleanup: (base / 'folder');
		markForCleanup: (base / 'file').	
	
	"Destination exists already"
	self should: [ file moveTo: (folder / 'newFile') ] raise: Error.
	self assert: (base / 'file') exists.
	self assert: (folder / 'newFile') exists! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testMoveToFailingMissingSource
	| base folder |
	
	base := filesystem workingDirectory.
	
	folder := (base / 'folder') ensureCreateDirectory. 
	
	"Cleanup after running"
	self 
		markForCleanup: (base / 'folder' / 'newFile');
		markForCleanup: (base / 'folder').
	
	self deny: (base / 'file') exists.
	"Destination exists already"
	self should: [ (base / 'file') moveTo: (folder / 'newFile') ] raise: Error.
	self deny: (base / 'file') exists.
	self deny: (folder / 'newFile') exists! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testCopyWithCorrectBasename
	| directory |
 	self
        markForCleanup: 'gooly';
        markForCleanup: 'plonk'.
	directory := filesystem workingDirectory.
 	(directory / 'gooly') ensureCreateFile.
	directory / 'gooly' copyTo: directory / 'plonk'.
 
	self assert: (directory / 'plonk') exists.
 	self assert: (directory childNames includes: 'plonk')! !

!FileSystemTest methodsFor: 'tests - streams' stamp: ''!
testReadStream
	| reference stream |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self should: [ reference readStream ] raise: FileDoesNotExistException.
	reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ].
	stream := reference readStream.
	self assert: stream contents asString equals: 'griffle'.
	stream close! !

!FileSystemTest methodsFor: 'tests - streams' stamp: ''!
testWriteStream
	| reference stream |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	stream := reference writeStream.
	stream nextPutAll: 'griffle'.
	stream close.
	self assert: (filesystem workingDirectory / 'griffle') isFile.
	stream := reference writeStream.
	stream close! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testMoveTo
	| base file folder |
	
	base := filesystem workingDirectory.
	
	folder := (base / 'folder') ensureCreateDirectory. 
	file := (base / 'file') ensureCreateFile.
	
	"Cleanup after running"
	self 
		markForCleanup: (base / 'folder' / 'newFile');
		markForCleanup: (base / 'folder') ;
		markForCleanup: (base / 'file').	
	
	file moveTo: (folder / 'newFile').
	self deny: (base / 'file') exists.
	self assert: (folder / 'newFile') exists.! !

!FileSystemTest methodsFor: 'tests - streams compatibility' stamp: ''!
testBinaryReadStreamDoIfAbsent
	| reference |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self assert: (reference 
		binaryReadStreamDo: [ :stream | false ]
		ifAbsent: [ true ]).
	reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ].
	self assert: (reference 
		binaryReadStreamDo: [ :stream | stream contents asString = 'griffle' ]
		ifAbsent: [ false ])! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testCreateFile
	| path |
	path := filesystem workingDirectory / 'plonk' / 'griffles'.
	(filesystem workingDirectory / 'plonk') ensureCreateDirectory.
	self shouldnt: [ path createFile] raise:Error.
	self assert:path exists .
	(filesystem workingDirectory / 'plonk') deleteAll.! !

!FileSystemTest methodsFor: 'tests - streams compatibility' stamp: ''!
testBinaryReadStreamDo
	| reference |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self 
		should: [ reference binaryReadStreamDo: [ :stream | self assert: false ] ] 
		raise: FileDoesNotExistException.
	reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ].
	self 
		assert: (reference readStreamDo: [ :stream | stream contents asString ]) 
		equals: 'griffle'! !

!FileSystemTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	filesystem := self createFileSystem.
	toDelete := OrderedCollection new! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testDelete
	"Unlike ensureDelete, delete raises an exception if the file does not exist."
	| reference |
	
	reference := filesystem workingDirectory / 'does-not-exist'.
	self deny: reference exists.
	
	self 
		should: [ reference delete ]
		raise: FileDoesNotExistException.
		
		
	reference := ( filesystem workingDirectory / 'file') ensureCreateFile.
	reference delete.
	
	self deny: reference exists! !

!FileSystemTest methodsFor: 'tests - streams compatibility' stamp: ''!
testBinaryReadStreamIfAbsent
	| reference stream |
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle').
	self assert: (reference binaryReadStreamIfAbsent: [ true ]).
	reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ].
	stream := reference binaryReadStreamIfAbsent: [ false ].
	self assert: stream contents asString equals: 'griffle'.
	stream close! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testFile
	| path |
	
	path := Path * 'gooly'.
	self markForCleanup: path.
	
	(filesystem workingDirectory resolve: path) 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: ''!
testRoot
	self assert: filesystem root fileSystem equals: filesystem.
	self assert: filesystem root path equals: Path root.
	self assert: filesystem root isRoot.! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testNonExistentEntryAt
	| path1 path2  |
	path1 := Path * 'plonk1'.
	path2 := Path * 'plonk2'.
	self markForCleanup: path1.
	filesystem createDirectory: path1.

	self shouldnt: [ filesystem entryAt: path1 ] raise: FileDoesNotExistException.
	self should: [ filesystem entryAt: path2 ] raise: FileDoesNotExistException! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testMoveToFailingMissingDestination
	| base file |
	
	base := filesystem workingDirectory.
	
	file := (base / 'file') ensureCreateFile.
	
	"Cleanup after running"
	self 
		markForCleanup: (base / 'folder' / 'newFile');
		markForCleanup: (base / 'folder') ;
		markForCleanup: (base / 'file').	
	
	"Destination exists already"
	self deny: (base / 'folder') exists.
	self should: [ file moveTo: (base / 'folder' / 'newFile') ] raise: Error.
	self assert: (base / 'file') exists.
	self deny: (base / 'folder' / 'newFile') exists! !

!FileSystemTest methodsFor: 'tests - directory entries' stamp: ''!
testDirectoryEntrySizeForFile

	| entry reference |
 
	self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). 
	reference writeStreamDo: [ :stream | stream nextPutAll: 'Pharo' ].
	
	entry := filesystem workingDirectory entries detect: [:each | each basename = 'griffle' ] ifNone: [ self fail: 'griffle test file missing' ].
	self assert: entry size equals: 5! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testDirectory
	| path |
	
	path := Path * 'plonk'.
	self markForCleanup: path.
	
	filesystem createDirectory: path.
	
	self assert: (filesystem exists: path).
	self assert: (filesystem isDirectory: path).
	
	filesystem delete: path.
	self deny: (filesystem isFile: path).
	self deny: (filesystem exists: path)! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testCreateDirectoryNotCreateParent
	| path |
	path := filesystem workingDirectory / 'plonk' / 'griffle'.
	self should:[path createDirectory] raise: DirectoryDoesNotExist.
	self assert: path exists not! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
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 equals: path! !

!FileSystemTest methodsFor: 'initialization' stamp: ''!
markForCleanup: anObject
	toDelete add: (filesystem resolve: anObject)! !

!FileSystemTest methodsFor: 'tests' stamp: ''!
testEntryAt
	| path1 path2 entry1 entry2  |

	path1 := Path * 'plonk1'.
	path2 := Path * 'plonk2'.
	self markForCleanup: path1.
	self markForCleanup: path2.
	
	filesystem createDirectory: path1.
	(Delay forSeconds: 2) wait. "#creationTime seems limited to 1 second resolution"
	filesystem createDirectory: path2.
	
	entry1 := filesystem entryAt: path1.
	entry2 := filesystem entryAt: path2.
	
	self assert: entry1 isDirectory.
	self assert: entry2 isDirectory.
	self assert: entry1 reference equals: (filesystem referenceTo: path1) asAbsolute.
	self assert: entry2 reference equals: (filesystem referenceTo: path2) asAbsolute.

	self assert: entry1 creationTime < entry2 creationTime.
	self assert: entry1 modificationTime < entry2 modificationTime.! !

!FileSystemTest class methodsFor: 'accessing' stamp: ''!
packageNamesUnderTest
	^ #('FileSystem')! !

!FileSystemTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!FileSystemTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #FileSystemTest! !

!FileSystemTreeTest commentStamp: ''!
SUnit tests for a file system tree!
!FileSystemTreeTest methodsFor: 'running' stamp: ''!
createFile: aString
	self subclassResponsibility! !

!FileSystemTreeTest methodsFor: 'running' stamp: ''!
createDirectory: aString
	self subclassResponsibility! !

!FileSystemTreeTest methodsFor: 'running' stamp: ''!
setUpGreek
	self 
		createDirectory: '/alpha';
		createDirectory: '/alpha/beta';
		createFile: '/alpha/beta/gamma';
		createFile: '/alpha/beta/delta';
		createDirectory: '/alpha/epsilon';
		createFile: '/alpha/epsilon/zeta'! !

!FileSystemTreeTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #FileSystemTreeTest! !

!FileSystemVisitor commentStamp: ''!
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: ''!
visitDirectory: aReference
	^ self visitReference: aReference! !

!FileSystemVisitor methodsFor: 'visiting' stamp: ''!
visitReference: aReference! !

!FileSystemVisitor methodsFor: 'visiting' stamp: ''!
visitFile: aReference
	^ self visitReference: aReference! !

!FileTest commentStamp: ''!
Unit tests for file operations!
!FileTest methodsFor: 'tests' stamp: ''!
testCheckExistenceOfExistingFileThrowsException

	| file |
	file := File named: 'asd.txt'.
	file writeStream close.
	self should: [file checkDoesNotExist] raise: FileAlreadyExistsException! !

!FileTest methodsFor: 'tests' stamp: ''!
testOpeningForAppendSetsPositionAtEnd

	| file |
	(File named: 'asd.txt') writeStreamDo: [ :stream | stream nextPutAll: 'aaa' ].
	file := (File named: 'asd.txt') openForAppend.
	[ self assert: file position equals: 3
		] ensure: [ file ifNotNil: [ file close ] ]! !

!FileTest methodsFor: 'running' stamp: ''!
tearDown

	'asd.txt' asFileReference ensureDelete.
	super tearDown! !

!FileTest methodsFor: 'tests' stamp: ''!
testOpeningFileSetsPositionAtBeginning

	| file |
	(File named: 'asd.txt') writeStreamDo: [ :stream | stream nextPutAll: 'aaa' ].
	file := (File named: 'asd.txt') openForWrite.
	[self assert: file position equals: 0 
		] ensure: [ file ifNotNil: [ file close ] ]! !

!FileTest methodsFor: 'tests' stamp: ''!
testOpeningFileObjectCreatesFile

	(File named: 'asd.txt') writeStream close.
	"Our File implementation should not cache anything.
	This test is based on this assumption."
	self assert: (File named: 'asd.txt') exists! !

!FileTest methodsFor: 'tests' stamp: ''!
testOpeningFileNormallyDoesNotDeleteExistingFile

	| size |
	(File named: 'asd.txt') writeStreamDo: [ :stream | stream nextPutAll: 'aaa' ].

	size := (File named: 'asd.txt') size.
	self assert: size equals: 3! !

!FileTest methodsFor: 'tests' stamp: ''!
testFileDelete

	| file |
	file := File named: 'asd.txt'.
	file writeStream close.
	file delete.
	self deny: file exists.! !

!FileTest methodsFor: 'tests' stamp: ''!
testOpenFileForReadDoesNotDeleteExistingFile

	| size |
	(File named: 'asd.txt') writeStreamDo: [ :stream | stream nextPutAll: 'aaa' ].

	size := (File named: 'asd.txt') size.
	self assert: size equals: 3! !

!FileTest methodsFor: 'tests' stamp: ''!
testCheckExistenceOfNonExistingFileDoesNotThrowException

	| file |
	file := File named: 'asd.txt'.
	[file checkDoesNotExist] 
		on: FileAlreadyExistsException
		do: [ :ex | self assert: false description: 'File should not exist!!' ]! !

!FileTest methodsFor: 'tests' stamp: ''!
testFileExists

	| file |
	file := File named: 'asd.txt'.
	file writeStream close.
	self assert: file exists.
	file delete! !

!FileWriteError commentStamp: ''!
Notify about an error when trying to attempt to write to a file!
!FillBorderStyle commentStamp: ''!
BorderStyle supporting general (potentially composite) fillstyles. !
!FillBorderStyle methodsFor: 'geometry' stamp: ''!
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}! !

!FillBorderStyle methodsFor: 'accessing' stamp: ''!
fillStyle
	"Answer the value of fillStyle"

	^fillStyle ifNil: [self color]! !

!FillBorderStyle methodsFor: 'testing' stamp: ''!
hasFillStyle
	"Answer true."

	^true! !

!FillBorderStyle methodsFor: 'accessing' stamp: ''!
fillStyle: anObject
	"Set the value of fillStyle"

	fillStyle := anObject.
	anObject ifNotNil: [self baseColor: anObject asColor]! !

!FillBorderStyle methodsFor: 'drawing' stamp: ''!
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]! !

!FillStyle commentStamp: ''!
FillStyle is an abstract base class for fills in the BalloonEngine.!
!FillStyle methodsFor: 'testing' stamp: ''!
isOrientedFill
	"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
	^false! !

!FillStyle methodsFor: 'testing' stamp: ''!
isTranslucent
	^true "Since we don't know better"! !

!FillStyle methodsFor: 'testing' stamp: ''!
isCompositeFill
	"Answer whether the receiver is a composite fill.
	False by default."

	^false! !

!FillStyle methodsFor: 'converting' stamp: ''!
asColor
	^self subclassResponsibility! !

!FillStyle methodsFor: 'converting' stamp: ''!
mixed: fraction with: aColor
	^self asColor mixed: fraction with: aColor! !

!FillStyle methodsFor: 'accessing' stamp: ''!
scaledPixelValue32
	"Return a pixel value of depth 32 for the primary color in the fill style"
	^self asColor scaledPixelValue32! !

!FillStyle methodsFor: 'testing' stamp: ''!
isTransparent
	^false! !

!FillStyle methodsFor: 'testing' stamp: ''!
isBitmapFill
	^false! !

!FillStyle methodsFor: 'testing' stamp: ''!
isSolidFill
	^false! !

!FillStyle methodsFor: 'operating' stamp: ''!
fillRectangle: aRectangle on: aCanvas
	"Fill the given rectangle on the given canvas with the receiver."
	
	aCanvas fillRectangle: aRectangle basicFillStyle: self! !

!FillStyle methodsFor: 'testing' stamp: ''!
isGradientFill
	^false! !

!FillStyleBorder commentStamp: ''!
BorderStyle supporting general (potentially composite) fillstyles.!
!FillStyleBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!FilteredMorphTreeModel commentStamp: ''!
I'm a MorphTreeModel enriched with a filter text field. When a pattern is entered in the textfield, then only appropriate root items are drawn in the tree. Very useful to filter a list of items. This model should be used everywhere a filter is added on top of a list as in Nautilus

Examples:
	"An example with auto-accept for the filter 
	(accepted as you type is the default)"
	| model morph |
	model := FilteredMorphTreeModel new.
	model rootItems: Morph allSubclasses.
	morph :=  model defaultMorphIn: World.
	morph extent: 300@500.
	morph openInWorld
	
	"Another example with a ghost string, and the user 
	has to accept the filter contents explicitly 
	with a return  or CMD-S in the text field"
	| model morph |
	model := FilteredMorphTreeModel new 
		ghostString: 'Enter a pattern'; 
		autoAccept: false; 
		yourself.
	model rootItems: Morph allSubclasses.
	morph :=  model defaultMorphIn: World.
	morph extent: 300@500.
	morph openInWorld
	
	"A dialog window with a filtered list"
	| window m |
	window := StandardWindow new model: self.
	window title: 'Test runner'.
	m := FilteredMorphTreeModel new
		wrapBlockOrSelector: #selector;
		rootItems: Morph methods.
	window addMorph: (m defaultMorphIn: window) fullFrame: LayoutFrame identity.
	window openInWorld

Internal Representation and Key Implementation Points.
The initial root item list is kept locally.
See #rootItems:

Instance Variables
	ghostString:		<String>
	autoAccept:		<Boolean>
	initialItems:		<Collection>
	patternModel:		<RubScrolledTextModel>!
!FilteredMorphTreeModel methodsFor: 'accessing' stamp: ''!
ghostString
	^ ghostString! !

!FilteredMorphTreeModel methodsFor: 'accessing' stamp: ''!
ghostString: aString
	"set the help text that is displayed in the filter text field when empty"
	ghostString := aString! !

!FilteredMorphTreeModel methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	patternModel := RubScrolledTextModel new.
	patternModel announcer 
		when: RubTextUpdatedInModel 
		send: #whenPatternChanged: 
		to: self.
	autoAccept := true.
	ghostString := ''! !

!FilteredMorphTreeModel methodsFor: 'accessing' stamp: ''!
rootItems: aListOfItems
	"set the root items as in superclass with a copy + keep the list locally"
	initialRootItems := aListOfItems.
	super rootItems: initialRootItems copy.
	self updateList! !

!FilteredMorphTreeModel methodsFor: 'view' stamp: ''!
defaultMorphIn: aThemable
	| treeMorph patternMorph |
	treeMorph := self defaultTreeMorph buildContents.
	patternMorph := patternModel newTextField
		hResizing: #spaceFill;
		autoAccept: autoAccept;
		withGhostText: ghostString;
		textFont: StandardFonts defaultFont;
		yourself.
	patternMorph ghostTextRuler font: StandardFonts defaultFont.
	patternMorph  announcer when: RubReturnEntered  send: #whenReturnInFilter: to: self.
	^ self theme
		newColumnIn: aThemable
		for: {patternMorph. treeMorph}! !

!FilteredMorphTreeModel methodsFor: 'accessing - pattern' stamp: ''!
ensureSafePattern: aPattern
	" do not throw an error if the pattern is bad - important in case of auto-accepting"
	^ [ aPattern asRegexIgnoringCase ]
		on: RegexSyntaxError
		do: [ :ex | ]! !

!FilteredMorphTreeModel methodsFor: 'accessing - pattern' stamp: ''!
whenReturnInFilter: anAnnouncement 
	"needed if auto-accept is false"
	patternModel acceptEditsInView! !

!FilteredMorphTreeModel methodsFor: 'accessing - pattern' stamp: ''!
whenPatternChanged: anAnnouncement
	"just update the list"
	self updateList! !

!FilteredMorphTreeModel methodsFor: 'accessing' stamp: ''!
autoAccept: aBoolean
	"If true (default) the filter acts immediately on the list, else, the user has to enter a carriage return or to accept with cms-s"
	autoAccept := aBoolean! !

!FilteredMorphTreeModel methodsFor: 'accessing - pattern' stamp: ''!
pattern
	" the pattern to use to filter the list"
	^ self ensureSafePattern: patternModel getText asString trimBoth! !

!FilteredMorphTreeModel methodsFor: 'accessing' stamp: ''!
patternModel
	"The filter model"
	^ patternModel! !

!FilteredMorphTreeModel methodsFor: 'accessing - pattern' stamp: ''!
updateList
	"update the list by applying the pattern on the initial root item list"
	super rootItems: (self initialRootItems select: [ :p | (self pattern matchesIn: p name) notEmpty ]).
	super updateList! !

!FilteredMorphTreeModel methodsFor: 'accessing' stamp: ''!
initialRootItems
	"contains the full list, the filtered list is in rootItems"
	^ initialRootItems ifNil: [ initialRootItems := #() ]! !

!FilteredMorphTreeModel class methodsFor: 'examples' stamp: ''!
example
	"self example"

	| window row m |
	window := StandardWindow new model: self.
	window title: 'Test runner'.
	row := (m := self new)
		wrapBlockOrSelector: #selector;
		rootItems: Morph methods;
		defaultMorphIn: window.
	m updateList.
	window addMorph: row fullFrame: LayoutFrame identity.
	window openInWorld! !

!FindReplaceService commentStamp: ''!
Model for a find and replace service in editors!
!FindReplaceService methodsFor: 'accessing' stamp: ''!
isRegex: aBoolean
	isRegex := aBoolean.
	self findPolicyChanged
! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
entireWordsOnly
	^ entireWordsOnly ifNil: [entireWordsOnly := false]! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
entireWordsOnly: aBoolean
	entireWordsOnly := aBoolean.
	self findPolicyChanged! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
findStartIndex
	^ findStartIndex! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
convertedFindString
	| specials |
	specials := '^$:\+*[]()?'.
	^String 
		streamContents: [:s | self findString 
			do: [:c | (specials includes: c) ifTrue: [s nextPut:$\].
				s nextPut: c]]! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
findPolicyChanged

	self changed: #findPolicy! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
replaceText
	^ replaceText ifNil: [replaceText := '']! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
searchBackwards: aBoolean
	searchBackwards := aBoolean.
	self findPolicyChanged
! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
findText: aStringOrText isRegex: isReg caseSensitive: isCaseSensitive entireWordsOnly: forEntireWordsOnly
		self isRegex: isReg.
		self findText: aStringOrText.
		self entireWordsOnly: forEntireWordsOnly.
		self caseSensitive: isCaseSensitive! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
caseSensitive: aBoolean
	caseSensitive := aBoolean.
	self findPolicyChanged! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
findText: aStringOrText isRegex: aBoolean entireWordsOnly: forEntireWordsOnly
		self isRegex: aBoolean.
		self findText: aStringOrText.
		self entireWordsOnly: forEntireWordsOnly! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
findText
	^ (findText ifNil: [findText := '' asText. findText]) asString! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
findText: aStringOrText isRegex: aBoolean
		self isRegex: aBoolean.
		self findText: aStringOrText.
		self replaceText: ''.
! !

!FindReplaceService methodsFor: 'updating' stamp: ''!
updateFindStartIndexForTextMorph: aTextMorph
	| si |
	si := aTextMorph editor selectionInterval.
	self findStartIndex: (self searchBackwards ifTrue: [si first - 1] ifFalse: [si last + 1])! !

!FindReplaceService methodsFor: 'services' stamp: ''!
replaceInTextMorph: aTextMorph

	findStartIndex := self searchBackwards 
		ifTrue: [aTextMorph editor stopIndex] 
		ifFalse: [aTextMorph editor startIndex].
	(self findInTextMorph: aTextMorph)
		ifNotNil: [aTextMorph replaceSelectionWith: self replaceText]! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
wrapAround
	^ wrapAround ifNil: [wrapAround := true]! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
findStartIndex: anInteger
	findStartIndex := anInteger! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
findText: aStringOrText
	findText := aStringOrText asText.
	self findPolicyChanged.! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
selectionRegexString
	^ self convertedFindString
! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
replaceText: aStringOrText
	replaceText := aStringOrText asString.
	self findPolicyChanged
! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
wrapAround: aBoolean
	wrapAround := aBoolean.
	self findPolicyChanged

! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
caseSensitive
	^ caseSensitive ifNil: [caseSensitive := TextEditor caseSensitiveFinds]! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
regexString
	^ self isRegex 
		ifTrue: [self findString]
		ifFalse: [self convertedFindString]
! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
isRegex
	^ isRegex ifNil: [isRegex := false]! !

!FindReplaceService methodsFor: 'services' stamp: ''!
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: ''!
findInTextMorph: aTextMorph
	| where  |
	findStartIndex 
		ifNil: [findStartIndex := self searchBackwards 
			ifTrue: [aTextMorph editor stopIndex]
			ifFalse: [aTextMorph editor startIndex]].
	findStartIndex > 0 
		ifTrue: [where := aTextMorph
			findAndSelect: self findRegex
			startingAt: findStartIndex
			searchBackwards: self searchBackwards].
	(where isNil and: [self wrapAround])
		ifTrue: [ | idx |
			idx := self searchBackwards ifTrue: [aTextMorph editor string size] ifFalse: [1].
			where := aTextMorph
				findAndSelect: self findRegex
				startingAt: idx
				searchBackwards: self searchBackwards].
	where ifNil: [aTextMorph flash].
	^ where
! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
findString
	^ self findText asString! !

!FindReplaceService methodsFor: 'services' stamp: ''!
replaceAllInTextMorph: aTextMorph
	| startIdx |
	startIdx := self wrapAround ifTrue: [1] ifFalse: [aTextMorph editor selectionInterval first].
	aTextMorph replaceAll: self findRegex with: self replaceText startingAt: startIdx
! !

!FindReplaceService methodsFor: 'accessing' stamp: ''!
searchBackwards
	^ searchBackwards ifNil: [searchBackwards := false]! !

!FindReplaceService methodsFor: 'services' stamp: ''!
findRegex
	| s |
	self regexString ifEmpty: [ ^nil ].
	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 class methodsFor: 'instance creation' stamp: ''!
newFor: textArea

	"sublasses may use the text area object"
	^ self new! !

!Finder commentStamp: ''!
I'm the finderUI model in the MVC pattern.

I'm compute the search string and I construct a resultDictionary.
Then I throw events everywhere and my views are redrawn.!
!Finder methodsFor: 'private' stamp: ''!
disableUseRegEx
	"send a disable useRegEx dropbox event"
	^ self triggerEvent: #disableUseRegEx! !

!Finder methodsFor: 'private' stamp: ''!
enableUseRegEx
	"send an 'enableUseRegEx' dropbox event"
	^ self triggerEvent: #enableUseRegEx! !

!Finder methodsFor: 'accessing' stamp: ''!
environment: aCollection

	 environment := aCollection! !

!Finder methodsFor: 'private - selector' stamp: ''!
messagesNameSearch: aString
	"I'm searching for selectors"
	^ self useRegEx
		ifTrue: [ | regex |
			regex := aString asRegex.
			self methodSearch: [ :method| 	regex search: method selector asString ]]
		ifFalse: [
			self methodSearch: (self messageSearchBlockFrom: aString)]! !

!Finder methodsFor: 'accessing' stamp: ''!
resultDictionary
	"I should answer a dictionary"
	^resultDictionary! !

!Finder methodsFor: 'accessing' stamp: ''!
selectedClass

	^selectedClass! !

!Finder methodsFor: 'display' stamp: ''!
open
	<script: 'self new open'>
	
	^ (FinderUI on: self) open! !

!Finder methodsFor: 'private' stamp: ''!
constructDictionary
	"I construct the adequate dictionary regarding the search mode"

	self searchingString isEmpty ifTrue: [ ^self resultDictionary: Dictionary new ].
	[ :job|
		job title: 'Searching...' translated.
		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: 'accessing' stamp: ''!
environment

	 ^ environment ! !

!Finder methodsFor: 'accessing' stamp: ''!
searchingStringSilently: aString

	searchingString := aString
! !

!Finder methodsFor: 'private' stamp: ''!
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 - example' stamp: ''!
constructDictionaryWithMethodFinder: aString
	"construct dictionary when searching patterns"

	| result listOfResults listOfSelectors |
	result := Dictionary new.
	listOfResults := self computeWithMethodFinder: aString.
	listOfSelectors := listOfResults collect: [ :each | each selector ].
	self packagesSelection classesDo:[ :class | 
			class methodsDo:  [ :method | 
					| index |
					(index := listOfSelectors indexOf: method selector) = 0
						ifFalse: [ 
							| key value |
							key := listOfResults 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: 'checkbox' stamp: ''!
isExamplesSymbol
	"Answer if the current mode is Examples"
	^self currentSearchMode = #Examples! !

!Finder methodsFor: 'checkbox' stamp: ''!
isPragmasSymbol
	"Answer if the current mode is Pragmas"
	^self currentSearchMode = #Pragmas! !

!Finder methodsFor: 'private' stamp: ''!
sourceRegexSearch: aSearchString
	| regex |
	regex := aSearchString asRegex.
	^ self methodSearch: [ :method | regex search: method sourceCode ]! !

!Finder methodsFor: 'private - pragma' stamp: ''!
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 - example' stamp: ''!
computeWithMethodFinder: aString
	"Compute the selectors for the single example of receiver and args, in the very top pane"

	| data result dataObjects |
	(aString includes: $.)
		ifFalse: [ ^ #() ].	"delete trailing period. This should be fixed in the Parser!!"
	data := aString trimRight: [ :char | char isSeparator or: [ char = $. ] ].

	[ dataObjects := Smalltalk compiler evaluate: '{' , data , '}' ]
		on: SyntaxErrorNotification, RuntimeSyntaxError
		do: [ :e | 
			self inform: 'Syntax Error: ' , e errorMessage.
			^ #() ].	"#( data1 data2 result )"
	
	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.
			^ #() ].
		
	result := MethodFinder new findMethodsByExampleInput: dataObjects allButLast andExpectedResult: dataObjects last.
	result isEmpty ifTrue: [ self inform: 'no single method'. ^ #()].
	^ result.! !

!Finder methodsFor: 'private - class' stamp: ''!
constructClassNamesDictionary
	"Construct the dictionary in the case I'm searching in class names"
	
	| result listOfClasses |
	listOfClasses := self computeListOfClasses: self searchingString.
	result := Dictionary new.
	listOfClasses do: [:each | 
		result at: each put: (each selectors sort: [:a :b | a < b])].
	self resultDictionary: result! !

!Finder methodsFor: 'checkbox' stamp: ''!
isClassNamesSymbol
	"answer if the current mode is Classes"
	^self currentSearchMode = #Classes! !

!Finder methodsFor: 'accessing' stamp: ''!
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: ''!
selection: aSelectionHolder
	"anObject is a selection holder"
	"Depending of the value of currentSearchMode, I fill selectedMethod and SelectedClass with the good items."
	"Then, I update the source code text area"

	| path methodNode method classNode class |
	(aSelectionHolder isNil or: [aSelectionHolder selectedNodePath isNil]) ifTrue: [
		self selectedClass: nil.
		self selectedMethod: nil.
		^self].
	path := aSelectionHolder selectedNodePath.
	self isSelectorsSymbol
		ifTrue: [
			path first isSingle
				ifTrue: [
					method := path first itemMethod selector.
					class := path first itemMethod methodClass ]
				ifFalse: [
					methodNode := path first.
					classNode := path at: 2 ifAbsent: [ nil ]]].
	self isClassNamesSymbol
		ifTrue: [
			classNode := path first.
			methodNode := path at: 2 ifAbsent:[nil]].
	self isSourceSymbol
		ifTrue: [
			methodNode := path first.
			classNode := path at: 2 ifAbsent:[nil]].
	self isExamplesSymbol
		ifTrue: [
			methodNode := path first.
			classNode := path at: 2 ifAbsent:[nil]].
	self isPragmasSymbol
		ifTrue: [
			methodNode := path at:2 ifAbsent: [ nil ].
			classNode := path at: 3 ifAbsent:[nil]].		

	classNode ifNotNil: [ class := classNode item ].
	self selectedClass: class.
	
	methodNode ifNotNil: [ method := methodNode item ].
	self selectedMethod: method.
	
	self triggerEvent: #updateSourceCode! !

!Finder methodsFor: 'accessing' stamp: ''!
useRegEx: aBoolean

	useRegEx := aBoolean! !

!Finder methodsFor: 'accessing' stamp: ''!
selectedMethod
	"I should answer a CompiledMethod"
	^selectedMethod! !

!Finder methodsFor: 'accessing' stamp: ''!
useRegEx
	"I should answer a boolean that tells whether regExpression should be taken into account"
	 ^ useRegEx! !

!Finder methodsFor: 'private - class' stamp: ''!
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: 'default' stamp: ''!
defaultPackagesSelection
	 ^ self environment! !

!Finder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	searchingString := self defaultString.
	environment := self defaultEnvironment.
	packagesSelection := self defaultPackagesSelection.
	resultDictionary := Dictionary new.
	currentSearchMode := #Selectors.
	useRegEx := false
	! !

!Finder methodsFor: 'private' stamp: ''!
resetEnvironment
	"I send an event when I reset the environment"
	self environment: self defaultEnvironment.
	self triggerEvent: #resetEnvironment! !

!Finder methodsFor: 'accessing' stamp: ''!
searchingString

	^searchingString! !

!Finder methodsFor: 'private' stamp: ''!
sourceStringSearch: aSearchString 
	^ self 
		methodSearch: [ :method |
			method sourceCode includesSubstring: aSearchString caseSensitive: false ]! !

!Finder methodsFor: 'private - pragma' stamp: ''!
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 selector matchesRegexIgnoringCase: aString ]]
		ifFalse: [[ :pragma | pragma selector includesSubstring: aString caseSensitive: false ]].
	
	(Pragma all select: byCondition)
		do: [ :pragma |
			(result at: (pragma selector) ifAbsentPut: OrderedCollection new)				
				add: pragma method ].
	^ result! !

!Finder methodsFor: 'default' stamp: ''!
defaultString
	^ ''! !

!Finder methodsFor: 'private - selector' stamp: ''!
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)) ifNotNil: [ :aSymbol | [ :method | method selector = aSymbol ] ]! !

!Finder methodsFor: 'private - selector' stamp: ''!
constructDictionaryWithMessagesNameSearch: aString
	"Construct dictionary when searching for selector"
	
	| result listOfMethods |
	result := Dictionary new.
	listOfMethods := self messagesNameSearch: aString.
	listOfMethods do: [:method || key value |
			key := method selector.
			value := method methodClass.
			(result includesKey: key)
				ifTrue: [ (result at: key) add: value]
				ifFalse: [ result at: key put: (OrderedCollection new add: value; yourself)]].
	self resultDictionary: result! !

!Finder methodsFor: 'accessing' stamp: ''!
currentSearchMode
	"Getter"
	"I shoud answer a Symbol in :
		- #Selectors
		- #Classes
		- #Source
		- #Examples"
	
	 ^ currentSearchMode! !

!Finder methodsFor: 'checkbox' stamp: ''!
isSourceSymbol
	"Answer if the current mode is Source"
	^self currentSearchMode = #Source! !

!Finder methodsFor: 'private' stamp: ''!
classSearch: aSelectBlock
	| result |
	result := OrderedCollection new.
	self packagesSelection classesAndTraitsDo:[ :class | 
			(aSelectBlock value: class)
				ifTrue: [ result add: class ] ].
	^ result! !

!Finder methodsFor: 'accessing' stamp: ''!
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: ''!
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: ''!
selectedMethod: aMethod
	"When the method seletion is changed, I send an event to UI"
	selectedMethod := aMethod.
	self triggerEvent: #updateSelectedMethod! !

!Finder methodsFor: 'accessing' stamp: ''!
selectedClass: aClass
	"When the class seletion is changed, I send an event to UI"
	selectedClass := aClass.
	self triggerEvent: #updateSelectedClass
	! !

!Finder methodsFor: 'private' stamp: ''!
sourceSearch: aSearchString
	"I'm searching in sources"
	^ self useRegEx
		ifTrue: [ self sourceRegexSearch: aSearchString ]
		ifFalse:[ self sourceStringSearch: aSearchString ]! !

!Finder methodsFor: 'private' stamp: ''!
methodSearch: aSelectBlock 
	| result | 
	result := OrderedCollection new.
	aSelectBlock ifNil: [ ^result ].
	self packagesSelection classesAndTraits do:[ :class |
			class methodsDo: [ :method | 
				(aSelectBlock value: method) ifTrue: [ result add: method ]].
			class classSide methodsDo: [ :method | 
				(aSelectBlock value: method) ifTrue: [ result add: method ]]
			]
			displayingProgress: [ :aClass | aClass name ].
	^ result! !

!Finder methodsFor: 'accessing' stamp: ''!
packagesSelection: aCollection
	"I change the classes selection, then I rebuild the result dictionary"

	packagesSelection :=  aCollection.
	self constructDictionary! !

!Finder methodsFor: 'checkbox' stamp: ''!
isSelectorsSymbol
	"Answer if the current mode is Selectors"
	^self currentSearchMode = #Selectors! !

!Finder methodsFor: 'default' stamp: ''!
defaultEnvironment
	 ^ RBBrowserEnvironment new! !

!Finder methodsFor: 'accessing' stamp: ''!
packagesSelection
	"I should be a selection of classes"
	^packagesSelection! !

!Finder class methodsFor: 'menu' stamp: ''!
open
	<script>
	
	^ self new open! !

!Finder class methodsFor: 'menu' stamp: ''!
finderMenuOn: aBuilder 
	<worldMenu>

	(aBuilder item: #Finder)
		action: [self open];
		order: 2;
		parent: #Searching;
		help: 'Looking for something ?';
		icon: self icon.! !

!Finder class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]" 

	registry register: self as: #finder

	! !

!Finder class methodsFor: 'menu' stamp: ''!
icon

	^ FinderUI icon! !

!FinderClassNode commentStamp: ''!
A FinderClassNode is a node used by the FinderUI's tree representing a Class!
!FinderClassNode methodsFor: 'accessing' stamp: ''!
childNodeClassFromItem: anItem 
	"The children (if there are some) are instances of
	FinderMethodNode (in the case of a Classes research)"
	^ FinderMethodNode ! !

!FinderClassNode methodsFor: 'private' stamp: ''!
browseClass

	^ Smalltalk tools browser openOnClass: self item selector: self parentNode item! !

!FinderClassNode methodsFor: 'private' stamp: ''!
browseReferences

	self systemNavigation browseAllCallsOnClass: self item.! !

!FinderClassNode methodsFor: 'private' stamp: ''!
browseHierarchy

	self systemNavigation browseHierarchy: self item! !

!FinderClassNode methodsFor: 'private' stamp: ''!
browse

	self hasParentNode ifFalse: [ ^ super browseClass ].
	^ self browseClass! !

!FinderClassNode methodsFor: 'event handling' stamp: ''!
menu: menu shifted: aBoolean
	menu
		add: 'Hierarchy (h)'
		target: self
		selector: #browseHierarchy.
	menu
		add: 'References (N)'
		target: self
		selector: #browseReferences.
	^ super menu: menu shifted: aBoolean! !

!FinderClassNode methodsFor: 'accessing' stamp: ''!
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: ''!
keyDown: anEvent
	(anEvent controlKeyPressed or: [ anEvent commandKeyPressed ]) ifFalse: [ ^ false ].
	anEvent keyCharacter == $h ifTrue: [ ^ self browseHierarchy ].
	anEvent keyCharacter == $N ifTrue: [ ^ self browseReferences ].
	^ super keyDown: anEvent! !

!FinderExampleClassNode commentStamp: ''!
A FinderExampleClassNode is a node used by the FinderUI's tree representing the Class for the method deduced
from an examples (by MethodFinder)!
!FinderExampleClassNode methodsFor: 'displaying' stamp: ''!
displayString
	(self parentNode receiver isKindOf: self item)
		ifTrue: [ ^ '*' , super displayString ].
	^ super displayString! !

!FinderExampleMethodNode commentStamp: ''!
A FinderExampleMethodNode is a node used by the FinderUI's tree representing a Method deduced
from an examples (by MethodFinder)!
!FinderExampleMethodNode methodsFor: 'displaying' stamp: ''!
displayString

	^ String streamContents: [ :str | 
		  str
			  print: self item;
			  nextPutAll: ' -> ';
			  print: self item evaluate ]! !

!FinderExampleMethodNode methodsFor: 'accessing' stamp: ''!
childNodeClassFromItem: anItem
	"I answer the class of my children nodes (if I have some)"

	^ FinderExampleClassNode! !

!FinderExampleMethodNode methodsFor: 'private' stamp: ''!
selector
	^ self item selector! !

!FinderExampleMethodNode methodsFor: 'private' stamp: ''!
receiver
	"return the receiver of my item."
	^self item receiver! !

!FinderMethodNode commentStamp: ''!
A FinderMethodNode is a node used by the FinderUI's tree representing a Method!
!FinderMethodNode methodsFor: 'accessing' stamp: ''!
childNodeClassFromItem: anItem
	"I answer the class of my children nodes (if I have some)"
	^ FinderClassNode! !

!FinderMethodNode methodsFor: 'private' stamp: ''!
browseClass

	^ Smalltalk tools browser openOnClass: self parentNode item selector: self item! !

!FinderMethodNode methodsFor: 'event handling' stamp: ''!
addInspectMenuItem: menu

	self hasParentNode ifTrue: [ ^ super addInspectMenuItem: menu ]! !

!FinderMethodNode methodsFor: 'private' stamp: ''!
selector
	^ self item! !

!FinderMethodNode methodsFor: 'private' stamp: ''!
isSingle

	^ false! !

!FinderMethodNode methodsFor: 'private' stamp: ''!
browseSenders

	SystemNavigation new browseSendersOf: self selector name: 'Senders of ', self selector autoSelect: self selector! !

!FinderMethodNode methodsFor: 'event handling' stamp: ''!
menu: menu shifted: aBoolean
	
	menu
		add: 'Implementors (m)'
		target: self
		selector: #browseImplementors.
		
	menu
		add: 'Senders (n)'
		target: self
		selector: #browseSenders.
		
	^ super menu: menu shifted: aBoolean! !

!FinderMethodNode methodsFor: 'private' stamp: ''!
browse
	self item isSymbol	ifTrue: [ 	
		^ SystemNavigation new browseAllImplementorsOf: self item ].
	self item browse! !

!FinderMethodNode methodsFor: 'accessing' stamp: ''!
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: 'event handling' stamp: ''!
keyDown: anEvent
	(anEvent controlKeyPressed or: [ anEvent commandKeyPressed ]) ifFalse: [ ^ false ].
	anEvent keyCharacter == $n ifTrue: [ ^ self browseSenders ].
	anEvent keyCharacter == $m ifTrue: [ ^ self browseImplementors ].
	^ super keyDown: anEvent! !

!FinderMethodNode methodsFor: 'private' stamp: ''!
browseImplementors
	SystemNavigation new browseAllImplementorsOf: self selector 
		! !

!FinderMethodNode methodsFor: 'private' stamp: ''!
inspectItem
	self hasParentNode ifTrue: [ (self parentNode item compiledMethodAt: self item) inspect ]! !

!FinderNode commentStamp: ''!
A FinderNode is an abstract class used by the tree of FinderUI!
!FinderNode methodsFor: 'displaying' stamp: ''!
displayString
	
	^ self item asString! !

!FinderNode methodsFor: 'private' stamp: ''!
browseClass

	^ Smalltalk tools browser openOnClass: self item! !

!FinderNode methodsFor: 'event handling' stamp: ''!
addInspectMenuItem: menu

	menu
		add: 'Inspect (i)'
		target: self
		selector: #inspectItem! !

!FinderNode methodsFor: 'event handling' stamp: ''!
menu: menu shifted: aBoolean
	menu
		add: 'Browse (b)'
		target: self
		selector: #browse.
	self addInspectMenuItem: menu.
		
	menu addLine.
	menu
		add: 'Expand All'
		target: self model
		selector: #expandAll.
	menu
		add: 'Collapse All'
		target: self model
		selector: #collapseAll.
	^menu! !

!FinderNode methodsFor: 'private' stamp: ''!
browse

	self subclassResponsibility! !

!FinderNode methodsFor: 'private' stamp: ''!
doubleClick
	self browse! !

!FinderNode methodsFor: 'event handling' stamp: ''!
keyDown: anEvent
	(anEvent controlKeyPressed or: [ anEvent commandKeyPressed ]) ifFalse: [ ^ false ].
	anEvent keyCharacter == $b ifTrue: [ ^ self browse ].
	anEvent keyCharacter == $i ifTrue: [ ^ self inspectItem ]! !

!FinderNode methodsFor: 'testing' stamp: ''!
hasParentNode
	^ self parentNode isNil not! !

!FinderNode methodsFor: 'private' stamp: ''!
inspectItem
	self item inspect! !

!FinderPragmaMethodNode commentStamp: ''!
A FinderPragmaMethodNode is a method node for a selector name found by the pragma collector. Unlike a FinderMethod node, this node is not bound to unique compiled method, it is just the selector.!
!FinderPragmaMethodNode methodsFor: 'event handling' stamp: ''!
addInspectMenuItem: menu
! !

!FinderPragmaNode commentStamp: ''!
A FinderPragmaNode is a Node used to render a pragma in the Finder Tree!
!FinderPragmaNode methodsFor: 'private' stamp: ''!
displayString
	^ '<' , self item  , '>'! !

!FinderPragmaNode methodsFor: 'accessing' stamp: ''!
childNodeClassFromItem: anItem 
	
	^ FinderPragmaMethodNode ! !

!FinderPragmaNode methodsFor: 'private' stamp: ''!
browseClass! !

!FinderPragmaNode methodsFor: 'private' stamp: ''!
browseReferences

	self systemNavigation browseAllReferencesTo: self item! !

!FinderPragmaNode methodsFor: 'private' stamp: ''!
browseHierarchy! !

!FinderPragmaNode methodsFor: 'private' stamp: ''!
browse
	Smalltalk tools messageList browseSendersOf: self item! !

!FinderPragmaNode methodsFor: 'event handling' stamp: ''!
menu: menu shifted: aBoolean
	menu
		add: 'References (N)'
		target: self
		selector: #browseReferences.
	^ super menu: menu shifted: aBoolean! !

!FinderPragmaNode methodsFor: 'accessing' stamp: ''!
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: ''!
keyDown: anEvent
	(anEvent controlKeyPressed or: [ anEvent commandKeyPressed ]) ifFalse: [ ^ false ].
	anEvent keyCharacter == $h ifTrue: [ ^ self browseHierarchy ].
	anEvent keyCharacter == $N ifTrue: [ ^ self browseReferences ].
	^ super keyDown: anEvent! !

!FinderPragmaNode methodsFor: 'private' stamp: ''!
inspectItem
	(RBBrowserEnvironment default forPragmas: {self item}) methods inspect! !

!FinderSingleMethodNode commentStamp: ''!
A FinderSingleMethodNode is a node used to display a selector implemented only once in the system!
!FinderSingleMethodNode methodsFor: 'printing' stamp: ''!
displayString
	^ self itemMethod selector , ' (' , self itemMethod methodClass name , ')'! !

!FinderSingleMethodNode methodsFor: 'private' stamp: ''!
isSingle

	^ true! !

!FinderSingleMethodNode methodsFor: 'private' stamp: ''!
itemMethod
	| itemClass |
	itemClass := (self model resultDictionary at: self item) first.
	^ itemClass >> self item! !

!FinderSingleMethodNode methodsFor: 'accessing' stamp: ''!
childrenItems

	^ #()! !

!FinderUI commentStamp: ''!
A FinderUI is a UI used to render a Finder instance.

This tool is used to look for selectors, class, source code or patterns through the system, or through a specified environment!
!FinderUI methodsFor: 'buttons behavior' stamp: ''!
allClassesButtonState
	^ false! !

!FinderUI methodsFor: 'text areas behavior' stamp: ''!
buildDescriptionOf: aClass

	^ String streamContents: [ :stream | 
		  stream nextPutAll: aClass definitionString.
		  aClass hasComment ifTrue: [ 
			  stream
				  cr;
				  cr;
				  cr;
				  nextPutAll: aClass comment ] ]! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildBrowseButton
	^ (PluggableButtonMorph 
			on: self 
			getState: #browseButtonState 
			action: #browseButtonAction 
			label: #browseButtonLabel)
			hResizing: #spaceFill! !

!FinderUI methodsFor: 'items creation' stamp: ''!
addAllItems: aWindow
	| toolbar height btnFont btnToolbar cst |
	toolbar := self buildSearchModeToolBar: aWindow.
	height := toolbar minExtent y.
	cst := 15.
	aWindow
		addMorph: toolbar
		fullFrame:
			(LayoutFrame identity
				bottomFraction: 0;
				bottomOffset: height).
	aWindow
		addMorph: self buildPackagesTree buildContents
		fullFrame:
			(LayoutFrame identity
				bottomFraction: 0.58;
				topOffset: height).
	btnFont := StandardFonts buttonFont.
	btnToolbar := self buildBrowseToolBar: aWindow.
	aWindow
		addMorph: btnToolbar
		fullFrame:
			(LayoutFrame identity
				topFraction: 0.58;
				bottomFraction: 0.58;
				bottomOffset: btnFont height + cst).
	aWindow
		addMorph: self sourceTextArea
		fullFrame:
			(LayoutFrame identity
				topFraction: 0.58;
				topOffset: btnFont height + cst)! !

!FinderUI methodsFor: 'accessing' stamp: ''!
selectedClass
	^ self finder selectedClass! !

!FinderUI methodsFor: 'mode list' stamp: ''!
isExamplesSymbol
	^self finder isExamplesSymbol! !

!FinderUI methodsFor: 'mode list' stamp: ''!
isPragmasSymbol
	^self finder isPragmasSymbol! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildPackagesTree
	^ self defaultTreeMorph! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
environmentButtonLabel
	^ 'Packages...'! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
searchButtonState
	^ false! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
environmentButtonState
	^ false! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
implementorsButtonLabel
	^'Implementors'! !

!FinderUI methodsFor: 'private' stamp: ''!
updateSelectedClass
	self changed: #selectedClass! !

!FinderUI methodsFor: 'accessing' stamp: ''!
selection: aSelection
	
	super selection: aSelection.
	self finder selection: aSelection! !

!FinderUI methodsFor: 'items creation' stamp: ''!
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: 'buttons behavior' stamp: ''!
hierarchyButtonAction
	self hierarchy! !

!FinderUI methodsFor: 'private' stamp: ''!
implementors
	self selectedMethod ifNil: [ ^ self ].
	SystemNavigation new browseAllImplementorsOf: self selectedMethod! !

!FinderUI methodsFor: 'private' stamp: ''!
openPackageChooser
	(DialogItemsChooser
		on: self
		unselectedItems: self constructPackagesSet
		selectedItems: (self constructPackagesSet: self packagesSelection)
		selectedItemsSetterSelector: #collectFromPackages: 
		title: 'Package Chooser'
		unselectedItemsLabel: 'Unselected Packages' translated
		selectedItemsLabel: 'Selected Packages' translated) open! !

!FinderUI methodsFor: 'text areas behavior' stamp: ''!
shoutAboutToStyle: aPluggableShoutMorphOrView

	aPluggableShoutMorphOrView classOrMetaClass: self selectedClass.
	self selectedClass ifNil: [^ false].
	self selectedMethod ifNil: [^ false].
	^ true! !

!FinderUI methodsFor: 'accessing' stamp: ''!
sourceTextArea
	^ sourceTextArea ifNil: [ self buildSourceTextArea ]! !

!FinderUI methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass

	^ self selectedClass! !

!FinderUI methodsFor: 'accessing' stamp: ''!
currentSearchMode
	^self finder currentSearchMode! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
sendersButtonLabel
	^ 'Senders'! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
inheritanceButtonState
	^ self selectedClass isNil | self isClassNamesSymbol! !

!FinderUI methodsFor: 'mode list' stamp: ''!
isSelectorsSymbol
	^self finder isSelectorsSymbol! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
hierarchyButtonLabel
	^ 'Hierarchy'! !

!FinderUI methodsFor: 'private' stamp: ''!
packagesSelection
	^self finder packagesSelection! !

!FinderUI methodsFor: 'checkbox' stamp: ''!
disableUseRegEx
	useRegExCheckbox isSelected
		ifTrue: [ useRegExCheckbox toggleSelected ].
	useRegExCheckbox enabled: false! !

!FinderUI methodsFor: 'checkbox' stamp: ''!
enableUseRegEx
	useRegExCheckbox 
		enabled: true;
		updateEnabled! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
searchButtonAction
	forceSearch := true.
	self searchingTextArea contentMorph acceptTextInModel! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
hierarchyButtonState
	^ self selectedClass isNil! !

!FinderUI methodsFor: 'private' stamp: ''!
constructPackagesSet
	| result |
	result := (self environment packages collect: [:each | each name])
		difference: (self packagesSelection packages collect: [:each | each name]).
	^ result asSet asSortedCollection: [ :a :b | a < b ]! !

!FinderUI methodsFor: 'display' stamp: ''!
open
	 
	| window |
	window := StandardWindow new model: self.
	self addAllItems: window.
	window setLabel: self defaultWindowLabel.
	window openInWorld.
	self searchingTextArea contentMorph takeKeyboardFocus! !

!FinderUI methodsFor: 'items creation' stamp: ''!
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; 
			keyDownActionSelector: #keyDown:;
			multiSelection: self multiSelection;
			autoMultiSelection: self autoMultiSelection;
			isCheckList: self isCheckList;
			doubleClickSelector: #doubleClick;
			getMenuSelector: #menu:shifted:! !

!FinderUI methodsFor: 'do it requirements' stamp: ''!
doItReceiver

	^ self selectedClass ifNotNil: [ :selectedClass | selectedClass instanceSide ]! !

!FinderUI methodsFor: 'text areas behavior' stamp: ''!
updateSourceCode
	self sourceTextModel setText: self sourceCode ! !

!FinderUI methodsFor: 'private' stamp: ''!
keyDown: event
	self selectedNode ifNotNil: [:node | node keyDown: event]! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
sendersButtonState
	^ self selectedMethod isNil | self isClassNamesSymbol! !

!FinderUI methodsFor: 'mode list' stamp: ''!
isClassNamesSymbol

	^self finder isClassNamesSymbol! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildVersionsButton
	^ (PluggableButtonMorph 
			on: self 
			getState: #versionsButtonState 
			action: #versionsButtonAction 
			label: #versionsButtonLabel)
			hResizing: #spaceFill! !

!FinderUI methodsFor: 'accessing' stamp: ''!
selectedMethod
	^ self finder selectedMethod! !

!FinderUI methodsFor: 'private' stamp: ''!
senders
	self selectedMethod
		ifNotNil: [ :selector | 
			SystemNavigation new
				browseSendersOf: selector
				name: 'Senders of ' , selector asString
				autoSelect: selector asString ]! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildEnvironmentButton
	^ (PluggableButtonMorph 
			on: self 
			getState: #environmentButtonState 
			action: #environmentButtonAction 
			label: #environmentButtonLabel)
			beSticky! !

!FinderUI methodsFor: 'do it requirements' stamp: ''!
doItContext

	^ nil! !

!FinderUI methodsFor: 'private' stamp: ''!
labelFont
	^StandardFonts defaultFont! !

!FinderUI methodsFor: 'private' stamp: ''!
resetEnvironment
	self triggerEvent: #resetEnvironment! !

!FinderUI methodsFor: 'private' stamp: ''!
useRegEx
	^ self finder useRegEx! !

!FinderUI methodsFor: 'text areas behavior' stamp: ''!
collectFromPackages: aCollection
	self packagesSelection: (self environment forPackageNames: aCollection)! !

!FinderUI methodsFor: 'private' stamp: ''!
hierarchy
	self selectedClass
		ifNotNil: [ :class | 
			self selectedMethod
				ifNil: [ SystemNavigation new browseHierarchy: class ]
				ifNotNil: [ :selector | SystemNavigation new browseHierarchy: class selector: selector ] ]! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
allClassesButtonLabel
	^ 'All Packages'! !

!FinderUI methodsFor: 'private' stamp: ''!
searchModeHelpText
	^'Choose the mode for the search'! !

!FinderUI methodsFor: 'accessing' stamp: ''!
searchingString: aString

	^self finder searchingString: aString! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
inheritanceButtonAction
	self inheritance! !

!FinderUI methodsFor: 'accessing' stamp: ''!
searchedTextList
	^ searchedTextList ifNil: [ searchedTextList := OrderedCollection new ]! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
environmentButtonAction
	self openPackageChooser! !

!FinderUI methodsFor: 'accessing' stamp: ''!
searchedTextList: aCollection

	searchedTextList := aCollection! !

!FinderUI methodsFor: 'accessing' stamp: ''!
searchedTextListMaxSize: anInteger
	[ self searchedTextList size > anInteger ] whileTrue: [ self searchedTextList removeLast ].
	self changed: #searchedTextList! !

!FinderUI methodsFor: 'accessing' stamp: ''!
finder
	^finder! !

!FinderUI methodsFor: 'items creation' stamp: ''!
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: ''!
buildSearchModeToolBar: aWindow
	^aWindow newToolbar: {
		self buildSearchingTextArea.
		self buildSearchButton.
		self buildRegExChooser.
		self buildSearchModeDropListIn: aWindow.
		self buildEnvironmentButton.
		self buildAllClassesButton}! !

!FinderUI methodsFor: 'tree behavior' stamp: ''!
resultDictionary 
	^self finder resultDictionary ! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
implementorsButtonAction
	self implementors! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildAllClassesButton
	^ PluggableButtonMorph 
			on: self 
			getState: #allClassesButtonState 
			action: #allClassesButtonAction 
			label: #allClassesButtonLabel! !

!FinderUI methodsFor: 'accessing' stamp: ''!
searchingTextArea
	^ searchingTextArea ifNil: [ self buildSearchingTextArea ]! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
implementorsButtonState
	^ self selectedMethod isNil | self isClassNamesSymbol! !

!FinderUI methodsFor: 'accessing' stamp: ''!
environment
	^ self finder environment! !

!FinderUI methodsFor: 'private' stamp: ''!
constructPackagesSet: aPackageEnvironment
	| result |
	result := aPackageEnvironment packages collect: [ :c | c name ].
	^ (result reject: [ :each | each isNil ]) asSet asSortedCollection: [ :a :b | a < b ]! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
searchButtonLabel
	^ 'Search'! !

!FinderUI methodsFor: 'events handling' stamp: ''!
doubleClick
	self selectedNode doubleClick! !

!FinderUI methodsFor: 'accessing' stamp: ''!
finder: aFinder
	finder := aFinder! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
browseButtonLabel
	^'Browse'! !

!FinderUI methodsFor: 't - accessing' stamp: ''!
rootNodeClassFromItem: anItem
	"To have the good class for my nodes, I ask my owner,
	because he is the only one who knows his state"

	^ self
		forSelectorsDo: [ (self resultDictionary at: anItem) size > 1
				ifTrue: [ FinderMethodNode ]
				ifFalse: [ FinderSingleMethodNode ] ]
		forClassNamesDo: [ FinderClassNode ]
		forSourceDo: [ FinderMethodNode ]
		forExamplesDo: [ FinderExampleMethodNode ]
		forPragmasDo: [ FinderPragmaNode ]! !

!FinderUI methodsFor: 'items creation' stamp: ''!
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: 'buttons behavior' stamp: ''!
browseButtonState
	^self selectedClass isNil or: [ self selectedMethod isNil ]! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildSearchButton
	^ (PluggableButtonMorph 
			on: self 
			getState: #searchButtonState 
			action: #searchButtonAction 
			label: #searchButtonLabel)
			hResizing: #shrinkWrap! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildBrowseToolBar: aWindow
	| toolbar |
	toolbar := aWindow newToolbar: {
		self buildBrowseButton.
		self buildSendersButton.
		self buildImplementorsButton.
		self buildVersionsButton.
		self buildInheritanceButton.
		self buildHierarchyButton}.
	^toolbar hResizing: #shrinkWrap! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
versionsButtonAction
	Smalltalk tools versionBrowser 
		browseVersionsForClass: self selectedClass 
		selector: self selectedMethod! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
versionsButtonLabel
	^'Versions'! !

!FinderUI methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	wrapBlockOrSelector := [ :i | i asString ]! !

!FinderUI methodsFor: 'display' stamp: ''!
initialExtent
	^ 700@500! !

!FinderUI methodsFor: 'accessing' stamp: ''!
searchingString
	^self finder searchingString! !

!FinderUI methodsFor: 'accessing' stamp: ''!
forceSearch
	^ forceSearch ifNil: [ forceSearch := false ]! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
versionsButtonState
	^self selectedClass isNil | self isClassNamesSymbol.! !

!FinderUI methodsFor: 'mode list' stamp: ''!
isSourceSymbol
	^self finder isSourceSymbol! !

!FinderUI methodsFor: 'accessing' stamp: ''!
currentSearchMode: aSymbol
	self finder searchingStringSilently: self searchingTextArea contentMorph textMorph text asString.
	self searchingTextArea contentMorph hasUnacceptedEdits: false.
	self finder currentSearchMode: aSymbol! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildSendersButton
	^ (PluggableButtonMorph 
			on: self 
			getState: #sendersButtonState 
			action: #sendersButtonAction 
			label: #sendersButtonLabel)
			hResizing: #spaceFill! !

!FinderUI methodsFor: 'events handling' stamp: ''!
whenTextAcceptedInView: anAnnouncement
	self compileSource: sourceTextArea text notifying: sourceTextArea! !

!FinderUI methodsFor: 'text areas behavior' stamp: ''!
sourceCode

	^ self selectedClass 
		ifNil: [
			self isExamplesSymbol
				ifTrue: [ self class methodFinderExplanation ]
				ifFalse: [ self defaultExplanation]]
		ifNotNil:[
			self selectedMethod 
				ifNil: [
					self buildDescriptionOf: self selectedClass]
				ifNotNil:[
					| selector |
					selector := self isExamplesSymbol
								ifTrue: [self selectedMethod selector]
								ifFalse: [self selectedMethod].
					(self selectedClass >> selector) sourceCode]]! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
sendersButtonAction
	self senders! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildSourceTextArea
	sourceTextArea := self sourceTextModel newScrolledText
		beForSmalltalkCode;
		beWrapped;
		yourself.
	sourceTextArea textArea announcer when: RubTextAcceptRequest send: #whenTextAcceptedInView: to: self.
	self updateSourceCode.
	^ sourceTextArea! !

!FinderUI methodsFor: 'mode list' stamp: ''!
searchModesList
	^#(Selectors Classes Source Pragmas Examples)! !

!FinderUI methodsFor: 'accessing' stamp: ''!
browsedEnvironment
	^ self environment ! !

!FinderUI methodsFor: 'searching' stamp: ''!
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: 'accessing' stamp: ''!
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: 'text areas behavior' stamp: ''!
searchingAccept: aText
	self forceSearch
		ifFalse: [ aText asString = self searchingString
				ifTrue: [ ^ self ] ].
	self searchingString: aText asString.
	forceSearch := false! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
inheritanceButtonLabel
	^ 'Inheritance'! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
allClassesButtonAction

	self finder packagesSelection: self environment! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildImplementorsButton
	^ (PluggableButtonMorph 
			on: self 
			getState: #implementorsButtonState 
			action: #implementorsButtonAction 
			label: #implementorsButtonLabel)
			hResizing: #spaceFill! !

!FinderUI methodsFor: 'accessing' stamp: ''!
sourceTextModel
	^ sourceTextModel ifNil: [ sourceTextModel := RubScrolledTextModel new interactionModel: self ]! !

!FinderUI methodsFor: 'private' stamp: ''!
defaultExplanation
^
'The Finder can be used in 4 different ways:
	- Selectors: your research is done among selectors
	- Classes : your research is done among classes names
	- Source : your research is done among all the source code
	- Pragmas: your research is done among pragmas
	- Examples : your research uses the Method Finder behavior 
			   (for further informations, print ''FinderUI methodFinderExplanation'')
	
			
In these four modes, you can also tick the ''Use RegEx'' checkbox.
If you pick this box, your search will be done using regular expressions instead of just matching.

The ''Select classes'' button opened a dialog window  to select which classes will be used for the search.
The ''All classes'' button is used to reset the classes selection.'! !

!FinderUI methodsFor: 'accessing' stamp: ''!
searchedTextListMaxSize
	^20! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildInheritanceButton
	^ (PluggableButtonMorph 
			on: self 
			getState: #inheritanceButtonState 
			action: #inheritanceButtonAction 
			label: #inheritanceButtonLabel)
			hResizing: #spaceFill! !

!FinderUI methodsFor: 'items creation' stamp: ''!
buildHierarchyButton
	^ (PluggableButtonMorph 
			on: self 
			getState: #hierarchyButtonState 
			action: #hierarchyButtonAction 
			label: #hierarchyButtonLabel)
			hResizing: #spaceFill! !

!FinderUI methodsFor: 't - accessing' stamp: ''!
menu: menu shifted: b 
	self selectedNode ifNil: [ ^menu ].
	^ self selectedNode menu: menu shifted: b ! !

!FinderUI methodsFor: 'buttons behavior' stamp: ''!
browseButtonAction

	self selectedNode browse! !

!FinderUI methodsFor: 'private' stamp: ''!
updateSelectedMethod
	self changed: #selectedMethod! !

!FinderUI methodsFor: 'private' stamp: ''!
inheritance
	self selectedClass
		ifNotNil: [ :class | 
			self selectedMethod
				ifNotNil: [ :selector | SystemNavigation new methodHierarchyBrowserForClass: class selector: selector ] ]! !

!FinderUI methodsFor: 'display' stamp: ''!
defaultWindowLabel
	^ 'Finder'! !

!FinderUI methodsFor: 'private' stamp: ''!
packagesSelection: aCollection

	self finder packagesSelection: aCollection! !

!FinderUI methodsFor: 'accessing' stamp: ''!
rootItems
	^ self resultDictionary keys sort: [ :a :b | a asString < b asString ]! !

!FinderUI methodsFor: 'text areas behavior' stamp: ''!
compileSource: aString notifying: aController

	| class method |
	(self selectedClass isNil or: [ self selectedMethod isNil ])
		ifTrue:[
			self changed: #clearUserEdits.
			^self].
	class := self selectedClass.
	method := class compiledMethodAt: self selectedMethod.
	(class compile: (aString asString) classified: method category notifying: aController)
			ifNil: [^ self ]
			ifNotNil: [:selector |
				self changed: #clearUserEdits ]! !

!FinderUI class methodsFor: 'class initialization' stamp: ''!
initialize
	searchedTextListMaxSize := 15! !

!FinderUI class methodsFor: 'icons' stamp: ''!
taskbarIconName
	^#smallFindIcon! !

!FinderUI class methodsFor: 'instance creation' stamp: ''!
on: aFinder

	| instance |
	instance := self new finder: aFinder.
	self doAllSubscriptionsOn: aFinder to: instance.
	^instance! !

!FinderUI class methodsFor: 'event subscriptions' stamp: ''!
subscribesResetEnvironmentOn: aFinder to: anInstance

	aFinder
		when: #resetEnvironment
		send: #resetEnvironment
		to: anInstance! !

!FinderUI class methodsFor: 'event subscriptions' stamp: ''!
doAllSubscriptionsOn: aFinder to: anInstance
	self subscribesUpdateSourceCodeOn: aFinder to: anInstance.
	self subscribesResetEnvironmentOn: aFinder to: anInstance.
	self subscribesEnableUseRegExOn: aFinder to: anInstance.
	self subscribesDisableUseRegExOn: aFinder to: anInstance.
	self subscribesUpdateSelectedMethodOn: aFinder to: anInstance.
	self subscribesUpdateSelectedClassOn: aFinder to: anInstance.
	self subscribesUpdateListOn: aFinder to: anInstance! !

!FinderUI class methodsFor: 'event subscriptions' stamp: ''!
subscribesUpdateSelectedMethodOn: aFinder to: anInstance

	aFinder
		when: #updateSelectedMethod
		send: #updateSelectedMethod
		to: anInstance! !

!FinderUI class methodsFor: 'event subscriptions' stamp: ''!
subscribesUpdateSourceCodeOn: aFinder to: anInstance

	aFinder
		when: #updateSourceCode
		send: #updateSourceCode
		to: anInstance! !

!FinderUI class methodsFor: 'explanations' stamp: ''!
methodFinderExplanation
	"The comment in the bottom pane"

	MethodFinder new findMethodsByExampleInput: #( 1 2 ) andExpectedResult: 3.
		"to keep the method methodFor: from being removed from the system"

	^ 'Use an example to find a method in the system.  
	
   ''a''. ''b''. ''ab''       will find the message #, for strings concatenation
   2. -2                will find the message #negated
   3. 6                 will find the message #factorial
   20. 10. 15. 15       will find the message #min:max:

It works on collections too:

   {2. 4. 5. 1}. 5. 3   will find the message #indexOf:
   {2. 5. 1}. 5. true   will find the message #includes:
	
An example is made up of the following two or more items separated by a period: 
	
	receiver. answer
	receiver. argument1. answer
	receiver. argument1. argument2. answer
	etc...
	
For example, type: 3. 4. 7. into the search box and click <Search>

Take care on separating spaces because of floating point numbers.

 	3.4.7      will find nothing, it is interpreted two numbers, 3.4 and. 7
	3. 4. 7    will find you the message #+
	
The examples array should contain one object for the receiver, one object per expected argument and then a final object with the expected result.	

In other words 
 - a unary method example expects an array of input objects #( receiver ) and an expected result
 - a binary method example expects an array with two input objects #( receiver argument ) and an expected result
 - a keyword method example expects an array with at least two elements  #( receiver argument1 argument2 ... ) and an expected results

The method finder will take the input objects (receiver and arguments) and perform their permutation to be able to find more results.
Then, it will lookup in the receiver''s hierarchy the approved and forbidden methods to run on the hierarchy and run them on the permutation of objects.

Receiver and arguments do not have to be in the right order.

Alternatively, in this bottom pane or in the Playground, use #findMethodsByExampleInput:andExpectedResult: directly to find a method in the system.  Select this line of code and choose "print it" or "inspect it.  

	MethodFinder new findMethodsByExampleInput: #( 1 2 ) andExpectedResult: 3.

It is useful when you want to look for computed objects:
	
	MethodFinder new 
		findMethodsByExampleInput: {''29 Apr 1999'' asDate} 
		andExpectedResult: ''30 Apr 1999'' asDate.

This will find the message #next.

	MethodFinder new 
		findMethodsByExampleInput: {''30 Apr 1999'' asDate} 
		andExpectedResult: ''Friday''. 

This will find the message #dayOfWeekName

The Method Finder is not trying all methods in the system so if it will find nothing, a method with requested behavior may still exist. '.

		
! !

!FinderUI class methodsFor: 'icons' stamp: ''!
icon
	^ self iconNamed: #smallFindIcon! !

!FinderUI class methodsFor: 'accessing' stamp: ''!
searchedTextListMaxSize: anInteger

	self allInstancesDo: [:each | each searchedTextListMaxSize: anInteger].
	searchedTextListMaxSize := anInteger! !

!FinderUI class methodsFor: 'event subscriptions' stamp: ''!
subscribesUpdateListOn: aFinder to: anInstance

	aFinder
		when: #updateResultDictionary
		send: #updateList
		to: anInstance! !

!FinderUI class methodsFor: 'event subscriptions' stamp: ''!
subscribesEnableUseRegExOn: aFinder to: anInstance

	aFinder
		when: #enableUseRegEx
		send: #enableUseRegEx
		to: anInstance! !

!FinderUI class methodsFor: 'event subscriptions' stamp: ''!
subscribesDisableUseRegExOn: aFinder to: anInstance

	aFinder
		when: #disableUseRegEx
		send: #disableUseRegEx
		to: anInstance! !

!FinderUI class methodsFor: 'event subscriptions' stamp: ''!
subscribesUpdateSelectedClassOn: aFinder to: anInstance

	aFinder
		when: #updateSelectedClass
		send: #updateSelectedClass
		to: anInstance! !

!FixedFaceFont commentStamp: ''!
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: 'displaying' stamp: ''!
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: ''!
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: ''!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
	^baseFont installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor! !

!FixedFaceFont methodsFor: 'displaying' stamp: ''!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont 
	| destPoint |
	destPoint := self
				displayString: aString
				on: aBitBlt
				from: startIndex
				to: stopIndex
				at: aPoint
				kern: kernDelta.
	^ Array with: stopIndex + 1 with: destPoint! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
baseFont
	^baseFont! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
ascent
	^baseFont ascent! !

!FixedFaceFont methodsFor: 'private' stamp: ''!
glyphInfoOf: aCharacter into: glyphInfoArray

	^ baseFont glyphInfoOf: substitutionCharacter into: glyphInfoArray.! !

!FixedFaceFont methodsFor: 'displaying' stamp: ''!
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: 'accessing' stamp: ''!
descent
	^baseFont descent! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
emphasized: emph
	^self class new baseFont: (baseFont emphasized: emph)! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
passwordCharacter
	^$*! !

!FixedFaceFont methodsFor: 'initialization' stamp: ''!
errorFont
	displaySelector := #displayErrorOn:length:at:kern:baselineY:.
	substitutionCharacter := $?.! !

!FixedFaceFont methodsFor: 'caching' stamp: ''!
releaseCachedState
	baseFont releaseCachedState.! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
baseFont: aFont
	baseFont := aFont! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
lineGrid
	^baseFont lineGrid! !

!FixedFaceFont methodsFor: 'initialization' stamp: ''!
passwordFont
	displaySelector := #displayPasswordOn:length:at:kern:baselineY:.
	substitutionCharacter := $*! !

!FixedFaceFont methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	baseFont := TextStyle defaultFont.
	self passwordFont! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
maxAscii
	^ SmallInteger maxVal! !

!FixedFaceFont methodsFor: 'displaying' stamp: ''!
displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta 
	| maskedString |
	maskedString := String new: length.
	maskedString atAllPut: substitutionCharacter.
	^ baseFont
		displayString: maskedString
		on: aCanvas
		from: 1
		to: length
		at: aPoint
		kern: kernDelta! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
height
	^baseFont height! !

!FixedFaceFont methodsFor: 'displaying' stamp: ''!
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: 'accessing' stamp: ''!
descentKern
	^baseFont descentKern! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
baseKern
	^baseFont baseKern! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
familyName
	^baseFont familyName, '-pw'! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
characterFormAt: character 
	^ baseFont characterFormAt: substitutionCharacter! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
fontSize: aNumber 
	self baseFont: (StrikeFont familyName: baseFont familyName size: aNumber) copy! !

!FixedFaceFont methodsFor: 'accessing' stamp: ''!
pointSize
	^baseFont pointSize! !

!FixedFaceFont methodsFor: 'displaying' stamp: ''!
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: 'measuring' stamp: ''!
widthOf: aCharacter 
	^ baseFont widthOf: substitutionCharacter! !

!FixedFaceFont methodsFor: 'displaying' stamp: ''!
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! !

!FixedLayout commentStamp: ''!
I am the default layout for objects.

I contain a fixed number of Slots.
Instances of classes using this kind of layout have always the same size.!
!FixedLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	^ self hasFields
		ifTrue: [ 1 ]
		ifFalse: [ 0 ]! !

!FixedLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGFixedLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)]
! !

!FixedLayout methodsFor: 'testing' stamp: ''!
isFixedLayout
	^true! !

!FixedLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass
	^ (superLayout extend: aScope)
		host: aClass;
		yourself! !

!FixedLayout class methodsFor: '*Monticello' stamp: 'nil'!
mcTypeSymbol 
	^ #normal! !

!FlagIconStyler commentStamp: ''!
I'm in charge to style an ast when there is a message send of #flag:.
This is used to tag methods for TODOs, having many of these is a bad
sign...

	self flag: #Bob!
!FlagIconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^(Color yellow alpha: 0.3)! !

!FlagIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^aNode isMessage and: [aNode selector = #flag:]! !

!FlagIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #flag.! !

!Float commentStamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
degreesToRadians
	"Answer the receiver in radians. Assumes the receiver is in degrees."

	^self * RadiansPerDegree! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
closeTo: num precision: aPrecision
 	"Tell whether the receiver and arguments are close from each other given a precision"
	
	num isNumber ifFalse: [ ^ [self = num] onErrorDo: [false]].
	self = 0.0 ifTrue: [^ num abs < aPrecision].
	num = 0 ifTrue: [^self abs < aPrecision].
	^self = num asFloat
		or: [(self - num) abs / (self abs max: num abs) < aPrecision]! !

!Float methodsFor: 'comparing' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
integerPart
	"Answer a Float whose value is the receiver's truncated value."

	^self - self fractionPart! !

!Float methodsFor: '*UnifiedFFI' stamp: ''!
packAsDoubleToArity: arity 
	| rolledPointer |
		
	rolledPointer := self.
	1 to: arity do: [ :index | rolledPointer := rolledPointer pointerDouble ].
	^ rolledPointer	! !

!Float methodsFor: 'printing' stamp: ''!
absPrintInexactlyOn: aStream base: base
	"Print my value on a stream in the given base.  Assumes that my value is strictly
	positive; negative numbers, zero, NaNs and infinite numbers 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 |
	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: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitHookPrimitive: self! !

!Float methodsFor: 'testing' stamp: ''!
isSelfEvaluating
    ^true! !

!Float methodsFor: 'printing' stamp: ''!
storeOn: aStream base: base 
	"Print the Number exactly so it can be interpreted back unchanged"
	self isFinite
		ifTrue: [self signBit = 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: '*Math-Operations-Extensions' stamp: ''!
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: 'testing' stamp: ''!
isZero
	^self = 0.0! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
safeArcCos
	"Answer the angle in radians."

	^ (self between: -1.0 and: 1.0)
		ifTrue: [ self arcCos ]
		ifFalse: [ self sign arcCos ]! !

!Float methodsFor: '*UnifiedFFI' stamp: ''!
packAsFloatToArity: arity 
	| rolledPointer |
		
	rolledPointer := self.
	1 to: arity do: [ :index | rolledPointer := rolledPointer pointerFloat ].
	^ rolledPointer	! !

!Float methodsFor: 'testing' stamp: ''!
isFinite
	"simple, byte-order independent test for rejecting Not-a-Number and (Negative)Infinity"

	^(self - self) = 0.0! !

!Float methodsFor: '*Fuel-Core' stamp: ''!
serializeOn: anEncoder

	anEncoder 
		encodeUint32: (self at: 1);
		encodeUint32: (self at: 2).! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
tan
	"Answer the tangent of the receiver taken as an angle in radians."

	^ self sin / self cos! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
degreeSin
	"Take care of exceptional values"
	
	self isFinite ifTrue: [^super degreeSin].
	^self degreesToRadians sin! !

!Float methodsFor: 'printing' stamp: ''!
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 signBit = 1 ifTrue: [ stream nextPut: $- ].
			self = 0.0
				ifTrue: [ stream nextPutAll: '0.0' ]
				ifFalse: [ FloatPrintPolicy absPrint: self negated on: stream base: base ] ]! !

!Float methodsFor: 'converting' stamp: ''!
asScaledDecimal

	"Answer a scaled decimal number approximating the receiver.
	
	IEEE 754 double precision numbers use 53 bits to encode mantissa. This means
	that the maximum amount of decimal digits that can be represented is log10(2^53).
	
	Due to the fact that at least one of the decimal digits has to be placed to 
	the left of the decimal point, the scale was set to 15 - 1 = 14."

	^ self asScaledDecimal: 14! !

!Float methodsFor: 'arithmetic' stamp: ''!
negated
	"Answer a Number that is the negation of the receiver.
	Implementation note: this version cares of negativeZero."

	^-1.0 * self! !

!Float methodsFor: 'accessing' stamp: ''!
at: index put: value 
	^self basicAt: index put: value! !

!Float methodsFor: 'mathematical functions' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
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: 'copying' stamp: ''!
deepCopy

	^self copy! !

!Float methodsFor: 'mathematical functions' stamp: ''!
signBit
	"Answer 1 if the receiver has sign bit set (including case of IEEE-754 negative-zero).
	Answer 0 otherwise"

	^((self at: 1) bitShift: -31)! !

!Float methodsFor: 'printing' stamp: ''!
printBinaryLiteralOn: stream

	"Floats represent those numbers that can be written in Pharo notation as literals of the form {sign}2r1.{fraction}e{exponent} -- where {sign} is the minus
	sign or is empty, {fraction} is a sequence of 52 bits and {exponent} is an integer from -1022 to 1023 -- as well as those numbers that can be written
	as {sign}2r0.{fraction}e-1022 and some special values. This method prints a Float as such a literal expression, or a message expression in the case of
	the special values. Evaluating the expression always results in a Float with the exact same bit pattern, with the exception of the not-a-number Floats
	which all get printed as 'Float nan'. The following article has a table in the section 'Summary' at the end which enumerates the different bit patterns
	of Floats and how to interpret them, which was used in writing this method: http://steve.hollasch.net/cgindex/coding/ieeefloat.html"

	| signBit exponentBits fractionBits |

	signBit := (self basicAt: 1) bitShift: -31.
	exponentBits := ((self basicAt: 1) bitShift: -20) bitAnd: 2r11111111111.
	fractionBits := (((self basicAt: 1) bitAnd: 2r11111111111111111111) bitShift: 32) bitOr: (self basicAt: 2).

	(exponentBits = 2047) ifTrue: [ 
		(fractionBits = 0) ifTrue: [
			stream nextPutAll: 'Float infinity'.
			(signBit = 1) ifTrue: [ stream nextPutAll: ' negated' ].
		] ifFalse: [
			stream nextPutAll: 'Float nan'.
		].
		^ self
	].

	(signBit = 1) ifTrue: [ stream nextPut: $- ].
	(exponentBits = 0) ifTrue: [ 
		(fractionBits = 0) ifTrue: [
			stream nextPutAll: '0.0'
		] ifFalse: [
			stream nextPutAll: '2r0.'.
			fractionBits printOn: stream base: 2 length: (Float precision - 1) padded: true.
			stream nextPutAll: 'e-1022'.
		].
		^ self
	].

	stream nextPutAll: '2r1.'.
	fractionBits printOn: stream base: 2 length: (Float precision - 1) padded: true.
	stream nextPut: $e.
	(exponentBits - 1023) printOn: stream base: 10.! !

!Float methodsFor: 'mathematical functions' stamp: ''!
timesTwoPower: anInteger 
	^ self subclassResponsibility! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*UnifiedFFI' stamp: ''!
packToArity: arity 
	self error: 'Use #rollAsFloatArity: or #rollAsDoubleArity:'! !

!Float methodsFor: '*UnifiedFFI' stamp: ''!
pointerDouble
	"sizeof(double)== 8"
	^ (ByteArray new: FFIFloat64 externalTypeSize)
		doubleAt: 1 put: self;
		yourself! !

!Float methodsFor: 'printing' stamp: ''!
binaryLiteralString

	^ String streamContents: [ :stream | self printBinaryLiteralOn: stream ]! !

!Float methodsFor: 'testing' stamp: ''!
isNaN
	"simple, byte-order independent test for Not-a-Number"

	^ self ~= self! !

!Float methodsFor: 'accessing' stamp: ''!
basicAt: index
	"Primitive. Assumes receiver is indexable. Answer the value of an 
	indexable element in the receiver. Fail if the argument index is not an 
	Integer or is out of bounds. Essential. Do not override in a subclass. See 
	Object documentation whatIsAPrimitive.

	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."

	<primitive: 38>
	^super basicAt: index.! !

!Float methodsFor: 'mathematical functions' stamp: ''!
reciprocalLogBase2
	"optimized for self = 10, for use in conversion for printing"

	^ self = 10.0
		ifTrue: [Ln2 / Ln10]
		ifFalse: [Ln2 / self ln]! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
reduce
    "If self is close to an integer, return that integer"

    (self closeTo: self rounded) ifTrue: [^ self rounded]! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
cos
	"Answer the cosine of the receiver taken as an angle in radians."

	^ (self + Halfpi) sin! !

!Float methodsFor: 'converting' stamp: ''!
asFloat
	"Answer the receiver itself."

	^self! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
log
	"Answer the base 10 logarithm of the receiver."

	^ self ln / Ln10! !

!Float methodsFor: 'printing' stamp: ''!
absPrintExactlyOn: aStream base: base
	"Print my value on a stream in the given base.  Assumes that my value is strictly
	positive; negative numbers, zero, NaNs and infinite numbers 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 |
	fBase := base asFloat.
	significand := self significandAsInteger.
	roundingIncludesLimits := significand even.
	exp := (self exponent - 52) max: MinValLogBase2.
	baseExpEstimate := (self exponent * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
	exp >= 0
		ifTrue:
			[be := 1 << exp.
			significand ~= 16r10000000000000
				ifTrue:
					[r := significand * be * 2.
					s := 2.
					mPlus := be]
				ifFalse:
					[be1 := be * 2.
					r := significand * be1 * 2.
					s := 4.
					mPlus := be1].
				mMinus := be]
		ifFalse:
			[(exp = MinValLogBase2) | (significand ~= 16r10000000000000)
				ifTrue:
					[r := significand * 2.
					s := (1 << (exp negated)) * 2.
					mPlus := 1]
				ifFalse:
					[r := significand * 4.
					s := (1 << (exp negated + 1)) * 2.
					mPlus := 2].
				mMinus := 1].
	baseExpEstimate >= 0
		ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)]
		ifFalse:
			[scale := base raisedToInteger: baseExpEstimate negated.
			r := r * scale.
			mPlus := mPlus * scale.
			mMinus := mMinus * scale].
	(r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s))
		ifTrue: [baseExpEstimate := baseExpEstimate + 1]
		ifFalse:
			[r := r * base.
			mPlus := mPlus * base.
			mMinus := mMinus * base].
	(fixedFormat := baseExpEstimate between: -3 and: 6)
		ifTrue:
			[decPointCount := baseExpEstimate.
			baseExpEstimate <= 0
				ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]]
		ifFalse:
			[decPointCount := 1]. 
	[d := r // s.
	r := r \\ s.
	(tc1 := (r < mMinus) | (roundingIncludesLimits & (r = mMinus))) |
	(tc2 := (r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s)))] whileFalse:
		[aStream nextPut: (Character digitValue: d).
		r := r * base.
		mPlus := mPlus * base.
		mMinus := mMinus * base.
		decPointCount := decPointCount - 1.
		decPointCount = 0 ifTrue: [aStream nextPut: $.]].
	tc2 ifTrue:
		[tc1 not | (tc1 & (r*2 >= s)) ifTrue: [d := d + 1]].
	aStream nextPut: (Character digitValue: d).
	decPointCount > 0
		ifTrue:
		[decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0].
		aStream nextPutAll: '.0'].
	fixedFormat ifFalse:
		[aStream nextPut: $e.
		aStream nextPutAll: (baseExpEstimate - 1) printString]! !

!Float methodsFor: 'printing' stamp: ''!
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: 'converting' stamp: ''!
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: 'comparing' stamp: ''!
literalEqual: other

	^ (super literalEqual: other) and: [ self isZero not or: [ self signBit = other signBit ] ]! !

!Float methodsFor: 'printing' stamp: ''!
printShowingDecimalPlaces: placesDesired
	"This implementation avoids any rounding error caused by rounded or roundTo:"
	
	^self asTrueFraction printShowingDecimalPlaces: placesDesired! !

!Float methodsFor: 'copying' stamp: ''!
shallowCopy

	^self - 0.0! !

!Float methodsFor: 'converting' stamp: ''!
adaptToInteger: rcvr andSend: selector
	"If I am involved in arithmetic with an Integer, convert it to a Float."
	^ rcvr asFloat perform: selector with: self! !

!Float methodsFor: 'testing' stamp: ''!
isInfinite
	"Return true if the receiver is positive or negative infinity."

	^ self = Infinity or: [self = NegativeInfinity]! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
closeTo: num
 	"Tell whether the receiver and arguments are close from each."
	
	^ self closeTo: num precision: 0.0001! !

!Float methodsFor: 'converting' stamp: ''!
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: 'accessing' stamp: ''!
at: index 
	^self basicAt: index! !

!Float methodsFor: 'testing' stamp: ''!
isPowerOfTwo
	"Return true if the receiver is an integral power of two.
	Floats never return true here."
	^false! !

!Float methodsFor: 'printing' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
arcCos
	"Answer the angle in radians."

	^ Halfpi - self arcSin! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
radiansToDegrees
	"Answer the receiver in degrees. Assumes the receiver is in radians."

	^self / RadiansPerDegree! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
reciprocal

	"Returns the reciprocal.
	If self is 0.0 the / signals a ZeroDivide"
	
	^1.0 / self! !

!Float methodsFor: 'mathematical functions' stamp: ''!
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: 'converting' stamp: ''!
asFraction
	^ self asTrueFraction! !

!Float methodsFor: 'testing' stamp: ''!
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: 'mathematical functions' stamp: ''!
significandAsInteger
	"Answer the mantissa of a Float shifted so as to have the ulp equal to 1.
	For exceptional values, infinity and nan, just answer the bit pattern."

	self isFinite ifTrue:
		[^(self timesTwoPower: self class precision - 1 - (self exponent max: self class emin)) truncated abs].
	^(((self basicAt: 1) bitAnd: 16r000FFFFF) bitShift: 32) bitOr: (self basicAt: 2)! !

!Float methodsFor: 'arithmetic' stamp: ''!
abs
	"This is faster than using Number abs and works for negativeZero."
	self <= 0.0
		ifTrue: [^ 0.0 - self]
		ifFalse: [^ self]! !

!Float methodsFor: 'printing' stamp: ''!
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: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  Do not record me."

	^ self shallowCopy! !

!Float methodsFor: 'converting' stamp: ''!
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: ''!
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: '*Math-Operations-Extensions' stamp: ''!
round: numberOfWishedDecimal
	"Round the decimal part of the receiver to be limited to the number of wished decimal. Only leave a fixed amount of decimal"
   "(10.12345 round: 2) >>> 10.12 "
        
	^(self asFraction round: numberOfWishedDecimal) asFloat! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
degreeCos
	"Take care of exceptional values"
	
	self isFinite ifTrue: [^super degreeCos].
	^self degreesToRadians cos! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
arcTan: denominator
	"Answer the angle in radians.
	Implementation note: use sign in order to catch cases of negativeZero"
	
	"(-0.5 arcTan: -0.5) >>> -2.356194490192345"
	"(1.2 arcTan: 1.5) >>>  0.6747409422235526"
	"(1.2 arcTan: -1.5) >>> 2.4668517113662407"
	^ self = 0.0
		ifTrue: [denominator signBit = 0
			ifTrue: [ 0 ]
			ifFalse: [ self signBit = 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: 'testing' stamp: ''!
isFloat
	^ true! !

!Float methodsFor: '*UnifiedFFI' stamp: ''!
pointer 
	"Floats in Pharo are 64bits (8 bytes) and that correspond directly with a double on C.
	 So 'default' behaviour will be to address it as a double (float is also available in case is 
	 needed)"
	^ self pointerDouble! !

!Float methodsFor: 'private' stamp: ''!
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 floorLog: fBase.
	scale := 1.0.
	logScale := 0.
	[(x := fBase raisedTo: (exp + logScale)) = 0]
		whileTrue:
			[scale := scale * fBase.
			logScale := logScale + 1].
	x := self * scale / x.
	fuzz := fBase raisedTo: 1 - digitCount.
	"round the last digit to be printed"
	x := 0.5 * fuzz + x.
	x >= fBase
		ifTrue: 
			["check if rounding has unnormalized x"
			x := x / fBase.
			exp := exp + 1].
	(exp < 6 and: [exp > -4])
		ifTrue: 
			["decimal notation"
			q := 0.
			exp < 0 ifTrue: [1 to: 1 - exp do: [:i | aStream nextPut: ('0.0000'
at: i)]]]
		ifFalse: 
			["scientific notation"
			q := exp.
			exp := 0].
	[x >= fuzz]
		whileTrue: 
			["use fuzz to track significance"
			xi := x asInteger.
			aStream nextPut: (Character digitValue: xi).
			x := x - xi asFloat * fBase.
			fuzz := fuzz * fBase.
			exp := exp - 1.
			exp = -1 ifTrue: [aStream nextPut: $.]].
	[exp >= -1]
		whileTrue: 
			[aStream nextPut: $0.
			exp := exp - 1.
			exp = -1 ifTrue: [aStream nextPut: $.]].
	q ~= 0
		ifTrue: 
			[aStream nextPut: $e.
			q printOn: aStream]! !

!Float methodsFor: 'accessing' stamp: ''!
basicAt: index put: value
	"Primitive. Assumes receiver is indexable. Store the second argument 
	value in the indexable element of the receiver indicated by index. Fail 
	if the index is not an Integer or is out of bounds. Or fail if the value is 
	not of the right type for this kind of collection. Answer the value that 
	was stored. Essential. Do not override in a subclass. See Object 
	documentation whatIsAPrimitive.

	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."

	<primitive: 39>
	^super basicAt: index put: value! !

!Float methodsFor: 'converting' stamp: ''!
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: '*UnifiedFFI' stamp: ''!
pointerFloat
	"sizeof(float)== 4"
	^ (ByteArray new: FFIFloat32 externalTypeSize)
		floatAt: 1 put: self;
		yourself! !

!Float methodsFor: 'converting' stamp: ''!
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: 'mathematical functions' stamp: ''!
exponent
	^ self subclassResponsibility! !

!Float methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	"Print the Number exactly so it can be interpreted back unchanged"
	
	self storeOn: aStream base: 10! !

!Float methodsFor: 'mathematical functions' stamp: ''!
significand

	^ self timesTwoPower: (self exponent negated)! !

!Float methodsFor: '*Math-Operations-Extensions' stamp: ''!
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 class methodsFor: 'constants' stamp: ''!
twoPi

	^ Twopi! !

!Float class methodsFor: '*Fuel-Core' stamp: ''!
materializeFrom: aDecoder
	"The * 1 is here to give a chance to the VM to create a SmallFloat64 if it can (thanks Nicolas Cellier)."
	
	^ (BoxedFloat64 new: 2)
		at: 1 put: aDecoder nextEncodedUint32;
		at: 2 put: aDecoder nextEncodedUint32;
		* 1.
! !

!Float class methodsFor: 'constants' stamp: ''!
denormalized
	"Answer whether implementation supports denormalized numbers (also known as gradual underflow)."
	
	^true! !

!Float class methodsFor: 'constants' stamp: ''!
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: ''!
threePi

	^ ThreePi! !

!Float class methodsFor: 'constants' stamp: ''!
negativeInfinity
	"Answer the value used to represent a negative infinite magnitude"

	^ NegativeInfinity! !

!Float class methodsFor: 'instance creation' stamp: ''!
basicNew
	^BoxedFloat64 basicNew: 2! !

!Float class methodsFor: 'constants' stamp: ''!
negativeZero

	^ NegativeZero! !

!Float class methodsFor: 'instance creation' stamp: ''!
basicNew: anInteger
	^BoxedFloat64 basicNew: 2! !

!Float class methodsFor: 'constants' stamp: ''!
halfPi
	^ Halfpi! !

!Float class methodsFor: 'constants' stamp: ''!
one
	
	^1.0! !

!Float class methodsFor: 'constants' stamp: ''!
pi
	"Answer the constant, Pi."

	^Pi! !

!Float class methodsFor: 'instance creation' stamp: ''!
readFrom: aStream 
	"Answer a new Float as described on the stream, aStream."

	^(super readFrom: aStream) asFloat! !

!Float class methodsFor: 'constants' stamp: ''!
emax
	"Answer exponent of maximal representable value"
	
	^1023! !

!Float class methodsFor: 'constants' stamp: ''!
nan
	"Answer the canonical value used to represent Not-A-Number"

	^ NaN! !

!Float class methodsFor: 'instance creation' stamp: ''!
fromIEEE32Bit: word
	"Convert the given 32 bit word (which is supposed to be a positive 32-bit value) from
	 a 32 bit IEEE floating point representation into an actual float object (being
	 64 bits wide). Should only be used for conversion in FloatArrays or likewise objects."
	
	| sign mantissa exponent delta |
	word <= 0 ifTrue:
		[^word negative
			ifTrue: [self error: 'Cannot deal with negative numbers']
			ifFalse: [self zero]].
	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
			ifTrue:
				[sign = 0 
					ifTrue: [self infinity]
					ifFalse: [self negativeInfinity]]
			ifFalse: [self nan]].

	exponent = -127 ifTrue:
		"gradual underflow (denormalized number)
		 Remove first bit of mantissa and adjust exponent"
		[delta := mantissa highBit.
		 mantissa := (mantissa bitAnd: (1 bitShift: delta - 1) - 1) bitShift: 24 - delta.
		 exponent := exponent + delta - 23].
	
	"Create new float"
	^(self basicNew: 2)
		basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3));
		basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29);
		* 1.0 "reduce to SmallFloat64 if possible"! !

!Float class methodsFor: '*Math-Operations-Extensions' stamp: ''!
fminDenormalized
	"Answer the minimum denormalized value representable."
	
	^1.0 timesTwoPower: MinValLogBase2! !

!Float class methodsFor: '*Math-Operations-Extensions' stamp: ''!
fmin
	"Answer minimum positive representable value."
	
	^self denormalized
		ifTrue: [self fminDenormalized]
		ifFalse: [self fminNormalized]! !

!Float class methodsFor: 'class initialization' stamp: ''!
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: ''!
emin
	"Answer exponent of minimal normalized representable value"
	
	^-1022! !

!Float class methodsFor: 'constants' stamp: ''!
radix
	"Answer the radix used for internal floating point representation."
	
	^2! !

!Float class methodsFor: 'instance creation' stamp: ''!
fromIEEE64Bit: doubleWord

    ^ (self new: 2) basicAt: 1 put: (doubleWord bitShift: -32); basicAt: 2 put: (doubleWord bitAnd: 16rFFFFFFFF); yourself! !

!Float class methodsFor: '*Math-Operations-Extensions' stamp: ''!
fmax
	"Answer the maximum finite floating point value representable."
	
	^MaxVal! !

!Float class methodsFor: 'instance creation' stamp: ''!
readFrom: aStream ifFail: aBlock
	"Answer a new Float as described on the stream, aStream."

	^(super readFrom: aStream ifFail: [^aBlock value]) asFloat! !

!Float class methodsFor: '*Math-Operations-Extensions' stamp: ''!
fminNormalized
	"Answer the minimum normalized value representable."
	
	^1.0 timesTwoPower: -1022! !

!Float class methodsFor: 'constants' stamp: ''!
e
	"Answer the constant, E."

	^E! !

!Float class methodsFor: 'constants' stamp: ''!
zero
	^ 0.0! !

!Float class methodsFor: '*Math-Operations-Extensions' stamp: ''!
epsilon
	"Answer difference between 1.0 and previous representable value"
	
	^1.0 timesTwoPower: 1 - self precision! !

!Float class methodsFor: 'constants' stamp: ''!
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: ''!
infinity
	"Answer the value used to represent an infinite magnitude"

	^ Infinity! !

!FloatArray commentStamp: ''!
FloatArrays store 32bit IEEE floating point numbers.

For further comments read comments of `WordArray`.!
!FloatArray methodsFor: 'arithmetic' stamp: ''!
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 |
	<primitive: 'primitiveDotProduct' module: 'FloatArrayPlugin'>
	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: 'primitives - plugin' stamp: ''!
primAddScalar: scalarValue

	<primitive: 'primitiveAddScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) + scalarValue].! !

!FloatArray methodsFor: 'primitives - plugin' stamp: ''!
sum

	<primitive: 'primitiveSum' module: 'FloatArrayPlugin'>
	^ super sum! !

!FloatArray methodsFor: 'comparing' stamp: ''!
= aFloatArray 
	| length |
	<primitive: 'primitiveEqual' module: 'FloatArrayPlugin'>
	aFloatArray class = self class ifFalse: [^ false].
	length := self size.
	length = aFloatArray size ifFalse: [^ false].
	1 to: self size do: [:i | (self at: i)
			= (aFloatArray at: i) ifFalse: [^ false]].
	^ true! !

!FloatArray methodsFor: '*Collections-arithmetic' stamp: ''!
* anObject
	^self copy *= anObject! !

!FloatArray methodsFor: 'comparing' stamp: ''!
hash
	| result |
	<primitive:'primitiveHashArray' module: 'FloatArrayPlugin'>
	result := 0.
	1 to: self size do:[:i| result := result + (self basicAt: i) ].
	^result bitAnd: 16r1FFFFFFF! !

!FloatArray methodsFor: '*Collections-arithmetic' stamp: ''!
*= anObject
	^anObject isNumber
		ifTrue:[self primMulScalar: anObject asFloat]
		ifFalse:[self primMulArray: anObject]! !

!FloatArray methodsFor: 'primitives - plugin' stamp: ''!
primDivArray: floatArray

	<primitive: 'primitiveDivFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) / (floatArray at: i)].! !

!FloatArray methodsFor: 'primitives - plugin' stamp: ''!
primAddArray: floatArray

	<primitive: 'primitiveAddFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) + (floatArray at: i)].! !

!FloatArray methodsFor: '*Collections-arithmetic' stamp: ''!
/ anObject
	^self copy /= anObject! !

!FloatArray methodsFor: 'accessing' stamp: ''!
at: index
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!FloatArray methodsFor: 'converting' stamp: ''!
asFloatArray
	^self! !

!FloatArray methodsFor: 'primitives - plugin' stamp: ''!
primDivScalar: scalarValue

	<primitive: 'primitiveDivScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) / scalarValue].! !

!FloatArray methodsFor: '*Collections-arithmetic' stamp: ''!
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: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	self pinInMemory.
	^ PointerUtils oopForObject: self
! !

!FloatArray methodsFor: '*Collections-arithmetic' stamp: ''!
- anObject
	^self shallowCopy -= anObject! !

!FloatArray methodsFor: '*Collections-arithmetic' stamp: ''!
\\= 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: ''!
+= anObject
	^ anObject addAssignToFloatArray: self! !

!FloatArray methodsFor: 'primitives - plugin' stamp: ''!
primMulArray: floatArray

	<primitive: 'primitiveMulFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) * (floatArray at: i)].! !

!FloatArray methodsFor: '*Collections-arithmetic' stamp: ''!
negated
	^self copy *= -1! !

!FloatArray methodsFor: 'accessing' stamp: ''!
at: index put: value
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	value isFloat 
		ifTrue:[self basicAt: index put: value asIEEE32BitWord]
		ifFalse:[self at: index put: value asFloat].
	^value! !

!FloatArray methodsFor: 'private' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !

!FloatArray methodsFor: 'primitives - plugin' stamp: ''!
primSubScalar: scalarValue

	<primitive: 'primitiveSubScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) - scalarValue].! !

!FloatArray methodsFor: 'accessing' stamp: ''!
defaultElement
	"Return the default element of the receiver"
	^0.0! !

!FloatArray methodsFor: 'primitives - plugin' stamp: ''!
primMulScalar: scalarValue

	<primitive: 'primitiveMulScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) * scalarValue].! !

!FloatArray methodsFor: 'adding' stamp: ''!
addAssignToFloatArray: aFloatArray

	^ aFloatArray primAddArray: self! !

!FloatArray methodsFor: 'primitives - plugin' stamp: ''!
primSubArray: floatArray

	<primitive: 'primitiveSubFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) - (floatArray at: i)].! !

!FloatArray methodsFor: '*Collections-arithmetic' stamp: ''!
/= anObject
	^anObject isNumber
		ifTrue:[self primDivScalar: anObject asFloat]
		ifFalse:[self primDivArray: anObject]! !

!FloatArray methodsFor: '*Collections-arithmetic' stamp: ''!
+ anObject
	^self copy += anObject! !

!FloatArray methodsFor: '*Collections-arithmetic' stamp: ''!
-= anObject
	^anObject isNumber
		ifTrue:[self primSubScalar: anObject asFloat]
		ifFalse:[self primSubArray: anObject]! !

!FloatArrayTest commentStamp: ''!
These tests are used to assert that FloatArrayPlugin has same results as Float asIEEE32BitWord!
!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collection

	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutFirst

	| result |
	result := self nonEmpty copyWithoutFirst.
	
	self assert: result size equals: (self nonEmpty size - 1).
	
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (self nonEmpty at: (i + 1))]! !

!FloatArrayTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne)! !

!FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtLastPut

	| index |
	index := self indexArray anyOne.	
	self nonEmpty atLast: index put: self aValue.	

	self assert: (self nonEmpty at: (self nonEmpty size + 1 - index)) equals: self aValue! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
sizeCollection
	"Answers a collection not empty"
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedConcatenationTest
	self empty.
	self assertEmpty: self empty.
	self firstCollection.
	self secondCollection! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
oldSubCollection
" return a subCollection included in collectionWith1TimeSubcollection .
ex :   subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)"
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
elementInForElementAccessing
" return an element inculded in 'moreThan4Elements'"
	^ elementInNonEmpty! !

!FloatArrayTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!FloatArrayTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAt

	| subcollection index collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 1.
	self assert: index equals: 1.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 2.
	self assert: index equals: 0! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirstNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!FloatArrayTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index between bounds of 'nonEmpty'"

	^ 3! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessFotMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
elementInForReplacement
	"Return an element included in 'nonEmpty'"

	^ self nonEmpty anyOne! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSubcollectionAccessTest

	self moreThan3Elements.
	self assert: self moreThan3Elements size > 2! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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: 'requirements' stamp: ''!
moreThan3Elements
	" return a collection including atLeast 3 elements"
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!FloatArrayTest methodsFor: 'tests - sorting' stamp: ''!
testSort
	| result tmp |
	result := self unsortedCollection sort.
	tmp := result at: 1.
	result do:
		[:each | self assert: each>=tmp. tmp:= each. ].! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDoEmpty
	| result |
	result := OrderedCollection new.
	self empty reverseDo: [ :each | result add: each ].

	self assertEmpty: result! !

!FloatArrayTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollect
	
	| result firstCollection secondCollection index  |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	result := firstCollection  with: secondCollection collect:
		[:a :b |
		( index := index + 1).
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals:  b.
		b].
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (secondCollection  at: i)].
	self assert: result size = secondCollection size! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
elementsCopyNonIdenticalWithoutEqualElements
	" return a collection that does niot incllude equal elements ( classic equality )
	all elements included are elements for which copy is not identical to the element  "
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
testOFixtureReplacementSequencedTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.

	self elementInForReplacement.
	self assert: (self nonEmpty includes: self elementInForReplacement).

	self newElement.

	self firstIndex.
	self assert: (self firstIndex >= 1 & self firstIndex) <= self nonEmpty size.

	self secondIndex.
	self assert: (self secondIndex >= 1 & self secondIndex) <= self nonEmpty size.

	self assert: self firstIndex <= self secondIndex.

	self replacementCollection.

	self replacementCollectionSameSize.
	self assert: self secondIndex - self firstIndex + 1 equals: self replacementCollectionSameSize size! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLastNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
moreThan4Elements

" return a collection including at leat 4 elements"
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
collectionWithNonIdentitySameAtEndAndBegining
	" return a collection with elements at end and begining equals only with classic equality (they are not the same object).
(others elements of the collection are not equal to those elements)"
	^ collectionWithSameAtEndAndBegining! !

!FloatArrayTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!FloatArrayTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', '.
	
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString withIndexDo: 
		[:el :i |  self assert: el equals: ((self nonEmpty at:i)asString)]! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsCollect
	| index result |
	index := 0.

	result := self nonEmptyMoreThan1Element
		pairsCollect: [ :each1 :each2 | 
			self assert: (self nonEmptyMoreThan1Element indexOf: each2) equals: (index := index + 2).
			(self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1) ].

	result do: [ :each | self assert: each ]! !

!FloatArrayTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printElementsOn: aStream.
	allElementsAsString:=(result findBetweenSubstrings: ' ').
	allElementsAsString withIndexDo: 
		[:el :i | self assert: el equals: ((self nonEmpty at: i)asString) ]! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
nonEmptyMoreThan1Element
" return a collection that doesn't includes equal elements' and doesn't include nil elements'" 
	^nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtRandom

	| result |
	result := self nonEmpty atRandom.
	self assert: (self nonEmpty includes: result)! !

!FloatArrayTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!FloatArrayTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllIndexesPut
	
	self nonEmpty atAllPut: self aValue.
	self nonEmpty do:[ :each| self assert: each = self aValue].! !

!FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringOne
	
	"self assert: self oneItemCol asCommaString = '1'.
	self assert: self oneItemCol asCommaStringAnd = '1'."

	self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString).
	self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString)! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	^ elementNotIn! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
anotherElementNotIn
" return an element different of 'elementNotIn'  not included in 'nonEmpty' "
	^ elementNotIn! !

!FloatArrayTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfIfAbsentDuplicate

	| 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 ]) equals: 1! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testFirstSecondThird

	self assert: self moreThan4Elements first equals: (self moreThan4Elements at: 1).
	self assert: self moreThan4Elements second equals: (self moreThan4Elements at: 2).
	self assert: self moreThan4Elements third equals: (self moreThan4Elements at: 3).
	self assert: self moreThan4Elements fourth equals: (self moreThan4Elements at: 4)! !

!FloatArrayTest methodsFor: 'tests' stamp: ''!
testSumWithIntegerScalar
	| floatArray scalar expectedResult actualResult |
	
	floatArray := #(1 2) asFloatArray.
	scalar := 3.
	
	expectedResult := #(4 5) asFloatArray.
	actualResult := floatArray + scalar.
	
	self assert: actualResult equals: expectedResult.! !

!FloatArrayTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterEmpty
	| result |
	result := self empty copyAfter: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfIfAbsentDuplicate

	| 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 ]) equals: collection size! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionClass 
	"Return the class to be used to create instances of the class tested"
	
	^ FloatArray! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureBeginsEndsWithTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self assert: self nonEmpty size > 1.
	self empty.
	self assertEmpty: self empty! !

!FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterLastWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the last occurrence of element :"
	result := collection copyAfterLast: element.

	"Verify content"
	self assertEmpty: result! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtIfAbsent

	| 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' stamp: ''!
testMiddle

	self assert: self moreThan4Elements middle equals: (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! !

!FloatArrayTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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 - copying same contents' stamp: ''!
testReverse

	| result |
	result := self nonEmpty reversed.	
	"verify content of 'result: '"
	1 to: result size do:
		[:i | self assert: ((result at: i) 
			= (self nonEmpty at: (self nonEmpty size - i + 1)))].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
elementNotIn
"return an element not included in 'nonEmpty' "

	^ elementNotIn! !

!FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
firstIndex
" return an index between 'nonEmpty' bounds that is < to 'second index' "
	^2! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testBeforeIfAbsent

	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 - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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 - sorting' stamp: ''!
testIsSorted
	self assert: self sortedInAscendingOrderCollection isSorted.
	self deny: self unsortedCollection isSorted! !

!FloatArrayTest methodsFor: 'tests - subcollections access' stamp: ''!
testLastNElements

	| result |
	result := self moreThan3Elements last: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i + 1) ].
	self assert: result size equals: (self moreThan3Elements size - 1).
	self 
		should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ]
		raise: Error! !

!FloatArrayTest methodsFor: 'tests - creation' stamp: ''!
testWithAll

	| aCol collection |
	collection := self collectionMoreThan5Elements asOrderedCollection.
	aCol := self collectionClass withAll: collection.
	
	collection do: [ :each | self assert: (aCol occurrencesOf: each ) equals: ( collection occurrencesOf: each ) ].
	
	self assert: aCol size equals: collection size! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
valueArray
" return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty'  at indexes in 'indexArray' "
	| result |
	result := Array new: self indexArray size.
	1 to: result size do:
		[:i |
		result at:i put: (self aValue ).
		].
	^ result.! !

!FloatArrayTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printNameOn: aStream.

	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents equals: ('an ',self nonEmpty class name ) ]
		ifFalse:[ self assert: aStream contents equals: ('a ',self nonEmpty class name)].! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithCopyNonIdentical
	" return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)"
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!FloatArrayTest methodsFor: 'tests - equality' stamp: ''!
testHasEqualElementsOfIdenticalCollectionObjects
	
	self assert: (self empty hasEqualElements: self empty). 
	self assert: (self nonEmpty hasEqualElements: self nonEmpty)! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
" return a collection elements that can be sorte ( understanding message ' < '  or ' > ')"
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButFirstDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButFirstDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i +1))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element size-1)! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLastEmpty
	| result |
	result := self empty copyUpToLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!FloatArrayTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAtIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutTest
	self aValue.
	self anotherValue.

	self anIndex.
	self nonEmpty isDictionary ifFalse: [ self assert: (self anIndex >= 1 & self anIndex) <= self nonEmpty size ].

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!FloatArrayTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWithManyOccurrence
	| result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff |
	" testing fixture here as this method may be not used for collection that can't contain equals element :"
	self collectionWith2TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection) = 2.	" test :"
	diff := self replacementCollection size - self oldSubCollection size.
	result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection.	"detecting indexes of olSubCollection"
	firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection.	" verifying that replacementCollection has been put in places of oldSubCollections "
	firstIndexesOfOccurrence
		do: [ :each | 
			(firstIndexesOfOccurrence indexOf: each) = 1
				ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ]
				ifFalse: [ each + diff to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ].	" verifying that the 'between' parts correspond to the initial collection : "
	1 to: firstIndexesOfOccurrence size do: [ :i | 
		i = 1
			ifTrue: [ 1 to: (firstIndexesOfOccurrence at: i) - 1 do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ]
			ifFalse: [ 
				resultBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self replacementCollection size.
				collectionBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self oldSubCollection size.
				1 to: (firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | 
					self
						assert:
							(result at: resultBetweenPartIndex + i - 1)
								= (self collectionWith2TimeSubcollection at: collectionBetweenPartIndex + i - 1) ] ]	" specific comportement for the begining of the collection :"	" between parts till the end : " ].	"final part :"
	1 to: self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size) do: [ :i | 
		self
			assert:
				(result at: firstIndexesOfOccurrence last + self replacementCollection size - 1 + i)
					= (self collectionWith2TimeSubcollection at: firstIndexesOfOccurrence last + self oldSubCollection size - 1 + i) ]! !

!FloatArrayTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!FloatArrayTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOf

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection lastIndexOf: element) = 1.
	self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutOneOrMoreElementsTest
	self aValue.


	self indexArray.
	self indexArray
		do: [ :each | 
			self assert: each class = SmallInteger.
			self assert: (each >= 1 & each) <= self nonEmpty size ].

	self assert: self indexArray size = self valueArray size.

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDoError
	
	self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error! !

!FloatArrayTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignForSequenceableCollections

	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' stamp: ''!
testEqualSignIsTrueForEmptyButNonIdenticalCollections
	
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy! !

!FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingStartWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty .
	result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ).
	
	"verify content of 'result' : "
	1 to: 2   do:
		[:i | self assert: ( element ) = ( result at:(i) ) ].
	
	3 to: result size do:
		[:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ].

	"verify size of 'result' :"
	self assert: result size = (self nonEmpty size + 2).! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
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 - copying with or without' stamp: ''!
testCopyWithSequenceable

	| result index element |
	index := self indexInNonEmpty.
	element := self nonEmpty at: index.
	result := self nonEmpty copyWith: (element ).
	
	self assert: result size equals: (self nonEmpty size + 1).
	self assert: result last equals: element.
	
	1 to: (result size - 1) do:
		[ :i | self assert: (result at: i) equals: ( self nonEmpty at: i)]! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDoEmpty
	| result |
	result := OrderedCollection new.

	self empty keysAndValuesDo: [ :i :value | result add: value + i ].

	self assertEmpty: result! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexCollect
	
	| result index collection |
	index := 0.
	collection := self nonEmptyMoreThan1Element .
	result := collection  withIndexCollect: [:each :i | 
		self assert: i equals: (index := index + 1).	
		self assert: i equals: (collection  indexOf: each).
		each ]. 
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (collection at: i)].
	self assert: result size equals: collection size! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
elementInForIndexAccessing
" return an element included in 'collectionMoreThan1NoDuplicates' "
	^ elementInNonEmpty .! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDetectSequenced
	"Testing that detect keep the first element returning true for sequenceable collections"

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element  detect: [:each | each notNil ].
	self assert: result equals: element! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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 - index access' stamp: ''!
testLastIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection last.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: 99! !

!FloatArrayTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWithInsertion
	| result  indexOfSubcollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: ( indexOfSubcollection - 1 ) with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'' : '"
	
	1 to: (indexOfSubcollection -1) do: 
		[
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i)=(result at: i)
		].
	
	" middle part containing replacementCollection : "
	indexOfSubcollection  to: (indexOfSubcollection  + self replacementCollection size-1) do: 
		[
		:i |
		self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 ))
		].
	
	" end part :"
	(indexOfSubcollection  + self replacementCollection size) to: (result size) do:
		[:i|
		self assert: (result at: i)=(self collectionWith1TimeSubcollection  at: (i-self replacementCollection size))].
	
	" verify size: "	
	self assert: result size=(self collectionWith1TimeSubcollection  size + self replacementCollection size).! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan5Elements
" return a collection including at least 5 elements"
	
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
secondIndex
" return an index between 'nonEmpty' bounds that is > to 'first index' "
	^self firstIndex +1! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopySameContentsTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionWith2TimeSubcollection
" return a collection including 'oldSubCollection'  two or many time "
	^ collectionWith2TimeSubcollection ifNil: [ collectionWith2TimeSubcollection := self collectionWith1TimeSubcollection, self oldSubCollection  ].! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLast

	| index |
	self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last.

	index := self moreThan4Elements indexOf: self elementInForElementAccessing.
	self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! !

!FloatArrayTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
secondCollection
" return a collection that will be the second part of the concatenation"
	^ collectionWithEqualElements! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self collection anyOne! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
nonEmpty

	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
elementNotInForIndexAccessing
" return an element not included in 'collectionMoreThan1NoDuplicates' "
	^ elementNotIn! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testCollectFromTo
	
	| result |
	result:=self nonEmptyMoreThan1Element 
		collect: [ :each | each ]
		from: 1
		to: (self nonEmptyMoreThan1Element size - 1).
		
	1 to: result size
		do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ].
	self assert: result size = (self nonEmptyMoreThan1Element size - 1)! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
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 - arithmetic' stamp: ''!
testArithmeticCoercion
	"This test is related to http://bugs.squeak.org/view.php?id=6782"
	
	self assert: 3.0 / (FloatArray with: 2.0) equals: (FloatArray with: 1.5).
	self assert: 3.0 * (FloatArray with: 2.0) equals: (FloatArray with: 6.0).
	self assert: 3.0 + (FloatArray with: 2.0) equals: (FloatArray with: 5.0).
	self assert: 3.0 - (FloatArray with: 2.0) equals: (FloatArray with: 1.0).
	self assert: 3.0 / (FloatArray with: 2.0) equals: (FloatArray with: 1.5).
	self assert: 3.0 * (FloatArray with: 2.0) equals: (FloatArray with: 6.0).
	self assert: 3.0 + (FloatArray with: 2.0) equals: (FloatArray with: 5.0).
	self assert: 3.0 - (FloatArray with: 2.0) equals: (FloatArray with: 1.0)! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
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: ''!
anotherValue
" return a value ( not eual to 'aValue' ) to put into nonEmpty "
	^ elementInNonEmpty! !

!FloatArrayTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfIfAbsent

	| collection |
	collection := self collectionMoreThan1NoDuplicates.
	self assert: (collection 
			indexOf: collection first
			ifAbsent: [ 33 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 33 ]) equals: 33! !

!FloatArrayTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ FloatArray! !

!FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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 - fixture' stamp: ''!
test0FixtureCopyPartOfForMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!FloatArrayTest methodsFor: 'tests - copying same contents' stamp: ''!
testReversed

	| result |
	result := self nonEmpty reversed.
	
	"Verify content"
	result withIndexDo:
		[:el :i | self assert: el equals: (self nonEmpty at: (self nonEmpty size - i + 1))].

	"Verify size"
	self assert: result size=self nonEmpty size.! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFromToDo
	
	| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each].
	
	1 to: (self nonEmptyMoreThan1Element  size -1) do:
		[:i | self assert: (self nonEmptyMoreThan1Element at:i) = (result at:i) ].

	self assert: result size = (self nonEmptyMoreThan1Element size - 1).! !

!FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
empty
	^ empty! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDo
	| result |
	result := OrderedCollection new.
	self nonEmpty reverseDo: [: each | result add: each].
	
	1 to: result size do:
		[:i|
		self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))]! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0TSequencedStructuralEqualityTest

	self nonEmpty at: 1	"Ensures #nonEmpty is sequenceable"! !

!FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionWith1TimeSubcollection
" return a collection including 'oldSubCollection'  only one time "
	^ collectionWith1TimeSubcollection ifNil: [ collectionWith1TimeSubcollection := collectionWithSameAtEndAndBegining  , self oldSubCollection , collectionWithSameAtEndAndBegining  ].! !

!FloatArrayTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	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 - begins ends with' stamp: ''!
testsEndsWith
	
	self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst).
	self assert: (self nonEmpty endsWith: self nonEmpty).
	self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCreationWithTest

	self collectionMoreThan5Elements.
	self assert: self collectionMoreThan5Elements size >= 5! !

!FloatArrayTest methodsFor: 'tests - sorting' stamp: ''!
testSortedUsingBlock
	| result tmp |
	result := self unsortedCollection sorted:  [:a :b | a>b]..
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!FloatArrayTest methodsFor: 'tests - arithmetic' stamp: ''!
testDotProduct
	| a b |
	a := #(2.0 3.0 4.0 5.0) asFloatArray.
	b := #(2.0 3.0 4.0 5.0) asFloatArray.
	self assert: (a dot: b) equals: 54! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLastEmpty
	| result |
	result := self empty copyAfterLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
withEqualElements
	^ collectionWithEqualElements! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan1NoDuplicates
	" return a collection of size > 1 without equal elements"
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfStartingAtDuplicate

	| 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 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 55 ]) equals: 1! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
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 - subcollections access' stamp: ''!
testAllButFirstNElements

	| allButFirst collection |
	collection := self moreThan3Elements.
	allButFirst := collection allButFirst: 2.
	allButFirst withIndexDo: 
		 [:el :i | self assert: el equals: (collection at: i + 2) ].
	self assert: allButFirst size + 2 equals: collection size! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithSameAtEndAndBegining
" return a collection with elements at end and begining equals .
(others elements of the collection are not equal to those elements)"
	^ collectionWithSameAtEndAndBegining! !

!FloatArrayTest methodsFor: 'tests' stamp: ''!
testSumWithIntegerArray
	| floatArray integerArray expectedResult actualResult |
	
	floatArray := #(1 2) asFloatArray.
	integerArray := #(3 4) asIntegerArray.
	
	expectedResult := #(4 6) asFloatArray.
	actualResult := floatArray + integerArray.
	
	self assert: actualResult equals: expectedResult.! !

!FloatArrayTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
" return a collection of size 1 including one element"
	^ nonEmpty1Element! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithIdentical
	"Return a collection of type: 'self collectionWIithoutEqualsElements class containing two elements equals (with identity equality)."

	| result collection anElement |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := collection first.
	collection add: anElement.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
indexArray
" return a Collection including indexes between bounds of 'nonEmpty' "

	^ { 1. 4. 3.}! !

!FloatArrayTest methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWith
	
	self assert: (self nonEmpty beginsWith: (self nonEmpty copyUpTo: self nonEmpty last)).
	self assert: (self nonEmpty beginsWith: self nonEmpty).
	self deny: (self nonEmpty beginsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
sortedInAscendingOrderCollection
	"Return a collection sorted in ascending order"
	^ sortedCollection ifNil: [ sortedCollection := ( FloatArray new: 3)at: 1 put: 1.0 ; at: 2 put: 2.0 ; at: 3 put: 3.0 ; yourself ]! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest

	self nonEmpty! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
indexInForCollectionWithoutDuplicates
" return an index between 'collectionWithoutEqualsElements'  bounds"
	^ 2.! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!FloatArrayTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopy

	| result |
	result := self nonEmpty shallowCopy.
	
	"Verfy content"
	self nonEmpty withIndexDo:
		[:el :i | self assert: (result at:i) equals: (self nonEmpty at:i)].
	
	"Verify size"
	self assert: result size equals: self nonEmpty size.! !

!FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty.
	result := self nonEmpty forceTo: (self nonEmpty size + 2) paddingWith: element.
	
	"Verify content of 'result'"
	self nonEmpty withIndexDo:
		[:el :index | self assert: el equals: (result at: index) ].
	
	(result size - 1) to: result size do:
		[:i | self assert: (result at:i) equals: element ].

	"Verify size of 'result'"
	self assert: result size equals: self nonEmpty size + 2! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsDo

	| index |
	index:=1.
	
	self nonEmptyMoreThan1Element  pairsDo: 
		[:each1 :each2 | 
		self assert: (self nonEmptyMoreThan1Element at:index) equals: each1.
		self assert: (self nonEmptyMoreThan1Element at:(index+1)) equals: each2.
		index := index + 2 ].
	
	self nonEmptyMoreThan1Element size odd
		ifTrue:[ self assert: index equals: self nonEmptyMoreThan1Element size ]
		ifFalse:[ self assert: index equals: (self nonEmptyMoreThan1Element size+1) ]! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtWrap
	"
	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 - subcollections access' stamp: ''!
testAllButLast

	| abf col |
	col := self moreThan3Elements.
	abf := col allButLast.
	self deny: abf last = col last.
	self assert: abf size + 1 equals: col size! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexDo

	|  indexes elements |
	indexes:= OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:value :i  |
			indexes  add: (i).
			elements add: value ].
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:el :i |
			self assert: (indexes at: i) equals: i.
			self assert: (elements at: i) equals: el ].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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 - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!FloatArrayTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLastNElements

	| allButLast collection |
	collection := self moreThan3Elements.
	allButLast := collection allButLast: 2.
	allButLast withIndexDo: [:el :i | self assert: el equals: (collection at: i) ].
	self assert: allButLast size + 2 equals: collection size! !

!FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	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 - begins ends with' stamp: ''!
testsBeginsWithEmpty
	
	self deny: (self nonEmpty beginsWith:(self empty)).
	self deny: (self empty beginsWith:(self nonEmpty))! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithOrWithoutSpecificElementsTest

	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self indexInNonEmpty.
	self assert: self indexInNonEmpty > 0.
	self assert: self indexInNonEmpty <= self nonEmpty size! !

!FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithFirst

	| index element result |
	index:= self indexInNonEmpty .
	element:= self nonEmpty at: index.
	
	result := self nonEmpty copyWithFirst: element.	
	
	self assert: result size = (self nonEmpty size + 1).
	self assert: result first = element .
	
	2 to: result size do:
	[ :i |
	self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! !

!FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfDuplicate

	| 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) equals: collection size! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpTo

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection   copyUpTo: (collection  at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at:i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllPut
 
	self nonEmpty atAll: self indexArray put: self aValue.
	
	self indexArray do:
		[:i | self assert: (self nonEmpty at: i) equals: self aValue ]! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLast

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection copyUpToLast: (collection at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at: i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!FloatArrayTest methodsFor: 'tests' stamp: ''!
testSumWithFloatScalar
	| floatArray scalar expectedResult actualResult |
	
	floatArray := #(1 2) asFloatArray.
	scalar := 0.1.
	
	expectedResult := #(1.1 2.1) asFloatArray.
	actualResult := floatArray + scalar.
	
	self assert: actualResult equals: expectedResult.! !

!FloatArrayTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!FloatArrayTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			lastIndexOf: element
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 99 ]) equals: 99! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToLastWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyUpToLast:' should copy until the last occurrence :"
	result := collection copyUpToLast: (element ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (collection at: i) ].
	
	self assert: result size equals: (collection size - 1)! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
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: 'tests - fixture' stamp: ''!
test0SortingArrayedTest
	| tmp sorted |
	" an unsorted collection of number "
	self unsortedCollection.
	self unsortedCollection do: [ :each | each isNumber ].
	sorted := true.
	self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ].
	self deny: sorted.	" a collection of number sorted in an ascending order"
	self sortedInAscendingOrderCollection.
	self sortedInAscendingOrderCollection do: [ :each | each isNumber ].
	tmp := self sortedInAscendingOrderCollection at: 1.
	self sortedInAscendingOrderCollection
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	firstCollection  with: secondCollection do:
		[:a :b |
		index := index + 1.
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals: b ]! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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 - iterate on sequenced reable collections' stamp: ''!
testGroupsOfAtATimeCollect
	| groupsOf2 |
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: [ :x | x ]).
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: #yourself).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 2 atATimeCollect: [ :x | x ].
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 2.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 2 ]).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 3 atATimeCollect: #yourself.
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 3.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 3 ]).! !

!FloatArrayTest methodsFor: 'tests' stamp: ''!
testSumWithOrderedCollection
	| floatArray collection expectedResult actualResult |
	
	floatArray := #(1 2) asFloatArray.
	collection := #(3 4) asOrderedCollection.
	
	expectedResult := #(4 6) asFloatArray.
	actualResult := floatArray + collection.
	
	self assert: actualResult equals: expectedResult.! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithReplacementTest
	self replacementCollection.
	self oldSubCollection.
	self collectionWith1TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
elementToAdd
" return an element of type 'nonEmpy' elements'type'  not  yet included in nonEmpty" 
	^ elementNotIn! !

!FloatArrayTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAtIfAbsent
	| absent subcollection collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ].
	self deny: absent.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ].
	self assert: absent! !

!FloatArrayTest methodsFor: 'tests - arithmetic' stamp: ''!
testAddNoMutation
	"this test checks that addition does not impact the orginal arrays"

	| a b c |
	a := { 1.2. 2.3 } asFloatArray.
	b := { 1.2. 2.3 } asFloatArray.
	c := a + b.
	self assert: a equals: { 1.2. 2.3 } asFloatArray.
	self assert: b equals: { 1.2. 2.3 } asFloatArray! !

!FloatArrayTest methodsFor: 'tests - converting' stamp: ''!
testAsSet
 	"Test with a collection without equal elements"
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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 - begins ends with' stamp: ''!
testsEndsWithEmpty
	
	self deny: (self nonEmpty endsWith: self empty).
	self deny: (self empty endsWith: self nonEmpty)! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLast

	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection copyAfterLast: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!FloatArrayTest methodsFor: 'tests - at put' stamp: ''!
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 - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!FloatArrayTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!FloatArrayTest methodsFor: 'tests - at put' stamp: ''!
testAtPut
	
	self nonEmpty at: self anIndex put: self aValue.
	self assert: (self nonEmpty at: self anIndex) = self aValue.! !

!FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtWrapPut
	 
	| index |
	index := self indexArray anyOne.
	
	self nonEmpty atWrap: 0 put: self aValue.
	self assert: self nonEmpty last equals: self aValue.
	
	self nonEmpty atWrap: (self nonEmpty size + 1) put: self aValue.
	self assert: self nonEmpty first equals: self aValue.
	
	self nonEmpty atWrap: index put: self aValue.
	self assert: (self nonEmpty at: index) equals: self aValue.
	
	self nonEmpty atWrap: (self nonEmpty size + index) put: self aValue .
	self assert: (self nonEmpty at: index) equals: self aValue.! !

!FloatArrayTest methodsFor: 'tests - creation' stamp: ''!
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 ) equals: (collection occurrencesOf: element1).
	self assert: (aCol occurrencesOf: element2 ) equals: (collection occurrencesOf: element2)! !

!FloatArrayTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceAllWith
	| result collection oldElement newElement oldOccurrences |
	collection := self nonEmpty.
	result := collection copy.
	oldElement := self elementInForReplacement.
	newElement := self newElement.
	oldOccurrences := (result occurrencesOf: oldElement) + (result occurrencesOf: newElement).
	result replaceAll: oldElement with: newElement.
	
	self assert: oldOccurrences equals: (result occurrencesOf: newElement)! !

!FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutIndex

	| result index |	
	index := self indexInNonEmpty.
	result := self nonEmpty copyWithoutIndex: index.
	
	"Verify content of result"
	result withIndexDo: 
		[:element :i | 
		 i <  index ifTrue: [ self assert: element equals: (self nonEmpty at: i) ].
		 i >= index ifTrue: [ self assert: element equals: (self nonEmpty at: (i + 1)) ]].
	
	"Verify size of result"
	self assert: result size equals: (self nonEmpty size - 1)! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
newElement
"return an element that will be put in the collection in place of another"
	^ elementNotIn! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
anIndex
" return an index in nonEmpty bounds"
	^ 2! !

!FloatArrayTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceFromToWithStartingAt
	| result repStart collection replacementCollec firstInd secondInd |
	collection := self nonEmpty.
	result := collection copy.
	replacementCollec := self replacementCollectionSameSize.
	firstInd := self firstIndex.
	secondInd := self secondIndex.
	repStart := replacementCollec size - (secondInd - firstInd + 1) + 1.
	result replaceFrom: firstInd to: secondInd with: replacementCollec startingAt: repStart.
	
	"Verify content of 'result'"
	
	"First part of 'result'" 	
	1 to: (firstInd - 1) do: [:i | self assert: (collection at:i) equals: (result at: i) ].
	
	"Middle part containing replacementCollection"	
	firstInd to: (replacementCollec size - repStart +1) do: 
		[:i| self assert: (result at: i) equals: (replacementCollec at: (repStart + (i - firstInd))) ].
	
	"End part"
	(firstInd + replacementCollec size) to: (result size) do:
		[ :i | self assert: (result at: i) equals: (collection at: (secondInd + 1 - (firstInd + replacementCollec size) + i)) ]! !

!FloatArrayTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	empty := FloatArray new.
	elementInNonEmpty := 7.0.
	nonEmpty5ElementsNoDuplicate := (FloatArray new: 5)
		at: 1 put: 1.5;
		at: 2 put: 2.5;
		at: 3 put: elementInNonEmpty;
		at: 4 put: 4.5;
		at: 5 put: 5.5;
		yourself.
	elementNotIn := 999.0.
	elementTwiceIn := 2.3.
	collectionWithEqualElements := (FloatArray new: 3)
		at: 1 put: 2.0;
		at: 2 put: 2.0;
		at: 3 put: 3.5;
		yourself.
	nonEmpty1Element := (FloatArray new: 1)
		at: 1 put: 1.2;
		yourself.
	collectionWithSameAtEndAndBegining := (FloatArray new: 3)
		at: 1 put: 2.0;
		at: 2 put: 1.0;
		at: 3 put: 2.0 copy;
		yourself! !

!FloatArrayTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!FloatArrayTest methodsFor: 'tests' stamp: ''!
testSorted
	| result tmp unsorted |
	unsorted := self unsortedCollection.
	result := unsorted sorted.
	self deny: unsorted == result.
	tmp := result at: 1.
	result
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringMore

	"self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'.
	self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3'"

	| result resultAnd index allElementsAsString |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
 
	index := 1.
	(result findBetweenSubstrings: ',' )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 findBetweenSubstrings: ',' ).
	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 - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result:= self empty,self secondCollection .
	
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:i).
		].
	"size : "
	self assert: result size = ( self secondCollection size).! !

!FloatArrayTest methodsFor: 'tests - sorting' stamp: ''!
testIsSortedBy
	self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]).
	self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]).! !

!FloatArrayTest methodsFor: 'tests - at put' stamp: ''!
testAtPutOutOfBounds
	
	self should: [self empty at: self anIndex put: self aValue] raise: Error! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
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 - element accessing' stamp: ''!
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' stamp: ''!
testLast

	self assert: self moreThan4Elements last equals: (self moreThan4Elements at: self moreThan4Elements size)! !

!FloatArrayTest methodsFor: 'tests - creation' stamp: ''!
testWith
	
	| aCol anElement |
	anElement := self collectionMoreThan5Elements anyOne.
	aCol := self collectionClass with: anElement.
	self assert: (aCol includes: anElement).! !

!FloatArrayTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation
	| result index |
	result:= self firstCollection,self secondCollection .
	"first part : "
	index := 1.
	self firstCollection do: 
		[:each | 
		self assert: (self firstCollection at: index)=each.
		index := index+1.].
	"second part : "
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:index).
		index:=index+1].
	"size : "
	self assert: result size = (self firstCollection size + self secondCollection size).! !

!FloatArrayTest methodsFor: 'tests - creation' stamp: ''!
testOfSize
	
	| aCol |
	aCol := self collectionClass ofSize: 3.
	self assert: aCol size equals: 3.! !

!FloatArrayTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContentsSized
	| result |
	result:= self collectionClass new: 1 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.
	
	result:= self collectionClass new: 1000 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!FloatArrayTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopyEmpty
	| result |
	result := self empty shallowCopy.
	self assertEmpty: result! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertAsSetForMultiplinessTest
	"a collection  with equal elements:"

	| res |
	self withEqualElements.
	res := true.
	self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res = true! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
replacementCollection
" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection'  " 
	^ collectionWithSameAtEndAndBegining! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
howMany: aSubCollection in: collection
" return an integer representing how many time 'subCollection'  appears in 'collection'  "
	| tmp nTime |
	tmp := collection.
	nTime:= 0.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				nTime := nTime + 1.
				1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.]
				]
			ifFalse: [tmp := tmp copyWithoutFirst.]
		 ].
	
	^ nTime.! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
firstCollection
" return a collection that will be the first part of the concatenation"
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateSequencedReadableTest
	| res |
	self nonEmptyMoreThan1Element.
	self assert: self nonEmptyMoreThan1Element size > 1.

	self empty.
	self assertEmpty: self empty.

	res := true.
	self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
unsortedCollection
" retur a collection that is not yat sorted"
	^nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!FloatArrayTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessTest
	| res |
	self collectionMoreThan1NoDuplicates.
	self assert: self collectionMoreThan1NoDuplicates size > 1.
	res := true.
	self collectionMoreThan1NoDuplicates
		detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self elementInForIndexAccessing.
	self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing).
	self elementNotInForIndexAccessing.
	self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDo! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
aValue
" return a value to put into nonEmpty"
	^ elementNotIn! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
" return a collection of elements included in 'nonEmpty'  "
	^ nonEmptySubcollection 
	ifNil: [ nonEmptySubcollection := (FloatArray new:2 ) at:1 put: self nonEmpty first ; at:2 put: self nonEmpty last ; yourself ]! !

!FloatArrayTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!FloatArrayTest methodsFor: 'tests - copying with replacement' stamp: ''!
firstIndexesOf: aSubCollection in: collection
" return an OrderedCollection with the first indexes of the occurrences of subCollection in  collection "
	| tmp result currentIndex |
	tmp:= collection.
	result:= OrderedCollection new.
	currentIndex := 1.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				result add: currentIndex.
				1 to: aSubCollection size do: 
					[:i | 
					tmp := tmp copyWithoutFirst.
					currentIndex := currentIndex + 1]
				]
			ifFalse: [
				tmp := tmp copyWithoutFirst.
				currentIndex := currentIndex +1.
				]
		 ].
	
	^ result.! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
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 - copying part of sequenceable' stamp: ''!
testCopyFromTo
	| result  index collection |
	collection := self collectionWithoutEqualElements .
	index :=self indexInForCollectionWithoutDuplicates .
	result := collection   copyFrom: index  to: collection  size .
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at:i) equals: (collection  at: (i + index - 1))].
	
	"Verify size"
	self assert: result size equals: (collection  size - index + 1)! !

!FloatArrayTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	allElementsAsString withIndexDo: 
		[:el :i | 
		i=1
			ifTrue:[
				self accessCollection class name first isVowel 
					ifTrue:[self assert: el equals: 'an' ]
					ifFalse:[self assert: el equals: 'a'].].
		i=2
			ifTrue:[self assert: el equals: self accessCollection class name].
		i>2
			ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]]! !

!FloatArrayTest methodsFor: 'tests - subcollections access' stamp: ''!
testFirstNElements

	| result |
	result := self moreThan3Elements first: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i) ].
	
	self assert: result size equals: (self moreThan3Elements size - 1).
	self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: SubscriptOutOfBounds! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the first occurrence:"
	result := collection   copyAfter: (element ).
	
	"Verifying content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + 1 )) equals: (result at: (i)) ].

	"Verify size"
	self assert: result size equals: (collection size - 1).! !

!FloatArrayTest methodsFor: 'testing' stamp: ''!
testFloatArrayPluginPrimitiveAt
	"if FloatArrayPlugin primitive are not here, this test is dumb.
	Otherwise, it will compare primitive and #fromIEEE32Bit:"

	#(2r0.0 2r1.0 2r1.1 2r1.00000000000000000000001 2r1.0e-10 2r1.1e-10 2r1.00000000000000000000001e-10 2r1.0e10 2r1.1e10 2r1.00000000000000000000001e10 2r1.0e-126 2r1.11111111111111111111111e127 2r1.11111111111111111111111e128 2r0.11111111111111111111111e-126 2r0.00000000000000000000001e-126 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 2r1.1111111111111111111111110e127 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) equals: (Float fromIEEE32Bit: ((FloatArray with: e) basicAt: 1)).
			self assert: ((FloatArray with: e negated) at: 1) equals: (Float fromIEEE32Bit: ((FloatArray with: e negated) basicAt: 1)) ].
	"regular numbers no truncation or rounding"

	"smallest float32 before gradual underflow"

	"biggest float32"

	"overflow"

	"gradual underflow"

	"with rounding mode : tests on 25 bits"

	"overflow"

	"gradual underflow"

	"special cases"
	(Array with: Float infinity with: Float infinity negated with: Float negativeZero)
		do: [ :e | self assert: ((FloatArray with: e) at: 1) equals: (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: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	difference := self collectionWithoutEqualElements difference: self empty.
	self assert: difference size = self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each) ]! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
elementNotInForElementAccessing
" return an element not included in 'moreThan4Elements' "
	^ elementNotIn! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDo
	"| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		result add: (value+i)].
	
	1 to: result size do:
		[:i|
		self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]"
	|  indexes elements |
	indexes := OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		indexes  add: (i).
		elements add: value].
	
	(1 to: self nonEmptyMoreThan1Element size )do:
		[ :i |
		self assert: (indexes at: i) equals: i.
		self assert: (elements at: i) equals: (self nonEmptyMoreThan1Element at: i).	
		].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testFromToPut
	
	| collection index |
	index := self indexArray anyOne.
	collection := self nonEmpty copy.
	collection from: 1 to: index  put: self aValue..
	1 to: index do:
		[:i | self assert: (collection at: i)= self aValue].
	(index +1) to: collection size do:
		[:i | self assert: (collection at:i)= (self nonEmpty at:i)].! !

!FloatArrayTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString |
	result:=''.
	aStream:= ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ').
	allElementsAsString withIndexDo: 
		[:el :i | 
		i<(allElementsAsString size-1 )
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:i)asString)].
		i=(allElementsAsString size-1)
			ifTrue:[ self deny: (allElementsAsString at:i) equals: ('and')asString].
		i=(allElementsAsString size)
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:(i-1))asString)]]! !

!FloatArrayTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!FloatArrayTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!FloatArrayTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfSequenceableTest
	self collectionWithoutEqualElements.
	self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ].
	self indexInForCollectionWithoutDuplicates.
	self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size.
	self empty.
	self assertEmpty: self empty! !

!FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfStartingAtDuplicate

	| 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 ]) equals: 1.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 55 ]) equals: collection size! !

!FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result index |
	delim := ', '.
	result := ''.
	multiItemStream := ReadWriteStream on: result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	index:=1.
	(result findBetweenSubstrings: delim)do:
		[:each |
			self assert: each= ((self nonEmpty at:index) asString).
			index:=index+1 ]! !

!FloatArrayTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!FloatArrayTest methodsFor: 'tests - equality' stamp: ''!
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 - index accessing for multipliness' stamp: ''!
testIndexOfDuplicate

	| 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) equals: 1! !

!FloatArrayTest methodsFor: 'tests - sorting' stamp: ''!
testSortUsingSortBlock
	| result tmp |
	result := self unsortedCollection sort: [:a :b | a>b].
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!FloatArrayTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContents
	| result |
	result:= self collectionClass streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
subCollectionNotIn
" return a collection for which at least one element is not included in 'moreThan4Elements' "
	^ collectionNotIncluded 
		ifNil: [ collectionNotIncluded := (FloatArray new: 2) at:1 put: elementNotIn ; at: 2 put: elementNotIn  ; yourself ].! !

!FloatArrayTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWith
	| result  indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1.
	lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection  size -1.
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: lastIndexOfOldSubcollection   with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'  "
	
	1 to: (indexOfSubcollection  - 1) do: 
		[ 
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i) = (result at: i)
		].
	
	" middle part containing replacementCollection : "
	
	(indexOfSubcollection ) to: ( lastIndexOfReplacementCollection  ) do: 
		[
		:i |
		self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1))
		].
	
	" end part :"
	1 to: (result size - lastIndexOfReplacementCollection   ) do:
		[ 
		:i |
		self assert: (result at: ( lastIndexOfReplacementCollection  + i  ) ) = (self collectionWith1TimeSubcollection  at: ( lastIndexOfOldSubcollection  + i  ) ).
		].! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedElementAccessTest

	self moreThan4Elements.
	self assert: self moreThan4Elements size >= 4.
	self subCollectionNotIn.
	self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ].
	self elementNotInForElementAccessing.
	self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing).
	self elementInForElementAccessing.
	self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastError

	self 
		should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ]
		raise: Error! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLast

	| element result |
	element := self nonEmptyMoreThan1Element at: self nonEmptyMoreThan1Element size.
	result := self nonEmptyMoreThan1Element findLast: [:each | each =element].
	
	self assert: result equals: self nonEmptyMoreThan1Element size! !

!FloatArrayTest methodsFor: 'tests - copying same contents' stamp: ''!
testShuffled
	| result |
	result := self nonEmpty shuffled .
	
	"verify content of 'result: '"
	result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size.! !

!FloatArrayTest methodsFor: 'tests - streaming' stamp: ''!
testNewStreamContentsReturnsCollectionOfCorrectSize
	| result item originalSize |
	originalSize := 10.
	item := self firstCollection first.
	result := self collectionClass
		new: originalSize
		streamContents: [ :stream | 
			1 to: originalSize + 1 do: [ :each | stream nextPut: item ].
			stream position: originalSize ].
	self assert: result size equals: originalSize! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToEmpty
	| result |
	result := self empty copyUpTo: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!FloatArrayTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceFromToWith
	| result collection replacementCollec firstInd secondInd |
	collection := self nonEmpty .
	replacementCollec := self replacementCollectionSameSize.
	firstInd := self firstIndex.
	secondInd := self secondIndex.
	result := collection copy.
	result replaceFrom: firstInd to: secondInd with: replacementCollec.
	
	"Verify content of 'result'"

	"First part of 'result'"	
	1 to: (firstInd - 1) do: [:i | self assert: (collection at:i) equals: (result at: i) ].
	
	"Middle part containing replacementCollection"	
	firstInd to: (firstInd + replacementCollec size - 1) do: 
		[:i | self assert: (result at: i) equals: (replacementCollec at: (i - firstInd + 1)) ].
	
	"End part"
	(firstInd + replacementCollec size) to: (result size) do:
		[:i|
		self assert: (result at: i) equals: (collection at: (secondInd + 1 - (firstInd + replacementCollec size) + i)) ]! !

!FloatArrayTest methodsFor: 'testing' stamp: ''!
testFloatArrayPluginPrimitiveAtPut
	"if FloatArrayPlugin primitive are not here, this test is dumb.
	Otherwise, it will compare primitive and #asIEEE32BitWord"

	#(2r0.0 2r1.0 2r1.1 2r1.00000000000000000000001 2r1.0e-10 2r1.1e-10 2r1.00000000000000000000001e-10 2r1.0e10 2r1.1e10 2r1.00000000000000000000001e10 2r1.0e-126 2r1.11111111111111111111111e127 2r1.11111111111111111111111e128 2r0.11111111111111111111111e-126 2r0.00000000000000000000001e-126 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 2r1.1111111111111111111111110e127 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) equals: e asIEEE32BitWord.
			self assert: ((FloatArray with: e negated) basicAt: 1) equals: e negated asIEEE32BitWord ].
	"regular numbers no truncation or rounding"

	"smallest float32 before gradual underflow"

	"biggest float32"

	"overflow"

	"gradual underflow"

	"with rounding mode : tests on 25 bits"

	"overflow"

	"gradual underflow"

	"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) equals: e asIEEE32BitWord ]! !

!FloatArrayTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButLastDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButLastDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i ))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element  size-1)! !

!FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllPutAll

	| aValueArray |
	aValueArray := self valueArray .
	self nonEmpty atAll: self indexArray putAll: aValueArray  .
	
	self indexArray withIndexDo: [:element :index |
		self assert: (self nonEmpty at: element) equals: (aValueArray  at: index) ]! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollectError

	self should: [ self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := firstCollection size.
	
	firstCollection  reverseWith: secondCollection do:
		[:a :b |
	
		self assert: (firstCollection at: index) equals: a. 
		self assert: (secondCollection at: index) equals: b.
			(index := index - 1)]! !

!FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''!
testAtOutOfBounds

	self 
		should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ]
		raise: Error.
	self 
		should: [ self moreThan4Elements at: -1 ]
		raise: Error! !

!FloatArrayTest methodsFor: 'tests - copy' stamp: ''!
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 - copying with replacement' stamp: ''!
testCopyReplaceAllWith1Occurrence
	| 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 part of sequenceable' stamp: ''!
testCopyEmptyMethod
	| result |
	result := self collectionWithoutEqualElements copyEmpty.
	self assertEmpty: result.
	self assert: result class equals: self nonEmpty class! !

!FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfter
	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection   copyAfter: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!FloatArrayTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithCopy
	"Return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals (with identity equality)
	but 2 elements only equals with classic equality"
	
	| result collection |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	collection add: collection first copy.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!FloatArrayTest methodsFor: 'tests - includes' stamp: ''!
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 - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
 	 'copyUpTo:' should copy until the first occurrence"
	result := collection copyUpTo: element.

	"Verify content"
	self assertEmpty: result! !

!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirst

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element findFirst: [:each | each = element].
	
	self assert: result equals: 1! !

!FloatArrayTest methodsFor: 'tests - subcollections access' stamp: ''!
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 - equality' stamp: ''!
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 - index access' stamp: ''!
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) equals: index! !

!FloatArrayTest methodsFor: 'tests - as set tests' stamp: ''!
testAsSetWithEqualsElements

	| result |
	result := self withEqualElements asSet.
	self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = Set! !

!FloatArrayTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	 
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!FloatArrayTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements

" return a collection not including equal elements "
	^ nonEmpty5ElementsNoDuplicate! !

!FloatArrayTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |
	delim := ', '.
	result := ''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!FloatPrintPolicy commentStamp: ''!
I am FloatPrintPolicy.
I am a DynamicVariable.

I control whether Float instances are printed exactly or inexactly. The inexact printing is much faster, but can be less accurate. 

The default policy is ExactFloatPrintPolicy.

FloatPrintPolicy 
	value: InexactFloatPrintPolicy new 
	during: [ Float pi printString ]!
!FloatPrintPolicy methodsFor: 'initialization' stamp: ''!
initialize
	default := ExactFloatPrintPolicy new! !

!FloatPrintPolicy methodsFor: 'accessing' stamp: ''!
default
	^ default! !

!FloatPrintPolicy class methodsFor: 'printing' stamp: ''!
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! !

!FloatReferencesRule commentStamp: ''!
The rule detects if any Float system classes are refferenced by an AST!
!FloatReferencesRule methodsFor: 'accessing' stamp: ''!
rationale

	^ 'You should not reference ',
		(self systemClassNames joinUsing: Character space),
		' as they are there for system purpose and should not be referenced directly.'! !

!FloatReferencesRule methodsFor: 'running' stamp: ''!
basicCheck: node
	node isGlobalVariable ifFalse: [ ^ false ].
	^(self systemClassNames includes: node name)! !

!FloatReferencesRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!FloatReferencesRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Access to a system class'! !

!FloatReferencesRule methodsFor: 'running' stamp: ''!
systemClassNames

	^ #(BoxedFloat64 SmallFloat64)! !

!FloatReferencesRuleTest methodsFor: 'running' stamp: ''!
tearDown

	testClass := nil.
	super tearDown! !

!FloatReferencesRuleTest methodsFor: 'tests' stamp: ''!
testBasicCheck1

	| testMethod |
	testMethod := testClass >> (testClass compile: 'testMethod SmallFloat64').  
	
	self assert: (FloatReferencesRule new basicCheck: testMethod ast body statements first)! !

!FloatReferencesRuleTest methodsFor: 'tests' stamp: ''!
testBasicCheck

	| testMethod |
	testMethod := testClass >> (testClass compile: 'testMethod BoxedFloat64').
	
	self assert: (FloatReferencesRule new basicCheck: testMethod ast body statements first )! !

!FloatReferencesRuleTest methodsFor: 'tests' stamp: ''!
testBasicCheck2

	| testMethod |
	testMethod := testClass >> (testClass compile: 'testMethod').  
	
	self deny: (FloatReferencesRule new basicCheck: testMethod ast)! !

!FloatReferencesRuleTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	testClass := Object newAnonymousSubclass.! !

!FloatTest commentStamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
testDegreeCosForExceptionalValues

	self assert: Float nan degreeCos isNaN.
	self assert: Float infinity degreeCos isNaN.
	self assert: Float infinity negated degreeCos isNaN! !

!FloatTest methodsFor: 'tests - zero behavior' stamp: ''!
testZeroSignificandAsInteger
	"This is about http://bugs.squeak.org/view.php?id=6990"
	
	self assert: 0.0 significandAsInteger equals: 0! !

!FloatTest methodsFor: 'tests - mathematical functions' stamp: ''!
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) equals: aPositive].
              negatives do: [:aNegative |
                      self assert: (aPositiveSign copySignTo: aNegative) equals: aNegative negated].
              
				  self assert: (aPositiveSign copySignTo: zero) sign equals: 0.
              self assert: (aPositiveSign copySignTo: negz) sign equals: 0].

      negatives do: [:aNegativeSign |
              positives do: [:aPositive |
                      self assert: (aNegativeSign copySignTo: aPositive) equals: aPositive negated].
              negatives do: [:aNegative |
                      self assert: (aNegativeSign copySignTo: aNegative) equals: aNegative].
              self assert: (aNegativeSign copySignTo: zero) sign equals: 0.
              self assert: (aNegativeSign copySignTo: negz) sign equals: 0]! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 equals: '0.30000000000000004'.
	self assert: (-0.1-0.2) printString equals: '-0.30000000000000004'.
	self assert: 240 degreesToRadians cos equals: -0.5000000000000004.
  	self assert: 240 degreesToRadians cos abs equals: 0.5000000000000004! !

!FloatTest methodsFor: 'tests - NaN behavior' stamp: ''!
testNaN1
	self assert: Float nan identicalTo: Float nan.
	self deny: Float nan equals: Float nan
	"a NaN is not equal to itself."! !

!FloatTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testStoreOnRoundTrip
	"If storeOn: prints exactly and the parser avoid cumulating round off Errors,
	then Float should be read back exactly.
	Note: there is no guarantee to restore the bit pattern of NaN though"
	
	self assert: (self class compiler evaluate: Float halfPi storeString) equals: Float halfPi.
	self assert: (self class compiler evaluate: Float halfPi negated storeString) equals: Float halfPi negated.
	self assert: (self class compiler evaluate: Float infinity storeString) equals: Float infinity.
	self assert: (self class compiler evaluate: Float infinity negated storeString) equals: Float infinity negated.
	self assert: (self class compiler evaluate: Float nan storeString) isNaN! !

!FloatTest methodsFor: 'tests - arithmetic' stamp: ''!
testZeroRaisedToNegativePower
	"this is a test related to http://bugs.squeak.org/view.php?id=6781"
	
	self should: [0.0 raisedTo: -1] raise: ZeroDivide.
	self should: [0.0 raisedTo: -1.0] raise: ZeroDivide! !

!FloatTest methodsFor: 'tests - conversion' stamp: ''!
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 equals: y.
	
	self assert: x asInteger equals: int.
	
	"this one should be true for any float"
	self assert: x asInteger equals: x asTrueFraction asInteger.

	"a random test"
	r := Random new.
	10000 timesRepeat: [
		x := r next * 1.9999e16 + 1.0e12 .
		self assert: x truncated equals: x asTrueFraction truncated ]! !

!FloatTest methodsFor: 'tests - printing' stamp: ''!
testFloatPrintPolicy
	"It is hard to test printing Floats reliably, but this at least covers the code path"

	| pi |	
	pi := FloatPrintPolicy value: InexactFloatPrintPolicy new during: [ Float pi printString ].
	self assert: (pi beginsWith: '3.14159').
	
	pi := FloatPrintPolicy value: ExactFloatPrintPolicy new during: [ Float pi printString ].
	self assert: (pi beginsWith: '3.14159')! !

!FloatTest methodsFor: 'tests' stamp: ''!
testHash
	self assert: 2 = 2.0 ==> (2 hash = 2.0 hash).
	self assert: 1 / 2 = 0.5 ==> ((1 / 2) hash = 0.5 hash).
	Float nan hash.
	Float infinity hash! !

!FloatTest methodsFor: 'tests - mathematical functions' stamp: ''!
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 equals: 1].
      strictNegatives do: [:aNegative | self assert: aNegative sign equals: -1].

      "The sign of zeros"
      self assert: zero sign equals: 0.
      self assert: negz sign equals: 0.

      "Test the copy sign functions"
      positives do: [:aPositiveSign |
              positives do: [:aPositive |
                      self assert: (aPositive sign: aPositiveSign) equals: aPositive].
              negatives do: [:aNegative |
                      self assert: (aNegative sign: aPositiveSign) equals: aNegative negated].
              self assert: (zero sign: aPositiveSign) sign equals: 0.
              self assert: (negz sign: aPositiveSign) sign equals: 0.
              self assert: (zero sign: aPositiveSign) signBit equals: 0.
              self assert: (negz sign: aPositiveSign) signBit equals: 0].

      negatives do: [:aNegativeSign |
              positives do: [:aPositive |
                      self assert: (aPositive sign: aNegativeSign) equals: aPositive negated].
              negatives do: [:aNegative |
                      self assert: (aNegative sign: aNegativeSign) equals: aNegative].
              self assert: (zero sign: aNegativeSign) sign equals: 0.
              self assert: (negz sign: aNegativeSign) sign equals: 0.
              self assert: (zero sign: aNegativeSign) signBit equals: 1.
              self assert: (negz sign: aNegativeSign) signBit equals: 1]! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testFractionAsFloat
	"use a random test"
	
	| r m frac err collec |
	r := Random new seed: 1234567.
	m := (2 raisedTo: 54) - 1.
	200 timesRepeat: [
		frac := ((r nextInteger: m) * (r nextInteger: m) + 1) / ((r nextInteger: m) * (r nextInteger: m) + 1).
		err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52).
		self assert: err < (1/2)].
	
	collec := #(16r10000000000000 16r1FFFFFFFFFFFFF 1 2 16r20000000000000 16r20000000000001 16r3FFFFFFFFFFFFF 16r3FFFFFFFFFFFFE 16r3FFFFFFFFFFFFD).
	collec do: [:num |
		collec do: [:den |
			frac := Fraction numerator: num denominator: den.
			err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52).
			self assert: err <= (1/2)]]! !

!FloatTest methodsFor: 'tests' stamp: ''!
testCopy
	"Elementary tests"
	
	self assert: 2.0 copy equals: 2.0.
	self assert: -0.5 copy equals: -0.5.
	
	"Are exceptional Floats preserved by the copy ?"
	self assert: Float nan copy isNaN.
	self assert: Float infinity copy equals: Float infinity.
	self assert: Float infinity negated copy equals: Float infinity negated.
	
	"Is the sign of zero preserved by the copy ?"
	self assert: 0.0 copy hex equals: 0.0 hex.
	self assert: Float negativeZero copy hex equals: Float negativeZero hex! !

!FloatTest methodsFor: 'tests - arithmetic' stamp: ''!
testContinuedFractions
	self assert: (Float pi asApproximateFractionAtOrder: 1) equals: (22/7).
	self assert: (Float pi asApproximateFractionAtOrder: 3) equals: (355/113)! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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) equals: 0.
	self assert: (Float negativeZero arcTan: 0) equals: 0.
	self assert: ((0 arcTan: Float negativeZero) closeTo: Float pi).
	self assert: ((Float negativeZero arcTan: Float negativeZero) closeTo: Float pi negated)! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testDegreeSinForExceptionalValues

	self assert: Float nan degreeSin isNaN.
	self assert: Float infinity degreeSin isNaN.
	self assert: Float infinity negated degreeSin isNaN! !

!FloatTest methodsFor: 'tests - NaN behavior' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
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 equals: y.
	self assert: x asTrueFraction equals: int.
	
	"this one should be true for any float
	in order to conform to ISO/IEC 10967-2"
	self assert: x rounded equals: x asTrueFraction rounded.
	self assert: x negated rounded equals: x negated asTrueFraction rounded.

	"a random test"
	r := Random new.
	10000 timesRepeat: [
		x := r next * 1.9999e16 + 1.0e12 .
		self assert: x rounded equals: x asTrueFraction rounded.
		self assert: x negated rounded equals: x negated asTrueFraction rounded ]! !

!FloatTest methodsFor: 'tests - conversion' stamp: ''!
testFloor

	self assert: 1.0 floor equals: 1.
	self assert: 1.1 floor equals: 1.
	self assert: -2.0 floor equals: -2.
	self assert: -2.1 floor equals: -3! !

!FloatTest methodsFor: 'tests - conversion' stamp: ''!
testStringAsNumber
	"This covers parsing in Number>>readFrom:"

	| aFloat |
	aFloat := '10r-12.3456' asNumber.
	self assert: -12.3456 equals: aFloat.
	aFloat := '10r-12.3456e2' asNumber.
	self assert: -1234.56 equals: aFloat.
	aFloat := '10r-12.3456d2' asNumber.
	self assert: -1234.56 equals: aFloat.
	aFloat := '10r-12.3456q2' asNumber.
	self assert: -1234.56 equals: aFloat.
	aFloat := '-12.3456q2' asNumber.
	self assert: -1234.56 equals: aFloat.
	aFloat := '12.3456q2' asNumber.
	self assert: 1234.56 equals: aFloat! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testFractionAsFloat2
	"test rounding to nearest even"
		
	self assert: ((1<<52)+0+(1/4)) asFloat asTrueFraction equals: ((1<<52)+0).
	self assert: ((1<<52)+0+(1/2)) asFloat asTrueFraction equals: ((1<<52)+0).
	self assert: ((1<<52)+0+(3/4)) asFloat asTrueFraction equals: ((1<<52)+1).
	self assert: ((1<<52)+1+(1/4)) asFloat asTrueFraction equals: ((1<<52)+1).
	self assert: ((1<<52)+1+(1/2)) asFloat asTrueFraction equals: ((1<<52)+2).
	self assert: ((1<<52)+1+(3/4)) asFloat asTrueFraction equals: ((1<<52)+2)! !

!FloatTest methodsFor: 'tests - characterization' stamp: ''!
testMaxExactInteger
	self assert: Float maxExactInteger asFloat truncated equals: Float maxExactInteger.
	0 to: 10000 do: [ :j | self assert: (Float maxExactInteger - j) asFloat truncated equals: Float maxExactInteger - j ].
	self deny: (Float maxExactInteger + 1) asFloat truncated equals: Float maxExactInteger + 1! !

!FloatTest methodsFor: 'tests - zero behavior' stamp: ''!
testZero1

	self assert: Float negativeZero equals: 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: '*Kernel-Tests-Extended' stamp: ''!
testInfinityCloseTo
	"This is a test for bug http://bugs.squeak.org/view.php?id=6729"

	self deny: (Float infinity closeTo: Float infinity negated).
	self deny: (Float infinity negated closeTo: Float infinity)! !

!FloatTest methodsFor: 'tests - conversion' stamp: ''!
testTruncated

	self assert: 1.0 truncated equals: 1.
	self assert: 1.1 truncated equals: 1.
	self assert: -2.0 truncated equals: -2.
	self assert: -2.1 truncated equals: -2! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testHugeIntegerCloseTo
	"This is a test for bug http://bugs.squeak.org/view.php?id=7368"

	self deny: (1.0 closeTo: 200 factorial).
	self deny: (200 factorial closeTo: 1.0).
	self assert: (Float infinity closeTo: 200 factorial) equals: (200 factorial closeTo: Float infinity)! !

!FloatTest methodsFor: 'tests - infinity behavior' stamp: ''!
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: 'coverage' stamp: ''!
classToBeTested
	
	^ Float! !

!FloatTest methodsFor: 'tests - conversion' stamp: ''!
testCeiling

	self assert: 1.0 ceiling equals: 1.
	self assert: 1.1 ceiling equals: 2.
	self assert: -2.0 ceiling equals: -2.
	self assert: -2.1 ceiling equals: -2! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 - NaN behavior' stamp: ''!
testNaN4

	| dict |
	dict := Dictionary new.
	dict at: Float nan put: #NaN.
	self deny: (dict includes: Float nan)
	"as a NaN is not equal to itself, it can not be retrieved when it is used as a dictionary key"! !

!FloatTest methodsFor: 'tests - infinity behavior' stamp: ''!
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 equals: i2
	"All infinities are signed. Negative infinity is not equal to Infinity"! !

!FloatTest methodsFor: 'tests - compare' stamp: ''!
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 equals: (1/4).
	self assert: 0.5 equals: (1/2).
	self deny: 0.5 equals: (3/4).
	
	self assert: 0.5 ~= (1/4).
	self deny: 0.5 ~= (1/2).
	self assert: 0.5 ~= (3/4)! !

!FloatTest methodsFor: 'tests - mathematical functions' stamp: ''!
testRaisedTo

	self should: [ -1.23 raisedTo: 1/4 ] raise: ArithmeticError! !

!FloatTest methodsFor: 'tests - conversion' stamp: ''!
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) equals: 1.
	self assert: (Number readFrom: s2) equals: 1! !

!FloatTest methodsFor: 'tests - zero behavior' stamp: ''!
testIsZero

	self assert: 0.0 isZero.
	self deny: 0.1 isZero! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testBinaryLiteralString

	self assert: 0.0 binaryLiteralString equals: '0.0'.
	self assert: 0.0 negated binaryLiteralString equals: '-0.0'.
	self assert: Float infinity binaryLiteralString equals: 'Float infinity'.
	self assert: Float infinity negated binaryLiteralString equals: 'Float infinity negated'.
	self assert: Float nan binaryLiteralString equals: 'Float nan'.

	self assert: Float fminDenormalized binaryLiteralString equals: '2r0.0000000000000000000000000000000000000000000000000001e-1022'.
	self assert: Float fminNormalized binaryLiteralString equals: '2r1.0000000000000000000000000000000000000000000000000000e-1022'.
	self assert: (Float fminNormalized - Float fminDenormalized) binaryLiteralString equals: '2r0.1111111111111111111111111111111111111111111111111111e-1022'.
	self assert: Float epsilon binaryLiteralString equals: '2r1.0000000000000000000000000000000000000000000000000000e-52'.
	self assert: Float fmax binaryLiteralString equals: '2r1.1111111111111111111111111111111111111111111111111111e1023'.

	self assert: Float fminDenormalized negated binaryLiteralString equals: '-2r0.0000000000000000000000000000000000000000000000000001e-1022'.
	self assert: Float fminNormalized negated binaryLiteralString equals: '-2r1.0000000000000000000000000000000000000000000000000000e-1022'.

	self assert: 1.0 binaryLiteralString equals: '2r1.0000000000000000000000000000000000000000000000000000e0'.
	self assert: (1.0 + Float epsilon) binaryLiteralString equals: '2r1.0000000000000000000000000000000000000000000000000001e0'.
	self assert: (1.0 - (Float epsilon / 2)) binaryLiteralString equals: '2r1.1111111111111111111111111111111111111111111111111111e-1'.
	self assert: 2.0 binaryLiteralString equals: '2r1.0000000000000000000000000000000000000000000000000000e1'.
	
	self assert: 0.1 binaryLiteralString equals: '2r1.1001100110011001100110011001100110011001100110011010e-4'.
	self assert: 0.2 binaryLiteralString equals: '2r1.1001100110011001100110011001100110011001100110011010e-3'.
	self assert: 0.3 binaryLiteralString equals: '2r1.0011001100110011001100110011001100110011001100110011e-2'.
	self assert: (0.1 + 0.2) binaryLiteralString equals: '2r1.0011001100110011001100110011001100110011001100110100e-2'.
	self assert: 0.5 binaryLiteralString equals: '2r1.0000000000000000000000000000000000000000000000000000e-1'.
	
	self assert: 2r0.0000000000000000000000000000000000000000000000000001e-1022 binaryLiteralString equals: '2r0.0000000000000000000000000000000000000000000000000001e-1022'.
	self assert: 2r0.0101010101010101010101010101010101010101010101010101e-1022 binaryLiteralString equals: '2r0.0101010101010101010101010101010101010101010101010101e-1022'.
	self assert: 2r0.1010101010101010101010101010101010101010101010101010e-1022 binaryLiteralString equals: '2r0.1010101010101010101010101010101010101010101010101010e-1022'.
	self assert: 2r0.1111111111111111111111111111111111111111111111111111e-1022 binaryLiteralString equals: '2r0.1111111111111111111111111111111111111111111111111111e-1022'.
	self assert: 2r1.0101010101010101010101010101010101010101010101010101e-3 binaryLiteralString equals: '2r1.0101010101010101010101010101010101010101010101010101e-3'.
	self assert: 2r1.1010101010101010101010101010101010101010101010101010e3 binaryLiteralString equals: '2r1.1010101010101010101010101010101010101010101010101010e3'.
	self assert: 2r1.1111111111111111111111111111111111111111111111111111e1023 binaryLiteralString equals: '2r1.1111111111111111111111111111111111111111111111111111e1023'.

	self assert: -2r0.0000000000000000000000000000000000000000000000000001e-1022 binaryLiteralString equals: '-2r0.0000000000000000000000000000000000000000000000000001e-1022'.
	self assert: -2r1.0000000000000000000000000000000000000000000000000000e-1022 binaryLiteralString equals: '-2r1.0000000000000000000000000000000000000000000000000000e-1022'.
	self assert: -2r1.1111111111111111111111111111111111111111111111111111e1023 binaryLiteralString equals: '-2r1.1111111111111111111111111111111111111111111111111111e1023'.

	self assert: (Float fromIEEE64Bit: 2r0111111111110000000000000000000000000000000000000000000000000001) binaryLiteralString equals: 'Float nan'.
	self assert: (Float fromIEEE64Bit: 2r0111111111111111111111111111111111111111111111111111111111111111) binaryLiteralString equals: 'Float nan'.
	self assert: (Float fromIEEE64Bit: 2r1111111111110000000000000000000000000000000000000000000000000001) binaryLiteralString equals: 'Float nan'.
	self assert: (Float fromIEEE64Bit: 2r1111111111111111111111111111111111111111111111111111111111111111) binaryLiteralString equals: 'Float nan'! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testCharacterization

	"Test the largest finite representable floating point value"
	self assert: Float fmax successor equals: Float infinity.
	self assert: Float infinity predecessor equals: Float fmax.
	self assert: Float fmax negated predecessor equals: Float infinity negated.
	self assert: Float infinity negated successor equals: Float fmax negated.
	
	"Test the smallest positive representable floating point value"
	self assert: Float fmin predecessor equals: 0.0.
	self assert: 0.0 successor equals: Float fmin.
	self assert: Float fmin negated successor equals: 0.0.
	self assert: 0.0 predecessor equals: Float fmin negated.
	
	"Test the relative precision"
	self assert: Float one + Float epsilon > Float one.
	self assert: Float one + Float epsilon equals: Float one successor.
	self assert: Float one + (Float epsilon / Float radix) equals: Float one.
	
	"Test maximum and minimum exponent"
	self assert: Float fmax exponent equals: Float emax.
	self assert: Float fminNormalized exponent equals: Float emin.
	Float denormalized ifTrue: [
		self assert: Float fminDenormalized exponent equals: (Float emin + 1 - Float precision)].
	
	"Alternative tests for maximum and minimum"
	self assert: (Float radix - Float epsilon) * (Float radix raisedTo: Float emax) equals: Float fmax.
	self assert: Float epsilon * (Float radix raisedTo: Float emin) equals: Float fmin.
	
	"Test sucessors and predecessors"
	self assert: Float one predecessor successor equals: Float one.
	self assert: Float one successor predecessor equals: Float one.
	self assert: Float one negated predecessor successor equals: Float one negated.
	self assert: Float one negated successor predecessor equals: Float one negated.
	self assert: Float infinity successor equals: Float infinity.
	self assert: Float infinity negated predecessor equals: 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 equals: '7FEFFFFFFFFFFFFF'.
	self assert: Float fminDenormalized hex equals: '0000000000000001'.
	self assert: Float fminNormalized hex equals: '0010000000000000'.
	self assert: 0.0 hex equals: '0000000000000000'.
	self assert: Float negativeZero hex equals: '8000000000000000'.
	self assert: Float one hex equals: '3FF0000000000000'.
	self assert: Float infinity hex equals: '7FF0000000000000'.
	self assert: Float infinity negated hex equals: 'FFF0000000000000'! !

!FloatTest methodsFor: 'tests - NaN behavior' stamp: ''!
testNaNisLiteral

	self deny: Float nan isLiteral description: 'there is no literal representation of NaN'! !

!FloatTest methodsFor: 'tests - arithmetic' stamp: ''!
testDivide

	self assert: 1.5 / 2.0 equals: 0.75.	
	self assert: 2.0 / 1 equals: 2.0.
	
	self should: [ 2.0 / 0 ] raise: ZeroDivide.
	self should: [ 2.0 / 0.0 ] raise: ZeroDivide.
	self should: [ 1.2 / Float negativeZero ] raise: ZeroDivide.
	self should: [ 1.2 / (1.3 - 1.3) ] raise: ZeroDivide! !

!FloatTest methodsFor: 'tests - compare' stamp: ''!
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"
	
	| 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 - NaN behavior' stamp: ''!
testReciprocal

	self 
		assert: 1.0 reciprocal equals: 1.0;
		assert: 2.0 reciprocal equals: 0.5;
		assert: -1.0 reciprocal equals: -1.0;
		assert: -2.0 reciprocal equals: -0.5.
		
	self should: [ 0.0 reciprocal ] raise: ZeroDivide! !

!FloatTest methodsFor: 'tests - conversion' stamp: ''!
testReadingTooLargeExponents
	self assert: (Float readFrom: '7.5e333') equals: Float infinity.
	self assert: (Float readFrom: '7.5e-333') equals: Float zero.
	self assert: (Float readFrom: '-7.5e333') equals: Float infinity negated.
	self assert: (Float readFrom: '-7.5e-333') equals: Float zero.

	self assert: (Float readFrom: '7.5e3333') equals: Float infinity.
	self assert: (Float readFrom: '7.5e-3333') equals: Float zero.
	self assert: (Float readFrom: '-7.5e3333') equals: Float infinity negated.
	self assert: (Float readFrom: '-7.5e-3333') equals: Float zero.! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testDegreeCos

	45.0 degreeCos.	"Following tests use approximate equality, because cosine are generally evaluated using inexact Floating point arithmetic"
	self assert: (45.0 degreeCos squared - 0.5) abs <= Float epsilon.
	self assert: (60.0 degreeCos - 0.5) abs <= Float epsilon.
	self assert: (120.0 degreeCos + 0.5) abs <= Float epsilon.
	-360.0 to: 360.0 do: [ :i | self assert: (i degreeCos closeTo: i degreesToRadians cos) ].	"Following tests use strict equality which is a requested property of degreeCos"
	-10.0 to: 10.0 do: [ :k | 
		self assert: (k * 360 + 90) degreeCos equals: 0.
		self assert: (k * 360 - 90) degreeCos equals: 0.
		self assert: (k * 360 + 180) degreeCos + 1 equals: 0.
		self assert: (k * 360) degreeCos - 1 equals: 0 ]! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testNaN5

	self assert: ((Float nan asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2) copyFrom: 2 to: 9) 
		  equals: '11111111'.
	self assert: (Float fromIEEE32Bit:
		(Integer readFrom: '01111111110000000000000000000000' readStream base: 2)) isNaN! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testDegreeSin

	45.0 degreeSin.	"Following tests use approximate equality, because sine are generally evaluated using inexact Floating point arithmetic"
	self assert: (45.0 degreeSin squared - 0.5) abs <= Float epsilon.
	self assert: (30.0 degreeSin - 0.5) abs <= Float epsilon.
	self assert: (-30.0 degreeSin + 0.5) abs <= Float epsilon.
	-360.0 to: 360.0 do: [ :i | self assert: (i degreeSin closeTo: i degreesToRadians sin) ].	"Following tests use strict equality which is a requested property of degreeSin"
	-10.0 to: 10.0 do: [ :k | 
		self assert: (k * 360 + 90) degreeSin - 1 equals: 0.
		self assert: (k * 360 - 90) degreeSin + 1 equals: 0.
		self assert: (k * 360 + 180) degreeSin equals: 0.
		self assert: (k * 360) degreeSin equals: 0 ]! !

!FloatTest methodsFor: 'tests' stamp: ''!
testFractionAsFloatWithUnderflow
	"test rounding to nearest even"

	| underflowPower |
	underflowPower := Float emin - Float precision.
	self assert: (2 raisedTo: underflowPower) asFloat equals: 0.0.	
	self assert: (2 raisedTo: underflowPower) negated asFloat equals: 0.0.
	self assert: (2 raisedTo: underflowPower) negated asFloat signBit = 1 description: 'a negative underflow should return a negative zero'! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 equals: 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 equals: 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 equals: conv.
	
	"case 4: obviously round to upper"
	conv := 2r1.0000000000000000000000011e25 asIEEE32BitWord.
	expected := exponentPart bitOr: 2r1.
	self assert: expected equals: conv! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 equals: conv.
	
	"case 2: smallest number"
	conv := 2r0.00000000000000000000001e-126 asIEEE32BitWord.
	expected := exponentPart bitOr: 2r1.
	self assert: expected equals: 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 equals: 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 equals: 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 equals: conv! !

!FloatTest methodsFor: 'tests - zero behavior' stamp: ''!
testNegativeZeroSign

	self assert: Float negativeZero sign equals: 0. "Like any other zero, a negative zero has its sign being zero"
	self assert: Float negativeZero signBit equals: 1 "But it can be distinguished with its signBit"! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
test32bitConversion
	"Except for NaN, we can convert a 32bits float to a 64bits float exactly.
	Thus we can convert the 64bits float to the original 32bits float pattern."
	
	#(16r0 "zero"
	 16r80000000 "negative zero"
	 16r1 "min unormalized"
	 16r12345 "a unnormalized"
	 16r801FEDCB "a negative unnormalized"
	 16r7FFFFF "largest unnormalized"
	 16r800000 "smallest normalized"
	 16r468ACDEF "a normalized float"
	 16rCABD1234 "a negative normalized float"
	 16r7F7FFFFF "largest finite float"
	 16r7F800000 "positive infinity"
	 16rFF800000 "negative infinity"
	)
	  do: [:originalWord | self assert: (Float fromIEEE32Bit: originalWord) asIEEE32BitWord equals: originalWord ]! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 equals: 16r1FFFFFFFFFFFFF asFloat.
	self assert: 16r1FFFFFFFFFFFFF equals: 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) equals: (1/i) asFloat]
			ifFalse: [self deny: (1/i) equals: (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) equals: 0.
	self deny: 1 / (11 raisedTo: 400) equals: 0.0.
	
	"Test hash code"
	self assert:
		((Set new: 3) add: 3; add: 3.0; size) equals:
		((Set new: 4) add: 3; add: 3.0; size)! !

!FloatTest methodsFor: 'tests - NaN behavior' stamp: ''!
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 |
	self skip.
	compareSelectors := #(#< #<= #> #>= #=).
	theNaN := Float nan.
	anotherNaN := Float infinity - Float infinity.
	comparand := {1. 2.3. Float infinity. 2/3. 1.25s2. 2 raisedTo: 50}.
	comparand := comparand , (comparand collect: [:e | e negated]).
	comparand := comparand , {theNaN. anotherNaN}.

"do a first pass to collect all broken methods"
	brokenMethods := Set new.
	comparand do: [:comp |
		compareSelectors do: [:op |
			(theNaN perform: op with: comp) ifTrue: [brokenMethods add: (theNaN class lookupSelector: op)].
			(comp perform: op with: theNaN) ifTrue: [brokenMethods add: (comp class lookupSelector: op)]].
		(theNaN ~= comp) ifFalse: [brokenMethods add: (theNaN class lookupSelector: #~=)].
		(comp ~= theNaN) ifFalse: [brokenMethods add: (comp class lookupSelector: #~=)]].
	
"build a warning message to tell about all broken methods at once"
	warningMessage := String streamContents: [:s |
			s nextPutAll: 'According to IEEE 754 comparing with a NaN should always return false, except ~= that should return true.'; cr.
			s nextPutAll: 'All these methods failed to do so. They are either broken or call a broken one'.
			brokenMethods do: [:e | s cr; print: e methodClass; nextPutAll: '>>'; print: e selector]].
		
"Redo the tests so as to eventually open a debugger on one of the failures"
	brokenMethods := Set new.
	comparand do: [:comp2 |
		compareSelectors do: [:op2 |
			self deny: (theNaN perform: op2 with: comp2) description: warningMessage.
			self deny: (comp2 perform: op2 with: theNaN) description: warningMessage].
		self assert: (theNaN ~= comp2) description: warningMessage.
		self assert: (comp2 ~= theNaN) description: warningMessage].! !

!FloatTest methodsFor: 'tests - NaN behavior' stamp: ''!
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, for which Float may have different internal representations."

	| nan1 nan2 |
	nan1 := Float nan copy.
	nan2 := Float nan copy.

	"test two instances of NaN with the same bit pattern"
	self deny: nan1 equals: nan2.
	self deny: nan1 identicalTo: nan2.
	self deny: nan1 equals: nan1.
	self assert: nan1 identicalTo: nan1.

	"change the bit pattern of nan1"
	self assert: nan1 size equals: 2.
	self assert: (nan1 at: 2) equals: 0.
	nan1 at: 1 put: (nan1 at: 1) + 999.
	self assert: nan1 isNaN.
	self assert: nan2 isNaN.
	self deny: (nan1 at: 1) equals: (nan2 at: 1).

	"test two instances of NaN with different bit patterns"
	self deny: nan1 equals: nan2.
	self deny: nan1 identicalTo: nan2.
	self deny: nan1 equals: nan1.
	self assert: nan1 identicalTo: nan1! !

!FloatTest methodsFor: 'tests - conversion' stamp: ''!
testIntegerAsFloat
	"assert IEEE 754 round to nearest even mode is honoured"

	self deny: 16r1FFFFFFFFFFFF0801 asFloat equals: 16r1FFFFFFFFFFFF0800 asFloat.	"this test is on 65 bits"
	self deny: 16r1FFFFFFFFFFFF0802 asFloat equals: 16r1FFFFFFFFFFFF0800 asFloat.	"this test is on 64 bits"
	self assert: 16r1FFFFFFFFFFF1F800 asFloat equals: 16r1FFFFFFFFFFF20000 asFloat.	"nearest even is upper"
	self assert: 16r1FFFFFFFFFFFF0800 asFloat equals: 16r1FFFFFFFFFFFF0000 asFloat	"nearest even is lower"! !

!FloatTest methodsFor: 'tests - conversion' stamp: ''!
testRounded

	self assert: 0.9 rounded equals: 1.
	self assert: 1.0 rounded equals: 1.
	self assert: 1.1 rounded equals: 1.
	self assert: -1.9 rounded equals: -2.
	self assert: -2.0 rounded equals: -2.
	self assert: -2.1 rounded equals: -2.
	
	"In case of tie, round to upper magnitude"
	self assert: 1.5 rounded equals: 2.
	self assert: -1.5 rounded equals: -2! !

!FloatTest methodsFor: 'tests - printing' stamp: ''!
testStoreOn
	| float |
	float := -1.2.
	self assert: (String streamContents: [ :s | float storeOn: s ]) equals: ' -1.2'.
	
	float := 1.2.	
	self assert: (String streamContents: [ :s | float storeOn: s ]) equals: '1.2'! !

!FloatTest methodsFor: 'tests - compare' stamp: ''!
testLiteralEqual

	self deny: (0.0 literalEqual: 0.0 negated).
	self deny: (-0.0 literalEqual: -0.0 negated).
	self deny: (0.0 literalEqual: -0.0)! !

!FloatTest methodsFor: 'tests - printing' stamp: ''!
testStoreBase16
	"This bug was reported in mantis http://bugs.squeak.org/view.php?id=6695"

	self
		assert: (20.0 storeStringBase: 16) = '16r14.0'
		description: 'the radix prefix should not be omitted, except in base 10'! !

!FloatTest methodsFor: 'tests - zero behavior' stamp: ''!
testNegativeZeroAbs

	self assert: Float negativeZero abs sign positive description: 'the absolute value of a negative zero is zero'! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testRounding

	self assert: (10.1234 round: 2) equals: 10.12.
 	self assert: (10.1234 round: 0) equals: 10! !

!FloatTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testCloseTo

	self deny: (Float nan closeTo: Float nan) description: 'NaN isn''t close to anything'.
	self deny: (Float nan closeTo: 1.0) description: 'NaN isn''t close to anything'.
	self deny: (1.0 closeTo: Float nan) description: 'NaN isn''t close to anything'.
	
	self deny: (-1.0 closeTo: 1.0).
	self deny: (1.0 closeTo: Float infinity).
	self assert: (Float infinity closeTo: Float infinity) description: 'since they are =, they also are closeTo:'.
	
	self assert: (1.0/3.0 closeTo: 1/3).
	self assert: (1.0e-8 closeTo: 0).
	self assert: (0 closeTo: 1.0e-8).
	self assert: (1+1.0e-8 closeTo: 1.0).
	
	self assert: (1000000001.0 closeTo: 1000000000.0).
	self deny: (1000000001 closeTo: 1000000000) description: 'exact representation are considered closeTo: only if equal'! !

!FloatTest methodsFor: 'tests - printing' stamp: ''!
testPrintPaddedWithTo
	"The problem was caused by treating the format specifier as a number rather than
	as a string, such the the number may be a Float subject to floating point rounding
	errors. The solution to treat the format specifier as a string, and extract the integer
	fields before and after the decimal point in the string."

	self assert: (1.0 printPaddedWith: $0 to: 2.2) equals: '01.00'.
	self assert: (1.0 printPaddedWith: $X to: 2.2) equals: 'X1.0X'.
	self assert: (1.0 printPaddedWith: $0 to: 2) equals: '01.0'.
	self assert: (12345.6789 printPaddedWith: $0 to: 2) equals: '12345.6789'.
	self assert: (12345.6789 printPaddedWith: $0 to: 2.2) equals: '12345.6789'.
	self assert: (12.34 printPaddedWith: $0 to: 2.2) equals: '12.34'.
	self assert: (12345.6789 printPaddedWith: $0 to: 2.2) equals: '12345.6789'.
	self assert: (123.456 printPaddedWith: $X to: 4.4) equals: 'X123.456X'.
	self assert: (1.0 printPaddedWith: $0 to: 2.1) equals: '01.0'.
	self assert: (1.0 printPaddedWith: $0 to: 2.2) equals: '01.00'.
	self assert: (1.0 printPaddedWith: $0 to: 2.3) equals: '01.000'. "previously failed due to float usage"
	self assert: (1.0 printPaddedWith: $0 to: 2.4) equals: '01.0000'. "previously failed due to float usage"
	self assert: (1.0 printPaddedWith: $0 to: 2.5) equals: '01.00000'! !

!FloatTest methodsFor: 'tests' stamp: ''!
testAsScaledDecimal

	self
		assert: 0.00000000000006 asScaledDecimal asString
		equals: '0.00000000000006s14'.
	self
		assert: 9.99999999999999 asScaledDecimal asString
		equals: '9.99999999999999s14'.
	self
		assert:
		(ScaledDecimal newFromNumber: 9.999999999999999 scale: 15) asString
		equals: '9.999999999999998s15'.
		self assert: (ScaledDecimal  newFromNumber: 9.999999999999994 scale: 15) asString 
		equals: '9.999999999999995s15'! !

!FluidBuilder commentStamp: ''!
I'm responsible to build class expressed with the fluid syntax.

```
```
Object << #Point 
	slots: { #x . #y };
	tag: 'Basics';
	package: 'Kernel'
```	

### Design decisions

The KEY design decisions are:

- The code snippet above should be able to be used for scripting (interactively).
- The code snippet above must return a class builder 
- A class builder should offer two important messsage: 
-- `build` that returns a class but does not install it. 
-- `install` that installs the class in the system.

To manage class side slots and traits, I follow the design of the classBuilder which is to get all the instance 
side information in addition to the class side one. 
For this the fillFromClass: method is responsible to convert all the class information into an information expected 
by the class builder. 

In the future we would like to revisit the need for such fluid class builders and also revisit the API of the class builders (shift and fluid).
There are too many conversion and we should realigned the APIs with the class default values too. 


!
!FluidBuilder methodsFor: 'accessing' stamp: ''!
slotsToBuild

	^ slotsToBuild! !

!FluidBuilder methodsFor: 'class side' stamp: ''!
classTraitsToBuild
	^ classTraitsToBuild! !

!FluidBuilder methodsFor: 'class side' stamp: ''!
classTraits: aCollection 
	classTraitsToBuild := aCollection asTraitComposition! !

!FluidBuilder methodsFor: 'building' stamp: ''!
shiftClassBuilder 

	^ shiftClassBuilder ifNil: [ shiftClassBuilder := self fillShiftClassBuilder ]! !

!FluidBuilder methodsFor: 'copying' stamp: ''!
fillInstanceSideFromClass: aClass 
	
	| tag |

	slotsToBuild := aClass slots.	
	uses := aClass traitComposition.
	self package: aClass package name.

	tag := (aClass package classTagForClass: aClass).
	tag ifNotNil: [ :s | 
		s isRoot ifFalse: [self tag: (aClass package classTagForClass: aClass) name ]].! !

!FluidBuilder methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	slotsToBuild := #().
	classSlotsToBuild := #().
	
	uses := TaEmptyComposition new.
	classTraitsToBuild := uses classComposition.
	
"	#packageName . #tagToBuild"! !

!FluidBuilder methodsFor: 'building' stamp: ''!
install
	"Install the class in the system environment"
	
	^ ShiftClassInstaller new makeWithBuilder: self shiftClassBuilder! !

!FluidBuilder methodsFor: 'copying' stamp: ''!
fillClassSideFromEnvironment: anEnvironment 

	| oldClass |
	oldClass := anEnvironment at: nameToBuild ifAbsent: [ ^ self ].
	
	classSlotsToBuild := oldClass class slots.
	classTraitsToBuild := oldClass class traitComposition! !

!FluidBuilder methodsFor: 'API' stamp: ''!
traits: anArray
	
	uses := anArray asTraitComposition.
	classTraitsToBuild := uses classComposition! !

!FluidBuilder methodsFor: 'building' stamp: ''!
fillShiftClassBuilder 

	shiftClassBuilder := ShiftClassBuilder new.
	shiftClassBuilder	
		buildEnvironment: ShSmalltalkGlobalsEnvironment new;
		name: nameToBuild.
	
	shiftClassBuilder slots: slotsToBuild.	
	shiftClassBuilder traitComposition: uses asTraitComposition.
	
	(tagToBuild isNil or: [ tagToBuild isEmpty ])
		ifTrue: [ shiftClassBuilder category: packageName ]
		ifFalse: [ tagToBuild isEmpty 
						ifFalse: [ shiftClassBuilder category: packageName, '-', tagToBuild asString ]
						ifTrue: [ shiftClassBuilder category: packageName ]
		].
	
	shiftClassBuilder classSlots: classSlotsToBuild.
	shiftClassBuilder classTraitComposition: classTraitsToBuild.! !

!FluidBuilder methodsFor: 'accessing - mandatory' stamp: ''!
packageToBuild

	^ packageName! !

!FluidBuilder methodsFor: 'API' stamp: ''!
tag: aString

	tagToBuild := aString! !

!FluidBuilder methodsFor: 'accessing' stamp: ''!
tagToBuild

	^ tagToBuild! !

!FluidBuilder methodsFor: 'accessing - mandatory' stamp: ''!
nameToBuild
	"mandatory"
	
	^ nameToBuild! !

!FluidBuilder methodsFor: 'accessing - mandatory' stamp: ''!
nameToBuild: aSymbol 
	nameToBuild := aSymbol! !

!FluidBuilder methodsFor: 'accessing' stamp: ''!
tag

	^ tagToBuild! !

!FluidBuilder methodsFor: 'accessing' stamp: ''!
traitsToBuild

	^ uses! !

!FluidBuilder methodsFor: 'building' stamp: ''!
build
	"Return a class that is not installed in the system."
	
	^ self shiftClassBuilder build! !

!FluidBuilder methodsFor: 'class side' stamp: ''!
classSlots: aCollection 
	classSlotsToBuild := aCollection collect: [ :e | e asSlot ]! !

!FluidBuilder methodsFor: 'API' stamp: ''!
package: aString

	packageName := aString.! !

!FluidBuilder methodsFor: 'class side' stamp: ''!
classSlotsToBuild
	^ classSlotsToBuild! !

!FluidBuilder methodsFor: 'API' stamp: ''!
slots: anArray

	slotsToBuild := anArray collect: [ :each | each asSlot ]! !

!FluidBuilder methodsFor: 'API' stamp: ''!
trait: aTraitComposition

	self deprecated:  'Please use #traits: instead' transformWith:  '`@receiver trait: `@arg' 
						-> '`@receiver traits: `@arg'.
						
	^ self traits: aTraitComposition! !

!FluidBuilder methodsFor: 'deprecated' stamp: ''!
uses: aTraitComposition

	self deprecated:  'Please use #traits: instead' transformWith:  '`@receiver trait: `@arg' 
						-> '`@receiver traits: `@arg'.
						
	^ self traits: aTraitComposition! !

!FluidClassBuilder commentStamp: ''!
I'm a builder to create class definition using a fluid interface. For now I'm just wrapping a shiftClassBuilder.  In the future I should be removed and a shiftClassBuilder should be used instead.

I'm created by the message `<<` as in 

```
Object << #Point
```

My build process happens when I resolve the message `package:` as in 

```
Object << #Point 
	slots: { #x . #y };
	tag: 'Basics';
	package: 'Kernel'
```	

Now this is not totally true. This expression creates a `ShiftClassBuilder`.
And we should send `build` to the fluidclassbuilder to actually kick the building.
 
The mandatory information (name, superclass, package) are systematically passed to the builder.
Others are checked first and when available passed. 	
	
### To install a class

```
ShiftClassInstaller new makeWithBuilder: (Object << #Point33 
 slots: { #x . #y };
 tag: 'Basics';
 package: 'Kernel') shiftClassBuilder	
```
!
!FluidClassBuilder methodsFor: 'copying' stamp: ''!
fillInstanceSideFromClass: aClass 

	super fillInstanceSideFromClass: aClass.
	self superclass: aClass superclass.

	self layout: aClass classLayout class.
		
	self sharedVariables: (aClass classVariables collect: [ :e | e key ]) .
	self sharedPools: (aClass sharedPools collect: [:each | each name ]) asArray.! !

!FluidClassBuilder methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	sharedVariables := #().
	sharedPools := #().
	layout := FixedLayout! !

!FluidClassBuilder methodsFor: 'API' stamp: ''!
layout: aClass 
	layout := aClass! !

!FluidClassBuilder methodsFor: 'API' stamp: ''!
sharedPools: aString

	sharedPools := aString! !

!FluidClassBuilder methodsFor: 'accessing - mandatory' stamp: ''!
superclassToBuild

	^ superclassToBuild! !

!FluidClassBuilder methodsFor: 'accessing' stamp: ''!
layoutToBuild
	^ layout! !

!FluidClassBuilder methodsFor: 'building' stamp: ''!
fillShiftClassBuilder 

	super fillShiftClassBuilder.
	shiftClassBuilder superclass: superclassToBuild.
	shiftClassBuilder sharedVariables: sharedVariables.
	shiftClassBuilder sharedPoolsCollectionOfSymbols: sharedPools.
	shiftClassBuilder layoutClass: layout.

	^ shiftClassBuilder! !

!FluidClassBuilder methodsFor: 'accessing' stamp: ''!
sharedVariablesToBuild

	^ sharedVariables! !

!FluidClassBuilder methodsFor: 'accessing' stamp: ''!
sharedPoolsToBuild

	^ sharedPools! !

!FluidClassBuilder methodsFor: 'accessing - mandatory' stamp: ''!
superclassToBuild: aClass

	superclassToBuild := aClass! !

!FluidClassBuilder methodsFor: 'API' stamp: ''!
sharedVariables: aCollection

	sharedVariables := aCollection! !

!FluidClassBuilder methodsFor: 'accessing - mandatory' stamp: ''!
superclass: aClass

	superclassToBuild := aClass! !

!FluidClassBuilderTest methodsFor: 'tests - gathering' stamp: ''!
testBuilderSharedVariables

	builder 
		layout: ByteLayout;
		sharedVariables: { #NonAsciiMap };
		package: 'Collections-Strings'.  
	self assert: builder sharedVariablesToBuild equals: { #NonAsciiMap }.
	self assert: builder layoutToBuild equals: ByteLayout! !

!FluidClassBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testChevronIsWorkingOnClassSide

	| instBuilder newClass clasBuilder |
	
	RPackageOrganizer default registerPackageNamed: #'Mock'. 
	
	instBuilder := (Object << #Point2
		slots: { #a. #b };
		layout: WeakLayout;
		traits: {TViewModelMock };
		sharedVariables: { #AAA};
		sharedPools: { #TextConstants};
		tag: 'boring' ;
		package: 'Mock').
		
	"Ideally we should not install the class but just build it (sending instBuilder build)
	the problem is that category and tag are lost by the class builder. 
	Hence we cannot test for real."
	newClass := instBuilder install.
	
	clasBuilder := Object class << newClass class
		traits: {TViewModelMock classTrait}.
		
	self assert: clasBuilder packageToBuild equals: instBuilder packageToBuild.
	self assert: clasBuilder superclassToBuild equals: instBuilder superclassToBuild.
	self assert: clasBuilder layoutToBuild equals: instBuilder layoutToBuild.
	self assert: clasBuilder sharedVariablesToBuild equals: instBuilder sharedVariablesToBuild.
	self assert: clasBuilder sharedPoolsToBuild equals: instBuilder sharedPoolsToBuild.
	
	self assert: clasBuilder slotsToBuild equals: instBuilder slotsToBuild.
	self assert: clasBuilder tagToBuild equals: instBuilder tagToBuild.
	self assert: clasBuilder traitsToBuild name equals: TViewModelMock name.
	self assert: clasBuilder nameToBuild equals: instBuilder nameToBuild.
	
	self assert: clasBuilder classSlotsToBuild equals: instBuilder classSlotsToBuild.
	self assert: clasBuilder classTraitsToBuild equals: instBuilder classTraitsToBuild.! !

!FluidClassBuilderTest methodsFor: 'tests - gathering' stamp: ''!
testBuilderWithSlots

	builder slots: { #x . #y }.
	self assert: builder slotsToBuild equals: {#x => InstanceVariableSlot. #y => InstanceVariableSlot}! !

!FluidClassBuilderTest methodsFor: 'tests - gathering' stamp: ''!
testBuilderSharedPools

	builder slots: {#string . #runs};
		tag: 'Base';
		sharedPools: 'TextConstants';
		package: 'Text-Core'.  
	self assert: builder sharedPoolsToBuild equals: 'TextConstants'! !

!FluidClassBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testCreatedEmptyClassHasDefaultElements

	| instBuilder newClass |
	instBuilder := (Object << #Point2
		package: 'Mock').
		
	"Ideally we should not install the class but just build it (sending instBuilder build)
	the problem is that category and tag are lost by the class builder. 
	Hence we cannot test for real."
	newClass := instBuilder install.
	
	self assert: newClass name equals: #Point2.
	self assert: newClass slotNames equals: #().
	self assert: newClass classLayout class equals: FixedLayout.
	self assert: newClass traitComposition equals: {} asTraitComposition.
	self assert: newClass class traitComposition equals: {} asTraitComposition.	
	self assert: newClass classVarNames equals: #().
	self assertCollection: newClass sharedPools hasSameElements: {}.
	self assert: newClass category equals: 'Mock'.! !

!FluidClassBuilderTest methodsFor: 'tests - gathering' stamp: ''!
testBuilderWithTag

	builder tag: 'Foo'.
	self assert: builder tagToBuild equals: 'Foo'! !

!FluidClassBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testExistingClassWithClassSlotThenWeRemoveIt

	| instBuilder newClass classBuilder |

	"We are creating a class with a class slot. This class slot is defined in the class side of the fluid definition.
	Then we are removing the classSlot, it should remove it"

	instBuilder := (Object << #Point2
		slots: { #a. #b };
		layout: WeakLayout;
		traits: {TViewModelMock };
		sharedVariables: { #BBB};
		classSlots: #(AAA);
		sharedPools: { #TextConstants};
		tag: 'boring' ;
		package: 'Mock').
		
	"Ideally we should not install the class but just build it (sending instBuilder build)
	the problem is that category and tag are lost by the class builder. 
	Hence we cannot test for real."
	newClass := instBuilder install.
	
	self assert: newClass class slots first name equals: #AAA.
	
	classBuilder := Object class << newClass class.
	
	newClass := classBuilder install.
	
	self assert: newClass class slots equals: #()! !

!FluidClassBuilderTest methodsFor: 'tests - gathering' stamp: ''!
testBuilderTraits

	builder traits: TViewModelMock.
	self assert: builder traitsToBuild equals: TViewModelMock asTraitComposition.
	builder fillShiftClassBuilder! !

!FluidClassBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testExistingClassWithClassSlot

	| instBuilder newClass |

	"We are creating a class with a class slot. This class slot is defined in the class side of the fluid definition.
	When redefining the instance side, the class slot should not be lost."

	instBuilder := (Object << #Point2
		slots: { #a. #b };
		layout: WeakLayout;
		traits: {TViewModelMock };
		sharedVariables: { #BBB};
		classSlots: #(AAA);
		sharedPools: { #TextConstants};
		tag: 'boring' ;
		package: 'Mock').
		
	"Ideally we should not install the class but just build it (sending instBuilder build)
	the problem is that category and tag are lost by the class builder. 
	Hence we cannot test for real."
	newClass := instBuilder install.
	
	self assert: newClass class slots first name equals: #AAA.
	
	instBuilder := (Object << #Point2
		slots: { #a. #b. #c };
		layout: WeakLayout;
		traits: {TViewModelMock };
		sharedVariables: { #BBB};
		sharedPools: { #TextConstants};
		tag: 'boring' ;
		package: 'Mock').
	
	newClass := instBuilder install.
	
	self assert: newClass class slots first name equals: #AAA! !

!FluidClassBuilderTest methodsFor: 'tests - gathering' stamp: ''!
testBuildLayout

	builder 
		layout: VariableLayout;
		package: 'Collections-Sequenceable'.
	self assert: builder layoutToBuild equals: VariableLayout! !

!FluidClassBuilderTest methodsFor: 'tests - mandatory' stamp: ''!
testCreateBuilder

	builder := Object << #Point.
	self assert: builder superclassToBuild equals: Object.
	self assert: builder nameToBuild equals: #Point.! !

!FluidClassBuilderTest methodsFor: 'tests - gathering' stamp: ''!
testBuilderTraitsClass

	builder traits: TViewModelMock class.
	self assert: builder traitsToBuild equals: TViewModelMock class asTraitComposition.
	builder fillShiftClassBuilder! !

!FluidClassBuilderTest methodsFor: 'tests - mandatory' stamp: ''!
testBuilderWithPackage

	builder package: 'Kernel-BasicObjects'.
	self 
		assert: builder packageToBuild 
		equals: 'Kernel-BasicObjects'! !

!FluidClassBuilderTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	builder := FluidClassBuilder new
		           superclassToBuild: Object;
		           nameToBuild: #Point33;
		           package: 'FakedPackage'! !

!FluidClassBuilderTest methodsFor: 'tests - classBuilder generation' stamp: ''!
testBuildSimplePoint2

	| clas |
	builder := Object << #Point2.
	builder slots: { #x . #y }.
	builder package: 'FakedCore'.
	clas := builder build.
	
	self assert: clas superclass equals: Object.
	self assert: clas name equals: #Point2.
	self assert: clas slots size equals: 2.
	self flag: #askPablo.
	"self assert: clas package packageName equals: 'FakedCore'"! !

!FluidClassBuilderTest methodsFor: 'tests - classBuilder generation' stamp: ''!
testInstallSimplePoint2

	[ | pt2Class |
	self assert: (self class environment at: #Point2 ifAbsent: [ true ]).
	builder := Object << #Point2.
	builder slots: { #x . #y }.
	builder package: 'FakedCore'.
	builder install.
	
	pt2Class := self class environment at: #Point2.
	self assert: pt2Class superclass equals: Object.
	self assert: pt2Class name equals: #Point2.
	self assert: pt2Class slots size equals: 2 ] ensure: [  
			self class environment removeKey: #Point2 ifAbsent: [self fail]. 
			self assert: (self class environment at: #Point2 ifAbsent: [ true ])]! !

!FluidClassBuilderTest methodsFor: 'private - cleanup' stamp: ''!
removeTestArtifactsFromSystem

	self class environment at: #MyClass 
		ifPresent: [:p | p removeFromSystem: false ]
		ifAbsent: [ ].! !

!FluidClassBuilderTest methodsFor: 'running' stamp: ''!
tearDown

	self class environment 
		at: #Point2 
		ifPresent: [ :cl | cl removeFromSystem  ].

	(RPackageOrganizer default packageNamed: #'Mock' ifAbsent: [ nil ])
		ifNotNil: [:x | x removeFromSystem ].

	super tearDown.! !

!FluidClassBuilderTest methodsFor: 'tests - gathering' stamp: ''!
testBuilderTraitsWithComposition

	builder traits: TViewModelMock + TViewModelMock2.
	self
		assert: builder traitsToBuild
		equals: TViewModelMock + TViewModelMock2.
	builder fillShiftClassBuilder! !

!FluidClassBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testClassTraits

	builder classTraits: {TViewModel classSide}.
	self assert: builder classTraitsToBuild equals: {TViewModel classSide} asTraitComposition! !

!FluidClassBuilderTest methodsFor: 'tests - mandatory' stamp: ''!
testInstallMinimalMockClass

	| shiftClassBuilder installedClass |
	self removeTestArtifactsFromSystem.
	[ 
	builder := self class compilerClass new
		           evaluate: 'Object << #MyClass
	layout: FixedLayout;
	traits: {};
	slots: {};
	sharedVariables: {};
	tag: '''' ;
	sharedPools: {};
	package: ''MyPackage'''.
	builder build.
	shiftClassBuilder := builder shiftClassBuilder.
	ShiftClassInstaller new makeWithBuilder: shiftClassBuilder.
	
	installedClass := self class environment at: #MyClass ifAbsent: [self fail].
	         
	self assert: installedClass superclass equals: Object.
	self assert: installedClass name equals: #MyClass.
	self assert: installedClass isFixed.
	self assert: installedClass slots isEmpty.
	self assert: installedClass traitComposition isEmpty.
	self assert: installedClass classVariables isEmpty.
	self assert: installedClass sharedPools isEmpty]
		ensure: [ self removeTestArtifactsFromSystem ]! !

!FluidClassBuilderTest methodsFor: 'tests - hidden protocols' stamp: ''!
testBuildClassTraitsAPI

	| clas |
	builder := Object << #Point2.
	builder classTraits: { TViewModelMock2 classTrait }.
	"pay attention classTraits: is not to be sent by the user.
	users should only send traits:"
	builder package: 'FakedCore'.
	clas := builder build.
	
	self assert: clas superclass equals: Object.
	self assert: clas name equals: #Point2.
	self assert: clas class traitComposition equals: { TViewModelMock2 classTrait } asTraitComposition! !

!FluidClassBuilderTest methodsFor: 'tests - hidden protocols' stamp: ''!
testBuildClassSlotsAPI

	| clas |
	builder := Object << #Point2.
	builder slots: { #x }.
	builder classSlots: {#classX . #classY}.
	"pay attention classSlots: is not to be sent by the user.
	users should only send slots:"
	builder package: 'FakedCore'.
	clas := builder build.
	
	self assert: clas superclass equals: Object.
	self assert: clas name equals: #Point2.
	self assert: clas slots size equals: 1.
	self assert: clas class slots size equals: 2.! !

!FluidClassBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testChevronIsWorkingOnClassSideOnEmpty

	| instBuilder newClass clasBuilder |
	instBuilder := (Object << #Point2
		package: 'Mock').
	
	"Ideally we should not install the class but just build it (sending instBuilder build)
	the problem is that category and tag are lost by the class builder. 
	Hence we cannot test for real."
	newClass := instBuilder install.
	
	clasBuilder := Object class << newClass class.
		
	self assert: clasBuilder packageToBuild equals: instBuilder packageToBuild.
	self assert: clasBuilder superclassToBuild equals: instBuilder superclassToBuild.
	self assert: clasBuilder layoutToBuild equals: instBuilder layoutToBuild.
	self assert: clasBuilder sharedVariablesToBuild equals: instBuilder sharedVariablesToBuild.
	self assert: clasBuilder sharedPoolsToBuild equals: instBuilder sharedPoolsToBuild.
	
	self assert: clasBuilder slotsToBuild equals: instBuilder slotsToBuild.
	self assert: clasBuilder tagToBuild equals: instBuilder tagToBuild.
	self assert: clasBuilder traitsToBuild equals: instBuilder traitsToBuild.
	self assert: clasBuilder nameToBuild equals: instBuilder nameToBuild.
	
	self assert: clasBuilder classSlotsToBuild equals: instBuilder classSlotsToBuild.
	self assert: clasBuilder classTraitsToBuild equals: instBuilder classTraitsToBuild.! !

!FluidClassBuilderTest methodsFor: 'accessing' stamp: ''!
builder 	

	^  builder! !

!FluidClassBuilderTest methodsFor: 'tests - mandatory' stamp: ''!
testCreateBuilderWithNil

	builder := nil << #NewProtoObject.
	self assert: builder superclassToBuild equals: nil.
	self assert: builder nameToBuild equals: #NewProtoObject.! !

!FluidClassBuilderTest methodsFor: 'tests - classBuilder generation' stamp: ''!
testFillShiftClassBuilder

	| shift |
	builder := Object << #Point2.
	builder slots: { #x . #y }.
	builder sharedVariables: {  #Share1 . #Share2 }.
	builder sharedPools: { ChronologyConstants }.
	builder tag: 'Mafia'.
	builder package: 'FakedCore'.
	builder fillShiftClassBuilder.
	shift := builder shiftClassBuilder. 
	self assert: shift superclass equals: Object.
	self assert: shift name equals: #Point2.
	self assert: shift slots size equals: 2.
	self assert: shift sharedPools equals: {ChronologyConstants}.
	self assert: shift category equals: 'FakedCore-Mafia'.
	self flag: #askPablo.
	"self assert: clas package packageName equals: 'FakedCore'"! !

!FluidClassBuilderTest methodsFor: 'tests - mandatory' stamp: ''!
testCreateClassWithFullExpandedDefinitionKeepsTheMinimum

	"check ClassDescription>>#definitionFullExpanded"

	| shiftClassBuilder |
	builder := self class compilerClass new
		           evaluate: 'Object << #MyClass
	layout: FixedLayout;
	traits: {};
	slots: {};
	sharedVariables: {};
	tag: '''' ;
	sharedPools: {};
	package: ''MyPackage'''.
	builder build.
	shiftClassBuilder := builder shiftClassBuilder.
		          
	self assert: shiftClassBuilder superclass equals: Object.
	self assert: shiftClassBuilder name equals: #MyClass.
	self assert: shiftClassBuilder layoutDefinition slots isEmpty.
	"we should add slots to ShiftClassBuilder"
	self flag: #Pablo.
	self assert: shiftClassBuilder traitComposition isEmpty.
	self assert: shiftClassBuilder layoutDefinition sharedVariables isEmpty.
	self assert: shiftClassBuilder layoutDefinition sharedPools isEmpty.! !

!FluidClassBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testClassSlots

	builder classSlots: {#string . #runs}.
	self assert: builder classSlotsToBuild  equals: {#string => InstanceVariableSlot. #runs => InstanceVariableSlot}! !

!FluidClassBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testCreatedClassHasAllElements

	| instBuilder newClass |
	instBuilder := (Object << #Point2
		slots: { #a. #b };
		layout: WeakLayout;
		traits: {TViewModelMock };
		sharedVariables: { #AAA};
		sharedPools: { #TextConstants};
		tag: 'boring' ;
		package: 'Mock').
		
	"Ideally we should not install the class but just build it (sending instBuilder build)
	the problem is that category and tag are lost by the class builder. 
	Hence we cannot test for real."
	newClass := instBuilder install.
	
	self assert: newClass name equals: #Point2.
	self assert: newClass slots size equals: 2.
	self assert: newClass slotNames equals: #(a b).
	self assert: newClass classLayout class equals: WeakLayout.
	self assert: newClass traitComposition equals: {TViewModelMock} asTraitComposition.
	self assert: newClass class traitComposition equals: {TViewModelMock classSide} asTraitComposition.
	self assert: newClass classVarNames equals: #(AAA).
	self assertCollection: newClass sharedPools hasSameElements: {TextConstants}.
	self assert: newClass category equals: 'Mock-boring'.! !

!FluidClassDefinitionPrinter commentStamp: ''!
```
Object < #MyClass
	layout: FixedLayout;
	uses: {};
	slots: {};
	sharedVariables: {};
	sharedPools: {};
	tag: '' ;
	package: 'FluidClassDefinition-Printer-UnderDev'
```

is the template definition for the fluid syntax


This is the fluid definition of the current class :).

```
ClassDefinitionPrinter < #FluidClassDefinitionPrinter
	tag: 'Printer-UnderDev';
	package: 'FluidClassDefinition'
```

You can also configure it to display empty slots.

``` 
ClassDefinitionPrinter displayEmptySlots: true
```

!
!FluidClassDefinitionPrinter methodsFor: 'template' stamp: ''!
compactClassDefinitionTemplateInPackage: aPackageName 
	^ String streamContents: [ :s |
			s nextPutAll: 'Object << #MyClass'; crtab.
			s nextPutAll: 'slots: {};'; crtab. 
			s nextPutAll: 'sharedVariables: {};'; crtab.
			s nextPutAll: 'package: ''', aPackageName, '''' ]! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
packageOn: s

	s
		crtab;
	 	nextPutAll: 'package: ';
		nextPut: $';
		nextPutAll: forClass package packageName;
		nextPut: $'! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
slotDefinitionString
	"Answer a string that represents an executable description of my Slots"
	
	^String streamContents: [ :str | self slotDefinitionsOn: str]! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
layoutOn: s
	"Layout is always followed by other message ultimately package: so it terminates with ;"
	s
		crtab;
		nextPutAll: 'layout: ';
		nextPutAll: forClass classLayout class name;
		nextPutAll: ';'! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
traitsOn: strm
	"uses: can the last part of a definition so watch out for terminating ;"
	
	forClass hasTraitComposition ifTrue: [
		"forClass traitComposition innerClass = TEmpty ifTrue: [ ^ self ]."
		"isEmpty traitComposition should probably moved to Trait."
		strm 
			crtab; 
			nextPutAll: 'traits: {';
			nextPutAll: forClass traitCompositionString;
			nextPutAll: '};' ]! !

!FluidClassDefinitionPrinter methodsFor: 'definition double dispatch API' stamp: ''!
metaclassDefinitionString 

	^ String streamContents: [ :strm |
		forClass superclass 
			ifNotNil: [ forClass = ProtoObject class
								ifFalse: [ 
								strm 
									nextPutAll: forClass superclass name;
									nextPutAll: ' << ';
									nextPutAll: forClass name ]
								ifTrue: [ strm 
									nextPutAll: 'Class class << ';
									nextPutAll: forClass name ] ]
			ifNil: [ strm nextPutAll: 'ProtoObject ' ].
		self lastTraitsOn: strm.
		forClass slots ifNotEmpty: [ self lastSlotsOn: strm ] ]! !

!FluidClassDefinitionPrinter methodsFor: 'printing' stamp: ''!
testClassDefinitionTemplateInPackage: aPackageName

		^ String streamContents: [ :s |
						s nextPutAll: 'TestCase << #MyTest'; crtab.
						s nextPutAll: 'slots: {};'; crtab. 
						s nextPutAll: 'tag: '''' ;';crtab.
						s nextPutAll: 'package: ''', aPackageName, '''' ]! !

!FluidClassDefinitionPrinter methodsFor: 'expanded double dispatch API' stamp: ''!
expandedTraitClassDefinitionString

	^ String streamContents: [ :s | 
		  | tag |
		  s nextPutAll: 'Trait << '.
		  s nextPutAll: forClass name.

		  s crtab.
		  s nextPutAll: 'traits: '.
		  forClass hasTraitComposition
			  ifTrue: [ 
				  s
					  nextPutAll: '{';
					  nextPutAll: forClass traitCompositionString;
					  nextPutAll: '};' ]
			  ifFalse: [ s nextPutAll: '{};' ].
		  s crtab.
		  s nextPutAll: 'slots: '.
		  self slotDefinitionsOn: s ]! !

!FluidClassDefinitionPrinter methodsFor: 'template' stamp: ''!
compactTraitDefinitionTemplateInPackage: aPackageName
	
	^ String streamContents: [ :s | 
		  s
			  nextPutAll: 'Trait << #TMyTrait';  crtab;
			  nextPutAll: 'traits: {};'; crtab ;
			  nextPutAll: 'slots: {};'; crtab ;
			  nextPutAll: 'package: ''';
			  nextPutAll: aPackageName;
			  nextPutAll: '''' ]! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
slotShiftOn: aStream

	aStream
		cr;
		tab;
		tab;
		tab! !

!FluidClassDefinitionPrinter methodsFor: 'definition double dispatch API' stamp: ''!
expandedTraitedMetaclassDefinitionString

	^ String streamContents: 
		[:strm |
		strm 
			nextPutAll: forClass superclass name;
			nextPutAll: ' << ';
			nextPutAll: forClass name.
		self traitsOn: strm.
		self lastSlotsOn: strm]! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
slotDefinitionsOn: aStream
	"If the class has many instance variable print one slot per line, do the same for complex slots."

	| oneSlotPerLine localSlots |
	"We could have the heuristics based on the sum of the slot name character length."
	oneSlotPerLine := false.
	localSlots := forClass localSlots.
	( localSlots size > 8 or: [ localSlots anySatisfy: [ :s | s needsFullDefinition ]]) 
		ifTrue: [ localSlots size = 1 ifFalse: [ oneSlotPerLine := true ] ].
	aStream nextPutAll: '{'.
	"To start aligned really nice when we have two complex slots"
	oneSlotPerLine ifTrue: [ 
		self slotShiftOn: aStream ].
	localSlots
		do: [ :slot | 
			aStream space.
			aStream nextPutAll: slot definitionString.
			oneSlotPerLine := slot needsFullDefinition | oneSlotPerLine.
			aStream space ]
		separatedBy: [ 
			aStream nextPutAll: '.'.
			oneSlotPerLine ifTrue: [ self slotShiftOn: aStream ] ].
	aStream nextPutAll: '}'! !

!FluidClassDefinitionPrinter methodsFor: 'printing' stamp: ''!
traitDefinitionTemplateInPackage: aPackageName
	
	^ String streamContents: [ :s | 
		  s
			  nextPutAll: 'Trait << #TMyTrait';
			  crtab.
		  s
			  nextPutAll: 'traits: {};';
			  crtab.
		  s
			  nextPutAll: 'slots: {};';
			  crtab.
		  s
			  nextPutAll: 'tag: '''' ;';
			  crtab.
		  s
			  nextPutAll: 'package: ''';
			  nextPutAll: aPackageName;
			  nextPutAll: '''' ]! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
msgAndClassNameOn: s

	s
		nextPutAll: ' << #';
		nextPutAll: forClass name! !

!FluidClassDefinitionPrinter methodsFor: '*ClassParser' stamp: ''!
classDefinitionParserClass

	^ CDFluidClassDefinitionParser! !

!FluidClassDefinitionPrinter methodsFor: 'expanded double dispatch API' stamp: ''!
expandedClassDefinitionString

	^ String streamContents: [ :s | 
		s nextPutAll: forClass superclass name.
		self msgAndClassNameOn: s.
		self layoutOn: s.
		s crtab.
		s nextPutAll: 'traits: '.
		forClass hasTraitComposition
			ifTrue: [ s nextPutAll: '{'; nextPutAll: forClass traitCompositionString; nextPutAll: '};' ]
			ifFalse: [ s nextPutAll: '{};' ].
		self slotsOn: s.
		self sharedVariablesOn: s.
		self sharedPoolsOn: s.
		
		(forClass package classTagForClass: forClass) ifNotNil: [ :t |
			| tag | 
			tag := t name.
			tag = forClass package name 
				ifTrue: [ s crtab; nextPutAll: 'tag: '''';' ]
				ifFalse: [ self tagOn: s]].
			self packageOn: s ]! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
sharedVariablesOn: s
	"shared variable is always followed by other message ultimately package: so it terminates with ;"
	s
		crtab;
		nextPutAll: 'sharedVariables: '.
	self classVariableDefinitionsOn: s.
	s  
		nextPutAll: ';'! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
lastSlotsOn: s

	s crtab.
	s nextPutAll: 'slots: '.
	self slotDefinitionsOn: s.! !

!FluidClassDefinitionPrinter methodsFor: 'expanded double dispatch API' stamp: ''!
expandedMetaclassDefinitionString
	
	^ String streamContents: [ :s | 
		forClass  
			ifNotNil: [ s nextPutAll: forClass name ]
			ifNil: [ s nextPutAll: 'ProtoObject ' ].
		s crtab. 
		forClass hasTraitComposition 
			ifTrue: [
				s 
					nextPutAll: 'traits: ';
					nextPutAll: forClass traitCompositionString;
					nextPutAll: ';']
			ifFalse: [ s nextPutAll: 'traits: {};'].
		s crtab.
		s nextPutAll: 'slots: '.
		self slotDefinitionsOn: s. 
		]! !

!FluidClassDefinitionPrinter methodsFor: 'printing' stamp: ''!
classDefinitionTemplateInPackage: aPackageName

		^ String streamContents: [ :s |
						s nextPutAll: 'Object << #MyClass'; crtab.
						s nextPutAll: 'layout: FixedLayout;'; crtab.
						s nextPutAll: 'traits: {};'; crtab.
						s nextPutAll: 'slots: {};'; crtab. 
						s nextPutAll: 'sharedVariables: {};'; crtab.
						s nextPutAll: 'sharedPools: {};'; crtab.
						s nextPutAll: 'tag: '''' ;';crtab.
						s nextPutAll: 'package: ''', aPackageName, '''' ]! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
lastTraitsOn: strm
	"uses: can the last part of a definition so watch out for terminating ;"
	
	forClass hasTraitComposition ifTrue: [
		strm 
			crtab; 
			nextPutAll: 'traits: {';
			nextPutAll: forClass traitCompositionString;
			nextPutAll: '}'.
	forClass slots	ifNotEmpty: [ strm nextPutAll: ';' ] ].! !

!FluidClassDefinitionPrinter methodsFor: 'definition double dispatch API' stamp: ''!
traitDefinitionString

	^ String streamContents: [ :strm | 
			strm nextPutAll: 'Trait'.
			self msgAndClassNameOn: strm.
			self traitsOn: strm.

		   forClass slots ifNotEmpty: [ self slotsOn: strm ].
			self tagOn: strm.
			self packageOn: strm ]! !

!FluidClassDefinitionPrinter methodsFor: 'expanded double dispatch API' stamp: ''!
expandedTraitDefinitionString
	
	^ String streamContents: [ :s |		
		| tag |
		s nextPutAll: 'Trait'.
		self msgAndClassNameOn: s.
		
		s crtab.
		s nextPutAll: 'traits: '.
		forClass hasTraitComposition
			ifTrue: [ s nextPutAll: '{'; nextPutAll: forClass traitCompositionString; nextPutAll: '};' ]
			ifFalse: [ s nextPutAll: '{};' ].
		self slotsOn: s.
		s crtab.
							
		(forClass package classTagForClass: forClass) ifNotNil: [:t | 
							tag := t name.
							tag = forClass package name
								ifFalse:  [
									s nextPutAll: 'tag: '; 
					nextPut: $'; 
					nextPutAll: tag asString ; 
					nextPutAll: ''';'.
					s crtab
				]].
				
				s 
					nextPutAll: 'package: ''';
					nextPutAll: forClass package packageName;
					nextPutAll: '''' ]! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
classVariableDefinitionsOn: aStream 
	"Answer a string that evaluates to the definition of the class Variables"
	
		| fullDef |
		forClass classVariables 
			ifEmpty: [ aStream nextPutAll: '{}' ]
			ifNotEmpty:[  :clsVars|
		aStream nextPutAll: '{'.
		clsVars do: [:global |
				aStream space. 
				aStream nextPutAll: global definitionString.
				fullDef := global needsFullDefinition.
				aStream space.]				
			separatedBy: [ 
				aStream nextPutAll: '.'.  
				fullDef ifTrue: [ aStream cr;tab;tab;tab;tab ]].
		aStream nextPutAll: '}'. ]! !

!FluidClassDefinitionPrinter methodsFor: 'definition double dispatch API' stamp: ''!
traitedMetaclassDefinitionString

	^ String streamContents: 
		[:strm |
		strm 
			nextPutAll: forClass superclass name;
			nextPutAll: ' << ';
			nextPutAll: forClass name.
		self lastTraitsOn: strm.
		forClass slots ifNotEmpty: [ self lastSlotsOn: strm ]]! !

!FluidClassDefinitionPrinter methodsFor: 'expanded double dispatch API' stamp: ''!
tagOn: s

	| tag |
	(forClass package classTagForClass: forClass) ifNotNil: [ :t | 
		tag := t name.
		tag = forClass package name ifFalse: [ 
			s crtab.
			s
				nextPutAll: 'tag: ';
				nextPut: $';
				nextPutAll: tag asString;
				nextPutAll: ''';' ] ]! !

!FluidClassDefinitionPrinter methodsFor: 'definition double dispatch API' stamp: ''!
classDefinitionString

	"Next step
		- some of the methods defined on classe will have to be moved in this class.
		- refactor to remove duplication with metaclass,...."

	^ String streamContents: [ :s | 
		  forClass superclass
			  ifNotNil: [ s nextPutAll: forClass superclass name ]
			  ifNil: [ s nextPutAll: 'nil' ].
			
		  self msgAndClassNameOn: s.
		  forClass classLayout isFixedLayout 
				ifFalse: [ self layoutOn: s ].

			self traitsOn: s.
			self class displayEmptySlots 
				ifTrue: [ self slotsOn: s ]
		  		ifFalse: [forClass slots ifNotEmpty: [ self slotsOn: s ]].
		  forClass classVariables ifNotEmpty: [ self sharedVariablesOn: s ].
		  forClass sharedPools ifNotEmpty: [ self sharedPoolsOn: s ].

		  self tagOn: s.
		  self packageOn: s ]! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
sharedPoolsOn: s
	"shared pool message is always followed by other message ultimately package: so it terminates with ;"
	s
		crtab;
		nextPutAll: 'sharedPools: {'.
	forClass sharedPools
		do: [ :p | 
			s space.
			s nextPutAll: p name.
			s space ]
		separatedBy: [ s nextPutAll: '.' ].
	s
		nextPutAll: '};'! !

!FluidClassDefinitionPrinter methodsFor: 'elementary operations' stamp: ''!
slotsOn: s
	"uses: can the last part of a definition so watch out for terminating ;"
	
	s crtab.
	s nextPutAll: 'slots: '.
	self slotDefinitionsOn: s.
	s nextPutAll: ';'.! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testSystemAnnouncerClass
	
	self assert: (self forClass: SystemAnnouncer class) equals: 'Announcer class << SystemAnnouncer class
	slots: { #announcer }'! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - expanded' stamp: ''!
testExpandedTime

	self 
		assert: (self expandedForClass: Time)  
		equals: 'Magnitude << #Time
	layout: FixedLayout;
	traits: {};
	slots: { #seconds . #nanos };
	sharedVariables: {};
	sharedPools: { ChronologyConstants };
	tag: ''Chronology'';
	package: ''Kernel'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'helpers' stamp: ''!
expandedForClass: aClass
	^ (FluidClassDefinitionPrinter for: aClass) expandedDefinitionString! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testArrayedCollectionWithPoolDictionary

	self assert: (self forClass: ExampleForTestWithSharedPool) equals: 'ArrayedCollection << #ExampleForTestWithSharedPool
	sharedPools: { ChronologyConstants };
	tag: ''Classes'';
	package: ''Kernel-Tests'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testByteString

	self assert: (self forClass: ByteString) equals: 'String << #ByteString
	layout: ByteLayout;
	sharedVariables: { #NonAsciiMap };
	tag: ''Base'';
	package: ''Collections-Strings'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testMetaclassClass
	
	self assert: (self forClass: Metaclass class) equals: 
 'ClassDescription class << Metaclass class'! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testPoint
	
	self assert: (self forClass: Point) equals: 'Object << #Point
	slots: { #x . #y };
	tag: ''BasicObjects'';
	package: ''Kernel'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - complex slots' stamp: ''!
testClassDefinitionWithComplexSlotShouldBeDisplayedAsFluid

	ClassDefinitionPrinter showFluidClassDefinition: false.
	self assert: MockWithComplexSlot needsSlotClassDefinition.

	self 
		assert: (self forClass: MockWithComplexSlot) 
		equals: 'Object << #MockWithComplexSlot
	slots: { #aComplexSlot => ObservableSlot };
	tag: ''Fluid'';
	package: ''Kernel-Tests'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - template' stamp: ''!
testCompactClassTemplate

	self 
		assert: (FluidClassDefinitionPrinter new compactClassDefinitionTemplateInPackage: 'Kernel') 
		equals:  'Object << #MyClass
	slots: {};
	sharedVariables: {};
	package: ''Kernel'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - unnecessary values' stamp: ''!
testPointMinimalInformation
	"I would like to be able to test if I provide too many empty values that
	the default empty values are just ignored."
	| class |
	class := (Object << #CDFluidMock
	slots: {#x . #y};
	tag: 'BasicObjects';
	package: 'Kernel') build.
	"I cannot test the tag because the class is not installed so the package manager
	does not know the package and the class."
	self assert: (self forClass: class) equals: 'Object << #CDFluidMock
	slots: { #x . #y };
	package: ''_UnpackagedPackage'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - template' stamp: ''!
testFullClassTemplate

	self 
		assert: (FluidClassDefinitionPrinter new classDefinitionTemplateInPackage: 'Kernel') 
		equals:  'Object << #MyClass
	layout: FixedLayout;
	traits: {};
	slots: {};
	sharedVariables: {};
	sharedPools: {};
	tag: '''' ;
	package: ''Kernel'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - unnecessary values' stamp: ''!
testDoesNotDisplayEmptySlots

	| class |
	ClassDefinitionPrinter displayEmptySlots: false.
	class := (Object << #CDFluidMock
	slots: {};
	tag: 'BasicObjects';
	package: 'Kernel') build.
	self assert: (self forClass: class) equals: 'Object << #CDFluidMock
	package: ''_UnpackagedPackage'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testProtoObject
	
	self assert: (self forClass: ProtoObject) equals: 'nil << #ProtoObject
	tag: ''Objects'';
	package: ''Kernel'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - expanded' stamp: ''!
testExpandedOnClassWithoutTag

	self 
		assert: (self expandedForClass: EncoderForSistaV1)
		equals:   'BytecodeEncoder << #EncoderForSistaV1
	layout: FixedLayout;
	traits: {};
	slots: {};
	sharedVariables: {};
	sharedPools: {};
	tag: '''';
	package: ''Kernel-BytecodeEncoders'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testArray

	self 
		assert: (self forClass: Array)
		equals: 'ArrayedCollection << #Array
	layout: VariableLayout;
	tag: ''Base'';
	package: ''Collections-Sequenceable'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - expanded' stamp: ''!
testExpandedEmptyLayoutClass

	self 
		assert: (self expandedForClass: EmptyLayout class)  
		equals: 'EmptyLayout class
	traits: {};
	slots: { #instance }'! !

!FluidClassDefinitionPrinterTest methodsFor: 'helpers' stamp: ''!
forClass: aClass
	^ (FluidClassDefinitionPrinter for: aClass) definitionString! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testMetaclass
	
	self assert: (self forClass: Metaclass) equals: 'ClassDescription << #Metaclass
	slots: { #thisClass };
	tag: ''Classes'';
	package: ''Kernel'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - expanded' stamp: ''!
testExpandedPoint

	self 
		assert: (self expandedForClass: Point) 
		equals: 'Object << #Point
	layout: FixedLayout;
	traits: {};
	slots: { #x . #y };
	sharedVariables: {};
	sharedPools: {};
	tag: ''BasicObjects'';
	package: ''Kernel'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testChronologyConstants

	self
		assert: (self forClass: ChronologyConstants)
		equals: 'SharedPool << #ChronologyConstants
	sharedVariables: { #NanosInSecond . #MonthNames . #SecondsInHour . #SecondsInDay . #DayNames . #DaysInMonth . #HoursInDay . #NanosInMillisecond . #SecondsInMinute . #SqueakEpoch . #MinutesInHour . #MicrosecondsInDay };
	tag: ''Chronology'';
	package: ''Kernel'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - unnecessary values' stamp: ''!
testDisplayEmptySlots
	"I would like to be able to test if I provide too many empty values that
	the default empty values are just ignored."
	| class |
	ClassDefinitionPrinter displayEmptySlots: true.
	class := (Object << #CDFluidMock
	slots: {};
	tag: 'BasicObjects';
	package: 'Kernel') build.
	self assert: (self forClass: class) equals: 'Object << #CDFluidMock
	slots: {};
	package: ''_UnpackagedPackage'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testProtoObjectClass
	
	self assert: (self forClass: ProtoObject class) equals: 'Class class << ProtoObject class'! !

!FluidClassDefinitionPrinterTest methodsFor: 'tests - complex slots' stamp: ''!
testDefinitionWithComplexSlot
	"Fluid definition support complex slots."
	
	self assert: (self forClass: MockWithComplexSlot) equals: 'Object << #MockWithComplexSlot
	slots: { #aComplexSlot => ObservableSlot };
	tag: ''Fluid'';
	package: ''Kernel-Tests'''! !

!FluidClassDefinitionPrinterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	ClassDefinitionPrinter showFluidClassDefinition: true! !

!FluidClassSideClassBuilder commentStamp: ''!
I'm a builder responsible for handling the specific case of 

```
Object class >> Point class
	slots: ;
	traits: ....;
```

We want to make sure that we are not forced to use classSlots: and classTraits: 
because users will be confused. !
!FluidClassSideClassBuilder methodsFor: 'accessing' stamp: ''!
traits: aCollection
	"pay attention that on class side we want to write traits: and not classTraits:"
	
	classTraitsToBuild := aCollection asTraitComposition! !

!FluidClassSideClassBuilder methodsFor: 'accessing' stamp: ''!
slots: anArray
	"pay attention on the class side we do not have to have classSlots: but slots:"
	
	classSlotsToBuild := anArray collect: [ :each | each asSlot ]! !

!FluidClassSideClassBuilderTest methodsFor: 'tests' stamp: ''!
testBuilderWithSlots

	builder slots: { #metaX . #metaY }.
	"the builder is class side builder so we are setting the class level"
	
	self assert: builder classSlotsToBuild equals: {#metaX => InstanceVariableSlot. #metaY => InstanceVariableSlot}.
	self assert: builder slotsToBuild equals: #().! !

!FluidClassSideClassBuilderTest methodsFor: 'tests' stamp: ''!
testBuilderClassName
	
	"Yes a class side builder expects the instance name."
	self assert: builder nameToBuild equals: #'Point33'! !

!FluidClassSideClassBuilderTest methodsFor: 'tests' stamp: ''!
testBuilderSuperclass
	
	self assert: builder superclassToBuild equals: Object! !

!FluidClassSideClassBuilderTest methodsFor: 'tests' stamp: ''!
testBuilderWithTraits

	builder traits: { TViewModelMock classTrait }.
	"the builder is class side builder so we are setting the class level"
	self assert: builder traitsToBuild isEmpty.
	self assert: builder classTraitsToBuild name equals: TViewModelMock classTrait name! !

!FluidClassSideClassBuilderTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	"as we can see the superclass and name are the ones of the class (not the metaclass)"
	builder := FluidClassSideClassBuilder new
		           superclassToBuild: Object;
		           nameToBuild: #Point33;
		           package: 'FakedPackage'! !

!FluidClassSideTraitBuilder commentStamp: ''!
I'm a builder responsible for handling the specific case of 

```
Trait >> TPoint classTrait
	slots: ;
	traits: ....;
```

We want to make sure that we are not forced to use classSlots: and classTraits: 
because users will be confused. !
!FluidClassSideTraitBuilder methodsFor: 'accessing' stamp: ''!
traits: aCollection
	"pay attention that on class side we want to write traits: and not classTraits:"
	
	classTraitsToBuild := aCollection asTraitComposition! !

!FluidClassSideTraitBuilder methodsFor: 'accessing' stamp: ''!
slots: anArray
	"pay attention on the class side we do not have to have classSlots: but slots:"
	
	classSlotsToBuild := anArray collect: [ :each | each asSlot ]! !

!FluidClassSideTraitBuilderTest methodsFor: 'initialization' stamp: ''!
testSlots

	| trait |
	builder := Trait << TViewModelMock classTrait
					slots: { #x . #y };
					package: 'FakedCore'.
	trait := builder build.
	
	self assert: trait name equals: #TViewModelMock.
	self assert: trait class slots size equals: 2! !

!FluidClassSideTraitBuilderTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	"as we can see the superclass and name are the ones of the class (not the metaclass)"
	builder := FluidClassSideTraitBuilder new
		           nameToBuild: TViewModelMock! !

!FluidTraitBuilder commentStamp: ''!
Similar to class `FluidClassBuilder` but for traits!
!FluidTraitBuilder methodsFor: 'accessing' stamp: ''!
fillShiftClassBuilder
	
	super fillShiftClassBuilder.
	shiftClassBuilder 
		beTrait;
		sharedVariables: #();
		sharedPools: ''.
		
	^ shiftClassBuilder! !

!FluidTraitBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testCreatingEmptyTraitHasDefaultElements

	| instBuilder newTrait |
	instBuilder := (Trait << #TTestTrait
		package: 'Mock').
		
	"Ideally we should not install the class but just build it (sending instBuilder build)
	the problem is that category and tag are lost by the class builder. 
	Hence we cannot test for real."
	newTrait := instBuilder install.
	
	self assert: newTrait name equals: #TTestTrait.
	self assert: newTrait slotNames equals: #().
	self assert: newTrait traitComposition equals: {} asTraitComposition.
	self assert: newTrait class traitComposition equals: {} asTraitComposition.
	self assert: newTrait classVarNames equals: #().
	self assert: newTrait category equals: 'Mock'.! !

!FluidTraitBuilderTest methodsFor: 'tests - classBuilder generation' stamp: ''!
testBuildSimplePoint2

	| trait |
	builder := Trait << #TPoint2
					slots: { #x . #y };
					package: 'FakedCore'.
	trait := builder build.
	
	self assert: trait name equals: #TPoint2.
	self assert: trait slots size equals: 2! !

!FluidTraitBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testExistingTraitWithClassSlotsArePreservedIfChangingInstanceSide

	| instBuilder newTrait |
	instBuilder := (Trait << #TTestTrait
		classSlots: #(AAA);
		package: 'Mock').
		
	"Ideally we should not install the class but just build it (sending instBuilder build)
	the problem is that category and tag are lost by the class builder. 
	Hence we cannot test for real."
	newTrait := instBuilder install.
	
	instBuilder := (Trait << #TTestTrait
		slots: #(aaa);
		package: 'Mock').

	newTrait := instBuilder install.

	self assert: newTrait class slotNames equals: #(AAA)! !

!FluidTraitBuilderTest methodsFor: 'private - cleanup' stamp: ''!
removeTestArtifactsFromSystem

	self class environment
		at: #TMyClass
		ifPresent: [ :p | p removeFromSystem: false ]
		ifAbsent: [ ]! !

!FluidTraitBuilderTest methodsFor: 'running' stamp: ''!
tearDown

	self class environment 
		at: #TTestTrait 
		ifPresent: [ :cl | cl removeFromSystem  ].
	super tearDown.! !

!FluidTraitBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testExistingTraitWithSlotsArePreservedIfChangingClassSide

	| instBuilder newTrait classBuilder |
	instBuilder := (Trait << #TTestTrait
		slots: #(aaa);
		package: 'Mock').
		
	"Ideally we should not install the class but just build it (sending instBuilder build)
	the problem is that category and tag are lost by the class builder. 
	Hence we cannot test for real."
	newTrait := instBuilder install.
	
	classBuilder := (Trait << newTrait classTrait 
		slots: #(AAA);
		package: 'Mock').

	newTrait := classBuilder install.

	self assert: newTrait class slotNames equals: #(AAA)	.
	self assert: newTrait slotNames equals: #(aaa)! !

!FluidTraitBuilderTest methodsFor: 'tests - install' stamp: ''!
testInstallSimplePoint2

	[ | trait |
	self assert: (self class environment at: #TPoint2 ifAbsent: [ true ]).
	
	builder := Trait << #TPoint2
					slots: { #x . #y };
					package: 'FakedCore'.
	builder install.
	trait := self class environment at: #TPoint2. 
	self assert: trait name equals: #TPoint2.
	self assert: trait slots size equals: 2 ] ensure: [  
			self class environment removeKey: #TPoint2 ifAbsent: [self fail]. 
			self assert: (self class environment at: #TPoint2 ifAbsent: [ true ])]! !

!FluidTraitBuilderTest methodsFor: 'tests' stamp: ''!
testTraitNoSlotsNoUse

	| trait |
	builder := Trait << #TPoint3
		package: 'Fake'.
	trait := builder build.
	
	self assert: trait name equals: #TPoint3.
	self assert: trait package packageName equals: '_UnpackagedPackage'! !

!FluidTraitBuilderTest methodsFor: 'tests' stamp: ''!
testTraitUse

	| trait |
	builder := (Trait << #TPoint3)
		           traits: TViewModelMock;
		           package: 'Fake'.
	trait := builder build.

	self assert: trait name equals: #TPoint3.
	self assert: trait traitComposition innerClass equals: TViewModelMock.
	self assert: trait package packageName equals: '_UnpackagedPackage'! !

!FluidTraitBuilderTest methodsFor: 'tests - install' stamp: ''!
testInstallMinimalMockClass

	| shiftClassBuilder installedClass |
	self removeTestArtifactsFromSystem.
	[ 
	builder := self class compilerClass new
		           evaluate: 'Trait << #TMyClass
	traits: {};
	slots: {};
	tag: '''' ;
	package: ''MyPackage'''.
	shiftClassBuilder := builder shiftClassBuilder.
	ShiftClassInstaller new makeWithBuilder: shiftClassBuilder.
	
	installedClass := self class environment at: #TMyClass ifAbsent: [self fail].
	         
	self assert: installedClass name equals: #TMyClass.
	self assert: installedClass isFixed.
	self assert: installedClass slots isEmpty.
	self assert: installedClass traitComposition isEmpty ]
		ensure: [ self removeTestArtifactsFromSystem ]! !

!FluidTraitBuilderTest methodsFor: 'tests - classBuilder generation' stamp: ''!
testFillShiftClassBuilder

	| shift |
	builder := Trait << #TPoint2.
	builder slots: { #x. #y }.
	builder traits: { TViewModelMock }.
	builder tag: 'Mafia'.
	builder package: 'FakedCore'.
	builder fillShiftClassBuilder.
	shift := builder shiftClassBuilder.
	self assert: shift name equals: #TPoint2.
	self assert: shift slots size equals: 2.
	self assert: shift category equals: 'FakedCore-Mafia'.
	self flag: #askPablo
	"self assert: clas package packageName equals: 'FakedCore'"! !

!FluidTraitBuilderTest methodsFor: 'class side' stamp: ''!
testClassSlots

	builder classSlots: {#string . #runs}.
	self assert: builder classSlotsToBuild equals: {#string => InstanceVariableSlot. #runs => InstanceVariableSlot}! !

!FluidTraitBuilderTest methodsFor: 'tests - class creation' stamp: ''!
testCreatingFullTraitHasAllElements

	| instBuilder newTrait |
	instBuilder := (Trait << #TTestTrait
		slots: #(a b c);
		traits: {TViewModelMock};
		tag: 'lala';
		package: 'Mock').
		
	"Ideally we should not install the class but just build it (sending instBuilder build)
	the problem is that category and tag are lost by the class builder. 
	Hence we cannot test for real."
	newTrait := instBuilder install.
	
	self assert: newTrait name equals: #TTestTrait.
	self assert: newTrait slotNames equals: #(a b c).
	self assert: newTrait traitComposition equals: {TViewModelMock} asTraitComposition.
	self assert: newTrait class traitComposition equals: {TViewModelMock classSide} asTraitComposition.
	self assert: newTrait classVarNames equals: #().
	self assert: newTrait category equals: 'Mock-lala'.! !

!FluidTraitBuilderTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	builder := FluidTraitBuilder new! !

!FontChooser commentStamp: ''!
I'm an object holding information to choose a font from a list of fonts.!
!FontChooser methodsFor: 'action' stamp: ''!
apply

	(target isNil or: [ setSelector isNil ]) ifTrue: [ ^ self ].			
	self selectedFont ifNotNil: [ :font | target perform: setSelector with: font ].! !

!FontChooser methodsFor: 'accessing' stamp: ''!
getSelector

	^ getSelector! !

!FontChooser methodsFor: 'accessing' stamp: ''!
pointSize: aNumber

	pointSize := aNumber.
	self announcer announce: #pointSizeChanged.! !

!FontChooser methodsFor: 'accessing' stamp: ''!
fontStyleList

	^ self selectedFontFamily
		ifNil: [ #() ]
		ifNotNil: [ :family | fontStyleList := family members asSortedCollection ].! !

!FontChooser methodsFor: 'accessing' stamp: ''!
setSelector: selector

	setSelector := selector! !

!FontChooser methodsFor: 'action' stamp: ''!
updateFontList
	FreeTypeFontProvider current updateFromSystem.
	self refreshFontList.
	self changed:#fontListStrings.! !

!FontChooser methodsFor: 'selected' stamp: ''!
selectedPointSize
	^self selectedFont pointSize! !

!FontChooser methodsFor: 'action' stamp: ''!
refreshFontList
	
	^fontList := LogicalFontManager current allFamilies! !

!FontChooser methodsFor: 'selected' stamp: ''!
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: ''!
selectedPointSizeIndex

	^self pointSizeList indexOf: (pointSize reduce asString padLeftTo: 3)! !

!FontChooser methodsFor: 'accessing' stamp: ''!
fontList
	
	^ fontList ifNil: [ self refreshFontList ].! !

!FontChooser methodsFor: 'selected' stamp: ''!
selectedPointSizeIndex: anIndex

	anIndex = 0 ifTrue: [^self].
	pointSize := (self pointSizeList at: anIndex) trimBoth asNumber.
	self announcer announce: #pointSizeChanged.! !

!FontChooser methodsFor: 'selected' stamp: ''!
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: 'accessing' stamp: ''!
fontStyleListStrings
	"names of simulated styles are enclosed in parenthesis"

	^ self fontStyleList collect: [:fontFamilyMember | | styleName |
		styleName := fontFamilyMember styleName.
		fontFamilyMember isSimulatedStyle
			ifTrue: ['(', styleName, ')']
			ifFalse: [styleName]].! !

!FontChooser methodsFor: 'action' stamp: ''!
unemphasizedSelectedFont
	|name font family |
	family := self fontList at: self selectedFontIndex ifAbsent:[nil].
	family ifNil:[^nil].
	(family isKindOf: TextStyleAsFontFamily)
		ifTrue:[^family textStyle fontOfPointSize: pointSize].
	name :=  family familyName.
	font := LogicalFont 
		familyName: name
		pointSize: pointSize 
		stretchValue: 5
		weightValue: 400
		slantValue: 0.
	font realFont isTTCFont "true for FreeTypeFont"
		ifFalse: [font := font textStyle fontOfPointSize: pointSize].
	^font! !

!FontChooser methodsFor: 'accessing' stamp: ''!
target: anObject

	target := anObject! !

!FontChooser methodsFor: 'selected' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	super initialize.
	title := 'Choose A Font'.! !

!FontChooser methodsFor: 'selected' stamp: ''!
selectedFontFamily

	^ self fontList at: self selectedFontIndex ifAbsent: [nil].! !

!FontChooser methodsFor: 'action' stamp: ''!
setStyleValuesFrom: aFont
	((aFont isKindOf: LogicalFont) or:[aFont isKindOf: AbstractFontFamilyMember])
		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: 'accessing' stamp: ''!
title: aString

	title := aString! !

!FontChooser methodsFor: 'accessing' stamp: ''!
fontListStrings

	| isUpdateRequired |
	isUpdateRequired := fontListStrings isNil or: [fontList size ~= fontListStrings size].
	isUpdateRequired ifTrue: [
		fontListStrings := self fontList collect: [:each | each familyName]].
	^ fontListStrings! !

!FontChooser methodsFor: 'accessing' stamp: ''!
getSelector: aSelectorSymbolOrFont

	getSelector := aSelectorSymbolOrFont! !

!FontChooser methodsFor: 'selected' stamp: ''!
selectedFontIndex: anIndex

	| family member newStyleIndex |
	anIndex = 0 ifTrue: [^self].
	selectedFontIndex := anIndex.
	"change the selected style to be the closest to the last
	user selected weight slant and stretch values. 
	By user selected I mean that the user changed the style list selection, 
	rather than a change being forced because a particular family didn't have that style"
	family := self fontList at: selectedFontIndex.
	member := family closestMemberWithStretchValue: stretchValue weightValue: weightValue slantValue: slantValue.
	newStyleIndex := self fontStyleList indexOf: member.
	selectedFontStyleIndex := newStyleIndex. 
	self setPointSizeListFrom: member.
	self announcer announce: #selectedFontStyleIndex.
	self announcer announce: #selectedFontIndex.! !

!FontChooser methodsFor: 'accessing' stamp: ''!
pointSize

	^ pointSize ifNil: [pointSize := 10.0]! !

!FontChooser methodsFor: 'accessing' stamp: ''!
pointSizeList

	pointSizeList ifNotNil: [ ^ pointSizeList ].
	^ pointSizeList := (1 to: 256) collect: [ :each | each asString padLeftTo: 3 ].! !

!FontChooser methodsFor: 'selected' stamp: ''!
setPointSizeListFrom: aFontFamilyMember
	| style old new |
	old := pointSizeList.
	(aFontFamilyMember isKindOf: AbstractFontFamilyMember)
		ifTrue:[
			style := TextStyle named: aFontFamilyMember family familyName.
			style ifNotNil:[
				new := style pointSizes collect: [:each | 
					each reduce asString padLeftTo: 3]]].
	new ifNil: [ new := (1 to: 256) collect: [:each | 
				each asString padLeftTo: 3 ]].
	
	pointSizeList := new.
	old ~= new ifTrue: [ self announcer announce: #pointSizeListChanged]! !

!FontChooser methodsFor: 'accessing' stamp: ''!
target

	^ target! !

!FontChooser methodsFor: 'accessing' stamp: ''!
windowTitle
	^ title translated! !

!FontChooser methodsFor: 'selected' stamp: ''!
selectedFontStyleIndex: anIndex
	| familyMember |
	anIndex = 0
		ifTrue: [^self].
	selectedFontStyleIndex := anIndex.
	familyMember := self fontStyleList at: anIndex.
	self setStyleValuesFrom: familyMember.
	self announcer announce:  #selectedFontStyleIndex.! !

!FontChooser class methodsFor: 'open' stamp: ''!
openWithWindowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector
	<script: 'self example'>

	| instance windowMorph |
	instance := self new.
	instance
		title: titleString;
		target: anObject;
		setSelector: setSelector;
		getSelector: getSelector.
	(windowMorph := FontChooserMorph withModel: instance)
		position: self currentWorld width - 640 / 2 @ (self currentWorld height - 480 / 2);
		extent: 640 @ 480;
		open.
	"position: self currentWorld primaryHand position;"
	^ windowMorph! !

!FontChooser class methodsFor: 'examples' stamp: ''!
example
	self openWithWindowTitle: 'Choose the Menu Font' for: StandardFonts setSelector: #menuFont: getSelector: #menuFont! !

!FontChooser class methodsFor: 'instance creation' stamp: ''!
windowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector
	
	| instance answer |
	instance := self new.
	instance 
		title: titleString;
		target: anObject;
		setSelector: setSelector;
		getSelector: getSelector.
	(answer := FontChooserMorph withModel: instance)
		position: self currentWorld primaryHand position;
		extent: 450@220;
		createWindow.
	^answer! !

!FontChooserMorph commentStamp: ''!
I'm the UI of a font chooser. 

FontChooser 
	openWithWindowTitle: 'Choose the Menu Font' 
	for: StandardFonts 
	setSelector: #menuFont: 
	getSelector: #menuFont
	
!
!FontChooserMorph methodsFor: 'initialization' stamp: ''!
initializeWithModel: aFontChooser
	self 
		model: aFontChooser;
		clipSubmorphs: true;
		setLabel: self model windowTitle;
		name: 'FontChooser'.
	self model announcer when: #pointSizeListChanged send: #updatePointSizeList to: self.
	self model announcer when: #selectedFontIndex send: #updateFontIndex to: self.
	self model announcer when: #pointSizeChanged send: #updatePointSize to: self.
	self model announcer when: #selectedFontStyleIndex send: #updateStyleList to: self.
	self updatePreview! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
newFontList 

	| widget requiredWidth |
	widget := PluggableListMorph
		on: self model
		list: #fontListStrings
		selected: #selectedFontIndex
		changeSelected: #selectedFontIndex:.

	requiredWidth := self
		widthRequiredFor: [ :each | widget font widthOfStringOrText: each familyName ]
		from: model fontList
		noLessThan: 20.

	widget	
		color: Color white;
		borderInset;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		width: requiredWidth + widget scrollBarThickness + (widget font widthOfStringOrText: '  ').
		
	self model announcer when: #fontsUpdated send: #verifyContents to: widget.
	
	^ widget.! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
newFontPreviewInnerPanel
	"Answer a morph for the preview text."
	
	| textMorph |
	textMorph := self newText: self previewText.
	textMorph margins: 4 asMargin.
	^ self model selectedFont
		ifNil: [ textMorph ]
		ifNotNil: [ :f | textMorph beAllFont: f ]! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
apply
	result := model selectedFont.
	model apply! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
pointSizeString: aText
	
	| string number |
	string := aText asString trimBoth.
	string isEmpty ifTrue: [^self].
	string
		detect: [:c | c isDigit not and: [c ~= $.]]
		ifFound: [^self].
	[number := string asNumber asFloat] on: Error do: [:e | ^self].
	(number < 1 or: [number > 1024])
		ifTrue: [^self].

	pointSizeMorph ifNotNil: [pointSizeMorph hasUnacceptedEdits: false].
	model pointSize: number! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
okButtonClicked

	self apply.
	self delete.! !

!FontChooserMorph methodsFor: 'open/close' stamp: ''!
open

	^ self createWindow openInWorld.! !

!FontChooserMorph methodsFor: 'ui elements' stamp: ''!
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: 'ui elements' stamp: ''!
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: ''!
languageIndex

	| item |
	item := self pangrams detect: [ :one | one value = selectedPangram ] ifNone: nil.
	^self pangrams indexOf: item.! !

!FontChooserMorph methodsFor: 'accessing' stamp: ''!
result
	^ result! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
updateFontList

	model updateFontList.
	self announcer announce: #fontsUpdated.! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
newFontSizePanel

	pointSizeMorph := self newFontPointSizeField.
	^ Morph new
		borderWidth: 1;
		borderColor: Color black;
		hResizing: #spaceFill;
		vResizing: #shrinkwrap;
		color: Color transparent;
		layoutPolicy: TableLayout new;
		cellInset: 0;
		listCentering: #topLeft;
		listDirection: #leftToRight;
		cellPositioning: #leftCenter;
		clipSubmorphs: true;
		addMorphBack: self newFontPointSizeLabel;
		addMorphBack: pointSizeMorph.! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
updatePointSizeList

	pointSizeList ifNotNil: [ pointSizeList updateList ].
	self updatePreview! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
updatePreview

	 self fontPreviewPanel scrollTarget: self newFontPreviewInnerPanel! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
updatePointSize

	pointSizeList ifNotNil: [ pointSizeList selectionIndex: model selectedPointSizeIndex ].
	"this should not be like that but managed by the list!!!!!!!!"
	
	self updatePreview! !

!FontChooserMorph methodsFor: 'private' stamp: ''!
widthRequiredFor: aBlock from: aCollection noLessThan: anInteger
	"aBlock - takes each item as an argument, and returns the width it needs"

	^ aCollection inject: anInteger into: [ :max :each | | itemWidth |
		itemWidth := aBlock value: each.
		max max: itemWidth ].! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
applyButtonClicked
	self apply.! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
newFontPointSizeField
	^ (RubScrolledTextMorph
		on: self
		text: #pointSizeString
		accept: #pointSizeString:)
		acceptOnCR: true;
		vScrollbarShowNever;
		color: Color gray veryMuchLighter;
		borderColor: #inset;
		vResizing: #rigid;
		hResizing: #spaceFill;
		width:
			(TextStyle defaultFont
				widthOfString: '99999999.99');
		height:
			TextStyle defaultFont height + 6;
		yourself! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
pangrams
	^ OrderedCollection new
		add: 'English' -> 'the quick brown fox jumps over the lazy dog';
		add: 'Bulgarian' -> 'Под южно дърво, цъфтящо в синьо, бягаше малко пухкаво зайче.';
		add: 'Czech' -> 'Příliš žluťoučký kůň úpěl ďábelské ódy.';
		add: 'Chinese' -> '視野無限廣，窗外有藍天
    微風迎客，軟語伴茶';
		add: 'Danish' -> 'Quizdeltagerne spiste jordbær med fløde, mens cirkusklovnen Walther spillede på xylofon.';
		add: 'Dutch' -> 'Pa''s wijze lynx bezag vroom het fikse aquaduct';
		add: 'Esperanto' -> 'Eĥoŝanĝo ĉiuĵaŭde';
		add: 'Estonian' -> 'See väike mölder jõuab rongile hüpata';
		add: 'Finnish' -> 'Viekas kettu punaturkki laiskan koiran takaa kurkki';
		add: 'French' -> 'Voix ambiguë d''un cœur qui au zéphyr préfère les jattes de kiwis';
		add: 'German' -> 'Zwölf Boxkämpfer jagen Viktor quer über den großen Sylter Deich';
		add: 'Greek' -> 'Θέλει αρετή και τόλμη η ελευθερία. (Ανδρέας Κάλβος)';
		add: 'Hebrew' -> 'דג סקרן שט לו בים זך אך לפתע פגש חבורה נחמדה שצצה כך';
		add: 'Hungarian' -> 'Egy hűtlen vejét fülöncsípő, dühös mexikói úr Wesselényinél mázol Quitóban';
		add: 'Italian' -> 'Ma la volpe, col suo balzo, ha raggiunto il quieto Fido.';
		add: 'Japanese' -> 'いろはにほへと ちりぬるを わかよたれそ つねならむ うゐのおくやま けふこえて あさきゆめみし ゑひもせす';
		add: 'Korean' -> '다람쥐 헌 쳇바퀴에 타고파';
		add: 'Latvian' -> 'Sarkanās jūrascūciņas peld pa jūru.';
		add: 'Norwegian' -> 'En god stil må først og fremst være klar. Den må være passende. Aristoteles.';
		add: 'Portugese' -> 'A rápida raposa castanha salta por cima do cão lento.';
		add: 'Brazilian portugese' -> 'A ligeira raposa marrom ataca o cão preguiçoso';
		add: 'Polish' -> 'Pchnąć w tę łódź jeża lub ośm skrzyń fig';
		add: 'Romanian' -> 'Agera vulpe maronie sare peste câinele cel leneş';
		add: 'Russian' -> 'Съешь ещё этих мягких французских булок да выпей же чаю';
		add: 'Serbian (cyrillic)' -> 'Чешће цeђење мрeжастим џаком побољшава фертилизацију генских хибрида.';
		add: 'Serbian (latin)' -> 'Češće ceđenje mrežastim džakom poboljšava fertilizaciju genskih hibrida.';
		add: 'Slovak' -> 'Kŕdeľ šťastných ďatľov učí pri ústí Váhu mĺkveho koňa obhrýzať kôru a žrať čerstvé mäso.';
		add: 'Slovene' -> 'V kožuščku hudobnega fanta stopiclja mizar in kliče 0619872345.';
		add:
				'Spanish'
						->
							'El veloz murciélago hindú comía feliz cardillo y kiwi. La cigüeña tocaba el saxofón detrás del palenque de paja.';
		add: 'Swedish' -> 'Flygande bäckasiner söka hwila på mjuka tuvor';
		add:
				'Thai'
						->
							'เป็นมนุษย์สุดประเสริฐเลิศคุณค่า
    กว่าบรรดาฝูงสัตว์เดรัจฉาน
    จงฝ่าฟันพัฒนาวิชาการ อย่าล้างผลาญฤๅเข่นฆ่าบีฑาใคร
    ไม่ถือโทษโกรธแช่งซัดฮึดฮัดด่า
    หัดอภัยเหมือนกีฬาอัชฌาสัย
    ปฏิบัติประพฤติกฎกำหนดใจ
    พูดจาให้จ๊ะ ๆ จ๋า ๆ น่าฟังเอยฯ';
		add: 'Turkish' -> 'Pijamalı hasta, yağız şoföre çabucak güvendi';
		yourself! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
updateFontIndex

	fontList ifNotNil: [ fontList selectionIndex: model selectedFontIndex ].
	styleList ifNotNil: [ styleList updateList ].
	pointSizeList ifNotNil: [ pointSizeList updateList ].
	self updatePreview! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
newLanguageList

	| widget |
	widget := PluggableListMorph
		on: self 
		list: #languages
		selected: #languageIndex
		changeSelected: #languageIndex:.
	^ widget	
			color: Color white;
			borderInset;
			vResizing: #spaceFill;
			hResizing: #spaceFill;
			yourself.! !

!FontChooserMorph methodsFor: 'accessing' stamp: ''!
languageIndex: anIndex

	anIndex isZero ifTrue: [ ^ self ]. 
	selectedPangram := (self pangrams at: anIndex) value.
	languageList selectionIndex: anIndex.
	self updatePreview! !

!FontChooserMorph methodsFor: 'open/close' stamp: ''!
delete
	model := nil.
	super delete! !

!FontChooserMorph methodsFor: 'accessing' stamp: ''!
selectedPangram
	^ selectedPangram ifNil: [ self pangrams first value ]! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
newFontPointSizeLabel 

	^ StringMorph
		contents: 'Point size:' translated;
		yourself.! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
newPointSizeList 

	| widget |
	widget := PluggableListMorph
		on: self model
		list: #pointSizeList
		selected: #selectedPointSizeIndex
		changeSelected: #selectedPointSizeIndex:.
	^ widget	
			color: Color white;
			borderInset;
			vResizing: #spaceFill;
			hResizing: #spaceFill;
			yourself.! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
updateStyleList

	styleList ifNotNil: [ styleList selectionIndex: model selectedFontStyleIndex ].
	"this should not be like that but managed by the list!!!!!!!!"
	
	self updatePreview! !

!FontChooserMorph methodsFor: 'accessing' stamp: ''!
previewText

	"Answer the preview text based on current font."

	| sample i maxLineLength endOfLineCharacters |

	model selectedFont ifNil: [ ^ '' ].
	sample := String new writeStream.
	model selectedFont isSymbolFont
		ifFalse: [ | pangram |

			pangram := self selectedPangram.
			sample
				nextPutAll: pangram;
				cr;
				nextPutAll: pangram asUppercase;
				cr
			].
	i := 0.
	maxLineLength := 30.
	endOfLineCharacters := '@Z`z'.
	33 to: 255 do: [ :asciiValue | 
		| character |

		character := Character value: asciiValue.
		sample nextPut: character.
		i := i + 1.
		( ( endOfLineCharacters includes: character ) or: [ i = maxLineLength ] )
			ifTrue: [ i := 0.
				sample cr
				]
		].
	^ sample contents! !

!FontChooserMorph methodsFor: 'initialization' stamp: ''!
initializeLabelArea
	"Customize the window bar by removing all the decorations"
	
	super initializeLabelArea.
	self
		removeCollapseBox;
		removeExpandBox;
		removeMenuBox! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
cancelButtonClicked
	result :=nil.
	self delete! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
languages
	
	^ self pangrams collect: [:each | each key]! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
newFontStyleList 

	| widget minWidth requiredWidth |
	widget := PluggableListMorph
		on: self model
		list: #fontStyleListStrings
		selected: #selectedFontStyleIndex
		changeSelected: #selectedFontStyleIndex:.
		
	minWidth := widget font widthOfStringOrText: 'Condensed Extra Bold Oblique' "long, but not the longest".
	requiredWidth := self
		widthRequiredFor: [ :each | widget font widthOfStringOrText: each styleName ]
		from: model fontStyleList
		noLessThan: minWidth.

	^ widget	
			color: Color white;
			borderInset;
			vResizing: #spaceFill;
			hResizing: #spaceFill;
			width: requiredWidth + widget scrollBarThickness + (widget font widthOfStringOrText: '  ');
			yourself.! !

!FontChooserMorph methodsFor: 'ui elements' stamp: ''!
updateButton

	updateButton ifNotNil: [ ^ updateButton ].
	updateButton := self
		newButtonFor: self
		action: #updateButtonClicked
		label: 'Update' translated
		help: 'Click here to rescan Font Folder and update the font list' translated.
	^ updateButton
		hResizing: #spaceFill;
		yourself.! !

!FontChooserMorph methodsFor: 'ui elements' stamp: ''!
okButton

	okButton ifNotNil: [ ^ okButton ].
	okButton := self
			newButtonFor: self
			action: #okButtonClicked
			label: 'OK' translated
			help: 'Click here to close this dialog, and accept your selection' translated.
		^ okButton
			hResizing: #spaceFill;
			yourself.! !

!FontChooserMorph methodsFor: 'actions' stamp: ''!
updateButtonClicked

	self updateFontList.! !

!FontChooserMorph methodsFor: 'accessing' stamp: ''!
pointSizeString

	^ model pointSize asString.! !

!FontChooserMorph methodsFor: 'interface building' stamp: ''!
createWindow
	"Create the package loader window."
	
	| buttonBar buttonBarOffset previewFrame buttonBarFrame |	
	buttonBar := self newRow: {
		self applyButton.
		self okButton.
		self cancelButton.
		self updateButton }.
	buttonBar cellInset: 8@0.
	buttonBarOffset := buttonBar minExtent y negated - (2 * ProportionalSplitterMorph splitterWidth).
	
	fontList := self newFontList borderWidth: 0.
	self 
		addMorph: fontList
		frame: (0.0 @ 0.0 corner: 0.4 @ 0.4).

	styleList := self newFontStyleList
		borderWidth: 0;
		yourself.
	self 
		addMorph: styleList
		frame: (0.4 @ 0.0 corner: 0.6 @ 0.4).

	pointSizeList := self newPointSizeList
		borderWidth: 0;
		yourself.
	self 
		addMorph: pointSizeList
		frame: (0.6 @ 0.0 corner: 0.75 @ 0.4).
		
	languageList := self newLanguageList
		borderWidth: 0;
		yourself.
	self 
		addMorph: languageList
		frame: (0.75 @ 0.0 corner: 1.0 @ 0.4).
	self languageIndex: 1.	
	
	previewFrame := (0 @ 0.4 corner: 1 @1) asLayoutFrame
		bottomOffset: buttonBarOffset
		yourself.
	self 
		addMorph: self fontPreviewPanel
		fullFrame: previewFrame. 

	buttonBarFrame := (0 @1 corner: 1@1) asLayoutFrame
		topOffset: buttonBarOffset;
		yourself.
	self 
		addMorph: buttonBar
		fullFrame: buttonBarFrame.! !

!FontChooserMorph methodsFor: 'ui elements' stamp: ''!
fontPreviewPanel 

	^fontPreviewPanel ifNil:
		[ fontPreviewPanel := self newScrollPaneFor: self newFontPreviewInnerPanel ]! !

!FontChooserMorph class methodsFor: 'instance creation' stamp: ''!
withModel: aFontChooser
	^self new 
		initializeWithModel: aFontChooser;
		yourself.! !

!FontSet commentStamp: ''!
FontSet provides a mechanism for storing a set of fonts as a class that can be conveniently filedOut, filedIn, and installed as a TextStyle.

The most common use is...
	Find a font you like.
	Use BitFont to convert a bunch of sizes to data files named, eg, LovelyNN.BF
	Use FontSet convertFontsNamed: 'Lovely' to produce a FontSet named Lovely.
	FileOut that FontSet for later use.
	Use Lovely installAsTextStyle to make all sizes available in a TextStyle
		named #Lovely in the TextConstants dictionary.
	Use ctrl-k in any text pane to select the new Lovely style for that paragraph.
	Then use cmd-1 through 5 or cmd-k to set the point-size for any selection.
!
!FontSet class methodsFor: 'installing' stamp: ''!
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: aString base64Decoded readStream! !

!FontSet class methodsFor: 'installing' stamp: ''!
installAsDefault 
	"FontSetNewYork installAsDefault"
	
	(self confirm: 'Do you want to install' translated, '
''' , self fontName , ''' as default font?' translated)
		ifFalse: [^ self].
	self installAsTextStyle.
	TextSharedInformation at: #DefaultTextStyle put: (TextStyle named: self fontName).! !

!FontSet class methodsFor: 'private' stamp: ''!
fontCategory
	^ 'Graphics-Fonts' asSymbol! !

!FontSet class methodsFor: 'compiling' stamp: ''!
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: 'private' stamp: ''!
fontName
	^ self name asSymbol! !

!FontSet class methodsFor: 'installing' stamp: ''!
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 ]))! !

!FontSubstitutionDuringLoading commentStamp: ''!
signaled by font loading code when reading a DiskProxy that calls for a missing font.!
!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: ''!
pixelSize
	"Answer the value of pixelSize"

	^ pixelSize! !

!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: ''!
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: ''!
pixelSize: anObject
	"Set the value of pixelSize"

	pixelSize := anObject! !

!FontSubstitutionDuringLoading methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(;
		nextPutAll: familyName;
		nextPut: $-;
		print: pixelSize;
		nextPut: $).! !

!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: ''!
familyName: anObject
	"Set the value of familyName"

	familyName := anObject! !

!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: ''!
familyName
	"Answer the value of familyName"

	^ familyName! !

!FontSubstitutionDuringLoading class methodsFor: 'instance creation' stamp: ''!
forFamilyName: aName pixelSize: aSize
	^(self new)
		familyName: aName;
		pixelSize: aSize;
		yourself.! !

!FontTest commentStamp: ''!
I am mainly a test for fallback font.
FontTest buildSuite run!
!FontTest methodsFor: 'testing' stamp: ''!
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 equals: (width + 4)
	"bb destForm asMorph openInHand."
! !

!FontTest methodsFor: 'testing' stamp: ''!
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 equals: (width @ height)! !

!FooSharedPool commentStamp: ''!
Just a class for testing.!
!ForEventTestMock methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	counter := 0! !

!ForEventTestMock methodsFor: 'accessing' stamp: ''!
stringMorph
	^ stringMorph ifNil: [ stringMorph := self mockStringMorph ]! !

!ForEventTestMock methodsFor: 'accessing' stamp: ''!
mouseEnter: a from: b
	counter := counter + 1! !

!ForEventTestMock methodsFor: 'accessing' stamp: ''!
counter: anObject
	counter := anObject! !

!ForEventTestMock methodsFor: 'accessing' stamp: ''!
counter
	^ counter! !

!ForEventTestMock methodsFor: 'accessing' stamp: ''!
mockStringMorph
	^ StringMorph new
		contents: 'Test';
		on: #mouseEnter send: #mouseEnter:from: to: self;
		yourself! !

!ForbiddenClassAnnotation commentStamp: ''!
I represent class annotation which annotates forbidden classes.
I am only used during registry bulding. And my instances are never added to the registry.

When annotation is attatched to forbidden class I am used instead during registry building. I guard actual annotation from being added to the registry.

I define #isForbidden method to be always true. So it never fails.
I was introduced to check actual annotation inside ensure block. So if #isForbidden method fails (due to bad implementation) the full annotation will be safelly replaced by BrokenClassAnnotation with details about error.
But if it not fails then such annotation is replaced by me. And outer place where annotation is added to the registry can safelly check #isForbidden without error guard.  !
!ForbiddenClassAnnotation methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	self printDeclarationOn: aStream! !

!ForbiddenClassAnnotation methodsFor: 'accessing' stamp: ''!
actualAnnotation
	^self freshInstance! !

!ForbiddenClassAnnotation methodsFor: 'testing' stamp: ''!
isForbidden
	^true! !

!ForbiddenClassAnnotationExample methodsFor: 'testing' stamp: ''!
isForbidden
	self assert: annotatedClass notNil.
	^true! !

!Form commentStamp: ''!
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: 'initialization' stamp: ''!
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: 'file in/out' stamp: ''!
writeOn: file
	"Write the receiver on the file in the format
		depth, extent, offset, bits."
	self writeAttributesOn: file.
	self writeBitsOn: file! !

!Form methodsFor: 'transitions' stamp: ''!
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].
			waitTime := 3 - (Time millisecondClockValue - t).
			waitTime > 0 ifTrue:
				["(Delay forMilliseconds: waitTime) wait"]].! !

!Form methodsFor: 'converting' stamp: ''!
lighter
	"Answer a lighter variant of this form"

	^ self lighter: 0.16! !

!Form methodsFor: 'converting' stamp: ''!
asFormOfDepth: d
	| newForm |
	d = self depth ifTrue:[^self].
	newForm := Form extent: self extent depth: d.
	(BitBlt toForm: newForm)
		colorMap: (self colormapIfNeededFor: newForm);
		copy: (self boundingBox)
		from: 0@0 in: self
		fillColor: nil rule: Form over.
	"Special case: For a 16 -> 32 bit conversion fill the alpha channel because it gets lost in translation."
	(self depth = 16 and:[d= 32]) ifTrue:[newForm fillAlpha: 255].
	^newForm! !

!Form methodsFor: 'transitions' stamp: ''!
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: 'private' stamp: ''!
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: 'testing' stamp: ''!
mightBeTranslucent
	"Answer whether this form may be translucent"
	^self depth = 32! !

!Form methodsFor: 'color mapping' stamp: ''!
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: 'copying' stamp: ''!
copy: sourceRectangle from: sourceForm to: destPt rule: rule
	^ self copy: (destPt extent: sourceRectangle extent)
		from: sourceRectangle topLeft in: sourceForm rule: rule! !

!Form methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!Form methodsFor: 'accessing' stamp: ''!
hasBeenModified: aBool
	"Change the receiver to reflect the modification state"
	aBool ifTrue:[^self unhibernate].
	self shouldPreserveContents
		ifTrue:[self hibernate]
		ifFalse:[bits := nil]! !

!Form methodsFor: 'testing' stamp: ''!
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: '*Morphic-Core' stamp: ''!
defaultCanvasClass

	"Return the default canvas used for drawing onto the receiver"
	^ FormCanvas! !

!Form methodsFor: 'color mapping' stamp: ''!
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: 'transitions' stamp: ''!
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: 'accessing' stamp: ''!
extent
	^ width @ height! !

!Form methodsFor: 'converting' stamp: ''!
asSourceForm
	^self! !

!Form methodsFor: '*Graphics-Files' stamp: ''!
writeBMPfileNamed: fName  "Display writeBMPfileNamed: 'display.bmp'"
	BMPReadWriter putForm: self onFileNamed: fName! !

!Form methodsFor: 'converting' stamp: ''!
asGrayScaleWithAlpha
	"Unlike asGrayScale, this method fully preserves the alpha channel and only desaturates the form(makes grayscale)."
	^ (self asFormOfDepth: 32) collectColors: [ :c |  |l|
		l := c luminance.
		Color r:l g: l b: l alpha: c alpha ]! !

!Form methodsFor: 'transitions' stamp: ''!
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 ]! !

!Form methodsFor: 'testing' stamp: ''!
isFillAccelerated: ruleInteger for: aColor
	"Return true if the receiver can perform accelerated fill operations by itself"
	^false! !

!Form methodsFor: 'transitions' stamp: ''!
fadeImageHorFine: otherImage at: topLeft
	"Display fadeImageHorFine: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: (0@(i-1) extent: mask width@1) fillColor: Color black.
		mask fill: (0@(i-1+16) extent: mask width@1) fillColor: Color black.
		(i*2) <= mask width]! !

!Form methodsFor: 'converting' stamp: ''!
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: 'copying' stamp: ''!
copy: aRect
 	"Return a new form which derives from the portion of the original form delineated by aRect."
	| newForm |
	newForm := self class extent: aRect extent depth: depth.
	^ newForm copyBits: aRect from: self at: 0@0
		clippingBox: newForm boundingBox rule: Form over fillColor: nil! !

!Form methodsFor: 'testing' stamp: ''!
isDisplayScreen
	^false! !

!Form methodsFor: 'color mapping' stamp: ''!
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: 'converting' stamp: ''!
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: 'testing' stamp: ''!
isLittleEndian
	"Return true if the receiver contains little endian pixels, meaning the left-most pixel is stored in the least significant bits of a word."
	^depth < 0! !

!Form methodsFor: 'scaling, rotation' stamp: ''!
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: '*Graphics-Files' stamp: ''!
writeOnMovie: file
	"Write just my bits on the file."
	self unhibernate.
	bits writeUncompressedOn: file! !

!Form methodsFor: 'color mapping' stamp: ''!
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 sum: [:a | a value]).
				cts := cts copyWithoutAll: cluster]].
		palette size = nColors or: [delta < 0.001]]
		whileFalse:
			[dist := palette size > nColors
				ifTrue: [dist + delta]
				ifFalse: [dist - delta].
			delta := delta / 2].
	^ palette collect: [:a | a key]! !

!Form methodsFor: 'converting' stamp: ''!
dimmed
	"Answer a dimmed variant of this form."
	"Form fromUser dimmed asMorph openInWorld"
	^ self dimmed: 0.5! !

!Form methodsFor: 'displaying' stamp: ''!
drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Refer to the comment in 
	DisplayMedium|drawLine:from:to:clippingBox:rule:mask:." 
	
	| dotSetter |
	"set up an instance of BitBlt for display"
	dotSetter := BitBlt 
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: anInteger
		destOrigin: beginPoint
		sourceOrigin: 0 @ 0
		extent: sourceForm extent
		clipRect: clipRect.
	dotSetter drawFrom: beginPoint to: endPoint! !

!Form methodsFor: 'file in/out' stamp: ''!
storeBitsOn:aStream base:anInteger
	bits do: [:word | 
		anInteger = 10
			ifTrue: [aStream space]
			ifFalse: [aStream crtab: 2].
		word storeOn: aStream base: anInteger].! !

!Form methodsFor: 'transitions' stamp: ''!
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: 'color mapping' stamp: ''!
mapColor: oldColor to: newColor
	"Make all pixels of the given color in this Form to the given new color."
	"Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution."

	| map |
	map := (Color cachedColormapFrom: self depth to: self depth) copy.
	map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth).
	(BitBlt toForm: self)
		sourceForm: self;
		sourceOrigin: 0@0;
		combinationRule: Form over;
		destX: 0 destY: 0 width: width height: height;
		colorMap: map;
		copyBits.! !

!Form methodsFor: 'private' stamp: ''!
setResourceBits: aForm
	"Private. Really. Used for setting the 'resource bits' when externalizing some form"
	bits := aForm.! !

!Form methodsFor: 'private' stamp: ''!
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: 'file in/out' stamp: ''!
storeBits:startBit to:stopBit on:aStream
	bits storeBits:startBit to:stopBit on:aStream.! !

!Form methodsFor: 'other' stamp: ''!
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"

	<primitive: 232>
	self primitiveFailed! !

!Form methodsFor: 'copying' stamp: ''!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm 
	"Make up a BitBlt table and copy the bits."

	(BitBlt  
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: rule
		destOrigin: destOrigin
		sourceOrigin: sourceRect origin
		extent: sourceRect extent
		clipRect: clipRect) copyBits! !

!Form methodsFor: '*Athens-Core' stamp: ''!
asAthensPaintOn: canvas 

	^ canvas surface createFormPaint: self! !

!Form methodsFor: 'color mapping' stamp: ''!
colormapFromARGB
	"Return a ColorMap mapping from canonical ARGB space into the receiver.
	Note: This version is optimized for image 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: '*Polymorph-Widgets' stamp: ''!
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: '*Morphic-Base' stamp: ''!
floodFillTolerance
	^ self class floodFillTolerance! !

!Form methodsFor: 'image manipulation' stamp: ''!
smear: dir distance: dist
	"Smear any black pixels in this form in the direction dir in Log N steps"
	| skew bb |
	bb := BitBlt destForm: self sourceForm: self fillColor: nil
		combinationRule: Form under destOrigin: 0@0 sourceOrigin: 0@0
		extent: self extent clipRect: self boundingBox.
	skew := 1.
	[skew < dist] whileTrue:
		[bb destOrigin: dir*skew; copyBits.
		skew := skew+skew]! !

!Form methodsFor: '*Morphic-Base-Support' stamp: ''!
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: '*FreeType-Graphics' stamp: ''!
ftSize

	^ (self bitsSize * 4) + 32! !

!Form methodsFor: 'testing' stamp: ''!
isBltAccelerated: ruleInteger for: sourceForm
	"Return true if the receiver can perform accelerated blts operations by itself"
	^false! !

!Form methodsFor: 'accessing' stamp: ''!
center
	"Note that offset is ignored here.  Are we really going to embrace offset?  "
	^ (width @ height) // 2! !

!Form methodsFor: '*Graphics-Files' stamp: ''!
resourceTag
	^'FORM'! !

!Form methodsFor: 'scaling, rotation' stamp: ''!
shrink: aRectangle by: scale 
	| scalePt |
	scalePt := scale asPoint.
	^ self magnify: aRectangle by: (1.0 / scalePt x asFloat) @ (1.0 / scalePt y asFloat)! !

!Form methodsFor: 'analyzing' stamp: ''!
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: 'color mapping' stamp: ''!
balancedPatternFor: aColor depth: aDepth 
	 
	"A generalization of bitPatternForDepth: as it exists.  Generates a 2x2 stipple of color.
	The topLeft and bottomRight pixel are closest approx to this color"
	| pv1 pv2 mask1 mask2 pv3 c |
	
	aColor isTransparent ifTrue:[  ^ Bitmap with: 0 ].

	(depth 
		between: 4
		and: 16) ifFalse: [ ^ aColor bitPatternForDepth: depth ].
	
	pv1 := aColor pixelValueForDepth: depth.
	"
	Subtract error due to pv1 to get pv2.
	pv2 := (self - (err1 := (Color colorFromPixelValue: pv1 depth: depth) - self))
						pixelValueForDepth: depth.
	Subtract error due to 2 pv1's and pv2 to get pv3.
	pv3 := (self - err1 - err1 - ((Color colorFromPixelValue: pv2 depth: depth) - self))
						pixelValueForDepth: depth.
"
	"Above two statements computed faster by the following..."
	pv2 := (c := aColor - ((Color 
			colorFromPixelValue: pv1
			depth: depth) - aColor)) pixelValueForDepth: depth.
	pv3 := c + (c - (Color 
				colorFromPixelValue: pv2
				depth: depth)) pixelValueForDepth: depth.

	"Return to a 2-word bitmap that encodes a 2x2 stipple of the given pixelValues."
	mask1 := #(
		#-
		#-
		#-
		16843009
		#-
		#-
		#-
		65537
		#-
		#-
		#-
		#-
		#-
		#-
		#-
		1
	) at: depth.	"replicates every other 4 bits"	"replicates every other 8 bits"	"replicates every other 16 bits"
	mask2 := #(
		#-
		#-
		#-
		269488144
		#-
		#-
		#-
		16777472
		#-
		#-
		#-
		#-
		#-
		#-
		#-
		65536
	) at: depth.	"replicates the other 4 bits"	"replicates the other 8 bits"	"replicates the other 16 bits"
	^  Bitmap 
		with: mask1 * pv1 + (mask2 * pv2)
		with: mask1 * pv3 + (mask2 * pv1).! !

!Form methodsFor: 'file in/out' stamp: ''!
store32To24HexBitsOn:aStream
	^self storeBits:20 to:0 on:aStream.! !

!Form methodsFor: 'copying' stamp: ''!
copy: destRectangle from: sourcePt in: sourceForm rule: rule 
	"Make up a BitBlt table and copy the bits."
	(BitBlt toForm: self)
		copy: destRectangle
		from: sourcePt in: sourceForm
		fillColor: nil rule: rule! !

!Form methodsFor: 'accessing' stamp: ''!
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: 'filling' stamp: ''!
eraseShape: bwForm
	"use bwForm as a mask to clear all pixels where bwForm has 1's"
	((BitBlt  destForm: self sourceForm: bwForm 
		fillColor: nil
		combinationRule: Form erase1bitShape	"Cut a hole in the picture with my mask"
		destOrigin: bwForm offset 
		sourceOrigin: 0@0
		extent: self extent clipRect: self boundingBox)
		colorMap: (Bitmap with: 0 with: 16rFFFFFFFF))
		copyBits.! !

!Form methodsFor: '*Morphic-Base' stamp: ''!
scaledByDisplayScaleFactor
	
	^ self scaledToSize: self extent * self currentWorld displayScaleFactor.! !

!Form methodsFor: 'file in/out' stamp: ''!
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: 'accessing' stamp: ''!
offset: aPoint

	offset := aPoint! !

!Form methodsFor: '*Morphic-Base' stamp: ''!
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: 'other' stamp: ''!
relativeTextAnchorPosition

	^nil		"so forms can be in TextAnchors"! !

!Form methodsFor: '*Graphics-Files' stamp: ''!
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: (EndianDetector isBigEndian ifTrue:[1] ifFalse: [0])].
	aStream nextNumber: 4 put: bits size.
	aStream nextPutAll: bits.! !

!Form methodsFor: 'filling' stamp: ''!
fill: aRectangle rule: anInteger fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by aForm 
	according to the rule anInteger."
	(BitBlt toForm: self)
		copy: aRectangle
		from: 0@0 in: nil
		fillColor: aForm rule: anInteger! !

!Form methodsFor: 'initialization' stamp: ''!
finish
	"If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."! !

!Form methodsFor: 'copying' stamp: ''!
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: 'transitions' stamp: ''!
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: 'file in/out' stamp: ''!
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: 'transitions' stamp: ''!
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: 'accessing' stamp: ''!
nativeDepth
	"Return the 'native' depth of the receiver, e.g., including the endianess"
	^depth! !

!Form methodsFor: 'file in/out' stamp: ''!
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: 'converting' stamp: ''!
colorReduced
	"Return a color-reduced ColorForm version of the receiver, if possible, or the receiver itself if not."

	| tally tallyDepth colorCount newForm cm oldPixelValues newFormColors nextColorIndex c |
	tally := self tallyPixelValues asArray.
	tallyDepth := (tally size log: 2) asInteger.
	colorCount := 0.
	tally do: [:n | n > 0 ifTrue: [colorCount := colorCount + 1]].
	(tally at: 1) = 0 ifTrue: [colorCount := colorCount + 1].  "include transparent"
	colorCount > 256 ifTrue: [^ self].  "cannot reduce"
	newForm := self formForColorCount: colorCount.

	"build an array of just the colors used, and a color map to translate
	 old pixel values to their indices into this color array"
	cm := Bitmap new: tally size.
	oldPixelValues := self colormapIfNeededForDepth: 32.
	newFormColors := Array new: colorCount.
	newFormColors at: 1 put: Color transparent.
	nextColorIndex := 2.
	2 to: cm size do: [:i |
		(tally at: i) > 0 ifTrue: [
			oldPixelValues 
				ifNil: [c := Color colorFromPixelValue: i - 1 depth: tallyDepth]
				ifNotNil: [c := Color colorFromPixelValue: (oldPixelValues at: i) depth: 32].
			newFormColors at: nextColorIndex put: c.
			cm at: i put: nextColorIndex - 1.  "pixel values are zero-based indices"
			nextColorIndex := nextColorIndex + 1]].

	"copy pixels into new ColorForm, mapping to new pixel values"
	newForm copyBits: self boundingBox
		from: self
		at: 0@0
		clippingBox: self boundingBox
		rule: Form over
		fillColor: nil
		map: cm.
	newForm colors: newFormColors.
	newForm offset: offset.
	^ newForm! !

!Form methodsFor: 'converting' stamp: ''!
asGrayScale
	"Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.)"
	| f32 srcForm result map bb grays |
	self depth = 32 ifFalse: [
		f32 := Form extent: width@height depth: 32.
		self displayOn: f32.
		^ f32 asGrayScale].
	self unhibernate.
	srcForm := Form extent: (width * 4)@height depth: 8.
	srcForm bits: bits.
	result := ColorForm extent: width@height depth: 8.
	map := Bitmap new: 256.
	2 to: 256 do: [:i | map at: i put: i - 1].
	map at: 1 put: 1.  "map zero pixel values to near-black"
	bb := (BitBlt toForm: result)
		sourceForm: srcForm;
		combinationRule: Form over;
		colorMap: map.
	0 to: width - 1 do: [:dstX |
		bb  sourceRect: (((dstX * 4) + 2)@0 extent: 1@height);
			destOrigin: dstX@0;
			copyBits].

	"final BitBlt to zero-out pixels that were truely transparent in the original"
	map := Bitmap new: 512.
	map at: 1 put: 16rFF.
	(BitBlt toForm: result)
		sourceForm: self;
		sourceRect: self boundingBox;
		destOrigin: 0@0;
		combinationRule: Form erase;
		colorMap: map;
		copyBits.
	
	grays := (0 to: 255) collect: [:brightness | Color gray: brightness asFloat / 255.0].
	grays at: 1 put: Color transparent.
	result colors: grays.
	^ result! !

!Form methodsFor: 'printing' stamp: ''!
printOn: aStream
    aStream
        nextPutAll: self class name;
        nextPut: $(; print: width;
        nextPut: $x; print: height;
        nextPut: $x; print: depth;
        nextPut: $).! !

!Form methodsFor: 'filling' stamp: ''!
fillFromXYColorBlock: colorBlock
	"General Gradient Fill.
	Supply relative x and y in [0.0 ... 1.0] to colorBlock,
	and paint each pixel with the color that comes back"
	| poker yRel xRel |
	poker := BitBlt bitPokerToForm: self.
	0 to: height-1 do:
		[:y | yRel := y asFloat / (height-1) asFloat.
		0 to: width-1 do:
			[:x |  xRel := x asFloat / (width-1) asFloat.
			poker pixelAt: x@y
				put: ((colorBlock value: xRel value: yRel) pixelWordForDepth: self depth)]]
"
 | d |
((Form extent: 100@20 depth: Display depth)
	fillFromXYColorBlock:
	[:x :y | d := 1.0 - (x - 0.5) abs - (y - 0.5) abs.
	Color r: d g: 0 b: 1.0-d]) display
"! !

!Form methodsFor: 'analyzing' stamp: ''!
innerPixelRectFor: pv orNot: not
	"Return a rectangle describing the smallest part of me that includes 
	all pixels of value pv.
	Note:  If orNot is true, then produce a copy that includes all pixels
	that are DIFFERENT from the supplied (background) value"

	| xTally yTally |
	xTally := self xTallyPixelValue: pv orNot: not.
	yTally := self yTallyPixelValue: pv orNot: not.
	^ ((xTally findFirst: [:t | t>0]) - 1) @ ((yTally findFirst: [:t | t>0]) - 1)
		corner:
			(xTally findLast: [:t | t>0])@(yTally findLast: [:t | t>0])! !

!Form methodsFor: 'converting' stamp: ''!
darker
	"Answer a darker variant of this form."
	
	^ self darker: 0.16! !

!Form methodsFor: 'accessing' stamp: ''!
offset
	^offset ifNil:[0@0]! !

!Form methodsFor: 'initialization' stamp: ''!
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: 'file in/out' stamp: ''!
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: 'analyzing' stamp: ''!
tallyPixelValuesInRect: destRect into: valueTable
	"Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable."

	(BitBlt toForm: self)
		sourceForm: self;  "src must be given for color map ops"
		sourceOrigin: 0@0;
		tallyMap: valueTable;
		combinationRule: 33;
		destRect: destRect;
		copyBits.
	^ valueTable

"
Move a little rectangle around the screen and print its tallies...
 | r tallies nonZero |
Cursor blank showWhile: [
[Sensor anyButtonPressed] whileFalse:
	[r := Sensor cursorPoint extent: 10@10.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil.
	tallies := (Display copy: r) tallyPixelValues.
	nonZero := (1 to: tallies size) select: [:i | (tallies at: i) > 0]
			thenCollect: [:i | (tallies at: i) -> (i-1)].
	nonZero printString , '          ' displayAt: 0@0.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]]
"! !

!Form methodsFor: 'testing' stamp: ''!
isExternalForm
	^false! !

!Form methodsFor: 'display box access' stamp: ''!
boundingBox
	^ Rectangle origin: 0 @ 0
			corner: width @ height! !

!Form methodsFor: 'testing' stamp: ''!
isTranslucent
	"Answer whether this form may be translucent"
	^self depth = 32! !

!Form methodsFor: 'file in/out' stamp: ''!
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: 'displaying' stamp: ''!
displayScaledOn: aForm
	"Display the receiver on aForm, scaling if necessary.
		Form fromUser displayScaledOn: Display.
	"
	self extent = aForm extent ifTrue:[^self displayOn: aForm].
	(WarpBlt toForm: aForm)
		sourceForm: self destRect: aForm boundingBox;
		combinationRule: Form paint;
		cellSize: 2;
		warpBits.! !

!Form methodsFor: 'color mapping' stamp: ''!
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: 'other' stamp: ''!
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: 'displaying' stamp: ''!
displayOnPort: port at: location
	port copyForm: self to: location rule: Form over! !

!Form methodsFor: '*Spec2-Morphic' stamp: ''!
asPresenter

	^ SpImagePresenter new 
		image: self;
		yourself! !

!Form methodsFor: 'analyzing' stamp: ''!
yTallyPixelValue: pv orNot: not
	"Return an array of the number of pixels with value pv by y-value.
	Note that if not is true, then this will tally those different from pv."
	| cm slice copyBlt countBlt |
	cm := self newColorMap.		"Map all colors but pv to zero"
	not ifTrue: [cm atAllPut: 1].		"... or all but pv to one"
	cm at: pv+1 put: 1 - (cm at: pv+1).
	slice := Form extent: width@1.
	copyBlt := (BitBlt destForm: slice sourceForm: self
				halftoneForm: nil combinationRule: Form over
				destOrigin: 0@0 sourceOrigin: 0@0 extent: slice width @ 1
				clipRect: slice boundingBox) colorMap: cm.
	countBlt := (BitBlt toForm: slice)
				fillColor: (Bitmap with: 0);
				destRect: (0@0 extent: slice extent);
				combinationRule: 32.
	^ (0 to: height-1) collect:
		[:y |
		copyBlt sourceOrigin: 0@y; copyBits.
		countBlt copyBits]! !

!Form methodsFor: 'converting' stamp: ''!
asCursorForm

	^ Form newFrom: self! !

!Form methodsFor: 'accessing' stamp: ''!
bitsSize
	| pixPerWord |
	depth ifNil: [ depth := 1 ].
	pixPerWord := 32 // self depth.
	^ width + pixPerWord - 1 // pixPerWord * height! !

!Form methodsFor: 'analyzing' stamp: ''!
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: 'filling' stamp: ''!
fillFromXColorBlock: colorBlock
	"Horizontal Gradient Fill.
	Supply relative x in [0.0 ... 1.0] to colorBlock,
	and paint each pixel with the color that comes back"
	| xRel |
	0 to: width-1 do:
		[:x |  xRel := x asFloat / (width-1) asFloat.
		self fill: (x@0 extent: 1@height) 
			fillColor: (colorBlock value: xRel)]
"
((Form extent: 100@100 depth: Display depth)
	fillFromXColorBlock: [:x | Color r: x g: 0.0 b: 0.5]) display
"! !

!Form methodsFor: 'bordering' stamp: ''!
borderWidth: anInteger fillColor: aMask
	"Set the width of the border for the receiver to be anInteger and paint it 
	using aMask as the border color."

	self border: self boundingBox width: anInteger fillColor: aMask! !

!Form methodsFor: 'testing' stamp: ''!
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: 'scaling, rotation' stamp: ''!
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: 'pixel access' stamp: ''!
pixelValueAt: aPoint 
	"Return the raw pixel value at the given point. This pixel value depends on the receiver's depth. Typical clients use colorAt: to get a Color.  "

	^ (BitBlt bitPeekerFromForm: self) pixelAt: aPoint! !

!Form methodsFor: 'converting' stamp: ''!
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: 'color mapping' stamp: ''!
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: 'accessing' stamp: ''!
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: 'scaling, rotation' stamp: ''!
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: 'accessing' stamp: ''!
depth
	^ depth < 0 ifTrue:[0-depth] ifFalse:[depth]! !

!Form methodsFor: 'converting' stamp: ''!
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: 'filling' stamp: ''!
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: 'converting' stamp: ''!
invertedAndAlphaMultiplied
	^ (self asFormOfDepth: 32) collectColors: [ :c |
		| a |
		a := c alpha.
		Color r: (1.0 - c red) * a g: (1.0 - c green) * a b: (1.0 - c blue) * a alpha: a
	]! !

!Form methodsFor: 'converting' stamp: ''!
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: 'display box access' stamp: ''!
computeBoundingBox
	^ Rectangle origin: 0 @ 0
			corner: width @ height! !

!Form methodsFor: 'file in/out' stamp: ''!
readBitsFrom: aBinaryStream
	
	bits := Bitmap newFromStream: aBinaryStream.
	bits size = self bitsSize ifFalse: [self error: 'wrong bitmap size; bad Form file?'].
	^ self! !

!Form methodsFor: 'image manipulation' stamp: ''!
replaceColor: oldColor withColor: newColor
	"Replace one color with another everywhere is this form"

	| cm newInd target ff |
	self depth = 32
		ifTrue: [cm := (Color  cachedColormapFrom: 16 to: 32) copy]
		ifFalse: [cm := Bitmap new: (1 bitShift: (self depth min: 15)).
				1 to: cm size do: [:i | cm at: i put: i - 1]].
	newInd := newColor pixelValueForDepth: self depth.
	cm at: (oldColor pixelValueForDepth: (self depth min: 16))+1 put: newInd.
	target := newColor isTransparent 
		ifTrue: [ff := Form extent: self extent depth: depth.
			ff fillWithColor: newColor.  ff]
		ifFalse: [self].
	(BitBlt toForm: target)
		sourceForm: self;
		sourceOrigin: 0@0;
		combinationRule: Form paint;
		destX: 0 destY: 0 width: width height: height;
		colorMap: cm;
		copyBits.
	newColor = Color transparent 
		ifTrue: [target displayOn: self].! !

!Form methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
setAsBackground
	"Set this form as a background image."
	| world |
	world := self currentWorld.
	world backgroundMorph: ((Smalltalk ui theme builder newAlphaImage: self help: nil) autoSize: false;
			 layout: #scaled;
			 lock)! !

!Form methodsFor: '*Morphic-Base' stamp: ''!
iconOrThumbnailOfSize: aNumberOrPoint 
	"Answer an appropiate form to represent the receiver"
	^ self scaledIntoFormOfSize: aNumberOrPoint! !

!Form methodsFor: '*Morphic-Core' stamp: ''!
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: 'converting' stamp: ''!
alphaMultiplied
	^ (self asFormOfDepth: 32) collectColors: [ :c |
		| a |
		a := c alpha.
		Color r: c red * a g: c green * a b: c blue * a alpha: a
	]! !

!Form methodsFor: 'file in/out' stamp: ''!
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: 'accessing' stamp: ''!
bits
	"Answer the receiver's Bitmap containing its bits."

	^ bits! !

!Form methodsFor: 'copying' stamp: ''!
deepCopy

	^ self shallowCopy
		bits: bits copy;
		offset: offset copy! !

!Form methodsFor: 'displaying' stamp: ''!
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: 'filling' stamp: ''!
findShapeAroundSeedBlock: seedBlock
	"Build a shape that is black in any region marked by seedBlock. 
	SeedBlock will be supplied a form, in which to blacken various
	pixels as 'seeds'.  Then the seeds are smeared until 
	there is no change in the smear when it fills the region, ie,
	when smearing hits a black border and thus goes no further."
	| smearForm previousSmear all count smearPort |
	self assert: [self depth > 1]. "Only meaningful for B/W forms."
	all := self boundingBox.
	smearForm := Form extent: self extent.
	smearPort := BitBlt toForm: smearForm.
	seedBlock value: smearForm.		"Blacken seeds to be smeared"
	smearPort copyForm: self to: 0 @ 0 rule: Form erase.  "Clear any in black"
	previousSmear := smearForm deepCopy.
	count := 1.
	[count = 10 and:   "check for no change every 10 smears"
		[count := 1.
		previousSmear copy: all from: 0 @ 0 in: smearForm rule: Form reverse.
		previousSmear isAllWhite]]
		whileFalse: 
			[smearPort copyForm: smearForm to: 1 @ 0 rule: Form under.
			smearPort copyForm: smearForm to: -1 @ 0 rule: Form under.
			"After horiz smear, trim around the region border"
			smearPort copyForm: self to: 0 @ 0 rule: Form erase.
			smearPort copyForm: smearForm to: 0 @ 1 rule: Form under.
			smearPort copyForm: smearForm to: 0 @ -1 rule: Form under.
			"After vert smear, trim around the region border"
			smearPort copyForm: self to: 0 @ 0 rule: Form erase.
			count := count+1.
			count = 9 ifTrue: "Save penultimate smear for comparison"
				[previousSmear copy: all from: 0 @ 0 in: smearForm rule: Form over]].
	"Now paint the filled region in me with aHalftone"
	^ smearForm! !

!Form methodsFor: 'scaling, rotation' stamp: ''!
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 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: 'private' stamp: ''!
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: 'scaling, rotation' stamp: ''!
rotateBy: deg
	"Rotate the receiver by the indicated number of degrees."
	"rot is the destination form, bit enough for any angle."

	^ self rotateBy: deg smoothing: 1
"
 | a f |  f := Form fromDisplay: (0@0 extent: 200@200).  a := 0.
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
		rotateBy: (a := a+5)) display].
f display
"! !

!Form methodsFor: 'pixel access' stamp: ''!
pixelValueAt: aPoint put: pixelValue
	"Store the given raw pixel value at the given point. Typical clients use colorAt:put: to store a color. "

	(BitBlt bitPokerToForm: self) pixelAt: aPoint put: pixelValue.! !

!Form methodsFor: '*Graphics-Files' stamp: ''!
readNativeResourceFrom: byteStream
	| img |
	img := [ ImageReadWriter formFromStream: byteStream ]
		on: Error
		do: [ :ex | ^ nil ].
	(img isColorForm and: [ self isColorForm ])
		ifTrue: [ | cc |
			cc := img colors.
			img colors: nil.
			img displayOn: self.
			img colors: cc ]
		ifFalse: [ img displayOn: self ]! !

!Form methodsFor: 'transitions' stamp: ''!
fadeImageHor: otherImage at: topLeft
	"Display fadeImageHor: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: (0@(mask height//2-i) extent: mask width@(i*2)) fillColor: Color black.
		(i*2) <= mask width]! !

!Form methodsFor: 'converting' stamp: ''!
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: 'transitions' stamp: ''!
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: 'copying' stamp: ''!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm map: map
	"Make up a BitBlt table and copy the bits.  Use a colorMap."

	((BitBlt  
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: rule
		destOrigin: destOrigin
		sourceOrigin: sourceRect origin
		extent: sourceRect extent
		clipRect: clipRect) colorMap: map) copyBits! !

!Form methodsFor: 'bordering' stamp: ''!
borderWidth: anInteger color: aMask
	"Set the width of the border for the receiver to be anInteger and paint it 
	using aMask as the border color."

	self border: self boundingBox width: anInteger fillColor: aMask! !

!Form methodsFor: 'file in/out' stamp: ''!
writeBitsOn: file
	bits writeOn: file! !

!Form methodsFor: '*Graphics-Files' stamp: ''!
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 = EndianDetector isBigEndian 
		ifFalse: 
			[Bitmap 
				swapBytesIn: bits
				from: 1
				to: bits size]! !

!Form methodsFor: 'copying' stamp: ''!
blankCopyOf: aRectangle scaledBy: scale

        ^ self class extent: (aRectangle extent * scale) truncated depth: depth! !

!Form methodsFor: 'image manipulation' stamp: ''!
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: 'file in/out' stamp: ''!
storeHexBitsOn:aStream
	^self storeBits:28 to:0 on:aStream.! !

!Form methodsFor: 'file in/out' stamp: ''!
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: 'other' stamp: ''!
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: '*Polymorph-Widgets-Themes' stamp: ''!
mergeWith: aForm at: aPoint
	| mergedForm |

	mergedForm := self deepCopy.
	mergedForm getCanvas 
		translucentImage: aForm 
		at: aPoint. 
		
	^ mergedForm! !

!Form methodsFor: 'accessing' stamp: ''!
bits: aBitmap 
	"Reset the Bitmap containing the receiver's bits."

	bits := aBitmap! !

!Form methodsFor: 'filling' stamp: ''!
fillFromYColorBlock: colorBlock
	"Vertical Gradient Fill.
	Supply relative y in [0.0 ... 1.0] to colorBlock,
	and paint each pixel with the color that comes back"
	| yRel |
	0 to: height-1 do:
		[:y |  yRel := y asFloat / (height-1) asFloat.
		self fill: (0@y extent: width@1) 
			fillColor: (colorBlock value: yRel)]
"
((Form extent: 100@100 depth: Display depth)
	fillFromYColorBlock: [:y | Color r: y g: 0.0 b: 0.5]) display
"! !

!Form methodsFor: 'color mapping' stamp: ''!
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: 'analyzing' stamp: ''!
primCountBits
	"Count the non-zero pixels of this form."
	self depth > 8 ifTrue:
		[^(self asFormOfDepth: 8) primCountBits].
	^ (BitBlt toForm: self)
		fillColor: (Bitmap with: 0);
		destRect: (0@0 extent: width@height);
		combinationRule: 32;
		copyBits! !

!Form methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionForm
	<inspectorPresentationOrder: 0 title: 'Form'>
	
	^ SpMorphPresenter new 
		morph: self asMorph;
		yourself! !

!Form methodsFor: 'color mapping' stamp: ''!
balancedPatternFor: aColor
	"Return the pixel word for representing the given color on the receiver"

	^ self hasNonStandardPalette
		ifTrue: [ self bitPatternFor: aColor ]
		ifFalse: [ self balancedPatternFor: aColor depth: self depth ]! !

!Form methodsFor: 'displaying' stamp: ''!
displayResourceFormOn: aForm
	"a special display method for blowing up resource thumbnails"
	
	self extent = aForm extent
		ifTrue: [ ^ self displayOn: aForm ].

	"We've got no bilinear interpolation. Use WarpBlt instead"
	(WarpBlt toForm: aForm)
		sourceForm: self destRect: aForm boundingBox;
		combinationRule: 3;
		cellSize: 2;
		warpBits.! !

!Form methodsFor: 'pixel access' stamp: ''!
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: 'initialization' stamp: ''!
shutDown
	"The system is going down. Try to preserve some space"
	self hibernate! !

!Form methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
mergeWith: aForm
	^ self mergeWith: aForm at: 0@0! !

!Form methodsFor: 'converting' stamp: ''!
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: '*Morphic-Base' stamp: ''!
asAlphaImageMorph

	^ AlphaImageMorph new image: self! !

!Form methodsFor: '*Morphic-Core' stamp: ''!
getCanvas
	"Return a Canvas that can be used to draw onto the receiver"
	^self defaultCanvasClass on: self! !

!Form methodsFor: 'accessing' stamp: ''!
depth: bitsPerPixel
	(bitsPerPixel > 32 or:
		[(bitsPerPixel bitAnd: bitsPerPixel-1) ~= 0])
		ifTrue: [self error: 'bitsPerPixel must be 1, 2, 4, 8, 16 or 32'].
	depth := bitsPerPixel! !

!Form methodsFor: 'file in/out' stamp: ''!
storeOn: aStream

	self storeOn: aStream base: 10! !

!Form methodsFor: 'displaying' stamp: ''!
paintBits: sourceForm at: destOrigin translucent: factor
	"Make up a BitBlt table and copy the bits with the given colorMap."
	(BitBlt destForm: self
		sourceForm: sourceForm
		halftoneForm: nil
		combinationRule: 31
		destOrigin: destOrigin
		sourceOrigin: 0@0
		extent: sourceForm extent
		clipRect: self boundingBox)
		copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255)
"
 | f f2 f3 | f := Form fromUser. f replaceColor: f peripheralColor withColor: Color transparent.
f2 := Form fromDisplay: (0@0 extent: f extent). f3 := f2 deepCopy.
0.0 to: 1.0 by: 1.0/32 do:
	[:t | f3 := f2 deepCopy. f3 paintBits: f at: 0@0 translucent: t.
	f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait].
"! !

!Form methodsFor: 'scaling, rotation' stamp: ''!
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 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: ''!
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 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: ''!
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 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: 'transitions' stamp: ''!
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: 'file in/out' stamp: ''!
storeOn: aStream base: anInteger 
	"Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original."

	self unhibernate.
	aStream nextPut: $(.
	aStream nextPutAll: self species name.
	aStream crtab: 1.
	aStream nextPutAll: 'extent: '.
	self extent printOn: aStream.
	aStream crtab: 1.
	aStream nextPutAll: 'depth: '.
	self depth printOn: aStream.
	aStream crtab: 1.
	aStream nextPutAll: 'fromArray: #('.
	self storeBitsOn:aStream base:anInteger.
	aStream nextPut: $).
	aStream crtab: 1.
	aStream nextPutAll: 'offset: '.
	self offset printOn: aStream.
	aStream nextPut: $).! !

!Form methodsFor: 'copying' stamp: ''!
copyBits: sourceForm at: destOrigin translucent: factor
	"Make up a BitBlt table and copy the bits with the given colorMap."
	(BitBlt  
		destForm: self
		sourceForm: sourceForm
		halftoneForm: nil
		combinationRule: 30
		destOrigin: destOrigin
		sourceOrigin: 0@0
		extent: sourceForm extent
		clipRect: self boundingBox)
		copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255)
"
 | f f2 f3 | f := Form fromUser. f2 := Form fromDisplay: (0@0 extent: f extent). f3 := f2 deepCopy.
0.0 to: 1.0 by: 1.0/32 do:
	[:t | f3 := f2 deepCopy. f3 copyBits: f at: 0@0 translucent: t.
	f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait].
"! !

!Form methodsFor: 'analyzing' stamp: ''!
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' stamp: ''!
pixelCompare: aRect with: otherForm at: otherLoc
	"Compare the selected bits of this form (those within aRect) against
	those in a similar rectangle of otherFrom.  Return the sum of the
	absolute value of the differences of the color values of every pixel.
	Obviously, this is most useful for rgb (16- or 32-bit) pixels but,
	in the case of 8-bits or less, this will return the sum of the differing
	bits of the corresponding pixel values (somewhat less useful)"
	| pixPerWord temp |
	pixPerWord := 32//self depth.
	(aRect left\\pixPerWord = 0 and: [aRect right\\pixPerWord = 0]) ifTrue:
		["If word-aligned, use on-the-fly difference"
		^ (BitBlt toForm: self) copy: aRect from: otherLoc in: otherForm
				fillColor: nil rule: 32].
	"Otherwise, combine in a word-sized form and then compute difference"
	temp := self copy: aRect.
	temp copy: aRect from: otherLoc in: otherForm rule: 21.
	^ (BitBlt toForm: temp) copy: aRect from: otherLoc in: nil
				fillColor: (Bitmap with: 0) rule: 32
"  Dumb example prints zero only when you move over the original rectangle...
 | f diff | f := Form fromUser.
[Sensor anyButtonPressed] whileFalse:
	[diff := f pixelCompare: f boundingBox
		with: Display at: Sensor cursorPoint.
	diff printString , '        ' displayAt: 0@0]
"! !

!Form methodsFor: 'initialization' stamp: ''!
fromDisplay: aRectangle 
	"Create a virtual bit map from a user specified rectangular area on the 
	display screen. Reallocates bitmap only if aRectangle ~= the receiver's 
	extent."

	(width = aRectangle width and: [height = aRectangle height])
		ifFalse: [self setExtent: aRectangle extent depth: depth].
	self
		copyBits: (aRectangle origin extent: self extent)
		from: Display
		at: 0 @ 0
		clippingBox: self boundingBox
		rule: Form over
		fillColor: nil! !

!Form methodsFor: 'converting' stamp: ''!
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: 'color mapping' stamp: ''!
mapColors: oldColorBitsCollection to: newColorBits
	"Make all pixels of the given color in this Form to the given new color."
	"Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution."

	| map |
	self depth < 16
		ifTrue: [map := (Color cachedColormapFrom: self depth to: self depth) copy]
		ifFalse: [
			"use maximum resolution color map"
			"source is 16-bit or 32-bit RGB; use colormap with 5 bits per color component"
			map := Color computeRGBColormapFor: self depth bitsPerColor: 5].
	oldColorBitsCollection do:[ :oldColor | map at: oldColor put: newColorBits].

	(BitBlt toForm: self)
		sourceForm: self;
		sourceOrigin: 0@0;
		combinationRule: Form over;
		destX: 0 destY: 0 width: width height: height;
		colorMap: map;
		copyBits.! !

!Form methodsFor: 'color mapping' stamp: ''!
newColorMap 
	"Return an uninitialized color map array appropriate to this Form's depth."

	^ Bitmap new: (1 bitShift: (self depth min: 15))! !

!Form methodsFor: '*Morphic-Base' stamp: ''!
asMorph
	^ImageMorph new form: self! !

!Form methodsFor: '*Graphics-Files' stamp: ''!
writePNGFileNamed: fileName  
	PNGReadWriter putForm: self onFileNamed: fileName! !

!Form methodsFor: 'other' stamp: ''!
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: '*Morphic-Core' stamp: ''!
borderWidth: anInteger 
	"Set the width of the border for the receiver to be anInteger and paint it 
	using black as the border color."

	self 
		border: self boundingBox 
		width: anInteger 
		fillColor: Smalltalk ui theme borderColor! !

!Form methodsFor: 'color mapping' stamp: ''!
makeBWForm: foregroundColor
	"Map this form into a B/W form with 1's in the foreground regions."
	| bwForm map |
	bwForm := Form extent: self extent.
	map := self newColorMap.  "All non-foreground go to 0's"
	map at: (foregroundColor indexInMap: map) put: 1.
	bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map.
	^ bwForm! !

!Form methodsFor: 'pixel access' stamp: ''!
colorAt: aPoint
	"Return the color in the pixel at the given point.  "

	^ Color 
		colorFromPixelValue: (self pixelValueAt: aPoint)
		depth: self depth! !

!Form methodsFor: 'transitions' stamp: ''!
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: 'file in/out' stamp: ''!
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: 'accessing' stamp: ''!
height
	^ height! !

!Form methodsFor: 'color mapping' stamp: ''!
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: 'analyzing' stamp: ''!
rectangleEnclosingPixelsNotOfColor: aColor
	"Answer the smallest rectangle enclosing all the pixels of me that are different from the given color. Useful for extracting a foreground graphic from its background."

	| cm slice copyBlt countBlt top bottom newH left right |
	"map the specified color to 1 and all others to 0"
	cm := Bitmap new: (1 bitShift: (self depth min: 15)).
	cm primFill: 1.
	cm at: (aColor indexInMap: cm) put: 0.

	"build a 1-pixel high horizontal slice and BitBlts for counting pixels of interest"
	slice := Form extent: width @ 1 depth: 1.
	copyBlt := (BitBlt toForm: slice)
		sourceForm: self;
		combinationRule: Form over;
		destX: 0
			destY: 0
			width: width
			height: 1;
		colorMap: cm.
	countBlt := (BitBlt toForm: slice)
		fillColor: (Bitmap with: 0);
		destRect: (0 @ 0 extent: slice extent);
		combinationRule: 32.

	"scan in from top and bottom"
	top := (0 to: height)
		detect: [ :y | 
			copyBlt
				sourceOrigin: 0 @ y;
				copyBits.
			countBlt copyBits > 0 ]
		ifNone: [ ^ 0 @ 0 extent: 0 @ 0 ].
	bottom := (height - 1 to: top by: -1)
		detect: [ :y | 
			copyBlt
				sourceOrigin: 0 @ y;
				copyBits.
			countBlt copyBits > 0 ].

	"build a 1-pixel wide vertical slice and BitBlts for counting pixels of interest"
	newH := bottom - top + 1.
	slice := Form extent: 1 @ newH depth: 1.
	copyBlt := (BitBlt toForm: slice)
		sourceForm: self;
		combinationRule: Form over;
		destX: 0
			destY: 0
			width: 1
			height: newH;
		colorMap: cm.
	countBlt := (BitBlt 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: 'initialization' stamp: ''!
swapEndianness
	"Swap from big to little endian pixels and vice versa"
	depth := 0 - depth.! !

!Form methodsFor: 'filling' stamp: ''!
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: 'pixel access' stamp: ''!
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: 'other' stamp: ''!
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: 'testing' stamp: ''!
isStatic

	^false! !

!Form methodsFor: 'bordering' stamp: ''!
border: rect width: borderWidth rule: rule fillColor: fillColor
        "Paint a border whose rectangular area is defined by rect. The
width of the border of each side is borderWidth. Uses fillColor for drawing
the border."
        | blt |
        blt := (BitBlt toForm: self) combinationRule: rule; fillColor: fillColor.
        blt sourceOrigin: 0@0.
        blt destOrigin: rect origin.
        blt width: rect width; height: borderWidth; copyBits.
        blt destY: rect corner y - borderWidth; copyBits.
        blt destY: rect origin y + borderWidth.
        blt height: rect height - borderWidth - borderWidth; width:
borderWidth; copyBits.
        blt destX: rect corner x - borderWidth; copyBits! !

!Form methodsFor: 'scaling, rotation' stamp: ''!
magnifyBy: scale 
	"Answer a Form created as a scaling of the receiver.
	Scale may be a Float, and may be greater or less than 1.0."

	^ self magnify: self boundingBox by: scale
			smoothing: (scale < 1 ifTrue: [2] ifFalse: [1])! !

!Form methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
mergeBottomRightWith: aForm
	^ self 
		mergeWith: aForm 
		at: self extent - aForm extent! !

!Form methodsFor: 'color mapping' stamp: ''!
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: 'transitions' stamp: ''!
fadeImage: otherImage at: topLeft
	indexAndMaskDo: indexAndMaskBlock
	
	"This fade uses halftones as a blending hack.
	Zeros in the halftone produce the original image (self), and 
	ones in the halftone produce the 'otherImage'.
	IndexAndMaskBlock gets evaluated prior to each cycle,
	and the resulting boolean determines whether to continue cycling."
	| index imageRect maskForm resultForm |
	imageRect := otherImage boundingBox.
	resultForm := self copy: (topLeft extent: imageRect extent).
	maskForm := Form extent: 32@32.
	index := 0.

	[indexAndMaskBlock value: (index := index+1) value: maskForm]
	whileTrue:
		[maskForm reverse.
		resultForm copyBits: imageRect from: resultForm at: 0@0
			clippingBox: imageRect rule: Form over fillColor: maskForm.
		maskForm reverse.
		resultForm copyBits: imageRect from: otherImage at: 0@0
			clippingBox: imageRect rule: Form under fillColor: maskForm.
		self copyBits: imageRect from: resultForm at: topLeft
				clippingBox: self boundingBox rule: Form over fillColor: nil ]! !

!Form methodsFor: 'accessing' stamp: ''!
displayScreen
	"Return the display screen the receiver is allocated on. 
	Forms in general are internal and not allocated on any particular display."
	^ nil! !

!Form methodsFor: 'testing' stamp: ''!
isForm
	^true! !

!Form methodsFor: 'private' stamp: ''!
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: '*Graphics-Files' stamp: ''!
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: 'analyzing' stamp: ''!
xTallyPixelValue: pv orNot: not
	"Return an array of the number of pixels with value pv by x-value.
	Note that if not is true, then this will tally those different from pv."
	| cm slice countBlt copyBlt |
	cm := self newColorMap.		"Map all colors but pv to zero"
	not ifTrue: [cm atAllPut: 1].		"... or all but pv to one"
	cm at: pv+1 put: 1 - (cm at: pv+1).
	slice := Form extent: 1@height.
	copyBlt := (BitBlt destForm: slice sourceForm: self
				halftoneForm: nil combinationRule: Form over
				destOrigin: 0@0 sourceOrigin: 0@0 extent: 1 @ slice height
				clipRect: slice boundingBox) colorMap: cm.
	countBlt := (BitBlt toForm: slice)
				fillColor: (Bitmap with: 0);
				destRect: (0@0 extent: slice extent);
				combinationRule: 32.
	^ (0 to: width-1) collect:
		[:x |
		copyBlt sourceOrigin: x@0; copyBits.
		countBlt copyBits]! !

!Form methodsFor: 'copying' stamp: ''!
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: 'testing' stamp: ''!
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 Pharo RGBA layout
	at the receiver's depth."
	^false! !

!Form methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."
	^ self! !

!Form methodsFor: 'copying' stamp: ''!
copyBits: sourceRect from: sourceForm at: destOrigin colorMap: map 
	"Make up a BitBlt table and copy the bits with the given colorMap."
	((BitBlt  
		destForm: self
		sourceForm: sourceForm
		halftoneForm: nil
		combinationRule: Form over
		destOrigin: destOrigin
		sourceOrigin: sourceRect origin
		extent: sourceRect extent
		clipRect: self boundingBox) colorMap: map) copyBits! !

!Form methodsFor: 'transitions' stamp: ''!
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: '*Graphics-Files' stamp: ''!
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: 'private' stamp: ''!
initFromArray: array
	"Fill the bitmap from array.  If the array is shorter,
	then cycle around in its contents until the bitmap is filled."
	| ax aSize array32 i j word16 |
	ax := 0.
	aSize := array size.
	aSize > bits size ifTrue:
		["backward compatibility with old 16-bit bitmaps and their forms"
		array32 := Array new: height * (width + 31 // 32).
		i := j := 0.
		1 to: height do:
			[:y | 1 to: width+15//16 do:
				[:x16 | word16 := array at: (i := i + 1).
				x16 odd ifTrue: [array32 at: (j := j+1) put: (word16 bitShift: 16)]
						ifFalse: [array32 at: j put: ((array32 at: j) bitOr: word16)]]].
		^ self initFromArray: array32].
	1 to: bits size do:
		[:index |
		(ax := ax + 1) > aSize ifTrue: [ax := 1].
		bits at: index put: (array at: ax)]! !

!Form methodsFor: 'scaling, rotation' stamp: ''!
magnify: aRectangle by: scale 
	"Answer a Form created as a scaling of the receiver.
	Scale may be a Float, and may be greater or less than 1.0."
	^ self magnify: aRectangle by: scale smoothing: 1

"Dynamic test...
[Sensor anyButtonPressed] whileFalse:
	[(Display magnify: (Sensor cursorPoint extent: 31@41) by: 5@3) display]
"
"Scaling test...
| f cp | f := Form fromDisplay: (Rectangle originFromUser: 100@100).
Display restoreAfter: [Sensor waitNoButton.
[Sensor anyButtonPressed] whileFalse:
	[cp := Sensor cursorPoint.
	(f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent) display]]
"
"Consistency test...
 | f f2 p | [Sensor anyButtonPressed] whileFalse:
	[f := Form fromDisplay: ((p := Sensor cursorPoint) extent: 31@41).
	Display fillBlack: (p extent: 31@41).
	f2 := f magnify: f boundingBox by: 5@3.
	(f2 shrink: f2 boundingBox by: 5@3) displayAt: p]
"! !

!Form methodsFor: 'converting' stamp: ''!
withAlphaExtractedFromSubpixelRendering
	^ (self asFormOfDepth: 32) collectColors: [ :c |
		| r g b a|
		r := c red.
		g := c green.
		b := c blue.
		a := c alpha.
		a := ((r max: g) max: b) * a.
		
		Color r: r g: g b: b alpha: a
	]! !

!Form methodsFor: 'testing' stamp: ''!
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 class methodsFor: '*Graphics-Files-FileRegistry' stamp: ''!
fileReaderServicesForFile: fullName suffix: suffix
	<fileService>

	^((ImageReadWriter allTypicalFileExtensions add: '*'; add: 'form'; yourself)
		includes: suffix)
		ifTrue: [ self services ]
		ifFalse: [#()]! !

!Form class methodsFor: 'instance creation' stamp: ''!
dotOfSize: diameter
	"Create a form which contains a round black dot."
	| radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx |
	radius := diameter//2.
	form := self extent: diameter@diameter offset: (0@0) - (radius@radius).	
	bb := (BitBlt toForm: form)
		sourceX: 0; sourceY: 0;
		combinationRule: Form over;
		fillColor: Color black.
	rect := form boundingBox.
	centerX := rect center x.
	centerY := rect center y.
	centerYBias := rect height odd ifTrue: [0] ifFalse: [1].
	centerXBias := rect width odd ifTrue: [0] ifFalse: [1].
	radiusSquared := (rect height asFloat / 2.0) squared - 0.01.
	xOverY := rect width asFloat / rect height asFloat.
	maxy := rect height - 1 // 2.

	"First do the inner fill, and collect x values"
	0 to: maxy do:
		[:dy |
		dx := ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated.
		bb	destX: centerX - centerXBias - dx
			destY: centerY - centerYBias - dy
			width: dx + dx + centerXBias + 1
			height: 1;
			copyBits.
		bb	destY: centerY + dy;
			copyBits].
	^ form
"
Time millisecondsToRun:
	[1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]]
"! !

!Form class methodsFor: 'mode constants' stamp: ''!
reverse
	"Answer the integer denoting mode reverse."

	^6! !

!Form class methodsFor: 'instance creation' stamp: ''!
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: '*Graphics-Files-FileRegistry' stamp: ''!
setBackgroundFromImageFileNamed: aFileName

	(self fromFileNamed: aFileName) setAsBackground! !

!Form class methodsFor: '*Graphics-Files' stamp: ''!
fromBase64String: aBase64EncodedString
	"Convenient method to instantiate a Form from an image content encoded in base64 (used to store image data in a method for example".
	"Encoded string can be obtained with:
	(Base64MimeConverter mimeEncode: 'picture.png' asFileReference binaryReadStream) contents."
	
	^ self fromBinaryStream: aBase64EncodedString base64Decoded asByteArray readStream! !

!Form class methodsFor: 'settings' stamp: ''!
floodFillTolerance: aFloat
	(aFloat >= 0.0 and: [aFloat < 0.3])
		ifTrue: [FloodFillTolerance := aFloat]
		ifFalse: [FloodFillTolerance := 0.0]! !

!Form class methodsFor: '*Graphics-Files-FileRegistry' stamp: ''!
services
	"Defines what options are available when a user drags and drop an image file (jpeg, png...) onto the pharo image. These options are defined by methods with the #formService pragma on this class."
	| services |
	services := OrderedCollection new.
	(Pragma allNamed: #formService in: self class) do: [:pragma | 
		pragma method selector isUnary ifTrue: [  
			services add: (self perform: (pragma method selector))
		]
	].
	^ services asArray.! !

!Form class methodsFor: 'instance creation' stamp: ''!
fromDisplay: aRectangle using: oldForm
	"Like fromDisplay: only if oldForm is the right size, copy into it and answer it instead."

	^ (oldForm ~~ nil and: [ oldForm extent = aRectangle extent ])
		ifTrue: [ oldForm fromDisplay: aRectangle.
			oldForm ]
		ifFalse: [ self fromDisplay: aRectangle ]! !

!Form class methodsFor: 'mode constants' stamp: ''!
under
	"Answer the integer denoting mode under."

	^7! !

!Form class methodsFor: 'mode constants' stamp: ''!
paint
	"Answer the integer denoting the 'paint' combination rule."

	^25! !

!Form class methodsFor: '*Graphics-Files' stamp: ''!
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 new DisplayObject writeOn: formats, JPEG, and PCX. Return nil if the file could not be read or was of an unrecognized format."

	| firstByte |
	firstByte := aBinaryStream peek.
	firstByte = 1 ifTrue: [ ^ self error: 'old ST80 format not supported' ].
	firstByte = 2 ifTrue: [ ^ self new readFrom: aBinaryStream ].

	"Try for JPG, GIF, or PCX..."
	"Note: The following call closes the stream."
	^ ImageReadWriter formFromStream: aBinaryStream! !

!Form class methodsFor: '*Graphics-Files-FileRegistry' stamp: ''!
serviceOpenImageInWindow
	"Answer a service for opening a graphic in a window"
	<formService>
	^ SimpleServiceEntry 
		provider: self 
		label: 'Open graphic in a window'
		selector: #openImageInWindow:
		description: 'Open a graphic file in a window'
		buttonLabel: 'Open'! !

!Form class methodsFor: 'mode constants' stamp: ''!
over
	"Answer the integer denoting mode over."

	^3! !

!Form class methodsFor: 'instance creation' stamp: ''!
fromDisplay: aRectangle 
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen defined by aRectangle."

	^ (self extent: aRectangle extent depth: Display depth)
		fromDisplay: aRectangle! !

!Form class methodsFor: 'mode constants' stamp: ''!
oldPaint
	"Answer the integer denoting the 'paint' combination rule."

	^16! !

!Form class methodsFor: 'instance creation' stamp: ''!
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: ''!
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: ''!
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: ''!
fromUser: gridPoint
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen designated by the user. The grid for selecting an area is 
	aPoint. Ensures that the returned form has positive extent."
	| rect |
	rect := Rectangle fromUser: gridPoint.
	^ self fromDisplay: (rect origin extent: (rect extent max: gridPoint))! !

!Form class methodsFor: '*Graphics-Files-FileRegistry' stamp: ''!
serviceImageAsBackground
	"Answer a service for setting the desktop background from a given graphical file's contents"
	<formService>
	^ 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: 'instance creation' stamp: ''!
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: ''!
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: 'initialize-release' stamp: ''!
initialize
	SessionManager default registerGuiClassNamed: self name! !

!Form class methodsFor: 'mode constants' stamp: ''!
oldErase1bitShape
	"Answer the integer denoting mode erase."

	^ 17! !

!Form class methodsFor: 'mode constants' stamp: ''!
blend
	"Answer the integer denoting BitBlt's alpha blend combination rule."
	^24! !

!Form class methodsFor: '*Graphics-Files' stamp: ''!
fromFileNamed: fileName 
	"Read a Form or ColorForm from the given file."
	
	^ fileName asFileReference 
			binaryReadStreamDo: [ :in | self fromBinaryStream: in ]! !

!Form class methodsFor: 'instance creation' stamp: ''!
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: '*Graphics-Files-FileRegistry' stamp: ''!
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.
	(ImageMorph withForm: image) openInWorld! !

!Form class methodsFor: 'mode constants' stamp: ''!
erase
	"Answer the integer denoting mode erase."

	^4! !

!Form class methodsFor: 'system startup' stamp: ''!
shutDown  "Form shutDown"
	"Compress all instances in the system.  Will decompress on demand..."
	Form allInstancesDo: [:f | f hibernate].
	ColorForm allInstancesDo: [:f | f hibernate].! !

!Form class methodsFor: 'instance creation' stamp: ''!
extent: extentPoint depth: bitsPerPixel bits: aBitmap
	"Answer an instance of me with blank bitmap of the given dimensions and depth."

	^ self basicNew setExtent: extentPoint depth: bitsPerPixel bits: aBitmap! !

!Form class methodsFor: 'mode constants' stamp: ''!
and
	"Answer the integer denoting the logical 'and' combination rule."

	^1! !

!Form class methodsFor: '*Morphic-Base' stamp: ''!
floodFillTolerance
	^ FloodFillTolerance ifNil: [FloodFillTolerance := 0.0]! !

!Form class methodsFor: 'mode constants' stamp: ''!
blendAlpha
	"Answer the integer denoting BitBlt's blend-with-constant-alpha rule."

	^ 30! !

!Form class methodsFor: 'mode constants' stamp: ''!
paintAlpha
	"Answer the integer denoting BitBlt's paint-with-constant-alpha rule."

	^ 31! !

!Form class methodsFor: 'mode constants' stamp: ''!
erase1bitShape
	"Answer the integer denoting mode erase."

	^ 26! !

!FormCanvas commentStamp: ''!
Note that when shadowDrawing is true, shadowStipple may be either a color, for a solid shadow of the given color, or it may be a stipple used to simulate gray shading when the display cannot support alpha blending.!
!FormCanvas methodsFor: 'copying' stamp: ''!
copyOffset: aPoint
	^ self copyOrigin: origin + aPoint clipRect: clipRect! !

!FormCanvas methodsFor: 'drawing - rectangles' stamp: ''!
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: 'private' stamp: ''!
privateClipRect

	^clipRect! !

!FormCanvas methodsFor: 'accessing' stamp: ''!
allocateForm: extentPoint
	"Allocate a new form which is similar to the receiver"
	^form allocateForm: extentPoint! !

!FormCanvas methodsFor: 'drawing - support' stamp: ''!
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: 'private' stamp: ''!
translucentPatterns
	^ self class translucentPatterns! !

!FormCanvas methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubParagraph: para bounds: bounds color: c

	| scanner |
	self setPaintColor: c.
	scanner := (port clippedBy: (bounds translateBy: origin)) rubDisplayScannerFor: para
		foreground: c background: Color transparent
		ignoreColorChanges: false.
	para drawOn: (self copyClipRect: bounds) using: scanner at: origin + bounds topLeft.
! !

!FormCanvas methodsFor: 'accessing' stamp: ''!
depth

	^ form depth! !

!FormCanvas methodsFor: 'drawing - text' stamp: ''!
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: 'accessing' stamp: ''!
form

	^ form! !

!FormCanvas methodsFor: '*Morphic-Base' stamp: ''!
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 - rectangles' stamp: ''!
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: 'private' stamp: ''!
privatePort

	^port! !

!FormCanvas methodsFor: 'drawing - ovals' stamp: ''!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given oval."

	self flag: #pharoFixMe.		"Bob: this and its siblings could be moved up to Canvas with the
						right #balloonFillOval:..."

	(aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
		self flag: #pharoFixMe. "See PluggableCanvas>>fillOval:fillStyle:borderWidth:borderColor:"
		^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 drawOval: (aRectangle insetBy: bw // 2)
			color: aFillStyle 
			borderWidth: bw
			borderColor: bc! !

!FormCanvas methodsFor: 'private' stamp: ''!
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: '*Morphic-Base' stamp: ''!
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: 'private - balloon engine' stamp: ''!
drawRectangle: r color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a rectangle"

	self ensuredEngine
		drawRectangle: r
		fill: c
		borderWidth: borderWidth
		borderColor: borderColor
		transform: self transform.! !

!FormCanvas methodsFor: 'private' stamp: ''!
resetGrafPort
	"Private!! Create a new grafPort for a new copy."

	port := GrafPort toForm: form.
	port clipRect: clipRect.! !

!FormCanvas methodsFor: 'private' stamp: ''!
setPaintColor: aColor
	"Install a new color used for filling."
	
	| paintColor screen patternWord |
	paintColor := aColor.
	paintColor ifNil: [paintColor := Color transparent].
	paintColor isColor ifFalse: [ 
		(paintColor isKindOf: InfiniteForm) 
			ifFalse: [^self error:'Cannot install color'].
		^port fillPattern: paintColor; combinationRule: Form paint].
	"Okay, so paintColor really *is* a color"
	port sourceForm: nil.
	(paintColor isTranslucent) ifFalse: [
		port fillPattern: paintColor.
		port combinationRule: Form paint.
		self depth = 8 ifTrue: [
			port fillColor: (form balancedPatternFor: paintColor)].
		^self].
	"paintColor is translucent color"

	self depth > 8 ifTrue: [
		"BitBlt setup for alpha mapped transfer"
		port fillPattern: paintColor.
		self depth = 16
			ifTrue: [port alphaBits: paintColor privateAlpha; combinationRule: 31]
			ifFalse: [port combinationRule: Form blend].
		^self].

	"Can't represent actual transparency -- use stipple pattern"
	screen := self translucentMaskFor: paintColor alpha depth: self depth.
	patternWord := form pixelWordFor: paintColor.
	port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
	port combinationRule: Form paint! !

!FormCanvas methodsFor: 'copying' stamp: ''!
copyOrigin: aPoint clipRect: aRectangle
	"Return a copy of this canvas with the given origin. The clipping rectangle of this canvas is the intersection of the given rectangle and the receiver's current clipping rectangle. This allows the clipping rectangles of nested clipping morphs to be composed."
	^ self copy
		setOrigin: aPoint
		clipRect: (clipRect intersect: aRectangle ifNone: ["well, now we will clip everything" 0@0 corner: 0@0])! !

!FormCanvas methodsFor: 'drawing - polygons' stamp: ''!
drawPolygon: vertices fillStyle: aFillStyle borderWidth: borderWidth borderColor: borderColor

	| canvasCopy |
	canvasCopy := (FormCanvas on: form) setOrigin: origin clipRect: clipRect.
	canvasCopy ensuredEngine
		drawPolygon: (vertices copyWith: vertices first) asArray
		fill: aFillStyle
		borderWidth: borderWidth
		borderColor: borderColor
		transform: self transform.! !

!FormCanvas methodsFor: 'other' stamp: ''!
flushDisplay

	Display deferUpdates: false! !

!FormCanvas methodsFor: 'drawing' stamp: ''!
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: 'copying' stamp: ''!
postCopy
	"The copy share same underlying Form but with its own grafPort."

	self flush.
	super postCopy.
	self resetGrafPort.
	self resetEngine! !

!FormCanvas methodsFor: 'private' stamp: ''!
setClearColor: aColor
	"Install a new clear color - e.g., a color is used for clearing the background"
	| clearColor |
	clearColor := aColor ifNil:[Color transparent].
	clearColor isColor ifFalse:[
		(clearColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: clearColor; combinationRule: Form over].
	"Okay, so clearColor really *is* a color"
	port sourceForm: nil.
	port combinationRule: Form over.
	port fillPattern: clearColor.
	self depth = 8 ifTrue:[
		"Use a stipple pattern"
		port fillColor: (form balancedPatternFor: clearColor)].! !

!FormCanvas methodsFor: 'accessing' stamp: ''!
extent

	^ form extent! !

!FormCanvas methodsFor: 'drawing - support' stamp: ''!
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 - text' stamp: ''!
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;
			displayUnderlineOn: port from: (bounds topLeft + origin + (0@font ascent)) to: endPoint.	
		].
	strikethrough ifTrue: [ 
		font installOn: port
			foregroundColor: uc
			backgroundColor: Color transparent;
			displayStrikeoutOn: port from: (bounds topLeft + origin + (0@font ascent)) to: endPoint.	
	].

	port clipRect: portRect.! !

!FormCanvas methodsFor: 'drawing - text' stamp: ''!
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: 'initialization' stamp: ''!
finish
	"If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."
	form finish! !

!FormCanvas methodsFor: 'drawing - images' stamp: ''!
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: 'private' stamp: ''!
setFillColor: aColor
	"Install a new color used for filling."
	| screen patternWord fillColor |
	fillColor := aColor.
	fillColor ifNil:[fillColor := Color transparent].
	fillColor isColor ifFalse:[
		(fillColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: fillColor; combinationRule: Form over].
	"Okay, so fillColor really *is* a color"
	port sourceForm: nil.
	fillColor isTranslucent ifFalse:[
		port combinationRule: Form over.
		port fillPattern: fillColor.
		self depth = 8 ifTrue:[
			"In 8 bit depth it's usually a good idea to use a stipple pattern"
			port fillColor: (form balancedPatternFor: fillColor)].
		^self].
	"fillColor is some translucent color"

	self depth > 8 ifTrue:[
		"BitBlt setup for alpha masked transfer"
		port fillPattern: fillColor.
		self depth = 16
			ifTrue:[port alphaBits: fillColor privateAlpha; combinationRule: 30]
			ifFalse:[port combinationRule: Form blend].
		^self].
	"Can't represent actual transparency -- use stipple pattern"
	screen := self translucentMaskFor: fillColor alpha depth: self depth.
	patternWord := form pixelWordFor: fillColor.
	port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
	port combinationRule: Form paint.! !

!FormCanvas methodsFor: 'drawing - images' stamp: ''!
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: '*Morphic-Base' stamp: ''!
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.
		width := character = carriageReturn
			ifTrue: [ lineWidth := lineWidth max: width.
				lineHeight := lineHeight + textStyle lineGrid.
				0 ]
			ifFalse: [ width + (font widthOf: character) ] ].
	lineWidth := lineWidth max: width.
	bounds := aPoint extent: lineWidth @ lineHeight.

	port colorMap: nil.
	portRect := port clipRect.
	port
		clipByX1: bounds left + origin x
		y1: bounds top + origin y
		x2: bounds right + origin x
		y2: bounds bottom + origin y.
	port combinationRule: Form paint.
	port fill: bounds fillColor: Color white rule: Form paint.
	font installOn: port foregroundColor: c backgroundColor: Color white.
	aString lines
		doWithIndex: [ :line :index | 
			font
				displayString: line
				on: port
				from: 1
				to: line size
				at: bounds topLeft + origin + (0 @ (index - 1) * textStyle lineGrid)
				kern: 0 ].
	port clipRect: portRect! !

!FormCanvas methodsFor: 'drawing - support' stamp: ''!
clipBy: aRectangle during: aBlock
	"Set a clipping rectangle active only during the execution of aBlock.
	Note: In the future we may want to have more general clip shapes - not just rectangles"
	^aBlock value: (self copyClipRect: aRectangle)! !

!FormCanvas methodsFor: 'private - balloon engine' stamp: ''!
resetEngine
	engine := nil.! !

!FormCanvas methodsFor: 'drawing - polygons' stamp: ''!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	"Generalize for the BalloonCanvas"
	^self drawPolygon: vertices fillStyle: aColor borderWidth: bw borderColor: bc! !

!FormCanvas methodsFor: 'private' stamp: ''!
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 - balloon engine' stamp: ''!
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: self transform.! !

!FormCanvas methodsFor: 'accessing' stamp: ''!
origin
	"Return the current origin for drawing operations"
	^ origin! !

!FormCanvas methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll:' on: '; print: form.! !

!FormCanvas methodsFor: 'other' stamp: ''!
showAt: pt invalidRects: updateRects
	| blt |
	blt := (BitBlt toForm: Display)
			sourceForm: form;
			combinationRule: Form over.
	updateRects do:
		[:rect |
		blt sourceRect: rect;
			destOrigin: rect topLeft + pt;
			copyBits]! !

!FormCanvas methodsFor: 'other' stamp: ''!
showAt: pt

	^ form displayAt: pt! !

!FormCanvas methodsFor: 'private - balloon engine' stamp: ''!
ensuredEngine
	engine := BalloonEngine new.
	engine aaLevel: 1.
	engine bitBlt: port.
	engine destOffset: origin.
	engine clipRect: clipRect.
	engine deferred: false.

	engine colorTransform: colorTransform.
	engine edgeTransform: self transform.
	^engine! !

!FormCanvas methodsFor: 'copying' stamp: ''!
flush
	"Force all pending primitives onscreen"
	engine ifNotNil:[engine flush].! !

!FormCanvas methodsFor: 'initialization' stamp: ''!
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: 'private' stamp: ''!
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 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: 'drawing - rectangles' stamp: ''!
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)].
	].
	
	^self drawRectangle: aRectangle
			color: aFillStyle
			borderWidth: 0
			borderColor: nil! !

!FormCanvas methodsFor: 'other' stamp: ''!
warpFrom: sourceQuad toRect: destRect
	^ (WarpBlt toForm: port destForm)
		combinationRule: Form paint;
		sourceQuad: sourceQuad destRect: (destRect translateBy: origin);
		clipRect: clipRect! !

!FormCanvas methodsFor: 'copying' stamp: ''!
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: 'testing' stamp: ''!
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 - balloon engine' stamp: ''!
transform

	^ (transform ifNil: [MatrixTransform2x3 identity])! !

!FormCanvas methodsFor: 'accessing' stamp: ''!
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: 'drawing - ovals' stamp: ''!
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: 'accessing' stamp: ''!
clipRect
	"Return the currently active clipping rectangle"
	^ clipRect translateBy: origin negated! !

!FormCanvas methodsFor: 'copying' stamp: ''!
copyClipRect: aRectangle
	^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin)! !

!FormCanvas methodsFor: 'private' stamp: ''!
translucentMaskFor: alphaValue depth: d
	"Return a pattern representing a mask usable for stipple transparency"
	^(self translucentPatterns at: d) at: ((alphaValue min: 1.0 max: 0.0) * 4) rounded + 1! !

!FormCanvas methodsFor: 'private' stamp: ''!
setOrigin: aPoint clipRect: aRectangle

	origin := aPoint.
	clipRect := aRectangle.
	port clipRect: aRectangle.! !

!FormCanvas methodsFor: 'private' stamp: ''!
setForm: aForm

	self reset.
	form := aForm.
	port := GrafPort toForm: form.! !

!FormCanvas methodsFor: 'drawing' stamp: ''!
fillColor: c
	"Note: This always fills, even if the color is transparent."
	self setClearColor: c.
	port fillRect: form boundingBox offset: origin.! !

!FormCanvas methodsFor: 'drawing - support' stamp: ''!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."
	^aBlock value: (self copyOffset: delta)! !

!FormCanvas methodsFor: 'drawing' stamp: ''!
paragraph: para bounds: bounds color: c

	| scanner |
	self setPaintColor: c.
	scanner := (port clippedBy: (bounds translateBy: origin)) displayScannerFor: para
		foreground: c background: Color transparent
		ignoreColorChanges: false.
	para displayOn: (self copyClipRect: bounds) using: scanner at: origin+ bounds topLeft.! !

!FormCanvas methodsFor: 'drawing - rectangles' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
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: ''!
extent: extent depth: depth

	^ self new setForm: (Form extent: extent depth: depth)! !

!FormCanvas class methodsFor: 'caching' stamp: ''!
translucentPatterns

	^ TranslucentPatterns ifNil: [ TranslucentPatterns := self defaultTranslucentPatterns ]! !

!FormCanvas class methodsFor: 'instance creation' stamp: ''!
on: aForm

	^ self new setForm: aForm! !

!FormCanvas class methodsFor: 'caching' stamp: ''!
defaultTranslucentPatterns
	| patterns |
	patterns := 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.
			patterns at: d put: patternList ].

	^ patterns! !

!FormCanvas class methodsFor: 'instance creation' stamp: ''!
extent: aPoint

	^ self extent: aPoint depth: Display depth! !

!FormTest commentStamp: ''!
SUnit tests for class Form!
!FormTest methodsFor: 'tests - 32 bit' stamp: ''!
test32BitFormBlackShouldStayBlackAfterSave
	"Solve bug: https://pharo.manuscript.com/f/cases/14619"

	| blackForm |
	blackForm := (Form extent: 10 @ 10) fillColor: Color black.
	self assert: blackForm colorsUsed first equals: Color black! !

!FormTest methodsFor: 'tests - 32 bit' stamp: ''!
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: ''!
testIsAllWhite
	"Make sure #isAllWhite works for all bit depths"
	
	#(-32 -16 -8 -4 -2 -1 1 2 4 8 16 32) do:[:d| | form |
		form := Form extent: 16@16 depth: d.
		form fillBlack.
		self deny: form isAllWhite.
		form fillWhite.
		self assert: form isAllWhite.
	].! !

!FormTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^Form! !

!Fraction commentStamp: ''!
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: 'converting' stamp: ''!
asFloat
	"Answer a Float that closely approximates the value of the receiver.
	This implementation will answer the closest floating point number to the receiver.
	In case of a tie, it will use the IEEE 754 round to nearest even mode.
	In case of overflow, it will answer +/- Float infinity."

	| a b mantissa exponent hasTruncatedBits lostBit n ha hb hm |
	a := numerator abs.
	b := denominator.	"denominator is always positive"
	ha := a highBitOfMagnitude.
	hb := b highBitOfMagnitude.
	
	"Number of bits to keep in mantissa plus one to handle rounding."
	n := 1 + Float precision.

	"If both numerator and denominator are represented exactly in floating point number,
	then fastest thing to do is to use hardwired float division."
	(ha < n and: [hb < n]) ifTrue: [^numerator asFloat / denominator asFloat].

	"Shift the fraction by a power of two exponent so as to obtain a mantissa with n bits.
	First guess is rough, the mantissa might have n+1 bits."
	exponent := ha - hb - n.
	exponent >= 0
		ifTrue: [b := b bitShift: exponent]
		ifFalse: [a := a bitShift: exponent negated].
	mantissa := a quo: b.
	hasTruncatedBits := a > (mantissa * b).
	hm := mantissa highBit.
	
	"Check for gradual underflow, in which case the mantissa will loose bits.
	Keep at least one bit to let underflow preserve the sign of zero."
	lostBit := Float emin - (exponent + hm - 1).
	lostBit > 0 ifTrue: [n := n - lostBit max: 1].

	"Remove excess bits in the mantissa."
	hm > n
		ifTrue:
			[exponent := exponent + hm - n.
			hasTruncatedBits := hasTruncatedBits or: [mantissa anyBitOfMagnitudeFrom: 1 to: hm - n].
			mantissa := mantissa bitShift: n - hm].

	"Check if mantissa must be rounded upward.
	The case of tie (mantissa odd & hasTruncatedBits not)
	will be handled by Integer>>asFloat."
	(hasTruncatedBits and: [mantissa odd])
		ifTrue: [mantissa := mantissa + 1].

	^ (self positive
			ifTrue: [mantissa asFloat]
			ifFalse: [mantissa asFloat negated])
		timesTwoPower: exponent! !

!Fraction methodsFor: 'comparing' stamp: ''!
< aNumber
	aNumber isFraction ifTrue:
		[^ numerator * aNumber denominator < (aNumber numerator * denominator)].
	^ aNumber adaptToFraction: self andCompare: #<! !

!Fraction methodsFor: 'private' stamp: ''!
reduced

	| gcd numer denom |
	numerator = 0 ifTrue: [^0].
	gcd := numerator gcd: denominator.
	numer := numerator // gcd.
	denom := denominator // gcd.
	denom = 1 ifTrue: [^numer].
	^Fraction numerator: numer denominator: denom! !

!Fraction methodsFor: 'comparing' stamp: ''!
= aNumber
	aNumber isNumber ifFalse: [^ false].
	aNumber isFraction
		ifTrue: [numerator = 0 ifTrue: [^ aNumber numerator = 0].
				^ (numerator * aNumber denominator) =
					(aNumber numerator * denominator)
				"Note: used to just compare num and denom,
					but this fails for improper fractions"].
	^ aNumber adaptToFraction: self andCompare: #=! !

!Fraction methodsFor: 'arithmetic' stamp: ''!
* 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: 'truncation and round off' stamp: ''!
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: 'comparing' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
log
	"This function is defined because super log might overflow."
	| res |
	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: 'converting' stamp: ''!
isFraction
	^ true! !

!Fraction methodsFor: 'arithmetic' stamp: ''!
/ aNumber
	"Answer the result of dividing the receiver by aNumber."
	aNumber isFraction
		ifTrue: [^self * aNumber reciprocal].
	^ aNumber adaptToFraction: self andSend: #/! !

!Fraction methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'converting' stamp: ''!
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: 'printing' stamp: ''!
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: ''!
printOn: aStream

	aStream nextPut: $(.
	numerator printOn: aStream.
	aStream nextPut: $/.
	denominator printOn: aStream.
	aStream nextPut: $).! !

!Fraction methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating 
	^ true! !

!Fraction methodsFor: 'testing' stamp: ''!
isPowerOfTwo
	^ numerator = 1 and: [ denominator isPowerOfTwo ]! !

!Fraction methodsFor: 'printing' stamp: ''!
storeOn: aStream base: base

	aStream nextPut: $(.
	numerator storeOn: aStream base: base.
	aStream nextPut: $/.
	denominator storeOn: aStream base: base.
	aStream nextPut: $).! !

!Fraction methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'comparing' stamp: ''!
> aNumber
	aNumber isFraction ifTrue:
		[^ numerator * aNumber denominator > (aNumber numerator * denominator)].
	^ aNumber adaptToFraction: self andCompare: #>! !

!Fraction methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter writeFraction: self! !

!Fraction methodsFor: '*Math-Operations-Extensions' stamp: ''!
squared
	"See Fraction (Number) | squared"
	^ Fraction numerator: numerator squared denominator: denominator squared! !

!Fraction methodsFor: 'private' stamp: ''!
numerator

	^numerator! !

!Fraction methodsFor: 'arithmetic' stamp: ''!
- aNumber
	"Answer the difference between the receiver and aNumber."
	aNumber isInteger ifTrue:
		[^Fraction numerator: numerator - (denominator * aNumber) denominator: denominator].
	aNumber isFraction ifTrue:
		[^ self + aNumber negated].
	^ aNumber adaptToFraction: self andSend: #-! !

!Fraction methodsFor: 'private' stamp: ''!
reciprocal
	
	numerator abs = 1 ifTrue: [^denominator * numerator].
	^self class numerator: denominator denominator: numerator! !

!Fraction methodsFor: 'converting' stamp: ''!
asFraction	
	"Answer the receiver itself."

	^self! !

!Fraction methodsFor: 'comparing' stamp: ''!
>= aNumber
	aNumber isFraction ifTrue:
		[^ numerator * aNumber denominator >= (aNumber numerator * denominator)].
	^ aNumber adaptToFraction: self andCompare: #>=! !

!Fraction methodsFor: 'printing' stamp: ''!
printOn: aStream base: base

	aStream nextPut: $(.
	numerator printOn: aStream base: base.
	aStream nextPut: $/.
	denominator printOn: aStream base: base.
	aStream nextPut: $).! !

!Fraction methodsFor: 'converting' stamp: ''!
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: 'arithmetic' stamp: ''!
negated 
	"Refer to the comment in Number|negated."

	^ Fraction
		numerator: numerator negated
		denominator: denominator! !

!Fraction methodsFor: 'private' stamp: ''!
denominator

	^denominator! !

!Fraction methodsFor: 'private' stamp: ''!
setNumerator: n denominator: d

	d = 0
		ifTrue: [^(ZeroDivide dividend: n) signal]
		ifFalse: 
			[numerator := n asInteger.
			denominator := d asInteger abs. "keep sign in numerator"
			d < 0 ifTrue: [numerator := numerator negated]]! !

!Fraction methodsFor: '*Math-Operations-Extensions' stamp: ''!
nthRoot: aPositiveInteger
	"Answer the nth root of the receiver."

	| guess |
	guess := (numerator nthRootTruncated: aPositiveInteger) / (denominator nthRootTruncated: aPositiveInteger).
	(guess raisedTo: aPositiveInteger) = self ifTrue: [^guess].
	"There is no exact nth root, so answer a Float approximation"
	^(self abs ln / aPositiveInteger) exp * self sign! !

!Fraction methodsFor: '*Math-Operations-Extensions' stamp: ''!
raisedToFraction: aFraction
	| root |
	root := (self numerator nthRootTruncated: aFraction denominator) / (self denominator nthRootTruncated: aFraction denominator).
	(root raisedToInteger: aFraction denominator) = self ifTrue: [^root raisedToInteger: aFraction numerator].
	^super raisedToFraction: aFraction! !

!Fraction methodsFor: 'truncation and round off' stamp: ''!
round: numberOfWishedDecimal
	"Round the decimal part of the receiver to be limited to the number of wished decimal. Only leave a fixed amount of decimal"
   "(1/3 round: 2) >>> (33/100) "   
	"(111/100 round: 2) >>> (111/100) "
	
	^self roundTo: (10 raisedTo: numberOfWishedDecimal negated)! !

!Fraction methodsFor: 'testing' stamp: ''!
negative

	^numerator negative! !

!Fraction methodsFor: 'truncation and round off' stamp: ''!
truncated 
	"Refer to the comment in Number|truncated."

	^numerator quo: denominator! !

!Fraction methodsFor: 'truncation and round off' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
ln
	"This function is defined because super ln might overflow."
	| res |
	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: 'arithmetic' stamp: ''!
+ aNumber 
	"Answer the sum of the receiver and aNumber."
	| n d d1 d2 |
	aNumber isInteger ifTrue:
		[^Fraction numerator: numerator + (denominator * aNumber) denominator: denominator].
	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: 'comparing' stamp: ''!
<= aNumber
	aNumber isFraction ifTrue:
		[^ numerator * aNumber denominator <= (aNumber numerator * denominator)].
	^ aNumber adaptToFraction: self andCompare: #<=! !

!Fraction class methodsFor: 'instance creation' stamp: ''!
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: '*NumberParser' stamp: ''!
readFrom: stringOrStream 
	"Answer a Fraction as described on aStream with following rules:
	- numerator can specify a different radix (like '16rABC').
	- fraction sign '/' is optional, and must immediately follow numerator without space.
	- denominator must immediately follow fraction sign and can specify a different radix (like 16rABC).
	If stringOrStream does not start with a valid number description, fail."
	
	^(NumberParser on: stringOrStream) nextFraction! !

!FractionTest commentStamp: ''!
SUnit tests for fractions!
!FractionTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
testInexactRaisedTo
	"
	FractionTest new testInexactRaisedTo
	"

	self assert: (((1 << 1024) + 1) / ((1 << 1024) + 3) raisedTo: 1 / 3) equals: 1.0.
	self assert: ((((1 << 1024) + 1) / ((1 << 1024) + 3)) negated raisedTo: 1 / 3) equals: -1.0! !

!FractionTest methodsFor: 'tests - reading' stamp: ''!
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 - sinuses' stamp: ''!
testReciprocal
	self
		assert: (1 / 2) reciprocal equals: 2;
		assert: (3 / 4) reciprocal equals: 4 / 3;
		assert: (-1 / 3) reciprocal equals: -3;
		assert: (-3 / 5) reciprocal equals: -5 / 3! !

!FractionTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
testDegreeCos

	(4 / 3) degreeCos.
	-361 / 3 to: 359 / 3 do: [ :i | self assert: (i degreeCos closeTo: i degreesToRadians cos) ]! !

!FractionTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testDegreeSin

	(4 / 3) degreeSin.
	-361 / 3 to: 359 / 3 do: [ :i | self assert: (i degreeSin closeTo: i degreesToRadians sin) ]! !

!FractionTest methodsFor: 'tests - conversions' stamp: ''!
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: ''!
testIsPowerOfTwo
	"Negative fraction"
	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.
	"Positive fraction"
	self assert: (1 / 2) isPowerOfTwo.
	self assert: (1 / (2 raisedTo: 80)) isPowerOfTwo.
	self assert: (1 negated / (2 raisedTo: 80) negated) isPowerOfTwo.
	self deny: ((2 raisedTo: 80) / 3) isPowerOfTwo.
	self assert: ((2 raisedTo: 80) / 4) isPowerOfTwo! !

!FractionTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 - reading' stamp: ''!
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: 'private' stamp: ''!
assert: a classAndValueEquals: b
	self assert: a class equals: b class.
	self assert: a equals: b! !

!FractionTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testFloorLog
	self assert: (1 / 100 floorLog: 10) equals: -2.
	self assert: ((2 raisedTo: Float emax + 11) / 3 floorLog: 10) = ((Float emax + 11) * 2 log - 3 log) floor description: 'Fraction>>log should not overflow'.
	self
		assert: (3 / (2 raisedTo: Float precision - Float emin) floorLog: 10) = ((Float emin - Float precision) * 2 log + 3 log) floor
		description: 'Fraction>>log should not underflow'! !

!FractionTest methodsFor: 'tests - conversions' stamp: ''!
testFloor
	self assert: (3 / 2) floor equals: 1.
	self assert: (-3 / 2) floor equals: -2! !

!FractionTest methodsFor: 'tests - conversions' stamp: ''!
testRounded
	self assert: (4 / 5) rounded equals: 1.
	self assert: (6 / 5) rounded equals: 1.
	self assert: (-4 / 5) rounded equals: -1.
	self assert: (-6 / 5) rounded equals: -1.

	"In case of tie, round to upper magnitude"
	self assert: (3 / 2) rounded equals: 2.
	self assert: (-3 / 2) rounded equals: -2! !

!FractionTest methodsFor: 'tests - conversions' stamp: ''!
testTruncated
	self assert: (3 / 2) truncated equals: 1.
	self assert: (-3 / 2) truncated equals: -1! !

!FractionTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 - printing' stamp: ''!
testFractionPrinting
	self assert: (353 / 359) printString equals: '(353/359)'.
	self assert: (2 / 3 printStringBase: 2) equals: '(10/11)'.
	self assert: (2 / 3 storeStringBase: 2) equals: '(2r10/2r11)'.
	self assert: (5 / 7 printStringBase: 3) equals: '(12/21)'.
	self assert: (5 / 7 storeStringBase: 3) equals: '(3r12/3r21)'.
	self assert: (11 / 13 printStringBase: 4) equals: '(23/31)'.
	self assert: (11 / 13 storeStringBase: 4) equals: '(4r23/4r31)'.
	self assert: (17 / 19 printStringBase: 5) equals: '(32/34)'.
	self assert: (17 / 19 storeStringBase: 5) equals: '(5r32/5r34)'.
	self assert: (23 / 29 printStringBase: 6) equals: '(35/45)'.
	self assert: (23 / 29 storeStringBase: 6) equals: '(6r35/6r45)'.
	self assert: (31 / 37 printStringBase: 7) equals: '(43/52)'.
	self assert: (31 / 37 storeStringBase: 7) equals: '(7r43/7r52)'.
	self assert: (41 / 43 printStringBase: 8) equals: '(51/53)'.
	self assert: (41 / 43 storeStringBase: 8) equals: '(8r51/8r53)'.
	self assert: (47 / 53 printStringBase: 9) equals: '(52/58)'.
	self assert: (47 / 53 storeStringBase: 9) equals: '(9r52/9r58)'.
	self assert: (59 / 61 printStringBase: 10) equals: '(59/61)'.
	self assert: (59 / 61 storeStringBase: 10) equals: '(59/61)'.
	self assert: (67 / 71 printStringBase: 11) equals: '(61/65)'.
	self assert: (67 / 71 storeStringBase: 11) equals: '(11r61/11r65)'.
	self assert: (73 / 79 printStringBase: 12) equals: '(61/67)'.
	self assert: (73 / 79 storeStringBase: 12) equals: '(12r61/12r67)'.
	self assert: (83 / 89 printStringBase: 13) equals: '(65/6B)'.
	self assert: (83 / 89 storeStringBase: 13) equals: '(13r65/13r6B)'.
	self assert: (97 / 101 printStringBase: 14) equals: '(6D/73)'.
	self assert: (97 / 101 storeStringBase: 14) equals: '(14r6D/14r73)'.
	self assert: (103 / 107 printStringBase: 15) equals: '(6D/72)'.
	self assert: (103 / 107 storeStringBase: 15) equals: '(15r6D/15r72)'.
	self assert: (109 / 113 printStringBase: 16) equals: '(6D/71)'.
	self assert: (109 / 113 storeStringBase: 16) equals: '(16r6D/16r71)'.
	self assert: (127 / 131 printStringBase: 17) equals: '(78/7C)'.
	self assert: (127 / 131 storeStringBase: 17) equals: '(17r78/17r7C)'.
	self assert: (137 / 139 printStringBase: 18) equals: '(7B/7D)'.
	self assert: (137 / 139 storeStringBase: 18) equals: '(18r7B/18r7D)'.
	self assert: (149 / 151 printStringBase: 19) equals: '(7G/7I)'.
	self assert: (149 / 151 storeStringBase: 19) equals: '(19r7G/19r7I)'.
	self assert: (157 / 163 printStringBase: 20) equals: '(7H/83)'.
	self assert: (157 / 163 storeStringBase: 20) equals: '(20r7H/20r83)'.
	self assert: (167 / 173 printStringBase: 21) equals: '(7K/85)'.
	self assert: (167 / 173 storeStringBase: 21) equals: '(21r7K/21r85)'.
	self assert: (179 / 181 printStringBase: 22) equals: '(83/85)'.
	self assert: (179 / 181 storeStringBase: 22) equals: '(22r83/22r85)'.
	self assert: (191 / 193 printStringBase: 23) equals: '(87/89)'.
	self assert: (191 / 193 storeStringBase: 23) equals: '(23r87/23r89)'.
	self assert: (197 / 199 printStringBase: 24) equals: '(85/87)'.
	self assert: (197 / 199 storeStringBase: 24) equals: '(24r85/24r87)'.
	self assert: (211 / 223 printStringBase: 25) equals: '(8B/8N)'.
	self assert: (211 / 223 storeStringBase: 25) equals: '(25r8B/25r8N)'.
	self assert: (227 / 229 printStringBase: 26) equals: '(8J/8L)'.
	self assert: (227 / 229 storeStringBase: 26) equals: '(26r8J/26r8L)'.
	self assert: (233 / 239 printStringBase: 27) equals: '(8H/8N)'.
	self assert: (233 / 239 storeStringBase: 27) equals: '(27r8H/27r8N)'.
	self assert: (241 / 251 printStringBase: 28) equals: '(8H/8R)'.
	self assert: (241 / 251 storeStringBase: 28) equals: '(28r8H/28r8R)'.
	self assert: (257 / 263 printStringBase: 29) equals: '(8P/92)'.
	self assert: (257 / 263 storeStringBase: 29) equals: '(29r8P/29r92)'.
	self assert: (269 / 271 printStringBase: 30) equals: '(8T/91)'.
	self assert: (269 / 271 storeStringBase: 30) equals: '(30r8T/30r91)'.
	self assert: (277 / 281 printStringBase: 31) equals: '(8T/92)'.
	self assert: (277 / 281 storeStringBase: 31) equals: '(31r8T/31r92)'.
	self assert: (283 / 293 printStringBase: 32) equals: '(8R/95)'.
	self assert: (283 / 293 storeStringBase: 32) equals: '(32r8R/32r95)'.
	self assert: (307 / 311 printStringBase: 33) equals: '(9A/9E)'.
	self assert: (307 / 311 storeStringBase: 33) equals: '(33r9A/33r9E)'.
	self assert: (313 / 317 printStringBase: 34) equals: '(97/9B)'.
	self assert: (313 / 317 storeStringBase: 34) equals: '(34r97/34r9B)'.
	self assert: (331 / 337 printStringBase: 35) equals: '(9G/9M)'.
	self assert: (331 / 337 storeStringBase: 35) equals: '(35r9G/35r9M)'.
	self assert: (347 / 349 printStringBase: 36) equals: '(9N/9P)'.
	self assert: (347 / 349 storeStringBase: 36) equals: '(36r9N/36r9P)'.

	self assert: (-2 / 3 printStringBase: 2) equals: '(-10/11)'.
	self assert: (-2 / 3 storeStringBase: 2) equals: '(-2r10/2r11)'.
	self assert: (5 / -7 printStringBase: 3) equals: '(-12/21)'.
	self assert: (5 / -7 storeStringBase: 3) equals: '(-3r12/3r21)'! !

!FractionTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Fraction! !

!FractionTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testInexactSqrt
	"
	FractionTest new testInexactSqrt
	"

	self assert: (((1 << 1024) + 1) / ((1 << 1024) + 3)) sqrt equals: 1.0! !

!FractionTest methodsFor: 'tests - rounding' stamp: ''!
testRounding
	
	self assert: ((6/90) round: 2) equals: 7/100! !

!FractionTest methodsFor: 'tests - conversions' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
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 - conversions' stamp: ''!
testCeiling
	self assert: (3 / 2) ceiling equals: 2.
	self assert: (-3 / 2) ceiling equals: -1! !

!FreeTypeCache commentStamp: ''!
Cache for freetype fonts!
!FreeTypeCache methodsFor: 'public' stamp: ''!
cacheSize
	^ self maximumSize / 1024! !

!FreeTypeCache methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	maximumSize := self class defaultMaximumSize.
	fontTable := self dictionaryClass new: 100.
	used := 0.
	fifo := self fifoClass new! !

!FreeTypeCache methodsFor: 'private - accessing' stamp: ''!
dictionaryClass
	^Dictionary! !

!FreeTypeCache methodsFor: 'private - accessing' stamp: ''!
fifoClass
	^FreeTypeCacheLinkedList! !

!FreeTypeCache methodsFor: 'add-remove' stamp: ''!
removeAllForType: typeFlag
	| toRemove |
	
	toRemove := IdentitySet new.
	fifo do:[:entry |
		entry type = typeFlag
			ifTrue:[toRemove add: entry]].
	toRemove do:[:entry | | d | 
		fifo remove: entry.
		d := (fontTable at: entry font) at: entry charCode.
		d removeKey: entry type.	
		used := used - (self sizeOf: entry object) ].! !

!FreeTypeCache methodsFor: 'public' stamp: ''!
maximumSize: anIntegerOrNil

	maximumSize := anIntegerOrNil.
	maximumSize ifNotNil:[
		used > maximumSize
			ifTrue:["shrink"
				self shrinkTo: maximumSize]]! !

!FreeTypeCache methodsFor: 'add-remove' stamp: ''!
atFont: aFreeTypeFont charCode: charCodeInteger type: typeFlag put: anObject 
	| charCodeTable typeTable anObjectSize oldEntry oldEntrySize entry |

	aFreeTypeFont mutex criticalReleasingOnError: [  					
		anObjectSize := self sizeOf: anObject.
		(maximumSize notNil and:[anObjectSize > maximumSize]) 
			ifTrue:[^anObject].  
		(charCodeTable := fontTable at: aFreeTypeFont ifAbsentPut:[self dictionaryClass new: 60])
			ifNotNil:[
				(typeTable := charCodeTable at: charCodeInteger ifAbsentPut:[self dictionaryClass new: 10])
					ifNotNil:[
						oldEntry := typeTable at: typeFlag ifAbsent:[].
						oldEntrySize := (oldEntry 
							ifNil:[0] 
							ifNotNil:[self sizeOf: oldEntry object]). 
						entry := (self fifoEntryClass new
							font: aFreeTypeFont;
							charCode: charCodeInteger;
							type: typeFlag;
							object: anObject;
							yourself).
						typeTable at: typeFlag put: entry]].
		used := used + anObjectSize - oldEntrySize.
		oldEntry ifNotNil: [fifo remove: oldEntry].
		fifo addLast: entry.
		maximumSize ifNotNil:[self shrinkTo: maximumSize].
		^anObject]! !

!FreeTypeCache methodsFor: 'private - accessing' stamp: ''!
fifoEntryClass
	^FreeTypeCacheEntry! !

!FreeTypeCache methodsFor: 'add-remove' stamp: ''!
atFont: aFreeTypeFont charCode: charCodeInteger type: typeFlag

	^ self
		atFont: aFreeTypeFont
		charCode: charCodeInteger
		type: typeFlag
		ifAbsentPut: [ self error: 'Not found' ]! !

!FreeTypeCache methodsFor: 'public' stamp: ''!
maximumSize

	^ maximumSize! !

!FreeTypeCache methodsFor: 'public' stamp: ''!
cacheSize: anInteger
	self maximumSize: (anInteger * 1024)! !

!FreeTypeCache methodsFor: 'add-remove' stamp: ''!
removeAll
	fontTable := self dictionaryClass new: 100.
	fifo := self fifoClass new.
	used := 0! !

!FreeTypeCache methodsFor: 'add-remove' stamp: ''!
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: 'reporting' stamp: ''!
reportCacheState
	"Answer a description of the current state of the cache"
	| usedPercent |
	usedPercent := maximumSize 
		ifNil: [0]
		ifNotNil: [(used * 100 / maximumSize) asFloat rounded].
	^usedPercent asString,'% Full (maximumSize: ', maximumSize asString, ' , used: ', used asString,')'! !

!FreeTypeCache methodsFor: 'private - sizing' stamp: ''!
shrinkTo: newSize
	"if the used size is greater than newSize, then remove all the receiver's entries"
	
	used > newSize ifTrue:[self removeAll]! !

!FreeTypeCache methodsFor: 'private - accessing' stamp: ''!
sizeOf: anObject

	^ anObject ftSize! !

!FreeTypeCache methodsFor: 'add-remove' stamp: ''!
atFont: aFreeTypeFont charCode: charCodeInteger type: typeFlag ifAbsentPut: aBlock 
	| charCodeTable typeTable entry v vSize |

	aFreeTypeFont mutex criticalReleasingOnError: [  				
		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 class methodsFor: 'system startup' stamp: ''!
clearCacheOnShutdown
	"Answer true if the cache should be cleared on image shutdown"
	
	^true! !

!FreeTypeCache class methodsFor: 'accessing' stamp: ''!
defaultMaximumSize
	"Answer the default maximumSize in bytes"
	
	^1024*5000 "5 Megabytes"! !

!FreeTypeCache class methodsFor: 'initialize-release' stamp: ''!
initialize
	SessionManager default 
		registerGuiClassNamed: self name
		atPriority: 10.! !

!FreeTypeCache class methodsFor: 'accessing' stamp: ''!
current
	^ current ifNil: [  current := self new ]! !

!FreeTypeCache class methodsFor: 'system startup' stamp: ''!
shutDown: isImageQuitting 
	isImageQuitting ifFalse: [ ^ self ].
	(current notNil and: [ self clearCacheOnShutdown ])
		ifTrue:[ 
			self current removeAll.
			current := nil ]! !

!FreeTypeCache class methodsFor: 'private - cleaning' stamp: ''!
clearCurrent
	<script>
	
	current := nil! !

!FreeTypeCache class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting

	isImageStarting ifFalse: [ ^ self ].
	self current removeAll.
	current := nil! !

!FreeTypeCache class methodsFor: 'cleanup' stamp: ''!
cleanUp
	self clearCurrent! !

!FreeTypeCacheConstants commentStamp: ''!
Constants for the FreeType cache!
!FreeTypeCacheConstants class methodsFor: 'class initialization' stamp: ''!
initialize
	
	FreeTypeCacheWidth := 0.
	FreeTypeCacheGlyph := 100.	"start at 100 and allow room for 64 subpixel positioned glyphs"
	FreeTypeCacheGlyphLCD := 200. "start at 200 and allow room for 64 subpixel positioned glyphs"
	FreeTypeCacheGlyphMono := 3.
	FreeTypeCacheLinearWidth := 4! !

!FreeTypeCacheEntry commentStamp: ''!
An entry for the FreeTypeCache!
!FreeTypeCacheEntry methodsFor: 'comparing' stamp: ''!
= 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: ''!
hash
	^charCode hash! !

!FreeTypeCacheEntry methodsFor: 'accessing' stamp: ''!
charCode: anObject
	"Set the value of charCode"

	charCode := anObject! !

!FreeTypeCacheEntry methodsFor: 'accessing' stamp: ''!
font
	"Answer the value of font"

	^ font! !

!FreeTypeCacheEntry methodsFor: 'accessing' stamp: ''!
font: anObject
	"Set the value of font"

	font := anObject! !

!FreeTypeCacheEntry methodsFor: 'accessing' stamp: ''!
object: anObject
	"Set the value of object"

	object := anObject! !

!FreeTypeCacheEntry methodsFor: 'accessing' stamp: ''!
type: anObject
	"Set the value of type"

	type := anObject! !

!FreeTypeCacheEntry methodsFor: 'accessing' stamp: ''!
charCode
	"Answer the value of charCode"

	^ charCode! !

!FreeTypeCacheEntry methodsFor: 'accessing' stamp: ''!
previousLink
	"Answer the value of previousLink"

	^ previousLink! !

!FreeTypeCacheEntry methodsFor: 'accessing' stamp: ''!
object
	"Answer the value of object"

	^ object! !

!FreeTypeCacheEntry methodsFor: 'accessing' stamp: ''!
type
	"Answer the value of type"

	^ type! !

!FreeTypeCacheEntry methodsFor: 'accessing' stamp: ''!
previousLink: anObject
	"Set the value of previousLink"

	previousLink := anObject! !

!FreeTypeCacheLinkedList commentStamp: ''!
A linked list for the FreeTypeCache!
!FreeTypeCacheLinkedList methodsFor: 'removing' stamp: ''!
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 
		ifNil: [firstLink := lastLink := nil]
		ifNotNil: [firstLink previousLink: nil].
	oldLink nextLink: nil.
	^oldLink! !

!FreeTypeCacheLinkedList methodsFor: 'adding' stamp: ''!
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: ''!
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: ''!
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: 'reordering' stamp: ''!
moveDown: aLink
	|  e1 e2 e3 e4  |
	
	(e3 := aLink nextLink) ifNil:[^self].
	e2 := aLink.
	e4 := e3 nextLink.
	e1 := e2 previousLink.
	"swap e2 & e3"
	e1 ifNotNil:[e1 nextLink: e2].
	e2 nextLink: e3.
	e3 nextLink: e4.
	e4 ifNotNil:[e4 previousLink: e3].
	e3 previousLink: e2.
	e2 previousLink: e1! !

!FreeTypeCacheLinkedList methodsFor: 'removing' stamp: ''!
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 
		ifNil: [firstLink := lastLink := nil]
		ifNotNil:[lastLink nextLink: nil].
	oldLink previousLink: nil.
	^oldLink! !

!FreeTypeCacheLinkedList methodsFor: 'adding' stamp: ''!
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: ''!
remove: aLink ifAbsent: aBlock  
	| prev next  |

	prev := aLink previousLink.
	next := aLink nextLink.
	prev ifNotNil: [prev nextLink: next].
	next ifNotNil: [next previousLink: prev].
	aLink == firstLink ifTrue:[firstLink := next].
	aLink == lastLink ifTrue:[lastLink := prev].
	aLink nextLink: nil.
	aLink previousLink: nil.		
	^aLink! !

!FreeTypeCacheTest commentStamp: ''!
SUnit tests for FreeType cache!
!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testSetMaximumSizeUnbounded
	| u |
	u := fullCache instVarNamed: #used.
	fullCache maximumSize: nil.	"unbounded"
	self assert: u equals: (fullCache instVarNamed: #used).
	self validateSizes: cache.
	self validateCollections: cache! !

!FreeTypeCacheTest methodsFor: 'private' stamp: ''!
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 equals: fontTableEntries size.
	self assert: fifo asSet equals: fontTableEntries.
	self assert: (lastLink isNil or: [ lastLink nextLink isNil ])! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testSetMaximumSize
	cache maximumSize: 0.
	self assert: (cache instVarNamed: #maximumSize) equals: 0.
	cache maximumSize: 99999999999999999.
	self assert: (cache instVarNamed: #maximumSize) equals: 99999999999999999.
	cache maximumSize: nil.	"unbounded"
	self assert: (cache instVarNamed: #maximumSize) isNil.
	self validateSizes: cache.
	self validateCollections: cache! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
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) equals: 0.	"cache has been cleared on reaching max size"
	self validateSizes: cache.
	self validateCollections: cache.
	self should: [ cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph ] raise: Error.
	self should: [ cache atFont: font1 charCode: $Y asInteger type: FreeTypeCacheGlyph ] raise: Error! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testInstanceInitialization
	self assert: (cache instVarNamed: #maximumSize) equals: FreeTypeCache defaultMaximumSize.
	self assert: (cache instVarNamed: #used) equals: 0.
	self assert: (cache instVarNamed: #fontTable) class equals: cache dictionaryClass.
	self assertEmpty: (cache instVarNamed: #fontTable).
	self assert: (cache instVarNamed: #fifo) class equals: cache fifoClass.
	self assertEmpty: (cache instVarNamed: #fifo)! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
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 identicalTo: font1XGlyph.
	self validateSizes: cache.
	self validateCollections: cache! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testSetMaximumSizeShrink
	| m |
	m := fullCache instVarNamed: #maximumSize.
	fullCache maximumSize: m // 2.	"shrink"
	self assert: (fullCache instVarNamed: #used) equals: 0.	"cache is cleared when used > maximumSize"
	self validateSizes: fullCache.
	self validateCollections: fullCache! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
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 equals: f2.

	f3 := f copy.
	f3 nextLink: nil.
	self assert: f equals: f3	"equality not based on nextLink"! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testReport
	self assert: fullCache reportCacheState equals: '100% Full (maximumSize: 400320 , used: 400320)'.
	fullCache maximumSize: 800640.
	self assert: fullCache reportCacheState equals: '50% Full (maximumSize: 800640 , used: 400320)'.
	self assert: cache reportCacheState equals: '0% Full (maximumSize: 5120000 , used: 0)'.
	cache maximumSize: nil.
	self assert: cache reportCacheState equals: '0% Full (maximumSize: nil , used: 0)'! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testEntriesRemovedFIFO
	| |
	cache maximumSize: 10*(cache sizeOf: font1XGlyph).
	1 to: 10 do:[:i |
		cache 
			atFont: font1 
			charCode: (1000-i) 
			type: FreeTypeCacheGlyph 
			put: font1XGlyph].
	self validateCollections: cache.
	11 to:1000 do:[:i |
		cache 
			atFont: font1 
			charCode: (1000-i) 
			type: FreeTypeCacheGlyph 
			put: font1XGlyph.
		self validateSizes: cache.
		self validateCollections: cache.
		"i-9 to: i do:[:i2 |
			self 
				shouldnt: [cache atFont: font1 charCode: 1000-i2 type: FreeTypeCacheGlyph]
				raise: Error]."
		self 
			should: [cache atFont: font1 charCode: 1000-(i-10) type: FreeTypeCacheGlyph]
			raise: Error].  
	self validateSizes: cache.! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testPutSameElementTwice
	cache maximumSize: nil.
	cache
		atFont: font1
		charCode: $X asInteger
		type: FreeTypeCacheGlyph
		put: font1XGlyph.
	self assert: (cache instVarNamed: #used) equals: (cache sizeOf: font1XGlyph).
	self validateSizes: cache.
	self validateCollections: cache.
	cache
		atFont: font1
		charCode: $X asInteger
		type: FreeTypeCacheGlyph
		put: font1XGlyph.
	self assert: (cache instVarNamed: #used) equals: (cache sizeOf: font1XGlyph).
	self validateSizes: cache.
	self validateCollections: cache! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testFailedGet
	self should: [ cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph ] raise: Error.
	self assert: (cache instVarNamed: #used) equals: 0.
	self validateSizes: cache! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testRemoveAllForType
	| fifo |

	fullCache maximumSize: nil.	
	1 to: 100 do:[:i |
		fullCache atFont: font1 charCode: i type: 1 put: font1XGlyph].
	1 to: 100 do:[:i |
		fullCache atFont: font2 charCode: i type: 2 put: font1YGlyph].
	1 to: 100 do:[:i |
		fullCache atFont: font3 charCode: i type: 3 put: font1ZGlyph].
	fifo := fullCache instVarNamed: #fifo.
	self assert: (fifo detect:[:each | each type = 1] ifNone:[]) notNil.
	self assert: (fifo detect:[:each | each type = 2] ifNone:[]) notNil.
	self assert: (fifo detect:[:each | each type = 3] ifNone:[]) notNil.
	fullCache removeAllForType: 1.
	self validateSizes: fullCache.
	self validateCollections: fullCache.
	fifo := (fullCache instVarNamed: #fifo).
	self assert: (fifo detect:[:each | each type = 1] ifNone:[]) isNil.
	self assert: (fifo detect:[:each | each type = 2] ifNone:[]) notNil.
	self assert: (fifo detect:[:each | each type = 3] ifNone:[]) notNil.! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
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 equals: 100.
	self validateSizes: cache.
	self validateCollections: cache! !

!FreeTypeCacheTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	cache := FreeTypeCache new.
	font1 := FreeTypeFont basicNew.
	font2 := FreeTypeFont basicNew.
	font3 := FreeTypeFont basicNew.
	font1XGlyph := (GlyphForm extent: 100@100 depth: 32)
		advance: 100;
		linearAdvance: 10000;
		yourself.
	font1YGlyph := (GlyphForm extent: 100@100 depth: 32)
		advance: 100;
		linearAdvance: 10000;
		yourself.
	font1ZGlyph := (GlyphForm extent: 100@100 depth: 32)
		advance: 100;
		linearAdvance: 10000;
		yourself.
	fullCache := FreeTypeCache new.
	fullCache 
		maximumSize: (10*(fullCache sizeOf: font1YGlyph))..
	1 to: 10 do:[:i |
		fullCache atFont: font1 charCode: i type: FreeTypeCacheGlyph put: font1YGlyph].! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
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 identicalTo: font1XGlyph.
	self validateSizes: cache.
	self validateCollections: cache! !

!FreeTypeCacheTest methodsFor: 'private' stamp: ''!
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 equals: used.
	self assert: (max isNil or: [ used <= max ])! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
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 identicalTo: font1XGlyph.
	self validateSizes: cache.
	self validateCollections: cache! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
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 identicalTo: font1XGlyph.
	self validateSizes: cache.
	self validateCollections: cache! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testSingleton
	self assert: FreeTypeCache current class equals: FreeTypeCache.
	self assert: FreeTypeCache current identicalTo: FreeTypeCache current! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testRemoveAll
	| m fifo fontTable |
	m := fullCache instVarNamed: #maximumSize.
	fifo := fullCache instVarNamed: #fifo.
	fontTable := fullCache instVarNamed: #fontTable.
	fullCache removeAll.
	self assertEmpty: (fullCache instVarNamed: #fifo).
	self assertEmpty: (fullCache instVarNamed: #fontTable).
	self assert: (fullCache instVarNamed: #used) equals: 0.
	self assert: m equals: (fullCache instVarNamed: #maximumSize).
	self assert: fifo class equals: (fullCache instVarNamed: #fifo) class.
	self assert: fontTable class equals: (fullCache instVarNamed: #fontTable) class! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
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 identicalTo: font1XGlyph.
	self validateSizes: cache.
	self validateCollections: cache! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testGlyphAccessIsThreadSafe

	"This test is weak because it depends in the rendering of Morphic and Rubrik"
	"This test breaks 95% of times"	

	self timeLimit: 20 seconds.
	
	10 timesRepeat: [  
		 | sem text canvases blocky |

		sem := Semaphore new.
		text := (String loremIpsum: 25*1024).
		FreeTypeCache current removeAll.
		canvases := OrderedCollection new.
			
		blocky := [  | canvas |
			canvas := FormCanvas extent: 1000@1000.
			canvases add: canvas.
			(RubScrolledTextMorph new)
					setText: text;
					font: StandardFonts codeFont;
					bounds: (0@0 corner: canvas form extent);
					fullDrawOn: canvas.
			sem signal ].
			
		blocky forkAt: 39.
		blocky forkAt: 39.
		blocky forkAt: 39.
		
		sem 
			wait;
			wait;
			wait.	
			
		self assert: (((canvases at:1) form bits = (canvases at:2) form bits) and: [ ((canvases at:2) form bits = (canvases at:3) form bits) ]) 
	].! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
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) equals: 0.	"cache has been cleared on reaching max size"
	self validateSizes: cache.
	self validateCollections: cache.
	self should: [ cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph ] raise: Error.
	self should: [ cache atFont: font1 charCode: $Y asInteger type: FreeTypeCacheGlyph ] raise: Error! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testGlyphAccessIsThreadSafeWhenAskingWidth

	"This test is weak because it depends in the rendering of Morphic and Rubrik"
	"This test breaks 95% of times"	

	self timeLimit: 20 seconds.
	
	10 timesRepeat: [  
		 | sem text canvases blocky widthAsk |

		sem := Semaphore new.
		text := (String loremIpsum: 25*1024).
		FreeTypeCache current removeAll.
		canvases := OrderedCollection new.

		widthAsk := [
			1 to: text size do: [ :i | StandardFonts codeFont widthOf: (text at: i). i % 50 = 0 ifTrue: [ Processor yield ]].
			sem signal ].

			
		blocky := [  | canvas |
			canvas := FormCanvas extent: 1000@1000.
			canvases add: canvas.
			(RubScrolledTextMorph new)
					setText: text;
					font: StandardFonts codeFont;
					bounds: (0@0 corner: canvas form extent);
					fullDrawOn: canvas.
			sem signal ].
			
		blocky forkAt: 39.
		blocky forkAt: 39.
		blocky forkAt: 39.
		widthAsk forkAt: 39.
		
		sem 
			wait;
			wait;
			wait;
			wait.	
			
		self assert: (((canvases at:1) form bits = (canvases at:2) form bits) and: [ ((canvases at:2) form bits = (canvases at:3) form bits) ]) 
	].! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testRemoveAllForFont
	| fifo |

	fullCache maximumSize: nil.	
	1 to: 100 do:[:i |
		fullCache atFont: font1 charCode: i type: 1 put: font1XGlyph].
	1 to: 100 do:[:i |
		fullCache atFont: font2 charCode: i type: 2 put: font1YGlyph].
	1 to: 100 do:[:i |
		fullCache atFont: font3 charCode: i type: 3 put: font1ZGlyph].
	fifo := fullCache instVarNamed: #fifo.
	self assert: (fifo detect:[:each | each font = font1] ifNone:[]) notNil.
	self assert: (fifo detect:[:each | each font = font2] ifNone:[]) notNil.
	self assert: (fifo detect:[:each | each font = font3] ifNone:[]) notNil.
	fullCache removeAllForFont: font1.
	self validateSizes: fullCache.
	self validateCollections: fullCache.
	fifo := (fullCache instVarNamed: #fifo).
	self assert: (fifo detect:[:each | each font = font1] ifNone:[]) isNil.
	self assert: (fifo detect:[:each | each font = font2] ifNone:[]) notNil.
	self assert: (fifo detect:[:each | each font = font2] ifNone:[]) notNil.! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testSetMaximumSizeGrow
	| u m |
	u := fullCache instVarNamed: #used.
	m := fullCache instVarNamed: #maximumSize.
	fullCache maximumSize: m * 2.	"grow"
	self assert: u equals: (fullCache instVarNamed: #used).
	self validateSizes: cache.
	self validateCollections: cache! !

!FreeTypeCacheTest methodsFor: 'tests' stamp: ''!
testConstants
	| constants |
	constants := {FreeTypeCacheWidth . FreeTypeCacheGlyphMono . FreeTypeCacheGlyphLCD . FreeTypeCacheGlyph}.
	self assert: constants asSet size equals: constants size.	"no 2 have same value"
	self assert: (constants detect: [ :x | x isNil ] ifNone: [  ]) isNil	"no value is nil"! !

!FreeTypeEmbeddedFileInfo commentStamp: ''!
File info for embbeded FreeType fonts!
!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: ''!
fileContents: anObject
	"Set the value of fileContents"

	fileContents := anObject! !

!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: ''!
fileContents
	"Answer the value of fileContents"

	^ fileContents! !

!FreeTypeEmbeddedFileInfo methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
 			nextPut: ${;
			print: self locationType;
 			nextPut: $};
 			nextPut: $(;
			print: fileContents size;
			nextPutAll: ' bytes )';
 			nextPut: $[;
			print: index;
			nextPutAll: '] ';
			print: familyName;
			nextPutAll: ' - ';
			print: styleName;
			nextPutAll: ' - ';
			print: postscriptName;
 			space;
			nextPutAll:
				(bold
					ifTrue: [ 'B' ]
					ifFalse: [ '' ]);
			nextPutAll: ' ';
			nextPutAll:
				(italic
					ifTrue: [ 'I' ]
					ifFalse: [ '' ]);
			nextPutAll: ' ';
			nextPutAll:
				(fixedWidth
					ifTrue: [ 'Monospaced' ]
					ifFalse: [ '' ]);
			nextPutAll: ' ';
			print: stretchValue;
			nextPutAll: ' ';
			print: weightValue;
			cr! !

!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: ''!
fileSize
	^fileContents size! !

!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: ''!
locationType
	"Answer the value of locationType"

	^ #embedded! !

!FreeTypeEmbeddedFileInfo methodsFor: 'testing' stamp: ''!
isEmbedded
	^true! !

!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: ''!
baseName
	"Answer the value of baseName"

	^ baseName! !

!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: ''!
baseName: anObject
	"Set the value of baseName"

	baseName := anObject! !

!FreeTypeExternalMemory commentStamp: ''!
FreeType externalMemory !
!FreeTypeExternalMemory methodsFor: 'primitives' stamp: ''!
primCopyToExternalMemory: aByteArray
	"copy aByteArray into newly allocated, external memory, and store the
	address of that memory in the receiver's handle"

	handle := ExternalAddress allocate: aByteArray size.
	LibC memCopy: aByteArray to: handle size: aByteArray size.! !

!FreeTypeExternalMemory methodsFor: 'validation' stamp: ''!
validate
	self isValid ifTrue: [ ^ self ].
	bytes ifNil: [ ^ self  ].
	
	self primCopyToExternalMemory: bytes.
	self autoRelease! !

!FreeTypeExternalMemory methodsFor: 'accessing' stamp: ''!
bytes: aByteArray
	bytes := aByteArray! !

!FreeTypeExternalMemory methodsFor: 'accessing' stamp: ''!
bytes
	^bytes! !

!FreeTypeExternalMemory class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #bytes:'! !

!FreeTypeExternalMemory class methodsFor: 'instance creation' stamp: ''!
bytes: aByteArray
	^ self basicNew
		bytes: aByteArray;
		autoRelease;
		yourself! !

!FreeTypeExternalMemory class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: handle

	handle ifNil: [ ^ self ].
	handle isNull
		ifTrue: [ ^ self ].
	handle free.
	handle beNull! !

!FreeTypeFace commentStamp: ''!
Do not rearrange these fields!!!
!FreeTypeFace methodsFor: 'testing' stamp: ''!
hasStyleName
	^super styleName notNil! !

!FreeTypeFace methodsFor: 'accessing' stamp: ''!
filename
	^filename! !

!FreeTypeFace methodsFor: 'initialization' stamp: ''!
actAsExecutor
	super actAsExecutor.
	filename := '<finalizer>'.! !

!FreeTypeFace methodsFor: 'copying' stamp: ''!
postCopy 

	handle beNull.
	self validate.
	self autoRelease.
	^ self! !

!FreeTypeFace methodsFor: 'validation' stamp: ''!
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"
	
	(self isValid 
		and: [ numCharmaps notNil ]) 
		ifTrue: [ ^ self ].
	
	self create! !

!FreeTypeFace methodsFor: 'validation' stamp: ''!
create
	"create me in FT2. This gets my handle, and loads the fields"
	
	fileContentsExternalMemory 
		ifNotNil: [ self newFaceFromExternalMemory: fileContentsExternalMemory index: index ]	
		ifNil: [	self newFaceFromFile: filename asFileReference index: index ].
			
	self loadFields.! !

!FreeTypeFace methodsFor: 'testing' stamp: ''!
hasFamilyName
	^super familyName notNil! !

!FreeTypeFace methodsFor: 'accessing' stamp: ''!
fileContentsExternalMemoryBytes
	^fileContentsExternalMemory ifNotNil:[fileContentsExternalMemory bytes]! !

!FreeTypeFace methodsFor: 'accessing' stamp: ''!
familyName
	^super familyName ifNil:['?']! !

!FreeTypeFace methodsFor: 'accessing' stamp: ''!
fileContentsExternalMemory: aFreeTypeExternalMemory
	fileContentsExternalMemory := aFreeTypeExternalMemory! !

!FreeTypeFace methodsFor: 'testing' stamp: ''!
hasKerning
	"FT_FACE_FLAG_KERNING = 64 (1 << 6)"

	^ hasKerning ifNil: [ hasKerning := (faceFlags bitAnd: 64) = 64 ]! !

!FreeTypeFace methodsFor: 'accessing' stamp: ''!
filename: aString
	filename := aString! !

!FreeTypeFace methodsFor: 'accessing' stamp: ''!
index: anInteger
	index := anInteger! !

!FreeTypeFace methodsFor: 'caching' stamp: ''!
releaseCachedState

	hasKerning := nil.! !

!FreeTypeFace methodsFor: 'accessing' stamp: ''!
styleName
	^super styleName ifNil:['']! !

!FreeTypeFace methodsFor: 'accessing' stamp: ''!
index
	^index! !

!FreeTypeFace class methodsFor: 'instance creation' stamp: ''!
fromBytes: aByteArray index: anInteger
	"share alike instances"
	| newFace |
	
	self allInstancesDo: [:inst |
		(inst fileContentsExternalMemoryBytes = aByteArray and: [inst index = anInteger])
			ifTrue: [^inst "validate"]].
	newFace := self basicNew
		fileContentsExternalMemory: (FreeTypeExternalMemory bytes: aByteArray);
		index: anInteger;
		autoRelease;
		yourself.
	^ newFace! !

!FreeTypeFace class methodsFor: 'font dirs' stamp: ''!
rememberFontDir: aDirecory! !

!FreeTypeFace class methodsFor: 'instance creation' stamp: ''!
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;
		autoRelease;
		yourself! !

!FreeTypeFace class methodsFor: 'font dirs' stamp: ''!
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! !

!FreeTypeFileInfo commentStamp: ''!
File infos for a FreeType font!
!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
modificationTime
	"Answer the value of modificationTime"

	^ modificationTime! !

!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
absolutePath: anObject
	"Set the value of absolutePath"

	absolutePath := anObject! !

!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
absoluteOrRelativePath: anObject
	"Set the value of absoluteOrRelativePath"

	absoluteOrRelativePath := anObject! !

!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
absoluteOrRelativePath
	"Answer the value of absoluteOrRelativePath"

	^ absoluteOrRelativePath! !

!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
absolutePath
	"Answer the value of absolutePath"

	^ absolutePath! !

!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
locationType: anObject
	"Set the value of locationType"

	locationType := anObject! !

!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
fileSize
	"Answer the value of fileSize"

	^ fileSize! !

!FreeTypeFileInfo methodsFor: 'printing' stamp: ''!
printOn: aStream
	"super printOn: aStream."
	aStream 
		nextPutAll: familyGroupName asString, '::',styleNameExtracted asString, ' '; 
		nextPutAll:  
			(locationType = #absolute 
				ifTrue:[''] 
				ifFalse:['{',locationType asString,'}']);
		nextPutAll: absoluteOrRelativePath asString;
		nextPutAll: '[',index asString,'] ';
		nextPutAll: familyName asString;
		nextPutAll: ' - ', styleName asString;
		nextPutAll: ' - ', postscriptName asString;		
		nextPutAll: ' ',(bold ifTrue:['B'] ifFalse:['']);
		nextPutAll: ' ',(italic ifTrue:['I'] ifFalse:['']);
		nextPutAll: ' ',(fixedWidth ifTrue:['Monospaced'] ifFalse:['']);
		nextPutAll: ' ',(stretchValue asString);
		nextPutAll: ' ',(weightValue asString);	
		cr! !

!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
locationType
	"Answer the value of locationType"

	^ locationType! !

!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
fileSize: anObject
	"Set the value of fileSize"

	fileSize := anObject! !

!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
baseName
	^ absolutePath asFileReference basename! !

!FreeTypeFileInfo methodsFor: 'accessing' stamp: ''!
modificationTime: anObject
	"Set the value of modificationTime"

	modificationTime := anObject! !

!FreeTypeFileInfoAbstract commentStamp: ''!
Abstract superclass for file infos for a FreeType font!
!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
weightValue
	"Answer the value of weightValue"

	^ weightValue! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
bold
	"Answer the value of bold"

	^ bold! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
postscriptName: anObject
	"Set the value of postscriptName"

	postscriptName := anObject! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
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: ''!
isBolderThan: val
	^self weightValue >= val! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
isItalicOrOblique
	^self slantValue > 0! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
italic: anObject
	"Set the value of italic"

	italic := anObject! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
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: ''!
styleName: anObject
	"Set the value of styleName"

	styleName := anObject! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
weight
	"Answer the value of weight"

	^ weight! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
stretchValue
	"Answer the value of stretchValue"

	^ stretchValue! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
familyName: anObject
	"Set the value of familyName"

	familyName := anObject! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
bold: anObject
	"Set the value of bold"

	bold := anObject! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
slantValue
	^slantValue! !

!FreeTypeFileInfoAbstract methodsFor: 'testing' stamp: ''!
isEmbedded
	^false! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
index: anObject
	"Set the value of index"

	index := anObject! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
index
	"Answer the value of index"

	^ index! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
fixedWidth
	"Answer the value of fixedWidth"

	^ fixedWidth! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
italic
	"Answer the value of italic"

	^ italic! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
stretch
	"Answer the value of stretch"

	^ stretch! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
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: ''!
postscriptName
	"Answer the value of postscriptName"

	^ postscriptName! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
stretchValue: anObject
	"Set the value of stretchValue"

	stretchValue := anObject! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
fixedWidth: anObject
	"Set the value of fixedWidth"

	fixedWidth := anObject! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
numFaces: anObject
	"Set the value of numFaces"

	numFaces := anObject! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
familyGroupName
	"Answer the value of familyGroupName"

	^ familyGroupName! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
style
	"Answer the value of slant"

	^ slant! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
numFaces
	"Answer the value of numFaces"

	^ numFaces! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
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: ''!
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: ''!
weightValue: anObject
	"Set the value of weightValue"

	weightValue := anObject! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
familyName
	"Answer the value of familyName"

	^ familyName! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
styleName
	"Answer the value of styleName"

	^ styleName! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
slant
	"Answer the value of slant"

	^ slant! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
styleNameExtracted
	^styleNameExtracted! !

!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: ''!
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! !

!FreeTypeFont commentStamp: ''!
A FreeType font!
!FreeTypeFont methodsFor: 'measuring' stamp: ''!
widthAndKernedWidthCache
	^widthAndKernedWidthCache ifNil:[widthAndKernedWidthCache := Dictionary new]! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
isTTCFont
	"not really - look for senders of this"
	^true! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
face: aFace
	face := aFace! !

!FreeTypeFont methodsFor: 'displaying' stamp: ''!
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 useSubPixelAntiAliasing 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: 'comparing' stamp: ''!
hash
	^pointSize hash! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
pointSize: aSize
	pointSize := aSize! !

!FreeTypeFont methodsFor: 'displaying' stamp: ''!
displayStrikeoutOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint
	| top bottom strikeoutThickness s e |
	
	"the strikeout size/position for TrueType fonts should really come from the TT_OS2 table.
	This needs to be read by the plugin when the face is created.
	For now, we use the underlineThickness, and 1/4 of the ascender from the baseline"
	strikeoutThickness := (self face underlineThickness * self pixelSize / self face unitsPerEm). 			
	top := ((self face ascender / 4) * self pixelSize / self face unitsPerEm) negated - (strikeoutThickness/2).
	top := top rounded.
	bottom := top + strikeoutThickness ceiling.
	s := baselineStartPoint + (0@top).
	e := baselineEndPoint + (0@bottom).
	self displayLineGlyphOn: aDisplayContext from: s to: e! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
depth

	^ 32.! !

!FreeTypeFont methodsFor: 'displaying' stamp: ''!
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: 'measuring' stamp: ''!
hintedKerningLeft: leftChar right: rightChar
	^(self linearKerningLeft: leftChar right: rightChar) rounded! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
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 isSimulatedStyle ifFalse:[^0].
	italic := self isSimulatedItalic.
	faceItalic := face isItalic.
	(italic and: [faceItalic not])
		ifTrue:[^self defaultSimulatedItalicSlant].
	^0! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
descent
	^cachedDescent ifNil:[ 
		cachedDescent := ((self face descender * self pixelSize // self face unitsPerEm) negated) ]! !

!FreeTypeFont methodsFor: 'metrics' stamp: ''!
underlineThickness
	^ self face underlineThickness * self pixelSize / self face unitsPerEm.! !

!FreeTypeFont methodsFor: 'glyph lookup' stamp: ''!
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: 'measuring' stamp: ''!
getLinearWidthOf: aCharacter 
	| em glyph la charCode |

	aCharacter < $  ifTrue: [^self getLinearWidthOf: $ ].
	charCode := aCharacter asUnicode asInteger.
	(self face charmaps includes:'unic')
		ifTrue:[
			(self isSymbolFont and: [ charCode between: 16r20 and: 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 , PrimitiveFailed 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: 'testing' stamp: ''!
isItalic
	^(simulatedEmphasis == nil and:[self face isItalic])
		or:[self isSimulatedItalic]! !

!FreeTypeFont methodsFor: 'initialization' stamp: ''!
initialize: aFont

	self face: aFont face.! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
isSimulatedBold
	^self simulatedEmphasis anyMask: 1! !

!FreeTypeFont methodsFor: '*Athens-Text' stamp: ''!
getPreciseHeight
	"get precise font ascent, can be floating value"
	
	^(self face height * self pixelSize / self face unitsPerEm) asFloat.! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
isSimulatedStyle
	^simulatedEmphasis notNil! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
face
	"Validate, and answer, the receiver's face"
	
	^face validate! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
pixelSize
	^pixelSize ifNil:[pixelSize := super pixelSize rounded]! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
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: 'glyph lookup' stamp: ''!
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: 'accessing' stamp: ''!
postscriptName
	^self face postscriptName! !

!FreeTypeFont methodsFor: '*Athens-Text' stamp: ''!
getPreciseDescent
	"we using face bouding box for getting ascent value, otherwise two different
	font sizes on same line won't align properly"
	
	^(self face descender * self pixelSize / self face unitsPerEm) asFloat negated.! !

!FreeTypeFont methodsFor: '*FreeType-Graphics' stamp: ''!
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 useSubPixelAntiAliasing and: [depth >= 8])
		ifTrue:[
			aDisplayContext 
				combinationRule: 41.
			aDisplayContext 
				copyBitsColor: foreColorVal 
				alpha: foreColorAlpha 
				gammaTable: FreeTypeSettings current gammaTable
				ungammaTable: FreeTypeSettings current gammaInverseTable]
		ifFalse:[
			glyph fillWithColor: foreColor.
			aDisplayContext combinationRule: (depth <= 8 ifTrue: [Form paint] ifFalse: [34]).
			aDisplayContext copyBits].		
	aDisplayContext 
		colorMap: originalColorMap;
		combinationRule: oldCombinationRule;
		halftoneForm: oldHalftoneForm.! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
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 ffiGetCharIndex: c asInteger) = 0
			ifTrue:[^false]].
	^true! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
height

	^cachedHeight ifNil:[
		cachedHeight := (self face height * self pixelSize / self face unitsPerEm) ceiling ]! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
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: 'glyph lookup' stamp: ''!
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 useSubPixelAntiAliasing])
				ifTrue:[
					self 
						mode41GlyphOf: aCharacter
						colorValue: aColorValue
						mono: FreeTypeSettings current monoHinting
						subpixelPosition: validSub]
				ifFalse:[
					self 
						glyphOf: aCharacter
						colorValue: aColorValue
						mono: FreeTypeSettings current monoHinting
						subpixelPosition: validSub]]! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
isRegular
	^(simulatedEmphasis == nil and:[self face isRegular])
		or: [self isSimulatedRegular]! !

!FreeTypeFont methodsFor: '*Athens-Text' stamp: ''!
getPreciseAscent
	"we using face bouding box for getting ascent value, otherwise two different
	font sizes on same line won't align properly"
	
	^(self face ascender * self pixelSize / self face unitsPerEm) asFloat.! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
isBold
	^(simulatedEmphasis == nil and:[self face isBold])
		or:[self isSimulatedBold]! !

!FreeTypeFont methodsFor: 'glyph lookup' stamp: ''!
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: 'testing' stamp: ''!
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 ffiGetCharIndex: c asInteger) = 0
			ifTrue:[^false]
			ifFalse:[
				(setOfIndices includes: i)
					ifTrue:[^false]
					ifFalse:[setOfIndices add: i]]].
	^true! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
minAscii
	"should have default in AbstractFont"
	^0! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
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: ''!
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: 'displaying' stamp: ''!
installOn: aBitBlt foregroundColor: foreColor backgroundColor: backColor

	| |
	"fcolor := foreColor pixelValueForDepth: 32."
	aBitBlt installFreeTypeFont: self foregroundColor: foreColor backgroundColor: backColor.! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
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 between: 16r20 and: 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, PrimitiveFailed 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: ''!
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: 'glyph lookup' stamp: ''!
characterRenderingOptimizedFormAt: aCharacter
	FreeTypeSettings current useSubPixelAntiAliasing ifFalse: [ ^ super characterRenderingOptimizedFormAt: aCharacter ].
	
	^ (self 
		glyphOf: aCharacter 
		destDepth: 32 
		colorValue: (Color white pixelValueForDepth: 32)
		subpixelPosition: 0) withAlphaExtractedFromSubpixelRendering! !

!FreeTypeFont methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self class name;
		nextPut: $(;
		print: face familyName;
		space;
		print: face styleName;
		space;
		print: pointSize;
		nextPut: $)! !

!FreeTypeFont methodsFor: '*Text-Scanning' stamp: ''!
scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX
	"scan a multibyte character string"
	^aCharacterScanner scanKernableMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString rightX: rightX ! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
subPixelPositioned
	"Answer true if the receiver is currently using subpixel positioned
	glyphs, false otherwise. This affects how padded space sizes are calculated
	when composing text."
	| settings |
	^subPixelPositioned 
		ifNil:[
			settings := FreeTypeSettings current.
			subPixelPositioned := settings hinting not or:[settings lightHinting]]! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
isSimulatedRegular
	^simulatedEmphasis = 0! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
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 isSimulatedStyle ifFalse:[^0].
	bold := self isSimulatedBold.
	faceBold := face isBold.
	(bold and: [faceBold not])
		ifTrue:[^self pixelSize/24].
	^0! !

!FreeTypeFont methodsFor: 'emphasis' stamp: ''!
emphasized: code
	"empty stub, see https://github.com/pharo-project/pharo/issues/7550"! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
hasSubPixelAntiAliasing
	^ FreeTypeSettings current useSubPixelAntiAliasing! !

!FreeTypeFont methodsFor: '*FreeType-Morphic' stamp: ''!
gtInspectorFontIn: composite
	<gtInspectorPresentationOrder: 0>
	composite morph
		title: 'Font';
		display: [ :x | | pane |
			pane := ScrollPane new
						alwaysShowScrollBars: true;
						yourself.
			pane scroller addMorph:
					((String streamContents: [ :s | 22 to: 255 do: [ :idx | s nextPut: idx asCharacter ] ]) asMorph
						font: x;
						yourself).
			pane ]! !

!FreeTypeFont methodsFor: 'initialization' stamp: ''!
releaseCachedState
	face releaseCachedState.
	FreeTypeCache current removeAllForFont: self.! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
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 between: 16r20 and: 16rFF)
						ifTrue:[l := (Character value: l asInteger + 16rF000) asUnicode].
					(r asInteger between: 16r20 and: 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 between: 16r20 and: 16rFF)
						ifTrue:[l := (Character value: l asInteger) unicodeToMacRoman].
					(r asInteger between: 16r20 and: 16rFF)
						ifTrue:[r := (Character value: r asInteger) unicodeToMacRoman]]].
	^(f kerningLeft: l right: r) x asFloat *  self pixelSize / f unitsPerEm! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
setFace: aFreetypeFace pointSize: anInteger
	face := aFreetypeFace.
	pointSize := anInteger.! !

!FreeTypeFont methodsFor: 'displaying' stamp: ''!
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: 'measuring' stamp: ''!
lineGrid

	^self height! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
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: '*Athens-Text' stamp: ''!
getGlyphWidth: aCharacter 
	aCharacter asciiValue = 9 ifTrue: [ 
		^  (self linearWidthOf: Character space) * 8
		]. 
	^ (self linearWidthOf: aCharacter)! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
isFixedWidth
	^self face isFixedWidth! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
maxAscii
	"should have default in AbstractFont"
	^SmallInteger maxVal! !

!FreeTypeFont methodsFor: 'metrics' stamp: ''!
underlineTop
	^ ((self face underlinePosition * self pixelSize / self face unitsPerEm) negated - (self underlineThickness/2)) rounded + 1 "needs the +1 , possibly because glyph origins are moved down by 1 so that their baselines line up with strike fonts"! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
veryDeepCopyWith: deepCopier! !

!FreeTypeFont methodsFor: '*Athens-Text' stamp: ''!
glyphRendererOn: anAthensSurface

	self validate.
	^ anAthensSurface getFreetypeFontRendererFor: self! !

!FreeTypeFont methodsFor: '*Text-Scanning' stamp: ''!
scanByteCharactersFrom: startIndex to: stopIndex in: aByteString with: aCharacterScanner rightX: rightX
	"scan a single byte character string"
	^aCharacterScanner scanKernableByteCharactersFrom: startIndex to: stopIndex in: aByteString rightX: rightX! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
clearCachedMetrics
	widthAndKernedWidthCache := cachedHeight := cachedAscent := cachedDescent := subPixelPositioned := nil! !

!FreeTypeFont methodsFor: 'metrics' stamp: ''!
strikeoutThickness
	^ self underlineThickness! !

!FreeTypeFont methodsFor: '*Athens-Text' stamp: ''!
asFreetypeFont
	^ self! !

!FreeTypeFont methodsFor: 'validation' stamp: ''!
validate 
	self face validate! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
mutex

	^ mutex ifNil: [ mutex := Semaphore forMutualExclusion ]! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
defaultSimulatedItalicSlant
	^0.22! !

!FreeTypeFont methodsFor: 'metrics' stamp: ''!
strikeoutTop
	^ (((self face ascender / 4) * self pixelSize / self face unitsPerEm) negated - (self strikeoutThickness/2)) rounded.! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
descentKern
	"should have default in AbstractFont"
	^0! !

!FreeTypeFont methodsFor: 'notifications' stamp: ''!
pixelsPerInchChanged
	"the TextStyle pixels per inch setting has changed"
	
	pixelSize := nil.
	widthAndKernedWidthCache := nil.
	FreeTypeCache current removeAllForFont: self.! !

!FreeTypeFont methodsFor: 'accessing' stamp: ''!
familyName 

	^face familyName! !

!FreeTypeFont methodsFor: 'glyph lookup' stamp: ''!
characterFormAt: aCharacter
	FreeTypeSettings current 
		forceNonSubPixelDuring:[
			^self 
				glyphOf: aCharacter 
				destDepth: 32 
				colorValue: (Color black pixelValueForDepth: 32)
				subpixelPosition: 0]! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
pointSize
	^pointSize! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
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: ''!
basicAscent

	^(self face ascender * self pixelSize // self face unitsPerEm).! !

!FreeTypeFont methodsFor: 'testing' stamp: ''!
isSimulatedItalic
	^self simulatedEmphasis anyMask: 2! !

!FreeTypeFont methodsFor: 'measuring' stamp: ''!
kerningLeft: leftChar right: rightChar
	^self isSubPixelPositioned
		ifTrue: [self linearKerningLeft: leftChar right: rightChar]
		ifFalse:[self hintedKerningLeft: leftChar right: rightChar]! !

!FreeTypeFont class methodsFor: 'instance creation' stamp: ''!
fromBytes: aByteArray pointSize: anInteger
	^self fromBytes: aByteArray pointSize: anInteger index: 0! !

!FreeTypeFont class methodsFor: 'instance creation' stamp: ''!
fromFile: aFileName pointSize: anInteger index: i
	^self new
		setFace: (FreeTypeFace fromFile: aFileName index: i) pointSize: anInteger; 
		yourself! !

!FreeTypeFont class methodsFor: 'instance creation' stamp: ''!
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: ''!
fromBytes: aByteArray pointSize: anInteger  index: i
	^self new
		setFace: (FreeTypeFace fromBytes: aByteArray index: i) pointSize: anInteger; 
		yourself! !

!FreeTypeFont class methodsFor: 'instance creation' stamp: ''!
fromFile: aFileName pointSize: anInteger 
	^ self fromFile: aFileName pointSize: anInteger index: 0! !

!FreeTypeFontFamily commentStamp: ''!
FreeType font family!
!FreeTypeFontFamily methodsFor: 'accessing' stamp: ''!
addMember: aFreeTypeFontFamilyMember
	aFreeTypeFontFamilyMember family: self.
	members add: aFreeTypeFontFamilyMember! !

!FreeTypeFontFamily methodsFor: 'simulated members' stamp: ''!
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 isSimulatedStyle
					ifTrue:[members add: regular asSimulatedBoldOblique]
					ifFalse:[	members add: regular asSimulatedOblique]]]! !

!FreeTypeFontFamily methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	members := OrderedCollection new.! !

!FreeTypeFontFamily methodsFor: 'simulated members' stamp: ''!
rebuildSimulatedMembers
	"FOR TESTING ONLY"
	
	members := members reject:[:each| each isSimulatedStyle ].
	self addSimulatedMembers.! !

!FreeTypeFontFamily methodsFor: 'accessing' stamp: ''!
addMembersFromFileInfos: aCollectionOfFreeTypeFileInfo
	
	
	aCollectionOfFreeTypeFileInfo do:[:aFileInfo | | member |
		member := FreeTypeFontFamilyMember fromFileInfo: aFileInfo.
		(self memberWithStyleName: member styleName)
			ifNil:[self addMember: member]].! !

!FreeTypeFontFamily methodsFor: 'accessing' stamp: ''!
memberWithStyleName: aString
	^members detect:[:each | each styleName = aString] ifNone:[]! !

!FreeTypeFontFamilyMember commentStamp: ''!
FreeType FontFamily member  !
!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
beSimulatedStyle

	isSimulatedStyle := true! !

!FreeTypeFontFamilyMember methodsFor: 'testing' stamp: ''!
isSimulatedStyle 
	"Return true if the receiver is a simulated style"
	
	^isSimulatedStyle! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
weightValue
	"Answer the value of weightValue"

	^ weightValue! !

!FreeTypeFontFamilyMember methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	isSimulatedStyle := false! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
stretchValue: anObject
	"Set the value of stretchValue"

	stretchValue := anObject! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
fileInfo: anObject
	"Set the value of fileInfo"

	fileInfo := anObject! !

!FreeTypeFontFamilyMember methodsFor: 'converting' stamp: ''!
asSimulatedBold
	^self copy 
		weightValue: LogicalFont weightBold;
		styleName: (fileInfo styleNameWithWeightForcedToBe: 'Bold');
		beSimulatedStyle;
		yourself! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
fileInfo
	"Answer the value of fileInfo"

	^ fileInfo! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
slantName
	"Answer the value of slantName"

	^ slantName! !

!FreeTypeFontFamilyMember methodsFor: 'comparing' stamp: ''!
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 isSimulatedStyle ifTrue:[ 10000 ] ifFalse:[ 0 ].
	v := v + (stretchValue * 1000).
	v := v + (normalizedWeight).
	v := v + (slantValue).
	^v! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
weightName: anObject
	"Set the value of weightName"

	weightName := anObject! !

!FreeTypeFontFamilyMember methodsFor: 'converting' stamp: ''!
asSimulatedOblique
	^self copy 
		slantValue: LogicalFont slantItalic;  "treat italic and oblique the same"
		styleName: (fileInfo styleNameWithItalicForcedToBe: 'Oblique');
		beSimulatedStyle;
		yourself! !

!FreeTypeFontFamilyMember methodsFor: 'converting' stamp: ''!
asSimulatedBoldOblique
	^self copy 
		slantValue: LogicalFont slantItalic; "treat italic and oblique the same"
		weightValue:LogicalFont weightBold;
		styleName: (fileInfo styleNameWithWeightForcedToBe: 'Bold' italicForcedToBe: 'Oblique');
		beSimulatedStyle;
		yourself! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
stretchValue
	"Answer the value of stretchValue"

	^ stretchValue! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
weightValue: anObject
	"Set the value of weightValue"

	weightValue := anObject! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
slantValue
	"Answer the value of slantValue"

	^ slantValue! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
stretchName
	"Answer the value of stretchName"

	^ stretchName! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
weightName
	"Answer the value of weightName"

	^ weightName! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
stretchName: anObject
	"Set the value of stretchName"

	stretchName := anObject! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
slantName: anObject
	"Set the value of slantName"

	slantName := anObject! !

!FreeTypeFontFamilyMember methodsFor: 'comparing' stamp: ''!
<= aFreeTypeFontFamilyMember
	^self sortValue <= aFreeTypeFontFamilyMember sortValue! !

!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: ''!
slantValue: anObject
	"Set the value of slantValue"

	slantValue := anObject! !

!FreeTypeFontFamilyMember class methodsFor: 'instance creation' stamp: ''!
fromFileInfo: aFreeTypeFileInfo
	
	^self new
		fileInfo: aFreeTypeFileInfo;	 
		styleName: aFreeTypeFileInfo styleNameExtracted;
		stretchName: aFreeTypeFileInfo stretch;
		stretchValue: aFreeTypeFileInfo stretchValue;
		weightName: aFreeTypeFileInfo weight;
		weightValue: aFreeTypeFileInfo weightValue;
		slantName: aFreeTypeFileInfo slant;
		slantValue: aFreeTypeFileInfo slantValue;
		yourself! !

!FreeTypeFontFamilyMemberTest commentStamp: ''!
This class contains tests for class `FreeTypeFontFamilyMember`!
!FreeTypeFontFamilyMemberTest methodsFor: 'tests' stamp: ''!
testBeSimulatedStyle

	|member|
	member := FreeTypeFontFamilyMember new.
	self deny: member isSimulatedStyle.
	member beSimulatedStyle.
	self assert: member isSimulatedStyle.! !

!FreeTypeFontFamilyMemberTest methodsFor: 'tests' stamp: ''!
testIsNotSimulatedStyleByDefault

	self deny: FreeTypeFontFamilyMember new isSimulatedStyle! !

!FreeTypeFontProvider commentStamp: ''!
This is a font provider for true type fonts. You can use it to add TTF files to your image:

FreeTypeFontProvider current 
	updateFontsFromSystem;
	updateAvailableFontFamilies. 

You can add TTF fonts from a spetial dirrectory:
FreeTypeFontProvider current 
	updateFromDirectory: './fonts/' asFileReference done: Set new.

Then you can use font dialog:
	FreeTypeFontSelectorDialogWindow new open.

Or set for example set ballon or default font as following:
	StandardFonts balloonFont: 
	        (LogicalFont familyName: 'Arial'  pointSize: 10). 
	StandardFonts defaultFont: 
	        (LogicalFont familyName: 'Arial'  pointSize: 10).!
!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: ''!
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: 'font families' stamp: ''!
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: ''!
families
	
	^tempFamilies ifNil:[families]! !

!FreeTypeFontProvider methodsFor: 'file paths' stamp: ''!
platformAbsoluteDirectories
	Smalltalk os isWin32
		ifTrue: [ ^ self winFontDirectories ].
	Smalltalk os isUnix
		ifTrue: [ ^ self unixFontDirectories ].
	Smalltalk os isMacOSX
		ifTrue: [ ^ self macOSXFolderDirectories ].
	^ {}! !

!FreeTypeFontProvider methodsFor: 'font families' stamp: ''!
platformImageRelativeDirectories
	
	| directory |
	directory := self imageRelativeFontFolder.
	directory exists
		ifTrue: [ ^ { directory } ].
	^ #()! !

!FreeTypeFontProvider methodsFor: 'file paths' stamp: ''!
getWindowsFontFolderPath
	"Answer the windows font folder path.
	This is obtained through the Windows API if FFI is present,
	otherwise it is a guess !!"

	| tfExternalFunctionClass tfBasicType fun buff |
	tfExternalFunctionClass := Smalltalk globals at: #TFExternalFunction ifAbsent: [ ^ self guessWindowsFontFolderPath ].
	tfBasicType := Smalltalk globals at: #TFBasicType.
		
	fun := tfExternalFunctionClass
		       name: 'SHGetFolderPathA'
		       moduleName: 'shfolder.dll'
		       parameterTypes: { 
				       tfBasicType slong.
				       tfBasicType slong.
				       tfBasicType slong.
				       tfBasicType slong.
				       tfBasicType pointer }
		       returnType: tfBasicType slong.

	buff := ByteArray new: 1024.
	
	[ TFSameThreadRunner uniqueInstance invokeFunction: fun withArguments: { 0. 16r0014. 0. 0. buff } ]
		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: ''!
unixUsualDirectories
	"Trying with some common directories in unix. The prefered version is to read the /etc/fonts/fonts.conf"
	
	| localUserFonts |
	localUserFonts := FileLocator home / 'Library' / 'Fonts'.
	
	^ {localUserFonts} , #('/usr/share/fonts' '/usr/local/share/fonts') collect: [ :each | each asFileReference ] thenSelect: [ :each | each exists ]! !

!FreeTypeFontProvider methodsFor: 'file paths' stamp: ''!
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: 'accessing' stamp: ''!
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: 'file paths' stamp: ''!
macOSXFolderDirectories
	| localUserFonts |
	"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"
	
	"Adding some directories following the guidelines in https://support.apple.com/en-us/HT201722"
	
	localUserFonts := FileLocator home / 'Library' / 'Fonts'.
	
	^{localUserFonts} , #('/System/Library/Fonts' '/Network/Library/Fonts/' '/Library/Fonts')
		collect: [ :each| each asFileReference ]
		thenSelect: [ :each| each exists ].! !

!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: ''!
updateEmbeddedFreeTypeFonts
	"Ensure the provider is installed"	
	self addFontInstaller: EmbeddedFreeTypeFontInstaller current.
	"Now install embeded fonts"
	fontInstallers do: [ :each | each installAllFontsIn: self ].
	self buildFamilies! !

!FreeTypeFontProvider methodsFor: 'accessing' stamp: ''!
cacheFileInfo: aFreeTypeFileInfo index: i

	(fileInfoCache  at:  {aFreeTypeFileInfo fileSize. i} ifAbsentPut:[Set new])
		add:  aFreeTypeFileInfo! !

!FreeTypeFontProvider methodsFor: 'file paths' stamp: ''!
winFontDirectories
	| results |
	
	results := OrderedCollection new.
	
	self getWindowsFontFolderPath
		ifNotNil: [ :aString | | directory |
				directory := aString asFileReference.
				directory exists 
					ifTrue: [ results add: directory ]].
	
	self getWindowsLocalPaths
		do: [ :directory | 
				directory exists 
					ifTrue: [ results add: directory ]].
		
	^ results! !

!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: ''!
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: 'font families' stamp: ''!
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 lookup' stamp: ''!
fontFor: aLogicalFont familyName: familyName
	| info answer simulatedSqueakEmphasis needsSimulatedBold needsSimulatedSlant
	squeakBoldEmphasis squeakItalicEmphasis |
	
	FT2Library current isAvailable ifFalse:[^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: 'file paths' stamp: ''!
unixFontDirectories
	"Trying with some common directories in unix. The prefered version is to read the /etc/fonts/fonts.conf"

	| localUserFonts |
	localUserFonts := FileLocator home / '.fonts'.
	^ {localUserFonts} , #('/usr/share/fonts' '/usr/local/share/fonts') collect: [ :each | each asFileReference ] thenSelect: [ :each | each exists ]! !

!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: ''!
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 utf8Encoded asString.
	[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 newFaceFromFile: path index: i.
	face loadFields]
		on: FT2Error, PrimitiveFailed
		do: [:e | ^self failedToOpen: face from: path index: i ].
	(face height notNil  and:[face hasFamilyName and:[face hasStyleName and:[face isValid]]])
		ifFalse: [ ^self failedToOpen:face from: path index: i ]
		ifTrue: [
			numFaces ifNil: [numFaces := face numFaces].
			info :=FreeTypeFileInfo new
				absoluteOrRelativePath: aFile path isAbsolute;
				absolutePath: path; "used for quick lookup on same platform"
				locationType: #default;
				index: i;
				fileSize: aFile size;
				modificationTime: aFile modificationTime;
				familyName: face familyName;
				styleName: face styleName;
				postscriptName: face postscriptName;
				bold: face isBold;
				italic: face isItalic;
				fixedWidth: face isFixedWidth;
				numFaces: numFaces;
				extractAttributesFromNames;
				yourself.
			self addFileInfo: info index: i.
			self cacheFileInfo: info index: i.
			"Transcript show: 'from file : ', info asString."].
	i := i + 1.
	i < numFaces "note, we use < rather than <= , because i is zero based"] whileTrue:[].! !

!FreeTypeFontProvider methodsFor: 'accessing' stamp: ''!
addFileInfo: aFreeTypeFileInfo
	fileInfos add: aFreeTypeFileInfo! !

!FreeTypeFontProvider methodsFor: 'removing' stamp: ''!
removeFontInstaller: anEmbeddedFreeTypeFontInstaller 
	fontInstallers remove: anEmbeddedFreeTypeFontInstaller ifAbsent: [ ]! !

!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: ''!
prepareForUpdating
	
	tempFileInfos := fileInfos. "tempFileInfos will be used during update"
	tempFamilies := families.   "tempFamilies will be used during update"
	fileInfos := OrderedCollection  new: 100.! !

!FreeTypeFontProvider methodsFor: 'error handling' stamp: ''!
failedToOpen: face from: path index: i
	"Transcript cr; show: 'Failed : ', path asString, '[', i asString,']'."
	"remove all cache entries for path with index >= i"! !

!FreeTypeFontProvider methodsFor: 'error handling' stamp: ''!
failedToOpen: face index: i
	"Transcript cr; show: 'Failed : ', path asString, '[', i asString,']'."
	"remove all cache entries for path with index >= i"! !

!FreeTypeFontProvider methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	fileInfos := OrderedCollection  new: 100.
	fileInfoCache := Dictionary new: 100. "keyed by file size" 
	families := Dictionary new.
	fontInstallers := OrderedCollection new.! !

!FreeTypeFontProvider methodsFor: 'file paths' stamp: ''!
imageRelativeFontFolder
  ^SmalltalkImage current imageDirectory asFileReference / 'Fonts'! !

!FreeTypeFontProvider methodsFor: 'file paths' stamp: ''!
platformVMRelativeDirectories
  | directory |
  directory := Smalltalk vm directory asFileReference / 'Fonts'.
  directory exists ifTrue: [ ^{directory} ].
  ^#()! !

!FreeTypeFontProvider methodsFor: 'file paths' stamp: ''!
getWindowsLocalPaths
	
	"This values should be read from the repository in the key 
	HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Fonts
	However, things happened and we don't have support of the registry in the base image.
	So this is the best alternative... or not...??  "

	^ {(FileLocator home / 'AppData' / 'Local' / 'Microsoft' / 'Windows' / 'Fonts').
	(FileLocator home / 'AppData' / 'Roaming' / 'Microsoft' / 'Windows' / 'Fonts')}! !

!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: ''!
updateFileCacheInfo
	fileInfoCache values
		do: [ :col | col copy do: [ :each | each absolutePath asFileReference ifAbsent: [ col remove: each ] ] ]
		displayingProgress: [ 'Updating cached file info' ]! !

!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: ''!
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: 'accessing' stamp: ''!
addFirstFileInfo: aFreeTypeFileInfo index: i
	fileInfos addFirst: aFreeTypeFileInfo! !

!FreeTypeFontProvider methodsFor: '*EmbeddedFreeType-Tests' stamp: ''!
includesInstaller: anEmbeddedFreeTypeFontInstaller 
	^ fontInstallers identityIncludes: anEmbeddedFreeTypeFontInstaller! !

!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: ''!
updateFromSystem
	self prepareForUpdating.
	'FreeType' displayProgressFrom: 0 to: 3 during: [ :mainBar | 
		self updateFileCacheInfo.
		mainBar current: 1.
		self updateFontsFromSystem.
		mainBar current: 2.
		self updateAvailableFontFamilies.
		mainBar current: 3 ].
	LogicalFont allInstances do: [ :each | "in case they have a bad one" each clearRealFont ]! !

!FreeTypeFontProvider methodsFor: 'accessing' stamp: ''!
addFontInstaller: aFontInstaller
	(fontInstallers includes: aFontInstaller) ifTrue: [ ^ self ].
	fontInstallers add: aFontInstaller! !

!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: ''!
loadFromSystem
	self updateFromSystem.! !

!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: ''!
updateFontsFromSystem
	| done |
	"Add all the embedded file infos"
	FT2Library current isAvailable ifFalse: [ ^ self ].
	self updateEmbeddedFreeTypeFonts.
	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: 'accessing' stamp: ''!
addFileInfo: aFreeTypeFileInfo index: i
	fileInfos add: aFreeTypeFileInfo! !

!FreeTypeFontProvider methodsFor: 'font lookup' stamp: ''!
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: 'loading and updating' stamp: ''!
prepareForRelease

	"When releasing an image, we should only include the embedded fonts"

	self initialize.
	self updateEmbeddedFreeTypeFonts! !

!FreeTypeFontProvider class methodsFor: 'class initialization' stamp: ''!
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.
	
	current := nil.
	self current "this creates an instance of me, and updates from the system"! !

!FreeTypeFontProvider class methodsFor: 'accessing' stamp: ''!
current
	"
	current := nil.
	TimeProfileBrowser onBlock: [FreeTypeFontProvider current]
	"
	^current 
		ifNil:[
			current := self new.
			current updateFromSystem]! !

!FreeTypeFontProvider class methodsFor: 'accessing' stamp: ''!
resetCurrent
	"I reset all provider contents.
	 I do not free current because I do not want an update (see #current) each time I reset."
	current ifNil: [ ^ self ].
	self current initialize. "Reexecute initialization is dirty, but it makes the trick"! !

!FreeTypeFontProvider class methodsFor: 'extra fonts registration' stamp: ''!
registerFont: aClassWithFont

	"Do nothing if freetype is disabled currently"
	
	FreeTypeSystemSettings loadFt2Library ifTrue: [ 
		aClassWithFont installFontsIn: self current
		 ]! !

!FreeTypeFontSelectorDialogWindow commentStamp: ''!
I'm a dialog to select a font. 

### Usage example:

```
| fontSelector |
fontSelector := FreeTypeFontSelectorDialogWindow new.
UITheme builder openModal: fontSelector.
fontSelector selectedFont inspect.
```!
!FreeTypeFontSelectorDialogWindow methodsFor: 'instance creation' stamp: ''!
newFontStyleButtonRowMorph
	"Answer a new font style button row morph."

	^self newRow: {
		self newBoldButtonMorph.
		self newItalicButtonMorph}! !

!FreeTypeFontSelectorDialogWindow methodsFor: 'updating' stamp: ''!
updateFromSelectedFont
	"Update our state based on the selected font."

	|font|
	font := self selectedFont ifNil: [TextStyle defaultFont].
	fontFamilyIndex := (self fontFamilies indexOf: font familyName).
	fontSizeIndex := (self fontSizes indexOf: font pointSize).
	isBold := (font emphasis allMask: TextEmphasis bold emphasisCode).
	isItalic := (font emphasis allMask: TextEmphasis italic emphasisCode).
	self
		changed: #fontFamilyIndex;
		changed: #fontSizeIndex;
		changed: #isBold;
		changed: #isItalic.
	self textPreviewMorph ifNotNil: [:tp |
		tp font: self selectedFont.
		self changed: #previewText]! !

!FreeTypeFontSelectorDialogWindow methodsFor: 'defaults' stamp: ''!
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: 'accessing' stamp: ''!
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! !

!FreeTypeGlyphRenderer commentStamp: ''!
This class produces glyphs for a FreeTypeFont.
It can be subclassed to provide, for example, sub-pixel anti-aliased glyphs.!
!FreeTypeGlyphRenderer methodsFor: 'public' stamp: ''!
glyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont

	| form |
	form := self 
		renderGlyph: aCharacter 
		depth: (monoBoolean ifTrue:[1] ifFalse:[8]) 
		subpixelPosition: sub
		font: aFreeTypeFont.
	monoBoolean 
		ifTrue:[
			form := self fixBytesForMono: form.
			form := form asFormOfDepth: 8 ].
	form := self convert8to32: form colorValue: aColorValue.
	^form! !

!FreeTypeGlyphRenderer methodsFor: 'private' stamp: ''!
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 between: 16r20 and: 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, PrimitiveFailed do:[:e | 
		^(GlyphForm extent: 0@0 depth: depth)
			advance: 0@0;
			linearAdvance: 0@0;
			offset:0@0;
			yourself].
		 
	glyph := face glyph. 
	slant := aFreeTypeFont simulatedItalicSlant.
	extraWidth := (glyph height * slant) abs ceiling.
	synthBoldStrength := aFreeTypeFont simulatedBoldStrength.
	boldExtra := 4 * synthBoldStrength abs ceiling.
	extraWidth := extraWidth + boldExtra.
	sub > 0 ifTrue:[ extraWidth := extraWidth + 1].
	extraHeight := boldExtra.
	form := GlyphForm extent: (glyph width + extraWidth + 1)@(glyph height + extraHeight+ 1) depth: depth.
	s := (glyph height-glyph hBearingY)  * slant.
	s := s sign * (s abs ceiling). 
	offsetX := glyph hBearingX negated + s + (boldExtra // 2) .
	offsetY := glyph height - glyph hBearingY + (boldExtra//2).
	synthBoldStrength ~= 0
		ifTrue:[face emboldenOutline: synthBoldStrength].
	face transformOutlineAngle: 0 scalePoint: 1@1  slant: slant.
	face translateOutlineBy: (offsetX+(sub/64))@offsetY.
	face renderGlyphIntoForm: form.
	form offset: (glyph hBearingX - s - (boldExtra // 2) ) @ (glyph hBearingY + 1 + (boldExtra / 2) ceiling  ) negated.
	"When not hinting FreeType sets the advance to the truncated linearAdvance.
	The characters appear squashed together. Rounding is probably better, so we fix the advance here"
	aFreeTypeFont subPixelPositioned
		ifTrue:[ form advance: glyph roundedPixelLinearAdvance]
		ifFalse:[ form advance: glyph advance].
	form linearAdvance: glyph linearAdvance.
	^form! !

!FreeTypeGlyphRenderer methodsFor: 'private' stamp: ''!
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: ''!
convert8to32: aGlyphForm colorValue: foreColorValue
	"Convert from the 8 bit deep form produced by FreeType, where each byte represents the intensity of a single pixel, to a 32 bit deep form with pixels of color foreColorValue"
	 
	| w h s answer rowstart bytes word littleEndian shift v a colorVal foreColorVal foreColorA foreColorR foreColorG foreColorB r g b |

	foreColorVal := foreColorValue.
	foreColorA := foreColorVal >> 24.
	foreColorR := foreColorVal >> 16 bitAnd: 16rFF.
	foreColorG := foreColorVal >> 8 bitAnd: 16rFF.
	foreColorB := foreColorVal bitAnd: 16rFF.
	bytes := aGlyphForm bits.
	w := aGlyphForm width.
	h := aGlyphForm height.
	answer := aGlyphForm class extent: w@h depth: 32.
	answer 
		offset: (aGlyphForm offset x) @ (aGlyphForm offset y);
		advance: aGlyphForm advance;
		linearAdvance: aGlyphForm linearAdvance.
	s := w + 3 >> 2.
	littleEndian := aGlyphForm isLittleEndian.
	0 to: h - 1 do: [:y |
		rowstart := (y * s)+1.
		0 to: w - 1 do:[:x | 
			word := bytes at: rowstart + (x//4).
			shift := 8* (littleEndian 
				ifTrue:[x bitAnd: 3] 
				ifFalse:[3-(x bitAnd: 3)]).
			v := word >>shift bitAnd: 16rFF.
			a := v > 0 ifTrue:[v * foreColorA // 16rFF] ifFalse:[0].
			r := v > 0 ifTrue:[a * foreColorR // 16rFF] ifFalse:[0].
			g := v > 0 ifTrue:[a * foreColorG // 16rFF] ifFalse:[0].
			b := v > 0 ifTrue:[a * foreColorB // 16rFF] ifFalse:[0].
			colorVal := (a bitShift: 24) + (r bitShift: 16) + (g bitShift: 8) + b.
			answer bits integerAt: (y*w)+(x+1) put: colorVal]].
	^answer! !

!FreeTypeGlyphRenderer methodsFor: 'public' stamp: ''!
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: ''!
convert8To32: aGlyphForm
	"Convert aGlyphForm from the 8 bit deep form produced by FreeType, where each byte represents the intensity of a single pixel, to a 32 bit deep form" 
	| w h s answer rowstart bytes word littleEndian shift v a colorVal |

	bytes := aGlyphForm bits.
	w := aGlyphForm width.
	h := aGlyphForm height.
	answer := aGlyphForm class extent: w@h depth: 32.
	answer 
		offset: (aGlyphForm offset x) @(aGlyphForm offset y);
		advance: aGlyphForm advance;
		linearAdvance: aGlyphForm linearAdvance.
	s := w + 3 >> 2.
	littleEndian := aGlyphForm isLittleEndian.
	0 to: h - 1 do: [:y |
		rowstart := (y * s)+1.
		0 to: w - 1 do:[:x | 
			word := bytes at: rowstart + (x//4).
			shift := 8* (littleEndian 
				ifTrue:[x bitAnd: 3] 
				ifFalse:[3-(x bitAnd: 3)]).
			v := word >>shift bitAnd: 16rFF.
			a := v > 0 ifTrue:[16rFF] ifFalse:[0].
			colorVal := v + (v bitShift: 8) +  (v bitShift: 16) + (a bitShift: 24).
			answer bits integerAt: (y*w)+(x+1) put: colorVal]].
	^answer! !

!FreeTypeGlyphRenderer methodsFor: 'public' stamp: ''!
mode41GlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont

	| form |
	form := self 
		renderGlyph: aCharacter 
		depth: (monoBoolean ifTrue:[1] ifFalse:[8]) 
		subpixelPosition: sub 
		font: aFreeTypeFont.
	monoBoolean 
		ifTrue:[
			form := self fixBytesForMono: form.
			form := form asFormOfDepth: 32]
		ifFalse:[
			form := self convert8To32: form ].
	^form! !

!FreeTypeGlyphRenderer class methodsFor: 'instance creation' stamp: ''!
current
	<script: 'self current inspect'>

	^current ifNil:[current := self new]! !

!FreeTypeGlyphRenderer class methodsFor: 'accessing' stamp: ''!
current: aKindOfFreeTypeGlyphRender
	current := aKindOfFreeTypeGlyphRender! !

!FreeTypeNameParser commentStamp: ''!
A name parser!
!FreeTypeNameParser methodsFor: 'parsing' stamp: ''!
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: 'known names' stamp: ''!
italicAndObliqueNames
	^self class italicAndObliqueNames! !

!FreeTypeNameParser methodsFor: 'known names' stamp: ''!
weightNames
	^self class weightNames! !

!FreeTypeNameParser methodsFor: 'parsing' stamp: ''!
splitBadTokensIn: aString
	"split tokens such as BoldOblique, that should be two words"
	| str |
	str := aString.
	#(	('bold' 'oblique') ('bold' 'italic')
	) do:[:pair | | i |
		(i := str asLowercase findString: pair first, pair second startingAt: 1) > 0
			ifTrue:[
				str := (str first: i + pair first size - 1), ' ', (str last: (str size - (i + pair first size - 1)))]].
	^str! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
extractedUpright
	^extractedUpright! !

!FreeTypeNameParser methodsFor: 'known names' stamp: ''!
stretchNames
	^self class stretchNames! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
italicFlag: aBoolean
	italicFlag := aBoolean! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
boldFlag: aBoolean
	boldFlag := aBoolean! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
styleName: styleName
	
	styleNameIn := styleName.! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
extractedStretchValue
	^extractedStretchValue! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
extractedStretch
	^extractedStretch! !

!FreeTypeNameParser methodsFor: 'parsing' stamp: ''!
extractWeight
	"match and remove last weight tokens"
	| matches start end |

	extractedWeightValue := LogicalFont weightRegular.
	(self weightNames 
		detect: [:each |
			matches := self lastMatchValueSequence: each allButFirst.
			matches ifNotNil:[extractedWeightValue := each first].
			matches notNil]
		ifNone:[]) ifNotNil:[
			start := matches first second.
			end :=  matches last third.
			extractedWeight := combinedName copyFrom: start to: end.
			[start > 1 and:[delimiters includes: (combinedName at: start - 1)]] "also remove delimiters before token"
				whileTrue:[start := start - 1].
			[end < combinedName size and:[delimiters includes: (combinedName at: end + 1)]] "also remove delimiters after token"
				whileTrue:[end := end + 1].		
			combinedName := combinedName copyReplaceFrom: start to: end with: ' '.].	
	(extractedWeight isNil and:[boldFlag])
		ifTrue:["no weight specified in familyName or styleName; force it to be 'Bold'"
			extractedWeight := 'Bold'.
			extractedWeightValue := LogicalFont weightBold]! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
extractedSlant
	^extractedSlant! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
familyName: familyName
	familyNameIn := familyName.! !

!FreeTypeNameParser methodsFor: 'known names' stamp: ''!
italicNames
	^self class italicNames! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
styleNameIn: styleName
	
	styleNameIn := styleName.! !

!FreeTypeNameParser methodsFor: 'parsing' stamp: ''!
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: ''!
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: ''!
tokenize: aString 
	"answer an OrderedCollection of {string. start. end} tuples.
	tokens are separated by $- $_ $, $. and whitespace"
	| currentTokens answer start |
	
	currentTokens := aString findTokens: delimiters keep: delimiters.
	answer := OrderedCollection new.
	start := 1.
	currentTokens do:[:tok |
		(delimiters includes: tok first)
			ifFalse:[answer add: {tok. start. start+tok size - 1}].
		start := start + tok size].
	^answer! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
extractedSlantValue
	^extractedSlantValue! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
extractedWeightValue
	^extractedWeightValue! !

!FreeTypeNameParser methodsFor: 'parsing' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	super initialize.
	delimiters := ',.-_'.
	Character separators do:[:c | delimiters := delimiters , c asString].! !

!FreeTypeNameParser methodsFor: 'known names' stamp: ''!
normalNames
	^self class normalNames! !

!FreeTypeNameParser methodsFor: 'parsing' stamp: ''!
extractUpright
	"extract from current combined name.
	answer new combinedName"
	| normalTok start end | 

	normalTok := tokens reversed 
		detect: [:tok | 
			(self normalNames 
				detect: [:str | str asLowercase = tok first asLowercase] 
				ifNone:[]) notNil ]
		ifNone:[].
	normalTok ifNotNil:[
		"remove it from combinedName"
		start := normalTok second.
		end :=  normalTok third.
		extractedUpright := combinedName copyFrom: start to: end.
		[start > 1 and:[delimiters includes: (combinedName at: start - 1)]]
			whileTrue:[start := start - 1].
		[end < combinedName size and:[delimiters includes: (combinedName at: end + 1)]]
			whileTrue:[end := end + 1].		
		combinedName := combinedName copyReplaceFrom: start to: end with: ' '].! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
extractedWeight
	^extractedWeight! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
familyNameIn: familyName
	familyNameIn := familyName.! !

!FreeTypeNameParser methodsFor: 'accessing' stamp: ''!
familyName
	^combinedName trimBoth! !

!FreeTypeNameParser methodsFor: 'parsing' stamp: ''!
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 class methodsFor: 'known names' stamp: ''!
italicAndObliqueNames
	^self italicNames, self obliqueNames! !

!FreeTypeNameParser class methodsFor: 'known names' stamp: ''!
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: ''!
weightNames
	"Answer a sequence of arrays.
	Each array has an integer weight value as its first element.
	The remaining elements are String tokens which might appear
	within a font family-style name"
	"
	TO RE-INITIALIZE...
	self instVarNamed: #weightNames put: nil.
	"
	weightNames ifNotNil:[^weightNames].
	^weightNames := {
		{LogicalFont weightExtraThin. 'extra'. 'thin'}.
		{LogicalFont weightExtraThin.'extrathin'}.
		{LogicalFont weightExtraThin. 'ext'. 'thin'}.
		{LogicalFont weightExtraThin. 'extthin'}.
		{LogicalFont weightUltraThin.'ultra'. 'thin'}.
		{LogicalFont weightUltraThin.'ultrathin'}.
		{LogicalFont weightExtraLight. 'extra'. 'light'}.
		{LogicalFont weightExtraLight. 'extralight'}.
		{LogicalFont weightExtraLight. 'ext'. 'light'}.
		{LogicalFont weightExtraLight. 'extlight'}.
		{LogicalFont weightUltraLight. 'ultra'. 'light'}.
		{LogicalFont weightUltraLight. 'ultralight'}.
		{LogicalFont weightSemiBold. 'semi'. 'bold'}.
		{LogicalFont weightSemiBold. 'semibold'}.
		{LogicalFont weightDemiBold. 'demi'. 'bold'}.
		{LogicalFont weightDemiBold. 'demibold'}.
		{LogicalFont weightExtraBold. 'extra'. 'bold'}.
		{LogicalFont weightExtraBold. 'extrabold'}.
		{LogicalFont weightExtraBold. 'ext'. 'bold'}.
		{LogicalFont weightExtraBold. 'extbold'}. 
		{LogicalFont weightUltraBold. 'ultra'. 'bold'}.
		{LogicalFont weightUltraBold. 'ultrabold'}.
		{LogicalFont weightExtraBlack. 'extra'. 'black'}.
		{LogicalFont weightExtraBlack. 'extrablack'}.
		{LogicalFont weightExtraBlack. 'ext'. 'black'}.
		{LogicalFont weightExtraBlack. 'extblack'}.
		{LogicalFont weightUltraBlack.'ultra'. 'black'}.
		{LogicalFont weightUltraBlack. 'ultrablack'}.
		{LogicalFont weightBold. 'bold'}.
		{LogicalFont weightThin.'thin'}.
		{LogicalFont weightLight. 'light'}.
		{LogicalFont weightMedium. 'medium'}.
		{LogicalFont weightBlack. 'black'}.
		{LogicalFont weightHeavy. 'heavy'}.
		{LogicalFont weightNord. 'nord'}.
		{LogicalFont weightDemi. 'demi'}.
		{LogicalFont weightUltra. 'ultra'}.
		}! !

!FreeTypeNameParser class methodsFor: 'known names' stamp: ''!
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: ''!
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: ''!
italicNames
	"Answer a sequence of String tokens that indicate an italic font
	within a font family-style name"
	"
	TO RE-INITIALIZE...
	self instVarNamed: #italicNames put: nil.
	"
	italicNames ifNotNil:[^italicNames].
	^italicNames := #(
		'ita'
		'ital'
		'italic'
		'cursive'
		'kursiv').! !

!FreeTypeSettings commentStamp: ''!
Settings for FreeType!
!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
monoHinting
	^monoHinting ifNil:[monoHinting := false]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
glyphContrast
	^ 100 - ((self gamma  sqrt * 100) - 50)! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
useSubPixelAntiAliasing
	^ self forceNonSubPixelCount == 0 and: [ self bitBltSubPixelAvailable ]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
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.
			self currentWorld restoreMorphicDisplay]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
subPixelAntiAliasing
	^ self useSubPixelAntiAliasing and: [ subPixelAntiAliasing ifNil: [ false ] ]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
gammaInverseTable
	^gammaInverseTable! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
forceNonSubPixelCount
	^forceNonSubPixelCount ifNil:[forceNonSubPixelCount := 0]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
lcdvHinting
	^lcdvHinting ifNil:[lcdvHinting := false]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
gammaTable
	^gammaTable! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
monitorType: aSymbol
	"#LCD or #CRT"
	subPixelAntiAliasing := aSymbol = #LCD.
	self currentWorld restoreMorphicDisplay.! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
clearBitBltSubPixelAvailable	
	
	bitBltSubPixelAvailable := nil.! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
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]].
				self currentWorld restoreMorphicDisplay]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
monitorType
  "#LCD or #CRT"
  ^ self subPixelAntiAliasing ifTrue: [#LCD] ifFalse: [#CRT]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
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 ].
	
	self flag: #DEPENDENCY. "This is a hidden dependency on morphic :("
	self class environment 
		at: #Paragraph
		ifPresent: [ :aClass | aClass refreshAllCompositions ]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
subPixelAntiAliasing: aBoolean
	subPixelAntiAliasing := aBoolean! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
hinting
	^hinting ifNil:[hinting := true]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
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: ''!
subPixelFiltersFromRatios: anArray
	"Convert the ratios in anArray to a similar array containing the filter proportions as floats.
	Example:
	if <array3ofArrays5> = #((1 3 5 3 1) (1 3 5 3 1) (1 3 5 3 1))
	Then the answer is #(#(0.0769230769230769 0.2307692307692308 0.3846153846153846 0.2307692307692308 0.0769230769230769) #(0.0769230769230769 0.2307692307692308 0.3846153846153846 0.2307692307692308 0.0769230769230769) #(0.0769230769230769 0.2307692307692308 0.3846153846153846 0.2307692307692308 0.0769230769230769))"
	
	| r g b rRatios gRatios bRatios rsum gsum bsum rfilter gfilter bfilter blurR blurG blurB |
		
	r := "Color red luminance" 1.0 .
	g := "Color green luminance" 1.0 .
	b := "Color blue luminance"1.0 .
	blurR :=  anArray first.
	blurG := anArray second.
	blurB := anArray third.
	rRatios := blurR collect:[:i | r*i].
	gRatios := blurG collect:[:i | g*i].
	bRatios := blurB collect:[:i | b*i].
	"rRatios := 	{g*blurR first .	b*blurR second.	r*blurR third.	g*bl.	b*blur*blur }.							
	gRatios := 	{b*blur*blur.	r*blur.	g.		b*blur.	r*blur*blur}.
	bRatios :=	{r*blur*blur.	g*blur.	b.		r*blur.	g*blur*blur }."
	rsum := rRatios inject:0 into:[:t :i | t+i].
	gsum := gRatios inject:0 into:[:t :i | t+i].
	bsum := bRatios inject:0 into:[:t :i | t+i].
	rfilter := rRatios collect:[:e | e / rsum].
	gfilter := gRatios collect:[:e | e / gsum].
	bfilter := bRatios collect:[:e | e / bsum].
	^{rfilter. gfilter. bfilter}! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
clearForceNonSubPixelCount
	
	forceNonSubPixelCount := nil.! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
lightHinting
	^lightHinting ifNil:[lightHinting := true]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
defaultSubPixelFilterRatios
	^#((1 3 5 3 1) (1 3 5 3 1) (1 3 5 3 1))! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
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: ''!
forceNonSubPixelDuring: aBlock
	forceNonSubPixelCount ifNil:[forceNonSubPixelCount := 0].
	forceNonSubPixelCount := forceNonSubPixelCount + 1.
	aBlock ensure:[forceNonSubPixelCount := forceNonSubPixelCount - 1]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
gamma
	^gamma ifNil:[gamma := 1.0]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
forceAutoHinting
	^forceAutoHinting ifNil:[forceAutoHinting := false]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
subPixelFilters
	^subPixelFilters ifNil:[subPixelFilters := self subPixelFiltersFromRatios: self defaultSubPixelFilterRatios]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
lcdHinting
	^lcdHinting ifNil:[lcdHinting := false]! !

!FreeTypeSettings methodsFor: 'accessing' stamp: ''!
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: '*FreeType-Graphics' stamp: ''!
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: '*FreeType-Graphics' stamp: ''!
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 class methodsFor: 'settings' stamp: ''!
updateFontsAtImageStartup
	^ UpdateFontsAtImageStartup ifNil: [UpdateFontsAtImageStartup := false]! !

!FreeTypeSettings class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default 
		registerGuiClassNamed: self name 
		atPriority: 10.! !

!FreeTypeSettings class methodsFor: 'instance creation' stamp: ''!
current
	current == nil ifFalse:[^current].
	^current := self new! !

!FreeTypeSettings class methodsFor: 'system startup' stamp: ''!
shutDown: quitting 
	quitting ifFalse: [ ^ self ]. 

	self current 
		clearBitBltSubPixelAvailable;
		clearForceNonSubPixelCount.
	"FreeTypeCache clearCacheOnShutdown
		ifTrue: [ FreeTypeCache clearCurrent ].	
	FT2Handle clearRegistry.
	FreeTypeFontProvider resetCurrent. 
	EmbeddedFreeTypeFontInstaller resetCurrent."! !

!FreeTypeSettings class methodsFor: 'settings' stamp: ''!
updateFontsAtImageStartup: aBoolean
	UpdateFontsAtImageStartup := aBoolean! !

!FreeTypeSettings class methodsFor: 'system startup' stamp: ''!
startUp: resuming
	resuming ifTrue:[ self updateFreeType ]! !

!FreeTypeSettings class methodsFor: 'system startup' stamp: ''!
updateFreeType
	self current 
		clearBitBltSubPixelAvailable;
		clearForceNonSubPixelCount.
	"Embeded fonts update always"
	FreeTypeFontProvider current updateEmbeddedFreeTypeFonts. 
	self updateFontsAtImageStartup 
		ifTrue: [ FreeTypeFontProvider current updateFromSystem ]! !

!FreeTypeSubPixelAntiAliasedGlyphRenderer commentStamp: ''!
A SubPixel-AntiAliased GlyphRenderer for FreeType!
!FreeTypeSubPixelAntiAliasedGlyphRenderer methodsFor: 'rendering' stamp: ''!
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: ''!
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 between: 16r20 and: 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, PrimitiveFailed 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: ''!
subGlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont

	| form |
	monoBoolean
		ifFalse:[
			form := self 
				renderStretchedGlyph: aCharacter 
				depth: 8 
				subpixelPosition: sub 
				font: aFreeTypeFont. 
			form := self filter: form]
		ifTrue:[
			form := self 
				renderGlyph: aCharacter 
				depth: 1 
				subpixelPosition: sub 
				font: aFreeTypeFont.
			form := self fixBytesForMono: form.					
			form := form asFormOfDepth: 32].
	^form! !

!FreeTypeSubPixelAntiAliasedGlyphRenderer class methodsFor: 'class initialization' stamp: ''!
initialize

	FreeTypeGlyphRenderer current: self new! !

!FreeTypeSystemSettings commentStamp: ''!
Settings for the FreeType system!
!FreeTypeSystemSettings class methodsFor: '*FreeType-Graphics' stamp: ''!
loadFt2Library: aBoolean
	(LoadFT2Library = aBoolean) 
		ifTrue: [ ^ self ].
	LoadFT2Library := aBoolean.
	aBoolean 
		ifTrue: [ 
			FreeTypeFontProvider current updateFromSystem ]
		ifFalse: [
			StandardFonts setSmallBitmapFonts.
			FreeTypeFontProvider unload ]! !

!FreeTypeSystemSettings class methodsFor: 'settings' stamp: ''!
noFt2Library
	^ 'Free type fonts are not available'! !

!FreeTypeSystemSettings class methodsFor: 'settings' stamp: ''!
loadFt2Library
	^ LoadFT2Library ifNil: [LoadFT2Library := false]! !

!FreeTypeSystemSettings class methodsFor: 'settings' stamp: ''!
ft2LibraryVersion
	^ Smalltalk ui theme 
		newLabelIn: self 
		for: self 
		label: 'Available version: ', FT2Version current asString 
		getEnabled: nil.! !

!FreeTypeSystemSettings class methodsFor: 'settings' stamp: ''!
freeTypeSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #noFt2Library)
		target: self;
		iconName: #smallConfigurationIcon;
		type: #Label;
		label: 'Free type';
		default: 'Free type fonts are not available';
		precondition: [ FT2Library current isAvailable not ];
		parent: #appearance;
		order: 3;
		description:
			'Free type fonts are not available probably because the FT2 plugin is not installed. Check your VM installation'.
	(aBuilder setting: #loadFt2Library)
		target: self;
		default: true;
		dialog: [ self ft2LibraryVersion ];
		iconName: #smallConfigurationIcon;
		label: 'Use Free type';
		description:
			'If checked, it allows the usage of Freetype fonts and updates available fonts by scanning the current system';
		precondition: [ FT2Library current notNil ];
		parent: #appearance;
		order: 3;
		with: [ (aBuilder pickOne: #monitorType)
				label: 'Monitor type';
				description: 'LCD is generally better for flat screens';
				target: FreeTypeSettings;
				targetSelector: #current;
				order: 0;
				default: #LCD;
				domainValues: {#LCD . #CRT}.
			(aBuilder setting: #updateFontsAtImageStartup)
				order: 1;
				target: FreeTypeSettings;
				default: false;
				label: 'Update fonts at startup';
				description: 'If true, then the available font list is recomputed at each startup'.
			(aBuilder group: #advancedSettings)
				order: 10;
				label: 'Advanced features';
				description: 'Some very specific parameters as the hinting or the cache size';
				with: [ (aBuilder range: #cacheSize)
						target: FreeTypeCache;
						targetSelector: #current;
						label: 'Cache size';
						description: 'The size of the font cache in KBytes';
						default: 5000;
						range: (0 to: 50000 by: 10).
					(aBuilder pickOne: #hintingSymbol)
						label: 'Hinting';
						description:
							'Changes the glyph shapes:'
								,
									'
o FULL: glyph shapes features are snapped to pixel boundaries. Glyphs are monochrome, with no anti-aliasing. This option changes the shapes the most.'
								,
									'
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.'
								,
									'
o NORMAL: glyph shapes features are snapped to pixel boundaries. Glyphs are anti-aliased.'
								,
									'
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.';
						target: FreeTypeSettings;
						targetSelector: #current;
						default: #Light;
						domainValues:
							{('Light' -> #Light).
							('Normal' -> #Normal).
							('Full' -> #Full).
							('None' -> #None)}.
					(aBuilder range: #glyphContrast)
						target: FreeTypeSettings;
						targetSelector: #current;
						default: 55.0;
						label: 'Glyph contrast';
						description:
							'Change the contrast level for glyphs. This is an integer between 1 and 100' ;
						range: (0 to: 100 by: 10) ] ]! !

!FreeTypeSystemSettings class methodsFor: 'settings' stamp: ''!
noFt2Library: aBoolean 

	"ignore it for now"! !

!FuelOutStackDebugAction commentStamp: ''!
A FuelOutStackDebugAction is	a debugging action that serialize a portion of the current stack trace using fuel.
!
!FuelOutStackDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 125! !

!FuelOutStackDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Serialize a portion of the current stack trace using fuel.'! !

!FuelOutStackDebugAction methodsFor: 'actions' stamp: ''!
executeAction
	self class serializeStackFromContext: self interruptedContext! !

!FuelOutStackDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #fuelOutStack! !

!FuelOutStackDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Fuel out Stack'! !

!FuelOutStackDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<contextMenuDebuggingAction>! !

!FuelOutStackDebugAction class methodsFor: 'gt-extensions' stamp: ''!
gtActionFor: aDebugger
	<gtStackDebuggingAction>
	
	^ (self forDebugger: aDebugger)
			order: 30! !

!FuelOutStackDebugAction class methodsFor: 'serialization' stamp: ''!
serializeStackFromContext: aContext
	FLDebuggerStackSerializer serializeStackFromContext: aContext! !

!FullBlockClosure commentStamp: ''!
A FullBlockClosure is a closure that can be independent of any outerContext if desired.  It has its own method (currently reusing the startpc inst var) and its own receiver.  outerContext can be either a MethodContext/Context or nil.

Instance Variables
	outerContext 	<Context>
	(startpc) compiledBlock <CompiledBlock> for compatibility, this is startpc.
	numArgs 		<SmallInteger>
	receiver:		<Object>!
!FullBlockClosure methodsFor: 'accessing' stamp: ''!
receiver: anObject
	receiver := anObject! !

!FullBlockClosure methodsFor: 'accessing' stamp: ''!
receiver
	^ receiver! !

!FullStackDebugAction commentStamp: ''!
A FullStackDebugAction displays the entire stack in the stack widget.
!
!FullStackDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 30! !

!FullStackDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Open a full debugger to navigate in the full bugged stack.'! !

!FullStackDebugAction methodsFor: 'actions' stamp: ''!
executeAction
	
	self debugger stack expandBy: self expandedStackSize! !

!FullStackDebugAction methodsFor: 'accessing' stamp: ''!
expandedStackSize

	^ 100000! !

!FullStackDebugAction methodsFor: 'accessing' stamp: ''!
enabled

	^ self shouldEnableFullStackButton! !

!FullStackDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #fullStack! !

!FullStackDebugAction methodsFor: 'testing' stamp: ''!
shouldEnableFullStackButton

	self debugger ifNil: [ ^ false ].  
		
	^ self debugger stack listItems 
		ifEmpty: [ false ] 
		ifNotEmpty: [ :aList |
			aList last sender notNil ]! !

!FullStackDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Full Stack'! !

!FullStackDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<debuggingAction>
	<contextMenuDebuggingAction>! !

!FullscreenAnnouncement commentStamp: ''!
I am announced when full-screen mode state is changed.!
!FullscreenAnnouncement methodsFor: 'accessing' stamp: ''!
displayScreen: anObject
	displayScreen := anObject! !

!FullscreenAnnouncement methodsFor: 'accessing' stamp: ''!
fullscreen: anObject
	fullscreen := anObject! !

!FullscreenAnnouncement methodsFor: 'accessing' stamp: ''!
fullscreen
	^ fullscreen! !

!FullscreenAnnouncement methodsFor: 'accessing' stamp: ''!
displayScreen
	^ displayScreen! !

!FullscreenMorph commentStamp: ''!
Provides for another morph to occupy the full screen area (less docking bars).!
!FullscreenMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		changeProportionalLayout;
		bounds: self currentWorld clearArea;
		beSticky! !

!FullscreenMorph methodsFor: 'initialize' stamp: ''!
preOpenInWorld: aWorld

	"Do nothing"! !

!FullscreenMorph methodsFor: 'accessing' stamp: ''!
setContentMorph: aMorph
	"Replace the submorphs with aMorph."
	
	self removeAllMorphs.
	self
		addMorph: aMorph
		fullFrame: LayoutFrame identity! !

!FullscreenMorph methodsFor: 'initialize' stamp: ''!
postOpenInWorld: aWorld
	
	(self submorphs notEmpty and: [ self submorphs first isSystemWindow ])
		ifTrue: [ self submorphs first openedFullscreen ].
	super postOpenInWorld: aWorld! !

!FullscreenMorph methodsFor: 'accessing' stamp: ''!
contentMorph
	"Answer the current content."
	
	^self submorphs first! !

!FullscreenMorph methodsFor: 'change reporting' stamp: ''!
displayExtentChanged

	self updateBounds! !

!FullscreenMorph methodsFor: 'private - layout' stamp: ''!
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: 'initialize' stamp: ''!
defaultColor
	"Return the receiver's default color."
	
	^Color white! !

!FullscreenMorph methodsFor: 'private - layout' stamp: ''!
updateBounds
	"Update the receiver's bounds to fill the world."

	self bounds: self owner clearArea! !

!FuzzyLabelMorph commentStamp: ''!
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: 'drawing' stamp: ''!
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 contrastingBlackAndWhiteColor 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: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	offset := 1.
	alpha := 0.5.
	super initialize! !

!FuzzyLabelMorph methodsFor: 'accessing' stamp: ''!
offset: anObject
	"Set the value of offset"

	offset := anObject.
	self fitContents! !

!FuzzyLabelMorph methodsFor: 'initialization' stamp: ''!
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: 'accessing' stamp: ''!
measureContents
	"Add 2 times offset."
	
	^super measureContents ceiling + (self offset * 2) asPoint! !

!FuzzyLabelMorph methodsFor: 'accessing' stamp: ''!
setWidth: width
	"Set the width/extent."
	
	self extent: width @ (self fontToUse height ceiling + (2 * self offset))! !

!FuzzyLabelMorph methodsFor: 'accessing' stamp: ''!
offset
	"Answer the value of offset"

	^ offset! !

!FuzzyLabelMorph methodsFor: 'accessing' stamp: ''!
alpha: anObject
	"Set the value of alpha"

	alpha := anObject.
	self changed! !

!FuzzyLabelMorph methodsFor: 'accessing' stamp: ''!
alpha
	"Answer the value of alpha"

	^ alpha! !

!FuzzyMatcher commentStamp: ''!
FuzzyMatcher is an approximate string matching algorithm that can determine if a string includes a given pattern.
For example, the string 'axby' matches both the pattern 'ab' and, 'ay', but not 'ba'. 

The algorithm is based on lib_fts[1], and includes an optional scoring algorithm that can be used to sort all the matches based on their similarity to the pattern.

1: 
https://blog.forrestthewoods.com/reverse-engineering-sublime-text-s-fuzzy-match-4cffeed33fdb
https://github.com/forrestthewoods/lib_fts
!
!FuzzyMatcher methodsFor: 'scoring - bonus' stamp: ''!
adjacencyIncrease

	^ 1.2! !

!FuzzyMatcher methodsFor: 'scoring - bonus' stamp: ''!
adjacencyBonus

	^ 5! !

!FuzzyMatcher methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	pattern := lowercasePattern := ''.
	indexes := #()! !

!FuzzyMatcher methodsFor: 'scoring - bonus' stamp: ''!
separatorBonus

	^ 5! !

!FuzzyMatcher methodsFor: 'scoring - penalty' stamp: ''!
unmatchedLetterPenalty

	^ -1! !

!FuzzyMatcher methodsFor: 'comparing' stamp: ''!
match: aString ifScored: aBlock
	
	| score |
	
	score := 0.	
		
	pattern ifEmpty: [ aBlock value: score. ^ self ].
	
	(self matches: aString) ifFalse: [ ^ self ].
	
	score := self firstScore: aString at: indexes first.
	
	2 to: pattern size do: [ :pix | 
		score := score + (self score: aString at: (indexes at: pix) patternAt: pix) ].
		
	score := score + self indexScore + ((aString size - pattern size) * self unmatchedLetterPenalty).
		
	aBlock value: score! !

!FuzzyMatcher methodsFor: 'accessing' stamp: ''!
pattern: aString

	pattern := aString.
	lowercasePattern := pattern asLowercase.
	indexes := Array new: pattern size! !

!FuzzyMatcher methodsFor: 'private - accessing' stamp: ''!
indexScore 

	| sum ramp |
	
	ramp := 1.
	sum := 0.
	
	1 to: indexes size - 1 do: [ :ix |
		ramp := (indexes at: ix) + 1 = (indexes at: ix + 1) 
			ifTrue: [ ramp + (ramp * self adjacencyIncrease) ]
			ifFalse: [ 1 ].		
		
		sum := sum + ramp - 1
	].
	
	^ sum rounded! !

!FuzzyMatcher methodsFor: 'scoring - penalty' stamp: ''!
leadingLetterPenalty

	^ -3! !

!FuzzyMatcher methodsFor: 'scoring - bonus' stamp: ''!
adjacentCaseEqualBonus

	^ 3! !

!FuzzyMatcher methodsFor: 'scoring - bonus' stamp: ''!
caseEqualBonus

	^ 7! !

!FuzzyMatcher methodsFor: 'comparing' stamp: ''!
matches: aString

	| idx |
	
	pattern size > aString size ifTrue: [ ^ false ].

	idx := 0.
	pattern withIndexDo: [ :each :i |
		idx := aString 
			findString: each asString 
			startingAt: idx + 1 
			caseSensitive: false. 
		
		idx == 0 ifTrue: [ ^ false ].
		indexes at: i put: idx.
	].

	^ true! !

!FuzzyMatcher methodsFor: 'scoring - bonus' stamp: ''!
firstLetterBonus

	^ 12! !

!FuzzyMatcher methodsFor: 'scoring - penalty' stamp: ''!
maxLeadingLetterPenalty

	^ -9! !

!FuzzyMatcher methodsFor: 'accessing' stamp: ''!
pattern

	^ pattern! !

!FuzzyMatcher methodsFor: 'private - testing' stamp: ''!
isSeparator: aCharacter
	
	^  #'_:' includes: aCharacter! !

!FuzzyMatcher methodsFor: 'private - accessing' stamp: ''!
score: aString at: stringIndex patternAt: patternIndex

	| score prev |
	
	prev := (aString at: stringIndex - 1).
	
	score := (self isSeparator: prev) 
		ifTrue: [ self separatorBonus ]
		ifFalse: [ (prev asLowercase = (lowercasePattern at: patternIndex - 1))
			ifTrue: [ 
				self adjacencyBonus + 
				((prev = (pattern at: patternIndex - 1)) ifTrue: [ self adjacentCaseEqualBonus ] ifFalse: [ 0 ]) 
			] 
			ifFalse: [ 0 ] 
		].
	
	(aString at: stringIndex) = (pattern at: patternIndex) ifTrue: [ 
		score := score + self caseEqualBonus.
	].

	^ score! !

!FuzzyMatcher methodsFor: 'private - accessing' stamp: ''!
firstScore: aString at: anIndex

	| score |

	score := (aString at: anIndex) = pattern first 
		ifTrue: [ self caseEqualBonus ]
		ifFalse: [ 0 ].
	
	anIndex = 1 	ifTrue: [ ^ score + self firstLetterBonus ].
		
	score := score + (((anIndex - 1) * self leadingLetterPenalty) max: self maxLeadingLetterPenalty).
				
	^ score! !

!FuzzyMatcher class methodsFor: 'utilities - api' stamp: ''!
allMatching: aPattern in: aCollectionOfStrings by: aBlockReturningString

	| matcher |
	
	matcher := self pattern: aPattern.

	^ aCollectionOfStrings select: [:each | matcher matches: (aBlockReturningString value: each) ]! !

!FuzzyMatcher class methodsFor: 'utilities - api' stamp: ''!
allSortedByScoreMatching: aPattern in: aCollectionOfStrings
	
	^ self allSortedByScoreMatching: aPattern in: aCollectionOfStrings by: [:each | each ]! !

!FuzzyMatcher class methodsFor: 'utilities - api' stamp: ''!
allSortedByScoreMatching: aPattern in: aCollectionOfStrings by: aBlockReturningString

	| matcher matches |
	
	aPattern isEmpty ifTrue: [ ^aCollectionOfStrings asArray ].
	
	matcher := self pattern: aPattern.
	matches := OrderedCollection new: aCollectionOfStrings size // 2.
	
	aCollectionOfStrings do: [:each | 
		matcher 
			match: (aBlockReturningString value: each) 
			ifScored: [:score | matches add: score -> each ] ].
	
	matches sort: [:a :b | a key >= b key ].
	
	^ matches collect: [:each | each value ] as: Array! !

!FuzzyMatcher class methodsFor: 'construction' stamp: ''!
pattern: aString

	^self new
		pattern: aString;
		yourself! !

!FuzzyMatcher class methodsFor: 'utilities - api' stamp: ''!
allMatching: aPattern in: aCollectionOfStrings

	| matcher |
	
	matcher := self pattern: aPattern.

	^ aCollectionOfStrings select: [:each | matcher matches: each ]! !

!FuzzyMatcherExample commentStamp: ''!
FuzzyExample is a class used to showcase the FuzzyMatcher score matching. 
See the example on the class side.
!
!FuzzyMatcherExample methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	pattern := ''.
	
	dataSource := FTEasyListDataSource new
		elements: #();
		display: [ :item |
			String streamContents: [ :stream |			
				stream 
					nextPutAll: item value asString;
					space: (10 - ((stream position *2) min: 8));
					nextPutAll: item key asString
			]
		];
		yourself.
				
	textModel := RubScrolledTextModel new.
	textModel announcer when: RubEditsStateChangedInModel 
		send: #update to: self.
	
	stringMorph := StringMorph contents: '' font: self aquireFont! !

!FuzzyMatcherExample methodsFor: 'event handling' stamp: ''!
update

	self updatePattern: textModel getText asString! !

!FuzzyMatcherExample methodsFor: 'opening' stamp: ''!
open
	<script: 'self new open'>
	| window area |
	
	window := (self buildMorph openInWindowLabeled: 'Fuzzy Matching Example').
	area := window world clearArea.
	
	window 
		extent: (area extent * (0.6 @ 0.7)) asIntegerPoint;
		center: area center.
	
	^ window! !

!FuzzyMatcherExample methodsFor: 'private' stamp: ''!
setElements: aCollection

	elements := aCollection collect: [:each | each -> 0 ].
	matchedElements := elements.
	dataSource elements: matchedElements! !

!FuzzyMatcherExample methodsFor: 'event handling' stamp: ''!
updatePattern: newPattern

	| searchPool t text |

	pattern = newPattern ifTrue: [ ^ self ].

	searchPool := pattern size > newPattern size 
		ifTrue: [ elements ]
		ifFalse: [ matchedElements ].

	t := [ matchedElements := self match: newPattern for: searchPool ] timeToRun.
	
	text := 'Checked {1} items, found {2} matching | {3} ms' format: { 
		elements size . matchedElements size. t asMilliSeconds }.
	
	stringMorph contents: text.		
	pattern := newPattern.	
	dataSource elements: matchedElements.	
	dataSource table ifNotNil: [ :fastTable | fastTable refresh ]! !

!FuzzyMatcherExample methodsFor: 'accessing' stamp: ''!
elements: aCollection

	elements := aCollection collect: [:each | each -> 0 ].
	matchedElements := elements.
	dataSource elements: matchedElements.
	self update! !

!FuzzyMatcherExample methodsFor: 'private' stamp: ''!
fontName

	^ 'Source Sans Pro'! !

!FuzzyMatcherExample methodsFor: 'accessing' stamp: ''!
pattern: aString

	textModel setText: aString! !

!FuzzyMatcherExample methodsFor: 'opening' stamp: ''!
buildMorph

	| morph ft |
	
	morph := AlignmentMorph newColumn
		color: Color transparent;  
		cellInset: 4@4;
		yourself.
	
	textModel := textModel newTextField
		textFont: self aquireFont;
		hResizing: #spaceFill;
		yourself.
		
	ft := FTTableMorph new
		dataSource: dataSource;
		vResizing: #spaceFill; 
		hResizing: #spaceFill;
		yourself.

	morph 
		addMorph: ft;
		addMorph: stringMorph;
		addMorph: textModel.
	
	^ morph! !

!FuzzyMatcherExample methodsFor: 'private' stamp: ''!
match: aPattern for: aCollection

	| matcher matches |
	
	aPattern isEmpty ifTrue: [ ^ aCollection ].
	
	matcher := FuzzyMatcher pattern: aPattern.

	matches := OrderedCollection new: aCollection size.
	
	aCollection do: [ :each | 
		matcher 
			match: each key
			ifScored: [ :score | matches add: each key -> score ] 
	].
	
	matches sort: [ :a :b | a value >= b value ].
	
	^ matches! !

!FuzzyMatcherExample methodsFor: 'private' stamp: ''!
aquireFont

	^ LogicalFont familyName: self fontName pointSize: 16! !

!FuzzyMatcherExample class methodsFor: 'examples' stamp: ''!
exampleSelectors
	<example>

	^ self new 
		pattern: '::::::::::';
		elements: Symbol selectorTable asArray;
		open! !

!FuzzyMatcherExample class methodsFor: 'examples' stamp: ''!
examplePackages
	<example>

	^ self new 
		pattern: '-st';
		elements: (RPackage organizer packages collect: [:each | each name] );
		open! !

!FuzzyMatcherExample class methodsFor: 'examples' stamp: ''!
exampleAuthors
	<sampleInstance>
	| authors blk |
	
	authors := OrderedCollection new.
	blk := [ :mtd | 
		mtd timeStamp ifNotEmpty: [ :stamp |
			(' ' join: ((stamp splitOn: ' ') allButLast: 2)) ifNotEmpty: [ :author |
				 author trimmed ifNotEmpty: [ authors add: author ]
			]
		] 
	].
	Smalltalk globals allClassesAndTraitsDo: [ :each |
		each methodsDo: blk. 
		each classSide methodsDo: blk.
	].

	^ self new 
		elements: authors asSet asArray;
		open! !

!FuzzyMatcherExample class methodsFor: 'examples' stamp: ''!
exampleClasses
	<sampleInstance>

	^ self new 
		pattern: 'mph';
		elements: (self environment allClassesAndTraits collect: [:each | each name]);
		open! !

!FuzzyMatcherTest commentStamp: ''!
Tests for FuzzyMatcher. !
!FuzzyMatcherTest methodsFor: 'tests' stamp: ''!
testClassSideAPI

	"If the protocol is changed, so should the class comment."
	FuzzyMatcher class protocols detect: [ :p | p = #'utilities - api' ].
	
	self 	
		assert: (FuzzyMatcher allMatching: #a in: #(a b ab))
		equals: #(a ab);
	
		assert: (FuzzyMatcher allMatching: #a in: { #a -> 1 . #b -> 2 . #acb -> 3 } by: [:each | each key ])
		equals: { #a -> 1 . #acb -> 3 };
		
		assert: (FuzzyMatcher allSortedByScoreMatching: #b in: { #aaca .#aAaaB . #Aaab . #baaa . #aaba })
		equals: #(baaa aaba Aaab aAaaB)! !

!FuzzyMatcherTest methodsFor: 'asserting' stamp: ''!
assert: matcher scoreFor: aString equals: aBlockOrNumber

	matcher match: aString ifScored: [ :score |
		self assert: score equals: aBlockOrNumber value.
		^ self	 ].

	self error: 'Expected to match: ', aString! !

!FuzzyMatcherTest methodsFor: 'tests' stamp: ''!
testIsSeparator

	| matcher |
	matcher := self newMatcher.
	
	self
		assert: (matcher isSeparator: $_);
		assert: (matcher isSeparator: $:);
		deny: (matcher isSeparator: $!!);
		deny: (matcher isSeparator: $a)! !

!FuzzyMatcherTest methodsFor: 'tests' stamp: ''!
testAllMatchingIn

	| input output |
	
	input := #('0g' 'ogb' 'gat' 'dog' 'FroG' 'hog' 'goh' 'hgo').
	output := FuzzyMatcher allMatching: 'og' in: input.
	
	self assert: output asArray equals: #('ogb' 'dog' 'FroG' 'hog')! !

!FuzzyMatcherTest methodsFor: 'tests' stamp: ''!
testScoreValues

	| matcher |
	
	matcher := self newMatcher.
	
	matcher pattern: 'a'.
	
	self 
	
		assert: matcher 
		scoreFor: 'a' 
		equals: (matcher firstLetterBonus + matcher caseEqualBonus);
		
		assert: matcher 
		scoreFor: 'A' 
		equals: (matcher firstLetterBonus);
		
		assert: matcher 
		scoreFor: 'ab' 
		equals: (matcher firstLetterBonus + matcher caseEqualBonus + matcher unmatchedLetterPenalty);
		
		assert: matcher 
		scoreFor: '1a' 
		equals: (matcher leadingLetterPenalty + matcher unmatchedLetterPenalty + matcher caseEqualBonus);
		
		assert: matcher 
		scoreFor: '12345a' 
		equals: (matcher maxLeadingLetterPenalty + (5 * matcher unmatchedLetterPenalty ) + (matcher caseEqualBonus)).
		
	matcher pattern: 'ab'.
	
	self 
	
		assert: matcher 
		scoreFor: 'ab' 
		equals: [ "delayed bonus calculation since #indexscore is based on state after matching" 
			matcher firstLetterBonus 
			+  matcher adjacencyBonus 
			+ (matcher caseEqualBonus * 2) 
			+ (matcher adjacentCaseEqualBonus) 
			+  matcher indexScore
		];
		
		assert: matcher 
		scoreFor: 'A:B' 
		equals: (
			matcher firstLetterBonus 
			+ matcher separatorBonus 
			+ matcher unmatchedLetterPenalty
		);
		
		assert: matcher 
		scoreFor: 'able' 
		equals: [ 
			matcher firstLetterBonus 
			+  matcher adjacencyBonus 
			+  matcher adjacentCaseEqualBonus 
			+ (matcher caseEqualBonus * 2) 
			+ (matcher unmatchedLetterPenalty * 2)
			+  matcher indexScore
		]! !

!FuzzyMatcherTest methodsFor: 'running' stamp: ''!
newMatcher

	^ FuzzyMatcher new! !

!FuzzyMatcherTest methodsFor: 'tests' stamp: ''!
testAssumptions

	self
		assert: (((1 - 1) * 3) max: -9) equals: 0;
	 	assert: ((2 - 1 - 1) negated) equals: 0;				
		assert: ('a' findString: 'a' startingAt: 2 caseSensitive: false) equals: 0! !

!FuzzyMatcherTest methodsFor: 'tests' stamp: ''!
testChangePattern

	| matcher |	
	matcher := self newMatcher.
	
	self 
		assert: matcher pattern equals: '';
		assert: (matcher matches: 'abcdefghijkl');
		assert: (matcher matches: '').
	
	matcher pattern: 'afg'.
	
	self 
		assert: (matcher matches: 'abcdefghijkl');
		deny: (matcher matches: '')! !

!FuzzyMatcherTest methodsFor: 'tests' stamp: ''!
testMatching

	| matcher |	
	matcher := self newMatcher.
	matcher pattern: 'a'.
	
	self 
		assert: (matcher matches: 'a');
		assert: (matcher matches: String cr, String tab, String lf, String space, 'a');
		assert: (matcher matches: ',;:_-!!"#¤%&/?+\()a')! !

!FuzzyMatcherTest methodsFor: 'tests' stamp: ''!
testSortedByScore

	| input output |
	
	input := #('abc' 'a'  'whj' 'cab' 'cat' 'dog' 'ab').	
		
	output := FuzzyMatcher allSortedByScoreMatching: 'a' in: input.
	
	self assertCollection: output asArray equals: #('a' 'ab' 'abc' 'cab' 'cat')! !

!FuzzyMatcherTest methodsFor: 'tests' stamp: ''!
testEmptyPattern

	| matcher |
	matcher := self newMatcher.

	self
		assertEmpty: matcher pattern;
		assert: matcher scoreFor: '' equals: 0;
		assert: matcher scoreFor: 'abc' equals: 0;
		assert: matcher scoreFor: '   ' equals: 0! !

!G1DElement commentStamp: ''!
Description
--------------------

I am the common superclass to all 1D elements. A 1D elements covers elements such as points, lines, segments, rays...!
!G1DElement methodsFor: 'testing' stamp: ''!
boundaryContains: aPoint
	^ self includes: aPoint! !

!G1DElement methodsFor: 'accessing' stamp: ''!
length
	"Return the length of the element."

	^ self subclassResponsibility! !

!G1DElement class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = G1DElement! !

!G2DCoordinates commentStamp: ''!
Description
--------------------

I am a coordinates set for plans. (2D space).

Examples
--------------------

	GCoordinates withCollection: #(1 3).

	G2DCoordinates coordinates: #(1 3).
	
	G2DCoordinates x: 1 y: 2!
!G2DCoordinates class methodsFor: 'instance creation' stamp: ''!
x: aNumber y: anotherNumber
	^ self new
		x: aNumber;
		y: anotherNumber;
		yourself! !

!G2DCoordinates class methodsFor: 'accessing' stamp: ''!
numberOfDimensions
	^ 2! !

!G3DCoordinates commentStamp: ''!
Description
--------------------

I am a coordinates set for 3D spaces.

Examples
--------------------

	GCoordinates withCollection: #(1 3 2).

	G3DCoordinates coordinates: #(1 3 2).
	
	G2DCoordinates x: 1 y: 2 z: 3!
!G3DCoordinates methodsFor: 'accessing' stamp: ''!
z: aNumber
	^ coordinates at: 3 put: aNumber! !

!G3DCoordinates methodsFor: 'accessing' stamp: ''!
z
	^ coordinates at: 3! !

!G3DCoordinates class methodsFor: 'accessing' stamp: ''!
numberOfDimensions
	^ 3! !

!G3DCoordinates class methodsFor: 'instance creation' stamp: ''!
x: aNumber y: anotherNumber z: thirdNumber
	^ self new
		x: aNumber;
		y: anotherNumber;
		z: thirdNumber;
		yourself! !

!GAngle commentStamp: ''!
Description
--------------------

I represent a geometric angle. 

For now I can manage angle in radians or degrees.

If the angle is not in [0;2π[ , I'll take care to convert it in order to store the angle as a radian value in [0;2π[.

Examples
--------------------

	90 degrees. "90.0°"

	(0.5 * Float pi)  radians. "90.0°"
	
	0.5π radians. "90.0°"	
	
	450 degrees. "90.0°"
	
	0.5π radians + 0.5π radians. "180.0°"
	
	0.5π radians - 0.25π radians. "45.0°"
	
	0.5π radians * 6. "180.0°"
	
	6 * 0.5π radians. "180.0°"
	
	90 degrees < 100 degrees. "true"
	
	90 degrees < -270 degrees. "false"
	
	90 degrees < 460 degrees. "false"
	
	0 radians isZero. "true"
	
	90 degrees explementary. "270.0°"
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	radians:		<aNumber>		The angle in radians in bounds [0;2π[
!
!GAngle methodsFor: 'comparison' stamp: ''!
< aGAngle 
	^ self radians < aGAngle radians! !

!GAngle methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].

	^ (radians - anObject radians) =~ 0 or: [ (radians - anObject radians) =~ TwoPi ]! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
* anInteger 
	^ anInteger multiplyWithAngle: self! !

!GAngle methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ radians hash! !

!GAngle methodsFor: 'converting' stamp: ''!
radianNumber
	^ self radians! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
/ anInteger 
	^ anInteger divideWithAngle: self! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
sin
	^ self radians sin! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
addWithAngle: aGAngle 
	^ (self radians + aGAngle radians) radians! !

!GAngle methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream
		nextPutAll: (self degreeNumber asString truncateTo: 10);
		nextPutAll: '°'! !

!GAngle methodsFor: 'converting' stamp: ''!
degreeNumber
	^ self radians radiansToDegrees! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
substractWithAngle: aGAngle 
	^ (aGAngle radians - self radians) radians! !

!GAngle methodsFor: 'testing' stamp: ''!
isObtuse
	^ self > RightAngle and: [ self < StraightAngle ]! !

!GAngle methodsFor: 'comparison' stamp: ''!
> aGAngle 
	^ aGAngle < self! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
adaptToNumber: anInteger andSend: aString 
	(#(#/ #+) anySatisfy: [ :forgivenSelector | aString = forgivenSelector ]) ifTrue: [ self error: 'Cannot execute ' , aString , ' on an Integer with an angle' ]. "I think we can do better than an if here but no time."
	^ self perform: aString with: anInteger! !

!GAngle methodsFor: 'testing' stamp: ''!
isZero
	^ self = ZeroAngle! !

!GAngle methodsFor: 'testing' stamp: ''!
isReflex
	^ self > StraightAngle and: [ self radians < TwoPi ]! !

!GAngle methodsFor: 'testing' stamp: ''!
isRight
	^ self = RightAngle! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
- aGAngle 
	^ aGAngle substractWithAngle: self! !

!GAngle methodsFor: 'testing' stamp: ''!
isAcute
	^ self > 0 radians and: [ self < RightAngle ]! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
tan
	^ self radians tan! !

!GAngle methodsFor: 'testing' stamp: ''!
isStraight
	^ self = StraightAngle! !

!GAngle methodsFor: 'comparison' stamp: ''!
>= aGAngle 
	^ aGAngle <= self! !

!GAngle methodsFor: 'accessing' stamp: ''!
explementary
	^ (0 - self radians) radians! !

!GAngle methodsFor: 'accessing' stamp: ''!
radians
	^ radians! !

!GAngle methodsFor: 'initialization' stamp: ''!
initializeWith: aNumber 
	radians := aNumber.
	radians := radians \\ TwoPi.
	radians negative ifTrue: [ radians := radians + TwoPi ]! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
multiplyWithAngle: aGAngle 
	self error: 'Not possible to multiply an angle by another angle'! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
cos
	^ self radians cos! !

!GAngle methodsFor: 'arithmetic' stamp: ''!
+ aGAngle 
	^ aGAngle addWithAngle: self! !

!GAngle methodsFor: 'comparison' stamp: ''!
<= aGAngle 
	^ (self > aGAngle) not! !

!GAngle class methodsFor: 'class initialization' stamp: ''!
initialize
	TwoPi := 2π.
	ZeroAngle := 0 radians.
	RightAngle := 0.5π radians.
	StraightAngle := 1π radians! !

!GAngle class methodsFor: 'instance creation' stamp: ''!
degrees: anInteger 
	^ self radians: anInteger degreesToRadians! !

!GAngle class methodsFor: 'instance creation' stamp: ''!
radians: aNumber
	^ self new
		initializeWith: aNumber;
		yourself! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testCreation
	angle := 90 degrees.
	self assert: angle equals: (GAngle degrees: 90).

	angle := 1π radians.
	self assert: angle equals: (GAngle radians: 1π)! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testDivision
	angle := 90 degrees.
	self assert: angle / 2 equals: 45 degrees.
	self assert: angle / 1 equals: 90 degrees.
	self should: [ angle / 10 degrees ] raise: Error description: 'It should not be possible to divide two angles'.
	self should: [ 10 / angle ] raise: Error description: 'It should not be possible to divide a number by an angle'.! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testMultiplication
	angle := 90 degrees.
	self assert: angle * 2 equals: 180 degrees.
	self assert: 2 * angle equals: 180 degrees.
	self assert: angle * 1 equals: 90 degrees.
	self should: [ angle * 10 degrees ] raise: GeometryError description: 'It should not be possible to multiple two angles'! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testInferior
	angle := 90 degrees.
	self assert: angle < 100 degrees.
	self deny: angle < 90 degrees.
	self deny: angle < 80 degrees.
	self deny: angle < 400 degrees.
	self assert: angle < -260 degrees! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testEquals
	angle := 90 degrees.
	self assert: angle equals: 90 degrees.
	self assert: angle hash equals: 90 degrees hash.
	self deny: angle = 60 degrees.
	self deny: angle hash = 60 degrees hash.
	self assert: angle equals: 450 degrees.
	self assert: angle hash equals: 450 degrees hash.
	self assert: angle equals: -270 degrees.
	self assert: angle hash equals: -270 degrees hash.
	
	self assert: angle = 90.00000000000000000000000000000000000000000000000001 degrees description: 'We accept a little imprecision because of the float precision'! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testIsObtuse
	angle := 80 degrees.
	self deny: angle isObtuse.
	
	angle := 100 degrees.
	self assert: angle isObtuse.
	
	angle := 190 degrees.
	self deny: angle isObtuse.
	
	angle := 90 degrees.
	self deny: angle isObtuse! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testIsZero
	angle := 0 degrees.
	self assert: angle isZero.

	angle := 90 degrees.
	self deny: angle isZero! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testRadianNumber
	angle := 90 degrees.
	self assert: angle radianNumber equals: 0.5π! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testIsRight
	angle := 80 degrees.
	self deny: angle isRight.
	
	angle := 100 degrees.
	self deny: angle isRight.
	
	angle := 90 degrees.
	self assert: angle isRight! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testExplementary
	angle := 90 degrees.
	self assert: angle explementary equals: 270 degrees.
	
	angle := 80 degrees.
	self assert: angle explementary equals: 280 degrees! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testSuperiorOrEqual
	angle := 90 degrees.
	self deny: angle >= 100 degrees.
	self assert: angle >= 90 degrees.
	self assert: angle >= 80 degrees.
	self assert: angle >= 400 degrees.
	self deny: angle >= -260 degrees! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testIsStraight
	angle := 80 degrees.
	self deny: angle isStraight.
	
	angle := 180 degrees.
	self assert: angle isStraight.
	
	angle := 200 degrees.
	self deny: angle isStraight! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testInferiorOrEqual
	angle := 90 degrees.
	self assert: angle <= 100 degrees.
	self assert: angle <= 90 degrees.
	self deny: angle <= 80 degrees.
	self deny: angle <= 400 degrees.
	self assert: angle <= -260 degrees! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testTan	
	angle := 180 degrees.
	self assert: angle tan =~ 0.
	
	angle := 0 degrees.
	self assert: angle tan =~ 0! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testDegreeNumber
	angle := 90 degrees.
	self assert: angle degreeNumber equals: 90! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testAddition
	angle := 90 degrees.
	self assert: (angle + 10 degrees) equals: 100 degrees.
	self assert: (angle + 360 degrees) equals: 90 degrees.
	self should: [ angle + 10 ] raise: Error description: 'It should not be possible to add a number to an angle'.! !

!GAngleTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GAngle! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testCos
	angle := 90 degrees.
	self assert: angle cos =~ 0.
	
	angle := 180 degrees.
	self assert: angle cos =~ -1.
	
	angle := 270 degrees.
	self assert: angle cos =~ 0.
	
	angle := 0 degrees.
	self assert: angle cos =~ 1! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testIsAcute
	angle := 80 degrees.
	self assert: angle isAcute.
	
	angle := 100 degrees.
	self deny: angle isAcute.
	
	angle := 90 degrees.
	self deny: angle isAcute! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testIsReflex
	angle := 80 degrees.
	self deny: angle isReflex.
	
	angle := 180 degrees.
	self deny: angle isReflex.
	
	angle := 200 degrees.
	self assert: angle isReflex! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testSin
	angle := 90 degrees.
	self assert: angle sin =~ 1.
	
	angle := 180 degrees.
	self assert: angle sin =~ 0.
	
	angle := 270 degrees.
	self assert: angle sin =~ -1.
	
	angle := 0 degrees.
	self assert: angle sin =~ 0! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testSubtraction
	angle := 90 degrees.
	self assert: (angle - 10 degrees) equals: 80 degrees.
	self assert: (angle - 360 degrees) equals: 90 degrees.
	self should: [ angle - 10 ] raise: Error description: 'It should not be possible to substract a number to an angle'.! !

!GAngleTest methodsFor: 'tests' stamp: ''!
testSuperior
	angle := 90 degrees.
	self deny: angle > 100 degrees.
	self deny: angle > 90 degrees.
	self assert: angle > 80 degrees.
	self assert: angle > 400 degrees.
	self deny: angle > -260 degrees! !

!GArc commentStamp: ''!
Description
--------------------

In Euclidean geometry, an arc is a closed segment of a differentiable curve.

It is defined by 3 parameters
- The center of the arc
- The origin of the arc
- The oriented angle of the arc

Examples
--------------------

	GArc center: 3 , 3 origin: 5 , 6 angle: 0.5π radians.
	
	GArc center: 3 , 3 origin: 5 , 6 angle: 90 degrees.
	
	GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10.
	
	(GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10) endPoint.
	
	(GArc center: 1 , 0 origin: 4 , 0 direction: -1 , 2) includes: 1 , 3.
	
	(GArc center: -1 , 0 origin: 4 , 0 direction: 1 , 4) intersectionsWith: (GLine through: 0 , 0 and: 1 , 1).
	
	(GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10) length.
	
	(GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10) radius.
	
	(GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10) translateBy: #(1 -2) asGVector.
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	center:			<aGPoint>		Center of the circle whose bounds contains the arc.
	direction:		<aGPoint>		Origin point of the arc.
	angle:				<aGAngle>		Angle betweent the vector center-origin and the vector center-endpoint of the arc.
!
!GArc methodsFor: 'accessing' stamp: ''!
centralAngle
	"Alias of angle to cover the geometric names"

	^ self angle! !

!GArc methodsFor: 'accessing' stamp: ''!
center
	^ center! !

!GArc methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].
	
	^ origin = anObject origin and: [ center = anObject center and: [ angle = anObject angle ] ]! !

!GArc methodsFor: 'accessing' stamp: ''!
center: anObject
	center := anObject! !

!GArc methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ origin hash bitXor: (center hash bitXor: angle hash)! !

!GArc methodsFor: 'testing' stamp: ''!
includes: aGPoint
	"An arc includes a point in the angle between the vector defined by the origin and center and the vector defined by the point and the center is between 0 and the arc angle and if the distance of the point from the center is equals to the radius."

	^ ((self origin - self center angleWith: aGPoint - self center) < self angle)
		and: [ (aGPoint distanceTo: self center) =~ self radius ]! !

!GArc methodsFor: 'accessing' stamp: ''!
angle
	^ angle! !

!GArc methodsFor: 'intersections' stamp: ''!
intersectionsWith: anElement
	^ anElement intersectionsWithArc: self! !

!GArc methodsFor: 'comparing' stamp: ''!
translateBy: aGVector 
	self center: self center + aGVector.
	self origin: self origin + aGVector! !

!GArc methodsFor: 'accessing' stamp: ''!
origin
	^ origin! !

!GArc methodsFor: 'intersections' stamp: ''!
intersectionsWithLine: aGLine 
	^ aGLine intersectionsWithArc: self! !

!GArc methodsFor: 'accessing' stamp: ''!
origin: anObject
	origin := anObject! !

!GArc methodsFor: 'intersections' stamp: ''!
intersectionsWithEllipse: aGEllipse
	^ aGEllipse intersectionsWithArc: self! !

!GArc methodsFor: 'comparing' stamp: ''!
printOn: aStream
	super printOn: aStream.

	aStream
		<< $(;
		<< 'center: ';
		print: center coordinates;
		<< ' | origin: ';
		print: origin coordinates;
		<< ' | angle: ';
		print: self angle;
		<< $)! !

!GArc methodsFor: 'accessing' stamp: ''!
endPoint
	"The end point is the point at the end of the arc (opposed to the origin)."

	^ self origin rotatedBy: self angle about: self center! !

!GArc methodsFor: 'accessing' stamp: ''!
radius
	^ (self origin - self center) length! !

!GArc methodsFor: 'accessing' stamp: ''!
length
	^ self angle radians * self radius! !

!GArc methodsFor: 'accessing' stamp: ''!
angle: anObject
	angle := anObject! !

!GArc class methodsFor: 'instance creation' stamp: ''!
center: aGPoint origin: anotherGPoint direction: yetAnotherGPoint
	"Take three parameters to create a new arc:
	- A point representing the center of the arc (center of the circle whose bond contains the arc circle)
	- A point defining the origin of the arc
	- A point denining the direction of the arc in the trigonometric direction"
	
	"The conventional representation of an arc it a center, an origin and an angle. To determine the angle we compute the oriented angle between the vector center-origin and the vector center-direction."
	^ self center: aGPoint origin: anotherGPoint angle: (aGPoint - anotherGPoint angleWith: aGPoint - yetAnotherGPoint)! !

!GArc class methodsFor: 'instance creation' stamp: ''!
center: aGPoint origin: anotherGPoint angle: aGAngle
	"Take three parameters to create a new arc:
	- A point representing the center of the arc (center of the circle whose bond contains the arc circle)
	- A point defining the origin of the arc
	- An angle representing the angle between the vector center-origin and the vector center-endpoint of the arc."

	^ self new
		center: aGPoint;
		origin: anotherGPoint;
		angle: aGAngle;
		yourself! !

!GArcTest commentStamp: ''!
A G1DElementTest is a test class for testing the behavior of G1DElement!
!GArcTest methodsFor: 'test' stamp: ''!
testIntersectionsWithPolygon
	| polygon |
	polygon := GPolygon vertices: {(1 , 2) . (1 , 5) . (-3 , 5) . (-3 , 0)}.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (arc intersectionsWith: polygon) isEmpty.

	arc := GArc center: 1 , 0 origin: 4 , 0 direction: -1 , 2.
	self assert: (arc intersectionsWith: polygon) hasCloseElementsTo: {(1 , 3)}.
	self assertCollection: (arc intersectionsWith: polygon) hasSameElements: (arc intersectionsWithPolygon: polygon)! !

!GArcTest methodsFor: 'test' stamp: ''!
testEndPoint
	arc := GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10.
	self assert: arc endPoint equals: 8 , 8! !

!GArcTest methodsFor: 'test' stamp: ''!
testIncludes
	arc := GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10.
	self assert: (arc includes: 8.8284271247462 , 6).
	self deny: (arc includes: 8 , 6).
	self deny: (arc includes: 4 , 4).
	self deny: (arc includes: 4 , 8).
	
	arc := GArc center: 6 , 6 origin: 8 , 4 direction: 3, 6.
	self assert: (arc includes: 8.8284271247462 , 6).
	self deny: (arc includes: 8 , 6).
	self deny: (arc includes: 4 , 4).
	self assert: (arc includes: 4 , 8).! !

!GArcTest methodsFor: 'test' stamp: ''!
testTranslateBy
	arc := GArc center: 6 , 6 origin: 10 , 6 direction: 10 , 10.
	arc translateBy: #(1 -2) asGVector.
	self assert: arc equals: (GArc center: 7 , 4 origin: 11 , 4 direction: 11 , 8)! !

!GArcTest methodsFor: 'test' stamp: ''!
testEquals
	arc := GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10.
	self assert: arc equals: (GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10).
	self assert: arc hash equals: (GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10) hash.
	self assert: arc equals: (GArc center: 6 , 6 origin: 8 , 4 direction: 11 , 11).
	self assert: arc hash equals: (GArc center: 6 , 6 origin: 8 , 4 direction: 11 , 11) hash.
	
	self deny: arc = (GArc center: 5 , 6 origin: 8 , 4 direction: 11 , 11).
	self deny: arc hash = (GArc center: 5 , 6 origin: 8 , 4 direction: 11 , 11) hash.
	self deny: arc = (GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 11).
	self deny: arc hash = (GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 11) hash.
	
	arc := GArc center: 6 , 6 origin: 8 , 4 angle: 0.5π radians.
	self assert: arc equals: (GArc center: 6 , 6 origin: 8 , 4 angle: 0.5π radians).
	self assert: arc hash equals: (GArc center: 6 , 6 origin: 8 , 4 angle: 0.5π radians) hash.! !

!GArcTest methodsFor: 'test' stamp: ''!
testCentralAngle
	arc := GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10.
	self assert: arc centralAngle equals: 90 degrees.
	self assert: arc centralAngle equals: arc angle.! !

!GArcTest methodsFor: 'test' stamp: ''!
testAngle
	arc := GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10.
	self assert: arc angle equals: 90 degrees! !

!GArcTest methodsFor: 'test' stamp: ''!
testIntersectionsWithEllipse
	"Because we need the intersection between two ellipse to do that. Until we have that, we declare the test as expected failure"
	<expectedFailure>
	| ellipse |
	ellipse := GEllipse center: -4 , 3 vertex: 1 , 3 coVertex: -4 , 7.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (arc intersectionsWith: ellipse) isEmpty.

	arc := GArc center: 1 , 0 origin: 4 , 0 direction: -1 , 2.
	self assert: (arc intersectionsWith: ellipse) hasCloseElementsTo: {(1 , 3)}.
	self assertCollection: (arc intersectionsWith: ellipse) hasSameElements: (arc intersectionsWithEllipse: ellipse)! !

!GArcTest methodsFor: 'test' stamp: ''!
testLength
	arc := GArc center: 6 , 6 origin: 8 , 4 direction: 10 , 10.
	self assert: arc length =~ 4.442882938158366! !

!GArcTest methodsFor: 'test' stamp: ''!
testIntersectionsWithPoint
	| point |
	point := 3 , 3.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (arc intersectionsWith: point) isEmpty.

	arc := GArc center: -1 , 0 origin: 4 , 0 direction: 1 , 4.
	self assert: (arc intersectionsWith: point) hasCloseElementsTo: {(3 , 3)}.
	self assertCollection: (arc intersectionsWith: point) hasSameElements: (arc intersectionsWithPoint: point)! !

!GArcTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GArc! !

!GArcTest methodsFor: 'test' stamp: ''!
testIntersectionsWithSegment
	| segment |
	segment := GSegment with: 0 , 0 with: 1 , 1.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (arc intersectionsWith: segment) isEmpty.

	arc := GArc center: -1 , 0 origin: 4 , 0 direction: 1 , 4.
	self assert: (arc intersectionsWith: segment) isEmpty.

	segment := GSegment with: 0 , 0 with: 4 , 4.
	self assert: (arc intersectionsWith: segment) hasCloseElementsTo: {(3 , 3)}.
	self assertCollection: (arc intersectionsWith: segment) hasSameElements: (arc intersectionsWithSegment: segment)! !

!GArcTest methodsFor: 'test' stamp: ''!
testIntersectionsWithLine
	| line |
	line := GLine through: 0 , 0 and: 1 , 1.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (arc intersectionsWith: line) isEmpty.

	arc := GArc center: -1 , 0 origin: 4 , 0 direction: 1 , 4.
	self assert: (arc intersectionsWith: line) hasCloseElementsTo: {(3 , 3)}.
	self assertCollection: (arc intersectionsWith: line) hasSameElements: (arc intersectionsWithLine: line)! !

!GArcTest methodsFor: 'test' stamp: ''!
testRadius
	arc := GArc center: 6 , 6 origin: 10 , 6 direction: 10 , 10.
	self assert: arc radius equals: 4! !

!GArcTest methodsFor: 'test' stamp: ''!
testIntersectionsWithRay
	| ray |
	ray := GRay origin: 0 , 0 direction: 1 , 1.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (arc intersectionsWith: ray) isEmpty.

	arc := GArc center: -1 , 0 origin: 4 , 0 direction: 1 , 4.
	self assert: (arc intersectionsWith: ray flipped) isEmpty.

	self assert: (arc intersectionsWith: ray) hasCloseElementsTo: {(3 , 3)}.
	self assertCollection: (arc intersectionsWith: ray) hasSameElements: (arc intersectionsWithRay: ray)! !

!GArcTest methodsFor: 'test' stamp: ''!
testIntersectionsWithArc
	"Because we need the intersection between two ellipse to do that. Until we have that, we declare the test as expected failure"
	<expectedFailure>
	| arc2 |
	arc2 := GArc center: 1 , -1 origin: 5 , -1 direction: 5 , 0.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: -1 , 2.
	self assert: (arc intersectionsWith: arc2) isEmpty.


	arc2 := GArc center: 1 , -1 origin: 5 , -1 direction: 0 , 2.
	self assert: (arc intersectionsWith: arc2) hasCloseElementsTo: {(1 , 3)}.
	self assertCollection: (arc intersectionsWith: arc2) hasSameElements: (arc intersectionsWithArc: arc2)! !

!GB2312 commentStamp: ''!
This class represents the domestic character encoding called GB 2312 used for simplified Chinese.
!
!GB2312 class methodsFor: 'class methods' stamp: ''!
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: ''!
leadingChar

	^ 2.
! !

!GB2312 class methodsFor: 'class methods' stamp: ''!
initialize
	"
	GB2312 initialize
"
	self initializeUcsTable.
	EncodedCharSet declareEncodedCharSet: self atIndex: 2+1.
	EncodedCharSet declareEncodedCharSet: self atIndex: 8+1.
	compoundTextSequence := String streamContents: 
		[ :stream | 
		stream nextPut: Character escape.
		stream nextPut: $$.
		stream nextPut: $(.
		stream nextPut: $A ]! !

!GB2312 class methodsFor: 'class methods' stamp: ''!
compoundTextSequence
	^ compoundTextSequence! !

!GB2312 class methodsFor: 'class methods' stamp: ''!
initializeUcsTable

	| table size gb2312 unicode gb2312Table |
	table := #(16r2121 16r3000 16r2122 16r3001 16r2123 16r3002 16r2124 16r30FB 16r2125 16r02C9 16r2126 16r02C7 16r2127 16r00A8 16r2128 16r3003 16r2129 16r3005 16r212A 16r2015 16r212B 16rFF5E 16r212C 16r2016 16r212D 16r2026 16r212E 16r2018 16r212F 16r2019 16r2130 16r201C 16r2131 16r201D 16r2132 16r3014 16r2133 16r3015 16r2134 16r3008 16r2135 16r3009 16r2136 16r300A 16r2137 16r300B 16r2138 16r300C 16r2139 16r300D 16r213A 16r300E 16r213B 16r300F 16r213C 16r3016 16r213D 16r3017 16r213E 16r3010 16r213F 16r3011 16r2140 16r00B1 16r2141 16r00D7 16r2142 16r00F7 16r2143 16r2236 16r2144 16r2227 16r2145 16r2228 16r2146 16r2211 16r2147 16r220F 16r2148 16r222A 16r2149 16r2229 16r214A 16r2208 16r214B 16r2237 16r214C 16r221A 16r214D 16r22A5 16r214E 16r2225 16r214F 16r2220 16r2150 16r2312 16r2151 16r2299 16r2152 16r222B 16r2153 16r222E 16r2154 16r2261 16r2155 16r224C 16r2156 16r2248 16r2157 16r223D 16r2158 16r221D 16r2159 16r2260 16r215A 16r226E 16r215B 16r226F 16r215C 16r2264 16r215D 16r2265 16r215E 16r221E 16r215F 16r2235 16r2160 16r2234 16r2161 16r2642 16r2162 16r2640 16r2163 16r00B0 16r2164 16r2032 16r2165 16r2033 16r2166 16r2103 16r2167 16rFF04 16r2168 16r00A4 16r2169 16rFFE0 16r216A 16rFFE1 16r216B 16r2030 16r216C 16r00A7 16r216D 16r2116 16r216E 16r2606 16r216F 16r2605 16r2170 16r25CB 16r2171 16r25CF 16r2172 16r25CE 16r2173 16r25C7 16r2174 16r25C6 16r2175 16r25A1 16r2176 16r25A0 16r2177 16r25B3 16r2178 16r25B2 16r2179 16r203B 16r217A 16r2192 16r217B 16r2190 16r217C 16r2191 16r217D 16r2193 16r217E 16r3013 16r2231 16r2488 16r2232 16r2489 16r2233 16r248A 16r2234 16r248B 16r2235 16r248C 16r2236 16r248D 16r2237 16r248E 16r2238 16r248F 16r2239 16r2490 16r223A 16r2491 16r223B 16r2492 16r223C 16r2493 16r223D 16r2494 16r223E 16r2495 16r223F 16r2496 16r2240 16r2497 16r2241 16r2498 16r2242 16r2499 16r2243 16r249A 16r2244 16r249B 16r2245 16r2474 16r2246 16r2475 16r2247 16r2476 16r2248 16r2477 16r2249 16r2478 16r224A 16r2479 16r224B 16r247A 16r224C 16r247B 16r224D 16r247C 16r224E 16r247D 16r224F 16r247E 16r2250 16r247F 16r2251 16r2480 16r2252 16r2481 16r2253 16r2482 16r2254 16r2483 16r2255 16r2484 16r2256 16r2485 16r2257 16r2486 16r2258 16r2487 16r2259 16r2460 16r225A 16r2461 16r225B 16r2462 16r225C 16r2463 16r225D 16r2464 16r225E 16r2465 16r225F 16r2466 16r2260 16r2467 16r2261 16r2468 16r2262 16r2469 16r2265 16r3220 16r2266 16r3221 16r2267 16r3222 16r2268 16r3223 16r2269 16r3224 16r226A 16r3225 16r226B 16r3226 16r226C 16r3227 16r226D 16r3228 16r226E 16r3229 16r2271 16r2160 16r2272 16r2161 16r2273 16r2162 16r2274 16r2163 16r2275 16r2164 16r2276 16r2165 16r2277 16r2166 16r2278 16r2167 16r2279 16r2168 16r227A 16r2169 16r227B 16r216A 16r227C 16r216B 16r2321 16rFF01 16r2322 16rFF02 16r2323 16rFF03 16r2324 16rFFE5 16r2325 16rFF05 16r2326 16rFF06 16r2327 16rFF07 16r2328 16rFF08 16r2329 16rFF09 16r232A 16rFF0A 16r232B 16rFF0B 16r232C 16rFF0C 16r232D 16rFF0D 16r232E 16rFF0E 16r232F 16rFF0F 16r2330 16rFF10 16r2331 16rFF11 16r2332 16rFF12 16r2333 16rFF13 16r2334 16rFF14 16r2335 16rFF15 16r2336 16rFF16 16r2337 16rFF17 16r2338 16rFF18 16r2339 16rFF19 16r233A 16rFF1A 16r233B 16rFF1B 16r233C 16rFF1C 16r233D 16rFF1D 16r233E 16rFF1E 16r233F 16rFF1F 16r2340 16rFF20 16r2341 16rFF21 16r2342 16rFF22 16r2343 16rFF23 16r2344 16rFF24 16r2345 16rFF25 16r2346 16rFF26 16r2347 16rFF27 16r2348 16rFF28 16r2349 16rFF29 16r234A 16rFF2A 16r234B 16rFF2B 16r234C 16rFF2C 16r234D 16rFF2D 16r234E 16rFF2E 16r234F 16rFF2F 16r2350 16rFF30 16r2351 16rFF31 16r2352 16rFF32 16r2353 16rFF33 16r2354 16rFF34 16r2355 16rFF35 16r2356 16rFF36 16r2357 16rFF37 16r2358 16rFF38 16r2359 16rFF39 16r235A 16rFF3A 16r235B 16rFF3B 16r235C 16rFF3C 16r235D 16rFF3D 16r235E 16rFF3E 16r235F 16rFF3F 16r2360 16rFF40 16r2361 16rFF41 16r2362 16rFF42 16r2363 16rFF43 16r2364 16rFF44 16r2365 16rFF45 16r2366 16rFF46 16r2367 16rFF47 16r2368 16rFF48 16r2369 16rFF49 16r236A 16rFF4A 16r236B 16rFF4B 16r236C 16rFF4C 16r236D 16rFF4D 16r236E 16rFF4E 16r236F 16rFF4F 16r2370 16rFF50 16r2371 16rFF51 16r2372 16rFF52 16r2373 16rFF53 16r2374 16rFF54 16r2375 16rFF55 16r2376 16rFF56 16r2377 16rFF57 16r2378 16rFF58 16r2379 16rFF59 16r237A 16rFF5A 16r237B 16rFF5B 16r237C 16rFF5C 16r237D 16rFF5D 16r237E 16rFFE3 16r2421 16r3041 16r2422 16r3042 16r2423 16r3043 16r2424 16r3044 16r2425 16r3045 16r2426 16r3046 16r2427 16r3047 16r2428 16r3048 16r2429 16r3049 16r242A 16r304A 16r242B 16r304B 16r242C 16r304C 16r242D 16r304D 16r242E 16r304E 16r242F 16r304F 16r2430 16r3050 16r2431 16r3051 16r2432 16r3052 16r2433 16r3053 16r2434 16r3054 16r2435 16r3055 16r2436 16r3056 16r2437 16r3057 16r2438 16r3058 16r2439 16r3059 16r243A 16r305A 16r243B 16r305B 16r243C 16r305C 16r243D 16r305D 16r243E 16r305E 16r243F 16r305F 16r2440 16r3060 16r2441 16r3061 16r2442 16r3062 16r2443 16r3063 16r2444 16r3064 16r2445 16r3065 16r2446 16r3066 16r2447 16r3067 16r2448 16r3068 16r2449 16r3069 16r244A 16r306A 16r244B 16r306B 16r244C 16r306C 16r244D 16r306D 16r244E 16r306E 16r244F 16r306F 16r2450 16r3070 16r2451 16r3071 16r2452 16r3072 16r2453 16r3073 16r2454 16r3074 16r2455 16r3075 16r2456 16r3076 16r2457 16r3077 16r2458 16r3078 16r2459 16r3079 16r245A 16r307A 16r245B 16r307B 16r245C 16r307C 16r245D 16r307D 16r245E 16r307E 16r245F 16r307F 16r2460 16r3080 16r2461 16r3081 16r2462 16r3082 16r2463 16r3083 16r2464 16r3084 16r2465 16r3085 16r2466 16r3086 16r2467 16r3087 16r2468 16r3088 16r2469 16r3089 16r246A 16r308A 16r246B 16r308B 16r246C 16r308C 16r246D 16r308D 16r246E 16r308E 16r246F 16r308F 16r2470 16r3090 16r2471 16r3091 16r2472 16r3092 16r2473 16r3093 16r2521 16r30A1 16r2522 16r30A2 16r2523 16r30A3 16r2524 16r30A4 16r2525 16r30A5 16r2526 16r30A6 16r2527 16r30A7 16r2528 16r30A8 16r2529 16r30A9 16r252A 16r30AA 16r252B 16r30AB 16r252C 16r30AC 16r252D 16r30AD 16r252E 16r30AE 16r252F 16r30AF 16r2530 16r30B0 16r2531 16r30B1 16r2532 16r30B2 16r2533 16r30B3 16r2534 16r30B4 16r2535 16r30B5 16r2536 16r30B6 16r2537 16r30B7 16r2538 16r30B8 16r2539 16r30B9 16r253A 16r30BA 16r253B 16r30BB 16r253C 16r30BC 16r253D 16r30BD 16r253E 16r30BE 16r253F 16r30BF 16r2540 16r30C0 16r2541 16r30C1 16r2542 16r30C2 16r2543 16r30C3 16r2544 16r30C4 16r2545 16r30C5 16r2546 16r30C6 16r2547 16r30C7 16r2548 16r30C8 16r2549 16r30C9 16r254A 16r30CA 16r254B 16r30CB 16r254C 16r30CC 16r254D 16r30CD 16r254E 16r30CE 16r254F 16r30CF 16r2550 16r30D0 16r2551 16r30D1 16r2552 16r30D2 16r2553 16r30D3 16r2554 16r30D4 16r2555 16r30D5 16r2556 16r30D6 16r2557 16r30D7 16r2558 16r30D8 16r2559 16r30D9 16r255A 16r30DA 16r255B 16r30DB 16r255C 16r30DC 16r255D 16r30DD 16r255E 16r30DE 16r255F 16r30DF 16r2560 16r30E0 16r2561 16r30E1 16r2562 16r30E2 16r2563 16r30E3 16r2564 16r30E4 16r2565 16r30E5 16r2566 16r30E6 16r2567 16r30E7 16r2568 16r30E8 16r2569 16r30E9 16r256A 16r30EA 16r256B 16r30EB 16r256C 16r30EC 16r256D 16r30ED 16r256E 16r30EE 16r256F 16r30EF 16r2570 16r30F0 16r2571 16r30F1 16r2572 16r30F2 16r2573 16r30F3 16r2574 16r30F4 16r2575 16r30F5 16r2576 16r30F6 16r2621 16r0391 16r2622 16r0392 16r2623 16r0393 16r2624 16r0394 16r2625 16r0395 16r2626 16r0396 16r2627 16r0397 16r2628 16r0398 16r2629 16r0399 16r262A 16r039A 16r262B 16r039B 16r262C 16r039C 16r262D 16r039D 16r262E 16r039E 16r262F 16r039F 16r2630 16r03A0 16r2631 16r03A1 16r2632 16r03A3 16r2633 16r03A4 16r2634 16r03A5 16r2635 16r03A6 16r2636 16r03A7 16r2637 16r03A8 16r2638 16r03A9 16r2641 16r03B1 16r2642 16r03B2 16r2643 16r03B3 16r2644 16r03B4 16r2645 16r03B5 16r2646 16r03B6 16r2647 16r03B7 16r2648 16r03B8 16r2649 16r03B9 16r264A 16r03BA 16r264B 16r03BB 16r264C 16r03BC 16r264D 16r03BD 16r264E 16r03BE 16r264F 16r03BF 16r2650 16r03C0 16r2651 16r03C1 16r2652 16r03C3 16r2653 16r03C4 16r2654 16r03C5 16r2655 16r03C6 16r2656 16r03C7 16r2657 16r03C8 16r2658 16r03C9 16r2721 16r0410 16r2722 16r0411 16r2723 16r0412 16r2724 16r0413 16r2725 16r0414 16r2726 16r0415 16r2727 16r0401 16r2728 16r0416 16r2729 16r0417 16r272A 16r0418 16r272B 16r0419 16r272C 16r041A 16r272D 16r041B 16r272E 16r041C 16r272F 16r041D 16r2730 16r041E 16r2731 16r041F 16r2732 16r0420 16r2733 16r0421 16r2734 16r0422 16r2735 16r0423 16r2736 16r0424 16r2737 16r0425 16r2738 16r0426 16r2739 16r0427 16r273A 16r0428 16r273B 16r0429 16r273C 16r042A 16r273D 16r042B 16r273E 16r042C 16r273F 16r042D 16r2740 16r042E 16r2741 16r042F 16r2751 16r0430 16r2752 16r0431 16r2753 16r0432 16r2754 16r0433 16r2755 16r0434 16r2756 16r0435 16r2757 16r0451 16r2758 16r0436 16r2759 16r0437 16r275A 16r0438 16r275B 16r0439 16r275C 16r043A 16r275D 16r043B 16r275E 16r043C 16r275F 16r043D 16r2760 16r043E 16r2761 16r043F 16r2762 16r0440 16r2763 16r0441 16r2764 16r0442 16r2765 16r0443 16r2766 16r0444 16r2767 16r0445 16r2768 16r0446 16r2769 16r0447 16r276A 16r0448 16r276B 16r0449 16r276C 16r044A 16r276D 16r044B 16r276E 16r044C 16r276F 16r044D 16r2770 16r044E 16r2771 16r044F 16r2821 16r0101 16r2822 16r00E1 16r2823 16r01CE 16r2824 16r00E0 16r2825 16r0113 16r2826 16r00E9 16r2827 16r011B 16r2828 16r00E8 16r2829 16r012B 16r282A 16r00ED 16r282B 16r01D0 16r282C 16r00EC 16r282D 16r014D 16r282E 16r00F3 16r282F 16r01D2 16r2830 16r00F2 16r2831 16r016B 16r2832 16r00FA 16r2833 16r01D4 16r2834 16r00F9 16r2835 16r01D6 16r2836 16r01D8 16r2837 16r01DA 16r2838 16r01DC 16r2839 16r00FC 16r283A 16r00EA 16r2845 16r3105 16r2846 16r3106 16r2847 16r3107 16r2848 16r3108 16r2849 16r3109 16r284A 16r310A 16r284B 16r310B 16r284C 16r310C 16r284D 16r310D 16r284E 16r310E 16r284F 16r310F 16r2850 16r3110 16r2851 16r3111 16r2852 16r3112 16r2853 16r3113 16r2854 16r3114 16r2855 16r3115 16r2856 16r3116 16r2857 16r3117 16r2858 16r3118 16r2859 16r3119 16r285A 16r311A 16r285B 16r311B 16r285C 16r311C 16r285D 16r311D 16r285E 16r311E 16r285F 16r311F 16r2860 16r3120 16r2861 16r3121 16r2862 16r3122 16r2863 16r3123 16r2864 16r3124 16r2865 16r3125 16r2866 16r3126 16r2867 16r3127 16r2868 16r3128 16r2869 16r3129 16r2924 16r2500 16r2925 16r2501 16r2926 16r2502 16r2927 16r2503 16r2928 16r2504 16r2929 16r2505 16r292A 16r2506 16r292B 16r2507 16r292C 16r2508 16r292D 16r2509 16r292E 16r250A 16r292F 16r250B 16r2930 16r250C 16r2931 16r250D 16r2932 16r250E 16r2933 16r250F 16r2934 16r2510 16r2935 16r2511 16r2936 16r2512 16r2937 16r2513 16r2938 16r2514 16r2939 16r2515 16r293A 16r2516 16r293B 16r2517 16r293C 16r2518 16r293D 16r2519 16r293E 16r251A 16r293F 16r251B 16r2940 16r251C 16r2941 16r251D 16r2942 16r251E 16r2943 16r251F 16r2944 16r2520 16r2945 16r2521 16r2946 16r2522 16r2947 16r2523 16r2948 16r2524 16r2949 16r2525 16r294A 16r2526 16r294B 16r2527 16r294C 16r2528 16r294D 16r2529 16r294E 16r252A 16r294F 16r252B 16r2950 16r252C 16r2951 16r252D 16r2952 16r252E 16r2953 16r252F 16r2954 16r2530 16r2955 16r2531 16r2956 16r2532 16r2957 16r2533 16r2958 16r2534 16r2959 16r2535 16r295A 16r2536 16r295B 16r2537 16r295C 16r2538 16r295D 16r2539 16r295E 16r253A 16r295F 16r253B 16r2960 16r253C 16r2961 16r253D 16r2962 16r253E 16r2963 16r253F 16r2964 16r2540 16r2965 16r2541 16r2966 16r2542 16r2967 16r2543 16r2968 16r2544 16r2969 16r2545 16r296A 16r2546 16r296B 16r2547 16r296C 16r2548 16r296D 16r2549 16r296E 16r254A 16r296F 16r254B 16r3021 16r554A 16r3022 16r963F 16r3023 16r57C3 16r3024 16r6328 16r3025 16r54CE 16r3026 16r5509 16r3027 16r54C0 16r3028 16r7691 16r3029 16r764C 16r302A 16r853C 16r302B 16r77EE 16r302C 16r827E 16r302D 16r788D 16r302E 16r7231 16r302F 16r9698 16r3030 16r978D 16r3031 16r6C28 16r3032 16r5B89 16r3033 16r4FFA 16r3034 16r6309 16r3035 16r6697 16r3036 16r5CB8 16r3037 16r80FA 16r3038 16r6848 16r3039 16r80AE 16r303A 16r6602 16r303B 16r76CE 16r303C 16r51F9 16r303D 16r6556 16r303E 16r71AC 16r303F 16r7FF1 16r3040 16r8884 16r3041 16r50B2 16r3042 16r5965 16r3043 16r61CA 16r3044 16r6FB3 16r3045 16r82AD 16r3046 16r634C 16r3047 16r6252 16r3048 16r53ED 16r3049 16r5427 16r304A 16r7B06 16r304B 16r516B 16r304C 16r75A4 16r304D 16r5DF4 16r304E 16r62D4 16r304F 16r8DCB 16r3050 16r9776 16r3051 16r628A 16r3052 16r8019 16r3053 16r575D 16r3054 16r9738 16r3055 16r7F62 16r3056 16r7238 16r3057 16r767D 16r3058 16r67CF 16r3059 16r767E 16r305A 16r6446 16r305B 16r4F70 16r305C 16r8D25 16r305D 16r62DC 16r305E 16r7A17 16r305F 16r6591 16r3060 16r73ED 16r3061 16r642C 16r3062 16r6273 16r3063 16r822C 16r3064 16r9881 16r3065 16r677F 16r3066 16r7248 16r3067 16r626E 16r3068 16r62CC 16r3069 16r4F34 16r306A 16r74E3 16r306B 16r534A 16r306C 16r529E 16r306D 16r7ECA 16r306E 16r90A6 16r306F 16r5E2E 16r3070 16r6886 16r3071 16r699C 16r3072 16r8180 16r3073 16r7ED1 16r3074 16r68D2 16r3075 16r78C5 16r3076 16r868C 16r3077 16r9551 16r3078 16r508D 16r3079 16r8C24 16r307A 16r82DE 16r307B 16r80DE 16r307C 16r5305 16r307D 16r8912 16r307E 16r5265 16r3121 16r8584 16r3122 16r96F9 16r3123 16r4FDD 16r3124 16r5821 16r3125 16r9971 16r3126 16r5B9D 16r3127 16r62B1 16r3128 16r62A5 16r3129 16r66B4 16r312A 16r8C79 16r312B 16r9C8D 16r312C 16r7206 16r312D 16r676F 16r312E 16r7891 16r312F 16r60B2 16r3130 16r5351 16r3131 16r5317 16r3132 16r8F88 16r3133 16r80CC 16r3134 16r8D1D 16r3135 16r94A1 16r3136 16r500D 16r3137 16r72C8 16r3138 16r5907 16r3139 16r60EB 16r313A 16r7119 16r313B 16r88AB 16r313C 16r5954 16r313D 16r82EF 16r313E 16r672C 16r313F 16r7B28 16r3140 16r5D29 16r3141 16r7EF7 16r3142 16r752D 16r3143 16r6CF5 16r3144 16r8E66 16r3145 16r8FF8 16r3146 16r903C 16r3147 16r9F3B 16r3148 16r6BD4 16r3149 16r9119 16r314A 16r7B14 16r314B 16r5F7C 16r314C 16r78A7 16r314D 16r84D6 16r314E 16r853D 16r314F 16r6BD5 16r3150 16r6BD9 16r3151 16r6BD6 16r3152 16r5E01 16r3153 16r5E87 16r3154 16r75F9 16r3155 16r95ED 16r3156 16r655D 16r3157 16r5F0A 16r3158 16r5FC5 16r3159 16r8F9F 16r315A 16r58C1 16r315B 16r81C2 16r315C 16r907F 16r315D 16r965B 16r315E 16r97AD 16r315F 16r8FB9 16r3160 16r7F16 16r3161 16r8D2C 16r3162 16r6241 16r3163 16r4FBF 16r3164 16r53D8 16r3165 16r535E 16r3166 16r8FA8 16r3167 16r8FA9 16r3168 16r8FAB 16r3169 16r904D 16r316A 16r6807 16r316B 16r5F6A 16r316C 16r8198 16r316D 16r8868 16r316E 16r9CD6 16r316F 16r618B 16r3170 16r522B 16r3171 16r762A 16r3172 16r5F6C 16r3173 16r658C 16r3174 16r6FD2 16r3175 16r6EE8 16r3176 16r5BBE 16r3177 16r6448 16r3178 16r5175 16r3179 16r51B0 16r317A 16r67C4 16r317B 16r4E19 16r317C 16r79C9 16r317D 16r997C 16r317E 16r70B3 16r3221 16r75C5 16r3222 16r5E76 16r3223 16r73BB 16r3224 16r83E0 16r3225 16r64AD 16r3226 16r62E8 16r3227 16r94B5 16r3228 16r6CE2 16r3229 16r535A 16r322A 16r52C3 16r322B 16r640F 16r322C 16r94C2 16r322D 16r7B94 16r322E 16r4F2F 16r322F 16r5E1B 16r3230 16r8236 16r3231 16r8116 16r3232 16r818A 16r3233 16r6E24 16r3234 16r6CCA 16r3235 16r9A73 16r3236 16r6355 16r3237 16r535C 16r3238 16r54FA 16r3239 16r8865 16r323A 16r57E0 16r323B 16r4E0D 16r323C 16r5E03 16r323D 16r6B65 16r323E 16r7C3F 16r323F 16r90E8 16r3240 16r6016 16r3241 16r64E6 16r3242 16r731C 16r3243 16r88C1 16r3244 16r6750 16r3245 16r624D 16r3246 16r8D22 16r3247 16r776C 16r3248 16r8E29 16r3249 16r91C7 16r324A 16r5F69 16r324B 16r83DC 16r324C 16r8521 16r324D 16r9910 16r324E 16r53C2 16r324F 16r8695 16r3250 16r6B8B 16r3251 16r60ED 16r3252 16r60E8 16r3253 16r707F 16r3254 16r82CD 16r3255 16r8231 16r3256 16r4ED3 16r3257 16r6CA7 16r3258 16r85CF 16r3259 16r64CD 16r325A 16r7CD9 16r325B 16r69FD 16r325C 16r66F9 16r325D 16r8349 16r325E 16r5395 16r325F 16r7B56 16r3260 16r4FA7 16r3261 16r518C 16r3262 16r6D4B 16r3263 16r5C42 16r3264 16r8E6D 16r3265 16r63D2 16r3266 16r53C9 16r3267 16r832C 16r3268 16r8336 16r3269 16r67E5 16r326A 16r78B4 16r326B 16r643D 16r326C 16r5BDF 16r326D 16r5C94 16r326E 16r5DEE 16r326F 16r8BE7 16r3270 16r62C6 16r3271 16r67F4 16r3272 16r8C7A 16r3273 16r6400 16r3274 16r63BA 16r3275 16r8749 16r3276 16r998B 16r3277 16r8C17 16r3278 16r7F20 16r3279 16r94F2 16r327A 16r4EA7 16r327B 16r9610 16r327C 16r98A4 16r327D 16r660C 16r327E 16r7316 16r3321 16r573A 16r3322 16r5C1D 16r3323 16r5E38 16r3324 16r957F 16r3325 16r507F 16r3326 16r80A0 16r3327 16r5382 16r3328 16r655E 16r3329 16r7545 16r332A 16r5531 16r332B 16r5021 16r332C 16r8D85 16r332D 16r6284 16r332E 16r949E 16r332F 16r671D 16r3330 16r5632 16r3331 16r6F6E 16r3332 16r5DE2 16r3333 16r5435 16r3334 16r7092 16r3335 16r8F66 16r3336 16r626F 16r3337 16r64A4 16r3338 16r63A3 16r3339 16r5F7B 16r333A 16r6F88 16r333B 16r90F4 16r333C 16r81E3 16r333D 16r8FB0 16r333E 16r5C18 16r333F 16r6668 16r3340 16r5FF1 16r3341 16r6C89 16r3342 16r9648 16r3343 16r8D81 16r3344 16r886C 16r3345 16r6491 16r3346 16r79F0 16r3347 16r57CE 16r3348 16r6A59 16r3349 16r6210 16r334A 16r5448 16r334B 16r4E58 16r334C 16r7A0B 16r334D 16r60E9 16r334E 16r6F84 16r334F 16r8BDA 16r3350 16r627F 16r3351 16r901E 16r3352 16r9A8B 16r3353 16r79E4 16r3354 16r5403 16r3355 16r75F4 16r3356 16r6301 16r3357 16r5319 16r3358 16r6C60 16r3359 16r8FDF 16r335A 16r5F1B 16r335B 16r9A70 16r335C 16r803B 16r335D 16r9F7F 16r335E 16r4F88 16r335F 16r5C3A 16r3360 16r8D64 16r3361 16r7FC5 16r3362 16r65A5 16r3363 16r70BD 16r3364 16r5145 16r3365 16r51B2 16r3366 16r866B 16r3367 16r5D07 16r3368 16r5BA0 16r3369 16r62BD 16r336A 16r916C 16r336B 16r7574 16r336C 16r8E0C 16r336D 16r7A20 16r336E 16r6101 16r336F 16r7B79 16r3370 16r4EC7 16r3371 16r7EF8 16r3372 16r7785 16r3373 16r4E11 16r3374 16r81ED 16r3375 16r521D 16r3376 16r51FA 16r3377 16r6A71 16r3378 16r53A8 16r3379 16r8E87 16r337A 16r9504 16r337B 16r96CF 16r337C 16r6EC1 16r337D 16r9664 16r337E 16r695A 16r3421 16r7840 16r3422 16r50A8 16r3423 16r77D7 16r3424 16r6410 16r3425 16r89E6 16r3426 16r5904 16r3427 16r63E3 16r3428 16r5DDD 16r3429 16r7A7F 16r342A 16r693D 16r342B 16r4F20 16r342C 16r8239 16r342D 16r5598 16r342E 16r4E32 16r342F 16r75AE 16r3430 16r7A97 16r3431 16r5E62 16r3432 16r5E8A 16r3433 16r95EF 16r3434 16r521B 16r3435 16r5439 16r3436 16r708A 16r3437 16r6376 16r3438 16r9524 16r3439 16r5782 16r343A 16r6625 16r343B 16r693F 16r343C 16r9187 16r343D 16r5507 16r343E 16r6DF3 16r343F 16r7EAF 16r3440 16r8822 16r3441 16r6233 16r3442 16r7EF0 16r3443 16r75B5 16r3444 16r8328 16r3445 16r78C1 16r3446 16r96CC 16r3447 16r8F9E 16r3448 16r6148 16r3449 16r74F7 16r344A 16r8BCD 16r344B 16r6B64 16r344C 16r523A 16r344D 16r8D50 16r344E 16r6B21 16r344F 16r806A 16r3450 16r8471 16r3451 16r56F1 16r3452 16r5306 16r3453 16r4ECE 16r3454 16r4E1B 16r3455 16r51D1 16r3456 16r7C97 16r3457 16r918B 16r3458 16r7C07 16r3459 16r4FC3 16r345A 16r8E7F 16r345B 16r7BE1 16r345C 16r7A9C 16r345D 16r6467 16r345E 16r5D14 16r345F 16r50AC 16r3460 16r8106 16r3461 16r7601 16r3462 16r7CB9 16r3463 16r6DEC 16r3464 16r7FE0 16r3465 16r6751 16r3466 16r5B58 16r3467 16r5BF8 16r3468 16r78CB 16r3469 16r64AE 16r346A 16r6413 16r346B 16r63AA 16r346C 16r632B 16r346D 16r9519 16r346E 16r642D 16r346F 16r8FBE 16r3470 16r7B54 16r3471 16r7629 16r3472 16r6253 16r3473 16r5927 16r3474 16r5446 16r3475 16r6B79 16r3476 16r50A3 16r3477 16r6234 16r3478 16r5E26 16r3479 16r6B86 16r347A 16r4EE3 16r347B 16r8D37 16r347C 16r888B 16r347D 16r5F85 16r347E 16r902E 16r3521 16r6020 16r3522 16r803D 16r3523 16r62C5 16r3524 16r4E39 16r3525 16r5355 16r3526 16r90F8 16r3527 16r63B8 16r3528 16r80C6 16r3529 16r65E6 16r352A 16r6C2E 16r352B 16r4F46 16r352C 16r60EE 16r352D 16r6DE1 16r352E 16r8BDE 16r352F 16r5F39 16r3530 16r86CB 16r3531 16r5F53 16r3532 16r6321 16r3533 16r515A 16r3534 16r8361 16r3535 16r6863 16r3536 16r5200 16r3537 16r6363 16r3538 16r8E48 16r3539 16r5012 16r353A 16r5C9B 16r353B 16r7977 16r353C 16r5BFC 16r353D 16r5230 16r353E 16r7A3B 16r353F 16r60BC 16r3540 16r9053 16r3541 16r76D7 16r3542 16r5FB7 16r3543 16r5F97 16r3544 16r7684 16r3545 16r8E6C 16r3546 16r706F 16r3547 16r767B 16r3548 16r7B49 16r3549 16r77AA 16r354A 16r51F3 16r354B 16r9093 16r354C 16r5824 16r354D 16r4F4E 16r354E 16r6EF4 16r354F 16r8FEA 16r3550 16r654C 16r3551 16r7B1B 16r3552 16r72C4 16r3553 16r6DA4 16r3554 16r7FDF 16r3555 16r5AE1 16r3556 16r62B5 16r3557 16r5E95 16r3558 16r5730 16r3559 16r8482 16r355A 16r7B2C 16r355B 16r5E1D 16r355C 16r5F1F 16r355D 16r9012 16r355E 16r7F14 16r355F 16r98A0 16r3560 16r6382 16r3561 16r6EC7 16r3562 16r7898 16r3563 16r70B9 16r3564 16r5178 16r3565 16r975B 16r3566 16r57AB 16r3567 16r7535 16r3568 16r4F43 16r3569 16r7538 16r356A 16r5E97 16r356B 16r60E6 16r356C 16r5960 16r356D 16r6DC0 16r356E 16r6BBF 16r356F 16r7889 16r3570 16r53FC 16r3571 16r96D5 16r3572 16r51CB 16r3573 16r5201 16r3574 16r6389 16r3575 16r540A 16r3576 16r9493 16r3577 16r8C03 16r3578 16r8DCC 16r3579 16r7239 16r357A 16r789F 16r357B 16r8776 16r357C 16r8FED 16r357D 16r8C0D 16r357E 16r53E0 16r3621 16r4E01 16r3622 16r76EF 16r3623 16r53EE 16r3624 16r9489 16r3625 16r9876 16r3626 16r9F0E 16r3627 16r952D 16r3628 16r5B9A 16r3629 16r8BA2 16r362A 16r4E22 16r362B 16r4E1C 16r362C 16r51AC 16r362D 16r8463 16r362E 16r61C2 16r362F 16r52A8 16r3630 16r680B 16r3631 16r4F97 16r3632 16r606B 16r3633 16r51BB 16r3634 16r6D1E 16r3635 16r515C 16r3636 16r6296 16r3637 16r6597 16r3638 16r9661 16r3639 16r8C46 16r363A 16r9017 16r363B 16r75D8 16r363C 16r90FD 16r363D 16r7763 16r363E 16r6BD2 16r363F 16r728A 16r3640 16r72EC 16r3641 16r8BFB 16r3642 16r5835 16r3643 16r7779 16r3644 16r8D4C 16r3645 16r675C 16r3646 16r9540 16r3647 16r809A 16r3648 16r5EA6 16r3649 16r6E21 16r364A 16r5992 16r364B 16r7AEF 16r364C 16r77ED 16r364D 16r953B 16r364E 16r6BB5 16r364F 16r65AD 16r3650 16r7F0E 16r3651 16r5806 16r3652 16r5151 16r3653 16r961F 16r3654 16r5BF9 16r3655 16r58A9 16r3656 16r5428 16r3657 16r8E72 16r3658 16r6566 16r3659 16r987F 16r365A 16r56E4 16r365B 16r949D 16r365C 16r76FE 16r365D 16r9041 16r365E 16r6387 16r365F 16r54C6 16r3660 16r591A 16r3661 16r593A 16r3662 16r579B 16r3663 16r8EB2 16r3664 16r6735 16r3665 16r8DFA 16r3666 16r8235 16r3667 16r5241 16r3668 16r60F0 16r3669 16r5815 16r366A 16r86FE 16r366B 16r5CE8 16r366C 16r9E45 16r366D 16r4FC4 16r366E 16r989D 16r366F 16r8BB9 16r3670 16r5A25 16r3671 16r6076 16r3672 16r5384 16r3673 16r627C 16r3674 16r904F 16r3675 16r9102 16r3676 16r997F 16r3677 16r6069 16r3678 16r800C 16r3679 16r513F 16r367A 16r8033 16r367B 16r5C14 16r367C 16r9975 16r367D 16r6D31 16r367E 16r4E8C 16r3721 16r8D30 16r3722 16r53D1 16r3723 16r7F5A 16r3724 16r7B4F 16r3725 16r4F10 16r3726 16r4E4F 16r3727 16r9600 16r3728 16r6CD5 16r3729 16r73D0 16r372A 16r85E9 16r372B 16r5E06 16r372C 16r756A 16r372D 16r7FFB 16r372E 16r6A0A 16r372F 16r77FE 16r3730 16r9492 16r3731 16r7E41 16r3732 16r51E1 16r3733 16r70E6 16r3734 16r53CD 16r3735 16r8FD4 16r3736 16r8303 16r3737 16r8D29 16r3738 16r72AF 16r3739 16r996D 16r373A 16r6CDB 16r373B 16r574A 16r373C 16r82B3 16r373D 16r65B9 16r373E 16r80AA 16r373F 16r623F 16r3740 16r9632 16r3741 16r59A8 16r3742 16r4EFF 16r3743 16r8BBF 16r3744 16r7EBA 16r3745 16r653E 16r3746 16r83F2 16r3747 16r975E 16r3748 16r5561 16r3749 16r98DE 16r374A 16r80A5 16r374B 16r532A 16r374C 16r8BFD 16r374D 16r5420 16r374E 16r80BA 16r374F 16r5E9F 16r3750 16r6CB8 16r3751 16r8D39 16r3752 16r82AC 16r3753 16r915A 16r3754 16r5429 16r3755 16r6C1B 16r3756 16r5206 16r3757 16r7EB7 16r3758 16r575F 16r3759 16r711A 16r375A 16r6C7E 16r375B 16r7C89 16r375C 16r594B 16r375D 16r4EFD 16r375E 16r5FFF 16r375F 16r6124 16r3760 16r7CAA 16r3761 16r4E30 16r3762 16r5C01 16r3763 16r67AB 16r3764 16r8702 16r3765 16r5CF0 16r3766 16r950B 16r3767 16r98CE 16r3768 16r75AF 16r3769 16r70FD 16r376A 16r9022 16r376B 16r51AF 16r376C 16r7F1D 16r376D 16r8BBD 16r376E 16r5949 16r376F 16r51E4 16r3770 16r4F5B 16r3771 16r5426 16r3772 16r592B 16r3773 16r6577 16r3774 16r80A4 16r3775 16r5B75 16r3776 16r6276 16r3777 16r62C2 16r3778 16r8F90 16r3779 16r5E45 16r377A 16r6C1F 16r377B 16r7B26 16r377C 16r4F0F 16r377D 16r4FD8 16r377E 16r670D 16r3821 16r6D6E 16r3822 16r6DAA 16r3823 16r798F 16r3824 16r88B1 16r3825 16r5F17 16r3826 16r752B 16r3827 16r629A 16r3828 16r8F85 16r3829 16r4FEF 16r382A 16r91DC 16r382B 16r65A7 16r382C 16r812F 16r382D 16r8151 16r382E 16r5E9C 16r382F 16r8150 16r3830 16r8D74 16r3831 16r526F 16r3832 16r8986 16r3833 16r8D4B 16r3834 16r590D 16r3835 16r5085 16r3836 16r4ED8 16r3837 16r961C 16r3838 16r7236 16r3839 16r8179 16r383A 16r8D1F 16r383B 16r5BCC 16r383C 16r8BA3 16r383D 16r9644 16r383E 16r5987 16r383F 16r7F1A 16r3840 16r5490 16r3841 16r5676 16r3842 16r560E 16r3843 16r8BE5 16r3844 16r6539 16r3845 16r6982 16r3846 16r9499 16r3847 16r76D6 16r3848 16r6E89 16r3849 16r5E72 16r384A 16r7518 16r384B 16r6746 16r384C 16r67D1 16r384D 16r7AFF 16r384E 16r809D 16r384F 16r8D76 16r3850 16r611F 16r3851 16r79C6 16r3852 16r6562 16r3853 16r8D63 16r3854 16r5188 16r3855 16r521A 16r3856 16r94A2 16r3857 16r7F38 16r3858 16r809B 16r3859 16r7EB2 16r385A 16r5C97 16r385B 16r6E2F 16r385C 16r6760 16r385D 16r7BD9 16r385E 16r768B 16r385F 16r9AD8 16r3860 16r818F 16r3861 16r7F94 16r3862 16r7CD5 16r3863 16r641E 16r3864 16r9550 16r3865 16r7A3F 16r3866 16r544A 16r3867 16r54E5 16r3868 16r6B4C 16r3869 16r6401 16r386A 16r6208 16r386B 16r9E3D 16r386C 16r80F3 16r386D 16r7599 16r386E 16r5272 16r386F 16r9769 16r3870 16r845B 16r3871 16r683C 16r3872 16r86E4 16r3873 16r9601 16r3874 16r9694 16r3875 16r94EC 16r3876 16r4E2A 16r3877 16r5404 16r3878 16r7ED9 16r3879 16r6839 16r387A 16r8DDF 16r387B 16r8015 16r387C 16r66F4 16r387D 16r5E9A 16r387E 16r7FB9 16r3921 16r57C2 16r3922 16r803F 16r3923 16r6897 16r3924 16r5DE5 16r3925 16r653B 16r3926 16r529F 16r3927 16r606D 16r3928 16r9F9A 16r3929 16r4F9B 16r392A 16r8EAC 16r392B 16r516C 16r392C 16r5BAB 16r392D 16r5F13 16r392E 16r5DE9 16r392F 16r6C5E 16r3930 16r62F1 16r3931 16r8D21 16r3932 16r5171 16r3933 16r94A9 16r3934 16r52FE 16r3935 16r6C9F 16r3936 16r82DF 16r3937 16r72D7 16r3938 16r57A2 16r3939 16r6784 16r393A 16r8D2D 16r393B 16r591F 16r393C 16r8F9C 16r393D 16r83C7 16r393E 16r5495 16r393F 16r7B8D 16r3940 16r4F30 16r3941 16r6CBD 16r3942 16r5B64 16r3943 16r59D1 16r3944 16r9F13 16r3945 16r53E4 16r3946 16r86CA 16r3947 16r9AA8 16r3948 16r8C37 16r3949 16r80A1 16r394A 16r6545 16r394B 16r987E 16r394C 16r56FA 16r394D 16r96C7 16r394E 16r522E 16r394F 16r74DC 16r3950 16r5250 16r3951 16r5BE1 16r3952 16r6302 16r3953 16r8902 16r3954 16r4E56 16r3955 16r62D0 16r3956 16r602A 16r3957 16r68FA 16r3958 16r5173 16r3959 16r5B98 16r395A 16r51A0 16r395B 16r89C2 16r395C 16r7BA1 16r395D 16r9986 16r395E 16r7F50 16r395F 16r60EF 16r3960 16r704C 16r3961 16r8D2F 16r3962 16r5149 16r3963 16r5E7F 16r3964 16r901B 16r3965 16r7470 16r3966 16r89C4 16r3967 16r572D 16r3968 16r7845 16r3969 16r5F52 16r396A 16r9F9F 16r396B 16r95FA 16r396C 16r8F68 16r396D 16r9B3C 16r396E 16r8BE1 16r396F 16r7678 16r3970 16r6842 16r3971 16r67DC 16r3972 16r8DEA 16r3973 16r8D35 16r3974 16r523D 16r3975 16r8F8A 16r3976 16r6EDA 16r3977 16r68CD 16r3978 16r9505 16r3979 16r90ED 16r397A 16r56FD 16r397B 16r679C 16r397C 16r88F9 16r397D 16r8FC7 16r397E 16r54C8 16r3A21 16r9AB8 16r3A22 16r5B69 16r3A23 16r6D77 16r3A24 16r6C26 16r3A25 16r4EA5 16r3A26 16r5BB3 16r3A27 16r9A87 16r3A28 16r9163 16r3A29 16r61A8 16r3A2A 16r90AF 16r3A2B 16r97E9 16r3A2C 16r542B 16r3A2D 16r6DB5 16r3A2E 16r5BD2 16r3A2F 16r51FD 16r3A30 16r558A 16r3A31 16r7F55 16r3A32 16r7FF0 16r3A33 16r64BC 16r3A34 16r634D 16r3A35 16r65F1 16r3A36 16r61BE 16r3A37 16r608D 16r3A38 16r710A 16r3A39 16r6C57 16r3A3A 16r6C49 16r3A3B 16r592F 16r3A3C 16r676D 16r3A3D 16r822A 16r3A3E 16r58D5 16r3A3F 16r568E 16r3A40 16r8C6A 16r3A41 16r6BEB 16r3A42 16r90DD 16r3A43 16r597D 16r3A44 16r8017 16r3A45 16r53F7 16r3A46 16r6D69 16r3A47 16r5475 16r3A48 16r559D 16r3A49 16r8377 16r3A4A 16r83CF 16r3A4B 16r6838 16r3A4C 16r79BE 16r3A4D 16r548C 16r3A4E 16r4F55 16r3A4F 16r5408 16r3A50 16r76D2 16r3A51 16r8C89 16r3A52 16r9602 16r3A53 16r6CB3 16r3A54 16r6DB8 16r3A55 16r8D6B 16r3A56 16r8910 16r3A57 16r9E64 16r3A58 16r8D3A 16r3A59 16r563F 16r3A5A 16r9ED1 16r3A5B 16r75D5 16r3A5C 16r5F88 16r3A5D 16r72E0 16r3A5E 16r6068 16r3A5F 16r54FC 16r3A60 16r4EA8 16r3A61 16r6A2A 16r3A62 16r8861 16r3A63 16r6052 16r3A64 16r8F70 16r3A65 16r54C4 16r3A66 16r70D8 16r3A67 16r8679 16r3A68 16r9E3F 16r3A69 16r6D2A 16r3A6A 16r5B8F 16r3A6B 16r5F18 16r3A6C 16r7EA2 16r3A6D 16r5589 16r3A6E 16r4FAF 16r3A6F 16r7334 16r3A70 16r543C 16r3A71 16r539A 16r3A72 16r5019 16r3A73 16r540E 16r3A74 16r547C 16r3A75 16r4E4E 16r3A76 16r5FFD 16r3A77 16r745A 16r3A78 16r58F6 16r3A79 16r846B 16r3A7A 16r80E1 16r3A7B 16r8774 16r3A7C 16r72D0 16r3A7D 16r7CCA 16r3A7E 16r6E56 16r3B21 16r5F27 16r3B22 16r864E 16r3B23 16r552C 16r3B24 16r62A4 16r3B25 16r4E92 16r3B26 16r6CAA 16r3B27 16r6237 16r3B28 16r82B1 16r3B29 16r54D7 16r3B2A 16r534E 16r3B2B 16r733E 16r3B2C 16r6ED1 16r3B2D 16r753B 16r3B2E 16r5212 16r3B2F 16r5316 16r3B30 16r8BDD 16r3B31 16r69D0 16r3B32 16r5F8A 16r3B33 16r6000 16r3B34 16r6DEE 16r3B35 16r574F 16r3B36 16r6B22 16r3B37 16r73AF 16r3B38 16r6853 16r3B39 16r8FD8 16r3B3A 16r7F13 16r3B3B 16r6362 16r3B3C 16r60A3 16r3B3D 16r5524 16r3B3E 16r75EA 16r3B3F 16r8C62 16r3B40 16r7115 16r3B41 16r6DA3 16r3B42 16r5BA6 16r3B43 16r5E7B 16r3B44 16r8352 16r3B45 16r614C 16r3B46 16r9EC4 16r3B47 16r78FA 16r3B48 16r8757 16r3B49 16r7C27 16r3B4A 16r7687 16r3B4B 16r51F0 16r3B4C 16r60F6 16r3B4D 16r714C 16r3B4E 16r6643 16r3B4F 16r5E4C 16r3B50 16r604D 16r3B51 16r8C0E 16r3B52 16r7070 16r3B53 16r6325 16r3B54 16r8F89 16r3B55 16r5FBD 16r3B56 16r6062 16r3B57 16r86D4 16r3B58 16r56DE 16r3B59 16r6BC1 16r3B5A 16r6094 16r3B5B 16r6167 16r3B5C 16r5349 16r3B5D 16r60E0 16r3B5E 16r6666 16r3B5F 16r8D3F 16r3B60 16r79FD 16r3B61 16r4F1A 16r3B62 16r70E9 16r3B63 16r6C47 16r3B64 16r8BB3 16r3B65 16r8BF2 16r3B66 16r7ED8 16r3B67 16r8364 16r3B68 16r660F 16r3B69 16r5A5A 16r3B6A 16r9B42 16r3B6B 16r6D51 16r3B6C 16r6DF7 16r3B6D 16r8C41 16r3B6E 16r6D3B 16r3B6F 16r4F19 16r3B70 16r706B 16r3B71 16r83B7 16r3B72 16r6216 16r3B73 16r60D1 16r3B74 16r970D 16r3B75 16r8D27 16r3B76 16r7978 16r3B77 16r51FB 16r3B78 16r573E 16r3B79 16r57FA 16r3B7A 16r673A 16r3B7B 16r7578 16r3B7C 16r7A3D 16r3B7D 16r79EF 16r3B7E 16r7B95 16r3C21 16r808C 16r3C22 16r9965 16r3C23 16r8FF9 16r3C24 16r6FC0 16r3C25 16r8BA5 16r3C26 16r9E21 16r3C27 16r59EC 16r3C28 16r7EE9 16r3C29 16r7F09 16r3C2A 16r5409 16r3C2B 16r6781 16r3C2C 16r68D8 16r3C2D 16r8F91 16r3C2E 16r7C4D 16r3C2F 16r96C6 16r3C30 16r53CA 16r3C31 16r6025 16r3C32 16r75BE 16r3C33 16r6C72 16r3C34 16r5373 16r3C35 16r5AC9 16r3C36 16r7EA7 16r3C37 16r6324 16r3C38 16r51E0 16r3C39 16r810A 16r3C3A 16r5DF1 16r3C3B 16r84DF 16r3C3C 16r6280 16r3C3D 16r5180 16r3C3E 16r5B63 16r3C3F 16r4F0E 16r3C40 16r796D 16r3C41 16r5242 16r3C42 16r60B8 16r3C43 16r6D4E 16r3C44 16r5BC4 16r3C45 16r5BC2 16r3C46 16r8BA1 16r3C47 16r8BB0 16r3C48 16r65E2 16r3C49 16r5FCC 16r3C4A 16r9645 16r3C4B 16r5993 16r3C4C 16r7EE7 16r3C4D 16r7EAA 16r3C4E 16r5609 16r3C4F 16r67B7 16r3C50 16r5939 16r3C51 16r4F73 16r3C52 16r5BB6 16r3C53 16r52A0 16r3C54 16r835A 16r3C55 16r988A 16r3C56 16r8D3E 16r3C57 16r7532 16r3C58 16r94BE 16r3C59 16r5047 16r3C5A 16r7A3C 16r3C5B 16r4EF7 16r3C5C 16r67B6 16r3C5D 16r9A7E 16r3C5E 16r5AC1 16r3C5F 16r6B7C 16r3C60 16r76D1 16r3C61 16r575A 16r3C62 16r5C16 16r3C63 16r7B3A 16r3C64 16r95F4 16r3C65 16r714E 16r3C66 16r517C 16r3C67 16r80A9 16r3C68 16r8270 16r3C69 16r5978 16r3C6A 16r7F04 16r3C6B 16r8327 16r3C6C 16r68C0 16r3C6D 16r67EC 16r3C6E 16r78B1 16r3C6F 16r7877 16r3C70 16r62E3 16r3C71 16r6361 16r3C72 16r7B80 16r3C73 16r4FED 16r3C74 16r526A 16r3C75 16r51CF 16r3C76 16r8350 16r3C77 16r69DB 16r3C78 16r9274 16r3C79 16r8DF5 16r3C7A 16r8D31 16r3C7B 16r89C1 16r3C7C 16r952E 16r3C7D 16r7BAD 16r3C7E 16r4EF6 16r3D21 16r5065 16r3D22 16r8230 16r3D23 16r5251 16r3D24 16r996F 16r3D25 16r6E10 16r3D26 16r6E85 16r3D27 16r6DA7 16r3D28 16r5EFA 16r3D29 16r50F5 16r3D2A 16r59DC 16r3D2B 16r5C06 16r3D2C 16r6D46 16r3D2D 16r6C5F 16r3D2E 16r7586 16r3D2F 16r848B 16r3D30 16r6868 16r3D31 16r5956 16r3D32 16r8BB2 16r3D33 16r5320 16r3D34 16r9171 16r3D35 16r964D 16r3D36 16r8549 16r3D37 16r6912 16r3D38 16r7901 16r3D39 16r7126 16r3D3A 16r80F6 16r3D3B 16r4EA4 16r3D3C 16r90CA 16r3D3D 16r6D47 16r3D3E 16r9A84 16r3D3F 16r5A07 16r3D40 16r56BC 16r3D41 16r6405 16r3D42 16r94F0 16r3D43 16r77EB 16r3D44 16r4FA5 16r3D45 16r811A 16r3D46 16r72E1 16r3D47 16r89D2 16r3D48 16r997A 16r3D49 16r7F34 16r3D4A 16r7EDE 16r3D4B 16r527F 16r3D4C 16r6559 16r3D4D 16r9175 16r3D4E 16r8F7F 16r3D4F 16r8F83 16r3D50 16r53EB 16r3D51 16r7A96 16r3D52 16r63ED 16r3D53 16r63A5 16r3D54 16r7686 16r3D55 16r79F8 16r3D56 16r8857 16r3D57 16r9636 16r3D58 16r622A 16r3D59 16r52AB 16r3D5A 16r8282 16r3D5B 16r6854 16r3D5C 16r6770 16r3D5D 16r6377 16r3D5E 16r776B 16r3D5F 16r7AED 16r3D60 16r6D01 16r3D61 16r7ED3 16r3D62 16r89E3 16r3D63 16r59D0 16r3D64 16r6212 16r3D65 16r85C9 16r3D66 16r82A5 16r3D67 16r754C 16r3D68 16r501F 16r3D69 16r4ECB 16r3D6A 16r75A5 16r3D6B 16r8BEB 16r3D6C 16r5C4A 16r3D6D 16r5DFE 16r3D6E 16r7B4B 16r3D6F 16r65A4 16r3D70 16r91D1 16r3D71 16r4ECA 16r3D72 16r6D25 16r3D73 16r895F 16r3D74 16r7D27 16r3D75 16r9526 16r3D76 16r4EC5 16r3D77 16r8C28 16r3D78 16r8FDB 16r3D79 16r9773 16r3D7A 16r664B 16r3D7B 16r7981 16r3D7C 16r8FD1 16r3D7D 16r70EC 16r3D7E 16r6D78 16r3E21 16r5C3D 16r3E22 16r52B2 16r3E23 16r8346 16r3E24 16r5162 16r3E25 16r830E 16r3E26 16r775B 16r3E27 16r6676 16r3E28 16r9CB8 16r3E29 16r4EAC 16r3E2A 16r60CA 16r3E2B 16r7CBE 16r3E2C 16r7CB3 16r3E2D 16r7ECF 16r3E2E 16r4E95 16r3E2F 16r8B66 16r3E30 16r666F 16r3E31 16r9888 16r3E32 16r9759 16r3E33 16r5883 16r3E34 16r656C 16r3E35 16r955C 16r3E36 16r5F84 16r3E37 16r75C9 16r3E38 16r9756 16r3E39 16r7ADF 16r3E3A 16r7ADE 16r3E3B 16r51C0 16r3E3C 16r70AF 16r3E3D 16r7A98 16r3E3E 16r63EA 16r3E3F 16r7A76 16r3E40 16r7EA0 16r3E41 16r7396 16r3E42 16r97ED 16r3E43 16r4E45 16r3E44 16r7078 16r3E45 16r4E5D 16r3E46 16r9152 16r3E47 16r53A9 16r3E48 16r6551 16r3E49 16r65E7 16r3E4A 16r81FC 16r3E4B 16r8205 16r3E4C 16r548E 16r3E4D 16r5C31 16r3E4E 16r759A 16r3E4F 16r97A0 16r3E50 16r62D8 16r3E51 16r72D9 16r3E52 16r75BD 16r3E53 16r5C45 16r3E54 16r9A79 16r3E55 16r83CA 16r3E56 16r5C40 16r3E57 16r5480 16r3E58 16r77E9 16r3E59 16r4E3E 16r3E5A 16r6CAE 16r3E5B 16r805A 16r3E5C 16r62D2 16r3E5D 16r636E 16r3E5E 16r5DE8 16r3E5F 16r5177 16r3E60 16r8DDD 16r3E61 16r8E1E 16r3E62 16r952F 16r3E63 16r4FF1 16r3E64 16r53E5 16r3E65 16r60E7 16r3E66 16r70AC 16r3E67 16r5267 16r3E68 16r6350 16r3E69 16r9E43 16r3E6A 16r5A1F 16r3E6B 16r5026 16r3E6C 16r7737 16r3E6D 16r5377 16r3E6E 16r7EE2 16r3E6F 16r6485 16r3E70 16r652B 16r3E71 16r6289 16r3E72 16r6398 16r3E73 16r5014 16r3E74 16r7235 16r3E75 16r89C9 16r3E76 16r51B3 16r3E77 16r8BC0 16r3E78 16r7EDD 16r3E79 16r5747 16r3E7A 16r83CC 16r3E7B 16r94A7 16r3E7C 16r519B 16r3E7D 16r541B 16r3E7E 16r5CFB 16r3F21 16r4FCA 16r3F22 16r7AE3 16r3F23 16r6D5A 16r3F24 16r90E1 16r3F25 16r9A8F 16r3F26 16r5580 16r3F27 16r5496 16r3F28 16r5361 16r3F29 16r54AF 16r3F2A 16r5F00 16r3F2B 16r63E9 16r3F2C 16r6977 16r3F2D 16r51EF 16r3F2E 16r6168 16r3F2F 16r520A 16r3F30 16r582A 16r3F31 16r52D8 16r3F32 16r574E 16r3F33 16r780D 16r3F34 16r770B 16r3F35 16r5EB7 16r3F36 16r6177 16r3F37 16r7CE0 16r3F38 16r625B 16r3F39 16r6297 16r3F3A 16r4EA2 16r3F3B 16r7095 16r3F3C 16r8003 16r3F3D 16r62F7 16r3F3E 16r70E4 16r3F3F 16r9760 16r3F40 16r5777 16r3F41 16r82DB 16r3F42 16r67EF 16r3F43 16r68F5 16r3F44 16r78D5 16r3F45 16r9897 16r3F46 16r79D1 16r3F47 16r58F3 16r3F48 16r54B3 16r3F49 16r53EF 16r3F4A 16r6E34 16r3F4B 16r514B 16r3F4C 16r523B 16r3F4D 16r5BA2 16r3F4E 16r8BFE 16r3F4F 16r80AF 16r3F50 16r5543 16r3F51 16r57A6 16r3F52 16r6073 16r3F53 16r5751 16r3F54 16r542D 16r3F55 16r7A7A 16r3F56 16r6050 16r3F57 16r5B54 16r3F58 16r63A7 16r3F59 16r62A0 16r3F5A 16r53E3 16r3F5B 16r6263 16r3F5C 16r5BC7 16r3F5D 16r67AF 16r3F5E 16r54ED 16r3F5F 16r7A9F 16r3F60 16r82E6 16r3F61 16r9177 16r3F62 16r5E93 16r3F63 16r88E4 16r3F64 16r5938 16r3F65 16r57AE 16r3F66 16r630E 16r3F67 16r8DE8 16r3F68 16r80EF 16r3F69 16r5757 16r3F6A 16r7B77 16r3F6B 16r4FA9 16r3F6C 16r5FEB 16r3F6D 16r5BBD 16r3F6E 16r6B3E 16r3F6F 16r5321 16r3F70 16r7B50 16r3F71 16r72C2 16r3F72 16r6846 16r3F73 16r77FF 16r3F74 16r7736 16r3F75 16r65F7 16r3F76 16r51B5 16r3F77 16r4E8F 16r3F78 16r76D4 16r3F79 16r5CBF 16r3F7A 16r7AA5 16r3F7B 16r8475 16r3F7C 16r594E 16r3F7D 16r9B41 16r3F7E 16r5080 16r4021 16r9988 16r4022 16r6127 16r4023 16r6E83 16r4024 16r5764 16r4025 16r6606 16r4026 16r6346 16r4027 16r56F0 16r4028 16r62EC 16r4029 16r6269 16r402A 16r5ED3 16r402B 16r9614 16r402C 16r5783 16r402D 16r62C9 16r402E 16r5587 16r402F 16r8721 16r4030 16r814A 16r4031 16r8FA3 16r4032 16r5566 16r4033 16r83B1 16r4034 16r6765 16r4035 16r8D56 16r4036 16r84DD 16r4037 16r5A6A 16r4038 16r680F 16r4039 16r62E6 16r403A 16r7BEE 16r403B 16r9611 16r403C 16r5170 16r403D 16r6F9C 16r403E 16r8C30 16r403F 16r63FD 16r4040 16r89C8 16r4041 16r61D2 16r4042 16r7F06 16r4043 16r70C2 16r4044 16r6EE5 16r4045 16r7405 16r4046 16r6994 16r4047 16r72FC 16r4048 16r5ECA 16r4049 16r90CE 16r404A 16r6717 16r404B 16r6D6A 16r404C 16r635E 16r404D 16r52B3 16r404E 16r7262 16r404F 16r8001 16r4050 16r4F6C 16r4051 16r59E5 16r4052 16r916A 16r4053 16r70D9 16r4054 16r6D9D 16r4055 16r52D2 16r4056 16r4E50 16r4057 16r96F7 16r4058 16r956D 16r4059 16r857E 16r405A 16r78CA 16r405B 16r7D2F 16r405C 16r5121 16r405D 16r5792 16r405E 16r64C2 16r405F 16r808B 16r4060 16r7C7B 16r4061 16r6CEA 16r4062 16r68F1 16r4063 16r695E 16r4064 16r51B7 16r4065 16r5398 16r4066 16r68A8 16r4067 16r7281 16r4068 16r9ECE 16r4069 16r7BF1 16r406A 16r72F8 16r406B 16r79BB 16r406C 16r6F13 16r406D 16r7406 16r406E 16r674E 16r406F 16r91CC 16r4070 16r9CA4 16r4071 16r793C 16r4072 16r8389 16r4073 16r8354 16r4074 16r540F 16r4075 16r6817 16r4076 16r4E3D 16r4077 16r5389 16r4078 16r52B1 16r4079 16r783E 16r407A 16r5386 16r407B 16r5229 16r407C 16r5088 16r407D 16r4F8B 16r407E 16r4FD0 16r4121 16r75E2 16r4122 16r7ACB 16r4123 16r7C92 16r4124 16r6CA5 16r4125 16r96B6 16r4126 16r529B 16r4127 16r7483 16r4128 16r54E9 16r4129 16r4FE9 16r412A 16r8054 16r412B 16r83B2 16r412C 16r8FDE 16r412D 16r9570 16r412E 16r5EC9 16r412F 16r601C 16r4130 16r6D9F 16r4131 16r5E18 16r4132 16r655B 16r4133 16r8138 16r4134 16r94FE 16r4135 16r604B 16r4136 16r70BC 16r4137 16r7EC3 16r4138 16r7CAE 16r4139 16r51C9 16r413A 16r6881 16r413B 16r7CB1 16r413C 16r826F 16r413D 16r4E24 16r413E 16r8F86 16r413F 16r91CF 16r4140 16r667E 16r4141 16r4EAE 16r4142 16r8C05 16r4143 16r64A9 16r4144 16r804A 16r4145 16r50DA 16r4146 16r7597 16r4147 16r71CE 16r4148 16r5BE5 16r4149 16r8FBD 16r414A 16r6F66 16r414B 16r4E86 16r414C 16r6482 16r414D 16r9563 16r414E 16r5ED6 16r414F 16r6599 16r4150 16r5217 16r4151 16r88C2 16r4152 16r70C8 16r4153 16r52A3 16r4154 16r730E 16r4155 16r7433 16r4156 16r6797 16r4157 16r78F7 16r4158 16r9716 16r4159 16r4E34 16r415A 16r90BB 16r415B 16r9CDE 16r415C 16r6DCB 16r415D 16r51DB 16r415E 16r8D41 16r415F 16r541D 16r4160 16r62CE 16r4161 16r73B2 16r4162 16r83F1 16r4163 16r96F6 16r4164 16r9F84 16r4165 16r94C3 16r4166 16r4F36 16r4167 16r7F9A 16r4168 16r51CC 16r4169 16r7075 16r416A 16r9675 16r416B 16r5CAD 16r416C 16r9886 16r416D 16r53E6 16r416E 16r4EE4 16r416F 16r6E9C 16r4170 16r7409 16r4171 16r69B4 16r4172 16r786B 16r4173 16r998F 16r4174 16r7559 16r4175 16r5218 16r4176 16r7624 16r4177 16r6D41 16r4178 16r67F3 16r4179 16r516D 16r417A 16r9F99 16r417B 16r804B 16r417C 16r5499 16r417D 16r7B3C 16r417E 16r7ABF 16r4221 16r9686 16r4222 16r5784 16r4223 16r62E2 16r4224 16r9647 16r4225 16r697C 16r4226 16r5A04 16r4227 16r6402 16r4228 16r7BD3 16r4229 16r6F0F 16r422A 16r964B 16r422B 16r82A6 16r422C 16r5362 16r422D 16r9885 16r422E 16r5E90 16r422F 16r7089 16r4230 16r63B3 16r4231 16r5364 16r4232 16r864F 16r4233 16r9C81 16r4234 16r9E93 16r4235 16r788C 16r4236 16r9732 16r4237 16r8DEF 16r4238 16r8D42 16r4239 16r9E7F 16r423A 16r6F5E 16r423B 16r7984 16r423C 16r5F55 16r423D 16r9646 16r423E 16r622E 16r423F 16r9A74 16r4240 16r5415 16r4241 16r94DD 16r4242 16r4FA3 16r4243 16r65C5 16r4244 16r5C65 16r4245 16r5C61 16r4246 16r7F15 16r4247 16r8651 16r4248 16r6C2F 16r4249 16r5F8B 16r424A 16r7387 16r424B 16r6EE4 16r424C 16r7EFF 16r424D 16r5CE6 16r424E 16r631B 16r424F 16r5B6A 16r4250 16r6EE6 16r4251 16r5375 16r4252 16r4E71 16r4253 16r63A0 16r4254 16r7565 16r4255 16r62A1 16r4256 16r8F6E 16r4257 16r4F26 16r4258 16r4ED1 16r4259 16r6CA6 16r425A 16r7EB6 16r425B 16r8BBA 16r425C 16r841D 16r425D 16r87BA 16r425E 16r7F57 16r425F 16r903B 16r4260 16r9523 16r4261 16r7BA9 16r4262 16r9AA1 16r4263 16r88F8 16r4264 16r843D 16r4265 16r6D1B 16r4266 16r9A86 16r4267 16r7EDC 16r4268 16r5988 16r4269 16r9EBB 16r426A 16r739B 16r426B 16r7801 16r426C 16r8682 16r426D 16r9A6C 16r426E 16r9A82 16r426F 16r561B 16r4270 16r5417 16r4271 16r57CB 16r4272 16r4E70 16r4273 16r9EA6 16r4274 16r5356 16r4275 16r8FC8 16r4276 16r8109 16r4277 16r7792 16r4278 16r9992 16r4279 16r86EE 16r427A 16r6EE1 16r427B 16r8513 16r427C 16r66FC 16r427D 16r6162 16r427E 16r6F2B 16r4321 16r8C29 16r4322 16r8292 16r4323 16r832B 16r4324 16r76F2 16r4325 16r6C13 16r4326 16r5FD9 16r4327 16r83BD 16r4328 16r732B 16r4329 16r8305 16r432A 16r951A 16r432B 16r6BDB 16r432C 16r77DB 16r432D 16r94C6 16r432E 16r536F 16r432F 16r8302 16r4330 16r5192 16r4331 16r5E3D 16r4332 16r8C8C 16r4333 16r8D38 16r4334 16r4E48 16r4335 16r73AB 16r4336 16r679A 16r4337 16r6885 16r4338 16r9176 16r4339 16r9709 16r433A 16r7164 16r433B 16r6CA1 16r433C 16r7709 16r433D 16r5A92 16r433E 16r9541 16r433F 16r6BCF 16r4340 16r7F8E 16r4341 16r6627 16r4342 16r5BD0 16r4343 16r59B9 16r4344 16r5A9A 16r4345 16r95E8 16r4346 16r95F7 16r4347 16r4EEC 16r4348 16r840C 16r4349 16r8499 16r434A 16r6AAC 16r434B 16r76DF 16r434C 16r9530 16r434D 16r731B 16r434E 16r68A6 16r434F 16r5B5F 16r4350 16r772F 16r4351 16r919A 16r4352 16r9761 16r4353 16r7CDC 16r4354 16r8FF7 16r4355 16r8C1C 16r4356 16r5F25 16r4357 16r7C73 16r4358 16r79D8 16r4359 16r89C5 16r435A 16r6CCC 16r435B 16r871C 16r435C 16r5BC6 16r435D 16r5E42 16r435E 16r68C9 16r435F 16r7720 16r4360 16r7EF5 16r4361 16r5195 16r4362 16r514D 16r4363 16r52C9 16r4364 16r5A29 16r4365 16r7F05 16r4366 16r9762 16r4367 16r82D7 16r4368 16r63CF 16r4369 16r7784 16r436A 16r85D0 16r436B 16r79D2 16r436C 16r6E3A 16r436D 16r5E99 16r436E 16r5999 16r436F 16r8511 16r4370 16r706D 16r4371 16r6C11 16r4372 16r62BF 16r4373 16r76BF 16r4374 16r654F 16r4375 16r60AF 16r4376 16r95FD 16r4377 16r660E 16r4378 16r879F 16r4379 16r9E23 16r437A 16r94ED 16r437B 16r540D 16r437C 16r547D 16r437D 16r8C2C 16r437E 16r6478 16r4421 16r6479 16r4422 16r8611 16r4423 16r6A21 16r4424 16r819C 16r4425 16r78E8 16r4426 16r6469 16r4427 16r9B54 16r4428 16r62B9 16r4429 16r672B 16r442A 16r83AB 16r442B 16r58A8 16r442C 16r9ED8 16r442D 16r6CAB 16r442E 16r6F20 16r442F 16r5BDE 16r4430 16r964C 16r4431 16r8C0B 16r4432 16r725F 16r4433 16r67D0 16r4434 16r62C7 16r4435 16r7261 16r4436 16r4EA9 16r4437 16r59C6 16r4438 16r6BCD 16r4439 16r5893 16r443A 16r66AE 16r443B 16r5E55 16r443C 16r52DF 16r443D 16r6155 16r443E 16r6728 16r443F 16r76EE 16r4440 16r7766 16r4441 16r7267 16r4442 16r7A46 16r4443 16r62FF 16r4444 16r54EA 16r4445 16r5450 16r4446 16r94A0 16r4447 16r90A3 16r4448 16r5A1C 16r4449 16r7EB3 16r444A 16r6C16 16r444B 16r4E43 16r444C 16r5976 16r444D 16r8010 16r444E 16r5948 16r444F 16r5357 16r4450 16r7537 16r4451 16r96BE 16r4452 16r56CA 16r4453 16r6320 16r4454 16r8111 16r4455 16r607C 16r4456 16r95F9 16r4457 16r6DD6 16r4458 16r5462 16r4459 16r9981 16r445A 16r5185 16r445B 16r5AE9 16r445C 16r80FD 16r445D 16r59AE 16r445E 16r9713 16r445F 16r502A 16r4460 16r6CE5 16r4461 16r5C3C 16r4462 16r62DF 16r4463 16r4F60 16r4464 16r533F 16r4465 16r817B 16r4466 16r9006 16r4467 16r6EBA 16r4468 16r852B 16r4469 16r62C8 16r446A 16r5E74 16r446B 16r78BE 16r446C 16r64B5 16r446D 16r637B 16r446E 16r5FF5 16r446F 16r5A18 16r4470 16r917F 16r4471 16r9E1F 16r4472 16r5C3F 16r4473 16r634F 16r4474 16r8042 16r4475 16r5B7D 16r4476 16r556E 16r4477 16r954A 16r4478 16r954D 16r4479 16r6D85 16r447A 16r60A8 16r447B 16r67E0 16r447C 16r72DE 16r447D 16r51DD 16r447E 16r5B81 16r4521 16r62E7 16r4522 16r6CDE 16r4523 16r725B 16r4524 16r626D 16r4525 16r94AE 16r4526 16r7EBD 16r4527 16r8113 16r4528 16r6D53 16r4529 16r519C 16r452A 16r5F04 16r452B 16r5974 16r452C 16r52AA 16r452D 16r6012 16r452E 16r5973 16r452F 16r6696 16r4530 16r8650 16r4531 16r759F 16r4532 16r632A 16r4533 16r61E6 16r4534 16r7CEF 16r4535 16r8BFA 16r4536 16r54E6 16r4537 16r6B27 16r4538 16r9E25 16r4539 16r6BB4 16r453A 16r85D5 16r453B 16r5455 16r453C 16r5076 16r453D 16r6CA4 16r453E 16r556A 16r453F 16r8DB4 16r4540 16r722C 16r4541 16r5E15 16r4542 16r6015 16r4543 16r7436 16r4544 16r62CD 16r4545 16r6392 16r4546 16r724C 16r4547 16r5F98 16r4548 16r6E43 16r4549 16r6D3E 16r454A 16r6500 16r454B 16r6F58 16r454C 16r76D8 16r454D 16r78D0 16r454E 16r76FC 16r454F 16r7554 16r4550 16r5224 16r4551 16r53DB 16r4552 16r4E53 16r4553 16r5E9E 16r4554 16r65C1 16r4555 16r802A 16r4556 16r80D6 16r4557 16r629B 16r4558 16r5486 16r4559 16r5228 16r455A 16r70AE 16r455B 16r888D 16r455C 16r8DD1 16r455D 16r6CE1 16r455E 16r5478 16r455F 16r80DA 16r4560 16r57F9 16r4561 16r88F4 16r4562 16r8D54 16r4563 16r966A 16r4564 16r914D 16r4565 16r4F69 16r4566 16r6C9B 16r4567 16r55B7 16r4568 16r76C6 16r4569 16r7830 16r456A 16r62A8 16r456B 16r70F9 16r456C 16r6F8E 16r456D 16r5F6D 16r456E 16r84EC 16r456F 16r68DA 16r4570 16r787C 16r4571 16r7BF7 16r4572 16r81A8 16r4573 16r670B 16r4574 16r9E4F 16r4575 16r6367 16r4576 16r78B0 16r4577 16r576F 16r4578 16r7812 16r4579 16r9739 16r457A 16r6279 16r457B 16r62AB 16r457C 16r5288 16r457D 16r7435 16r457E 16r6BD7 16r4621 16r5564 16r4622 16r813E 16r4623 16r75B2 16r4624 16r76AE 16r4625 16r5339 16r4626 16r75DE 16r4627 16r50FB 16r4628 16r5C41 16r4629 16r8B6C 16r462A 16r7BC7 16r462B 16r504F 16r462C 16r7247 16r462D 16r9A97 16r462E 16r98D8 16r462F 16r6F02 16r4630 16r74E2 16r4631 16r7968 16r4632 16r6487 16r4633 16r77A5 16r4634 16r62FC 16r4635 16r9891 16r4636 16r8D2B 16r4637 16r54C1 16r4638 16r8058 16r4639 16r4E52 16r463A 16r576A 16r463B 16r82F9 16r463C 16r840D 16r463D 16r5E73 16r463E 16r51ED 16r463F 16r74F6 16r4640 16r8BC4 16r4641 16r5C4F 16r4642 16r5761 16r4643 16r6CFC 16r4644 16r9887 16r4645 16r5A46 16r4646 16r7834 16r4647 16r9B44 16r4648 16r8FEB 16r4649 16r7C95 16r464A 16r5256 16r464B 16r6251 16r464C 16r94FA 16r464D 16r4EC6 16r464E 16r8386 16r464F 16r8461 16r4650 16r83E9 16r4651 16r84B2 16r4652 16r57D4 16r4653 16r6734 16r4654 16r5703 16r4655 16r666E 16r4656 16r6D66 16r4657 16r8C31 16r4658 16r66DD 16r4659 16r7011 16r465A 16r671F 16r465B 16r6B3A 16r465C 16r6816 16r465D 16r621A 16r465E 16r59BB 16r465F 16r4E03 16r4660 16r51C4 16r4661 16r6F06 16r4662 16r67D2 16r4663 16r6C8F 16r4664 16r5176 16r4665 16r68CB 16r4666 16r5947 16r4667 16r6B67 16r4668 16r7566 16r4669 16r5D0E 16r466A 16r8110 16r466B 16r9F50 16r466C 16r65D7 16r466D 16r7948 16r466E 16r7941 16r466F 16r9A91 16r4670 16r8D77 16r4671 16r5C82 16r4672 16r4E5E 16r4673 16r4F01 16r4674 16r542F 16r4675 16r5951 16r4676 16r780C 16r4677 16r5668 16r4678 16r6C14 16r4679 16r8FC4 16r467A 16r5F03 16r467B 16r6C7D 16r467C 16r6CE3 16r467D 16r8BAB 16r467E 16r6390 16r4721 16r6070 16r4722 16r6D3D 16r4723 16r7275 16r4724 16r6266 16r4725 16r948E 16r4726 16r94C5 16r4727 16r5343 16r4728 16r8FC1 16r4729 16r7B7E 16r472A 16r4EDF 16r472B 16r8C26 16r472C 16r4E7E 16r472D 16r9ED4 16r472E 16r94B1 16r472F 16r94B3 16r4730 16r524D 16r4731 16r6F5C 16r4732 16r9063 16r4733 16r6D45 16r4734 16r8C34 16r4735 16r5811 16r4736 16r5D4C 16r4737 16r6B20 16r4738 16r6B49 16r4739 16r67AA 16r473A 16r545B 16r473B 16r8154 16r473C 16r7F8C 16r473D 16r5899 16r473E 16r8537 16r473F 16r5F3A 16r4740 16r62A2 16r4741 16r6A47 16r4742 16r9539 16r4743 16r6572 16r4744 16r6084 16r4745 16r6865 16r4746 16r77A7 16r4747 16r4E54 16r4748 16r4FA8 16r4749 16r5DE7 16r474A 16r9798 16r474B 16r64AC 16r474C 16r7FD8 16r474D 16r5CED 16r474E 16r4FCF 16r474F 16r7A8D 16r4750 16r5207 16r4751 16r8304 16r4752 16r4E14 16r4753 16r602F 16r4754 16r7A83 16r4755 16r94A6 16r4756 16r4FB5 16r4757 16r4EB2 16r4758 16r79E6 16r4759 16r7434 16r475A 16r52E4 16r475B 16r82B9 16r475C 16r64D2 16r475D 16r79BD 16r475E 16r5BDD 16r475F 16r6C81 16r4760 16r9752 16r4761 16r8F7B 16r4762 16r6C22 16r4763 16r503E 16r4764 16r537F 16r4765 16r6E05 16r4766 16r64CE 16r4767 16r6674 16r4768 16r6C30 16r4769 16r60C5 16r476A 16r9877 16r476B 16r8BF7 16r476C 16r5E86 16r476D 16r743C 16r476E 16r7A77 16r476F 16r79CB 16r4770 16r4E18 16r4771 16r90B1 16r4772 16r7403 16r4773 16r6C42 16r4774 16r56DA 16r4775 16r914B 16r4776 16r6CC5 16r4777 16r8D8B 16r4778 16r533A 16r4779 16r86C6 16r477A 16r66F2 16r477B 16r8EAF 16r477C 16r5C48 16r477D 16r9A71 16r477E 16r6E20 16r4821 16r53D6 16r4822 16r5A36 16r4823 16r9F8B 16r4824 16r8DA3 16r4825 16r53BB 16r4826 16r5708 16r4827 16r98A7 16r4828 16r6743 16r4829 16r919B 16r482A 16r6CC9 16r482B 16r5168 16r482C 16r75CA 16r482D 16r62F3 16r482E 16r72AC 16r482F 16r5238 16r4830 16r529D 16r4831 16r7F3A 16r4832 16r7094 16r4833 16r7638 16r4834 16r5374 16r4835 16r9E4A 16r4836 16r69B7 16r4837 16r786E 16r4838 16r96C0 16r4839 16r88D9 16r483A 16r7FA4 16r483B 16r7136 16r483C 16r71C3 16r483D 16r5189 16r483E 16r67D3 16r483F 16r74E4 16r4840 16r58E4 16r4841 16r6518 16r4842 16r56B7 16r4843 16r8BA9 16r4844 16r9976 16r4845 16r6270 16r4846 16r7ED5 16r4847 16r60F9 16r4848 16r70ED 16r4849 16r58EC 16r484A 16r4EC1 16r484B 16r4EBA 16r484C 16r5FCD 16r484D 16r97E7 16r484E 16r4EFB 16r484F 16r8BA4 16r4850 16r5203 16r4851 16r598A 16r4852 16r7EAB 16r4853 16r6254 16r4854 16r4ECD 16r4855 16r65E5 16r4856 16r620E 16r4857 16r8338 16r4858 16r84C9 16r4859 16r8363 16r485A 16r878D 16r485B 16r7194 16r485C 16r6EB6 16r485D 16r5BB9 16r485E 16r7ED2 16r485F 16r5197 16r4860 16r63C9 16r4861 16r67D4 16r4862 16r8089 16r4863 16r8339 16r4864 16r8815 16r4865 16r5112 16r4866 16r5B7A 16r4867 16r5982 16r4868 16r8FB1 16r4869 16r4E73 16r486A 16r6C5D 16r486B 16r5165 16r486C 16r8925 16r486D 16r8F6F 16r486E 16r962E 16r486F 16r854A 16r4870 16r745E 16r4871 16r9510 16r4872 16r95F0 16r4873 16r6DA6 16r4874 16r82E5 16r4875 16r5F31 16r4876 16r6492 16r4877 16r6D12 16r4878 16r8428 16r4879 16r816E 16r487A 16r9CC3 16r487B 16r585E 16r487C 16r8D5B 16r487D 16r4E09 16r487E 16r53C1 16r4921 16r4F1E 16r4922 16r6563 16r4923 16r6851 16r4924 16r55D3 16r4925 16r4E27 16r4926 16r6414 16r4927 16r9A9A 16r4928 16r626B 16r4929 16r5AC2 16r492A 16r745F 16r492B 16r8272 16r492C 16r6DA9 16r492D 16r68EE 16r492E 16r50E7 16r492F 16r838E 16r4930 16r7802 16r4931 16r6740 16r4932 16r5239 16r4933 16r6C99 16r4934 16r7EB1 16r4935 16r50BB 16r4936 16r5565 16r4937 16r715E 16r4938 16r7B5B 16r4939 16r6652 16r493A 16r73CA 16r493B 16r82EB 16r493C 16r6749 16r493D 16r5C71 16r493E 16r5220 16r493F 16r717D 16r4940 16r886B 16r4941 16r95EA 16r4942 16r9655 16r4943 16r64C5 16r4944 16r8D61 16r4945 16r81B3 16r4946 16r5584 16r4947 16r6C55 16r4948 16r6247 16r4949 16r7F2E 16r494A 16r5892 16r494B 16r4F24 16r494C 16r5546 16r494D 16r8D4F 16r494E 16r664C 16r494F 16r4E0A 16r4950 16r5C1A 16r4951 16r88F3 16r4952 16r68A2 16r4953 16r634E 16r4954 16r7A0D 16r4955 16r70E7 16r4956 16r828D 16r4957 16r52FA 16r4958 16r97F6 16r4959 16r5C11 16r495A 16r54E8 16r495B 16r90B5 16r495C 16r7ECD 16r495D 16r5962 16r495E 16r8D4A 16r495F 16r86C7 16r4960 16r820C 16r4961 16r820D 16r4962 16r8D66 16r4963 16r6444 16r4964 16r5C04 16r4965 16r6151 16r4966 16r6D89 16r4967 16r793E 16r4968 16r8BBE 16r4969 16r7837 16r496A 16r7533 16r496B 16r547B 16r496C 16r4F38 16r496D 16r8EAB 16r496E 16r6DF1 16r496F 16r5A20 16r4970 16r7EC5 16r4971 16r795E 16r4972 16r6C88 16r4973 16r5BA1 16r4974 16r5A76 16r4975 16r751A 16r4976 16r80BE 16r4977 16r614E 16r4978 16r6E17 16r4979 16r58F0 16r497A 16r751F 16r497B 16r7525 16r497C 16r7272 16r497D 16r5347 16r497E 16r7EF3 16r4A21 16r7701 16r4A22 16r76DB 16r4A23 16r5269 16r4A24 16r80DC 16r4A25 16r5723 16r4A26 16r5E08 16r4A27 16r5931 16r4A28 16r72EE 16r4A29 16r65BD 16r4A2A 16r6E7F 16r4A2B 16r8BD7 16r4A2C 16r5C38 16r4A2D 16r8671 16r4A2E 16r5341 16r4A2F 16r77F3 16r4A30 16r62FE 16r4A31 16r65F6 16r4A32 16r4EC0 16r4A33 16r98DF 16r4A34 16r8680 16r4A35 16r5B9E 16r4A36 16r8BC6 16r4A37 16r53F2 16r4A38 16r77E2 16r4A39 16r4F7F 16r4A3A 16r5C4E 16r4A3B 16r9A76 16r4A3C 16r59CB 16r4A3D 16r5F0F 16r4A3E 16r793A 16r4A3F 16r58EB 16r4A40 16r4E16 16r4A41 16r67FF 16r4A42 16r4E8B 16r4A43 16r62ED 16r4A44 16r8A93 16r4A45 16r901D 16r4A46 16r52BF 16r4A47 16r662F 16r4A48 16r55DC 16r4A49 16r566C 16r4A4A 16r9002 16r4A4B 16r4ED5 16r4A4C 16r4F8D 16r4A4D 16r91CA 16r4A4E 16r9970 16r4A4F 16r6C0F 16r4A50 16r5E02 16r4A51 16r6043 16r4A52 16r5BA4 16r4A53 16r89C6 16r4A54 16r8BD5 16r4A55 16r6536 16r4A56 16r624B 16r4A57 16r9996 16r4A58 16r5B88 16r4A59 16r5BFF 16r4A5A 16r6388 16r4A5B 16r552E 16r4A5C 16r53D7 16r4A5D 16r7626 16r4A5E 16r517D 16r4A5F 16r852C 16r4A60 16r67A2 16r4A61 16r68B3 16r4A62 16r6B8A 16r4A63 16r6292 16r4A64 16r8F93 16r4A65 16r53D4 16r4A66 16r8212 16r4A67 16r6DD1 16r4A68 16r758F 16r4A69 16r4E66 16r4A6A 16r8D4E 16r4A6B 16r5B70 16r4A6C 16r719F 16r4A6D 16r85AF 16r4A6E 16r6691 16r4A6F 16r66D9 16r4A70 16r7F72 16r4A71 16r8700 16r4A72 16r9ECD 16r4A73 16r9F20 16r4A74 16r5C5E 16r4A75 16r672F 16r4A76 16r8FF0 16r4A77 16r6811 16r4A78 16r675F 16r4A79 16r620D 16r4A7A 16r7AD6 16r4A7B 16r5885 16r4A7C 16r5EB6 16r4A7D 16r6570 16r4A7E 16r6F31 16r4B21 16r6055 16r4B22 16r5237 16r4B23 16r800D 16r4B24 16r6454 16r4B25 16r8870 16r4B26 16r7529 16r4B27 16r5E05 16r4B28 16r6813 16r4B29 16r62F4 16r4B2A 16r971C 16r4B2B 16r53CC 16r4B2C 16r723D 16r4B2D 16r8C01 16r4B2E 16r6C34 16r4B2F 16r7761 16r4B30 16r7A0E 16r4B31 16r542E 16r4B32 16r77AC 16r4B33 16r987A 16r4B34 16r821C 16r4B35 16r8BF4 16r4B36 16r7855 16r4B37 16r6714 16r4B38 16r70C1 16r4B39 16r65AF 16r4B3A 16r6495 16r4B3B 16r5636 16r4B3C 16r601D 16r4B3D 16r79C1 16r4B3E 16r53F8 16r4B3F 16r4E1D 16r4B40 16r6B7B 16r4B41 16r8086 16r4B42 16r5BFA 16r4B43 16r55E3 16r4B44 16r56DB 16r4B45 16r4F3A 16r4B46 16r4F3C 16r4B47 16r9972 16r4B48 16r5DF3 16r4B49 16r677E 16r4B4A 16r8038 16r4B4B 16r6002 16r4B4C 16r9882 16r4B4D 16r9001 16r4B4E 16r5B8B 16r4B4F 16r8BBC 16r4B50 16r8BF5 16r4B51 16r641C 16r4B52 16r8258 16r4B53 16r64DE 16r4B54 16r55FD 16r4B55 16r82CF 16r4B56 16r9165 16r4B57 16r4FD7 16r4B58 16r7D20 16r4B59 16r901F 16r4B5A 16r7C9F 16r4B5B 16r50F3 16r4B5C 16r5851 16r4B5D 16r6EAF 16r4B5E 16r5BBF 16r4B5F 16r8BC9 16r4B60 16r8083 16r4B61 16r9178 16r4B62 16r849C 16r4B63 16r7B97 16r4B64 16r867D 16r4B65 16r968B 16r4B66 16r968F 16r4B67 16r7EE5 16r4B68 16r9AD3 16r4B69 16r788E 16r4B6A 16r5C81 16r4B6B 16r7A57 16r4B6C 16r9042 16r4B6D 16r96A7 16r4B6E 16r795F 16r4B6F 16r5B59 16r4B70 16r635F 16r4B71 16r7B0B 16r4B72 16r84D1 16r4B73 16r68AD 16r4B74 16r5506 16r4B75 16r7F29 16r4B76 16r7410 16r4B77 16r7D22 16r4B78 16r9501 16r4B79 16r6240 16r4B7A 16r584C 16r4B7B 16r4ED6 16r4B7C 16r5B83 16r4B7D 16r5979 16r4B7E 16r5854 16r4C21 16r736D 16r4C22 16r631E 16r4C23 16r8E4B 16r4C24 16r8E0F 16r4C25 16r80CE 16r4C26 16r82D4 16r4C27 16r62AC 16r4C28 16r53F0 16r4C29 16r6CF0 16r4C2A 16r915E 16r4C2B 16r592A 16r4C2C 16r6001 16r4C2D 16r6C70 16r4C2E 16r574D 16r4C2F 16r644A 16r4C30 16r8D2A 16r4C31 16r762B 16r4C32 16r6EE9 16r4C33 16r575B 16r4C34 16r6A80 16r4C35 16r75F0 16r4C36 16r6F6D 16r4C37 16r8C2D 16r4C38 16r8C08 16r4C39 16r5766 16r4C3A 16r6BEF 16r4C3B 16r8892 16r4C3C 16r78B3 16r4C3D 16r63A2 16r4C3E 16r53F9 16r4C3F 16r70AD 16r4C40 16r6C64 16r4C41 16r5858 16r4C42 16r642A 16r4C43 16r5802 16r4C44 16r68E0 16r4C45 16r819B 16r4C46 16r5510 16r4C47 16r7CD6 16r4C48 16r5018 16r4C49 16r8EBA 16r4C4A 16r6DCC 16r4C4B 16r8D9F 16r4C4C 16r70EB 16r4C4D 16r638F 16r4C4E 16r6D9B 16r4C4F 16r6ED4 16r4C50 16r7EE6 16r4C51 16r8404 16r4C52 16r6843 16r4C53 16r9003 16r4C54 16r6DD8 16r4C55 16r9676 16r4C56 16r8BA8 16r4C57 16r5957 16r4C58 16r7279 16r4C59 16r85E4 16r4C5A 16r817E 16r4C5B 16r75BC 16r4C5C 16r8A8A 16r4C5D 16r68AF 16r4C5E 16r5254 16r4C5F 16r8E22 16r4C60 16r9511 16r4C61 16r63D0 16r4C62 16r9898 16r4C63 16r8E44 16r4C64 16r557C 16r4C65 16r4F53 16r4C66 16r66FF 16r4C67 16r568F 16r4C68 16r60D5 16r4C69 16r6D95 16r4C6A 16r5243 16r4C6B 16r5C49 16r4C6C 16r5929 16r4C6D 16r6DFB 16r4C6E 16r586B 16r4C6F 16r7530 16r4C70 16r751C 16r4C71 16r606C 16r4C72 16r8214 16r4C73 16r8146 16r4C74 16r6311 16r4C75 16r6761 16r4C76 16r8FE2 16r4C77 16r773A 16r4C78 16r8DF3 16r4C79 16r8D34 16r4C7A 16r94C1 16r4C7B 16r5E16 16r4C7C 16r5385 16r4C7D 16r542C 16r4C7E 16r70C3 16r4D21 16r6C40 16r4D22 16r5EF7 16r4D23 16r505C 16r4D24 16r4EAD 16r4D25 16r5EAD 16r4D26 16r633A 16r4D27 16r8247 16r4D28 16r901A 16r4D29 16r6850 16r4D2A 16r916E 16r4D2B 16r77B3 16r4D2C 16r540C 16r4D2D 16r94DC 16r4D2E 16r5F64 16r4D2F 16r7AE5 16r4D30 16r6876 16r4D31 16r6345 16r4D32 16r7B52 16r4D33 16r7EDF 16r4D34 16r75DB 16r4D35 16r5077 16r4D36 16r6295 16r4D37 16r5934 16r4D38 16r900F 16r4D39 16r51F8 16r4D3A 16r79C3 16r4D3B 16r7A81 16r4D3C 16r56FE 16r4D3D 16r5F92 16r4D3E 16r9014 16r4D3F 16r6D82 16r4D40 16r5C60 16r4D41 16r571F 16r4D42 16r5410 16r4D43 16r5154 16r4D44 16r6E4D 16r4D45 16r56E2 16r4D46 16r63A8 16r4D47 16r9893 16r4D48 16r817F 16r4D49 16r8715 16r4D4A 16r892A 16r4D4B 16r9000 16r4D4C 16r541E 16r4D4D 16r5C6F 16r4D4E 16r81C0 16r4D4F 16r62D6 16r4D50 16r6258 16r4D51 16r8131 16r4D52 16r9E35 16r4D53 16r9640 16r4D54 16r9A6E 16r4D55 16r9A7C 16r4D56 16r692D 16r4D57 16r59A5 16r4D58 16r62D3 16r4D59 16r553E 16r4D5A 16r6316 16r4D5B 16r54C7 16r4D5C 16r86D9 16r4D5D 16r6D3C 16r4D5E 16r5A03 16r4D5F 16r74E6 16r4D60 16r889C 16r4D61 16r6B6A 16r4D62 16r5916 16r4D63 16r8C4C 16r4D64 16r5F2F 16r4D65 16r6E7E 16r4D66 16r73A9 16r4D67 16r987D 16r4D68 16r4E38 16r4D69 16r70F7 16r4D6A 16r5B8C 16r4D6B 16r7897 16r4D6C 16r633D 16r4D6D 16r665A 16r4D6E 16r7696 16r4D6F 16r60CB 16r4D70 16r5B9B 16r4D71 16r5A49 16r4D72 16r4E07 16r4D73 16r8155 16r4D74 16r6C6A 16r4D75 16r738B 16r4D76 16r4EA1 16r4D77 16r6789 16r4D78 16r7F51 16r4D79 16r5F80 16r4D7A 16r65FA 16r4D7B 16r671B 16r4D7C 16r5FD8 16r4D7D 16r5984 16r4D7E 16r5A01 16r4E21 16r5DCD 16r4E22 16r5FAE 16r4E23 16r5371 16r4E24 16r97E6 16r4E25 16r8FDD 16r4E26 16r6845 16r4E27 16r56F4 16r4E28 16r552F 16r4E29 16r60DF 16r4E2A 16r4E3A 16r4E2B 16r6F4D 16r4E2C 16r7EF4 16r4E2D 16r82C7 16r4E2E 16r840E 16r4E2F 16r59D4 16r4E30 16r4F1F 16r4E31 16r4F2A 16r4E32 16r5C3E 16r4E33 16r7EAC 16r4E34 16r672A 16r4E35 16r851A 16r4E36 16r5473 16r4E37 16r754F 16r4E38 16r80C3 16r4E39 16r5582 16r4E3A 16r9B4F 16r4E3B 16r4F4D 16r4E3C 16r6E2D 16r4E3D 16r8C13 16r4E3E 16r5C09 16r4E3F 16r6170 16r4E40 16r536B 16r4E41 16r761F 16r4E42 16r6E29 16r4E43 16r868A 16r4E44 16r6587 16r4E45 16r95FB 16r4E46 16r7EB9 16r4E47 16r543B 16r4E48 16r7A33 16r4E49 16r7D0A 16r4E4A 16r95EE 16r4E4B 16r55E1 16r4E4C 16r7FC1 16r4E4D 16r74EE 16r4E4E 16r631D 16r4E4F 16r8717 16r4E50 16r6DA1 16r4E51 16r7A9D 16r4E52 16r6211 16r4E53 16r65A1 16r4E54 16r5367 16r4E55 16r63E1 16r4E56 16r6C83 16r4E57 16r5DEB 16r4E58 16r545C 16r4E59 16r94A8 16r4E5A 16r4E4C 16r4E5B 16r6C61 16r4E5C 16r8BEC 16r4E5D 16r5C4B 16r4E5E 16r65E0 16r4E5F 16r829C 16r4E60 16r68A7 16r4E61 16r543E 16r4E62 16r5434 16r4E63 16r6BCB 16r4E64 16r6B66 16r4E65 16r4E94 16r4E66 16r6342 16r4E67 16r5348 16r4E68 16r821E 16r4E69 16r4F0D 16r4E6A 16r4FAE 16r4E6B 16r575E 16r4E6C 16r620A 16r4E6D 16r96FE 16r4E6E 16r6664 16r4E6F 16r7269 16r4E70 16r52FF 16r4E71 16r52A1 16r4E72 16r609F 16r4E73 16r8BEF 16r4E74 16r6614 16r4E75 16r7199 16r4E76 16r6790 16r4E77 16r897F 16r4E78 16r7852 16r4E79 16r77FD 16r4E7A 16r6670 16r4E7B 16r563B 16r4E7C 16r5438 16r4E7D 16r9521 16r4E7E 16r727A 16r4F21 16r7A00 16r4F22 16r606F 16r4F23 16r5E0C 16r4F24 16r6089 16r4F25 16r819D 16r4F26 16r5915 16r4F27 16r60DC 16r4F28 16r7184 16r4F29 16r70EF 16r4F2A 16r6EAA 16r4F2B 16r6C50 16r4F2C 16r7280 16r4F2D 16r6A84 16r4F2E 16r88AD 16r4F2F 16r5E2D 16r4F30 16r4E60 16r4F31 16r5AB3 16r4F32 16r559C 16r4F33 16r94E3 16r4F34 16r6D17 16r4F35 16r7CFB 16r4F36 16r9699 16r4F37 16r620F 16r4F38 16r7EC6 16r4F39 16r778E 16r4F3A 16r867E 16r4F3B 16r5323 16r4F3C 16r971E 16r4F3D 16r8F96 16r4F3E 16r6687 16r4F3F 16r5CE1 16r4F40 16r4FA0 16r4F41 16r72ED 16r4F42 16r4E0B 16r4F43 16r53A6 16r4F44 16r590F 16r4F45 16r5413 16r4F46 16r6380 16r4F47 16r9528 16r4F48 16r5148 16r4F49 16r4ED9 16r4F4A 16r9C9C 16r4F4B 16r7EA4 16r4F4C 16r54B8 16r4F4D 16r8D24 16r4F4E 16r8854 16r4F4F 16r8237 16r4F50 16r95F2 16r4F51 16r6D8E 16r4F52 16r5F26 16r4F53 16r5ACC 16r4F54 16r663E 16r4F55 16r9669 16r4F56 16r73B0 16r4F57 16r732E 16r4F58 16r53BF 16r4F59 16r817A 16r4F5A 16r9985 16r4F5B 16r7FA1 16r4F5C 16r5BAA 16r4F5D 16r9677 16r4F5E 16r9650 16r4F5F 16r7EBF 16r4F60 16r76F8 16r4F61 16r53A2 16r4F62 16r9576 16r4F63 16r9999 16r4F64 16r7BB1 16r4F65 16r8944 16r4F66 16r6E58 16r4F67 16r4E61 16r4F68 16r7FD4 16r4F69 16r7965 16r4F6A 16r8BE6 16r4F6B 16r60F3 16r4F6C 16r54CD 16r4F6D 16r4EAB 16r4F6E 16r9879 16r4F6F 16r5DF7 16r4F70 16r6A61 16r4F71 16r50CF 16r4F72 16r5411 16r4F73 16r8C61 16r4F74 16r8427 16r4F75 16r785D 16r4F76 16r9704 16r4F77 16r524A 16r4F78 16r54EE 16r4F79 16r56A3 16r4F7A 16r9500 16r4F7B 16r6D88 16r4F7C 16r5BB5 16r4F7D 16r6DC6 16r4F7E 16r6653 16r5021 16r5C0F 16r5022 16r5B5D 16r5023 16r6821 16r5024 16r8096 16r5025 16r5578 16r5026 16r7B11 16r5027 16r6548 16r5028 16r6954 16r5029 16r4E9B 16r502A 16r6B47 16r502B 16r874E 16r502C 16r978B 16r502D 16r534F 16r502E 16r631F 16r502F 16r643A 16r5030 16r90AA 16r5031 16r659C 16r5032 16r80C1 16r5033 16r8C10 16r5034 16r5199 16r5035 16r68B0 16r5036 16r5378 16r5037 16r87F9 16r5038 16r61C8 16r5039 16r6CC4 16r503A 16r6CFB 16r503B 16r8C22 16r503C 16r5C51 16r503D 16r85AA 16r503E 16r82AF 16r503F 16r950C 16r5040 16r6B23 16r5041 16r8F9B 16r5042 16r65B0 16r5043 16r5FFB 16r5044 16r5FC3 16r5045 16r4FE1 16r5046 16r8845 16r5047 16r661F 16r5048 16r8165 16r5049 16r7329 16r504A 16r60FA 16r504B 16r5174 16r504C 16r5211 16r504D 16r578B 16r504E 16r5F62 16r504F 16r90A2 16r5050 16r884C 16r5051 16r9192 16r5052 16r5E78 16r5053 16r674F 16r5054 16r6027 16r5055 16r59D3 16r5056 16r5144 16r5057 16r51F6 16r5058 16r80F8 16r5059 16r5308 16r505A 16r6C79 16r505B 16r96C4 16r505C 16r718A 16r505D 16r4F11 16r505E 16r4FEE 16r505F 16r7F9E 16r5060 16r673D 16r5061 16r55C5 16r5062 16r9508 16r5063 16r79C0 16r5064 16r8896 16r5065 16r7EE3 16r5066 16r589F 16r5067 16r620C 16r5068 16r9700 16r5069 16r865A 16r506A 16r5618 16r506B 16r987B 16r506C 16r5F90 16r506D 16r8BB8 16r506E 16r84C4 16r506F 16r9157 16r5070 16r53D9 16r5071 16r65ED 16r5072 16r5E8F 16r5073 16r755C 16r5074 16r6064 16r5075 16r7D6E 16r5076 16r5A7F 16r5077 16r7EEA 16r5078 16r7EED 16r5079 16r8F69 16r507A 16r55A7 16r507B 16r5BA3 16r507C 16r60AC 16r507D 16r65CB 16r507E 16r7384 16r5121 16r9009 16r5122 16r7663 16r5123 16r7729 16r5124 16r7EDA 16r5125 16r9774 16r5126 16r859B 16r5127 16r5B66 16r5128 16r7A74 16r5129 16r96EA 16r512A 16r8840 16r512B 16r52CB 16r512C 16r718F 16r512D 16r5FAA 16r512E 16r65EC 16r512F 16r8BE2 16r5130 16r5BFB 16r5131 16r9A6F 16r5132 16r5DE1 16r5133 16r6B89 16r5134 16r6C5B 16r5135 16r8BAD 16r5136 16r8BAF 16r5137 16r900A 16r5138 16r8FC5 16r5139 16r538B 16r513A 16r62BC 16r513B 16r9E26 16r513C 16r9E2D 16r513D 16r5440 16r513E 16r4E2B 16r513F 16r82BD 16r5140 16r7259 16r5141 16r869C 16r5142 16r5D16 16r5143 16r8859 16r5144 16r6DAF 16r5145 16r96C5 16r5146 16r54D1 16r5147 16r4E9A 16r5148 16r8BB6 16r5149 16r7109 16r514A 16r54BD 16r514B 16r9609 16r514C 16r70DF 16r514D 16r6DF9 16r514E 16r76D0 16r514F 16r4E25 16r5150 16r7814 16r5151 16r8712 16r5152 16r5CA9 16r5153 16r5EF6 16r5154 16r8A00 16r5155 16r989C 16r5156 16r960E 16r5157 16r708E 16r5158 16r6CBF 16r5159 16r5944 16r515A 16r63A9 16r515B 16r773C 16r515C 16r884D 16r515D 16r6F14 16r515E 16r8273 16r515F 16r5830 16r5160 16r71D5 16r5161 16r538C 16r5162 16r781A 16r5163 16r96C1 16r5164 16r5501 16r5165 16r5F66 16r5166 16r7130 16r5167 16r5BB4 16r5168 16r8C1A 16r5169 16r9A8C 16r516A 16r6B83 16r516B 16r592E 16r516C 16r9E2F 16r516D 16r79E7 16r516E 16r6768 16r516F 16r626C 16r5170 16r4F6F 16r5171 16r75A1 16r5172 16r7F8A 16r5173 16r6D0B 16r5174 16r9633 16r5175 16r6C27 16r5176 16r4EF0 16r5177 16r75D2 16r5178 16r517B 16r5179 16r6837 16r517A 16r6F3E 16r517B 16r9080 16r517C 16r8170 16r517D 16r5996 16r517E 16r7476 16r5221 16r6447 16r5222 16r5C27 16r5223 16r9065 16r5224 16r7A91 16r5225 16r8C23 16r5226 16r59DA 16r5227 16r54AC 16r5228 16r8200 16r5229 16r836F 16r522A 16r8981 16r522B 16r8000 16r522C 16r6930 16r522D 16r564E 16r522E 16r8036 16r522F 16r7237 16r5230 16r91CE 16r5231 16r51B6 16r5232 16r4E5F 16r5233 16r9875 16r5234 16r6396 16r5235 16r4E1A 16r5236 16r53F6 16r5237 16r66F3 16r5238 16r814B 16r5239 16r591C 16r523A 16r6DB2 16r523B 16r4E00 16r523C 16r58F9 16r523D 16r533B 16r523E 16r63D6 16r523F 16r94F1 16r5240 16r4F9D 16r5241 16r4F0A 16r5242 16r8863 16r5243 16r9890 16r5244 16r5937 16r5245 16r9057 16r5246 16r79FB 16r5247 16r4EEA 16r5248 16r80F0 16r5249 16r7591 16r524A 16r6C82 16r524B 16r5B9C 16r524C 16r59E8 16r524D 16r5F5D 16r524E 16r6905 16r524F 16r8681 16r5250 16r501A 16r5251 16r5DF2 16r5252 16r4E59 16r5253 16r77E3 16r5254 16r4EE5 16r5255 16r827A 16r5256 16r6291 16r5257 16r6613 16r5258 16r9091 16r5259 16r5C79 16r525A 16r4EBF 16r525B 16r5F79 16r525C 16r81C6 16r525D 16r9038 16r525E 16r8084 16r525F 16r75AB 16r5260 16r4EA6 16r5261 16r88D4 16r5262 16r610F 16r5263 16r6BC5 16r5264 16r5FC6 16r5265 16r4E49 16r5266 16r76CA 16r5267 16r6EA2 16r5268 16r8BE3 16r5269 16r8BAE 16r526A 16r8C0A 16r526B 16r8BD1 16r526C 16r5F02 16r526D 16r7FFC 16r526E 16r7FCC 16r526F 16r7ECE 16r5270 16r8335 16r5271 16r836B 16r5272 16r56E0 16r5273 16r6BB7 16r5274 16r97F3 16r5275 16r9634 16r5276 16r59FB 16r5277 16r541F 16r5278 16r94F6 16r5279 16r6DEB 16r527A 16r5BC5 16r527B 16r996E 16r527C 16r5C39 16r527D 16r5F15 16r527E 16r9690 16r5321 16r5370 16r5322 16r82F1 16r5323 16r6A31 16r5324 16r5A74 16r5325 16r9E70 16r5326 16r5E94 16r5327 16r7F28 16r5328 16r83B9 16r5329 16r8424 16r532A 16r8425 16r532B 16r8367 16r532C 16r8747 16r532D 16r8FCE 16r532E 16r8D62 16r532F 16r76C8 16r5330 16r5F71 16r5331 16r9896 16r5332 16r786C 16r5333 16r6620 16r5334 16r54DF 16r5335 16r62E5 16r5336 16r4F63 16r5337 16r81C3 16r5338 16r75C8 16r5339 16r5EB8 16r533A 16r96CD 16r533B 16r8E0A 16r533C 16r86F9 16r533D 16r548F 16r533E 16r6CF3 16r533F 16r6D8C 16r5340 16r6C38 16r5341 16r607F 16r5342 16r52C7 16r5343 16r7528 16r5344 16r5E7D 16r5345 16r4F18 16r5346 16r60A0 16r5347 16r5FE7 16r5348 16r5C24 16r5349 16r7531 16r534A 16r90AE 16r534B 16r94C0 16r534C 16r72B9 16r534D 16r6CB9 16r534E 16r6E38 16r534F 16r9149 16r5350 16r6709 16r5351 16r53CB 16r5352 16r53F3 16r5353 16r4F51 16r5354 16r91C9 16r5355 16r8BF1 16r5356 16r53C8 16r5357 16r5E7C 16r5358 16r8FC2 16r5359 16r6DE4 16r535A 16r4E8E 16r535B 16r76C2 16r535C 16r6986 16r535D 16r865E 16r535E 16r611A 16r535F 16r8206 16r5360 16r4F59 16r5361 16r4FDE 16r5362 16r903E 16r5363 16r9C7C 16r5364 16r6109 16r5365 16r6E1D 16r5366 16r6E14 16r5367 16r9685 16r5368 16r4E88 16r5369 16r5A31 16r536A 16r96E8 16r536B 16r4E0E 16r536C 16r5C7F 16r536D 16r79B9 16r536E 16r5B87 16r536F 16r8BED 16r5370 16r7FBD 16r5371 16r7389 16r5372 16r57DF 16r5373 16r828B 16r5374 16r90C1 16r5375 16r5401 16r5376 16r9047 16r5377 16r55BB 16r5378 16r5CEA 16r5379 16r5FA1 16r537A 16r6108 16r537B 16r6B32 16r537C 16r72F1 16r537D 16r80B2 16r537E 16r8A89 16r5421 16r6D74 16r5422 16r5BD3 16r5423 16r88D5 16r5424 16r9884 16r5425 16r8C6B 16r5426 16r9A6D 16r5427 16r9E33 16r5428 16r6E0A 16r5429 16r51A4 16r542A 16r5143 16r542B 16r57A3 16r542C 16r8881 16r542D 16r539F 16r542E 16r63F4 16r542F 16r8F95 16r5430 16r56ED 16r5431 16r5458 16r5432 16r5706 16r5433 16r733F 16r5434 16r6E90 16r5435 16r7F18 16r5436 16r8FDC 16r5437 16r82D1 16r5438 16r613F 16r5439 16r6028 16r543A 16r9662 16r543B 16r66F0 16r543C 16r7EA6 16r543D 16r8D8A 16r543E 16r8DC3 16r543F 16r94A5 16r5440 16r5CB3 16r5441 16r7CA4 16r5442 16r6708 16r5443 16r60A6 16r5444 16r9605 16r5445 16r8018 16r5446 16r4E91 16r5447 16r90E7 16r5448 16r5300 16r5449 16r9668 16r544A 16r5141 16r544B 16r8FD0 16r544C 16r8574 16r544D 16r915D 16r544E 16r6655 16r544F 16r97F5 16r5450 16r5B55 16r5451 16r531D 16r5452 16r7838 16r5453 16r6742 16r5454 16r683D 16r5455 16r54C9 16r5456 16r707E 16r5457 16r5BB0 16r5458 16r8F7D 16r5459 16r518D 16r545A 16r5728 16r545B 16r54B1 16r545C 16r6512 16r545D 16r6682 16r545E 16r8D5E 16r545F 16r8D43 16r5460 16r810F 16r5461 16r846C 16r5462 16r906D 16r5463 16r7CDF 16r5464 16r51FF 16r5465 16r85FB 16r5466 16r67A3 16r5467 16r65E9 16r5468 16r6FA1 16r5469 16r86A4 16r546A 16r8E81 16r546B 16r566A 16r546C 16r9020 16r546D 16r7682 16r546E 16r7076 16r546F 16r71E5 16r5470 16r8D23 16r5471 16r62E9 16r5472 16r5219 16r5473 16r6CFD 16r5474 16r8D3C 16r5475 16r600E 16r5476 16r589E 16r5477 16r618E 16r5478 16r66FE 16r5479 16r8D60 16r547A 16r624E 16r547B 16r55B3 16r547C 16r6E23 16r547D 16r672D 16r547E 16r8F67 16r5521 16r94E1 16r5522 16r95F8 16r5523 16r7728 16r5524 16r6805 16r5525 16r69A8 16r5526 16r548B 16r5527 16r4E4D 16r5528 16r70B8 16r5529 16r8BC8 16r552A 16r6458 16r552B 16r658B 16r552C 16r5B85 16r552D 16r7A84 16r552E 16r503A 16r552F 16r5BE8 16r5530 16r77BB 16r5531 16r6BE1 16r5532 16r8A79 16r5533 16r7C98 16r5534 16r6CBE 16r5535 16r76CF 16r5536 16r65A9 16r5537 16r8F97 16r5538 16r5D2D 16r5539 16r5C55 16r553A 16r8638 16r553B 16r6808 16r553C 16r5360 16r553D 16r6218 16r553E 16r7AD9 16r553F 16r6E5B 16r5540 16r7EFD 16r5541 16r6A1F 16r5542 16r7AE0 16r5543 16r5F70 16r5544 16r6F33 16r5545 16r5F20 16r5546 16r638C 16r5547 16r6DA8 16r5548 16r6756 16r5549 16r4E08 16r554A 16r5E10 16r554B 16r8D26 16r554C 16r4ED7 16r554D 16r80C0 16r554E 16r7634 16r554F 16r969C 16r5550 16r62DB 16r5551 16r662D 16r5552 16r627E 16r5553 16r6CBC 16r5554 16r8D75 16r5555 16r7167 16r5556 16r7F69 16r5557 16r5146 16r5558 16r8087 16r5559 16r53EC 16r555A 16r906E 16r555B 16r6298 16r555C 16r54F2 16r555D 16r86F0 16r555E 16r8F99 16r555F 16r8005 16r5560 16r9517 16r5561 16r8517 16r5562 16r8FD9 16r5563 16r6D59 16r5564 16r73CD 16r5565 16r659F 16r5566 16r771F 16r5567 16r7504 16r5568 16r7827 16r5569 16r81FB 16r556A 16r8D1E 16r556B 16r9488 16r556C 16r4FA6 16r556D 16r6795 16r556E 16r75B9 16r556F 16r8BCA 16r5570 16r9707 16r5571 16r632F 16r5572 16r9547 16r5573 16r9635 16r5574 16r84B8 16r5575 16r6323 16r5576 16r7741 16r5577 16r5F81 16r5578 16r72F0 16r5579 16r4E89 16r557A 16r6014 16r557B 16r6574 16r557C 16r62EF 16r557D 16r6B63 16r557E 16r653F 16r5621 16r5E27 16r5622 16r75C7 16r5623 16r90D1 16r5624 16r8BC1 16r5625 16r829D 16r5626 16r679D 16r5627 16r652F 16r5628 16r5431 16r5629 16r8718 16r562A 16r77E5 16r562B 16r80A2 16r562C 16r8102 16r562D 16r6C41 16r562E 16r4E4B 16r562F 16r7EC7 16r5630 16r804C 16r5631 16r76F4 16r5632 16r690D 16r5633 16r6B96 16r5634 16r6267 16r5635 16r503C 16r5636 16r4F84 16r5637 16r5740 16r5638 16r6307 16r5639 16r6B62 16r563A 16r8DBE 16r563B 16r53EA 16r563C 16r65E8 16r563D 16r7EB8 16r563E 16r5FD7 16r563F 16r631A 16r5640 16r63B7 16r5641 16r81F3 16r5642 16r81F4 16r5643 16r7F6E 16r5644 16r5E1C 16r5645 16r5CD9 16r5646 16r5236 16r5647 16r667A 16r5648 16r79E9 16r5649 16r7A1A 16r564A 16r8D28 16r564B 16r7099 16r564C 16r75D4 16r564D 16r6EDE 16r564E 16r6CBB 16r564F 16r7A92 16r5650 16r4E2D 16r5651 16r76C5 16r5652 16r5FE0 16r5653 16r949F 16r5654 16r8877 16r5655 16r7EC8 16r5656 16r79CD 16r5657 16r80BF 16r5658 16r91CD 16r5659 16r4EF2 16r565A 16r4F17 16r565B 16r821F 16r565C 16r5468 16r565D 16r5DDE 16r565E 16r6D32 16r565F 16r8BCC 16r5660 16r7CA5 16r5661 16r8F74 16r5662 16r8098 16r5663 16r5E1A 16r5664 16r5492 16r5665 16r76B1 16r5666 16r5B99 16r5667 16r663C 16r5668 16r9AA4 16r5669 16r73E0 16r566A 16r682A 16r566B 16r86DB 16r566C 16r6731 16r566D 16r732A 16r566E 16r8BF8 16r566F 16r8BDB 16r5670 16r9010 16r5671 16r7AF9 16r5672 16r70DB 16r5673 16r716E 16r5674 16r62C4 16r5675 16r77A9 16r5676 16r5631 16r5677 16r4E3B 16r5678 16r8457 16r5679 16r67F1 16r567A 16r52A9 16r567B 16r86C0 16r567C 16r8D2E 16r567D 16r94F8 16r567E 16r7B51 16r5721 16r4F4F 16r5722 16r6CE8 16r5723 16r795D 16r5724 16r9A7B 16r5725 16r6293 16r5726 16r722A 16r5727 16r62FD 16r5728 16r4E13 16r5729 16r7816 16r572A 16r8F6C 16r572B 16r64B0 16r572C 16r8D5A 16r572D 16r7BC6 16r572E 16r6869 16r572F 16r5E84 16r5730 16r88C5 16r5731 16r5986 16r5732 16r649E 16r5733 16r58EE 16r5734 16r72B6 16r5735 16r690E 16r5736 16r9525 16r5737 16r8FFD 16r5738 16r8D58 16r5739 16r5760 16r573A 16r7F00 16r573B 16r8C06 16r573C 16r51C6 16r573D 16r6349 16r573E 16r62D9 16r573F 16r5353 16r5740 16r684C 16r5741 16r7422 16r5742 16r8301 16r5743 16r914C 16r5744 16r5544 16r5745 16r7740 16r5746 16r707C 16r5747 16r6D4A 16r5748 16r5179 16r5749 16r54A8 16r574A 16r8D44 16r574B 16r59FF 16r574C 16r6ECB 16r574D 16r6DC4 16r574E 16r5B5C 16r574F 16r7D2B 16r5750 16r4ED4 16r5751 16r7C7D 16r5752 16r6ED3 16r5753 16r5B50 16r5754 16r81EA 16r5755 16r6E0D 16r5756 16r5B57 16r5757 16r9B03 16r5758 16r68D5 16r5759 16r8E2A 16r575A 16r5B97 16r575B 16r7EFC 16r575C 16r603B 16r575D 16r7EB5 16r575E 16r90B9 16r575F 16r8D70 16r5760 16r594F 16r5761 16r63CD 16r5762 16r79DF 16r5763 16r8DB3 16r5764 16r5352 16r5765 16r65CF 16r5766 16r7956 16r5767 16r8BC5 16r5768 16r963B 16r5769 16r7EC4 16r576A 16r94BB 16r576B 16r7E82 16r576C 16r5634 16r576D 16r9189 16r576E 16r6700 16r576F 16r7F6A 16r5770 16r5C0A 16r5771 16r9075 16r5772 16r6628 16r5773 16r5DE6 16r5774 16r4F50 16r5775 16r67DE 16r5776 16r505A 16r5777 16r4F5C 16r5778 16r5750 16r5779 16r5EA7 16r5821 16r4E8D 16r5822 16r4E0C 16r5823 16r5140 16r5824 16r4E10 16r5825 16r5EFF 16r5826 16r5345 16r5827 16r4E15 16r5828 16r4E98 16r5829 16r4E1E 16r582A 16r9B32 16r582B 16r5B6C 16r582C 16r5669 16r582D 16r4E28 16r582E 16r79BA 16r582F 16r4E3F 16r5830 16r5315 16r5831 16r4E47 16r5832 16r592D 16r5833 16r723B 16r5834 16r536E 16r5835 16r6C10 16r5836 16r56DF 16r5837 16r80E4 16r5838 16r9997 16r5839 16r6BD3 16r583A 16r777E 16r583B 16r9F17 16r583C 16r4E36 16r583D 16r4E9F 16r583E 16r9F10 16r583F 16r4E5C 16r5840 16r4E69 16r5841 16r4E93 16r5842 16r8288 16r5843 16r5B5B 16r5844 16r556C 16r5845 16r560F 16r5846 16r4EC4 16r5847 16r538D 16r5848 16r539D 16r5849 16r53A3 16r584A 16r53A5 16r584B 16r53AE 16r584C 16r9765 16r584D 16r8D5D 16r584E 16r531A 16r584F 16r53F5 16r5850 16r5326 16r5851 16r532E 16r5852 16r533E 16r5853 16r8D5C 16r5854 16r5366 16r5855 16r5363 16r5856 16r5202 16r5857 16r5208 16r5858 16r520E 16r5859 16r522D 16r585A 16r5233 16r585B 16r523F 16r585C 16r5240 16r585D 16r524C 16r585E 16r525E 16r585F 16r5261 16r5860 16r525C 16r5861 16r84AF 16r5862 16r527D 16r5863 16r5282 16r5864 16r5281 16r5865 16r5290 16r5866 16r5293 16r5867 16r5182 16r5868 16r7F54 16r5869 16r4EBB 16r586A 16r4EC3 16r586B 16r4EC9 16r586C 16r4EC2 16r586D 16r4EE8 16r586E 16r4EE1 16r586F 16r4EEB 16r5870 16r4EDE 16r5871 16r4F1B 16r5872 16r4EF3 16r5873 16r4F22 16r5874 16r4F64 16r5875 16r4EF5 16r5876 16r4F25 16r5877 16r4F27 16r5878 16r4F09 16r5879 16r4F2B 16r587A 16r4F5E 16r587B 16r4F67 16r587C 16r6538 16r587D 16r4F5A 16r587E 16r4F5D 16r5921 16r4F5F 16r5922 16r4F57 16r5923 16r4F32 16r5924 16r4F3D 16r5925 16r4F76 16r5926 16r4F74 16r5927 16r4F91 16r5928 16r4F89 16r5929 16r4F83 16r592A 16r4F8F 16r592B 16r4F7E 16r592C 16r4F7B 16r592D 16r4FAA 16r592E 16r4F7C 16r592F 16r4FAC 16r5930 16r4F94 16r5931 16r4FE6 16r5932 16r4FE8 16r5933 16r4FEA 16r5934 16r4FC5 16r5935 16r4FDA 16r5936 16r4FE3 16r5937 16r4FDC 16r5938 16r4FD1 16r5939 16r4FDF 16r593A 16r4FF8 16r593B 16r5029 16r593C 16r504C 16r593D 16r4FF3 16r593E 16r502C 16r593F 16r500F 16r5940 16r502E 16r5941 16r502D 16r5942 16r4FFE 16r5943 16r501C 16r5944 16r500C 16r5945 16r5025 16r5946 16r5028 16r5947 16r507E 16r5948 16r5043 16r5949 16r5055 16r594A 16r5048 16r594B 16r504E 16r594C 16r506C 16r594D 16r507B 16r594E 16r50A5 16r594F 16r50A7 16r5950 16r50A9 16r5951 16r50BA 16r5952 16r50D6 16r5953 16r5106 16r5954 16r50ED 16r5955 16r50EC 16r5956 16r50E6 16r5957 16r50EE 16r5958 16r5107 16r5959 16r510B 16r595A 16r4EDD 16r595B 16r6C3D 16r595C 16r4F58 16r595D 16r4F65 16r595E 16r4FCE 16r595F 16r9FA0 16r5960 16r6C46 16r5961 16r7C74 16r5962 16r516E 16r5963 16r5DFD 16r5964 16r9EC9 16r5965 16r9998 16r5966 16r5181 16r5967 16r5914 16r5968 16r52F9 16r5969 16r530D 16r596A 16r8A07 16r596B 16r5310 16r596C 16r51EB 16r596D 16r5919 16r596E 16r5155 16r596F 16r4EA0 16r5970 16r5156 16r5971 16r4EB3 16r5972 16r886E 16r5973 16r88A4 16r5974 16r4EB5 16r5975 16r8114 16r5976 16r88D2 16r5977 16r7980 16r5978 16r5B34 16r5979 16r8803 16r597A 16r7FB8 16r597B 16r51AB 16r597C 16r51B1 16r597D 16r51BD 16r597E 16r51BC 16r5A21 16r51C7 16r5A22 16r5196 16r5A23 16r51A2 16r5A24 16r51A5 16r5A25 16r8BA0 16r5A26 16r8BA6 16r5A27 16r8BA7 16r5A28 16r8BAA 16r5A29 16r8BB4 16r5A2A 16r8BB5 16r5A2B 16r8BB7 16r5A2C 16r8BC2 16r5A2D 16r8BC3 16r5A2E 16r8BCB 16r5A2F 16r8BCF 16r5A30 16r8BCE 16r5A31 16r8BD2 16r5A32 16r8BD3 16r5A33 16r8BD4 16r5A34 16r8BD6 16r5A35 16r8BD8 16r5A36 16r8BD9 16r5A37 16r8BDC 16r5A38 16r8BDF 16r5A39 16r8BE0 16r5A3A 16r8BE4 16r5A3B 16r8BE8 16r5A3C 16r8BE9 16r5A3D 16r8BEE 16r5A3E 16r8BF0 16r5A3F 16r8BF3 16r5A40 16r8BF6 16r5A41 16r8BF9 16r5A42 16r8BFC 16r5A43 16r8BFF 16r5A44 16r8C00 16r5A45 16r8C02 16r5A46 16r8C04 16r5A47 16r8C07 16r5A48 16r8C0C 16r5A49 16r8C0F 16r5A4A 16r8C11 16r5A4B 16r8C12 16r5A4C 16r8C14 16r5A4D 16r8C15 16r5A4E 16r8C16 16r5A4F 16r8C19 16r5A50 16r8C1B 16r5A51 16r8C18 16r5A52 16r8C1D 16r5A53 16r8C1F 16r5A54 16r8C20 16r5A55 16r8C21 16r5A56 16r8C25 16r5A57 16r8C27 16r5A58 16r8C2A 16r5A59 16r8C2B 16r5A5A 16r8C2E 16r5A5B 16r8C2F 16r5A5C 16r8C32 16r5A5D 16r8C33 16r5A5E 16r8C35 16r5A5F 16r8C36 16r5A60 16r5369 16r5A61 16r537A 16r5A62 16r961D 16r5A63 16r9622 16r5A64 16r9621 16r5A65 16r9631 16r5A66 16r962A 16r5A67 16r963D 16r5A68 16r963C 16r5A69 16r9642 16r5A6A 16r9649 16r5A6B 16r9654 16r5A6C 16r965F 16r5A6D 16r9667 16r5A6E 16r966C 16r5A6F 16r9672 16r5A70 16r9674 16r5A71 16r9688 16r5A72 16r968D 16r5A73 16r9697 16r5A74 16r96B0 16r5A75 16r9097 16r5A76 16r909B 16r5A77 16r909D 16r5A78 16r9099 16r5A79 16r90AC 16r5A7A 16r90A1 16r5A7B 16r90B4 16r5A7C 16r90B3 16r5A7D 16r90B6 16r5A7E 16r90BA 16r5B21 16r90B8 16r5B22 16r90B0 16r5B23 16r90CF 16r5B24 16r90C5 16r5B25 16r90BE 16r5B26 16r90D0 16r5B27 16r90C4 16r5B28 16r90C7 16r5B29 16r90D3 16r5B2A 16r90E6 16r5B2B 16r90E2 16r5B2C 16r90DC 16r5B2D 16r90D7 16r5B2E 16r90DB 16r5B2F 16r90EB 16r5B30 16r90EF 16r5B31 16r90FE 16r5B32 16r9104 16r5B33 16r9122 16r5B34 16r911E 16r5B35 16r9123 16r5B36 16r9131 16r5B37 16r912F 16r5B38 16r9139 16r5B39 16r9143 16r5B3A 16r9146 16r5B3B 16r520D 16r5B3C 16r5942 16r5B3D 16r52A2 16r5B3E 16r52AC 16r5B3F 16r52AD 16r5B40 16r52BE 16r5B41 16r54FF 16r5B42 16r52D0 16r5B43 16r52D6 16r5B44 16r52F0 16r5B45 16r53DF 16r5B46 16r71EE 16r5B47 16r77CD 16r5B48 16r5EF4 16r5B49 16r51F5 16r5B4A 16r51FC 16r5B4B 16r9B2F 16r5B4C 16r53B6 16r5B4D 16r5F01 16r5B4E 16r755A 16r5B4F 16r5DEF 16r5B50 16r574C 16r5B51 16r57A9 16r5B52 16r57A1 16r5B53 16r587E 16r5B54 16r58BC 16r5B55 16r58C5 16r5B56 16r58D1 16r5B57 16r5729 16r5B58 16r572C 16r5B59 16r572A 16r5B5A 16r5733 16r5B5B 16r5739 16r5B5C 16r572E 16r5B5D 16r572F 16r5B5E 16r575C 16r5B5F 16r573B 16r5B60 16r5742 16r5B61 16r5769 16r5B62 16r5785 16r5B63 16r576B 16r5B64 16r5786 16r5B65 16r577C 16r5B66 16r577B 16r5B67 16r5768 16r5B68 16r576D 16r5B69 16r5776 16r5B6A 16r5773 16r5B6B 16r57AD 16r5B6C 16r57A4 16r5B6D 16r578C 16r5B6E 16r57B2 16r5B6F 16r57CF 16r5B70 16r57A7 16r5B71 16r57B4 16r5B72 16r5793 16r5B73 16r57A0 16r5B74 16r57D5 16r5B75 16r57D8 16r5B76 16r57DA 16r5B77 16r57D9 16r5B78 16r57D2 16r5B79 16r57B8 16r5B7A 16r57F4 16r5B7B 16r57EF 16r5B7C 16r57F8 16r5B7D 16r57E4 16r5B7E 16r57DD 16r5C21 16r580B 16r5C22 16r580D 16r5C23 16r57FD 16r5C24 16r57ED 16r5C25 16r5800 16r5C26 16r581E 16r5C27 16r5819 16r5C28 16r5844 16r5C29 16r5820 16r5C2A 16r5865 16r5C2B 16r586C 16r5C2C 16r5881 16r5C2D 16r5889 16r5C2E 16r589A 16r5C2F 16r5880 16r5C30 16r99A8 16r5C31 16r9F19 16r5C32 16r61FF 16r5C33 16r8279 16r5C34 16r827D 16r5C35 16r827F 16r5C36 16r828F 16r5C37 16r828A 16r5C38 16r82A8 16r5C39 16r8284 16r5C3A 16r828E 16r5C3B 16r8291 16r5C3C 16r8297 16r5C3D 16r8299 16r5C3E 16r82AB 16r5C3F 16r82B8 16r5C40 16r82BE 16r5C41 16r82B0 16r5C42 16r82C8 16r5C43 16r82CA 16r5C44 16r82E3 16r5C45 16r8298 16r5C46 16r82B7 16r5C47 16r82AE 16r5C48 16r82CB 16r5C49 16r82CC 16r5C4A 16r82C1 16r5C4B 16r82A9 16r5C4C 16r82B4 16r5C4D 16r82A1 16r5C4E 16r82AA 16r5C4F 16r829F 16r5C50 16r82C4 16r5C51 16r82CE 16r5C52 16r82A4 16r5C53 16r82E1 16r5C54 16r8309 16r5C55 16r82F7 16r5C56 16r82E4 16r5C57 16r830F 16r5C58 16r8307 16r5C59 16r82DC 16r5C5A 16r82F4 16r5C5B 16r82D2 16r5C5C 16r82D8 16r5C5D 16r830C 16r5C5E 16r82FB 16r5C5F 16r82D3 16r5C60 16r8311 16r5C61 16r831A 16r5C62 16r8306 16r5C63 16r8314 16r5C64 16r8315 16r5C65 16r82E0 16r5C66 16r82D5 16r5C67 16r831C 16r5C68 16r8351 16r5C69 16r835B 16r5C6A 16r835C 16r5C6B 16r8308 16r5C6C 16r8392 16r5C6D 16r833C 16r5C6E 16r8334 16r5C6F 16r8331 16r5C70 16r839B 16r5C71 16r835E 16r5C72 16r832F 16r5C73 16r834F 16r5C74 16r8347 16r5C75 16r8343 16r5C76 16r835F 16r5C77 16r8340 16r5C78 16r8317 16r5C79 16r8360 16r5C7A 16r832D 16r5C7B 16r833A 16r5C7C 16r8333 16r5C7D 16r8366 16r5C7E 16r8365 16r5D21 16r8368 16r5D22 16r831B 16r5D23 16r8369 16r5D24 16r836C 16r5D25 16r836A 16r5D26 16r836D 16r5D27 16r836E 16r5D28 16r83B0 16r5D29 16r8378 16r5D2A 16r83B3 16r5D2B 16r83B4 16r5D2C 16r83A0 16r5D2D 16r83AA 16r5D2E 16r8393 16r5D2F 16r839C 16r5D30 16r8385 16r5D31 16r837C 16r5D32 16r83B6 16r5D33 16r83A9 16r5D34 16r837D 16r5D35 16r83B8 16r5D36 16r837B 16r5D37 16r8398 16r5D38 16r839E 16r5D39 16r83A8 16r5D3A 16r83BA 16r5D3B 16r83BC 16r5D3C 16r83C1 16r5D3D 16r8401 16r5D3E 16r83E5 16r5D3F 16r83D8 16r5D40 16r5807 16r5D41 16r8418 16r5D42 16r840B 16r5D43 16r83DD 16r5D44 16r83FD 16r5D45 16r83D6 16r5D46 16r841C 16r5D47 16r8438 16r5D48 16r8411 16r5D49 16r8406 16r5D4A 16r83D4 16r5D4B 16r83DF 16r5D4C 16r840F 16r5D4D 16r8403 16r5D4E 16r83F8 16r5D4F 16r83F9 16r5D50 16r83EA 16r5D51 16r83C5 16r5D52 16r83C0 16r5D53 16r8426 16r5D54 16r83F0 16r5D55 16r83E1 16r5D56 16r845C 16r5D57 16r8451 16r5D58 16r845A 16r5D59 16r8459 16r5D5A 16r8473 16r5D5B 16r8487 16r5D5C 16r8488 16r5D5D 16r847A 16r5D5E 16r8489 16r5D5F 16r8478 16r5D60 16r843C 16r5D61 16r8446 16r5D62 16r8469 16r5D63 16r8476 16r5D64 16r848C 16r5D65 16r848E 16r5D66 16r8431 16r5D67 16r846D 16r5D68 16r84C1 16r5D69 16r84CD 16r5D6A 16r84D0 16r5D6B 16r84E6 16r5D6C 16r84BD 16r5D6D 16r84D3 16r5D6E 16r84CA 16r5D6F 16r84BF 16r5D70 16r84BA 16r5D71 16r84E0 16r5D72 16r84A1 16r5D73 16r84B9 16r5D74 16r84B4 16r5D75 16r8497 16r5D76 16r84E5 16r5D77 16r84E3 16r5D78 16r850C 16r5D79 16r750D 16r5D7A 16r8538 16r5D7B 16r84F0 16r5D7C 16r8539 16r5D7D 16r851F 16r5D7E 16r853A 16r5E21 16r8556 16r5E22 16r853B 16r5E23 16r84FF 16r5E24 16r84FC 16r5E25 16r8559 16r5E26 16r8548 16r5E27 16r8568 16r5E28 16r8564 16r5E29 16r855E 16r5E2A 16r857A 16r5E2B 16r77A2 16r5E2C 16r8543 16r5E2D 16r8572 16r5E2E 16r857B 16r5E2F 16r85A4 16r5E30 16r85A8 16r5E31 16r8587 16r5E32 16r858F 16r5E33 16r8579 16r5E34 16r85AE 16r5E35 16r859C 16r5E36 16r8585 16r5E37 16r85B9 16r5E38 16r85B7 16r5E39 16r85B0 16r5E3A 16r85D3 16r5E3B 16r85C1 16r5E3C 16r85DC 16r5E3D 16r85FF 16r5E3E 16r8627 16r5E3F 16r8605 16r5E40 16r8629 16r5E41 16r8616 16r5E42 16r863C 16r5E43 16r5EFE 16r5E44 16r5F08 16r5E45 16r593C 16r5E46 16r5941 16r5E47 16r8037 16r5E48 16r5955 16r5E49 16r595A 16r5E4A 16r5958 16r5E4B 16r530F 16r5E4C 16r5C22 16r5E4D 16r5C25 16r5E4E 16r5C2C 16r5E4F 16r5C34 16r5E50 16r624C 16r5E51 16r626A 16r5E52 16r629F 16r5E53 16r62BB 16r5E54 16r62CA 16r5E55 16r62DA 16r5E56 16r62D7 16r5E57 16r62EE 16r5E58 16r6322 16r5E59 16r62F6 16r5E5A 16r6339 16r5E5B 16r634B 16r5E5C 16r6343 16r5E5D 16r63AD 16r5E5E 16r63F6 16r5E5F 16r6371 16r5E60 16r637A 16r5E61 16r638E 16r5E62 16r63B4 16r5E63 16r636D 16r5E64 16r63AC 16r5E65 16r638A 16r5E66 16r6369 16r5E67 16r63AE 16r5E68 16r63BC 16r5E69 16r63F2 16r5E6A 16r63F8 16r5E6B 16r63E0 16r5E6C 16r63FF 16r5E6D 16r63C4 16r5E6E 16r63DE 16r5E6F 16r63CE 16r5E70 16r6452 16r5E71 16r63C6 16r5E72 16r63BE 16r5E73 16r6445 16r5E74 16r6441 16r5E75 16r640B 16r5E76 16r641B 16r5E77 16r6420 16r5E78 16r640C 16r5E79 16r6426 16r5E7A 16r6421 16r5E7B 16r645E 16r5E7C 16r6484 16r5E7D 16r646D 16r5E7E 16r6496 16r5F21 16r647A 16r5F22 16r64B7 16r5F23 16r64B8 16r5F24 16r6499 16r5F25 16r64BA 16r5F26 16r64C0 16r5F27 16r64D0 16r5F28 16r64D7 16r5F29 16r64E4 16r5F2A 16r64E2 16r5F2B 16r6509 16r5F2C 16r6525 16r5F2D 16r652E 16r5F2E 16r5F0B 16r5F2F 16r5FD2 16r5F30 16r7519 16r5F31 16r5F11 16r5F32 16r535F 16r5F33 16r53F1 16r5F34 16r53FD 16r5F35 16r53E9 16r5F36 16r53E8 16r5F37 16r53FB 16r5F38 16r5412 16r5F39 16r5416 16r5F3A 16r5406 16r5F3B 16r544B 16r5F3C 16r5452 16r5F3D 16r5453 16r5F3E 16r5454 16r5F3F 16r5456 16r5F40 16r5443 16r5F41 16r5421 16r5F42 16r5457 16r5F43 16r5459 16r5F44 16r5423 16r5F45 16r5432 16r5F46 16r5482 16r5F47 16r5494 16r5F48 16r5477 16r5F49 16r5471 16r5F4A 16r5464 16r5F4B 16r549A 16r5F4C 16r549B 16r5F4D 16r5484 16r5F4E 16r5476 16r5F4F 16r5466 16r5F50 16r549D 16r5F51 16r54D0 16r5F52 16r54AD 16r5F53 16r54C2 16r5F54 16r54B4 16r5F55 16r54D2 16r5F56 16r54A7 16r5F57 16r54A6 16r5F58 16r54D3 16r5F59 16r54D4 16r5F5A 16r5472 16r5F5B 16r54A3 16r5F5C 16r54D5 16r5F5D 16r54BB 16r5F5E 16r54BF 16r5F5F 16r54CC 16r5F60 16r54D9 16r5F61 16r54DA 16r5F62 16r54DC 16r5F63 16r54A9 16r5F64 16r54AA 16r5F65 16r54A4 16r5F66 16r54DD 16r5F67 16r54CF 16r5F68 16r54DE 16r5F69 16r551B 16r5F6A 16r54E7 16r5F6B 16r5520 16r5F6C 16r54FD 16r5F6D 16r5514 16r5F6E 16r54F3 16r5F6F 16r5522 16r5F70 16r5523 16r5F71 16r550F 16r5F72 16r5511 16r5F73 16r5527 16r5F74 16r552A 16r5F75 16r5567 16r5F76 16r558F 16r5F77 16r55B5 16r5F78 16r5549 16r5F79 16r556D 16r5F7A 16r5541 16r5F7B 16r5555 16r5F7C 16r553F 16r5F7D 16r5550 16r5F7E 16r553C 16r6021 16r5537 16r6022 16r5556 16r6023 16r5575 16r6024 16r5576 16r6025 16r5577 16r6026 16r5533 16r6027 16r5530 16r6028 16r555C 16r6029 16r558B 16r602A 16r55D2 16r602B 16r5583 16r602C 16r55B1 16r602D 16r55B9 16r602E 16r5588 16r602F 16r5581 16r6030 16r559F 16r6031 16r557E 16r6032 16r55D6 16r6033 16r5591 16r6034 16r557B 16r6035 16r55DF 16r6036 16r55BD 16r6037 16r55BE 16r6038 16r5594 16r6039 16r5599 16r603A 16r55EA 16r603B 16r55F7 16r603C 16r55C9 16r603D 16r561F 16r603E 16r55D1 16r603F 16r55EB 16r6040 16r55EC 16r6041 16r55D4 16r6042 16r55E6 16r6043 16r55DD 16r6044 16r55C4 16r6045 16r55EF 16r6046 16r55E5 16r6047 16r55F2 16r6048 16r55F3 16r6049 16r55CC 16r604A 16r55CD 16r604B 16r55E8 16r604C 16r55F5 16r604D 16r55E4 16r604E 16r8F94 16r604F 16r561E 16r6050 16r5608 16r6051 16r560C 16r6052 16r5601 16r6053 16r5624 16r6054 16r5623 16r6055 16r55FE 16r6056 16r5600 16r6057 16r5627 16r6058 16r562D 16r6059 16r5658 16r605A 16r5639 16r605B 16r5657 16r605C 16r562C 16r605D 16r564D 16r605E 16r5662 16r605F 16r5659 16r6060 16r565C 16r6061 16r564C 16r6062 16r5654 16r6063 16r5686 16r6064 16r5664 16r6065 16r5671 16r6066 16r566B 16r6067 16r567B 16r6068 16r567C 16r6069 16r5685 16r606A 16r5693 16r606B 16r56AF 16r606C 16r56D4 16r606D 16r56D7 16r606E 16r56DD 16r606F 16r56E1 16r6070 16r56F5 16r6071 16r56EB 16r6072 16r56F9 16r6073 16r56FF 16r6074 16r5704 16r6075 16r570A 16r6076 16r5709 16r6077 16r571C 16r6078 16r5E0F 16r6079 16r5E19 16r607A 16r5E14 16r607B 16r5E11 16r607C 16r5E31 16r607D 16r5E3B 16r607E 16r5E3C 16r6121 16r5E37 16r6122 16r5E44 16r6123 16r5E54 16r6124 16r5E5B 16r6125 16r5E5E 16r6126 16r5E61 16r6127 16r5C8C 16r6128 16r5C7A 16r6129 16r5C8D 16r612A 16r5C90 16r612B 16r5C96 16r612C 16r5C88 16r612D 16r5C98 16r612E 16r5C99 16r612F 16r5C91 16r6130 16r5C9A 16r6131 16r5C9C 16r6132 16r5CB5 16r6133 16r5CA2 16r6134 16r5CBD 16r6135 16r5CAC 16r6136 16r5CAB 16r6137 16r5CB1 16r6138 16r5CA3 16r6139 16r5CC1 16r613A 16r5CB7 16r613B 16r5CC4 16r613C 16r5CD2 16r613D 16r5CE4 16r613E 16r5CCB 16r613F 16r5CE5 16r6140 16r5D02 16r6141 16r5D03 16r6142 16r5D27 16r6143 16r5D26 16r6144 16r5D2E 16r6145 16r5D24 16r6146 16r5D1E 16r6147 16r5D06 16r6148 16r5D1B 16r6149 16r5D58 16r614A 16r5D3E 16r614B 16r5D34 16r614C 16r5D3D 16r614D 16r5D6C 16r614E 16r5D5B 16r614F 16r5D6F 16r6150 16r5D5D 16r6151 16r5D6B 16r6152 16r5D4B 16r6153 16r5D4A 16r6154 16r5D69 16r6155 16r5D74 16r6156 16r5D82 16r6157 16r5D99 16r6158 16r5D9D 16r6159 16r8C73 16r615A 16r5DB7 16r615B 16r5DC5 16r615C 16r5F73 16r615D 16r5F77 16r615E 16r5F82 16r615F 16r5F87 16r6160 16r5F89 16r6161 16r5F8C 16r6162 16r5F95 16r6163 16r5F99 16r6164 16r5F9C 16r6165 16r5FA8 16r6166 16r5FAD 16r6167 16r5FB5 16r6168 16r5FBC 16r6169 16r8862 16r616A 16r5F61 16r616B 16r72AD 16r616C 16r72B0 16r616D 16r72B4 16r616E 16r72B7 16r616F 16r72B8 16r6170 16r72C3 16r6171 16r72C1 16r6172 16r72CE 16r6173 16r72CD 16r6174 16r72D2 16r6175 16r72E8 16r6176 16r72EF 16r6177 16r72E9 16r6178 16r72F2 16r6179 16r72F4 16r617A 16r72F7 16r617B 16r7301 16r617C 16r72F3 16r617D 16r7303 16r617E 16r72FA 16r6221 16r72FB 16r6222 16r7317 16r6223 16r7313 16r6224 16r7321 16r6225 16r730A 16r6226 16r731E 16r6227 16r731D 16r6228 16r7315 16r6229 16r7322 16r622A 16r7339 16r622B 16r7325 16r622C 16r732C 16r622D 16r7338 16r622E 16r7331 16r622F 16r7350 16r6230 16r734D 16r6231 16r7357 16r6232 16r7360 16r6233 16r736C 16r6234 16r736F 16r6235 16r737E 16r6236 16r821B 16r6237 16r5925 16r6238 16r98E7 16r6239 16r5924 16r623A 16r5902 16r623B 16r9963 16r623C 16r9967 16r623D 16r9968 16r623E 16r9969 16r623F 16r996A 16r6240 16r996B 16r6241 16r996C 16r6242 16r9974 16r6243 16r9977 16r6244 16r997D 16r6245 16r9980 16r6246 16r9984 16r6247 16r9987 16r6248 16r998A 16r6249 16r998D 16r624A 16r9990 16r624B 16r9991 16r624C 16r9993 16r624D 16r9994 16r624E 16r9995 16r624F 16r5E80 16r6250 16r5E91 16r6251 16r5E8B 16r6252 16r5E96 16r6253 16r5EA5 16r6254 16r5EA0 16r6255 16r5EB9 16r6256 16r5EB5 16r6257 16r5EBE 16r6258 16r5EB3 16r6259 16r8D53 16r625A 16r5ED2 16r625B 16r5ED1 16r625C 16r5EDB 16r625D 16r5EE8 16r625E 16r5EEA 16r625F 16r81BA 16r6260 16r5FC4 16r6261 16r5FC9 16r6262 16r5FD6 16r6263 16r5FCF 16r6264 16r6003 16r6265 16r5FEE 16r6266 16r6004 16r6267 16r5FE1 16r6268 16r5FE4 16r6269 16r5FFE 16r626A 16r6005 16r626B 16r6006 16r626C 16r5FEA 16r626D 16r5FED 16r626E 16r5FF8 16r626F 16r6019 16r6270 16r6035 16r6271 16r6026 16r6272 16r601B 16r6273 16r600F 16r6274 16r600D 16r6275 16r6029 16r6276 16r602B 16r6277 16r600A 16r6278 16r603F 16r6279 16r6021 16r627A 16r6078 16r627B 16r6079 16r627C 16r607B 16r627D 16r607A 16r627E 16r6042 16r6321 16r606A 16r6322 16r607D 16r6323 16r6096 16r6324 16r609A 16r6325 16r60AD 16r6326 16r609D 16r6327 16r6083 16r6328 16r6092 16r6329 16r608C 16r632A 16r609B 16r632B 16r60EC 16r632C 16r60BB 16r632D 16r60B1 16r632E 16r60DD 16r632F 16r60D8 16r6330 16r60C6 16r6331 16r60DA 16r6332 16r60B4 16r6333 16r6120 16r6334 16r6126 16r6335 16r6115 16r6336 16r6123 16r6337 16r60F4 16r6338 16r6100 16r6339 16r610E 16r633A 16r612B 16r633B 16r614A 16r633C 16r6175 16r633D 16r61AC 16r633E 16r6194 16r633F 16r61A7 16r6340 16r61B7 16r6341 16r61D4 16r6342 16r61F5 16r6343 16r5FDD 16r6344 16r96B3 16r6345 16r95E9 16r6346 16r95EB 16r6347 16r95F1 16r6348 16r95F3 16r6349 16r95F5 16r634A 16r95F6 16r634B 16r95FC 16r634C 16r95FE 16r634D 16r9603 16r634E 16r9604 16r634F 16r9606 16r6350 16r9608 16r6351 16r960A 16r6352 16r960B 16r6353 16r960C 16r6354 16r960D 16r6355 16r960F 16r6356 16r9612 16r6357 16r9615 16r6358 16r9616 16r6359 16r9617 16r635A 16r9619 16r635B 16r961A 16r635C 16r4E2C 16r635D 16r723F 16r635E 16r6215 16r635F 16r6C35 16r6360 16r6C54 16r6361 16r6C5C 16r6362 16r6C4A 16r6363 16r6CA3 16r6364 16r6C85 16r6365 16r6C90 16r6366 16r6C94 16r6367 16r6C8C 16r6368 16r6C68 16r6369 16r6C69 16r636A 16r6C74 16r636B 16r6C76 16r636C 16r6C86 16r636D 16r6CA9 16r636E 16r6CD0 16r636F 16r6CD4 16r6370 16r6CAD 16r6371 16r6CF7 16r6372 16r6CF8 16r6373 16r6CF1 16r6374 16r6CD7 16r6375 16r6CB2 16r6376 16r6CE0 16r6377 16r6CD6 16r6378 16r6CFA 16r6379 16r6CEB 16r637A 16r6CEE 16r637B 16r6CB1 16r637C 16r6CD3 16r637D 16r6CEF 16r637E 16r6CFE 16r6421 16r6D39 16r6422 16r6D27 16r6423 16r6D0C 16r6424 16r6D43 16r6425 16r6D48 16r6426 16r6D07 16r6427 16r6D04 16r6428 16r6D19 16r6429 16r6D0E 16r642A 16r6D2B 16r642B 16r6D4D 16r642C 16r6D2E 16r642D 16r6D35 16r642E 16r6D1A 16r642F 16r6D4F 16r6430 16r6D52 16r6431 16r6D54 16r6432 16r6D33 16r6433 16r6D91 16r6434 16r6D6F 16r6435 16r6D9E 16r6436 16r6DA0 16r6437 16r6D5E 16r6438 16r6D93 16r6439 16r6D94 16r643A 16r6D5C 16r643B 16r6D60 16r643C 16r6D7C 16r643D 16r6D63 16r643E 16r6E1A 16r643F 16r6DC7 16r6440 16r6DC5 16r6441 16r6DDE 16r6442 16r6E0E 16r6443 16r6DBF 16r6444 16r6DE0 16r6445 16r6E11 16r6446 16r6DE6 16r6447 16r6DDD 16r6448 16r6DD9 16r6449 16r6E16 16r644A 16r6DAB 16r644B 16r6E0C 16r644C 16r6DAE 16r644D 16r6E2B 16r644E 16r6E6E 16r644F 16r6E4E 16r6450 16r6E6B 16r6451 16r6EB2 16r6452 16r6E5F 16r6453 16r6E86 16r6454 16r6E53 16r6455 16r6E54 16r6456 16r6E32 16r6457 16r6E25 16r6458 16r6E44 16r6459 16r6EDF 16r645A 16r6EB1 16r645B 16r6E98 16r645C 16r6EE0 16r645D 16r6F2D 16r645E 16r6EE2 16r645F 16r6EA5 16r6460 16r6EA7 16r6461 16r6EBD 16r6462 16r6EBB 16r6463 16r6EB7 16r6464 16r6ED7 16r6465 16r6EB4 16r6466 16r6ECF 16r6467 16r6E8F 16r6468 16r6EC2 16r6469 16r6E9F 16r646A 16r6F62 16r646B 16r6F46 16r646C 16r6F47 16r646D 16r6F24 16r646E 16r6F15 16r646F 16r6EF9 16r6470 16r6F2F 16r6471 16r6F36 16r6472 16r6F4B 16r6473 16r6F74 16r6474 16r6F2A 16r6475 16r6F09 16r6476 16r6F29 16r6477 16r6F89 16r6478 16r6F8D 16r6479 16r6F8C 16r647A 16r6F78 16r647B 16r6F72 16r647C 16r6F7C 16r647D 16r6F7A 16r647E 16r6FD1 16r6521 16r6FC9 16r6522 16r6FA7 16r6523 16r6FB9 16r6524 16r6FB6 16r6525 16r6FC2 16r6526 16r6FE1 16r6527 16r6FEE 16r6528 16r6FDE 16r6529 16r6FE0 16r652A 16r6FEF 16r652B 16r701A 16r652C 16r7023 16r652D 16r701B 16r652E 16r7039 16r652F 16r7035 16r6530 16r704F 16r6531 16r705E 16r6532 16r5B80 16r6533 16r5B84 16r6534 16r5B95 16r6535 16r5B93 16r6536 16r5BA5 16r6537 16r5BB8 16r6538 16r752F 16r6539 16r9A9E 16r653A 16r6434 16r653B 16r5BE4 16r653C 16r5BEE 16r653D 16r8930 16r653E 16r5BF0 16r653F 16r8E47 16r6540 16r8B07 16r6541 16r8FB6 16r6542 16r8FD3 16r6543 16r8FD5 16r6544 16r8FE5 16r6545 16r8FEE 16r6546 16r8FE4 16r6547 16r8FE9 16r6548 16r8FE6 16r6549 16r8FF3 16r654A 16r8FE8 16r654B 16r9005 16r654C 16r9004 16r654D 16r900B 16r654E 16r9026 16r654F 16r9011 16r6550 16r900D 16r6551 16r9016 16r6552 16r9021 16r6553 16r9035 16r6554 16r9036 16r6555 16r902D 16r6556 16r902F 16r6557 16r9044 16r6558 16r9051 16r6559 16r9052 16r655A 16r9050 16r655B 16r9068 16r655C 16r9058 16r655D 16r9062 16r655E 16r905B 16r655F 16r66B9 16r6560 16r9074 16r6561 16r907D 16r6562 16r9082 16r6563 16r9088 16r6564 16r9083 16r6565 16r908B 16r6566 16r5F50 16r6567 16r5F57 16r6568 16r5F56 16r6569 16r5F58 16r656A 16r5C3B 16r656B 16r54AB 16r656C 16r5C50 16r656D 16r5C59 16r656E 16r5B71 16r656F 16r5C63 16r6570 16r5C66 16r6571 16r7FBC 16r6572 16r5F2A 16r6573 16r5F29 16r6574 16r5F2D 16r6575 16r8274 16r6576 16r5F3C 16r6577 16r9B3B 16r6578 16r5C6E 16r6579 16r5981 16r657A 16r5983 16r657B 16r598D 16r657C 16r59A9 16r657D 16r59AA 16r657E 16r59A3 16r6621 16r5997 16r6622 16r59CA 16r6623 16r59AB 16r6624 16r599E 16r6625 16r59A4 16r6626 16r59D2 16r6627 16r59B2 16r6628 16r59AF 16r6629 16r59D7 16r662A 16r59BE 16r662B 16r5A05 16r662C 16r5A06 16r662D 16r59DD 16r662E 16r5A08 16r662F 16r59E3 16r6630 16r59D8 16r6631 16r59F9 16r6632 16r5A0C 16r6633 16r5A09 16r6634 16r5A32 16r6635 16r5A34 16r6636 16r5A11 16r6637 16r5A23 16r6638 16r5A13 16r6639 16r5A40 16r663A 16r5A67 16r663B 16r5A4A 16r663C 16r5A55 16r663D 16r5A3C 16r663E 16r5A62 16r663F 16r5A75 16r6640 16r80EC 16r6641 16r5AAA 16r6642 16r5A9B 16r6643 16r5A77 16r6644 16r5A7A 16r6645 16r5ABE 16r6646 16r5AEB 16r6647 16r5AB2 16r6648 16r5AD2 16r6649 16r5AD4 16r664A 16r5AB8 16r664B 16r5AE0 16r664C 16r5AE3 16r664D 16r5AF1 16r664E 16r5AD6 16r664F 16r5AE6 16r6650 16r5AD8 16r6651 16r5ADC 16r6652 16r5B09 16r6653 16r5B17 16r6654 16r5B16 16r6655 16r5B32 16r6656 16r5B37 16r6657 16r5B40 16r6658 16r5C15 16r6659 16r5C1C 16r665A 16r5B5A 16r665B 16r5B65 16r665C 16r5B73 16r665D 16r5B51 16r665E 16r5B53 16r665F 16r5B62 16r6660 16r9A75 16r6661 16r9A77 16r6662 16r9A78 16r6663 16r9A7A 16r6664 16r9A7F 16r6665 16r9A7D 16r6666 16r9A80 16r6667 16r9A81 16r6668 16r9A85 16r6669 16r9A88 16r666A 16r9A8A 16r666B 16r9A90 16r666C 16r9A92 16r666D 16r9A93 16r666E 16r9A96 16r666F 16r9A98 16r6670 16r9A9B 16r6671 16r9A9C 16r6672 16r9A9D 16r6673 16r9A9F 16r6674 16r9AA0 16r6675 16r9AA2 16r6676 16r9AA3 16r6677 16r9AA5 16r6678 16r9AA7 16r6679 16r7E9F 16r667A 16r7EA1 16r667B 16r7EA3 16r667C 16r7EA5 16r667D 16r7EA8 16r667E 16r7EA9 16r6721 16r7EAD 16r6722 16r7EB0 16r6723 16r7EBE 16r6724 16r7EC0 16r6725 16r7EC1 16r6726 16r7EC2 16r6727 16r7EC9 16r6728 16r7ECB 16r6729 16r7ECC 16r672A 16r7ED0 16r672B 16r7ED4 16r672C 16r7ED7 16r672D 16r7EDB 16r672E 16r7EE0 16r672F 16r7EE1 16r6730 16r7EE8 16r6731 16r7EEB 16r6732 16r7EEE 16r6733 16r7EEF 16r6734 16r7EF1 16r6735 16r7EF2 16r6736 16r7F0D 16r6737 16r7EF6 16r6738 16r7EFA 16r6739 16r7EFB 16r673A 16r7EFE 16r673B 16r7F01 16r673C 16r7F02 16r673D 16r7F03 16r673E 16r7F07 16r673F 16r7F08 16r6740 16r7F0B 16r6741 16r7F0C 16r6742 16r7F0F 16r6743 16r7F11 16r6744 16r7F12 16r6745 16r7F17 16r6746 16r7F19 16r6747 16r7F1C 16r6748 16r7F1B 16r6749 16r7F1F 16r674A 16r7F21 16r674B 16r7F22 16r674C 16r7F23 16r674D 16r7F24 16r674E 16r7F25 16r674F 16r7F26 16r6750 16r7F27 16r6751 16r7F2A 16r6752 16r7F2B 16r6753 16r7F2C 16r6754 16r7F2D 16r6755 16r7F2F 16r6756 16r7F30 16r6757 16r7F31 16r6758 16r7F32 16r6759 16r7F33 16r675A 16r7F35 16r675B 16r5E7A 16r675C 16r757F 16r675D 16r5DDB 16r675E 16r753E 16r675F 16r9095 16r6760 16r738E 16r6761 16r7391 16r6762 16r73AE 16r6763 16r73A2 16r6764 16r739F 16r6765 16r73CF 16r6766 16r73C2 16r6767 16r73D1 16r6768 16r73B7 16r6769 16r73B3 16r676A 16r73C0 16r676B 16r73C9 16r676C 16r73C8 16r676D 16r73E5 16r676E 16r73D9 16r676F 16r987C 16r6770 16r740A 16r6771 16r73E9 16r6772 16r73E7 16r6773 16r73DE 16r6774 16r73BA 16r6775 16r73F2 16r6776 16r740F 16r6777 16r742A 16r6778 16r745B 16r6779 16r7426 16r677A 16r7425 16r677B 16r7428 16r677C 16r7430 16r677D 16r742E 16r677E 16r742C 16r6821 16r741B 16r6822 16r741A 16r6823 16r7441 16r6824 16r745C 16r6825 16r7457 16r6826 16r7455 16r6827 16r7459 16r6828 16r7477 16r6829 16r746D 16r682A 16r747E 16r682B 16r749C 16r682C 16r748E 16r682D 16r7480 16r682E 16r7481 16r682F 16r7487 16r6830 16r748B 16r6831 16r749E 16r6832 16r74A8 16r6833 16r74A9 16r6834 16r7490 16r6835 16r74A7 16r6836 16r74D2 16r6837 16r74BA 16r6838 16r97EA 16r6839 16r97EB 16r683A 16r97EC 16r683B 16r674C 16r683C 16r6753 16r683D 16r675E 16r683E 16r6748 16r683F 16r6769 16r6840 16r67A5 16r6841 16r6787 16r6842 16r676A 16r6843 16r6773 16r6844 16r6798 16r6845 16r67A7 16r6846 16r6775 16r6847 16r67A8 16r6848 16r679E 16r6849 16r67AD 16r684A 16r678B 16r684B 16r6777 16r684C 16r677C 16r684D 16r67F0 16r684E 16r6809 16r684F 16r67D8 16r6850 16r680A 16r6851 16r67E9 16r6852 16r67B0 16r6853 16r680C 16r6854 16r67D9 16r6855 16r67B5 16r6856 16r67DA 16r6857 16r67B3 16r6858 16r67DD 16r6859 16r6800 16r685A 16r67C3 16r685B 16r67B8 16r685C 16r67E2 16r685D 16r680E 16r685E 16r67C1 16r685F 16r67FD 16r6860 16r6832 16r6861 16r6833 16r6862 16r6860 16r6863 16r6861 16r6864 16r684E 16r6865 16r6862 16r6866 16r6844 16r6867 16r6864 16r6868 16r6883 16r6869 16r681D 16r686A 16r6855 16r686B 16r6866 16r686C 16r6841 16r686D 16r6867 16r686E 16r6840 16r686F 16r683E 16r6870 16r684A 16r6871 16r6849 16r6872 16r6829 16r6873 16r68B5 16r6874 16r688F 16r6875 16r6874 16r6876 16r6877 16r6877 16r6893 16r6878 16r686B 16r6879 16r68C2 16r687A 16r696E 16r687B 16r68FC 16r687C 16r691F 16r687D 16r6920 16r687E 16r68F9 16r6921 16r6924 16r6922 16r68F0 16r6923 16r690B 16r6924 16r6901 16r6925 16r6957 16r6926 16r68E3 16r6927 16r6910 16r6928 16r6971 16r6929 16r6939 16r692A 16r6960 16r692B 16r6942 16r692C 16r695D 16r692D 16r6984 16r692E 16r696B 16r692F 16r6980 16r6930 16r6998 16r6931 16r6978 16r6932 16r6934 16r6933 16r69CC 16r6934 16r6987 16r6935 16r6988 16r6936 16r69CE 16r6937 16r6989 16r6938 16r6966 16r6939 16r6963 16r693A 16r6979 16r693B 16r699B 16r693C 16r69A7 16r693D 16r69BB 16r693E 16r69AB 16r693F 16r69AD 16r6940 16r69D4 16r6941 16r69B1 16r6942 16r69C1 16r6943 16r69CA 16r6944 16r69DF 16r6945 16r6995 16r6946 16r69E0 16r6947 16r698D 16r6948 16r69FF 16r6949 16r6A2F 16r694A 16r69ED 16r694B 16r6A17 16r694C 16r6A18 16r694D 16r6A65 16r694E 16r69F2 16r694F 16r6A44 16r6950 16r6A3E 16r6951 16r6AA0 16r6952 16r6A50 16r6953 16r6A5B 16r6954 16r6A35 16r6955 16r6A8E 16r6956 16r6A79 16r6957 16r6A3D 16r6958 16r6A28 16r6959 16r6A58 16r695A 16r6A7C 16r695B 16r6A91 16r695C 16r6A90 16r695D 16r6AA9 16r695E 16r6A97 16r695F 16r6AAB 16r6960 16r7337 16r6961 16r7352 16r6962 16r6B81 16r6963 16r6B82 16r6964 16r6B87 16r6965 16r6B84 16r6966 16r6B92 16r6967 16r6B93 16r6968 16r6B8D 16r6969 16r6B9A 16r696A 16r6B9B 16r696B 16r6BA1 16r696C 16r6BAA 16r696D 16r8F6B 16r696E 16r8F6D 16r696F 16r8F71 16r6970 16r8F72 16r6971 16r8F73 16r6972 16r8F75 16r6973 16r8F76 16r6974 16r8F78 16r6975 16r8F77 16r6976 16r8F79 16r6977 16r8F7A 16r6978 16r8F7C 16r6979 16r8F7E 16r697A 16r8F81 16r697B 16r8F82 16r697C 16r8F84 16r697D 16r8F87 16r697E 16r8F8B 16r6A21 16r8F8D 16r6A22 16r8F8E 16r6A23 16r8F8F 16r6A24 16r8F98 16r6A25 16r8F9A 16r6A26 16r8ECE 16r6A27 16r620B 16r6A28 16r6217 16r6A29 16r621B 16r6A2A 16r621F 16r6A2B 16r6222 16r6A2C 16r6221 16r6A2D 16r6225 16r6A2E 16r6224 16r6A2F 16r622C 16r6A30 16r81E7 16r6A31 16r74EF 16r6A32 16r74F4 16r6A33 16r74FF 16r6A34 16r750F 16r6A35 16r7511 16r6A36 16r7513 16r6A37 16r6534 16r6A38 16r65EE 16r6A39 16r65EF 16r6A3A 16r65F0 16r6A3B 16r660A 16r6A3C 16r6619 16r6A3D 16r6772 16r6A3E 16r6603 16r6A3F 16r6615 16r6A40 16r6600 16r6A41 16r7085 16r6A42 16r66F7 16r6A43 16r661D 16r6A44 16r6634 16r6A45 16r6631 16r6A46 16r6636 16r6A47 16r6635 16r6A48 16r8006 16r6A49 16r665F 16r6A4A 16r6654 16r6A4B 16r6641 16r6A4C 16r664F 16r6A4D 16r6656 16r6A4E 16r6661 16r6A4F 16r6657 16r6A50 16r6677 16r6A51 16r6684 16r6A52 16r668C 16r6A53 16r66A7 16r6A54 16r669D 16r6A55 16r66BE 16r6A56 16r66DB 16r6A57 16r66DC 16r6A58 16r66E6 16r6A59 16r66E9 16r6A5A 16r8D32 16r6A5B 16r8D33 16r6A5C 16r8D36 16r6A5D 16r8D3B 16r6A5E 16r8D3D 16r6A5F 16r8D40 16r6A60 16r8D45 16r6A61 16r8D46 16r6A62 16r8D48 16r6A63 16r8D49 16r6A64 16r8D47 16r6A65 16r8D4D 16r6A66 16r8D55 16r6A67 16r8D59 16r6A68 16r89C7 16r6A69 16r89CA 16r6A6A 16r89CB 16r6A6B 16r89CC 16r6A6C 16r89CE 16r6A6D 16r89CF 16r6A6E 16r89D0 16r6A6F 16r89D1 16r6A70 16r726E 16r6A71 16r729F 16r6A72 16r725D 16r6A73 16r7266 16r6A74 16r726F 16r6A75 16r727E 16r6A76 16r727F 16r6A77 16r7284 16r6A78 16r728B 16r6A79 16r728D 16r6A7A 16r728F 16r6A7B 16r7292 16r6A7C 16r6308 16r6A7D 16r6332 16r6A7E 16r63B0 16r6B21 16r643F 16r6B22 16r64D8 16r6B23 16r8004 16r6B24 16r6BEA 16r6B25 16r6BF3 16r6B26 16r6BFD 16r6B27 16r6BF5 16r6B28 16r6BF9 16r6B29 16r6C05 16r6B2A 16r6C07 16r6B2B 16r6C06 16r6B2C 16r6C0D 16r6B2D 16r6C15 16r6B2E 16r6C18 16r6B2F 16r6C19 16r6B30 16r6C1A 16r6B31 16r6C21 16r6B32 16r6C29 16r6B33 16r6C24 16r6B34 16r6C2A 16r6B35 16r6C32 16r6B36 16r6535 16r6B37 16r6555 16r6B38 16r656B 16r6B39 16r724D 16r6B3A 16r7252 16r6B3B 16r7256 16r6B3C 16r7230 16r6B3D 16r8662 16r6B3E 16r5216 16r6B3F 16r809F 16r6B40 16r809C 16r6B41 16r8093 16r6B42 16r80BC 16r6B43 16r670A 16r6B44 16r80BD 16r6B45 16r80B1 16r6B46 16r80AB 16r6B47 16r80AD 16r6B48 16r80B4 16r6B49 16r80B7 16r6B4A 16r80E7 16r6B4B 16r80E8 16r6B4C 16r80E9 16r6B4D 16r80EA 16r6B4E 16r80DB 16r6B4F 16r80C2 16r6B50 16r80C4 16r6B51 16r80D9 16r6B52 16r80CD 16r6B53 16r80D7 16r6B54 16r6710 16r6B55 16r80DD 16r6B56 16r80EB 16r6B57 16r80F1 16r6B58 16r80F4 16r6B59 16r80ED 16r6B5A 16r810D 16r6B5B 16r810E 16r6B5C 16r80F2 16r6B5D 16r80FC 16r6B5E 16r6715 16r6B5F 16r8112 16r6B60 16r8C5A 16r6B61 16r8136 16r6B62 16r811E 16r6B63 16r812C 16r6B64 16r8118 16r6B65 16r8132 16r6B66 16r8148 16r6B67 16r814C 16r6B68 16r8153 16r6B69 16r8174 16r6B6A 16r8159 16r6B6B 16r815A 16r6B6C 16r8171 16r6B6D 16r8160 16r6B6E 16r8169 16r6B6F 16r817C 16r6B70 16r817D 16r6B71 16r816D 16r6B72 16r8167 16r6B73 16r584D 16r6B74 16r5AB5 16r6B75 16r8188 16r6B76 16r8182 16r6B77 16r8191 16r6B78 16r6ED5 16r6B79 16r81A3 16r6B7A 16r81AA 16r6B7B 16r81CC 16r6B7C 16r6726 16r6B7D 16r81CA 16r6B7E 16r81BB 16r6C21 16r81C1 16r6C22 16r81A6 16r6C23 16r6B24 16r6C24 16r6B37 16r6C25 16r6B39 16r6C26 16r6B43 16r6C27 16r6B46 16r6C28 16r6B59 16r6C29 16r98D1 16r6C2A 16r98D2 16r6C2B 16r98D3 16r6C2C 16r98D5 16r6C2D 16r98D9 16r6C2E 16r98DA 16r6C2F 16r6BB3 16r6C30 16r5F40 16r6C31 16r6BC2 16r6C32 16r89F3 16r6C33 16r6590 16r6C34 16r9F51 16r6C35 16r6593 16r6C36 16r65BC 16r6C37 16r65C6 16r6C38 16r65C4 16r6C39 16r65C3 16r6C3A 16r65CC 16r6C3B 16r65CE 16r6C3C 16r65D2 16r6C3D 16r65D6 16r6C3E 16r7080 16r6C3F 16r709C 16r6C40 16r7096 16r6C41 16r709D 16r6C42 16r70BB 16r6C43 16r70C0 16r6C44 16r70B7 16r6C45 16r70AB 16r6C46 16r70B1 16r6C47 16r70E8 16r6C48 16r70CA 16r6C49 16r7110 16r6C4A 16r7113 16r6C4B 16r7116 16r6C4C 16r712F 16r6C4D 16r7131 16r6C4E 16r7173 16r6C4F 16r715C 16r6C50 16r7168 16r6C51 16r7145 16r6C52 16r7172 16r6C53 16r714A 16r6C54 16r7178 16r6C55 16r717A 16r6C56 16r7198 16r6C57 16r71B3 16r6C58 16r71B5 16r6C59 16r71A8 16r6C5A 16r71A0 16r6C5B 16r71E0 16r6C5C 16r71D4 16r6C5D 16r71E7 16r6C5E 16r71F9 16r6C5F 16r721D 16r6C60 16r7228 16r6C61 16r706C 16r6C62 16r7118 16r6C63 16r7166 16r6C64 16r71B9 16r6C65 16r623E 16r6C66 16r623D 16r6C67 16r6243 16r6C68 16r6248 16r6C69 16r6249 16r6C6A 16r793B 16r6C6B 16r7940 16r6C6C 16r7946 16r6C6D 16r7949 16r6C6E 16r795B 16r6C6F 16r795C 16r6C70 16r7953 16r6C71 16r795A 16r6C72 16r7962 16r6C73 16r7957 16r6C74 16r7960 16r6C75 16r796F 16r6C76 16r7967 16r6C77 16r797A 16r6C78 16r7985 16r6C79 16r798A 16r6C7A 16r799A 16r6C7B 16r79A7 16r6C7C 16r79B3 16r6C7D 16r5FD1 16r6C7E 16r5FD0 16r6D21 16r603C 16r6D22 16r605D 16r6D23 16r605A 16r6D24 16r6067 16r6D25 16r6041 16r6D26 16r6059 16r6D27 16r6063 16r6D28 16r60AB 16r6D29 16r6106 16r6D2A 16r610D 16r6D2B 16r615D 16r6D2C 16r61A9 16r6D2D 16r619D 16r6D2E 16r61CB 16r6D2F 16r61D1 16r6D30 16r6206 16r6D31 16r8080 16r6D32 16r807F 16r6D33 16r6C93 16r6D34 16r6CF6 16r6D35 16r6DFC 16r6D36 16r77F6 16r6D37 16r77F8 16r6D38 16r7800 16r6D39 16r7809 16r6D3A 16r7817 16r6D3B 16r7818 16r6D3C 16r7811 16r6D3D 16r65AB 16r6D3E 16r782D 16r6D3F 16r781C 16r6D40 16r781D 16r6D41 16r7839 16r6D42 16r783A 16r6D43 16r783B 16r6D44 16r781F 16r6D45 16r783C 16r6D46 16r7825 16r6D47 16r782C 16r6D48 16r7823 16r6D49 16r7829 16r6D4A 16r784E 16r6D4B 16r786D 16r6D4C 16r7856 16r6D4D 16r7857 16r6D4E 16r7826 16r6D4F 16r7850 16r6D50 16r7847 16r6D51 16r784C 16r6D52 16r786A 16r6D53 16r789B 16r6D54 16r7893 16r6D55 16r789A 16r6D56 16r7887 16r6D57 16r789C 16r6D58 16r78A1 16r6D59 16r78A3 16r6D5A 16r78B2 16r6D5B 16r78B9 16r6D5C 16r78A5 16r6D5D 16r78D4 16r6D5E 16r78D9 16r6D5F 16r78C9 16r6D60 16r78EC 16r6D61 16r78F2 16r6D62 16r7905 16r6D63 16r78F4 16r6D64 16r7913 16r6D65 16r7924 16r6D66 16r791E 16r6D67 16r7934 16r6D68 16r9F9B 16r6D69 16r9EF9 16r6D6A 16r9EFB 16r6D6B 16r9EFC 16r6D6C 16r76F1 16r6D6D 16r7704 16r6D6E 16r770D 16r6D6F 16r76F9 16r6D70 16r7707 16r6D71 16r7708 16r6D72 16r771A 16r6D73 16r7722 16r6D74 16r7719 16r6D75 16r772D 16r6D76 16r7726 16r6D77 16r7735 16r6D78 16r7738 16r6D79 16r7750 16r6D7A 16r7751 16r6D7B 16r7747 16r6D7C 16r7743 16r6D7D 16r775A 16r6D7E 16r7768 16r6E21 16r7762 16r6E22 16r7765 16r6E23 16r777F 16r6E24 16r778D 16r6E25 16r777D 16r6E26 16r7780 16r6E27 16r778C 16r6E28 16r7791 16r6E29 16r779F 16r6E2A 16r77A0 16r6E2B 16r77B0 16r6E2C 16r77B5 16r6E2D 16r77BD 16r6E2E 16r753A 16r6E2F 16r7540 16r6E30 16r754E 16r6E31 16r754B 16r6E32 16r7548 16r6E33 16r755B 16r6E34 16r7572 16r6E35 16r7579 16r6E36 16r7583 16r6E37 16r7F58 16r6E38 16r7F61 16r6E39 16r7F5F 16r6E3A 16r8A48 16r6E3B 16r7F68 16r6E3C 16r7F74 16r6E3D 16r7F71 16r6E3E 16r7F79 16r6E3F 16r7F81 16r6E40 16r7F7E 16r6E41 16r76CD 16r6E42 16r76E5 16r6E43 16r8832 16r6E44 16r9485 16r6E45 16r9486 16r6E46 16r9487 16r6E47 16r948B 16r6E48 16r948A 16r6E49 16r948C 16r6E4A 16r948D 16r6E4B 16r948F 16r6E4C 16r9490 16r6E4D 16r9494 16r6E4E 16r9497 16r6E4F 16r9495 16r6E50 16r949A 16r6E51 16r949B 16r6E52 16r949C 16r6E53 16r94A3 16r6E54 16r94A4 16r6E55 16r94AB 16r6E56 16r94AA 16r6E57 16r94AD 16r6E58 16r94AC 16r6E59 16r94AF 16r6E5A 16r94B0 16r6E5B 16r94B2 16r6E5C 16r94B4 16r6E5D 16r94B6 16r6E5E 16r94B7 16r6E5F 16r94B8 16r6E60 16r94B9 16r6E61 16r94BA 16r6E62 16r94BC 16r6E63 16r94BD 16r6E64 16r94BF 16r6E65 16r94C4 16r6E66 16r94C8 16r6E67 16r94C9 16r6E68 16r94CA 16r6E69 16r94CB 16r6E6A 16r94CC 16r6E6B 16r94CD 16r6E6C 16r94CE 16r6E6D 16r94D0 16r6E6E 16r94D1 16r6E6F 16r94D2 16r6E70 16r94D5 16r6E71 16r94D6 16r6E72 16r94D7 16r6E73 16r94D9 16r6E74 16r94D8 16r6E75 16r94DB 16r6E76 16r94DE 16r6E77 16r94DF 16r6E78 16r94E0 16r6E79 16r94E2 16r6E7A 16r94E4 16r6E7B 16r94E5 16r6E7C 16r94E7 16r6E7D 16r94E8 16r6E7E 16r94EA 16r6F21 16r94E9 16r6F22 16r94EB 16r6F23 16r94EE 16r6F24 16r94EF 16r6F25 16r94F3 16r6F26 16r94F4 16r6F27 16r94F5 16r6F28 16r94F7 16r6F29 16r94F9 16r6F2A 16r94FC 16r6F2B 16r94FD 16r6F2C 16r94FF 16r6F2D 16r9503 16r6F2E 16r9502 16r6F2F 16r9506 16r6F30 16r9507 16r6F31 16r9509 16r6F32 16r950A 16r6F33 16r950D 16r6F34 16r950E 16r6F35 16r950F 16r6F36 16r9512 16r6F37 16r9513 16r6F38 16r9514 16r6F39 16r9515 16r6F3A 16r9516 16r6F3B 16r9518 16r6F3C 16r951B 16r6F3D 16r951D 16r6F3E 16r951E 16r6F3F 16r951F 16r6F40 16r9522 16r6F41 16r952A 16r6F42 16r952B 16r6F43 16r9529 16r6F44 16r952C 16r6F45 16r9531 16r6F46 16r9532 16r6F47 16r9534 16r6F48 16r9536 16r6F49 16r9537 16r6F4A 16r9538 16r6F4B 16r953C 16r6F4C 16r953E 16r6F4D 16r953F 16r6F4E 16r9542 16r6F4F 16r9535 16r6F50 16r9544 16r6F51 16r9545 16r6F52 16r9546 16r6F53 16r9549 16r6F54 16r954C 16r6F55 16r954E 16r6F56 16r954F 16r6F57 16r9552 16r6F58 16r9553 16r6F59 16r9554 16r6F5A 16r9556 16r6F5B 16r9557 16r6F5C 16r9558 16r6F5D 16r9559 16r6F5E 16r955B 16r6F5F 16r955E 16r6F60 16r955F 16r6F61 16r955D 16r6F62 16r9561 16r6F63 16r9562 16r6F64 16r9564 16r6F65 16r9565 16r6F66 16r9566 16r6F67 16r9567 16r6F68 16r9568 16r6F69 16r9569 16r6F6A 16r956A 16r6F6B 16r956B 16r6F6C 16r956C 16r6F6D 16r956F 16r6F6E 16r9571 16r6F6F 16r9572 16r6F70 16r9573 16r6F71 16r953A 16r6F72 16r77E7 16r6F73 16r77EC 16r6F74 16r96C9 16r6F75 16r79D5 16r6F76 16r79ED 16r6F77 16r79E3 16r6F78 16r79EB 16r6F79 16r7A06 16r6F7A 16r5D47 16r6F7B 16r7A03 16r6F7C 16r7A02 16r6F7D 16r7A1E 16r6F7E 16r7A14 16r7021 16r7A39 16r7022 16r7A37 16r7023 16r7A51 16r7024 16r9ECF 16r7025 16r99A5 16r7026 16r7A70 16r7027 16r7688 16r7028 16r768E 16r7029 16r7693 16r702A 16r7699 16r702B 16r76A4 16r702C 16r74DE 16r702D 16r74E0 16r702E 16r752C 16r702F 16r9E20 16r7030 16r9E22 16r7031 16r9E28 16r7032 16r9E29 16r7033 16r9E2A 16r7034 16r9E2B 16r7035 16r9E2C 16r7036 16r9E32 16r7037 16r9E31 16r7038 16r9E36 16r7039 16r9E38 16r703A 16r9E37 16r703B 16r9E39 16r703C 16r9E3A 16r703D 16r9E3E 16r703E 16r9E41 16r703F 16r9E42 16r7040 16r9E44 16r7041 16r9E46 16r7042 16r9E47 16r7043 16r9E48 16r7044 16r9E49 16r7045 16r9E4B 16r7046 16r9E4C 16r7047 16r9E4E 16r7048 16r9E51 16r7049 16r9E55 16r704A 16r9E57 16r704B 16r9E5A 16r704C 16r9E5B 16r704D 16r9E5C 16r704E 16r9E5E 16r704F 16r9E63 16r7050 16r9E66 16r7051 16r9E67 16r7052 16r9E68 16r7053 16r9E69 16r7054 16r9E6A 16r7055 16r9E6B 16r7056 16r9E6C 16r7057 16r9E71 16r7058 16r9E6D 16r7059 16r9E73 16r705A 16r7592 16r705B 16r7594 16r705C 16r7596 16r705D 16r75A0 16r705E 16r759D 16r705F 16r75AC 16r7060 16r75A3 16r7061 16r75B3 16r7062 16r75B4 16r7063 16r75B8 16r7064 16r75C4 16r7065 16r75B1 16r7066 16r75B0 16r7067 16r75C3 16r7068 16r75C2 16r7069 16r75D6 16r706A 16r75CD 16r706B 16r75E3 16r706C 16r75E8 16r706D 16r75E6 16r706E 16r75E4 16r706F 16r75EB 16r7070 16r75E7 16r7071 16r7603 16r7072 16r75F1 16r7073 16r75FC 16r7074 16r75FF 16r7075 16r7610 16r7076 16r7600 16r7077 16r7605 16r7078 16r760C 16r7079 16r7617 16r707A 16r760A 16r707B 16r7625 16r707C 16r7618 16r707D 16r7615 16r707E 16r7619 16r7121 16r761B 16r7122 16r763C 16r7123 16r7622 16r7124 16r7620 16r7125 16r7640 16r7126 16r762D 16r7127 16r7630 16r7128 16r763F 16r7129 16r7635 16r712A 16r7643 16r712B 16r763E 16r712C 16r7633 16r712D 16r764D 16r712E 16r765E 16r712F 16r7654 16r7130 16r765C 16r7131 16r7656 16r7132 16r766B 16r7133 16r766F 16r7134 16r7FCA 16r7135 16r7AE6 16r7136 16r7A78 16r7137 16r7A79 16r7138 16r7A80 16r7139 16r7A86 16r713A 16r7A88 16r713B 16r7A95 16r713C 16r7AA6 16r713D 16r7AA0 16r713E 16r7AAC 16r713F 16r7AA8 16r7140 16r7AAD 16r7141 16r7AB3 16r7142 16r8864 16r7143 16r8869 16r7144 16r8872 16r7145 16r887D 16r7146 16r887F 16r7147 16r8882 16r7148 16r88A2 16r7149 16r88C6 16r714A 16r88B7 16r714B 16r88BC 16r714C 16r88C9 16r714D 16r88E2 16r714E 16r88CE 16r714F 16r88E3 16r7150 16r88E5 16r7151 16r88F1 16r7152 16r891A 16r7153 16r88FC 16r7154 16r88E8 16r7155 16r88FE 16r7156 16r88F0 16r7157 16r8921 16r7158 16r8919 16r7159 16r8913 16r715A 16r891B 16r715B 16r890A 16r715C 16r8934 16r715D 16r892B 16r715E 16r8936 16r715F 16r8941 16r7160 16r8966 16r7161 16r897B 16r7162 16r758B 16r7163 16r80E5 16r7164 16r76B2 16r7165 16r76B4 16r7166 16r77DC 16r7167 16r8012 16r7168 16r8014 16r7169 16r8016 16r716A 16r801C 16r716B 16r8020 16r716C 16r8022 16r716D 16r8025 16r716E 16r8026 16r716F 16r8027 16r7170 16r8029 16r7171 16r8028 16r7172 16r8031 16r7173 16r800B 16r7174 16r8035 16r7175 16r8043 16r7176 16r8046 16r7177 16r804D 16r7178 16r8052 16r7179 16r8069 16r717A 16r8071 16r717B 16r8983 16r717C 16r9878 16r717D 16r9880 16r717E 16r9883 16r7221 16r9889 16r7222 16r988C 16r7223 16r988D 16r7224 16r988F 16r7225 16r9894 16r7226 16r989A 16r7227 16r989B 16r7228 16r989E 16r7229 16r989F 16r722A 16r98A1 16r722B 16r98A2 16r722C 16r98A5 16r722D 16r98A6 16r722E 16r864D 16r722F 16r8654 16r7230 16r866C 16r7231 16r866E 16r7232 16r867F 16r7233 16r867A 16r7234 16r867C 16r7235 16r867B 16r7236 16r86A8 16r7237 16r868D 16r7238 16r868B 16r7239 16r86AC 16r723A 16r869D 16r723B 16r86A7 16r723C 16r86A3 16r723D 16r86AA 16r723E 16r8693 16r723F 16r86A9 16r7240 16r86B6 16r7241 16r86C4 16r7242 16r86B5 16r7243 16r86CE 16r7244 16r86B0 16r7245 16r86BA 16r7246 16r86B1 16r7247 16r86AF 16r7248 16r86C9 16r7249 16r86CF 16r724A 16r86B4 16r724B 16r86E9 16r724C 16r86F1 16r724D 16r86F2 16r724E 16r86ED 16r724F 16r86F3 16r7250 16r86D0 16r7251 16r8713 16r7252 16r86DE 16r7253 16r86F4 16r7254 16r86DF 16r7255 16r86D8 16r7256 16r86D1 16r7257 16r8703 16r7258 16r8707 16r7259 16r86F8 16r725A 16r8708 16r725B 16r870A 16r725C 16r870D 16r725D 16r8709 16r725E 16r8723 16r725F 16r873B 16r7260 16r871E 16r7261 16r8725 16r7262 16r872E 16r7263 16r871A 16r7264 16r873E 16r7265 16r8748 16r7266 16r8734 16r7267 16r8731 16r7268 16r8729 16r7269 16r8737 16r726A 16r873F 16r726B 16r8782 16r726C 16r8722 16r726D 16r877D 16r726E 16r877E 16r726F 16r877B 16r7270 16r8760 16r7271 16r8770 16r7272 16r874C 16r7273 16r876E 16r7274 16r878B 16r7275 16r8753 16r7276 16r8763 16r7277 16r877C 16r7278 16r8764 16r7279 16r8759 16r727A 16r8765 16r727B 16r8793 16r727C 16r87AF 16r727D 16r87A8 16r727E 16r87D2 16r7321 16r87C6 16r7322 16r8788 16r7323 16r8785 16r7324 16r87AD 16r7325 16r8797 16r7326 16r8783 16r7327 16r87AB 16r7328 16r87E5 16r7329 16r87AC 16r732A 16r87B5 16r732B 16r87B3 16r732C 16r87CB 16r732D 16r87D3 16r732E 16r87BD 16r732F 16r87D1 16r7330 16r87C0 16r7331 16r87CA 16r7332 16r87DB 16r7333 16r87EA 16r7334 16r87E0 16r7335 16r87EE 16r7336 16r8816 16r7337 16r8813 16r7338 16r87FE 16r7339 16r880A 16r733A 16r881B 16r733B 16r8821 16r733C 16r8839 16r733D 16r883C 16r733E 16r7F36 16r733F 16r7F42 16r7340 16r7F44 16r7341 16r7F45 16r7342 16r8210 16r7343 16r7AFA 16r7344 16r7AFD 16r7345 16r7B08 16r7346 16r7B03 16r7347 16r7B04 16r7348 16r7B15 16r7349 16r7B0A 16r734A 16r7B2B 16r734B 16r7B0F 16r734C 16r7B47 16r734D 16r7B38 16r734E 16r7B2A 16r734F 16r7B19 16r7350 16r7B2E 16r7351 16r7B31 16r7352 16r7B20 16r7353 16r7B25 16r7354 16r7B24 16r7355 16r7B33 16r7356 16r7B3E 16r7357 16r7B1E 16r7358 16r7B58 16r7359 16r7B5A 16r735A 16r7B45 16r735B 16r7B75 16r735C 16r7B4C 16r735D 16r7B5D 16r735E 16r7B60 16r735F 16r7B6E 16r7360 16r7B7B 16r7361 16r7B62 16r7362 16r7B72 16r7363 16r7B71 16r7364 16r7B90 16r7365 16r7BA6 16r7366 16r7BA7 16r7367 16r7BB8 16r7368 16r7BAC 16r7369 16r7B9D 16r736A 16r7BA8 16r736B 16r7B85 16r736C 16r7BAA 16r736D 16r7B9C 16r736E 16r7BA2 16r736F 16r7BAB 16r7370 16r7BB4 16r7371 16r7BD1 16r7372 16r7BC1 16r7373 16r7BCC 16r7374 16r7BDD 16r7375 16r7BDA 16r7376 16r7BE5 16r7377 16r7BE6 16r7378 16r7BEA 16r7379 16r7C0C 16r737A 16r7BFE 16r737B 16r7BFC 16r737C 16r7C0F 16r737D 16r7C16 16r737E 16r7C0B 16r7421 16r7C1F 16r7422 16r7C2A 16r7423 16r7C26 16r7424 16r7C38 16r7425 16r7C41 16r7426 16r7C40 16r7427 16r81FE 16r7428 16r8201 16r7429 16r8202 16r742A 16r8204 16r742B 16r81EC 16r742C 16r8844 16r742D 16r8221 16r742E 16r8222 16r742F 16r8223 16r7430 16r822D 16r7431 16r822F 16r7432 16r8228 16r7433 16r822B 16r7434 16r8238 16r7435 16r823B 16r7436 16r8233 16r7437 16r8234 16r7438 16r823E 16r7439 16r8244 16r743A 16r8249 16r743B 16r824B 16r743C 16r824F 16r743D 16r825A 16r743E 16r825F 16r743F 16r8268 16r7440 16r887E 16r7441 16r8885 16r7442 16r8888 16r7443 16r88D8 16r7444 16r88DF 16r7445 16r895E 16r7446 16r7F9D 16r7447 16r7F9F 16r7448 16r7FA7 16r7449 16r7FAF 16r744A 16r7FB0 16r744B 16r7FB2 16r744C 16r7C7C 16r744D 16r6549 16r744E 16r7C91 16r744F 16r7C9D 16r7450 16r7C9C 16r7451 16r7C9E 16r7452 16r7CA2 16r7453 16r7CB2 16r7454 16r7CBC 16r7455 16r7CBD 16r7456 16r7CC1 16r7457 16r7CC7 16r7458 16r7CCC 16r7459 16r7CCD 16r745A 16r7CC8 16r745B 16r7CC5 16r745C 16r7CD7 16r745D 16r7CE8 16r745E 16r826E 16r745F 16r66A8 16r7460 16r7FBF 16r7461 16r7FCE 16r7462 16r7FD5 16r7463 16r7FE5 16r7464 16r7FE1 16r7465 16r7FE6 16r7466 16r7FE9 16r7467 16r7FEE 16r7468 16r7FF3 16r7469 16r7CF8 16r746A 16r7D77 16r746B 16r7DA6 16r746C 16r7DAE 16r746D 16r7E47 16r746E 16r7E9B 16r746F 16r9EB8 16r7470 16r9EB4 16r7471 16r8D73 16r7472 16r8D84 16r7473 16r8D94 16r7474 16r8D91 16r7475 16r8DB1 16r7476 16r8D67 16r7477 16r8D6D 16r7478 16r8C47 16r7479 16r8C49 16r747A 16r914A 16r747B 16r9150 16r747C 16r914E 16r747D 16r914F 16r747E 16r9164 16r7521 16r9162 16r7522 16r9161 16r7523 16r9170 16r7524 16r9169 16r7525 16r916F 16r7526 16r917D 16r7527 16r917E 16r7528 16r9172 16r7529 16r9174 16r752A 16r9179 16r752B 16r918C 16r752C 16r9185 16r752D 16r9190 16r752E 16r918D 16r752F 16r9191 16r7530 16r91A2 16r7531 16r91A3 16r7532 16r91AA 16r7533 16r91AD 16r7534 16r91AE 16r7535 16r91AF 16r7536 16r91B5 16r7537 16r91B4 16r7538 16r91BA 16r7539 16r8C55 16r753A 16r9E7E 16r753B 16r8DB8 16r753C 16r8DEB 16r753D 16r8E05 16r753E 16r8E59 16r753F 16r8E69 16r7540 16r8DB5 16r7541 16r8DBF 16r7542 16r8DBC 16r7543 16r8DBA 16r7544 16r8DC4 16r7545 16r8DD6 16r7546 16r8DD7 16r7547 16r8DDA 16r7548 16r8DDE 16r7549 16r8DCE 16r754A 16r8DCF 16r754B 16r8DDB 16r754C 16r8DC6 16r754D 16r8DEC 16r754E 16r8DF7 16r754F 16r8DF8 16r7550 16r8DE3 16r7551 16r8DF9 16r7552 16r8DFB 16r7553 16r8DE4 16r7554 16r8E09 16r7555 16r8DFD 16r7556 16r8E14 16r7557 16r8E1D 16r7558 16r8E1F 16r7559 16r8E2C 16r755A 16r8E2E 16r755B 16r8E23 16r755C 16r8E2F 16r755D 16r8E3A 16r755E 16r8E40 16r755F 16r8E39 16r7560 16r8E35 16r7561 16r8E3D 16r7562 16r8E31 16r7563 16r8E49 16r7564 16r8E41 16r7565 16r8E42 16r7566 16r8E51 16r7567 16r8E52 16r7568 16r8E4A 16r7569 16r8E70 16r756A 16r8E76 16r756B 16r8E7C 16r756C 16r8E6F 16r756D 16r8E74 16r756E 16r8E85 16r756F 16r8E8F 16r7570 16r8E94 16r7571 16r8E90 16r7572 16r8E9C 16r7573 16r8E9E 16r7574 16r8C78 16r7575 16r8C82 16r7576 16r8C8A 16r7577 16r8C85 16r7578 16r8C98 16r7579 16r8C94 16r757A 16r659B 16r757B 16r89D6 16r757C 16r89DE 16r757D 16r89DA 16r757E 16r89DC 16r7621 16r89E5 16r7622 16r89EB 16r7623 16r89EF 16r7624 16r8A3E 16r7625 16r8B26 16r7626 16r9753 16r7627 16r96E9 16r7628 16r96F3 16r7629 16r96EF 16r762A 16r9706 16r762B 16r9701 16r762C 16r9708 16r762D 16r970F 16r762E 16r970E 16r762F 16r972A 16r7630 16r972D 16r7631 16r9730 16r7632 16r973E 16r7633 16r9F80 16r7634 16r9F83 16r7635 16r9F85 16r7636 16r9F86 16r7637 16r9F87 16r7638 16r9F88 16r7639 16r9F89 16r763A 16r9F8A 16r763B 16r9F8C 16r763C 16r9EFE 16r763D 16r9F0B 16r763E 16r9F0D 16r763F 16r96B9 16r7640 16r96BC 16r7641 16r96BD 16r7642 16r96CE 16r7643 16r96D2 16r7644 16r77BF 16r7645 16r96E0 16r7646 16r928E 16r7647 16r92AE 16r7648 16r92C8 16r7649 16r933E 16r764A 16r936A 16r764B 16r93CA 16r764C 16r938F 16r764D 16r943E 16r764E 16r946B 16r764F 16r9C7F 16r7650 16r9C82 16r7651 16r9C85 16r7652 16r9C86 16r7653 16r9C87 16r7654 16r9C88 16r7655 16r7A23 16r7656 16r9C8B 16r7657 16r9C8E 16r7658 16r9C90 16r7659 16r9C91 16r765A 16r9C92 16r765B 16r9C94 16r765C 16r9C95 16r765D 16r9C9A 16r765E 16r9C9B 16r765F 16r9C9E 16r7660 16r9C9F 16r7661 16r9CA0 16r7662 16r9CA1 16r7663 16r9CA2 16r7664 16r9CA3 16r7665 16r9CA5 16r7666 16r9CA6 16r7667 16r9CA7 16r7668 16r9CA8 16r7669 16r9CA9 16r766A 16r9CAB 16r766B 16r9CAD 16r766C 16r9CAE 16r766D 16r9CB0 16r766E 16r9CB1 16r766F 16r9CB2 16r7670 16r9CB3 16r7671 16r9CB4 16r7672 16r9CB5 16r7673 16r9CB6 16r7674 16r9CB7 16r7675 16r9CBA 16r7676 16r9CBB 16r7677 16r9CBC 16r7678 16r9CBD 16r7679 16r9CC4 16r767A 16r9CC5 16r767B 16r9CC6 16r767C 16r9CC7 16r767D 16r9CCA 16r767E 16r9CCB 16r7721 16r9CCC 16r7722 16r9CCD 16r7723 16r9CCE 16r7724 16r9CCF 16r7725 16r9CD0 16r7726 16r9CD3 16r7727 16r9CD4 16r7728 16r9CD5 16r7729 16r9CD7 16r772A 16r9CD8 16r772B 16r9CD9 16r772C 16r9CDC 16r772D 16r9CDD 16r772E 16r9CDF 16r772F 16r9CE2 16r7730 16r977C 16r7731 16r9785 16r7732 16r9791 16r7733 16r9792 16r7734 16r9794 16r7735 16r97AF 16r7736 16r97AB 16r7737 16r97A3 16r7738 16r97B2 16r7739 16r97B4 16r773A 16r9AB1 16r773B 16r9AB0 16r773C 16r9AB7 16r773D 16r9E58 16r773E 16r9AB6 16r773F 16r9ABA 16r7740 16r9ABC 16r7741 16r9AC1 16r7742 16r9AC0 16r7743 16r9AC5 16r7744 16r9AC2 16r7745 16r9ACB 16r7746 16r9ACC 16r7747 16r9AD1 16r7748 16r9B45 16r7749 16r9B43 16r774A 16r9B47 16r774B 16r9B49 16r774C 16r9B48 16r774D 16r9B4D 16r774E 16r9B51 16r774F 16r98E8 16r7750 16r990D 16r7751 16r992E 16r7752 16r9955 16r7753 16r9954 16r7754 16r9ADF 16r7755 16r9AE1 16r7756 16r9AE6 16r7757 16r9AEF 16r7758 16r9AEB 16r7759 16r9AFB 16r775A 16r9AED 16r775B 16r9AF9 16r775C 16r9B08 16r775D 16r9B0F 16r775E 16r9B13 16r775F 16r9B1F 16r7760 16r9B23 16r7761 16r9EBD 16r7762 16r9EBE 16r7763 16r7E3B 16r7764 16r9E82 16r7765 16r9E87 16r7766 16r9E88 16r7767 16r9E8B 16r7768 16r9E92 16r7769 16r93D6 16r776A 16r9E9D 16r776B 16r9E9F 16r776C 16r9EDB 16r776D 16r9EDC 16r776E 16r9EDD 16r776F 16r9EE0 16r7770 16r9EDF 16r7771 16r9EE2 16r7772 16r9EE9 16r7773 16r9EE7 16r7774 16r9EE5 16r7775 16r9EEA 16r7776 16r9EEF 16r7777 16r9F22 16r7778 16r9F2C 16r7779 16r9F2F 16r777A 16r9F39 16r777B 16r9F37 16r777C 16r9F3D 16r777D 16r9F3E 16r777E 16r9F44).
	table size even ifFalse: [^ self error: 'given table size must be even'].
	size := table size / 2.
	gb2312 := Array new: size.
	unicode := Array new: size.
	1 to: table size by: 2 do: [:index |
		| tableIndex |
		tableIndex := index + 1 / 2.
		gb2312 at: tableIndex put: (table at: index).
		unicode at: tableIndex put: (table at: index + 1)].
	gb2312Table := Array new: 94*94 withAll: -1.
	gb2312 withIndexDo: [:elem :index | | uIndex code u |
		code := (elem // 256 - 33) * 94 + (elem \\ 256 - 33) + 1.
		(gb2312Table at: code) ~= -1 ifTrue: [self error].
		uIndex := gb2312 indexOf: elem.
		uIndex = 0 ifFalse: [
			u := unicode at: uIndex.
			gb2312Table at: code put: u.
		] ].
	ucsTable := gb2312Table.! !

!GB2312 class methodsFor: 'class methods' stamp: ''!
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)! !

!GCircle commentStamp: ''!
I am a circle. I have a center in (cx, cy) and radius. My equation is: 
(x-cx)^2  + (y-cy)^2 = radius^2 or 
a * (x^2) + a * (y^2) + d * x + e * y + f = 0 
!
!GCircle methodsFor: 'comparing' stamp: ''!
boundaryContains: aPoint
	^ self radius =~ (self center distanceTo: aPoint)! !

!GCircle methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: ('x² + y² = {1}²' format: {self radius})! !

!GCircle methodsFor: 'accessing' stamp: ''!
radius
	^ self semiMajorAxisLength! !

!GCircle methodsFor: 'accessing' stamp: ''!
perimeter
	^ 2π * self radius! !

!GCircle methodsFor: 'public interface' stamp: ''!
upperPoint
	^ center x , ( center y + self radius )! !

!GCircle class methodsFor: 'instance creation' stamp: ''!
center: aPoint1 radius: aNumber
	^ self center: aPoint1 vertex: aPoint1 x , (aPoint1 y + aNumber) coVertex: aPoint1 x + aNumber , aPoint1 y! !

!GCircleTest methodsFor: 'tests' stamp: ''!
testUpperPoint
	circle := GCircle center: 1 , 1 radius: 3.
	self assert: circle upperPoint equals: 1 , 4! !

!GCircleTest methodsFor: 'tests' stamp: ''!
testBoundaryContains
	circle := GCircle center: 609 / 17 , (10837 / 136) radius: 38.27069133568686.
	self assert: (circle boundaryContains: 5 , 57).
	self assert: (circle boundaryContains: 74 , 77).
	self deny: (circle boundaryContains: 74 , 72).

	circle := GCircle center: 2 , 2 radius: 3.
	self assert: (circle boundaryContains: 5 , 2)! !

!GCircleTest methodsFor: 'tests' stamp: ''!
testIncludes
	circle := GCircle center: 2 , 2 radius: 3.
	self assert: (circle includes: 2 , 2).
	self deny: (circle includes: 6 , 2).

	circle := GCircle center: 30 , 30 radius: 20.
	self assert: (circle includes: 50 , 30).
	self assert: (circle includes: 10 , 30).
	self assert: (circle includes: 30 , 10).
	self assert: (circle includes: 30 , 30).

	circle := GCircle center: 0 , 0 radius: 31.62277660168381.
	self assert: (circle includes: -30 , -10).
	self assert: (circle includes: 10 , -30).
	self assert: (circle includes: 30 , 10).
	self deny: (circle includes: 30 , 30).
	self assert: (circle includes: 10 , 10).

	circle := GCircle center: 0 , 0 radius: 31.61277660168381.
	self deny: (circle includes: 30 , 10)! !

!GCircleTest methodsFor: 'tests' stamp: ''!
testBoundaryContainsWhichOf
	circle := GCircle center: 2 , 2 radius: 3.
	self assert: (circle boundaryContainsWhichOf: {(2 , 2) . (5 , 2)}) equals: {(5 , 2)}! !

!GCircleTest methodsFor: 'tests' stamp: ''!
testEquals
	circle := GCircle center: 1 , 1 radius: 3.
	self assert: circle equals: (GCircle center: 1 , 1 radius: 3).
	self assert: circle hash equals: (GCircle center: 1 , 1 radius: 3) hash.
	self deny: circle = (GCircle center: 1.002 , 1.009 radius: 3).
	self deny: circle hash = (GCircle center: 1.002 , 1.009 radius: 3) hash.
	self assert: circle equals: (GCircle center: 1 , 1 radius: 2.999999999).
	self assert: circle equals: (GCircle center: 1.00000001 , 0.9999991 radius: 2.999999999).
	self deny: circle = (GCircle center: 1 , 1 radius: 34).
	circle := GCircle center: 1.4 , 1 radius: 3.
	self deny: circle = (GCircle center: 1 , 1 radius: 34)! !

!GCircleTest methodsFor: 'tests' stamp: ''!
testEncompassingRectangle
	circle := GCircle center: 2 , 2 radius: 3.
	self assert: circle encompassingRectangle equals: (GRectangle origin: -1 , -1 corner: 5 , 5)! !

!GCircleTest methodsFor: 'tests' stamp: ''!
testContains
	circle := GCircle center: 2 , 2 radius: 3.
	self assert: (circle contains: 2 , 2).
	self deny: (circle contains: 6 , 2).

	circle := GCircle center: 30 , 30 radius: 20.
	self deny: (circle contains: 50 , 30).
	self deny: (circle contains: 10 , 30).
	self deny: (circle contains: 30 , 10).
	self assert: (circle contains: 30 , 30).

	circle := GCircle center: 0 , 0 radius: 31.62277660168381.
	self deny: (circle contains: -30 , -10).
	self deny: (circle contains: 10 , -30).
	self deny: (circle contains: 30 , 10).
	self deny: (circle contains: 30 , 30).
	self assert: (circle contains: 10 , 10)! !

!GCircleTest methodsFor: 'tests' stamp: ''!
testTranslateBy
	circle := GCircle center: 3,4 radius: 2.
	circle translateBy: #(1 -2) asGVector.
	self assert: circle center equals: 4, 2.
	self assert: circle radius equals: 2! !

!GCircleTest methodsFor: 'tests' stamp: ''!
testBoundaryContainsAny
	circle := GCircle center: 2 , 2 radius: 3.
	self assert: (circle boundaryContainsAny: {(2 , 2) . (5 , 2)})! !

!GCircleTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GCircle! !

!GCircleTest methodsFor: 'tests' stamp: ''!
testPerimeter
	circle := GCircle center: (609 / 17) , (10837 / 136) radius: 38.27069133568686.
	self assert: circle perimeter equals: 240.46184549599278! !

!GCoordinates commentStamp: ''!
Description
--------------------

I represent a set of coordinates that will be used by other geometric elements.

My subclass will represent sets of a certain amount of coordinates. In the long terme we would like to remove all the subclasses and that everything manage myself as a n-dimensions coordinates set, but for now we prefer to begin with simple sets like 2D or 3D.

I implement basic arithmetic that can be done with coordinates.

Examples
--------------------
	
	"Instance creation"
	GCoordinates withCollection: #(1 3). 	"(1,3)"
	
	#(1 3) asGCoordinates.	"(1,3)"
	
	"Arithmetic"		
	(GCoordinates withCollection: #(1 3)) + (GCoordinates withCollection: #(5 1)). 	"(6,4)"
		
	(GCoordinates withCollection: #(1 3)) - (GCoordinates withCollection: #(5 1)). 	"(-4,2)"
		
	(GCoordinates withCollection: #(1 3)) * 2. 	"(2,6)"
		
	(GCoordinates withCollection: #(1 3)) / 2. 	"((1/2),(3/2))"
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	coordinates:		<aCollection> 	A collection of all the coordinates I contains.
!
!GCoordinates methodsFor: 'enumerating' stamp: ''!
coordinatesCollect: aBlock
	^ coordinates collect: aBlock! !

!GCoordinates methodsFor: 'printing' stamp: ''!
printCoordinatesOn: aStream
	aStream << $(.
	coordinates do: [ :number | aStream << number asString ] separatedBy: [ aStream << $, ].
	aStream << $)! !

!GCoordinates methodsFor: 'comparing' stamp: ''!
= otherCoordinates
	"Answer whether the receiver and anObject represent the same object."

	self == otherCoordinates ifTrue: [ ^ true ].
	self class = otherCoordinates class ifFalse: [ ^ false ].

	otherCoordinates coordinatesWith: coordinates do: [ :number2 :number1 | number1 = number2 ifFalse: [ ^ false ] ].

	^ true! !

!GCoordinates methodsFor: 'arithmetic' stamp: ''!
* aNumber
	"Answer a Point that is the multiplication of the receiver and arg."

	aNumber isNumber ifFalse: [ self error: 'Coordinates can only be multiplicated by a number.' ].

	^ self class newWithCoordinates: (self coordinatesCollect: [ :number | number * aNumber ])! !

!GCoordinates methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."
	
	^ coordinates hash negated "We negate to not have a collision with Array"! !

!GCoordinates methodsFor: 'enumerating' stamp: ''!
fold: aBlock
	^ self coordinates fold: aBlock! !

!GCoordinates methodsFor: 'accessing' stamp: ''!
numberOfDimensions
	^ self class numberOfDimensions! !

!GCoordinates methodsFor: 'arithmetic' stamp: ''!
/ aNumber
	"Answer a Point that is the division of the receiver and arg."

	aNumber isNumber ifFalse: [ self error: 'Coordinates can only be divided by a number.' ].

	^ self class newWithCoordinates: (self coordinatesCollect: [ :number | number / aNumber ])! !

!GCoordinates methodsFor: 'accessing' stamp: ''!
y: aNumber
	"Might return an error for 1D coordinates, but do they make sense?"

	coordinates at: 2 put: aNumber! !

!GCoordinates methodsFor: 'enumerating' stamp: ''!
coordinatesWith: aCollection do: aBlock
	coordinates with: aCollection do: aBlock! !

!GCoordinates methodsFor: 'accessing' stamp: ''!
x
	^ coordinates at: 1! !

!GCoordinates methodsFor: 'printing' stamp: ''!
printOn: aStream
	self printCoordinatesOn: aStream! !

!GCoordinates methodsFor: 'accessing' stamp: ''!
x: aNumber
	coordinates at: 1 put: aNumber! !

!GCoordinates methodsFor: 'accessing' stamp: ''!
at: anInteger
	^ self coordinates at: anInteger! !

!GCoordinates methodsFor: 'accessing' stamp: ''!
y
	"Might return an error for 1D coordinates, but do they make sense?"

	^ coordinates at: 2! !

!GCoordinates methodsFor: 'accessing' stamp: ''!
lowerLimitsWith: otherCoordinates
	^ self class newWithCoordinates: (self coordinatesWith: otherCoordinates coordinates collect: [ :number1 :number2 | number1 min: number2 ])! !

!GCoordinates methodsFor: 'converting' stamp: ''!
asGPoint
	^ GPoint coordinates: self! !

!GCoordinates methodsFor: 'arithmetic' stamp: ''!
- otherCoordinates 
	"Answer a Point that is the substraction of the receiver and arg."
	self numberOfDimensions = otherCoordinates numberOfDimensions ifFalse: [ self error: 'For now we accept only substraction of coordinates from the same dimension. We will see later if we should do more.' ].

	^ self class newWithCoordinates: (otherCoordinates coordinatesWith: coordinates collect: [ :number2 :number1 | number1 - number2 ])! !

!GCoordinates methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	coordinates := Array new: self numberOfDimensions! !

!GCoordinates methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	coordinates := coordinates copy! !

!GCoordinates methodsFor: 'converting' stamp: ''!
asGVector
	^ GVector coordinates: self! !

!GCoordinates methodsFor: 'private' stamp: ''!
initializeWith: anArray
	anArray size = self numberOfDimensions ifFalse: [ self error: 'The provided array must have the same size than my number of dimensions which is ' , self numberOfDimensions size asString ].

	coordinates := anArray! !

!GCoordinates methodsFor: 'accessing' stamp: ''!
coordinates
	^ coordinates! !

!GCoordinates methodsFor: 'enumerating' stamp: ''!
inject: aSeed into: aBlock
	^ self coordinates inject: aSeed into: aBlock! !

!GCoordinates methodsFor: 'enumerating' stamp: ''!
coordinatesWith: aCollection collect: aBlock
	^ coordinates with: aCollection collect: aBlock! !

!GCoordinates methodsFor: 'arithmetic' stamp: ''!
+ otherCoordinates 
	"Answer a Point that is the sum of the receiver and arg."
	self numberOfDimensions = otherCoordinates numberOfDimensions ifFalse: [ self error: 'For now we accept only addition of coordinates from the same dimension. We will see later if we should do more.' ].

	^ self class newWithCoordinates: (otherCoordinates coordinatesWith: coordinates collect: [ :number1 :number2 | number1 + number2 ])! !

!GCoordinates methodsFor: 'accessing' stamp: ''!
upperLimitsWith: otherCoordinates
	^ self class newWithCoordinates: (self coordinatesWith: otherCoordinates coordinates collect: [ :number1 :number2 | number1 max: number2 ])! !

!GCoordinates class methodsFor: 'accessing' stamp: ''!
numberOfDimensions
	^ self subclassResponsibility! !

!GCoordinates class methodsFor: 'instance creation' stamp: ''!
withCollection: aCollection
	^ self allSubclasses
		detect: [ :e | e numberOfDimensions = aCollection size ]
		ifFound: [ :class | 
			class basicNew
				initializeWith: aCollection asArray;
				yourself ]
		ifNone: [ self error: 'This amount of coordinated is not yet managed.' ]! !

!GCoordinates class methodsFor: 'instance creation' stamp: ''!
newWithCoordinates: aCollection
	^ self basicNew
		initializeWith: aCollection;
		yourself! !

!GCoordinatesTest methodsFor: 'tests' stamp: ''!
testDivision
	| coordinates2 |
	coordinates := G2DCoordinates x: 2 y: 8.
	coordinates2 := coordinates / 2.
	self assert: coordinates2 x equals: 1.
	self assert: coordinates2 y equals: 4! !

!GCoordinatesTest methodsFor: 'tests' stamp: ''!
testUpperLimitsWith
	| coordinates2 coordinates3 |
	coordinates := G2DCoordinates x: 1 y: 8.
	coordinates2 := G2DCoordinates x: 4 y: 6.
	coordinates3 := coordinates upperLimitsWith: coordinates2.
	self assert: coordinates3 x equals: 4.
	self assert: coordinates3 y equals: 8! !

!GCoordinatesTest methodsFor: 'tests' stamp: ''!
testMultiplication
	| coordinates2 |
	coordinates := G2DCoordinates x: 2 y: 8.
	coordinates2 := coordinates * 2.
	self assert: coordinates2 x equals: 4.
	self assert: coordinates2 y equals: 16! !

!GCoordinatesTest methodsFor: 'tests' stamp: ''!
testEquals
	self flag: #pharo6. "Use #deny:equals: when Pharo 7 will be the minimum requirement"
	self assert: (G2DCoordinates x: 1 y: 2) equals: (G2DCoordinates x: 1 y: 2).
	self deny: (G2DCoordinates x: 2 y: 4) = (G2DCoordinates x: 1 y: 2).
	self assert: (G2DCoordinates x: 1 y: 2) hash equals: (G2DCoordinates x: 1 y: 2) hash.
	self deny: (G2DCoordinates x: 2 y: 4) hash = (G2DCoordinates x: 1 y: 2) hash! !

!GCoordinatesTest methodsFor: 'accessing' stamp: ''!
newInstance
	^ self actualClass withCollection: #(1 2)! !

!GCoordinatesTest methodsFor: 'tests' stamp: ''!
test3DCoordinates
	coordinates := G3DCoordinates x: 1 y: 2 z: 3.
	self assert: coordinates x equals: 1.
	self assert: coordinates y equals: 2.
	self assert: coordinates z equals: 3! !

!GCoordinatesTest methodsFor: 'tests' stamp: ''!
testSubstraction
	| coordinates2 coordinates3 |
	coordinates := G2DCoordinates x: 1 y: 2.
	coordinates2 := G2DCoordinates x: 4 y: 8.
	coordinates3 := coordinates - coordinates2.
	self assert: coordinates3 x equals: -3.
	self assert: coordinates3 y equals: -6! !

!GCoordinatesTest methodsFor: 'tests' stamp: ''!
testAddition
	| coordinates2 coordinates3 |
	coordinates := G2DCoordinates x: 1 y: 2.
	coordinates2 := G2DCoordinates x: 4 y: 8.
	coordinates3 := coordinates + coordinates2.
	self assert: coordinates3 x equals: 5.
	self assert: coordinates3 y equals: 10! !

!GCoordinatesTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GCoordinates! !

!GCoordinatesTest methodsFor: 'tests' stamp: ''!
test2DCoordinates
	coordinates := G2DCoordinates x: 1 y: 2.
	self assert: coordinates x equals: 1.
	self assert: coordinates y equals: 2.
	
	coordinates := G2DCoordinates x: -1 y: -2.
	self assert: coordinates x equals: -1.
	self assert: coordinates y equals: -2! !

!GCoordinatesTest methodsFor: 'tests' stamp: ''!
testCoordinates
	coordinates := GCoordinates withCollection: #(1 2).
	self assert: coordinates x equals: 1.
	self assert: coordinates y equals: 2.
	self should: [ coordinates z ] raise: MessageNotUnderstood.
	
	coordinates := GCoordinates withCollection: #(1 2 3).
	self assert: coordinates x equals: 1.
	self assert: coordinates y equals: 2.
	self assert: coordinates z equals: 3! !

!GCoordinatesTest methodsFor: 'tests' stamp: ''!
testLowerLimitsWith
	| coordinates2 coordinates3 |
	coordinates := G2DCoordinates x: 1 y: 8.
	coordinates2 := G2DCoordinates x: 4 y: 6.
	coordinates3 := coordinates lowerLimitsWith: coordinates2.
	self assert: coordinates3 x equals: 1.
	self assert: coordinates3 y equals: 6! !

!GElement commentStamp: ''!
Description
--------------------

I am a common super class for all geometric elements. I define the common API all elements should be able to answer to.


Public API and Key Messages
--------------------

- #includes: 	This methods takes a point as parameter and answer true of the element includes the point. (Boundaries included) Note: In the future I should be able to take more elements than the point as parameter using double dispatch as #intersectionsWith:.
- #contains: 	This methods takes a point as parameter and answer true of the element includes the point. (Boundaries excluded) Note: In the future I should be able to take more elements than the point as parameter using double dispatch as #intersectionsWith:.
- #boundaryContains: 		This methods takes a point as parameter and answer true of the boundaries of the element includes the point.
- #intersectionsWith: 	Takes as parameter any GElement and returns a collection of intersections points with this element.
- #translateBy: 			Takes a vector as parameter and translate the element by this vector.
!
!GElement methodsFor: 'testing' stamp: ''!
contains: aPoint
	"Return true if the element includes the argument but not in its boundaries.
	
	Will always be false for 1D elements."

	self flag: #todo. "Maybe later we could use double dispatch to be able to do something like `aPolygon contains: aCricle` like with intersections"
	^ (self includes: aPoint) and: [ (self boundaryContains: aPoint) not ]! !

!GElement methodsFor: 'testing' stamp: ''!
boundaryContainsWhichOf: points
	^ points select: [ :point | self boundaryContains: point ]! !

!GElement methodsFor: 'testing' stamp: ''!
includes: aPoint
	"I should return true if the points is contained in the element including the boundaries. Else I will answer false."

	self flag: #todo. "Maybe later we could use double dispatch to be able to do something like `aPolygon includes: aCricle` like with intersections"
	^ self subclassResponsibility! !

!GElement methodsFor: 'intersections' stamp: ''!
intersectionsWithRay: aGRay
	^ (aGRay asGLine intersectionsWith: self) select: [ :point | aGRay includes: point ]! !

!GElement methodsFor: 'intersections' stamp: ''!
intersectionsWithPoint: aPoint
	^ (self boundaryContains: aPoint) ifTrue: [ {aPoint} ] ifFalse: [ {} ]! !

!GElement methodsFor: 'intersections' stamp: ''!
intersectionsWith: anElement
	"We should use double dispatch to find intersection points"

	^ self subclassResponsibility! !

!GElement methodsFor: 'testing' stamp: ''!
boundaryContains: aPoint
	"Should return true if the boundaries of the element contains the point. Else it should return false.
	
	For 1D elements it is equivalent to #includes:"

	^ self subclassResponsibility! !

!GElement methodsFor: 'intersections' stamp: ''!
intersectionsWithPolygon: aGPolygon
	^ (aGPolygon edges flatCollect: [ :segment | segment intersectionsWith: self ]) asSet! !

!GElement methodsFor: 'intersections' stamp: ''!
intersectionsWithLine: aGLine
	"I should return the intersection points between me and a line"
	
	^ self subclassResponsibility! !

!GElement methodsFor: 'transforming' stamp: ''!
translateBy: aPoint
	"Translate the shape by a delta defined by a point."
	
	self subclassResponsibility! !

!GElement methodsFor: 'intersections' stamp: ''!
intersectionsWithEllipse: aGEllipse
	"I should return the intersection points between me and an ellipse"
	
	^ self subclassResponsibility! !

!GElement methodsFor: 'intersections' stamp: ''!
intersectionsWithSegment: aGSegment
	^ (aGSegment asGLine intersectionsWith: self) select: [ :point | aGSegment includes: point ]! !

!GElement methodsFor: 'intersections' stamp: ''!
intersectionsWithArc: anArc
	^ (self intersectionsWithEllipse: (GCircle center: anArc center radius: anArc radius)) select: [ :point | anArc includes: point ]! !

!GElement methodsFor: 'testing' stamp: ''!
boundaryContainsAny: points
	^ points anySatisfy: [ :point | self boundaryContains: point ]! !

!GElement class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = GElement! !

!GElementTestCase methodsFor: 'accessing' stamp: ''!
testIntersectionsWithPolygon
	^ self subclassResponsibility! !

!GElementTestCase methodsFor: 'accessing' stamp: ''!
testIncludes
	^ self subclassResponsibility! !

!GElementTestCase methodsFor: 'accessing' stamp: ''!
testTranslateBy
	^ self subclassResponsibility! !

!GElementTestCase methodsFor: 'accessing' stamp: ''!
testIntersectionsWithEllipse
	^ self subclassResponsibility! !

!GElementTestCase methodsFor: 'accessing' stamp: ''!
testIntersectionsWithPoint
	^ self subclassResponsibility! !

!GElementTestCase methodsFor: 'accessing' stamp: ''!
testIntersectionsWithSegment
	^ self subclassResponsibility! !

!GElementTestCase methodsFor: 'accessing' stamp: ''!
testIntersectionsWithLine
	^ self subclassResponsibility! !

!GElementTestCase methodsFor: 'accessing' stamp: ''!
testIntersectionsWithRay
	^ self subclassResponsibility! !

!GElementTestCase methodsFor: 'accessing' stamp: ''!
testIntersectionsWithArc
	^ self subclassResponsibility! !

!GElementTestCase class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = GElementTestCase! !

!GEllipse commentStamp: ''!
I am ellipse I have center and 2 vertices.

Example

```Smalltalk
"circle radius = 10"
GEllipse center: 0@0 vertex: 0@10 coVertex: 10@0
``` !
!GEllipse methodsFor: 'accessing' stamp: ''!
coVertex
	^ coVertex! !

!GEllipse methodsFor: 'accessing' stamp: ''!
center
	^ center! !

!GEllipse methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].
	
	^ vertex =~ anObject vertex and: [ center =~ anObject center and: [ coVertex =~ anObject coVertex ] ]! !

!GEllipse methodsFor: 'testing' stamp: ''!
includes: aPoint
	"Solution from: https://math.stackexchange.com/questions/76457/check-if-a-point-is-within-an-ellipse"

	^ (aPoint x - center x) squared / self semiMajorAxisLength squared + ((aPoint y - center y) squared / self semiMinorAxisLength squared) <= 1! !

!GEllipse methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ vertex hash bitXor: (center hash bitXor: coVertex hash)! !

!GEllipse methodsFor: 'accessing' stamp: ''!
minorAxisLength
	^ self minorAxis length! !

!GEllipse methodsFor: 'transforming' stamp: ''!
translateBy: aGVector 
	center translateBy: aGVector.
	vertex translateBy: aGVector.
	coVertex translateBy: aGVector! !

!GEllipse methodsFor: 'testing' stamp: ''!
boundaryContains: aPoint
	"Solution from: https://math.stackexchange.com/questions/76457/check-if-a-point-is-within-an-ellipse"

	^ (aPoint x - center x) squared / self semiMajorAxisLength squared + ((aPoint y - center y) squared / self semiMinorAxisLength squared) = 1! !

!GEllipse methodsFor: 'accessing' stamp: ''!
vertex
	^ vertex! !

!GEllipse methodsFor: 'accessing' stamp: ''!
area
	"pi * a * b"

	^ (self semiMajorAxisLength * self semiMinorAxisLength)π! !

!GEllipse methodsFor: 'accessing' stamp: ''!
foci
	^ self majorAxis asGLine intersectionsWith: (GCircle center: center radius: self fociLocation)! !

!GEllipse methodsFor: 'intersections' stamp: ''!
intersectionsWithLine: aGLine
	"
	http://www.ambrsoft.com/TrigoCalc/Circles2/Ellipse/EllipseLine.htm
	
	Ellipse: ((x-h)²/a²) + ((y - k)²/b²) = 1
	Line: y = mx + c
	"

	| h k a b m c e t a2m2 ab a2 b2 m2 k2 t2 tk sqrt abm x1 x2 y1 y2 sqrtContent |
	
	"If b = 0 this is a vertical line"
	aGLine b = 0 ifTrue: [ ^ self intersectionsWithVerticalLine: aGLine ].
	
	h := center x.
	k := center y.
	a := self semiMajorAxisLength.
	b := self semiMinorAxisLength.
	
	m := aGLine a / aGLine b negated.
	c := aGLine c / aGLine b negated.
	e := c - k.
	t := c + (m * h).
	ab := a * b.
	abm := ab * m.
	a2 := a squared.
	b2 := b squared.
	m2 := m squared.
	k2 := k squared.
	t2 := t squared.
	a2m2 := a2 * m2.
	tk := t * k.
	sqrtContent := (a2m2 + b2 - t2 - k2 + (2 * tk)).
	sqrtContent >= 0 ifFalse: [ ^ {  } ]. "No intersections"
	
	sqrt := (a2m2 + b2 - t2 - k2 + (2 * tk)) sqrt.
	x1 := (h * b2 - (m * a2 * e) + (ab * sqrt)) / (a2m2 + b2).
	x2 := (h * b2 - (m * a2 * e) - (ab * sqrt)) / (a2m2 + b2).
	y1 := (b2 * t + (k * a2m2) + (abm * sqrt)) / (a2m2 + b2).
	y2 := (b2 * t + (k * a2m2) - (abm * sqrt)) / (a2m2 + b2).

	^ {(x1 , y1) . (x2 , y2)} asSet! !

!GEllipse methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: ('((x - {1})²/{2}) + ((y - {3})²/{4}) = 1' format: {center x . self semiMajorAxisLength squared . center y . self semiMinorAxisLength squared})! !

!GEllipse methodsFor: 'accessing' stamp: ''!
perimeter
	"The perimeter of an ellipse cannot be calculated easily. This method will give an approximation with Ramanujan II"

	| h semiMajorAndMinorLength |
	semiMajorAndMinorLength := self semiMajorAxisLength + self semiMinorAxisLength.
	h := (self semiMajorAxisLength - self semiMinorAxisLength) squared / semiMajorAndMinorLength squared.

	^ (semiMajorAndMinorLength * (1 + (3 * h / (10 + (4 - (3 * h)) squared))))π! !

!GEllipse methodsFor: '*Roassal3-Shapes' stamp: ''!
rsScaleWith: anAthensAffineTransform
	| m |
	m := anAthensAffineTransform.
	^ self class 
		center: (m transform: center)
		vertex: (m transform: coVertex)
		coVertex: (m transform: vertex)! !

!GEllipse methodsFor: 'accessing' stamp: ''!
majorAxisLength
	^ self majorAxis length! !

!GEllipse methodsFor: 'accessing' stamp: ''!
minorAxis
	^ GSegment with: center + (center - coVertex) with: center + (coVertex - center)! !

!GEllipse methodsFor: 'accessing' stamp: ''!
center: anObject
	center := anObject! !

!GEllipse methodsFor: 'intersections' stamp: ''!
intersectionsWithVerticalLine: aGLine
	"
	Ellipse: ((x-h)²/a²) + ((y - k)²/b²) = 1
	Line: x = -c/a 
	"

	| h k a2 b2 x sqrt y1 y2 tmp tmp2 |
	h := center x.
	k := center y.
	a2 := self semiMajorAxisLength squared.
	b2 := self semiMinorAxisLength squared.
	x := aGLine c negated / aGLine a.
	tmp := (x - h) squared / a2.
	tmp2 := (b2 * (1 - tmp)).
	
	"I am not sure this is correct but I have the impression that if this is negative, there is no intersection."
	tmp2 < 0 ifTrue: [ ^ {  } ].
	
	sqrt := tmp2 sqrt.

	y1 := k + sqrt.
	y2 := k - sqrt.

	^ {(x , y1) . (x , y2)} asSet! !

!GEllipse methodsFor: 'accessing' stamp: ''!
coVertex: anObject
	coVertex := anObject! !

!GEllipse methodsFor: 'intersections' stamp: ''!
intersectionsWith: anElement
	^ anElement intersectionsWithEllipse: self! !

!GEllipse methodsFor: 'accessing' stamp: ''!
semiMinorAxisLength
	^ self minorAxis length / 2! !

!GEllipse methodsFor: 'intersections' stamp: ''!
intersectionsWithEllipse: aGEllipse
	"And also tested"

	self shouldBeImplemented! !

!GEllipse methodsFor: 'accessing' stamp: ''!
majorAxis
	^ GSegment with: center + (center - vertex) with: center + (vertex - center)! !

!GEllipse methodsFor: 'accessing' stamp: ''!
encompassingRectangle
	| radiuxPoints |
	radiuxPoints := { vertex . (center + (center - vertex)). coVertex . (center + (center - coVertex)) } collect: #coordinates.
	^ GRectangle origin: (radiuxPoints fold: [ :pt1 :pt2 | pt1 upperLimitsWith: pt2 ]) asGPoint corner: (radiuxPoints fold: [ :pt1 :pt2 | pt1 lowerLimitsWith: pt2 ]) asGPoint! !

!GEllipse methodsFor: 'accessing' stamp: ''!
vertex: anObject
	vertex := anObject! !

!GEllipse methodsFor: 'transforming' stamp: ''!
fitInExtent: extent
	| scales |
	scales := extent coordinatesWith: self encompassingRectangle extent coordinates collect: [ :number1 :number2 | number1 / number2 ].
	vertex := ((vertex - center) coordinates coordinatesWith: scales collect: [ :a :b | a * b ]) asGVector + center.
	coVertex := ((coVertex - center) coordinates coordinatesWith: scales collect: [ :a :b | a * b ]) asGVector + center! !

!GEllipse methodsFor: 'accessing' stamp: ''!
fociLocation
	"c² = a² - b²"

	^ (self semiMajorAxisLength squared - self semiMinorAxisLength squared) sqrt! !

!GEllipse methodsFor: 'accessing' stamp: ''!
semiMajorAxisLength
	^ self majorAxis length / 2! !

!GEllipse class methodsFor: 'instance creation' stamp: ''!
center: aGPoint vertex: aGPoint2 coVertex: aGPoint3
	| d1 d2 zero |
	d1 := aGPoint - aGPoint2.
	d2 := aGPoint - aGPoint3.
	zero := GVector x: 0 y: 0."Zero vector"
	(d1 = zero and: [ d2 = zero ]) ifTrue: [ 
		self error: 'This is not an ellipse but a point.'  ].
	(d1 = zero or: [ d2 = zero ]) ifTrue: [ 
		self error: 'This is not an ellipse but a line.' ].
	^ self new
		center: aGPoint;
		vertex: aGPoint2;
		coVertex: aGPoint3;
		yourself! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithArc
	"Because we need the intersection between two ellipse to do that. Until we have that, we declare the test as expected failure"
	<expectedFailure>
	| arc |
	ellipse := GEllipse center: -4 , 3 vertex: 1 , 3 coVertex: -4 , 7.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (ellipse intersectionsWith: arc) isEmpty.

	arc := GArc center: 1 , 0 origin: 4 , 0 direction: -1 , 2.
	self assert: (ellipse intersectionsWith: arc) hasCloseElementsTo: {(1 , 3)}.
	self assertCollection: (ellipse intersectionsWith: arc) hasSameElements: (ellipse intersectionsWithArc: arc)! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testBoundaryContains
	ellipse := (GEllipse center: 4 , 1 vertex: 6 , 1 coVertex: 4 , 2).
	self deny: (ellipse boundaryContains: 4, 1).
	self assert: (ellipse boundaryContains: 6, 1).
	self assert: (ellipse boundaryContains: 4, 2).
	self deny: (ellipse boundaryContains: 3, 1).
	self deny: (ellipse boundaryContains: 2.1, 0.1).
	self deny: (ellipse boundaryContains: 3, 0.13).! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testIncludes
	ellipse := (GEllipse center: 4 , 1 vertex: 6 , 1 coVertex: 4 , 2).
	self assert: (ellipse includes: 4, 1).
	self assert: (ellipse includes: 6, 1).
	self assert: (ellipse includes: 4, 2).
	self assert: (ellipse includes: 3, 1).
	self deny: (ellipse includes: 2.1, 0.1).
	self deny: (ellipse includes: 3, 0.13).
	self assert: (ellipse includes: 3, 0.15).! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPolygon
	| polygon |
	polygon := GPolygon vertices: {(5 , 1) . (9 , 1) . (8 , 0) . (6 , -1)}.
	ellipse := GEllipse center: 2,6 vertex: 7, 6 coVertex: 2,9 .
	self assert: (ellipse intersectionsWith: polygon) isEmpty.

	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (ellipse intersectionsWith: polygon) hasCloseElementsTo: {(2 , 3) . (5.7267799 , 4)}.
	self assertCollection: (ellipse intersectionsWith: polygon) hasSameElements: (ellipse intersectionsWithPolygon: polygon)! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testNonEmpty
	| shape line intersections |
	shape := GEllipse center: 0@0 vertex: 0@10 coVertex: 5@10.
	line := GLine through: shape center and: 10@10.
	intersections := self sortedIntersectionsBetween: shape and: line.
	self assert: intersections isNotEmpty.
	self assert: (intersections first asPoint closeTo: -7.4535599249993@ -7.4535599249993).
	self assert: (intersections second asPoint closeTo: 7.4535599249993@ 7.4535599249993).! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testEquals
	ellipse := GEllipse center: 10 , 10 vertex: 7 , 10 coVertex: 12 , 10.
	self assert: ellipse equals: (GEllipse center: 10 , 10 vertex: 7 , 10 coVertex: 12 , 10).
	self assert: ellipse hash equals: (GEllipse center: 10 , 10 vertex: 7 , 10 coVertex: 12 , 10) hash.
	self deny: ellipse = (GEllipse center: 10 , 10 vertex: 7 , 11 coVertex: 12 , 10).
	self deny: ellipse hash = (GEllipse center: 10 , 10 vertex: 7 , 11 coVertex: 12 , 10) hash! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testEncompassingRectangle
	ellipse := GEllipse center: 4 , -1 vertex: 9 , -1 coVertex: 4 , 2.
	self assert: ellipse encompassingRectangle equals: (GRectangle origin: -1 , 2 corner: 9 , -4)! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testTranslateBy
	ellipse := GEllipse center: 4 , -1 vertex: 9 , -1 coVertex: 4 , 2.
	ellipse translateBy: {1 . 1} asGVector.
	self assert: ellipse center equals: 5 , 0.
	self assert: ellipse vertex equals: 10 , 0.
	self assert: ellipse coVertex equals: 5 , 3! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testEmpty
	self should: [ GEllipse center: 0,0 vertex: 0,0 coVertex: 0,0. ] raise: Error.
	self should: [ GEllipse center: 10,10 vertex: 10,10 coVertex: 10,10. ] raise: Error.
	self should: [ GEllipse center: 0,0 vertex: 0,0 coVertex: 0,3. ] raise: Error.! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testMajorAxis
	ellipse := GEllipse center: 10 , 10 vertex: 7.1715 , 10 coVertex: 10 , 8.
	self assert: (ellipse) majorAxis equals: (GSegment with: 7.1715 , 10 with: 12.8285 , 10)! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithVerticalLine
	| line |
	ellipse := GEllipse center: 3.5 , 2 vertex: 6 , 2 coVertex: 3.5 , 4.
	line := GLine a: 1 b: 0 c: -2.
	self assert: (ellipse intersectionsWithVerticalLine: line) hasCloseElementsTo: {(2 , 0.3999999) . (2 , 3.6)}.
	self assertCollection: (ellipse intersectionsWithLine: line) hasSameElements: (ellipse intersectionsWithVerticalLine: line)! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithEllipse
	self flag: #todo! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testMinorAxis
	ellipse := GEllipse center: 10 , 10 vertex: 7.1715 , 10 coVertex: 10 , 8.
	self assert: ellipse minorAxis equals: (GSegment with: 10 , 8 with: 10 , 12)! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testFoci
	| foci |
	foci := (GEllipse center: 10 , 10 vertex: 7.171575 , 10 coVertex: 10 , 8) foci.
	self assert: foci hasCloseElementsTo: {(8 , 10) . (12 , 10)}! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testArea
	ellipse := GEllipse center: 5 , -1 vertex: 10 , -1 coVertex: 5 , 2.
	self assert: ellipse area =~ 47.123889! !

!GEllipseTest methodsFor: 'util' stamp: ''!
sortedIntersectionsBetween: shape and: line
	^ (shape intersectionsWith: line) asOrderedCollection 
		sorted: [ :a :b | a asPoint < b asPoint ].! !

!GEllipseTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GEllipse! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPoint
	| point |
	point := 2 , 4.
	ellipse := GEllipse center: 1 , 3 vertex: 5 , 6 coVertex: 3 , 4.
	self assert: (ellipse intersectionsWith: point) isEmpty.

	ellipse := GEllipse center: 2 , 1 vertex: 5 , 1 coVertex: 2 , 4.
	self assert: (ellipse intersectionsWith: point) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (ellipse intersectionsWith: point) hasSameElements: (ellipse intersectionsWithPoint: point)! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithSegment
	| segment |
	segment := GSegment with: 0 , -1 with: 1 , 4.
	ellipse := GEllipse center: 3.5 , 2 vertex: 6 , 2 coVertex: 3.5 , 4.
	self assert: (ellipse intersectionsWith: segment) isEmpty.

	segment := GSegment with: 0 , 1 with: 2 , 3.
	self assert: (ellipse intersectionsWith: segment) hasCloseElementsTo: {(1 , 2)}.

	segment := GSegment with: 0 , 1 with: 5 , 6.
	self assert: (ellipse intersectionsWith: segment) hasCloseElementsTo: {(1 , 2) . (2.951219 , 3.951219)}.
	self assertCollection: (ellipse intersectionsWith: segment) hasSameElements: (ellipse intersectionsWithSegment: segment).
	
	segment := GSegment with: -3, 5 with: -3, 0.
	ellipse := GCircle center: 1, 0 radius: 3.
	self assert: (ellipse intersectionsWith: segment) isEmpty! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testFitInExtent
	ellipse := GEllipse center: 10 , 10 vertex: 20 , 10 coVertex: 10 , 15.
	ellipse fitInExtent: #(100 100) asGVector.
	self assert: ellipse center equals: 10 , 10.
	self assert: ellipse vertex equals: 60 , 10.
	self assert: ellipse coVertex equals: 10 , 60.

	ellipse := GEllipse center: 10 , 10 vertex: 20 , 10 coVertex: 10 , 15.
	ellipse fitInExtent: #(100 60) asGVector.
	self assert: ellipse center equals: 10 , 10.
	self assert: ellipse vertex equals: 60 , 10.
	self assert: ellipse coVertex equals: 10 , 40! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithLine
	| line |
	"Test without intersection"
	ellipse := GEllipse center: 2 , 5 vertex: 2 , 9 coVertex: 5 , 5.
	self assert: (ellipse intersectionsWith: (GLine a: -1 b: 1 c: -20)) isEmpty.
	
	"Test with an ellipse centered at the origin and a line going through the origin"
	ellipse := GEllipse center: 0 , 0 vertex: 0 , 3 coVertex: 2 , 0.
	line := GLine a: -1 b: 1 c: 0.
	self assert: (ellipse intersectionsWith: line) hasCloseElementsTo: {(1.6641 , 1.6641) . (-1.6641 , -1.6641)}.

	"Test with an ellipse centered at the origin and a line not going through the origin"
	line := GLine a: -1 b: 1 c: -1.
	self assert: (ellipse intersectionsWith: line) hasCloseElementsTo: {(0.9065084 , 1.9065084) . (-2.291123 , -1.291123)}.

	"Test with an ellipse not centered at the origin and a line not going through the origin"
	ellipse := GEllipse center: 2 , 5 vertex: 2 , 9 coVertex: 5 , 5.
	line := GLine a: -2 b: 1 c: -8.
	self assert: (ellipse intersectionsWith: line) hasCloseElementsTo: {(-0.263181454 , 7.473637091) . (-1.873804847 , 4.252390306)}.
	self assertCollection: (ellipse intersectionsWith: line) hasSameElements: (ellipse intersectionsWithLine: line).
	
	"Test with tangent"
	ellipse := GEllipse center: 2 , 5 vertex: 2 , 9 coVertex: 5 , 5.
	line := GLine a: -1 b: 1 c: -8.
	self assert: (ellipse intersectionsWith: line) hasCloseElementsTo: {(-6 / 5 , (34 / 5))}! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testPerimeter
	ellipse := GEllipse center: 2,6 vertex: 7, 6 coVertex: 2,9.
	self assert: ellipse perimeter =~ 25.32480! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithRay
	| ray |
	ray := GRay origin: 0 , -1 direction: 1 , 4.
	ellipse := GEllipse center: 3.5 , 2 vertex: 6 , 2 coVertex: 3.5 , 4.
	self assert: (ellipse intersectionsWith: ray) isEmpty.

	ray := GRay origin: 2 , 3 direction: 0 , 1.
	self assert: (ellipse intersectionsWith: ray) hasCloseElementsTo: {(1 , 2)}.

	ray := GRay origin: 0 , 1 direction: 5 , 6.
	self assert: (ellipse intersectionsWith: ray) hasCloseElementsTo: {(1 , 2) . (2.951219 , 3.951219)}.
	self assertCollection: (ellipse intersectionsWith: ray) hasSameElements: (ellipse intersectionsWithRay: ray)! !

!GEllipseTest methodsFor: 'tests' stamp: ''!
testFociLocation
	ellipse := GEllipse center: 4 , -1 vertex: 9 , -1 coVertex: 4 , 2.
	self assert: ellipse fociLocation equals: 4! !

!GIFReadWriter commentStamp: ''!
I am GIFReadWriter.
I am a concrete ImageReadWriter.

Updated implementation of a GIF file (byte-level) decoder.

I implment a Stream-like behavior over a GIF image file, and can both read and write GIF files.

Previously, two classes distinguished between "still" and "animated" GIFs. However, the standard specifies that any GIF can have "frames" and be animated. This reimplementation treats this as normal.

See these links for more detailed information:
 
 https://www.w3.org/Graphics/GIF/spec-gif89a.txt
 https://en.wikipedia.org/wiki/GIF
 http://www.matthewflickinger.com/lab/whatsinagif/bits_and_bytes.asp

For writing GIF files, I take a collection of AnimatedImageFrame objects and write the appropriate headers, Graphics Control Extensions, and everything else needed for writing an animated GIF.

For reading GIF files, I take a binary filestream and set my own `frames` variable to be a collection of AnimatedImageFrames, which themselves contain decoded Forms and instructions for disposal, delay, etc.

NOTE: I make use of the LzwGifDecoder and LzwGifEncoder classes in order to encode/decode individual bitmap data for each image frame of the GIF.

See `GIFReadWriter exampleAnim` for more information.  !
!GIFReadWriter methodsFor: 'accessing' stamp: ''!
canvasWidth
	^ canvasWidth! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
backgroundColor
	backgroundColorIndex ifNotNil: [ 
		colorPalette ifNotNil: [ 
			^ colorPalette at: backgroundColorIndex + 1]].
	^ Color transparent.! !

!GIFReadWriter methodsFor: 'private - decoding' stamp: ''!
readDisposal: aPackedByte
	"Read the three-bit disposal flag from
	the packed byte in the Graphic Control Extension block.
	Disposal is three-bits with the following codes:
	 |0 0 0 [0 0 0] 0 0|
	1 => leave current frame and draw on top of it (#leaveCurrent)
	2 => Restore to background color (#restoreBackground)
	3 => Restore to state before current frame was drawn (#restorePrevState)"
	| least middle both |
	(both := (aPackedByte bitAnd: 12) = 12).
	both ifTrue: [ ^ #restorePrevState ].
	
	least := (aPackedByte bitAnd: 4) = 4.
	least ifTrue: [ ^ #leaveCurrent ].
	
	middle := (aPackedByte bitAnd: 8) = 8.
	middle ifTrue: [ ^ #restoreBackground ].
	
	^ #otherDisposal! !

!GIFReadWriter methodsFor: 'private - decoding' stamp: ''!
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' ] ].
	"Width and Height for whole canvas, not
	just an invididual frame/form"
	canvasWidth := self readWord.
	canvasHeight := self readWord.
	byte := self next.
	hasColorMap := (byte bitAnd: 128) ~= 0.
	bitsPerPixel := (byte bitAnd: 7) + 1.
	backgroundColorIndex := self next.
	self next ~= 0 ifTrue: 
		[ is89 ifFalse: [ ^ self error: 'corrupt GIF file (screen descriptor)' ] ].
	hasColorMap 
		ifTrue: [ colorPalette := self readColorTable: (1 bitShift: bitsPerPixel) ]
		ifFalse: 
			[ colorPalette := nil	"Palette monochromeDefault" ]! !

!GIFReadWriter methodsFor: 'private - decoding' stamp: ''!
readWord
	^self next + (self next bitShift: 8)! !

!GIFReadWriter methodsFor: 'private - decoding' stamp: ''!
readCommentExtension
	| blockTerminator |
	blockTerminator := self next.
	blockTerminator > 0
		ifTrue: [ comment := self next: blockTerminator.
			blockTerminator := self next ].
	blockTerminator = 0
		ifFalse: [ ^ self error: 'Invalid Block Terminator' ]! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
forms
	frames ifNil: [ ^ nil ].
	^ frames collect: [ :f | f form ].! !

!GIFReadWriter methodsFor: 'private - encoding' stamp: ''!
writeNetscapeExtension
	"Writes a GIF Application Extension corresponding
	to the NETSCAPE2.0 version, with specifies the loopCount."
	self
		nextPut: Extension;
		nextPut: 255; "Indicates Application Extension"
		nextPut: 11; "Indicates how many bytes follow, almost always 11"
		nextPutAll: ('NETSCAPE2.0' asByteArray);
		nextPut: 3;
		nextPut: 1;
		writeWord: (loopCount ifNil: [ 0 ]);
		nextPut: 0.! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
form
	"By default, answer with the first Form available in the
	ImageFrames collection. If there are not any frames, answer nil"
	frames ifNil: [ ^ nil ].
	frames ifEmpty: [ ^ nil ].
	^ frames first form.! !

!GIFReadWriter methodsFor: 'private - decoding' stamp: ''!
readApplicationExtension
	"Uses the underlying stream to read a so-called
	Application Extension to the GIF Image. These extensions
	are at the whole file -- not individual frame like a GCE --
	level. It appears the only kind widely used is the NETSCAPE
	extension for determining the number of times an animated
	GIF should loop."
	| bytesFollow appName appAuthCode caughtInfo numSubBlocks loopVal1 loopVal2 |
	"How many bytes before data begins?
	Usually 11"
	bytesFollow := self next.
	appName := (String streamContents: [ :s |
		1 to: 8 do: [ :num |
			s
				nextPut: self next asCharacter ] ]).
	appAuthCode := (String streamContents: [ :s |
		1 to: 3 do: [ :num |
			s
				nextPut: self next asCharacter ] ]).
	caughtInfo := (appName size + appAuthCode size).
	caughtInfo = bytesFollow ifFalse: [ 
		(bytesFollow = caughtInfo) timesRepeat: [ 
			self next ] ].
	numSubBlocks := self next.
	appName = 'NETSCAPE' 
		ifTrue: [ 
			self next. "Data sub-block index (always 1)"
			"If it's the NETSCAPE extension, the next
			byte will set the loopCount. This is stored in
			a 2-byte lo-hi unsigned format"
			loopVal1 := self next.
			loopVal2 := self next.
			loopCount := (loopVal2 * 256) + loopVal1.
			self next = 0 ifFalse: [ ^ self error: 'Corrupt NETSCAPE Application Block' ].
			^ self ].

	"For now we ignore Application Extensions
	that are not the NETSCAPE kind"
	[ numSubBlocks = 0 ] whileFalse: [ 
		self next: numSubBlocks.
		numSubBlocks := self next ].! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
setStream: aStream 
	"Feed it in from an existing source"
	stream := aStream! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
loopCount: aNumber
	"Set looping. This must be done before any image is written!!"
	loopCount := aNumber! !

!GIFReadWriter methodsFor: 'private' stamp: ''!
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: 'stream access' stamp: ''!
close
	"Write terminator"
	self nextPut: Terminator.
	^super close! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
nextPutFrame: anAnimatedImageFrame
	"Given the current settings, write the bytes onto the
	output stream for the given ImageFrame and its form"
	| aForm reduced tempForm tempFrame |
	
	aForm := anAnimatedImageFrame form copy.
	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.
	tempFrame := AnimatedImageFrame new 
		form: reduced;
		offset: anAnimatedImageFrame offset;
		delay: anAnimatedImageFrame delay;
		disposal: anAnimatedImageFrame disposal.
	self writeHeader.
	self writeFrameHeader: tempFrame.
	self writeBitData: reduced bits.! !

!GIFReadWriter methodsFor: 'private - decoding' stamp: ''!
readExtensionBlock: aGifBlock withFrame: anImageFrame
	"Determine which type of extension block we are
	looking at. The most common is the Graphic Control Extension (GCE)
	which tells us information about the image frame, including delays
	offsets in the canvas, and how to dispose of the frame in animation"
	| extensionType packedByte delayByte1 delayByte2 |
	extensionType := self next.
	
	"255 is an Application Extension.
	 This seems to always be the NETSCAPE
	 extension, which has looping information.
	This extension does not affect individual frames,
	but rather sets the loopCount for the whole image"
	extensionType = 255 ifTrue: [ 
		^ self readApplicationExtension ].
	
	
	"249 Corresponds to the GCE"
	extensionType = 249 ifTrue: [ 
		self next = 4 ifFalse: [ ^ self "The GIF is likely corrupt in this case" ].
		"====
		Reserved                      3 Bits (Ignore)
		Disposal Method               3 Bits 
		User Input Flag               1 Bit  (Ignore)
		Transparent Color Flag        1 Bit  (Need to Implement)
		==="
		packedByte := self next.
		delayByte1 := self next.
		delayByte2 := self next.
		transparentIndex := self next.
		(packedByte bitAnd: 1) = 0 "Changed to see if other endian is the real end..."
			ifTrue: [ transparentIndex := nil ].
		anImageFrame 
			disposal: (self readDisposal: packedByte);
			"Delay time is stored as 2 bytes unsigned"
			delay: (delayByte2 * 256 + delayByte1) * 10.
		self next = 0 ifFalse: [ ^ self error: 'Corrupt GCE Block!!' ].
		^ self ].

	extensionType = 254 ifTrue: [ 
		^ self readCommentExtension ].

	"If you get to this point, we don't know the Extension Type"
	^ self error: 'Unknown GIF Extension: ',(extensionType asString).! !

!GIFReadWriter methodsFor: 'writing' stamp: ''!
writeDisposal: aSymbol toPackedByte: aByte
	"Using the GIF Graphics Control Extension
	packed byte format, respond with a modified version
	of the passed byte that includes the correct 3-bit
	disposal code corresponding to the passed in symbol"
	
	aSymbol = #restoreBackground
		ifTrue: [ 
			"This is a value of 2 in the 3-bit structure,
			so 010, then shifted two to the left (equal to 8)"
			^ aByte + (2 bitShift: 2) ].
	
	aSymbol = #leaveCurrent
		ifTrue: [ 
			"This is a value of 1 in the 3-bit structure,
			so 001, then shifted two to the left (equal to 4)"
			^ aByte + (1 bitShift: 2) ].
	
	aSymbol = #restorePrevState
		ifTrue: [ 
			"This is a value of 3 in the 3-bit structure,
			so 011, then shifted two to the left (equal to 12)"
			^ aByte + (3 bitShift: 2) ].
	^ aByte! !

!GIFReadWriter methodsFor: 'private - encoding' stamp: ''!
writeWord: aWord
	self nextPut: (aWord bitAnd: 255).
	self nextPut: ((aWord bitShift: -8) bitAnd: 255).
	^aWord! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
understandsImageFormat
	^('abc' collect: [:x | stream next asCharacter]) = 'GIF'! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
canvasWidth: aNumber
	canvasWidth := aNumber! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
canvasHeight: aNumber
	canvasHeight := aNumber! !

!GIFReadWriter methodsFor: 'private - encoding' stamp: ''!
writeBitData: bits 
	"using modified Lempel-Ziv Welch algorithm."
	| encoder initCodeSize |
	encoder := LzwGifEncoder new
		rowByteSize: (width * 8 + 31) // 32 * 4;
		extent: width@height;
		codeStream: stream.
	initCodeSize := bitsPerPixel <= 1 
		ifTrue: [ 2 ]
		ifFalse: [ bitsPerPixel ].
	encoder minimumCodeSize: initCodeSize.
	encoder encode: bits.! !

!GIFReadWriter methodsFor: 'private - decoding' stamp: ''!
readBody
	"Read the GIF blocks. Modified to return a frame."
	| block frame |
	frame := nil.
	frames := OrderedCollection new.
	[ stream atEnd ] whileFalse: [ 
		block := self next.
		
		"If we have reached the terminator byte, return."
		block = Terminator ifTrue: [ ^ frame ].
		block = ImageSeparator 
			ifTrue: [ 
				frame ifNil: [ frame := AnimatedImageFrame new ].
				frame form: (self readBitDataOnFrame: frame). "Adjusting message for testing"
				frame offset: offset. "Set from instance var, which is set in readBitData"
				
				frames add: frame.
				self processColorsFor: frame.
				self next = Terminator ifTrue: [ ^ frames last ].
				frame := nil. ]
			ifFalse: 
				[ "If it's not actual image data, perhaps
					it's an Extension of some kind (there can be several)"
					block = Extension 
						ifTrue: [ 
							frame ifNil: [ frame := AnimatedImageFrame new ].
							self readExtensionBlock: block withFrame: frame ]
						ifFalse: [ ^ self error: 'Unknown Bytes!!' ] ] 
		].
	^ frames.! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
frames: aCollectionOfImageFrames
	"Set the receiver's underlying collection of
	ImageFrame objects. Used when attempting to write
	out GIF images"
	frames := aCollectionOfImageFrames! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
nextImage
	"This method ensures older compatibility with ImageReadWriter.
	We respond with the Form corresponding to the *first image* on
	the receiver's read byte stream"
	self
		readHeader;
		readBody.
	^ self form.! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
nextPutImage: aForm
	"Given the current settings, write the bytes onto the
	output stream for the given ImageFrame and its form"
	| reduced tempForm tempFrame |
	
	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.
	tempFrame := AnimatedImageFrame new 
		form: reduced;
		offset: reduced offset.
	self writeHeader.
	self writeFrameHeader: tempFrame.
	self writeBitData: reduced bits.! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
frames
	^ frames! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
canvasHeight
	^ canvasHeight! !

!GIFReadWriter methodsFor: 'private - decoding' stamp: ''!
readBitDataOnFrame: aFrame
	"using modified Lempel-Ziv Welch algorithm."
	| initCodeSize  packedBits hasLocalColor localColorSize maxOutCodes decoder c  bytes |
	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.
	bytes := ByteArray new: rowByteSize * height.

	initCodeSize := self next.

	c := ColorForm 
		extent: width@height
		depth: 8. 

	decoder := LzwGifDecoder new.
	decoder 
		codeStream: stream;
		minimumCodeSize: initCodeSize;
		maxCode: maxOutCodes;
		onDecodedBit: [ :bit |
			bytes
				at: (ypos * rowByteSize + xpos + 1)
				put: bit.
			self updatePixelPosition ].
	decoder decode.
	c bits copyFromByteArray: bytes.
	^ c! !

!GIFReadWriter methodsFor: 'private - decoding' stamp: ''!
processColorsFor: anImageFrame
	"Colors can only be mapped after the GCE has been evaluated
	for a given image frame. We perform this action using either
	the local or global color table for this frame's form"
	| colorTable |
	colorTable := localColorTable ifNil: [ colorPalette ].
	
	"Use a copy so we don't mess up the global color table as we parse"
	colorTable := colorTable copyFrom: 1 to: colorTable size.
	
	transparentIndex 
		ifNotNil: [ 
			transparentIndex + 1 > colorTable size
				ifTrue: [ 
					colorTable := colorTable
										forceTo: transparentIndex + 1
										paddingWith: Color white ].
				colorTable
					at: transparentIndex + 1
					put: Color transparent ].
	anImageFrame form colors: colorTable.! !

!GIFReadWriter methodsFor: 'accessing' stamp: ''!
writeFrameHeader: anImageFrame
	"Write any Extensions and/or headers that apply
	to individual frames/subimages"
	| interlaceByte |
	anImageFrame delay notNil | transparentIndex notNil ifTrue: [ 
		self writeGCEForFrame: anImageFrame ].
	
	"Next is the image descriptor"
	self 
		nextPut: ImageSeparator;
		writeWord: (anImageFrame offset x);
		writeWord: (anImageFrame offset y);
		writeWord: (anImageFrame form extent x);
		writeWord: (anImageFrame form extent y).
	
	interlaceByte := interlace
		ifTrue: [ 64 ]
		ifFalse: [ 0 ].
	self nextPut: interlaceByte! !

!GIFReadWriter methodsFor: 'private - encoding' stamp: ''!
writeHeader
	| byte |
	"Write the overall image file header onto the
	output stream. This includes the global information
	about the file, such as canvasWidth etc. Only do so
	if the stream is in the initial position."
	stream position = 0 ifFalse: [ ^ self ].

	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 / unused 'pixel aspect ratio"
	colorPalette do: 
		[ :pixelValue | 
		self
			nextPut: ((pixelValue bitShift: -16) bitAnd: 255);
			nextPut: ((pixelValue bitShift: -8) bitAnd: 255);
			nextPut: (pixelValue bitAnd: 255) ].
	loopCount notNil ifTrue: 
		[ self writeNetscapeExtension ].! !

!GIFReadWriter methodsFor: 'testing' stamp: ''!
isAnimated
	frames ifNil: [ ^ false ].
	^ frames size > 1! !

!GIFReadWriter methodsFor: 'private - decoding' stamp: ''!
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 - encoding' stamp: ''!
writeGCEForFrame: anAnimatedImageFrame
	"Writes a Graphics Control Extension onto
	the output stream for the given image frame"
	| nextDelay packedByte |
	nextDelay := anAnimatedImageFrame delay.
	anAnimatedImageFrame delay ifNil: [ nextDelay := 0 ].
	"Set the bits of the packed byte"
	"====
		Reserved                      3 Bits (Ignore)
		Disposal Method               3 Bits 
		User Input Flag               1 Bit  (Ignore)
		Transparent Color Flag        1 Bit 
		==="
	packedByte := 0.
	transparentIndex
		ifNotNil: [ packedByte := 1 ].
	packedByte := self 
		writeDisposal: (anAnimatedImageFrame disposal)
		toPackedByte: packedByte.
	
	self 
		nextPut: Extension;
		nextPutAll: #(249 4) asByteArray;
		nextPut: packedByte;
		"nextPut: (transparentIndex
				ifNil: [ 0 ]
				ifNotNil: [ 9 ]);"
		writeWord: nextDelay // 10;
		nextPut: (transparentIndex ifNil: [ 0 ]);
		nextPut: 0.! !

!GIFReadWriter class methodsFor: 'examples' stamp: ''!
grabScreenAndSaveOnDisk
	"GIFReadWriter grabScreenAndSaveOnDisk"
	| form fileName |
	
	form := Form fromUser.
	form bits size = 0 ifTrue: [ ^ self inform: 'Empty region selected.' ].
	
	fileName := (FileSystem disk workingDirectory / 'Pharo', 'gif') fullName.
		
	UIManager default 
		informUser: 'Writing ' translated, fileName
		during: 
			[ GIFReadWriter 
				putForm: form
				onFileNamed: fileName ]! !

!GIFReadWriter class methodsFor: 'initialization' stamp: ''!
initialize
	"GIFReadWriter initialize"
	ImageSeparator := $, asInteger.
	Extension := $!! asInteger.
	Terminator := $; asInteger! !

!GIFReadWriter class methodsFor: 'examples' stamp: ''!
exampleAnim
	"This example writes out an animated gif of
	 a red circle"

	| writer extent center frameDelay |
	writer := GIFReadWriter on: (File openForWriteFileNamed: 'anim.gif').
	writer loopCount: 20.		"Repeat 20 times"
	frameDelay := 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"
			| frame |
			frame := AnimatedImageFrame new
				delay: frameDelay;
				form: (ColorForm extent: extent depth: 8).
			0.0 to: 359.0 do: [:theta | frame form colorAt: (center + (Point r: r degrees: theta)) rounded put: Color red].
			writer nextPutFrame: frame]
		]	ensure: [writer close]].! !

!GIFReadWriter class methodsFor: 'image reading/writing' stamp: ''!
wantsToHandleGIFs
	^ true! !

!GIFReadWriter class methodsFor: 'image reading/writing' stamp: ''!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can 
	read might commonly have"

	^ self allSubclasses
		detect: [ :cls | cls wantsToHandleGIFs ]
		ifFound: [ #() ]
		ifNone: [ 
			"if none of my subclasses wants , then i''ll have to do"
			#('gif') ]! !

!GIFReadWriterTest commentStamp: ''!
GIF Specific ReadWriter tests. All tests ensure that the images written are read back in correctly and visa-versa. Using different colors helps ensure that the resulting mapped pixel data for each is reasonably correct.!
!GIFReadWriterTest methodsFor: 'tests' stamp: ''!
testColorsOutIn
	"Ensure that the colors that are written match up
	to the colors that are read in again"
	| canvas form outBytes inBytes writer reader |
	canvas := FormCanvas extent: 400@400.
	canvas
		fillRectangle: (0@0 extent: 200@200) color: Color green;
		fillRectangle: (200@0 extent: 400@200) color: Color red;
		fillRectangle: (0@200 extent: 200@400) color: Color yellow;
		fillRectangle: (200@200 extent: 400@400) color: Color black.
	form := canvas form.
	outBytes := WriteStream on: (ByteArray new).
	writer := GIFReadWriter on: outBytes.
	writer
		nextPutImage: form;
		close.
	outBytes := outBytes contents.
	inBytes := ReadStream on: outBytes.
	reader := GIFReadWriter on: inBytes.
	reader
		readHeader;
		readBody.
	self assert: reader isAnimated equals: false.
	self assert: (reader form colorAt: 50@50) equals: Color green.
	self assert: (reader form colorAt: 250@50) equals: Color red.
	self assert: (reader form colorAt: 50@250) equals: Color yellow.
	self assert: (reader form colorAt: 250@250) equals: Color black.! !

!GIFReadWriterTest methodsFor: 'accessing' stamp: ''!
animatedColorFrames
	"Responds with a collection of AnimatedImageFrames
	each containing equal-sized rectangles of green, red, 
	yellow. and black. When animated, these rectangles move
	into each other's positions, then back"
	| frames topLeft topRight bottomLeft bottomRight revFrames |
	frames := OrderedCollection new.
	topLeft := (0@0 extent: 200@200).
	topRight := (200@0 extent: 400@200).
	bottomLeft := (0@200 extent: 200@400).
	bottomRight := (200@200 extent: 400@400).
	
	0 to: 200 by: 20 do: [ :num |
		| newTopLeft newTopRight newBottomLeft newBottomRight canvas |
		newTopLeft := topLeft translateBy: (num@0).
		newTopRight := topRight translateBy: (0@num).
		newBottomLeft := (bottomLeft origin - (0@num)) corner: (bottomLeft extent - (0@num)).
		newBottomRight := (bottomRight origin - (num@0)) extent: (bottomLeft extent - (0@0)).
		canvas := FormCanvas extent: 400@400.
		canvas
			fillRectangle: newTopLeft color: Color green;
			fillRectangle: newTopRight color: Color red;
			fillRectangle: newBottomLeft color: Color yellow;
			fillRectangle: newBottomRight color: Color black.
		frames add: (AnimatedImageFrame new
			form: canvas form;
			disposal: #restoreBackground;
			delay: 60) ].

	revFrames := frames reversed.
	revFrames do: [ :f | frames add: f ].
	^ frames! !

!GIFReadWriterTest methodsFor: 'tests' stamp: ''!
testAnimatedColorsOutIn
	"Ensure that the colored rectangles in the created
	animated gif are correct at different frames"
	| frames outBytes writer reader inBytes activeFrame |
	frames := self animatedColorFrames.
	
	"Write out the GIF bytes to the byte stream"
	outBytes := WriteStream on: (ByteArray new).
	writer := GIFReadWriter on: outBytes.
	frames do: [ :f | writer nextPutFrame: f ].
	writer close.
	
	"Read the GIF byte stream back into a GIF"
	inBytes := ReadStream on: (outBytes contents).
	reader := GIFReadWriter on: inBytes.
	reader
		readHeader;
		readBody.
	
	self assert: reader isAnimated equals: true.
	activeFrame := reader frames at: 1.
	self assert: (activeFrame form colorAt: 100@100) equals: Color green.
	self assert: (activeFrame form colorAt: 300@100) equals: Color red.
	self assert: (activeFrame form colorAt: 100@300) equals: Color yellow.
	self assert: (activeFrame form colorAt: 300@300) equals: Color black.
	activeFrame := reader frames at: 11.
	self assert: (activeFrame form colorAt: 100@100) equals: Color yellow.
	self assert: (activeFrame form colorAt: 300@100) equals: Color green.
	self assert: (activeFrame form colorAt: 100@300) equals: Color black.
	self assert: (activeFrame form colorAt: 300@300) equals: Color red.! !

!GIFReadWriterTest methodsFor: 'tests' stamp: ''!
testColorsFileOutIn
	"Ensure that the colors that are written match up
	to the colors that are read in again"
	| canvas form outBytes inBytes writer reader |
	canvas := FormCanvas extent: 400@400.
	canvas
		fillRectangle: (0@0 extent: 200@200) color: Color green;
		fillRectangle: (200@0 extent: 400@200) color: Color red;
		fillRectangle: (0@200 extent: 200@400) color: Color yellow;
		fillRectangle: (200@200 extent: 400@400) color: Color black.
	form := canvas form.
	outBytes := 'testColorsFileOutIn.gif' asFileReference binaryWriteStream.
	writer := GIFReadWriter on: outBytes.
	writer
		nextPutImage: form;
		close.
	inBytes := 'testColorsFileOutIn.gif' asFileReference binaryReadStream.
	reader := GIFReadWriter on: inBytes.
	reader
		readHeader;
		readBody.
	inBytes close.
	'testColorsFileOutIn.gif' asFileReference delete.
	self assert: reader isAnimated equals: false.
	self assert: (reader form colorAt: 50@50) equals: Color green.
	self assert: (reader form colorAt: 250@50) equals: Color red.
	self assert: (reader form colorAt: 50@250) equals: Color yellow.
	self assert: (reader form colorAt: 250@250) equals: Color black.! !

!GIFReadWriterTest class methodsFor: 'accessing' stamp: ''!
animGifExampleBytes
	"Complete Bytes of the anim example gif file"
	^ #[71 73 70 56 57 97 42 0 42 0 231 0 0 255 255 255 0 0 0 255 255 255 128 128 128 255 0 0 0 255 0 0 0 255 0 255 255 255 255 0 255 0 255 32 32 32 64 64 64 96 96 96 159 159 159 191 191 191 223 223 223 8 8 8 16 16 16 24 24 24 40 40 40 48 48 48 56 56 56 72 72 72 80 80 80 88 88 88 104 104 104 112 112 112 120 120 120 135 135 135 143 143 143 151 151 151 167 167 167 175 175 175 183 183 183 199 199 199 207 207 207 215 215 215 231 231 231 239 239 239 247 247 247 0 0 0 0 51 0 0 102 0 0 153 0 0 204 0 0 255 0 0 0 51 0 51 51 0 102 51 0 153 51 0 204 51 0 255 51 0 0 102 0 51 102 0 102 102 0 153 102 0 204 102 0 255 102 0 0 153 0 51 153 0 102 153 0 153 153 0 204 153 0 255 153 0 0 204 0 51 204 0 102 204 0 153 204 0 204 204 0 255 204 0 0 255 0 51 255 0 102 255 0 153 255 0 204 255 0 255 255 51 0 0 51 51 0 51 102 0 51 153 0 51 204 0 51 255 0 51 0 51 51 51 51 51 102 51 51 153 51 51 204 51 51 255 51 51 0 102 51 51 102 51 102 102 51 153 102 51 204 102 51 255 102 51 0 153 51 51 153 51 102 153 51 153 153 51 204 153 51 255 153 51 0 204 51 51 204 51 102 204 51 153 204 51 204 204 51 255 204 51 0 255 51 51 255 51 102 255 51 153 255 51 204 255 51 255 255 102 0 0 102 51 0 102 102 0 102 153 0 102 204 0 102 255 0 102 0 51 102 51 51 102 102 51 102 153 51 102 204 51 102 255 51 102 0 102 102 51 102 102 102 102 102 153 102 102 204 102 102 255 102 102 0 153 102 51 153 102 102 153 102 153 153 102 204 153 102 255 153 102 0 204 102 51 204 102 102 204 102 153 204 102 204 204 102 255 204 102 0 255 102 51 255 102 102 255 102 153 255 102 204 255 102 255 255 153 0 0 153 51 0 153 102 0 153 153 0 153 204 0 153 255 0 153 0 51 153 51 51 153 102 51 153 153 51 153 204 51 153 255 51 153 0 102 153 51 102 153 102 102 153 153 102 153 204 102 153 255 102 153 0 153 153 51 153 153 102 153 153 153 153 153 204 153 153 255 153 153 0 204 153 51 204 153 102 204 153 153 204 153 204 204 153 255 204 153 0 255 153 51 255 153 102 255 153 153 255 153 204 255 153 255 255 204 0 0 204 51 0 204 102 0 204 153 0 204 204 0 204 255 0 204 0 51 204 51 51 204 102 51 204 153 51 204 204 51 204 255 51 204 0 102 204 51 102 204 102 102 204 153 102 204 204 102 204 255 102 204 0 153 204 51 153 204 102 153 204 153 153 204 204 153 204 255 153 204 0 204 204 51 204 204 102 204 204 153 204 204 204 204 204 255 204 204 0 255 204 51 255 204 102 255 204 153 255 204 204 255 204 255 255 255 0 0 255 51 0 255 102 0 255 153 0 255 204 0 255 255 0 255 0 51 255 51 51 255 102 51 255 153 51 255 204 51 255 255 51 255 0 102 255 51 102 255 102 102 255 153 102 255 204 102 255 255 102 255 0 153 255 51 153 255 102 153 255 153 153 255 204 153 255 255 153 255 0 204 255 51 204 255 102 204 255 153 204 255 204 204 255 255 204 255 0 255 255 51 255 255 102 255 255 153 255 255 204 255 255 255 255 33 255 11 78 69 84 83 67 65 80 69 50 46 48 3 1 20 0 0 33 249 4 0 1 0 0 0 44 0 0 0 0 42 0 42 0 0 8 84 0 1 8 28 72 176 160 193 131 8 19 42 92 200 176 161 195 135 16 35 74 156 72 177 162 197 139 24 51 106 220 200 177 163 199 143 32 67 138 28 73 178 164 201 147 38 9 168 76 73 0 192 74 146 45 5 198 28 185 242 37 76 155 40 115 234 220 201 179 167 207 159 64 131 10 29 74 180 168 209 163 12 3 2 0 33 249 4 0 1 0 0 0 44 0 0 0 0 42 0 42 0 0 8 98 0 1 8 28 72 176 160 193 131 8 19 42 92 200 176 161 195 135 16 35 74 156 72 177 162 197 139 24 51 106 220 200 177 163 199 143 32 67 138 28 73 178 164 71 2 40 81 146 84 41 144 37 72 151 45 9 132 148 105 144 230 71 155 4 113 118 212 217 114 166 78 152 39 109 2 189 153 146 167 201 163 72 147 42 93 202 180 169 211 167 80 163 74 157 74 53 97 64 0 33 249 4 0 1 0 0 0 44 0 0 0 0 42 0 42 0 0 8 110 0 1 8 28 72 176 160 193 131 8 19 42 92 200 176 161 195 135 16 35 74 156 72 177 162 197 139 24 51 106 220 200 177 163 199 143 32 67 138 28 57 145 128 73 147 35 79 14 84 249 17 165 65 151 29 9 36 148 25 147 230 65 152 26 109 34 212 153 145 231 203 152 11 125 94 196 89 144 104 207 153 45 133 26 205 9 147 101 200 147 75 73 74 157 74 181 170 213 171 88 179 106 221 202 181 171 87 130 1 1 0 33 249 4 0 1 0 0 0 44 0 0 0 0 42 0 42 0 0 8 124 0 1 8 28 72 176 160 193 131 8 19 42 92 200 176 161 195 135 16 35 74 156 72 177 162 197 139 24 51 106 220 200 177 163 199 143 32 67 14 36 64 178 36 129 144 37 11 166 236 72 50 97 203 141 47 93 158 212 56 115 97 205 139 49 21 230 172 120 211 102 198 158 58 127 62 4 58 145 40 66 163 17 145 26 84 58 148 169 192 157 60 27 58 109 106 115 42 213 163 86 33 174 28 9 21 166 201 174 34 195 138 29 75 182 172 217 179 104 211 170 93 107 54 32 0 33 249 4 0 1 0 0 0 44 0 0 0 0 42 0 42 0 0 8 132 0 1 8 28 72 176 160 193 131 8 19 42 92 200 176 161 195 135 16 35 74 156 72 177 162 197 139 24 51 106 220 200 177 163 199 135 4 66 138 36 240 81 160 200 130 39 57 166 60 184 242 98 200 134 47 49 146 116 56 211 98 76 152 53 41 230 132 105 115 39 195 155 18 125 242 212 57 81 40 205 162 21 141 46 84 250 19 169 78 166 44 161 46 141 40 117 105 85 147 87 21 102 205 170 181 42 208 158 74 91 102 20 43 86 229 200 175 37 211 170 93 203 182 173 219 183 112 227 202 205 24 16 0 33 249 4 0 1 0 0 0 44 0 0 0 0 42 0 42 0 0 8 138 0 1 8 28 72 176 160 193 131 8 19 42 92 200 176 161 195 135 16 35 74 156 72 177 162 197 139 24 51 106 220 40 145 128 199 143 4 56 18 252 120 144 228 70 143 11 81 102 84 153 50 228 69 150 12 97 118 116 249 80 102 77 154 16 109 54 196 25 145 167 67 159 53 59 190 236 57 52 103 209 160 22 129 42 84 138 180 41 69 166 8 161 238 20 250 116 162 212 165 86 175 150 212 186 181 39 215 168 95 117 122 221 249 181 165 217 147 58 77 138 4 0 82 237 218 183 112 227 202 157 75 183 174 221 187 5 3 2 0 33 249 4 0 1 0 0 0 44 0 0 0 0 42 0 42 0 0 8 150 0 1 8 28 72 176 160 193 131 8 19 42 92 200 176 161 195 135 16 35 74 156 72 177 162 197 139 24 23 18 216 200 145 99 70 131 30 65 110 252 8 32 100 66 147 21 71 58 84 73 145 229 74 2 45 97 74 116 249 50 165 204 135 55 91 66 164 57 51 167 198 140 62 79 6 157 200 243 224 80 157 12 143 18 109 168 116 38 83 146 77 7 70 221 249 244 227 212 146 80 153 94 77 186 117 235 207 154 22 139 158 188 232 85 160 88 173 61 137 150 37 120 22 97 91 174 56 215 26 125 139 146 108 209 186 86 59 118 36 201 183 175 223 191 128 3 11 198 24 16 0 33 249 4 0 1 0 0 0 44 0 0 0 0 42 0 42 0 0 8 160 0 1 8 28 72 176 160 193 131 8 19 42 92 200 176 161 195 135 16 35 74 156 72 49 34 129 139 24 49 86 76 152 241 96 199 141 3 47 54 20 185 145 228 67 147 22 9 76 68 233 144 37 68 151 10 97 190 84 217 18 164 64 154 12 113 218 212 137 80 230 74 158 6 129 130 20 74 144 104 69 163 0 124 82 244 137 244 40 71 155 30 159 66 45 104 180 233 82 169 83 67 98 205 154 116 107 214 170 86 83 198 228 218 117 44 215 166 74 197 46 12 91 115 36 84 182 73 225 246 148 155 54 166 220 155 119 241 46 189 91 119 109 216 190 35 53 6 21 124 54 227 71 178 136 19 43 94 156 53 32 0 33 249 4 0 1 0 0 0 44 0 0 0 0 42 0 42 0 0 8 174 0 1 8 28 72 176 160 193 131 8 19 42 92 200 176 161 195 135 16 15 18 152 72 145 98 196 134 21 37 90 188 104 112 227 66 143 23 65 98 156 24 146 0 71 129 36 31 166 60 9 96 229 71 147 44 7 186 68 56 51 102 205 130 48 99 226 84 120 211 102 206 142 58 105 210 252 25 84 38 81 148 69 133 2 77 186 148 96 207 162 51 143 50 69 234 116 170 196 157 86 177 202 204 170 149 42 87 175 96 185 18 149 58 117 44 89 168 71 207 6 149 170 86 39 219 182 39 123 194 229 120 246 105 92 181 115 33 182 181 27 145 111 203 188 47 29 250 13 172 18 112 71 195 40 7 59 85 172 113 174 200 187 55 51 90 173 72 249 171 229 203 0 2 2 0 33 249 4 0 1 0 0 0 44 0 0 0 0 42 0 42 0 0 8 177 0 1 8 28 72 176 160 193 131 8 19 42 36 72 160 161 67 135 11 35 30 124 56 17 162 196 133 13 47 2 200 168 177 32 199 142 27 9 128 180 8 82 32 73 140 34 75 26 252 152 144 165 74 134 41 17 186 124 9 179 37 77 133 49 61 230 188 169 115 34 79 156 43 127 98 244 40 20 232 192 157 69 131 154 76 106 116 35 83 155 33 159 202 20 137 84 234 81 167 86 125 86 205 74 53 171 86 175 65 183 90 237 10 150 97 212 178 103 197 50 141 169 54 41 91 180 88 151 130 221 217 246 39 210 186 52 171 206 20 186 55 238 218 150 120 59 246 53 25 88 226 224 163 133 113 6 62 57 242 112 69 149 142 21 107 140 108 152 49 97 202 141 31 90 86 24 16 0 59].! !

!GLMOSWindowWorldMorph commentStamp: ''!
I am an OSWindow world morph that is used by Glamour to display its content in a external OSWindow.

Usage examples:

GTInspector new openInExternalWindowOn: 3.

3 inspectInExternalWindow.!
!GLMOSWindowWorldMorph methodsFor: 'submorphs - add/remove' stamp: ''!
delete
	self model notNil ifTrue: [self model unregisterFromAllAnnouncements].
	super delete! !

!GLMOSWindowWorldMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	self layoutPolicy: ProportionalLayout new.
	self clipSubmorphs: true.! !

!GLMOSWindowWorldMorph methodsFor: 'announcing' stamp: ''!
when: anAnnouncement do: aBlock 
	^ self announcer when: anAnnouncement do: aBlock! !

!GLMOSWindowWorldMorph methodsFor: 'callbacks' stamp: ''!
actOnWindowRequest: ann

	ann action value: self! !

!GLMOSWindowWorldMorph methodsFor: 'accessing' stamp: ''!
toolbarBox: anObject
	toolbarBox := anObject! !

!GLine commentStamp: ''!
Description
--------------------

A GLine goes through two points and can be represented by an equation of the form ax + by + c = 0.

Examples
--------------------

	GLine a: 1 b: 1 c: -13.
	
	GLine through: 1 , 3 and: 3 , 0.
	
	(GLine a: 2 b: -3 c: 0.5) intersectionsWith: (GLine a: -2 b: -2 c: 4).
	
	(GLine a: 1 b: 2 c: 0.5) isParallelTo: (GLine a: 2 b: 4 c: 4).
	
	(GLine through: -1 , -4 and: 1 , -2) translateBy: #(1 -2) asGVector.
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	v1:						<aGPoint>				One points on the line.
	v2:						<aGPoint>				Another point on the line.
	equationCache:		<aDictionary>		Dictionary caching the values of the equation ax + by + c = 0.
!
!GLine methodsFor: 'arithmetic' stamp: ''!
angleWith: aLine
	^ self v1 - self v2 angleWith: aLine v1 - aLine v2! !

!GLine methodsFor: 'accessing' stamp: ''!
c
	^ self linearEquation at: #c! !

!GLine methodsFor: 'comparing' stamp: ''!
= line
	self == line ifTrue: [ ^ true ].
	self class = line class ifFalse: [ ^ false ].

	(self isParallelTo: line) ifFalse: [ ^ false ].

	^ [ (self yFor: 1) =~ (line yFor: 1) ]
		on: GeometryError
		do: [ "This can happen if b = 0" (self xFor: 1) =~ (line xFor: 1) ]! !

!GLine methodsFor: 'testing' stamp: ''!
includes: aPoint
	^ self a * aPoint x + (self b * aPoint y) + self c =~ 0! !

!GLine methodsFor: 'comparing' stamp: ''!
hash
	^ ([ self yFor: 1 ]
		on: GeometryError
		do: [ "This can happen if b = 0" self xFor: 1 ]) hash! !

!GLine methodsFor: 'accessing' stamp: ''!
linearEquation
	"Return a dictionary with value for a, b and c representing the line with an equation of the form: ax + by + c = 0"

	^ equationCache ifNil: [ equationCache := self privateLinearEquationComputation ]! !

!GLine methodsFor: 'properties' stamp: ''!
xFor: anY
	self a = 0 ifTrue: [ self error: 'Cannot answer a x if a = 0' ].

	^ ((anY * self b + self c) / self a) negated! !

!GLine methodsFor: 'transforming' stamp: ''!
translateBy: aGVector
	self v1: self v1 + aGVector.
	self v2: self v2 + aGVector! !

!GLine methodsFor: 'properties' stamp: ''!
yFor: anX
	self b = 0 ifTrue: [ self error: 'Cannot answer an y if b = 0' ].

	^ ((anX * self a + self c) / self b) negated! !

!GLine methodsFor: 'accessing' stamp: ''!
determinantWith: aLine
	"I return the determinant between two line.
	
	First line: ax + by + c = 0
	Second line: px + qy + c = 0
	
	Determinant: a*q - p*b
	"

	^ (GMatrix rows: {{self a . self b} . {aLine a . aLine b}}) determinant! !

!GLine methodsFor: 'intersections' stamp: ''!
intersectionsWithLine: aGLine
	| p q r x y determinant |
	determinant := self determinantWith: aGLine.

	determinant =~ 0 ifTrue: [ ^ { } "Line are parallel if determinant = 0" ].

	p := aGLine a.
	q := aGLine b.
	r := aGLine c.
	
	x := (self c negated * q - (r negated * self b)) / determinant.
	y := (self a * r negated - (p * self c negated)) / determinant.
	^ { (x , y) }! !

!GLine methodsFor: 'accessing' stamp: ''!
a
	^ self linearEquation at: #a! !

!GLine methodsFor: 'printing' stamp: ''!
printOn: aStream
	self a ~~ 0
		ifTrue: [ self a ~~ 1 ifTrue: [ self a printOn: aStream ].
			aStream nextPutAll: 'x '.
			self b sign >= 0 ifTrue: [ aStream nextPutAll: '+ ' ] ].
	self b ~~ 0
		ifTrue: [ self b ~~ 1 ifTrue: [ self b printOn: aStream ].
			aStream nextPutAll: 'y' ].
	self c ~~ 0
		ifTrue: [ aStream space.
			self c sign >= 0 ifTrue: [ aStream nextPutAll: '+ ' ].
			self c printOn: aStream ].
	aStream nextPutAll: ' = 0'! !

!GLine methodsFor: 'distance functions' stamp: ''!
distanceTo: aGPoint
	^ (self a * aGPoint x + (self b * aGPoint y) + self c) abs / (self a squared + self b squared) sqrt! !

!GLine methodsFor: 'initialization' stamp: ''!
resetEquationCache
	equationCache := nil! !

!GLine methodsFor: 'accessing' stamp: ''!
length
	^ Float infinity! !

!GLine methodsFor: 'accessing' stamp: ''!
v1: aPoint
	v1 := aPoint.
	self resetEquationCache! !

!GLine methodsFor: 'accessing' stamp: ''!
b
	^ self linearEquation at: #b! !

!GLine methodsFor: 'properties' stamp: ''!
isParallelTo: aLine
	"If the determinant it 0 then the lines are parallel"

	^ (self determinantWith: aLine) =~ 0! !

!GLine methodsFor: 'accessing' stamp: ''!
v1
	^ v1! !

!GLine methodsFor: 'accessing' stamp: ''!
v2
	^ v2! !

!GLine methodsFor: 'converting' stamp: ''!
asGLine
	^ self ! !

!GLine methodsFor: 'intersections' stamp: ''!
intersectionsWith: anElement
	^ anElement intersectionsWithLine: self! !

!GLine methodsFor: 'private' stamp: ''!
privateLinearEquationComputation
	v1 y = v2 y ifTrue: [ ^ Dictionary with: #a -> 0 with: #b -> 1 with: #c -> v1 y negated ].
	v1 x = v2 x ifTrue: [ ^ Dictionary with: #a -> 1 with: #b -> 0 with: #c -> v1 x negated ].

	^ Dictionary with: #a -> (v1 y - v2 y) with: #b -> (v2 x - v1 x) with: #c -> ((v1 x - v2 x) * v1 y + ((v2 y - v1 y) * v1 x))! !

!GLine methodsFor: 'accessing' stamp: ''!
v2: aPoint
	v2 := aPoint.
	self resetEquationCache! !

!GLine methodsFor: 'intersections' stamp: ''!
intersectionsWithEllipse: aGEllipse 
	^ aGEllipse intersectionsWithLine: self! !

!GLine class methodsFor: 'instance creation' stamp: ''!
through: aPoint1 and: aPoint2
	^ self new
		v1: aPoint1;
		v2: aPoint2;
		yourself! !

!GLine class methodsFor: 'instance creation' stamp: ''!
a: a b: b c: c
	"ax + by + c = 0
	ax + c = -by
	-((ax + c) / b) = y
	
	ax + by + c = 0
	by + c = -ax
	-((by + c) / a) = x
	"

	^ b = 0 ifFalse: [ self through: 1 , ((a * 1 + c) / b) negated and: 2 , ((a * 2 + c) / b) negated ] ifTrue: [ self through: ((b * 1 + c) / a) negated , 1 and: ((b * 2 + c) / a) negated , 2 ]! !

!GLineTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPolygon
	| polygon |
	line := GLine through: 0 , 1 and: 5 , 6.
	polygon := GPolygon vertices: {(3 , 3) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (line intersectionsWith: polygon) isEmpty.

	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (line intersectionsWith: polygon) hasCloseElementsTo: {(3 , 4) . (2 , 3)}.
	self assertCollection: (line intersectionsWith: polygon) hasSameElements: (line intersectionsWithPolygon: polygon).

	polygon := GPolygon vertices: {(2 , 3) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (line intersectionsWith: polygon) hasCloseElementsTo: {(2 , 3)}! !

!GLineTest methodsFor: 'tests' stamp: ''!
testIncludes
	self deny: ((GSegment with: 17674 / 229 , (14582 / 229) with: 76.82622578909061 , 64.97050543967634) asGLine includes: -28206 / 397 , (50382 / 397)).
	self assert: ((GLine through: 1 , 3 and: 3 , 0) includes: 1 , 3).
	self assert: ((GLine through: 1 , 3 and: 3 , 0) includes: 3 , 0).
	self assert: ((GLine through: -1 , 1 and: 1 , -1) includes: 0 , 0).
	self assert: ((GLine through: 0 , 0 and: 12 , 9) includes: 13 , (39 / 4)).
	self assert: ((GLine through: 0 , 0 and: 13 , (39 / 4)) includes: 12 , 9).
	self deny: ((GLine through: 0 , 0 and: 1 , 1) includes: 1 , 2).
	self deny: ((GLine through: 0 , 0 and: 1 , 1) includes: 1 , 1.01).
	self deny: ((GLine through: 0 , 0 and: 1 , 1) includes: 2 , 2.001)! !

!GLineTest methodsFor: 'tests' stamp: ''!
testTranslateBy
	line := GLine through: -1 , -4 and: 1 , -2.
	line translateBy: #(1 -2) asGVector.
	self assert: (line isParallelTo: (GLine through: -1 , -4 and: 1 , -2)).
	self assert: (line includes: 0 , -6).
	self assert: (line includes: 3 , -3).
	self assert: (line includes: -1 , -7)! !

!GLineTest methodsFor: 'tests' stamp: ''!
testEquals
	self assert: (GLine a: 1 b: 1 c: -13) equals: (GLine a: 6 b: 6 c: -78).
	self assert: (GLine a: 1 b: 1 c: -13) hash equals: (GLine a: 1 b: 1 c: -13) hash.
	self assert: (GLine a: 0 b: 1 c: -13) equals: (GLine a: 0 b: 6 c: -78).
	self deny: (GLine a: 1 b: 1 c: -13) = (GLine a: 1 b: 6 c: -78).
	self deny: (GLine a: 1 b: 1 c: -13) = (GLine a: 6 b: 6 c: -7).
	self assert: (GLine a: 1 b: 0 c: -13) equals: (GLine a: 6 b: 0 c: -78).
	self assert: (GLine a: 0 b: 1 c: 0) equals: (GLine a: 0 b: 6 c: 0).
	self assert: (GLine a: 1 b: 0 c: 0) equals: (GLine a: 1 b: 0 c: 0).
	self deny: (GLine a: 1 b: 1 c: -13) = (GLine a: 6 b: 6 c: 0).
	self assert: (GLine a: 0 b: 1 c: -13) equals: (GLine a: 0 b: 6 c: -78).
	self assert: (GLine a: -48.989794855663575 b: 48.98979485566357 c: 4.547473508864641e-13) equals: (GLine a: -138.58803762173304 b: 138.58803762173304 c: 1.8189894035458565e-12).
	self
		assert: (GSegment with: -24.494897427831784 , -24.494897427831795 with: 24.494897427831784 , 24.49489742783178) asGLine
		equals: (GSegment with: -99.30232333601874 , -99.30232333601876 with: 39.285714285714285 , 39.28571428571428) asGLine.
	self
		assert: (GSegment with: -24.494897427831784 , -24.494897427831795 with: 24.494897427831784 , 24.49489742783178) asGLine
		equals: (GSegment with: 24.494897427831784 , 24.49489742783178 with: -24.494897427831784 , -24.494897427831795) asGLine! !

!GLineTest methodsFor: 'tests' stamp: ''!
testAsGLine
	line := GLine through: 1 , 2 and: 3 , 5.
	self assert: line asGLine equals: line! !

!GLineTest methodsFor: 'tests' stamp: ''!
testAngleWith
	| line2 |
	line := GLine through: 0 , 0 and: 5 , 24.
	line2 := GLine through: 3 , 4 and: 4 , 7.
	self assert: (line angleWith: line2) equals: -0.11635 radians ! !

!GLineTest methodsFor: 'tests' stamp: ''!
testDistanceTo
	self assert: ((GLine a: 1 b: 0 c: -7) distanceTo: 7 , 0) equals: 0.
	self assert: ((GLine a: 1 b: 0 c: -7) distanceTo: 7 , 7) equals: 0.
	self assert: ((GLine a: 1 b: 0 c: -7) distanceTo: 0 , 0) equals: 7! !

!GLineTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithEllipse
	| ellipse |
	"Test without intersection"
	ellipse := GEllipse center: 2 , 5 vertex: 2 , 9 coVertex: 5 , 5.
	line := (GLine a: -1 b: 1 c: -20).
	self assert: (line intersectionsWith: ellipse) isEmpty.
	
	"Test with an ellipse centered at the origin and a line going through the origin"
	ellipse := GEllipse center: 0 , 0 vertex: 0 , 3 coVertex: 2 , 0.
	line := GLine a: -1 b: 1 c: 0.
	self assert: (line intersectionsWith: ellipse) hasCloseElementsTo: {(1.6641 , 1.6641) . (-1.6641 , -1.6641)}.

	"Test with an ellipse centered at the origin and a line not going through the origin"
	line := GLine a: -1 b: 1 c: -1.
	self assert: (line intersectionsWith: ellipse) hasCloseElementsTo: {(0.9065084 , 1.9065084) . (-2.291123 , -1.291123)}.

	"Test with an ellipse not centered at the origin and a line not going through the origin"
	ellipse := GEllipse center: 2 , 5 vertex: 2 , 9 coVertex: 5 , 5.
	line := GLine a: -2 b: 1 c: -8.
	self assert: (line intersectionsWith: ellipse) hasCloseElementsTo: {(-0.263181454 , 7.473637091) . (-1.873804847 , 4.252390306)}.
	self assertCollection: (line intersectionsWith: ellipse) hasSameElements: (line intersectionsWithEllipse: ellipse).
	
	"Test with tangent"
	ellipse := GEllipse center: 2 , 5 vertex: 2 , 9 coVertex: 5 , 5.
	line := GLine a: -1 b: 1 c: -8.
	self assert: (line intersectionsWith: ellipse) hasCloseElementsTo: {(-6 / 5 , (34 / 5))}! !

!GLineTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPoint
	| point |
	point := 2 , 4.
	line := GLine through: 5 , 6 and: 7 , 102.
	self assert: (line intersectionsWith: point) isEmpty.

	line := GLine through: 1 , 3 and: 3 , 5.
	self assert: (line intersectionsWith: point) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (line intersectionsWith: point) hasSameElements: (line intersectionsWithPoint: point)! !

!GLineTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GLine! !

!GLineTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithSegment
	| segment |
	line := GLine through: -5 , 1 and: -3 , 3.
	segment := GSegment with: -7 , 2  with: -4, 3 .
	self assert: (line intersectionsWith: segment) isEmpty.
	
	segment := GSegment with: -6 , 4  with: -3, 1 .
	self assert: (line intersectionsWith: segment) hasCloseElementsTo: {(-4 , 2)}.
	self assertCollection: (line intersectionsWith: segment) hasSameElements: (line intersectionsWithSegment: segment)! !

!GLineTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithLine
	| line2 |
	line := GLine through: 0 , 0 and: 1 , 1.
	line2 := GLine through: 3 , 3 and: 5 , 5.
	self assert: (line intersectionsWith: line2) isEmpty.

	line := GLine a: 2 b: -3 c: 0.5.
	line2 := GLine a: 1 b: 1 c: -2.
	self assert: (line intersectionsWith: line2) hasCloseElementsTo: {(1.1 , 0.9)}.

	line2 := GLine a: -2 b: -2 c: 4.
	self assert: (line intersectionsWith: line2) hasCloseElementsTo: {(1.1 , 0.9)}.
	self assertCollection: (line intersectionsWith: line2) hasSameElements: (line intersectionsWithLine: line2)! !

!GLineTest methodsFor: 'tests' stamp: ''!
testIsParallelTo
	self deny: ((GLine a: 0 b: -3 c: 0.5) isParallelTo: (GLine a: -2 b: 0 c: 4)).
	self deny: ((GLine a: 0 b: -3 c: 0.5) isParallelTo: (GLine a: -2 b: 1 c: 4)).
	self assert: ((GLine a: 1 b: 2 c: 0.5) isParallelTo: (GLine a: 2 b: 4 c: 4)).
	self assert: ((GLine a: 0 b: 2 c: 0.5) isParallelTo: (GLine a: 0 b: 2 c: 0.5))! !

!GLineTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithRay
	| ray |
	line := GLine through: -5 , 1 and: -3 , 3.	
	ray := GRay origin: -5 , 3  direction: -7, 5 .
	self assert: (line intersectionsWith: ray) isEmpty.
	
	ray := GRay origin: -7 , 5  direction: -5, 3 .
	self assert: (line intersectionsWith: ray) hasCloseElementsTo: {(-4 , 2)}.
	self assertCollection: (line intersectionsWith: ray) hasSameElements: (line intersectionsWithRay: ray)! !

!GLineTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithArc
	| arc |
	line := GLine through: 0 , 0 and: 1 , 1.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (line intersectionsWith: arc) isEmpty.

	arc := GArc center: -1 , 0 origin: 4 , 0 direction: 1 , 4.
	self assert: (line intersectionsWith: arc) hasCloseElementsTo: {(3 , 3)}.
	self assertCollection: (line intersectionsWith: arc) hasSameElements: (line intersectionsWithArc: arc)! !

!GMatrix commentStamp: ''!
Description
--------------------

I am a simple implementation of matrix for operations needing matrix in geometry computations.

I will not implement all matrix operations, only the one needed for the features of geometry elements.
	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	rows:		<aCollection> 	A collection of collection containing the rows of the matrix.
!
!GMatrix methodsFor: 'accessing' stamp: ''!
at: anInteger at: anInteger2 
	^ (self at: anInteger) at: anInteger2! !

!GMatrix methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].
	^ rows = anObject rows! !

!GMatrix methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ rows hash negated! !

!GMatrix methodsFor: 'accessing' stamp: ''!
rows: anObject
	rows := anObject! !

!GMatrix methodsFor: 'arithmetic' stamp: ''!
determinant
	self flag: #todo.	"For now this implementation is only for 2D squared matrix. We should later manage n-dimensions matrix"
	^ (self at: 1 at: 1) * (self at: 2 at: 2) - ((self at: 1 at: 2) * (self at: 2 at: 1))! !

!GMatrix methodsFor: 'accessing' stamp: ''!
at: anInteger
	^ self rows at: anInteger! !

!GMatrix methodsFor: 'accessing' stamp: ''!
rows
	^ rows! !

!GMatrix class methodsFor: 'instance creation' stamp: ''!
rows: aCollection
	^ self new
		rows: aCollection;
		yourself! !

!GMatrixTest commentStamp: ''!
A GMatrixTest is a test class for testing the behavior of GMatrix!
!GMatrixTest methodsFor: 'test' stamp: ''!
testEquals
	matrix := GMatrix rows: #(#(3 5) #(2 9)).
	self assert: matrix equals: (GMatrix rows: #(#(3 5) #(2 9))).
	self assert: matrix hash equals: (GMatrix rows: #(#(3 5) #(2 9))) hash.
	self deny: matrix = (GMatrix rows: #(#(3 5) #(2 1))).
	self deny: matrix hash = (GMatrix rows: #(#(3 5) #(2 1))) hash! !

!GMatrixTest methodsFor: 'test' stamp: ''!
testAt
	matrix := GMatrix rows: #(#(3 5) #(2 9)).
	self assert: (matrix at: 1) equals: #(3 5).
	self assert: (matrix at: 2) equals: #(2 9)! !

!GMatrixTest methodsFor: 'test' stamp: ''!
testAtAt
	matrix := GMatrix rows: #(#(3 5) #(2 9)).
	self assert: (matrix at: 1 at: 1) equals: 3.
	self assert: (matrix at: 1 at: 2) equals: 5.
	self assert: (matrix at: 2 at: 1) equals: 2.
	self assert: (matrix at: 2 at: 2) equals: 9! !

!GMatrixTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GMatrix! !

!GMatrixTest methodsFor: 'test' stamp: ''!
testDeterminant
	matrix := GMatrix rows: #(#(3 5) #(2 9)).
	self assert: matrix determinant equals: 17! !

!GPoint commentStamp: ''!
Description
--------------------

I represent a geometric point. In the contrary of default Pharo point, I implement only the point logic and cannot be used as a vector. 

Vectors can be used with GVector.

I am based on a set of coordinates and my API should be independent from the number of dimensions of the current space. The computations will rely on coordinates.

Examples
--------------------

	"Instance creation"
	
	GPoint withCollection: #(1 2).	 "a GPoint(1,2)"
	
	GPoint withCollection: #(1 4 2). "a GPoint(1,4,2)"
	
	GPoint coordinates: (GCoordinates withCollection: #(1 3)). 	"a GPoint(1,3)"
	
	(GCoordinates withCollection: #(1 3)) asGPoint.	"a GPoint(1,3)"
	
	#(1 2) asGPoint.	"a GPoint(1,2)"
		
	1 , 2.		"a GPoint(1,2)"		
		
	"Arithmetic"
	(1 , 2) + (2 , 3). "a GPoint(3,5) <= This will be a new instance."
	
	(1, 2) translateBy: (2 , 3).	"a GPoint(3,5) <= This will be the same instance than the receiver" 
		
	(4, 2) - (1, 1).	"a GVector(3,1)"
		
	(3, 5) middlePointTo: (9, 15).	"a GPoint(6,10)"
	
	(3, 5) distanceTo: (9, 15).	"11.661903789690601"
	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	coordinates:		<aGCoordinates> 	I represent the coordinates of the point.
!
!GPoint methodsFor: '*Roassal3-Shapes' stamp: ''!
center
	^ self! !

!GPoint methodsFor: 'comparing' stamp: ''!
= anotherPoint
	"Answer whether the receiver and anObject represent the same object."

	self == anotherPoint ifTrue: [ ^ true ].
	self class = anotherPoint class ifFalse: [ ^ false ].

	^ coordinates = anotherPoint coordinates! !

!GPoint methodsFor: 'testing' stamp: ''!
includes: aGPoint
	^ aGPoint =~ self! !

!GPoint methodsFor: 'accessing' stamp: ''!
coordinates: anObject
	coordinates := anObject! !

!GPoint methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ coordinates hash squared "Try to avoid collisions with GAbstractCoordinates"! !

!GPoint methodsFor: 'transforming' stamp: ''!
translateBy: aVector 
	"Answer a Point translated by a vector."

	coordinates := coordinates + aVector coordinates! !

!GPoint methodsFor: 'accessing' stamp: ''!
y: aNumber 
	self coordinates y: aNumber! !

!GPoint methodsFor: 'enumerating' stamp: ''!
coordinatesWith: aCollection do: aBlock
	self coordinates coordinatesWith: aCollection coordinates do: aBlock! !

!GPoint methodsFor: 'accessing' stamp: ''!
x
	^ self coordinates x! !

!GPoint methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	self coordinates printCoordinatesOn: aStream! !

!GPoint methodsFor: 'accessing' stamp: ''!
x: aNumber 
	self coordinates x: aNumber! !

!GPoint methodsFor: 'intersections' stamp: ''!
intersectionsWithLine: aGLine 
	^ aGLine intersectionsWithPoint: self! !

!GPoint methodsFor: 'accessing' stamp: ''!
y
	^ self coordinates y! !

!GPoint methodsFor: 'comparing' stamp: ''!
distanceTo: aGPoint 
	"Answer the distance between aPoint and the receiver.
	
	The distance between two points is the length of the vector transposing v1 into v2"
	
	^ (self - aGPoint) length! !

!GPoint methodsFor: 'converting' stamp: ''!
asPoint
	^ self x @ self y! !

!GPoint methodsFor: 'accessing' stamp: ''!
length
	"https://math.stackexchange.com/questions/1936865/what-is-the-length-of-a-point-on-the-real-number-line"

	^ 0! !

!GPoint methodsFor: '*Roassal3-Shapes' stamp: ''!
rsScaleWith: anAthensAffineTransform
	^ (anAthensAffineTransform transform: self) asGPoint! !

!GPoint methodsFor: 'converting' stamp: ''!
asGPoint
	^ self! !

!GPoint methodsFor: 'arithmetic' stamp: ''!
- aPoint
	"I return a vector represented by the substraction of two points"

	^ (self coordinates - aPoint coordinates) asGVector! !

!GPoint methodsFor: 'transformations' stamp: ''!
rotateBy: aGAngle about: aGPoint
	"Rotate the point around the another point of the plan.
	
	This will change the receiver. To get a new point use #rotatedBy:about:.
	
	This is only valid for 2D points."

	| cos sin diffX diffY |
	cos := aGAngle cos.
	sin := aGAngle sin.
	diffX := self x - aGPoint x.
	diffY := self y - aGPoint y.
	self x: cos * diffX - (sin * diffY) + aGPoint x.
	self y: sin * diffX + (cos * diffY) + aGPoint y! !

!GPoint methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self coordinates: self coordinates copy! !

!GPoint methodsFor: 'arithmetic' stamp: ''!
additionWithVector: aGVector
	^ self + aGVector! !

!GPoint methodsFor: 'intersections' stamp: ''!
intersectionsWith: anElement
	^ anElement intersectionsWithPoint: self! !

!GPoint methodsFor: 'transformations' stamp: ''!
rotatedBy: aGAngle
	"Rotate the point around the origin (0,0) of the plan.
	
	This will return a new point. To change the receiver use #rotateBy:.
	
	This is only valid for 2D points."

	^ self rotatedBy: aGAngle about: 0 , 0! !

!GPoint methodsFor: 'intersections' stamp: ''!
intersectionsWithEllipse: aGEllipse 
	^ aGEllipse intersectionsWithPoint: self! !

!GPoint methodsFor: 'accessing' stamp: ''!
coordinates
	^ coordinates! !

!GPoint methodsFor: 'comparing' stamp: ''!
=~ aPoint
	^ (self distanceTo: aPoint) =~ 0
! !

!GPoint methodsFor: 'transformations' stamp: ''!
rotatedBy: aGAngle about: aGPoint
	"Rotate the point around another point of the plan.
	
	This will return a new point. To change the receiver use #rotateBy:about:.
	
	This is only valid for 2D points."

	| cos sin diffX diffY |
	cos := aGAngle cos.
	sin := aGAngle sin.
	diffX := self x - aGPoint x.
	diffY := self y - aGPoint y.
	^ cos * diffX - (sin * diffY) + aGPoint x , (sin * diffX + (cos * diffY) + aGPoint y)! !

!GPoint methodsFor: 'enumerating' stamp: ''!
coordinatesWith: aCollection collect: aBlock
	^ self coordinates coordinatesWith: aCollection coordinates collect: aBlock! !

!GPoint methodsFor: 'transformations' stamp: ''!
rotateBy: aGAngle
	"Rotate the point around the origin (0,0) of the plan.
	
	This will change the receiver. To get a new point use #rotatedBy:.
	
	This is only valid for 2D points."

	self rotateBy: aGAngle about: 0 , 0! !

!GPoint methodsFor: 'accessing' stamp: ''!
segment: aPoint 
	^ GSegment with: self with: aPoint ! !

!GPoint methodsFor: 'arithmetic' stamp: ''!
+ aGVector
	"I return a new point translated by a vector"

	^ self copy
		translateBy: aGVector;
		yourself! !

!GPoint class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!GPoint class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!GPoint class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!GPoint class methodsFor: 'instance creation' stamp: ''!
coordinates: aCoordinates
	^ self new
		coordinates: aCoordinates;
		yourself! !

!GPoint class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!GPoint class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!GPoint class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!GPoint class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!GPoint class methodsFor: 'instance creation' stamp: ''!
x: aNumber y: anotherNumber
	^ self new
		coordinates: (G2DCoordinates x: aNumber y: anotherNumber);
		yourself! !

!GPoint class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!GPoint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!GPoint class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!GPoint class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!GPoint class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!GPoint class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!GPoint class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!GPoint class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!GPoint class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!GPoint class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!GPoint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!GPoint class methodsFor: 'instance creation' stamp: ''!
withCollection: aCollection
	^ self coordinates: (GCoordinates withCollection: aCollection)! !

!GPoint class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!GPoint class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!GPoint class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!GPoint class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!GPoint class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!GPoint class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!GPoint class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!GPoint class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!GPoint class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!GPoint class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!GPoint class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!GPointTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPolygon
	| polygon |
	point := 2 , 4.
	polygon := GPolygon vertices: {(1 , 5) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (point intersectionsWith: polygon) isEmpty.

	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (point intersectionsWith: polygon) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (point intersectionsWith: polygon) hasSameElements: (point intersectionsWithPolygon: polygon)! !

!GPointTest methodsFor: 'tests' stamp: ''!
testRotateBy
	point := 5 , 5.
	point rotateBy: 90 degrees.
	self assert: point =~ (-5 , 5).
	point rotateBy: 90 degrees.
	self assert: point =~ (-5 , -5)! !

!GPointTest methodsFor: 'tests' stamp: ''!
testIncludes
	point := 2 , 4.
	self deny: (point includes: 3, 4).
	self assert: (point includes: 2, 4)! !

!GPointTest methodsFor: 'tests' stamp: ''!
testRotateByAbout
	point := 5 , 5.
	point rotateBy: 90 degrees about: 3 , 3.
	self assert: point =~ (1 , 5).
	point rotateBy: 90 degrees about: 3 , 3.
	self assert: point =~ (1 , 1)! !

!GPointTest methodsFor: 'tests' stamp: ''!
testRotatedByAbout
	point := 5 , 5.
	self assert: (point rotatedBy: 90 degrees about: 3 , 3) =~ (1 , 5).
	self deny: (point rotatedBy: 90 degrees about: 3 , 3) == point! !

!GPointTest methodsFor: 'tests' stamp: ''!
testEquals
	self assert: (1 , 2) equals: (1 , 2).
	self deny: (2 , 4) = (1 , 2).
	self assert: (1 , 2) hash equals: (1 , 2) hash.
	self deny: (2 , 4) hash = (1 , 2) hash! !

!GPointTest methodsFor: 'tests' stamp: ''!
testTranslateBy
	| vector |
	point := (1, 2).
	vector := GVector x: 2 y: 3.
	point translateBy: vector.
	self assert: point equals: (3, 5).
	point translateBy: vector.
	self assert: point equals: (5 , 8)! !

!GPointTest methodsFor: 'tests' stamp: ''!
testWithCollection
	self assert: (GPoint withCollection: #(1 2)) equals: 1 , 2.
	self should: [ GPoint withCollection: #() ] raise: GeometryError! !

!GPointTest methodsFor: 'tests' stamp: ''!
testDistanceTo
	self assert: (0 , 0 distanceTo: 0 , 0) equals: 0.
	self assert: (0 , 0 distanceTo: 0 , 5) equals: 5.
	self assert: (5 , 0 distanceTo: 0 , 0) equals: 5.
	self assert: (3 , 0 distanceTo: 0 , 4) equals: 5.
	self assert: (5 , 0 distanceTo: 2 , 4) equals: 5.
	self deny: (0 , 0 distanceTo: 0 , 0) = 1! !

!GPointTest methodsFor: 'tests' stamp: ''!
test2DPoint
	point := GPoint x: 1 y: 2.
	self assert: point x equals: 1.
	self assert: point y equals: 2.
	
	point := GPoint x: -1 y: -2.
	self assert: point x equals: -1.
	self assert: point y equals: -2.
	
	point := GPoint coordinates: (G2DCoordinates x: 1 y: 2).
	self assert: point x equals: 1.
	self assert: point y equals: 2.
	
	point := (1 , 2).
	self assert: point x equals: 1.
	self assert: point y equals: 2.! !

!GPointTest methodsFor: 'tests' stamp: ''!
testRotatedBy
	point := 5 , 5.
	self assert: (point rotatedBy: 90 degrees) =~ (-5 , 5).
	self deny: (point rotatedBy: 90 degrees) == point! !

!GPointTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithEllipse
	| ellipse |
	point := 2 , 4.
	ellipse := GEllipse center: 1 , 3 vertex: 5 , 6 coVertex: 3 , 4.
	self assert: (point intersectionsWith: ellipse) isEmpty.

	ellipse := GEllipse center: 2 , 1 vertex: 5 , 1 coVertex: 2 , 4.
	self assert: (point intersectionsWith: ellipse) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (point intersectionsWith: ellipse) hasSameElements: (point intersectionsWithEllipse: ellipse)! !

!GPointTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPoint
	point := 2 , 4.
	self assert: (point intersectionsWith: 3 , 4) isEmpty.
	self assert: (point intersectionsWith: 2 , 4) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (point intersectionsWith: 2 , 4) hasSameElements: (point intersectionsWithPoint: 2 , 4)! !

!GPointTest methodsFor: 'tests' stamp: ''!
testAddition
	| vector |
	point := (1, 2).
	vector := GVector x: 2 y: 3.
	self assert: point + vector equals: (3, 5).
	self assert: point equals: (1, 2)! !

!GPointTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GPoint ! !

!GPointTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithSegment
	| segment |
	point := 2 , 4.
	segment := GSegment with: 5 , 6 with: 7 , 102.
	self assert: (point intersectionsWith: segment) isEmpty.

	segment := GSegment with: 1 , 3 with: 0 , 2.
	self assert: (point intersectionsWith: segment) isEmpty.

	segment := GSegment with: 1 , 3 with: 3 , 5.
	self assert: (point intersectionsWith: segment) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (point intersectionsWith: segment) hasSameElements: (point intersectionsWithSegment: segment)! !

!GPointTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithLine
	| line |
	point := 2 , 4.
	line := GLine through: 5 , 6 and: 7 , 102.
	self assert: (point intersectionsWith: line) isEmpty.

	line := GLine through: 1 , 3 and: 3 , 5.
	self assert: (point intersectionsWith: line) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (point intersectionsWith: line) hasSameElements: (point intersectionsWithLine: line)! !

!GPointTest methodsFor: 'tests' stamp: ''!
testCopy
	| pointCopy |
	point := (1, 2).
	pointCopy := point copy.
	self assert: point equals: pointCopy.
	point x: 2.
	self deny: point = pointCopy.
	self deny: point == pointCopy! !

!GPointTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithRay
	| ray |
	point := 2 , 4.
	ray := GRay origin: 5 , 6 direction: 7 , 102.
	self assert: (point intersectionsWith: ray) isEmpty.

	ray := GRay origin: 1 , 3 direction: 0 , 2.
	self assert: (point intersectionsWith: ray) isEmpty.

	ray := GRay origin: 0 , 2 direction: 1 , 3.
	self assert: (point intersectionsWith: ray) hasCloseElementsTo: {(2 , 4)}.

	ray := GRay origin: 1 , 3 direction: 3 , 5.
	self assert: (point intersectionsWith: ray) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (point intersectionsWith: ray) hasSameElements: (point intersectionsWithRay: ray)! !

!GPointTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithArc
	| arc |
	point := 3 , 3.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (point intersectionsWith: arc) isEmpty.

	arc := GArc center: -1 , 0 origin: 4 , 0 direction: 1 , 4.
	self assert: (point intersectionsWith: arc) hasCloseElementsTo: {(3 , 3)}.
	self assertCollection: (point intersectionsWith: arc) hasSameElements: (point intersectionsWithArc: arc)! !

!GPolygon commentStamp: ''!
I'm polygon builded on my vertices.

!
!GPolygon methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].

	^ vertices = anObject vertices! !

!GPolygon methodsFor: 'testing' stamp: ''!
includes: aPoint
	" Thanks to Google and Randolph Franklin i don't have to reinvent this very simple algorithm. See [ 1 ] for details, copyrights etc.

	https://wrf.ecse.rpi.edu//Research/Short_Notes/pnpoly.html"

	| inside testX testY j |
	inside := false.
	j := self vertices size.
	testX := aPoint x.
	testY := aPoint y.

	self vertices doWithIndex: [ :pi :i | 
		| pj |
		pj := self vertices at: j.

		(pi y > testY ~= (pj y > testY) and: [ testX < ((pj x - pi x) * (testY - pi y) / (pj y - pi y) + pi x) ]) ifTrue: [ inside := inside not ].

		j := i ].

	^ inside! !

!GPolygon methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ vertices hash bitXor: self class hash! !

!GPolygon methodsFor: 'transforming' stamp: ''!
scaleBy: anInteger

	anInteger <= 0 ifTrue: [ self error: 'Scale must be over zeo' ].

	vertices := self vertices collect: [ :vertice | (vertice - self center) * anInteger + self center ]! !

!GPolygon methodsFor: 'transforming' stamp: ''!
translateBy: aPoint
	"Move a polygon by a delta defined by aPoint"

	vertices := self vertices collect: [ :point | point + aPoint ]! !

!GPolygon methodsFor: 'intersections' stamp: ''!
intersectionsWith: anElement
	^ anElement intersectionsWithPolygon: self! !

!GPolygon methodsFor: 'testing' stamp: ''!
boundaryContains: aGPoint 
	^ self edges anySatisfy: [ :segment | segment includes: aGPoint ]! !

!GPolygon methodsFor: 'accessing' stamp: ''!
vertices
	
	^ vertices! !

!GPolygon methodsFor: 'intersections' stamp: ''!
intersectionsWithLine: aGLine
	^ aGLine intersectionsWithPolygon: self! !

!GPolygon methodsFor: 'intersections' stamp: ''!
intersectionsWithEllipse: aGEllipse
	^ aGEllipse intersectionsWithPolygon: self! !

!GPolygon methodsFor: 'accessing' stamp: ''!
encompassingRectangle
	| origin corner |
	origin := ((self vertices collect: #coordinates) fold: [ :coor1 :coor2 | coor1 lowerLimitsWith: coor2 ]) asGPoint.
	corner := ((self vertices collect: #coordinates) fold: [ :coor1 :coor2 | coor1 upperLimitsWith: coor2 ]) asGPoint.
	^ GRectangle origin: origin corner: corner! !

!GPolygon methodsFor: 'accessing' stamp: ''!
perimeter
	^ self edges sum: #length! !

!GPolygon methodsFor: 'accessing' stamp: ''!
edges
	| edges |
	edges := (self vertices overlappingPairsCollect: [ :point1 :point2 | (GSegment with: point1 with: point2) ]) asOrderedCollection.
	edges add: (GSegment with: self vertices last with: self vertices first).
	^ edges! !

!GPolygon methodsFor: '*Roassal3-Shapes' stamp: ''!
rsScaleWith: anAthensAffineTransform
	^ self class vertices: (self vertices collect: [ :p | anAthensAffineTransform transform: p ])! !

!GPolygon methodsFor: 'rectangle functions' stamp: ''!
expandBy: anInteger
	self fitInExtent: self extent + (2 * {anInteger . anInteger} asGVector)! !

!GPolygon methodsFor: 'transforming' stamp: ''!
fitInExtent: extent
	"I take as parameter a point and will fit the polygon in a rectangle whose dimensions is defined by the extent."

	| scales |
	scales := extent coordinatesWith: self encompassingRectangle extent coordinates collect: [ :number1 :number2 | number1 / number2 ].
	vertices := self vertices collect: [ :vertice | ((vertice - self center) coordinates coordinatesWith: scales collect: [ :a :b | a * b ]) asGVector + self center ]! !

!GPolygon methodsFor: 'accessing' stamp: ''!
vertices: aCollection
	vertices := aCollection collect: #asGPoint! !

!GPolygon class methodsFor: 'instance creation' stamp: ''!
newRegularPolygonWithEdgeNumber: aNumber
	"I return the polygon vertices for a regular polygon with a number of segment given as parameter.
	
	If Y give 8 as parameter I get an octogon."

	| angle encompassingCircleRadius |
	angle := 2π / aNumber.
	encompassingCircleRadius := 0.5.
	^ self newVertices: ((1 to: aNumber) collect: [ :index | ((encompassingCircleRadius + index) * angle) sin , ((encompassingCircleRadius + index) * angle) cos negated ])! !

!GPolygon class methodsFor: 'instance creation' stamp: ''!
vertices: aCollection
	^ self new
		vertices: aCollection;
		yourself! !

!GPolygon class methodsFor: 'public' stamp: ''!
convexHullOn: aCollection
	| lastPoint nextPoint convexHull |
	"self halt."
	convexHull := OrderedCollection new.
	nextPoint := aCollection detectMin: #x.
	[ lastPoint := nextPoint.
	convexHull add: lastPoint.
	nextPoint := aCollection detect: [ :point | point ~= lastPoint ].
	(aCollection copyWithout: nextPoint)
		do: [ :point | 
			| turn |
			turn := (nextPoint x - lastPoint x) * (point y - lastPoint y)
				- ((point x - lastPoint x) * (nextPoint y - lastPoint y)).
			(turn < 0
				or: [ turn = 0
						and: [ (lastPoint distanceTo: point) > (lastPoint distanceTo: nextPoint) ] ])
				ifTrue: [ nextPoint := point ] ] ]
		doWhileTrue: [ convexHull first ~= nextPoint ].

	^ self vertices: convexHull! !

!GPolygon class methodsFor: 'instance creation' stamp: ''!
newVertices: aCollection
	self deprecated: 'Use #vertices: instead' transformWith: '`@receiver newVertices: `@statements' -> '`@receiver vertices: `@statements'.
	^ self vertices: aCollection! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPolygon
	| polygon2 |
	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	polygon2 := GPolygon vertices: {(-3 , 5) . (0 , 5) . (1 , 2) . (-1 , 4)}.
	self assert: (polygon intersectionsWith: polygon2) isEmpty.

	polygon2 := GPolygon vertices: {(5 , 1) . (8 , 1) . (8 , 0) . (6 , -1)}.
	self assert: (polygon intersectionsWith: polygon2) hasCloseElementsTo: {(6 , 1)}.

	polygon2 := GPolygon vertices: {(5 , 6) . (8 , 7) . (8 , 3) . (5 , 3)}.
	self assert: (polygon intersectionsWith: polygon2) hasCloseElementsTo: {(6 , 3) . (5 , 4)}.
	self assertCollection: (polygon intersectionsWith: polygon2) hasSameElements: (polygon intersectionsWithPolygon: polygon2)! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testBoundaryContains
	self assert: ((GPolygon vertices: {(10 , 10) . (-10 , 10) . (-10 , -10)}) boundaryContains: 0 , 10).
	self deny: ((GPolygon vertices: {(10 , 10) . (-10 , 10) . (-10 , -10)}) boundaryContains: -5 , 5)! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testIncludes
	self assert: ((GPolygon vertices: {(10 , 10) . (-10 , 10) . (-10 , -10)}) includes: -5 , 5)! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testTranslateBy
	polygon := GPolygon vertices: {(10 , 10) . (-10 , 10) . (-10 , -10)}.
	polygon translateBy: 10 , 10.
	self assert: polygon vertices equals: {(20 , 20) . (0 , 20) . (0 , 0)}! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testEquals
	polygon := GPolygon vertices: {(1 , 1) . (2 , 3) . (5 , 8) . (2 , 5)}.
	self assert: polygon equals: (GPolygon vertices: {(1 , 1) . (2 , 3) . (5 , 8) . (2 , 5)}).
	self assert: polygon hash equals: (GPolygon vertices: {(1 , 1) . (2 , 3) . (5 , 8) . (2 , 5)}) hash.
	self deny: polygon = (GPolygon vertices: {(1 , 1) . (2 , 4) . (5 , 8) . (2 , 5)}).
	self deny: polygon hash = (GPolygon vertices: {(1 , 1) . (2 , 4) . (5 , 8) . (2 , 5)}) hash! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testEncompassingRectangle
	self
		assert:
			(GPolygon
				vertices:
					{(0 , -20) . (0 , 10) . (30 , -30) . (40 , 0) . (-10 , 0).
					(40 , -20)}) encompassingRectangle
		equals:
			(GRectangle
				left: -10
				right: 40
				top: 10
				bottom: -30)! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testConvexHullOn
	self
		assert:
			(GPolygon
				convexHullOn:
					{(0 , -20).
					(0 , 10).
					(30 , -30).
					(40 , 0).
					(-10 , 0).
					(40 , -20)}) vertices
		equals:
			{(-10 , 0).
			(0 , -20).
			(30 , -30).
			(40 , -20).
			(40 , 0).
			(0 , 10)} asOrderedCollection.
	self
		assert:
			(GPolygon
				convexHullOn:
					{(0 , -20).
					(0 , 10).
					(30 , -30).
					(0 , 0).
					(40 , 0).
					(-10 , 0).
					(40 , -20)}) vertices
		equals:
			{(-10 , 0).
			(0 , -20).
			(30 , -30).
			(40 , -20).
			(40 , 0).
			(0 , 10)} asOrderedCollection! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testScaleBy
	polygon := GPolygon vertices: {(10 , 4) . (-4 , 10) . (-10 , -8)}.
	polygon scaleBy: 1.
	self assert: polygon vertices equals: {(10 , 4) . (-4 , 10) . (-10 , -8)}.

	polygon := GPolygon vertices: {(5 , 2) . (-2 , 5) . (-5 , -5)}.
	polygon scaleBy: 2.
	self assert: polygon vertices equals: {(10 , 4) . (-4 , 10) . (-10 , -10)}.

	polygon := GPolygon vertices: {(10 , 4) . (-4 , 10) . (-10 , -10)}.
	polygon scaleBy: 1 / 2.
	self assert: polygon vertices equals: {(5 , 2) . (-2 , 5) . (-5 , -5)}.

	self should: [ polygon scaleBy: 0 ] raise: GeometryError! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testEdges
	self
		assert:
			(GPolygon
				convexHullOn:
					{(0 , -20).
					(0 , 10).
					(30 , -30).
					(40 , 0).
					(-10 , 0).
					(40 , -20)}) edges first
		equals: (GSegment with: -10 , 0 with: 0 , -20).
	self
		assert:
			(GPolygon
				convexHullOn:
					{(0 , -20).
					(0 , 10).
					(30 , -30).
					(40 , 0).
					(-10 , 0).
					(40 , -20)}) edges second
		equals: (GSegment with: 0 , -20 with: 30 , -30).
	self
		assert:
			(GPolygon
				convexHullOn:
					{(0 , -20).
					(0 , 10).
					(30 , -30).
					(40 , 0).
					(-10 , 0).
					(40 , -20)}) edges last
		equals: (GSegment with: -10 , 0 with: 0 , 10)! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithEllipse
	| ellipse |
	polygon := GPolygon vertices: {(5 , 1) . (9 , 1) . (8 , 0) . (6 , -1)}.
	ellipse := GEllipse center: 2,6 vertex: 7, 6 coVertex: 2,9 .
	self assert: (polygon intersectionsWith: ellipse) isEmpty.

	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (polygon intersectionsWith: ellipse) hasCloseElementsTo: {(2 , 3) . (5.7267799 , 4)}.
	self assertCollection: (polygon intersectionsWith: ellipse) hasSameElements: (polygon intersectionsWithEllipse: ellipse)! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPoint
	| point |
	point := 2 , 4.
	polygon := GPolygon vertices: {(1 , 5) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (polygon intersectionsWith: point) isEmpty.

	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (polygon intersectionsWith: point) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (polygon intersectionsWith: point) hasSameElements: (polygon intersectionsWithPoint: point)! !

!GPolygonTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GPolygon! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithSegment
	| segment |
	segment := GSegment with: 0 , -1 with: 0 , 4.
	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (polygon intersectionsWith: segment) isEmpty.

	segment := GSegment with: 0 , -1 with: 1 , 3.
	self assert: (polygon intersectionsWith: segment) isEmpty.

	segment := GSegment with: 0 , 1 with: 5 , 6.
	self assert: (polygon intersectionsWith: segment) hasCloseElementsTo: {(2 , 3) . (3 , 4)}.
	self assertCollection: (polygon intersectionsWith: segment) hasSameElements: (polygon intersectionsWithSegment: segment)! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testFitInExtent
	polygon := GPolygon vertices: {(10 , 10) . (-10 , 10) . (-10 , -10)}.
	polygon fitInExtent: {20 . 20} asGVector.
	self
		assert: polygon vertices
		equals: {(10 , 10) . (-10 , 10) . (-10 , -10)}.
	polygon fitInExtent: {40 . 40} asGVector.
	self
		assert: polygon vertices
		equals: {(20 , 20) . (-20 , 20) . (-20 , -20)}.
	polygon fitInExtent: {10 . 10} asGVector.
	self
		assert: polygon vertices
		equals: {(5 , 5) . (-5 , 5) . (-5 , -5)}! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithLine
	| line |
	line := GLine through: 0 , 1 and: 5 , 6.
	polygon := GPolygon vertices: {(3 , 3) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (polygon intersectionsWith: line) isEmpty.

	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (polygon intersectionsWith: line) hasCloseElementsTo: {(3 , 4) . (2 , 3)}.
	self assertCollection: (polygon intersectionsWith: line) hasSameElements: (polygon intersectionsWithLine: line).

	polygon := GPolygon vertices: {(2 , 3) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (polygon intersectionsWith: line) hasCloseElementsTo: {(2 , 3)}! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithRay
	| ray |
	ray := GRay origin: 0 , -1 direction: 0 , 4.
	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (polygon intersectionsWith: ray) isEmpty.

	ray := GRay origin: 1 , 3 direction: 0 , -1.
	self assert: (polygon intersectionsWith: ray) isEmpty.

	ray := GRay origin: 0 , 1 direction: 5 , 6.
	self assert: (polygon intersectionsWith: ray) hasCloseElementsTo: {(2 , 3) . (3 , 4)}.
	self assertCollection: (polygon intersectionsWith: ray) hasSameElements: (polygon intersectionsWithRay: ray)! !

!GPolygonTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithArc
	| arc |
	polygon := GPolygon vertices: {(1 , 2) . (1 , 5) . (-3 , 5) . (-3 , 0)}.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (polygon intersectionsWith: arc) isEmpty.

	arc := GArc center: 1 , 0 origin: 4 , 0 direction: -1 , 2.
	self assert: (polygon intersectionsWith: arc) hasCloseElementsTo: {(1 , 3)}.
	self assertCollection: (polygon intersectionsWith: arc) hasSameElements: (polygon intersectionsWithArc: arc)! !

!GRay commentStamp: ''!
Description
--------------------

A ray starts out at a point and continues off to infinity

A ray is a geometry figure defined by an initial point, the origin, and another point to define a direction.

Examples
--------------------

	GRay origin: 0 , -1 direction: 1 , 4.
	
	(GRay origin: 100 , 100 direction: 80 , 110) flipped.
	
	(GRay origin: 100 , 100 direction: 80 , 110) includes: 120 , 90.
	
	(GRay origin: 0 , 0 direction: 1 , 1) intersectionsWith: GRay origin: 2 , 3 direction: 2 , 0.
	
	(GRay origin: -1 , -4 direction: 1 , -2) translateBy: #(1 -2).
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	directionPoint:		<aGPoint>		A point that can be anywhere on the ray and defining the direction of the ray.
	initialPoint:		<aGPoint>		A GPoint defining the end point of the ray.
!
!GRay methodsFor: 'properties' stamp: ''!
flipped
	^ self class origin: self initialPoint direction: initialPoint + (initialPoint - directionPoint)! !

!GRay methodsFor: 'arithmetic' stamp: ''!
angleWith: aGRay 
	^ (self directionPoint - self initialPoint) angleWith: (aGRay directionPoint - aGRay initialPoint)! !

!GRay methodsFor: 'accessing' stamp: ''!
initialPoint: aGPoint
	initialPoint := aGPoint asGPoint! !

!GRay methodsFor: 'comparing' stamp: ''!
= aRay
	self == aRay ifTrue: [ ^ true ].
	self class = aRay class ifFalse: [ ^ false ].

	^ self initialPoint =~ aRay initialPoint and: [ (self angleWith: aRay) isZero ]! !

!GRay methodsFor: 'testing' stamp: ''!
includes: aPoint
	^ ((self directionPoint - self initialPoint) angleWith: (aPoint - self initialPoint)) isZero! !

!GRay methodsFor: 'comparing' stamp: ''!
hash
	"We define the hash by its origin and the angle the ray has with the x axis."

	^ self initialPoint hash bitXor: (self directionPoint - self initialPoint angleWith: {1 . 1} asGVector) hash! !

!GRay methodsFor: 'converting' stamp: ''!
asGLine
	^ GLine through: self initialPoint and: self directionPoint! !

!GRay methodsFor: 'intersections' stamp: ''!
intersectionsWith: anElement
	^ anElement intersectionsWithRay: self! !

!GRay methodsFor: 'transforming' stamp: ''!
translateBy: aGVector 
	initialPoint := initialPoint + aGVector.
	directionPoint := directionPoint + aGVector! !

!GRay methodsFor: 'intersections' stamp: ''!
intersectionsWithLine: aGLine
	^ aGLine intersectionsWithRay: self! !

!GRay methodsFor: 'intersections' stamp: ''!
intersectionsWithEllipse: aGEllipse	
	^ aGEllipse intersectionsWithRay: self! !

!GRay methodsFor: 'accessing' stamp: ''!
directionPoint
	^ directionPoint 
! !

!GRay methodsFor: 'accessing' stamp: ''!
initialPoint 
	^ initialPoint
! !

!GRay methodsFor: 'accessing' stamp: ''!
length
	"A ray is not finite."

	^ Float infinity! !

!GRay methodsFor: 'accessing' stamp: ''!
directionPoint: aGPoint
	directionPoint := aGPoint asGPoint! !

!GRay class methodsFor: 'instance creation' stamp: ''!
origin: aGPoint direction: anotherPoint
	^ self new
		initialPoint: aGPoint;
		directionPoint: anotherPoint;
		yourself! !

!GRayTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPolygon
	| polygon |
	ray := GRay origin: 0 , -1 direction: 0 , 4.
	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (ray intersectionsWith: polygon) isEmpty.

	ray := GRay origin: 1 , 3 direction: 0 , -1.
	self assert: (ray intersectionsWith: polygon) isEmpty.

	ray := GRay origin: 0 , 1 direction: 5 , 6.
	self assert: (ray intersectionsWith: polygon) hasCloseElementsTo: {(2 , 3) . (3 , 4)}.
	self assertCollection: (ray intersectionsWith: polygon) hasSameElements: (ray intersectionsWithPolygon: polygon)! !

!GRayTest methodsFor: 'tests' stamp: ''!
testIncludes
	self deny: ((GRay origin: 100 , 100 direction: 80 , 110) includes: 120 , 90).
	self assert: ((GRay origin: 100 , 100 direction: 120 , 90) includes: 120 , 90).
	self assert: ((GRay origin: 100 , 100 direction: 120 , 90) includes: 100 , 100).
	self assert: ((GRay origin: 100 , 100 direction: 110 , 110) includes: 150 , 150).
	self assert: ((GRay origin: 0 , 0 direction: 12 , 9) includes: 13 , (39 / 4)).
	self assert: ((GRay origin: 28 , 30 direction: 9 , 1) includes: -4.97992 , -20.33777)! !

!GRayTest methodsFor: 'tests' stamp: ''!
testTranslateBy
	ray := GRay origin: -1 , -4 direction: 1 , -2.
	ray translateBy: #(1 -2) asGVector.
	self assert: ray initialPoint equals: 0 , -6! !

!GRayTest methodsFor: 'tests' stamp: ''!
testEquals
	| ray2 |
	ray := GRay origin: 0 , 0 direction: 1 , 1.
	ray2 := GRay origin: 0 , 0 direction: 2 , 2.
	self assert: ray equals: ray2.
	self assert: ray hash equals: ray2 hash.

	ray2 := GRay origin: 0,0 direction: 2, 3.
	self deny: ray = ray2.
	self deny: ray hash = ray2 hash! !

!GRayTest methodsFor: 'tests' stamp: ''!
testAngleWith
	| ray2 |
	ray := GRay origin: 0 , 0 direction: 5 , 24.
	ray2 := GRay origin: 3 , 4 direction: 4 , 7.
	self assert: (ray angleWith: ray2) equals: -0.11635 radians! !

!GRayTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithEllipse
	| ellipse |
	ray := GRay origin: 0 , -1 direction: 1 , 4.
	ellipse := GEllipse center: 3.5 , 2 vertex: 6 , 2 coVertex: 3.5 , 4.
	self assert: (ray intersectionsWith: ellipse) isEmpty.

	ray := GRay origin: 2 , 3 direction: 0 , 1.
	self assert: (ray intersectionsWith: ellipse) hasCloseElementsTo: {(1 , 2)}.

	ray := GRay origin: 0 , 1 direction: 5 , 6.
	self assert: (ray intersectionsWith: ellipse) hasCloseElementsTo: {(1 , 2) . (2.951219 , 3.951219)}.
	self assertCollection: (ray intersectionsWith: ellipse) hasSameElements: (ray intersectionsWithEllipse: ellipse)! !

!GRayTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPoint
	| point |
	point := 2 , 4.
	ray := GRay origin: 5 , 6 direction: 7 , 102.
	self assert: (ray intersectionsWith: point) isEmpty.

	ray := GRay origin: 1 , 3 direction: 0 , 2.
	self assert: (ray intersectionsWith: point) isEmpty.

	ray := GRay origin: 0 , 2 direction: 1 , 3.
	self assert: (ray intersectionsWith: point) hasCloseElementsTo: {(2 , 4)}.

	ray := GRay origin: 1 , 3 direction: 3 , 5.
	self assert: (ray intersectionsWith: point) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (ray intersectionsWith: point) hasSameElements: (ray intersectionsWithPoint: point)! !

!GRayTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GRay! !

!GRayTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithSegment
	| segment |
	segment := GSegment with: -2 , 0 with: -2 , 3.
	ray := GRay origin: 0 , 0 direction: 1 , 1.
	self assert: (ray intersectionsWith: segment) isEmpty.

	segment := GSegment with: 2 , 0 with: 2 , 3.
	self assert: (ray intersectionsWith: segment) hasCloseElementsTo: {(2 , 2)}.
	self assertCollection: (ray intersectionsWith: segment) hasSameElements: (ray intersectionsWithSegment: segment).

	ray := GRay origin: 1 , 1 direction: 0 , 0.
	self assert: (ray intersectionsWith: segment) isEmpty! !

!GRayTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithLine
	| line |
	line := GLine through: -5 , 1 and: -3 , 3.	
	ray := GRay origin: -5 , 3  direction: -7, 5 .
	self assert: (ray intersectionsWith: line) isEmpty.
	
	ray := GRay origin: -7 , 5  direction: -5, 3 .
	self assert: (ray intersectionsWith: line) hasCloseElementsTo: {(-4 , 2)}.
	self assertCollection: (ray intersectionsWith: line) hasSameElements: (ray intersectionsWithLine: line)! !

!GRayTest methodsFor: 'tests' stamp: ''!
testFlipped
	self assert: (GRay origin: 100 , 100 direction: 80 , 110) flipped directionPoint equals: 120 , 90.
	self assert: (GRay origin: 100 , 100 direction: 120 , 90) flipped directionPoint equals: 80 , 110! !

!GRayTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithRay
	| ray2 |
	ray2 := GRay origin: -2 , 0 direction: -2 , 3.
	ray := GRay origin: 0 , 0 direction: 1 , 1.
	self assert: (ray2 intersectionsWithRay: ray) isEmpty.

	ray2 := GRay origin: 2 , 3 direction: 2 , 0.
	self assert: (ray2 intersectionsWith: ray) hasCloseElementsTo: {(2 , 2)}.
	self assertCollection: (ray2 intersectionsWith: ray) hasSameElements: (ray2 intersectionsWithRay: ray).

	ray := GRay origin: 1 , 1 direction: 0 , 0.
	self assert: (ray2 intersectionsWith: ray) isEmpty! !

!GRayTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithArc
	| arc |
	ray := GRay origin: 0 , 0 direction: 1 , 1.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (ray intersectionsWith: arc) isEmpty.

	arc := GArc center: -1 , 0 origin: 4 , 0 direction: 1 , 4.
	self assert: (ray flipped intersectionsWith: arc) isEmpty.

	self assert: (ray intersectionsWith: arc) hasCloseElementsTo: {(3 , 3)}.
	self assertCollection: (ray intersectionsWith: arc) hasSameElements: (ray intersectionsWithArc: arc)! !

!GRectangle commentStamp: ''!
I am a rectangle. See my parent for API!
!GRectangle methodsFor: 'accessing' stamp: ''!
center
	"Answer the point at the center of the receiver."

	^ self diagonals anyOne midPoint! !

!GRectangle methodsFor: 'accessing' stamp: ''!
width
	"Answer the width of the receiver."

	^ (self vertices at: 2) distanceTo: (self vertices at: 1)! !

!GRectangle methodsFor: 'accessing' stamp: ''!
diagonals
	^ {((self vertices at: 1) segment: (self vertices at: 3)).
	((self vertices at: 2) segment: (self vertices at: 4))}! !

!GRectangle methodsFor: 'accessing' stamp: ''!
area
	"Answer the receiver's area, the product of width and height."

	^ self width * self height max: 0! !

!GRectangle methodsFor: 'accessing' stamp: ''!
extent
	"Answer a vector representing the extent of my encompassing rectangle."

	| verticesCoordinates encompassingRectangleOrigin encompassingRectangleCorner |
	verticesCoordinates := self vertices collect: #coordinates.
	encompassingRectangleOrigin := verticesCoordinates fold: [:coor1 :coor2 | coor1 upperLimitsWith: coor2].
	encompassingRectangleCorner := verticesCoordinates fold: [:coor1 :coor2 | coor1 lowerLimitsWith: coor2].
	^ (encompassingRectangleOrigin - encompassingRectangleCorner) asGVector! !

!GRectangle methodsFor: 'accessing' stamp: ''!
height
	"Answer the height of the receiver."

	^ (self vertices at: 2) distanceTo: (self vertices at: 3)! !

!GRectangle class methodsFor: 'instance creation' stamp: ''!
left: left right: right top: top bottom: bottom
	"Answer an instance of me whose left, right, top, and bottom coordinates 
	are determined by the arguments."

	| origin corner |
	origin := (left min: right) @ (top min: bottom).
	corner := (left max: right) @ (top max: bottom).

	^ self origin: origin corner: corner! !

!GRectangle class methodsFor: 'instance creation' stamp: ''!
origin: point1 corner: point2
	"Answer an instance of me whose corners (top left and bottom right) are 
	determined by the arguments."

	| or cor |
	or := (point1 x min: point2 x) , (point1 y min: point2 y).
	cor := (point1 x max: point2 x) , (point1 y max: point2 y).
	
	or = cor ifTrue: [ self error: 'This is not a rectangle but a point.' ].
	
	^ self vertices: { or . (cor x , or y). cor. (or x , cor y) }! !

!GRectangle class methodsFor: 'instance creation' stamp: ''!
vertices: aCollection
	| rectangle edges |
	
	aCollection size = 4 ifFalse: [ self error: 'A Rectangle should have 4 vertices.' ].
	
	rectangle := super vertices: aCollection.
	
	edges := rectangle edges.
	
	(((edges at: 1) length = (edges at: 3) length) and: [ ((edges at: 2) length = (edges at: 4) length) ]) ifFalse: [ self error: 'This is not a rectangle but a parallelogram' ].
	
	^ rectangle! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testBoundaryContains
	self assert: ((GRectangle origin: 1 , 3 corner: 3 , 0) boundaryContains: 1 , 3).
	self assert: ((GRectangle origin: 1 , 3 corner: 3 , 0) boundaryContains: 2 , 3).
	self deny: ((GRectangle origin: 1 , 3 corner: 3 , 0) boundaryContains: 0 , 0)! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testHeight
	self assert: rectangle height equals: 10! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testDiagonals
	rectangle := GRectangle vertices: {(1 , 1) . (5 , 1) . (5 , 6) . (1 , 6)}.
	self assertCollection: rectangle diagonals hasSameElements: {(GSegment with: 1 , 6 with: 5 , 1) . (GSegment with: 5 , 6 with: 1 , 1)}.

	rectangle := GRectangle vertices: {(1 , 3) . (2 , 1) . (5 , 4) . (4 , 6)}.
	self assertCollection: rectangle diagonals hasSameElements: {(GSegment with: 1 , 3 with: 5 , 4) . (GSegment with: 4 , 6 with: 2 , 1)}.

	rectangle := GRectangle vertices: {(1 , 3) . (4 , 6) . (5 , 4) . (2 , 1)}.
	self assertCollection: rectangle diagonals hasSameElements: {(GSegment with: 1 , 3 with: 5 , 4) . (GSegment with: 4 , 6 with: 2 , 1)}! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testIncludes
	self assert: (rectangle includes: 11 , 11).
	self assert: (rectangle includes: 10 , 10).
	self deny: (rectangle includes: 9 , 9).
	self deny: (rectangle includes: 21 , 21).
	self deny: (rectangle includes: 15 , 21).
	self deny: (rectangle includes: 9 , 15).
	self assert: ((GRectangle origin: 1 , 3 corner: 3 , 0) includes: 2 , 1).
	self deny: ((GRectangle origin: 1 , 3 corner: 3 , 0) includes: 0 , 0)! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testEquals
	rectangle := GRectangle origin: 0 , 0 corner: 5 , 5.
	self assert: rectangle equals: (GRectangle origin: 0 , 0 corner: 5 , 5).
	self assert: rectangle hash equals: (GRectangle origin: 0 , 0 corner: 5 , 5) hash.
	self deny: rectangle = (GRectangle origin: 1 , 0 corner: 5 , 5).
	self deny: rectangle hash = (GRectangle origin: 1 , 0 corner: 5 , 5) hash! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testWidth
	self assert: rectangle width equals: 10! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testVertices
	self should: [ GRectangle vertices: {(1 , 1) . (2 , 2) . (3 , 5)} ] raise: GeometryError.
	self should: [ GRectangle vertices: {(0 , 0) . (2 , 0) . (2 , -2) . (-1 , -2)} ] raise: GeometryError! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testExpandBy
	rectangle := GRectangle vertices: {(-1 , -1) . (-1 , 1) . (1 , 1) . (1 , -1)}.
	rectangle expandBy: 0.5.
	self assert: rectangle equals: (GRectangle vertices: {(-1.5 , -1.5) . (-1.5 , 1.5) . (1.5 , 1.5) . (1.5 , -1.5)}).

	rectangle := GRectangle vertices: {(-2 , -1) . (-2 , 1) . (2 , 1) . (2 , -1)}.
	rectangle expandBy: 0.5.
	self assert: rectangle equals: (GRectangle vertices: {(-2.5 , -1.5) . (-2.5 , 1.5) . (2.5 , 1.5) . (2.5 , -1.5)})! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testArea
	self assert: (GRectangle origin: 0 , 0 corner: 5 , 5) area equals: 25.
	self assert: (GRectangle origin: 2 , 3 corner: 10 , 8) area equals: 40.
	self assert: (GRectangle origin: 5 , 5 corner: 6 , 6) area equals: 1.
	self assert: (GRectangle origin: -1 , -2 corner: 2 , 1) area equals: 9! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testCenter
	| translated1 translated2 |
	rectangle := GRectangle vertices: {(1 , 1) . (5 , 1) . (5 , 6) . (1 , 6)}.
	self assert: rectangle center equals: 3, (7/2).

	rectangle := GRectangle vertices: {(1 , 3) . (2 , 1) . (5 , 4) . (4 , 6)}.
	self assert: rectangle center equals: 3, (7/2).

	rectangle := GRectangle vertices: {(1 , 3) . (4 , 6) . (5 , 4) . (2 , 1)}.
	self assert: rectangle center equals: 3, (7/2).
	
	rectangle := GRectangle vertices: {(1 , 3) . (4 , 6) . (5 , 4) . (2 , 1)}.
	translated1 := rectangle translateBy: #(1 2) asGVector.
	rectangle := GRectangle vertices: {(1 , 3) . (4 , 6) . (5 , 4) . (2 , 1)}.
	translated2 := rectangle translateBy: #(1 2) asGVector.
	self assert: translated1 center = translated2 center description: 'the center is translated with the rectangle'! !

!GRectangleTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GRectangle! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testExtent
	rectangle := GRectangle vertices: {(1 , 1) . (5 , 1) . (5 , 6) . (1 , 6)}.
	self assert: rectangle extent equals: #(4 5) asGVector.

	rectangle := GRectangle vertices: {(1 , 3) . (2 , 1) . (5 , 4) . (4 , 6)}.
	self assert: rectangle extent equals: #(4 5) asGVector.

	rectangle := GRectangle vertices: {(1 , 3) . (4 , 6) . (5 , 4) . (2 , 1)}.
	self assert: rectangle extent equals: #(4 5) asGVector! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithLine
	| intersections |
	intersections := (GRectangle origin: 1 , 3 corner: 3 , 0) intersectionsWithLine: (GSegment with: 0 , 3 with: 4 , 1) asGLine.
	self assert: intersections hasCloseElementsTo: {(1 , (5 / 2)) . (3 , (3 / 2))}! !

!GRectangleTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithRay
	self assert: ((GRectangle origin: 1 , 3 corner: 3 , 0) intersectionsWithRay: (GRay origin: 2 , 1 direction: 4 , 1)) hasCloseElementsTo: {(3 , 1)}! !

!GRectangleTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	rectangle := GRectangle origin: 10 , 10 corner: 20 , 20! !

!GSegment commentStamp: ''!
Description
--------------------

I am a geometric segment. I am defined by two points which are my limits.

As a goemetric segment, I have no direction, so the order of the two points during the creation has no importance.

Examples
--------------------

	GSegment with: 1 , 2 with: 3 , 4.
	
	(GSegment with: 1 , 3 with: 3 , 0) includes: 1 , 3.
	
	(GSegment with: -1 , -1 with: 1 , 1) intersectionsWith: (GSegment with: -3 , 3 with: -1 , 1).
	
	(GSegment with: 0 , 0 with: 3 , 4) length.
	
	(GSegment with: -1 , 2 with: 2 , 1) midPoint.
	
	(GSegment with: -1 , -4 with: 1 , -2) translateBy: #(1 -2) asGVector.
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	v1:		<aGPoint>		One of the two limit of the segment.
	v2:		<aGPoint>		Second limit of the segment. 
!
!GSegment methodsFor: 'properties' stamp: ''!
midPoint
	^ ((v1 coordinates + v2 coordinates) / 2) asGPoint! !

!GSegment methodsFor: 'arithmetic' stamp: ''!
angleWith: aSegment
	^ self v1 - self v2 angleWith: aSegment v1 - aSegment v2! !

!GSegment methodsFor: 'accessing' stamp: ''!
v1
	^ v1! !

!GSegment methodsFor: 'comparing' stamp: ''!
= aSegment
	self == aSegment ifTrue: [ ^ true ].
	self class = aSegment class ifFalse: [ ^ false ].
	
	^ (v1 =~ aSegment v1 and: [ v2 =~ aSegment v2 ])
		or: [ v1 =~ aSegment v2 and: [ v2 =~ aSegment v1 ] ]! !

!GSegment methodsFor: 'properties' stamp: ''!
includes: aGPoint
	"The point is on the segment if the sum of the distance from v1 to aGPoint and the distance of a GPoint to v2 is my length"

	^ (v2 distanceTo: aGPoint) + (aGPoint distanceTo: v1) =~ self length! !

!GSegment methodsFor: 'comparing' stamp: ''!
hash
	^ v1 hash bitXor: v2 hash! !

!GSegment methodsFor: 'accessing' stamp: ''!
v2
	^ v2! !

!GSegment methodsFor: 'properties' stamp: ''!
asGLine
	^ GLine through: v1 and: v2! !

!GSegment methodsFor: 'intersections' stamp: ''!
intersectionsWith: anElement
	^ anElement intersectionsWithSegment: self! !

!GSegment methodsFor: 'transforming' stamp: ''!
translateBy: aGVector 
	v1 := v1 + aGVector.
	v2 := v2 + aGVector! !

!GSegment methodsFor: 'accessing' stamp: ''!
v2: aGPoint
	v2 := aGPoint asGPoint! !

!GSegment methodsFor: 'intersections' stamp: ''!
intersectionsWithLine: aLine
	^ aLine intersectionsWithSegment: self! !

!GSegment methodsFor: 'printing' stamp: ''!
printOn: aStream
	v1 coordinates printOn: aStream.
	aStream nextPutAll: '>-<'.
	v2 coordinates printOn: aStream! !

!GSegment methodsFor: 'intersections' stamp: ''!
intersectionsWithEllipse: aGEllipse 
	^ aGEllipse intersectionsWithSegment: self! !

!GSegment methodsFor: 'initialization' stamp: ''!
vertices
	^ { v1 . v2 }! !

!GSegment methodsFor: 'properties' stamp: ''!
distanceTo: aGPoint
	self flag: #todo.	"«The distance between segments and rays may not be the same as the distance between their extended lines. » http://geomalgorithms.com/a07-_distance.html
	
	So apparently this implementation is wrong."
	^ self asGLine distanceTo: aGPoint! !

!GSegment methodsFor: 'properties' stamp: ''!
perpendicularBisector
	self flag: #todo.	"This is only for 2D. We should rely on GPoints to be able to do it for n-dimensions."

	^ GLine a: v2 x - v1 x b: v2 y - v1 y c: (v1 x * v1 x - (v2 x * v2 x) + (v1 y * v1 y) - (v2 y * v2 y)) / 2! !

!GSegment methodsFor: 'properties' stamp: ''!
length
	"The distance between two points is the length of the vector transposing v1 into v2"

	^ (v2 - v1) length! !

!GSegment methodsFor: 'accessing' stamp: ''!
v1: aGPoint
	v1 := aGPoint asGPoint! !

!GSegment class methodsFor: 'instance creation' stamp: ''!
with: aPoint1 with: aPoint2
	^ self new
		v1: aPoint1;
		v2: aPoint2;
		yourself! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPolygon
	| polygon |
	segment := GSegment with: 0 , -1 with: 0 , 4.
	polygon := GPolygon vertices: {(1 , 4) . (6 , 4) . (6 , 1) . (3 , 2)}.
	self assert: (segment intersectionsWith: polygon) isEmpty.

	segment := GSegment with: 0 , -1 with: 1 , 3.
	self assert: (segment intersectionsWith: polygon) isEmpty.

	segment := GSegment with: 0 , 1 with: 5 , 6.
	self assert: (segment intersectionsWith: polygon) hasCloseElementsTo: {(2 , 3) . (3 , 4)}.
	self assertCollection: (segment intersectionsWith: polygon) hasSameElements: (segment intersectionsWithPolygon: polygon)! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testIncludes
	self assert: ((GSegment with: 1 , 3 with: 3 , 0) includes: 1 , 3).
	self assert: ((GSegment with: 1 , 3 with: 3 , 0) includes: 3 , 0).
	self assert: ((GSegment with: -1 , 1 with: 1 , -1) includes: 0 , 0).
	self deny: ((GSegment with: 0 , 0 with: 12 , 9) includes: 13 , (39 / 4)).
	self assert: ((GSegment with: 0 , 0 with: 13 , (39 / 4)) includes: 12 , 9)! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testTranslateBy
	segment := GSegment with: -1 , -4 with: 1 , -2.
	segment translateBy: #(1 -2) asGVector.
	self assert: segment v1 equals: 0 , -6.
	self assert: segment v2 equals: 2 , -4! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testEquals
	| segm1 segm2 |
	self flag: #pharo6. "Use #deny:equals: when Pharo 7 will be the minimum requirement"
	segm1 := GSegment with: 1 , 2 with: 3 , 4.
	segm2 := GSegment with: 0 , 0 with: 3 , 3.
	self deny: segm1 = segm2.
	self deny: segm1 asGLine = segm2 asGLine.
	self deny: segm1 hash = segm2 hash.
	
	segm1 := GSegment with: 1 , 1 with: 3 , 3.
	segm2 := GSegment with: 0 , 0 with: 3 , 3.
	self assert: segm1 asGLine equals: segm2 asGLine.
	self deny: segm1 = segm2.
	
	segm1 := GSegment with: -24.494897427831784 , -24.494897427831795 with: 24.494897427831784 , 24.49489742783178.
	segm2 := GSegment with: 24.494897427831784 , 24.49489742783178 with: -24.494897427831784 , -24.494897427831795.
	self assert: segm1 asGLine equals: segm2 asGLine .
	
	segm1 := GSegment with: -24.494897427831784 , -24.494897427831795 with: 24.494897427831784 , 24.49489742783178.
	segm2 := GSegment with: 24.494897427831784 , 24.49489742783178 with: -24.494897427831784 , -24.494897427831795.
	self assert: segm1 equals: segm2.
	self assert: segm1 hash equals: segm2 hash.
	
	self assert: (GSegment with: -1 , -1 with: 1 , 1) equals: (GSegment with: 1 , 1 with: -1 , -1).
	self deny: (GSegment with: -1 , -1 with: 1 , 1) = (GSegment with: -1 , 1 with: -1 , 1).! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testAsGLine
	| line |
	line := (GSegment with: 1 , 3 with: 3 , 0) asGLine.
	self assert: line a equals: 3.
	self assert: line b equals: 2.
	self assert: line c equals: -9.
	
	line := (GSegment with: -2 , 4 with: 2 , 4) asGLine.
	self assert: line a equals: 0.
	self assert: line b equals: 1.
	self assert: line c equals: -4.
	
	line := (GSegment with: 1 , 3 with: 1 , 0) asGLine.
	self assert: line a equals: 1.
	self assert: line b equals: 0.
	self assert: line c equals: -1! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testPerpendicularBisector
	self assert: (GSegment with: -1 , 2 with: 0 , 0) perpendicularBisector equals: (GLine a: -1 b: 2 c: -2.5).
	self assert: (GSegment with: 1 , 3 with: -1 , 1) perpendicularBisector equals: (GLine a: -2 b: -2 c: 4).
	self assert: (GSegment with: 3 , 0 with: 1 , 3) perpendicularBisector equals: (GLine a: -2 b: 3 c: -1 / 2)! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testAngleWith
	| segment2 |
	segment := GSegment with: 0 , 0 with: 5 , 24.
	segment2 := GSegment with: 3 , 4 with: 4 , 7.
	self assert: (segment angleWith: segment2) equals: -0.11635 radians! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testDistanceTo
	self assert: ((GSegment with: -2 , 4 with: 2 , 4) distanceTo: -2 , 4) equals: 0.
	self assert: ((GSegment with: -2 , 4 with: 2 , 4) distanceTo: 2 , 4) equals: 0.
	self assert: ((GSegment with: 477 / 11 , (149 / 2) with: -56.73661227723915 , 143.3189209406019) distanceTo: 36819 / 1022 , (82249 / 1022)) =~ 0.7697676365059569.
	self assert: ((GSegment with: 838 / 41 , (4811 / 82) with: 57583 / 914 , (56095 / 914)) distanceTo: 57.998905906959145 , 61.11074842728413) =~ (2 * 0.02757564283371476)! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testSegmentFromPoints
	self assert: (1 , 2 segment: 2 , 3) equals: (GSegment with: 1 , 2 with: 2 , 3)! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithEllipse
	| ellipse |
	segment := GSegment with: 0 , -1 with: 1 , 4.
	ellipse := GEllipse center: 3.5 , 2 vertex: 6 , 2 coVertex: 3.5 , 4.
	self assert: (segment intersectionsWith: ellipse) isEmpty.

	segment := GSegment with: 0 , 1 with: 2 , 3.
	self assert: (segment intersectionsWith: ellipse) hasCloseElementsTo: {(1 , 2)}.

	segment := GSegment with: 0 , 1 with: 5 , 6.
	self assert: (segment intersectionsWith: ellipse) hasCloseElementsTo: {(1 , 2) . (2.951219 , 3.951219)}.
	self assertCollection: (segment intersectionsWith: ellipse) hasSameElements: (segment intersectionsWithEllipse: ellipse)! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testLength
	self assert: (GSegment with: 0 , 0 with: 3 , 4) length equals: 5.
	self assert: (GSegment with: -2 , 1 with: 3 , 4) length equals: 34 sqrt! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithPoint
	| point |
	point := 2 , 4.
	segment := GSegment with: 5 , 6 with: 7 , 102.
	self assert: (segment intersectionsWith: point) isEmpty.

	segment := GSegment with: 1 , 3 with: 0 , 2.
	self assert: (segment intersectionsWith: point) isEmpty.

	segment := GSegment with: 1 , 3 with: 3 , 5.
	self assert: (segment intersectionsWith: point) hasCloseElementsTo: {(2 , 4)}.
	self assertCollection: (segment intersectionsWith: point) hasSameElements: (segment intersectionsWithPoint: point)! !

!GSegmentTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GSegment! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithSegment
	| segment2 |
	segment := GSegment with: -1 , -1 with: 1 , 1.
	segment2 := GSegment with: -3 , 3 with: -1 , 1.
	self assert: (segment intersectionsWith: segment2) isEmpty.

	segment := GSegment with: -3 , 1 with: -4 , 0.
	self assert: (segment intersectionsWith: segment2) isEmpty.

	segment := GSegment with: 0 , 1 with: 3 , 1.
	segment2 := GSegment with: 0 , 3 with: 4 , -1.
	self assert: (segment intersectionsWith: segment2) hasCloseElementsTo: {(2 , 1)}.
	self assertCollection: (segment intersectionsWith: segment2) hasSameElements: (segment intersectionsWithSegment: segment2).

	segment2 := GSegment with: 0 , 1 with: 2 , 8.
	self assert: (segment intersectionsWith: segment2) hasCloseElementsTo: {(0 , 1)}! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithLine
	| line |
	line := GLine through: -5 , 1 and: -3 , 3.
	segment := GSegment with: -7 , 2  with: -4, 3 .
	self assert: (segment intersectionsWith: line) isEmpty.
	
	segment := GSegment with: -6 , 4  with: -3, 1 .
	self assert: (segment intersectionsWith: line) hasCloseElementsTo: {(-4 , 2)}.
	self assertCollection: (segment intersectionsWith: line) hasSameElements: (segment intersectionsWithLine: line)! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testMidPoint
	self assert: (GSegment with: -1 , 2 with: 2 , 1) midPoint equals: 0.5 , 1.5.
	self assert: (GSegment with: 2 , 1 with: 2 , 1) midPoint equals: 2 , 1! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithRay
	| ray |
	segment := GSegment with: -2 , 0 with: -2 , 3.
	ray := GRay origin: 0 , 0 direction: 1 , 1.
	self assert: (segment intersectionsWithRay: ray) isEmpty.

	segment := GSegment with: 2 , 0 with: 2 , 3.
	self assert: (segment intersectionsWith: ray) hasCloseElementsTo: {(2 , 2)}.
	self assertCollection: (segment intersectionsWith: ray) hasSameElements: (segment intersectionsWithRay: ray).

	ray := GRay origin: 1 , 1 direction: 0 , 0.
	self assert: (segment intersectionsWith: ray) isEmpty! !

!GSegmentTest methodsFor: 'tests' stamp: ''!
testIntersectionsWithArc
	| arc |
	segment := GSegment with: 0 , 0 with: 1 , 1.
	arc := GArc center: 1 , 0 origin: 4 , 0 direction: 3 , 2.
	self assert: (segment intersectionsWith: arc) isEmpty.

	arc := GArc center: -1 , 0 origin: 4 , 0 direction: 1 , 4.
	self assert: (segment intersectionsWith: arc) isEmpty.

	segment := GSegment with: 0 , 0 with: 4 , 4.
	self assert: (segment intersectionsWith: arc) hasCloseElementsTo: {(3 , 3)}.
	self assertCollection: (segment intersectionsWith: arc) hasSameElements: (segment intersectionsWithArc: arc)! !

!GShape commentStamp: ''!
Description
--------------------

I am a common superclass for all shapes elements.

I define the minimal API each elements should be able to answer to.!
!GShape methodsFor: 'properties' stamp: ''!
semiperimeter
	^ self perimeter / 2! !

!GShape methodsFor: 'accessing' stamp: ''!
center
	^ self encompassingRectangle center! !

!GShape methodsFor: 'transforming' stamp: ''!
scaleBy: aPoint
	"Scale the shape by a delta defined by a point."
	
	self subclassResponsibility! !

!GShape methodsFor: 'accessing' stamp: ''!
area
	"Return the area of the shape"
	
	^ self subclassResponsibility! !

!GShape methodsFor: 'accessing' stamp: ''!
extent
	"I return a vector representing the extent of the encompassing rectangle of the shape. I should be able to translate the corner of the encompassing rectangle to its origin."
	
	^ self encompassingRectangle extent! !

!GShape methodsFor: 'accessing' stamp: ''!
encompassingRectangle
	"I should return a rectangle on the minimum size that contains the shape"
	
	^ self subclassResponsibility! !

!GShape methodsFor: 'accessing' stamp: ''!
perimeter
	"Return the perimeter of the shape"
	
	^ self subclassResponsibility! !

!GShape methodsFor: 'transforming' stamp: ''!
fitInExtent: anExtent
	"I should transform my shape to fit in a rectangle of size 0@0 to the extent as parameter, keeping my center.
	Note that I should keep proportions. We could maybe implement another method to not keep proportions."
	
	self subclassResponsibility! !

!GShape class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = GShape! !

!GShapeTestCase methodsFor: 'accessing' stamp: ''!
testBoundaryContains
	^ self subclassResponsibility! !

!GShapeTestCase methodsFor: 'accessing' stamp: ''!
testEncompassingRectangle
	^ self subclassResponsibility! !

!GShapeTestCase methodsFor: 'accessing' stamp: ''!
testFitInExtent
	^ self subclassResponsibility! !

!GShapeTestCase class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = GShapeTestCase! !

!GTestCase methodsFor: 'tests' stamp: ''!
testErrorsArePersonnalized
	self should: [ self newInstance error ] raise: GeometryError.
	self should: [ self newInstance error: 'Error' ] raise: GeometryError! !

!GTestCase methodsFor: 'accessing' stamp: ''!
testEquals
	^ self subclassResponsibility! !

!GTestCase methodsFor: 'asserting' stamp: ''!
assert: aCollection hasCloseElementsTo: anotherCollection
	"Assertion pass if the collections have the same elements using the =~ comparaison operator."

	self
		assert: (aCollection size = anotherCollection size and: [ aCollection allSatisfy: [ :each | anotherCollection anySatisfy: [ :expected | expected =~ each ] ] ])
		description:
			(String
				streamContents: [ :stream | 
					stream
						nextPutAll: 'Given Collections do not match!!';
						lf;
						tab;
						nextPutAll: 'Expecting : ';
						print: anotherCollection asArray;
						lf;
						tab;
						nextPutAll: 'Got : ';
						print: aCollection asArray;
						lf ])! !

!GTestCase methodsFor: 'accessing' stamp: ''!
newInstance
	^ self actualClass new! !

!GTestCase methodsFor: 'accessing' stamp: ''!
actualClass
	^ self subclassResponsibility! !

!GTestCase class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!GTestCase class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = GTestCase! !

!GTriangle commentStamp: ''!
I am a triangle!
!GTriangle methodsFor: 'accessing' stamp: ''!
v1
	^ vertices at: 1! !

!GTriangle methodsFor: 'figures' stamp: ''!
circumscribedCircle
	^ (self edges first perpendicularBisector intersectionsWith: self edges last perpendicularBisector)
		ifNotEmpty: [ :points | GCircle center: points anyOne radius: (self v1 distanceTo: self v2) * (self v2 distanceTo: self v3) * (self v3 distanceTo: self v1) / (4 * self area) ]! !

!GTriangle methodsFor: 'accessing' stamp: ''!
v2
	^ vertices at: 2! !

!GTriangle methodsFor: 'properties' stamp: ''!
area
	| semiperimeter|
	semiperimeter := self semiperimeter.

	^ (self edges 
		inject: semiperimeter
		into: [ :subProduct :edge |
			(semiperimeter - edge length) * subProduct ]) sqrt! !

!GTriangle methodsFor: 'accessing' stamp: ''!
v3
	^ vertices at: 3! !

!GTriangle methodsFor: 'figures' stamp: ''!
isDegenerate
	^ (self v1 = self v2 or: [ self v1 = self v3 or: [ self v2 = self v3 ] ])
		ifTrue: [ true ]
		ifFalse: [ self edges first length + self edges second length = self edges third length
				or: [ self edges second length + self edges third length = self edges first length or: [ self edges third length + self edges first length = self edges second length ] ] ]! !

!GTriangle class methodsFor: 'instance creation' stamp: ''!
with: aPoint1 with: aPoint2 with: aPoint3
	^ self vertices: { aPoint1. aPoint2. aPoint3 }! !

!GTriangle class methodsFor: 'instance creation' stamp: ''!
vertices: aCollection	
	aCollection size = 3 ifFalse: [ self error: 'A triangle should have 3 vertices.' ].

	^ super vertices: aCollection! !

!GTriangleTest methodsFor: 'tests' stamp: ''!
testEquals
	triangle := GTriangle with: 0 , 0 with: 2 , 0 with: 0 , 2.
	self assert: triangle equals: (GTriangle with: 0 , 0 with: 2 , 0 with: 0 , 2).
	self assert: triangle hash equals: (GTriangle with: 0 , 0 with: 2 , 0 with: 0 , 2) hash.
	self deny: triangle = (GTriangle with: 1 , 0 with: 2 , 0 with: 0 , 2).
	self deny: triangle hash = (GTriangle with: 1 , 0 with: 2 , 0 with: 0 , 2) hash! !

!GTriangleTest methodsFor: 'tests' stamp: ''!
testIsDegenerate
	self assert: (GTriangle with: 0 , 0 with: 2 , 0 with: 3 , 0) isDegenerate.
	self deny: (GTriangle with: 0 , 0 with: 2 , 0 with: 0 , 3) isDegenerate.
	self assert: (GTriangle with: 1 , 0 with: 1 , 2 with: 1 , -1) isDegenerate.
	self assert: (GTriangle with: 1 , 1 with: 3 , 3 with: 2 , 2) isDegenerate.
	self assert: (GTriangle with: 1 , 1 with: 2 , 2 with: 3 , 3) isDegenerate.
	self deny: (GTriangle with: 1 , 1 with: 2 , 2 with: 2 , 1) isDegenerate.
	self assert: (GTriangle with: 1.9357176033002985e-6 , 212.13203242024665 with: 1.1175870793405243e-6 , 122.47448602157178 with: 1.5805068047363063e-6 , 173.2050791763809) isDegenerate.
	self deny: (GTriangle with: 1.9357176033002985e-6 , 212.13203242024665 with: -2.7375180875116245e-6 , 299.9999972624819 with: 1.5805068047363063e-6 , 173.2050791763809) isDegenerate.
	self deny: (GTriangle with: 1.9357176033002985e-6 , 212.13203242024665 with: -2.7375180875116245e-6 , 299.9999972624819 with: 1.1175870793405243e-6 , 122.47448602157178) isDegenerate.
	self assert: (GTriangle with: -10 , -30 with: -30 , -10 with: -10 , -30) isDegenerate! !

!GTriangleTest methodsFor: 'tests' stamp: ''!
testCircumscribedCircle
	| circle |
	circle := (GTriangle with: -1 , 2 with: 0 , 0 with: 2 , 1) circumscribedCircle.
	self assert: circle center equals: 0.5 , 1.5.
	self assert: (circle radius closeTo: 10 sqrt / 2).

	circle := (GTriangle with: -1 , 1 with: 3 , 0 with: 1 , 3) circumscribedCircle.
	self assert: circle center equals: (11 / 10) , (9 / 10).
	self assert: (circle radius closeTo: (1 + (21 * 21)) sqrt / 10).
	
	circle := (GTriangle with: -1 , 1 with: 2 , 3 with: 5 , -3) circumscribedCircle.
	self assert: circle center equals: (9 / 4) , (-5 / 8).
	self assert: (circle radius closeTo: 5 sqrt * 13 / 8).
	
	circle := (GTriangle with: 2 , 3 with: 7 , 4 with: 5 , 7) circumscribedCircle.
	self assert: circle center equals: (147 / 34) , (149 / 34)! !

!GTriangleTest methodsFor: 'tests' stamp: ''!
testArea
	self assert: ((GTriangle with: 0 , 0 with: 2 , 0 with: 0 , 2) area closeTo: 2)! !

!GTriangleTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GTriangle! !

!GTriangleTest methodsFor: 'tests' stamp: ''!
testSemiperimeter
	self assert: (GTriangle with: 0 , 0 with: 2 , 0 with: 0 , 2) semiperimeter equals: 2 + 2 sqrt! !

!GTriangleTest methodsFor: 'tests' stamp: ''!
testPerimeter
	self assert: (GTriangle with: 0 , 0 with: 2 , 0 with: 0 , 2) perimeter equals: 4 + 8 sqrt! !

!GVector commentStamp: ''!
Description
--------------------

I represent a geometric vector. I have a state close to the state of a GPoint but a vector only represent a direction and a length.

My direction will go from the origin of the plan ( (0, 0) in a 2D plan) to my coordinates. My length will be defined by my coordinates.

Examples
--------------------

	"Instance creation"
	GVector withCollection: #(1 2).	 "a GVector(1,2)"
	
	GVector coordinates: (GCoordinates withCollection: #(1 3)). 	"a GVector(1,3)"
	
	(GCoordinates withCollection: #(1 3)) asGVector.	"a GVector(1,3)"
	
	#(1 2) asGVector.	"a GVector(1,2)"	
			
	"Arithmetic"	
	#(3 5) asGVector length.	"5.830951894845301"
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	coordinates:		<GCoordinates> 	Coordinates defining my direction and length.
!
!GVector methodsFor: 'arithmetic' stamp: ''!
angleWith: aGVector
	| angle |
	self flag: #todo.	"This implementation is only for 2D vectors. Later we should support it for n-dimension vectors."
	self coordinates numberOfDimensions ~= 2 ifTrue: [ self error: 'For now oriented angle is only implemented for 2D vectors. Feel free to contribute.' ]. 
	
	angle := self nonOrientedAngleWith: aGVector.

	^ (GMatrix rows: {self coordinates . aGVector coordinates}) determinant > 0 ifTrue: [ angle ] ifFalse: [ angle explementary ]! !

!GVector methodsFor: 'comparing' stamp: ''!
= anotherPoint
	"Answer whether the receiver and anObject represent the same object."

	self == anotherPoint ifTrue: [ ^ true ].
	self class = anotherPoint class ifFalse: [ ^ false ].

	^ coordinates = anotherPoint coordinates! !

!GVector methodsFor: 'arithmetic' stamp: ''!
* anOperand
	^ anOperand multiplyWithVector: self! !

!GVector methodsFor: 'accessing' stamp: ''!
coordinates: anObject
	coordinates := anObject! !

!GVector methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	| coordHash |
	coordHash := coordinates hash.
	^ coordHash squared + coordHash "Try to avoid collisions with GAbstractCoordinates and GPoint"! !

!GVector methodsFor: 'arithmetic' stamp: ''!
nonOrientedAngleWith: aGVector
	"angle = cos^-1 a . b / (|a| * |b|)"

	"If we have a zero vector, delegate it the computation to avoid a zero divide."

	aGVector isZeroVector ifTrue: [ ^ aGVector angleWith: self ].

	^ ([ ((self dotProduct: aGVector) / (self length * aGVector length)) arcCos ]
		on: DomainError
		do:
			[ "Sometimes we can get a Domain Error because of some missprecision of floats... In that case we will reduce the precision to get a result" ((self dotProduct: aGVector) / (self length * aGVector length) roundTo: 0.00000000000001) arcCos ]) radians! !

!GVector methodsFor: 'arithmetic' stamp: ''!
/ aGVector 
	self shouldBeImplemented.! !

!GVector methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self coordinates: self coordinates copy! !

!GVector methodsFor: 'arithmetic' stamp: ''!
additionWithVector: aGVector
	^ (self coordinates + aGVector coordinates) asGVector! !

!GVector methodsFor: 'accessing' stamp: ''!
y: aNumber 
	self coordinates y: aNumber! !

!GVector methodsFor: 'enumerating' stamp: ''!
coordinatesWith: aCollection do: aBlock
	self coordinates coordinatesWith: aCollection coordinates do: aBlock! !

!GVector methodsFor: 'accessing' stamp: ''!
x
	^ self coordinates x! !

!GVector methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	self coordinates printCoordinatesOn: aStream! !

!GVector methodsFor: 'accessing' stamp: ''!
x: aNumber 
	self coordinates x: aNumber! !

!GVector methodsFor: 'arithmetic' stamp: ''!
multiplyWithVector: aGVector
	"We should implement vector product later."
	
	self shouldBeImplemented! !

!GVector methodsFor: 'accessing' stamp: ''!
y
	^ self coordinates y! !

!GVector methodsFor: 'accessing' stamp: ''!
coordinates
	^ coordinates! !

!GVector methodsFor: 'arithmetic' stamp: ''!
adaptToNumber: anInteger andSend: aString 
	^ self perform: aString with: anInteger! !

!GVector methodsFor: 'accessing' stamp: ''!
length
	"https://onlinemschool.com/math/library/vector/length/"

	^ (self coordinates inject: 0 into: [ :res :number | res + number squared ]) sqrt! !

!GVector methodsFor: 'enumerating' stamp: ''!
coordinatesWith: aCollection collect: aBlock
	^ self coordinates coordinatesWith: aCollection coordinates collect: aBlock! !

!GVector methodsFor: 'arithmetic' stamp: ''!
dotProduct: aGVector
	^ (self coordinatesWith: aGVector coordinates collect: [ :point1 :point2 | point1 * point2 ]) sum! !

!GVector methodsFor: 'testing' stamp: ''!
isZeroVector
	^ false! !

!GVector methodsFor: 'arithmetic' stamp: ''!
+ anOperand
	^ anOperand additionWithVector: self! !

!GVector class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!GVector class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!GVector class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!GVector class methodsFor: 'instance creation' stamp: ''!
coordinates: aCoordinates
	(aCoordinates coordinates allSatisfy: [ :e | e = 0]) ifTrue: [ ^ GZeroVector coordinates: aCoordinates ].

	^ self new
		coordinates: aCoordinates;
		yourself! !

!GVector class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!GVector class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!GVector class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!GVector class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!GVector class methodsFor: 'instance creation' stamp: ''!
x: aNumber y: anotherNumber
	^ self coordinates: (G2DCoordinates x: aNumber y: anotherNumber)! !

!GVector class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!GVector class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!GVector class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!GVector class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!GVector class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!GVector class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!GVector class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!GVector class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!GVector class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!GVector class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!GVector class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!GVector class methodsFor: 'instance creation' stamp: ''!
withCollection: aCollection
	^ self coordinates: (GCoordinates withCollection: aCollection)! !

!GVector class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!GVector class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!GVector class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!GVector class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!GVector class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!GVector class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!GVector class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!GVector class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!GVector class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!GVector class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!GVector class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!GVectorTest methodsFor: 'tests' stamp: ''!
testMultiplication
	| newVector |
	vector := #(2 8) asGVector.
	newVector := vector * 2.
	self assert: newVector x equals: 4.
	self assert: newVector y equals: 16! !

!GVectorTest methodsFor: 'tests' stamp: ''!
testEquals
	self flag: #pharo6. "Use #deny:equals: when Pharo 7 will be the minimum requirement"
	self assert: (GVector x: 1 y: 2) equals: (GVector x: 1 y: 2).
	self deny: (GVector x: 2 y: 4) = (GVector x: 1 y: 2).
	self assert: (GVector x: 1 y: 2) hash equals: (GVector x: 1 y: 2) hash.
	self deny: (GVector x: 2 y: 4) hash = (GVector x: 1 y: 2) hash! !

!GVectorTest methodsFor: 'tests' stamp: ''!
testNonOrientedAngleWith
	vector := {2 . 9 . -3} asGVector.
	self assert: (vector nonOrientedAngleWith: {-3 . -4 . 8} asGVector) equals: 2.37687 radians.

	vector := {5 . 24} asGVector.
	self assert: (vector nonOrientedAngleWith: {1 . 3} asGVector) equals: 0.11635 radians.

	vector := {2 . 0} asGVector.
	self assert: (vector nonOrientedAngleWith: vector) isZero.
	self assert: (vector nonOrientedAngleWith: {2 . 1} asGVector) equals: 0.4636476090008063 radians.
	self assert: ({2 . 1} asGVector nonOrientedAngleWith: vector) equals: 0.4636476090008063 radians.
	self assert: (vector nonOrientedAngleWith: {2 . 2} asGVector) equals: 0.7853981633974483 radians.
	self assert: ({2 . 2} asGVector nonOrientedAngleWith: vector) equals: 0.7853981633974483 radians.
	self assert: (vector nonOrientedAngleWith: {1 . 2} asGVector) equals: 1.1071487177940922 radians.
	self assert: ({1 . 2} asGVector nonOrientedAngleWith: vector) equals: 1.1071487177940922 radians! !

!GVectorTest methodsFor: 'tests' stamp: ''!
testAngleWith
	vector := {2 . 0} asGVector.
	self assert: (vector angleWith: vector) isZero.
	self assert: (vector angleWith: {2 . 1} asGVector) equals: 0.4636476090008063 radians.
	self assert: ({2 . 1} asGVector angleWith: vector) equals: -0.4636476090008063 radians.
	self assert: (vector angleWith: {2 . 2} asGVector) equals: 0.7853981633974483 radians.
	self assert: ({2 . 2} asGVector angleWith: vector) equals: -0.7853981633974483 radians.
	self assert: (vector angleWith: {1 . 2} asGVector) equals: 1.1071487177940922 radians.
	self assert: ({1 . 2} asGVector angleWith: vector) equals: -1.1071487177940922 radians! !

!GVectorTest methodsFor: 'tests' stamp: ''!
test2DVector
	vector := GVector x: 1 y: 2.
	self assert: vector x equals: 1.
	self assert: vector y equals: 2.
	
	vector := GVector x: -1 y: -2.
	self assert: vector x equals: -1.
	self assert: vector y equals: -2.
	
	vector := GVector coordinates: (G2DCoordinates x: 1 y: 2).
	self assert: vector x equals: 1.
	self assert: vector y equals: 2! !

!GVectorTest methodsFor: 'tests' stamp: ''!
testDotProduct
	vector := {-6 . 8} asGVector.
	self assert: (vector dotProduct: {5 . 12} asGVector) equals: 66! !

!GVectorTest methodsFor: 'tests' stamp: ''!
testLength
	vector := GVector x: 3 y: -4.
	self assert: vector length equals: 5! !

!GVectorTest methodsFor: 'accessing' stamp: ''!
actualClass
	^ GVector! !

!GZeroVector commentStamp: ''!
Description
--------------------

	I represent the zero vector that is a vector of length 0 and the only vector without direction.!
!GZeroVector methodsFor: 'arithmetic' stamp: ''!
angleWith: aGVector
	^ 0 radians! !

!GZeroVector methodsFor: 'testing' stamp: ''!
isZeroVector
	^ true! !

!GZeroVector class methodsFor: 'instance creation' stamp: ''!
coordinates: aCoordinates
	^ self new
		coordinates: aCoordinates;
		yourself! !

!GZipConstants commentStamp: ''!
This class defines magic numbers taken from the RFC1952 GZIP file format 
specification version 4.3 (1996) [1].  A class imports these constants 
as 'class variables' by including the following in its class definition: 
   poolDictionaries: 'GZipConstants' 
A method on the class side initialises the values. 

[1] http://www.ietf.org/rfc/rfc1952.txt  (Section 2.3.1 Member header 
and trailer) 
-------------8<----snip--------------- 

As an aside the following in [GzipConstants class >> initialize] does 
not match the specification for bit 5 as "reserved". 
    GZipEncryptFlag := 16r20.    "Archive is encrypted" 

I did find it defined here [2] & [3] however the FAQ [4] specifically 
says encryption is NOT part of the standard. 

This constant is only used in [GzipReadStream >> on:from:to] as... 
    (flags anyMask: GZipEncryptFlag) 
        ifTrue:[^self error:'Cannot decompress encrypted stream']. 

So perhaps its okay to leave but maybe some slight benefit from amending 
the text as follows.. 
    GZipEncryptFlag := 16r20.    "Archive is encrypted.  Not supported. 
Not part of the standard." 
    ifTrue:[^self error:'Cannot decompress encrypted stream. Encryption 
is not part of RFC1952']. 

It is a better presentation to a user if you can indicate that it is 
someone else's fault that their decompress failed, and not Pharo. 

[2] http://www.onicos.com/staff/iz/formats/gzip.html
[3] http://research.cs.wisc.edu/wpis/examples/pcca/gzip/gzip.h
[3] http://www.gzip.org/#faq15!
!GZipConstants class methodsFor: 'pool initialization' stamp: 'nil'!
gzipMagic
	^GZipMagic! !

!GZipConstants class methodsFor: 'pool initialization' stamp: 'nil'!
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"! !

!GZipReadStream commentStamp: ''!
gzip is an integral part of the VM. !
!GZipReadStream methodsFor: 'crc' stamp: 'nil'!
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: 'crc' stamp: 'nil'!
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: 'initialization' stamp: 'nil'!
on: aCollection from: firstIndex to: lastIndex
	"Check the header of the GZIP stream."
	| method magic flags length |
	super on: aCollection from: firstIndex to: lastIndex.
	crc := 16rFFFFFFFF.
	magic := self nextBits: 16.
	(magic = GZipMagic) 
		ifFalse:[^self error:'Not a GZipped stream'].
	method := self nextBits: 8.
	(method = GZipDeflated)
		ifFalse:[^self error:'Bad compression method'].
	flags := self nextBits: 8.
	(flags anyMask: GZipEncryptFlag) 
		ifTrue:[^self error:'Cannot decompress encrypted stream'].
	(flags anyMask: GZipReservedFlags)
		ifTrue:[^self error:'Cannot decompress stream with unknown flags'].
	"Ignore stamp, extra flags, OS type"
	self nextBits: 16; nextBits: 16. "stamp"
	self nextBits: 8. "extra flags"
	self nextBits: 8. "OS type"
	(flags anyMask: GZipContinueFlag) "Number of multi-part archive - ignored"
		ifTrue:[self nextBits: 16]. 
	(flags anyMask: GZipExtraField) "Extra fields - ignored"
		ifTrue:[	length := self nextBits: 16.
				1 to: length do:[:i| self nextBits: 8]].
	(flags anyMask: GZipNameFlag) "Original file name - ignored"
		ifTrue:[[(self nextBits: 8) = 0] whileFalse].
	(flags anyMask: GZipCommentFlag) "Comment - ignored"
		ifTrue:[[(self nextBits: 8) = 0] whileFalse]! !

!GZipReadStream class methodsFor: 'file in/out' stamp: 'nil'!
viewContents: fullFileName
	"Open the decompressed contents of the .gz file with the given name."

	| file |
	(file := fullFileName asFileReference) binaryReadStreamDo: 
		[ :aStream | self with: aStream do: 
			[ :aGzStream | UIManager default edit: aGzStream upToEnd label: 'Decompressed contents of: ' , file basename ] ]! !

!GZipReadStream class methodsFor: '*System-FileRegistry' stamp: ''!
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: ''!
fileReaderServicesForFile: fullName suffix: suffix
	<fileService>
	| services |
	services := OrderedCollection new.
	(#('gz' '*') includes: suffix)
		ifFalse: [ ^ services ].
	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: 'unzipping' stamp: 'nil'!
unzip: fullFileName to: pathName
	"Unzip the contents of the file specified by the full path name or file reference fullFileName to the location given by pathName.
	GZipReadStream unzip:'/aPath/zip.gz' to: '/aPath'
	GZipReadStream unzip:'zip.gz' to: '/aPath'
	GZipReadStream unzip:'/aPath/zip.gz' asFileReference to: '/aPath' asFileReference
	
	To unzip a .zip go to the class ZipArchive"

	| buffer newName |
	newName := fullFileName asFileReference basenameWithoutExtension.
	pathName asFileReference ensureCreateDirectory / newName
		binaryWriteStreamDo: [ :unzipped | 
			self with: fullFileName asFileReference binaryReadStream
				do: [ :zipped | 
					buffer := ByteArray new: 50000.
					[ zipped atEnd ] whileFalse: [ unzipped nextPutAll: (zipped nextInto: buffer) ] ] ].
	^ newName! !

!GZipReadStream class methodsFor: 'unzipping' stamp: 'nil'!
unzip: fullFileName 
	"Unzip the contents of the file specified by the full path name or file reference fullFileName to the current working directory
	To unzip a .zip go to the class ZipArchive"
	
	^ self unzip: fullFileName to: FileSystem disk workingDirectory! !

!GZipReadStream class methodsFor: '*System-FileRegistry' stamp: ''!
services

	^ Array 
		with: self serviceViewDecompress
		with: self serviceDecompressToFile
	! !

!GZipReadStream class methodsFor: 'file in/out' stamp: 'nil'!
fileIn: fullFileName
	"FileIn the contents of a gzipped file"

	self
		with: fullFileName asFileReference binaryReadStream
		do: [ :aStream | CodeImporter evaluateString: aStream contents asString ]! !

!GZipReadStream class methodsFor: '*System-FileRegistry' stamp: ''!
serviceDecompressToFile

	^ FileModifyingSimpleServiceEntry 
				provider: self 
				label: 'Decompress to file'
				selector: #saveContents:
				description: 'Decompress to file'! !

!GZipReadStream class methodsFor: '*System-FileRegistry' stamp: ''!
serviceViewDecompress

	^ SimpleServiceEntry 
				provider: self 
				label: 'View decompressed'
				selector: #viewContents:
				description: 'View decompressed' 
! !

!GZipReadStream class methodsFor: 'file in/out' stamp: 'nil'!
saveContents: fullFileName
	"Save the contents of a gzipped file"

	| buffer newName |
	newName := fullFileName asFileReference basenameWithoutExtension.
	newName asFileReference binaryWriteStreamDo: [ :unzipped | 
			fullFileName asFileReference
				binaryReadStreamDo: [ :readStream | 
					self with: readStream
						do: [ :zipped | 
							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) ] ] ] ] ].
	^ newName! !

!GZipReadStreamTest commentStamp: ''!
Tests for the GZipReadStream class!
!GZipReadStreamTest methodsFor: 'tests' stamp: ''!
testUnzipTo
	| gzFile txtFile return |
	[ (gzFile := filesystem workingDirectory / self class gzFileName)
		binaryWriteStreamDo: [ :stream | stream nextPutAll: self class gzFileBytes ].
	txtFile := filesystem workingDirectory / gzFile basenameWithoutExtension.

	return := GZipReadStream unzip: gzFile to: filesystem workingDirectory.
	self assert: return equals: gzFile basenameWithoutExtension.
	self assert: txtFile exists.
	self assert: txtFile contents equals: 'This is a test text' ]
		ensure: [ filesystem workingDirectory ensureDeleteAllChildren ]! !

!GZipReadStreamTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	filesystem := FileSystem memory! !

!GZipReadStreamTest class methodsFor: 'resources' stamp: ''!
gzFileName
	^ 'test.txt.gz'! !

!GZipReadStreamTest class methodsFor: 'resources' stamp: ''!
gzFileBytes
	^ #[31 139 8 8 9 73 195 91 4 0 116 101 115 116 46 116 120 116 0 1 19 0 236 255 84 104 105 115 32 105 115 32 97 32 116 101 115 116 32 116 101 120 116 30 128 114 177 19 0 0 0]! !

!GZipWriteStream commentStamp: ''!
gzip is an integral part of the VM. !
!GZipWriteStream methodsFor: 'initialization' stamp: 'nil'!
writeHeader
	"Write the GZip header"
	encoder nextBits: 16 put: GZipMagic.
	encoder nextBits: 8 put: GZipDeflated.
	encoder nextBits: 8 put: 0. "No flags"
	encoder nextBits: 32 put: 0. "no time stamp"
	encoder nextBits: 8 put: 0. "No extra flags"
	encoder nextBits: 8 put: 0. "No OS type"! !

!GZipWriteStream methodsFor: 'initialization' stamp: 'nil'!
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)].! !

!GeneralScrollBar commentStamp: ''!
Support for GeneralScrollPane.!
!GeneralScrollBar class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!GeneralScrollBarMorph commentStamp: ''!
Support for GeneralScrollPane.!
!GeneralScrollBarMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self showWhenNeeded! !

!GeneralScrollBarMorph methodsFor: 'accessing' stamp: ''!
showState: anObject

	showState := anObject! !

!GeneralScrollBarMorph methodsFor: 'accessing' stamp: ''!
showWhenNeeded
	"Set the scrollbar to be shown if needed."

	self showState: #whenNeeded! !

!GeneralScrollBarMorph methodsFor: 'accessing' stamp: ''!
showNever
	"Set the scrollbar to be never shown."

	self showState: #never! !

!GeneralScrollBarMorph methodsFor: 'accessing' stamp: ''!
showAlways
	"Set the scrollbar to be always shown."

	self showState: #always! !

!GeneralScrollBarMorph methodsFor: 'accessing' stamp: ''!
showState

	^ showState! !

!GeneralScrollBarMorph methodsFor: 'accessing' stamp: ''!
showsWhenNeeded
	"Answer whether the scrollbar should be shown if needed."

	^self showState == #whenNeeded! !

!GeneralScrollBarMorph methodsFor: 'model access' stamp: ''!
setValue: newValue
	"Bypass screwed up scrollbar!!"
	
	^self perform: #setValue: withArguments: {newValue} inSuperclass: SliderMorph! !

!GeneralScrollBarMorph methodsFor: 'accessing' stamp: ''!
showsAlways
	"Answer whether the scrollbar should always be shown."

	^self showState == #always! !

!GeneralScrollBarMorph methodsFor: 'accessing' stamp: ''!
showsNever
	"Answer whether the scrollbar should never be shown."

	^self showState == #never! !

!GeneralScrollPane commentStamp: ''!
A scroll pane that handles its contents accurately.!
!GeneralScrollPane class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!GeneralScrollPaneMorph commentStamp: ''!
A scroll pane that handles its contents accurately.!
!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
hHideScrollbar
	"Hide the horizontal scrollbar."
	
	self hScrollbarShowing ifFalse: [^self].
	self removeMorph: self hScrollbar.
	self vResizeScrollbar.
	self resizeScroller! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
vUpdateScrollbar
	"Update the visibility and dimensions of the vertical scrollbar as needed."
	
	self vScrollbarNeeded
		ifTrue: [self
				vShowScrollbar;
				vResizeScrollbar]
		ifFalse: [self vHideScrollbar]! !

!GeneralScrollPaneMorph methodsFor: 'layout' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'geometry' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'geometry' stamp: ''!
resizeScroller
	"Resize the scroller to fit the scroll bounds."
	
	self scroller bounds: self scrollBounds! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
vScrollbarShowNever
	"Set the vertical scrollbar to never show."
	
	self vScrollbar showNever.
	self updateScrollbars! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
changeScrollerTableLayout
	"Change the scroller's layout policy to a table layout."

	self scroller changeTableLayout! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
vScrollbarShowAlways
	"Set the vertical scrollbar to always show."
	
	self vScrollbar showAlways.
	self updateScrollbars! !

!GeneralScrollPaneMorph methodsFor: 'events-processing' stamp: ''!
handlesMouseWheel: evt
	"Do I want to receive mouseWheel events?." 

	^true! !

!GeneralScrollPaneMorph methodsFor: 'instance creation' stamp: ''!
newScroller
	"Answer a new scroller."

	^TransformWithLayoutMorph new
		color: Color transparent! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'geometry' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		scroller: self newScroller;
		hScrollbar: self newHScrollbar;
		vScrollbar: self newVScrollbar;
		scrollTarget: self defaultScrollTarget.
	self
		addMorph: self scroller;
		resizeScroller! !

!GeneralScrollPaneMorph methodsFor: 'accessing' stamp: ''!
hScrollbar: anObject
	"Set the value of hScrollbar"

	hScrollbar := anObject! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
hShowScrollbar
	"Show the horizontal scrollbar."
	
	self hResizeScrollbar.
	self hScrollbarShowing ifTrue: [^self].
	self privateAddMorph: self hScrollbar atIndex: 1.
	self vResizeScrollbar.
	self resizeScroller! !

!GeneralScrollPaneMorph methodsFor: 'event handling' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
hScrollbarShowNever
	"Set the horizontal scrollbar to never show."
	
	self hScrollbar showNever.
	self updateScrollbars! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
vShowScrollbar
	"Show the vertical scrollbar."
	
	self vResizeScrollbar.
	self vScrollbarShowing ifTrue: [^self].
	self privateAddMorph: self vScrollbar atIndex: 1.
	self hResizeScrollbar.
	self resizeScroller! !

!GeneralScrollPaneMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Adopt the given pane color."
	
	super adoptPaneColor: paneColor.
	self hScrollbar adoptPaneColor: paneColor.
	self vScrollbar adoptPaneColor: paneColor! !

!GeneralScrollPaneMorph methodsFor: 'accessing' stamp: ''!
hScrollbar
	"Answer the value of hScrollbar"

	^ hScrollbar! !

!GeneralScrollPaneMorph methodsFor: 'client list accessing' stamp: ''!
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]! !

!GeneralScrollPaneMorph methodsFor: 'geometry' stamp: ''!
setScrollDeltas
	"Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."
	
	self
		hSetScrollDelta;
		vSetScrollDelta! !

!GeneralScrollPaneMorph methodsFor: 'accessing' stamp: ''!
vScrollbar: anObject
	"Set the value of vScrollbar"

	vScrollbar := anObject! !

!GeneralScrollPaneMorph methodsFor: 'initialize' stamp: ''!
defaultColor
	"Answer the default color/fill style for the receiver."
	
	^ Color transparent! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
hScrollbarShowAlways
	"Set the horizontal scrollbar to always show."
	
	self hScrollbar showAlways.
	self updateScrollbars! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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]! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
scrollTarget
	"Answer the morph that is scrolled."
	
	^self scroller submorphs first! !

!GeneralScrollPaneMorph methodsFor: 'event handling' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
vHideScrollbar
	"Hide the vertical scrollbar."
	
	self vScrollbarShowing ifFalse: [^self].
	self removeMorph: self vScrollbar.
	self hResizeScrollbar.
	self resizeScroller! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
defaultScrollTarget
	"Answer a new default scroll target."

	^ Morph new
		extent: 200@150! !

!GeneralScrollPaneMorph methodsFor: 'event handling' stamp: ''!
mouseWheel: event 
	"Handle a mouseWheel event."
	
	(self scrollTarget handlesMouseWheel: event)
		ifTrue: [^self scrollTarget mouseWheel: event]. "pass on"
	
	event isUp ifTrue: [ ^ vScrollbar scrollUp: 3 ].
	event isDown ifTrue: [ ^ vScrollbar scrollDown: 3 ].
	event isLeft  ifTrue: [ ^ hScrollbar scrollLeft: 3 ].
	event isRight  ifTrue: [ ^ hScrollbar scrollRight: 3 ].! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
hUpdateScrollbar
	"Update the visibility and dimensions of the horizontal scrollbar as needed."
	
	self hScrollbarNeeded
		ifTrue: [self
					hShowScrollbar;
					hResizeScrollbar]
		ifFalse: [self hHideScrollbar]! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
vScrollbarShowWhenNeeded
	"Set the vertical scrollbar to show if needed."
	
	self vScrollbar showWhenNeeded.
	self updateScrollbars! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
hScrollbarInterval
	"Answer the computed size of the thumb of the horizontal scrollbar."
	
	^self scrollBounds width asFloat / self scrollTarget width min: 1.0.! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'geometry' stamp: ''!
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"! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
scrollTarget: aMorph
	"Set the morph that is scrolled."
	
	self scroller
		removeAllMorphs;
		addMorph: aMorph.
	self updateScrollbars! !

!GeneralScrollPaneMorph methodsFor: 'accessing' stamp: ''!
scroller: anObject
	"Set the value of scroller"

	scroller := anObject! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
hScrollbarShowWhenNeeded
	"Set the horizontal scrollbar to show if needed."
	
	self hScrollbar showWhenNeeded.
	self updateScrollbars! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
vScrollbarInterval
	"Answer the computed size of the thumb of the vertical scrollbar."
	
	^self scrollBounds height asFloat / self scrollTarget height min: 1.0.! !

!GeneralScrollPaneMorph methodsFor: 'layout' stamp: ''!
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]! !

!GeneralScrollPaneMorph methodsFor: 'defaults' stamp: ''!
scrollbarThickness
	"Answer the width or height of a scrollbar as appropriate to
	its orientation."
	
	^ self theme scrollbarThickness! !

!GeneralScrollPaneMorph methodsFor: 'geometry' stamp: ''!
vLeftoverScrollRange
	"Return the entire scrolling range minus the currently viewed area."
	
	^self scrollTarget height - self scrollBounds height max: 0! !

!GeneralScrollPaneMorph methodsFor: 'accessing' stamp: ''!
scrollBarThickness
	"Answer the width or height of a scrollbar as appropriate to
	its orientation."
	
	^self theme scrollbarThickness! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
vScrollbarShowing
	"Answer whether the vertical scrollbar is showing."
	
	^self vScrollbar owner notNil! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	"Yes for page up/down."
	
	^true! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'accessing' stamp: ''!
scroller
	"Answer the value of scroller"

	^ scroller! !

!GeneralScrollPaneMorph methodsFor: 'instance creation' stamp: ''!
newHScrollbar
	"Answer a new horizontal scrollbar."

	^GeneralScrollBarMorph new
		model: self;
		setValueSelector: #hScrollbarValue:! !

!GeneralScrollPaneMorph methodsFor: 'instance creation' stamp: ''!
newVScrollbar
	"Answer a new vertical scrollbar."

	^GeneralScrollBarMorph new
		model: self;
		setValueSelector: #vScrollbarValue:! !

!GeneralScrollPaneMorph methodsFor: 'layout' stamp: ''!
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]! !

!GeneralScrollPaneMorph methodsFor: 'accessing' stamp: ''!
vScrollbar
	"Answer the value of vScrollbar"

	^ vScrollbar! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
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! !

!GeneralScrollPaneMorph methodsFor: 'scrollbars' stamp: ''!
hScrollbarShowing
	"Answer whether the horizontal scrollbar is showing."
	
	^self hScrollbar owner notNil! !

!GeneralScrollPaneMorph methodsFor: 'updating' stamp: ''!
updateScrollbars
	"Update the visibility, dimensions and values of the scrollbars as needed."
	
	self
		vUpdateScrollbar;
		hUpdateScrollbar;
		setScrollDeltas! !

!Generator commentStamp: ''!
A `Generator` transforms callback interfaces into stream interfaces. 

The `Generator` class was originally written by Paolo Bonzini and inspired from functional programming languages.

With basic iterators, you specify an action to be perform to elements of a collection or stream but you do not control when computation pass from one element to the next one. In addition you cannot perform a lazzy computation on potentially infinite stream of objects. 

Generators offer a nice solution to such problem. Generators provide a way to use blocks to define a stream of values. The return values are computed one at a time, as needed, and hence need not even be finite. 

A generator needs a block and will make sure that the block is executed once at a time and that the block has the control to decide when to yield computation. A generator offers an API that is compatible with the one of stream since it act as a stream of objects. 

A generator should be instantiated using the expression `Generator on: [...]`. 
The following code creates an infinite streams of 1. 

```
| g | 
g := Generator on: [ :gen | [ gen yield: 1 ] repeat ].
g next
> 1
g next 
> 1
```

### Behavior 

The generator itself is passed to the block, and as soon as a message like `next`, `peek`, `atEnd` or `peekFor:` is sent to the generator, execution of the block starts/resumes and goes on until the generator's `yield:` method is called: then the argument of `yield:` will be the generator's next element. 

If the block goes on to the end without calling `yield:`, the generator will produce no more elements and `atEnd` will return true.


A generator is a quick way to create a stream of objects. A generator is a kind of pluggable stream, in that a user-supplied blocks defines which values are in a stream.

For example, here is an empty generator and two infinite generators:

```
Generator on: [ :gen | ]
Generator on: [ :gen | [ gen yield: 1 ] repeat ]
```

As a more concrete example taken from GNU Smalltalk implementation, these lines process a file and create Person objects out of the file:

```
lines := file lines.
lines := lines select: [ :line | line ~ '^[A-Za-z]+ [0-9]+$' ].
fields := lines collect: [ :line | line subStrings ].
people := fields collect: [ :data |
            Person name: data first age: data second asInteger ].
```
Let's see how to rewrite them to use a single Generator instead:

```
Generator on: [ :gen |
    file linesDo: [ :line || data |
        line ~ '^[A-Za-z]+ [0-9]+$' ifTrue: [
            data := line subStrings.
            gen yield: (Person name: data first age: data second asInteger) ] ] ].
```
As you can see, `select:` becomes an if-statement, and the value from the final stream is yielded to the user of the generator.
Generators use continuations, but they shield the users from their complexity by presenting the 
same simple interface as streams.


### Instance Variables

- block:		<BlockClosure> The block associated with the generator.
- continue:	<MethodContext>	The continuation to return to.
- home:		<MethodContext>	The home (root) context of the activated block
- next:		<Object>		The next object to return from the Generator.
!
!Generator methodsFor: 'public' stamp: ''!
value: anObject 
	"Allows passing generators as arguments to methods expecting blocks.
	A synonym for #yield: / #nextPut:."
	^ self nextPut: anObject! !

!Generator methodsFor: 'private' stamp: ''!
fork
	| result |
	home := thisContext.
	block reentrant value: self.
	thisContext swapSender: continue.
	result := next.
	continue := next := home := nil.
	^ result! !

!Generator methodsFor: 'accessing' stamp: ''!
peek
	"Answer the upcoming object of the receiver."

	^ next! !

!Generator methodsFor: 'accessing' stamp: ''!
next
	"Generate and answer the next object in the receiver."

	^ self atEnd ifFalse: [
		home swapSender: thisContext sender.
		continue := thisContext swapSender: continue
	]! !

!Generator methodsFor: 'public' stamp: ''!
yield: anObject 
	"Yield the next value to the consumer of the generator.
	A synonym for #nextPut:"
	^ self nextPut: anObject! !

!Generator methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: self class name; nextPutAll: ' on: '; print: block! !

!Generator methodsFor: 'accessing' stamp: ''!
size
	"A generator does not know its size."

	^ self shouldNotImplement! !

!Generator methodsFor: 'accessing' stamp: ''!
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: 'open/close' stamp: ''!
close
	"Close the receiving generator and unwind its ensure-blocks."

	continue ifNotNil:[continue unwindTo: home].
	continue := block := next := nil! !

!Generator methodsFor: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
atEnd
	"Answer whether the receiver can access any more objects."

	^ continue isNil or: [ continue isDead ]! !

!Generator methodsFor: 'initialization' stamp: ''!
reset
	"Reset the generator, i.e., start it over"
	continue ifNotNil:[continue unwindTo: home].
	next := nil.
	continue := thisContext.
	self fork! !

!Generator methodsFor: 'initialization' stamp: ''!
initializeOn: aBlock
	block := aBlock.
	self reset! !

!Generator class methodsFor: 'examples' stamp: ''!
somePrimes
	"self somePrimes" 
	
	^ String streamContents: [ :str | 
		| generator |
		generator := Generator on: [:g| Integer primesUpTo: 100 do:[:prime| g yield: prime]].
		[generator atEnd] whileFalse:[ str nextPutAll: generator next printString; cr]]! !

!Generator class methodsFor: 'instance creation' stamp: ''!
on: aBlock
	^ self basicNew initializeOn: aBlock! !

!GeneratorTest commentStamp: ''!
SUnit tests for class Generator!
!GeneratorTest methodsFor: 'generators' stamp: ''!
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: 'tests' stamp: ''!
testEnsure
	| generator |
	generator := Generator
		on: [ :g | 
			[ g
				yield: 1;
				yield: 2 ]
				ensure: [ g yield: 3 ] ].
	self assert: generator upToEnd asArray equals: #(1 2 3)! !

!GeneratorTest methodsFor: 'tests' stamp: ''!
testReset
	| generator |
	generator := self numbersBetween: 1 and: 3.
	self assert: generator next equals: 1.
	self assert: generator next equals: 2.
	generator reset.
	self assert: generator next equals: 1.
	self assert: generator next equals: 2.
	self assert: generator next equals: 3.
	self assert: generator next equals: nil.
	generator reset.
	self assert: generator next equals: 1! !

!GeneratorTest methodsFor: 'tests' stamp: ''!
testNext
	| generator |
	generator := self numbersBetween: 1 and: 3.
	self assert: generator next equals: 1.
	self assert: generator next equals: 2.
	self assert: generator next equals: 3.
	self assert: generator next isNil! !

!GeneratorTest methodsFor: 'tests' stamp: ''!
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 equals: 0;
		assert: notEnsure equals: 0.
	self assert: generator peek equals: 1.
	self
		assert: doEnsure equals: 0;
		assert: notEnsure equals: 0.
	generator reset.
	self
		assert: doEnsure equals: 1;
		assert: notEnsure equals: 0 ]
		ensure: [ notEnsure := notEnsure + 1 ].
	self
		assert: doEnsure equals: 1;
		assert: notEnsure equals: 1! !

!GeneratorTest methodsFor: 'tests' stamp: ''!
testPeek
	| generator |
	generator := self numbersBetween: 1 and: 3.
	self assert: generator peek equals: 1.
	self assert: generator peek equals: 1.
	generator next.
	self assert: generator peek equals: 2! !

!GeneratorTest methodsFor: 'tests' stamp: ''!
testEmpty
	| generator |
	generator := Generator on: [ :g | ].
	self assert: generator atEnd.
	self assert: generator peek isNil.
	self assert: generator next isNil! !

!GeneratorTest methodsFor: 'tests' stamp: ''!
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: 'tests' stamp: ''!
testErrorPropagation
	"Ensure that errors in the generator block are properly propagated"

	| generator |
	generator := Generator
		on: [ :g | 
			g yield: 1.
			g error: 'yo' ].
	self should: [ generator next ] raise: Error! !

!GeneratorTest methodsFor: 'tests' stamp: ''!
testClose
	| generator doEnsure notEnsure |
	doEnsure := notEnsure := 0.
	[ generator := Generator
		on: [ :g | 
			[ g
				yield: 1;
				yield: 2 ]
				ensure: [ doEnsure := doEnsure + 1 ] ].
	self
		assert: doEnsure equals: 0;
		assert: notEnsure equals: 0.
	self assert: generator peek equals: 1.
	self
		assert: doEnsure equals: 0;
		assert: notEnsure equals: 0.
	generator close.
	self
		assert: doEnsure equals: 1;
		assert: notEnsure equals: 0 ]
		ensure: [ notEnsure := notEnsure + 1 ].
	self
		assert: doEnsure equals: 1;
		assert: notEnsure equals: 1! !

!GeneratorTest methodsFor: 'generators' stamp: ''!
numbersBetween: aStartInteger and: aStopInteger
	"Yields the nubmers between aStartInteger and aStopInteger."
	
	^ Generator on: [ :generator |
		aStartInteger to: aStopInteger 
			do: [ :value | generator yield: value ] ]! !

!GeneratorTest methodsFor: 'tests' stamp: ''!
testFibonacci
	| generator |
	generator := self fibonacciSequence.
	self assert: (generator next: 10) asArray equals: #(1 1 2 3 5 8 13 21 34 55)! !

!GeneratorTest methodsFor: 'tests' stamp: ''!
testSimple
	| generator |
	generator := Generator
		on: [ :g | 
			g
				yield: 1;
				yield: 2 ].
	self assert: generator upToEnd asArray equals: #(1 2)! !

!GeneratorTest methodsFor: 'tests' stamp: ''!
testContents
	| generator |
	generator := self numbersBetween: 1 and: 3.
	self assert: generator contents equals: #(1 2 3)! !

!GeneratorTest class methodsFor: 'accessing' stamp: ''!
packageNamesUnderTest
	^ #('Generator')! !

!GenericPaintPatch commentStamp: ''!
I am a generic patch whose content is built through path building style commands. I have rough correspondence to SVG mesh gradient paths.!
!GenericPaintPatch methodsFor: 'accessing' stamp: ''!
buildBlock: anObject
	buildBlock := anObject! !

!GenericPaintPatch methodsFor: 'accessing' stamp: ''!
buildBlock
	^ buildBlock! !

!GenericPaintPatch methodsFor: '*Athens-Cairo' stamp: ''!
addToCairoMeshGradientPaint: meshGradientPaint
	meshGradientPaint beginPatch.
	[ 
		buildBlock value: meshGradientPaint
	] ensure: [ meshGradientPaint endPatch ].! !

!GeometryError commentStamp: ''!
Description
--------------------

I am a common exception for the Geometry project!
!GeometryObject commentStamp: ''!
Description
--------------------

I am a common superclass for all Geometry object. Concrete (points, segments, polygons...) and abstract objects (coordinates, vectors, ...).!
!GeometryObject methodsFor: 'error handling' stamp: ''!
error: aString
	^ self class error: aString! !

!GeometryObject methodsFor: 'error handling' stamp: ''!
error
	^ self class error! !

!GeometryObject class methodsFor: 'error handling' stamp: ''!
error: aString
	GeometryError signal: aString! !

!GeometryObject class methodsFor: 'error handling' stamp: ''!
error
	GeometryError signal! !

!GlobalForTesting commentStamp: ''!
I am used for testing!
!GlobalIdentifier commentStamp: ''!
I keep global IDs that are used for tracking user activity, e.g. computer id. By default, you should access me by calling #uniqueInstance.

Responsibility:
The IDs that are important to store onto disk (and shared by all images) should be placed in persistedInformation instance variable. On other hand, if you do not want to store it onto disk, create a new instance variable. I can #loadPreferences and #savePreferences onto a disk.

I know computer ID and secret ID. Computer ID is a global UUID that is share among all the images. It is stored on a local disk. Secret ID is use for encrypting information, e.g., class names, method names. You can use #hashForText: method.

Collaborators: I do not collaborate with other classes. I only offer the basic IDs for other frameworks.

Public API and Key Messages

- computerUUID 
- ensureComputerUUID
- hashForText:
- loadPreferences 
- savePreferences.

Before using #computerUUID, you should call #ensureComputerUUID. It will update UUID from the disk or stores existing one if it is not stored yet. I behave like this as automatic storing data to disk on image start-up leads to errors.

Internal Representation and Key Implementation Points.

    Instance Variables
	persistedInformation:		<Dictionary>
	preferences:		<FileReference>
!
!GlobalIdentifier methodsFor: 'accessing' stamp: ''!
computerUUID
	"This value identifies a user logged into the computer.
	Before calling #computerUUID method, you should call #ensure."
	^ persistedInformation at: #computerUUID! !

!GlobalIdentifier methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	"Dictionary contains all the values that we want to persist on disk."
	persistedInformation := Dictionary new.
	persistedInformation at: #computerUUID put: UUID new asString.
	persistedInformation at: #secretUUID put: UUID new asString.
	persistenceStrategy := GlobalIdentifierPersistence ston.
	persistenceStrategy previous: GlobalIdentifierPersistence fuel.! !

!GlobalIdentifier methodsFor: 'accessing' stamp: ''!
persistenceStrategy
	^ persistenceStrategy! !

!GlobalIdentifier methodsFor: 'accessing' stamp: ''!
persistedInformation
	^ persistedInformation! !

!GlobalIdentifier methodsFor: 'accessing' stamp: ''!
secretUUID
	"This value can be used for obfuscating an information before sending it.
	See #obfuscate: method.
	Before calling #secretUUID method, you should call #ensure."
	^ persistedInformation at: #secretUUID! !

!GlobalIdentifier methodsFor: 'load and saving' stamp: ''!
ensure
	self persistenceStrategy ensure: self persistedInformation! !

!GlobalIdentifier methodsFor: 'actions' stamp: ''!
obfuscate: anObject
	"If you have an information that you want to obfuscate before sending,
	this is likely a good solution for you."
	^ anObject hash bitXor: self secretUUID hash! !

!GlobalIdentifier methodsFor: 'accessing' stamp: ''!
persistenceStrategy: anObject
	persistenceStrategy := anObject! !

!GlobalIdentifier class methodsFor: 'initialization' stamp: ''!
initializeUniqueInstance
	uniqueInstance := self basicNew initialize.
	uniqueInstance ensure.! !

!GlobalIdentifier class methodsFor: 'instance creation' stamp: ''!
new
	"Users should not create instances of this class.
	Within the framework more instances are created when loading data and when testing."
	self shouldNotImplement! !

!GlobalIdentifier class methodsFor: 'class initialization' stamp: ''!
initialize

	SessionManager default
		register: (ClassSessionHandler forClassNamed: self name)
		inCategory: SessionManager default systemCategory  
		atPriority: SessionManager default defaultPriority - 80.! !

!GlobalIdentifier class methodsFor: 'accessing' stamp: ''!
uniqueInstance
	"self uniqueInstance"
	uniqueInstance ifNil: [ self initializeUniqueInstance ].
	^ uniqueInstance! !

!GlobalIdentifier class methodsFor: 'system startup' stamp: ''!
startUp: resuming

	self reset! !

!GlobalIdentifier class methodsFor: 'class initialization' stamp: ''!
reset
	"self reset"
	uniqueInstance := nil! !

!GlobalIdentifier class methodsFor: 'cleanup' stamp: ''!
cleanUp
	"Clean unique instance."	
	self reset.! !

!GlobalIdentifierFuelPersistence commentStamp: ''!
I serialize or materialize objects using FUEL framework. Create instance of me calling GlobalIdentifierPersistence fuel.!
!GlobalIdentifierFuelPersistence methodsFor: 'load and saving' stamp: ''!
load
	^ FLMaterializer materializeFromFileNamed: self preferences fullName! !

!GlobalIdentifierFuelPersistence methodsFor: 'load and saving' stamp: ''!
save: aDictionary into: aWriteStream
	[ FLSerializer serialize: aDictionary on: aWriteStream ]
		on: Error
		do: [ :anError | "ignore" ]! !

!GlobalIdentifierFuelPersistence methodsFor: 'configuration' stamp: ''!
fileName 
	^ 'org.pharo.gt.spotter.event.recorder.fuel'! !

!GlobalIdentifierFuelPersistenceTest commentStamp: ''!
A GlobalIdentifierFuelPersistenceTest is a test class for testing the behavior of GlobalIdentifierFuelPersistence!
!GlobalIdentifierFuelPersistenceTest methodsFor: 'running' stamp: ''!
tearDown
	(FileLocator workingDirectory / self folderName) 
		ensureDeleteAllChildren; 
		ensureDelete.
	super tearDown ! !

!GlobalIdentifierFuelPersistenceTest methodsFor: 'running' stamp: ''!
setUpPreferencesAndChecker
	preferences := FileLocator workingDirectory / self folderName / 'pharoX' / 'preferences.fuel'.
	preferences ensureDelete.
	checker := GlobalIdentifierPersistenceMockChecker new answer: [ FileLocator workingDirectory exists ].
! !

!GlobalIdentifierFuelPersistenceTest methodsFor: 'accessing' stamp: ''!
persistenceClass
	^ GlobalIdentifierFuelPersistence! !

!GlobalIdentifierMerger commentStamp: ''!
I am able to merge dictionaries of existing (in the image) and stored (on a disk) values.

First, I identify if the image values belongs to the current computer. Then I decide to favor existing or stored values. It is importatnt to notice that I change the existing dictionary received by #existing: message. GlobalIdentifierPersistence used me when he needs to load values from the local disk.

Collaborators: GlobalIdentifierPersistence 

Public API and Key Messages

- existing:
- stored: 
- merge

Example:
	GlobalIdentifierMerger new
		existing: (Dictionary newFromPairs: #(#a 1 #b  2));
		stored: (Dictionary newFromPairs: #(#a 3 #c  4));
		merge;
		existing
 
Internal Representation and Key Implementation Points.

    Instance Variables
	existing:		<Dictionary>
	stored:		<Dictionary>
!
!GlobalIdentifierMerger methodsFor: 'accessing' stamp: ''!
existing: anObject
	existing := anObject! !

!GlobalIdentifierMerger methodsFor: 'actions' stamp: ''!
mergeDifferentComputer
	"It puts all stored values into existing dictionary."
	stored keysAndValuesDo: [ :eachKey :eachValue |
		existing at: eachKey put: eachValue ].
	self convertValues.
	^ true! !

!GlobalIdentifierMerger methodsFor: 'actions' stamp: ''!
convertValues
	existing 
		at: #computerUUID 
		ifPresent: [ :aValue | existing at: #computerUUID put: aValue asString ]
		ifAbsent: [ "ignore" ].
	existing 
		at: #secretUUID
		ifPresent: [ :aValue | existing at: #secretUUID put: aValue asString ]
		ifAbsent: [ "ignore" ].! !

!GlobalIdentifierMerger methodsFor: 'actions' stamp: ''!
mergeSameComputer
	"It add into existing dictionary keys that are included in the stored dictionary,
	but are missing in the existing dictionary. Useful when a new version
	adds new configuration values that should be saved too.
	
	It returns true if existing dictionary is changed."
	| difference |
	difference := stored keys difference: existing keys.
	difference ifEmpty: [ ^ false ].
	difference do: [ :eachKey |
		existing at: eachKey put: (stored at: eachKey) ].
	self convertValues.
	^ true! !

!GlobalIdentifierMerger methodsFor: 'actions' stamp: ''!
merge
	"If UUIDs are different, it is likely different user and we should use
	localy stored settings. If the UUIDs are same, we keep settings of the image.
	
	It returns true if existing dictionary is changed."
	^ ((existing at: #computerUUID ifAbsent: nil) = (stored at: #computerUUID ifAbsent: nil)
		or: [ (stored includesKey: #computerUUID) not ])
			ifTrue: [ self mergeSameComputer ]
			ifFalse: [ self mergeDifferentComputer ]! !

!GlobalIdentifierMerger methodsFor: 'accessing' stamp: ''!
stored: anObject
	stored := anObject! !

!GlobalIdentifierMerger methodsFor: 'accessing' stamp: ''!
existing
	^ existing! !

!GlobalIdentifierMerger methodsFor: 'accessing' stamp: ''!
stored
	^ stored! !

!GlobalIdentifierMergerTest commentStamp: ''!
A GlobalIdentifierMergerTest is a test class for testing the behavior of GlobalIdentifierMerger!
!GlobalIdentifierMergerTest methodsFor: 'tests' stamp: ''!
testMerge3
	"Existing has same key as stored."

	existing at: #a put: 42.
	stored at: #a put: 21.
	self deny: merger merge.
	self deny: existing equals: stored.
	self assert: existing size equals: 1.
	self assert: stored size equals: 1.
	self assert: (existing at: #a) equals: 42! !

!GlobalIdentifierMergerTest methodsFor: 'tests' stamp: ''!
testMerge
	"Existing is empty. Stored has value."
	stored at: #a put: 42.
	self assert: merger merge.
	self assert: existing equals: stored.
	self assert: (existing at: #a) equals: 42.
	! !

!GlobalIdentifierMergerTest methodsFor: 'tests' stamp: ''!
testMerge4
	"Existing has different computer id as stored."

	existing at: #computerUUID put: 42.
	existing at: #a put: 43.
	existing at: #c put: 44.
	stored at: #computerUUID put: 21.
	stored at: #b put: 22.
	stored at: #c put: 23.
	self assert: merger merge.
	self deny: existing equals: stored.
	self assert: existing size equals: 4.
	self assert: stored size equals: 3.
	self assert: (existing at: #computerUUID) equals: 21 asString.
	self assert: (existing at: #a) equals: 43.
	self assert: (existing at: #b) equals: 22.
	self assert: (existing at: #c) equals: 23! !

!GlobalIdentifierMergerTest methodsFor: 'tests' stamp: ''!
testMerge6
	"Existing has different computer id as stored."

	existing at: #a put: 43.
	existing at: #c put: 44.
	stored at: #computerUUID put: 21.
	stored at: #b put: 22.
	stored at: #c put: 23.
	self assert: merger merge.
	self deny: existing equals: stored.
	self assert: existing size equals: 4.
	self assert: stored size equals: 3.
	self assert: (existing at: #computerUUID) equals: 21 asString.
	self assert: (existing at: #a) equals: 43.
	self assert: (existing at: #b) equals: 22.
	self assert: (existing at: #c) equals: 23! !

!GlobalIdentifierMergerTest methodsFor: 'tests' stamp: ''!
testMerge2
	"Existing has something. Stored has another key."

	existing at: #a put: 42.
	stored at: #b put: 21.
	self assert: merger merge.
	self deny: existing equals: stored.
	self assert: existing size equals: 2.
	self assert: stored size equals: 1.
	self assert: (existing at: #a) equals: 42.
	self assert: (existing at: #b) equals: 21! !

!GlobalIdentifierMergerTest methodsFor: 'tests' stamp: ''!
testMerge5
	"Existing has different computer id as stored."

	existing at: #computerUUID put: 42.
	existing at: #a put: 43.
	existing at: #c put: 44.
	stored at: #b put: 22.
	stored at: #c put: 23.
	self assert: merger merge.
	self deny: existing equals: stored.
	self assert: existing size equals: 4.
	self assert: stored size equals: 2.
	self assert: (existing at: #computerUUID) equals: 42 asString.
	self assert: (existing at: #a) equals: 43.
	self assert: (existing at: #b) equals: 22.
	self assert: (existing at: #c) equals: 44! !

!GlobalIdentifierMergerTest methodsFor: 'tests' stamp: ''!
testMerge8
	"Ensure that it converts secretUUID into string."

	stored at: #secretUUID put: UUID new.
	self assert: merger merge.
	self deny: existing equals: stored.
	self assert: (existing at: #secretUUID) equals: (stored at: #secretUUID) asString! !

!GlobalIdentifierMergerTest methodsFor: 'tests' stamp: ''!
testMerge7
	"Ensure that it converts computerUUID into string."

	stored at: #computerUUID put: UUID new.
	self assert: merger merge.
	self deny: existing equals: stored.
	self assert: (existing at: #computerUUID) equals: (stored at: #computerUUID) asString! !

!GlobalIdentifierMergerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	existing := Dictionary new.
	stored := Dictionary new.
	merger := GlobalIdentifierMerger new.
	merger existing: existing; stored: stored! !

!GlobalIdentifierPersistence commentStamp: ''!
I represent persistence strategy for GlobalIdentifier. 

I can load or save existing preferences (a dictionary) using #load: or #save: message. I know whare the preference file is stored (#preferences). I also know what previous persistence stategy was used; for that reason you should use #ensure: instead of #load: message. In that case, I will load the old file and then save it using new persistence strategy.

Collaborators: GlobalIdentifier uses me for loading and saving values; in both cases GlobalIdentifier uses #ensure:

Public API and Key Messages

- ensure: it loads stored values, merge with existing in the image and saves the current state on the disk

Example:
	GlobalIdentifierPersistence ston
		previous: (GlobalIdentifierPersistence fuel
					preferences: FileLocator workingDirectory / 'example.fuel';
					yourself);
		preferences: FileLocator workingDirectory / 'example.ston';
		ensure: (Dictionary new at: #a put: 1; at: #b put: 2);
		yourself

Internal Representation and Key Implementation Points.

    Instance Variables
	preferences:				<FileReference>
	previousPersistence:		<GlobalIdentifierPersistence>
!
!GlobalIdentifierPersistence methodsFor: 'accessing' stamp: ''!
checker
	"Return a GlobalIdentifierPersistenceChecker object."
	^ checker ifNil: [ checker := GlobalIdentifierPersistenceChecker new ]! !

!GlobalIdentifierPersistence methodsFor: 'load and saving' stamp: ''!
save: aDictionary
	self isEnabled ifFalse: [ ^ self ].
	self delete.
	self ensureDirectory.
	self preferences binaryWriteStreamDo: [ :aPreferenceStream | 
			self save: aDictionary into: aPreferenceStream ]! !

!GlobalIdentifierPersistence methodsFor: 'operations' stamp: ''!
delete
	"self deletePreferences"
	[ self preferences ensureDelete ]
	on: Error do: [ "ignore" ]! !

!GlobalIdentifierPersistence methodsFor: 'load and saving' stamp: ''!
load
	"It loads and returns stored dictionary."
	^ self subclassResponsibility! !

!GlobalIdentifierPersistence methodsFor: 'accessing' stamp: ''!
preferences: anObject
	preferences := anObject! !

!GlobalIdentifierPersistence methodsFor: 'testing' stamp: ''!
isEnabled
	"If HOME directory does not exists, ignore the persistence mechanism.
	HOME directory may not exists in case of a server deployment.
	See https://pharo.manuscript.com/f/cases/19944"
	^ self checker isEnabled! !

!GlobalIdentifierPersistence methodsFor: 'accessing' stamp: ''!
previous
	^ previousPersistence! !

!GlobalIdentifierPersistence methodsFor: 'load and saving' stamp: ''!
save: aDictionary into: aWriteStream
	"Saves aDictionary into aWriteStream"
	self subclassResponsibility! !

!GlobalIdentifierPersistence methodsFor: 'accessing' stamp: ''!
previous: aGlobalIdentifierPersistence
	previousPersistence := aGlobalIdentifierPersistence! !

!GlobalIdentifierPersistence methodsFor: 'configuration' stamp: ''!
fileName
	^ self subclassResponsibility! !

!GlobalIdentifierPersistence methodsFor: 'testing' stamp: ''!
hasPreviousPersistence
	^ previousPersistence notNil! !

!GlobalIdentifierPersistence methodsFor: 'accessing' stamp: ''!
checker: aGlobalIdentifierPersistenceChecker
	checker := aGlobalIdentifierPersistenceChecker! !

!GlobalIdentifierPersistence methodsFor: 'load and saving' stamp: ''!
mayOverwrite: aDictionary
	"If I keep previous persistence strategy, I am the main one and I can overwrite the current preference file.
	I am called only on loading failure; it means when I cannot load preference file."
	self hasPreviousPersistence ifTrue: [ self save: aDictionary ].! !

!GlobalIdentifierPersistence methodsFor: 'merging' stamp: ''!
mergeExisting: existingDictionary stored: storedDictionary
	^ GlobalIdentifierMerger new
			existing: existingDictionary;
			stored: storedDictionary;
			merge! !

!GlobalIdentifierPersistence methodsFor: 'testing' stamp: ''!
shouldCallPreviousPersistence
	^ self preferences exists not and: [ self hasPreviousPersistence ]! !

!GlobalIdentifierPersistence methodsFor: 'load and saving' stamp: ''!
load: existingDictionary
	"It loads stored information into existingDictionary."
	self isEnabled ifFalse: [ ^ self ].
	self preferences ifAbsent: [
		"This is a new computer, so we define new computer UUID.
		User still has to agree about sending data if it is not has been done yet."
		^ self save: existingDictionary ].
	[ (self mergeExisting: existingDictionary stored: self load)
			ifTrue: [ self save: existingDictionary ].
	] on: Error do: [ 
		"Preferences likely contains a different settings version, so we store the actual one.
		We should keep the preferences as stable as possible."
		self mayOverwrite: existingDictionary ]! !

!GlobalIdentifierPersistence methodsFor: 'configuration' stamp: ''!
defaultPreferences
	^ FileLocator preferences / 'pharo' / self fileName! !

!GlobalIdentifierPersistence methodsFor: 'accessing' stamp: ''!
preferences
	^ preferences ifNil: [ preferences := self defaultPreferences ]! !

!GlobalIdentifierPersistence methodsFor: 'operations' stamp: ''!
ensureDirectory
	self preferences parent ensureCreateDirectory ! !

!GlobalIdentifierPersistence methodsFor: 'load and saving' stamp: ''!
ensure: existingDictionary
	"It proceeds all backward compatibility work."
	self shouldCallPreviousPersistence ifTrue: [ 
		previousPersistence ensure: existingDictionary ].
	self load: existingDictionary! !

!GlobalIdentifierPersistence methodsFor: 'accessing' stamp: ''!
preferencesContents

	^ self preferences binaryReadStreamDo: [ :stream | stream contents ]! !

!GlobalIdentifierPersistence class methodsFor: 'instance creation' stamp: ''!
ston
	^ GlobalIdentifierStonPersistence new! !

!GlobalIdentifierPersistence class methodsFor: 'instance creation' stamp: ''!
fuel
	^ GlobalIdentifierFuelPersistence new! !

!GlobalIdentifierPersistenceChecker commentStamp: ''!
I check whether a persistence should be stored. I return answer of `FileIdentifier home exists`. Such use case is important for a server deployment, where HOME directory may not exists. See https://pharo.fogbugz.com/f/cases/19944

I collaborate with GlobalIdentifierPersistence that uses me for checking before any disk operation.!
!GlobalIdentifierPersistenceChecker methodsFor: 'testing' stamp: ''!
isEnabled
	"See class comment or https://pharo.manuscript.com/f/cases/19944."
	^ FileLocator home exists and: [ FileLocator home fileSystem isWritable ]! !

!GlobalIdentifierPersistenceMockChecker commentStamp: ''!
I am a MOCK equivalent for GlobalIdentifierPersistenceChecker, useful for testing behavior.!
!GlobalIdentifierPersistenceMockChecker methodsFor: 'testing' stamp: ''!
isEnabled
	^ self answer value! !

!GlobalIdentifierPersistenceMockChecker methodsFor: 'accessing' stamp: ''!
answer: anObject
	answer := anObject! !

!GlobalIdentifierPersistenceMockChecker methodsFor: 'accessing' stamp: ''!
answer
	^ answer ifNil: [ answer := false ]! !

!GlobalIdentifierPersistenceTest commentStamp: ''!
A GlobalIdentifierPersistenceTest is a test class for testing the behavior of GlobalIdentifierPersistence!
!GlobalIdentifierPersistenceTest methodsFor: 'tests' stamp: ''!
testDelete
	preferences parent ensureCreateDirectory.
	preferences ensureCreateFile.
	self assert: preferences exists.
	persistence delete.
	self deny: preferences exists.
	! !

!GlobalIdentifierPersistenceTest methodsFor: 'tests' stamp: ''!
testLoad
	"Load when nothing is stored."
	| values |
	values := Dictionary new.
	values at: #a put: 42.
	persistence load: values.
	self assert: values size equals: 1.
	self assert: (values at: #a) equals: 42.
	self assert: preferences exists.! !

!GlobalIdentifierPersistenceTest methodsFor: 'tests' stamp: ''!
testLoad2
	"Load stored values."
	| values loaded |
	values := Dictionary new.
	values at: #a put: 42.
	persistence save: values.
	loaded := Dictionary new.
	persistence load: loaded.
	self assert: loaded equals: values.
! !

!GlobalIdentifierPersistenceTest methodsFor: 'running' stamp: ''!
tearDown
	preferences ensureDelete.
	super tearDown.! !

!GlobalIdentifierPersistenceTest methodsFor: 'tests' stamp: ''!
testEnsureDirectory
	persistence ensureDirectory.
	self assert: preferences parent exists.
	self deny: preferences exists.
	! !

!GlobalIdentifierPersistenceTest methodsFor: 'tests' stamp: ''!
testDefault
	self
		deny: preferences exists
		description: 'The preference file should not exist by default.'.
	self
		deny: preferences parent exists
		description: 'The preference directory should not exist by default.'! !

!GlobalIdentifierPersistenceTest methodsFor: 'running' stamp: ''!
setUpPreferencesAndChecker
	self subclassResponsibility! !

!GlobalIdentifierPersistenceTest methodsFor: 'accessing' stamp: ''!
persistenceClass
	^ self subclassResponsibility! !

!GlobalIdentifierPersistenceTest methodsFor: 'accessing' stamp: ''!
folderName
	^ 'pharoPreferencesTestFolder'! !

!GlobalIdentifierPersistenceTest methodsFor: 'tests' stamp: ''!
testIsEnabled
	self assert: persistence isEnabled.! !

!GlobalIdentifierPersistenceTest methodsFor: 'tests' stamp: ''!
testLoad3
	"Load stored values."

	| values loaded |
	persistence checker: self newFalseChecker.
	values := Dictionary new.
	values at: #a put: 42.
	persistence save: values.
	loaded := Dictionary new.
	persistence load: loaded.
	self assertEmpty: loaded! !

!GlobalIdentifierPersistenceTest methodsFor: 'tests' stamp: ''!
testSave
	| values |
	values := Dictionary new.
	values at: #a put: 42.
	persistence save: values.
	self assert: preferences exists.! !

!GlobalIdentifierPersistenceTest methodsFor: 'instance creation' stamp: ''!
newFalseChecker
	^ GlobalIdentifierPersistenceMockChecker new! !

!GlobalIdentifierPersistenceTest methodsFor: 'tests' stamp: ''!
testSave2
	| values |
	persistence checker: self newFalseChecker.
	values := Dictionary new.
	values at: #a put: 42.
	persistence save: values.
	self deny: preferences exists.! !

!GlobalIdentifierPersistenceTest methodsFor: 'tests' stamp: ''!
testIsEnabled2
	persistence checker: self newFalseChecker.
	self deny: persistence isEnabled.! !

!GlobalIdentifierPersistenceTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self setUpPreferencesAndChecker.
	persistence := self persistenceClass new preferences: preferences; yourself.
	persistence checker: checker.! !

!GlobalIdentifierPersistenceTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = GlobalIdentifierPersistenceTest name! !

!GlobalIdentifierStonPersistence commentStamp: ''!
I serialize or materialize objects using STON framework. Create instance of me calling GlobalIdentifierPersistence ston.!
!GlobalIdentifierStonPersistence methodsFor: 'load and saving' stamp: ''!
load
	^ self preferences readStreamDo: [ :aReadStream |
			STON fromStream: aReadStream ]! !

!GlobalIdentifierStonPersistence methodsFor: 'load and saving' stamp: ''!
save: aDictionary into: aWriteStream
	STON put: aDictionary onStreamPretty: (ZnCharacterWriteStream on: aWriteStream encoding: 'utf8')! !

!GlobalIdentifierStonPersistence methodsFor: 'configuration' stamp: ''!
fileName
	^ 'org.pharo.global-identifiers.ston'! !

!GlobalIdentifierStonPersistenceTest commentStamp: ''!
SUnit tests for GlobalIdentifierStonPersistence!
!GlobalIdentifierStonPersistenceTest methodsFor: 'running' stamp: ''!
setUpPreferencesAndChecker
	| memory |
	memory := FileSystem memory.
	preferences := memory workingDirectory / self folderName / 'pharoX' / 'preferences.ston'.
	preferences ensureDelete.
	checker := GlobalIdentifierPersistenceMockChecker new
		answer: [ memory workingDirectory exists ]! !

!GlobalIdentifierStonPersistenceTest methodsFor: 'accessing' stamp: ''!
persistenceClass
	^ GlobalIdentifierStonPersistence! !

!GlobalIdentifierTest commentStamp: ''!
A GlobalIdentifierTest is a test class for testing the behavior of GlobalIdentifier!
!GlobalIdentifierTest methodsFor: 'tests' stamp: ''!
testEnsure
	"The computer UUID is not stored immediately because the Pharo Integration Server
	raised building errors when storing the computer UUID on the CI server."
	| stored |
	self testPreferenceFilesNotCollideWithRealPreferences.
	identifier ensure.
	self assert: preferences exists description: 'The actual preferences should be stored now.'.
	stored := identifier persistenceStrategy load.
	self assert: stored equals: identifier persistedInformation.
! !

!GlobalIdentifierTest methodsFor: 'running' stamp: ''!
tearDown
	preferences ensureDelete.
	(FileLocator workingDirectory / self folderName) 
		ensureDeleteAllChildren; 
		ensureDelete.
	super tearDown.	! !

!GlobalIdentifierTest methodsFor: 'tests' stamp: ''!
testBackwardCompatibility2
	"Let's say that we have information stored using both FUEL and STON, and we use STON.
	We will ignore FUEL file and load STON."

	| fuelPersistence fuelPrefereces fuelDictionary stonDictionary |
	fuelPersistence := GlobalIdentifierPersistence fuel.
	fuelPersistence
		checker:
			(self newChecker
				answer: [ FileLocator workingDirectory exists ];
				yourself).
	fuelPrefereces := preferences parent / 'old-preferences.fuel'.
	fuelPersistence preferences: fuelPrefereces.
	fuelDictionary := Dictionary new.
	fuelDictionary at: #computerUUID put: 42.
	fuelPersistence save: fuelDictionary.
	identifier persistenceStrategy previous: fuelPersistence.
	stonDictionary := Dictionary new.
	stonDictionary at: #computerUUID put: 21.
	identifier persistenceStrategy save: stonDictionary.
	self deny: identifier computerUUID equals: 42.
	self deny: identifier computerUUID equals: 21.
	self assert: fuelPersistence preferences exists.
	self assert: identifier persistenceStrategy preferences exists.
	identifier ensure.
	self assert: identifier computerUUID equals: 21 asString! !

!GlobalIdentifierTest methodsFor: 'instance creation' stamp: ''!
newChecker
	^ GlobalIdentifierPersistenceMockChecker new! !

!GlobalIdentifierTest methodsFor: 'tests' stamp: ''!
testDefault
	self deny: preferences exists description: 'The preference file should not exists by default.'.
	self deny: preferences parent exists description: 'The preference directory should not exists by default.'! !

!GlobalIdentifierTest methodsFor: 'tests' stamp: ''!
testBackwardCompatibility
	"Let's say that we have information stored using FUEL, but we use STON.
	We do not have any STON stored value.
	Let's check that we load the FUEL, then stores it as STON."

	| fuelPersistence fuelPrefereces fuelDictionary |
	fuelPersistence := GlobalIdentifierPersistence fuel.
	fuelPersistence
		checker:
			(self newChecker
				answer: [ FileLocator workingDirectory exists ];
				yourself).
	fuelPrefereces := preferences parent / 'old-preferences.fuel'.
	fuelPersistence preferences: fuelPrefereces.
	fuelDictionary := Dictionary new.
	fuelDictionary at: #computerUUID put: 42.
	fuelPersistence save: fuelDictionary.
	identifier persistenceStrategy previous: fuelPersistence.
	self deny: identifier computerUUID equals: 42.
	self assert: fuelPersistence preferences exists.
	identifier ensure.
	self assert: identifier computerUUID equals: 42 asString.
	self assert: identifier persistenceStrategy preferences exists! !

!GlobalIdentifierTest methodsFor: 'tests' stamp: ''!
testPreferenceFilesNotCollideWithRealPreferences
	"Ensure that setUp is done correctly and we do not override or change production preferences.
	See https://pharo.manuscript.com/f/cases/19501"
	| strategy |
	strategy := identifier persistenceStrategy.
	[ strategy ] whileNotNil: [ 
		self deny: (FileLocator preferences contains: strategy preferences)
			description: 'Tested preference file should NOT be stored in the preferences directory.'.
		self assert: (FileLocator preferences contains: strategy defaultPreferences)
			description: 'Default preference file should BE stored in the preferences directory.'.
		strategy := strategy previous.
	].! !

!GlobalIdentifierTest methodsFor: 'accessing' stamp: ''!
actualPreferencesFileName
	^ identifier persistenceStrategy fileName! !

!GlobalIdentifierTest methodsFor: 'tests' stamp: ''!
testComputerUUID
	"The computer UUID is not stored immediately because the Pharo Integration Server
	raised building errors when storing the computer UUID on the CI server."
	self assert: identifier computerUUID notNil.
	self assert: identifier computerUUID isString.
	self testDefault.! !

!GlobalIdentifierTest methodsFor: 'accessing' stamp: ''!
folderName
	^ 'pharoPreferencesTestFolder'! !

!GlobalIdentifierTest methodsFor: 'running' stamp: ''!
setUpPersistenceStrategyAndChecker
	self subclassResponsibility! !

!GlobalIdentifierTest methodsFor: 'tests' stamp: ''!
testBackwardCompatibility4
	"Let's say that we have information stored using FUEL but we cannot read the file. 
	We use STON. The STON preference file is broken, we cannot read it.
	Let's check that we keep FUEL file untouched and creates STON file."

	| fuelPersistence fuelPrefereces data dictionary |
	fuelPersistence := GlobalIdentifierPersistence fuel.
	fuelPersistence
		checker:
			(self newChecker
				answer: [ FileLocator workingDirectory exists ];
				yourself).
	fuelPrefereces := preferences parent / 'old-preferences.fuel'.
	fuelPrefereces parent ensureCreateDirectory.
	data := 'some data'.
	"we create unreadable file."
	fuelPrefereces writeStreamDo: [ :aStream | aStream nextPutAll: data ].
	"we create broken file."
	identifier persistenceStrategy preferences writeStreamDo: [ :aStream | aStream nextPutAll: data ].
	fuelPersistence preferences: fuelPrefereces.
	identifier persistenceStrategy previous: fuelPersistence.
	self assert: fuelPrefereces exists.
	self assert: fuelPrefereces contents equals: data.
	self assert: identifier persistenceStrategy preferences exists.
	self assert: identifier persistenceStrategy preferences contents equals: data.
	identifier ensure.
	self assert: fuelPrefereces exists.
	self assert: fuelPrefereces contents equals: data.
	self assert: identifier persistenceStrategy preferences exists.
	self deny: identifier persistenceStrategy preferencesContents equals: data.
	dictionary := Dictionary new.
	identifier persistenceStrategy load: dictionary.
	self assert: dictionary equals: identifier persistedInformation! !

!GlobalIdentifierTest methodsFor: 'tests' stamp: ''!
testDoNotStoreIfHomeDoesNotExists
	"Ignore persistence if HOME directory does not exists.
	In the case that the image is deployed on a server, HOME directory may not exists.
	See issue https://pharo.manuscript.com/f/cases/19944."
	| strategy |
	strategy := identifier persistenceStrategy.
	[ strategy ] whileNotNil: [ 
		strategy checker: (self newChecker answer: false; yourself).
		strategy := strategy previous.
	].
	identifier ensure.
	strategy := identifier persistenceStrategy.
	[ strategy ] whileNotNil: [ 
		self deny: strategy preferences exists.
		strategy := strategy previous.
	].
	self assert: identifier computerUUID notNil.
! !

!GlobalIdentifierTest methodsFor: 'tests' stamp: ''!
testBackwardCompatibility3
	"Let's say that we have information stored using FUEL but we cannot read the file. 
	We use STON. We do not have any STON stored value.
	Let's check that we keep FUEL file untouched and creates STON file."
	| fuelPersistence fuelPrefereces data |
	fuelPersistence := GlobalIdentifierPersistence fuel.
	fuelPersistence checker: (self newChecker answer: [ FileLocator workingDirectory exists ]; yourself).
	fuelPrefereces := preferences parent / 'old-preferences.fuel'.
	fuelPrefereces parent ensureCreateDirectory.
	data := 'some data'.
	fuelPrefereces writeStreamDo: [ :aStream | aStream nextPutAll: data ].
	fuelPersistence preferences: fuelPrefereces.
	identifier persistenceStrategy previous: fuelPersistence.
	self assert: fuelPrefereces exists.
	self assert: fuelPrefereces contents equals: data.
	self deny: identifier persistenceStrategy preferences exists.
	identifier ensure.
	self assert: fuelPrefereces exists.
	self assert: fuelPrefereces contents equals: data.
	self assert: identifier persistenceStrategy preferences exists.! !

!GlobalIdentifierTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	identifier := GlobalIdentifier basicNew initialize.
	self setUpPersistenceStrategyAndChecker! !

!GlobalIdentifierTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = GlobalIdentifierTest ! !

!GlobalIdentifierWithDefaultConfigurationTest commentStamp: ''!
SUnit tests for GlobalIdentifier with a default configuration!
!GlobalIdentifierWithDefaultConfigurationTest methodsFor: 'tests' stamp: ''!
testEnsure
	| stored |
	super testEnsure.
	self assert: oldPreferences exists description: 'The old preferences should be stored now.'.
	stored := identifier persistenceStrategy previous load.
	self assert: stored equals: identifier persistedInformation.! !

!GlobalIdentifierWithDefaultConfigurationTest methodsFor: 'running' stamp: ''!
tearDown
	oldPreferences ensureDelete.
	super tearDown! !

!GlobalIdentifierWithDefaultConfigurationTest methodsFor: 'running' stamp: ''!
setUpPersistenceStrategyAndChecker
	preferences := FileLocator workingDirectory / self folderName / 'pharoX' / self actualPreferencesFileName.
	preferences ensureDelete.
	oldPreferences := FileLocator workingDirectory / self folderName / 'pharoX' / self oldPreferencesFileName.
	oldPreferences ensureDelete.
	identifier persistenceStrategy preferences: preferences.
	identifier persistenceStrategy previous preferences: oldPreferences.
	identifier persistenceStrategy checker: (self newChecker answer: [ FileLocator workingDirectory exists ]; yourself).
	identifier persistenceStrategy previous checker: (self newChecker answer: [ FileLocator workingDirectory exists ]; yourself).
	! !

!GlobalIdentifierWithDefaultConfigurationTest methodsFor: 'accessing' stamp: ''!
oldPreferencesFileName
	^ identifier persistenceStrategy previous fileName! !

!GlobalIdentifierWithFuelTest commentStamp: ''!
SUnit tests for GlobalIdentifier with FUEL!
!GlobalIdentifierWithFuelTest methodsFor: 'accessing' stamp: ''!
actualPreferencesFileName
	^ 'preferences.fuel'! !

!GlobalIdentifierWithFuelTest methodsFor: 'running' stamp: ''!
setUpPersistenceStrategyAndChecker
	preferences := FileLocator workingDirectory / self folderName / 'pharoX' / self actualPreferencesFileName.
	preferences ensureDelete.
	identifier persistenceStrategy: GlobalIdentifierPersistence fuel.
	identifier persistenceStrategy preferences: preferences.
	identifier persistenceStrategy checker: (self newChecker answer: [ FileLocator workingDirectory exists ]; yourself).
! !

!GlobalIdentifierWithStonTest commentStamp: ''!
SUnit tests for GlobalIdentifier with STON!
!GlobalIdentifierWithStonTest methodsFor: 'accessing' stamp: ''!
actualPreferencesFileName
	^ 'preferences.ston'! !

!GlobalIdentifierWithStonTest methodsFor: 'running' stamp: ''!
setUpPersistenceStrategyAndChecker
	preferences := FileLocator workingDirectory / self folderName / 'pharoX' / self actualPreferencesFileName.
	preferences ensureDelete.
	identifier persistenceStrategy: GlobalIdentifierPersistence ston.
	identifier persistenceStrategy preferences: preferences.
	identifier persistenceStrategy checker: (self newChecker answer: [ FileLocator workingDirectory exists ]; yourself).
! !

!GlobalVariable commentStamp: ''!
I model Globals. I am stored as a binding in the Smalltalk globals.

The compiler forwards bytecode generation to me for accessing the variable.!
!GlobalVariable methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForReferencesFor: aStep
	<stSpotterOrder: 130>
	aStep listProcessor
			title: 'References';
			allCandidates: [ (SystemNavigation default allReferencesTo: self) collect: [:each | each compiledMethod] ];
			itemName: [ :method | method displayString ];
			filter: StFilterSubstring! !

!GlobalVariable methodsFor: 'queries' stamp: ''!
definingClass
	"The class defining the variable. For Globals, return nil"
	^nil! !

!GlobalVariable methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterClassFor: aStep
	<stSpotterOrder: 50>
	aStep listProcessor
			title: 'Class';
			allCandidates: [ { self value class }];
			itemIcon: #systemIcon;
			filter: StFilterSubstring! !

!GlobalVariable methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
stActDefault
	self value inspect! !

!GlobalVariable methodsFor: 'testing' stamp: ''!
isGlobalVariable
	^true! !

!GlobalVariable methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment 

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGGlobalVariable named: self key asSymbol parent: anRGEnvironment].! !

!GlobalVariable methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder
	methodBuilder pushLiteralVariable: self! !

!GlobalVariable methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder

	methodBuilder storeIntoLiteralVariable: self! !

!GlobalVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitGlobalVariableNode: aNode! !

!GlobalVariable methodsFor: 'accessing' stamp: ''!
scope
	"The scope of Globals is Smalltalk globals"
	^ Smalltalk globals! !

!GlobalVariableTest commentStamp: ''!
Tests for GlobalVariable!
!GlobalVariableTest methodsFor: 'tests - properties' stamp: ''!
testNotWrittenInMethod

	self deny: (Object binding isWrittenIn: self class >> testSelector)! !

!GlobalVariableTest methodsFor: 'tests - properties' stamp: ''!
testPropertyAtPut

	| testValue |
	
	testValue := Date today.
	self class binding propertyAt: #testKeySelector put: testValue.
	self
		assert: (self class binding propertyAt: #testKeySelector)
		equals: testValue.
	self class binding removeProperty: #testKeySelector.
	self assert: self class binding properties isNil.! !

!GlobalVariableTest methodsFor: 'tests - properties' stamp: ''!
testScope

	self assert: Object binding scope equals: Object environment.
	self assert: (Object binding scope lookupVar: Object binding name) equals: Object binding.! !

!GlobalVariableTest methodsFor: 'tests - properties' stamp: ''!
testIsReadInMethod

	self assert: (Object binding isReadIn: self class >> testSelector).
	self deny: ((self class environment classNamed: #String) binding 
							isReadIn: self class >> testSelector).! !

!GlobalVariableTest methodsFor: 'tests - properties' stamp: ''!
testRemoveProperty

	self class binding propertyAt: #testKeySelector put: 1.
		
	self class binding removeProperty: #testKeySelector.
	self
		assert: (self class binding propertyAt: #testKeySelector)
		equals: nil.
		
	self assert: self class binding properties isNil.! !

!GlobalVariableTest methodsFor: 'tests' stamp: ''!
testIsShadowing
	self deny: Object binding isShadowing! !

!GlyphForm commentStamp: ''!
A specialized form for glyphs!
!GlyphForm methodsFor: 'accessing' stamp: ''!
advance: aNumber
	^advance := aNumber! !

!GlyphForm methodsFor: 'accessing' stamp: ''!
linearAdvance
	^linearAdvance! !

!GlyphForm methodsFor: 'converting' stamp: ''!
invertedAndAlphaMultiplied
	| result |
	result := super invertedAndAlphaMultiplied.
	^ (self class extent: result extent depth: result depth bits: result bits)
		offset: offset;
		advance: advance;
		linearAdvance: linearAdvance;
		yourself! !

!GlyphForm methodsFor: 'converting' stamp: ''!
withAlphaExtractedFromSubpixelRendering
	| result |
	"Take the maximum of r,g,b as the alpha. Then multiply by a."
	result := self collectColors: [:c |
		| r g b a|
		r := c red.
		g := c green.
		b := c blue.
		a := c alpha.
		a := ((r max: g) max: b) * a.
		
		Color r: r g: g b: b alpha: a
	].

	^ (self class extent: result extent depth: result depth bits: result bits)
		offset: offset;
		advance: advance;
		linearAdvance: linearAdvance;
		yourself! !

!GlyphForm methodsFor: 'converting' stamp: ''!
asFormOfDepth: d
	| newForm |
	d = self depth ifTrue:[^self].
	newForm := self class extent: self extent depth: d.
	(BitBlt toForm: newForm)
		colorMap: (self colormapIfNeededFor: newForm);
		copy: (self boundingBox)
		from: 0@0 in: self
		fillColor: nil rule: Form over.
	newForm 
		offset: offset;
		advance:advance;
		linearAdvance: linearAdvance.
	^newForm! !

!GlyphForm methodsFor: 'accessing' stamp: ''!
linearAdvance: aNumber
	^linearAdvance := aNumber! !

!GlyphForm methodsFor: 'accessing' stamp: ''!
advance
	^advance! !

!GlyphRenderer commentStamp: ''!
Renderer for font glyphs!
!GlyphRenderer methodsFor: 'private - initialization' stamp: ''!
initForFont: aFont

	self subclassResponsibility! !

!GlyphRenderer class methodsFor: 'instance creation' stamp: ''!
forFont: aFont
	^ self basicNew initForFont: aFont! !

!Gofer commentStamp: ''!
: 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: 'repositories - options' stamp: ''!
disablePackageCache
	"Disable the use of the package-cache repository."

	packageCacheRepository := nil! !

!Gofer methodsFor: 'references' stamp: ''!
configuration
	"Add a default Configuration package by using the repository name.
	Assumes that there has been at least one repository set"
	^ self configurationOf: self repositories last project capitalized.! !

!Gofer methodsFor: 'operations' stamp: ''!
reinitialize
	"Calls the class side initializers on all package code."
	
	^ self execute: GoferReinitialize! !

!Gofer methodsFor: 'repositories' stamp: ''!
directory: aDirectoryOrString
	"Add a file-system repository at aDirectoryOrString."

	| repository |
	repository := (aDirectoryOrString isString and: [ aDirectoryOrString endsWith: '*' ])
		ifTrue: [ 
			MCSubDirectoryRepository new
				directory: aDirectoryOrString allButLast asFileReference;
				yourself ]
		ifFalse: [ 
			(MCDirectoryRepository new)
				directory:
						(aDirectoryOrString isString
								ifTrue: [ aDirectoryOrString asFileReference ]
								ifFalse: [ aDirectoryOrString ]);
				yourself ].
	self repository: repository! !

!Gofer methodsFor: 'operations' stamp: ''!
loadVersion: anMetacelloVersionIdentifierSymbol
	"Load the given version name"
	^ self execute: GoferMetacelloLoad do: [ :operation|
		operation version: anMetacelloVersionIdentifierSymbol ]! !

!Gofer methodsFor: 'references' stamp: ''!
configurationOf: aProjectName
	"Add a package reference to the configuration of the given project"
	references addLast: (GoferConfigurationReference name: aProjectName)! !

!Gofer methodsFor: 'repositories - options' stamp: ''!
disableRepositoryErrors
	"Silently swallow all repository errors."

	errorBlock := [ :error | error resume: #() ]! !

!Gofer methodsFor: 'operations' stamp: ''!
recompile
	"Recompile the specified packages."

	^ self execute: GoferRecompile! !

!Gofer methodsFor: '*metacello-testsmc' stamp: ''!
metacelloLoad
	"Load the specified packages into the image."
	
	^ self execute: MetacelloGoferLoad! !

!Gofer methodsFor: 'operations' stamp: ''!
cleanup
	"Cleans the specified packages."
	
	^ self execute: GoferCleanup! !

!Gofer methodsFor: 'repositories - places' stamp: ''!
smalltalkhubUser: aUserName project: aProjectName
	self repository: (MCSmalltalkhubRepository owner: aUserName project: aProjectName)! !

!Gofer methodsFor: 'operations' stamp: ''!
loadBleedingEdge
	"Load the baseline of the previously specifed configuration."
	
	^ self loadVersion: #bleedingEdge! !

!Gofer methodsFor: 'repositories - places' stamp: ''!
gemsource: aString
	self url: 'http://seaside.gemstone.com/ss/' , aString! !

!Gofer methodsFor: 'accessing' stamp: ''!
resolved
	"Answer the resolved references of the receiver."

	^ self references collect: [ :each | each resolveWith: self ]! !

!Gofer methodsFor: 'operations' stamp: ''!
revert
	"Revert the specified packages to the currently loaded version."
	
	^ self execute: GoferRevert! !

!Gofer methodsFor: 'operations' stamp: ''!
commit
	"Commit the modified packages."

	^ self execute: GoferCommit! !

!Gofer methodsFor: 'references' stamp: ''!
package: aString
	"Add the package aString to the receiver. aString is a package name as it appears in the Monticello Browser, something like 'Magritte-Seaside'. Gofer will try to resolve this name to an actual version in one of the configured repositories before doing something with the package. Gofer sorts all the versions in all the repositories according to branch name (versions without a branch are preferred), version number, author name and repository priority. The top hit of this sorted list is eventually going to be loaded and used."

	references addLast: (GoferPackageReference name: aString)! !

!Gofer methodsFor: 'operations' stamp: ''!
remoteChanges
	"Display the changes between the working copy and the remote changes."
	
	^ self execute: GoferRemoteChanges! !

!Gofer methodsFor: 'operations' stamp: ''!
load
	"Load the specified packages into the image."
	
	^ self execute: GoferLoad! !

!Gofer methodsFor: 'initialization' stamp: ''!
initialize
	self enablePackageCache; enableRepositoryErrors.
	references := OrderedCollection new.
	repositories := OrderedCollection new! !

!Gofer methodsFor: 'accessing' stamp: ''!
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: 'deprecated' stamp: ''!
addPackage: aPackage

	self
		deprecated: 'Use #package: instead'
		transformWith: '`@receiver addPackage: `@arg' 
						-> '`@receiver package: `@arg'.

	self package: aPackage! !

!Gofer methodsFor: 'repositories - places' stamp: ''!
renggli: aString
	self url: 'http://source.lukas-renggli.ch/' , aString! !

!Gofer methodsFor: 'copying' stamp: ''!
postCopy
	references := references copy.
	repositories := repositories copy.
	resolvedReferencesCache := nil! !

!Gofer methodsFor: 'operations' stamp: ''!
push
	"Upload local versions from local cache into remote repositories."

	^ self execute: GoferPush! !

!Gofer methodsFor: 'repositories' stamp: ''!
url: urlString username: username password: passwordString
	"Add urlString as a repository for the following package operations."
	| repository |
	repository := MCRepository fromUrl: 
		(urlString asUrl
			username: (username ifEmpty: [ nil ]);
			password: (passwordString ifEmpty: [ nil ]);
			yourself).
	
	self repository: repository.! !

!Gofer methodsFor: 'operations' stamp: ''!
unload
	"Unload the specified packages."
	
	^ self execute: GoferUnload! !

!Gofer methodsFor: 'operations' stamp: ''!
merge
	"Merge the specified packages into their working copies."
	
	^ self execute: GoferMerge! !

!Gofer methodsFor: 'private' stamp: ''!
execute: anOperationClass
	^ self execute: anOperationClass do: nil! !

!Gofer methodsFor: 'operations' stamp: ''!
commit: aString
	"Commit the modified packages with the given commit message."

	^ self execute: GoferCommit do: [ :operation | operation message: aString ]! !

!Gofer methodsFor: 'repositories - places' stamp: ''!
blueplane: aString
	self url: 'http://squeaksource.blueplane.jp/' , aString! !

!Gofer methodsFor: 'accessing' stamp: ''!
references
	"Answer the configured references."

	^ Array withAll: references! !

!Gofer methodsFor: 'accessing' stamp: ''!
repositories
	"Answer the configured monticello repositories."

	| result |
	result := OrderedCollection withAll: repositories.
	packageCacheRepository ifNotNil: [ result addFirst: packageCacheRepository ].
	^ result asArray! !

!Gofer methodsFor: 'operations' stamp: ''!
loadDevelopment
	"Load the development version of the previously specifed configuration."
	
	^ self loadVersion: #development! !

!Gofer methodsFor: 'private' stamp: ''!
execute: anOperationClass do: aBlock
	| operation |
	operation := anOperationClass on: self copy.
	aBlock ifNotNil: [ aBlock value: operation ].
	^ operation execute! !

!Gofer methodsFor: 'repositories - options' stamp: ''!
enableRepositoryErrors
	"Throw an exception when repositories are not available."

	errorBlock := [ :error | error pass ]! !

!Gofer methodsFor: 'repositories' stamp: ''!
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 - places' stamp: ''!
squeakfoundation: aString
	self url: 'http://source.squeakfoundation.org/' , aString! !

!Gofer methodsFor: 'operations' stamp: ''!
update
	"Update the specified packages."
	
	^ self execute: GoferUpdate! !

!Gofer methodsFor: 'repositories - places' stamp: ''!
squeaksource: aProjectName
	self repository: (MCSqueaksourceRepository location: 'http://www.squeaksource.com/' , aProjectName)! !

!Gofer methodsFor: 'operations' stamp: ''!
fetch
	"Download versions from remote repositories into the local cache."

	^ self execute: GoferFetch! !

!Gofer methodsFor: 'repositories - places' stamp: ''!
squeaksource3: aProjectName
	self repository: (MCGemstoneRepository location: 'http://ss3.gemtalksystems.com/ss/' , aProjectName)! !

!Gofer methodsFor: '*metacello-testsmc' stamp: ''!
metacelloUnload
	"Unload the specified packages."
	
	^ self execute: MetacelloTestsGoferUnload! !

!Gofer methodsFor: 'references' stamp: ''!
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: '*metacello-testsmc' stamp: ''!
metacelloCleanup
	"Cleans the specified packages."
	
	^ self execute: MetacelloTestsGoferCleanup! !

!Gofer methodsFor: 'repositories' stamp: ''!
url: anUrlString
	"Add anUrlString as a repository for the following package operations."

	self url: anUrlString username: String new password: String new! !

!Gofer methodsFor: 'operations' stamp: ''!
localChanges
	"Answer the changes between the base version and the working copy."
	
	^ self execute: GoferLocalChanges! !

!Gofer methodsFor: 'operations' stamp: ''!
loadStable
	"Load the stable version of the previously specifed configuration."
	
	^ self loadVersion: #stable! !

!Gofer methodsFor: 'repositories - options' stamp: ''!
enablePackageCache
	"Enable the use of the package-cache repository."

	packageCacheRepository := MCCacheRepository uniqueInstance.! !

!Gofer methodsFor: 'repositories - places' stamp: ''!
impara: aString
	self url: 'http://source.impara.de/' , aString! !

!Gofer methodsFor: 'references' stamp: ''!
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 - places' stamp: ''!
wiresong: aString
	self url: 'http://source.wiresong.ca/' , aString! !

!Gofer methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
basicReferencesIn: aRepository
	^ [ aRepository goferReferences asSortedCollection asArray ] 
		on: GoferRepositoryError
		do: errorBlock! !

!Gofer class methodsFor: 'instance creation' stamp: ''!
it
	^ self new! !

!Gofer class methodsFor: 'private' stamp: ''!
gofer
	"Create a Gofer instance"

	^ self new
		renggli: 'gofer';
		package: 'Gofer-Core';
		package: 'Gofer-Tests';
		yourself! !

!GoferApiTest commentStamp: ''!
SUnit tests for Gofer API!
!GoferApiTest methodsFor: 'tests - references' stamp: ''!
testConstraintReference

	| reference |
	gofer 
		repository: self monticelloRepository; 
		package: 'GoferBar' constraint: [ :ref | ref branch = 'branch' ].
	
	self assert: gofer resolved size equals: 1.
	
	reference := gofer resolved first.
	
	self assert: (reference isKindOf: GoferResolvedReference).
	self assert: reference packageName equals: 'GoferBar'.
	self assert: reference author equals: 'lr'.
	self assert: reference branch equals: 'branch'.
	self assert: reference versionNumber equals: 2.
	self assert: reference repository equals: self monticelloRepository! !

!GoferApiTest methodsFor: 'tests - repositories' stamp: ''!
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: 'tests - repositories - options' stamp: ''!
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: 'tests - references' stamp: ''!
testVersionReference

	| reference |
	gofer 
		repository: self monticelloRepository; 
		version: 'GoferFoo-lr.2'.
	self assert: gofer resolved size equals: 1.
	
	reference := gofer resolved first.
	
	self assert: (reference isKindOf: GoferResolvedReference).
	self assert: reference packageName equals: 'GoferFoo'.
	self assert: reference author equals: 'lr'.
	self assertEmpty: reference branch.
	self assert: reference versionNumber equals: 2.
	self assert: reference repository equals: self monticelloRepository! !

!GoferApiTest methodsFor: 'tests - repositories' stamp: ''!
testCustomRepository

	gofer repository: self monticelloRepository.
	
	self assert: gofer repositories: (Array with: self monticelloRepository description).
	self assert: gofer repositories first equals: self monticelloRepository! !

!GoferApiTest methodsFor: 'tests - repositories - places' stamp: ''!
testRenggli

	gofer renggli: 'pier'.
	self assert: gofer repositories: #('http://source.lukas-renggli.ch/pier')! !

!GoferApiTest methodsFor: 'tests - repositories' stamp: ''!
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: 'tests - repositories - places' stamp: ''!
testGemsource

	gofer gemsource: 'Seaside29'.
	self assert: gofer repositories: #('http://seaside.gemstone.com/ss/Seaside29')! !

!GoferApiTest methodsFor: 'tests - repositories - places' stamp: ''!
testSmalltalkhub

	gofer smalltalkhubUser: 'dh83' project: 'ci'.
	self assert: gofer repositories: #('http://smalltalkhub.com/mc/dh83/ci/main/')! !

!GoferApiTest methodsFor: 'asserting' stamp: ''!
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: 'tests - repositories' stamp: ''!
testSubDirectoryRepository

	testingEnvironment
		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: 'tests' stamp: ''!
testInitialReferences

	self assertEmpty: gofer references! !

!GoferApiTest methodsFor: 'tests - references' stamp: ''!
testPackageReference

	| reference |
	gofer
		repository: self monticelloRepository;
		package: 'GoferFoo'.

	self assert: gofer resolved size equals: 1.

	reference := gofer resolved first.

	self assert: (reference isKindOf: GoferResolvedReference).
	self assert: reference packageName equals: 'GoferFoo'.
	self assert: reference author equals: 'lr'.
	self assertEmpty: reference branch.
	self assert: reference versionNumber equals: 4.
	self assert: reference repository equals: self monticelloRepository! !

!GoferApiTest methodsFor: 'tests - repositories - places' stamp: ''!
testWiresong

	gofer wiresong: 'ob'.
	self assert: gofer repositories: #('http://source.wiresong.ca/ob')! !

!GoferApiTest methodsFor: 'tests - repositories' stamp: ''!
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: 'tests - repositories - options' stamp: ''!
testRepositoryErrors

	gofer
		url: 'http://google.com/pharo_official_language_for_android';
		repository: self monticelloRepository.
	gofer package: 'GoferFoo'.
	gofer enableRepositoryErrors.
	self should: [ gofer resolved ] raise: GoferRepositoryError.
	gofer disableRepositoryErrors.
	gofer resolved! !

!GoferApiTest methodsFor: 'utilities' stamp: ''!
assert: aGofer repositories: anArray

	self assert: aGofer repositories size equals: anArray size.
	aGofer repositories with: anArray
		do: [ :first :second | 
			self assert: first description equals: second ]! !

!GoferApiTest methodsFor: 'tests - repositories' stamp: ''!
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: 'tests - repositories - places' stamp: ''!
testBlueplane

	gofer blueplane: 'SIXX'.
	self assert: gofer repositories: #('http://squeaksource.blueplane.jp/SIXX')! !

!GoferApiTest methodsFor: 'tests' stamp: ''!
testInitialRepositories

	gofer := Gofer new.

	self assert: gofer repositories size equals: 1.
	self assert: (gofer repositories first isKindOf: MCCacheRepository uniqueInstance class)! !

!GoferChanges commentStamp: ''!
Handling changes!
!GoferChanges methodsFor: 'queries' stamp: ''!
patchsetOf: aReference
	"Answer the source snapshot of aReference."
	
	| source target |
	source := self sourceSnapshotOf: aReference.
	target := self targetSnapshotOf: aReference.
	^ target patchRelativeToBase: source! !

!GoferChanges methodsFor: 'private' stamp: ''!
addReference: aReference

	super addReference: aReference.
	self model operations 
		addAll: (self patchsetOf: aReference) operations! !

!GoferChanges methodsFor: 'queries' stamp: ''!
sourceSnapshotOf: aReference
	"Answer the source snapshot of aReference."
	
	self subclassResponsibility! !

!GoferChanges methodsFor: 'running' stamp: ''!
execute

	^ self model! !

!GoferChanges methodsFor: 'private' stamp: ''!
defaultModel
	^ MCPatch operations: OrderedCollection new! !

!GoferChanges methodsFor: 'queries' stamp: ''!
targetSnapshotOf: aReference
	"Answer the source snapshot of aReference."
	
	self subclassResponsibility! !

!GoferChanges class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == GoferChanges! !

!GoferCleanup commentStamp: ''!
Cleanup working copies!
!GoferCleanup methodsFor: 'cleaning' stamp: ''!
cleanupProtocols: aWorkingCopy

	aWorkingCopy packageSet extendedClasses 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: ''!
execute

	self workingCopies
		do: [ :each | self cleanup: each ]! !

!GoferCleanup methodsFor: 'cleaning' stamp: ''!
cleanup: aWorkingCopy

	self 
		cleanupCategories: aWorkingCopy;
		cleanupProtocols: aWorkingCopy! !

!GoferCleanup methodsFor: 'cleaning' stamp: ''!
cleanupCategories: aWorkingCopy

	aWorkingCopy packageSet systemCategories do: [ :category |
		(Smalltalk organization classesInCategory: category) isEmpty
			ifTrue: [ Smalltalk organization removeSystemCategory: category ] ]! !

!GoferCommit commentStamp: ''!
Commit work!
!GoferCommit methodsFor: 'accessing' stamp: ''!
message: aString
	message := aString! !

!GoferCommit methodsFor: 'running' stamp: ''!
execute

	self workingCopies 
		do: [ :each | self execute: each ]! !

!GoferCommit methodsFor: 'running' stamp: ''!
execute: aWorkingCopy

	| repositories version |
	repositories := self gofer repositories
		reject: [ :repository | (aWorkingCopy changesRelativeToRepository: repository) isEmpty ].
	repositories isEmpty
		ifTrue: [ ^ self ].
	version := [ aWorkingCopy newVersionIn: (MCRepositoryGroup withRepositories: repositories) ]
		on: MCVersionNameAndMessageRequest
		do: [ :notifcation |
			self message ifNil: [ message := notifcation outer last ].
			notifcation resume: (Array with: notifcation suggestedName with: self message) ].
	self gofer repositories
		do: [ :repository | repository storeVersion: version ]! !

!GoferCommit methodsFor: 'accessing' stamp: ''!
message
	^ message! !

!GoferCommit methodsFor: 'initialization' stamp: ''!
initializeOn: aGofer

	super initializeOn: aGofer disablePackageCache! !

!GoferConfigurationReference commentStamp: ''!
A GoferPackageReference refers to the latest version of a Monticello package representing a Metacello Configuration.!
!GoferConfigurationReference methodsFor: 'testing' stamp: ''!
isConfigurationReference

	^ true! !

!GoferConfigurationReference methodsFor: 'accessing' stamp: ''!
project

	^ self configurationClass project! !

!GoferConfigurationReference methodsFor: 'accessing' stamp: ''!
name

	^ self configurationName! !

!GoferConfigurationReference methodsFor: 'accessing' stamp: ''!
configurationClass

	^ Smalltalk globals at: self configurationName asSymbol! !

!GoferConfigurationReference methodsFor: 'accessing' stamp: ''!
packageName

	^ self configurationName! !

!GoferConfigurationReference methodsFor: 'accessing' stamp: ''!
configurationName

	^ 'ConfigurationOf', name! !

!GoferConstraintReference commentStamp: ''!
A GoferPackageReference refers to the latest version of a Monticello package satisfying an additional constraint.!
!GoferConstraintReference methodsFor: 'private' stamp: ''!
matches: aResolvedReference

	^ (super matches: aResolvedReference) and: [ 
		  constraintBlock value: aResolvedReference ]! !

!GoferConstraintReference methodsFor: 'initialization' stamp: ''!
initializeName: aString constraint: aBlock

	self initializeName: aString.
	constraintBlock := aBlock! !

!GoferConstraintReference class methodsFor: 'instance creation' stamp: ''!
name: aString constraint: aBlock

	^ self basicNew 
		initializeName: aString constraint: aBlock;
		yourself! !

!GoferFetch commentStamp: ''!
Fetch packages using Gofer!
!GoferFetch methodsFor: 'running' stamp: ''!
execute
	self model
		do: [ :reference | self cacheRepository storeVersion: reference version ]
		displayingProgress: 'Fetching Versions'! !

!GoferFetch methodsFor: 'private' stamp: ''!
defaultModel
	^ Set new! !

!GoferFetch methodsFor: 'initialization' stamp: ''!
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 ] ] ]! !

!GoferLoad commentStamp: ''!
Loading for specific packages using Gofer!
!GoferLoad methodsFor: 'private' stamp: ''!
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: ''!
addResolved: aResolvedReference
	| version |
	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: 'accessing' stamp: ''!
versions
	^ model versions! !

!GoferLoad methodsFor: 'running' stamp: ''!
execute
	self model hasVersions
		ifTrue: [ self model load ].
	self updateRepositories.
	self updateCategories! !

!GoferLoad methodsFor: 'private' stamp: ''!
defaultModel
	^ MCVersionLoader new! !

!GoferLoad methodsFor: 'initialization' stamp: ''!
initializeOn: aGofer
	super initializeOn: aGofer.
	aGofer resolved
		do: [ :each | self addResolved: each ]
		displayingProgress: 'Loading Versions'! !

!GoferLoad methodsFor: 'private' stamp: ''!
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 ] ]! !

!GoferLocalChanges commentStamp: ''!
Handling local changes!
!GoferLocalChanges methodsFor: 'queries' stamp: ''!
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: ''!
targetSnapshotOf: aReference

	^ aReference workingCopy package snapshot! !

!GoferMerge commentStamp: ''!
Merge work!
!GoferMerge methodsFor: 'running' stamp: ''!
execute

	[ self model merge ]
		on: MCMergeResolutionRequest
		do: [ :request |  request autoMerge ].
	self gofer cleanup! !

!GoferMerge methodsFor: 'private' stamp: ''!
defaultModel

	^ MCVersionMerger new! !

!GoferMetacelloLoad commentStamp: ''!
I am a Gofer Operation that extracts a metacello configuration from the current repository and loads the given version.!
!GoferMetacelloLoad methodsFor: 'accessing' stamp: ''!
configurationReference
	^ gofer references
		detect: [ :ref | ref isConfigurationReference ]
		ifNone: [ 
			gofer configuration.
			^ self configurationReference ].! !

!GoferMetacelloLoad methodsFor: 'accessing' stamp: ''!
configuration
	^ self configurationReference project! !

!GoferMetacelloLoad methodsFor: 'accessing' stamp: ''!
version: aVersionStringOrSymbol 
	"A version identifiery see MetacelloProject>>#version:"
	version := aVersionStringOrSymbol! !

!GoferMetacelloLoad methodsFor: 'running' stamp: ''!
execute
	super execute.
	self loadConfiguration.! !

!GoferMetacelloLoad methodsFor: 'accessing' stamp: ''!
metacelloVersion
	| configuration |
	
	configuration := self configuration project.
	self version 
		ifNil: [ ^ configuration stableVersion ].
		
	"Now let's wrap Metcaello's strange behaviors of distinguishing strings and symbols"
	[ 
		"First we try to load the latest version for a given version string"
		^ (configuration latestVersion: self version)
			ifNil: [ 
				"If that doesn't work we use the default version lookup to find a version with the given name"
				configuration version: self version ] 
	] on: MetacelloVersionDoesNotExistError do: [ :error |
			^ self version = 'last'
				ifTrue: [
					"manual fallback since there is no symbolic name for lastVersion"
					configuration lastVersion ]
				ifFalse: [ 
					"symbols and strings are not equal in Meteacello..."
					configuration version: self version asSymbol ]].! !

!GoferMetacelloLoad methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!GoferMetacelloLoad methodsFor: 'running' stamp: ''!
loadConfiguration
	self metacelloVersion load! !

!GoferOperation commentStamp: ''!
Common superclass of Gofer operations!
!GoferOperation methodsFor: 'initialization' stamp: ''!
initialize
	model := self defaultModel! !

!GoferOperation methodsFor: 'running' stamp: ''!
execute
	"Execute the receiving action."

	self subclassResponsibility! !

!GoferOperation methodsFor: 'private' stamp: ''!
defaultModel
	^ nil! !

!GoferOperation methodsFor: 'initialization' stamp: ''!
initializeOn: aGofer
	gofer := aGofer.
	self initialize! !

!GoferOperation methodsFor: 'accessing' stamp: ''!
model
	"Answer the Monticello model of this operation."
	
	^ model! !

!GoferOperation methodsFor: 'accessing' stamp: ''!
gofer
	"Answer the Gofer instance that triggered this operation."

	^ gofer! !

!GoferOperation class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Gofer operations can only work on Gofer instances.'! !

!GoferOperation class methodsFor: 'instance creation' stamp: ''!
on: aGofer
	^ self basicNew initializeOn: aGofer! !

!GoferOperation class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == GoferOperation! !

!GoferOperationTest commentStamp: ''!
SUnit tests for Gofer operations!
!GoferOperationTest methodsFor: 'utilities' stamp: ''!
hasVersion: aString

	^ self allManagers anySatisfy: [ :version | version ancestry ancestorString = aString ]! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testLoad

	gofer version: 'GoferFoo-lr.1'.
	gofer load.
	self assert: (self hasVersion: 'GoferFoo-lr.1').
	self assert: (self hasClass: #GoferFoo)! !

!GoferOperationTest methodsFor: 'accessing' stamp: ''!
environment: anObject

	environment := anObject! !

!GoferOperationTest methodsFor: 'utilities' stamp: ''!
allManagers

	^ MCWorkingCopy allManagers! !

!GoferOperationTest methodsFor: 'utilities' stamp: ''!
hasPackage: aString

	^ self allManagers anySatisfy: [ :package | package packageName = aString ]! !

!GoferOperationTest methodsFor: 'running' stamp: ''!
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 ].
	super tearDown! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testMerge

	| initial |
	initial := gofer copy.
	initial
		version: 'GoferBar-jf.1';
		load.
	gofer
		package: 'GoferBar';
		load.
	(environment classNamed: #GoferBar) compile: 'foo'.
	[ gofer merge ]
		on: ProvideAnswerNotification
		do: [ :e | e resume: true ].
	self assert: (self hasClass: #GoferBar selector: #foo)! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testRemoteChanges

	| changes |
	gofer
		package: 'GoferBar';
		load.
	(environment classNamed: #GoferBar) compile: 'foo'.
	changes := gofer remoteChanges.
	self assert: changes operations size equals: 1! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testRecompile

	gofer package: 'Gofer-Core'.
	gofer recompile! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testLocalChanges

	| changes |
	gofer
		package: 'GoferBar';
		load.
	(environment classNamed: #GoferBar) compile: 'foo'.
	changes := gofer localChanges.
	self assert: changes operations size equals: 1! !

!GoferOperationTest methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testUnload

	gofer
		package: 'GoferFoo';
		load.
	gofer unload.
	self deny: (self hasPackage: 'GoferFoo').
	self deny: (self hasClass: #GoferFoo)! !

!GoferOperationTest methodsFor: 'utilities' stamp: ''!
hasClass: aSymbol

	^ environment includesKey: aSymbol! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testCommit

	| repository |
	repository := MCDictionaryRepository new.
	gofer
		package: 'GoferFoo';
		load.
	gofer := Gofer new.
	gofer 
		disablePackageCache;
		repository: repository;
		package: 'GoferFoo';
		commit: 'A test commit'.
	self assert: repository allVersionInfos size equals: 1! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testReinitialize

	| class |
	gofer
		package: 'GoferFoo';
		load.
	class := Smalltalk classNamed: #GoferFoo.
	class
		addClassVarNamed: #InstanceSide;
		addClassVarNamed: #ClassSide.
	class compile: 'initialize InstanceSide := true'.
	class class compile: 'initialize ClassSide := true'.
	self assert: (class classPool at: #InstanceSide) isNil.
	self assert: (class classPool at: #ClassSide) isNil.
	gofer reinitialize.
	self assert: (class classPool at: #InstanceSide) isNil.
	self assert: (class classPool at: #ClassSide)! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testCleanup

	| class |
	gofer
		package: 'GoferFoo';
		load.
	class := environment classNamed: #GoferFoo.
	environment organization addCategory: #'GoferFoo-Empty'.
	class organization addCategory: #empty.
	class class organization addCategory: #empty.
	gofer cleanup.
	self deny: (Smalltalk organization categories includes: #'GoferFoo-Empty').
	self deny: (class organization categories includes: #'GoferFoo-Empty').
	self deny: (class class organization categories includes: #'GoferFoo-Empty')! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testRevert

	gofer
		package: 'GoferFoo';
		package: 'GoferBar';
		load.
	(environment classNamed: #GoferBar) category: 'GoferFoo'.
	gofer revert.
	self assert: (environment classNamed: #GoferFoo) category asSymbol equals: #GoferFoo.
	self assert: (environment classNamed: #GoferBar) category asSymbol equals: #GoferBar! !

!GoferOperationTest methodsFor: 'running' stamp: ''!
setUpEnvironment

	environment := self class environment.! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testFetch

	gofer 
		package: 'GoferFoo';
		fetch! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testPush

	| repository |
	gofer := Gofer new.
	gofer disablePackageCache.
	gofer repository: (repository := MCDictionaryRepository new).
	gofer package: 'GoferFoo'.
	gofer push! !

!GoferOperationTest methodsFor: 'tests' stamp: ''!
testUpdate

	| initial |
	initial := gofer copy.
	initial
		version: 'GoferFoo-lr.1';
		load.
	gofer package: 'GoferFoo'.
	gofer update.
	self assert: (self hasVersion: 'GoferFoo-lr.4')! !

!GoferOperationTest methodsFor: 'utilities' stamp: ''!
hasClass: aSymbol selector: aSelector

	^ (environment classNamed: aSymbol) includesSelector: aSelector! !

!GoferOperationTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	self setUpEnvironment.
	gofer repository: self monticelloRepository! !

!GoferPackageReference commentStamp: ''!
A GoferPackageReference refers to the latest version of a Monticello package.!
!GoferPackageReference methodsFor: 'private' stamp: ''!
matches: aResolvedReference

	^ self packageName = aResolvedReference packageName! !

!GoferPackageReference methodsFor: 'accessing' stamp: ''!
packageName

	^ name! !

!GoferPackageReference methodsFor: '*Metacello-MC' stamp: ''!
metacelloPackageNameWithBranch
	"Answer array with package name and package name with branch name .. no branch name"

	^ { self packageName.
		 self packageName }! !

!GoferPush commentStamp: ''!
Push a version!
!GoferPush methodsFor: 'running' stamp: ''!
execute

	self model 
		do: [ :assocation | assocation value storeVersion: assocation key version ]
		displayingProgress: 'Pushing Versions'! !

!GoferPush methodsFor: 'private' stamp: ''!
defaultModel

	^ OrderedCollection new! !

!GoferPush methodsFor: 'initialization' stamp: ''!
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 ] ] ] ] ]! !

!GoferRecompile commentStamp: ''!
Recompile!
!GoferRecompile methodsFor: 'running' stamp: ''!
execute

	self workingCopies
		do: [ :each | self execute: each ]! !

!GoferRecompile methodsFor: 'running' stamp: ''!
execute: aWorkingCopy

	aWorkingCopy packageSet methods
		do: [ :each | each methodClass recompile: each selector ]! !

!GoferReference commentStamp: ''!
A GoferReference is an abstract superclass for various kinds of references to Monticello packages and versions.!
!GoferReference methodsFor: 'querying' stamp: ''!
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: 'initialization' stamp: ''!
initializeName: aString

	name := aString! !

!GoferReference methodsFor: 'comparing' stamp: ''!
= aReference

	^ self class = aReference class and: [ self name = aReference name ]! !

!GoferReference methodsFor: 'testing' stamp: ''!
isConfigurationReference

	^ false! !

!GoferReference methodsFor: 'comparing' stamp: ''!
hash

	^ self name hash! !

!GoferReference methodsFor: 'querying' stamp: ''!
resolveAllWith: aGofer
	"Answer a sorted collection of all resolved references within aGofer."

	^ aGofer allResolved select: [ :each | self matches: each ]! !

!GoferReference methodsFor: 'querying' stamp: ''!
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: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' name: '; print: self name! !

!GoferReference methodsFor: 'private' stamp: ''!
matches: aResolvedReference
	"Answer true if the receiver matches aResolvedReference."

	self subclassResponsibility! !

!GoferReference methodsFor: 'accessing' stamp: ''!
name
	"Answer the name of this reference."
	
	^ name! !

!GoferReference methodsFor: 'accessing' stamp: ''!
packageName
	"Answer the package name."
	
	self subclassResponsibility! !

!GoferReference methodsFor: 'querying' stamp: ''!
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: '*Metacello-MC' stamp: ''!
matchesMetacelloGoferPackage: aMetacelloGoferPackage
  | pFilename refFilename char |
  ((pFilename := aMetacelloGoferPackage packageFilename) == nil
    or: [ aMetacelloGoferPackage name = aMetacelloGoferPackage packageFilename ])
    ifTrue: [ ^ super matches: self ].
  self name = pFilename
    ifTrue: [ ^ true ].
  (self name beginsWith: pFilename)
    ifFalse: [ ^ false ].
  refFilename := self metacelloPackageNameWithBranch at: 2.
  refFilename = pFilename
    ifTrue: [ ^ true ].
  pFilename size < refFilename size
    ifTrue: [ 
      (refFilename beginsWith: pFilename)
        ifFalse: [ ^ false ].
      (char := pFilename at: pFilename size) ~= $-
        ifTrue: [ char := refFilename at: pFilename size + 1 ] ]
    ifFalse: [ 
      (pFilename beginsWith: refFilename)
        ifFalse: [ ^ false ].
      (char := refFilename at: refFilename size) ~= $-
        ifTrue: [ char := pFilename at: refFilename size + 1 ] ].
  ^ char = $. or: [ char = $- ]! !

!GoferReference class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Use #name: to initialize the receiver.'! !

!GoferReference class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == GoferReference! !

!GoferReference class methodsFor: 'instance creation' stamp: ''!
name: aString

	^ self basicNew 
		initializeName: aString;
		yourself! !

!GoferReferenceTest commentStamp: ''!
SUnit tests for GoferReference and subclasses!
!GoferReferenceTest methodsFor: 'tests - working' stamp: ''!
testPackageShouldFindWorkingCopy

	| packageReference workingCopy |
	packageReference := GoferPackageReference name: 'Gofer-Core'.
	workingCopy := packageReference workingCopy.
	self assert: workingCopy packageName equals: 'Gofer-Core'! !

!GoferReferenceTest methodsFor: 'tests' stamp: ''!
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: 'tests - working' stamp: ''!
testVersionShouldFindWorkingCopy

	| versionReference workingCopy |
	versionReference := GoferVersionReference name: 'Gofer-Core-lr.18'.
	workingCopy := versionReference workingCopy.
	
	self assert: workingCopy packageName equals: 'Gofer-Core'! !

!GoferReferenceTest methodsFor: 'tests - reference' stamp: ''!
testVersionShouldFindLatestVersion

	| versionReference reference |
	versionReference := GoferVersionReference name: 'GoferFoo-lr.2'.
	reference := versionReference resolveWith: gofer.

	self assert: reference packageName equals: 'GoferFoo'.
	self assert: reference author equals: 'lr'.
	self assert: reference versionNumber equals: 2.
	self assertEmpty: reference branch.
	self assert: reference repository equals: self monticelloRepository.

	versionReference := GoferVersionReference name: 'GoferFoo-lr.3'.
	self should: [ versionReference resolveWith: gofer ] raise: Error! !

!GoferReferenceTest methodsFor: 'tests - reference' stamp: ''!
testContraintShouldFindLatestVersion

	| constraintReference reference |
	constraintReference := GoferConstraintReference name: 'GoferBar' constraint: [ :ref | true ].
	self assert: (constraintReference resolveAllWith: gofer) size equals: 4.

	reference := constraintReference resolveWith: gofer.

	self assert: reference packageName equals: 'GoferBar'.
	self assert: reference author equals: 'lr'.
	self assertEmpty: reference branch.
	self assert: reference versionNumber equals: 1.
	self assert: reference repository equals: self monticelloRepository.

	constraintReference := GoferConstraintReference name: 'GoferBar' constraint: [ :ref | ref branch = 'branch' ].

	self assert: (constraintReference resolveAllWith: gofer) size equals: 2.

	reference := constraintReference resolveWith: gofer.

	self assert: reference packageName equals: 'GoferBar'.
	self assert: reference author equals: 'lr'.
	self assert: reference branch equals: 'branch'.
	self assert: reference versionNumber equals: 2.
	self assert: reference repository equals: self monticelloRepository.

	constraintReference := GoferConstraintReference name: 'GoferBar' constraint: [ :ref | ref author = 'jf' ].

	self assert: (constraintReference resolveAllWith: gofer) size equals: 1.

	reference := constraintReference resolveWith: gofer.

	self assert: reference packageName equals: 'GoferBar'.
	self assert: reference author equals: 'jf'.
	self assertEmpty: reference branch.
	self assert: reference versionNumber equals: 1.
	self assert: reference repository equals: self monticelloRepository.

	constraintReference := GoferConstraintReference name: 'GoferBar' constraint: [ :ref | false ].

	self assertEmpty: (constraintReference resolveAllWith: gofer).
	self should: [ constraintReference resolveWith: gofer ] raise: Error! !

!GoferReferenceTest methodsFor: 'tests - reference' stamp: ''!
testPackageShouldFindLatestVersion

	| packageReference reference |
	packageReference := GoferPackageReference name: 'GoferFoo'.
	reference := packageReference resolveWith: gofer.

	self assert: reference packageName equals: 'GoferFoo'.
	self assert: reference author equals: 'lr'.
	self assertEmpty: reference branch.
	self assert: reference versionNumber equals: 4.
	self assert: reference repository equals: self monticelloRepository! !

!GoferReferenceTest methodsFor: 'tests' stamp: ''!
testVersionShouldParseComplexName

	| queryReference |
	queryReference := GoferVersionReference name: 'Seaside2.8b5'.
	self assert: queryReference packageName equals: 'Seaside2'.
	self assertEmpty: queryReference author.
	self assert: queryReference branch equals: '8b5'.
	self assert: queryReference versionNumber equals: 0.

	queryReference := GoferVersionReference name: 'Seaside2.8b5-avi.1'.
	self assert: queryReference packageName equals: 'Seaside2'.
	self assert: queryReference author equals: 'avi'.
	self assert: queryReference branch equals: '8b5'.
	self assert: queryReference versionNumber equals: 1.

	queryReference := GoferVersionReference name: 'Seaside-Core-pmm.2'.
	self assert: queryReference packageName equals: 'Seaside-Core'.
	self assert: queryReference author equals: 'pmm'.
	self assertEmpty: queryReference branch.
	self assert: queryReference versionNumber equals: 2.

	queryReference := GoferVersionReference name: 'Seaside-Core.configcleanup-jf.3'.
	self assert: queryReference packageName equals: 'Seaside-Core'.
	self assert: queryReference author equals: 'jf'.
	self assert: queryReference branch equals: 'configcleanup'.
	self assert: queryReference versionNumber equals: 3.

	queryReference := GoferVersionReference name: 'Seaside-Core.configcleanup.extraspeedup-lr.69'.
	self assert: queryReference packageName equals: 'Seaside-Core'.
	self assert: queryReference author equals: 'lr'.
	self assert: queryReference branch equals: 'configcleanup.extraspeedup'.
	self assert: queryReference versionNumber equals: 69.

	queryReference := GoferVersionReference name: 'Seaside-Core.configcleanup42.extraspeedup-lr.69'.
	self assert: queryReference packageName equals: 'Seaside-Core'.
	self assert: queryReference author equals: 'lr'.
	self assert: queryReference branch equals: 'configcleanup42.extraspeedup'.
	self assert: queryReference versionNumber equals: 69! !

!GoferReferenceTest methodsFor: 'tests - working' stamp: ''!
testContraintShouldFindWorkingCopy

	| constraintReference workingCopy |
	constraintReference := GoferConstraintReference 
		name: 'Gofer-Core'
		constraint: [ :reference | false ].
	workingCopy := constraintReference workingCopy.
	self assert: workingCopy packageName equals: 'Gofer-Core'! !

!GoferReferenceTest methodsFor: 'tests - working' stamp: ''!
testResolvedShouldFindWorkingCopy

	| versionReference workingCopy |
	versionReference := GoferResolvedReference name: 'Gofer-Core-lr.18' repository: self monticelloRepository.
	workingCopy := versionReference workingCopy.
	self assert: workingCopy packageName equals: 'Gofer-Core'! !

!GoferReferenceTest methodsFor: 'tests' stamp: ''!
testBranchAfterAuthorIsNotABranch

	| queryReference |
	queryReference := GoferVersionReference name: 'Seaside-Core-jf.configcleanup.3'.
	self assert: queryReference packageName equals: 'Seaside-Core'.
	self assert: queryReference author equals: 'jf.configcleanup'.
	self assertEmpty: queryReference branch.
	self assert: queryReference versionNumber equals: 3.

	queryReference := GoferVersionReference name: 'Seaside-Core-lr.configcleanup.extraspeedup.69'.
	self assert: queryReference packageName equals: 'Seaside-Core'.
	self assert: queryReference author equals: 'lr.configcleanup.extraspeedup'.
	self assertEmpty: queryReference branch.
	self assert: queryReference versionNumber equals: 69.

	queryReference := GoferVersionReference name: 'Seaside-Core-lr.configcleanup42.extraspeedup.69'.
	self assert: queryReference packageName equals: 'Seaside-Core'.
	self assert: queryReference author equals: 'lr.configcleanup42.extraspeedup'.
	self assertEmpty: queryReference branch.
	self assert: queryReference versionNumber equals: 69! !

!GoferReferenceTest methodsFor: 'tests - reference' stamp: ''!
testResolvedShouldFindLatestVersion

	| versionReference reference |
	versionReference := GoferResolvedReference name: 'GoferFoo-lr.2' repository: self monticelloRepository.
	reference := versionReference resolveWith: gofer.

	self assert: reference packageName equals: 'GoferFoo'.
	self assert: reference author equals: 'lr'.
	self assertEmpty: reference branch.
	self assert: reference versionNumber equals: 2.
	self assert: reference repository equals: self monticelloRepository! !

!GoferReferenceTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	gofer repository: self monticelloRepository! !

!GoferReinitialize commentStamp: ''!
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: ''!
execute

	self workingCopies
		do: [ :each | self execute: each ]! !

!GoferReinitialize methodsFor: 'running' stamp: ''!
execute: aWorkingCopy

	aWorkingCopy packageSet methods do: [ :each |
		(each isClassSide and: [ each selector = #initialize ])
			ifTrue: [ each methodClass instanceSide initialize ] ]! !

!GoferRemoteChanges commentStamp: ''!
Handling remote changes!
!GoferRemoteChanges methodsFor: 'queries' stamp: ''!
sourceSnapshotOf: aReference

	^ aReference workingCopy package snapshot! !

!GoferRemoteChanges methodsFor: 'private' stamp: ''!
targetSnapshotOf: aReference

	^ (aReference resolveWith: self gofer) version snapshot! !

!GoferRepositoryError commentStamp: ''!
A GoferRepositoryError is the error thrown when a repository cannot be accessed.!
!GoferRepositoryError methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!GoferRepositoryError methodsFor: 'private' stamp: ''!
isResumable
	^ true! !

!GoferRepositoryError methodsFor: 'accessing' stamp: ''!
repository: aRepository
	repository := aRepository! !

!GoferRepositoryError class methodsFor: 'instance creation' stamp: ''!
signal: aString repository: aRepository

	^ self new
		  repository: aRepository;
		  signal: aString! !

!GoferResolvedReference commentStamp: ''!
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: '*Metacello-MC' stamp: ''!
asMetacelloCachingResolvedReference

	^MetacelloCachingGoferResolvedReference name: self name repository: self repository! !

!GoferResolvedReference methodsFor: 'accessing' stamp: ''!
repository
	"Answer the repository of the receiver."
	
	^ repository! !

!GoferResolvedReference methodsFor: 'actions' stamp: ''!
merge
	"Merge-in the changes of this refence"
	
	Gofer new
		repository: self repository;
		package: package;
		version: self name;
		merge! !

!GoferResolvedReference methodsFor: 'accessing' stamp: ''!
version
	"Answer a Monticello version of the receiver."

	^ self repository versionFrom: self name! !

!GoferResolvedReference methodsFor: 'initialization' stamp: ''!
initializeName: aString repository: aRepository
	self initializeName: aString.
	repository := aRepository! !

!GoferResolvedReference methodsFor: 'comparing' stamp: ''!
<= aResolvedReference
	"Sort versions according to:

		1. package name
		2. branch name, list versions without branch last
		3. version number
		4. author name
		5. repository priority"
	
	self packageName = aResolvedReference packageName
		ifFalse: [ ^ self packageName <= aResolvedReference packageName ].
	self branch = aResolvedReference branch ifFalse: [ 
		^ (self branch isEmpty or: [ aResolvedReference branch isEmpty ])
			ifTrue: [ self branch size > aResolvedReference branch size ]
			ifFalse: [ self branch <= aResolvedReference branch ] ].
	self versionNumber = aResolvedReference versionNumber
		ifFalse: [ ^ self versionNumber <= aResolvedReference versionNumber ].
	self author = aResolvedReference author
		ifFalse: [ ^ self author <= aResolvedReference author ].
	self repository goferPriority = aResolvedReference repository goferPriority
		ifFalse: [ ^ self repository goferPriority <= aResolvedReference repository goferPriority ].
	^ true! !

!GoferResolvedReference class methodsFor: 'instance creation' stamp: ''!
name: aString repository: aRepository

	^ self basicNew 
		initializeName: aString repository: aRepository;
		yourself! !

!GoferResource commentStamp: ''!
SUnit test resource for Gofer testing!
!GoferResource methodsFor: 'accessing' stamp: ''!
versionReferences

	^ versionReferences! !

!GoferResource methodsFor: 'accessing' stamp: ''!
monticelloRepository

	^ monticelloRepository! !

!GoferResource methodsFor: 'private - running' stamp: ''!
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')! !

!GoferResource methodsFor: 'private - running' stamp: ''!
setUpMonticelloRepository
	"This method builds a fake repository with the version references from #buildReferences."
	| packages |
	
	packages := Dictionary new.
	monticelloRepository := MCDictionaryRepository new.
	versionReferences do: [ :reference |
		monticelloRepository basicStoreVersion: (MCVersion new
			setPackage:  (packages 
				at: reference packageName 
				ifAbsentPut: [ MetacelloTestsMCPackage new name: reference packageName ])
			info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
			snapshot: (MCSnapshot fromDefinitions: (Array
				with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol))
				with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: '')))
			dependencies: #()) ].! !

!GoferResource methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	self
		setUpVersionReferences;
		setUpMonticelloRepository! !

!GoferRevert commentStamp: ''!
Revert work!
!GoferRevert methodsFor: 'private' stamp: ''!
referenceFor: aReference

	| ancestors |
	ancestors := aReference workingCopy ancestry ancestors.
	ancestors isEmpty ifTrue: [ ^ MCSnapshot new ].
	^ GoferVersionReference name: ancestors first name! !

!GoferRevert methodsFor: 'running' stamp: ''!
execute

	self workingCopies
		do: [ :each | each modified: false ].
	super execute! !

!GoferSynchronize commentStamp: ''!
Synchronize repos !
!GoferSynchronize methodsFor: 'accessing' stamp: ''!
cacheRepository
	^ MCCacheRepository uniqueInstance! !

!GoferSynchronize methodsFor: 'initialization' stamp: ''!
initializeOn: aGofer
	super initializeOn: aGofer disablePackageCache.
	MCFileBasedRepository flushAllCaches.
	cacheReferences := self gofer allResolvedIn: self cacheRepository! !

!GoferSynchronize class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == GoferSynchronize! !

!GoferTest commentStamp: ''!
Abstract superclass for Gofer tests!
!GoferTest methodsFor: 'accessing' stamp: ''!
versionReferences

	^ GoferResource current versionReferences! !

!GoferTest methodsFor: 'accessing' stamp: ''!
monticelloRepository

	^ GoferResource current monticelloRepository! !

!GoferTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	gofer := Gofer new.
	gofer disablePackageCache! !

!GoferTest class methodsFor: 'testing' stamp: ''!
isUnitTest
	^false! !

!GoferTest class methodsFor: 'accessing' stamp: ''!
packageNamesUnderTest
	^ #('Gofer-Core')! !

!GoferTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #GoferTest! !

!GoferTest class methodsFor: 'accessing' stamp: ''!
resources
	^ Array with: GoferResource! !

!GoferUnload commentStamp: ''!
Unload!
!GoferUnload methodsFor: 'unloading' stamp: ''!
unloadPackage: aWorkingCopy

	self model unloadPackage: aWorkingCopy package! !

!GoferUnload methodsFor: 'unregistering' stamp: ''!
unregisterWorkingCopy: aWorkingCopy

	aWorkingCopy unregister! !

!GoferUnload methodsFor: 'unregistering' stamp: ''!
unregisterPackageSet: aWorkingCopy

	aWorkingCopy packageSet unregister! !

!GoferUnload methodsFor: 'unloading' stamp: ''!
unload: aWorkingCopy

	self unloadClasses: aWorkingCopy.
	self unloadPackage: aWorkingCopy! !

!GoferUnload methodsFor: 'running' stamp: ''!
execute

	self workingCopies 
		do: [ :copy | self unload: copy ].
	self model load.
	self gofer cleanup.
	self workingCopies 
		do: [ :copy | self unregister: copy ]! !

!GoferUnload methodsFor: 'private' stamp: ''!
defaultModel

	^ (Smalltalk globals at: #MCMultiPackageLoader ifAbsent: [ MCPackageLoader ]) new! !

!GoferUnload methodsFor: 'unregistering' stamp: ''!
unregisterPackageInfo: aWorkingCopy

	RPackageOrganizer default
		unregisterPackageNamed: aWorkingCopy packageName! !

!GoferUnload methodsFor: 'unregistering' stamp: ''!
unregisterRepositories: aWorkingCopy

	aWorkingCopy repositoryGroup repositories allButFirst do: [ :repository |
		MCWorkingCopy allManagers do: [ :copy |
			(copy repositoryGroup includes: repository)
				ifTrue: [ ^ self ] ].
		MCRepositoryGroup default
			removeRepository: repository ]! !

!GoferUnload methodsFor: 'unloading' stamp: ''!
unloadClasses: aWorkingCopy

	aWorkingCopy packageSet methods do: [ :each |
		(each isClassSide and: [ each selector = #unload ])
			ifTrue: [ each methodClass instanceSide unload ] ]! !

!GoferUnload methodsFor: 'unregistering' stamp: ''!
unregister: aWorkingCopy

	self 
		unregisterWorkingCopy: aWorkingCopy;
		unregisterRepositories: aWorkingCopy;
		unregisterPackageSet: aWorkingCopy;
		unregisterPackageInfo: aWorkingCopy! !

!GoferUpdate commentStamp: ''!
Update!
!GoferUpdate methodsFor: 'private' stamp: ''!
addReference: aReference

	super addReference: aReference.
	self model addVersion: ((self referenceFor: aReference)
		 resolveWith: self gofer) version! !

!GoferUpdate methodsFor: 'private' stamp: ''!
referenceFor: aReference

	^ aReference! !

!GoferUpdate methodsFor: 'running' stamp: ''!
execute

	self model hasVersions
		ifTrue: [ self model load ].
	self gofer cleanup! !

!GoferUpdate methodsFor: 'private' stamp: ''!
defaultModel

	^ MCVersionLoader new! !

!GoferVersionReference commentStamp: ''!
A GoferVersionReference refers to a specific version of a Monticello package.!
!GoferVersionReference methodsFor: 'initialization' stamp: ''!
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: 'initialization' stamp: ''!
initializeName: aString

	super initializeName: aString.
	self parseName: aString! !

!GoferVersionReference methodsFor: 'accessing' stamp: ''!
versionNumber
	"Answer the version of the receiver."

	^ versionNumber! !

!GoferVersionReference methodsFor: 'accessing' stamp: ''!
author
	"Answer the author of the receiver."
	
	^ author! !

!GoferVersionReference methodsFor: '*Metacello-MC' stamp: ''!
compare: aLoadableReference using: aComparisonOperator
	"Compare versions using <aComparisonOperator>. package names #= then compare based upon version number
	Branches and Author names are used in the case of a version number tie, because we need to avoid seesaw loading."
		
	self packageName = aLoadableReference packageName
		ifFalse: [ ^false ].
	self versionNumber = aLoadableReference versionNumber
		ifFalse: [ ^ self versionNumber perform: aComparisonOperator with: aLoadableReference versionNumber ].
	self branch = aLoadableReference branch 
		ifFalse: [ ^ self branch perform: aComparisonOperator with: aLoadableReference branch ].
	^ self author perform: aComparisonOperator with: aLoadableReference author! !

!GoferVersionReference methodsFor: 'private' stamp: ''!
matches: aResolvedReference

	^ self name = aResolvedReference name! !

!GoferVersionReference methodsFor: 'accessing' stamp: ''!
branch
	"Answer the branch of the receiver."
	
	^ branch! !

!GoferVersionReference methodsFor: 'accessing' stamp: ''!
packageName
	"Answer the package of the receiver."

	^ package! !

!GoferVersionReference methodsFor: '*Metacello-MC' stamp: ''!
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: '*Metacello-MC' stamp: ''!
matchesMetacelloGoferPackage: aMetacelloGoferPackage
  | ref |
  (super matchesMetacelloGoferPackage: aMetacelloGoferPackage)
    ifFalse: [ ^ false ].
  ref := self class name: aMetacelloGoferPackage packageFilename.
  ref versionNumber = 0
    ifTrue: [ ^ true ].
  ^ self versionNumber = ref versionNumber! !

!GoferWorking commentStamp: ''!
Common superclass for workin copies in Gofer!
!GoferWorking methodsFor: 'accessing' stamp: ''!
workingCopies
	"Answer the working copies to be operated on."

	^ workingCopies! !

!GoferWorking methodsFor: 'private' stamp: ''!
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) ]! !

!GoferWorking methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	workingCopies := OrderedCollection new! !

!GoferWorking methodsFor: 'initialization' stamp: ''!
initializeOn: aGofer

	super initializeOn: aGofer.
	aGofer references 
		do: [ :each | self addReference: each ]! !

!GoferWorking class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == GoferWorking! !

!GradientFillStyle commentStamp: ''!
A gradient fill style is a fill which interpolates smoothly between any number of colors.

Instance variables:
	colorRamp	<Array of: Association> Contains the colors and their relative positions along the fill, which is a number between zero and one.
	pixelRamp	<Bitmap>		A cached version of the colorRamp to avoid needless recomputations.
	radial		<Boolean>	If true, this fill describes a radial gradient. If false, it is a linear gradient.
	isTranslucent	<Boolean>	A (cached) flag determining if there are any translucent colors involved.

Class variables:
	PixelRampCache <LRUCache>	Recently used pixelRamps. They tend to have high temporal locality and this saves space and time.!
!GradientFillStyle methodsFor: 'comparing' stamp: ''!
= anGradientFillStyle
	"Answer whether equal."

	^super = anGradientFillStyle
		and: [self pixelRamp == anGradientFillStyle pixelRamp] "LRU should make identity equal"! !

!GradientFillStyle methodsFor: 'accessing' stamp: ''!
colorRamp: anArray
	colorRamp := anArray.
	pixelRamp := nil.
	isTranslucent := nil.! !

!GradientFillStyle methodsFor: 'comparing' stamp: ''!
hash
	"Hash is implemented because #= is implemented."
	
	^super hash bitXor: self pixelRamp hash! !

!GradientFillStyle methodsFor: 'accessing' stamp: ''!
radial
	^radial ifNil:[false]! !

!GradientFillStyle methodsFor: 'accessing' stamp: ''!
radial: aBoolean
	radial := aBoolean! !

!GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
addNewColorIn: aMorph event: evt
	^self inform:'not yet implemented'! !

!GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
beRadialGradientIn: aMorph
	self radial: true.
	aMorph changed.! !

!GradientFillStyle methodsFor: 'accessing' stamp: ''!
colorRamp
	^colorRamp! !

!GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
changeSecondColorIn: aMorph event: evt
	^self changeColorOf: aMorph rampIndex: 2! !

!GradientFillStyle methodsFor: 'converting' stamp: ''!
asColor
	"Guess..."
	^colorRamp first value mixed: 0.5 with: colorRamp last value! !

!GradientFillStyle methodsFor: 'converting' stamp: ''!
mixed: fraction with: aColor
	^self copy colorRamp: (colorRamp collect:[:assoc| assoc key -> (assoc value mixed: fraction with: aColor)])! !

!GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
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' target: self selector: #beLinearGradientIn: argument: aMorph ] 		ifFalse: [ aMenu add: 'radial gradient' target: self selector: #beRadialGradientIn: argument: aMorph ].
	aMenu addLine.
	aMenu add: 'change first color' target: self selector: #changeFirstColorIn:event: argument: aMorph.
	aMenu add: 'change second color' target: self selector: #changeSecondColorIn:event: argument: aMorph.
	aMenu addLine.
	super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! !

!GradientFillStyle methodsFor: 'testing' stamp: ''!
isTranslucent
	^isTranslucent ifNil:[isTranslucent := self checkTranslucency]! !

!GradientFillStyle methodsFor: 'private' stamp: ''!
checkTranslucency
	^colorRamp anySatisfy: [:any| any value isTranslucent]! !

!GradientFillStyle methodsFor: 'private' stamp: ''!
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: 'testing' stamp: ''!
isRadialFill
	^radial == true! !

!GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
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-Base-Balloon' stamp: ''!
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: '*Morphic-Base-Balloon' stamp: ''!
changeColorOf: aMorph rampIndex: rampIndex
	| originalColor |
	originalColor := (colorRamp at: rampIndex) value.
	Smalltalk ui theme 
		chooseColorIn: self currentWorld title: 'Color' color: originalColor for: [:color |
		self changeColorAt: rampIndex  to:  color.
		aMorph changed]! !

!GradientFillStyle methodsFor: '*Athens-Balloon' stamp: ''!
asAthensPaintOn: anAthensCanvas

	^ AthensGradientPaint new gradient: self.
	"^ radial ifTrue: [
		anAthensCanvas surface
			createRadialGradient: colorRamp
			center:  (anAthensCanvas pathTransform inverseTransform: origin )
			radius: direction y ]
	ifFalse: [
		anAthensCanvas surface
			createLinearGradient: colorRamp
			origin: (anAthensCanvas pathTransform inverseTransform: origin)
			corner: (anAthensCanvas pathTransform inverseTransform: origin + direction ) ]
"! !

!GradientFillStyle methodsFor: 'private' stamp: ''!
scaledAlphaMix: theta of: lastWord with: nextWord
	"Open-coded version of alpha mixing two 32bit pixel words and returning the scaled pixel value."
	| word0 word1 a0 a1 alpha v0 v1 vv value |
	word0 := lastWord.
	word1 := nextWord.
	"note: extract alpha first so we'll be in SmallInteger range afterwards"
	a0 := word0 bitShift: -24. a1 := word1 bitShift: -24.
	alpha := a0 + (a1 - a0 * theta) truncated.
	"Now make word0 and word1 SmallIntegers"
	word0 := word0 bitAnd: 16rFFFFFF. word1 := word1 bitAnd: 16rFFFFFF.
	"Compute first component value"
	v0 := (word0 bitAnd: 255). v1 := (word1 bitAnd: 255).
	vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
	value := vv.
	"Compute second component value"
	v0 := ((word0 bitShift: -8) bitAnd: 255). v1 := ((word1 bitShift: -8) bitAnd: 255).
	vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
	value := value bitOr: (vv bitShift: 8).
	"Compute third component value"
	v0 := ((word0 bitShift: -16) bitAnd: 255). v1 := ((word1 bitShift: -16) bitAnd: 255).
	vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
	value := value bitOr: (vv bitShift: 16).
	"Return result"
	^value bitOr: (alpha bitShift: 24)! !

!GradientFillStyle methodsFor: 'accessing' stamp: ''!
pixelRamp
	"Compute a pixel ramp, and cache it for future accesses"

	^ pixelRamp ifNil: [
		"Ask my cache for an existing instance or to create one"
		pixelRamp := self class pixelRampCache at: colorRamp ]! !

!GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
beLinearGradientIn: aMorph
	self radial: false.
	aMorph changed.! !

!GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
changeFirstColorIn: aMorph event: evt
	^self changeColorOf: aMorph rampIndex: 1! !

!GradientFillStyle methodsFor: 'accessing' stamp: ''!
pixelRamp: aBitmap
	pixelRamp := aBitmap! !

!GradientFillStyle methodsFor: 'testing' stamp: ''!
isGradientFill
	^true! !

!GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
changeColorAt: rampIndex to: aColor
	| ramp |
	ramp := colorRamp deepCopy.
	(ramp at: rampIndex) value: aColor.
	
	colorRamp := ramp.
	isTranslucent := nil.
	pixelRamp := nil.! !

!GradientFillStyle class methodsFor: 'instance creation' stamp: ''!
ramp: colorRamp
	^self new colorRamp: colorRamp! !

!GradientFillStyle class methodsFor: 'initialization' stamp: ''!
initialize
	"GradientFillStyle initialize"
	
	self initPixelRampCache! !

!GradientFillStyle class methodsFor: 'accessing' stamp: ''!
pixelRampCache
	"Allow access to my cache of pixel ramps."

	^ PixelRampCache ifNil: [ self initPixelRampCache ]! !

!GradientFillStyle class methodsFor: 'private - initialization' stamp: ''!
initPixelRampCache
	"Create an LRUCache to use for accessing pixel ramps.
	When a new pixel ramp is needed, a temporary GradientFillStyle
	is created so that it can be used to create a new pixel ramp"

	^ PixelRampCache := LRUCache new 
		maximumWeight: 32;
		factory: [ :key | 
			(GradientFillStyle new colorRamp: key) 
				computePixelRampOfSize: 512 ];
		yourself! !

!GradientFillStyle class methodsFor: 'instance creation' stamp: ''!
colors: colorArray
	"Create a gradient fill style from an array of equally spaced colors"
	^self ramp: (colorArray withIndexCollect:
		[:color :index| (index-1 asFloat / (colorArray size - 1 max: 1)) -> color])! !

!GradientFillStyle class methodsFor: 'cleanup' stamp: ''!
cleanUp
	"Flush caches"

	self initPixelRampCache! !

!GradientFillStyle class methodsFor: 'examples' stamp: ''!
sample
	<sampleInstance>

	^(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! !

!GradientPaint commentStamp: ''!
I am paint which using color gradient for fills.

The gradient is defined using color ramp in range between 0 and 1
where colors can be set at certain point. The color are interpolated between defined points.

The color ramp is a collection of associations with keys - floating point values between 0 and 1
and values with Colors, for example:

{  0 -> Color white. 1 -> Color black }.

My subclasses used to define a concrete kind of gradient,
while me is an abstract class which has common properties for all gradients: color ramp.

Also, note that my subclasses representing backend-neutral gradients,
encapsulating all necessary data, which is then passed to corresponding surface factory method, like
AthensSurface>>#createLinearGradient:start:stop: , which answers backend-specific gradient paint.
I am userful in cases when user wants to define a paint without need
to have any Athens surface at hand.

Sure thing, using backend-specific gradients is preferable, if possible,
because conversion to backend-specific paint can be costly. 
Especially if gradient is statically defined (ramp values and other parameters never changing) 
and used many times during the life time of surface.

!
!GradientPaint methodsFor: '*NumericInterpolator' stamp: ''!
interpolateTo: anObject at: t
	| otherRamp ramp newRamp | 
	otherRamp := anObject isColor 
		ifTrue: [ colorRamp collect: [ :a | anObject ] ]
		ifFalse: [ anObject colorRamp ].
	ramp := self colorRamp.
	ramp size = otherRamp size ifFalse: [ self error: 'invalid sizes for color ramp' ].
	
	newRamp := self colorRamp collectWithIndex: [ :a :i | | a2 |
		a2 := otherRamp at: i.
		a key -> (a value interpolateTo: a2 value at: t) ].
	^ self copy
		colorRamp: newRamp! !

!GradientPaint methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	colorRamp := OrderedCollection new! !

!GradientPaint methodsFor: 'accessing' stamp: ''!
colorRamp: aRamp
	"The color ramp is a collection of associations with keys - floating point values between 0 and 1
	 and values with Colors, for example:

	{  0 -> Color white. 1 -> Color black }."

	colorRamp := aRamp copy! !

!GradientPaint methodsFor: 'accessing' stamp: ''!
colorRamp
	^ colorRamp! !

!GradientPaint methodsFor: 'accessing' stamp: ''!
atStop: anOffset put: aColor

	colorRamp add: (anOffset -> aColor)! !

!GradientPaint class methodsFor: '*Roassal3-Shapes' stamp: ''!
fromArray: array
	^ self new 
		colorRamp: (array collect: [ :as | as key -> (Color colorFrom: as value)]);
		yourself! !

!GrafPort commentStamp: ''!
Provides extended Graphic support like translucency!
!GrafPort methodsFor: 'drawing support' stamp: ''!
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: 'copying' stamp: ''!
copyBits
	"Override copybits to do translucency if desired"

	(combinationRule between: 30 and: 31)
		ifTrue: [ self copyBitsTranslucent: (alpha ifNil: [ 255 ]) ]
		ifFalse: [ super copyBits ]! !

!GrafPort methodsFor: '*Graphics-Fonts' stamp: ''!
installStrikeFont: aStrikeFont

	^ self installStrikeFont: aStrikeFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]).! !

!GrafPort methodsFor: 'accessing' stamp: ''!
contentsOfArea: aRectangle into: aForm
	destForm 
		displayOn: aForm 
		at:  aRectangle origin
		clippingBox: (0@0 extent: aRectangle extent).
	^aForm! !

!GrafPort methodsFor: 'accessing' stamp: ''!
lastFontForegroundColor
	^lastFontForegroundColor! !

!GrafPort methodsFor: 'drawing support' stamp: ''!
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: ''!
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: ''!
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: '*Morphic-Base' stamp: ''!
displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode
	^ (BitBltDisplayScanner new text: para text textStyle: para textStyle
			foreground: foreColor background: backColor fillBlt: self
			ignoreColorChanges: shadowMode)
		setPort: self shallowCopy! !

!GrafPort methodsFor: 'copying' stamp: ''!
clippedBy: aRectangle
	^ self copy clipBy: aRectangle! !

!GrafPort methodsFor: 'accessing' stamp: ''!
fillPattern: anObject
	fillPattern := anObject.
	self fillColor: anObject.! !

!GrafPort methodsFor: 'drawing support' stamp: ''!
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: '*FreeType-Graphics' stamp: ''!
installFreeTypeFont: aFreeTypeFont foregroundColor: foregroundColor backgroundColor: backgroundColor

	super installFreeTypeFont: aFreeTypeFont foregroundColor: foregroundColor backgroundColor: backgroundColor.
	lastFont := aFreeTypeFont.
	lastFontForegroundColor := foregroundColor.
	lastFontBackgroundColor := backgroundColor.! !

!GrafPort methodsFor: 'drawing support' stamp: ''!
frameRect: rect borderWidth: borderWidth
	sourceX := 0.
	sourceY := 0.
	(rect areasOutside: (rect insetBy: borderWidth)) do:
		[:edgeStrip | self destRect: edgeStrip; copyBits].! !

!GrafPort methodsFor: '*Graphics-Fonts' stamp: ''!
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: 'accessing' stamp: ''!
alphaBits: a
	alpha := a! !

!GrafPort methodsFor: 'drawing support' stamp: ''!
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: '*Graphics-Fonts' stamp: ''!
lastFont

	^ lastFont.! !

!GrafPort methodsFor: 'drawing support' stamp: ''!
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: ''!
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: '*Rubric-Editing-Core' stamp: ''!
rubDisplayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode
	^ (RubDisplayScanner new text: para text textStyle: para textStyle
			foreground: foreColor background: backColor fillBlt: self
			ignoreColorChanges: shadowMode)
		setPort: self shallowCopy! !

!GraphicFontSettings commentStamp: ''!
Settings for the fonts!
!GraphicFontSettings class methodsFor: 'fonts' stamp: ''!
standardFontsSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #standardFonts)
		label: 'Standard fonts';
		target: StandardFonts;
		dialog: [self fontSizeRow];
		parent: #appearance;
		order: 4;
		with: [ 
			(aBuilder setting: #defaultFont)
				order: 1;
				description: 'The default text font' ;
				default: (LogicalFont familyName: 'Source Sans Pro' pointSize: 10);
				dialog: (MessageSend receiver: self selector: #resetAllFontToDefaultButton);
				label: 'Default'.
			(aBuilder setting: #codeFont) 
				description: 'The standard code font' ;
				default: (LogicalFont familyName: 'Source Code Pro' pointSize: 10);
				label: 'Code'.
			(aBuilder setting: #listFont)
				description: 'The standard list font' ;
				default: (LogicalFont familyName: 'Source Sans Pro' pointSize: 10);
				label: 'List'.
			(aBuilder setting: #menuFont)
				description: 'The standard menu font' ;
				default: (LogicalFont familyName: 'Source Sans Pro' pointSize: 10);
				label: 'Menu' .
			(aBuilder setting: #buttonFont)
				description: 'The standard button font' ;
				default: (LogicalFont familyName: 'Source Sans Pro' pointSize: 10);
				label: 'Button' .
			(aBuilder setting: #windowTitleFont)
				description: 'The standard window title font' ;
				default: (LogicalFont familyName: 'Source Sans Pro' pointSize: 11);
				label: 'Window title' .
			(aBuilder setting: #balloonFont)
				description: 'The standard balloon-help font' ;
				default: (LogicalFont familyName: 'Source Sans Pro' pointSize: 9);
				label: 'Balloon-help' .
			(aBuilder setting: #haloFont)
				default: (LogicalFont familyName: 'Source Sans Pro' pointSize: 9);
				description: 'The morphic halo font' ;
				label: 'Morphic halo' ]
				
				! !

!GraphicFontSettings class methodsFor: 'fonts' stamp: ''!
resetAllFontToDefault
	StandardFonts setAllStandardFontsTo: StandardFonts defaultFont.
	SettingBrowser refreshAllSettingBrowsers.
	EditorFindReplaceDialogWindow cleanUp.
	 
! !

!GraphicFontSettings class methodsFor: 'fonts' stamp: ''!
resetAllFontToDefaultButton
	^ (self theme
		newButtonIn: self
		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: self
				for:
					{(AlphaImageMorph new
						image: (self iconNamed: #smallRedoIcon)).
					(self theme buttonLabelForText: 'Force all' translated)});
		yourself! !

!GraphicFontSettings class methodsFor: 'fonts' stamp: ''!
displayScaleFactorForStyleNamed: aSymbol

	^ (#(#(#superTiny 0.6) #(#tiny 0.8) #(#small 1) #(#medium 1.4) #(#large 1.6) #(veryLarge 2) #(huge 2.7))
		detect: [:info | info first asUppercase = aSymbol asUppercase] ifNone: []) 
			ifNotNil: [:info | info second]
! !

!GraphicFontSettings class methodsFor: 'fonts' stamp: ''!
fontSizeRow
	^ self theme newRowIn: self 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: ''!
fontChoiceButtonForStyle: aSymbol label: aLabel
	| label |
	label := StringMorph 
				contents: aLabel asString 
				font: (TextStyle default fontOfPointSize: (StandardFonts pointSizeForStyleNamed: aSymbol)).
	^ (self theme 
		newButtonIn: self
		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: ''!
setFontsToStyleNamed: aSymbol

	(self class environment includesKey: #SourceCodeFonts)
		ifTrue: [ (self environment at: #SourceCodeFonts) setFontsToStyleNamed: aSymbol ]
		ifFalse: [ StandardFonts setFontsToStyleNamed: aSymbol ].
		
	WorldMorph displayScaleFactor: (self displayScaleFactorForStyleNamed: aSymbol).

	SettingBrowser refreshAllSettingBrowsers.
	EditorFindReplaceDialogWindow cleanUp.! !

!GroupWindowMorph commentStamp: ''!
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: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		icon: iconSelector
		getEnabled: enabledSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newAlphaImage: aForm help: helpText
	"Answer an alpha image morph."

	^self theme
		newAlphaImageIn: self
		image: aForm
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText
	"Answer a morph list for the given model."

	^self
		newMorphListFor: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: nil
		help: helpText! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
deny: aStringOrText title: aString
	"Open a denial dialog."

	^self theme
		denyIn: self
		text: aStringOrText
		title: aString! !

!GroupWindowMorph methodsFor: 'accessing' stamp: ''!
tabGroup

	^ tabGroup! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
question: aStringOrText
	"Open a question dialog."

	^self question: aStringOrText title: 'Question' translated! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
message: aStringOrText title: aString
	"Open a message dialog."

	^self theme
		messageIn: self
		text: aStringOrText
		title: aString! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: aModel
		label: aString
		offset: offset
		alpha: alpha
		getEnabled: enabledSel! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newString: aStringOrText style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: aStyle! !

!GroupWindowMorph methodsFor: 'model - updating' stamp: ''!
okToChange

    ^self tabGroup pages allSatisfy: [ :each | each model okToChange ]! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newColorPresenterFor: aModel getColor: getSel help: helpText
	"Answer a color presenter with the given selectors."

	^self theme
		newColorPresenterIn: self
		for: aModel
		getColor: getSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: #bottomLeft! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newImage: aForm
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newSeparator
	"Answer an horizontal separator."

	^self theme
		newSeparatorIn: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newScrollPaneFor: aMorph
	"Answer a new scroll pane morph to scroll the given morph."
	
	^self theme
		newScrollPaneIn: self
		for: aMorph! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newStack: controls
	"Answer a morph laid out with a stack of controls."

	^self theme
		newStackIn: self
		for: controls! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newLabelGroup: labelsAndControls
	"Answer a morph laid out with a column of labels and a column of associated controls.
	Controls having a vResizing value of #spaceFill will
	cause their row to use #spaceFill also, otherwise #shrinkWrap."

	^self theme
		newLabelGroupIn: self
		for: labelsAndControls! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newGroupboxForAll: controls
	"Answer a plain groupbox with the given controls."

	^self theme
		newGroupboxIn: self
		forAll: controls! !

!GroupWindowMorph methodsFor: 'testing' stamp: ''!
isActive
	^ false! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
message: aStringOrText
	"Open a message dialog."

	^self message: aStringOrText title: 'Information' translated! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newCancelButton
	"Answer a new cancel button."

	^self newCancelButtonFor: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newVerticalSeparator
	"Answer a vertical separator."

	^self theme
		newVerticalSeparatorIn: self! !

!GroupWindowMorph methodsFor: 'windows' stamp: ''!
removeWindow: aSystemWindow
	"Remove a window from the pages."

	aSystemWindow isCloseable
		ifFalse: [ ^ self ].
	aSystemWindow announcer unsubscribe: self.
	self tabGroup removePage: aSystemWindow.
	aSystemWindow configureForUnembedding.
	"self world addMorph: aSystemWindow"
	aSystemWindow deleteDiscardingChanges.
	self tabGroup pages ifEmpty: [ self owner delete ]! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText
	"Answer a list for the given model."

	^self
		newListFor: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: nil
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newNoButton
	"Answer a new No button."

	^self newNoButtonFor: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newYesButtonFor: aModel
	"Answer a new yes button."

	^self theme
		newYesButtonIn: self
		for: aModel! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
textEntry: aStringOrText
	"Open a text entry dialog."

	^self textEntry: aStringOrText title: 'Entry' translated! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title for: contentMorph
	"Answer a new pluggable dialog with the given content."

	^self theme
		newPluggableDialogWindowIn: self
		title: title
		for: contentMorph! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newToolbar
	"Answer a toolbar."

	^self theme
		newToolbarIn: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText
	"Answer a bracket slider with the given selectors."

	^self
		newBracketSliderFor: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum 
		getEnabled: nil
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: aClass
		default: defaultValue
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseColor
	"Answer the result of a color selector dialog ."

	^self chooseColor: Color black! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText
		entryCompletion: anEntryCompletion! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newGroupbox: aString
	"Answer a groupbox with the given label."

	^self theme
		newGroupboxIn: self
		label: aString! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title
	"Answer a new pluggable dialog with the given content."

	^self
		newPluggableDialogWindow: title
		for: nil! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel help: helpText
	"Answer a text entry for the given model."

	^self
		newTextEntryFor: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: nil 
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a bracket slider with the given selectors."

	^self theme
		newBracketSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseFont
	"Answer the result of a font selector dialog."

	^self chooseFont: nil! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newExpander: aString forAll: controls
	"Answer an expander with the given label and controls."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: controls! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		label: (AlphaImageMorph new image: aForm)
		help: helpText! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseExistingFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseExistingFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText
	"Open a question dialog."

	^self questionWithoutCancel: aStringOrText title: 'Question' translated! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseColor: aColor 
	"Answer the result of a color selector dialog with the given color."

	^self theme
		chooseColorIn: self
		title: 'Colour Selector' translated
		color: aColor! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseDirectory: title 
	"Answer the result of a file dialog with the given title, answer a directory."

	^self
		chooseDirectory: title
		path: nil! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText list: aList
	"Open a drop list chooser dialog."

	^self
		chooseDropList: aStringOrText
		title: 'Choose' translated
		list: aList! !

!GroupWindowMorph methodsFor: 'windows' stamp: ''!
grabWindow
	"Request an existing window from the user and add it."

	|windows choice|
	windows := self world visibleSystemWindows.
	choice := UIManager default
		chooseFrom: (windows collect: [:e | e labelString])
		values: windows
		lines: #()
		message: 'Choose a window to add to the organiser' translated
		title: 'Grab window' translated.
	choice ifNotNil: [self addWindow: choice]! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel ghostText: ghostText getEnabled: enabledSel help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: String
		default: ''
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: false
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
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: 'updating' stamp: ''!
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: self activeHand keyboardFocus.
						self tabGroup page ifNotNil: [self tabGroup page activate].]
				]! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseForSaveFileReference: 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
		chooseForSaveFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector
	"Answer a new tree morph."
	
	^self theme
		newTreeIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newWindowFor: aModel title: titleString
	"Answer a new window morph."
	
	^self theme
		newWindowIn: self
		for: aModel
		title: titleString! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newToolbar: controls
	"Answer a toolbar with the given controls."

	^self theme
		newToolbarIn: self
		for: controls! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newOKButtonFor: aModel getEnabled: enabledSel
	"Answer a new OK button."

	^self theme
		newOKButtonIn: self
		for: aModel
		getEnabled: enabledSel! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newStack
	"Answer a morph laid out as a stack."

	^self theme
		newStackIn: self
		for: #()! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newToolSpacer
	"Answer a tool spacer."

	^self theme
		newToolSpacerIn: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newTitle: aString for: control
	"Answer a morph laid out with a column with a title."

	^self theme
		newTitleIn: self
		label: aString
		for: control! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion

	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel 
		help: helpText
		entryCompletion: anEntryCompletion! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText
	"Answer a slider with the given selectors."

	^self theme
		newSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: 0
		max: 1
		quantum: nil
		getEnabled: enabledSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newOKButtonFor: aModel
	"Answer a new OK button."

	^self
		newOKButtonFor: aModel
		getEnabled: nil! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newCancelButtonFor: aModel
	"Answer a new cancel button."

	^self theme
		newCancelButtonIn: self
		for: aModel! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector
	"Answer a text editor for the given model."

	^self theme
		newTextEditorIn: self
		for: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: menuSelector! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newSVSelector: aColor help: helpText
	"Answer a saturation-volume selector with the given color."

	^self theme
		newSVSelectorIn: self
		color: aColor
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newButtonLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new button text label."

	^self theme
		newButtonLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseFont: aFont 
	"Answer the result of a font selector dialog with the given initial font."

	^self theme
		chooseFontIn: self
		title: 'Font Selector' translated
		font: aFont! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString
	"Open an alert dialog."

	^self
		alert: aStringOrText
		title: aString
		configure: [:d | ]! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newString: aStringOrText
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: #plain! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newTabGroup: labelsAndPages
	"Answer a tab group with the given tab labels associated with pages."

	^self theme
		newTabGroupIn: self
		for: labelsAndPages! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newButtonLabel: aString
	"Answer a new button text label."

	^self
		newButtonLabelFor: nil
		label: aString
		getEnabled: nil! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString entryText: defaultEntryText
	"Open a text entry dialog."

	^self theme
		textEntryIn: self
		text: aStringOrText
		title: aString
		entryText: defaultEntryText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: cornerSymbol! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
chooseForSaveFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseForSaveFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow
	"Answer a new pluggable dialog."

	^self
		newPluggableDialogWindow: 'Dialog'! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText! !

!GroupWindowMorph methodsFor: 'dropping/grabbing' stamp: ''!
wantsDroppedMorph: aMorph event: evt
  "Accept if a SystemWindow."
  
  self visible ifFalse: [^ false].
  self dropEnabled ifFalse: [^ false].
  
  (self tabGroup tabSelectorMorph bounds containsPoint: evt position) ifFalse: [^ false].
  
  ^aMorph isSystemWindow! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newExpander: aString for: aControl
	"Answer an expander with the given label and control."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: {aControl}! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newExpander: aString
	"Answer an expander with the given label."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: #()! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseExistingFileReference: 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
		chooseExistingFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self theme
		newRadioButtonIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
question: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionIn: self
		text: aStringOrText
		title: aString! !

!GroupWindowMorph methodsFor: 'windows' stamp: ''!
onWindowLabelChanged: ann
	self tabGroup relabelPage: ann window with: (self tabLabelFor: ann window)! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newCloseButtonFor: aModel
	"Answer a new close button."

	^self theme
		newCloseButtonIn: self
		for: aModel! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newFuzzyLabel: aString
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: nil
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: nil! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newRow
	"Answer a morph laid out as a row."

	^self theme
		newRowIn: self
		for: #()! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
abort: aStringOrText title: aString
	"Open an error dialog."

	^self theme
		abortIn: self
		text: aStringOrText
		title: aString! !

!GroupWindowMorph methodsFor: 'windows' stamp: ''!
tabLabelFor: aSystemWindow
	"Answer the tab label to use for the given page."

	^self newRow: {
		 (self newButtonLabel: (aSystemWindow labelString truncateWithElipsisTo: 40))
			setBalloonText: aSystemWindow labelString.
		 self
			newCloseControlFor: nil
			action: [self removeWindow: aSystemWindow]
			help: 'Close this tab and free the window'}! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		alertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newNoButtonFor: aModel
	"Answer a new No button."

	^self theme
		newNoButtonIn: self
		for: aModel! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newOverflowRowForAll: aCollectionOfMorphs
	"Answer a new overflow row morph that provides a drop down for
	the given contents that are unable to fit the bounds."
	
	^self theme
		newOverflowRowIn: self
		forAll: aCollectionOfMorphs! !

!GroupWindowMorph methodsFor: 'windows' stamp: ''!
newTabGroup
	"Answer a new tab group."

	^(self newTabGroup: #())
		cornerStyle: #square! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a morph list for the given model."

	^self theme
		newMorphListIn: self
		for: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!GroupWindowMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
themeChanged
	self color: self defaultColor.
	super themeChanged! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText title: aString list: aList
	"Open a drop list chooser dialog."

	^self theme
		chooseDropListIn: self
		text: aStringOrText
		title: aString
		list: aList! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newYesButton
	"Answer a new Yes button."

	^self newYesButtonFor: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newHSVSelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVSelectorIn: self
		color: aColor
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: nil
		help: helpText! !

!GroupWindowMorph methodsFor: 'layout' stamp: ''!
changePropotionalLayout
	| layout |
	((layout := self layoutPolicy) notNil and:[layout isProportionalLayout])
		ifTrue:[^self]. "already proportional layout"
	self layoutPolicy: ProportionalLayout new.
	self layoutChanged.! !

!GroupWindowMorph methodsFor: 'dropping/grabbing' stamp: ''!
dragTab: aSystemWindow event: anEvent in: aTabLabel
	"Drag a tab. Remove the window from the organiser and place in hand."
	
	self removeWindow: aSystemWindow.
	aSystemWindow position: anEvent targetPoint.
	anEvent hand grabMorph: aSystemWindow! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		getLabel: labelSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'initialization' stamp: ''!
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: 'controls' stamp: ''!
newPanel
	"Answer a new panel."

	^self theme
		newPanelIn: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newGroupbox: aString forAll: controls
	"Answer a groupbox with the given label and controls."

	^self theme
		newGroupboxIn: self
		label: aString
		forAll: controls! !

!GroupWindowMorph methodsFor: 'layout' stamp: ''!
acceptDroppingMorph: aSystemWindow event: evt
	"Add the window."

	self addWindow: aSystemWindow! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
proceed: aStringOrText
	"Open a proceed dialog."

	^self proceed: aStringOrText title: 'Proceed' translated! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a drop list for the given model."

	^self theme
		newDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newToolbarHandle
	"Answer a toolbar handle."

	^self theme
		newToolbarHandleIn: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newLabel: aString
	"Answer a new text label."

	^self
		newLabelFor: nil
		label: aString
		getEnabled: nil! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
longMessage: aStringOrText title: aString
	"Open a (long) message dialog."

	^self theme
		longMessageIn: self
		text: aStringOrText
		title: aString! !

!GroupWindowMorph methodsFor: 'theme' stamp: ''!
theme
	"Answer the ui theme that provides controls."

	^ Smalltalk ui theme! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
centeredAlert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		centeredAlertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newToolDockingBar
	"Answer a tool docking bar."

	^self theme
		newToolDockingBarIn: self! !

!GroupWindowMorph methodsFor: 'testing' stamp: ''!
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 isTopWindow ]! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseColor: aColor title: title
	"Answer the result of a color selector dialog with the given title and initial colour."

	^self theme
		chooseColorIn: self
		title: title
		color: aColor! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newMultistateButton
	"Answer a new multistate button morph.
	To be usable it needs to have fill styles assigned to various states along
	with mouse-up/down actions."
	
	^self theme
		newMultistateButtonIn: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newOKButton
	"Answer a new OK button."

	^self newOKButtonFor: self! !

!GroupWindowMorph methodsFor: 'initialize' stamp: ''!
defaultColor
	^ self theme windowColor lighter! !

!GroupWindowMorph methodsFor: 'accessing' stamp: ''!
tabGroup: anObject

	tabGroup := anObject! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newHueSelector: aModel getHue: getSel setHue: setSel help: helpText
	"Answer a hue selector with the given selectors."

	^self theme
		newHueSelectorIn: self
		for: aModel
		getHue: getSel
		setHue: setSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		getLabel: labelSel
		getEnabled: enabledSel! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a morph drop list for the given model."

	^self theme
		newMorphDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newGroupbox
	"Answer a plain groupbox."

	^self theme
		newGroupboxIn: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newEmbeddedMenu
	"Answer a new menu."

	^self theme
		newEmbeddedMenuIn: self
		for: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newHSVASelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVASelectorIn: self
		color: aColor
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 
	"Answer a text editor for the given model."

	^self 
		newTextEditorFor: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: nil! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newGroupboxFor: control
	"Answer a plain groupbox with the given control."

	^self theme
		newGroupboxIn: self
		for: control! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newDialogPanel
	"Answer a new main dialog panel."

	^self theme
		newDialogPanelIn: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newImageFor: aModel get: getSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newImageIn: self
		for: aModel
		get: getSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newGroupbox: aString for: control
	"Answer a groupbox with the given label and control."

	^self theme
		newGroupboxIn: self
		label: aString
		for: control! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newMenuFor: aModel
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: aModel! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newString: aStringOrText font: aFont style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: aFont
		style: aStyle! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel 
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newMenu
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText
	"Answer an alpha channel selector with the given selectors."

	^self theme
		newAlphaSelectorIn: self
		for: aModel
		getAlpha: getSel
		setAlpha: setSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		font: aFont
		help: helpText
		entryCompletion: anEntryCompletion! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: enabledSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
deny: aStringOrText
	"Open a denial dialog."

	^self deny: aStringOrText title: 'Access Denied' translated! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: aModel
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: enabledSel! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionWithoutCancelIn: self
		text: aStringOrText
		title: aString! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString
	"Open a text entry dialog."

	^self
		textEntry: aStringOrText
		title: aString
		entryText: ''! !

!GroupWindowMorph methodsFor: 'updating' stamp: ''!
update: aSymbol
	"Handle tab changes."

	super update: aSymbol.
	aSymbol == #selectedIndex
		ifTrue: [self tabGroup page activate]! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newText: aStringOrText
	"Answer a new text."

	^self theme
		newTextIn: self
		text: aStringOrText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self
		newRadioButtonFor: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
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: 'windows' stamp: ''!
addWindow: aSystemWindow
  "Add an existing window to the pages."

	aSystemWindow isTopWindow
		ifTrue: [SystemWindow passivateTopWindow].
		
	self tabGroup
		addPage: aSystemWindow configureForEmbedding
		label: (self tabLabelFor: aSystemWindow);
		selectedPageIndex: self tabGroup pages size.
		
	self isActive ifFalse: [self tabGroup selectedTab passivate].
	
	self tabGroup selectedTab
		on: #startDrag
		send: #dragTab:event:in:
		to: self
		withValue: aSystemWindow.
		
	aSystemWindow announcer
		when: WindowLabelled 
		send: #onWindowLabelChanged:
		to: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newRow: controls
	"Answer a morph laid out with a row of controls."

	^self theme
		newRowIn: self
		for: controls! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		getLabel: labelSel
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newColumn: controls
	"Answer a morph laid out with a column of controls."

	^self theme
		newColumnIn: self
		for: controls! !

!GroupWindowMorph methodsFor: 'windows' stamp: ''!
offerWindowMenu
	"Popup the window menu. Fill from current workspace."

	| aMenu |
	aMenu := self buildWindowMenu.
	aMenu
		addLine;
		add: 'Grab window...' target: self selector: #grabWindow.
	aMenu lastItem icon: (self iconNamed: #smallWindowIcon).
	self tabGroup page
		ifNotNil: [ :page | page model addModelItemsToWindowMenu: aMenu ].
	aMenu popUpEvent: self currentEvent in: self world! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newSliderFor: aModel getValue: getSel setValue: setSel help: helpText
	"Answer a slider with the given selectors."

	^self theme
		newSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: 0
		max: 1
		quantum: nil
		getEnabled: nil
		help: helpText! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
chooseDirectory: title path: path
	"Answer the result of a file dialog with the given title, answer a directory."

	^self theme
		chooseDirectoryIn: self
		title: title
		path: path! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
alert: aStringOrText
	"Open an alert dialog."

	^self alert: aStringOrText title: 'Alert' translated! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
proceed: aStringOrText title: aString
	"Open a proceed dialog and answer true if not cancelled, false otherwise."

	^self theme
		proceedIn: self
		text: aStringOrText
		title: aString! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newCloseControlFor: aModel action: aValuable help: helpText
	"Answer a new cancel button."

	^self theme
		newCloseControlIn: self
		for: aModel
		action: aValuable
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newButtonFor: aModel action: actionSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: nil 
		label: stringOrText
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
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: 'events-processing' stamp: ''!
handleDropMorph: anEvent
	"Handle a dropping morph."
	
	| aMorph |
	aMorph := anEvent contents.
	"Ignore whether the dropping morph wants to be dropped, just whether the receiver wants it"
	(self wantsDroppedMorph: aMorph event: anEvent)
		ifFalse: [^ self].
	anEvent wasHandled: true.
	self acceptDroppingMorph: aMorph event: anEvent.
	aMorph justDroppedInto: self event: anEvent! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newCloseButton
	"Answer a new close button."

	^self newCloseButtonFor: self! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newImage: aForm size: aPoint
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm
		size: aPoint! !

!GroupWindowMorph methodsFor: 'services' stamp: ''!
abort: aStringOrText
	"Open an error dialog."

	^self abort: aStringOrText title: 'Error' translated! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		useIndex: true
		help: helpText! !

!GroupWindowMorph methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a drop list for the given model."

	^self theme
		newDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!GroupWindowMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!GroupWindowMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!GroupWindowMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!GroupWindowMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!GroupWindowMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!GroupWindowMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!GroupWindowMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!GroupWindowMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!GroupWindowMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!GroupWindowMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!GroupWindowMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!GroupWindowMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!GroupWindowMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!GroupWindowMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!GroupWindowMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!GroupWindowMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!GroupWindowMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!GroupWindowMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!GroupWindowMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!GroupWindowMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!GroupWindowMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!GroupWindowMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!GroupWindowMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!GroupWindowMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!GroupWindowMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!GroupWindowMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!GroupWindowMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!GroupWindowMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!GroupWindowMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!GroupboxMorph commentStamp: ''!
Groupbox with title with a vertical layout. Appears in a lighter colour than the owner's pane colour.!
!GroupboxMorph methodsFor: 'accessing' stamp: ''!
labelMorph
	"Answer the value of labelMorph"

	^ labelMorph! !

!GroupboxMorph methodsFor: 'adding' stamp: ''!
addContentMorph: aMorph
	"Add a morph to the content."

	^self contentMorph addMorphBack: aMorph! !

!GroupboxMorph methodsFor: 'rounding' stamp: ''!
cornerStyle: aSymbol
	"Pass on to list too."

	super cornerStyle: aSymbol.
	self labelMorph cornerStyle: aSymbol.
	self contentMorph cornerStyle: aSymbol! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
getContentSelector

	^ getContentSelector! !

!GroupboxMorph methodsFor: 'initialization' stamp: ''!
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: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
labelMorph: anObject
	"Set the value of labelMorph"

	labelMorph := anObject! !

!GroupboxMorph methodsFor: 'instance creation' stamp: ''!
newContentMorph
	"Answer a new content morph"

	|p|
	p := PanelMorph new
		roundedCorners: self roundedCorners;
		changeTableLayout; 
		layoutInset: 4;
		cellInset: 8;
		vResizing: #spaceFill;
		hResizing: #spaceFill.
	p borderStyle: (self theme groupPanelBorderStyleFor: p).
	^p! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
contentMorph
	"Answer the value of contentMorph"

	^ contentMorph! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
contentMorph: anObject
	"Set the value of contentMorph"

	contentMorph := anObject! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
font
	"Answer the label font"

	^self labelMorph font! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
font: aFont
	"Set the label font"

	self labelMorph font: aFont! !

!GroupboxMorph methodsFor: 'geometry testing' stamp: ''!
minExtent
	"Answer the minmum extent of the receiver.
	Based on label and rounding."

	^super minExtent max: self labelMorph minExtent + (8@0)! !

!GroupboxMorph methodsFor: 'instance creation' stamp: ''!
newLabelMorph
	"Answer a new label morph"

	^TextMorph new
		roundedCorners: #(1 4);
		margins: (Margin left: 2 right: 2 top: 1 bottom: -1);
		contents: 'groupbox';
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		lock! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
paneColorOrNil
	"Answer the window's pane color or nil otherwise."

	^super paneColorOrNil ifNotNil: [:c | self theme subgroupColorFrom: c]! !

!GroupboxMorph methodsFor: 'updating' stamp: ''!
replaceContentMorph: aMorph
	"Replace the content."

	self contentMorph
		removeAllMorphs;
		addMorphBack: aMorph.
	self adoptPaneColor: super paneColorOrNil.
	^aMorph! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
roundedCorners: anArray
	"Set the corners to round."

	super roundedCorners: anArray.
	self contentMorph ifNotNil: [:cm | cm roundedCorners: self roundedCorners]! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
selectedTab
	"Answer the label morph for compatibility with TabPanelBorder."
	
	^self labelMorph owner
		ifNotNil: [self labelMorph]! !

!GroupboxMorph methodsFor: 'updating' stamp: ''!
update: aSymbol
	"Replace the content if appropriate."
	
	super update: aSymbol.
	aSymbol = self getContentSelector ifTrue: [
		self contentFromModel ifNotNil: [:c | self replaceContentMorph: c]]! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Pass on to the content morph."
	
	|c|
	paneColor ifNil: [^super adoptPaneColor: paneColor].
	c := self theme subgroupColorFrom: paneColor.
	super adoptPaneColor: c.
	self contentMorph borderStyle: (self theme groupPanelBorderStyleFor: self).
	self labelMorph
		color: paneColor blacker muchDarker;
		backgroundColor: c;
		borderStyle: (self theme groupLabelBorderStyleFor: self)! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
contentFromModel
	"Answer content from the model."
	
	^self getContentSelector ifNotNil: [:s |
		self model ifNotNil: [:m | m perform: s]]! !

!GroupboxMorph methodsFor: 'geometry testing' stamp: ''!
containsPoint: aPoint
	"Override here to check the label and content instead."
	
	^(super containsPoint: aPoint) and: [
		(self labelMorph containsPoint: aPoint) or: [
		self contentMorph containsPoint: aPoint]]! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
getContentSelector: anObject

	getContentSelector := anObject! !

!GroupboxMorph methodsFor: 'accessing' stamp: ''!
label
	"Answer the contents of the label morph."

	^self labelMorph contents! !

!GrowlMorph commentStamp: ''!
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: DateAndTime now)
"		vanishDelay: 1000;
		resetVanishTimer".
	World doOneCycle ].

(GrowlMorph openWithLabel: 'The time' contents: DateAndTime now) 
	actionBlock: [Transcript open].!
!GrowlMorph methodsFor: 'internal' stamp: ''!
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: 'default' stamp: ''!
defaultBackgroundColor

	^ self theme growlFillColorFor: self! !

!GrowlMorph methodsFor: 'accessing' stamp: ''!
backgroundColor

	^ backgroundColor ifNil: [ backgroundColor := self defaultBackgroundColor ]! !

!GrowlMorph methodsFor: 'stepping' stamp: ''!
step

	(self containsPoint: self activeHand position) ifTrue: [
		self resetAlpha.
		^ self].
	vanishTime ifNotNil: [DateAndTime now < vanishTime ifTrue: [^self]].
	self alpha: self alpha - 0.05.! !

!GrowlMorph methodsFor: 'position' stamp: ''!
unoccupiedPositionTopLeft

	| startPos area rect morphs |
	
	startPos := 10@10.
	area := self currentWorld clearArea.
	rect := area topLeft + (startPos) extent: self extent.
	
	morphs := self activeGrowlMorphs.
	[self is: rect saneWithRespectTo: morphs] whileFalse: [
		rect := rect translateBy: 0@10.
		rect bottom > area height ifTrue: [^ area topLeft + startPos ]
	].
	^ rect origin! !

!GrowlMorph methodsFor: 'internal' stamp: ''!
is: rect saneWithRespectTo: morphs

	^(morphs anySatisfy: [ :morph | morph owner isNotNil and: [morph bounds intersects: rect]]) not! !

!GrowlMorph methodsFor: 'position' stamp: ''!
unoccupiedPositionBottomLeft

	| startPos area rect morphs |
	
	startPos := 10 negated @ (self height + 10).
	area := self currentWorld clearArea.
	rect := (area bottomLeft - startPos) extent: self extent.
	
	morphs := self activeGrowlMorphs.
	[self is: rect saneWithRespectTo: morphs] whileFalse: [
		rect := rect translateBy: 0@(-10).
		rect top < 0 ifTrue: [^ area bottomLeft - startPos]
	].
	^ rect origin! !

!GrowlMorph methodsFor: 'accessing' stamp: ''!
contentsColor: aColor
	"when you set this contentsColor, it takes precedence over theme one. In certain case (such as for green as in SUnit) it is needed, normally you do not need it."
	contentsColor := aColor.
	contentsAttr color: aColor! !

!GrowlMorph methodsFor: 'accessing' stamp: ''!
labelColor: aColor
	"when you set this labelColor, it takes precedence over theme one. In certain case (such as for green as in SUnit) it is needed, normally you do not need it."
	labelColor := aColor.
	labelAttr color: self labelColor.! !

!GrowlMorph methodsFor: 'internal' stamp: ''!
resetVanishTimer

	vanishTime := DateAndTime now + self vanishDelay.
	self resetAlpha.! !

!GrowlMorph methodsFor: 'initialization' stamp: ''!
labelAttributes
	^ { labelAttr. TextAlignment centered. TextFontChange font4. TextEmphasis bold. }! !

!GrowlMorph methodsFor: 'accessing' stamp: ''!
labelColor
	^ labelColor ifNil: [ labelColor := self theme growlLabelColorFor: self ]! !

!GrowlMorph methodsFor: 'accessing' stamp: ''!
alpha: newAlpha

	alpha := newAlpha.
	labelAttr color: (self labelColor alpha: alpha).
	contentsAttr color: (self contentsColor alpha: alpha).
	self backgroundColor: (self nextColorStep: self backgroundColor).
	self allMorphsDo: [:m |
		m borderColor: (self nextColorStep: m borderColor).
		m color: (self nextColorStep: m color)].
	self borderColor isTransparent ifTrue: [self delete].! !

!GrowlMorph methodsFor: 'building' stamp: ''!
contents: contentsString

	self streamDo: [ :w |
		w withAttributes: self contentsAttributes do: [w nextPutAll: contentsString asString]]! !

!GrowlMorph methodsFor: 'position' stamp: ''!
unoccupiedPositionTopRight

	| startPos area rect morphs |
	
	startPos := (self width + 10 @ 10 negated).
	area := self currentWorld clearArea.
	rect := (area topRight - startPos) extent: self extent.
	
	morphs := self activeGrowlMorphs.	
	[self is: rect saneWithRespectTo: morphs] whileFalse: [
		rect := rect translateBy: 0@10.
		rect bottom > area height ifTrue: [^ (area topRight - startPos) ]
	].

	^ rect origin! !

!GrowlMorph methodsFor: 'initialization' stamp: ''!
initializeContentsAttributes
	contentsAttr := TextColor color: self contentsColor.! !

!GrowlMorph methodsFor: 'accessing' stamp: ''!
alpha
	^ alpha! !

!GrowlMorph methodsFor: 'stepping' stamp: ''!
stepTime
	^ 100! !

!GrowlMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
 	self  borderStyle: (BorderStyle color: self defaultBorderColor width: 1).
	
	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: 'building' stamp: ''!
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: 'opening' stamp: ''!
preOpenInWorld: aWorld

	self position: self unoccupiedPosition! !

!GrowlMorph methodsFor: 'accessing' stamp: ''!
vanishDelay: aDuration

	vanishDelay := aDuration.
	self resetVanishTimer! !

!GrowlMorph methodsFor: 'default' stamp: ''!
minimumExtent
	^ 256@38! !

!GrowlMorph methodsFor: 'initialization' stamp: ''!
nextColorStep: aColor
	^ aColor alpha: self alpha! !

!GrowlMorph methodsFor: 'initialization' stamp: ''!
createDismissHandle
	| handle |
	handle := self theme growlDismissHandleFor: self.
	handle on: #mouseUp send: #delete to: self.
	^ handle! !

!GrowlMorph methodsFor: 'default' stamp: ''!
defaultTextStyle
	^ TextStyle actualTextStyles at: #Accuny! !

!GrowlMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	super mouseDown: evt.
	evt yellowButtonPressed ifTrue: [^ self].
	actionBlock ifNotNil: [actionBlock valueWithPossibleArgs: { self }].! !

!GrowlMorph methodsFor: 'position' stamp: ''!
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: 'accessing' stamp: ''!
enabled

	^ false! !

!GrowlMorph methodsFor: 'initialization' stamp: ''!
contentsAttributes
	^ { contentsAttr. TextAlignment centered. TextFontChange font2. }! !

!GrowlMorph methodsFor: 'building' stamp: ''!
actionBlock: aBlock

	actionBlock := aBlock! !

!GrowlMorph methodsFor: 'default' stamp: ''!
defaultBorderColor
	
	^ self theme growlBorderColorFor: self! !

!GrowlMorph methodsFor: 'initialization' stamp: ''!
initializeLabelAttributes
	labelAttr := TextColor color: self labelColor.! !

!GrowlMorph methodsFor: 'position' stamp: ''!
unoccupiedPositionBottomRight

	| startPos area rect morphs |
	
	startPos := (self width + 10 ) @ (self height + 10).
	area := self currentWorld clearArea.
	rect := (area bottomRight - startPos) extent: self extent.
	
	morphs := self activeGrowlMorphs.	
	[self is: rect saneWithRespectTo: morphs] whileFalse: [
		rect := rect translateBy: 0@(-10).
		rect top < 0 ifTrue: [^ area bottomRight - startPos ]
	].
	^ rect origin! !

!GrowlMorph methodsFor: 'stepping' stamp: ''!
wantsSteps
	^ true! !

!GrowlMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^ actionBlock notNil or: [super handlesMouseDown: evt]! !

!GrowlMorph methodsFor: 'accessing' stamp: ''!
contentsColor
	^ contentsColor ifNil: [ contentsColor := self theme growlContentsColorFor: self ]! !

!GrowlMorph methodsFor: 'default' stamp: ''!
defaultVanishDelay
	
	^ 1  seconds! !

!GrowlMorph methodsFor: 'internal' stamp: ''!
activeGrowlMorphs

	^self currentWorld submorphs select: [ :morph | morph isKindOf: GrowlMorph ].! !

!GrowlMorph methodsFor: 'internal' stamp: ''!
resetAlpha
	^ self alpha: 0.9! !

!GrowlMorph methodsFor: 'accessing' stamp: ''!
vanishDelay

	^ vanishDelay! !

!GrowlMorph class methodsFor: 'position' stamp: ''!
position: aSymbol

	(self possiblePositions includes: aSymbol) ifFalse: [ ^ self ].

	Position := aSymbol! !

!GrowlMorph class methodsFor: 'instance creation' stamp: ''!
openWithLabel: aString contents: contentString

	^ self openWithLabel: aString 
		contents: contentString 
		backgroundColor: nil 
		labelColor: nil! !

!GrowlMorph class methodsFor: 'instance creation' stamp: ''!
label: aString contents: contentString
	
	^ self new
		label: aString contents: contentString;
		yourself! !

!GrowlMorph class methodsFor: 'settings' stamp: ''!
growlPositionChoices

	^#(topRight 'top right' 
		bottomLeft 'bottom left'
		bottomRight 'bottom right'
		topLeft 'topLeft') pairsCollect: [:a :b | b -> a]! !

!GrowlMorph class methodsFor: 'position' stamp: ''!
position

	^ Position ifNil: [ Position := #topRight ]! !

!GrowlMorph class methodsFor: 'position' stamp: ''!
possiblePositions

	^ #( bottomRight bottomLeft topRight topLeft )! !

!GrowlMorph class methodsFor: 'position' stamp: ''!
type: aSymbol

	(self possibleTypes includes: aSymbol) ifFalse: [ ^ self ].

	Type := aSymbol! !

!GrowlMorph class methodsFor: 'settings' stamp: ''!
growlSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #growl)
		label: 'Popup notification';  
		parent: #appearance;
		description: 'All settings concerned with the notifications popup look''n feel';
		with: [
			(aBuilder pickOne: #type)
				label: 'Popup notifycation type';
				target: self;
				default: #growl;
				order: 1;
				domainValues: self growlTypeChoices.
			(aBuilder pickOne: #position)
				label: 'Popup position';
				target: self;
				default: #bottomLeft;
				order: 2;
				domainValues: self growlPositionChoices.]! !

!GrowlMorph class methodsFor: 'instance creation' stamp: ''!
contents: contentString
	
	^ self label: '' contents: contentString! !

!GrowlMorph class methodsFor: 'position' stamp: ''!
type

	^ Type ifNil: [ Type := #growl ]! !

!GrowlMorph class methodsFor: 'position' stamp: ''!
possibleTypes

	^ #( growl window )! !

!GrowlMorph class methodsFor: 'instance creation' stamp: ''!
openWithLabel: aString contents: contentString color: aColor
	
	^ self openWithLabel: aString 
		contents: contentString 
		backgroundColor: aColor 
		labelColor: nil! !

!GrowlMorph class methodsFor: 'instance creation' stamp: ''!
openWithContents: contentString

	^ self openWithLabel: '' 
		contents: contentString 
		backgroundColor: nil 
		labelColor: nil! !

!GrowlMorph class methodsFor: 'instance creation' stamp: ''!
openWithLabel: aString contents: contentString backgroundColor: aColor labelColor: aLabelColor
	
	^ self type = #window 
		ifTrue: [ MessageDialogWindow new message: contentString ]
		ifFalse: [ 
			| anInstance |
			anInstance := self label: aString contents: contentString.
			aColor ifNotNil: [ anInstance backgroundColor: aColor ].
			aLabelColor ifNotNil: [ 
				anInstance labelColor: aLabelColor.
				anInstance contentsColor: aLabelColor ].
			anInstance openInWorld ]! !

!GrowlMorph class methodsFor: 'settings' stamp: ''!
growlTypeChoices

	^#(growl 'Growl Morph' 
		window 'Dialog window') pairsCollect: [:a :b | b -> a]! !

!GuideTest commentStamp: ''!
Common superclass for tests of guidance through the filesystem!
!GuideTest methodsFor: 'asserting' stamp: ''!
assertVisitedIs: anArray
	visited with: anArray do:
		[:entry :basename | 
		self assert: entry reference basename equals: basename]! !

!GuideTest methodsFor: 'visitor' stamp: ''!
visitDirectory: aReference
	visited add: aReference! !

!GuideTest methodsFor: 'visitor' stamp: ''!
visitFile: aReference
	visited add: aReference! !

!GuideTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	visited := OrderedCollection new.
	filesystem := FileSystem memory.
	self setUpGreek! !

!GuideTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #GuideTest! !

!HColorSelectorMorph commentStamp: ''!
ColorComponentSelector showing a hue rainbow palette.!
!HColorSelectorMorph methodsFor: 'accessing' stamp: ''!
color: aColor
	"Ignore to preserve fill style."! !

!HColorSelectorMorph methodsFor: 'protocol' stamp: ''!
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])! !

!HDChangeReport commentStamp: ''!
A change report!
!HDChangeReport methodsFor: 'generating' stamp: ''!
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: 'accessing' stamp: ''!
resolved
	^ gofer resolved! !

!HDChangeReport methodsFor: 'generating' stamp: ''!
generateChangeAddition: aPatch on: aStream
	aStream tab; tab; tab; nextPutAll: '<item action="add">'; nextPutAll: (self encode: (self convert: aPatch summary)); nextPutAll: '</item>'; nextPut: Character lf! !

!HDChangeReport methodsFor: 'generating' stamp: ''!
generateChangeModification: aPatch on: aStream
	aStream tab; tab; tab; nextPutAll: '<item action="change">'; nextPutAll: (self encode: (self convert: aPatch summary)); nextPutAll: '</item>'; nextPut: Character lf! !

!HDChangeReport methodsFor: 'running' stamp: ''!
run
	
	'changelog.xml' asFileReference ensureDelete writeStreamDo: [ :stream|
		self generateOn: stream ]! !

!HDChangeReport methodsFor: 'generating' stamp: ''!
generateChangeRemoval: aPatch on: aStream
	aStream tab; tab; tab; nextPutAll: '<item action="remove">'; nextPutAll: (self encode: (self convert: aPatch summary)); nextPutAll: '</item>'; nextPut: Character lf! !

!HDChangeReport methodsFor: 'generating' stamp: ''!
generateChangeSet: aResolvedVersion on: aStream
	| info |
	info := aResolvedVersion version info.
	aStream tab; nextPutAll: '<logentry version="'; nextPutAll: (self encode: info name); nextPutAll: '">'; nextPut: Character lf.
	aStream tab; tab; nextPutAll: '<date>'; nextPutAll: (self encode: info date yyyymmdd); space; nextPutAll: (self encode: info time print24); nextPutAll: '</date>'; nextPut: Character lf.
	aStream tab; tab; nextPutAll: '<author>'; nextPutAll: (self encode: info author); nextPutAll: '</author>'; nextPut: Character lf.
	aStream tab; tab; nextPutAll: '<msg>'; nextPutAll: (self encode: (self convert: info message)); nextPutAll: '</msg>'; nextPut: Character lf.
	"aStream tab; tab; nextPutAll: '<items>'; nextPut: Character lf.
	(self changesFor: aResolvedVersion)
		do: [ :each | self generateChange: each on: aStream ].
	aStream tab; tab; nextPutAll: '</items>'; nextPut: Character lf."
	aStream tab; nextPutAll: '</logentry>'; nextPut: Character lf! !

!HDChangeReport methodsFor: 'initialization' stamp: ''!
initializeOn: aCollection
	gofer := Gofer new.
	aCollection do: [ :each | gofer package: each ]! !

!HDChangeReport methodsFor: 'generating' stamp: ''!
generateOn: aStream
	aStream nextPutAll: '<?xml version="1.0" encoding="UTF-8"?>'; nextPut: Character lf.
	aStream nextPutAll: '<changelog>'; nextPut: Character lf.
	self resolved
		do: [ :each | self generateChangeSet: each on: aStream ].
	aStream nextPutAll: '<changelog>'! !

!HDChangeReport methodsFor: 'accessing' stamp: ''!
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 class methodsFor: 'running' stamp: ''!
runPackages: aCollectionOfStrings
	^ (self new initializeOn: aCollectionOfStrings) run! !

!HDChangeReport class methodsFor: 'running' stamp: ''!
runClasses: aCollectionOfClasses named: aString
	self error: 'The change report is only runnable on packages.'! !

!HDChangeReport class methodsFor: 'running' stamp: ''!
runPackage: aString
	^ self runPackages: (Array with: aString)! !

!HDCoverageReport commentStamp: ''!
Hudson report for test coverage!
!HDCoverageReport methodsFor: 'generating' stamp: ''!
generatePackage: aPackage method: aReference on: aStream
 
	aStream tab: 5; nextPutAll: '<method name="'; nextPutAll: (self encode: aReference selector); 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: '</method>'; nextPut: Character lf! !

!HDCoverageReport methodsFor: 'generating' stamp: ''!
generateDataOn: aStream
	| items |
	aStream tab; nextPutAll: '<data>'; nextPut: Character lf.
	aStream tab; tab; nextPutAll: '<all name="all classes">'; nextPut: Character lf.
	self
		generateType: 'class' indent: 3
		total: (items := (packages flatCollect: [ :each | each classes ]) asSet) size
		actual: ((covered collect: [ :each | each methodClass instanceSide ]) asSet
			count: [ :each | items includes: each ])
		on: aStream.
	self
		generateType: 'method' indent: 3
		total: (items := (packages flatCollect: [ :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: '</all>'; nextPut: Character lf.
	aStream tab; nextPutAll: '</data>'; nextPut: Character lf! !

!HDCoverageReport methodsFor: 'private' stamp: ''!
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: 'running' stamp: ''!
tearDown
	wrappers do: [ :each | each uninstall ].
	super tearDown.
	self generate! !

!HDCoverageReport methodsFor: 'private' stamp: ''!
ignoredSelectors
	^ #(packageNamesUnderTest classNamesNotUnderTest)! !

!HDCoverageReport methodsFor: 'generating' stamp: ''!
generatePackage: aPackage class: aClass on: aStream
	| items |
	aStream tab: 4; nextPutAll: '<class name="'; nextPutAll: (self encode: aClass name); nextPutAll: '">'; nextPut: Character lf.
	self
		generateType: 'class' indent: 5
		total: 1
		actual: ((covered anySatisfy: [ :each | each methodClass instanceSide = aClass ])
			ifTrue: [ 1 ] ifFalse: [ 0 ])
		on: aStream.
	self
		generateType: 'method' indent: 5
		total: (items := aPackage definedMethodsForClass: 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: '</class>'; nextPut: Character lf! !

!HDCoverageReport methodsFor: 'generating' stamp: ''!
generateType: aString indent: anInteger total: totalInteger actual: actualInteger on: aStream
	aStream tab: anInteger; 
		nextPutAll: '<coverage type="'; nextPutAll: aString; 
		nextPutAll: ', %" value="'; print: (totalInteger = 0 ifTrue: [ 0 ] ifFalse: [ (100.0 * actualInteger / totalInteger) rounded ]); 
		nextPutAll: '% ('; print: actualInteger; nextPut: $/; print: totalInteger; nextPutAll: ')"/>'; 
		nextPut: Character lf! !

!HDCoverageReport methodsFor: 'private' stamp: ''!
packagesIn: aTestAsserter
	^ self addTestsIn: aTestAsserter to: Set new! !

!HDCoverageReport methodsFor: 'generating' stamp: ''!
generateStatsOn: aStream
	aStream tab; nextPutAll: '<stats>'; nextPut: Character lf.
	aStream tab; tab; nextPutAll: '<packages value="'; print: (packages size); nextPutAll: '"/>'; nextPut: Character lf.
	aStream tab; tab; nextPutAll: '<classes value="'; print: (packages sum: [ :each | each classes size ]); nextPutAll: '"/>'; nextPut: Character lf.
	aStream tab; tab; nextPutAll: '<methods value="'; print: (packages sum: [ :each | each methods size ]); nextPutAll: '"/>'; nextPut: Character lf.
	aStream tab; nextPutAll: '</stats>'; nextPut: Character lf.! !

!HDCoverageReport methodsFor: 'generating' stamp: ''!
generatePackage: aPackage on: aStream
	| items |
	aStream tab: 3; nextPutAll: '<package name="'; nextPutAll: (self encode: (aPackage packageName copyReplaceAll: '-' with: '.')); nextPutAll: '">'; nextPut: Character lf.
	self
		generateType: 'class' indent: 4
		total: (items := aPackage classes asSet) size
		actual: ((covered collect: [ :each | each methodClass instanceSide ]) 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: '</package>'; nextPut: Character lf! !

!HDCoverageReport methodsFor: 'generating' stamp: ''!
generate
	| coverage |
	covered := (wrappers select: [ :each | each hasRun ])
		collect: [ :each | each reference ].
	coverage := File openForWriteFileNamed: suite name , '-Coverage.xml'.
	[ self generateOn: coverage ]
		ensure: [ coverage close ]! !

!HDCoverageReport methodsFor: 'private' stamp: ''!
methodsIn: aPackage
	aPackage ifNil: [ ^ #() ].
	^ aPackage methods reject: [ :method | 
		(self ignoredSelectors includes: method selector)
			or: [ method compiledMethod isAbstract
			or: [ method compiledMethod refersToLiteral: #ignoreForCoverage ] ] ]! !

!HDCoverageReport methodsFor: 'generating' stamp: ''!
generateOn: aStream
	aStream nextPutAll: '<?xml version="1.0" encoding="UTF-8"?>'; nextPut: Character lf.
	aStream nextPutAll: '<report>'; nextPut: Character lf.
	self generateStatsOn: aStream.
	self generateDataOn: aStream.
	aStream nextPutAll: '</report>'; nextPut: Character lf! !

!HDCoverageReport methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	wrappers := ((packages := self packagesIn: suite)
		flatCollect: [ :package | self methodsIn: package ])
		collect: [ :each | HDTestCoverage on: each ].
	wrappers do: [ :each | each install ]! !

!HDLintReport commentStamp: ''!
Hudson report for lint results!
!HDLintReport methodsFor: 'generating' stamp: ''!
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: '<error'.
		aStream nextPutAll: ' source="'; nextPutAll: (self encode: rule class name); nextPut: $".
		aStream nextPutAll: ' message="'; nextPutAll: (self encode: rule group); nextPutAll: ' - '; nextPutAll: (self encode: rule name); nextPut: $".
		aStream nextPutAll: ' severity="'; nextPutAll: (rule
			severity = #information 
				ifTrue: [ 'info' ]
				ifFalse: [ 
					rule severity = #warning
						ifTrue: [ 'warning' ]
						ifFalse: [ 'error' ] ]); nextPut: $".
		aStream nextPutAll: ' line="'; print: aPoint x + start x; nextPut: $".
		aPoint y + start y - 1 <= 1
			ifFalse: [ aStream nextPutAll: ' column="'; print: aPoint y + start y - 1; nextPut: $" ].
		aStream nextPutAll: '/>'; nextPut: Character lf ]! !

!HDLintReport methodsFor: 'testing' stamp: ''!
isSelectorEnvironment: anEnvironment
	^ #(SelectorEnvironment ParseTreeEnvironment VariableEnvironment) includes: anEnvironment class name! !

!HDLintReport methodsFor: 'testing' stamp: ''!
isClassEnvironment: anEnvironment
	^ #(CategoryEnvironment ClassEnvironment VariableEnvironment) includes: anEnvironment class name! !

!HDLintReport methodsFor: 'generating' stamp: ''!
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: ''!
generateClass: aClass source: sourceStream on: aStream
	| offset source matching |
	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: ''!
generateClass: aClass on: aStream
	| sourceStream sourceName |
	sourceStream := WriteStream on: String new.
	sourceName := environment label , '-' , aClass name , '.st'.
	aStream tab; nextPutAll: '<file name="'; nextPutAll: (self encode: sourceName); nextPutAll: '">'; nextPut: Character lf.
	self generateClass: aClass source: sourceStream on: aStream.
	self generateClass: aClass class source: sourceStream on: aStream.
	aStream tab; nextPutAll: '</file>'; nextPut: Character lf.
	sourceName asFileReference ensureDelete writeStreamDo: [ :stream | 
		stream nextPutAll: sourceStream contents ]! !

!HDLintReport methodsFor: 'private' stamp: ''!
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 methodsFor: 'running' stamp: ''!
run
	RBSmalllintChecker 
		runRule: (RBCompositeLintRule rules: rules)
		onEnvironment: environment.
		
	(environment label , '-Lint.xml') asFileReference ensureDelete writeStreamDo: [ :stream|
		 self generateOn: stream ]! !

!HDLintReport methodsFor: 'initialization' stamp: ''!
initializeOn: anEnvironment
	environment := anEnvironment.
	rules := (RBCompositeLintRule rulesFor: RBBasicLintRule)
		reject: [ :each | each class name endsWith: 'SpellingRule' ]! !

!HDLintReport methodsFor: 'generating' stamp: ''!
generateOn: aStream
	aStream nextPutAll: '<?xml version="1.0" encoding="UTF-8"?>'; nextPut: Character lf.
	aStream nextPutAll: '<checkstyle version="5.2">'; nextPut: Character lf.
	(environment allClasses asSortedCollection: [ :a :b | a name <= b name ])
		do: [ :class | self generateClass: class on: aStream ].
	aStream nextPutAll: '</checkstyle>'! !

!HDLintReport methodsFor: 'accessing' stamp: ''!
rules
	^rules! !

!HDLintReport class methodsFor: 'running' stamp: ''!
runEnvironment: anEnvironment
	^ self new 
		initializeOn: anEnvironment; 
		run! !

!HDLintReport class methodsFor: 'running' stamp: ''!
runClasses: aCollectionOfClasses named: aString
	| classEnvironment |
	classEnvironment := RBBrowserEnvironment new
		forClasses: aCollectionOfClasses.
	classEnvironment label: aString.
	^ self runEnvironment: classEnvironment! !

!HDLintReport class methodsFor: 'running' stamp: ''!
runPackage: aString
	| packageEnvironment |
	packageEnvironment := RBBrowserEnvironment new
		forPackageNames: (Array with: aString).
	packageEnvironment label: aString.
	^ self runEnvironment: packageEnvironment! !

!HDReport commentStamp: ''!
A Hudson report!
!HDReport methodsFor: 'private' stamp: ''!
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: ''!
encode: aString
	^ ((aString asString 
		copyReplaceAll: '&' with: '&amp;') 
		copyReplaceAll: '"' with: '&quot;') 
		copyReplaceAll: '<' with: '&lt;'! !

!HDReport class methodsFor: 'running' stamp: ''!
runCategories: aCollectionOfStrings
	^ aCollectionOfStrings do: [ :each | self runCategory: each ]! !

!HDReport class methodsFor: 'running' stamp: ''!
runCategory: aString
	^ self runClasses: (Smalltalk organization classesInCategory: aString) named: aString! !

!HDReport class methodsFor: 'running' stamp: ''!
runPackages: aCollectionOfStrings
	^ aCollectionOfStrings collect: [ :each | self runPackage: each ]! !

!HDReport class methodsFor: 'running' stamp: ''!
runClasses: aCollectionOfClasses named: aString
	self subclassResponsibility! !

!HDReport class methodsFor: 'running' stamp: ''!
runPackage: aString
	self subclassResponsibility! !

!HDTestCoverage commentStamp: ''!
Used to measure test coverage for Hudson reports. It uses methods-as-objects approach.

You may use it do find methods that are not called in your package with code like this:

```language=Pharo&caption=Beautiful
| methods wrappers |
methods := 'My Package' asPackage methods.
wrappers := methods collect: [ :each | HDTestCoverage on: each ].
wrappers do: [ :each | each install ].

"open the application here"
	
wrappers do: [ :each | each uninstall ].
wrappers := wrappers reject: [:each | each hasRun].
(wrappers collect: [:each | each reference]) inspect.
```
!
!HDTestCoverage methodsFor: 'private' stamp: ''!
doesNotUnderstand: aMessage
	^ method perform: aMessage selector withArguments: aMessage arguments! !

!HDTestCoverage methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!HDTestCoverage methodsFor: 'testing' stamp: ''!
hasRun
	^ hasRun! !

!HDTestCoverage methodsFor: 'actions' stamp: ''!
install
	reference methodClass methodDict
		at: reference selector
		put: self.! !

!HDTestCoverage methodsFor: 'private' stamp: ''!
mark
	hasRun := true! !

!HDTestCoverage methodsFor: 'evaluation' stamp: ''!
run: aSelector with: anArray in: aReceiver
	self mark; uninstall.
	^ aReceiver withArgs: anArray executeMethod: method! !

!HDTestCoverage methodsFor: 'accessing' stamp: ''!
reference
	^ reference! !

!HDTestCoverage methodsFor: 'initialization' stamp: ''!
initializeOn: aMethodReference
	hasRun := false.
	reference := aMethodReference.
	method := reference compiledMethod! !

!HDTestCoverage methodsFor: 'actions' stamp: ''!
uninstall
	reference methodClass methodDict
		at: reference selector
		put: method.! !

!HDTestCoverage class methodsFor: 'instance creation' stamp: ''!
on: aMethodReference
	^ self new initializeOn: aMethodReference! !

!HDTestReport commentStamp: ''!
Hudson report for test results!
!HDTestReport methodsFor: 'accessing' stamp: ''!
suiteTotal
	^ suite 
		ifNotNil: [ suite tests size ]
		ifNil: [ 0 ]! !

!HDTestReport methodsFor: 'private' stamp: ''!
writeException: anException of: aTestCase asNode: errorNodeName

	self  
		writeException: anException 
		asNode: errorNodeName 
		using: [ 	self writeExceptionStack: anException of: aTestCase ]! !

!HDTestReport methodsFor: 'running' stamp: ''!
runSuite: aTestSuite
	^ self
		initializeOn: aTestSuite;
		run;
		done! !

!HDTestReport methodsFor: 'testing' stamp: ''!
hasErrors 
	^ suiteErrors ~= 0! !

!HDTestReport methodsFor: 'initialization' stamp: ''!
openProgressStream 
	
	| aFile |
	aFile := File named: progressFileName.
	aFile delete.
	progressStream := ZnCharacterWriteStream
			on: (aFile writeStream setToEnd; yourself)
			encoding: 'utf8'! !

!HDTestReport methodsFor: 'private' stamp: ''!
writeError: anError of: aTestCase

	self writeException: anError of: aTestCase asNode: 'error'! !

!HDTestReport methodsFor: 'private' stamp: ''!
newLogDuring: aBlock

	| currentStream tempStream |
	currentStream := stream.
	stream := tempStream := String new writeStream.
	aBlock ensure: [ stream := currentStream ].
	^tempStream contents! !

!HDTestReport methodsFor: 'private' stamp: ''!
writeFailure: aTestFailure of: aTestCase

	self writeException: aTestFailure of: aTestCase asNode: 'failure'! !

!HDTestReport methodsFor: 'running' stamp: ''!
recordUnexpectedPassOf: aTestCase
	suiteFailures := suiteFailures + 1.
	
	self 
		writeException: (TestFailure new messageText: 'Unexpected pass (test is marked as expected failure)') 
		asNode: 'failure'
		using: [  ]! !

!HDTestReport methodsFor: 'testing' stamp: ''!
hasFailures 
	^ suiteFailures ~= 0! !

!HDTestReport methodsFor: 'running' stamp: ''!
recordError: anError duringTest: aTestCase 

	aTestCase shouldPass ifFalse: [ ^self ].
	suiteErrors := suiteErrors + 1.
				
	self writeError: anError of: aTestCase.
	self serializeError: anError of: aTestCase.! !

!HDTestReport methodsFor: 'private' stamp: ''!
generateTestName: aTestCase
	^ nodeName , (aTestCase class category copyReplaceAll: '-' with: '.')! !

!HDTestReport methodsFor: 'running' stamp: ''!
recordPassOf: aTestCase! !

!HDTestReport methodsFor: 'running' stamp: ''!
run
	Author uniqueInstance
		ifUnknownAuthorUse: 'hudson'
		during: [ [ 
			self setUp.
			suiteTime := [ self runAll ]
				timeToRun ]
					ensure: [ self tearDown ] ]! !

!HDTestReport methodsFor: 'accessing' stamp: ''!
stageName: anObject
	stageName := anObject! !

!HDTestReport methodsFor: 'private' stamp: ''!
calculateNodeName
	| environmentClass name bitString |
	bitString := Smalltalk vm is32bit
		ifTrue: [ '32' ]
		ifFalse: [ '64' ].

	name := Smalltalk os family , bitString , '.'.

	"The Stage name has kernel in the name when running the tests in the small image.
	We need to keep record of that"
	(self stageName includesSubstring: 'Kernel')
		ifTrue: [name := name , '.Kernel' ].

	" If the environment class is not available, because it needs FFI, I use the node name,
	because for sure I am in the Bootstrap process."
	environmentClass := Smalltalk at: #OSEnvironment ifAbsent: [ ^ name ].

	^ environmentClass current
		at: 'JENKINS_HOME'
		ifPresent: [ :value | name ]
		ifAbsent: [ '' ]! !

!HDTestReport methodsFor: 'accessing' stamp: ''!
suitePassing 
	^ self suiteTotal - self suiteFailures - self suiteErrors! !

!HDTestReport methodsFor: 'running' stamp: ''!
setUp

	| aFile |
	self openProgressStream.
	progressStream nextPutAll: 'running suite: ';
		nextPutAll: suite name ; crlf; flush.

	fileName := stageName isEmpty ifTrue: [ '' ] ifFalse: [ stageName , '-' ].
	fileName := fileName , suite name , '-Test.xml'.
	aFile := File named: fileName .
	aFile delete.
	stream := ZnCharacterWriteStream
			on: (aFile writeStream setToEnd; yourself)
			encoding: 'utf8'.	
		
	stream nextPutAll: '<?xml version="1.0" encoding="UTF-8"?>'; lf.
	stream
		nextPutAll: '<testsuite ';
		nextPutAll: 'name="'; nextPutAll: (self encode: suite name); nextPutAll: '" ';
		nextPutAll: 'tests="'; print: suite tests size; nextPutAll: '" ';
		nextPutAll: 'timestamp="'; print: Time now; nextPutAll: '" ';
		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 wrappedStream position - 1.
	stream nextPutAll: (String new: 100 withAll: $ ); lf.
	
	"Initialize the test resources."
	suite resources do: [ :each |
		each isAvailable
			ifFalse: [ each signalInitializationError ] ]! !

!HDTestReport methodsFor: 'accessing' stamp: ''!
progressFileName
	^ progressFileName! !

!HDTestReport methodsFor: 'accessing' stamp: ''!
shouldSerializeError: aBoolean
	shouldSerializeError := aBoolean.! !

!HDTestReport methodsFor: 'running' stamp: ''!
tearDown
	suite resources 
		do: [ :each | each reset ].
		
	stream tab; nextPutAll: '<system-out><!![CDATA[]]></system-out>'; lf.
	stream tab; nextPutAll: '<system-err><!![CDATA[]]></system-err>'; lf.
	stream nextPutAll: '</testsuite>'.
	
	stream wrappedStream position: suitePosition.
	stream 
		nextPutAll: ' failures="'; print: suiteFailures; 
		nextPutAll: '" errors="'; print: suiteErrors; 
		nextPutAll: '" time="'; print: suiteTime asMilliSeconds / 1000.0; 
		nextPutAll: '">'.
	stream close.
	
	progressStream 
		nextPutAll: 'finished running suite: ';
		nextPutAll: suite name;
		close! !

!HDTestReport methodsFor: 'running' stamp: ''!
done
	"just close the file"
	[ progressStream close ] on: Error do: []! !

!HDTestReport methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	shouldSerializeError := true.
	suiteTime := 0 asDuration.
	suitePosition := suiteFailures := suiteErrors := 0.
	progressFileName := 'progress.log'.
	stageName := self class currentStageName.
	nodeName := self calculateNodeName.
	! !

!HDTestReport methodsFor: 'running' stamp: ''!
serializeError: error of: aTestCase

	"We got an error from a test, let's serialize it so we can properly debug it later on..."

	| fuelFileName |
	
	self shouldSerializeError ifFalse: [ ^ self ].
	
	self class environment
		at: #FLDebuggerStackSerializer
		ifPresent: [ :fuelOutStackDebugAction | 
			| context testCaseMethodContext |
			context := error signalerContext.
			testCaseMethodContext := context findContextSuchThat: [ :ctx | 
				                         ctx receiver == aTestCase and: [ 
					                         ctx methodSelector == #performTest ] ].
			context := context copyTo: testCaseMethodContext.

			fuelFileName := fileName copyReplaceAll: '.xml' with: ('-' , aTestCase class name asString , '-',  aTestCase selector asString , '.fuel').

			[ fuelOutStackDebugAction 
					serializeStackFromContext: context sender 
					toFileNamed: fuelFileName ]
				on: Error
				do: [ :err | Stdio stderr << err messageText; crlf; flush ] ]! !

!HDTestReport methodsFor: 'running' stamp: ''!
recordFailure: aTestFailure duringTest: aTestCase 

	aTestCase shouldPass ifFalse: [ ^self ].
	suiteFailures := suiteFailures + 1.	
			
	self writeFailure: aTestFailure of: aTestCase.
	self serializeError: aTestFailure of: aTestCase.! !

!HDTestReport methodsFor: 'testing' stamp: ''!
hasFailuresOrErrors 
	^ self hasFailures or: [ self hasErrors ]! !

!HDTestReport methodsFor: 'running' stamp: ''!
runCase: aTestCase
	self
		reportTestCase: aTestCase
		runBlock: [ 
			[aTestCase runCaseManaged.
			aTestCase shouldPass 
				ifTrue: [ self recordPassOf: aTestCase ]
				ifFalse: [ self recordUnexpectedPassOf: aTestCase ]
			] on: Exception do: [ :exc | 
					exc recordResultOf: aTestCase inHDTestReport: self ]
		]! !

!HDTestReport methodsFor: 'accessing' stamp: ''!
stageName
	"The stage name is used by the CI to name the report files"
	^ stageName! !

!HDTestReport methodsFor: 'accessing' stamp: ''!
suiteErrors
	^ suiteErrors! !

!HDTestReport methodsFor: 'private' stamp: ''!
writeException: anException asNode: errorNodeName using: writeBlock
	| encodedErrorName encodedErrorDescription |
	stream tab; tab; nextPutAll: '<' ; nextPutAll: errorNodeName; nextPutAll: ' type="'.
	encodedErrorName := self encode: anException class name.
	encodedErrorDescription := self
		encode: (anException messageText ifNil: [ anException description ]).
	stream
		nextPutAll: encodedErrorName;
		nextPutAll: '" message="'; 	nextPutAll: encodedErrorDescription; nextPutAll: '">';
		lf; nextPutAll: encodedErrorName;	lf.
	encodedErrorDescription ifNotEmpty: [ 
		stream nextPutAll: encodedErrorDescription;
		lf ].
	writeBlock value.
	stream tab; tab; nextPutAll: '</'; nextPutAll: errorNodeName; nextPutAll: '>'; lf! !

!HDTestReport methodsFor: 'accessing' stamp: ''!
shouldSerializeError
	^ shouldSerializeError! !

!HDTestReport methodsFor: 'accessing' stamp: ''!
progressFileName: anObject
	progressFileName := anObject! !

!HDTestReport methodsFor: 'running' stamp: ''!
recordSkip: aTestSkip duringTest: aTestCase! !

!HDTestReport methodsFor: 'private' stamp: ''!
reportTestCase: aTestCase runBlock: aBlock
	| time testLog |
	progressStream
		nextPutAll: 'starting testcase: ';
		nextPutAll: aTestCase class name;
		nextPutAll: '>>';
		nextPutAll: aTestCase nameForReport;
		nextPutAll: ' ... ';
		flush.
	"The test element must be written after test completion to include a time information about run.
	Therefore we can't report any error during test directly into the main xml stream.
	Otherwise any new xml element would be written out of the test node.
	To allow reporting during test we set a temp log stream 
	which we append to the main stream at the end of test as part of test element"
	testLog := self newLogDuring: [ time := aBlock timeToRun ].
	stream
		tab; nextPutAll: '<testcase classname="';
		nextPutAll: (self encode: (self generateTestName: aTestCase));
		nextPut: $.;
		nextPutAll: (self encode: aTestCase class name);
		nextPutAll: '" name="';
		nextPutAll: (self encode: aTestCase nameForReport);
		nextPutAll: '" time="';
		print: time asMilliSeconds / 1000.0;
		nextPutAll: '">';
		lf.
	stream nextPutAll: testLog.
	stream tab; nextPutAll: '</testcase>'; lf.
	progressStream nextPutAll: 'finished' ; crlf; flush! !

!HDTestReport methodsFor: 'private' stamp: ''!
writeExceptionStack: anException of: aTestCase
	| context |
	context := anException signalerContext.
	[ context isNil or: [ context receiver == aTestCase and: [ context methodSelector == #runCase ]]]
		whileFalse: [
			[ stream nextPutAll: (self encode: context printString); lf ] 
				onErrorDo: [ stream nextPutAll: 'PRINTING ERROR'; lf].
			context := context sender ]! !

!HDTestReport methodsFor: 'accessing' stamp: ''!
suiteFailures
	^ suiteFailures! !

!HDTestReport methodsFor: 'initialization' stamp: ''!
initializeOn: aTestSuite
	suite := aTestSuite! !

!HDTestReport methodsFor: 'running' stamp: ''!
runAll
	CurrentExecutionEnvironment runTestsBy: [ 
		suite tests do: [ :each | each run: self ]
	]! !

!HDTestReport methodsFor: 'private' stamp: ''!
stackTraceString: err of: aTestCase
	^ self newLogDuring: [ self writeExceptionStack: err of: aTestCase ]! !

!HDTestReport class methodsFor: 'running' stamp: ''!
currentStageName: aStageName
	CurrentStageName := aStageName! !

!HDTestReport class methodsFor: 'running' stamp: ''!
currentStageName
	^CurrentStageName ifNil: [ '' ]! !

!HDTestReport class methodsFor: 'running' stamp: ''!
runClasses: aCollectionOfClasses named: aString
	| suite classes |
	suite := TestSuite named: aString.
	classes := (aCollectionOfClasses
		select: [ :each | (each includesBehavior: TestCase) and: [ each isAbstract not ] ])
			asSortedCollection: [ :a :b | a name <= b name ].
	classes isEmpty
		ifTrue: [ ^ nil ].
		
	classes
		do: [ :each | suite addTests: each buildSuite tests ].
	^ self runSuite: suite! !

!HDTestReport class methodsFor: 'running' stamp: ''!
runPackage: aString
	^ self runClasses: (RPackage organizer packageNamed: aString) definedClasses named: aString! !

!HDTestReport class methodsFor: 'running' stamp: ''!
runSuite: aTestSuite
	^ self new
		runSuite: aTestSuite! !

!HEAbstractExported commentStamp: ''!
Hermes Files contains one or more exported elements in it.
Each exported element is a subclass of myself.

I basically implements the logic to compare two elements
The comparison and the hash code is implemented using the instance variables in the objects.

In my class side I have the method #readFrom: aHermesStream
that is used to read any of my subclasses.
Each of my subclasses knows how to read itself from the stream.!
!HEAbstractExported methodsFor: 'comparing' stamp: ''!
instVarNamesForEqualityComparison
	"By default all the instance variables are used in the comparison and in the hash calculation"
	^ self class allInstVarNames! !

!HEAbstractExported methodsFor: 'comparing' stamp: ''!
= anObject
	"The comparison is implemented using a set of my instance variables.
	Each subclass has the responsibility to tell the instance variables to use."
	self species = anObject species
		ifFalse: [ ^ false ].
	^ self valuesToCompareForEquality = anObject valuesToCompareForEquality! !

!HEAbstractExported methodsFor: 'comparing' stamp: ''!
hash
	"The hash is calculated with the instance variable used for comparison"
	^ self valuesToCompareForEquality
		inject: self species hash
		into: [ :hash :comparisonValue | (hash bitXor: comparisonValue hash) hashMultiply ]! !

!HEAbstractExported methodsFor: 'comparing' stamp: ''!
valuesToCompareForEquality
	"By default all the instance variables are used in the comparison and in the hash calculation"
	^ self instVarNamesForEqualityComparison collect: [ :ivName | self instVarNamed: ivName ]! !

!HEAbstractExported class methodsFor: 'instance creation' stamp: ''!
readFrom: aReader
	^ self new
		readFrom: aReader;
		yourself! !

!HEAdditionalMethodState commentStamp: ''!
I represent an AdditionMethodState.
I serialize myself into a stream with the following fields:

    - method
    - selector
    - an array containing all the elements in the original additional method state.

Each of this elements is exported as a HEExportedLiteral.
My value contains the array of elements in the AdditionalMethodState.!
!HEAdditionalMethodState methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	"When the literal is deserialized in the environment, the method is the actual method that is currently deserialized (this #newMethod message)."
	| additionalMethodState |
	additionalMethodState := AdditionalMethodState new: value value size.
	additionalMethodState method: env newMethod.
	additionalMethodState selector: (selector asLiteralIn: env).

	value value withIndexDo: [ :e :idx | additionalMethodState basicAt: idx put: (e asLiteralIn: env) ].
	^ additionalMethodState! !

!HEAdditionalMethodState methodsFor: 'accessing' stamp: ''!
value: anAdditionalMethodState
	"I extract the information from the additional method state and convert it to exported literals."
	method := anAdditionalMethodState method asExportedLiteral.
	selector := anAdditionalMethodState selector asExportedLiteral.

	value := Array new: anAdditionalMethodState size.
	1 to: anAdditionalMethodState size do: [ :idx | value at: idx put: (anAdditionalMethodState basicAt: idx) ].
	value := value asExportedLiteral! !

!HEAdditionalMethodState methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	method := HEExportedLiteral readFrom: aReader.
	selector := HEExportedLiteral readFrom: aReader.
	value := HEExportedLiteral readFrom: aReader.! !

!HEAdditionalMethodState class methodsFor: 'accessing' stamp: ''!
tag
	^ 1.! !

!HEArray commentStamp: ''!
I represent an instance of an Array
My value instance variable has an array in it. 
Each of the values of the original array is transformed in a HEExportedLiteral. 
When writing to the stream the array is written in the following way:

1. The size of the array is written as a 32bits integer.
2. Each of the literals is written.

This allows us to export any kind of array, if it is limited to a size of 32 bits integer.

The reading is perform in the inverse order!
!HEArray methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	"A new array is returned with all its elements as target literals in the environment"
	^ value collect: [ :e | e asLiteralIn: env ]! !

!HEArray methodsFor: 'accessing' stamp: ''!
value: anArray
	value := anArray collect: [:each | each asExportedLiteral]! !

!HEArray methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	| size | 
	"The size of the array is stored as a 32bits integer. Before any of the elements"
	size := aReader readInt32.
	value := Array new:size.
	
	1 to:size do:[:idx | value at:idx put: (HEExportedLiteral readFrom: aReader)].! !

!HEArray class methodsFor: 'accessing' stamp: ''!
tag
	^ 2.! !

!HEAssociation commentStamp: ''!
I am simple representation of an association.
I store both values, the key and the value.
The key and the value are transformed as HEExportedLiterals.
When writing or reading, the key is before of the value.!
!HEAssociation methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ (key asLiteralIn: env) -> (value asLiteralIn: env)! !

!HEAssociation methodsFor: 'accessing' stamp: ''!
value: anAssociation
	value := anAssociation value asExportedLiteral.
	key := anAssociation key asExportedLiteral.! !

!HEAssociation methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	key := HEExportedLiteral readFrom: aReader.
	value := HEExportedLiteral readFrom: aReader.! !

!HEAssociation class methodsFor: 'accessing' stamp: ''!
tag
	^ 12! !

!HEBinaryReader commentStamp: ''!
I wrap a binary stream implementing helping methods to read basic types:

 - Byte
 - Int32
 - ByteArray
 - ByteString
 - ByteSymbol
 - Unsigned Int32

The format is platform independent. It uses always 4 bytes per integer (32 bits).
In this way the format can be used in any platform and architecture.

The integers are stored in little endian style.!
!HEBinaryReader methodsFor: 'reading' stamp: ''!
readByte
	^ stream next! !

!HEBinaryReader methodsFor: 'accessing' stamp: ''!
stream: anObject
	stream := anObject! !

!HEBinaryReader methodsFor: 'reading' stamp: ''!
readByteArray
	| byteArray size |
	size := self readInt32. 
	byteArray := stream next: size.
	^ byteArray! !

!HEBinaryReader methodsFor: 'reading' stamp: ''!
readByteString
	^ self readByteArray asString! !

!HEBinaryReader methodsFor: 'reading' stamp: ''!
readByteSymbol
	^ self readByteString asSymbol! !

!HEBinaryReader methodsFor: 'initialization' stamp: ''!
close
	self stream close.! !

!HEBinaryReader methodsFor: 'reading' stamp: ''!
readUInt32
	| byteArray n |
	byteArray := stream next: self intSize.
	n := byteArray at: 4.
	n := (n bitShift: 8) + (byteArray at: 3).
	n := (n bitShift: 8) + (byteArray at: 2).
	n := (n bitShift: 8) + (byteArray at: 1).
	^ n! !

!HEBinaryReader methodsFor: 'accessing' stamp: ''!
stream
	^ stream! !

!HEBinaryReader methodsFor: 'reading' stamp: ''!
readInt32
	| byteArray n |
	byteArray := stream next: self intSize.
	n := byteArray at: 4.
	n := (n bitShift: 8) + (byteArray at: 3).
	n := (n bitShift: 8) + (byteArray at: 2).
	n := (n bitShift: 8) + (byteArray at: 1).
	(byteArray at: 4) >= 128
		ifTrue: [ n := -16r100000000 + n ].
	^ n! !

!HEBinaryReader methodsFor: 'sizes' stamp: ''!
intSize
	^ 4! !

!HEBoolean commentStamp: ''!
I represent a boolean.
I am stored in the file as a byte with values 0 (false) and 1 (true).!
!HEBoolean methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ value! !

!HEBoolean methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	value := aReader readByte = 1! !

!HEBoolean class methodsFor: 'accessing' stamp: ''!
tag
	^ 17! !

!HEByteArray commentStamp: ''!
I represent a byteArray. 
The Hermes streams knows how to store byte arrays. 
I only use them.!
!HEByteArray methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ value! !

!HEByteArray methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	value := aReader readByteArray.! !

!HEByteArray class methodsFor: 'accessing' stamp: ''!
tag
	^ 15! !

!HEByteString commentStamp: ''!
I represent a byte string.
Readers and writers knows how to handle byte strings.
I just use them and I provide an entry point to my subclasses to convert the readed value.!
!HEByteString methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ value! !

!HEByteString methodsFor: 'reading' stamp: ''!
doConvertValue: aValue
	"My subclasses are able to do something else to convert the readed value"
	^ aValue.! !

!HEByteString methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	value := self doConvertValue:(aReader readByteString).! !

!HEByteString class methodsFor: 'accessing' stamp: ''!
tag
	^ 4.! !

!HECharacter commentStamp: ''!
I represent a character.
I serialize myself as a String of a single character.
When I am readed back I just read the first character of the value.
My value is always a String!
!HECharacter methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ value at:1! !

!HECharacter methodsFor: 'accessing' stamp: ''!
value: aValue
	value := aValue asString.! !

!HECharacter class methodsFor: 'accessing' stamp: ''!
tag
	^ 5.! !

!HEClass commentStamp: ''!
I implement all the behavior to export a class.

My header includes:

	className
	superclass
	instanceVariables
	classInstancevariables
	classVariables
	sharedPools
	layoutClass
	
All exported as ByteStrings (and symbols).
I do not support exporting special slots (yet).!
!HEClass methodsFor: 'accessing' stamp: ''!
classVariables: anObject
	classVariables := anObject! !

!HEClass methodsFor: 'accessing' stamp: ''!
isTrait
	^ false! !

!HEClass methodsFor: 'accessing' stamp: ''!
classInstancevariables: anObject
	classInstancevariables := anObject! !

!HEClass methodsFor: 'accessing' stamp: ''!
sharedPools: anObject
	sharedPools := anObject! !

!HEClass methodsFor: 'accessing' stamp: ''!
className: anObject
	className := anObject! !

!HEClass methodsFor: 'accessing' stamp: ''!
classInstancevariables
	^ classInstancevariables! !

!HEClass methodsFor: 'accessing' stamp: ''!
classVariables
	^ classVariables! !

!HEClass methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: 'HEClass ( ';
		print: className;
		nextPutAll: ' )'! !

!HEClass methodsFor: 'accessing' stamp: ''!
instanceVariables
	^ instanceVariables! !

!HEClass methodsFor: 'accessing' stamp: ''!
superclass
	^ superclass ifEmpty: [nil]! !

!HEClass methodsFor: 'accessing' stamp: ''!
instanceVariables: anObject
	instanceVariables := anObject! !

!HEClass methodsFor: 'accessing' stamp: ''!
layoutClass
	^ layoutClass! !

!HEClass methodsFor: 'accessing' stamp: ''!
layoutClass: anObject
	layoutClass := anObject! !

!HEClass methodsFor: 'accessing' stamp: ''!
sharedPools
	^ sharedPools! !

!HEClass methodsFor: 'accessing' stamp: ''!
superclass: anObject
	superclass := anObject! !

!HEClass methodsFor: 'initialization' stamp: ''!
className
	^ className! !

!HEClass methodsFor: 'reading' stamp: ''!
doReadHeaderFrom: aReader
	className := aReader readByteSymbol.
	superclass := aReader readByteSymbol.
	instanceVariables := aReader readByteString.
	classInstancevariables := aReader readByteString.
	classVariables := aReader readByteString.
	sharedPools := aReader readByteString.
	layoutClass := aReader readByteSymbol! !

!HEClassTrait commentStamp: ''!
I represent a ClassTrait.
I am stored as a symbol.

When serialized I get the name of the base trait.
When deserialized I find the classTrait in the target environment!
!HEClassTrait methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ (env classNamed: value) classTrait! !

!HEClassTrait methodsFor: 'accessing' stamp: ''!
value: aClassTrait
	value := aClassTrait instanceSide name.! !

!HEClassTrait class methodsFor: 'accessing' stamp: ''!
tag
	^ 22! !

!HEClassVariable commentStamp: ''!
I represent a ClassVariable.
I am stored as a symbol.

When serialized I get the name of the class variable
When deserialized I look up the class variable binding in the class that is being deserialized.!
!HEClassVariable methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	"I ask the binding to the class that is currently being deserialized"
	^ env newClass bindingOf: value! !

!HEClassVariable methodsFor: 'accessing' stamp: ''!
value: aClassVariable
	value := aClassVariable name.! !

!HEClassVariable class methodsFor: 'accessing' stamp: ''!
tag
	^ 6.! !

!HECompiledBlock methodsFor: 'accessing' stamp: ''!
value: aCompiledBlock
	
	| literalSpace |

	encoderClassName := self encoderClassName: aCompiledBlock.
	
	numArgs := aCompiledBlock numArgs.
	numTemps := aCompiledBlock numTemps.
	hasPrimitive := aCompiledBlock isPrimitive asBit.

	literalSpace := (aCompiledBlock numLiterals + 1) * Smalltalk wordSize.

	bytecode := ByteArray new: aCompiledBlock size - literalSpace.
	1 to: bytecode size do: [ :i | bytecode at: i put: (aCompiledBlock at: i + literalSpace) ].

	literals := aCompiledBlock allLiterals allButLast collect: [ :e | e asExportedLiteral ].
	"The last literal is the home method or block of this compiledBlock"
	literals := literals copyWith: nil asExportedLiteral.! !

!HECompiledBlock methodsFor: 'compiling' stamp: ''!
headerFor: anEnvironment
	| encoderClass|
	"When a method is deserialized its header should be recalculated"
	encoderClass := anEnvironment classNamed: encoderClassName.
	
	^ (CompiledMethod headerFlagForEncoder: encoderClass) + (numArgs bitShift: 24) + (numTemps bitShift: 18) + literals size + (hasPrimitive bitShift: 16)! !

!HECompiledBlock methodsFor: 'reading' stamp: ''!
doReadFrom: aReader

	| numberOfLiterals |

	encoderClassName := aReader readByteString.
	numArgs := aReader readUInt32.
	numTemps := aReader readUInt32.
	hasPrimitive := aReader readUInt32.

	bytecode := aReader readByteArray.

	numberOfLiterals := aReader readInt32.
	literals := Array new: numberOfLiterals.
	1 to: numberOfLiterals do: [ :idx | literals at:idx put: (HEExportedLiteral readFrom: aReader) ]! !

!HECompiledBlock methodsFor: 'reading' stamp: ''!
asLiteralIn: anEnvironment

	| containingBlockOrMethod newBlock literalSpace previousBlock|
	
	previousBlock := anEnvironment newBlock.
	containingBlockOrMethod := previousBlock ifNil: [ anEnvironment newMethod ].
	
	newBlock := CompiledBlock newMethod: bytecode size header: (self headerFor: anEnvironment).
	
	anEnvironment newBlock: newBlock.

	literals
		doWithIndex:
			[ :literal :idx | newBlock literalAt: idx put: (literal asLiteralIn: anEnvironment) ].

	newBlock literalAt: literals size put: containingBlockOrMethod.
	literalSpace := (literals size + 1) * Smalltalk wordSize.

 	bytecode doWithIndex: [ :e :idx | newBlock at: idx + literalSpace put: e ].

	anEnvironment newBlock: previousBlock.

	^ newBlock! !

!HECompiledBlock class methodsFor: 'accessing' stamp: ''!
tag

	^ 28! !

!HEDuplicationModeStrategy commentStamp: ''!
I am the abstract strategy to use when a duplication is produced loading a package.
My subclasses gives different options that can be set by a command line parameter.
Each subclass has a classSide message #keyword that identifies it self.
I look up the corresponding subclass to use.!
!HEDuplicationModeStrategy methodsFor: 'validating existence' stamp: ''!
existingTrait: aHETrait on: installer
	^ installer environment
		at: aHETrait traitName
		ifPresent: [ :aTrait | 
			self 
				doExistingTrait: aTrait 
				hermesTrait: aHETrait 
				installer: installer ]
		ifAbsent: [ nil ]! !

!HEDuplicationModeStrategy methodsFor: 'validating existence' stamp: ''!
doExistingClass: aClass hermesClass: aHEClass installer: installer
	self subclassResponsibility! !

!HEDuplicationModeStrategy methodsFor: 'validating existence' stamp: ''!
doExistingTrait: aTrait hermesTrait: aHETrait installer: installer
	self subclassResponsibility! !

!HEDuplicationModeStrategy methodsFor: 'validating existence' stamp: ''!
shouldBuildMethod: aHEMethod in: aClass installer: installer
	^ aClass
		compiledMethodAt: aHEMethod name
		ifPresent: [ :m | 
			(m isFromTrait and: [ aClass isTrait not ])
				ifTrue: [ ^ true ].
			self 
				doShouldBuildMethod: aHEMethod 
				in: installer 
				installer: aClass 
				original: m]
		ifAbsent: [ true ]! !

!HEDuplicationModeStrategy methodsFor: 'validating existence' stamp: ''!
doShouldBuildMethod: aHEMethod in: installer installer: aClass original: aMethod
	self subclassResponsibility! !

!HEDuplicationModeStrategy methodsFor: 'validating existence' stamp: ''!
existingClass: aHEClass on: installer
	^ installer environment
		at: aHEClass className
		ifPresent: [ :aClass | 
			self 
				doExistingClass: aClass 
				hermesClass: aHEClass 
				installer: installer  ]
		ifAbsent: [ nil ]! !

!HEDuplicationModeStrategy class methodsFor: 'instance creation' stamp: ''!
forOption: keyword
	^ (self allSubclasses
		detect: [ :e | e keyword = keyword ]
		ifNone: [ self error: 'There is no duplication strategy for ''' , keyword , '''' ]) new! !

!HEExportedLiteral commentStamp: ''!
I represent all the literals that a method and a trait composition can have.

My subclasses implements all the behavior for the different types of literals. 
All my subclasses has a #tag number. Each tag number should be unique. 
This number is written in the stream before of the content of the literal. 
In this way, the literal can be properly deserialized. 

By sure, playing with the tag numbers requires incrementing the version of the hermes files, 
as they do not keep compatibility if the numbers change.

For deserializing a literal I have a class side message called

#readFrom: aHermesStream

This message returns the correct instance representing the literal value.

Also I implement helping classSide methods to check the sanity of the tags, #checkAllTags and #missingTags

By default I have a value, but my subclasses can have more instance variables.

My subclasses implements the method 
#asLiteralIn: env
This method creates the proper literal in the given environment. Some of the literals are environment dependent,
for example the classes.!
!HEExportedLiteral methodsFor: 'accessing' stamp: ''!
value: anObject
	value := anObject! !

!HEExportedLiteral methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!HEExportedLiteral methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	"Main template method to read the instance from the reader stream"
	self subclassResponsibility.! !

!HEExportedLiteral methodsFor: 'converting' stamp: ''!
asExportedLiteral
	"I am already an exported literal, I do not need any conversion"
	^ self! !

!HEExportedLiteral class methodsFor: 'instance creation' stamp: ''!
readFrom: aReader
	| tag subclass |
	tag := aReader readByte.
	subclass := self allSubclasses detect: [ :e | e tag = tag ].
	^ subclass new
		doReadFrom: aReader;
		yourself! !

!HEExportedMetaclass commentStamp: ''!
I represent a Metaclass
I am stored as a symbol.

When serialized I get the name of the base class.
When deserialized I find the metaclass in the target environment!
!HEExportedMetaclass methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ (env classNamed: value) class! !

!HEExportedMetaclass methodsFor: 'accessing' stamp: ''!
value: aMetaclass
	value := aMetaclass instanceSide name.! !

!HEExportedMetaclass class methodsFor: 'accessing' stamp: ''!
tag
	^ 16! !

!HEExtendedEnvironment commentStamp: ''!
I wrap the target environment.
I provide access to all the elements in the environment and also to:

- The class being deserialized
- The method being deserialized
- The selector of the method being deserialized.!
!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
inner: anObject
	inner := anObject! !

!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
newMethod
	^ newMethod! !

!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
inner
	^ inner! !

!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
newBlock: anObject

	newBlock := anObject! !

!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
newClass: anObject
	newClass := anObject! !

!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
newBlock

	^ newBlock! !

!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
newSelector
	^ newSelector! !

!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
newMethod: anObject
	newMethod := anObject! !

!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
newClass
	^ newClass! !

!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
classNamed: aClassName
	^ newClass name = aClassName
		ifTrue: [ newClass ]
		ifFalse: [ inner classNamed: aClassName ]! !

!HEExtendedEnvironment methodsFor: 'accessing' stamp: ''!
newSelector: anObject
	newSelector := anObject! !

!HEExtendedInstaller commentStamp: ''!
The HEInstaller is really basic. 
It is designed that way to keep simple the bootstraped image. 
A bigger or complex bootstraped image requires more bootstrap time.

So, I am loaded later (with Hermes itself) and I extend the behavior in HEInstaller 

I add: 
 	- 	Having a duplication Strategy
	-	Having a configuration to fail on new undeclared variables.!
!HEExtendedInstaller methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	failOnUndeclared := true.
	duplicationMode := HEFailOnDuplication new.! !

!HEExtendedInstaller methodsFor: 'initialization' stamp: ''!
forOptions: aCommandLine
	failOnUndeclared := (aCommandLine hasOption: 'no-fail-on-undeclared') not.

	duplicationMode := HEDuplicationModeStrategy forOption: (aCommandLine optionAt: 'on-duplication' ifAbsent: [ 'fail' ]).! !

!HEExtendedInstaller methodsFor: 'reporting undeclared' stamp: ''!
reportNewUndeclareds: newUndeclareds
	| message |
	newUndeclareds
		ifNotEmpty: [ message := 'New Undeclared created... check dependencies: ', newUndeclareds keys printString.
			failOnUndeclared
				ifTrue: [ self error: message ]
				ifFalse: [ SystemNotification signal: message ] ]! !

!HEExtendedInstaller methodsFor: 'accessing' stamp: ''!
duplicationMode: anObject
	duplicationMode := anObject! !

!HEExtendedInstaller methodsFor: 'accessing' stamp: ''!
failOnUndeclared: anObject
	failOnUndeclared := anObject! !

!HEExtendedInstaller methodsFor: 'validating existence' stamp: ''!
shouldBuildMethod: aHEMethod in: aClass
	^ duplicationMode shouldBuildMethod: aHEMethod in: aClass installer: self.! !

!HEExtendedInstaller methodsFor: 'validating existence' stamp: ''!
existingTrait: aHETrait
	^ duplicationMode existingTrait: aHETrait on: self.! !

!HEExtendedInstaller methodsFor: 'validating existence' stamp: ''!
existingClass: aHEClass
	^ duplicationMode existingClass: aHEClass on: self.! !

!HEFailOnDuplication commentStamp: ''!
I implement the default behavior.
Producing an error if there is a duplication.!
!HEFailOnDuplication methodsFor: 'validating existence' stamp: ''!
doExistingClass: aClass hermesClass: aHEClass installer: installer
	^ self error: (installer messageExistingClass: aHEClass)! !

!HEFailOnDuplication methodsFor: 'validating existence' stamp: ''!
doExistingTrait: aTrait hermesTrait: aHETrait installer: installer
	^ self error: (installer messageExistingTrait: aHETrait)! !

!HEFailOnDuplication methodsFor: 'validating existence' stamp: ''!
doShouldBuildMethod: aHEMethod in: installer installer: aClass original: aMethod
	^ self error: (installer messageMethod: aHEMethod alreadyExistsIn: aClass)! !

!HEFailOnDuplication class methodsFor: 'accessing' stamp: ''!
keyword
	^ 'fail'! !

!HEFloat commentStamp: ''!
I represent a Float number
I am stored as two unsigned int32 numbers.
These numbers are got from the instance (Float >> #at:)
When readed back I always create a BoxedFloat. 
Then this instance is operated to generate the correct immediate instance if required.
This hack allows us to load the same hermes file in 32bits or 64 bits!
!HEFloat methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ value.! !

!HEFloat methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	| originalValue |
	originalValue := BoxedFloat64 new.
	originalValue at:1 put: (aReader readUInt32).
	originalValue at:2 put: (aReader readUInt32).
	
	"Force the conversion to SmallFloat64 or BoxedFloat64"
	value := originalValue - 0.0.! !

!HEFloat class methodsFor: 'accessing' stamp: ''!
tag
	^ 3.! !

!HEFraction commentStamp: ''!
I represent a Fraction.
I store myself as two exported literals: the numerator and the denominator.!
!HEFraction methodsFor: 'converting' stamp: ''!
asLiteralIn: aFraction
	^ value! !

!HEFraction methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	| denominator numerator |
	numerator := HEExportedLiteral readFrom: aReader.
	denominator := HEExportedLiteral readFrom: aReader.
	
	value := Fraction numerator: numerator value denominator: denominator value.! !

!HEFraction class methodsFor: 'accessing' stamp: ''!
tag 
	^ 24! !

!HEGlobalVariable commentStamp: ''!
I represent a Global variable.
I am stored as a symbol.

When serialized I get the name of the variable.
When deserialized I find the global variable in the target environment.
I use the class being created to look up the binding. If there is no binding I create an undeclared. !
!HEGlobalVariable methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	| bind |
	bind := env newClass bindingOf: value.
	
	bind ifNotNil: [ ^ bind ].
	
	^UndeclaredVariable registeredWithName: value! !

!HEGlobalVariable methodsFor: 'accessing' stamp: ''!
value: aClassVariable
	value := aClassVariable name.! !

!HEGlobalVariable class methodsFor: 'accessing' stamp: ''!
tag
	^ 7.! !

!HEIgnoreOnDuplication commentStamp: ''!
When there is a duplication, I do not do nothing. I keep the version already in the image!
!HEIgnoreOnDuplication methodsFor: 'validating existence' stamp: ''!
doExistingClass: aClass hermesClass: aHEClass installer: installer
	^ aClass! !

!HEIgnoreOnDuplication methodsFor: 'validating existence' stamp: ''!
doExistingTrait: aTrait hermesTrait: aHETrait installer: installer
	^ aTrait! !

!HEIgnoreOnDuplication methodsFor: 'validating existence' stamp: ''!
doShouldBuildMethod: aHEMethod in: installer installer: aClass original: aMethod
	^ false! !

!HEIgnoreOnDuplication class methodsFor: 'accessing' stamp: ''!
keyword
	^ 'ignore'! !

!HEInstaller commentStamp: ''!
I am the entry point to load a package of Hermes.

I am the basic implementation, I can only handle basic cases:
- If there is a new undeclared I produce an error.
- If there is an existing element I produce an error.

For more extended options check HEExtendedEnvironment

Example: 

	file := 'aFile.hermes'.
	installer := HEInstaller new.
	
	reader := HEBinaryReader new
		stream: (File named: file) readStream;
		yourself.

	readPackage := HEPackage readFrom: reader.

	installer installPackage: readPackage!
!HEInstaller methodsFor: 'creating classes' stamp: ''!
build: aHEClass
	| newClass superclass layoutType  |

	(self existingClass: aHEClass) ifNotNil: [ :x | ^ x ].

	superclass := self classNamed: aHEClass superclass.
	layoutType := self classNamed: aHEClass layoutClass.

	newClass := self class classInstaller make: [ :builder |
		builder name: aHEClass className;
		superclass: superclass;
		layoutClass: layoutType;
		slots: (self asSlots: aHEClass instanceVariables);
		sharedVariables:  (self asClassVariables:aHEClass classVariables);
		sharedPools: aHEClass sharedPools;
		category: aHEClass category;
		classSlots: (self asSlots: aHEClass classInstancevariables) ].
	
	self processTraitsFrom: aHEClass in: newClass.
	
	^newClass.! !

!HEInstaller methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!HEInstaller methodsFor: 'creating traits' stamp: ''!
buildTraitCompositionFor: traitComposition

	| aLiteral |
	
	aLiteral := (traitComposition asLiteralIn: environment).
	aLiteral isArray 
		ifTrue: [ ^ aLiteral 
							ifEmpty: [ self emptyTraitCompositionClass new ]
							ifNotEmpty: [ self traitSequenceClass withAll: (aLiteral collect: [:each | each asTraitComposition]) ]  ]
		ifFalse: [ ^ aLiteral asTraitComposition ]! !

!HEInstaller methodsFor: 'installing methods' stamp: ''!
rebuildMethod: aMethod into: aClass
	| newMethod literalSpace extendedEnvironment |
	
	(self shouldBuildMethod: aMethod in: aClass) ifFalse: [ ^ self ].	

	extendedEnvironment := HEExtendedEnvironment new.
	extendedEnvironment inner: environment.
	extendedEnvironment newClass: aClass.
	extendedEnvironment newSelector: aMethod name.

	newMethod := CompiledMethod newMethod: aMethod bytecode size header: (aMethod headerFor: extendedEnvironment).

	extendedEnvironment newMethod: newMethod.

	aMethod literals
		doWithIndex:
			[ :literal :idx | newMethod literalAt: idx put: (literal asLiteralIn: extendedEnvironment) ].

	newMethod classBinding: aClass binding.
	literalSpace := (aMethod literals size + 1) * Smalltalk wordSize.

	aMethod bytecode doWithIndex: [ :e :idx | newMethod at: idx + literalSpace put: e ].

	aClass
		addAndClassifySelector: aMethod name
		withMethod: newMethod
		inProtocol: aMethod protocol! !

!HEInstaller methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!HEInstaller methodsFor: 'accessing' stamp: ''!
classNamed: aSymbol
	aSymbol ifNil: [ ^ nil ].
	^ self environment at: aSymbol! !

!HEInstaller methodsFor: 'installing methods' stamp: ''!
installMethods: exportedClass into: aClass
	exportedClass methods do: [ :e | self rebuildMethod: e into: aClass ].
	exportedClass classSideMethods
		do:
			[ :e | self rebuildMethod: e into: aClass classSide ]! !

!HEInstaller methodsFor: 'messages' stamp: ''!
messageExistingClass: aHEClass
	^ 'The class ' , aHEClass className asString
		, ' already exists. Should not be overwritten'! !

!HEInstaller methodsFor: 'creating classes' stamp: ''!
processTraitsFrom: aHEClass in: newClass

	hasTraits ifFalse: [ ^ self ].

	newClass setTraitComposition: (self buildTraitCompositionFor: aHEClass traitComposition).
	newClass class setTraitComposition: (self buildTraitCompositionFor: aHEClass classTraitComposition).! !

!HEInstaller methodsFor: 'validating existence' stamp: ''!
existingTrait: aHETrait
	(environment includesKey: aHETrait traitName) ifTrue:[ 
		self error: (self messageExistingTrait: aHETrait)
	].
	
	^nil! !

!HEInstaller methodsFor: 'validating existence' stamp: ''!
existingClass: aHEClass
	(environment hasClassNamed: aHEClass className) ifTrue:[
		self error: (self messageExistingClass: aHEClass)
	].
	^ nil! !

!HEInstaller methodsFor: 'creating traits' stamp: ''!
buildTrait: aTraitDefinition
	| newTrait traitComposition traitClass|
	
	(self existingTrait: aTraitDefinition) ifNotNil: [:x | ^ x ].
	
	traitClass := Smalltalk globals at: #Trait ifAbsent: [ self error: 'Trait support is not installed' ].
	
	traitComposition := self buildTraitCompositionFor: aTraitDefinition traitComposition.	
	
	newTrait := traitClass
		named: aTraitDefinition traitName
		uses: traitComposition
		package: aTraitDefinition category
		env: environment.

	newTrait classTrait traitComposition: (self buildTraitCompositionFor: aTraitDefinition classTraitComposition).

	^ newTrait! !

!HEInstaller methodsFor: 'initialization' stamp: ''!
initialize
	environment := self class environment.
	originalUndeclareds := Undeclared copy.
	hasTraits := Smalltalk globals hasClassNamed: #Trait.! !

!HEInstaller methodsFor: 'reporting undeclared' stamp: ''!
createdUndeclared
	^ (Undeclared associations reject: [ :asoc | originalUndeclareds associations includes: asoc]) asDictionary! !

!HEInstaller methodsFor: 'messages' stamp: ''!
messageMethod: aHEMethod alreadyExistsIn: aClass
	^ 'The method ' , aHEMethod name asString , ' already exists in class ' , aClass name asString! !

!HEInstaller methodsFor: 'reporting undeclared' stamp: ''!
reportNewUndeclareds: newUndeclareds
	newUndeclareds ifNotEmpty: [ self error: 'New Undeclared created... check dependencies: ' , newUndeclareds keys printString ]! !

!HEInstaller methodsFor: 'converting' stamp: ''!
asClassVariables: aString
	| trimmed |
	trimmed := aString trimBoth.

	trimmed isEmpty
		ifTrue: [ ^ #() ].

	^ (trimmed substrings: ' ') collect: [:x | x asSymbol => ClassVariable]! !

!HEInstaller methodsFor: 'creating traits' stamp: ''!
traitSequenceClass

	^ Smalltalk at: #TaSequence ifAbsent: [ self error: 'Trait support has not been loaded' ]! !

!HEInstaller methodsFor: 'messages' stamp: ''!
messageExistingTrait: aHETrait
	^ 'The trait ' , aHETrait traitName asString
		, ' already exists. Should not be overwritten'! !

!HEInstaller methodsFor: 'converting' stamp: ''!
asSlots: aString
	| trimmed |
	trimmed := aString trimBoth.

	trimmed isEmpty
		ifTrue: [ ^ #() ].

	^ (trimmed splitOn: ' ') collect: [ :e | e asSymbol asSlot ] as: Array! !

!HEInstaller methodsFor: 'installing methods' stamp: ''!
installExtensionMethod: extensionMethod
	| aClass |
	aClass := self environment classNamed: extensionMethod className.
	
	aClass ifNil: [ self error: 'Required class named: ' , extensionMethod className, ' does not exists.' ].
	
	self rebuildMethod: extensionMethod into: aClass.! !

!HEInstaller methodsFor: 'creating traits' stamp: ''!
emptyTraitCompositionClass

	^ Smalltalk at: #TaEmptyComposition ifAbsent: [ self error: 'Trait support has not been loaded' ]! !

!HEInstaller methodsFor: 'installing package' stamp: ''!
installPackage: aHEPackage
	| storedAnnouncements |
	
	storedAnnouncements := SystemAnnouncer uniqueInstance suspendAllWhileStoring: [ self doInstallPackage: aHEPackage ].	
	storedAnnouncements do: [ :e | SystemAnnouncer uniqueInstance announce: e ].! !

!HEInstaller methodsFor: 'installing package' stamp: ''!
doInstallPackage: aHEPackage
	| newTraits newClasses |
	"Creating the package. It requires a number of steps.
	1. Register the package in the organizer."
	RPackageOrganizer default registerPackageNamed: aHEPackage packageName.

	"2. Install the traits"
	newTraits := aHEPackage traits collect: [ :exportedTrait | self buildTrait: exportedTrait ].

	"3. Install traits methods"
	aHEPackage traits with: newTraits do: [ :exportedTrait :newTrait | self installMethods: exportedTrait into: newTrait ].

	"4. Install classes"
	newClasses := aHEPackage classes
		collect: [ :exportedClass | self build: exportedClass ].

	"5. Install class methods"
	aHEPackage classes with: newClasses do: [ :exportedClass :newClass | self installMethods: exportedClass into: newClass ].

	"6. Install extension methods"
	aHEPackage extensionMethods do: [ :e | self installExtensionMethod: e ].
	
	"7. After all I validate if there are no new undeclared variables created in the environment.
	A new undeclared is a sign of an improper modularization."
	self validateNoNewUndeclared! !

!HEInstaller methodsFor: 'validating existence' stamp: ''!
shouldBuildMethod: aHEMethod in: aClass
	aClass
		compiledMethodAt: aHEMethod name
		ifPresent: [ :m | 
			(m isFromTrait and:[aClass isTrait not]) ifTrue:[ ^ true ].  	
			self error: (self messageMethod: aHEMethod alreadyExistsIn: aClass ) ]
		ifAbsent: [ ^ true ]! !

!HEInstaller methodsFor: 'reporting undeclared' stamp: ''!
validateNoNewUndeclared
	self reportNewUndeclareds: self createdUndeclared.
	
	SystemNotification signal: ('[Hermes] Remaining Undeclared variables in the system: '
		, Undeclared keys printString)! !

!HEInteger commentStamp: ''!
I represent an Integer.
I am stored as:
   - sign (1 for negative, 0 for possitive)
   - a byte array of the content.

This allows to serialize any given Integer in the image!
!HEInteger methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ value! !

!HEInteger methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	| anArray isNegative |
	isNegative := aReader readByte = 1.
	anArray := aReader readByteArray.

	value := anArray asInteger * (isNegative ifTrue: [-1] ifFalse: [1])! !

!HEInteger class methodsFor: 'accessing' stamp: ''!
tag
	^ 8! !

!HEMethod commentStamp: ''!
I represent a serialized method.

I store all the information needed to regenerate the method in the target image.
I store this information and all the bytecode as a byteArray.
Also I store all the literals that have been transformed to HEExportedLiteral's subclasses

I have:
   - the name
   - the class name
   - the protocol
   - the name of the encoderClass 
   - the number of arguments (useful not to parse the selector, in the target system).
   - the number of temporaries
   - if it is a primitive.
  - the bytecode
  - the literals.

Check the methods #readFrom: and #writeInto: for details of how it is written in the file.!
!HEMethod methodsFor: 'accessing' stamp: ''!
bytecode: anObject
	bytecode := anObject! !

!HEMethod methodsFor: 'accessing' stamp: ''!
bytecode
	^ bytecode! !

!HEMethod methodsFor: 'accessing' stamp: ''!
className: anObject
	className := anObject! !

!HEMethod methodsFor: 'compiling' stamp: ''!
headerFor: anEnvironment
	| encoderClass|
	"When a method is deserialized its header should be recalculated"
	encoderClass := anEnvironment classNamed: encoderClassName.
	
	^ (CompiledMethod headerFlagForEncoder: encoderClass) + (numArgs bitShift: 24) + (numTemps bitShift: 18) + literals size + (hasPrimitive bitShift: 16)! !

!HEMethod methodsFor: 'accessing' stamp: ''!
literals
	^ literals! !

!HEMethod methodsFor: 'accessing' stamp: ''!
literals: anObject
	literals := anObject! !

!HEMethod methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream
		nextPutAll: 'HEMethod ( ';
		print: name ;
		nextPutAll: ' )'! !

!HEMethod methodsFor: 'accessing' stamp: ''!
protocol
	^ protocol! !

!HEMethod methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!HEMethod methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!HEMethod methodsFor: 'accessing' stamp: ''!
protocol: anObject
	protocol := anObject! !

!HEMethod methodsFor: 'reading' stamp: ''!
readFrom: aReader
	| numberOfLiterals |

	name := aReader readByteSymbol.
	className := aReader readByteSymbol.
	protocol := aReader readByteSymbol.
		
	encoderClassName := aReader readByteString.
	numArgs := aReader readUInt32.
	numTemps := aReader readUInt32.
	hasPrimitive := aReader readUInt32.

	bytecode := aReader readByteArray.

	numberOfLiterals := aReader readInt32.
	literals := Array new: numberOfLiterals.
	1 to: numberOfLiterals do: [ :idx | literals at:idx put: (HEExportedLiteral readFrom: aReader) ]! !

!HEMethod methodsFor: 'accessing' stamp: ''!
className
	^ className! !

!HEMethodContainer commentStamp: ''!
I implement the common behavior between classes and traits.
I implement all the handling of methods (instance side and class side) and the trait compositions (instance side and class side).
The headers of a class and a trait are different. Each subclass implements this reading.!
!HEMethodContainer methodsFor: 'reading' stamp: ''!
doReadMethodsFrom: aReader
	| numberOfMethods numberOfClassMethods |
	"The category of a trait or a class is stored as a byteString."
	category := aReader readByteSymbol.
	"The methods are stored with the quantity before them. First the instance side and the the class side."
	numberOfMethods := aReader readInt32.

	methods := (1 to: numberOfMethods) collect: [ :i | HEMethod readFrom: aReader ] as: Array.
	numberOfClassMethods := aReader readInt32.

	classSideMethods := (1 to: numberOfClassMethods) collect: [ :i | HEMethod readFrom: aReader ] as: Array.

	"The trait composition are readed after."
	traitComposition := HEExportedLiteral readFrom: aReader.
	classTraitComposition := HEExportedLiteral readFrom: aReader! !

!HEMethodContainer methodsFor: 'accessing' stamp: ''!
classTraitComposition: anObject
	classTraitComposition := anObject! !

!HEMethodContainer methodsFor: 'accessing' stamp: ''!
classSideMethods
	^ classSideMethods! !

!HEMethodContainer methodsFor: 'accessing' stamp: ''!
methods: anObject
	methods := anObject! !

!HEMethodContainer methodsFor: 'accessing' stamp: ''!
category: anObject
	category := anObject! !

!HEMethodContainer methodsFor: 'accessing' stamp: ''!
category
	^ category! !

!HEMethodContainer methodsFor: 'accessing' stamp: ''!
classSideMethods: anObject
	classSideMethods := anObject! !

!HEMethodContainer methodsFor: 'accessing' stamp: ''!
traitComposition
	^ traitComposition! !

!HEMethodContainer methodsFor: 'accessing' stamp: ''!
methods
	^ methods! !

!HEMethodContainer methodsFor: 'reading' stamp: ''!
readFrom: aReader
	self doReadHeaderFrom: aReader.
	self doReadMethodsFrom: aReader! !

!HEMethodContainer methodsFor: 'accessing' stamp: ''!
classTraitComposition
	^ classTraitComposition! !

!HEMethodContainer methodsFor: 'accessing' stamp: ''!
traitComposition: anObject
	traitComposition := anObject! !

!HEMethodContainer methodsFor: 'reading' stamp: ''!
doReadHeaderFrom: aReader
	"The headers of a class and a trait are different. Each subclass implements this reading"
	self subclassResponsibility! !

!HEMethodLiteral commentStamp: ''!
I represent a Method stored as a literal.
I am stored as a className and a selector.
Both elements are stored as HEExportedLiterals.!
!HEMethodLiteral methodsFor: 'accessing' stamp: ''!
value: aMethod
	className := aMethod methodClass name.
	selector := aMethod selector.! !

!HEMethodLiteral methodsFor: 'accessing' stamp: ''!
className: anObject
	className := anObject! !

!HEMethodLiteral methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	className := aReader readByteSymbol.
	selector := aReader readByteSymbol.! !

!HEMethodLiteral methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ (env newClass name = className and: [ env newSelector = selector ])
		ifTrue: [ env newMethod ]
		ifFalse: [ (env classNamed: className) >> selector ]! !

!HEMethodLiteral methodsFor: 'introspection' stamp: ''!
className
	^ className! !

!HEMethodLiteral class methodsFor: 'accessing' stamp: ''!
tag
	^ 10.! !

!HEPackage commentStamp: ''!
Even though the format is intented to store any kind of objects as a root element.
This is the root element expected by the command line tool and the installer.

I represent an exported package.
I store in myself the version of Hermes used to export me. 
I also include: 
	- the package name as an exported symbol
	- the classes ordered by dependency
	- the traits ordered by dependency
	- the extension methods
	
I first load all the traits. 
Then the classes

Then the methods for all the classes and traits.
And then the extension methods.!
!HEPackage methodsFor: 'initialization' stamp: ''!
initialize
	version := self class formatVersion.
	classes := OrderedCollection new.
	traits := OrderedCollection new.

	extensionMethods := OrderedCollection new.! !

!HEPackage methodsFor: 'reading' stamp: ''!
readClassFrom: aReader
	classes add: (HEClass readFrom: aReader).! !

!HEPackage methodsFor: 'accessing' stamp: ''!
packageName: anObject
	packageName := anObject! !

!HEPackage methodsFor: 'accessing' stamp: ''!
traits: anObject
	traits := anObject! !

!HEPackage methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream
		nextPutAll: 'HEPackage ( ';
		print: packageName ;
		nextPutAll: ' )'! !

!HEPackage methodsFor: 'accessing' stamp: ''!
classes: anObject
	classes := anObject! !

!HEPackage methodsFor: 'accessing' stamp: ''!
traits
	^ traits! !

!HEPackage methodsFor: 'accessing' stamp: ''!
extensionMethods
	^ extensionMethods! !

!HEPackage methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!HEPackage methodsFor: 'accessing' stamp: ''!
extensionMethods: anObject
	extensionMethods := anObject! !

!HEPackage methodsFor: 'accessing' stamp: ''!
packageName
	^ packageName! !

!HEPackage methodsFor: 'adding' stamp: ''!
addClass: anExportedClass
	classes add: anExportedClass.! !

!HEPackage methodsFor: 'reading' stamp: ''!
readFrom: aReader
	| numberOfTraits numberOfClasses numberOfExtensionMethods |
	version := aReader readInt32.
	
	version = self class formatVersion ifFalse:[self error:'Invalid Hermes file version, expecting: ' , self class formatVersion asString , ' but was: ' , version asString].
	
	packageName := aReader readByteSymbol.

	numberOfTraits := aReader readInt32.
	1 to: numberOfTraits do: [ :idx | traits add: (HETrait readFrom: aReader)].

	numberOfClasses := aReader readInt32.
	1 to: numberOfClasses do: [ :idx | classes add: (HEClass readFrom: aReader)].

	numberOfExtensionMethods := aReader readInt32.
	1 to: numberOfExtensionMethods do: [ :idx | extensionMethods add: (HEMethod readFrom: aReader) ]! !

!HEPackage methodsFor: 'accessing' stamp: ''!
classes
	^ classes! !

!HEPackage class methodsFor: 'formatting' stamp: ''!
formatVersion
	^ 2! !

!HEPragma commentStamp: ''!
I represent a Pragma.
I am stored as a methodLiteral, a keyword and an array of  arguments.
The literals are exported as HEAbstractLiteral.

The method is a HEMethodLiteral
The keyword is a HESymbol
and the arguments si a HEArray!
!HEPragma methodsFor: 'accessing' stamp: ''!
value: aPragma
	method := aPragma method asExportedLiteral.
	keyword := aPragma selector asExportedLiteral.
	arguments := aPragma arguments asExportedLiteral! !

!HEPragma methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	method := HEExportedLiteral readFrom: aReader.
	keyword := HEExportedLiteral readFrom: aReader.
	arguments := HEExportedLiteral readFrom: aReader.! !

!HEPragma methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ Pragma for: (method asLiteralIn: env) selector: (keyword asLiteralIn: env) arguments: (arguments asLiteralIn: env)! !

!HEPragma methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!HEPragma methodsFor: 'accessing' stamp: ''!
keyword
	^ keyword! !

!HEPragma methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!HEPragma class methodsFor: 'accessing' stamp: ''!
tag
	^ 11.! !

!HEReplaceOnDuplication commentStamp: ''!
When there is a duplication I replace the existing version in the target image with the version I am loading from the hermes package.!
!HEReplaceOnDuplication methodsFor: 'validating existence' stamp: ''!
doExistingClass: aClass hermesClass: aHEClass installer: installer
	^ nil! !

!HEReplaceOnDuplication methodsFor: 'validating existence' stamp: ''!
doExistingTrait: aTrait hermesTrait: aHETrait installer: installer
	^ nil! !

!HEReplaceOnDuplication methodsFor: 'validating existence' stamp: ''!
doShouldBuildMethod: aHEMethod in: installer installer: aClass original: aMethod
	^ true! !

!HEReplaceOnDuplication class methodsFor: 'accessing' stamp: ''!
keyword
	^ 'replace'! !

!HEScaledDecimal commentStamp: ''!
I represent a scaled decimal.
I am stored as a Fraction (check HEFraction class) but also adding the scale.
The scale is stored as a exported literal.!
!HEScaledDecimal methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	| scale |
	super doReadFrom: aReader.
	scale := HEExportedLiteral readFrom: aReader.
	
	value := ScaledDecimal newFromNumber: value scale: scale value.! !

!HEScaledDecimal class methodsFor: 'accessing' stamp: ''!
tag 
	^ 25! !

!HESendMessage commentStamp: ''!
I represent the sending of a message.
I store the selector, the receiver and the arguments.
I am used to serialize the Trait compositions. 
As a trait composition is a Smalltalk expression it is serialized as one or more message send.

Each of my elements are HEExportedLiterals, so they can be any literal!
!HESendMessage methodsFor: 'accessing' stamp: ''!
receiver: anObject
	receiver := anObject! !

!HESendMessage methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!HESendMessage methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!HESendMessage methodsFor: 'accessing' stamp: ''!
arguments: anObject
	arguments := anObject! !

!HESendMessage methodsFor: 'accessing' stamp: ''!
receiver
	^ receiver! !

!HESendMessage methodsFor: 'reading' stamp: ''!
doReadFrom: aReader 

	selector := (HEExportedLiteral readFrom: aReader).
	receiver := (HEExportedLiteral readFrom: aReader).
	arguments := (HEExportedLiteral readFrom: aReader).! !

!HESendMessage methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	| aReceiver aSelector args |

	aReceiver := receiver asLiteralIn: env.
	aSelector := selector asLiteralIn: env.
	args := arguments asLiteralIn: env.
	
	^ aReceiver perform: aSelector withArguments: args! !

!HESendMessage methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!HESendMessage class methodsFor: 'instance creation' stamp: ''!
selector: aSelector receiver: aReceiver arguments: arguments

	^ self new
		selector: aSelector;
		receiver: aReceiver;
		arguments: arguments;
		yourself! !

!HESendMessage class methodsFor: 'instance creation' stamp: ''!
tag
	^ 27! !

!HESymbol commentStamp: ''!
I represent the symbols.
I just extend the HEByteString representation.
I just add a conversion from String to Symbol after reading the value.!
!HESymbol methodsFor: 'reading' stamp: ''!
doConvertValue: aValue
	^ aValue asSymbol.! !

!HESymbol class methodsFor: 'accessing' stamp: ''!
tag
	^ 9.! !

!HETrait commentStamp: ''!
I implement the custom behavior for exporting a trait.
My header only includes the name of the trait.
Mostly of my behavior is from HEMethodContainer.!
!HETrait methodsFor: 'accessing' stamp: ''!
isTrait
	^ true! !

!HETrait methodsFor: 'accessing' stamp: ''!
traitName: anObject
	traitName := anObject! !

!HETrait methodsFor: 'reading' stamp: ''!
doReadHeaderFrom: aReader
	traitName := aReader readByteSymbol.! !

!HETrait methodsFor: 'accessing' stamp: ''!
traitName
	^ traitName! !

!HETraitLiteral commentStamp: ''!
I represent a Trait.
I am stored as a symbol.

When serialized I get the name of the trait.
When deserialized I find the trait in the target environment!
!HETraitLiteral methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ env classNamed: value! !

!HETraitLiteral methodsFor: 'accessing' stamp: ''!
value: aTrait
	value := aTrait name.! !

!HETraitLiteral class methodsFor: 'accessing' stamp: ''!
tag
	^ 19! !

!HEUndefinedObject commentStamp: ''!
I represent nil as a literal.
I am only stored as my tag. I have no content.!
!HEUndefinedObject methodsFor: 'converting' stamp: ''!
asLiteralIn: env
	^ nil! !

!HEUndefinedObject methodsFor: 'reading' stamp: ''!
doReadFrom: aReader! !

!HEUndefinedObject class methodsFor: 'accessing' stamp: ''!
tag
	^ 13! !

!HEWideString commentStamp: ''!
I represent a WideString.
I store myself as a byte array.
To store myself I encode the content in utf8.!
!HEWideString methodsFor: 'reading' stamp: ''!
doReadFrom: aReader
	value := aReader readByteArray utf8Decoded.! !

!HEWideString class methodsFor: 'accessing' stamp: ''!
tag
	^ 26! !

!HMAC commentStamp: ''!
HMAC is a mechanism for message authentication using cryptographic hash functions. HMAC can be used with any iterative cryptographic hash function, e.g., MD5, SHA-1, in combination with a secret shared key.  The cryptographic strength of HMAC depends on the properties of the underlying hash function.

See RFC 2114.!
!HMAC methodsFor: 'accessing' stamp: ''!
key: aByteArray 
	key := aByteArray.
	key size > hash blockSize ifTrue: [ key := hash hashMessage: key ].
	key size < hash blockSize ifTrue: [ key := key , (ByteArray new: hash blockSize - key size) ]! !

!HMAC methodsFor: 'accessing' stamp: ''!
destroy
	key destroy! !

!HMAC methodsFor: 'initialization' stamp: ''!
setHash: aHash 
	hash := aHash.
	ipad := ByteArray 
		new: aHash blockSize
		withAll: 54.
	epad := ByteArray 
		new: aHash blockSize
		withAll: 92! !

!HMAC methodsFor: 'accessing' stamp: ''!
digestMessage: aByteArray
	^ hash hashMessage: (key bitXor: epad), (hash hashMessage: (key bitXor: ipad), aByteArray)! !

!HMAC methodsFor: 'accessing' stamp: ''!
digestSize
	^ hash hashSize! !

!HMAC methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: 'HMAC-'; print: hash! !

!HMAC class methodsFor: 'instance creation' stamp: ''!
on: aHashFunction
	^ self new setHash: aHashFunction! !

!HSVAColorSelectorMorph commentStamp: ''!
Colour selector featuring a saturation/volume area, hue selection strip and alpha selection strip.!
!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: ''!
hsvMorph
	"Answer the value of hsvMorph"

	^ hsvMorph! !

!HSVAColorSelectorMorph methodsFor: 'operations' stamp: ''!
newAColorMorph
	"Answer a new alpha color morph."

	^AColorSelectorMorph new
		model: self;
		hResizing: #spaceFill;
		vResizing: #rigid;
		setValueSelector: #alphaSelected:;
		extent: 24@24! !

!HSVAColorSelectorMorph methodsFor: 'initialization' stamp: ''!
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: 'operations' stamp: ''!
selectedColor
	"Answer the selected color."

	^self hsvMorph selectedColor alpha: self aMorph value! !

!HSVAColorSelectorMorph methodsFor: 'operations' stamp: ''!
triggerSelectedColor
	"Trigger the event for the selected colour"

	self triggerEvent: #selectedColor with: self selectedColor! !

!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: ''!
alphaSelected: aFloat
	"The alpha has changed."

	self triggerSelectedColor! !

!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: ''!
aMorph: anObject
	"Set the value of aMorph"

	aMorph := anObject! !

!HSVAColorSelectorMorph methodsFor: 'operations' stamp: ''!
selectedColor: aColor
	"Set the hue and sv components."

	self aMorph value: aColor alpha.
	self hsvMorph selectedColor: aColor beOpaque! !

!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: ''!
aMorph
	"Answer the value of aMorph"

	^ aMorph! !

!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: ''!
colorSelected: aColor
	"A color has been selected. Set the base color for the alpha channel."

	self aMorph color: aColor.
	self triggerSelectedColor! !

!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: ''!
defaultColor
	"Answer the default color/fill style for the receiver."
	
	^Color transparent! !

!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: ''!
hsvMorph: anObject
	"Set the value of hsvMorph"

	hsvMorph := anObject! !

!HSVAColorSelectorMorph methodsFor: 'operations' stamp: ''!
newHSVColorMorph
	"Answer a new hue/saturation/volume color morph."

	^HSVColorSelectorMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		when: #colorSelected send: #colorSelected: to: self! !

!HSVColorSelectorMorph commentStamp: ''!
Colour selector featuring a saturation/volume area and a hue selection strip.!
!HSVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
svMorph: anObject
	"Set the value of svMorph"

	svMorph := anObject! !

!HSVColorSelectorMorph methodsFor: 'operations' stamp: ''!
newHColorMorph
	"Answer a new hue color morph."

	^HColorSelectorMorph new
		model: self;
		setValueSelector: #hue:;
		hResizing: #rigid;
		vResizing: #spaceFill;
		extent: 36@36! !

!HSVColorSelectorMorph methodsFor: 'initialization' stamp: ''!
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: 'operations' stamp: ''!
selectedColor
	"Answer the selected color."

	^self svMorph selectedColor! !

!HSVColorSelectorMorph methodsFor: 'operations' stamp: ''!
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: 'accessing' stamp: ''!
svMorph
	"Answer the value of svMorph"

	^ svMorph! !

!HSVColorSelectorMorph methodsFor: 'operations' stamp: ''!
selectedColor: aColor
	"Set the hue and sv components."

	self hue: aColor hue / 360.
	self svMorph selectedColor: aColor! !

!HSVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
hMorph
	"Answer the value of hMorph"

	^ hMorph! !

!HSVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
defaultColor
	"Answer the default color/fill style for the receiver."
	
	^Color transparent! !

!HSVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
hMorph: anObject
	"Set the value of hMorph"

	hMorph := anObject! !

!HTTPEncodingTest commentStamp: ''!
SUnit tests for HTTPEncoding!
!HTTPProgress commentStamp: ''!
I am HTTPProgress, a notification to show progress when using HTTP.

I include
	- total: The total size of the download/upload (if known)
	- amount: The completed amount of the download/upload (if known)

Use #total:, #amount: or #amountLeft: to set the appropriate byte counts to indicate progress.
Use #fraction or #percentage as a value that indicates progress.
Total and amount are optional and can be nil. Test using #isEmpty.

You can try 
	HTTPProgress example.
!
!HTTPProgress methodsFor: 'testing' stamp: ''!
isEmpty
	"Answer true if I do not contain a numerical progress indication."
  	
	^ amount isNil or: [ total isNil ]! !

!HTTPProgress methodsFor: 'accessing' stamp: ''!
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: ''!
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: ''!
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: ''!
amount: byteCount
	"Set the amount of bytes that has already been transferred."

	amount := byteCount! !

!HTTPProgress methodsFor: 'testing' stamp: ''!
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: 'printing' stamp: ''!
printOn: stream
	"Print an extra progress percentage if available"
	
	super printOn: stream.
	self isEmpty 
		ifFalse: [ 
			stream space; print: self percentage rounded; nextPut: $% ]! !

!HTTPProgress methodsFor: 'accessing' stamp: ''!
amount
	"Answer the amount that has already been transferred.
	Can be nil. Should be between 0 and total."

	^ amount! !

!HTTPProgress methodsFor: 'accessing' stamp: ''!
beComplete
	"Make me complete, i.e. indicate that all bytes were transferred."

	amount := total! !

!HTTPProgress methodsFor: 'accessing' stamp: ''!
total: byteCount
	"Set the total byte count to transfer"

	total := byteCount! !

!HTTPProgress methodsFor: 'accessing' stamp: ''!
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: ''!
total
	"Answer the total byte count to transfer. Can be nil."

	^ total! !

!HTTPProgress class methodsFor: 'examples' stamp: ''!
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: ''!
signalAmount: amount total: total
	"Create and signal HTTPProgress with amount bytes transferred out of total."
	
	^ self new
		amount: amount;
		total: total;
		signal! !

!HTTPProgress class methodsFor: 'exceptioninstantiator' stamp: ''!
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! !

!HaloMorph commentStamp: ''!
This morph provides a halo of handles for its target morph. Dragging, duplicating, rotating, and resizing to be done by mousing down on the appropriate handle. There are also handles for help and for a menu of infrequently used operations.!
!HaloMorph methodsFor: 'handles' stamp: ''!
addFontEmphHandle: haloSpec

	innerTarget isTextMorph ifTrue: [ 
		self
			addHandle: haloSpec
			on: #mouseDown
			send: #chooseEmphasisOrAlignment
			to: innerTarget ]! !

!HaloMorph methodsFor: 'halos and balloon help' stamp: ''!
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: ''!
addDragHandle: haloSpec

	(self
		 addHandle: haloSpec
		 on: #mouseDown
		 send: #startDrag:with:
		 to: self) on: #mouseMove send: #doDrag:with: to: self! !

!HaloMorph methodsFor: 'private' stamp: ''!
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 buildTitle: [ :menuTitle | menuTitle
		title: (innerTarget externalName asString truncateWithElipsisTo: 40);
		"icon: Smalltalk ui icons smallDebugIcon;"
		withCloseBox;
		withPinBox
	];
	popUpEvent: evt in: self world! !

!HaloMorph methodsFor: 'private' stamp: ''!
doRot: evt with: rotHandle
	"Update the rotation of my target if it is rotatable. Keep the relevant command object up to date."

	| degrees |	
	growingOrRotating ifFalse: [^self].
	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 contrastingBlackAndWhiteColor].
	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: ''!
handleAllowanceForIconicHalos

	^ 12! !

!HaloMorph methodsFor: 'geometry' stamp: ''!
position: pos
	"Halos display imperfectly if their coordinates are non-integral
		-- especially the direction handles."

	^ super position: pos asIntegerPoint! !

!HaloMorph methodsFor: 'private' stamp: ''!
showDirectionHandles: wantToShow

	self showDirectionHandles: wantToShow addHandles: true  "called from menu"! !

!HaloMorph methodsFor: 'private' stamp: ''!
positionDirectionShaft: shaft
	"Position the shaft."

	| alphaRadians unitVector |
	"Pretty crude and slow approach at present, but a stake in the ground"
	alphaRadians := target heading degreesToRadians.
	unitVector := alphaRadians sin @ alphaRadians cos negated.
	shaft setVertices: { 
			(unitVector * 6 + directionArrowAnchor). "6 = radius of deadeye circle"
			(unitVector * self directionArrowLength + directionArrowAnchor) }! !

!HaloMorph methodsFor: 'handles' stamp: ''!
addHelpHandle: haloSpec

	target balloonText ifNotNil:
		[(self addHandle: haloSpec on: #mouseDown send: #mouseDownOnHelpHandle: to: innerTarget)
			on: #mouseUp send: #deleteBalloon to: innerTarget]! !

!HaloMorph methodsFor: 'accessing' stamp: ''!
setTarget: aMorph
	"Private!! Set the target without adding handles."

	target := aMorph topRendererOrSelf.
	innerTarget := target renderedMorph.
	innerTarget wantsDirectionHandles
		ifTrue: [self showDirectionHandles: true addHandles: false].
	target hasHalo: true.! !

!HaloMorph methodsFor: 'private' stamp: ''!
startGrow: evt with: growHandle
	"Initialize resizing of my target. Launch a command representing it, to support Undo"

	| botRt |
	growingOrRotating := true.
	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: 'events' stamp: ''!
staysUpWhenMouseIsDownIn: aMorph
	^ ((aMorph == target) or: [aMorph hasOwner: self])! !

!HaloMorph methodsFor: 'copying' stamp: ''!
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: 'meta-actions' stamp: ''!
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: 'handles' stamp: ''!
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: 'private' stamp: ''!
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: ''!
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: ''!
directionArrowLength

	^ 25! !

!HaloMorph methodsFor: 'settings' stamp: ''!
showBoundsInHalo

	^ self class showBoundsInHalo! !

!HaloMorph methodsFor: 'submorphs - add/remove' stamp: ''!
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: 'accessing' stamp: ''!
wantsToBeTopmost
	"Answer if the receiver want to be one of the topmost objects in its owner"
	
	^ true! !

!HaloMorph methodsFor: 'geometry' stamp: ''!
worldBoundsForMorph: aMorph
	"Answer the rectangle to be used as the inner dimension of aMorph halos.
	Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle."

	| r |
	r := (self haloEnclosesFullBounds)
		ifFalse: [ aMorph boundsIn: nil ]
		ifTrue: [ aMorph fullBoundsInWorld ].
	self showBoundsInHalo ifTrue: [ ^r expandBy: 2 ].
	^r! !

!HaloMorph methodsFor: 'events' stamp: ''!
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
		ifNil: [ hand := aMorph world ifNotNil: [ :w | w activeHand ].
			hand ifNil: [ hand := aMorph world primaryHand ].
			hand lastEvent transformedBy: ( aMorph transformedFrom: nil )
			]
		ifNotNil: [ hand := evt hand.
			evt
			].
	self target: aMorph.
	hand halo: self.
	hand world addMorphFront: self.
	positionOffset := anEvent position - ( aMorph point: aMorph position in: owner ).
	self startStepping! !

!HaloMorph methodsFor: 'private' stamp: ''!
showingDirectionHandles
	^directionArrowAnchor notNil! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: 'testing' stamp: ''!
isHaloMorph 

	^ true! !

!HaloMorph methodsFor: 'private' stamp: ''!
setCenterOfRotation: evt with: rotationHandle

	| localPt |
	evt hand obtainHalo: self.
	evt hand showTemporaryCursor: nil.
	(rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse: [ 
		localPt := innerTarget transformFromWorld globalPointToLocal:
			           rotationHandle center.
		innerTarget setRotationCenterFrom: localPt ].
	rotationHandle removeProperty: #dragByCenterOfRotation.
	self endInteraction! !

!HaloMorph methodsFor: 'handles' stamp: ''!
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: 'accessing' stamp: ''!
target

	^ target! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: ''!
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: ''!
trackDirectionArrow: anEvent with: shaft
	anEvent hand obtainHalo: self.
	shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
	self layoutChanged! !

!HaloMorph methodsFor: 'stepping' stamp: ''!
step
	| newBounds |
	target
		ifNil: [^ self].
	newBounds := target isWorldMorph
				ifTrue: [target bounds]
				ifFalse: [self localHaloBoundsFor: target renderedMorph].
	newBounds = self bounds
		ifTrue: [^ self].
	newBounds extent = self bounds extent
		ifTrue: [^ self position: newBounds origin].
	growingOrRotating
		ifFalse: [submorphs size > 1
				ifTrue: [self addHandles]].
	"adjust halo bounds if appropriate"
	self bounds: newBounds! !

!HaloMorph methodsFor: 'private' stamp: ''!
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 ]! !

!HaloMorph methodsFor: 'private' stamp: ''!
doScale: evt with: scaleHandle
	"Update the scale of my target if it is scalable."
	| newHandlePos colorToUse |
	growingOrRotating ifFalse: [ ^self ].
	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 contrastingBlackAndWhiteColor].
	scaleHandle position: newHandlePos.! !

!HaloMorph methodsFor: 'handles' stamp: ''!
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: 'meta-actions' stamp: ''!
handlerForBlueButtonDown: anEvent
	"Blue button was clicked within the receiver"

	^ self! !

!HaloMorph methodsFor: 'events - processing' stamp: ''!
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: 'handles' stamp: ''!
addDebugHandle: handleSpec

	self class haloWithDebugHandle ifTrue: [ 
		self
			addHandle: handleSpec
			on: #mouseDown
			send: #doDebug:with:
			to: self ]! !

!HaloMorph methodsFor: 'event handling' stamp: ''!
mouseMove: evt
	"Drag our target around"

	| thePoint |
	thePoint := target point: evt position - positionOffset from: owner.
	target setConstrainedPosition: thePoint hangOut: true! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: 'stepping' stamp: ''!
stepTime

	^ 0  "every cycle"! !

!HaloMorph methodsFor: 'handles' stamp: ''!
addFontStyleHandle: haloSpec

	innerTarget isTextMorph ifTrue: [ 
		self
			addHandle: haloSpec
			on: #mouseDown
			send: #chooseStyle
			to: innerTarget ]! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: 'copying' stamp: ''!
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: 'menu' stamp: ''!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu"

	^ false! !

!HaloMorph methodsFor: 'events' stamp: ''!
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: 'handles' stamp: ''!
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: 'settings' stamp: ''!
gradientHalo

	^ false! !

!HaloMorph methodsFor: 'private' stamp: ''!
addName
	"Add a name readout at the bottom of the halo."
	
	self addNameBeneath: self basicBox string: target externalName! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: 'handles' stamp: ''!
addRecolorHandle: haloSpec
	"Add a recolor handle to the receiver, if appropriate"

	"since this halo now opens a more general properties panel, allow it in all cases"
	"innerTarget canSetColor ifTrue:"

	self addHandle: haloSpec on: #mouseUp send: #doRecolor:with: to: self! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: ''!
doGrow: evt with: growHandle
	"Called while the mouse is down in the grow handle"

	| newExtent extentToUse scale |
	growingOrRotating ifFalse: [ ^self ].
	evt hand obtainHalo: self.
	newExtent := (target pointFromWorld: (evt cursorPoint - positionOffset)) - target topLeft.
	evt shiftPressed ifTrue: [
		scale := (newExtent x / (originalExtent x max: 1)) min:
					(newExtent y / (originalExtent y max: 1)).
		newExtent := (originalExtent x * scale) asInteger @ (originalExtent y * scale) asInteger
	].
	(newExtent x < 1 or: [newExtent y < 1 ]) ifTrue: [^ self].
	target renderedMorph extent: (extentToUse := newExtent).
	growHandle position: evt cursorPoint - (growHandle extent // 2).
	self layoutChanged! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: ''!
addGraphicalHandleFrom: formKey at: aPoint
	"Add the supplied form as a graphical handle centered at the given point. Return the handle."
	
	| handle aForm |
	aForm := Smalltalk ui icons
		iconNamed: formKey 
		ifNone: [ self iconNamed: #solidMenuIcon ].
	handle := ImageMorph new form: aForm; bounds: (Rectangle center: aPoint extent: aForm extent).
	handle wantsYellowButtonMenu: false.
	self addMorph: handle.
	handle on: #mouseUp send: #endInteraction to: self.
	^ handle! !

!HaloMorph methodsFor: 'private' stamp: ''!
addSimpleHandlesForWorldHalos
	"Nothing special at present here -- just use the regular handles.  Cannot rotate or resize world"

	self addHandlesForWorldHalos! !

!HaloMorph methodsFor: 'events - processing' stamp: ''!
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: 'private' stamp: ''!
addHandles

	self addCircleHandles! !

!HaloMorph methodsFor: 'halos and balloon help' stamp: ''!
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: 'events' stamp: ''!
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: 'private' stamp: ''!
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: ''!
showDirectionHandles: wantToShow addHandles: needHandles

	directionArrowAnchor := wantToShow 
				ifTrue: [target referencePositionInWorld	"not nil means show"]
				ifFalse: [nil].
	needHandles ifTrue: [self addHandles]! !

!HaloMorph methodsFor: 'private' stamp: ''!
doDirection: anEvent with: directionHandle

	anEvent hand obtainHalo: self.
	self removeAllHandlesBut: directionHandle! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas

	| alpha |
	(alpha := self magicAlpha) = 1.0 ifTrue: [ 
		^ super drawSubmorphsOn: aCanvas ].
	^ super drawSubmorphsOn: (aCanvas asAlphaBlendingCanvas: alpha)! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: ''!
simpleFudgeOffset
	"account for the difference in basicBoxes between regular and simple handles"

	^ 0@0! !

!HaloMorph methodsFor: 'accessing' stamp: ''!
target: aMorph

	self setTarget: aMorph.
	target ifNotNil: [self addHandles].! !

!HaloMorph methodsFor: 'private' stamp: ''!
addFullHandles

	self addCircleHandles! !

!HaloMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	growingOrRotating := false.
	self borderStyle:
		(SimpleBorderStyle width: 2 color: self theme menuSelectionColor)! !

!HaloMorph methodsFor: 'private' stamp: ''!
mouseDownInDimissHandle: evt with: dismissHandle

	evt hand obtainHalo: self.
	self removeAllHandlesBut: dismissHandle.
	self setColor: Color darkGray toHandle: dismissHandle! !

!HaloMorph methodsFor: 'dropping/grabbing' stamp: ''!
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: 'handles' stamp: ''!
addRotateHandle: haloSpec

	(self
		 addHandle: haloSpec
		 on: #mouseDown
		 send: #startRot:with:
		 to: self) on: #mouseMove send: #doRot:with: to: self! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
magicAlpha: alpha

	self setProperty: #magicAlpha toValue: alpha.
	self changed! !

!HaloMorph methodsFor: 'private' stamp: ''!
handleSize

	^ 30! !

!HaloMorph methodsFor: 'private' stamp: ''!
maybeDoDup: evt with: dupHandle

	evt hand obtainHalo: self.
	^ self doDup: evt with: dupHandle! !

!HaloMorph methodsFor: 'private' stamp: ''!
doDup: evt with: dupHandle
	"Ask hand to duplicate my target."

	(target isKindOf: SelectionMorph) ifTrue:
		[^ target doDup: evt fromHalo: self handle: dupHandle].

	self obtainHaloForEvent: evt andRemoveAllHandlesBut: dupHandle.
	self setTarget: (target duplicateMorph: evt).
	evt hand grabMorph: target.
	self step. "update position if necessary"
	evt hand addMouseListener: self. "Listen for the drop"! !

!HaloMorph methodsFor: 'accessing - defaults' stamp: ''!
defaultColor
	"Answer the default color/fill style for the receiver."

	^ Color transparent! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: 'handles' stamp: ''!
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: ''!
addMenuHandle: haloSpec

	self addHandle: haloSpec on: #mouseDown send: #doMenu:with: to: self! !

!HaloMorph methodsFor: 'handles' stamp: ''!
addFontSizeHandle: haloSpec

	innerTarget isTextMorph ifTrue: [ 
		self
			addHandle: haloSpec
			on: #mouseDown
			send: #chooseFont
			to: innerTarget ]! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: 'updating' stamp: ''!
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: 'events - processing' stamp: ''!
containsPoint: aPoint event: anEvent
	"Blue buttons are handled by the halo"

	(anEvent isMouse and: [ 
		 anEvent isMouseDown and: [ anEvent blueButtonPressed ] ]) ifFalse: [ 
		^ super containsPoint: aPoint event: anEvent ].
	^ bounds containsPoint: anEvent position! !

!HaloMorph methodsFor: 'private' stamp: ''!
doDrag: evt with: dragHandle

	| thePoint |
	evt hand obtainHalo: self.
	thePoint := target point: evt position - positionOffset from: owner.
	target setConstrainedPosition:  thePoint hangOut: true! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: ''!
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.
			handle borderColor: aColor muchDarker.
			self setColor: aColor toHandle: handle
			]
		ifFalse: [ 
			handle := EllipseMorph newBounds: bou color: aColor.
			handle borderWidth: 0 ].
	handle wantsYellowButtonMenu: false.
	iconName
		ifNotNil: [ ( self iconNamed: iconName )
				ifNotNil: [ :form | 
					| image |

					image := ImageMorph new.
					image form: form.
					image color: aColor contrastingBlackAndWhiteColor.
					image lock.
					handle addMorphCentered: image
					]
			].
	^ handle! !

!HaloMorph methodsFor: 'private' stamp: ''!
trackCenterOfRotation: anEvent with: rotationHandle
	(rotationHandle hasProperty: #dragByCenterOfRotation) 
		ifTrue:[^self doDrag: anEvent with: rotationHandle].
	anEvent hand obtainHalo: self.
	rotationHandle center: anEvent cursorPoint.! !

!HaloMorph methodsFor: 'accessing' stamp: ''!
magicAlpha

	^ self valueOfProperty: #magicAlpha ifAbsent: [ 1.0 ]! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: 'settings' stamp: ''!
haloEnclosesFullBounds

	^ self class haloEnclosesFullBounds! !

!HaloMorph methodsFor: 'event handling' stamp: ''!
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: 'private' stamp: ''!
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: 'accessing' stamp: ''!
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: [SimpleBorderStyle width: 0 color: Color transparent]! !

!HaloMorph methodsFor: 'private' stamp: ''!
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 := StringMorph contents: aString font: StandardFonts haloFont.
	nameMorph 
	wantsYellowButtonMenu: false;
	color: self theme balloonTextColor;
	backgroundColor: self theme balloonBackgroundColor;
	target: innerTarget.
	
	namePosition := outerRectangle bottomCenter -
		((nameMorph width // 2) @ (self handleSize negated // 2 - 1)).
		
	nameMorph position: (namePosition min: w viewBox bottomRight - nameMorph extent y + 2).
	self addMorph: nameMorph.
	^ nameMorph! !

!HaloMorph methodsFor: 'handles' stamp: ''!
addDismissHandle: handleSpec 
	"Add the dismiss handle according to the spec, unless my target resists
	dismissal "
	| dismissHandle |
	target okayToAddDismissHandle
		ifTrue: [dismissHandle := self
						addHandle: handleSpec
						on: #mouseDown
						send: #mouseDownInDimissHandle:with:
						to: self.
			dismissHandle 
				on: #mouseUp
				send: #maybeDismiss:with:
				to: self.
			dismissHandle
				on: #mouseDown
				send: #setDismissColor:with:
				to: self.
			dismissHandle
				on: #mouseMove
				send: #setDismissColor:with:
				to: self]! !

!HaloMorph methodsFor: 'private' stamp: ''!
removeAllHandlesBut: aHandle
	"Remove all handles except aHandle."

	submorphs copy do: [ :m | m == aHandle ifFalse: [ m delete ] ]! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
innerTarget

	^ innerTarget! !

!HaloMorph methodsFor: 'private' stamp: ''!
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: 'handles' stamp: ''!
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: 'wiw support' stamp: ''!
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: 'geometry -  testing' stamp: ''!
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: 'accessing' stamp: ''!
haloBox: aBox

	haloBox := aBox! !

!HaloMorph class methodsFor: 'settings' stamp: ''!
showBoundsInHalo
	^ ShowBoundsInHalo ifNil: [ShowBoundsInHalo := false]! !

!HaloMorph class methodsFor: 'halo theme' stamp: ''!
currentHaloSpecifications
	^ CurrentHaloSpecifications ifNil: [self installHaloTheme: #iconicHaloSpecifications]! !

!HaloMorph class methodsFor: 'halo theme' stamp: ''!
initialize
	"self initialize"
	
	self installHaloTheme: #iconicHaloSpecifications! !

!HaloMorph class methodsFor: 'halo theme' stamp: ''!
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: ''!
haloWithDebugHandle
	^ HaloWithDebugHandle ifNil: [HaloWithDebugHandle := true]! !

!HaloMorph class methodsFor: 'halo theme' stamp: ''!
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: ''!
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: ''!
installHaloTheme: haloSpecificationsSelector
	^ CurrentHaloSpecifications := self allHaloSpecsFromArray: (self perform: haloSpecificationsSelector).! !

!HaloMorph class methodsFor: 'halo theme' stamp: ''!
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: ''!
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: 'settings' stamp: ''!
haloWithDebugHandle: aBoolean
	 HaloWithDebugHandle := aBoolean! !

!HaloMorph class methodsFor: 'settings' stamp: ''!
haloEnclosesFullBounds: aBoolean
	HaloEnclosesFullBounds := aBoolean! !

!HaloMorph class methodsFor: 'halo theme' stamp: ''!
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: 'settings' stamp: ''!
haloEnclosesFullBounds
	^ HaloEnclosesFullBounds ifNil: [HaloEnclosesFullBounds := false]! !

!HaloMorph class methodsFor: 'settings' stamp: ''!
showBoundsInHalo: aBoolean
	ShowBoundsInHalo := aBoolean! !

!HaloMorph class methodsFor: 'halo theme' stamp: ''!
allHaloSpecsFromArray: anArray
	^ anArray collect: [:quin | self haloSpecFromArray: quin]! !

!HaloSpec commentStamp: ''!
Sets spec's for how handles are layed out in a halo.!
!HaloSpec methodsFor: 'accessing' stamp: ''!
horizontalPlacement

	^ horizontalPlacement! !

!HaloSpec methodsFor: 'accessing' stamp: ''!
verticalPlacement

	^ verticalPlacement! !

!HaloSpec methodsFor: 'actions' stamp: ''!
addHandleSelector

	^ addHandleSelector! !

!HaloSpec methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream 
		nextPutAll: ' (';
		print: addHandleSelector;
 		space;
		print: iconSymbol;
 		nextPut: $)! !

!HaloSpec methodsFor: 'setter' stamp: ''!
horizontalPlacement: hp verticalPlacement: vp color: col iconSymbol: is addHandleSelector: sel

	horizontalPlacement := hp.
	verticalPlacement := vp.
	color := col.
	iconSymbol := is asSymbol.
	addHandleSelector := sel! !

!HaloSpec methodsFor: 'accessing' stamp: ''!
iconSymbol

	^ iconSymbol! !

!HaloSpec methodsFor: 'accessing' stamp: ''!
color

	^ color! !

!Halt commentStamp: ''!
Halt is a special exception provided to support breakpoints as defined in  Object>>halt.

!!!! Basic usage

To manually set a breakpoint you can use message halt as follows: 
[[[			
anObject halt. 
]]]
You can also use 

[[[
Halt now
]]]

[[[
Halt now: 'With a nice explanation'
]]]

!!!! Advanced usage
The class Halt supports different halting mechanisms such as conditionals, based on iteration or simply stopping the first time. 

!!!!!! Conditionals

[[[
foo
	...
	Halt if: #invokedFromThisSelector
]]]

This expression will only stop the execution  of method foo if this method is in the call chain (is invoked from ) message invokedFromThisSelector.

[[[
foo
      ...
      Halt if: aBlock		
]]]

The execution of foo will stop if aBlock returns true. 

!!!!!! Counting
Sometimes we need to stop after a given number of iteration.

[[[
Halt count: 5
]]]



!!!!!! Once
It is really useful sometimes to stop only and only one time

[[[
foo
	...
	Halt once. 
]]]

It will be stopped the first time. 
Then if you need to rearm it to stop another time you should use

[[[
Halt resetOnce			
]]]


!!!! Implementation details

In past Halt was a normal exception (not a kind of UnhandledException) and it was processed through UnhandledError indirection. 
But it such design did not allow to debug the unhandled logic itself. For example halt in UnhandledError>>#defaultAction leaded to infinite recursion!
!Halt methodsFor: 'private' stamp: ''!
exception
	"In the context management, it might happen that we get an Halt instead of an UnhandledError. The context will ask the exception. In case we have an halt, we should return self."

	^ self! !

!Halt methodsFor: '*SUnit-Core' stamp: ''!
manageTestProcessBy: aProcessMonitorTestService
	"When halt is signaled during test it is always an user intention to debug the test.
	Therefore we should pass all suspended failures from background processes.
	So that we will open debugger on all exceptions raised during test"
	
	aProcessMonitorTestService passBackgroundFailures! !

!Halt methodsFor: 'private' stamp: ''!
completeProcess: aProcess with: aContext
	^ aContext methodNode
		pragmaNamed: #debuggerCompleteToSender
		ifPresent: [ aProcess completeTo: aContext sender ]
		ifAbsent: [ super completeProcess: aProcess with: aContext ]! !

!Halt methodsFor: '*JenkinsTools-Core' stamp: ''!
recordResultOf: aTestCase inHDTestReport: aHDTestReport
	
	aHDTestReport recordError: self duringTest: aTestCase! !

!Halt class methodsFor: 'halting' stamp: ''!
if: condition
	<debuggerCompleteToSender>
	"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"
	LocalRecursionStopper during: [ 
		condition isSymbol ifTrue: [ 
			^ self haltIfCallChain: thisContext home sender contains: condition ].
		condition isBlock ifTrue: [ 
			^ self haltIfBlock: condition withCallingObjectFrom: thisContext home sender].
		condition ifTrue: [self signalIn: thisContext home sender ].
	]! !

!Halt class methodsFor: 'halting' stamp: ''!
ifTest
	<debuggerCompleteToSender>
	"Halt if execution was started by a test"
	CurrentExecutionEnvironment value isTest ifTrue: [self signalIn: thisContext home sender ].! !

!Halt class methodsFor: '*Morphic-Base' stamp: ''!
resetOnceMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #'Enable all break/inspect once')
		parent: #Breakpoints;
		order: 99;
		help: 'Reset the break/inspect once. Once restarted, the first break once encountered will stop the execution.';
		action: [ Halt resetOnce ]! !

!Halt class methodsFor: 'once-reset' stamp: ''!
resetHaltOnCount
	 #haltOnCount: senders do: [ :method | method ast removeProperty: #haltCount ifAbsent: [  ] ].! !

!Halt class methodsFor: 'halting' stamp: ''!
now: aString
	"set a breakpoint with some explanation"
	<debuggerCompleteToSender>
	self signal: aString! !

!Halt class methodsFor: 'private' stamp: ''!
haltIfBlock: aBlock withCallingObjectFrom: haltSenderContext

	(aBlock cull: haltSenderContext receiver)
		ifTrue: [self signalIn: haltSenderContext]
		ifFalse: [^ self].! !

!Halt class methodsFor: 'testing' stamp: ''!
captureIfSignalledWhenStepping
	^self == Halt! !

!Halt class methodsFor: 'once-reset' stamp: ''!
resetOnce
	"Once stops an expression once and only once. Halt resetOnce will rearm and make sure that the execution of a method containing Halt once will stop another time."
	 (#haltOnce senders, #inspectOnce senders) do: [ :method | 
		method ast sendNodes do: [ :sendNode| 
			sendNode removeProperty: #Once ifAbsent: [  ]]]! !

!Halt class methodsFor: 'halting' stamp: ''!
onCountWithBehavior: behaviorBlock
	"Halt on the anInteger-th time through, as defined in the behavior block passed as parameter.
	First parameter of the behaviorBlock is the AST node corresponding to the halt call."

	<debuggerCompleteToSender>
	| callingContext node |
	"if the compiler is not loaded, we fall back on the standard halt "
	self environment at: #OpalCompiler ifAbsent: [ ^ self now ].
	callingContext := thisContext sender sender sender.
	node := callingContext sourceNodeExecuted.
	(node hasProperty: #haltCount)
		ifFalse: [ node propertyAt: #haltCount put: 0 ].
	node propertyAt: #haltCount put: (node propertyAt: #haltCount) + 1.
	(behaviorBlock value: node)
		ifTrue: [ ^ self signal ]! !

!Halt class methodsFor: 'private' stamp: ''!
haltIfCallChain: haltSenderContext contains: aSelector
	| cntxt |
	cntxt := haltSenderContext.
	[ cntxt isNil ] whileFalse: [ 
		cntxt selector = aSelector ifTrue: [ self signalIn: haltSenderContext ].
		cntxt := cntxt sender ]! !

!Halt class methodsFor: 'halting' stamp: ''!
now
	<debuggerCompleteToSender>
	self signal.! !

!Halt class methodsFor: 'halting' stamp: ''!
onCount: anInteger
	"Halts once when a count is reached"

	<debuggerCompleteToSender>
	^ self
		onCountWithBehavior: [ :node | (node propertyAt: #haltCount) = anInteger ]! !

!Halt class methodsFor: 'halting' stamp: ''!
ifNotTest
	<debuggerCompleteToSender>
	"Halt if execution was not started by a test"
	CurrentExecutionEnvironment value isTest ifFalse: [self signalIn: thisContext home sender ].! !

!Halt class methodsFor: 'halting' stamp: ''!
once
	"Stop once and only once the execution of the method containing the expression Halt once. If you need to get it stops another time after the first stop, use Halt resetOnce."

	| callingContext senderContext node |
	<debuggerCompleteToSender>
		
	"if the compiler is not loaded, we fall back on the standard halt "
	self environment at: #OpalCompiler ifAbsent: [ ^self now ].	
	
	callingContext := (thisContext findContextSuchThat: [ :ctx | 
		ctx compiledCode sendsAnySelectorOf: #(haltOnce) ]
	) ifNil: [ thisContext sender ].
	
	senderContext := thisContext.
	
	LocalRecursionStopper during: [
		"we need to ignore when the code below calls us again"
		node := callingContext sourceNodeExecuted.
		(node hasProperty: #Once) ifTrue: [ ^ self ]. 
		node propertyAt: #Once put: true.
		
		self signalIn: senderContext
		
	].! !

!Halt class methodsFor: 'halting' stamp: ''!
fromCount: anInteger
	"Always halt after a count has been reached"

	<debuggerCompleteToSender>
	^ self
		onCountWithBehavior: [ :node | (node propertyAt: #haltCount) >= anInteger ]! !

!HaltIconStyler commentStamp: ''!
I'm in charge to style  the editor for  message sends with the "halt", "halt:" or "haltIf:" selectors, like "self halt".!
!HaltIconStyler methodsFor: 'defaults' stamp: ''!
iconLabelBlock: aNode
	^ [aNode selector]! !

!HaltIconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^(Color red alpha: 0.1)! !

!HaltIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	| selectorsToBeHighlighted |
	selectorsToBeHighlighted := { 'halt'. 'halt:'. 'haltIf:'. 'haltIfNil' }.
	^aNode isMessage and: [ selectorsToBeHighlighted anySatisfy: [ :sel| sel = aNode selector ]].! !

!HaltIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #haltIcon ! !

!HaltInCompiledBlockPrintOnTest methodsFor: 'running' stamp: ''!
tearDown 
	oldCode ifNotNil: 	[BlockClosure compileSilently: oldCode].
	super tearDown! !

!HaltInCompiledBlockPrintOnTest methodsFor: 'running' stamp: ''!
testExecutingHaltingPrintOnABlockOpensASingleDebugger

	| ourException dbg debugSession sem myProcess |
	"This is a smoke test making sure that putting an halt in BlockClosure printOn: does not lead 
	to endless loop."
	
	sem := Semaphore new.
	
	myProcess := [[[  ] printString] on: Exception do: [:e | 
		e freeze.
		ourException := e ].	
		sem signal.
	] fork.
	"We are creating a dedicated process, because when closing the debugger it will kill the process and 
	using the active process will kill the test."
	sem wait.
	
	debugSession := myProcess newDebugSessionNamed: 'test' startedAt: ourException signalerContext.
	
	debugSession exception: ourException.
	
	dbg := StDebugger openOn: debugSession withFullView: true.
	dbg window close.! !

!HaltInCompiledBlockPrintOnTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	oldCode := (BlockClosure >> #printOn:) sourceCode.
	BlockClosure compileSilently: 'printOn: aStream
	 	self halt.
	'.! !

!HaltOnCountIconStyler commentStamp: ''!
I'm in charge to style  the editor for  a "haltOnCount:". Clicking on it resets the counter.!
!HaltOnCountIconStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	^[ aNode removeProperty: #haltCount ifAbsent: []]! !

!HaltOnCountIconStyler methodsFor: 'defaults' stamp: ''!
iconLabelBlock: aNode
	^ [(aNode hasProperty: #haltCount) 
		ifTrue: [(aNode propertyAt: #haltCount) asString, ' ,click to reset']
		ifFalse: ['count: 0' ]]! !

!HaltOnCountIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^ aNode isMessage
		and: [ #(#haltOnCount: #haltFromCount:) includes: aNode selector ]! !

!HaltOnceIconStyler commentStamp: ''!
I'm in charge to style  the editor for  a "haltOnce". Clicking on it re-enables the haltOnce.!
!HaltOnceIconStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	^[	aNode removeProperty: #Once ifAbsent: [aNode propertyAt: #Once put: true ]]! !

!HaltOnceIconStyler methodsFor: 'defaults' stamp: ''!
iconLabelBlock: aNode
	^ [(aNode hasProperty: #Once) 
		ifTrue: ['inactive, click to turn on']
		ifFalse: ['active, click to turn off' ]]! !

!HaltOnceIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^aNode isMessage and: [ aNode selector = #haltOnce]! !

!HaltTest methodsFor: 'tests' stamp: ''!
testHaltFromCount
	<haltOrBreakpointForTesting>

	| anObject haltCount |
	anObject := Object new.
	thisContext method recompile. "reset state of #halOnce here"
	"Halts regardless of whether HaltOnce is false for the image"
	self shouldHaltWhen: [ anObject haltFromCount: 1 ].

	"Should halt if executed enough times"	
	self shouldHaltAfter: 2 times: [ anObject haltFromCount: 2 ].
	
	"Should still halt if executed again after the count is reached"	
	self shouldHaltAfter: 2 times: [ anObject haltFromCount: 2 ].
	
	"Should not halt if not executed enough times"	
	self shouldntHaltAfter: 2 times: [ anObject haltFromCount: 3 ].
	
	"Should continue halting after the count is reached"
	haltCount := 0.
	10 timesRepeat: [ [ anObject haltFromCount: 3 ]
				on: Halt
				do: [ haltCount := haltCount + 1 ] ].
	self assert: haltCount equals: 8! !

!HaltTest methodsFor: 'helpers' stamp: ''!
shouldntHaltWhen: aBlock

	self shouldnt: aBlock raise: Halt.! !

!HaltTest methodsFor: 'tests' stamp: ''!
testHaltOnCount
	<haltOrBreakpointForTesting>

	| anObject haltCount |
	anObject := Object new.
	thisContext method recompile.

	"Should not halt if not executed enough times"
	self shouldntHaltAfter: 2 times: [ anObject haltOnCount: 3 ].
	self shouldHaltAfter: 3 times: [ anObject haltOnCount: 3 ].

	"Should stop halting after the count is reached"
	haltCount := 0.
	10 timesRepeat: [ [ anObject haltOnCount: 3 ]
				on: Halt
				do: [ haltCount := haltCount + 1 ] ].
	self assert: haltCount equals: 1! !

!HaltTest methodsFor: 'helpers' stamp: ''!
shouldHaltAfter: aNumber times: aBlock
	
	self shouldHaltWhen: [ aNumber timesRepeat: aBlock ].! !

!HaltTest methodsFor: 'helpers' stamp: ''!
a1
	self b1! !

!HaltTest methodsFor: 'tests' stamp: ''!
testHaltIf
	<haltOrBreakpointForTesting>

	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]].! !

!HaltTest methodsFor: 'helpers' stamp: ''!
shouldHaltWhen: aBlock

	self should: aBlock raise: Halt.! !

!HaltTest methodsFor: 'helpers' stamp: ''!
a
	self b! !

!HaltTest methodsFor: 'tests' stamp: ''!
testContainsHalt
	
	| annonClass |
	
	self 
	assert: (Object >> #halt) containsHalt;
	deny: (Object >> #haltIfNil) containsHalt;
	deny: (Halt class >> #once) containsHalt;
	assert: (self class>> #testHaltIfNil) containsHalt.
	
	annonClass := Object newAnonymousSubclass.
	annonClass 
	compile: 'm1 self halt';
	compile: 'm2 self haltIfNil';
	compile: 'm3 self yourself';
	compile: 'm4 Halt yourself';
	compile: 'm5 Halt once'.
	
	self
	assert: (annonClass >> #m1) containsHalt;
	assert: (annonClass >> #m2) containsHalt;
	deny: (annonClass >> #m3) containsHalt;
	deny: (annonClass >> #m4) containsHalt;
	assert: (annonClass >> #m5) containsHalt! !

!HaltTest methodsFor: 'tests' stamp: ''!
testHaltIfNil
	<haltOrBreakpointForTesting>

	self should: [ nil haltIfNil] raise: Halt! !

!HaltTest methodsFor: 'tests' stamp: ''!
testHaltOnce
	<haltOrBreakpointForTesting>
	| anObject block |
	anObject := Object new.
	block :=  [ anObject haltOnce ]. 
	self should: block raise: Halt.
	"block value."
	Halt resetOnce.! !

!HaltTest methodsFor: 'helpers' stamp: ''!
b
	<haltOrBreakpointForTesting>
	self haltIf: #testHaltIf! !

!HaltTest methodsFor: 'helpers' stamp: ''!
b1
	<haltOrBreakpointForTesting>
	self haltIf: #testasdasdfHaltIf! !

!HaltTest methodsFor: 'helpers' stamp: ''!
shouldntHaltAfter: aNumber times: aBlock
	
	self shouldntHaltWhen: [ aNumber timesRepeat: aBlock ].! !

!HandMorph commentStamp: ''!
The cursor may be thought of as the HandMorph.  The hand's submorphs hold anything being carried by dragging.  

There is some minimal support for multiple hands in the same world.!
!HandMorph methodsFor: 'focus handling' stamp: ''!
releaseMouseFocus: aMorph
	"If the given morph had the mouse focus before, release it"
	self mouseFocus == aMorph ifTrue:[self releaseMouseFocus].! !

!HandMorph methodsFor: 'focus handling' stamp: ''!
releaseKeyboardFocus
	"Release the current keyboard focus unconditionally"
	self newKeyboardFocus: nil.! !

!HandMorph methodsFor: 'accessing' stamp: ''!
cursorBounds
	^ temporaryCursor
		ifNil: [ self position extent: NormalCursor extent ]
		ifNotNil: [ self position + temporaryCursorOffset extent: temporaryCursor extent ]! !

!HandMorph methodsFor: 'focus handling' stamp: ''!
releaseMouseFocus
	"Release the current mouse focus unconditionally."
	self newMouseFocus: nil.! !

!HandMorph methodsFor: 'geometry' stamp: ''!
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: 'event handling' stamp: ''!
cursorPoint

	^ self position! !

!HandMorph methodsFor: 'double click support' stamp: ''!
resetClickState
	"Reset the double-click detection state to normal (i.e., not waiting for a double-click)."
	mouseClickState := nil.! !

!HandMorph methodsFor: 'cursor' stamp: ''!
currentCursor

	^ self world currentCursor! !

!HandMorph methodsFor: 'accessing' stamp: ''!
lastEvent
	^ lastMouseEvent! !

!HandMorph methodsFor: 'listeners' stamp: ''!
mouseListeners
	^mouseListeners! !

!HandMorph methodsFor: 'listeners' stamp: ''!
mouseListeners: anArrayOrNil
	mouseListeners := anArrayOrNil! !

!HandMorph methodsFor: 'accessing' stamp: ''!
anyModifierKeyPressed
	^recentModifiers anyMask: 16r0E	"cmd | opt | ctrl"! !

!HandMorph methodsFor: '*Morphic-Base' stamp: ''!
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: 'listeners' stamp: ''!
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: ''!
removeMouseListener: anObject
	"Remove anObject from the current mouse listeners."
	self mouseListeners: (self removeListener: anObject from: self mouseListeners).! !

!HandMorph methodsFor: '*SUnit-Support-UITesting' stamp: ''!
simulateKeyStroke: aCharacterOrShortcut

	| shortcut |
	shortcut := aCharacterOrShortcut asKeyCombination.
	self handleEvent: (KeyboardEvent new
		setType: #keystroke
		buttons: shortcut modifier eventCode
		position: self position 
		keyValue: shortcut key asciiValue
		charCode: shortcut key asciiValue
		hand: self activeHand 
		stamp: DateAndTime now).! !

!HandMorph methodsFor: 'balloon help' stamp: ''!
spawnBalloonFor: aMorph
	aMorph showBalloon: aMorph balloonText hand: self.! !

!HandMorph methodsFor: 'paste buffer' stamp: ''!
pasteBuffer: aMorphOrNil
	"Set the contents of the paste buffer."
	PasteBuffer := aMorphOrNil.! !

!HandMorph methodsFor: 'meta-actions' stamp: ''!
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 = self world ifTrue: [^ self].
	self releaseMouseFocus.
	grabbed := aMorph aboutToBeGrabbedBy: self.
	grabbed ifNil: [^self].
	grabbed := grabbed topRendererOrSelf.
	^self grabMorph: grabbed from: grabbed owner! !

!HandMorph methodsFor: 'balloon help' stamp: ''!
balloonHelp: aBalloonMorph
	"Return the balloon morph associated with this hand"
	self balloonHelp ifNotNil:[:oldHelp |oldHelp delete].
	aBalloonMorph
		ifNil:[self removeProperty: #balloonHelpMorph]
		ifNotNil:[self setProperty: #balloonHelpMorph toValue: aBalloonMorph]! !

!HandMorph methodsFor: 'focus handling' stamp: ''!
keyboardFocus: aMorphOrNil
	self newKeyboardFocus: aMorphOrNil! !

!HandMorph methodsFor: 'focus handling' stamp: ''!
keyboardFocus 
	^ keyboardFocus! !

!HandMorph methodsFor: 'cursor' stamp: ''!
showTemporaryCursor: cursorOrNil
	"Set the temporary cursor to the given Form. If the argument is nil, revert to the normal cursor."

	self showTemporaryCursor: cursorOrNil hotSpotOffset: 0@0! !

!HandMorph methodsFor: 'balloon help' stamp: ''!
triggerBalloonFor: aMorph after: timeOut
	"Trigger balloon help after the given time out for some morph"
	self addAlarm: #spawnBalloonFor: with: aMorph after: timeOut.! !

!HandMorph methodsFor: 'double click support' stamp: ''!
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: 'listeners' stamp: ''!
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: 'events - processing' stamp: ''!
handleEvent: anEvent
	| evt  |
	owner ifNil:[^self].
	evt := anEvent.
	
	"nil test here is for efficiency in the normal case"
	EventStats ifNotNil: [ self class 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 ].
	

	evt isKeyboard ifTrue:[
		
		(evt isKeystroke and: [supressNextKeyPress == true])
			ifTrue: [
				supressNextKeyPress := false.
				^ self ].
		
			self sendListenEvent: evt to: self keyboardListeners.
			self sendKeyboardEvent: evt.
			supressNextKeyPress := evt isKeyDown and: [evt supressNextKeyPress].
		^ self ].

	evt isDropEvent ifTrue:[
		^ self sendEvent: evt focus: nil ].

	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 ]].

	evt isMove ifTrue:[
		| pos |
		pos := evt position.
		evt isDraggingEvent ifTrue: [ 
			| treshold |
			treshold := 0.
			(self submorphs at: 1 ifAbsent: [ nil ])
				ifNotNil: [ :first | treshold := self top-first top ].
			pos y < (self class upperHandLimit+treshold) ifTrue: [ pos := pos x @ (self class upperHandLimit + treshold)] ].
		
		self position: pos.
		self sendMouseEvent: evt.
	] ifFalse:[
		"Issue a synthetic move event if we're not at the position of the event"
		(evt position = self position) ifFalse:[self moveToEvent: evt].
		"Drop submorphs on button events"
		(self hasSubmorphs) 
			ifTrue:[self dropMorphs: evt]
			ifFalse:[self sendMouseEvent: evt].
	].
	self showMouseFocusEvent: evt.
	self mouseOverHandler processMouseOver: lastMouseEvent.! !

!HandMorph methodsFor: 'paste buffer' stamp: ''!
objectToPaste
	"It may need to be sent #startRunning by the client"
	^ Cursor wait showWhile: [PasteBuffer veryDeepCopy]

	"PasteBuffer usableDuplicateIn: self world"! !

!HandMorph methodsFor: 'drop shadows' stamp: ''!
shadowOffset

	^ 6@8! !

!HandMorph methodsFor: 'listeners' stamp: ''!
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: 'focus handling' stamp: ''!
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 |
	keyboardFocus == aMorphOrNil ifTrue: [ ^self ].
	oldFocus := keyboardFocus.
	keyboardFocus := aMorphOrNil.
	
	oldFocus ifNotNil: [oldFocus keyboardFocusChange: false].
	aMorphOrNil ifNotNil: [ aMorphOrNil keyboardFocusChange: true ].! !

!HandMorph methodsFor: 'drawing' stamp: ''!
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: 'private - events' stamp: ''!
pendingEventQueue

	^ pendingEventQueue ifNil: [ pendingEventQueue := WaitfreeQueue new ]! !

!HandMorph methodsFor: 'paste buffer' stamp: ''!
pasteBuffer
	"Return the paste buffer associated with this hand"
	^ PasteBuffer! !

!HandMorph methodsFor: 'drawing' stamp: ''!
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: 'listeners' stamp: ''!
eventListeners
	^eventListeners! !

!HandMorph methodsFor: 'drawing' stamp: ''!
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: 'halo handling' stamp: ''!
releaseHalo: aHalo
	"Used for transfering halos between hands"
	self removeProperty: #halo! !

!HandMorph methodsFor: 'cursor' stamp: ''!
currentCursor: aCursor

	self world currentCursor: aCursor.
	self world isCursorOwner ifTrue: [
		aCursor activateInCursorOwner: self world ]! !

!HandMorph methodsFor: 'focus handling' stamp: ''!
mouseFocus: aMorphOrNil
	mouseFocus := aMorphOrNil! !

!HandMorph methodsFor: 'private - events' stamp: ''!
sendMouseEvent: anEvent
	"Send the event to the morph currently holding the focus, or if none to the owner of the hand."
	^self sendEvent: anEvent focus: self mouseFocus clear:[self mouseFocus: nil]! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: ''!
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: 'cursor' stamp: ''!
showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset 
	"Set the temporary cursor to the given Form.
	If the argument is nil, revert to the normal hardware cursor."

	self changed.
	temporaryCursorOffset 
		ifNotNil: [bounds := bounds translateBy: temporaryCursorOffset negated].
	cursorOrNil 
		ifNil: [temporaryCursor := temporaryCursorOffset := hardwareCursor := nil]
		ifNotNil: 
			[temporaryCursor := cursorOrNil asCursorForm.
			temporaryCursorOffset := temporaryCursor offset - hotSpotOffset.
			(cursorOrNil isKindOf: Cursor) ifTrue: [hardwareCursor := cursorOrNil]].
	bounds := self cursorBounds.
	self
		layoutChanged;
		changed! !

!HandMorph methodsFor: 'focus handling' stamp: ''!
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: 'layout' stamp: ''!
fullBounds
	"Extend my bounds by the shadow offset when carrying morphs."

	| bnds |
	bnds := super fullBounds.
	^ submorphs
		ifEmpty: [ bnds ]
		ifNotEmpty: [ bnds topLeft corner: bnds bottomRight + self shadowOffset ]! !

!HandMorph methodsFor: 'private - events' stamp: ''!
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: 'selected object' stamp: ''!
selectedObject
	"answer the selected object for the hand or nil is none"
	| halo |
	halo := self halo.
	halo ifNil: [^ nil].
	^ halo target renderedMorph! !

!HandMorph methodsFor: 'listeners' stamp: ''!
eventListeners: anArrayOrNil
	eventListeners := anArrayOrNil! !

!HandMorph methodsFor: 'events - processing' stamp: ''!
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 ].
	
	[
		MorphicRenderLoop new doOneCycleWhile: [ release not ].
	] ensure: [
		captureBlock := nil.
	]! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: ''!
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: 'change reporting' stamp: ''!
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: 'events - processing' stamp: ''!
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: 'halo handling' stamp: ''!
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: 'drawing' stamp: ''!
needsToBeDrawn
	"Return true if this hand must be drawn explicitly 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: [ ^ true ].
	"Switch from one hardware cursor to another, if needed."
	cursor := hardwareCursor ifNil: [Cursor normal].
	self currentCursor == cursor ifFalse: [cursor show].
	^ false! !

!HandMorph methodsFor: 'events - processing' stamp: ''!
showDebugEvent: evt

	ShowEvents == true ifTrue: [
		| ofs| 
		Display fill: (0@0 extent: 500@120) rule: Form over fillColor: Color white.
		ofs := (owner hands indexOf: self) - 1 * 60.
		evt printString displayAt: (0@ofs) + (evt isKeyboard ifTrue: [0@30] ifFalse: [0@0]).
		self keyboardFocus printString displayAt: (0@ofs)+(0@45).
		].! !

!HandMorph methodsFor: 'halo handling' stamp: ''!
removeHaloAround: aMorph
	"remove the receiver's halo associated to aMorph (if any)"
	| halo |
	halo := self halo.
	halo
		ifNil: [ ^ self ].
	halo target == aMorph
		ifFalse: [ ^ self ].
	self removeProperty: #halo.
	halo delete.! !

!HandMorph methodsFor: 'private - events' stamp: ''!
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: 'event handling' stamp: ''!
noticeMouseOver: aMorph event: anEvent
	mouseOverHandler ifNil:[^self].
	mouseOverHandler noticeMouseOver: aMorph event: anEvent.! !

!HandMorph methodsFor: 'events - processing' stamp: ''!
waitButton
	self captureEventsUntil: [:evt | self anyButtonPressed ]! !

!HandMorph methodsFor: 'listeners' stamp: ''!
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: 'halo handling' stamp: ''!
obtainHalo: aHalo
	"Used for transfering halos between hands"

	self halo == aHalo
		ifTrue: [ ^ self ].	
	"Find former owner"
	self world hands detect: [ :hand | hand halo == aHalo ] ifFound: [ :formerOwner | formerOwner releaseHalo: aHalo ].
	self halo: aHalo! !

!HandMorph methodsFor: 'halos and balloon help' stamp: ''!
halo
	"Return the halo associated with this hand, if any"
	^self valueOfProperty: #halo! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: ''!
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: 'private - events' stamp: ''!
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: 'accessing' stamp: ''!
anyButtonPressed
	^lastMouseEvent anyButtonPressed! !

!HandMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self initForEvents.
	bounds := 0 @ 0 extent: Cursor normal extent.
	damageRecorder := DamageRecorder new.
	cachedCanvasHasHoles := false.
	supressNextKeyPress := false.
	self initForEvents! !

!HandMorph methodsFor: 'listeners' stamp: ''!
keyboardListeners
	^nil! !

!HandMorph methodsFor: 'initialization' stamp: ''!
interrupted
	"Something went wrong - we're about to bring up a debugger. 
	Release some stuff that could be problematic."
	self releaseAllFocus. "or else debugger might not handle clicks"! !

!HandMorph methodsFor: 'drawing' stamp: ''!
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].
			self currentCursor == cursor ifFalse: [cursor show].	"show hardware cursor"
			savedPatch := nil]! !

!HandMorph methodsFor: 'drawing' stamp: ''!
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"
	cachedCanvasHasHoles 
		ifTrue: [aCanvas paintImage: cacheCanvas form at: subBnds origin]
		ifFalse: 	[
			aCanvas 
			drawImage: cacheCanvas form
			at: subBnds origin
			sourceRect: cacheCanvas form boundingBox
		].
	self drawOn: aCanvas	"draw the hand itself in front of morphs"! !

!HandMorph methodsFor: 'halo handling' stamp: ''!
removeHalo
	"remove the receiver's halo (if any)"
	self halo ifNotNil: [ :h | self removeHaloAround: h target ]! !

!HandMorph methodsFor: 'balloon help' stamp: ''!
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: 'accessing' stamp: ''!
noButtonPressed
	"Answer whether any mouse button is not being pressed."

	^self anyButtonPressed not! !

!HandMorph methodsFor: 'listeners' stamp: ''!
removeEventListener: anObject
	"Remove anObject from the current event listeners."
	self eventListeners: (self removeListener: anObject from: self eventListeners).! !

!HandMorph methodsFor: 'updating' stamp: ''!
changed

	hasChanged := true.! !

!HandMorph methodsFor: 'geometry' stamp: ''!
position

	^temporaryCursor
		ifNil: [bounds topLeft]
		ifNotNil: [
			temporaryCursorOffset 
				ifNil: [ bounds topLeft ]
				ifNotNil: [ :anOffset | bounds topLeft - anOffset ] ]! !

!HandMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	"Draw the hand itself (i.e., the cursor)."

	temporaryCursor 
		ifNotNil: [aCanvas paintImage: temporaryCursor at: bounds topLeft].! !

!HandMorph methodsFor: 'halo handling' stamp: ''!
removeHaloFromClick: anEvent on: aMorph 
	| halo |
	halo := self halo
				ifNil: [^ self].
	(halo target hasOwner: self)
		ifTrue: [^ self].
	(halo staysUpWhenMouseIsDownIn: aMorph)
		ifFalse: [self removeHalo]! !

!HandMorph methodsFor: 'accessing' stamp: ''!
targetOffset
	"Return the offset of the last mouseDown location relative to the origin of the recipient morph. During menu interactions, this is the absolute location of the mouse down event that invoked the menu."

	^ targetOffset! !

!HandMorph methodsFor: 'accessing' stamp: ''!
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: 'events - processing' stamp: ''!
showMouseFocusEvent: evt

	ShowEvents == true ifTrue: [
		| ofs| 
		ofs := (owner hands indexOf: self) - 1 * 60.
		self mouseFocus printString displayAt: (0@ofs) + (0@15)].! !

!HandMorph methodsFor: 'balloon help' stamp: ''!
removePendingBalloonFor: aMorph
	"Get rid of pending balloon help."
	self removeAlarm: #spawnBalloonFor:.
	self deleteBalloonTarget: aMorph.! !

!HandMorph methodsFor: 'private - events' stamp: ''!
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].
	result := owner processEvent: anEvent.
	^result! !

!HandMorph methodsFor: 'balloon help' stamp: ''!
balloonHelp
	"Return the balloon morph associated with this hand"
	^self valueOfProperty: #balloonHelpMorph! !

!HandMorph methodsFor: 'private - events' stamp: ''!
queuePendingEvent: aMorphicEvent
	"Queue an (extra) event produced during an event handling cycle, to be processed in later cycles.
	An event handling cycle should generate and manage a single event.
	In the case a cycle needs to generate several events (see MouseClickState), only one event is handled.
	Remaining events are queued for later processing.
	"
	self pendingEventQueue nextPut: aMorphicEvent! !

!HandMorph methodsFor: 'private - events' stamp: ''!
processEvents

	"Process user input events from the local input devices."

	| evt |

	[ (evt := self pendingEventQueue nextOrNil) notNil ] whileTrue: [ 
		evt == #invalid ifTrue: [ ^ self ].
		evt ifNotNil: [ "Finally, handle it"
			self handleEvent: evt.
			"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 ].! !

!HandMorph methodsFor: 'accessing' stamp: ''!
colorForInsets
	"Morphs being dragged by the hand use the world's color"
	^ owner colorForInsets! !

!HandMorph methodsFor: 'private - events' stamp: ''!
mapSymbolToKeyValue: keyValue

	"Backwards compatibility.
	Transform a VM keycode to a corresponding ascii value"

	^ { KeyboardKey down -> 31.
		KeyboardKey keypadDown -> 31.
		KeyboardKey left -> 28.
		KeyboardKey keypadLeft -> 28.
		KeyboardKey right -> 29.
		KeyboardKey keypadRight -> 29.
		KeyboardKey up -> 30.
		KeyboardKey keypadUp -> 30.
		KeyboardKey enter -> 13.
		KeyboardKey keypadEnter -> 13.
		KeyboardKey tab -> 9.
		KeyboardKey backspace -> 8.
		} asDictionary
		at: (Smalltalk os keyForValue: keyValue)
		ifAbsent: [ 0 ]! !

!HandMorph methodsFor: 'caching' stamp: ''!
releaseCachedState
	| oo |
	super releaseCachedState.
	cacheCanvas := nil.
	oo := owner.
	self removeAllMorphs.
	self initialize.	"nuke everything"
	self privateOwner: oo.
	self releaseAllFocus.! !

!HandMorph methodsFor: 'accessing' stamp: ''!
mouseOverHandler
	^mouseOverHandler ifNil:[mouseOverHandler := MouseOverHandler new].! !

!HandMorph methodsFor: 'initialization' stamp: ''!
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: 'classification' stamp: ''!
isHandMorph

	^ true! !

!HandMorph methodsFor: 'accessing' stamp: ''!
shiftPressed
	^lastMouseEvent shiftPressed! !

!HandMorph methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  Do not copy hands this way."
	^ self! !

!HandMorph methodsFor: 'private - events' stamp: ''!
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: 'grabbing/dropping' stamp: ''!
dropMorphs
	"Drop the morphs at the hands position"
	self dropMorphs: lastMouseEvent.! !

!HandMorph methodsFor: 'focus handling' stamp: ''!
releaseAllFocus
	mouseFocus := nil.
	self newKeyboardFocus: nil.! !

!HandMorph methodsFor: 'private - events' stamp: ''!
sendFocusEvent: anEvent to: focusHolder clear: aBlock
	"Send the event to the morph currently holding the focus"
	| result w transformedEvent |
	
	w := focusHolder world ifNil:[^ aBlock value].
	transformedEvent := anEvent transformedBy: (focusHolder transformedFrom: self).

	w becomeActiveDuring:[
		result := focusHolder handleFocusEvent: transformedEvent.
	].

	"As I am copying the event, I have to propagate the supressNextKeyPress, so it is correctly handled."
	anEvent isKeyboard 
		ifTrue: [ anEvent supressNextKeyPress: transformedEvent supressNextKeyPress ]. 

	^result! !

!HandMorph methodsFor: 'focus handling' stamp: ''!
releaseKeyboardFocus: aMorph
	"If the given morph had the keyboard focus before, release it"
	self keyboardFocus == aMorph ifTrue:[self releaseKeyboardFocus].! !

!HandMorph methodsFor: 'drawing' stamp: ''!
visible: aBoolean
	self needsToBeDrawn ifFalse: [ ^self ].
	super visible: aBoolean! !

!HandMorph methodsFor: 'meta-actions' stamp: ''!
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: 'grabbing/dropping' stamp: ''!
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: 'drawing' stamp: ''!
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: ''!
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: 'focus handling' stamp: ''!
mouseFocus
	^mouseFocus! !

!HandMorph methodsFor: 'focus handling' stamp: ''!
newMouseFocus: aMorph event: event 
	aMorph ifNotNil: [targetOffset := event cursorPoint - aMorph position].
	^self newMouseFocus: aMorph! !

!HandMorph methodsFor: 'cursor' stamp: ''!
temporaryCursor
	^ temporaryCursor! !

!HandMorph class methodsFor: 'events - processing' stamp: ''!
logEventStatsStop
	EventStats := nil.! !

!HandMorph class methodsFor: 'accessing' stamp: ''!
upperHandLimit

	^ UpperHandLimit ifNil: [ UpperHandLimit := 0 ]! !

!HandMorph class methodsFor: 'class initialization' stamp: ''!
initialize
	"HandMorph initialize"

	PasteBuffer := nil.
	DoubleClickTime := 350.
	NormalCursor := CursorWithMask normal asCursorForm.! !

!HandMorph class methodsFor: 'events - processing' stamp: ''!
logEventStats: evt
	EventStats ifNotNil: [
		EventStats at: #count put: (EventStats at: #count ifAbsent:[0]) + 1.
		EventStats at: evt type put: (EventStats at: evt type ifAbsent:[0]) + 1.
		].! !

!HandMorph class methodsFor: 'events - processing' stamp: ''!
logEventStatsStart
	EventStats ifNil:[EventStats := IdentityDictionary new].! !

!HandMorph class methodsFor: 'accessing' stamp: ''!
doubleClickTime: milliseconds

	DoubleClickTime := milliseconds.! !

!HandMorph class methodsFor: 'settings' stamp: ''!
logEventStatsEnabled: aBoolean
	aBoolean
		ifTrue: [ self logEventStatsStart ]
		ifFalse: [ self logEventStatsStop ].! !

!HandMorph class methodsFor: 'settings' stamp: ''!
logEventStatsEnabled
	"self logEventStatsEnabled"
	^ EventStats isNotNil! !

!HandMorph class methodsFor: 'events - processing' stamp: ''!
eventStats
	^ EventStats ifNil: [ 'EventStats are disabled' ].! !

!HandMorph class methodsFor: 'utilities' stamp: ''!
showEvents: aBool
	"HandMorph showEvents: true"
	"HandMorph showEvents: false"
	ShowEvents := aBool.
	aBool ifFalse: [ self currentWorld invalidRect: (0@0 extent: 500@120) ].! !

!HandMorph class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #handMorphsLogEventStats)
		parent: #pharoSystem;
		label: 'HandMorph event statistics';
		target: self;
		default: false;
		selector: #logEventStatsEnabled;
		description: 'Enable/disable gathering global statistics of events handled by HandMorphs.
"HandMorph eventStats inspect"'! !

!HandMorph class methodsFor: 'accessing' stamp: ''!
doubleClickTime

	^ DoubleClickTime! !

!HandMorph class methodsFor: 'cleanup' stamp: ''!
cleanUp
	"Called from ImageCleaner>>cleanUpForRelease --> SmalltalkImage>>cleanUp:except:confirming:"
	self logEventStatsStop.! !

!HandMorph class methodsFor: 'accessing' stamp: ''!
upperHandLimit: anInteger

	UpperHandLimit := anInteger! !

!HandleMorph commentStamp: ''!
A HandleMorph provides mouse-up control behavior.!
!HandleMorph methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	self extent: 8 @ 8! !

!HandleMorph methodsFor: 'stepping' stamp: ''!
step

	pointBlock value: self center! !

!HandleMorph methodsFor: 'dropping/grabbing' stamp: ''!
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 ].	"Probably unnecessary"
	anEvent hand releaseKeyboardFocus: self.
	self
		changed;
		delete! !

!HandleMorph methodsFor: 'iterating' stamp: ''!
forEachPointDo: aBlock lastPointDo: otherBlock

	pointBlock := aBlock.
	lastPointBlock := otherBlock! !

!HandleMorph methodsFor: 'event handling' stamp: ''!
keyDown: 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"
			"Probably unnecessary"
			owner releaseKeyboardFocus: self.
			self delete ]! !

!HandleMorph methodsFor: 'iterating' stamp: ''!
forEachPointDo: aBlock

	pointBlock := aBlock! !

!HandleMorph methodsFor: 'stepping' stamp: ''!
stepTime
	"Update every hundredth of a second."
	
	^ 10! !

!HashAndEqualsTestCase commentStamp: ''!
I am an abstract TestCase superclass that tests for correct operation of #hash and #=.

Subclasses of me need to fill my prototypes with suitable objects to be tested.!
!HashAndEqualsTestCase methodsFor: 'tests' stamp: ''!
testEquality
	"Check that prototypes report equality correctly"

	prototypes do: [:p | self assert: (EqualityTester with: p) result ]! !

!HashAndEqualsTestCase methodsFor: 'tests' stamp: ''!
testHash
	"Check prototypes with equality method hash correctly"

	prototypes do: [:p | self assert: (HashTester with: p) result ]! !

!HashAndEqualsTestCase methodsFor: 'running' stamp: ''!
setUp
	"Subclasses will add their prototypes into this collection"

	super setUp.
	prototypes := OrderedCollection new! !

!HashAndEqualsTestCase class methodsFor: 'tests' stamp: ''!
isAbstract 

	^self == HashAndEqualsTestCase ! !

!HashFunction commentStamp: ''!
Common superclass for hash functions!
!HashFunction methodsFor: 'accessing' stamp: ''!
doubleHashStream: aStream
	^ self hashStream: ((self hashStream: aStream) asByteArray readStream)! !

!HashFunction methodsFor: 'accessing' stamp: ''!
hashMessage: aStringOrByteArray
	"MD5 new hashMessage: 'foo'"
	^ self hashStream: aStringOrByteArray asByteArray readStream! !

!HashFunction methodsFor: 'accessing' stamp: ''!
hashSize
	^ self class hashSize! !

!HashFunction methodsFor: 'accessing' stamp: ''!
hashStream: aStream
	^ self subclassResponsibility! !

!HashFunction methodsFor: 'converting' stamp: ''!
hmac
	^ HMAC on: self! !

!HashFunction methodsFor: 'accessing' stamp: ''!
blockSize
	^ self class blockSize! !

!HashFunction methodsFor: 'accessing' stamp: ''!
doubleHashMessage: aStringOrByteArray
	"SHA1 new doubleHashMessage: 'foo'"
	^ self doubleHashStream: aStringOrByteArray asByteArray readStream! !

!HashFunction class methodsFor: 'hashing' stamp: ''!
hashMessage: aStringOrByteArray
	^ self new hashMessage: aStringOrByteArray! !

!HashFunction class methodsFor: 'accessing' stamp: ''!
hashSize
	^ self subclassResponsibility! !

!HashFunction class methodsFor: 'hashing' stamp: ''!
hashStream: aPositionableStream
	^ self new hashStream: aPositionableStream! !

!HashFunction class methodsFor: 'accessing' stamp: ''!
blockSize
	^ self subclassResponsibility! !

!HashTableSizes commentStamp: ''!
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 primary 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. It is ordered, and is binary searched to find the closest good size >= the requested size.

This class caches a second table built from the first to support faster direct lookup of primes for requested sizes in the range of 0 to "self maxSmallSize".!
!HashTableSizes methodsFor: 'private' stamp: ''!
primeAlmostFactorsOf: anInteger
	"Answer primes less than anInteger whose remainder when dividing anInteger is small"

	| factors |
	factors := OrderedCollection new.
	anInteger even ifTrue: [factors add: 2].
	3 to: anInteger // 2 + 2 by: 2 do: [:i | 
		(i isPrime and: [| remainder | 
						remainder := anInteger \\ i.
						remainder <= 1 or: [remainder = (i - 1)]])
			ifTrue: [factors add: i]].
	^factors asArray! !

!HashTableSizes methodsFor: 'private' stamp: ''!
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."

	| limit |

	candidate := self firstCandidateForExp: exp.
	limit := self limitForExp: exp.
	[ self candidateIsGoodPrime ]
		whileFalse:
			[ candidate := candidate + 2.
			candidate > limit
				ifTrue: [ ^ nil ] ].
	^ candidate! !

!HashTableSizes methodsFor: 'initialization' stamp: ''!
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: ''!
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: ''!
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: ''!
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: ''!
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: ''!
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 class methodsFor: 'private' stamp: ''!
basicAtLeast: lowerLimit
	"Binary search for 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: 'class initialization' stamp: ''!
initialize
	"Throw away any previously-cached sizes, then compute and cache the sizes."
	"self initialize"

	sizes := nil.
	self sizes.

	smallSizesLookupTable := nil.
	self smallSizesLookupTable! !

!HashTableSizes class methodsFor: 'private' stamp: ''!
sizes
	sizes
		ifNil: [
			"Compute a sorted Array of known good table sizes that can be
			binary searched with #basicAtLeast:."
			sizes := self new computeSizes ].
	^ sizes! !

!HashTableSizes class methodsFor: 'private' stamp: ''!
smallSizesLookupTable
	smallSizesLookupTable
		ifNil: [
			"Compute a lookup table of known good table sizes by caching the
			result of binary searching 'sizes' with #basicAtLeast: for a range
			of small sizes from 0 to #maxSmallSize."
			smallSizesLookupTable :=
				(0 to: self maxSmallSize) asArray collect: [ :each |
					self basicAtLeast: each ] ].
	^ smallSizesLookupTable! !

!HashTableSizes class methodsFor: 'public' stamp: ''!
atLeast: lowerLimit
	"Answer the next good size >= lowerlimit.
	If lowerLimit is larger than the largest known good prime,
	just make it odd."

	^ lowerLimit <= self maxSmallSize
		ifTrue: [
			self smallSizesLookupTable at:
				(lowerLimit <= 0
					ifTrue: [ 1 ]
					ifFalse: [ lowerLimit ceiling + 1 ]) ]
		ifFalse: [ self basicAtLeast: lowerLimit ]! !

!HashTableSizes class methodsFor: 'private' stamp: ''!
maxSmallSize
	^ 255! !

!HashTableSizes class methodsFor: 'private' stamp: ''!
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"! !

!HashTableSizesTest commentStamp: ''!
SUnit test for HashTableSizes!
!HashTableSizesTest methodsFor: 'tests' stamp: ''!
testAtLeast
	-1000 to: 1000 do: [ :limit | 
		| size |
		"#atLeast: should answer the next known good prime not less than i, or
		the next odd integer if i is greater than the largest known good prime."
		size := HashTableSizes atLeast: limit.
		self
			assert: size >= limit;
			assert: size positive;
			assert: size isInteger;
			assert: (size isPrime or: [ size odd ]).
		"it should behave the same as the lower-level #basicAtLeast: it relies on"
		self assert: size equals: (HashTableSizes basicAtLeast: limit) ].

	-1000.1 to: 1000.1 do: [ :limit | 
		| size |
		size := HashTableSizes atLeast: limit.
		self
			assert: size > limit;
			"do not round fractional limits down"
				assert: size positive;
			assert: size isInteger;
			assert: (size isPrime or: [ size odd ]);
			assert: size equals: (HashTableSizes basicAtLeast: limit) ]! !

!HashTester commentStamp: ''!
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: 'operation' stamp: ''!
resultFor: runs
	"Test that the hash is the same over runs and answer the result"

	| hash |
	hash := self prototype hash.
	1 to: runs do: [ :i | hash = self prototype hash ifFalse: [ ^ false ] ].
	^ true! !

!HashTesterTest commentStamp: ''!
I am a simple test case to check that HashTester works correctly!
!HashTesterTest methodsFor: 'tests' stamp: ''!
testBasicBehaviour

	self
		assert: ((HashTester with: 1) resultFor: 100);
		assert: ((HashTester with: 'fred') resultFor: 100);
		deny: ((HashTester with: BadHasher new) resultFor: 100)! !

!HashedCollection commentStamp: ''!
I am an abstract collection of objects that implement hash and equality in a consistent 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:		<ArrayedCollection> (typically Array or WeakArray)
	tally:		<Integer> (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: 'private' stamp: ''!
scanForEmptySlotFor: aKey
	"Scan the key array for the first slot containing an empty slot (indicated by a nil). Answer the index of that slot. This method will be overridden in various subclasses that have different interpretations for matching elements."
	
	| index start |
	index := start := aKey hash \\ array size + 1.
	[ 
		(array at: index) ifNil: [ ^index ].
		(index := index \\ array size + 1) = start ] whileFalse.
	self errorNoFreeSpace! !

!HashedCollection methodsFor: 'private' stamp: ''!
errorNoFreeSpace

	self error: 'There is no free space in this collection!!'! !

!HashedCollection methodsFor: '*Monticello-Storing' stamp: 'nil'!
comeFullyUpOnReload: smartRefStream
	"Symbols have new hashes in this image."

	self  compact.
	"^ self"
! !

!HashedCollection methodsFor: 'private' stamp: ''!
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: ''!
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: ''!
atNewIndex: index put: anObject
	array at: index put: anObject.
	tally := tally + 1.
	self fullCheck! !

!HashedCollection methodsFor: '*Fuel-Core' stamp: ''!
fuelAfterMaterialization

	self rehash! !

!HashedCollection methodsFor: 'enumerating' stamp: ''!
union: aCollection
	"Answer the set theoretic union of the receiver and aCollection, using the receiver's notion of equality and not side effecting the receiver at all."

	^ self copy addAll: aCollection; yourself! !

!HashedCollection methodsFor: 'private' stamp: ''!
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 ifNotNil: [ self noCheckAdd: each ] ]! !

!HashedCollection methodsFor: 'private' stamp: ''!
array
	^ array! !

!HashedCollection methodsFor: 'private' stamp: ''!
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: ''!
noCheckAdd: anObject

    self subclassResponsibility! !

!HashedCollection methodsFor: 'private' stamp: ''!
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: 'initialization' stamp: ''!
initialize: n
	"Initialize array to an array size of n"
	array := Array new: n.
	tally := 0! !

!HashedCollection methodsFor: 'adding' stamp: ''!
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: 'private' stamp: ''!
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: ''!
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: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	| copyOfSelf|
	copyOfSelf := super veryDeepCopyWith: deepCopier.
	"force Sets and Dictionaries to rehash"
	copyOfSelf rehash.
		^ copyOfSelf! !

!HashedCollection methodsFor: '*Reflectivity' stamp: ''!
metaLinkOptions
	^{
	#findElementOrNil: -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!HashedCollection methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
capacity
	"Answer the current capacity of the receiver."

	^ array size! !

!HashedCollection methodsFor: 'removing' stamp: ''!
removeAll
	"remove all elements from this collection.
	Preserve the capacity"
	
	self initialize: self capacity! !

!HashedCollection methodsFor: 'accessing' stamp: ''!
size
	^ tally! !

!HashedCollection methodsFor: 'private' stamp: ''!
growSize
	"Answer what my next higher table size should be"

	^HashTableSizes atLeast: self capacity * 3 // 2 + 2! !

!HashedCollection methodsFor: 'private' stamp: ''!
rehash
	self growTo: self capacity! !

!HashedCollection class methodsFor: 'instance creation' stamp: ''!
new
	^ self basicNew
		initialize: 5;
		yourself! !

!HashedCollection class methodsFor: 'instance creation' stamp: ''!
new: nElements
	"Create a Set large enough to hold nElements without growing"
	^ self basicNew initialize: (self sizeFor: nElements)! !

!HashedCollection class methodsFor: 'cleanup' stamp: ''!
compactAll
	"HashedCollection compactAll"	
		
	self allSubclassesDo: #compactAllInstances! !

!HashedCollection class methodsFor: 'instance creation' stamp: ''!
empty
	^ self basicNew
		initialize: 1;
		yourself! !

!HashedCollection class methodsFor: 'cleanup' stamp: ''!
cleanUp: aggressive
	"Rehash all instances when cleaning aggressively"

	aggressive ifTrue: [self compactAll].! !

!HashedCollection class methodsFor: 'testing' stamp: ''!
isAbstract

	^self name = #HashedCollection! !

!HashedCollection class methodsFor: 'cleanup' stamp: ''!
compactAllInstances
	"Do not use #allInstancesDo: because rehash may create new instances."
	
	self allInstances do: [ :each | each compact ]! !

!HashedCollection class methodsFor: 'instance creation' stamp: ''!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."
	^self subclassResponsibility! !

!HashedCollection class methodsFor: 'cleanup' stamp: ''!
rehashAllInstances
	"Do not use #allInstancesDo: because rehash may create new instances."
	
	self allInstances do: [ :each | each rehash ]! !

!HashedCollection class methodsFor: 'cleanup' stamp: ''!
rehashAll
	"HashedCollection rehashAll"	
		
	self allSubclassesDo: #rehashAllInstances! !

!HashedCollection class methodsFor: 'instance creation' stamp: ''!
sizeFor: nElements
	"Large enough size to hold nElements with some slop (see fullCheck)"
	
	nElements < 4 ifTrue: [ ^5 ].
	^ HashTableSizes atLeast: nElements +1 * 4 // 3! !

!Heap commentStamp: ''!
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           <Array>         The data repository
       tally           <Integer>       The number of elements in the heap
       sortBlock       <Block|nil>     A two-argument block defining the sort order,
                                                       or nil in which case the default sort order is
                                                               [:element1 :element2| element1 <= element2]
       indexUpdateBlock        <Block|nil>
                                                       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: 'testing' stamp: 'nil'!
isEmpty
	"Answer whether the receiver contains any elements."
	^tally = 0! !

!Heap methodsFor: 'comparing' stamp: 'nil'!
= 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: 'adding' stamp: 'nil'!
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: 'removing' stamp: 'nil'!
removeFirst
	"Remove the first element from the receiver"
	self emptyCheck.
	^self privateRemoveAt: 1! !

!Heap methodsFor: 'growing' stamp: 'nil'!
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: 'private' stamp: 'nil'!
upHeap: anIndex
	"Check the heap upwards for correctness starting at anIndex.
	 Everything below anIndex is ok."
	| value k kDiv2 tmp |
	anIndex = 0 ifTrue:[^self].
	k := anIndex.
	value := array at: anIndex.
	[ (k > 1) and:[self sorts: value before: (tmp := array at: (kDiv2 := k bitShift: -1))] ] 
		whileTrue:[
			array at: k put: tmp.
			self updateObjectIndex: k.
			k := kDiv2].
	array at: k put: value.
	self updateObjectIndex: k.! !

!Heap methodsFor: 'testing' stamp: 'nil'!
isHeap

	^ true! !

!Heap methodsFor: 'private' stamp: 'nil'!
setCollection: aCollection tally: newTally
	array := aCollection.
	tally := newTally.! !

!Heap methodsFor: 'private' stamp: 'nil'!
updateObjectIndex: index
	"If indexUpdateBlock is not nil, notify the object at index of its new position in the heap array."
	indexUpdateBlock ifNotNil: [
		indexUpdateBlock value: (array at: index) value: index]! !

!Heap methodsFor: 'sorting' stamp: 'nil'!
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: 'sorting' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
at: index
	"Heap are not designed to be accessed sequentially."
	
	self shouldNotImplement.! !

!Heap methodsFor: 'growing' stamp: 'nil'!
grow
	"Become larger."
	self growTo: self size + self growSize.! !

!Heap methodsFor: 'enumerating' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
first
	"Return the first element in the receiver"
	^array at: 1! !

!Heap methodsFor: 'accessing' stamp: 'nil'!
sortBlock: aBlock
	sortBlock := aBlock.
	self reSort.! !

!Heap methodsFor: '*Kernel-Processes' stamp: ''!
removeFirstOrNil
	"Remove the first element from the receiver"
	self isEmpty ifTrue:  [ ^nil ].
	^self privateRemoveAt: 1! !

!Heap methodsFor: 'private' stamp: 'nil'!
setCollection: aCollection
	array := aCollection.
	tally := 0.! !

!Heap methodsFor: 'sorting' stamp: 'nil'!
sorted
	"Return a new sequenceable collection which contains the same elements as self but its 
elements are sorted in ascending order using the #'<=' operator."
	
	^self sorted: [ :a :b| a <= b ]! !

!Heap methodsFor: 'private' stamp: 'nil'!
array
	^array! !

!Heap methodsFor: 'enumerating' stamp: 'nil'!
collect: aBlock
	^self collect: aBlock as: Array! !

!Heap methodsFor: 'sorting' stamp: 'nil'!
sort
	"Sort this collection into ascending order using the '<=' operator."

	self sort: [:a :b | a <= b]! !

!Heap methodsFor: 'sorting' stamp: 'nil'!
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: 'private' stamp: 'nil'!
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: 'sorting' stamp: 'nil'!
sorted: aSortBlockOrNil
	"Return a new sequenceable collection which contains the same elements as self but its 
elements are sorted by aSortBlockOrNil. The block should take two arguments and return true if 
the first element should preceed the second one. If aSortBlock is nil then <= is used for 
comparison."
	
	^self copy sort: aSortBlockOrNil! !

!Heap methodsFor: 'private' stamp: 'nil'!
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: 'testing' stamp: 'nil'!
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: 'sorting' stamp: 'nil'!
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: 'copying' stamp: 'nil'!
copyEmpty
	"Answer a copy of the receiver without any of the receiver's elements."

	^self class sortBlock: sortBlock! !

!Heap methodsFor: 'accessing' stamp: 'nil'!
at: index put: newObject
	"Heap are not designed to be accessed sequentially.
	Please consider using #add: instead."
	
	self shouldNotImplement.! !

!Heap methodsFor: 'sorting' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
indexUpdateBlock: aBlockOrNil

	indexUpdateBlock := aBlockOrNil.! !

!Heap methodsFor: 'sorting' stamp: 'nil'!
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: 'copying' stamp: 'nil'!
postCopy
	super postCopy.
	array := array copy! !

!Heap methodsFor: 'accessing' stamp: 'nil'!
defaultSortBlock
	^ self class defaultSortBlock! !

!Heap methodsFor: 'removing' stamp: 'nil'!
removeAll

	array atAllPut: nil.
	tally := 0! !

!Heap methodsFor: 'private' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
size
	"Answer how many elements the receiver contains."

	^ tally! !

!Heap methodsFor: 'accessing' stamp: 'nil'!
reSort
	"Resort the entire heap"
	self isEmpty ifTrue:[^self].
	tally // 2 to: 1 by: -1 do:[:i| self downHeap: i].! !

!Heap methodsFor: 'private' stamp: 'nil'!
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: 'sorting' stamp: 'nil'!
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: 'growing' stamp: 'nil'!
trim
	"Remove any empty slots in the receiver."
	self growTo: self size.! !

!Heap methodsFor: 'accessing' stamp: 'nil'!
sortBlock
	^ sortBlock ifNil: [ sortBlock := self defaultSortBlock ]! !

!Heap methodsFor: 'growing' stamp: 'nil'!
growSize
	"Return the size by which the receiver should grow if there are no empty slots left."
	^array size max: 5! !

!Heap methodsFor: 'removing' stamp: 'nil'!
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 class methodsFor: 'instance creation' stamp: 'nil'!
new
	^self new: 10! !

!Heap class methodsFor: 'instance creation' stamp: 'nil'!
new: n
	^super new setCollection: (Array new: n)! !

!Heap class methodsFor: 'instance creation' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
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: 'examples' stamp: 'nil'!
heapSortExample	
	"self 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)."
	
	^ String streamContents: [ :str | 
		| 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].
		].
	str << 'Time for heap-sort: ' << time printString << ' msecs ';cr.
	"The quicksort version"
	time := Time millisecondsToRun:[
		sorted := SortedCollection withAll: array.
	].
	str << 'Time for quick-sort: ' << time printString <<' msecs '; cr.
	"The merge-sort version"
	time := Time millisecondsToRun:[
		array mergeSortFrom: 1 to: array size by: [:v1 :v2| v1 <= v2].
	].
	str << 'Time for merge-sort: ' << time printString  << ' msecs'; cr.
	]! !

!Heap class methodsFor: 'instance creation' stamp: 'nil'!
sortBlock: aBlock
	"Create a new heap sorted by the given block"
	^self new sortBlock: aBlock! !

!Heap class methodsFor: 'examples' stamp: 'nil'!
heapExample	
	"self 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."
	
	^ String streamContents: [ :str | 
		| 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 := self withAll: array.
			1 to: n do:[:i| 
				sorted removeFirst.
				sorted add: rnd next].
	].
	str << 'Time for Heap: ' << time printString <<' msecs '; cr.
	"The quicksort version"
	time := Time millisecondsToRun:[
		sorted := SortedCollection withAll: array.
		1 to: n do:[:i| 
			sorted removeFirst.
			sorted add: rnd next].
	].
	str << 'Time for SortedCollection: '<< time printString << ' msecs'.]! !

!Heap class methodsFor: 'instance creation' stamp: 'nil'!
withAll: aCollection sortBlock: aBlock
	"Create a new heap with all the elements from aCollection"
	^(self basicNew)
		setCollection: aCollection asArray copy tally: aCollection size;
		sortBlock: aBlock;
		yourself! !

!HeapTest commentStamp: ''!
SUnit tests for heap collections!
!HeapTest methodsFor: 'requirements' stamp: ''!
collection
	^ collectionWith4Elements! !

!HeapTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne)! !

!HeapTest methodsFor: 'requirements' stamp: ''!
elementInForElementAccessing
	" return an element inculded in 'moreThan4Elements'"
	^ self moreThan4Elements anyOne.! !

!HeapTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!HeapTest methodsFor: 'tests - as identity set' stamp: ''!
testAsIdentitySetWithIdentityEqualsElements

	| result |
	result := self collectionWithIdentical asIdentitySet.
	" Only one element should have been removed as two elements are equals with Identity equality"
	self assert: result size = (self collectionWithIdentical size - 1).
	self collectionWithIdentical do: 
		[ :each | 
		(self collectionWithIdentical occurrencesOf: each) > 1 
			ifTrue: 
				[ "the two elements equals only with classic equality shouldn't 'have been removed"
				self assert: (result asOrderedCollection occurrencesOf: each) = 1
				" the other elements are still here" ]
			ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ].
	self assert: result class = IdentitySet! !

!HeapTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithElementAlreadyIn

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	oldSize := collection size.
	anElement := self element.
	self assert: (collection includes: anElement).
	
	added := collection addIfNotPresent: anElement.
	
	self assert: added == anElement .	"test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: oldSize! !

!HeapTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!HeapTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!HeapTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!HeapTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!HeapTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllSuchThat

	| el aSubCollection |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := self nonEmptyWithoutEqualElements copyWithout: el.
	self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | aSubCollection includes: each ].
	self assert: self nonEmptyWithoutEqualElements size = 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionOfSize5
	" return a collection of size 5"
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index between bounds of 'nonEmpty'"

	^ 2! !

!HeapTest methodsFor: 'requirements' stamp: ''!
moreThan3Elements
	" return a collection including atLeast 3 elements"
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!HeapTest methodsFor: 'requirements' stamp: ''!
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  "
	^ stringCollection! !

!HeapTest methodsFor: 'requirements' stamp: ''!
moreThan4Elements

	" return a collection including at leat 4 elements"
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'tests - adding' stamp: ''!
testTAddWithOccurrences
	| 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 equals: (oldSize + 5)! !

!HeapTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!HeapTest methodsFor: 'tests - as identity set' stamp: ''!
testAsIdentitySetWithoutIdentityEqualsElements

	| result collection |
	collection := self collectionWithCopy.
	result := collection asIdentitySet.
	" no elements should have been removed as no elements are equels with Identity equality"
	self assert: result size = collection size.
	collection do: 
		[ :each | 
		(collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ].
	self assert: result class = IdentitySet! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
testCopySameClass
	"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: 'requirements' stamp: ''!
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: ''!
otherCollection
	^ otherCollection! !

!HeapTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!HeapTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementReallyRemovesElement
 
	| size |
	size := self nonEmptyWithoutEqualElements size.
	self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne.
	self assert: size - 1 = self nonEmptyWithoutEqualElements size! !

!HeapTest methodsFor: 'tests - growable' stamp: ''!
testAddEmptyGrows
	
	| oldSize |
	oldSize := self empty size.
	self empty add: self element.
	self assert: (self empty size) = (oldSize + 1).! !

!HeapTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!HeapTest methodsFor: 'tests - adding' stamp: ''!
testTAddAll

	| added collection toBeAdded |
	collection := self collectionWithElement.
	toBeAdded := self otherCollection.
	added := collection addAll: toBeAdded.
	self assert: added == toBeAdded .	"test for identiy because #addAll: has not reason to copy its parameter."
	self assert: (collection includesAll: toBeAdded )! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
	" return a collection for wich each element is not included in 'nonEmpty' "
	^ collectionNotIncluded! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!HeapTest methodsFor: 'requirements' stamp: ''!
nonEmptyMoreThan1Element
	" return a collection that don't includes equal elements'" 
	^nonEmpty5ElementsWithoutDuplicate .! !

!HeapTest methodsFor: 'basic tests' stamp: ''!
testAdd
	
	| heap |
	heap := Heap new.
	self assert: heap size equals: 0.
	heap add: 3.
	self assert: heap size equals: 1.
	self deny: heap isEmpty.
	self assert: heap first equals: 3.
	heap add: 2.
	self assert: heap size equals: 2.
	self assert: heap first equals: 2! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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: 'requirements' stamp: ''!
elementToAdd
	" return an element of type 'nonEmpy' elements'type'"
	^ elementNotIn! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
testCopyNonEmptyWithoutAllNotIncluded

	| res |
	res := self nonEmpty copyWithoutAll: self collectionNotIncluded.
	"here we do not test the size since for a non empty set we would get a problem.
	Then in addition copy is not about duplicate management. The element should 
	be in at the end."
	self nonEmpty do: [ :each | self assert: (res includes: each) ]! !

!HeapTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	^ elementNotIn! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRequirementsOfTAddTest

	self collectionWithElement.
	self otherCollection.
	self element.
	self assert: (self collectionWithElement includes: self element).
	self deny: (self otherCollection includes: self element)! !

!HeapTest methodsFor: 'tests - converting' stamp: ''!
testAsSet
 	"Test with a collection without equal elements"
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set! !

!HeapTest methodsFor: 'requirements' stamp: ''!
anotherElementNotIn
	" return an element different of 'elementNotIn'  not included in 'nonEmpty' "
	^ 9999! !

!HeapTest methodsFor: 'basic tests' stamp: ''!
testSortBlock

	| heap |
	heap := Heap withAll: #(1 3 5).
	self assert: heap asArray equals: #(1 3 5).
	
	heap sortBlock: [ :e1 :e2 | e1 >= e2 ].
	self assert: heap asArray equals: #(5 3 1)! !

!HeapTest methodsFor: 'tests - remove' stamp: ''!
testRemoveIfAbsent
	| res |
	res := self nonEmptyWithoutEqualElements remove: self elementNotIn ifAbsent: [ 33 ].
	self assert: res equals: 33! !

!HeapTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!HeapTest methodsFor: 'parameters' stamp: ''!
valuePutIn
	"the value that we will put in the non empty collection"
	
	^ 7! !

!HeapTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''!
testOccurrencesOfForMultipliness

	| collection elem |
	collection := self collectionWithEqualElements.
	elem := self elementTwiceInForOccurrences.

	self assert: (collection occurrencesOf: elem ) equals: 2.! !

!HeapTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!HeapTest methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!HeapTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExistsTwice

	| 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: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!HeapTest methodsFor: 'requirements' stamp: ''!
integerCollectionWithoutEqualElements
	" return a collection of integer without equal elements"
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionClass
	"Return the class to be used to create instances of the class tested"
	
	^ Heap! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionWith5Elements
	" return a collection of size 5 including 5 elements"
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionWithElement
	^ collectionWithElement! !

!HeapTest methodsFor: 'tests - growable' stamp: ''!
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 - creation' stamp: ''!
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 ) equals: (collection occurrencesOf: element1).
	self assert: (aCol occurrencesOf: element2 ) equals: (collection occurrencesOf: element2)! !

!HeapTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!HeapTest methodsFor: 'tests - adding' stamp: ''!
testTAdd
	| added collection |
	collection := self otherCollection.
	added := collection add: self element.
	
	self assert: added == self element.	"test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection includes: self element)	.
	self assert: (self collectionWithElement includes: self element).! !

!HeapTest methodsFor: 'requirements' stamp: ''!
accessCollection
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'requirements' stamp: ''!
elementInForOccurrences
	^self nonEmpty anyOne! !

!HeapTest methodsFor: 'requirements' stamp: ''!
elementNotInForOccurrences
	^ elementNotIn! !

!HeapTest methodsFor: 'requirements' stamp: ''!
newElement
	"return an element that will be put in the collection in place of another"
	^ elementNotIn! !

!HeapTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRequirementsOfTGrowableTest
	self empty.
	self nonEmpty.
	self element.
	self elementNotInForOccurrences.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty.
	self assert: (self nonEmpty includes: self element).
	self deny: (self nonEmpty includes: self elementNotInForOccurrences)! !

!HeapTest methodsFor: 'tests - converting' stamp: ''!
testAsByteArray

	| res |
	self integerCollectionWithoutEqualElements.
	self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ].
	res := true.
	self integerCollectionWithoutEqualElements
		detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! !

!HeapTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!HeapTest methodsFor: 'running' stamp: ''!
setUp
	super 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.
	stringCollection := Heap new add: 'a' ; add: 'b' ; add: 'c' ; 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: 'requirements' stamp: ''!
elementNotIn
	^ elementNotIn! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTRemoveTest
	| duplicate |
	self empty.
	self nonEmptyWithoutEqualElements.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	duplicate := true.
	self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ].
	self assert: duplicate = false.
	self elementNotIn.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! !

!HeapTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!HeapTest methodsFor: 'requirements' stamp: ''!
firstIndex
	" return an index between 'nonEmpty' bounds that is < to 'second index' "
	^2! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!HeapTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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 - creation' stamp: ''!
testWithAll

	| aCol collection |
	collection := self collectionMoreThan5Elements asOrderedCollection.
	aCol := self collectionClass withAll: collection.
	
	collection do: [ :each | self assert: (aCol occurrencesOf: each ) equals: ( collection occurrencesOf: each ) ].
	
	self assert: aCol size equals: collection size! !

!HeapTest methodsFor: 'tests - creation' stamp: ''!
testWith
	
	| aCol anElement |
	anElement := self collectionMoreThan5Elements anyOne.
	aCol := self collectionClass with: anElement.
	self assert: (aCol includes: anElement).! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionWithCopyNonIdentical
	" return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)"
	^ stringCollection! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
	" return a collection elements that can be sorte ( understanding message ' < '  or ' > ')"
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertAsSetForMultiplinessTest
	"a collection  with equal elements:"

	| res |
	self withEqualElements.
	res := true.
	self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res = true! !

!HeapTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAll
	| el aSubCollection collection |
	collection := self nonEmptyWithoutEqualElements.
	el := collection anyOne.
	aSubCollection := collection copyWithout: el.
	collection removeAll: aSubCollection.
	self assert: collection size = 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! !

!HeapTest methodsFor: 'requirements' stamp: ''!
replacementCollection
	" return a collection including elements of type 'collectionOfSize5' elements'type"
	^ collectionWith4Elements! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!HeapTest methodsFor: 'tests' stamp: ''!
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: 'tests' stamp: ''!
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 - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!HeapTest methodsFor: 'requirements' stamp: ''!
firstCollection
" return a collection that will be the first part of the concatenation"
	^nonEmpty! !

!HeapTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExists
 
	| el res |
	el := self nonEmptyWithoutEqualElements anyOne.
	res := self nonEmptyWithoutEqualElements remove: el.
	self assert: res == el! !

!HeapTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!HeapTest methodsFor: 'tests - as set tests' stamp: ''!
testAsIdentitySetWithEqualsElements

	| result collection |
	collection := self withEqualElements .
	result := collection asIdentitySet.
	collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = IdentitySet! !

!HeapTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithNewElement

	| added oldSize collection elem |
	collection := self otherCollection.
	oldSize := collection size.
	elem := self element.
	self deny: (collection includes: elem ).
	
	added := collection  addIfNotPresent: elem .
	self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: (oldSize + 1).! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
aValue
	" return a value to put into nonEmpty"
	^ self nonEmpty anyOne! !

!HeapTest methodsFor: 'basic tests' stamp: ''!
testDo

	| heap coll |
	heap := Heap withAll: #(1 3 5).
	coll := OrderedCollection new.
	
	heap do: [:each | coll add: each].
	
	self assert: coll equals: #(1 3 5) asOrderedCollection! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
	" return a collection of elements included in 'nonEmpty'  "
	^ self nonEmpty! !

!HeapTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!HeapTest methodsFor: 'requirements' stamp: ''!
elementInForIndexAccessing
	" return an element included in 'collectionMoreThan1NoDuplicates' "
	^ self collectionMoreThan1NoDuplicates anyOne.! !

!HeapTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllError
	| el aSubCollection |
	el := self elementNotIn.
	aSubCollection := self nonEmptyWithoutEqualElements copyWith: el.
	self should: [ self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! !

!HeapTest methodsFor: 'basic tests' stamp: ''!
testRemove

	| heap |
	heap := Heap new.
	self should: [ heap removeFirst ] raise: Error.
	heap add: 5.
	heap removeFirst.
	self assert: heap size equals: 0.
	heap add: 5.
	self should: [ heap removeAt: 2 ] raise: Error! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan5Elements
	" return a collection including at least 5 elements"
	
	^nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'requirements' stamp: ''!
secondIndex
	" return an index between 'nonEmpty' bounds that is > to 'second index' "
	^3! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeWithIdentityTest

	| anElement |
	self collectionWithCopyNonIdentical.
	anElement := self collectionWithCopyNonIdentical anyOne.
	self deny: anElement == anElement copy! !

!HeapTest methodsFor: 'requirements' stamp: ''!
elementTwiceIn
	^elementTwiceIn! !

!HeapTest methodsFor: 'basic tests' stamp: ''!
testFirst
	| heap | 
	heap := Heap new.
	heap add: 5.
	heap add: 12.
	heap add: 1.
	self assert: heap first equals: 1.
	heap removeFirst.
	self assert: heap first equals: 5.! !

!HeapTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!HeapTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self collection anyOne! !

!HeapTest methodsFor: 'requirements' stamp: ''!
secondCollection
	" return a collection that will be the second part of the concatenation"
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	^nonEmpty.! !

!HeapTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	difference := self collectionWithoutEqualElements difference: self empty.
	self assert: difference size = self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each) ]! !

!HeapTest methodsFor: 'requirements' stamp: ''!
elementNotInForElementAccessing
	" return an element not included in 'moreThan4Elements' "
	^ elementNotIn! !

!HeapTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithoutEqualElements
	" return a collection without equal elements "
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllFoundIn
	| el aSubCollection |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn.
	self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection.
	self assert: self nonEmptyWithoutEqualElements size = 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
elementNotInForIndexAccessing
	" return an element not included in 'collectionMoreThan1NoDuplicates' "
	^ elementNotIn! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
	" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'requirements' stamp: ''!
replacementCollectionSameSize
	" return a collection of size (secondIndex - firstIndex + 1)"
	^subCollection! !

!HeapTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!HeapTest methodsFor: 'tests - adding' stamp: ''!
testTAddTwice

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	anElement := self element.
	oldSize := collection size.
	added := collection 
		add: anElement;
		add: anElement.
	self assert: added == anElement.	"test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection includes: anElement).
	self assert: collection size equals: (oldSize + 2)! !

!HeapTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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 - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!HeapTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Heap! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsSetForIdentityMultiplinessTest
	"A collection (of elements for which copy is not identical ) without equal elements:"

	| anElement res |
	self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := self elementsCopyNonIdenticalWithoutEqualElements anyOne.
	self deny: anElement copy == anElement.
	res := true.
	self elementsCopyNonIdenticalWithoutEqualElements
		detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!HeapTest methodsFor: 'requirements' stamp: ''!
subCollectionNotIn
	" return a collection for which at least one element is not included in 'moreThan4Elements' "
	^ collectionNotIncluded! !

!HeapTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!HeapTest methodsFor: 'requirements' stamp: ''!
expectedSizeAfterReject
	"Number of even elements in #collection"
	^ expectedSizeAfterReject.! !

!HeapTest methodsFor: 'basic tests' stamp: ''!
testHeap
	| heap |
	heap := Heap new.
	self assert: heap isHeap.

	self assertEmpty: heap.
	heap add: 1.
	self denyEmpty: heap! !

!HeapTest methodsFor: 'requirements' stamp: ''!
result
	^ collectResult.! !

!HeapTest methodsFor: 'requirements' stamp: ''!
empty
	^empty.! !

!HeapTest methodsFor: 'requirements' stamp: ''!
element
	^ element! !

!HeapTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty

	| result |
	result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne).
	self assert: result equals: 0! !

!HeapTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	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 - fixture' stamp: ''!
test0FixtureCreationWithTest

	self collectionMoreThan5Elements.
	self assert: self collectionMoreThan5Elements size >= 5! !

!HeapTest methodsFor: 'tests' stamp: ''!
testExamples
	Heap heapExample.
	Heap heapSortExample! !

!HeapTest methodsFor: 'requirements' stamp: ''!
withEqualElements
	^ sameAtEndAndBegining! !

!HeapTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementFromEmpty
	 
	self 
		should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ]
		raise: Error! !

!HeapTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
collectionWithEqualElements
	" return a collection including atLeast two elements equal"

	^ collectionWithDuplicateElement! !

!HeapTest methodsFor: 'requirements' stamp: ''!
elementTwiceInForOccurrences
	" return an element included exactly two time in # collectionWithEqualElements"
^ duplicateElement! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan1NoDuplicates
	" return a collection of size > 1 without equal elements"
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'requirements' stamp: ''!
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: ''!
expectedElementByDetect
	"Returns the first even element of #collection"
	^ expectedElementByDetect.! !

!HeapTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
	" return a collection of size 1 including one element"
	^ nonEmpty1Element! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionWithIdentical
	"Return a collection of type: 'self collectionWIithoutEqualsElements class containing two elements equals (with identity equality)."

	| result collection anElement |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := collection first.
	collection add: anElement.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
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 - occurrencesOf' stamp: ''!
testOccurrencesOf
	| collection |
	collection := self collectionWithoutEqualElements .
	
	collection do: [ :each | self assert: (collection occurrencesOf: each) equals: 1 ]! !

!HeapTest methodsFor: 'requirements' stamp: ''!
indexArray
	" return a Collection including indexes between bounds of 'nonEmpty' "

	^ indexArray! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesForMultiplinessTest
	| cpt |
	self collectionWithEqualElements.
	self collectionWithEqualElements.
	self elementTwiceInForOccurrences.
	self elementTwiceInForOccurrences.
	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 - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!HeapTest methodsFor: 'requirements' stamp: ''!
speciesClass
	
	^ speciesClass! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionWithCopy
	"Return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals (with identity equality)
	but 2 elements only equals with classic equality"
	
	| result collection |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	collection add: collection first copy.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!HeapTest methodsFor: 'tests - includes' stamp: ''!
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 - including with identity' stamp: ''!
testIdentityIncludes
	" test the comportement in presence of elements 'includes' but not 'identityIncludes' "
	" can not be used by collections that can't include elements for wich copy doesn't return another instance "
	| collection anElement |
	
	collection := self collectionWithCopyNonIdentical.
	anElement := collection anyOne copy.

	self deny: (collection identityIncludes: anElement)! !

!HeapTest methodsFor: 'requirements' stamp: ''!
indexInForCollectionWithoutDuplicates
	" return an index between 'collectionWithoutEqualsElements'  bounds"
	^ 2! !

!HeapTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!HeapTest methodsFor: 'tests - as set tests' stamp: ''!
testAsSetWithEqualsElements

	| result |
	result := self withEqualElements asSet.
	self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = Set! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!HeapTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements

	" return a collection not including equal elements "
	^ nonEmpty5ElementsWithoutDuplicate! !

!HeapTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!HeapTest methodsFor: 'requirements' stamp: ''!
sizeCollection
	"Answers a collection whose #size is 4"
	^collectionWith4Elements! !

!HelpAPIDocumentation commentStamp: ''!
This class represents the browsable package API help for the help system.

Instance Variables
!
!HelpAPIDocumentation class methodsFor: 'accessing' stamp: ''!
bookName
	^'API Documentation'! !

!HelpAPIDocumentation class methodsFor: 'accessing' stamp: ''!
helpPackages
	^#('HelpSystem-Core-Model' 'HelpSystem-Core-Utilities' 'HelpSystem-Core-UI')! !

!HelpAPIDocumentation class methodsFor: 'defaults' stamp: ''!
builder
	^PackageAPIHelpBuilder! !

!HelpBrowser commentStamp: ''!
A HelpBrowser is used to display a hierarchy of help topics and their contents.

Instance Variables
	rootTopic: 		<HelpTopic>
	window:			<StandardWindow>	 
	treeMorph:		<PluggableTreeMorph>
	contentMorph:		<Morph>			

rootTopic
	- xxxxx

window
	- xxxxx

treeMorph 
	- xxxxx

contentMorph 
	- xxxxx

!
!HelpBrowser methodsFor: 'actions' stamp: ''!
selectTopicSatisfying: aBlock
	"I select the first topic that satisfies the given block.
	If the topic has subtopics it is expanded. If the topic is not visible 
	the entire path to that topic is expanded."
	
	(self helpTopic pathToTopicSatisfying: aBlock) ifNotEmpty: [ :aCollection |
		treeMorph 
			selectPath: aCollection allButFirst
			in: (treeMorph scroller submorphs at: 1 ifAbsent: [^treeMorph]) ]! !

!HelpBrowser methodsFor: 'accessing' stamp: ''!
doItContext
	^ nil! !

!HelpBrowser methodsFor: 'actions' stamp: ''!
previous
	treeMorph setSelectionIndex: (treeMorph getSelectionIndex - 1 max: 1)! !

!HelpBrowser methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize. 
	self initWindow.! !

!HelpBrowser methodsFor: 'initialization' stamp: ''!
shoutAboutToStyle: aPluggableShoutMorphOrView 
	^ (self rootTopic respondsTo: #canHaveSyntaxHighlighting)
				and: [self rootTopic canHaveSyntaxHighlighting]! !

!HelpBrowser methodsFor: 'accessing' stamp: ''!
sourceTextModel
	^ sourceTextModel ifNil: [ sourceTextModel := RubScrolledTextModel new interactionModel: self ]! !

!HelpBrowser methodsFor: 'actions' stamp: ''!
next
	treeMorph setSelectionIndex: treeMorph getSelectionIndex + 1! !

!HelpBrowser methodsFor: 'ui' stamp: ''!
open	
 	"Open the receivers window" 

	self refresh.	
	window openInWorld.! !

!HelpBrowser methodsFor: 'actions' stamp: ''!
refresh
	| helpTopic items |
	helpTopic := self helpTopic.
	window setLabel: helpTopic title.
	items := helpTopic subtopics collect: [ :each | HelpTopicListItemWrapper with: each ].
	treeMorph list: items.
	self sourceTextModel setText: helpTopic contents! !

!HelpBrowser methodsFor: 'accessing' stamp: ''!
rootTopic
	^rootTopic! !

!HelpBrowser methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass
	^ nil! !

!HelpBrowser methodsFor: 'events' stamp: ''!
onItemClicked: anItem
	anItem ifNil: [ ^ self sourceTextModel setText: rootTopic asHelpTopic contents ].
	self sourceTextModel setText: anItem contents! !

!HelpBrowser methodsFor: 'actions' stamp: ''!
selectARootTopic: aHelpClass
	"Used to unfold a particular topic"
	
	| item |
	item := treeMorph allItems detect: [:each | 
            each complexContents item key = aHelpClass name ].
   treeMorph selection: item! !

!HelpBrowser methodsFor: 'accessing' stamp: ''!
doItReceiver
	^ nil! !

!HelpBrowser methodsFor: 'ui' stamp: ''!
menu
	^ (PragmaMenuBuilder pragmaKeyword: #HelpBrowserContextMenu model: self) menu.! !

!HelpBrowser methodsFor: 'ui' stamp: ''!
shoutMorphFillMenu: aMenu
	^ aMenu addAllFrom: self menu! !

!HelpBrowser methodsFor: 'accessing' stamp: ''!
window

	^ window! !

!HelpBrowser methodsFor: 'ui' stamp: ''!
initWindow
	| toolbar dock contentMorph | 
	window := StandardWindow new.
	window model: self.
	window title: 'Help Browser' translated.
	toolbar := window
		newToolbar:
			{(window
				newButtonFor: self
				getState: nil
				action: #refresh
				arguments: nil
				getEnabled: nil
				labelForm: (self iconNamed: #refreshIcon)
				help: 'Refresh' translated)}.
	dock := window newToolDockingBar.
	dock addMorphBack: toolbar.
	window
		addMorph: dock
		fullFrame:
			(LayoutFrame identity
				bottomFraction: 0;
				bottomOffset: dock minExtent y).	"Tree"
	treeMorph := PluggableTreeMorph new.
	treeMorph
		model: self;
		setSelectedSelector: #onItemClicked:.
	window
		addMorph: treeMorph
		fullFrame:
			(LayoutFrame identity
				rightFraction: 0.3;
				topOffset: dock minExtent y).	"Text"
	contentMorph := self sourceTextModel newScrolledText
		beForSmalltalkScriptingWithDefaultFont;
		beWrapped;
		yourself.
	contentMorph menuProvider: self selector: #shoutMorphFillMenu:.
	window
		addMorph: contentMorph
		fullFrame:
			(LayoutFrame identity
				leftFraction: 0.3;
				topOffset: dock minExtent y)! !

!HelpBrowser methodsFor: 'actions' stamp: ''!
helpTopic
	^ helpTopicCache ifNil: [ helpTopicCache := rootTopic asHelpTopic ]! !

!HelpBrowser methodsFor: 'ui' stamp: ''!
close
	window notNil ifTrue: [window delete]! !

!HelpBrowser methodsFor: 'ui' stamp: ''!
bindings
	"I'm used as an interaction model for the Help Browser text editors.
	Return an empty collection of bindings, since no compilation or code completion happen on myself"
	^ Dictionary new! !

!HelpBrowser methodsFor: 'accessing' stamp: ''!
rootTopic: aHelpTopic

	rootTopic := aHelpTopic. 
	self refresh! !

!HelpBrowser class methodsFor: 'accessing' stamp: ''!
defaultHelpBrowser: aClass
	"Use a new help browser implementation"
	
	DefaultHelpBrowser := aClass! !

!HelpBrowser class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^ #bookIcon! !

!HelpBrowser class methodsFor: 'instance creation' stamp: ''!
open
	^self openOn: SystemHelp! !

!HelpBrowser class methodsFor: 'instance creation' stamp: ''!
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: 'ui' stamp: ''!
menuOn: aBuilder
	
	(aBuilder item: #'Do it' translated)
		keyText: 'd';
		selector: #doIt;
		help: nil;
		iconName: #smallDoIt.
	(aBuilder item: #'Print it' translated)
		keyText: 'p';
		selector: #printIt;
		help: nil;
		iconName: #smallPrintIt.
	(aBuilder item: #'Inspect it' translated)
		keyText: 'i';
		selector: #inspectIt;
		help: nil;
		iconName: #smallInspectIt.! !

!HelpBrowser class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #'Help Browser')
		parent: #HelpBrowser;
		order: 1;
		action: [ self open ];
		iconName: #smallHelpIcon;
		help: 'Explore a list of help topics to learn to use Pharo tools.';
		withSeparatorAfter! !

!HelpBrowser class methodsFor: 'accessing' stamp: ''!
defaultHelpBrowser
	^ DefaultHelpBrowser ifNil: [DefaultHelpBrowser := self]! !

!HelpBrowserTest commentStamp: ''!
SUnit tests for the help browser!
!HelpBrowserTest methodsFor: 'testing' stamp: ''!
testLazyDefaultHelpBrowser
	
	self assert: self defaultTestClass defaultHelpBrowser notNil! !

!HelpBrowserTest methodsFor: 'testing' stamp: ''!
testDefaultHelpBrowserIsReplacable
	| current replacement |
	"save the one that is registered"
	current := self defaultTestClass defaultHelpBrowser.
	replacement := AdvancedHelpBrowserDummy.
	[ 
	self defaultTestClass defaultHelpBrowser: replacement.
	self assert: self defaultTestClass defaultHelpBrowser identicalTo: replacement.
	self defaultTestClass open ] ensure: [ self defaultTestClass defaultHelpBrowser: current ]! !

!HelpBrowserTest methodsFor: 'testing' stamp: ''!
testOpen
	|browser|
	browser := self defaultTestClass open.
	self currentWorld doOneCycleNow. 
	browser close! !

!HelpBrowserTest methodsFor: 'accessing' stamp: ''!
defaultTestClass
	^HelpBrowser! !

!HelpBrowserTest methodsFor: 'testing' stamp: ''!
testDefaultHelpBrowser
	| current replacement instance |
	current := self defaultTestClass defaultHelpBrowser.
	replacement := AdvancedHelpBrowserDummy.
	[ self defaultTestClass defaultHelpBrowser: replacement.
	self assert: self defaultTestClass defaultHelpBrowser identicalTo: replacement.

	instance := self defaultTestClass open.
	self assert: instance rootTopic notNil.
	self assert: instance isOpen ]
		ensure: [ self defaultTestClass defaultHelpBrowser: current ]! !

!HelpBuilder commentStamp: ''!
This is an utility class that builds the books for a help system.

Instance Variables
	rootTopics:		<OrderedCollection>

rootTopics
	- a collection of books 
!
!HelpBuilder methodsFor: 'initialization' stamp: ''!
initialize 
	"Initializes the receiver"
	
	super initialize.
	topicToBuild := self topicClass new.! !

!HelpBuilder methodsFor: 'accessing' stamp: ''!
topicToBuild
	^topicToBuild! !

!HelpBuilder methodsFor: 'accessing' stamp: ''!
rootToBuildFrom: anObject
	rootToBuildFrom := anObject! !

!HelpBuilder methodsFor: 'building' stamp: ''!
build
	self subclassResponsibility! !

!HelpBuilder methodsFor: 'private - accessing' stamp: ''!
topicClass
	^HelpTopic! !

!HelpBuilder class methodsFor: 'building' stamp: ''!
buildHelpTopicFrom: aHelpTopicDescription
	"Start building from the given help topic description"
	
	^(self new)
		rootToBuildFrom: aHelpTopicDescription;
		build;
		topicToBuild! !

!HelpExporter commentStamp: ''!
I am used to export the classic help stored as special methods into microdown files.
!
!HelpExporter methodsFor: 'writing' stamp: ''!
writeTopic: topic
	| writeStream |
	writeStream := (self writeStreamFromTopic: topic).
	self writeTopic: topic level: 1 toStream: writeStream.
	writeStream flush;close! !

!HelpExporter methodsFor: 'private' stamp: ''!
demoteContents: contents toLevel: level
	^ ((contents copyReplaceAll: (String cr,'### ') with: (String cr, ('#' repeat: 3+level),' '))
		copyReplaceAll: (String cr,'## ') with: (String cr, ('#' repeat: 2+level),' '))
		copyReplaceAll: (String cr,'# ') with: (String cr, ('#' repeat: 1+level),' ')! !

!HelpExporter methodsFor: 'accessing' stamp: ''!
rootDirectory
	"return a path to the root directory to store microdown files"
	| root |
	root := 'doc' asFileReference.
	root ensureCreateDirectory.
	^ root! !

!HelpExporter methodsFor: 'accessing' stamp: ''!
systemHelpTopics
	^ SystemHelp asHelpTopic! !

!HelpExporter methodsFor: 'writing' stamp: ''!
writeAllTopics
	|topics|
	CustomHelp formatter: CustomHelpMicrodownFormatter new.
	topics := self systemHelpTopics.
	topics subtopics do: [ :topic | self writeTopic: topic ].
	CustomHelp formatter: nil "force default"! !

!HelpExporter methodsFor: 'writing' stamp: ''!
writeStreamFromTopic: topic
	| fileName fileRef aStream |
	fileName := 'gen_', (topic title asLowercase select: [ :c | c isAlphaNumeric  ]).
	fileRef := (self rootDirectory  / fileName, 'md' ) asFileReference.
	fileRef deleteIfAbsent: [ "ignore" ].
	aStream :=  fileRef writeStream .
	^ aStream! !

!HelpExporter methodsFor: 'private' stamp: ''!
writeTopic: topic level: level toStream: stream 
	stream  << ('#' repeat: level) << ' ' << topic title << String cr.
	topic contents ifNotEmpty: 
		[ stream << (self demoteContents: topic contents  toLevel: level) << String cr. ].
	topic subtopics do: [ :t | self writeTopic: t level: level +1 toStream: stream ]! !

!HelpExporter class methodsFor: 'accessing' stamp: ''!
export
	<script>
	self new writeAllTopics! !

!HelpHowToHelpTopics commentStamp: ''!
Explains help topics!
!HelpHowToHelpTopics class methodsFor: 'pages' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
pages
	^#(overview page1 page2 page3 page4)! !

!HelpHowToHelpTopics class methodsFor: 'pages' stamp: ''!
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: 'accessing' stamp: ''!
bookName
	^'Implementation'! !

!HelpHowToHelpTopics class methodsFor: 'pages' stamp: ''!
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''
			iconName: #packageIcon
			contents: ''Second subsection''.		
		root 
			addSubtopic: sub1; 
			addSubtopic: sub2.
		HelpBrowser openOn: root
		
		'! !

!HelpHowToHelpTopics class methodsFor: 'pages' stamp: ''!
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
'! !

!HelpHowToHelpTopicsFromCode commentStamp: ''!
How to create help topics from code!
!HelpHowToHelpTopicsFromCode class methodsFor: 'accessing' stamp: ''!
pages
	^#(overview step1 step2 step3 step4 step5 step6 step7)! !

!HelpHowToHelpTopicsFromCode class methodsFor: 'accessing' stamp: ''!
bookName
	^'Custom help from code'! !

!HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: ''!
step5
	^HelpTopic
		title: 'Step 5 - Test your help'
		contents:
	'STEP 5 - TEST YOUR HELP
	
By using 
      
       HelpBrowser open

 
'! !

!HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: ''!
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: ''!
step7
	^HelpTopic
		title: 'Step 7 - Tips and Tricks'
		contents:
	'STEP 7 - TIPS AND TRICKS

Tip1:
          If you implement the #pages method you can also 
          use the name of a custom help class that should be 
          integrated between the specific pages:
 
              #pages
                   ^(firstPage MyAppTutorial secondPage)

Tip2:
          You can easily edit the help contents of a page by 
          using the #edit: message. For our example just evaluate:

			MyAppHelp edit: #firstPage
			
	     This will open a workspace with the help contents and 
	     when you accept it it will be saved back to the help 
	     method defining the topic.		  
		

'! !

!HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: ''!
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: ''!
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: ''!
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.

Additionaly you can specify #bookDescription which will be displayed in the HelpBrowser when one selects your book. The description han be added in the following way:

	bookDescription
	    ^ ''This is a help book about my App'''! !

!HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: ''!
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'' 
    	           iconName: #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: ''!
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)

'! !

!HelpOnHelp commentStamp: ''!
Welcome to Pharo Smalltalk Help System!
!HelpOnHelp class methodsFor: 'accessing' stamp: ''!
key
	^'HelpOnHelp'! !

!HelpOnHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#(introduction HelpHowToHelpTopics HelpAPIDocumentation)! !

!HelpOnHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^'Help on Help'! !

!HelpOnHelp class methodsFor: 'pages' stamp: ''!
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.

!!' readStream nextChunkText! !

!HelpTopic commentStamp: ''!
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:		<Object>      The help topic contents
	icon:			<Form|nil>	   An optional icon for the topic
	key:			<String|nil>    An optional unique key
	subtopics:	      <Collection>  A collection of subtopics
	title:			<String>        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: 'converting' stamp: ''!
asHelpTopic 
	"Converts the receiver to a help topic"
	
	^self! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
iconName: aSymbol
	"Sets the receivers icon"
	
	self icon: (self iconNamed: aSymbol)! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
addSubtopic: aTopic
	"Adds the given topic to the receivers collection of subtopics, and set this object as owner of the subtopic"
	
	self subtopics add: aTopic.
	aTopic owner: self.
	^aTopic! !

!HelpTopic methodsFor: 'testing' stamp: ''!
hasSubtopics 
	"Returns true if the receiver has subtopics, false otherwise"
	
	^self subtopics notEmpty! !

!HelpTopic methodsFor: 'printing' stamp: ''!
displayStringOn: stream
	^ stream nextPutAll: self title! !

!HelpTopic methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream 
		nextPutAll: '(';
		nextPutAll: self title;
		nextPutAll: ')'! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
icon 
 	"Returns the receivers icon"
	
	^icon! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
owner
	"an ownder is a HelpTopic that uses the current HelptTopic as subtopic"
^ owner! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
contents
	"Returns the receivers contents"
	
	^ contents! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
contents: aStringOrText
	"Sets the receivers contents to the given object" 
	"Some of the topics has #symbols as the first character on a line in their sample code. 
	Indent it by one space to avoid issue when generating markdown."
	contents := aStringOrText copyReplaceAll: (String cr,'#') with: (String cr,' #')! !

!HelpTopic methodsFor: 'operating' stamp: ''!
sortSubtopicsByTitle
	"Sort the subtopics by title"
	
	subtopics := SortedCollection withAll: self subtopics! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
title
	"Returns the receivers title"
	
	^ title! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
icon: aSymbol
	"Sets the receivers icon"
	
	icon := aSymbol! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
pathToTopicSatisfying: aBlock
	"I return the complete path to the first topic satifying the given block.
	The path is a collection starting with the root node and ending with the 
	node satifying the given block. If no node is found I return an empty collection."
	
	(aBlock value: self) ifTrue: [ ^ {self} ].
	
	self subtopics do: [ :aHelpTopic |
		(aHelpTopic pathToTopicSatisfying: aBlock)
			ifNotEmpty: [ :aPath |
				^ { self }, aPath ] ].
	^ #()! !

!HelpTopic methodsFor: '*NewTools-Spotter-Processors' stamp: ''!
stTopicIcon
	^ self hasSubtopics
		ifTrue: [ Smalltalk ui icons iconNamed: #bookIcon ]
		ifFalse: [ Smalltalk ui icons iconNamed: #pageIcon ]! !

!HelpTopic methodsFor: 'initialization' stamp: ''!
initialize 
	"Initializes the receiver"
	
	super initialize.
	self title: self defaultTitle.
	self contents: ''.
	self key: ''! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
subtopics: aCollection 
	"Sets the receivers subtopics"
	
	aCollection do: [ :topic|  topic owner: self  ].
	subtopics := aCollection.! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
title: anObject
	"Sets the receivers title"
	
	title := anObject! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
key 	
	"Returns a unique key identifying the receiver in the help system"	
		
	^key! !

!HelpTopic methodsFor: '*NewTools-Spotter-Processors' stamp: ''!
stActDefault
	HelpBrowser openOn: self! !

!HelpTopic methodsFor: '*NewTools-Spotter-Processors' stamp: ''!
stAllSubtopics

	 ^ self subtopics flatCollect: [:aTopic |
		aTopic asOrderedCollection, aTopic stAllSubtopics ]
		 ! !

!HelpTopic methodsFor: 'defaults' stamp: ''!
defaultTitle
	"Returns the receivers default title"
	
	^'Unnamed Topic'! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
owner: topic
	"an owner is a HelpTopic that uses the current HelptTopic as subtopic"
owner := topic! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
subtopics 
	"Returns the receivers list of subtopics"
	
	^ subtopics ifNil: [subtopics := OrderedCollection new]! !

!HelpTopic methodsFor: 'accessing' stamp: ''!
key: aUniqueKey
	"Sets a unique key identifying the receiver in the help system"	
		
	key := aUniqueKey! !

!HelpTopic methodsFor: 'comparing' stamp: ''!
<= anotherHelpTopic
	"Use sorting by title as the default sort order"
	
	^self title <= anotherHelpTopic title! !

!HelpTopic class methodsFor: 'instance creation' stamp: ''!
title: aTitle icon: anIcon contents: aText
	"Create a new instance with given title, icon and content"
	
	^(self new)
		title: aTitle;
		icon: anIcon;
		contents: aText;
		yourself.! !

!HelpTopic class methodsFor: 'instance creation' stamp: ''!
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: ''!
named: aString
	"Create a new instance with given title and empty contents"
	
	^(self new)
		title: aString;
		yourself! !

!HelpTopic class methodsFor: 'instance creation' stamp: ''!
title: aTitle iconName: anIconName contents: aText
	"Create a new instance with given title, icon and content"
	
	^(self new)
		title: aTitle;
		iconName: anIconName;
		contents: aText;
		yourself.! !

!HelpTopicListItemWrapper commentStamp: ''!
This class implements a list item wrapper for help topics.

Instance Variables
!
!HelpTopicListItemWrapper methodsFor: 'accessing' stamp: ''!
balloonText
	"Returns a string used for fly by help"
	
	^self item title! !

!HelpTopicListItemWrapper methodsFor: 'accessing' stamp: ''!
asString
	"Returns a string used as a label"
	
	^item title! !

!HelpTopicListItemWrapper methodsFor: 'accessing' stamp: ''!
icon
	"Either return the icon for the given topic"

	item icon notNil
		ifTrue: [ ^ item icon ].
	^ item hasSubtopics
		ifTrue: [ self iconNamed: #bookIcon ]
		ifFalse: [ self iconNamed: #pageIcon ]! !

!HelpTopicListItemWrapper methodsFor: 'accessing' stamp: ''!
contents
	"Returns subnodes (if any)"
	
 	item hasSubtopics ifFalse: [^#()].	
	^(item subtopics) collect: [ :each | 
		HelpTopicListItemWrapper with: each
	].! !

!HelpTopicListItemWrapperTest commentStamp: ''!
SUnit tests for class HelpTopicListItemWrapper!
!HelpTopicListItemWrapperTest methodsFor: 'testing' stamp: ''!
testDisplayLabel
	| instance |
	instance := self defaultTestClass with: (HelpTopic named: 'My Topic').
	self assert: instance asString equals: 'My Topic'! !

!HelpTopicListItemWrapperTest methodsFor: 'accessing' stamp: ''!
defaultTestClass 
	^HelpTopicListItemWrapper! !

!HelpTopicTest commentStamp: ''!
SUnit tests for HelpTopic class!
!HelpTopicTest methodsFor: 'testing' stamp: ''!
testSubtopicOwnership
	"Test that when a subtopic is added to a topic then owner of the subtopic is the topic"

	| subtopic owner |
	owner := self defaultTestClass named: 'I am the owner'.
	subtopic := self defaultTestClass named: 'I am the subtopic'.

	owner addSubtopic: subtopic.

	self assert: subtopic owner identicalTo: owner! !

!HelpTopicTest methodsFor: 'testing' stamp: ''!
testAddingSubtopic
	| subtopic returned |
	subtopic := self defaultTestClass named: 'Subtopic'.
	returned := topic addSubtopic: subtopic.
	self assert: returned identicalTo: subtopic.
	self assert: (topic subtopics includes: subtopic)! !

!HelpTopicTest methodsFor: 'testing' stamp: ''!
testInstanceCreation
	| instance |
	instance := self defaultTestClass named: 'My Topic'.
	self assert: instance title equals: 'My Topic'! !

!HelpTopicTest methodsFor: 'accessing' stamp: ''!
defaultTestClass
	^HelpTopic! !

!HelpTopicTest methodsFor: 'testing' stamp: ''!
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 equals: a.
	self assert: sorted last equals: c! !

!HelpTopicTest methodsFor: 'testing' stamp: ''!
testInitialization
	self assert: topic title equals: 'Unnamed Topic'.
	self assertEmpty: topic key.
	self assertEmpty: topic contents! !

!HelpTopicTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	topic := self defaultTestClass new.! !

!HermesCommandLineHandler commentStamp: ''!
This is the command line handler to load Hermes files in the image.
The format is intented to export any of the objects. However, the command line expects to have a package as its root element.
It loads the hermes files passed as parameter.
They are loaded in the order of the parameters.

Usage: loadHermes [--save] [extendedOptions] [<hermesFiles> ...]
	--save                		save after loading the packages if there is no error
	 <hermesFiles>      	a list of .hermes files to load in the image.
	extendedOptions 	read the extension section.
	
Examples:
	#Load the package Test-Package
	pharo Pharo.image loadHermes Test-Package.hermes
	
	#Load the package Test-Package and saving
	pharo Pharo.image loadHermes --save Test-Package.hermes
	
	
Extensions 
=========

When Hermes-Extensions is loaded additional options are present: 
	no-fail-on-undeclared		It does not fail the loading if there are new undeclared variables. By default it fails.
	on-duplication=action	When there is a duplication in the loading package what is the action to take:
								fail		(default) Fail on a duplication
								ignore	Ignore the error and do not do nothing. Keeping the image version
								replace	Replace the image version with the one in the Hermes Package.
									
Examples
								
	#Load the package Test-Package without failing on new undeclared variables.
	pharo Pharo.image loadHermes --save --no-fail-on-undeclared Test-Package.hermes

	#Load the package Test-Package replacing the image version with the ones in the hermes file.
	pharo Pharo.image loadHermes --save --on-duplication=replace Test-Package.hermes
!
!HermesCommandLineHandler methodsFor: 'processing files' stamp: ''!
processFiles
	"The files are processed in order of the command line"
	(self commandLine allFilesWithExtension: '.hermes') do: [ :file | self processFile: file ]! !

!HermesCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self activateHelp ifTrue: [ ^ self ].
	self validateParameters.
	
	self processFiles.
		
	(self hasOption: 'save')
		ifTrue: [ Smalltalk snapshot: true andQuit: false ].

	self exitSuccess! !

!HermesCommandLineHandler methodsFor: 'processing files' stamp: ''!
processFile: file
	"It loads the package and installs it in the image"
	| installer reader readPackage |
	installer := self createInstaller.
	SystemNotification signal: ('[Hermes] Reading ' , file).

	reader := HEBinaryReader new
		stream: (File named: file) readStream;
		yourself.

	readPackage := HEPackage readFrom: reader.

	SystemNotification signal: ('[Hermes] Installing ' , file).
	installer installPackage: readPackage! !

!HermesCommandLineHandler methodsFor: 'processing files' stamp: ''!
createInstaller
	"In the basic installation, the bootstraped version of Hermes, 
	there is only one Installer, the HEInstaller. 
	When the extensions are installed the new installer to use is the HEExtendedInstaller."

	^ Smalltalk globals
		at: #HEExtendedInstaller
		ifPresent: [ :instClass | 
			instClass new
				forOptions: self commandLine;
				yourself ]
		ifAbsent: [ HEInstaller new ]! !

!HermesCommandLineHandler methodsFor: 'validation' stamp: ''!
validateParameters
	"The command line handle should have at least one .hermes file"
	(self commandLine hasFileWithExtension: '.hermes')
		ifFalse: [ ^ self exitFailure: 'Missing Hermes file as argument' ]! !

!HermesCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'loadHermes'! !

!HermesCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Loads the hermes files passed as parameter'! !

!HiAbstractColorStrategy commentStamp: ''!
I represent a trategy to map nodes and links of a ruler to colors. I'm used by the HiSimpleRenderer.!
!HiAbstractColorStrategy methodsFor: 'accessing' stamp: ''!
ruler: aHiRuler
	self subclassResponsibility! !

!HiAbstractColorStrategy methodsFor: 'accessing' stamp: ''!
colorForNode: aHiNode
	^ self subclassResponsibility! !

!HiAbstractColorStrategy methodsFor: 'accessing' stamp: ''!
colorForLink: aHiLink
	^ self subclassResponsibility! !

!HiAbstractRenderer commentStamp: ''!
My subclasses know how to render a Hiedra visualization (HiRuler) using Athens.
!
!HiAbstractRenderer methodsFor: 'accessing' stamp: ''!
formExtent
	"Answer the pixel extent for the form to be rendered (as a Point)."

	^ self formWidth @ self formHeight! !

!HiAbstractRenderer methodsFor: 'accessing' stamp: ''!
formWidth
	"Answer the width in pixels for the form to be rendered."

	"Note: The reason of numberOfColumns + 2 is the left and right margin."
	^ (ruler numberOfColumns + 2) * self cellWidth! !

!HiAbstractRenderer methodsFor: 'accessing' stamp: ''!
rowsInterval: anObject
	rowsInterval := anObject! !

!HiAbstractRenderer methodsFor: 'accessing' stamp: ''!
formHeight
	"Answer the height in pixels for the form to be rendered."

	^ rowsInterval size * self rowHeight! !

!HiAbstractRenderer methodsFor: 'accessing' stamp: ''!
rowHeight
	^ self subclassResponsibility! !

!HiAbstractRenderer methodsFor: 'accessing' stamp: ''!
ruler
	^ ruler! !

!HiAbstractRenderer methodsFor: 'accessing' stamp: ''!
ruler: aHiRuler
	ruler := aHiRuler! !

!HiAbstractRenderer methodsFor: 'API' stamp: ''!
newForm
	"Answer a new form, rendered with the current ruler and rowInterval."
	
	self subclassResponsibility! !

!HiAbstractRenderer methodsFor: 'accessing' stamp: ''!
rowWidthAt: rowIndex
	"Answer the width in pixels required by a row to be rendered."

	"The +2 represents the left and right margin."
	^ ((ruler numberOfColumnsAt: rowIndex) + 2) * self cellWidth! !

!HiAbstractRenderer methodsFor: 'accessing' stamp: ''!
rowsInterval
	^ rowsInterval! !

!HiAbstractRenderer methodsFor: 'accessing' stamp: ''!
cellWidth
	^ self subclassResponsibility! !

!HiBranchMapping commentStamp: ''!
I know how to map each link and node of a Hiedra ruler to a branch number. This is useful to colorize a ruler.
Note that my mapping is arbitrary, and other mappings are possible.!
!HiBranchMapping methodsFor: 'accessing' stamp: ''!
branchByLink
	^ branchByLink! !

!HiBranchMapping methodsFor: 'convenience' stamp: ''!
allLinksWithSameBranchAs: aHiLink 
	| branch |
	branch := self branchAtLink: aHiLink.
	^ Array streamContents: [:stream |
		branchByLink keysAndValuesDo: [:link :branchNumber |
			branchNumber = branch ifTrue: [ stream nextPut: link ] ] ].! !

!HiBranchMapping methodsFor: 'accessing' stamp: ''!
branchAtLink: aHiLink
	"Answer the branch number for a link."

	^ self branchByLink at: aHiLink! !

!HiBranchMapping methodsFor: 'accessing' stamp: ''!
branchAtNode: aHiNode
	"Answer the branch number for a node."

	^ self branchByNode at: aHiNode! !

!HiBranchMapping methodsFor: 'building' stamp: ''!
buildBranchByLink
	"Build a dictionary that maps each link to a branch number."
	
	branchByLink := Dictionary new.
	ruler nodes reverseDo: [ :node |
		node incomingLinks do: [ :link |
			self markBranchLinksFrom: link ] ]! !

!HiBranchMapping methodsFor: 'accessing' stamp: ''!
branchCount
	^ branchCount! !

!HiBranchMapping methodsFor: 'private' stamp: ''!
markBranchLinksFrom: link
	| nextLink |

	"Stop if the link is already marked."
	(branchByLink includesKey: link) ifTrue: [ ^self ].

	"Then, it's a new branch."
	branchCount := branchCount + 1.

	"Iterate the first available branch until there isn't any more."
	nextLink := link.
	[	branchByLink at: nextLink put: branchCount.
		nextLink origin incomingLinks ifEmpty: [ ^self ].
		nextLink := nextLink origin incomingLinks
			detect: [ :each | (branchByLink includesKey: each) not ]
			ifNone: [ ^self ]
	] repeat! !

!HiBranchMapping methodsFor: 'accessing' stamp: ''!
ruler
	^ ruler! !

!HiBranchMapping methodsFor: 'building' stamp: ''!
buildBranchByNode
	"Build a dictionary that maps each node to a branch number."
	
	branchByNode := Dictionary new.
	ruler nodes reverseDo: [ :node |
		self markNode: node ].! !

!HiBranchMapping methodsFor: 'initialization' stamp: ''!
initializeWith: aHiRuler
	self initialize.
	ruler := aHiRuler! !

!HiBranchMapping methodsFor: 'private' stamp: ''!
markNode: aHiNode
	| branch |
	branch := aHiNode hasAnyLink 
		ifTrue: [ branchCount := branchCount + 1 ]
		ifFalse: [ self branchAtLink: aHiNode anyLink ].
	branchByNode
		at: aHiNode
		put: branch! !

!HiBranchMapping methodsFor: 'building' stamp: ''!
build
	"Build the internal collaborators that will know the branch numbers for each node and link in the ruler. Required after instance creation."
	
	branchCount := 0.
	self buildBranchByLink.
	self buildBranchByNode.! !

!HiBranchMapping methodsFor: 'accessing' stamp: ''!
branchByNode
	^ branchByNode! !

!HiBranchMapping class methodsFor: 'convenience' stamp: ''!
builtFor: aHiRuler 
	^ (self newFor: aHiRuler)
		build;
		yourself! !

!HiBranchMapping class methodsFor: 'instance creation' stamp: ''!
newFor: aHiRuler 
	^ self basicNew
		initializeWith: aHiRuler;
		yourself! !

!HiColumnController commentStamp: ''!
I am a column controller. My responsability is to provide a convenient API to Hiedra users, either in Spec (TreePresenter) or Morph (FastTable). Basically, a table widget that shows a Hiedra visualization in a column will obtain the "cell morphs" that correspond to each row of the table. 

I implement a pagination mechanism to split the rendering of a HiRuler in pages of a fixed size on demand.

My most important collaborator is a Hiedra renderer (subclass of HiAbstractRenderer) that the user can personalize with appearance settings, and that my instances use to render the pages forms on demand.!
!HiColumnController methodsFor: 'API' stamp: ''!
renderer
	^ renderer! !

!HiColumnController methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	renderer := HiSimpleRenderer new.
	pageSize := 30.
	session := Smalltalk session.
	self reset.! !

!HiColumnController methodsFor: 'private' stamp: ''!
formAtPage: pageIndex

	self checkSession.

	^ formByPageIndex
		at: pageIndex
		ifAbsentPut: [
			renderer
				rowsInterval: (self rowIntervalAtPage: pageIndex);
				newForm ]! !

!HiColumnController methodsFor: 'private' stamp: ''!
pageIndexAtRow: rowIndex

	^ (rowIndex - 1) // self pageSize! !

!HiColumnController methodsFor: 'API' stamp: ''!
pageSize: anInteger
	"Set the number of rows that will be rendered together (when I'm asked for a missing cell Morph)."

	pageSize := anInteger! !

!HiColumnController methodsFor: 'API' stamp: ''!
cellMorphAtValue: aValue
	"Answer a Morph that corresponds to aValue. See #cellMorphAtRowIndex: for more information."

	^ self cellMorphAtRow: (self rowIndexAtValue: aValue)! !

!HiColumnController methodsFor: 'API' stamp: ''!
renderer: aHiRulerRenderer
	renderer := aHiRulerRenderer! !

!HiColumnController methodsFor: 'API' stamp: ''!
ruler
	^ renderer ruler! !

!HiColumnController methodsFor: 'API' stamp: ''!
pageSize
	^ pageSize! !

!HiColumnController methodsFor: 'private' stamp: ''!
rowIntervalAtPage: pageIndex
	"Answer the interval of row indices that correspond to the specified page index."

	^ 	(self rowIndexOfFirstItemAtPage: pageIndex) to: 
		(((pageIndex + 1) * self pageSize) min: self ruler numberOfRows)! !

!HiColumnController methodsFor: 'API' stamp: ''!
ruler: aHiRuler
	renderer ruler: aHiRuler! !

!HiColumnController methodsFor: 'private' stamp: ''!
checkSession

	session == Smalltalk session 
		ifFalse: [ self reset ]! !

!HiColumnController methodsFor: 'private' stamp: ''!
rowIndexAtValue: aValue
	^ self ruler valueIndices
		at: aValue
		ifAbsent: [ self error: 'Value not found. Should the table refresh the ruler?' ]! !

!HiColumnController methodsFor: 'API' stamp: ''!
rulerWidth

	^ renderer formWidth! !

!HiColumnController methodsFor: 'private' stamp: ''!
cellBoundsForRow: rowIndex inPage: pageIndex
	
	| rowIndexRelativeToRuler rowIndexRelativeToPage rowIndexOfFirstNodeInPage |
	rowIndexRelativeToRuler := (self ruler nodeAtRow: rowIndex) rulerPoint y.
	rowIndexOfFirstNodeInPage := self rowIndexOfFirstItemAtPage: pageIndex.
	rowIndexRelativeToPage := rowIndexRelativeToRuler - rowIndexOfFirstNodeInPage.

	^ 0 @ (rowIndexRelativeToPage * renderer rowHeight)
		corner: (renderer rowWidthAt: rowIndex) @ ((rowIndexRelativeToPage + 1) * renderer rowHeight)! !

!HiColumnController methodsFor: 'private' stamp: ''!
newCellMorphForRow: rowIndex
	"Answer a Morph that corresponds to aValue in the rendered ruler."

	| pageIndex aForm cellBoundsInPage |
	pageIndex := self pageIndexAtRow: rowIndex.
	cellBoundsInPage := self
		cellBoundsForRow: rowIndex
		inPage: pageIndex.

	aForm := Form
		extent: cellBoundsInPage extent
		depth: 32.
	aForm getCanvas
		translucentImage: (self formAtPage: pageIndex)
		at: 0 @ 0
		sourceRect: cellBoundsInPage.
	^ aForm asMorph! !

!HiColumnController methodsFor: 'API' stamp: ''!
reset
	"Reset the internal state with the purpose to regenerate the visualization the next time #cellMorphFor: is executed."

	cellMorphByRowIndex := Dictionary new.
	formByPageIndex := Dictionary new.! !

!HiColumnController methodsFor: 'API' stamp: ''!
cellMorphAtRow: rowIndex
	"Answer a Morph that corresponds to a row index. The height of such Morph is given by renderer's rowHeight and the width is given by the ruler's numberOfColumns and the renderer's cellWidth.
	This is an important method of this class, that the table widget will use to fill each Hiedra column's cell."

	self checkSession.

	^ cellMorphByRowIndex at: rowIndex ifAbsent: [ self newCellMorphForRow: rowIndex ]! !

!HiColumnController methodsFor: 'private' stamp: ''!
rowIndexOfFirstItemAtPage: pageIndex
	^ pageIndex * self pageSize + 1! !

!HiExampleCommit commentStamp: ''!
I'm a fake commit that serves as model for Hiedra examples.

The example methods in class-side captured the commits in real git tags.
To capture each one, the following code was inserted into IceTipCommitsDataSource>>elements:

~~~~
[	| commits commitsAsString sourceCode selector |
	commits := elements collect: [:each | 
		HiExampleCommit new
			id: each entity id;
			comment: each entity comment;
			parentIds: each entity ancestorIds;
			yourself ].
	commitsAsString := STON toStringPretty: commits.
	selector := tool model repositoryModel name, '_', ((tool model name copyReplaceAll: '.' with: '_') copyReplaceAll: '-' with: '_').
	sourceCode := selector, '
	^ STON fromString: (', commitsAsString storeString, ')'.
	HiExampleCommit classSide compile: sourceCode classified: #examples. 
] value.

~~~~

!
!HiExampleCommit methodsFor: 'accessing' stamp: ''!
parentIds
	^ parentIds! !

!HiExampleCommit methodsFor: 'accessing' stamp: ''!
id: anObject
	id := anObject! !

!HiExampleCommit methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Append a sequence of characters to aStream that identify the receiver."

	super printOn: aStream.

	aStream
		nextPut: $(;
		print: id;
		nextPutAll: ' -> ';
		print: parentIds asArray;
		nextPut: $).! !

!HiExampleCommit methodsFor: 'accessing' stamp: ''!
comment
	^ comment! !

!HiExampleCommit methodsFor: 'accessing' stamp: ''!
comment: anObject
	comment := anObject! !

!HiExampleCommit methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!HiExampleCommit methodsFor: 'accessing' stamp: ''!
parentIds: aCollection
	parentIds := aCollection! !

!HiExampleCommit class methodsFor: 'examples' stamp: ''!
randomlyGenerated

	| values random |
	values := 60 to: 1 by: -1.
	random := Random new.
	^ (values collect: [ :value | 
		self new
			id: value;
			comment: 'Randomly Connected Element #', value asString;
			parentIds: ((values copyWithout: value) intersection: { random nextInteger: values max });
			yourself
		]) reversed! !

!HiExamplesTest methodsFor: 'running' stamp: ''!
tearDown 
	
	example ifNotNil: [ example close ].
	super tearDown! !

!HiExamplesTest methodsFor: 'private' stamp: ''!
performTest
	example := self class classWithExamplesToTest perform: testSelector asSymbol! !

!HiExamplesTest class methodsFor: 'tests' stamp: ''!
whichClassIncludesTestSelector: aSymbol
	^self classWithExamplesToTest classSide whichClassIncludesSelector: aSymbol! !

!HiExamplesTest class methodsFor: 'tests' stamp: ''!
classWithExamplesToTest
	^ self! !

!HiExamplesTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = HiExamplesTest! !

!HiExamplesTest class methodsFor: 'tests' stamp: ''!
testSelectors

	^ self classWithExamplesToTest classSide methods 
			select: [ :each |  (each selector beginsWith: 'example') and: [ each numArgs = 0 ] ]
			thenCollect: [ :each | each selector ]! !

!HiFastTableExample commentStamp: ''!
I am an example of use of Hiedra in a FastTable.!
!HiFastTableExample methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
	"Answer a morph with the cell view."
	
	column id = #'Comment' ifTrue: [
		| hiedraMorph commentMorph |
		hiedraMorph := hiedraColumnController cellMorphAtRow: rowIndex.
		commentMorph := (self elementAt: rowIndex) comment asMorph.
		^ FTCellMorph new
			addMorphBack: hiedraMorph;
			addMorphBack: commentMorph;
			yourself
		].

	^ self error! !

!HiFastTableExample methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	hiedraColumnController := HiColumnController new.
	hiedraColumnController renderer
		arrowSize: 1;
		nodeConnectionOffset: 2;
		cellWidth: 7.! !

!HiFastTableExample methodsFor: 'accessing' stamp: ''!
elements: commits
	super elements: commits.

	"Adjust the ruler rendering settings with table's row height."
	hiedraColumnController renderer rowHeight: self table rowHeight floor.

	"Create a new ruler model with the new elements"
	hiedraColumnController ruler: (HiRulerBuilder 
		newRulerValues: commits
		linksBlock: [:aCommit |
			aCommit parentIds collect: [:id | 
				commits detect: [:each | each id = id ] ] ]).

	"Reset the visualization"
	hiedraColumnController reset.! !

!HiFastTableExample class methodsFor: 'examples' stamp: ''!
example60RandomCommits
	^ self openExample: #randomlyGenerated! !

!HiFastTableExample class methodsFor: 'examples' stamp: ''!
openExample: selector

	| commits dataSource table |
	commits := HiExampleCommit perform: selector.
	dataSource := self new.

	table := FTTableMorph new
		extent: 500 @ 700;
		addColumn: (FTColumn id: #'Comment');
		hideColumnHeaders;
		dataSource: dataSource;
		beResizable;
		yourself.
	
	dataSource elements: commits.
	
	^ table openInWindowLabeled: ('Hiedra in FastTable - {1} - {2} elements' format: {selector. commits size}).! !

!HiFastTableExampleTest class methodsFor: 'tests' stamp: ''!
classWithExamplesToTest
	^ HiFastTableExample! !

!HiLink commentStamp: ''!
I am a directed link that connects an origin node with a target node in a Hiedra ruler.!
!HiLink methodsFor: 'accessing' stamp: ''!
origin
	^ origin! !

!HiLink methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	
	aStream
		nextPut: $(;
		print: origin theValue;
		nextPutAll: '->';
		print: target theValue;
		nextPut: $).! !

!HiLink methodsFor: 'testing' stamp: ''!
isDescending
	"Answer whether the origin of this link is over the target."

	^ origin rulerPoint y < target rulerPoint y! !

!HiLink methodsFor: 'accessing' stamp: ''!
intermediatePoints
	^ intermediatePoints! !

!HiLink methodsFor: 'testing' stamp: ''!
doesContinue: anotherLink
	^ anotherLink target = origin! !

!HiLink methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!HiLink methodsFor: 'initialization' stamp: ''!
initializeWithOrigin: aNode target: anotherNode intermediatePoints: aCollectionOfPoints

	self initialize.
	
	origin := aNode.
	target := anotherNode.
	intermediatePoints := aCollectionOfPoints.! !

!HiLink class methodsFor: 'instance creation' stamp: ''!
origin: aNode target: anotherNode intermediatePoints: aListOfPoints

	^ self basicNew
		initializeWithOrigin: aNode target: anotherNode intermediatePoints: aListOfPoints;
		yourself! !

!HiNode commentStamp: ''!
I am a node that represents a value in a Hiedra ruler. I know links that connect myself with other nodes of the same ruler (incoming and outgoing).

!
!HiNode methodsFor: 'accessing' stamp: ''!
rulerPoint
	^ rulerPoint! !

!HiNode methodsFor: 'testing' stamp: ''!
hasAnyLink
	^ outgoingLinks isEmpty and: [ incomingLinks isEmpty ]! !

!HiNode methodsFor: 'accessing' stamp: ''!
theValue
	^ value! !

!HiNode methodsFor: 'accessing' stamp: ''!
addIncomingLink: aHiLink 
	incomingLinks add: aHiLink! !

!HiNode methodsFor: 'accessing' stamp: ''!
outgoingLinks
	^ outgoingLinks! !

!HiNode methodsFor: 'accessing' stamp: ''!
anyLink
	"Answer a link (assuming it has at least one either outgoing or incoming link)."

	^ (outgoingLinks ifEmpty: [ incomingLinks ]) first! !

!HiNode methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	
	aStream
		nextPut: $(;
		print: value;
		space;
		print: self rulerPoint;
		nextPut: $).! !

!HiNode methodsFor: 'accessing' stamp: ''!
intermediateRowIndicesTo: anotherNode

	| originRowIndex targetRowIndex |
	originRowIndex := self rulerPoint y.
	targetRowIndex := anotherNode rulerPoint y.

	^ originRowIndex <= targetRowIndex
		ifTrue: [ originRowIndex + 1 to: targetRowIndex - 1 ]
		ifFalse: [ originRowIndex - 1 to: targetRowIndex + 1 by: -1 ]! !

!HiNode methodsFor: 'initialization' stamp: ''!
initializeWithValue: aValue rulerPoint: aPoint

	self initialize.
	rulerPoint := aPoint.
	value := aValue.
	outgoingLinks := LinkedList new.
	incomingLinks := LinkedList new.! !

!HiNode methodsFor: 'accessing' stamp: ''!
incomingLinks
	^ incomingLinks! !

!HiNode methodsFor: 'testing' stamp: ''!
hasLinkTo: aHiNode
	^ outgoingLinks anySatisfy: [ :each | each target = aHiNode ]! !

!HiNode methodsFor: 'accessing' stamp: ''!
addOutgoingLink: aHiLink 
	outgoingLinks add: aHiLink! !

!HiNode class methodsFor: 'instance creation' stamp: ''!
value: aValue rulerPoint: aPoint
	^ self basicNew
		initializeWithValue: aValue
			rulerPoint: aPoint;
		yourself! !

!HiRuler commentStamp: ''!
I represent a model for a Hiedra visualization (a ruler), which is composed of nodes and links between such nodes.

The user must create a ruler with a list of values. Then, my API provides #addNodeFor: and #addLinkFrom:to: to fill the ruler. Example:

```
	| ruler c b a |
	ruler := HiRuler withValues: #(c b a).

	c := ruler addNodeFor: #c.
	a := ruler addNodeFor: #a.
	ruler addLinkFrom: c to: a.

	b := ruler addNodeFor: #b.
	ruler
		addLinkFrom: c to: b;
		addLinkFrom: b to: a.
```

Which generates a ruler like:

	c
	|\ 
	| | 
	| b 
	| | 
	|/ 
	a 


Note 1: A ruler always has a 1-to-1 relation between values, rows and nodes.
Note 2: See HiAbstractRenderer to render my instances into Forms.!
!HiRuler methodsFor: 'accessing' stamp: ''!
links
	^ links! !

!HiRuler methodsFor: 'accessing' stamp: ''!
nodes
	^ nodeByRow! !

!HiRuler methodsFor: 'accessing' stamp: ''!
valueIndices
	^ rowByValue! !

!HiRuler methodsFor: 'accessing' stamp: ''!
addLinkFrom: aNode to: anotherNode
	"Add a HiLink to the ruler from aNode to anotherNode. The link will occupy a free point in the ruler for each intermediate row from the origin to the target node."
	
	| intermediatePoints newLink |
	intermediatePoints := (aNode intermediateRowIndicesTo: anotherNode)
		collect: [ :row | ((elementsByRow at: row) size + 1) @ row ].

	newLink := HiLink
		origin: aNode
		target: anotherNode
		intermediatePoints: intermediatePoints.

	(linksByRow at: aNode rulerPoint y) add: newLink.
	intermediatePoints do: [ :aPoint |
		(elementsByRow at: aPoint y) addLast: newLink.
		(linksByRow at: aPoint y) add: newLink ].
	(linksByRow at: anotherNode rulerPoint y) add: newLink.
	
	aNode addOutgoingLink: newLink.
	anotherNode addIncomingLink: newLink.
	links add: newLink.
	
	^ newLink! !

!HiRuler methodsFor: 'accessing' stamp: ''!
addNodeFor: aValue
	"Add the node for aValue. The node will occupy a free point in the ruler in the corresponding row.
	
	Constraints:
	- aValue must belong to the initial list of values used when creating the ruler instance.
	- aValue must be added exactly once as node.
	"

	| newNode rowElements columnIndex rowIndex |
	rowIndex := rowByValue at: aValue.
	rowElements := elementsByRow at: rowIndex.
	columnIndex := rowElements size + 1.
	newNode := HiNode value: aValue rulerPoint: columnIndex@rowIndex.

	rowElements addLast: newNode.
	nodeByRow at: rowIndex put: newNode.
	nodeByValue at: aValue put: newNode.
	valueByRow at: rowIndex put: aValue. "TODO: Remove... too much redundancy"
	
	^ newNode! !

!HiRuler methodsFor: 'accessing' stamp: ''!
elementsByRow
	^ elementsByRow! !

!HiRuler methodsFor: 'accessing' stamp: ''!
linksAtRow: rowIndex

	^ linksByRow at: rowIndex! !

!HiRuler methodsFor: 'accessing' stamp: ''!
nodeAtValue: aValue

	^ nodeByValue at: aValue! !

!HiRuler methodsFor: 'accessing' stamp: ''!
numberOfColumns

	^ elementsByRow 
		ifEmpty: [ 0 ]
		ifNotEmpty: [ elementsByRow max: #size ]! !

!HiRuler methodsFor: 'accessing' stamp: ''!
numberOfRows

	^ elementsByRow size! !

!HiRuler methodsFor: 'initialization' stamp: ''!
initializeWithValues: aSequenceableCollection 

	self initialize.
	valueByRow := aSequenceableCollection.

	rowByValue := Dictionary new: valueByRow size.
	valueByRow withIndexDo: [ :each :index | rowByValue at: each put: index ].
	nodeByValue := Dictionary new: valueByRow size.
	nodeByRow := Array new: valueByRow size.
	links := OrderedCollection new.

	elementsByRow := Array new: valueByRow size.
	linksByRow := Array new: valueByRow size.
	1 to: valueByRow size do: [ :index | 
		elementsByRow at: index put: LinkedList new.
		linksByRow at: index put: LinkedList new ].! !

!HiRuler methodsFor: 'accessing' stamp: ''!
numberOfColumnsAt: rowIndex

	^ (elementsByRow at: rowIndex) size! !

!HiRuler methodsFor: 'accessing' stamp: ''!
values
	^ valueByRow! !

!HiRuler methodsFor: 'accessing' stamp: ''!
nodeAtRow: rowIndex

	^ nodeByRow at: rowIndex! !

!HiRuler methodsFor: 'accessing' stamp: ''!
nodeAtValue: aValue ifAbsent: aBlock

	^ nodeByValue at: aValue ifAbsent: aBlock! !

!HiRuler class methodsFor: 'instance creation' stamp: ''!
new
	"use #withNumberOfRows: instead"
	self shouldNotImplement! !

!HiRuler class methodsFor: 'instance creation' stamp: ''!
withValues: aSequenceableCollection
	
	^ self basicNew
		initializeWithValues: aSequenceableCollection;
		yourself.! !

!HiRulerBuilder commentStamp: ''!
I provide a convenient API to create instances of HiRuler. The user sets a list of values (will be wrapped as nodes) and a linksBlock (that answers what values are connected from a value). 

A class side method eases the creation in ony one message send.!
!HiRulerBuilder methodsFor: 'private' stamp: ''!
stackLinksFrom: aValue in: pending

	| linkedValues |
	linkedValues := linksBlock value: aValue.
	linkedValues reverseDo: [:each | pending push: (aValue -> each) ].! !

!HiRulerBuilder methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	linksBlock := [ :value | #() ].
	values := #().! !

!HiRulerBuilder methodsFor: 'private' stamp: ''!
buildLinksStartingAt: aValue
	"This method traverses the values using the linkBlock."

	| pending |
	pending := Stack new.
	self stackLinksFrom: aValue in: pending.

	[ pending isEmpty ] whileFalse: [
		| next aNode anotherNode |
		next := pending pop.

		aNode := ruler nodeAtValue: next key.
		anotherNode := ruler
			nodeAtValue: next value
			ifAbsent: [ 
				self stackLinksFrom: next value in: pending.
				ruler addNodeFor: next value ].

		(aNode hasLinkTo: anotherNode) ifFalse: [ 
			ruler addLinkFrom: aNode to: anotherNode.
		].

	].! !

!HiRulerBuilder methodsFor: 'accessing' stamp: ''!
linksBlock: aBlockClosure

	linksBlock := aBlockClosure! !

!HiRulerBuilder methodsFor: 'building' stamp: ''!
ruler
	^ ruler! !

!HiRulerBuilder methodsFor: 'accessing' stamp: ''!
values
	^ values! !

!HiRulerBuilder methodsFor: 'building' stamp: ''!
build
	
	ruler := HiRuler withValues: values.

	values do: [ :each | 
		ruler
			nodeAtValue: each
			ifAbsent: [
				ruler addNodeFor: each.
				self buildLinksStartingAt: each ].
		].! !

!HiRulerBuilder methodsFor: 'accessing' stamp: ''!
values: aCollection 
	values := aCollection! !

!HiRulerBuilder methodsFor: 'accessing' stamp: ''!
linksBlock
	^ linksBlock! !

!HiRulerBuilder class methodsFor: 'convenience' stamp: ''!
newRulerValues: aCollection linksBlock: aBlockClosure
	^ self new
		values: aCollection;
		linksBlock: aBlockClosure;
		build;
		ruler! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testCycle
	"
	b
	| \
	| /
	a
	"

	self buildRulerWith: {
		#b -> #(a).
		#a -> #(b).
	}.

	self assertRulerHasNodes: {
		#b -> (1@1).
		#a -> (1@2).
	}.
	
	self assertRulerHasLinks: {
		(#b->#a) -> {1@1. 1@2}.
		(#a->#b) -> {1@2. 1@1}.
	}.! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testTwoMergedForks
	"
	c
	|\ 
	| | 
	| b 
	| | 
	|/ 
	a 
	"
	
	self buildRulerWith: {
		#c -> #(a b) copy.
		#b -> #(a) copy.
		#a -> #() copy.
	}.

	self assertRulerHasNodes: {
		#c -> (1@1).
		#b -> (2@2).
		#a -> (1@3).
	}.
	
	self assertRulerHasLinks: {
		(#c->#a) -> {1@1. 1@2. 1@3}.

		(#c->#b) -> {1@1. 2@2}.
		(#b->#a) -> {2@2. 1@3}.
	}.! !

!HiRulerBuilderTest methodsFor: 'running' stamp: ''!
debugShowingRulerInPresenter: valuesAndParentsAsDictionary
	"Open a Spec window when a class variable enables it.

	Enable with:
		DebugShowingRulerInWindow := true.
	Disable with:
		DebugShowingRulerInWindow := false.
	"

	| hiedraColumnController values |
	DebugShowingRulerInWindow ifFalse: [ ^ self ].

	values := valuesAndParentsAsDictionary keys.

	"Set up the ruler controller."
	hiedraColumnController := HiColumnController new.
	hiedraColumnController ruler: (HiRulerBuilder newRulerValues: values linksBlock: [ :key | valuesAndParentsAsDictionary at: key ]).
	hiedraColumnController renderer
		rowHeight: FTTableMorph defaultRowHeight floor;
		cellWidth: 10.
	hiedraColumnController reset.

	"Show the ruler in a Spec tree."
	SpTablePresenter new
		addColumn:
			((SpStringTableColumn evaluated: #value)
				width: 15;
				yourself);
		addColumn: (SpImageTableColumn evaluated: [ :item | hiedraColumnController cellMorphAtValue: item ]);
		items: values;
		title: testSelector asString;
		openWithSpec! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testTwoUnconnectedNodes
	"
	b

	a	 	
	"

	self buildRulerWith: {
		#b -> #().
		#a -> #().
	}.

	self assertRulerHasNodes: {
		#b -> (1@1).
		#a -> (1@2).
	}.
	
	self assertRulerHasLinks: {
	}.! !

!HiRulerBuilderTest methodsFor: 'running' stamp: ''!
assertRulerHasNodes: expectedNodesAndRulerPointsAsAssociations

	| actualNodes failures |
	actualNodes := ruler nodes.
	self assert: actualNodes size equals: expectedNodesAndRulerPointsAsAssociations size.
	self
		assert: (actualNodes collect: #theValue as: Bag)
		equals: (expectedNodesAndRulerPointsAsAssociations collect: #key as: Bag).

	failures := expectedNodesAndRulerPointsAsAssociations select: [ :each |
		| actualNode expectedValue expectedRulerPoint|
		expectedValue := each key.
		expectedRulerPoint := each value.
		actualNode := actualNodes detect: [:aNode | aNode theValue = expectedValue ].
		actualNode rulerPoint ~= expectedRulerPoint.
		].

	self
		assert: failures isEmpty
		description: [ 'Nodes found at unexpected points: {1}'
			format: { failures printString } ].! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testTwoMergedForks2
	"
	c
	|\ 
	| | 
	b | 
	| | 
	|/ 
	a 
	"
	
	self buildRulerWith: {
		#c -> #(b a).
		#b -> #(a).
		#a -> #().
	}.

	self assertRulerHasNodes: {
		#c -> (1@1).
		#b -> (1@2).
		#a -> (1@3).
	}.
	
	self assertRulerHasLinks: {
		(#c->#b) -> {1@1. 1@2}.
		(#b->#a) -> {1@2. 1@3}.

		(#c->#a) -> {1@1. 2@2. 1@3}.
	}.! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testEmpty
	self buildRulerWith: #().

	self assertEmpty: ruler nodes.
	self assertEmpty: ruler links! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testThreeMergedForks
	"
	d
	|\ 
	| | 
	c | 
	|\| 
	|/\
	b |
	| | 
	|/ 
	a
	"
	
	self buildRulerWith: {
		#d -> #(c b).
		#c -> #(b a).
		#b -> #(a).
		#a -> #().
	}.

	self assertRulerHasNodes: {
		#d -> (1@1).
		#c -> (1@2).
		#b -> (1@3).
		#a -> (1@4).
	}.
	
	self assertRulerHasLinks: {
		(#d->#c) -> {1@1. 1@2}.
		(#c->#b) -> {1@2. 1@3}.
		(#b->#a) -> {1@3. 1@4}.

		(#c->#a) -> {1@2. 2@3. 1@4}.

		(#d->#b) -> {1@1. 2@2. 1@3}.
	}.! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testThreeMergedForks3
	"
	d
	|\ 
	| | 
	| c 
	| | 
	|/| 
	b |
	| | 
	|/ 
	a
	"
	
	self buildRulerWith: {
		#d -> #(b c).
		#c -> #(a b).
		#b -> #(a).
		#a -> #().
	}.

	self assertRulerHasNodes: {
		#d -> (1@1).
		#c -> (2@2).
		#b -> (1@3).
		#a -> (1@4).
	}.
	
	self assertRulerHasLinks: {
		(#d->#b) -> {1@1. 1@2. 1@3}.
		(#b->#a) -> {1@3. 1@4}.

		(#d->#c) -> {1@1. 2@2}.
		(#c->#a) -> {2@2. 2@3. 1@4}.

		(#c->#b) -> {2@2. 1@3}.
	}.! !

!HiRulerBuilderTest methodsFor: 'running' stamp: ''!
assertRulerHasLinks: expectedLinksAndRulerPointsAsAssociations

	| actualRulerPoints |
	self assert: ruler links size equals: expectedLinksAndRulerPointsAsAssociations size.

	expectedLinksAndRulerPointsAsAssociations withIndexDo: [ :each :index |
		| actualLink expectedLinkAsAssociation rulerPoints |
		actualLink := ruler links at: index.
		expectedLinkAsAssociation := each key.
		rulerPoints := each value.
		actualRulerPoints := {actualLink origin rulerPoint}, actualLink intermediatePoints asArray, {actualLink target rulerPoint}.
		self
			assert: actualLink origin theValue -> actualLink target theValue
			equals: expectedLinkAsAssociation.
		self
			assert: actualRulerPoints = rulerPoints asArray
			description: [ '{1}: Found {2} instead of {3}.' format: { actualLink. actualRulerPoints. rulerPoints } ].
	]! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testThreeMergedForks2
	"
	d
	|\ 
	| | 
	| c 
	| | 
	|/| 
	b |
	| | 
	|/ 
	a
	"
	
	self buildRulerWith: {
		#d -> #(b c).
		#c -> #(b a).
		#b -> #(a).
		#a -> #().
	}.

	self assertRulerHasNodes: {
		#d -> (1@1).
		#c -> (2@2).
		#b -> (1@3).
		#a -> (1@4).
	}.
	
	self assertRulerHasLinks: {
		(#d->#b) -> {1@1. 1@2. 1@3}.
		(#b->#a) -> {1@3. 1@4}.

		(#d->#c) -> {1@1. 2@2}.
		(#c->#b) -> {2@2. 1@3}.

		(#c->#a) -> {2@2. 2@3. 1@4}.
	}.! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testTwoUnmergedForks
	"
	d
	|
	| c
	| |
	b |
	|/
	a
	"

	self buildRulerWith: {
		#d -> #(b).
		#c -> #(a).
		#b -> #(a).
		#a -> #().
	}.

	self assertRulerHasNodes: {
		#d -> (1@1).
		#b -> (1@3).
		#a -> (1@4).
		#c -> (2@2).
	}.
	
	self assertRulerHasLinks: {
		(#d->#b) -> {1@1. 1@2. 1@3}.
		(#b->#a) -> {1@3. 1@4}.

		(#c->#a) -> {2@2. 2@3. 1@4}.
	}.! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testTwoConnectedNodes
	"
	b
	|
	a
	"

	self buildRulerWith: {
		#b -> #(a).
		#a -> #().
	}.

	self assertRulerHasNodes: {
		#b -> (1@1).
		#a -> (1@2).
	}.
	
	self assertRulerHasLinks: {
		(#b->#a) -> {1@1. 1@2}.
	}.! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testFourMergedForks
	"
	d
	|\ \
	| | | 
	| c | 
	| |\| 
	| |/\
	| b |
	| | | 
	|/ /
	a
	"
	
	self buildRulerWith: {
		#d -> #(a c b).
		#c -> #(b a).
		#b -> #(a).
		#a -> #().
	}.

	self assertRulerHasNodes: {
		#d -> (1@1).
		#c -> (2@2).
		#b -> (2@3).
		#a -> (1@4).
	}.
	
	self assertRulerHasLinks: {
		(#d->#a) -> {1@1. 1@2. 1@3. 1@4}.

		(#d->#c) -> {1@1. 2@2}.
		(#c->#b) -> {2@2. 2@3}.
		(#b->#a) -> {2@3. 1@4}.

		(#c->#a) -> {2@2. 3@3. 1@4}.

		(#d->#b) -> {1@1. 3@2. 2@3}.
	}.! !

!HiRulerBuilderTest methodsFor: 'tests' stamp: ''!
testOneNode
	"
	a
	"

	self buildRulerWith: {
		#a -> #().
	}.

	self assertRulerHasNodes: {
		#a -> (1@1).
	}.
	
	self assertEmpty: ruler links.! !

!HiRulerBuilderTest methodsFor: 'running' stamp: ''!
buildRulerWith: valuesAndParentsAsAssociations

	| valuesAndParentsAsDictionary values |

	"This dictionary keeps order, we need it."
	valuesAndParentsAsDictionary := valuesAndParentsAsAssociations as: SmallDictionary.
	values := valuesAndParentsAsDictionary keys.
	
	ruler := HiRulerBuilder new 
		values: values;
		linksBlock: [ :key | valuesAndParentsAsDictionary at: key ];
		build;
		ruler.

	self debugShowingRulerInPresenter: valuesAndParentsAsDictionary.! !

!HiRulerBuilderTest class methodsFor: 'initialize - event' stamp: ''!
initialize
	DebugShowingRulerInWindow := false! !

!HiRulerTest commentStamp: ''!
A HiRulerTest is a test class for testing the behavior of HiRuler!
!HiRulerTest methodsFor: 'tests' stamp: ''!
testTwoMergedForks
	"
	c
	|\ 
	| | 
	| b 
	| | 
	|/ 
	a 
	"

	| ruler c b a |
	ruler := HiRuler withValues: #(c b a) copy.

	c := ruler addNodeFor: #c.
	a := ruler addNodeFor: #a.
	ruler addLinkFrom: c to: a.

	b := ruler addNodeFor: #b.
	ruler
		addLinkFrom: c to: b;
		addLinkFrom: b to: a.

	self assertCollection: ruler nodes hasSameElements: {c . b . a}.
	self assert: ruler links size equals: 3.

	self assert: c rulerPoint equals: 1 @ 1.
	self assert: b rulerPoint equals: 2 @ 2.
	self assert: a rulerPoint equals: 1 @ 3.

	self assert: c theValue equals: #c.
	self assert: b theValue equals: #b.
	self assert: a theValue equals: #a! !

!HiRulerTest methodsFor: 'tests' stamp: ''!
testEmpty
	| ruler |
	ruler := HiRuler withValues: #().

	self assertEmpty: ruler nodes.
	self assertEmpty: ruler links.
	self assertEmpty: ruler elementsByRow.
	self assert: ruler numberOfColumns equals: 0.
	self assert: ruler numberOfRows equals: 0! !

!HiSimpleRenderer commentStamp: ''!
I render a Hiedra visualization (HiRuler) in a Form using Athens. The nodes and links of the ruler will occupy the cells of an imaginary grid in the Athens canvas. 

Decisions to render the ruler:

* All nodes have the same appearance (radius, color, etc.).
* All links have the same appearance (width, color, etc.).
* All cells have same dimensions (width and height).

The #accessing methods provide a way to customize the renderization.

IMPORTANT: The #rowHeight is only rendering parameter that HAS NO DEFAULT VALUE and the user must set it with the pixel height of rows (an integer number).
!
!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
cellCenterFor: aRulerPoint

	^ (self cellOriginFor: aRulerPoint) + ((cellWidth // 2) @ (rowHeight // 2))! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
renderLinks: links on: athensCanvas

	"Draw each link on the canvas."
	links do: [ :each | 

		"Set the paint for this link."
		(athensCanvas setStrokePaint: (colorStrategy colorForLink: each)) width: linkWidth.
		athensCanvas paint joinMiter.
	
		"Draw it"
		athensCanvas drawShape: (self athensPathForLink: each on: athensCanvas) ]! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
nodeBottomRelativeConnectionPoint

	^ 0 @ (nodeRadio + nodeConnectionOffset)! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
nodeRadius: aNumber
	nodeRadio := aNumber! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
addLinkFragmentFromTopLeft: topPoint toBottomRight: bottomPoint intermediateY: intermediateY into: athensPathBuilder
	"	
		 s
		 \___
		     \
		     e
	"

	| halfColumn |
	halfColumn := cellWidth/2.
	athensPathBuilder
		ccwArcTo: (topPoint x    + halfColumn) @ intermediateY angle: self linkCurveAngle;
		lineTo:   (bottomPoint x - halfColumn) @ intermediateY;
		cwArcTo:  bottomPoint angle: self linkCurveAngle! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
useUniformColorStrategy
	colorStrategy := HiUniformColorStrategy new.
	colorStrategy ruler: ruler.! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
arrowSize
	^ arrowSize! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
linkColor: aColor
	self useUniformColorStrategy.
	colorStrategy linkColor: aColor.! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
linkCurveAngle
	^ linkCurveAngle! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
linkDashes: anArrayOfFillGapPairs
	"Set how are the links dashed. 
	See AthensStrokePaint>>dashes:offset: to understand the parameter."

	linkDashes := anArrayOfFillGapPairs! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
nodeBorderWidth: aNumber
	nodeBorderWidth := aNumber! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
rowHeight: anInteger
	"Set the pixel height for rows (an integer number).
	Note this assumes there is a unique height for all rows."

	rowHeight := anInteger! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
colorStrategy
	^ colorStrategy! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
arrowSize: aNumber
	arrowSize := aNumber! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
linkWidth: aNumber
	linkWidth := aNumber! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
ruler: aHiRuler
	super ruler: aHiRuler.
	colorStrategy ruler: ruler.! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
athensPathForLink: aHiLink on: athensCanvas
	"Answer the Athens path for a link."

	^ aHiLink isDescending
		ifTrue: [ 
			self
				athensPathForDescendingLink: aHiLink
				on: athensCanvas ]
		ifFalse: [
			self
				athensPathForAscendingLink: aHiLink
				on: athensCanvas ]! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
addLinkFragmentFromTopRight: topPoint toBottomLeft: bottomPoint intermediateY: intermediateY into: athensPathBuilder
	"	
		     s
		  ___/
		 /
		 e
	"

	| halfColumn |
	halfColumn := cellWidth/2.
	athensPathBuilder 
		cwArcTo:  (topPoint x    - halfColumn) @ intermediateY angle: self linkCurveAngle;
		lineTo:   (bottomPoint x + halfColumn) @ intermediateY;
		ccwArcTo: bottomPoint angle: self linkCurveAngle! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
cellOriginFor: aRulerPoint

	^ ((aRulerPoint x - 1) * cellWidth) @ 
	  ((aRulerPoint y - 1) * rowHeight)! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
linkWidth
	^ linkWidth! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
nodeColor: aColor
	self useUniformColorStrategy.
	colorStrategy nodeColor: aColor! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
athensPathForNodeOn: athensCanvas
	"Answer the Athens path for a node."

	| nd pd |
	pd := nodeRadio.
	nd := -1 * nodeRadio.
	^ athensCanvas createPath: [ :pathBuilder | 
		pathBuilder
			absolute;
			moveTo: nd @ 0;
			ccwArcTo: 0 @ pd angle: 90 degreesToRadians;
			ccwArcTo: pd @ 0 angle: 90 degreesToRadians;
			ccwArcTo: 0 @ nd angle: 90 degreesToRadians;
			ccwArcTo: nd @ 0 angle: 90 degreesToRadians ]! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
colorStrategy: aHiColorStrategy
	colorStrategy := aHiColorStrategy! !

!HiSimpleRenderer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	self useWheelColorStrategy.

	nodeRadio := 3.0.
	nodeBorderWidth := 1.1.
	nodeConnectionOffset := 0.

	linkWidth := 1.3.
	linkDashes := #().
	linkCurveAngle := 45 degreesToRadians.

	arrowSize := linkWidth * 0.75.

	cellWidth := linkWidth * 3! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
cellWidth: aNumber
	cellWidth := aNumber! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
nodeConnectionOffset: aNumber
	"Set the visual offset between a node and its incoming and outcoming links."

	nodeConnectionOffset := aNumber! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
addArrowInto: athensPathBuilder descending: aBoolean

	| c |
	arrowSize isZero ifTrue: [ ^ self ].

	c := aBoolean ifTrue: [ 1 ] ifFalse: [ -1 ].
	athensPathBuilder
		relative;
		lineTo: (-1 * arrowSize) @ (-1 * c * arrowSize);
		lineTo: ( 2 * arrowSize) @ 0;
		lineTo: (-1 * arrowSize) @ (c * arrowSize);
		absolute.! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
athensPathForDescendingLink: aHiLink on: athensCanvas
	"Answer the Athens path for a link that goes from top to bottom."

	^ athensCanvas createPath: [ :athensPathBuilder | 
		| nodeConnectionYOffset fragmentStart |
		nodeConnectionYOffset := self nodeBottomRelativeConnectionPoint.

		"Start of first fragment (that connects at BOTTOM of the origin node)"
		fragmentStart := (self cellCenterFor: aHiLink origin rulerPoint) + nodeConnectionYOffset.
		athensPathBuilder absolute; moveTo: fragmentStart.

		"Add all fragments except last"
		aHiLink intermediatePoints do: [ :rulerPoint |
			| fragmentEnd offset |
			fragmentEnd := self cellCenterFor: rulerPoint.
			offset := fragmentStart x > fragmentEnd x
				ifTrue: [ linkWidth negated ] ifFalse: [ linkWidth ].
			self
				addLinkFragmentFrom: fragmentStart
				to: fragmentEnd
				intermediateY: (self cellOriginFor: rulerPoint) y + offset
				into: athensPathBuilder.
			fragmentStart := fragmentEnd
			].

		"Add last fragment (that connects at TOP of the target node)"
		self
			addLinkFragmentFrom: fragmentStart
			to: (self cellCenterFor: aHiLink target rulerPoint) - nodeConnectionYOffset
			intermediateY: (self cellOriginFor: aHiLink target rulerPoint) y
			into: athensPathBuilder.

		"The arrow (if enabled) is connected to target node"
		self addArrowInto: athensPathBuilder descending: true.
		]! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
linkCurveAngle: anAngleAsRadians
	"Example argument: 45 degreesToRadians"

	linkCurveAngle := anAngleAsRadians! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
linkDashes
	^ linkDashes! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
rowHeight
	^ rowHeight! !

!HiSimpleRenderer methodsFor: 'API' stamp: ''!
newForm
	"Answer a new form, rendered with the current ruler and rowInterval."
	
	| athensSurface |
	athensSurface := AthensCairoSurface extent: self formExtent.
	
	athensSurface drawDuring: [ :athensCanvas |
		athensCanvas pathTransform translateBy: self initialTranslationInAthensCanvas.

		self renderOn: athensCanvas ].

	^ athensSurface asForm! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
nodeBorderWidth
	^ nodeBorderWidth! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
renderOn: athensCanvas
	"Render all nodes and links that correspond to the previously selected rowsInterval in the athensCanvas."
	
	| links nodes |
	nodes := rowsInterval collect: [:row | ruler nodeAtRow: row ].
	links := rowsInterval flatCollect: [:row | ruler linksAtRow: row ] as: Set.

	self renderLinks: links on: athensCanvas.
	self renderNodes: nodes on: athensCanvas.! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
initialTranslationInAthensCanvas
	"Apply left margin + rowsInterval offset."

	^ self cellWidth @ (-1 * (rowsInterval first - 1) * self rowHeight)! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
athensPathForAscendingLink: aHiLink on: athensCanvas
	"Answer the Athens path for a link that goes from bottom to top."

	^ athensCanvas createPath: [ :athensPathBuilder | 
		| nodeConnectionYOffset fragmentStart |
		nodeConnectionYOffset := self nodeBottomRelativeConnectionPoint.

		"Start of first fragment (that connects at BOTTOM of the target node)"
		fragmentStart := (self cellCenterFor: aHiLink target rulerPoint) + nodeConnectionYOffset.
		athensPathBuilder absolute; moveTo: fragmentStart.

		"The arrow (if enabled) is connected to target node"
		self addArrowInto: athensPathBuilder descending: false.

		"Add all fragments except last (in reversed order)"
		aHiLink intermediatePoints reverseDo: [ :rulerPoint | 
			| fragmentEnd offset |
			fragmentEnd := self cellCenterFor: rulerPoint.
			offset := fragmentStart x > fragmentEnd x
				ifTrue: [ linkWidth negated ] ifFalse: [ linkWidth ].
			self
				addLinkFragmentFrom: fragmentStart
				to: fragmentEnd
				intermediateY: (self cellOriginFor: rulerPoint) y + offset
				into: athensPathBuilder.
			fragmentStart := fragmentEnd
			].

		"Add last fragment (that connects at TOP of the origin node)"
		self
			addLinkFragmentFrom: fragmentStart
			to: (self cellCenterFor: aHiLink origin rulerPoint) - nodeConnectionYOffset
			intermediateY: (self cellOriginFor: aHiLink origin rulerPoint) y
			into: athensPathBuilder.
		]! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
renderNodes: nodes on: athensCanvas

	| nodeAthensPath |

	"Create the Athens path that is common to all nodes."
	nodeAthensPath := self athensPathForNodeOn: athensCanvas.

	athensCanvas paintMode restoreAfter: [
		nodes do: [ :each |
		
			"Set the stroke for this node."
			(athensCanvas setStrokePaint: (colorStrategy colorForNode: each)) width: nodeBorderWidth.

			"Draw it"
			athensCanvas pathTransform restoreAfter: [
				athensCanvas pathTransform
					translateBy: (self cellCenterFor: each rulerPoint).
				athensCanvas drawShape: nodeAthensPath ] ] ].! !

!HiSimpleRenderer methodsFor: 'rendering' stamp: ''!
addLinkFragmentFrom: topPoint to: bottomPoint intermediateY: intermediateY into: athensPathBuilder
	"Add a curve between two points in a canvas, that pass via an intermediate Y."

	topPoint x = bottomPoint x
		ifTrue: [ ^ athensPathBuilder lineTo: bottomPoint ].

	topPoint x < bottomPoint x
		ifTrue: [
			self
				addLinkFragmentFromTopLeft: topPoint
				toBottomRight: bottomPoint
				intermediateY: intermediateY
				into: athensPathBuilder ]
		ifFalse: [
			self
				addLinkFragmentFromTopRight: topPoint
				toBottomLeft: bottomPoint
				intermediateY: intermediateY
				into: athensPathBuilder ]! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
nodeConnectionOffset
	^ nodeConnectionOffset! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
useWheelColorStrategy
	colorStrategy := HiWheelColorStrategy new.
	colorStrategy ruler: ruler.! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
nodeRadius
	^ nodeRadio! !

!HiSimpleRenderer methodsFor: 'accessing' stamp: ''!
cellWidth
	^ cellWidth! !

!HiSpecExample commentStamp: ''!
I am an example of use of Hiedra in the Spec library (with Morph as backend).!
!HiSpecExample methodsFor: 'initialization' stamp: ''!
initializeTable
	table := self newTable.

	"Configure hiedra controller"
	hiedraColumnController := HiColumnController new.

	hiedraColumnController renderer
		linkWidth: 3.5;
		nodeRadius: 1.5;
		nodeBorderWidth: 3.0;
		arrowSize: 0;
		nodeConnectionOffset: 3;
		cellWidth: 8;
		useUniformColorStrategy.

	"Adjust the ruler rendering settings with table's row height."
	hiedraColumnController renderer rowHeight: FTTableMorph defaultRowHeight floor.

	"Configure columns"
	table
		addColumn: (SpImageTableColumn evaluated: [ :item |
			hiedraColumnController cellMorphAtValue: item ]);
		addColumn: (SpStringTableColumn evaluated: [ :item |
			item comment ])! !

!HiSpecExample methodsFor: 'accessing' stamp: ''!
commits: commits 

	table items: commits.

	hiedraColumnController ruler: (HiRulerBuilder 
		newRulerValues: commits
		linksBlock: [:aCommit |
			aCommit parentIds collect: [:id | 
				commits detect: [:each | each id = id ] ] ]).

	hiedraColumnController reset.
	
	"After #reset, we know the desired width for the column."
	table columns first width: hiedraColumnController rulerWidth.! !

!HiSpecExample methodsFor: 'windows' stamp: ''!
close
	
	self window close! !

!HiSpecExample methodsFor: 'initialization' stamp: ''!
initializeActionBar

	| refreshButton inspectButton |
	refreshButton := self newButton
		label: 'Redraw';
		help: 'Refresh the table (and redraw all Hiedra cells with current rendering parameters).';
		action: [ UIManager default defer: [ self forceRefreshHiedra ] ];
		yourself.
	inspectButton := self newButton
		label: 'Renderer'; 
		help: ('Inspect the Hiedra renderer, that has the rendering parameters. Press on {1} button to see the effect of any change on the renderer.' format: { refreshButton label });
		action: [ UIManager default defer: [ hiedraColumnController renderer inspect ] ];
		yourself.

	actionBar := self newActionBar
		add: inspectButton;
		add: refreshButton;
		yourself.! !

!HiSpecExample methodsFor: 'initialization' stamp: ''!
initializePresenters
	self initializeTable.
	self initializeActionBar.! !

!HiSpecExample methodsFor: 'initialization' stamp: ''!
forceRefreshHiedra
	hiedraColumnController reset.
	table withAdapterDo: #refreshList.! !

!HiSpecExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #table;
		add: #actionBar withConstraints: [ :constraints | constraints height: self toolbarHeight ];
		yourself! !

!HiSpecExample class methodsFor: 'specs' stamp: ''!
openExample: selector

	| commits |
	commits := HiExampleCommit perform: selector.

	^ self new
		commits: commits;
		openWithSpec;
		withWindowDo: [ :window |
			window
				extent: 600 @ 800;
				title: ('Hiedra in Spec2 with Roassal3 - {1} - {2} elements' format: {selector. commits size}) ];
		yourself.! !

!HiSpecExample class methodsFor: 'specs' stamp: ''!
example60RandomCommits
	^ self openExample: #randomlyGenerated! !

!HiSpecExampleTest class methodsFor: 'tests' stamp: ''!
classWithExamplesToTest
	^ HiSpecExample! !

!HiUniformColorStrategy commentStamp: ''!
I map all nodes to a color and all links to another color (by default the same color).!
!HiUniformColorStrategy methodsFor: 'accessing' stamp: ''!
nodeColor: anObject
	^ nodeColor := anObject! !

!HiUniformColorStrategy methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	linkColor := nodeColor := Smalltalk ui theme caretColor! !

!HiUniformColorStrategy methodsFor: 'accessing' stamp: ''!
linkColor
	^ linkColor! !

!HiUniformColorStrategy methodsFor: 'accessing' stamp: ''!
linkColor: anObject
	linkColor := anObject! !

!HiUniformColorStrategy methodsFor: 'accessing' stamp: ''!
ruler: aHiRuler
	"Nothing to do"! !

!HiUniformColorStrategy methodsFor: 'accessing' stamp: ''!
colorForNode: aHiNode
	^ nodeColor! !

!HiUniformColorStrategy methodsFor: 'accessing' stamp: ''!
colorForLink: aHiLink
	^ linkColor! !

!HiUniformColorStrategy methodsFor: 'accessing' stamp: ''!
nodeColor
	^ nodeColor! !

!HiWheelColorStrategy commentStamp: ''!
I map nodes and links of a ruler to colors depending on the branches. Check HiBranchMapping to see how to decide what's the branch of a node or link.!
!HiWheelColorStrategy methodsFor: 'private' stamp: ''!
newColorGenerator
	^ Generator
		on: [ :generator | 
			| nextIndex |
			nextIndex := 1.
			[ generator yield: (self colorWheel at: nextIndex).
			nextIndex := (nextIndex + 1) \\ self colorWheel size + 1 ] repeat ]! !

!HiWheelColorStrategy methodsFor: 'accessing' stamp: ''!
colorWheel
	^ colorWheel ifNil: [ colorWheel := self defaultColorWheel ]! !

!HiWheelColorStrategy methodsFor: 'private' stamp: ''!
branchMapping
	^ branchMapping! !

!HiWheelColorStrategy methodsFor: 'accessing' stamp: ''!
defaultColorWheelSize
	^ 10! !

!HiWheelColorStrategy methodsFor: 'accessing' stamp: ''!
ruler: aHiRuler
	aHiRuler ifNil: [ ^self ].
	
	branchMapping := HiBranchMapping builtFor: aHiRuler.

	colorByBranch := Array streamContents: [ :stream |
		| colorGenerator |
		colorGenerator := self newColorGenerator.
		branchMapping branchCount timesRepeat: [
			stream nextPut: colorGenerator next ] ]! !

!HiWheelColorStrategy methodsFor: 'accessing' stamp: ''!
colorForNode: aHiNode
	^ colorByBranch at: (branchMapping branchAtNode: aHiNode)! !

!HiWheelColorStrategy methodsFor: 'accessing' stamp: ''!
colorForLink: aHiLink
	^ colorByBranch at: (branchMapping branchAtLink: aHiLink)! !

!HiWheelColorStrategy methodsFor: 'accessing' stamp: ''!
defaultColorWheel
	| referenceColor |
	referenceColor := Smalltalk ui theme textColor.

	"Little workaround: The wheel is being reversed to avoid having red at first (it's a color associated with danger)"
	^ (Color wheel: self defaultColorWheelSize saturation: 0.95 brightness: 0.95)
		reversed
		collect: [ :each | each mixed: 0.75 with: referenceColor ]! !

!HiWheelColorStrategy methodsFor: 'accessing' stamp: ''!
colorWheel: aCollectionOfColors
	colorWheel := aCollectionOfColors! !

!HistoryIterator commentStamp: ''!
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:		<Integer>
	maxSize:		<Integer>
	plugged:		<Boolean>
	recorder:		<UndoRedoGroup>

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: 'removing' stamp: ''!
removeFirst
	self recorder removeFirst! !

!HistoryIterator methodsFor: 'adding' stamp: ''!
addItem: anHistoryItem
	| result |
	self isPlugged ifFalse: [^ false].
	self recorder removeLast: (self size - self index).
	result := self recorder addItem: anHistoryItem.
	self updateIndex.
	^ result! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
current
	^ (self index <= self size and: [self index > 0])
		ifTrue: [self recorder at: self index]! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
nextList
	"return 'next' items sublist "
	^ self recorder copyFrom: self index + 1 to: self size! !

!HistoryIterator methodsFor: 'removing' stamp: ''!
removeAt: anIndex
	self recorder removeAt: anIndex! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
recorder
	^ recorder ifNil: [recorder := UndoRedoGroup new]! !

!HistoryIterator methodsFor: 'testing' stamp: ''!
hasPrevious
	"is there an item before current index"
	^ self index > 0! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
previousList
	"return 'prev' items sublist"
	^ self recorder copyFrom: 1 to: self index - 1! !

!HistoryIterator methodsFor: 'grouping' stamp: ''!
openGroup
	self recorder openGroup.
	self updateIndex.
! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
at: anInteger
	^ self recorder at: anInteger! !

!HistoryIterator methodsFor: 'undo - undo' stamp: ''!
redo: doMessageSend undo: undoMessageSend
	self addItem: (UndoRedoRecord redo: doMessageSend undo: undoMessageSend)! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
first
	^ self recorder first! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
last
	^ self recorder last! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
maxSize
	^ maxSize ifNil: [maxSize := self defaultMaximumSize]! !

!HistoryIterator methodsFor: 'initialization' stamp: ''!
reset
	self recorder reset.
	index := nil.! !

!HistoryIterator methodsFor: 'undo - undo' stamp: ''!
doAndAddRecord: anUndoRedoRecord
	| result |
	result := anUndoRedoRecord do.
	self addItem: anUndoRedoRecord.
	^ result! !

!HistoryIterator methodsFor: 'testing' stamp: ''!
isPlugged
	^ plugged ifNil: [plugged := true]! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
index
	^ index ifNil: [index := self size]! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
maxSize: anInteger
	maxSize := anInteger! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
defaultMaximumSize
	"unlimited by default"
	^ 999999999! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
previous
	"previous item in history"
	^ self hasPrevious
		ifTrue: [index := self index - 1.
			self current]! !

!HistoryIterator methodsFor: 'testing' stamp: ''!
hasNext
	"is there an item after current index"
	^ self recorder size - self index > 0! !

!HistoryIterator methodsFor: 'compatibility' stamp: ''!
closeRecordGroup
	^ self closeGroup! !

!HistoryIterator methodsFor: 'grouping' stamp: ''!
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: 'accessing' stamp: ''!
next
	"next item in history"
	^ self hasNext
		ifTrue: [ index := self index + 1.
			self current]! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
at: anInteger put: anItem
	self recorder at: anInteger put: anItem! !

!HistoryIterator methodsFor: 'compatibility' stamp: ''!
openRecordGroup
	^ self openGroup! !

!HistoryIterator methodsFor: 'grouping' stamp: ''!
closeGroup
	self recorder closeGroup
! !

!HistoryIterator methodsFor: 'undo - undo' stamp: ''!
redoArray: doArray undoArray: undoArray
	self addItem: (UndoRedoRecord redoArray: doArray undoArray: undoArray)! !

!HistoryIterator methodsFor: 'undo - undo' stamp: ''!
do
	^ self redo! !

!HistoryIterator methodsFor: 'undo - undo' stamp: ''!
undo
	self unplugWhile: [
		self current ifNotNil: [:curr | curr undo].
		self previous].
	^ true! !

!HistoryIterator methodsFor: 'accessing' stamp: ''!
size
	^ self recorder size! !

!HistoryIterator methodsFor: 'adding' stamp: ''!
addRecord: anItem
	^ self addItem: anItem
! !

!HistoryIterator methodsFor: 'adding' stamp: ''!
updateIndex
	self size <= self maxSize
		ifFalse: [self removeFirst].
	index := self size.
! !

!HistoryIterator methodsFor: 'undo - undo' stamp: ''!
redo
	self unplugWhile: [
		self hasNext ifFalse: [^false].
		self next redo].
	^ true! !

!HistoryIterator methodsFor: 'undo - undo' stamp: ''!
unplugWhile: aBlock
	| wasPlugged |
	wasPlugged := self isPlugged.
	plugged := false.
	aBlock ensure: [ plugged := wasPlugged ]! !

!HistoryIteratorTest commentStamp: ''!
SUnit tests for HistoryIterator!
!HistoryIteratorTest methodsFor: 'testing' stamp: ''!
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 equals: 0! !

!HistoryIteratorTest methodsFor: 'testing' stamp: ''!
testGrouping
	| aCollection |
	aCollection := OrderedCollection new.

	historyList openGroup.
	self assert: historyList size equals: 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 equals: 1.
	self assert: (historyList at: 1) size equals: 2.
	historyList closeGroup.
	self assert: (historyList at: 1) closed.
	self assert: aCollection size equals: 2.
	self assert: aCollection first equals: 1.
	self assert: aCollection last equals: 2.
	historyList undo.
	self assertEmpty: aCollection! !

!HistoryIteratorTest methodsFor: 'testing' stamp: ''!
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: ''!
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: ''!
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 equals: 5! !

!HistoryIteratorTest methodsFor: 'testing' stamp: ''!
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 equals: 3.	
	self assert: aCollection last equals: 3! !

!HistoryIteratorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	historyList := HistoryIterator new.! !

!HistoryLeaf commentStamp: ''!
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: ''!
addItem: anHistoryItem 
	^ false! !

!HistoryLeaf methodsFor: 'testing' stamp: ''!
opened
	^ false! !

!HistoryLeaf methodsFor: 'testing' stamp: ''!
isComposite
	^ false! !

!HistoryNode commentStamp: ''!
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:		<OrderedCollection>
	opened:		<Boolean>

history
	- The list of subnodes (HistoryLeaf or HistoryNode instances)

opened
	- true if the node is opened for adding
!
!HistoryNode methodsFor: 'testing' stamp: ''!
isEmpty
	^ self history isEmpty! !

!HistoryNode methodsFor: 'private' stamp: ''!
removeFirst
	self history removeFirst! !

!HistoryNode methodsFor: 'adding' stamp: ''!
addItem: anHistoryItem 
	self current notNil
		ifTrue: [(self current addItem: anHistoryItem)
				ifTrue: [^ true]].
	self opened
		ifTrue: [self history add: anHistoryItem.
			^ true].
	^ false! !

!HistoryNode methodsFor: 'accessing' stamp: ''!
current
	^ self history isEmpty
		ifFalse: [self history last] ! !

!HistoryNode methodsFor: 'removing' stamp: ''!
removeAt: anIndex
	self history removeAt: anIndex! !

!HistoryNode methodsFor: 'opening-closing' stamp: ''!
open
	opened := true! !

!HistoryNode methodsFor: 'accessing' stamp: ''!
at: aPosition put: anItem
	self history at: aPosition put: anItem! !

!HistoryNode methodsFor: 'opening-closing' stamp: ''!
closeGroup
	(self current notNil
			and: [self current isComposite
				and: [self current opened]])
		ifTrue: [self current closeGroup]
		ifFalse: [self close]! !

!HistoryNode methodsFor: 'testing' stamp: ''!
closed
	^ self opened not! !

!HistoryNode methodsFor: 'testing' stamp: ''!
opened
	^ opened ifNil: [opened := true]! !

!HistoryNode methodsFor: 'opening-closing' stamp: ''!
openGroup
	^ self addItem: self groupClass new! !

!HistoryNode methodsFor: 'accessing' stamp: ''!
size
	^ self history size! !

!HistoryNode methodsFor: 'accessing' stamp: ''!
history
	^ history ifNil: [history := OrderedCollection new] ! !

!HistoryNode methodsFor: 'accessing' stamp: ''!
at: aPosition
	^ self history at: aPosition! !

!HistoryNode methodsFor: 'copying' stamp: ''!
copyFrom: start to: stop
	^ self history copyFrom: start to: stop! !

!HistoryNode methodsFor: 'accessing' stamp: ''!
groupClass
	^ self class! !

!HistoryNode methodsFor: 'accessing' stamp: ''!
first
	^ self history first! !

!HistoryNode methodsFor: 'accessing' stamp: ''!
last
	^ self history last! !

!HistoryNode methodsFor: 'opening-closing' stamp: ''!
close
	opened := false! !

!HistoryNode methodsFor: 'testing' stamp: ''!
isComposite
	^ true! !

!HistoryNode methodsFor: 'initialization' stamp: ''!
reset
	history := nil.
	opened := true! !

!HistoryNode methodsFor: 'removing' stamp: ''!
removeLast: count
	self history removeLast: count! !

!HistoryNode methodsFor: 'removing' stamp: ''!
removeLast
	self history removeLast! !

!HistoryNodeTest commentStamp: ''!
SUnit tests for HistoryNode!
!HistoryNodeTest methodsFor: 'tests' stamp: ''!
testReset
	| h i |
	h := HistoryNode new.
	h addItem: (i := HistoryLeaf new).
	self assert: h current equals: i.
	self assert: h size equals: 1.
	h reset.
	self assert: h size equals: 0! !

!HistoryNodeTest methodsFor: 'tests' stamp: ''!
testOneGroup
	| h i c i2 i3 i4 |
	h := HistoryNode new.
	h addItem: (i := HistoryLeaf new).
	self assert: h size equals: 1.
	self assert: (h at: 1) equals: i.
	h openGroup.
	self assert: h size equals: 2.
	self assert: (h at: 1) equals: i.
	self assert: (c := h at: 2) isComposite.
	self assertEmpty: c.
	h addItem: (i2 := HistoryLeaf new).
	self assert: h size equals: 2.
	self assert: c size equals: 1.
	self assert: c current equals: i2.
	h closeGroup.
	h addItem: (i3 := HistoryLeaf new).
	self assert: h size equals: 3.
	self assert: (h at: 3) equals: i3.
	h closeGroup.
	h addItem: (i4 := HistoryLeaf new).
	self assert: h size equals: 3! !

!HistoryNodeTest methodsFor: 'tests' stamp: ''!
testGroup
	| h i |
	h := HistoryNode new.
	h addItem: (i := HistoryLeaf new).
	self assert: h size equals: 1.
	self assert: (h at: 1) equals: i.
	h openGroup.
	self assert: h size equals: 2.
	self assert: (h at: 1) equals: i.
	self assert: (h at: 2) isComposite! !

!HistoryNodeTest methodsFor: 'tests' stamp: ''!
testClose
	| h i |
	h := HistoryNode new.
	h close.
	h addItem: (i := HistoryLeaf new).
	h open.
 	h addItem: i.
	self assert: h current equals: i! !

!HistoryNodeTest methodsFor: 'tests' stamp: ''!
testOneItem
	| h i |
	h := HistoryNode new.
	h addItem: (i := HistoryLeaf new).
	self assert: h size equals: 1.
	self assert: h current equals: i! !

!HistoryNodeTest methodsFor: 'tests' stamp: ''!
testTwoConsecutiveCloseGroup
	| h i grp1 grp2 i3 | 
	h := HistoryNode new.
	h addItem: (i := HistoryLeaf new).
	self assert: h size equals: 1.
	self assert: (h at: 1) equals: i.
	h openGroup.
	self assert: h size equals: 2.
	grp1 := h at: 2.
	h openGroup.
	self assert: h size equals: 2.
	self assert: grp1 size equals: 1.
	grp2 := grp1 at: 1.
	self assert: grp2 size equals: 0.
	h closeGroup.
	h closeGroup.
	h addItem: (i3 := HistoryLeaf new).
	self assert: h size equals: 3.
	self assert: h current equals: i3.
	

	
	
! !

!HistoryNodeTest methodsFor: 'tests' stamp: ''!
testTwoGroups
	| h i grp1 grp2  i2 i3 | 
	h := HistoryNode new.
	h addItem: (i := HistoryLeaf new).
	self assert: h size equals: 1.
	self assert: (h at: 1) equals: i.
	h openGroup.
	self assert: h size equals: 2.
	grp1 := h at: 2.
	h openGroup.
	self assert: h size equals: 2.
	self assert: grp1 size equals: 1.
	grp2 := grp1 at: 1.
	self assert: grp2 size equals: 0.
	h addItem: (i2 := HistoryLeaf new).
	self assert: grp2 size equals: 1.
	h closeGroup.
	h addItem: (i2 := HistoryLeaf new).
	self assert: grp2 size equals: 1.
	self assert: grp1 size equals: 2.
	self assert: grp1 current equals: i2.
	h closeGroup.
	h addItem: (i3 := HistoryLeaf new).
	self assert: grp2 size equals: 1.
	self assert: grp1 size equals: 2.
	self assert: h size equals: 3.
	self assert: h current equals: i3! !

!HistoryNodeTest methodsFor: 'tests' stamp: ''!
testEmptyHistory
	| h |
	h := HistoryNode new.
	self assert: h size equals: 0.
	self assert: h current isNil! !

!HistorySlot commentStamp: ''!
This is the History slot. It saves (by default 5) older values. 
The complete history can be read with #readHistory:!
!HistorySlot methodsFor: 'initialization' stamp: ''!
initialize
	size := 5
! !

!HistorySlot methodsFor: 'meta-object-protocol' stamp: ''!
rawRead: anObject
	"return the wrapper (the collection) used to store the value"
	^super read: anObject! !

!HistorySlot methodsFor: 'meta-object-protocol' stamp: ''!
wantsInitialization

    ^ true! !

!HistorySlot methodsFor: 'meta-object-protocol' stamp: ''!
readHistory: anObject
	"return the complete history"
	^ self rawRead: anObject! !

!HistorySlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	"we return the last value from the collection"
	^ (self rawRead: anObject) last! !

!HistorySlot methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		store: self name;
		nextPutAll: ' => ';
		nextPutAll: self class name;
		nextPutAll: ' size: ';
		store: size! !

!HistorySlot methodsFor: 'accessing' stamp: ''!
size
	^ size! !

!HistorySlot methodsFor: 'accessing' stamp: ''!
size: anObject
	size := anObject! !

!HistorySlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aDictionary to: anObject
	| history |
	history := self rawRead: anObject.
	history size >= size
		ifTrue: [ history removeFirst ].
	^ history addLast: aDictionary! !

!HistorySlot methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	"for speed, we inline the #last send instead of calling the #read: method"
	aMethodBuilder pushInstVar: index.
	aMethodBuilder send: #last! !

!HistorySlot methodsFor: 'initialization' stamp: ''!
initialize: anObject
	super write: (OrderedCollection with: nil) to: anObject
! !

!HistorySlotTest methodsFor: 'tests' stamp: ''!
testAddOneElement
	| slot instance |
	slot := #slot1 => HistorySlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	self compileAccessorsFor: slot.

	instance := aClass new.
	instance slot1: 25.
	self assert: instance slot1 equals: 25! !

!HistorySlotTest methodsFor: 'tests' stamp: ''!
testModifyIvarToHistory
	"test if we can transform a standard ivar to a history slot when instances are present"

	| slot instance |
	slot := #slot1 =>InstanceVariableSlot .
	aClass := self make: [ :builder | builder slots: {slot} ].

	self compileAccessorsFor: slot.

	instance := aClass new.
	instance slot1: 25.
	slot := #slot1 =>HistorySlot.
	aClass := self make: [ :builder | builder slots: {slot} ].
	
	self assert: instance slot1 equals: 25.
	self assert: (slot readHistory: instance) asArray equals: #(nil 25)! !

!HistorySlotTest methodsFor: 'tests' stamp: ''!
testIsFirstElementNil

	| slot instance |
	slot := #slot1 => HistorySlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	self compileAccessorsFor: slot.

	instance := aClass new.

  	self assert: (instance slot1) equals: nil! !

!HistorySlotTest methodsFor: 'tests' stamp: ''!
testAddOneElementAndModifyClass
	| slot instance |
	slot := #slot1 => HistorySlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	self compileAccessorsFor: slot.

	instance := aClass new.
	instance slot1: 25.
	
	aClass addInstVarNamed: 'x'.
	self assert: instance slot1 equals: 25! !

!HistorySlotTest methodsFor: 'tests' stamp: ''!
testAddTwoElementsHistoryRead
	| slot instance |
	slot := #slot1 => HistorySlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	self compileAccessorsFor: slot.

	instance := aClass new.
	instance slot1: 25.
	instance slot1: 35.
	self assert: instance slot1 equals: 35.
	self assert: (slot readHistory: instance) asArray equals: #(nil 25 35)! !

!HistorySlotTest methodsFor: 'tests' stamp: ''!
testAddTwoElements
	| slot instance |
	slot := #slot1 => HistorySlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	self compileAccessorsFor: slot.

	instance := aClass new.
	instance slot1: 25.
	instance slot1: 35.
	self assert: instance slot1 equals: 35! !

!HistorySlotTest methodsFor: 'tests' stamp: ''!
testHistoryGreaterThanThree
	| slot instance |
	slot := #slot1 => HistorySlot size: 3.
	aClass := self make: [ :builder | builder slots: {slot} ].

	self compileAccessorsFor: slot.

	instance := aClass new.
	instance slot1: 25.
	instance slot1: 35.
	instance slot1: 35.
	instance slot1: 35.
	instance slot1: 35.
	instance slot1: 35.
	self assert: (slot readHistory: instance) size equals: 3! !

!HookGenerator commentStamp: ''!
New version

-> takes all links and one node
-> returns the complete AST for the hook.!
!HookGenerator methodsFor: 'accessing' stamp: ''!
links
	^links! !

!HookGenerator methodsFor: 'ast manipulation' stamp: ''!
wrapCondition: hook link: aLink
	| linkBlock conditionExpression condSelector condArguments linkConditionArguments|
	
	condSelector := aLink condition valueSelector.
	linkConditionArguments  := aLink conditionArguments.
	condArguments := #().
	
	(condSelector numArgs > 0) ifTrue: [
			condArguments := OrderedCollection new.
			1 to: condSelector numArgs do: [:i |
				condArguments add: (self genReification: (linkConditionArguments at: i) for: aLink)]
	].
	
	linkBlock := self encloseInBlock: hook asSequenceNode.
	conditionExpression := RBMessageNode 
			receiver: ((self hasOption: #optionInlineCondition for: aLink)  
				ifTrue: [RBLiteralNode value: aLink condition]
				ifFalse:[RBMessageNode receiver: (RBLiteralNode value: aLink)
											 selector: #condition ])
			selector: condSelector
			arguments: condArguments.
	^RFMessageNode
				receiver: conditionExpression
				selector: #ifTrue:
				arguments: {linkBlock}! !

!HookGenerator methodsFor: 'accessing' stamp: ''!
plugins
	^ plugins! !

!HookGenerator methodsFor: 'results' stamp: ''!
insteadHooks
	| insteadLinks |
	insteadLinks := ((links select: [ :each | each control = #instead ])) asArray.
	insteadLinks isEmpty ifTrue: [ ^#()].
	^(self hookFor: insteadLinks last) parent: node ! !

!HookGenerator methodsFor: 'private' stamp: ''!
genReification: aSymbolOrNode for: aLink
	| plugin | 
	(aSymbolOrNode isKindOf: RBProgramNode) ifTrue: [ ^ aSymbolOrNode].
	plugin := aSymbolOrNode isSymbol 
		ifTrue: [(plugins at: aSymbolOrNode ifAbsent: [self error: 'reification not supported for this entity']) entity: entity link: aLink]
		ifFalse: [ aSymbolOrNode link: aLink; entity: entity. aSymbolOrNode ].
	^plugin perform: self selectorForNode! !

!HookGenerator methodsFor: 'ast manipulation' stamp: ''!
encloseInBlock: nodeOrCollection
	"Creates a new block node from a node or a list of nodes"
	^ RBBlockNode body: nodeOrCollection asSequenceNode! !

!HookGenerator methodsFor: 'results' stamp: ''!
postamble
	| postamble |
	"This is code executed just before the #after link"
	
	postamble := OrderedCollection new.
	links do: [:link |  
		plugins do: [ :plugin | (link allReifications includes: plugin key) ifTrue: [postamble addAll: ((plugin entity: entity link: link) postamble: entity)]]].
		
	^postamble! !

!HookGenerator methodsFor: 'results' stamp: ''!
preamble
	| preamble |
	"Very simplistic now: needs to do some optimizatons"
	
	preamble := OrderedCollection new.
	links do: [:link |  
		plugins do: [ :plugin | (link allReifications includes: plugin key) ifTrue: [preamble addAll: ((plugin entity: entity link: link) preamble: entity)]].
		link control = #instead ifTrue: [
				"for instead links, the preamble needs to clean the stack. For now just implemented for message sends"
				((entity isKindOf: RBProgramNode) and: [node isMessage]) ifTrue: [
					entity numArgs + 1 timesRepeat: [preamble add: (RFStorePopIntoTempNode named: #RFBalancestack)]]]].
	^preamble! !

!HookGenerator methodsFor: 'options' stamp: ''!
hasOption: aSymbol for: aLink
	"take the class and method overrides to options into account"
	^(node methodNode optionsFor: aLink) includes: aSymbol.! !

!HookGenerator methodsFor: 'results' stamp: ''!
beforeHooks
	^links 
			select: [ :each | each control = #before ] 
			thenCollect:  [ :link | (self hookFor: link) parent: node] ! !

!HookGenerator methodsFor: 'ast manipulation' stamp: ''!
selectorForNode
	"The selector to be called on the Reification plugin"
	^('genFor' , entity class name) asSymbol.! !

!HookGenerator methodsFor: 'results' stamp: ''!
afterHooks
	^ links 
			select: [ :each | each control = #after ] 
			thenCollect:  [ :link | (self hookFor: link) parent: node].! !

!HookGenerator methodsFor: 'ast manipulation' stamp: ''!
wrapInContext: hook link: aLink
	^RFMessageNode 
		receiver: (RBLiteralNode value: aLink)
		selector: #valueInContext:
		arguments: {self encloseInBlock: hook}! !

!HookGenerator methodsFor: 'initialize' stamp: ''!
entity: anEntity node: aNode links: aCollection
	plugins := Dictionary new.
	node := aNode.
	entity := anEntity.
	links := aCollection.
	
	"register all the plugins that can reify information for this node"
	RFReification subclasses do: [:plugin |
		(plugin entities anySatisfy: [:class | entity isKindOf: class])	 ifTrue: [
			plugins at: plugin key put: plugin]
		].
! !

!HookGenerator methodsFor: 'results' stamp: ''!
hook
	^RBSequenceNode statements: (links collect:  [ :link | self hookFor: link ]). ! !

!HookGenerator methodsFor: 'private' stamp: ''!
generateArguments: aMetalink
	| arguments |
	
	arguments := aMetalink arguments collect: [: each | self genReification: each for: aMetalink].
	(self hasOption: #argsAsArray for: aMetalink) ifTrue: 
		[ ^RBArrayNode statements: arguments ].
	^arguments! !

!HookGenerator methodsFor: 'private' stamp: ''!
hookFor: aLink
	| receiver hook arguments |
	
	(self hasOption: #optionDisabledLink for: aLink) ifTrue: [ ^RBSequenceNode new ].
	
	receiver := aLink metaObject isSymbol 
		ifTrue: [ self genReification: aLink metaObject for: aLink ]
		ifFalse: [  
			(self hasOption: #optionInlineMetaObject for: aLink)
				ifTrue: [RBLiteralNode value: aLink metaObject]
				ifFalse: [RBMessageNode receiver: (RBLiteralNode value: aLink)
											 selector: #metaObject ]].
	arguments := self generateArguments: aLink.
	
	hook := RFMessageNode 
		receiver: receiver
		selector: aLink selector 
		arguments: arguments.
	
	(self hasOption: #optionOneShot for: aLink) ifTrue: [			
			hook := RBSequenceNode statements: {
				RBMessageNode
					receiver: (RBLiteralNode value: aLink)
					selector: #uninstall.
				hook }].
	aLink hasCondition ifTrue: [hook := self wrapCondition: hook link: aLink].
	(aLink hasMetaLevel or: [self hasOption: #optionMetalevel for: aLink]) ifTrue: [hook := self wrapInContext: hook link: aLink].		
	
	hook propertyAt: #hook put: true.
			
	^ hook! !

!HookGenerator class methodsFor: 'instance creation' stamp: ''!
node: aNode
	^self entity: aNode node: aNode! !

!HookGenerator class methodsFor: 'instance creation' stamp: ''!
entity: anEntity node: aNode
	^self new entity: anEntity node: aNode links: anEntity links ! !

!HookGeneratorForVariables commentStamp: ''!
I am a version of the HookGenerator that is used when generating hooks for  first class variables like Globals, ClassVariables, Slots and TemporaryVariables !
!HowToContributeHelp commentStamp: ''!
A help topic on how to contribute!
!HowToContributeHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#(introduction)! !

!HowToContributeHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^'Contribute to base code'! !

!HowToContributeHelp class methodsFor: 'pages' stamp: ''!
introduction
	"This method was automatically generated."
	<script: 'self edit: #introduction'>
	^HelpTopic
		title: 'Introduction'
		contents: 
'This help summarizes the process to contribute to the Pharo base code. Proposing a bug fix or enhancement is easy and relatively well documented. 
The following website contains a clear description of the change:
	http://pharo.org/contribute-propose-fix 
 !!' readStream nextChunkText! !

!HowToMakeYourOwnTutorial commentStamp: ''!
I'm a Pharo tutorial which teach to create a Pharo tutorial. Open me with

ProfStef goOn: HowToMakeYourOwnTutorial.!
!HowToMakeYourOwnTutorial methodsFor: 'lessons' stamp: ''!
createLessonFactoryMethods
	^ Lesson 
title: 'Lesson factory methods'
lesson: 
'"Next, create category ''lessons'' and add a method per lesson.

Each method must return a Lesson object.

Your can use Lesson class>>title:lesson: to create Lesson object."

HowToDebug compile:
''useSelfHalt
	^ Lesson
title: ''''self halt''''
lesson: 
''''"Put self halt. in the method you want to debug."

ProfStef next.''''''
classified: ''lessons''.

HowToDebug compile:
''examineStackTrace
	^ Lesson
title: ''''self halt''''
lesson: 
''''"Look at PharoDebug.log."

ProfStef next.''''''
classified: ''lessons''.

HowToDebug compile:
''changeReturnValue
	^ Lesson
title: ''''Change return value''''
lesson: 
''''"Easy in the debugger !!"''''''
classified: ''lessons''.

ProfStef next.'.! !

!HowToMakeYourOwnTutorial methodsFor: 'tutorial' stamp: ''!
tutorial 
	^ #(
		subclassAbstractTutorial
		createLessonFactoryMethods
		implementTutorial
		runYourTutorial
		)! !

!HowToMakeYourOwnTutorial methodsFor: 'lessons' stamp: ''!
subclassAbstractTutorial
	^ Lesson 
title: 'AbstractTutorial'
lesson: 
'"Here are the steps to create your own Pharo tutorial. 

First, create a subclass of AbstractTutorial. For example:"

AbstractTutorial subclass: #HowToDebug
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''YourTutorial''.
	
ProfStef next.'! !

!HowToMakeYourOwnTutorial methodsFor: 'lessons' stamp: ''!
implementTutorial
	^ Lesson 
title: 'Implement tutorial method'
lesson: 
'"Finally implement the tutorial method to return an Array of your lesson factory methods:"

HowToDebug compile:
''tutorial
	^ #(
#useSelfHalt
#examineStackTrace
#changeReturnValue
)''
classified: ''tutorial''.


ProfStef next.'.! !

!HowToMakeYourOwnTutorial methodsFor: 'lessons' stamp: ''!
runYourTutorial
	^ Lesson 
title: 'Run your tutorial'
lesson: 
'"You can run your fresh new tutorial like this:" 

ProfStef goOn: HowToDebug.'.! !

!HowToMakeYourOwnTutorialTest commentStamp: ''!
Tests for HowToMakeYourOwnTutorial!
!HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: ''!
testEachSelectorReturnsALesson
	| answer |
	self testedTutorial tutorial do: [:aSelector|
		answer := (self testedTutorial perform: aSelector).
		self assert: (answer isKindOf: Lesson).
	]! !

!HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: ''!
testNotEmpty
	self assert: self testedTutorial tutorial notEmpty.! !

!HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: ''!
testSizeReturnsNumberOfSelectors
	self assert: (self testedTutorial tutorial size) equals: self testedTutorial size.! !

!HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: ''!
testedTutorial
	"Returns an instance of an AbstractTutorial subclass"
	^ HowToMakeYourOwnTutorial new! !

!HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: ''!
testEachSelectorExists
	self testedTutorial tutorial do: [:aSelector|
		self assert: (self testedTutorial respondsTo: aSelector) 
	]! !

!HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: ''!
testLessonAtReturnsCorrespondingLesson
	| answer |
	1 to: (self testedTutorial tutorial size) do: [:index|
		answer := self testedTutorial lessonAt: index.
		self assert: (answer isKindOf: Lesson)
	]! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!HowToMakeYourOwnTutorialTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!HowToMakeYourOwnTutorialTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!IRAccess commentStamp: ''!
IRAccess models all bytecodes that read or write variables or self/super/thisContext!
!IRBlockReturnTop commentStamp: ''!
I model the bytecode for block returns.!
!IRBlockReturnTop methodsFor: 'accessing' stamp: ''!
successor: anObject

	successor := anObject.! !

!IRBlockReturnTop methodsFor: 'accessing' stamp: ''!
successor
	^ successor! !

!IRBlockReturnTop methodsFor: 'testing' stamp: ''!
isBlockReturnTop

	^true.! !

!IRBlockReturnTop methodsFor: 'accessing' stamp: ''!
successorSequences
	"sent to last instruction in sequence which is expected to be a jump and return instruction"

	^  { successor }! !

!IRBlockReturnTop methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitBlockReturnTop: self! !

!IRBuilder commentStamp: ''!
I provide a simple interface for constructing an IRMethod.  For example, to create an ir method that compares first instVar to first arg and returns 'yes' or 'no' (same example as in BytecodeGenerator), do:

	IRBuilder new
		numArgs: 1;
		addTemps: #(a z);
		pushReceiver;
		pushInstVar: 1;
		pushTemp: #a;
		send: #>;
		jumpAheadTo: #else if: false;
		pushLiteral: 'yes';
		returnTop;
		jumpAheadTarget: #else;
		pushLiteral: 'no';
		returnTop;
		ir

Sending #compiledMethod to an ir method will generate its compiledMethod.  Sending #methodNode to it will decompile to its parse tree.
!
!IRBuilder methodsFor: 'mapping' stamp: ''!
mapToNode: object
	"new instructions will be associated with object"

	sourceMapNodes addLast: object! !

!IRBuilder methodsFor: 'initialize' stamp: ''!
compilationContext: aCompilationContext
	ir compilationContext: aCompilationContext! !

!IRBuilder methodsFor: 'mapping' stamp: ''!
mapToByteIndex: index
	"decompiling"

	sourceMapByteIndex := index! !

!IRBuilder methodsFor: 'initialize' stamp: ''!
numArgs: anInteger
	ir numArgs: anInteger.
	ir sourceNode: self sourceNode.! !

!IRBuilder methodsFor: 'mapping' stamp: ''!
popMap

	sourceMapNodes removeLast! !

!IRBuilder methodsFor: 'scopes' stamp: ''!
pushScope: anIRBlockOrMethod

	currentScope push: anIRBlockOrMethod! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushReceiver

	self add: (IRInstruction pushReceiver)! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
jumpAheadTo: labelSymbol
	"Jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self.  This is and its corresponding target is only good for one use.  Other jumpAheadTo: with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called."

	"jumpAheadTarget: label will pop this and replace destination with its basic block"

	(jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
		addLast: (self add: IRJump new).
	self startNewSequence.! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushLiteralVariable: object

	self add: (IRInstruction pushLiteralVariable: object)! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
storeInstVar: name

	^self add: (IRInstruction storeInstVar: name).! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
popTop

	self add: IRInstruction popTop! !

!IRBuilder methodsFor: 'initialize' stamp: ''!
createTempVectorNamed: name withVars: anArray
	
	self addTemp: name.
	self add: (IRInstruction createTempVectorNamed: name withVars: anArray).
	
	"if we have the ast, we can store the temp offsets"
	self sourceNode ifNotNil: [ :sourceNode |
		anArray doWithIndex: [ :varName :i|
			(sourceNode scope lookupVar: varName) index: i]]! !

!IRBuilder methodsFor: 'initialization' stamp: ''!
initialize
	ir := IRMethod new.
	jumpAheadStacks := IdentityDictionary new.
	jumpBackTargetStacks := IdentityDictionary new.
	sourceMapNodes := OrderedCollection new.	"stack"
	currentScope := Stack new.
	self pushScope: ir.
	
	"Leave an empty sequence up front (guaranteed not to be in loop)"
	ir startSequence: ((IRSequence orderNumber: 0) method:ir).
	currentSequence := (IRSequence orderNumber: 1) method:ir.
	ir startSequence add:
		(IRJump new
			destination: currentSequence;
			bytecodeIndex: sourceMapByteIndex;
			yourself).! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushThisProcess
	"This is only supported with EncoderForSistaV1"
	self add: (IRInstruction pushThisProcess)! !

!IRBuilder methodsFor: 'initialize' stamp: ''!
addTemps: newKeys
	newKeys do: [ :key | self addTemp: key ]! !

!IRBuilder methodsFor: 'accessing' stamp: ''!
properties: aDict
	ir properties: aDict! !

!IRBuilder methodsFor: 'private' stamp: ''!
startNewSequence
	"End current instruction sequence and start a new sequence to add instructions to.  If ending block just falls through to new block then add an explicit jump to it so they stay linked"

	| newSequence | 
	currentSequence ifEmpty: [^ self].	"block is still empty, continue using it"
	newSequence := IRSequence orderNumber: currentSequence orderNumber + 1.
	newSequence method: ir.

	currentSequence last transitionsToNextSequence
		ifFalse: [ self add: (IRJump new destination: newSequence)].
	currentSequence := newSequence.! !

!IRBuilder methodsFor: 'scopes' stamp: ''!
currentScope 
	^currentScope top! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushThisContext

	self add: (IRInstruction pushThisContext)! !

!IRBuilder methodsFor: 'accessing' stamp: ''!
irPrimitive: primNode

	ir irPrimitive: primNode! !

!IRBuilder methodsFor: 'results' stamp: ''!
ir

	^ ir optimize! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushInstVar: index

	self add: (IRInstruction pushInstVar: index).! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
blockReturnTop
	| retInst |
	
	retInst := IRInstruction blockReturnTop.
	self add: retInst.
	self startNewSequence.
	retInst  successor: currentSequence.
	self popScope.! !

!IRBuilder methodsFor: 'initialize' stamp: ''!
addTemp: tempKey
	
	| tempMap |
	tempMap := self currentScope tempMap.
	
	"adding the same var multiple times reuses the same offset"
	(tempMap includesKey: tempKey) ifTrue: [ ^ 	self cacheIndex: tempKey ].
	
	tempMap at: tempKey put: tempMap size + 1.
	self cacheIndex: tempKey.! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushDup

	self add: IRInstruction pushDup! !

!IRBuilder methodsFor: 'private' stamp: ''!
add: instr
	
	"Associate instr with current parse node or byte range"
	instr sourceNode: self sourceNode.
	instr bytecodeIndex: self sourceByteIndex.
	^ currentSequence add: instr! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushTemp: aSelector

	^ self add: (IRInstruction pushTemp: aSelector)! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
addBlockReturnTopIfRequired
	"If the current sequence is empty this means that there was a returntop before 
	then since there is no more stmts we do not need a blockreturntop"
	
	"cant we optimize this away later? Then the frontend can always just add a return...."
	
	| predecessors |
	self flag: 'cant we do this automatically.... frontend always adds return, we ignore it if there is a ret method before?'.
	
	predecessors := ir predecessorsOf: currentSequence.
	(currentSequence isEmpty and: [(predecessors isEmpty) or: [((ir predecessorsOf: currentSequence) 
								anySatisfy: [:each | (each last isBlockReturnTop not) and: [(each last isReturn) 
												or: [(each size > 1) and: [(each at: each size -1) isReturn] ]]])] ])
							ifTrue: [self popScope]
							ifFalse: [self blockReturnTop ]! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
jumpAheadTo: labelSymbol if: boolean
	"Conditional jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self.  This and its corresponding target is only good for one use.  Other jumpAheadTo:... with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called."

	| instr |
	"jumpAheadTarget: label will pop this and replace destination with its basic block"
	(jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
		addLast: (instr := self add: (IRJumpIf new boolean: boolean)).
	self startNewSequence.
	instr otherwise: currentSequence.! !

!IRBuilder methodsFor: 'accessing' stamp: ''!
compilationContext
	^ir compilationContext! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
send: selector toSuperOf: behavior

	^self add: (IRInstruction send: selector toSuperOf: behavior)! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushFullClosureCompiledBlock: compiledBlock copiedValues: copiedValues

	^ self add: (IRInstruction pushFullClosureCompiledBlock: compiledBlock copiedValues: copiedValues)! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushLiteral: object

	self add: (IRInstruction pushLiteral: object)! !

!IRBuilder methodsFor: 'decompiling' stamp: ''!
addJumpBackTarget: label to: sequence

	(jumpBackTargetStacks at: label ifAbsentPut: [OrderedCollection new])
		addLast: sequence! !

!IRBuilder methodsFor: 'decompiling' stamp: ''!
testJumpAheadTarget: label

	jumpAheadStacks at: label ifPresent: [:stack |
		[stack isEmpty] whileFalse: [self jumpAheadTarget: label]
	]! !

!IRBuilder methodsFor: 'initialize' stamp: ''!
addPragma: aPragma
	^ir addPragma: aPragma! !

!IRBuilder methodsFor: 'initialize' stamp: ''!
addLiteral: aLiteral
	"Add this literal at the end of the literal array if there is space left"
	aLiteral ifNil: [ ^ self ].
	ir addAdditionalLiteral: aLiteral.! !

!IRBuilder methodsFor: 'mapping' stamp: ''!
sourceByteIndex

	^ sourceMapByteIndex! !

!IRBuilder methodsFor: 'scopes' stamp: ''!
popScope
	currentScope pop.! !

!IRBuilder methodsFor: 'initialize' stamp: ''!
additionalLiterals:  literals
	"Add this literal at the end of the literal array if there is space left"
	ir addAdditionalLiterals: literals.! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushRemoteTemp: name inVector: nameOfVector

	^self add: (IRInstruction pushRemoteTemp: name inVectorAt: nameOfVector)! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
storeTemp: aSymbol

	^self add: (IRInstruction storeTemp: aSymbol)! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
jumpBackTarget: labelSymbol
	"Remember this basic block for a future jumpBackTo: labelSymbol.  Stack up remembered targets with same name and remove them from stack for each jumpBackTo: called with same name."

	self startNewSequence.
	(jumpBackTargetStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
		addLast: currentSequence.! !

!IRBuilder methodsFor: 'mapping' stamp: ''!
sourceNode
	^ sourceMapNodes
		ifEmpty: [nil]
		ifNotEmpty: [sourceMapNodes last]! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
storeIntoLiteralVariable: name
	
	^self add: (IRInstruction storeIntoLiteralVariable: name)! !

!IRBuilder methodsFor: 'initialize' stamp: ''!
cacheIndex: tempKey
	"if we have the ast, we can store the temp offset"
	self sourceNode ifNotNil: [ :sourceNode | 
		| var |
		var := sourceNode scope lookupVar: tempKey.
		"some vars (e.g. limits in loops) do not exist on the AST level"
		var ifNotNil: [ var index: (self currentScope tempMap at: tempKey) ] ].! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
returnTop

	self add: IRInstruction returnTop.
	self startNewSequence.! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
send: selector

	^self add: (IRInstruction send: selector)! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushConsArray: size

	self add: (IRInstruction pushConsArray: size)! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
jumpAheadTarget: labelSymbol
	"Pop latest jumpAheadTo: with this labelSymbol and have it point to this new instruction sequence"

	| jumpInstr |
	self startNewSequence.
	jumpInstr := (jumpAheadStacks at: labelSymbol ifAbsent: [
			self error: 'Missing jumpAheadTo: ', labelSymbol printString]) removeLast.
	jumpInstr destination: currentSequence.! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
jumpBackTo: labelSymbol
	"Pop last remembered position with this label and write an unconditional jump to it"

	| sequence jump |
	sequence := (jumpBackTargetStacks at: labelSymbol ifAbsent: [self error: 'Missing jumpBackTarget: ', labelSymbol printString]) removeLast.
	jump := IRJump new destination: sequence.
	self add: jump.
	self startNewSequence.
	jump successor: currentSequence.! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
storeRemoteTemp: name inVector: nameOfVector

	^self add: (IRInstruction storeRemoteTemp: name inVectorAt: nameOfVector)! !

!IRBuilder methodsFor: 'instructions' stamp: ''!
pushNewArray: size

	self add: (IRInstruction pushNewArray: size)! !

!IRBuilder class methodsFor: 'builder api' stamp: ''!
buildMethod: aBlock
	^(self buildIR: aBlock) compiledMethod! !

!IRBuilder class methodsFor: 'builder api' stamp: ''!
buildIR: aBlock
	^(aBlock value: self new) ir.! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testSendSuper

	| iRMethod aCompiledMethod  |
	iRMethod := IRBuilder new
		pushReceiver;
		send: #isThisEverCalled toSuperOf: self class;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.


	self assert: (aCompiledMethod isKindOf: CompiledMethod).
     self should: [(aCompiledMethod valueWithReceiver: (self class new) arguments: #())] raise: Error.
	^iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testJumpBackTo

	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushReceiver;
		pushLiteral: false;
		jumpBackTarget: #begin;
		jumpAheadTo: #end if: true;
		pushLiteral: true;
		jumpBackTo: #begin;
		jumpAheadTarget: #end;	
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) isNil).
	^iRMethod.! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testPushThisContext
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushThisContext;
		send: #receiver;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: 5 arguments: #()) equals: 5.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testPopTop

	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushReceiver;
		pushLiteral: false;
		popTop;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) isNil).
	^iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralVariableGlobale
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteralVariable: (testingEnvironment associationAt: #Smalltalk);
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.

	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: Smalltalk.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testPushConsArray
	| iRMethod aCompiledMethod receiver |
	iRMethod := IRBuilder new
		pushReceiver;
		pushConsArray: 1;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.

	receiver := 5 @ 8.

	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: receiver arguments: #()) first identicalTo: receiver.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testStoreIvar
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 34;
		storeInstVar: 2;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: self arguments: #()) equals: 34.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralVariableClass
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteralVariable: Object binding;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.

	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: Object.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralCharacter
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: $e;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: $e.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testPushConsArray2
	| iRMethod aCompiledMethod receiver |
	iRMethod := IRBuilder new
		pushLiteral: 'hi!!';
		pushConsArray: 1;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.

	receiver := 5 @ 8.

	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: receiver arguments: #()) equals: #('hi!!').
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralFloat

	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 2.0; 	
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
 	self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) closeTo: 2.0).
	^iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralInteger
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 2;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: 2.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testReturnInstVar
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushInstVar: 1;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: 3 @ 4 arguments: #()) equals: 3.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testStoreTemp
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		addTemps: #(a);
		pushLiteral: 34;
		storeTemp: #a;
		popTop;
		pushTemp: #a;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: 34.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testPushThisProcess
	
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushThisProcess;
		send: #class;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: Process.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testPushTempTemp

	| iRMethod aCompiledMethod  |
	iRMethod := IRBuilder new
		addTemps: #(a);
		pushTemp: #a;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.


	self assert: (aCompiledMethod isKindOf: CompiledMethod).
     self assert: ((aCompiledMethod valueWithReceiver: 5 arguments: #() ) isNil).
	^iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralArray
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: #(test 4 you);
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: #(test 4 you).
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralVariableClassVariable
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteralVariable: (OCOpalExamples classVariableNamed: #ExampleClassVariable);
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.

	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	OCOpalExamples new classVariable: #tag.
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: #tag.
	OCOpalExamples reset.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testReturnTop

	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: false;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self deny: (aCompiledMethod valueWithReceiver: nil arguments: #()).
	^iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testPushNewArray

	| iRMethod aCompiledMethod receiver |
	iRMethod := IRBuilder new

		pushNewArray: 1;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	
	receiver :=  (5@8).

	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: ((aCompiledMethod valueWithReceiver: receiver arguments: #()) first isNil).
	^iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testStoreIntoVariable
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 4;
		storeIntoLiteralVariable: (self class bindingOf: #TestToPush);
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.


	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	aCompiledMethod valueWithReceiver: nil arguments: #().
	self assert: self class testToPush equals: 4.
	self class testToPush: nil.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testDup

	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder buildIR: [ : builder | 
		builder pushLiteral: 3;
		pushDup;
		send: #=;
		returnTop].

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
  	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #() ).
	^iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testStorePopIntoVariable
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 4;
		storeIntoLiteralVariable: (self class bindingOf: #TestToPush);
		popTop;
		pushLiteralVariable: (self class bindingOf: #TestToPush);
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.


	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	aCompiledMethod valueWithReceiver: nil arguments: #().
	self assert: self class testToPush equals: 4.
	self class testToPush: nil.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralNil

	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: nil; 	
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.

	self assert: (aCompiledMethod isKindOf: CompiledMethod).
     self assert: ((aCompiledMethod valueWithReceiver: 4 arguments: #() ) isNil).
	^iRMethod! !

!IRBuilderTest methodsFor: 'tests - builder' stamp: ''!
testBuildMethod
	|  aCompiledMethod |
	
	aCompiledMethod := IRBuilder buildMethod: [ : builder | 
		builder pushLiteral: 3;
		pushDup;
		send: #=;
		returnTop].

	self assert: (aCompiledMethod isKindOf: CompiledMethod).! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testInstVar
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushInstVar: 1;
		pushInstVar: 2;
		send: #+;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: 3 @ 4 arguments: #()) equals: 7.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralSymbol
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: #you;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.

	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: #you.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralString
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 'hello';
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.

	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: 'hello'.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testLiteralBoolean

	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: true; 	
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() )).
	^iRMethod.! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testPushSelf
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushReceiver;
		send: #class;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.


	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) identicalTo: UndefinedObject.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testStorePopIvar
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 34;
		storeInstVar: 2;
		popTop;
		pushInstVar: 2;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: self arguments: #()) equals: 34.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testPushTempArgument
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		numArgs: 2;
		addTemps: #(a b);
		pushTemp: #a;
		pushTemp: #b;
		send: #+;
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.


	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #(2 8)) equals: 10.
	^ iRMethod! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testJumpAheadToIf

	| iRMethod aCompiledMethod |
	
	iRMethod := IRBuilder new
		pushReceiver;
		pushLiteral: true;
		jumpAheadTo: #end if: true;
		returnTop;
		jumpAheadTarget: #end;	
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
 	self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) isNil).
	^iRMethod.! !

!IRBuilderTest methodsFor: 'tests' stamp: ''!
testJumpAheadTo
	| iRMethod aCompiledMethod iRBuilder |
	iRBuilder := IRBuilder new.
	iRMethod := iRBuilder
		pushLiteral: 2;
		pushLiteral: 1;
		send: #+;
		jumpAheadTo: #end;
		pushLiteral: 3;
		jumpAheadTarget: #end;
		returnTop;
		ir.


	aCompiledMethod := iRMethod compiledMethod.
	self assert: (aCompiledMethod isKindOf: CompiledMethod).
	self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) equals: 3.
	^ iRMethod! !

!IRBuilderTest class methodsFor: 'accessing' stamp: ''!
testToPush: anObject

	TestToPush := anObject! !

!IRBuilderTest class methodsFor: 'accessing' stamp: ''!
testToPush
	^TestToPush! !

!IRBuilderTest class methodsFor: 'accessing' stamp: ''!
compilerClass
	^ OpalCompiler! !

!IRBytecodeDecompiler commentStamp: ''!
I interpret bytecode instructions, sending the appropriate instruction messages to my IRBuilder, resulting in an IRMethod.!
!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
storeIntoRemoteTemp: remoteIndex inVectorAt: tempIndex 
	|  remoteArray remoteTempName |
	remoteArray := self scope tempAt: tempIndex.
	remoteTempName := self scope tempAt: remoteIndex inRemote: remoteArray.	
	irBuilder storeRemoteTemp: remoteTempName inVector: remoteArray.! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
pushConsArrayWithElements: numElements 
	irBuilder pushConsArray: numElements! !

!IRBytecodeDecompiler methodsFor: 'private' stamp: ''!
methodClass
	^ instructionStream  method methodClass! !

!IRBytecodeDecompiler methodsFor: 'scope' stamp: ''!
pushScope: copiedValues numArgs: numArgs
	|scope |
	scope := IRBytecodeScope new numArgs: numArgs.
	scopeStack push: scope.
	scope copiedValues: copiedValues.! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
	self storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex.
	self doPop.! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
pushConstant: value
	irBuilder pushLiteral: value! !

!IRBytecodeDecompiler methodsFor: 'public access' stamp: ''!
decompile: aCompiledMethod
	instructionStream := InstructionStream on: aCompiledMethod.
	irBuilder := IRReconstructor new.
	scopeStack := Stack new.
	self pushScope: #() numArgs: aCompiledMethod numArgs.
	irBuilder irPrimitive: aCompiledMethod irPrimitive.
	
	aCompiledMethod hasProperties ifTrue: [irBuilder properties: aCompiledMethod properties copy].
	irBuilder numArgs: aCompiledMethod numArgs.
	irBuilder addTemps: self scope args.
	aCompiledMethod isQuick
		ifTrue: [self quickMethod]
		ifFalse: [self interpret].
	self popScope.
	"just add all literals of the compiledMethod as additional literals.
	 duplicates will be filtered out, but we keep the optimized ones"
	irBuilder additionalLiterals: aCompiledMethod literals.
	"when compiling methods of context classes, force long form for iVar access by getting the correct context"
	irBuilder compilationContext: aCompiledMethod methodClass compiler compilationContext.
	^ irBuilder ir.! !

!IRBytecodeDecompiler methodsFor: 'quick methods' stamp: ''!
quickMethod

	instructionStream method primitive = 256 ifTrue: [
		^ self methodReturnReceiver
	]. 
	instructionStream method isReturnSpecial ifTrue: [
		^ self methodReturnConstant: (instructionStream method encoderClass quickPrimSpecialConstants at: instructionStream method primitive - 256)
	].
	instructionStream method isReturnField ifTrue: [
		self pushReceiverVariable: instructionStream method returnField.
		^ self methodReturnTop
	].
	self error: 'quick method inconsistency'! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
popIntoLiteralVariable: offset
	self storeIntoLiteralVariable: offset.
	self doPop.! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
send: selector super: superFlag numArgs: numArgs
	superFlag
		ifTrue: [irBuilder send: selector toSuperOf: self methodClass]
		ifFalse: [irBuilder send: selector]! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
doPop
	irBuilder popTop! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
pushReceiver
	irBuilder pushReceiver! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
pushNewArrayOfSize: size
	newTempVector := IRRemoteArray new size: size! !

!IRBytecodeDecompiler methodsFor: 'quick methods' stamp: ''!
methodReturnConstant: value
	self pushConstant: value.
	self methodReturnTop.! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
pushLiteralVariable: assoc
	irBuilder pushLiteralVariable: assoc.! !

!IRBytecodeDecompiler methodsFor: 'scope' stamp: ''!
popScope
	| scope tempIndex |
	scope := self scope.
	
	irBuilder addTemps: scope temps.
	
	" Remap your own temp vectors "
	scope ownTempVectors do: [ :tempVector |
		irBuilder
			remapTemp: (scope -> tempVector index)
			toRemote: tempVector ].
	
	" Remap the copied values "
	tempIndex := scope numArgs.
	scope copiedValues do: [ :copiedValue |
		irBuilder
			remapTemp: (scope -> tempIndex)
			toRemote: copiedValue.
		tempIndex := tempIndex + 1. ].
	
	^ scopeStack pop! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
methodReturnTop
	irBuilder isLastClosureInstruction
		ifTrue: [
			self popScope.
			irBuilder fixPushNilsForTemps.
			irBuilder returnTop.
			irBuilder popScope. ]
		ifFalse: [ irBuilder returnTop ]! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
jump: dist if: bool
	| index |
	index := instructionStream pc + dist .

	dist >= 0 ifTrue: [
		"conditional jump forward"
		^ irBuilder jumpAheadTo: index if: bool ].

	self error: 'Should not do this'! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
interpret
	| endPC |
	endPC := instructionStream method endPC.
	[instructionStream pc > endPC ] 
		whileFalse: [
			self checkIfJumpTarget.
			irBuilder mapToByteIndex: instructionStream pc.
			instructionStream interpretNextInstructionFor: self.]! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
storeIntoTemporaryVariable: offset
	irBuilder storeTemp: (self scope tempAt: offset)! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
doDup
	irBuilder pushDup! !

!IRBytecodeDecompiler methodsFor: 'quick methods' stamp: ''!
methodReturnReceiver
	self pushReceiver.
	self methodReturnTop.! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
pushActiveContext
	irBuilder pushThisContext! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
popIntoReceiverVariable: offset
	self storeIntoReceiverVariable: offset.
	self doPop.! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
storeIntoLiteralVariable: value
	irBuilder storeIntoLiteralVariable: value! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
pushTemporaryVariable: offset
	irBuilder pushTemp: (self scope tempAt: offset)! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
popIntoTemporaryVariable: offset
	newTempVector
		ifNil: [
			self storeIntoTemporaryVariable: offset.
			self doPop. ]
		ifNotNil: [
			self scope newTempVector: newTempVector at: offset.
			" Keep offset for remapping in popScope "
			newTempVector index: offset.
			irBuilder createTempVectorNamed: newTempVector withVars: newTempVector.
			newTempVector := nil ]! !

!IRBytecodeDecompiler methodsFor: 'private' stamp: ''!
checkIfJumpTarget
	irBuilder testJumpAheadTarget: instructionStream pc! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
blockReturnTop
	self popScope.
	irBuilder blockReturnTop.! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
pushFullClosure: compiledBlock numCopied: numCopied receiverOnStack: receiverOnStack ignoreOuterContext: ignoreOuterContext 
	
	| copiedValues |

	copiedValues := irBuilder removeLast: numCopied.

	irBuilder
		pushFullClosureCompiledBlock: compiledBlock copiedValues: copiedValues! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
storeIntoReceiverVariable: offset
	irBuilder storeInstVar: offset + 1.! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
pushReceiverVariable: offset
	irBuilder pushInstVar: offset + 1.! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
jump: dist
	| index seq instr newSeq seqs |
	index := instructionStream pc + dist.

	dist >= 0 ifTrue: [
		"jump forward"
		^ irBuilder jumpAheadTo: index ].
	"jump to the jump instuction itself"
	dist >= -2 ifTrue: 
		[	irBuilder jumpBackTarget: index.
			irBuilder jumpBackTo: index.
		^self].
	"jump backward"
	seqs := irBuilder ir allSequences.
	seq := seqs findLast: [:s | s notEmpty and: [s first bytecodeIndex <= index]].
	seq := seqs at: seq.
	seq first bytecodeIndex = index
		ifTrue: [ newSeq := seq ]
		ifFalse: [
			instr := seq detect: [:i | (seq after: i) bytecodeIndex = index].
			newSeq := seq splitAfter: instr ].
	irBuilder addJumpBackTarget: index to: newSeq.
	"if we have split the currentSequence of the irBuilder, make sure to set it
	to the newSeq"
	irBuilder currentSequence = seq ifTrue: [irBuilder currentSequence: newSeq].
	irBuilder jumpBackTo: index.! !

!IRBytecodeDecompiler methodsFor: 'scope' stamp: ''!
scope
	^ scopeStack top! !

!IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: ''!
pushRemoteTemp: remoteIndex inVectorAt: tempIndex 
	|  remoteArray remoteTempName |
	remoteArray := self scope tempAt: tempIndex.
	remoteTempName := self scope tempAt: remoteIndex inRemote: remoteArray.
	irBuilder pushRemoteTemp: remoteTempName inVector: remoteArray.! !

!IRBytecodeGenerator commentStamp: ''!
Handles the byte code generation of jumps, literals and similar things. Byte code independent. The encoder is bytecode dependent.

I generate bytecodes in response to 'instructions' messages being sent to me.  I rewrite jumps at the end so their jump offsets are correct (see #bytecodes).  For example, to create a compiled method that compares first instVar to first arg and returns 'yes' or 'no' (same example as in IRBuilder), do:

	BytecodeGenerator new
		numArgs: 1;
		pushInstVar: 1;
		pushTemp: 1;
		send: #>;
		if: false goto: #else;
		pushLiteral: 'yes';
		returnTop;
		label: #else;
		pushLiteral: 'no';
		returnTop;
		compiledMethod

You can send #ir to the compiledMethod to decompile to its IRMethod, and you can send #methodNode to either to decompile to its parse tree.


Instance Variables
	additionalLiterals:		<OCLiteralSet> Those are literals evaluated for effect and optimized control flow messages selectors used in the method in order to be able to do sendersOf: on these literals with success.
	bytes:		<OrderedCollection of bytes> current sequence of bytecodes being written 
	encoder:		<BytecodeEncoder> Set the one you need depending on which bytecode set you want to use.
	forceLongForm:		<Boolean> true if instance variable access requires a long form (typically, Context access)
		
	Following inst vars are used to map bytecode pc to IR instruction	
	instrMap:		<OrderedCollection>
	instrMaps:		<IdentityDictionary of OrderedCollection>
			
	lastLiteral:		<Behavior> Basically in the case you would compile without annotating the method with its class and its selector, this literal is used to enforce the method class to be a literal to allow super sends.
	lastSpecialReturn:		<Message> used to generate quick returns
	literals:		<OCLiteralList> literals of the methods
	numArgs:		<Smi> number of arguments of the method
	numberOfTemps:		<Smi> number of temps of the method
	primNumber:		<Smi> primitive number (or 0)
	properties:		<AdditionalMethodState | nil> used to hold the additional method state (pragmas for examples)
			
	Following inst vars are used to correctly map the jumps (See #initialize for extra information)
	orderSeq:		<OrderedCollection> Reverse map of seq order
	seqBytes:		<IdentityDictionary>
	seqOrder:		<IdentityDictionary>
	jumps:		<IdentityDictionary>
	currentSeqId:		<Object>
	currentSeqNum:		<Smi>
			
	stack:		<Stack> simulated stack. Only simulates the depth of the stack. Store its maximum value in stacks instance variable.
	stacks:		<IdentityDictionary (seqId -> stackCount)> used to find out the maximum depth of the method and therefore set the largeFrameBit!
!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
if: bool goto: seqId1 otherwise: seqId2
	stack pop.
	stacks at: seqId1 put: (stack linkTo: (stacks at: seqId1 ifAbsentPut: [ nil ])).
	stacks at: seqId2 put: (stack linkTo: (stacks at: seqId2 ifAbsentPut: [ nil ])).
	self
		saveLastJump:
			(Message
				selector: #from:if:goto:otherwise:
				arguments:
					{currentSeqId.
					bool.
					seqId1.
					seqId2}).
	self
		from: currentSeqId
		if: bool
		goto: seqId1
		otherwise: seqId2! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
compilationContext: aCompilationContext
	compilationContext := aCompilationContext! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
goto: seqId
	stacks at: seqId put: (stack linkTo: (stacks at: seqId ifAbsentPut: [ nil ])).
	self
		saveLastJump:
			(Message
				selector: #from:goto:
				arguments:
					{currentSeqId.
					seqId}).
	self from: currentSeqId goto: seqId! !

!IRBytecodeGenerator methodsFor: 'mapping' stamp: ''!
mapBytesTo: instr
	"Record the current byte offset in instruction sequence as start of instr. 
	This is later used to calculate the total byte offset of instruction in generated code,
	see #bytecodes"
	instrMap add: instr -> (bytes size + 1)! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
numArgs

	^ numArgs! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
spurVMHeader: literalsSize
	^ (CompiledMethod headerFlagForEncoder: self encoderClass) +
		(self numArgs bitShift: 24) +
		( self numTemps bitShift: 18) +
		literalsSize +
		(self hasPrimitive asBit bitShift: 16)! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
storeRemoteTemp: tempIndex inVectorAt: tempVectorIndex 
	encoder genStoreRemoteTemp: tempIndex - 1 inVectorAt: tempVectorIndex - 1! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
numArgs: n

	numArgs := n! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
literals
	literals := literals asArray.	"Put the optimized selectors in literals so as to browse senders more easily"
	additionalLiterals := additionalLiterals asArray reject: [ :e | literals hasLiteral: e ].
	additionalLiterals isEmpty
		ifFalse: [ 
			"Use one entry per literal if enough room, else make anArray"
			literals := literals size + additionalLiterals size + 2 > 255
				ifTrue: [ literals copyWith: additionalLiterals ]
				ifFalse: [ literals , additionalLiterals ] ].
	(literals anySatisfy: [ :each | each isMethodProperties ])
		ifFalse: [ literals := literals copyWith: nil ].
	^ lastLiteral ifNil: [ literals copyWith: nil ] ifNotNil: [ literals copyWith: lastLiteral ]! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
bytecodes
	| stream |
	self updateJumpOffsets.
	stream := (ByteArray new: 100) writeStream. 
	primitiveBytes ifNotNil: [stream nextPutAll: primitiveBytes contents].
	orderSeq do: [ :seqId | |lastInstr|
			"If the instruction will emit bytes, record the first byte emitted as the instructions bytecode index"
			lastInstr := IRInstruction new -> 1.
			(instrMaps at: seqId) do: [ :assoc | |nextInstr|
				nextInstr := assoc.
				lastInstr key bytecodeIndex: ((nextInstr value - lastInstr value) > 0 ifTrue: [ 
					stream position + lastInstr value]).
				lastInstr := assoc.
				  ].
			lastInstr key bytecodeIndex: ((seqBytes at: seqId) size < lastInstr value ifFalse: [  stream position + lastInstr value]).
			stream nextPutAll: (seqBytes at: seqId) ].
	^ stream contents! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
addLastLiteral: object
	lastLiteral ifNil: [ ^ lastLiteral := object ].
	((lastLiteral literalEqual: object)
		or: [ 
			"case of metaclass, they have no unique association"
			lastLiteral isVariableBinding and: [ lastLiteral key isNil ] ])
		ifFalse: [ self error: 'there can only be one last literal' ]! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
storePopTemp: index
	stack pop. 
	encoder genStorePopTemp: index - 1! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushReceiver
	stack push.
	encoder genPushReceiver! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushFullBlockClosure: fullBlock
	fullBlock copiedValues size timesRepeat: [ stack pop ].
	stack push.
	encoder 
		genPushFullClosure: (self literalIndexOf: fullBlock compiledBlock) 
		numCopied: fullBlock copiedValues size
		receiverOnStack: false
		outerContextNeeded: true! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
encoderClass
	^ encoderClass! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
numTemps

	^ numberOfTemps! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
storeInstVar: index 
	forceLongForm 
		ifTrue: [ encoder genStoreInstVarLong: index - 1 ]
		ifFalse: [ encoder genStoreInstVar: index - 1 ]! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushLiteralVariable: object 
	stack push.
	encoder genPushLiteralVar: (self literalIndexOf: object).! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
popTop
	stack pop.
	encoder genPop! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
saveLastJump: message
	jumps at: currentSeqId put: {bytes size. message}.! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushThisProcess

	stack push.
	encoder genPushThisProcess.! !

!IRBytecodeGenerator methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	encoder := self encoderClass new.
	encoder stream: self.
	
	primNumber := 0.
	
	inBlock := false.
	literals := OCLiteralList new.
	"The following dicts are keyed by sequence id given by client in label: (and gotos)."
	seqOrder := IdentityDictionary new.  "seqId -> seq order num"
	seqBytes := IdentityDictionary new.  "seqId -> seq bytecodes"
	jumps := IdentityDictionary new.  "seqId -> last jump instr"
	instrMaps := IdentityDictionary new.  "seqId -> (clientInstr -> bytecode pos)"
	stacks := IdentityDictionary new.  "seqId -> stackCount"
	numArgs := 0.
	currentSeqNum := 0.
	orderSeq := OrderedCollection new.  "reverse map of seqOrder"
	additionalLiterals := OCLiteralSet new.
	forceLongForm := false.
	"starting label in case one is not provided by client"
	self label: self newDummySeqId! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
pragmas: aCollection
	aCollection do: [:each | self addPragma: each]! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
label: seqId
	lastSpecialReturn := nil.
	currentSeqId := seqId.
	currentSeqNum := currentSeqNum + 1.
	seqOrder at: seqId put: currentSeqNum.
	orderSeq at: currentSeqNum ifAbsentPut: [seqId].
	bytes := seqBytes at: seqId ifAbsentPut: [OrderedCollection new].
	jumps at: seqId ifAbsentPut: [nil].
	instrMap := instrMaps at: seqId ifAbsentPut: [OrderedCollection new].
	stack
		ifNil: [ stack := stacks at: currentSeqId ifAbsentPut: [ IRStackCount new ] ]
		ifNotNil: [stack := stacks at: currentSeqId ifAbsentPut: [ stack class newOn:stack ] ]! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
jumpForward: distance

	distance = 0 ifTrue: [^ self].  
	encoder genJump: distance.! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
updateJump: seqId
	"Recalculate final jump bytecodes.  Return true if jump bytecodes SIZE has changed, otherwise return false"
	| pair s1 |
	pair := jumps at: seqId.
	pair ifNil: [^ false].  "no jump, a return"
	bytes := seqBytes  at: seqId.
	s1 := bytes size.
	bytes removeLast: (bytes size - pair first).
	pair last sendTo: self.
	^ s1 ~= bytes size.! !

!IRBytecodeGenerator methodsFor: 'initialize' stamp: ''!
irPrimitive: anIrPrimitive
	literals isEmpty ifFalse: [self error: 'init prim before adding instructions'].
	anIrPrimitive spec ifNotNil: [literals add: anIrPrimitive spec].
	primNumber := anIrPrimitive num.
	primNumber = 0 ifTrue: [ ^ self ].
	self encoderClass callPrimitiveCode ifNil: [ ^ self ].
	encoder genCallPrimitive: primNumber! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
properties: propDict
	properties := propDict.! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushThisContext

	stack push.
	encoder genPushThisContext! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
jump: distance if: condition withInterpreter: anInterpreter
	
	^ self jump: distance if: condition! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushInstVar: instVarIndex
	stack push.
	forceLongForm
		ifTrue: [ encoder genPushInstVarLong: instVarIndex - 1 ]
		ifFalse: [ encoder genPushInstVar: instVarIndex - 1 ]! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
primNum
	^ primNumber! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
blockReturnTop
	encoder genReturnTopToCaller! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
addProperties: cm
	"set the properties of cm according to properties saved"

	properties
		ifNotNil: [ cm penultimateLiteral: properties.
			properties method: cm.
			properties pragmas do: [ :each | each method: cm ] ]! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
updateJumpOffsets
	[ orderSeq 
		inject: false 
		into: [ :changed :seqId | (self updateJump: seqId) or: [ changed ]] 
	] whileTrue! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
compiledMethod

	^ self compiledMethodWith: CompiledMethodTrailer empty! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
literalIndexOf: object

	| index |
	
	(index := literals literalIndexOf: object ifAbsent: 0) > 0 ifFalse: [
		index := self addLiteral: object].
	
	"conversion from 1 based to 0 based"
	^ index - 1! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
stackFrameSize
	^ (stacks collect: [:s | s length]) max! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushRemoteTemp: tempIndex inVectorAt: tempVectorIndex
	stack push.
	encoder genPushRemoteTemp: tempIndex - 1 inVectorAt: tempVectorIndex - 1! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
jumpBackward: distance

	encoder genJumpLong: distance negated - self encoderClass backJumpBytecodeSize! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
returnReceiver
	bytes ifEmpty: [ lastSpecialReturn := Message selector: #returnReceiver].
	encoder genReturnReceiver.! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushDup
	stack push.
	encoder genDup! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushTemp: index
	stack push.
	encoder genPushTemp: index - 1! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
compilationContext
	^ compilationContext ifNil: [compilationContext := CompilationContext default]! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
quickMethodPrim

	| index |
	self numArgs = 0 ifFalse: [^ 0].
	lastSpecialReturn ifNil: [^ 0].
	(seqBytes  size <= 2) ifFalse: [^ 0].
	"this is for ruling out the case in which the structure is the same as a quick return
	but with and invalid special literal."
	((literals size = 1) and: [ (encoderClass quickPrimSpecialConstants identityIncludes: literals first) not and: [ lastSpecialReturn selector = #returnConstant: ] ] )
		ifTrue: [^ 0].
	lastSpecialReturn selector == #returnReceiver 
		ifTrue: [^256].
	lastSpecialReturn selector == #returnConstant:
		 ifTrue: [^(index := encoderClass quickPrimSpecialConstants identityIndexOf: lastSpecialReturn argument) > 0
					ifTrue: [256 + index] ifFalse: [0]].
	lastSpecialReturn selector == #returnInstVar: 
		ifTrue: [^forceLongForm 
					ifTrue: [0]  "when compiling long bytecodes for Contexts, do not do quick return either"
					ifFalse: [263 + lastSpecialReturn argument]]! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
send: selector toSuperOf: behavior
	| index nArgs |
	nArgs := selector numArgs.
	stack pop: nArgs.
	index := self literalIndexOf: selector.

	inBlock
		ifTrue: [
			"we need to use a copy of the binding as else 'references to' will find this method" 
			encoder genPushLiteralVar: (self literalIndexOf: behavior binding copy).
			encoder genSendDirectedSuper: index numArgs: nArgs ]
		ifFalse: [ 
			self addLastLiteral: behavior binding.  
			encoder genSendSuper: index numArgs: nArgs ]! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
newDummySeqId

	^ Object new! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
inBlock: bool
	inBlock := bool.! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
forceLongForm: aBoolean
	forceLongForm := aBoolean! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
nextPut: byte
	bytes add: byte! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushLiteral: object
	stack push.
	"identity includes else 0.0 = 0 whereas it's a Float" 
	(self encoderClass specialLiterals identityIncludes: object) ifTrue: [ 
		^ encoder genPushSpecialLiteral: object ].
	encoder genPushLiteral: (self literalIndexOf: object)! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
updateLiterals: code
	"Add back pointer from compiled block to outer code"
	code literals do: [ :each |
		each isEmbeddedBlock ifTrue: [ each outerCode: code ] ]! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
from: fromSeqId if: bool goto: toSeqId otherwise: otherwiseSeqId

	| distance from to otherwise |
	from := seqOrder at: fromSeqId.
	to := seqOrder at: toSeqId ifAbsent: [^ self jump: 0 if: bool].  "not done yet"
	otherwise := seqOrder at: otherwiseSeqId ifAbsent: [^ self jump: 0 if: bool].  "not done yet"
	from < to ifFalse: [self error].
	from + 1 = otherwise ifFalse: [self error].
	distance := (from + 1 to: to - 1)
		inject: 0
		into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size].
	self jump: distance if: bool.! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
addPragma: aPragma
	properties ifNil: [ properties := AdditionalMethodState new ].
	properties := properties copyWith: aPragma.! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
addLiteral: object
	literals add: object.
	^ literals identityIndexOf: object! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
encoderClass: class
	encoderClass := class! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
returnConstant: constant
	bytes ifEmpty: [ lastSpecialReturn := Message selector: #returnConstant: argument: constant ].
	(#(nil true false) includes: constant) ifTrue: 
		[ ^ encoder genReturnSpecialLiteral:constant ].
	self pushLiteral: constant.
	self returnTop! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
jump: distance if: condition
	distance = 0
		ifTrue: [ ^ encoder genPop ].
	condition
		ifTrue: [ encoder genBranchPopTrue: distance ]
		ifFalse: [ encoder genBranchPopFalse: distance ]! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
additionalLiterals: aSet
	additionalLiterals := aSet.! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
storePopInstVar: index 
	stack pop.
	forceLongForm 
		ifTrue: [ encoder genStorePopInstVarLong: index - 1 ]
		ifFalse: [ encoder genStorePopInstVar: index - 1 ]! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
if: bool goto: seqId
	| otherwiseSeqId |
	otherwiseSeqId := self newDummySeqId.
	self if: bool goto: seqId otherwise: otherwiseSeqId.
	self label: otherwiseSeqId! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
storePopRemoteTemp: tempIndex inVectorAt: tempVectorIndex 
	stack pop.
	encoder genStorePopRemoteTemp: tempIndex - 1 inVectorAt: tempVectorIndex - 1! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
numTemps: anInteger

	numberOfTemps := anInteger! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
storeTemp: index
	encoder genStoreTemp: index - 1! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
storePopIntoLiteralVariable: assoc

	encoder genStorePopLiteralVar: (self literalIndexOf: assoc).
	stack pop! !

!IRBytecodeGenerator methodsFor: 'private' stamp: ''!
from: fromSeqId goto: toSeqId

	| distance from to |
	from := seqOrder at: fromSeqId.
	to := seqOrder at: toSeqId ifAbsent: [^ self].
	from + 1 = to ifTrue: [^ self].  "fall through, no jump needed"

	from < to ifTrue: [ "jump forward"
		distance := (from + 1 to: to - 1) inject: 0 into: [:size :i | 
				size + (seqBytes at: (orderSeq at: i)) size].
		self jumpForward: distance.
	] ifFalse: [ "jump backward"
		distance := ((to to: from - 1) inject: 0 into: [:size :i |
				size + (seqBytes at: (orderSeq at: i)) size])
			+ bytes size.
		self jumpBackward: distance.
	].! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
storeIntoLiteralVariable: object 
	encoder genStoreLiteralVar: (self literalIndexOf: object).! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
compiledMethodWith: trailer
	| lits quickPrimitive |
	lits := self literals.
	quickPrimitive := self quickMethodPrim.
	(primNumber = 0 and: [quickPrimitive > 0]) ifTrue: [
		"if we are a quick method we need to add a bytecode at the beginning. #bytecodes
		takes primitiveBytes into account" 
		primitiveBytes := (ByteArray new: 4) writeStream.
		encoder stream: primitiveBytes.
		encoder genCallPrimitive: quickPrimitive.
	].
	^ self compiledMethodWith: trailer header: (self spurVMHeader: lits size) literals: lits! !

!IRBytecodeGenerator methodsFor: 'accessing' stamp: ''!
properties
	^ properties! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
returnTop
	stack pop.
	encoder genReturnTop! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
compiledMethodWith: trailer header: header literals: lits
	| cm cmClass|
	"we look up the class in the productionEnvironment"
	cmClass := self compilationContext compiledMethodClass.
	cm := trailer createMethod: self bytecodes size class: cmClass header: header.
	(WriteStream with: cm)
		position: cm initialPC - 1;
		nextPutAll: self bytecodes.
	lits withIndexDo: [:obj :i | cm literalAt: i put: obj].
	cm needsFrameSize: self stackFrameSize.
	self updateLiterals: cm.
	self addProperties: cm.
	^ cm! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
send: selector
	| nArgs |
	nArgs := selector numArgs.
	stack pop: nArgs.
	(self encoderClass specialSelectors includes: selector)
		ifTrue: [ ^ encoder genSendSpecial: (self encoderClass specialSelectors indexOf: selector) numArgs: nArgs ].
	encoder genSend: (self literalIndexOf: selector) numArgs: nArgs! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushConsArray: size
	stack push.
	stack pop: size.
	encoder genPushConsArray: size! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
hasPrimitive
	"do I have a primitive? Both normal primitive and quick return"
	primNumber > 0 ifTrue: [ ^true ].
	^ self endPrimNumber > 0! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
compiledBlockWith: trailer
	| lits header cb |
	lits := self literals allButLast "1 free only for compiledBlock".
	header := self spurVMHeader: lits size.
	cb := CompiledBlock newMethod: self bytecodes size header: header.
	(WriteStream with: cb)
		position: cb initialPC - 1;
		nextPutAll: self bytecodes.
	lits withIndexDo: [:obj :i | cb literalAt: i put: obj].
	cb needsFrameSize: self stackFrameSize.
	self updateLiterals: cb.
	^ cb! !

!IRBytecodeGenerator methodsFor: 'results' stamp: ''!
endPrimNumber
	"primitive number including quick return. Only valid at the end of generation"
	^ primNumber > 0
			ifTrue: [ primNumber ]
			ifFalse: [ self quickMethodPrim ]! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
returnInstVar: index 
	bytes ifEmpty: [
		lastSpecialReturn := Message selector: #returnInstVar: argument: index].
	self pushInstVar: index.
	self returnTop.! !

!IRBytecodeGenerator methodsFor: 'instructions' stamp: ''!
pushNewArray: size
	stack push.
	encoder genPushNewArray: size! !

!IRBytecodeGenerator class methodsFor: 'instance creation' stamp: ''!
newWithEncoderClass: class
	^ self basicNew 
		encoderClass: class;
		initialize;
		yourself! !

!IRBytecodeScope commentStamp: ''!
I am an internal class used by the  decompiler to recreat variable information!
!IRBytecodeScope methodsFor: 'accessing' stamp: ''!
temps
	| result tempOffset numTemps |
	tempOffset := copiedValues size + numArgs.
	numTemps := temps - tempOffset.
	result := Array new: numTemps.
	tempOffset := tempOffset - 1.
	1 to: numTemps do: [ :idx | result at: idx put: self -> (tempOffset + idx)  ].
	ownTempVectors do: [ :tempVector | result at: tempVector index - tempOffset put: tempVector ].
	^ result! !

!IRBytecodeScope methodsFor: 'initialization' stamp: ''!
initialize
	temps := 0.
	ownTempVectors := OrderedCollection new! !

!IRBytecodeScope methodsFor: 'accessing' stamp: ''!
args
	| args |
	args := Array new: numArgs.
	1 to: numArgs do: [ :idx | args at: idx put: self -> (idx - 1)].
	^ args! !

!IRBytecodeScope methodsFor: 'accessing' stamp: ''!
numArgs
	^ numArgs! !

!IRBytecodeScope methodsFor: 'accessing' stamp: ''!
copiedValues: someCopiedValues
	copiedValues := someCopiedValues! !

!IRBytecodeScope methodsFor: 'accessing' stamp: ''!
numArgs: anInteger
	numArgs := anInteger.
	temps := temps max: numArgs! !

!IRBytecodeScope methodsFor: 'accessing' stamp: ''!
copiedValues
	^ copiedValues! !

!IRBytecodeScope methodsFor: 'accessing' stamp: ''!
newTempVector: aTempVector at: offset
	ownTempVectors add: aTempVector.
	self tempAt: offset! !

!IRBytecodeScope methodsFor: 'accessing' stamp: ''!
ownTempVectors
	^ ownTempVectors! !

!IRBytecodeScope methodsFor: 'accessing' stamp: ''!
tempAt: remoteIndex inRemote: remoteArray
	^ remoteIndex! !

!IRBytecodeScope methodsFor: 'accessing' stamp: ''!
tempAt: zeroBasedIndex
	temps := temps max: zeroBasedIndex + 1.
	^ self -> zeroBasedIndex! !

!IRClosureStackCount commentStamp: ''!
IRClosureStackCount is used to distinguish between a stack 
in the method scope and a stack within a closure block. The
closure stack size is independent of the number of tempvars from the compiled method, therefore that number is subtracted
from this stack size length.!
!IRClosureStackCount methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	numMethodTempVars := 0.! !

!IRClosureStackCount methodsFor: 'accessing' stamp: ''!
numMethodTempVars: nilOrNumber
	numMethodTempVars := nilOrNumber ifNil:[0]! !

!IRClosureStackCount methodsFor: 'accessing' stamp: ''!
numMethodTempVars
	^ numMethodTempVars! !

!IRClosureStackCount methodsFor: 'accessing' stamp: ''!
length

	^ super length - self numMethodTempVars! !

!IRClosureStackCount class methodsFor: 'instance creation' stamp: ''!
newOn: stack
	^ (self startAt: stack position)
		numMethodTempVars: stack numMethodTempVars;
		yourself! !

!IRFix commentStamp: ''!
Fix the IR nodes.

Transforms:

store, pop => popInto
some returns => quick returns!
!IRFix methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	storePopToFix := OrderedCollection new.
	retToFix := OrderedCollection new.! !

!IRFix methodsFor: 'visiting' stamp: ''!
visitSequence: instructionSequence
	prevInstr := nil.
	storePopToFix reset.
	retToFix reset.
	super visitSequence: instructionSequence.
	retToFix do: [ :each | self convertRet: each forSeq: instructionSequence ].
	storePopToFix do: [ :each | self convertStorePop: each forSeq: instructionSequence ]! !

!IRFix methodsFor: 'private' stamp: ''!
convertRet: assoc forSeq: seq 
	| push ret |
	push := assoc key.
	ret := assoc value.
	seq replaceNode: push withNode: (push quickRetNode sourceNode: ret sourceNode).
	seq remove: ret.! !

!IRFix methodsFor: 'visiting' stamp: ''!
visitPop: pop
	prevInstr ifNil: [ ^ self ].
	prevInstr isStore ifFalse: [ ^ self ].
	"store then pop, however, cannot remove instr while iterating over the collection"
	storePopToFix add: prevInstr -> pop.! !

!IRFix methodsFor: 'private' stamp: ''!
convertStorePop: assoc forSeq: seq 
	| store pop |
	store := assoc key.
	pop := assoc value.
	seq replaceNode: store withNode: (store popIntoNode sourceNode: store sourceNode).
	seq remove: pop.! !

!IRFix methodsFor: 'visiting' stamp: ''!
visitReturn: ret
	prevInstr ifNil: [ ^ self ].
	prevInstr canBeQuickReturn ifFalse: [ ^ self ].
	retToFix add: prevInstr -> ret.! !

!IRFix methodsFor: 'visiting' stamp: ''!
visitInstruction: instr
	self visitNode: instr.
	prevInstr := instr.! !

!IRInstVarAccess commentStamp: ''!
I am a bytecode accessing an instance variable. As such, I have an index.!
!IRInstVarAccess methodsFor: 'accessing' stamp: ''!
index: anInteger
	index := anInteger! !

!IRInstVarAccess methodsFor: 'testing' stamp: ''!
isInstVarAccess
	^ true! !

!IRInstVarAccess methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!IRInstruction commentStamp: ''!
I am an instruction in the IR (intermediate representation) language.  The IR serves as the intermediary between the Smalltalk language and the bytecode language.  It is easier to optimize and translate to/from this language than it is to optimize/translate directly from Smalltalk to bytecodes.  The IR is generic and simple consisting of just twelve instructions.  They are:

	goto: labelNum
	if: boolean goto: labelNum1 otherwise: labelNum2
	label: labelNum
	popTop
	pushDup
	pushLiteral: object
	pushTemp: name
	blockReturn
	returnTop
	send: selector
	send: selector toSuperOf: behavior
	storeTemp: name

Each instruction is reified as an instance of one of my subclasses and grouped by basic block (IRSequence) into an IRMethod.  IRInterpreter visits each instruction in a IRMethod responding to the above instruction messages sent to it.
!
!IRInstruction methodsFor: 'mapping' stamp: ''!
bytecodeIndex: index

	bytecodeIndex := index! !

!IRInstruction methodsFor: 'accessing' stamp: ''!
sequence: aSeq
	sequence := aSeq! !

!IRInstruction methodsFor: 'adding' stamp: ''!
addInstructionsBefore: aCollection
	sequence addInstructions: aCollection before: self.! !

!IRInstruction methodsFor: 'inspector' stamp: ''!
children
	^#()! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isPop

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isIf

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isPushLiteral: valueTest

	^ false! !

!IRInstruction methodsFor: 'printing' stamp: ''!
printOn: aStream
	IRPrinter new
			stream: aStream;
			visitNode: self! !

!IRInstruction methodsFor: 'mapping' stamp: ''!
bytecodeIndex

	^ bytecodeIndex! !

!IRInstruction methodsFor: 'replacing' stamp: ''!
replaceWith: aNode
	sequence ifNil: [self error: 'This node doesn''t have a sequence'].
	sequence replaceNode: self withNode: aNode! !

!IRInstruction methodsFor: 'adding' stamp: ''!
addInstructionsAfter: aCollection
	sequence addInstructions: aCollection after: self.! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isPushLiteral
	^false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isBlockReturnTop

	^false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isReturn

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isRead
	^false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
canBeQuickReturn
	^ false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isTempVector
	^false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isLiteralVariable
	^false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isInstVarAccess

	^false.! !

!IRInstruction methodsFor: 'mapping' stamp: ''!
bytecodeOffset
	| startpc |
	startpc := self method compiledMethod initialPC.
	self bytecodeIndex ifNil: [^startpc].
	^self bytecodeIndex + startpc - 1.! !

!IRInstruction methodsFor: 'replacing' stamp: ''!
delete
	sequence ifNil: [self error: 'This node doesn''t have a sequence'].
	sequence remove: self.! !

!IRInstruction methodsFor: 'inspector' stamp: ''!
sourceInterval
	^self sourceNode sourceInterval! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isStore
	^false! !

!IRInstruction methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	self error: 'I don''t store other nodes'! !

!IRInstruction methodsFor: 'mapping' stamp: ''!
sourceNode: parseNode

	sourceNode := parseNode! !

!IRInstruction methodsFor: 'accessing' stamp: ''!
method
	^sequence method.! !

!IRInstruction methodsFor: 'testing' stamp: ''!
transitionsToNextSequence
	"Does the current instruction intrinsically know how to transition to the next sequence?"
	^ self isJump or: [self isReturn]! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isGoto
	"is unconditional jump"
	
	^ false! !

!IRInstruction methodsFor: 'mapping' stamp: ''!
sourceNode

	^ sourceNode! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isSend
	^false.! !

!IRInstruction methodsFor: 'accessing' stamp: ''!
nonBodySuccessorSequences
	^self successorSequences! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isJump
	"goto or if"

	^false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isSelf
	^false! !

!IRInstruction methodsFor: 'testing' stamp: ''!
isTemp
	^false! !

!IRInstruction methodsFor: 'accessing' stamp: ''!
successorSequences
	"sent to last instruction in sequence which is expected to be a jump and return instruction"

	^ #()! !

!IRInstruction methodsFor: 'accessing' stamp: ''!
sequence
	^sequence! !

!IRInstruction methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	self subclassResponsibility! !

!IRInstruction methodsFor: 'replacing' stamp: ''!
replaceWithInstructions: aCollection 

	sequence ifNil: [self error: 'This node doesn''t have a sequence'].
	sequence replaceNode: self withNodes: aCollection! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushDup

	^ IRPushDup new! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
popTop
	^ IRPop new! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushRemoteTemp: aName inVectorAt: nameOfVector
	^ IRPushRemoteTemp new
		name: aName;
		tempVectorName: nameOfVector;
		yourself.! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushThisProcess
	^ IRPushThisProcess new! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushTemp: aName
	aName = 'self' ifTrue: [self error: 'use pushReceiver'].
	^ IRPushTemp new
		name: aName;
		yourself! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
createTempVectorNamed: aTempVectorName withVars: anArray  

	^ IRTempVector new
		name: aTempVectorName;
		vars: anArray;
		yourself.! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
storeTemp: aName
	^ IRStoreTemp new
		name: aName;
		yourself! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
send: selector toSuperOf: behavior

	behavior ifNil: [self error: 'super of nil does not exist'].
	^ IRSend new
		selector: selector;
		superOf: behavior;
		yourself.! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
storeRemoteTemp: aName inVectorAt: nameOfVector
	^ IRStoreRemoteTemp new
		name: aName;
		tempVectorName: nameOfVector;
		yourself.! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushThisContext
	^ IRPushThisContext new! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
storeIntoLiteralVariable: object

	^ IRStoreLiteralVariable new
		association: object;
		yourself! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushFullClosureCompiledBlock: compiledBlock copiedValues: copiedValues
	^IRPushFullClosure new
			copiedValues: copiedValues;
			compiledBlock: compiledBlock;
			yourself.! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushInstVar: index

	^ IRPushInstVar new 
			index:  index; 
			yourself! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
returnTop

	^ IRReturn new! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushLiteral: object

	^ IRPushLiteral new
		literal: object! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
blockReturnTop
	^ IRBlockReturnTop new! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushReceiver
	^ IRPushReceiver new! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
send: selector

	^ IRSend new
		selector: selector! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushConsArray: aSize 
	^IRPushArray new
		size: aSize;
		cons: true;
		yourself.! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushLiteralVariable: object

	^ IRPushLiteralVariable new
		association: object;
		yourself! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
pushNewArray: aSize
	
	^IRPushArray new
		size: aSize;
		cons: false;
		yourself.! !

!IRInstruction class methodsFor: 'instance creation' stamp: ''!
storeInstVar: index
	^ IRStoreInstVar new 
		index: index; 
		yourself! !

!IRJump commentStamp: ''!
Instruction "goto: labelNum"!
!IRJump methodsFor: 'accessing' stamp: ''!
destination

	^ destination! !

!IRJump methodsFor: 'accessing' stamp: ''!
successor: succ
	successor := succ! !

!IRJump methodsFor: 'accessing' stamp: ''!
successor
	^successor! !

!IRJump methodsFor: 'testing' stamp: ''!
isGoto
	"is unconditional jump"

	^ true! !

!IRJump methodsFor: 'accessing' stamp: ''!
nextBytecodeOffsetAfterJump
	^ destination last destination first bytecodeOffset! !

!IRJump methodsFor: 'accessing' stamp: ''!
destination: aSequence
	destination := aSequence! !

!IRJump methodsFor: 'testing' stamp: ''!
isJump
	"goto or if"

	^ true! !

!IRJump methodsFor: 'accessing' stamp: ''!
successorSequences

	^ {destination. successor}! !

!IRJump methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitJump: self! !

!IRJumpIf commentStamp: ''!
Instruction "if: boolean goto: labelNum1 otherwise: labelNum2"!
!IRJumpIf methodsFor: 'accessing' stamp: ''!
otherwise: aSequence

	otherwise := aSequence! !

!IRJumpIf methodsFor: 'testing' stamp: ''!
isGoto
	"is unconditional jump"

	^ false! !

!IRJumpIf methodsFor: 'accessing' stamp: ''!
boolean

	^ boolean! !

!IRJumpIf methodsFor: 'accessing' stamp: ''!
nextBytecodeOffsetAfterJump
	"check if we are in ifTrue:ifFalse: / ifFalse:ifTrue: or in ifTrue: / ifFalse: and answers the next byte code offset"
	^destination last isJump 
		ifTrue: [ destination last destination first bytecodeOffset ]
		ifFalse: [ 
			(destination sequence at: ((destination size - 1) max: 1)) bytecodeOffset ]! !

!IRJumpIf methodsFor: 'testing' stamp: ''!
isIf

	^ true! !

!IRJumpIf methodsFor: 'accessing' stamp: ''!
boolean: bool

	boolean := bool! !

!IRJumpIf methodsFor: 'accessing' stamp: ''!
nonBodySuccessorSequences

	^ {destination}! !

!IRJumpIf methodsFor: 'accessing' stamp: ''!
otherwise

	^ otherwise! !

!IRJumpIf methodsFor: 'accessing' stamp: ''!
successorSequences

	^ {destination. otherwise}! !

!IRJumpIf methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitJumpIf: self! !

!IRLiteralVariableAccess commentStamp: ''!
LiteralVariables are 

-> Globals
-> Pool access
-> Class Var access!
!IRLiteralVariableAccess methodsFor: 'accessing' stamp: ''!
association 
	^association! !

!IRLiteralVariableAccess methodsFor: 'accessing' stamp: ''!
name
	^association key! !

!IRLiteralVariableAccess methodsFor: 'accessing' stamp: ''!
association: anAssociation
	association := anAssociation! !

!IRLiteralVariableAccess methodsFor: 'testing' stamp: ''!
isLiteralVariable
	^true! !

!IRMethod commentStamp: ''!
I am a method in the IR (intermediate representation) language consisting of IRInstructions grouped by IRSequence (basic block).  The IRSequences form a control graph (therefore I only have to hold onto the starting sequence).  #compiledMethod will convert me to a CompiledMethod.  #methodNode will convert me back to a parse tree.
!
!IRMethod methodsFor: 'decompiling' stamp: ''!
instructionsForDecompiling
	"return all instructions, but skip the block bodies, as the decompiler
	recurses over blocks"
	
	^startSequence instructionsForDecompiling allButFirst.! !

!IRMethod methodsFor: 'enumerating' stamp: ''!
allInstructionsMatching: aBlock
	" return irNodes as a flat collection "

	| irInstructions |
	irInstructions := OrderedCollection new.
	startSequence withAllSuccessorsDo: [:seq | seq do: [:bc | (aBlock value: bc) ifTrue: [irInstructions add: bc]]].
	^irInstructions! !

!IRMethod methodsFor: 'accessing' stamp: ''!
compilationContext: aCompilationContext
	compilationContext := aCompilationContext! !

!IRMethod methodsFor: 'accessing' stamp: ''!
numArgs

	^ numArgs! !

!IRMethod methodsFor: 'accessing' stamp: ''!
compilationContext
	^ compilationContext ifNil: [ 
		"only happens when decompiling or using stand-alone"
		compilationContext := CompilationContext default]! !

!IRMethod methodsFor: 'inlining' stamp: ''!
addInstructionsBefore: aCollection

	(self startSequence nextSequence first) addInstructionsBefore: aCollection.! !

!IRMethod methodsFor: 'inspector' stamp: ''!
children
	^self startSequence withAllSuccessors! !

!IRMethod methodsFor: 'accessing' stamp: ''!
numArgs: anInteger

	numArgs := anInteger! !

!IRMethod methodsFor: 'accessing' stamp: ''!
forceLongForm
	compilationContext ifNil: [ ^ false ].
	^compilationContext optionLongIvarAccessBytecodes! !

!IRMethod methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inpectionIr
	<inspectorPresentationOrder: 40 title: 'Symbolic'>

	^ SpTextPresenter new 
		text: (self ir longPrintString trimmed);
		yourself! !

!IRMethod methodsFor: 'scoping' stamp: ''!
indexForVarNamed: aName

	^tempMap at: aName! !

!IRMethod methodsFor: 'optimizing' stamp: ''!
optimize
	self removeEmptyStart.
	self compilationContext optionOptimizeIR ifFalse: [^self].
	self absorbJumpsToSingleInstrs! !

!IRMethod methodsFor: 'translating' stamp: ''!
generate: trailer
	
	| irTranslator |
   irTranslator := IRTranslator context: compilationContext trailer: trailer.
	irTranslator 
		visitNode: self;
		pragmas: pragmas.
	compiledMethod := irTranslator compiledMethod.
	self sourceNode 
		ifNotNil: [ 
			compiledMethod classBinding: self sourceNode methodClass binding.
			compiledMethod selector: self sourceNode selector ]
		ifNil: [ 
			compiledMethod classBinding: UndefinedObject binding.
			compiledMethod selector: #UndefinedMethod ].
	^ compiledMethod! !

!IRMethod methodsFor: 'inlining' stamp: ''!
addInstructionsAfter: aCollection
	| returningSeqs  lastInstr |
	aCollection ifEmpty: [^self].
	returningSeqs := self allSequences select: [:each | each last isReturn].
	lastInstr := returningSeqs last last.
	lastInstr addInstructionsBefore: aCollection.! !

!IRMethod methodsFor: 'accessing' stamp: ''!
addPragma: aPragma
	
	pragmas add: aPragma.! !

!IRMethod methodsFor: 'accessing' stamp: ''!
addAdditionalLiteral: aLiteral
	additionalLiterals add: aLiteral! !

!IRMethod methodsFor: 'translating' stamp: ''!
generate
	^self generate: CompiledMethodTrailer empty! !

!IRMethod methodsFor: 'printing' stamp: ''!
longPrintOn: stream

	IRPrinter new
		stream: stream;
		visitNode: self! !

!IRMethod methodsFor: 'accessing' stamp: ''!
sourceNode: aNode
	sourceNode := aNode! !

!IRMethod methodsFor: 'accessing' stamp: ''!
sourceInterval
	^self sourceNode sourceInterval! !

!IRMethod methodsFor: 'accessing' stamp: ''!
method
	^self.! !

!IRMethod methodsFor: 'accessing' stamp: ''!
addAdditionalLiterals: literals 
	additionalLiterals :=  literals! !

!IRMethod methodsFor: 'initialization' stamp: ''!
initialize

	irPrimitive := IRPrimitive null.
	tempMap := Dictionary new.
	pragmas := OrderedCollection new.
	additionalLiterals := OCLiteralSet new.
	numArgs := 0.! !

!IRMethod methodsFor: 'enumerating' stamp: ''!
allSequences
	^ startSequence withAllSuccessors! !

!IRMethod methodsFor: 'translating' stamp: ''!
generateBlock: trailer withScope: scope
	| irTranslator |
      irTranslator := IRTranslator context: compilationContext trailer: trailer.
	irTranslator 
		pushOuterVectors: scope;
		visitNode: self;
		pragmas: pragmas.
	compiledMethod := irTranslator compiledBlock.
	^ compiledMethod! !

!IRMethod methodsFor: 'accessing' stamp: ''!
irPrimitive

	^ irPrimitive! !

!IRMethod methodsFor: 'accessing' stamp: ''!
additionalLiterals
	^additionalLiterals! !

!IRMethod methodsFor: 'accessing' stamp: ''!
tempMap
	^ tempMap! !

!IRMethod methodsFor: 'accessing' stamp: ''!
sourceNode
	^sourceNode! !

!IRMethod methodsFor: 'accessing' stamp: ''!
irPrimitive: aPrimitiveNode

	irPrimitive := aPrimitiveNode! !

!IRMethod methodsFor: 'accessing' stamp: ''!
ir
	^self.! !

!IRMethod methodsFor: 'accessing' stamp: ''!
properties: propDict
	properties := propDict.! !

!IRMethod methodsFor: 'testing' stamp: ''!
isSend
	^false.! !

!IRMethod methodsFor: 'translating' stamp: ''!
compiledMethodWith: trailer

	^compiledMethod 
		ifNil: [self generate: trailer ]
		ifNotNil: [compiledMethod]! !

!IRMethod methodsFor: 'accessing' stamp: ''!
tempKeys

	^ tempMap keys! !

!IRMethod methodsFor: 'accessing' stamp: ''!
properties
	^properties! !

!IRMethod methodsFor: 'optimizing' stamp: ''!
removeEmptyStart

	 (startSequence size = 1) ifTrue: [
        "startSeq is just unconditional jump, forget it"
        startSequence := startSequence last destination].! !

!IRMethod methodsFor: 'optimizing' stamp: ''!
absorbJumpsToSingleInstrs

	startSequence absorbJumpToSingleInstr: IdentitySet new! !

!IRMethod methodsFor: 'initialize' stamp: ''!
startSequence: irSequence

	startSequence := irSequence.
	irSequence method: self.! !

!IRMethod methodsFor: 'accessing' stamp: ''!
predecessorsOf: aSequence
	| predecessors |
	predecessors := OrderedCollection new.
	self allSequences do: [:each | (each successorSequences includes: aSequence) ifTrue: [predecessors add: each]].
	^predecessors! !

!IRMethod methodsFor: 'enumerating' stamp: ''!
allTempAccessInstructions
	^self allInstructionsMatching: [:bc | bc isTemp].! !

!IRMethod methodsFor: 'enumerating' stamp: ''!
firstInstructionMatching: aBlock
	" return irNodes as a flat collection "

	startSequence withAllSuccessorsDo: [:seq | seq do: [:bc | (aBlock value: bc) ifTrue: [^bc]]].
	^nil! !

!IRMethod methodsFor: 'enumerating' stamp: ''!
allInstructions
	" return irNodes as a flat collection "

	| irInstructions |
	irInstructions := OrderedCollection new.
	startSequence withAllSuccessorsDo: [:seq | seq do: [:bc | irInstructions add: bc]].
	^irInstructions! !

!IRMethod methodsFor: 'translating' stamp: ''!
compiledMethod

	^ self compiledMethodWith: CompiledMethodTrailer empty! !

!IRMethod methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitMethod: self! !

!IRMethod methodsFor: 'translating' stamp: ''!
compiledBlock: scope

	^compiledMethod 
		ifNil: [self generateBlock: CompiledMethodTrailer empty withScope: scope ]
		ifNotNil: [compiledMethod]! !

!IRMethod methodsFor: 'accessing' stamp: ''!
startSequence

	^ startSequence! !

!IRPop commentStamp: ''!
Instruction "popTop"!
!IRPop methodsFor: 'testing' stamp: ''!
isPop
	^true! !

!IRPop methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPop: self! !

!IRPopIntoInstVar commentStamp: ''!
Pop into instance variable.!
!IRPopIntoInstVar methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPopIntoInstVar: self! !

!IRPopIntoLiteralVariable commentStamp: ''!
pop into literal variable!
!IRPopIntoLiteralVariable methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPopIntoLiteralVariable: self! !

!IRPopIntoRemoteTemp commentStamp: ''!
pop into remote temp!
!IRPopIntoRemoteTemp methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPopIntoRemoteTemp: self! !

!IRPopIntoTemp commentStamp: ''!
pop into temp!
!IRPopIntoTemp methodsFor: 'accessing' stamp: ''!
nextBytecodeOffsetAfterJump
	"if we are in to:do: answers the next byte code offset"
	^ self sequence last destination last destination first bytecodeOffset! !

!IRPopIntoTemp methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPopIntoTemp: self! !

!IRPrimitive commentStamp: ''!
I represent a primitive.  I am more than just a number if I am a named primitive.

Structure:

 num	<Integer>	Primitive number.
 spec	<Object>		Stored in first literal when num is 117 or 120.
!
!IRPrimitive methodsFor: 'printing' stamp: ''!
sourceText

	^ String streamContents: [:stream |
		self printPrimitiveOn: stream]! !

!IRPrimitive methodsFor: 'printing' stamp: ''!
printPrimitiveOn: aStream
	"Print the primitive on aStream"

	| primIndex primDecl |
	primIndex := primitiveNum.
	primIndex = 0
		ifTrue: [ ^ self ].
	primIndex = 120
		ifTrue: [ 
			"External call spec"
			^ aStream print: spec ].
	aStream nextPutAll: '<primitive: '.
	primIndex = 117
		ifTrue: [ 
			primDecl := spec.
			aStream
				nextPut: $';
				nextPutAll: primDecl second;
				nextPut: $'.
			primDecl first
				ifNotNil: [ 
					aStream
						nextPutAll: ' module: ';
						nextPut: $';
						nextPutAll: primDecl first;
						nextPut: $' ] ]
		ifFalse: [ aStream print: primIndex ].
	aStream nextPut: $>! !

!IRPrimitive methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: 'primitive '; print: primitiveNum! !

!IRPrimitive methodsFor: 'accessing' stamp: ''!
spec: literal

	spec := literal! !

!IRPrimitive methodsFor: 'accessing' stamp: ''!
spec

	^ spec! !

!IRPrimitive methodsFor: 'accessing' stamp: ''!
num: n

	primitiveNum := n! !

!IRPrimitive methodsFor: 'accessing' stamp: ''!
initializeFrom: aPragmaNode

	primitiveNum := 0.
	spec := Array 
		with: (aPragmaNode arguments second) name
		with: (aPragmaNode arguments first) name
		with: 0 with: 0.! !

!IRPrimitive methodsFor: 'accessing' stamp: ''!
num

	^ primitiveNum! !

!IRPrimitive class methodsFor: 'instance creation' stamp: ''!
null

	^ self new num: 0! !

!IRPrimitive class methodsFor: 'initialization' stamp: ''!
from: aPragmaNode

	^ self new initializeFrom: aPragmaNode! !

!IRPrinter commentStamp: ''!
I interpret IRMethod instructions and write them out to a print stream.!
!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPopIntoLiteralVariable: litVar
	
	| object |
	object := litVar association.
	stream nextPutAll: 'popIntoLiteralVariable: '.
	object isVariableBinding ifTrue: [^ stream nextPutAll: object key].
	object printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPopIntoTemp: tmp

	stream nextPutAll: 'popIntoTemp: '.
	tmp name printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitStoreTemp: tmp

   	stream nextPutAll: 'storeTemp: '.
	tmp name printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitSequence: instructionSequence
	self label: instructionSequence orderNumber.
	super visitSequence: instructionSequence! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPopIntoInstVar: instVar
	
	stream nextPutAll: 'popIntoInstVar: '.
	instVar index printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushFullClosure: fullBlock

	stream nextPutAll: 'pushFullBlock: '.
	stream nextPutAll: fullBlock compiledBlock printString.
	stream nextPutAll: ' numCopied: '.
	stream nextPutAll: fullBlock copiedValues size printString.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushArray: array
	
	array cons 
		ifTrue: [  
			stream nextPutAll: 'pushConsArray: ' ]
		ifFalse: [
			stream nextPutAll: 'pushNewArray: ' ].
	array size printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitJump: jump

	stream nextPutAll: 'goto: '.
	jump destination orderNumber printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitStoreInstVar: instVar
	stream nextPutAll: 'storeInstVar: '.
   instVar index printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitSend: send

	send superOf
		ifNil: [ stream nextPutAll: 'send: '.
			send selector printOn: stream. ]
		ifNotNil: [ :behavior | stream nextPutAll: 'send: '.
			send selector printOn: stream.
			stream nextPutAll: ' toSuperOf: '.
			behavior printOn: stream ]! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitStoreLiteralVariable: var

	| object |
	object := var association.
	stream nextPutAll: 'storeLiteralVariable: '.
	object isVariableBinding ifTrue: [^ stream nextPutAll: object key].
	object printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushTemp: tmp

	stream nextPutAll: 'pushTemp: '.
	tmp name printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushDup: dup
	
	stream nextPutAll: 'pushDup'! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitTempVector: tempVector

	stream nextPutAll: 'createTempVectorNamed: '.
	tempVector name printOn: stream.
	stream nextPutAll: ' withVars: '.
	stream nextPutAll: tempVector vars printString.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushLiteral: lit

	| object |
	object := lit literal.
	stream nextPutAll: 'pushLiteral: '.
	object isVariableBinding ifTrue: [^ stream nextPutAll: object key].
	object printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushRemoteTemp: remoteTemp

	stream nextPutAll: 'pushRemoteTemp: '.
	remoteTemp name printOn: stream.
	stream nextPutAll: ' inVector: '.
	remoteTemp tempVectorName printOn: stream! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitReturnInstVar: instVar
	stream nextPutAll: 'returnInstVar: '.
   instVar index printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitStoreRemoteTemp: remoteTemp
	stream nextPutAll: 'storeRemoteTemp: '.
	remoteTemp name printOn: stream.
	stream nextPutAll: ' inVector: '.
	remoteTemp tempVectorName printOn: stream.! !

!IRPrinter methodsFor: 'private' stamp: ''!
label: seqNum

	"add tab and cr since this does not get called within interpretInstruction:"
	stream cr.  "extra cr just to space out sequences"
	stream nextPutAll: 'label: '.
	seqNum printOn: stream.
	stream cr.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitBlockReturnTop: blockReturnTop

	stream nextPutAll: 'blockReturnTop'.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitReturnReceiver: receiver

	stream nextPutAll: 'returnReceiver'! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushThisContext: ctxt

	stream nextPutAll: 'pushThisContext'! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitReturnLiteral: lit

	| object |
	object := lit literal.
	stream nextPutAll: 'returnLiteral: '.
	object isVariableBinding ifTrue: [^ stream nextPutAll: object key].
	object printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushThisProcess: pushThisProcess

	stream nextPutAll: 'pushThisProcess'! !

!IRPrinter methodsFor: 'private' stamp: ''!
stream: stringWriteStream

	stream := stringWriteStream! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPop: pop

	stream nextPutAll: 'popTop'! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushReceiver: receiver

	stream nextPutAll: 'pushReceiver'! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushInstVar: instVar
	
	stream nextPutAll: 'pushInstVar: '.
	instVar index printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitJumpIf: jumpIf

	stream nextPutAll: 'if: '.
	jumpIf boolean printOn: stream.
	stream nextPutAll: ' goto: '.
	jumpIf destination orderNumber printOn: stream.
	stream nextPutAll: ' else: '.
	jumpIf otherwise orderNumber printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPopIntoRemoteTemp: remoteTemp

	stream nextPutAll: 'popIntoRemoteTemp: '.
	remoteTemp name printOn: stream.
	stream nextPutAll: ' inVector: '.
	remoteTemp tempVectorName printOn: stream! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitReturn: ret
	
	stream nextPutAll: 'returnTop'.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitPushLiteralVariable: var
	
	| object |
	object := var association.
	stream nextPutAll: 'pushLiteralVariable: '.
	object isVariableBinding ifTrue: [^ stream nextPutAll: object key].
	object printOn: stream.! !

!IRPrinter methodsFor: 'visiting' stamp: ''!
visitInstruction: aNode
	self visitNode: aNode.
	stream cr.! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testPushTempTemp
	| ir |
	ir := IRBuilderTest new testPushTempTemp.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushTemp: #a
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testLiteralArray
	| ir |
	ir := IRBuilderTest new testLiteralArray.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
returnLiteral: #(#test 4 #you)
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testJumpBackTo
	| ir |
	ir := IRBuilderTest new testJumpBackTo.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushReceiver
pushLiteral: false
goto: 2

label: 2
if: true goto: 4 else: 3

label: 3
pushLiteral: true
goto: 2

label: 4
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testPushThisContext
	| ir |
	ir := IRBuilderTest new testPushThisContext.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushThisContext
send: #receiver
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testPopTop
	| ir |
	ir := IRBuilderTest new testPopTop.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushReceiver
pushLiteral: false
popTop
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testPushNewArray
	| ir |
	ir := IRBuilderTest new testPushNewArray.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushNewArray: 1
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testReturnTop
	| ir |
	ir := IRBuilderTest new testReturnTop.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
returnLiteral: false
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testSendSuper
	| ir |
	ir := IRBuilderTest new testSendSuper.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushReceiver
send: #isThisEverCalled toSuperOf: IRBuilderTest
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testStoreIntoVariable
	| ir |
	ir := IRBuilderTest new testStoreIntoVariable.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushLiteral: 4
storeLiteralVariable: TestToPush
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testDup
	| ir |
	ir := IRBuilderTest new testDup.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushLiteral: 3
pushDup
send: #=
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testInstVar
	| ir |
	ir := IRBuilderTest new testInstVar.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushInstVar: 1
pushInstVar: 2
send: #+
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testPushConsArray
	| ir |
	ir := IRBuilderTest new testPushConsArray.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushReceiver
pushConsArray: 1
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testLiteralVariableClass
	| ir |
	ir := IRBuilderTest new testLiteralVariableClass.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushLiteralVariable: Object
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testPushSelf
	| ir |
	ir := IRBuilderTest new testPushSelf.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushReceiver
send: #class
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testPushTempArgument
	| ir |
	ir := IRBuilderTest new testPushTempArgument.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushTemp: #a
pushTemp: #b
send: #+
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testJumpAheadToIf
	| ir |
	ir := IRBuilderTest new testJumpAheadToIf.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushReceiver
pushLiteral: true
if: true goto: 3 else: 2

label: 2
returnTop

label: 3
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testStoreTemp
	| ir |
	ir := IRBuilderTest new testStoreTemp.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushLiteral: 34
popIntoTemp: #a
pushTemp: #a
returnTop
'! !

!IRPrinterTest methodsFor: 'tests' stamp: ''!
testJumpAheadTo
	| ir |
	ir := IRBuilderTest new testJumpAheadTo.
	self
		assert: ir longPrintString
		equals:
			'
label: 1
pushLiteral: 2
pushLiteral: 1
send: #+
goto: 2

label: 2
returnTop
'! !

!IRPushArray commentStamp: ''!
I model the pushArray bytecode.

Used for setting up the temp vectors and for the brace array construct: { }.!
!IRPushArray methodsFor: 'accessing' stamp: ''!
cons
	^ cons! !

!IRPushArray methodsFor: 'initialization' stamp: ''!
initialize
	size := 0.
	cons := false.! !

!IRPushArray methodsFor: 'accessing' stamp: ''!
size: aSmallInteger 
	size := aSmallInteger! !

!IRPushArray methodsFor: 'accessing' stamp: ''!
size 
	^ size! !

!IRPushArray methodsFor: 'accessing' stamp: ''!
cons: aBool
	cons := aBool.! !

!IRPushArray methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushArray: self! !

!IRPushDup commentStamp: ''!
Instruction "pushDup"!
!IRPushDup methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushDup: self! !

!IRPushFullClosure commentStamp: ''!
I represent the creation and the push on stack of a FullBlockClosure.

!
!IRPushFullClosure methodsFor: 'accessing' stamp: ''!
copiedValues: anObject
	copiedValues := anObject! !

!IRPushFullClosure methodsFor: 'accessing' stamp: ''!
copiedValues
	^ copiedValues! !

!IRPushFullClosure methodsFor: 'debugging' stamp: ''!
indexForVarNamed: aName
	^ sourceNode ir indexForVarNamed: aName! !

!IRPushFullClosure methodsFor: 'scoping' stamp: ''!
remapCopiedValueAt: index oldOne: aTemp newOne: aRemote 

	self copiedValues at: index put: aRemote.! !

!IRPushFullClosure methodsFor: 'accessing' stamp: ''!
compiledBlock: anObject
	compiledBlock := anObject! !

!IRPushFullClosure methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushFullClosure: self! !

!IRPushFullClosure methodsFor: 'accessing' stamp: ''!
compiledBlock
	^ compiledBlock! !

!IRPushInstVar commentStamp: ''!
push inst var!
!IRPushInstVar methodsFor: 'accessing' stamp: ''!
quickRetNode
	^ IRReturnInstVar new
		index: index;
		yourself! !

!IRPushInstVar methodsFor: 'testing' stamp: ''!
canBeQuickReturn
	^ true! !

!IRPushInstVar methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushInstVar: self! !

!IRPushLiteral commentStamp: ''!
Instruction "pushLiteral: object"!
!IRPushLiteral methodsFor: 'testing' stamp: ''!
isPushLiteral: valueTest
	^ valueTest value: literal! !

!IRPushLiteral methodsFor: 'accessing' stamp: ''!
literal: object

	literal := object! !

!IRPushLiteral methodsFor: 'accessing' stamp: ''!
literal

	^ literal! !

!IRPushLiteral methodsFor: 'accessing' stamp: ''!
quickRetNode
	^ IRReturnLiteral new
		literal: literal;
		yourself! !

!IRPushLiteral methodsFor: 'testing' stamp: ''!
isPushLiteral

	^ true! !

!IRPushLiteral methodsFor: 'testing' stamp: ''!
canBeQuickReturn
	^ true! !

!IRPushLiteral methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushLiteral: self! !

!IRPushLiteralVariable commentStamp: ''!
push literal variable!
!IRPushLiteralVariable methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushLiteralVariable: self! !

!IRPushReceiver commentStamp: ''!
I am modelling the push self bytecode!
!IRPushReceiver methodsFor: 'accessing' stamp: ''!
quickRetNode
	^ IRReturnReceiver new! !

!IRPushReceiver methodsFor: 'testing' stamp: ''!
isSelf
	^true! !

!IRPushReceiver methodsFor: 'testing' stamp: ''!
canBeQuickReturn
	^ true! !

!IRPushReceiver methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushReceiver: self! !

!IRPushRemoteTemp commentStamp: ''!
push remote temp!
!IRPushRemoteTemp methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushRemoteTemp: self! !

!IRPushTemp commentStamp: ''!
push temp!
!IRPushTemp methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushTemp: self! !

!IRPushThisContext commentStamp: ''!
I model push thisContext bytecode!
!IRPushThisContext methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushThisContext: self! !

!IRPushThisProcess methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitPushThisProcess: self! !

!IRReconstructor commentStamp: ''!
I am a specialized IRBuilder for the decompiler!
!IRReconstructor methodsFor: 'initialize' stamp: ''!
createTempVectorNamed: name withVars: anArray
	" Don't add the temp yet, we only know it's index at the end of the block or method "
	"self addVectorTemps: anArray"
	" Update the byte index to point before the pushing of the new vector "
	sourceMapByteIndex := sourceMapByteIndex - 2.
	self add: (IRInstruction createTempVectorNamed: name withVars: anArray)! !

!IRReconstructor methodsFor: 'initialization' stamp: ''!
initialize
	temps := Dictionary new.
	remoteTemps := Dictionary new.
	closureCopiedValues := Dictionary new.
	sourceMapByteIndex := 0.
	super initialize.! !

!IRReconstructor methodsFor: 'remapping' stamp: ''!
rememberReference: anInstruction to: name in: dictionary
	(dictionary at: name ifAbsentPut: [ OrderedCollection new ])
		add: anInstruction! !

!IRReconstructor methodsFor: 'instructions' stamp: ''!
pushRemoteTemp: name inVector: nameOfVector
	| anInstruction |
	anInstruction := super pushRemoteTemp: name inVector: nameOfVector.
	self rememberReference: anInstruction to: nameOfVector in: remoteTemps.! !

!IRReconstructor methodsFor: 'instructions' stamp: ''!
pushTemp: aSelector
	| anInstruction |
	anInstruction := super pushTemp: aSelector.
	self rememberReference: anInstruction to: aSelector in: temps.! !

!IRReconstructor methodsFor: 'instructions' stamp: ''!
storeTemp: aSelector
	| anInstruction |
	anInstruction := super storeTemp: aSelector.
	self rememberReference: anInstruction to: aSelector in: temps.! !

!IRReconstructor methodsFor: 'remapping' stamp: ''!
remapTemp: aTemp toRemote: aRemote
	(temps removeKey: aTemp ifAbsent: [ #() ])
		do: [ :tempAccess |
			tempAccess name: aRemote.
			self rememberReference: tempAccess to: aRemote in: temps ].
		
	(remoteTemps removeKey: aTemp ifAbsent: [ #() ])
		do: [ :tempAccess |
			tempAccess tempVectorName: aRemote.
			self rememberReference: tempAccess to: aRemote in: remoteTemps. ].

	(closureCopiedValues removeKey: aTemp ifAbsent: [ #() ])
		do: [ :aClosureAndIndex | |closure index|
			closure := aClosureAndIndex key.
			index := aClosureAndIndex value.
			closure remapCopiedValueAt: index oldOne: aTemp newOne: aRemote.
			self rememberReference: aClosureAndIndex to: aRemote in: closureCopiedValues. ].! !

!IRReconstructor methodsFor: 'instructions' stamp: ''!
pushFullClosureCompiledBlock: compiledBlock copiedValues: copiedValues
	| anInstruction |
	anInstruction := super pushFullClosureCompiledBlock: compiledBlock copiedValues: copiedValues.

	anInstruction copiedValues withIndexDo: [ :aValue :index |
		self rememberReference: anInstruction -> index to: aValue in: closureCopiedValues ]! !

!IRReconstructor methodsFor: 'accessing' stamp: ''!
currentSequence: aSeq
	currentSequence := aSeq! !

!IRReconstructor methodsFor: 'instructions' stamp: ''!
blockReturnTop
	self fixPushNilsForTemps.
	^ super blockReturnTop! !

!IRReconstructor methodsFor: 'accessing' stamp: ''!
currentSequence
	^currentSequence! !

!IRReconstructor methodsFor: 'testing' stamp: ''!
isLastClosureInstruction
	| nextJumps |
	nextJumps := jumpAheadStacks at: sourceMapByteIndex + 1 ifAbsent: [ ^ false ].
	^ nextJumps anySatisfy: [ :anOrigin | anOrigin = self currentScope ]! !

!IRReconstructor methodsFor: 'removing' stamp: ''!
fixPushNilsForTemps
	" There are pushConstant: nil in the beginning of the blocksequence for all of the defined temps.
	  We got these pushConstant: nil in. Now our closure will generate them again, meaning we will double
	  the number of pushConstant: nil in the final block. To avoid this, we strip the ones we got in from the IR.  "

	| blocksequence |
	blocksequence := self currentScope blockSequence sequence.
	self currentScope definedTemps do: [ :temp | blocksequence removeFirst ].! !

!IRReconstructor methodsFor: 'removing' stamp: ''!
removeLast: n
	" Make the address of the instruction be the address of the first removed instruction. "
	sourceMapByteIndex := sourceMapByteIndex - n.
	^ (currentSequence removeLast: n) collect: [ :node |
		node isTemp ifFalse: [ self error: 'Should only remove temp accesses!!' ].
		node name ]! !

!IRReconstructor methodsFor: 'instructions' stamp: ''!
storeRemoteTemp: name inVector: nameOfVector
	| anInstruction |
	anInstruction := super storeRemoteTemp: name inVector: nameOfVector.
	self rememberReference: anInstruction to: nameOfVector in: remoteTemps.! !

!IRRemoteArray commentStamp: ''!
I model the TempVector for the decompiler!
!IRRemoteArray methodsFor: 'enumerating' stamp: ''!
indexOf: anInteger
	^anInteger + 1.! !

!IRRemoteArray methodsFor: 'accessing' stamp: ''!
size: aSize
	size := aSize! !

!IRRemoteArray methodsFor: 'accessing' stamp: ''!
size
	^ size! !

!IRRemoteArray methodsFor: 'enumerating' stamp: ''!
do: aBlock
	1 to: size do: [ :idx | aBlock value: (idx - 1) ]! !

!IRRemoteArray methodsFor: 'accessing' stamp: ''!
index: anIndex
	index := anIndex! !

!IRRemoteArray methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!IRRemoteTempAccess commentStamp: ''!
I model the pushRemoteTemporary Bytecode!
!IRRemoteTempAccess methodsFor: 'accessing' stamp: ''!
tempVectorName
	^ tempVectorName! !

!IRRemoteTempAccess methodsFor: 'accessing' stamp: ''!
tempVectorName: anObject
	tempVectorName := anObject! !

!IRRemoteTempAccess methodsFor: 'testing' stamp: ''!
isRemoteTemp
	^ true! !

!IRReturn commentStamp: ''!
Instruction "returnTop"!
!IRReturn methodsFor: 'accessing' stamp: ''!
nonBodySuccessorSequences
	^#()! !

!IRReturn methodsFor: 'testing' stamp: ''!
isReturn

	^ true! !

!IRReturn methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitReturn: self! !

!IRReturnInstVar commentStamp: ''!
specific node when returning an inst var!
!IRReturnInstVar methodsFor: 'accessing' stamp: ''!
index: anObject
	index := anObject! !

!IRReturnInstVar methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitReturnInstVar: self! !

!IRReturnInstVar methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!IRReturnLiteral commentStamp: ''!
specific node when returning a constant!
!IRReturnLiteral methodsFor: 'accessing' stamp: ''!
literal: anObject
	literal := anObject! !

!IRReturnLiteral methodsFor: 'accessing' stamp: ''!
literal
	^ literal! !

!IRReturnLiteral methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitReturnLiteral: self! !

!IRReturnReceiver commentStamp: ''!
specific node when returning self!
!IRReturnReceiver methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitReturnReceiver: self! !

!IRSend commentStamp: ''!
Instruction "send: selector" or "send: selector toSuperOf: behavior"!
!IRSend methodsFor: 'accessing' stamp: ''!
selector
	^selector! !

!IRSend methodsFor: 'accessing' stamp: ''!
superOf

	^ superOf! !

!IRSend methodsFor: 'testing' stamp: ''!
isSuperSend
    ^superOf notNil! !

!IRSend methodsFor: 'accessing' stamp: ''!
selector: symbol

	selector := symbol! !

!IRSend methodsFor: 'testing' stamp: ''!
isSend
	^true.! !

!IRSend methodsFor: 'accessing' stamp: ''!
superOf: behavior

	superOf := behavior! !

!IRSend methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitSend: self! !

!IRSequence commentStamp: ''!
A sequence is corresponds to a block in the control flow graph.!
!IRSequence methodsFor: 'successor sequences' stamp: ''!
withNonBodySuccessorsDo: block
	"Iterate over me and all my successors only once"

	self withNonBodySuccessorsDo: block alreadySeen: IdentitySet new! !

!IRSequence methodsFor: 'removing' stamp: ''!
removeFirst
	^sequence removeFirst.! !

!IRSequence methodsFor: 'enumerating' stamp: ''!
reverseDo: aBlock
	^sequence reverseDo: aBlock.! !

!IRSequence methodsFor: 'inspector' stamp: ''!
children
	^sequence! !

!IRSequence methodsFor: 'accessing' stamp: ''!
after: o
	^sequence after: o! !

!IRSequence methodsFor: 'accessing' stamp: ''!
orderNumber: num
	"Sequences are sorted by this number"
	orderNumber := num.! !

!IRSequence methodsFor: 'adding' stamp: ''!
add: instr before: another
	sequence add: instr before: another.
	instr sequence: self.
	^instr.! !

!IRSequence methodsFor: 'enumerating' stamp: ''!
do: aBlock
	^sequence do: aBlock.! !

!IRSequence methodsFor: 'accessing' stamp: ''!
last
	^sequence last! !

!IRSequence methodsFor: 'removing' stamp: ''!
removeLast: n
	^sequence removeLast: n.! !

!IRSequence methodsFor: 'successor sequences' stamp: ''!
withAllSuccessors
	"Return me and all my successors sorted by sequence orderNumber"

	| list |
	list := OrderedCollection new: 20.
	self withAllSuccessorsDo: [:seq | list add: seq].
	^ list asSortedCollection: [:x :y | x orderNumber <= y orderNumber]! !

!IRSequence methodsFor: 'adding' stamp: ''!
addLast: anInstruction
	^self add: anInstruction.! !

!IRSequence methodsFor: 'accessing' stamp: ''!
orderNumber
	"Sequences are sorted by this number"

	^ orderNumber! !

!IRSequence methodsFor: 'inspector' stamp: ''!
sourceInterval
	^self sequence first sourceInterval first to: self sequence last sourceInterval last! !

!IRSequence methodsFor: 'initialization' stamp: ''!
initialize
	sequence := OrderedCollection new.! !

!IRSequence methodsFor: 'optimizing' stamp: ''!
absorbJumpToSingleInstr: alreadySeen
	"Collapse jumps to single return instructions into caller"

	| seqs seq |
	(alreadySeen includes: self) ifTrue: [^ self].
	alreadySeen add: self.
	[ (seqs := self successorSequences) size = 1  "unconditional jump..." 
	   and: [((seq := seqs first) size = 1)  "...to single instruction..."
	    and: [seq successorSequences size < 2
		and: [self last isBlockReturnTop not
		  and: [((seq sequence size = 1) and: [(seq sequence first isBlockReturnTop) or: [seq sequence first isReturn]]) not]]]]"...but don't collapse conditional jumps so their otherwiseSequences can stay right after them"
	] whileTrue: [ "replace goto with single instruction"
		self removeLast.
		seq do: [:instr |  self add: instr copy].
	].

	seqs do: [:instrs | instrs ifNotNil: [:i | i absorbJumpToSingleInstr: alreadySeen]].! !

!IRSequence methodsFor: 'manipulating' stamp: ''!
splitAfter: instruction

	| newSeq index next |
	next := self nextSequence.
	next := next
		ifNil: [self orderNumber + 1]
		ifNotNil: [(next orderNumber + self orderNumber) / 2].
	newSeq := self class new orderNumber: next.
	newSeq method: self method.
	"Split after instruction"
	index := sequence indexOf: instruction.
	(sequence last: sequence size - index) do: [:instr | newSeq add: instr].
	sequence := sequence first: index.
	self flag: 'The jump inherits the bytecode index from the instruction where it was split. Check if this value is correct.'.
	self add: (IRJump new destination: newSeq; bytecodeIndex: (instruction bytecodeIndex + 1)).
	^ newSeq! !

!IRSequence methodsFor: 'adding' stamp: ''!
add: instr after: another

	sequence add: instr after: another.
	instr sequence: self.
	^instr.! !

!IRSequence methodsFor: 'accessing' stamp: ''!
size
	^sequence size.! !

!IRSequence methodsFor: 'adding' stamp: ''!
addInstructions: aCollection before: anInstruction

	aCollection do: [:instr | self add: instr before: anInstruction].! !

!IRSequence methodsFor: 'accessing' stamp: ''!
method: aIRMethod

	method := aIRMethod! !

!IRSequence methodsFor: 'testing' stamp: ''!
notEmpty
	^sequence notEmpty! !

!IRSequence methodsFor: 'successor sequences' stamp: ''!
successorSequences

	sequence isEmpty ifTrue: [^ #()].
	^ sequence last successorSequences! !

!IRSequence methodsFor: 'accessing' stamp: ''!
sequence
	^sequence! !

!IRSequence methodsFor: 'testing' stamp: ''!
ifNotEmpty: aBlock
	^sequence ifNotEmpty: aBlock! !

!IRSequence methodsFor: 'successor sequences' stamp: ''!
instructionsForDecompiling

	| irInstructions |
	irInstructions := OrderedCollection new.
	self withNonBodySuccessorsDo: [:seq | seq do: [:bc | irInstructions add: bc]].
	^irInstructions! !

!IRSequence methodsFor: 'enumerating' stamp: ''!
contains: aBlock
	^sequence contains: aBlock.! !

!IRSequence methodsFor: 'testing' stamp: ''!
isEmpty
	^sequence isEmpty! !

!IRSequence methodsFor: 'successor sequences' stamp: ''!
withNonBodySuccessorsDo: block alreadySeen: set
	"Iterate over me and all my successors only once"

	(set includes: self) ifTrue: [^ self].
	set add: self.
	block value: self.
	self nonBodySuccessorSequences do: [:seq |
		seq ifNotNil: [seq withNonBodySuccessorsDo: block alreadySeen: set]].! !

!IRSequence methodsFor: 'adding' stamp: ''!
add: anInstruction

	sequence add: anInstruction.
	anInstruction sequence: self.
	^anInstruction.! !

!IRSequence methodsFor: 'successor sequences' stamp: ''!
withAllSuccessorsDo: block alreadySeen: set
	"Iterate over me and all my successors only once"

	(set includes: self) ifTrue: [^ self].
	set add: self.
	block value: self.
	self successorSequences do: [:seq |
		seq ifNotNil: [seq withAllSuccessorsDo: block alreadySeen: set]].! !

!IRSequence methodsFor: 'enumerating' stamp: ''!
select: aBlock
	^sequence select: aBlock.! !

!IRSequence methodsFor: 'successor sequences' stamp: ''!
nextSequence

	| sequences i |
	sequences := self withAllSuccessors.
	i := sequences findFirst: [:seq | seq orderNumber = self orderNumber].
	(i = 0 or: [i = sequences size]) ifTrue: [^ nil].
	^ sequences at: i + 1! !

!IRSequence methodsFor: 'printing' stamp: ''!
printOn: stream

	stream nextPutAll: 'an '.
	self class printOn: stream.
	stream space.
	stream nextPut: $(.
	self orderNumber printOn: stream.
	stream nextPut: $).! !

!IRSequence methodsFor: 'accessing' stamp: ''!
at: index
	^sequence at: index! !

!IRSequence methodsFor: 'accessing' stamp: ''!
first
	^sequence first! !

!IRSequence methodsFor: 'replacing' stamp: ''!
remove: aNode
	aNode sequence: nil.
	sequence remove: aNode ifAbsent: [self error].! !

!IRSequence methodsFor: 'successor sequences' stamp: ''!
withAllSuccessorsDo: block
	"Iterate over me and all my successors only once"

	self withAllSuccessorsDo: block alreadySeen: IdentitySet new! !

!IRSequence methodsFor: 'adding' stamp: ''!
addInstructions: aCollection
	
	^aCollection do: [:instr | self add: instr].! !

!IRSequence methodsFor: 'testing' stamp: ''!
ifEmpty: aBlock
	^sequence ifEmpty: aBlock! !

!IRSequence methodsFor: 'removing' stamp: ''!
removeLast
	^sequence removeLast.! !

!IRSequence methodsFor: 'printing' stamp: ''!
longPrintOn: stream

	[IRPrinter new
		stream: stream;
		visitNode: self
	] onDNU: #orderNumber do: [:ex | ex resume: ex receiver]! !

!IRSequence methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNodes: aCollection 

	self addInstructions: aCollection before: aNode.
	sequence remove: aNode ifAbsent: [self error].! !

!IRSequence methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 

	| index |
	index := sequence indexOf: aNode ifAbsent: [ self error ].
	sequence at: index put: (anotherNode sequence: self).! !

!IRSequence methodsFor: 'accessing' stamp: ''!
method

	^method! !

!IRSequence methodsFor: 'successor sequences' stamp: ''!
instructionsDo: aBlock

	^self withAllSuccessorsDo: [:seq | seq do: aBlock].! !

!IRSequence methodsFor: 'inspector' stamp: ''!
sourceNode
	"we should do better here"
	^RBSequenceNode new.! !

!IRSequence methodsFor: 'adding' stamp: ''!
addAllFirst: aCollection
	^sequence addAllFirst: aCollection.! !

!IRSequence methodsFor: 'successor sequences' stamp: ''!
nonBodySuccessorSequences

	sequence isEmpty ifTrue: [^ #()].
	^ sequence last nonBodySuccessorSequences! !

!IRSequence methodsFor: 'copying' stamp: ''!
, otherCollection 
	^sequence, otherCollection! !

!IRSequence methodsFor: 'adding' stamp: ''!
addAll: aCollection
	^sequence addAll: aCollection! !

!IRSequence methodsFor: 'adding' stamp: ''!
addInstructions: aCollection after: anInstruction
	
	^aCollection reverseDo: [:instr | self add: instr after: anInstruction].! !

!IRSequence methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitSequence: self! !

!IRSequence methodsFor: 'enumerating' stamp: ''!
detect: aBlock
	^sequence detect: aBlock! !

!IRSequence class methodsFor: 'instance creation' stamp: ''!
orderNumber: aNumber
	^self new orderNumber: aNumber! !

!IRStackCount commentStamp: ''!
This keeps track of the stack count for the BytecodeGenerator.!
!IRStackCount methodsFor: 'results' stamp: ''!
position

	^position! !

!IRStackCount methodsFor: 'results' stamp: ''!
linkTo: stackOrNil

	stackOrNil ifNil: [^  self class newOn: self].
	^ self position = stackOrNil start
		ifTrue: [stackOrNil]
		ifFalse: [self error: 'stack out of sync in bytecode generator']! !

!IRStackCount methodsFor: 'comparing' stamp: ''!
= other

	^ self class == other class 
	  and: [start = other start
	  and: [position = other position
	  and: [length = other size]]]! !

!IRStackCount methodsFor: 'comparing' stamp: ''!
hash

	^ position hash bitXor: (length hash bitXor: start hash)! !

!IRStackCount methodsFor: 'initialize' stamp: ''!
startAt: pos

	start := position := length := pos! !

!IRStackCount methodsFor: 'affecting' stamp: ''!
push
	^ self push: 1! !

!IRStackCount methodsFor: 'printing' stamp: ''!
printOn: aStream
	
	super printOn: aStream.
	aStream
		nextPutAll: ' start '; print: start;
		nextPutAll: ' stop '; print: position;
		nextPutAll: ' max '; print: length.! !

!IRStackCount methodsFor: 'results' stamp: ''!
size

	^length! !

!IRStackCount methodsFor: 'affecting' stamp: ''!
pop

	^ self pop: 1! !

!IRStackCount methodsFor: 'affecting' stamp: ''!
push: n
	(position := position + n) > length 
		ifTrue: [length := position]! !

!IRStackCount methodsFor: 'results' stamp: ''!
length

	^length! !

!IRStackCount methodsFor: 'affecting' stamp: ''!
pop: n

	(position := position - n) < 0 
		ifTrue: [self error: 'stack underflow in bytecode generator']! !

!IRStackCount methodsFor: 'results' stamp: ''!
start

	^ start! !

!IRStackCount class methodsFor: 'instance creation' stamp: ''!
new

	^ super new startAt: 0! !

!IRStackCount class methodsFor: 'instance creation' stamp: ''!
newOn: stack

	^ self startAt: stack position! !

!IRStackCount class methodsFor: 'instance creation' stamp: ''!
startAt: pos

	^ self new startAt: pos! !

!IRStoreInstVar commentStamp: ''!
store inst var!
!IRStoreInstVar methodsFor: 'testing' stamp: ''!
isStore
	^ true! !

!IRStoreInstVar methodsFor: 'accessing' stamp: ''!
popIntoNode
	^ IRPopIntoInstVar new
		index: index; 
		yourself! !

!IRStoreInstVar methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitStoreInstVar: self! !

!IRStoreLiteralVariable commentStamp: ''!
store literal variable!
!IRStoreLiteralVariable methodsFor: 'testing' stamp: ''!
isStore
	^ true! !

!IRStoreLiteralVariable methodsFor: 'accessing' stamp: ''!
popIntoNode
	^ IRPopIntoLiteralVariable new
		association: association;
		yourself! !

!IRStoreLiteralVariable methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitStoreLiteralVariable: self! !

!IRStoreRemoteTemp commentStamp: ''!
store remote temp!
!IRStoreRemoteTemp methodsFor: 'testing' stamp: ''!
isStore
	^ true! !

!IRStoreRemoteTemp methodsFor: 'accessing' stamp: ''!
popIntoNode
	^ IRPopIntoRemoteTemp new
		name: name;
		tempVectorName: tempVectorName;
		yourself! !

!IRStoreRemoteTemp methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitStoreRemoteTemp: self! !

!IRStoreTemp commentStamp: ''!
store temp!
!IRStoreTemp methodsFor: 'testing' stamp: ''!
isStore
	^ true! !

!IRStoreTemp methodsFor: 'accessing' stamp: ''!
popIntoNode
	^ IRPopIntoTemp new
		name: name;
		yourself! !

!IRStoreTemp methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitStoreTemp: self! !

!IRTempAccess commentStamp: ''!
I model the pushTemporary Bytecode!
!IRTempAccess methodsFor: 'accessing' stamp: ''!
name

	^name! !

!IRTempAccess methodsFor: 'accessing' stamp: ''!
name: aString
	name := aString! !

!IRTempAccess methodsFor: 'testing' stamp: ''!
isRemoteTemp
	^ false! !

!IRTempAccess methodsFor: 'testing' stamp: ''!
isTemp
	^true.! !

!IRTempVector commentStamp: ''!
I model the tempVector.

The tempvector is an array that stores all escaping variables of a block that are written to from outside.!
!IRTempVector methodsFor: 'accessing' stamp: ''!
vars: anObject
	vars := anObject.! !

!IRTempVector methodsFor: 'accessing' stamp: ''!
indexForVarNamed: aName
	^vars indexOf: aName! !

!IRTempVector methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!IRTempVector methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!IRTempVector methodsFor: 'accessing' stamp: ''!
vars
	^ vars! !

!IRTempVector methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitTempVector: self! !

!IRTempVector methodsFor: 'testing' stamp: ''!
isTempVector
	^true! !

!IRTransformTest methodsFor: 'tests - adding' stamp: ''!
testDelete
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 1;
		pushLiteral: 2;
		returnTop;
		ir.
	(iRMethod allSequences last
		detect: [ :each | each isPushLiteral: [ :c | c == 2 ] ]) delete.
	aCompiledMethod := iRMethod compiledMethod.
	self
		assert: (aCompiledMethod valueWithReceiver: nil arguments: #())
		equals: 1! !

!IRTransformTest methodsFor: 'tests - enumeration' stamp: ''!
testAllInstructions
		| ir |

		ir := IRBuilderTest new testPushTempTemp.
		self assert: ir allInstructions last isReturn.! !

!IRTransformTest methodsFor: 'tests - adding' stamp: ''!
testAddIntructionsBeforeFromLList
	| iRMethod aCompiledMethod push llist col |
	iRMethod := IRBuilder new
		pushLiteral: 1;
		returnTop;
		ir.
	push := iRMethod allSequences last at: 1.
	llist := LinkedList new.
	llist add: (IRInstruction pushLiteral: 2).
	llist add: IRInstruction returnTop.
	col := llist asOrderedCollection.
	iRMethod allSequences last addInstructions: col before: push.
	aCompiledMethod := iRMethod compiledMethod.
	self
		assert: (aCompiledMethod valueWithReceiver: nil arguments: #())
		equals: 2! !

!IRTransformTest methodsFor: 'tests - adding' stamp: ''!
testAddIntructionsBefore
	| iRMethod aCompiledMethod push |
	iRMethod := IRBuilder new
		pushLiteral: 1;
		returnTop;
		ir.
	push := iRMethod allSequences last first.
	iRMethod allSequences last
		addInstructions:
			{(IRInstruction pushLiteral: 2).
			IRInstruction returnTop}
		before: push.
	aCompiledMethod := iRMethod compiledMethod.
	self
		assert: (aCompiledMethod valueWithReceiver: nil arguments: #())
		equals: 2! !

!IRTransformTest methodsFor: 'tests - adding' stamp: ''!
testAdd
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 1;
		returnTop;
		ir.
	iRMethod allSequences last last delete.
	iRMethod allSequences last last delete.
	iRMethod allSequences last add: (IRInstruction pushLiteral: 2).
	iRMethod allSequences last add: IRInstruction returnTop.
	aCompiledMethod := iRMethod compiledMethod.
	self
		assert: (aCompiledMethod valueWithReceiver: nil arguments: #())
		equals: 2! !

!IRTransformTest methodsFor: 'tests - adding' stamp: ''!
testAddBefore
	| iRMethod aCompiledMethod ret |
	iRMethod := IRBuilder new
		pushLiteral: 1;
		returnTop;
		ir.
	iRMethod allSequences last last delete.
	iRMethod allSequences last last delete.
	ret := IRInstruction returnTop.
	iRMethod allSequences last add: ret.
	iRMethod allSequences last
		add: (IRInstruction pushLiteral: 2)
		before: ret.
	aCompiledMethod := iRMethod compiledMethod.
	self
		assert: (aCompiledMethod valueWithReceiver: nil arguments: #())
		equals: 2! !

!IRTransformTest methodsFor: 'tests - enumeration' stamp: ''!
testAllTempAccessInstructions
	| ir |
	ir := IRBuilderTest new testPushTempTemp.
	self assert: ir allTempAccessInstructions size equals: 1! !

!IRTransformTest methodsFor: 'tests - adding' stamp: ''!
testReplace
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 1;
		returnTop;
		ir.
	iRMethod allSequences last first
		replaceWith: (IRInstruction pushLiteral: 2).
	aCompiledMethod := iRMethod compiledMethod.
	self
		assert: (aCompiledMethod valueWithReceiver: nil arguments: #())
		equals: 2! !

!IRTransformTest methodsFor: 'tests - adding' stamp: ''!
testReplaceInstr
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 1;
		returnTop;
		ir.
	iRMethod allSequences last first
		replaceWithInstructions: {(IRInstruction pushLiteral: 2)}.
	aCompiledMethod := iRMethod compiledMethod.
	self
		assert: (aCompiledMethod valueWithReceiver: nil arguments: #())
		equals: 2! !

!IRTransformTest methodsFor: 'tests - adding' stamp: ''!
testAddIntructions
	| iRMethod aCompiledMethod |
	iRMethod := IRBuilder new
		pushLiteral: 1;
		returnTop;
		ir.
	iRMethod allSequences last last delete.
	iRMethod allSequences last last delete.
	iRMethod allSequences last
		addInstructions:
			{(IRInstruction pushLiteral: 2).
			IRInstruction returnTop}.
	aCompiledMethod := iRMethod compiledMethod.
	self
		assert: (aCompiledMethod valueWithReceiver: nil arguments: #())
		equals: 2! !

!IRTranslator commentStamp: ''!
I visit IRMethod instructions, sending the appropriate bytecode messages to my BytecodeGenerator (gen). !
!IRTranslator methodsFor: 'results' stamp: ''!
compiledBlock
	^ gen compiledBlockWith: trailer! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPopIntoLiteralVariable: var

	gen storePopIntoLiteralVariable: var association! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPopIntoTemp: tmp

   	gen storePopTemp: (self currentScope indexForVarNamed: tmp name)! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitStoreTemp: tmp

   	gen storeTemp: (self currentScope indexForVarNamed: tmp name)! !

!IRTranslator methodsFor: 'accessing' stamp: ''!
compilationContext: aContext
	compilationContext := aContext.
	gen := compilationContext bytecodeGeneratorClass newWithEncoderClass: compilationContext encoderClass.
	gen compilationContext: aContext.! !

!IRTranslator methodsFor: 'results' stamp: ''!
pushOuterVectors: scope
	| scopesWithVector sc |
	scopesWithVector := OrderedCollection new.
	sc := scope.
	[ sc outerScope isBehavior ] whileFalse: [ 
		sc := sc outerScope.
		sc hasTempVector ifTrue: [ scopesWithVector add: sc ] ].
	scopesWithVector reverseDo: [ :scopeWithVector |
		tempVectorStack push: (IRInstruction 
			createTempVectorNamed: scopeWithVector tempVectorName
			withVars: scopeWithVector tempVectorVarNames)].
	gen inBlock: true.! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitSequence: instructionSequence
	self label: instructionSequence orderNumber.
	super visitSequence: instructionSequence! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPopIntoInstVar: instVar
	gen storePopInstVar: instVar index! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushArray: array

	array cons 
		ifTrue: [  
			gen pushConsArray: array size ]
		ifFalse: [
			gen pushNewArray: array size ]! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushFullClosure: fullBlock

	fullBlock copiedValues do: [:name | 	
		gen pushTemp: (self currentScope indexForVarNamed: name)].
	gen mapBytesTo: fullBlock.
	gen pushFullBlockClosure: fullBlock! !

!IRTranslator methodsFor: 'accessing' stamp: ''!
compilationContext
	^ compilationContext! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitJump: jump

	gen goto: jump destination orderNumber! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitStoreInstVar: instVar
	gen storeInstVar: instVar index! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitSend: send

	send superOf
		ifNil: [ gen send: send selector ]
		ifNotNil: [ :behavior |  gen send: send selector toSuperOf: behavior ]! !

!IRTranslator methodsFor: 'private' stamp: ''!
pushScope: anIRBlockOrMethod

	currentScope push: anIRBlockOrMethod! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitStoreLiteralVariable: var

	gen storeIntoLiteralVariable: var association! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitSequences:  irSequences
	irSequences withIndexDo: [ :seq :i | seq orderNumber: i].
	self visitNodes: irSequences.! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushDup: dup
	
	gen pushDup! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitTempVector: tempVector

	tempVectorStack push: tempVector.
	gen pushNewArray: tempVector vars size. 
	gen storePopTemp: (self currentScope indexForVarNamed: tempVector name)! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushTemp: tmp

	gen pushTemp: (self currentScope indexForVarNamed: tmp name)! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushRemoteTemp: remoteTemp
	| tempIndex tempVectorIndex tempVector |

	tempVector := tempVectorStack detect: [:each | each name = remoteTemp tempVectorName].
	tempVectorIndex := tempVector indexForVarNamed: remoteTemp name.
	tempIndex := self currentScope indexForVarNamed: remoteTemp tempVectorName.

	gen pushRemoteTemp: tempVectorIndex inVectorAt: tempIndex! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitReturnInstVar: instVar

	gen returnInstVar: instVar index! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushLiteral: lit
	^ gen pushLiteral: lit literal beReadOnlyLiteral! !

!IRTranslator methodsFor: 'private' stamp: ''!
popScope

	currentScope size = 1 ifFalse: [currentScope pop]! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitStoreRemoteTemp: remoteTemp
	| tempIndex tempVectorIndex tempVector |

	tempVector := tempVectorStack detect: [:each | each name = remoteTemp tempVectorName].
	tempVectorIndex := tempVector indexForVarNamed: remoteTemp name.
	tempIndex := self currentScope indexForVarNamed: remoteTemp tempVectorName.

	gen storeRemoteTemp: tempVectorIndex inVectorAt: tempIndex! !

!IRTranslator methodsFor: 'private' stamp: ''!
pragmas: aCollection
	gen pragmas: aCollection! !

!IRTranslator methodsFor: 'initialization' stamp: ''!
initialize
	currentScope := Stack new.
	tempVectorStack := Stack new.! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitBlockReturnTop: blockReturnTop

	gen blockReturnTop! !

!IRTranslator methodsFor: 'private' stamp: ''!
label: seqNum

	gen label: seqNum.! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitReturnReceiver: rec

	gen returnReceiver! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushThisContext: ctxt

	gen pushThisContext! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitReturnLiteral: lit

	gen returnConstant: lit literal! !

!IRTranslator methodsFor: 'private' stamp: ''!
currentScope 
	^currentScope top! !

!IRTranslator methodsFor: 'results' stamp: ''!
compiledMethodWith: aTrailer

	^ gen compiledMethodWith: aTrailer! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushReceiver: receiver

	gen pushReceiver! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushThisProcess: pushThisProcess
	gen pushThisProcess! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushInstVar: instVar
	
	gen pushInstVar: instVar index! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitMethod: anIr
	IRFix new visitNode: anIr.
	self pushScope: anIr.
	gen irPrimitive: anIr irPrimitive.
	gen numArgs: anIr numArgs.
	gen properties: anIr properties.
	gen numTemps: (anIr tempMap size).
	gen additionalLiterals: anIr additionalLiterals.
	gen forceLongForm: anIr forceLongForm.
	self visitSequences: anIr allSequences.! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPop: pop

	gen popTop! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitJumpIf: jumpIf

	gen 
		if: jumpIf boolean 
		goto: jumpIf destination orderNumber 
		otherwise: jumpIf otherwise orderNumber! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPopIntoRemoteTemp: remoteTemp
	| tempIndex tempVectorIndex tempVector |

	tempVector := tempVectorStack detect: [ :each | each name = remoteTemp tempVectorName ].
	tempVectorIndex := tempVector indexForVarNamed: remoteTemp name.
	tempIndex := self currentScope indexForVarNamed: remoteTemp tempVectorName.

	gen storePopRemoteTemp: tempVectorIndex inVectorAt: tempIndex! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitReturn: ret
	
	gen returnTop! !

!IRTranslator methodsFor: 'initialize' stamp: ''!
trailer: aTrailer

	trailer := aTrailer! !

!IRTranslator methodsFor: 'results' stamp: ''!
compiledMethod
	^ gen compiledMethodWith: trailer! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitPushLiteralVariable: var

	gen pushLiteralVariable: var association! !

!IRTranslator methodsFor: 'visiting' stamp: ''!
visitInstruction: instr
	gen mapBytesTo: instr.
	self visitNode: instr.! !

!IRTranslator class methodsFor: 'instance creation' stamp: ''!
new
	^self context: CompilationContext default trailer: CompiledMethodTrailer empty! !

!IRTranslator class methodsFor: 'instance creation' stamp: ''!
context: aCompilationContext trailer: aCompiledMethodTrailer
	^self basicNew 
		initialize;
		compilationContext: aCompilationContext;
		trailer: aCompiledMethodTrailer! !

!IRVisitor commentStamp: ''!
I visit an IRMethod instructions and write them out to a print stream.!
!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPopIntoLiteralVariable: litVar! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPopIntoTemp: tmp! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitStoreTemp: storeTemp! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitSequence: sequence
	sequence do: [ :instr | self visitInstruction: instr].! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushArray: pushArray! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushFullClosure: fullBlock! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPopIntoInstVar: instVar! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitJump: jump! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitStoreInstVar: storeInstVar! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitSend: send! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitStoreLiteralVariable: storeLiteralVariable! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitNode: elem
	^ elem accept: self! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushTemp: pushTemp! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushDup: pushDup! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitTempVector: tempVector! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushLiteral: pushLiteral! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushRemoteTemp: pushRemoteTemp! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitReturnInstVar: instVar! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitStoreRemoteTemp: storeRemoteTemp! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitBlockReturnTop: blockReturnTop! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitReturnReceiver: rec! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushThisContext: pushThisContext! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitReturnLiteral: lit! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushThisProcess: pushThisProcess! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushInstVar: pushInstVar! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushReceiver: receiver! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitMethod: method
	self visitNodes: method allSequences.! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPop: pop! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitNodes: col
	col do: [ :each | self visitNode: each ]! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPopIntoRemoteTemp: remoteTemp! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitJumpIf: jumpIf! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitReturn: return! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitPushLiteralVariable: pushLiteralVariable! !

!IRVisitor methodsFor: 'visiting' stamp: ''!
visitInstruction: instr! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testPushTempTemp
	| ir |
	ir := IRBuilderTest new testPushTempTemp.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testLiteralArray
	| ir |
	ir := IRBuilderTest new testLiteralArray.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testJumpBackTo
	| ir |
	ir := IRBuilderTest new testJumpBackTo.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testPushThisContext
	| ir |
	ir := IRBuilderTest new testPushThisContext.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testPopTop
	| ir |
	ir := IRBuilderTest new testPopTop.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testPushNewArray
	| ir |
	ir := IRBuilderTest new testPushNewArray.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testReturnTop
	| ir |
	ir := IRBuilderTest new testReturnTop.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testSendSuper
	| ir |
	ir := IRBuilderTest new testSendSuper.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testStoreIntoVariable
	| ir |
	ir := IRBuilderTest new testStoreIntoVariable.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testDup
	| ir |
	ir := IRBuilderTest new testDup.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testInstVar
	| ir |
	ir := IRBuilderTest new testInstVar.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testPushConsArray
	| ir |
	ir := IRBuilderTest new testPushConsArray.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'utilities' stamp: ''!
interpret: ir
	IRVisitor new visitNode: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testLiteralVariableClass
	| ir |
	ir := IRBuilderTest new testLiteralVariableClass.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testPushSelf
	| ir |
	ir := IRBuilderTest new testPushSelf.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testPushTempArgument
	| ir |
	ir := IRBuilderTest new testPushTempArgument.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testJumpAheadToIf
	| ir |
	ir := IRBuilderTest new testJumpAheadToIf.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testStoreTemp
	| ir |
	ir := IRBuilderTest new testStoreTemp.
	self interpret: ir! !

!IRVisitorTest methodsFor: 'tests' stamp: ''!
testJumpAheadTo
	| ir |
	ir := IRBuilderTest new testJumpAheadTo.
	self interpret: ir! !

!ISOLanguageDefinition commentStamp: ''!
The language definitions from International Organization for Standardization.

You can obtain the list of the all the ISOCountries and languages.!
!ISOLanguageDefinition methodsFor: 'accessing' stamp: ''!
iso2: aString
	iso2 := aString ifEmpty: [nil] ifNotEmpty: [aString]! !

!ISOLanguageDefinition methodsFor: 'accessing' stamp: ''!
iso3
	^iso3 ifNil: ['']! !

!ISOLanguageDefinition methodsFor: 'accessing' stamp: ''!
iso3Alternate
	^iso3Alternate ifNil: ['']! !

!ISOLanguageDefinition methodsFor: 'accessing' stamp: ''!
language: aString
	language := aString! !

!ISOLanguageDefinition methodsFor: 'accessing' stamp: ''!
language
	^ language! !

!ISOLanguageDefinition methodsFor: 'accessing' stamp: ''!
iso3: aString
	iso3 := aString ifEmpty: [nil] ifNotEmpty: [aString]! !

!ISOLanguageDefinition methodsFor: 'accessing' stamp: ''!
iso2
	^iso2 ifNil: [self iso3]! !

!ISOLanguageDefinition methodsFor: 'accessing' stamp: ''!
iso3Alternate: aString
	iso3Alternate := aString ifEmpty: [nil] ifNotEmpty: [aString]! !

!ISOLanguageDefinition class methodsFor: 'private - ISO 3' stamp: ''!
iso3LanguageTable
	"self iso3LanguageTable"

	^ISO3Table ifNil: [ISO3Table := self initISO3LanguageTable]! !

!ISOLanguageDefinition class methodsFor: 'initialization' stamp: ''!
initialize
	"self initialize"

	ISO3Table := nil.
	ISO2Table := nil! !

!ISOLanguageDefinition class methodsFor: 'private - ISO 2' stamp: ''!
iso2LanguageTable
	"self 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 - ISO 3166' stamp: ''!
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: ''!
initISOCountries
	"self initISOCountries"
	| iso3166Table |
	iso3166Table := self 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)].
	! !

!ISOLanguageDefinition class methodsFor: 'private - ISO 2' stamp: ''!
iso2Countries
	"self iso2Countries"
	"ISO2Countries := nil. ISO3Countries := nil"

	ISO2Countries ifNil: [self initISOCountries].
	^ISO2Countries! !

!ISOLanguageDefinition class methodsFor: 'private - ISO 3166' stamp: ''!
initISO3LanguageTable
	"self  initISO3LanguageTable"
	
	^ self readISOLanguagesFrom: self isoLanguages readStream.
	! !

!ISOLanguageDefinition class methodsFor: 'private - ISO 3166' stamp: ''!
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: ''!
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: ''!
readISOLanguagesFrom: stream
	"self readISOLanguagesFrom: self isoLanguages readStream "
	| languages language code3 index line |
	languages := Dictionary new.
	[stream atEnd
		or: [(line := stream nextLine readStream) atEnd]]
		whileFalse: [
			language := self new.
			code3 := line upTo: Character tab.
			(index := code3 indexOf: $/) > 0
				ifTrue: [
					language iso3: (code3 copyFrom: 1 to: index-1).
					language iso3Alternate: (code3 copyFrom: index+1 to: code3 size)]
				ifFalse: [language iso3: code3].
			language
				iso2: (line upTo: Character tab);
				language: line upToEnd.
			languages at: language iso3 put: language].
	^languages! !

!ISOLanguageDefinition class methodsFor: 'accessing' stamp: ''!
iso3LanguageDefinition: aString
	^self iso3LanguageTable at: aString! !

!ISOLanguageDefinition class methodsFor: 'accessing' stamp: ''!
iso2LanguageDefinition: aString
	^self iso2LanguageTable at: aString! !

!ISOLanguageDefinition class methodsFor: 'private - ISO 3' stamp: ''!
iso3Countries
	"self iso3Countries"
	"ISO2Countries := nil. ISO3Countries := nil"

	ISO3Countries ifNil: [self initISOCountries].
	^ISO3Countries! !

!ISOLanguageDefinitionTest commentStamp: ''!
Unit tests on ISO language definitions!
!ISOLanguageDefinitionTest methodsFor: 'tests' stamp: ''!
testISO2LanguageDefinition

	self 
		assert: (ISOLanguageDefinition iso2LanguageDefinition: 'de') language equals: 'German';
		assert: (ISOLanguageDefinition iso2LanguageDefinition: 'fr') language equals: 'French'! !

!ISOLanguageDefinitionTest methodsFor: 'tests' stamp: ''!
testISO3LanguageDefinition

	self 
		assert: (ISOLanguageDefinition iso3LanguageDefinition: 'deu') language equals: 'German';
		assert: (ISOLanguageDefinition iso3LanguageDefinition: 'fra') language equals: 'French'! !

!IVsAndClassVarNamesConflictTest commentStamp: ''!
SUnit tests to tests conflicts for instance variables and class variable names!
!IVsAndClassVarNamesConflictTest methodsFor: 'running' stamp: ''!
tearDown

	classFactory cleanUp.
	super tearDown! !

!IVsAndClassVarNamesConflictTest methodsFor: 'tests' stamp: ''!
testOneCanProceedWhenIntroducingCapitalizedInstanceVariables
	| class |
	[ 
		class := classFactory
			newSubclassOf: classFactory defaultSuperclass
			instanceVariableNames: 'X Y'
			classVariableNames: ''
	]
		on: Exception
		do: [ :ex | ex resume ].
	self assert: (testingEnvironment keys includes: class name)! !

!IVsAndClassVarNamesConflictTest methodsFor: 'tests' stamp: ''!
testOneCanProceedWhenIntroducingClasseVariablesBeginingWithLowerCaseCharacters
	| class |
	[ 
		class := classFactory
			newSubclassOf: classFactory defaultSuperclass
			instanceVariableNames: 'a BVarName'
			classVariableNames: ''
	]
		on: Exception
		do: [ :ex | ex resume ].
	self assert: (testingEnvironment keys includes: class name)! !

!IVsAndClassVarNamesConflictTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	classFactory := ClassFactoryForTestCase new! !

!IceAbstractCommitWalk commentStamp: ''!
Base class for shared code between different commit walk implementations.!
!IceAbstractCommitWalk methodsFor: 'walk definition' stamp: ''!
uptoCommits: commits
	commits do: [ :commit | self uptoCommit: commit  ]! !

!IceAbstractCommitWalk methodsFor: 'instance creation' stamp: ''!
fromCommit: aCommit

	self subclassResponsibility! !

!IceAbstractCommitWalk methodsFor: 'walking' stamp: ''!
firstCommit
	^ self commitsDo: [ :commit | ^ commit ] ! !

!IceAbstractCommitWalk methodsFor: 'walking' stamp: ''!
commitsDo: aBlock 
	self rawResultsDo: [ :result | aBlock value: (self commitFrom: result) ]! !

!IceAbstractCommitWalk methodsFor: 'walk definition' stamp: ''!
upto: aCommitish
	self uptoCommit: aCommitish commit! !

!IceAbstractCommitWalk methodsFor: 'walking' stamp: ''!
commits
	| commits |
	commits := OrderedCollection new.
	self commitsDo: [ :commit | commits add: commit ].
	^ commits! !

!IceAbstractCommitWalk methodsFor: 'accessing' stamp: ''!
modifyingPackage: anObject
	modifyingPackage := anObject! !

!IceAbstractCommitWalk methodsFor: 'private' stamp: ''!
commitFrom: result
	^ self repository commitFromGitCommit: result! !

!IceAbstractCommitWalk methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceAbstractCommitWalk methodsFor: 'accessing' stamp: ''!
modifyingPackage
	^ modifyingPackage! !

!IceAbstractCommitWalk methodsFor: 'walk definition' stamp: ''!
uptoBranch: anIceBranch 
	self uptoCommit: anIceBranch lastCommit! !

!IceAbstractCommitWalk methodsFor: 'walking' stamp: ''!
includesCommit: aCommit
	self commitsDo: [ :commit | 
		commit id = aCommit id ifTrue: [ ^ true ]].
	^ false! !

!IceAbstractCommitWalk methodsFor: 'walking' stamp: ''!
versionsFor: package detect: selectBlock ifNone: ifNoneBlock
	self modifyingPackage: package.
	self commitsDo: [ :commit | 
		| version | 
		version := commit versionFor: package.
		(selectBlock value: version) ifTrue: [ ^ version ]
	].

	^ ifNoneBlock value
  ! !

!IceAbstractCommitWalk methodsFor: 'accessing' stamp: ''!
maxNumber: anObject
	maxNumber := anObject! !

!IceAbstractCommitWalk methodsFor: 'walking' stamp: ''!
versionsFor: package
	self modifyingPackage: package.
	^ self commits collect: [ :commit | commit versionFor: package ]
! !

!IceAbstractCommitWalk methodsFor: 'walk definition' stamp: ''!
uptoBranches: branches
	^ branches do: [ :branch | self uptoBranch: branch ]! !

!IceAbstractCommitWalk methodsFor: 'accessing' stamp: ''!
maxNumber
	^ maxNumber! !

!IceAbstractCommitWalk methodsFor: 'walk definition' stamp: ''!
uptoVersion: version
	version hideYourselfFromCommitWalk: self
! !

!IceAbstractCommitWalk methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceAbstractCommitWalk methodsFor: 'instance creation' stamp: ''!
fromTag: anIceTag 
	
	self subclassResponsibility! !

!IceAbstractCommitWalk class methodsFor: 'instance creation' stamp: ''!
forRepository: repository
	^ self new repository: repository; yourself! !

!IceAbstractCommitWalk class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceAbstractCommitWalk ! !

!IceAbstractCredentials commentStamp: ''!
I represent the common behavior of all iceberg credentials.!
!IceAbstractCredentials methodsFor: 'accessing' stamp: ''!
host
	^ host! !

!IceAbstractCredentials methodsFor: '*Iceberg-TipUI' stamp: ''!
editModelClass
	^ self subclassResponsibility! !

!IceAbstractCredentials methodsFor: 'accessing' stamp: ''!
isPresent
	^ self subclassResponsibility! !

!IceAbstractCredentials methodsFor: 'accessing' stamp: ''!
description
	^ self subclassResponsibility! !

!IceAbstractCredentials methodsFor: 'API - storing' stamp: ''!
storeInto: aCredentialStore forHostname: aHost 
	host := aHost.
	aCredentialStore storePlaintextCredential: self forHostname: aHost! !

!IceAbstractCredentials methodsFor: 'accessing' stamp: ''!
hostDescription
	^ self subclassResponsibility! !

!IceAbstractCredentials methodsFor: '*Iceberg-TipUI' stamp: ''!
askForModelClass
	^ self subclassResponsibility! !

!IceAbstractCredentials methodsFor: 'accessing' stamp: ''!
host: anObject
	host := anObject! !

!IceAbstractCredentials methodsFor: 'testing' stamp: ''!
isDefault
	^ false! !

!IceAbstractCredentials methodsFor: 'accessing' stamp: ''!
type
	^ self subclassResponsibility! !

!IceAbstractCredentials class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceAbstractCredentials! !

!IceAbstractNode commentStamp: ''!
My subclasses implement a tree used for diffing and merging.!
!IceAbstractNode methodsFor: 'accessing' stamp: ''!
firstNodeSuchThat: foundBlock ifNone: noneBlock

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
isEmpty

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
addTo: anotherNode

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
mergeWith: anotherNode onLeft: leftBlock onRight: rightBlock onMerge: mergeBlock

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
resolve: aRelativePath ifPresent: presentBlock ifAbsent: absentBlock

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
allChildrenDo: aBlockClosure
	"Evaluate aBlockClosure with my direct and indirect children."
	
	self childrenDo: [ :each |
		aBlockClosure value: each.
		each allChildrenDo: aBlockClosure ]! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
select: aBlockClosure

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
children
	"Answer the (direct) children of this node."

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
isEmptyNode

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
anySatisfy: aBlockClosure

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
collectWithPath: aBlockClosure

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
firstNodeSuchThat: conditionBlock 
	
	^ self firstNodeSuchThat: conditionBlock ifNone: [ NotFound signalFor: conditionBlock ]! !

!IceAbstractNode methodsFor: 'enumerating' stamp: ''!
childrenDo: aBlockClosure 
	
	self children do: aBlockClosure! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
do: aBlockClosure
	"Evaluate aBlockClosure on my value and the values of my children."

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'enumerating' stamp: ''!
withAllChildrenDo: aBlockClosure

	aBlockClosure value: self.
	self allChildrenDo: aBlockClosure! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
notEmpty

	^ self isEmpty not! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
collect: aBlockClosure
	"Collect the results of aBlockClosure on my value and the values of my children."

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
hasChanges

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
accept: aVisitor

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
includesKey: anObject

	^ self subclassResponsibility! !

!IceAbstractNode methodsFor: 'accessing' stamp: ''!
path
	"Answer a RelativePath to the top parent."

	^ self subclassResponsibility! !

!IceAbstractNode class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceAbstractNode! !

!IceAbstractProject commentStamp: ''!
Abstract superclass for projects!
!IceAbstractProject methodsFor: 'accessing' stamp: ''!
sourceDirectoryReference
	
	^ commitish fileSystem resolve: self sourceDirectoryPath! !

!IceAbstractProject methodsFor: 'comparing' stamp: ''!
= anotherProject

	self species = anotherProject species ifFalse: [ ^ false ].
	self repository = anotherProject repository ifFalse: [ ^ false ]. 
	self properties = anotherProject properties ifFalse: [ ^ false ].
	^ true.! !

!IceAbstractProject methodsFor: 'API - packages' stamp: ''!
packagesFrom: aCommit
	
	self repository handleLibgitError: [ | writerClass sourceFileReference |
		writerClass := self writerClass.
		sourceFileReference :=  aCommit fileSystem resolve: self sourceDirectory.
		sourceFileReference exists ifFalse: [ ^ #() ].
		
		^ sourceFileReference children
			select: [ :each | writerClass isValidPackage: each ]
			thenCollect: [ :each | | packageName |
				packageName := writerClass packageNameFromDirectory: each basename.
				IcePackage named: packageName repository: self repository ] ]! !

!IceAbstractProject methodsFor: 'testing' stamp: ''!
readOnlyVersion

	^ self! !

!IceAbstractProject methodsFor: 'writing' stamp: ''!
addToChangeBuilder: anIceChangeImporter 
	
	"Nothing by default"! !

!IceAbstractProject methodsFor: 'accessing' stamp: ''!
repository
	
	^ commitish repository! !

!IceAbstractProject methodsFor: 'testing' stamp: ''!
isInvalid
	
	^ false! !

!IceAbstractProject methodsFor: 'API - packages' stamp: ''!
packages
	
	self repository handleLibgitError: [ | writerClass sourceFileReference |
		writerClass := self writerClass.
		sourceFileReference := commitish fileSystem resolve: self sourceDirectoryPath.
		sourceFileReference exists ifFalse: [ ^ #() ].
		
		^ sourceFileReference children
			select: [ :each | writerClass isValidPackage: each ]
			thenCollect: [ :each | | packageName |
				packageName := writerClass packageNameFromDirectory: each.
				IcePackage named: packageName repository: self repository ] ]! !

!IceAbstractProject methodsFor: 'testing' stamp: ''!
isDirty
	"Compare against the project extracted from the HEAD commit.
	If the commit has no project, it will be an unborn project."
	^ self repository workingCopy referenceCommit project ~= self readOnlyVersion! !

!IceAbstractProject methodsFor: 'accessing' stamp: ''!
commitish: anIceCommitish
	
	commitish := anIceCommitish! !

!IceAbstractProject methodsFor: 'testing' stamp: ''!
isUnborn
	
	^ false! !

!IceAbstractProject methodsFor: 'accessing' stamp: ''!
properties

	^ Dictionary new! !

!IceAbstractProject methodsFor: 'accessing' stamp: ''!
writerClass
	
	^ self repository properties writerClass! !

!IceAbstractProject methodsFor: 'accessing' stamp: ''!
sourceDirectoryPath

	"API compatible both with Pharo6 and Pharo7.
	This could be replaced by the Pharo7 API
	
	RelativePath with: self subdirectory
	"
	^ (RelativePath withAll: (RelativePath canonicalizeElements: ($/ split: self sourceDirectory)))! !

!IceAbstractProject methodsFor: 'accessing' stamp: ''!
sourceDirectory
	
	^ self subclassResponsibility! !

!IceAbstractProject class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository
	
	^ self onCommitish: aRepository workingCopy! !

!IceAbstractProject class methodsFor: 'instance creation' stamp: ''!
onCommitish: anIceCommitish
	
	^ self new
		commitish: anIceCommitish;
		yourself! !

!IceAbstractProject class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceAbstractProject! !

!IceAddition commentStamp: ''!
I am an addition in a tree. I contain the definition I'm adding. I know what is the icon for addition and how to calculate a conflict with other operations.!
!IceAddition methodsFor: 'contents' stamp: ''!
leftContents
	
	^ definition contents! !

!IceAddition methodsFor: 'merging' stamp: ''!
mergeWithLeftModification: anIceModification 
	
	"This should not happen. If I represent an addition of a node, that means that the original definition did not exist on the base version.
	Thus, the left version can never MODIFY a non existing version. It can add it too."
	self shouldNotImplement! !

!IceAddition methodsFor: 'merging' stamp: ''!
mergeWithLeftRemoval: anIceRemoval 
	
	"This should not happen. If I represent an addition of a node, that means that the original definition did not exist on the base version.
	Thus, the left version can never REMOVE a non existing version. It can add it too."
	self shouldNotImplement! !

!IceAddition methodsFor: 'accessing' stamp: ''!
rightContents
	
	^ ''! !

!IceAddition methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	
	^ self iconNamed: #changeAdd! !

!IceAddition methodsFor: 'merging' stamp: ''!
mergeWithLeftAddition: anIceAddition 
	
	"If the addition is the same, I can just keep any of them."
	anIceAddition definition = self definition 
		ifTrue: [ ^ IceNonConflictingOperation operation: anIceAddition ].
		
	^ IceConflictingOperation left: anIceAddition right: self! !

!IceAddition methodsFor: 'operations' stamp: ''!
inverse
	
	^ IceRemoval definition: definition! !

!IceAddition methodsFor: 'merging' stamp: ''!
mergeWithLeftNoOperation: anIceNoModification 
	
	"This should not happen. If I represent an addition of a node, that means that the original definition did not exist on the base version.
	Thus, the left version can never have an operation on the same element."
	self shouldNotImplement! !

!IceAddition methodsFor: 'testing' stamp: ''!
isAddition
	
	^ true! !

!IceAddition methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitAddition: self! !

!IceAddition methodsFor: 'merging' stamp: ''!
mergeWithOperation: anOperation
	
	^ anOperation mergeWithLeftAddition: self! !

!IceAnnouncement commentStamp: ''!
I'm a generic announcement in the iceberg context.!
!IceAnnouncement methodsFor: 'testing' stamp: ''!
appliesToRepository: aRepository
	^ false! !

!IceAnnouncer commentStamp: ''!
I'm the general announcer of Iceberg.
I'm an announcer that knows how to suspend just some kind of announcements (the ones that matches matching block on #suspendAllMatching:while:).

In current implementation of Iceberg, I will be used mainly for the convenience method: #suspendAllForRepository:while:
!
!IceAnnouncer methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	suspendAll := false.
	suspendedConditions := OrderedCollection new: 5! !

!IceAnnouncer methodsFor: 'suspending' stamp: ''!
suspendAllMatching: matchBlock while: aBlock

	suspendedConditions add: matchBlock.
	aBlock ensure: [ suspendedConditions remove: matchBlock ]! !

!IceAnnouncer methodsFor: 'suspending' stamp: ''!
suspendAllForRepository: aRepository while: aBlock

	^ self 
		suspendAllMatching: [ :ann | ann appliesToRepository: aRepository ] 
		while: aBlock ! !

!IceAnnouncer methodsFor: 'suspending' stamp: ''!
suspendAllWhile: aBlock
	| previousSuspensionState |
	
	previousSuspensionState := suspendAll.
	suspendAll := true.
	aBlock ensure: [ 
		suspendAll := previousSuspensionState ]! !

!IceAnnouncer methodsFor: 'announce' stamp: ''!
announce: anAnnouncement

	(self isAnnouncementSuspended: anAnnouncement) ifTrue: [ ^ anAnnouncement asAnnouncement ].
	^ super announce: anAnnouncement! !

!IceAnnouncer methodsFor: 'testing' stamp: ''!
isSuspended

	^ suspendAll! !

!IceAnnouncer methodsFor: 'testing' stamp: ''!
isAnnouncementSuspended: anAnnouncement

	suspendAll ifTrue: [ ^ true ].
	suspendedConditions ifEmpty: [ ^ false ].
	^ suspendedConditions anySatisfy: [ :each | 
		each value: anAnnouncement ]! !

!IceAsDependencyVisitor methodsFor: 'visiting' stamp: ''!
visitClassDefinition: anIceClassDefinition
	^ IceClassDependency new
		definition: anIceClassDefinition;
		cherrypicker: cherrypicker ;
		yourself! !

!IceAsDependencyVisitor methodsFor: 'accessing' stamp: ''!
cherrypicker: anIceCherrypicker 
	cherrypicker := anIceCherrypicker! !

!IceAsDependencyVisitor methodsFor: 'visiting' stamp: ''!
visitExtensionDefinition: anIceExtensionDefinition
	^ IceExtendedClassDependency new
		definition: anIceExtensionDefinition;
		cherrypicker: cherrypicker;
		yourself! !

!IceAsDependencyVisitor methodsFor: 'visiting' stamp: ''!
visitTraitDefinition: anIceTraitDefinition
	^ IceTraitDependency new
		definition: anIceTraitDefinition;
		cherrypicker: cherrypicker;
		yourself! !

!IceAsDependencyVisitor methodsFor: 'visiting' stamp: ''!
visitMethodNode: anIceMethodDefinition 
	^ IceMethodDependency new
	definition: anIceMethodDefinition ;
	cherrypicker: cherrypicker ;
	yourself ! !

!IceAsDependencyVisitor methodsFor: 'visiting' stamp: ''!
visitTreeNode: anIceNode
	^ anIceNode value definition accept: self! !

!IceAsDependencyVisitor methodsFor: 'visiting' stamp: ''!
visitPackage: anIcePackageDefinition
	^ IcePackageDependency new
		definition: anIcePackageDefinition;
		cherrypicker: cherrypicker;
		yourself! !

!IceAttachedSingleVersionWorkingCopy commentStamp: ''!
I am a working copy whose packages were all loaded from the same single commit.!
!IceAttachedSingleVersionWorkingCopy methodsFor: 'testing' stamp: ''!
isCommitMerged: aCommit

	^ aCommit isAncestorOf: self referenceCommit! !

!IceAttachedSingleVersionWorkingCopy methodsFor: 'merging' stamp: ''!
mergeCommit: mergeCommit
	
	^ IceMerge new
		repository: self repository;
		mergeCommit: mergeCommit;
		execute.! !

!IceAttachedSingleVersionWorkingCopy methodsFor: 'testing' stamp: ''!
isSingleCommitState
	
	^ true! !

!IceAttachedSingleVersionWorkingCopy methodsFor: 'displaying' stamp: ''!
description
	
	^ self referenceCommit description! !

!IceAttachedSingleVersionWorkingCopy methodsFor: 'accessing' stamp: ''!
referenceCommit
	
	^ repository workingCopy referenceCommit! !

!IceAttachedSingleVersionWorkingCopy methodsFor: 'accessing' stamp: ''!
referenceCommits
	
	^ { self referenceCommit }! !

!IceAttachedSingleVersionWorkingCopy methodsFor: 'merging' stamp: ''!
mergeStateWith: aMergeableState
	
	^ aMergeableState mergeWithSingleVersionWorkingCopyState: self! !

!IceAttachedSingleVersionWorkingCopy methodsFor: 'testing' stamp: ''!
includesCommit: anIceCommit
	
	^ self referenceCommit = anIceCommit! !

!IceAttachedSingleVersionWorkingCopy methodsFor: 'testing' stamp: ''!
isDetached
	
	^ self referenceCommit ~= repository head commit! !

!IceAttachedSingleVersionWorkingCopy methodsFor: 'accessing' stamp: ''!
singleCommit
	
	^ self referenceCommit! !

!IceAttachedSingleVersionWorkingCopy methodsFor: 'validating' stamp: ''!
validateCanCommit
	
	self isDetached
		ifTrue: [ IceWorkingCopyDesyncronized signal ]! !

!IceAttachedSingleVersionWorkingCopy class methodsFor: 'instance creation' stamp: ''!
on: anIceCommit repository: aRepository
	
	^ self new
		referenceCommit: anIceCommit;
		repository: aRepository;
		yourself! !

!IceAuthenticationError commentStamp: ''!
I indicate when an error trying to authenticate occurs (tipically, when cloning without credentials)!
!IceAuthenticationError methodsFor: 'accessing' stamp: ''!
messageText
	^ messageText ifNil: [self defaultMessageText format: { super messageText }]! !

!IceAuthenticationError methodsFor: 'accessing' stamp: ''!
defaultMessageText
	^ 'There was an authentication error while trying to execute the operation: {1}. 
This happens usually because you didn''t provide a valid set of credentials. 
You may fix this problem in different ways: 

1. adding your keys to ssh-agent, executing ssh-add ~/.ssh/id_rsa in your command line.
2. adding your keys in settings (open settings browser search for "Use custom SSH keys" and
add your public and private keys).
3. using HTTPS instead SSH (Just use an url in the form HTTPS://etc.git)'! !

!IceAuthenticationError methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor
	aVisitor visitAuthenticationError: self! !

!IceBackendWriterAdapter commentStamp: ''!
Adapter for having MCFileTreeWriters being able to write into Iceberg backend repositories without introducing unpleasant modifications in them.!
!IceBackendWriterAdapter methodsFor: 'accessing' stamp: ''!
propertyFileExtension
	^ MCFileTreeRepository defaultPropertyFileExtension! !

!IceBackendWriterAdapter methodsFor: 'accessing' stamp: ''!
backend: anObject
	backend := anObject! !

!IceBackendWriterAdapter methodsFor: 'accessing' stamp: ''!
backend
	^ backend! !

!IceBackendWriterAdapter methodsFor: 'accessing' stamp: ''!
directory
	^ self backend codeDirectory ! !

!IceBackendWriterAdapter class methodsFor: 'instance creation' stamp: ''!
for: anIceBackend
	^ self new backend: anIceBackend; yourself.! !

!IceBasicProject methodsFor: 'comparing' stamp: ''!
= anotherProject

	self species = anotherProject species ifFalse: [ ^ false ].
	properties = anotherProject properties ifFalse: [ ^ false ].
	self repository = anotherProject repository ifFalse: [ ^ false ]. 

	^ true.! !

!IceBasicProject methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
"	repositoryProperties := self readProperties.
	repositoryProperties properties
		at: #format
		ifAbsent: [ 	repositoryProperties fileFormat: self backwardsCompatibleFormat ]"! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
commitish
	^ commitish! !

!IceBasicProject methodsFor: 'comparing' stamp: ''!
hash

	^ commitish hash! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
fileSystem
	
	^ commitish fileSystem! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
projectFileIn: aCommitish 
	
	^ aCommitish fileSystem resolve: self projectFilePath! !

!IceBasicProject methodsFor: 'writing' stamp: ''!
addToChangeBuilder: anIceChangeImporter

	self addProjectFileToChangeBuilder: anIceChangeImporter.
	"self addPropertiesFileToChangeBuilder: anIceChangeImporter."! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
projectName
	
	^ properties at: #projectName ifAbsent: [ self repository name ]! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
sourceDirectory: aString 
	
	properties at: 'srcDirectory' put: aString! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
backwardsCompatibleFormat

	^ TIceRepositoryWriter users
		detect: #isLegacyDefault
		ifNone: [ Smalltalk at: #IceLibgitFiletreeWriter ]! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
properties: aCollection 
	properties := aCollection! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
repository
	^ commitish repository! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
fileFormatId: aFileFormat

	self repositoryProperties fileFormatId: aFileFormat! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
projectFileReference

	^ self projectFileIn: commitish! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
repositoryProperties
	^ self repository properties! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
properties
	^ properties! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
name
	
	^ self repository name! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
fileFormat: aFileFormat

	self fileFormatId: aFileFormat id! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
projectFilePath

	^ RelativePath with: '.project'.! !

!IceBasicProject methodsFor: 'writing' stamp: ''!
addProjectFileToChangeBuilder: anIceChangeImporter 
	
	| projectFileName |
	self isUnborn ifTrue: [ ^ self ].
	
	self assert: self projectFilePath size = 1.
	projectFileName := self projectFilePath segments first.
	
	anIceChangeImporter
		addFileNamed: projectFileName
		path: self projectFilePath
		contents: self contentsString.! !

!IceBasicProject methodsFor: 'storing' stamp: ''!
contentsString

	^ ByteArray streamContents: [ :stream |
		(STONWriter on: (ZnCharacterWriteStream on: stream)) 
			prettyPrint: true;
			newLine: OSPlatform current lineEnding;
			nextPut: self properties ]! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
sourceDirectoryPath

	"API compatible both with Pharo6 and Pharo7.
	This could be replaced by the Pharo7 API
	
	RelativePath with: self subdirectory
	"
	^ (RelativePath withAll: (RelativePath canonicalizeElements: ($/ split: self sourceDirectory)))! !

!IceBasicProject methodsFor: 'accessing' stamp: ''!
sourceDirectory
	
	^ properties at: 'srcDirectory' ifAbsent: [ 'src' ]! !

!IceBasicProject class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository withSourceDirectory: aDirectory
	
	^ self basicNew
		properties: Dictionary new;
		commitish: aRepository workingCopy;
		sourceDirectory: aDirectory;
		initialize;
		yourself! !

!IceBasicProject class methodsFor: 'instance creation' stamp: ''!
onProperties: properties commitish: aCommitish
	
	^ self basicNew
		properties: properties;
		commitish: aCommitish;
		initialize;
		yourself! !

!IceBasicProject class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository
	
	^ self basicNew
		properties: Dictionary new;
		commitish: aRepository workingCopy;
		initialize;
		yourself! !

!IceBasicProjectReader commentStamp: ''!
I am a basic project reader that is used by default in case no other project reader was found.
I create an IceBasicProject in case a .project file is found, or an IceUnbornProject otherwise.!
!IceBasicProjectReader methodsFor: 'testing' stamp: ''!
canReadProjectFromCommitish: aCommitish
	
	^ (aCommitish fileSystem / '.project') exists! !

!IceBasicProjectReader methodsFor: 'reading' stamp: ''!
readProjectFromCommitish: anIceCommitish 

	| properties projectFileReference |
	projectFileReference := anIceCommitish fileSystem / '.project'.
	properties := projectFileReference binaryReadStreamDo: [ :stream | STON fromStream: (ZnCharacterReadStream on: stream encoding: 'utf8') ].
	^ IceBasicProject onProperties: properties commitish: anIceCommitish! !

!IceBitbucketRepositoryType commentStamp: ''!
I resolve Bitbucket repositories!
!IceBitbucketRepositoryType class methodsFor: 'accessing' stamp: ''!
type
	^ 'bitbucket'! !

!IceBranch commentStamp: ''!
I am an abstract class representing a branch. My history and accessing operations delegate in my current commit. The only exception is checkout operation that checkouts and sets myself as HEAD.

Check my superclass and subclasses for more information.!
!IceBranch methodsFor: 'API - branches' stamp: ''!
delete
	
	self subclassResponsibility! !

!IceBranch methodsFor: 'comparing' stamp: ''!
= aBranch

	^ self fullname = aBranch fullname! !

!IceBranch methodsFor: 'API - changes' stamp: ''!
changesFromCommit: anIceCommit
	
	^ self commit changesFromCommit: anIceCommit! !

!IceBranch methodsFor: 'API - history' stamp: ''!
commitsDo: aBlockClosure 
	
	self newCommitWalk commitsDo: aBlockClosure! !

!IceBranch methodsFor: 'comparing' stamp: ''!
hash

	^ self fullname hash! !

!IceBranch methodsFor: 'testing' stamp: ''!
isBranch
	
	^ true! !

!IceBranch methodsFor: 'testing' stamp: ''!
isHead
	^ self repository head = self! !

!IceBranch methodsFor: 'testing' stamp: ''!
isLocal
	
	^ self isRemote not! !

!IceBranch methodsFor: 'validation' stamp: ''!
validateIsBranch
	
	"Nothing. I'm a branch"! !

!IceBranch methodsFor: 'accessing' stamp: ''!
description
	
	^ self name! !

!IceBranch methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self class name;
		nextPutAll: '(';
		nextPutAll: self name;
		nextPutAll: ')'! !

!IceBranch methodsFor: 'API - packages' stamp: ''!
packages
	
	^ self commit packages! !

!IceBranch methodsFor: 'private - changes' stamp: ''!
versionFor: anIcePackage 
	
	^ self commit versionFor: anIcePackage! !

!IceBranch methodsFor: 'accessing' stamp: ''!
fullname

	^ name! !

!IceBranch methodsFor: 'API - history' stamp: ''!
includesCommit: aCommit
	
	^ self newCommitWalk includesCommit: aCommit! !

!IceBranch methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!IceBranch methodsFor: 'API - packages' stamp: ''!
includesPackageNamed: aString
	
	^ self commit includesPackageNamed: aString! !

!IceBranch methodsFor: 'accessing' stamp: ''!
name: aString 
	name := aString! !

!IceBranch methodsFor: 'API - history' stamp: ''!
newCommitWalk

	^ repository newCommitWalk fromBranch: self! !

!IceBranch methodsFor: 'API - packages' stamp: ''!
packageNames
	
	^ self commit packageNames! !

!IceBranch methodsFor: 'API - properties' stamp: ''!
properties
	
	^ self commit properties! !

!IceBranch methodsFor: 'private - monticello' stamp: ''!
snapshotFor: anIceSavedPackage 
	
	^ self commit snapshotFor: anIceSavedPackage! !

!IceBranch class methodsFor: 'instance creation' stamp: ''!
named: aName inRepository: aRepository

	| branch |
	branch := super inRepository: aRepository.
	branch name: aName.
	^ branch! !

!IceBranchAlreadyExists methodsFor: 'accessing' stamp: ''!
branchName

	^ branchName! !

!IceBranchAlreadyExists methodsFor: 'accessing' stamp: ''!
branchName: aBranchName

	branchName := aBranchName! !

!IceBranchNotFound commentStamp: ''!
A branch was not found.!
!IceBranchNotFound methodsFor: 'accessing' stamp: ''!
branchName
	^ branchName! !

!IceBranchNotFound methodsFor: 'accessing' stamp: ''!
branchName: aString 
	branchName := aString! !

!IceChange commentStamp: ''!
I represent an abstract change.!
!IceChange methodsFor: 'displaying' stamp: ''!
displayingProgressString
	^ self subclassResponsibility! !

!IceChange methodsFor: 'displaying' stamp: ''!
accept: anIceChangeImporter
	^ self subclassResponsibility! !

!IceChangeImporter commentStamp: ''!
I am a visitor that imports changes from different sources into a tree.

I receive the node where I have to work on, a version, and the I can be visited by several sources (like git or image changes). 

I work recursively: I create new instances of myself to build the children nodes of my node.!
!IceChangeImporter methodsFor: 'visiting' stamp: ''!
visitProjectChange: anIceProjectChange 
	
	"Import the project file extracted from the commit without utterly post-treatment to create the new project file"
	
	version project addToChangeBuilder: self! !

!IceChangeImporter methodsFor: 'visiting' stamp: ''!
visitImageChange: anIceImageChange 

	| importer |
	importer := IceMCPackageImporter new
		package: anIceImageChange package;
		version: version;
		yourself.
	^ importer importOn: (self ensureSourceCodeParentNodeIn: parentNode)! !

!IceChangeImporter methodsFor: 'visiting' stamp: ''!
visitCypressPropertiesChange: anIceCypressPropertiesChange 
	
	version properties addToChangeBuilder: self! !

!IceChangeImporter methodsFor: 'accessing' stamp: ''!
version: aVersion 
	
	version := aVersion! !

!IceChangeImporter methodsFor: 'private' stamp: ''!
ensureDirectoryAtPath: aPathSegments inNode: aNode

	| firstChild |
	aPathSegments ifEmpty: [ ^ aNode ].
	firstChild := self ensureDirectoryNamed: aPathSegments first inNode: aNode.
	^ self ensureDirectoryAtPath: aPathSegments allButFirst inNode: firstChild! !

!IceChangeImporter methodsFor: 'private' stamp: ''!
ensureDirectoryNamed: aName inNode: aNode

	aNode childAt: aName ifPresent: [ :node |
		self assert: node value isDirectoryDefinition.
		^ node ].
	^ aNode addChild: (IceDirectoryDefinition named: aName path: aNode path / aName)! !

!IceChangeImporter methodsFor: 'private' stamp: ''!
ensureSourceCodeParentNodeIn: aNode
	
	^ self
		ensureDirectoryAtPath: diff repository subdirectoryPath segments
		inNode: aNode! !

!IceChangeImporter methodsFor: 'importing' stamp: ''!
addFileNamed: aString path: aRelativePath contents: aByteArray 

	| fileParentNode |

	fileParentNode := parentNode.
	aRelativePath segments allButLastDo: [ :each | 
		fileParentNode := (fileParentNode includesKey: each)
			ifTrue: [ fileParentNode / each ]
			ifFalse: [ fileParentNode addChild: (IceDirectoryDefinition named: each path: aRelativePath parent) ].
		self assert: fileParentNode value isDirectoryDefinition ].

	fileParentNode addChild: (IceFileDefinition
		named: aString
		path: aRelativePath
		contents: aByteArray).! !

!IceChangeImporter methodsFor: 'accessing' stamp: ''!
diff: anIceDiff 
	diff := anIceDiff! !

!IceChangeImporter methodsFor: 'accessing' stamp: ''!
parentNode: anIcePackageNode 
	parentNode := anIcePackageNode! !

!IceChangeImporter methodsFor: '*Iceberg-Libgit' stamp: ''!
visitGitChange: anIceGitChange 

	| importer |
	importer := IceGitChangeImporter new
		path: anIceGitChange path;
		diff: diff;
		version: version;
		yourself.
	importer importOn: parentNode.! !

!IceChangeSetChanged commentStamp: ''!
I announce when a IceChangeSet has changed.!
!IceCheckoutAllPackages commentStamp: ''!
I'm the simplest possible checkout strategy: I will load into image all packages defined in repository regardless their previous status. 

This strategy is very dangerous since it can introduce in image package versions that were not there before. Or it may cause the packages/classes became incorrectly initialised. But some project can find this strategy very apeleable nevertheless.!
!IceCheckoutAllPackages methodsFor: 'checkout' stamp: ''!
checkoutOn: anIceWorkingCopy
	
	anIceWorkingCopy
		loadPackagesNamed: committish packageNames
		fromCommit: committish commit.
	self repository setHead: committish.
	anIceWorkingCopy referenceCommit: committish commit.
	anIceWorkingCopy markAllPackagesAsClean.! !

!IceCheckoutAllPackages class methodsFor: 'accessing' stamp: ''!
order
	^ 20! !

!IceCheckoutAllPackages class methodsFor: '*Iceberg-TipUI' stamp: ''!
description
	^ 'Checkout ALL packages in the repository'! !

!IceCheckoutAlreadyLoadedPackages commentStamp: ''!
I'm a strategy thet will load into image JUST the packages that were already loaded on it. 
Loading same-named packages of those already in image is probably the best strategy possible before an installation following a project description.

This strategy is still dangerous bacause packages installed may be incorrectly initialisated. Or a refactor could have split a package and now half of the data are not there anymore. But still... is the best possible approach when you do not have a propper project description.
!
!IceCheckoutAlreadyLoadedPackages methodsFor: 'checkout' stamp: ''!
checkoutOn: anIceWorkingCopy 
	
	anIceWorkingCopy loadChangesInWorkingCopy: self diff.
	self repository setHead: committish.
	anIceWorkingCopy referenceCommit: committish commit.
	anIceWorkingCopy markAllPackagesAsClean.! !

!IceCheckoutAlreadyLoadedPackages class methodsFor: 'accessing' stamp: ''!
order
	^ 10! !

!IceCheckoutAlreadyLoadedPackages class methodsFor: '*Iceberg-TipUI' stamp: ''!
description
	^ 'Checkout packages ALREADY LOADED in the image'! !

!IceCheckoutConflictError commentStamp: ''!
I indicate there are conflicts when I try to checkout so I can't perform the operation.!
!IceCheckoutConflictError methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor
	aVisitor visitCheckoutConflict: self! !

!IceCheckoutDoNotLoadPackages commentStamp: ''!
A strategy to checkout but not load packages into the image!
!IceCheckoutDoNotLoadPackages methodsFor: 'checkout' stamp: ''!
checkoutOn: anIceWorkingCopy 
	committish commit adopt.
	self repository setHead: committish! !

!IceCheckoutDoNotLoadPackages class methodsFor: 'accessing' stamp: ''!
order
	^ 1000! !

!IceCheckoutDoNotLoadPackages class methodsFor: '*Iceberg-TipUI' stamp: ''!
description
	^ 'DO NOT CHECKOUT any packages, I will load them manually (for experts only)'! !

!IceCheckoutStrategy commentStamp: ''!
I'm a general strategy to perform checkouts. 
In Pharo, checkouts are a lot more complicated than a simple checkout in file system, since we have packages installed that corresponds with the commit of reference.
Doing a checkout then means also introduce new versions into the image, and there are different possible strategies to perform this task in a safe way. 
My children will implement method #checkoutPackagesOn: to perform this task.!
!IceCheckoutStrategy methodsFor: 'accessing' stamp: ''!
workingCopy
	
	^ self repository workingCopy! !

!IceCheckoutStrategy methodsFor: 'accessing' stamp: ''!
repository

	^ committish repository! !

!IceCheckoutStrategy methodsFor: 'accessing' stamp: ''!
committish: aCommittish
	
	committish := aCommittish! !

!IceCheckoutStrategy methodsFor: '*Iceberg-TipUI' stamp: ''!
description

	^ self class description! !

!IceCheckoutStrategy methodsFor: 'accessing' stamp: ''!
commitish: aCommittish
	
	committish := aCommittish! !

!IceCheckoutStrategy methodsFor: 'accessing' stamp: ''!
diff: anIceDiff 
	
	diff := anIceDiff! !

!IceCheckoutStrategy methodsFor: 'checkout' stamp: ''!
checkoutOn: anIceWorkingCopy 
	
	self subclassResponsibility! !

!IceCheckoutStrategy methodsFor: 'accessing' stamp: ''!
diff
	
	^ diff ifNil: [ 
		diff := committish diffTo: self workingCopy ].! !

!IceCheckoutStrategy class methodsFor: 'accessing' stamp: ''!
order
	^ self subclassResponsibility! !

!IceCheckoutStrategy class methodsFor: 'accessing' stamp: ''!
allStrategies
	^ (self allSubclasses 
		sorted: [ :a :b | a order < b order ])
		collect: #uniqueInstance! !

!IceCheckoutStrategy class methodsFor: '*Iceberg-TipUI' stamp: ''!
description
	^ self subclassResponsibility! !

!IceCherrypicker commentStamp: ''!
I know how to cherry-pick changes from a source IceDiff into a target IceDiff. 

* The source diff is an "initial change set" (ICS) with changes we want to initially selected.
* The target diff is an "estimated transitive change set" (ETCS) is the universe of changes, some of them will be pruned if they are not required by the changes in the ICS.
!
!IceCherrypicker methodsFor: 'testing' stamp: ''!
includesDependencyTo: aDefinition

	^ dependencies anySatisfy: [ :each | each isDependencyTo: aDefinition ]. ! !

!IceCherrypicker methodsFor: 'accessing' stamp: ''!
receiverToAncestorDiff
	^ receiverToAncestorDiff! !

!IceCherrypicker methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment:= anObject ! !

!IceCherrypicker methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	dependencies := Set new! !

!IceCherrypicker methodsFor: 'operations' stamp: ''!
mergeWithCurrentBranch
	mergeTree  := IceTreeMerger new
		merge: self targetDiff tree
		into: self receiverToAncestorDiff tree! !

!IceCherrypicker methodsFor: 'dependencies' stamp: ''!
addMetaclassDependency: anIceClassDefinition
	dependencies
		add:
			(IceMetaclassDependency new
				definition: anIceClassDefinition;
				cherrypicker: self;
				yourself)! !

!IceCherrypicker methodsFor: 'execution - private' stamp: ''!
pruneUndependedNodesInTargetDiff

	IceCherrypickerDiffPruner new
		cherrypicker: self;
		applyTo: incomingChangesDiff! !

!IceCherrypicker methodsFor: 'dependencies' stamp: ''!
addPackageDependency: aIcePackageDefinition
	dependencies
		add:
			(IcePackageDependency new
				definition: aIcePackageDefinition;
								cherrypicker: self;
				yourself)! !

!IceCherrypicker methodsFor: 'accessing' stamp: ''!
environment
	^ environment ifNil: [ environment := IceDependencyEnvironment on: receiverToAncestorDiff targetVersion  ]! !

!IceCherrypicker methodsFor: 'execution - public' stamp: ''!
execute
	"Obtain the initial change set (ICS)"

	self addInitialDependencies.

	"Obtain an estimated transitive change set (ETCS)"
	self addTransitiveDependencies.

	"Transform the diff to hold the ETCS"
	self pruneUndependedNodesInTargetDiff.

	"Merge changes into the current branch."
	self mergeWithCurrentBranch.
	^ mergeTree! !

!IceCherrypicker methodsFor: 'accessing' stamp: ''!
targetDiff
	^ incomingChangesDiff! !

!IceCherrypicker methodsFor: 'accessing' stamp: ''!
targetDiff: anObject
	incomingChangesDiff := anObject! !

!IceCherrypicker methodsFor: 'execution - private' stamp: ''!
addTransitiveDependencies
	| originalDependencies |
	originalDependencies := nil.

	[ originalDependencies ~= dependencies ]
		whileTrue: [ originalDependencies := dependencies copy.
			originalDependencies
				do: [ :each | each addTransitiveDependenciesFrom: incomingChangesDiff to: self ]]! !

!IceCherrypicker methodsFor: 'dependencies' stamp: ''!
addExtendedClassDependency: aIceExtensionDefinition
	dependencies
		add:
			(IceExtendedClassDependency new
				definition: aIceExtensionDefinition;
				cherrypicker: self;
				yourself)! !

!IceCherrypicker methodsFor: 'accessing' stamp: ''!
dependencies
	^ dependencies! !

!IceCherrypicker methodsFor: 'accessing' stamp: ''!
receiverToAncestorDiff: anIceDiff 
	receiverToAncestorDiff:= anIceDiff.! !

!IceCherrypicker methodsFor: 'accessing' stamp: ''!
sourceDiff
	^ sourceDiff! !

!IceCherrypicker methodsFor: 'accessing' stamp: ''!
sourceDiff: anObject
	sourceDiff := anObject! !

!IceCherrypicker methodsFor: 'dependencies' stamp: ''!
addMethodDependencyOf: aIceMethodDefinition
	dependencies
		add:
			(IceMethodDependency new
				definition: aIceMethodDefinition;
				cherrypicker: self;
				yourself)! !

!IceCherrypicker methodsFor: 'dependencies' stamp: ''!
addClassDependencyOf: aIceClassDefinition
	dependencies
		add:
			(IceClassDependency new
				definition: aIceClassDefinition;
								cherrypicker: self;
				yourself)! !

!IceCherrypicker methodsFor: 'accessing - options' stamp: ''!
addDependency: anIceDependency 
	self dependencies add: anIceDependency .! !

!IceCherrypicker methodsFor: 'dependencies' stamp: ''!
addTraitDependencyOf: aIceTraitDefinition
	dependencies
		add:
			(IceTraitDependency new
				definition: aIceTraitDefinition;
								cherrypicker: self;
				yourself)! !

!IceCherrypicker methodsFor: 'execution - private' stamp: ''!
addInitialDependencies

	sourceDiff accept: (IceCherrypickerInitialDependenciesCollector new
				cherrypicker: self;
				yourself)! !

!IceCherrypickerDiffPruner commentStamp: ''!
I am an IceDiff visitor to remove nodes that are not required the IceCherrypicker dependencies.
!
!IceCherrypickerDiffPruner methodsFor: 'visiting' stamp: ''!
visitRemoval: anIceRemoval
	(cherrypicker includesDependencyTo: anIceRemoval definition)
		ifFalse: [ nodesToRemove add: currentNode ]! !

!IceCherrypickerDiffPruner methodsFor: 'accessing' stamp: ''!
cherrypicker: anIceCherrypicker
	cherrypicker := anIceCherrypicker! !

!IceCherrypickerDiffPruner methodsFor: 'visiting' stamp: ''!
visitAddition: anIceAddition 
	
	(cherrypicker includesDependencyTo: anIceAddition definition) 
		ifFalse: [ nodesToRemove add: currentNode ]! !

!IceCherrypickerDiffPruner methodsFor: 'visiting' stamp: ''!
visitModification: anIceModification

	(cherrypicker includesDependencyTo: anIceModification definition)
		ifFalse: [ nodesToRemove add: currentNode ]! !

!IceCherrypickerDiffPruner methodsFor: 'applying' stamp: ''!
applyTo: anIceDiff
	
	nodesToRemove := Set new.
	
	anIceDiff accept: self.
	
	nodesToRemove do: [ :aNode | aNode parent removeChild: aNode ].
! !

!IceCherrypickerDiffPruner methodsFor: 'accessing' stamp: ''!
cherrypicker
	^ cherrypicker! !

!IceCherrypickerDiffPruner methodsFor: 'visiting' stamp: ''!
visitNoModification: anIceNoModification 
	
	"Nothing with me. Just visit children"
	self visitChildrenOf: currentNode.
! !

!IceCherrypickerInitialDependenciesCollector commentStamp: ''!
I am a visitor of IceDiff (and IceDefinition) collect the initial ser of dependencies in an instance of IceCherrypicker.
!
!IceCherrypickerInitialDependenciesCollector methodsFor: 'visiting' stamp: ''!
visitRemoval: anIceRemoval
	anIceRemoval definition accept: self.
		self visitChildrenOf: currentNode! !

!IceCherrypickerInitialDependenciesCollector methodsFor: 'visiting' stamp: ''!
visitClassDefinition: anIceClassDefinition
	anIceClassDefinition isMeta
		ifTrue: [ cherrypicker
				addMetaclassDependency: anIceClassDefinition ]
		ifFalse: [ cherrypicker addClassDependencyOf: anIceClassDefinition ]! !

!IceCherrypickerInitialDependenciesCollector methodsFor: 'accessing' stamp: ''!
cherrypicker: anIceCherrypicker

	cherrypicker := anIceCherrypicker! !

!IceCherrypickerInitialDependenciesCollector methodsFor: 'visiting' stamp: ''!
visitAddition: anIceAddition
	anIceAddition definition accept: self.
		self visitChildrenOf: currentNode! !

!IceCherrypickerInitialDependenciesCollector methodsFor: 'accessing' stamp: ''!
visitExtensionDefinition: anIceExtensionDefinition
cherrypicker addExtendedClassDependency: anIceExtensionDefinition! !

!IceCherrypickerInitialDependenciesCollector methodsFor: 'visiting' stamp: ''!
visitTraitDefinition: anIceTraitDefinition
	cherrypicker
		addTraitDependencyOf: anIceTraitDefinition! !

!IceCherrypickerInitialDependenciesCollector methodsFor: 'visiting' stamp: ''!
visitMethodNode: anIceMethodDefinition
	cherrypicker
		addMethodDependencyOf: anIceMethodDefinition! !

!IceCherrypickerInitialDependenciesCollector methodsFor: 'visiting' stamp: ''!
visitModification: anIceModification
	anIceModification definition accept: self.
		self visitChildrenOf: currentNode! !

!IceCherrypickerInitialDependenciesCollector methodsFor: 'accessing' stamp: ''!
cherrypicker
	^ cherrypicker! !

!IceCherrypickerInitialDependenciesCollector methodsFor: 'visiting' stamp: ''!
visitNoModification: anIceNoModification 
	
	"Nothing with me. Just visit children"
	self visitChildrenOf: currentNode.! !

!IceCherrypickerInitialDependenciesCollector methodsFor: 'visiting' stamp: ''!
visitPackage: anIcePackageDefinition
	cherrypicker
		addPackageDependency: anIcePackageDefinition! !

!IceClassDefinition commentStamp: ''!
I represent a class read from an Iceberg repository, either from a commit or from the working directory in disk.

My contents is the class definition code.

See my superclasses for more information.!
!IceClassDefinition methodsFor: 'patching' stamp: ''!
addModification: anIceModification toPatcher: aMCPatcher 
	
	"If we are replacing an existing class, we need to handle the case. 
	For example, removing the last instance variable. 
	We need to remove the existing definition (empty class instance variables are not saved)."
	| defModification |
	
	"If the new definition has no class instance vaiables, we remove the meta side variables, and apply the new changes to the patcher "
	(self isMeta and: [ mcDefinition isNil and: [ anIceModification rightDefinition asMCDefinition isNotNil ] ])
		ifTrue: [ 
			defModification := anIceModification rightDefinition asMCDefinition deepCopy.
			defModification removeMetaSideVariables.
			aMCPatcher
				modifyDefinition: anIceModification rightDefinition asMCDefinition
				to: defModification.
				^ self].

	"We should not handle metaclasses if their mcDefinition is nil.
	They should be added automatically when added the instance side."
	(self isMeta and: [ mcDefinition isNil ])
		ifTrue: [ ^ self ].
	
	aMCPatcher
		modifyDefinition: anIceModification rightDefinition asMCDefinition
		to: anIceModification leftDefinition asMCDefinition! !

!IceClassDefinition methodsFor: 'patching' stamp: ''!
addToPatcher: aMCPatcher 
	
	"We should not handle metaclasses if their mcDefinition is nil.
	They should be added automatically when added the instance side."
	(self isMeta and: [ mcDefinition isNil ])
		ifTrue: [ ^ self ].
	
	"We should only be in this case if there is not instace-side changes."
	aMCPatcher addDefinition: self asMCDefinition! !

!IceClassDefinition methodsFor: 'testing' stamp: ''!
isClassDefinition
	
	^ true! !

!IceClassDefinition methodsFor: 'converting' stamp: ''!
asMCDefinitionWithoutMetaSide
	
	^ mcDefinition deepCopy removeMetaSideVariables
! !

!IceClassDefinition methodsFor: 'accessing' stamp: ''!
basicName
	^ name! !

!IceClassDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	^ self iconNamed: #class! !

!IceClassDefinition methodsFor: 'accessing' stamp: ''!
contents
	mcDefinition ifNil: [ ^ '' ].
	^ self isMeta
		ifFalse: [ mcDefinition fullDefinitionString ]
		ifTrue: [ mcDefinition classDefinitionString ]! !

!IceClassDefinition methodsFor: 'visiting' stamp: ''!
accept: aVisitor 
	
	^ aVisitor visitClassDefinition: self! !

!IceClassDefinition methodsFor: 'patching' stamp: ''!
removeFromPatcher: aMCPatcher 
	
	"If the meta side is removed, we should modify the class definition to not include the meta-parts such as class-instance-variables"
	self asMCDefinition ifNil: [ ^ self ].
	
	isMeta ifTrue: [ 
		
	"The patcher is storing the definitions by name of the class only.
	We need to check it also if the original definition is the one we have here.
	If it is, we can replace it in the patch.
	But if it is not, we should not replace. If we replace it we will overwrite
	the changes already in the patcher"
		aMCPatcher definitions definitionLike: self asMCDefinition 
			ifPresent: [ :found |
				found = self asMCDefinition 
				ifTrue: [
					aMCPatcher
						modifyDefinition: self asMCDefinition
						to: self asMCDefinitionWithoutMetaSide]] 
			ifAbsent: [].
		^ self ].
	
	aMCPatcher removeDefinition: self asMCDefinition ! !

!IceClassDependency commentStamp: ''!
I am a dependency to a class.!
!IceClassDependency methodsFor: 'private' stamp: ''!
subclassNames

	^ self cherrypicker environment
		allSubclassesNamesOf: self definition name! !

!IceClassDependency methodsFor: 'visiting' stamp: ''!
isDependencyTo: aIceDefinition
	^ aIceDefinition asMCDefinition className
		= definition asMCDefinition className! !

!IceClassDependency methodsFor: 'comparing' stamp: ''!
= anObject
	^ super = anObject
		and: [ definition asMCDefinition superclassName = anObject definition asMCDefinition superclassName ]! !

!IceClassDependency methodsFor: 'dependencies' stamp: ''!
referencedTraits
	^ ((RBParser parseExpression: definition asMCDefinition traitComposition)
		allChildren select: #isVariable) collect: #name! !

!IceClassDependency methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash bitXor: self definition asMCDefinition superclassName hash! !

!IceClassDependency methodsFor: 'dependencies' stamp: ''!
referencedClasses
	^ {definition asMCDefinition superclassName} , self subclassNames
		, self referencedSharedPool! !

!IceClassDependency methodsFor: 'dependencies' stamp: ''!
referencedPackages

	^ self definition asMCDefinition category! !

!IceClassDependency methodsFor: 'dependencies' stamp: ''!
referencedSharedPool
	^ (definition asMCDefinition sharedPoolsString splitOn: ' ') collect: #asSymbol! !

!IceCloneError commentStamp: ''!
Error while cloning a project!
!IceCloneError class methodsFor: 'signalling' stamp: ''!
signalFor: anObject

	^ self subclassResponsibility! !

!IceCloneLocationAlreadyExists commentStamp: ''!
Error while cloning a project - the location on disk already exists
!
!IceCloneLocationAlreadyExists methodsFor: 'accessing' stamp: ''!
location
	^ location! !

!IceCloneLocationAlreadyExists methodsFor: 'accessing' stamp: ''!
location: anObject
	location := anObject! !

!IceCloneLocationAlreadyExists methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor
	aVisitor visitCloneLocationAlreadyExists: self.! !

!IceCloneLocationAlreadyExists class methodsFor: 'signalling' stamp: ''!
signalFor: aLocation
	^ self new
		location: aLocation;
		signal.! !

!IceCloneRemoteNotFound commentStamp: ''!
The remote was not found!
!IceCloneRemoteNotFound methodsFor: 'accessing' stamp: ''!
remoteUrl
	^ remoteUrl! !

!IceCloneRemoteNotFound methodsFor: 'accessing' stamp: ''!
remoteUrl: anObject
	remoteUrl := anObject! !

!IceCloneRemoteNotFound methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor
	aVisitor visitCloneRemoteNotFound: self.! !

!IceCloneRemoteNotFound class methodsFor: 'signalling' stamp: ''!
signalFor: aUrl
	^ self new
		remoteUrl: aUrl;
		signal.! !

!IceCodeDefinition commentStamp: ''!
I am an IceDefinition that have some source code in my contents.

See my sub/superclasses for more information.!
!IceCodeDefinition methodsFor: 'comparing' stamp: ''!
= anotherDefinition

	^ super = anotherDefinition
		and: [ self contents = anotherDefinition contents ]! !

!IceCodeDefinition methodsFor: 'comparing' stamp: ''!
hash

	^ self contents hash! !

!IceCodeDefinition methodsFor: 'patching' stamp: ''!
addModification: anIceModification toPatcher: aMCPatcher 
	
	aMCPatcher
		modifyDefinition: anIceModification rightDefinition asMCDefinition
		to: anIceModification leftDefinition asMCDefinition! !

!IceCodeDefinition methodsFor: 'patching' stamp: ''!
addToPatcher: aMCPatcher 
	
	self subclassResponsibility! !

!IceCodeDefinition methodsFor: 'accessing' stamp: ''!
contents
	
	^ self subclassResponsibility! !

!IceCodeDefinition methodsFor: 'patching' stamp: ''!
removeFrom: aPatcher
	
	self subclassResponsibility! !

!IceCodeDefinition methodsFor: 'patching' stamp: ''!
removeFromPatcher: aMCPatcher 
	
	self subclassResponsibility! !

!IceCodeDefinition class methodsFor: 'instance creation' stamp: ''!
named: aName source: aString
	
	^ (super named: aName)
		source: aString;
		yourself! !

!IceCommit commentStamp: ''!
I represent a repository commit. As such, I hold information about commit message, date, author and id:

  aCommit id.
  aCommit author.
  aCommit datetime.
  aCommit comment.

I also provide operations to access my history:

  aCommit parent.
  aCommit ancestors.
  aCommit isAncestorOf: anotherCommit.
  aCommit isParentOf: anotherCommit.

And to the packages existing in that commit:

  aCommit packageNames.

IMPORTANT IMPLEMENTATION NOTE. For optimization purposes, a commit caches the names of the packages inside himself. This was made under the assumption that a commit is immutble and nobody "cooks" the commit once it is in the repository.!
!IceCommit methodsFor: 'API - history' stamp: ''!
ancestors
	
	^ self subclassResponsibility! !

!IceCommit methodsFor: 'API - history' stamp: ''!
commonAncestorWith: aCommitish
	
	^ aCommitish commonAncestorWithCommit: self! !

!IceCommit methodsFor: 'private - changes' stamp: ''!
changesFromNoCommit: anIceNoCommit 

	^ self packages collect: [ :each | IceImageChange package: each ]! !

!IceCommit methodsFor: 'accessing' stamp: ''!
timeStamp
	
	self subclassResponsibility! !

!IceCommit methodsFor: 'API - tags' stamp: ''!
createTag: aString

	self subclassResponsibility! !

!IceCommit methodsFor: 'testing' stamp: ''!
isMergeCommit
	
	^ self ancestors size > 1! !

!IceCommit methodsFor: 'API - changes' stamp: ''!
diffToWorkingCopyForPackages: aCollection

	^ IceDiff new
		sourceVersion: self;
		targetVersion: self repository workingCopy;
		buildForPackages: aCollection! !

!IceCommit methodsFor: 'private - monticello' stamp: ''!
compatibleUsername
	
	^ 'CompatibleUserName'! !

!IceCommit methodsFor: 'printing' stamp: ''!
description
	
	self tags
		ifNotEmpty: [ :tags |
			^ ', ' join: (tags collect: [ :each | each name ]) ].
		
	^ 'Detached at {1}' format: { self shortId }! !

!IceCommit methodsFor: 'validating' stamp: ''!
validateIsBranch
	"Operation not permitted in a detached commit state"
	IceNotInBranch signal! !

!IceCommit methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self class name;
		nextPutAll: '(';
		nextPutAll: self id asString;
		nextPutAll: ')'! !

!IceCommit methodsFor: 'API - changes' stamp: ''!
diffToWorkingCopyForPackage: aPackage

	^ self diffToWorkingCopyForPackages: { aPackage }! !

!IceCommit methodsFor: 'API - packages' stamp: ''!
packages

	^ self packageNames collect: [ :name | IcePackage named: name repository: self repository ]! !

!IceCommit methodsFor: 'API - packages' stamp: ''!
packageNames
	
	^ self subclassResponsibility! !

!IceCommit methodsFor: 'API - history' stamp: ''!
parent
	
	^ self ancestors first! !

!IceCommit methodsFor: 'API - changes' stamp: ''!
changesTo: aCommitish

	^ aCommitish changesFromCommit: self! !

!IceCommit methodsFor: 'printing' stamp: ''!
status

	(self repository workingCopy referenceCommits includes: self)
		ifTrue: [ 'Current' ].

	(self repository workingCopy referenceCommits
		anySatisfy: [ :each | each isNoCommit not and: [ self isAncestorOf: each ]])
			ifTrue: [ ^ 'Loaded' ].

	(self repository branch newCommitWalk includesCommit: self)
			ifTrue: [ ^ 'Not loaded' ].

	^ 'Not merged'! !

!IceCommit methodsFor: 'accessing' stamp: ''!
commit
	
	^ self! !

!IceCommit methodsFor: 'testing' stamp: ''!
isNoCommit
	
	^ false! !

!IceCommit methodsFor: 'accessing' stamp: ''!
id
	self subclassResponsibility! !

!IceCommit methodsFor: 'accessing' stamp: ''!
datetime
	
	self subclassResponsibility! !

!IceCommit methodsFor: 'API - working copy' stamp: ''!
adopt
	
	"Low level.
	For the working copy to adopt myself as reference commit"
	
	self repository workingCopy adoptCommit: self! !

!IceCommit methodsFor: 'API - changes' stamp: ''!
canRevertChanges
	^ false! !

!IceCommit methodsFor: 'private - changes' stamp: ''!
changedPackagesToWorkingCopy: left 
	
	| leftPackageNames rightPackageNames added removed |
	
	"We do not need to do a double dispatch to calculate a diff.
	diffBetween: a and: b
	  a snapshot difference: b snapshot.
	
	 - Monticello already knows how to do it
	 - the algorithm is in only one place
	 - exploit polymorphism
	"
	self flag: #pharoTodo. "Refactor"
	
	leftPackageNames := left packageNames.
	rightPackageNames := self packageNames.
	added := (leftPackageNames \ rightPackageNames) 
		collect: [ :each | IcePackage named: each repository: self repository ].
	"this will give me the removals, but I'm still don't know what to do with them
	 (because if I just add it it will show them as added not as removed)"
	removed := (rightPackageNames \ leftPackageNames)
		reject: [ :each | self packageNames includes: each ]
		thenCollect: [ :each | IcePackage named: each repository: self repository ].
	
	^ added, ((left modifiedPackages
		reject: [ :p | (leftPackageNames \ rightPackageNames ) includes: p name ])
		collect: [ :mcPackage | IcePackage named: mcPackage name repository: repository ] as: Array),
			removed! !

!IceCommit methodsFor: 'API - history' stamp: ''!
isParentOf: aCommit

	^ self newCommitWalk includesCommit: aCommit! !

!IceCommit methodsFor: 'API - history' stamp: ''!
isAncestorOf: aCommit
	
	^ aCommit isParentOf: self! !

!IceCommit methodsFor: 'accessing' stamp: ''!
author
	
	^ self subclassResponsibility! !

!IceCommit methodsFor: 'testing' stamp: ''!
isUnknownCommit
	
	^ false! !

!IceCommit methodsFor: 'private - monticello' stamp: ''!
mcPackageSnapshotsOfPackages: aCollection
	self flag: #pharoTodo. "I'm not sure I need to answer an empty snapshot. 
	if there is no mcVersion it likely means the package was removed and an empty snapshow will 
	keep it there."
	^ aCollection
		select: #isLoaded
		thenCollect: [ :package |
			[ (self repository mcVersionFor: 
				(IceSavedPackageVersion fromCommit: self package: package mcPackage))
					snapshot ]
			on: IceVersionDoesNotExist 
			do: [ :e | MCSnapshot empty ] ]! !

!IceCommit methodsFor: 'testing' stamp: ''!
hasMultipleAncestors
	| ancestors |
	ancestors := self ancestors.
	^ ancestors notNil 
		and: [ ancestors size > 1 ]! !

!IceCommit methodsFor: 'testing' stamp: ''!
isMerged
	
	^ self repository workingCopy isCommitMerged: self! !

!IceCommit methodsFor: 'API - tags' stamp: ''!
tags
	
	^ self repository tags select: [ :each | each commit = self ]! !

!IceCommit methodsFor: 'API - project' stamp: ''!
project
	
	self subclassResponsibility! !

!IceCommit methodsFor: 'private - changes' stamp: ''!
versionFor: aPackage
	
	^ IceSavedPackageVersion fromCommit: self package: aPackage! !

!IceCommit methodsFor: 'accessing' stamp: ''!
comment
	
	self subclassResponsibility! !

!IceCommit methodsFor: 'API - changes' stamp: ''!
diffToWorkingCopy
	^ self diffTo: self repository workingCopy! !

!IceCommit methodsFor: 'accessing' stamp: ''!
name

	^ self id! !

!IceCommit methodsFor: 'API - packages' stamp: ''!
includesPackageNamed: aName
	
	^ self packageNames includes: aName! !

!IceCommit methodsFor: 'API - history' stamp: ''!
newCommitWalk

	^ repository newCommitWalk fromCommit: self! !

!IceCommit methodsFor: 'API - changes' stamp: ''!
diffToParent
	"returns a diff between me and my first parent/ancestor"
	^ self diffTo: (self ancestors
			ifNotEmpty: #first
			ifEmpty: [ nil ])! !

!IceCommit methodsFor: 'printing' stamp: ''!
shortId
	
	"This is just for presentation purposes.
	Don't trust this id, it is not guaranteed to be unique"
	^ self id first: 7! !

!IceCommit methodsFor: 'API - changes' stamp: ''!
diffFromHead
	^ self repository headCommit diffTo: self! !

!IceCommited commentStamp: ''!
Announces when a repository has commited.!
!IceCommitish commentStamp: ''!
I represent a repository commitish, in other words, an object that is or could be used as a commit.
I am an abstract class presenting the main API of my subclasses.

My main actions are

 - checkout: load all code of a commit into the working copy, and set itself as HEAD.
     aCommitish checkout.

 - checkoutPackageNamed: load the code of a package into the working copy, without setting HEAD.
     aCommitish checkoutPackageNamed: aPackageNameString.

 - merge: merge myself in the working copy
     aCommitish merge.

- switch: set myself as HEAD
    aCommitish switch.

I can also be queried for packages, ancestry and to make diffs to another commitishs:

 aCommitish packageNames.
 aCommitish diffTo: anotherCommitish.

 aCommitish commits.
 aCommitish newCommitWalk.!
!IceCommitish methodsFor: 'API - actions' stamp: ''!
loadPackageNamed: aString 
	"Load the code of the given package into the working copy.
	Does not modify HEAD"
		
	self repository workingCopy
		loadPackageNamed: aString
		fromCommit: self! !

!IceCommitish methodsFor: 'API - history' stamp: ''!
commonAncestorWith: anIceWorkingCopy 

	^ self commit commonAncestorWith: anIceWorkingCopy! !

!IceCommitish methodsFor: 'API - changes' stamp: ''!
changesFromCommit: anIceCommit 

	^ self subclassResponsibility! !

!IceCommitish methodsFor: 'API - history' stamp: ''!
commitsDo: aBlockClosure 
	
	self newCommitWalk commitsDo: aBlockClosure! !

!IceCommitish methodsFor: 'testing' stamp: ''!
isUnbornBranch
	
	^ false! !

!IceCommitish methodsFor: 'API - history' stamp: ''!
commits
	
	^ self newCommitWalk commits! !

!IceCommitish methodsFor: 'validating' stamp: ''!
validateIsBranch
	
	"Nothing. I'm a branch"! !

!IceCommitish methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceCommitish methodsFor: 'API - actions' stamp: ''!
switch

	self checkout: IceCheckoutDoNotLoadPackages new! !

!IceCommitish methodsFor: 'API - packages' stamp: ''!
packages
	
	^ #()! !

!IceCommitish methodsFor: 'API - packages' stamp: ''!
packageNames
	
	^ self subclassResponsibility! !

!IceCommitish methodsFor: 'API - tags' stamp: ''!
tagNames
	
	^ self tags collect: #name! !

!IceCommitish methodsFor: 'API - cherry-picking' stamp: ''!
cherryPickFrom: anotherCommit 
	
	^ anotherCommit cherryPickTo: self! !

!IceCommitish methodsFor: 'testing' stamp: ''!
isDetached

	^ self isBranch not! !

!IceCommitish methodsFor: 'API - changes' stamp: ''!
changesTo: aCommitish

	^ self commit changesTo: aCommitish! !

!IceCommitish methodsFor: 'accessing' stamp: ''!
commit
	
	self subclassResponsibility! !

!IceCommitish methodsFor: 'private - monticello' stamp: ''!
mcVersionFor: anIceSavedPackageVersion 
	
	^ repository mcVersionFor: anIceSavedPackageVersion! !

!IceCommitish methodsFor: 'API - actions' stamp: ''!
switchAndMergeWorkingCopy
	self switch.
	self flag: #pharoTodo. "Demeters law"
	self repository workingCopy referenceCommit merge.
	self commit merge! !

!IceCommitish methodsFor: 'testing' stamp: ''!
isBranch
	
	^ false! !

!IceCommitish methodsFor: 'cherry-picking' stamp: ''!
cherryPickTo: anotherCommit 

	| initialDiff extendedDiff commonAncestor receiverDiff |
	
	initialDiff := self commit diffToParent.
	commonAncestor := self commonAncestorWith: anotherCommit commit.
   extendedDiff := self diffTo: commonAncestor.
	receiverDiff := anotherCommit commit diffTo: commonAncestor.

	^ IceCherrypicker new
		sourceDiff: initialDiff;
		targetDiff: extendedDiff;
		receiverToAncestorDiff: receiverDiff;
		execute.
	
! !

!IceCommitish methodsFor: 'validating' stamp: ''!
validateCanMerge

	| imageCommit headCommit mergeCommit |
	self repository isModified
		ifTrue: [ IceExperimentalFeature signal: 'Experimental Feature: merge when there is a dirty working copy. Could cause a loss of your local changes. Please commit before merge.' ].
	
	imageCommit := self repository workingCopy referenceCommit.
	headCommit := self repository headCommit.
	mergeCommit := self commit.
	
	{ mergeCommit . imageCommit . headCommit } asSet size > 2
		ifTrue: [ 
			IceMergeAborted signal: ('Cannot perform a tri-merge. You are trying to merge {1} into {2}, but the image is in {3}. Please, procceed to load either {1} or {2} in your image to merge.'
				format: { 
					mergeCommit description.
					self repository head description.
					imageCommit description }) ].! !

!IceCommitish methodsFor: 'API - changes' stamp: ''!
diffTo: aCommitish

	^ IceDiff from: self to: aCommitish! !

!IceCommitish methodsFor: 'API - checkout' stamp: ''!
checkout: aCheckoutStrategy
	
	aCheckoutStrategy committish: self.
	^ repository checkout: aCheckoutStrategy! !

!IceCommitish methodsFor: 'testing' stamp: ''!
isTag
	
	^ false! !

!IceCommitish methodsFor: 'API - tags' stamp: ''!
tags
	
	^ self commit tags! !

!IceCommitish methodsFor: 'API - actions' stamp: ''!
checkout
		
	self checkout: (IceCheckoutAlreadyLoadedPackages new
		committish: self;
		yourself)! !

!IceCommitish methodsFor: 'API - project' stamp: ''!
project
	
	self subclassResponsibility! !

!IceCommitish methodsFor: 'private - monticello' stamp: ''!
versionFor: aPackage

	self subclassResponsibility! !

!IceCommitish methodsFor: 'API - actions' stamp: ''!
merge
	
	^ self repository workingCopy mergeCommit: self commit! !

!IceCommitish methodsFor: 'API - actions' stamp: ''!
checkoutWithStrategy: aCheckoutStrategy
	"Load code of a myself into the working copy (following strategy), and set myself as HEAD."
	
	repository checkout: (aCheckoutStrategy commitish: self)! !

!IceCommitish methodsFor: 'API - properties' stamp: ''!
properties
	^ IceRepositoryProperties
		fromFileReferenceDirectory: self project sourceDirectoryReference
		commitish: self! !

!IceCommitish methodsFor: 'API - packages' stamp: ''!
includesPackageNamed: aString
	
	^ false! !

!IceCommitish methodsFor: 'API - history' stamp: ''!
newCommitWalk

	self subclassResponsibility! !

!IceCommitish methodsFor: 'API - properties' stamp: ''!
readerClass
	
	^ self commit readerClass! !

!IceCommitish methodsFor: 'API - properties' stamp: ''!
writerClass
	
	^ self commit writerClass! !

!IceCommitish methodsFor: 'API - changes' stamp: ''!
diffToParent

	^ self diffTo: self parent! !

!IceCommitish methodsFor: 'testing' stamp: ''!
isWorkingCopy
	
	^ false! !

!IceCommitish methodsFor: 'private - monticello' stamp: ''!
snapshotForPackage: anIceSavedPackage

	^ [ (self mcVersionFor: (self versionFor: anIceSavedPackage)) snapshot ]
		on: IceVersionDoesNotExist 
		do: [ MCSnapshot empty ]! !

!IceCommitish methodsFor: 'accessing' stamp: ''!
repository: aRepository
	
	repository := aRepository! !

!IceCommitish methodsFor: 'API - actions' stamp: ''!
checkoutAllPackages
		
	repository checkout: (IceCheckoutAllPackages new
		committish: self;
		yourself)! !

!IceCommitish class methodsFor: 'instance creation' stamp: ''!
inRepository: aRepository

	^ self new
		repository: aRepository;
		yourself! !

!IceConflictingOperation commentStamp: ''!
I reprensent a conflict between two operations that can be solved by using #selectLeft and #selectRight.!
!IceConflictingOperation methodsFor: 'accessing' stamp: ''!
leftContents
	
	^ leftOperation leftContents! !

!IceConflictingOperation methodsFor: 'accessing' stamp: ''!
leftOperation: anOperation
	
	leftOperation := anOperation! !

!IceConflictingOperation methodsFor: 'morphic - compatibility' stamp: ''!
contextClass
	
	^ leftOperation contextClass! !

!IceConflictingOperation methodsFor: 'accessing' stamp: ''!
key
	
	"Any of my operations should have the same key"
	^ leftOperation key! !

!IceConflictingOperation methodsFor: 'resolution' stamp: ''!
selectRight
	
	chosen := rightOperation! !

!IceConflictingOperation methodsFor: 'accessing' stamp: ''!
description
	
	"Any of my instances should have the same description"
	^ leftOperation description! !

!IceConflictingOperation methodsFor: 'accessing' stamp: ''!
rightContents
	
	^ rightOperation leftContents! !

!IceConflictingOperation methodsFor: 'resolution' stamp: ''!
chosenOperation

	^ chosen! !

!IceConflictingOperation methodsFor: 'resolution' stamp: ''!
isRightChosen
	
	^ chosen = rightOperation! !

!IceConflictingOperation methodsFor: 'resolution' stamp: ''!
isLeftChosen
	
	^ chosen = leftOperation! !

!IceConflictingOperation methodsFor: 'morphic - compatibility' stamp: ''!
actualClass
	
	^ leftOperation definition actualClass! !

!IceConflictingOperation methodsFor: 'accessing' stamp: ''!
definition
	
	"This is just for compatibility"
	^ leftOperation definition! !

!IceConflictingOperation methodsFor: '*Iceberg-TipUI' stamp: ''!
preferredColor
	
	^ self isResolved
		ifTrue: [ Color gray ]
		ifFalse: [ Color red ]! !

!IceConflictingOperation methodsFor: 'resolution' stamp: ''!
selectLeft
	
	chosen := leftOperation! !

!IceConflictingOperation methodsFor: 'testing' stamp: ''!
isConflict

	^ true! !

!IceConflictingOperation methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitConflictingOperation: self! !

!IceConflictingOperation methodsFor: 'accessing' stamp: ''!
rightOperation: anOperation
	
	rightOperation := anOperation! !

!IceConflictingOperation methodsFor: '*Iceberg-TipUI' stamp: ''!
operationIcon
	^ self iconNamed: #changeUpdate! !

!IceConflictingOperation class methodsFor: 'instance creation' stamp: ''!
left: leftOperation right: rightOperation
	
	^ self new
		leftOperation: leftOperation;
		rightOperation: rightOperation;
		yourself! !

!IceConvertFormatAction methodsFor: 'private' stamp: ''!
migratePackage: packageName commit: commit
	| filetreePackage srcDir subDirWithDelim mcVersion |
	
	srcDir := self codeDirectory.
	subDirWithDelim := self codeDirectoryWithDelim.
	
	mcVersion := (commit versionFor: packageName) mcVersion.
	mcVersion := self ensureMCVersionWithClassOrganisation: mcVersion.
	mcVersion := self ensureMCClassOrganisationHasCorrectStructure: mcVersion.
	self writerClass 
		forInternalStoreFileOut: mcVersion 
		on: repository.
	filetreePackage := commit writerClass directoryNameFor: packageName.
	(srcDir / filetreePackage) ensureDeleteAll.
	self repository addFilesToIndex: { 
		subDirWithDelim, (IceLibgitTonelWriter directoryNameFor: packageName).
		subDirWithDelim, (IceLibgitFiletreeWriter directoryNameFor: packageName) }! !

!IceConvertFormatAction methodsFor: 'private' stamp: ''!
obtainCommonCategory: aString from: aCollection

   	^ (aCollection allSatisfy: [ :each | each beginsWith: aString ])
 		ifTrue: [ aString ]
 		ifFalse: [ 
 			(aString includes: $-) 
 				ifTrue: [ self obtainCommonCategory: (aString copyUpToLast: $-) from: aCollection ]
 				ifFalse: [ '' ] ] ! !

!IceConvertFormatAction methodsFor: 'accessing' stamp: ''!
format
	^ format! !

!IceConvertFormatAction methodsFor: 'accessing' stamp: ''!
mergeWithCurrentBranch: anObject
	mergeWithCurrentBranch := anObject! !

!IceConvertFormatAction methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceConvertFormatAction methodsFor: 'execution' stamp: ''!
execute
	| oldBranch newBranch |

	oldBranch := self repository branch.
	self migrateSources.
	newBranch := self repository branch.	
	self isMergeWithCurrentBranch ifTrue: [
		oldBranch checkout: IceCheckoutDoNotLoadPackages new.
		newBranch merge ]! !

!IceConvertFormatAction methodsFor: 'accessing' stamp: ''!
branchName
	^ branchName! !

!IceConvertFormatAction methodsFor: 'accessing' stamp: ''!
codeDirectoryWithDelim
	 ^ self repository subdirectory isEmptyOrNil 
		ifTrue: [ '' ]
		ifFalse: [ self repository subdirectory, '/' ]! !

!IceConvertFormatAction methodsFor: 'private' stamp: ''!
removeFiletreeRemnants
	"remove .filetree remaining"
	| filetreeFiles |
	
	filetreeFiles := self codeDirectory allChildrenMatching: '.filetree'.
	filetreeFiles do: #ensureDelete.
	self repository addFilesToIndex: (filetreeFiles collect: [ :each | 
		((each relativeTo: self codeDirectory) printWithDelimiter: $/) ]).
	! !

!IceConvertFormatAction methodsFor: 'private' stamp: ''!
migrateSources
	| commit |
	
	"branch if you want to perform the migration on separated place (you 
	can later do a PR)"
	self repository createBranch: self branchName.

	commit := self repository branch commit.
	self repository workingCopy packages do: [ :each | 
		self 
			migratePackage: each 
			commit: commit ].

	(self repository workingCopy fileSystem resolve: self repository properties propertiesFilePath)
		ensureDelete;
		binaryWriteStreamDo: [ :stream |
			stream nextPutAll: (self repository properties
				fileFormatId: self format;
				contentsString)  ].
	self repository addFileToIndex: self repository properties propertiesFilePath.
	
	self format = #filetree ifFalse: [ 
		self removeFiletreeRemnants ].
	
	"commit"
	self repository 
		commitIndexWithMessage: 'sources migrated' 
		andParents: { commit }.! !

!IceConvertFormatAction methodsFor: 'accessing' stamp: ''!
writerClass
	
	^ format = #tonel
		ifTrue: [ IceLibgitTonelWriter ]
		ifFalse: [ IceLibgitFiletreeWriter ]! !

!IceConvertFormatAction methodsFor: 'testing' stamp: ''!
isMergeWithCurrentBranch
	^ mergeWithCurrentBranch! !

!IceConvertFormatAction methodsFor: 'accessing' stamp: ''!
codeDirectory
	^ self repository codeDirectory! !

!IceConvertFormatAction methodsFor: 'private' stamp: ''!
ensureMCVersionWithClassOrganisation: mcVersion
	"if a package does not has class organisation (happens when package is composed 
	 only for extensions, we need to ensure it has one, otherwise package creation will 
	 fail"

	^ mcVersion snapshot definitions 
		detect: [ :each | each isClassDefinition ]
		ifFound: [ :each | mcVersion ]
		ifNone: [ 
			MCVersion 
				package: mcVersion package
				info: mcVersion info
				snapshot: (MCSnapshot fromDefinitions: (
					{ MCOrganizationDefinition categories: { mcVersion package name }}, 
					mcVersion snapshot definitions)) ]! !

!IceConvertFormatAction methodsFor: 'private' stamp: ''!
ensureMCClassOrganisationHasCorrectStructure: mcVersion
 	| organisation |

   	organisation := mcVersion snapshot definitions 
 		detect: [ :each | each isOrganizationDefinition ].

   	(organisation categories size = 1) ifFalse: [ | baseCategory |
 		baseCategory := self 
 			obtainCommonCategory: organisation categories first 
 			from: organisation categories.
 		baseCategory ifEmpty: [ 
 			self error: 'I didn''t find a base category, something is wrong with the package definition' ].
 		baseCategory = organisation categories first ifFalse: [ 
 			organisation categories: (organisation categories copyWithFirst: baseCategory) ] ].

   	^ mcVersion  ! !

!IceConvertFormatAction methodsFor: 'accessing' stamp: ''!
format: anObject
	format := anObject! !

!IceConvertFormatAction methodsFor: 'accessing' stamp: ''!
branchName: anObject
	branchName := anObject! !

!IceConvertFormatAction methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceCreateBranchCommand commentStamp: ''!
I'm a command to create a new branch from a commit. 
this is usefull in the case of commiting changes in unsync repositories (so you open a branch and you commit there)!
!IceCreateBranchCommand methodsFor: 'execute' stamp: ''!
execute
	| selection |
	selection := UIManager default
		request: 'Please provide the name of the new branch to be created'
		initialAnswer: ''
		title: 'Create new branch'.
	selection isEmptyOrNil ifTrue: [ ^ self ].
	self repository createBranch: selection.
	self beSuccess! !

!IceCredentialStore commentStamp: ''!
I am the responsible for storing the credentials. 
Now I can store plain text credentials and SSH key pairs. 

I store the credentials in a fuel file, this is non encrypted. So it should be improved later.

There is a default instance that stores the credentials in a file per image, in the pharo-local directory.
In the settings you can modify the location of the credentials file.!
!IceCredentialStore methodsFor: 'API - storing' stamp: ''!
saveIntoStore

	| serializer |
	
	self flag: #pharoTodo. "implement an encrypted version"
		
	storeFile ifNotNil: [  	
		storeFile parent ensureCreateDirectory.	
		
		storeFile resolve binaryWriteStreamDo: [ :stream | 
			serializer := FLSerializer on:  stream.
			serializer serialize: {plainCredentials. sshCredentials}]
	]! !

!IceCredentialStore methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	plainCredentials := Dictionary new.
	sshCredentials := Dictionary new.! !

!IceCredentialStore methodsFor: 'API - accessing' stamp: ''!
allCredentials
	self loadFromStore.
	self defaultSSHCredential.
	
	^ plainCredentials values , sshCredentials values! !

!IceCredentialStore methodsFor: 'API - storing' stamp: ''!
loadFromStore

	| array |
	self flag: #pharoTodo. "implement an encrypted version"
	
	"If I don't have a store file I do nothing"
	storeFile ifNil: [ ^ self ].
	
	"If the file is new, I cannot load it."
	storeFile exists ifFalse: [ ^ self ].
	
	array := FLMaterializer materializeFromFileNamed: storeFile resolve pathString.
	plainCredentials := array at: 1.
	sshCredentials := array at: 2.
! !

!IceCredentialStore methodsFor: 'API - accessing' stamp: ''!
storeCredential: credential
 
	self loadFromStore.
	credential storeInto: self forHostname: credential host.
	self saveIntoStore! !

!IceCredentialStore methodsFor: 'testing' stamp: ''!
isCurrent
	^ self == CurrentStore! !

!IceCredentialStore methodsFor: 'API - accessing' stamp: ''!
sshCredentialForHostname: aHostname
 
	^ self lookup: aHostname in: sshCredentials ifAbsent: [ self defaultSSHCredential ].! !

!IceCredentialStore methodsFor: 'API - accessing' stamp: ''!
storeCredential: credential forHostname: aHostname
 
	self loadFromStore.
	credential storeInto: self forHostname: aHostname.
	self saveIntoStore! !

!IceCredentialStore methodsFor: 'API - accessing' stamp: ''!
defaultSSHCredential
	^ sshCredentials
		at: #*
		ifAbsentPut: [ IceSshCredentials new
				host: #*;
				yourself ]! !

!IceCredentialStore methodsFor: 'private - storing' stamp: ''!
removePlainTextCredential: anIcePlaintextCredentials 
	
	plainCredentials removeKey: anIcePlaintextCredentials host! !

!IceCredentialStore methodsFor: 'API - storing' stamp: ''!
removeCredential: aCredential 

	aCredential removeFrom: self.
	self saveIntoStore.! !

!IceCredentialStore methodsFor: 'private - storing' stamp: ''!
storePlaintextCredential: credential forHostname: aHostname
 
	plainCredentials at: aHostname put: credential! !

!IceCredentialStore methodsFor: 'private - storing' stamp: ''!
storeSshCredential: credential forHostname: aHostname
 
	sshCredentials at: aHostname put: credential! !

!IceCredentialStore methodsFor: 'API - accessing' stamp: ''!
plaintextCredentialForHostname: aHostname
 
	^ self lookup: aHostname in: plainCredentials ifAbsent: [ IcePlaintextCredentials new ]! !

!IceCredentialStore methodsFor: 'private - storing' stamp: ''!
removeSSHCredential: aCredential 
	
	sshCredentials removeKey: aCredential host! !

!IceCredentialStore methodsFor: 'accessing' stamp: ''!
storeFile: aFileLocator 
	storeFile := aFileLocator! !

!IceCredentialStore methodsFor: 'private - lookup' stamp: ''!
lookup: aHostName in: dict ifAbsent: aBlock

	self loadFromStore.
	^ dict at: aHostName ifAbsent: aBlock! !

!IceCredentialStore class methodsFor: 'accessing' stamp: ''!
current
	^ CurrentStore
		ifNil: [ CurrentStore := self new
				storeFile: self storeFile;
				yourself ]! !

!IceCredentialStore class methodsFor: 'accessing' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
		
	(aBuilder group: #PlainTextCredentials)
		parent: #Iceberg;
		name: #icebergCredentials;
		noOrdering;
		target: self current;
		label: 'Credentials';
		with: [
			(aBuilder setting: #storeFile)
				target: self;
				type: #FilePathEncoder;
				default: self defaultCredentialsStoreFile;
				label: 'Location of credentials store';
				description: 'The location of the credential store. The password are stored in plain... yet'.
		].	
! !

!IceCredentialStore class methodsFor: 'accessing' stamp: ''!
storeFile
	^ StoreFile ifNil:
		[ StoreFile := self defaultCredentialsStoreFile ]! !

!IceCredentialStore class methodsFor: 'accessing' stamp: ''!
defaultCredentialsStoreFile
	^ FileLocator localDirectory / #iceberg / 'credentials.fuel'! !

!IceCredentialStore class methodsFor: 'accessing' stamp: ''!
storeFile: aValue
	StoreFile := aValue! !

!IceCredentialsProvider commentStamp: ''!
I am in charge of remembering credentials information, configuration and providing it as required by the different backend implementations.

I have a counter to avoid for trying for ever with the same credentials.!
!IceCredentialsProvider methodsFor: 'accessing' stamp: ''!
remote: anObject
	remote := anObject! !

!IceCredentialsProvider methodsFor: 'accessing' stamp: ''!
credentialStore
	^ IceCredentialStore current! !

!IceCredentialsProvider methodsFor: 'initialization' stamp: ''!
initialize
	tries := 0.
! !

!IceCredentialsProvider methodsFor: 'private' stamp: ''!
obtainPlaintextCredentials: response
	self subclassResponsibility! !

!IceCredentialsProvider methodsFor: 'private' stamp: ''!
obtainSshCredentials: response
	self subclassResponsibility! !

!IceCredentialsProvider methodsFor: 'actions' stamp: ''!
provideSshAgentCredentialsTo: credentials
	"Just check for tries to ensure we do not enter an infinite cycle in libgit2"
	tries := tries + 1.
	tries >= 3 ifTrue: [ 
		Transcript show: 'aborting'; cr.
		LGitNoCredentialsProvided signal: 'No ssh-agent credentials found.' ]! !

!IceCredentialsProvider methodsFor: 'accessing' stamp: ''!
plaintextCredentials
	^ self credentialStore plaintextCredentialForHostname: remote host.! !

!IceCredentialsProvider methodsFor: 'accessing' stamp: ''!
sshCredentialsClass
	^ self class sshCredentialsClass! !

!IceCredentialsProvider methodsFor: 'private' stamp: ''!
obtainCredentials: response
	self subclassResponsibility! !

!IceCredentialsProvider methodsFor: 'accessing' stamp: ''!
sshCredentials
	^ IceCredentialStore current sshCredentialForHostname: remote host.! !

!IceCredentialsProvider methodsFor: 'actions' stamp: ''!
providePlaintextCredentials
	^self plaintextCredentials isPresent
		ifTrue: [ self plaintextCredentials copy ]
		ifFalse: [ self providePlaintextCredentialsTo: IcePlaintextCredentials new ].! !

!IceCredentialsProvider methodsFor: 'actions' stamp: ''!
providePlaintextCredentialsTo: credentials
	tries := tries + 1.

	tries >= 3 ifTrue: [ 
		Transcript show: 'aborting'; cr.
		LGitNoCredentialsProvided signal: 'There where already three failed attempts, aborting' ].
	
	tries = 1 & self plaintextCredentials isPresent
		ifTrue: [ credentials readFrom: self plaintextCredentials ]
		ifFalse: [ self obtainPlaintextCredentials: credentials ].

! !

!IceCredentialsProvider methodsFor: 'actions' stamp: ''!
provideSshCredentialsTo: credentials
	tries := tries + 1.

	tries >= 3 ifTrue: [ 
		Transcript show: 'aborting'; cr.
		LGitNoCredentialsProvided signal: 'There where already three failed attempts, aborting' ].
		
	tries = 1 & self sshCredentials isPresent
		ifTrue: [ credentials readFrom: self sshCredentials ]
		ifFalse: [ self obtainSshCredentials: credentials ].! !

!IceCredentialsProvider class methodsFor: 'instance creation' stamp: ''!
defaultForRemote: aRemote
	^ self providerType new
		remote: aRemote;
		yourself! !

!IceCredentialsProvider class methodsFor: 'accessing' stamp: ''!
sshCredentialsClass
	self useCustomSsh ifTrue: [ ^ LGitCredentialsSSH ].
	^ LGitCredentialsSSHAgent
	! !

!IceCredentialsProvider class methodsFor: 'instance creation' stamp: ''!
defaultForHost: aString
	
	^ self defaultForRemote: (IceRemoteWithOnlyHostname for: aString)
! !

!IceCredentialsProvider class methodsFor: 'private' stamp: ''!
providerType
	^ ProviderType ifNil: [ ProviderType := self defaultCredentialProviderClass ]! !

!IceCredentialsProvider class methodsFor: 'instance creation' stamp: ''!
defaultForRemoteUrl: url
	^ self providerType new
		remote: (IceGitRemote url: url);
		yourself! !

!IceCredentialsProvider class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #useCustomSsh)
		parent: #icebergCredentials;
		noOrdering;
		target: self;
		default: false;
		label: 'Use custom SSH keys';
		description:
			'Check if you want to have your own pair of keys (id_rsa and id_rsa.pub), without using the ssh-agent';
		with: [ (aBuilder setting: #username)
				target: self;
				targetSelector: #sshCredentials;
				label: 'SSH Username';
				default: 'git';
				description:
					'If you are trying to connect to github through ssh (something like git@github.com:owner/projectName), the username should be `git`'.
			(aBuilder setting: #publicKey)
				target: self;
				targetSelector: #sshCredentials;
				type: #FilePathEncoder;
				default: IceSshCredentials defaultPublicKey ;
				label: 'Public SSH key';
				description: 'The path to your private ssh key, probably /home/<userName>/.ssh/id_rsa.pub'.
			(aBuilder setting: #privateKey)
				target: self;
				targetSelector: #sshCredentials;
				type: #FilePathEncoder;
				default: IceSshCredentials defaultPrivateKey;
				label: 'Private SSH key';
				description: 'The path to your private ssh key, probably /home/<userName>/.ssh/id_rsa'.
			(aBuilder setting: #keyPassphrase)
				target: self;
				type: #Password;
				default: '';
				targetSelector: #sshCredentials;
				label: 'Passphrase of your SSH key' ]! !

!IceCredentialsProvider class methodsFor: 'accessing' stamp: ''!
useCustomSsh: aBoolean
	UseCustomSsh := aBoolean! !

!IceCredentialsProvider class methodsFor: 'private' stamp: ''!
providerType: anObject
	ProviderType := anObject! !

!IceCredentialsProvider class methodsFor: 'accessing' stamp: ''!
sshCredentials
	"It returns the default ssh credentials to use when not configured new for the host"
	^ IceCredentialStore current defaultSSHCredential ! !

!IceCredentialsProvider class methodsFor: 'private' stamp: ''!
defaultCredentialProviderClass
	| providers  |
	providers := self allSubclasses.
	providers size = 1 ifTrue: [ ^ providers anyOne ].
	^ providers detect: #isDefault! !

!IceCredentialsProvider class methodsFor: 'accessing' stamp: ''!
useCustomSsh
	^ UseCustomSsh ifNil: [ UseCustomSsh := false ]! !

!IceCredentialsProvider class methodsFor: 'private' stamp: ''!
isDefault
	^ false! !

!IceCritiquesVisitor commentStamp: ''!
I am a tree visitor that returns a set of critics to the elements in the collection!
!IceCritiquesVisitor methodsFor: 'visiting' stamp: ''!
visitPackage: anIcePackageDefinition 
	
	| aPackage |
	
	aPackage := RPackage organizer packageNamed: anIcePackageDefinition name ifAbsent: [ ^ self ].
	critiques addAll: aPackage critiques! !

!IceCritiquesVisitor methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	critiques := Set new! !

!IceCritiquesVisitor methodsFor: 'visiting' stamp: ''!
visitRemoval: anIceRemoval 
	
	"We do nothing on removal"! !

!IceCritiquesVisitor methodsFor: 'visiting' stamp: ''!
visitClassDefinition: anIceClassDefinition

	anIceClassDefinition canBeBrowsed ifTrue: [ 
		critiques addAll: anIceClassDefinition actualClass critiques ]! !

!IceCritiquesVisitor methodsFor: 'accessing' stamp: ''!
critiques
	^ critiques! !

!IceCritiquesVisitor methodsFor: 'visiting' stamp: ''!
visitAddition: anIceAddition 
	
	^ anIceAddition definition accept: self! !

!IceCritiquesVisitor methodsFor: 'visiting' stamp: ''!
visitExtensionDefinition: anIceExtension 
	"^ anIceExtension definition accept: self"
	| actualClass methods |
	actualClass := anIceExtension actualClass.
	methods := actualClass methodsInProtocol: '*', anIceExtension packageName.
	methods do: [ :method | critiques addAll: method critiques ].
	
	! !

!IceCritiquesVisitor methodsFor: 'visiting' stamp: ''!
visitMethodNode: anIceMethodDefinition 

	anIceMethodDefinition canBeBrowsed 
		ifTrue: [ critiques addAll: (anIceMethodDefinition contextClass >> anIceMethodDefinition name) critiques ]! !

!IceCritiquesVisitor methodsFor: 'visiting' stamp: ''!
visitAll: aCollection

	aCollection
		do: [ :each | each accept: self ]
		displayingProgress: [ :each | 'Calculating Critiques...' ]! !

!IceCritiquesVisitor methodsFor: 'visiting' stamp: ''!
visitModification: anIceModification 

	^ anIceModification definition accept: self! !

!IceCritiquesVisitor methodsFor: 'visiting' stamp: ''!
visitNoModification: anIceNoModification 
	
	"If there is no modification I don't generate critics for this node"! !

!IceCritiquesVisitor methodsFor: 'visiting' stamp: ''!
visitFileNode: anIceFileDefinition 
	
	! !

!IceCypressPropertiesChange methodsFor: 'displaying' stamp: ''!
displayingProgressString
	^ 'Comparing Cypress changes'! !

!IceCypressPropertiesChange methodsFor: 'visiting' stamp: ''!
accept: anIceChangeImporter 
	
	anIceChangeImporter visitCypressPropertiesChange: self! !

!IceDefinedDependency commentStamp: ''!
I am a dependency for the IceDefinitions that have a MCDefinition.!
!IceDefinedDependency methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."
	self == anObject
		ifTrue: [ ^ true ].
	self species = anObject species
		ifFalse: [ ^ false ].
	^ definition className = anObject definition className! !

!IceDefinedDependency methodsFor: 'dependencies' stamp: ''!
referencedTraits

	^ self subclassResponsibility ! !

!IceDefinedDependency methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ definition className hash! !

!IceDefinedDependency methodsFor: 'dependencies' stamp: ''!
referencedClasses

	^ self subclassResponsibility ! !

!IceDefinedDependency methodsFor: 'dependencies' stamp: ''!
referencedPackages
	^ self subclassResponsibility! !

!IceDefinedDependency methodsFor: 'dependencies' stamp: ''!
addTransitiveDependenciesFrom: anIceDiff to: anIceCherrypicker
	| asDependencyVisitor |
	asDependencyVisitor := IceAsDependencyVisitor new.
	asDependencyVisitor cherrypicker: anIceCherrypicker .

	self referencedClasses
		do: [ :aName | 
			IceNodeQuery new
				on: anIceDiff tree;
				className: aName;
				execute;
				ifFound:
						[ :iceNode | anIceCherrypicker addDependency: (iceNode accept: asDependencyVisitor) ] ].

	self referencedTraits
		do: [ :aName | 
			IceNodeQuery new
				on: anIceDiff tree;
				traitName: aName;
				execute;
				ifFound:
						[ :iceNode | anIceCherrypicker addDependency: (iceNode accept: asDependencyVisitor) ] ].

	self referencedPackages
		do: [ :aName | 
			IceNodeQuery new
				on: anIceDiff tree;
				packageName: aName;
				execute;
				ifFound:
						[ :iceNode | anIceCherrypicker addDependency: (iceNode accept: asDependencyVisitor) ] ]! !

!IceDefinedDependency methodsFor: 'accessing' stamp: ''!
definition: anObject
	definition := anObject! !

!IceDefinedDependency methodsFor: 'accessing' stamp: ''!
definition
	^ definition! !

!IceDefinition commentStamp: ''!
I represent the definition of an element in an Iceberg repository. My subclasses represent more concretely classes, traits, extensions, methods and files.

I am used to easily read and write from a repository working copy or commit. The Filetree or Tonel parser create IceDefinitions that are later on used to browse, generate diffs, or merges.

My main API is used to show myself in a diff or merge browser:

 - contents: textual value of the definition (e.g., the code of a class or a method, the contents of a file)
 - icon: the preferred icon to show this entity
 - accept: visitor API
 - is* to test which of my subclasses you're working with

I am also used for comparison to build diffs. See my definitions of equality along my subclasses.!
!IceDefinition methodsFor: 'testing' stamp: ''!
isFileDefinition
	
	^ false! !

!IceDefinition methodsFor: 'comparing' stamp: ''!
= anotherDefinition

	^ self species = anotherDefinition species
		and: [ self name = anotherDefinition name ]! !

!IceDefinition methodsFor: 'comparing' stamp: ''!
hash

	^ self name hash! !

!IceDefinition methodsFor: 'testing' stamp: ''!
isDirectoryDefinition
	
	^ false! !

!IceDefinition methodsFor: 'testing' stamp: ''!
isPackageDefinition
	
	^ false! !

!IceDefinition methodsFor: 'morphic - compatibility' stamp: ''!
contextClass
	
	^ nil! !

!IceDefinition methodsFor: 'accessing' stamp: ''!
key
	
	^ name! !

!IceDefinition methodsFor: 'testing' stamp: ''!
isTraitDefinition
	
	^ false! !

!IceDefinition methodsFor: 'testing' stamp: ''!
isClassDefinition
	
	^ false! !

!IceDefinition methodsFor: 'accessing' stamp: ''!
name
	
	^ name! !

!IceDefinition methodsFor: 'accessing' stamp: ''!
name: aString 
	
	name := aString! !

!IceDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	
	self subclassResponsibility! !

!IceDefinition methodsFor: 'testing' stamp: ''!
isMethodDefinition
	
	^ false! !

!IceDefinition methodsFor: 'testing' stamp: ''!
isExtensionDefinition
	
	^ false! !

!IceDefinition methodsFor: 'accessing' stamp: ''!
contents
	
	self subclassResponsibility! !

!IceDefinition methodsFor: 'visiting' stamp: ''!
removeFrom: aVisitor
	
	self subclassResponsibility! !

!IceDefinition methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	self subclassResponsibility! !

!IceDefinition methodsFor: 'testing' stamp: ''!
isRootDefinition
	
	^ false! !

!IceDefinition class methodsFor: 'instance creation' stamp: ''!
named: aString 
	
	^ self new
		name: aString;
		yourself! !

!IceDependency commentStamp: ''!
I am a dependency of an IceDefinition in a IceDiff.
!
!IceDependency methodsFor: 'adding' stamp: ''!
isDependencyTo: aDefinition
	^ self subclassResponsibility! !

!IceDependency methodsFor: 'accessing' stamp: ''!
cherrypicker: anIceCherrypicker
	cherrypicker :=anIceCherrypicker ! !

!IceDependency methodsFor: 'adding' stamp: ''!
addTransitiveDependenciesFrom: anIceDiff to: anIceCherrypicker
	^ self subclassResponsibility! !

!IceDependency methodsFor: 'accessing' stamp: ''!
cherrypicker 
	^ cherrypicker ! !

!IceDependencyEnvironment methodsFor: 'accessing' stamp: ''!
allSubclassesNamesOf: aName

	| result |
	result := self subclassNamesOf: aName.
	result ifEmpty: [ ^ result ].
	
	^ result , (result flatCollect: [ :e | self allSubclassesNamesOf: e ]).! !

!IceDependencyEnvironment methodsFor: 'private' stamp: ''!
definitions

	^ definitions
		ifNil: [ 
			definitions := commit packages flatCollect: [ :package | (commit snapshotForPackage: package) definitions ] ]! !

!IceDependencyEnvironment methodsFor: 'accessing' stamp: ''!
traits
	^ self definitions select: [ :e | e isTraitDefinition ]! !

!IceDependencyEnvironment methodsFor: 'accessing' stamp: ''!
commit: anIceGitCommit 
	commit := anIceGitCommit! !

!IceDependencyEnvironment methodsFor: 'querying' stamp: ''!
subclassNamesOf: aString
	^ self classes
		select: [ :e | e superclassName = aString ]
		thenCollect: [ :e | e className ]! !

!IceDependencyEnvironment methodsFor: 'accessing' stamp: ''!
allUsingTraitNamed: aName 
	| result |
	result := self usersOfTraitNamed: aName.
	result ifEmpty: [ ^ result ].

	^ result
		, (result flatCollect: [ :e | self allUsingTraitNamed:  e ])! !

!IceDependencyEnvironment methodsFor: 'accessing' stamp: ''!
usersOfTraitNamed: aName 
	^ (self traits , self classes) 
		select: [ :e | e traitComposition includesSubstring: aName ]
		thenCollect: [ :e | e className ]! !

!IceDependencyEnvironment methodsFor: 'querying' stamp: ''!
classes
	
	^ self definitions select: [ :e | e isClassDefinition ]! !

!IceDependencyEnvironment class methodsFor: 'instance creation' stamp: ''!
on: anIceGitCommit 
	^ self new 
	commit: anIceGitCommit;
	yourself ! !

!IceDiff commentStamp: ''!
I am a diff between two Iceberg Commitish's. I calculate a diff by:

 - Asking to the repository the list of changed files/packages between the two versions. These are obtained, for example, by the Monticello dirty flags and the list of modified files provided by Git.
 - Using that list, the diff calculates two trees of IceDefinition. Those trees are represented as compositions of IceNode.
 - Then, the two trees are diff'd (see #diff:with:), and a tree of differences is obtained. This tree is also a composition of IceNodes, but contains IceOperation objects instead (additions, deletions and modifications).

The diff is calculated from left to right. This means that the resulting operations are the operations to apply on the right tree (the destination) to obtain the same tree as in the left (the source).

I am created by doing one of the following:

- IceDiff from: aVersion to: anotherVersion.

- IceDiff new
	sourceVersion: aVersion;
	targetVersion: anotherVersion;
	build;
	yourself!
!IceDiff methodsFor: 'building' stamp: ''!
imageChanges

	^ self imageChangesForPackages: source loadedPackages! !

!IceDiff methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ tree isEmpty! !

!IceDiff methodsFor: 'converting' stamp: ''!
packageNameFromDirectory: aString 
	
	^ self writerClass packageNameFromDirectory: aString! !

!IceDiff methodsFor: 'testing' stamp: ''!
isValidPackage: aFileReference
	
	^ self writerClass isValidPackage: aFileReference! !

!IceDiff methodsFor: 'accessing' stamp: ''!
targetVersion
	
	^ target! !

!IceDiff methodsFor: 'accessing' stamp: ''!
mergedTree
	^ mergedTree! !

!IceDiff methodsFor: 'accessing' stamp: ''!
description
	
	^ target description! !

!IceDiff methodsFor: 'accessing' stamp: ''!
repository
	
	^ source repository! !

!IceDiff methodsFor: 'accessing' stamp: ''!
sourceVersion
	
	^ source! !

!IceDiff methodsFor: 'accessing' stamp: ''!
targetVersion: aCommitish
	
	target := aCommitish! !

!IceDiff methodsFor: 'building' stamp: ''!
buildForChanges: aCollection

	| leftTree rightTree |
	leftTree := IceNode value: IceRootDefinition new.
	rightTree := IceNode value: IceRootDefinition new.

	aCollection do: [ :change | 
		change accept: (IceChangeImporter new
			version: source;
			diff: self;
			parentNode: leftTree;
			yourself).
			
		change accept: (IceChangeImporter new
			version: target;
			diff: self;
			parentNode: rightTree;
			yourself) ] "displayingProgress: [ :change | change displayingProgressString ]".

	mergedTree := self mergedTreeOf: leftTree with: rightTree.
	tree := mergedTree select: [ :operation | operation hasChanges ].! !

!IceDiff methodsFor: 'testing' stamp: ''!
isCodeSubdirectory: aNode
	
	| nodeLocation repositorySubdirectoryLocation |
	nodeLocation := self repository location resolve: aNode path.
	repositorySubdirectoryLocation := self repository subdirectoryReference.
	^ nodeLocation pathString = repositorySubdirectoryLocation pathString! !

!IceDiff methodsFor: 'accessing' stamp: ''!
packages
	
	tree isEmpty ifTrue: [ ^ #( ) ].
	^ self codeSubdirectoryNode children! !

!IceDiff methodsFor: 'building' stamp: ''!
build

	self buildForChanges: (source changesTo: target)! !

!IceDiff methodsFor: 'accessing' stamp: ''!
diffTree: anIceTreeDiff

	tree := anIceTreeDiff! !

!IceDiff methodsFor: 'accessing' stamp: ''!
codeSubdirectoryNode
	
	^ self repository subdirectory
		ifNotEmpty: [ tree firstNodeSuchThat: [ :definition | self isCodeSubdirectory: definition ] ]
		ifEmpty: [ tree ]
		! !

!IceDiff methodsFor: 'building' stamp: ''!
buildFull

	"Image changes should be processed before commit changes
	to take into account changes in the image"
	self buildForChanges: self imageChanges, (source referenceCommit changesTo: target) asArray! !

!IceDiff methodsFor: 'testing' stamp: ''!
canRevertChanges
	
	^ source canRevertChanges! !

!IceDiff methodsFor: 'operations' stamp: ''!
diff: leftTree with: rightTree

	^ (self mergedTreeOf: leftTree with: rightTree)
		select: [ :operation | operation hasChanges ]! !

!IceDiff methodsFor: 'operations' stamp: ''!
mergedTreeOf: leftTree with: rightTree
	
	^ leftTree
		mergeWith: rightTree
		onLeft: [ :definition | IceAddition definition: definition ]
		onRight: [ :definition | IceRemoval definition: definition ]
		onMerge: [ :left :right |
			left = right
				ifTrue: [ IceNoModification definition: left ]
				ifFalse: [ IceModification left: left right: right ] ]! !

!IceDiff methodsFor: 'accessing' stamp: ''!
treeToShow
	"Returns the tree to show in the UI.
	For a diff it is always the same tree.
	Polymorphic with an ice merge"
	^ self tree! !

!IceDiff methodsFor: 'accessing' stamp: ''!
tree
	^ tree! !

!IceDiff methodsFor: 'building' stamp: ''!
buildForPackages: aCollection

	self buildForChanges: (aCollection collect: [ :package | IceImageChange package: package ])! !

!IceDiff methodsFor: 'copying' stamp: ''!
copyWithOnly: aCollection 
	
	| treeCopy selectedOperations |
	selectedOperations := aCollection collect: #value.
	treeCopy := tree select: [ :node | selectedOperations includes: node ].
	
	^ self class new
		sourceVersion: source;
		targetVersion: target;
		diffTree: treeCopy;
		yourself! !

!IceDiff methodsFor: 'building' stamp: ''!
buildForAllFiles

	| files changes |
	files := (source fileSystem childNames, target fileSystem childNames) asSet.
	changes := files collect: [ :each | IceGitChange on: each ].
	
	self buildForChanges: changes! !

!IceDiff methodsFor: 'building' stamp: ''!
imageChangesForPackages: aCollection

	^ aCollection collect: [ :package | IceImageChange package: package ] as: Array! !

!IceDiff methodsFor: 'converting' stamp: ''!
writerClass
	
	"I am cached per instance of diff because obtaining the writer class is an expensive operation (600ms per call)"
	^ writerClass ifNil: [ writerClass := self repository writerClass ]! !

!IceDiff methodsFor: 'testing' stamp: ''!
includesPackageNamed: aString
	^ self isEmpty not
		and: [ self codeSubdirectoryNode includesKey: aString ]! !

!IceDiff methodsFor: 'accessing' stamp: ''!
sourceVersion: aCommitish
	
	source := aCommitish! !

!IceDiff methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ tree accept: aVisitor! !

!IceDiff class methodsFor: 'instance creation' stamp: ''!
from: sourceCommitish to: targetCommitish
	
	^ self new
		sourceVersion: sourceCommitish;
		targetVersion: targetCommitish;
		build;
		yourself! !

!IceDirectoryDefinition commentStamp: ''!
I represent a directory inside the iceberg repository. 

My contents is an empty string.

See my superclasses for more information.!
!IceDirectoryDefinition methodsFor: 'testing' stamp: ''!
isDirectoryDefinition
	
	^ true! !

!IceDirectoryDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	^ self iconNamed: #emptyPackage! !

!IceDirectoryDefinition methodsFor: 'accessing' stamp: ''!
contents
	
	^ ''! !

!IceDirectoryDefinition methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitDirectoryDefinition: self! !

!IceDuplicatedRepository commentStamp: ''!
When trying to create a repository I found another one with a conflicting location (i.e. the same director on disk).!
!IceEmptyMerge commentStamp: ''!
I am a null object representing the absence of a merge. I am used when no merge is needed between two versions, for example, in case the commit to merge is already in the image and the commit to merge into is an ancestor of this commit.!
!IceEmptyMerge methodsFor: 'accessing' stamp: ''!
mergeTree
	
	^ IceEmptyNode new! !

!IceEmptyMerge methodsFor: 'accessing' stamp: ''!
tree
	
	^ self mergeTree! !

!IceEmptyNode commentStamp: ''!
I am a null object representing an empty node of a tree. I'm used together with IceNode.!
!IceEmptyNode methodsFor: 'enumerating' stamp: ''!
firstNodeSuchThat: conditionBlock ifNone: noneBlock
	
	^ (conditionBlock value: self)
		ifTrue: [ self ]
		ifFalse: noneBlock! !

!IceEmptyNode methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ true! !

!IceEmptyNode methodsFor: 'adding' stamp: ''!
addTo: anotherNode 
	"I'm empty, so I do not add myself to a tree."! !

!IceEmptyNode methodsFor: 'merging' stamp: ''!
mergeWith: anotherNode onLeft: leftBlock onRight: rightBlock onMerge: mergeBlock
	
	^ anotherNode collect: rightBlock! !

!IceEmptyNode methodsFor: 'accessing' stamp: ''!
resolve: aRelativePath ifPresent: presentBlock ifAbsent: absentBlock 
	^ absentBlock value! !

!IceEmptyNode methodsFor: 'enumerating' stamp: ''!
select: aBlockClosure 
	
	^ self! !

!IceEmptyNode methodsFor: 'accessing' stamp: ''!
children
	
	^ #()! !

!IceEmptyNode methodsFor: 'testing' stamp: ''!
isEmptyNode
	
	^ true! !

!IceEmptyNode methodsFor: 'enumerating' stamp: ''!
anySatisfy: aBlockClosure 
	
	^ false! !

!IceEmptyNode methodsFor: 'enumerating' stamp: ''!
collectWithPath: aBlockClosure 
	^ self! !

!IceEmptyNode methodsFor: 'enumerating' stamp: ''!
do: aBlock
	"Do nothing"! !

!IceEmptyNode methodsFor: 'enumerating' stamp: ''!
collect: aBlockClosure 

	^ self! !

!IceEmptyNode methodsFor: 'testing' stamp: ''!
hasChanges
	
	^ false! !

!IceEmptyNode methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitEmptyNode: self! !

!IceEmptyNode methodsFor: 'accessing' stamp: ''!
includesKey: aString 
	
	^ false! !

!IceEmptyNode methodsFor: 'accessing' stamp: ''!
path

	^ RelativePath new! !

!IceEmptyWorkingCopy commentStamp: ''!
I am an empty working copy, with no loaded packages.!
!IceEmptyWorkingCopy methodsFor: 'display' stamp: ''!
description
	
	^ 'Nothing loaded'! !

!IceEmptyWorkingCopy methodsFor: 'accessing' stamp: ''!
referenceCommit
	
	^ repository head commit! !

!IceEmptyWorkingCopy methodsFor: 'merging' stamp: ''!
mergeStateWith: aMergeableState
	
	^ aMergeableState mergeWithEmptyWorkingCopyState: self! !

!IceEmptyWorkingCopy methodsFor: 'testing' stamp: ''!
isDetached
	"I have no reference commit, I cannot be detached"
	^ false! !

!IceEmptyWorkingCopy methodsFor: 'validating' stamp: ''!
validateCanCommit
	
	"I've no packages loaded. I can always commit.
	I will commit on top of head."! !

!IceError commentStamp: ''!
Base class for all errors in Iceberg.!
!IceError methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor
	aVisitor visitGenericError: self! !

!IceErrorVisitor commentStamp: ''!
I'm a generic visitor for IceError instances. My subclasses can override my methods to specialize handling.!
!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitCloneRemoteNotFound: anError
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitCloneLocationAlreadyExists: anError 
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: '*Iceberg-TipUI' stamp: ''!
visitExperimentalFeature: aWarning
	
	"By default experimental features are just accepted when we are not in an interactive mode".
	aWarning resume! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitMergeAborted: anError
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitGenericError: anError
	"Just re-send as default (to have a debugger)"
	anError pass! !

!IceErrorVisitor methodsFor: '*Iceberg-TipUI' stamp: ''!
visitNoCommitMessage: aWarning
	self visitGenericError: aWarning! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitWorkingCopyDesynchronizedError: anError
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitShouldCommitBeforePullError: anError
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitNothingToCommitError: anError
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitRemoteDesynchronizedError: anError
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitNoRemote: anError
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitCheckoutConflict: anError
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitMissingCredentialsError: anError
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitRemoteAlreadyExistError: anError
	self visitGenericError: anError! !

!IceErrorVisitor methodsFor: 'visiting' stamp: ''!
visitAuthenticationError: anError
	self visitGenericError: anError! !

!IceExperimentalFeature commentStamp: ''!
Everytime an user tries to use an experimental feature, maybe the UI want to show a confirmation message. 

This is useful to guarantee the correct keeping of the changes.!
!IceExperimentalFeature methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor

	aVisitor visitExperimentalFeature: self! !

!IceExtendedClassDependency methodsFor: 'adding' stamp: ''!
isDependencyTo: anIceDefinition
	^ anIceDefinition name = self definition name! !

!IceExtendedClassDependency methodsFor: 'comparing' stamp: ''!
= anObject
	^ super = anObject and: [ self definition name = anObject definition name ]! !

!IceExtendedClassDependency methodsFor: 'dependencies' stamp: ''!
referencedTraits
	
	^ self referencedClasses ! !

!IceExtendedClassDependency methodsFor: 'comparing' stamp: ''!
hash
	^ super hash bitXor: self definition name hash! !

!IceExtendedClassDependency methodsFor: 'dependencies' stamp: ''!
referencedClasses
	^ {definition name asSymbol }! !

!IceExtendedClassDependency methodsFor: 'dependencies' stamp: ''!
referencedPackages
	^ {self definition packageName}! !

!IceExtendedClassDependency methodsFor: 'visiting' stamp: ''!
visitExtensionDefinition: anIceExtensionDefinition
	^ definition  name = anIceExtensionDefinition name! !

!IceExtensionDefinition commentStamp: ''!
I represent a container of method extensions read from an Iceberg repository, either from a commit or from the working directory in disk.
The package containing this definition will have as many instances of myself as different classes are extended.

My contents is just an empty string as the extended class/trait is not defined in the package.

See my superclasses for more information.!
!IceExtensionDefinition methodsFor: 'comparing' stamp: ''!
= otherExtension
	^ self species = otherExtension species 
		and: [ self name = otherExtension name ]! !

!IceExtensionDefinition methodsFor: 'comparing' stamp: ''!
hash
	^ self name hash! !

!IceExtensionDefinition methodsFor: 'patching' stamp: ''!
addModification: anIceModification toPatcher: aMCPatcher 
	
	"Do nothing. Monticello does not have definitions for extensions"! !

!IceExtensionDefinition methodsFor: 'accessing' stamp: ''!
packageName: anObject
	packageName := anObject! !

!IceExtensionDefinition methodsFor: 'patching' stamp: ''!
addToPatcher: aMCPatcher 
	
	"Monticello does not reify extensions"! !

!IceExtensionDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	^ self iconNamed: #group! !

!IceExtensionDefinition methodsFor: 'accessing' stamp: ''!
packageName
	^ packageName! !

!IceExtensionDefinition methodsFor: 'testing' stamp: ''!
isExtensionDefinition
	
	^ true! !

!IceExtensionDefinition methodsFor: 'visiting' stamp: ''!
contents

	^ ''! !

!IceExtensionDefinition methodsFor: 'patching' stamp: ''!
removeFrom: aPatcher
	
	"Do nothing. Do not remove extensions"! !

!IceExtensionDefinition methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	^ aVisitor visitExtensionDefinition: self! !

!IceExtensionDefinition methodsFor: 'patching' stamp: ''!
removeFromPatcher: aMCPatcher 
	
	"Monticello does not reify extensions"! !

!IceExtensionDefinition class methodsFor: 'instance creation' stamp: ''!
named: aString isMeta: isMeta packageName: aName
	^ self new
		name: aString;
		isMeta: isMeta;
		packageName: aName;
		yourself! !

!IceExternalJob methodsFor: 'events' stamp: ''!
changed

	current >= max ifTrue: [ ^ Job jobAnnouncer announce: (JobEnd on: self) ].
	Job jobAnnouncer announce: (JobChange on: self)! !

!IceExternalJob methodsFor: 'accessing' stamp: ''!
progress
	^ min >= max ifTrue: [ 1 ] ifFalse: [ (current - min) / (max - min) ]! !

!IceExternalJob methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	started := false! !

!IceExternalJob methodsFor: 'accessing' stamp: ''!
current: anInteger 
	current := anInteger ! !

!IceExternalJob methodsFor: 'accessing' stamp: ''!
title: aString 
	title := aString! !

!IceExternalJob methodsFor: 'events' stamp: ''!
ensureStarted
	started ifFalse: [ self start ]! !

!IceExternalJob methodsFor: 'accessing' stamp: ''!
min: anInteger 
	min := anInteger ! !

!IceExternalJob methodsFor: 'accessing' stamp: ''!
owner
	^ nil! !

!IceExternalJob methodsFor: 'events' stamp: ''!
start
	started := true.

	Job jobAnnouncer announce: (JobStart on: self)! !

!IceExternalJob methodsFor: 'events' stamp: ''!
end
	Job jobAnnouncer announce: (JobEnd on: self)! !

!IceExternalJob methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!IceExternalJob methodsFor: 'accessing' stamp: ''!
max: anInteger 
	max := anInteger! !

!IceFileDefinition commentStamp: ''!
I represent a file inside the iceberg repository. 

My contents are the contents of the file, utf8 decoded.

See my superclasses for more information.!
!IceFileDefinition methodsFor: 'testing' stamp: ''!
isFileDefinition
	
	^ true! !

!IceFileDefinition methodsFor: 'comparing' stamp: ''!
= anotherDefinition

	^ super = anotherDefinition and: [ contents = anotherDefinition basicContents ]! !

!IceFileDefinition methodsFor: 'comparing' stamp: ''!
hash
	
	^ self contents hash! !

!IceFileDefinition methodsFor: 'comparing' stamp: ''!
basicContents

	^ contents! !

!IceFileDefinition methodsFor: 'testing' stamp: ''!
isBinary
	
	[contents utf8Decoded] on: ZnInvalidUTF8 do: [ ^ true ].
	^ false! !

!IceFileDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	^ self iconNamed: #book! !

!IceFileDefinition methodsFor: 'accessing' stamp: ''!
contents
	"Contents for display purposes.
	If the file is binary (or could not detect as utf8 file) then just return an hexa dump representation of the contents
	If the file is in utf8 decode it and show the text"

	^ self isBinary
		ifTrue: [ String streamContents: [ :stream | contents hexDumpOn: stream max: Float infinity ] ]
		ifFalse: [ contents utf8Decoded ]! !

!IceFileDefinition methodsFor: 'accessing' stamp: ''!
contents: anObject

	contents := anObject! !

!IceFileDefinition methodsFor: 'operations' stamp: ''!
removeFrom: aVisitor 
	aVisitor removeFile: self! !

!IceFileDefinition methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitFileNode: self! !

!IceFileDefinition methodsFor: 'accessing' stamp: ''!
basicContents: anObject

	contents := anObject! !

!IceFileDefinition class methodsFor: 'instance creation' stamp: ''!
named: aString path: aPath fileReference: aFileReference
	^ self
		named: aString
		path: aPath
		contents: (aFileReference binaryReadStreamDo: [ :each | each upToEnd ])! !

!IceFileDefinition class methodsFor: 'instance creation' stamp: ''!
named: aString path: aPath contents: contents
	
	^ (self named: aString path: aPath)
		basicContents: contents
		yourself! !

!IceFileSystemDefinition commentStamp: ''!
I am an abstract class representing a non-code element read from an Iceberg repository, either from a commit or from the working directory in disk.

My concrete subclasses represent directories and files.

See my superclasses for more information.!
!IceFileSystemDefinition methodsFor: 'accessing' stamp: ''!
fileReference: aFileReference

	fileReference := aFileReference ! !

!IceFileSystemDefinition methodsFor: 'accessing' stamp: ''!
path: anObject

	path := anObject! !

!IceFileSystemDefinition methodsFor: 'accessing' stamp: ''!
fileReference

	^ fileReference! !

!IceFileSystemDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
canBeBrowsed
	
	"It can always be browsed through the libgit file system"
	^ true! !

!IceFileSystemDefinition methodsFor: 'visiting' stamp: ''!
removeFrom: aVisitor
	
	aVisitor removeFileReferenceInPath: self path! !

!IceFileSystemDefinition methodsFor: 'accessing' stamp: ''!
path
	^ path! !

!IceFileSystemDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
canBrowseReferences
	
	"We do not track file references..."
	^ false! !

!IceFileSystemDefinition class methodsFor: 'instance creation' stamp: ''!
named: aString path: aPath
	
	^ (self named: aString)
		path: aPath
		yourself! !

!IceFiletreeToTonelCommand commentStamp: ''!
I'm a command to enable the filetree to tonel conversion.
I will be active in repository list browser, when repository is in filetree format.
!
!IceFiletreeToTonelCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipFiletreeToTonelDialog on: self repository) openDialogWithSpec! !

!IceFiletreeToTonelCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	| repository |
	self hasRepository ifFalse: [ ^ false ].

	repository := self repository.
	^ repository isMissing not 
		and: [ repository workingCopy isDetached not
			and: [ repository workingCopy writerClass id = #filetree
				and: [ repository head isUnbornBranch not ] ] ]
! !

!IceFiletreeToTonelCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Convert repository sources to tonel'! !

!IceGenericError methodsFor: 'accessing' stamp: ''!
wrappedException: anError
	
	wrappedException := anError! !

!IceGitChange commentStamp: ''!
I represent a change coming from git (in contrast to a change coming from the image). I know the changed file and I can be visited to define the create a more detailed diff.!
!IceGitChange methodsFor: 'displaying' stamp: ''!
displayingProgressString
	^ 'Comparing changes of ' , filePathString! !

!IceGitChange methodsFor: 'accessing' stamp: ''!
filePathString: aString 
	filePathString := aString! !

!IceGitChange methodsFor: 'accessing' stamp: ''!
child
	
	^ IceGitChange on: (RelativePath withAll: self path segments allButFirst) pathString! !

!IceGitChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: 'gitChange(';
		nextPutAll: filePathString asString;
		nextPutAll: ')'! !

!IceGitChange methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitGitChange: self! !

!IceGitChange methodsFor: 'accessing' stamp: ''!
path
	
	^ Path from: filePathString! !

!IceGitChange class methodsFor: 'accessing' stamp: ''!
on: aString 
	
	^ self new
		filePathString: aString;
		yourself! !

!IceGitChangeImporter methodsFor: 'building' stamp: ''!
nextPath

	^ IceGitChangeImporter new
		path: (RelativePath withAll: path segments allButFirst);
		diff: diff;
		version: version;
		yourself.! !

!IceGitChangeImporter methodsFor: 'importing' stamp: ''!
importOn: aNode
	
	| currentSegment fileReference filePath |
	currentSegment := path segments first.
	
	filePath := aNode path / currentSegment.
	fileReference := version fileSystem resolve: filePath.
		
	"Do not import if the file does not exist in git"
	fileReference exists
		ifFalse: [ ^ self ].

	"If I represent a package, let's do it and do nothing else.
	This could be optimized to add the exact methods and avoid MC diff afterwards"
	((diff isCodeSubdirectory: aNode)
		and: [ version writerClass isValidPackage: fileReference ])
			ifTrue: [ ^ self ensurePackageFromDirectory: fileReference inParentNode: aNode ].

	"If I do not represent a package, I may be a file or a directory that may (recursively) contain a method or a package.
	For now, we only support packages inside the declared subdirectory (or root otherwise).
	All other changes are simple directory/file changes"
	
	"If path = 1 this means it is a file"
	path size = 1
		ifTrue: [ 
				fileReference exists ifTrue: [
				^ aNode addChild: (IceFileDefinition named: currentSegment path: filePath fileReference: fileReference) ] ].
	
	path size > 1 ifTrue: [ | directoryReference directoryPath |
		directoryPath := aNode path / currentSegment.
		directoryReference := version fileSystem resolve: directoryPath.
			directoryReference exists ifTrue: [
				"Otherwise, we recursively create a directory structure"
				self nextPath importOn: (self ensureDirectory: fileReference inParentNode: aNode) ] ].
	
	"If path size = 0 we should stop recursion"! !

!IceGitChangeImporter methodsFor: 'accessing' stamp: ''!
repository
	
	^ diff repository! !

!IceGitChangeImporter methodsFor: 'accessing' stamp: ''!
path: aRelativePath 
	path := aRelativePath! !

!IceGitChangeImporter methodsFor: 'accessing' stamp: ''!
version: aVersion
	
	version := aVersion! !

!IceGitChangeImporter methodsFor: 'building' stamp: ''!
ensurePackageFromDirectory: aFileReference inParentNode: aParentNode
	
	| importer packageName package |
	
	packageName := version writerClass packageNameFromDirectory: aFileReference.
	
	"Package already exists"
	(aParentNode includesKey: packageName)
		ifTrue: [ ^ self ].
	
	package := IcePackage
		named: packageName
		repository: self repository.
	
	importer := IceMCPackageImporter new
		package: package;
		version: version;
		yourself.
	^ importer importOn: aParentNode! !

!IceGitChangeImporter methodsFor: 'accessing' stamp: ''!
diff: anIceDiff 
	diff := anIceDiff! !

!IceGitChangeImporter methodsFor: 'building' stamp: ''!
ensureDirectory: aFileReference inParentNode: aNode
	
	aNode childAt: aFileReference basename ifPresent: [ :node |
		self assert: node value isDirectoryDefinition.
		^ node ].
	^ aNode addChild: (IceDirectoryDefinition named: aFileReference basename path: aNode path / aFileReference basename)! !

!IceGitCheckoutProgress methodsFor: 'accessing' stamp: ''!
block
	^ [ :path :completed :total :payload | 
		job ensureStarted.
		
		job min: 0.
		job max: total.
		job current: completed.
		job title: ('Checking out... ({1}/{2})' format: { completed. total}).
		
		job changed.
	]! !

!IceGitCheckoutProgress methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	job := IceExternalJob new
		title: 'Checking out...';
		yourself.
		
	self initializeBlock.! !

!IceGitCheckoutProgress methodsFor: 'initialization' stamp: ''!
initializeBlock
	self signature: self class fnSpec block: self block.! !

!IceGitClone methodsFor: 'accessing' stamp: ''!
location
	^ location! !

!IceGitClone methodsFor: 'accessing' stamp: ''!
location: aFileReference
	location := aFileReference! !

!IceGitClone methodsFor: 'accessing' stamp: ''!
url: aString 
	url := aString! !

!IceGitClone methodsFor: 'actions' stamp: ''!
execute

	| repo cloneOptions checkoutOptions callbacks |
	location exists
		ifTrue: [ IceCloneLocationAlreadyExists signalFor: location ].
	
	[location ensureCreateDirectory.
	
	repo := LGitRepository on: location.
	cloneOptions := repo cloneOptionsStructureClass withCredentialsProvider: (IceCredentialsProvider defaultForRemoteUrl: url).

	"Keeping references, because if not the GC take them."
	checkoutOptions := cloneOptions checkoutOptions.
	callbacks := cloneOptions fetchOptions callbacks.
	callbacks transferProgress: IceGitTransferProgress new.
	
	checkoutOptions checkoutStrategy: LGitCheckoutStrategyEnum git_checkout_force.
	checkoutOptions progressCallback: IceGitCheckoutProgress new.

	repo clone: url options: cloneOptions.

	(LGitRemote of: repo named: 'origin')
		lookup;
		setUrl: url.
		
	] on: LGitCallReturnHandler , IceWrongUrl do: [ :error |
		location exists ifTrue: [ location ensureDeleteAll ].
		error acceptError: (IceLibgitErrorVisitor onContext: self) ].! !

!IceGitClone methodsFor: 'accessing' stamp: ''!
url
	^ url! !

!IceGitCommit methodsFor: 'comparing' stamp: ''!
= aGitCommit

	(aGitCommit isKindOf: self species)
		ifFalse: [ ^ false ].
	^ self id = aGitCommit id! !

!IceGitCommit methodsFor: 'API - changes' stamp: ''!
changesFromCommit: anIceGitCommit 
	|  files |
	files := self repository changedFilesBetween: anIceGitCommit and: self.
	^ files collect: [ :each | IceGitChange on: each ]! !

!IceGitCommit methodsFor: 'comparing' stamp: ''!
hash

	^ self id hash! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
id: aString 
	id := aString! !

!IceGitCommit methodsFor: 'API - tags' stamp: ''!
createTag: aString 

	self repository handleLibgitError: [ 
		self repositoryHandle
			createTag: aString
			targetId: self libgitCommit id
			force: false.
		^ IceTag
			named: aString
			inRepository: self repository ]! !

!IceGitCommit methodsFor: 'API - packages' stamp: ''!
resetPackageCache
	
	packageNamesCache := nil.! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
timeStamp
	^ self datetime! !

!IceGitCommit methodsFor: 'ancestry' stamp: ''!
commonAncestorWithCommit: anIceGitCommit
	
	repository handleLibgitError: [ | mergeBaseId |
		mergeBaseId := [ (self repositoryHandle
			mergeBaseBetween: (LGitId fromHexString: self id)
			and: (LGitId fromHexString: anIceGitCommit id)) hexString ]
			on: LGit_GIT_ENOTFOUND
			do: [ nil ].
		^ mergeBaseId ifNotNil: [ self repository lookupCommit: mergeBaseId ] ]! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
ancestorIds: aCollection 
	ancestorIds := aCollection! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
packageNames
	
	^ self repository commitsInPackageCache
		at: self
		ifAbsentPut: [ self fetchPackageNames ]! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
repositoryHandle
	
	<repositoryHandleAccessor>
	^ repository repositoryHandle! !

!IceGitCommit methodsFor: 'private' stamp: ''!
libgitCommit
	
	repository handleLibgitError: [ ^ LGitCommit of: self repositoryHandle fromHexString: self id ]! !

!IceGitCommit methodsFor: 'TOMOVE' stamp: ''!
snapshotFor: package 
	^ [ (self repository mcVersionFor: (self versionFor: package)) snapshot ]
		on: IceVersionDoesNotExist 
		do: [ :e | MCSnapshot empty ]! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
datetime
	^ datetime! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
fetchPackageNames

	| writerClass dir |
	writerClass := self writerClass.
	dir := self fileSystem resolve: (self project sourceDirectory).
		
	dir exists ifFalse: [ ^ #() ].
	
	^ dir children
		select: [ :each | writerClass isValidPackage: each ]
		thenCollect: [ :each | writerClass packageNameFromDirectory: each ]! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
gitRef
	
	^ self id! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
author
	^ author! !

!IceGitCommit methodsFor: 'accessing - file' stamp: ''!
fileSystem
	
	^ (FileSystem onGitCommit: self libgitCommit) root! !

!IceGitCommit methodsFor: 'testing' stamp: ''!
hasMultipleAncestors
	| ancestors |
	"using ancestorsIds because ancestors will instantiate parents and is slower"
	ancestors := self ancestorIds.
	^ ancestors notNil 
		and: [ ancestors size > 1 ]! !

!IceGitCommit methodsFor: 'accessing - file' stamp: ''!
entryByPath: aString 
	
	repository handleLibgitError: [ ^ (LGitCommit of: self repositoryHandle fromHexString: self id) entryByPath: aString ]! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
ancestorIds

	^ ancestorIds! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
author: aString 
	author := aString! !

!IceGitCommit methodsFor: 'API - project' stamp: ''!
project

	self flag: #todo. "This is a quick fix for issue https://github.com/pharo-vcs/iceberg/issues/1002 and this should probably be improved to also cover issue https://github.com/pharo-vcs/iceberg/issues/949
	
	The idea is that if Iceberg contains a project at a certain commit and is associated to a local repository without the commit (because the image comes from a CI for example and the local repository is not in synch), we try to fetch the repository because the commit might be in the remote. This should cover most of the cases but might still fail if, for example, the local repository has different remotes than the one used where the repository was added to the image.
	
	This is a quick fix of the issue for Pharo 7 release."

	^ [ IceProjectReader readProjectFrom: self ] on: NotFound do: [ self repository fetch. IceProjectReader readProjectFrom: self ]! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
comment
	^ comment! !

!IceGitCommit methodsFor: 'API - properties' stamp: ''!
readerClass
	
	^ self properties readerClass! !

!IceGitCommit methodsFor: 'API - properties' stamp: ''!
writerClass

	^ self properties writerClass! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
comment: aString 
	comment := aString! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
datetime: aDateAndTime 
	datetime := aDateAndTime! !

!IceGitCommit methodsFor: 'accessing' stamp: ''!
ancestors
	
	^ ancestorIds collect: [ :each | repository lookupCommit: each ]! !

!IceGitFileRemote commentStamp: ''!
I am a 'remote' repository which is stored locally in your machine and accessed through a 'file://' url.!
!IceGitFileRemote methodsFor: 'accessing' stamp: ''!
detailedInfo
	^ { 'Origin' -> path pathString }! !

!IceGitFileRemote methodsFor: 'accessing' stamp: ''!
host
	^ 'local filesystem'! !

!IceGitFileRemote methodsFor: 'querying' stamp: ''!
organizer
	^ 'local'! !

!IceGitFileRemote methodsFor: 'accessing' stamp: ''!
projectName
	^ path basename
! !

!IceGitFileRemote methodsFor: 'private' stamp: ''!
parseUrl
	| znUrl |
	znUrl := ZnUrl fromString: url defaultScheme: 'file'.
	path := znUrl asFileReference.
	projectName := path basename.
! !

!IceGitFileRemote class methodsFor: 'testing' stamp: ''!
canHandleUrl: aRepositoryUrl
	^ (aRepositoryUrl beginsWith: 'file:') or: [aRepositoryUrl beginsWith: '/']! !

!IceGitHttpRemote commentStamp: ''!
A remote repository created out of a HTTP  url, such as 'http://localhost/owner/repository.git'.

!
!IceGitHttpRemote class methodsFor: 'accessing - defaults' stamp: ''!
defaultPort
	"Returns the HTTP default port"
	
	^80! !

!IceGitHttpRemote class methodsFor: 'testing' stamp: ''!
canHandleUrl: aRepositoryUrl
	^ (aRepositoryUrl beginsWith: self protocolID, '://') ! !

!IceGitHttpRemote class methodsFor: 'accessing - defaults' stamp: ''!
protocolID
	"Return the protocol identifier"
	
	^'http'! !

!IceGitHttpsRemote commentStamp: ''!
A remote repository created out of a HTTPS  url, such as 'https://github.com/npasserini/iceberg.git'.

!
!IceGitHttpsRemote methodsFor: 'testing' stamp: ''!
referencesSameRemoteLocationAs: aRemote
	^ (super referencesSameRemoteLocationAs: aRemote)
		or: [ (self url withoutSuffix: '.git') sameAs: (aRemote httpsUrl withoutSuffix: '.git') ] ! !

!IceGitHttpsRemote class methodsFor: 'accessing - defaults' stamp: ''!
defaultPort
	"Returns the HTTPS default port"
	
	^443! !

!IceGitHttpsRemote class methodsFor: 'accessing - defaults' stamp: ''!
protocolID
	"Return the protocol identifier"
	
	^'https'! !

!IceGitHubAPI commentStamp: ''!
I represent an access point to the GitHub API. 
I provide different high level abstractions to interact with GitHub, following the speciphications you can find here: https://developer.github.com/v3/!
!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
getCommit: aCommitish owner: owner project: projectName 

	^ self get: 'repos/', owner,'/', projectName, '/commits/', aCommitish! !

!IceGitHubAPI methodsFor: 'private - factory' stamp: ''!
newRequestTo: aString

	^ ZnClient new 
		in: [ :this | 
			(self credentials notNil and: [ isAnonymous not]) ifTrue: [ 
				self credentials applyToRequest: this ] ]; 
		headerAt: 'Accept' put: self acceptMediaType;
		url: 'https://api.github.com/', (aString first = $/
			ifTrue: [ aString allButFirst ]
			ifFalse: [ aString ]);
		yourself! !

!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
updatePullRequest: owner project: projectName number: aNumber data: aDictionary 
	^ self 
		patch: 'repos/', owner, '/', projectName, '/pulls/', aNumber asString
		with: [ :client |
			client 
				entity: (ZnEntity text: (STON toJsonString: aDictionary));
				contentType: ZnMimeType applicationJson ]! !

!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
getBranches: owner project: projectName
	^ self get: 'repos/', owner,'/', projectName, '/branches'! !

!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
addComment: owner project: projectName number: aNumber data: aDictionary
	^ self 
		post: 'repos/', owner, '/', projectName, '/issues/', aNumber asString, '/comments'
		with: [ :client |
			client 
				entity: (ZnEntity text: (STON toJsonString: aDictionary));
				contentType: ZnMimeType applicationJson ]! !

!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
addPullRequest: owner project: projectName data: aDictionary
	^ self 
		post: 'repos/', owner, '/', projectName, '/pulls'
		with: [ :client |
			client 
				entity: (ZnEntity text: (STON toJsonString: aDictionary));
				contentType: ZnMimeType applicationJson ]! !

!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
acceptPullRequest: owner project: projectName number: aNumber data: aDictionary
	^ self 
		put: 'repos/', owner, '/', projectName, '/pulls/', aNumber asString, '/merge'
		with: [ :client |
			client 
				entity: (ZnEntity text: (STON toJsonString: aDictionary));
				contentType: ZnMimeType applicationJson ]! !

!IceGitHubAPI methodsFor: 'accessing' stamp: ''!
credentials: anObject
	credentials := anObject! !

!IceGitHubAPI methodsFor: 'private - requesting' stamp: ''!
getRaw: aString 
	^ self responseWithValidationDo: [
		(self newRequestTo: aString)
			get;
			response ]! !

!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
getRepository: owner project: projectName
	^ self get: 'repos/', owner,'/', projectName! !

!IceGitHubAPI methodsFor: 'private - requesting' stamp: ''!
put: aString with: aBlock  
	^ self jsonContentsWithValidationDo: [
		(self newRequestTo: aString)
			in: aBlock;
			put;
			response ]! !

!IceGitHubAPI methodsFor: 'accessing' stamp: ''!
acceptMediaType

	^ acceptMediaType ifNil: [ 
		  acceptMediaType := 'application/vnd.github.v3+json' ]! !

!IceGitHubAPI methodsFor: 'responses' stamp: ''!
handleUnauthorized: aZnResponse 
	"If we are in unauthorized we require the correct credentials."
	
	| newCredentials githubOtp |
	aZnResponse isSuccess ifTrue: [ ^ self ].
	aZnResponse status ~= 401 ifTrue: [ ^ self ].

	"Does this require two factor authentication now?"
	githubOtp := aZnResponse headers at: 'X-Github-Otp' ifAbsent: [ nil ].
	newCredentials := githubOtp = 'required; app'
		ifTrue: [ IcePlaintextOtpCredentials new ]
		ifFalse: [ IcePlaintextCredentials new ].
	
	"Ignoring if you press cancel"
	(IceCredentialsProvider defaultForHost: 'github.com')
		obtainCredentials: newCredentials.
	IceAuthenticationError signal: 'Retry to use the new credentials'
	! !

!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
deleteBranch: owner project: projectName name: branchName
	^ self delete: 'repos/', owner, '/', projectName, '/git/refs/heads/', branchName! !

!IceGitHubAPI methodsFor: 'accessing' stamp: ''!
acceptMediaType: aString
	"Set the media type to use in the request.
	See: https://developer.github.com/v3/media/"

	acceptMediaType := aString! !

!IceGitHubAPI methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	isAnonymous := false! !

!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
getBranch: owner project: projectName name: branchName
	^ self get: 'repos/', owner,'/', projectName, '/branches/', branchName! !

!IceGitHubAPI methodsFor: 'private - requesting' stamp: ''!
get: aString 
	^ self jsonContentsWithValidationDo: [
		(self newRequestTo: aString)
			get;
			response ]! !

!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
getIssue: owner project: projectName number: issueNumber

	^ self get: 'repos/', owner,'/', projectName, '/issues/', (issueNumber asString)! !

!IceGitHubAPI methodsFor: 'private - requesting' stamp: ''!
getPaginated: aString 
	^ IceGitHubAPIPaginatedResult api: self request: aString
! !

!IceGitHubAPI methodsFor: 'private - requesting' stamp: ''!
get: aString parameters: aDictionary
	^ self jsonContentsWithValidationDo: [
		(self newRequestTo: aString, (String streamContents: [ :stream |
				stream << '?'.
				aDictionary associations 
					do: [ :keyPair | stream << keyPair key << '=' << keyPair value ]
					separatedBy: [ stream << '&' ] ] ))
			get;
			response ]! !

!IceGitHubAPI methodsFor: 'accessing' stamp: ''!
credentials
	^ credentials ifNil: [ credentials := self class obtainCredentials ]! !

!IceGitHubAPI methodsFor: 'private' stamp: ''!
contentsWithValidationDo: aBlock
	^ (self responseWithValidationDo: aBlock) contents! !

!IceGitHubAPI methodsFor: 'requesting' stamp: ''!
getPullRequests: owner project: projectName
	^ self getPaginated: 'repos/', owner, '/', projectName, '/pulls'
		! !

!IceGitHubAPI methodsFor: 'private - requesting' stamp: ''!
patch: aString with: aBlock  
	^ self jsonContentsWithValidationDo: [
		(self newRequestTo: aString)
			in: aBlock;
			patch;
			response ]! !

!IceGitHubAPI methodsFor: 'private - requesting' stamp: ''!
post: aString with: aBlock  
	^ self jsonContentsWithValidationDo: [
		(self newRequestTo: aString)
			in: aBlock;
			post;
			response ]! !

!IceGitHubAPI methodsFor: 'private - requesting' stamp: ''!
delete: aString 
	^ self contentsWithValidationDo: [
		(self newRequestTo: aString)
			delete;
			response ]! !

!IceGitHubAPI methodsFor: 'private' stamp: ''!
jsonContentsWithValidationDo: aBlock

	^ STON fromString: (self contentsWithValidationDo: aBlock)! !

!IceGitHubAPI methodsFor: 'accessing' stamp: ''!
beAnonymous

	isAnonymous := true! !

!IceGitHubAPI methodsFor: 'private' stamp: ''!
responseWithValidationDo: aBlock
	| response |
	
	response := aBlock value.
	
	self handleUnauthorized: response.
	
	response isSuccess 
		ifFalse: [ IceGitHubError signalFor: response ].
	^ response! !

!IceGitHubAPI class methodsFor: 'utilities' stamp: ''!
issuesClosedOn: repoName milestone: milestone 
	"Answers a string with a list and description of items closed on a milestone. 
	 Used to paste it as explanations on releases, etc.
	 Example: 
	 	self issuesClosedOn: 'pharo-vcs/iceberg' milestone: '0.7.3'"
	
	| project api issues |
	
	api := self new.
	project := '/repos/', repoName.
	issues := (api get: project, '/milestones')
		detect: [ :each | (each at: 'title') = milestone ]
		ifFound: [ :each | 
			api 
				get: project, '/issues'
				parameters: { 
					'milestone' -> (each at: 'number') asString.
					'state' -> 'closed' } asDictionary ]
		ifNone: [ #() ].
	
	^ String streamContents: [ :stream |  
		issues 
			do: [ :each | 
				stream << '- #' << (each at: 'number') << ': ' << (each at: 'title').
				each 
					at: 'labels' 
					ifPresent: [ :labels | 
						stream << ' ('.
						labels 
							do: [ :eachLabel | stream << (eachLabel at: 'name') ]
							separatedBy: [ stream << ', ' ].
						stream << ')' ] ]
			separatedBy: [ stream << String lf ] ]! !

!IceGitHubAPI class methodsFor: 'credentials' stamp: ''!
ensureCredentials
	| provider |

	provider := IceCredentialsProvider defaultForHost: 'github.com'. 
	^ provider providePlaintextCredentials.! !

!IceGitHubAPI class methodsFor: 'private' stamp: ''!
obtainCredentials
	| provider |
	
	"I try to get the configured credentials, if there is no, I will not attempt to get some.
	Use #ensureCredentials when really need to login."
	
	provider := IceCredentialsProvider defaultForHost: 'github.com'.
	provider plaintextCredentials isPresent ifFalse: [^ nil ].
	^ provider plaintextCredentials.
! !

!IceGitHubAPIPaginatedResult commentStamp: ''!
I'm a paginated answer from github (he sends results in pages and includes information in headers)!
!IceGitHubAPIPaginatedResult methodsFor: 'accessing' stamp: ''!
hasNext
	^ result isNil or: [ self parseMorePages: (result headers at: 'Link' ifAbsent: [ nil ]) ]! !

!IceGitHubAPIPaginatedResult methodsFor: 'accessing' stamp: ''!
next

	nextPage ifNil: [ nextPage := 1 ].
	^ [ 
		| aUrl |
		aUrl := self request asUrl ? (#page -> nextPage asString).
		result := self api getRaw: aUrl asString.
		STON fromString: result contents

		] ensure: [ nextPage := nextPage + 1 ]! !

!IceGitHubAPIPaginatedResult methodsFor: 'accessing' stamp: ''!
api
	^ api! !

!IceGitHubAPIPaginatedResult methodsFor: 'private' stamp: ''!
parseMorePages: aString 
	"github does not send 'Links' header if there are no pages, and it does not sends 'next' link
	 if we are at the last page"
	aString ifNil: [ ^ false ].
	^ (aString substrings: ',') anySatisfy: [ :each | each includesSubstring: 'rel="next"' ] ! !

!IceGitHubAPIPaginatedResult methodsFor: 'accessing' stamp: ''!
all
	| stream |
	stream := Array new writeStream.
	[ self hasNext ] 
	whileTrue: [ stream << self next ].
	^ stream contents! !

!IceGitHubAPIPaginatedResult methodsFor: 'accessing' stamp: ''!
api: anObject
	api := anObject! !

!IceGitHubAPIPaginatedResult methodsFor: 'accessing' stamp: ''!
request
	^ request! !

!IceGitHubAPIPaginatedResult methodsFor: 'accessing' stamp: ''!
request: anObject
	request := anObject! !

!IceGitHubAPIPaginatedResult class methodsFor: 'instance creation' stamp: ''!
api: anAPI request: aString
	^ self new 
		api: anAPI;
		request: aString;
		yourself
		! !

!IceGitHubAcceptPullRequestModel commentStamp: ''!
I'm a dialog for collecting data to accept a pull request.!
!IceGitHubAcceptPullRequestModel methodsFor: 'accessing' stamp: ''!
availableTypes

	^ #( 'merge' 'squash' 'rebase' )! !

!IceGitHubAcceptPullRequestModel methodsFor: 'accessing' stamp: ''!
type

	^ self typeList selectedItem! !

!IceGitHubAcceptPullRequestModel methodsFor: 'accessing' stamp: ''!
messageGhostText

	^ 'Commit title

Add an optional extented description'! !

!IceGitHubAcceptPullRequestModel methodsFor: 'events' stamp: ''!
onAccept: aBlock
	acceptBlock := aBlock! !

!IceGitHubAcceptPullRequestModel methodsFor: 'accessing' stamp: ''!
defaultType

	^ 'merge'! !

!IceGitHubAcceptPullRequestModel methodsFor: 'specs' stamp: ''!
titleForWindow

	^ 'Accept pull request'! !

!IceGitHubAcceptPullRequestModel methodsFor: 'accessing - ui' stamp: ''!
typeLabel

	^ typeLabel! !

!IceGitHubAcceptPullRequestModel methodsFor: 'actions' stamp: ''!
accept

	acceptBlock ifNotNil: [ acceptBlock cull: self ].

	self closeWindow! !

!IceGitHubAcceptPullRequestModel methodsFor: 'accessing - ui' stamp: ''!
typeList

	^ typeList! !

!IceGitHubAcceptPullRequestModel methodsFor: 'accessing - ui' stamp: ''!
acceptButton

	^ acceptButton! !

!IceGitHubAcceptPullRequestModel methodsFor: 'api' stamp: ''!
initialExtentForWindow

	^ (500 @ 250) scaledByDisplayScaleFactor! !

!IceGitHubAcceptPullRequestModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	messageLabel := self newLabel.
	messageText := self newText.
	typeLabel := self newLabel.
	typeList := self newDropList.
	acceptButton := self newButton.
		
	messageLabel label: 'Comment'.
	messageText
		autoAccept: true;
		placeholder: self messageGhostText.
	typeLabel label: 'Merge type'.
	acceptButton
		label: 'Accept pull request';
		action: [ self accept ].
! !

!IceGitHubAcceptPullRequestModel methodsFor: 'initialization' stamp: ''!
connectPresenters
	super connectPresenters.
	self typeList
		items: self availableTypes;
		display: [ :each | each ];
		selectItem: self defaultType! !

!IceGitHubAcceptPullRequestModel methodsFor: 'accessing' stamp: ''!
message

	^ self messageText text asString! !

!IceGitHubAcceptPullRequestModel methodsFor: 'accessing - ui' stamp: ''!
messageLabel

	^ messageLabel! !

!IceGitHubAcceptPullRequestModel methodsFor: 'accessing - ui' stamp: ''!
messageText

	^ messageText! !

!IceGitHubAcceptPullRequestModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newHorizontal
				add: #messageLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #messageText;
				yourself);
		add:
			(SpBoxLayout newHorizontal
				add: #typeLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #typeList;
				yourself)
			withConstraints: [ :constraints | constraints width: 25 * self currentWorld displayScaleFactor ];
		add: #acceptButton
			withConstraints: [ :constraints | constraints height: self buttonHeight ];
		yourself! !

!IceGitHubAction commentStamp: ''!
I represent a common behavior for the actions of the GithubPlugin!
!IceGitHubAction methodsFor: 'accessing' stamp: ''!
remote: anObject
	remote := anObject! !

!IceGitHubAction methodsFor: 'initialization' stamp: ''!
initialize
	retries := 3! !

!IceGitHubAction methodsFor: 'executing' stamp: ''!
execute
	self withErrorHandlingDo: [ 
		[[ self basicExecute ] on: IceAuthenticationError do: [ :e |
			retries = 0 ifTrue: [ e pass ].
			retries := retries - 1.
			^ self execute.
		]] on: LGitNoCredentialsProvided do: [ ^ self].
		self finishSuccess ]! !

!IceGitHubAction methodsFor: 'accessing' stamp: ''!
credentials 
	^ credentials ifNil: [ credentials := self obtainCredentials ]! !

!IceGitHubAction methodsFor: 'private' stamp: ''!
obtainCredentials
	^ IceGitHubAPI obtainCredentials! !

!IceGitHubAction methodsFor: 'private' stamp: ''!
github
	^ IceGitHubAPI new 
		credentials: self credentials;
		yourself! !

!IceGitHubAction methodsFor: 'private' stamp: ''!
reportError: error
	
	| message |
	message := error messageBody.
	message = 'Invalid field: head'
		ifTrue: [ message := 'Branch does not exist on github. Please commit and push your changes.' ].
	UIManager default 
		alert: message
		title: 'Error creating pull request: ', error messageText! !

!IceGitHubAction methodsFor: 'accessing' stamp: ''!
remote
	^ remote! !

!IceGitHubAction class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceGitHubAction ! !

!IceGitHubBadCredentialsError commentStamp: ''!
I'm an error that happens when credentials are bad.!
!IceGitHubBadCredentialsError methodsFor: 'accessing' stamp: ''!
messageBody
	^ 'Credentials provided are wrong'! !

!IceGitHubBadCredentialsError class methodsFor: 'testing' stamp: ''!
isAppropriateFor: aResponse 
	^ aResponse status = 401! !

!IceGitHubCommand commentStamp: ''!
I'm a generic command to perform plugin actions for GitHub.
My children define the real behavior, and they need to implement #execute.!
!IceGitHubCommand methodsFor: 'accessing' stamp: ''!
remoteModel

	^ self context
! !

!IceGitHubCommand methodsFor: 'accessing' stamp: ''!
remote

	^ self context entity
! !

!IceGitHubCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ super canBeExecuted and: [ self remote url includesSubstring: 'github.com' ]! !

!IceGitHubCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceGitHubCommand! !

!IceGitHubCreatePullRequestModel commentStamp: ''!
I'm a dialog to ask for data relevant to create a pull request.!
!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
baseRemote
	"This is the 'base' remote (the place where the repository is forked). This is used to 
	 suggest fork PR destination (base)"

	^ baseRemote ifNil: [ baseRemote := self obtainBaseRemote ]! !

!IceGitHubCreatePullRequestModel methodsFor: 'events' stamp: ''!
onAccept: aBlock

	acceptBlock := aBlock! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing - ui' stamp: ''!
baseForkList
	^ baseForkList! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
defaultBaseBranchName

	self hasParent ifFalse: [ ^ self baseDefaultBranchName ].
	^ self baseBranchNames
		  detect: [ :each | each = self branch shortname ]
		  ifNone: [ self baseDefaultBranchName ]! !

!IceGitHubCreatePullRequestModel methodsFor: 'private' stamp: ''!
obtainBaseRemote

	| base |
	base := self gitBase.
	^ IceGitRemote url:
		  ((base at: #git_url) copyReplaceAll: 'git://' with: 'https://')! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
repository

	^ repository! !

!IceGitHubCreatePullRequestModel methodsFor: 'private' stamp: ''!
baseBranchNames

	^ self baseBranches collect: [ :each | each at: #name ]! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
credentials: aCredentials

	credentials := aCredentials! !

!IceGitHubCreatePullRequestModel methodsFor: 'private' stamp: ''!
baseBranches

	^ baseBranches ifNil: [ baseBranches := self requestBaseBranches ]! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing - ui' stamp: ''!
baseBranchList
	^ baseBranchList! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
branch

	^ self repository branch! !

!IceGitHubCreatePullRequestModel methodsFor: 'actions' stamp: ''!
accept

	| title |
	title := self titlePanel text trim.
	title ifEmpty: [ 
		UIManager default alert: 'You need to specify a title for the pull request.' title: 'Error'. 
		^ self ].
	
	acceptBlock ifNotNil: [ 
		acceptBlock cull: self createPullRequest ].
	
	self closeWindow! !

!IceGitHubCreatePullRequestModel methodsFor: 'private' stamp: ''!
createPullRequest

	^ IceGitHubPullRequestDefinition new 
		credentials: self credentials;
		title: self titlePanel text trim;
		headRemote: self headForkList selectedItem;
		headBranchName: self headBranchList selectedItem;
		baseRemote: self baseForkList selectedItem;
		baseBranchName: self baseBranchList selectedItem;
		body: self bodyPanel text asString trim;
		yourself! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing - ui' stamp: ''!
headLabel
	^ headLabel! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing - ui' stamp: ''!
headForkList
	^ headForkList! !

!IceGitHubCreatePullRequestModel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (500 @ 300) scaledByDisplayScaleFactor! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
baseDefaultBranchName

	^ self gitBase at: #default_branch! !

!IceGitHubCreatePullRequestModel methodsFor: 'private' stamp: ''!
obtainAvailableBranchNames

	^ ((self repository allBranches collect: #shortname as: Set)
			addAll: self baseBranchNames;
			asArray)
			sort
! !

!IceGitHubCreatePullRequestModel methodsFor: 'private' stamp: ''!
obtainAvailableRemotes

	| remotes |
	remotes := self repository remotes.
	(remotes includes: self baseRemote)
		ifFalse: [ remotes := remotes copyWith: self baseRemote ].
	^ remotes	
! !

!IceGitHubCreatePullRequestModel methodsFor: 'private' stamp: ''!
obtainLastCommitMessage

	^ self branch commit comment! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
headRemote

	^ headRemote ifNil: [ self repository head upstream remote ]! !

!IceGitHubCreatePullRequestModel methodsFor: 'private - request' stamp: ''!
requestGitRepositoryInfo

	| remote |
	remote := self headRemote.
	^ IceGitHubAPI new
		  credentials: self credentials;
		  getRepository: remote owner project: remote projectBasename! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
availableRemotes
	"Retrieves available remotes to perform the PR"

	^ availableRemotes ifNil: [ 
		  availableRemotes := self obtainAvailableRemotes ]! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing - ui' stamp: ''!
titleLabel

	^ titleLabel! !

!IceGitHubCreatePullRequestModel methodsFor: 'private' stamp: ''!
gitBase

	| json |
	json := self gitRepositoryInfo.
	^ json at: #parent ifAbsent: [ json ]! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing - ui' stamp: ''!
baseLabel
	^ baseLabel! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing - ui' stamp: ''!
titlePanel

	^ titlePanel! !

!IceGitHubCreatePullRequestModel methodsFor: 'private' stamp: ''!
gitRepositoryInfo

	^ gitRepositoryInfo ifNil: [ 
		  gitRepositoryInfo := self requestGitRepositoryInfo ]! !

!IceGitHubCreatePullRequestModel methodsFor: 'private' stamp: ''!
hasParent

	^ self gitRepositoryInfo includesKey: #parent! !

!IceGitHubCreatePullRequestModel methodsFor: 'specs' stamp: ''!
titleForWindow

	^ 'New pull request'! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
credentials

	^ credentials! !

!IceGitHubCreatePullRequestModel methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aWindow

	aWindow
		addButton: 'Create pull request'
		do: [ self accept ]! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing - ui' stamp: ''!
bodyLabel
	^ bodyLabel! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
defaultHeadBranchName

	^ self branch shortname! !

!IceGitHubCreatePullRequestModel methodsFor: 'private - request' stamp: ''!
requestBaseBranches

	^ IceGitHubAPI new
		  credentials: self credentials;
		  getBranches: self baseRemote owner
		  project: self baseRemote projectBasename! !

!IceGitHubCreatePullRequestModel methodsFor: 'initialization' stamp: ''!
initializeRepository: aRepository credentials: aCredentials headRemote: aRemote

	repository := aRepository.
	credentials := aCredentials.
	headRemote := aRemote.
	self initialize! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing - ui' stamp: ''!
bodyPanel
	^ bodyPanel! !

!IceGitHubCreatePullRequestModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	titleLabel := self newLabel.
	titlePanel := self newTextInput
		autoAccept: true;
		yourself.
	headLabel := self newLabel.
	headForkList := self newDropList.
	headBranchList := self newDropList.
	baseLabel := self newLabel.
	baseForkList := self newDropList.
	baseBranchList := self newDropList.
	bodyLabel := self newLabel.
	bodyPanel := self newText
		autoAccept: true;
		yourself.

	titleLabel label: 'Title'.
	headLabel label: 'From (Head)'.
	baseLabel label: 'To (Base)'.
	bodyLabel label: 'Comment'! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing' stamp: ''!
availableBranchNames

	^ availableBranchNames ifNil: [ 
		  availableBranchNames := self obtainAvailableBranchNames ]! !

!IceGitHubCreatePullRequestModel methodsFor: 'accessing - ui' stamp: ''!
headBranchList
	^ headBranchList! !

!IceGitHubCreatePullRequestModel class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #repository:credentials:headRemote:'! !

!IceGitHubCreatePullRequestModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #titleLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #titlePanel;
				yourself)
			withConstraints:
				[ :constraints | constraints height: 25 * self currentWorld displayScaleFactor ];
		add:
			(SpBoxLayout newLeftToRight
				add: #headLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #headForkList;
				add: #headBranchList;
				yourself)
			withConstraints:
				[ :constraints | constraints height: 25 * self currentWorld displayScaleFactor ];
		add:
			(SpBoxLayout newLeftToRight
				add: #baseLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #baseForkList;
				add: #baseBranchList;
				yourself)
			withConstraints:
				[ :constraints | constraints height: 25 * self currentWorld displayScaleFactor ];
		add:
			(SpBoxLayout newLeftToRight
				add: #bodyLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #bodyPanel;
				yourself );
			yourself! !

!IceGitHubCreatePullRequestModel class methodsFor: 'instance creation' stamp: ''!
repository: aRepository credentials: aCredentials headRemote: aRemote

	^ self basicNew
		  initializeRepository: aRepository
		  credentials: aCredentials
		  headRemote: aRemote;
		  yourself! !

!IceGitHubError commentStamp: ''!
I'm an error that happens when something fails when performing a GitHub action.!
!IceGitHubError methodsFor: 'accessing' stamp: ''!
messageBody
	| errors |
	errors := self jsonContents at: #errors ifAbsent: [ ^ '' ].
	^ String streamContents: [ :stream | 
		errors
			do: [ :each | stream << (self errorToString: each) ] 
			separatedBy: [ stream cr ] ].! !

!IceGitHubError methodsFor: 'accessing' stamp: ''!
messageText
	^ self jsonContents at: #message! !

!IceGitHubError methodsFor: 'accessing' stamp: ''!
code
	^ self response status! !

!IceGitHubError methodsFor: 'private' stamp: ''!
errorToString: aDictionary 
	(aDictionary at: #code) = 'custom' ifTrue: [ ^ self customError: aDictionary ].
	(aDictionary at: #code) = 'invalid' ifTrue: [ ^ self invalidError: aDictionary ].
	
	^ self unknownError: aDictionary	! !

!IceGitHubError methodsFor: 'accessing' stamp: ''!
response: anObject
	response := anObject! !

!IceGitHubError methodsFor: 'private' stamp: ''!
unknownError: aDictionary
	^ String streamContents: [ :stream | 
		(aDictionary associations sorted: [ :a :b | a key < b key  ])
			do: [ :each | stream << each key << ': ' << each value ]
			separatedBy: [ stream << ', ' ] ]! !

!IceGitHubError methodsFor: 'accessing' stamp: ''!
response
	^ response! !

!IceGitHubError methodsFor: 'accessing' stamp: ''!
jsonContents
	^ jsonContents ifNil: [ jsonContents := STON fromString: self contents ]	
	! !

!IceGitHubError methodsFor: 'accessing' stamp: ''!
contents
	^ self response contents! !

!IceGitHubError methodsFor: 'private' stamp: ''!
customError: aDictionary
	^ aDictionary at: #message
		! !

!IceGitHubError methodsFor: 'private' stamp: ''!
invalidError: aDictionary
	^ 'Invalid field: ', (aDictionary at: #field)
	
		! !

!IceGitHubError class methodsFor: 'instance creation' stamp: ''!
for: aResponse
	^ (self errorClassFor: aResponse) new 
		response: aResponse;
		yourself	! !

!IceGitHubError class methodsFor: 'testing' stamp: ''!
isAppropriateFor: aResponse
	^ false! !

!IceGitHubError class methodsFor: 'private' stamp: ''!
errorClassFor: aResponse
	^ self allSubclasses 
		detect: [ :each | each isAppropriateFor: aResponse  ]
		ifNone: [ self ]! !

!IceGitHubError class methodsFor: 'instance creation' stamp: ''!
signalFor: aResponse
	^ (self for: aResponse) signal! !

!IceGitHubGenericError commentStamp: ''!
I'm an error that happens when something went wrong on GitHub API operations.!
!IceGitHubGenericError class methodsFor: 'testing' stamp: ''!
isAppropriateFor: aResponse
	^ aResponse status = 422! !

!IceGitHubJSONDataSource commentStamp: ''!
I'm a generic datasource to show in a table results of a JSON. 
I'm intended to be used to show information from GitHub API, but I'm generic enough to be used which any kind of JSON structure.!
!IceGitHubJSONDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex 
	^ FTCellMorph new  
		addMorphBack: ((self elementAt: rowIndex) at: column id) asStringMorph;
		yourself
	! !

!IceGitHubJSONDataSource methodsFor: 'private' stamp: ''!
columnTitleFor: column
	^ column id capitalized! !

!IceGitHubJSONDataSource methodsFor: 'accessing' stamp: ''!
actionColumn: column
	elements := elements sorted: [ :a :b |
		(a at: column id) < (b at: column id) ]
		! !

!IceGitHubJSONDataSource methodsFor: 'accessing' stamp: ''!
headerColumn: column
	column id ifNil: [ ^ nil ].

	^ SimpleButtonMorph new
		layoutPolicy: RowLayout new; 
		listDirection: #leftToRight; 
		wrapCentering: #center;
		cellInset: 5@0;
		layoutInset: 5@0;
		label: (self columnTitleFor: column);
		target: self;
		actionSelector: #actionColumn:;
		arguments: {column};
		yourself! !

!IceGitHubNewBranchFromIssueCommand methodsFor: 'testing' stamp: ''!
iconName

	^ #github! !

!IceGitHubNewBranchFromIssueCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipCheckoutBranchDialog on: self repositoryModel)
		withTypes: (IceGitHubPlugin new checkoutBranchPanelsOnModel: self repositoryModel);
		openDialogWithSpec! !

!IceGitHubNewBranchFromIssueCommand methodsFor: 'testing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ true! !

!IceGitHubNewBranchFromIssueCommand methodsFor: 'testing' stamp: ''!
canBeExecuted 

	^ self repositoryModel isNotNil! !

!IceGitHubNewBranchFromIssueCommand class methodsFor: 'testing' stamp: ''!
defaultToolbarItemName

	^ 'New issue'! !

!IceGitHubNewBranchFromIssueCommand class methodsFor: 'testing' stamp: ''!
defaultName

	^ 'Create new branch for issue...'! !

!IceGitHubNewBranchFromIssuePanel commentStamp: ''!
I'm a panel to create a new branch taking a GitHub issue as basis.
A GitHub issue will be created in the form: 

123-a-github-issue!
!IceGitHubNewBranchFromIssuePanel methodsFor: 'accessing - ui' stamp: ''!
issueNumberText

	^ issueNumberText! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	fetched := false! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'accessing - ui' stamp: ''!
issueText

	^ issueText! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'private' stamp: ''!
updateText: aString 

	issueText text: aString.
	fetched := true! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'private' stamp: ''!
wait: time thenDo: aBlock
	"This method avoids to request too many times the github api. 
	 It does it in the simplest way possible: it starts a process that waits some 
	 time (usually 500 milliseconds). If there is another entry before, it terminates 
	 the process and starts a new one."

	currentWaitingProcess ifNotNil: [ currentWaitingProcess terminate ].
	currentWaitingProcess := [ 
			time wait.
			aBlock value ] 
		forkNamed: 'GitHub issue tracker'! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'accessing' stamp: ''!
selectRemoteModel

	^ selectRemoteModel ifNil: [
		selectRemoteModel := IceTipRemoteActionModel 
			repositoryModel: self model
			on: self model entity ]! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'private' stamp: ''!
validateIssue: aString

	| number remote |
	fetched := false.
	aString trimmed isEmpty ifTrue: [ ^ self ].
	aString isAllDigits ifFalse: [ ^ self ].
	number := aString asNumber.
	(issue isNil or: [ (issue at: 'number') ~= number ]) ifFalse: [ ^ self ].
	remote := self selectRemoteModel remote.
	
	self wait: 500 milliSeconds thenDo: [ 	
		[
			issue := IceGitHubAPI new 
				beAnonymous;
				getIssue: remote owner 
					project: remote projectName 
					number: number.
			UIManager default defer: [ 
				self updateText: (self sanitizeTitle: (issue at: 'title')) ] ]
		on: IceGitHubError do: [ :e | 
			e messageText = 'Not Found' ifFalse: [ e pass ].
			 UIManager default defer: [ 
				self updateText: self unknownTitle ] ] ]! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'private' stamp: ''!
useRemote: aRemoteModel

	self selectRemoteModel useRemote: aRemoteModel! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'private' stamp: ''!
sanitizeTitle: aString
	| separators safeSeparator |
	
	aString isEmptyOrNil ifTrue: [ ^ self unknownTitle ].
	
	safeSeparator := $-.
	separators := { Character space. Character tab. $_. safeSeparator }.
	^ String streamContents: [ :str | 
		aString do: [ :c |
			(separators includes: c) ifTrue: [ str nextPut: safeSeparator ].
			c isAlphaNumeric ifTrue: [ str nextPut: c ] ] ]! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'New branch from issue'! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'accessing - ui' stamp: ''!
issueLabel

	^ issueLabel! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'accessing' stamp: ''!
branchName
	
	^ '{1}-{2}' format: { 
		issueNumberText text trim. 
		issueText text trim }.! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'accessing' stamp: ''!
validate
	
	self
		assert: ((issueNumberText text asString notEmpty) and: [ issueNumberText text isAllDigits ])
		description: 'Please enter a valid issue number'.
	self
		assert: fetched
		description: 'Please fetch a valid issue number'! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'accessing' stamp: ''!
icon

	^ (self iconNamed: #github) scaledToSize: 16@16! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'accessing - ui' stamp: ''!
remotePanel

	^ remotePanel! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ 800 @ 175! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	self initializeCurrentBranchLabel.
	remotePanel := self
		instantiate: IceTipSelectRemotePresenter
		on: self selectRemoteModel.
	remotePanel remoteList
		whenSelectedItemChangedDo: [ :remoteModel | self useRemote: remoteModel ].
	branchLabel := self newLabel
		label: 'Issue number:';
		yourself.
	issueNumberText := self newTextInput
		placeholder: 'e.g., 123';
		autoAccept: true;
		yourself.
	issueLabel := self newLabel
		label: 'Branch name:';
		yourself.
	issueText := self newTextInput
		placeholder: 'Generated-from-title-after-issue-number-is-completed';
		disable;
		yourself.
		
	issueNumberText whenTextChangedDo: [ :text | self validateIssue: text ]! !

!IceGitHubNewBranchFromIssuePanel methodsFor: 'accessing' stamp: ''!
unknownTitle

	^ 'INVALID-ISSUE'! !

!IceGitHubNewBranchFromIssuePanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #currentBranchLabel height: self inputTextHeight;
		  add: #remotePanel height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #branchLabel width: self labelWidth;
				   add: #issueNumberText;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #issueLabel width: self labelWidth;
				   add: #issueText;
				   yourself)
		  height: self inputTextHeight! !

!IceGitHubNewPullRequestAction commentStamp: ''!
I'm an action to create a new pull request.!
!IceGitHubNewPullRequestAction methodsFor: 'executing' stamp: ''!
basicExecute

	credentials := IceGitHubAPI ensureCredentials.

	remote ifNil: [ 
		remote := self repository branch hasUpstream
			ifTrue: [ self repository branch upstream remote ]
			ifFalse: [ self askRemote: self repository ]
	].

	(self validateMakePullRequestOn: self repository) ifFalse: [ ^ #() ].

	(IceGitHubCreatePullRequestModel 
		repository: self repository
		credentials: self credentials
		headRemote: remote)
		onAccept: [ :pullRequest | 
			[ | pullRequestDatas url |
			pullRequestDatas := pullRequest send.
			url := pullRequestDatas at: 'html_url'.
			UIManager default 
				inform: 'Pull request created. Click to view on Github.' 
				actionOnClick: [ self class environment at: #WebBrowser ifPresent: [ :webBrowser | webBrowser openOn: url ] ifAbsent: [ self inform: ('Cannot open "{1}" because the project WebBrowser is not present by default in Pharo 6.' format: { url }) ]  ] ]
				on: IceGitHubError
				do: [ :e | self reportError: e ] ];
		openDialogWithSpec! !

!IceGitHubNewPullRequestAction methodsFor: 'private' stamp: ''!
validateMakePullRequestOn: aRepository
	| status |
	
	status := OrderedCollection new: 2.
	aRepository isModified 
		ifTrue: [ status add: 'Uncommited changes' ].
	(aRepository outgoingCommitsTo: remote) 
		ifNotEmpty: [ :commits | '{1} not published' format: { commits size } ].
	status ifEmpty: [ ^ true ].
	
	^ UIManager default 
		confirm: (('{1} has ongoing modifications ({2}). 
Do you want to continue anyway?') format: { aRepository name. status asCommaString })! !

!IceGitHubNewPullRequestAction methodsFor: 'private' stamp: ''!
askRemote: aRepository

	^ aRepository remotes anyOne! !

!IceGitHubNewPullRequestCommand commentStamp: ''!
I'm a command to create a Pull Request!
!IceGitHubNewPullRequestCommand methodsFor: 'executing' stamp: ''!
execute

	^ IceGitHubNewPullRequestAction new
		  repository: self repository;
		  execute! !

!IceGitHubNewPullRequestCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Create Pull Request...'! !

!IceGitHubNilPullRequest commentStamp: ''!
Description
--------------------

I am a nil PR that can be used when the user has no PR to see.!
!IceGitHubNilPullRequest methodsFor: 'accessing' stamp: ''!
body
	^ ''! !

!IceGitHubNilPullRequest methodsFor: 'accessing' stamp: ''!
baseLabel
	^ 'No PR selected'! !

!IceGitHubNilPullRequest methodsFor: 'accessing' stamp: ''!
author
	^ 'No PR selected'! !

!IceGitHubNilPullRequest methodsFor: 'accessing' stamp: ''!
url
	^ 'No PR selected'! !

!IceGitHubNilPullRequest methodsFor: 'accessing' stamp: ''!
headLabel
	^ 'No PR selected'! !

!IceGitHubOpenOnGithubAction commentStamp: ''!
Description
--------------------

I am a simple action taking as parameters an owner of a project and the project name and I open the project on github from that.	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	organisation:		<aString>		The name of the owner of the project.
	projectName:			<aString>		The project name.
!
!IceGitHubOpenOnGithubAction methodsFor: 'executing' stamp: ''!
basicExecute
	[ 
	
	| url |
	url := (self github getRepository: self organisation project: self projectName) at: 'html_url'.
	
	self class environment at: #WebBrowser ifPresent: [ :webBrowser | webBrowser openOn: url ] ifAbsent: [ self inform: ('Cannot open "{1}" because the project WebBrowser is not present by default in Pharo 6.' format: { url }) ] 
	
	]
		on: IceGitHubError
		do: [ self inform: ('Invalid Github repository. No project named "{1}" found for the owner "{2}"' format: {self projectName. self organisation}) ]! !

!IceGitHubOpenOnGithubAction methodsFor: 'accessing' stamp: ''!
projectName
	^ projectName! !

!IceGitHubOpenOnGithubAction methodsFor: 'accessing' stamp: ''!
organisation
	^ organisation! !

!IceGitHubOpenOnGithubAction methodsFor: 'accessing' stamp: ''!
projectName: anObject
	projectName := anObject! !

!IceGitHubOpenOnGithubAction methodsFor: 'accessing' stamp: ''!
organisation: anObject
	organisation := anObject! !

!IceGitHubOpenOnGithubAction class methodsFor: 'instance creation' stamp: ''!
organisation: aString projectName: anotherString
	^ self new
		organisation: aString;
		projectName: anotherString;
		yourself! !

!IceGitHubOpenOnGithubCommand commentStamp: ''!
Description
--------------------

I am a command opening the repository page of the remote on GitHub if possible.!
!IceGitHubOpenOnGithubCommand methodsFor: 'executing' stamp: ''!
execute

	(IceGitHubOpenOnGithubAction
		 organisation: self remote owner
		 projectName: self remote projectName) execute! !

!IceGitHubOpenOnGithubCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Open on github'! !

!IceGitHubPlugin commentStamp: ''!
I'm a pluging to handle GitHub issues integration. 
It just add options to easily handle the creation of branchs with the "convention" issue naming format (number-plus-normalised-title): 

123-a-sample-of-issue-branch
!
!IceGitHubPlugin methodsFor: 'accessing - ui' stamp: ''!
checkoutBranchPanelsOnModel: aRepositoryModel 
	
	^ { IceGitHubNewBranchFromIssuePanel on: aRepositoryModel }! !

!IceGitHubPlugin class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository

	^ aRepository remotes anySatisfy: [ :each | each host = 'github.com' ]! !

!IceGitHubPullRequest commentStamp: ''!
I'm a pull request from github API. 
I represent (more or less), what is described here: https://developer.github.com/v3/pulls/#list-pull-requests!
!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
number
	^ self jsonAt: #number! !

!IceGitHubPullRequest methodsFor: 'private - accessing' stamp: ''!
jsonAt: aKey
	^ self json at: aKey! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
baseCommit
	^ repository commitAt: self baseSHA! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
commits
	^ self branch commits! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceGitHubPullRequest methodsFor: 'actions' stamp: ''!
mergeIntoWorkingCopy
	self repository 
		ensureBranch: self branchName;
		checkoutBranch: self branchName.
	self branch merge! !

!IceGitHubPullRequest methodsFor: 'initialization' stamp: ''!
initializeWithJSON: aDictionary
	json := aDictionary.
	self initialize! !

!IceGitHubPullRequest methodsFor: 'actions' stamp: ''!
fetch

	^ [ self remote fetch ] ensure: [ fetched := true ]! !

!IceGitHubPullRequest methodsFor: 'private - accessing' stamp: ''!
json
	^ json! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
url
	^ self jsonAt: #url! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
branch
	fetched ifFalse: [ self fetch ].
	^ branch ifNil: [
		branch := (self repository
			remoteNamed: self remote name )
				remoteBranchNamed: self headRef ]! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
owner 
	^ (((self jsonAt: #base) at: #repo) at: #owner) at: #login! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
headLabel
	^ (self jsonAt: #head) at: #label! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
status
	^ status ifNil: [ 
		status := IceGitHubAPI new 
			get: 'repos/', self owner, '/', self projectName, '/commits/', self headSHA, '/status' ]! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
baseSHA
	^ (self jsonAt: #base) at: #sha! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
remote
	| remote |
	remote := IceGitRemote 
		name: self author
		url: (((self jsonAt: #head) at: #repo) at: #ssh_url).
	^ self repository remotes 
		detect: [ :each | each = remote ]
		ifFound: [ :each | each ]
		ifNone: [ 
			self repository addRemote: remote.
			remote ].
	
	! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
title
	^ self jsonAt: #title! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
body
	^ self jsonAt: #body! !

!IceGitHubPullRequest methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	fetched := false! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
baseLabel
	^ (self jsonAt: #base) at: #label! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
author
	^ (self jsonAt: 'user') at: 'login'! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
headSHA
	^ (self jsonAt: #head) at: #sha! !

!IceGitHubPullRequest methodsFor: 'actions' stamp: ''!
rejectMessage: messageString
	messageString trimBoth 
		ifNotEmpty: [ self addComment: messageString ].
	IceGitHubAPI new 
		updatePullRequest: self owner 
			project: self projectName
			number: self number
			data: { #state -> #closed } asDictionary! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
projectName
	^ ((self jsonAt: #base) at: #repo) at: #name! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
detail
	^ detail ifNil: [
		detail := IceGitHubAPI new get: ((self jsonAt: #url) allButFirst: 23) ]! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
branchName
	^ self branch name! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
state
	^ self jsonAt: #state! !

!IceGitHubPullRequest methodsFor: 'actions' stamp: ''!
addComment: messageString
	IceGitHubAPI new 
		addComment: self owner 
			project: self projectName
			number: self number
			data: { #body -> messageString } asDictionary! !

!IceGitHubPullRequest methodsFor: 'actions' stamp: ''!
acceptMessage: messageString type: typeString
	IceGitHubAPI new 
		acceptPullRequest: self owner 
			project: self projectName
			number: self number
			data: { 
				#commit_title -> (messageString lines 
					ifNotEmpty: [ :each | each first trimBoth ] 
					ifEmpty: [ '' ]). 
				#commit_message -> (messageString lines 
					ifNotEmpty: [ :lines | (lines allButFirst joinUsing: String lf) trimBoth ] 
					ifEmpty: [ '' ]). 
				#sha-> self headSHA.
				#merge_method -> typeString } asDictionary! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
headRef
	^ (self jsonAt: #head) at: #ref! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
htmlUrl
	^ self jsonAt: #html_url! !

!IceGitHubPullRequest methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceGitHubPullRequest class methodsFor: 'instance creation' stamp: ''!
fromJSON: aDictionary
	^ self basicNew
		initializeWithJSON: aDictionary;
		yourself! !

!IceGitHubPullRequestDataSource commentStamp: ''!
I'm a datasource for pull request status, to be used when showing pull requests details. 

See IceGitHubPullRequestDetailModel!
!IceGitHubPullRequestDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex 
	column id = #target_url ifTrue: [ ^ self targetUrlCellColumn: column rowIndex: rowIndex ].
	column id = #state ifTrue: [ ^ self statusCellColumn: column rowIndex: rowIndex ].
	column id = #context ifTrue: [ ^ self contextCellColumn: column rowIndex: rowIndex ].
	^ super cellColumn: column row: rowIndex ! !

!IceGitHubPullRequestDataSource methodsFor: 'private' stamp: ''!
iconNameForStatus: status
	status = 'success' ifTrue: [ ^ #testGreen ].
	status = 'failure' ifTrue: [ ^ #testRed ].
	status = 'pending' ifTrue: [ ^ #testYellow ].
	
	^ #testNotRun! !

!IceGitHubPullRequestDataSource methodsFor: 'actions' stamp: ''!
copyToClipboard: url
	Clipboard clipboardText: url informing: ('Url {1} copied to clipboard' format: {url})! !

!IceGitHubPullRequestDataSource methodsFor: 'private' stamp: ''!
targetUrlCellColumn: column rowIndex: rowIndex
	| url |
	url := (self elementAt: rowIndex) at: column id.
	^ FTCellMorph new  
		addMorphBack: (
			IconicButton new
				target: self;
				actionSelector: #copyToClipboard:;
				arguments: { url };
				labelGraphic: ((self iconNamed: #smallCopy) scaledToSize: 12@12);
				color: Color transparent;
				helpText: ('Copy url {1} to clipboard' format: { url });
				borderWidth: 0;
				yourself);
		yourself
	! !

!IceGitHubPullRequestDataSource methodsFor: 'private' stamp: ''!
statusCellColumn: column rowIndex: rowIndex
	| status |
	status := (self elementAt: rowIndex) at: column id.
	^ FTCellMorph new  
		cellInset: 5;
		addMorphBack: (self iconForStatus: status) asMorph;
		addMorphBack: status asStringMorph;
		yourself
	! !

!IceGitHubPullRequestDataSource methodsFor: 'private' stamp: ''!
contextCellColumn: column rowIndex: rowIndex
	| context |
	context := (self elementAt: rowIndex) at: column id.
	(context includesSubstring: 'travis-ci')
		ifTrue: [ context := 'travis-ci' ].
	^ FTCellMorph new  
		addMorphBack: context asMorph;
		yourself
		! !

!IceGitHubPullRequestDataSource methodsFor: 'private' stamp: ''!
columnTitleFor: column
	column id = #target_url ifTrue: [ ^ '' ].
	^ super columnTitleFor: column! !

!IceGitHubPullRequestDataSource methodsFor: 'private' stamp: ''!
iconForStatus: status
	^ self iconNamed: (self iconNameForStatus: status)! !

!IceGitHubPullRequestDataSource methodsFor: 'accessing' stamp: ''!
actionColumn: column
	column id = #target_url ifTrue: [ ^ self ].
	^ super actionColumn: column
	! !

!IceGitHubPullRequestDefinition commentStamp: ''!
I am a pull request. 
I can be sent using ==#sendWithCredentials:== protocol.!
!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
body
	^ body! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
baseRemote
	^ baseRemote! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
baseRemote: anObject
	baseRemote := anObject! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
headBranchName
	^ headBranchName! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
title: anObject
	title := anObject! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
credentials
	^ credentials! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
credentials: anObject
	credentials := anObject! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
headRemote: anObject
	headRemote := anObject! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
headBranchName: anObject
	headBranchName := anObject! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
baseBranchName: anObject
	baseBranchName := anObject! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
baseBranchName
	^ baseBranchName! !

!IceGitHubPullRequestDefinition methodsFor: 'actions' stamp: ''!
send
	| pullRequestData |

	pullRequestData := { 
		'title' -> self title.
		'head' -> (self headRemote owner, ':', self headBranchName).
		'base' -> self baseBranchName.
		'body' -> self body.
	} asDictionary.
	
	^ IceGitHubAPI new 
		credentials: self credentials;
		addPullRequest: self baseRemote owner 
			project: self baseRemote projectBasename 
			data: pullRequestData! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
body: anObject
	body := anObject! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
headRemote
	^ headRemote! !

!IceGitHubPullRequestDefinition methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!IceGitHubPullRequestDetailModel commentStamp: ''!
I'm a spec model to present a detailed view of a Pull Request.!
!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
fromText
	^ fromText! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
toText
	^ toText! !

!IceGitHubPullRequestDetailModel methodsFor: 'private' stamp: ''!
iconForMergeable: mergeable
	mergeable = true ifTrue: [ ^ self iconNamed: #smallOk ].
	^ self iconNamed: #smallCancel! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
mergeableLabel
	^ mergeableLabel! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
statusLabel
	^ statusLabel! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing' stamp: ''!
pullRequest: aPullRequest
	pullRequest := aPullRequest.
	urlText text: self pullRequest url.
	authorText text: self pullRequest author.
	fromText text: self pullRequest headLabel.
	toText text: self pullRequest baseLabel.
	bodyText text: self pullRequest body.
	self retrieveStatuses.
	self retrieveDetail! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
urlLabel
	^ urlLabel! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
checksTable
	^ checksTable! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
statusIcon
	^ statusIcon! !

!IceGitHubPullRequestDetailModel methodsFor: 'private' stamp: ''!
retrieveDetail
	
	self mergeableMessage text: (self mergeableMessage text , '  Loading...' ).
	[ | detail mergeable |  
		[  
			detail := self pullRequest detail.
			mergeable := detail at: #mergeable ]
		on: Error do: [ :e | mergeable := nil ].
		mergeableMessage defer: [mergeableMessage text: (self textForMergeable: mergeable).].
		mergeableIcon defer: [mergeableIcon image: ( self iconForMergeable: mergeable).].
		] fork! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
urlText
	^ urlText! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
authorLabel
	^ authorLabel! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing' stamp: ''!
pullRequest
	^ pullRequest! !

!IceGitHubPullRequestDetailModel methodsFor: 'private' stamp: ''!
iconForStatus: status
	status = 'success' ifTrue: [ ^ self iconNamed: #testGreen ].
	status = 'failure' ifTrue: [ ^ self iconNamed: #testRed ].
	status = 'pending' ifTrue: [ ^ self iconNamed: #testYellow ].
	
	^ self iconNamed: #testNotRun! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
bodyText
	^ bodyText! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
mergeableMessage
	^ mergeableMessage! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
authorText
	^ authorText! !

!IceGitHubPullRequestDetailModel methodsFor: 'private - factory' stamp: ''!
newChecksTable
	^ self newTable
		addColumn:
			(SpCompositeTableColumn new
				title: 'state';
				addColumn:
					(SpImageTableColumn
						evaluated: [ :aStatus | self iconForStatus: (aStatus at: 'state') ]);
				addColumn: (SpStringTableColumn evaluated: [ :aStatus | aStatus at: 'state' ]);
				width: 50 * self currentWorld displayScaleFactor);
		addColumn:
			((SpStringTableColumn
				title: 'context';
				evaluated: [ :aStatus | aStatus at: 'context' ])
				width: 120 * self currentWorld displayScaleFactor);
		addColumn:
			(SpStringTableColumn
				title: 'description';
				evaluated: [ :aStatus | aStatus at: 'description' ]);
		beResizable;
		showColumnHeaders;
		contextMenu:
				[ (self rootCommandsGroup / 'checks commands') beRoot asMenuPresenter ]! !

!IceGitHubPullRequestDetailModel methodsFor: 'private' stamp: ''!
retrieveStatuses
"	self statusPanel widget addMorphBack: 'Loading...' asMorph."
	self statusMessage text: (statusMessage text , '  Loading...').
	[ | status generalStatus statuses |	
	[
		status := self pullRequest status.
		generalStatus := status at: 'state'.
		statuses := status at: 'statuses' ]
	on: Error do: [ :e | 
		generalStatus := 'Unknown'.
		statuses := #() ].
		statusMessage defer: [statusMessage text: (self textForMergeable: generalStatus).].
		statusIcon defer: [statusIcon image: (self iconForStatus: generalStatus).].
		checksTable defer: [ checksTable items:(statuses )]
	] fork! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
statusMessage
	^ statusMessage! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
fromLabel
	^ fromLabel! !

!IceGitHubPullRequestDetailModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.

	urlLabel := self newLabel label: 'Url'.
	authorLabel := self newLabel label: 'Author'.
	fromLabel := self newLabel label: 'From'.
	toLabel := self newLabel label: 'Into'.
	mergeableLabel := self newLabel label: 'Mergeable'.
	statusLabel := self newLabel label: 'Status'.

	urlText := self newTextInput disable; yourself.
	authorText  := self newTextInput disable; yourself.
	fromText  := self newTextInput disable; yourself.
	toText  := self newTextInput disable; yourself.
	mergeableIcon := self newImage.
	mergeableMessage := self newTextInput disable; yourself.
	statusIcon  := self newImage.
	statusMessage := self newTextInput disable; yourself.
	checksTable := self newChecksTable.
	bodyText := self newText disable; yourself.
! !

!IceGitHubPullRequestDetailModel methodsFor: 'private' stamp: ''!
textForMergeable: mergeable
	mergeable = true ifTrue: [ ^ 'Yes' ].
	mergeable = false ifTrue: [ ^ 'There are conflicts' ].
	^ mergeable asString
	! !

!IceGitHubPullRequestDetailModel methodsFor: 'accessing - ui' stamp: ''!
toLabel
	^ toLabel! !

!IceGitHubPullRequestDetailModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #urlLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #urlText;
				yourself)
			height: self inputTextHeight;
		add:
			(SpBoxLayout newLeftToRight
				add: #authorLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #authorText;
				yourself)
			height: self inputTextHeight;
		add:
			(SpBoxLayout newLeftToRight
				add: #fromLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #fromText;
				yourself)
			height: self inputTextHeight;
		add:
			(SpBoxLayout newHorizontal
				add: #toLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #toText;
				yourself)
			height: self inputTextHeight;
		add:
			(SpBoxLayout newHorizontal
				add: #mergeableLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #mergeableIcon width: self iconWidth ;
				add: #mergeableMessage;
				yourself)
			height: self inputTextHeight;
		add:
			(SpBoxLayout newLeftToRight
				add: #statusLabel
					withConstraints:
						[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
				add: #statusIcon width: self iconWidth ;
				add: #statusMessage;
				yourself)
			height: self inputTextHeight;
			add: #checksTable;
			add: #bodyText
			withConstraints:
				[ :constraints | constraints width: 80 * self currentWorld displayScaleFactor ];
		yourself! !

!IceGitHubPullRequestDetailModel class methodsFor: 'commands' stamp: ''!
buildCommandsGroupWith: presenterIntance forRoot: rootCommandGroup

	rootCommandGroup register:
		((CmCommandGroup named: 'checks commands') asSpecGroup 
			register: IceTipOpenCheckUrlCommand forSpec)! !

!IceGitHubRejectPullRequestModel commentStamp: ''!
I'm a dialog to collect data about a pull request rejection.!
!IceGitHubRejectPullRequestModel methodsFor: 'accessing' stamp: ''!
availableTypes

	^ #( 'merge' 'squash' 'rebase' )! !

!IceGitHubRejectPullRequestModel methodsFor: 'accessing' stamp: ''!
messageGhostText

	^ 'Commit title

Add an optional extented description'! !

!IceGitHubRejectPullRequestModel methodsFor: 'events' stamp: ''!
onAccept: aBlock

	acceptBlock := aBlock! !

!IceGitHubRejectPullRequestModel methodsFor: 'accessing' stamp: ''!
defaultType

	^ 'merge'! !

!IceGitHubRejectPullRequestModel methodsFor: 'specs' stamp: ''!
titleForWindow

	^ 'Accept pull request'! !

!IceGitHubRejectPullRequestModel methodsFor: 'actions' stamp: ''!
accept

	acceptBlock ifNotNil: [ acceptBlock cull: self ].

	self closeWindow! !

!IceGitHubRejectPullRequestModel methodsFor: 'accessing - ui' stamp: ''!
acceptButton

	^ acceptButton! !

!IceGitHubRejectPullRequestModel methodsFor: 'api' stamp: ''!
initialExtentForWindow

	^ (500 @ 250) scaledByDisplayScaleFactor! !

!IceGitHubRejectPullRequestModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	messageLabel := self newLabel.
	messageText := self newText autoAccept: true.
	acceptButton := self newButton.

	messageLabel label: 'Comment'.
	messageText placeholder: self messageGhostText.
	acceptButton
		label: 'Reject pull request';
		action: [ self accept ].
! !

!IceGitHubRejectPullRequestModel methodsFor: 'accessing' stamp: ''!
message

	^ self messageText text asString! !

!IceGitHubRejectPullRequestModel methodsFor: 'accessing - ui' stamp: ''!
messageLabel

	^ messageLabel! !

!IceGitHubRejectPullRequestModel methodsFor: 'accessing - ui' stamp: ''!
messageText

	^ messageText! !

!IceGitHubRejectPullRequestModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #messageLabel withConstraints: [ :constraints | 
					   constraints width: 80 currentWorld displayScaleFactor ];
				   add: #messageText;
				   yourself);
		  add: #acceptButton
		  withConstraints:
		  [ :constraints | constraints height: self buttonHeight ] yourself! !

!IceGitHubRemoteCommand commentStamp: ''!
I represent the commands that execute on certain repository's remote.!
!IceGitHubRemoteCommand methodsFor: 'accessing' stamp: ''!
repositoryModel

	^ self remoteModel repositoryModel
! !

!IceGitHubRemoteCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceGitHubRemoteCommand! !

!IceGitHubRemoveBranchesAction commentStamp: ''!
I'm an action to remove branches from remotes.!
!IceGitHubRemoveBranchesAction methodsFor: 'private' stamp: ''!
cacheAllBranches
	self remoteBranches do: [ :each | | branchName |
		branchName := each at: 'name'.
		branchesByName 
			at: branchName 
			ifAbsentPut: [ self remoteBranch: branchName ] ]! !

!IceGitHubRemoveBranchesAction methodsFor: 'private' stamp: ''!
remoteBranch: aName
	^ self requestRemoteBranch: aName! !

!IceGitHubRemoveBranchesAction methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	branchesByName := OrderedDictionary new! !

!IceGitHubRemoveBranchesAction methodsFor: 'private' stamp: ''!
remoteBranches
	^ branches ifNil: [ branches := self requestRemoteBranches ]! !

!IceGitHubRemoveBranchesAction methodsFor: 'execute' stamp: ''!
basicExecute
	credentials := IceGitHubAPI ensureCredentials.
	UIManager default
		informUser: ('Retrieving branch information from {1}' format: {self remote url})
		during: [ self cacheAllBranches ].
	IceGitHubRemoveBranchesModel new
		remote: remote;
		selectLabel: 'Remove branches';
		items: branchesByName values ;
		onAccept: [ :selection | self removeBranches: selection ];
		openDialogWithSpec! !

!IceGitHubRemoveBranchesAction methodsFor: 'actions' stamp: ''!
removeBranches: aCollection
	[ 
		aCollection do: [ :each | self removeBranch: each ] ]
	on: IceGitHubError do: [ :e | self reportError: e ]! !

!IceGitHubRemoveBranchesAction methodsFor: 'private' stamp: ''!
requestRemoteBranches
	^ IceGitHubAPI new
		getBranches: self remote owner 
		project: self remote projectBasename! !

!IceGitHubRemoveBranchesAction methodsFor: 'actions' stamp: ''!
removeBranch: json
	| branchName |
	
	branchName := json at: 'name'.
	IceGitHubAPI new 
		credentials: self credentials;
		deleteBranch: self remote owner 
			project: self remote projectBasename
			name: branchName.
	UIManager default inform: ('Branch {1} removed.' format: { branchName })		
	! !

!IceGitHubRemoveBranchesAction methodsFor: 'private' stamp: ''!
requestRemoteBranch: aName
	^ IceGitHubAPI new
		getBranch: self remote owner 
		project: self remote projectBasename
		name: aName! !

!IceGitHubRemoveBranchesCommand commentStamp: ''!
I'm a command to remove branches from remotes.!
!IceGitHubRemoveBranchesCommand methodsFor: 'execute' stamp: ''!
execute

	^ IceGitHubRemoveBranchesAction new
		  repository: self repository;
		  remote: self remote;
		  execute! !

!IceGitHubRemoveBranchesCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Remove Branches...'! !

!IceGitHubRemoveBranchesModel commentStamp: ''!
I'm a dialog to select a list of anything (used by branches now).!
!IceGitHubRemoveBranchesModel methodsFor: 'accessing' stamp: ''!
remote: anObject

	remote := anObject! !

!IceGitHubRemoveBranchesModel methodsFor: 'accessing - ui' stamp: ''!
listPanel

	^ listPanel! !

!IceGitHubRemoveBranchesModel methodsFor: 'initialization' stamp: ''!
initialize

	selectedItems := Set new.
	super initialize! !

!IceGitHubRemoveBranchesModel methodsFor: 'accessing' stamp: ''!
timeSinceLastCommit: branch

	| lastCommitDate |
	lastCommitDate := 	((((branch at: 'commit') at: 'commit')
		at: 'author') at: 'date')asDateAndTime.
		^ '{1} days' format: {(Date today - lastCommitDate) days}! !

!IceGitHubRemoveBranchesModel methodsFor: 'events' stamp: ''!
onAccept: aBlock

	acceptBlock := aBlock! !

!IceGitHubRemoveBranchesModel methodsFor: 'actions' stamp: ''!
confirmSelection

	acceptBlock ifNotNil: [ acceptBlock value: selectedItems ].
	self closeWindow! !

!IceGitHubRemoveBranchesModel methodsFor: 'accessing - ui' stamp: ''!
selectButton

	^ selectButton! !

!IceGitHubRemoveBranchesModel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Select branches to remove on remote {1}' format:
		  { self remote name }! !

!IceGitHubRemoveBranchesModel methodsFor: 'api' stamp: ''!
items: aCollection

	self listPanel items: aCollection! !

!IceGitHubRemoveBranchesModel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ 550 @ 500! !

!IceGitHubRemoveBranchesModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	listPanel := self newTable.
	selectButton := self newButton.
	listPanel
		addColumn:
			((SpCheckBoxTableColumn
				evaluated: [ :branch | selectedItems includes: branch ])
				onActivation: [ :branch | selectedItems add: branch ];
				onDeactivation: [ :branch | selectedItems remove: branch ];
				width: 20 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			((SpStringTableColumn evaluated: [ :branch | branch at: 'name' ])
				width: 350 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			(SpStringTableColumn
				evaluated: [ :branch | self timeSinceLastCommit: branch ]).
	selectButton
		label: 'Select';
		action: [ self confirmSelection ].
! !

!IceGitHubRemoveBranchesModel methodsFor: 'accessing' stamp: ''!
remote

	^ remote! !

!IceGitHubRemoveBranchesModel methodsFor: 'api' stamp: ''!
displayBlock: aBlock
	
	displayBlock := aBlock! !

!IceGitHubRemoveBranchesModel methodsFor: 'api' stamp: ''!
selectLabel: aString

	self selectButton label: aString! !

!IceGitHubRemoveBranchesModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #listPanel;
		  add: #selectButton
		  withConstraints: [ :constraints | 
			  constraints height: self buttonHeight ];
		  yourself! !

!IceGitHubSelectItem commentStamp: ''!
I'm a helper to keep selected items in a list.!
!IceGitHubSelectItem methodsFor: 'accessing' stamp: ''!
value: aBoolean
	aBoolean 
		ifTrue: [ self addItem ]
		ifFalse: [ self removeItem ]
	! !

!IceGitHubSelectItem methodsFor: 'private' stamp: ''!
removeItem
	(list includes: item) ifFalse: [ ^ self ].
	list remove: item ! !

!IceGitHubSelectItem methodsFor: 'private' stamp: ''!
addItem
	(list includes: item) ifTrue: [ ^ self ].
	list add: item ! !

!IceGitHubSelectItem methodsFor: 'accessing' stamp: ''!
value 
	^ list includes: item! !

!IceGitHubSelectItem methodsFor: 'initialization' stamp: ''!
initializeList: aCollection item: anObject
	list := aCollection.
	item := anObject.
	self initialize! !

!IceGitHubSelectItem class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #list:item:'! !

!IceGitHubSelectItem class methodsFor: 'instance creation' stamp: ''!
list: selectedItems item: anObject
	^ self basicNew 
		initializeList: selectedItems item: anObject;
		yourself! !

!IceGitHubTipPullRequestBrowser commentStamp: ''!
Description
--------------------

I a browser centered on a Pull Request. 

I display the list of commits of the PR for review, allow the user to merge the PR and to accept/reject it of the user has the rights on the repository.
!
!IceGitHubTipPullRequestBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList
	"Answer the presenter that is the main list of items of this browser."

	^ commits! !

!IceGitHubTipPullRequestBrowser methodsFor: 'actions' stamp: ''!
mergePullRequestIntoImage

	(UIManager default confirm:
		 ('I will create a new local branch named {1}. Should I continue?' 
			  format: { self pullRequest branchName })) ifFalse: [ ^ self ].

	IceGitHubAPI ensureCredentials.

	self pullRequest mergeIntoWorkingCopy! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing' stamp: ''!
repositoryModel
	^ repositoryModel! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing' stamp: ''!
repositoryModel: anObject
	repositoryModel := anObject! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing - ui' stamp: ''!
commits

	^ commits! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing' stamp: ''!
pullRequest: anObject
	pullRequest := anObject! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing' stamp: ''!
refresh

	| commitModels |
	commitModels := self pullRequest commits collect: [ :each | 
		                (IceTipCommitModel
			                 repositoryModel: self repositoryModel
			                 on: each) beCached ].
	commits items: commitModels! !

!IceGitHubTipPullRequestBrowser methodsFor: 'actions' stamp: ''!
rejectPullRequest

	IceGitHubRejectPullRequestModel new
		onAccept: [ :aModel | 
			IceGitHubAPI ensureCredentials.
			self pullRequest rejectMessage: aModel message.
			self closeWindow ];
		openWithSpec! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing - ui' stamp: ''!
rejectButton

	^ rejectButton! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing - ui' stamp: ''!
commitLabel

	^ commitLabel! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing - ui' stamp: ''!
mergeButton

	^ mergeButton! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing' stamp: ''!
pullRequest
	^ pullRequest! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing' stamp: ''!
titleForWindow

	^ 'Browsing pull request: #{1} {2}' format: { self pullRequest number. self pullRequest title }
! !

!IceGitHubTipPullRequestBrowser methodsFor: 'initialization' stamp: ''!
initializeDiff

	diff beForMerge.
! !

!IceGitHubTipPullRequestBrowser methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aModel

	self repositoryModel: aModel! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing - ui' stamp: ''!
acceptButton

	^ acceptButton! !

!IceGitHubTipPullRequestBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (1050 @ 800) scaledByDisplayScaleFactor! !

!IceGitHubTipPullRequestBrowser methodsFor: 'initialization' stamp: ''!
initializeCommitsTable

	| textStylingBlock |
	textStylingBlock := [ :string :commit | 
	                    commit isMerged
		                    ifTrue: [ string asText ]
		                    ifFalse: [ string asText allBold ] ].

	commits
		beResizable;
		addColumn: (SpStringTableColumn new
				 title: 'Date & time';
				 evaluated: [ :commit | 
					 textStylingBlock
						 value: commit datetime asLocalStringYMDHM
						 value: commit ];
				 width: 120 * self currentWorld displayScaleFactor;
				 yourself);
		addColumn: (SpStringTableColumn new
				 title: 'Id';
				 evaluated: [ :commit | 
					 textStylingBlock value: commit shortId value: commit ];
				 width: 50 * self currentWorld displayScaleFactor;
				 yourself);
		addColumn: (SpStringTableColumn new
				 title: 'Author';
				 evaluated: [ :commit | 
					 textStylingBlock value: commit author value: commit ];
				 width: 120 * self currentWorld displayScaleFactor;
				 yourself);
		addColumn: (SpStringTableColumn new
				 title: 'Comment';
				 evaluated: [ :commit | 
					 textStylingBlock value: commit comment value: commit ];
				 width: 300 * self currentWorld displayScaleFactor;
				 yourself).
		
	! !

!IceGitHubTipPullRequestBrowser methodsFor: 'initialization' stamp: ''!
connectPresenters

	super connectPresenters.
	self commits whenSelectionChangedDo: [ :selection | 
		self diff selectedModel: selection selectedItem ].

	mergeButton action: [ self mergePullRequestIntoImage ].
	acceptButton action: [ self acceptPullRequest ].
	rejectButton action: [ self rejectPullRequest ]! !

!IceGitHubTipPullRequestBrowser methodsFor: 'actions' stamp: ''!
acceptPullRequest

	IceGitHubAcceptPullRequestModel new
		onAccept: [ :aModel | 
			IceGitHubAPI ensureCredentials.
			self pullRequest acceptMessage: aModel message type: aModel type.
			self closeWindow ];
		openWithSpec! !

!IceGitHubTipPullRequestBrowser methodsFor: 'accessing - ui' stamp: ''!
diff

	^ diff! !

!IceGitHubTipPullRequestBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.

	commitLabel := self newLabel.
	commits := self newTable.
	diff := self instantiate: IceTipCommitInfoPresenter.
	mergeButton := self newButton.
	acceptButton := self newButton.
	rejectButton := self newButton.
	
	commitLabel label: 'Commits'.
	self initializeCommitsTable.
	diff beForMerge.
	mergeButton label: 'Merge into image'; icon: (self iconNamed: #smallLoadProject).
	acceptButton label: 'Accept pull request'; icon: (self iconNamed: #testGreen).
	rejectButton label: 'Reject pull request'; icon: (self iconNamed: #testRed).

	self refresh.
! !

!IceGitHubTipPullRequestBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	"Nothing to add"! !

!IceGitHubTipPullRequestBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #commitLabel height: self labelHeight;
		  add: (SpPanedLayout newTopToBottom
				   add: #commits;
				   add: #diff;
				   yourself);
		  add: (SpBoxLayout newLeftToRight
				   add: #mergeButton;
				   add: #acceptButton;
				   add: #rejectButton;
				   yourself)
		  height: self toolbarHeight;
		  yourself! !

!IceGitHubTipPullRequestBrowser class methodsFor: 'accessing' stamp: ''!
taskbarIcon

	^ self iconNamed: #komitterSmalltalkhubRemote! !

!IceGitHubTipPullRequestBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	"Nothing to add"! !

!IceGitHubTipPullRequestBrowser class methodsFor: 'instance creation' stamp: ''!
on: aModel pullRequest: aPullRequest
	^ self basicNew
		pullRequest: aPullRequest;
		setModelBeforeInitialization: aModel;
		initialize;
		yourself! !

!IceGitHubTreeCommand commentStamp: ''!
I represent all the Github commands that work on a Tree item!
!IceGitHubTreeCommand methodsFor: 'testing' stamp: ''!
actsOnBranch: anIceTipTreeBranch

	^ false! !

!IceGitHubTreeCommand methodsFor: 'testing' stamp: ''!
actsOnRemote: aRemoteModel

	^ true! !

!IceGitHubTreeCommand methodsFor: 'accessing' stamp: ''!
remote

	^ self item model entity! !

!IceGitHubTreeCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self item notNil and: [(self item canActivateCommand: self) and: [super canBeExecuted]]! !

!IceGitHubTreeCommand methodsFor: 'testing' stamp: ''!
actsOnTag: aRemoteModel

	^ false! !

!IceGitHubTreeCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceGitHubTreeCommand! !

!IceGitHubTreeNewPullRequestCommand commentStamp: ''!
I'm a command to create a Pull Request!
!IceGitHubTreeNewPullRequestCommand methodsFor: 'executing' stamp: ''!
execute 

	^ IceGitHubNewPullRequestAction new
		repository: self repository;
		remote: self remote;
		execute.
! !

!IceGitHubTreeNewPullRequestCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'New Pull Request'! !

!IceGitHubTreeOpenOnGithubCommand commentStamp: ''!
Description
--------------------

I am a command opening the repository page of the remote on GitHub if possible.!
!IceGitHubTreeOpenOnGithubCommand methodsFor: 'executing' stamp: ''!
execute

	(IceGitHubOpenOnGithubAction
		 organisation: self remote owner
		 projectName: self remote projectName) execute! !

!IceGitHubTreeOpenOnGithubCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Open on github'! !

!IceGitHubTreeRemoveBranchesCommand commentStamp: ''!
I'm a command to remove branches from remotes.!
!IceGitHubTreeRemoveBranchesCommand methodsFor: 'executing' stamp: ''!
execute

	^ IceGitHubRemoveBranchesAction new
		  repository: self repository;
		  remote: self remote;
		  execute! !

!IceGitHubTreeRemoveBranchesCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Remove Remote Branches'! !

!IceGitHubTreeViewPullRequestCommand commentStamp: ''!
I'm a command to show the pull request review browser.!
!IceGitHubTreeViewPullRequestCommand methodsFor: 'executing' stamp: ''!
execute

	^ IceGitHubViewPullRequestAction new
		  repository: self repository;
		  remote: self remote;
		  execute! !

!IceGitHubTreeViewPullRequestCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'View Pull Requests'! !

!IceGitHubViewPullRequestAction commentStamp: ''!
I'm an action to view the open pull Requests.!
!IceGitHubViewPullRequestAction methodsFor: 'executing' stamp: ''!
basicExecute
	credentials := IceGitHubAPI ensureCredentials.
	
	UIManager default
		informUser: ('Retrieving pull requests from {1}' format: {self remote})
		during: [ (IceTipGitHubPullRequestListBrowser onRepository: self repository)
				remote: self remote;
				refreshPullRequests;
				openWithSpec ]! !

!IceGitHubViewPullRequestsCommand commentStamp: ''!
I'm a command to show the pull request review browser.!
!IceGitHubViewPullRequestsCommand methodsFor: 'execute' stamp: ''!
execute

	^ IceGitHubViewPullRequestAction new
		  repository: self repository;
		  remote: self remote;
		  execute! !

!IceGitHubViewPullRequestsCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'View Pull Requests...'! !

!IceGitIndex methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ modifiedFilePaths isEmpty! !

!IceGitIndex methodsFor: 'accessing' stamp: ''!
includes: aRelativePath 
	
	^ modifiedFilePaths includes: aRelativePath! !

!IceGitIndex methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	modifiedFilePaths := Set new! !

!IceGitIndex methodsFor: 'adding' stamp: ''!
addPackage: anIcePackageDefinition 
	
	| pathSegments |
	pathSegments := repository subdirectoryPath segments asOrderedCollection.
	pathSegments add: (repository writerClass directoryNameFor: anIcePackageDefinition).	
	self addPath: (RelativePath withAll: pathSegments)! !

!IceGitIndex methodsFor: 'API - commiting' stamp: ''!
libGitCommitsFrom: aLGitRepository for: aListOfCommitish
	^ aListOfCommitish collect: 
		[ :commitish | 
		LGitCommit of: aLGitRepository fromId: (LGitId fromHexString: commitish id) ]! !

!IceGitIndex methodsFor: 'storing' stamp: ''!
storeMCVersion: aMCVersion 

	| pathSegments |
	repository internalStoreVersion: aMCVersion.
	pathSegments := OrderedCollection new.
	repository subdirectory
		ifNotEmpty: [ :directory | pathSegments add: directory ].
	pathSegments add: (repository writerClass directoryNameFor: aMCVersion package).
	
	self addPath: (RelativePath withAll: pathSegments)! !

!IceGitIndex methodsFor: 'storing' stamp: ''!
storeVersion: aMCVersion 
	
	repository internalStoreVersion: aMCVersion! !

!IceGitIndex methodsFor: 'storing' stamp: ''!
storeFileDefinition: anIceFileDefinition 
	
	(repository location resolve: anIceFileDefinition path)
		ensureDelete;
		binaryWriteStreamDo: [ :writeStream |
			writeStream nextPutAll: anIceFileDefinition binaryContents ].

	self addPath: anIceFileDefinition path! !

!IceGitIndex methodsFor: 'updating' stamp: ''!
updateDiskWorkingCopy: anIceDiff
	anIceDiff tree
		accept:
			(IceGitWorkingCopyUpdateVisitor new
				repository: repository;
				index: self;
				diff: anIceDiff)! !

!IceGitIndex methodsFor: 'operations' stamp: ''!
addToGitIndex

	repository addFilesToIndex: modifiedFilePaths.! !

!IceGitIndex methodsFor: 'API - commiting' stamp: ''!
commitWithMessage: message andParents: parentCommits
	
	| index |
	repository handleLibgitError: [ | signature commitId indexTreeId |
		self addToGitIndex.
		[ signature := self repositoryHandle defaultSignature ]
			on: LGit_GIT_ENOTFOUND, LGit_GIT_ERROR
			do: [ :e | IceGitUsernameOrEmailNotFound guessKind: e ifNot: [ e pass ] ].
		index := self repositoryHandle index.
		indexTreeId := index writeTreeAndReturnOid.
		index free.
		commitId := (LGitCommitBuilder of: self repositoryHandle)
			tree: (LGitTree of: self repositoryHandle fromId: indexTreeId);
			message: message withUnixLineEndings utf8Encoded asString "FFI is expecting an string";
			parents:
				(self repositoryHandle isUnborn
					ifTrue: [ #() ]
					ifFalse: [ self libGitCommitsFrom: self repositoryHandle for: parentCommits ]);
			"'HEAD' branch could not exist yet. No problem, libgit will create it, 
				but we have to remember it to notify the frontend."
				updateReference:
				([ self repositoryHandle head name ]
					on: LGit_GIT_EUNBORNBRANCH
					do: [ repository branch gitRef ]);
			author: signature;
			committer: signature;
			writeCommit;
			commitId.
		^ repository commitFromGitCommit: (LGitCommit of: self repositoryHandle fromId: commitId)]! !

!IceGitIndex methodsFor: 'accessing' stamp: ''!
repositoryHandle
	
	<repositoryHandleAccessor>
	^ repository repositoryHandle! !

!IceGitIndex methodsFor: 'storing' stamp: ''!
addPath: aPath

	modifiedFilePaths add: aPath! !

!IceGitIndex methodsFor: 'storing' stamp: ''!
removeFileDefinition: anIceFileDefinition 
	
	(repository location resolve: anIceFileDefinition path)
		ensureDelete.

	self addPath: anIceFileDefinition path! !

!IceGitLocalBranch methodsFor: 'private - tracking' stamp: ''!
upstream
	
	^ self upstreamIfNone: [ IceUpstreamNotConfigured signal ]! !

!IceGitLocalBranch methodsFor: 'API - branches' stamp: ''!
delete
	repository handleLibgitError: [ | found |
		found := self repositoryHandle lookupLocalBranch: self name ifAbsent: [ nil ].
		self repositoryHandle deleteBranch: found ]! !

!IceGitLocalBranch methodsFor: 'accessing' stamp: ''!
gitRef
	
	^ self name! !

!IceGitLocalBranch methodsFor: 'private - pushing' stamp: ''!
pushBranchToRemote: aRemote gitRemote: gitRemote progress: pushProgress
	
	gitRemote 
		pushWithRefSpec: (LGitRefSpec new
			source: self fullname;
			destination: self fullname;
			yourself)
		pushOptions: (gitRemote ffiLibrary uniqueInstance pushOptionsStructureClass defaults
			callbacks: ((gitRemote ffiLibrary uniqueInstance remoteCallbacksStructureClass withProvider: (IceCredentialsProvider defaultForRemote: aRemote)) 
				pushTransferProgress: pushProgress; 
				yourself);
			yourself)! !

!IceGitLocalBranch methodsFor: 'accessing' stamp: ''!
trackedBranch
	
	| upstream |
	upstream := self upstream.
	upstream ifNil: [ 
		upstream := self setUpstream: (self lookupRemoteBranch: '/origin/', self name) ].
	
	^ upstream! !

!IceGitLocalBranch methodsFor: 'file-access' stamp: ''!
fileSystem
	
	^ self commit fileSystem! !

!IceGitLocalBranch methodsFor: 'tracking' stamp: ''!
tracksRemoteBranch
	
	^ self hasUpstream! !

!IceGitLocalBranch methodsFor: 'private - pushing' stamp: ''!
pushTagsToRemote: aRemote gitRemote: gitRemote progress: pushProgress

	self tags do: [ :tag | 
		self 
			pushTag: tag 
			toRemote: aRemote 
			gitRemote: gitRemote 
			progress: pushProgress ]! !

!IceGitLocalBranch methodsFor: 'accessing' stamp: ''!
branchNamePrefix

	^ 'refs/heads/'! !

!IceGitLocalBranch methodsFor: 'private - pushing' stamp: ''!
setUpstreamIfMissing: aRemote
	
	self hasUpstream ifTrue: [ ^ self ].
	self setUpstream: (aRemote remoteBranchNamed: self gitRef)! !

!IceGitLocalBranch methodsFor: 'accessing' stamp: ''!
shortname

	^ self name! !

!IceGitLocalBranch methodsFor: 'API - remotes' stamp: ''!
setUpstream: anIceGitRemoteBranch
	
	repository handleLibgitError: [ | localBranch |
		localBranch := self repositoryHandle lookupLocalBranch: self name.
		localBranch setUpstream: anIceGitRemoteBranch gitRef ]! !

!IceGitLocalBranch methodsFor: 'accessing' stamp: ''!
name

	^ self fullname withoutPrefix: self branchNamePrefix! !

!IceGitLocalBranch methodsFor: 'accessing' stamp: ''!
commit: anIceGitCommit
	"Update the branch to point to a commit.
	If the branch is HEAD, check it out in disk also."

	repository handleLibgitError: [ | localBranch gitcommit |
		localBranch := self repositoryHandle lookupLocalBranch: self name.
		gitcommit := self repositoryHandle revparse: anIceGitCommit id.
		localBranch setTargetId: gitcommit id.
		self = repository head
			ifTrue: [ self repositoryHandle
					checkout_treeish: gitcommit
					opts:
						(LGitCheckoutOptions defaults
							checkoutStrategy: LGitCheckoutStrategyEnum git_checkout_force;
							yourself) ]]! !

!IceGitLocalBranch methodsFor: 'private - tracking' stamp: ''!
hasUpstream
	
	self upstreamIfNone: [ ^ false ].
	^ true! !

!IceGitLocalBranch methodsFor: 'accessing' stamp: ''!
repositoryHandle
	
	<repositoryHandleAccessor>
	^ repository repositoryHandle! !

!IceGitLocalBranch methodsFor: 'private - pushing' stamp: ''!
pushTag: tag toRemote: aRemote gitRemote: gitRemote progress: pushProgress

	gitRemote 
		pushWithRefSpec: (LGitRefSpec new
			source: 'refs/tags/' , tag name;
			destination: 'refs/tags/' , tag name;
			yourself)
		pushOptions: (gitRemote ffiLibrary uniqueInstance pushOptionsStructureClass defaults
			callbacks: ((gitRemote ffiLibrary uniqueInstance remoteCallbacksStructureClass withProvider: (IceCredentialsProvider defaultForRemote: aRemote))
				pushTransferProgress: pushProgress;
				yourself);
			yourself)! !

!IceGitLocalBranch methodsFor: 'private - tracking' stamp: ''!
upstreamIfNone: aBlock
	repository handleLibgitError: [ | localBranch gitUpstream |
		localBranch := self repositoryHandle lookupLocalBranch: self name.
		gitUpstream := localBranch upstream.
		gitUpstream ifNil: [ ^ aBlock value ].
		^ IceGitRemoteBranch named: gitUpstream name inRepository: repository ]! !

!IceGitLocalBranch methodsFor: 'accessing' stamp: ''!
commit
	
	repository handleLibgitError: [ | gitCommit gitId |
		gitId := (self repositoryHandle lookupLocalBranch: self name) targetId.
		gitCommit := LGitCommit of: self repositoryHandle fromId: gitId.
		^ self repository commitFromGitCommit: gitCommit ]! !

!IceGitLocalBranch methodsFor: 'API - remotes' stamp: ''!
pushTo: aRemote

	repository handleLibgitError: [ 
		self basicPushTo: aRemote ]! !

!IceGitLocalBranch methodsFor: 'merging' stamp: ''!
mergeWithBranch: anIceGitRemoteBranch 
	self shouldBeImplemented.! !

!IceGitLocalBranch methodsFor: 'private - pushing' stamp: ''!
basicPushTo: aRemote
	| gitRemote |
	
	gitRemote := (LGitRemote of: self repositoryHandle named: aRemote name) lookup.
	[ 
		| pushProgress |
		pushProgress := IcePushTransferProgress new.
		"Push branch"
		self 
			pushBranchToRemote: aRemote 
			gitRemote: gitRemote 
			progress: pushProgress.
		"Push tags"
		self 
			pushTagsToRemote: aRemote
			gitRemote: gitRemote
			progress: pushProgress.
			
		"Verify we have an stream"
		self setUpstreamIfMissing: aRemote ] 
	on: LGit_GIT_ENONFASTFORWARD 
	do: [ :e | 
		e resignalAs: (IceRemoteDesynchronized new
			remote: aRemote;
			yourself) ]! !

!IceGitLocalRepositoryType commentStamp: ''!
I resolve git local repositories (repositories already existing on your disk).
A gitlocal repositoy is composed of: 

gitlocal://full/path/to/repository

gitlocal  		- The git local identifier
full/path/...	- This is a path to the place where the sources are. 
	
For example, if you have a  repository in '/dev/voyage', which also has sources in subdirectory 'mc', your full path will be: '/dev/voyage/mc'. A part of my responsibilities is to find the git root  in the path provided.

Example: 
------------
A script to install voyage using this would like more or less like this:

Metacello new
	repository: 'gitlocal://Users/esteban/Dev/Repository/voyage/mc';
	baseline: 'Voyage';
	load: 'mongo tests'.
!
!IceGitLocalRepositoryType methodsFor: 'accessing' stamp: ''!
mcRepository

	| repository tuple extractedLocation |

	tuple := self splitRootAndSubdirectoryFromLocation.
	extractedLocation := tuple first asFileReference asAbsolute.
	repository := IceRepository registry 
		detect: [ :each | 
			each location notNil 
				and: [ each location resolve asAbsolute = extractedLocation ] ]
		ifNone: [ 
			(IceRepositoryCreator new 
				location: tuple first;
				subdirectory: tuple second;
				ensureProjectFile;
				createRepository)
				register ].
			
	^ repository metacelloAdapter: repository head description.! !

!IceGitLocalRepositoryType methodsFor: 'private' stamp: ''!
splitRootAndSubdirectoryFromLocation
	| root subDir |
	(self location beginsWith: (self class type, '://'))
		ifFalse: [ self error: 'Invalid URL (It should be ', self class type, '://...)' ].
	root := (self location allButFirst: self class type size + 3) asFileReference.
	subDir := #().
	[ root isRoot or: [ self isGitRoot: root ] ] 
	whileFalse: [ 
		(root asAbsolute = FileSystem workingDirectory)
			ifFalse: [ subDir := subDir copyWithFirst: root basename ].
		root := root parent ].
	root isRoot ifTrue: [ self error: 'I can''t find a .git/config file.' ].
	
	^ { 
		root. "a FileReference"
		String streamContents: [ :stream | subDir asStringOn: stream delimiter: '/' ] "a String" }! !

!IceGitLocalRepositoryType methodsFor: 'testing' stamp: ''!
isGitRoot: aReference
	^ IceRepositoryCreator isGitRoot: aReference! !

!IceGitLocalRepositoryType class methodsFor: 'accessing' stamp: ''!
type
	^ 'gitlocal'! !

!IceGitNetworkRemote commentStamp: ''!
Base abstract class for SCP and HTTPS remotes.!
!IceGitNetworkRemote methodsFor: 'accessing' stamp: ''!
detailedInfo
	^ { 
		'Origin' -> self url.
		"'Remote User' -> self userName."
		'Remote host' -> (self port = self class defaultPort ifTrue: [ self host ] ifFalse: [self host, ':', self portName]).
		'Repo Owner' -> self owner.
	} ! !

!IceGitNetworkRemote methodsFor: 'comparing' stamp: ''!
referencesSameRemoteLocationAs: another
	^ (self url withoutSuffix: '.git') sameAs: (another url withoutSuffix: '.git')! !

!IceGitNetworkRemote methodsFor: 'accessing' stamp: ''!
host
	^ host! !

!IceGitNetworkRemote methodsFor: 'querying' stamp: ''!
organizer
	^ self owner! !

!IceGitNetworkRemote methodsFor: 'private' stamp: ''!
stripPossibleExtension: aString
	^ (aString endsWith: '.git')
		ifTrue: [ aString allButLast: 4 ]
		ifFalse: [ aString ]! !

!IceGitNetworkRemote methodsFor: 'accessing' stamp: ''!
user
	^user! !

!IceGitNetworkRemote methodsFor: 'accessing' stamp: ''!
owner
	 ^ owner! !

!IceGitNetworkRemote methodsFor: 'accessing' stamp: ''!
parseUrl
	| znUrl |
	znUrl := ZnUrl fromString: url.
	user := znUrl username.
	host := znUrl host.
	port := znUrl port ifNil: [self class defaultPort].

	path := znUrl segments allButLast: (2 min: znUrl segments size).
	
	znUrl segments size >= 2
		ifTrue: [ owner := (znUrl segments last: 2) first ].

	projectName := self stripPossibleExtension: (znUrl segments last).! !

!IceGitNetworkRemote methodsFor: 'accessing' stamp: ''!
port

	^port ifNil: [ self class defaultPort ]! !

!IceGitNetworkRemote methodsFor: 'private' stamp: ''!
basicUrl: aString
	url := aString! !

!IceGitNetworkRemote methodsFor: 'accessing' stamp: ''!
portName
	^self port asString! !

!IceGitNetworkRemote methodsFor: 'accessing' stamp: ''!
userName
	^user ifNil: [ '' ]
	
! !

!IceGitNetworkRemote methodsFor: 'accessing' stamp: ''!
projectPath

	| projectPath |
	"Work on a copy of the path"
	projectPath := OrderedCollection withAll: self path.
	self owner ifNotNil: [ projectPath add: self owner ].
	projectPath add: self projectName.
	^ (RelativePath withAll: projectPath) pathString! !

!IceGitNetworkRemote methodsFor: 'accessing' stamp: ''!
path
	^path ifNil: [ path := OrderedCollection new ].! !

!IceGitNetworkRemote class methodsFor: 'accessing - defaults' stamp: ''!
defaultPort
	^self subclassResponsibility! !

!IceGitNetworkRemote class methodsFor: 'testing' stamp: ''!
canHandleUrl: aString 
	"I am abstract I can't handle any url."
	^ false! !

!IceGitNetworkRemote class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceGitNetworkRemote ! !

!IceGitRemote methodsFor: 'comparing' stamp: ''!
= another
	^ self species = another species
		and: [ self referencesSameRemoteLocationAs: another ]! !

!IceGitRemote methodsFor: 'branches' stamp: ''!
branches
	
	^ self localRepository remoteTrackedBranches select: [ :e | e remoteName = self name ]! !

!IceGitRemote methodsFor: 'fetching' stamp: ''!
fetchBranch: aBranch
	
	localRepository handleLibgitError: [
		[ | refSpec remote |
		refSpec := LGitRefSpec
			fromString:
				('{2}:refs/remotes/{1}/{2}'
					format:
						{self name.
						aBranch name}).
		(remote := LGitRemote of: self repositoryHandle named: self name)
			lookup;
			fetchWithCredentials: (IceCredentialsProvider defaultForRemote: self) refSpec: refSpec ]
			on: LGitAbstractError
			do: [ :e | e acceptError: (IceLibgitErrorVisitor onContext: self) ] ]! !

!IceGitRemote methodsFor: 'branches' stamp: ''!
remoteBranchNamed: aString ifPresent: presentBlock ifAbsent: absentBlock

	localRepository handleLibgitError: [| found |
		found := self repositoryHandle lookupRemoteBranch: self name , '/' , aString ifAbsent: [ nil ].
		^ found ifNil: absentBlock ifNotNil: [ ^ presentBlock value: (localRepository basicNewRemoteBranchNamed: found name) ]]! !

!IceGitRemote methodsFor: 'fetching' stamp: ''!
fetch
	
	localRepository handleLibgitError: [
		[ (LGitRemote of: self repositoryHandle named: self name)
			lookup;
			fetchWithCredentials: (IceCredentialsProvider defaultForRemote: self)
			andProgressCallback: IceGitTransferProgress new ]
			on: LGitAbstractError
			do: [ :e | e acceptError: (IceLibgitErrorVisitor onContext: self) ].
		
		"Call post fetch to fix unknown commits"
		localRepository postFetch ]! !

!IceGitRemote methodsFor: 'accessing' stamp: ''!
repositoryHandle

	<repositoryHandleAccessor>
	^ localRepository repositoryHandle! !

!IceGitRemote class methodsFor: 'testing' stamp: ''!
isValidUrl: aRepositoryUrl
	^ self allSubclasses  
		anySatisfy: [ :subclass | subclass canHandleUrl: aRepositoryUrl ]! !

!IceGitRemote class methodsFor: 'instance creation' stamp: ''!
url: aRepositoryUrl
	self allSubclasses
		detect: [ :subclass | subclass canHandleUrl: aRepositoryUrl ]
		ifFound: [ :subclass | ^ subclass new url: aRepositoryUrl ]
		ifNone: [ IceWrongUrl signal: 'Remote repository scheme not supported: ', aRepositoryUrl ]! !

!IceGitRemote class methodsFor: 'testing' stamp: ''!
canHandleUrl: aRepositoryUrl
	^ self subclassResponsibility ! !

!IceGitRemote class methodsFor: 'instance creation' stamp: ''!
name: aName url: anUrl
	^ (self url: anUrl)
		name: aName;
		yourself! !

!IceGitRemote class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceGitRemote! !

!IceGitRemoteBranch methodsFor: 'API - branches' stamp: ''!
delete
	
	repository handleLibgitError: [ | found |
		found := self repositoryHandle lookupRemoteBranch: self name ifAbsent: [ nil ].
		self repositoryHandle deleteBranch: found ]! !

!IceGitRemoteBranch methodsFor: 'accessing' stamp: ''!
gitRef
	
	^ self name! !

!IceGitRemoteBranch methodsFor: 'filesystem' stamp: ''!
fileSystem
	^ self commit fileSystem! !

!IceGitRemoteBranch methodsFor: 'accessing' stamp: ''!
shortname

	^ self name withoutPrefix: self remoteName, '/'! !

!IceGitRemoteBranch methodsFor: 'accessing' stamp: ''!
remoteName
	
	^ (self fullname substrings: '/') third! !

!IceGitRemoteBranch methodsFor: 'accessing' stamp: ''!
name

	^ self fullname withoutPrefix: self prefix! !

!IceGitRemoteBranch methodsFor: 'accessing' stamp: ''!
repositoryHandle

	<repositoryHandleAccessor>
	^ repository repositoryHandle! !

!IceGitRemoteBranch methodsFor: 'accessing' stamp: ''!
prefix

	^ 'refs/remotes/'! !

!IceGitRemoteBranch methodsFor: 'accessing' stamp: ''!
commit
	
	repository handleLibgitError: [ | gitCommit gitId |
		gitId := (self repositoryHandle lookupRemoteBranch: self name) targetId.
		gitCommit := LGitCommit of: self repositoryHandle fromId: gitId.
		^ self repository commitFromGitCommit: gitCommit ]! !

!IceGitRepositoryType commentStamp: ''!
I resolve a generic git repository.

I accept direct URLs as my parameter to form a repository using a MCGitRemoteRepository. I can parse then this kind of urls:

git:https://github.com/user/project.git
git:git@github.com:user/project.git!
!IceGitRepositoryType methodsFor: 'accessing' stamp: ''!
mcRepositoryClass
	
	^ MCGitRemoteRepository! !

!IceGitRepositoryType class methodsFor: 'accessing' stamp: ''!
type

	^ 'git'! !

!IceGitScpRemote commentStamp: ''!
A remote repository created out of a SCP url, such as 'git@github.com:npasserini/iceberg.git'.

!
!IceGitScpRemote methodsFor: 'testing' stamp: ''!
referencesSameRemoteLocationAs: aRemote
	^ ((super referencesSameRemoteLocationAs: aRemote)
		or: [ self httpsUrl = aRemote httpsUrl ])
			! !

!IceGitScpRemote methodsFor: 'testing' stamp: ''!
isAlternateSSHUrl: aString 
	
	^ self class isAlternateSSHUrl: aString! !

!IceGitScpRemote methodsFor: 'testing' stamp: ''!
isSSHUrl: aString 
	
	^ self class isSSHUrl: aString! !

!IceGitScpRemote methodsFor: 'private - patches' stamp: ''!
parseUrl
	| urlStream restSegments |
	(self isSSHUrl: url)
		ifTrue: [ ^ super parseUrl ].
	
	(self isAlternateSSHUrl: url) ifFalse: [ IceWrongUrl signal: 'Remote repository scheme not supported: ', url ].
	
	"We now parse alternate ssh urls like lars@myserver.example.com:repos/myrepo.git"
	urlStream := url readStream.
	user := urlStream upTo: $@.
	host := (urlStream upTo: $:) ifEmpty: [ nil ].
	restSegments := urlStream upToEnd substrings: '/'.
	
	path := restSegments size >= 2
		ifTrue: [ restSegments allButLast: 2 ]
		ifFalse: [ #() ].
	owner := restSegments size > 1
		ifTrue: [ restSegments at: (restSegments size - 1) ]
		ifFalse: [ nil ].

	restSegments isEmpty ifTrue: [ IceWrongUrl signal: 'Remote repository scheme not supported: ', url ].
	projectName := self stripPossibleExtension: (restSegments last)! !

!IceGitScpRemote methodsFor: 'private - patches' stamp: ''!
httpsUrl
	^ 'https://{1}/{2}.git' format: { self host . self projectPath }
! !

!IceGitScpRemote class methodsFor: 'accessing - defaults' stamp: ''!
defaultPort
	^ 22! !

!IceGitScpRemote class methodsFor: 'testing' stamp: ''!
isAlternateSSHUrl: aUrl
	"Definition taken from https://stackoverflow.com/questions/14348874/git-repository-url-ssh-syntax-without-absolute-path"
	^ (aUrl includesSubstring: '://') not and: [ (aUrl beginsWith: '/') not ]! !

!IceGitScpRemote class methodsFor: 'testing' stamp: ''!
isSSHUrl: aUrl
	^ aUrl beginsWith: 'ssh://'! !

!IceGitScpRemote class methodsFor: 'testing' stamp: ''!
canHandleUrl: aUrl
	"Very simplistic implementation that does not cover all cases. Either there
	is the ssh scheme or treat all non absolute paths as SSH"

	^ (self isSSHUrl: aUrl) or: [ self isAlternateSSHUrl: aUrl ]! !

!IceGitSshRemote commentStamp: ''!
A remote repository created out of a git  url, such as 'git://localhost/owner/repository.git'.

!
!IceGitSshRemote methodsFor: 'testing' stamp: ''!
referencesSameRemoteLocationAs: aRemote
	^ ((super referencesSameRemoteLocationAs: aRemote)
		or: [ self httpsUrl sameAs: aRemote httpsUrl ])
			! !

!IceGitSshRemote methodsFor: 'private - patches' stamp: ''!
httpsUrl
	^ 'https://{1}/{2}.git' format: { self host . self projectPath }
! !

!IceGitSshRemote class methodsFor: 'accessing - defaults' stamp: ''!
defaultPort
	^9418! !

!IceGitSshRemote class methodsFor: 'testing' stamp: ''!
canHandleUrl: aRepositoryUrl
	^ aRepositoryUrl beginsWith: 'git://'! !

!IceGitTransferProgress methodsFor: 'accessing' stamp: ''!
block
	^ [ :stats :payload | 
		| gitStats |
		gitStats := LGitTransferProgress fromHandle: stats.
		job ensureStarted.
		
		job min: 0.
		job max: gitStats prim_total_objects.
		job current: gitStats prim_received_objects.
		job title: ('Fetching Git objects... ({1}/{2})' format: { gitStats prim_received_objects. gitStats prim_total_objects}).
		
		job changed.
		
		0
	]! !

!IceGitTransferProgress methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	job := IceExternalJob new
		title: 'Fetching Git objects...';
		yourself.
		
	self initializeBlock.! !

!IceGitTransferProgress methodsFor: 'initialize-release' stamp: ''!
initializeBlock
	self signature: self class fnSpec block: self block.! !

!IceGitUnbornBranch methodsFor: 'accessing' stamp: ''!
gitRef
	"When the repository is unborn, the repository has a single ref that points to no commits.
	The HEAD file then contains some content such as:
	
		ref: refs/heads/[branch_name]
	"

	^ ((repository location / '.git' / 'HEAD') contents withoutPrefix: 'ref: ') trimBoth! !

!IceGitUnbornBranch methodsFor: 'accessing' stamp: ''!
branchNamePrefix

	^ 'refs/heads/'! !

!IceGitUnbornBranch methodsFor: 'accessing' stamp: ''!
name
	"Remove the refs/heads prefix from the full branch name"
	^ self gitRef withoutPrefix: self branchNamePrefix! !

!IceGitUsernameOrEmailNotFound commentStamp: ''!
I'm an error to be sent when the error that comes from external library can be guessed to be the absense of user.name and user.email properties.!
!IceGitUsernameOrEmailNotFound methodsFor: 'visiting' stamp: ''!
isResumable

	^ true! !

!IceGitUsernameOrEmailNotFound methodsFor: 'visiting' stamp: ''!
acceptError: anObject
	anObject visitMissingCredentialsError: self! !

!IceGitUsernameOrEmailNotFound class methodsFor: 'accessing' stamp: ''!
guessKind: anError ifNot: notBlock 
	(anError messageText asLowercase = 'Config value ''user.name'' was not found' asLowercase
		or: [ anError messageText asLowercase = 'Config value ''user.email'' was not found' asLowercase
		or: [ anError messageText asLowercase = 'Failed to parse signature - Signature cannot have an empty name or email' asLowercase ] ])
		ifTrue: [ ^ self signal ].
	notBlock value! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitNonConflictingOperation: anIceNonConflictingOperation 
	
	anIceNonConflictingOperation chosenOperation accept: self! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitDirectoryDefinition: anIceDirectoryDefinition 
	self visitChildrenOf: currentNode! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitPackage: anIcePackageDefinition 
	
	"I am a package, I have to export my changes using the repository format.
	Thus, I cut here the recursion on my children, I have to do the recursion myself"
	| mcPackage snapshot patcher version |
	mcPackage := MCPackage named: anIcePackageDefinition name.

	"Take a snapshot of the package from the version we want to apply our changes on (usually the commit in disk) and apply them to it.
	This will create a snapshot with only the selected changes"
	snapshot := [diff targetVersion snapshotFor: anIcePackageDefinition]
		on: NotFound do: [ MCSnapshot empty ].
	patcher := MCPatcher snapshot: snapshot.
	currentNode accept: (IceMCSnapshotPatchVisitor new
		patcher: patcher;
		yourself).

	version := MCVersion new
		setPackage: mcPackage
		info: (IceMCVersionInfo package: mcPackage message: 'Internal...')
		snapshot: patcher patchedSnapshot
		dependencies: #().

	"Save version to disk.
	The repository will take care of the correct output format.
	Note: this step does not perform a commit, it just exports changes so the repository can then perform a commit"
	
	index storeVersion: version! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitRemoval: anIceRemoval 
	
	anIceRemoval definition removeFrom: self! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'actions' stamp: ''!
removeFileReferenceInPath: aPath
	
	(repository workingCopy fileSystem resolve: aPath) ensureDeleteAll! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitAddition: anIceAddition 
	
	anIceAddition definition accept: self! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'operations' stamp: ''!
removeFile: anIceFileDefinition 
	
	(repository location resolvePath: anIceFileDefinition path)
		ensureDelete! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitRootDefinition: anIceRootDefinition 
	
	self visitChildrenOf: currentNode! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'accessing' stamp: ''!
diff: anIceDiff 
	diff := anIceDiff! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'operations' stamp: ''!
removePackage: aDefinition
	
	(repository location resolvePath: aDefinition path) ensureDeleteAll! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitModification: anIceModification 
	
	^ anIceModification leftDefinition accept: self! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'accessing' stamp: ''!
index: anIndex 
	index := anIndex! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitNoModification: anIceNoModification 
	
	anIceNoModification definition accept: self! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'accessing' stamp: ''!
repository: anIceLibgitRepository 
	repository := anIceLibgitRepository! !

!IceGitWorkingCopyUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitFileNode: anIceFileDefinition 
	
	| reference |
	reference := repository location resolve: anIceFileDefinition path.
	reference parent ensureCreateDirectory.
	reference
		ensureDelete;
		binaryWriteStreamDo: [ :writeStream |
			writeStream nextPutAll: anIceFileDefinition basicContents ].! !

!IceGithubRepositoryType commentStamp: ''!
I resolve Github repositories!
!IceGithubRepositoryType methodsFor: 'accessing' stamp: ''!
mcRepository
	| baseRepo |
	
	self guessRegisteredRepository
		ifNotNil: [ :repo | 
			repo isValid ifTrue: [ ^ repo metacelloAdapter: self projectVersion  ].
			"If the repo is not valid, we forget it and reget a new one. Because Metacello want to use it"
			repo forget	].
		
	baseRepo := self mcRepositoryClass location: self location.
	^ (Iceberg icebergRepositoriesURLs includes: baseRepo scpUrl)
		ifTrue: [ 
			"Do not use Iceberg to load iceberg code, 
			see https://github.com/pharo-vcs/iceberg/issues/168"
			baseRepo ]
		ifFalse: [  
			baseRepo getOrCreateIcebergRepository metacelloAdapter: self projectVersion ]
		! !

!IceGithubRepositoryType class methodsFor: 'accessing' stamp: ''!
type
	^ 'github'! !

!IceGitlabRepositoryType commentStamp: ''!
I resolve Gilab repositories!
!IceGitlabRepositoryType class methodsFor: 'accessing' stamp: ''!
type
	^ 'gitlab'! !

!IceHistory commentStamp: ''!
I provide optimized access to the history of a commitish. I access the history of a commit in a batch, caching them in an internal collection to provide fast access.

Moreover, I implement fast access to history information such as knowing if a commit is merged in head or not.

Future optimizations: 
 - implement pagination!
!IceHistory methodsFor: 'testing' stamp: ''!
isHead
	
	^ commitish = repository head! !

!IceHistory methodsFor: 'testing' stamp: ''!
includes: anIceGitCommit 
	
	^ self commitDictionary includesKey: anIceGitCommit id! !

!IceHistory methodsFor: 'history' stamp: ''!
lookupCommits
	
	| newCommitDictionary newCommits |
	newCommitDictionary := Dictionary new.
	newCommits := OrderedCollection new.
	commitish commitsDo: [ :each | | commit |
		commit := IceHistoryCommit commit: each history: self.
		newCommits add: commit.
		newCommitDictionary at: each id put: commit ].
	commitDictionary := newCommitDictionary.
	commits := newCommits.! !

!IceHistory methodsFor: 'history' stamp: ''!
commits
	
	commits ifNil: [ self lookupCommits ].
	^ commits! !

!IceHistory methodsFor: 'accessing' stamp: ''!
headHistory
	
	^ headHistory ifNil: [ 
		headHistory := IceHistory on: repository headCommit repository: repository ]! !

!IceHistory methodsFor: 'accessing' stamp: ''!
commitish: aCommitish
	commitish := aCommitish! !

!IceHistory methodsFor: 'accessing' stamp: ''!
name
	
	^ commitish name! !

!IceHistory methodsFor: 'history' stamp: ''!
commitDictionary

	commitDictionary ifNil: [ self lookupCommits ].
	^ commitDictionary! !

!IceHistory methodsFor: 'accessing' stamp: ''!
repository: aRepository 
	repository := aRepository! !

!IceHistory class methodsFor: 'instance creation' stamp: ''!
on: commitish repository: anIceRepository
	
	^ self new
		commitish: commitish;
		repository: anIceRepository;
		yourself! !

!IceHistoryCommit commentStamp: ''!
I am a commit optimizing history access. I know a history and can determine if I'm merged asking to my history if HEAD history contains me.

All other operations are simply forwarded to my wrapped ice commit.!
!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
datetime
	
	^ iceCommit datetime! !

!IceHistoryCommit methodsFor: 'testing' stamp: ''!
canRevertChanges
	
	^ iceCommit canRevertChanges! !

!IceHistoryCommit methodsFor: 'API - changes' stamp: ''!
diffFromHead
	
	^ iceCommit diffFromHead! !

!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
history: anObject
	history := anObject! !

!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
author
	
	^ iceCommit author! !

!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
iceCommit: anIceGitCommit 
	iceCommit := anIceGitCommit! !

!IceHistoryCommit methodsFor: 'testing' stamp: ''!
isMerged
	
	^ history headHistory includes: iceCommit! !

!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
repository
	
	^ iceCommit repository! !

!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
history
	^ history! !

!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
comment
	
	^ iceCommit comment! !

!IceHistoryCommit methodsFor: 'API - changes' stamp: ''!
diffToParent
	
	^ iceCommit diffToParent! !

!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
shortId
	
	^ iceCommit shortId! !

!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
iceCommit
	^ iceCommit! !

!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
id
	
	^ iceCommit id! !

!IceHistoryCommit methodsFor: 'accessing' stamp: ''!
ancestors
	
	^ iceCommit ancestorIds! !

!IceHistoryCommit class methodsFor: 'instance creation' stamp: ''!
commit: anIceCommit history: aHistory
	
	^ self new
		iceCommit: anIceCommit;
		history: aHistory;
		yourself! !

!IceHttpsProtocol methodsFor: 'composing' stamp: ''!
composeUrlWithHost: host repositoryPath: path
	
	^ 'https://{1}/{2}.git' format: { host . path }! !

!IceHttpsProtocol class methodsFor: 'accessing' stamp: ''!
description
	
	^ 'HTTPS'! !

!IceHttpsProtocol class methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
githubRequestUrlKey
	
	^ #'clone_url'! !

!IceImageChange commentStamp: ''!
I represent a change coming from the image (in contrast to a change coming from git). I know the changed file and I can be visited to define the create a more detailed diff.!
!IceImageChange methodsFor: 'displaying' stamp: ''!
displayingProgressString
	^ 'Comparing image changes of ' , self package name! !

!IceImageChange methodsFor: 'accessing' stamp: ''!
package: anIcePackage 
	package := anIcePackage! !

!IceImageChange methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!IceImageChange methodsFor: 'building' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitImageChange: self! !

!IceImageChange class methodsFor: 'instance creation' stamp: ''!
package: anIcePackage 
	
	^ self new
		package: anIcePackage;
		yourself! !

!IceInMergeWorkingCopy commentStamp: ''!
I am a working copy whose packages are all in merge status in the same commits.!
!IceInMergeWorkingCopy methodsFor: 'testing' stamp: ''!
isInMerge
	
	^ true! !

!IceInMergeWorkingCopy methodsFor: 'display' stamp: ''!
description
	
	^ ', ' join: (self referenceCommits collect: #description)! !

!IceInMergeWorkingCopy methodsFor: 'accessing' stamp: ''!
referenceCommits
	
	^ self workingCopy referenceCommit! !

!IceInMergeWorkingCopy methodsFor: 'merging' stamp: ''!
mergeStateWith: aMergeableState
	
	^ aMergeableState mergeWithInMergeWorkingCopyState: self! !

!IceInMergeWorkingCopy methodsFor: 'testing' stamp: ''!
isDetached

	^ self referenceCommits first ~= self repository headCommit! !

!IceInMergeWorkingCopy methodsFor: 'validating' stamp: ''!
validateCanCommit
	
	self workingCopy referenceCommit first = repository head commit
		ifFalse: [ IceWorkingCopyDesyncronized signal ]! !

!IceIndex commentStamp: ''!
I represent an index of temporary stored files for later commit. I'm used internally, usually people should not use me.

My main responsibility is to store temporary changes and commit them.

However, I'm an abstract class, check my subclasses for more concrete information.!
!IceIndex methodsFor: 'testing' stamp: ''!
isEmpty
	
	self subclassResponsibility! !

!IceIndex methodsFor: 'adding' stamp: ''!
addPackage: aPackage
	
	self subclassResponsibility! !

!IceIndex methodsFor: 'updating' stamp: ''!
updateIndex: anIceDiff 

	anIceDiff tree
		accept: (IceIndexUpdateVisitor new
			index: self;
			diff: anIceDiff).! !

!IceIndex methodsFor: 'storing' stamp: ''!
storeVersion: aMCVersion 
	
	self subclassResponsibility! !

!IceIndex methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceIndex methodsFor: 'updating' stamp: ''!
updateDiskWorkingCopy: anIceDiff 
	
	self subclassResponsibility! !

!IceIndex methodsFor: 'API - commiting' stamp: ''!
commitWithMessage: message andParents: parentCommits

	self subclassResponsibility.	
! !

!IceIndex methodsFor: 'accessing' stamp: ''!
repository: anIceLibgitRepository 
	repository := anIceLibgitRepository! !

!IceIndex class methodsFor: 'instance creation' stamp: ''!
on: anIceLibgitRepository 
	
	^ self new
		repository: anIceLibgitRepository;
		yourself! !

!IceIndexUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitNonConflictingOperation: anIceNonConflictingOperation 
	
	anIceNonConflictingOperation chosenOperation accept: self! !

!IceIndexUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitDirectoryDefinition: anIceDirectoryDefinition 
	self visitChildrenOf: currentNode! !

!IceIndexUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitPackage: anIcePackageDefinition 
	
	index addPackage: anIcePackageDefinition! !

!IceIndexUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitRemoval: anIceRemoval

	"Do the same as an addition"
	self visitAddition: anIceRemoval! !

!IceIndexUpdateVisitor methodsFor: 'accessing' stamp: ''!
repository

	^ index repository! !

!IceIndexUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitAddition: anIceAddition 
	
	anIceAddition definition accept: self! !

!IceIndexUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitRootDefinition: anIceRootDefinition 
	
	self visitChildrenOf: currentNode! !

!IceIndexUpdateVisitor methodsFor: 'accessing' stamp: ''!
diff: anIceDiff 
	diff := anIceDiff! !

!IceIndexUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitModification: anIceModification 
	
	^ anIceModification leftDefinition accept: self! !

!IceIndexUpdateVisitor methodsFor: 'accessing' stamp: ''!
index: anIndex
	
	index := anIndex! !

!IceIndexUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitNoModification: anIceNoModification 
	
	anIceNoModification definition accept: self! !

!IceIndexUpdateVisitor methodsFor: 'visiting' stamp: ''!
visitFileNode: anIceFileDefinition 
	
	index addPath: anIceFileDefinition path! !

!IceInvalidProject commentStamp: ''!
I represent a project that cannot be read from the history.
I fetch most of my properties from the current project that may be a project or an unborn project.!
!IceInvalidProject methodsFor: 'testing' stamp: ''!
isInvalid
	
	^ true! !

!IceInvalidProject methodsFor: 'accessing' stamp: ''!
sourceDirectory
	
	"I'm an invalid project.
	Ask the current project as a fallback"
	^ self repository project sourceDirectory! !

!IceInvalidProjectReader commentStamp: ''!
I am a reader for invalid project commits.
I return an invalid project for those commits that are not the current checked out commit and do not have a .project file.
This is because an invalid project cannot be fixed since it is already in the history.!
!IceInvalidProjectReader methodsFor: 'accessing' stamp: ''!
priority

	"The unborn project reader should be the default one in case no other matches"
	^ 100000! !

!IceInvalidProjectReader methodsFor: 'testing' stamp: ''!
canReadProjectFromCommitish: aCommitish
	
	^ aCommitish isWorkingCopy not
		and: [ (aCommitish fileSystem / '.project') exists not ]! !

!IceInvalidProjectReader methodsFor: 'reading' stamp: ''!
readProjectFromCommitish: aCommitish

	^ IceInvalidProject onCommitish: aCommitish! !

!IceLibgitCommitWalk commentStamp: ''!
Utility class for searching through a commit history taking advantage of git revwalk utilities. Found and returned commits will be added to the commit cache of the corresponding IceRepository.!
!IceLibgitCommitWalk methodsFor: 'walk definition' stamp: ''!
fromTag: tag
	self revwalk.
	^ self fromLGitId: (lgitRepository revparse: tag name) id

! !

!IceLibgitCommitWalk methodsFor: 'walk definition' stamp: ''!
fromCommit: commit
	self fromCommitId: commit id! !

!IceLibgitCommitWalk methodsFor: 'walking' stamp: ''!
commitsDo: aBlock 
	self maxNumber 
		ifNil: [ super commitsDo: aBlock ]
		ifNotNil: [ | count |
			count := 0.
			super commitsDo: [ :commit |
				aBlock value: commit.
				count := count + 1.
				count == self maxNumber ifTrue: [ ^ self ]
			]
		]
! !

!IceLibgitCommitWalk methodsFor: 'private' stamp: ''!
shouldInclude: aLGitCommit 
	^ self modifyingPackage 
		ifNil: [ true ] 
		ifNotNil: [ :package | 
			aLGitCommit changesFileNamed: package directoryPathString ]
! !

!IceLibgitCommitWalk methodsFor: 'walk definition' stamp: ''!
fromLGitId: lGitId
	self revwalk pushCommit: lGitId! !

!IceLibgitCommitWalk methodsFor: 'private' stamp: ''!
rawResultsDo: aBlockClosure 
	self revwalk 
		select: [ :result | self shouldInclude: result ]
		thenDo: aBlockClosure! !

!IceLibgitCommitWalk methodsFor: 'accessing' stamp: ''!
revwalk

	repository handleLibgitError: [
		^ revwalk
			ifNil: [ "Keep a reference to the repo so that it does not get garbage collected 
				(that would free C memory and make leave the revwalk object dumb)"
				lgitRepository := self repositoryHandle.
				revwalk := LGitRevwalk of: self repositoryHandle.
				revwalk autoRelease.
				revwalk ]]! !

!IceLibgitCommitWalk methodsFor: 'walk definition' stamp: ''!
uptoCommit: commit
	self revwalk hideCommit: (LGitId fromHexString: commit id)! !

!IceLibgitCommitWalk methodsFor: 'accessing' stamp: ''!
repositoryHandle

	<repositoryHandleAccessor>	
	^ repository repositoryHandle! !

!IceLibgitCommitWalk methodsFor: 'walk definition' stamp: ''!
fromBranch: branch
	[ self revwalk pushReference: (lgitRepository lookupBranch: (branch isRemote ifTrue: [branch fullname] ifFalse: [ branch shortname ]) remote: branch isRemote) ]
		on: LGit_GIT_EINVALIDSPEC do: [
			"branch real branch, so try to find a corresponding treeish using revparse, 
			this will handle stuff like 'master~1'"
			self fromLGitId: (lgitRepository revparse: branch name) id
		]

! !

!IceLibgitCommitWalk methodsFor: 'walk definition' stamp: ''!
fromHead
	self revwalk pushHead! !

!IceLibgitCommitWalk methodsFor: 'walk definition' stamp: ''!
fromCommitId: commitId
	self fromLGitId: (LGitId fromHexString: commitId)! !

!IceLibgitErrorVisitor commentStamp: ''!
I transform libgit errors into Iceberg errors using a double dispatch.
In case there is no case implemented for an exception a generic error will be raised instead.

Each case in the double dispatch implements transformations for a specific kind of libgit error such as ENOTFOUND, ECONFLICT and so on. However, each libgit error can be mapped to several high-level Iceberg exceptions. It is the responsibility of this error visitor to do the matching of the different information provided by a libgit error (error code, description, message text) and decide which exception to use.

I also have a context, which points to the object that is requesting the exception transformation.
This context is used to obtain more information about the operation that failed, usually not provided by Libgit, such as urls, locations, etc.!
!IceLibgitErrorVisitor methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!IceLibgitErrorVisitor methodsFor: 'visiting' stamp: ''!
visitEEOF: aLGit_GIT_EEOF

	aLGit_GIT_EEOF messageText trimmed = 'ERROR: Repository not found.'
		ifTrue: [ IceCloneRemoteNotFound signalFor: context url ].
	
	^ self visitGenericError: aLGit_GIT_EEOF! !

!IceLibgitErrorVisitor methodsFor: 'visiting' stamp: ''!
visitENOTFOUND: anError

	NotFound signal: anError messageText! !

!IceLibgitErrorVisitor methodsFor: 'visiting' stamp: ''!
visitGenericError: anError

	IceGenericError new
		messageText: anError messageText;
		wrappedException: anError;
		signal! !

!IceLibgitErrorVisitor methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!IceLibgitErrorVisitor methodsFor: 'visiting' stamp: ''!
visitECONFLICT: anError
	anError object =  LGitErrorTypeEnum giterr_checkout
		ifTrue: [ ^ anError resignalAs: IceCheckoutConflictError new ].
	self visitGenericError: anError! !

!IceLibgitErrorVisitor methodsFor: 'visiting' stamp: ''!
visitERROR: anError

	(anError object = LGitErrorTypeEnum giterr_ssh)
		ifTrue: [ anError resignalAs: IceAuthenticationError new ].
	"user errors needs to be handled differently, since they do not have an 
	 actual code. This is a HACK, but it will fix #577"
	(anError object value = LGitReturnCodeEnum git_euser value)
		ifTrue: [ self visitEUSER: anError  ].

	"Error in libgit in non-windows"
	anError messageText trimmed asLowercase = 'Unexpected HTTP status code: 404' asLowercase
		ifTrue: [ IceCloneRemoteNotFound signalFor: context url ].

	"Error in libgit in windows"
	anError messageText trimmed = 'request failed with status code: 404'
		ifTrue: [ IceCloneRemoteNotFound signalFor: context url ].

	self visitGenericError: anError! !

!IceLibgitErrorVisitor methodsFor: 'visiting' stamp: ''!
visitEEXISTS: anError

	(anError messageText asLowercase beginsWith: 'failed to write reference ''refs/tags')
		ifTrue: [ | refName messageStream|
			messageStream := anError messageText readStream.
			refName := messageStream
				upTo: $/;
				upTo: $/;
				upTo: $'.
			IceTagAlreadyExists new
				tagName: refName;
				signal ].
	self visitGenericError: anError! !

!IceLibgitErrorVisitor methodsFor: 'visiting' stamp: ''!
visitEUSER: anError
	"Since user errors do not have a code, they can can just be handled by analysis 
	 of messageText. String comparisson is not the thing in history, but for not it will 
	 fit. :("
	anError messageText = 'No ssh-agent suitable credentials found.'
		ifTrue: [ anError resignalAs: IceAuthenticationError new ].
	anError messageText asLowercase = 'Invalid username and/or password provided.' asLowercase
		ifTrue: [ anError resignalAs: IceAuthenticationError new ].
	self visitGenericError: anError! !

!IceLibgitErrorVisitor class methodsFor: 'instance creation' stamp: ''!
onContext: aContext

	^ self new
		context: aContext;
		yourself! !

!IceLibgitFiletreeFileUtils commentStamp: ''!
Emulates other 'file utils' classes by reading from a git repository (its blob, not a working copy'). Allows for reading any tree (from any commit) in the repository.!
!IceLibgitFiletreeFileUtils class methodsFor: 'utilities' stamp: ''!
directoryFromPath: aString relativeTo: aCommitOrTree
	^ aCommitOrTree 
		entryByPath: aString 
		ifAbsent: [ 
			IceMissingRepositoryEntry new name: aString; owner: aCommitOrTree; signal ]
! !

!IceLibgitFiletreeFileUtils class methodsFor: 'utilities' stamp: ''!
readStreamFor: fileName in: tree do: aBlock
	(tree entryByPath: fileName) readStreamDo: aBlock! !

!IceLibgitFiletreeFileUtils class methodsFor: 'accessing' stamp: ''!
pathNameDelimiter
	^ $/! !

!IceLibgitFiletreeFileUtils class methodsFor: 'utilities' stamp: ''!
directoryFromEntry: treeEntry 
	^ treeEntry object! !

!IceLibgitFiletreeFileUtils class methodsFor: 'utilities' stamp: ''!
directoryExists: aLGitTreeEntry 
	^ aLGitTreeEntry type = LGitObjectTypeEnum git_obj_tree! !

!IceLibgitFiletreeFileUtils class methodsFor: 'utilities' stamp: ''!
fileName: anEntry
    ^ anEntry filename! !

!IceLibgitFiletreeFileUtils class methodsFor: 'utilities' stamp: ''!
writeStreamFor: fileName in: directory do: aBlock 
	directory addEntryNamed: fileName withContents: (String streamContents: aBlock).! !

!IceLibgitFiletreeFileUtils class methodsFor: 'utilities' stamp: ''!
deleteAll: aTreeBuilder 
    ^ aTreeBuilder deleteAll! !

!IceLibgitFiletreeFileUtils class methodsFor: 'utilities' stamp: ''!
directoryName: anEntry
    ^ anEntry filename! !

!IceLibgitFiletreeLog commentStamp: ''!
I'm a tool to ask the full history of a method (based on filetree file format).!
!IceLibgitFiletreeLog methodsFor: 'private' stamp: ''!
cypressClassOrTraitName: aMethod
	^ aMethod origin instanceSide name, (self cypressMethodClassExtension: aMethod)
	! !

!IceLibgitFiletreeLog methodsFor: 'private' stamp: ''!
definitionFor: aMethod path: aPath commit: aCommit
	^ ((IceLibgitFiletreeLogReader fileName: aPath on: aCommit)
		package: aMethod package mcPackage; 
		packageDirectory: (self repository directoryPathStringForPackage: aMethod package);
		definitions)
		detect: [ :each | each isMethodDefinition and: [ each selector = aMethod selector  ] ]
		ifNone: [ 
			 "not found, return 'NULL' object: compare will fail anyway"
			MCMethodDefinition 
				className: aMethod origin name
				selector: aMethod selector
				category: #''
				timeStamp: nil
				source: '' ]! !

!IceLibgitFiletreeLog methodsFor: 'private' stamp: ''!
basepathOf: aPath
	^ aPath! !

!IceLibgitFiletreeLog methodsFor: 'private' stamp: ''!
cypressMethodSideName: aMethod 
	^ aMethod origin isClassSide
		ifTrue: [ 'class' ]
		ifFalse: [ 'instance' ]! !

!IceLibgitFiletreeLog methodsFor: 'private' stamp: ''!
toFileName: aMethod
	^ self fileNameForMethod: aMethod! !

!IceLibgitFiletreeLog methodsFor: 'private' stamp: ''!
cypressMethodName: aMethod
	^ (MCFileTreeStCypressWriter fileNameForSelector: aMethod selector asString), '.st'! !

!IceLibgitFiletreeLog methodsFor: 'private' stamp: ''!
cypressMethodClassExtension: aMethod 
	aMethod isExtension ifTrue: [ ^ '.extension' ].
	aMethod origin isTrait ifTrue: [ ^ '.trait' ].
	^ '.class'! !

!IceLibgitFiletreeLog methodsFor: 'private' stamp: ''!
cypressPackageName: aPackage 
	^ aPackage name, '.package'! !

!IceLibgitFiletreeLog methodsFor: 'private' stamp: ''!
fileNameForMethod: aMethod
	| path |
	
	path := OrderedCollection new.
	self repository subdirectory 
		ifNotEmpty: [ :subDir | path add: subDir ].
	path 
		add: (self cypressPackageName: aMethod package);
		add: (self cypressClassOrTraitName: aMethod);
		add: (self cypressMethodSideName: aMethod);
		add: (self cypressMethodName: aMethod).
	
	^ String streamContents: [ :stream |
		path asStringOn: stream delimiter: '/' ]! !

!IceLibgitFiletreeLog class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	^ aRepository writerClass id = #filetree! !

!IceLibgitFiletreeLogReader commentStamp: ''!
I read exclusively the definition of the method defined in fileName.
I'm using to speed the creation of a version list on IceLibgitFiletreeLog.!
!IceLibgitFiletreeLogReader methodsFor: 'accessing' stamp: ''!
fileName
	^ fileName! !

!IceLibgitFiletreeLogReader methodsFor: 'accessing' stamp: ''!
fileName: aString
	fileName := aString! !

!IceLibgitFiletreeLogReader methodsFor: 'utilities' stamp: ''!
loadDefinitions
 	| entry segments className classIsMeta entryPath packageIndex |	
	
	definitions := OrderedCollection new.
	
	segments := (self fileName substrings: '/') allButLast asOrderedCollection.
	classIsMeta := segments removeLast = 'class'.
	className := segments last copyUpToLast: $..
	"entryPath is the relative path from the package to the method being loaded"
	packageIndex := segments indexOf: packageDirectory filename.
	entryPath := packageIndex > 0 ifTrue: 
		[ entryPath := $/ join: (segments copyFrom: 1 to: packageIndex).
		self fileName allButFirst: entryPath size ]
	ifFalse:
		[ self fileName allButFirst: packageDirectory filename size ].
	entry := (packageDirectory 
		entryByPath: entryPath
		ifAbsent: [ ^ nil ]).
	entry readStreamDo: [ :fileStream |
		| category source timestamp selector |

		category := fileStream nextLine.
		source := fileStream upToEnd.
 		selector := self methodSelectorFor: source.
 		timestamp := stream author name, ' ' , stream time asDateAndTime asStringYMDHM.
		definitions add: (MCMethodDefinition
			className: className
			classIsMeta: classIsMeta
			selector: selector
			category: category
			timeStamp: timestamp
			source: source) ]! !

!IceLibgitFiletreeLogReader methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!IceLibgitFiletreeLogReader methodsFor: 'accessing' stamp: ''!
package: aPackage
	package := aPackage! !

!IceLibgitFiletreeLogReader class methodsFor: 'instance creation' stamp: ''!
fileName: aString on: aCommit
	^ (self on: aCommit)
		fileName: aString;
		yourself! !

!IceLibgitFiletreeReader commentStamp: ''!
Reads an MCVersion from a git repository (its blob, not a working copy!!) using libgit bindings.

Currently we only support metadata-less repositories.!
!IceLibgitFiletreeReader methodsFor: 'accessing' stamp: ''!
versionName
	^ ('{1}-{2}.{3}' format: {
		self packageNameFromPackageDirectory. 
		self commit compatibleUsername. 
		self versionNumber
	})! !

!IceLibgitFiletreeReader methodsFor: 'accessing' stamp: ''!
iceVersion
	^ iceVersion! !

!IceLibgitFiletreeReader methodsFor: 'accessing' stamp: ''!
packageNameFromPackageDirectory
	^ iceVersion packageName! !

!IceLibgitFiletreeReader methodsFor: 'testing' stamp: ''!
hasMonticelloMetadata
	^ false! !

!IceLibgitFiletreeReader methodsFor: 'accessing' stamp: ''!
commit
	^ stream! !

!IceLibgitFiletreeReader methodsFor: 'accessing' stamp: ''!
iceVersion: anObject
	iceVersion := anObject.
	self packageDirectory: (iceVersion commit project sourceDirectoryPath / (IceLibgitFiletreeWriter directoryNameFor: (IcePackage named: iceVersion package name repository: iceVersion commit repository))) pathString! !

!IceLibgitFiletreeReader methodsFor: 'accessing' stamp: ''!
loadVersionInfo
	^ info := self iceVersion info! !

!IceLibgitFiletreeReader methodsFor: 'accessing' stamp: ''!
fileUtils
	^ IceLibgitFiletreeFileUtils! !

!IceLibgitFiletreeReader class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!IceLibgitFiletreeReader class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!IceLibgitFiletreeReader class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!IceLibgitFiletreeReader class methodsFor: 'testing' stamp: ''!
isLegacyDefault
	^ true! !

!IceLibgitFiletreeReader class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!IceLibgitFiletreeReader class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!IceLibgitFiletreeReader class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!IceLibgitFiletreeReader class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!IceLibgitFiletreeReader class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!IceLibgitFiletreeReader class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceLibgitFiletreeReader class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!IceLibgitFiletreeReader class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!IceLibgitFiletreeReader class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!IceLibgitFiletreeReader class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!IceLibgitFiletreeReader class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!IceLibgitFiletreeReader class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!IceLibgitFiletreeReader class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!IceLibgitFiletreeReader class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!IceLibgitFiletreeReader class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceLibgitFiletreeReader class methodsFor: 'accessing' stamp: ''!
compatibleAuthorNameOf: aString
	"Timestamp of method has a very precise format that needs to be fulfiled: 
		
		'FirstnameLastname MM/DD/YYYY HH/MM' 
	
	Problem is that git username is different: Firstname Lastname.
	To make this compatible, we remove spaces... but this can be a problem in the future... 
	we'll see."
	^ aString reject: [ :each | each = Character space ]! !

!IceLibgitFiletreeReader class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!IceLibgitFiletreeReader class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!IceLibgitFiletreeReader class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!IceLibgitFiletreeReader class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!IceLibgitFiletreeReader class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!IceLibgitFiletreeReader class methodsFor: 'testing' stamp: ''!
id
	^ #filetree! !

!IceLibgitFiletreeReader class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!IceLibgitFiletreeReader class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!IceLibgitFiletreeReader class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!IceLibgitFiletreeReader class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!IceLibgitFiletreeReader class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!IceLibgitFiletreeReader class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!IceLibgitFiletreeReader class methodsFor: 'instance creation' stamp: ''!
on: aCommitOrTree iceVersion: iceVersion
	^ (self on: aCommitOrTree) 
		iceVersion: iceVersion; 
		yourself! !

!IceLibgitFiletreeSnapshotWriter commentStamp: ''!
I'm a filetree snapshot writer to ensure the output will be libgit2 compatible.
I'm not surre I cannot unify myself class with my parent.!
!IceLibgitFiletreeSnapshotWriter methodsFor: 'initialize-release' stamp: ''!
propertyFileExtension
  ^ MCFileTreeRepository defaultPropertyFileExtension! !

!IceLibgitFiletreeSnapshotWriter methodsFor: 'accessing' stamp: ''!
fileUtils
	^ IceLibgitFiletreeFileUtils! !

!IceLibgitFiletreeSnapshotWriter methodsFor: 'visiting' stamp: ''!
writeInDirectoryName: directoryNameOrPath fileName: fileName extension: ext visit: visitBlock
    | directory |
    directory := self directoryForDirectoryNamed: directoryNameOrPath.
    self fileUtils
        writeStreamFor: fileName , ext
        in: directory
        do: [ :fs | 
            self setFileStream: fs.
            visitBlock value ]! !

!IceLibgitFiletreeWriter commentStamp: ''!
I'm a filetree writer to ensure the output will be libgit2 compatible.
I'm not surre I cannot unify myself class with my parent.!
!IceLibgitFiletreeWriter methodsFor: 'accessing' stamp: ''!
snapshotWriterClass
	^ IceLibgitFiletreeSnapshotWriter! !

!IceLibgitFiletreeWriter methodsFor: 'visiting' stamp: ''!
writeVersion: aVersion
	directory := aVersion package name, '.package'.
	packageFileDirectory := stream / directory.

	self packageFileDirectory ensureDeleteAll.
	self writeFormat.
	self writePackage: aVersion package.
	self writeDefinitions: aVersion.
	aVersion dependencies do: [ :ea | self writeVersionDependency: ea ]! !

!IceLibgitFiletreeWriter methodsFor: 'writing' stamp: ''!
addString: string at: fileNameOrPath encodedTo: ignored
    "fileNameOrPath may have one or two elements"
    "encodeTo: arg, because FileTree uses UTF8 by default"

	| split path fileName |
	split := fileNameOrPath lastIndexOf: $/.
	path := fileNameOrPath first: split.
	fileName := fileNameOrPath copyFrom: split + 1.
	
	(self packageFileDirectory entryByPath: path)
		addEntryNamed: fileName withContents: string.
! !

!IceLibgitFiletreeWriter methodsFor: 'accessing' stamp: ''!
fileUtils
	^ IceLibgitFiletreeFileUtils! !

!IceLibgitFiletreeWriter methodsFor: 'visiting' stamp: ''!
subPackageFileDirectoryFor: directoryNameOrPath
	^ self packageFileDirectory entryByPath: directoryNameOrPath ! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
packageNameFromDirectory: aFileReference
	^ aFileReference basenameWithoutExtension! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
isValidPackage: aFileReference
	^ (aFileReference basename endsWith: '.package') 
		and: [ aFileReference isDirectory 
			and: [(aFileReference / 'monticello.meta') exists]]! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
isLegacyDefault
	^ true! !

!IceLibgitFiletreeWriter class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
description
	^ 'Filetree'! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
isDefault
	"Indicates when this is default when create new repositories"
	^ false! !

!IceLibgitFiletreeWriter class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!IceLibgitFiletreeWriter class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceLibgitFiletreeWriter class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
directoryNameFor: aPackage
	^ aPackage name, '.package'! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!IceLibgitFiletreeWriter class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!IceLibgitFiletreeWriter class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
forInternalStore
	^ IceMetadatalessFileTreeWriter! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!IceLibgitFiletreeWriter class methodsFor: 'writing' stamp: ''!
forInternalStoreFileOut: aMCVersion on: aRepository
	self forInternalStore 
		fileOut: aMCVersion
		on: (IceBackendWriterAdapter for: aRepository)! !

!IceLibgitFiletreeWriter class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!IceLibgitFiletreeWriter class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
id
	^ #filetree! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!IceLibgitFiletreeWriter class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!IceLibgitFiletreeWriter class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!IceLibgitFiletreeWriter class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!IceLibgitRepository commentStamp: ''!
I am an iceberg repository that uses libgit as backend.
I have a handle to a LGitRepository that is lazily initialized on usage, and cleaned up on every shutdown (automatically done by uFFI).

Every access to the libgit repository should be wrapped with a call to #handleLibgitError: to manage possible libgit errors and transform them to a correct iceberg error.!
!IceLibgitRepository methodsFor: 'testing' stamp: ''!
isCodeMissing
	^ self subdirectory isEmptyOrNil 
		ifTrue: [ self isMissing ]
		ifFalse: [ (self repositoryDirectory / self subdirectory) exists not  ]! !

!IceLibgitRepository methodsFor: 'API - branches' stamp: ''!
localBranches

	self handleLibgitError: [ 
		self repositoryHandle isUnborn
			ifTrue: [ ^ {self head} ].
		^ OrderedCollection
			new: 10
			streamContents: [ :stream | self repositoryHandle localBranchesDo: [ :br :isLocal | stream nextPut: (self basicNewBranchNamed: br name) ] ] ]! !

!IceLibgitRepository methodsFor: 'to-cleanup' stamp: ''!
addTo: aMCRepositoryGroup 
	"For now do not add me as an MCRepository"! !

!IceLibgitRepository methodsFor: 'API - configuration' stamp: ''!
getConfigurationGlobal: aBoolean

	self handleLibgitError: [ | config |
		config := self repositoryHandle config.
		^ aBoolean
			ifTrue: [ config openGlobal ]
			ifFalse: [ config ] ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
locationIfPresent: aBlock ifAbsent: absentBlock

	self location ifNil: [ ^ absentBlock value ].

	^ self location exists
		ifTrue: [ aBlock value: location ]
		ifFalse: [ absentBlock value ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
mergeBaseBetween: aCommitId and: anotherCommitId
	
	self handleLibgitError: [ ^ (self repositoryHandle
			mergeBaseBetween: (LGitId fromHexString: aCommitId)
			and: (LGitId fromHexString: anotherCommitId)) hexString ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
location
	^ location! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
commitIdFrom: aLGitCommit 
	^ aLGitCommit id hexString! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
logClass
	^ IceLog allSubclasses 
		detect: [ :each | each isAvailableFor: self ]! !

!IceLibgitRepository methodsFor: 'private - libgit' stamp: ''!
resetHandle
	handle := nil! !

!IceLibgitRepository methodsFor: 'API - remotes' stamp: ''!
remotes
	
	self handleLibgitError: [ | gitRemotes |
		self isValid ifFalse: [ ^ #() ].
		gitRemotes := self repositoryHandle allRemotes.
		^ gitRemotes
			collect: [ :each | 
				(IceGitRemote name: each remoteName url: each url)
					localRepository: self;
					yourself ] ]! !

!IceLibgitRepository methodsFor: 'printing' stamp: ''!
description
	^ [ super description ] on: Error do: [ 
		self location isNil
			ifTrue: [ 'Not specified location' ]
			ifFalse: [ 'Bad location: ', self location path pathString ] ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
subdirectoryReference
	
	^ self location resolve: self subdirectoryPath! !

!IceLibgitRepository methodsFor: 'API - files' stamp: ''!
addFilesToIndex: aCollection

	self handleLibgitError: [
		| gitIndex |
		gitIndex := self repositoryHandle index.
		gitIndex
			addAll:
				(aCollection
					collect: [ :each | 
						self assert: each asFileReference isRelative.
						"self assert: (self location resolve: each) exists."
						each asFileReference path pathString ]
					as: Array).
		gitIndex
			writeToDisk;
			free ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
commitishNamed: aName
	"Resolve a name in the form of:
	  - a commit hash
	  - a branch name
	  - some other expression such as HEAD or master~1
	and return the corresponding iceberg object for it."

	^ self
		branchNamed: aName
		ifAbsent: [ "If there is a single remote, we can look for the branch in this single remote."
			self remotes size = 1
				ifTrue: [ self remotes anyOne
						remoteBranchNamed: aName
						ifPresent: [ :found | ^ found ]
						ifAbsent: [ "Continue with the revparse" ] ].
			self revparse: aName ]! !

!IceLibgitRepository methodsFor: 'private - commits' stamp: ''!
commitCache
	
	^ commitCache ifNil: [ commitCache := LRUCache new maximumWeight: 30  ]! !

!IceLibgitRepository methodsFor: 'API - branches' stamp: ''!
basicNewBranchNamed: aString 

	^ IceGitLocalBranch named: aString inRepository: self! !

!IceLibgitRepository methodsFor: 'API - project' stamp: ''!
newProjectFromCommit: aCommit

	^ IceProjectReader readProjectFrom: self! !

!IceLibgitRepository methodsFor: 'API - tags' stamp: ''!
hasTagNamed: aString 
	
	^ self tagNames includes: aString! !

!IceLibgitRepository methodsFor: 'private - changes' stamp: ''!
newIndex
	
	^ IceGitIndex on: self! !

!IceLibgitRepository methodsFor: 'API - remotes' stamp: ''!
remoteTrackedBranches
	
	self handleLibgitError: [
		^ OrderedCollection
			new: 10
			streamContents: [ :stream | 
				self repositoryHandle
					remoteBranchesDo: [ :br :isLocal | 
						self assert: isLocal not.
						stream nextPut: (self basicNewRemoteBranchNamed: br name) ] ] ]! !

!IceLibgitRepository methodsFor: 'private - commits' stamp: ''!
commitFromGitCommit: aLGitCommit 
	
	^ self commitCache at: aLGitCommit id hexString ifAbsentPut: [
		
		IceGitCommit new
			id: aLGitCommit id hexString;
			author: aLGitCommit author name;
			datetime: aLGitCommit time asDateAndTime;
			ancestorIds: (aLGitCommit parents collect: [ :parent | parent id hexString ]);
			comment: aLGitCommit message;
			repository: self;
			yourself ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
repositoryDirectory
	^ self location! !

!IceLibgitRepository methodsFor: 'private - libgit' stamp: ''!
repositoryHandle

	<repositoryHandleAccessor>
	(handle isNil or: [ handle isNull ])
		ifTrue: [ handle := (LGitRepository on: self location) open ].
	^ handle! !

!IceLibgitRepository methodsFor: 'testing' stamp: ''!
isMissing
	^ self repositoryDirectory isNil 
		or: [ self repositoryDirectory exists not ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
setHead: anIceGitCommitish
	
	"Need to keep the reference, if not it is garbage collected. As the options are only passed to a FFI call"
	| progress |
	progress := IceGitCheckoutProgress new.
	
	self handleLibgitError: [ 
		self repositoryHandle
			checkout: anIceGitCommitish gitRef
			options:
				(LGitCheckoutOptions defaults
					checkoutStrategy: LGitCheckoutStrategyEnum git_checkout_force;
					progressCallback: progress;
					yourself) ]! !

!IceLibgitRepository methodsFor: 'API - branches' stamp: ''!
createBranch: aString inCommit: anIceGitCommit

	self handleLibgitError: [
		(self repositoryHandle isUnborn and: [ anIceGitCommit isNoCommit ])
			ifTrue: [ ^ self createBranch: aString ].
		self repositoryHandle createBranch: aString targetId: (LGitId fromHexString: anIceGitCommit gitRef) force: false.
		^ (self branchNamed: aString)
			switch;
			yourself ]! !

!IceLibgitRepository methodsFor: 'API - commits' stamp: ''!
revparse: aName

	self handleLibgitError: [ | gitCommit gitId |
		gitId := (self repositoryHandle revparse: aName) object id.
		gitCommit := LGitCommit of: self repositoryHandle fromId: gitId.
		^ self commitFromGitCommit: gitCommit ]! !

!IceLibgitRepository methodsFor: 'API - files' stamp: ''!
addFileToIndex: aFile
	
	self addFilesToIndex: { aFile }! !

!IceLibgitRepository methodsFor: 'API - branches' stamp: ''!
createBranch: branchName
	| newBranch |
	"This is really low level and may provoke problems.
	Libgit does not provide an API to change branch when the repository is unborn.
	Instead, we replace the HEAD file adding a reference with the new branch.
			
	This may break other existing refs in the repository."
	self handleLibgitError: [ [ self repositoryHandle isUnborn
				ifTrue: [ (self location / '.git' / 'HEAD')
						ensureDelete;
						writeStreamDo: [ :stream | 
							stream
								nextPutAll: 'ref: refs/heads/';
								nextPutAll: branchName ] ]
				ifFalse: [ newBranch := self repositoryHandle createBranch: branchName target: self repositoryHandle head.
					self repositoryHandle setHead: newBranch ] ]
				on: LGit_GIT_EEXISTS
				do: [ :error | 
					IceBranchAlreadyExists new
						branchName: branchName;
						signal ].
			^ self head ]! !

!IceLibgitRepository methodsFor: 'API - registry' stamp: ''!
delete
	"Delete is idempotent. If the repository does not exist, do nothing.
	Otherwise, forget the repository and remove it from the disk.
	Cleanup also the FFI handles."
	
	super delete.
	
	handle := nil.
	self locationIfPresent: [ :aLocation | aLocation ensureDeleteAll ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
subdirectoryPath
	
	"API compatible both with Pharo6 and Pharo7.
	This could be replaced by the Pharo7 API
	
	RelativePath with: self subdirectory
	"
	^ RelativePath withAll: (RelativePath canonicalizeElements: ($/ split: self subdirectory))! !

!IceLibgitRepository methodsFor: 'API - working copy' stamp: ''!
createSourceDirectory
	(location / self subdirectory) ensureCreateDirectory.
	
	self properties
		fileFormat: self class defaultFileFormat;
		store	! !

!IceLibgitRepository methodsFor: 'API - packages' stamp: ''!
isModified
	"We cannot correctly determine if a repository is modified if it is missing so, false"
	
	^ self isMissing not and: [ super isModified ]! !

!IceLibgitRepository methodsFor: 'API - commits' stamp: ''!
lookupCommit: commitId ifAbsent: aBlock
	^ [ self revparse: commitId ]
		on: NotFound
		do: aBlock! !

!IceLibgitRepository methodsFor: 'API - remotes' stamp: ''!
remoteNamed: aName ifAbsent: aBlockClosure
	
	self handleLibgitError: [ | gitRemote |
	[ gitRemote := (LGitRemote of: self repositoryHandle named: aName) lookup.
	^ (IceGitRemote name: gitRemote remoteName url: gitRemote url)
		localRepository: self;
		yourself ]
		on: LGitObjectNotInitialized
		do: [ ^ aBlockClosure value ] ]! !

!IceLibgitRepository methodsFor: 'private - initialization' stamp: ''!
init
	"Initialize new repository. This is the equivalent to running in the command line:
	  $ git init
	"

	self initBare: false! !

!IceLibgitRepository methodsFor: 'API - properties' stamp: ''!
readerClass
	^ self properties readerClass! !

!IceLibgitRepository methodsFor: 'API - branches' stamp: ''!
basicNewRemoteBranchNamed: aString 

	^ IceGitRemoteBranch named: aString inRepository: self! !

!IceLibgitRepository methodsFor: 'initialization' stamp: ''!
initBare: isBare
	(LGitRepository on: self location) initBare: isBare! !

!IceLibgitRepository methodsFor: 'private - libgit' stamp: ''!
free

	(handle isNil or: [ handle isNull ])
		ifFalse: [ 
			handle free.
			handle := nil ]! !

!IceLibgitRepository methodsFor: 'API - packages' stamp: ''!
directoryNameForPackage: package

	^ (self writerClass 
		directoryNameFor: package)
		asString! !

!IceLibgitRepository methodsFor: 'API - packages' stamp: ''!
directoryForPackage: mcPackage
	| package |
	package := self packageNamed: mcPackage name.
	^ self subdirectory isEmptyOrNil
		ifTrue: [ self directoryNameForPackage: package ]
		ifFalse: [ self subdirectory, '/', (self directoryNameForPackage: package) ]! !

!IceLibgitRepository methodsFor: 'API - branches' stamp: ''!
branchNamed: aString ifPresent: presentBlock ifAbsent: absentBlock

	self handleLibgitError: [ | found |
		found := self repositoryHandle lookupLocalBranch: aString ifAbsent: [ nil ].
		^ found ifNil: absentBlock ifNotNil: [ presentBlock value: (self basicNewBranchNamed: found name) ] ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
log
	^ self logClass for: self! !

!IceLibgitRepository methodsFor: 'API - commits' stamp: ''!
newNoCommit
	
	^ IceNoCommit repository: self! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
location: aFileReference
	location := aFileReference.
	self resetHandle! !

!IceLibgitRepository methodsFor: 'API - remotes' stamp: ''!
origin
	
	^ self
		remoteNamed: 'origin'
		ifAbsent: [
			IceUndefinedRemote new
				name: 'origin';
				yourself ]! !

!IceLibgitRepository methodsFor: 'API - remotes' stamp: ''!
remoteBranchNamed: aString ifPresent: presentBlock ifAbsent: absentBlock
	
	self handleLibgitError: [ | branchRef |
		branchRef := self repositoryHandle lookupRemoteBranch: aString ifAbsent: [ ^ absentBlock value ].
		presentBlock value: (self basicNewRemoteBranchNamed: branchRef name) ]! !

!IceLibgitRepository methodsFor: 'private - commits' stamp: ''!
internalStoreVersion: aMCVersion
	self writerClass
		forInternalStoreFileOut: aMCVersion 
		on: self! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
basicCodeDirectory
	^ self subdirectory isEmptyOrNil 
		ifTrue: [ self repositoryDirectory ]
		ifFalse: [ self repositoryDirectory / self subdirectory  ].! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
subdirectory: aString 
	
	self project sourceDirectory: aString! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
head
	
	^ self lookupHead! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
codeDirectory
	"Code repository might have been deleted or image might have been moved."
	self repositoryDirectory exists
		ifTrue: [ ^ self basicCodeDirectory ]
		ifFalse: [ IceLocalRepositoryMissing signalFor: self ]! !

!IceLibgitRepository methodsFor: 'testing' stamp: ''!
isCloneOfUrl: aString

	^ self isMissing not and: [ super isCloneOfUrl: aString ]! !

!IceLibgitRepository methodsFor: 'private - monticello' stamp: ''!
mcVersionFor: iceVersion
	[ | commit |
		commit := iceVersion commit libgitCommit.
		^ (iceVersion commit readerClass on: commit iceVersion: iceVersion) version ]
	on: IceMissingRepositoryEntry, LGit_GIT_ENOTFOUND
	do: [ 
		IceVersionDoesNotExist new
			version: iceVersion;
			signal ]! !

!IceLibgitRepository methodsFor: 'API - packages' stamp: ''!
directoryPathStringForPackage: aMCPackage 

	^ self subdirectory isEmptyOrNil 
		ifTrue: [ self directoryNameForPackage: aMCPackage ]
		ifFalse: [ self subdirectory, '/',  (self directoryNameForPackage: aMCPackage) ]! !

!IceLibgitRepository methodsFor: 'API - packages' stamp: ''!
packageLocationFor: anIceSavedPackage
	| packageLocation directoryName |
	 
	packageLocation := self location.
	self subdirectory ifNotEmpty: [ 
		packageLocation := packageLocation / self subdirectory ].
	directoryName := self writerClass directoryNameFor: anIceSavedPackage.
	packageLocation := packageLocation / directoryName.
	^ packageLocation! !

!IceLibgitRepository methodsFor: 'API - tags' stamp: ''!
removeTag: anIceTag 
	
	self handleLibgitError: [
		self repositoryHandle git_tag_delete: anIceTag name ]! !

!IceLibgitRepository methodsFor: 'private - libgit' stamp: ''!
handleLibgitError: aBlock
	"Handle errors while calling libgit.
	The pragma is used to detect this method and verify on architectural rules that it is correctly called"
	<libgitErrorHandler>
	
	aBlock on: LGitCallReturnHandler do: [ :error | error acceptError: (IceLibgitErrorVisitor onContext: self) ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
iceCommitFrom: aGitCommit
	"The type of 'aCommitish' depends on how each backend internal representation. "

	^ self commitFromGitCommit: aGitCommit! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
subdirectory
	^ self project sourceDirectory! !

!IceLibgitRepository methodsFor: 'printing' stamp: ''!
headDescription
	
	^ [ super headDescription ] on: Error do: [ 'Bad location' ]! !

!IceLibgitRepository methodsFor: 'API - branches' stamp: ''!
allBranches
	
	^ self localBranches, self remoteTrackedBranches! !

!IceLibgitRepository methodsFor: 'private - tags' stamp: ''!
peelTag: anIceTag 
	self handleLibgitError: [ | lgitRef |
		lgitRef := (self repositoryHandle lookup: 'refs/tags/', anIceTag name).
		^ self lookupCommit: lgitRef targetId hexString ]! !

!IceLibgitRepository methodsFor: 'API - packages' stamp: ''!
isPackageExported: anIceSavedPackage

	| packageLocation |
	packageLocation := self packageLocationFor: anIceSavedPackage.
	^ packageLocation exists and: [ packageLocation hasChildren ]! !

!IceLibgitRepository methodsFor: 'API - registry' stamp: ''!
checkForRegistryConflicts
	
	"If the repository has no location, do not check for conflicts."
	self location ifNil: [ ^ self ].
	
	self class registry 
		detect: [ :repo | repo location = self location ]
		ifFound: [ :repo | self origin = repo origin
			ifTrue: [ 
				IceDuplicatedRepository signal: 
					('You already have an Iceberg repository 
at {1} 
and with the same origin URL. 

If you really whant create another one, 
please locate it in a different directory.'
					 format: {self location pathString}) ]
			ifFalse: [
				IceDuplicatedRepository signal: 
					('You already have an Iceberg repository at 
{1} 
but with a different origin URL.

You provided {2} 
and the original repository''s url is {3}.'
					 format: {self location. self origin. repo origin}) ]].! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
locationIfPresent: aBlock

	^ self locationIfPresent: aBlock ifAbsent: [ self ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
lookupHead
	self handleLibgitError: [ | head |
		self repositoryHandle isUnborn
			ifTrue: [ ^ IceGitUnbornBranch inRepository: self ].
		head := self repositoryHandle head.
		^ head isBranch
			ifTrue: [ self basicNewBranchNamed: head name ]
			ifFalse: [ head object asIcebergObjectInRepository: self ] ]! !

!IceLibgitRepository methodsFor: 'private - changes' stamp: ''!
changedFilesBetween: aCommitish and: otherCommitish
	"Answer a list of files that changed between two commits"

	self handleLibgitError: [ | fromTree toTree diff |
		fromTree := (LGitCommit of: self repositoryHandle fromHexString: aCommitish id) tree.
		toTree := (LGitCommit of: self repositoryHandle fromHexString: otherCommitish id) tree.
		diff := fromTree diffTo: toTree.
		^ diff files ]! !

!IceLibgitRepository methodsFor: 'API - project' stamp: ''!
project
	
	^ self workingCopy project! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
properties
	^ self workingCopy repositoryProperties! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
name

	^ name ifNil: [ name := self obtainRepositoryName ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
obtainRepositoryName
	
	^ self location basename! !

!IceLibgitRepository methodsFor: 'testing' stamp: ''!
isValid
	self flag: #pharoTodo. "Make this tests more solid"
	^ self isMissing not! !

!IceLibgitRepository methodsFor: 'private - remotes' stamp: ''!
doRemoveRemote: aRemote
	self handleLibgitError: [
		(LGitRemote of: self repositoryHandle named: aRemote name)
			lookup;
			delete ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
newCommitWalk
	^ IceLibgitCommitWalk forRepository: self! !

!IceLibgitRepository methodsFor: 'API - tags' stamp: ''!
tags
	self handleLibgitError: [ 
		^ self repositoryHandle tags
			collect: [ :each | 
				IceTag named: each inRepository: self ] ]! !

!IceLibgitRepository methodsFor: 'API - accessing' stamp: ''!
writerClass
	^ self project writerClass! !

!IceLibgitRepository methodsFor: 'API - remotes' stamp: ''!
remoteAt: aString put: aRemote

	self handleLibgitError: [ self repositoryHandle addRemote: aRemote name url: aRemote url ]! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
defaultFileFormatType
	^ DefaultFileFormatType ifNil: [ 
		DefaultFileFormatType := TIceRepositoryWriter traitUsers 
			detect: #isDefault
			ifFound: #name
			ifNone: [ nil "To be filled later (on first demand)" ] ]! !

!IceLibgitRepository class methodsFor: 'accessing' stamp: ''!
repositoriesLocation
 	^ self shareRepositoriesBetweenImages 
		ifTrue: [ self sharedRepositoriesLocation ]
		ifFalse: [ self localRepositoriesLocation ] ! !

!IceLibgitRepository class methodsFor: 'accessing' stamp: ''!
defaultFileFormat
	^ Smalltalk at: self defaultFileFormatType asSymbol! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
shareRepositoriesBetweenImages: anObject
	ShareRepositoriesBetweenImages := anObject! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
formatTypeDomainValues
	^ TIceRepositoryWriter traitUsers 
		ifNotEmpty: [ :users | users collect: [ :each | each description -> each name ] ]
		ifEmpty: [ { 'Undefined' -> nil } ]! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
sharedRepositoriesLocationString
	^ self sharedRepositoriesLocation fullName! !

!IceLibgitRepository class methodsFor: 'accessing' stamp: ''!
localRepositoriesLocation
	^ FileLocator localDirectory / #iceberg! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
defaultCodeSubdirectory: aString
	DefaultCodeSubdirectory := aString
! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
defaultFileFormatType: anObject
	DefaultFileFormatType := anObject! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
shareRepositoriesBetweenImages
	^ ShareRepositoriesBetweenImages ifNil: [ ShareRepositoriesBetweenImages := false ]! !

!IceLibgitRepository class methodsFor: 'rules' stamp: ''!
libgitErrorHandlerPragmaSelector
	
	"Pragma selector used to detect methods used as libgit error handlers.
	This selector is mainly used by architectural rules to ensure that libgit is being called correctly."
	^ #libgitErrorHandler! !

!IceLibgitRepository class methodsFor: 'utilities' stamp: ''!
requiredLibGit2MinimumVersion
	^ IceSemanticVersion 
		major: 0 
		minor: 25 
		patch: 1! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
sharedRepositoriesLocationString: aString
	SharedRepositoriesLocation := aString asFileReference! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder 
	<systemsettings>
	
	(aBuilder pickOne: #'defaultFileFormatType')
		parent: #Iceberg;
		target: self;
		default: #IceLibgitTonelWriter;
		label: 'File format type';
		description: 'Select your preferred file format.';
		domainValues: self formatTypeDomainValues.
  
	(aBuilder setting: #'defaultCodeSubdirectory')
		parent: #Iceberg;
		target: self;
		label: 'Default Code Subdirectory';
		default: 'src';
		description: 'Select your preferred source code folder name'.

	(aBuilder setting: #shareRepositoriesBetweenImages)
		parent: #Iceberg;
		target: self;
		default: false;
		label: 'Share repositories between images';
		description: 'Check if you want to have your git repositories cloned by default in a single location that is shared between all your Pharo images';
		with: [
			(aBuilder setting: #sharedRepositoriesLocationString)
				target: self;
				type: #Directory;
				default: (FileLocator home / #iceberg) asFileReference fullName;
				label: 'Location for shared repositories';
				description: 'A directory where you have your git repositories'.
		].
		! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
defaultCodeSubdirectory
	^ DefaultCodeSubdirectory ifNil: [ DefaultCodeSubdirectory := 'src' ]
! !

!IceLibgitRepository class methodsFor: 'rules' stamp: ''!
libgitErrorHandlerSelector
	
	"Detect what method is used for handling libgit errors.
	Detection is done through a pragma to allow future renames.
	
	This selector is mainly used by architectural rules to ensure that libgit is being called correctly."
	^ (self methods detect: [ :each |
		each pragmas anySatisfy: [ :pragma | pragma keyword = self libgitErrorHandlerPragmaSelector ] ]) selector! !

!IceLibgitRepository class methodsFor: 'rules' stamp: ''!
libgitRepositoryHandleAccessors
	
	^ self allMethods select: [ :m | m pragmas anySatisfy: [ :p | p keyword = self libgitRepositoryHandleAccessorPragmaSelector ] ]! !

!IceLibgitRepository class methodsFor: 'rules' stamp: ''!
libgitRepositoryHandleAccessorPragmaSelector
	
	"Pragma selector used to detect methods allowed to directly access the repository handle. 
	This selector is mainly used by architectural rules to ensure that libgit is being called correctly."
	^ #repositoryHandleAccessor! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
sharedRepositoriesLocation
	^ SharedRepositoriesLocation ifNil: [ 
		SharedRepositoriesLocation := (FileLocator home / #iceberg) asFileReference ]! !

!IceLibgitRepository class methodsFor: 'utilities' stamp: ''!
verifyBackendAvailabilityIfNot: aBlock
	| presentVersion requiredVersion |
	
	presentVersion := IceSemanticVersion fromArray: LGitLibrary uniqueInstance version.
	requiredVersion := self requiredLibGit2MinimumVersion.	
	requiredVersion <= presentVersion 
		ifFalse: [ ^ aBlock cull: requiredVersion cull: presentVersion ]! !

!IceLibgitRepository class methodsFor: 'settings' stamp: ''!
sharedRepositoriesLocation: anObject
	SharedRepositoriesLocation := anObject! !

!IceLibgitTonelFileUtils commentStamp: ''!
Emulates other 'file utils' classes by reading from a git repository (its blob, not a working copy'). Allows for reading any tree (from any commit) in the repository.!
!IceLibgitTonelFileUtils class methodsFor: 'utilities' stamp: ''!
directoryFromPath: aString relativeTo: aCommitOrTree
	^ aCommitOrTree 
		entryByPath: aString 
		ifAbsent: [ 
			IceMissingRepositoryEntry new name: aString; owner: aCommitOrTree; signal ]
! !

!IceLibgitTonelFileUtils class methodsFor: 'utilities' stamp: ''!
readStreamFor: fileName in: tree do: aBlock
	(tree entryByPath: fileName) readStreamDo: aBlock! !

!IceLibgitTonelFileUtils class methodsFor: 'accessing' stamp: ''!
pathNameDelimiter
	^ $/! !

!IceLibgitTonelFileUtils class methodsFor: 'utilities' stamp: ''!
directoryFromEntry: treeEntry 
	^ treeEntry object! !

!IceLibgitTonelFileUtils class methodsFor: 'utilities' stamp: ''!
directoryExists: aLGitTreeEntry 
	^ aLGitTreeEntry type = LGitObjectTypeEnum git_obj_tree! !

!IceLibgitTonelFileUtils class methodsFor: 'utilities' stamp: ''!
fileName: anEntry
    ^ anEntry filename! !

!IceLibgitTonelFileUtils class methodsFor: 'utilities' stamp: ''!
writeStreamFor: fileName in: directory do: aBlock 
	directory addEntryNamed: fileName withContents: (String streamContents: aBlock).! !

!IceLibgitTonelFileUtils class methodsFor: 'utilities' stamp: ''!
deleteAll: aTreeBuilder 
    ^ aTreeBuilder deleteAll! !

!IceLibgitTonelFileUtils class methodsFor: 'utilities' stamp: ''!
directoryName: anEntry
    ^ anEntry filename! !

!IceLibgitTonelLog commentStamp: ''!
I'm a tool to ask the full history of a method (based on tonel file format).!
!IceLibgitTonelLog methodsFor: 'private' stamp: ''!
definitionFor: aMethod path: aPath commit: aCommit
	^ ((IceLibgitTonelLogReader fileName: aPath on: aCommit)
		package: aMethod package mcPackage; 
		packageDirectory: (self repository directoryPathStringForPackage: aMethod package);
		definitions)
		detect: [ :each | each isMethodDefinition and: [ each selector = aMethod selector  ] ]
		ifNone: [ 
			 "not found, return 'NULL' object: compare will fail anyway"
			MCMethodDefinition 
				className: aMethod origin name
				selector: aMethod selector
				category: #''
				timeStamp: nil
				source: '' ]! !

!IceLibgitTonelLog methodsFor: 'private' stamp: ''!
basepathOf: aPath 
	^ aPath copyAfterLast: $/! !

!IceLibgitTonelLog methodsFor: 'private' stamp: ''!
tonelClassExtension: aClass
	aClass isTrait ifTrue: [ ^ '.trait' ].
	^ '.class'! !

!IceLibgitTonelLog methodsFor: 'private' stamp: ''!
tonelClassOrTraitName: aClass
	^ aClass name, (self tonelClassExtension: aClass), '.st'! !

!IceLibgitTonelLog methodsFor: 'private' stamp: ''!
toFileName: aMethod
	^ self fileNameForMethod: aMethod! !

!IceLibgitTonelLog methodsFor: 'private' stamp: ''!
tonelMethodClassOrTraitName: aMethod
	^ aMethod origin instanceSide name, (self tonelMethodClassExtension: aMethod), '.st'
	
	! !

!IceLibgitTonelLog methodsFor: 'private' stamp: ''!
tonelMethodClassExtension: aMethod
	aMethod isExtension ifTrue: [ ^ '.extension' ].
	aMethod origin isTrait ifTrue: [ ^ '.trait' ].
	^ '.class'
	! !

!IceLibgitTonelLog methodsFor: 'private' stamp: ''!
tonelPackageName: aPackage
	^ aPackage name	! !

!IceLibgitTonelLog methodsFor: 'private' stamp: ''!
fileNameForMethod: aMethod
	| path |
	
	path := OrderedCollection new.
	self repository subdirectory 
		ifNotEmpty: [ :subDir | path add: subDir ].
	path add: (self tonelPackageName: aMethod package).
	path add: (self tonelMethodClassOrTraitName: aMethod).
	
	^ String streamContents: [ :stream |
		path asStringOn: stream delimiter: '/' ]! !

!IceLibgitTonelLog class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	^ aRepository writerClass id = #tonel! !

!IceLibgitTonelLogReader commentStamp: ''!
I read exclusively the definition of the method defined in fileName.
I'm using to speed the creation of a version list on IceLibgitTonelLog.!
!IceLibgitTonelLogReader methodsFor: 'accessing' stamp: ''!
fileName
	^ fileName! !

!IceLibgitTonelLogReader methodsFor: 'accessing' stamp: ''!
fileName: aString
	fileName := aString! !

!IceLibgitTonelLogReader methodsFor: 'accessing' stamp: ''!
package: aPackage
	package := aPackage! !

!IceLibgitTonelLogReader methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!IceLibgitTonelLogReader methodsFor: 'private' stamp: ''!
canBeLoaded: aFileReference
	^ (super canBeLoaded: aFileReference)
		and: [ aFileReference filename = self fileName ] ! !

!IceLibgitTonelLogReader class methodsFor: 'instance creation' stamp: ''!
fileName: aString on: aCommit
	^ (self on: aCommit)
		fileName: aString;
		yourself! !

!IceLibgitTonelReader commentStamp: ''!
I'm a reader for the tonel file format.
!
!IceLibgitTonelReader methodsFor: 'accessing' stamp: ''!
versionName
	^ ('{1}-{2}.{3}' format: {
		self packageNameFromPackageDirectory. 
		self commit compatibleUsername. 
		self versionNumber
	})! !

!IceLibgitTonelReader methodsFor: 'accessing' stamp: ''!
iceVersion
	^ iceVersion! !

!IceLibgitTonelReader methodsFor: 'private' stamp: ''!
packageNameFromPackageDirectory
	^ iceVersion packageName! !

!IceLibgitTonelReader methodsFor: 'accessing' stamp: ''!
repository
	^ self iceVersion repository! !

!IceLibgitTonelReader methodsFor: 'accessing' stamp: ''!
commit
	^ stream! !

!IceLibgitTonelReader methodsFor: 'accessing' stamp: ''!
iceVersion: anObject
	| repository packageDirectoryName |
	iceVersion := anObject.
	repository := iceVersion commit repository.
	package := iceVersion package.
	
	packageDirectoryName := iceVersion commit writerClass directoryNameFor: package.
	self packageDirectory: (repository subdirectoryPath / packageDirectoryName) pathString! !

!IceLibgitTonelReader methodsFor: 'loading' stamp: ''!
loadVersionInfo
	^ info := self iceVersion info! !

!IceLibgitTonelReader methodsFor: 'accessing' stamp: ''!
package
	^ MCPackage named: self iceVersion packageName! !

!IceLibgitTonelReader methodsFor: 'accessing' stamp: ''!
fileUtils
	^ IceLibgitTonelFileUtils! !

!IceLibgitTonelReader class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!IceLibgitTonelReader class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!IceLibgitTonelReader class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!IceLibgitTonelReader class methodsFor: 'testing' stamp: ''!
isLegacyDefault
	^ false! !

!IceLibgitTonelReader class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!IceLibgitTonelReader class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!IceLibgitTonelReader class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!IceLibgitTonelReader class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!IceLibgitTonelReader class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!IceLibgitTonelReader class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceLibgitTonelReader class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!IceLibgitTonelReader class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!IceLibgitTonelReader class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!IceLibgitTonelReader class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!IceLibgitTonelReader class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!IceLibgitTonelReader class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!IceLibgitTonelReader class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!IceLibgitTonelReader class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!IceLibgitTonelReader class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceLibgitTonelReader class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!IceLibgitTonelReader class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!IceLibgitTonelReader class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!IceLibgitTonelReader class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!IceLibgitTonelReader class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!IceLibgitTonelReader class methodsFor: 'accessing' stamp: ''!
id
	^ #tonel! !

!IceLibgitTonelReader class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!IceLibgitTonelReader class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!IceLibgitTonelReader class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!IceLibgitTonelReader class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!IceLibgitTonelReader class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!IceLibgitTonelReader class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!IceLibgitTonelReader class methodsFor: 'instance creation' stamp: ''!
on: aCommitOrTree iceVersion: iceVersion
	^ (self on: aCommitOrTree) 
		iceVersion: iceVersion; 
		yourself! !

!IceLibgitTonelWriter commentStamp: ''!
I write versions and snapshots in tonel format.!
!IceLibgitTonelWriter methodsFor: 'accessing' stamp: ''!
repositoryDirectory: anObject
	repositoryDirectory := anObject! !

!IceLibgitTonelWriter methodsFor: 'writing' stamp: ''!
writeVersion: aVersion
	(self repositoryDirectory / aVersion package name) ensureDeleteAll.
	self writeSnapshot: aVersion snapshot
	! !

!IceLibgitTonelWriter methodsFor: 'accessing' stamp: ''!
repositoryDirectory
	^ repositoryDirectory! !

!IceLibgitTonelWriter methodsFor: 'writing' stamp: ''!
writeSnapshot: aSnapshot
	(TonelWriter on: self repositoryDirectory) writeSnapshot: aSnapshot
		! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
packageNameFromDirectory: aFileReference
	^ aFileReference basename! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
isValidPackage: aFileReference 
	
	^ aFileReference basename first isLetter
		and: [ aFileReference isDirectory
		and: [ (aFileReference / 'package.st') exists ] ]! !

!IceLibgitTonelWriter class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
isLegacyDefault
	"Indicates when repository is default as legacy (when there is no properties file indicating 
	 a specific format type)"
	^ false! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
logClass
	^ IceLibgitTonelLog! !

!IceLibgitTonelWriter class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
description
	^ 'Tonel'! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
isDefault
	^ true! !

!IceLibgitTonelWriter class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!IceLibgitTonelWriter class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!IceLibgitTonelWriter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceLibgitTonelWriter class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!IceLibgitTonelWriter class methodsFor: 'accessing - ancient preference selectors' stamp: ''!
directoryNameFor: aPackage
	^ aPackage name! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
readerClass
	^ IceLibgitTonelReader! !

!IceLibgitTonelWriter class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!IceLibgitTonelWriter class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
forInternalStore
	^ TonelWriter! !

!IceLibgitTonelWriter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!IceLibgitTonelWriter class methodsFor: 'writing' stamp: ''!
forInternalStoreFileOut: aMCVersion on: aRepository
	self forInternalStore 
		fileOut: aMCVersion
		on: aRepository subdirectoryReference! !

!IceLibgitTonelWriter class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!IceLibgitTonelWriter class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
id
	^ #tonel! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!IceLibgitTonelWriter class methodsFor: 'instance creation' stamp: ''!
on: dir
	^ self new repositoryDirectory: dir
	
	
! !

!IceLibgitTonelWriter class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!IceLibgitTonelWriter class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!IceLibgitTonelWriter class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!IceLibgitTonelWriter class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!IceLibgitTonelWriter class methodsFor: 'writing' stamp: ''!
fileOut: aVersion on: dir
	(self on: dir) writeVersion: aVersion
! !

!IceLibgitTreeBuilder commentStamp: ''!
Please comment me using the following template inspired by Class Responsibility Collaborator (CRC) design:

For the Class part:  State a one line summary. For example, "I represent a paragraph of text".

For the Responsibility part: Three sentences about my main responsibilities - what I do, what I know.

For the Collaborators Part: State my main collaborators and one line about how I interact with them. 

Public API and Key Messages

- message one   
- message two 
- (for bonus points) how to create instances.

   One simple example is simply gorgeous.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	builder:		<Object>
	changes:		<Object>
	children:		<Object>
	entryName:		<Object>
	originalTree:		<LGitTree> Contains the original contents on which this builder bases. Warning: this will not reflect the actual contents of the builder. Use #buildTree instead.
	parent:		<Object>


    Implementation Points!
!IceLibgitTreeBuilder methodsFor: 'building' stamp: ''!
buildTree
	self children keysAndValuesDo: [ :childEntryName :childBuilder |
		childBuilder hasChanges ifTrue: [ 
			self builder 
				addEntry: childBuilder buildTree
				filename: childEntryName
		]
	].

	^ self builder newTree! !

!IceLibgitTreeBuilder methodsFor: 'accessing' stamp: ''!
initialTree
	^ initialTree
! !

!IceLibgitTreeBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	hasChanges := false.
	! !

!IceLibgitTreeBuilder methodsFor: 'accessing' stamp: ''!
entryName
	^ entryName! !

!IceLibgitTreeBuilder methodsFor: 'querying' stamp: ''!
entryByName: aString
	^ self children 
		at: aString 
		ifAbsentPut: [  
			self class new 
				initializeWithParent: self 
				entryName: aString ]! !

!IceLibgitTreeBuilder methodsFor: 'initializing' stamp: ''!
initializeWithTree: aLGitTree
	"This is a builder on the root of a repository"
	initialTree := aLGitTree ! !

!IceLibgitTreeBuilder methodsFor: 'modifying' stamp: ''!
addEntryNamed: name withContents: aString
	self builder 
		addEntry: (LGitBlob of: self repository fromString: aString)
		filename: name.
		
	self changes add: name.
	hasChanges := true! !

!IceLibgitTreeBuilder methodsFor: 'accessing' stamp: ''!
children
	^ children ifNil: [ children := Dictionary new ]! !

!IceLibgitTreeBuilder methodsFor: 'querying' stamp: ''!
entryByPath: aString
	^ (aString = '.' )
		ifTrue: [ self ]
		ifFalse: [( ($/ split: aString) reject: #isEmpty)
			inject: self 
			into: [ :treeBuilder :name | treeBuilder entryByName: name ]]! !

!IceLibgitTreeBuilder methodsFor: 'initializing' stamp: ''!
initializeWithParent: anIceTreeBuilder entryName: aString
	| treeEntry |
	parent := anIceTreeBuilder.
	entryName := aString.

	treeEntry := parent builder getEntryNamed: entryName.
	treeEntry isReady "i.e. the entry alredy exists in parent tree"
		ifTrue: [ initialTree := treeEntry tree ]
		ifFalse: [ 
			"The entry didn't exist so this is a new entry"
			hasChanges := true ]
! !

!IceLibgitTreeBuilder methodsFor: 'patches' stamp: ''!
directory
	^ self ! !

!IceLibgitTreeBuilder methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		nextPutAll: self class name;
		nextPut: $(.
	self printPathOn: aStream.
	aStream nextPut: $)
! !

!IceLibgitTreeBuilder methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!IceLibgitTreeBuilder methodsFor: 'accessing' stamp: ''!
repository
	^ parent 
		ifNotNil: [ self parent repository ]
		ifNil: [ self initialTree owner ]! !

!IceLibgitTreeBuilder methodsFor: 'printing' stamp: ''!
printPathOn: aStream
	parent 
		ifNil: [ 
			aStream nextPutAll: initialTree repository workingDirectoryName ]
		ifNotNil: [ 	
			parent printPathOn: aStream.
			aStream nextPut: $/;
				nextPutAll: entryName ] ! !

!IceLibgitTreeBuilder methodsFor: 'accessing' stamp: ''!
builder
	^ builder ifNil: [ 
		builder := LGitTreeBuilder 
			of: self repository
			fromTree: self initialTree ]
! !

!IceLibgitTreeBuilder methodsFor: 'accessing' stamp: ''!
changes
	^ changes ifNil: [ changes := OrderedCollection new ]! !

!IceLibgitTreeBuilder methodsFor: 'querying' stamp: ''!
hasChanges
	^ hasChanges
		or: [ initialTree isNil "It means that this is a new tree"
		or: [ self children anySatisfy: #hasChanges ]]
! !

!IceLibgitTreeBuilder methodsFor: 'modifying' stamp: ''!
deleteAll
	self builder clear.
! !

!IceLibgitTreeBuilder class methodsFor: 'instance creation' stamp: ''!
on: aLGitTree
	"Creates a tree builder on the root of the repository"
	^ self new initializeWithTree: aLGitTree! !

!IceLocalBranch commentStamp: ''!
I am a local branch. My main difference with remote branches is that I may have a remote tracked branch. This remote tracked branch allows me to calculate my incoming and outgoing commits.

  branch incomingCommits.
  branch hasIncomingCommits.
  branch outgoingCommits.
  branch hasOutgoingCommits.

I can moreover calculate incoming and outgoing commits to/from a given remote.

  branch incomingCommitsFrom: aRemote.
  branch hasIncomingCommitsFrom: aRemote.
  branch outgoingCommitsTo: aRemote.
  branch hasOutgoingCommitsTo: aRemote.

Notice that none of these operations fetches the remote, thus the information may not be up to date. You may explicitly fetch before doing these questions.

A local branch can also pull from its tracked branch or pull from a given remote.

  branch pull.
  branch pullFrom: aRemote.!
!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
hasIncomingCommitsFrom: aRemote
	
	| localCommits remoteCommits |
	self tracksRemoteBranch
		ifFalse: [ ^ false ].
	
	localCommits := self commits.
	remoteCommits := self trackedBranch commits.
	^ remoteCommits anySatisfy: [ :each |
		(localCommits includes: each) not ]! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
setUpstreamRemote: aRemote
	
	self setUpstream: (aRemote remoteBranchNamed: self name)! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
upstream
	
	^ self subclassResponsibility! !

!IceLocalBranch methodsFor: 'testing' stamp: ''!
isRemote

	^ false! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
tracksRemoteBranch
	
	^ self subclassResponsibility! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
pullFrom: aRemote
	
	| remoteBranch |
	aRemote fetchBranch: self.
	remoteBranch := aRemote
		remoteBranchNamed: self name
		ifAbsent: [ ^ self ].
	self repository workingCopy mergeCommit: remoteBranch commit.! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
reducedOutgoingCommitsWhenNoRemote
	^ self newCommitWalk
		maxNumber: 20;
		commits! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
outgoingCommitsTo: aRemote
	
	| remoteBranch walk |

	"If there is no remote tracking branch in the remote, we cannot calculate outgoing commits.
	All the commits in the branch are going to be outgoing, so I will take the first 20 to show."
	remoteBranch := aRemote remoteBranchNamed: self name ifAbsent: [ ^ self reducedOutgoingCommitsWhenNoRemote ].
	walk := self newCommitWalk.
	remoteBranch ifNotNil: [ 
		walk uptoCommit: remoteBranch commit ].
	^ walk commits! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
pull
	
	self pullFrom: self upstream remote! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
incomingCommitsFromBranch: aBranch
	
	^ aBranch newCommitWalk
		uptoCommit: self commit;
		commits! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
outgoingCommits
	
	self hasUpstream ifFalse: [ ^ #() ].
	^ self outgoingCommitsTo: self upstream remote! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
incomingCommitsFrom: aRemote
	
	| remoteBranch |

	remoteBranch := aRemote remoteBranchNamed: self name ifAbsent: [ ^ #() ].
	^ remoteBranch newCommitWalk
		uptoCommit: self commit;
		commits! !

!IceLocalBranch methodsFor: 'accessing' stamp: ''!
trackedBranch
	
	self subclassResponsibility! !

!IceLocalBranch methodsFor: 'testing' stamp: ''!
hasIncomingCommits
	
	self hasUpstream ifFalse: [ ^ false ].
	^ self hasIncomingCommitsFrom: self upstream remote! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
hasOutgoingCommitsTo: aRemote
	
	| localCommits remoteCommits |
	self tracksRemoteBranch
		ifFalse: [ ^ false ].
	
	localCommits := self commits.
	remoteCommits := self trackedBranch commits.
	^ localCommits anySatisfy: [ :each |
		(remoteCommits includes: each) not ]! !

!IceLocalBranch methodsFor: 'testing' stamp: ''!
hasOutgoingCommits
	
	self hasUpstream ifFalse: [ ^ false ].
	^ self hasOutgoingCommitsTo: self upstream remote! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
push
	
	self pushTo: self upstream remote! !

!IceLocalBranch methodsFor: 'API - merging' stamp: ''!
mergeWith: aCommit

	self subclassResponsibility! !

!IceLocalBranch methodsFor: 'API - commits' stamp: ''!
resetToCommit: anIceGitCommit
	"Equivalent to a `git reset --hard` but not touching the image"
	"1) Change the current commit of this branch
	 2) Check it out in disk if it is current branch
	 3) Clean index
	It does not checkout any code in the image.
	Instead, it should make a diff and mark differences"
	self commit: anIceGitCommit! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
setUpstream: anUpstreamBranch
	
	self subclassResponsibility! !

!IceLocalBranch methodsFor: 'API - commits' stamp: ''!
commit: anIceCommit
	
	self subclassResponsibility! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
hasUpstream
	
	^ self subclassResponsibility! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
incomingCommits
	
	self hasUpstream ifFalse: [ ^ #() ].
	^ self incomingCommitsFrom: self upstream remote! !

!IceLocalBranch methodsFor: 'API - remotes' stamp: ''!
pushTo: aRemote
	
	self subclassResponsibility! !

!IceLocalBranch methodsFor: 'API - merging' stamp: ''!
mergeWithBranch: aBranch
	
	self subclassResponsibility! !

!IceLocalRepositoryMissing commentStamp: ''!
The repository code directory does not exist, maybe because the image was moved. 

Default action is to clone the repository again, but signal an error and allow for other components to react accordingly.!
!IceLocalRepositoryMissing methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceLocalRepositoryMissing methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceLocalRepositoryMissing class methodsFor: 'exceptioninstantiator' stamp: ''!
signalFor: repository
	^ self new 
		repository: repository;
		signal! !

!IceLog commentStamp: ''!
I'm an abstract log tool.
I'm used to crate a full history of a method (see #historyOfMethod:)

I'm used through a repository: 

aRepository ice historyOfMethod: aMethod!
!IceLog methodsFor: 'private' stamp: ''!
definitionFor: aMethod path: aPath commit: aCommit
	self subclassResponsibility! !

!IceLog methodsFor: 'private' stamp: ''!
iceCommitFrom: aLGitCommit
	^ self repository iceCommitFrom: aLGitCommit! !

!IceLog methodsFor: 'private' stamp: ''!
basepathOf: aPath
	self subclassResponsibility! !

!IceLog methodsFor: 'private' stamp: ''!
collectVersionsFrom: aCollection method: aMethod path: aPath
	| lastDefinition basepath history |
		
	basepath := self basepathOf: aPath.
	lastDefinition := MCMethodDefinition new.
	history := OrderedCollection new.
	aCollection reverseDo: [ :eachCommit | | definition |
		definition := self definitionFor: aMethod path: basepath commit: eachCommit.
		lastDefinition = definition  ifFalse: [ 
			history add: (IceLogVersion 
				commit: (self repository commitFromGitCommit: eachCommit)
				definition: definition asRingDefinition).
			lastDefinition := definition ] ].

	^ history reversed! !

!IceLog methodsFor: 'private' stamp: ''!
toFileName: aMethod
	^ self subclassResponsibility! !

!IceLog methodsFor: 'accessing' stamp: ''!
historyOfMethod: aMethod
	| path commits |

	path := self toFileName: aMethod.
	commits := self collectCommitsFor: aMethod path: path.
	
	^ self 
		collectVersionsFrom: commits 
		method: aMethod 
		path: path! !

!IceLog methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceLog methodsFor: 'private' stamp: ''!
collectCommitsFor: aMethod path: aPath
	| commit pathSpec options commits pathSpecArray |

	commit := self repository headCommit.
	pathSpec := LGitPathSpec withAll: { aPath }.
	options := LGitDiffOptions defaults.
	pathSpecArray := LGitStringArray withAll: { aPath }.
	options pathspec: pathSpecArray.

	commits := OrderedCollection new.
	self repository newCommitWalk 
		fromCommit: commit;
		rawResultsDo: [ :eachCommit | | parents tree | 
			parents := eachCommit numberOfParents.
			tree := eachCommit tree.
			parents = 0 
				ifTrue: [
					(tree matchesPathSpec: pathSpec)
						ifTrue: [ commits add: eachCommit ] ]
				ifFalse: [ 
					eachCommit parents do: [ :eachParent | | diff |
						diff := tree diffTo: eachParent tree options: options. 
						diff numberOfDeltas > 0 
							ifTrue: [ commits add: eachCommit ] ] ] ].

	^ commits! !

!IceLog methodsFor: 'initialization' stamp: ''!
initializeRepository: aRepository
	repository := aRepository.
	self initialize! !

!IceLog class methodsFor: 'instance creation' stamp: ''!
new
	self error: '#for:'! !

!IceLog class methodsFor: 'instance creation' stamp: ''!
for: aRepository
	^ self basicNew
		initializeRepository: aRepository;
		yourself	! !

!IceLog class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	^ false! !

!IceLogVersion commentStamp: ''!
I'm a log version. 
I keep a commit and a method definition from each method version tracked on IceLog>>#historyOfMethod:.!
!IceLogVersion methodsFor: 'accessing' stamp: ''!
datetime
	^ self commit datetime! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
timeStamp
	^ self commit timeStamp! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
author
	^ self commit author! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
description
	^ '{1} at {2}' format: { self author. self datetime asLocalStringYMDHM }! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
tags
	^ self commit tags! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
source
	^ String streamContents: [ :stream | 
		stream 
			<< '"protocol: ' << self definition category << '"'; cr;
			<< self definition sourceCode ]! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
comment
	^ self commit comment! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
definition: aRingDefinition
	definition := aRingDefinition! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
commit: aCommit
	commit := aCommit! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
originMethod
	^ (Smalltalk at: self definition methodClass name) >> self definition selector! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
tagNames
	^ self commit tagNames! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
definition
	^ definition! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
commit
	^ commit! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
shortId
	^ self commit shortId! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
id
	^ self commit id! !

!IceLogVersion methodsFor: 'accessing' stamp: ''!
ancestors
	^ self commit ancestors! !

!IceLogVersion class methodsFor: 'instance creation' stamp: ''!
commit: aCommit definition: aRingDefinition 
	^ self new 
		commit: aCommit; 
		definition: aRingDefinition;
		yourself! !

!IceMCDefinitionImporter commentStamp: ''!
I am an importer that visits MCDefinitions and creates IceDefinitions from them. I install those definitions into a corresponding package node.!
!IceMCDefinitionImporter methodsFor: 'visiting' stamp: ''!
visitMetaclassDefinition: aMCClassDefinition
	"We do nothing because of Monticello meta-model.
	
	The problem is that Monticello visitor does not launch the Metaclass visit if the metaclass does not have any class instance variables or Trait composition. We need this information all the time so we will generate it in the class visit.
	
	The concrete method it MCClassDefinition>>accept:"

	! !

!IceMCDefinitionImporter methodsFor: 'testing' stamp: ''!
isExtension: aName
	
	snapshot classDefinitionNamed: aName ifAbsent:  [ ^ true ].
	^ false! !

!IceMCDefinitionImporter methodsFor: 'visiting' stamp: ''!
visitClassDefinition: aMCClassDefinition 
	
	| classDefinitionNode classDefinition |
	classDefinitionNode := self
		ensureMethodOwnerNamed: aMCClassDefinition className
		isMeta: false
		isTrait: false
		isExtension: false.
	classDefinitionNode value mcDefinition: aMCClassDefinition.
	
	(aMCClassDefinition hasClassInstanceVariables
		or: [aMCClassDefinition hasClassTraitComposition]) ifTrue: [
		"We also generate the definition for the metaclass (See visitMetaclassDefinition: comment)"
		classDefinition := self
			ensureMethodOwnerNamed: aMCClassDefinition className
			isMeta: true
			isTrait: false
			isExtension: false.
		classDefinition value mcDefinition: aMCClassDefinition ].
	^ classDefinitionNode! !

!IceMCDefinitionImporter methodsFor: 'visiting' stamp: ''!
ensureMethodOwnerNamed: ownerName isMeta: isMeta isTrait: isTrait isExtension: isExtension
	| newDefinition |
	newDefinition := isExtension
		ifTrue: [ IceExtensionDefinition named: ownerName isMeta: isMeta packageName: packageNode value name]
		ifFalse: [ isTrait
				ifFalse: [ IceClassDefinition named: ownerName isMeta: isMeta ]
				ifTrue: [ IceTraitDefinition named: ownerName isMeta: isMeta ] ].

	^ packageNode
		childAt: newDefinition key
		ifAbsentPut: [ newDefinition ]! !

!IceMCDefinitionImporter methodsFor: 'testing' stamp: ''!
isTrait: aName 
	
	| definition |
	definition := snapshot classDefinitionNamed: aName ifAbsent: [ ^ false ].
	^ definition isTraitDefinition! !

!IceMCDefinitionImporter methodsFor: 'accessing' stamp: ''!
snapshot: aMCSnapshot 
	snapshot := aMCSnapshot! !

!IceMCDefinitionImporter methodsFor: 'visiting' stamp: ''!
visitTraitDefinition: aMCTraitDefinition 
	
	| traitDefinitionNode |
	traitDefinitionNode := self
		ensureMethodOwnerNamed: aMCTraitDefinition className
		isMeta: false
		isTrait: true
		isExtension: false.
	traitDefinitionNode value mcDefinition: aMCTraitDefinition.
	^ traitDefinitionNode! !

!IceMCDefinitionImporter methodsFor: 'accessing' stamp: ''!
packageNode: anIcePackageNode 
	packageNode := anIcePackageNode! !

!IceMCDefinitionImporter methodsFor: 'visiting' stamp: ''!
visitOrganizationDefinition: aMCOrganizationDefinition 
	
	packageNode value categories: aMCOrganizationDefinition categories! !

!IceMCDefinitionImporter methodsFor: 'visiting' stamp: ''!
visitMethodDefinition: aMCMethodDefinition 
	
	| ownerName isMeta isTrait ownerNode |
	
	ownerName := aMCMethodDefinition className.
	isMeta := aMCMethodDefinition classIsMeta.
	isTrait := self isTrait: aMCMethodDefinition className.
	
	ownerNode := self
		ensureMethodOwnerNamed: ownerName
		isMeta: isMeta
		isTrait: isTrait
		isExtension: (self isExtension: aMCMethodDefinition className).

	^ ownerNode addChild: (IceMethodDefinition
		className: aMCMethodDefinition className
		classIsMeta: aMCMethodDefinition classIsMeta
		protocol: aMCMethodDefinition protocol
		name: aMCMethodDefinition selector
		sourceCode: aMCMethodDefinition source)! !

!IceMCDefinitionImporter methodsFor: 'visiting' stamp: ''!
visitClassTraitDefinition: aMCClassTraitDefinition 

	| classTraitDefinitionNode |
	classTraitDefinitionNode := self
		ensureMethodOwnerNamed: aMCClassTraitDefinition className
		isMeta: true
		isTrait: true
		isExtension: false.
	classTraitDefinitionNode value mcDefinition: aMCClassTraitDefinition.
	^ classTraitDefinitionNode! !

!IceMCPackageImporter commentStamp: ''!
I am an importer of MCPackages into an IceNode. I am created from a version and a node. I calculate the snapshot of that definition and import all those definitions into my node, delegating to a IceMCDefinitionImporter.!
!IceMCPackageImporter methodsFor: 'importing' stamp: ''!
importOn: aNode
	
	| packageNode snapshot definition |
	"If the version does not include the package, we do not calculate a snapshot nor import it"
	(version includesPackageNamed: self packageName)
		ifFalse: [ ^ self ].
	
	definition := IcePackageDefinition named: self packageName.
	packageNode := aNode addChild: definition.
	definition path: packageNode path.
	
	snapshot := self snapshot.
	snapshot definitions do: [ :e | 
		e accept: (IceMCDefinitionImporter new
			packageNode: packageNode;
			snapshot: snapshot;
			yourself) ].
	^ packageNode! !

!IceMCPackageImporter methodsFor: 'accessing' stamp: ''!
version: aVersion
	
	version := aVersion! !

!IceMCPackageImporter methodsFor: 'accessing' stamp: ''!
packageName
	
	^ self package name! !

!IceMCPackageImporter methodsFor: 'accessing' stamp: ''!
snapshot
	
	^ version snapshotForPackage: self package! !

!IceMCPackageImporter methodsFor: 'accessing' stamp: ''!
package: aPackage
	
	package := aPackage! !

!IceMCPackageImporter methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!IceMCSnapshotPatchVisitor methodsFor: 'visiting' stamp: ''!
visitRemoval: anIceRemoval 
	anIceRemoval definition removeFromPatcher: patcher.
	self visitChildrenOf: currentNode! !

!IceMCSnapshotPatchVisitor methodsFor: 'visiting' stamp: ''!
visitAddition: anIceAddition 
	anIceAddition definition addToPatcher: patcher.
	self visitChildrenOf: currentNode! !

!IceMCSnapshotPatchVisitor methodsFor: 'accessing' stamp: ''!
patcher: aMCPatcher
	patcher := aMCPatcher! !

!IceMCSnapshotPatchVisitor methodsFor: 'visiting' stamp: ''!
visitModification: anIceModification

	anIceModification leftDefinition addModification: anIceModification toPatcher: patcher.
	self visitChildrenOf: currentNode! !

!IceMCSnapshotPatchVisitor methodsFor: 'visiting' stamp: ''!
visitNoModification: anIceNoModification
	
	anIceNoModification definition addToPatcher: patcher.
	self visitChildrenOf: currentNode! !

!IceMCSnapshotPatchVisitor methodsFor: 'visiting' stamp: ''!
visitNonConflictingOperation: anIceNonConflictingOperation

	^ anIceNonConflictingOperation chosenOperation accept: self! !

!IceMCVersionInfo commentStamp: ''!
Adapter to produce an MCVersionInfo that knows how to (lazily) load ancestors from an Iceberg repository.!
!IceMCVersionInfo methodsFor: 'comparing' stamp: ''!
= anotherIceMCVersionInfo

	^ super = anotherIceMCVersionInfo
		and: [ package name = anotherIceMCVersionInfo package name ]! !

!IceMCVersionInfo methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	date := Date today.
	time := Time now! !

!IceMCVersionInfo methodsFor: 'comparing' stamp: ''!
hash

	^ super hash << 10 + package hash! !

!IceMCVersionInfo methodsFor: 'accessing' stamp: ''!
iceVersion
	^ commit versionFor: package! !

!IceMCVersionInfo methodsFor: 'private' stamp: ''!
loadAncestorsAndStepChildren
	self shouldBeImplemented ! !

!IceMCVersionInfo methodsFor: 'initialization' stamp: ''!
fromPackage: aPackage message: commitMessage
	"This creates a partial version info. Full version info can not be created until we commit into a repository, 
	but current fileout tools require it, so we first create an incomplete info and after committing it will be completed
	by sending #fromCommit:package:
	
	To improve this implementation we should review the fileout process."

	name := ('{1}-{2}.{3}' format: {aPackage name. Author fullName. 'unknown'}).
	package := aPackage.
	message := commitMessage.
	id := UUID new
! !

!IceMCVersionInfo methodsFor: 'accessing' stamp: ''!
commit
	^ commit! !

!IceMCVersionInfo methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!IceMCVersionInfo methodsFor: 'initialization' stamp: ''!
fromCommit: aCommit package: aPackage
	"This method can be used for first initializing a version info or to update a partially initialized version info."
	"See #fromPackage:message:"
	commit := aCommit.
	package := aPackage.
	
   	date := commit datetime asDate.
   	time := commit datetime asTime.
	
	name := ('{1}-{2}.{3}' format: {
		package name. 
		commit compatibleUsername. 
		commit datetime asUnixTime 
	}).
	
	id := self class uuidFromCommit: aCommit package: aPackage.

   	message := commit comment.
   	author := commit compatibleUsername
! !

!IceMCVersionInfo class methodsFor: 'utilities' stamp: ''!
uuidFromSHA: cid
	"Return an adequate uuid from a git commit ID. Copied from GitFileTree."

	^ UUID nilUUID
		in: [ :uuid |
			1 to: 16 do: [ :i | uuid at: i put: (cid at: i) ].
			uuid at: 9 put: (16r80 bitOr: ((uuid at: 9) bitAnd: 16r3F)).	"Type"
			uuid at: 7 put: (16r50 bitOr: ((uuid at: 7) bitAnd: 16r0F)).	"Version 5 : SHA-1 Namespace (git)."
			uuid ]! !

!IceMCVersionInfo class methodsFor: 'utilities' stamp: ''!
uuidFromCommit: aCommit package: aPackage
	^ self uuidFromSHA: (SHA1 new hashStream: (ReadStream on: aCommit id, aPackage name))
! !

!IceMCVersionInfo class methodsFor: 'instance creation' stamp: ''!
package: package message: commitMessage
	^ self new fromPackage: package message: commitMessage
! !

!IceMerge commentStamp: ''!
I implement the merge between two versions. I calculate the diff tree of each version and then calculate a merge tree containing the operations that should be applied to the right target tree to arrive to the left tree.

I am created by doing one of the following:

- IceMerge from: aVersion to: anotherVersion.

- IceMerge new
	sourceVersion: aVersion;
	targetVersion: anotherVersion;
	build;
	yourself!
!IceMerge methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ mergeTree isEmpty! !

!IceMerge methodsFor: 'testing' stamp: ''!
isInverseMerge
	"When the image commit corresponds to the mergeCommit. 
	It means we are in an inverse merge. We want to merge the changes from the image into head commit.
	
	This is false when the image commit corresponds with head. In this other scenario, we want to merge the changes from the merge commit into head commit."
	^ self imageCommit = mergeCommit! !

!IceMerge methodsFor: 'executing' stamp: ''!
updateWorkingCopy

	" 3 - Load changes in the image.
	In case the commit was already in the history, merge is a null object with no changes"
	repository workingCopy loadChangesInWorkingCopy: self changesToWorkingCopyTree.
	repository workingCopy refreshDirtyPackages! !

!IceMerge methodsFor: 'executing' stamp: ''!
calculateChanges

	| commonAncestor sourceDiff targetDiff |

	mergeTree ifNotNil: [ ^ self ].

	commonAncestor := (self leftCommit commonAncestorWith: mergeCommit) ifNil: [ IceNoCommit new ].
	sourceDiff := self sourceVersion diffTo: commonAncestor.
	targetDiff := self targetVersion diffTo: commonAncestor.

	mergeTree := IceTreeMerger new merge: sourceDiff tree
		into: targetDiff tree.
	
	changesToWorkingCopyTree := self isInverseMerge 
		ifTrue: [  IceTreeMerger new merge: targetDiff tree into: sourceDiff tree ] 
		ifFalse: [ mergeTree  ]
	 ! !

!IceMerge methodsFor: 'accessing' stamp: ''!
targetVersion
	"This is the commit that will receive the changes. 
	In a merge, the commit receiving the changes is the head of the repository."
	^ self leftCommit! !

!IceMerge methodsFor: 'testing' stamp: ''!
isFastForward
	^ self headCommit isAncestorOf: mergeCommit! !

!IceMerge methodsFor: 'accessing' stamp: ''!
repository
	
	^ repository! !

!IceMerge methodsFor: 'enumerating' stamp: ''!
conflictsDo: aBlockClosure 
	
	mergeTree do: [ :each |
		each isConflict ifTrue: [ aBlockClosure value: each value ] ]! !

!IceMerge methodsFor: 'executing' stamp: ''!
execute
	"at begining of this, there is a possibility that imageCommit needs to be 'fixed' to use."
	| commitToAdvance |
	mergeCommit validateCanMerge.
	self isAlreadyMerged ifTrue: [ ^ self ].

	" 1 - Merge changes.
	If the image and merge commit are the same, and the headCommit is their ancestor, we should do nothing.
	Otherwise, we should merge the two commits we have, discerning well which is the left and which is the right commit." 
	self resolveConflicts.
	commitToAdvance := self updateHead.
	
	self updateWorkingCopy.
	
	^ commitToAdvance! !

!IceMerge methodsFor: 'accessing' stamp: ''!
sourceVersion
	"This is the commit that will provide the changes. 
	In a merge, the commit providing the changes is the merge commit."

	^ mergeCommit! !

!IceMerge methodsFor: 'testing' stamp: ''!
hasConflicts
	
	self calculateChanges.
	^ mergeTree anySatisfy: [ :e | e isConflict ]! !

!IceMerge methodsFor: 'accessing' stamp: ''!
headCommit
	^ repository headCommit! !

!IceMerge methodsFor: 'testing' stamp: ''!
isAlreadyMerged
	"The commit is already merged in the image and in the head commit.
	This means the selected commit is already in the history and there is nothing to do about it."

	^ mergeCommit isAncestorOf: self leftCommit! !

!IceMerge methodsFor: 'descriptions' stamp: ''!
sourceDescription
	^ 'Working Copy version: ' , self repository workingCopy description! !

!IceMerge methodsFor: 'executing' stamp: ''!
updateHead
	" 2 - Update HEAD.
	If the merged commits are from diverging branches, generate a merge commit.
	Then, adopt the commit in
	 - the working copy
	 - the current branch"

	| commitToAdvance |
	commitToAdvance := self isFastForward
		ifTrue: [ "Fast-forward. There is no need to update the working copy in disk.
			Changing the commit in the branch below will checkout the commit in disk."
			repository workingCopy adoptCommit: mergeCommit.
			mergeCommit ]
		ifFalse: [ "Merge case"
			repository workingCopy
				setMergeStateBetweenCommits:
					{self leftCommit.
					mergeCommit}.
			repository workingCopy commitChanges: self withMessage: 'Merge ' , mergeCommit id asString force: true ].
	repository branch commit: commitToAdvance! !

!IceMerge methodsFor: 'accessing' stamp: ''!
leftCommit

	^ self isInverseMerge
		ifTrue: [ self headCommit ]
		ifFalse: [ self imageCommit ].
! !

!IceMerge methodsFor: 'accessing' stamp: ''!
treeToShow
	"Returns the tree to show in the UI.
	Polymorphic with an ice Diff"
	^ self changesToWorkingCopyTree! !

!IceMerge methodsFor: 'accessing' stamp: ''!
unresolvedConflictCount

	^ mergeTree count: [ :operation |
		operation isConflict and: [ operation isResolved not ] ]! !

!IceMerge methodsFor: 'accessing' stamp: ''!
mergeCommit: aCommit 
	mergeCommit := aCommit! !

!IceMerge methodsFor: 'testing' stamp: ''!
isMerged
	
	^ mergeTree allSatisfy: [ :operation |
		operation isConflict not or: [ operation isResolved ] ]! !

!IceMerge methodsFor: 'accessing' stamp: ''!
mergeTree
	self calculateChanges.
	^ mergeTree! !

!IceMerge methodsFor: 'accessing' stamp: ''!
tree
	"Returns the tree to merge.
	Polymorphic with an ice Diff"
	^ self mergeTree! !

!IceMerge methodsFor: 'descriptions' stamp: ''!
targetDescription
	^ 'Merging commit: ' , self sourceVersion description! !

!IceMerge methodsFor: 'accessing' stamp: ''!
imageCommit
	
	^ imageCommit ifNil: [ imageCommit := repository workingCopy referenceCommit ]! !

!IceMerge methodsFor: 'accessing' stamp: ''!
changesToWorkingCopyTree

	self calculateChanges.
	^ changesToWorkingCopyTree! !

!IceMerge methodsFor: 'executing' stamp: ''!
resolveConflicts
	self hasConflicts
		ifTrue: [ | resolved |
			"Abort merge and signal for manual merge. 
				Index is not saved and repository will be discarded, 
				so no further action is needed to abort the merge"
			resolved := IceMergeResolutionRequest new
				merger: self;
				signal: 'Merging ' , mergeCommit description , ' into ' , self leftCommit description.
			resolved
				ifFalse: [ IceMergeAborted signal ] ]! !

!IceMerge methodsFor: 'accessing' stamp: ''!
repository: anIceRepository 
	repository := anIceRepository! !

!IceMergeAborted commentStamp: ''!
Attempting to merge arised a conflict so merge was aborted.!
!IceMergeAborted methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor
	aVisitor visitMergeAborted: self! !

!IceMergeListWrapper commentStamp: ''!
I am a morphic list wrapper that wraps iceberg diff tree nodes (potentially with conflicts)!
!IceMergeListWrapper methodsFor: 'comparing' stamp: ''!
= aWrapper

	^ self item = aWrapper item! !

!IceMergeListWrapper methodsFor: 'comparing' stamp: ''!
hash

	^ self item hash! !

!IceMergeListWrapper methodsFor: 'resolution' stamp: ''!
chooseLocal
	
	^ item value selectRight! !

!IceMergeListWrapper methodsFor: 'testing' stamp: ''!
asString

	^item value description! !

!IceMergeListWrapper methodsFor: 'resolution' stamp: ''!
chooseRemote
	
	^ item value selectLeft! !

!IceMergeListWrapper methodsFor: 'testing' stamp: ''!
icon

	^ item value icon! !

!IceMergeListWrapper methodsFor: 'morphic-compatibility' stamp: ''!
actualClass
	
	^ self item value actualClass! !

!IceMergeListWrapper methodsFor: 'testing' stamp: ''!
contents
	"Answer the contents of the change from the model."

	^ item children collect: [ :each | IceMergeListWrapper with: each model: model ]! !

!IceMergeListWrapper methodsFor: 'accessing' stamp: ''!
preferredColor

	^ self item value preferredColor! !

!IceMergeListWrapper methodsFor: 'testing' stamp: ''!
isConflict
	
	^ item value isConflict! !

!IceMergeResolutionRequest methodsFor: 'exception description' stamp: ''!
defaultAction

	| window mergeMorph |
	mergeMorph := (IceTipMergeMorph forMerger: merge).

	mergeMorph
		fromDescription: merge sourceDescription;
		toDescription: merge targetDescription.

	window := mergeMorph newWindow
		title: 'Merge';
		yourself.

	window openModal.
	^ mergeMorph merged! !

!IceMergeResolutionRequest methodsFor: 'accessing' stamp: ''!
merger: anIceMerge 
	
	merge := anIceMerge! !

!IceMergeResolutionRequest methodsFor: 'accessing' stamp: ''!
merge
	^ merge! !

!IceMergeToChangeTreeVisitor commentStamp: ''!
I visit a tree of IceNode with IceOperationMerge with all operations already chosen and return the coresponding tree of changes (IceNodes with IceOperation)!
!IceMergeToChangeTreeVisitor methodsFor: 'visiting' stamp: ''!
visitPackage: anIcePackageDefinition
	self convertMergeNodeToChangeNode.
	self visitChildrenOf: currentNode! !

!IceMergeToChangeTreeVisitor methodsFor: 'utilities' stamp: ''!
convertMergeNodeToChangeNode
	currentNode value: currentNode value chosenOperation .! !

!IceMergeToChangeTreeVisitor methodsFor: 'visiting' stamp: ''!
visitClassDefinition: anIceClassDefinition 
	self convertMergeNodeToChangeNode.
	self visitChildrenOf: currentNode! !

!IceMergeToChangeTreeVisitor methodsFor: 'visiting' stamp: ''!
visitAddition: anIceAddition 
	self convertMergeNodeToChangeNode.! !

!IceMergeToChangeTreeVisitor methodsFor: 'visiting' stamp: ''!
visitRootDefinition: anIceRootDefinition 
	self visitChildrenOf: currentNode! !

!IceMergeToChangeTreeVisitor methodsFor: 'visiting' stamp: ''!
visitNoModification: anIceNoModification
	anIceNoModification definition accept: self.! !

!IceMergeToChangeTreeVisitor methodsFor: 'visiting' stamp: ''!
visitNonConflictingOperation: anIceNonConflictingOperation 
	anIceNonConflictingOperation chosenOperation accept: self.! !

!IceMergeWorkingCopyCommand commentStamp: ''!
I'm a command to perform a merge  of current image sources with head commit.!
!IceMergeWorkingCopyCommand methodsFor: 'execute' stamp: ''!
execute
	| commit |
	commit := self repository headCommit.
	commit merge.
	(self repository workingCopy referenceCommit = commit)
		ifTrue: [ self beSuccess ]! !

!IceMetacelloDuplicatedNotification methodsFor: 'accessing' stamp: ''!
defaultAction
    "Default for Upgrade is to allow"

	^ self useIncoming! !

!IceMetacelloDuplicatedNotification methodsFor: 'exception handling' stamp: ''!
useLoaded
	^ self resume: self builder addLocalRepository! !

!IceMetacelloDuplicatedNotification methodsFor: 'accessing' stamp: ''!
builder: anObject
	builder := anObject! !

!IceMetacelloDuplicatedNotification methodsFor: 'accessing' stamp: ''!
projectName
	
	^ builder locationToUse basename! !

!IceMetacelloDuplicatedNotification methodsFor: 'accessing' stamp: ''!
existingProjectRegistration

	| repository |
	repository := IceLibgitRepository new
		location: builder locationToUse.
	^ IceMetacelloProjectRegistration new
		version: repository head description;
		yourself! !

!IceMetacelloDuplicatedNotification methodsFor: 'accessing' stamp: ''!
newProjectRegistration

	^ IceMetacelloProjectRegistration new
		version: builder commitishName;
		yourself! !

!IceMetacelloDuplicatedNotification methodsFor: 'accessing' stamp: ''!
builder
	^ builder! !

!IceMetacelloDuplicatedNotification methodsFor: 'exception handling' stamp: ''!
useIncoming
	^ self resume: self builder addLocalRepositoryAndCheckout! !

!IceMetacelloLoadChoice commentStamp: ''!
I'm a recorded choice when installing a metacello baseline/configuration.
A choice is created whenever there is a conflict between two project versions (loaded and incomming). Due the nature of Matacello, this choice can be asked several times... A choice keeps track of what user selected to avoid asking him every time.!
!IceMetacelloLoadChoice methodsFor: 'testing' stamp: ''!
isChoiceBetween: firstOption and: secondOption

	^ (self optionA = firstOption)
		and: [ self optionB = secondOption ]! !

!IceMetacelloLoadChoice methodsFor: 'accessing' stamp: ''!
optionB: anObject
	optionB := anObject! !

!IceMetacelloLoadChoice methodsFor: 'accessing' stamp: ''!
optionA: anObject
	optionA := anObject! !

!IceMetacelloLoadChoice methodsFor: 'accessing' stamp: ''!
choosen: anObject
	choosen := anObject! !

!IceMetacelloLoadChoice methodsFor: 'accessing' stamp: ''!
projectName
	^ projectName! !

!IceMetacelloLoadChoice methodsFor: 'accessing' stamp: ''!
optionA
	^ optionA! !

!IceMetacelloLoadChoice methodsFor: 'accessing' stamp: ''!
projectName: anObject
	projectName := anObject! !

!IceMetacelloLoadChoice methodsFor: 'accessing' stamp: ''!
choosen
	^ choosen! !

!IceMetacelloLoadChoice methodsFor: 'accessing' stamp: ''!
optionB
	^ optionB! !

!IceMetacelloLoadSession commentStamp: ''!
I'm a metacello execution sesssion. 
I will be active during the context of a "metacello load" command, and it will be shared between all dependent baselines/configurations to be traversed in that execution.

Tipically, I will be used to keep some state needed during the full execution, like a choice of what whas selected when conflicting or upgraded versions acts.  !
!IceMetacelloLoadSession methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	choices := Set new! !

!IceMetacelloLoadSession methodsFor: 'accessing' stamp: ''!
recordChoice: anIceMetacelloLoadChoice
	
	^ choices add: anIceMetacelloLoadChoice! !

!IceMetacelloLoadSession methodsFor: 'accessing' stamp: ''!
recordChoiceProject: projectName optionA: optionA optionB: optionB ifAbsentAnswer: aBlock
	
	^ choices 
		detect: [ :each | 
			(each projectName = projectName)
			and: [ each isChoiceBetween: optionA and: optionB ] ]
		ifFound: [ :choice | choice choosen ]
		ifNone: [ | choosen |
			choosen := aBlock value.
			choosen ifNotNil: [  
				self recordChoice: (IceMetacelloLoadChoice new 
					projectName: projectName;
					optionA: optionA;
					optionB: optionB;
					choosen: choosen;
					yourself) ].
			choosen ]! !

!IceMetacelloLoadSessionContext commentStamp: ''!
I'm a dynamic variable to keep a load session.!
!IceMetacelloPharoPlatform commentStamp: ''!
I'm a class to add support for iceberg to metacello.!
!IceMetacelloPharoPlatform methodsFor: 'enumerating' stamp: ''!
withMetacelloLoadSessionDo: aBlock 
	| context |

	"Use current context or create a new one"
	context := IceMetacelloLoadSessionContext value 
		ifNil: [ IceMetacelloLoadSession new ].

	"pass it"
	IceMetacelloLoadSessionContext
		value: context 
		during: aBlock! !

!IceMetacelloPharoPlatform methodsFor: 'testing' stamp: ''!
canHandleType: type
	^ Iceberg enableMetacelloIntegration 
		and: [ IceMetacelloRepositoryType canHandleType: type ]! !

!IceMetacelloPharoPlatform methodsFor: 'repository creation' stamp: ''!
extractTypeFromDescription: description

	(description beginsWith: 'ftp://') ifTrue: [ ^'ftp' ].
	IceMetacelloRepositoryType allTypes 
		detect:  [ :each | each isSuitableForLocation: description  ] 
		ifFound: [ :class | ^ class type ].
	^ super extractTypeFromDescription: description! !

!IceMetacelloPharoPlatform methodsFor: 'repository creation' stamp: ''!
createRepository: aRepositorySpec
	(self canHandleType: aRepositorySpec type)
		ifTrue: [ ^ Iceberg mcRepositoryFor: aRepositorySpec description ].

	^ super createRepository: aRepositorySpec! !

!IceMetacelloPharoPlatform class methodsFor: 'initialization' stamp: ''!
initialize
	 self select! !

!IceMetacelloProjectRegistration commentStamp: ''!
I represent a project registration in iceberg. I adapt the behavior of metacello project registrations, containing a version.

For the moment I'm only used for compatibility reasons.!
!IceMetacelloProjectRegistration methodsFor: 'printing' stamp: ''!
locked
	"Only for compatibility for now"
	^ false! !

!IceMetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
version: aString 
	version := aString! !

!IceMetacelloProjectRegistration methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: version asString! !

!IceMetacelloRepositoryAdapter commentStamp: ''!
Adapter for allowing metacello to use Iceberg to download packages and versions.!
!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
addTo: aMCRepositoryGroup 
	"Do nothing, we do not need to register the repository into the monticello registry"! !

!IceMetacelloRepositoryAdapter methodsFor: 'comparing' stamp: ''!
= other
	^ other species = self species 
		and: [ other description = self description ]! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
getOrCreateIcebergRepository

	^ self repository! !

!IceMetacelloRepositoryAdapter methodsFor: 'comparing' stamp: ''!
hash
	"Not a good hash, but is copied from MCRepository"
	^ self description hash! !

!IceMetacelloRepositoryAdapter methodsFor: 'compatibility' stamp: ''!
isRemote
	"User for Komitter"
	^ false! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
commitIdFor: aWorkingCopy ifFound: aBlock

	self flag: #pharoTodo. "Do nothing?"! !

!IceMetacelloRepositoryAdapter methodsFor: 'querying' stamp: ''!
repositoryVersionString
	^ self repository workingCopy referenceCommit id! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
projectVersion: anObject
	projectVersion := anObject! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
projectVersion
	^ projectVersion! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
description
		
	^ self repository origin url, '[', projectVersion, ']'! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
repository

	^ repository! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
goferReferences
	
	self repository head description = projectVersion ifFalse: [ (self repository commitishNamed: projectVersion) checkoutWithStrategy: IceCheckoutDoNotLoadPackages new ].
	
	^ self repository workingCopy packages 
		collect: [ :package | 
			GoferResolvedReference 
				name: package latestVersion info name 
				repository: self ]! !

!IceMetacelloRepositoryAdapter methodsFor: 'compatibility' stamp: ''!
unregister

	^ MCRepositoryGroup default removeRepository: self! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
repoPath
	^ self repository subdirectory ! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
repositoryDescription
	^ self repository description
! !

!IceMetacelloRepositoryAdapter methodsFor: 'testing' stamp: ''!
hasNoLoadConflicts: anMCGitBasedRepository
	"Copied from MCGitBasedNetworkRepository"
  	(anMCGitBasedRepository isKindOf: self class) ifFalse: [ ^ false ].

	^ self projectPath = anMCGitBasedRepository projectPath and: [
		self repoPath = anMCGitBasedRepository repoPath and: [ 
			self projectVersion = anMCGitBasedRepository projectVersion ] ]! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
goferPriority
	^ 8! !

!IceMetacelloRepositoryAdapter methodsFor: 'MonticelloGUI' stamp: ''!
morphicOpen: workingCopy
	| shouldOpenIceberg |
	shouldOpenIceberg := UIManager default 
		confirm: ('{1} belongs to {2} and cannot be browsed here. 
Do you want to open the Iceberg Browser instead?' format: { workingCopy packageName. self repository name }) 
		label: 'Browsing an iceberg repository'
		trueChoice: 'Open' 
		falseChoice: 'Cancel'
		cancelChoice: nil
		default: true.
	shouldOpenIceberg ifFalse: [ ^ self ].
	IceTipRepositoriesBrowser new openWithSpec! !

!IceMetacelloRepositoryAdapter methodsFor: 'initialization' stamp: ''!
flushForScriptGet
	"do nothing"! !

!IceMetacelloRepositoryAdapter methodsFor: 'compatibility' stamp: ''!
isCache
	"User for Kommiter and Versionner"
	^ false! !

!IceMetacelloRepositoryAdapter methodsFor: 'versions' stamp: ''!
versionFrom: aVersionName 
	| packageName package version |
	packageName := (MCFileTreeRepository parseName: aVersionName) first.
	package := self repository packageNamed: packageName.
	
	version := package latestVersion.
	version info name = aVersionName ifFalse: [
		version := package versions detect: [ :ver | ver info name = aVersionName ]].
	
	^ version mcVersion
	
	
	
	! !

!IceMetacelloRepositoryAdapter methodsFor: 'testing' stamp: ''!
isValid
	^ true! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
projectPath
	^ self repository origin projectPath! !

!IceMetacelloRepositoryAdapter methodsFor: 'testing' stamp: ''!
canUpgradeTo: anMCGitBasedRepository 
  (anMCGitBasedRepository isKindOf: self class) ifFalse: [ ^ false ].

  ^ self projectPath = anMCGitBasedRepository projectPath 
	and: [ self repoPath = anMCGitBasedRepository repoPath and: [ self projectVersion = anMCGitBasedRepository projectVersion ]]! !

!IceMetacelloRepositoryAdapter methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceMetacelloRepositoryAdapter class methodsFor: 'instance creation' stamp: ''!
for: anIceRepository withVersion: aString 

	| projectVersion |
		
	projectVersion := aString isEmptyOrNil 
		ifTrue: [ anIceRepository head description ]
		ifFalse: [ aString ].

	^ self new 
		repository: anIceRepository;
		projectVersion: projectVersion;
		yourself! !

!IceMetacelloRepositoryType commentStamp: ''!
I'm a base class to provide different type of MCRepositories from iceberg, so metacello can do his work of installing packages.
My children define specific types, visit them to have more details of what you can do.!
!IceMetacelloRepositoryType methodsFor: 'accessing' stamp: ''!
mcRepository
	self subclassResponsibility! !

!IceMetacelloRepositoryType methodsFor: 'accessing' stamp: ''!
location
	^ location! !

!IceMetacelloRepositoryType methodsFor: 'initialization' stamp: ''!
initializeLocation: aString
	location := aString.
	self initialize! !

!IceMetacelloRepositoryType class methodsFor: 'accessing' stamp: ''!
allTypes

	^ self allSubclasses reject: [ :each | each isAbstract ]! !

!IceMetacelloRepositoryType class methodsFor: 'testing' stamp: ''!
isSuitableForType: aType
	^ self type = aType! !

!IceMetacelloRepositoryType class methodsFor: 'instance creation' stamp: ''!
for: aLocationString
	^ (self allTypes
		detect: [ :each | each isSuitableForLocation: aLocationString ])
		location: aLocationString! !

!IceMetacelloRepositoryType class methodsFor: 'private' stamp: ''!
location: aLocationString
	self = IceMetacelloRepositoryType 
		ifTrue: [ self error: 'I''m an abstract class, use one of my children instead.' ].
	
	^ self basicNew
		initializeLocation: aLocationString;
		yourself! !

!IceMetacelloRepositoryType class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = IceMetacelloRepositoryType! !

!IceMetacelloRepositoryType class methodsFor: 'testing' stamp: ''!
canHandleType: aType 

	^ self allTypes
		anySatisfy: [ :each | each isSuitableForType: aType ]  
	! !

!IceMetacelloRepositoryType class methodsFor: 'private' stamp: ''!
extractTypeOf: aString 

	^ aString copyUpTo: $:! !

!IceMetacelloRepositoryType class methodsFor: 'testing' stamp: ''!
isSuitableForLocation: aLocationString
	^ self isSuitableForType: (self extractTypeOf: aLocationString) ! !

!IceMetacelloRepositoryType class methodsFor: 'accessing' stamp: ''!
type
	^ self subclassResponsibility! !

!IceMetaclassDependency commentStamp: ''!
I am a dependency to a metaclass.!
!IceMetaclassDependency methodsFor: 'visiting' stamp: ''!
isDependencyTo: anIceClassDefinition
	^ anIceClassDefinition basicName = definition basicName! !

!IceMetaclassDependency methodsFor: 'dependencies' stamp: ''!
addTransitiveDependenciesFrom: anIceDiff to: anIceCherrypicker
	IceNodeQuery new
		on: anIceDiff tree;
		className: definition name;
		execute;
		ifFound:
				[ :anIceNode | anIceCherrypicker addClassDependencyOf: anIceNode value definition ]! !

!IceMetaclassDependency methodsFor: 'accessing' stamp: ''!
definition: anIceClassDefinition
	definition:= anIceClassDefinition ! !

!IceMetaclassDependency methodsFor: 'accessing' stamp: ''!
definition
	^ definition! !

!IceMetadatalessFileTreeWriter commentStamp: ''!
I can write metadataless filetree versions from an ice formed version.!
!IceMetadatalessFileTreeWriter methodsFor: 'accessing' stamp: ''!
snapshotWriterClass
	^ IceMetadatalessStCypressWriter! !

!IceMetadatalessFileTreeWriter methodsFor: 'visiting' stamp: ''!
writeVersion: aVersion
	"We have to do that to avoid writing the version info."

	| members |
	directory := (members := MCFileTreeRepository
		parseName: aVersion info name) last.
	self deleteExistingPackageStructureFor: members.
	self fileUtils ensureDirectoryExists: self packageFileDirectory.
	self initializePackageFileDirectoryCache.
	self writeFormat.
	self writePackage: aVersion package.
	self writeDefinitions: aVersion.
	aVersion dependencies do: [ :ea | self writeVersionDependency: ea ]! !

!IceMetadatalessFileTreeWriter class methodsFor: 'writing' stamp: ''!
fileOut: aVersion on: aStream
	(self on: aStream) writeVersion: aVersion! !

!IceMetadatalessStCypressWriter commentStamp: ''!
I can write filetree metadataless versions of a snapshot.!
!IceMetadatalessStCypressWriter methodsFor: 'writing' stamp: ''!
writeDefinitions: aCollection
	| classDirExtension extensionClasses extensionMethodDefinitions extensionMethodMap methodHolders |
	self writeBasicDefinitions: aCollection.
	extensionClasses := OrderedCollection new.
	extensionMethodDefinitions := OrderedCollection new.
	methodHolders := self classDefinitions , self traitDefinitions.
	self methodDefinitions
		keysAndValuesDo:
			[ :className :extensionMethods | 
			methodHolders
				at: className
				ifAbsent:
					[ extensionClasses add: className.
					extensionMethodDefinitions addAll: extensionMethods ] ].
	extensionClasses
		do: [ :className | self methodDefinitions removeKey: className ].
	self
		writeMethodHolderDefinitions: self traitDefinitions
		extension: '.trait'
		to: ''
		do:
			[ :definition :classPath | self writeTraitDefinition: definition to: classPath ].
	self
		writeMethodHolderDefinitions: self classDefinitions
		extension: '.class'
		to: ''
		do:
			[ :definition :classPath | self writeClassDefinition: definition to: classPath ].
	classDirExtension := '.extension'.
	extensionMethodMap := Dictionary new.
	extensionMethodDefinitions
		do:
			[ :methodDefinition | 
			| classPath |
			(extensionMethodMap
				at: methodDefinition className
				ifAbsent:
					[ extensionMethodMap
						at: methodDefinition className
						put: OrderedCollection new ]) add: methodDefinition.
			classPath := methodDefinition className , classDirExtension
				, self fileUtils pathNameDelimiter asString.
			self writeExtensionClassDefinition: methodDefinition to: classPath ].
	extensionMethodMap
		keysAndValuesDo:
			[ :className :classMethodDefinitions | 
			| classPath filenameMetaMap |
			filenameMetaMap := self fileNameMapFor: classMethodDefinitions.
			classMethodDefinitions
				do:
					[ :methodDefinition | 
					| filename methodPath |
					filename := (filenameMetaMap at: methodDefinition classIsMeta)
						at: methodDefinition selector.
					classPath := methodDefinition className , classDirExtension
						, self fileUtils pathNameDelimiter asString.
					methodPath := classPath
						,
							(methodDefinition classIsMeta
								ifTrue: [ 'class' ]
								ifFalse: [ 'instance' ])
						, self fileUtils pathNameDelimiter asString.
					self
						writeMethodDefinition: methodDefinition
						to: methodPath
						filename: filename ] ]! !

!IceMetadatalessStCypressWriter methodsFor: 'writing' stamp: ''!
writeTraitDefinition: definition to: classPath
	self
		writeInDirectoryName: classPath
		fileName: 'README'
		extension: '.md'
		visit: [ self writeClassComment: definition ].
	self
		writeInDirectoryName: classPath
		fileName: 'properties'
		extension: self propertyFileExtension
		visit: [ self writeTraitDefinition: definition ]! !

!IceMetadatalessStCypressWriter methodsFor: 'writing' stamp: ''!
writeMethodProperties: classMethodDefinitions
	"We don't want to write that."

	self shouldNotImplement! !

!IceMetadatalessStCypressWriter methodsFor: 'writing' stamp: ''!
writeClassDefinition: definition to: classPath
	self
		writeInDirectoryName: classPath
		fileName: 'README'
		extension: '.md'
		visit: [ self writeClassComment: definition ].
	self
		writeInDirectoryName: classPath
		fileName: 'properties'
		extension: self propertyFileExtension
		visit: [ self writeClassDefinition: definition ]! !

!IceMetadatalessStCypressWriter class methodsFor: 'writing' stamp: ''!
on: aStream
	^ self new stream: aStream! !

!IceMethodContainerDefinition commentStamp: ''!
I am an abstract class representing an IceDefinition that is a container of methods. I.e., a class, a trait or an extension.

I have a name which is the name of the container I represent. If I'm meta-side, I add to my name a suffix class. For example: Integer class.

I also contain the monticello definition that corresponds to me.

See my super/subclasses for more information.!
!IceMethodContainerDefinition methodsFor: 'patching' stamp: ''!
asMCDefinition

	^ mcDefinition! !

!IceMethodContainerDefinition methodsFor: 'accessing' stamp: ''!
isMeta: anObject
	isMeta := anObject! !

!IceMethodContainerDefinition methodsFor: 'accessing' stamp: ''!
key
	
	^ super key , (self isMeta ifTrue: [ ' class' ] ifFalse: [ '' ])! !

!IceMethodContainerDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
browse
	
	| browsed |
	browsed := Smalltalk globals at: name.
	browsed isMeta ifTrue: [ browsed classSide ].
	browsed browse! !

!IceMethodContainerDefinition methodsFor: 'accessing' stamp: ''!
isMeta
	^ isMeta! !

!IceMethodContainerDefinition methodsFor: 'converting' stamp: ''!
asMCDefinitionWithoutMetaSide
	
	self subclassResponsibility! !

!IceMethodContainerDefinition methodsFor: 'accessing' stamp: ''!
name
	^ name , (isMeta ifTrue: [ ' class' ] ifFalse: [ '' ])! !

!IceMethodContainerDefinition methodsFor: 'accessing' stamp: ''!
name: aString

	name := aString! !

!IceMethodContainerDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
canBeBrowsed
	
	^ Smalltalk globals includesKey: name! !

!IceMethodContainerDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
actualClass
	
	| actualClass |
	actualClass := Smalltalk globals at: name.
	^ isMeta ifTrue: [ actualClass classSide ] ifFalse: [ actualClass ]! !

!IceMethodContainerDefinition methodsFor: 'accessing' stamp: ''!
contents
	mcDefinition ifNil: [ ^ '' ].
	^ self isMeta
		ifFalse: [ mcDefinition fullDefinitionString ]
		ifTrue: [ mcDefinition classDefinitionString ]! !

!IceMethodContainerDefinition methodsFor: 'patching' stamp: ''!
removeFrom: aPatcher
	
	aPatcher removeClass: self! !

!IceMethodContainerDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
canBrowseReferences
	
	^ self canBeBrowsed! !

!IceMethodContainerDefinition methodsFor: 'patching' stamp: ''!
mcDefinition: aMCDefinition

	mcDefinition := aMCDefinition! !

!IceMethodContainerDefinition class methodsFor: 'instance creation' stamp: ''!
named: aString isMeta: isMeta
	
	^ self new
		name: aString;
		isMeta: isMeta;
		yourself! !

!IceMethodDefinition commentStamp: ''!
I represent a method read from an Iceberg repository, either from a commit or from the working directory in disk.

My contents is the code of the method.

See my superclasses for more information.!
!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
classIsMeta: anObject
	classIsMeta := anObject! !

!IceMethodDefinition methodsFor: 'comparing' stamp: ''!
= anotherDefinition
	"A method can be equal and belong to another class (and be in the other side). 
	 And yes, even if this usually should not happen, it happens (and not always is incorrect)"
	^ super = anotherDefinition 
		and: [ self className = anotherDefinition className 
		and: [ self classIsMeta = anotherDefinition classIsMeta ] ]! !

!IceMethodDefinition methodsFor: 'patching' stamp: ''!
asMCDefinition

	^ MCMethodDefinition 
		className: self className
		classIsMeta: self classIsMeta
		selector: self name
		category: self protocol
		timeStamp: ''
		source: sourceCode! !

!IceMethodDefinition methodsFor: 'actions' stamp: ''!
install
	
	self asMCDefinition load! !

!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
ownerName
	
	^ className! !

!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
sourceCode: aString

	sourceCode := aString! !

!IceMethodDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	
	^ self iconNamed: #changeUpdate! !

!IceMethodDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
canBeBrowsed
	
	^ self contextClass
		ifNotNil: [ :class | class includesSelector: name ]
		ifNil: [ false ]! !

!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
contents

	^ '"', self protocol, '"
', sourceCode! !

!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
protocol: anObject
	protocol := anObject! !

!IceMethodDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
canBrowseReferences
	
	^ false! !

!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
className

	^ className! !

!IceMethodDefinition methodsFor: 'patching' stamp: ''!
removeFromPatcher: aMCPatcher 
	
	aMCPatcher removeDefinition: self asMCDefinition! !

!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
classIsMeta
	^ classIsMeta! !

!IceMethodDefinition methodsFor: 'morphic - compatibility' stamp: ''!
isLoadable
	^ self contextClass notNil! !

!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
selector
	
	^ name! !

!IceMethodDefinition methodsFor: 'morphic - compatibility' stamp: ''!
contextClass
	
	| class |
	class := Smalltalk globals at: self className ifAbsent: [ ^ nil ].
	self classIsMeta ifTrue: [ class := class classSide ].
	^ class! !

!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
className: anObject
	className := anObject! !

!IceMethodDefinition methodsFor: 'patching' stamp: ''!
addToPatcher: aMCPatcher 
	
	aMCPatcher addDefinition: self asMCDefinition! !

!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
protocol
	^ protocol! !

!IceMethodDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
browse
	
	(self contextClass >> name) browse! !

!IceMethodDefinition methodsFor: 'testing' stamp: ''!
isMethodDefinition
	
	^ true! !

!IceMethodDefinition methodsFor: 'morphic - compatibility' stamp: ''!
actualClass

	^ self contextClass! !

!IceMethodDefinition methodsFor: 'patching' stamp: ''!
removeFrom: aPatcher
	
	aPatcher removeMethod: self! !

!IceMethodDefinition methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitMethodNode: self! !

!IceMethodDefinition methodsFor: 'accessing' stamp: ''!
sourceCode

	^ sourceCode! !

!IceMethodDefinition class methodsFor: 'instance creation' stamp: ''!
className: aClassName classIsMeta: classIsMeta protocol: protocol name: aString sourceCode: source

	^ (self named: aString)
		className: aClassName;
		classIsMeta: classIsMeta;
		protocol: protocol;
		sourceCode: source;
		yourself! !

!IceMethodDependency commentStamp: ''!
I am a dependency to a method.!
!IceMethodDependency methodsFor: 'testing' stamp: ''!
isDependencyTo: anIceMethodDefinition

	^ 	anIceMethodDefinition isMethodDefinition and: [ 
		anIceMethodDefinition asMCDefinition className = definition className and: [ 
		anIceMethodDefinition asMCDefinition selector = definition selector ] ]! !

!IceMethodDependency methodsFor: 'comparing' stamp: ''!
= anObject
	^ super = anObject
		and: [ definition asMCDefinition selector = anObject definition asMCDefinition selector ]! !

!IceMethodDependency methodsFor: 'dependencies' stamp: ''!
referencedTraits
	
	"The method cannot diferenciate if the reference is a trait or a class, so I try both"
	^ self referencedClasses ! !

!IceMethodDependency methodsFor: 'comparing' stamp: ''!
hash
	^ super hash bitXor: definition asMCDefinition className hash! !

!IceMethodDependency methodsFor: 'dependencies' stamp: ''!
referencedClasses

	^ self referencedNames , {definition className}! !

!IceMethodDependency methodsFor: 'dependencies' stamp: ''!
methodAST
	^ RBParser parseMethod: definition asMCDefinition source! !

!IceMethodDependency methodsFor: 'dependencies' stamp: ''!
referencedNames
	^ (self methodAST allChildren select: #isVariable) collect: #name! !

!IceMethodDependency methodsFor: 'dependencies' stamp: ''!
referencedPackages
	^ { }! !

!IceMethodDependency methodsFor: 'testing' stamp: ''!
addTransitiveDependenciesFrom: anIceDiff to: anIceCherrypicker
	super addTransitiveDependenciesFrom: anIceDiff to: anIceCherrypicker.

	self referencedSelectors
		do: [ :aSelector | 
			IceNodeQuery new
				on: anIceDiff tree;
				selector: aSelector;
				execute;
				ifFound: [ :anIceNode | anIceCherrypicker addDependency: (anIceNode accept: IceAsDependencyVisitor new  )] ]! !

!IceMethodDependency methodsFor: 'computing - dependencies' stamp: ''!
referencedSelectors
	
	^ (self methodAST allChildren select: #isMessage) collect: #selector! !

!IceMissingRepositoryEntry commentStamp: ''!
Directory does not exist in the specified version in the repository.!
!IceMissingRepositoryEntry methodsFor: 'accessing' stamp: ''!
owner: anObject
	owner := anObject! !

!IceMissingRepositoryEntry methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!IceMissingRepositoryEntry methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!IceMissingRepositoryEntry methodsFor: 'accessing' stamp: ''!
owner
	^ owner! !

!IceMissingRepositoryEntry methodsFor: 'accessing' stamp: ''!
messageText
	^ self name! !

!IceModification commentStamp: ''!
I am a modification in a tree. I contain the definition I'm changing (right) and the new (left) version of the definition. I know what is the icon for modification and how to calculate a conflict with other operations.!
!IceModification methodsFor: 'accessing' stamp: ''!
oldDefinition
	
	^ oldNode! !

!IceModification methodsFor: 'comparing' stamp: ''!
= anotherOperation

	^ super = anotherOperation
		and: [ self rightDefinition = anotherOperation rightDefinition ]! !

!IceModification methodsFor: 'accessing' stamp: ''!
leftContents
	
	^ definition contents! !

!IceModification methodsFor: 'accessing' stamp: ''!
oldNode: aNode
	
	oldNode := aNode! !

!IceModification methodsFor: 'testing' stamp: ''!
isModification
	
	^ true! !

!IceModification methodsFor: 'accessing' stamp: ''!
key
	
	^ definition key! !

!IceModification methodsFor: 'merging' stamp: ''!
mergeWithLeftModification: anIceModification 
	
	"If the modification is the same, I can just keep any of them."
	anIceModification leftDefinition = self leftDefinition 
		ifTrue: [ ^ IceNonConflictingOperation operation: anIceModification ].
		
	^ IceConflictingOperation left: anIceModification right: self! !

!IceModification methodsFor: 'merging' stamp: ''!
mergeWithLeftRemoval: anIceRemoval 
	
	^ IceConflictingOperation left: anIceRemoval right: self! !

!IceModification methodsFor: 'accessing' stamp: ''!
description
	
	^ definition name! !

!IceModification methodsFor: 'accessing' stamp: ''!
oldNode
	
	^ oldNode! !

!IceModification methodsFor: 'accessing' stamp: ''!
rightContents
	
	^ oldNode contents! !

!IceModification methodsFor: 'accessing' stamp: ''!
rightDefinition: aDefinition
	
	oldNode := aDefinition! !

!IceModification methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	
	^ self iconNamed: #changeUpdate! !

!IceModification methodsFor: 'merging' stamp: ''!
mergeWithLeftAddition: anIceAddition 
	
	"This should not happen. If I represent a modification of a node, that means that the original definition existed on the base version.
	Thus, the right version can never ADD an already existing version. It can remove it or modify it."
	self shouldNotImplement! !

!IceModification methodsFor: 'accessing' stamp: ''!
rightDefinition
	
	^ oldNode! !

!IceModification methodsFor: 'operations' stamp: ''!
inverse
	
	^ IceModification left: self rightDefinition right: self leftDefinition! !

!IceModification methodsFor: 'merging' stamp: ''!
mergeWithLeftNoOperation: anIceNoModification 
	
	^ IceNonConflictingOperation operation: self! !

!IceModification methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitModification: self! !

!IceModification methodsFor: 'merging' stamp: ''!
mergeWithOperation: anOperation
	
	^ anOperation mergeWithLeftModification: self! !

!IceModification class methodsFor: 'instance creation' stamp: ''!
left: leftDefinition right: rightDefinition

	^ self new
		leftDefinition: leftDefinition;
		rightDefinition: rightDefinition;
		yourself! !

!IceNoCommit commentStamp: ''!
I am a null object representing the absence of a commit. I'm used generally in the case of unborn branches, or when a package was loaded but no iceberg information is available.!
!IceNoCommit methodsFor: 'private - monticello' stamp: ''!
mcCommit

	"This method is just for compatibility.
	I shold be used only in case of commit to an unborn branch"
	
	^ MCVersion new! !

!IceNoCommit methodsFor: 'comparing' stamp: ''!
= aNoCommit

	^ aNoCommit isNoCommit! !

!IceNoCommit methodsFor: 'API - changes' stamp: ''!
changesFromCommit: anIceNoCommit 
	
	^ anIceNoCommit changesFromNoCommit: self! !

!IceNoCommit methodsFor: 'API - changes' stamp: ''!
changesFromNoCommit: anIceNoCommit 
	
	^ #()! !

!IceNoCommit methodsFor: 'API - changes' stamp: ''!
commonAncestorWith: aCommitish

	^ aCommitish! !

!IceNoCommit methodsFor: 'accessing - file' stamp: ''!
fileSystem
	
	"This should belong to a Git specific No-Commit only..."
	^ FileSystem memory root! !

!IceNoCommit methodsFor: 'comparing' stamp: ''!
hash

	^ self class hash! !

!IceNoCommit methodsFor: 'testing' stamp: ''!
isAncestorOf: aCommit

	^ false! !

!IceNoCommit methodsFor: 'testing' stamp: ''!
isParentOf: aCommit
	
	^ false! !

!IceNoCommit methodsFor: 'testing' stamp: ''!
isUnknownCommit
	
	^ false! !

!IceNoCommit methodsFor: 'printing' stamp: ''!
description
	
	^ 'No code loaded'! !

!IceNoCommit methodsFor: 'accessing' stamp: ''!
repository

	^ repository! !

!IceNoCommit methodsFor: 'testing' stamp: ''!
isLoaded
	
	^ false! !

!IceNoCommit methodsFor: 'private - changes' stamp: ''!
changedPackagesToCommitInfo: anIceGitCommit
	
	^ anIceGitCommit packages! !

!IceNoCommit methodsFor: 'API - packages' stamp: ''!
packageNames
	
	^ #()! !

!IceNoCommit methodsFor: 'API - project' stamp: ''!
project

	^ repository newUnbornProject! !

!IceNoCommit methodsFor: 'private - monticello' stamp: ''!
snapshotFor: anIceSavedPackage 
	
	^ MCSnapshot empty! !

!IceNoCommit methodsFor: 'API - packages' stamp: ''!
includesPackageNamed: aName
	
	^ false! !

!IceNoCommit methodsFor: 'API - properties' stamp: ''!
writerClass

	^ self properties writerClass! !

!IceNoCommit methodsFor: 'API - changes' stamp: ''!
changesTo: aCommitish

	^ aCommitish changesFromNoCommit: self! !

!IceNoCommit methodsFor: 'accessing' stamp: ''!
commit
	
	^ self! !

!IceNoCommit methodsFor: 'testing' stamp: ''!
isNoCommit

	^ true! !

!IceNoCommit methodsFor: 'accessing' stamp: ''!
repository: aRepository

	repository := aRepository! !

!IceNoCommit class methodsFor: 'instance creation' stamp: ''!
repository: aRepository

	^ self new
		repository: aRepository;
		yourself! !

!IceNoCommitMessage commentStamp: ''!
I indicate when a commit will be performed without a message comment.
This is usually possible, but bad, very bad. Do not do it.!
!IceNoCommitMessage methodsFor: 'accessing' stamp: ''!
messageText
	^ messageText ifNil: [ self class defaultMessageText ]! !

!IceNoCommitMessage methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor
	aVisitor visitNoCommitMessage: self! !

!IceNoCommitMessage class methodsFor: 'accessing' stamp: ''!
defaultMessageText
	^ 'You are trying to commit without a message!!
When this is possible, is not a good practice.'! !

!IceNoModification commentStamp: ''!
I am a no modification in a tree. I am useful to represent a container (that did not change) containing elements that did change. I contain the definition I represent to be able to show it. I delegate the icon to my definition and I know how to calculate a conflict with other operations.!
!IceNoModification methodsFor: 'accessing' stamp: ''!
leftContents
	
	^ definition contents! !

!IceNoModification methodsFor: 'merging' stamp: ''!
mergeWithLeftModification: anIceModification 
	
	^ IceNonConflictingOperation operation: anIceModification! !

!IceNoModification methodsFor: 'merging' stamp: ''!
mergeWithLeftRemoval: anIceRemoval
	
	"We assume that if I'm in the operation tree this means my children have modifications.
	So a removal of a tree with modifications should be a conflict.
	
	This should maybe be enhanced: if my children are removals maybe this should not be a conflict, but this is the simplest solution right now."
	^ IceConflictingOperation left: anIceRemoval right: self! !

!IceNoModification methodsFor: 'testing' stamp: ''!
isNoModification
	
	^ true! !

!IceNoModification methodsFor: '*Iceberg-TipUI' stamp: ''!
icon

	^ definition icon! !

!IceNoModification methodsFor: 'merging' stamp: ''!
mergeWithLeftAddition: anIceAddition 
	
	"This should not happen. If I represent a no modification of a node, that means that the original definition existed on the base version.
	Thus, the right version can never ADD an already existing version. It can remove it or modify it."
	self shouldNotImplement! !

!IceNoModification methodsFor: 'operations' stamp: ''!
inverse
	
	^ self! !

!IceNoModification methodsFor: 'merging' stamp: ''!
mergeWithLeftNoOperation: anIceNoModification 
	
	"There was no modifications on both sides, I can just return the left side"
	^ IceNonConflictingOperation operation: anIceNoModification! !

!IceNoModification methodsFor: 'testing' stamp: ''!
hasChanges
	
	^ false! !

!IceNoModification methodsFor: 'testing' stamp: ''!
isConflict
	^ false! !

!IceNoModification methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitNoModification: self! !

!IceNoModification methodsFor: 'merging' stamp: ''!
mergeWithOperation: anOperation
	
	^ anOperation mergeWithLeftNoOperation: self! !

!IceNoRemoteBranch commentStamp: ''!
The operation you tried (for example push) requires that your branch has a configured upstream (something like origin/branchName), but is has none.!
!IceNode commentStamp: ''!
I am a tree implementation used for diffing and merging.

I work by composition and not inheritance. My users should use the values of the node (kept in the #value instance variable) and not subclass myself.
Each node stores its child nodes in a dictionary, indexed by a key.

Tree API:
 - #/ access to children
 - #path get the path of the current node in the tree
 - #parent get the parent node of the current node
 - #rootNode get the root node of the current tree
 - #children get the children of the current node
 - #keys, #keysDo:, #includesKey: enumerate the keys of the node
 - #at:put, #childAt:ifAbsentPut:, #childAt:ifPresent:
 - #resolve:, #resolve:ifAbsent: resolve a path in the current node
 - #replaceBy: replaces the current node by another node
 - #replace:with: replaces the given child node by another node

Enumerating API:
 - #allSatisfy:
 - #anySatisfy:
 - #collect:
 - #detect:
 - #select:
 - #count:
 - #do:

Visiting API:
 - visit:!
!IceNode methodsFor: 'evaluating' stamp: ''!
value: aValue
 
	value := aValue! !

!IceNode methodsFor: 'adding' stamp: ''!
addTo: anotherNode
	
	anotherNode addNode: self! !

!IceNode methodsFor: 'comparing' stamp: ''!
hash

	^ self key hash! !

!IceNode methodsFor: 'accessing' stamp: ''!
/ aString 
	
	^ childrenDictionary at: aString! !

!IceNode methodsFor: 'accessing' stamp: ''!
children
	
	^ childrenDictionary values sorted: [ :a :b | a key < b key ]! !

!IceNode methodsFor: 'accessing' stamp: ''!
description
	
	^ value description! !

!IceNode methodsFor: 'enumerating' stamp: ''!
nextNodeSuchThat: conditionBlock ifNone: noneBlock
	
	self children do: [ :each |
		(conditionBlock value: each)
			ifTrue: [ ^ each ].
		each
			nextNodeSuchThat: conditionBlock
			ifFound: [ :found | ^ found  ] ].
	
	^ self parent
		nextChildNodeStartingFrom: self
		suchThat: conditionBlock
		ifNone: noneBlock! !

!IceNode methodsFor: 'enumerating' stamp: ''!
do: aBlockClosure 
	
	aBlockClosure value: self value.
	self childrenDo: [ :node | node do: aBlockClosure ]! !

!IceNode methodsFor: 'enumerating' stamp: ''!
nextChildNodeStartingFrom: anIceNode suchThat: conditionBlock ifNone: noneBlock 
	
	| aCollection |
	aCollection := self children.
	(aCollection indexOf: anIceNode) + 1
		to: aCollection size do: [ :index | | item |
			item := aCollection at: index.
			(conditionBlock value: item)
				ifTrue: [ ^ item ].
			item
				nextNodeSuchThat: conditionBlock
				ifFound: [ :found | ^ found ] ].
	
	self parent ifNil: [^ noneBlock value ].
	
	^ self parent
		nextChildNodeStartingFrom: self
		suchThat: conditionBlock
		ifNone: noneBlock! !

!IceNode methodsFor: 'adding' stamp: ''!
addNode: aNode

	self at: aNode key put: aNode.
	^ aNode! !

!IceNode methodsFor: 'enumerating' stamp: ''!
count: aBlockClosure 
	
	| count |
	count := 0.
	(aBlockClosure value: self value)
		ifTrue: [ count := 1 ].
	
	self childrenDo: [ :each | count := count + (each count: aBlockClosure) ].
	^ count! !

!IceNode methodsFor: 'enumerating' stamp: ''!
collect: aBlock
	| newNode |
	newNode := self class value: (aBlock value: self value).
	self childrenDo: [ :e |
		newNode addNode: (e collect: aBlock) ].
	^ newNode! !

!IceNode methodsFor: 'testing' stamp: ''!
hasChanges
	
	^ value hasChanges or: [ self children anySatisfy: [ :child | child hasChanges ] ]! !

!IceNode methodsFor: 'accessing' stamp: ''!
childAt: aString ifAbsentPut: aBlock

	^ childrenDictionary
		  at: aString
		  ifAbsent: [ self addChild: aBlock value ]! !

!IceNode methodsFor: 'accessing' stamp: ''!
path
	
	^ RelativePath withAll: self allPathSegments! !

!IceNode methodsFor: 'enumerating' stamp: ''!
firstNodeSuchThat: conditionBlock ifNone: noneBlock
	
	(conditionBlock value: self)
		ifTrue: [ ^ self ].
	
	self
		nextNodeSuchThat: conditionBlock
		ifFound: [ :found | ^ found ].
	
	^ self parent
		ifNil: noneBlock
		ifNotNil: [
			self parent
				nextChildNodeStartingFrom: self
				suchThat: conditionBlock
				ifNone: noneBlock ]! !

!IceNode methodsFor: 'comparing' stamp: ''!
basicEqualsTo: aNode

	^ self value = aNode value! !

!IceNode methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	childrenDictionary := Dictionary new! !

!IceNode methodsFor: 'accessing' stamp: ''!
at: aString put: aNode 
	
	aNode parent: self.
	childrenDictionary at: aString put: aNode! !

!IceNode methodsFor: 'accessing' stamp: ''!
key
	
	^ value key! !

!IceNode methodsFor: 'testing' stamp: ''!
hasParent
	
	^ self parent notNil! !

!IceNode methodsFor: 'enumerating' stamp: ''!
anySatisfy: aBlockClosure 
	
	(aBlockClosure value: self value)
		ifTrue: [ ^ true ].
		
	self childrenDo: [ :e |
		(e anySatisfy: aBlockClosure)
			ifTrue: [ ^ true ] ].

	^ false! !

!IceNode methodsFor: 'enumerating' stamp: ''!
nextNodeSuchThat: conditionBlock ifFound: foundBlock 
	
	self children do: [ :each |
		(conditionBlock value: each)
			ifTrue: [ ^ foundBlock value: each ].
		each
			nextNodeSuchThat: conditionBlock
			ifFound: [ :found | ^  foundBlock value: found  ] ].! !

!IceNode methodsFor: 'accessing' stamp: ''!
withAllParentNodes

	self hasParent ifFalse: [ ^ #() ].
	self parent hasParent ifFalse: [ ^ { self } ].
	^ self parent withAllParentNodes copyWith: self! !

!IceNode methodsFor: 'accessing' stamp: ''!
resolve: aRelativePath ifAbsent: aBlock
	
	^ self resolve: aRelativePath ifPresent: [ :each | each ] ifAbsent: aBlock! !

!IceNode methodsFor: 'accessing' stamp: ''!
definition
	
	^ value definition! !

!IceNode methodsFor: 'accessing' stamp: ''!
includesKey: anObject
	
	^ childrenDictionary includesKey: anObject! !

!IceNode methodsFor: '*Iceberg-TipUI' stamp: ''!
gtInspectorItemsIn: composite
	<gtInspectorPresentationOrder: 0>
	^ composite fastTable 
		title: 'Items';
		display: [ self children ];
		column: 'Key' evaluated: [:each | each key ] width: 200 * self currentWorld displayScaleFactor;
		column: 'Value' evaluated: [:each | each value ] width: 400 * self currentWorld displayScaleFactor! !

!IceNode methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ childrenDictionary isEmpty! !

!IceNode methodsFor: 'comparing' stamp: ''!
= anotherNode

	^ (self basicEqualsTo: anotherNode)
		and: [ self children asSet = anotherNode children asSet ]! !

!IceNode methodsFor: 'accessing' stamp: ''!
resolve: aRelativePath ifPresent: presentBlock ifAbsent: absentBlock 	
	| segments node |
	segments := aRelativePath segments.
	
	segments ifEmpty: [ ^ presentBlock value: self value ].
	
	node := childrenDictionary at: segments first ifAbsent: [^ absentBlock value ].
	
	^node
		resolve: (RelativePath withAll: segments allButFirst) 
		ifPresent: presentBlock
		ifAbsent: absentBlock! !

!IceNode methodsFor: 'accessing' stamp: ''!
resolve: aRelativePath 
	
	^ self resolve: aRelativePath ifAbsent: [ NotFound signalFor: aRelativePath ]! !

!IceNode methodsFor: 'accessing' stamp: ''!
keys

	^ childrenDictionary keys! !

!IceNode methodsFor: 'enumerating' stamp: ''!
select: aBlock

	| selectedChildren newNode |
	selectedChildren := self children collect: [ :childNode | 
		childNode select: aBlock ].
	
	((selectedChildren anySatisfy: [ :each | each isEmptyNode not ])
		or: [ aBlock value: self value ])
			ifFalse: [ ^ IceEmptyNode new ].
		
	newNode := self class value: self value.
	selectedChildren do: [ :e |
		e addTo: newNode ].
	^ newNode! !

!IceNode methodsFor: 'accessing' stamp: ''!
keysDo: aBlockClosure 
	
	childrenDictionary keysDo: aBlockClosure! !

!IceNode methodsFor: 'testing' stamp: ''!
isEmptyNode

	^ false! !

!IceNode methodsFor: 'enumerating' stamp: ''!
collectWithPath: aBlock
	| newNode |
	newNode := self class value: (aBlock value: self value value: self path).
	self childrenDo: [ :each |
		newNode addNode: (each collectWithPath: aBlock) ].
	^ newNode! !

!IceNode methodsFor: 'accessing' stamp: ''!
parent: anObject
	
	parent := anObject! !

!IceNode methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream
		nextPutAll: 'IceNode(';
		nextPutAll: self key asString;
		nextPutAll: ')'! !

!IceNode methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!IceNode methodsFor: 'accessing' stamp: ''!
replace: oldNode with: newNode
	
	self assert: oldNode name = newNode name.
	childrenDictionary at: oldNode name put: newNode! !

!IceNode methodsFor: 'accessing' stamp: ''!
replaceBy: aNode 
	
	parent replace: self with: aNode! !

!IceNode methodsFor: 'removing' stamp: ''!
removeChild: anIceNode 
	
	childrenDictionary removeKey: anIceNode key! !

!IceNode methodsFor: 'accessing' stamp: ''!
rootNode
	
	^ self parent rootNode! !

!IceNode methodsFor: 'accessing' stamp: ''!
allPathSegments

	^ self withAllParentNodes collect: [ :each | each key ]! !

!IceNode methodsFor: 'enumerating' stamp: ''!
mergeWith: anotherTree onLeft: leftBlock onRight: rightBlock onMerge: mergeBlock
	
	| mergedTree newNode |
	mergedTree := mergeBlock value: self value value: anotherTree value.
	newNode := self class value: mergedTree.
		
	self keysDo: [ :key |
		(anotherTree includesKey: key)
			ifTrue:  [ | childNode | 
				childNode := (self / key)
					mergeWith: anotherTree / key
					onLeft: leftBlock
					onRight: rightBlock
					onMerge: mergeBlock.
				childNode addTo: newNode ]
			ifFalse: [ 
				newNode addNode: ((self / key) collect: leftBlock) ] ].

	anotherTree keysDo: [ :key |
		(self includesKey: key)
			ifFalse: [ 
				newNode addNode: ((anotherTree / key) collect: rightBlock) ] ].

	^ newNode! !

!IceNode methodsFor: 'accessing' stamp: ''!
childAt: aString ifPresent: aBlockClosure

	^ childrenDictionary at: aString ifPresent: aBlockClosure! !

!IceNode methodsFor: 'enumerating' stamp: ''!
mergeWith: anotherTree onMerge: mergeBlock
	
	^ self
		mergeWith: anotherTree
		onLeft: [ :each | each ]
		onRight:  [ :each | each ]
		onMerge: mergeBlock! !

!IceNode methodsFor: 'evaluating' stamp: ''!
value
	
	^ value! !

!IceNode methodsFor: 'adding' stamp: ''!
addChild: aChild
	
	^ self addNode: (self class value: aChild).! !

!IceNode methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitTreeNode: self! !

!IceNode methodsFor: 'enumerating' stamp: ''!
allSatisfy: aBlockClosure 
	
	(aBlockClosure value: self value)
		ifFalse: [ ^ false ].
		
	self childrenDo: [ :e |
		(e allSatisfy: aBlockClosure)
			ifFalse: [ ^ false ] ].

	^ true! !

!IceNode methodsFor: 'enumerating' stamp: ''!
detect: aBlock
	^ (self firstNodeSuchThat: aBlock) value! !

!IceNode class methodsFor: 'instance creation' stamp: ''!
value: aValue
	
	^ self new
		value: aValue;
		yourself! !

!IceNode class methodsFor: 'instance creation' stamp: ''!
value: aValue parent: aParentNode 
	
	^ (self value: aValue)
		parent: aParentNode;
		yourself! !

!IceNodeCodeDisplayVisitor commentStamp: ''!
I am a IceNode (containing an IceOperationMerge) visitor meant to update a SpCodePresenter
 with the highlighted code.!
!IceNodeCodeDisplayVisitor methodsFor: 'visiting' stamp: ''!
visitPackage: anIcePackageDefinition

	codePresenter
		text: '';
		behavior: nil! !

!IceNodeCodeDisplayVisitor methodsFor: 'accessing' stamp: ''!
codePresenter

	^ codePresenter! !

!IceNodeCodeDisplayVisitor methodsFor: 'visiting' stamp: ''!
visitClassDefinition: anIceClassDefinition

	codePresenter text: anIceClassDefinition contents.
	codePresenter behavior: nil! !

!IceNodeCodeDisplayVisitor methodsFor: 'visiting' stamp: ''!
visitMethodNode: anIceMethodDefinition

	codePresenter
		text: anIceMethodDefinition sourceCode;
		behavior:
			(anIceMethodDefinition className asClassIfAbsent: [ 
					 UndefinedObject ])! !

!IceNodeCodeDisplayVisitor methodsFor: 'accessing' stamp: ''!
codePresenter: aSpCodePresenter

	codePresenter := aSpCodePresenter! !

!IceNodeCodeDisplayVisitor methodsFor: 'visiting' stamp: ''!
visitConflictingOperation: anIceConflictingOperation

	anIceConflictingOperation chosenOperation definition accept: self! !

!IceNodeCodeDisplayVisitor methodsFor: 'visiting' stamp: ''!
visitNonConflictingOperation: anIceNonConflictingOperation

	anIceNonConflictingOperation definition accept: self! !

!IceNodeCodeDisplayVisitor class methodsFor: 'instance creation' stamp: ''!
onCodePresenter: aSpCodePresenter
	^ self new
		codePresenter: aSpCodePresenter ;
		yourself! !

!IceNodeQuery commentStamp: ''!
I am a IceNode (and IceDefinition) visitor that can detect a code entity in the tree.!
!IceNodeQuery methodsFor: 'visiting' stamp: ''!
initialize

	super initialize.
	results := Set new! !

!IceNodeQuery methodsFor: 'visiting' stamp: ''!
visitRemoval: anIceRemoval
	anIceRemoval definition accept: self.
	self visitChildrenOf: currentNode! !

!IceNodeQuery methodsFor: 'building' stamp: ''!
className: aString 
	
	entityName := aString! !

!IceNodeQuery methodsFor: 'building' stamp: ''!
on: anIceNode 
	
	root := anIceNode! !

!IceNodeQuery methodsFor: 'building' stamp: ''!
packageName: aString
	entityName := aString! !

!IceNodeQuery methodsFor: 'building' stamp: ''!
selector: aSelector 
	
	selector := aSelector! !

!IceNodeQuery methodsFor: 'visiting' stamp: ''!
visitAddition: anIceAddition 
	
	anIceAddition definition accept: self.
	self visitChildrenOf: currentNode.! !

!IceNodeQuery methodsFor: 'executing' stamp: ''!
execute
	
	root accept: self! !

!IceNodeQuery methodsFor: 'visiting' stamp: ''!
visitClassDefinition: anIceClassDefinition 
	
	anIceClassDefinition asMCDefinition className = entityName ifTrue: [ results add: currentNode ].! !

!IceNodeQuery methodsFor: 'visiting' stamp: ''!
visitExtensionDefinition: anIceExtensionDefinition
	anIceExtensionDefinition name = entityName
		ifTrue: [ results add: currentNode ].! !

!IceNodeQuery methodsFor: 'visiting' stamp: ''!
visitTraitDefinition: anIceTraitDefinition 
	
	anIceTraitDefinition asMCDefinition className = entityName ifTrue: [ results add: currentNode ].! !

!IceNodeQuery methodsFor: 'visiting' stamp: ''!
visitMethodNode: anIceMethodDefinition 

	anIceMethodDefinition asMCDefinition selector = selector ifTrue: [ results add: currentNode ].! !

!IceNodeQuery methodsFor: 'building' stamp: ''!
traitName: aString 
	
	entityName := aString! !

!IceNodeQuery methodsFor: 'visiting' stamp: ''!
visitModification: anIceModification 

	anIceModification definition accept: self.
	self visitChildrenOf: currentNode.! !

!IceNodeQuery methodsFor: 'querying' stamp: ''!
ifFound: aBlockClosure 

	results do: aBlockClosure ! !

!IceNodeQuery methodsFor: 'visiting' stamp: ''!
visitNoModification: anIceNoModification

	"Nothing with me. Just visit children"
	self visitChildrenOf: currentNode! !

!IceNodeQuery methodsFor: 'visiting' stamp: ''!
visitPackage: anIcePackageDefinition
	anIcePackageDefinition name = entityName
		ifTrue: [ results add: currentNode ]! !

!IceNonConflictingOperation commentStamp: ''!
I reprensent a non-conflict between two operations that can be solved automatically. The user can still override the automatic choice using #selectLeft and #selectRight.!
!IceNonConflictingOperation methodsFor: 'accessing' stamp: ''!
leftContents
	
	^ operation leftContents! !

!IceNonConflictingOperation methodsFor: 'morphic - compatibility' stamp: ''!
contextClass
	
	^ operation contextClass! !

!IceNonConflictingOperation methodsFor: 'accessing' stamp: ''!
key
	
	"Any of my operations should have the same key"
	^ operation key! !

!IceNonConflictingOperation methodsFor: 'resolution' stamp: ''!
selectRight
	
	chosen := operation inverse! !

!IceNonConflictingOperation methodsFor: 'accessing' stamp: ''!
description
	
	"Any of my instances should have the same description"
	^ operation description! !

!IceNonConflictingOperation methodsFor: 'accessing' stamp: ''!
rightContents
	
	^ operation rightContents! !

!IceNonConflictingOperation methodsFor: 'accessing' stamp: ''!
chosenOperation
	
	^ chosen
		ifNil: [ operation ]
		ifNotNil: [ chosen ]! !

!IceNonConflictingOperation methodsFor: 'resolution' stamp: ''!
isRightChosen
	
	^ chosen = operation inverse! !

!IceNonConflictingOperation methodsFor: 'resolution' stamp: ''!
isLeftChosen
	
	^ chosen = operation! !

!IceNonConflictingOperation methodsFor: 'morphic - compatibility' stamp: ''!
actualClass
	
	^ operation definition actualClass! !

!IceNonConflictingOperation methodsFor: 'accessing' stamp: ''!
definition
	
	"This is just for compatibility"
	^ operation definition! !

!IceNonConflictingOperation methodsFor: '*Iceberg-TipUI' stamp: ''!
preferredColor
	
	^ self isResolved
		ifTrue: [ Color gray ]
		ifFalse: [ nil ]! !

!IceNonConflictingOperation methodsFor: 'accessing' stamp: ''!
operation: anIceModification 
	operation := anIceModification! !

!IceNonConflictingOperation methodsFor: 'resolution' stamp: ''!
selectLeft
	
	chosen := operation! !

!IceNonConflictingOperation methodsFor: 'testing' stamp: ''!
isConflict

	^ false! !

!IceNonConflictingOperation methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitNonConflictingOperation: self! !

!IceNonConflictingOperation methodsFor: '*Iceberg-TipUI' stamp: ''!
operationIcon
	
	^ operation icon! !

!IceNonConflictingOperation class methodsFor: 'instance creation' stamp: ''!
operation: anOperation
	
	^ self new
		operation: anOperation;
		yourself! !

!IceNonInteractiveCredentialsProvider commentStamp: ''!
A credentials provider that retrieves defaults or throws exceptions (but do not interacts with the user)!
!IceNonInteractiveCredentialsProvider methodsFor: 'private' stamp: ''!
obtainPlaintextCredentials: response
	"Maybe I can read a file here?"
	LGitNoCredentialsProvided signal! !

!IceNonInteractiveCredentialsProvider methodsFor: 'private' stamp: ''!
obtainSshCredentials: response
	"Maybe I can read a file here?"
	LGitNoCredentialsProvided signal! !

!IceNonInteractiveCredentialsProvider methodsFor: 'private' stamp: ''!
obtainCredentials: response
	"Maybe I can read a file here?"
	LGitNoCredentialsProvided signal! !

!IceNothingToCommit commentStamp: ''!
I indicate when there is nothing to commit (and you tried to do it)!
!IceNothingToCommit methodsFor: 'visiting' stamp: ''!
acceptError: anObject
	anObject visitNothingToCommitError: self! !

!IceNullCommitWalk methodsFor: 'accessing' stamp: ''!
commitsDo: aBlock 
	"Do nothing. A null commit does not has any commits to walk."! !

!IceNullCommitWalk methodsFor: 'accessing' stamp: ''!
commits
	"A null commit walk has no commits"
	^ #()! !

!IceOperation commentStamp: ''!
I represent a merge operation. I know how to install myself in the system, how to inverse myself and how to show the definitions I'm being applied to. Check my subclasses for more information.!
!IceOperation methodsFor: 'comparing' stamp: ''!
= anotherOperation

	^ self species = anotherOperation species
		and: [ self leftDefinition = anotherOperation leftDefinition ]! !

!IceOperation methodsFor: 'comparing' stamp: ''!
hash
	^ self leftDefinition hash! !

!IceOperation methodsFor: 'operations' stamp: ''!
install
	
	self leftDefinition install! !

!IceOperation methodsFor: 'merging' stamp: ''!
mergeWithLeftModification: anIceModification 
	
	^ self subclassResponsibility! !

!IceOperation methodsFor: 'accessing' stamp: ''!
description
	
	^ definition name! !

!IceOperation methodsFor: 'accessing' stamp: ''!
rightContents
	
	^ definition contents! !

!IceOperation methodsFor: 'accessing' stamp: ''!
printOn: aStream

	super printOn: aStream .
	aStream nextPutAll: '( ';
	print: definition ;
	nextPutAll: ' )'.! !

!IceOperation methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	
	self subclassResponsibility! !

!IceOperation methodsFor: '*Iceberg-TipUI' stamp: ''!
canBeBrowsed
	
	^ self leftDefinition canBeBrowsed! !

!IceOperation methodsFor: '*Iceberg-TipUI' stamp: ''!
preferredColor

	"Use the default color"
	^ nil! !

!IceOperation methodsFor: 'merging' stamp: ''!
mergeWithLeftNoOperation: anIceNoModification 
	
	^ self subclassResponsibility! !

!IceOperation methodsFor: 'testing' stamp: ''!
hasChanges
	
	^ true! !

!IceOperation methodsFor: '*Iceberg-TipUI' stamp: ''!
canBrowseReferences
	
	^ false! !

!IceOperation methodsFor: 'accessing' stamp: ''!
leftDefinition: aNode

	definition := aNode! !

!IceOperation methodsFor: 'accessing' stamp: ''!
leftContents
	
	self subclassResponsibility! !

!IceOperation methodsFor: 'testing' stamp: ''!
isResolved
	
	^ false! !

!IceOperation methodsFor: 'accessing' stamp: ''!
leftDefinition

	^ definition! !

!IceOperation methodsFor: 'testing' stamp: ''!
isModification
	
	^ false! !

!IceOperation methodsFor: 'morphic - compatibility' stamp: ''!
contextClass
	
	^ definition contextClass! !

!IceOperation methodsFor: 'accessing' stamp: ''!
key
	
	^ definition key! !

!IceOperation methodsFor: 'merging' stamp: ''!
mergeWithLeftRemoval: anIceRemoval 
	
	self subclassResponsibility! !

!IceOperation methodsFor: '*Iceberg-TipUI' stamp: ''!
browse
	
	^ self leftDefinition browse! !

!IceOperation methodsFor: 'testing' stamp: ''!
isRemoval
	
	^ false! !

!IceOperation methodsFor: 'accessing' stamp: ''!
definition: aDefinition

	definition := aDefinition! !

!IceOperation methodsFor: 'testing' stamp: ''!
isNoModification
	
	^ false! !

!IceOperation methodsFor: 'merging' stamp: ''!
mergeWithLeftAddition: anIceAddition 
	
	self subclassResponsibility! !

!IceOperation methodsFor: 'accessing' stamp: ''!
name
	
	^ definition name! !

!IceOperation methodsFor: 'accessing' stamp: ''!
definition
	^ definition! !

!IceOperation methodsFor: 'operations' stamp: ''!
inverse
	
	self subclassResponsibility! !

!IceOperation methodsFor: 'testing' stamp: ''!
isAddition
	
	^ false! !

!IceOperation methodsFor: 'testing' stamp: ''!
isConflict
	^false.! !

!IceOperation methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	self subclassResponsibility! !

!IceOperation methodsFor: 'merging' stamp: ''!
mergeWithOperation: anOperation
	
	self subclassResponsibility! !

!IceOperation class methodsFor: 'instance creation' stamp: ''!
definition: aDefinition
	
	^ self new
		definition: aDefinition;
		yourself! !

!IceOperationMerge commentStamp: ''!
I represent a merge between two operations. I know if I'm a conflict or not, if I have changes, and the user can use me to resolve a conflict.!
!IceOperationMerge methodsFor: 'accessing' stamp: ''!
leftContents
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'testing' stamp: ''!
isResolved
	
	^ chosen notNil! !

!IceOperationMerge methodsFor: 'morphic - compatibility' stamp: ''!
isLoadable
	^ false! !

!IceOperationMerge methodsFor: 'morphic - compatibility' stamp: ''!
contextClass
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'accessing' stamp: ''!
key
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'resolution' stamp: ''!
selectRight
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'accessing' stamp: ''!
description
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'accessing' stamp: ''!
rightContents
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'accessing' stamp: ''!
chosenOperation
	
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'resolution' stamp: ''!
isRightChosen
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'resolution' stamp: ''!
isLeftChosen
	self subclassResponsibility! !

!IceOperationMerge methodsFor: '*Iceberg-TipUI' stamp: ''!
icon

	self isRightChosen ifTrue: [ ^ self iconNamed: #changeBlock ].
	self isLeftChosen ifTrue: [ ^ self iconNamed: #forward ].
	
	^ self operationIcon! !

!IceOperationMerge methodsFor: 'resolution' stamp: ''!
clearSelection
	
	chosen := nil! !

!IceOperationMerge methodsFor: 'morphic - compatibility' stamp: ''!
actualClass
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'accessing' stamp: ''!
definition
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'resolution' stamp: ''!
selectLeft
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'testing' stamp: ''!
hasChanges

	^ self chosenOperation hasChanges! !

!IceOperationMerge methodsFor: 'testing' stamp: ''!
isConflict
	self subclassResponsibility! !

!IceOperationMerge methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ self subclassResponsibility! !

!IceOperationMerge methodsFor: '*Iceberg-TipUI' stamp: ''!
operationIcon
	self subclassResponsibility! !

!IcePackage commentStamp: ''!
Can give information about a package that is saved in a repository, for example: 
- isLoaded if the package has been loaded into the image.
- isModified if the package has local changes to be commited
- incomingCommits information about commits in the repository that are newer than the version loaded into the image.
!
!IcePackage methodsFor: 'comparing' stamp: ''!
= another
	^ self species = another species 
		and: [ self repository = another repository 
		and: [ self name = another name ]]
! !

!IcePackage methodsFor: 'comparing' stamp: ''!
hash
	^ self name hash! !

!IcePackage methodsFor: 'accessing - monticello' stamp: ''!
currentCommits
	
	^ repository workingCopy referenceCommits! !

!IcePackage methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IcePackage methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: self class name.
	self printDescriptionOn: aStream! !

!IcePackage methodsFor: 'testing' stamp: ''!
isLoaded
	
	^ repository workingCopy isLoadedPackageNamed: self packageName! !

!IcePackage methodsFor: 'actions' stamp: ''!
reload
	self load! !

!IcePackage methodsFor: 'accessing - monticello' stamp: ''!
mcWorkingCopy

	^ self isLoaded ifTrue: [
		self mcPackage workingCopy ]! !

!IcePackage methodsFor: 'accessing' stamp: ''!
packageName
	^ package! !

!IcePackage methodsFor: 'accessing - monticello' stamp: ''!
metacelloBaselineName

	^ self name allButFirst: self metacelloBaselinePrefix size! !

!IcePackage methodsFor: 'loading' stamp: ''!
isClean

	^ self isDirty not! !

!IcePackage methodsFor: 'testing' stamp: ''!
isExported

	^ repository isPackageExported: self! !

!IcePackage methodsFor: 'TOMOVE' stamp: ''!
latestVersion
	
	^ self versionFor: self repository head commit! !

!IcePackage methodsFor: 'accessing - monticello' stamp: ''!
isMetacelloBaseline
	
	^ self name beginsWith: self metacelloBaselinePrefix! !

!IcePackage methodsFor: 'querying' stamp: ''!
outgoingCommits
	^ self repository branch outgoingCommits: [ :walk | walk modifyingPackage: self ]
! !

!IcePackage methodsFor: 'accessing - monticello' stamp: ''!
mcSnapshotInRepository
	"Answer a version of the package as it is present on repository. 
	 Useful to browse non-loaded packages."
	^ self repository branch snapshotFor: self! !

!IcePackage methodsFor: 'loading' stamp: ''!
load
	
	self repository workingCopy loadPackageNamed: self name! !

!IcePackage methodsFor: 'querying' stamp: ''!
loadedVersion
	^ self repository workingCopy versionFor: self! !

!IcePackage methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	isDirty := false! !

!IcePackage methodsFor: 'accessing' stamp: ''!
package: anObject
	package := anObject! !

!IcePackage methodsFor: 'testing' stamp: ''!
isModified
	
	^ self isDirty! !

!IcePackage methodsFor: 'loading' stamp: ''!
beClean

	isDirty := false! !

!IcePackage methodsFor: '*Iceberg-Adapters' stamp: ''!
directoryName

	^ self repository directoryNameForPackage: self! !

!IcePackage methodsFor: 'accessing - monticello' stamp: ''!
metacelloBaselinePrefix
	
	^ 'BaselineOf'! !

!IcePackage methodsFor: 'actions' stamp: ''!
unload

	repository workingCopy unloadPackage: self! !

!IcePackage methodsFor: 'accessing - monticello' stamp: ''!
currentCommit
	
	^ repository workingCopy referenceCommit! !

!IcePackage methodsFor: 'querying' stamp: ''!
versions
	"Return all versions of this package in the current branch, latest first. 
	Containing info in the repo makes it easier to refresh."
	^ self repository branch versionsFor: self
! !

!IcePackage methodsFor: 'printing' stamp: ''!
printDescriptionOn: aStream
	aStream nextPut: $(;
		nextPutAll: package;
		nextPutAll: ', ';
		nextPutAll: (self isLoaded ifTrue: 'loaded' ifFalse: 'not loaded');
		nextPut: $)! !

!IcePackage methodsFor: 'loading' stamp: ''!
isDirty

	^ self isLoaded and: [isDirty ifNil: [ isDirty := false ]]! !

!IcePackage methodsFor: 'accessing' stamp: ''!
name
	^ package! !

!IcePackage methodsFor: 'actions' stamp: ''!
remove
	"Removes the package from the repository.
	Does not unload from the image"
	repository workingCopy basicRemovePackage: self! !

!IcePackage methodsFor: 'querying' stamp: ''!
versionFor: aCommitId
	^ aCommitId commit versionFor: self! !

!IcePackage methodsFor: '*Iceberg-TipUI' stamp: ''!
browse
	
	(RPackageOrganizer default packageNamed: self name) browse! !

!IcePackage methodsFor: 'accessing' stamp: ''!
beDirty: aBoolean
	
	isDirty := aBoolean! !

!IcePackage methodsFor: 'accessing - monticello' stamp: ''!
mcPackage
	
	^ MCPackage named: self packageName! !

!IcePackage methodsFor: 'loading' stamp: ''!
beDirty

	isDirty := true! !

!IcePackage methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!IcePackage methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IcePackage methodsFor: 'versions' stamp: ''!
versionLike: selectBlock ifNone: ifNoneBlock
	"Return all versions of this package in the current branch, latest first. 
	Containing info in the repo makes it easier to refresh."
	^ self repository branch 
		versionsFor: self 
		detect: selectBlock 
		ifNone: ifNoneBlock 
! !

!IcePackage class methodsFor: 'instance creation' stamp: ''!
named: packageName repository: repository
	^ self new 
		package: packageName;
		repository: repository; 
		yourself! !

!IcePackageDefinition commentStamp: ''!
I represent a package inside the iceberg repository. How I am built depends on the repository format (e.g., tonel or filetree).

My contents are the tags defined in the package.

See my superclasses for more information.!
!IcePackageDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
canBrowseReferences
	
	^ false! !

!IcePackageDefinition methodsFor: 'accessing' stamp: ''!
asMCDefinition
	
	^ MCOrganizationDefinition categories: categories! !

!IcePackageDefinition methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	categories := #()! !

!IcePackageDefinition methodsFor: 'accessing' stamp: ''!
categories
	^ categories! !

!IcePackageDefinition methodsFor: 'testing' stamp: ''!
isPackageDefinition
	
	^ true! !

!IcePackageDefinition methodsFor: 'patching' stamp: ''!
addModification: anIceModification toPatcher: aMCPatcher 

	"In MC there is no such thing as a MCPackage definition.
	Instead, we should manage organization definitions.
	The problem is that they have no identity: they do not know the package they belong to.
	Then, if we just apply this modification, we end up just adding a new definition (and having both).
	To solve this, we remove the old organization and add the new one explicitly."

	aMCPatcher removeDefinition: anIceModification rightDefinition asMCDefinition.
	^ aMCPatcher addDefinition: anIceModification leftDefinition asMCDefinition! !

!IcePackageDefinition methodsFor: 'patching' stamp: ''!
addToPatcher: aPatcher
	
	aPatcher addDefinition: (MCOrganizationDefinition categories: categories)! !

!IcePackageDefinition methodsFor: 'accessing' stamp: ''!
path: aRelativePath 
	
	path := aRelativePath! !

!IcePackageDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	^ self iconNamed: #package! !

!IcePackageDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
canBeBrowsed
	
	^ RPackage organizer includesPackageNamed: name! !

!IcePackageDefinition methodsFor: 'accessing' stamp: ''!
contents
	
	^ String streamContents: [ :stream |
		stream nextPutAll:	'Package tags: '.
		categories do: [ :elem | 
			stream nextPutAll: String crlf;
				nextPutAll: String tab;
				nextPutAll: elem.
	]]! !

!IcePackageDefinition methodsFor: 'accessing' stamp: ''!
categories: aCollection

	categories := aCollection! !

!IcePackageDefinition methodsFor: 'operations' stamp: ''!
removeFrom: aVisitor 
	aVisitor removePackage: self! !

!IcePackageDefinition methodsFor: 'accessing' stamp: ''!
package
	
	^ package! !

!IcePackageDefinition methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitPackage: self! !

!IcePackageDefinition methodsFor: 'accessing' stamp: ''!
path
	^ path! !

!IcePackageDefinition methodsFor: 'patching' stamp: ''!
removeFromPatcher: aPatcher
	
	aPatcher removeDefinition: (MCOrganizationDefinition categories: categories)! !

!IcePackageDependency commentStamp: ''!
I am a dependency to a package.!
!IcePackageDependency methodsFor: 'testing' stamp: ''!
isDependencyTo: anIcePackageDefinition
	^ definition name = anIcePackageDefinition name! !

!IcePackageDependency methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ definition name = anObject definition name! !

!IcePackageDependency methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ definition name hash! !

!IcePackageDependency methodsFor: 'dependencies' stamp: ''!
addTransitiveDependenciesFrom: anIceDiff to: anIceCherrypicker 
	"No transitive dependencies of a package"! !

!IcePackageDependency methodsFor: 'accessing' stamp: ''!
definition: aIcePackageDefinition
	definition := aIcePackageDefinition! !

!IcePackageDependency methodsFor: 'accessing' stamp: ''!
definition 
	^ definition ! !

!IcePackageLoaded commentStamp: ''!
I announce when a package has been loaded.!
!IcePackageLoaded methodsFor: 'accessing' stamp: ''!
loadedVersion
	^ loadedVersion! !

!IcePackageLoaded methodsFor: 'accessing' stamp: ''!
loadedVersion: anObject
	loadedVersion := anObject! !

!IcePackageLoaded class methodsFor: 'instance creation' stamp: ''!
version: version 
	^ self new loadedVersion: version! !

!IcePackageUnloaded commentStamp: ''!
I announce when a package has been unloaded.!
!IcePharoPlugin methodsFor: 'events' stamp: ''!
fetchIfNeeded: aRepository

	(aRepository lookupCommit: SystemVersion current commitHash) isUnknownCommit
		ifFalse: [ ^ self ].

	UIManager default
		informUser: 'Fetching incoming commits'
		during: [ aRepository remotes
				detect: [ :each | each projectName = 'pharo-project' ]
				ifFound: [ :each | each fetch ] ]! !

!IcePharoPlugin methodsFor: 'events' stamp: ''!
repositoryWasCreated: aRepository
! !

!IcePharoPlugin methodsFor: 'events' stamp: ''!
repositoryWillBeCreated: aRepository
	SystemVersion current major < 7 ifTrue: [ ^ self ].
	
	self fetchIfNeeded: aRepository.
	(aRepository lookupCommit: SystemVersion current commitHash) adopt.! !

!IcePharoPlugin class methodsFor: 'accessing - commits' stamp: ''!
icebergCommitHash

	^ self
		  getCommitishOfProject: 'Iceberg'
		  owner: 'pharo-vcs'
		  repository: 'iceberg'! !

!IcePharoPlugin class methodsFor: 'accessing - commits' stamp: ''!
tonelCommitHash

	^ self
		  getCommitishOfProject: 'Tonel'
		  owner: 'pharo-vcs'
		  repository: 'tonel'! !

!IcePharoPlugin class methodsFor: 'adding' stamp: ''!
addPharoProjectToIceberg
	"It will take all packages corresponding to Pharo project and it will create an iceberg 
	 project with it"

	self 
		addProjectNamed: 'pharo' 
		commit: self pharoCommitHash 
		baselines: #(
			BaselineOfAthens
			BaselineOfBasicTools
			BaselineOfDisplay
			BaselineOfFlashback
			BaselineOfIDE
			BaselineOfMonticello
			BaselineOfMenuRegistration
			BaselineOfMetacello
			BaselineOfMorphic
			BaselineOfMorphicCore 
			BaselineOfPharo
			BaselineOfPharoBootstrap
			BaselineOfSUnit
			BaselineOfShift 
			BaselineOfSpec
			BaselineOfSpec2
			BaselineOfNewTools
			BaselineOfTraits
			BaselineOfUI    
			BaselineOfUnifiedFFI).! !

!IcePharoPlugin class methodsFor: 'adding' stamp: ''!
addIcebergProjectToIceberg

	self
		addProjectNamed: 'iceberg'
		commit: self icebergCommitHash
		baselines: #( BaselineOfIceberg ).

	self
		addProjectNamed: 'libgit2-pharo-bindings'
		commit: self libgitCommitHash
		baselines: #( BaselineOfLibGit ).		
	
	self
		addProjectNamed: 'tonel'
		commit: self tonelCommitHash
		baselines: #( BaselineOfTonel ).		
! !

!IcePharoPlugin class methodsFor: 'accessing - commits' stamp: ''!
libgitCommitHash

	^ self
		  getCommitishOfProject: 'LibGit'
		  owner: 'pharo-vcs'
		  repository: 'libgit2-pharo-bindings'! !

!IcePharoPlugin class methodsFor: 'accessing - commits' stamp: ''!
getCommitishOfProject: projectName owner: owner repository: repository

	| shortHash |

	"We need to get the short hash from Metacello"
	shortHash := (MetacelloProjectRegistration registry registrations 
		              detect: [ :e | e projectName = projectName ])
		             versionInfo versionString.

	"We need to get the full hash from github api"

	^ (IceGitHubAPI new
		   getCommit: shortHash
		   owner: owner
		   project: repository) at: #sha! !

!IcePharoPlugin class methodsFor: 'accessing - commits' stamp: ''!
pharoCommitHash

	^ SystemVersion current commitHash! !

!IcePharoPlugin class methodsFor: 'adding' stamp: ''!
addProjectNamed: aName commit: aCommitId baselines: aCollection
	| repository commit workingCopy |

	repository := IceLibgitRepository new
		name: aName;
		yourself.
	
	commit := IceUnknownCommit new 
		repository: repository;
		id: aCommitId;
	 	yourself.

	workingCopy := IceWorkingCopy basicNew
		repository: repository;
		initialize;
		referenceCommit: commit;
		project: ((IceBasicProject onRepository: repository)
			sourceDirectory: 'src';
			yourself);
		yourself.

	repository workingCopy: workingCopy.
	
	(aCollection 
		flatCollect: [ :each | (Smalltalk globals at: each) allPackageNames copyWith: each ] 
		as: Set)
		do: [ :each | 
			repository workingCopy basicAddPackage: (IcePackage
				named: each
				repository: repository) ].

	repository register! !

!IcePharoPlugin class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository

	^ aRepository remotes anySatisfy: [ :each | each projectName = 'pharo' ]! !

!IcePlaintextCredentials commentStamp: ''!
In addition to my base I have a one time token as well.!
!IcePlaintextCredentials methodsFor: '*Iceberg-TipUI' stamp: ''!
editModelClass
	^ IceTipEditPlaintextCredentialsModel ! !

!IcePlaintextCredentials methodsFor: 'testing' stamp: ''!
isPresent
	^ self username isEmpty not and: [ self password isEmpty not ]! !

!IcePlaintextCredentials methodsFor: 'printing' stamp: ''!
description
	^ 'User: ' , username! !

!IcePlaintextCredentials methodsFor: 'accessing' stamp: ''!
password: anObject
	password := anObject! !

!IcePlaintextCredentials methodsFor: 'accessing' stamp: ''!
password
	^ password ifNil: [ password := '' ]! !

!IcePlaintextCredentials methodsFor: 'printing' stamp: ''!
hostDescription
	^ host! !

!IcePlaintextCredentials methodsFor: '*Iceberg-TipUI' stamp: ''!
askForModelClass
	^ IceTipAskForPlaintextCredentialsModel ! !

!IcePlaintextCredentials methodsFor: 'accessing' stamp: ''!
username: anObject
	username := anObject! !

!IcePlaintextCredentials methodsFor: 'instance creation' stamp: ''!
readFrom: credentials
	self username: credentials username.
	self password: credentials password! !

!IcePlaintextCredentials methodsFor: 'API - storing' stamp: ''!
removeFrom: aStore 
	
	aStore removePlainTextCredential: self! !

!IcePlaintextCredentials methodsFor: 'accessing' stamp: ''!
type
	^ 'Plain Text'! !

!IcePlaintextCredentials methodsFor: 'accessing' stamp: ''!
username
	^ username ifNil: [ username := '' ]! !

!IcePlaintextCredentials methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
applyToRequest: aRequest
	aRequest
		username: self username password: self password! !

!IcePlaintextOtpCredentials commentStamp: ''!
In addition to my base I have a one time token as well.!
!IcePlaintextOtpCredentials methodsFor: 'accessing' stamp: ''!
token
	^token! !

!IcePlaintextOtpCredentials methodsFor: '*Iceberg-TipUI' stamp: ''!
askForModelClass
	^ IceTipAskForPlaintextOtpCredentialsModel ! !

!IcePlaintextOtpCredentials methodsFor: 'accessing' stamp: ''!
token: aToken
	token := aToken! !

!IcePlaintextOtpCredentials methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
applyToRequest: aRequest
	super applyToRequest: aRequest.
	self token ifNotNil: [:aToken |
		aRequest headerAt: 'X-Github-OTP' put: aToken ].! !

!IcePlugin commentStamp: ''!
I'm a base for all kind of plugins. 
I can define 

- repositoryActions (actions that will be added to IceRepositoriesBrowser, repositories section)
- ... (TBD)!
!IcePlugin methodsFor: 'events' stamp: ''!
repositoryWasCreated: aRepository
	"Hook. Allows plugins to do an action when a repository is created"
! !

!IcePlugin methodsFor: 'events' stamp: ''!
repositoryWillBeCreated: aRepository
	"Hook. Allows plugins to do an action when a repository will be added"
! !

!IcePlugin methodsFor: 'accessing - ui' stamp: ''!
checkoutBranchPanelsOnModel: anIceTipCachedModel 

	"Hook for subclasses"
	^ #()! !

!IcePlugin class methodsFor: 'testing' stamp: ''!
allAvailableFor: aRepository
	^ self allSubclasses select: [ :each | each isAvailableFor: aRepository ]
! !

!IcePlugin class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IcePlugin! !

!IcePlugin class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	^ self subclassResponsibility! !

!IcePluginManager commentStamp: ''!
I keep plugins configured for a repository. 

WARNING: Managers are kept in a weak dictionary with Repository as a key, reason why plugins can't have any kind of reference that could cause a memory leak. 
Consider using stateless plugins or instance copies of relevant information instead.!
!IcePluginManager methodsFor: 'accessing' stamp: ''!
plugins 
	^ plugins! !

!IcePluginManager methodsFor: 'accessing' stamp: ''!
addPlugin: aPlugin 
	plugins := plugins copyWith: aPlugin! !

!IcePluginManager methodsFor: 'events' stamp: ''!
repositoryWasCreated: aRepository
	^ self plugins do: [ :each | each repositoryWasCreated: aRepository ]! !

!IcePluginManager methodsFor: 'events' stamp: ''!
repositoryWillBeCreated: aRepository
	^ self plugins do: [ :each | each repositoryWillBeCreated: aRepository ]! !

!IcePluginManager methodsFor: 'accessing - ui' stamp: ''!
checkoutBranchPanelsOnModel: aModel 

	^ Array streamContents: [ :stream |
		self plugins do: [ :each |
			stream nextPutAll: (each checkoutBranchPanelsOnModel: aModel) ]]! !

!IcePluginManager methodsFor: 'initialization' stamp: ''!
initializeRepository: aRepository
	self initialize.
	plugins := self availablePluginsFor: aRepository! !

!IcePluginManager methodsFor: 'initialization' stamp: ''!
availablePluginsFor: aRepository
	^ (IcePlugin allAvailableFor: aRepository) 
		collect: #new
		as: Array! !

!IcePluginManager class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #managerFor:'! !

!IcePluginManager class methodsFor: 'instance creation' stamp: ''!
managerFor: aRepository
	^ self basicNew initializeRepository: aRepository! !

!IceProjectChange commentStamp: ''!
I represent the fact that the project changed. I'm using during the double-dispatch of diff calculation, so concrete projects can add themselves to the change calculation.!
!IceProjectChange methodsFor: 'displaying' stamp: ''!
displayingProgressString
	^ 'Comparing Project change'! !

!IceProjectChange methodsFor: 'visiting' stamp: ''!
accept: anIceChangeImporter 
	
	anIceChangeImporter visitProjectChange: self! !

!IceProjectReader commentStamp: ''!
I am a project reader that knows how to return a project object from a commit.
New readers can be created by inheriting this class, and will be detected by inheritance.
Then, a reader must implement:

 - #canReadProjectFromCommitish: returns a boolean that indicates if the reader knows how to read the project
 - #readProjectFromCommitish: returns a project object!
!IceProjectReader methodsFor: 'accessing' stamp: ''!
priority

	"By default all readers are important..."
	^ 1! !

!IceProjectReader methodsFor: 'testing' stamp: ''!
canReadProjectFromCommitish: aCommitish
	"Return a boolean indicating if I know how to read the project from the commitish"
	self subclassResponsibility! !

!IceProjectReader methodsFor: 'reading' stamp: ''!
readProjectFromCommitish: aCommitish
	"Return a project object read from the commitish"
	self subclassResponsibility! !

!IceProjectReader class methodsFor: 'accessing' stamp: ''!
availableReaders

	^ (self allSubclasses
		collect: [ :each | each new ])
		sorted: [ :a :b | a priority < b priority ]! !

!IceProjectReader class methodsFor: 'instance creation' stamp: ''!
readProjectFrom: anIceCommitish

	^ (self availableReaders
		detect: [ :any | any canReadProjectFromCommitish: anIceCommitish ])
			readProjectFromCommitish: anIceCommitish! !

!IceProviderRepositoryType commentStamp: ''!
I 'm a base class to resolve provider-based repositories.
A provider repositoy is composed of: 

provider://username/repository[:commitish][/subdir]

provider  	- The provider identifier (e.g. github, bitbucket, etc.)
username 	- The provider user
repository	- The provider repository
commitish	- an optional commitish (a branch, a tag, a commit id)
subdir		- an optional subdirectory where the packages exist.
		
Example: 
------------
A script to install voyage using this would like more or less like this:

Metacello new
	repository: 'github//pharo-nosql/voyage:master/mc';
	baseline: 'Voyage';
	load: 'mongo tests'.!
!IceProviderRepositoryType methodsFor: 'accessing' stamp: ''!
guessRegisteredRepository
	"I get the project name and try to find it into the already registered projects. 
	 If I find it, I will use this instead cloning a new one."

	^ IceRepository registry 
		detect: [ : each | each name = self projectName ] 
		ifNone: [ nil ]! !

!IceProviderRepositoryType methodsFor: 'accessing' stamp: ''!
mcRepository
	| baseRepo |
	
	self guessRegisteredRepository
		ifNotNil: [ :repo | 
			repo isValid ifTrue: [ ^ repo metacelloAdapter: self projectVersion ].
			"If the repo is not valid, we forget it and reget a new one. 
			 Because Metacello want to use it"
			repo forget ].
	baseRepo := self mcRepositoryClass location: self location.
	^ baseRepo getOrCreateIcebergRepository metacelloAdapter: self projectVersion! !

!IceProviderRepositoryType methodsFor: 'accessing' stamp: ''!
projectName

	^ (self location substrings: '/') third copyUpTo: $:! !

!IceProviderRepositoryType methodsFor: 'accessing' stamp: ''!
projectVersion

	^ (location substrings: '/') third copyAfter: $:! !

!IceProviderRepositoryType methodsFor: 'accessing' stamp: ''!
mcRepositoryClass
	^ MCGitBasedNetworkRepository allSubclasses detect: [ :e | e basicDescription = self class type ].! !

!IceProviderRepositoryType class methodsFor: 'testing' stamp: ''!
isAbstract
	^ super isAbstract
		or: [ self = IceProviderRepositoryType ]! !

!IceProxyMCVersionInfo commentStamp: ''!
I'm a proxy to keep information on pre-loaded packages when repository is not present.
This is the case of pharo project, which is distributed without a repository connection, but users may still need to link with it to make contributions.!
!IceProxyMCVersionInfo methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	^ aMessage sendTo: (self findVersionInfo 
		ifNotNil: [ :versionInfo | self becomeForward: versionInfo copyHash: false ]
		ifNil: [ self stubVersionInfo ])! !

!IceProxyMCVersionInfo methodsFor: 'initialization' stamp: ''!
lazy
	^ self! !

!IceProxyMCVersionInfo methodsFor: 'accessing' stamp: ''!
stubVersionInfo: aVersionInfo 
	stubVersionInfo := aVersionInfo! !

!IceProxyMCVersionInfo methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream << self class name << '(' << packageName << ')'! !

!IceProxyMCVersionInfo methodsFor: 'reflective operations' stamp: ''!
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! !

!IceProxyMCVersionInfo methodsFor: 'private' stamp: ''!
findVersionInfo 
	| repo remote commit |

	(self class lastCommitFound notNil 
		and: [ self class lastCommitFound id = commitId ])
		ifTrue: [ 
			commit := self class lastCommitFound.
			repo := commit repository ]
		ifFalse: [ 
			remote := IceGitRemote url: remoteUrl.
			repo := IceRepository registry 
				detect: [ :eachRepo | 
					eachRepo remotes 
						anySatisfy: [ :each | each referencesSameRemoteLocationAs: remote ] ]
				ifNone: [ ^ nil ].
			commit := repo lookupCommit: commitId.
			commit ifNil: [ 
				IceError signal: ('Your repository seems to be out of sync.!!
Please fetch from "{1}" and try again.' 
					format: { remote }) ].
			self class lastCommitFound: commit ].
	
	^ IceMCVersionInfo new 
		fromCommit: commit 
		package: (IcePackage named: packageName repository: repo)! !

!IceProxyMCVersionInfo methodsFor: 'printing' stamp: ''!
printString
	^ String streamContents: [ :stream | self printOn: stream ]! !

!IceProxyMCVersionInfo methodsFor: 'inspecting' stamp: ''!
inspect
	"Create and schedule an Inspector in which the user can examine the receiver's variables."
	^ Smalltalk tools inspector inspect: self! !

!IceProxyMCVersionInfo methodsFor: 'accessing' stamp: ''!
stubVersionInfo 
	^ stubVersionInfo ifNil: [ 
		stubVersionInfo := MCVersionInfo
			name: packageName
			id: UUID new
			message: 'fabricated from a proxy repository'
			date: nil
			time: nil
			author: ''
			ancestors: #() ]! !

!IceProxyMCVersionInfo methodsFor: 'initialization' stamp: ''!
remoteUrl: urlString packageName: nameString commitId: idString stub: aStub
	remoteUrl := urlString.
	packageName := nameString.
	commitId := idString.
	stubVersionInfo := aStub! !

!IceProxyMCVersionInfo class methodsFor: 'instance creation' stamp: ''!
remoteUrl: anUrl packageName: aName commit: aCommit message: aString author: authorString
	^ self 
		remoteUrl: anUrl
		packageName: aName 
		commitId: aCommit id
		stub: (MCVersionInfo
			name: aName
			id: UUID new
			message: aString
			date: aCommit datetime asDate
			time: aCommit datetime asTime
			author: authorString
			ancestors: #())! !

!IceProxyMCVersionInfo class methodsFor: 'private' stamp: ''!
lastCommitFound
	^ LastCommitFound! !

!IceProxyMCVersionInfo class methodsFor: 'instance creation' stamp: ''!
remoteUrl: urlString packageName: nameString commitId: idString
	^ self new 
		remoteUrl: urlString 
		packageName: nameString 
		commitId: idString
		stub: nil! !

!IceProxyMCVersionInfo class methodsFor: 'instance creation' stamp: ''!
remoteUrl: urlString packageName: nameString commitId: idString stub: aVersionInfo
	^ self new 
		remoteUrl: urlString 
		packageName: nameString 
		commitId: idString
		stub: aVersionInfo! !

!IceProxyMCVersionInfo class methodsFor: 'private' stamp: ''!
lastCommitFound: aCommit
	| oldCommit |
	oldCommit := LastCommitFound.
	LastCommitFound := aCommit.
	"This is just a cleanup mechanism... in general iceberg will be scanning 
	 a full repository and each proxy will be pointing to same commit so no 
	 point in keep it waiting"
	(LastCommitFound notNil and: [ oldCommit isNil ]) ifTrue: [ 
		[ (Delay forSeconds: 60) wait. 
		 	LastCommitFound := nil ] fork ]! !

!IcePullRemoteCommand commentStamp: ''!
I'm a command to perform a pull from a remote.!
!IcePullRemoteCommand methodsFor: 'accessing' stamp: ''!
remote: anObject
	remote := anObject! !

!IcePullRemoteCommand methodsFor: 'execute' stamp: ''!
execute
	self repository branch pullFrom: self remote.
	self beSuccess! !

!IcePullRemoteCommand methodsFor: 'accessing' stamp: ''!
remote
	^ remote! !

!IcePushTransferProgress methodsFor: 'accessing' stamp: ''!
block
	^ [ :current :total :bytes :payload | 
		job ensureStarted.
		
		job min: 0.
		job max: total.
		job current: current.
		job title: ((self title, ' ({1}/{2})') format: { current. total}).
		
		job changed.
		
		0
	]! !

!IcePushTransferProgress methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	job := IceExternalJob new
		title: self title;
		yourself.
		
	self initializeBlock.! !

!IcePushTransferProgress methodsFor: 'initialization' stamp: ''!
initializeBlock
	self signature: self class fnSpec block: self block.! !

!IcePushTransferProgress methodsFor: 'accessing' stamp: ''!
title
	^ 'Pushing...'! !

!IcePushed commentStamp: ''!
Announces when a repository has been pushed.!
!IceRemote commentStamp: ''!
I represent a reference to an upstream repository, i.e. the repository to which you want to push/pull. Usually I am called a  'remote' but I could also be local. Most frequently each repository has at least one remote named 'origin'.

I am abstract, my subclasses provide access to different kinds of remotes.

Right now I just provide information about the different parts of the url, I could get smarter in the future.

Internal Representation and Key Implementation Points.
    Instance Variables
	url:		<String>!
!IceRemote methodsFor: 'comparing' stamp: ''!
= another
	
	self subclassResponsibility! !

!IceRemote methodsFor: 'accessing' stamp: ''!
localRepository: aRepository
	
	localRepository := aRepository! !

!IceRemote methodsFor: 'testing' stamp: ''!
hasBranches
	^ self branches isNotEmpty! !

!IceRemote methodsFor: 'testing' stamp: ''!
isSame: aRemote
	^ (self referencesSameRemoteLocationAs: aRemote)
		and: [ self name = aRemote name ]! !

!IceRemote methodsFor: 'branches' stamp: ''!
branches
	
	self subclassResponsibility! !

!IceRemote methodsFor: 'accessing' stamp: ''!
branchesFrom: aRepository
	"I return all the branches of my remote from a repository"

	^ aRepository branches
		select: [ :branch | branch isRemote and: [ branch remoteName = self name ] ]! !

!IceRemote methodsFor: 'fetching' stamp: ''!
fetchBranch: aRemoteBranch
	
	self subclassResponsibility! !

!IceRemote methodsFor: 'fetching' stamp: ''!
fetch
	
	self subclassResponsibility! !

!IceRemote methodsFor: 'printing' stamp: ''!
printOn: stream
	stream 
		<< (self name ifNil: [ 'noname' ]) 
		<< ' (' << self url << ')'! !

!IceRemote methodsFor: 'branches' stamp: ''!
remoteBranchNamed: aString ifPresent: presentClosure ifAbsent: absentClosure
	
	^ absentClosure value! !

!IceRemote methodsFor: 'accessing' stamp: ''!
url
	^ url! !

!IceRemote methodsFor: 'accessing' stamp: ''!
name: aString 
	
	name := aString! !

!IceRemote methodsFor: 'private' stamp: ''!
basicUrl: aString
	url := aString! !

!IceRemote methodsFor: 'patches' stamp: ''!
httpsUrl
	"This method is used to compare exchangeable addresses (https:// and git@). 
	 So it has sense in my children, and is notably used on #isSameUrl: 
	 implementations"
	^ self url! !

!IceRemote methodsFor: 'accessing' stamp: ''!
detailedInfo
	^ #()! !

!IceRemote methodsFor: 'displaying' stamp: ''!
displayString
	^ '{1}: {2}' format: { 
			self name.
			self url }! !

!IceRemote methodsFor: 'testing' stamp: ''!
referencesSameRemoteLocationAs: another
	"Base/trivial implementation is that two urls are the same if they are equal, 
	but some subclasses have more complicated logic to detect two urls pointing to the same remote"
	^ self url sameAs: another url! !

!IceRemote methodsFor: 'branches' stamp: ''!
remoteBranchNamed: aString 
	
	^ self
		remoteBranchNamed: aString
		ifPresent: [ :branch | ^ branch ]
		ifAbsent: [ IceBranchNotFound new
			branchName: aString;
			signal ]! !

!IceRemote methodsFor: 'accessing' stamp: ''!
host
	^ self subclassResponsibility! !

!IceRemote methodsFor: 'accessing' stamp: ''!
localRepository
	
	^ localRepository! !

!IceRemote methodsFor: 'accessing' stamp: ''!
url: aString
	self basicUrl: aString.
	self parseUrl! !

!IceRemote methodsFor: 'accessing' stamp: ''!
projectBasename
	^ self projectName withoutSuffix: '.git'! !

!IceRemote methodsFor: 'accessing' stamp: ''!
projectName
	^ projectName! !

!IceRemote methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!IceRemote methodsFor: 'branches' stamp: ''!
remoteBranchNamed: aString ifAbsent: aBlock
	
	^ self
		remoteBranchNamed: aString
		ifPresent: [ :branch | ^ branch ]
		ifAbsent: [ ^ aBlock value ]! !

!IceRemote methodsFor: 'testing' stamp: ''!
hasRemoteBranchNamed: aString 
	
	self
		remoteBranchNamed: aString
		ifPresent: [ :branch | ^ true ]
		ifAbsent: [ ^ false ]! !

!IceRemote methodsFor: 'private' stamp: ''!
parseUrl
	^ self subclassResponsibility ! !

!IceRemote methodsFor: 'accessing' stamp: ''!
upstreamForBranch: aBranch backend: backend
	^ backend 
		lookupBranchNamed: aBranch name 
		inRemote: self remoteName
! !

!IceRemote methodsFor: 'testing' stamp: ''!
isUndefined
	^ false! !

!IceRemoteAlreadyExistsError methodsFor: 'accessing' stamp: ''!
remoteName: aString 
	remoteName := aString! !

!IceRemoteAlreadyExistsError methodsFor: 'accessing' stamp: ''!
remoteName
	^ remoteName! !

!IceRemoteAlreadyExistsError methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor
	aVisitor visitRemoteAlreadyExistError: self! !

!IceRemoteBranch commentStamp: ''!
I am a remote tracked branch. I am a copy to a branch that exists in a remote. I can thus only synchronize myself with the external repository through fetches and with the local branches.

  branch fetch.
  branch fetchFrom:.

  branch outgoingCommits.
  branch hasOutgoingCommits.!
!IceRemoteBranch methodsFor: 'API - remotes' stamp: ''!
outgoingCommits
	^ #()! !

!IceRemoteBranch methodsFor: 'comparing' stamp: ''!
= aBranch

	^ aBranch isRemote
		and: [ self name = aBranch name ]! !

!IceRemoteBranch methodsFor: 'comparing' stamp: ''!
hash

	^ self name hash! !

!IceRemoteBranch methodsFor: 'testing' stamp: ''!
isRemote

	^ true! !

!IceRemoteBranch methodsFor: 'API - checkout' stamp: ''!
checkout: aCheckoutStrategy

	| localBranch |
	self repository 
		branchNamed: self shortName
		ifPresent: [ :branch | IceError signal: ('Branch {1} already exists' format: { self shortName }) ].
	
	localBranch := self repository
		createBranch: self shortName
		inCommit: self commit.

	aCheckoutStrategy committish: localBranch.
	^ localBranch checkout: aCheckoutStrategy! !

!IceRemoteBranch methodsFor: 'API - actions' stamp: ''!
checkoutWithStrategy: aCheckoutStrategy
	"checkouts a remote branch"

	"if there is a local branch with that name, checkout it (it will be that what you want, you will need to do 
	a pull later)"	
	self repository localBranches
		detect: [ :each | each name = self shortName ]
		ifFound: [ :each | ^ each checkout ].
	"there are no local repositories. First we need to create one."
	self repository
		createBranch: self shortName 
		inCommit: self commit.
	"then we can do the checkout"
	^ super checkoutWithStrategy: aCheckoutStrategy! !

!IceRemoteBranch methodsFor: 'API - remotes' stamp: ''!
incomingCommits
	^ #()! !

!IceRemoteBranch methodsFor: 'accessing' stamp: ''!
shortName
	^ self name copyAfter: $/! !

!IceRemoteBranch methodsFor: 'accessing' stamp: ''!
remote
	^ repository remoteNamed: self remoteName! !

!IceRemoteDesynchronized commentStamp: ''!
I indicate when a remote is desyncronized. 
It means the version I have in the working copy (not the image) is different to the version I have in the remote (then I need to pull/branch/whatever before commiting).!
!IceRemoteDesynchronized methodsFor: 'accessing' stamp: ''!
remote: anObject
	remote := anObject! !

!IceRemoteDesynchronized methodsFor: 'converting' stamp: ''!
asResumable
	resumable := true! !

!IceRemoteDesynchronized methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	resumable := false! !

!IceRemoteDesynchronized methodsFor: 'private' stamp: ''!
isResumable
	^ resumable! !

!IceRemoteDesynchronized methodsFor: 'accessing' stamp: ''!
remote
	^ remote! !

!IceRemoteDesynchronized methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor
	aVisitor visitRemoteDesynchronizedError: self! !

!IceRemoteNotFoundError methodsFor: 'accessing' stamp: ''!
remoteName: aString 
	remoteName := aString! !

!IceRemoteNotFoundError methodsFor: 'accessing' stamp: ''!
remoteName
	^ remoteName! !

!IceRemoteWithOnlyHostname commentStamp: ''!
I represent a replacement for the remotes. 
I am used when there is only an String as URL.
This is to not intended to be polymorphic with all the uses of remotes in iceberg. 
It is only used in the credential!
!IceRemoteWithOnlyHostname methodsFor: 'accessing' stamp: ''!
host
	^ host ! !

!IceRemoteWithOnlyHostname methodsFor: 'accessing' stamp: ''!
host: aString 
	host := aString! !

!IceRemoteWithOnlyHostname class methodsFor: 'instance creation' stamp: ''!
for: aHost
	^ self new
		host: aHost;
		yourself! !

!IceRemoval commentStamp: ''!
I am a removal in a tree. I contain the definition I'm removing. I know what is the icon for removal and how to calculate a conflict with other operations.!
!IceRemoval methodsFor: 'accessing' stamp: ''!
leftContents
	
	^ ''! !

!IceRemoval methodsFor: 'merging' stamp: ''!
mergeWithLeftModification: anIceModification 
	
	^ IceConflictingOperation
		left: anIceModification
		right: self! !

!IceRemoval methodsFor: 'merging' stamp: ''!
mergeWithLeftRemoval: anIceRemoval 
	
	^ IceNonConflictingOperation operation: anIceRemoval! !

!IceRemoval methodsFor: 'testing' stamp: ''!
isRemoval
	
	^ true! !

!IceRemoval methodsFor: '*Iceberg-TipUI' stamp: ''!
icon

	^ self iconNamed: #changeRemove! !

!IceRemoval methodsFor: 'merging' stamp: ''!
mergeWithLeftAddition: anIceAddition 
	
	"This should not happen. If I represent a removal of a node, that means that the original definition existed on the base version.
	Thus, the right version can never ADD an already existing version. It can remove it too or modify it."
	self shouldNotImplement! !

!IceRemoval methodsFor: 'operations' stamp: ''!
inverse
	
	^ IceAddition definition: definition! !

!IceRemoval methodsFor: 'merging' stamp: ''!
mergeWithLeftNoOperation: anIceNoModification 
	
	"We assume that if the IceNoModification is in the tree this means its children have modifications.
	So a removal of a tree with modifications should be a conflict.
	
	This should maybe be enhanced: if my children are removals maybe this should not be a conflict, but this is the simplest solution right now."
	^ IceConflictingOperation left: anIceNoModification right: self! !

!IceRemoval methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitRemoval: self! !

!IceRemoval methodsFor: 'merging' stamp: ''!
mergeWithOperation: anOperation
	
	^ anOperation mergeWithLeftRemoval: self! !

!IceRepository commentStamp: ''!
I represent an iceberg repository. I am an abstract class, my subclasses will represent concrete repositories such as monticello or git repositories. I define the main API and I have some common methods defined as template methods.

!! Instantiation
Check my subclasses to know how to instantiate them.

!! Basic  repository properties

All repositories have two main properties: a name and a working copy. 
 - name is used to identify a repository
 - the working copy is used to manage the status of all code loaded from the repository. See #IceWorkingCopy

!! The repository HEAD

Moreover, every repository has to define a HEAD. The repository HEAD is a reference to our current working commit/branch in the repository.

  repository head.

The head can be either a branch or a commit. To access the current commit you can ask the head for its commit, or directly the repository for its headCommit (Yes, commits and branches are polymorphic, a commit returns self when asked for its commit).

  repository head commit.
  repository headCommit.

HEAD is an important concept inside iceberg. It is used to calculate if our code is synchronized, if we have commits to fetch and load, and so on...

Moreover, please notice that HEAD is a repository property, and it is completely separate from the image's state. The image can have code loaded from commits other than HEAD, and vice-versa. More of it is explained in IceWorkingCopy class comment.

!! Branches

An iceberg repository natively  supports branches. To query the branches in the repository you can ask for:

  repository localBranches.
  repository remoteTrackedBranches.
  repository allBranches.

Other convenience methods also provide:

  repository localBranchNames.
  repository remoteBranchNames.

Take into account that such methods will return only already fetched branches. If the branch exists in a remote repository, you should need to do a #fetch before being able to see it.

Branches can also be queried by name, using the utility methods

  repository branchNamed: aName.
  repository branchNamed: aName ifAbsent: [ ... ].
  repository branchNamed: aName ifPresent: [ ... ].
  repository branchNamed: aName ifAbsent: [ ... ] ifPresent: [ ... ].

and the variant for remote branches.

  repository remoteBranchNamed: aName.
  repository remoteBranchNamed: aName ifAbsent: [ ... ].
  repository remoteBranchNamed: aName ifPresent: [ ... ].
  repository remoteBranchNamed: aName ifAbsent: [ ... ] ifPresent: [ ... ].

Branches can be created from a specific commit or, by default, from #headCommit.

  repository createBranch: aBranchName.
  repository createBranch: aBranchName inCommit: aCommit.

Notice that creating a branch will switch to it automatically.

The variant #ensureBranch: will create a branch only if a branch with the same name does not exist.

  repository ensureBranch: aBranchName.

Also, to create a branch tracking a remote branch (that is, that will start from the same commit and follow the evolution of a remote branch), you can use #createBranchTracking: aBranchName.

Finally, to switch to an existing branch:

  repository switchToBranchNamed: aBranchName.

!! Remotes

Remotes are references to remote repositories. Remotes are used for pulling and pushing commits and branches.
Remotes can be added using the #addRemote: message and removed using the remoteRemote: message . However, thou shall be careful, remotes should be created from the class corresponding to the repository. For example, git repositories should use git remotes, and so on. Check IceRemote and its concrete subclasses.

  repository addRemote: aRemote.

Once remotes are configured, we can configure them as pull remote and push remote. A pull remote is a remote used for pulling commits by default, while a push remote is a remote used for pushing new commits by default.

  repository pullRemote: aRemote.
  repository pushRemote: aRemote.

  repository isPullRemote: aRemote.
  repository isPushRemote: aRemote.

If pull or push remotes are not configured, they will default to 'origin'. Origin is a well known remote, for which an accessor to the 'origin' remote  is provided through the #origin message.

  repository origin.

Remotes can be queried with:

  repository remotes.
  repository remoteNamed: aName.
  repository remoteNamed: aName ifAbsent: [ ... ].

Moreover, we can query if the current branch has commits to be uploaded using the #outgoingCommits and friends, or if the current branch has commits to be downloaded using the #ingoingCommits and friends.

  repository hasIncomingCommits.
  repository incomingCommits.
  repository hasIncomingCommitsFrom: aRemote.
  repository incomingCommitsFrom: aRemote.

  repository hasOutgoingCommits.
  repository outgoingCommits.
  repository hasOutgoingCommitsTo: aRemote.
  repository outgoingCommitsTo: aRemote.

Finally, we can interact with remotes via the fetch, pull and push operations.
Fetch downloads new commits and branches from the specified remote.
Pull and push operations delegate to pull and push of the current branch. Check IceLocalBranch.

  repository fetch.
  repository pull.
  repository push.

!! Committing code

Once modifications are done, we can commit them to the repository using the commit* messages. The main API for it is #commitWithMessage: that will commit all changes with the given commit.

  repository commitWithMessage: 'aMessage in a string'.

A second commit message is also available to commit cherry picks:

  repository commitCherryPick: aChangesList withMessage: ' a message in a string'.

NOTICE that commits can only be done if the following is true:

 - HEAD is a branch
 - the working copy reference commit is the same commit as #headCommit

In any other case, commits are forbidden as they may break the repository consistency.

!! Loading code & Package querying

From the repository point of view, only some convenience methods are provided to checkout all code from the current branch, unload all loaded code, know what packages are loaded or modified. Please refer to IceWorkingCopy for a more complete API.

!
!IceRepository methodsFor: 'API - remotes' stamp: ''!
hasIncomingCommitsFrom: aRemote
	
	^ self branch hasIncomingCommitsFrom: aRemote! !

!IceRepository methodsFor: '*Iceberg-Changes' stamp: ''!
fullWorkingCopyDiff
	^ IceDiff new
		source: self workingCopy;
		target: self head;
		buildFull;
		yourself! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
hasLocalBranchNamed: aString
	
	^ self branchNamed: aString
		ifPresent: [ :branch | true ]
		ifAbsent: [ false ]! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
remotes
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
pullFrom: aRemote
	"Fetch new commits corresponding to the remote.
	Then merge the remote branch with the current branch."
	self branch pullFrom: aRemote! !

!IceRepository methodsFor: 'API - history' stamp: ''!
commitAt: commitId
	
	^ self lookupCommit: commitId! !

!IceRepository methodsFor: 'API - changes' stamp: ''!
discardChanges
	
	self workingCopy discardChanges! !

!IceRepository methodsFor: 'API - tags' stamp: ''!
hasTagNamed: aString 
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - accessing' stamp: ''!
branch
	"Returns head if head is a branch.
	Throws an exception if HEAD is not a branch"
	
	self head validateIsBranch.
	^ self head! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
hasLocalBraches
	^ self localBranches isNotEmpty! !

!IceRepository methodsFor: 'private - changes' stamp: ''!
newIndex
	
	self subclassResponsibility! !

!IceRepository methodsFor: '*Iceberg-Adapters' stamp: ''!
metacelloAdapter: version
	^ IceMetacelloRepositoryAdapter for: self withVersion: version! !

!IceRepository methodsFor: 'API - changes' stamp: ''!
notifyPackageModified: aString 
	
	^ self workingCopy notifyPackageModified: aString! !

!IceRepository methodsFor: 'API - tags' stamp: ''!
tagNames
	
	^ self tags collect: #name! !

!IceRepository methodsFor: 'API - accessing' stamp: ''!
setHead: anIceGitBranch 
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
createBranch: branchName inCommit: aCommit
	"Creates a new branch from a given commit and switch to it"

	self subclassResponsibility! !

!IceRepository methodsFor: 'API - loading' stamp: ''!
checkoutBranch: branchName
	"Convenience method to checkout all packages from a branch given a branch name"

	(self
		branchNamed: branchName
		ifAbsent: [
			self createBranch: branchName ]) checkout! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
outgoingCommits
	^ self branch outgoingCommits ! !

!IceRepository methodsFor: '*Iceberg-Plugin' stamp: ''!
pluginManager
	^ IcePluginManager managerFor: self! !

!IceRepository methodsFor: 'API - registry' stamp: ''!
delete
	"Delete is idempotent. If the repository does not exist, do nothing.
	Otherwise, forget the repository"
	self forget! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
remoteBranchNamed: aString
	"Access a remote branch by name.
	Throws an IceBranchNotFound is the branch does not exist in the repository."
	
	^ self
		remoteBranchNamed: aString
		ifPresent: [ :branch | ^ branch ]
		ifAbsent: [ IceBranchNotFound new
			branchName: aString;
			signal ]! !

!IceRepository methodsFor: 'API - accessing' stamp: ''!
subdirectoryPath
	"Return a relative path containing the path to the code source.
	This is required to compute the diff between two versions.
	
	Subclasses that do not require this may implement it, for example, as an empty relative path"
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
push
	"Push current commits to the default push remote"
	
	self branch push! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
remoteNamed: aString ifAbsent: aBlockClosure 
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
incomingCommits
	
	(self head isDetached)
		ifTrue: [ ^ #() ].
	^ self branch incomingCommits! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
remoteBranchNamed: aName ifAbsent: absentBlock
	"Access a remote branch by name.
	Returns the result of the second argument if absent."
	
	^ self
		branchNamed: aName
		ifPresent: [ :branch | branch ]
		ifAbsent: absentBlock! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
branchNamed: aName
	"Access a branch by name.
	Throws an IceBranchNotFound is the branch does not exist in the repository."
	
	^ self
		branchNamed: aName
		ifPresent: [ :branch | ^ branch ]
		ifAbsent:[ 
			IceBranchNotFound new
				branchName: aName;
				signal ]! !

!IceRepository methodsFor: 'private - remotes' stamp: ''!
postFetch
	"This method is called after every fetch.
	Fox possible broken references using unknown commits."
	| maybeGoodCommit |
	
	self workingCopy referenceCommit isUnknownCommit ifFalse: [ ^ self ].
	maybeGoodCommit := self lookupCommit: self workingCopy referenceCommit id.
	maybeGoodCommit isUnknownCommit ifFalse: [ 	maybeGoodCommit adopt ]! !

!IceRepository methodsFor: 'API - commits' stamp: ''!
newNoCommit
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - tags' stamp: ''!
createTag: aString

	^ self workingCopy referenceCommit createTag: aString! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
remoteBranchNamed: aString ifPresent: presentBlock ifAbsent: absentBlock 
	"Access a remote branch by name.
	If present, evaluate the block used as second argument with the branch found.
	If absent, evaluate the absent block."
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
branchNamed: aString ifPresent: aBlockClosure 
	"Access a branch by name.
	If present, evaluate the block used as second argument with the branch found.
	If absent, do nothing."
	
	^ self
		branchNamed: aString
		ifPresent: aBlockClosure
		ifAbsent: [ self ]! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
fetchFrom: aRemote 
	"Fetch all commits and branches from the pull remote"

	aRemote fetch! !

!IceRepository methodsFor: 'API - history' stamp: ''!
includesCommit: anIceCommit
	self lookupCommit: anIceCommit id ifAbsent: [ ^ false ].
	^ true	! !

!IceRepository methodsFor: 'private - commits' stamp: ''!
internalStoreVersion: aMCVersion 
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
createNewBranch: branchName
	"Creates a new branch starting on HEAD commit and switch to it"

	self createBranch: branchName inCommit: self headCommit! !

!IceRepository methodsFor: 'API - accessing' stamp: ''!
head
	"The repository HEAD is a reference to our current working commit/branch in the repository.

	The head can be either a branch or a commit. To access the current commit you can ask the head for its commit, or directly the repository for its #headCommit (Yes, commits and branches are polymorphic, a commit returns self when asked for its commit)."

	self subclassResponsibility! !

!IceRepository methodsFor: 'accessing' stamp: ''!
workingCopy: aWorkingCopy
	"See IceWorkingCopy"
	
	workingCopy := aWorkingCopy.
	workingCopy repository: self! !

!IceRepository methodsFor: 'testing' stamp: ''!
isCloneOfUrl: aString 

	^ self origin url = aString! !

!IceRepository methodsFor: 'accessing' stamp: ''!
workingCopy
	"See IceWorkingCopy"
	
	^ workingCopy! !

!IceRepository methodsFor: 'private - packages' stamp: ''!
workingCopies
	^ self loadedPackages collect: #workingCopy
! !

!IceRepository methodsFor: 'API - history' stamp: ''!
lookupCommit: commitId

	^ self
		lookupCommit: commitId
		ifAbsent: [ IceUnknownCommit new 
				repository: self;
				id: commitId; yourself ]! !

!IceRepository methodsFor: 'testing' stamp: ''!
hasLoadedPackages
	^ self loadedPackages notEmpty! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
ensureBranch: branchName
	(self hasLocalBranchNamed: branchName)
		ifFalse: [ self createBranch: branchName ]
! !

!IceRepository methodsFor: 'API - tags' stamp: ''!
tags
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - project' stamp: ''!
project
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
switchToCommitishNamed: aString
	
	^ (self commitishNamed: aString)
		switch;
		yourself! !

!IceRepository methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!IceRepository methodsFor: 'API - commit' stamp: ''!
commitIndexWithMessage: message andParents: parentCommitishList
	"Low level.
	
	Commit what is saved in the index"
	
	| newCommit |
	newCommit := index commitWithMessage: message andParents: parentCommitishList.
	index := self newIndex.
	self workingCopy referenceCommit: newCommit.
	self workingCopy refreshDirtyPackages.
	^ newCommit! !

!IceRepository methodsFor: 'API - packages' stamp: ''!
includesPackageNamed: aString
	"Returns true if the given package name belongs to a package loaded in the image"
	
	^ self workingCopy includesPackageNamed: aString! !

!IceRepository methodsFor: 'API - history' stamp: ''!
newCommitWalk
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
pushTo: aRemote	
	
	self branch pushTo: aRemote! !

!IceRepository methodsFor: 'private - remotes' stamp: ''!
remoteAt: aString put: aRemote

	self subclassResponsibility! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
switchToBranchNamed: aString
	
	^ (self branchNamed: aString)
		switch;
		yourself! !

!IceRepository methodsFor: 'API - loading' stamp: ''!
checkoutAllPackages

	"A checkout operation loads all packages from the current branch in the image"
	self branch checkoutAllPackages! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
localBranches
	"Lists local branches"
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
addRemote: aRemote  
	"Add a remote to the current repository.
	
	Throw an exception if a remote with the same name already exists"
	
	(self hasRemoteNamed: aRemote name)
		ifTrue: [ IceRemoteAlreadyExistsError new
			remoteName: aRemote name;
			signal ].
	
	self remoteAt: aRemote name put: aRemote.
	aRemote localRepository: self.! !

!IceRepository methodsFor: 'private - commits' stamp: ''!
commitsInPackageCache

	^ commitsInPackageCache ifNil: [ commitsInPackageCache := LRUCache new maximumWeight: 30  ]! !

!IceRepository methodsFor: 'API - packages' stamp: ''!
packageNamed: packageName
	"Returns the loaded package with the given name"
	
	^ self workingCopy packageNamed: packageName! !

!IceRepository methodsFor: 'printing' stamp: ''!
description
	^ self origin url, '[', self head description, ']'! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
remoteTrackedBranches
	"Lists branches in remotes"
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - accessing' stamp: ''!
commitishNamed: aName
	"Resolve a name in the form of:
	  - a commit hash
	  - a branch name
	  - some other expression such as HEAD or master~1
	and return the corresponding iceberg object for it."

	^ self subclassResponsibility! !

!IceRepository methodsFor: 'API - project' stamp: ''!
newProjectFromCommit: aCommit

	self subclassResponsibility! !

!IceRepository methodsFor: 'accessing' stamp: ''!
workingCopyDiff
	
	^ self workingCopy diffToReferenceCommit! !

!IceRepository methodsFor: 'API - accessing' stamp: ''!
headCommit
	"The head can be either a branch or a commit. To access the current commit you can ask the head for its commit, or directly the repository for its headCommit (Yes, commits and branches are polymorphic, a commit returns self when asked for its commit)."

	^ self head commit! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
outgoingCommitsTo: aRemote
	^ self branch outgoingCommitsTo: aRemote! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
pull
	"Fetch new commits corresponding to the current branch from the default pull remote.
	Then merge the remote branch with the current branch."
	self branch pull! !

!IceRepository methodsFor: 'API - registry' stamp: ''!
forget
	self class unregisterRepository: self ifAbsent: [ ^ nil ].
	Iceberg announcer announce: (IceRepositoryForgotten repository: self)! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
createBranch: branchName
	"Creates a new branch from #headCommit and switch to it"
	
	^ self createBranch: branchName inCommit: self headCommit! !

!IceRepository methodsFor: 'API - commit' stamp: ''!
commitChanges: changes withMessage: message
	"Creates a commit with the given changes using the comment given as argument.
	
	NOTICE that commits can only be done if the following is true:

 - HEAD is a branch
 - the working copy reference commit is the same commit as #headCommit"

	^ self workingCopy
		commitChanges: changes
		withMessage: message! !

!IceRepository methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	workingCopy := IceWorkingCopy basicNew.
	workingCopy repository: self.
	workingCopy initialize.
	
	index := self newIndex.! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
remoteNamed: aString 
	
	^ self remoteNamed: aString ifAbsent: [ IceRemoteNotFoundError new
		remoteName: aString;
		signal ]! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
localBranchNames
	
	^ self localBranches collect: #name! !

!IceRepository methodsFor: 'API - packages' stamp: ''!
isModified
	"Returns true if a package in the working copy has modifications"
	
	^ self workingCopy isModified! !

!IceRepository methodsFor: 'API - history' stamp: ''!
lookupCommit: commitId ifAbsent: aBlock
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - loading' stamp: ''!
unload
	"Unload all code loaded into the image that belong to this repository"
	
	self workingCopy unload! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
remoteBranchNamed: aString ifPresent: aBlockClosure 
	"Access a remote branch by name.
	If present, evaluate the block used as second argument with the branch found.
	If absent, do nothing."
	
	^ self
		branchNamed: aString
		ifPresent: aBlockClosure
		ifAbsent: [ self ]! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
branchNamed: aName ifAbsent: absentBlock
	"Access a branch by name.
	Returns the result of the second argument if absent."
	
	^ self
		branchNamed: aName
		ifPresent: [ :branch | branch ]
		ifAbsent: absentBlock! !

!IceRepository methodsFor: 'validating' stamp: ''!
validateCanPushTo: aRemote
	| commits |
	
	"I need to perform a fetch to have access to latest commits, because there is no 
	 other way to know if local repository is behind remote repository."
	aRemote fetch.
	"Now I can check if we are in sync"
	commits := self branch incomingCommitsFrom: aRemote.
	commits ifEmpty: [ ^ self ].

	IceRemoteDesynchronized new 
		asResumable;
		remote: aRemote;
		signal! !

!IceRepository methodsFor: 'validating' stamp: ''!
validateCanCommit
	"Private API. Do not rely on this.
	
	To know if you can commit you should ask the working copy"
	
	"If the repository head is detached (aka not a branch) we cannot commit.
	The repository has to be placed on a branch."
	self head isDetached ifTrue: [
		IceWorkingCopyDesyncronized signal ]! !

!IceRepository methodsFor: 'private - commits' stamp: ''!
commitsInPackageCache: aCache

	commitsInPackageCache := aCache! !

!IceRepository methodsFor: '*Iceberg-TipUI' stamp: ''!
gtInspectorItemsIn: composite
	<gtInspectorPresentationOrder: 0>
	^ composite fastTable 
		title: 'Packages';
		display: [ self workingCopy packages ];
		column: 'Name' evaluated: [:each | each name ] width: 400 * self currentWorld displayScaleFactor;
		column: 'Status' evaluated: [:each | each asString ] width: 400 * self currentWorld displayScaleFactor! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
hasRemoteNamed: aString 
	
	self remoteNamed: aString ifAbsent: [ ^ false ].
	^ true! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
branchNamed: aName ifPresent: presentBlock ifAbsent: absentBlock
	"Access a branch by name.
	If present, evaluate the block used as second argument with the branch found.
	If absent, evaluate the absent block."
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'accessing' stamp: ''!
log
	^ self subclassResponsibility! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
origin

	self subclassResponsibility! !

!IceRepository methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: self class name;
		nextPut: $(;
		nextPutAll: name asString;
		nextPut: $)! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
fetch
	"Fetch all commits and branches from all remotes"
	
	self remotes do: [ :each | each fetch ] 
		displayingProgress: [ :each | 'Remote: ' , each name asString ]! !

!IceRepository methodsFor: 'deprecated' stamp: ''!
branchesForMerge: aCommit
	"Returns a list of local branches to which we could merge the received commit"

	^ self allBranches reject: [ :each | each includesCommit: aCommit ]! !

!IceRepository methodsFor: 'API - cherry-picking' stamp: ''!
cherryPickFrom: anotherCommit 

	^ self head cherryPickFrom: anotherCommit! !

!IceRepository methodsFor: 'accessing' stamp: ''!
name: aString
	"Change the name of the repository as is seen inside image (real project name resides 
	 externally, in repository). This can be confusing, but some times you need it to create new 
	 repositories from image (before creating repository externally... which means no remote)"
	name := aString! !

!IceRepository methodsFor: 'testing' stamp: ''!
canPush
	
	^ self head isDetached not and: [ 
		self branch tracksRemoteBranch ]! !

!IceRepository methodsFor: 'API - tags' stamp: ''!
removeTag: anIceTag 
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - commit' stamp: ''!
commitWithMessage: message
	"Creates a commit with all changed code using the comment given as argument.
	
	NOTICE that commits can only be done if the following is true:

 - HEAD is a branch
 - the working copy reference commit is the same commit as #headCommit"
	
	^ self workingCopy commitWithMessage: message! !

!IceRepository methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!IceRepository methodsFor: 'API - packages' stamp: ''!
modifiedPackages
	"Lists all modified packages currently loaded in the image"

	^ self workingCopy modifiedPackages! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
remoteBranchNames
	
	^ self remoteTrackedBranches collect: #name! !

!IceRepository methodsFor: 'printing' stamp: ''!
headDescription
	
	^ self head description! !

!IceRepository methodsFor: 'API - branches' stamp: ''!
allBranches
	"Returns all local and remote branches, instances of IceBranch, from the current repository. This method will return only already fetched branches."
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'private - tags' stamp: ''!
peelTag: anIceTag 
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - working copy' stamp: ''!
checkout: aCheckoutStrategy
	
	self workingCopy checkout: aCheckoutStrategy! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
hasIncomingCommits
	
	^ self branch hasIncomingCommits! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
hasOutgoingCommits
	
	^ self branch hasOutgoingCommits! !

!IceRepository methodsFor: 'API - registry' stamp: ''!
checkForRegistryConflicts

	self subclassResponsibility! !

!IceRepository methodsFor: 'API - project' stamp: ''!
newUnbornProject
	
	^ IceUnbornProject onRepository: self! !

!IceRepository methodsFor: 'API - registry' stamp: ''!
register
	self checkForRegistryConflicts.
	self class registerRepository: self.
	Iceberg announcer announce: (IceRepositoryCreated repository: self).
	^ self 
! !

!IceRepository methodsFor: 'API - remotes' stamp: ''!
removeRemote: aRemote
	
	(self hasRemoteNamed: aRemote name)
		ifFalse: [ IceRemoteNotFoundError new
			remoteName: aRemote name;
			signal ].
		
	self doRemoveRemote: aRemote! !

!IceRepository methodsFor: 'API - accessing' stamp: ''!
branchName
	"Returns current branch name.
	
	Throws an exception if HEAD is not a branch"

	^ self branch name! !

!IceRepository methodsFor: 'validating' stamp: ''!
validateCanPull
	self isModified 
		ifTrue: [ IceShouldCommitBeforePull signal ]! !

!IceRepository methodsFor: 'private - remotes' stamp: ''!
doRemoveRemote: aRemote
	
	self subclassResponsibility! !

!IceRepository methodsFor: 'API - packages' stamp: ''!
loadedPackages
	"Lists all loaded packages"

	^ self workingCopy loadedPackages! !

!IceRepository methodsFor: 'API - tags' stamp: ''!
tagNamed: aString 
	
	(self hasTagNamed: aString) ifFalse: [ 
		IceTagNotFound new
			tagName: aString;
			signal ].
		
	^ IceTag named: aString inRepository: self! !

!IceRepository class methodsFor: 'registry' stamp: ''!
registry
	^ Registry ifNil: [ Registry := OrderedCollection new ]! !

!IceRepository class methodsFor: 'registry' stamp: ''!
registeredRepositoryIncludingPackage: aPackage 
	^ self registry 
		detect: [ :each | each includesPackageNamed: aPackage name ]
		ifNone: [ nil ]! !

!IceRepository class methodsFor: 'registry' stamp: ''!
registerRepository: aRepository
	
	self registry add: aRepository.
	^ aRepository! !

!IceRepository class methodsFor: 'registry' stamp: ''!
repositories
	
	^ self registry! !

!IceRepository class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceRepository! !

!IceRepository class methodsFor: 'registry' stamp: ''!
unregisterRepository: aRepository ifAbsent: aBlock
	^ self registry 
		remove: aRepository 
		ifAbsent: aBlock ! !

!IceRepository class methodsFor: 'class initialization' stamp: ''!
reset
	Registry := nil.
	Iceberg announcer announce: IceRepositoryForgotten new.! !

!IceRepositoryAnnouncement commentStamp: ''!
Groupes different announcements that can happen in a repository.!
!IceRepositoryAnnouncement methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceRepositoryAnnouncement methodsFor: 'testing' stamp: ''!
appliesToRepository: aRepository
	^ self repository = aRepository! !

!IceRepositoryAnnouncement methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceRepositoryAnnouncement class methodsFor: 'instance creation' stamp: ''!
for: repository
	^ self new repository: repository; yourself! !

!IceRepositoryCommand commentStamp: ''!
I'm a generic command  for iceberg repositories.!
!IceRepositoryCommand methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	success := false! !

!IceRepositoryCommand methodsFor: 'accessing' stamp: ''!
beSuccess
	success := true! !

!IceRepositoryCommand methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceRepositoryCommand methodsFor: 'execute' stamp: ''!
execute 
	self subclassResponsibility! !

!IceRepositoryCommand methodsFor: 'testing' stamp: ''!
isSuccess
	^ success! !

!IceRepositoryCommand methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceRepositoryCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceRepositoryCommand! !

!IceRepositoryCreated commentStamp: ''!
I announce when a repository has been created.!
!IceRepositoryCreator commentStamp: ''!
I create repositories. 
I do this (trying in this order):

- with a location and url defined, I check if it can be a repository and in positive case, I answer the repository, or I can do a clone+checkout (into location) and answer the resulting repository.
- with a remote defined , I can take url and location and perform the correct actions.

You can also define  branchName to checkout a specific branch.!
!IceRepositoryCreator methodsFor: 'private - actions' stamp: ''!
addLocalRepository
	self repository location: self locationToUse.
	self repository pluginManager repositoryWillBeCreated: self repository.
			
	self repository workingCopy initializePackagesFromRepository.
	self doEnsureProject. 	

	self repository pluginManager repositoryWasCreated: self repository.
	^ self repository	! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
remote: anObject
	remote := anObject! !

!IceRepositoryCreator methodsFor: 'remotes' stamp: ''!
addRemote: aString 
	
	self remote: (IceGitRemote url: aString)! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
location
	^ location! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
location: anObject
	location := anObject! !

!IceRepositoryCreator methodsFor: 'API-project' stamp: ''!
ensureProjectFile
	ensureProjectFile := true! !

!IceRepositoryCreator methodsFor: 'actions' stamp: ''!
createRepository	
	^ [
		self validate.
		self isCloning
			ifTrue: [ self cloneRepository ]
			ifFalse: [ self addLocalRepository ] ]
	on: IceDuplicatedRepository 
	do: [ :e | 
		"This is a HACK to allow process to recover from here"
		e signal ]! !

!IceRepositoryCreator methodsFor: 'private - accessing' stamp: ''!
remoteToUse
	self remote ifNotNil: [ ^ self remote ].
	self url ifNotNil: [ ^ IceGitRemote url: self url ]. 
	^ nil! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
repository

	^ repository ifNil: [ repository := IceLibgitRepository new ]! !

!IceRepositoryCreator methodsFor: 'actions' stamp: ''!
createNewRepositoryNamed: aString
	| locationToUse  |
	self validate.
	locationToUse := self locationToUse.
	(locationToUse exists and: [ locationToUse hasChildren ])
		ifTrue: [ IceError
				signal: ('{1} is not empty.' format: {locationToUse fullName}) ].
	locationToUse ensureCreateDirectory.
	self subdirectory
		ifNotEmpty: [ (locationToUse resolve: self subdirectory) ensureCreateDirectory ].
	repository := IceLibgitRepository new
		name: aString;
		location: locationToUse;
		initBare: isBareRepository;
		yourself.
	self addProjectFileTo: repository.
	self addPropertiesFileTo: repository.
	repository workingCopy refreshProject.
	^ repository! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
url
	^ url! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
commitishName: aName
	branchName := aName! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
subdirectory: anObject
	subdirectory := anObject! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
formatToUse 
	^ IceLibgitRepository defaultFileFormat! !

!IceRepositoryCreator methodsFor: 'private' stamp: ''!
addProjectFileTo: aRepository
	
	| newProject |
	newProject := IceBasicProject onRepository: aRepository.
	newProject sourceDirectory: self subdirectory.
	aRepository workingCopy basicSetProject: newProject.! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
remote
	^ remote! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
commitishName
	^ branchName! !

!IceRepositoryCreator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	ensureProjectFile := false.
	isBareRepository := false! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
subdirectory
	^ subdirectory ifNil: [ self class defaultSubdirectory ]! !

!IceRepositoryCreator methodsFor: 'private' stamp: ''!
validateAlreadyPresentAndNotGit
	"Validate if I will add a local repository (url isNil and location isNotNil)... 
	 testing the local directory actually exists"	
	(self remoteToUse isNil
		and: [ self location notNil
		and: [ self location exists
		and: [ (self class isGitRoot: self location) not ] ] ])
		ifTrue: [ 
			IceError signal: ('"{1}" is not a git directory' format: {self location fullName}) ]
! !

!IceRepositoryCreator methodsFor: 'private' stamp: ''!
validateLocation
	(self location isNil 
		and: [ self remoteToUse isNil ])
		ifTrue: [ IceError signal: 'No location/url or remote defined.' ]! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
url: anObject
	url := anObject! !

!IceRepositoryCreator methodsFor: 'private' stamp: ''!
validateNotDuplicated
	(self remoteToUse isNotNil
		and: [ self locationToUse exists and: [ self locationToUse hasChildren ] ])
		ifTrue: [ 
			IceDuplicatedRepository signal:
					('You already have an Iceberg repository 
at {1}. 

If you really want create another one, 
please locate it in a different directory.'
						format: {self locationToUse pathString}) ]! !

!IceRepositoryCreator methodsFor: 'private - actions' stamp: ''!
addLocalRepositoryAndCheckout
	| localRepository |
	localRepository := self addLocalRepository.
	localRepository remotes 
		detect:[ :each | each referencesSameRemoteLocationAs: self remoteToUse ]
		ifFound: [ :found | localRepository fetchFrom: found ].
	localRepository switchToCommitishNamed: self commitishName.
	^ localRepository! !

!IceRepositoryCreator methodsFor: 'private' stamp: ''!
validate
	self validateLocation.
	self validateAlreadyPresentAndNotGit.
	self validateNotDuplicated! !

!IceRepositoryCreator methodsFor: 'private - testing' stamp: ''!
isCloning
	^ self remoteToUse notNil! !

!IceRepositoryCreator methodsFor: 'private - accessing' stamp: ''!
locationToUse
	^ self location ifNil: [ self defaultLocation ]! !

!IceRepositoryCreator methodsFor: 'private' stamp: ''!
addPropertiesFileTo: aRepository
	aRepository properties fileFormat: self formatToUse! !

!IceRepositoryCreator methodsFor: 'initialization' stamp: ''!
beBare

	isBareRepository := true! !

!IceRepositoryCreator methodsFor: 'private - actions' stamp: ''!
cloneRepository
	IceGitClone new
		location: self locationToUse;
		url: self remoteToUse url;
		execute.
	self repository location: self locationToUse.
		
	self commitishName 
		ifNotNil: [ self repository switchToCommitishNamed: self commitishName ].
	self repository pluginManager repositoryWillBeCreated: self repository.	

	self doEnsureProject.
	self repository workingCopy initializePackagesFromRepository.
		
	self repository pluginManager repositoryWasCreated: self repository.
	^ self repository! !

!IceRepositoryCreator methodsFor: 'private' stamp: ''!
doEnsureProject

	ensureProjectFile ifFalse: [ ^ self ].
	self repository project isUnborn ifFalse: [ ^ self ].

	self repository workingCopy project: (IceBasicProject onRepository: self repository withSourceDirectory: self subdirectory).
	self repository workingCopy refreshRepositoryProperties.
	
	"If the properties file has no format, set it the default legacy format"
	self repository workingCopy properties properties
		at: #format
		ifAbsent: [ 	self repository workingCopy properties fileFormat: (TIceRepositoryWriter users
			detect: #isLegacyDefault
			ifNone: [ Smalltalk at: #IceLibgitFiletreeWriter ]) ].
		
	self repository workingCopy refreshPackages.! !

!IceRepositoryCreator methodsFor: 'private - accessing' stamp: ''!
defaultLocation
	| remoteToUse |
	remoteToUse := self remoteToUse.
	^ IceLibgitRepository repositoriesLocation 
		/ remoteToUse organizer 
		/ remoteToUse projectName! !

!IceRepositoryCreator methodsFor: 'accessing' stamp: ''!
repository: anExistingRepository

	repository := anExistingRepository! !

!IceRepositoryCreator class methodsFor: 'accessing' stamp: ''!
defaultSubdirectory
	^ ''! !

!IceRepositoryCreator class methodsFor: 'testing' stamp: ''!
isGitRoot: aReference
	self flag: #pharoTodo. "This does not understand submodules"
	^ aReference isDirectory 
		and: [ (aReference directoriesMatching: '.git') notEmpty
		and: [ (aReference / '.git' / 'config') exists ] ]! !

!IceRepositoryForgotten commentStamp: ''!
I announce when a repository has been forgotten (removed from iceberg).!
!IceRepositoryModified commentStamp: ''!
Announces an unspecified change to a repository.!
!IceRepositoryProperties commentStamp: ''!
I'm a class to keep the filetree properties file (present in all repository). 
I can answer concrete things about repositories, e.g. : 

- which is my file format (#cypress, #tonel, etc.)
- what are my reader/write filetree files
- ...!
!IceRepositoryProperties methodsFor: 'storing' stamp: ''!
storeOnDirectory: aFileLocator root: rootDirectory

	| propertiesFileReference relativePath |
	propertiesFileReference := aFileLocator / self class propertiesFileName.
	relativePath := propertiesFileReference relativeTo: rootDirectory.
	
	propertiesFileReference resolve
		ensureDelete;
		writeStreamDo: [ :stream | 
			(STONWriter on: stream) 
				prettyPrint: true;
				newLine: OSPlatform current lineEnding;
				nextPut: self properties  ]! !

!IceRepositoryProperties methodsFor: 'comparing' stamp: ''!
= anotherObject

	^ self species = anotherObject species and: [ properties = anotherObject properties ]! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
commitish
	^ commitish! !

!IceRepositoryProperties methodsFor: 'converting' stamp: ''!
asBornProperties
	
	^ self! !

!IceRepositoryProperties methodsFor: 'comparing' stamp: ''!
hash
	^ properties hash! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
at: aKey put: aValue

	self properties at: aKey put: aValue! !

!IceRepositoryProperties methodsFor: 'writing' stamp: ''!
addToChangeBuilder: anIceChangeImporter 

	anIceChangeImporter
		addFileNamed: self propertiesFilePath segments last
		path: self propertiesFilePath
		contents: self contentsString! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
fileFormat
	^ self writerClass! !

!IceRepositoryProperties methodsFor: 'private' stamp: ''!
properties: aDictionary
	properties := aDictionary! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
propertiesFilePath
	
	^ repository project sourceDirectoryPath / self class propertiesFileName! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
fileFormatId: aFileFormatId
	
	self properties at: #format put: aFileFormatId! !

!IceRepositoryProperties methodsFor: 'initialization-release' stamp: ''!
ensureDefaultProperties
	
	properties at: #format ifAbsentPut: [ 
		self writerClass id
	]! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
at: aKey

	^ self properties at: aKey! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
commitish: anObject
	self assert: anObject isNotNil.
	commitish := anObject! !

!IceRepositoryProperties methodsFor: 'testing' stamp: ''!
isDirty
	
	^ repository workingCopy referenceCommit properties ~= self! !

!IceRepositoryProperties methodsFor: 'testing' stamp: ''!
isUnborn
	
	^ false! !

!IceRepositoryProperties methodsFor: 'private' stamp: ''!
properties
	^ properties ifNil: [ properties := Dictionary new ]! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
fileFormat: aClass
	
	self fileFormatId: aClass id! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
readerClass
	^ TIceRepositoryReader users detect: [ :each | each id = self fileFormat id  ]! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
contentsString
	
	^ ByteArray streamContents: [ :stream |
		(STONWriter on: (ZnCharacterWriteStream on: stream)) 
				prettyPrint: true;
				newLine: OSPlatform current lineEnding;
				nextPut: self properties ]! !

!IceRepositoryProperties methodsFor: 'storing' stamp: ''!
storeOnFileReference: aFileReference

	aFileReference
		ensureDelete;
		writeStreamDo: [ :stream | 
			(STONWriter on: stream) 
				prettyPrint: true;
				newLine: OSPlatform current lineEnding;
				nextPut: self properties  ]! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
writerClass
	^ self properties
		at: 'format' 
		ifPresent: [ :v | TIceRepositoryWriter users detect: [ :each | each id = v  ] ]
		ifAbsent: [ 
			commitish project isInvalid
				ifFalse: [ IceLibgitRepository defaultFileFormat ]
				ifTrue: [ TIceRepositoryWriter users
					detect: #isLegacyDefault
					ifNone: [ Smalltalk at: #IceLibgitFiletreeWriter ] ]  ]
! !

!IceRepositoryProperties methodsFor: 'accessing' stamp: ''!
repository: anIceLibgitRepository 
	repository := anIceLibgitRepository! !

!IceRepositoryProperties class methodsFor: 'instance creation' stamp: ''!
fromFileReferenceDirectory: aDirectory commitish: aCommitish

	^ self fromFileReference: aDirectory / self propertiesFileName  commitish: aCommitish! !

!IceRepositoryProperties class methodsFor: 'accessing' stamp: ''!
propertiesFileName
	^ '.properties'! !

!IceRepositoryProperties class methodsFor: 'instance creation' stamp: ''!
fromDictionary: aDictionary commitish: aCommitish
	^ self new
		repository: aCommitish repository;
		commitish: aCommitish;
		properties: aDictionary;
		ensureDefaultProperties;
		yourself! !

!IceRepositoryProperties class methodsFor: 'instance creation' stamp: ''!
readPropertiesFrom: aFileReference
	self flag: #pharoFixMe.	"When Pharo 6.1 will not be supported anymore we can directly use: `ref readStreamDo: [ :stream | STON fromStream: stream ]` but currently FileReference>>readStream return a ZnBufferedStream in Pharo 61 and a ZnCharacterReadStream decoding utf8 in Pharo 7."
	^ aFileReference
		binaryReadStreamDo: [ :stream | STON fromStream: (ZnCharacterReadStream on: stream encoding: 'utf8') ]! !

!IceRepositoryProperties class methodsFor: 'instance creation' stamp: ''!
fromFileReference: aFileReference commitish: aCommitish

	aFileReference exists
		ifFalse: [ ^ IceUnbornRepositoryProperties fromDictionary: Dictionary new commitish: aCommitish ].
	^ self fromDictionary: (self readPropertiesFrom: aFileReference) commitish: aCommitish! !

!IceRepositoryRegistryAnnouncement commentStamp: ''!
I'm a generic announcement to notify when the repository registry has changed.!
!IceRepositoryRegistryAnnouncement methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceRepositoryRegistryAnnouncement methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceRepositoryRegistryAnnouncement class methodsFor: 'instance creation' stamp: ''!
repository: aRepository
	^ self new repository: aRepository; yourself! !

!IceRepositoryRegistryModified commentStamp: ''!
I'm a generic announcement to notify when the repository registry has changed.!
!IceRepositoryRegistryModified methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceRepositoryRegistryModified methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceRepositoryRegistryModified class methodsFor: 'instance creation' stamp: ''!
repository: aRepository
	^ self new repository: aRepository; yourself! !

!IceRootDefinition commentStamp: ''!
I am an IceDefinition representing the repository root. I contain all packages, directories and files of the repository. I'm not meant to be shown.

See my superclasses for more information.!
!IceRootDefinition methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	name := ''.! !

!IceRootDefinition methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitRootDefinition: self! !

!IceRootDefinition methodsFor: 'testing' stamp: ''!
isRootDefinition
	
	^ true! !

!IceSSHProtocol methodsFor: 'url' stamp: ''!
composeUrlWithHost: host repositoryPath: path
	
	^ 'git@{1}:{2}.git' format: { host . path }! !

!IceSSHProtocol class methodsFor: 'accessing' stamp: ''!
description
	
	^ 'SSH'! !

!IceSSHProtocol class methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
githubRequestUrlKey
	
	^ #'ssh_url'! !

!IceSavedPackageVersion commentStamp: ''!
A version of a package as saved in a repository. We have one of this for each commit in a repository which modifies the specified package.

Internal representation
- commit is the commit from which I loaded this version. 
- originatingCommit is the commit in which this version was first introduced, it is useful for comparing this version to another one.

!
!IceSavedPackageVersion methodsFor: 'accessing - monticello' stamp: ''!
mcVersion

	^ commit mcVersionFor: self! !

!IceSavedPackageVersion methodsFor: 'comparing' stamp: ''!
= another
	self species = another species ifFalse: [ ^ false ].
	
	"If I both load commits are equal, we are the same version."
	^ self commit = another commit! !

!IceSavedPackageVersion methodsFor: 'patches' stamp: ''!
nextVersionName
	^ ('{1}-{2}.{3}' format: {
		self package packageName. 
		self author. 
		self info versionNumber + 1
	})
! !

!IceSavedPackageVersion methodsFor: 'comparing' stamp: ''!
hash
	^ self commit hash! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
repository
	^ self package repository! !

!IceSavedPackageVersion methodsFor: '*Iceberg-TipUI' stamp: ''!
description
	^ self commit description ! !

!IceSavedPackageVersion methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream print: self class;
		nextPut: $(;
		nextPutAll: self package name.

"	commit ifNotNil: [ 
		aStream 
		nextPutAll: ', loaded from: ';
		nextPutAll: commit shortId ]."
		
"	originatingCommit ifNotNil: [ 
		aStream 
			nextPutAll: ', committed in: ';
			nextPutAll: originatingCommit shortId ]."
		
	aStream nextPut: $).
! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
entry: anObject
	entry := anObject.
	entry repository: self repository! !

!IceSavedPackageVersion methodsFor: 'accessing - monticello' stamp: ''!
lookupSnapshot
	
	^ commit snapshotForPackage: self package! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
packageName
	^ self package name! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
commit
	^ commit! !

!IceSavedPackageVersion methodsFor: 'comparing' stamp: ''!
isNewerThan: another
	^ self info timeStamp > another info timeStamp! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
package: anObject
	package := anObject! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
entry
	^ entry! !

!IceSavedPackageVersion methodsFor: 'comparing' stamp: ''!
isAncestorOfCommitId: anotherCommitId
	^ self commit isAncestorOf: (self repository lookupCommit: anotherCommitId)
! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
info
	^ info ifNil: [ info := IceMCVersionInfo new fromCommit: self commit package: package ]! !

!IceSavedPackageVersion methodsFor: 'walk definition' stamp: ''!
hideYourselfFromCommitWalk: commitWalk
	commitWalk uptoCommit: self commit! !

!IceSavedPackageVersion methodsFor: 'patches' stamp: ''!
updated
	^ self! !

!IceSavedPackageVersion methodsFor: 'comparing' stamp: ''!
isAncestorOf: anotherVersion
	^ self commit isAncestorOf: anotherVersion commit
! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
author
	^ self info author! !

!IceSavedPackageVersion methodsFor: 'actions' stamp: ''!
merge
	self mcVersion merge
! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
commit: anIceCommit
	commit := anIceCommit ! !

!IceSavedPackageVersion methodsFor: 'accessing - monticello' stamp: ''!
snapshot
	"compatibility method"
	^ self mcSnapshot! !

!IceSavedPackageVersion methodsFor: 'accessing - monticello' stamp: ''!
mcPackage
	
	^ package mcPackage! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
info: anObject
	info := anObject! !

!IceSavedPackageVersion methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!IceSavedPackageVersion methodsFor: 'accessing - monticello' stamp: ''!
mcSnapshot

	^ self mcVersion snapshot! !

!IceSavedPackageVersion class methodsFor: 'instance creation' stamp: ''!
forPackage: package
	"Use fromCommit:package: instead"
	self shouldNotImplement ! !

!IceSavedPackageVersion class methodsFor: 'instance creation' stamp: ''!
fromCommit: commit package: package
	^ self new
		commit: commit;
		package: package;
		yourself! !

!IceSemanticVersion commentStamp: ''!
I represent the semver (http://semver.org) of libgit2. 
Since I exist just to be able to compare versions, I'm limited (reason why I'm not promoted to a more general package).
!
!IceSemanticVersion methodsFor: 'comparing' stamp: ''!
< aMagnitude 
	"Answer whether the receiver is less than the argument."
	| version |
	version := aMagnitude iceSemanticVersion.
	^ self asInteger < version asInteger
! !

!IceSemanticVersion methodsFor: 'converting' stamp: ''!
iceSemanticVersion
	^ self! !

!IceSemanticVersion methodsFor: 'comparing' stamp: ''!
= aMagnitude 
	"Compare the receiver with the argument and answer with true if the 
	receiver is equal to the argument. Otherwise answer false."
	| version |
	
	version := aMagnitude iceSemanticVersion.
	^ self asInteger = version asInteger
! !

!IceSemanticVersion methodsFor: 'accessing' stamp: ''!
minor
	^ minor! !

!IceSemanticVersion methodsFor: 'comparing' stamp: ''!
hash
	^ ((self species hash
		bitXor: self major)
		bitXor: self minor)
		bitXor: self patch
! !

!IceSemanticVersion methodsFor: 'accessing' stamp: ''!
major
	^ major! !

!IceSemanticVersion methodsFor: 'printing' stamp: ''!
printOn: stream 
	stream 
		<< self major asString 
		<< '.' << self minor asString 
		<< '.' << self patch asString! !

!IceSemanticVersion methodsFor: 'accessing' stamp: ''!
patch
	^ patch! !

!IceSemanticVersion methodsFor: 'converting' stamp: ''!
asInteger
	"this does not works for versions 0.100+.*, but I do not think it will arrive to that"
	^ (self major * 10000) 
		+ (self minor * 100)
		+ self patch! !

!IceSemanticVersion methodsFor: 'initialization' stamp: ''!
initializeMajor: majorNumber minor: minorNumber patch: patchNumber
	major := majorNumber.
	minor := minorNumber. 
	patch := patchNumber! !

!IceSemanticVersion class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use one of my siblings'! !

!IceSemanticVersion class methodsFor: 'instance creation' stamp: ''!
major: majorNumber minor: minorNumber patch: patchNumber
	^ self basicNew 
		initializeMajor: majorNumber 
			minor: minorNumber 
			patch: patchNumber;
		yourself! !

!IceSemanticVersion class methodsFor: 'instance creation' stamp: ''!
fromArray: anArray
	^ self 
		major: anArray first 
		minor: anArray second 
		patch: anArray third! !

!IceShouldCommitBeforePull commentStamp: ''!
I'm thrown when an attempt to pull was made and there are changes in the image. 
This is a resumable error because user may want to do it anyway.!
!IceShouldCommitBeforePull methodsFor: 'private' stamp: ''!
isResumable
	^ true! !

!IceShouldCommitBeforePull methodsFor: 'visiting' stamp: ''!
acceptError: anObject
	anObject visitShouldCommitBeforePullError: self! !

!IceSortingStrategy commentStamp: ''!
I am a sorting strategy taking as parameter a collection and returning the collection sorted. The user can customize the sorting to get, for example, the modified entities first or last. 


Example


	IceSortingStrategy new first: #modified; last: #notLoaded; sort: aCollection

 
Internal Representation and Key Implementation Points.

    Instance Variables
	first:		<aSymbol>		Represent the entities to display first.
	last:		<aSymbol>		Represent the entities to display last.!
!IceSortingStrategy methodsFor: 'sorting' stamp: ''!
sortByName: aCollection
	^ aCollection sorted: #packageName ascending! !

!IceSortingStrategy methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	first := #modified.
	last := #notLoaded! !

!IceSortingStrategy methodsFor: 'accessing' stamp: ''!
first: anObject
	first := anObject.
	
	(anObject ~= #none and: [ self last = anObject ])
		ifTrue: [ self last: #none ]! !

!IceSortingStrategy methodsFor: 'accessing' stamp: ''!
selectMatching: aSymbol from: aCollection
	aSymbol = #modified
		ifTrue: [ ^ aCollection select: #isModified ].
	aSymbol = #notLoaded
		ifTrue: [ ^ aCollection reject: #isLoaded ].
	self error: 'This sorting is not accepted: ' , aSymbol! !

!IceSortingStrategy methodsFor: 'accessing' stamp: ''!
last: anObject
	last := anObject.
	
	(anObject ~= #none and: [ self first = anObject ])
		ifTrue: [ self first: #none ]! !

!IceSortingStrategy methodsFor: 'sorting' stamp: ''!
sort: aListOfPackages
	| result packages lasts |
	packages := aListOfPackages.
	result := OrderedCollection new.
	self first = #none ifFalse: [ result addAll: (self sortByName: (self selectMatching: self first from: packages)) ].
	packages := packages copyWithoutAll: result.
	lasts := self last = #none ifTrue: [ {} ] ifFalse: [ self selectMatching: self last from: packages ].
	packages := packages copyWithoutAll: lasts.
	result addAll: (self sortByName: packages).
	result addAll: (self sortByName: lasts).
	^ result! !

!IceSortingStrategy methodsFor: 'accessing' stamp: ''!
first
	^ first! !

!IceSortingStrategy methodsFor: 'accessing' stamp: ''!
last
	^ last! !

!IceSortingStrategy methodsFor: 'accessing' stamp: ''!
withOthers: aSymbol 
	self first = aSymbol ifTrue: [ self first: nil ].
	self last = aSymbol ifTrue: [ self last: nil ]! !

!IceSortingStrategy class methodsFor: 'accessing' stamp: ''!
possibleValues
	^ #(#none #modified #notLoaded)! !

!IceSshCredentials commentStamp: ''!
I am a container for the credentials needed for connecting to a git repository via ssh/scp.!
!IceSshCredentials methodsFor: 'accessing' stamp: ''!
username
	^ username ifNil: [ username := self class defaultUsername ]! !

!IceSshCredentials methodsFor: 'accessing' stamp: ''!
keyPassphrase: anObject
	keyPassphrase := anObject.
	
	self storeIfDefault.! !

!IceSshCredentials methodsFor: 'accessing' stamp: ''!
privateKey
	^ privateKey ifNil: [ privateKey := self class defaultPrivateKey ]! !

!IceSshCredentials methodsFor: '*Iceberg-TipUI' stamp: ''!
editModelClass
	^ IceTipEditSSHCredentialsModel! !

!IceSshCredentials methodsFor: 'testing' stamp: ''!
isPresent
	^ self username notEmpty 
		and: [ self publicKey notEmpty 
		and: [ self privateKey notEmpty ] ]! !

!IceSshCredentials methodsFor: 'accessing' stamp: ''!
publicKey
	^ publicKey ifNil: [ publicKey := self class defaultPublicKey ]! !

!IceSshCredentials methodsFor: 'printing' stamp: ''!
description

	^ 'User: ' , self username , ' Public: ' , self publicKey , ' Private: ' , self privateKey ! !

!IceSshCredentials methodsFor: 'API - storing' stamp: ''!
storeInto: aCredentialStore forHostname: aHost

	host := aHost.
 	aCredentialStore storeSshCredential: self forHostname: aHost! !

!IceSshCredentials methodsFor: 'accessing' stamp: ''!
keyPassphrase
	^ keyPassphrase ifNil: [ keyPassphrase := '' ]! !

!IceSshCredentials methodsFor: 'printing' stamp: ''!
hostDescription
	^ host = #'*' ifTrue: [ 'Default' ] ifFalse: [ host ]! !

!IceSshCredentials methodsFor: '*Iceberg-TipUI' stamp: ''!
askForModelClass
	^ self notYetImplemented! !

!IceSshCredentials methodsFor: 'accessing' stamp: ''!
username: anObject
	username := anObject! !

!IceSshCredentials methodsFor: 'accessing' stamp: ''!
publicKey: anObject
	publicKey := anObject.
	
	self storeIfDefault.! !

!IceSshCredentials methodsFor: 'private - storing' stamp: ''!
removeFrom: aStore 

	aStore removeSSHCredential: self.! !

!IceSshCredentials methodsFor: 'testing' stamp: ''!
isDefault

	^ host = #'*'! !

!IceSshCredentials methodsFor: 'private - storing' stamp: ''!
storeIfDefault
	
	self isDefault ifFalse: [ ^ self ].
	IceCredentialStore current storeCredential: self.! !

!IceSshCredentials methodsFor: 'accessing' stamp: ''!
type
	^ 'SSH Keys'! !

!IceSshCredentials methodsFor: 'accessing' stamp: ''!
privateKey: anObject
	privateKey := anObject.
	
	self storeIfDefault.! !

!IceSshCredentials class methodsFor: 'accessing' stamp: ''!
defaultPrivateKey 	
	self flag: #pharoTodo. "In fact this is different for windows. We need to change this."
	^ (FileLocator home asFileReference / '.ssh' / 'id_rsa') pathString! !

!IceSshCredentials class methodsFor: 'accessing' stamp: ''!
defaultUsername
	^ 'git'! !

!IceSshCredentials class methodsFor: 'accessing' stamp: ''!
defaultPublicKey
	self flag: #pharoTodo. "In fact this is different for windows. We need to change this."
	^ (FileLocator home asFileReference / '.ssh' / 'id_rsa.pub') pathString! !

!IceSystemEventListener commentStamp: ''!
I am a class that listens to system events and dispatch them to the right iceberg object.
I'm mainly used to mark as dirty packages whose methods and classes are modified.

I'm implemented as class side methods to avoid memory leaks and problems when unsubscribing to events.!
!IceSystemEventListener class methodsFor: 'class initialization' stamp: ''!
initialize

	self registerSystemAnnouncements! !

!IceSystemEventListener class methodsFor: 'class initialization' stamp: ''!
unregisterSystemAnnouncements
	
	SystemAnnouncer uniqueInstance unsubscribe: self! !

!IceSystemEventListener class methodsFor: 'event handling' stamp: ''!
handleClassChange: aClassChange

	"We should take care not only about the class package but also the package of the methods extending that class."
	self handlePackagesChange: aClassChange packagesAffected
! !

!IceSystemEventListener class methodsFor: 'event handling' stamp: ''!
handleMethodChange: aMethodChange

	self handlePackagesChange: aMethodChange packagesAffected! !

!IceSystemEventListener class methodsFor: 'event handling' stamp: ''!
handleVersionLoaded: ann
	"When monticello finishes to load a package, we need to verify its status to mark them as dirty or 
	 not dirty as they apply."

	| package |
	"this is ugly, but since I do not have a package I need to look for it"
	package := RPackageOrganizer default packageMatchingExtensionName: ann label.
	
	"The package can be nil".
	package ifNil: [ ^self ].

	"now we can verify its status"
	RPackageSet withoutCacheDo: [
		IceRepository registry
			do: [ :each | 
				(each includesPackageNamed: package name)
					ifTrue: [ | icePackage isDirty |
						icePackage := each packageNamed: package name.
						self flag: #pharoTodo. "Ugly hack. Should enhance for next version"
						isDirty := each workingCopy referenceCommit isUnknownCommit
							ifTrue: [ true ]
							ifFalse: [ | diff |
								diff := each workingCopy referenceCommit diffToWorkingCopyForPackage: icePackage.
								diff includesPackageNamed: package name ].
						icePackage beDirty: isDirty.
						Iceberg announcer announce: (IceRepositoryModified for: each) ] ]]! !

!IceSystemEventListener class methodsFor: 'class initialization' stamp: ''!
registerSystemAnnouncements

	self unregisterSystemAnnouncements.
	SystemAnnouncer uniqueInstance weak
		when: ClassAnnouncement send: #handleClassChange: to: self;
		when: MethodAnnouncement send: #handleMethodChange: to: self;
		when: ClassTagAnnouncement send: #handlePackageChange: to: self;
		when: MCVersionLoaderStopped send: #handleVersionLoaded: to: self.! !

!IceSystemEventListener class methodsFor: 'event handling' stamp: ''!
handlePackagesChange: packages

	IceRepository registry do: [ :repository | | changed |
		changed := false.
		packages do: [ :each | changed := changed | (each isNotNil and: [ repository notifyPackageModified: each name ]) ].
		changed ifTrue: [ 	Iceberg announcer announce: (IceRepositoryModified for: repository) ]]! !

!IceSystemEventListener class methodsFor: 'event handling' stamp: ''!
handlePackageChange: aPackageChange

	self handlePackagesChange: aPackageChange packagesAffected! !

!IceTag commentStamp: ''!
Representation of a tag!
!IceTag methodsFor: 'API - tags' stamp: ''!
delete

	self repository removeTag: self! !

!IceTag methodsFor: 'accessing' stamp: ''!
gitRef
	^ self name! !

!IceTag methodsFor: 'accessing' stamp: ''!
fileSystem
	
	^ self commit fileSystem! !

!IceTag methodsFor: 'testing' stamp: ''!
isTag

	^ true! !

!IceTag methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceTag methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self class name;
		nextPutAll: ': ';
		print: self name! !

!IceTag methodsFor: 'querying' stamp: ''!
versionFor: package
	^ self commit versionFor: package! !

!IceTag methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!IceTag methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!IceTag methodsFor: 'querying' stamp: ''!
lastCommit
	^ self repository backend revparseCommit: self name! !

!IceTag methodsFor: 'API - history' stamp: ''!
newCommitWalk

	^ repository newCommitWalk fromTag: self! !

!IceTag methodsFor: 'accessing' stamp: ''!
versionsFor: package 
	^ self commit versionsFor: package! !

!IceTag methodsFor: 'querying' stamp: ''!
commit
	^ commit ifNil: [ commit := self repository peelTag: self ]! !

!IceTag methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceTag class methodsFor: 'instance creation' stamp: ''!
named: aTagName inRepository: anIceRepository 
	^ self new name: aTagName; repository: anIceRepository; yourself! !

!IceTagAlreadyExists methodsFor: 'accessing' stamp: ''!
tagName
	^ tagName! !

!IceTagAlreadyExists methodsFor: 'accessing' stamp: ''!
tagName: anObject
	tagName := anObject! !

!IceTagAlreadyExists methodsFor: 'accessing' stamp: ''!
messageText

	^ 'Tag {1} already exists' format: { tagName }! !

!IceTagNotFound methodsFor: 'accessing' stamp: ''!
tagName: aString 
	tagName := aString! !

!IceTipAbstractCredentialCommand commentStamp: ''!
I am the common class of all the commands over an specific credential.!
!IceTipAbstractCredentialCommand methodsFor: 'accessing' stamp: ''!
credential

	^ self item! !

!IceTipAbstractCredentialCommand methodsFor: 'accessing' stamp: ''!
store

	^ self context model! !

!IceTipAbstractCredentialCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipAbstractCredentialCommand! !

!IceTipAbstractCredentialStoreCommand commentStamp: ''!
I am the abstract class of all the general commands in the credentials list.!
!IceTipAbstractCredentialStoreCommand methodsFor: 'initialization' stamp: ''!
iconName

	^ #add! !

!IceTipAbstractCredentialStoreCommand methodsFor: 'executing' stamp: ''!
store

	^ self context store! !

!IceTipAbstractCredentialStoreCommand methodsFor: 'testing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ true! !

!IceTipAbstractCredentialStoreCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipAbstractCredentialStoreCommand! !

!IceTipAbstractCredentialsModel commentStamp: ''!
I implement the basic behavior of all the dialogs 
to ask / add / edit credentials.

There are subclasses to each of the actions and the types of keys.!
!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
askingHostname: aString

	askingHostname := aString
! !

!IceTipAbstractCredentialsModel methodsFor: 'API - opening' stamp: ''!
open

	self openModalWithSpec.
	
	^ self credentials! !

!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
credentials: anIceCredentials

	credentials := anIceCredentials.
	self refreshPresenterFromCredentials! !

!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
newCredentials
	"Answer a new instance of the credentials using the form inputs."

	^ self subclassResponsibility! !

!IceTipAbstractCredentialsModel methodsFor: 'updating' stamp: ''!
updateOkButton

	self window ifNil: [ ^ self ].
	self okButton enabled: self isOkEnabled! !

!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
hostnameFromInput
	"Answer the remoote hostname for the credentials."

	^ self subclassResponsibility! !

!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
tool: aBrowser
	"Set the tool that triggered this dialog, and therefore might need a #refresh after the users accepts the dialog and it produces an effect on the system."

	tool := aBrowser! !

!IceTipAbstractCredentialsModel methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	accepted := false! !

!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
credentialStore: aStore 
	credentialStore := aStore! !

!IceTipAbstractCredentialsModel methodsFor: 'testing' stamp: ''!
isOkEnabled
	"Determite if the user should be enabled to press on the accept button."
	
	^ self subclassResponsibility! !

!IceTipAbstractCredentialsModel methodsFor: 'actions' stamp: ''!
closeAction

	accepted ifFalse: [ self cancelAction ]! !

!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
storeCheckbox

	^ storeCheckbox! !

!IceTipAbstractCredentialsModel methodsFor: 'actions' stamp: ''!
cancelAction
	"Action to execute on cancel."! !

!IceTipAbstractCredentialsModel methodsFor: 'actions' stamp: ''!
acceptAddAction

	credentials := self newCredentials.

	credentialStore
		storeCredential: credentials
		forHostname: self hostnameFromInput.

	accepted := true.
	tool refresh! !

!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
credentials
	^ credentials! !

!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter

	super initializeDialogWindow: aDialogWindowPresenter.
	self updateOkButton.

	aDialogWindowPresenter whenClosedDo: [ accepted ifFalse: [ self cancelAskAction ] ] 
	! !

!IceTipAbstractCredentialsModel methodsFor: 'actions' stamp: ''!
acceptEditAction

	self refreshCredentialsFromPresenter.
	credentialStore storeCredential: self credentials.
	tool ifNotNil: #refresh.
	accepted := true.
	^ credentials! !

!IceTipAbstractCredentialsModel methodsFor: 'updating' stamp: ''!
okButton

	^ self window buttons first! !

!IceTipAbstractCredentialsModel methodsFor: 'actions' stamp: ''!
acceptAskAction

	credentials := self newCredentials.

	self shouldStoreCredentials ifTrue: [ 
		credentialStore
			storeCredential: credentials
			forHostname: askingHostname ].

	accepted := true.
	^ credentials! !

!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
refreshCredentialsFromPresenter
	"Hook to update the credentials object from the presenter inputs."! !

!IceTipAbstractCredentialsModel methodsFor: 'accessing' stamp: ''!
refreshPresenterFromCredentials
	"Hook to update the presenter input fields from the credentials object."! !

!IceTipAbstractCredentialsModel methodsFor: 'testing' stamp: ''!
shouldStoreCredentials

	^ storeCheckbox state! !

!IceTipAbstractCredentialsModel methodsFor: 'actions' stamp: ''!
cancelAskAction

	accepted := true.
	self closeWindow.
	LGitNoCredentialsProvided signal! !

!IceTipAbstractCredentialsModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	
	storeCheckbox := self newCheckBox
		label: 'Do you want this credentials to be stored for future use?';
		help: 'Please note that storing your credentials is handy but unsafe';
		state: true.
! !

!IceTipAbstractCredentialsModel methodsFor: 'API - opening' stamp: ''!
openNonModal

	^ self openNonModalWithSpec! !

!IceTipAbstractPlaintextCredentialsModel commentStamp: ''!
I implement the basic behavior of all the plaintext credentials.
My subclasses implements the specific behavior for each of the operations.!
!IceTipAbstractPlaintextCredentialsModel methodsFor: 'accessing - ui' stamp: ''!
usernameInput

	^ usernameInput! !

!IceTipAbstractPlaintextCredentialsModel methodsFor: 'testing' stamp: ''!
isOkEnabled

	^ self username isNotEmpty and: [ self password isNotEmpty ]! !

!IceTipAbstractPlaintextCredentialsModel methodsFor: 'accessing' stamp: ''!
newCredentials

	^ IcePlaintextCredentials new
		  username: self username;
		  password: self password;
		  yourself! !

!IceTipAbstractPlaintextCredentialsModel methodsFor: 'accessing' stamp: ''!
password

	^ passwordInput text! !

!IceTipAbstractPlaintextCredentialsModel methodsFor: 'accessing - ui' stamp: ''!
passwordInput

	^ passwordInput! !

!IceTipAbstractPlaintextCredentialsModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	usernameLabel := self newLabel label: 'Username: '.
	usernameInput := self newTextInput
		autoAccept: true;
		whenTextChangedDo: [ self updateOkButton ];
		yourself.
	passwordLabel := self newLabel label: 'Password: '.
	passwordInput := self newTextInput
		bePassword;
		autoAccept: true;
		whenTextChangedDo: [ self updateOkButton ];
		yourself.
! !

!IceTipAbstractPlaintextCredentialsModel methodsFor: 'accessing' stamp: ''!
username

	^ usernameInput text! !

!IceTipAbstractSSHCredentialsModel commentStamp: ''!
I implement the basic behavior of all the ssh credentials.
My subclasses implements the specific behavior for each of the operations.!
!IceTipAbstractSSHCredentialsModel methodsFor: 'accessing' stamp: ''!
privateKey

	^ privateKeyInput location
		  ifNil: [ '' ]
		  ifNotNil: [ :x | x pathString ]! !

!IceTipAbstractSSHCredentialsModel methodsFor: 'testing' stamp: ''!
isOkEnabled

	^ self username isNotEmpty and: [ 
		  self publicKey isNotEmpty and: [ self privateKey isNotEmpty ] ]! !

!IceTipAbstractSSHCredentialsModel methodsFor: 'accessing' stamp: ''!
publicKey

	^ publicKeyInput location
		  ifNil: [ '' ]
		  ifNotNil: [ :x | x pathString ]! !

!IceTipAbstractSSHCredentialsModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	usernameLabel := self newLabel
		label: 'Username: ';
		yourself.
	usernameInput := self newTextInput
		autoAccept: true;
		whenTextChangedDo: [ self updateOkButton ];
		yourself.
	passphraseLabel := self newLabel
		label: 'Key Passphrase: ';
		yourself.
	passphraseInput := self newTextInput
		bePassword;
		autoAccept: true;
		whenTextChangedDo: [ self updateOkButton ];
		yourself.
	privateKeyInput := IceTipFilePresenter new
		label: 'Private Key';
		onChoose: [ self updateOkButton ];
		chooseTitle: 'Select Private Key';
		whenTextChanged: [ self updateOkButton ];
		yourself.
	publicKeyInput := IceTipFilePresenter new
		label: 'Public Key';
		onChoose: [ self updateOkButton ];
		chooseTitle: 'Select Public Key';
		whenTextChanged: [ self updateOkButton ];
		yourself.
! !

!IceTipAbstractSSHCredentialsModel methodsFor: 'accessing' stamp: ''!
username

	^ usernameInput text! !

!IceTipAbstractSSHCredentialsModel methodsFor: 'accessing' stamp: ''!
passphrase

	^ passphraseInput text! !

!IceTipAction commentStamp: ''!
I'm like a lightweight command, used in general for apply concrete actions. !
!IceTipAction methodsFor: 'executing' stamp: ''!
basicExecute
	self subclassResponsibility
! !

!IceTipAction methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceTipAction methodsFor: 'executing' stamp: ''!
execute
	self withErrorHandlingDo: [ 
		self basicExecute.
		self finishSuccess ]! !

!IceTipAction methodsFor: 'accessing' stamp: ''!
onSuccess: aBlock 
	"Some actions need to execute something right after finish. Like a refresh of panels, etc.
	 If a block is defined here, it will be evaluated right after the command is executed, if 
	 there are no exceptions."
	successBlock := aBlock! !

!IceTipAction methodsFor: 'private' stamp: ''!
finishSuccess
	successBlock ifNotNil: [ successBlock value ]! !

!IceTipAction methodsFor: 'private' stamp: ''!
withErrorHandlingDo: aBlock
	aBlock
	on: IceError, IceWarning
	do: [ :e | e acceptError: (IceTipInteractiveErrorVisitor on: self repository) ].
! !

!IceTipAction methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceTipAction class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipAction! !

!IceTipAddPackageCommand commentStamp: ''!
Command that opens a dialog to add a/many package/s into the selected repository.!
!IceTipAddPackageCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #add! !

!IceTipAddPackageCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipAddPackagesDialog on: self repositoryModel) openDialogWithSpec! !

!IceTipAddPackageCommand methodsFor: 'testing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ true! !

!IceTipAddPackageCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $n meta! !

!IceTipAddPackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Adds an existing package to this repository'! !

!IceTipAddPackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Add package'! !

!IceTipAddPackagesDialog commentStamp: ''!
I'm a dialog to add packages to a repository.!
!IceTipAddPackagesDialog methodsFor: 'accessing - ui' stamp: ''!
packagesList

	^ packagesList! !

!IceTipAddPackagesDialog methodsFor: 'accessing' stamp: ''!
selectedPackage

	^ packagesList selectedItem! !

!IceTipAddPackagesDialog methodsFor: 'accessing' stamp: ''!
refresh

	packagesList items: (packageNameText text
		ifEmpty: [
			self allPackagesNotRegistered ]
		ifNotEmpty: [ :text |
			self allPackagesNotRegistered select: [ :currPackage | 
				 currPackage name asLowercase includesSubstring:
					 text asString asLowercase ] ])
! !

!IceTipAddPackagesDialog methodsFor: 'initialization' stamp: ''!
initializePackagesList

	packagesList
		addColumn:
			(SpCompositeTableColumn new
				addColumn:
					(SpCheckBoxTableColumn new
						evaluated: [ :item | selectedPackages includes: item ];
						onActivation: [ :item | selectedPackages add: item ];
						onDeactivation: [ :item | selectedPackages remove: item ifAbsent: [  ] ];
						width: 20 * self currentWorld displayScaleFactor;
						yourself);
				addColumn:
					(SpImageTableColumn new
						width: 20;
						evaluated: [ :each | self iconNamed: #package ];
						yourself);
				addColumn:
					(SpStringTableColumn new
						evaluated: #name;
						yourself);
				yourself)! !

!IceTipAddPackagesDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Add packages'! !

!IceTipAddPackagesDialog methodsFor: 'accessing' stamp: ''!
validate

	self
		assert: self selectedPackage isNotNil
		description: 'Please select a branch to checkout.'! !

!IceTipAddPackagesDialog methodsFor: 'actions' stamp: ''!
accept

	"ensure window goes away (in case accept comes from a keybinding and not the ok button)"
	self closeWindow.
	selectedPackages ifEmpty: [ 
		UIManager default inform: 'No packages selected.'.
		^ self ].
	self model addPackages: selectedPackages! !

!IceTipAddPackagesDialog methodsFor: 'accessing' stamp: ''!
model: anObject

	model := anObject.
	self refresh! !

!IceTipAddPackagesDialog methodsFor: 'initialization' stamp: ''!
initializePackageNameText

	packageNameText
		placeholder: 'Enter a package name';
		autoAccept: true;
		whenTextChangedDo: [ :text | self refresh ]! !

!IceTipAddPackagesDialog methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipAddPackagesDialog methodsFor: 'accessing' stamp: ''!
allPackagesNotRegistered

	| currentPackagesNames |
	currentPackagesNames := self model packages collect: #packageName.
	^ self allPackages reject: [ :rPackage | 
		  currentPackagesNames includes: rPackage name ]! !

!IceTipAddPackagesDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	selectedPackages := OrderedCollection new.
	packagesList := self newTable.
	packageNameText := self newTextInput.

	self initializePackagesList.
	self initializePackageNameText.

	self refresh.! !

!IceTipAddPackagesDialog methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipAddPackagesDialog methodsFor: 'accessing' stamp: ''!
allPackages

	^ RPackageOrganizer default packages
		asOrderedCollection 
		sort: [ :a :b | a name < b name ]! !

!IceTipAddPackagesDialog methodsFor: 'initialization' stamp: ''!
iconForWindow

	^ self iconNamed: #branch! !

!IceTipAddPackagesDialog methodsFor: 'accessing - ui' stamp: ''!
packageNameText

	^ packageNameText! !

!IceTipAddPackagesDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #packagesList;
		  add: #packageNameText height: self inputTextHeight! !

!IceTipAddPlainTextCredentialCommand commentStamp: ''!
I create a new plaintext credential on the credential store.!
!IceTipAddPlainTextCredentialCommand methodsFor: 'executing' stamp: ''!
execute

	IceTipAddPlaintextCredentialsModel new
		credentialStore: self store;
		tool: self tool;
		openNonModal! !

!IceTipAddPlainTextCredentialCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Add a new plain text credential'! !

!IceTipAddPlainTextCredentialCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'Plain Text'! !

!IceTipAddPlaintextCredentialsModel commentStamp: ''!
I implement the dialog to add plaintext credentials.!
!IceTipAddPlaintextCredentialsModel methodsFor: 'testing' stamp: ''!
isOkEnabled

	^ super isOkEnabled and: [ self hostnameFromInput isNotEmpty ]! !

!IceTipAddPlaintextCredentialsModel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Add new Plain Text Credential'! !

!IceTipAddPlaintextCredentialsModel methodsFor: 'testing' stamp: ''!
accept

	self acceptAddAction! !

!IceTipAddPlaintextCredentialsModel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (350 @ (self class inputTextHeight * 5 + self class buttonHeight))
		  scaledByDisplayScaleFactor! !

!IceTipAddPlaintextCredentialsModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	hostLabel := self newLabel label: 'Host: '.
	hostInput := self newTextInput
		autoAccept: true;
		whenTextChangedDo: [ self updateOkButton ];
		yourself! !

!IceTipAddPlaintextCredentialsModel methodsFor: 'accessing' stamp: ''!
hostnameFromInput

	^ hostInput text! !

!IceTipAddPlaintextCredentialsModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #hostLabel width: 80 * self currentWorld displayScaleFactor;
				add: #hostInput;
				yourself )
			height: self inputTextHeight;
		add:
			(SpBoxLayout newLeftToRight
				add: #usernameLabel width: 80 * self currentWorld displayScaleFactor;
				add: #usernameInput;
				yourself )
			height: self inputTextHeight;
		add:
			(SpBoxLayout newLeftToRight
				add: #passwordLabel width: 80 * self currentWorld displayScaleFactor;
				add: #passwordInput;
				yourself )
			height: self inputTextHeight;
		yourself! !

!IceTipAddRemoteCommand commentStamp: ''!
Command that opens a dialog to add a remote to a repository.!
!IceTipAddRemoteCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #add! !

!IceTipAddRemoteCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipAddRemoteDialog on: self repositoryModel) openDialogWithSpec! !

!IceTipAddRemoteCommand methodsFor: 'testing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ true! !

!IceTipAddRemoteCommand methodsFor: 'executing' stamp: ''!
canBeExecuted
	"Any repository can have more remotes."

	^ true! !

!IceTipAddRemoteCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Adds a remote to this repository'! !

!IceTipAddRemoteCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Add remote'! !

!IceTipAddRemoteDialog commentStamp: ''!
I'm a dialog to add remotes to a repository.!
!IceTipAddRemoteDialog methodsFor: 'accessing - ui' stamp: ''!
nameText

	^ nameText! !

!IceTipAddRemoteDialog methodsFor: 'events' stamp: ''!
onAccept: aBlock

	acceptBlock := aBlock! !

!IceTipAddRemoteDialog methodsFor: 'accessing - ui' stamp: ''!
urlLabel

	^ urlLabel! !

!IceTipAddRemoteDialog methodsFor: 'accessing - ui' stamp: ''!
urlText

	^ urlText! !

!IceTipAddRemoteDialog methodsFor: 'accessing' stamp: ''!
remoteUrl

	^ self urlText text trimmed! !

!IceTipAddRemoteDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Add remote'! !

!IceTipAddRemoteDialog methodsFor: 'actions' stamp: ''!
validate

	self
		assert: self remoteName notEmpty 
		description: 'You need to specify a remote name.'.
	self
		assert: self remoteUrl notEmpty
		description: 'You need to specify a remote url.'
! !

!IceTipAddRemoteDialog methodsFor: 'accessing' stamp: ''!
remoteName

	^ self nameText text trimmed! !

!IceTipAddRemoteDialog methodsFor: 'accessing - ui' stamp: ''!
nameLabel

	^ nameLabel! !

!IceTipAddRemoteDialog methodsFor: 'actions' stamp: ''!
accept

	self validate.
	self model 
		addRemoteNamed: self remoteName 
		url: self remoteUrl.
	^ acceptBlock ifNotNil: [ acceptBlock cull: self remoteName ]! !

!IceTipAddRemoteDialog methodsFor: 'accessing' stamp: ''!
model: anObject

	model := anObject! !

!IceTipAddRemoteDialog methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipAddRemoteDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (500@(
		self class inputTextHeight * 2
		+ self class buttonHeight 
		+ 50 "Yes, a magic number"
		)) scaledByDisplayScaleFactor! !

!IceTipAddRemoteDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	nameLabel := self newLabel
		label: 'Remote name';
		yourself.
	nameText := self newTextInput
		placeholder: 'e.g., user-remote';
		autoAccept: true;
		yourself.
	urlLabel := self newLabel
		label: 'Remote URL';
		yourself.
	urlText := self newTextInput
		placeholder: 'e.g., git@github.com:user/project.git';
		autoAccept: true;
		yourself.
! !

!IceTipAddRemoteDialog methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipAddRemoteDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #nameLabel width: self labelWidth;
				   add: #nameText;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #urlLabel width: self labelWidth;
				   add: #urlText;
				   yourself)
		  height: self inputTextHeight;
		  yourself! !

!IceTipAddRepositoryCommand commentStamp: ''!
I register Iceberg projects.
I will open a dialog to take the new possible repository (from available options) and I will register it into the IceRepository>>#registry list.!
!IceTipAddRepositoryCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #add! !

!IceTipAddRepositoryCommand methodsFor: 'executing' stamp: ''!
execute

	IceTipRegisterRepositoryDialog new openDialogWithSpec! !

!IceTipAddRepositoryCommand methodsFor: 'testing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ true! !

!IceTipAddRepositoryCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $n meta! !

!IceTipAddRepositoryCommand methodsFor: 'testing' stamp: ''!
canBeExecuted 
	
	"This command can be executed with our without selection"
	^ true! !

!IceTipAddRepositoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Add a repository (new, local, cloned) to your managed repositories.'! !

!IceTipAddRepositoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Add'! !

!IceTipAddSSHCredentialsModel commentStamp: ''!
I implement the dialog to add SSH credentials.!
!IceTipAddSSHCredentialsModel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Add SSH credential'! !

!IceTipAddSSHCredentialsModel methodsFor: 'accessing' stamp: ''!
newCredentials
	
	^ IceSshCredentials new
		username: self username;
		publicKey: self publicKey;
		privateKey: self privateKey;
		keyPassphrase: self passphrase;
		yourself ! !

!IceTipAddSSHCredentialsModel methodsFor: 'actions' stamp: ''!
accept

	self acceptAddAction! !

!IceTipAddSSHCredentialsModel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (350 @ (self class inputTextHeight * 7 + self class buttonHeight))
		  scaledByDisplayScaleFactor! !

!IceTipAddSSHCredentialsModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	hostLabel := self newLabel
		label: 'Host: ';
		yourself.
	hostInput := self newTextInput
		autoAccept: true;
		whenTextChangedDo: [ self updateOkButton ];
		yourself! !

!IceTipAddSSHCredentialsModel methodsFor: 'accessing' stamp: ''!
hostnameFromInput
	
	^ hostInput text! !

!IceTipAddSSHCredentialsModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #hostLabel width: self labelWidth;
				   add: #hostInput;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #usernameLabel width: self labelWidth;
				   add: #usernameInput;
				   yourself)
		  height: self inputTextHeight;
		  add: #publicKeyInput height: self inputTextHeight;
		  add: #privateKeyInput height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #passphraseLabel width: self labelWidth;
				   add: #passphraseInput;
				   yourself)
		  height: self inputTextHeight! !

!IceTipAddSshCredentialCommand commentStamp: ''!
I add a new IceSshCredentials to the store!
!IceTipAddSshCredentialCommand methodsFor: 'execution' stamp: ''!
execute

	IceTipAddSSHCredentialsModel new
		credentialStore: self store;
		tool: self tool;
		openNonModal! !

!IceTipAddSshCredentialCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Add a SSH pair of credential'! !

!IceTipAddSshCredentialCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'SSH Pair'! !

!IceTipAddTokenCredentialCommand methodsFor: 'executing' stamp: ''!
execute

	IceTipAddTokenCredentialsModel new
		credentialStore: self store;
		tool: self tool;
		openNonModal! !

!IceTipAddTokenCredentialCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Add a new token credential'! !

!IceTipAddTokenCredentialCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'Token'! !

!IceTipAddTokenCredentialsModel commentStamp: ''!
I am a dialog to add token credentials.!
!IceTipAddTokenCredentialsModel methodsFor: 'testing' stamp: ''!
isOkEnabled

	^ self usernameFromInput isNotEmpty and: [ 
		  self hostnameFromInput isNotEmpty and: [ 
			  self tokenFromInput isNotEmpty ] ]! !

!IceTipAddTokenCredentialsModel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Add token credentials'! !

!IceTipAddTokenCredentialsModel methodsFor: 'accessing' stamp: ''!
newCredentials
	
	^ IceTokenCredentials new
		username: self usernameFromInput;
		token: self tokenFromInput;
		host: self hostnameFromInput;
		yourself ! !

!IceTipAddTokenCredentialsModel methodsFor: 'accessing' stamp: ''!
accept

	self acceptAddAction! !

!IceTipAddTokenCredentialsModel methodsFor: 'accessing' stamp: ''!
tokenFromInput
	
	^ tokenInput text! !

!IceTipAddTokenCredentialsModel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (350 @ (self class inputTextHeight * 5 + self class buttonHeight)) scaledByDisplayScaleFactor! !

!IceTipAddTokenCredentialsModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	usernameLabel := self newLabel
		label: 'Username: ';
		yourself.
	usernameInput := self newTextInput
		autoAccept: true;
		whenTextChangedDo: [ self updateOkButton ];
		yourself.

	hostLabel := self newLabel
		label: 'Host: ';
		yourself.
	hostInput := self newTextInput
		placeholder: 'github.com';
		autoAccept: true;
		whenTextChangedDo: [ self updateOkButton ];
		yourself.

	tokenLabel := self newLabel
		label: 'Token: ';
		yourself.
	tokenInput := self newTextInput
		bePassword;
		autoAccept: true;
		whenTextChangedDo: [ self updateOkButton ];
		yourself.
! !

!IceTipAddTokenCredentialsModel methodsFor: 'accessing' stamp: ''!
hostnameFromInput
	
	^ hostInput text! !

!IceTipAddTokenCredentialsModel methodsFor: 'accessing' stamp: ''!
usernameFromInput
	
	^ usernameInput text! !

!IceTipAddTokenCredentialsModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #usernameLabel width: self labelWidth;
				   add: #usernameInput;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #hostLabel width: self labelWidth;
				   add: #hostInput;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #tokenLabel width: self labelWidth;
				   add: #tokenInput;
				   yourself)
		  height: self inputTextHeight;
		  yourself! !

!IceTipAdoptCommitCommand commentStamp: ''!
I'm a command that sets a commit as the commit of a working copy. 

I won't modify the loaded code, but will calculate the differences between the
loaded packages and the new commit, to mark packages as dirty.!
!IceTipAdoptCommitCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #recoverLostChanges! !

!IceTipAdoptCommitCommand methodsFor: 'accessing' stamp: ''!
defaultNameFromContext

	^ 'Adopt commit ' , self selectedCommitish shortId! !

!IceTipAdoptCommitCommand methodsFor: 'executing' stamp: ''!
execute
	
	self selectedCommitish adopt.
	Iceberg announcer announce: (IceRepositoryModified for: self repository)! !

!IceTipAdoptCommitCommand methodsFor: 'initialization' stamp: ''!
name
	"Answer the name for the command. In order to have a specialized string for certain parameters of the context, and given the fact that sometimes the context is nil (e.g. when a context menu is calculated when the selection is empty)."

	self flag: #pharoTodo. "Find another solution (problem explained above)"
	^ self context
		  ifNil: [ self className ]
		  ifNotNil: [ self defaultNameFromContext ]! !

!IceTipAdoptCommitCommand methodsFor: 'accessing' stamp: ''!
selectedCommitish

	^ self item! !

!IceTipAdoptCommitCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Sets this commit as the commit of your working copy. It will not modify your loaded code, but it will calculate the differences between your loaded packages and the the new commit to mark packages as dirty.'! !

!IceTipAnnouncement commentStamp: ''!
I'm a general announcement for Tip UI events.
(the announcements happened here are just for UI consumption)!
!IceTipAskForPlaintextCredentialsModel commentStamp: ''!
I implement the dialog to ask plaintext credentials.
This dialog is used when the IceTipInteractiveCredentialsProvider needs to ask a plaintext credential.!
!IceTipAskForPlaintextCredentialsModel methodsFor: 'actions' stamp: ''!
cancel

	self cancelAskAction! !

!IceTipAskForPlaintextCredentialsModel methodsFor: 'actions' stamp: ''!
cancelAction

	self cancelAskAction! !

!IceTipAskForPlaintextCredentialsModel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Please log in to ' , askingHostname! !

!IceTipAskForPlaintextCredentialsModel methodsFor: 'actions' stamp: ''!
accept

	^ self acceptAskAction! !

!IceTipAskForPlaintextCredentialsModel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (350 @ (self class inputTextHeight * 5 + self class buttonHeight))
		  scaledByDisplayScaleFactor! !

!IceTipAskForPlaintextCredentialsModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #usernameLabel
				   width: 80 * self currentWorld displayScaleFactor;
				   add: #usernameInput;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #passwordLabel
				   width: 80 * self currentWorld displayScaleFactor;
				   add: #passwordInput;
				   yourself)
		  height: self inputTextHeight;
		  add: #storeCheckbox height: self inputTextHeight! !

!IceTipAskForPlaintextOtpCredentialsModel methodsFor: 'accessing' stamp: ''!
newCredentials

	^ IcePlaintextOtpCredentials new
		  username: self username;
		  password: self password;
		  token: self token;
		  yourself! !

!IceTipAskForPlaintextOtpCredentialsModel methodsFor: 'accessing' stamp: ''!
token

	^ tokenInput text! !

!IceTipAskForPlaintextOtpCredentialsModel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (350 @ (self class inputTextHeight * 6 + self class buttonHeight))
		  scaledByDisplayScaleFactor! !

!IceTipAskForPlaintextOtpCredentialsModel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	tokenLabel := self newLabel label: 'OTP Token: '.
	tokenInput := self newTextInput
		bePassword;
		autoAccept: true;
		whenTextChangedDo: [ self updateOkButton ];
		yourself! !

!IceTipAskForPlaintextOtpCredentialsModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #usernameLabel width: 80 * self currentWorld displayScaleFactor;
				add: #usernameInput;
				yourself )
			height: self inputTextHeight;
		add:
			(SpBoxLayout newLeftToRight
				add: #passwordLabel width: 80 * self currentWorld displayScaleFactor;
				add: #passwordInput;
				yourself )
			height: self inputTextHeight;
		add:
			(SpBoxLayout newLeftToRight
				add: #tokenLabel width: 80 * self currentWorld displayScaleFactor;
				add: #tokenInput;
				yourself )
			height: self inputTextHeight;
		add: #storeCheckbox height: self inputTextHeight
! !

!IceTipAskSSHCredentialsModel commentStamp: ''!
I am a dialog to ask for SSH credentials.!
!IceTipAskSSHCredentialsModel methodsFor: 'actions' stamp: ''!
cancelAction

	self cancelAskAction! !

!IceTipAskSSHCredentialsModel methodsFor: 'accessing' stamp: ''!
newCredentials

	self refreshCredentialsFromPresenter.
	^ credentials! !

!IceTipAskSSHCredentialsModel methodsFor: 'actions' stamp: ''!
accept

	^ self acceptAskAction! !

!IceTipBitbucketRepositoryPanel commentStamp: ''!
I'm a panel to show and/or manipulate a project definition in a BitBucket git repository.!
!IceTipBitbucketRepositoryPanel methodsFor: 'actions' stamp: ''!
configureBuilder: aBuilder

	aBuilder beBitbucket! !

!IceTipBitbucketRepositoryPanel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Clone From bitbucket.org'! !

!IceTipBitbucketRepositoryPanel methodsFor: 'accessing' stamp: ''!
providerName

	^ 'Bitbucket'! !

!IceTipBitbucketRepositoryPanel methodsFor: 'initialization' stamp: ''!
iconForWindow

	^ self iconNamed: #bitbucket! !

!IceTipBitbucketRepositoryPanel class methodsFor: 'accessing' stamp: ''!
order

	^ 110! !

!IceTipBranchModel commentStamp: ''!
I expose data of a branch.!
!IceTipBranchModel methodsFor: 'actions' stamp: ''!
switchAndMergeThen: aBlock
	<noCache>

	IceTipStandardAction new
		repository: self entity repository; 
		message: ('Merging branch {1} from {2}' format: { self name. self repositoryName });
		onSuccessRepositoryModified;
		onSuccess: aBlock;
		execute: [ self entity switchAndMergeWorkingCopy ]! !

!IceTipBranchModel methodsFor: 'accessing' stamp: ''!
checkoutStrategies
	^ IceCheckoutStrategy allStrategies! !

!IceTipBranchModel methodsFor: 'actions' stamp: ''!
delete
	<noCache>
	
	IceTipStandardAction new
		repository: self repositoryModel entity;
		message: ('Removing branch {1}' format: { self name });
		onSuccessRepositoryModified;
		execute: [ self entity delete ]! !

!IceTipBranchModel methodsFor: 'testing' stamp: ''!
isHead
	^ self entity isHead! !

!IceTipBranchModel methodsFor: 'testing' stamp: ''!
isLocal
	^ self entity isLocal! !

!IceTipBranchModel methodsFor: 'accessing' stamp: ''!
shortDescriptionWithDecoration
	^ self addDecorationTo: (self entity isRemote 
		ifTrue: [ self name copyAfter: $/ ]
		ifFalse: [ self name])! !

!IceTipBranchModel methodsFor: 'accessing' stamp: ''!
commits
	self shouldBeImplemented.! !

!IceTipBranchModel methodsFor: 'actions' stamp: ''!
mergeThen: aBlock
	<noCache>

	IceTipStandardAction new 
		repository: self repositoryModel entity;
		message: ('Merging branch {1} from {2}' format: { self name. self repositoryName });
		onSuccessRepositoryModified;
		onSuccess: aBlock;
		execute: [ self entity merge ]! !

!IceTipBranchModel methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	^ self addDecorationTo: (self entity isRemote 
		ifTrue: [ self entity shortName ]
		ifFalse: [ self name ])! !

!IceTipBranchModel methodsFor: 'actions' stamp: ''!
previewMerge: aMergeType
	"this will open a 'checkout browser' that will allow user to validate the changes before 
	 actually checking out (checkout operation will be called in my sibling method, #checkout)"
	<noCache>
	(IceTipMergePreviewBrowser onBranch: self) 
		mergeType: aMergeType;
		openWithSpec! !

!IceTipBranchModel methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $[;
		nextPutAll: self name;
		nextPut: $]! !

!IceTipBranchModel methodsFor: 'actions' stamp: ''!
checkoutWithStrategy: aCheckoutStrategy then: aBlock
	<noCache>
	
	IceTipStandardAction new 
		repository: self entity repository; 
		message: ('Checking out branch {1} from {2}' format: { self name. self repositoryName });
		onSuccessRepositoryModified;
		onSuccess: aBlock;
		execute: [ self entity checkoutWithStrategy: aCheckoutStrategy ]! !

!IceTipBranchModel methodsFor: 'API - commits' stamp: ''!
resetToCommit: anIceTipCachedModel 
	
	entity resetToCommit: anIceTipCachedModel entity! !

!IceTipBranchModel methodsFor: 'accessing' stamp: ''!
diffToWorkingCopy
	| commitModel |
	commitModel := IceTipCommitModel on: self entity commit.
	^ commitModel diffToWorkingCopy! !

!IceTipBranchModel methodsFor: 'accessing' stamp: ''!
name
	^ self entity name! !

!IceTipBranchModel methodsFor: 'accessing' stamp: ''!
commitModels
	| commits |
	commits := OrderedCollection new.
	self entity commitsDo: [ :each | 
		commits add: (IceTipCommitModel 
			repositoryModel: self repositoryModel 
			on: each) 
			beCached ].
	^ commits! !

!IceTipBranchModel methodsFor: 'testing' stamp: ''!
hasUpstream
	
	^ entity hasUpstream! !

!IceTipBranchModel methodsFor: 'actions' stamp: ''!
previewCheckout
	"this will open a 'checkout browser' that will allow user to validate the changes before 
	 actually checking out (checkout operation will be called in my sibling method, #checkout)"
	<noCache>

	(IceTipCheckoutPreviewBrowser onBranch: self) openWithSpec! !

!IceTipBranchModel methodsFor: 'private' stamp: ''!
addDecorationTo: aString
	| text |
	text := aString asText.
	[ 
		self entity isHead ifTrue: [ text := text allBold ] ]
	on: IceNotInBranch do: [ :e | "Do not decorate" ].
	^ text! !

!IceTipBranchModel methodsFor: 'accessing' stamp: ''!
repositoryName
	^ self repositoryModel name! !

!IceTipBranchModel methodsFor: 'accessing' stamp: ''!
diffFromHead
	| commitModel |
	commitModel := IceTipCommitModel on: self entity commit.
	^ commitModel diffFromHead! !

!IceTipBranchPanel commentStamp: ''!
I'm a generic panel to checkout panels. 
My children will define different strategies to checkout (select an existing branch -local or remote-, or enter a new branch name)!
!IceTipBranchPanel methodsFor: 'testing' stamp: ''!
isNewBranch

	^ false! !

!IceTipBranchPanel methodsFor: 'events' stamp: ''!
onAccept: aBlock

	acceptBlock := aBlock! !

!IceTipBranchPanel methodsFor: 'accessing' stamp: ''!
validate
	^ self subclassResponsibility! !

!IceTipBranchPanel methodsFor: 'actions' stamp: ''!
doAccept

	self subclassResponsibility! !

!IceTipBranchPanel methodsFor: 'accessing' stamp: ''!
icon

	^ self subclassResponsibility! !

!IceTipBranchPanel methodsFor: 'actions' stamp: ''!
accept

	self validate.
	self doAccept.
	acceptBlock ifNotNil: [ acceptBlock cull: self ]! !

!IceTipBranchPanel methodsFor: 'accessing' stamp: ''!
model: anObject

	model := anObject! !

!IceTipBranchPanel methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipBranchPanel methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipBranchPanel class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository

	^ self on: (IceTipRepositoryModel on: aRepository) beCached! !

!IceTipBrowseCommand commentStamp: ''!
I'm a command to "browse" a change definition (method, class or package).!
!IceTipBrowseCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #smallSystemBrowser! !

!IceTipBrowseCommand methodsFor: 'executing' stamp: ''!
execute

	self item value definition browse! !

!IceTipBrowseCommand methodsFor: 'activation' stamp: ''!
shortcutKey

	^ $b meta! !

!IceTipBrowseCommand methodsFor: 'executing' stamp: ''!
canBeExecuted

	^ self hasSelectedItem
! !

!IceTipBrowseCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Browse the selected item'! !

!IceTipBrowseCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Browse...'! !

!IceTipBrowsePackageCommand commentStamp: ''!
Command that browses the selected package as it is loaded in the image.!
!IceTipBrowsePackageCommand methodsFor: 'executing' stamp: ''!
execute

	self packageModel browsePackage! !

!IceTipBrowsePackageCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $b meta! !

!IceTipBrowsePackageCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ super canBeExecuted and: [ self isPackageLoaded ]! !

!IceTipBrowsePackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Browse the selected package as it is loaded in the image'! !

!IceTipBrowsePackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Browse'! !

!IceTipBrowseRepositoryPackageVersionCommand commentStamp: ''!
Command that opens a browser on the code of the repository.

The current implementation relies on a monticello MCSnapshotBrowser!
!IceTipBrowseRepositoryPackageVersionCommand methodsFor: 'executing' stamp: ''!
execute

	self packageModel browseRepositoryVersion! !

!IceTipBrowseRepositoryPackageVersionCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Browse the version in the repository'! !

!IceTipBrowseRepositoryPackageVersionCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Browse this version in Monticello'! !

!IceTipBrowser commentStamp: ''!
I'm the superclass of Spec2 browsers in Iceberg Tip-UI. Each concrete subclass has some kind
of list or table that contain the items that are being browsed.

Some design remarks: 

* Each browser has to have ONE model as entry point for data, and JUST ONE. See #model accessor.
* Browsers have a toolbar with commands that are applicable for the model.
* Browsers have a context menu on list or table items, that provide commands that are specific for the selection.!
!IceTipBrowser methodsFor: 'accessing' stamp: ''!
repositoryModel
	"Answer the IceTipRepositoryModel associated to this presenter."

	^ self model repositoryModel! !

!IceTipBrowser methodsFor: 'commands' stamp: ''!
refreshMainListContextMenuWith: rootGroup
	"Update context menu (for mainList)."

	rootGroup
		commandOrGroupNamed: self class selectionCommandGroupName
		ifFound: [ :subgroup |
			self mainList contextMenuFromCommandsGroup: subgroup ].! !

!IceTipBrowser methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self subscribeToAnnouncements! !

!IceTipBrowser methodsFor: 'accessing' stamp: ''!
selectedItem
	"Answer the object selected in the main list of this browser. The answer is nil when there isn't a selection."

	^ self mainList selection selectedItem! !

!IceTipBrowser methodsFor: 'accessing - ui' stamp: ''!
toolbar

	^ toolbar! !

!IceTipBrowser methodsFor: 'accessing' stamp: ''!
refresh
	"Update the UI elements given a possible update in the model."! !

!IceTipBrowser methodsFor: 'commands' stamp: ''!
refreshShortcutsWith: rootGroup
	"Update shortcuts with available commands"

	self window 
		ifNotNil: [ :aWindow | 
			rootGroup installShortcutsIn: aWindow]
	
! !

!IceTipBrowser methodsFor: 'initialization' stamp: ''!
defaultKeyboardFocus

	^ self mainList! !

!IceTipBrowser methodsFor: 'testing' stamp: ''!
hasSelectedItem
	
	^ self mainList selection isEmpty not! !

!IceTipBrowser methodsFor: 'commands' stamp: ''!
refreshCommands

	| rootGroup |
	rootGroup := self rootCommandsGroup.
	IceTipCleanCommandGroupVisitor new visit: rootGroup.

	self
		refreshShortcutsWith: rootGroup;
		refreshMainListContextMenuWith: rootGroup;
		refreshToolbarWith: rootGroup.
! !

!IceTipBrowser methodsFor: 'commands' stamp: ''!
refreshToolbarWith: rootGroup
	"Update toolbar (in window)."

	self hasWindow ifFalse: [ ^ self ].
	toolbar := nil.

	rootGroup
		commandOrGroupNamed: self class generalCommandGroupName
		ifFound: [ :subgroup | 
			| builder |
			subgroup beRoot.
			builder := IceTipToolbarPresenterBuilder new.
			builder visit: subgroup.

			builder toolbarPresenter
				displayMode: SpToolbarDisplayMode modeIconAndLabel;
				addStyle: 'stToolbar'.
			builder toolbarPresenter isEmpty ifFalse: [
				toolbar := builder toolbarPresenter ] ].

	self window toolbar: toolbar! !

!IceTipBrowser methodsFor: 'accessing' stamp: ''!
model: anObject

	model := anObject! !

!IceTipBrowser methodsFor: 'initialization' stamp: ''!
initializeWindow: aSpWindowPresenter

	super initializeWindow: aSpWindowPresenter.

	self refreshCommands. "This adds the toolbar, if not empty."
! !

!IceTipBrowser methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (600 @ 400) scaledByDisplayScaleFactor! !

!IceTipBrowser methodsFor: 'initialization' stamp: ''!
subscribeToAnnouncements! !

!IceTipBrowser methodsFor: 'initialization' stamp: ''!
connectPresenters

	super connectPresenters.
	self mainList whenSelectionChangedDo: [ self refreshCommands ]! !

!IceTipBrowser methodsFor: 'initialization' stamp: ''!
iconForWindow

	^ self iconNamed: #komitterSmalltalkhubRemote! !

!IceTipBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList
	"Answer the presenter that is the main list of items of this browser."

	^ self subclassResponsibility! !

!IceTipBrowser methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	self subclassResponsibility! !

!IceTipBrowser class methodsFor: 'commands' stamp: ''!
selectionCommandGroupName

	^ 'Selection'! !

!IceTipBrowser class methodsFor: 'commands' stamp: ''!
selectionExtraCommandGroupName

	^ 'Extra'! !

!IceTipBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionExtraCommandGroupWith: presenter for: aCommandGroup

	aCommandGroup register: IceTipInspectCommand forSpec! !

!IceTipBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	self subclassResponsibility! !

!IceTipBrowser class methodsFor: 'commands' stamp: ''!
buildCommandsGroupWith: presenter forRoot: aCommandGroup

	| generalCommandGroup selectionCommandGroup selectionExtraCommandGroup |
	selectionCommandGroup :=
		(CmCommandGroup named: self selectionCommandGroupName) asSpecGroup.
	selectionExtraCommandGroup :=
		(CmCommandGroup named: self selectionExtraCommandGroupName) asSpecGroup.
	generalCommandGroup := 
		(CmCommandGroup named: self generalCommandGroupName) asSpecGroup.

	aCommandGroup
		register: selectionCommandGroup;
		register: generalCommandGroup.
		
	self
		buildSelectionCommandGroupWith: presenter for: selectionCommandGroup;
		buildSelectionExtraCommandGroupWith: presenter for: selectionExtraCommandGroup;
		buildGeneralCommandGroupWith: presenter for: generalCommandGroup.

	selectionCommandGroup register: selectionExtraCommandGroup.
! !

!IceTipBrowser class methodsFor: 'commands' stamp: ''!
generalCommandGroupName

	^ 'General'! !

!IceTipCache commentStamp: ''!
I'm a cache that can be reseted when some announcements arrive. 
I'm used to cache values to be used on the UI.

I can be reseted (sending #reset), but responsibility of reset caches belongs to presenters who use them.!
!IceTipCache methodsFor: 'accessing' stamp: ''!
proxy
	^ proxy! !

!IceTipCache methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self reset! !

!IceTipCache methodsFor: 'accessing' stamp: ''!
at: aKey put: anObject
	^ objects 
		at: aKey 
		put: anObject! !

!IceTipCache methodsFor: 'accessing' stamp: ''!
at: aKey ifPresent: anObject
	^ objects 
		at: aKey 
		ifPresent: anObject! !

!IceTipCache methodsFor: 'accessing' stamp: ''!
proxy: anObject
	proxy := anObject! !

!IceTipCache methodsFor: 'accessing' stamp: ''!
at: aKey ifAbsent: anObject
	^ objects 
		at: aKey 
		ifAbsent: anObject! !

!IceTipCache methodsFor: 'accessing' stamp: ''!
at: aKey ifAbsentPut: anObject
	^ objects 
		at: aKey 
		ifAbsentPut: anObject! !

!IceTipCache methodsFor: 'accessing' stamp: ''!
objects
	^ objects! !

!IceTipCache methodsFor: 'initialization' stamp: ''!
reset
	objects := SmallDictionary new! !

!IceTipCache class methodsFor: 'instance creation' stamp: ''!
proxy: aProxy 
	^ self new proxy: aProxy ! !

!IceTipCachedModel commentStamp: ''!
I'm a cached model. 
I take all unary messages sent to my realObject and I cache their values. 
I keep a cache with rules for reset it, which can be accessedon the #resetOn: family of messages.!
!IceTipCachedModel methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	aMessage selector isUnary
		ifTrue: [ 
			cache 
				at: aMessage selector
				ifPresent: [ :value | ^ value ].
			 (self realObject class lookupSelector: aMessage selector)
				ifNotNil: [ :method |
					(method hasPragmaNamed: #noCache)
						ifFalse: [ 
							^ cache
								at: aMessage selector 
								put: (self forwardMessage: aMessage) ] ] ].
	^ self forwardMessage: aMessage! !

!IceTipCachedModel methodsFor: 'reflective operations' stamp: ''!
forwardMessage: aMessage
	^ realObject 
		perform: aMessage selector 
		withArguments: aMessage arguments ! !

!IceTipCachedModel methodsFor: 'comparing' stamp: ''!
= aObject

	self species ~= aObject species ifTrue: [ ^ false ].
	^ self realObject = aObject realObject! !

!IceTipCachedModel methodsFor: 'comparing' stamp: ''!
hash

	^ self realObject hash! !

!IceTipCachedModel methodsFor: 'accessing' stamp: ''!
realObject
	^ realObject! !

!IceTipCachedModel methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	self realObject printOn: aStream.
	aStream nextPut: $)! !

!IceTipCachedModel methodsFor: 'initialization' stamp: ''!
initializeObject: anObject
	realObject := anObject.
	cache := IceTipCache proxy: self.
	self initialize! !

!IceTipCachedModel methodsFor: 'accessing' stamp: ''!
reset
	cache reset! !

!IceTipCachedModel class methodsFor: 'instance creation' stamp: ''!
for: anObject
	^ self basicNew initializeObject: anObject! !

!IceTipCalculateDirtyPackagesCommand commentStamp: ''!
I'm a command that makes a working copy to recalculate the dirty packages (via #forceCalculateDirtyPackages).!
!IceTipCalculateDirtyPackagesCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #repair! !

!IceTipCalculateDirtyPackagesCommand methodsFor: 'executing' stamp: ''!
execute

	IceTipStandardAction new
		repository: self item entity;
		message: 'Recalculating Dirty Packages';
		onSuccessRepositoryModified;
		execute: [
			self item entity workingCopy forceCalculateDirtyPackages ]
! !

!IceTipCalculateDirtyPackagesCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self hasSelectedItem
! !

!IceTipCalculateDirtyPackagesCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Recalculate dirty packages'! !

!IceTipCheckoutBranchCommand commentStamp: ''!
Command that opens a dialog to checkout a (new or already existing) branch.!
!IceTipCheckoutBranchCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #branch! !

!IceTipCheckoutBranchCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipCheckoutBranchDialog on: self repositoryModel)
		openDialogWithSpec! !

!IceTipCheckoutBranchCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ super canBeExecuted and: [ self isRepositoryMissing not]! !

!IceTipCheckoutBranchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultToolbarItemName

	^ 'Branch'! !

!IceTipCheckoutBranchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Checkout a new or existing branch.'! !

!IceTipCheckoutBranchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Checkout branch'! !

!IceTipCheckoutBranchDialog commentStamp: ''!
I'm a dialog to perform a checkout of a branch.

(self onRepository: IceRepository registry anyOne) openDialogWithSpec!
!IceTipCheckoutBranchDialog methodsFor: 'accessing' stamp: ''!
allTypes

	^ types ifNil: [ types := self createCheckoutBranchTypes ]! !

!IceTipCheckoutBranchDialog methodsFor: 'private - factory' stamp: ''!
createCheckoutBranchTypes

	| allTypes |
	"Collect types new+local+remotes"	
	allTypes :=  { 
		IceTipCheckoutNewBranchPanel on: self model. "New branch"
	 	(IceTipCheckoutBranchPanel on: self model) 
			titleForWindow: 'Local';
			icon: (self iconNamed: #branch);
			yourself }, 
	(self model remoteModels collect: [ :each | 
		(IceTipCheckoutBranchPanel on: each)
			titleForWindow: each name;
			icon: (self iconNamed: #remote);
			yourself ]),
	(self model entity pluginManager checkoutBranchPanelsOnModel: self model).
	
	"Doing this because I can trigger the accept inside the panels."
	allTypes do: [ :each | each onAccept: [ self closeWindow ] ].
	
	^ allTypes! !

!IceTipCheckoutBranchDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Checkout branch'! !

!IceTipCheckoutBranchDialog methodsFor: 'accessing' stamp: ''!
withOnlyNewBranch

	types := self allTypes select: #isNewBranch.
	typeList items: types! !

!IceTipCheckoutBranchDialog methodsFor: 'actions' stamp: ''!
doAccept

	self selectedType doAccept! !

!IceTipCheckoutBranchDialog methodsFor: 'accessing' stamp: ''!
withoutNewBranch
	types := self allTypes reject: #isNewBranch.
	typeList items: types.! !

!IceTipCheckoutBranchDialog methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipCheckoutBranchDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (600 @ 400) scaledByDisplayScaleFactor! !

!IceTipCheckoutBranchDialog methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipCheckoutBranchDialog methodsFor: 'accessing' stamp: ''!
withTypes: aCollection
	types := aCollection.
	typeList items: types.! !

!IceTipCheckoutBranchDialog class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository

	^ self on: (IceTipRepositoryModel on: aRepository) beCached! !

!IceTipCheckoutBranchPanel commentStamp: ''!
I'm a panel to peform the checkout of an existing branch.!
!IceTipCheckoutBranchPanel methodsFor: 'actions' stamp: ''!
doAccept

	self selectedBranch previewCheckout! !

!IceTipCheckoutCommitCommand commentStamp: ''!
I checkout a specific commit from history.
I will let your repository in detach mode!!!
!IceTipCheckoutCommitCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #refresh! !

!IceTipCheckoutCommitCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipCheckoutPreviewBrowser onBranch: self selectedCommit)
		openWithSpec! !

!IceTipCheckoutCommitCommand methodsFor: 'accessing' stamp: ''!
selectedCommit

	^ self context selectedCommit! !

!IceTipCheckoutCommitCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Set the selected commit as current commit and load the code in the image'! !

!IceTipCheckoutCommitCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Checkout'! !

!IceTipCheckoutModel methodsFor: 'accessing' stamp: ''!
checkoutStrategies
	
	^ checkoutStrategies! !

!IceTipCheckoutModel methodsFor: 'actions' stamp: ''!
executeCheckoutActionAndThen: aBlock 
	
	<noCache>
	IceTipStandardAction new 
		repository: self repository;
		message: ('Checking out {1} from {2}' format: { self targetName. self repositoryName });
		onSuccessRepositoryModified;
		onSuccess: aBlock;
		execute: [ self checkout ]! !

!IceTipCheckoutModel methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	checkoutStrategies := (IceCheckoutStrategy allSubclasses 
		sorted: [ :a :b | a order < b order ])
		collect: #new.
	checkoutStrategy := checkoutStrategies first.! !

!IceTipCheckoutModel methodsFor: 'accessing' stamp: ''!
calculateDiff

	^ commitish entity diffTo: self repository workingCopy! !

!IceTipCheckoutModel methodsFor: 'accessing' stamp: ''!
checkoutStrategy
	
	^ checkoutStrategy! !

!IceTipCheckoutModel methodsFor: 'actions' stamp: ''!
checkout

	checkoutStrategy
		committish: self commitish;
		diff: self diff entity.

	self commitish checkout: checkoutStrategy! !

!IceTipCheckoutModel methodsFor: 'accessing' stamp: ''!
checkoutStrategy: aStrategy
	checkoutStrategy := aStrategy! !

!IceTipCheckoutNewBranchCommand commentStamp: ''!
Action to start the creation of a new branch from the selected commit.
Then checkout the selected branch.!
!IceTipCheckoutNewBranchCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #branch! !

!IceTipCheckoutNewBranchCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipCheckoutNewBranchPanel on: self repositoryModel)
		commitish: self selectedCommit;
		withResultDo: [ :branch | branch checkout ];
		openDialogWithSpec! !

!IceTipCheckoutNewBranchCommand methodsFor: 'accessing' stamp: ''!
selectedCommit

	^ self item entity! !

!IceTipCheckoutNewBranchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Create a new branch from the selected commit and switch to it'! !

!IceTipCheckoutNewBranchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Branch...'! !

!IceTipCheckoutNewBranchPanel commentStamp: ''!
I'm a panel to create a new local branch !
!IceTipCheckoutNewBranchPanel methodsFor: 'testing' stamp: ''!
isNewBranch

	^ true! !

!IceTipCheckoutNewBranchPanel methodsFor: 'callbacks' stamp: ''!
withResultDo: aBlockClosure 
	
	callback := aBlockClosure! !

!IceTipCheckoutNewBranchPanel methodsFor: 'accessing - ui' stamp: ''!
currentBranchLabel

	^ currentBranchLabel! !

!IceTipCheckoutNewBranchPanel methodsFor: 'accessing' stamp: ''!
openDialogWithSpec

	^ super openDialogWithSpec
		  okAction: [ self accept ];
		  yourself! !

!IceTipCheckoutNewBranchPanel methodsFor: 'accessing - ui' stamp: ''!
branchLabel

	^ branchLabel! !

!IceTipCheckoutNewBranchPanel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'New branch'! !

!IceTipCheckoutNewBranchPanel methodsFor: 'accessing' stamp: ''!
validate

	self 
		assert: self branchName isNotEmpty
		description: 'Please enter your new branch name.'.
	self 
		assert: (self branchName noneSatisfy: #isSeparator)
		description: 'You can''t have spaces in your branch name.'! !

!IceTipCheckoutNewBranchPanel methodsFor: 'accessing' stamp: ''!
branchName

	^ self branchInputText text asString trimBoth! !

!IceTipCheckoutNewBranchPanel methodsFor: 'actions' stamp: ''!
doAccept

	self model
		checkoutNewBranchNamed: self branchName
		inCommit: (branchCommitish ifNil: [ self model entity workingCopy referenceCommit ])
		thenDo: [ :newBranch | callback ifNotNil: [ callback value: newBranch ] ]! !

!IceTipCheckoutNewBranchPanel methodsFor: 'accessing' stamp: ''!
commitish: anIceTipModel
	
	branchCommitish := anIceTipModel! !

!IceTipCheckoutNewBranchPanel methodsFor: 'accessing' stamp: ''!
icon

	^ self iconNamed: #smallNew! !

!IceTipCheckoutNewBranchPanel methodsFor: 'accessing - ui' stamp: ''!
branchInputText

	^ branchInputText! !

!IceTipCheckoutNewBranchPanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	self initializeCurrentBranchLabel.
	branchLabel := self newLabel
		               label: 'New branch';
		               yourself.
	branchInputText := self newTextInput
		                   autoAccept: true;
		                   placeholder: 'e.g., feature/what';
		                   yourself.
! !

!IceTipCheckoutNewBranchPanel methodsFor: 'initialization' stamp: ''!
initializeCurrentBranchLabel

	currentBranchLabel := self newLabel
		label: 'Current branch: ', self model branchName! !

!IceTipCheckoutNewBranchPanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #currentBranchLabel height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #branchLabel width: self labelWidth;
				   add: #branchInputText;
				   yourself)
		  height: self inputTextHeight! !

!IceTipCheckoutPreviewBrowser commentStamp: ''!
I preview the changes that will be introduced in the image when a checkout occurs.

(self onBranch: IceRepository registry anyOne branch) openWithSpec.!
!IceTipCheckoutPreviewBrowser methodsFor: 'accessing' stamp: ''!
selectedCheckoutStrategy

	^ selectedCheckoutStrategy! !

!IceTipCheckoutPreviewBrowser methodsFor: 'initialization' stamp: ''!
initializeCheckoutStrategyList

	| checkoutStrategies |
	checkoutStrategies := self model checkoutStrategies.
	checkoutStrategyList
		items: checkoutStrategies;
		display: [ :each | each description ].
	checkoutStrategyList whenSelectedItemChangedDo: [ :aStrategy | 
		self model checkoutStrategy: aStrategy ]! !

!IceTipCheckoutPreviewBrowser methodsFor: 'private - factory' stamp: ''!
newActionButton

	^ self newButton
		label: 'Checkout';
		icon: (self iconNamed: #branch);
		help: ('Checks out {1} into your image.' format: { self model targetName });
		action: [ self doCheckout ];
		yourself! !

!IceTipCheckoutPreviewBrowser methodsFor: 'accessing - ui' stamp: ''!
checkoutStrategyList

	^ checkoutStrategyList! !

!IceTipCheckoutPreviewBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Preview checkout of {1}/{2}' format: { 
		self model repositoryName.
		self model targetName }! !

!IceTipCheckoutPreviewBrowser methodsFor: 'actions' stamp: ''!
doCheckout

	self model executeCheckoutActionAndThen: [ self closeWindow ]! !

!IceTipCheckoutPreviewBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	diffPanel
		leftLabel: 'Working Copy';
		rightLabel: 'Checkout ' , model targetName.
	
	checkoutStrategyLabel := self newLabel
		label: 'How to checkout:';
		yourself.
	checkoutStrategyList := self newDropList.
	self initializeCheckoutStrategyList.
! !

!IceTipCheckoutPreviewBrowser methodsFor: 'accessing - ui' stamp: ''!
checkoutStrategyLabel

	^ checkoutStrategyLabel! !

!IceTipCheckoutPreviewBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #checkoutStrategyLabel
				   width: 100 * self currentWorld displayScaleFactor;
				   add: #checkoutStrategyList;
				   yourself)
		  height: self inputTextHeight;
		  add: #diffPanel expand: true;
		  add: #actionPanel height: self inputTextHeight;
		  yourself! !

!IceTipCheckoutPreviewBrowser class methodsFor: 'instance creation' stamp: ''!
onBranch: aBranch

	^ self on: (IceTipCheckoutModel new
		commitish: aBranch;
		yourself)! !

!IceTipCheckoutSelectedBranchCommand commentStamp: ''!
Command that checks out the selected branch!
!IceTipCheckoutSelectedBranchCommand methodsFor: 'testing' stamp: ''!
actsOnBranch: aBranchModel

	^ true! !

!IceTipCheckoutSelectedBranchCommand methodsFor: 'accessing' stamp: ''!
iconName
	^ #branch! !

!IceTipCheckoutSelectedBranchCommand methodsFor: 'executing' stamp: ''!
execute

	self item previewCheckout! !

!IceTipCheckoutSelectedBranchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Checkout this branch'! !

!IceTipCheckoutSelectedBranchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Checkout branch'! !

!IceTipCheckoutSelectedTagCommand commentStamp: ''!
Command that checks out the selected tag!
!IceTipCheckoutSelectedTagCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #branch! !

!IceTipCheckoutSelectedTagCommand methodsFor: 'executing' stamp: ''!
execute
	self item previewCheckout! !

!IceTipCheckoutSelectedTagCommand methodsFor: 'testing' stamp: ''!
actsOnTag: aRemoteModel

	^ true! !

!IceTipCheckoutSelectedTagCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Checkout this tag for this repository. Repository will then be in Detached Head state!!'! !

!IceTipCheckoutSelectedTagCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Checkout tag'! !

!IceTipCherryPickCommand commentStamp: ''!
Generic command to cherry pick changes!
!IceTipCherryPickCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipCherrypickPreviewBrowser onCommitish: self selectedCommitish)
		openWithSpec! !

!IceTipCherryPickCommand methodsFor: 'executing' stamp: ''!
selectedCommitish

	^ self context selectedCommit realObject entity! !

!IceTipCherryPickCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	self flag: #pharoTodo. "TODO: Still not ready"
	^ false! !

!IceTipCherryPickCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Cherrypick this commit and apply changes to the working copy'! !

!IceTipCherryPickCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Cherrypick'! !

!IceTipCherrypickModel methodsFor: 'accessing' stamp: ''!
treeToShow
" Return the tree to display in windows "
	^ self mergeTree! !

!IceTipCherrypickModel methodsFor: 'accessing' stamp: ''!
commitish
	^commitish! !

!IceTipCherrypickModel methodsFor: 'accessing' stamp: ''!
mergeTree
	^mergeTree! !

!IceTipCherrypickModel methodsFor: 'accessing' stamp: ''!
repository
	^commitish repository.! !

!IceTipCherrypickModel methodsFor: 'accessing' stamp: ''!
commitish: aCommistish
	commitish := aCommistish.
	mergeTree := commitish repository cherryPickFrom: aCommistish! !

!IceTipCherrypickModel methodsFor: 'accessing' stamp: ''!
diff
	^ self! !

!IceTipCherrypickModel class methodsFor: 'instance creation' stamp: ''!
onCommitish: aCommitish

	^ self new
		  commitish: aCommitish;
		  yourself! !

!IceTipCherrypickPreviewBrowser methodsFor: 'accessing' stamp: ''!
mergeType: anObject
	
	self model mergeType: anObject! !

!IceTipCherrypickPreviewBrowser methodsFor: 'private - factory' stamp: ''!
newActionButton

	^ self newButton
		label: 'Apply';
		icon: (self iconNamed: #merge);
		help: 'Apply changes into your Working Copy';
		action: [ self doCherryPick ];
		yourself! !

!IceTipCherrypickPreviewBrowser methodsFor: 'actions' stamp: ''!
doCherryPick

	| root |
	root := diffPanel model tree.
	root accept: IceMergeToChangeTreeVisitor new.
	self model repository workingCopy loadChangesInWorkingCopy: root.
	self closeWindow! !

!IceTipCherrypickPreviewBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Preview result of Cherrypick'! !

!IceTipCherrypickPreviewBrowser methodsFor: 'accessing - ui' stamp: ''!
buttonBar

	^ buttonBar! !

!IceTipCherrypickPreviewBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (800 @ 600) scaledByDisplayScaleFactor! !

!IceTipCherrypickPreviewBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters
	super initializePresenters.

	diffPanel := self
		instantiate: (IceTipMergeSelectingPanel onDiff: self model diff).
	buttonBar := self newButtonBar.
	buttonBar add: self newActionButton.

	diffPanel leftLabel: 'Working Copy'.
	diffPanel rightLabel: ' With Cherrypicked commit '! !

!IceTipCherrypickPreviewBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList
	"Answer the presenter that is the main list of items of this browser."

	^ diffPanel iceNodesTree! !

!IceTipCherrypickPreviewBrowser methodsFor: 'accessing - ui' stamp: ''!
diffPanel

	^ diffPanel! !

!IceTipCherrypickPreviewBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	"Nothing to add"! !

!IceTipCherrypickPreviewBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #diffPanel;
		  add: #buttonBar height: self buttonHeight;
		  yourself! !

!IceTipCherrypickPreviewBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	"Nothing to add"! !

!IceTipCherrypickPreviewBrowser class methodsFor: 'instance creation' stamp: ''!
onCommitish: aCommitish
	^ self
		on:
			(IceTipCherrypickModel onCommitish: aCommitish)! !

!IceTipCleanCommandGroupVisitor commentStamp: ''!
I'm a CmVisitor that in one hand, tells each command to be hidden if it can't be executed, and in the other hand, unregisters each group that is empty.
!
!IceTipCleanCommandGroupVisitor methodsFor: 'visiting' stamp: ''!
visitCommandGroup: aCmCommandsGroup

	super visitCommandGroup: aCmCommandsGroup.

	aCmCommandsGroup groups do: [ :nestedGroup |
		(nestedGroup allCommands
			noneSatisfy: [ :each | each canBeExecuted ]) 
				ifTrue: [ aCmCommandsGroup unregister: nestedGroup ] ] 
! !

!IceTipCleanCommandGroupVisitor methodsFor: 'visiting' stamp: ''!
visitCommand: aCmCommand
	
	aCmCommand beHiddenWhenCantBeRun! !

!IceTipCommand commentStamp: ''!
I'm the superclass of all commands of the IceTip UI.!
!IceTipCommand methodsFor: 'accessing' stamp: ''!
repositoryModel

	^ self context repositoryModel! !

!IceTipCommand methodsFor: 'accessing' stamp: ''!
tool

	^ self context! !

!IceTipCommand methodsFor: 'accessing' stamp: ''!
badge
	"Answer a number as extra information in the button. An answer of nil means no information."

	^ nil! !

!IceTipCommand methodsFor: 'converting' stamp: ''!
asSpecCommand 

	| spCommand |
	spCommand := self decorateWith: IceTipSpCommand.
	
	spCommand
		iconProvider: self application;
		iconName: self iconName.

	self shouldBeDisplayedOnRightSideInToolbar ifTrue: [
		spCommand beDisplayedOnRightSide ].
	
	self shortcutKey ifNotNil: [ :keyCombination |
		spCommand shortcutKey: keyCombination ].

	^ spCommand! !

!IceTipCommand methodsFor: 'accessing' stamp: ''!
application

	^ SpApplication defaultApplication! !

!IceTipCommand methodsFor: 'testing' stamp: ''!
hasUnbornProject
	^ self repositoryModel hasUnbornProject! !

!IceTipCommand methodsFor: 'accessing' stamp: ''!
iconName
	"Answer the icon name (a Symbol) for this command."
	
	^ #blank
! !

!IceTipCommand methodsFor: 'testing' stamp: ''!
isRepositoryMissing

	^ self hasRepository and: [
		self repositoryModel isMissing or: [
			self repositoryModel isCodeMissing ] ]! !

!IceTipCommand methodsFor: 'testing' stamp: ''!
isRepositoryOperational
	^ self isRepositoryMissing not 
		and: [ self isRepositoryDetached not
			and: [ self hasUnbornProject not ] ]! !

!IceTipCommand methodsFor: 'accessing' stamp: ''!
repository

	^ self repositoryModel entity! !

!IceTipCommand methodsFor: 'testing' stamp: ''!
isRepositoryDetached
	^ self repositoryModel isNil 
		or: [ self  repositoryModel isDetached ]! !

!IceTipCommand methodsFor: 'testing' stamp: ''!
hasSelectedItem

	^ self context selectedItem notNil! !

!IceTipCommand methodsFor: 'testing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ false! !

!IceTipCommand methodsFor: 'accessing' stamp: ''!
toolbarItemName
	
	^ self class defaultToolbarItemName! !

!IceTipCommand methodsFor: 'accessing' stamp: ''!
toolAnnouncer

	^ self tool announcer! !

!IceTipCommand methodsFor: 'executing' stamp: ''!
item

	^ self context selectedItem! !

!IceTipCommand methodsFor: 'testing' stamp: ''!
hasRepository

	^ self repositoryModel notNil! !

!IceTipCommand methodsFor: 'accessing' stamp: ''!
shortcutKey
	"Answer the key combination to execute this command. Answer nil if there isn't a key combination."
	
	^ nil
! !

!IceTipCommand methodsFor: 'accessing' stamp: ''!
withErrorHandlingDo: aBlock

	aBlock
		on: IceError
		do: [ :e |
			e acceptError:
				(IceTipInteractiveErrorVisitor on: self repository) ]! !

!IceTipCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultToolbarItemName

	^ self defaultName
! !

!IceTipCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipCommand! !

!IceTipCommandToPresenterBuildingStrategy commentStamp: ''!
I'm an abstract strategy to build Spec2 buttons wrapping a IceTipSpCommand. My concrete subclasses do this with specific characteristics.

!
!IceTipCommandToPresenterBuildingStrategy methodsFor: 'public' stamp: ''!
resultOn: aCommand

	^ self buttonPresenterClass new
		label: aCommand name;
		help: aCommand description;
		in: [ :button | 
			aCommand hasIcon
				ifTrue: [ button icon: aCommand icon ] ];
		action: [ aCommand execute ];
		yourself
! !

!IceTipCommandToPresenterBuildingStrategy methodsFor: 'hook' stamp: ''!
buttonPresenterClass

	^ self subclassResponsibility! !

!IceTipCommentPanel commentStamp: ''!
I'm a comment panel.
I can obtain a comment text and certain "commit specific" options. !
!IceTipCommentPanel methodsFor: 'accessing' stamp: ''!
repositoryModel

	^ repositoryModel! !

!IceTipCommentPanel methodsFor: 'private - accessing' stamp: ''!
repositoryRemoteName

	^ self repositoryModel pushRemoteName! !

!IceTipCommentPanel methodsFor: 'accessing - ui' stamp: ''!
commentText

	^ commentText! !

!IceTipCommentPanel methodsFor: 'events' stamp: ''!
onCommit: aBlock

	commitButton action: [ 
		aBlock 
			cull: self message
			cull: self isPushing ]! !

!IceTipCommentPanel methodsFor: 'accessing' stamp: ''!
refresh

	commitButton help: ('Commit your changes to {1}' format: { self repositoryName }).
	pushCheckbox label: ('Push changes to {1}' format: { self repositoryRemoteName })! !

!IceTipCommentPanel methodsFor: 'testing' stamp: ''!
isPushing

	^ self pushCheckbox state! !

!IceTipCommentPanel methodsFor: 'accessing - ui' stamp: ''!
saveCheckbox

	^ saveCheckbox! !

!IceTipCommentPanel methodsFor: 'specs' stamp: ''!
titleForWindow

	^ 'Comment'! !

!IceTipCommentPanel methodsFor: 'accessing' stamp: ''!
fixesField

	^ fixesField! !

!IceTipCommentPanel methodsFor: 'accessing' stamp: ''!
clear

	commentText text: ''! !

!IceTipCommentPanel methodsFor: 'accessing - ui' stamp: ''!
pushCheckbox

	^ pushCheckbox! !

!IceTipCommentPanel methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aRepositoryModel

	repositoryModel := aRepositoryModel! !

!IceTipCommentPanel methodsFor: 'accessing - ui' stamp: ''!
commitButton

	^ commitButton! !

!IceTipCommentPanel methodsFor: 'testing' stamp: ''!
isSaving

	^ self saveCheckbox state! !

!IceTipCommentPanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	| fixesHelpString |
	super initializePresenters.

	pushCheckbox := self newCheckBox.
	saveCheckbox := self newCheckBox.
	critiquesCheckbox := self newCheckBox.
	
	self repositoryModel branchModel hasUpstream
		ifTrue: [
			pushCheckbox
				label: ('Push changes to {1}' format: {self repositoryRemoteName});
				state: IceTipCommitSettings pushOnCommit;
				whenChangedDo: [ :state | IceTipCommitSettings pushOnCommit: state ] ]
		ifFalse: [
			pushCheckbox
				label: 'Cannot push new branch automatically. Use the `Push` option';
				enabled: false ].
	saveCheckbox
		label: 'Save the image when commiting';
		state: IceTipCommitSettings saveImageOnCommit;
		whenChangedDo: [ :state | IceTipCommitSettings saveImageOnCommit: state ].

	critiquesCheckbox
		label: 'Run Critiques when commiting';
		state: IceTipCommitSettings critiquesOnCommit;
		whenChangedDo: [ :state | IceTipCommitSettings critiquesOnCommit: state ].

	commentText := self newText
		autoAccept: true;
		placeholder: 'A comment for your commit';
		yourself.

	fixesHelpString := 'Enter the number of the issue that you fixed. Github will close it when it will be commited or merged in the default branch'.
	fixesLabel := self newLabel
		label: 'Fixes #';
		help: fixesHelpString;
		yourself.
	fixesField := self newNumberInput
		autoAccept: true;
		help: fixesHelpString;
		placeholder: 'issue number';
		beInteger;
		yourself.

	actionButtonBar := self newButtonBar.
	actionButtonBar
		add:
			(commitButton := self newButton
				label: 'Commit';
				icon: (self iconNamed: #smallOk);
				help: ('Commit your changes to {1}' format: {self repositoryName});
				yourself).
! !

!IceTipCommentPanel methodsFor: 'accessing' stamp: ''!
fixesLabel

	^ fixesLabel! !

!IceTipCommentPanel methodsFor: 'accessing' stamp: ''!
actionButtonBar

	^ actionButtonBar! !

!IceTipCommentPanel methodsFor: 'accessing' stamp: ''!
message

	self fixesField text isAllDigits ifFalse: [ 
		^ self commentText text asString ].

	^ String streamContents: [ :stream | 
		  stream
			  nextPutAll: self commentText text asString; cr;
			  nextPutAll: 'Fixes #';
			  nextPutAll: self fixesField number asString ]! !

!IceTipCommentPanel methodsFor: 'private - accessing' stamp: ''!
repositoryName

	^ self repositoryModel name! !

!IceTipCommentPanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	self flag: #pharoTodo. "FIXES ISSUE NUMBER INPUT is disabled. See below.
	Reason: for the first stage of merging dev-1.9, we'll keep the diff as simple
	as possible, to reduce noise in users. (Right now this branch is only a
	migration from Spec1+Commander1 to Spec2+Commander2)."

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #pushCheckbox;
				   add: #saveCheckbox;
					add: #critiquesCheckbox;
				   yourself)
		  height: self inputTextHeight;
		  add: #commentText;
" 		  add: (SpBoxLayout newLeftToRight
				   add: #fixesLabel width: 40;
				   add: #fixesField;
				   yourself)
		  height: self inputTextHeight;"
		  add: #actionButtonBar withConstraints: [ :aConstraint |
			 aConstraint 	
				height: self buttonHeight + 6;
				fill: true;
				padding: 5 ]! !

!IceTipCommitAction commentStamp: ''!
I perform a commit!
!IceTipCommitAction methodsFor: 'validating' stamp: ''!
validateChangeListNotEmpty
	"If there are no selected changed, no point on commiting :)"
	
	items ifEmpty: [ IceNothingToCommit signal ]! !

!IceTipCommitAction methodsFor: 'accessing' stamp: ''!
message: anObject
	message := anObject! !

!IceTipCommitAction methodsFor: 'executing' stamp: ''!
basicExecute
	self validateCanCommit.
	UIManager default 
		informUser: 'Commiting...' 
		during: [ 
			self repository
				commitChanges: (diff copyWithOnly: items)
				withMessage: message ].
	Iceberg announcer announce: (IceRepositoryModified for: self repository).
	Iceberg announcer announce: (IceCommited for: self repository).! !

!IceTipCommitAction methodsFor: 'accessing' stamp: ''!
items: anObject
	items := anObject! !

!IceTipCommitAction methodsFor: 'accessing' stamp: ''!
diff: anObject
	diff := anObject! !

!IceTipCommitAction methodsFor: 'validating' stamp: ''!
validateCanCommit
	self validateMessageNotEmpty! !

!IceTipCommitAction methodsFor: 'accessing' stamp: ''!
items
	^ items! !

!IceTipCommitAction methodsFor: 'accessing' stamp: ''!
message
	^ message! !

!IceTipCommitAction methodsFor: 'accessing' stamp: ''!
diff
	^ diff! !

!IceTipCommitAction methodsFor: 'validating' stamp: ''!
validateMessageNotEmpty
	self message ifEmpty: [ IceNoCommitMessage signal ]! !

!IceTipCommitBrowser commentStamp: ''!
I'm a browser to commit changes to a repository.

(self onRepository: IceRepository registry anyOne) openWithSpec!
!IceTipCommitBrowser methodsFor: 'actions' stamp: ''!
doCommit

	| selectedItems message isPushing isSaving commitBlock|
	self closeWindow.

	selectedItems := diffPanel selectedItems.
	message := commentPanel message.
	isPushing := commentPanel isPushing.
	isSaving := commentPanel isSaving.
	
	commitBlock := [  
			self
				doCommit: selectedItems
				message: message
				pushing: isPushing
				saving: isSaving ].

	(IceTipCritiquesBeforeCommitBrowser on: selectedItems)
		commitModel: self model;
		onAccept: commitBlock ;
		openIfCritiques! !

!IceTipCommitBrowser methodsFor: 'actions' stamp: ''!
doExpandSelection
	
	diffPanel doExpandSelection! !

!IceTipCommitBrowser methodsFor: 'accessing' stamp: ''!
initialize 

	super initialize.
	saveAction := IceTipSaveImageAction new! !

!IceTipCommitBrowser methodsFor: 'accessing' stamp: ''!
refresh

	diffPanel refresh! !

!IceTipCommitBrowser methodsFor: 'private' stamp: ''!
verifyNeedsRefreshOrClose
	"Verifies if there are remaining changes to commit. 
	 In case there are none, close the window."
	
	self model reset.
	diffPanel model reset.
	diffPanel model isEmpty
		ifTrue: [ ^ self closeWindow ].
	self commentPanel clear. 
	diffPanel basicRefresh! !

!IceTipCommitBrowser methodsFor: 'accessing' stamp: ''!
saveAction: anAction

	saveAction := anAction! !

!IceTipCommitBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Commit on {1} branch {2}' format: { 
			  self model name.
			  self model branchName }! !

!IceTipCommitBrowser methodsFor: 'actions' stamp: ''!
doCommit: aCollection message: aString pushing: pushingBoolean saving: savingBoolean

	self model
		commit:
			(IceTipCommitAction new
				diff: self model workingCopyDiff;
				items: aCollection;
				message: aString;
				yourself)
		then: [ self verifyNeedsRefreshOrClose.
			pushingBoolean
				ifTrue: [ (IceTipPushAction new repository: self model entity) execute ].
			savingBoolean
				ifTrue: [ saveAction execute ] ]! !

!IceTipCommitBrowser methodsFor: 'initialization' stamp: ''!
initializeAcceptShortcut

	self
		bindKeyCombination: $s meta
		toAction: [ self accept ].
		
	commentPanel commentText
		bindKeyCombination: $s meta
		toAction: [ self accept ].
! !

!IceTipCommitBrowser methodsFor: 'private' stamp: ''!
refreshWhenRepository: ann

	(self model isModelOf: ann repository)
		ifFalse: [ ^ self ].
	self model reset.
	self refresh! !

!IceTipCommitBrowser methodsFor: 'actions' stamp: ''!
accept

	^ self doCommit! !

!IceTipCommitBrowser methodsFor: 'accessing - ui' stamp: ''!
commentPanel: aSpPresenter

	commentPanel := aSpPresenter! !

!IceTipCommitBrowser methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindow

	super initializeWindow: aWindow.
	aWindow bindKeyCombination: $s meta toAction: [ self accept ]! !

!IceTipCommitBrowser methodsFor: 'accessing - ui' stamp: ''!
commentPanel

	^ commentPanel! !

!IceTipCommitBrowser methodsFor: 'accessing - ui' stamp: ''!
diffPanel: aSpPresenter

	diffPanel := aSpPresenter! !

!IceTipCommitBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (800@600) scaledByDisplayScaleFactor! !

!IceTipCommitBrowser methodsFor: 'actions' stamp: ''!
doCollapseSelection

	diffPanel doCollapseSelection! !

!IceTipCommitBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	
	diffPanel := self instantiate: IceTipDiffSelectingPanel on: self model workingCopyDiff.
	diffPanel leftLabel: 'Repository'.
	diffPanel rightLabel: 'Working Copy'.
	
	commentPanel := self instantiate: IceTipCommentPanel on: self model.
	commentPanel onCommit: [ self doCommit ].
	
	self initializeAcceptShortcut.
! !

!IceTipCommitBrowser methodsFor: 'accessing - ui' stamp: ''!
diffPanel

	^ diffPanel! !

!IceTipCommitBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList
	"Answer the presenter that is the main list of items of this browser."

	^ diffPanel iceNodesTree! !

!IceTipCommitBrowser methodsFor: 'initialization' stamp: ''!
subscribeToAnnouncements

	self announcer
		when: IceTipDiffRefreshed
		send: #refreshWhenRepository:
		to: self! !

!IceTipCommitBrowser class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository

	^ self on: (IceTipRepositoryModel on: aRepository)! !

!IceTipCommitBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	{ 	
		IceTipBrowseCommand.
		IceTipRevertChangeCommand.
	} 
	do: [ :each | aCommandGroup register: each forSpec ].
	
	aCommandGroup register: ((CmCommandGroup named: 'Edit') asSpecGroup
		beDisplayedAsGroup;
		register: IceTipTreeExpandCommand forSpec;
		register: IceTipTreeCollapseCommand forSpec;
		yourself).
! !

!IceTipCommitBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newTopToBottom
		  add: #diffPanel;
		  add: #commentPanel;
		  yourself! !

!IceTipCommitBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	aCommandGroup register: IceTipRefreshCommitCommand forSpec! !

!IceTipCommitCommand commentStamp: ''!
I open a the commit window, with all latest changes.!
!IceTipCommitCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #smallOk! !

!IceTipCommitCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipCommitBrowser on: self repositoryModel) openWithSpec! !

!IceTipCommitCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $s meta! !

!IceTipCommitCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self isRepositoryOperational! !

!IceTipCommitCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Commit changes to this repository'! !

!IceTipCommitCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Commit'! !

!IceTipCommitDiffModel commentStamp: ''!
I'm a "static" diff. 
I represent a diff between two concrete commits.!
!IceTipCommitDiffModel methodsFor: 'accessing' stamp: ''!
diff
	^ self entity! !

!IceTipCommitInfoPresenter commentStamp: ''!
I'm a panel to show the history of a commitish (usually a branch or a tag). I display infos on it and diffs.

I'm usually used as part of an IceTipHistoryBrowser.!
!IceTipCommitInfoPresenter methodsFor: 'private factory' stamp: ''!
newInfoPage

	^ SpNotebookPage  
		title: 'Info'
		icon: (self iconNamed: #smallQuestion)
		provider: [ self commitInfo ]! !

!IceTipCommitInfoPresenter methodsFor: 'initialization' stamp: ''!
initialize

	self beForCommit.
	super initialize! !

!IceTipCommitInfoPresenter methodsFor: 'accessing' stamp: ''!
refresh
	
	selectedModel ifNil: [ ^ self ].
	
	headPage title: (headTabContainer labelFor: selectedModel).
	ancestorPage title: (ancestorTabContainer labelFor: selectedModel).
	notebookPanel resetAllPageContents! !

!IceTipCommitInfoPresenter methodsFor: 'accessing' stamp: ''!
beForMerge

	headTabContainer := IceTipHistoryDiffToHead tab: headPage.
	ancestorTabContainer := IceTipHistoryDiffToAncestor tab: ancestorPage! !

!IceTipCommitInfoPresenter methodsFor: 'private' stamp: ''!
refreshDiffFromAncestorLabel

	ancestorTabContainer updateLabelOn: selectedModel! !

!IceTipCommitInfoPresenter methodsFor: 'private factory' stamp: ''!
newEmpty

	^ self newLabel
		  label: '(No commit selected)';
		  yourself! !

!IceTipCommitInfoPresenter methodsFor: 'private' stamp: ''!
commitInfo

	selectedModel ifNil: [ ^ self newEmpty ].
	^ IceTipReadOnlyFormBuilder newBuiltFor: selectedModel info application: self application! !

!IceTipCommitInfoPresenter methodsFor: 'accessing' stamp: ''!
beForCommit

	headTabContainer := IceTipHistoryDiffFromHead tab: headPage.
	ancestorTabContainer := IceTipHistoryDiffToAncestor tab: ancestorPage! !

!IceTipCommitInfoPresenter methodsFor: 'initialization' stamp: ''!
initializeCommitPanel
	"This will be initialised in fact on the first refresh"

	notebookPanel
		addPage: (infoPage := self newInfoPage);
		addPage: (headPage := self newDiffPage 
			title: 'Diff from HEAD';
			presenterProvider: [ self diffFromHead ];
			yourself);
		addPage: (ancestorPage := self newDiffPage 
			title: 'Diff from ancestor';
			presenterProvider: [ self diffFromAncestor ];
			yourself)! !

!IceTipCommitInfoPresenter methodsFor: 'accessing' stamp: ''!
selectedModel: aModel

	selectedModel := aModel.
	self refresh! !

!IceTipCommitInfoPresenter methodsFor: 'private' stamp: ''!
refreshDiffFromAncestor

	ancestorTabContainer updateContentsOn: selectedModel! !

!IceTipCommitInfoPresenter methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipCommitInfoPresenter methodsFor: 'private' stamp: ''!
refreshDiffFromHead

	headTabContainer updateContentsOn: selectedModel! !

!IceTipCommitInfoPresenter methodsFor: 'private factory' stamp: ''!
newDiffPage

	^ SpNotebookPage 
		title: 'Diff'
		icon: (self iconNamed: #diff)
		provider: [ "It will be overriden" ]! !

!IceTipCommitInfoPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	notebookPanel := self newNotebook.
	self initializeCommitPanel.
! !

!IceTipCommitInfoPresenter methodsFor: 'private' stamp: ''!
refreshDiffFromHeadLabel

	headTabContainer updateLabelOn: selectedModel! !

!IceTipCommitInfoPresenter methodsFor: 'private' stamp: ''!
diffFromAncestor
	
	selectedModel ifNil: [ ^ self newEmpty ].
	^ IceTipDiffPanel on: (ancestorTabContainer diffFor: selectedModel)! !

!IceTipCommitInfoPresenter methodsFor: 'private' stamp: ''!
diffFromHead
	
	selectedModel ifNil: [ ^ self newEmpty ].
	^ IceTipDiffPanel on: (headTabContainer diffFor: selectedModel)! !

!IceTipCommitInfoPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #notebookPanel;
		  yourself! !

!IceTipCommitModel commentStamp: ''!
I'm a model for IceCommit entries. !
!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
ancestors
	^ self entity ancestors! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
timeStamp
	^ self entity timeStamp! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	| text |
	text := (', ' join: self entity tagNames) asText allBold makeAllColor: Color gray.
	text ifNotEmpty: [ text := text , ' ' ].
	text append: self entity comment asText.
	^ text! !

!IceTipCommitModel methodsFor: 'private' stamp: ''!
calculateDiff: aBlock
	| diff |
	
	UIManager default 
		informUser: 'Calculating diff'
		during: [ 
			diff := aBlock value.
			diff build ].

	^ diff! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
commitModels
	| commits |
	commits := OrderedCollection new.
	self entity commitsDo: [ :each | 
		commits add: (IceTipCommitModel 
			repositoryModel: self repositoryModel 
			on: each) 
			beCached ].
	^ commits! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
diffFromFirstAncestor
	| diff ancestorCommit |
	
	ancestorCommit := self entity ancestors 
		ifNotEmpty: #first
		ifEmpty: [ IceNoCommit new ].
	diff := self calculateDiff: [ ancestorCommit diffTo: self entity ].
	^ IceTipCommitDiffModel
		repositoryModel: self repositoryModel 
		on: diff! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
diffToHead
	| head diff |
	
	head := self repositoryModel entity headCommit.
	diff := self calculateDiff: [ self entity diffTo: head ].
	^ IceTipCommitDiffModel
		repositoryModel: self repositoryModel 
		on: diff! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
commit
	
	^ self entity! !

!IceTipCommitModel methodsFor: 'actions' stamp: ''!
mergeHistoryFromSecondAncestor
	<noCache>
	
	^ self mergeHistoryFromAncestor: self entity ancestors second! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
ancestorShortIdOrOrigin
	^ self entity ancestors 
		ifNotEmpty: [ self ancestorShortId ]
		ifEmpty: [ 'Origin' ]! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
id
	^ self entity id! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
info
	^ {('Commit:' -> ('[' , self shortId , '] ' , self id)).
	('Parents:' -> (self entity ancestors collect: #shortId) asCommaString).
	('Author:' -> self entity author).
	('Date:' -> self entity timeStamp asStringYMDHM).
	('Tags:' -> self entity tagNames asCommaString).
	('Comment:' -> self entity comment)}! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
datetime
	^ self entity datetime! !

!IceTipCommitModel methodsFor: 'API - commits' stamp: ''!
adopt
	
	self entity adopt! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
diffToFirstAncestor
	| diff ancestorCommit |
	
	ancestorCommit := self entity ancestors 
		ifNotEmpty: #first
		ifEmpty: [ IceNoCommit new ].
	diff := self calculateDiff: [ self entity diffTo: ancestorCommit ].
	^ IceTipCommitDiffModel
		repositoryModel: self repositoryModel 
		on: diff! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
author
	^ self entity author! !

!IceTipCommitModel methodsFor: 'copying' stamp: ''!
copyToClipboardId: id
	Clipboard clipboardText: id informing: ('Commitish ID copied to clipboard ({1})' format: {id})! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
ancestorShortId
	^ self entity ancestors first shortId! !

!IceTipCommitModel methodsFor: 'testing' stamp: ''!
hasMultipleAncestors
	
	^ self entity hasMultipleAncestors! !

!IceTipCommitModel methodsFor: 'testing' stamp: ''!
isMerged
	^ self entity isMerged! !

!IceTipCommitModel methodsFor: 'private' stamp: ''!
mergeHistoryFromAncestor: anIceGitCommit 
	^ (IceTipCommitRangeModel 
		repositoryModel: self repositoryModel 
		on: anIceGitCommit)
		toCommit: self entity parent;
		beCached! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
comment
	^ self entity comment! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
diffToWorkingCopy
	| diff |
	diff := self calculateDiff: [ self entity diffToWorkingCopy ].
	^ IceTipCommitDiffModel
		repositoryModel: self repositoryModel 
		on: diff! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
name
	
	^ self entity description! !

!IceTipCommitModel methodsFor: 'copying' stamp: ''!
copyCommitIDToClipboard
	<noCache>
	self copyToClipboardId: self commitId! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
shortId
	^ self entity shortId! !

!IceTipCommitModel methodsFor: 'accessing' stamp: ''!
diffFromHead
	| head diff |
	
	head := self repositoryModel entity headCommit.
	diff := self calculateDiff: [ head diffTo: self entity ].
	^ IceTipCommitDiffModel
		repositoryModel: self repositoryModel 
		on: diff! !

!IceTipCommitModel class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!IceTipCommitModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!IceTipCommitModel class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!IceTipCommitModel class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!IceTipCommitModel class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!IceTipCommitModel class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!IceTipCommitModel class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!IceTipCommitModel class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!IceTipCommitModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceTipCommitModel class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!IceTipCommitModel class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!IceTipCommitModel class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!IceTipCommitModel class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!IceTipCommitModel class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!IceTipCommitModel class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!IceTipCommitModel class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!IceTipCommitModel class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!IceTipCommitModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceTipCommitModel class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!IceTipCommitModel class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!IceTipCommitModel class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!IceTipCommitModel class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!IceTipCommitModel class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!IceTipCommitModel class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!IceTipCommitModel class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!IceTipCommitModel class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!IceTipCommitModel class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!IceTipCommitModel class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!IceTipCommitModel class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!IceTipCommitRangeModel methodsFor: 'accessing' stamp: ''!
toCommit: anObject
	toCommit := anObject! !

!IceTipCommitRangeModel methodsFor: 'accessing' stamp: ''!
toCommit
	^ toCommit! !

!IceTipCommitRangeModel methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	^ self name! !

!IceTipCommitRangeModel methodsFor: 'accessing' stamp: ''!
name
	^ 'Commits from {1} to {2}' format: { 
		self fromCommit shortId. 
		self toCommit shortId }! !

!IceTipCommitRangeModel methodsFor: 'accessing' stamp: ''!
commitModels
	^ (self fromCommit newCommitWalk uptoCommit: self toCommit) commits 
		collect: [ :each |
			(IceTipCommitModel 
				repositoryModel: self repositoryModel 
				on: each) 
				beCached ]
		! !

!IceTipCommitRangeModel methodsFor: 'accessing' stamp: ''!
fromCommit
	^ self entity! !

!IceTipCommitSettings class methodsFor: 'accessing' stamp: ''!
pushOnCommit

	^ pushOnCommit ifNil: [ 
		  pushOnCommit := self pushOnCommitDefaultValue ]! !

!IceTipCommitSettings class methodsFor: 'accessing' stamp: ''!
pushOnCommit: aBoolean
	pushOnCommit := aBoolean ! !

!IceTipCommitSettings class methodsFor: 'accessing' stamp: ''!
critiquesOnCommit: aBoolean
	critiquesOnCommit := aBoolean ! !

!IceTipCommitSettings class methodsFor: 'accessing' stamp: ''!
saveImageOnCommit

	^ saveImageOnCommit ifNil: [ 
		  saveImageOnCommit := self saveImageOnCommitDefaultValue ]! !

!IceTipCommitSettings class methodsFor: 'accessing' stamp: ''!
critiquesOnCommit

	^ critiquesOnCommit ifNil: [ 
		  critiquesOnCommit := self critiquesOnCommitDefaultValue ]! !

!IceTipCommitSettings class methodsFor: 'accessing' stamp: ''!
critiquesOnCommitDefaultValue

	^ true! !

!IceTipCommitSettings class methodsFor: 'accessing' stamp: ''!
saveImageOnCommit: aBoolean
	saveImageOnCommit := aBoolean ! !

!IceTipCommitSettings class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder

	<systemsettings>
	(aBuilder group: #commitPreferences)
		parent: #Iceberg;
		noOrdering;
		target: self;
		label: 'Commit action settings';
		description: 'Chose the behavior when you commit something';
		with: [
			(aBuilder setting: #critiquesOnCommit)
				noOrdering;
				target: self;
				default: self critiquesOnCommitDefaultValue;
				label: 'Run Code Critiques when commiting';
				description:
					'Check if you want to run the code critiques on the changes each time you commit them'.
			(aBuilder setting: #saveImageOnCommit)
				noOrdering;
				target: self;
				default: self saveImageOnCommitDefaultValue;
				label: 'Save the image when commiting';
				description:
					'Check if you want to save the image each time you commit something'.
			(aBuilder setting: #pushOnCommit)
				noOrdering;
				target: self;
				default: self pushOnCommitDefaultValue;
				label: 'Push when commiting';
				description:
					'Check if you want to push your changes each time you commit something' ]! !

!IceTipCommitSettings class methodsFor: 'accessing' stamp: ''!
saveImageOnCommitDefaultValue

	^ true! !

!IceTipCommitSettings class methodsFor: 'accessing' stamp: ''!
pushOnCommitDefaultValue

	^ false! !

!IceTipCommitishModel commentStamp: ''!
I'm a base model for all commitish models to be used.
I can provide #commitModels which changes depending on concrete model.!
!IceTipCommitishModel methodsFor: 'testing' stamp: ''!
isCommitish

	^ true! !

!IceTipCommitishModel methodsFor: 'accessing' stamp: ''!
commitId
	
	^ self entity commit id! !

!IceTipCommitishModel methodsFor: 'accessing' stamp: ''!
commitModels
	self subclassResponsibility! !

!IceTipCommitishModel methodsFor: 'accessing' stamp: ''!
shortCommitId
	
	^ self entity shortId! !

!IceTipCopyCommitishCommand commentStamp: ''!
Command that copies the selected entity short commit ID to the clipboard!
!IceTipCopyCommitishCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #book! !

!IceTipCopyCommitishCommand methodsFor: 'executing' stamp: ''!
execute

	self item copyCommitIDToClipboard! !

!IceTipCopyCommitishCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self hasSelectedItem and: [ self item commitId isNotNil ]! !

!IceTipCopyCommitishCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Copy the selected short commit ID (7 characters long) to the clipboard'! !

!IceTipCopyCommitishCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Copy commitish ID'! !

!IceTipCreateTagCommand commentStamp: ''!
I an a commander command that will be activated on any commitish or repository and ask the selected item to create a tag on itself.!
!IceTipCreateTagCommand methodsFor: 'activation' stamp: ''!
iconName

	^ #glamorousBookmark! !

!IceTipCreateTagCommand methodsFor: 'executing' stamp: ''!
execute
	
	(IceTipCreateTagPanel on: self item) openDialogWithSpec! !

!IceTipCreateTagCommand methodsFor: 'testing' stamp: ''!
canBeExecuted 

	^ self repositoryModel isNotNil! !

!IceTipCreateTagCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Creates a tag for the selected commit'! !

!IceTipCreateTagCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Create tag'! !

!IceTipCreateTagPanel commentStamp: ''!
I am a spec component that manages the creation of a new tag.
I have a form with a label and an input, and the commitish to tag.

I'm done to be embedded in a dialog, so I implement doAccept to execute my action.!
!IceTipCreateTagPanel methodsFor: 'testing' stamp: ''!
isNewBranch
	^ true! !

!IceTipCreateTagPanel methodsFor: 'accessing - ui' stamp: ''!
tagNameLabel

	^ tagNameLabel! !

!IceTipCreateTagPanel methodsFor: 'accessing - ui' stamp: ''!
existingTagsList

	^ existingTagsList! !

!IceTipCreateTagPanel methodsFor: 'accessing' stamp: ''!
openDialogWithSpec

	^ super openDialogWithSpec
		okAction: [ self accept ];
		yourself! !

!IceTipCreateTagPanel methodsFor: 'accessing' stamp: ''!
latestTagPartsIn: tagNames

	| prefix parts |
	"Find the highest numeric version with optional 'v' prefix. Set any missing parts to 0. For proper comparison (build data, prerelease, etc.), a Semver library is needed."
	parts := #('v' 0 0 0).
	prefix := 'v'.
	(tagNames select: [ :each | 'v?[0-9]' asRegex matchesPrefix: each ])
		ifNotEmpty: [ :tags | 
			| latestTag |
			latestTag := tags sorted last.
			parts := ((latestTag beginsWith: prefix)
				ifTrue: [ #('v') ]
				ifFalse: [ #('') ])
				,
					((((latestTag withoutPrefix: prefix) copyUpTo: $-) splitOn: '.')
						collect: [ :each | NumberParser parse: each onError: [ 0 ] ]).
			parts := parts , (#(0 0 0) first: 4 - parts size) ].
	^ parts! !

!IceTipCreateTagPanel methodsFor: 'accessing - ui' stamp: ''!
minorButton
	^ minorButton! !

!IceTipCreateTagPanel methodsFor: 'accessing' stamp: ''!
commitishToTag

	^ commitishToTag! !

!IceTipCreateTagPanel methodsFor: 'accessing' stamp: ''!
commitish: anIceTipCachedModel
	
	commitishToTag := anIceTipCachedModel! !

!IceTipCreateTagPanel methodsFor: 'accessing' stamp: ''!
accept

	self validate.
	self doAccept.
	acceptBlock ifNotNil: [ acceptBlock cull: self ]! !

!IceTipCreateTagPanel methodsFor: 'accessing' stamp: ''!
setModelBeforeInitialization: aCommitish

	self commitish: aCommitish! !

!IceTipCreateTagPanel methodsFor: 'initialization' stamp: ''!
iconForWindow

	^ self iconNamed: #smallNew! !

!IceTipCreateTagPanel methodsFor: 'accessing' stamp: ''!
latestTagParts

	^ self latestTagPartsIn: (commitishToTag tagModels collect: #name)! !

!IceTipCreateTagPanel methodsFor: 'initialization' stamp: ''!
initializeCurrentBranchLabel

	currentCommitishLabel := self newLabel
		label: 'Current commit: ', commitishToTag commit shortId;
		yourself
! !

!IceTipCreateTagPanel methodsFor: 'accessing - ui' stamp: ''!
tagName

	^ self tagNameInputText text asString trimBoth! !

!IceTipCreateTagPanel methodsFor: 'callbacks' stamp: ''!
withResultDo: aBlockClosure 
	
	callback := aBlockClosure! !

!IceTipCreateTagPanel methodsFor: 'initialization' stamp: ''!
initializeNextTagPanel

	| parts prefix nextMajor nextMinor nextPatch toString |
	parts := self latestTagParts.
	prefix := parts first.
	parts := parts allButFirst.
	toString := [ :arr | (arr collect: #asString) joinUsing: '.' ].
	nextMajor := prefix , (toString value: (Array with: parts first + 1 with: 0 with: 0)).
	nextMinor := prefix
		, (toString value: (Array with: parts first with: parts second + 1 with: 0)).
	nextPatch := prefix
		, (toString value: (Array with: parts first with: parts second with: parts third + 1)).
	majorButton := self newButton
		label: 'major (' , nextMajor , ')';
		action: [ tagNameInputText text: nextMajor ].
	minorButton := self newButton
		label: 'minor (' , nextMinor , ')';
		action: [ tagNameInputText text: nextMinor ].
	patchButton := self newButton
		label: 'patch (' , nextPatch , ')';
		action: [ tagNameInputText text: nextPatch ]
! !

!IceTipCreateTagPanel methodsFor: 'accessing - ui' stamp: ''!
majorButton
	^ majorButton! !

!IceTipCreateTagPanel methodsFor: 'initialization' stamp: ''!
initializeExistingTagsList

	existingTagsList := self newList.
	existingTagsList
		items: commitishToTag tagModels;
		display: #name;
		sortingBlock: #name descending
! !

!IceTipCreateTagPanel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'New tag of ' , commitishToTag name! !

!IceTipCreateTagPanel methodsFor: 'accessing' stamp: ''!
validate

	self 
		assert: self tagName isNotEmpty
		description: 'Please enter your new branch name.'.
	self 
		assert: (self tagName noneSatisfy: #isSeparator)
		description: 'You can''t have spaces in your branch name.'! !

!IceTipCreateTagPanel methodsFor: 'accessing - ui' stamp: ''!
tagNameInputText

	^ tagNameInputText! !

!IceTipCreateTagPanel methodsFor: 'accessing - ui' stamp: ''!
currentCommitishLabel

	^ currentCommitishLabel! !

!IceTipCreateTagPanel methodsFor: 'actions' stamp: ''!
doAccept

	self validate.
	commitishToTag
		createTag: self tagName
		thenDo: [ :newBranch | callback ifNotNil: [ callback value: newBranch ] ]! !

!IceTipCreateTagPanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	self initializeCurrentBranchLabel.

	tagNameLabel := self newLabel
		                label: 'New tag';
		                yourself.
	tagNameInputText := self newTextInput
		                    autoAccept: true;
		                    placeholder: 'e.g., v[X].[Y].[Z]';
		                    yourself.

	self initializeNextTagPanel.
	self initializeExistingTagsList.
! !

!IceTipCreateTagPanel methodsFor: 'accessing - ui' stamp: ''!
patchButton

	^ patchButton! !

!IceTipCreateTagPanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #currentCommitishLabel height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #tagNameLabel width: self labelWidth;
				   add: #tagNameInputText;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #majorButton;
				   add: #minorButton;
				   add: #patchButton;
				   yourself)
		  height: self inputTextHeight;
		  add: #existingTagsList height: self inputTextHeight * 3;
		  yourself! !

!IceTipCredentialsSettings class methodsFor: 'settings' stamp: ''!
editButtonLabel
	^ 'Edit'! !

!IceTipCredentialsSettings class methodsFor: 'settings' stamp: ''!
editButtonAction
	IceTipCredentialsStoreBrowser new openWithSpec.! !

!IceTipCredentialsSettings class methodsFor: 'settings' stamp: ''!
editButtonState
	^ true! !

!IceTipCredentialsSettings class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>

	(aBuilder group: #EditCredentials)
		parent: #icebergCredentials;
		noOrdering;
		target: self;
		label: 'Current list of credentials';
		dialog: [
			PluggableButtonMorph
				on: self
				getState: nil
				action: #editButtonAction
				label: #editButtonLabel ]! !

!IceTipCredentialsStoreBrowser commentStamp: ''!
I am the browser used to show a credentials store.!
!IceTipCredentialsStoreBrowser methodsFor: 'initialization' stamp: ''!
initializeCredentialsList

	credentialsList
		addColumn:
			(SpStringTableColumn new
				title: 'Host';
				evaluated: #hostDescription;
				width: 100 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			((SpStringTableColumn
				title: 'Type'
				evaluated: #type)
				width: 75 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			(SpStringTableColumn
				title: 'Description'
				evaluated: #description)! !

!IceTipCredentialsStoreBrowser methodsFor: 'initialization' stamp: ''!
initialize

	model ifNil: [ model := IceCredentialStore current ].	
	super initialize.
! !

!IceTipCredentialsStoreBrowser methodsFor: 'accessing' stamp: ''!
refresh

	credentialsList items: self model allCredentials! !

!IceTipCredentialsStoreBrowser methodsFor: 'accessing' stamp: ''!
store

	^ self model! !

!IceTipCredentialsStoreBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ model isCurrent
		  ifTrue: [ 'Current Iceberg credentials' ]
		  ifFalse: [ 'Credentials of ' , model printString ]! !

!IceTipCredentialsStoreBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.

	credentialsList := self newTable.
	self initializeCredentialsList.

	self refresh.! !

!IceTipCredentialsStoreBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList

	^ credentialsList! !

!IceTipCredentialsStoreBrowser methodsFor: 'accessing' stamp: ''!
credentialsList

	^ credentialsList! !

!IceTipCredentialsStoreBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	{ 	IceTipEditCredentialCommand.
		IceTipRemoveCredentialCommand }
			do: [ :each |
				aCommandGroup register: each forSpec ]
! !

!IceTipCredentialsStoreBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #credentialsList;
		  yourself! !

!IceTipCredentialsStoreBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	{	IceTipAddPlainTextCredentialCommand.
		IceTipAddSshCredentialCommand.
		IceTipAddTokenCredentialCommand }
			do: [ :each |
				aCommandGroup register: each forSpec ]! !

!IceTipCritiquesBeforeCommitBrowser commentStamp: ''!
I am a dialog to be used before commit so we can check if the code to commit has critiques on it!
!IceTipCritiquesBeforeCommitBrowser methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: someNodes

	model := someNodes! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'updating' stamp: ''!
updateSelectedCritique

	critiquesList selectedItem
		ifNil: [ 
			detailPanel text: ''.
			browseButton enabled: false.
			autofixButton enabled: false ]
		ifNotNil: [ :aCritique | 
			detailPanel text: aCritique description.
			autofixButton enabled: (aCritique providesChange).
			browseButton enabled: true ]! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'updating' stamp: ''!
disableCommitAfterChanges

	self withWindowDo: [ :window | 
		window buttons second 
			label: 'Commit';
			enabled: false.
		window buttons third label: 'Close' ]! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'accessing' stamp: ''!
onAccept: aFullBlockClosure 
	
	onAcceptAction := aFullBlockClosure ! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'actions' stamp: ''!
doAutofix

	critiquesList selectedItem ifNotNil: [ :aCritique | 
		(RePropertyAction new
			 icon: (aCritique iconNamed: #repairIcon);
			 description: 'Automatically resolve the issue';
			 action: [ :crit | 
				 | changesBrowser |
				 changesBrowser := (ChangesBrowser changes: { crit change })
					                   extent: 500 @ 400;
					                   setModal: SystemWindow topWindow;
					                   yourself.

				 changesBrowser openDialogWithSpec
					 okAction: [ 
						 changesBrowser accept.
						 self disableCommitAfterChanges.
						 self updatePresenter ];
					 centered ]) actOnCritic: aCritique ofEntity: aCritique entity ]! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Critiques for Commit on {1} branch {2}' format: { 
			  commitModel name.
			  commitModel branchName }! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'initialization' stamp: ''!
updatePresenter 

	super updatePresenter.
	critiques := (IceCritiquesVisitor new visitAll: self model; critiques) asOrderedCollection.
	critiquesList items: critiques.

	critiques ifNotEmpty: [ critiquesList selectIndex: 1].
! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aWindow

	super initializeDialogWindow: aWindow.

	aWindow initialExtent: 600@400.

	aWindow buttons addFirst: (SpButtonPresenter new 
		owner: aWindow;
		label: 'Update';
		icon: (self iconNamed: #refresh);
		action: (MessageSend receiver: self selector: #updatePresenter);
		yourself).

	aWindow buttons second label: 'Force Commit'.
	aWindow buttons third label: 'Cancel Commit'.
	
	aWindow 
		bindKeyCombination: Character cr asShortcut toAction: [ self accept].
! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'actions' stamp: ''!
accept

	self closeWindow.
	onAcceptAction value! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'initialization' stamp: ''!
initializeReasonPanel

	reasonPanel := self newText
		beNotEditable;
		addStyle: 'iceTipReadonly';
		beWrapWord;
		yourself.

	reasonPanel text: 'Selected changes in the commit have critiques detected.
Select each critique to see a detailed message of each critique.'.
! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'initialization' stamp: ''!
initializeCritiquesList

	critiquesList := self newTable.
	critiquesList
		addColumn: (SpImageTableColumn new 
			width: 20;
			evaluated: [ :aCritique | aCritique icon ];
			yourself);
		addColumn: (SpImageTableColumn new 
			width: 20;
			evaluated: [ :aCritique | self iconNamed: aCritique entity systemIconName  ];
			yourself);
		addColumn: (SpStringTableColumn new 
			title: 'Entity';
			evaluated: [ :aCritique | aCritique entity printString ];
			yourself);
		addColumn: (SpStringTableColumn new 
			title: 'Critique';
			evaluated: [ :aCritique | aCritique title ];
			yourself);
		whenSelectionChangedDo: (MessageSend receiver: self selector: #updateSelectedCritique) ! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'accessing' stamp: ''!
commitModel

	^ commitModel! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'actions' stamp: ''!
openIfCritiques

	"If the setting is disabled we just commit"
	IceTipCommitSettings critiquesOnCommit 
		ifFalse: [ ^ onAcceptAction value ].

	critiques 
		ifNotEmpty: [ self openNonModalWithSpec ] 
		ifEmpty: [ onAcceptAction value ] 
	! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'initialization' stamp: ''!
initializeDetailPanel

	detailPanel := self newText
		beNotEditable;
		beWrapWord;
		addStyle: 'iceTipReadonly';
		yourself.
! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.

	browseButton := self newButton.
	browseButton label: 'Browse Entity'.
	browseButton action: (MessageSend receiver: self selector: #doBrowse).
	browseButton icon: (self iconNamed: #glamorousBrowse).

	autofixButton := self newButton.
	autofixButton label: 'Autofix'.
	autofixButton action: (MessageSend receiver: self selector: #doAutofix).
	autofixButton icon: (self iconNamed: #repair).

	self initializeCritiquesList.
	self initializeReasonPanel.
	self initializeDetailPanel! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'accessing' stamp: ''!
commitModel: anObject

	commitModel := anObject! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'actions' stamp: ''!
doBrowse
	
	critiquesList selectedItem ifNotNil: [ :aCritique | aCritique entity browse ]! !

!IceTipCritiquesBeforeCommitBrowser methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!IceTipCritiquesBeforeCommitBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	! !

!IceTipCritiquesBeforeCommitBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
			add: #reasonPanel withConstraints: [ :constraints |
				constraints 
					height: 70;
					padding: 2 ];	
			add: #critiquesList withConstraints: [ :constraints | 
				constraints
					height: 100;
					padding: 2 ];
			add: #detailPanel withConstraints: [ :constraints | 
				constraints
					height: 100; 
					padding: 2 ];
			add: ( SpBoxLayout newLeftToRight 
				add: #browseButton;
				add: #autofixButton;
				yourself) withConstraints: [:constraints | 
					constraints 
						height: self buttonHeight;
						padding: 2];
			yourself! !

!IceTipCritiquesBeforeCommitBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	! !

!IceTipDeleteBranchCommand commentStamp: ''!
Command that deletes the selected branch!
!IceTipDeleteBranchCommand methodsFor: 'testing' stamp: ''!
actsOnBranch: aBranchModel

	^ aBranchModel isLocal! !

!IceTipDeleteBranchCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #delete! !

!IceTipDeleteBranchCommand methodsFor: 'executing' stamp: ''!
execute

	self item delete! !

!IceTipDeleteBranchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Delete this branch for this repository'! !

!IceTipDeleteBranchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Delete branch'! !

!IceTipDeleteRemoteCommand commentStamp: ''!
Command that deletes the selected remote!
!IceTipDeleteRemoteCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #delete! !

!IceTipDeleteRemoteCommand methodsFor: 'executing' stamp: ''!
execute

	self remoteModel delete! !

!IceTipDeleteRemoteCommand methodsFor: 'testing' stamp: ''!
actsOnRemote: aRemoteModel

	^ true! !

!IceTipDeleteRemoteCommand methodsFor: 'executing' stamp: ''!
remoteModel

	^ self item! !

!IceTipDeleteRemoteCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Delete this remote for this repository'! !

!IceTipDeleteRemoteCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Delete remote'! !

!IceTipDeleteTagCommand commentStamp: ''!
Command that deletes the selected tag!
!IceTipDeleteTagCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #delete! !

!IceTipDeleteTagCommand methodsFor: 'executing' stamp: ''!
execute

	self tagModel delete! !

!IceTipDeleteTagCommand methodsFor: 'executing' stamp: ''!
tagModel

	^ self item! !

!IceTipDeleteTagCommand methodsFor: 'testing' stamp: ''!
actsOnTag: aRemoteModel

	^ true! !

!IceTipDeleteTagCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Delete this tag for this repository'! !

!IceTipDeleteTagCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Delete tag'! !

!IceTipDialog commentStamp: ''!
I'm a general dialog. 
I implement a default accept method that needs to be overriden my children and some utility methods to easier build a dialog.!
!IceTipDialog methodsFor: 'actions' stamp: ''!
cancel
	"override this if you want a dialog"

	self closeWindow! !

!IceTipDialog methodsFor: 'showing' stamp: ''!
openNonModalWithSpec

	^ super openDialogWithSpec! !

!IceTipDialog methodsFor: 'showing' stamp: ''!
openDialogWithSpec

	^ self openModalWithSpec
! !

!IceTipDialog methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aWindow

	super initializeDialogWindow: aWindow.

	aWindow 
		  okAction: [ self accept ];
		  cancelAction: [ self cancel ]; 
		  bindKeyCombination: Character escape asShortcut toAction: [ self cancel ].
		! !

!IceTipDialog methodsFor: 'actions' stamp: ''!
accept
	"override this if you want a dialog"! !

!IceTipDiffEntryRemoved commentStamp: ''!
I announce when an entry (a method, a class or a package) has been reverted. 

I'm used to refresh diff panels without recalculate everything again.  !
!IceTipDiffEntryRemoved methodsFor: 'accessing' stamp: ''!
entry: anObject
	entry := anObject! !

!IceTipDiffEntryRemoved methodsFor: 'accessing' stamp: ''!
entry
	^ entry! !

!IceTipDiffEntryRemoved class methodsFor: 'instance creation' stamp: ''!
entry: anObject
	^ self new entry: anObject! !

!IceTipDiffModel commentStamp: ''!
I'm a base model to present diffs.!
!IceTipDiffModel methodsFor: 'accessing' stamp: ''!
tree
	^ self diff treeToShow! !

!IceTipDiffModel methodsFor: 'accessing' stamp: ''!
copyWithOnly: aCollection
	^ self diff copyWithOnly: aCollection! !

!IceTipDiffModel methodsFor: 'private' stamp: ''!
resetDiff
	! !

!IceTipDiffModel methodsFor: 'actions' stamp: ''!
reset
	UIManager default 	
		informUser: 'Refreshing changes' 
		during: [ 
			self resetDiff.
			"ask for diff to force a build"
			self diff ]! !

!IceTipDiffModel methodsFor: 'accessing' stamp: ''!
treeRoots
	^ self tree children! !

!IceTipDiffModel methodsFor: 'accessing' stamp: ''!
diff
	^ self subclassResponsibility! !

!IceTipDiffModel class methodsFor: 'instance creation' stamp: ''!
new
	^ self error: 'Use #for:'! !

!IceTipDiffModel class methodsFor: 'instance creation' stamp: ''!
on: aDiff
	^ self basicNew 
		initializeEntity: aDiff;
		yourself! !

!IceTipDiffPanel commentStamp: ''!
I'm a diff panel that shows packages/classes/methods changed in a column and a diff in the other.

I receive a model that needs to understand #elements.
also #elements answer should be a collection of elements that also understand elements.

(IceTipDiffPanel onDiff: (IceRepository registry first workingCopyDiff)) openWithSpec!
!IceTipDiffPanel methodsFor: 'accessing' stamp: ''!
rightLabel: aString

	diffPanel rightLabel: aString! !

!IceTipDiffPanel methodsFor: 'accessing' stamp: ''!
basicRefresh

	self resetDiffContents.
	iceNodesTree
		roots: self model treeRoots;
		expandAll! !

!IceTipDiffPanel methodsFor: 'event handling' stamp: ''!
handleArrowRight

	self expandPath: iceNodesTree selection selectedPath! !

!IceTipDiffPanel methodsFor: 'private' stamp: ''!
collapsePath: aPath

	iceNodesTree 
		collapsePath: aPath;
		selectPath: aPath! !

!IceTipDiffPanel methodsFor: 'private' stamp: ''!
expandPath: aPath

	iceNodesTree 
		expandPath: aPath;
		selectPath: aPath! !

!IceTipDiffPanel methodsFor: 'accessing' stamp: ''!
refresh

	self model reset.
	self basicRefresh
! !

!IceTipDiffPanel methodsFor: 'private' stamp: ''!
diffContentsLeft: leftString right: rightString

	diffPanel
		"Clean the diff first, to avoid comparing old right against new left"
		leftText: '';
		rightText: '';
		"Now set all of them"
		leftText: leftString;
		rightText: rightString! !

!IceTipDiffPanel methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipDiffPanel methodsFor: 'initialization' stamp: ''!
subscribeToAnnouncements

	self announcer
		when: IceTipDiffEntryRemoved 
		send: #refresh
		to: self
! !

!IceTipDiffPanel methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipDiffPanel methodsFor: 'private' stamp: ''!
resetDiffContents

	self diffContentsLeft: '' right: ''! !

!IceTipDiffPanel methodsFor: 'actions' stamp: ''!
doCollapseSelection
	
	self collapsePath: iceNodesTree selection selectedPath! !

!IceTipDiffPanel methodsFor: 'accessing - ui' stamp: ''!
diffPanel

	^ diffPanel! !

!IceTipDiffPanel methodsFor: 'initialization' stamp: ''!
changeListColumn

	^ SpCompositeTableColumn new
		addColumn: (SpImageTableColumn new
			width: 20;
			evaluated: [ :each | each value icon ];
			yourself);
		addColumn: self changeDescriptionColumn;
		yourself! !

!IceTipDiffPanel methodsFor: 'actions' stamp: ''!
doExpandSelection
	
	self expandPath: iceNodesTree selection selectedPath! !

!IceTipDiffPanel methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self subscribeToAnnouncements! !

!IceTipDiffPanel methodsFor: 'accessing' stamp: ''!
selectedItem

	^ iceNodesTree selectedItem! !

!IceTipDiffPanel methodsFor: 'event handling' stamp: ''!
selectionChanged

	| itemValue |
	itemValue := iceNodesTree selectedItem value.
	itemValue ifNotNil: [ 
		self
			diffContentsLeft: itemValue rightContents
			right: itemValue leftContents ]! !

!IceTipDiffPanel methodsFor: 'event handling' stamp: ''!
handleArrowLeft

	self collapsePath: iceNodesTree selection selectedPath! !

!IceTipDiffPanel methodsFor: 'accessing' stamp: ''!
leftLabel: aString

	diffPanel leftLabel: aString.! !

!IceTipDiffPanel methodsFor: 'specs' stamp: ''!
titleForWindow

	^ 'Diff'! !

!IceTipDiffPanel methodsFor: 'initialization' stamp: ''!
changeDescriptionColumn

	^ SpStringTableColumn new
		  evaluated: [ :each | each definition name ];
		  yourself! !

!IceTipDiffPanel methodsFor: 'accessing - ui' stamp: ''!
iceNodesTree

	^ iceNodesTree! !

!IceTipDiffPanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	iceNodesTree := self newTreeTable.
	diffPanel := self instantiate: SpDiffPresenter.

	self initializeTree.
	self initializeDiffPanel.

	self basicRefresh! !

!IceTipDiffPanel methodsFor: 'initialization' stamp: ''!
initializeDiffPanel

	diffPanel showOptions: false! !

!IceTipDiffPanel methodsFor: 'initialization' stamp: ''!
initializeTree

	iceNodesTree
		hideColumnHeaders;
		addColumn: self changeListColumn;
		children: [ :each | each children ];
		whenSelectionChangedDo: [ self selectionChanged ];
		bindKeyCombination: Character arrowLeft asKeyCombination 
			toAction: [ self handleArrowLeft ];
		bindKeyCombination: Character arrowRight asKeyCombination 
			toAction: [ self handleArrowRight ].! !

!IceTipDiffPanel class methodsFor: 'instance creation' stamp: ''!
onDiff: aDiff

	^ self on: (IceTipCommitDiffModel on: aDiff)! !

!IceTipDiffPanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newLeftToRight
		  positionOfSlider: 25 percent;
		  add: #iceNodesTree;
		  add: #diffPanel;
		  yourself! !

!IceTipDiffPreviewModel methodsFor: 'accessing' stamp: ''!
targetName
	
	^ commitish name! !

!IceTipDiffPreviewModel methodsFor: 'accessing' stamp: ''!
commitish
	^ commitish entity! !

!IceTipDiffPreviewModel methodsFor: 'accessing' stamp: ''!
calculateDiff

	self subclassResponsibility! !

!IceTipDiffPreviewModel methodsFor: 'accessing' stamp: ''!
repository
	
	^ commitish repositoryModel entity! !

!IceTipDiffPreviewModel methodsFor: 'accessing' stamp: ''!
commitish: aCommitish
	
	commitish := aCommitish! !

!IceTipDiffPreviewModel methodsFor: 'accessing' stamp: ''!
diff

	^ diffModel ifNil: [ | diff |
		UIManager default 
			informUser: 'Calculating diff'
			during: [ diff := self calculateDiff ].
			diffModel := IceTipCommitDiffModel
					repositoryModel: self repositoryModel 
					on: diff ]! !

!IceTipDiffPreviewModel methodsFor: 'accessing' stamp: ''!
repositoryName
	
	^ self repository name! !

!IceTipDiffRefreshed commentStamp: ''!
I announce when a diff has been refreshed.!
!IceTipDiffRefreshed methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceTipDiffRefreshed methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceTipDiffRefreshed class methodsFor: 'instance creation' stamp: ''!
for: aRepository
	^ self new repository: aRepository! !

!IceTipDiffSelectingPanel commentStamp: ''!
I'm a diff panel that shows packages/classes/methods changed in a column and a diff in the other.
I give users the possibility of select changes.  

By default, all my elements are selected on opening.

As my father, I receive a model that needs to understand #elements.
also #elements answer should be a collection of elements that also understand elements.

!
!IceTipDiffSelectingPanel methodsFor: 'initialization' stamp: ''!
changeListColumn

	^ SpCompositeTableColumn new
		addColumn: (SpCheckBoxTableColumn new
			width: 20;
			evaluated: [ :iceNode | checkedIceNodes includes: iceNode ];
			onActivation: [ :iceNode | self activateItem: iceNode ];
			onDeactivation: [ :iceNode | self deactivateItem: iceNode ]);
		addColumn: (SpImageTableColumn new
			width: 20;
			evaluated: [ :each | each value icon ];
			yourself);
		addColumn: self changeDescriptionColumn;
		yourself! !

!IceTipDiffSelectingPanel methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	checkedIceNodes := Set new.
	self model treeRoots do: [ :root |
		checkedIceNodes add: root.
		root allChildrenDo: [ :child | checkedIceNodes add: child ] ]
! !

!IceTipDiffSelectingPanel methodsFor: 'accessing' stamp: ''!
refresh

	super refresh.
	self model treeRoots do: [ :root |
		root withAllChildrenDo: [ :each | checkedIceNodes add: each ] ]! !

!IceTipDiffSelectingPanel methodsFor: 'private' stamp: ''!
toggleActivationItem: iceNode

	(checkedIceNodes includes: iceNode)
		ifTrue: [ self deactivateItem: iceNode ]
		ifFalse: [ self activateItem: iceNode ]

	! !

!IceTipDiffSelectingPanel methodsFor: 'accessing' stamp: ''!
refreshCheckbox
	"Refresh after a checkbox state has changed. When a node with children changes this state, all children might change too. That's the reason of this special refresh. When a leave node changed such state, this refresh is redundant."

	iceNodesTree refresh! !

!IceTipDiffSelectingPanel methodsFor: 'private' stamp: ''!
deactivateItem: iceNode
		
	checkedIceNodes remove: iceNode.
	iceNode children isEmptyOrNil ifTrue: [ ^ self ].

	iceNode allChildrenDo: [ :child |
		checkedIceNodes remove: child ifAbsent: [  ] ].

	self refreshCheckbox.! !

!IceTipDiffSelectingPanel methodsFor: 'accessing' stamp: ''!
selectedItems

	^ checkedIceNodes! !

!IceTipDiffSelectingPanel methodsFor: 'private' stamp: ''!
activateItem: iceNode
		
	checkedIceNodes add: iceNode.
	iceNode children isEmptyOrNil ifTrue: [ ^ self ].

	iceNode allChildrenDo: [ :child |
		checkedIceNodes add: child ].

	self refreshCheckbox
! !

!IceTipDiffSelectingPanel methodsFor: 'initialization' stamp: ''!
initializeTree

	super initializeTree.
	iceNodesTree 
		bindKeyCombination: Character space asKeyCombination 
		toAction: [ self toggleActivationItem: iceNodesTree selectedItem ]! !

!IceTipDirectMergeType commentStamp: ''!
I'm a direct merge.
I will perform a simple merge: 
	
	Current branch <- Merging branch

This is the default merge mechanism (what users do most of the time)!
!IceTipDirectMergeType methodsFor: 'executing' stamp: ''!
mergeOn: aModel then: aBlock
	^ aModel mergeThen: aBlock! !

!IceTipDirectoryPresenter commentStamp: ''!
I'm a model to choose directories.!
!IceTipDirectoryPresenter methodsFor: 'actions' stamp: ''!
chooseReference

	^ UIManager default 
		chooseDirectory: self chooseTitle 
		path: self location! !

!IceTipDiscardAllChangesPreviewBrowser methodsFor: 'operations' stamp: ''!
doDiscardAll
	
	self model executeDiscardAndThen: [ self closeWindow ]! !

!IceTipDiscardAllChangesPreviewBrowser methodsFor: 'private - factory' stamp: ''!
newActionButton

	^ self newButton
		label: 'Discard All';
		icon: (self iconNamed: #refresh);
		help: ('Discard all changes from the image and loads the current commit');
		action: [ self doDiscardAll ];
		yourself! !

!IceTipDiscardAllChangesPreviewBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow
	
	^ 'Preview Changes to Discard'! !

!IceTipDiscardAllChangesPreviewBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (1100 @ 400) scaledByDisplayScaleFactor! !

!IceTipDiscardAllChangesPreviewBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters 

	super initializePresenters.
	
	diffPanel
		leftLabel: 'Working Copy (Image)';
		rightLabel: 'Commit to load: ' , model workingCopy referenceCommit id.
! !

!IceTipDiscardAllChangesPreviewBrowser class methodsFor: 'instance creation' stamp: ''!
onRepository: anIceModelRepository

	^ self on: (IceTipDiscardAllModel new
			   workingCopy: anIceModelRepository entity workingCopy;
				repository: anIceModelRepository entity;
			   yourself)! !

!IceTipDiscardAllModel methodsFor: 'accessing' stamp: ''!
workingCopy

	^ workingCopy! !

!IceTipDiscardAllModel methodsFor: 'operations' stamp: ''!
discardAll
	
	workingCopy discardChanges! !

!IceTipDiscardAllModel methodsFor: 'operations' stamp: ''!
calculateDiff
	
	^ workingCopy referenceCommit diffTo: workingCopy! !

!IceTipDiscardAllModel methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceTipDiscardAllModel methodsFor: 'accessing' stamp: ''!
workingCopy: anObject

	workingCopy := anObject! !

!IceTipDiscardAllModel methodsFor: 'operations' stamp: ''!
executeDiscardAndThen: aBlock 
	
	<noCache>
	IceTipStandardAction new 
		repository: self repository;
		message: ('Discarding changes in the image');
		onSuccessRepositoryModified;
		onSuccess: aBlock;
		execute: [ self discardAll ]! !

!IceTipDiscardAllModel methodsFor: 'operations' stamp: ''!
diff

	^ diffModel ifNil: [ 
		  | diff |
		  UIManager default
			  informUser: 'Calculating diff'
			  during: [ diff := self calculateDiff ].
		  diffModel := IceTipCommitDiffModel
			               repositoryModel: self repositoryModel
			               on: diff ]! !

!IceTipDiscardAllModel methodsFor: 'accessing' stamp: ''!
repository: anIceTipCachedModel 
	
	repository := anIceTipCachedModel! !

!IceTipDiscardChangesCommand commentStamp: ''!
Command that discard all changes in the repository!
!IceTipDiscardChangesCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #refresh! !

!IceTipDiscardChangesCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipDiscardAllChangesPreviewBrowser onRepository: self repositoryModel)
		openWithSpec

! !

!IceTipDiscardChangesCommand methodsFor: 'testing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ true! !

!IceTipDiscardChangesCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self isRepositoryMissing not and: [ 
		| aCommit |
		aCommit := self repository workingCopy referenceCommit.
		aCommit isCollection not and: [ aCommit isUnknownCommit not ] ]! !

!IceTipDiscardChangesCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Discard all changes in this working copy.'! !

!IceTipDiscardChangesCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Discard all'! !

!IceTipEditCredentialCommand commentStamp: ''!
I open the edit dialog on the credential.
I colaborate with the credential to know the specific class of the dialog model.
Check #editModelClass in IceSshCredentials and IcePlaintextCredentials!
!IceTipEditCredentialCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #edit! !

!IceTipEditCredentialCommand methodsFor: 'executing' stamp: ''!
execute

	self item editModelClass new
		credentials: self item;
		credentialStore: self store;
		tool: self tool;
		openNonModal.! !

!IceTipEditCredentialCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $e meta! !

!IceTipEditCredentialCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Edits the credential from the store'! !

!IceTipEditCredentialCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Edit'! !

!IceTipEditPlaintextCredentialsModel commentStamp: ''!
I implement the dialog to edit plaintext credentials.!
!IceTipEditPlaintextCredentialsModel methodsFor: 'accessing' stamp: ''!
refreshPresenterFromCredentials

	usernameInput text: credentials username.
	passwordInput text: credentials password! !

!IceTipEditPlaintextCredentialsModel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Edit credential for ' , credentials host! !

!IceTipEditPlaintextCredentialsModel methodsFor: 'actions' stamp: ''!
refreshCredentialsFromPresenter

	credentials
		username: self username;
		password: self password! !

!IceTipEditPlaintextCredentialsModel methodsFor: 'actions' stamp: ''!
accept 
	
	^ self acceptEditAction! !

!IceTipEditPlaintextCredentialsModel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (350 @ (self class inputTextHeight * 4 + self class buttonHeight))
		  scaledByDisplayScaleFactor! !

!IceTipEditPlaintextCredentialsModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #usernameLabel
				   width: 80 * self currentWorld displayScaleFactor;
				   add: #usernameInput;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #passwordLabel
				   width: 80 * self currentWorld displayScaleFactor;
				   add: #passwordInput;
				   yourself)
		  height: self inputTextHeight;
		  yourself! !

!IceTipEditProjectDialog methodsFor: 'actions' stamp: ''!
selectedFileFormat
	
	^ formatList selectedItem! !

!IceTipEditProjectDialog methodsFor: 'accessing - ui' stamp: ''!
sourceDirectoryTree

	^ sourceDirectoryTree! !

!IceTipEditProjectDialog methodsFor: 'events' stamp: ''!
onAccept: aBlockClosure 
	
	acceptCallback := aBlockClosure! !

!IceTipEditProjectDialog methodsFor: 'initialization' stamp: ''!
initializeMessagePanel

	| icon |

	self hasToShowWarning ifTrue: [ 
		icon := self iconNamed: #warning.
		icon := icon scaledToSize: (icon extent * 2).

		messageIcon image: icon .
		messageText text: self warningMessage ]! !

!IceTipEditProjectDialog methodsFor: 'initialization' stamp: ''!
initializeDirectoryTree

	sourceDirectoryTree
		addColumn: (SpCompositeTableColumn new
				 addColumn: (SpImageTableColumn new
						  width: 20;
						  evaluated: [ self iconNamed: #package ];
						  yourself);
				 addColumn: (SpStringTableColumn new
						  evaluated: #basename;
						  yourself));
		roots: { self model fileSystem };
		children: [ :each | each directories ];
		whenSelectionChangedDo: [ :announcement | 
			self sourceDirectorySelectionChanged: announcement selectedPaths ]! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
messageIcon

	^ messageIcon! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
defaultFormat

	^ defaultFormat! !

!IceTipEditProjectDialog methodsFor: 'actions' stamp: ''!
accept	
	
	IceTipStandardAction new 
		repository: model repository;
		message: 'Setting up project';
		onSuccessRepositoryModified;
		execute: [ 
			"Update the project"
			model sourceDirectory: self selectedDirectoryPath pathString.
			model fileFormat: self selectedFileFormat.
			self assert: model repositoryProperties fileFormat = self selectedFileFormat.
			"Set the project in the repository"
			model repository workingCopy project: model ].

	self closeWindow.
	acceptCallback ifNotNil: [ 
		acceptCallback value ].! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
acceptCallback

	^ acceptCallback! !

!IceTipEditProjectDialog methodsFor: 'accessing - ui' stamp: ''!
nameLabel

	^ nameLabel! !

!IceTipEditProjectDialog methodsFor: 'events' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipEditProjectDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ self hasToShowWarning 
		ifTrue: [ (475@525) scaledByDisplayScaleFactor ]
		ifFalse: [  
			(475@(
				200 "Tree"
				+ (self class inputTextHeight * 3)
				+ self class buttonHeight 
				+ 75 "Yes, a magic number"
			)) scaledByDisplayScaleFactor]
! !

!IceTipEditProjectDialog methodsFor: 'actions' stamp: ''!
removeDirectory

	| toRemove newSelection |
	
	newSelection := selectedDirectoryPath parent.
	toRemove := selectedDirectoryPath asResolvedBy: self model fileSystem.

	toRemove exists 
		ifTrue: [ 
			(UIManager default 
				questionWithoutCancel: ('Are you sure to delete ''{1}''?' format: {toRemove basename})  
				title: 'Remove directory')
				ifFalse: [ ^ self].
			toRemove ensureDelete ].
		
	sourceDirectoryTree roots: { self model fileSystem }.
	self expandAndSelect: newSelection.
! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
username

	^ self nameInput text trimBoth! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
messageText 

	^ messageText ! !

!IceTipEditProjectDialog methodsFor: 'accessing - ui' stamp: ''!
formatLabel

	^ formatLabel! !

!IceTipEditProjectDialog methodsFor: 'actions' stamp: ''!
addDirectory

	| newDirectoryName newDirectory previousSelection |
	
	newDirectoryName := UIManager default
		textEntry: 'Enter the new Directory name'
		title: 'Create a directory'.
	
	newDirectoryName ifNil: [ ^ self ].
	
	previousSelection := selectedDirectoryPath.
	newDirectory := (previousSelection / newDirectoryName) asResolvedBy: self model fileSystem. 
	
	newDirectory exists 
		ifFalse: [ newDirectory createDirectory ].
	
	sourceDirectoryTree roots: { self model fileSystem }.
	self expandAndSelect: previousSelection.
! !

!IceTipEditProjectDialog methodsFor: 'accessing - ui' stamp: ''!
sourceDirectoryLabel

	^ sourceDirectoryLabel! !

!IceTipEditProjectDialog methodsFor: 'initialization' stamp: ''!
initialize

	selectedDirectoryPath := RelativePath new.
	formats := TIceRepositoryWriter users sorted: [ :a :b | a description < b description ].
	defaultFormat := IceLibgitRepository defaultFileFormat.
	
	super initialize.! !

!IceTipEditProjectDialog methodsFor: 'accessing - ui' stamp: ''!
nameInput

	^ nameInput! !

!IceTipEditProjectDialog methodsFor: 'accessing - ui' stamp: ''!
formatList

	^ formatList! !

!IceTipEditProjectDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Edit Project'! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
warningMessage

	^ 'Be careful. You should choose the actual format of the current repository.
Changing the format in here will not migrate your code to another format.

If you want to migrate your code from Filetree to Tonel, use the migration option in the context menu (Extra >> Convert repository sources to Tonel).'! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
formats

	^ formats! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
hasToShowWarning

	^ model repository workingCopy packages isNotEmpty! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
selectedDirectoryPath

	^ selectedDirectoryPath! !

!IceTipEditProjectDialog methodsFor: 'accessing' stamp: ''!
sourceDirectorySelectionChanged: selectedPaths

	| selection |

	selectedPaths
		ifEmpty:
			[ "If the user does not select any directory, we choose the root and we use the default format"
			selectedDirectoryPath := RelativePath new.
			selection := self sourceDirectoryTree roots first ]
		ifNotEmpty: [ selection := self sourceDirectoryTree
				itemAtPath: selectedPaths first. ].
	formatList selectItem: (self guessFormatFromDirectory: selection).
	selectedDirectoryPath := selection relativeTo: self model fileSystem. ! !

!IceTipEditProjectDialog methodsFor: 'utilities' stamp: ''!
expandAndSelect: aRelativePath 

	
	| path aPathForSpec currentNode |
	path := aRelativePath segments	asOrderedCollection.
	
	aPathForSpec := OrderedCollection new.
	aPathForSpec add: 1.
	
	currentNode := self model fileSystem.
	
	path do: [ :aPart | | found |
		found := currentNode directories detect: [ :e | e basename = aPart ] ifNone: [ ^self ].
		aPathForSpec add: (currentNode directories indexOf: found).
		currentNode := found].
	
	sourceDirectoryTree expandPath: aPathForSpec.

	sourceDirectoryTree withAdapterPerformOrDefer: [ :anAdapter |
		sourceDirectoryTree selectPaths: { aPathForSpec } ].
	
	

! !

!IceTipEditProjectDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	nameLabel := self newLabel
		label: 'Project Name';
		yourself.
	nameInput := self newLabel
		label: self model name;
		yourself.
	sourceDirectoryLabel := self newLabel
		label: 'Code directory';
		yourself.
	sourceDirectoryTree := self newTreeTable.
	formatLabel := self newLabel
		label: 'Format';
		yourself.
	formatList := self newDropList.
	messageIcon := self newImage.
	messageText := self newText
		beNotEditable;
		addStyle: 'iceTipReadonly';
		yourself.

	removeButton := self newButton icon: (self iconNamed: #remove); yourself.
	addButton := self newButton icon: (self iconNamed: #add); yourself.

	self initializeMessagePanel.
	self initializeDirectoryTree.
! !

!IceTipEditProjectDialog methodsFor: 'initialization' stamp: ''!
connectPresenters

	super connectPresenters.

	removeButton action: [ self removeDirectory ].
	addButton action: [ self addDirectory ].

	self formatList
		items: self formats;
		display: [ :each | each description ];
		selectItem: model repositoryProperties fileFormat.

	self expandAndSelect: (RelativePath with: model sourceDirectory).
! !

!IceTipEditProjectDialog methodsFor: 'format-management' stamp: ''!
guessFormatFromDirectory: aFileReference 
	
	"We take as guinea pig a sub-directory to guess what format it is on.
	In case the current directory has no children directories, we just select the default format"
	| guineaPig |
	guineaPig := aFileReference children detect: [ :any | any isDirectory ] ifNone: [ ^ defaultFormat ].
	
	"Filetree must have precedence as it has the most restrictive name convention (directories ending with .package)"
	((formats includes: IceLibgitFiletreeWriter)
		and: [ IceLibgitFiletreeWriter isValidPackage: guineaPig ])
			ifTrue: [ ^ IceLibgitFiletreeWriter ].
	
	"Otherwise go with the entire list"
	^ formats
		detect: [ :each | each isValidPackage: guineaPig ]
		ifNone: [ ^ defaultFormat ].! !

!IceTipEditProjectDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #nameLabel width: self labelWidth;
				   add: #nameInput expand: true;
				   add: #addButton width: 32 * self currentWorld displayScaleFactor;
				   add: #removeButton width: 32 * self currentWorld displayScaleFactor;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #sourceDirectoryLabel width: self labelWidth;
				   add: #sourceDirectoryTree;
				   yourself)
		  height: 200 * self currentWorld displayScaleFactor;
		  add: (SpBoxLayout newLeftToRight
				   add: #formatLabel width: self labelWidth;
				   add: #formatList;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #messageIcon width: self labelWidth;
				   add: #messageText;
				   yourself);
		  yourself! !

!IceTipEditRepositoryCommand commentStamp: ''!
Command that opens a dialog to edit a repository meta-data!
!IceTipEditRepositoryCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #edit! !

!IceTipEditRepositoryCommand methodsFor: 'executing' stamp: ''!
execute

	self repositoryModel edit! !

!IceTipEditRepositoryCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ super canBeExecuted and: [ self isRepositoryOperational ]! !

!IceTipEditRepositoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Edit repository data'! !

!IceTipEditRepositoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Edit...'! !

!IceTipEditSSHCredentialsModel commentStamp: ''!
I implement the dialog to edit SSH credentials.!
!IceTipEditSSHCredentialsModel methodsFor: 'accessing' stamp: ''!
refreshPresenterFromCredentials

	usernameInput text: credentials username.
	passphraseInput text: credentials keyPassphrase.
	privateKeyInput location: credentials privateKey.
	publicKeyInput location: credentials publicKey! !

!IceTipEditSSHCredentialsModel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Edit SSH keys for ' , self credentials hostDescription! !

!IceTipEditSSHCredentialsModel methodsFor: 'actions' stamp: ''!
refreshCredentialsFromPresenter

	credentials
		username: self username;
		publicKey: self publicKey;
		privateKey: self privateKey;
		keyPassphrase: self passphrase! !

!IceTipEditSSHCredentialsModel methodsFor: 'actions' stamp: ''!
accept

	^ self acceptEditAction! !

!IceTipEditSSHCredentialsModel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (350 @ (self class inputTextHeight * 6 + self class buttonHeight)) scaledByDisplayScaleFactor! !

!IceTipEditSSHCredentialsModel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #usernameLabel width: self labelWidth;
				   add: #usernameInput;
				   yourself)
		  height: self inputTextHeight;
		  add: #publicKeyInput height: self inputTextHeight;
		  add: #privateKeyInput height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #passphraseLabel width: self labelWidth;
				   add: #passphraseInput;
				   yourself)
		  height: self inputTextHeight! !

!IceTipEditTokenCredentialsModel commentStamp: ''!
I am a dialog to edit token credentials.!
!IceTipEditTokenCredentialsModel methodsFor: 'accessing' stamp: ''!
refreshPresenterFromCredentials

	usernameInput text: credentials username.
	tokenInput text: credentials token.
	hostInput text: credentials host.
! !

!IceTipEditTokenCredentialsModel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Edit token credentials'! !

!IceTipEditTokenCredentialsModel methodsFor: 'accessing' stamp: ''!
refreshCredentialsFromPresenter

	credentials
		username: self usernameFromInput;
		token: self tokenFromInput;
		host: self hostnameFromInput
! !

!IceTipEditTokenCredentialsModel methodsFor: 'accessing' stamp: ''!
accept

	^ self acceptEditAction! !

!IceTipEntityModel commentStamp: ''!
I'm a generic model for Iceberg entities (tipically, repositories, commits, packages, etc., etc., etc.) !
!IceTipEntityModel methodsFor: 'accessing' stamp: ''!
displayString
	^ self entity name! !

!IceTipEntityModel methodsFor: 'accessing' stamp: ''!
repositoryModel
	^ repositoryModel! !

!IceTipEntityModel methodsFor: 'accessing' stamp: ''!
repositoryModel: anObject
	repositoryModel := anObject! !

!IceTipEntityModel methodsFor: 'TOMOVE' stamp: ''!
colorNotLoaded
	^ Smalltalk ui theme disabledTextColor! !

!IceTipEntityModel methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	"A decorated description of this entity. 
	 It can return a text (in case decorations apply) or a simple string."
	^ self subclassResponsibility! !

!IceTipEntityModel methodsFor: 'initialization' stamp: ''!
initializeEntity: anObject
	entity := anObject.
	self initialize
	! !

!IceTipEntityModel methodsFor: 'testing' stamp: ''!
isCommitish
	
	^ false! !

!IceTipEntityModel methodsFor: 'accessing' stamp: ''!
entity
	^ entity! !

!IceTipEntityModel methodsFor: 'TOMOVE' stamp: ''!
colorModified
	^ Smalltalk ui theme successTextColor! !

!IceTipEntityModel methodsFor: 'TOMOVE' stamp: ''!
toWarningMessage: aString
	^ aString asText allBold makeAllColor: self colorWarning! !

!IceTipEntityModel methodsFor: 'TOMOVE' stamp: ''!
colorWarning
	^ Smalltalk ui theme warningTextColor! !

!IceTipEntityModel methodsFor: 'tagging' stamp: ''!
createTag: aString thenDo: aBlockClosure 
	<noCache>

	IceTipStandardAction new 
		repository: self entity;
		message: ('Creating tag {1} on commit {2}' format: { aString. self commit shortId });
		onSuccessRepositoryModified;
		execute: [ | branch |
			branch := self commit createTag: aString.
			aBlockClosure value: branch ]
	! !

!IceTipEntityModel methodsFor: 'testing' stamp: ''!
isModelOf: anObject
	^ self entity = anObject! !

!IceTipEntityModel class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #for:'! !

!IceTipEntityModel class methodsFor: 'instance creation' stamp: ''!
on: anObject 
	^ self basicNew 
		initializeEntity: anObject;
		yourself! !

!IceTipEntityModel class methodsFor: 'instance creation' stamp: ''!
repositoryModel: aRepositoryModel on: anObject 
	^ self basicNew		
		initializeEntity: anObject;
		repositoryModel: aRepositoryModel;
		yourself! !

!IceTipErrorDialog commentStamp: ''!
I'm an error dialog that is used to show generic errors to users.
This is to enhance the user experience of using iceberg, since exceptions can be sometimes intrusive or aggresive.

My model is an exception that I'll freeze for further debugging.

(IceTipErrorDialog on: anError) openDialogWithSpec!
!IceTipErrorDialog methodsFor: 'accessing - ui' stamp: ''!
errorLabel

	^ errorLabel! !

!IceTipErrorDialog methodsFor: 'accessing - ui' stamp: ''!
iconPanel

	^ iconPanel! !

!IceTipErrorDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Error'! !

!IceTipErrorDialog methodsFor: 'accessing' stamp: ''!
exception

	^ exception! !

!IceTipErrorDialog methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aWindow

	aWindow 
		addButton: 'Debug' 
		do: [ :presenter | self accept. presenter close ].
	aWindow 
		addButton: 'Ignore' 
		do: [ :presenter | presenter close ].! !

!IceTipErrorDialog methodsFor: 'initialization' stamp: ''!
accept
	
	self closeWindow.
	exception debug.! !

!IceTipErrorDialog methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aDomainObject

	self exception: aDomainObject! !

!IceTipErrorDialog methodsFor: 'accessing' stamp: ''!
exception: anException

	exception := anException freeze! !

!IceTipErrorDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (500@(
		self class inputTextHeight * 2
		+ self class buttonHeight 
		+ 50 "Yes, a magic number"
		)) scaledByDisplayScaleFactor! !

!IceTipErrorDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.

	iconPanel := self newImage.
	iconPanel image: (self iconNamed: #error).

	errorLabel := self newText.
	errorLabel text: exception messageText! !

!IceTipErrorDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		  add: #iconPanel width: 40 * self currentWorld displayScaleFactor;
		  add: #errorLabel;
		  yourself! !

!IceTipExistingBranchPanel commentStamp: ''!
I'm a panel (that will be part of a dialog) to perform actions on existing panels. 
Actions themselves needs to be defined by my children.!
!IceTipExistingBranchPanel methodsFor: 'accessing' stamp: ''!
selectedBranch

	^ self branchesList selection selectedItem! !

!IceTipExistingBranchPanel methodsFor: 'accessing - ui' stamp: ''!
titleForWindow: aString

	title := aString! !

!IceTipExistingBranchPanel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ title ifNil: [ self model name ]! !

!IceTipExistingBranchPanel methodsFor: 'accessing' stamp: ''!
validate

	self selectedBranch ifNil: [ 
		IceError signal: 'Please select a branch to checkout.' ]! !

!IceTipExistingBranchPanel methodsFor: 'initialization' stamp: ''!
branchModels

	^ self model branchModels! !

!IceTipExistingBranchPanel methodsFor: 'accessing - ui' stamp: ''!
icon

	^ icon ifNil: [ self iconNamed: #branch ]! !

!IceTipExistingBranchPanel methodsFor: 'accessing - ui' stamp: ''!
branchesList

	^ branchesList! !

!IceTipExistingBranchPanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	branchesList := self newTable.
	self initializeBranchesList! !

!IceTipExistingBranchPanel methodsFor: 'accessing - ui' stamp: ''!
icon: anIcon

	icon := anIcon! !

!IceTipExistingBranchPanel methodsFor: 'initialization' stamp: ''!
initializeBranchesList

	branchesList
		hideColumnHeaders;
		addColumn: (SpStringTableColumn evaluated: #shortDescriptionWithDecoration);
		items: self model branchModels.

	self model branchModels
		detect: #isHead
		ifFound: [ :head | branchesList selectItem: head ]
		ifNone: [ self model hasBranches ifTrue: [ branchesList selectIndex: 1 ] ].

	self flag: #pharoTodo. "Instead of detecting 'isHead', we would prefer to select 'self model defaultBranchSelection' but we have a bug with the caches. The reason is that #branchModels returns the same cache used by the list but not #defaultBranchSelection."
! !

!IceTipExistingBranchPanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		  add: #branchesList;
		  yourself! !

!IceTipFetchAllProjectCommand commentStamp: ''!
I'm a command to perform a fetch operation on all registered projects.!
!IceTipFetchAllProjectCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #smallUpdate! !

!IceTipFetchAllProjectCommand methodsFor: 'executing' stamp: ''!
isConfirmed

	^ UIManager default
		  confirm:
		  'This operation can take some times depending on the size and number of your repositories. Are you sure you want to fetch all repositories?'
		  label: 'Proceed?'! !

!IceTipFetchAllProjectCommand methodsFor: 'executing' stamp: ''!
execute

	| repositories |
	self isConfirmed ifFalse: [ ^ self ].
	
	repositories := IceRepository registry.
	UIManager default
		informUserDuring: [ :bar | 
			bar max: repositories size.
			bar value: 1.
			repositories
				withIndexDo: [ :each :index | 
					bar label: ('Fetching incoming commits of {1}' format: {each name}).
					bar value: index + 1.
					each fetch ] ].
	
	"Inform an unespecified change to force a refresh"
	Iceberg announcer announce: IceRepositoryModified new! !

!IceTipFetchAllProjectCommand methodsFor: 'testing' stamp: ''!
canBeExecuted 
	
	"This command can be executed with our without selection"
	^ true! !

!IceTipFetchAllProjectCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Fetch (bring new commits) from all repositories in your list.'! !

!IceTipFetchAllProjectCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Fetch all'! !

!IceTipFetchCommand commentStamp: ''!
I'm a command to perform a fetch operation on selected project.!
!IceTipFetchCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #smallUpdate! !

!IceTipFetchCommand methodsFor: 'executing' stamp: ''!
execute

	self repositoryModel fetch! !

!IceTipFetchCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $f meta! !

!IceTipFetchCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ super canBeExecuted and: [ 
		  self isRepositoryMissing not and: [ 
			  self repositoryModel hasRemotes ] ]! !

!IceTipFetchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Fetch (bring new commits) from this repositories.'! !

!IceTipFetchCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Fetch'! !

!IceTipFetchInPullCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #smallUpdate! !

!IceTipFetchInPullCommand methodsFor: 'executing' stamp: ''!
execute

	context model remoteModel fetch
! !

!IceTipFetchInPullCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Fetch from the selected remote'! !

!IceTipFetchInPullCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Fetch'! !

!IceTipFetchRemoteCommand commentStamp: ''!
Command that fetches from remote repositories!
!IceTipFetchRemoteCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #smallUpdate! !

!IceTipFetchRemoteCommand methodsFor: 'executing' stamp: ''!
execute

	self remoteModel fetch! !

!IceTipFetchRemoteCommand methodsFor: 'testing' stamp: ''!
actsOnRemote: aRemoteModel

	^ true! !

!IceTipFetchRemoteCommand methodsFor: 'executing' stamp: ''!
remoteModel

	^ self item! !

!IceTipFetchRemoteCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Fetch commits from this remote'! !

!IceTipFetchRemoteCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Fetch remote'! !

!IceTipFilePresenter commentStamp: ''!
I'm a model to choose files.!
!IceTipFilePresenter methodsFor: 'actions' stamp: ''!
chooseReference

	^ UIManager default
		   chooseExistingFileReference: self chooseTitle
		   extensions: nil
		   path: self location
		   preview: nil! !

!IceTipFiletreeToTonelDialog commentStamp: ''!
I'm a dialog validate and perform a migration of sources from filetree to tonel.
!
!IceTipFiletreeToTonelDialog methodsFor: 'accessing' stamp: ''!
branchBaseName

	^ 'migrate-sources-to-tonel'! !

!IceTipFiletreeToTonelDialog methodsFor: 'accessing - ui' stamp: ''!
iconPanel

	^ iconPanel! !

!IceTipFiletreeToTonelDialog methodsFor: 'accessing - ui' stamp: ''!
mergeWithMasterCheckbox

	^ mergeWithMasterCheckbox! !

!IceTipFiletreeToTonelDialog methodsFor: 'accessing' stamp: ''!
repository

	^ repository! !

!IceTipFiletreeToTonelDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Convert sources to tonel'! !

!IceTipFiletreeToTonelDialog methodsFor: 'accessing' stamp: ''!
branchName

	^ branchName ifNil: [ branchName := self obtainBranchName ]! !

!IceTipFiletreeToTonelDialog methodsFor: 'actions' stamp: ''!
doAccept
	
	IceConvertFormatAction new 
		repository: self repository;
		branchName: self branchName;
		format: #tonel;
		mergeWithCurrentBranch: self mergeWithMasterCheckbox state;
		execute! !

!IceTipFiletreeToTonelDialog methodsFor: 'actions' stamp: ''!
accept
	
	IceTipStandardAction new 
		repository: self repository; 
		message: ('Migrating {1} sources to tonel' format: { self repository name });
		onSuccessRepositoryModified;
		onSuccess: [ UIManager default inform: 'Sources migrated!!' ];
		execute: [ self doAccept ]! !

!IceTipFiletreeToTonelDialog methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	repository := anObject! !

!IceTipFiletreeToTonelDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (500
	   @ (self class inputTextHeight * 5 + self class buttonHeight + 50))
		  scaledByDisplayScaleFactor! !

!IceTipFiletreeToTonelDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	iconPanel := self newImage
		image: (self iconNamed: #question);
		yourself.
	confirmLabel := self newText
		text: (self confirmMessage format: {
			self repository name.
			self branchName });
		yourself.
	mergeWithMasterCheckbox := self newCheckBox
		label: ('Merge with branch {1}' format: {self repository branchName});
		state: true;
		yourself.
! !

!IceTipFiletreeToTonelDialog methodsFor: 'accessing' stamp: ''!
confirmMessage

	^ 'Convert repository {1} sources from filetree format to tonel. 
This process will use a new branch named {2}. 
You can choose to not merge immediately your migration.

ARE YOU SURE?'! !

!IceTipFiletreeToTonelDialog methodsFor: 'private' stamp: ''!
obtainBranchName

	| baseName suffix count |
	count := 0.
	baseName := self branchBaseName.
	suffix := ''.
	[ true ] whileTrue: [ 
		self repository
			branchNamed: baseName , suffix
			ifAbsent: [ ^ baseName , suffix ].
		count := count + 1.
		suffix := '-' , count asString ]! !

!IceTipFiletreeToTonelDialog methodsFor: 'accessing - ui' stamp: ''!
confirmLabel

	^ confirmLabel! !

!IceTipFiletreeToTonelDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		  add: #iconPanel width: 40 * self currentWorld displayScaleFactor;
		  add: (SpBoxLayout newTopToBottom
				   add: #confirmLabel;
				   add: #mergeWithMasterCheckbox height: self inputTextHeight;
				   yourself);
		  yourself! !

!IceTipForgetRepositoryCommand commentStamp: ''!
I will allow the "forget" of a repository (remote it from list of registered repositories).
I also add the possibility of remove the repository from file system.!
!IceTipForgetRepositoryCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #remove! !

!IceTipForgetRepositoryCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipRemoveRepositoryDialog on: self repositoryModel)
		openDialogWithSpec! !

!IceTipForgetRepositoryCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $x meta! !

!IceTipForgetRepositoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Removes this repository from the list of managed repositories (it will not remove any local repository)'! !

!IceTipForgetRepositoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Forget repository'! !

!IceTipGitHubPullRequestListBrowser commentStamp: ''!
Description
--------------------

I am a spec presenter to show the list of PR available for a remote and informations on them.
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	details:				<aPresenter>		A presenten showing the details for a PR.
	pullRequests:		<anAdaptor>		An adaptor corresponding to a table containing the pull requests to view.
	remote:				<aRemote>			The remote we should view the PR of.
!
!IceTipGitHubPullRequestListBrowser methodsFor: 'accessing' stamp: ''!
remote: aRemote

	remote := aRemote! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'accessing' stamp: ''!
details

	^ details! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'actions' stamp: ''!
refreshPullRequests
	
	self pullRequests
		items: self fetchPullRequests;
		selectIndex: 1 "No error if list is empty"
! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'private' stamp: ''!
strongSelection: aSelection

	self viewPullRequest: aSelection selectedItem! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'accessing' stamp: ''!
repository

	^ model! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Pull requests on {1} ({2})' format: { self remote name. self remote url }! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'private' stamp: ''!
fetchPullRequests

	^ (IceGitHubAPI new
		getPullRequests: self remote owner project: self remote projectName) all
		collect: [ :each | 
			(IceGitHubPullRequest fromJSON: each)
				repository: self repository entity;
				yourself ]! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'private' stamp: ''!
updateSelectedPullRequest: aSpSingleSelectionMode

	aSpSingleSelectionMode isEmpty ifFalse: [ 
		self details pullRequest: aSpSingleSelectionMode selectedItem ]! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'initialization' stamp: ''!
initializePullRequestsTable

	pullRequests
		beResizable;
		addColumn:
			(SpStringTableColumn new
				title: '#';
				evaluated: [ :pullRequest | pullRequest number asString ];
				width: 50 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			(SpStringTableColumn new
				title: 'State';
				evaluated: #state;
				width: 50 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			(SpStringTableColumn new
				title: 'Author';
				evaluated: #author;
				width: 120 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			(SpStringTableColumn new
				title: 'Title';
				evaluated: #title;
				yourself)
! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (700 @ 700) scaledByDisplayScaleFactor! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'actions' stamp: ''!
viewPullRequest: aPullRequest

	UIManager default
		informUser: (
				'Opening pull request {1} {2}' format: { 
					 aPullRequest number.
					 aPullRequest title })
		during: [ 
			(IceGitHubTipPullRequestBrowser
				 on: self model
				 pullRequest: aPullRequest) openWithSpec ]! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	pullRequests := self newTable.
	details := self instantiate: IceGitHubPullRequestDetailModel.
	
	self initializePullRequestsTable.
! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'initialization' stamp: ''!
connectPresenters

	super connectPresenters.
	self pullRequests
		activateOnDoubleClick;
		whenActivatedDo: [ :selection | self strongSelection: selection ];
		whenSelectionChangedDo: [ :selection |
			self updateSelectedPullRequest: selection ].
! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList

	^ pullRequests! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'accessing' stamp: ''!
pullRequests

	^ pullRequests! !

!IceTipGitHubPullRequestListBrowser methodsFor: 'accessing' stamp: ''!
remote

	^ remote! !

!IceTipGitHubPullRequestListBrowser class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository

	^ self on: (IceTipRepositoryModel on: aRepository)! !

!IceTipGitHubPullRequestListBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	{ 	IceTipOpenGitHubPullRequestCommand }
			do: [ :each |
				aCommandGroup register: each forSpec ]
! !

!IceTipGitHubPullRequestListBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newTopToBottom
		  positionOfSlider: 30 percent;
		  add: #pullRequests;
		  add: #details;
		  yourself! !

!IceTipGitHubPullRequestListBrowser class methodsFor: 'accessing' stamp: ''!
taskbarIcon

	^ self iconNamed: #komitterSmalltalkhubRemote! !

!IceTipGitHubPullRequestListBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	aCommandGroup register: IceTipRefreshPullRequestsCommand forSpec! !

!IceTipGitHubRepositoryPanel commentStamp: ''!
I'm a presenter to define a new remote repository from a GitHub repository (owner/project).
!
!IceTipGitHubRepositoryPanel methodsFor: 'accessing' stamp: ''!
configureBuilder: aBuilder

	aBuilder beGithub! !

!IceTipGitHubRepositoryPanel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Clone From github.com'! !

!IceTipGitHubRepositoryPanel methodsFor: 'accessing' stamp: ''!
providerName

	^ 'GitHub'! !

!IceTipGitHubRepositoryPanel methodsFor: 'querying - github' stamp: ''!
getGitHubRepository

	^ [ IceGitHubAPI new
		beAnonymous;
		getRepository: self userName project: self projectName ]
			on: LGitNoCredentialsProvided
			do: [ nil ]! !

!IceTipGitHubRepositoryPanel methodsFor: 'initialization' stamp: ''!
iconForWindow

	^ (self iconNamed: #github) lighter: 0.50 "just to be sure is visible in all themes"! !

!IceTipGitHubRepositoryPanel methodsFor: 'accessing' stamp: ''!
newRepository

	| newRepository |
	newRepository := super newRepository.
	UIManager default 
		informUser: 'Configuring Remotes...'
		during: [ | githubRepository |
			githubRepository := self getGitHubRepository.
			githubRepository ifNil: [ ^ newRepository ].
			(githubRepository at: #fork)
				ifTrue: [ | parent remote |
					parent := githubRepository at: #parent.
					remote := IceGitRemote
						name: ((parent at: #owner) at: #login)
						url: (parent at: self selectedProtocol githubRequestUrlKey).
					newRepository addRemote: remote.
					remote fetch. ] ].
	^ newRepository
! !

!IceTipGitHubRepositoryPanel class methodsFor: 'accessing' stamp: ''!
order

	^ 100! !

!IceTipGitLabRepositoryPanel commentStamp: ''!
I'm a panel to show and/or manipulate a project definition in a GitLab git repository.!
!IceTipGitLabRepositoryPanel methodsFor: 'actions' stamp: ''!
configureBuilder: aBuilder

	aBuilder beGitLab! !

!IceTipGitLabRepositoryPanel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Clone From gitlab.com'! !

!IceTipGitLabRepositoryPanel methodsFor: 'accessing' stamp: ''!
providerName

	^ 'GitLab'! !

!IceTipGitLabRepositoryPanel methodsFor: 'initialization' stamp: ''!
iconForWindow

	^ self iconNamed: #gitlab! !

!IceTipGitLabRepositoryPanel class methodsFor: 'accessing' stamp: ''!
order

	^ 120! !

!IceTipGitProviderRepositoryPanel commentStamp: ''!
I'm a panel to show and/or manipulate a project definition in a git remote repository.

I'm an abstract class, and my concrete subclasses define the particularities
for each provider.
!
!IceTipGitProviderRepositoryPanel methodsFor: 'accessing - ui' stamp: ''!
userNameLabel

	^ userNameLabel! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing - ui' stamp: ''!
projectNameInputText

	^ projectNameInputText! !

!IceTipGitProviderRepositoryPanel methodsFor: 'actions' stamp: ''!
configureBuilder: aBuilder

	self subclassResponsibility! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing' stamp: ''!
projectName

	^ self projectNameInputText text asString trimmed! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing' stamp: ''!
remoteUrl
	
	| builder |
	builder := IceUrlBuilder new
		protocol: self selectedProtocol new;
		username: self userName project: self projectName.
	self configureBuilder: builder.
	^ builder buildUrl! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing' stamp: ''!
selectedProtocol

	^ self protocolDropList selectedItem! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing' stamp: ''!
validate

	self
		assert: self userName isNotEmpty
		description: 'You must enter a GitHub owner (e.g. username).'.
	self
		assert: self projectName isNotEmpty
		description: 'You must enter a GitHub project name.'.
	super validate! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing - ui' stamp: ''!
userNameInputText

	^ userNameInputText! !

!IceTipGitProviderRepositoryPanel methodsFor: 'private' stamp: ''!
projectAsPathToAppend

	^ (self userName isEmpty and: [ self projectName isEmpty ])
		ifTrue: [ '' ]
		ifFalse: [ (self userName ifEmpty: [ '?' ]), '/', self projectName ]
! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing - ui' stamp: ''!
projectNameLabel

	^ projectNameLabel! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing' stamp: ''!
protocolDropList

	^ protocolDropList! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing' stamp: ''!
protocolLabel

	^ protocolLabel! !

!IceTipGitProviderRepositoryPanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	userNameLabel := self newLabel
		label: 'Owner name';
		yourself.
	userNameInputText := self newTextInput
		autoAccept: true;
		placeholder: 'e.g., JohnDoe';
		yourself.
	projectNameLabel := self newLabel
		label: 'Project name';
		yourself.
	projectNameInputText := self newTextInput
		autoAccept: true;
		placeholder: 'e.g., MyProject';
		yourself.
	protocolLabel := self newLabel
		label: 'Protocol';
		yourself.
	protocolDropList := self newDropList.

	userNameInputText
		whenTextChangedDo: [ :text | projectLocation appendPath: self projectAsPathToAppend ].
	projectNameInputText
		whenTextChangedDo: [ :text | projectLocation appendPath: self projectAsPathToAppend ].
	protocolDropList
		items: IceUrlProtocol allSubclasses;
		display: [ :each | each description ];
		selectItem: IceUrlProtocol defaultProtocol.
! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing' stamp: ''!
providerName

	^ self subclassResponsibility! !

!IceTipGitProviderRepositoryPanel methodsFor: 'accessing' stamp: ''!
userName

	^ self userNameInputText text asString trimmed! !

!IceTipGitProviderRepositoryPanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #userNameLabel width: self labelWidth;
				   add: #userNameInputText;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #projectNameLabel width: self labelWidth;
				   add: #projectNameInputText;
				   yourself)
		  height: self inputTextHeight;
		  add: #projectLocation height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #protocolLabel width: self labelWidth;
				   add: #protocolDropList;
				   yourself)
		  height: self inputTextHeight;
		  yourself! !

!IceTipGitProviderRepositoryPanel class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self = IceTipGitProviderRepositoryPanel ]! !

!IceTipGitRepositoryPanel commentStamp: ''!
I'm a presenter to define remote repositories.
Repositories needs to have a valid url (one that can be parsed by IceRemote) and a valid location (where to place the clone)!
!IceTipGitRepositoryPanel methodsFor: 'utilities' stamp: ''!
extractProjectName: aString

	^ [ (IceGitRemote url: aString) projectName ]
		  on: IceWrongUrl
		  do: [ 'invalid-url' ]! !

!IceTipGitRepositoryPanel methodsFor: 'accessing' stamp: ''!
remoteUrl

	^ self remoteInputText text asString trimmed! !

!IceTipGitRepositoryPanel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Clone remote repository'! !

!IceTipGitRepositoryPanel methodsFor: 'accessing' stamp: ''!
validate

	| remoteString |
	remoteString := self remoteUrl.
	self
		assert: remoteString isNotEmpty
		description: 'You must enter your project url.'.
	self
		assert: (IceGitRemote isValidUrl: remoteString)
		description: 'The url is incorrect.'.
	self
		assert: self projectLocation location notNil
		description:
		'Project location must be defined (if it does not exists, it will be created).'! !

!IceTipGitRepositoryPanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	self initializeRemoteURL.

	self remoteInputText
		placeholder: 'e.g., ssh://[user@]host.xz[:port]/path/to/repo.git'.
	self remoteInputText whenTextChangedDo: [ :text |
		self projectLocation appendPath: (self extractProjectName: text) ].
! !

!IceTipGitRepositoryPanel methodsFor: 'initialization' stamp: ''!
iconForWindow

	^ self iconNamed: #git! !

!IceTipGitRepositoryPanel methodsFor: 'accessing' stamp: ''!
newRepository

	UIManager default 
		informUser: ('Cloning repository {1}' format: { self remoteUrl })
		during: [ 
			^ IceRepositoryCreator new 
				repository: repository;
				remote: (IceGitRemote url: self remoteUrl);
				location: self projectLocation location;
				createRepository ]! !

!IceTipGitRepositoryPanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #remoteLabel width: self labelWidth;
				   add: #remoteInputText;
				   yourself)
		  height: self inputTextHeight;
		  add: #projectLocation height: self inputTextHeight;
		  yourself! !

!IceTipGitRepositoryPanel class methodsFor: 'accessing' stamp: ''!
order

	^ 1000 "to the end"! !

!IceTipGitUsernameAndEmailDialog commentStamp: ''!
I'm a dialog for asking "user.name" and "user.email" .!
!IceTipGitUsernameAndEmailDialog methodsFor: 'testing' stamp: ''!
isGlobal

	^ self globalCheckbox state! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'accessing' stamp: ''!
email

	^ self emailInput text trimBoth! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'accessing - ui' stamp: ''!
nameInput

	^ nameInput! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'events' stamp: ''!
onAccept: aBlockClosure 
	
	acceptCallback := aBlockClosure! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Please provide Git missing properties'! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'accessing - ui' stamp: ''!
nameLabel

	^ nameLabel! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'actions' stamp: ''!
accept

	self username isEmptyOrNil ifTrue: [ ^ UIManager default alert: 'user.name is required.' ].
	self email isEmptyOrNil ifTrue: [ ^ UIManager default alert: 'user.email is required.' ].	
	
	(model getConfigurationGlobal: self isGlobal)
		username: self username;
		email: self email.
	
	self closeWindow.
	
	acceptCallback ifNotNil: [ 
		acceptCallback value ].! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'accessing - ui' stamp: ''!
emailInput

	^ emailInput! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'accessing - ui' stamp: ''!
emailLabel

	^ emailLabel! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (400@(
		self class inputTextHeight * 3
		+ self class buttonHeight 
		+ 50 "Yes, a magic number"
		)) scaledByDisplayScaleFactor! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	nameLabel := self newLabel
		label: 'user.name';
		yourself.
	nameInput := self newTextInput
		placeholder: 'e.g., John Doe';
		autoAccept: true;
		yourself.
	emailLabel := self newLabel
		label: 'user.email';
		yourself.
	emailInput := self newTextInput
		placeholder: 'e.g., johndoe@mail.net';
		autoAccept: true;
		yourself.
	globalCheckbox := self newCheckBox
		label: 'Save properties as global?';
		state: false;
		yourself.
! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'events' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'accessing - ui' stamp: ''!
globalCheckbox
	^ globalCheckbox! !

!IceTipGitUsernameAndEmailDialog methodsFor: 'accessing' stamp: ''!
username

	^ self nameInput text trimBoth! !

!IceTipGitUsernameAndEmailDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #nameLabel
				   width: 100 * self currentWorld displayScaleFactor;
				   add: #nameInput;
				   yourself)
		  height: self inputTextHeight;
		  add: (SpBoxLayout newLeftToRight
				   add: #emailLabel
				   width: 100 * self currentWorld displayScaleFactor;
				   add: #emailInput;
				   yourself)
		  height: self inputTextHeight;
		  add: #globalCheckbox height: self inputTextHeight;
		  yourself! !

!IceTipHiedraHistoryBrowser commentStamp: ''!
I add a Hiedra column to the browser defined by my superclass. This column visualizes the relationship between commits in the history list.!
!IceTipHiedraHistoryBrowser methodsFor: 'accessing' stamp: ''!
refreshHiedraColumn
	| ancestorIds |

	ancestorIds := Dictionary new.
	self model commitModels do: [ :aCommit |
		ancestorIds
			at: aCommit id
			put: aCommit entity ancestorIds ].
	hiedraColumnController reset.

	"Note: ids should keep the original order to generate the ruler correctly."
	hiedraColumnController ruler: (HiRulerBuilder
		newRulerValues: (self model commitModels collect: #id) 
		linksBlock: [ :id | ancestorIds at: id ]).
! !

!IceTipHiedraHistoryBrowser methodsFor: 'accessing' stamp: ''!
refresh

	self refreshHiedraColumn.
	super refresh! !

!IceTipHiedraHistoryBrowser methodsFor: 'initialization' stamp: ''!
initializeCommitList
	"Add the Hiedra column at the beginning. The Datasource has the logic to render it."

	commitList
		addColumn:
			(SpImageTableColumn new
				evaluated: [ :each |
					hiedraColumnController cellMorphAtRow: (commitList items indexOf: each) ];
				title: ' ';
				width: 80;
				yourself).
	super initializeCommitList.
! !

!IceTipHiedraHistoryBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	self initializeHiedraColumn! !

!IceTipHiedraHistoryBrowser methodsFor: 'initialization' stamp: ''!
initializeHiedraColumn

	| ancestorIds |
	hiedraColumnController := HiColumnController new.
	hiedraColumnController renderer
		arrowSize: 0;
		nodeConnectionOffset: 0;
		nodeRadius: 1.75.

	ancestorIds := Dictionary new.
	self model commitModels do: [ :aCommit |
		"Note: Hiedra expects each ancestor id corresponds to a commit in elements."
		ancestorIds
			at: aCommit id
			put: aCommit entity ancestorIds ].

	hiedraColumnController ruler: (HiRulerBuilder
		newRulerValues: (self model commitModels collect: #id) "Note: ids should keep the original order."
		linksBlock: [ :id | ancestorIds at: id ]).

	hiedraColumnController renderer rowHeight: 20; cellWidth: 5.25! !

!IceTipHiedraHistoryBrowser class methodsFor: '*Calypso-SystemPlugins-Monticello-Browser' stamp: ''!
calypsoCommandsWith: presenter forRootGroup: aCommandGroup
	<extensionCommands>

	aCommandGroup / self selectionCommandGroupName register:
		ClyBrowseIcebergCommitCommand forSpec! !

!IceTipHistoryActionBrowser commentStamp: ''!
I'm a base browser for pull/push action browser.!
!IceTipHistoryActionBrowser methodsFor: 'accessing - ui' stamp: ''!
commitsPanel: aSpPresenter

	commitsPanel := aSpPresenter! !

!IceTipHistoryActionBrowser methodsFor: 'accessing' stamp: ''!
refresh

	self refreshCommits! !

!IceTipHistoryActionBrowser methodsFor: 'private - factory' stamp: ''!
newActionButton
	"Answer a new instance of SpButton to be placed at bottom, as the main action of the window."

	^ self subclassResponsibility! !

!IceTipHistoryActionBrowser methodsFor: 'accessing - ui' stamp: ''!
commitsPanel

	^ commitsPanel! !

!IceTipHistoryActionBrowser methodsFor: 'actions' stamp: ''!
moveToRemote: aRemoteModel

	aRemoteModel ifNil: [ ^ self ].
	
	self model useRemote: aRemoteModel.
	self model reset.
	self refreshCommits.
	self updateTitle! !

!IceTipHistoryActionBrowser methodsFor: 'private' stamp: ''!
refreshWhenRepository: ann

	(self model repositoryModel isModelOf: ann repository)
		ifFalse: [ ^ self ].
	self model reset.
	self refresh! !

!IceTipHistoryActionBrowser methodsFor: 'accessing' stamp: ''!
refreshCommits

	commitsPanel refresh! !

!IceTipHistoryActionBrowser methodsFor: 'actions' stamp: ''!
accept

	button performAction! !

!IceTipHistoryActionBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (800@600) scaledByDisplayScaleFactor! !

!IceTipHistoryActionBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	commitsPanel := self instantiate: IceTipHistoryBrowser on: self model.
	actionButtonBar := self newButtonBar.
	actionButtonBar add: (button := self newActionButton).
! !

!IceTipHistoryActionBrowser methodsFor: 'initialization' stamp: ''!
subscribeToAnnouncements

	self announcer
		when: IceTipDiffRefreshed
		send: #refreshWhenRepository:
		to: self.

	Iceberg announcer weak
		when: IceRepositoryAnnouncement
		send: #refreshWhenRepository:
		to: self! !

!IceTipHistoryActionBrowser methodsFor: 'accessing - ui' stamp: ''!
actionButtonBar

	^ actionButtonBar! !

!IceTipHistoryBrowser commentStamp: ''!
I'm a browser and panel to show the history of a commitish (usually a branch or a tag). 
I'm usually used as part of an IceTipRepositoryBrowser.

(self onBranch: IceRepository registry anyOne branch) openWithSpec.!
!IceTipHistoryBrowser methodsFor: 'accessing' stamp: ''!
refreshCommitList

	| commitModels |
	commitModels := self model commitModels.
	commitList items: commitModels.
	commitInfoTabs selectedModel: (commitModels ifNotEmpty: #first ifEmpty: [ nil ])
! !

!IceTipHistoryBrowser methodsFor: 'events' stamp: ''!
whenSelectionChangedDo: aBlock 
	
	commitList whenSelectionChangedDo: aBlock! !

!IceTipHistoryBrowser methodsFor: 'accessing' stamp: ''!
refresh

	self refreshCommitList! !

!IceTipHistoryBrowser methodsFor: 'accessing' stamp: ''!
beForMerge

	self commitInfoTabs beForMerge! !

!IceTipHistoryBrowser methodsFor: 'accessing - ui' stamp: ''!
commitList

	^ commitList! !

!IceTipHistoryBrowser methodsFor: 'event handling' stamp: ''!
selectionChanged: anElement

	commitInfoTabs selectedModel: anElement! !

!IceTipHistoryBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ self model
		ifNotNil: [ 'History of {1}' format: {self model repositoryName} ]
		ifNil: [ 'History' ]
! !

!IceTipHistoryBrowser methodsFor: 'initialization' stamp: ''!
initializeCommitList

	commitList
		beResizable;
		addColumn:
			((SpStringTableColumn
				evaluated: [ :each | each timeStamp asLocalStringYMDHM ])
				title: 'Timestamp';
				width: 110 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			((SpStringTableColumn evaluated: #shortId)
				title: 'Commit';
				width: 60 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			((SpStringTableColumn evaluated: #author)
				title: 'Author';
				width: 150 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			((SpStringTableColumn evaluated: #descriptionWithDecoration)
				title: 'Description';
				yourself);
		whenSelectionChangedDo: [ :aSelection | self selectionChanged: aSelection selectedItem ]
! !

!IceTipHistoryBrowser methodsFor: 'accessing - ui' stamp: ''!
commitInfoTabs

	^ commitInfoTabs! !

!IceTipHistoryBrowser methodsFor: 'accessing' stamp: ''!
model: anObject

	super model: anObject.
	self refresh! !

!IceTipHistoryBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (700 @ 700) scaledByDisplayScaleFactor! !

!IceTipHistoryBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.	
	commitList := self newTable.
	commitInfoTabs := self instantiate: IceTipCommitInfoPresenter.
	
	self initializeCommitList.
		
	self refreshCommitList.! !

!IceTipHistoryBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList
	"Answer the presenter that is the main list of items of this browser."

	^ commitList! !

!IceTipHistoryBrowser methodsFor: 'accessing' stamp: ''!
selectedCommit

	^ commitList selection selectedItem! !

!IceTipHistoryBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	{	IceTipAdoptCommitCommand.
		IceTipCheckoutNewBranchCommand.
		IceTipCheckoutCommitCommand.
		IceTipCreateTagCommand.
		IceTipResetBranchToThisCommitCommand.
		IceTipCopyCommitishCommand.
		IceTipCherryPickCommand.
		} do: [ :each |
			aCommandGroup register: each forSpec ]
! !

!IceTipHistoryBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newTopToBottom
		  add: #commitList;
		  add: #commitInfoTabs;
		  yourself! !

!IceTipHistoryBrowser class methodsFor: 'specs' stamp: ''!
panelSpec
	
	^ SpPanedLayout newTopToBottom
		add: #commitList;
		add: #commitInfoTabs;
		yourself! !

!IceTipHistoryBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	"Nothing to add"! !

!IceTipHistoryDiffFromHead commentStamp: ''!
I keep a diff from HEAD to WorkingCopy.
!
!IceTipHistoryDiffFromHead methodsFor: 'accessing' stamp: ''!
diffFor: aCommitModel
	^ aCommitModel diffFromHead! !

!IceTipHistoryDiffFromHead methodsFor: 'accessing' stamp: ''!
labelFor: aCommitModel
	^ 'HEAD to {1}' format: { aCommitModel ifNotNil: #shortId }! !

!IceTipHistoryDiffToAncestor commentStamp: ''!
I keep a diff from a commit to his mail parent.!
!IceTipHistoryDiffToAncestor methodsFor: 'accessing' stamp: ''!
diffFor: aCommitModel
	^ aCommitModel diffToFirstAncestor! !

!IceTipHistoryDiffToAncestor methodsFor: 'accessing' stamp: ''!
labelFor: aCommitModel
	^ '{1} to {2}' format: { 
		aCommitModel shortId.
		aCommitModel ancestorShortIdOrOrigin }! !

!IceTipHistoryDiffToHead commentStamp: ''!
I keep a diff from WorkingCopy to HEAD.
!
!IceTipHistoryDiffToHead methodsFor: 'accessing' stamp: ''!
diffFor: aCommitModel
	^ aCommitModel diffToHead! !

!IceTipHistoryDiffToHead methodsFor: 'accessing' stamp: ''!
labelFor: aCommitModel
	^ '{1} to HEAD' format: { aCommitModel ifNotNil: #shortId }! !

!IceTipHistoryDiffUpdater commentStamp: ''!
I represent the direction of calculus of diffs.
Since orders may change for different operations, I need a different approach for each scenario.
!
!IceTipHistoryDiffUpdater methodsFor: 'updating' stamp: ''!
updateContentsOn: aCommitModel
	aCommitModel ifNil: [ ^ self ].
	self tab contents: (self newDiffPanelFor: (self diffFor: aCommitModel)) buildWithSpec! !

!IceTipHistoryDiffUpdater methodsFor: 'accessing' stamp: ''!
tab: anObject
	tab := anObject! !

!IceTipHistoryDiffUpdater methodsFor: 'updating' stamp: ''!
updateOn: aCommitModel
	self updateLabelOn: aCommitModel.
	self updateContentsOn: aCommitModel! !

!IceTipHistoryDiffUpdater methodsFor: 'accessing' stamp: ''!
diffFor: aCommitModel
	self subclassResponsibility! !

!IceTipHistoryDiffUpdater methodsFor: 'updating' stamp: ''!
updateLabelOn: aCommitModel
	self tab label: (self labelFor: aCommitModel)! !

!IceTipHistoryDiffUpdater methodsFor: 'private factory' stamp: ''!
newDiffPanelFor: aDiffModel
	^ IceTipDiffPanel on: aDiffModel! !

!IceTipHistoryDiffUpdater methodsFor: 'accessing' stamp: ''!
tab
	^ tab! !

!IceTipHistoryDiffUpdater methodsFor: 'accessing' stamp: ''!
labelFor: aCommitModel
	^ self subclassResponsibility! !

!IceTipHistoryDiffUpdater class methodsFor: 'instance creation' stamp: ''!
tab: aTab
	^ self new
		tab: aTab;
		yourself! !

!IceTipHistoryDiffUpdater class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipHistoryDiffUpdater! !

!IceTipInspectCommand commentStamp: ''!
I am a command implementing the inspect option. I have several context activations to be able to inspect different objects in Iceberg's UI!
!IceTipInspectCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #glamorousInspect! !

!IceTipInspectCommand methodsFor: 'executing' stamp: ''!
execute

	self item inspect! !

!IceTipInspectCommand methodsFor: 'accessing' stamp: ''!
item

	| maybeCachedObject |
	maybeCachedObject := super item.
	
	^ (maybeCachedObject respondsTo: #realObject)
		ifTrue: [ maybeCachedObject realObject ] ifFalse: [ maybeCachedObject ]! !

!IceTipInspectCommand methodsFor: 'executing' stamp: ''!
canBeExecuted

	^ self context hasSelectedItem! !

!IceTipInspectCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Inspect the selected element'! !

!IceTipInspectCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Inspect...'! !

!IceTipInstallVersionCommand commentStamp: ''!
Command used in the version browser, inside the code browser.
This command takes the selected version and installs it (also called revert).!
!IceTipInstallVersionCommand methodsFor: 'activation' stamp: ''!
iconName

	^ #smallRedo! !

!IceTipInstallVersionCommand methodsFor: 'execution' stamp: ''!
execute
	
	self version install! !

!IceTipInstallVersionCommand methodsFor: 'execution' stamp: ''!
version

	^ self context selectedItem! !

!IceTipInstallVersionCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Revert to the selected version'! !

!IceTipInstallVersionCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Install this version'! !

!IceTipInteractiveCredentialsProvider commentStamp: ''!
I am a credential provider that requires the missing plaintext credential to the user.!
!IceTipInteractiveCredentialsProvider methodsFor: 'private' stamp: ''!
obtainPlaintextCredentials: credentialsToReturn
	| returnedCred |
	returnedCred := IceTipAskForPlaintextCredentialsModel new
		credentialStore: self credentialStore;
		askingHostname: remote host;
		openDialogWithSpec;
		credentials.

	credentialsToReturn readFrom: returnedCred! !

!IceTipInteractiveCredentialsProvider methodsFor: 'private' stamp: ''!
obtainSshCredentials: credentialsToReturn 
	
	| returnedCred |
	
	returnedCred := IceTipAskSSHCredentialsModel new
		credentials: self sshCredentials;
		credentialStore: self credentialStore;
		open.
		
	credentialsToReturn readFrom: returnedCred! !

!IceTipInteractiveCredentialsProvider methodsFor: 'private' stamp: ''!
obtainCredentials: credentialsToReturn

	| returnedCred |
	returnedCred := credentialsToReturn askForModelClass new
		credentialStore: self credentialStore;
		askingHostname: remote host;
		open.

	credentialsToReturn readFrom: returnedCred! !

!IceTipInteractiveCredentialsProvider class methodsFor: 'private' stamp: ''!
initialize
	
	self providerType: nil! !

!IceTipInteractiveCredentialsProvider class methodsFor: 'private' stamp: ''!
isDefault
	^ true! !

!IceTipInteractiveErrorVisitor commentStamp: ''!
I'm a visitor to provide users with an interactive way to react to iceberg errors.
!
!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitRemoteAlreadyExistError: anError 
	UIManager default inform: ('Remote "{1}" already exists.' format: { anError remoteName })! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitCloneRemoteNotFound: anError
	UIManager default 
		alert: ('The clone remote {1} could not been found' format: { anError remoteUrl })
		title: 'Clone action failed'	! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitCloneLocationAlreadyExists: anError 
	UIManager default 
		alert: ('The clone location {1} already exists' format: { anError location })
		title: 'Clone action failed'	! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitExperimentalFeature: aWarning
	| proceed |
	
	proceed := UIManager default
		confirm: aWarning messageText
		label: 'Warning!!'  
		trueChoice: 'Continue' 
		falseChoice: 'Cancel'
		cancelChoice: nil
		default: false.
	
	proceed ifNil: [ ^ self ].
	proceed ifTrue: [ aWarning resume ]! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitMergeAborted: anError
	UIManager default 
		alert: (anError messageText ifNil: ['Automatic (fast-forward) merge is not possible. 
Please perform the merge manually, then proceed with your previous operation.
WARNING: If you have external files, you may need to verify the conflicts there.'])
		title: 'Automatic merge failed'! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitGenericError: anError
	
	(IceTipErrorDialog on: anError) openDialogWithSpec! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitNoCommitMessage: aWarning
	| proceed |
	
	proceed := UIManager default
		confirm: aWarning messageText
		label: 'Warning!!'  
		trueChoice: 'Commit' 
		falseChoice: 'Cancel'
		cancelChoice: nil
		default: false.
	
	proceed ifNil: [ ^ self ].
	proceed ifTrue: [ aWarning resume ]! !

!IceTipInteractiveErrorVisitor methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitWorkingCopyDesynchronizedError: anError
	| solveStrategy command |
	solveStrategy := UIManager default 
		chooseFrom: #(
			'Create new branch and commit' 
			'Merge local copy into image and commit')		
		values: { 
			IceCreateBranchCommand. 
			IceMergeWorkingCopyCommand }
		message: 'Your loaded code is not synchronized with the local sources in your repository. 
You need to solve this problem before you continue, please choose one of the strategies below.'
		title: 'Loaded code out of sync!!'.
	solveStrategy ifNil: [ ^ self ].
	(command := solveStrategy new) 
		repository: self repository;
		execute.
	command isSuccess 
		ifTrue: [ anError retry ]! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitShouldCommitBeforePullError: anError
	| continue |
	continue := UIManager default
		confirm:
			'Your repository has uncommited changes. Merging incoming commits will change
your current working copy and your current state will not be recoverable. 
We recommend that you commit first and then pull incoming changes again.'
		label: 'You might loose your current changes!!'
		trueChoice: 'Proceed anyway'
		falseChoice: 'Cancel'
		cancelChoice: nil
		default: false.	
	continue ifFalse: [ ^ self ].
	anError resume! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitNothingToCommitError: anError
	UIManager default inform: 'There is nothing to commit.'! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitRemoteDesynchronizedError: anError
	| continue command |
	
	continue := UIManager default
		confirm: ('Your repository is out of sync with remote {1}. 
You need to pull remote changes before continue and push your changes.' format: { anError remote })
		label: 'Remote repository out of sync!!'
		trueChoice: 'Pull'
		falseChoice: 'Cancel'
		cancelChoice: nil
		default: false.	
	(continue isNil or: [continue not])
		ifTrue: [ ^ self ].	

	command := IcePullRemoteCommand new
		repository: self repository;
		remote: anError remote;
		yourself.

	[ command execute ]
	on: IceMergeAborted, IceShouldCommitBeforePull
	do: [ :e |
		self flag: #pharoTodo. "Refactor this" 
		(e isKindOf: IceShouldCommitBeforePull)
			ifTrue: [ e resume ]
			ifFalse: [ e acceptError: self ] ].
	
	command isSuccess ifFalse: [ ^ self ].
	anError isResumable ifTrue: [ ^ anError resume ].
	anError retry! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitNoRemote: anError
	UIManager default 
		alert: 'There are no remotes defined for this repository. 
Add one before continue.'
		title: 'Remote action failed'	! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitCheckoutConflict: anError
	UIManager default 
		alert: anError messageText
		title: 'Iceberg conflicts while checking out'! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitMissingCredentialsError: anError

	((IceTipGitUsernameAndEmailDialog on: self repository)
		onAccept: [ anError resume ];
		openDialogWithSpec)
			modalRelativeTo: self currentWorld.! !

!IceTipInteractiveErrorVisitor methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceTipInteractiveErrorVisitor methodsFor: 'visiting' stamp: ''!
visitAuthenticationError: anError
	UIManager default 
		alert: anError messageText
		title: 'Iceberg authentication Error'! !

!IceTipInteractiveErrorVisitor class methodsFor: 'instance creation' stamp: ''!
on: aModel
	^ self new repository: aModel! !

!IceTipLoadPackageCommand commentStamp: ''!
Command that loads the current non-loaded selected package!
!IceTipLoadPackageCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #add! !

!IceTipLoadPackageCommand methodsFor: 'executing' stamp: ''!
execute

	self packageModel load.
	Iceberg announcer announce:
		(IceRepositoryModified for: self repository)! !

!IceTipLoadPackageCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self isPackageLoaded not! !

!IceTipLoadPackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Load selected package in the image'! !

!IceTipLoadPackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Load'! !

!IceTipLocalRepositoryPanel commentStamp: ''!
I will define a repository that already exists. 
!
!IceTipLocalRepositoryPanel methodsFor: 'accessing' stamp: ''!
location

	^ self projectLocation location! !

!IceTipLocalRepositoryPanel methodsFor: 'accessing' stamp: ''!
location: aReferenceOrString

	^ self projectLocation location: aReferenceOrString! !

!IceTipLocalRepositoryPanel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Import from existing clone'! !

!IceTipLocalRepositoryPanel methodsFor: 'accessing' stamp: ''!
validate

	self
		assert: self location notNil
		description: 'Project location must exist!!'.
	self
		assert: self location exists
		description: 'Project location must exist!!'.
	self
		assert: (IceRepositoryCreator isGitRoot: self location)
		description: 'Project location does not seems to be a valid git repository.'! !

!IceTipLocalRepositoryPanel methodsFor: 'testing' stamp: ''!
isLocalRepository

	^ true! !

!IceTipLocalRepositoryPanel methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (500@(
		self class inputTextHeight * 2
		+ self class buttonHeight 
		+ 50 "Yes, a magic number"
		)) scaledByDisplayScaleFactor! !

!IceTipLocalRepositoryPanel methodsFor: 'initialization' stamp: ''!
iconForWindow

	^ self iconNamed: #smallOpen! !

!IceTipLocalRepositoryPanel methodsFor: 'accessing' stamp: ''!
newRepository

	UIManager default 
		informUser: ('Importing repository from {1}' format: { self location fullName })
		during: [ 
			^ IceRepositoryCreator new
				repository: repository;
				location: self location;
				createRepository ]! !

!IceTipLocalRepositoryPanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #projectLocation height: self inputTextHeight;
		  yourself! !

!IceTipLocalRepositoryPanel class methodsFor: 'accessing' stamp: ''!
order

	^ 20! !

!IceTipLocationPresenter commentStamp: ''!
I'm an abstract model to provide locations (directories or files). 
I need to be included in other components (search references to my children for examples)!
!IceTipLocationPresenter methodsFor: 'events' stamp: ''!
whenTextChanged: aBlockClosure

	self locationInput whenTextChangedDo: aBlockClosure! !

!IceTipLocationPresenter methodsFor: 'accessing - ui' stamp: ''!
locationInput

	^ locationInput! !

!IceTipLocationPresenter methodsFor: 'accessing' stamp: ''!
label: aString

	label := aString.
	self locationLabel label: aString! !

!IceTipLocationPresenter methodsFor: 'hook' stamp: ''!
onChoose

	^ chooseBlock! !

!IceTipLocationPresenter methodsFor: 'accessing' stamp: ''!
location
	"This method return the location to use in the repository
	If the location is relative to IceLibgitRepository >> #localRepositoriesLocation
	It returns a FileLocator so the image can be moved or the directory renamed.
	If the location is outside of the local repositories location it returns a file reference"

	| fileReferenceLocation relativePath|

	fileReferenceLocation := locationInput text trim
		ifNotEmpty: [ :value | value asFileReference ]
		ifEmpty: [ ^ nil ].

	(fileReferenceLocation
		isContainedBy: IceLibgitRepository localRepositoriesLocation)
		ifFalse: [ ^ fileReferenceLocation ].

	relativePath := IceLibgitRepository localRepositoriesLocation makeRelative: locationInput text trim asFileReference.
	
	^ IceLibgitRepository localRepositoriesLocation resolvePath: relativePath ! !

!IceTipLocationPresenter methodsFor: 'accessing' stamp: ''!
location: aReferenceOrString

	| ref |
	ref := aReferenceOrString asFileReference.
	keptLocation ifNotNil: [ 
		| newRef |
		newRef := (self location pathString 
			copyReplaceAll: keptLocation pathString 
			with: ref pathString) 
			asFileReference.
		keptLocation := ref.
		ref := newRef ].
	
	self basicLocation: ref! !

!IceTipLocationPresenter methodsFor: 'accessing' stamp: ''!
defaultChooseDialogTitle

	^ 'Choose directory'! !

!IceTipLocationPresenter methodsFor: 'private' stamp: ''!
basicLocation: aReference

	locationInput text: aReference pathString! !

!IceTipLocationPresenter methodsFor: 'accessing' stamp: ''!
chooseTitle: aString

	chooseTitle := aString! !

!IceTipLocationPresenter methodsFor: 'accessing' stamp: ''!
chooseTitle

	^ chooseTitle ifNil: [ self defaultChooseDialogTitle ]! !

!IceTipLocationPresenter methodsFor: 'accessing' stamp: ''!
icon

	^ self iconNamed: #open! !

!IceTipLocationPresenter methodsFor: 'actions' stamp: ''!
chooseReference

	self subclassResponsibility! !

!IceTipLocationPresenter methodsFor: 'accessing' stamp: ''!
appendPath: aString

	keptLocation ifNil: [ keptLocation := self location ].
	
	self basicLocation: (aString 
		ifNotEmpty: [ (keptLocation ifNil: [ '.' asFileReference ]) / aString ]
		ifEmpty: [ keptLocation ]).! !

!IceTipLocationPresenter methodsFor: 'actions' stamp: ''!
choose

	self chooseReference ifNotNil: [ :reference | 
		self location: reference.
		self onChoose ifNotNil: #value ]! !

!IceTipLocationPresenter methodsFor: 'accessing - ui' stamp: ''!
locationLabel

	^ locationLabel! !

!IceTipLocationPresenter methodsFor: 'accessing - ui' stamp: ''!
chooseButton

	^ chooseButton! !

!IceTipLocationPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	locationLabel := self newLabel
		label: self label;
		yourself.
	locationInput := self newTextInput
		autoAccept: true;
		yourself.
	chooseButton := self newButton
		icon: self icon;
		yourself.
	
	chooseButton action: [ self choose ].
! !

!IceTipLocationPresenter methodsFor: 'accessing' stamp: ''!
label

	^ label ifNil: [ self defaultLabel ]! !

!IceTipLocationPresenter methodsFor: 'hook' stamp: ''!
onChoose: aBlockClosure
	"I allow to set a hook to execute when the user select a location."

	chooseBlock := aBlockClosure! !

!IceTipLocationPresenter methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Directory'! !

!IceTipLocationPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		  add: #locationLabel width: self labelWidth;
		  add: #locationInput;
		  add: #chooseButton width: 24;
		  yourself! !

!IceTipLocationPresenter class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipLocationPresenter! !

!IceTipManagePackagesCommand commentStamp: ''!
I'm a command to open the package manager browser for a project.!
!IceTipManagePackagesCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #package! !

!IceTipManagePackagesCommand methodsFor: 'executing' stamp: ''!
execute
	(IceTipWorkingCopyBrowser on: self repositoryModel) openWithSpec! !

!IceTipManagePackagesCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $p meta! !

!IceTipManagePackagesCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Open packages manager browser for this repository'! !

!IceTipManagePackagesCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Packages'! !

!IceTipManageRepositoryCommand commentStamp: ''!
I'm a command to show the repository manager for a repository model. 
!
!IceTipManageRepositoryCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #komitterSmalltalkhubRemote! !

!IceTipManageRepositoryCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipRepositoryBrowser on: self repositoryModel) openWithSpec! !

!IceTipManageRepositoryCommand methodsFor: 'testing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ true! !

!IceTipManageRepositoryCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $r meta! !

!IceTipManageRepositoryCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ super canBeExecuted and: [ self isRepositoryMissing not ]! !

!IceTipManageRepositoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultToolbarItemName

	^ 'Repository'! !

!IceTipManageRepositoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Open repository manager browser for this repository.'! !

!IceTipManageRepositoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Open Repository'! !

!IceTipMergeBranchDialog commentStamp: ''!
I'm a dialog to perform a merge of a branch.

(self onRepository: IceRepository registry anyOne) openDialogWithSpec!
!IceTipMergeBranchDialog methodsFor: 'accessing' stamp: ''!
allTypes

	^ types ifNil: [ types := self createMergeBranchTypes ]! !

!IceTipMergeBranchDialog methodsFor: 'accessing' stamp: ''!
beSwitchAndMerge

	self allTypes do: #beSwitchAndMerge! !

!IceTipMergeBranchDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Select branch to merge into ' , self model branchName! !

!IceTipMergeBranchDialog methodsFor: 'actions' stamp: ''!
doAccept

	self selectedType doAccept! !

!IceTipMergeBranchDialog methodsFor: 'accessing' stamp: ''!
model: anObject

	model := anObject.
	self allTypes do: [ :each | each model: anObject ]! !

!IceTipMergeBranchDialog methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipMergeBranchDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (600 @ 400) scaledByDisplayScaleFactor! !

!IceTipMergeBranchDialog methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipMergeBranchDialog methodsFor: 'private - factory' stamp: ''!
createMergeBranchTypes

	| allTypes |
	"Collect types local+remotes"	
	allTypes :=  { 
	 	(IceTipMergeBranchPanel on: self model) 
			titleForWindow: 'Local';
			withoutHead;
			icon: (self iconNamed: #branch);
			yourself }, 
	(self model remoteModels collect: [ :each | 
		(IceTipMergeBranchPanel on: each)
			titleForWindow: each name;
			icon: (self iconNamed: #remote);
			yourself ]).
	
	"Doing this because I can trigger the accept inside the panels."
	allTypes do: [ :each | each onAccept: [ self closeWindow ] ].
	
	^ allTypes! !

!IceTipMergeBranchDialog class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository

	^ self on: (IceTipRepositoryModel on: aRepository) beCached! !

!IceTipMergeBranchPanel commentStamp: ''!
I'm a panel to peform the merge of an existing branch.!
!IceTipMergeBranchPanel methodsFor: 'accessing' stamp: ''!
mergeType: anObject

	mergeType := anObject! !

!IceTipMergeBranchPanel methodsFor: 'accessing' stamp: ''!
mergeType

	^ mergeType ifNil: [ IceTipMergeType default ]! !

!IceTipMergeBranchPanel methodsFor: 'accessing' stamp: ''!
withoutHead

	self branchesList items: (self branchModels reject: #isHead).
	self branchesList selectIndex: 1! !

!IceTipMergeBranchPanel methodsFor: 'accessing' stamp: ''!
beSwitchAndMerge

	self mergeType: IceTipMergeType switchAndMerge! !

!IceTipMergeBranchPanel methodsFor: 'actions' stamp: ''!
doAccept

	IceTipStandardAction new 
		repository: self model entity; 
		message: ('Verifying merge from {1}' format: { self selectedBranch name });
		onSuccess: [ self selectedBranch previewMerge: self mergeType ];
		execute: [ self validate ]! !

!IceTipMergeCommand commentStamp: ''!
Command that opens a dialog to select a branch to merge in the current merge!
!IceTipMergeCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #merge! !

!IceTipMergeCommand methodsFor: 'executing' stamp: ''!
execute
	(IceTipMergeBranchDialog on: self repositoryModel) openDialogWithSpec! !

!IceTipMergeCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self isRepositoryOperational! !

!IceTipMergeCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Merge your current branch with another.'! !

!IceTipMergeCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Merge'! !

!IceTipMergeHistoryCommand commentStamp: ''!
Command that opens a window showing the history of the selected merged branch.!
!IceTipMergeHistoryCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipHistoryBrowser on:
		 self commitModel mergeHistoryFromSecondAncestor) openWithSpec! !

!IceTipMergeHistoryCommand methodsFor: 'executing' stamp: ''!
commitModel

	^ self context selectedCommit! !

!IceTipMergeHistoryCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self commitModel hasMultipleAncestors! !

!IceTipMergeHistoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Show the merged history of the selected merge commit'! !

!IceTipMergeHistoryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Browse merge history'! !

!IceTipMergeModel methodsFor: 'accessing' stamp: ''!
mergeType: aMergeType

	mergeType := aMergeType! !

!IceTipMergeModel methodsFor: 'actions' stamp: ''!
mergeAction

	^ mergeAction ifNil: [
		mergeAction := IceMerge new
			repository: self repositoryModel entity;
			mergeCommit: commitish entity commit;
			yourself ]! !

!IceTipMergeModel methodsFor: 'accessing' stamp: ''!
repositoryModel
	^ commitish repositoryModel! !

!IceTipMergeModel methodsFor: 'actions' stamp: ''!
calculateDiff

	^ self mergeAction! !

!IceTipMergeModel methodsFor: 'actions' stamp: ''!
executeMergeActionAndThen: aBlock 

	<noCache>
	IceTipStandardAction new 
		repository: self repository;
		message: ('Merging {1} into {2}' format: { self targetName. self repositoryName });
		onSuccessRepositoryModified;
		onSuccess: aBlock;
		execute: [ self merge ]! !

!IceTipMergeModel methodsFor: 'actions' stamp: ''!
merge

	mergeType mergeOn: commitish then: [  ].! !

!IceTipMergeMorph commentStamp: ''!
I redefine PSMCMergeMorph to be able to use an IceMergePatchMorph as patch morph!
!IceTipMergeMorph methodsFor: 'instance creation' stamp: ''!
newPatchMorph
	"Answer a new patch morph."

	^IceTipMergePatchMorph new
		borderWidth: 0;
		addDependent: self;
		yourself! !

!IceTipMergeMorph methodsFor: 'initialization' stamp: ''!
model: aMerger
	"Set the model and update the window."

	"Inlined/Copied from MorphicModel because we need to overwrite superclass' behavior"
	model ifNotNil: [aMerger removeDependent: self].
	aMerger ifNotNil: [aMerger addDependent: self].
	model := aMerger.
	
	self patchMorph model: aMerger! !

!IceTipMergeMorph methodsFor: 'accessing' stamp: ''!
conflictCount
	"Answer the number of conflicts that are unresolved."

	^(self model ifNil: [^0]) unresolvedConflictCount! !

!IceTipMergePatchMorph commentStamp: ''!
I redefine part of monticello's PSMCMergePatchMorph to not require to rebuild a tree but use Iceberg's one directly. I also adapt the patch morph to handle files and several packages at the same time.!
!IceTipMergePatchMorph methodsFor: 'actions' stamp: ''!
keepCurrentVersion
	"Mark the conflict as local."
	
	self selectedChangeWrapper chooseLocal.
	self changed: #changes.
	self updateSource! !

!IceTipMergePatchMorph methodsFor: 'actions' stamp: ''!
markAsConflict
	"Mark the operation as unresolved conflict."
	
	self selectedChangeWrapper item value clearSelection.
	self changed: #changes.
	self updateSource.! !

!IceTipMergePatchMorph methodsFor: 'updating' stamp: ''!
updateSource
	"Update the source difference morph."

	
	|sel|
	sel := self selectedChange.
	self diffMorph allowJoinClicks: false"(sel notNil and: [
		sel isConflict and: [sel  isModification]])".
	
	sel isNil
		ifTrue: [self diffMorph
				from: ''
				to: '']
		ifFalse: [
			self diffMorph
				from: sel rightContents asText
				to: sel leftContents asText
				contextClass: sel contextClass ].

	(sel isNil or: [sel isConflict not]) ifTrue: [^self].
	sel isLeftChosen
		ifTrue: [self diffMorph indicateDst]
		ifFalse: [self diffMorph indicateSrc]! !

!IceTipMergePatchMorph methodsFor: 'testing' stamp: ''!
useAllIncomingVersion
	"Mark all conflicts as remote."
	
	self model mergeTree do: [:c | 
		c isConflict ifTrue: [ c selectRight ] ].
	self changed: #changes.
	self updateSource! !

!IceTipMergePatchMorph methodsFor: 'testing' stamp: ''!
markAllAsConflict
	"Mark all conflicts as unresolved."
	
	self model mergeTree do: [:c | 
		c isConflict ifTrue: [ c clearSelection ] ].
	self changed: #changes.
	self updateSource! !

!IceTipMergePatchMorph methodsFor: 'testing' stamp: ''!
hasAnyNonConflictConflicts
	"Answer whether there are any conflicts not marked as a conflict."

	^ self model mergeTree anySatisfy: [:conflict |
		conflict isConflict and: [ conflict isResolved ] ]! !

!IceTipMergePatchMorph methodsFor: 'testing' stamp: ''!
hasAnyNonKeptConflicts
	"Answer whether there are any conflicts not marked as keep."

	^ self model mergeTree anySatisfy: [:conflict |
		conflict isConflict and: [ 
			conflict isResolved not or: [conflict isRightChosen ] ] ]! !

!IceTipMergePatchMorph methodsFor: 'testing' stamp: ''!
selectionIsRemoteChosen
	self selectedChange ifNil: [ ^ false].
	^ self selectedChange isConflict
		and: [ self selectedChange isRightChosen ]! !

!IceTipMergePatchMorph methodsFor: 'testing' stamp: ''!
hasAnyNonIncomingConflicts
	"Answer whether there are any conflicts not marked as incoming."

	^ self model mergeTree anySatisfy: [:conflict |
		conflict isConflict and: [ 
			conflict isResolved not or: [conflict isLeftChosen ] ] ]! !

!IceTipMergePatchMorph methodsFor: 'actions' stamp: ''!
selectNextConflict
	"Select the next conflict after the current selection, if any."

	|next |
	next := self nextConflict ifNil: [^self].
	self changed: {#openPath}, next item path segments! !

!IceTipMergePatchMorph methodsFor: 'testing' stamp: ''!
keepAllCurrentVersion
	"Mark all conflicts as local."
	
	self model mergeTree do: [:c | 
		c isConflict ifTrue: [ c selectLeft ] ].
	self changed: #changes.
	self updateSource! !

!IceTipMergePatchMorph methodsFor: 'testing' stamp: ''!
hasConflicts
	"Answer whether there are any conflicts."
	
	^ self model mergeTree anySatisfy: [:conflict |
		conflict isConflict ]! !

!IceTipMergePatchMorph methodsFor: 'accessing' stamp: ''!
changes
	"Answer the changes tree roots."
	
	^ model ifNotNil: [ model mergeTree children collect: [ :each | IceMergeListWrapper with: each model: model ] ]! !

!IceTipMergePatchMorph methodsFor: 'testing' stamp: ''!
notAllConflictsResolved
	"Answer whether any conflicts are unresolved."
	
	^self model mergeTree anySatisfy: [:item | 
		item isConflict and: [item isResolved not]]! !

!IceTipMergePatchMorph methodsFor: 'accessing' stamp: ''!
selectedChange
	"Answer the selected change."

	^(self selectedChangeWrapper ifNil: [^nil]) item value! !

!IceTipMergePatchMorph methodsFor: 'private' stamp: ''!
selectionHasActualClass
	"Answer whether the currently selected change has an actual
	class in the image."

	^self selectedChangeWrapper
		ifNil: [false]
		ifNotNil: [:w | w item value contextClass notNil]! !

!IceTipMergePatchMorph methodsFor: 'actions' stamp: ''!
nextConflict
	"Answer the next (unresolved) conflict or, nil if none."

	| node firstNode |
	firstNode := self selectedChangeWrapper
		ifNil: [ IceMergeListWrapper with: model mergeTree children first model: model ].
	
	node := firstNode item
		nextNodeSuchThat: [ :item | item value isConflict and: [item value isResolved not] ]
		ifNone: [ ^ nil ].
		
	^ IceMergeListWrapper with: node model: model.! !

!IceTipMergePreviewBrowser commentStamp: ''!
I preview the changes that will be introduced in the image when a merge occurs.

(self onBranch: IceRepository registry anyOne branch) openWithSpec.!
!IceTipMergePreviewBrowser methodsFor: 'accessing' stamp: ''!
mergeType: anObject
	
	self model mergeType: anObject! !

!IceTipMergePreviewBrowser methodsFor: 'private - factory' stamp: ''!
newActionButton

	^ self newButton 
		label: 'Merge';
		icon: (self iconNamed: #merge);
		help: ('Merges {1} with your image''s version.' format: { self model targetName });
		action: [ self doMerge ];
		yourself! !

!IceTipMergePreviewBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Preview merge of {1}/{2}' format: { 
		self model repositoryName.
		self model targetName }! !

!IceTipMergePreviewBrowser methodsFor: 'actions' stamp: ''!
doMerge

	self model executeMergeActionAndThen: [ self closeWindow ]! !

!IceTipMergePreviewBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	diffPanel leftLabel: 'Working Copy'.
	diffPanel rightLabel: 'Merge with ', model targetName! !

!IceTipMergePreviewBrowser class methodsFor: 'instance creation' stamp: ''!
onBranch: aBranch
	^ self on: (IceTipMergeModel new
		commitish: aBranch;
		yourself)
! !

!IceTipMergeSelectingPanel methodsFor: 'initialization' stamp: ''!
changeListColumn

	^ SpCompositeTableColumn new
		addColumn:
			(SpCheckBoxTableColumn new
				width: 20;
				evaluated: [ :iceNode | checkedIceNodes includes: iceNode ];
				onActivation: [ :iceNode |
					checkedIceNodes add: iceNode.
					iceNode value selectLeft.
					iceNode notEmpty ifTrue: [
						iceNode allChildrenDo: [ :child | checkedIceNodes add: child ].
						self basicRefresh ] ];
				onDeactivation: [ :iceNode |
					checkedIceNodes remove: iceNode.
					iceNode value selectRight.
					iceNode notEmpty ifTrue: [
						iceNode allChildrenDo: [ :child |
							checkedIceNodes remove: child ifAbsent: [  ] ].
						self basicRefresh ].
					 ]);
		addColumn:
			(SpImageTableColumn new
				width: 20;
				evaluated: [ :each | each value chosenOperation icon ];
				yourself);
		addColumn: self changeDescriptionColumn;
		yourself! !

!IceTipMergeSelectingPanel methodsFor: 'accessing' stamp: ''!
basicRefresh

	super basicRefresh.
	self refreshCodePanel.! !

!IceTipMergeSelectingPanel methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	checkedIceNodes := Set new.
	self model treeRoots do: [ :root | 
		root withAllChildrenDo: [ :child | 
			checkedIceNodes add: child.
			child value isConflict ifTrue: [ child value selectLeft ] ] ]! !

!IceTipMergeSelectingPanel methodsFor: 'event handling' stamp: ''!
selectionChanged

	super selectionChanged.
	self refreshCodePanel.! !

!IceTipMergeSelectingPanel methodsFor: 'accessing' stamp: ''!
refresh

	super refresh.
	self model treeRoots do: [ :root |
		root withAllChildrenDo: [ :each | checkedIceNodes add: each ] ].
	self refreshCodePanel ! !

!IceTipMergeSelectingPanel methodsFor: 'accessing' stamp: ''!
codePanel

	^ codePanel! !

!IceTipMergeSelectingPanel methodsFor: 'private' stamp: ''!
refreshCodePanel

	| visitor mergeNode |
	visitor := IceNodeCodeDisplayVisitor onCodePresenter: codePanel.
	mergeNode := iceNodesTree selectedItem value.
	mergeNode
		ifNil: [ codePanel text: '' ]
		ifNotNil: [ mergeNode accept: visitor ]! !

!IceTipMergeSelectingPanel methodsFor: 'accessing' stamp: ''!
selectedItems

	^ checkedIceNodes! !

!IceTipMergeSelectingPanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	codePanel := self newCode.

	"Super triggers a selection changed that requires that codePanel is already instantiated."
	super initializePresenters.
! !

!IceTipMergeSelectingPanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newLeftToRight
		  positionOfSlider: 25 percent;
		  add: #iceNodesTree;
		  add: (SpBoxLayout newTopToBottom
				   add: #diffPanel;
				   add: #codePanel;
				   yourself);
		  yourself
! !

!IceTipMergeType commentStamp: ''!
I'm a base class for merge types. 
My children define strategies of how to merge two commitish.
	
!
!IceTipMergeType methodsFor: 'executing' stamp: ''!
mergeOn: aModel then: aBlock
	self subclassResponsibility! !

!IceTipMergeType class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #uniqueInstance'! !

!IceTipMergeType class methodsFor: 'accessing' stamp: ''!
direct
	^ IceTipDirectMergeType uniqueInstance! !

!IceTipMergeType class methodsFor: 'instance creation' stamp: ''!
uniqueInstance 
	self = IceTipMergeType 
		ifTrue: [ self error: 'I''m an abstract type. Use one of my children' ].
	^ uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! !

!IceTipMergeType class methodsFor: 'accessing' stamp: ''!
default
	^ self direct! !

!IceTipMergeType class methodsFor: 'accessing' stamp: ''!
switchAndMerge
	^ IceTipSwitchAndMergeType uniqueInstance! !

!IceTipMetacelloInstallBaselineCommand commentStamp: ''!
I'm a general command to install metacello baselines.!
!IceTipMetacelloInstallBaselineCommand methodsFor: 'private' stamp: ''!
chooseConflictPolicyProject: projectName optionA: optionA optionB: optionB

	^ UIManager default 
		chooseFrom: {
			'Use INCOMING version {1}' format: { optionA }. 
			'Use LOADED version {1}' format: { optionB } }
		values: { 
			#useIncoming. 
			#useLoaded }
		message: ('There are conflicting versions of project "{1}".' format: { projectName })
		title: 'Conflicting project versions'! !

!IceTipMetacelloInstallBaselineCommand methodsFor: 'private' stamp: ''!
chooseUpgradePolicyFor: aMetacelloUpgradeRequest
	| projectName optionA optionB sessionContext |

	sessionContext := IceMetacelloLoadSessionContext value.
	projectName := aMetacelloUpgradeRequest projectName.
	optionA := aMetacelloUpgradeRequest newProjectRegistration printString.
	optionB := aMetacelloUpgradeRequest existingProjectRegistration printString.
	
	^ sessionContext 
		recordChoiceProject: projectName 
		optionA: optionA 
		optionB: optionB
		ifAbsentAnswer: [ 				
			self 
				chooseUpgradePolicyProject: projectName 
				optionA: optionA 
				optionB: optionB ]! !

!IceTipMetacelloInstallBaselineCommand methodsFor: 'private' stamp: ''!
chooseUpgradePolicyProject: projectName optionA: optionA optionB: optionB

	^ UIManager default 
		chooseFrom: {
			'Use INCOMING version {1}' format: { optionA }. 
			'Use LOADED version {1}' format: { optionB } }
		values: { 
			#useIncoming. 
			#useLoaded }
		message: ('There is already a project "{1}" in this installation.' format: { projectName })
		title: 'Duplicated project!!'! !

!IceTipMetacelloInstallBaselineCommand methodsFor: 'executing' stamp: ''!
iconName

	^ #smallLoadProject! !

!IceTipMetacelloInstallBaselineCommand methodsFor: 'private' stamp: ''!
installBaseline: icePackage 

	^ self installBaseline: icePackage groups: #()! !

!IceTipMetacelloInstallBaselineCommand methodsFor: 'private' stamp: ''!
chooseConflictPolicyFor: aMetacelloUpgradeRequest

	| projectName optionA optionB sessionContext |
	sessionContext := IceMetacelloLoadSessionContext value.
	projectName := aMetacelloUpgradeRequest projectName.
	optionA := aMetacelloUpgradeRequest newProjectRegistration printString.
	optionB := aMetacelloUpgradeRequest existingProjectRegistration printString.
	
	^ sessionContext 
		recordChoiceProject: projectName 
		optionA: optionA 
		optionB: optionB
		ifAbsentAnswer: [ 	
			self 
				chooseConflictPolicyProject: projectName 
				optionA: optionA 
				optionB: optionB ]! !

!IceTipMetacelloInstallBaselineCommand methodsFor: 'private' stamp: ''!
installBaseline: icePackage groups: anArray

	IceTipStandardAction new
		repository: self repository;
		message: ('Installing baseline {1} of {2}' format: { 
			icePackage metacelloBaselineName.
			self repositoryModel name });
		onSuccessRepositoryModified;
		execute: [ 
			Iceberg announcer 
				suspendAllForRepository: self repository
				while: [ self basicInstallBaseline: icePackage groups: anArray ] ]! !

!IceTipMetacelloInstallBaselineCommand methodsFor: 'private' stamp: ''!
basicInstallBaseline: icePackage groups: anArray

	| packageDir sourceDirectory |
	sourceDirectory := icePackage repository project sourceDirectory.
	sourceDirectory ifEmpty: [ sourceDirectory := '.'].

	packageDir := (icePackage repository location / sourceDirectory) fullName.

	Metacello new
		repository: 'gitlocal://', packageDir;
		baseline: icePackage metacelloBaselineName;
		onUpgrade: [ :e | | policy |
			policy := self chooseUpgradePolicyFor: e.
			policy ifNotNil: [ e perform: policy ] ];
		onConflict: [ :e | | policy |
			policy := self chooseConflictPolicyFor: e.
			policy ifNotNil: [ e perform: policy ] ];
		load: anArray! !

!IceTipMetacelloInstallBaselineCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self packageModel notNil and: [ self package isMetacelloBaseline ]! !

!IceTipMetacelloInstallBaselineCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipMetacelloInstallBaselineCommand! !

!IceTipMetacelloInstallBaselineDefaultCommand commentStamp: ''!
I'm a command to install a baseline (default group)!
!IceTipMetacelloInstallBaselineDefaultCommand methodsFor: 'executing' stamp: ''!
execute

	self installBaseline: self package! !

!IceTipMetacelloInstallBaselineDefaultCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Install baseline (default)'! !

!IceTipMetacelloInstallBaselineGroupCommand commentStamp: ''!
I'm a command to install a baseline (choose the group(s) to install)!
!IceTipMetacelloInstallBaselineGroupCommand methodsFor: 'executing' stamp: ''!
execute

	| result |
	result := UIManager default 
		request: 'Groups to install (a comma separated string)' 
		initialAnswer: '' 
		title: 'Enter groups to install'.
	result ifNil: [ ^ self ].
	
	self 
		installBaseline: self package
		groups: ((result substrings: ',') 
			collect: #trimmed 
			as: Array)! !

!IceTipMetacelloInstallBaselineGroupCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Install baseline...'! !

!IceTipMetacelloInstallCommandBuilder methodsFor: 'builder' stamp: ''!
addCommandsFor: anIceTipRepositoryModel intoGroup: aSpCommandGroup 
	
	| baselines |
	
	baselines := (anIceTipRepositoryModel workingCopy packageModels 
		select: [ :each | each name beginsWith: 'BaselineOf' ])
		sorted: [ :a :b | a name < b name ].
		
	
	baselines do: [ :aPackage |
		self addCommandsForPackage: aPackage intoGroup: aSpCommandGroup ]! !

!IceTipMetacelloInstallCommandBuilder methodsFor: 'builder' stamp: ''!
addCommandsForPackage: aPackage intoGroup: aSpCommandGroup 
	
	| defaultBaselineCommand groupBaselineCommand baselineName |
	
	baselineName := aPackage name allButFirst: 'BaselineOf' size.
	
	defaultBaselineCommand := IceTipMetacelloInstallBaselineDefaultCommand new.
	defaultBaselineCommand name: ('Install baseline of {1} (Default)' format: { baselineName }).
	defaultBaselineCommand packageModel: aPackage.
	aSpCommandGroup register: defaultBaselineCommand asSpecCommand.
	
	groupBaselineCommand := IceTipMetacelloInstallBaselineGroupCommand new.
	groupBaselineCommand name: ('Install baseline of {1} ...' format: { baselineName }).
	groupBaselineCommand packageModel: aPackage.
	aSpCommandGroup register: groupBaselineCommand asSpecCommand! !

!IceTipMetacelloPlugin commentStamp: ''!
I'm a plugin to add Metacello extensions into IceTip UI.!
!IceTipMetacelloPlugin class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	^ true! !

!IceTipModel commentStamp: ''!
I'm a base model for tip UI. 
Each tip component refers to one (and just one) model, which will provide model actions and access from presenters to backend.
Models can be cached using #beCached.!
!IceTipModel methodsFor: 'accessing' stamp: ''!
repositoryModel
	"this model does not provides a repository model"
	^ nil ! !

!IceTipModel methodsFor: 'private' stamp: ''!
toErrorMessage: aString

	^ aString asText allBold makeAllColor: self colorForError! !

!IceTipModel methodsFor: 'converting' stamp: ''!
beCached
	^ IceTipCachedModel for: self! !

!IceTipModel methodsFor: 'testing' stamp: ''!
matches: aString
	"Override this if you want to make this model discoverable"
	^ false! !

!IceTipModel methodsFor: 'private' stamp: ''!
colorForError

	^ Smalltalk ui theme dangerTextColor! !

!IceTipModel methodsFor: 'accessing' stamp: ''!
reset
	"to provide polymorphism with cached version"! !

!IceTipNewRepositoryPanel commentStamp: ''!
I'm a presenter to create a new repository from scratch.
Usually, I'm part of an IceTipRegisterProjectPresenter.

I will define location, name and source subdirectory and I will use that to create a #newRepository.!
!IceTipNewRepositoryPanel methodsFor: 'accessing - ui' stamp: ''!
projectNameInputText

	^ projectNameInputText! !

!IceTipNewRepositoryPanel methodsFor: 'accessing - ui' stamp: ''!
subdirectoryInputText

	^ subdirectoryInputText! !

!IceTipNewRepositoryPanel methodsFor: 'accessing - ui' stamp: ''!
subdirectoryLabel

	^ subdirectoryLabel! !

!IceTipNewRepositoryPanel methodsFor: 'initialization' stamp: ''!
initializeSourceDirectory

	subdirectoryLabel := self newLabel
		label: 'Source directory';
		yourself.
	subdirectoryInputText := self newTextInput
		placeholder: 'e.g., src';
		autoAccept: true;
		text: self defaultSubdirectory;
		yourself.
! !

!IceTipNewRepositoryPanel methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'New repository'! !

!IceTipNewRepositoryPanel methodsFor: 'accessing' stamp: ''!
validate

	self 
		assert: self projectNameInputText text isNotEmpty  
		description: 'You must enter a project name (it will be used also as part of the path).'.
	self
		assert: self projectLocation location notNil  
		description: 'Project location must be defined (if it does not exists, it will be created).'! !

!IceTipNewRepositoryPanel methodsFor: 'accessing - ui' stamp: ''!
projectNameLabel

	^ projectNameLabel! !

!IceTipNewRepositoryPanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	self initializeSourceDirectory.

	projectNameLabel := self newLabel
		label: 'Project name';
		yourself.
	projectNameInputText := self newTextInput
		placeholder: 'e.g., MyProject';
		autoAccept: true;
		whenTextChangedDo: [ :text | projectLocation appendPath: text ];
		yourself.
! !

!IceTipNewRepositoryPanel methodsFor: 'initialization' stamp: ''!
iconForWindow

	^ self iconNamed: #smallNew! !

!IceTipNewRepositoryPanel methodsFor: 'accessing' stamp: ''!
newRepository

	| repositoryName location subdirectory |
	repositoryName := self projectNameInputText text trimmed.
	location := self projectLocation location.
	subdirectory := self subdirectoryInputText text asString trimmed.
	
	UIManager default 
		informUser: ('Cloning repository {1} at {2}' format: { repositoryName. location fullName })
		during: [ 
			^ IceRepositoryCreator new
				repository: repository;
				location: location;
				subdirectory: subdirectory;
				createNewRepositoryNamed: repositoryName ]! !

!IceTipNewRepositoryPanel methodsFor: 'testing' stamp: ''!
isNewRepository

	^ true! !

!IceTipNewRepositoryPanel class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #projectNameLabel width: self labelWidth;
				   add: #projectNameInputText;
				   yourself)
		  height: 30;
		  add: #projectLocation height: 30;
		  add: (SpBoxLayout newLeftToRight
				   add: #subdirectoryLabel width: self labelWidth;
				   add: #subdirectoryInputText;
				   yourself)
		  height: 30;
		  yourself! !

!IceTipNewRepositoryPanel class methodsFor: 'accessing' stamp: ''!
order

	^ 10! !

!IceTipOpenCheckUrlCommand commentStamp: ''!
I'm a command to open in the native web browser the detail of a GitHub Pull Request check.
!
!IceTipOpenCheckUrlCommand methodsFor: 'accessing' stamp: ''!
targetUrl

	^ self context checksTable selection selectedItem at: 'target_url'
! !

!IceTipOpenCheckUrlCommand methodsFor: 'executing' stamp: ''!
execute
	"Execute the actions that should be done by the command. 
	This method expect that the context has been put in #context inst.var. if any context is relevant."

	WebBrowser openOn: self targetUrl
! !

!IceTipOpenCheckUrlCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Open a internet browser to look for the url of the check'! !

!IceTipOpenCheckUrlCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Open url'! !

!IceTipOpenGitHubPullRequestCommand commentStamp: ''!
Description
--------------------

I am a simple command to open the PR review tool.!
!IceTipOpenGitHubPullRequestCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #smallFind! !

!IceTipOpenGitHubPullRequestCommand methodsFor: 'executing' stamp: ''!
execute

	self tool viewPullRequest: self item! !

!IceTipOpenGitHubPullRequestCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self hasSelectedItem! !

!IceTipOpenGitHubPullRequestCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Open the Pull Request review tool'! !

!IceTipOpenGitHubPullRequestCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Review pull request'! !

!IceTipOpenNativelyCommand commentStamp: ''!
I am a command that, once executed, will open the native file browser on the directory containing the local repository of the git project.!
!IceTipOpenNativelyCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #smallWindow! !

!IceTipOpenNativelyCommand methodsFor: 'executing' stamp: ''!
execute

	self item location openInOSFileBrowser! !

!IceTipOpenNativelyCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	| location |
	self hasSelectedItem ifFalse: [ ^ false ].
	location := self item location.
	^ location isNotNil and: [ location exists ]! !

!IceTipOpenNativelyCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Open the native file browser on the local repository of this project.'! !

!IceTipOpenNativelyCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Open in native file browser'! !

!IceTipOptionDialog commentStamp: ''!
I'm a dialog that has different options. 
I'm a abstract class, I need to be used  through my children.

I'm kind of a "tabbed" dialog, but my options are "mac style": lateral and not top.

This is useful to keep a variable number of options.!
!IceTipOptionDialog methodsFor: 'private' stamp: ''!
replacePanelWith: aType

	contentPanel := aType.
	self needRebuild: false.
	self buildWithSpec! !

!IceTipOptionDialog methodsFor: 'accessing' stamp: ''!
allTypes

	^ self subclassResponsibility! !

!IceTipOptionDialog methodsFor: 'accessing' stamp: ''!
contextSelection

	^ type! !

!IceTipOptionDialog methodsFor: 'accessing' stamp: ''!
selectedType

	^ type! !

!IceTipOptionDialog methodsFor: 'initialization' stamp: ''!
initializeTypeList

	typeList
		hideColumnHeaders;
		addColumn: ((SpImageTableColumn evaluated: #iconForWindow) width: 20);
		addColumn: (SpStringTableColumn evaluated: #titleForWindow);
		whenSelectionChangedDo: [ :selection | 
			self selectionChanged: selection selectedItem ];
		items: self allTypes! !

!IceTipOptionDialog methodsFor: 'private' stamp: ''!
selectionChanged: aType

	type := aType.
	aType ifNotNil: [ 
		self window title: type titleForWindow.
		self replacePanelWith: type ]! !

!IceTipOptionDialog methodsFor: 'accessing - ui' stamp: ''!
contentPanel

	^ contentPanel! !

!IceTipOptionDialog methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aWindowPresenter

	super initializeDialogWindow: aWindowPresenter.
	aWindowPresenter okAction: [ self doAccept ].
	aWindowPresenter whenOpenedDo: [ self typeList selectIndex: 1 ]! !

!IceTipOptionDialog methodsFor: 'actions' stamp: ''!
doAccept

	self subclassResponsibility! !

!IceTipOptionDialog methodsFor: 'actions' stamp: ''!
accept

	^ [ 
	  self doAccept.
	  true ]
		  on: IceError , IceWarning
		  do: [ :e | 
			  e acceptError: IceTipInteractiveErrorVisitor new.
			  false ]! !

!IceTipOptionDialog methodsFor: 'accessing - ui' stamp: ''!
typeList

	^ typeList! !

!IceTipOptionDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (600 @ 300) scaledByDisplayScaleFactor! !

!IceTipOptionDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	contentPanel := self newNullPresenter.
	typeList := self newTable.
	self initializeTypeList.
! !

!IceTipOptionDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newLeftToRight
		  positionOfSlider: 30 percent;
		  add: #typeList;
		  add: #contentPanel;
		  yourself! !

!IceTipPackageCommand commentStamp: ''!
Abstract class representing commands to be applied on top of packages.!
!IceTipPackageCommand methodsFor: 'testing' stamp: ''!
isPackageLoaded 

	^ self hasPackageModel and: [ self packageModel isLoaded ]! !

!IceTipPackageCommand methodsFor: 'testing' stamp: ''!
hasPackageModel

	^ self packageModel notNil! !

!IceTipPackageCommand methodsFor: 'accessing' stamp: ''!
packageModel: anIceTipPackageModel 

	packageModel := anIceTipPackageModel! !

!IceTipPackageCommand methodsFor: 'accessing' stamp: ''!
packageModel

	^ packageModel ifNil: [self context packageModel]! !

!IceTipPackageCommand methodsFor: 'accessing' stamp: ''!
package

	^ self packageModel entity! !

!IceTipPackageCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipPackageCommand! !

!IceTipPackageModel commentStamp: ''!
I'm a model for IcePackage entries.!
!IceTipPackageModel methodsFor: 'actions' stamp: ''!
load
	<noCache>

	IceTipStandardAction new 
		repository: self entity repository;
		message: ('Loading package {1}' format: { self entity name });
		onSuccessRepositoryModified;
		execute: [ 
			Iceberg announcer
				suspendAllForRepository: self entity repository
				while: [ self entity load ] ]! !

!IceTipPackageModel methodsFor: 'testing' stamp: ''!
isModified
	^ self entity isModified! !

!IceTipPackageModel methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	| text |
	
	text := self displayString asText.
	self entity isLoaded
		ifFalse:[ text := text makeAllColor: self colorNotLoaded ].
	self entity isModified 
		ifTrue: [ text := ('*', text) asText makeAllColor: self colorModified ].
	^ text! !

!IceTipPackageModel methodsFor: 'actions' stamp: ''!
unload
	<noCache>

	IceTipStandardAction new 
		repository: self entity repository;
		message: ('Unloading package {1}' format: { self entity name });
		onSuccessRepositoryModified; 
		execute: [ 
			Iceberg announcer
				suspendAllForRepository: self entity repository
				while: [ self entity unload ] ]! !

!IceTipPackageModel methodsFor: 'actions' stamp: ''!
reload
	<noCache>

	IceTipStandardAction new 
		repository: self entity repository;
		message: ('Reloading package {1}' format: { self entity name }) ;
		onSuccessRepositoryModified;
		execute: [ 
			Iceberg announcer 
				suspendAllForRepository: self entity repository 
				while: [ self entity reload ] ]! !

!IceTipPackageModel methodsFor: 'testing' stamp: ''!
isLoaded
	^ self entity isLoaded! !

!IceTipPackageModel methodsFor: 'accessing' stamp: ''!
name
	^ self entity name! !

!IceTipPackageModel methodsFor: 'actions' stamp: ''!
remove
	<noCache>

	IceTipStandardAction new 
		repository: self entity repository;
		message: ('Removing package {1}' format: { self entity name });
		onSuccessRepositoryModified; 
		execute: [ 
			Iceberg announcer
				suspendAllForRepository: self entity repository
				while: [ self entity remove ] ]! !

!IceTipPackageModel methodsFor: 'accessing' stamp: ''!
packageName
	^ self entity packageName! !

!IceTipPackageModel methodsFor: 'accessing' stamp: ''!
status
	"entity could be a repository or a package"
	[
		self entity repository isMissing ifTrue: [ ^ self toErrorMessage: 'Local repository missing' ].
		self entity isLoaded ifFalse: [ ^ 'Not loaded' ].
		self entity isModified ifTrue: [ ^ 'Uncommited changes' ].
		^ 'Up to date' ] 
	on: Error do: [ :e | 
		^ self toErrorMessage: e description ]! !

!IceTipPackageModel methodsFor: 'actions' stamp: ''!
browseRepositoryVersion
	<noCache>
	| snapshot |
	
	snapshot := self entity mcSnapshotInRepository.
	(MCSnapshotBrowser forSnapshot: snapshot)
		showLabelled: 'Snapshot for ', self entity name! !

!IceTipPackageModel methodsFor: 'accessing' stamp: ''!
statusWithDecoration
	| text |
	
	text := self status asText.
	self entity isLoaded 
		ifFalse: [ text := text makeAllColor: self colorNotLoaded ].
	^ text! !

!IceTipPackageModel methodsFor: 'actions' stamp: ''!
browsePackage
	<noCache>

	self entity browse! !

!IceTipPreviewBrowser commentStamp: ''!
I'm a browser to show a preview of an operation that can be made right after.
Tipically, I'm using through my chldren, to do a checkout or merge.!
!IceTipPreviewBrowser methodsFor: 'accessing - ui' stamp: ''!
actionPanel

	^ actionPanel! !

!IceTipPreviewBrowser methodsFor: 'private - factory' stamp: ''!
newActionButton
	self subclassResponsibility! !

!IceTipPreviewBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (800 @ 400) scaledByDisplayScaleFactor! !

!IceTipPreviewBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	
	diffPanel := self instantiate: IceTipDiffPanel on: self model diff.
	actionPanel := self newButtonBar.
	actionPanel add: (button := self newActionButton).
! !

!IceTipPreviewBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList
	"Answer the presenter that is the main list of items of this browser."

	^ diffPanel iceNodesTree! !

!IceTipPreviewBrowser methodsFor: 'accessing - ui' stamp: ''!
diffPanel

	^ diffPanel! !

!IceTipPreviewBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	"Nothing to add"! !

!IceTipPreviewBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #diffPanel;
		  add: #actionPanel expand: false;
		  yourself! !

!IceTipPreviewBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	"Nothing to add"! !

!IceTipPullBrowser commentStamp: ''!
I perform a pull of incoming commits.
!
!IceTipPullBrowser methodsFor: 'actions' stamp: ''!
doPull

	self model pullThen: [ self closeWindow ]! !

!IceTipPullBrowser methodsFor: 'private - factory' stamp: ''!
newActionButton

	^ self newButton
		label: 'Pull';
		icon: (self iconNamed: #down);
		help: ('Pull new commits from {1}' format: { self model remoteName });
		action: [ self doPull ];
		yourself
! !

!IceTipPullBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Pull {1}/{2} from {3}' format: { 
		self model repositoryName.
		self model branchName. 
		self model remoteName }
! !

!IceTipPullBrowser methodsFor: 'initialization' stamp: ''!
labelForRemotePanel

	^ 'Pull from remote:'! !

!IceTipPullBrowser class methodsFor: 'instance creation' stamp: ''!
onRepositoryModel: aModel

	^ self on: (IceTipPullModel 
		repositoryModel: aModel 
		on: aModel entity) 
		beCached
! !

!IceTipPullBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	aCommandGroup register: IceTipFetchInPullCommand forSpec! !

!IceTipPullCommand commentStamp: ''!
I'm a command to perform a pull of incomming commits. 
I open a pull view window.!
!IceTipPullCommand methodsFor: 'executing' stamp: ''!
badge

	| result |
	(self repositoryModel isNotNil and: [
		self repositoryModel isMissing not]) ifTrue: [
		result := self repositoryModel numberOfIncomingCommits.
		"If zero, reset to nil to make it dissapear in Spec."
		result isZero ifTrue: [ result := nil ] ].

	^ result! !

!IceTipPullCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #down! !

!IceTipPullCommand methodsFor: 'executing' stamp: ''!
execute

	self withErrorHandlingDo: [ 
		self validateRemotesPresent.
	 	(IceTipPullBrowser onRepositoryModel: self repositoryModel) openWithSpec ]
! !

!IceTipPullCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Pulls into image all commits from your version to the origin remote HEAD'! !

!IceTipPullCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Pull'! !

!IceTipPullModel commentStamp: ''!
I'm a model to present pull commits and operations.!
!IceTipPullModel methodsFor: 'actions' stamp: ''!
pullThen: aBlock
	IceTipStandardAction new 
		repository: self entity;
		message: ('Pulling from {1}' format: { self remote name });
		onSuccessRepositoryModified;
		onSuccess: aBlock;
		execute: [ self entity pullFrom: self remote ]! !

!IceTipPullModel methodsFor: 'accessing' stamp: ''!
commitModels
	^ (self entity branch incomingCommitsFrom: self remote)
		collect: [ :each | 
			(IceTipCommitModel 
				repositoryModel: self repositoryModel 
				on: each) 
				beCached ]! !

!IceTipPushAction commentStamp: ''!
I perform a push.!
!IceTipPushAction methodsFor: 'executing' stamp: ''!
basicExecute
	UIManager default 
		informUser: 'Pushing...' 
		during: [ self repository push ].
	Iceberg announcer announce: (IceRepositoryModified for: self repository).
	Iceberg announcer announce: (IcePushed for: self repository).! !

!IceTipPushBrowser commentStamp: ''!
I perform a push of outgoing commits.
!
!IceTipPushBrowser methodsFor: 'actions' stamp: ''!
doPush

	self model pushThen: [ self closeWindow ]! !

!IceTipPushBrowser methodsFor: 'private - factory' stamp: ''!
newActionButton

	^ self newButton
		label: 'Push';
		icon: (self iconNamed: #up);
		help: ('Push new commits to {1}' format: { self model remoteName });
		action: [ self doPush ];
		yourself
! !

!IceTipPushBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Push {1}/{2} to {3}' format: { 
		self model repositoryName.
		self model branchName. 
		self model remoteName }! !

!IceTipPushBrowser methodsFor: 'initialization' stamp: ''!
labelForRemotePanel

	^ 'Push to remote:'
! !

!IceTipPushBrowser class methodsFor: 'instance creation' stamp: ''!
onRepositoryModel: aModel

	^ self on: (IceTipPushModel 
		repositoryModel: aModel 
		on: aModel entity) 
		beCached
! !

!IceTipPushBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	"No commands to add."! !

!IceTipPushCommand commentStamp: ''!
I'm a command to perform a push of outgoing commits. 
I open a push view window.!
!IceTipPushCommand methodsFor: 'executing' stamp: ''!
badge

	| result |
	(self repositoryModel isNotNil and: [
		self repositoryModel isMissing not]) ifTrue: [
		result := self repositoryModel numberOfOutgoingCommits.
		"If zero, reset to nil to make it dissapear in Spec."
		result = '0' ifTrue: [ result := nil ] ].

	^ result
! !

!IceTipPushCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #up! !

!IceTipPushCommand methodsFor: 'executing' stamp: ''!
execute

	self withErrorHandlingDo: [ 
		self validateRemotesPresent.
		(IceTipPushBrowser onRepositoryModel: self repositoryModel) openWithSpec ]! !

!IceTipPushCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Pushes pending commits to the origin repository (in current branch)'! !

!IceTipPushCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Push'! !

!IceTipPushModel commentStamp: ''!
I'm a model to present push commits and operations.!
!IceTipPushModel methodsFor: 'actions' stamp: ''!
pushThen: aBlock
	IceTipStandardAction new 
		repository: self entity;
		message: ('Pushing to {1}' format: { self remote name }) ;
		onSuccessRepositoryModified;
		onSuccess: aBlock;
		execute: [ self entity pushTo: self remote ]! !

!IceTipPushModel methodsFor: 'accessing' stamp: ''!
commitModels
	^ (self entity outgoingCommitsTo: self remote)
		collect: [ :each | 
			(IceTipCommitModel 
				repositoryModel: self repositoryModel 
				on: each) 
				beCached ]! !

!IceTipReadOnlyFormBuilder commentStamp: ''!
I'm a "read only form", used to display data in a more readable way than a list morph or a panel morph.
I receive a list of "label" and "values", being label a string and value a string or text object.

I can show lists of elements as this example shows: 

IceTipReadOnlyForm new 
	addLabel: 'Commit:' value: 'a test';
	addLabel: 'Parents:' value: '123456789';
	addLabel: 'Author:' value: 'Some Author <author@email.net>';
	addLabel: 'Date:' value: DateAndTime now asStringYMDHM;
	addLabel: 'Labels:' value: '';
	addLabel: 'Comment' value: String loremIpsum;
	openWithSpec.
	!
!IceTipReadOnlyFormBuilder methodsFor: 'accessing' stamp: ''!
labelWidth

	^ labelWidth ifNil: [ self defaultLabelWidth ]! !

!IceTipReadOnlyFormBuilder methodsFor: 'private - factory' stamp: ''!
newPresenter

	^ (spApplication newPresenter: SpPresenter)
		  layout: self newLayout;
		  yourself! !

!IceTipReadOnlyFormBuilder methodsFor: 'initialization' stamp: ''!
initialize

	items := OrderedDictionary new.
	super initialize! !

!IceTipReadOnlyFormBuilder methodsFor: 'accessing' stamp: ''!
defaultRowHeight

	^ 30 * self currentWorld displayScaleFactor! !

!IceTipReadOnlyFormBuilder methodsFor: 'accessing' stamp: ''!
labelWidth: aNumber

	^ labelWidth := aNumber! !

!IceTipReadOnlyFormBuilder methodsFor: 'accessing' stamp: ''!
defaultLabelWidth

	^ 100 * self currentWorld displayScaleFactor! !

!IceTipReadOnlyFormBuilder methodsFor: 'accessing' stamp: ''!
rowHeight

	^ rowHeight ifNil: [ rowHeight := self defaultRowHeight ]! !

!IceTipReadOnlyFormBuilder methodsFor: 'accessing' stamp: ''!
rowHeight: aNumber

	rowHeight := aNumber! !

!IceTipReadOnlyFormBuilder methodsFor: 'accessing' stamp: ''!
items: aDictionary

	items removeAll.
	items addAll: aDictionary.
! !

!IceTipReadOnlyFormBuilder methodsFor: 'accessing' stamp: ''!
labelColor: aColor

	^ labelColor := aColor! !

!IceTipReadOnlyFormBuilder methodsFor: 'accessing' stamp: ''!
application: aSpApplication 
	
	spApplication := aSpApplication! !

!IceTipReadOnlyFormBuilder methodsFor: 'private - factory' stamp: ''!
newLayout

	| newLayout |
	newLayout := SpBoxLayout newTopToBottom.

	items associations withIndexDo: [ :anAssociation :index | 
		
		"Last item takes all remaining space"		
		index = items size 
			ifTrue: [ newLayout
							add: (self newRowPresenterForLabel: anAssociation key value: anAssociation value)
							withConstraints: [ :constraints |
								constraints padding: 1 ] ]
			ifFalse: [ newLayout
							add: (self newRowPresenterForLabel: anAssociation key value: anAssociation value)
							withConstraints: [ :constraints | 
								constraints padding: 1.
								constraints height: self rowHeight ]]].

	^ newLayout! !

!IceTipReadOnlyFormBuilder methodsFor: 'accessing' stamp: ''!
labelColor

	^ labelColor ifNil: [ labelColor := Smalltalk ui theme textColor ]! !

!IceTipReadOnlyFormBuilder methodsFor: 'private - factory' stamp: ''!
newRowPresenterForLabel: aString value: anotherString

	^ SpBoxLayout newLeftToRight
		  add: ((spApplication newPresenter: SpLabelPresenter)
				   label: aString;
				   color: self labelColor;
				   yourself) width: self labelWidth;
		  add: ((spApplication newPresenter: SpTextInputFieldPresenter)
				   text: anotherString trimBoth;
					addStyle: 'iceTipReadonly';
					enabled: false;
				   yourself);
		  yourself! !

!IceTipReadOnlyFormBuilder class methodsFor: 'instance creation' stamp: ''!
newBuiltFor: aDictionary application: aSpApplication

	"If you want to keep order, just send an OrderedDictionary"

	^ self new
		items: aDictionary;
		application: aSpApplication;
		newPresenter! !

!IceTipRefreshCommitCommand commentStamp: ''!
Command that launches a refresh of the commit tree during commit!
!IceTipRefreshCommitCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #glamorousRefresh! !

!IceTipRefreshCommitCommand methodsFor: 'executing' stamp: ''!
execute

	self repositoryModel reset.
	"Announce to my owner (not the general announcement, because just my owner panel is 
	 interested on this action)"
	self toolAnnouncer announce: (IceTipDiffRefreshed for: self repository)! !

!IceTipRefreshCommitCommand methodsFor: 'accessing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ true! !

!IceTipRefreshCommitCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Refresh this change tree'! !

!IceTipRefreshCommitCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Refresh'! !

!IceTipRefreshPullRequestsCommand commentStamp: ''!
Description
--------------------

I am a simple command to refresh the content of the github pull requests browser!
!IceTipRefreshPullRequestsCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #glamorousRefresh! !

!IceTipRefreshPullRequestsCommand methodsFor: 'executing' stamp: ''!
execute

	UIManager default
		informUser: 'Refreshing pull request list'
		during: [ self tool refreshPullRequests ]! !

!IceTipRefreshPullRequestsCommand methodsFor: 'accessing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ true! !

!IceTipRefreshPullRequestsCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription

	^ 'Refresh the pull requests availables'! !

!IceTipRefreshPullRequestsCommand class methodsFor: 'accessing' stamp: ''!
defaultName

	^ 'Refresh'! !

!IceTipRegisterRepositoryDialog commentStamp: ''!
I'm a dialog to register new repositories.
I can create new repositories, add existing ones and clone for different places (including a generic url clone).

self new 
	onAccept: [ :newRepository | newRepository register ];
	openDialogWithSpec!
!IceTipRegisterRepositoryDialog methodsFor: 'accessing' stamp: ''!
allTypes

	^ types ifNil: [ types := IceTipRepositoryTypePanel allTypes ]! !

!IceTipRegisterRepositoryDialog methodsFor: 'events' stamp: ''!
onAccept: aBlock

	acceptBlock := aBlock! !

!IceTipRegisterRepositoryDialog methodsFor: 'accessing' stamp: ''!
withoutNewRepository

	types := self allTypes reject: #isNewRepository.
	typeList items: types! !

!IceTipRegisterRepositoryDialog methodsFor: 'accessing' stamp: ''!
withoutLocalRepository

	types := self allTypes reject: #isLocalRepository.
	typeList items: types! !

!IceTipRegisterRepositoryDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Register project'! !

!IceTipRegisterRepositoryDialog methodsFor: 'actions' stamp: ''!
doAccept

	| newRepository |
	self selectedType validate.
	self isEditing ifTrue: [ self selectedType repository: repository ].
	newRepository := self selectedType newRepository.
	self isEditing ifFalse: [ newRepository register ].
	acceptBlock ifNotNil: [ acceptBlock cull: self ]! !

!IceTipRegisterRepositoryDialog methodsFor: 'accessing' stamp: ''!
beForCloneOfRepository: aRepository

	self withoutNewRepository.
	self withoutLocalRepository.
	repository := aRepository! !

!IceTipRegisterRepositoryDialog methodsFor: 'testing' stamp: ''!
isEditing

	^ repository isNotNil! !

!IceTipRegisterRepositoryDialog methodsFor: 'actions' stamp: ''!
doEdit: aRepository

	repository
		location: aRepository location;
		subdirectory: aRepository subdirectory! !

!IceTipReloadPackageCommand commentStamp: ''!
Command that reloads the code of an already loaded package, discarding all changes done in the meantime that were not committed.!
!IceTipReloadPackageCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #refresh! !

!IceTipReloadPackageCommand methodsFor: 'executing' stamp: ''!
execute

	self packageModel reload.
	Iceberg announcer announce:
		(IceRepositoryModified for: self repository)! !

!IceTipReloadPackageCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self isPackageLoaded! !

!IceTipReloadPackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Reload selected package, discarding all changes.'! !

!IceTipReloadPackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Reload'! !

!IceTipRemoteActionBrowser methodsFor: 'initialization' stamp: ''!
labelForRemotePanel

	^ self subclassResponsibility! !

!IceTipRemoteActionBrowser methodsFor: 'accessing - ui' stamp: ''!
remotePanel: aSpPresenter

	remotePanel := aSpPresenter! !

!IceTipRemoteActionBrowser methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindow

	super initializeWindow: aWindow.
	
	aWindow bindKeyCombination: $s meta toAction: [ self accept ]! !

!IceTipRemoteActionBrowser methodsFor: 'accessing - ui' stamp: ''!
remotePanel

	^ remotePanel! !

!IceTipRemoteActionBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	remotePanel := self
		instantiate: IceTipSelectRemotePresenter
		on: self model.
	remotePanel label: self labelForRemotePanel.
	remotePanel remoteList
		whenSelectedItemChangedDo: [ :remoteModel | self moveToRemote: remoteModel ].
! !

!IceTipRemoteActionBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList

	^ commitsPanel commitList! !

!IceTipRemoteActionBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	"No commands to add"! !

!IceTipRemoteActionBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #remotePanel
		  withConstraints: [ :c | c height: self inputTextHeight ];
		  add: #commitsPanel withConstraints: [ :c | c spec: #panelSpec ];
		  add: #actionButtonBar
		  withConstraints: [ :c | c height: self buttonHeight ];
		  yourself! !

!IceTipRemoteActionBrowser class methodsFor: 'instance creation' stamp: ''!
onRepositoryModel: aRepository
	^ self subclassResponsibility! !

!IceTipRemoteActionCommand commentStamp: ''!
I'm a the abstract superclass of commands that act on remotes. !
!IceTipRemoteActionCommand methodsFor: 'validating' stamp: ''!
validateRemotesPresent

	self repositoryModel hasRemotes
		ifFalse: [ IceNoRemote signal ]! !

!IceTipRemoteActionCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self isRepositoryOperational
		and: [ self repositoryModel hasRemotes ]! !

!IceTipRemoteActionCommand class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ self == IceTipRemoteActionCommand! !

!IceTipRemoteActionModel methodsFor: 'accessing' stamp: ''!
useRemote: aRemoteModel
	remote := aRemoteModel entity.! !

!IceTipRemoteActionModel methodsFor: 'testing' stamp: ''!
isRepositoryDetached
	^ self entity workingCopy isDetached 
		or: [ self entity head isDetached ]! !

!IceTipRemoteActionModel methodsFor: 'accessing' stamp: ''!
remoteModels
	^ self repositoryModel remoteModels! !

!IceTipRemoteActionModel methodsFor: 'accessing' stamp: ''!
branchName
	^ entity branchName! !

!IceTipRemoteActionModel methodsFor: 'accessing' stamp: ''!
remoteName
	^ self remote name, '/', self entity branch name! !

!IceTipRemoteActionModel methodsFor: 'accessing' stamp: ''!
remoteModel
	^ repositoryModel remoteModels detect: [ :e | e entity = self remote ]! !

!IceTipRemoteActionModel methodsFor: 'accessing' stamp: ''!
remote
	^ remote ifNil: [ | head |
		head := self repositoryModel entity head.
		remote := (head isBranch and: [ head hasUpstream ])
				ifTrue: [ head upstream remote ]
				ifFalse: [ self remoteModels first entity ] ]! !

!IceTipRemoteActionModel methodsFor: 'accessing' stamp: ''!
repositoryName
	^ self repositoryModel name! !

!IceTipRemoteModel commentStamp: ''!
I'm a model for IceRemote entries.!
!IceTipRemoteModel methodsFor: 'accessing' stamp: ''!
repositoryModel 
	^ self explicitRequirement! !

!IceTipRemoteModel methodsFor: 'actions' stamp: ''!
delete
	<noCache>
	
	IceTipStandardAction new
		repository: self repositoryModel entity;
		message: ('Removing remote {1}' format: { self name });
		onSuccessRepositoryModified;
		do: [ self repositoryModel entity removeRemote: self entity ]! !

!IceTipRemoteModel methodsFor: 'comparing' stamp: ''!
= anotherModel

	self species = anotherModel species ifFalse: [ ^ false ].
	
	^ entity = anotherModel entity! !

!IceTipRemoteModel methodsFor: 'testing' stamp: ''!
hasBranches 
	^ self branches isNotEmpty! !

!IceTipRemoteModel methodsFor: 'accessing' stamp: ''!
defaultBranchSelection
	^ self branchModels
		detect: #isHead
		ifNone: [ self hasBranches
				ifTrue: [ self branchModels ifNotEmpty: #anyOne ] ]! !

!IceTipRemoteModel methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	^ '{1} <{2}>' format: { self name. self entity url }! !

!IceTipRemoteModel methodsFor: 'accessing' stamp: ''!
branches
	^ self entity branches! !

!IceTipRemoteModel methodsFor: 'actions' stamp: ''!
fetch
	<noCache>
	
	IceTipStandardAction new
		repository: self repositoryModel entity;
		message: ('Fetching remote {1}' format: { self name });
		onSuccessRepositoryModified;
		do: [ self entity fetch ]! !

!IceTipRemoteModel methodsFor: 'branches' stamp: ''!
branchModels
	^ self branches collect: [ :each | (IceTipBranchModel repositoryModel: self repositoryModel on: each) beCached ]! !

!IceTipRemoteModel methodsFor: 'accessing' stamp: ''!
name
	^ self entity name! !

!IceTipRemoteModel class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!IceTipRemoteModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!IceTipRemoteModel class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!IceTipRemoteModel class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!IceTipRemoteModel class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!IceTipRemoteModel class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!IceTipRemoteModel class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!IceTipRemoteModel class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!IceTipRemoteModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceTipRemoteModel class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!IceTipRemoteModel class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!IceTipRemoteModel class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!IceTipRemoteModel class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!IceTipRemoteModel class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!IceTipRemoteModel class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!IceTipRemoteModel class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!IceTipRemoteModel class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!IceTipRemoteModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceTipRemoteModel class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!IceTipRemoteModel class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!IceTipRemoteModel class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!IceTipRemoteModel class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!IceTipRemoteModel class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!IceTipRemoteModel class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!IceTipRemoteModel class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!IceTipRemoteModel class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!IceTipRemoteModel class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!IceTipRemoteModel class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!IceTipRemoteModel class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!IceTipRemotesTreeCommand commentStamp: ''!
I'm a the abstract superclass of commands that act on repositories. !
!IceTipRemotesTreeCommand methodsFor: 'testing' stamp: ''!
actsOnBranch: aBranchModel

	^ false! !

!IceTipRemotesTreeCommand methodsFor: 'testing' stamp: ''!
actsOnRemote: aRemoteModel

	^ false! !

!IceTipRemotesTreeCommand methodsFor: 'executing' stamp: ''!
canBeExecuted

	^ self hasSelectedItem and: [ self item canActivateCommand: self ]! !

!IceTipRemotesTreeCommand methodsFor: 'testing' stamp: ''!
actsOnTag: aTagModel

	^ false! !

!IceTipRemotesTreeCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipRemotesTreeCommand! !

!IceTipRemoveCredentialCommand commentStamp: ''!
I remove a credential from the credential store.!
!IceTipRemoveCredentialCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #remove! !

!IceTipRemoveCredentialCommand methodsFor: 'executing' stamp: ''!
execute
	
	self store removeCredential: self item.
	self tool refresh.! !

!IceTipRemoveCredentialCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $x meta! !

!IceTipRemoveCredentialCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self item isDefault not! !

!IceTipRemoveCredentialCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Removes the credential from the store'! !

!IceTipRemoveCredentialCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Remove'! !

!IceTipRemoveFromRepositoryPackageCommand commentStamp: ''!
Command that removes a package from the repository, without removing it from the system.!
!IceTipRemoveFromRepositoryPackageCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #glamorousTrash! !

!IceTipRemoveFromRepositoryPackageCommand methodsFor: 'executing' stamp: ''!
execute

	self packageModel remove! !

!IceTipRemoveFromRepositoryPackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Removes the current repository from the repository, without removing it from the system'! !

!IceTipRemoveFromRepositoryPackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Remove from repository'! !

!IceTipRemovePackageDialog methodsFor: 'accessing' stamp: ''!
unloadFromImageCheckbox

	^ unloadFromImageCheckbox! !

!IceTipRemovePackageDialog methodsFor: 'accessing - ui' stamp: ''!
iconPanel

	^ iconPanel! !

!IceTipRemovePackageDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Remove Package'! !

!IceTipRemovePackageDialog methodsFor: 'actions' stamp: ''!
accept

	self removeFromRepositoryCheckbox state
		ifTrue: [ self model remove ].
	self unloadFromImageCheckbox state
		ifTrue: [ self model unload ].! !

!IceTipRemovePackageDialog methodsFor: 'accessing' stamp: ''!
model: anObject

	model := anObject! !

!IceTipRemovePackageDialog methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipRemovePackageDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (500
		@ (self class inputTextHeight * 2 + self class buttonHeight + 75))
		scaledByDisplayScaleFactor	"Yes, a magic number"! !

!IceTipRemovePackageDialog methodsFor: 'accessing - ui' stamp: ''!
removeFromRepositoryCheckbox

	^ removeFromRepositoryCheckbox! !

!IceTipRemovePackageDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.

	iconPanel := self newImage
		image: (self iconNamed: #question);
		yourself.
	confirmLabel := self newLabel 
		label: (self confirmMessage format: { self model name });
		yourself.
	unloadFromImageCheckbox := self newCheckBox
		label: 'Unload from image';
		state: true;
		yourself.
	removeFromRepositoryCheckbox := self newCheckBox
		label: 'Remove from repository';
		state: true;
		yourself.
! !

!IceTipRemovePackageDialog methodsFor: 'accessing' stamp: ''!
confirmMessage

	^ 'Are you sure to remove package {1}?'! !

!IceTipRemovePackageDialog methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipRemovePackageDialog methodsFor: 'accessing - ui' stamp: ''!
confirmLabel

	^ confirmLabel! !

!IceTipRemovePackageDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #iconPanel
				   width: 40 * self currentWorld displayScaleFactor;
				   add: (SpBoxLayout newTopToBottom
						    add: #confirmLabel;
						    add: #unloadFromImageCheckbox height: self inputTextHeight;
						    add: #removeFromRepositoryCheckbox
						    height: self inputTextHeight;
						    yourself);
				   yourself);
		  yourself! !

!IceTipRemoveRepositoryDialog methodsFor: 'accessing' stamp: ''!
removeMessage
	^ 'Also remove repository from file system'! !

!IceTipRemoveRepositoryDialog methodsFor: 'accessing - ui' stamp: ''!
iconPanel

	^ iconPanel! !

!IceTipRemoveRepositoryDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Remove repository'! !

!IceTipRemoveRepositoryDialog methodsFor: 'actions' stamp: ''!
accept

	self removeFileSystemCheckbox state
		ifTrue: [ self model delete ]
		ifFalse: [ self model forget ]! !

!IceTipRemoveRepositoryDialog methodsFor: 'accessing' stamp: ''!
model: anObject

	model := anObject! !

!IceTipRemoveRepositoryDialog methodsFor: 'accessing - ui' stamp: ''!
removeFileSystemCheckbox

	^ removeFileSystemCheckbox! !

!IceTipRemoveRepositoryDialog methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipRemoveRepositoryDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (500@(
		self class inputTextHeight * 2
		+ self class buttonHeight 
		+ 50 "Yes, a magic number"
		)) scaledByDisplayScaleFactor! !

!IceTipRemoveRepositoryDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	iconPanel := self newImage
		image: (self iconNamed: #question);
		yourself.
	confirmLabel := self newLabel
		label: (self confirmMessage format: {self model name});
		yourself.
	removeFileSystemCheckbox := self newCheckBox
		label: self removeMessage;
		yourself.
! !

!IceTipRemoveRepositoryDialog methodsFor: 'accessing' stamp: ''!
confirmMessage
	^ 'Are you sure to remove your repository {1} from your image?'! !

!IceTipRemoveRepositoryDialog methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipRemoveRepositoryDialog methodsFor: 'accessing - ui' stamp: ''!
confirmLabel

	^ confirmLabel! !

!IceTipRemoveRepositoryDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: (SpBoxLayout newLeftToRight
				   add: #iconPanel
				   width: 40 * self currentWorld displayScaleFactor;
				   add: (SpBoxLayout newTopToBottom
						    add: #confirmLabel;
						    add: #removeFileSystemCheckbox height: self inputTextHeight;
						    yourself);
				   yourself);
		  yourself! !

!IceTipRepairAction commentStamp: ''!
I'm a repair option.
Repositories can be broken in several ways. My children will describe them and take the actions needed to perform the re-alignment of an image with its repository.!
!IceTipRepairAction methodsFor: 'accessing' stamp: ''!
repositoryModel
	^ repositoryModel! !

!IceTipRepairAction methodsFor: 'accessing' stamp: ''!
help 
	^ self class help! !

!IceTipRepairAction methodsFor: 'accessing' stamp: ''!
repositoryModel: anObject
	repositoryModel := anObject! !

!IceTipRepairAction methodsFor: 'accessing' stamp: ''!
repository
	^ self repositoryModel entity! !

!IceTipRepairAction methodsFor: 'private' stamp: ''!
fetchAllRemotes
	| remotes |
	remotes := self repository remotes.
	UIManager default informUserDuring: [ :bar | 
		bar label: 'Fetching incoming commits'.
		bar max: remotes size.
		bar value: 1.
		remotes withIndexDo: [ :each :index |
			bar label: ('Fetching incoming commits of {1}' format: {each name}).
			bar value: index + 1.
			self repository fetchFrom: each ] ].	! !

!IceTipRepairAction methodsFor: 'accessing' stamp: ''!
icon
	^ self class icon! !

!IceTipRepairAction methodsFor: 'executing' stamp: ''!
executeWith: aRepositoryModel
	self repositoryModel: aRepositoryModel.
	self execute! !

!IceTipRepairAction methodsFor: 'accessing' stamp: ''!
title
	^ self class title! !

!IceTipRepairAction class methodsFor: 'accessing' stamp: ''!
help
	^ self subclassResponsibility! !

!IceTipRepairAction class methodsFor: 'accessing' stamp: ''!
order
	^ self subclassResponsibility! !

!IceTipRepairAction class methodsFor: 'accessing' stamp: ''!
allAvailableFor: aRepository
	^ ((self allSubclasses 
		select: [ :each | each isAvailableFor: aRepository ])
		sorted: [ :a :b | a order < b order ])
		collect: #new! !

!IceTipRepairAction class methodsFor: 'accessing' stamp: ''!
icon
	^ self subclassResponsibility! !

!IceTipRepairAction class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipRepairAction! !

!IceTipRepairAction class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	^ false! !

!IceTipRepairAction class methodsFor: 'accessing' stamp: ''!
title
	^ self subclassResponsibility! !

!IceTipRepairCheckoutBranch commentStamp: ''!
I will perform the chechout of an existing branch, but I will remove all changes on image. 

I'm active when: 
	- working copy is detached 
	- repository HEAD is detached!
!IceTipRepairCheckoutBranch methodsFor: 'executing' stamp: ''!
basicExecute
	self fetchAllRemotes.
	(IceTipCheckoutBranchDialog on: self repositoryModel) 
		withoutNewBranch;
		openDialogWithSpec! !

!IceTipRepairCheckoutBranch class methodsFor: 'accessing' stamp: ''!
help
	^ 'Discard all changes in your image and checkout an existing branch.
This action will checkout the branch in the repository and synchronize your image with your repository.

This situation happens because the code loaded in your image does not correspond with the status of your repository.

This action opens a preview window before doing any change.

This operation will modify the state of your working copy on disk. All non-commited changes in your disk working copy that are not in the image will be lost (this can happen if you edited the repository from outside). If you want to keep them, perform a commit from outside before.'! !

!IceTipRepairCheckoutBranch class methodsFor: 'accessing' stamp: ''!
order
	^ 30! !

!IceTipRepairCheckoutBranch class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #branch! !

!IceTipRepairCheckoutBranch class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	"matches if: 
		- workingCopy is detached
		- HEAD is detached"

	^ aRepository isMissing not
		and: [ aRepository project isUnborn or: [ aRepository workingCopy isDetached or: [ aRepository head isDetached ] ] ]! !

!IceTipRepairCheckoutBranch class methodsFor: 'accessing' stamp: ''!
title
	^ 'Checkout an existing branch discarding image changes'! !

!IceTipRepairCheckoutNewBranch commentStamp: ''!
I will perform a checkout of a new branch starting from the current reference commit. 
This way, by changing the HEAD into something that fits the image, my repository will be attached and repository will be able to perform commits and all regular operations.

I'm active when: 
	- working copy is detached 
	- repository HEAD is detached!
!IceTipRepairCheckoutNewBranch methodsFor: 'executing' stamp: ''!
basicExecute
	"Fetching remotes is necessary in case the current image commit is not in the repository.
	Could be optimized"
	self fetchAllRemotes.
	(IceTipCheckoutBranchDialog on: self repositoryModel)
		withOnlyNewBranch;
		openDialogWithSpec! !

!IceTipRepairCheckoutNewBranch class methodsFor: 'accessing' stamp: ''!
help
	^ 'It creates a new branch from the commit your image is pointing to.
This will not lose any change in the image.

This situation happens because the code loaded in your image does not correspond with the status of your repository.

This operation will modify the state of your working copy on disk. All non-commited changes in your disk working copy that are not in the image will be lost (this can happen if you edited the repository from outside). If you want to keep them, perform a commit from outside before.'! !

!IceTipRepairCheckoutNewBranch class methodsFor: 'accessing' stamp: ''!
order
	^ 10! !

!IceTipRepairCheckoutNewBranch class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #smallNew! !

!IceTipRepairCheckoutNewBranch class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	"matches if: 
		- workingCopy is detached
		- HEAD is detached"
	
	aRepository isMissing ifTrue: [ ^ false ].
	aRepository workingCopy referenceCommit isUnknownCommit ifTrue: [ ^ false ].
	aRepository workingCopy referenceCommit isNoCommit ifTrue: [ ^ false ].
	
	^ aRepository workingCopy isDetached or: [ aRepository head isDetached ]! !

!IceTipRepairCheckoutNewBranch class methodsFor: 'accessing' stamp: ''!
title
	^ 'Create a new branch pointing to your image commit'! !

!IceTipRepairCloneRepository commentStamp: ''!
I'm a repair action to clone again a repository (in case something moved).

I'm active when repository can not be located in disk.

Notice that doing this can lead you to another situation that needs repair (like a detached status)!
!IceTipRepairCloneRepository methodsFor: 'executing' stamp: ''!
basicExecute
	IceTipRegisterRepositoryDialog new 
		beForCloneOfRepository: self repositoryModel entity;
		onAccept: [ 
			Iceberg announcer announce: (IceRepositoryModified for: self repositoryModel entity) ];
		openDialogWithSpec! !

!IceTipRepairCloneRepository class methodsFor: 'accessing' stamp: ''!
help
	^ 'Clone again the repository into a new location.

This situation happens when iceberg cannot find the repository on disk.

The cloned repository will be in the commit of the remote. 
This commit may be not the same commit that your image has.
So, this action will very probably let you in a detached status.
You will need to re-synchronize your repository with another repair action.'! !

!IceTipRepairCloneRepository class methodsFor: 'accessing' stamp: ''!
order
	^ 20! !

!IceTipRepairCloneRepository class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #smallAdd! !

!IceTipRepairCloneRepository class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	"active when there is no repository directory"

	^ aRepository isMissing! !

!IceTipRepairCloneRepository class methodsFor: 'accessing' stamp: ''!
title
	^ 'Clone again this repository in a new location'! !

!IceTipRepairCommand commentStamp: ''!
Command that opens the repair window on a repository!
!IceTipRepairCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #repair! !

!IceTipRepairCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipRepairRepositoryDialog on: self repositoryModel)
		openNonModalWithSpec! !

!IceTipRepairCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ super canBeExecuted and: [ self isRepositoryOperational not ]! !

!IceTipRepairCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultToolbarItemName

	^ 'Repair'! !

!IceTipRepairCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Helps you to repair your repository when it is detached.'! !

!IceTipRepairCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Repair repository'! !

!IceTipRepairCreateSubdirectory commentStamp: ''!
I will create the missing source subdirectory.

I'm active when: 
	- src subdirectory is not found.!
!IceTipRepairCreateSubdirectory methodsFor: 'executing' stamp: ''!
basicExecute

	self repositoryModel createSourceDirectory.
	"Force the update of the packages"
	self repository workingCopy refreshProjectFromRepository.
	Iceberg announcer announce: (IceRepositoryModified for: self repository)! !

!IceTipRepairCreateSubdirectory class methodsFor: 'accessing' stamp: ''!
help
	^ 'Create a new subdirectory for the code. 

The configured source directory does not exist in the repository. 
It is possible that the directory has been deleted or never commited after creating the meta-data.

This operation will modify the state of your working copy on disk. All non-commited changes in your disk working copy that are not in the image will be lost (this can happen if you edited the repository from outside). If you want to keep them, perform a commit from outside before.'! !

!IceTipRepairCreateSubdirectory class methodsFor: 'accessing' stamp: ''!
order
	^ 17! !

!IceTipRepairCreateSubdirectory class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #smallNew! !

!IceTipRepairCreateSubdirectory class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository

	^ aRepository isMissing not and: [aRepository isCodeMissing]! !

!IceTipRepairCreateSubdirectory class methodsFor: 'accessing' stamp: ''!
title
	^ 'Create code subdirectory'! !

!IceTipRepairDiscardAndLoad commentStamp: ''!
I will discard image changes and I will restore source from current repository HEAD.

I'm active when: 
	- working copy is detached 
	- repository HEAD is NOT detached!
!IceTipRepairDiscardAndLoad methodsFor: 'executing' stamp: ''!
basicExecute
			
	(IceTipCheckoutPreviewBrowser onBranch: self repositoryModel branchModel) openWithSpec! !

!IceTipRepairDiscardAndLoad methodsFor: 'private' stamp: ''!
finishSuccess
	super finishSuccess.
	Iceberg announcer announce: (IceRepositoryModified for: self repository)! !

!IceTipRepairDiscardAndLoad class methodsFor: 'accessing' stamp: ''!
help
	^ 'Discard all changes in your image and checkout the current commit (HEAD) in the repository.

This action will synchronize your image with the code in the repository.

All the changes in the image that have not been commited will be lost.

This situation happens because loaded code in your image is from a different commit than the current commit (HEAD) in the repository.

Opens a preview window with the incoming changes before doing any change.'! !

!IceTipRepairDiscardAndLoad class methodsFor: 'accessing' stamp: ''!
order
	^ 40! !

!IceTipRepairDiscardAndLoad class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #refresh! !

!IceTipRepairDiscardAndLoad class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	"matches if: 
		- workingCopy is detached
		- HEAD is NOT detached"

	^ aRepository isMissing not  
		and: [ aRepository workingCopy isDetached 
		and: [ aRepository head isDetached not ] ]! !

!IceTipRepairDiscardAndLoad class methodsFor: 'accessing' stamp: ''!
title
	^ 'Discard image changes and load repository version'! !

!IceTipRepairEditRepository commentStamp: ''!
I will open the edit repository window.

I'm active when: 
	- src subdirectory is not found.!
!IceTipRepairEditRepository methodsFor: 'executing' stamp: ''!
basicExecute

	self repositoryModel edit! !

!IceTipRepairEditRepository class methodsFor: 'accessing' stamp: ''!
help
	^ 'You can edit the repository to inform another subdirectory name. 
Once the new subdirectory is updated, the packages in the repository are available.
This action does not affect the changes in the disk working copy nor in the image.

This happens because the source code directory has been moved or renamed.
'! !

!IceTipRepairEditRepository class methodsFor: 'accessing' stamp: ''!
order
	^ 17! !

!IceTipRepairEditRepository class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #edit! !

!IceTipRepairEditRepository class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository

	^ aRepository isMissing not and: [aRepository isCodeMissing]! !

!IceTipRepairEditRepository class methodsFor: 'accessing' stamp: ''!
title
	^ 'Edit the repository to select the correct code subdirectory'! !

!IceTipRepairFetchRemoteBranch commentStamp: ''!
I will fetch repositories to try to find the unknown commit. 

matches if: 
	- workingCopy referenceCommit isUnknownCommit
!
!IceTipRepairFetchRemoteBranch methodsFor: 'executing' stamp: ''!
basicExecute
	"Fetching remotes is necessary in case the current image commit is not in the repository.
	Could be optimized"
	self fetchAllRemotes.! !

!IceTipRepairFetchRemoteBranch methodsFor: 'executing' stamp: ''!
finishSuccess
	super finishSuccess.
	Iceberg announcer announce: (IceRepositoryModified for: self repository)! !

!IceTipRepairFetchRemoteBranch class methodsFor: 'accessing' stamp: ''!
help
	^ 'You can fetch commits from a remote to find your image commit in your repository.
This will not lose any change in the image or the repository.
It will only fetch all the commits from the remotes, without changing the current commit (HEAD) nor branch.

This situation happens because the code loaded in your image is not in the branch currently selected on your repository.

After doing the fetch, it is required to create a new branch to commit into the repository. 
A second repair action will help you.'! !

!IceTipRepairFetchRemoteBranch class methodsFor: 'accessing' stamp: ''!
order
	^ 15! !

!IceTipRepairFetchRemoteBranch class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #smallUpdate! !

!IceTipRepairFetchRemoteBranch class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	"matches if: 
		- workingCopy referenceCommit isUnknownCommit"
		
	^ aRepository isMissing not 
		and: [ aRepository workingCopy referenceCommit isUnknownCommit ]! !

!IceTipRepairFetchRemoteBranch class methodsFor: 'accessing' stamp: ''!
title
	^ 'Fetch remote commits including the commits of the image version'! !

!IceTipRepairLocateRepository commentStamp: ''!
I'm a repair action to locate the directory were a repository resides.

I'm active when repository can not be located in disk.

Notice that doing this can lead you to another situation that needs repair (like a detached status)!
!IceTipRepairLocateRepository methodsFor: 'executing' stamp: ''!
basicExecute
	| dialog |
	dialog := IceTipLocalRepositoryPanel new
		location: (self repository location ifNil: [ self defaultLocation ]);
		yourself.
	dialog openDialogWithSpec 
		okAction: [
			dialog validate.
			self repositoryModel updateLocation: dialog location.
			true ]! !

!IceTipRepairLocateRepository methodsFor: 'executing' stamp: ''!
defaultSubdirectory
	^ IceLibgitRepository defaultCodeSubdirectory! !

!IceTipRepairLocateRepository methodsFor: 'private' stamp: ''!
defaultLocation
	^ IceLibgitRepository repositoriesLocation! !

!IceTipRepairLocateRepository class methodsFor: 'accessing' stamp: ''!
help
	^ 'Locate this repository in your file system.

This situation happens when iceberg cannot find the repository in disk.

This action will very probably let you in a detached status, because this only changes the location of the repository, but it does not affect the current commit (HEAD) or the current branch.
You will need to re-synchronize your repository with another repair action.

This happens if the repository has been removed from the disk or the image was pointing to a repository in another machine (For example, when sharing images with other machines / people).'! !

!IceTipRepairLocateRepository class methodsFor: 'accessing' stamp: ''!
order
	^ 10! !

!IceTipRepairLocateRepository class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #glamorousFolder! !

!IceTipRepairLocateRepository class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	"active when there is no repository directory"
	
	^ aRepository isMissing! !

!IceTipRepairLocateRepository class methodsFor: 'accessing' stamp: ''!
title
	^ 'Locate this repository in your file system'! !

!IceTipRepairMergeWithBranch commentStamp: ''!
I will perform a switch and merge of current reference commit with the selected branch. 

I'm active when: 
	- working copy is detached 
	- repository HEAD is NOT detached!
!IceTipRepairMergeWithBranch methodsFor: 'executing' stamp: ''!
basicExecute
	self fetchAllRemotes.
	(IceTipMergeBranchDialog on: self repositoryModel) 
		beSwitchAndMerge;
		openDialogWithSpec! !

!IceTipRepairMergeWithBranch class methodsFor: 'accessing' stamp: ''!
help
	^ 'This action checkouts an existing branch and loads the code in your image without discarding any change.
This will not lose any change in the image but may lead to conflicts. If there are conflicts it opens a merge view.

This situation happens because loaded code in your image is from a different commit than the current commit (HEAD) in the repository.

This operation will modify the state of your working copy in disk, the checkouted branch will replace the disk working copy. All non-commited changes in your disk working copy will be lost. If you want to keep them, perform a commit from outside before.'! !

!IceTipRepairMergeWithBranch class methodsFor: 'accessing' stamp: ''!
order
	^ 20! !

!IceTipRepairMergeWithBranch class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #merge! !

!IceTipRepairMergeWithBranch class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	"matches if: 
		- workingCopy is detached
		- HEAD is NOT detached"
		
	aRepository isMissing ifTrue: [ ^ false ].
	aRepository workingCopy referenceCommit isUnknownCommit ifTrue: [ ^ false ].
	aRepository workingCopy referenceCommit isNoCommit ifTrue: [ ^ false ].
		
	^ aRepository workingCopy isDetached and: [ aRepository head isDetached not ]! !

!IceTipRepairMergeWithBranch class methodsFor: 'accessing' stamp: ''!
title
	^ 'Checkout an existing branch and merge the changes into the image (without discarding image changes)'! !

!IceTipRepairProject commentStamp: ''!
I'm an action to repair a project, which is useful when it answers true to #isUnborn.!
!IceTipRepairProject methodsFor: 'executing' stamp: ''!
basicExecute
	(IceTipEditProjectDialog on: (IceBasicProject onRepository: self repositoryModel entity)) 
		openNonModalWithSpec! !

!IceTipRepairProject class methodsFor: 'accessing' stamp: ''!
help
	^ 'Edit the repository to add project meta-data.
This action will create a .project file in the root of your repository adding meta information such as source code directory, project name, format and so on.

This situation happens because your project does not have project meta-data and Iceberg does not know how to correctly interpret its data.'! !

!IceTipRepairProject class methodsFor: 'accessing' stamp: ''!
order
	^ 30! !

!IceTipRepairProject class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #config! !

!IceTipRepairProject class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	"matches if: 
		- workingCopy is atached
		- workingCopy project isUnborn"
	
	^ aRepository isMissing not  
		and: [  aRepository workingCopy isDetached not
			and: [ aRepository head isDetached not
				and: [ aRepository workingCopy project isUnborn ] ] ]! !

!IceTipRepairProject class methodsFor: 'accessing' stamp: ''!
title
	^ 'Create project meta-data'! !

!IceTipRepairPullRemoteBranch commentStamp: ''!
I will perform a pull from a remote, to bring put repository in sync.

matches if: 
	- workingCopy is detached AND there is no commit in the current available commits!
!IceTipRepairPullRemoteBranch methodsFor: 'executing' stamp: ''!
basicExecute
	"Fetching remotes is necessary in case the current image commit is not in the repository.
	Could be optimized"
	self fetchAllRemotes.
	(IceTipPullBrowser onRepositoryModel: self repositoryModel) openWithSpec! !

!IceTipRepairPullRemoteBranch class methodsFor: 'accessing' stamp: ''!
help
	^ 'You can pull commits from a remote to put your image and your repository in sync.
This will not lose any change in the image.

This situation happens because the code loaded in your image is not in the branch currently selected on your repository.

This operation will modify the state of your working copy in disk. All non-commited changes in your disk working copy that are not in the image will be lost. If you want to keep them, perform a commit from outside before.'! !

!IceTipRepairPullRemoteBranch class methodsFor: 'accessing' stamp: ''!
order
	^ 17! !

!IceTipRepairPullRemoteBranch class methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #down! !

!IceTipRepairPullRemoteBranch class methodsFor: 'testing' stamp: ''!
isAvailableFor: aRepository
	"matches if: 
		- workingCopy is detached AND there is no commit in the current available commits"

	aRepository isMissing ifTrue: [ ^ false ].
	aRepository workingCopy referenceCommit isUnknownCommit ifTrue: [ ^ false ].
	aRepository workingCopy referenceCommit isNoCommit ifTrue: [ ^ false ].

	^ aRepository workingCopy isDetached and: [ (aRepository includesCommit: aRepository workingCopy referenceCommit) not ]! !

!IceTipRepairPullRemoteBranch class methodsFor: 'accessing' stamp: ''!
title
	^ 'Pull remote commits to put your repository in sync'! !

!IceTipRepairRepositoryDialog methodsFor: 'accessing - ui' stamp: ''!
reasonPanel

	^ reasonPanel! !

!IceTipRepairRepositoryDialog methodsFor: 'initialization' stamp: ''!
initializeOptionsList

	optionsList
		hideColumnHeaders;
		addColumn: (SpCompositeTableColumn new
			addColumn: (SpImageTableColumn new
				width: 20;
				evaluated: #icon;
				yourself);
			addColumn: (SpStringTableColumn new
				evaluated: #title;
				yourself);
			yourself);
		items: self model availableRepairOptions;
		whenSelectionChangedDo: [ :selection | self selectionChanged: selection selectedItem ];
		whenActivatedDo: [ :selection | selection ifNotNil: [ self accept ] ]! !

!IceTipRepairRepositoryDialog methodsFor: 'accessing - ui' stamp: ''!
optionsList

	^ optionsList! !

!IceTipRepairRepositoryDialog methodsFor: 'initialization' stamp: ''!
refreshDialogButtons

	self window ifNotNil: [ :aWindow |
		aWindow buttons first enabled: (selectedOption isNotNil) ]! !

!IceTipRepairRepositoryDialog methodsFor: 'private' stamp: ''!
selectionChanged: selectedItem

	selectedOption := selectedItem.
	self refreshDetailPanel.
	self refreshDialogButtons.	
! !

!IceTipRepairRepositoryDialog methodsFor: 'private' stamp: ''!
refreshDetailPanel

	selectedOption ifNotNil: [ 
		detailPanel
			text: selectedOption help;
			yourself ]! !

!IceTipRepairRepositoryDialog methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Repair repository'! !

!IceTipRepairRepositoryDialog methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aWindow

	super initializeDialogWindow: aWindow.

	self refreshDialogButtons.	
	
	aWindow 
		bindKeyCombination: Character cr asShortcut toAction: [ 
			selectedOption ifNotNil: [self accept] ]

! !

!IceTipRepairRepositoryDialog methodsFor: 'accessing - ui' stamp: ''!
detailPanel

	^ detailPanel! !

!IceTipRepairRepositoryDialog methodsFor: 'actions' stamp: ''!
accept

	self closeWindow.
	selectedOption executeWith: self model! !

!IceTipRepairRepositoryDialog methodsFor: 'private' stamp: ''!
initializeReasonPanel

	reasonPanel text: self model longStatus! !

!IceTipRepairRepositoryDialog methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipRepairRepositoryDialog methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (700 @ 500) scaledByDisplayScaleFactor! !

!IceTipRepairRepositoryDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	
	reasonPanel := self newText
		beNotEditable;
		addStyle: 'iceTipReadonly';
		beWrapWord;
		yourself.
	optionsList := self newTable
		disable;
		yourself.
	detailPanel := self newText
		beNotEditable;
		beWrapWord;
		addStyle: 'iceTipReadonly';
		yourself.

	self initializeReasonPanel.
	self initializeOptionsList.
! !

!IceTipRepairRepositoryDialog methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipRepairRepositoryDialog class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository

	^ self on: (IceTipRepositoryModel on: aRepository) beCached! !

!IceTipRepairRepositoryDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: #reasonPanel 
		withConstraints: [ :constraints |
			constraints 
				height: 70 * self currentWorld displayScaleFactor;
				padding: 2 ];
		add: #optionsList
		withConstraints: [ :constraints |
			constraints 
				height: 100 * self currentWorld displayScaleFactor;
				padding: 2 ];
		add: #detailPanel
		withConstraints: [ :constraints |
			constraints padding: 2 ];
		yourself! !

!IceTipRepositoriesBrowser commentStamp: ''!
I'm a tool to show all repositories registered on this image. 
I define basic actions and an entry point to manage each repository individually.

IceTipRepositoriesBrowser new openWithSpec.!
!IceTipRepositoriesBrowser methodsFor: 'accessing' stamp: ''!
repositoryModel
	
	^ self selectedItem! !

!IceTipRepositoriesBrowser methodsFor: 'testing' stamp: ''!
isShowingRepository: anIceLibgitRepository

	^ self repositoryModels anySatisfy: [ :aRepositoryModel | 
		  aRepositoryModel entity = anIceLibgitRepository ]! !

!IceTipRepositoriesBrowser methodsFor: 'initialization' stamp: ''!
initializeRepositoryList

	repositoryList
		showColumnHeaders;
		beResizable;
		addColumn:
			((SpStringTableColumn evaluated: #descriptionWithDecoration)
				width: 200;
				title: self titleForWindow;
				yourself);
		addColumn:
			((SpStringTableColumn evaluated: #statusText)
				width: 150;
				title: #Status;
				yourself);
		addColumn:
			((SpStringTableColumn evaluated: #branchNameText)
				title: #Branch;
				yourself);
		activateOnDoubleClick;
		whenActivatedDo: [ self openManagePackagesWindow ]! !

!IceTipRepositoriesBrowser methodsFor: 'private' stamp: ''!
refresh

	repositoryList items: self model repositories! !

!IceTipRepositoriesBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Repositories'! !

!IceTipRepositoriesBrowser methodsFor: 'accessing' stamp: ''!
repositoryList

	^ repositoryList! !

!IceTipRepositoriesBrowser methodsFor: 'private' stamp: ''!
openManagePackagesWindow

	IceTipManagePackagesCommand new
		context: self;
		execute! !

!IceTipRepositoriesBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	repositoryList := self newTable.
	self initializeRepositoryList.

	self refresh.! !

!IceTipRepositoriesBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList

	^ repositoryList! !

!IceTipRepositoriesBrowser methodsFor: 'initialization' stamp: ''!
iconForWindow

	^ self class iconForWorldMenu! !

!IceTipRepositoriesBrowser methodsFor: 'accessing' stamp: ''!
repositoryModels
	"Return the currently shown repository models"

	^ repositoryList items
! !

!IceTipRepositoriesBrowser methodsFor: 'initialization' stamp: ''!
subscribeToAnnouncements

	Iceberg announcer weak when: IceAnnouncement send: #refresh to: self! !

!IceTipRepositoriesBrowser class methodsFor: 'instance creation' stamp: ''!
new
	
	^ self newOnRepositoryProvider: IceRepository! !

!IceTipRepositoriesBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	{
		IceTipRepairCommand.
		IceTipManagePackagesCommand.
		IceTipCommitCommand.
		IceTipPullCommand.
		IceTipPushCommand.
		IceTipFetchCommand.
		IceTipCheckoutBranchCommand.
	 	IceTipCreateTagCommand.
		IceTipMergeCommand.
		IceTipManageRepositoryCommand.
		IceTipEditRepositoryCommand.
		IceTipForgetRepositoryCommand.
		} do: [ :each |
			aCommandGroup register: each forSpec ]
! !

!IceTipRepositoriesBrowser class methodsFor: '*Iceberg-Plugin-Metacello' stamp: ''!
metacelloCommandsWith: presenter forRootGroup: aCommandGroup

	<extensionCommands>
	| newGroup |
	newGroup := CmCommandGroup forSpec
		name: 'Metacello';
		description: 'Metacello install operations';
		yourself.
	
	(aCommandGroup commandOrGroupNamed: 'Selection') register: newGroup.

	presenter selectedItem ifNotNil: [ 
		IceTipMetacelloInstallCommandBuilder new
			addCommandsFor: presenter selectedItem intoGroup: newGroup ]	
! !

!IceTipRepositoriesBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #repositoryList;
		  yourself! !

!IceTipRepositoriesBrowser class methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
githubRemoteCommands: anIceRemoteModel forRootGroup: aCommandGroup

	| thisRemoteGroup |
	thisRemoteGroup := CmCommandGroup forSpec
		name: anIceRemoteModel name;
		yourself.
	aCommandGroup register: thisRemoteGroup.

	"Note: The following commands use the remote model as a context, while the default
	context is the presenter."
	{ 	IceGitHubViewPullRequestsCommand.
		IceGitHubNewPullRequestCommand.
		IceGitHubOpenOnGithubCommand.
		IceGitHubRemoveBranchesCommand }
			do: [ :each | 
				thisRemoteGroup register: (each forSpecContext: anIceRemoteModel) ]
! !

!IceTipRepositoriesBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionExtraCommandGroupWith: presenter for: aCommandGroup

	super buildSelectionExtraCommandGroupWith: presenter for: aCommandGroup.

	{	IceTipCalculateDirtyPackagesCommand.
		IceTipCopyCommitishCommand.
		IceTipOpenNativelyCommand.
		} do: [ :each |
			aCommandGroup register: each forSpec ]
! !

!IceTipRepositoriesBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	{ 	IceTipFetchAllProjectCommand.
		IceTipAddRepositoryCommand.
		IceTipSettingsCommand
		} do: [ :each | 
			aCommandGroup register: each forSpec ]
! !

!IceTipRepositoriesBrowser class methodsFor: 'instance creation' stamp: ''!
newOnRepositoryProvider: aProvider 

	^ self basicNew
		model: (IceTipRepositoriesModel new repositoryProvider: aProvider; yourself);
		initialize;
		yourself! !

!IceTipRepositoriesBrowser class methodsFor: 'accessing' stamp: ''!
iconForWorldMenu

	^ self iconNamed: #komitterSmalltalkhubRemote! !

!IceTipRepositoriesBrowser class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder 
	"Add a custom menu item to the world menu"	
	<worldMenu> 
	
	(aBuilder item: #'Iceberg')
		order: 1;
		icon: self iconForWorldMenu;
		parent: #'Versioning';
		keyText: 'o, i';
		help: 'Iceberg is a set of tools that allow one to handle git repositories directly from a Pharo image.';
		action: [ self new openWithSpec ]! !

!IceTipRepositoriesBrowser class methodsFor: '*Calypso-SystemPlugins-Monticello-Browser' stamp: ''!
calypsoCommandsWith: presenter forRootGroup: aCommandGroup
	<extensionCommands>

	aCommandGroup / self selectionCommandGroupName register:
		ClyBrowseIcebergRepositoryCommand forSpec! !

!IceTipRepositoriesBrowser class methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
githubCommandsWith: presenter forRootGroup: aCommandGroup

	<extensionCommands>

	| pluginGroup remotesGroup |
	pluginGroup := CmCommandGroup forSpec
		name: 'Github';
		description: 'Github operations';
		iconName: #github;
		yourself.
		
	remotesGroup := CmCommandGroup forSpec
		name: 'Remotes';
		yourself.

	{ IceGitHubNewBranchFromIssueCommand.
	  IceFiletreeToTonelCommand }
			do: [ :each | pluginGroup register: each forSpec ].

	(aCommandGroup / self selectionCommandGroupName) 
		register: pluginGroup. 


	(presenter hasSelectedItem and: [
		presenter selectedItem hasRemotes ]) ifTrue: [
			presenter selectedItem remoteModels do: [ :each |
				self
					githubRemoteCommands: each
					forRootGroup: remotesGroup ] ].
	pluginGroup register: remotesGroup.
! !

!IceTipRepositoriesModel commentStamp: ''!
I'm a model to provide access to all repositories registered.!
!IceTipRepositoriesModel methodsFor: 'accessing' stamp: ''!
repositoryProvider: aProvider

	repositoryProvider := aProvider! !

!IceTipRepositoriesModel methodsFor: 'accessing' stamp: ''!
repositories
	
	^ repositoryProvider repositories collect: [ :each | (IceTipRepositoryModel on: each) beCached ]! !

!IceTipRepositoryBrowser commentStamp: ''!
I'm a browser to show the internals of a repository. 
I will show remotes, branches, tags and all possible operations in low level repository (pull, push,  branch. But all edit remotes, etc.)!
!IceTipRepositoryBrowser methodsFor: 'accessing' stamp: ''!
refresh

	self refreshCommands.
	self sidebarTree selection unselectAll.
	self sidebarTree roots: self model repositoryModelsByGroup.
	self selectCurrentBranch! !

!IceTipRepositoryBrowser methodsFor: 'event handling' stamp: ''!
commitishSelected: ann

	historyPanel model: ann! !

!IceTipRepositoryBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Repository of ' , self model name! !

!IceTipRepositoryBrowser methodsFor: 'initialization' stamp: ''!
initializeSidebarTree

	sidebarTree
		hideColumnHeaders;
		addColumn:
			(SpCompositeTableColumn new
				addColumn:
					(SpImageTableColumn new
						width: 20;
						evaluated: #icon;
						yourself);
				addColumn:
					(SpStringTableColumn new
						evaluated: #name;
						yourself);
				yourself);
		children: [ :each | each children ];
		whenSelectionChangedDo: [ :selection | 
			(selection isEmpty not and: [ selection selectedItem isCommitish ])
				ifTrue: [ self commitishSelected: selection selectedItem ] ].
! !

!IceTipRepositoryBrowser methodsFor: 'private - factory' stamp: ''!
refreshWhenRepository: ann

	(self model isModelOf: ann repository) ifFalse: [ ^ self ].
	self model reset.
	self refresh! !

!IceTipRepositoryBrowser methodsFor: 'accessing - ui' stamp: ''!
sidebarTree

	^ sidebarTree! !

!IceTipRepositoryBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (1000 @ 700) scaledByDisplayScaleFactor! !

!IceTipRepositoryBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	sidebarTree := self newTreeTable.
	historyPanel := self
		instantiate: IceTipHiedraHistoryBrowser
		on: self model headModel.

	historyPanel whenSelectionChangedDo: [ self refreshCommands ].
	historyPanel beForMerge.

	self initializeSidebarTree.

	self refresh.
! !

!IceTipRepositoryBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList
	"Answer the presenter that is the main list of items of this browser."

	^ sidebarTree! !

!IceTipRepositoryBrowser methodsFor: 'initialization' stamp: ''!
selectCurrentBranch

	| branch |
	branch := self model headModel entity.
	
	branch isBranch ifFalse: [ ^ self ].
	
	"We know that the current branch is a local one, so we build the path from 1 (for local branch) and the index of the current branch."
	sidebarTree selection selectPath: { 1. self model branches indexOf: branch}
! !

!IceTipRepositoryBrowser methodsFor: 'accessing - ui' stamp: ''!
historyPanel

	^ historyPanel! !

!IceTipRepositoryBrowser methodsFor: 'private - factory' stamp: ''!
subscribeToAnnouncements

    Iceberg announcer weak 
        when: IceRepositoryAnnouncement 
        send: #refreshWhenRepository: 
        to: self! !

!IceTipRepositoryBrowser class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #onRepository:'! !

!IceTipRepositoryBrowser class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository

	^ self on: (IceTipRepositoryModel on: aRepository)! !

!IceTipRepositoryBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	| aGroup |
	{
		IceTipFetchRemoteCommand.
		IceTipCheckoutSelectedBranchCommand.
		IceTipDeleteBranchCommand.
		IceTipDeleteTagCommand.
		IceTipCheckoutSelectedTagCommand.
		IceTipDeleteRemoteCommand
		}  do: [ :each |
			aCommandGroup register: each forSpec ].
	
	aGroup := (CmCommandGroup named: 'GitHub' ) asSpecGroup
		icon: (self iconNamed: #github);
		description: 'Extended Operations when the Remote is in Github'.
		
	
	aCommandGroup register: aGroup.

	IceGitHubTreeCommand allSubclasses do: [ :each |
		aGroup register: each forSpec ]
! !

!IceTipRepositoryBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newLeftToRight
		  positionOfSlider: 30 percent;
		  add: #sidebarTree;
		  add: #historyPanel withConstraints: [ :c | c spec: #panelSpec ];
		  yourself! !

!IceTipRepositoryBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	{	IceTipAddRemoteCommand.
		IceTipPushCommand.
		IceTipPullCommand.
		IceTipFetchCommand.
		IceTipCheckoutBranchCommand.
		IceTipMergeCommand } do: [ :each | 
			aCommandGroup register: each forSpec ]! !

!IceTipRepositoryCommand commentStamp: ''!
I'm a the abstract superclass of commands that act on repositories.!
!IceTipRepositoryCommand methodsFor: 'testing' stamp: ''!
actsOnBranch: aBranchModel

	^ false! !

!IceTipRepositoryCommand methodsFor: 'testing' stamp: ''!
actsOnRemote: aRemoteModel

	^ false! !

!IceTipRepositoryCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self repositoryModel isNotNil! !

!IceTipRepositoryCommand methodsFor: 'accessing' stamp: ''!
announcer

	^ self context toolAnnouncer! !

!IceTipRepositoryCommand methodsFor: 'testing' stamp: ''!
actsOnTag: aTagModel

	^ false! !

!IceTipRepositoryCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTipRepositoryCommand! !

!IceTipRepositoryModel commentStamp: ''!
I'm a model for IceRepository entries.!
!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
repositoryModel
	^ self! !

!IceTipRepositoryModel methodsFor: 'testing' stamp: ''!
isCodeMissing
	^ entity isCodeMissing! !

!IceTipRepositoryModel methodsFor: 'testing' stamp: ''!
hasBranches 
	^ self branches isNotEmpty! !

!IceTipRepositoryModel methodsFor: 'actions' stamp: ''!
addRemoteNamed: aName url: anUrl
	
	IceTipStandardAction new 
		repository: self entity;
		message: 'Adding remote';
		onSuccessRepositoryModified;
		execute: [ | remote |
			remote := IceGitRemote name: aName url: anUrl.
			self entity addRemote: remote.
			remote fetch ]! !

!IceTipRepositoryModel methodsFor: 'testing' stamp: ''!
hasUnbornProject
	^ self entity workingCopy project isUnborn! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
location
	
	^ entity location! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
availableRepairOptions
	<noCache>
	
	^ IceTipRepairAction allAvailableFor: self entity! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	| text |
	
	text := self displayString asText.
	self entity isModified 
		ifTrue: [ text := ('*', text) asText makeAllColor: self colorModified ].
	^ text! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
remotes
	
	^ entity remotes! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
branches
	^ self entity localBranches! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
longStatus

	(entity isMissing and: [ entity location isNil ])
		ifTrue: [ ^ 'Iceberg does not find a git repository. Please clone the repository or change the repository location to an existing Git repository' ].

	entity isMissing 
		ifTrue: [ ^ 'Iceberg does not find a git repository at {1}. Please clone the repository again or change the repository location to an existing Git repository' format: { entity location } ].
				
	entity workingCopy workingCopyState isUnknownCommitState 
		ifTrue: [ ^ 'This image has a loaded version of the code from commit {1}, but Iceberg does not find the commit in your local Git repository. You may fetch the correct commit from a remote repository or discard the code of your image and load the version that is in the repository.' format: { entity workingCopy referenceCommit shortId } ].
			
	entity workingCopy isDetached 
		ifTrue: [ ^ 'The loaded code in the image starts from commit {1}. This commit does not correspond with the commit in the head of the current branch of the repository (Commit {2}). You need to synchronize them to continue. You need to discard your image changes or change the HEAD of the repository to point to the commit.' format: { entity workingCopy referenceCommit shortId. entity headCommit shortId } ].

	entity head isDetached 
		ifTrue: [ ^ 'The repository and the image are in the same commit {1}. However, the commit is not in an active branch. It is not possible to commit in a Git detached HEAD state. Create a new branch (by checkouting) or checkout an existing one.' format: { entity headCommit shortId } ].

	entity workingCopy project isUnborn
		ifTrue: [ ^ 'Cannot find a project (meta-data and source directory) in your repository. Please edit your repository meta-data to indicate the source code directory or change the location to a valid iceberg repository' ].

	^ 'Your repository seems ok. Please report a ticket in Iceberg''s issue tracker. If you can, please send us a backup of your image in this state for debugging.'! !

!IceTipRepositoryModel methodsFor: 'private - testing' stamp: ''!
isLoaded
	^ self entity loadedPackages notEmpty ! !

!IceTipRepositoryModel methodsFor: 'actions' stamp: ''!
discardChanges
	<noCache>
	
	IceTipStandardAction new 
		repository: self entity;
		message: 'Discarding changes';
		onSuccessRepositoryModified;
		execute: [ 
			Iceberg announcer suspendAllWhile: [ 
				self entity discardChanges ] ]! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
commitId
	^ [ self entity headCommit id ] on: Error do: [ nil ].! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
repositoryModelsByGroup
	| branches tags |
	branches := self allBranchModels.
	tags := self tagModels.
	^ { 
	"Branches group"
	(IceTipTreeRepositoryGroup on: self)
		name: 'Branches';
		icon: (self iconNamed: #branch);
		children: (branches
			select: [ :each | each entity isLocal ]
			thenCollect: [ :each | IceTipTreeBranch on: each ]);
		yourself.
	"Remotes group"
	(IceTipTreeRepositoryGroup on: self)
		name: 'Remotes';
		icon: (self iconNamed: #remote);
		children: (self entity remotes collect: [ :eachRemote | | remoteModel |
			remoteModel := (IceTipRemoteModel repositoryModel: self on: eachRemote) beCached.
			(IceTipTreeRemote on: remoteModel)
				name: remoteModel name;
				children: (branches 
					select: [ :each | 
						each entity isRemote 
						and: [ each entity remoteName = eachRemote name ] ]
					thenCollect: [ :each | IceTipTreeBranch on: each ]);
				yourself	]);
		yourself.
	"Tags group"
	(IceTipTreeRepositoryGroup on: self)
		name: 'Tags';
		icon: (self iconNamed: #glamorousBookmark);
		children: (tags collect: [ :each | IceTipTreeTag on: each ]);
		yourself.
	}! !

!IceTipRepositoryModel methodsFor: 'actions' stamp: ''!
checkoutNewBranchNamed: aString inCommit: aCommit thenDo: aBlock
	<noCache>

	IceTipStandardAction new 
		repository: self entity;
		message: ('Checking out new branch {1}' format: { aString });
		onSuccessRepositoryModified;
		execute: [ | branch |
			branch := self entity createBranch: aString inCommit: aCommit.
			aBlock value: branch ]! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
workingCopyDiff
	<noCache>

	^ IceTipWorkingCopyDiffModel repositoryModel: self on: self entity! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
shortCommitId
	^ [self entity headCommit shortId] on: Error do: [ nil ].! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
status
	[
		| status incoming outgoing | 

		self verifyDirectoryStructureIfMissing: [ :message | ^ message ].
		
		entity workingCopy workingCopyState isUnknownCommitState 
			ifTrue: [ ^ self toErrorMessage: entity workingCopy workingCopyState description ].	
		entity workingCopy isDetached 
			ifTrue: [  ^ self toErrorMessage: 'Detached Working Copy' ].
		(entity head isDetached and: [ entity head tags notEmpty ])
			ifTrue: [ ^ self toWarningMessage: 'Detached HEAD' ].
		entity head isDetached 
			ifTrue: [ ^ self toErrorMessage: 'Detached HEAD' ].

		entity workingCopy project isUnborn
			ifTrue: [ ^ self toErrorMessage: 'No Project Found' ].

		self isLoaded ifFalse: [ ^ 'Not loaded' ].

		status := OrderedCollection new.
		entity isModified ifTrue: [ status add: 'Uncommited changes' ].
		
		incoming := self incomingCommits size.
		incoming > 0 ifTrue: [ status add: ('{1} incoming' format: { incoming })].
		
		outgoing := self outgoingCommits size.
		outgoing > 0 ifTrue: [ status add: ('{1} not published' format: { outgoing })].

		status ifEmpty: [ status add: 'Up to date' ].
		
		^ ', ' join: status
	] 
	on: Error do: [ :error | ^ self toErrorMessage: error description ]
! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
commit
	
	^ self entity workingCopy referenceCommit! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
allBranchModels
	^ self entity allBranches 
		collect: [ :each | 
			(IceTipBranchModel 
				repositoryModel: self 
				on: each) 
				beCached ]! !

!IceTipRepositoryModel methodsFor: 'testing' stamp: ''!
isMissing
	^ self entity isMissing! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
pushRemoteName

	^ self entity branch upstream name! !

!IceTipRepositoryModel methodsFor: 'testing' stamp: ''!
hasRemotes
	^ self entity remotes notEmpty! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
outgoingCommits
	^ self entity outgoingCommits! !

!IceTipRepositoryModel methodsFor: 'actions' stamp: ''!
forget
	<noCache>
	
	IceTipStandardAction new
		repository: self entity;
		message: ('Forgeting {1}' format: {self name});
		execute: [ self entity forget ]! !

!IceTipRepositoryModel methodsFor: 'actions' stamp: ''!
delete
	<noCache>
	
	IceTipStandardAction new
		repository: self entity;
		message: ('Deleting {1}' format: {self name});
		execute: [ self entity delete ]! !

!IceTipRepositoryModel methodsFor: 'operations' stamp: ''!
createSourceDirectory
	<noCache>
	entity createSourceDirectory! !

!IceTipRepositoryModel methodsFor: 'copying' stamp: ''!
copyToClipboardId: id
	Clipboard clipboardText: id informing: ('Commitish ID copied to clipboard ({1})' format: {id})! !

!IceTipRepositoryModel methodsFor: 'checking' stamp: ''!
checkMissing
	
	self isMissing ifTrue: [ 
		IceError signal: ('You have no repository attached to project "{1}"' format: { self name }) ]! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
remoteModels
	^ self entity remotes collect: [ :each |
		(IceTipRemoteModel repositoryModel: self on: each) beCached ]! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
tagModels
	
	^ self entity tags 
		collect: [ :each | 
			(IceTipTagModel 
				repositoryModel: self 
				on: each) 
				beCached ]! !

!IceTipRepositoryModel methodsFor: 'private' stamp: ''!
localRepositoryMissingText

	^ self toErrorMessage: 'Local repository missing'! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
incomingCommits
	^ self entity incomingCommits! !

!IceTipRepositoryModel methodsFor: 'testing' stamp: ''!
matches: aString
	^ self entity name matchesRegexIgnoringCase: aString! !

!IceTipRepositoryModel methodsFor: 'actions' stamp: ''!
edit
	<noCache>
	
	(IceTipEditProjectDialog on: self entity project) openNonModalWithSpec ! !

!IceTipRepositoryModel methodsFor: 'private' stamp: ''!
verifyDirectoryStructureIfMissing: aBlock
	self entity isMissing ifTrue: [ ^ aBlock value: self localRepositoryMissingText ]! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
headModel
	
	| head |
	head := self entity head.
	^ head isBranch
		ifTrue: [ self branchModelFor: head ]
		ifFalse: [ self commitModelFor: head ]! !

!IceTipRepositoryModel methodsFor: 'actions' stamp: ''!
fetch
	<noCache>
	
	IceTipStandardAction new 
		repository: self entity;
		message: ('Fetching incoming commits of {1}' format: { self name });
		onSuccessRepositoryModified;
		execute: [ self entity fetch ]! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
branchModel
	^ (IceTipBranchModel 
		repositoryModel: self 
		on: self entity branch)
		beCached! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
packages
	^ self entity workingCopy packages! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
numberOfOutgoingCommits
	^ [ | size |
		self entity branch hasUpstream ifFalse: [ ^ '*' ].
		size := self outgoingCommits size.
		size > 100
			ifTrue: [ '99+' ]
			ifFalse: [ size asString ] ]
		on: IceNotInBranch do: [ :e | '0' ]! !

!IceTipRepositoryModel methodsFor: 'testing' stamp: ''!
isDetached
	^ self entity workingCopy isDetached 
		or: [ self entity head isDetached ]! !

!IceTipRepositoryModel methodsFor: 'actions' stamp: ''!
addPackages: aCollection

	IceTipStandardAction new 
		repository: self entity;
		message: 'Adding packages';
		onSuccessRepositoryModified;
		execute: [ 
			aCollection do: [ :each | 
				self entity workingCopy addPackageNamed: each name ] ]! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
numberOfIncomingCommits
	^ self incomingCommits size! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
info 
	^ { 
		'Branch' -> self entity branch name.
		'Location' -> self entity location pathString.
		'Upstream' -> self entity upstream asString.
	  }! !

!IceTipRepositoryModel methodsFor: 'actions' stamp: ''!
updateLocation: aReference
	
	"change location"
	self entity location: aReference.
	self entity postFetch.

	Iceberg announcer announce: (IceRepositoryModified for: self entity)! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
workingCopy
	
	^ IceTipWorkingCopyModel on: self! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
branchNameText
	
	^ self branchName asText! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
statusText
	
	^ self status asText! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
subdirectory

	^ self entity subdirectory! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
defaultBranchSelection
	^ self branchModels
		detect: #isHead
		ifNone: [ self hasBranches
				ifTrue: [ self branchModels ifNotEmpty: #anyOne ] ]! !

!IceTipRepositoryModel methodsFor: 'branches' stamp: ''!
branchModels
	^ self branches collect: [ :each | (IceTipBranchModel repositoryModel: self repositoryModel on: each) beCached ]! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
branchName
	self entity isMissing ifTrue: [ ^ self class unknownBranchLabel ].
	
	^ self entity head description.! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
commitModelFor: aCommit
	^ (IceTipCommitModel 
		repositoryModel: self 
		on: aCommit)
		beCached! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
name
	^ self entity name! !

!IceTipRepositoryModel methodsFor: 'copying' stamp: ''!
copyCommitIDToClipboard
	<noCache>
	self copyToClipboardId: self commitId! !

!IceTipRepositoryModel methodsFor: 'actions' stamp: ''!
commit: aCommitIssue then: aBlock

	aCommitIssue 
		repository: self entity;
		onSuccess: aBlock;
		execute! !

!IceTipRepositoryModel methodsFor: 'accessing' stamp: ''!
branchModelFor: aBranch
	^ (IceTipBranchModel 
		repositoryModel: self 
		on: aBranch)
		beCached! !

!IceTipRepositoryModel class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!IceTipRepositoryModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!IceTipRepositoryModel class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!IceTipRepositoryModel class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!IceTipRepositoryModel class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!IceTipRepositoryModel class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!IceTipRepositoryModel class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!IceTipRepositoryModel class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!IceTipRepositoryModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceTipRepositoryModel class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!IceTipRepositoryModel class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!IceTipRepositoryModel class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!IceTipRepositoryModel class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!IceTipRepositoryModel class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!IceTipRepositoryModel class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!IceTipRepositoryModel class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!IceTipRepositoryModel class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!IceTipRepositoryModel class methodsFor: 'accessing' stamp: ''!
unknownBranchLabel
	^ 'Unknown'! !

!IceTipRepositoryModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IceTipRepositoryModel class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!IceTipRepositoryModel class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!IceTipRepositoryModel class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!IceTipRepositoryModel class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!IceTipRepositoryModel class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!IceTipRepositoryModel class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!IceTipRepositoryModel class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!IceTipRepositoryModel class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!IceTipRepositoryModel class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!IceTipRepositoryModel class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!IceTipRepositoryModel class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!IceTipRepositoryTypePanel commentStamp: ''!
I'm a generic repository type panel. 
I'm used as part of the creation dialog and to edit repository properties.!
!IceTipRepositoryTypePanel methodsFor: 'accessing' stamp: ''!
repository: aRepository
	"Used if editing an existing repository"

	repository := aRepository! !

!IceTipRepositoryTypePanel methodsFor: 'accessing - ui' stamp: ''!
remoteInputText

	^ remoteInputText! !

!IceTipRepositoryTypePanel methodsFor: 'accessing - ui' stamp: ''!
remoteLabel

	^ remoteLabel! !

!IceTipRepositoryTypePanel methodsFor: 'initialization' stamp: ''!
initializeProjectLocation

	projectLocation := self instantiate: IceTipDirectoryPresenter.
	projectLocation
		label: 'Local directory';
		chooseTitle: 'Choose local repository';
		location: self defaultLocation! !

!IceTipRepositoryTypePanel methodsFor: 'accessing' stamp: ''!
validate

	^ self subclassResponsibility! !

!IceTipRepositoryTypePanel methodsFor: 'testing' stamp: ''!
isLocalRepository

	^ false! !

!IceTipRepositoryTypePanel methodsFor: 'initialization' stamp: ''!
defaultSubdirectory

	^ IceLibgitRepository defaultCodeSubdirectory! !

!IceTipRepositoryTypePanel methodsFor: 'initialization' stamp: ''!
initializeRemoteURL

	remoteLabel := self newLabel label: 'Remote URL'; yourself.
	remoteInputText := self newTextInput
		placeholder: 'e.g., git@github.com:user/MyProject.git';
		autoAccept: true;
		yourself.! !

!IceTipRepositoryTypePanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	self initializeProjectLocation.
! !

!IceTipRepositoryTypePanel methodsFor: 'accessing - ui' stamp: ''!
projectLocation

	^ projectLocation! !

!IceTipRepositoryTypePanel methodsFor: 'accessing' stamp: ''!
newRepository

	^ self subclassResponsibility! !

!IceTipRepositoryTypePanel methodsFor: 'private' stamp: ''!
defaultLocation

	^ IceLibgitRepository repositoriesLocation pathString! !

!IceTipRepositoryTypePanel methodsFor: 'testing' stamp: ''!
isNewRepository

	^ false! !

!IceTipRepositoryTypePanel class methodsFor: 'accessing' stamp: ''!
allTypes
	^ ((self allSubclasses 
		reject: #isAbstract)
		sorted: [ :a :b | a order < b order ])
		collect: #new! !

!IceTipRepositoryTypePanel class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self = IceTipRepositoryTypePanel! !

!IceTipRepositoryTypePanel class methodsFor: 'accessing' stamp: ''!
order

	^ 0! !

!IceTipResetBranchToThisCommitCommand commentStamp: ''!
I'm a command to reset the selected branch to the selected commit. It does not modify the working copy.!
!IceTipResetBranchToThisCommitCommand methodsFor: 'accessing' stamp: ''!
selectedBranch

	^ self context model! !

!IceTipResetBranchToThisCommitCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #bottom! !

!IceTipResetBranchToThisCommitCommand methodsFor: 'executing' stamp: ''!
defaultNameFromContext

	^ 'Reset ', self selectedBranch name, ' to commit ', self selectedCommitish shortId! !

!IceTipResetBranchToThisCommitCommand methodsFor: 'executing' stamp: ''!
execute
	
	self selectedBranch resetToCommit: self selectedCommitish.
	Iceberg announcer announce: (IceRepositoryModified for: self repository).! !

!IceTipResetBranchToThisCommitCommand methodsFor: 'initialization' stamp: ''!
name

	^ self context
		  ifNil: [ self className ]
		  ifNotNil: [ self defaultNameFromContext ]! !

!IceTipResetBranchToThisCommitCommand methodsFor: 'accessing' stamp: ''!
selectedCommitish

	^ self item! !

!IceTipResetBranchToThisCommitCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Resets the selected branch to the selected commit. It does not modify the working copy (!!!!).'! !

!IceTipRevertChangeCommand commentStamp: ''!
I'm a command to install a chunk of code from a commit (shown in a diff) into the image. 
"chunk" can be a package, class or single method.!
!IceTipRevertChangeCommand methodsFor: 'executing' stamp: ''!
tool
	"We consider the diffPanel of the context as our tool. This is important because we have to announce in the same Announcer instance that is subscribed for our news."

	^ super tool diffPanel! !

!IceTipRevertChangeCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #smallUndo! !

!IceTipRevertChangeCommand methodsFor: 'executing' stamp: ''!
execute

	UIManager default
		informUser: 'Reverting change...'
		during: [
			self repository workingCopy discardChanges: self item ].

	self toolAnnouncer announce:
		(IceTipDiffEntryRemoved entry: self item).
	Iceberg announcer announce:
		(IceRepositoryModified for: self repository)! !

!IceTipRevertChangeCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Revert selected change in the image'! !

!IceTipRevertChangeCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Revert change'! !

!IceTipSaveImageAction commentStamp: ''!
I implement the action of saving the image.

I'm used by the presenter that prepares the commit.!
!IceTipSaveImageAction methodsFor: 'execution' stamp: ''!
execute

	Smalltalk saveSession.
	self inform: 'Image automatically saved'! !

!IceTipSelectRemotePresenter methodsFor: 'accessing - ui' stamp: ''!
addButton

	^ addButton! !

!IceTipSelectRemotePresenter methodsFor: 'accessing - ui' stamp: ''!
remoteLabel

	^ remoteLabel! !

!IceTipSelectRemotePresenter methodsFor: 'accessing' stamp: ''!
label: aString

	self remoteLabel label: aString! !

!IceTipSelectRemotePresenter methodsFor: 'accessing' stamp: ''!
refresh

	remoteList items: self model remoteModels! !

!IceTipSelectRemotePresenter methodsFor: 'accessing' stamp: ''!
selectRemoteNamed: aString

	remoteList selectItem:
		(self model remoteModels detect: [ :each | each name = aString ])! !

!IceTipSelectRemotePresenter methodsFor: 'actions' stamp: ''!
addRemote

	(IceTipAddRemoteDialog on: self model repositoryModel) 
		onAccept: [ :newRemoteName | 
			self model reset.
			self refresh.
			self selectRemoteNamed: newRemoteName ];
		openDialogWithSpec.! !

!IceTipSelectRemotePresenter methodsFor: 'accessing' stamp: ''!
icon

	^ self iconNamed: #add! !

!IceTipSelectRemotePresenter methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!IceTipSelectRemotePresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.

	remoteLabel := self newLabel
		label: 'Remote:';
		yourself.

	remoteList := self newDropList
		display: [ :each | each descriptionWithDecoration ];
		yourself.

	addButton := self newButton
		icon: self icon;
		action: [ self addRemote ];
		yourself.

	self refresh.
	self selectRemoteNamed: self model remoteModel name.
! !

!IceTipSelectRemotePresenter methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!IceTipSelectRemotePresenter methodsFor: 'accessing - ui' stamp: ''!
remoteList

	^ remoteList! !

!IceTipSelectRemotePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		  add: #remoteLabel width: self labelWidth;
		  add: #remoteList;
		  add: #addButton width: self iconWidth! !

!IceTipSettingsCommand commentStamp: ''!
Command that opens the settings on a repository!
!IceTipSettingsCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #configuration! !

!IceTipSettingsCommand methodsFor: 'executing' stamp: ''!
execute

	| browser window path |
	browser := SettingBrowser new 
		changePackageSet: { 
			#'Iceberg' asPackage.
			#'Iceberg-Libgit' asPackage };
		yourself.
	
	window := browser open.
	path := (window submorphs detect: [ :each | (each isKindOf: MorphTreeMorph) ]) nodeList.
	browser expandNodePath: path first contents first contents first path.! !

!IceTipSettingsCommand methodsFor: 'accessing' stamp: ''!
shouldBeDisplayedOnRightSideInToolbar

	^ true! !

!IceTipSettingsCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ $n meta! !

!IceTipSettingsCommand methodsFor: 'testing' stamp: ''!
canBeExecuted 
	
	"This command can be executed with our without selection"
	^ true! !

!IceTipSettingsCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Open settings browser to configure Iceberg'! !

!IceTipSettingsCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Settings'! !

!IceTipSpCommand commentStamp: ''!
I am a CmUICommand that is specialized for Iceberg UI. 

In particular, I'm used to wrap instances of IceTipCommand in a IceTipBrowser.!
!IceTipSpCommand methodsFor: 'presenter building' stamp: ''!
configureAsToolbarButton

	self presenterBuildingStrategy: IceTipToolbarButtonStrategy new! !

!IceTipSpCommand methodsFor: 'presenter building' stamp: ''!
initialize

	super initialize.
	self configureAsToolbarButton! !

!IceTipSpCommand methodsFor: 'displaying' stamp: ''!
ifVisible: aBlock

	self displayStrategy ifVisible: self do: aBlock! !

!IceTipSpCommand methodsFor: 'accessing' stamp: ''!
presenterBuildingStrategy
	^ presenterBuildingStrategy! !

!IceTipSpCommand methodsFor: 'accessing' stamp: ''!
toolbarItemName

	^ self decoratedCommand toolbarItemName! !

!IceTipSpCommand methodsFor: 'presenter building' stamp: ''!
buildPresenter

	^ self presenterBuildingStrategy resultOn: self! !

!IceTipSpCommand methodsFor: 'accessing' stamp: ''!
presenterBuildingStrategy: aStrategy
	presenterBuildingStrategy := aStrategy! !

!IceTipSpCommand methodsFor: 'displaying' stamp: ''!
displayIn: aMenuGroupOrPresenter do: aBlock

	self displayStrategy 
		display: self 
		in: aMenuGroupOrPresenter 
		do: aBlock! !

!IceTipSpPresenter commentStamp: ''!
I'm a SpPresenter that is prepared to be wrapped in a window (or a dialog). The way it is prepared is through a system of hooks (template method pattern), but also providing some convenience API.!
!IceTipSpPresenter methodsFor: 'accessing' stamp: ''!
closeWindow
	"Close the window of this presenter"

	self window close! !

!IceTipSpPresenter methodsFor: 'extensions' stamp: ''!
updateTitle
	
	self withWindowDo: [ :aWindow | aWindow title: self titleForWindow ]! !

!IceTipSpPresenter methodsFor: 'initialization' stamp: ''!
titleForWindow
	"Answer the title to use during initialization when this presenter is being opened 
	in a SpWindowPresenter."

	^ self subclassResponsibility
! !

!IceTipSpPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aSpWindowPresenter

	super initializeWindow: aSpWindowPresenter.

	aSpWindowPresenter
		title: self titleForWindow;
		windowIcon: self iconForWindow;
		initialExtent: self initialExtentForWindow
! !

!IceTipSpPresenter methodsFor: 'initialization' stamp: ''!
initialExtentForWindow
	"Answer either nil or a Point representing the initial extent of this presenter.
	It is used during initialization if this presenter is opened inside a SpWindowPresenter. 
	Answer nil if there is not a suggested extent."

	^ nil! !

!IceTipSpPresenter methodsFor: 'initialization' stamp: ''!
iconForWindow
	"Answer a Form to be used during initialization when opening in a SpWindowPresenter."

	^ self iconNamed: #smallWindow! !

!IceTipSpPresenter class methodsFor: 'accessing' stamp: ''!
currentApplication 

	^ StPresenter currentApplication ! !

!IceTipStandardAction commentStamp: ''!
I'm a generic UI action.
I will perform an action by informing user what's happening.
I will also check for errors happening while performing the task and try to recover from them.!
!IceTipStandardAction methodsFor: 'accessing' stamp: ''!
action: aBlock
	actionBlock := aBlock! !

!IceTipStandardAction methodsFor: 'accessing' stamp: ''!
message: anObject
	message := anObject! !

!IceTipStandardAction methodsFor: 'executing' stamp: ''!
basicExecute
	UIManager default 
		informUser: self message
		during: actionBlock.
	successAnnounceBlock 
		ifNotNil: [ Iceberg announcer announce: successAnnounceBlock value ]! !

!IceTipStandardAction methodsFor: 'accessing' stamp: ''!
action
	^ actionBlock! !

!IceTipStandardAction methodsFor: 'accessing' stamp: ''!
onSuccessAnnounce: aValuable
	successAnnounceBlock := aValuable! !

!IceTipStandardAction methodsFor: 'accessing' stamp: ''!
onSuccessRepositoryModified
	^ self onSuccessAnnounce: [ IceRepositoryModified for: self repository ]! !

!IceTipStandardAction methodsFor: 'executing' stamp: ''!
execute: aBlock
	self action: aBlock.
	self execute! !

!IceTipStandardAction methodsFor: 'executing' stamp: ''!
do: aBlock
	self action: aBlock.
	self execute! !

!IceTipStandardAction methodsFor: 'accessing' stamp: ''!
message
	^ message! !

!IceTipStyleContributor commentStamp: ''!
This class is responsibly of adding the custom styles used by Iceberg.
This class is call by Spec2 to extend the default stylesheet.
Check its superclass to understand the way of working.!
!IceTipStyleContributor methodsFor: 'styles' stamp: ''!
styleSheetContribution
	
	^ SpStyle newApplication 
		addClass: 'textInputField' with: [ :textClass |
			textClass addClass: 'iceTipReadonly' with: [ :iceTipReadonly |
			iceTipReadonly addPropertyDrawWith: [ :draw | draw color: Color transparent ] ]]	;
		addClass: 'text' with: [ :textClass |
			textClass addClass: 'iceTipReadonly' with: [ :iceTipReadonly |
			iceTipReadonly addPropertyDrawWith: [ :draw | draw color: Color transparent ] ]];
		yourself! !

!IceTipSwitchAndMergeType commentStamp: ''!
I'm a switch and merge merging type. 
I will switch first to the new branch, and then I will perform a merge with current reference commit.

	1. Switch to merging branch.
	2. Merging branch <- reference commit
	
This strategy is used to re-attach image when it is detached from current development branch.!
!IceTipSwitchAndMergeType methodsFor: 'executing' stamp: ''!
mergeOn: aModel then: aBlock
	^ aModel switchAndMergeThen: aBlock! !

!IceTipTagModel methodsFor: 'actions' stamp: ''!
delete
	<noCache>
	
	IceTipStandardAction new
		repository: self repositoryModel entity;
		message: ('Removing tag {1}' format: { self name });
		onSuccessRepositoryModified;
		do: [ self repositoryModel entity removeTag: self entity ]! !

!IceTipTagModel methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	
	^ self entity name! !

!IceTipTagModel methodsFor: 'accessing' stamp: ''!
name
	
	^ self entity name! !

!IceTipTagModel methodsFor: 'accessing' stamp: ''!
commitModels
	
	| commits |
	commits := OrderedCollection new.
	self entity commitsDo: [ :each | 
		commits add: (IceTipCommitModel 
			repositoryModel: self repositoryModel 
			on: each) 
			beCached ].
	^ commits! !

!IceTipTagModel methodsFor: 'actions' stamp: ''!
previewCheckout
	"this will open a 'checkout browser' that will allow user to validate the changes before 
	 actually checking out (checkout operation will be called in my sibling method, #checkout)"
	<noCache>

	(IceTipCheckoutPreviewBrowser onBranch: self) openWithSpec! !

!IceTipToolbarButtonStrategy commentStamp: ''!
I'm a strategy to build Spec2 buttons foro a toolar wrapping a IceTipSpCommand.
!
!IceTipToolbarButtonStrategy methodsFor: 'public' stamp: ''!
resultOn: aCommand

	| aButtonPresenter |
	aButtonPresenter := super resultOn: aCommand.

	aButtonPresenter
		label: aCommand toolbarItemName;
		badge: aCommand decoratedCommand badge.

	^ aButtonPresenter
! !

!IceTipToolbarButtonStrategy methodsFor: 'hook' stamp: ''!
buttonPresenterClass

	^ SpToolbarButtonPresenter! !

!IceTipToolbarPresenterBuilder commentStamp: ''!
I'm a SpToolbarPresenterBuilder that delegates to the command the decision to actually add a button to represent it.
!
!IceTipToolbarPresenterBuilder methodsFor: 'visiting' stamp: ''!
visitCommand: aCmCommandEntry

	aCmCommandEntry ifVisible: [ super visitCommand: aCmCommandEntry ]! !

!IceTipTreeBranch methodsFor: 'testing' stamp: ''!
canActivateCommand: aCommandClass
	^ aCommandClass actsOnBranch: self! !

!IceTipTreeCollapseCommand commentStamp: ''!
A generic command to collapse a tree.
It sends `doCollapseSelection` message to its context.!
!IceTipTreeCollapseCommand methodsFor: 'executing' stamp: ''!
execute

	self context doCollapseSelection! !

!IceTipTreeCollapseCommand methodsFor: 'executing' stamp: ''!
canBeExecuted

	^ self hasSelectedItem
! !

!IceTipTreeCollapseCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Collapse selected item'! !

!IceTipTreeCollapseCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Collapse'! !

!IceTipTreeExpandCommand commentStamp: ''!
A generic command to expand tree items within a tree.!
!IceTipTreeExpandCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ nil! !

!IceTipTreeExpandCommand methodsFor: 'executing' stamp: ''!
execute

	self context doExpandSelection! !

!IceTipTreeExpandCommand methodsFor: 'executing' stamp: ''!
canBeExecuted

	^ self hasSelectedItem
! !

!IceTipTreeExpandCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Expand selected item'! !

!IceTipTreeExpandCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Expand'! !

!IceTipTreeGroup commentStamp: ''!
I'm a model to be used when building groups for outline dataSources.
I keep groups with elements.
I can provide also a contexts for menu operations and other kind of options to be associated with group.!
!IceTipTreeGroup methodsFor: 'accessing' stamp: ''!
children
	^ children ifNil: [ #() ]! !

!IceTipTreeGroup methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	^ self name asText! !

!IceTipTreeGroup methodsFor: 'accessing' stamp: ''!
ensurePath: aPath
	| first next |
	
	first := aPath first.
	next := self children 
		detect: [ :each | each isSameAs: first ]
		ifNone: [ self addChild: (first copy children: OrderedCollection new) ].
	^ aPath allButFirst 
		ifNotEmpty: [ :remainingPath | next ensurePath: remainingPath ]
		ifEmpty: [ next ]! !

!IceTipTreeGroup methodsFor: 'accessing' stamp: ''!
traversingDo: aBlock parents: anArray
	aBlock cull: self cull: anArray.
	self children do: [ :each | 
		each 
			traversingDo: aBlock 
			parents: (anArray copyWith: self) ]! !

!IceTipTreeGroup methodsFor: 'testing' stamp: ''!
isGroup
	^ true! !

!IceTipTreeGroup methodsFor: 'accessing' stamp: ''!
children: aCollection
	children := aCollection.
	children do: [ :each | each parent: self ]! !

!IceTipTreeGroup methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!IceTipTreeGroup methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!IceTipTreeGroup methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!IceTipTreeGroup methodsFor: 'testing' stamp: ''!
isSameAs: aNode
	^ aNode species = self species 
		and: [ self name = aNode name
		and: [ aNode name notNil ] ]! !

!IceTipTreeGroup methodsFor: 'accessing' stamp: ''!
addChild: anObject
	children ifNil: [ children := OrderedCollection new ].
	children add: anObject.
	anObject parent: self.
	^ anObject! !

!IceTipTreeGroup methodsFor: 'accessing' stamp: ''!
traversingDo: aBlock
	^ self traversingDo: aBlock parents: #() ! !

!IceTipTreeGroup class methodsFor: 'instance creation' stamp: ''!
name: aName children: aCollection
	^ self new 
		name: aName;
		children: aCollection;
		yourself! !

!IceTipTreeGroup class methodsFor: 'instance creation' stamp: ''!
name: aName icon: anIcon children: aCollection
	^ self new 
		name: aName;
		icon: anIcon;
		children: aCollection;
		yourself! !

!IceTipTreeItem commentStamp: ''!
I'm a leaf element of a tree.!
!IceTipTreeItem methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	^ self model descriptionWithDecoration! !

!IceTipTreeItem methodsFor: 'accessing' stamp: ''!
traversingDo: aBlock parents: anArray
	aBlock cull: self cull: anArray! !

!IceTipTreeItem methodsFor: 'testing' stamp: ''!
isSameAs: aNode
	^ aNode species = self species 
		and: [ self model = aNode model ]! !

!IceTipTreeNode commentStamp: ''!
I'm a node of a tree.
I understand 
	- descriptionWithDecoration
	- icon!
!IceTipTreeNode methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	"redirect to model to provide polymorphism."
	self flag: #pharoTodo. "I'm not sure this is good practice... we'll see how it works"
	self model ifNil: [ ^ super doesNotUnderstand: aMessage ].
	^ aMessage sendTo: self model! !

!IceTipTreeNode methodsFor: 'accessing' stamp: ''!
children
	^ #()! !

!IceTipTreeNode methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	^ self subclassResponsibility! !

!IceTipTreeNode methodsFor: 'testing' stamp: ''!
isLeaf
	^ self isGroup not! !

!IceTipTreeNode methodsFor: 'accessing' stamp: ''!
traversingDo: aBlock parents: anArray
	self subclassResponsibility! !

!IceTipTreeNode methodsFor: 'accessing' stamp: ''!
parent: anObject
	parent := anObject! !

!IceTipTreeNode methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!IceTipTreeNode methodsFor: 'testing' stamp: ''!
isGroup
	^ false! !

!IceTipTreeNode methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!IceTipTreeNode methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!IceTipTreeNode methodsFor: 'testing' stamp: ''!
canActivateCommand: aCommandClass
	^ false! !

!IceTipTreeNode methodsFor: 'testing' stamp: ''!
isSameAs: aNode
	^ self subclassResponsibility! !

!IceTipTreeNode methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!IceTipTreeNode methodsFor: 'accessing' stamp: ''!
icon: anIcon
	icon := anIcon! !

!IceTipTreeNode methodsFor: 'accessing' stamp: ''!
path
	^ self parent 
		ifNotNil: [ :p | p path, { self } ]
		ifNil: [ { self } ]! !

!IceTipTreeNode class methodsFor: 'instance creation' stamp: ''!
on: aModel
	^ self new model: aModel! !

!IceTipTreeRemote methodsFor: 'testing' stamp: ''!
canActivateCommand: aCommandClass
	^ aCommandClass actsOnRemote: self! !

!IceTipTreeTag methodsFor: 'testing' stamp: ''!
canActivateCommand: aCommandClass
	^ aCommandClass actsOnTag: self! !

!IceTipUnloadAndRemovePackageCommand commentStamp: ''!
Command that opens a dialog to remove a package.
It gives the user with two checkboxes to choose:
 - remove from repository
 - unload

Right now this is only shown for loaded packages.!
!IceTipUnloadAndRemovePackageCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #glamorousTrash! !

!IceTipUnloadAndRemovePackageCommand methodsFor: 'executing' stamp: ''!
execute

	(IceTipRemovePackageDialog on: self packageModel) openDialogWithSpec! !

!IceTipUnloadAndRemovePackageCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self isPackageLoaded! !

!IceTipUnloadAndRemovePackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Opens a dialog to choose between unloading from system and/or removing a package from the repository'! !

!IceTipUnloadAndRemovePackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Unload and/or remove from repository'! !

!IceTipUnloadPackageCommand commentStamp: ''!
Command to unload a package from the system, keeping it in the repository!
!IceTipUnloadPackageCommand methodsFor: 'accessing' stamp: ''!
iconName

	^ #smallCancel! !

!IceTipUnloadPackageCommand methodsFor: 'executing' stamp: ''!
execute

	self packageModel unload! !

!IceTipUnloadPackageCommand methodsFor: 'testing' stamp: ''!
canBeExecuted

	^ self isPackageLoaded! !

!IceTipUnloadPackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Unload selected package from the system, but keep it in the repository.'! !

!IceTipUnloadPackageCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Unload'! !

!IceTipVersionHistoryBrowser commentStamp: ''!
I'm a browser and panel to show the version history of a method. 

For versions, I show the same commands of a regular history browser, but add some special commands.

(self onRepository: aRepository method: aMethod) openWithSpec.

!
!IceTipVersionHistoryBrowser methodsFor: 'private - factory' stamp: ''!
newInfoPage

	^ SpNotebookPage  
		title: 'Info'
		icon: (self iconNamed: #smallQuestion)
		provider: [ self newVersionInfoPresenter ]
! !

!IceTipVersionHistoryBrowser methodsFor: 'private' stamp: ''!
newDiffPresenter
	
	selectedModel ifNil: [ ^ self ].
	^ self 
		newDiffPanelLeft: ((self model commitModelAfter: selectedModel) 
			ifNotNil: #source
			ifNil: [ '' ])
		right: selectedModel source! !

!IceTipVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
refresh

	commitList items: self model commitModels.
	selectedModel := self model commitModels 
		ifNotEmpty: #first
		ifEmpty: [ nil ].
	self refreshCommitTabPanel! !

!IceTipVersionHistoryBrowser methodsFor: 'private' stamp: ''!
refreshCommitTabPanel
	
	selectedModel ifNil: [ ^ self ].
	diffPage title: ('{1} to {2}' format: { 
		(self model commitModelAfter: selectedModel) 
			ifNotNil: #shortId
			ifNil: [ 'origin' ].
		selectedModel shortId }).
	commitPanel resetAllPageContents! !

!IceTipVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
commitList

	^ commitList! !

!IceTipVersionHistoryBrowser methodsFor: 'event handling' stamp: ''!
selectionChanged: aSelectedItem

	selectedModel := aSelectedItem.
	self refreshCommitTabPanel! !

!IceTipVersionHistoryBrowser methodsFor: 'initialization' stamp: ''!
initializeCommitPanel
	"This will be initialised in fact on the first refresh"

	commitPanel
		addPage: (infoPage := self newInfoPage);
		addPage: (diffPage := self newDiffPage 
			title: 'Diff from ancestor';
			presenterProvider: [ self newDiffPresenter ];
			yourself)! !

!IceTipVersionHistoryBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ self model  
		ifNotNil: [ 'Versions of {1}' format: { self model name } ]
		ifNil: [ 'Versions' ]! !

!IceTipVersionHistoryBrowser methodsFor: 'initialization' stamp: ''!
initializeCommitList

	commitList
		beResizable;
		addColumn:
			(SpStringTableColumn new
				title: 'Timestamp';
				evaluated: [ :each | each timeStamp asLocalStringYMDHM ];
				width: 110 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			(SpStringTableColumn new
				title: 'Commit';
				evaluated: #shortId;
				width: 60 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			(SpStringTableColumn new
				title: 'Author';
				evaluated: #author;
				width: 150 * self currentWorld displayScaleFactor;
				yourself);
		addColumn:
			(SpStringTableColumn new
				title: 'Description';
				evaluated: #descriptionWithDecoration;
				yourself).
				
	commitList whenSelectionChangedDo: [ :aSelection |
		self selectionChanged: aSelection selectedItem ].
! !

!IceTipVersionHistoryBrowser methodsFor: 'private - factory' stamp: ''!
newDiffPanelLeft: leftString right: rightString

	^ (self instantiate: SpDiffPresenter) 
		leftText: leftString;
		rightText: rightString;
		showOptions: false! !

!IceTipVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
model: anObject

	super model: anObject.
	self refresh! !

!IceTipVersionHistoryBrowser methodsFor: 'private' stamp: ''!
newVersionInfoPresenter
	
	selectedModel ifNil: [ ^ self ].
	^ IceTipReadOnlyFormBuilder newBuiltFor: selectedModel info application: self application! !

!IceTipVersionHistoryBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (700@700) scaledByDisplayScaleFactor! !

!IceTipVersionHistoryBrowser methodsFor: 'private - factory' stamp: ''!
newDiffPage

	^ SpNotebookPage  
		title: 'Diff'
		icon: (self iconNamed: #diff)
		provider: [ self newDiffPresenter ]! !

!IceTipVersionHistoryBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.	
	commitList := self newTable.
	commitPanel := self newNotebook.
	
	self initializeCommitList.
	self initializeCommitPanel.
	
	self refresh! !

!IceTipVersionHistoryBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList
	"Answer the presenter that is the main list of items of this browser."

	^ commitList! !

!IceTipVersionHistoryBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	{ 	IceTipInstallVersionCommand }
			do: [ :each |
				aCommandGroup register: each forSpec ]
! !

!IceTipVersionHistoryBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec
	
	^ SpPanedLayout newTopToBottom
		add: #commitList;
		add: #commitPanel;
		yourself! !

!IceTipVersionHistoryBrowser class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository method: aMethod
	
	^ self on: (IceTipVersionHistoryModel 
		repositoryModel: (IceTipRepositoryModel on: aRepository) beCached 
		on: aMethod)
		beCached! !

!IceTipVersionHistoryBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	"Nothing to add"! !

!IceTipVersionHistoryModel commentStamp: ''!
I'm a model to provide the history of a method.!
!IceTipVersionHistoryModel methodsFor: 'accessing' stamp: ''!
descriptionWithDecoration
	^ self name! !

!IceTipVersionHistoryModel methodsFor: 'accessing' stamp: ''!
name
	^ '{1}>>{2}' format: { self entity origin name. self entity selector }! !

!IceTipVersionHistoryModel methodsFor: 'accessing' stamp: ''!
commitModels
	^ commitModels ifNil: [ 
		commitModels := self retrieveHistory collect: [ :each | 
			(IceTipVersionModel 
				repositoryModel: self repositoryModel 
				on: each) 
				beCached ] ]! !

!IceTipVersionHistoryModel methodsFor: 'private' stamp: ''!
retrieveHistory

	self repositoryModel checkMissing.
	UIManager default 
		informUser: ('Retrieving history of {1}' format: { self entity printString }) 
		during: [ ^ self repositoryModel entity log historyOfMethod: self entity ]! !

!IceTipVersionHistoryModel methodsFor: 'accessing' stamp: ''!
commitModelAfter: aModel
	^ self commitModels 
		after: aModel
		ifAbsent: [ nil ]! !

!IceTipVersionModel commentStamp: ''!
I'm a model for IceLogVersion entries. 

- I provide log-specific entries.
- I can install a certain method version.!
!IceTipVersionModel methodsFor: 'private' stamp: ''!
basicInstall
	| definition |
	
	definition := self entity definition.
	definition realClass 
		compile: definition sourceCode
		classified: definition category	! !

!IceTipVersionModel methodsFor: 'actions' stamp: ''!
install
	<noCache>

	IceTipStandardAction new 
		repository: self repositoryModel entity; 
		message: ('Installing {1} - {2}' format: { self entity definition. self name });
		onSuccessRepositoryModified;
		execute: [ self basicInstall ]! !

!IceTipVersionModel methodsFor: 'accessing' stamp: ''!
source
	^ self entity source! !

!IceTipVersionModel methodsFor: 'accessing' stamp: ''!
commit
	^ self entity commit! !

!IceTipWorkingCopyBrowser commentStamp: ''!
I'm a tool to show the internals of a repository from the point of view of an image. 
I show the packages managed by this repository and a series of actions to properly handle them in the context of an iceberg repository.

(IceTipPackagesBrowser forRepository: IceRepository registry anyOne) openWithSpec!
!IceTipWorkingCopyBrowser methodsFor: 'initialization' stamp: ''!
initializePackagesTable

	packagesTable
		beResizable;
		addColumn: (SpImageTableColumn new 
			width: (self iconNamed: #package) width;
			evaluated: [ self iconNamed: #package];
			yourself);
		addColumn: (SpStringTableColumn
			title: 'Name'
			evaluated: #descriptionWithDecoration);
		addColumn: (SpStringTableColumn
			title: 'Status'
			evaluated: #statusWithDecoration);
		activateOnDoubleClick;
		whenActivatedDo: [ :selection | self browsePackage: selection selectedItem ]! !

!IceTipWorkingCopyBrowser methodsFor: 'initialization' stamp: ''!
subscribeToAnnouncements

	Iceberg announcer weak
		when: IceRepositoryAnnouncement
		send: #refreshWhenRepository:
		to: self! !

!IceTipWorkingCopyBrowser methodsFor: 'private - actions' stamp: ''!
browsePackage: aPackageModel
	| commandClass |
	
	commandClass := aPackageModel isLoaded
		ifTrue: [ IceTipBrowsePackageCommand ]
		ifFalse: [ IceTipBrowseRepositoryPackageVersionCommand ].
		
	 commandClass new
		packageModel: aPackageModel;
		execute! !

!IceTipWorkingCopyBrowser methodsFor: 'accessing - ui' stamp: ''!
statusBar

	^ statusBar! !

!IceTipWorkingCopyBrowser methodsFor: 'accessing' stamp: ''!
refresh

	self refreshCommands.
	self refreshStatusBar.
	self refreshPackagesTable.
! !

!IceTipWorkingCopyBrowser methodsFor: 'accessing - ui' stamp: ''!
filterInput

	^ filterInput! !

!IceTipWorkingCopyBrowser methodsFor: 'accessing' stamp: ''!
allListItems

	^ self model packageModels! !

!IceTipWorkingCopyBrowser methodsFor: 'testing' stamp: ''!
showsPackageNamed: aString 
	
	^ packagesTable items anySatisfy: [ :packageModel | packageModel name = aString ]! !

!IceTipWorkingCopyBrowser methodsFor: 'initialization' stamp: ''!
titleForWindow

	^ 'Working copy of ', self model repositoryName! !

!IceTipWorkingCopyBrowser methodsFor: 'private' stamp: ''!
refreshStatusBar

	statusBar model: self model! !

!IceTipWorkingCopyBrowser methodsFor: 'private' stamp: ''!
refreshWhenRepository: ann

	(ann repository isNil or: [ 
		self model repositoryModel isModelOf: ann repository ]) ifFalse: [ 
		^ self ].
	self model reset.
	self refresh
! !

!IceTipWorkingCopyBrowser methodsFor: 'accessing' stamp: ''!
packageModel
	
	^ packagesTable selectedItem! !

!IceTipWorkingCopyBrowser methodsFor: 'initialization' stamp: ''!
initializeWindow: aSpWindowPresenter
	
	super initializeWindow: aSpWindowPresenter.

	aSpWindowPresenter statusBar: statusBar.
! !

!IceTipWorkingCopyBrowser methodsFor: 'private' stamp: ''!
refreshPackagesTable

	packagesTable items: (filterInput text
		ifEmpty: [ self allListItems ]
		ifNotEmpty: [ :pattern | self filteredItemsFor: pattern ])
! !

!IceTipWorkingCopyBrowser methodsFor: 'initialization' stamp: ''!
initialExtentForWindow

	^ (700 @ 500) scaledByDisplayScaleFactor! !

!IceTipWorkingCopyBrowser methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aRepositoryModel

	self model: ( IceTipWorkingCopyModel on: aRepositoryModel )! !

!IceTipWorkingCopyBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	filterInput := self newTextInput.
	packagesTable := self newTable.
	self initializePackagesTable.
	statusBar := self instantiate: IceTipWorkingCopyStatusBar.

	self refresh.
! !

!IceTipWorkingCopyBrowser methodsFor: 'initialization' stamp: ''!
connectPresenters

	super connectPresenters.
	filterInput
		placeholder: 'Filter...';
		whenTextChangedDo: [ :text | self refreshPackagesTable ]
! !

!IceTipWorkingCopyBrowser methodsFor: 'accessing - ui' stamp: ''!
mainList

	^ packagesTable! !

!IceTipWorkingCopyBrowser methodsFor: 'accessing - ui' stamp: ''!
packagesTable

	^ packagesTable! !

!IceTipWorkingCopyBrowser methodsFor: 'private' stamp: ''!
filteredItemsFor: pattern

	^ self allListItems select: [ :each | 
		  each name asLowercase includesSubstring: pattern asLowercase ]! !

!IceTipWorkingCopyBrowser class methodsFor: 'instance creation' stamp: ''!
onRepository: aRepository

	^ self on: (IceTipRepositoryModel on: aRepository)! !

!IceTipWorkingCopyBrowser class methodsFor: 'commands' stamp: ''!
buildSelectionCommandGroupWith: presenter for: aCommandGroup

	{ 	IceTipBrowsePackageCommand.
		IceTipBrowseRepositoryPackageVersionCommand.
		IceTipLoadPackageCommand.
		IceTipReloadPackageCommand.
		IceTipUnloadPackageCommand.
		IceTipUnloadAndRemovePackageCommand.
		IceTipRemoveFromRepositoryPackageCommand }
			do: [ :each | aCommandGroup register: each forSpec ]
! !

!IceTipWorkingCopyBrowser class methodsFor: '*Iceberg-Plugin-Metacello' stamp: ''!
metacelloCommandsWith: presenter forRootGroup: aCommandGroup

	<extensionCommands>
	| newGroup |
	newGroup := CmCommandGroup forSpec
		name: 'Metacello';
		description: 'Metacello install operations';
		yourself.

	{  IceTipMetacelloInstallBaselineDefaultCommand.
		IceTipMetacelloInstallBaselineGroupCommand }
			do: [ :each | newGroup register: each forSpec ].

	(aCommandGroup / self selectionCommandGroupName)
		register: newGroup. 
! !

!IceTipWorkingCopyBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		  add: #packagesTable;
		  add: #filterInput expand: false;
		  yourself! !

!IceTipWorkingCopyBrowser class methodsFor: 'commands' stamp: ''!
buildGeneralCommandGroupWith: presenter for: aCommandGroup

	{	IceTipRepairCommand. 	
		IceTipCommitCommand.
		IceTipPushCommand.
		IceTipPullCommand.
		IceTipFetchCommand.
		IceTipCheckoutBranchCommand.
		IceTipMergeCommand.
		IceTipManageRepositoryCommand.
		IceTipDiscardChangesCommand.
		IceTipAddPackageCommand } 
		do: [ :each |
			aCommandGroup register: each forSpec ]
! !

!IceTipWorkingCopyBrowser class methodsFor: '*Calypso-SystemPlugins-Monticello-Browser' stamp: ''!
calypsoCommandsWith: presenter forRootGroup: aCommandGroup
	<extensionCommands>

	aCommandGroup / self selectionCommandGroupName register:
		ClyBrowseIcebergPackageCommand forSpec! !

!IceTipWorkingCopyDiffModel commentStamp: ''!
I'm a diff model that represents a diff between the HEAD commit and the image working copy.!
!IceTipWorkingCopyDiffModel methodsFor: 'testing' stamp: ''!
isEmpty
	^ self diff isEmpty! !

!IceTipWorkingCopyDiffModel methodsFor: 'private' stamp: ''!
resetDiff
	diff := nil! !

!IceTipWorkingCopyDiffModel methodsFor: 'private - factory' stamp: ''!
newDiff
	^ self entity workingCopyDiff! !

!IceTipWorkingCopyDiffModel methodsFor: 'accessing' stamp: ''!
diff
	^ diff ifNil: [ diff := self newDiff ]! !

!IceTipWorkingCopyModel commentStamp: ''!
I'm a model to for IceWorkingCopy entries.!
!IceTipWorkingCopyModel methodsFor: 'accessing' stamp: ''!
repositoryModel
	^ repositoryModel! !

!IceTipWorkingCopyModel methodsFor: 'initialization' stamp: ''!
initializeRepositoryModel: aRepositoryModel
	repositoryModel := aRepositoryModel.
	self initialize! !

!IceTipWorkingCopyModel methodsFor: 'accessing' stamp: ''!
sortingStrategy
	^ sortingStrategy ifNil: [ sortingStrategy := IceSortingStrategy new first: #modified ]! !

!IceTipWorkingCopyModel methodsFor: 'accessing' stamp: ''!
branchName
	^ self repositoryModel branchName! !

!IceTipWorkingCopyModel methodsFor: 'accessing' stamp: ''!
commitId
	^ repositoryModel commitId! !

!IceTipWorkingCopyModel methodsFor: 'accessing' stamp: ''!
packageModels
	^ self sortingStrategy sort: (self repositoryModel entity workingCopy packages 
		collect: [ :each | 
			(IceTipPackageModel 
				repositoryModel: self repositoryModel 
				on: each) 
				beCached ])! !

!IceTipWorkingCopyModel methodsFor: 'accessing' stamp: ''!
shortCommitId
	^ repositoryModel shortCommitId! !

!IceTipWorkingCopyModel methodsFor: 'accessing' stamp: ''!
status
	^ self repositoryModel status! !

!IceTipWorkingCopyModel methodsFor: 'operations' stamp: ''!
copyCommitIDToClipboard
	<noCache>

	repositoryModel copyCommitIDToClipboard! !

!IceTipWorkingCopyModel methodsFor: 'accessing' stamp: ''!
reset
	self repositoryModel reset! !

!IceTipWorkingCopyModel methodsFor: 'accessing' stamp: ''!
repositoryName
	^ self repositoryModel name! !

!IceTipWorkingCopyModel class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'use #for:'! !

!IceTipWorkingCopyModel class methodsFor: 'instance creation' stamp: ''!
on: aRepositoryModel 
	^ self basicNew 
		initializeRepositoryModel: aRepositoryModel;
		yourself! !

!IceTipWorkingCopyStatusBar commentStamp: ''!
I'm the status bar for a IceTipWorkingCopyBrowser.!
!IceTipWorkingCopyStatusBar methodsFor: 'testing' stamp: ''!
canTakeKeyboardFocus

	^ false! !

!IceTipWorkingCopyStatusBar methodsFor: 'accessing' stamp: ''!
refreshWithoutCommitId: aModel

	branchLabel label: aModel branchName.
	commitLink := self newNullPresenter.
! !

!IceTipWorkingCopyStatusBar methodsFor: 'accessing' stamp: ''!
model: aModel
	"Fill labels from a IceTipWorkingCopyModel."

	aModel shortCommitId
		ifNil: [ self refreshWithoutCommitId: aModel ]
		ifNotNil: [ self refreshWithCommitId: aModel ].
	statusLabel label: aModel status.
! !

!IceTipWorkingCopyStatusBar methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	branchLabel := self newLabel.
	statusLabel := self newLabel! !

!IceTipWorkingCopyStatusBar methodsFor: 'accessing' stamp: ''!
refreshWithCommitId: aModel

	branchLabel label: ('{1} at ' format: { aModel branchName }).
	commitLink := self newLink.
	commitLink
		label: aModel shortCommitId;
		help: 'Copy the commit ID to the clipboard';
		action: [ aModel copyCommitIDToClipboard ].
! !

!IceTipWorkingCopyStatusBar class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		  add: #branchLabel expand: false;
		  add: #commitLink
			  expand: true
			  fill: true
			  padding: 0;
		  addLast: #statusLabel expand: false;
		  yourself! !

!IceTokenCredentials commentStamp: ''!
I implement authentication credentials via OAUTH-like token.

## Examples

* https://developer.github.com/v3/#authentication
* https://confluence.atlassian.com/bitbucketserver0514/using-bitbucket-server/personal-access-tokens
!
!IceTokenCredentials methodsFor: '*Iceberg-TipUI' stamp: ''!
editModelClass
	^ IceTipEditTokenCredentialsModel! !

!IceTokenCredentials methodsFor: 'accessing' stamp: ''!
isPresent
	^ self token notEmpty! !

!IceTokenCredentials methodsFor: 'printing' stamp: ''!
description
	^ 'User: ', username! !

!IceTokenCredentials methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
authorizationHeaderKey

	^ 'Authorization'! !

!IceTokenCredentials methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
authorizationHeaderValue

	^ 'Bearer ' , token! !

!IceTokenCredentials methodsFor: 'accessing' stamp: ''!
password
	"For git operations in GitHub, the token can be used as password.
	
	See https://docs.github.com/en/enterprise/2.15/user/articles/creating-a-personal-access-token-for-the-command-line#using-a-token-on-the-command-line"

	^ token! !

!IceTokenCredentials methodsFor: 'printing' stamp: ''!
hostDescription
	^ host! !

!IceTokenCredentials methodsFor: 'accessing' stamp: ''!
token

	^ token! !

!IceTokenCredentials methodsFor: '*Iceberg-TipUI' stamp: ''!
askForModelClass
	^ self notYetImplemented! !

!IceTokenCredentials methodsFor: 'accessing' stamp: ''!
username: aString
	username := aString! !

!IceTokenCredentials methodsFor: 'accessing' stamp: ''!
token: aString

	token := aString! !

!IceTokenCredentials methodsFor: 'removing' stamp: ''!
removeFrom: anIceCredentialStore 

	anIceCredentialStore removePlainTextCredential: self! !

!IceTokenCredentials methodsFor: 'accessing' stamp: ''!
username
	^ username! !

!IceTokenCredentials methodsFor: 'accessing' stamp: ''!
type

	^ 'Token'! !

!IceTokenCredentials methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
applyToRequest: aRequest

	token ifNil: [ ^ self ].

	aRequest
		headerAt: self authorizationHeaderKey
		put: self authorizationHeaderValue! !

!IceTraitDefinition commentStamp: ''!
I represent a trait read from an Iceberg repository, either from a commit or from the working directory in disk.

My contents is the trait definition.

See my superclasses for more information.!
!IceTraitDefinition methodsFor: 'comparing' stamp: ''!
= anotherDefinition
	
	^ super = anotherDefinition
		and: [ mcDefinition = anotherDefinition asMCDefinition ]! !

!IceTraitDefinition methodsFor: 'patching' stamp: ''!
addModification: anIceModification toPatcher: aMCPatcher 
	
	"We should not handle metaclasses if their mcDefinition is nil.
	They should be added automatically when added the instance side."
	(self isMeta and: [ mcDefinition isNil ])
		ifTrue: [ ^ self ].
	
	aMCPatcher
		modifyDefinition: anIceModification rightDefinition asMCDefinition
		to: anIceModification leftDefinition asMCDefinition! !

!IceTraitDefinition methodsFor: 'patching' stamp: ''!
addToPatcher: aMCPatcher 
	
	"We should not handle metaclasses if their mcDefinition is nil.
	They should be added automatically when added the instance side."
	(self isMeta and: [ mcDefinition isNil ])
		ifTrue: [ ^ self ].

	"We should only be in this case if there is not instace-side changes."
	aMCPatcher addDefinition: self asMCDefinition! !

!IceTraitDefinition methodsFor: 'testing' stamp: ''!
isTraitDefinition

	^ true! !

!IceTraitDefinition methodsFor: 'accessing' stamp: ''!
name
	^ name , (isMeta ifTrue: [ ' classTrait' ] ifFalse: [ '' ])! !

!IceTraitDefinition methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	^ self iconNamed: #trait! !

!IceTraitDefinition methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	
	^ aVisitor visitTraitDefinition: self! !

!IceTraitDefinition methodsFor: 'patching' stamp: ''!
removeFromPatcher: aMCPatcher 
	
	"We should not handle metaclasses. They will be added automatically when added the instance side"
	self isMeta ifTrue: [ ^ self ].
	
	aMCPatcher removeDefinition: self asMCDefinition! !

!IceTraitDependency commentStamp: ''!
I am a dependency to a trait.!
!IceTraitDependency methodsFor: 'visiting' stamp: ''!
isDependencyTo: anIceTraitDefinition
	^ anIceTraitDefinition name = definition name! !

!IceTraitDependency methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	^ super = anObject
		and: [ self definition name = anObject definition name ]! !

!IceTraitDependency methodsFor: 'dependencies' stamp: ''!
referencedTraits
	^ (((RBParser
		parseExpression: definition asMCDefinition traitComposition)
		allChildren select: #isVariable) collect: #name ) , self usedTraitsNames  ! !

!IceTraitDependency methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."
	^ super hash bitXor: definition name hash.
	"^ definition hash"! !

!IceTraitDependency methodsFor: 'dependencies' stamp: ''!
referencedClasses

	^ {  }! !

!IceTraitDependency methodsFor: 'dependencies' stamp: ''!
referencedPackages
	^ self definition asMCDefinition category! !

!IceTraitDependency methodsFor: 'accessing' stamp: ''!
usedTraitsNames
	^ self cherrypicker environment
		allUsingTraitNamed: self definition name! !

!IceTreeMerger methodsFor: 'building' stamp: ''!
merge: changeTree into: currentTree

	^ changeTree collectWithPath: [ :operation :path | 
			currentTree 
				resolve: path 
				ifPresent: [ :currentOperation | operation mergeWithOperation: currentOperation ] 
				ifAbsent: [ IceNonConflictingOperation operation: operation] ]! !

!IceTreeVisitor commentStamp: ''!
I implement a basic tree visitor for Iceberg trees implemented through IceNode!
!IceTreeVisitor methodsFor: 'visiting' stamp: ''!
visitChildrenOf: anIceNode 
	
	anIceNode childrenDo: [ :each | each accept: self ]! !

!IceTreeVisitor methodsFor: 'visiting' stamp: ''!
visitEmptyNode: anIceEmptyNode 
	
	"Do nothing by default"! !

!IceTreeVisitor methodsFor: 'visiting' stamp: ''!
visitTreeNode: anIceNode
	
	self withNode: anIceNode do: [ 
		anIceNode value accept: self ]! !

!IceTreeVisitor methodsFor: 'visiting' stamp: ''!
withNode: anIceNode do: aBlockClosure 
	
	| previousNode |
	previousNode := currentNode.
	currentNode := anIceNode.
	aBlockClosure ensure: [ 
		currentNode := previousNode ]! !

!IceTreeVisitor methodsFor: 'visiting' stamp: ''!
visitConflictingOperation: anIceConflictingOperation 
	
	anIceConflictingOperation isResolved
		ifFalse: [ self error: 'Cannot apply a non resolved conflict' ].
		
	^ anIceConflictingOperation chosenOperation accept: self! !

!IceTreeVisitor class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceTreeVisitor ! !

!IceUnbornBranch commentStamp: ''!
I am an unborn branch. I exist only on a new repository that has no commits inside. I manage the special case of a first repository commit and branch creation.!
!IceUnbornBranch methodsFor: 'API - remotes' stamp: ''!
hasIncomingCommitsFrom: aRemote
	
	aRemote fetch.
	^ aRemote hasRemoteBranchNamed: self name! !

!IceUnbornBranch methodsFor: 'comparing' stamp: ''!
= anotherBranch

	^ anotherBranch isUnbornBranch! !

!IceUnbornBranch methodsFor: 'API - changes' stamp: ''!
changesFromCommit: anIceNoCommit 
	"I am an unborn branch. This means the repository is not yet created and the commit is a no-commit"
	
	self assert: anIceNoCommit isNoCommit.
	^ #()! !

!IceUnbornBranch methodsFor: 'testing' stamp: ''!
isLocal
	
	^ true! !

!IceUnbornBranch methodsFor: 'testing' stamp: ''!
isRemote
	
	^ false! !

!IceUnbornBranch methodsFor: 'testing' stamp: ''!
isUnbornBranch
	
	^ true! !

!IceUnbornBranch methodsFor: 'API - remotes' stamp: ''!
tracksRemoteBranch
	
	^ false! !

!IceUnbornBranch methodsFor: 'printing' stamp: ''!
description
	
	^ self name! !

!IceUnbornBranch methodsFor: 'API - remotes' stamp: ''!
pullFrom: aRemote
	
	"This is a special operation: this branch is unborn.
	This means there is no local branch in ths repository.
	We shall then
	  - create a local branch tracking a remote branch with the same name
	  - pull from that branch
	
	If there is no branch in the remote repository with the same name, do nothing.
	"
	
	| remoteBranch |
	repository fetch.
	remoteBranch := aRemote remoteBranchNamed: self name ifAbsent: [ ^ self ].
	repository createBranch: self name inCommit: remoteBranch commit.! !

!IceUnbornBranch methodsFor: 'API - packages' stamp: ''!
packages

	^ #()! !

!IceUnbornBranch methodsFor: 'API - packages' stamp: ''!
packageNames
	
	^ #()! !

!IceUnbornBranch methodsFor: 'private - monticello' stamp: ''!
snapshotFor: anIceSavedPackage 
	
	"I am an unborn branch, I have no code, so my snapshot is empty"
	^ MCSnapshot empty! !

!IceUnbornBranch methodsFor: 'API - remotes' stamp: ''!
pull
	
	self pullFrom: repository origin! !

!IceUnbornBranch methodsFor: 'accessing' stamp: ''!
commit
	
	^ IceNoCommit repository: repository! !

!IceUnbornBranch methodsFor: 'API - remotes' stamp: ''!
outgoingCommits
	"I am unborn. I have no commits"
	^ #()! !

!IceUnbornBranch methodsFor: 'API - remotes' stamp: ''!
incomingCommitsFrom: aRemote
	| remoteBranch |
	remoteBranch := aRemote remoteBranchNamed: self name ifAbsent: [ ^ #() ].
	^ remoteBranch newCommitWalk
		uptoCommit: self commit;
		commits! !

!IceUnbornBranch methodsFor: 'testing' stamp: ''!
isHead
	
	^ true! !

!IceUnbornBranch methodsFor: 'testing' stamp: ''!
isBranch
	
	^ true! !

!IceUnbornBranch methodsFor: 'accessing' stamp: ''!
checkout: aCheckoutStreategy

	"Do nothing. An unborn branch is already HEAD"! !

!IceUnbornBranch methodsFor: 'testing' stamp: ''!
hasIncomingCommits
	
	^ self hasIncomingCommitsFrom: self repository origin! !

!IceUnbornBranch methodsFor: 'testing' stamp: ''!
hasOutgoingCommits
	
	^ false! !

!IceUnbornBranch methodsFor: 'API - remotes' stamp: ''!
hasOutgoingCommitsTo: aRemote

	^ false! !

!IceUnbornBranch methodsFor: 'API - remotes' stamp: ''!
push
	
	"Do nothing"! !

!IceUnbornBranch methodsFor: 'accessing' stamp: ''!
name

	self subclassResponsibility! !

!IceUnbornBranch methodsFor: 'API - remotes' stamp: ''!
incomingCommits
	"I am unborn. I have no commits"
	^ #()! !

!IceUnbornBranch methodsFor: 'testing' stamp: ''!
hasUpstream
	^ false! !

!IceUnbornBranch methodsFor: 'API - history' stamp: ''!
newCommitWalk
	
	^ IceNullCommitWalk new! !

!IceUnbornBranch methodsFor: 'API - remotes' stamp: ''!
pushTo: aRemote

	"Do Nothing"! !

!IceUnbornProject methodsFor: 'testing' stamp: ''!
readOnlyVersion

	^ IceInvalidProject onCommitish: commitish! !

!IceUnbornProject methodsFor: 'testing' stamp: ''!
isUnborn
	
	^ true! !

!IceUnbornProject methodsFor: 'accessing' stamp: ''!
sourceDirectory

	"Tricky method.
	If we are in an unborn project, it means the user has not configured meta-data on it yet.
	In that case, return the empty source directory"
	^ ''! !

!IceUnbornProjectReader commentStamp: ''!
I create unborn projects from a commitish if it is HEAD and it does not have a '.project' file.!
!IceUnbornProjectReader methodsFor: 'accessing' stamp: ''!
priority

	"The unborn project reader should be the default one in case no other matches"
	^ 100000! !

!IceUnbornProjectReader methodsFor: 'testing' stamp: ''!
canReadProjectFromCommitish: aCommitish
	
	^ aCommitish isWorkingCopy
		and: [ (aCommitish fileSystem / '.project') exists not ]! !

!IceUnbornProjectReader methodsFor: 'reading' stamp: ''!
readProjectFromCommitish: anIceCommitish

	^ IceUnbornProject onCommitish: anIceCommitish! !

!IceUnbornRepositoryProperties methodsFor: 'testing' stamp: ''!
asBornProperties
	
	^ IceRepositoryProperties
		fromDictionary: properties
		commitish: commitish! !

!IceUnbornRepositoryProperties methodsFor: 'testing' stamp: ''!
addToChangeBuilder: anIceChangeImporter 

	"I'm unborn"
	^ self! !

!IceUnbornRepositoryProperties methodsFor: 'testing' stamp: ''!
isUnborn

	^ true! !

!IceUndefinedRemote commentStamp: ''!
I am a null object representing a not found remote. I'm mainly used for polimorphism when the well known remote 'origin' is not found in the repository.!
!IceUndefinedRemote methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	url := 'No remote url'.
	projectName := 'No name'.
	name := 'No remote'! !

!IceUndefinedRemote methodsFor: 'accessing' stamp: ''!
host
	^ nil! !

!IceUndefinedRemote methodsFor: 'fetching' stamp: ''!
fetch
	
	IceRemoteNotFoundError new
		remoteName: name;
		signal: 'Please configure a pull remote for pulling.'! !

!IceUndefinedRemote methodsFor: 'accessing' stamp: ''!
upstreamForBranch: aBranch backend: backend
	^ nil! !

!IceUndefinedRemote methodsFor: 'testing' stamp: ''!
isUndefined
	^ true! !

!IceUndefinedRemote class methodsFor: 'testing' stamp: ''!
canHandleUrl: aRepositoryUrl
	^ false! !

!IceUnknownCommit commentStamp: ''!
I represent an commit that cannot be found in the current repository. I have a commit id/hash, but that commit was not fetched (or was wrongly set). Once the real commit is fetched, I'll be becomed into a real commit.!
!IceUnknownCommit methodsFor: 'API - working copy' stamp: ''!
adopt
	
	"Low level.
	For the working copy to adopt myself as reference commit"
	
	self repository workingCopy adoptCommit: self! !

!IceUnknownCommit methodsFor: 'API - changes' stamp: ''!
changesFromCommit: anIceGitCommit 
	^ anIceGitCommit changesFromNoCommit: self! !

!IceUnknownCommit methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	datetime := DateAndTime now! !

!IceUnknownCommit methodsFor: 'accessing' stamp: ''!
id: anObject
	id := anObject! !

!IceUnknownCommit methodsFor: 'accessing' stamp: ''!
fileSystem
	
	^ FileSystem memory root! !

!IceUnknownCommit methodsFor: 'testing' stamp: ''!
isParentOf: aCommit

	^ false! !

!IceUnknownCommit methodsFor: 'testing' stamp: ''!
isUnknownCommit
	
	^ true! !

!IceUnknownCommit methodsFor: 'accessing' stamp: ''!
compatibleUsername
	
	^ 'CompatibleUserName'! !

!IceUnknownCommit methodsFor: 'accessing' stamp: ''!
description
	^ 'Unknown {1}' format: { self shortId }! !

!IceUnknownCommit methodsFor: 'API - project' stamp: ''!
project

	^ repository newUnbornProject! !

!IceUnknownCommit methodsFor: 'accessing' stamp: ''!
comment
	
	^ ''! !

!IceUnknownCommit methodsFor: 'API - changes' stamp: ''!
changesTo: aCommitish

	aCommitish = self
		ifTrue: [ ^ #() ].
	^ aCommitish changesFromNoCommit: self! !

!IceUnknownCommit methodsFor: 'accessing' stamp: ''!
commit
	self shouldBeImplemented.! !

!IceUnknownCommit methodsFor: 'testing' stamp: ''!
isNoCommit
	
	^ false! !

!IceUnknownCommit methodsFor: 'accessing' stamp: ''!
shortId
	
	^ self id first: 7! !

!IceUnknownCommit methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!IceUnknownCommit methodsFor: 'accessing' stamp: ''!
datetime
	
	^ datetime! !

!IceUnknownVersionWorkingCopy methodsFor: 'testing' stamp: ''!
description
	
	^ 'Fetch required. ', self referenceCommit description! !

!IceUnknownVersionWorkingCopy methodsFor: 'testing' stamp: ''!
isDetached
	
	^ true! !

!IceUnknownVersionWorkingCopy methodsFor: 'testing' stamp: ''!
isUnknownCommitState
	
	^ true! !

!IceUrlBuilder methodsFor: 'accessing' stamp: ''!
beGithub
	
	self host: 'github.com'! !

!IceUrlBuilder methodsFor: 'building' stamp: ''!
buildUrl
	
	^ protocol
		composeUrlWithHost: host
		repositoryPath: path! !

!IceUrlBuilder methodsFor: 'accessing' stamp: ''!
path: aString 
	path := aString! !

!IceUrlBuilder methodsFor: 'accessing' stamp: ''!
beGitLab

	self host: 'gitlab.com'! !

!IceUrlBuilder methodsFor: 'accessing' stamp: ''!
beHttps
	
	protocol := IceHttpsProtocol new! !

!IceUrlBuilder methodsFor: 'accessing' stamp: ''!
beSsh
	
	protocol := IceSSHProtocol new! !

!IceUrlBuilder methodsFor: 'accessing' stamp: ''!
protocol: aProtocol 
	protocol := aProtocol! !

!IceUrlBuilder methodsFor: 'accessing' stamp: ''!
host: aString 
	host := aString! !

!IceUrlBuilder methodsFor: 'accessing' stamp: ''!
username: aUsername project: aProject 
	
	path := aUsername, '/', aProject! !

!IceUrlBuilder methodsFor: 'accessing' stamp: ''!
beBitbucket
	
	self host: 'bitbucket.org'! !

!IceUrlProtocol class methodsFor: 'accessing' stamp: ''!
description
	
	^ self subclassResponsibility! !

!IceUrlProtocol class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceUrlProtocol ! !

!IceUrlProtocol class methodsFor: 'accessing - defaults' stamp: ''!
defaultProtocol

	^ IceSSHProtocol! !

!IceUrlProtocol class methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
githubRequestUrlKey
	"Return the key used in github REST responses to get the URL with the correct protocol"
	self subclassResponsibility! !

!IceVersionDoesNotExist commentStamp: ''!
Version does not exist, probably the package was created in a later commit or it was deleted.!
!IceVersionDoesNotExist methodsFor: 'accessing' stamp: ''!
version: anObject
	version := anObject! !

!IceVersionDoesNotExist methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!IceVersionDoesNotExist methodsFor: 'accessing' stamp: ''!
messageText
	^ 'There is no version for package: {1} in  commit {2}' 
		format: { 
			self version packageName.
			self version commit id
		}! !

!IceWarning commentStamp: ''!
I'm a general warning in the context of iceberg UI.!
!IceWarning methodsFor: 'visiting' stamp: ''!
acceptError: aVisitor
	self subclassResponsibility! !

!IceWorkingCopy commentStamp: ''!
I represent and manage all code that is loaded in the current image. My main responsibilities are the bookeeping of loaded packages, the loaded commits, the modification and diffs, and the main entry point for committing code.

!! Adding and Loading Packages

Adding a working copy to a repository is achieved by the message addPackageNamed:

  repository addPackageNamed: aPackageNameString.

I can be later on queried using the following messages

  repository includesPackageNamed: aPackageNameString.
  repository isLoadedPackageNamed: aPackageNameString.

  repository packageNames.

Packages already in a repository can be loaded and unloaded with:

  repository checkoutPackageNamed: aPackageNameString.
  repository unloadPackageNamed: aPackageNameString.

And queried with:

  repository loadedPackages.

!! The Working Copy State

The working copy can be in different states depending on the repository and the package. It is the working copy state reponsibility to decide wether we can commit, if we are on a merge, and so on... The working copy state can be obtained through the message #workingCopyState.

  workingCopy workingCopyState.

The working copy state is calculated every time that it is called. This is because the state of the repository can be modified from outside the system (e.g.,  the command line or another tool). In any case, calculating the working copy state is fast enough to be executed on-line even for big repositories such as Pharo's. The working copy state is calculated from the status of each of its packages. It was decided like this because it may happen that somebody downloads a package from different commits. If this situation changes in the future, this is a good point for simplification.

Working copy states are instances of IceWorkingCopyState. Check it and its subclasses for more information.

!! The Current Commit(s)

A crucial information bookeept by the working copy is the current loaded commit(s). Indeed, depending on the state of the packages and the loaded code, there may be a single current commit or several:

 - having a single commit means that all loaded packages were loaded from the same commit
 - having multiple commits mean that we are in a merge situation
 - having no commit means that no packages were loaded or that they were loaded from another mechanism such as monticello 

In general terms, the current commit should not be accessed directly.

The following methods allow for testing and accessing the current commits:

  repository hasSingleCommit.
  repository hasUnknownCommit.
  repository isInMerge.

  repository referenceCommit.
  repository referenceCommits.

!!  Changes and Committing

The working copy bookkeeps the loaded packages and their state and thus it provides methods to query and commit those changes into the repository.

  repository modifiedPackages.
  repository isModified.

  repository commitWithMessage: aMessageString.
  repository commitChanges: aListOfChanges withMessage: aMessagString.
  repository commitPackages: aListOfPackages withMessage: aMessageString.

NOTICE that commits can only be done if the following is true:

 - repositroy HEAD is not detached (i.e., it is a branch)
 - I am not detached. I.e., my reference commit (in case of a merge, it should be the first one) is the same commit as #headCommit

Such validations can be verified with the following messages

  repository validateCanCommit.
  repository isDetached.

!!  Merging

The main entry point for merging a commit is the working copy, through the method #mergeCommit:. This method will, delegating to the working copy state, verify that the commit needs to be merged, can be merged, and if it has conflicts. In case there are no conflicts an automatic merge will be issued by default.

  workingCopy mergeCommit: aCommit.

IMPORTANT IMPLEMENTATION NOTE. The version information and commits are so far stored inside MCWorkingCopy and co. Check #updatePackage:toCommits:!
!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
addPackageNamed: aString 
	
	self addPackage: (IcePackage named: aString asSymbol repository: repository) beDirty! !

!IceWorkingCopy methodsFor: 'private - changes' stamp: ''!
changesFromCommit: anIceCommit
	"Image changes should be taken into account before changes in the repository"
	^ (self modifiedPackages collect: [ :each | 
			IceImageChange package: each ]) asArray,
				(self referenceCommit changesFromCommit: anIceCommit) asArray! !

!IceWorkingCopy methodsFor: 'private - changes' stamp: ''!
changesFromNoCommit: anIceNoCommit 
	
	^ self packages collect: [ :each | IceImageChange package: each ]! !

!IceWorkingCopy methodsFor: 'private - packages' stamp: ''!
includesInWorkingCopyPackageNamed: aString 
	^ (self packagesDictionary includesKey: aString)
		and: [ (self packageNamed: aString) isLoaded ]! !

!IceWorkingCopy methodsFor: 'API - merging' stamp: ''!
isCommitMerged: aCommit

	^ self workingCopyState isCommitMerged: aCommit! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
packageNamed: aString 
	
	^ self packagesDictionary at: aString! !

!IceWorkingCopy methodsFor: 'API - history' stamp: ''!
commonAncestorWithCommit:  aCommitish
	
	^ self referenceCommit commonAncestorWithCommit: aCommitish! !

!IceWorkingCopy methodsFor: '*Iceberg-TipUI' stamp: ''!
description
	
	^ self workingCopyState description! !

!IceWorkingCopy methodsFor: 'API - commits' stamp: ''!
hasUnknownCommit
	"Returns true if we couldn't calculate a single commit or a merge situation"
	
	^ self workingCopyState isUnknownCommitState! !

!IceWorkingCopy methodsFor: 'API - changes' stamp: ''!
discardChanges
	
	self discardChanges: self diffToReferenceCommit tree! !

!IceWorkingCopy methodsFor: 'API - changes' stamp: ''!
discardChanges: aTree
	
	self loadChangesInWorkingCopy: (aTree collect: [ :definition |
		definition inverse ]).
	self refreshDirtyPackages! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
packageNames
	
	^ self packagesDictionary keys! !

!IceWorkingCopy methodsFor: 'private - monticello' stamp: ''!
snapshotFor: package

	^ (self versionFor: package) snapshot! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
notifyPackageModified: aString 
	self flag: #pharoTodo. "we cannot use #includesPackageNamed: as is because it can happen 
	that a package is present in a commit but not in image yet?"
	
	self shouldIgnoreNotifications ifTrue: [ ^ false ].
	
	(self includesInWorkingCopyPackageNamed: aString)
		ifTrue: [ | package |
			package := self packageNamed: aString.
			package isDirty ifFalse: [ 
				package beDirty.
				^ true ]].
	^ false! !

!IceWorkingCopy methodsFor: 'API - changes' stamp: ''!
canRevertChanges
	
	^ true! !

!IceWorkingCopy methodsFor: 'API - loading' stamp: ''!
loadPackageNamed: aString fromCommit: aCommit

	self loadPackagesNamed: { aString } fromCommit: aCommit! !

!IceWorkingCopy methodsFor: 'API - commits' stamp: ''!
commitChanges: aDiff withMessage: message 
	
	^ self commitChanges: aDiff withMessage: message force: false! !

!IceWorkingCopy methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	shouldIgnoreNotifications := false.
	
	packages := Dictionary new.
	referenceCommit := repository newNoCommit.
	self basicSetProject: referenceCommit project.
	properties := referenceCommit properties asBornProperties! !

!IceWorkingCopy methodsFor: 'private - packages' stamp: ''!
refreshPackages
	| commitPackages |
	commitPackages := self referenceCommit isCollection
		ifTrue: [ (self referenceCommit flatCollect: [ :each | each packages ]) asSet ]
		ifFalse: [ self referenceCommit project packages ].

	"remove packages that are not there anymore"
	(self packages \ commitPackages) do: [ :each | self basicRemovePackage: each ].
	"Add packages not already there"
	(commitPackages \ self packages) do: [ :each | self basicAddPackage: each ].
! !

!IceWorkingCopy methodsFor: 'API - loading' stamp: ''!
unloadPackage: aPackage

	aPackage mcWorkingCopy ifNotNil: #unload! !

!IceWorkingCopy methodsFor: 'accessing' stamp: ''!
fileSystem
	
	^ repository location ifNil: [ FileSystem memory root ]! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
addPackage: aPackage
	
	self basicAddPackage: aPackage.
	aPackage beDirty.! !

!IceWorkingCopy methodsFor: 'API - changes' stamp: ''!
diffTo: aCommitish

	^ IceDiff
		from: self
		to: aCommitish commit! !

!IceWorkingCopy methodsFor: 'API - changes' stamp: ''!
isModified
	^ self project isDirty or: [ self loadedPackages anySatisfy: [ :e | e isDirty ] ]! !

!IceWorkingCopy methodsFor: 'API - commits' stamp: ''!
commitChanges: aDiff withMessage: message force: forcing 

	"Creates a commit with the given changes using the comment given as argument.
	The forcing parameter allows to create an empty commit. This is used by the merge.
	
	NOTICE that commits can only be done if the following is true:

 - HEAD is a branch
 - the working copy reference commit is the same commit as #headCommit"

	| newCommit |
	self validateCanCommit.
	self repository index
		updateDiskWorkingCopy: aDiff;
		updateIndex: aDiff.

	(forcing not and: [repository index isEmpty]) 
		ifTrue: [ IceNothingToCommit signal ].

	newCommit := self repository
		commitIndexWithMessage: message
		andParents: (self workingCopyState referenceCommits reject: [ :each | each isNoCommit ]).
	^ newCommit! !

!IceWorkingCopy methodsFor: 'API - properties' stamp: ''!
repositoryProperties
	
	^ properties! !

!IceWorkingCopy methodsFor: 'API - loading' stamp: ''!
unload
	
	"Unload all code loaded into the image that belong to this repository"
	self loadedPackages do: [ :each | self unloadPackage: each ]! !

!IceWorkingCopy methodsFor: 'API - commits' stamp: ''!
hasSingleCommit
	"Returns true if all loaded packages were loaded from the single same commit"
	
	^ self workingCopyState isSingleCommitState! !

!IceWorkingCopy methodsFor: 'private - impacting changes' stamp: ''!
removeMethod: anIceMethodDefinition 
	
	anIceMethodDefinition asMCDefinition unload! !

!IceWorkingCopy methodsFor: 'accessing' stamp: ''!
rootFileReference
	
	^ repository location! !

!IceWorkingCopy methodsFor: 'private - monticello' stamp: ''!
loadPackagesNamed: aCollection fromCommit: aCommit
	
	self ignoreNotificationsDuring: [ | loader |
		loader := MCVersionLoader new.
		aCollection do: [ :name | | package packageVersion |
			package := self packageNamed: name.
			packageVersion := (IceSavedPackageVersion
				fromCommit: aCommit
				package: package)
					mcVersion.
			loader addVersion: packageVersion.
			package beClean.
		].
		loader load ]! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
markAllPackagesAsClean
	
	self markAsCleanPackagesThat: [ :each | true ]! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
basicRemovePackage: aPackage
	
	self packagesDictionary 
		removeKey: aPackage name 
		ifAbsent: []! !

!IceWorkingCopy methodsFor: 'private - impacting changes' stamp: ''!
removeClassNamed: aString 
	
	"Impact the system.
	This should be enhanced"
	(Smalltalk globals at: aString ifAbsent: [ ^ self ]) removeFromSystem! !

!IceWorkingCopy methodsFor: 'API - properties' stamp: ''!
refreshRepositoryProperties
	
	properties := self referenceCommit properties asBornProperties.
! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
markAsCleanPackagesNotInDiff: aDiff
	
	self markAsCleanPackagesThat: [ :each |
		(aDiff includesPackageNamed: each name) not ]! !

!IceWorkingCopy methodsFor: 'private - monticello' stamp: ''!
applyDefinition: anIceDefinition inNode: aNode

	| loader |
	(anIceDefinition isFileDefinition
		or: [ anIceDefinition isDirectoryDefinition ])
			ifTrue: [ ^ self ].
	loader := MCPackageLoader new.
	loader addDefinition: anIceDefinition asMCDefinition.
	loader load! !

!IceWorkingCopy methodsFor: 'initialization' stamp: ''!
initializePackagesFromRepository
	"If no reference commit was configured, we adopt the head commit"
	| commitToAdopt |
	commitToAdopt := referenceCommit isNoCommit
		ifTrue: [ self repository headCommit ]
		ifFalse: [ referenceCommit ].
	self adoptCommit: commitToAdopt.! !

!IceWorkingCopy methodsFor: 'private - monticello' stamp: ''!
snapshotForPackage: aPackage 
	
	^ aPackage isLoaded
		ifTrue: [ (MCPackage named: aPackage name) basicSnapshot ]
		ifFalse: [ self referenceCommit snapshotForPackage: aPackage ]! !

!IceWorkingCopy methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceWorkingCopy methodsFor: 'validating' stamp: ''!
validateCanCommit
	"Verify sync between image version and working copy"	
	"If there are incomming commits is out of sync"
	
	"Check that head is not detached"
	self repository validateCanCommit.
	
	"Check that our current state lets us commit"
	self workingCopyState validateCanCommit! !

!IceWorkingCopy methodsFor: 'private - project' stamp: ''!
basicSetProject: aProject

	project := aProject! !

!IceWorkingCopy methodsFor: 'API - loading' stamp: ''!
loadPackageNamed: aString 
	
	self loadPackagesNamed: { aString }! !

!IceWorkingCopy methodsFor: 'API - history' stamp: ''!
commonAncestorWith: aCommitish
	
	^ self referenceCommit commonAncestorWith: aCommitish! !

!IceWorkingCopy methodsFor: 'API - project' stamp: ''!
project: anIceProject

	self basicSetProject: anIceProject.
	self refreshProject.! !

!IceWorkingCopy methodsFor: 'API - commits' stamp: ''!
isInMerge
	"Returns true if all the repository packages are in merge between the same commits."
	
	^ self workingCopyState isInMerge! !

!IceWorkingCopy methodsFor: 'private - changes' stamp: ''!
loadChangesInWorkingCopy: aTree
	
	| visitor |
	visitor := IceWorkingCopyPatcherVisitor on: self repository.
	aTree accept: visitor.
	
	self ignoreNotificationsDuring: [
		visitor load.
	]
! !

!IceWorkingCopy methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceWorkingCopy methodsFor: 'API - commits' stamp: ''!
referenceCommit
	
	^ referenceCommit! !

!IceWorkingCopy methodsFor: 'accessing' stamp: ''!
refreshProjectFromRepository

	| commitToCheck maybeProject |
	commitToCheck := referenceCommit isCollection
		ifTrue: [ referenceCommit first ]
		ifFalse: [ referenceCommit ].

	maybeProject := commitToCheck project.
	maybeProject isInvalid ifFalse: [ 
		self basicSetProject: maybeProject ].
	
	properties := commitToCheck properties asBornProperties.
	self refreshProject.
	^ project! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
packages
	
	^ self packagesDictionary values! !

!IceWorkingCopy methodsFor: 'private - packages' stamp: ''!
ignoreNotificationsDuring: aBlock
	"While the working copy is loading code, it should ignore modifications to avoid circular refreshes"

	| oldValue |
	oldValue := shouldIgnoreNotifications.
	shouldIgnoreNotifications := true.
	aBlock ensure: [ shouldIgnoreNotifications := oldValue ]! !

!IceWorkingCopy methodsFor: 'private - project' stamp: ''!
refreshProject

	repository commitsInPackageCache: nil.
	self refreshPackages! !

!IceWorkingCopy methodsFor: 'validating' stamp: ''!
isDetached

	^ self workingCopyState isDetached! !

!IceWorkingCopy methodsFor: 'API - changes' stamp: ''!
changesTo: aCommitish

	| removedPackages changes |
	changes := Set new.
	
	changes addAll: (aCommitish changesFromCommit: self referenceCommit).
	removedPackages := aCommitish packages \ self packages.
	changes addAll: (((self modifiedPackages, removedPackages) collect: [ :each | 
			IceImageChange package: each ])).
		
	self project isDirty
		ifTrue: [ changes add: IceProjectChange new ].
	self repositoryProperties isDirty
		ifTrue: [ changes add: IceCypressPropertiesChange new ].
	^ changes! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
addPackages: aCollection 
	
	aCollection keysDo: [ :each | self addPackageNamed: each ]! !

!IceWorkingCopy methodsFor: 'API - loading' stamp: ''!
loadPackagesNamed: aCollection 
	
	self
		loadPackagesNamed: aCollection
		fromCommit: self repository head commit! !

!IceWorkingCopy methodsFor: 'private - notifications' stamp: ''!
shouldIgnoreNotifications
	^ shouldIgnoreNotifications = true! !

!IceWorkingCopy methodsFor: 'API - loading' stamp: ''!
unloadPackageNamed: aPackageName

	self unloadPackage: (IcePackage named: aPackageName repository: repository)
	! !

!IceWorkingCopy methodsFor: 'accessing' stamp: ''!
workingCopyState
	"The working copy can be in different states depending on the repository and the package. It is the working copy state reponsibility to decide wether we can commit, if we are on a merge, and so on... The working copy state can be obtained through the message #workingCopyState.

  workingCopy workingCopyState.

The working copy state is calculated every time that it is called. This is because the state of the repository can be modified from outside the system (e.g.,  the command line or another tool). In any case, calculating the working copy state is fast enough to be executed on-line even for big repositories such as Pharo's. The working copy state is calculated from the status of each of its packages. It was decided like this because it may happen that somebody downloads a package from different commits. If this situation changes in the future, this is a good point for simplification."

	"This method obtains the head commit once and sends it as argument as an optimization.
	This is because asking for the head commit is expensive.
	
	Check the commits of #packageState"

	referenceCommit isCollection
		ifTrue: [ ^ IceInMergeWorkingCopy repository: repository ].
	referenceCommit isUnknownCommit
		ifTrue: [ ^ IceUnknownVersionWorkingCopy repository: repository ].
	referenceCommit isNoCommit
		ifTrue: [ ^ IceEmptyWorkingCopy repository: repository ].
	^ IceAttachedSingleVersionWorkingCopy repository: repository! !

!IceWorkingCopy methodsFor: 'private - monticello' stamp: ''!
mcVersionFor: anIceSavedPackageVersion 

	| mcPackage mcWorkingCopy |
	mcPackage := anIceSavedPackageVersion mcPackage.
	mcWorkingCopy := mcPackage workingCopy.
	^ MCVersion new
		setPackage: anIceSavedPackageVersion mcPackage
		info: mcWorkingCopy versionInfo
		snapshot: mcWorkingCopy snapshot
		dependencies: #()! !

!IceWorkingCopy methodsFor: 'API - commits' stamp: ''!
commitWithMessage: aString 
	"Creates a commit with all changed code using the comment given as argument.
	
	NOTICE that commits can only be done if the following is true:

 - HEAD is a branch
 - the working copy reference commit is the same commit as #headCommit"
	
	^ self
		commitChanges: self repository workingCopyDiff
		withMessage: aString! !

!IceWorkingCopy methodsFor: 'API - changes' stamp: ''!
modifiedPackages

	^ self loadedPackages select: [ :e | e isDirty ]! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
refreshDirtyPackages
	self markAsCleanPackagesNotInDiff: self repository workingCopyDiff! !

!IceWorkingCopy methodsFor: 'API - changes' stamp: ''!
forceCalculateDirtyPackages

	| diff |
	diff := IceDiff new
		sourceVersion: self;
		targetVersion: self referenceCommit;
		buildFull.

	self loadedPackages do: [ :each |
		each beDirty: (diff includesPackageNamed: each name) ].! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
isLoadedPackageNamed: aString 
	
	^ RPackageOrganizer default includesPackageNamed: aString! !

!IceWorkingCopy methodsFor: 'API - loading' stamp: ''!
checkout: aCheckoutStrategy
	
	aCheckoutStrategy checkoutOn: self! !

!IceWorkingCopy methodsFor: 'API - merging' stamp: ''!
mergeCommit: aCommit
	
	^ self workingCopyState mergeCommit: aCommit! !

!IceWorkingCopy methodsFor: 'API - commits' stamp: ''!
referenceCommits
	"Returns a collection with all current loaded commits.
	If we are in a single commit state, return a collection with only one element."
	
	^ { referenceCommit }! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
basicAddPackage: aPackage
	
	self packagesDictionary at: aPackage name put: aPackage.! !

!IceWorkingCopy methodsFor: 'API - project' stamp: ''!
project
	
	"For backwards compatibility, if we don't find a project, take the project from HEAD"
	^ project ifNil: [ self refreshProjectFromRepository ]! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
markAsCleanPackagesThat: aBlock
	
	self modifiedPackages do: [ :each |
		(aBlock value: each) ifTrue: [ each beClean ] ]! !

!IceWorkingCopy methodsFor: 'API - properties' stamp: ''!
properties
	^ properties! !

!IceWorkingCopy methodsFor: 'API - changes' stamp: ''!
diffToReferenceCommit

	^ self diffTo: self referenceCommit! !

!IceWorkingCopy methodsFor: 'private - monticello' stamp: ''!
versionFor: package

	^ IceSavedPackageVersion fromCommit: self package: package! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
includesPackageNamed: aString 
	"true if is in image or is in commit"
	^ self includesInWorkingCopyPackageNamed: aString! !

!IceWorkingCopy methodsFor: 'API - loading' stamp: ''!
loadAllPackages
	
	self loadPackagesNamed: repository head packageNames! !

!IceWorkingCopy methodsFor: 'API - loading' stamp: ''!
loadedPackages

	^ self packages select: #isLoaded! !

!IceWorkingCopy methodsFor: 'accessing' stamp: ''!
referenceCommit: aCommit

	self referenceCommit = aCommit
		ifTrue: [ ^ self ].

	referenceCommit := aCommit.
	self refreshProjectFromRepository! !

!IceWorkingCopy methodsFor: 'private - commits' stamp: ''!
setMergeStateBetweenCommits: aCollection 
	
	self referenceCommit: aCollection! !

!IceWorkingCopy methodsFor: 'testing' stamp: ''!
isWorkingCopy
	
	^ true! !

!IceWorkingCopy methodsFor: 'API - properties' stamp: ''!
writerClass
	
	^ self referenceCommit writerClass! !

!IceWorkingCopy methodsFor: 'API - packages' stamp: ''!
markAsDirtyPackageNamed: aPackageName

	(self packageNamed: aPackageName) beDirty
	
	! !

!IceWorkingCopy methodsFor: 'private - packages' stamp: ''!
packagesDictionary

	^ packages! !

!IceWorkingCopy methodsFor: 'accessing' stamp: ''!
adoptCommit: aCommit

	| oldCommit |
	self referenceCommit = aCommit
		ifTrue: [ ^ self ].

	oldCommit := self referenceCommit.
	self referenceCommit: aCommit.
	
	"If both commits are from a different class but still have the same ID, we do not need to force the calculation of dirty packages.
	This is required for the case when a working copy existed with an unknown comit but it was not linked to a repository"
	(oldCommit isNoCommit not and: [ oldCommit id = aCommit id ])
		ifFalse: [ self forceCalculateDirtyPackages. ]! !

!IceWorkingCopy class methodsFor: 'instance creation' stamp: ''!
fromWorkingCopy: aWorkingCopy
	^ self basicNew 
		repository: aWorkingCopy repository; 
		initialize;
		project: aWorkingCopy project;
		yourself! !

!IceWorkingCopy class methodsFor: 'instance creation' stamp: ''!
repository: repository
	^ self basicNew 
		repository: repository; 
		initialize;
		yourself! !

!IceWorkingCopyDesyncronized commentStamp: ''!
I indicate when a working copy is desyncronized. 
It means the version I have in the image is different to the version I have in the working copy.!
!IceWorkingCopyDesyncronized methodsFor: 'visiting' stamp: ''!
acceptError: anObject
	anObject visitWorkingCopyDesynchronizedError: self! !

!IceWorkingCopyPatcherVisitor commentStamp: ''!
I visit a tree of changes and apply those changes to the working copy.!
!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitFileNode: anIceFileDefinition
	
	"Ignore files, they are not loaded in the image"! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitDirectoryDefinition: anIceDirectoryDefinition

	self visitChildrenOf: currentNode! !

!IceWorkingCopyPatcherVisitor methodsFor: 'loading' stamp: ''!
load
	loader load! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitNonConflictingOperation: anIceNonConflictingOperation 
	
	^ anIceNonConflictingOperation chosenOperation accept: self! !

!IceWorkingCopyPatcherVisitor methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	loader := MCPackageLoader new! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
removeFileReferenceInPath: anUndefinedObject 
	
	"I do not remove nothing from the file in the image"! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitPackage: anIcePackageDefinition
	
	(self repository packageNamed: anIcePackageDefinition name) isLoaded
		ifFalse: [ ^ self ].
	
	currentNode accept: (IceMCSnapshotPatchVisitor new
		patcher: loader;
		yourself).! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitRemoval: anIceRemoval 
	
	anIceRemoval definition removeFrom: self.
	self visitChildrenOf: currentNode! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitClassDefinition: anIceClassDefinition 
	
	repository workingCopy applyDefinition: anIceClassDefinition inNode: currentNode.
	self visitChildrenOf: currentNode.! !

!IceWorkingCopyPatcherVisitor methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitAddition: anIceAddition 
	
	repository workingCopy applyDefinition: anIceAddition definition inNode: currentNode! !

!IceWorkingCopyPatcherVisitor methodsFor: 'removing' stamp: ''!
removeFile: anIceFileDefinition 
	"I do not remove nothing from the file in the image"! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitRootDefinition: anIceRootDefinition 
	
	self visitChildrenOf: currentNode! !

!IceWorkingCopyPatcherVisitor methodsFor: 'actions' stamp: ''!
removeMethod: anIceMethodDefinition 

	repository workingCopy removeMethod: anIceMethodDefinition! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitMethodNode: anIceMethodDefinition 

	repository workingCopy applyDefinition: anIceMethodDefinition inNode: currentNode! !

!IceWorkingCopyPatcherVisitor methodsFor: 'operations' stamp: ''!
removePackage: anIcePackageDefinition 
	
	repository workingCopy unloadPackageNamed: anIcePackageDefinition name! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitModification: anIceModification 
	
	anIceModification definition accept: self! !

!IceWorkingCopyPatcherVisitor methodsFor: 'visiting' stamp: ''!
visitNoModification: anIceNoModification 

	anIceNoModification definition accept: self! !

!IceWorkingCopyPatcherVisitor methodsFor: 'actions' stamp: ''!
removeClass: anIceClassDefinition 
	
	repository workingCopy removeClassNamed: anIceClassDefinition name! !

!IceWorkingCopyPatcherVisitor methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!IceWorkingCopyPatcherVisitor class methodsFor: 'instance creation' stamp: ''!
on: aRepository
	^ self new 
		repository: aRepository;
		yourself! !

!IceWorkingCopyState commentStamp: ''!
I represent the state of a working copy. I have several methods to combine myself with package states and generate new working copy states.!
!IceWorkingCopyState methodsFor: 'accessing' stamp: ''!
workingCopy
	
	^ repository workingCopy! !

!IceWorkingCopyState methodsFor: 'testing' stamp: ''!
isCommitMerged: aCommit

	self subclassResponsibility! !

!IceWorkingCopyState methodsFor: 'testing' stamp: ''!
isInMerge
	
	^ false! !

!IceWorkingCopyState methodsFor: 'merging' stamp: ''!
mergeCommit: aCommit
	
	self subclassResponsibility! !

!IceWorkingCopyState methodsFor: 'testing' stamp: ''!
isSingleCommitState
	
	^ false! !

!IceWorkingCopyState methodsFor: 'displaying' stamp: ''!
description

	self subclassResponsibility! !

!IceWorkingCopyState methodsFor: 'accessing' stamp: ''!
referenceCommit
	
	^ repository workingCopy referenceCommit! !

!IceWorkingCopyState methodsFor: 'accessing' stamp: ''!
referenceCommits
	
	^ { self referenceCommit }! !

!IceWorkingCopyState methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!IceWorkingCopyState methodsFor: 'merging' stamp: ''!
mergeStateWith: aMergeableState
	
	self subclassResponsibility! !

!IceWorkingCopyState methodsFor: 'testing' stamp: ''!
isDetached
	
	^ self subclassResponsibility! !

!IceWorkingCopyState methodsFor: 'validating' stamp: ''!
validateCanCommit
	
	self subclassResponsibility! !

!IceWorkingCopyState methodsFor: 'testing' stamp: ''!
isUnknownCommitState
	
	^ false! !

!IceWorkingCopyState methodsFor: 'accessing' stamp: ''!
repository: anIceLibgitRepository 
	repository := anIceLibgitRepository! !

!IceWorkingCopyState class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == IceWorkingCopyState ! !

!IceWorkingCopyState class methodsFor: 'accessing' stamp: ''!
repository: aRepository 

	^ self new
		repository: aRepository;
		yourself! !

!IceWrongUrl commentStamp: ''!
We can not parse the origin URL you have introduced. Maybe you made a typo, or maybe we do not support that kind of URLs.!
!Iceberg commentStamp: ''!
I am a cache providing access to several Ice objects, such as packages, repositories, working copies, etc.

Public API and Key Messages

- message one   
- message two 
- (for bonus points) how to create instances.

   One simple example is simply gorgeous.
 
Internal Representation and Key Implementation Points.


    Implementation Points!
!Iceberg class methodsFor: 'accessing' stamp: ''!
remoteTypeSelector
	"Should be #scpURL or #httpsURL"
	^ RemoteTypeSelector ifNil: [ RemoteTypeSelector := #scpUrl ]! !

!Iceberg class methodsFor: 'settings' stamp: ''!
showSystemRepositories: aBoolean
	ShowSystemRepositories := aBoolean! !

!Iceberg class methodsFor: 'class initialization' stamp: ''!
initialize
	self initializeSettings! !

!Iceberg class methodsFor: 'updating' stamp: ''!
update
	#(Iceberg LGitRepository MCFileTreeGitRepository) do: [:className | 
		Smalltalk 
			at: className 
			ifPresent: [ :class | class package iceRepository pull ] ]! !

!Iceberg class methodsFor: 'accessing' stamp: ''!
mcRepositoryFor: aLocationString
	^ (IceMetacelloRepositoryType for: aLocationString) mcRepository ! !

!Iceberg class methodsFor: 'accessing' stamp: ''!
icebergRepositoriesURLs
	^ {
		'git@github.com:pharo-vcs/iceberg.git'. 
		'git@github.com:pharo-vcs/filetree.git'.
		'git@github.com:pharo-vcs/libgit2-pharo-bindings.git'
	}! !

!Iceberg class methodsFor: 'class initialization' stamp: ''!
initializeSettings
	Smalltalk 
		at: #SystemSettingsPersistence 
		ifPresent: [ :class | | tree nodes | 
			tree := class default settingTree.
			nodes := tree deeplySelect: [ :node | node receiverPackage name beginsWith: 'Iceberg' ].
			class updateSettingNodes: nodes ]! !

!Iceberg class methodsFor: 'settings' stamp: ''!
showSystemRepositories
	^ ShowSystemRepositories ifNil: [ ShowSystemRepositories := false ]! !

!Iceberg class methodsFor: 'accessing' stamp: ''!
bootstrap
	| metacelloRegistrationEntry |
	metacelloRegistrationEntry := MetacelloProjectRegistration registry baselineRegistry at: 'BaselineOfIceberg'.
	self
		bootstrapWithCommitId: metacelloRegistrationEntry currentVersionString
		packageList: (metacelloRegistrationEntry baselineProjectSpec version packages collect: #name)! !

!Iceberg class methodsFor: 'accessing' stamp: ''!
bootstrapWithCommitId: commitId packageList: packageNameList

	| commit repository |
	repository := IceLibgitRepository new.
	commit := IceUnknownCommit new
		id: commitId;
		repository: repository;
 		yourself.
		
	repository name: 'iceberg'.
	repository workingCopy referenceCommit: commit.
	commit repository: repository.
	
	packageNameList do: [ :each |
		repository workingCopy basicAddPackage: (IcePackage
			named: each
			repository: repository) ].
	
	repository register! !

!Iceberg class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #Iceberg)
		parent: #SCM;
		with: [ (aBuilder setting: #enableMetacelloIntegration)
				target: self;
				order: 0.1;
				default: true;
				label: 'Enable Metacello integration';
				description: 'If selected, Metacello github:// repositories will be loaded using iceberg';
				with: [ 
					(aBuilder pickOne: #remoteTypeSelector)
						label: 'Remote type';
						description: 'When creating an Iceberg repository out of a github:// URL choose whether you want to user an SCP URL (i.e. with the form ''git@github.com:<username>/<project>.git'') or an HTTPS URL (i.e. with the form ''https://github.com/<username>/<project>.git''';
						domainValues:
							{('SCP (git@github.com:<username>/<project>.git)' -> #scpUrl).
							('HTTPS (https://github.com/<username>/<project>.git)' -> #httpsUrl).
							('HTTP (http://github.com/<username>/<project>.git)' -> #httpUrl)} ] ]! !

!Iceberg class methodsFor: 'accessing' stamp: ''!
repositoryForPackage: anRPackage 
	| existingRepositories possibleRepositoryTypes |
	
	existingRepositories := (MCWorkingCopy forPackage: anRPackage mcPackage) repositoryGroup repositories.
	possibleRepositoryTypes := IceRepository allSubclasses, 
		{ IceMetacelloRepositoryAdapter. 
		  MCGitHubRepository }.
	
	possibleRepositoryTypes do: [ :class |
		existingRepositories 
			detect: [ :repo | repo isKindOf: class ]
			ifFound: [ : repo |  ^ repo getOrCreateIcebergRepository ] ].

	self error: ('Could not find a git repository for {1}' format: {anRPackage name})
	! !

!Iceberg class methodsFor: 'settings' stamp: ''!
enableMetacelloIntegration
	^ EnableMetacelloIntegration ifNil: [ EnableMetacelloIntegration := true ]! !

!Iceberg class methodsFor: 'accessing' stamp: ''!
packageForCategoryNamed: categoryName
	| systemPackage |
	systemPackage := RPackageOrganizer default packageMatchingExtensionName: categoryName.
	^ self packageNamed: systemPackage name
! !

!Iceberg class methodsFor: 'settings' stamp: ''!
enableMetacelloIntegration: anObject
	EnableMetacelloIntegration := anObject! !

!Iceberg class methodsFor: 'accessing' stamp: ''!
announcer
	^ icebergAnnouncer ifNil: [ icebergAnnouncer := IceAnnouncer new ]! !

!Iceberg class methodsFor: 'accessing' stamp: ''!
remoteTypeSelector: anObject
	RemoteTypeSelector := anObject! !

!IconListPresenter commentStamp: ''!
An IconListPresenter is a spec presenter for icon list.
See AbstractWidgetPresenter

self example

You can also have a look at ExampleListPresenter >> exampleIconList for another example.

I provide the following variables icons and its accessors, it is a block that convert an item in the icon to display near the item.

todo
- getIconFor:!
!IconListPresenter methodsFor: 'api' stamp: ''!
icons
	"<api: #inspect>"
	"Return the block which takes an item as argument and returns the icon to display in the list"
	
	^ iconHolder value! !

!IconListPresenter methodsFor: 'api' stamp: ''!
icons: aBlock
	"<api: #block getter: #icon registration: #whenIconsChanged: >"
	"Set a block which takes an item as argument and returns the icon to display in the list"
	iconHolder value: aBlock! !

!IconListPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	iconHolder := [:item | nil ] asValueHolder.! !

!IconListPresenter methodsFor: 'api' stamp: ''!
getIconFor: anItem

	^ iconHolder value cull: anItem cull: self! !

!IconListPresenter methodsFor: 'api - events' stamp: ''!
whenIconsChanged: aBlock 
	
	iconHolder whenChangedDo: aBlock 

! !

!IconListPresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self new.
	example
		icons: [ :e | example iconNamed: #forwardIcon ];
		items: (1 to: 10) asArray;
		openWithSpec.
	^ example! !

!IconListPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(IconListAdapter
		adapt: #(model))! !

!IconListPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #IconListAdapter! !

!IconSetChanged commentStamp: ''!
I'm announced when an IconSet has been changed. !
!IconStyler commentStamp: ''!
I'm in charge to styling an ast with highlighting. To highglight something I need the rubric text model in textModel.
!
!IconStyler methodsFor: 'visiting' stamp: ''!
visitInstanceVariableNode: aSelfNode 
	self addIconStyle: aSelfNode.
	super visitInstanceVariableNode: aSelfNode.! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode 
	self addIconStyle: aBlockNode.
	super visitBlockNode: aBlockNode.! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode 
	self addIconStyle: aSequenceNode.
	super visitSequenceNode: aSequenceNode.! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitGlobalNode: aSelfNode 
	self addIconStyle: aSelfNode.
	super visitGlobalNode: aSelfNode.! !

!IconStyler methodsFor: 'accessing' stamp: ''!
textModel
	^ textModel! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitReturnNode: aReturnNode 
	self addIconStyle: aReturnNode.
	super visitReturnNode: aReturnNode ! !

!IconStyler methodsFor: 'styling' stamp: ''!
addIconMethodStyle: aMethodNode
	self addIconStyle: aMethodNode from: 1 to: 0! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: anAssignmentNode 
	self addIconStyle: anAssignmentNode.
	super visitAssignmentNode: anAssignmentNode.! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitCascadeNode: aCascadeNode 
	self addIconStyle: aCascadeNode.
	super visitCascadeNode: aCascadeNode.! !

!IconStyler methodsFor: 'hooks' stamp: ''!
segmentMorphClass

	^ RubTextSegmentMorph! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitLiteralNode: aLiteralNode 
	self addIconStyle: aLiteralNode.
	super visitLiteralNode: aLiteralNode.! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode 
	self addIconMethodStyle: aMethodNode.
	super visitMethodNode: aMethodNode.! !

!IconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^(Color green alpha: 0.1)! !

!IconStyler methodsFor: 'styling' stamp: ''!
addIconStyle: aNode from: start to: stop
	
	self addIconStyle: aNode from: start to: stop color: self highlightColor ! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitPragmaNode: aPragmaNode 
	self addIconStyle: aPragmaNode.
	super visitPragmaNode: aPragmaNode.! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitParseErrorNode: anErrorNode 
	self addIconStyle: anErrorNode.
	super visitParseErrorNode: anErrorNode.! !

!IconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^false ! !

!IconStyler methodsFor: 'defaults' stamp: ''!
borderColor 
	^Color gray! !

!IconStyler methodsFor: 'styling' stamp: ''!
styleText: aTextModel withAst: ast
	"style the AST using the textmodel passed as first argument. Ask all the registered stylers to act."
	
	stylerClasses do: [ :styleClass | 
		 ast acceptVisitor: (styleClass new textModel: aTextModel) ]! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitThisContextNode: aThisContextNode 
	self addIconStyle: aThisContextNode.
	super visitThisContextNode: aThisContextNode.! !

!IconStyler methodsFor: 'styling' stamp: ''!
addIconStyle: aNode from: start to: stop color: aColor

	| conf |
	(self shouldStyleNode: aNode) ifFalse: [ ^ self ].
	conf := RubConfigurationChange new.
	conf configurationBlock: [ :text | 
		| r |
		r := self segmentMorphClass from: start to: stop + 1.
		text addSegment: r.
		r label: (self iconLabelBlock: aNode).
		r icon: (self iconFor: aNode).
		r iconBlock: (self iconBlock: aNode).
		r color: aColor.
		r borderColor: self borderColor ].
	textModel announce: conf! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitTemporaryNode: aNode 
	self addIconStyle: aNode.
	super visitTemporaryNode: aNode.! !

!IconStyler methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self resetStylerClasses! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitEnglobingErrorNode: anEnglobingNode
	self addIconStyle: anEnglobingNode.
	anEnglobingNode content do: [ :each | self visitNode: each ]! !

!IconStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	^ [ ] ! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aRBLiteralArrayNode 
	self addIconStyle: aRBLiteralArrayNode.
	super visitLiteralArrayNode: aRBLiteralArrayNode.! !

!IconStyler methodsFor: 'defaults' stamp: ''!
iconLabelBlock: aNode
	^ [self iconLabel: aNode]! !

!IconStyler methodsFor: 'accessing' stamp: ''!
stylerClasses: anObject
	stylerClasses := anObject! !

!IconStyler methodsFor: 'styling' stamp: ''!
addIconStyle: aNode
	self addIconStyle: aNode from: aNode start to: aNode stop.! !

!IconStyler methodsFor: 'accessing' stamp: ''!
stylerClasses
	^ stylerClasses! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitArgumentNode: anArgumentNode 
	self addIconStyle: anArgumentNode.
	super visitArgumentNode: anArgumentNode.! !

!IconStyler methodsFor: 'initialization' stamp: ''!
resetStylerClasses
	stylerClasses := OrderedCollection new! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitArrayNode: anArrayNode 
	self addIconStyle: anArrayNode.
	super visitArrayNode: anArrayNode.! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitSuperNode: aSuperNode 
	self addIconStyle: aSuperNode.
	super visitSuperNode: aSuperNode.! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitSelfNode: aSelfNode 
	self addIconStyle: aSelfNode.
	super visitSelfNode: aSelfNode ! !

!IconStyler methodsFor: 'styling' stamp: ''!
styleAst: ast
	"Style the AST using the textmodel of the receiver. Ask all the registered stylers to act."
	
	stylerClasses do: [ :styleClass | 
			ast acceptVisitor: (styleClass new textModel: textModel) ]! !

!IconStyler methodsFor: 'visiting' stamp: ''!
visitMessageNode: aMessageNode 
	self addIconStyle: aMessageNode.
	super visitMessageNode: aMessageNode.! !

!IconStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode
	^ ''! !

!IconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^nil! !

!IconStyler methodsFor: 'accessing' stamp: ''!
textModel: anObject
	textModel := anObject! !

!IconStyler class methodsFor: 'style' stamp: ''!
withStaticStylers
	"Configure the receiver to invoke several static stylers. Now it is probably better to use the instance API:
	
	IconStyler new
		stylerClasses: { YourLovelyStyler };
		styleText: aTextModel withAST: anAST
	"
	
	^ self new 
		stylerClasses:  {BreakpointIconStyler. CounterIconStyler. DisabledBreakpointIconStyler. FlagIconStyler. HaltIconStyler. MetaLinkIconStyler. SemanticWarningIconStyler. WatchIconStyler. DocCommentIconStyler}; 
		yourself
! !

!IconicButton commentStamp: ''!
A "Simple Button" in which the appearance is provided by a Form.!
!IconicButton class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!IconicButtonMorph commentStamp: ''!
A "Simple Button" in which the appearance is provided by a Form.!
!IconicButtonMorph methodsFor: 'mouse events' stamp: ''!
mouseOverBorderStyle
	"Answer the border style to use whilst the mouse
	is over the receiver."

	^mouseOverBorderStyle ifNil: [BorderStyle thinGray]! !

!IconicButtonMorph methodsFor: 'accessing' stamp: ''!
labelGraphic

	^ graphicalMorph form! !

!IconicButtonMorph methodsFor: 'updating' stamp: ''!
update: aSelector
	
	aSelector = self interactSelector
		ifTrue: [ ^ self doButtonAction ].
		
	super update: aSelector! !

!IconicButtonMorph methodsFor: 'accessing' stamp: ''!
graphicalMorph

	^ graphicalMorph! !

!IconicButtonMorph methodsFor: 'mouse events' stamp: ''!
mouseLeave: evt
	"Reinstate the old border style."

	oldBorderStyle ifNil: [^self borderNormal].
	self borderStyle: oldBorderStyle. 
	oldBorderStyle := nil.! !

!IconicButtonMorph methodsFor: 'updating' stamp: ''!
themeChanged

	"do nothing for now"! !

!IconicButtonMorph methodsFor: 'initialization' stamp: ''!
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.! !

!IconicButtonMorph methodsFor: 'menu' stamp: ''!
addLabelItemsTo: aCustomMenu hand: aHandMorph
	"don't do the inherited behavior, since there is no textual label in this case"! !

!IconicButtonMorph methodsFor: 'mouse events' stamp: ''!
handlesMouseOver: anEvent
	"Answer true, otherwise what is all that
	#mouseEnter:/#mouseLeave: stuff about?"

	^true! !

!IconicButtonMorph methodsFor: 'updating' stamp: ''!
interactSelector

	 ^ #interact! !

!IconicButtonMorph methodsFor: 'accessing' stamp: ''!
shedSelvedge
	self extent: (self extent - (6@6))! !

!IconicButtonMorph methodsFor: 'accessing' stamp: ''!
defaultGraphics

	^  DefaultGraphics! !

!IconicButtonMorph methodsFor: 'geometry' stamp: ''!
extent: newExtent
	"Update the graphic position to keep centered."
	
	super extent: newExtent.
	graphicalMorph ifNotNil: [graphicalMorph position: self center - (graphicalMorph extent // 2)]! !

!IconicButtonMorph methodsFor: 'initialization' stamp: ''!
setDefaultLabel
	self labelGraphic: self class defaultGraphics! !

!IconicButtonMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self useSquareCorners! !

!IconicButtonMorph methodsFor: 'accessing' stamp: ''!
labelGraphic: aForm
	"Changed to look for any image morph rather than just a sketch."
	
	graphicalMorph ifNotNil: [graphicalMorph delete].
	graphicalMorph := ImageMorph new form: aForm.
	self extent: graphicalMorph extent + (self borderWidth + self extraBorder).
	graphicalMorph position: self center - (graphicalMorph extent // 2).
	self addMorph: graphicalMorph.
	graphicalMorph lock! !

!IconicButtonMorph methodsFor: 'mouse events' stamp: ''!
mouseEnter: evt
	"Remember the old border style."
	
	oldBorderStyle:= self borderStyle.
	self borderStyle: self mouseOverBorderStyle! !

!IconicButtonMorph methodsFor: 'mouse events' stamp: ''!
mouseOverBorderStyle: aBorderStyle
	"Set the border style to use whilst the mouse
	is over the receiver."

	mouseOverBorderStyle := aBorderStyle.! !

!IconicButtonMorph methodsFor: 'accessing' stamp: ''!
labelFromString: aString
	"Make an iconic label from aString"

	self labelGraphic: (StringMorph contents: aString) imageForm! !

!IconicButtonMorph methodsFor: 'accessing' stamp: ''!
extraBorder

	^ 6! !

!IconicButtonMorph methodsFor: 'mouse events' stamp: ''!
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 ])
		ifTrue: [ self mouseLeave: evt ]! !

!IconicButtonMorph methodsFor: 'accessing' stamp: ''!
borderRaised
	self borderStyle: (BorderStyle raised width: 2).! !

!IconicButtonMorph methodsFor: 'accessing' stamp: ''!
borderInset
	self borderStyle: (BorderStyle inset width: 2).! !

!IconicButtonMorph methodsFor: 'initialization' stamp: ''!
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.! !

!IconicButtonMorph methodsFor: 'accessing' stamp: ''!
graphicalMorph: aMorph
	self addMorph: aMorph.
	aMorph lock.! !

!IconicButtonMorph methodsFor: 'initialization' stamp: ''!
borderNormal
	self borderStyle: (BorderStyle width: 2 color: Color transparent).! !

!IconicButtonMorph methodsFor: 'initialization' stamp: ''!
borderThick
	self borderStyle: (BorderStyle width: 2 color: self raisedColor twiceDarker).! !

!IconicButtonMorph class methodsFor: 'initialize' stamp: ''!
initialize
	"self initialize"
	
	DefaultGraphics := self defaultGraphics! !

!IconicButtonMorph class methodsFor: 'initialize' stamp: ''!
defaultGraphics

	^ DefaultGraphics ifNil: [ DefaultGraphics := (Form extent: 20 @ 1 depth: 8)].! !

!IconicListItemMorph commentStamp: ''!
I am a wrapper used to display a morph with ahead an icon.

Here is the way to use me

IconicListItemMorph new
	icon: ThemeIcons current smallOkIcon asMorph;
	morph: 'Accept' asMorph;
	yourself;
	openInWorld!
!IconicListItemMorph methodsFor: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!IconicListItemMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!IconicListItemMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	self 	
		changeTableLayout;
		listDirection: #leftToRight;
		cellPositioning: #center;
		cellInset: 2;
		borderWidth: 0;
		color: Color transparent;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		extent: 20@16.! !

!IconicListItemMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!IconicListItemMorph methodsFor: 'accessing' stamp: ''!
originalObject: anObject
	
	originalObject := anObject! !

!IconicListItemMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!IconicListItemMorph methodsFor: 'accessing' stamp: ''!
morph
	^ morph! !

!IconicListItemMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!IconicListItemMorph methodsFor: 'accessing' stamp: ''!
morph: anObject
	
	morph ifNotNil: [ self removeMorph: morph ].
	morph := anObject.
	morph ifNotNil: [ "since the text can be removed" 
		self addMorphBack: morph.
		self adjustLayoutBounds]! !

!IconicListItemMorph methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!IconicListItemMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!IconicListItemMorph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean

	self submorphs do: [ :each |
			each enabled: aBoolean ].! !

!IconicListItemMorph methodsFor: 'accessing' stamp: ''!
icon: anObject

	icon ifNotNil: [ self removeMorph: icon ].
	
	icon := anObject asAlphaImageMorph.
	anObject ifNotNil: [ "since the text can be removed" 
		self addMorphFront: icon.
		self adjustLayoutBounds]! !

!IconicListItemMorph methodsFor: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!IconicListItemMorph methodsFor: 'accessing' stamp: ''!
originalObject

	^ originalObject! !

!IconicListItemMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!IconicListItemMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!IconicListItemMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!IconicListItemMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!IconicListItemMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!IconicListItemMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!IconicListItemMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!IconicListItemMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!IconicListItemMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IconicListItemMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!IconicListItemMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!IconicListItemMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!IconicListItemMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!IconicListItemMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!IconicListItemMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!IconicListItemMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!IconicListItemMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!IconicListItemMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!IconicListItemMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!IconicListItemMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!IconicListItemMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!IconicListItemMorph class methodsFor: 'instance creation' stamp: ''!
text: aText icon: form
	| morph |
	
	aText ifNotNil: [ morph := aText asMorph 
		lock;
		yourself ].

	^ self new
		morph:	morph;
		icon: form;
		yourself! !

!IconicListItemMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!IconicListItemMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!IconicListItemMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!IconicListItemMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!IconicListItemMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!IconicListItemMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!IconicListItemMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!IconicListItemMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!IdentifierChooserMorph commentStamp: ''!
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:		<Color>
	choiceMenus:		<Array>
	choicesMorph:		<AlignmentMorph>
	chooseBlock:		<Block>
	labels:		<Array>
	maxLines:		<Integer>
	requestor:		<Morph>
	scrollPaneWidth:		<Integer>

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: ''!
requestor: aTextMorph
	requestor := aTextMorph! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
choiceMenuItems
	"Answer the value of choiceMenus"

	^ Array streamContents: [:strm | self choiceMenus  do: [:menu | strm nextPutAll: menu menuItems]].! !

!IdentifierChooserMorph methodsFor: 'event handling' stamp: ''!
deleteIfPopUp: evt
	"For compatibility with MenuMorph."! !

!IdentifierChooserMorph methodsFor: 'ui-building' stamp: ''!
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: 'accessing' stamp: ''!
choiceMenus
	"Answer the value of choiceMenus"

	^ choiceMenus! !

!IdentifierChooserMorph methodsFor: 'event handling' stamp: ''!
switchToNextColumn
	"Give the next embedded menu keyboard focus."

	self switchToOtherColumn: [:prevIdx | 
		prevIdx =  self choiceMenus size
				ifTrue: [1]
				ifFalse: [prevIdx + 1]]! !

!IdentifierChooserMorph methodsFor: 'ui-building' stamp: ''!
open
	self addMorph: self newContentMorph.
	self openInWorld.! !

!IdentifierChooserMorph methodsFor: 'event handling' stamp: ''!
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: ''!
processEnter: anEvent
	self choiceMenus do: [:embeddedMenu | 
		embeddedMenu selectedItem ifNotNil: [:item |
			item invokeWithEvent: anEvent.
			^true ] ].
	^false! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
maxLines
	^ maxLines ifNil: [maxLines := 6]! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
chooseBlock: aBlock
	chooseBlock := aBlock! !

!IdentifierChooserMorph methodsFor: 'ui-building' stamp: ''!
newMenu 
	^ self theme
		newEmbeddedMenuIn: self
		for: self! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
choiceMenus: anObject
	"Set the value of choiceMenus"

	choiceMenus := anObject! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
baseColor
	^ baseColor ifNil: [baseColor := self defaultBaseColor]! !

!IdentifierChooserMorph methodsFor: 'ui-building' stamp: ''!
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: ''!
newRow
	^ AlignmentMorph new
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		extent: 1@1;
		borderWidth: 0;
		color: Color transparent.! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
allowedArea
	^ self class allowedArea! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
listHeight
	"Answer the height for the list."

	^ choicesMorph height! !

!IdentifierChooserMorph methodsFor: 'event handling' stamp: ''!
keyDown: 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
		ifTrue: [ ^ self processEnter: anEvent ].
	^false! !

!IdentifierChooserMorph methodsFor: 'ui-building' stamp: ''!
oneMenuOfWidth: anInteger
	self maxLines: 999999999.
	scrollPaneWidth := anInteger.! !

!IdentifierChooserMorph methodsFor: 'event handling' stamp: ''!
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 isMenuItemMorph and: [ sm isSelected ] )
						ifTrue: [ sub := sm ].
					sm isSelected
					]
			]
		ifNone: [  ].
	self choiceMenus do: [ :embeddedMenu | embeddedMenu selectItem: nil event: nil ].
	menuWithFocus
		ifNil: [ self selectFirstItem ]
		ifNotNil: [ 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: ''!
switchToPreviousColumn
	"Give the previous embedded menu keyboard focus."

	self switchToOtherColumn: [:prevIdx | 
		prevIdx =  1
			ifTrue: [self choiceMenus size]
			ifFalse: [prevIdx - 1]]! !

!IdentifierChooserMorph methodsFor: 'event handling' stamp: ''!
activate: evt
	"Backstop."! !

!IdentifierChooserMorph methodsFor: 'action' stamp: ''!
close
	self delete.! !

!IdentifierChooserMorph methodsFor: 'ui-building' stamp: ''!
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 ifNil: [ self labels: self labels allButFirst ].
	self labels ifEmpty: [ ^ answer ].
	self labels last ifNil: [ 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 isMenuMorph ] ).
	^ answer! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
defaultBaseColor
	^ Color transparent! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
labels: aCollectionOfString
	"Set the value of labels"
	labels := aCollectionOfString! !

!IdentifierChooserMorph methodsFor: 'ui-building' stamp: ''!
newScrollPaneFor: aMorph
	^ self theme
		newScrollPaneIn: self
		for: aMorph! !

!IdentifierChooserMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self borderWidth: 1.
	self layoutInset: 0.
	self changeTableLayout.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self color: self defaultBaseColor.! !

!IdentifierChooserMorph methodsFor: 'ui-building' stamp: ''!
newVerticalSeparator

	^ SeparatorMorph new
		fillStyle: Color transparent;
		borderStyle: (BorderStyle inset baseColor: Color gray; width: 1);
		extent: 1@1;
		vResizing: #spaceFill! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
requestor
	^ requestor! !

!IdentifierChooserMorph methodsFor: 'event handling' stamp: ''!
selectFirstItem
	"Select the first item in the embedded menus"

	self choiceMenus first selectItem:  self choiceMenuItems first event: nil.
	self takeKeyboardFocus.! !

!IdentifierChooserMorph methodsFor: 'action' stamp: ''!
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: 'ui-building' stamp: ''!
newMenuWith: menuItems
	"Answer menu with the given morphs."

	| menu |
	menu := self newMenu.
	menu cornerStyle: #square.
	menuItems do: [:m | menu addMorphBack: 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: ''!
scrollPane
	"Answer the scroll pane."

	^self findDeeplyA: GeneralScrollPaneMorph! !

!IdentifierChooserMorph methodsFor: 'event handling' stamp: ''!
selectNextItem
	"Select the next item in the embedded menus"

	| idx next |
	self choiceMenus 
		do: [:embeddedMenu | embeddedMenu menuItems 
			do: [:mi | ((mi isMenuItemMorph)  and: [mi isSelected])
				ifTrue: [idx := embeddedMenu menuItems indexOf: mi.
					idx = embeddedMenu menuItems size
						ifTrue: [idx := 0].
					idx := idx + 1. 
					[(embeddedMenu menuItems at: idx) isMenuItemMorph]
						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: ''!
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: ''!
keyStroke: anEvent
	anEvent keyCharacter = Character space
		ifTrue: [ ^self processEnter: anEvent ].
	^false! !

!IdentifierChooserMorph methodsFor: 'ui-building' stamp: ''!
setColor: aColor
	self color: aColor.
	self choiceMenus 
		ifNotNil: [:menus | menus 
			do: [:cm | cm color: aColor]]! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
baseColor: aColor
	baseColor := aColor.
	self setColor: aColor! !

!IdentifierChooserMorph methodsFor: 'event handling' stamp: ''!
selectPreviousItem
	"Select the previous item in the embedded menus"

	| idx previous |
	self choiceMenus 
		do: [:embeddedMenu | embeddedMenu menuItems 
			do: [:mi | ((mi isMenuItemMorph)  and: [mi isSelected])
				ifTrue: [idx := embeddedMenu menuItems indexOf: mi.
					idx = 1
						ifTrue: [idx := embeddedMenu menuItems size + 1].
					idx := idx - 1. 
					[(embeddedMenu menuItems at: idx) isMenuItemMorph]
						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: 'accessing' stamp: ''!
listMorph
	"Answer the height for the list."

	^ choicesMorph! !

!IdentifierChooserMorph methodsFor: 'ui-building' stamp: ''!
forcesHeight: aHeight
	| sp |
	(sp := self scrollPane) minHeight: aHeight.
	sp height: sp minHeight.
 	self height: sp height.! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
labels
	"Answer the value of labels"

	^ labels! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
choicesMorph: aMorph
	choicesMorph := aMorph! !

!IdentifierChooserMorph methodsFor: 'accessing' stamp: ''!
maxLines: anInteger
	maxLines := anInteger! !

!IdentifierChooserMorph class methodsFor: 'instance creation' stamp: ''!
example

	(self 
		labels: #('aaa' 'bbb' 'ccc') 
		chooseBlock:  [ :currText | currText matches: '*bb'])
	openInWorld! !

!IdentifierChooserMorph class methodsFor: 'instance creation' stamp: ''!
labels: aCollection chooseBlock: aBlock
	"return a new chooser or nil"
	^ aCollection isEmpty
		ifFalse: [ self new chooseBlock: aBlock; labels: aCollection; yourself].! !

!IdentifierChooserMorph class methodsFor: 'accessing' stamp: ''!
allowedArea
	"The area allowed for the building and positioning of the morph"
	| allowedArea |
	allowedArea := Display usableArea.
	allowedArea := allowedArea intersect: self currentWorld visibleClearArea ifNone: [ 0@0 corner: 0@0 "not sure about this"].
	^allowedArea! !

!IdentityBag commentStamp: ''!
Like a Bag, except that items are compared with #== instead of #= .

See the comment of IdentitySet for more information.
!
!IdentityBag methodsFor: 'converting' stamp: ''!
asSet
	^contents keys asIdentitySet! !

!IdentityBag class methodsFor: 'instance creation' stamp: ''!
contentsClass
	^IdentityDictionary! !

!IdentityBagTest commentStamp: ''!
SUnit tests for identity bags!
!IdentityBagTest methodsFor: 'requirements' stamp: ''!
elementToCopy
	^ elementToCopy ifNil: [ elementToCopy := 'element to copy' ]! !

!IdentityBagTest methodsFor: 'requirements' stamp: ''!
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: ''!
speciesClass
	^ IdentityBag! !

!IdentityBagTest methodsFor: 'tests - converting' stamp: ''!
testAsSetWithEqualsElements
	| t1 |
	t1 := self withEqualElements asSet.
	self withEqualElements do: [ :t2 | self assert: (t1 occurrencesOf: t2) equals: 1 ].
	self assert: t1 class equals: IdentitySet! !

!IdentityBagTest methodsFor: 'tests - identity adding' stamp: ''!
testIdentityAdd
	| added |
	self collection add: self elementToCopy.
	self deny: (self collection includes: self equalNotIdenticalElement).

	added := self collection add: self equalNotIdenticalElement.
	self assert: added identicalTo: self equalNotIdenticalElement.
	self assert: (self collection includes: self equalNotIdenticalElement)! !

!IdentityBagTest methodsFor: 'tests' stamp: ''!
testIdentity
 
	| bag identityBag aString anOtherString |
	
	aString := 'hello'.
	anOtherString := aString copy.
	
	self assert: aString equals: anOtherString.
	self assert: (aString == anOtherString) not.

	bag := Bag new.
	bag add: aString.
	bag add: aString.
	bag add: anOtherString.
	self assert: (bag occurrencesOf: aString) equals: 3.
	self assert: (bag occurrencesOf: anOtherString) equals: 3.
	
	identityBag := IdentityBag new.
	identityBag add: aString.
	identityBag add: aString.
	identityBag add: anOtherString.
	
	self assert: (identityBag occurrencesOf: aString) equals: 2.
	self assert: (identityBag occurrencesOf: anOtherString) equals: 1.! !

!IdentityBagTest methodsFor: 'requirements' stamp: ''!
equalNotIdenticalElement
	^ equalNotIdenticalElement ifNil: [ equalNotIdenticalElement := self elementToCopy copy ]! !

!IdentityDictionary commentStamp: ''!
Like a Dictionary, except that keys are compared with #== instead of #= .

See the comment of IdentitySet for more information.!
!IdentityDictionary methodsFor: 'private' stamp: ''!
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: ''!
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! !

!IdentityDictionary methodsFor: 'private' stamp: ''!
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! !

!IdentityDictionaryTest commentStamp: ''!
SUnit tests for identity dictionaries!
!IdentityDictionaryTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ IdentityDictionary! !

!IdentityDictionaryTest methodsFor: 'requirements' stamp: ''!
canBeUnhealthy
	^ false! !

!IdentityDictionaryTest methodsFor: 'tests - identity' stamp: ''!
testIdentity
	| dict key |
	dict := self classToBeTested new.
	key := 'key'.
	dict at: key put: 2.5.
	 
	
	self assert: (dict includesKey: key).
	self deny: (dict includesKey: key copy).
	
"	dict at: 1 put: 'djdh'.
	dict at: 'sksl' put: 1.0.
	self deny: (dict includesKey: 1.0) .
	self assert: (dict includes: 1)"! !

!IdentityDictionaryTest class methodsFor: 'building suites' stamp: ''!
shouldInheritSelectors

^true! !

!IdentityNewValueHolder commentStamp: ''!
I am a special because I announce changes only if the new value set is different from the current value.!
!IdentityNewValueHolder methodsFor: 'accessing' stamp: ''!
value: anObject

	self value == anObject ifFalse: [	super value: anObject ].! !

!IdentitySet commentStamp: ''!
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: 'testing' stamp: ''!
identityIncludes: anObject
	"Don't use a loop, #includes: already uses identity"
	^ self includes: anObject! !

!IdentitySet methodsFor: 'private' stamp: ''!
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! !

!IdentitySet methodsFor: 'converting' stamp: ''!
asIdentitySet
	^self! !

!IdentitySet methodsFor: 'private' stamp: ''!
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 enclosedElement == anObject ])
			ifTrue: [ ^index ].
		(index := index \\ array size + 1) = start ] whileFalse.
	self errorNoFreeSpace! !

!IdentitySet methodsFor: '*Fuel-Core' stamp: ''!
fuelReplacement
	| copy |
	copy := self copyEmpty addAll: self.
	^ (self size ~= copy size)
		ifTrue: [ copy ]
		ifFalse: [ self ]! !

!IdentitySetTest commentStamp: ''!
SUnit tests for identity sets!
!IdentitySetTest methodsFor: 'tests - identity' stamp: ''!
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: 'requirements' stamp: ''!
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: 'coverage' stamp: ''!
classToBeTested

	^ IdentitySet! !

!IdentitySetTest methodsFor: 'tests - identity' stamp: ''!
testIdentity
	| identitySet aString anOtherString |
	aString := 'hello'.
	anOtherString := aString copy.

	self assert: aString equals: anOtherString.
	self deny: aString identicalTo: anOtherString.

	identitySet := self classToBeTested new.
	identitySet add: aString.

	self assert: (identitySet occurrencesOf: aString) equals: 1.
	self assert: (identitySet occurrencesOf: anOtherString) equals: 0.

	self assert: (identitySet includes: aString).
	self deny: (identitySet includes: anOtherString) equals: 0! !

!IdentitySetTest class methodsFor: 'building suites' stamp: ''!
shouldInheritSelectors

^true! !

!IdentityTransform commentStamp: ''!
Identity transformation!
!IdentityTransform methodsFor: 'accessing' stamp: ''!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^self! !

!IdentityTransform methodsFor: 'transforming points' stamp: ''!
localPointsToGlobal: inArray
	"Transform all the points of inArray from local into global coordinates"
	^inArray! !

!IdentityTransform methodsFor: 'transforming points' stamp: ''!
localPointToGlobal: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	^aPoint! !

!IdentityTransform methodsFor: 'composing' stamp: ''!
composedWithGlobal: aTransformation
	^aTransformation! !

!IdentityTransform methodsFor: 'transforming rects' stamp: ''!
sourceQuadFor: aRectangle
	^ aRectangle innerCorners! !

!IdentityTransform methodsFor: 'converting' stamp: ''!
asMatrixTransform2x3
	"Represent the receiver as a 2x3 matrix transformation"
	^MatrixTransform2x3 identity! !

!IdentityTransform methodsFor: 'transforming rects' stamp: ''!
localBoundsToGlobal: aRectangle
	"Transform aRectangle from local coordinates into global coordinates"
	^aRectangle! !

!IdentityTransform methodsFor: 'testing' stamp: ''!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."
	^true! !

!IdentityTransform methodsFor: 'accessing' stamp: ''!
angle
	^ 0.0! !

!IdentityTransform methodsFor: 'transforming points' stamp: ''!
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: ''!
globalPointsToLocal: inArray
	"Transform all the points of inArray from global into local coordinates"
	^inArray! !

!IdentityTransform methodsFor: 'transforming rects' stamp: ''!
globalBoundsToLocal: aRectangle
	"Transform aRectangle from global coordinates into local coordinates"
	^aRectangle! !

!IdentityTransform methodsFor: 'composing' stamp: ''!
composedWithLocal: aTransformation
	^aTransformation! !

!IdentityTransform methodsFor: 'transforming points' stamp: ''!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^aPoint! !

!IdentityTransform methodsFor: 'testing' stamp: ''!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."
	^true! !

!IdentityTransform methodsFor: 'composing' stamp: ''!
composedWith: aTransform
	^aTransform! !

!IdentityTransform methodsFor: 'accessing' stamp: ''!
offset
	^0@0! !

!IdentityTransform methodsFor: 'initialize' stamp: ''!
setIdentity
	"I *am* the identity transform"
	^self! !

!IdentityTransform class methodsFor: 'instance creation' stamp: ''!
new
	"There can be only one"
	^Default! !

!IdentityTransform class methodsFor: 'initialization' stamp: ''!
initialize
	"IdentityTransform initialize"
	Default := self basicNew! !

!IllegalFileName commentStamp: ''!
I am raised on an attempt to use an illegal file name, e.g. the file name is too long for the platform.!
!IllegalName commentStamp: ''!
I am raised on an attempt to use an illegal file name
!
!IllegalName methodsFor: 'initialization' stamp: ''!
initializeWithName: aName
	name := aName.
	self messageText: aName! !

!IllegalName methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!IllegalName class methodsFor: 'instance creation' stamp: ''!
signalWith: aName
	^ (self name: aName) signal! !

!IllegalName class methodsFor: 'instance creation' stamp: ''!
name: aName
	^ self basicNew initializeWithName: aName! !

!IllegalResumeAttempt commentStamp: ''!
This class is private to the EHS implementation.  An instance of it is signaled whenever an attempt is made to resume from an exception which answers false to #isResumable.!
!IllegalResumeAttempt methodsFor: 'comment' stamp: ''!
readMe

	"Never handle this exception!!"! !

!IllegalResumeAttempt methodsFor: 'comment' stamp: ''!
isResumable
	
	^ false! !

!ImageCleaner commentStamp: ''!
Used for cleaning the image.

You can use one of my 2 methods: 
- CleanUpForRelease
	reinitialize the fonts
	reset metacello registry
	remove Empty Categories
	remove Empty Packages
	sort Categories
	remove undeclared globals
	remove obsolete references
	Launch the smalltalk cleanup
		run clean up on all the instances of the classes that implement cleanUp
- CleanUpForProduction
	All the previous actions +
	remove the background logo
	remove the tests
	remove the tools
	remove the versionner!
!ImageCleaner methodsFor: 'literal sharing' stamp: ''!
createLiteralTable
	| arrays |
	literalTable := OCLiteralSet new.
	self literalsDo: [ :literal :method | literalTable add: literal.
		"we add all the contentents of the arrays recursively, too"
		literal isArray ifTrue: [ 
			literal recursiveDo: [ :each | 
				(each isSymbol not and: [ each isImmediateObject not and: [each isNotNil]]) 
					ifTrue: [ literalTable add: each ] ] ] ].

	"we need to go over all array and unify. As we have all flattend arrays in the literalTable, we need to only have to iterate it"
	arrays := literalTable select: [ :each | each isArray ].
	arrays do: [ :array |
			array beWritableObject.
			array copy do: [ :arrayValue | 
				(arrayValue  isSymbol not and:  [ arrayValue isImmediateObject not ]) ifTrue:
				[array
					at: (array indexOf: arrayValue)
					put: (literalTable like: arrayValue)]].
			array beReadOnlyObject ].! !

!ImageCleaner methodsFor: 'cleaning' stamp: ''!
testPackages

	^ self class testPackages ! !

!ImageCleaner methodsFor: 'literal sharing' stamp: ''!
literalsDo: aBlock

	CompiledCode allSubInstancesDo: [ :cm | 
		cm literals do: [ :literal | 
			"Symbols are already shared, we can skip them here"
			(literal isLiteral and: [literal isSymbol not and: [literal isImmediateObject not and: [literal isNotNil]]]) 
				ifTrue: [ aBlock value: literal value: cm ] ] ]! !

!ImageCleaner methodsFor: 'cleaning' stamp: ''!
removeEmptyCategories

	"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 ].! !

!ImageCleaner methodsFor: 'cleaning' stamp: ''!
removeEmptyPackages
	| empty |
	empty := RPackageOrganizer default packages select: #isEmpty.
	empty do: #unregister.! !

!ImageCleaner methodsFor: 'literal sharing' stamp: ''!
detroyLiteralTable
	"in case someone keeps in instance of ImageCleaner, make sure the table gets GCed"
	literalTable := nil! !

!ImageCleaner methodsFor: 'cleaning' stamp: ''!
packagesForCleanUpInProduction
	"A list of packages who will be unloaded when going to production.
	 WARNING, ORDER IS IMPORTANT"
	
	^#('MonticelloMocks')
! !

!ImageCleaner methodsFor: 'api' stamp: ''!
cleanUpForProduction
	<script: 'self new cleanUpForProduction'>

	|unloading|	
	PolymorphSystemSettings showDesktopLogo: false.
	
	unloading := [ :each | (MCPackage named: each) unload ].	
	self packagesForCleanUpInProduction do: unloading.
	self class helpPackages do: unloading.
	self class testPackages do: unloading.
	self class examplePackages do: unloading.
	
	self cleanUpForRelease! !

!ImageCleaner methodsFor: 'cleaning' stamp: ''!
cleanUpMethods
	"Make sure that all methods in use are restarted"
	<script: 'self new cleanUpMethods'>
	WeakArray restartFinalizationProcess.
	ToolRegistry allSubInstances do: [:each | each resetAnnouncer].

	WorldState 
		allInstancesDo: [ :ws | ws convertAlarms; cleanStepList].
		
	ProcessBrowser initialize.
	Delay restartTimerEventLoop.
	"We are moving all the restart code to the classes"
	Smalltalk restartMethods.! !

!ImageCleaner methodsFor: 'cleaning' stamp: ''!
helpPackages
	^RPackageOrganizer default packageNames select: [ :each | each endsWith: '-Help' ]! !

!ImageCleaner methodsFor: 'cleaning' stamp: ''!
examplePackages
	^RPackageOrganizer default packageNames select: [ :each | each endsWith: 'Examples' ]! !

!ImageCleaner methodsFor: 'cleaning' stamp: ''!
cleanUpProcesses
	(Process allInstances
		reject: [ :p | 
			{
			Processor activeProcess.
			WeakArray runningFinalizationProcess.
			Processor backgroundProcess.
			SmalltalkImage current lowSpaceWatcherProcess.
			UIManager default uiProcess.
			Delay schedulingProcess} includes: p ])
		do: [ :p | 
			p
				suspend;
				terminate ]! !

!ImageCleaner methodsFor: 'literal sharing' stamp: ''!
shareLiterals
	"We go over all methods and replace all the literals that are equal by one copy"
	self createLiteralTable.
	self literalsDo: [ :literal :cm |
			cm literalAt: (cm indexOfLiteral: literal) put: (literalTable like: literal)  ].
	self detroyLiteralTable
		
! !

!ImageCleaner methodsFor: 'api' stamp: ''!
cleanUpForRelease
	<script: 'self new cleanUpForRelease'>

	Author fullName: 'MrCleaner'.
	self cleanUpMethods.
	self class environment at: #MetacelloProjectRegistration ifPresent: [ :class | class resetRegistry ].
	SystemNavigation new
		allObjectsDo: [ :each | 
			((each respondsTo: #releaseCachedState) and: [ (each isKindOf: RubAbstractTextArea) not ])
				ifTrue: [ each releaseCachedState ] ].
	
	self 
		removeEmptyCategories;
		removeEmptyPackages.
		
	Smalltalk organization sortCategories.

	Smalltalk 
		garbageCollect;
		cleanOutUndeclared; 
		fixObsoleteReferences;
		cleanUp: true except: #() confirming: false.
		
	FreeTypeFontProvider current prepareForRelease.	
	
	HashedCollection rehashAll.		
	self shareLiterals.
	Author reset! !

!ImageCleaner class methodsFor: 'accessing' stamp: ''!
testPackages

	<script: 'self testPackages inspect'>
	"All test packages to wipe out, except ReleeaseTests package."
	^ RPackageOrganizer default testPackageNames copyWithout:
		  'ReleaseTests'! !

!ImageCleaner class methodsFor: 'instance creation' stamp: ''!
cleanUpForProduction
	<script>
	self new cleanUpForProduction! !

!ImageCleaner class methodsFor: 'accessing' stamp: ''!
helpPackages
	<script: 'self helpPackages inspect'>
	
	^RPackageOrganizer default packageNames select: [ :each | each endsWith: '-Help' ]! !

!ImageCleaner class methodsFor: 'accessing' stamp: ''!
examplePackages
	<script: 'self examplePackages inspect'>
	
	^RPackageOrganizer default packageNames select: [ :each | each endsWith: '-Examples' ]! !

!ImageCleaner class methodsFor: 'instance creation' stamp: ''!
shareLiterals
	<script>
	self new shareLiterals! !

!ImageCleaner class methodsFor: 'instance creation' stamp: ''!
cleanUpForRelease
	<script>
	self new cleanUpForRelease! !

!ImageCleanerCommandLineHandler commentStamp: ''!
Usage: clean [ --release ]
	--release        do #cleanUpForRelease
	--production   do #cleanUpForProduction
	
Documentation:
	This allows to run the ImageCleaner from the commandLine.
	With no special option it runs Smalltalk cleanUp: true.

Usage:
	pharo Pharo.image clean
	pharo Pharo.image clean --release!
!ImageCleanerCommandLineHandler methodsFor: 'actions' stamp: ''!
cleanUpImage
	(self hasOption: 'release')
		ifTrue: [^ImageCleaner cleanUpForRelease].
	(self hasOption: 'production')	
		ifTrue: [ ^ImageCleaner cleanUpForProduction].
	Smalltalk cleanUp: true except: #() confirming: false.	! !

!ImageCleanerCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self activateHelp
		ifTrue: [  ^ self ].
	self cleanUpImage.
	Smalltalk snapshot: true andQuit: true.! !

!ImageCleanerCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'clean'! !

!ImageCleanerCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Run image cleanup'! !

!ImageFillStyle commentStamp: ''!
Simple fillstyle that draws a (potentially translucent) form at the specified origin. Direction and normal are unused.!
!ImageFillStyle methodsFor: 'comparing' stamp: ''!
= anOrientedFillStyle
	"Answer whether equal."

	^super = anOrientedFillStyle
		and: [(self form = anOrientedFillStyle form) and: [ offset = anOrientedFillStyle offset]]! !

!ImageFillStyle methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		origin: 0@0;
		offset: 0@0! !

!ImageFillStyle methodsFor: 'comparing' stamp: ''!
hash
	"Hash is implemented because #= is implemented."
	
	^super hash bitXor: self form hash! !

!ImageFillStyle methodsFor: 'accessing' stamp: ''!
offset: anObject
	"Set the value of offset"

	offset := anObject! !

!ImageFillStyle methodsFor: '*Athens-Balloon' stamp: ''!
asAthensPaintOn: anAthensCanvas

	^ (anAthensCanvas cacheAt: self ifAbsentPut: [
		anAthensCanvas surface
		createFormPaint: form ])
		origin: origin! !

!ImageFillStyle methodsFor: 'converting' stamp: ''!
asColor
	"Answer transparent, no other reasonable interpretation."
	
	^Color transparent! !

!ImageFillStyle methodsFor: 'accessing' stamp: ''!
extent
	"Answer the value of extent"

	^ extent! !

!ImageFillStyle methodsFor: 'accessing' stamp: ''!
form
	"Answer the value of form"

	^ form! !

!ImageFillStyle methodsFor: 'accessing' stamp: ''!
form: aForm
	"Set the value of form"

	form := aForm.
	self direction: aForm extent! !

!ImageFillStyle methodsFor: 'accessing' stamp: ''!
offset
	"Answer the value of offset"

	^ offset! !

!ImageFillStyle methodsFor: '*Polymorph-Widgets' stamp: ''!
fillRectangle: aRectangle on: aCanvas
	"Fill the given rectangle on the given canvas with the receiver."
	
	self extent
		ifNil: [aCanvas
				translucentImage: self form
				at: self origin]
		ifNotNil: [aCanvas clipBy: (self origin + self offset extent: self extent) during: [:c |
					c
						translucentImage: self form
						at: self origin]]! !

!ImageFillStyle methodsFor: 'accessing' stamp: ''!
extent: anObject
	"Set the value of extent"

	extent := anObject! !

!ImageFillStyle class methodsFor: 'instance creation' stamp: ''!
form: aForm
	"Answer a new instance of the receiver with the given form."

	^self new form: aForm! !

!ImageMorph commentStamp: ''!
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: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!ImageMorph methodsFor: 'accessing' stamp: ''!
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: 'drawing' stamp: ''!
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: 'accessing' stamp: ''!
image: anImage 
	
	image := anImage. 
	super extent: (2 * self borderWidth) asPoint + image extent.
	self changed! !

!ImageMorph methodsFor: 'menu' stamp: ''!
opacityString
	^ (self isOpaque) -> 'opaque' translated! !

!ImageMorph methodsFor: 'accessing' stamp: ''!
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: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!ImageMorph methodsFor: 'menu' stamp: ''!
changeOpacity
	self isOpaque: self isOpaque not! !

!ImageMorph methodsFor: 'accessing' stamp: ''!
form
	^ image! !

!ImageMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!ImageMorph methodsFor: 'accessing' stamp: ''!
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: ''!
withSnapshotBorder
	self 
		borderStyle:
			((ComplexBorderStyle style: #complexFramed)
				color: (Color r: 0.613 g: 1.0 b: 0.516);
				width: 1;
				yourself)! !

!ImageMorph methodsFor: 'menu commands' stamp: ''!
readFromFile
	| fileName |
	fileName := UIManager default
		request: 'Please enter the image file name' translated
		initialAnswer: 'fileName'.
	fileName isEmptyOrNil ifTrue: [^ self].
	self form: (Form fromFileNamed: fileName).! !

!ImageMorph methodsFor: 'caching' stamp: ''!
releaseCachedState

	super releaseCachedState.
	image hibernate.! !

!ImageMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	"Do nothing; 
		My extent is determined by my image Form. 
		For subclasses which need to set the extent, use #basicExtent:"! !

!ImageMorph methodsFor: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!ImageMorph methodsFor: 'other' stamp: ''!
imageExport
	
	^ self form bits asArray! !

!ImageMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: aCanvas
	
	| cached style|
	
	cached := aCanvas cacheAt: image ifAbsentPut: [
		image asAthensPaintOn: aCanvas.
		].
	
	aCanvas setPaint: cached.
		
		aCanvas paintTransform restoreAfter: [
			aCanvas paintTransform translateBy: self innerBounds origin "negated".
		
			aCanvas drawShape: self innerBounds.
		].
	(style := self borderStyle) ifNotNil: [
		aCanvas setStrokePaint: style.
		aCanvas drawShape: bounds]! !

!ImageMorph methodsFor: 'testing' stamp: ''!
wantsRecolorHandle
	^ image notNil and: [image depth = 1]! !

!ImageMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!ImageMorph methodsFor: 'initialization' stamp: ''!
defaultImage
	"Answer the default image for the receiver."

	^ DefaultForm! !

!ImageMorph methodsFor: 'accessing' stamp: ''!
borderWidth: bw

	| newExtent |
	newExtent := 2 * bw + image extent.
	bounds extent = newExtent ifFalse: [super extent: newExtent].
	super borderWidth: bw! !

!ImageMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!ImageMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self form: self defaultImage.! !

!ImageMorph methodsFor: 'menus' stamp: ''!
addCustomMenuItems: aMenu hand: aHand
	super addCustomMenuItems: aMenu hand: aHand.
	aMenu addUpdating: #opacityString selector: #changeOpacity! !

!ImageMorph methodsFor: 'menu commands' stamp: ''!
grabFromScreen

	self form: Form fromUser.! !

!ImageMorph methodsFor: 'geometry' stamp: ''!
basicExtent: aPoint

	"For sublcasses which need to use Morph>>#extent:"
	
	^super extent: aPoint! !

!ImageMorph methodsFor: 'other' stamp: ''!
resize: newSize

	self form: (image scaledToSize: newSize)! !

!ImageMorph methodsFor: 'accessing' stamp: ''!
isOpaque
	"Return true if the receiver is marked as being completely opaque"
	
	^ self
		valueOfProperty: #isOpaque
		ifAbsent: [false]! !

!ImageMorph methodsFor: 'geometry' stamp: ''!
adoptPaneColor: paneColor
	"Change our border color too."
	
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	self borderStyle baseColor: paneColor twiceDarker! !

!ImageMorph methodsFor: 'accessing' stamp: ''!
form: aForm
	image := aForm. 
	super extent: (2 * self borderWidth) asPoint + image extent.
	self changed! !

!ImageMorph methodsFor: 'testing' stamp: ''!
shouldFlex
	^ true.! !

!ImageMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!ImageMorph methodsFor: 'testing' stamp: ''!
areasRemainingToFill: aRectangle

	^self isOpaque
		ifTrue: [aRectangle areasOutside: self bounds]
		ifFalse: [Array with: aRectangle]! !

!ImageMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ImageMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ImageMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ImageMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ImageMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ImageMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ImageMorph class methodsFor: 'instance creation' stamp: ''!
fromString: aString font: aFont
	"Create a new ImageMorph showing the given string in the given font"

	^ self new form: (StringMorph contents: aString font: aFont) imageForm! !

!ImageMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ImageMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ImageMorph class methodsFor: 'initialization' stamp: ''!
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: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ImageMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ImageMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ImageMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ImageMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ImageMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ImageMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ImageMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ImageMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ImageMorph class methodsFor: 'instance creation' stamp: ''!
fromStream: aStream

	^self withForm: (ImageReadWriter formFromStream: aStream)! !

!ImageMorph class methodsFor: 'accessing' stamp: ''!
defaultForm
	^DefaultForm! !

!ImageMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ImageMorph class methodsFor: 'instance creation' stamp: ''!
withForm: aForm

	^ self new form: aForm ; yourself! !

!ImageMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ImageMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ImageMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ImageMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ImageMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ImageMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ImageMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ImageMorph class methodsFor: 'instance creation' stamp: ''!
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: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ImageMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ImageMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ImageMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ImagePresenter commentStamp: ''!
An ImagePresenter is a spec presenter for images.
See AbstractWidgetPresenter

I provide the following variables and their accessors
- action is the action performed when I am displayed.
- image is the form i display.!
!ImagePresenter methodsFor: 'api' stamp: ''!
action: aBlock
	"Set the action of the image"
	"<api: #block getter: #action>"
	actionHolder value: aBlock! !

!ImagePresenter methodsFor: 'api' stamp: ''!
image: aForm
	"<api: #image getter: #image>"
	"Set the form of the imagemorph"
	
	imageHolder value: aForm! !

!ImagePresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	imageHolder := nil asValueHolder.
	actionHolder := [] asValueHolder. 
	autoScaleHolder := false asValueHolder.
	imageHolder whenChangedDo: [ self changed: #getImage ].! !

!ImagePresenter methodsFor: 'api' stamp: ''!
action
	"<api: #inspect>"

	^ actionHolder value! !

!ImagePresenter methodsFor: 'api-valueHolder' stamp: ''!
actionHolder
	"To be able to register action when the action is changed."
	^ actionHolder! !

!ImagePresenter methodsFor: 'api' stamp: ''!
image
	"<api: #inspect>"

	^ imageHolder value! !

!ImagePresenter methodsFor: 'api-valueHolder' stamp: ''!
autoScaleHolder
	"To be able to register action when the autoscale is changed."

	^ autoScaleHolder! !

!ImagePresenter methodsFor: 'api' stamp: ''!
switchAutoscale
	autoScaleHolder value: autoScaleHolder value not.
	self changed: #switchAutoscale with: {}! !

!ImagePresenter methodsFor: 'api-valueHolder' stamp: ''!
imageHolder
	"To be able to register action when the image is changed."
	^ imageHolder! !

!ImagePresenter methodsFor: 'api' stamp: ''!
autoScale
	"<api: #inspect>"

	^ autoScaleHolder value! !

!ImagePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(ImageAdapter
		adapt: #(model))! !

!ImagePresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ImageAdapter! !

!ImagePreviewMorph commentStamp: ''!
Displays an image scaled to a fixed size along with a label describing the original dimensions.!
!ImagePreviewMorph methodsFor: 'accessing' stamp: ''!
cornerStyle: aSymbol
	"Pass on to selector and content too."

	super cornerStyle: aSymbol.
	self imageMorph cornerStyle: aSymbol! !

!ImagePreviewMorph methodsFor: 'initialization' stamp: ''!
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: 'accessing' stamp: ''!
defaultImageFormOfSize: aPoint
	"Answer a default preview image form."

	^(defaultImageForm isNil or: [defaultImageForm extent ~= aPoint])
		ifTrue: [defaultImageForm := Form extent: aPoint]
		ifFalse: [defaultImageForm]! !

!ImagePreviewMorph methodsFor: 'accessing' stamp: ''!
newImageMorph
	"Answer a new image morph."

	^AlphaImageMorph new
		borderStyle: (BorderStyle inset width: 1);
		color: Color white;
		alpha: 1.0! !

!ImagePreviewMorph methodsFor: 'accessing' stamp: ''!
newTextMorph
	"Answer a new text morph."

	^StringMorph contents: ''! !

!ImagePreviewMorph methodsFor: 'accessing' stamp: ''!
imageMorph
	"Answer the value of imageMorph"

	^ imageMorph! !

!ImagePreviewMorph methodsFor: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
textMorph: anObject
	"Set the value of textMorph"

	textMorph := anObject! !

!ImagePreviewMorph methodsFor: 'accessing' stamp: ''!
textMorph
	"Answer the value of textMorph"

	^ textMorph! !

!ImagePreviewMorph methodsFor: 'accessing' stamp: ''!
imageMorph: anObject
	"Set the value of imageMorph"

	imageMorph := anObject! !

!ImageReadWriter commentStamp: ''!
I am ImageReadWriter. 
I read an encoded image from a binary stream and return its as a Form. 
I write and encode an image as Form to a binary stream.
I am an abstract class, my subclasses implement concrete formats.
I can autodetect the format of some encoded images, so you can use me directly.

Usage

	ImageReadWriter formFromFileNamed: 'test.png'
	ImageReadWriter formFromStream: 'test.png' asFileReference binaryReadStream

Implementation 

Instance Variables:
	stream		<ReadStream|WriteStream>	binary stream that I read from or write to

Subclasses must implement the following messages:
	accessing
		nextImage
		nextPutImage:
	testing
		canUnderstand         (or my class side's #understandsImageFormat:)
			
(original) copyright (c) Kazuki Yasumatsu, 1995. All rights reserved.
!
!ImageReadWriter methodsFor: 'stream access' stamp: ''!
nextIntegerOfSize: numberOfBytes signed: signed bigEndian: bigEndian
	"Assuming the receiver is a stream of bytes, read the next integer of size numberOfBytes.
	If bigEndian is true, use network byte order, most significant byte first, 
	else use little endian order, least significant byte first.
	If signed is true, interpret as a two-complement signed value, 
	else interpret as a plain unsigned value."
	
	| value |
	value := 0.
	bigEndian
		ifTrue: [ 
			(numberOfBytes - 1) * 8 to: 0 by: -8 do: [ :shift |
				value := value + (self next bitShift: shift) ] ]
		ifFalse: [ 
			0 to: (numberOfBytes - 1) * 8 by: 8 do: [ :shift |
				value := value + (self next bitShift: shift) ] ].
	^ (signed and: [ (value bitAt: numberOfBytes * 8) = 1 ])
		ifTrue: [ value - (1 << (numberOfBytes * 8)) ]
		ifFalse: [ value ]! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
position

	^stream position! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
lf
	"PPM and PBM are used LF as CR."

	^stream nextPut: Character lf asInteger! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
nextWord
	"Read a 16-bit quantity from the input stream."

	^(stream next bitShift: 8) + stream next! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
next: size

	^stream next: size! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
position: anInteger

	^stream position: anInteger! !

!ImageReadWriter methodsFor: 'private' stamp: ''!
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: ''!
hasMagicNumber: aByteArray 
	| position |
	position := stream position.
	(stream next: aByteArray size) = aByteArray
		ifTrue: [ ^ true ].
	stream position: position.
	^ false! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
tab

	^stream nextPut: Character tab asInteger! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
nextPut: aByte

	^stream nextPut: aByte! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
close
	
	stream close! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
contents

	^stream contents! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
atEnd

	^stream atEnd! !

!ImageReadWriter methodsFor: 'testing' stamp: ''!
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: 'image reading/writing' stamp: ''!
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 methodsFor: 'stream access' stamp: ''!
next

	^stream next! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
nextLittleEndianNumber: numberOfBytes put: integer
	^ self nextIntegerOfSize: numberOfBytes signed: false bigEndian: false put: integer! !

!ImageReadWriter methodsFor: 'accessing' stamp: ''!
nextPutImage: imageForm
	"Encoding imageForm onto my stream"

	self subclassResponsibility! !

!ImageReadWriter methodsFor: 'accessing' stamp: ''!
nextImage
	"Decode an encoded image from my stream and return it as a Form"

	^ self subclassResponsibility! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
nextWordPut: a16BitW
	"Write out a 16-bit integer as 16 bits."

	stream nextPut: ((a16BitW bitShift: -8) bitAnd: 16rFF).
	stream nextPut: (a16BitW bitAnd: 16rFF).
	^a16BitW! !

!ImageReadWriter methodsFor: 'private' stamp: ''!
on: binaryStream 
	stream := binaryStream! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
space

	^stream nextPut: Character space asInteger! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
nextIntegerOfSize: numberOfBytes signed: signed bigEndian: bigEndian put: value
	"Assuming the receiver is a stream of bytes, write value as the next integer of size numberOfBytes.
	If bigEndian is true, use network byte order, most significant byte first, 
	else use little endian order, least significant byte first.
	If signed is true, encode as a two-complement signed value, 
	else encode as a plain unsigned value."
	
	| unsignedValue |
	unsignedValue := (signed and: [ value negative ])
		ifTrue: [ (1 << (numberOfBytes * 8)) + value ] 
		ifFalse: [ value ].
	(unsignedValue between: 0 and: (2 ** (numberOfBytes * 8)) - 1)
		ifFalse: [ DomainError signalFrom: 0 to: (2 ** (numberOfBytes * 8)) - 1 ].
	bigEndian
		ifTrue: [ 
			numberOfBytes to: 1 by: -1 do: [ :index |
				self nextPut: (unsignedValue byteAt: index) ] ]
		ifFalse: [ 
			1 to: numberOfBytes do: [ :index |
				self nextPut: (unsignedValue byteAt: index) ] ].
	^ value! !

!ImageReadWriter methodsFor: 'private' stamp: ''!
unpackBits: bits depthTo8From: depth with: width height: height pad: pad 
	"Unpack bits of depth 1, 2, or 4 image to it of depth 8 image."
	| bitMask pixelInByte bitsWidth upBitsWidth stopWidth trailingSize upBits bitIndex upBitIndex val |
	(#(1 2 4 ) includes: depth) ifFalse: [ ^ self error: 'depth must be 1, 2, or 4' ].
	(#(8 16 32 ) includes: pad) ifFalse: [ ^ self error: 'pad must be 8, 16, or 32' ].
	bitMask := (1 bitShift: depth) - 1.
	pixelInByte := 8 / depth.
	bitsWidth := (width * depth + pad - 1) // pad * (pad / 8).
	upBitsWidth := (width * 8 + pad - 1) // pad * (pad / 8).
	stopWidth := (width * depth + 7) // 8.
	trailingSize := width - ((stopWidth - 1) * pixelInByte).
	upBits := ByteArray new: upBitsWidth * height.
	1 
		to: height
		do: 
			[ :i | 
			bitIndex := (i - 1) * bitsWidth.
			upBitIndex := (i - 1) * upBitsWidth.
			1 
				to: stopWidth - 1
				do: 
					[ :j | 
					val := bits at: (bitIndex := bitIndex + 1).
					upBitIndex := upBitIndex + pixelInByte.
					1 
						to: pixelInByte
						do: 
							[ :k | 
							upBits 
								at: upBitIndex - k + 1
								put: (val bitAnd: bitMask).
							val := val bitShift: depth negated ] ].
			val := (bits at: (bitIndex := bitIndex + 1)) bitShift: depth negated * (pixelInByte - trailingSize).
			upBitIndex := upBitIndex + trailingSize.
			1 
				to: trailingSize
				do: 
					[ :k | 
					upBits 
						at: upBitIndex - k + 1
						put: (val bitAnd: bitMask).
					val := val bitShift: depth negated ] ].
	^ upBits! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
nextLittleEndianNumber: numberOfBytes
	^ self nextIntegerOfSize: numberOfBytes signed: false bigEndian: false! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
size

	^stream size! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
skip: anInteger

	^stream skip: anInteger! !

!ImageReadWriter methodsFor: 'testing' stamp: ''!
isAnimated
	^ false! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
nextLongPut: a32BitW
	"Write out a 32-bit integer as 32 bits."

	stream nextPut: ((a32BitW bitShift: -24) bitAnd: 16rFF).
	stream nextPut: ((a32BitW bitShift: -16) bitAnd: 16rFF).
	stream nextPut: ((a32BitW bitShift: -8) bitAnd: 16rFF).
	stream nextPut: (a32BitW bitAnd: 16rFF).
	^a32BitW! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
nextLong
	"Read a 32-bit quantity from the input stream."

	^(stream next bitShift: 24) + (stream next bitShift: 16) +
		(stream next bitShift: 8) + stream next! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
peekFor: aValue

	^stream peekFor: aValue! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
nextPutAll: aByteArray

	^stream nextPutAll: aByteArray! !

!ImageReadWriter methodsFor: 'stream access' stamp: ''!
cr

	^stream nextPut: Character cr asInteger! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: ''!
putForm: aForm onStream: aBinaryWriteStream 
	"Store (encode) the image of the Form aForm on aBinaryWriteStream.
	Use a concrete subclass to select the desired format.
	Closes aBinaryWriteStream when done."

	"PNGReadWriter putForm: PolymorphSystemSettings pharoLogoForm onStream: 'test.png' asFileReference binaryWriteStream"
	"PluginBasedJPEGReadWriter putForm: PolymorphSystemSettings pharoLogoForm onStream: 'test.jpg' asFileReference binaryWriteStream"

	| writer |
	writer := self on: aBinaryWriteStream.
	writer nextPutImage: aForm.
	writer close! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: ''!
understandsImageFormat: aStream
	^ [ (self new on: aStream) understandsImageFormat ]
		on: Error
		do: [ :ex | ex return: false ]! !

!ImageReadWriter class methodsFor: 'instance creation' stamp: ''!
on: binaryStream
	"Answer an instance of the receiver for encoding and/or decoding an image on binaryStream.
	For reading, you should pass along a read stream, for writing a write stream."

	^ self new on: binaryStream! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: ''!
putForm: aForm onFileNamed: fileName 
	"Store (encode) the image of the Form aForm on a file of with fileName.
	Use a concrete subclass to select the desired format."
	
	"PNGReadWriter putForm: PolymorphSystemSettings pharoLogoForm onFileNamed: 'test.png'"
	"PluginBasedJPEGReadWriter putForm: PolymorphSystemSettings pharoLogoForm onFileNamed: 'test.jpg'"
	
	fileName asFileReference 
		binaryWriteStreamDo: [ :out | (self on: out) nextPutImage: aForm ]! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: ''!
formFromStream: aBinaryReadStream
	"Answer a Form of the image stored on aBinaryReadStream.
	This will (normally) autodetect the format and delegate to the correct concrete subclass.
	Closes aBinaryReadStream when done."
	
	"ImageReadWriter formFromStream: 'test.png' asFileReference binaryReadStream"
	"ImageReadWriter formFromStream: 'test.jpg' asFileReference binaryReadStream"

	| positionableReadStream reader readerClass form |
	positionableReadStream := ZnPositionableReadStream on: aBinaryReadStream.
	readerClass := self readerClassFromStream: positionableReadStream.
	reader := readerClass new on: positionableReadStream.
	form := reader nextImage.
	aBinaryReadStream close.
	^ form! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: ''!
unrecognizedImageFormatError: aString
    UnrecognizedImageFormatError signal: aString! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: ''!
formFromFileNamed: fileName 
	"Answer a Form of the image stored (encoded) on the file with fileName.
	This will (normally) autodetect the format and delegate to the correct concrete subclass."
	
	"ImageReadWriter formFromFileNamed: 'test.png'"
	"ImageReadWriter formFromFileNamed: 'test.jpg'"
	
	^ fileName asFileReference 
		binaryReadStreamDo: [ :in | self formFromStream: in ]! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: ''!
readerClassFromStream: positionableReadStream
	| readerClass |
	readerClass := self withAllSubclasses
		detect: [ :subclass | 
			positionableReadStream savingPositionDo: [ 
				subclass understandsImageFormat: positionableReadStream ] ]
		ifNone: [ positionableReadStream close.
			^ self unrecognizedImageFormatError: 'Image format is not recognized.' ].
	^ readerClass! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: ''!
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: ''!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"

	^ #()! !

!ImageReadWriterTest commentStamp: ''!
Functional tests for image IO to binary streams and files for the major formats (JPEG,PNG,GIF,BMP)!
!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testPluginBasedJpegWriteReadInMemory
	| form bytes result |
	form := self pharoLogoFormNonTransparent.
	bytes := ByteArray streamContents: [ :out | PluginBasedJPEGReadWriter putForm: form onStream: out ].
	"Without format detection"
	result := (PluginBasedJPEGReadWriter on: bytes readStream) nextImage.
	self assert: form bits size equals: result bits size.
	"With format detection"
	result := ImageReadWriter formFromStream: bytes readStream.
	self assert: form bits size equals: result bits size! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testJpegWriteReadUsingFiles
	| form file result |
	form := self pharoLogoFormNonTransparent.
	file := (self class name asString , '-pharo-logo.jpeg') asFileReference.
	file ensureDelete.
	(PluginBasedJPEGReadWriter on: file binaryWriteStream) nextPutImage: form. "gets closed ?!!"
	"Without format detection"
	result := file binaryReadStreamDo: [ :in | (JPEGReadWriter on: in) nextImage ].
	self assert: form bits size equals: result bits size.
	"With format detection"
	result := file binaryReadStreamDo: [ :in | ImageReadWriter formFromStream: in ].
	self assert: form bits size equals: result bits size.
	file delete! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testHasMagicNumber
	"Tests now account for the new Streams, for which we cannot
	 assume we will be able to know the whole size"
	| exampleNumber writerStream failStream failTooShortStream reader |
	exampleNumber := 'GIF89a'.
	writerStream := ZnPositionableReadStream on: (ReadStream on: 'GIF89a this is some data').
	failStream := ZnPositionableReadStream on: (ReadStream on: 'This is incorrect').
	failTooShortStream := ZnPositionableReadStream on: (ReadStream on: 'GIF').
	
	"This one has the magic number at the current position"
	reader := ImageReadWriter on: writerStream.
	self assert: (reader hasMagicNumber: exampleNumber).
	
	"Does not have the magic number at the current position"
	reader := ImageReadWriter on: failStream.
	self assert: (reader hasMagicNumber: exampleNumber) equals: false.
	
	"The source stream is shorter than the magic number. Shouldn't error!!"
	reader := ImageReadWriter on: failTooShortStream.
	self assert: (reader hasMagicNumber: exampleNumber) equals: false.! !

!ImageReadWriterTest methodsFor: 'accessing' stamp: ''!
pharoLogoForm
	^ (PNGReadWriter on: (ZnBase64Encoder new decode: PolymorphSystemSettings pharoLogoContents) readStream) nextImage! !

!ImageReadWriterTest methodsFor: 'accessing' stamp: ''!
pharoLogoFormNonTransparent
	^ self pharoLogoForm 
		mapColor: Color transparent to: Color white;
		yourself! !

!ImageReadWriterTest methodsFor: 'accessing' stamp: ''!
pharoLogoFormDepth8
	^ self pharoLogoFormNonTransparent asFormOfDepth: 8! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testPngWriteReadUsingFiles
	| form file result |
	form := self pharoLogoForm.
	file := (self class name asString , '-pharo-logo.png') asFileReference.
	file ensureDelete.
	file binaryWriteStreamDo: [ :out | (PNGReadWriter on: out) nextPutImage: form ].
	"Without format detection"
	result := file binaryReadStreamDo: [ :in | (PNGReadWriter on: in) nextImage ].
	self assert: form bits equals: result bits.
	"With format detection"
	result := file binaryReadStreamDo: [ :in | ImageReadWriter formFromStream: in ].
	self assert: form bits equals: result bits.
	file delete! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testGifWriteReadUsingFiles
	| form file result |
	form := self pharoLogoFormDepth8.
	file := (self class name asString , '-pharo-logo.gif') asFileReference.
	file ensureDelete.
	file binaryWriteStreamDo: [ :out | (GIFReadWriter on: out) nextPutImage: form ].
	"Without format detection"
	result := file binaryReadStreamDo: [ :in | (GIFReadWriter on: in) nextImage ].
	self assert: form bits equals: result bits.
	"With format detection"
	result := file binaryReadStreamDo: [ :in | ImageReadWriter formFromStream: in ].
	self assert: form bits equals: result bits.
	file delete! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testPluginBasedJpegWriteReadUsingFiles
	| form file result |
	form := self pharoLogoFormNonTransparent.
	file := (self class name asString , '-pharo-logo.jpeg') asFileReference.
	file ensureDelete.
	(PluginBasedJPEGReadWriter on: file binaryWriteStream) nextPutImage: form. "gets closed ?!!"
	"Without format detection"
	result := file binaryReadStreamDo: [ :in | (PluginBasedJPEGReadWriter on: in) nextImage ].
	self assert: form bits size equals: result bits size.
	"With format detection"
	result := file binaryReadStreamDo: [ :in | ImageReadWriter formFromStream: in ].
	self assert: form bits size equals: result bits size.
	file delete! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testCanGetFormOutOfBase64EncodedStringImage
	| encodedImage form expextedFrom |
	encodedImage := PolymorphSystemSettings pharoLogoContents.
	expextedFrom := self pharoLogoForm.
	
	form := Form fromBase64String: encodedImage.
	
	self
		assert: form width 
		equals: expextedFrom width.
	self
		assert: form height 
		equals: expextedFrom height.
	self
		assert: form depth 
		equals: expextedFrom depth.
	self
		assert: form bits
		equals: self pharoLogoForm bits.! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testGifWriteReadInMemory
	| form bytes result |
	form := self pharoLogoFormDepth8.
	bytes := ByteArray streamContents: [ :out | GIFReadWriter putForm: form onStream: out ].
	"Without format detection"
	result := (GIFReadWriter on: bytes readStream) nextImage.
	self assert: form bits equals: result bits.
	"With format detection"
	result := ImageReadWriter formFromStream: bytes readStream.
	self assert: form bits equals: result bits! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testJpegWriteReadInMemory
	| form bytes result |
	form := self pharoLogoFormNonTransparent.
	bytes := ByteArray streamContents: [ :out | PluginBasedJPEGReadWriter putForm: form onStream: out ].
	"Without format detection"
	result := (JPEGReadWriter on: bytes readStream) nextImage.
	self assert: form bits size equals: result bits size.
	"With format detection"
	result := ImageReadWriter formFromStream: bytes readStream.
	self assert: form bits size equals: result bits size! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testPngWriteReadInMemory
	| form bytes result |
	form := self pharoLogoForm.
	bytes := ByteArray streamContents: [ :out | PNGReadWriter putForm: form onStream: out ].
	"Without format detection"
	result := (PNGReadWriter on: bytes readStream) nextImage.
	self assert: form bits equals: result bits.
	"With format detection"
	result := ImageReadWriter formFromStream: bytes readStream.
	self assert: form bits equals: result bits! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testBmpWriteReadInMemory
	| form bytes result |
	form := self pharoLogoFormNonTransparent.
	bytes := ByteArray streamContents: [ :out | BMPReadWriter putForm: form onStream: out ].
	"Without format detection"
	result := (BMPReadWriter on: bytes readStream) nextImage.
	self assert: form bits equals: result bits.
	"With format detection"
	result := ImageReadWriter formFromStream: bytes readStream.
	self assert: form bits equals: result bits! !

!ImageReadWriterTest methodsFor: 'tests' stamp: ''!
testBmpWriteReadUsingFiles
	| form file result |
	form := self pharoLogoFormNonTransparent.
	file := (self class name asString , '-pharo-logo.bmp') asFileReference.
	file ensureDelete.
	file binaryWriteStreamDo: [ :out | (BMPReadWriter on: out) nextPutImage: form ].
	"Without format detection"
	result := file binaryReadStreamDo: [ :in | (BMPReadWriter on: in) nextImage ].
	self assert: form bits equals: result bits.
	"With format detection"
	result := file binaryReadStreamDo: [ :in | ImageReadWriter formFromStream: in ].
	"result := ImageReadWriter formFromFileNamed: file fullPath."
	self assert: form bits equals: result bits.
	file delete! !

!ImmediateLayout commentStamp: ''!
I am the special layout for SmallIntegers.

SmallIntegers are typically implemented as tagged pointers and thus require a special format.!
!ImmediateLayout methodsFor: 'extending' stamp: ''!
extend: newScope
	^ FixedLayout new slotScope: newScope! !

!ImmediateLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGImmediateLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)]
! !

!ImmediateLayout methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self host: SmallInteger.! !

!ImmediateLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	^ 7! !

!ImmediateLayout methodsFor: 'extending' stamp: ''!
extend
	self error: 'ImmediateLayout can not be extendend'! !

!ImmediateLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else!!"
	^#immediateSubclass:! !

!ImmediateLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass
	^ superLayout extendImmediate
		host: aClass;
		yourself! !

!ImmediateLayout class methodsFor: '*Monticello' stamp: 'nil'!
mcTypeSymbol 	
	^ #immediate! !

!ImportingResourceHelp commentStamp: ''!
A help topic on how to import resources into the image!
!ImportingResourceHelp class methodsFor: 'documentation' stamp: ''!
importingIcon
	^ HelpTopic 
		title: 'Importing Icon'
		contents: 
'The easiest way to create icons from a bunch of .png pictures is to use IconFactory. 

1 - You can load it from the Catalog Browser, available from the WorldMenu/Tools.

2 - Once loaded, you need to create an empty class, which will contains your icons. Create a subclass of Object. For the purpose of the example, we will call it MatrixCubeIcons 

3 - You need to prepare the icon class to handle icons. For example, to provide caches. Simply evaluate:
	IconFactory setup: MatrixCubeIcons
	
4 - The last step is to import the .png files in the icon class:
	IconFactory createIconsFromDirectory: ''/Users/alexandrebergel/Desktop/Cube'' inClass: MatrixCubeIcons

After this last step, the class MatrixCubeIcons will contains the icons found in the directory /Users/alexandrebergel/Desktop/Cube
The icon class should be packaged within your application. 

Note that icons classes are GT-compatible. Simply inspect the expression: MatrixCubeIcons current

 '! !

!ImportingResourceHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#(overview encodingAndDecoding encodingAndDecodingImage)! !

!ImportingResourceHelp class methodsFor: 'accessing' stamp: ''!
bookName 
	^'Importing Resources'! !

!ImportingResourceHelp class methodsFor: 'documentation' stamp: ''!
overview
	^ HelpTopic 
		title: 'Overview'
		contents: (self heading: 'Overview'),
'Non trivial applications often rely on resources that may be externally provided such as icons, pictures, sounds. Such resources are typically defined as external files. Naturally, you can make your application depends on external files, however, importing resource files within the Pharo image and make it integrally part of you code has a number of advantages:
- you can simply deploy your application by downloading it from smalltalkhub. 
- having less dependencies on external files is always good to avoid technical subtilities such as file path containing weird characters.
 '! !

!ImportingResourceHelp class methodsFor: 'documentation' stamp: ''!
encodingAndDecoding
	^ HelpTopic 
		title: 'Encoding and Decoding'
		contents: (self heading: 'Encoding and Decoding'),
'The basic mechanism to encode and decode data is provided by the class Base64MimeConverter. Consider the following example:

mimeEncoded := ''Hello World'' asByteArray base64Encoded.
(Base64MimeConverter mimeDecodeToBytes: mimeEncoded readStream) contents asString

The variable mimeEncoded contains an encoding of the Hello World string using the mime64 encoding. 
The method #mimeDecodeToBytes: reads mime64 strings from a stream. The example uses a string, but it could refers to any objects. You essentially need a ReadStream.
 '! !

!ImportingResourceHelp class methodsFor: 'documentation' stamp: ''!
encodingAndDecodingImage
	^ HelpTopic 
		title: 'Encoding and Decoding Image'
		contents: (self heading: 'Encoding and Decoding Image'),
'Embedding pictures in plan source code is often the reason why one need to encode resources. The following script loads an image located in the filesystem, create a string-friendly representation, and store it in a method. 

You probably want to keep the image in a class variable or a hash table.

',
(self bold: '
form := PNGReadWriter formFromStream: ''/Users/alexandrebergel/Dropbox/Screenshots/Screenshot 2017-05-19 15.25.44.png'' asFileReference readStream.

"Write the stream on a stream"
w := WriteStream on: ByteArray new.
PNGReadWriter putForm: form onStream: w.
w contents.


"Convert the byteArray into mime 64. It takes less space in the image"
encodedContent := w contents base64Encoded.

"The following code converts the stream content "
PNGReadWriter formFromStream: (Base64MimeConverter mimeDecodeToBytes: encodedContent readStream).


"We encode the image as a method"
Object compile: ''imageSource  ^ '''',  encodedContent, ''''.
Object compile: ''image ^ PNGReadWriter formFromStream: (Base64MimeConverter mimeDecodeToBytes: self imageSource readStream). ''.

"A better implementation is to cache the image in an instance or class variable"

"The following expression return the image initially encoded"
Object new image 
'),'
'! !

!IncompatibleLayoutConflict commentStamp: ''!
I am an error raised when extending a class with an incompatible layout.!
!IncompatibleLayoutConflict methodsFor: 'accessing' stamp: ''!
layout
	^ layout! !

!IncompatibleLayoutConflict methodsFor: 'accessing' stamp: ''!
subType: anObject
	subType := anObject! !

!IncompatibleLayoutConflict methodsFor: 'accessing' stamp: ''!
layout: anObject
	layout := anObject! !

!IncompatibleLayoutConflict methodsFor: 'accessing' stamp: ''!
subType
	^ subType! !

!IncompatibleLayoutConflict methodsFor: 'accessing' stamp: ''!
messageText
	^ 'Class with ', layout class name, ' cannot be extended as ', subType! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
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: 'building' stamp: ''!
newSliderMorph
	"Answer a new morph for the slider."

	|slider|
	slider := self theme builder
		newBracketSliderFor: self
		getValue: #value
		setValue: #value:
		min: 0
		max: 100
		quantum: 1
		getEnabled: #enabled
		help: nil.
	slider fillStyle: self defaultSliderFillStyle.
	^slider! !

!IncrementalSliderMorph methodsFor: 'building' stamp: ''!
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: 'accessing' stamp: ''!
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: 'updating' stamp: ''!
update: aSymbol
	"Update the value."
	
	super update: aSymbol.
	aSymbol = self getValueSelector
		ifTrue: [^self updateValue].
	aSymbol = self getEnabledSelector
		ifTrue: [^self updateEnabled]! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
increment
	"Increment the value."

	self value: self value + self quantum! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
min: aNumber
	"Set the min value."

	(self sliderMorph ifNil: [^self]) min: aNumber! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
buttons
	"Answer the buttons."

	^{self firstSubmorph. self lastSubmorph}! !

!IncrementalSliderMorph methodsFor: 'initialization' stamp: ''!
on: anObject getValue: getSel setValue: setSel
	"Use the given selectors as the interface."

	self
		model: anObject;
		getValueSelector: getSel;
		setValueSelector: setSel;
		updateValue! !

!IncrementalSliderMorph methodsFor: 'updating' stamp: ''!
updateEnabled
	"Update the enablement state."

	self model ifNotNil: [
		self getEnabledSelector ifNotNil: [
			self enabled: (self model perform: self getEnabledSelector)]]! !

!IncrementalSliderMorph methodsFor: 'testing' stamp: ''!
maxEnabled
	"Answer whether the maximum button should be enabled."

	^self enabled and: [self notAtMax]! !

!IncrementalSliderMorph methodsFor: 'testing' stamp: ''!
notAtMin
	"Answer whether the value is not at the minimum,"

	^self value > self min! !

!IncrementalSliderMorph methodsFor: 'updating' stamp: ''!
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: 'accessing' stamp: ''!
getValueSelector
	"Answer the value of getValueSelector"

	^ getValueSelector! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
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: ''!
sliderMorph: anObject
	"Set the value of sliderMorph"

	sliderMorph := anObject! !

!IncrementalSliderMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	"Set the button width to match the height."

	self extent = aPoint ifTrue: [^self].
	super extent: aPoint.
	self updateOrientation: aPoint! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
max: aNumber
	"Set the max value."

	(self sliderMorph ifNil: [^self]) max: aNumber! !

!IncrementalSliderMorph methodsFor: 'API' stamp: ''!
decrement
	"Decrement the value."

	self value: self value - self quantum! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
setValueSelector
	"Answer the value of setValueSelector"

	^ setValueSelector! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
getValueSelector: anObject
	"Set the value of getValueSelector"

	getValueSelector := anObject! !

!IncrementalSliderMorph methodsFor: 'initialization' stamp: ''!
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: 'protocol' stamp: ''!
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: 'accessing' stamp: ''!
setValueSelector: anObject
	"Set the value of setValueSelector"

	setValueSelector := anObject! !

!IncrementalSliderMorph methodsFor: 'initialization' stamp: ''!
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: 'building' stamp: ''!
newButtonLabel: direction ofSize: size
	"Answer a new label for an inc/dec button."

	^AlphaImageMorph new
		image: (ScrollBarMorph
				arrowOfDirection: direction
				size: size
				color: self paneColor darker)! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
min
	"Answer the min value."

	^(self sliderMorph ifNil: [^0]) min! !

!IncrementalSliderMorph methodsFor: 'testing' stamp: ''!
notAtMax
	"Answer whether the value is not at the maximum,"

	^self value < self max! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
enabled
	"Answer whether the receiver is enabled for user input."

	^self sliderMorph
		ifNil: [super enabled]
		ifNotNil: [:sm | sm enabled]! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
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: ''!
getEnabledSelector
	"Answer the value of getEnabledSelector"

	^ getEnabledSelector! !

!IncrementalSliderMorph methodsFor: 'testing' stamp: ''!
minEnabled
	"Answer whether the minimum button should be enabled."

	^self enabled and: [self notAtMin]! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
quantum
	"Answer the quantum value."

	^(self sliderMorph ifNil: [^0]) quantum! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector: aSymbol
	"Set the value of getEnabledSelector"

	getEnabledSelector := aSymbol.
	self updateEnabled! !

!IncrementalSliderMorph methodsFor: 'building' stamp: ''!
newDecrementButton
	"Answer a new decrement button."

	^(self theme builder
		newButtonFor: self
		action: #decrement
		getEnabled: #minEnabled
		label: (self newButtonLabel: #left ofSize: 24)
		help: nil)
		vResizing: #spaceFill;
		width: 64;
		roundedCorners: #(1 2);
		setProperty: #wantsKeyboardFocusNavigation toValue: false;
		on: #mouseStillDown send: #decrement to: self! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
quantum: aNumber
	"Set the quantum value."

	(self sliderMorph ifNil: [^self]) quantum: aNumber! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
sliderMorph
	"Answer the value of sliderMorph"

	^ sliderMorph! !

!IncrementalSliderMorph methodsFor: 'accessing' stamp: ''!
max
	"Answer the max value."

	^(self sliderMorph ifNil: [^0]) max! !

!IncrementalSliderMorph class methodsFor: 'instance creation' stamp: ''!
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: 'instance creation' stamp: ''!
on: anObject getValue: getSel setValue: setSel min: min max: max quantum: quantum
	"Answer a new instance of the receiver with
	the given selectors as the interface."

	^self new
		min: min;
		max: max;
		quantum: quantum;
		on: anObject
		getValue: getSel
		setValue: setSel! !

!IndentingListItemMorph commentStamp: ''!
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 <SmallInteger> 	the indent level, from 0 at the root and increasing by 1 at each level of the hierarchy.

isExpanded <Boolean>		true if this item is expanded (showing its children)

complexContents <ListItemWrapper>	an adapter wrapping my represented item that can answer its children, etc.
	
firstChild <IndentingListItemMorph|nil>	my first child, or nil if none
	
container <SimpleHierarchicalListMorph>	my container
	
nextSibling <IndentingListItemMorph|nil>	the next item in the linked list of siblings, or nil if none.

Contributed by Bob Arning as part of the ObjectExplorer package.
Don't blame him if it's not perfect.  We wanted to get it out for people to play with.!
!IndentingListItemMorph methodsFor: 'private' stamp: ''!
findPathIn: anArray 
	| found |
	found := self findExactPathMatchIn: anArray.
	found
		ifNil: ["try again with no case sensitivity"
			found := self findSimilarPathMatchIn: anArray].
	^ found! !

!IndentingListItemMorph methodsFor: 'mouse events' stamp: ''!
inToggleArea: aPoint

	^self toggleRectangle containsPoint: aPoint! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: ''!
drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle
	"If I am not the only item in my container, draw the line between:
		- my toggle (if any) or my left edge (if no toggle)
		- and my text left edge.
	Only draw now if no toggle."

	| myBounds myCenter hLineY hLineLeft myTheme|
	self isSoleItem ifTrue: [ ^self ].
	self hasToggle ifTrue: [^self].
	myBounds := self toggleBounds.
	myCenter := myBounds center.
	hLineY := myCenter y - 1.
	hLineLeft := myCenter x.
	"Draw line from toggle to text. Use optimised form since vertical."
	myTheme := self theme.
	aCanvas
		frameRectangle: (hLineLeft @ hLineY corner: myBounds right + 3 @ (hLineY + 1))
		width: myTheme treeLineWidth
		colors: (myTheme treeLineColorsFrom: lineColor)
		dashes: myTheme treeLineDashes! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
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 notNil and: [owner submorphs first == self]! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
children
	| children |
	children := OrderedCollection new.
	self childrenDo: [:each | children add: each].
	^children! !

!IndentingListItemMorph methodsFor: 'private - container protocol' stamp: ''!
complexContents

	^complexContents! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
indentLevel

	^indentLevel! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
nextSibling

	^nextSibling! !

!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
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: 'converting' stamp: ''!
withoutListWrapper

	^complexContents withoutListWrapper! !

!IndentingListItemMorph methodsFor: 'private - container protocol' stamp: ''!
highlight

	complexContents highlightingColor ifNotNil: [self color: complexContents highlightingColor].
	self changed.! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
hasIcon
	"Answer whether the receiver has an icon."
	^ icon notNil! !

!IndentingListItemMorph methodsFor: 'initialization' stamp: ''!
initialize
"initialize the state of the receiver"
	super initialize.
""
	indentLevel := 0.
	isExpanded := false! !

!IndentingListItemMorph methodsFor: 'drag and drop' stamp: ''!
acceptDroppingMorph: toDrop event: evt
	complexContents acceptDroppingObject: toDrop complexContents.
	toDrop delete.
	self highlightForDrop: false.! !

!IndentingListItemMorph methodsFor: 'search' stamp: ''!
searchingString
	" string used to detect research "

	^ self contents asString! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
balloonText

	^complexContents balloonText ifNil: [super balloonText]! !

!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
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: 'private' stamp: ''!
toggleBounds
	^self toggleRectangle! !

!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
openItemPath: anArray
	"Open a path based on wrapper item equivalence. Generally more specific
	than #openPath: (string based)."
	
	| found |
	anArray isEmpty
		ifTrue: [^ container setSelectedMorph: nil].
	found := nil.
	self
		withSiblingsDo: [:each | found
				ifNil: [(each complexContents withoutListWrapper == anArray first
							or: [anArray first isNil])
						ifTrue: [found := each]]].
	found
		ifNotNil: [found isExpanded
				ifFalse: [found toggleExpandedState.
					container adjustSubmorphPositions].
			found changed.
			anArray size = 1
				ifTrue: [^ container setSelectedMorph: found].
			^ found firstChild
				ifNil: [container setSelectedMorph: nil]
				ifNotNil: [found firstChild openItemPath: anArray allButFirst]].
	^container setSelectedMorph: nil! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: ''!
unhighlight
	complexContents highlightingColor ifNotNil: [ self color: self theme textColor ].
	self changed.! !

!IndentingListItemMorph methodsFor: 'private - container protocol' stamp: ''!
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: 'drawing' stamp: ''!
drawLinesToFirstChildOn: aCanvas lineColor: lineColor
	"Draw line from me to first child.
	Don't bother if the first child has a toggle.."

	| vLineX vLineTop vLineBottom childBounds childCenter myTheme |
	self firstChild hasToggle
		ifTrue: [ ^ self ].
	childBounds := self firstChild toggleBounds.
	childCenter := childBounds center.
	vLineX := childCenter x.
	vLineTop := bounds bottom.
	vLineBottom := self firstChild hasToggle
		ifTrue: [ childCenter y - (childBounds height // 2) + 1 ]
		ifFalse: [ childCenter y - 2 ].
	myTheme := self theme.
	aCanvas
		frameRectangle: (vLineX @ vLineTop corner: (vLineX + 1) @ vLineBottom)
		width: myTheme treeLineWidth
		colors: (myTheme treeLineColorsFrom: lineColor)
		dashes: myTheme treeLineDashes! !

!IndentingListItemMorph methodsFor: 'private' stamp: ''!
findExactPathMatchIn: anArray 
	self
		withSiblingsDo: [:each | (each complexContents asString = anArray first
					or: [anArray first isNil])
				ifTrue: [^ each]].
	^ nil! !

!IndentingListItemMorph methodsFor: 'private' stamp: ''!
withSiblingsDo: aBlock

	| node |
	node := self.
	[node isNil] whileFalse: [
		aBlock value: node.
		node := node nextSibling
	].! !

!IndentingListItemMorph methodsFor: 'action' stamp: ''!
toggleRectangle

	| h |
	h := bounds height.
	^(bounds left + (13 * indentLevel)) @ bounds top extent: 9@h! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
changed
	"Need to invalidate the selection frame."

	container ifNil: [^super changed].
	self invalidRect: self selectionFrame.
	super changed! !

!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
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: 'drawing' stamp: ''!
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: [ self theme textColor ].
	icon
		ifNotNil: [ 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: 'private' stamp: ''!
findSimilarPathMatchIn: anArray 
	self
		withSiblingsDo: [:each | (each complexContents asString sameAs: anArray first)
				ifTrue: [^ each]].
	^ nil! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
userString
	"Add leading tabs to my userString"
	^ (String new: indentLevel withAll: Character tab), super userString! !

!IndentingListItemMorph methodsFor: 'private - container protocol' stamp: ''!
toggleExpandedState

	isExpanded := isExpanded not.
	self refreshExpandedState.! !

!IndentingListItemMorph methodsFor: 'private - container protocol' stamp: ''!
openPath: anArray
	| found |
	anArray isEmpty
		ifTrue: [ ^ container setSelectedMorph: nil ].
	found := self findPathIn: anArray.
	found ifNil: [ ^ container setSelectedMorph: nil ].
	found isExpanded
		ifTrue: [ found refreshExpandedState ]
		ifFalse: [ found toggleExpandedState ].
	container adjustSubmorphPositions.
	found changed.
	anArray size = 1
		ifTrue: [ ^ container setSelectedMorph: found ].
	^ found firstChild
		ifNil: [ container setSelectedMorph: nil ]
		ifNotNil: [ found firstChild openPath: anArray allButFirst ]! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
isExpanded

	^isExpanded! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
nextSibling: anotherMorph

	nextSibling := anotherMorph! !

!IndentingListItemMorph methodsFor: 'private - container protocol' stamp: ''!
recursiveDelete

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete].
	].
	self delete! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
icon
	"answer the receiver's icon"
	^ icon! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
isSoleItem
	^self isFirstItem and: [ owner submorphs size = 1 ]! !

!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
lastChild
	"Answer the last child."

	|c|
	c := self firstChild ifNil: [^nil].
	[c nextSibling isNil] whileFalse: [c := c nextSibling].
	^c! !

!IndentingListItemMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	self drawOnCanvasWrapperFor: anAthensCanvas! !

!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
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: 'accessing' stamp: ''!
isExpanded: aBoolean

	isExpanded := aBoolean! !

!IndentingListItemMorph methodsFor: 'halos and balloon help' stamp: ''!
boundsForBalloon

	"some morphs have bounds that are way too big"
	container ifNil: [^super boundsForBalloon].
	^self boundsInWorld intersect: container boundsInWorld ifNone: [self boundsInWorld ]! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
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: 'private - container protocol' stamp: ''!
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: 'drawing' stamp: ''!
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: 'initialization' stamp: ''!
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: 'enumeration' stamp: ''!
childrenDo: aBlock

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aBlock value: aNode].
	]! !

!IndentingListItemMorph methodsFor: 'private - container protocol' stamp: ''!
recursiveAddTo: aCollection

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: aCollection].
	].
	aCollection add: self! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
canExpand

	^complexContents hasContents! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
hasToggle
	^ complexContents hasContents! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: ''!
firstChild

	^firstChild! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: ''!
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).! !

!IndexedSlot commentStamp: ''!
By default each Slot corresponds to an instance variable and vice versa. Hence there is a Slot for each instance variable.

!
!IndexedSlot methodsFor: 'comparing' stamp: ''!
= other
	self == other
		ifTrue: [ ^ true ].
	^ ((self species == other species) 
			and: [ index = other index ])
			and: [ name = other name ]! !

!IndexedSlot methodsFor: 'testing' stamp: ''!
isVirtual
	"indexed slots are the only not virtual slots for now"
	^false! !

!IndexedSlot methodsFor: 'comparing' stamp: ''!
hash
	^ (self species hash bitXor: self name hash) bitXor: (self index ifNil: [ 0 ])! !

!IndexedSlot methodsFor: 'meta-object-protocol' stamp: ''!
object: anObject instVarAt: anIndex
	"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 for the
	 debugger. See  Object documentation whatIsAPrimitive."

	<primitive: 73>
	"instead of copying the fail code here, just call the method that has it"
	^thisContext object: anObject instVarAt: anIndex! !

!IndexedSlot methodsFor: 'comparing' stamp: ''!
hasSameDefinitionAs: other
	"Definiton does not contain index"
	^super = other! !

!IndexedSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
	^ self object: anObject instVarAt: index put: aValue! !

!IndexedSlot methodsFor: 'meta-object-protocol' stamp: ''!
object: anObject instVarAt: anIndex put: aValue 
	"Primitive. Store a value into a fixed variable in the argument anObject.
	 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 for the
	 debugger. See Object documentation whatIsAPrimitive."

	<primitive: 74>
	"instead of copying the fail code here, just call the method that has it"
	^thisContext object: anObject instVarAt: anIndex put: aValue! !

!IndexedSlot methodsFor: 'accessing' stamp: ''!
index: anIndex
	index := anIndex! !

!IndexedSlot methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ self class == IndexedSlot 
		ifTrue: [ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
			RGIndexedSlot named: self name asSymbol parent: (self definingClass classLayout asRingMinimalDefinitionIn: anRGEnvironment)]]
		ifFalse: [ super asRingMinimalDefinitionIn: anRGEnvironment ]! !

!IndexedSlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	^ self object: anObject instVarAt: index! !

!IndexedSlot methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!InexactFloatPrintPolicy commentStamp: ''!
I am InexactFloatPrintPolicy.

Through FloatPrintPolicy and double dispatch I force Float>>#printOn:base: to dynamically use the faster but potentially less accurate way to print Floats using Float>>#absPrintOn:base:!
!InexactFloatPrintPolicy methodsFor: 'printing' stamp: ''!
absPrint: float on: stream base: base
	"Doube dispatch to the faster but potentially less accurate way to print"

	^ float absPrintInexactlyOn: stream base: base! !

!InfiniteForm commentStamp: ''!
I represent a Form obtained by replicating a pattern form indefinitely in all directions.!
!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
isOrientedFill
	^true! !

!InfiniteForm methodsFor: 'displaying' stamp: ''!
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: 'fillstyle protocol' stamp: ''!
origin
	^0@0! !

!InfiniteForm methodsFor: 'accessing' stamp: ''!
asColor
	^ patternForm dominantColor! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
form
	"Bitmap fills respond to #form"
	^patternForm! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
normal
	^0 @ patternForm height! !

!InfiniteForm methodsFor: 'adding' stamp: ''!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"

	"prevents a walkback when control menu is built for morph with me as color"! !

!InfiniteForm methodsFor: 'displaying' stamp: ''!
colorForInsets
	^ Color transparent! !

!InfiniteForm methodsFor: 'accessing' stamp: ''!
dominantColor
	^ patternForm dominantColor! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
isSolidFill
	^false! !

!InfiniteForm methodsFor: 'accessing' stamp: ''!
offset 
	"Refer to the comment in DisplayObject|offset."

	^0 @ 0! !

!InfiniteForm methodsFor: 'displaying' stamp: ''!
raisedColor
	^ Color transparent! !

!InfiniteForm methodsFor: 'display box access' stamp: ''!
computeBoundingBox 
	"Refer to the comment in DisplayObject|computeBoundingBox."

	^0 @ 0 corner: SmallInteger maxVal @ SmallInteger maxVal! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
isTiled
	"Return true if the receiver should be drawn as a tiled pattern"
	^true! !

!InfiniteForm methodsFor: '*FormCanvas-Core' stamp: ''!
fillRectangle: aRectangle on: aCanvas
	"Fill the given rectangle on the given canvas with the receiver."
	
	aCanvas fillRectangle: aRectangle basicFillStyle: self! !

!InfiniteForm methodsFor: 'testing' stamp: ''!
mightBeTranslucent
	"Return true since the bitmap may be translucent and we don't really want to check"
	^true! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
isTranslucent
	"Return true since the bitmap may be translucent and we don't really want to check"
	^true! !

!InfiniteForm methodsFor: '*Athens-Morphic' stamp: ''!
asAthensPaintOn: canvas
	^ (canvas surface createFormPaint: self asForm)
		repeat;
		origin: self origin;
		direction: self direction;
		yourself! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
direction
	^patternForm width @ 0! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
origin: aPoint
	"Ignored"! !

!InfiniteForm methodsFor: 'displaying' stamp: ''!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"This is the real display message, but it doesn't get used until the new
	display protocol is installed."
	| targetBox patternBox bb |
	(patternForm isForm) ifFalse:
		[^ aDisplayMedium fill: clipRectangle rule: ruleInteger fillColor: patternForm].

	"Do it iteratively"
	targetBox := aDisplayMedium boundingBox intersect: clipRectangle ifNone: [ ^ self ].
	patternBox := patternForm boundingBox.
	bb := BitBlt destForm: aDisplayMedium sourceForm: patternForm fillColor: aForm
		combinationRule: ruleInteger destOrigin: 0@0 sourceOrigin: 0@0
		extent: patternBox extent clipRect: clipRectangle.
	bb colorMap:
		(patternForm colormapIfNeededFor: aDisplayMedium).
	(targetBox left truncateTo: patternBox width)
		to: targetBox right - 1 by: patternBox width do:
		[:x |
		(targetBox top truncateTo: patternBox height)
			to: targetBox bottom - 1 by: patternBox height do:
			[:y |
			bb destOrigin: x@y; copyBits]]! !

!InfiniteForm methodsFor: 'displaying' stamp: ''!
displayOnPort: aPort at: offset

	| targetBox patternBox savedMap top left |

	self flag: #pharoFixMe. "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: 'private' stamp: ''!
form: aForm

	patternForm := aForm! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
isBitmapFill
	^true! !

!InfiniteForm methodsFor: 'accessing' stamp: ''!
asForm
	^ patternForm! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
isGradientFill
	^false! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: ''!
bitPatternForDepth: suspectedDepth
	^ patternForm! !

!InfiniteForm class methodsFor: 'instance creation' stamp: ''!
with: aForm 
	"Answer an instance of me whose pattern form is the argument, aForm."

	^self new 
		form: aForm;
		yourself! !

!InflateStream commentStamp: ''!
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: 'bit access' stamp: 'nil'!
nextBits: n
	| bits |
	[bitPos < n] whileTrue:[
		bitBuf := bitBuf + (self nextByte bitShift: bitPos).
		bitPos := bitPos + 8].
	bits := bitBuf bitAnd: (1 bitShift: n)-1.
	bitBuf := bitBuf bitShift: 0 - n.
	bitPos := bitPos - n.
	^bits! !

!InflateStream methodsFor: 'private' stamp: 'nil'!
pastEndRead
	"A client has attempted to read beyond the read limit.
	Check in what state we currently are and perform
	the appropriate action"
	| blockType bp oldLimit |
	state = StateNoMoreData ifTrue:[^nil]. "Get out early if possible"
	"Check if we can move decoded data to front"
	self moveContentsToFront.
	"Check if we can fetch more source data"
	self moveSourceToFront.
	state = StateNewBlock ifTrue:[state := self getNextBlock].
	blockType := state bitShift: -1.
	bp := self bitPosition.
	oldLimit := readLimit.
	self perform: (BlockTypes at: blockType+1).
	"Note: if bit position hasn't advanced then nothing has been decoded."
	bp = self bitPosition 
		ifTrue:[^self primitiveFailed].
	"Update crc for the decoded contents"
	readLimit > oldLimit 
		ifTrue:[crc := self updateCrc: crc from: oldLimit+1 to: readLimit in: collection].
	state = StateNoMoreData ifTrue:[self verifyCrc].
	^self next! !

!InflateStream methodsFor: 'inflating' stamp: 'nil'!
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: 'crc' stamp: 'nil'!
verifyCrc
	"Verify the crc checksum in the input"! !

!InflateStream methodsFor: 'bit access' stamp: 'nil'!
bitPosition
	"Return the current bit position of the source"

	^ sourceStream == nil
		ifTrue: [ sourcePos * 8 + bitPos ]
		ifFalse: [ (sourceStream position + sourcePos) * 8 + bitPos ]! !

!InflateStream methodsFor: 'huffman trees' stamp: 'nil'!
distanceMap
	"This is used by the fast decompressor"
	^nil! !

!InflateStream methodsFor: 'accessing' stamp: 'nil'!
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: 'nil'!
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: 'accessing' stamp: 'nil'!
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: 'huffman trees' stamp: 'nil'!
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 occurrences 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: 'open/close' stamp: 'nil'!
close
	sourceStream ifNotNil:[sourceStream close].! !

!InflateStream methodsFor: 'accessing' stamp: 'nil'!
contents

	^ self upToEnd! !

!InflateStream methodsFor: 'inflating' stamp: 'nil'!
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: 'testing' stamp: 'nil'!
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: 'inflating' stamp: 'nil'!
processFixedBlock
	litTable := self 
				huffmanTableFrom: FixedLitCodes
				mappedBy: self literalLengthMap.
	distTable := self 
				huffmanTableFrom: FixedDistCodes
				mappedBy: self distanceMap.
	state := state bitOr: BlockProceedBit.
	self proceedFixedBlock.! !

!InflateStream methodsFor: 'initialization' stamp: 'nil'!
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: 'initialization' stamp: 'nil'!
reset
	"Position zero - nothing decoded yet"
	position := readLimit := 0.
	sourcePos := 0.
	bitBuf := bitPos := 0.
	state := 0.! !

!InflateStream methodsFor: 'accessing' stamp: 'nil'!
sourceStream
	^sourceStream! !

!InflateStream methodsFor: 'inflating' stamp: 'nil'!
proceedDynamicBlock
	self decompressBlock: litTable with: distTable! !

!InflateStream methodsFor: 'huffman trees' stamp: 'nil'!
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: 'private' stamp: 'nil'!
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: 'nil'!
getNextBlock
	^self nextBits: 3! !

!InflateStream methodsFor: 'crc' stamp: 'nil'!
crcError: aString
	^CRCError signal: aString! !

!InflateStream methodsFor: 'inflating' stamp: 'nil'!
decompressBlock: llTable with: dTable
	"Process the compressed data in the block.
	llTable is the huffman table for literal/length codes
	and dTable is the huffman table for distance codes."
	| value extra length distance oldPos oldBits oldBitPos |
	[readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[
		"Back up stuff if we're running out of space"
		oldBits := bitBuf.
		oldBitPos := bitPos.
		oldPos := sourcePos.
		value := self decodeValueFrom: llTable.
		value < 256 ifTrue:[ "A literal"
			collection byteAt: (readLimit := readLimit + 1) put: value.
		] ifFalse:["length/distance or end of block"
			value = 256 ifTrue:["End of block"
				state := state bitAnd: StateNoMoreData.
				^self].
			"Compute the actual length value (including possible extra bits)"
			extra := #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0) at: value - 256.
			length := #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258) at: value - 256.
			extra > 0 ifTrue:[length := length + (self nextBits: extra)].
			"Compute the distance value"
			value := self decodeValueFrom: dTable.
			extra := #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13) at: value+1.
			distance := #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769
						1025 1537 2049 3073 4097 6145 8193 12289 16385 24577) at: value+1.
			extra > 0 ifTrue:[distance := distance + (self nextBits: extra)].
			(readLimit + length >= collection size) ifTrue:[
				bitBuf := oldBits.
				bitPos := oldBitPos.
				sourcePos := oldPos.
				^self].
			collection 
					replaceFrom: readLimit+1 
					to: readLimit + length + 1 
					with: collection 
					startingAt: readLimit - distance + 1.
			readLimit := readLimit + length.
		].
	].! !

!InflateStream methodsFor: 'huffman trees' stamp: 'nil'!
increment: value bits: nBits
	"Increment a value of nBits length.
	The fast decompressor will do this differently"
	^value+1! !

!InflateStream methodsFor: 'huffman trees' stamp: 'nil'!
mapValues: values by: valueMap
	| oldValue |
	valueMap ifNil: [^values].
	1 to: values size do:[:i|
		oldValue := values at: i.
		"Note: there may be nil values if not all values are used"
		oldValue 
			ifNil: [^values]
			ifNotNil: [values at: i put: (valueMap at: oldValue+1)]].! !

!InflateStream methodsFor: 'huffman trees' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
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: 'bit access' stamp: 'nil'!
nextByte
	^source byteAt: (sourcePos := sourcePos + 1)! !

!InflateStream methodsFor: 'initialization' stamp: 'nil'!
on: aCollectionOrStream
	aCollectionOrStream isStream 
		ifTrue:[
			sourceStream := aCollectionOrStream.
			self getFirstBuffer
		] ifFalse:[
			source := aCollectionOrStream ].
	^self on: source from: 1 to: source size.! !

!InflateStream methodsFor: 'inflating' stamp: 'nil'!
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: 'nil'!
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: 'private' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
size
	"This is a compressed stream - we don't know the size beforehand"
	^self shouldNotImplement! !

!InflateStream methodsFor: 'accessing' stamp: 'nil'!
sourceLimit
	^sourceLimit! !

!InflateStream methodsFor: 'private' stamp: 'nil'!
decompressAll
	"Profile the decompression speed"
	[self atEnd] whileFalse:[
		position := readLimit.
		self next "Provokes decompression"
	].! !

!InflateStream methodsFor: 'crc' stamp: 'nil'!
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: 'huffman trees' stamp: 'nil'!
growHuffmanTable: table
	| newTable |
	newTable := table species new: table size * 2.
	newTable replaceFrom: 1 to: table size with: table startingAt: 1.
	^newTable! !

!InflateStream methodsFor: 'inflating' stamp: 'nil'!
proceedFixedBlock
	self decompressBlock: litTable with: distTable! !

!InflateStream methodsFor: 'accessing' stamp: 'nil'!
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: 'nil'!
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: 'positioning' stamp: 'nil'!
sourcePosition
	^sourcePos! !

!InflateStream methodsFor: 'private' stamp: 'nil'!
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: 'bit access' stamp: 'nil'!
nextSingleBits: n
	| out |
	out := 0.
	1 to: n do:[:i| out := (out bitShift: 1) + (self nextBits: 1)].
	^out! !

!InflateStream methodsFor: 'huffman trees' stamp: 'nil'!
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: 'nil'!
literalLengthMap
	"This is used by the fast decompressor"
	^nil! !

!InflateStream class methodsFor: 'initialization' stamp: 'nil'!
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]).! !

!InformDebugger commentStamp: ''!
I am a debugger that will log the error in an `#inform:` when called.!
!InformDebugger class methodsFor: 'opening api' stamp: ''!
openOn: aDebugSession withFullView: aBool andNotification: aString
	self inform: (self messageToPrintFrom: aDebugSession)! !

!InitializePackagesCommandLineHandler commentStamp: ''!
Usage: initializePackages [ --protocols=<protocols> ] [ --packages=<packages> ]  [ --save ]
	protocols	A name of a file with method protocols specification
	packages	a name of a file with packages list
	
Documentation:
Initializes packages structure from information provided in text files. This is used to initialize 
packages structure for bootstrapped images. Do not use it on full Pharo images.

Protocols are provided in file where every method has one line and provides following data separated by  tabs:
- class name
- method is on the class side (true/false)
- method selector
- protocol name

The <cr> line ending is expected for protocols and packages file.

Protocols file exxample:
RBReplaceRule	false	searchForTree:replaceWith:	matching
RBPatternPragmaNode	true	selector:keywordsPositions:arguments:	instance creation
			
Packages file contains list of packages where every package is on own line.

Examples:
	pharo Pharo.image initializePackages --protocols=protocols.txt --packages=packages.txt --save!
!InitializePackagesCommandLineHandler methodsFor: 'activation' stamp: ''!
initializePackagesFrom: aFileName

	| packages |

	packages := OrderedCollection new.
	(File named: aFileName) readStreamDo: [:binaryStream | | stream |
		stream := ZnCharacterReadStream on: binaryStream encoding: 'utf8'.
		[stream atEnd] whileFalse: [ 
			packages add: (stream upTo: Character cr)]].
	
	RPackageOrganizer default basicInitializeFromPackagesList: packages.
	RPackageOrganizer registerInterestToSystemAnnouncement.! !

!InitializePackagesCommandLineHandler methodsFor: 'activation' stamp: ''!
initializeProtocolsFrom: aFileName

	(File named: aFileName) readStreamDo: [:binaryStream | | stream |
		stream := ZnCharacterReadStream on: binaryStream encoding: 'utf8'.
		[stream atEnd] whileFalse: [ | line items selector class |
			line := stream upTo: Character cr.
			items := line findTokens: String tab.
			class := (items second = 'true') 
				ifTrue: [(Smalltalk classOrTraitNamed: items first) classSide]
				ifFalse: [Smalltalk classOrTraitNamed: items first].
			selector := items third asSymbol.

			class ifNil: [ 
				self error: ('Could not found class: ', items first printString , ' for selector: ', selector printString) ].			

			(class selectors includes: selector)
				ifTrue: [class organization classify: selector under: items fourth]]].! !

!InitializePackagesCommandLineHandler methodsFor: 'activation' stamp: ''!
activate

	self activateHelp
		ifTrue: [ ^ self ].
		
	(self hasOption: 'protocols')
			ifTrue: [ self initializeProtocolsFrom: (self optionAt: 'protocols')].
				
	(self hasOption: 'packages')
			ifTrue: [ self initializePackagesFrom: (self optionAt: 'packages')].
				
	(self hasOption: 'save')
		ifTrue: [ Smalltalk snapshot: true andQuit: false ].
	self exitSuccess! !

!InitializePackagesCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'initializePackages'! !

!InitializePackagesCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Initialize packages and protocols from a given lists'! !

!InitializedClassVariable commentStamp: ''!
I am a class variable that can initialize itself class creation.

#name => InitializedClassVariable default: 5.

#name => InitializedClassVariable defaultBlock: [ 'a block' ].

#name => InitializedClassVariable defaultBlock: [ :class | 'a block, parameter is the class' ].!
!InitializedClassVariable methodsFor: 'class building' stamp: ''!
installingIn: aClass
	default isBlock 
		ifTrue: [ self write: (default cull: aClass) ]
		ifFalse: [ self write: default ]! !

!InitializedClassVariableTest methodsFor: 'tests' stamp: ''!
testInitializedClassVariableReflectiveBlock
	| classVar |
	classVar := #ClassVar => InitializedClassVariable default: [5].
	aClass := self make: [ :builder | builder sharedVariables: {classVar}].

	self assert: classVar read equals: 5.
	classVar write: 10.
	self assert: classVar read equals: 10
	
	
	
	
	! !

!InitializedClassVariableTest methodsFor: 'tests' stamp: ''!
testInitializedClassVariableCompiled
	| classVar |
	classVar := #ClassVar => InitializedClassVariable default: 5.
	aClass := self make: [ :builder | builder sharedVariables: {classVar}].

	self compileAccessorsFor: classVar.
	self assert: aClass new ClassVar equals: 5.
	aClass new ClassVar: 6.
	self assert: aClass new ClassVar equals: 6
	
	

	! !

!InitializedClassVariableTest methodsFor: 'tests' stamp: ''!
testInitializedClassVariableReflectiveBlockParameter
	| classVar |
	classVar := #ClassVar => InitializedClassVariable default: [:class | class].
	aClass := self make: [ :builder | builder sharedVariables: {classVar}].

	self assert: classVar read equals: aClass! !

!InitializedClassVariableTest methodsFor: 'tests' stamp: ''!
testInitializedClassVariableReadReflective
	| classVar |
	classVar := #ClassVar => InitializedClassVariable default: 5.
	aClass := self make: [ :builder | builder sharedVariables: {classVar}].

	self assert: classVar read equals: 5.
	classVar write: 10.
	self assert: classVar read equals: 10
	
	
	
	
	! !

!InitializedSlot commentStamp: ''!
I am showing how a slot can initialize itself on object creation.

#name => InitializedSlot default: 5.

#name => InitializedSlot defaultBlock: [ 'a bloc' ].

#name => InitializedSlot defaultBlock: [ :object | 'a bloc, parameter is the instance' ].!
!InitializedSlot methodsFor: 'meta-object-protocol' stamp: ''!
wantsInitialization
	^ true! !

!InitializedSlot methodsFor: 'initialization' stamp: ''!
initialize: anObject
	default isBlock 
		ifTrue: [ self write: (default cull: anObject) to: anObject ]
		ifFalse: [ self write: default to: anObject ]! !

!InitializedSlotTest methodsFor: 'tests' stamp: ''!
testReflectiveReadWriteBlock
	| slot object|
	slot := #slot1 => InitializedSlot default: [4+1].
	aClass := self make: [ :builder | builder slots: {slot}].
	self assert: (aClass hasSlotNamed: #slot1).
	object := aClass new.

	"test reflective write and read"
	self assert: (slot read: object) equals: 5.
	slot write: 10 to: object.
	self assert: (slot read: object) equals: 10
	
	
	
	
	! !

!InitializedSlotTest methodsFor: 'tests' stamp: ''!
testReadWriteCompiled
	| slot object|
	slot := #slot1 => InitializedSlot default: 5.
	aClass := self make: [ :builder | builder slots: {slot}].
	self assert: (aClass hasSlotNamed: #slot1).
	self compileAccessorsFor: slot.
	object := aClass new.

	"test compiled write and read"
	self assert: (object slot1) equals: 5.
	object slot1: 10.
	self assert: (object slot1) equals: 10
	
	
	
	
	! !

!InitializedSlotTest methodsFor: 'tests' stamp: ''!
testLazyClassVariableReflectiveBlockParameter
	| classVar |
	classVar := #ClassVar => LazyClassVariable default: [:class | class].
	aClass := self make: [ :builder | builder sharedVariables: {classVar}].

	self assert: classVar read equals: aClass! !

!InitializedSlotTest methodsFor: 'tests' stamp: ''!
testReflectiveReadWrite
	| slot object|
	slot := #slot1 => InitializedSlot default: 5.
	aClass := self make: [ :builder | builder slots: {slot}].
	self assert: (aClass hasSlotNamed: #slot1).
	object := aClass new.

	"test reflective write and read"
	self assert: (slot read: object) equals: 5.
	slot write: 10 to: object.
	self assert: (slot read: object) equals: 10
	
	
	
	
	! !

!InlineTextDiffBuilder commentStamp: ''!
Line based Text diff builder!
!InlineTextDiffBuilder methodsFor: 'private' stamp: ''!
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! !

!InputTextDropList commentStamp: ''!
I am an elementary Spec widget that associates an TextInputField and a DropListPresenter.

self example

I provide accessors dropList and input and shortcuts for the most common methods of their api.!
!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
emptyList
	self dropList emptyList! !

!InputTextDropList methodsFor: 'accessing' stamp: ''!
input
	^ input! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
selectedItem
	self dropList selectedItem! !

!InputTextDropList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectedItemChanged: aBlock
	self dropList whenSelectedItemChanged: aBlock! !

!InputTextDropList methodsFor: 'initialization' stamp: ''!
initializeWidgets
	input := self instantiate: TextInputFieldPresenter.
	dropList := self instantiate: DropListPresenter.
	self focusOrder
		add: input;
		add: dropList! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
encrypted: aBoolean
	self input encrypted: aBoolean! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
setIndex: anIndex
	self dropList setIndex: anIndex! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
listSize
	self dropList listSize! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
text: aText
	self input text: aText! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
resetSelection
	self dropList resetSelection! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
acceptOnCR: aBoolean
	self input acceptOnCR: aBoolean! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
ghostText: aText
	self input ghostText: aText! !

!InputTextDropList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionIndexChanged: aBlock
	self dropList whenSelectionIndexChanged: aBlock! !

!InputTextDropList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionChanged: aBlock
	self dropList whenSelectionChanged: aBlock! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
entryCompletion: anEntryCompletion
	self input entryCompletion: anEntryCompletion! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
items: aList
	self dropList items: aList! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
beEncrypted
	self input beEncrypted! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
displayBlock: aBlock
	self dropList displayBlock: aBlock! !

!InputTextDropList methodsFor: 'accessing' stamp: ''!
dropList
	^ dropList! !

!InputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
text
	self input text! !

!InputTextDropList class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| ex |
	ex := self new.
	ex
		ghostText: 'a Number';
		displayBlock: [ :item | item asString ];
		items: {'Potatoes' . 'Carrots' . 'Onions'};
		extent: 350 @ 50;
		title: 'InputTextDropList example';
		openWithSpec.
	^ ex! !

!InputTextDropList class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newRow: [ :row | 
			row
				add: #input origin: 0 @ 0 corner: 0.3 @ 1;
				add: #dropList origin: 0.3 @ 0 corner: 1 @ 1 ];
			yourself! !

!InsetBorder commentStamp: ''!
see BorderedMorph!
!InsetBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!InsetBorderStyle commentStamp: ''!
see BorderedMorph!
!InsetBorderStyle methodsFor: 'accessing' stamp: ''!
style
	^#inset! !

!InsetBorderStyle methodsFor: 'color tracking' stamp: ''!
trackColorFrom: aMorph
	baseColor ifNil:[self color: aMorph insetColor].! !

!InsetBorderStyle methodsFor: 'accessing' stamp: ''!
topLeftColor
	"Changed from direct access to color since, if nil,
	self color is transparent."
	
	^width = 1 
		ifTrue: [self color twiceDarker]
		ifFalse: [self color darker]! !

!InsetBorderStyle methodsFor: 'accessing' stamp: ''!
bottomRightColor
	"Changed from direct access to color since, if nil,
	self color is transparent."
	
	^width = 1 
		ifTrue: [self color twiceLighter]
		ifFalse: [self color lighter]! !

!InsetBorderStyle methodsFor: 'accessing' stamp: ''!
colorsAtCorners
	| c c14 c23 |
	c := self color.
	c14 := c lighter. c23 := c darker.
	^Array with: c23 with: c14 with: c14 with: c23.! !

!InspectDebuggerDebugAction commentStamp: ''!
Inspect the debugger!
!InspectDebuggerDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder
	^ 130! !

!InspectDebuggerDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Opens an inspector on the underlying debugger object'! !

!InspectDebuggerDebugAction methodsFor: 'accessing' stamp: ''!
executeAction 
	self debugger inspect! !

!InspectDebuggerDebugAction methodsFor: 'accessing' stamp: ''!
id
	^ #inspectDebugger! !

!InspectDebuggerDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel
	^ 'Inspect debugger'! !

!InspectDebuggerDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<contextMenuDebuggingAction>! !

!InstVarRefLocator commentStamp: ''!
My job is to scan bytecodes for instance variable references.

BlockContext allInstances collect: [ :x |
	{x. x hasInstVarRef}
].!
!InstVarRefLocator methodsFor: 'validation' stamp: ''!
check: aMethod
	| scanner end |
	scanner := InstructionStream on: aMethod.
	end := aMethod endPC.

	[scanner pc <= end] whileTrue: [
		(self interpretNextInstructionUsing: scanner) ifTrue: [^true].
	].
	^false! !

!InstVarRefLocator methodsFor: 'instruction decoding' stamp: ''!
popIntoReceiverVariable: offset 

	bingo := true! !

!InstVarRefLocator methodsFor: 'initialization' stamp: ''!
interpretNextInstructionUsing: aScanner 
	
	bingo := false.
	aScanner interpretNextInstructionFor: self.
	^bingo! !

!InstVarRefLocator methodsFor: 'instruction decoding' stamp: ''!
storeIntoReceiverVariable: offset 
	bingo := true! !

!InstVarRefLocator methodsFor: 'instruction decoding' stamp: ''!
pushReceiverVariable: offset

	bingo := true! !

!InstVarRefLocator class methodsFor: 'validation' stamp: ''!
check: aMethod
	^ self new check: aMethod! !

!InstVarRefLocatorTest commentStamp: ''!
This is the unit test for the class InstVarRefLocator. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- there is a chapter in the PharoByExample book (http://pharobyexample.org)
	- the sunit class category!
!InstVarRefLocatorTest methodsFor: 'tests' stamp: ''!
testExample1
	| method |

	method := self class compiledMethodAt: #example1.
	self assert: (self hasInstVarRef: method).! !

!InstVarRefLocatorTest methodsFor: 'examples' stamp: ''!
example1
	<sampleInstance>
	| ff |
	(1 < 2) ifTrue: [tt ifNotNil: [ff := 'hallo']].
	^ ff.! !

!InstVarRefLocatorTest methodsFor: 'tests' stamp: ''!
testExample2
	| method |

	method := self class compiledMethodAt: #example2.
	self deny: (self hasInstVarRef: method).! !

!InstVarRefLocatorTest methodsFor: 'examples' stamp: ''!
example2
	<sampleInstance>
	| ff |	
	ff := 1.
	(1 < 2) ifTrue: [ff ifNotNil: [ff := 'hallo']].
	^ ff.! !

!InstVarRefLocatorTest methodsFor: 'private' stamp: ''!
hasInstVarRef: aMethod
	"Answer whether the receiver references an instance variable."

	| scanner end printer |

	scanner := InstructionStream on: aMethod.
	printer := InstVarRefLocator new.
	end := scanner method endPC.

	[scanner pc <= end] whileTrue: [
		(printer interpretNextInstructionUsing: scanner) ifTrue: [^true].
	].
	^false! !

!InstVarRefLocatorTest methodsFor: 'tests' stamp: ''!
testInstructions
	Object methods
		do: [ :method | 
			| scanner printer end |
			scanner := InstructionStream on: method.
			printer := InstVarRefLocator new.
			end := scanner method endPC.
			[ scanner pc <= end ] whileTrue: [ printer interpretNextInstructionUsing: scanner ] ]! !

!InstanceVariableNotFound commentStamp: ''!
Description
--------------------------

I am an exception raised when we try to access to an instance variable by its name but the receiver does not know this instance variable.

Examples 
--------------------------

	InstanceVariableNotFound signalFor: 'test'.
	
	Object new instVarNamed: 'test'.
	
	[ Object new instVarNamed: 'test' ] on: InstanceVariableNotFound do: [ :ex | ex ].

Internal Representation and Key Implementation Points.
--------------------------

    Instance Variables
	instVarName:		<aString>	Name of the instance variable we tried to access.!
!InstanceVariableNotFound methodsFor: 'accessing' stamp: ''!
instVarName
	^ instVarName! !

!InstanceVariableNotFound methodsFor: 'accessing' stamp: ''!
standardMessageText
	"Generate a standard textual description"

	^ String
		streamContents: [ :stream | 
			stream nextPutAll: self instVarName.
			stream nextPutAll: ' not found in '.
			stream print: self signaler ]! !

!InstanceVariableNotFound methodsFor: 'accessing' stamp: ''!
instVarName: anObject
	instVarName := anObject! !

!InstanceVariableNotFound methodsFor: 'accessing' stamp: ''!
messageText
	"Overwritten to initialiaze the message text to a standard text if it has not yet been set"
	
	^ messageText ifNil: [ messageText := self standardMessageText ]! !

!InstanceVariableNotFound class methodsFor: 'signalling' stamp: ''!
signalFor: aString
	"Create and signal a NoInstanceVariableNAmed exception for aString in the default receiver."
	
	^ self new
		instVarName: aString;
		signal! !

!InstanceVariableSlot commentStamp: ''!
I add some special behavior: 
	- I override bytecode generation to generate ivar read and write bytecodes
	- I print the definition as #name 
	
If you subclass this class, take note that as it overrides both #emitStore: and #emitValue: to use the fast bytecode, it will *not* call the reflective #read: and #write:to: methods.

!
!InstanceVariableSlot methodsFor: 'testing' stamp: ''!
isAccessedIn: aCompiledCode
	^ aCompiledCode accessesField: index! !

!InstanceVariableSlot methodsFor: 'printing' stamp: ''!
definitionOn: aStream
	"non special globals are defined by the symbol"
	^self needsFullDefinition
		ifTrue: [ super definitionOn: aStream ]
		ifFalse: [ self name printOn: aStream ]! !

!InstanceVariableSlot methodsFor: 'testing' stamp: ''!
isReadIn: aCompiledCode
	^aCompiledCode readsField: index! !

!InstanceVariableSlot methodsFor: 'testing' stamp: ''!
isWrittenIn: aCompiledCode
	^aCompiledCode writesField: index! !

!InstanceVariableSlot methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder
	"emit the bytecode to push ivar"
	methodBuilder pushInstVar: index! !

!InstanceVariableSlot methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder
	"generate store bytecode"
	methodBuilder storeInstVar: index! !

!InstanceVariableSlot methodsFor: 'testing' stamp: ''!
needsFullDefinition
	"I am just a backward compatible ivar slot and can use simple definitions.
	 Note: my subclasses need full definitions"

	^ self class ~= InstanceVariableSlot! !

!InstanceVariableSlot methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment
	
	^ self class == InstanceVariableSlot 
		ifTrue: [
			anRGEnvironment backend definitionFor: self ifAbsentRegister: [
				RGInstanceVariableSlot
					named: self name asSymbol
					parent:
						(self definingClass classLayout asRingMinimalDefinitionIn: anRGEnvironment)]]
		ifFalse: [ super asRingMinimalDefinitionIn: anRGEnvironment ]

! !

!InstanceVariableSlot class methodsFor: 'cleanup' stamp: ''!
resetIvarSlots
	"when the Ivar slots need to be re-created (e.g. due to changes in the layout of the class),
	 this method re-creates for every ivar a ivar slot"
	"to be removed later when the system is in a stable state"

	| block |
	block := [ :class | 
	class instVarNames
		withIndexDo: [ :ivarName :index | 
			class classLayout slotScope
				at: index
				put:
					((InstanceVariableSlot named: ivarName asSymbol)
						index: index + class superclass allInstVarNames size;
						yourself) ] ].
	Smalltalk allClasses
		do: [ :class | 
			block value: class.
			block value: class classSide ]! !

!InstructionClient commentStamp: ''!
My job is to make it easier to implement clients for InstructionStream. See InstVarRefLocator
as an example. !
!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
	"Store Top Of Stack And Store Into Offset of Temp Vector bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushConsArrayWithElements: numElements
	"Push Cons Array of size numElements popping numElements items from the stack into the array bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
	"Remove Top Of Stack And Store Into Offset of Temp Vector bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushClosureTemps: numTemps
	"push on stack nil numTemps times for the closure temps"! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
trap
	"send the class trap message to the current context."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushConstant: value
	"Push Constant, value, on Top Of Stack bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
popIntoLiteralVariable: anAssociation 
	"Remove Top Of Stack And Store Into Literal Variable bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
unusedBytecode
		"an unused bytecode is encountered"! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
send: selector super: supered numArgs: numberArguments
	"Send Message With Selector, selector, bytecode. The argument, 
	supered, indicates whether the receiver of the message is specified with 
	'super' in the source method. The arguments of the message are found in 
	the top numArguments locations on the stack and the receiver just 
	below them."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushActiveProcess
	"Push Active Process On Top Of Its Own Stack bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
doPop
	"Remove Top Of Stack bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushReceiver
	"Push Active Context's Receiver on Top Of Stack bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
jump: offset withInterpreter: anInterpreter
	
	^ self jump: offset! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pc: aPC

	"Set the pc to the given PC"! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
blockReturnConstant: value 
	"Return Constant From Block bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
methodReturnConstant: value 
	"Return Constant bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushLiteralVariable: anAssociation
	"Push Contents Of anAssociation On Top Of Stack bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushNewArrayOfSize: numElements 
	"Push New Array of size numElements bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
doDup
	"Duplicate Top Of Stack bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
jump: offset if: condition 
	"Conditional Jump bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
methodReturnTop
	"Return Top Of Stack bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
storeIntoTemporaryVariable: offset 
	"Store Top Of Stack Into Temporary Variable Of Method bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
directedSuperSend: selector numArgs: numArgs
	"Send Message Above Specific Class With Selector, selector, bytecode.
	 Start the lookup above the class that is the value of the association on
	 top of stack. The arguments  of the message are found in the top numArgs
	 stack locations beneath the association, and the receiver just below them."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
methodReturnReceiver
	"Return Self bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushActiveContext
	"Push Active Context On Top Of Its Own Stack bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
doNop
	"Do nothing (nop = no operation)"! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
popIntoReceiverVariable: offset 
	"Remove Top Of Stack And Store Into Instance Variable bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
callPrimitive: pimIndex
	"V3PlusClosures:	139 10001011	iiiiiiii   jjjjjjjj  Call Primitive #iiiiiiii + (jjjjjjjj * 256)
	 NewsqueakV4:		249 11111001	iiiiiiii   jjjjjjjj  Call Primitive #iiiiiiii + (jjjjjjjj * 256)
	 SistaV1:			248 11111000 iiiiiiii mjjjjjjj  Call Primitive #iiiiiiii + ( jjjjjjj * 256)
							m=1 means inlined primitive, no hard return after execution."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
storeIntoLiteralVariable: anAssociation 
	"Store Top Of Stack Into Literal Variable Of Method bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushTemporaryVariable: offset
	"Push Contents Of Temporary Variable Whose Index Is the 
	argument, offset, On Top Of Stack bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
jump: offset if: condition withInterpreter: anInterpreter
	
	^ self jump: offset if: condition! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
popIntoTemporaryVariable: offset 
	"Remove Top Of Stack And Store Into Temporary Variable bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
blockReturnTop
	"Return Top Of Stack bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
trapIfNotInstanceOf: behaviorOrArrayOfBehavior 
	"If the top of stack is not an instance of either the argument, or, if the
	argument is an Array,
	any of the elements of the argument, send the class trap message
	to the current context."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushFullClosure: aCollection numCopied: anInteger receiverOnStack: aFalse ignoreOuterContext: aFalse4 
	"Push Full Closure bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
storeIntoReceiverVariable: offset 
	"Store Top Of Stack Into Instance Variable Of Method bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
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: ''!
jump: offset
	"Unconditional Jump bytecode."! !

!InstructionClient methodsFor: 'instruction decoding' stamp: ''!
pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
	"Push Contents at Offset in Temp Vector bytecode."! !

!InstructionClientTest commentStamp: ''!
This is the unit test for the class InstructionClient. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- there is a chapter in the PharoByExample book (http://pharobyexample.org)
	- the sunit class category!
!InstructionClientTest methodsFor: 'tests' stamp: ''!
testInstructions
	"just interpret all of methods of Object"

	| client |
	client := InstructionClient new.
	Object methods
		do: [ :method | 
			| scanner |
			scanner := InstructionStream on: method.
			[ scanner pc <= method endPC ] whileTrue: [ scanner interpretNextInstructionFor: client ] ]! !

!InstructionStream commentStamp: ''!
Instance variables:
	sender: <Context|nil> context that invoked this context
	pc: <SmallInteger> (pc = program counter) offset of the bytecode instruction currently executed

My instances can interpret the byte-encoded Smalltalk instruction set. They maintain a program counter (pc) for streaming through CompiledMethods. My subclasses are Contexts, which inherit this capability. They store the return pointer in the instance variable sender, and the current position in their method in the instance variable pc. For other users, sender can hold a method to be similarly interpreted. The unclean re-use of sender to hold the method was to avoid a trivial subclass for the stand-alone scanning function.!
!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
selectorToSendOrSelf
	"If this instruction is a send, answer the selector, otherwise answer self."
 
	^ self method encoderClass selectorToSendOrItselfFor: self in: self method at: pc! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
followingPc
	"Answer the pc of the following bytecode."

	^self nextPc: (self method at: pc)! !

!InstructionStream methodsFor: 'accessing' stamp: ''!
compiledCode
	^self method! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
secondByte
	"Answer the second byte of the current bytecode."

	^self method at: pc + 1! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
previousPc

	"Return the PC of the instruction preceding the current one"
	^self method pcPreviousTo: pc! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
decodeNextInstruction
	"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: '*Debugging-Core' stamp: ''!
scanFor: scanBlock
	"Check all bytecode instructions with scanBlock, answer true if scanBlock answers true.
	This can be used to, e.g., check whether a method contains 'push closure' bytecodes like this:
	aMethod scanFor: [ :b | b = 143 ]"

	| method encoderClass end byte |
	method := self method.
	end := method endPC.
	encoderClass := method encoderClass.
	[pc <= end] whileTrue: 
		[(scanBlock value: (byte := method at: pc)) ifTrue:
			[^true].
		 pc := pc + (encoderClass bytecodeSize: byte)].
	^false! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
willReturn
	"Answer whether the next bytecode is a return."

	^ self method encoderClass isReturnAt: pc in: self method! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
advanceToFollowingPc
	"Advance the PC to the next valid PC in the instruction stream.
	Take into account that the current instruction may have a variable size and occupy more than a single byte."

	pc := self followingPc! !

!InstructionStream methodsFor: 'interpreting' stamp: ''!
interpretSistaV1ExtendedPush: extB for: client 
	"Implement the extended push for non-zero extensions."
	"*	82			01010010			Push thisContext, (then Extend B = 1 => push
	thisProcess) "
	extB = 0
		ifTrue: [^ client pushActiveContext].
	extB = 1
		ifTrue: [^ client pushActiveProcess].
	self error: 'undefined extended push'! !

!InstructionStream methodsFor: 'private' stamp: ''!
pc: anInteger

	pc := anInteger! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
addSelectorTo: set 
	"If this instruction is a send, add its selector to set."

	| selectorOrSelf |
	(selectorOrSelf := self selectorToSendOrSelf) == self ifFalse:
		[set add: selectorOrSelf]! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
willCreateBlock
	"next bytecode is a block creation"

	^ (self method encoderClass isCreateBlockAt: pc in: self method) or: 
		[ self method encoderClass isCreateFullBlockAt: pc in: self method]! !

!InstructionStream methodsFor: 'interpreting' stamp: ''!
interpretNext2ByteSistaV1Instruction: bytecode for: client extA: extA extB: extB startPC: startPC
	"Send to the argument, client, a message that specifies the next instruction.
	 This method handles the two-byte codes.
	 For a table of the bytecode set, see EncoderForV1's class comment."

	| byte method |
	method := self compiledCode.
	byte := self compiledCode at: pc.
	pc := pc + 1.
	client pc: pc.
	"We do an inline quasi-binary search on bytecode"
	bytecode < 234 ifTrue: "pushes"
		[bytecode < 231 ifTrue:
			[bytecode < 229 ifTrue:
				[| literal |
				 bytecode = 226 ifTrue:
					[^client pushReceiverVariable: (extA bitShift: 8) + byte].
				 literal := method literalAt: (extA bitShift: 8) + byte + 1.
				 bytecode = 227 ifTrue:
					[^client pushLiteralVariable: literal].
				 ^client pushConstant: literal].
			bytecode = 229 ifTrue:
				[^client pushTemporaryVariable: byte]. 
			^client pushClosureTemps: byte]. 
		bytecode = 231 ifTrue:
			[^byte < 128
				ifTrue: [client pushNewArrayOfSize: byte]
				ifFalse: [client pushConsArrayWithElements: byte - 128]].
		bytecode = 232 ifTrue:
			[^client pushConstant: (extB bitShift: 8) + byte].
		^client pushConstant: (Character value: (extB bitShift: 8) + byte)].
	bytecode < 240 ifTrue: "sends, trap and jump"
		[bytecode < 236 "sends" 
			ifTrue: [
			"The 64 is used as a mark to tell if the send is a direct super send"
			extB >= 64 
				ifTrue: [ | fixedExtB |
					fixedExtB := extB - 64.
					^ client 
						 directedSuperSend: (method literalAt: (extA bitShift: 5) + (byte // 8) + 1)
						 numArgs: (fixedExtB bitShift: 3) + (byte \\ 8)].
			^client
				send: (method literalAt: (extA bitShift: 5) + (byte // 8) + 1)
				super: bytecode = 235
				numArgs: (extB bitShift: 3) + (byte \\ 8)].

		 bytecode = 236 ifTrue:
			[^client trapIfNotInstanceOf: (method literalAt: (extA bitShift: 8) + byte + 1)].
		bytecode = 237 ifTrue:
			[^client jump: (extB bitShift: 8) + byte withInterpreter: self].
		 ^client jump: (extB bitShift: 8) + byte if: bytecode = 238 withInterpreter: self].
	bytecode < 243 ifTrue:
		[bytecode = 240 ifTrue:
			[^client popIntoReceiverVariable: (extA bitShift: 8) + byte].
		 bytecode = 241 ifTrue:
			[^client popIntoLiteralVariable: (method literalAt: (extA bitShift: 8) + byte + 1)].
		 ^client popIntoTemporaryVariable: byte].
	bytecode = 243 ifTrue:
		[^client storeIntoReceiverVariable: (extA bitShift: 8) + byte].
	bytecode = 244 ifTrue:
		[^client storeIntoLiteralVariable: (method literalAt: (extA bitShift: 8) + byte + 1)].
	bytecode = 245 ifTrue:
		[^client storeIntoTemporaryVariable: byte].
	"246-247	1111011 i	xxxxxxxx	UNASSIGNED"
	^self interpretUnusedBytecode: client at: startPC! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
followingBytecode
	"Answer the bytecode of the following bytecode (different to nextByte)."

	^self method at: self followingPc! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
atEnd

	^ pc > self method endPC! !

!InstructionStream methodsFor: '*OpalCompiler-Tests' stamp: ''!
peekInstruction
	"Return the next bytecode instruction as a message that an InstructionClient would understand.  The pc remains unchanged."

	| currentPc instruction |
	currentPc := self pc.
	instruction := self decodeNextInstruction.
	self pc: currentPc.
	^ instruction! !

!InstructionStream methodsFor: 'interpreting' stamp: ''!
interpretNextInstructionFor: client 
	"Send to the argument, client, a message that specifies the type of the 
	next instruction."
	^ self compiledCode encoderClass interpretNextInstructionFor: client  in: self! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
thirdByte
	"Answer the third byte of the current bytecode."

	^self method at: pc + 2! !

!InstructionStream methodsFor: 'scanning' stamp: ''!
method
	"Answer the compiled method that supplies the receiver's bytecodes."

	^sender		"method access when used alone (not as part of a context)"! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
willStore
	"Answer whether the next bytecode is a store or store-pop"

	^ self method encoderClass isStoreAt: pc in: self method! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
willJumpIfFalse
	"Answer whether the next bytecode is a jump-if-false."

	^ self method encoderClass isBranchIfFalseAt: pc in: self method! !

!InstructionStream methodsFor: 'interpreting' stamp: ''!
interpretNext3ByteSistaV1Instruction: bytecode for: client extA: extA extB: extB startPC: startPC
	"Send to the argument, client, a message that specifies the next instruction.
	 This method handles the three-byte codes.
	 For a table of the bytecode set, see EncoderForSistaV1's class comment."

	| method byte2 byte3 |
	method := self compiledCode.
	byte2 := method at: pc.
	byte3 := method at: pc + 1.
	pc := pc + 2.
	client pc: pc.
	"we search the bytecodes by what we expect to be the static frequency."
	bytecode = 248 ifTrue:
		[^client callPrimitive: byte2 + (byte3 bitShift: 8)].
	bytecode = 250 ifTrue:
		[self error: 'We only support full blocks'].
	bytecode = 251 ifTrue:
		[^client pushRemoteTemp: byte2 inVectorAt: byte3].
	bytecode = 252 ifTrue:
		[^client storeIntoRemoteTemp: byte2 inVectorAt: byte3].
	bytecode = 253 ifTrue:
		[^client popIntoRemoteTemp: byte2 inVectorAt: byte3].
	"249		11111001 	xxxxxxxx	syyyyyyy	Reserved for Push Float"
	bytecode = 254 ifTrue: 
		[^client 
			jumpOrPopIfNotInstanceOf: (method literalAt: (extA bitShift: 8) + byte2 + 1) 
			distance: ((extB bitShift: 8) + byte3) ].
	bytecode = 249 ifTrue: 
		[^client 
			pushFullClosure: (method literalAt: (extA bitShift: 8) + byte2 + 1) 
			numCopied: (byte3 bitAnd: 16r3F) 
			receiverOnStack: (byte3 bitAt: 7) = 1
			ignoreOuterContext: (byte3 bitAt: 8) = 1 ].
	^self interpretUnusedBytecode: client at: startPC! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
interpret
	"Interpret / evaluate the current method in the current context until the end.
	Use the context as client of the interpretation as well as the decoder of instructions.
	The context is a client that evaluates instructions"
	self interpretWithClient: self! !

!InstructionStream methodsFor: '*Deprecated10' stamp: ''!
debuggerMap
	self deprecated: 'please use the reflective API directly to read variables!!'.
	^self method debuggerMap! !

!InstructionStream methodsFor: 'interpreting' stamp: ''!
interpretNextSistaV1InstructionFor: client
	"Send to the argument, client, a message that specifies the next instruction."

	| byte div16 offset method extA extB savedPC |
	method := self compiledCode.
	"For a table of the bytecode set, see EncoderForSistaV1's class comment."
	"consume and compute any extensions first."
	extA := extB := 0.
	savedPC := pc.
	[byte := self compiledCode at: pc.
	 pc := pc + 1.
	 byte between: 16rE0 and: 16rE1] whileTrue:
		[| extByte |
		 extByte := self compiledCode at: pc.
		 pc := pc + 1.
		 byte = 16rE0
			ifTrue:
				[extA := (extA bitShift: 8) + extByte]
			ifFalse:
				[extB := (extB = 0 and: [extByte > 127])
							ifTrue: [extByte - 256]
							ifFalse: [(extB bitShift: 8) + extByte]]].
	client pc: pc.
	div16 := byte // 16.
	offset := byte \\ 16.
	"We do an inline quasi-binary search on each of the possible 16 values of div16"
	div16 < 11 ifTrue:
		[div16 < 6 ifTrue:
			[div16 < 4 ifTrue:
				[div16 < 2 ifTrue:
					[div16 = 0 ifTrue:
						 [^client pushReceiverVariable: offset].
					^client pushLiteralVariable: (method literalAt: offset + 1)]. "div16 = 1"
				 ^client pushConstant: (method literalAt: byte \\ 32 + 1)].
			 div16 = 4 ifTrue:
				[offset < 12 ifTrue:
					[^client pushTemporaryVariable: offset].
				 offset = 12 ifTrue:
					[^client pushReceiver].
				 offset = 13 ifTrue:
					[^client pushConstant: true].
				 offset = 14 ifTrue:
					[^client pushConstant: false].
				 offset = 15 ifTrue:
					[^client pushConstant: nil]].
			"div16 = 5"
			 offset < 2 ifTrue:
				[^client pushConstant: offset].
			 offset = 2 ifTrue:
				[^self interpretSistaV1ExtendedPush: extB for: client].
			 offset = 3 ifTrue:
				[^client doDup].
			
			 offset = 8 ifTrue:
				[^client methodReturnReceiver].
			 offset = 9 ifTrue:
				[^client methodReturnConstant: true].
			 offset = 10 ifTrue:
				[^client methodReturnConstant: false].
			 offset = 11 ifTrue:
				[^client methodReturnConstant: nil].
			 offset = 12 ifTrue:
				[^client methodReturnTop].
			 offset = 13 ifTrue:
				[^client blockReturnConstant: nil].
			 offset = 14 ifTrue:
				[^client blockReturnTop].
			 offset = 15 ifTrue:
				[^client doNop].
			 ^self interpretUnusedBytecode: client at: savedPC].
		"short sends"
		div16 = 6 ifTrue:
			[^client
				send: (Smalltalk specialSelectorAt: offset + 1)
				super: false
				numArgs: (Smalltalk specialNargsAt: offset + 1)].
		 div16 = 7 ifTrue:
			[^client
				send: (Smalltalk specialSelectorAt: offset + 17)
				super: false
				numArgs: (Smalltalk specialNargsAt: offset + 17)].
		^client
			send: (method literalAt: offset + 1)
			super: false
			numArgs: div16 - 8].
	"div16 >= 11; bytecode >= 176"
	div16 < 14 ifTrue:
		[div16 = 11 ifTrue:
			[offset < 8 ifTrue:
				[^client jump: offset + 1 withInterpreter: self].
			 ^client jump: offset - 7 if: true withInterpreter: self].
		 div16 = 12 ifTrue:
			[offset < 8 ifTrue:
				[
				^client jump: offset + 1 if: false withInterpreter: self].
			 ^client popIntoReceiverVariable: offset - 8].
		 "div16 = 13"
		 offset < 8 ifTrue:
		 	[^client popIntoTemporaryVariable: offset].
		 offset = 8 ifTrue: [ ^ client doPop ].
		 offset = 9 ifTrue: [ ^ client trap ].
		^self interpretUnusedBytecode: client at: savedPC].
	"2 byte and 3 byte codes"
	byte < 248 ifTrue:
		[^self interpretNext2ByteSistaV1Instruction: byte for: client extA: extA extB: extB startPC: savedPC].
	^self interpretNext3ByteSistaV1Instruction: byte for: client extA: extA extB: extB startPC: savedPC! !

!InstructionStream methodsFor: 'scanning' stamp: ''!
pc
	"Answer the index of the next bytecode."

	^pc! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
peekByte
	"Answer the first byte of the current bytecode."

	^self method at: pc! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
interpretWithClient: aClient
	| endPC |
	endPC := self method endPC.
	[pc > endPC] whileFalse: [self interpretNextInstructionFor: aClient]! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
willSend
	"Answer whether the next bytecode is a message-send."

	^ self method encoderClass isSendAt: pc in: self method! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
willJustPop

	^ self method encoderClass isJustPopAt: pc in: self method! !

!InstructionStream methodsFor: '*Debugging-Core' stamp: ''!
nextPc: currentByte
	"Answer the pc of the next bytecode following the current one, given the current bytecode.
	 Skips the extension bytecodes."
	^ pc + (self method encoderClass instructionSizeAt: pc of: self method)! !

!InstructionStream methodsFor: 'private' stamp: ''!
method: method pc: startpc

	sender := method. 
	"allows this class to stand alone as a method scanner"
	pc := startpc! !

!InstructionStream methodsFor: 'interpreting' stamp: ''!
interpretUnusedBytecode: client at: startPC
	^ client unusedBytecode! !

!InstructionStream class methodsFor: 'class initialization' stamp: ''!
initialize
	"Initialize an array of special constants returned by single-bytecode returns."

	SpecialConstants := 
		(Array with: true with: false with: nil)
			, (Array with: -1 with: 0 with: 1 with: 2)	
	"InstructionStream initialize."! !

!InstructionStream class methodsFor: 'instance creation' stamp: ''!
on: method 
	"Answer an instance of me on the argument, method."

	^self on: method pc: method initialPC! !

!InstructionStream class methodsFor: '*OpalCompiler-Core' stamp: ''!
compiler
	"The JIT compiler needs to trap all reads to instance variables of contexts. As this check is costly, it is only done in the long form of the bytecodes, which are not used often. In this hierarchy we force the compiler to alwasy generate long bytecodes"
	^super compiler options: #(+ optionLongIvarAccessBytecodes)! !

!InstructionStream class methodsFor: 'instance creation' stamp: ''!
on: method pc: aPC
	"Answer an instance of me on the argument, method."

	^self new method: method pc: aPC! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testStepThroughInAMethodWithoutError

	| initialContext aContext receiver suspendedProcess return |
	
	receiver := self classUnderTest new.
	suspendedProcess := [ receiver callingAMethodWithSuspendAndReturnANumber ] forkAt: Processor activePriority + 1.

	initialContext := aContext := suspendedProcess suspendedContext.
	[ initialContext method = (self classUnderTest >> #callingAMethodWithSuspendAndReturnANumber) ] 
		whileFalse: [ initialContext := initialContext sender].
	
	return := suspendedProcess stepToHome: initialContext.
	
	"Suspended process should stop in the exception"	
	self assert: return method equals: (self classUnderTest >> #callingAMethodWithSuspendAndReturnANumber).
	self assert: return top equals: 42.! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testStepThroughInAMethodWithMNU

	| initialContext aContext receiver suspendedProcess return |
	
	receiver := self classUnderTest new.
	suspendedProcess := [ receiver callingAMethodWithMNU ] forkAt: Processor activePriority + 1.

	initialContext := aContext := suspendedProcess suspendedContext.
	[ initialContext method = (self classUnderTest >> #callingAMethodWithMNU) ] 
		whileFalse: [ initialContext := initialContext sender].
	
	return := suspendedProcess stepToHome: initialContext.
	
	"Suspended process should stop in the exception"	
	self assert: return method equals: (self classUnderTest lookupSelector: #doesNotUnderstand:).! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testStepSendPopsArgumentsAndPushesResultBytecodes

	| context stream |
	context := [ 1 + 2 ] asContext.
	stream := InstructionStream on: context method.
	
	3 timesRepeat: [
		stream interpretNextInstructionFor: context ].

	self assert: context stackPtr equals: 1 "elements on the stack".
	self assert: context top equals: 3! !

!InstructionStreamTest methodsFor: 'helpers' stamp: ''!
directedSuperSend: aString numArgs: anInteger 
	
	operations add: { #directSuperSend:numArgs:. aString. anInteger }! !

!InstructionStreamTest methodsFor: 'tests' stamp: ''!
testNextPcAnswerNextBytecodePcInCaseOfExtension

	| stream methodToTest ir startingPc |
	methodToTest := ClassUsedInInstructionStreamTest
	                >> #newMethodWithALotOfLiteralsToTestExtensions.
	ir := (methodToTest ast allChildren select: [ :e | e isMessage ])
		      anyOne irInstruction.
	startingPc := ir bytecodeOffset.
	stream := InstructionStream new
		          method: methodToTest
		          pc: startingPc.
		
	"16rE0 16rE1 are extensions that help handling lot of literals.
	When such an extension is encoutered the next pc shoudl skip them.
	In our case we have 1 extension and the bytecode so the next pc is at the size of this extension plus the size of the bytecode extended (2 + 2)"	
	
	self assert: (stream nextPc: 16rE0) equals: startingPc + 4.! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testSimulatedTerminationOfProcessDoNotCorruptTheContext

	| initialContext aContext receiver semaphore process suspendedProcess return errorThatHappen |
	
	receiver := self classUnderTest new.
	semaphore := Semaphore new.
	process := [ semaphore wait ] forkAt: Processor activePriority + 1.
	receiver process: process.
	suspendedProcess := [ receiver callingAMethodSuspendedBeforeTheTerminateOfAnotherProcess ] forkAt: Processor activePriority + 1.

	initialContext := aContext := suspendedProcess suspendedContext.
	[ initialContext method = (self classUnderTest >> #callingAMethodSuspendedBeforeTheTerminateOfAnotherProcess) ] 
		whileFalse: [ initialContext := initialContext sender].
	
	[return := suspendedProcess stepToHome: initialContext] 
		on: Exception do: [:e | errorThatHappen := e ].

	self assert: errorThatHappen isNil.
	self assert: receiver expectedValue equals: 42! !

!InstructionStreamTest methodsFor: 'helpers' stamp: ''!
pushConstant: anInteger 

	operations add: { #pushConstant. anInteger }! !

!InstructionStreamTest methodsFor: 'helpers' stamp: ''!
classUnderTest 

	^ ClassUsedInInstructionStreamTest! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testStepSingleBytecode

	| context stream |
	context := [ 1 ] asContext.
	stream := InstructionStream on: context method.
	
	stream interpretNextInstructionFor: context.
	
	self assert: context top equals: 1! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testStepNonTakenConditionalJumpBytecodes

	| context stream |
	"Assume ifTrue: conditional jumps are compiled as jumpIfFalse"
	context := [ (true ifTrue: [ 1 ] ifFalse: [2]) + 7 ] asContext.
	stream := InstructionStream on: context method.
	
	6 timesRepeat: [
		"push true, not jump, push 1, jump to end, push 7, send +"
		stream interpretNextInstructionFor: context ].

	self assert: context top equals: 8! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testStepTwoBytecodes

	| context stream |
	context := [ 1 + 2 ] asContext.
	stream := InstructionStream on: context method.
	
	2 timesRepeat: [
		stream interpretNextInstructionFor: context ].

	self assert: context top equals: 2! !

!InstructionStreamTest methodsFor: 'helpers' stamp: ''!
send: aString super: aBoolean numArgs: anInteger 

	operations add: { #send:super:numArgs:. aString. aBoolean. anInteger }! !

!InstructionStreamTest methodsFor: 'tests' stamp: ''!
testBlockWithASuperSendHasCorrectNumberOfArguments

	| aMethod aCompiledBlock aStream |
	aMethod := self classUnderTest >> #methodWithASuperBlock.
	aCompiledBlock := aMethod literals at:1.
	
	self assert: aCompiledBlock isCompiledBlock.
	
	aStream := InstructionStream on: aCompiledBlock.

	aStream interpretWithClient: self.
		
	self assert: operations fifth equals: { #directSuperSend:numArgs:. #aSuperMethod:with:. 2 }! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testStepContextNonTakenConditionalJumpBytecodes

	| context |
	"Assume ifTrue: conditional jumps are compiled as jumpIfFalse"
	context := [ (true ifTrue: [ 1 ] ifFalse: [2]) + 7 ] asContext.
	
	6 timesRepeat: [
		"push true, not jump, push 1, jump to end, push 7, send +"
		context step ].

	self assert: context top equals: 8! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testSteppingSendsDirectSend

	| initialContext aContext receiver |
	
	receiver := self classUnderTest new.
	
	initialContext := Context 
		sender: nil receiver: receiver 
		method: self classUnderTest >> #valueOfBlockWithSupersend 
		arguments: #().

	aContext := initialContext.

	[aContext = nil] 
		whileFalse: [aContext := aContext step].
		
	self assert: receiver expectedValue equals: 42! !

!InstructionStreamTest methodsFor: 'helpers' stamp: ''!
blockReturnTop
	
		operations add: { #blockReturnTop }! !

!InstructionStreamTest methodsFor: 'helpers' stamp: ''!
pushReceiver
	
	operations add: {#pushReceiver}! !

!InstructionStreamTest methodsFor: 'accessing' stamp: ''!
pc: anInteger 
	
	"Ignore the PC"! !

!InstructionStreamTest methodsFor: 'tests' stamp: ''!
testBlockWithASuperWithoutArgumentsSendHasCorrectNumberOfArguments

	| aMethod aCompiledBlock aStream |
	aMethod := self classUnderTest >> #methodWithASuperBlockWithoutArguments.
	aCompiledBlock := aMethod literals at:1.
	
	self assert: aCompiledBlock isCompiledBlock.
	
	aStream := InstructionStream on: aCompiledBlock.

	aStream interpretWithClient: self.
		
	self assert: operations third equals: { #directSuperSend:numArgs:. #yourself. 0 }! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testSimulatingAMethodWithHaltHasCorrectContext

	| initialContext aContext receiver suspendedProcess return |
	
	receiver := self classUnderTest new.
	suspendedProcess := [ receiver callingAMethodWithHalt ] forkAt: Processor activePriority + 1.

	initialContext := aContext := suspendedProcess suspendedContext.
	[ initialContext method = (self classUnderTest >> #callingAMethodWithHalt) ] 
		whileFalse: [ initialContext := initialContext sender].
	
	return := suspendedProcess stepToHome: initialContext.
	
	"Suspended process should stop in the exception"	
	self assert: return method equals: (Object >> #halt).
	self assert: return size equals: 1.! !

!InstructionStreamTest methodsFor: 'helpers' stamp: ''!
pushLiteralVariable: aLiteralVariable 

	operations add: { #pushConstant. aLiteralVariable }! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testStepContextTakenConditionalJumpBytecodes

	| context |
	"Assume ifTrue: conditional jumps are compiled as jumpIfFalse"
	context := [ false ifTrue: [ 1 ]. 2 ] asContext.
	
	3 timesRepeat: [
		"push false, jump, push 2"
		context step ].

	self assert: context top equals: 2! !

!InstructionStreamTest methodsFor: 'tests - example' stamp: ''!
testStepTakenConditionalJumpBytecodes

	| context stream |
	"Assume ifTrue: conditional jumps are compiled as jumpIfFalse"
	context := [ false ifTrue: [ 1 ]. 2 ] asContext.
	stream := InstructionStream on: context method.
	
	3 timesRepeat: [
		"push false, jump, push 2"
		stream interpretNextInstructionFor: context ].

	self assert: context top equals: 2! !

!InstructionStreamTest methodsFor: 'running' stamp: ''!
setUp 

	super setUp.
	operations := OrderedCollection new! !

!Integer commentStamp: ''!
I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger.
	
Integer division consists of:
	/	exact division, answers a fraction if result is not a whole integer
	//	answers an Integer, rounded towards negative infinity
	\\	is modulo rounded towards negative infinity
	quo: truncated division, rounded towards zero!
!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
nthRootRounded: aPositiveInteger
	"Answer the integer nearest the nth root of the receiver."
	| guess |
	self = 0 ifTrue: [^0].
	self negative
		ifTrue:
			[aPositiveInteger even ifTrue: [ ArithmeticError signal: 'Negative numbers don''t have even roots.' ].
			^(self negated nthRootRounded: aPositiveInteger) negated].
	guess := self nthRootTruncated: aPositiveInteger.
	^self * 2 > ((guess + 1 raisedTo: aPositiveInteger) + (guess raisedTo: aPositiveInteger))
		ifTrue: [guess + 1]
		ifFalse: [guess]! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
printHexByteOn: characterWriteStream
	"Assuming the receiver is a byte value [0, 255],
	print a 2 character hexadecimal representation on characterWriteStream
	using the uppercase alphabet."
	
	(self between: 0 and: 255)
		ifTrue: [
			| highNibble lowNibble hexDigits |
			highNibble := self bitShift: -4.
			lowNibble := self bitAnd: 15.
			hexDigits := '0123456789ABCDEF'.
			characterWriteStream 
				nextPut: (hexDigits at: highNibble + 1);
				nextPut: (hexDigits at: lowNibble + 1) ]
		ifFalse: [ 
			self error: 'byte value between 0 and 255 expected' ]! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
lcm: n 
	"Answer the least common multiple of the receiver and n."

	^self // (self gcd: n) * n! !

!Integer methodsFor: 'system primitives' stamp: ''!
lastDigit
	"Answer the last digit of the integer base 256.  LargePositiveInteger uses bytes of base two number, and each is a 'digit'."

	^self byteAt: self bytesCount! !

!Integer methodsFor: 'private' stamp: ''!
digitSubtract: arg 
	| smaller larger z sum sl al ng |
	<primitive: 'primDigitSubtract' module:'LargeIntegers'>
	sl := self bytesCount.
	al := arg bytesCount.
	(sl = al
		ifTrue: 
			[[(self byteAt: sl)
				= (arg byteAt: sl) and: [sl > 1]]
				whileTrue: [sl := sl - 1].
			al := sl.
			(self byteAt: sl)
				< (arg byteAt: 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 byteAt: i) - (smaller byteAt: i).
		sum byteAt: i put: z - (z // 256 * 256).
		"sign-tolerant form of (z bitAnd: 255)"
		z := z // 256].
	^ sum normalize! !

!Integer methodsFor: 'printing' stamp: ''!
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: '*Keymapping-KeyCombinations' stamp: ''!
asKeyCombination
	^ KMSingleKeyCombination from: self asCharacter! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
slowFactorial
	"Answer the factorial of the receiver."
	
	"This implementation is recursive and very canonical.
	This implementation is intended for demo purposes, but for better performance
	another version 'factorial' is provided."
	
	"Example of usages:"
	
	"0 slowFactorial >>> 1"
	"1 slowFactorial >>> 1"
	"2 slowFactorial >>> 2"
	"3 slowFactorial >>> 6"
	"4 slowFactorial >>> 24"
	"5 slowFactorial >>> 120"
	"6 slowFactorial >>> 720"

	self > 0
		ifTrue: [ ^ self * (self - 1) slowFactorial ].
	self = 0
		ifTrue: [ ^ 1 ].
	self error: 'Not valid for negative integers'! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'private' stamp: ''!
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 |
	<primitive: 'primDigitDivNegative' module:'LargeIntegers'>
	arg = 0 ifTrue: [^ (ZeroDivide dividend: self) signal].
	"TFEI added this line"
	l := self bytesCount - arg bytesCount + 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 bytesCount + 1.
	"shifts so high order word is >=128"
	rem := self digitLshift: d.
	rem bytesCount = self bytesCount ifTrue: [rem := rem growto: self bytesCount + 1].
	"makes a copy and shifts"
	quo := Integer new: l neg: ng.
	dl := div bytesCount - 1.
	"Last actual byte of data"
	ql := l.
	dh := div byteAt: dl.
	dnh := dl = 1
				ifTrue: [0]
				ifFalse: [div byteAt: 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 bytesCount + 1 - k.
		"r1 := rem digitAt: j."
		(rem byteAt: 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 byteAt: j)
							bitShift: 4)
							+ ((rem byteAt: j - 1)
									bitShift: -4).
				qhi := t // dh.
				t := (t \\ dh bitShift: 4)
							+ ((rem byteAt: 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 byteAt: 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 bytesCount do: 
			[:i | 
			hi := (div byteAt: i)
						* qhi.
			lo := a + (rem byteAt: l) - ((hi bitAnd: 15)
							bitShift: 4) - ((div byteAt: i)
							* qlo).
			rem byteAt: 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 bytesCount do: 
					[:i | 
					a := (a bitShift: -8)
								+ (rem byteAt: l) + (div byteAt: i).
					rem byteAt: l put: (a bitAnd: 255).
					l := l + 1]].
		quo byteAt: quo bytesCount + 1 - k put: (qhi bitShift: 4)
				+ qlo].
	rem := rem
				digitRshift: d
				bytes: 0
				lookfirst: dl.
	^ Array with: quo with: rem! !

!Integer methodsFor: 'arithmetic' stamp: ''!
\\\ anInteger 
	"a modulo method for use in DSA. Be careful if you try to use this elsewhere."

	^self \\ anInteger! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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! !

!Integer methodsFor: 'private' stamp: ''!
growby: n

	^self growto: self bytesCount + n! !

!Integer methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
alt
	^ KMModifier alt + self! !

!Integer methodsFor: '*Kernel-Chronology' stamp: ''!
asSeconds
	^ Duration seconds: self! !

!Integer methodsFor: 'printing' stamp: ''!
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: 'arithmetic' stamp: ''!
- aNumber
	"Refer to the comment in Number - "
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [^ self digitSubtract: aNumber]
			ifFalse: [^ (self digitAdd: aNumber) normalize]].
	aNumber isFraction ifTrue:
		[^Fraction numerator: self * aNumber denominator - aNumber numerator denominator: aNumber denominator].
	^ aNumber adaptToInteger: self andSend: #-! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Keymapping-KeyCombinations' stamp: ''!
asShortcut
	^ self asKeyCombination! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'comparing' stamp: ''!
>= aNumber
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [self negative
						ifTrue: [^(self bytesCompare: aNumber) <= 0]
						ifFalse: [^(self bytesCompare: aNumber) >= 0]]
			ifFalse: [^ aNumber negative]].
	^ aNumber adaptToInteger: self andCompare: #>=! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
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: 'converting' stamp: ''!
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: 'accessing' stamp: ''!
denominator
	"Let an Integer be polymorphic to a Fraction. See #isFraction."
	^1! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
raisedToFraction: aFraction
	| root |
	root := self nthRootTruncated: aFraction denominator.
	(root raisedToInteger: aFraction denominator) = self ifTrue: [^root raisedToInteger: aFraction numerator].
	^super raisedToFraction: aFraction! !

!Integer methodsFor: 'system primitives' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart
	| j |  "Catches failure if LgInt replace primitive fails"
	j := repStart.
	start to: stop do:
		[:i |
		self byteAt: i put: (replacement byteAt: j).
		j := j+1]! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
storeStringHex
	"Returns a string representation of the receiver in base 16 in a way that executing it will return the receiver."
	"10 storeStringHex >>> '16rA'"

	^ self storeStringBase: 16! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
nthRoot: aPositiveInteger
	"Answer the nth root of the receiver.
	Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root."

	| guess p |

	guess := self nthRootRounded: aPositiveInteger.
	(guess raisedTo: aPositiveInteger) = self
		ifTrue: [ ^ guess ].

	p := Float precision - guess highBitOfMagnitude.
	p < 0 ifTrue: [ ^ guess asFloat ].

	guess := self << (p * aPositiveInteger) nthRootRounded: aPositiveInteger.
	^(guess / (1 << p)) asFloat! !

!Integer methodsFor: '*Random-Core' stamp: ''!
atRandom: aGenerator
	"Answer a random integer from 1 to self picked from aGenerator."

	^ aGenerator nextInteger: self! !

!Integer methodsFor: 'accessing' stamp: ''!
digitAt: anExponent base: base

	"Return number that represents digit at given position.
		42 digitAt: 2 base: 10 -> 4
		42 digitAt: 1 base: 10 -> 1
	It is always a number or zero:
		16rFF digitAt: 1 base: 16 -> 15
		1 digitAt: 2 base: 10 -> 0
	Results are not defined for base smaller than 2 and non-integer arguments."

	^ self // (base raisedToInteger: anExponent - 1) \\ base! !

!Integer methodsFor: 'private' stamp: ''!
growto: n

	^self copyto: (self species new: n)! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
decimalDigitAt: anExponent

	"Return number that represents digit at given decimal position.
		42 digitAt: 2 base: 10 -> 4
		42 digitAt: 1 base: 10 -> 1
	It is always a number or zero:
		1 digitAt: 2 base: 10 -> 0
	Results are not defined non-integer arguments."

	^ self digitAt: anExponent base: 10! !

!Integer methodsFor: '*Metacello-Core' stamp: ''!
metacelloStringLessThanSelf: aString
	"string version components are always '<' integer component"
	
	^true! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
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: ''!
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: 'truncation and round off' stamp: ''!
truncated 
	"Refer to the comment in Number|truncated."! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
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' stamp: ''!
printWithCommasOn: aStream
	"123456789 asStringWithCommas"
	"-123456789 asStringWithCommas"
	^ self printSeparatedBy: $, every: 3 signed: false on: aStream! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Metacello-Core' stamp: ''!
metacelloVersionComponentLessThan: aMetacelloVersonComponent

	^aMetacelloVersonComponent metacelloIntegerLessThanSelf: self! !

!Integer methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
control
	^ KMModifier ctrl + self! !

!Integer methodsFor: 'printing' stamp: ''!
printSeparatedBy: aDelimiter every: offset signed: printSigned base: base on: aStream
	| digits |
	digits := self abs printStringBase: base.
	
	self signBit = 1 
		ifTrue: [ aStream nextPut: $- ] 
		ifFalse: [ printSigned ifTrue: [ aStream nextPut: $+ ] ].
	
	1 to: digits size do: [ :i | 
		aStream nextPut: (digits at: i).
		(i < digits size and: [ (i - digits size) \\ offset = 0 ])
			ifTrue: [ aStream nextPut: aDelimiter ] ]! !

!Integer methodsFor: 'system primitives' stamp: ''!
byteAt: index
	self subclassResponsibility! !

!Integer methodsFor: 'comparing' stamp: ''!
= aNumber
	aNumber isNumber ifFalse: [^ false].
	aNumber isInteger ifTrue:
		[aNumber negative == self negative
			ifTrue: [^ (self bytesCompare: aNumber) = 0]
			ifFalse: [^ false]].
	^ aNumber adaptToInteger: self andCompare: #=! !

!Integer methodsFor: 'arithmetic' stamp: ''!
* aNumber
	"Refer to the comment in Number * " 
	aNumber isInteger ifTrue:
		[^ self digitMultiply: aNumber 
					neg: self negative ~~ aNumber negative].
	^ aNumber adaptToInteger: self andSend: #*! !

!Integer methodsFor: 'printing' stamp: ''!
asStringWithCommas
	"123456789 asStringWithCommas"
	"-123456789 asStringWithCommas"
	^ String streamContents: [:stream | 
		self printWithCommasOn: stream ]! !

!Integer methodsFor: 'private' stamp: ''!
digitMultiply: arg neg: ng 
	| prod prodLen carry digit k ab |
	<primitive: 'primDigitMultiplyNegative' module:'LargeIntegers'>
	(arg bytesCount = 1 and: [(arg byteAt: 1)
			= 0])
		ifTrue: [^ 0].
	(self bytesCount = 1 and: [(self byteAt: 1)
			= 0])
		ifTrue: [^ 0].
	prodLen := self bytesCount + arg bytesCount.
	prod := Integer new: prodLen neg: ng.
	"prod starts out all zero"
	1 to: self bytesCount do: [:i | (digit := self byteAt: i) ~= 0
			ifTrue: 
				[k := i.
				carry := 0.
				"Loop invariant: 0<=carry<=0377, k=i+j-1"
				1 to: arg bytesCount do: 
					[:j | 
					ab := (arg byteAt: j)
								* digit + carry + (prod byteAt: k).
					carry := ab bitShift: -8.
					prod byteAt: k put: (ab bitAnd: 255).
					k := k + 1].
				prod byteAt: k put: carry]].
	^ prod normalize! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'truncation and round off' stamp: ''!
normalize 
	"SmallInts OK; LgInts override"
	^ self! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
radix: base 
	^ self printStringBase: base! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'truncation and round off' stamp: ''!
asPowerOfTwo
	"Convert the receiver into a power of two"
	^self asSmallerPowerOfTwo! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
| anInteger
	^self bitOr: anInteger! !

!Integer methodsFor: 'printing' stamp: ''!
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: 'testing' stamp: ''!
isInteger
	"True for all subclasses of Integer."

	^ true! !

!Integer methodsFor: 'private' stamp: ''!
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 byteAt: i.
			neg1
				ifTrue: [b1 := z1
								ifTrue: [b1 = 0
										ifTrue: [0]
										ifFalse: [z1 := false.
											256 - b1]]
								ifFalse: [255 - b1]].
			b2 := arg byteAt: 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
				byteAt: i
				put: (rneg
						ifTrue: [rz
								ifTrue: [b = 0
										ifTrue: [0]
										ifFalse: [rz := false.
											256 - b]]
								ifFalse: [255 - b]]
						ifFalse: [b])].
	^ result normalize! !

!Integer methodsFor: 'arithmetic' stamp: ''!
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: 'testing' stamp: ''!
isPowerOfTwo
	"Return true if the receiver is an integral power of two."
	^ self ~= 0 and: [(self bitAnd: self-1) = 0]! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'printing - numerative' stamp: ''!
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: 'comparing' stamp: ''!
> aNumber
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [self negative
						ifTrue: [^(self bytesCompare: aNumber) < 0]
						ifFalse: [^(self bytesCompare: aNumber) > 0]]
			ifFalse: [^ aNumber negative]].
	^ aNumber adaptToInteger: self andCompare: #>! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
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 |
	<primitive: 'primAnyBitFromTo' module:'LargeIntegers'>
	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 byteAt: firstDigitIx.
			^ (digit bitAnd: mask)
				~= 0].
	((magnitude byteAt: firstDigitIx)
			bitShift: rightShift)
			~= 0
		ifTrue: [^ true].
	firstDigitIx + 1
		to: lastDigitIx - 1
		do: [:ix | (magnitude byteAt: ix)
					~= 0
				ifTrue: [^ true]].
	(((magnitude byteAt: lastDigitIx)
			bitShift: leftShift)
			bitAnd: 255)
			~= 0
		ifTrue: [^ true].
	^ false! !

!Integer methodsFor: 'converting' stamp: ''!
asInteger
	"Answer with the receiver itself."

	^self! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
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: 'private' stamp: ''!
copyto: x
	| stop |
	stop := self bytesCount min: x bytesCount.
	^ x replaceFrom: 1 to: stop with: self startingAt: 1! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
tinyBenchmarks
	
	| 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: '*FileSystem-Core' stamp: ''!
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: '*Metacello-Core' stamp: ''!
metacelloSemanticVersionComponentLessThan: aMetacelloVersonComponent
    ^ aMetacelloVersonComponent metacelloSemanticIntegerLessThanSelf: self! !

!Integer methodsFor: 'printing' stamp: ''!
print: positiveNumberString on: aStream prefix: prefix length: minimum padded: zeroFlag
	"Return a String based on concatenation of positiveNumberString with prefix then padded by 0 is zeroFlag is set for a minimum length."
	
	"(String streamContents: [:s | 10 print: '10' on: s prefix: 'zz' length: 4 padded: true] ) >>> 'zz10'"
	

	| 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: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter writeInteger: self! !

!Integer methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
shift
	^ KMModifier shift + self! !

!Integer methodsFor: 'converting' stamp: ''!
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: 'printing' stamp: ''!
isLiteral

	^true! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
primeFactors
	"Return all primeFactors of myself"
	"( 106260 primeFactors fold: [ :a :b | a * b ]) = 106260"
	
	^ Array streamContents: [ :s | self primeFactorsOn: s ]! !

!Integer methodsFor: 'private' stamp: ''!
digitRshift: anInteger bytes: b lookfirst: a 
	 "Shift right 8*b+anInteger bits, 0<=n<8.
	Discard all digits beyond a, and all zeroes at or below a."
	| n x r f m digit count i |
	n := 0 - anInteger.
	x := 0.
	f := n + 8.
	i := a.
	m := 255 bitShift: 0 - f.
	digit := self byteAt: 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 byteAt: 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 byteAt: b + 1) bitShift: n.
	b + 1 to: count do:
		[:j | digit := self byteAt: j + 1.
		r byteAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) 
			"Avoid values > 8 bits".
		x := digit bitShift: n].
	^r! !

!Integer methodsFor: '*UnifiedFFI' stamp: ''!
asExternalTypeOn: generator

	^ FFIConst 
		value: self
		type: (generator resolveType: #int32)! !

!Integer methodsFor: 'converting' stamp: ''!
hex
	"Returns a string representation of 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"
		
	"12 hex >>> '16rC'"	
	"10 hex >>> '16rA'"	
	"-10 hex >>> '-16rA'"	
		
	^ self storeStringBase: 16! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
printOn: aStream base: base length: minimum padded: zeroFlag
	"Return a String representation of this number in base b with a minimum length and padded by 0 if zeroFlag is set"
	
	"(String streamContents: [ :s | 10 printOn: s base: 10 length: 4 padded: true] ) >>> '0010'"
	"(String streamContents: [ :s | -10 printOn: s base: 10 length: 4 padded: true] ) >>> '-010'"
	

	| prefix |	
	prefix := self negative ifTrue: ['-'] ifFalse: [ '' ].
	self 
		print: (self abs printStringBase: base) 
		on: aStream 
		prefix: prefix 
		length: minimum 
		padded: zeroFlag! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
bitOr: n 
	"Answer an Integer whose bits are the logical OR of the receiver's bits  
	and those of the argument, n."
	| norm |
	<primitive: 'primDigitBitOr' module:'LargeIntegers'>
	norm := n normalize.
	^ self
		digitLogic: norm
		op: #bitOr:
		length: (self bytesCount max: norm bytesCount)! !

!Integer methodsFor: 'arithmetic' stamp: ''!
quo: aNumber 
	"Refer to the comment in Number quo: "
	| ng quo |
	aNumber isInteger ifTrue: 
		[ng := self negative == aNumber negative == false.
		quo := (self digitDiv: aNumber neg: ng) at: 1.
		^ quo normalize].
	^ aNumber adaptToInteger: self andSend: #quo:! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
montgomeryDigitMax
	"Answer the maximum value of a digit used in Montgomery algorithm."
	
	^1 << self montgomeryDigitLength - 1! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
printLowercaseHexByteOn: characterWriteStream
	"Assuming the receiver is a byte value [0, 255],
	print a 2 character hexadecimal representation on characterWriteStream
	using the lowercase alphabet."
	
	(self between: 0 and: 255)
		ifTrue: [
			| highNibble lowNibble hexDigits |
			highNibble := self bitShift: -4.
			lowNibble := self bitAnd: 15.
			hexDigits := '0123456789abcdef'.
			characterWriteStream 
				nextPut: (hexDigits at: highNibble + 1);
				nextPut: (hexDigits at: lowNibble + 1) ]
		ifFalse: [ 
			self error: 'byte value between 0 and 255 expected' ]! !

!Integer methodsFor: 'arithmetic' stamp: ''!
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: 'truncation and round off' stamp: ''!
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: 'bit manipulation' stamp: ''!
bitInvert32
	"Answer the 32-bit complement of the receiver."

	^ self bitXor: 16rFFFFFFFF! !

!Integer methodsFor: 'printing' stamp: ''!
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: 'bit manipulation' stamp: ''!
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: 'arithmetic' stamp: ''!
+ aNumber
	"Refer to the comment in Number + "
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [^ (self digitAdd: aNumber) normalize]
			ifFalse: [^ self digitSubtract: aNumber]].
	aNumber isFraction ifTrue:
		[^Fraction numerator: self * aNumber denominator + aNumber numerator denominator: aNumber denominator].
	^ aNumber adaptToInteger: self andSend: #+! !

!Integer methodsFor: 'comparing' stamp: ''!
<= aNumber
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [self negative
						ifTrue: [^ (self bytesCompare: aNumber) >= 0]
						ifFalse: [^ (self bytesCompare: aNumber) <= 0]]
			ifFalse: [^ self negative]].
	^ aNumber adaptToInteger: self andCompare: #<=! !

!Integer methodsFor: 'printing' stamp: ''!
asStringWithCommasSigned
	"123456789 asStringWithCommasSigned"
	"-123456789 asStringWithCommasSigned"
	^ String streamContents: [:stream | 
		self printWithCommasSignedOn: stream ]! !

!Integer methodsFor: 'comparing' stamp: ''!
< aNumber
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [self negative
						ifTrue: [^ (self bytesCompare: aNumber) > 0]
						ifFalse: [^ (self bytesCompare: aNumber) < 0]]
			ifFalse: [^ self negative]].
	^ aNumber adaptToInteger: self andCompare: #<! !

!Integer methodsFor: 'converting - arrays' stamp: ''!
asByteArray

	| stream |
	stream := ByteArray new writeStream.
	self bytesCount to: 1 by: -1 do: [:digitIndex |
		stream nextPut: (self byteAt: digitIndex)].
	^ stream contents! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
bitAnd: n 
	"Answer an Integer whose bits are the logical AND of the receiver's bits  
	and those of the argument, n."
	| norm |
	<primitive: 'primDigitBitAnd' module:'LargeIntegers'>
	norm := n normalize.
	^ self
		digitLogic: norm
		op: #bitAnd:
		length: (self bytesCount max: norm bytesCount)! !

!Integer methodsFor: 'truncation and round off' stamp: ''!
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: 'bit manipulation' stamp: ''!
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: 'truncation and round off' stamp: ''!
floor 
	"Refer to the comment in Number|floor."! !

!Integer methodsFor: 'printing' stamp: ''!
storeOn: aStream
	self < 0
		ifTrue: [ aStream space ].
		
	super storeOn: aStream.! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
montgomeryNumberOfDigits
	"Answer the number of montgomery digits required to represent the receiver."
	^self bytesCount * 8 + (self montgomeryDigitLength - 1) // self montgomeryDigitLength! !

!Integer methodsFor: 'arithmetic' stamp: ''!
/ aNumber
	"Refer to the comment in Number / "
	| quoRem |
	aNumber isInteger ifTrue:
		[quoRem := self digitDiv: aNumber neg: self negative ~~ aNumber negative.
		(quoRem at: 2) = 0
			ifTrue: [^ (quoRem at: 1) normalize]
			ifFalse: [^ (Fraction numerator: self denominator: aNumber) reduced]].
	^ aNumber adaptToInteger: self andSend: #/! !

!Integer methodsFor: 'printing' stamp: ''!
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: ''!
printSeparatedBy: aDelimiter every: offset signed: printSigned on: aStream
	^ self printSeparatedBy: aDelimiter every: offset signed: printSigned base: 10 on: aStream! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
primeFactorsOn: aStream
	"Recursively calculate the primefactors of myself and put the factors into the given stream"
	self = 1 | self isZero
		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: '*FileSystem-Core' stamp: ''!
humanReadableSIByteSize
	^ String streamContents: [ :s|
		self humanReadableSIByteSizeOn: s ]! !

!Integer methodsFor: '*Metacello-Core' stamp: ''!
metacelloSemanticStringLessThanSelf: aString
    "string version components are always '<' integer component"

    ^ true! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
storeOn: aStream base: base
	"Print a representation of the receiver on the stream
	<aStream> in base <base> where
	2 <= <baseInteger> <= 16. If <base> 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: '*NewTools-Inspector-Extensions' stamp: ''!
inspectIntegerIn: aBuilder
	<inspectorPresentationOrder: 30 title: 'Integer'> 
	| keysColumn valuesColumn items |
	items := { 'decimal' -> self printString.
					'hex' -> self printStringHex.
					'octal' -> (self printStringBase: 8).
					'binary' -> (self printStringBase: 2)} asOrderedCollection.
					
	keysColumn := SpStringTableColumn title: #key evaluated: [ :anAssociation | anAssociation key ].
	valuesColumn := SpStringTableColumn title: #value evaluated: [ :anAssociation | anAssociation value ].
	
	^ aBuilder newTable
		addColumn: keysColumn;
		addColumn: valuesColumn;
		items: items;
		yourself! !

!Integer methodsFor: 'arithmetic' stamp: ''!
alignedTo: anInteger
	"Answer the smallest number not less than receiver that is a multiple of anInteger."

	^(self+anInteger-1//anInteger)*anInteger

"5 alignedTo: 2"
"12 alignedTo: 3"! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
allMask: mask 
	"Treat the argument as a bit mask. Answer whether all of the bits that 
	are 1 in the argument are 1 in the receiver."

	^mask = (self bitAnd: mask)! !

!Integer methodsFor: 'converting - arrays' stamp: ''!
asByteArrayOfSize: aSize 
	"Answer a ByteArray of aSize with my value, most-significant byte first."
	| answer digitPos |
	aSize < self bytesCount ifTrue: [ self error: 'number to large for byte array' ].
	answer := ByteArray new: aSize.
	digitPos := 1.
	aSize 
		to: aSize - self bytesCount + 1
		by: -1
		do: 
			[ :pos | 
			answer 
				at: pos
				put: (self byteAt: digitPos).
			digitPos := digitPos + 1 ].
	^ answer! !

!Integer methodsFor: 'private' stamp: ''!
bytesCompare: arg 
	"Compare the magnitude of self with that of arg.   
	Return a code of 1, 0, -1 for self >, = , < arg"
	| len arglen argDigit selfDigit |
	<primitive: 'primDigitCompare' module:'LargeIntegers'>
	len := self bytesCount.
	(arglen := arg bytesCount) ~= len
		ifTrue: [arglen > len
				ifTrue: [^ -1]
				ifFalse: [^ 1]].
	[len > 0]
		whileTrue: 
			[(argDigit := arg byteAt: len) ~= (selfDigit := self byteAt: len)
				ifTrue: [argDigit < selfDigit
						ifTrue: [^ 1]
						ifFalse: [^ -1]].
			len := len - 1].
	^ 0! !

!Integer methodsFor: 'testing' stamp: ''!
even 
	"Refer to the comment in Number|even."

	^((self byteAt: 1) bitAnd: 1) = 0! !

!Integer methodsFor: 'accessing' stamp: ''!
digitSum
    "Returns the digit sum of the receiver"
    
    ^self abs asString inject: 0 into: [:value :new| value + new digitValue]! !

!Integer methodsFor: 'accessing' stamp: ''!
numerator
	"Let an Integer be polymorphic to a Fraction. See #isFraction."
	^self! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
numberOfCombinationsTaken: k
	"Return the number of combinations of (self) elements taken k at a time. 
	It is calculated as C(n,k) = n!! / (k!! (n-k)!!) 
	For 6 numberOfCombinationsTaken: 3, this is 6*5*4 / (1*2*3)"
	
	"6 numberOfCombinationsTaken: 3 >>> 20"

	| numerator denominator |
	k < 0 ifTrue: [^ 0].
	k > self ifTrue: [^ 0].
	
	numerator := 1.
	
	self to: (k max: self-k) + 1 by: -1 do: [ :factor |
		numerator := numerator * factor ].
	
	denominator := 1.
	
	1 to: (k min: self-k) do: [ :factor |
		denominator := denominator * factor ].
	
	^ numerator // denominator! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
montgomeryDigitLength
	"Answer the number of bits composing a digit in Montgomery algorithm.
	Primitive use either 8 or 32 bits digits"
	<primitive: 'primMontgomeryDigitLength' module:'LargeIntegers'>
	^8 "Legacy plugin which did not have this primitive did use 8 bits digits"! !

!Integer methodsFor: 'system primitives' stamp: ''!
bytesCount
	self subclassResponsibility! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
& aNumber
	^ self bitAnd: aNumber! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
noMask: mask 
	"Treat the argument as a bit mask. Answer whether none of the bits that 
	are 1 in the argument are 1 in the receiver."

	^0 = (self bitAnd: mask)! !

!Integer methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
command
	^ KMModifier command + self! !

!Integer methodsFor: 'truncation and round off' stamp: ''!
rounded 
	"Refer to the comment in Number|rounded."! !

!Integer methodsFor: 'truncation and round off' stamp: ''!
ceiling 
	"Refer to the comment in Number|ceiling."! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
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 |
	<primitive: 'primDigitBitShiftMagnitude' module:'LargeIntegers'>
	shiftCount >= 0 ifTrue: [^ self digitLshift: shiftCount].
	rShift := 0 - shiftCount.
	^ (self
		digitRshift: (rShift bitAnd: 7)
		bytes: (rShift bitShift: -3)
		lookfirst: self bytesCount) normalize! !

!Integer methodsFor: 'converting' stamp: ''!
asHexDigit
	^'0123456789ABCDEF' at: self+1! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
printStringPadded: minimal
	^self printStringLength: minimal padded: true! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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 (b raisedTo: m montgomeryNumberOfDigits),
	with (m bitAnd: b-1) * mInv \\ b = (b-1)
	with b = self montgomeryDigitBase (either 1<<8 or 1<<32)"
	
	| 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: '*Math-Operations-Extensions' stamp: ''!
montgomeryDigitBase
	"Answer the base used by Montgomery algorithm."
	^1 << self montgomeryDigitLength! !

!Integer methodsFor: 'printing' stamp: ''!
printWithCommasSignedOn: aStream
	"123456789 asStringWithCommasSigned"
	"-123456789 asStringWithCommasSigned"
	^ self printSeparatedBy: $, every: 3 signed: true on: aStream! !

!Integer methodsFor: 'printing' stamp: ''!
printString
	"For Integer, prefer the stream version to the string version for efficiency"
	
	^String streamContents: [:str | self printOn: str base: 10]! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
factorial
	"Answer the factorial of the receiver."

	"The factorial on n is defined as: n * (n-1)*(n-2)*... while n>0. Factorial of 0 is 1.
	We also know Factorial of 1 and 2 are themselves.
	
	This implementation uses a 2-partition algorithm.
	
	For a recursive (but slower) implementation see 'slowFactorial'
	
	Without verbose detail:
	
	If'm an even number,some optimization can be applied:
	Instead of doing all multiplication we can halving the number of multiplication regrouping terms, so:
	n*(n-1)*(n-2)*....*3*2*1
	can be rearranged as:
	(n*1)*((n-1)*2)*((n-2)*3)*...
	And the use the fact n is even to rewrite in a more efficient way.
	If I'm an odd number then compute for n-1 and multily by n.
	"
	
	"Example of usages:"
	
	"0 factorial >>> 1"
	"1 factorial >>> 1"
	"2 factorial >>> 2"
	"3 factorial >>> 6"
	"4 factorial >>> 24"
	"5 factorial >>> 120"
	"6 factorial >>> 720"

	| nex nexnext acc |
	"Guard for know cases (0,1,2,error)"
	self < 3
		ifTrue: [ ^ self < 0
				ifTrue: [ self error: 'Not valid for negative integers' ]
				ifFalse: [ self > 0
						ifTrue: [ self ]
						ifFalse: [ 1 ] ] ].
	acc := 2.
	nex := 2.
	nexnext := 10.
	
	self // 2 - 1
		timesRepeat: [ nex := nex + nexnext.
			nexnext := nexnext + 8.
			acc := acc * nex ].
	self odd
		ifTrue: [ acc := acc * self ].
	^ acc! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
isProbablyPrime
	"See isProbablyPrimeWithK:andQ:randomIndex: for the algoritm description."
	
	| k q randomNumbers |
	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."
	
	"Array of pregenerated 25 random numbers. "
	randomNumbers := #(0.816980664067427 0.9940209812456839 0.5106317962103671
		0.18859890764048273 0.7818407135931034 0.39687335928756434
		0.25054954609393587 0.9862212007801148 0.41972151138806785
		0.25944189925652084 0.44000080434605515 0.09351864414919105
		0.7678522154539136 0.292185133924794 0.7555458740124227
		0.4595045267881381 0.8925817282370206 0.621106479606175 
		0.9366027409846908 0.48226772969694237 0.47373301651036975
		0.030808489784043512 0.7982878004192784 0.8230616468112272
		0.19709795629470514).
	
	randomNumbers do: [:rnd | (self isProbablyPrimeWithK: k andQ: q randomIndex: rnd ) ifFalse: [ ^false ] ].
	"The probability of false positive after 25 iterations is less than (1/4 raisedTo: 25) < 1.0e-15"
	^true! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
>> shiftAmount
	"right shift"
	
	shiftAmount < 0 ifTrue: [self error: 'negative arg'].
	^ self bitShift: 0 - shiftAmount! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
bitStringLength

      ^self bytesCount * 8
           	"make sure positive integer bitString always begins with 0"
           + (self positive ifTrue: [1] ifFalse: [0])! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
montgomeryTimes: a modulo: m mInvModB: mInv
	"Answer the result of a Montgomery multiplication
	self * a * (b raisedTo: m montgomeryNumberOfDigits) inv \\ m
	NOTE: it is assumed that:
	self montgomeryNumberOfDigits <= m montgomeryNumberOfDigits
	a montgomeryNumberOfDigits <= m montgomeryNumberOfDigits
	mInv * m \\ b = (-1 \\ b) = (b-1) (this implies m odd)
	where b = self montgomeryDigitBase
	
	Answer nil in case of absent plugin or other failure."
	
	<primitive: 'primMontgomeryTimesModulo' module:'LargeIntegers'>
	^nil! !

!Integer methodsFor: 'testing' stamp: ''!
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: 'bit manipulation' stamp: ''!
anyMask: mask 
	"Treat the argument as a bit mask. Answer whether any of the bits that 
	are 1 in the argument are 1 in the receiver."

	^0 ~= (self bitAnd: mask)! !

!Integer methodsFor: '*Math-Operations-Extensions' stamp: ''!
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 := self montgomeryDigitBase - ((m bitAnd: self montgomeryDigitMax) reciprocalModulo: self montgomeryDigitBase).
 
	"Initialize the result to R=self montgomeryDigitModulo raisedTo: m montgomeryNumberOfDigits"
	a := (1 bitShift: m montgomeryNumberOfDigits * m montgomeryDigitLength) \\ 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: 'printing' stamp: ''!
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: ''!
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: '*Kernel-Chronology-Extras' stamp: ''!
asYear

 	^ Year year: self! !

!Integer methodsFor: 'accessing' stamp: ''!
decimalDigitLength

	"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.
	Result is not defined from negative numbers."
	
	^ self numberOfDigitsInBase: 10! !

!Integer methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
ctrl
	^ KMModifier ctrl + self! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
printStringLength: minimal
	^self printStringLength: minimal padded: false! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
printStringBase: base length: minimum padded: zeroFlag

	^ String streamContents: [:s| self printOn: s base: base length: minimum padded: zeroFlag]! !

!Integer methodsFor: '*Metacello-Core' stamp: ''!
metacelloIntegerLessThanSelf: anInteger

	^anInteger < self! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
storeStringBase: base length: minimum padded: zeroFlag
	"(10 storeStringBase: 16 length: 6 padded: true) >>> '16r00A'"

	^ String streamContents: [:s| 
			self storeOn: s base: base length: minimum padded: zeroFlag ]! !

!Integer methodsFor: 'private' stamp: ''!
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 byteAt: i put: 0].
	1 to: len - byteShift do: 
		[:i | 
		digit := self byteAt: i.
		result byteAt: i + byteShift put: (((digit bitAnd: mask)
				bitShift: bitShift)
				bitOr: carry).
		carry := digit bitShift: rShift].
	^ result! !

!Integer methodsFor: 'enumerating' stamp: ''!
timesRepeat: aBlock 
	"Evaluate the argument, aBlock, the number of times represented by the 
	receiver."

	| count |
	count := 1.
	[count <= self]
		whileTrue: 
			[aBlock value.
			count := count + 1]! !

!Integer methodsFor: 'printing - numerative' stamp: ''!
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: '*Random-Core' stamp: ''!
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 ].
	^ self atRandom: SharedRandom globalGenerator.! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
bitXor: n 
	"Answer an Integer whose bits are the logical XOR of the receiver's bits  
	and those of the argument, n."
	| norm |
	<primitive: 'primDigitBitXor' module:'LargeIntegers'>
	norm := n normalize.
	^ self
		digitLogic: norm
		op: #bitXor:
		length: (self bytesCount max: norm bytesCount)! !

!Integer methodsFor: 'converting' stamp: ''!
asCharacterDigit
	"Answer the Character whose string representation is the receiver."
	^Character digitValue: self! !

!Integer methodsFor: 'private' stamp: ''!
digitAdd: arg 
	| len arglen accum sum |
	<primitive: 'primDigitAdd' module:'LargeIntegers'>
	accum := 0.
	(len := self bytesCount) < (arglen := arg bytesCount) 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 byteAt: i) + (arg byteAt: i).
		sum byteAt: i put: (accum bitAnd: 255)].
	accum > 255
		ifTrue: 
			[sum := sum growby: 1.
			sum at: sum bytesCount put: (accum bitShift: -8)].
	^ sum! !

!Integer methodsFor: '*Metacello-Core' stamp: ''!
metacelloSemanticIntegerLessThanSelf: anInteger
    ^ anInteger < self! !

!Integer methodsFor: '*Graphics-Primitives' stamp: ''!
asColorOfDepth: d
	"Return a color value representing the receiver as color of the given depth"
	^Color colorFromPixelValue: self depth: d! !

!Integer methodsFor: 'truncation and round off' stamp: ''!
round: numberOfWishedDecimal
	"Round the decimal part of the receiver to be limited to the number of wished decimal. Only leave a fixed amount of decimal. Integers there are already rounded."
 
	^self! !

!Integer methodsFor: 'arithmetic' stamp: ''!
// 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: 'bit manipulation' stamp: ''!
<< shiftAmount
	"left shift"
	
	shiftAmount < 0 ifTrue: [self error: 'negative arg'].
	^ self bitShift: shiftAmount! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
lowBit
	"Answer the index of the low order bit of this number."
	| index |
	self = 0 ifTrue: [ ^ 0 ].
	index := 1.
	[ (self byteAt: index) = 0 ]
		whileTrue:
			[ index := index + 1 ].
	^ (self byteAt: index) lowBit + (8 * (index - 1))! !

!Integer methodsFor: 'printing' stamp: ''!
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: '*UnifiedFFI' stamp: ''!
pointer 
	^ (ByteArray new: FFIExternalType pointerSize)
		unsignedLongAt: 1 put: self;
		yourself! !

!Integer methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
meta
	^ KMModifier meta + self! !

!Integer methodsFor: 'bit manipulation' stamp: ''!
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: 'converting' stamp: ''!
asCharacter
	"Answer the Character whose value is the receiver."
	^Character value: self! !

!Integer methodsFor: 'converting' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
isProbablyPrimeWithK: k andQ: q randomIndex: aRandomFloat
	"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) * aRandomFloat "a pregerated random number") asInteger + 1.	
	"P2"
	j := 0.
	y := x raisedTo: q modulo: self.
	minusOne := self - 1.
	
	["P3"
	y = 1 ifTrue: [^j = 0].
	y = minusOne ifTrue: [^true].
	"P4"
	(j := j + 1) < k]
		whileTrue:
			[y := y squared \\ self].
	"P5"
	^false! !

!Integer methodsFor: 'mathematical functions' stamp: ''!
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: 'printing - numerative' stamp: ''!
printStringLength: minimal padded: zeroFlag
	^self printStringBase: 10 length: minimal padded: zeroFlag! !

!Integer class methodsFor: 'instance creation' stamp: ''!
new

	self == Integer ifTrue: [
		^ self error: 'Integer is an abstract class.  Make a concrete subclass.'].
	^ super new! !

!Integer class methodsFor: '*NumberParser' stamp: ''!
readFrom: aStringOrStream base: base 
	"Answer an instance of one of the concrete subclasses if Integer. 
	Initial minus sign accepted, and bases > 10 use letters A-Z.
	Imbedded radix specifiers not allowed;  use Number 
	class readFrom: for that.
	Raise an Error if there are no digits.
	If stringOrStream dos not start with a valid number description, answer 0 for backward compatibility. This is not clever and should better be changed."

	^(NumberParser on: aStringOrStream) nextIntegerBase: base! !

!Integer class methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Debugger-Model' stamp: ''!
canonicalArgumentName

	^ 'anInteger'.! !

!Integer class methodsFor: '*Tool-Finder' stamp: ''!
forbiddenSelectorsForMethodFinder

	^ #(#benchFib #tinyBenchmarks)! !

!Integer class methodsFor: '*NumberParser' stamp: ''!
readFrom: aStringOrStream ifFail: aBlock
	"Answer an instance of one of the concrete subclasses if Integer. 
	Initial minus sign accepted.
	Imbedded radix specifiers not allowed;  use Number 
	class readFrom: for that.
	Execute aBlock if there are no digits."

	^(NumberParser on: aStringOrStream) nextIntegerBase: 10 ifFail: aBlock! !

!Integer class methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'instance creation' stamp: ''!
basicNew

	self == Integer ifTrue: [
		^ self error: 'Integer is an abstract class.  Make a concrete subclass.'].
	^ super basicNew! !

!Integer class methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'testing' stamp: ''!
isAbstract

	^self name = #Integer! !

!Integer class methodsFor: 'instance creation' stamp: ''!
new: length neg: neg
	"Answer an instance of a large integer whose size is length. neg is a flag 
	determining whether the integer is negative or not."

	neg 
		ifTrue: [^LargeNegativeInteger new: length]
		ifFalse: [^LargePositiveInteger new: length]! !

!Integer class methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*NumberParser' stamp: ''!
readFrom: aStream radix: radix
	"retained for compatibility for now. do not use"
	^self readFrom: aStream base: radix! !

!Integer class methodsFor: 'reading' stamp: ''!
readHexByteFrom: characterReadStream
	| highNibble lowNibble |
	highNibble := characterReadStream next
		ifNotNil: [ :character | character hexDigitValue ].
	highNibble ifNil: [ self error: 'hex digit expected' ].
	lowNibble := characterReadStream next
		ifNotNil: [ :character | character hexDigitValue ].
	lowNibble ifNil: [ self error: 'hex digit expected' ].
	^ (highNibble bitShift: 4) + lowNibble! !

!Integer class methodsFor: '*NumberParser' stamp: ''!
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: ''!
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 byteAt: 4 put: byte4.
	value byteAt: 3 put: byte3.
	value byteAt: 2 put: byte2.
	value byteAt: 1 put: byte1.
	^ value! !

!IntegerArray commentStamp: ''!
IntegerArrays store 32bit signed Integer values.
Negative values are stored as 2's complement.

For further comments read comments of `WordArray`.!
!IntegerArray methodsFor: 'accessing' stamp: ''!
at: index
	| word |
	<primitive: 165>
	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: ''!
atAllPut: anInteger
	| word |
	anInteger < 0
		ifTrue:["word := 16r100000000 + anInteger"
				word := (anInteger + 1) negated bitInvert32]
		ifFalse:[word := anInteger].
	self primFill: word.! !

!IntegerArray methodsFor: 'converting' stamp: ''!
asIntegerArray
	^self! !

!IntegerArray methodsFor: 'accessing' stamp: ''!
at: index put: anInteger
	| word |
	<primitive: 166>
	anInteger < 0
		ifTrue:["word := 16r100000000 + anInteger"
				word := (anInteger + 1) negated bitInvert32]
		ifFalse:[word := anInteger].
	self  basicAt: index put: word.
	^anInteger! !

!IntegerArray methodsFor: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	self pinInMemory.
	^ PointerUtils oopForObject: self
! !

!IntegerArray methodsFor: 'private' stamp: ''!
primFill: aPositiveInteger
	"Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays."

	<primitive: 145>
	self errorImproperStore.! !

!IntegerArray methodsFor: 'accessing' stamp: ''!
defaultElement
	"Return the default element of the receiver"
	^0! !

!IntegerArrayTest commentStamp: ''!
SUnit tests for integer arrays!
!IntegerArrayTest methodsFor: 'tests' stamp: ''!
testPutAllNegative
	| array |
	array := IntegerArray new: 2.
	array  atAllPut: -1000.
	self assert: (array at: 2) equals: -1000! !

!IntegerArrayTest methodsFor: 'tests' stamp: ''!
testPutNegative
	| array |
	array := IntegerArray new: 2.
	array at: 2 put: -1000.
	self assert: (array at: 2) equals: -1000! !

!IntegerArrayTest methodsFor: 'tests' stamp: ''!
testAt
	| array |
	array := IntegerArray new: 5 withAll: 2.
	self assert: (array at: 3) equals: 2.
	
	array at: 3 put: 5.
	self assert: (array at: 3) equals: 5! !

!IntegerDigitLogicTest commentStamp: ''!
SUnit test to test digit logic of integers!
!IntegerDigitLogicTest methodsFor: 'tests' stamp: ''!
testAndSingleBitWithMinusOne
	"And a single bit with -1 and test for same value"

	1 to: 100 do: [ :i | self assert: ((1 bitShift: i) bitAnd: -1) equals: (1 bitShift: i) ]! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: ''!
testShiftMinusOne1LeftThenRight
	"Shift -1 left then right and test for 1"

	1 to: 100 do: [ :i | self assert: ((-1 bitShift: i) bitShift: i negated) equals: -1 ]! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: ''!
testShiftOneLeftThenRight
	"Shift 1 bit left then right and test for 1"

	1 to: 100 do: [ :i | self assert: ((1 bitShift: i) bitShift: i negated) equals: 1 ]! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: ''!
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) equals: n ]! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: ''!
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 equals: (n bitXor: -1) + 1 ]! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: ''!
testLargeShift
	"A sanity check for LargeInteger bitShifts"

	| suite |
	suite := #('101101011101001100110111110110011101101101000001110110011' '1101101001100010011001101110100000111011011010100011101100' '101101101011110011001100110011011101011001111000100011101000' '10101101101000101001111111111100101101011001011000100011100000' '1000101010101001111011101010111001011111110011110001000110000000' '1100101010101000010011101000110010111110110011110000000000000001').	"some numbers on 64 bits or less"
	"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 equals: bits , (String new: shift withAll: $0).
				self assert: rs equals: (bits copyFrom: 1 to: bits size - shift) ] ]! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: ''!
testMixedSignDigitLogic
	"Verify that mixed sign logic with large integers works."

	self assert: (-2 bitAnd: 16rFFFFFFFF) equals: 16rFFFFFFFE! !

!IntegerTest commentStamp: ''!
SUnit tests for integers.!
!IntegerTest methodsFor: 'tests - other' stamp: ''!
testNotInstantiable

	self should: [ Integer new ] raise: Exception! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testBitOr

	self assert: (2r0101 | 2r1010) equals: 2r1111.
	self assert: (2r0101 bitOr: 2r1010) equals: 2r1111.! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 - basic' stamp: ''!
testIsInteger

	self assert: (0 isInteger).! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testNthRoot
	1 << 2000 nthRoot: 100.
	self assert: (1 << 2000 nthRoot: 100) equals: 1 << 20! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: ''!
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 equals: 123.
	s := rs upToEnd.
	self assert: 's could be confused with a ScaledDecimal' equals: s.
	rs := '123.s could be confused with a ScaledDecimal' readStream.
	i := Integer readFrom: rs.
	self assert: i equals: 123.
	s := rs upToEnd.
	self assert: '.s could be confused with a ScaledDecimal' equals: s! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: ''!
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 - printing' stamp: ''!
testPrintStringHex

	self assert: 0 printStringHex equals: '0'.
	self assert: 12 printStringHex equals: 'C'.
	self assert: 1234 printStringHex equals: '4D2'! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: ''!
testIntegerReadsOkFromString
	self assert: (Integer readFrom: '123') equals: 123.
	self assert: (Integer readFrom: '-123') equals: -123.
	self assert: (Integer readFrom: 'a3' base: 16) equals: 163.
	self assert: (Integer readFrom: '-a3' base: 16) equals: -163! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 isFloat.
	self deny: result isInfinite.
	self assert: result equals: 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 - bitLogic' stamp: ''!
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."
	
	| n |
	"Shift 1 bit left then right and test for 1"
	1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) equals: 1].

	"Shift -1 left then right and test for 1"
	1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) equals: -1].

	"And a single bit with -1 and test for same value"
	1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) equals: (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) equals: n].

	"Verify that n negated = (n complemented + 1) for single bits"
	1 to: 100 do: [:i | 
					n := 1 bitShift: i. 
					self assert: n negated equals: ((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)) equals: -1].

	"Verify that n negated = (n complemented +1) for single bits"
	1 to: 100 do: [:i | 
					n := 1 bitShift: i.
					self assert: n negated equals: ((n bitXor: -1) + 1)]! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testPrintSeparatedByEverySignedOn
	| printer |
	printer := [ :integer :printSigned | 
		String streamContents: [ :stream | 
			integer
				printSeparatedBy: $.
				every: 3
				signed: printSigned
				on: stream ] ].
	self assert: (printer value: 123456789 value: false) equals: '123.456.789'.
	self assert: (printer value: -123456789 value: false) equals: '-123.456.789'.
	self assert: (printer value: 123456789 value: true) equals: '+123.456.789'.
	self assert: (printer value: -123456789 value: true) equals: '-123.456.789'! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
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 - basic' stamp: ''!
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 - arithmetic' stamp: ''!
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 equals: 1 ]
				ifFalse: [ self should: [ a reciprocalModulo: b ] raise: Error ] ] ]! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
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 equals: highBit.
			self assert: anInteger negated highBitOfMagnitude equals: highBit ]! !

!IntegerTest methodsFor: 'private' stamp: ''!
assert: a classAndValueEquals: b
	self assert: a class equals: b class.
	self assert: a equals: b! !

!IntegerTest methodsFor: 'tests - basic' stamp: ''!
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 - instance creation' stamp: ''!
testCreationFromBytes2
	"It is illegal for a LargeInteger to be less than SmallInteger maxVal. Here we test that Integer>>byte!!byte2:byte3:byte4: 
	 reconstructs (SmallInteger maxVal + 1) as an instance of LargePositiveInteger."

	| maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger |
	Smalltalk vm wordSize = 4 ifFalse: [ ^ self skip ].
	maxSmallInt := SmallInteger maxVal.
	hexString := (maxSmallInt + 1) printStringHex.
	self assert: hexString size equals: 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 equals: maxSmallInt + 1.
	self deny: builtInteger class equals: SmallInteger! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testHex
	self assert: 0 hex equals: '16r0'.
	self assert: 12 hex equals: '16rC'.
	self assert: 1234 hex equals: '16r4D2'! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: ''!
testStringAsNumber
	"This covers parsing in Number>>readFrom:
	Trailing decimal points should be ignored."

	self assert: '123' asNumber equals: 123.
	self assert: '-123' asNumber equals: -123.
	self assert: '123.' asNumber equals: 123.
	self assert: '-123.' asNumber equals: -123.
	self assert: '123This is not to be read' asNumber equals: 123.
	self assert: '123s could be confused with a ScaledDecimal' asNumber equals: 123.
	self assert: '123e could be confused with a Float' asNumber equals: 123! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testIntegerHex
	| result |
	result := 15 asInteger hex.
	self assert: result equals: '16rF'.
	result := 0 asInteger hex.
	self assert: result equals: '16r0'.
	result := 255 asInteger hex.
	self assert: result equals: '16rFF'.
	result := 90 asInteger hex.
	self assert: result equals: '16r5A'! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
testTwoComplementRightShift
	| large small |
	small := 2 << 16.
	large := 2 << 32.
	self assert: (small negated bitShift: -1) ~= ((small + 1) negated bitShift: -1) identicalTo: (large negated bitShift: -1) ~= ((large + 1) negated bitShift: -1).

	self assert: (small bitShift: -1) ~= (small + 1 bitShift: -1) identicalTo: (large bitShift: -1) ~= (large + 1 bitShift: -1)! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testNumberOfDigits
	2 to: 32 do: [ :b | 
		1 to: 1000 // b do: [ :n | 
			| bRaisedToN |
			bRaisedToN := b raisedTo: n.
			self assert: (bRaisedToN - 1 numberOfDigitsInBase: b) equals: n.
			self assert: (bRaisedToN numberOfDigitsInBase: b) equals: n + 1.
			self assert: (bRaisedToN + 1 numberOfDigitsInBase: b) equals: n + 1.

			self assert: (bRaisedToN negated + 1 numberOfDigitsInBase: b) equals: n.
			self assert: (bRaisedToN negated numberOfDigitsInBase: b) equals: n + 1.
			self assert: (bRaisedToN negated - 1 numberOfDigitsInBase: b) equals: n + 1 ] ]! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
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: ''!
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 equals: highBit ]! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
testFactorial	
	"Check some know values"
	self assert: 0 factorial equals: 1.
	self assert: 1 factorial equals: 1.
	self assert: 2 factorial equals: 2.
	self assert: 3 factorial equals: 6.
	self assert: 4 factorial equals: 24.
	self assert: 5 factorial equals: 120.
	self assert: 6 factorial equals: 720! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testBenchFib
	self assert: 0 benchFib equals: 1.
	self assert: 1 benchFib equals: 1.
	self assert: 2 benchFib equals: 3! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
testNthRootErrorConditions
	"
	IntegerTest new testExactRaisedToErrorConditions
	"

	self should: [ -2 nthRoot: 1/4 ] raise: ArithmeticError.
	self should: [ -2 nthRoot: 1.24 ] raise: ArithmeticError.! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testAsStringWithCommas
	self assert: 123456789 asStringWithCommas equals: '123,456,789'.
	self assert: -123456789 asStringWithCommas equals: '-123,456,789'! !

!IntegerTest methodsFor: 'tests - basic' stamp: ''!
testEven
	
	self deny: (1073741825 even).
	self assert: (1073741824  even).! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
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 equals: lowBit.
			self assert: anInteger negated lowBit equals: lowBit ]! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: ''!
testNew
	self should: [Integer new] raise: self defaultTestError.! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 equals: each sqrtFloor ]! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
testSlowFactorial

	"Check some know values"
	self assert: 0 slowFactorial equals: 1.
	self assert: 1 slowFactorial equals: 1.
	self assert: 2 slowFactorial equals: 2.
	self assert: 3 slowFactorial equals: 6.
	self assert: 4 slowFactorial equals: 24.
	self assert: 5 slowFactorial equals: 120.
	self assert: 6 slowFactorial equals: 720.
	
   "Compare fast implementarion with existing one for the first 1000 positive integers plus zero"
	0 to: 1000 do: [ :idx | self assert: idx slowFactorial equals: idx factorial]! !

!IntegerTest methodsFor: 'tests - arithmetic' stamp: ''!
testCrossSumBase

	self assert: ((-20 to: 20) collect: [:each | each crossSumBase: 10]) asArray   
		  equals: #(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 
		  equals: #(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: '*Kernel-Tests-Extended' stamp: ''!
testRomanPrinting
	self assert: 0 printStringRoman equals: ''.	"No symbol for zero"
	self assert: 1 printStringRoman equals: 'I'.
	self assert: 2 printStringRoman equals: 'II'.
	self assert: 3 printStringRoman equals: 'III'.
	self assert: 4 printStringRoman equals: 'IV'.
	self assert: 5 printStringRoman equals: 'V'.
	self assert: 6 printStringRoman equals: 'VI'.
	self assert: 7 printStringRoman equals: 'VII'.
	self assert: 8 printStringRoman equals: 'VIII'.
	self assert: 9 printStringRoman equals: 'IX'.
	self assert: 10 printStringRoman equals: 'X'.
	self assert: 23 printStringRoman equals: 'XXIII'.
	self assert: 36 printStringRoman equals: 'XXXVI'.
	self assert: 49 printStringRoman equals: 'XLIX'.
	self assert: 62 printStringRoman equals: 'LXII'.
	self assert: 75 printStringRoman equals: 'LXXV'.
	self assert: 88 printStringRoman equals: 'LXXXVIII'.
	self assert: 99 printStringRoman equals: 'XCIX'.
	self assert: 100 printStringRoman equals: 'C'.
	self assert: 101 printStringRoman equals: 'CI'.
	self assert: 196 printStringRoman equals: 'CXCVI'.
	self assert: 197 printStringRoman equals: 'CXCVII'.
	self assert: 198 printStringRoman equals: 'CXCVIII'.
	self assert: 293 printStringRoman equals: 'CCXCIII'.
	self assert: 294 printStringRoman equals: 'CCXCIV'.
	self assert: 295 printStringRoman equals: 'CCXCV'.
	self assert: 390 printStringRoman equals: 'CCCXC'.
	self assert: 391 printStringRoman equals: 'CCCXCI'.
	self assert: 392 printStringRoman equals: 'CCCXCII'.
	self assert: 487 printStringRoman equals: 'CDLXXXVII'.
	self assert: 488 printStringRoman equals: 'CDLXXXVIII'.
	self assert: 489 printStringRoman equals: 'CDLXXXIX'.
	self assert: 584 printStringRoman equals: 'DLXXXIV'.
	self assert: 585 printStringRoman equals: 'DLXXXV'.
	self assert: 586 printStringRoman equals: 'DLXXXVI'.
	self assert: 681 printStringRoman equals: 'DCLXXXI'.
	self assert: 682 printStringRoman equals: 'DCLXXXII'.
	self assert: 683 printStringRoman equals: 'DCLXXXIII'.
	self assert: 778 printStringRoman equals: 'DCCLXXVIII'.
	self assert: 779 printStringRoman equals: 'DCCLXXIX'.
	self assert: 780 printStringRoman equals: 'DCCLXXX'.
	self assert: 875 printStringRoman equals: 'DCCCLXXV'.
	self assert: 876 printStringRoman equals: 'DCCCLXXVI'.
	self assert: 877 printStringRoman equals: 'DCCCLXXVII'.
	self assert: 972 printStringRoman equals: 'CMLXXII'.
	self assert: 973 printStringRoman equals: 'CMLXXIII'.
	self assert: 974 printStringRoman equals: 'CMLXXIV'.
	self assert: 1069 printStringRoman equals: 'MLXIX'.
	self assert: 1070 printStringRoman equals: 'MLXX'.
	self assert: 1071 printStringRoman equals: 'MLXXI'.
	self assert: 1166 printStringRoman equals: 'MCLXVI'.
	self assert: 1167 printStringRoman equals: 'MCLXVII'.
	self assert: 1168 printStringRoman equals: 'MCLXVIII'.
	self assert: 1263 printStringRoman equals: 'MCCLXIII'.
	self assert: 1264 printStringRoman equals: 'MCCLXIV'.
	self assert: 1265 printStringRoman equals: 'MCCLXV'.
	self assert: 1360 printStringRoman equals: 'MCCCLX'.
	self assert: 1361 printStringRoman equals: 'MCCCLXI'.
	self assert: 1362 printStringRoman equals: 'MCCCLXII'.
	self assert: 1457 printStringRoman equals: 'MCDLVII'.
	self assert: 1458 printStringRoman equals: 'MCDLVIII'.
	self assert: 1459 printStringRoman equals: 'MCDLIX'.
	self assert: 1554 printStringRoman equals: 'MDLIV'.
	self assert: 1555 printStringRoman equals: 'MDLV'.
	self assert: 1556 printStringRoman equals: 'MDLVI'.
	self assert: 1651 printStringRoman equals: 'MDCLI'.
	self assert: 1652 printStringRoman equals: 'MDCLII'.
	self assert: 1653 printStringRoman equals: 'MDCLIII'.
	self assert: 1748 printStringRoman equals: 'MDCCXLVIII'.
	self assert: 1749 printStringRoman equals: 'MDCCXLIX'.
	self assert: 1750 printStringRoman equals: 'MDCCL'.
	self assert: 1845 printStringRoman equals: 'MDCCCXLV'.
	self assert: 1846 printStringRoman equals: 'MDCCCXLVI'.
	self assert: 1847 printStringRoman equals: 'MDCCCXLVII'.
	self assert: 1942 printStringRoman equals: 'MCMXLII'.
	self assert: 1943 printStringRoman equals: 'MCMXLIII'.
	self assert: 1944 printStringRoman equals: 'MCMXLIV'.
	self assert: 2004 printStringRoman equals: 'MMIV'.

	self assert: -1 printStringRoman equals: '-I'.
	self assert: -2 printStringRoman equals: '-II'.
	self assert: -3 printStringRoman equals: '-III'.
	self assert: -4 printStringRoman equals: '-IV'.
	self assert: -5 printStringRoman equals: '-V'.
	self assert: -6 printStringRoman equals: '-VI'.
	self assert: -7 printStringRoman equals: '-VII'.
	self assert: -8 printStringRoman equals: '-VIII'.
	self assert: -9 printStringRoman equals: '-IX'.
	self assert: -10 printStringRoman equals: '-X'! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: ''!
testCreationFromBytes1
	"It is illegal for a LargeInteger to be less than SmallInteger maxVal. Here we test that Integer>>byte!!byte2:byte3:byte4: 
	 reconstructs SmallInteger maxVal as an instance of SmallInteger."
  
	| maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger |
	Smalltalk vm wordSize = 4 ifFalse: [ ^ self skip ].
	maxSmallInt := SmallInteger maxVal.
	hexString := maxSmallInt printStringHex.
	self assert: hexString size equals: 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 equals: maxSmallInt.
	self assert: builtInteger class equals: SmallInteger! !

!IntegerTest methodsFor: 'tests - other' stamp: ''!
testDigitSum

	self assert: 1234 digitSum equals: 10! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: ''!
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: ''!
testCreationFromBytes3
	"It is illegal for a LargeInteger to be less than SmallInteger maxVal. Here we test that Integer>>byte!!byte2:byte3:byte4: 
	 reconstructs (SmallInteger maxVal - 1) as an instance of SmallInteger."
	
	| maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger |
	Smalltalk vm wordSize = 4 ifFalse: [ ^ self skip ].
	maxSmallInt := SmallInteger maxVal.
	hexString := (maxSmallInt - 1) printStringHex.
	self assert: hexString size equals: 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 equals: (maxSmallInt - 1).
	self assert: builtInteger class equals: SmallInteger! !

!IntegerTest methodsFor: 'tests - mathematical functions' stamp: ''!
testRaisedToErrorConditions
	"
	IntegerTest new testRaisedToErrorConditions
	"

	self should: [ -2 raisedTo: 1/4 ] raise: ArithmeticError.
	self should: [ -2 raisedTo: 1.24 ] raise: ArithmeticError.! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
testDigitsAccess

	self assert: (42 digitAt: 2 base: 10) equals: 4.
	self assert: (42 digitAt: 1 base: 10) equals: 2.
	self assert: (1 digitAt: 2 base: 10) equals: 0.
	self assert: (16rFF digitAt: 1 base: 16) equals: 15.

	self assert: (42 decimalDigitAt: 2) equals: 4.
	self assert: (42 decimalDigitAt: 1) equals: 2.
	
	self assert: (42 decimalDigitLength) equals: 2.
	self assert: (0 decimalDigitLength) equals: 1.
	self assert: (100000000000 decimalDigitLength) equals: 12. "large integer"

	"last digit of the integer base 256"
	self assert: (255 lastDigit) equals: 255.
	self assert: (256 lastDigit) equals: 1.
	self assert: ((256*256-1) lastDigit) equals: 255.
	self assert: ((256*256) lastDigit) equals: 1.! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: ''!
testReadFromWithError
	"Ensure that a string that does not represent an integer raises an error."
	
	self should: [Integer readFrom: 'invalid'] raise: Error! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testPrimesUpTo
	| primes nn |
	primes := Integer primesUpTo: 100.
	self assert: primes equals: #(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 equals: #(2 3).

	"this test is green for nn>25000, see #testLargePrimesUpTo"
	nn := 5.
	self deny: (Integer primesUpTo: nn) last equals: nn.
	self assert: (Integer primesUpTo: nn + 1) last equals: nn! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
testBitString
		
	Smalltalk vm wordSize = 4
		ifTrue: [
			self assert: 2 bitString equals: '0000000000000000000000000000010'.
			self assert: -1 bitString equals: '1111111111111111111111111111111'.
			self assert: -2 bitString equals: '1111111111111111111111111111110'.
			self assert: 2 bitStringLength equals: 31 ]. 
	Smalltalk vm wordSize = 8
		ifTrue: [
			self assert: 2 bitString equals: '0000000000000000000000000000000000000000000000000000000000010'.
			self assert: -1 bitString equals: '1111111111111111111111111111111111111111111111111111111111111'.
			self assert: -2 bitString equals: '1111111111111111111111111111111111111111111111111111111111110'.
			self assert: 2 bitStringLength equals: 61 ]. 
	"32 minus 1 for immediate encoding = 31 = 30 for number + 1 for sign"
	"64 minus 3 for immediate encoding = 61 = 60 for number + 1 for sign"
	self assert: 2 bitStringLength equals: (SmallInteger maxVal highBit + 1).! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnBaseShowRadix
	self assert: (String streamContents: [ :str | 123 printOn: str base: 10 showRadix: false ]) equals: '123'.
	self assert: (String streamContents: [ :str | 123 printOn: str base: 10 showRadix: true ]) equals: '10r123'.
	self assert: (String streamContents: [ :str | 123 printOn: str base: 8 showRadix: false ]) equals: '173'.
	self assert: (String streamContents: [ :str | 123 printOn: str base: 8 showRadix: true ]) equals: '8r173'! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
testNthRootExactness
	| inexactRoots largeExactPowersOf6 |
	largeExactPowersOf6 := (2 to: 100) collect: [:k | k raisedTo: 66].
	inexactRoots := largeExactPowersOf6 reject: [:e | (e nthRoot: 6) isInteger].
	self assert: inexactRoots isEmpty description: 'Failed to find the exact 6th root of these numbers'! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testSqrtErrorConditions
	"
	IntegerTest new testSqrtErrorConditions
	"

	self should: [ -1 sqrt ] raise: ArithmeticError! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testDegreeCos

	45 degreeCos.	"Following tests use approximate equality, because cosine are generally evaluated using inexact Floating point arithmetic"
	self assert: (45 degreeCos squared - (1 / 2)) abs <= Float epsilon.
	self assert: (60 degreeCos - (1 / 2)) abs <= Float epsilon.
	self assert: (120 degreeCos + (1 / 2)) abs <= Float epsilon.
	-360 to: 360 do: [ :i | self assert: (i degreeCos closeTo: i degreesToRadians cos) ].	"Following tests use strict equality which is a requested property of degreeCos"
	-10 to: 10 do: [ :k | 
		self assert: (k * 360 + 90) degreeCos equals: 0.
		self assert: (k * 360 - 90) degreeCos equals: 0.
		self assert: (k * 360 + 180) degreeCos + 1 equals: 0.
		self assert: (k * 360) degreeCos - 1 equals: 0 ]! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: ''!
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 equals: 2.
	self assert: 3r210 equals: 21.
	self assert: 4r3210 equals: 228.
	self assert: 5r43210 equals: 2930.
	self assert: 6r543210 equals: 44790.
	self assert: 7r6543210 equals: 800667.
	self assert: 8r76543210 equals: 16434824.
	self assert: 9r876543210 equals: 381367044.
	self assert: 10r9876543210 equals: 9876543210.
	self assert: 11rA9876543210 equals: 282458553905.
	self assert: 12rBA9876543210 equals: 8842413667692.
	self assert: 13rCBA9876543210 equals: 300771807240918.
	self assert: 14rDCBA9876543210 equals: 11046255305880158.
	self assert: 15rEDCBA9876543210 equals: 435659737878916215.
	self assert: 16rFEDCBA9876543210 equals: 18364758544493064720.
	self assert: 17rGFEDCBA9876543210 equals: 824008854613343261192.
	self assert: 18rHGFEDCBA9876543210 equals: 39210261334551566857170.
	self assert: 19rIHGFEDCBA9876543210 equals: 1972313422155189164466189.
	self assert: 20rJIHGFEDCBA9876543210 equals: 104567135734072022160664820.
	self assert: 21rKJIHGFEDCBA9876543210 equals: 5827980550840017565077671610.
	self assert: 22rLKJIHGFEDCBA9876543210 equals: 340653664490377789692799452102.
	self assert: 23rMLKJIHGFEDCBA9876543210 equals: 20837326537038308910317109288851.
	self assert: 24rNMLKJIHGFEDCBA9876543210 equals: 1331214537196502869015340298036888.
	self assert: 25rONMLKJIHGFEDCBA9876543210 equals: 88663644327703473714387251271141900.
	self assert: 26rPONMLKJIHGFEDCBA9876543210 equals: 6146269788878825859099399609538763450.
	self assert: 27rQPONMLKJIHGFEDCBA9876543210 equals: 442770531899482980347734468443677777577.
	self assert: 28rRQPONMLKJIHGFEDCBA9876543210 equals: 33100056003358651440264672384704297711484.
	self assert: 29rSRQPONMLKJIHGFEDCBA9876543210 equals: 2564411043271974895869785066497940850811934.
	self assert: 30rTSRQPONMLKJIHGFEDCBA9876543210 equals: 205646315052919334126040428061831153388822830.
	self assert: 31rUTSRQPONMLKJIHGFEDCBA9876543210 equals: 17050208381689099029767742314582582184093573615.
	self assert: 32rVUTSRQPONMLKJIHGFEDCBA9876543210 equals: 1459980823972598128486511383358617792788444579872.
	self assert: 33rWVUTSRQPONMLKJIHGFEDCBA9876543210 equals: 128983956064237823710866404905431464703849549412368.
	self assert: 34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 equals: 11745843093701610854378775891116314824081102660800418.
	self assert: 35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 equals: 1101553773143634726491620528194292510495517905608180485.
	self assert: 36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 equals: 106300512100105327644605138221229898724869759421181854980.

	self assert: -2r10 equals: -2.
	self assert: -3r210 equals: -21.
	self assert: -4r3210 equals: -228.
	self assert: -5r43210 equals: -2930.
	self assert: -6r543210 equals: -44790.
	self assert: -7r6543210 equals: -800667.
	self assert: -8r76543210 equals: -16434824.
	self assert: -9r876543210 equals: -381367044.
	self assert: -10r9876543210 equals: -9876543210.
	self assert: -11rA9876543210 equals: -282458553905.
	self assert: -12rBA9876543210 equals: -8842413667692.
	self assert: -13rCBA9876543210 equals: -300771807240918.
	self assert: -14rDCBA9876543210 equals: -11046255305880158.
	self assert: -15rEDCBA9876543210 equals: -435659737878916215.
	self assert: -16rFEDCBA9876543210 equals: -18364758544493064720.
	self assert: -17rGFEDCBA9876543210 equals: -824008854613343261192.
	self assert: -18rHGFEDCBA9876543210 equals: -39210261334551566857170.
	self assert: -19rIHGFEDCBA9876543210 equals: -1972313422155189164466189.
	self assert: -20rJIHGFEDCBA9876543210 equals: -104567135734072022160664820.
	self assert: -21rKJIHGFEDCBA9876543210 equals: -5827980550840017565077671610.
	self assert: -22rLKJIHGFEDCBA9876543210 equals: -340653664490377789692799452102.
	self assert: -23rMLKJIHGFEDCBA9876543210 equals: -20837326537038308910317109288851.
	self assert: -24rNMLKJIHGFEDCBA9876543210 equals: -1331214537196502869015340298036888.
	self assert: -25rONMLKJIHGFEDCBA9876543210 equals: -88663644327703473714387251271141900.
	self assert: -26rPONMLKJIHGFEDCBA9876543210 equals: -6146269788878825859099399609538763450.
	self assert: -27rQPONMLKJIHGFEDCBA9876543210 equals: -442770531899482980347734468443677777577.
	self assert: -28rRQPONMLKJIHGFEDCBA9876543210 equals: -33100056003358651440264672384704297711484.
	self assert: -29rSRQPONMLKJIHGFEDCBA9876543210 equals: -2564411043271974895869785066497940850811934.
	self assert: -30rTSRQPONMLKJIHGFEDCBA9876543210 equals: -205646315052919334126040428061831153388822830.
	self assert: -31rUTSRQPONMLKJIHGFEDCBA9876543210 equals: -17050208381689099029767742314582582184093573615.
	self assert: -32rVUTSRQPONMLKJIHGFEDCBA9876543210 equals: -1459980823972598128486511383358617792788444579872.
	self assert: -33rWVUTSRQPONMLKJIHGFEDCBA9876543210 equals: -128983956064237823710866404905431464703849549412368.
	self assert: -34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 equals: -11745843093701610854378775891116314824081102660800418.
	self assert: -35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 equals: -1101553773143634726491620528194292510495517905608180485.
	self assert: -36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 equals: -106300512100105327644605138221229898724869759421181854980.! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
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 - other' stamp: ''!
testIsAbstract 

	self assert: Integer isAbstract! !

!IntegerTest methodsFor: 'tests - basic' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
testDegreeSin

	45 degreeSin.	"Following tests use approximate equality, because sine are generally evaluated using inexact Floating point arithmetic"
	self assert: (45 degreeSin squared - (1 / 2)) abs <= Float epsilon.
	self assert: (30 degreeSin - (1 / 2)) abs <= Float epsilon.
	self assert: (-30 degreeSin + (1 / 2)) abs <= Float epsilon.
	-360 to: 360 do: [ :i | self assert: (i degreeSin closeTo: i degreesToRadians sin) ].	"Following tests use strict equality which is a requested property of degreeSin"
	-10 to: 10 do: [ :k | 
		self assert: (k * 360 + 90) degreeSin - 1 equals: 0.
		self assert: (k * 360 - 90) degreeSin + 1 equals: 0.
		self assert: (k * 360 + 180) degreeSin equals: 0.
		self assert: (k * 360) degreeSin equals: 0 ]! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: ''!
testIntegerReadsOkFromStream
	self assert: (Integer readFrom: '123' readStream) equals: 123.
	self assert: (Integer readFrom: '-123' readStream) equals: -123.
	self assert: (Integer readFrom: 'a3' readStream base: 16) equals: 163.
	self assert: (Integer readFrom: '-a3' readStream base: 16) equals: -163.

	self assert: (Integer readFrom: '3a' readStream base: 10) equals: 3! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
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 isFloat.
	self deny: result isInfinite.
	self assert: result equals: 100 factorial asFloat.	"No other float is closer. See following line"
	self assert: 100 factorial asFloat equals: (100 factorial + 1) asFloat! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testLn
	self assert: (100 ln closeTo: 10 ln*2).
	self assert: ((2 raisedTo: Float emax + 3) ln closeTo: 2 ln*(Float emax + 3)) description: 'Integer>>ln should not overflow'! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testIntegerPadding
 
	self assert: (1 printStringBase: 10 length: 0 padded: false) equals: '1'.
	self assert: (1 printStringBase: 10 length: 1 padded: false) equals: '1'.
	self assert: (1 printStringBase: 10 length: 2 padded: false) equals: ' 1'.
	self assert: (1024 printStringBase: 10 length: 19 padded: false) equals: '               1024'.
	self assert: (1024 printStringBase: 10 length: -1 padded: false) equals: '1024'.
	self assert: (1024 printStringBase: 10 length: 5 padded: false) equals: ' 1024'.
	self assert: (-1024 printStringBase: 10 length: 5 padded: false) equals: '-1024'.
	self assert: (-1024 printStringBase: 10 length: 19 padded: false) equals: '              -1024'.

	self assert: (1 printStringBase: 10 length: 0 padded: true) equals: '1'.
	self assert: (1 printStringBase: 10 length: 1 padded: true) equals: '1'.
	self assert: (1 printStringBase: 10 length: 2 padded: true) equals: '01'.
	self assert: (1024 printStringBase: 10 length: 19 padded: true) equals: '0000000000000001024'.
	self assert: (1024 printStringBase: 10 length: -1 padded: true) equals: '1024'.
	self assert: (1024 printStringBase: 10 length: 5 padded: true) equals: '01024'.
	self assert: (-1024 printStringBase: 10 length: 5 padded: true) equals: '-1024'.
	self assert: (-1024 printStringBase: 10 length: 19 padded: true) equals: '-000000000000001024'.

	self assert: (1 printStringBase: 16 length: 0 padded: false) equals: '1'.
	self assert: (1 printStringBase: 16 length: 1 padded: false) equals: '1'.
	self assert: (1 printStringBase: 16 length: 2 padded: false) equals: ' 1'.
	self assert: (2047 printStringBase: 16 length: 19 padded: false) equals: '                7FF'.
	self assert: (2047 printStringBase: 16 length: -1 padded: false) equals: '7FF'.
	self assert: (2047 printStringBase: 16 length: 4 padded: false) equals: ' 7FF'.
	self assert: (-2047 printStringBase: 16 length: 4 padded: false) equals: '-7FF'.
	self assert: (-2047 printStringBase: 16 length: 19 padded: false) equals: '               -7FF'.

	self assert: (1 printStringBase: 16 length: 0 padded: true) equals: '1'.
	self assert: (1 printStringBase: 16 length: 1 padded: true) equals: '1'.
	self assert: (1 printStringBase: 16 length: 2 padded: true) equals: '01'.
	self assert: (2047 printStringBase: 16 length: 19 padded: true) equals: '00000000000000007FF'.
	self assert: (2047 printStringBase: 16 length: -1 padded: true) equals: '7FF'.
	self assert: (2047 printStringBase: 16 length: 4 padded: true) equals: '07FF'.
	self assert: (-2047 printStringBase: 16 length: 4 padded: true) equals: '-7FF'.
	self assert: (-2047 printStringBase: 16 length: 19 padded: true) equals: '-0000000000000007FF'.

	self assert: (1 storeStringBase: 10 length: 0 padded: false) equals: '1'.
	self assert: (1 storeStringBase: 10 length: 1 padded: false) equals: '1'.
	self assert: (1 storeStringBase: 10 length: 2 padded: false) equals: ' 1'.
	self assert: (1024 storeStringBase: 10 length: 19 padded: false) equals: '               1024'.
	self assert: (1024 storeStringBase: 10 length: -1 padded: false) equals: '1024'.
	self assert: (1024 storeStringBase: 10 length: 5 padded: false) equals:' 1024'.
	self assert: (-1024 storeStringBase: 10 length: 5 padded: false) equals: '-1024'.
	self assert: (-1024 storeStringBase: 10 length: 19 padded: false) equals: '              -1024'.

	self assert: (1 storeStringBase: 10 length: 0 padded: true) equals: '1'.
	self assert: (1 storeStringBase: 10 length: 1 padded: true) equals: '1'.
	self assert: (1 storeStringBase: 10 length: 2 padded: true) equals: '01'.
	self assert: (1024 storeStringBase: 10 length: 19 padded: true) equals: '0000000000000001024'.
	self assert: (1024 storeStringBase: 10 length: -1 padded: true) equals: '1024'.
	self assert: (1024 storeStringBase: 10 length: 5 padded: true) equals: '01024'.
	self assert: (-1024 storeStringBase: 10 length: 5 padded: true) equals: '-1024'.
	self assert: (-1024 storeStringBase: 10 length: 19 padded: true) equals: '-000000000000001024'.

	self assert: (1 storeStringBase: 16 length: 0 padded: false) equals: '16r1'.
	self assert: (1 storeStringBase: 16 length: 4 padded: false) equals: '16r1'.
	self assert: (1 storeStringBase: 16 length: 5 padded: false) equals: ' 16r1'.
	self assert: (2047 storeStringBase: 16 length: 19 padded: false) equals: '             16r7FF'.
	self assert: (2047 storeStringBase: 16 length: -1 padded: false) equals: '16r7FF'.
	self assert: (2047 storeStringBase: 16 length: 7 padded: false) equals: ' 16r7FF'.
	self assert: (-2047 storeStringBase: 16 length: 7 padded: false) equals: '-16r7FF'.
	self assert: (-2047 storeStringBase: 16 length: 19 padded: false) equals: '            -16r7FF'.

	self assert: (1 storeStringBase: 16 length: 0 padded: true) equals: '16r1'.
	self assert: (1 storeStringBase: 16 length: 4 padded: true) equals: '16r1'.
	self assert: (1 storeStringBase: 16 length: 5 padded: true) equals: '16r01'.
	self assert: (2047 storeStringBase: 16 length: 19 padded: true) equals: '16r00000000000007FF'.
	self assert: (2047 storeStringBase: 16 length: -1 padded: true) equals: '16r7FF'.
	self assert: (2047 storeStringBase: 16 length: 7 padded: true) equals: '16r07FF'.
	self assert: (-2047 storeStringBase: 16 length: 7 padded: true) equals: '-16r7FF'.
	self assert: (-2047 storeStringBase: 16 length: 19 padded: true) equals: '-16r0000000000007FF'! !

!IntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testFloorLog
	self assert: (100 floorLog: 10) equals: 2.
	self assert: ((2 raisedTo: Float emax + 3) floorLog: 10) = (2 log * (Float emax + 3)) floor description: 'Integer>>floorLog: should not overflow'! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
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 equals: 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: '*Kernel-Tests-Extended' stamp: ''!
testLargePrimesUpTo
	| nn |
	nn := (2 raisedTo: 17) - 1.
	self deny: (Integer primesUpTo: nn) last equals: nn.
	self assert: (Integer primesUpTo: nn + 1) last equals: nn! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testStoreOn
	| integer |
	integer := 42.
	
	self assert: (String streamContents: [ :s | integer storeOn: s ]) equals: '42'.
	
	integer := -42.
	
	self assert: (String streamContents: [ :s | integer storeOn: s ]) equals: ' -42'.! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
testBitXor

	self assert: (2r1100 bitXor: 2r1010) equals: 2r0110.! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
testNthRootTruncated
	<timeout:  5 "seconds">
	| 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: '*Kernel-Tests-Extended' stamp: ''!
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: '*Kernel-Tests-Extended' stamp: ''!
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 - printing' stamp: ''!
testPositiveIntegerPrinting

	self assert: 0 printString equals: '0'.
	self assert: 0 printStringHex equals: '0'.
	self assert: 0 storeStringHex equals: '16r0'.

	self assert: (2 printStringBase: 2) equals: '10'.
	self assert: (2 radix: 2) equals: '10'.
	self assert: 2 printStringHex equals: '2'.
	self assert: (2 storeStringBase: 2) equals: '2r10'.
	self assert: 2 storeStringHex equals: '16r2'.
	self assert: (21 printStringBase: 3) equals: '210'.
	self assert: (21 radix: 3) equals: '210'.
	self assert: 21 printStringHex equals: '15'.
	self assert: (21 storeStringBase: 3) equals: '3r210'.
	self assert: 21 storeStringHex equals: '16r15'.
	self assert: (228 printStringBase: 4) equals: '3210'.
	self assert: (228 radix: 4) equals: '3210'.
	self assert: 228 printStringHex equals: 'E4'.
	self assert: (228 storeStringBase: 4) equals: '4r3210'.
	self assert: 228 storeStringHex equals: '16rE4'.
	self assert: (2930 printStringBase: 5) equals: '43210'.
	self assert: (2930 radix: 5) equals: '43210'.
	self assert: 2930 printStringHex equals: 'B72'.
	self assert: (2930 storeStringBase: 5) equals: '5r43210'.
	self assert: 2930 storeStringHex equals: '16rB72'.
	self assert: (44790 printStringBase: 6) equals: '543210'.
	self assert: (44790 radix: 6) equals: '543210'.
	self assert: 44790 printStringHex equals: 'AEF6'.
	self assert: (44790 storeStringBase: 6) equals: '6r543210'.
	self assert: 44790 storeStringHex equals: '16rAEF6'.
	self assert: (800667 printStringBase: 7) equals: '6543210'.
	self assert: (800667 radix: 7) equals: '6543210'.
	self assert: 800667 printStringHex equals: 'C379B'.
	self assert: (800667 storeStringBase: 7) equals: '7r6543210'.
	self assert: 800667 storeStringHex equals: '16rC379B'.
	self assert: (16434824 printStringBase: 8) equals: '76543210'.
	self assert: (16434824 radix: 8) equals: '76543210'.
	self assert: 16434824 printStringHex equals: 'FAC688'.
	self assert: (16434824 storeStringBase: 8) equals: '8r76543210'.
	self assert: 16434824 storeStringHex equals: '16rFAC688'.
	self assert: (381367044 printStringBase: 9) equals: '876543210'.
	self assert: (381367044 radix: 9) equals: '876543210'.
	self assert: 381367044 printStringHex equals: '16BB3304'.
	self assert: (381367044 storeStringBase: 9) equals: '9r876543210'.
	self assert: 381367044 storeStringHex equals: '16r16BB3304'.
	self assert: (9876543210 printStringBase: 10) equals: '9876543210'.
	self assert: (9876543210 radix: 10) equals: '9876543210'.
	self assert: 9876543210 printStringHex equals: '24CB016EA'.
	self assert: (9876543210 storeStringBase: 10) equals: '9876543210'.
	self assert: 9876543210 storeStringHex equals: '16r24CB016EA'.
	self assert: (282458553905 printStringBase: 11) equals: 'A9876543210'.
	self assert: (282458553905 radix: 11) equals: 'A9876543210'.
	self assert: 282458553905 printStringHex equals: '41C3D77E31'.
	self assert: (282458553905 storeStringBase: 11) equals: '11rA9876543210'.
	self assert: 282458553905 storeStringHex equals: '16r41C3D77E31'.
	self assert: (8842413667692 printStringBase: 12) equals: 'BA9876543210'.
	self assert: (8842413667692 radix: 12) equals: 'BA9876543210'.
	self assert: 8842413667692 printStringHex equals: '80AC8ECF56C'.
	self assert: (8842413667692 storeStringBase: 12) equals: '12rBA9876543210'.
	self assert: 8842413667692 storeStringHex equals: '16r80AC8ECF56C'.
	self assert: (300771807240918 printStringBase: 13) equals: 'CBA9876543210'.
	self assert: (300771807240918 radix: 13) equals: 'CBA9876543210'.
	self assert: 300771807240918 printStringHex equals: '1118CE4BAA2D6'.
	self assert: (300771807240918 storeStringBase: 13) equals: '13rCBA9876543210'.
	self assert: 300771807240918 storeStringHex equals: '16r1118CE4BAA2D6'.
	self assert: (11046255305880158 printStringBase: 14) equals: 'DCBA9876543210'.
	self assert: (11046255305880158 radix: 14) equals: 'DCBA9876543210'.
	self assert: 11046255305880158 printStringHex equals: '273E82BB9AF25E'.
	self assert: (11046255305880158 storeStringBase: 14) equals: '14rDCBA9876543210'.
	self assert: 11046255305880158 storeStringHex equals: '16r273E82BB9AF25E'.
	self assert: (435659737878916215 printStringBase: 15) equals: 'EDCBA9876543210'.
	self assert: (435659737878916215 radix: 15) equals: 'EDCBA9876543210'.
	self assert: 435659737878916215 printStringHex equals: '60BC6392F366C77'.
	self assert: (435659737878916215 storeStringBase: 15) equals: '15rEDCBA9876543210'.
	self assert: 435659737878916215 storeStringHex equals: '16r60BC6392F366C77'.
	self assert: (18364758544493064720 printStringBase: 16) equals: 'FEDCBA9876543210'.
	self assert: (18364758544493064720 radix: 16) equals: 'FEDCBA9876543210'.
	self assert: 18364758544493064720 printStringHex equals: 'FEDCBA9876543210'.
	self assert: (18364758544493064720 storeStringBase: 16) equals: '16rFEDCBA9876543210'.
	self assert: 18364758544493064720 storeStringHex equals: '16rFEDCBA9876543210'.
	self assert: (824008854613343261192 printStringBase: 17) equals: 'GFEDCBA9876543210'.
	self assert: (824008854613343261192 radix: 17) equals: 'GFEDCBA9876543210'.
	self assert: 824008854613343261192 printStringHex equals: '2CAB6B877C1CD2D208'.
	self assert: (824008854613343261192 storeStringBase: 17) equals: '17rGFEDCBA9876543210'.
	self assert: 824008854613343261192 storeStringHex equals: '16r2CAB6B877C1CD2D208'.
	self assert: (39210261334551566857170 printStringBase: 18) equals: 'HGFEDCBA9876543210'.
	self assert: (39210261334551566857170 radix: 18) equals: 'HGFEDCBA9876543210'.
	self assert: 39210261334551566857170 printStringHex equals: '84D97AFCAE81415B3D2'.
	self assert: (39210261334551566857170 storeStringBase: 18) equals: '18rHGFEDCBA9876543210'.
	self assert: 39210261334551566857170 storeStringHex equals: '16r84D97AFCAE81415B3D2'.
	self assert: (1972313422155189164466189 printStringBase: 19) equals: 'IHGFEDCBA9876543210'.
	self assert: (1972313422155189164466189 radix: 19) equals: 'IHGFEDCBA9876543210'.
	self assert: 1972313422155189164466189 printStringHex equals: '1A1A75329C5C6FC00600D'.
	self assert: (1972313422155189164466189 storeStringBase: 19) equals: '19rIHGFEDCBA9876543210'.
	self assert: 1972313422155189164466189 storeStringHex equals: '16r1A1A75329C5C6FC00600D'.
	self assert: (104567135734072022160664820 printStringBase: 20) equals: 'JIHGFEDCBA9876543210'.
	self assert: (104567135734072022160664820 radix: 20) equals: 'JIHGFEDCBA9876543210'.
	self assert: 104567135734072022160664820 printStringHex equals: '567EF3C9636D242A8C68F4'.
	self assert: (104567135734072022160664820 storeStringBase: 20) equals: '20rJIHGFEDCBA9876543210'.
	self assert: 104567135734072022160664820 storeStringHex equals: '16r567EF3C9636D242A8C68F4'.
	self assert: (5827980550840017565077671610 printStringBase: 21) equals: 'KJIHGFEDCBA9876543210'.
	self assert: (5827980550840017565077671610 radix: 21) equals: 'KJIHGFEDCBA9876543210'.
	self assert: 5827980550840017565077671610 printStringHex equals: '12D4CAE2B8A09BCFDBE30EBA'.
	self assert: (5827980550840017565077671610 storeStringBase: 21) equals: '21rKJIHGFEDCBA9876543210'.
	self assert: 5827980550840017565077671610 storeStringHex equals: '16r12D4CAE2B8A09BCFDBE30EBA'.
	self assert: (340653664490377789692799452102 printStringBase: 22) equals: 'LKJIHGFEDCBA9876543210'.
	self assert: (340653664490377789692799452102 radix: 22) equals: 'LKJIHGFEDCBA9876543210'.
	self assert: 340653664490377789692799452102 printStringHex equals: '44CB61B5B47E1A5D8F88583C6'.
	self assert: (340653664490377789692799452102 storeStringBase: 22) equals: '22rLKJIHGFEDCBA9876543210'.
	self assert: 340653664490377789692799452102 storeStringHex equals: '16r44CB61B5B47E1A5D8F88583C6'.
	self assert: (20837326537038308910317109288851 printStringBase: 23) equals: 'MLKJIHGFEDCBA9876543210'.
	self assert: (20837326537038308910317109288851 radix: 23) equals: 'MLKJIHGFEDCBA9876543210'.
	self assert: 20837326537038308910317109288851 printStringHex equals: '1070108876456E0EF115B389F93'.
	self assert: (20837326537038308910317109288851 storeStringBase: 23) equals: '23rMLKJIHGFEDCBA9876543210'.
	self assert: 20837326537038308910317109288851 storeStringHex equals: '16r1070108876456E0EF115B389F93'.
	self assert: (1331214537196502869015340298036888 printStringBase: 24) equals: 'NMLKJIHGFEDCBA9876543210'.
	self assert: (1331214537196502869015340298036888 radix: 24) equals: 'NMLKJIHGFEDCBA9876543210'.
	self assert: 1331214537196502869015340298036888 printStringHex equals: '41A24A285154B026B6ED206C6698'.
	self assert: (1331214537196502869015340298036888 storeStringBase: 24) equals: '24rNMLKJIHGFEDCBA9876543210'.
	self assert: 1331214537196502869015340298036888 storeStringHex equals: '16r41A24A285154B026B6ED206C6698'.
	self assert: (88663644327703473714387251271141900 printStringBase: 25) equals: 'ONMLKJIHGFEDCBA9876543210'.
	self assert: (88663644327703473714387251271141900 radix: 25) equals: 'ONMLKJIHGFEDCBA9876543210'.
	self assert: 88663644327703473714387251271141900 printStringHex equals: '111374860A2C6CEBE5999630398A0C'.
	self assert: (88663644327703473714387251271141900 storeStringBase: 25) equals: '25rONMLKJIHGFEDCBA9876543210'.
	self assert: 88663644327703473714387251271141900 storeStringHex equals: '16r111374860A2C6CEBE5999630398A0C'.
	self assert: (6146269788878825859099399609538763450 printStringBase: 26) equals: 'PONMLKJIHGFEDCBA9876543210'.
	self assert: (6146269788878825859099399609538763450 radix: 26) equals: 'PONMLKJIHGFEDCBA9876543210'.
	self assert: 6146269788878825859099399609538763450 printStringHex equals: '49FBA7F30B0F48BD14E6A99BD8ADABA'.
	self assert: (6146269788878825859099399609538763450 storeStringBase: 26) equals: '26rPONMLKJIHGFEDCBA9876543210'.
	self assert: 6146269788878825859099399609538763450 storeStringHex equals: '16r49FBA7F30B0F48BD14E6A99BD8ADABA'.
	self assert: (442770531899482980347734468443677777577 printStringBase: 27) equals: 'QPONMLKJIHGFEDCBA9876543210'.
	self assert: (442770531899482980347734468443677777577 radix: 27) equals: 'QPONMLKJIHGFEDCBA9876543210'.
	self assert: 442770531899482980347734468443677777577 printStringHex equals: '14D1A80A997343640C1145A073731DEA9'.
	self assert: (442770531899482980347734468443677777577 storeStringBase: 27) equals: '27rQPONMLKJIHGFEDCBA9876543210'.
	self assert: 442770531899482980347734468443677777577 storeStringHex equals: '16r14D1A80A997343640C1145A073731DEA9'.
	self assert: (33100056003358651440264672384704297711484 printStringBase: 28) equals: 'RQPONMLKJIHGFEDCBA9876543210'.
	self assert: (33100056003358651440264672384704297711484 radix: 28) equals: 'RQPONMLKJIHGFEDCBA9876543210'.
	self assert: 33100056003358651440264672384704297711484 printStringHex equals: '6145B6E6DACFA25D0E936F51D25932377C'.
	self assert: (33100056003358651440264672384704297711484 storeStringBase: 28) equals: '28rRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 33100056003358651440264672384704297711484 storeStringHex equals: '16r6145B6E6DACFA25D0E936F51D25932377C'.
	self assert: (2564411043271974895869785066497940850811934 printStringBase: 29) equals: 'SRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (2564411043271974895869785066497940850811934 radix: 29) equals: 'SRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 2564411043271974895869785066497940850811934 printStringHex equals: '1D702071CBA4A1597D4DD37E95EFAC79241E'.
	self assert: (2564411043271974895869785066497940850811934 storeStringBase: 29) equals: '29rSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 2564411043271974895869785066497940850811934 storeStringHex equals: '16r1D702071CBA4A1597D4DD37E95EFAC79241E'.
	self assert: (205646315052919334126040428061831153388822830 printStringBase: 30) equals: 'TSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (205646315052919334126040428061831153388822830 radix: 30) equals: 'TSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 205646315052919334126040428061831153388822830 printStringHex equals: '938B4343B54B550989989D02998718FFB212E'.
	self assert: (205646315052919334126040428061831153388822830 storeStringBase: 30) equals: '30rTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 205646315052919334126040428061831153388822830 storeStringHex equals: '16r938B4343B54B550989989D02998718FFB212E'.
	self assert: (17050208381689099029767742314582582184093573615 printStringBase: 31) equals: 'UTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (17050208381689099029767742314582582184093573615 radix: 31) equals: 'UTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 17050208381689099029767742314582582184093573615 printStringHex equals: '2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
	self assert: (17050208381689099029767742314582582184093573615 storeStringBase: 31) equals: '31rUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 17050208381689099029767742314582582184093573615 storeStringHex equals: '16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
	self assert: (1459980823972598128486511383358617792788444579872 printStringBase: 32) equals: 'VUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (1459980823972598128486511383358617792788444579872 radix: 32) equals: 'VUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 1459980823972598128486511383358617792788444579872 printStringHex equals: 'FFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
	self assert: (1459980823972598128486511383358617792788444579872 storeStringBase: 32) equals: '32rVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 1459980823972598128486511383358617792788444579872 storeStringHex equals: '16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
	self assert: (128983956064237823710866404905431464703849549412368 printStringBase: 33) equals: 'WVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (128983956064237823710866404905431464703849549412368 radix: 33) equals: 'WVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 128983956064237823710866404905431464703849549412368 printStringHex equals: '584120A0328DE272AB055A8AA003CE4A559F223810'.
	self assert: (128983956064237823710866404905431464703849549412368 storeStringBase: 33) equals: '33rWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 128983956064237823710866404905431464703849549412368 storeStringHex equals: '16r584120A0328DE272AB055A8AA003CE4A559F223810'.
	self assert: (11745843093701610854378775891116314824081102660800418 printStringBase: 34) equals: 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (11745843093701610854378775891116314824081102660800418 radix: 34) equals: 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 11745843093701610854378775891116314824081102660800418 printStringHex equals: '1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
	self assert: (11745843093701610854378775891116314824081102660800418 storeStringBase: 34) equals: '34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 11745843093701610854378775891116314824081102660800418 storeStringHex equals: '16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
	self assert: (1101553773143634726491620528194292510495517905608180485 printStringBase: 35) equals: 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (1101553773143634726491620528194292510495517905608180485 radix: 35) equals: 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 1101553773143634726491620528194292510495517905608180485 printStringHex equals: 'B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
	self assert: (1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) equals: '35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 1101553773143634726491620528194292510495517905608180485 storeStringHex equals: '16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
	self assert: (106300512100105327644605138221229898724869759421181854980 printStringBase: 36) equals: 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (106300512100105327644605138221229898724869759421181854980 radix: 36) equals: 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 106300512100105327644605138221229898724869759421181854980 printStringHex equals: '455D441E55A37239AB4C303189576071AF5578FFCA80504'.
	self assert: (106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) equals: '36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 106300512100105327644605138221229898724869759421181854980 storeStringHex equals: '16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testBadBase
	"This used to get into an endless loop.
	See Pharo #114"
	
	self should: [2 printStringBase: 1] raise: Error.! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testNegativeIntegerPrinting
 

	self assert: (-2 printStringBase: 2) equals: '-10'.
	self assert: (-2 radix: 2) equals: '-10'.
	self assert: -2 printStringHex equals: '-2'.
	self assert: (-2 storeStringBase: 2) equals: '-2r10'.
	self assert: -2 storeStringHex equals: '-16r2'.
	self assert: (-21 printStringBase: 3) equals: '-210'.
	self assert: (-21 radix: 3) equals: '-210'.
	self assert: -21 printStringHex equals: '-15'.
	self assert: (-21 storeStringBase: 3) equals: '-3r210'.
	self assert: -21 storeStringHex equals: '-16r15'.
	self assert: (-228 printStringBase: 4) equals: '-3210'.
	self assert: (-228 radix: 4) equals: '-3210'.
	self assert: -228 printStringHex equals: '-E4'.
	self assert: (-228 storeStringBase: 4) equals: '-4r3210'.
	self assert: -228 storeStringHex equals: '-16rE4'.
	self assert: (-2930 printStringBase: 5) equals: '-43210'.
	self assert: (-2930 radix: 5) equals: '-43210'.
	self assert: -2930 printStringHex equals: '-B72'.
	self assert: (-2930 storeStringBase: 5) equals: '-5r43210'.
	self assert: -2930 storeStringHex equals: '-16rB72'.
	self assert: (-44790 printStringBase: 6) equals: '-543210'.
	self assert: (-44790 radix: 6) equals: '-543210'.
	self assert: -44790 printStringHex equals: '-AEF6'.
	self assert: (-44790 storeStringBase: 6) equals: '-6r543210'.
	self assert: -44790 storeStringHex equals: '-16rAEF6'.
	self assert: (-800667 printStringBase: 7) equals: '-6543210'.
	self assert: (-800667 radix: 7) equals: '-6543210'.
	self assert: -800667 printStringHex equals: '-C379B'.
	self assert: (-800667 storeStringBase: 7) equals: '-7r6543210'.
	self assert: -800667 storeStringHex equals: '-16rC379B'.
	self assert: (-16434824 printStringBase: 8) equals: '-76543210'.
	self assert: (-16434824 radix: 8) equals: '-76543210'.
	self assert: -16434824 printStringHex equals: '-FAC688'.
	self assert: (-16434824 storeStringBase: 8) equals: '-8r76543210'.
	self assert: -16434824 storeStringHex equals: '-16rFAC688'.
	self assert: (-381367044 printStringBase: 9) equals: '-876543210'.
	self assert: (-381367044 radix: 9) equals: '-876543210'.
	self assert: -381367044 printStringHex equals: '-16BB3304'.
	self assert: (-381367044 storeStringBase: 9) equals: '-9r876543210'.
	self assert: -381367044 storeStringHex equals: '-16r16BB3304'.
	self assert: (-9876543210 printStringBase: 10) equals: '-9876543210'.
	self assert: (-9876543210 radix: 10) equals: '-9876543210'.
	self assert: -9876543210 printStringHex equals: '-24CB016EA'.
	self assert: (-9876543210 storeStringBase: 10) equals: '-9876543210'.
	self assert: -9876543210 storeStringHex equals: '-16r24CB016EA'.
	self assert: (-282458553905 printStringBase: 11) equals: '-A9876543210'.
	self assert: (-282458553905 radix: 11) equals: '-A9876543210'.
	self assert: -282458553905 printStringHex equals: '-41C3D77E31'.
	self assert: (-282458553905 storeStringBase: 11) equals: '-11rA9876543210'.
	self assert: -282458553905 storeStringHex equals: '-16r41C3D77E31'.
	self assert: (-8842413667692 printStringBase: 12) equals: '-BA9876543210'.
	self assert: (-8842413667692 radix: 12) equals: '-BA9876543210'.
	self assert: -8842413667692 printStringHex equals: '-80AC8ECF56C'.
	self assert: (-8842413667692 storeStringBase: 12) equals: '-12rBA9876543210'.
	self assert: -8842413667692 storeStringHex equals: '-16r80AC8ECF56C'.
	self assert: (-300771807240918 printStringBase: 13) equals: '-CBA9876543210'.
	self assert: (-300771807240918 radix: 13) equals: '-CBA9876543210'.
	self assert: -300771807240918 printStringHex equals: '-1118CE4BAA2D6'.
	self assert: (-300771807240918 storeStringBase: 13) equals: '-13rCBA9876543210'.
	self assert: -300771807240918 storeStringHex equals: '-16r1118CE4BAA2D6'.
	self assert: (-11046255305880158 printStringBase: 14) equals: '-DCBA9876543210'.
	self assert: (-11046255305880158 radix: 14) equals: '-DCBA9876543210'.
	self assert: -11046255305880158 printStringHex equals: '-273E82BB9AF25E'.
	self assert: (-11046255305880158 storeStringBase: 14) equals: '-14rDCBA9876543210'.
	self assert: -11046255305880158 storeStringHex equals: '-16r273E82BB9AF25E'.
	self assert: (-435659737878916215 printStringBase: 15) equals: '-EDCBA9876543210'.
	self assert: (-435659737878916215 radix: 15) equals: '-EDCBA9876543210'.
	self assert: -435659737878916215 printStringHex equals: '-60BC6392F366C77'.
	self assert: (-435659737878916215 storeStringBase: 15) equals: '-15rEDCBA9876543210'.
	self assert: -435659737878916215 storeStringHex equals: '-16r60BC6392F366C77'.
	self assert: (-18364758544493064720 printStringBase: 16) equals: '-FEDCBA9876543210'.
	self assert: (-18364758544493064720 radix: 16) equals: '-FEDCBA9876543210'.
	self assert: -18364758544493064720 printStringHex equals: '-FEDCBA9876543210'.
	self assert: (-18364758544493064720 storeStringBase: 16) equals: '-16rFEDCBA9876543210'.
	self assert: -18364758544493064720 storeStringHex equals: '-16rFEDCBA9876543210'.
	self assert: (-824008854613343261192 printStringBase: 17) equals: '-GFEDCBA9876543210'.
	self assert: (-824008854613343261192 radix: 17) equals: '-GFEDCBA9876543210'.
	self assert: -824008854613343261192 printStringHex equals: '-2CAB6B877C1CD2D208'.
	self assert: (-824008854613343261192 storeStringBase: 17) equals: '-17rGFEDCBA9876543210'.
	self assert: -824008854613343261192 storeStringHex equals: '-16r2CAB6B877C1CD2D208'.
	self assert: (-39210261334551566857170 printStringBase: 18) equals: '-HGFEDCBA9876543210'.
	self assert: (-39210261334551566857170 radix: 18) equals: '-HGFEDCBA9876543210'.
	self assert: -39210261334551566857170 printStringHex equals: '-84D97AFCAE81415B3D2'.
	self assert: (-39210261334551566857170 storeStringBase: 18) equals: '-18rHGFEDCBA9876543210'.
	self assert: -39210261334551566857170 storeStringHex equals: '-16r84D97AFCAE81415B3D2'.
	self assert: (-1972313422155189164466189 printStringBase: 19) equals: '-IHGFEDCBA9876543210'.
	self assert: (-1972313422155189164466189 radix: 19) equals: '-IHGFEDCBA9876543210'.
	self assert: -1972313422155189164466189 printStringHex equals: '-1A1A75329C5C6FC00600D'.
	self assert: (-1972313422155189164466189 storeStringBase: 19) equals: '-19rIHGFEDCBA9876543210'.
	self assert: -1972313422155189164466189 storeStringHex equals: '-16r1A1A75329C5C6FC00600D'.
	self assert: (-104567135734072022160664820 printStringBase: 20) equals: '-JIHGFEDCBA9876543210'.
	self assert: (-104567135734072022160664820 radix: 20) equals: '-JIHGFEDCBA9876543210'.
	self assert: -104567135734072022160664820 printStringHex equals: '-567EF3C9636D242A8C68F4'.
	self assert: (-104567135734072022160664820 storeStringBase: 20) equals: '-20rJIHGFEDCBA9876543210'.
	self assert: -104567135734072022160664820 storeStringHex equals: '-16r567EF3C9636D242A8C68F4'.
	self assert: (-5827980550840017565077671610 printStringBase: 21) equals: '-KJIHGFEDCBA9876543210'.
	self assert: (-5827980550840017565077671610 radix: 21) equals: '-KJIHGFEDCBA9876543210'.
	self assert: -5827980550840017565077671610 printStringHex equals: '-12D4CAE2B8A09BCFDBE30EBA'.
	self assert: (-5827980550840017565077671610 storeStringBase: 21) equals: '-21rKJIHGFEDCBA9876543210'.
	self assert: -5827980550840017565077671610 storeStringHex equals: '-16r12D4CAE2B8A09BCFDBE30EBA'.
	self assert: (-340653664490377789692799452102 printStringBase: 22) equals: '-LKJIHGFEDCBA9876543210'.
	self assert: (-340653664490377789692799452102 radix: 22) equals: '-LKJIHGFEDCBA9876543210'.
	self assert: -340653664490377789692799452102 printStringHex equals: '-44CB61B5B47E1A5D8F88583C6'.
	self assert: (-340653664490377789692799452102 storeStringBase: 22) equals: '-22rLKJIHGFEDCBA9876543210'.
	self assert: -340653664490377789692799452102 storeStringHex equals: '-16r44CB61B5B47E1A5D8F88583C6'.
	self assert: (-20837326537038308910317109288851 printStringBase: 23) equals: '-MLKJIHGFEDCBA9876543210'.
	self assert: (-20837326537038308910317109288851 radix: 23) equals: '-MLKJIHGFEDCBA9876543210'.
	self assert: -20837326537038308910317109288851 printStringHex equals: '-1070108876456E0EF115B389F93'.
	self assert: (-20837326537038308910317109288851 storeStringBase: 23) equals: '-23rMLKJIHGFEDCBA9876543210'.
	self assert: -20837326537038308910317109288851 storeStringHex equals: '-16r1070108876456E0EF115B389F93'.
	self assert: (-1331214537196502869015340298036888 printStringBase: 24) equals: '-NMLKJIHGFEDCBA9876543210'.
	self assert: (-1331214537196502869015340298036888 radix: 24) equals: '-NMLKJIHGFEDCBA9876543210'.
	self assert: -1331214537196502869015340298036888 printStringHex equals: '-41A24A285154B026B6ED206C6698'.
	self assert: (-1331214537196502869015340298036888 storeStringBase: 24) equals: '-24rNMLKJIHGFEDCBA9876543210'.
	self assert: -1331214537196502869015340298036888 storeStringHex equals: '-16r41A24A285154B026B6ED206C6698'.
	self assert: (-88663644327703473714387251271141900 printStringBase: 25) equals: '-ONMLKJIHGFEDCBA9876543210'.
	self assert: (-88663644327703473714387251271141900 radix: 25) equals: '-ONMLKJIHGFEDCBA9876543210'.
	self assert: -88663644327703473714387251271141900 printStringHex equals: '-111374860A2C6CEBE5999630398A0C'.
	self assert: (-88663644327703473714387251271141900 storeStringBase: 25) equals: '-25rONMLKJIHGFEDCBA9876543210'.
	self assert: -88663644327703473714387251271141900 storeStringHex equals: '-16r111374860A2C6CEBE5999630398A0C'.
	self assert: (-6146269788878825859099399609538763450 printStringBase: 26) equals: '-PONMLKJIHGFEDCBA9876543210'.
	self assert: (-6146269788878825859099399609538763450 radix: 26) equals: '-PONMLKJIHGFEDCBA9876543210'.
	self assert: -6146269788878825859099399609538763450 printStringHex equals: '-49FBA7F30B0F48BD14E6A99BD8ADABA'.
	self assert: (-6146269788878825859099399609538763450 storeStringBase: 26) equals: '-26rPONMLKJIHGFEDCBA9876543210'.
	self assert: -6146269788878825859099399609538763450 storeStringHex equals: '-16r49FBA7F30B0F48BD14E6A99BD8ADABA'.
	self assert: (-442770531899482980347734468443677777577 printStringBase: 27) equals: '-QPONMLKJIHGFEDCBA9876543210'.
	self assert: (-442770531899482980347734468443677777577 radix: 27) equals: '-QPONMLKJIHGFEDCBA9876543210'.
	self assert: -442770531899482980347734468443677777577 printStringHex equals: '-14D1A80A997343640C1145A073731DEA9'.
	self assert: (-442770531899482980347734468443677777577 storeStringBase: 27) equals: '-27rQPONMLKJIHGFEDCBA9876543210'.
	self assert: -442770531899482980347734468443677777577 storeStringHex equals: '-16r14D1A80A997343640C1145A073731DEA9'.
	self assert: (-33100056003358651440264672384704297711484 printStringBase: 28) equals: '-RQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-33100056003358651440264672384704297711484 radix: 28) equals: '-RQPONMLKJIHGFEDCBA9876543210'.
	self assert: -33100056003358651440264672384704297711484 printStringHex equals: '-6145B6E6DACFA25D0E936F51D25932377C'.
	self assert: (-33100056003358651440264672384704297711484 storeStringBase: 28) equals: '-28rRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -33100056003358651440264672384704297711484 storeStringHex equals: '-16r6145B6E6DACFA25D0E936F51D25932377C'.
	self assert: (-2564411043271974895869785066497940850811934 printStringBase: 29) equals: '-SRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-2564411043271974895869785066497940850811934 radix: 29) equals: '-SRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -2564411043271974895869785066497940850811934 printStringHex equals: '-1D702071CBA4A1597D4DD37E95EFAC79241E'.
	self assert: (-2564411043271974895869785066497940850811934 storeStringBase: 29) equals: '-29rSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -2564411043271974895869785066497940850811934 storeStringHex equals: '-16r1D702071CBA4A1597D4DD37E95EFAC79241E'.
	self assert: (-205646315052919334126040428061831153388822830 printStringBase: 30) equals: '-TSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-205646315052919334126040428061831153388822830 radix: 30) equals: '-TSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -205646315052919334126040428061831153388822830 printStringHex equals: '-938B4343B54B550989989D02998718FFB212E'.
	self assert: (-205646315052919334126040428061831153388822830 storeStringBase: 30) equals: '-30rTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -205646315052919334126040428061831153388822830 storeStringHex equals: '-16r938B4343B54B550989989D02998718FFB212E'.
	self assert: (-17050208381689099029767742314582582184093573615 printStringBase: 31) equals: '-UTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-17050208381689099029767742314582582184093573615 radix: 31) equals: '-UTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -17050208381689099029767742314582582184093573615 printStringHex equals: '-2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
	self assert: (-17050208381689099029767742314582582184093573615 storeStringBase: 31) equals: '-31rUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -17050208381689099029767742314582582184093573615 storeStringHex equals: '-16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
	self assert: (-1459980823972598128486511383358617792788444579872 printStringBase: 32) equals: '-VUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-1459980823972598128486511383358617792788444579872 radix: 32) equals: '-VUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -1459980823972598128486511383358617792788444579872 printStringHex equals: '-FFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
	self assert: (-1459980823972598128486511383358617792788444579872 storeStringBase: 32) equals: '-32rVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -1459980823972598128486511383358617792788444579872 storeStringHex equals: '-16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
	self assert: (-128983956064237823710866404905431464703849549412368 printStringBase: 33) equals: '-WVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-128983956064237823710866404905431464703849549412368 radix: 33) equals: '-WVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -128983956064237823710866404905431464703849549412368 printStringHex equals: '-584120A0328DE272AB055A8AA003CE4A559F223810'.
	self assert: (-128983956064237823710866404905431464703849549412368 storeStringBase: 33) equals: '-33rWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -128983956064237823710866404905431464703849549412368 storeStringHex equals: '-16r584120A0328DE272AB055A8AA003CE4A559F223810'.
	self assert: (-11745843093701610854378775891116314824081102660800418 printStringBase: 34) equals: '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-11745843093701610854378775891116314824081102660800418 radix: 34) equals: '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -11745843093701610854378775891116314824081102660800418 printStringHex equals: '-1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
	self assert: (-11745843093701610854378775891116314824081102660800418 storeStringBase: 34) equals: '-34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -11745843093701610854378775891116314824081102660800418 storeStringHex equals: '-16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
	self assert: (-1101553773143634726491620528194292510495517905608180485 printStringBase: 35) equals: '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-1101553773143634726491620528194292510495517905608180485 radix: 35) equals: '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -1101553773143634726491620528194292510495517905608180485 printStringHex equals: '-B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
	self assert: (-1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) equals: '-35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -1101553773143634726491620528194292510495517905608180485 storeStringHex equals: '-16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
	self assert: (-106300512100105327644605138221229898724869759421181854980 printStringBase: 36) equals: '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-106300512100105327644605138221229898724869759421181854980 radix: 36) equals: '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -106300512100105327644605138221229898724869759421181854980 printStringHex equals: '-455D441E55A37239AB4C303189576071AF5578FFCA80504'.
	self assert: (-106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) equals: '-36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -106300512100105327644605138221229898724869759421181854980 storeStringHex equals: '-16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.! !

!IntegerTest methodsFor: 'tests - basic' stamp: ''!
testAsSmallerPowerOfTwo
"Invalid input testing"
	"LargeNegativeIntegers"
	self should: [(2 raisedTo: 80) negated asSmallerPowerOfTwo] raise: DomainError.
	"Negative SmallIntegers"
	self should: [-1 asSmallerPowerOfTwo] raise: DomainError.
	"0"
	self should: [0 asSmallerPowerOfTwo] raise: DomainError.
"Valid inputs"
	"Small integers"
	self assert: 1 asSmallerPowerOfTwo equals: 1.
	self assert: 2 asSmallerPowerOfTwo equals: 2.
	self assert: 3 asSmallerPowerOfTwo equals: 2.
	self assert: 4 asSmallerPowerOfTwo equals: 4.
	self assert: 5 asSmallerPowerOfTwo equals: 4.
	"Large integers"
	self assert: ((2 raisedTo: 80) +1) asSmallerPowerOfTwo equals: (2 raisedTo: 80).
	self assert: (2 raisedTo: 80) asSmallerPowerOfTwo equals: (2 raisedTo: 80).
	self assert: ((2 raisedTo: 80) - 1) asSmallerPowerOfTwo equals: (2 raisedTo: 80 - 1)! !

!IntegerTest methodsFor: 'tests - printing' stamp: ''!
testPrintStringBase
	2 to: 32 do: [ :b | 
		1 to: 1000 // b do: [ :n | 
			| bRaisedToN |
			bRaisedToN := b raisedTo: n.
			self assert: (bRaisedToN - 1 printStringBase: b) equals: (String new: n withAll: (Character digitValue: b - 1)).
			self assert: (bRaisedToN printStringBase: b) equals: '1' , (String new: n withAll: $0).

			self assert: (bRaisedToN negated + 1 printStringBase: b) equals: '-' , (String new: n withAll: (Character digitValue: b - 1)).
			self assert: (bRaisedToN negated printStringBase: b) equals: '-1' , (String new: n withAll: $0) ] ]! !

!IntegerTest methodsFor: 'tests - other' stamp: ''!
testDigitSumOnNegative

	self assert: -1234 digitSum equals: 10! !

!IntegerTest methodsFor: 'tests - rounding' stamp: ''!
testRounding
 
	self assert: (5 round: 2) equals: 5! !

!InteractiveResolver commentStamp: ''!
I resolve origins by consulting the user. I maintain a cache of the user's responses.!
!InteractiveResolver methodsFor: 'initialization' stamp: ''!
initialize
	self flushLocalCache! !

!InteractiveResolver methodsFor: 'resolving' stamp: ''!
resolve: origin
	^ cache at: origin ifAbsent: [self unknownOrigin: origin]! !

!InteractiveResolver methodsFor: 'resolving' stamp: ''!
unknownOrigin: origin
	| reference |
	^ (next ifNotNil: [next resolve: origin]) ifNil: 
			[reference := ResolutionRequest for: origin.
			reference ifNotNil: [cache at: origin put: reference]]! !

!InteractiveResolver methodsFor: 'accessing' stamp: ''!
flushLocalCache
	cache := IdentityDictionary new! !

!InteractiveResolverTest commentStamp: ''!
SUnit tests for InteractiveResolver!
!InteractiveResolverTest methodsFor: 'tests' stamp: ''!
testCached
	[ resolver resolve: #home ]
		on: ResolutionRequest
		do: [ :req | req resume: self home ].
	self assertOriginResolves: #home! !

!InteractiveResolverTest methodsFor: 'running' stamp: ''!
createResolver
	^ InteractiveResolver new! !

!InteractiveResolverTest methodsFor: 'accessing' stamp: ''!
home
	^ FileLocator imageDirectory resolve! !

!InteractiveResolverTest methodsFor: 'tests' stamp: ''!
testNew
	[ self assertOriginResolves: #home ]
		on: ResolutionRequest
		do: [ :req | req resume: self home ]! !

!InternetConfiguration commentStamp: ''!
I read several parameters related to the default web browser network preferences, through the InternetConfigPlugin VM module.

For example, to get the default path where downloaded files should be placed:

InternetConfiguration getDownloadPath.

Seems to work only on MacOSX!
!InternetConfiguration class methodsFor: 'tests' stamp: ''!
usePassiveFTP
	"Return true if UsePassiveFTP"
	<script: 'self usePassiveFTP inspect'>

	^(self primitiveGetStringKeyedBy: 'UsePassiveFTP') = '1'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getWWWHomePage
	"Return the WWW home page url"
	"InternetConfiguration getWWWHomePage"

	^self primitiveGetStringKeyedBy: 'WWWHomePage'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getFingerHost
	"Return the default finger server"
	"InternetConfiguration getFingerHost"

	^self primitiveGetStringKeyedBy: 'FingerHost'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getNNTPHost
	"Return the NNTP server"
	"InternetConfiguration getNNTPHost"

	^self primitiveGetStringKeyedBy: 'NNTPHost'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getFTPProxyUser
	"Return the first level FTP proxy authorisation"
	"InternetConfiguration getFTPProxyUser"

	^self primitiveGetStringKeyedBy: 'FTPProxyUser'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getMailAccount
	"Return the mail account user@host.domain"
	"InternetConfiguration getMailAccount"

	^self primitiveGetStringKeyedBy: 'MailAccount'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getFTPProxyPassword
	"Return the FTP proxy password"
	"InternetConfiguration getFTPProxyPassword"

	^self primitiveGetStringKeyedBy: 'FTPProxyPassword'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getIRCHost
	"Return the Internet Relay Chat server"
	"InternetConfiguration getIRCHost"

	^self primitiveGetStringKeyedBy: 'IRCHost'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getRealName
	"Return the RealName"
	"InternetConfiguration getRealName"

	^self primitiveGetStringKeyedBy: 'RealName'! !

!InternetConfiguration class methodsFor: 'tests' stamp: ''!
useSocks
	"Return true if UseSocks"
	<script: 'self useSocks inspect'>

	^(self primitiveGetStringKeyedBy: 'UseSocks') = '1'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
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: ''!
getNewsAuthPassword
	"Return the Password for the authorised news servers"
	"InternetConfiguration getNewsAuthPassword"

	^self primitiveGetStringKeyedBy: 'NewsAuthPassword'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getLDAPServer
	"Return the LDAP server"
	"InternetConfiguration getLDAPServer"

	^self primitiveGetStringKeyedBy: 'LDAPServer'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getNTPHost
	"Return the  Network Time Protocol (NTP)"
	"InternetConfiguration getNTPHost"

	^self primitiveGetStringKeyedBy: 'NTPHost'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getSMTPHost
	"Return the SMTP server"
	"InternetConfiguration getSMTPHost"

	^self primitiveGetStringKeyedBy: 'SMTPHost'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getOrganization
	"Return the Organization"
	"InternetConfiguration getOrganization"

	^self primitiveGetStringKeyedBy: 'Organization'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getFTPHost
	"Return the FTPHost"
	"InternetConfiguration getFTPHost"

	^self primitiveGetStringKeyedBy: 'FTPHost'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getPhHost
	"Return the PhHost server"
	"InternetConfiguration getPhHost"

	^self primitiveGetStringKeyedBy: 'PhHost'! !

!InternetConfiguration class methodsFor: 'system primitives' stamp: ''!
primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName
	<primitive: 'primitiveGetMacintoshFileTypeAndCreatorFrom' module: 'InternetConfigPlugin'>
	^'********' copy! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getDownloadPath
	"Return the download path"
	"InternetConfiguration getDownloadPath"

	^self primitiveGetStringKeyedBy: 'DownLoadPath'! !

!InternetConfiguration class methodsFor: 'HTTP Proxy' stamp: ''!
configureHttpProxy

	self useHTTPProxy 
		ifTrue: [ self setHttpProxy ]
		ifFalse: [ NetworkSystemSettings useHTTPProxy: false ]! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getNewsAuthUsername
	"Return the user name for authorised news servers"
	"InternetConfiguration getNewsAuthUsername"

	^self primitiveGetStringKeyedBy: 'NewsAuthUsername'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getEmail
	"Return the  email address of user"
	"InternetConfiguration getEmail"

	^self primitiveGetStringKeyedBy: 'Email'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getSocksHost
	"Return the Socks server"
	"InternetConfiguration getSocksHost"

	^self primitiveGetStringKeyedBy: 'SocksHost'! !

!InternetConfiguration class methodsFor: 'initialization' stamp: ''!
initialize
	SessionManager default
		registerNetworkClassNamed: self name! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getTelnetHost
	"Return the TelnetHost server"
	"InternetConfiguration getTelnetHost"

	^self primitiveGetStringKeyedBy: 'TelnetHost'! !

!InternetConfiguration class methodsFor: 'system startup' stamp: ''!
startUp
	Smalltalk os configureHttpProxy! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getWhoisHost
	"Return the WhoisHost server"
	"InternetConfiguration getWhoisHost"

	^self primitiveGetStringKeyedBy: 'WhoisHost'! !

!InternetConfiguration class methodsFor: 'tests' stamp: ''!
useFTPProxy
	"Return true if UseFTPProxy"
	<script: 'self useFTPProxy inspect'>

	^(self primitiveGetStringKeyedBy: 'UseFTPProxy') = '1'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getFTPProxyHost
	"Return the FTP proxy host"
	"InternetConfiguration getFTPProxyHost"

	^self primitiveGetStringKeyedBy: 'FTPProxyHost'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getWAISGateway
	"Return the wais gateway"
	"InternetConfiguration getWAISGateway"

	^self primitiveGetStringKeyedBy: 'WAISGateway'! !

!InternetConfiguration class methodsFor: 'system primitives' stamp: ''!
primitiveGetStringKeyedBy: aKey
	<primitive: 'primitiveGetStringKeyedBy' module: 'InternetConfigPlugin'>
	^String new.! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getGopherProxy
	"Return the  Gopher proxy"
	"InternetConfiguration getGopherProxy"

	^self primitiveGetStringKeyedBy: 'GopherProxy'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getNoProxyDomains
	"Return a comma seperated string of domains not to proxy"
	"InternetConfiguration getNoProxyDomains"

	^self primitiveGetStringKeyedBy: 'NoProxyDomains'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getHTTPProxyHost
	"Return the http proxy for this client."
	"InternetConfiguration getHTTPProxyHost"

	^self primitiveGetStringKeyedBy: 'HTTPProxyHost'! !

!InternetConfiguration class methodsFor: 'HTTP Proxy' stamp: ''!
setHttpProxy

	(self getHTTPProxyHost findTokens: ':') ifNotEmpty: [ :p |
		NetworkSystemSettings
			httpProxyServer: p first;
			httpProxyPort: p second asInteger;
			useHTTPProxy: true ]! !

!InternetConfiguration class methodsFor: 'system startup' stamp: ''!
shutDown
	Smalltalk os isMacOS
		ifTrue: [ NetworkSystemSettings useHTTPProxy: false ]! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getGopherHost
	"Return the default Gopher server"
	"InternetConfiguration getGopherHost"

	^self primitiveGetStringKeyedBy: 'GopherHost'! !

!InternetConfiguration class methodsFor: 'tests' stamp: ''!
useHTTPProxy
	"Return true if UseHTTPProxy"
	<script: 'self useHTTPProxy inspect'>
	
	^(self primitiveGetStringKeyedBy: 'UseHTTPProxy') = '1'! !

!InternetConfiguration class methodsFor: 'tests' stamp: ''!
useGopherProxy
	"Return true if UseGopherProxy"
	<script: 'self useGopherProxy inspect'>

	^(self primitiveGetStringKeyedBy: 'UseGopherProxy') = '1'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getArchiePreferred
	"Return the preferred Archie server"
	"InternetConfiguration getArchiePreferred"

	^self primitiveGetStringKeyedBy: 'ArchiePreferred'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getMailPassword 
	"Return the mail account Password "
	"InternetConfiguration getMailPassword "

	^self primitiveGetStringKeyedBy: 'MailPassword'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getFTPProxyAccount
	"Return the second level FTP proxy authorisation"
	"InternetConfiguration getFTPProxyAccount"

	^self primitiveGetStringKeyedBy: 'FTPProxyAccount'! !

!InternetConfiguration class methodsFor: 'lookups' stamp: ''!
getLDAPSearchbase
	"Return the LDAP thing"
	"InternetConfiguration getLDAPSearchbase"

	^self primitiveGetStringKeyedBy: 'LDAPSearchbase'! !

!InterpolatedGradientFillStyle commentStamp: ''!
Gradient fill style that uses proper alpha-aware interpolation.!
!InterpolatedGradientFillStyle methodsFor: 'private' stamp: ''!
computePixelRampOfSize: length
	"Compute the pixel ramp in the receiver."
	
	| bits ramp lastColor lastIndex lastWord |
	ramp := colorRamp asSortedCollection:[:a1 :a2| a1 key < a2 key].
	bits := Bitmap new: length.
	lastColor := ramp first value.
	lastWord := self pixelWord32Of: lastColor .
	lastIndex := 0.
	ramp do:[:assoc| | distance nextColor theta nextWord nextIndex step |
		nextIndex := (assoc key * length) rounded.
		nextColor := assoc value.
		nextWord := nextColor pixelWord32.
		distance := nextIndex - lastIndex.
		distance = 0 ifTrue: [distance := 1].
		step := 1.0 / distance.
		theta := 0.0.
		lastIndex+1 to: nextIndex do: [:i|
			theta := theta + step.
			bits at: i put: (self interpolatedAlphaMix: theta of: lastWord and: nextWord)].
		lastIndex := nextIndex.
		lastColor := nextColor.
		lastWord := nextWord].
	lastIndex+1 to: length do: [:i| bits at: i put: lastWord].
	^bits! !

!InterpolatedGradientFillStyle methodsFor: 'private' stamp: ''!
pixelWord32Of: aColor 
	"Returns an integer representing the bits that appear in a single pixel of this color in a Form of depth 32.
	Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue.
	Just a little quicker if we are dealing with RGBA colors at 32 bit depth."
	| val rgb |
	rgb := aColor privateRGB .
	"eight bits per component; top 8 bits set to all ones (opaque alpha)"
	val := LargePositiveInteger new: 4.
	val at: 3 put: ((rgb bitShift: -22) bitAnd: 16rFF).
	val at: 2 put: ((rgb bitShift: -12) bitAnd: 16rFF).
	val at: 1 put: ((rgb bitShift: -2) bitAnd: 16rFF).
	val = 0 ifTrue: [val at: 1 put: 1].  "closest non-transparent black"
	val at: 4 put: self alpha.  "opaque alpha"
	^val! !

!InterpolatedGradientFillStyle methodsFor: 'private' stamp: ''!
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)! !

!Interval commentStamp: ''!
I represent a finite arithmetic progression (a range of number).

Description
--------------------------

I allow to iterate easily on a range of number (for example to manupulate an index) with a define step (by default one by one).

Zero step size is not allowed and will raise an error.

I know at which number I begin, at which number I end and the step.

I work with the Number class. I manipulate some numbers and I can be created from a Number.  

Public API and Key Messages
--------------------------

- I implement most of the classic Iterators as #do: or #collect:.

- #from: to: and #from: to: by:  are my two common contructors. But I am usually created by a message send on Number  (See examples).

Examples 
--------------------------

To create an Interval from 1 to 100 there is many ways:

	Interval from: 1 to: 100
	or
	Interval from: 1 to: 100 by: 1
	
	or from a Number 
	
	1 to: 100 
	or 
	1 to: 100 by: 1
	
	You can also use floats or fractions: 
	
	0.1 to: 0.5 by: 0.01
	or
	1/10 to: 1/2 by: 1/100
	
	NB: both expressions will not give exactly the same result. The first will contains only floats and the second only fractions.
	
 
Internal Representation and Key Implementation Points.
--------------------------

    Instance Variables
	start:		<Number> 	The beginning of the Interval.
	step:		<Number> 	The end of the Interval.
	stop:		<Number> 	The step of the interval. If the step is 3 and we begin at 1 the interval will be 1, 4, 7, 10, 13… until the end.
!
!Interval methodsFor: 'accessing' stamp: 'nil'!
sum
	"Optimized version. Use the sum(n * i - k, i=a..b) = -1/2 * (a - b - 1) * (n * (a + b) - 2 * k) equation with a = 1, n = step, b = self size and k = step - start."

	| b |
	b := self size.
	^b * ((b - 1) * step + (start * 2)) / 2! !

!Interval methodsFor: 'comparing' stamp: 'nil'!
= 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: 'adding' stamp: 'nil'!
add: newObject 
	"Adding to an Interval is not allowed."

	self shouldNotImplement! !

!Interval methodsFor: 'comparing' stamp: 'nil'!
hash
	"Hash is reimplemented because = is implemented."

	^(((start hash bitShift: 2)
		bitOr: stop hash)
		bitShift: 1)
		bitOr: self size! !

!Interval methodsFor: 'testing' stamp: 'nil'!
rangeIncludes: aNumber
	"Return true if aNumber lies anywhere between the interval bounds.
	This is a fast O(1) bounds check.
	
	Beware: because #rangeIncludes: only considers the sign of the step, not its magnitude, it also returns true for values that are not actual elements of the interval.
	For precise element inclusion with arbitrary step, use #includes:."

	^ step >= 0
		ifTrue: [ aNumber between: start and: stop ]
		ifFalse: [ aNumber between: stop and: start ]! !

!Interval methodsFor: 'private' stamp: 'nil'!
species

	^Array! !

!Interval methodsFor: 'enumerating' stamp: 'nil'!
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: 'private' stamp: 'nil'!
setFrom: startInteger to: stopInteger by: stepInteger

	start := startInteger.
	stop := stopInteger.
	step := stepInteger.
	step isZero ifTrue: [ ^ DomainError signal: 'Zero size steps not allowed' ]! !

!Interval methodsFor: 'accessing' stamp: 'nil'!
increment
	"Answer the receiver's interval increment."

	^step! !

!Interval methodsFor: 'sorting' stamp: 'nil'!
sort: aBlock
	"What sorting an Interval means is not clear."

	self shouldNotImplement.! !

!Interval methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	aStream nextPut: $(;
	 print: start;
	 nextPutAll: ' to: ';
	 print: stop.
	step ~= 1 ifTrue: [aStream nextPutAll: ' by: '; print: step].
	aStream nextPut: $)! !

!Interval methodsFor: 'self evaluating' stamp: 'nil'!
isSelfEvaluating
	^ self class == Interval! !

!Interval methodsFor: 'copying' stamp: 'nil'!
shuffled
	"Return an array that contains my elements shuffled in a random order"
	^ self asArray shuffle! !

!Interval methodsFor: 'accessing' stamp: 'nil'!
at: anInteger
	"Answer the anInteger'th element."

	(anInteger between: 1 and: self size)
		ifTrue: [ ^ start + (step * (anInteger - 1)) ]
		ifFalse: [ self errorSubscriptBounds: anInteger ]! !

!Interval methodsFor: 'accessing' stamp: 'nil'!
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 |
	(anElement isNumber and:[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: 'enumerating' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
first 
	"Refer to the comment in SequenceableCollection|first."

	^start! !

!Interval methodsFor: 'accessing' stamp: 'nil'!
last 
	"Refer to the comment in SequenceableCollection|last."

	^stop - (stop - start \\ step)! !

!Interval methodsFor: 'removing' stamp: 'nil'!
remove: newObject 
	"Removing from an Interval is not allowed."

	self error: 'elements cannot be removed from an Interval'! !

!Interval methodsFor: 'sorting' stamp: 'nil'!
sorted
	^ self increment >= 0
		ifTrue: [ self copy ]
		ifFalse: [ self last to: self first by: self increment negated ]! !

!Interval methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"Overwritten to get back the standard object behavior"

	stonWriter writeObject: self! !

!Interval methodsFor: 'enumerating' stamp: 'nil'!
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: 'arithmetic' stamp: 'nil'!
- number

	^ start - number to: stop - number by: step! !

!Interval methodsFor: 'converting' stamp: 'nil'!
asOpenInterval
	"Return a new interval representing the open version of the receiver.
	In other words, the new inteval does not contain the upper and lower boundaries of the receiver
	"
	
	"(1 to: 10) asOpenInterval >>> (2 to: 9)"
	"(10 to: 1 by: -1) asOpenInterval >>> (9 to: 2)"

	^ start + step to: stop - step! !

!Interval methodsFor: 'testing' stamp: 'nil'!
isInterval

	^ true! !

!Interval methodsFor: 'sorting' stamp: 'nil'!
sorted: aSortBlockOrNil
	"Return a new sequenceable collection which contains the same elements as self but its elements are sorted by aSortBlockOrNil. The block should take two arguments and return true if the first element should preceed the second one. If aSortBlock is nil then <= is used for comparison. We convert the interval to an array because intervals can't be changed."
	
	^self asArray sort: aSortBlockOrNil! !

!Interval methodsFor: 'accessing' stamp: 'nil'!
at: anInteger put: anObject 
	"Storing into an Interval is not allowed."

	self error: 'you can not store into an interval'! !

!Interval methodsFor: 'accessing' stamp: 'nil'!
extent 
	"Answer the max - min of the receiver interval."
	"(10 to: 50) extent"

	^stop - start! !

!Interval methodsFor: 'accessing' stamp: 'nil'!
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: 'enumerating' stamp: 'nil'!
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: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Overwritten to get back the standard object behavior"
	
	stonReader parseNamedInstVarsFor: self! !

!Interval methodsFor: 'printing' stamp: 'nil'!
storeOn: aStream 
	aStream nextPut: $(;
	 	store: start;
	 	nextPutAll: ' to: ';
	 	store: stop.
	step ~= 1 ifTrue: [aStream nextPutAll: ' by: '; store: step].
	aStream nextPut: $)! !

!Interval methodsFor: 'arithmetic' stamp: 'nil'!
+ number

	^ start + number to: stop + number by: step! !

!Interval methodsFor: 'accessing' stamp: 'nil'!
anyOne
	"This message will fail for an empty Interval, super would not.
	(2 to: 1) anyOne should fail because empty."

	^self at: 1! !

!Interval class methodsFor: 'instance creation' stamp: 'nil'!
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."

	<primitive: 70>
	self isVariable ifTrue: [ ^ self new: 0 ].
	"space must be low"
	OutOfMemory signal.
	^ self new  "retry if user proceeds"! !

!Interval class methodsFor: 'instance creation' stamp: 'nil'!
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: 'nil'!
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: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Overwritten to get back the standard object behavior"
	
	^ self new
		fromSton: stonReader;
		yourself! !

!Interval class methodsFor: 'accessing' stamp: 'nil'!
streamSpecies
	^ Array! !

!Interval class methodsFor: 'instance creation' stamp: 'nil'!
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.
"! !

!IntervalTest commentStamp: ''!
SUnit tests for intervals!
!IntervalTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutFirst

	| result |
	result := self nonEmpty copyWithoutFirst.
	
	self assert: result size equals: (self nonEmpty size - 1).
	
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (self nonEmpty at: (i + 1))]! !

!IntervalTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne)! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collection
	^ nonEmpty! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
sizeCollection
	"Answers a collection whose #size is 4"
	^ 1 to: 4.! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedConcatenationTest
	self empty.
	self assertEmpty: self empty.
	self firstCollection.
	self secondCollection! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
oldSubCollection
	^ subCollection! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
elementInForElementAccessing
" return an element inculded in 'accessCollection '"
	^ self accessCollection anyOne! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSubcollectionAccessTest

	self moreThan3Elements.
	self assert: self moreThan3Elements size > 2! !

!IntervalTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAt

	| subcollection index collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 1.
	self assert: index equals: 1.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 2.
	self assert: index equals: 0! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirstNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index between bounds of 'nonEmpty'"
	
	^ 2! !

!IntervalTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!IntervalTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
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: 'requirements' stamp: ''!
moreThan3Elements
	" return a collection including atLeast 3 elements"
	^ nonEmpty! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDoEmpty
	| result |
	result := OrderedCollection new.
	self empty reverseDo: [ :each | result add: each ].

	self assertEmpty: result! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollect
	
	| result firstCollection secondCollection index  |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	result := firstCollection  with: secondCollection collect:
		[:a :b |
		( index := index + 1).
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals:  b.
		b].
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (secondCollection  at: i)].
	self assert: result size = secondCollection size! !

!IntervalTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
moreThan4Elements

" return a collection including at leat 4 elements"
	^ nonEmpty! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLastNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
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 - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!IntervalTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', '.
	
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString withIndexDo: 
		[:el :i |  self assert: el equals: ((self nonEmpty at:i)asString)]! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsCollect
	| index result |
	index := 0.

	result := self nonEmptyMoreThan1Element
		pairsCollect: [ :each1 :each2 | 
			self assert: (self nonEmptyMoreThan1Element indexOf: each2) equals: (index := index + 2).
			(self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1) ].

	result do: [ :each | self assert: each ]! !

!IntervalTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOf

	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element) equals: (collection indexOf: element)! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
testAtRandom

	| result |
	result := self nonEmpty atRandom.
	self assert: (self nonEmpty includes: result)! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
nonEmptyMoreThan1Element
	^nonEmpty .! !

!IntervalTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printElementsOn: aStream.
	allElementsAsString:=(result findBetweenSubstrings: ' ').
	allElementsAsString withIndexDo: 
		[:el :i | self assert: el equals: ((self nonEmpty at: i)asString) ]! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!IntervalTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!IntervalTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testEquals2
	self assert: (3 to: 5) equals: #(3 4 5).
	self deny: (3 to: 5) equals: #(3 5).
	self deny: (3 to: 5) equals: #().

	self assert: #(3 4 5) equals: (3 to: 5).
	self deny: #(3 5) equals: (3 to: 5).
	self deny: #() equals: (3 to: 5)! !

!IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringOne
	
	"self assert: self oneItemCol asCommaString = '1'.
	self assert: self oneItemCol asCommaStringAnd = '1'."

	self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString).
	self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString)! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
anotherElementNotIn
	^ 42! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
testFirstSecondThird

	self assert: self moreThan4Elements first equals: (self moreThan4Elements at: 1).
	self assert: self moreThan4Elements second equals: (self moreThan4Elements at: 2).
	self assert: self moreThan4Elements third equals: (self moreThan4Elements at: 3).
	self assert: self moreThan4Elements fourth equals: (self moreThan4Elements at: 4)! !

!IntervalTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterEmpty
	| result |
	result := self empty copyAfter: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionClass
	"Return the class to be used to create instances of the class tested"
	
	^ Interval! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureBeginsEndsWithTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self assert: self nonEmpty size > 1.
	self empty.
	self assertEmpty: self empty! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testRangeIncludes

	self assert: ((1 to: 10) rangeIncludes: 3).
	self assert: ((1 to: 10 by: 2) rangeIncludes: 3).
	self assert: ((10 to: 1 by: -2) rangeIncludes: 3).
	self assert: ((1 to: 10 by: 2) rangeIncludes: 4).
	self assert: ((1 to: 10) rangeIncludes: 3.5).
	
	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).
	self deny: ((10 to: 1) rangeIncludes: 3).
	self deny: ((10 to: 1) rangeIncludes: -3)! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
integerCollection
	^ nonEmpty! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
accessCollection
	^ -2 to: 14 by: 4! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
testAtIfAbsent

	| absent |
	absent := false.
	self moreThan4Elements 
		at: self moreThan4Elements size + 1
		ifAbsent: [ absent := true ].
	self assert: absent = true.
	absent := false.
	self moreThan4Elements 
		at: self moreThan4Elements size
		ifAbsent: [ absent := true ].
	self assert: absent = false! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
elementInCollectionOfFloat
	^ collectionOfFloat anyOne! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testAsInterval
	"This is the same as newFrom:"

	self assert: (#(1 2 3) as: Interval) equals: (1 to: 3).
	self assert: (#(33 5 -23) as: Interval) equals: (33 to: -23 by: -28).
	self assert: (#[2 4 6] as: Interval) equals: (2 to: 6 by: 2).

	self should: [#(33 5 -22) as: Interval]
		raise: Error
		description: 'This is not an arithmetic progression'! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
testMiddle

	self assert: self moreThan4Elements middle equals: (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! !

!IntervalTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
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 - converting' stamp: ''!
testAsByteArray

	| res |
	self integerCollectionWithoutEqualElements.
	self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ].
	res := true.
	self integerCollectionWithoutEqualElements
		detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
elementNotIn
	^elementNotIn! !

!IntervalTest methodsFor: 'tests - copying same contents' stamp: ''!
testReverse

	| result |
	result := self nonEmpty reversed.	
	"verify content of 'result: '"
	1 to: result size do:
		[:i | self assert: ((result at: i) 
			= (self nonEmpty at: (self nonEmpty size - i + 1)))].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
testBeforeIfAbsent

	self 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 - sorting' stamp: ''!
testIsSorted
	self assert: self sortedInAscendingOrderCollection isSorted.
	self deny: self unsortedCollection isSorted! !

!IntervalTest methodsFor: 'tests - subcollections access' stamp: ''!
testLastNElements

	| result |
	result := self moreThan3Elements last: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i + 1) ].
	self assert: result size equals: (self moreThan3Elements size - 1).
	self 
		should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ]
		raise: Error! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0IndexAccessingTest
	self accessCollection.
	self assert: self accessCollection size equals: 5.
	self subCollectionNotIn.
	self subCollectionNotIn detect: [ :each | (self accessCollection includes: each) not ] ifNone: [ self assert: false ].
	self elementNotInForIndexAccessing.
	self deny: (self accessCollection includes: self elementNotInForIndexAccessing).
	self elementInForIndexAccessing.
	self assert: (self accessCollection includes: self elementInForIndexAccessing).
	self collectionOfFloat.
	self collectionOfFloat do: [ :each | self deny: each class equals: SmallInteger ]! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionWithCopyNonIdentical
	" return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)"
	^ collectionOfLargeIntegers! !

!IntervalTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printNameOn: aStream.

	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents equals: ('an ',self nonEmpty class name ) ]
		ifFalse:[ self assert: aStream contents equals: ('a ',self nonEmpty class name)].! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
" return a collection elements that can be sorte ( understanding message ' < '  or ' > ')"
	^ self nonEmpty! !

!IntervalTest methodsFor: 'tests - equality' stamp: ''!
testHasEqualElementsOfIdenticalCollectionObjects
	
	self assert: (self empty hasEqualElements: self empty). 
	self assert: (self nonEmpty hasEqualElements: self nonEmpty)! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButFirstDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButFirstDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i +1))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element size-1)! !

!IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLastEmpty
	| result |
	result := self empty copyUpToLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!IntervalTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAtIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!IntervalTest methodsFor: 'tests - index access' stamp: ''!
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 - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDoError
	
	self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error! !

!IntervalTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignForSequenceableCollections

	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' stamp: ''!
testEqualSignIsTrueForEmptyButNonIdenticalCollections
	
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy! !

!IntervalTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingStartWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty .
	result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ).
	
	"verify content of 'result' : "
	1 to: 2   do:
		[:i | self assert: ( element ) = ( result at:(i) ) ].
	
	3 to: result size do:
		[:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ].

	"verify size of 'result' :"
	self assert: result size = (self nonEmpty size + 2).! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
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 - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDoEmpty
	| result |
	result := OrderedCollection new.

	self empty keysAndValuesDo: [ :i :value | result add: value + i ].

	self assertEmpty: result! !

!IntervalTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithSequenceable

	| result index element |
	index := self indexInNonEmpty.
	element := self nonEmpty at: index.
	result := self nonEmpty copyWith: (element ).
	
	self assert: result size equals: (self nonEmpty size + 1).
	self assert: result last equals: element.
	
	1 to: (result size - 1) do:
		[ :i | self assert: (result at: i) equals: ( self nonEmpty at: i)]! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexCollect
	
	| result index collection |
	index := 0.
	collection := self nonEmptyMoreThan1Element .
	result := collection  withIndexCollect: [:each :i | 
		self assert: i equals: (index := index + 1).	
		self assert: i equals: (collection  indexOf: each).
		each ]. 
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (collection at: i)].
	self assert: result size equals: collection size! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
firstEven
	"Returns the first even number of #collection"
	^ -2! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
elementInForIndexAccessing

	^ elementIn! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDetectSequenced
	"Testing that detect keep the first element returning true for sequenceable collections"

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element  detect: [:each | each notNil ].
	self assert: result equals: element! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
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' stamp: ''!
testReverseUnevenDo
	| s i |
	s := OrderedCollection new.
	i := 10 to: 20 by: 3.
	i
		reverseDo: [:each | s addFirst: each].
	self
		assert: (s hasEqualElements: i)! !

!IntervalTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection last.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: 99! !

!IntervalTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWithInsertion
	| result  indexOfSubcollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: ( indexOfSubcollection - 1 ) with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'' : '"
	
	1 to: (indexOfSubcollection -1) do: 
		[
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i)=(result at: i)
		].
	
	" middle part containing replacementCollection : "
	indexOfSubcollection  to: (indexOfSubcollection  + self replacementCollection size-1) do: 
		[
		:i |
		self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 ))
		].
	
	" end part :"
	(indexOfSubcollection  + self replacementCollection size) to: (result size) do:
		[:i|
		self assert: (result at: i)=(self collectionWith1TimeSubcollection  at: (i-self replacementCollection size))].
	
	" verify size: "	
	self assert: result size=(self collectionWith1TimeSubcollection  size + self replacementCollection size).! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testPermutationsDo
	| i oc |
	i := 1.234 to: 4.234.
	oc := OrderedCollection new.
	i permutationsDo: [ :e | oc add: e ].
	self assert: oc size equals: i size factorial.
	^ oc! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopySameContentsTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!IntervalTest methodsFor: 'tests' stamp: ''!
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 - element accessing' stamp: ''!
testAtLast

	| index |
	self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last.

	index := self moreThan4Elements indexOf: self elementInForElementAccessing.
	self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! !

!IntervalTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
secondCollection
	^anotherCollection! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
nonEmpty

	^ nonEmpty! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
elementNotInForIndexAccessing

	^elementNotIn! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testCollectFromTo
	
	| result |
	result:=self nonEmptyMoreThan1Element 
		collect: [ :each | each ]
		from: 1
		to: (self nonEmptyMoreThan1Element size - 1).
		
	1 to: result size
		do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ].
	self assert: result size = (self nonEmptyMoreThan1Element size - 1)! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
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' stamp: ''!
testIsEvaluating
	self assert: (1 to: 10) isSelfEvaluating.
	self assert: (1 to: 10 by: 2) isSelfEvaluating! !

!IntervalTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfIfAbsent

	| collection |
	collection := self collectionMoreThan1NoDuplicates.
	self assert: (collection 
			indexOf: collection first
			ifAbsent: [ 33 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 33 ]) equals: 33! !

!IntervalTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Interval! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionOfFloat
	^collectionOfFloat! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testIntervalStoreOn
	"this is a test for http://bugs.squeak.org/view.php?id=4378"

	| interval1 interval2 |
	interval1 := 0 to: 1 by: 0.5s1 squared.
	interval2 := self class compiler evaluate: interval1 storeString.
	self assert: interval1 size equals: interval2 size! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFromToDo
	
	| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each].
	
	1 to: (self nonEmptyMoreThan1Element  size -1) do:
		[:i | self assert: (self nonEmptyMoreThan1Element at:i) = (result at:i) ].

	self assert: result size = (self nonEmptyMoreThan1Element size - 1).! !

!IntervalTest methodsFor: 'tests - copying same contents' stamp: ''!
testReversed

	| result |
	result := self nonEmpty reversed.
	
	"Verify content"
	result withIndexDo:
		[:el :i | self assert: el equals: (self nonEmpty at: (self nonEmpty size - i + 1))].

	"Verify size"
	self assert: result size=self nonEmpty size.! !

!IntervalTest methodsFor: 'tests' stamp: ''!
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)) equals: 4! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
expectedSizeAfterReject
	"Number of even elements in #collection"
	^ 3! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
result
	^ {SmallInteger . SmallInteger . SmallInteger . SmallInteger . SmallInteger . SmallInteger}! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
empty

	^ empty! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testReverseDo
	| s i |
	s := OrderedCollection new.
	i := 10 to: 20.
	i
		reverseDo: [:each | s addFirst: each].
	self
		assert: (s hasEqualElements: i)! !

!IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionWith1TimeSubcollection
	^ collectionWithSubCollection! !

!IntervalTest methodsFor: 'tests - sorting' stamp: ''!
testSortedUsingBlock
	| result tmp |
	result := self unsortedCollection sorted:  [:a :b | a>b]..
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!IntervalTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	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 - begins ends with' stamp: ''!
testsEndsWith
	
	self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst).
	self assert: (self nonEmpty endsWith: self nonEmpty).
	self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0TSequencedStructuralEqualityTest

	self nonEmpty at: 1	"Ensures #nonEmpty is sequenceable"! !

!IntervalTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty
	| result |
	result := self empty occurrencesOf: self collectionWithoutEqualElements anyOne.
	self assert: result equals: 0! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
elementInForIncludesTest

	^ elementIn! !

!IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLastEmpty
	| result |
	result := self empty copyAfterLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan1NoDuplicates
	" return a collection of size 5 without equal elements"
	^ nonEmpty! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
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 - subcollections access' stamp: ''!
testAllButFirstNElements

	| allButFirst collection |
	collection := self moreThan3Elements.
	allButFirst := collection allButFirst: 2.
	allButFirst withIndexDo: 
		 [:el :i | self assert: el equals: (collection at: i + 2) ].
	self assert: allButFirst size + 2 equals: collection size! !

!IntervalTest methodsFor: 'tests' stamp: ''!
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 - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element

	^ nonEmpty1Element! !

!IntervalTest methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWith
	
	self assert: (self nonEmpty beginsWith: (self nonEmpty copyUpTo: self nonEmpty last)).
	self assert: (self nonEmpty beginsWith: self nonEmpty).
	self deny: (self nonEmpty beginsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
sortedInAscendingOrderCollection
	"Return a collection sorted in ascending order"
	^ anotherCollection! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest

	self nonEmpty! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
indexInForCollectionWithoutDuplicates
	^ 2.! !

!IntervalTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopy

	| result |
	result := self nonEmpty shallowCopy.
	
	"Verfy content"
	self nonEmpty withIndexDo:
		[:el :i | self assert: (result at:i) equals: (self nonEmpty at:i)].
	
	"Verify size"
	self assert: result size equals: self nonEmpty size.! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!IntervalTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty.
	result := self nonEmpty forceTo: (self nonEmpty size + 2) paddingWith: element.
	
	"Verify content of 'result'"
	self nonEmpty withIndexDo:
		[:el :index | self assert: el equals: (result at: index) ].
	
	(result size - 1) to: result size do:
		[:i | self assert: (result at:i) equals: element ].

	"Verify size of 'result'"
	self assert: result size equals: self nonEmpty size + 2! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsDo

	| index |
	index:=1.
	
	self nonEmptyMoreThan1Element  pairsDo: 
		[:each1 :each2 | 
		self assert: (self nonEmptyMoreThan1Element at:index) equals: each1.
		self assert: (self nonEmptyMoreThan1Element at:(index+1)) equals: each2.
		index := index + 2 ].
	
	self nonEmptyMoreThan1Element size odd
		ifTrue:[ self assert: index equals: self nonEmptyMoreThan1Element size ]
		ifFalse:[ self assert: index equals: (self nonEmptyMoreThan1Element size+1) ]! !

!IntervalTest methodsFor: 'tests - indexable access' stamp: ''!
testAtWrap
	"
	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) equals: self elementInForIndexAccessing.
	self assert: (self accessCollection atWrap: index + self accessCollection size) equals: self elementInForIndexAccessing.
	self assert: (self accessCollection atWrap: index - self accessCollection size) equals: self elementInForIndexAccessing.
	self assert: (self accessCollection atWrap: 1 + self accessCollection size) equals: (self accessCollection at: 1)! !

!IntervalTest methodsFor: 'tests - indexable access' stamp: ''!
testAllButLastElements
	| abf col |
	col := self accessCollection.
	abf := col allButLast: 2.
	1 to: abf size do: [ :i | self assert: (abf at: i) equals: (col at: i) ].
	self assert: abf size + 2 equals: col size! !

!IntervalTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLast

	| abf col |
	col := self moreThan3Elements.
	abf := col allButLast.
	self deny: abf last = col last.
	self assert: abf size + 1 equals: col size! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexDo

	|  indexes elements |
	indexes:= OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:value :i  |
			indexes  add: (i).
			elements add: value ].
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:el :i |
			self assert: (indexes at: i) equals: i.
			self assert: (elements at: i) equals: el ].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
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' stamp: ''!
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 - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!IntervalTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!IntervalTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLastNElements

	| allButLast collection |
	collection := self moreThan3Elements.
	allButLast := collection allButLast: 2.
	allButLast withIndexDo: [:el :i | self assert: el equals: (collection at: i) ].
	self assert: allButLast size + 2 equals: collection size! !

!IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	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 - begins ends with' stamp: ''!
testsBeginsWithEmpty
	
	self deny: (self nonEmpty beginsWith:(self empty)).
	self deny: (self empty beginsWith:(self nonEmpty))! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithOrWithoutSpecificElementsTest

	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self indexInNonEmpty.
	self assert: self indexInNonEmpty > 0.
	self assert: self indexInNonEmpty <= self nonEmpty size! !

!IntervalTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithFirst

	| index element result |
	index:= self indexInNonEmpty .
	element:= self nonEmpty at: index.
	
	result := self nonEmpty copyWithFirst: element.	
	
	self assert: result size = (self nonEmpty size + 1).
	self assert: result first = element .
	
	2 to: result size do:
	[ :i |
	self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! !

!IntervalTest methodsFor: 'tests' stamp: ''!
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 - copying part of sequenceable' stamp: ''!
testCopyUpTo

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection   copyUpTo: (collection  at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at:i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLast

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection copyUpToLast: (collection at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at: i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testOtherNewFrom
	self assert: (Interval newFrom: #(1 2 3)) equals: (1 to: 3).
	self assert: (Interval newFrom: #(33 5 -23)) equals: (33 to: -23 by: -28).
	self should: [ Interval newFrom: #(33 5 -22) ] raise: Error.
	self assert: (#(33 5 -23) as: Interval) equals: (33 to: -23 by: -28).
	self should: [ #(33 5 -22) as: Interval ] raise: Error.

	self assert: ((-4 to: -12 by: -1) as: Interval) equals: (-4 to: -12 by: -1).
	self assert: (Interval newFrom: (1 to: 1)) equals: (1 to: 1).
	self assert: (Interval newFrom: (1 to: 0)) equals: (1 to: 0).
	self assert: (#(1) as: Interval) equals: (1 to: 1).
	self assert: (#() as: Interval) equals: (1 to: 0)! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testEquals
	self assert: (3 to: 5) equals: #(3 4 5).
	self deny: (3 to: 5) equals: #(3 5).
	self deny: (3 to: 5) equals: #().

	self assert: #(3 4 5) equals: (3 to: 5).
	self deny: #(3 5) equals: (3 to: 5).
	self deny: #() equals: (3 to: 5)! !

!IntervalTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			lastIndexOf: element
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 99 ]) equals: 99! !

!IntervalTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
	^ (nonEmpty last + 1) to: (nonEmpty last +5)! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testNewFrom
	self assert: (Interval newFrom: (1 to: 1)) equals: (1 to: 1).
	self assert: (Interval newFrom: #(1)) equals: (1 to: 1).
	self assert: (Interval newFrom: #()) equals: (1 to: 0)! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testMinus
	self assert: (1 to: 10) - 5 equals: (-4 to: 5)! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0SortingArrayedTest
	| tmp sorted |
	" an unsorted collection of number "
	self unsortedCollection.
	self unsortedCollection do: [ :each | each isNumber ].
	sorted := true.
	self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ].
	self deny: sorted.	" a collection of number sorted in an ascending order"
	self sortedInAscendingOrderCollection.
	self sortedInAscendingOrderCollection do: [ :each | each isNumber ].
	tmp := self sortedInAscendingOrderCollection at: 1.
	self sortedInAscendingOrderCollection
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testAdd
	self assert: (1 to: 10) + 5 equals: (6 to: 15)! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	firstCollection  with: secondCollection do:
		[:a :b |
		index := index + 1.
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals: b ]! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"A copy of a collection should always be of the same class as the instance it copies"
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: copy  == self nonEmpty! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testGroupsOfAtATimeCollect
	| groupsOf2 |
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: [ :x | x ]).
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: #yourself).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 2 atATimeCollect: [ :x | x ].
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 2.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 2 ]).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 3 atATimeCollect: #yourself.
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 3.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 3 ]).! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testExtent
	self assert: (1 to: 10) extent equals: 9.
	self assert: (1 to: 10 by: 2) extent equals: 9.
	self assert: (1 to: -1) extent equals: -2! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithReplacementTest
	self replacementCollection.
	self oldSubCollection.
	self collectionWith1TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
elementToAdd
	^ elementNotIn! !

!IntervalTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAtIfAbsent
	| absent subcollection collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ].
	self deny: absent.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ].
	self assert: absent! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
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 - converting' stamp: ''!
testAsSet
 	"Test with a collection without equal elements"
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set! !

!IntervalTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWithEmpty
	
	self deny: (self nonEmpty endsWith: self empty).
	self deny: (self empty endsWith: self nonEmpty)! !

!IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLast

	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection copyAfterLast: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
integerCollectionWithoutEqualElements
	^ 1 to: 23.! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
elementNotInForOccurrences
	^ 9! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
doWithoutNumber

	^ 6! !

!IntervalTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutIndex

	| result index |	
	index := self indexInNonEmpty.
	result := self nonEmpty copyWithoutIndex: index.
	
	"Verify content of result"
	result withIndexDo: 
		[:element :i | 
		 i <  index ifTrue: [ self assert: element equals: (self nonEmpty at: i) ].
		 i >= index ifTrue: [ self assert: element equals: (self nonEmpty at: (i + 1)) ]].
	
	"Verify size of result"
	self assert: result size equals: (self nonEmpty size - 1)! !

!IntervalTest methodsFor: 'running' stamp: ''!
setUp
	super 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.
	collectionOfLargeIntegers := 100 factorial to: 100 factorial + 5.! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testSorted
	| result tmp unsorted |
	unsorted := self unsortedCollection.
	result := unsorted sorted.
	self deny: unsorted == result.
	tmp := result at: 1.
	result
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!IntervalTest methodsFor: 'tests - sorting' stamp: ''!
testIsSortedBy
	self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]).
	self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]).! !

!IntervalTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result:= self empty,self secondCollection .
	
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:i).
		].
	"size : "
	self assert: result size = ( self secondCollection size).! !

!IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringMore

	"self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'.
	self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3'"

	| result resultAnd index allElementsAsString |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
 
	index := 1.
	(result findBetweenSubstrings: ',' )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 findBetweenSubstrings: ',' ).
	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 - indexable access' stamp: ''!
testAllButFirstElements
	| abf col |
	col := self accessCollection.
	abf := col allButFirst: 2.
	1 to: abf size do: [ :i | self assert: (abf at: i) equals: (col at: i + 2) ].
	self assert: abf size + 2 equals: col size! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testNumericTypes

	self assert: ((3 asNumber) to: 5) equals: #(3 4 5).
	
	self assert: (3.0 to: 5.0) equals: #(3.0 4.0 5.0).
	self assert: (3.0 to: 5.0 by: 0.5) equals: #(3.0 3.5 4.0 4.5 5.0).
	
	self assert: (3/1 to: 5/1) equals: #(3 4 5).

	"dynamic array, because fractions aren't literals"
	self assert: (1/2 to: 5/2 by: 1/2) equals: {1/2 . 1 . 3/2 . 2 . 5/2}.! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testAt
	self assert: ((1 to: 10) at: 1) equals: 1.
	self assert: ((1 to: 10) at: 3) equals: 3.
	self assert: ((1 to: 10 by: 2) at: 1) equals: 1.
	self assert: ((1 to: 10 by: 2) at: 3) equals: 5! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testLast
	self assert: (1 to: 10) last equals: 10.
	self assert: (1 to: 10 by: 2) last equals: 9! !

!IntervalTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation
	| result index |
	result:= self firstCollection,self secondCollection .
	"first part : "
	index := 1.
	self firstCollection do: 
		[:each | 
		self assert: (self firstCollection at: index)=each.
		index := index+1.].
	"second part : "
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:index).
		index:=index+1].
	"size : "
	self assert: result size = (self firstCollection size + self secondCollection size).! !

!IntervalTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContentsSized
	| result |
	result:= self collectionClass new: 1 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.
	
	result:= self collectionClass new: 1000 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
replacementCollection
	^ 5 to: 7.! !

!IntervalTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopyEmpty
	| result |
	result := self empty shallowCopy.
	self assertEmpty: result! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionInForIncluding
	^ nonEmpty copyWithout: (self nonEmpty last).! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
elementInForIndexAccess
	^ self accessCollection  anyOne! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
howMany: aSubCollection in: collection
" return an integer representing how many time 'subCollection'  appears in 'collection'  "
	| tmp nTime |
	tmp := collection.
	nTime:= 0.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				nTime := nTime + 1.
				1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.]
				]
			ifFalse: [tmp := tmp copyWithoutFirst.]
		 ].
	
	^ nTime.! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
firstCollection
	^ nonEmpty.! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateSequencedReadableTest
	| res |
	self nonEmptyMoreThan1Element.
	self assert: self nonEmptyMoreThan1Element size > 1.

	self empty.
	self assertEmpty: self empty.

	res := true.
	self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
unsortedCollection
" retur a collection that is not yat sorted"
	^ (10 to: 1 by: -2)! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testDo
	| s i |
	s := OrderedCollection new.
	i := (10 to: 20).
	i do: [ :each | s addLast: each].
	self assert: (s hasEqualElements: i)! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessTest
	| res |
	self collectionMoreThan1NoDuplicates.
	self assert: self collectionMoreThan1NoDuplicates size > 1.
	res := true.
	self collectionMoreThan1NoDuplicates
		detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self elementInForIndexAccessing.
	self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing).
	self elementNotInForIndexAccessing.
	self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! !

!IntervalTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
firstOdd
	"Returns the first odd number of #collection"
	^ -5! !

!IntervalTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
	
	^ subCollectionInNonEmpty .! !

!IntervalTest methodsFor: 'tests - copying with replacement' stamp: ''!
firstIndexesOf: aSubCollection in: collection
" return an OrderedCollection with the first indexes of the occurrences of subCollection in  collection "
	| tmp result currentIndex |
	tmp:= collection.
	result:= OrderedCollection new.
	currentIndex := 1.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				result add: currentIndex.
				1 to: aSubCollection size do: 
					[:i | 
					tmp := tmp copyWithoutFirst.
					currentIndex := currentIndex + 1]
				]
			ifFalse: [
				tmp := tmp copyWithoutFirst.
				currentIndex := currentIndex +1.
				]
		 ].
	
	^ result.! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testEquals3
	self assert: (3 to: 5 by: 2) first equals: (3 to: 6 by: 2) first.
	self assert: (3 to: 5 by: 2) last equals: (3 to: 6 by: 2) last.
	self assert: (3 to: 5 by: 2) equals: (3 to: 6 by: 2)! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
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 - copying part of sequenceable' stamp: ''!
testCopyFromTo
	| result  index collection |
	collection := self collectionWithoutEqualElements .
	index :=self indexInForCollectionWithoutDuplicates .
	result := collection   copyFrom: index  to: collection  size .
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at:i) equals: (collection  at: (i + index - 1))].
	
	"Verify size"
	self assert: result size equals: (collection  size - index + 1)! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testInvalid
	"empty, impossible ranges"

	self assert: (1 to: 0) equals: #().
	self assert: (1 to: -1) equals: #().
	self assert: (-1 to: -2) equals: #().
	self assert: (1 to: 5 by: -1) equals: #().

	"always contains only start value."
	self assert: (1 to: 1) equals: #(1).
	self assert: (1 to: 5 by: 10) equals: #(1).
	self assert: (1 to: 0 by: -2) equals: #(1).

	"zero steps are not allowed"
	self should: [ 1 to: 1 by: 0 ] raise: DomainError! !

!IntervalTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	allElementsAsString withIndexDo: 
		[:el :i | 
		i=1
			ifTrue:[
				self accessCollection class name first isVowel 
					ifTrue:[self assert: el equals: 'an' ]
					ifFalse:[self assert: el equals: 'a'].].
		i=2
			ifTrue:[self assert: el equals: self accessCollection class name].
		i>2
			ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]]! !

!IntervalTest methodsFor: 'tests - subcollections access' stamp: ''!
testFirstNElements

	| result |
	result := self moreThan3Elements first: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i) ].
	
	self assert: result size equals: (self moreThan3Elements size - 1).
	self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: SubscriptOutOfBounds! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeWithIdentityTest

	| anElement |
	self collectionWithCopyNonIdentical.
	anElement := self collectionWithCopyNonIdentical anyOne.
	self deny: anElement == anElement copy! !

!IntervalTest methodsFor: 'tests' stamp: ''!
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: ''!
testEquals4
	self assert: (3 to: 5 by: 2) equals: #(3 5).
	self deny: (3 to: 5 by: 2) equals: #(3 4 5).
	self deny: (3 to: 5 by: 2) equals: #().

	self assert: #(3 5) equals: (3 to: 5 by: 2).
	self deny: #(3 4 5) equals: (3 to: 5 by: 2).
	self deny: #() equals: (3 to: 5 by: 2)! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
elementNotInForElementAccessing
" return an element not included in 'accessCollection' "
	^ elementNotIn! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDo
	"| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		result add: (value+i)].
	
	1 to: result size do:
		[:i|
		self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]"
	|  indexes elements |
	indexes := OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		indexes  add: (i).
		elements add: value].
	
	(1 to: self nonEmptyMoreThan1Element size )do:
		[ :i |
		self assert: (indexes at: i) equals: i.
		self assert: (elements at: i) equals: (self nonEmptyMoreThan1Element at: i).	
		].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	^ collectionWithoutNil! !

!IntervalTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString |
	result:=''.
	aStream:= ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ').
	allElementsAsString withIndexDo: 
		[:el :i | 
		i<(allElementsAsString size-1 )
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:i)asString)].
		i=(allElementsAsString size-1)
			ifTrue:[ self deny: (allElementsAsString at:i) equals: ('and')asString].
		i=(allElementsAsString size)
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:(i-1))asString)]]! !

!IntervalTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!IntervalTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!IntervalTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfSequenceableTest
	self collectionWithoutEqualElements.
	self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ].
	self indexInForCollectionWithoutDuplicates.
	self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size.
	self empty.
	self assertEmpty: self empty! !

!IntervalTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result index |
	delim := ', '.
	result := ''.
	multiItemStream := ReadWriteStream on: result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	index:=1.
	(result findBetweenSubstrings: delim)do:
		[:each |
			self assert: each= ((self nonEmpty at:index) asString).
			index:=index+1 ]! !

!IntervalTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!IntervalTest methodsFor: 'tests - equality' stamp: ''!
testHasEqualElements

	self deny: (self empty hasEqualElements: self nonEmpty).
	self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). 
	self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty).
	self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed)! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
subCollectionNotIn

	^subCollectionNotIn! !

!IntervalTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContents
	| result |
	result:= self collectionClass streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedElementAccessTest

	self moreThan4Elements.
	self assert: self moreThan4Elements size >= 4.
	self subCollectionNotIn.
	self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ].
	self elementNotInForElementAccessing.
	self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing).
	self elementInForElementAccessing.
	self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! !

!IntervalTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWith
	| result  indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1.
	lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection  size -1.
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: lastIndexOfOldSubcollection   with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'  "
	
	1 to: (indexOfSubcollection  - 1) do: 
		[ 
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i) = (result at: i)
		].
	
	" middle part containing replacementCollection : "
	
	(indexOfSubcollection ) to: ( lastIndexOfReplacementCollection  ) do: 
		[
		:i |
		self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1))
		].
	
	" end part :"
	1 to: (result size - lastIndexOfReplacementCollection   ) do:
		[ 
		:i |
		self assert: (result at: ( lastIndexOfReplacementCollection  + i  ) ) = (self collectionWith1TimeSubcollection  at: ( lastIndexOfOldSubcollection  + i  ) ).
		].! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testIsInterval
	self assert: (1 to: 10) isInterval.
	self assert: (1 to: 10 by: 2) isInterval! !

!IntervalTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOfIAbsent
	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) 
	     equals: 1.

	self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) 
		  equals: 55! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastError

	self 
		should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ]
		raise: Error! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLast

	| element result |
	element := self nonEmptyMoreThan1Element at: self nonEmptyMoreThan1Element size.
	result := self nonEmptyMoreThan1Element findLast: [:each | each =element].
	
	self assert: result equals: self nonEmptyMoreThan1Element size! !

!IntervalTest methodsFor: 'tests' stamp: ''!
testShuffled

	| i is |
	i := (1 to: 20).
	is := i shuffled.
	self assert: i ~= is.
	self assert: i size equals: is size.
	self assert: (is includesAll: i).
	self assert: (i includesAll: is).! !

!IntervalTest methodsFor: 'tests - streaming' stamp: ''!
testNewStreamContentsReturnsCollectionOfCorrectSize
	| result item originalSize |
	originalSize := 10.
	item := self firstCollection first.
	result := self collectionClass
		new: originalSize
		streamContents: [ :stream | 
			1 to: originalSize + 1 do: [ :each | stream nextPut: item ].
			stream position: originalSize ].
	self assert: result size equals: originalSize! !

!IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToEmpty
	| result |
	result := self empty copyUpTo: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButLastDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButLastDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i ))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element  size-1)! !

!IntervalTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!IntervalTest methodsFor: 'tests' stamp: ''!
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 - iterate on sequenced reable collections' stamp: ''!
testWithCollectError

	self should: [ self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := firstCollection size.
	
	firstCollection  reverseWith: secondCollection do:
		[:a :b |
	
		self assert: (firstCollection at: index) equals: a. 
		self assert: (secondCollection at: index) equals: b.
			(index := index - 1)]! !

!IntervalTest methodsFor: 'tests - element accessing' stamp: ''!
testAtOutOfBounds

	self 
		should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ]
		raise: Error.
	self 
		should: [ self moreThan4Elements at: -1 ]
		raise: Error! !

!IntervalTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!IntervalTest methodsFor: 'tests - copy' stamp: ''!
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 - copying with replacement' stamp: ''!
testCopyReplaceAllWith1Occurrence
	| 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 - occurrencesOf' stamp: ''!
testOccurrencesOf
	| collection |
	collection := self collectionWithoutEqualElements .
	
	collection do: [ :each | self assert: (collection occurrencesOf: each) equals: 1 ]! !

!IntervalTest methodsFor: 'tests' stamp: ''!
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 - copying part of sequenceable' stamp: ''!
testCopyAfter
	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection   copyAfter: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!IntervalTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
speciesClass
	
	^ Array! !

!IntervalTest methodsFor: 'tests - includes' stamp: ''!
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' stamp: ''!
testIdentityIncludes
	" test the comportement in presence of elements 'includes' but not 'identityIncludes' "

	" can not be used by collections that can't include elements for wich copy doesn't return another instance "

	| collection element |
	self collectionWithCopyNonIdentical.
	collection := self collectionWithCopyNonIdentical.
	element := collection anyOne copy.	"self assert: (collection includes: element)."
	self deny: (collection identityIncludes: element)! !

!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirst

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element findFirst: [:each | each = element].
	
	self assert: result equals: 1! !

!IntervalTest methodsFor: 'tests - subcollections access' stamp: ''!
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 - equality' stamp: ''!
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 - index access' stamp: ''!
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) equals: index! !

!IntervalTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	 
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!IntervalTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
	^ nonEmpty! !

!IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |
	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 - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!InvalidGlobalName commentStamp: ''!
I am a warning signaled when trying to build a class with invalid name.!
!InvalidGlobalName class methodsFor: 'signalling' stamp: ''!
signal: aMessage for: aName
	self signal: aName asString, ': ', aMessage ! !

!InvalidSlotName commentStamp: ''!
I am signaled when the name of a Slot is an invalid variable name.!
!InvalidSlotName class methodsFor: 'signalling' stamp: ''!
signalFor: aSymbol
	self signal: aSymbol asString, ' is an invalid name for a slot'! !

!InvalidSocketStatusException commentStamp: ''!
Signals if an operation on a Socket found it in a state invalid for that operation.
!
!IsContextPostMortemTest methodsFor: 'helper' stamp: ''!
stepA2
	^ 42! !

!IsContextPostMortemTest methodsFor: 'helper' stamp: ''!
stepA1
	^ self stepA2! !

!IsContextPostMortemTest methodsFor: 'tests' stamp: ''!
testIsContextPostMortem
	self settingUpSessionAndProcessAndContextForBlock: [ self stepA1 ].
	session stepInto.
	"The top context of the context chain is not post mortem"
	self assert: (session isContextPostMortem: session interruptedProcess suspendedContext) not.
	"A context from the context chain is not post mortem"
	self assert: (session isContextPostMortem: context) not.
	"A context not from the context chain is post mortem..."
	self assert: (session isContextPostMortem: [2] asContext).
	process suspendedContext: nil.
	"...unless the process' suspended context is nil, in which case, no context is post mortem"
	self assert: (session isContextPostMortem: [2] asContext) not.! !

!JPEGColorComponent commentStamp: ''!
I represent a single component of color in JPEG YCbCr color space.  I can accept a list of blocks in my component from the current MCU, then stream the samples from this block for use in color conversion.  I also store the running DC sample value for my component, used by the Huffman decoder.

The following layout is fixed for the JPEG primitives to work:
	currentX 		<SmallInteger>
	currentY 		<SmallInteger>
	hSampleFactor 	<SmallInteger>
	vSampleFactor 	<SmallInteger>
	mcuBlocks 		<Array of: <IntegerArray of: DCTSize2 * Integer>>
	widthInBlocks 	<SmallInteger>
	heightInBlocks 	<SmallInteger>
	dctSize 			<SmallInteger>
	mcuWidth 		<SmallInteger>
	mcuHeight 		<SmallInteger>
	priorDCValue 	<SmallInteger>
!
!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
heightInBlocks

	^heightInBlocks! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
dcTableIndex: anInteger 
	dcTableIndex := anInteger! !

!JPEGColorComponent methodsFor: 'sample streaming' stamp: ''!
nextSample
	| dx dy blockIndex sampleIndex sample |
	dx := currentX // hSampleFactor.
	dy := currentY // vSampleFactor.
	blockIndex := dy // dctSize * widthInBlocks + (dx // dctSize) + 1.
	sampleIndex := dy \\ dctSize * dctSize + (dx \\ dctSize) + 1.
	sample := (mcuBlocks at: blockIndex) at: sampleIndex.
	currentX := currentX + 1.
	currentX < (mcuWidth * dctSize) ifFalse: 
		[ currentX := 0.
		currentY := currentY + 1 ].
	^ sample! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
qTableIndex
	^qTableIndex! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
priorDCValue: aNumber 
	priorDCValue := aNumber! !

!JPEGColorComponent methodsFor: 'sample streaming' stamp: ''!
resetSampleStream
	currentX := 0.
	currentY := 0! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
id: anObject 
	id := anObject! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
widthInBlocks: anInteger 
	widthInBlocks := anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
id

	^id! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
totalMcuBlocks

	^ heightInBlocks * widthInBlocks! !

!JPEGColorComponent methodsFor: 'sample streaming' stamp: ''!
initializeSampleStreamBlocks: aCollection 
	mcuBlocks := aCollection.
	self resetSampleStream! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
acTableIndex: anInteger 
	acTableIndex := anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
qTableIndex: anInteger 
	qTableIndex := anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
dcTableIndex

	^dcTableIndex! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
updateDCValue: aNumber 
	priorDCValue := priorDCValue + aNumber.
	^ priorDCValue! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
acTableIndex

	^acTableIndex! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
heightInBlocks: anInteger 
	heightInBlocks := anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
widthInBlocks

	^widthInBlocks! !

!JPEGColorComponent methodsFor: 'accessing' stamp: ''!
mcuWidth: mw mcuHeight: mh dctSize: ds 
	mcuWidth := mw.
	mcuHeight := mh.
	dctSize := ds.
	hSampleFactor := mcuWidth // widthInBlocks.
	vSampleFactor := mcuHeight // heightInBlocks! !

!JPEGHuffmanTable commentStamp: ''!
I represent the table of values used to decode Huffman entropy-encoded bitstreams.  From the JFIF file header entropy values, I build a derived table of codes and values for faster decoding.!
!JPEGHuffmanTable methodsFor: 'computation' stamp: ''!
makeDerivedTables
	| huffSize huffCode code si index lookbits |
	mincode := Array new: 16.
	maxcode := Array new: 17.
	valptr := Array new: 17.
	huffSize := OrderedCollection new.
	1 
		to: 16
		do: 
			[ :l | 
			1 
				to: (bits at: l)
				do: [ :i | huffSize add: l ] ].
	huffSize add: 0.
	code := 0.
	huffCode := Array new: huffSize size.
	si := huffSize at: 1.
	index := 1.
	[ (huffSize at: index) ~= 0 ] whileTrue: 
		[ [ (huffSize at: index) = si ] whileTrue: 
			[ huffCode 
				at: index
				put: code.
			index := index + 1.
			code := code + 1 ].
		code := code << 1.
		si := si + 1 ].
	index := 1.
	1 
		to: 16
		do: 
			[ :l | 
			(bits at: l) ~= 0 
				ifTrue: 
					[ valptr 
						at: l
						put: index.
					mincode 
						at: l
						put: (huffCode at: index).
					index := index + (bits at: l).
					maxcode 
						at: l
						put: (huffCode at: index - 1) ]
				ifFalse: 
					[ maxcode 
						at: l
						put: -1 ] ].
	maxcode 
		at: 17
		put: 1048575.
	lookaheadBits := (Array new: 1 << Lookahead) atAllPut: 0.
	lookaheadSymbol := Array new: 1 << Lookahead.
	index := 1.
	1 
		to: Lookahead
		do: 
			[ :l | 
			1 
				to: (bits at: l)
				do: 
					[ :i | 
					lookbits := ((huffCode at: index) << (Lookahead - l)) + 1.
					(1 << (Lookahead - l) 
						to: 1
						by: -1) do: 
						[ :ctr | 
						lookaheadBits 
							at: lookbits
							put: l.
						lookaheadSymbol 
							at: lookbits
							put: (values at: index).
						lookbits := lookbits + 1 ].
					index := index + 1 ] ]! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: ''!
bits: anObject 
	bits := anObject! !

!JPEGHuffmanTable methodsFor: 'computation' stamp: ''!
valueForCode: code length: length

	^ values at: ((valptr at: length) + code - (mincode at: length))! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: ''!
maxcode
	^maxcode! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: ''!
values: anObject 
	values := anObject! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: ''!
lookaheadBits
	^lookaheadBits! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: ''!
lookaheadSymbol
	^lookaheadSymbol! !

!JPEGHuffmanTable class methodsFor: 'initialization' stamp: ''!
initialize

	Lookahead := 8.
	BitBufferSize := 16! !

!JPEGHuffmanTable class methodsFor: 'constants' stamp: ''!
lookahead

	^ Lookahead! !

!JPEGReadStream commentStamp: ''!
Encapsulates huffman encoded access to JPEG data.

The following layout is fixed for the JPEG primitives to work:

	collection	<ByteArray | String>
	position		<SmallInteger>
	readLimit	<SmallInteger>
	bitBuffer	<SmallInteger>
	bitsInBuffer	<SmallInteger>!
!JPEGReadStream methodsFor: 'accessing' stamp: ''!
resetBitBuffer
	bitBuffer := 0.
	bitsInBuffer := 0! !

!JPEGReadStream methodsFor: 'accessing' stamp: ''!
nextByte
	^self next asInteger! !

!JPEGReadStream methodsFor: 'huffman trees' stamp: ''!
decodeValueFrom: table 
	"Decode the next value in the receiver using the given huffman table."
	| bits bitsNeeded tableIndex value |
	bitsNeeded := (table at: 1) bitShift: -24.	"Initial bits needed"
	tableIndex := 2.	"First real table"
	
	[ bits := self getBits: bitsNeeded.	"Get bits"
	value := table at: tableIndex + bits.	"Lookup entry in table"
	(value bitAnd: 1056964608) = 0	"Check if it is a non-leaf node" ] whileFalse: 
		[ "Fetch sub table"
		tableIndex := value bitAnd: 65535.	"Table offset in low 16 bit"
		bitsNeeded := (value bitShift: -24) bitAnd: 255.	"Additional bits in high 8 bit"
		bitsNeeded > MaxBits ifTrue: [ ^ self error: 'Invalid huffman table entry' ] ].
	^ value! !

!JPEGReadStream methodsFor: 'accessing' stamp: ''!
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: ''!
nextBytes: n
	^(self next: n) asByteArray! !

!JPEGReadStream methodsFor: 'accessing' stamp: ''!
getBits: requestedBits 
	| value |
	requestedBits > bitsInBuffer ifTrue: 
		[ self fillBuffer.
		requestedBits > bitsInBuffer ifTrue: [ self error: 'not enough bits available to decode' ] ].
	value := bitBuffer bitShift: requestedBits - bitsInBuffer.
	bitBuffer := bitBuffer bitAnd: (1 bitShift: bitsInBuffer - requestedBits) - 1.
	bitsInBuffer := bitsInBuffer - requestedBits.
	^ value! !

!JPEGReadStream methodsFor: 'huffman trees' stamp: ''!
growHuffmanTable: table 
	| newTable |
	newTable := table species new: table size * 2.
	newTable 
		replaceFrom: 1
		to: table size
		with: table
		startingAt: 1.
	^ newTable! !

!JPEGReadStream methodsFor: 'huffman trees' stamp: ''!
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: 'initialization' stamp: ''!
reset
	super reset.
	self resetBitBuffer! !

!JPEGReadStream methodsFor: 'huffman trees' stamp: ''!
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 class methodsFor: 'initialization' stamp: ''!
initialize
	"JPEGReadStream initialize"
	MaxBits := 16! !

!JPEGReadWriter commentStamp: ''!
I am JPEGReadWriter.
I am a concrete subclass of ImageReadWriter.

I implement the JPEG image format.

  https://en.wikipedia.org/wiki/JPEG

NOTE: I only implement reading, not writing, see PluginBasedJPEGReadWriter for that.

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: ''!
qTable
	qTable ifNil: [ qTable := Array new: QuantizationTableSize ].
	^ qTable! !

!JPEGReadWriter methodsFor: 'public access' stamp: ''!
nextImageDitheredToDepth: depth 
	| form xStep yStep x y bb |
	ditherMask := DitherMasks 
		at: depth
		ifAbsent: [ self error: 'can only dither to display depths' ].
	residuals := WordArray new: 3.
	sosSeen := false.
	self parseFirstMarker.
	[ sosSeen ] whileFalse: [ self parseNextMarker ].
	form := Form 
		extent: width @ height
		depth: depth.
	bb := BitBlt toForm: form.
	bb sourceForm: mcuImageBuffer.
	bb colorMap: (mcuImageBuffer colormapIfNeededFor: form).
	bb sourceRect: mcuImageBuffer boundingBox.
	bb combinationRule: Form over.
	xStep := mcuWidth * DCTSize.
	yStep := mcuHeight * DCTSize.
	y := 0.
	1 
		to: mcuRowsInScan
		do: 
			[ :row | 
			x := 0.
			1 
				to: mcusPerRow
				do: 
					[ :col | 
					self decodeMCU.
					self idctMCU.
					self colorConvertMCU.
					bb
						destX: x;
						destY: y;
						copyBits.
					x := x + xStep ].
			y := y + yStep ].
	^ form! !

!JPEGReadWriter methodsFor: 'dct' stamp: ''!
primIdctBlockInt: anArray component: aColorComponent
	^self primIdctInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! !

!JPEGReadWriter methodsFor: 'dct' stamp: ''!
primIdctInt: anArray qt: qt
	<primitive: 'primitiveIdctInt' module: 'JPEGReaderPlugin'>
	^self idctBlockInt: anArray qt: qt! !

!JPEGReadWriter methodsFor: 'preferences' stamp: ''!
useFloatingPoint

	^ false! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: ''!
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: 'marker parsing' stamp: ''!
okToIgnoreMarker: aMarker

	^ (((16rE0 to: 16rEF) includes: aMarker) "unhandled APPn markers"
		or: [aMarker = 16rDC or: [aMarker = 16rFE]]) "DNL or COM markers"
		or: [aMarker = 16r99] "Whatever that is"! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: ''!
sampleRangeLimit: aNumber

	aNumber < 0 ifTrue: [^ 0].
	aNumber > MaxSample ifTrue: [^ MaxSample].
	^ aNumber! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: ''!
processRestart
	stream resetBitBuffer.
	self parseNextMarker.
	currentComponents do: [ :c | c priorDCValue: 0 ].
	restartsToGo := restartInterval! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: ''!
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: 'marker parsing' stamp: ''!
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: 'testing' stamp: ''!
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: 'dct' stamp: ''!
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: 'marker parsing' stamp: ''!
parseAPPn
	| length buffer thumbnailLength markerStart |
	markerStart := self position.
	length := self nextWord.
	buffer := self next: 4.
	buffer asString = 'JFIF' ifFalse: 
		[ "Skip APPs that we're not interested in"
		stream next: length - 6.
		^ self ].
	self next.
	majorVersion := self next.
	minorVersion := self next.
	densityUnit := self next.
	xDensity := self nextWord.
	yDensity := self nextWord.
	thumbnailLength := self next * self next * 3.
	length := length - (self position - markerStart).
	length = thumbnailLength ifFalse: [ self error: 'APP0 thumbnail length is incorrect.' ].
	self next: length! !

!JPEGReadWriter methodsFor: 'dct' stamp: ''!
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: 'accessing' stamp: ''!
hDCTable
	hDCTable ifNil: [ hDCTable := Array new: HuffmanTableSize ].
	^ hDCTable! !

!JPEGReadWriter methodsFor: 'public access' stamp: ''!
nextPutImage: aForm
	self error: 'JPEGReadWriter supports decoding, for encoding, look at PluginBasedJPEGReadWriter'! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: ''!
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: ''!
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: 'huffman encoding' stamp: ''!
primDecodeBlockInto: sampleBuffer component: comp dcTable: dcTable acTable: acTable stream: jpegStream
	<primitive: 'primitiveDecodeMCU' module: 'JPEGReaderPlugin'>
	^self decodeBlockInto: sampleBuffer component: comp dcTable: dcTable acTable: acTable! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: ''!
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: 'huffman encoding' stamp: ''!
getBits: requestedBits
	^stream getBits: requestedBits! !

!JPEGReadWriter methodsFor: 'error handling' stamp: ''!
notSupported: aString

	self error: aString , ' is not currently supported'! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: ''!
sampleFloatRangeLimit: aNumber

	^ (aNumber rounded max: 0) min: MaxSample! !

!JPEGReadWriter methodsFor: 'dct' stamp: ''!
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: 'huffman encoding' stamp: ''!
scaleAndSignExtend: aNumber inFieldWidth: w
	^ aNumber < (1 bitShift: w - 1)
		ifTrue: [ aNumber - (1 bitShift: w) + 1 ]
		ifFalse: [ aNumber ]! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: ''!
primColorConvertYCbCrMCU: componentArray bits: bits residuals: residualArray ditherMask: mask
	<primitive: 'primitiveColorConvertMCU' module: 'JPEGReaderPlugin'>
	^self colorConvertIntYCbCrMCU! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: ''!
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: ''!
primColorConvertGrayscaleMCU
	self primColorConvertGrayscaleMCU: (currentComponents at: 1)
			bits: mcuImageBuffer bits
			residuals: residuals
			ditherMask: ditherMask.! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: ''!
skipMarker
	| length markerStart |
	markerStart := self position.
	length := self nextWord.
	self next: length - (self position - markerStart)! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: ''!
primColorConvertIntYCbCrMCU
	self primColorConvertYCbCrMCU: currentComponents
			bits: mcuImageBuffer bits
			residuals: residuals
			ditherMask: ditherMask.! !

!JPEGReadWriter methodsFor: 'accessing' stamp: ''!
hACTable
	hACTable ifNil: [ hACTable := Array new: HuffmanTableSize ].
	^ hACTable! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: ''!
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: ''!
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: 'public access' stamp: ''!
setStream: aStream 
	"Feed it in from an existing source"
	stream := JPEGReadStream on: aStream upToEnd! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: ''!
parseStartOfInput
	restartInterval := 0.
	densityUnit := 0.
	xDensity := 1.
	yDensity := 1! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: ''!
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: ''!
parseDecoderRestartInterval
	| length |
	length := self nextWord.
	length = 4 ifFalse: [ self error: 'DRI length incorrect' ].
	restartInterval := self nextWord! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: ''!
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: 'marker parsing' stamp: ''!
parseNOP

	"don't need to do anything, here"! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: ''!
colorConvertMCU

	^ currentComponents size = 3
		ifTrue:
			[self useFloatingPoint
				ifTrue: [self colorConvertFloatYCbCrMCU]
				ifFalse: [self primColorConvertYCbCrMCU: currentComponents
								bits: mcuImageBuffer bits
								residuals: residuals
								ditherMask: ditherMask.]]
		ifFalse: [self primColorConvertGrayscaleMCU]! !

!JPEGReadWriter methodsFor: 'dct' stamp: ''!
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: 'public access' stamp: ''!
nextImage

	^ self nextImageDitheredToDepth: Display depth! !

!JPEGReadWriter methodsFor: 'private' stamp: ''!
on: aStream 
	super on: aStream.
	stream := JPEGReadStream on: stream upToEnd! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: ''!
parseNextMarker
	"Parse the next marker of the stream"
	| byte discardedBytes |
	discardedBytes := 0.
	[ (byte := self next) = 255 ] whileFalse: [ discardedBytes := discardedBytes + 1 ].
	
	[ [ (byte := self next) = 255 ] whileTrue.
	byte = 0 ] whileTrue: [ discardedBytes := discardedBytes + 2 ].
	discardedBytes > 0 ifTrue: 
		[ "notifyWithLabel: 'warning: extraneous data discarded'"
		self ].
	self perform: (JFIFMarkerParser 
			at: byte
			ifAbsent: 
				[ (self okToIgnoreMarker: byte) 
					ifTrue: [ #skipMarker ]
					ifFalse: [ self error: 'marker ' , byte printStringHex , ' cannot be handled' ] ])! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: ''!
colorConvertIntYCbCrMCU
	| ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits |
	ySampleStream := currentComponents at: 1.
	cbSampleStream := currentComponents at: 2.
	crSampleStream := currentComponents at: 3.
	ySampleStream resetSampleStream.
	cbSampleStream resetSampleStream.
	crSampleStream resetSampleStream.
	bits := mcuImageBuffer bits.
	1 
		to: bits size
		do: 
			[ :i | 
			y := ySampleStream nextSample.
			cb := cbSampleStream nextSample - SampleOffset.
			cr := crSampleStream nextSample - SampleOffset.
			red := y + (FIXn1n40200 * cr // 65536) + (residuals at: 1).
			red > MaxSample 
				ifTrue: [ red := MaxSample ]
				ifFalse: [ red < 0 ifTrue: [ red := 0 ] ].
			residuals 
				at: 1
				put: (red bitAnd: ditherMask).
			red := red bitAnd: MaxSample - ditherMask.
			red < 1 ifTrue: [ red := 1 ].
			green := y - (FIXn0n34414 * cb // 65536) - (FIXn0n71414 * cr // 65536) + (residuals at: 2).
			green > MaxSample 
				ifTrue: [ green := MaxSample ]
				ifFalse: [ green < 0 ifTrue: [ green := 0 ] ].
			residuals 
				at: 2
				put: (green bitAnd: ditherMask).
			green := green bitAnd: MaxSample - ditherMask.
			green < 1 ifTrue: [ green := 1 ].
			blue := y + (FIXn1n77200 * cb // 65536) + (residuals at: 3).
			blue > MaxSample 
				ifTrue: [ blue := MaxSample ]
				ifFalse: [ blue < 0 ifTrue: [ blue := 0 ] ].
			residuals 
				at: 3
				put: (blue bitAnd: ditherMask).
			blue := blue bitAnd: MaxSample - ditherMask.
			blue < 1 ifTrue: [ blue := 1 ].
			bits 
				at: i
				put: 4278190080 + (red bitShift: 16) + (green bitShift: 8) + blue ]! !

!JPEGReadWriter methodsFor: 'dct' stamp: ''!
idctBlockInt: anArray component: aColorComponent
	^self idctBlockInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: ''!
primColorConvertGrayscaleMCU: componentArray bits: bits residuals: residualArray ditherMask: mask
	<primitive: 'primitiveColorConvertGrayscaleMCU' module: 'JPEGReaderPlugin'>
	"JPEGReaderPlugin doPrimitive: #primitiveColorConvertGrayscaleMCU."
	^self colorConvertGrayscaleMCU! !

!JPEGReadWriter methodsFor: 'dct' stamp: ''!
dctFloatRangeLimit: value

	^ (value / 8.0) + FloatSampleOffset.! !

!JPEGReadWriter class methodsFor: 'image reading/writing' stamp: ''!
putForm: aForm onStream: aBinaryWriteStream 
	self error: 'JPEGReadWriter supports decoding, for encoding, look at PluginBasedJPEGReadWriter'! !

!JPEGReadWriter class methodsFor: 'image reading/writing' stamp: ''!
understandsImageFormat: aStream
	(PluginBasedJPEGReadWriter understandsImageFormat: aStream) ifTrue:[^false].
	aStream next = 16rFF ifFalse: [^ false].
	aStream next = 16rD8 ifFalse: [^ false].
	^true! !

!JPEGReadWriter class methodsFor: 'initialization' stamp: ''!
initialize
	"JPEGReadWriter initialize"
	"general constants"
	DCTSize := 8.
	MaxSample := (2 raisedToInteger: DCTSize) - 1.
	SampleOffset := MaxSample // 2.
	FloatSampleOffset := SampleOffset asFloat.
	DCTSize2 := DCTSize squared.
	QuantizationTableSize := 4.
	HuffmanTableSize := 4.

	"floating-point Inverse Discrete Cosine Transform (IDCT) constants"
	ConstBits := 13.
	Pass1Bits := 2.
	DCTK1 := 2 sqrt.
	DCTK2 := 1.847759065.
	DCTK3 := 1.0823922.
	DCTK4 := -2.61312593.
	Pass1Div := 1 bitShift: ConstBits - Pass1Bits.
	Pass2Div := 1 bitShift: ConstBits + Pass1Bits + 3.

	"fixed-point Inverse Discrete Cosine Transform (IDCT) constants"
	FIXn0n298631336 := 2446.
	FIXn0n390180644 := 3196.
	FIXn0n541196100 := 4433.
	FIXn0n765366865 := 6270.
	FIXn0n899976223 := 7373.
	FIXn1n175875602 := 9633.
	FIXn1n501321110 := 12299.
	FIXn1n847759065 := 15137.
	FIXn1n961570560 := 16069.
	FIXn2n053119869 := 16819.
	FIXn2n562915447 := 20995.
	FIXn3n072711026 := 25172.

	"fixed-point color conversion constants"
	FIXn0n34414 := 22554.
	FIXn0n71414 := 46802.
	FIXn1n40200 := 91881.
	FIXn1n77200 := 116130.

	"reordering table from JPEG zig-zag order"
	JPEGNaturalOrder := #(
		1
		2
		9
		17
		10
		3
		4
		11
		18
		25
		33
		26
		19
		12
		5
		6
		13
		20
		27
		34
		41
		49
		42
		35
		28
		21
		14
		7
		8
		15
		22
		29
		36
		43
		50
		57
		58
		51
		44
		37
		30
		23
		16
		24
		31
		38
		45
		52
		59
		60
		53
		46
		39
		32
		40
		47
		54
		61
		62
		55
		48
		56
		63
		64
	).

	"scale factors for the values in the Quantization Tables"
	QTableScaleFactor := (0 to: DCTSize - 1) collect: 
		[ :k | 
		k = 0 
			ifTrue: [ 1.0 ]
			ifFalse: [ (k * Float pi / 16) cos * 2 sqrt ] ].

	"dithering masks"
	(DitherMasks := Dictionary new)
		add: 0 -> 0;
		add: 1 -> 127;
		add: 2 -> 63;
		add: 4 -> 63;
		add: 8 -> 31;
		add: 16 -> 7;
		add: 32 -> 0.

	"dictionary of marker parsers"
	(JFIFMarkerParser := Dictionary new)
		add: 1 -> #parseNOP;
		add: 192 -> #parseStartOfFile;
		add: 196 -> #parseHuffmanTable;
		addAll: ((208 to: 215) collect: 
				[ :m | 
				Association 
					key: m
					value: #parseNOP ]);
		add: 216 -> #parseStartOfInput;
		add: 217 -> #parseEndOfInput;
		add: 218 -> #parseStartOfScan;
		add: 219 -> #parseQuantizationTable;
		add: 221 -> #parseDecoderRestartInterval;
		add: 224 -> #parseAPPn;
		add: 225 -> #parseAPPn! !

!JPEGReadWriter class methodsFor: 'image reading/writing' stamp: ''!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('jpg' 'jpeg')! !

!Job commentStamp: ''!
A Job is a task to run and potentially notified to the user.

[:job | job title: 'Let us get started'.
	1 to: 10 do: [:each |
		job
			progress: (0.1 * each);
			title: 'Youpi ', each printString.
		(Delay forMilliseconds: 100) wait.
		] ]  asJob run!
!Job methodsFor: 'compatibility' stamp: ''!
value: aNumber

	self currentValue: aNumber.! !

!Job methodsFor: 'accessing' stamp: ''!
block
	
	^ block! !

!Job methodsFor: 'private' stamp: ''!
block: aBlock
	
	block := aBlock! !

!Job methodsFor: 'compatibility' stamp: ''!
current

	^ self currentValue! !

!Job methodsFor: 'accessing' stamp: ''!
lookup: lookupBlock ifNone: noneBlock
	"Detect a job that satisfies the lookupBlock, or value noneBlock if none satisfies. 
	The lookup starts at myself, following recursevely through my parent."

	(lookupBlock value: self) ifTrue: [ ^ self ].
		
	^ parent 
		ifNil: noneBlock 
		ifNotNil: [ parent lookup: lookupBlock ifNone: noneBlock ]! !

!Job methodsFor: 'accessing' stamp: ''!
children

	^ children copy! !

!Job methodsFor: 'compatibility' stamp: ''!
increment

	self currentValue: self currentValue + 1.! !

!Job methodsFor: 'testing' stamp: ''!
isRunning
	^ isRunning! !

!Job methodsFor: 'accessing' stamp: ''!
min: aNumber
	self migrateProgressWhileUpdatingBounds: [ min := aNumber ].
	self announceChange.! !

!Job methodsFor: 'private' stamp: ''!
parent

	^ parent! !

!Job methodsFor: 'accessing' stamp: ''!
announce: anAnnouncementClass

	| announcement |
	announcement := anAnnouncementClass on: self.
	self announcer announce: announcement! !

!Job methodsFor: 'private' stamp: ''!
parent: aJob 

	parent := aJob.! !

!Job methodsFor: 'accessing' stamp: ''!
owner

	^ block outerContext receiver! !

!Job methodsFor: 'accessing' stamp: ''!
migrateProgressWhileUpdatingBounds: aBlockChangingBounds
	"Keep the progress value consistent while we change min / max"
	| progress |
	progress := self progress.
	aBlockChangingBounds value.
	self progress: progress.! !

!Job methodsFor: 'private' stamp: ''!
removeChild: aJob 

	children remove: aJob.! !

!Job methodsFor: 'running' stamp: ''!
run

	[ self prepareForRunning.
	  CurrentJob value: self during: [ ^ block cull: self ] ]
			ensure: [ self cleanupAfterRunning ]! !

!Job methodsFor: 'accessing' stamp: ''!
title
	
	^ title! !

!Job methodsFor: 'accessing' stamp: ''!
announcer

	^ self class jobAnnouncer! !

!Job methodsFor: 'accessing' stamp: ''!
max: aNumber
	self migrateProgressWhileUpdatingBounds: [ max := aNumber ].! !

!Job methodsFor: 'compatibility' stamp: ''!
decrement

	self currentValue: self currentValue - 1! !

!Job methodsFor: 'progress' stamp: ''!
progress
	"Avoid negative progress and divideByZero."
	^ min >= max ifTrue: [ 1 ] ifFalse: [ (currentValue - min) / (max - min) ]! !

!Job methodsFor: 'compatibility' stamp: ''!
label

	^ self title! !

!Job methodsFor: 'accessing' stamp: ''!
currentValue: aNumber
	
	currentValue := aNumber.
	self announceChange! !

!Job methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	min := 0.
	max := 100.
	currentValue := 0.
	title := ''.
	isRunning := false.
	children := OrderedCollection new.! !

!Job methodsFor: 'compatibility' stamp: ''!
current: aNumber

	self currentValue: aNumber! !

!Job methodsFor: 'compatibility' stamp: ''!
label: aString 

	self title: aString.! !

!Job methodsFor: 'private' stamp: ''!
prepareForRunning

	isRunning := true.
	process := Processor activeProcess.
	CurrentJob value ifNotNil: [ :job | job addChild: self].
	self announce: JobStart.! !

!Job methodsFor: 'accessing' stamp: ''!
title: anObject
	
	title := anObject.
	self announceChange.! !

!Job methodsFor: 'progress' stamp: ''!
progress: aNormalizedFloat
	"Set the progress: 0.0 - 1.0"

	currentValue := (min + ((max - min) * aNormalizedFloat)).
	self announceChange.! !

!Job methodsFor: 'accessing' stamp: ''!
currentValue
	
	^ currentValue! !

!Job methodsFor: 'accessing' stamp: ''!
min
	
	^ min! !

!Job methodsFor: 'compatibility' stamp: ''!
value

	^ self currentValue.! !

!Job methodsFor: 'private' stamp: ''!
cleanupAfterRunning

	isRunning := false.
	process := nil.
	self announce: JobEnd.
	parent ifNotNil: [ :job | job removeChild: self ]! !

!Job methodsFor: 'debugging' stamp: ''!
debug
	^ process debug! !

!Job methodsFor: 'private' stamp: ''!
addChild: aJob

	children add: aJob.
	aJob parent: self! !

!Job methodsFor: 'accessing' stamp: ''!
announceChange

	isRunning ifFalse: [ ^ self ].
	self announce: JobChange! !

!Job methodsFor: 'accessing' stamp: ''!
max
	
	^ max! !

!Job class methodsFor: 'instance creation' stamp: ''!
block: aBlock

	^(self new)
		block: aBlock;
		yourself! !

!Job class methodsFor: 'accessing' stamp: ''!
current
	"Answer the current job or nil if none."

	^ CurrentJob value! !

!Job class methodsFor: 'examples' stamp: ''!
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: 'examples' stamp: ''!
exampleProgress

	[:job | job title: 'Let us get started'.
		1 to: 10 do: [:each | 
			job 
				progress: (0.1 * each); 
				title: 'Youpi ', each printString.
			(Delay forMilliseconds: 100) wait. 
			] ]  asJob run! !

!Job class methodsFor: 'announcing' stamp: ''!
jobAnnouncer
	"Answers the announcer for job announcements"
	
	^ jobAnnouncer 
			ifNil: [ jobAnnouncer := Announcer new ]! !

!Job class methodsFor: 'examples' stamp: ''!
exampleCurrentValue

	[ :job| 
		job title: 'Simulating some progress for 1 Second'. 
		1 second wait. "simulate some work"
		job currentValue: 50.
		1 second wait. "simulate some more work"
		job currentValue: 100.
		1 second wait. "simulate some more work"
	] asJob run! !

!JobAnnouncement commentStamp: ''!
I'm an abstract superclass for Job announcements. 

My subclasses are announced in Job jobAnnouncer.!
!JobAnnouncement methodsFor: 'accessing' stamp: ''!
progress
	^ job progress! !

!JobAnnouncement methodsFor: 'accessing' stamp: ''!
job: anObject
	
	job := anObject! !

!JobAnnouncement methodsFor: 'accessing' stamp: ''!
min
	^ job min! !

!JobAnnouncement methodsFor: 'accessing' stamp: ''!
job
	
	^ job! !

!JobAnnouncement methodsFor: 'accessing' stamp: ''!
title
	^ job title! !

!JobAnnouncement methodsFor: 'accessing' stamp: ''!
max
	^ job max! !

!JobAnnouncement class methodsFor: 'instance creation' stamp: ''!
on: aJob 

	^ self new job: aJob! !

!JobChange commentStamp: ''!
A JobChange is an announcement for a job change. To get notify

SystemAnnouncer uniqueInstance 
	on: JobChange send: #XXX to: whoever.!
!JobEnd commentStamp: ''!
A JobChange is an announcement for a job end.

A JobChange is an announcement for a job change. To get notify

SystemAnnouncer uniqueInstance 
	on: JobEnd send: #XXX to: whoever.!
!JobProgressBarMorph commentStamp: ''!
A JobProgressBarMorph is a progress bar with a title and a icon to stop update.

		JobProgressBarMorph new openInWorld.

I am often used by the Job class in Pharo and not directly.

It is possible to disable the icon to prevent the user from stopping the task via the #isInterruptible setting.

		JobProgressBarMorph isInterruptible: false!
!JobProgressBarMorph methodsFor: 'accessing' stamp: ''!
value: aNumber

	^ progressBar value: aNumber! !

!JobProgressBarMorph methodsFor: 'accessing' stamp: ''!
progress

	^ progressBar value / 100! !

!JobProgressBarMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	progressBar := ProgressBarMorph new.
	progressBar hResizing: #spaceFill.
	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;
		addInterruptionButton! !

!JobProgressBarMorph methodsFor: 'private' stamp: ''!
addInterruptionButton

	self isInterruptible ifFalse: [ ^ self ].

	self addMorphBack: (self iconNamed: #stopIcon) asMorph! !

!JobProgressBarMorph methodsFor: 'accessing' stamp: ''!
progress: aNormalizedNumber

	^ progressBar value: aNormalizedNumber * 100! !

!JobProgressBarMorph methodsFor: 'accessing' stamp: ''!
increment

	^ progressBar increment! !

!JobProgressBarMorph methodsFor: 'testing' stamp: ''!
isInterruptible

	^ self class isInterruptible! !

!JobProgressBarMorph methodsFor: 'evaluating' stamp: ''!
value

	^ progressBar value! !

!JobProgressBarMorph methodsFor: '*Deprecated10' stamp: ''!
isInterruptable

	self
		deprecated: 'Please use #isInterruptible instead'
		transformWith:
		'`@receiver isInterruptable' -> '`@receiver isInterruptible'.

	^ self class isInterruptible! !

!JobProgressBarMorph methodsFor: 'accessing' stamp: ''!
decrement

	^ progressBar decrement! !

!JobProgressBarMorph class methodsFor: 'settings' stamp: ''!
interruptionSetting: aBuilder 
	<systemsettings>
	
	(aBuilder setting: #isInterruptible) 
		label: 'Make progress bar interruptible';
		default: true;
		description: 'When enabled, add a button to progress bars to interrupt the action when clicked.';
		parent: #progress; 
		target: self;
		order: 1! !

!JobProgressBarMorph class methodsFor: 'examples' stamp: ''!
example

	self new openInWorld! !

!JobProgressBarMorph class methodsFor: 'testing' stamp: ''!
isInterruptible: aBoolean

	IsInterruptible := aBoolean! !

!JobProgressBarMorph class methodsFor: '*Deprecated10' stamp: ''!
isInterruptable: aBoolean

	self
		deprecated: 'Please use #isInterruptible: instead'
		transformWith:
		'`@receiver isInterruptable: `@arg' -> '`@receiver isInterruptible: `@arg'.
		
	self isInterruptible: aBoolean! !

!JobProgressBarMorph class methodsFor: 'testing' stamp: ''!
isInterruptible

	^ IsInterruptible ifNil: [ IsInterruptible := true ]! !

!JobProgressBarMorph class methodsFor: '*Deprecated10' stamp: ''!
isInterruptable

	self
		deprecated: 'Please use #isInterruptible instead'
		transformWith:
		'`@receiver isInterruptable' -> '`@receiver isInterruptible'.

	^ self isInterruptible! !

!JobProgressMorph commentStamp: ''!
I combine a progress title and a JobPorgressBarMorph to a visual representation of a Job.

Usually I am contained in the global instance of the SystemProgressMorph!
!JobProgressMorph methodsFor: 'updating' stamp: ''!
changed

	| msRefreshRate isTimeForRefresh |
	msRefreshRate := 60 "roughly 16 times per second".
	isTimeForRefresh := Time millisecondClockValue - self lastRefresh >= msRefreshRate.
	(self isInWorld and: [ isTimeForRefresh ]) ifTrue: [ 
		super changed ]! !

!JobProgressMorph methodsFor: 'API' stamp: ''!
current

	^ bar value! !

!JobProgressMorph methodsFor: 'accessing' stamp: ''!
job: aJob

	job := aJob! !

!JobProgressMorph methodsFor: 'accessing' stamp: ''!
lastRefresh

	^ lastRefresh ifNil: [ lastRefresh := 0 ]! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
refresh

	lastRefresh := Time millisecondClockValue.
	self width: labelMorph width + 25! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
result

	^ result! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
startAt: aNumber
 
	startValue := aNumber! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
result: anObject

	lock critical: [ 
		hasResult := true.
		result := anObject ]! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
forceRefreshOnNextChange

	lastRefresh := 0! !

!JobProgressMorph methodsFor: 'API' stamp: ''!
increment

	bar increment! !

!JobProgressMorph methodsFor: 'API' stamp: ''!
beComplete

	self close! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
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: ''!
close

	SystemProgressMorph uniqueInstance close: self.
	self removeDependent: SystemProgressMorph uniqueInstance! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
updateLayout

	labelMorph contents isEmpty
		ifFalse: [ self addMorphBack: labelMorph].
	self addMorphBack: bar! !

!JobProgressMorph methodsFor: 'API' stamp: ''!
label

	^ self labelMorph contents! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
max: aNumber
 
	endValue := aNumber! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
labelMorph

	^ labelMorph! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
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: 'API' stamp: ''!
progress

	^ bar progress! !

!JobProgressMorph methodsFor: 'API' stamp: ''!
decrement

	bar decrement! !

!JobProgressMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self addDependent: SystemProgressMorph uniqueInstance! !

!JobProgressMorph methodsFor: 'API' stamp: ''!
current: aNumber

	bar value: aNumber.
	self changed! !

!JobProgressMorph methodsFor: 'API' stamp: ''!
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: ''!
progress: aNormalizedNumber

	bar progress = aNormalizedNumber ifFalse: [ 
		bar progress: aNormalizedNumber.
		self changed: #progressValue ]! !

!JobProgressMorph methodsFor: 'action' stamp: ''!
debug

	job isRunning ifTrue: [ job debug ]! !

!JobProgressMorph methodsFor: 'private' stamp: ''!
start: aNumber

	startValue := aNumber! !

!JobProgressMorph class methodsFor: 'instance creation' stamp: ''!
job: aJob
	^ self new initializeJob: aJob! !

!JobStart commentStamp: ''!
A JobStart is announcement announcing the start of a job execution.

SystemAnnouncer uniqueInstance 
	on: JobStart send: #XXX to: whoever.!
!JobTest commentStamp: ''!
SUnit tests for Job class!
!JobTest methodsFor: 'tests' stamp: ''!
testChildJob
	| wasRun |
	wasRun := false.

	[ :job | 
	[ :job2 | 
	self assert: job children size equals: 1.
	self assert: job children first equals: job2.
	wasRun := true ] asJob run.

	self assertEmpty: job children ] asJob run.

	self assert: wasRun! !

!JobTest methodsFor: 'running' stamp: ''!
tearDown

	testingEnvironment at: #SystemProgressMorph ifPresent: [:spm | 
		spm uniqueInstance bars do: [ :e | e close ]].
	super tearDown! !

!JobTest methodsFor: 'tests' stamp: ''!
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: ''!
testSingleJob
	| wasRun |
	wasRun := false.
	[ :job | 
	self assertEmpty: job children.
	wasRun := true ] asJob run.
	self assert: wasRun! !

!JobTest methodsFor: 'tests' stamp: ''!
testJobAnnouncements
	| announcements |
	announcements := OrderedCollection new.

	Job jobAnnouncer weak when: JobStart send: #add: to: announcements.
	Job jobAnnouncer weak when: JobEnd send: #add: to: announcements.
	Job jobAnnouncer weak when: JobChange send: #add: to: announcements.

	self assertEmpty: announcements.

	[ :job | job currentValue: 1 ] asJob run.

	self assert: (announcements collect: #class as: Array) equals: {JobStart . JobChange . JobEnd}.

	Job jobAnnouncer unsubscribe: announcements! !

!JobTest methodsFor: 'tests' stamp: ''!
testOwner
	[ :job | 
	self assert: job owner identicalTo: self.
	[ :job2 | 
	self assert: job owner identicalTo: self.
	self assert: job2 owner identicalTo: self ] asJob run ] asJob run! !

!JobTest methodsFor: 'tests' stamp: ''!
testCurrentJob
	[ :job | 
	[ :job2 | 
	self assert: Job current identicalTo: job2.
	self deny: Job current identicalTo: job ] asJob run.

	self assert: Job current identicalTo: job ] asJob run! !

!JobTest methodsFor: 'tests' stamp: ''!
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: ''!
testLookupJob
	[ :job | 
	[ :job2 | 
	| noneFound result |
	noneFound := false.
	result := job2 lookup: [ :aJob | aJob == job2 ] ifNone: [ noneFound := true ].
	self assert: result identicalTo: job2.
	self deny: noneFound.

	result := job2 lookup: [ :aJob | aJob == job ] ifNone: [ noneFound := true ].
	self assert: result identicalTo: job.
	self deny: noneFound.

	result := job
		lookup: [ :aJob | aJob == job2 ]
		ifNone: [ noneFound := true.
			42 ].
	self assert: result equals: 42.
	self assert: noneFound ] asJob run.

	self assert: Job current identicalTo: job ] asJob run! !

!JoinSection commentStamp: ''!
A join section!
!JoinSection methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Draw the join on the given canvas."
	
	|v bc|
	(self src color isTransparent and: [self dst color isTransparent])
		ifTrue: [^self].
	v := self shape vertices.
	aCanvas
		drawPolygon: v
		fillStyle: (self fillStyleFor: self shape bounds).
	(self borderWidth > 0 and: [self borderColor isTransparent not]) ifTrue: [
		bc := self borderColorToUse.
		aCanvas
			line: v first + (0@self borderWidth // 2)
			to: v second + (-1@self borderWidth // 2)
			width: self borderWidth
			color: bc;
			line: v third - (1@(self borderWidth // 2))
			to: v fourth - (0@(self borderWidth // 2))
			width: self borderWidth
			color: bc]! !

!JoinSection methodsFor: 'accessing' stamp: ''!
additionHighlightColor
	^ additionHighlightColor! !

!JoinSection methodsFor: 'accessing' stamp: ''!
srcLineRange: anInterval
	"Set the src lneRange."

	self src lineRange: anInterval! !

!JoinSection methodsFor: 'accessing' stamp: ''!
dstRange: anInterval
	"Set the dst range."

	self dst range: anInterval.
	self updateShape! !

!JoinSection methodsFor: 'accessing' stamp: ''!
borderWidth
	"Answer the value of borderWidth"

	^ borderWidth! !

!JoinSection methodsFor: 'actions' stamp: ''!
createHighlights
	"Create and store the src and dst highlights."

	|s d|
	s := OrderedCollection new.
	d := OrderedCollection new.
	s add: (self newHighlight
			color: self src color;
			borderWidth: self borderWidth;
			bounds: (0@self src range first corner: 0@(self src range last + 1));
			borderSides: #(top left bottom)).
	d add: (self newHighlight
			color: self dst color;
			borderWidth: self borderWidth;
			bounds: (0@self dst range first corner: 0@(self dst range last + 1));
			borderSides: #(top right bottom)).
	self src highlights: s.
	self dst highlights: d! !

!JoinSection methodsFor: 'accessing' stamp: ''!
borderColor: aColor
	"Set the value of borderColor"

	borderColor := aColor.
	self updateHighlights! !

!JoinSection methodsFor: 'accessing' stamp: ''!
dst: anObject
	"Set the value of dst"

	dst := anObject! !

!JoinSection methodsFor: 'accessing' stamp: ''!
removalHighlightColor
	^ removalHighlightColor! !

!JoinSection methodsFor: 'accessing' stamp: ''!
dstLineRange: anInterval
	"Set the dst lineRange."

	self dst lineRange: anInterval! !

!JoinSection methodsFor: 'accessing' stamp: ''!
src
	"Answer the value of src"

	^ src! !

!JoinSection methodsFor: 'accessing' stamp: ''!
type: anObject
	"Set the value of type"

	type := anObject! !

!JoinSection methodsFor: 'actions' stamp: ''!
clicked
	"The receiver or a highlight was clicked."

	self wantsClick
		ifFalse: [ ^ false ].
	^ true! !

!JoinSection methodsFor: 'accessing' stamp: ''!
src: anObject
	"Set the value of src"

	src := anObject! !

!JoinSection methodsFor: 'accessing' stamp: ''!
additionHighlightColor: anObject
	additionHighlightColor := anObject.
	self updateHighlights! !

!JoinSection methodsFor: 'actions' stamp: ''!
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 groupByRuns: [ :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: self additionHighlightColor ].
			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: self removalHighlightColor ] ]! !

!JoinSection methodsFor: 'accessing' stamp: ''!
dst
	"Answer the value of dst"

	^ dst! !

!JoinSection methodsFor: 'accessing' stamp: ''!
shape: anObject
	"Set the value of shape"

	shape := anObject! !

!JoinSection methodsFor: 'instance creation' stamp: ''!
newHighlight
	"Anwser a new highlight."

	^TextHighlightByBounds new
		borderWidth: 1;
		borderColor: self borderColor;
		fillWidth: true! !

!JoinSection methodsFor: 'accessing' stamp: ''!
borderColor
	"Answer the value of borderColor"

	^ borderColor! !

!JoinSection methodsFor: 'accessing' stamp: ''!
type
	"Answer the value of type"

	^ type! !

!JoinSection methodsFor: 'updating' stamp: ''!
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: 'accessing' stamp: ''!
width: anObject
	"Set the value of width"

	width := anObject.
	self updateShape! !

!JoinSection methodsFor: 'accessing' stamp: ''!
dstOffset: aPoint
	"Set the dst offset."

	self dst offset:  aPoint.
	self updateShape! !

!JoinSection methodsFor: 'accessing' stamp: ''!
width
	"Answer the value of width"

	^ width! !

!JoinSection methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		src: JoinSide new;
		dst: JoinSide new;
		shape: Polygon new;
		width: 0;
		borderWidth: 0;
		borderColor: Color transparent;
		type: #modification! !

!JoinSection methodsFor: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
wantsClick
	"Don't if we are transparent for now."

	^(self src color isTransparent and: [self dst color isTransparent]) not! !

!JoinSection methodsFor: 'accessing' stamp: ''!
fillStyleFor: rect
	"Answer the fillStyle to use for the given rectangle."
	
	^self src color = self dst color
		ifTrue: [self src color]
		ifFalse: [(GradientFillStyle ramp: {0.0 -> self src color. 1.0 -> self dst color})
				direction: rect width@0;
				origin: rect topLeft]! !

!JoinSection methodsFor: 'accessing' stamp: ''!
srcOffset: aPoint
	"Set the src offset"

	self src offset:  aPoint.
	self updateShape! !

!JoinSection methodsFor: 'accessing' stamp: ''!
removalHighlightColor: anObject
	removalHighlightColor := anObject.
	self updateHighlights.! !

!JoinSection methodsFor: 'accessing' stamp: ''!
shape
	"Answer the value of shape"

	^ shape! !

!JoinSection methodsFor: 'accessing' stamp: ''!
srcColor: aColor
	"Set the src color."

	self src color: aColor! !

!JoinSection methodsFor: 'drawing' stamp: ''!
drawMapOn: aCanvas in: rect scale: scale
	"Draw the join on the given canvas scaled into the given rectangle."
	
	self type = #match ifTrue: [^self].
	aCanvas
		frameAndFillRectangle: (rect left @ (((self dst range first max: 0) * scale) truncated + rect top)
						corner: (rect right @ ((self dst range last * scale) truncated + rect top)))
		fillColor: (self fillStyleFor: rect)
		borderWidth: 1
		borderColor: self borderColorToUse! !

!JoinSection methodsFor: 'accessing' stamp: ''!
srcRange: anInterval
	"Set the  src range"

	self src range: anInterval.
	self updateShape! !

!JoinSection methodsFor: 'accessing' stamp: ''!
borderColorToUse
	"Answer the border color to use."
	
	^self borderColor! !

!JoinSection methodsFor: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
containsPoint: aPoint
	"Answer whether the receiver contains the given point."

	^self shape containsPoint: aPoint! !

!JoinSection methodsFor: 'adding' stamp: ''!
addHighlightsFrom: srcBlock to: dstBlock to: aCollection color: aColor
	"Add the highlights required for the given character blocks
	of a paragraph. May be up to three highlights depending
	on the line spans."
	
	srcBlock textLine = dstBlock textLine
		ifTrue: [aCollection add: (TextHighlightByBounds new
				color: aColor;
				bounds: (srcBlock topLeft corner: dstBlock bottomRight))]
		ifFalse: [aCollection
					add: (TextHighlightByBounds new
							color: aColor;
							bounds: (srcBlock topLeft corner: srcBlock textLine bottomRight));
					add: (TextHighlightByBounds new
							fillWidth: true;
							color: aColor;
							bounds: (srcBlock bottomLeft corner: dstBlock topRight));
					add: (TextHighlightByBounds new
							color: aColor;
							bounds: (dstBlock textLine topLeft corner: dstBlock bottomRight))]! !

!JoinSection methodsFor: 'accessing' stamp: ''!
dstColor: aColor
	"Set the dst color"

	self dst color: aColor! !

!JoinSide commentStamp: ''!
The join side!
!JoinSide methodsFor: 'accessing' stamp: ''!
color: anObject
	"Set the value of color"

	color := anObject! !

!JoinSide methodsFor: 'accessing' stamp: ''!
highlight
	"Answer the primary highlight."

	^(self highlights ifEmpty: [^nil]) first! !

!JoinSide methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		highlights: #();
		offset: 0@0;
		range: (1 to: 1);
		lineRange: (1 to: 0);
		color: Color yellow;
		text: ''! !

!JoinSide methodsFor: 'accessing' stamp: ''!
lineRange
	"Answer the value of lineRange"

	^ lineRange! !

!JoinSide methodsFor: 'accessing' stamp: ''!
text: anObject
	"Set the value of text"

	text := anObject! !

!JoinSide methodsFor: 'accessing' stamp: ''!
highlights: anObject
	"Set the value of highlights"

	highlights := anObject! !

!JoinSide methodsFor: 'accessing' stamp: ''!
offset: anObject
	"Set the value of offset"

	offset := anObject! !

!JoinSide methodsFor: 'accessing' stamp: ''!
range: anObject
	"Set the value of range"

	range := anObject! !

!JoinSide methodsFor: 'accessing' stamp: ''!
lineRange: anObject
	"Set the value of lineRange"

	lineRange := anObject! !

!JoinSide methodsFor: 'accessing' stamp: ''!
offset
	"Answer the value of offset"

	^ offset! !

!JoinSide methodsFor: 'accessing' stamp: ''!
highlights
	"Answer the value of highlights"

	^ highlights! !

!JoinSide methodsFor: 'accessing' stamp: ''!
range
	"Answer the value of range"

	^ range! !

!JoinSide methodsFor: 'accessing' stamp: ''!
color
	"Answer the value of color"

	^ color! !

!JoinSide methodsFor: 'accessing' stamp: ''!
text
	"Answer the value of text"

	^ text! !

!KMAltModifier commentStamp: ''!
I represent the Alt key modifier. Look at my superclass for a more detailed explanaition.!
!KMAltModifier methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	identifier := #a.
	name := 'Alt'.! !

!KMAltModifier methodsFor: 'matching' stamp: ''!
matchesEvent: aKeyboardEvent
	^ aKeyboardEvent altKeyPressed! !

!KMAltModifier methodsFor: 'accessing' stamp: ''!
eventCode
	^32! !

!KMAltModifier methodsFor: 'printing' stamp: ''!
printingPosition
	^2! !

!KMBuffer commentStamp: ''!
I am a buffer of keyboard events. I am checked against key combinations to see if there is a match.

I am cleared when the current morph loses focus or when a full match announcement is given.!
!KMBuffer methodsFor: 'matching' stamp: ''!
partialMatch

	KMLog logPartialMatch: currentEvent.
	currentEvent ifNotNil:[ currentEvent wasHandled: true ].! !

!KMBuffer methodsFor: 'initialization' stamp: ''!
initialize
	buffer := OrderedCollection new.! !

!KMBuffer methodsFor: 'clearing' stamp: ''!
clearBuffer

	currentEvent := nil.
	buffer removeAll.! !

!KMBuffer methodsFor: 'adding' stamp: ''!
addEvent: anEvent

	buffer add: anEvent.
	currentEvent := anEvent.! !

!KMBuffer methodsFor: 'accessing' stamp: ''!
buffer
	^buffer! !

!KMBuffer methodsFor: 'matching' stamp: ''!
completeMatch

	currentEvent ifNotNil:[ currentEvent wasHandled: true ].
	self clearBuffer.! !

!KMBuffer class methodsFor: 'initialize-release' stamp: ''!
resetUniqueInstance
	uniqueInstance := nil! !

!KMBuffer class methodsFor: 'accessing' stamp: ''!
uniqueInstance: aBuffer
	uniqueInstance := aBuffer.! !

!KMBuffer class methodsFor: 'accessing' stamp: ''!
uniqueInstance
	^uniqueInstance ifNil: [ uniqueInstance := self new ].! !

!KMBuilder commentStamp: ''!
I am a keymap builder that is used when configuring keymappings by pragmas.

Send me the #shortcut: message with a keymap name, so I give you a specific builder to build a keymap.

You can also tell me to install a category as global.!
!KMBuilder methodsFor: 'accessing' stamp: ''!
platform: aPlatform
	platform := aPlatform! !

!KMBuilder methodsFor: 'keymap-building' stamp: ''!
shortcut: aKeymapName
	^KMKeymapBuilder 
		for: aKeymapName
		platform: platform! !

!KMBuilder methodsFor: 'keymap-building' stamp: ''!
setAsGlobalCategory: aGlobalCategory

	KMRepository default setAsGlobalCategory: aGlobalCategory! !

!KMBuilder class methodsFor: 'instance creation' stamp: ''!
keymap: aPlatform
	(#( all Unix MacOSX Windows ) includes: aPlatform) ifFalse: [ self error: aPlatform, ' is not a valid platform' ].
	^self new
		platform: aPlatform;
		yourself! !

!KMBuilder class methodsFor: 'instance creation' stamp: ''!
keymap
	^self keymap: #all! !

!KMCatcherMorph commentStamp: ''!
I am a morph that captures keymappings, so they can be used for configuration/customization, or debugging.!
!KMCatcherMorph methodsFor: 'api' stamp: ''!
cancel
	edited
		ifFalse: [ ^ self ].
	self keystrokes: OrderedCollection new.
	self showInitialShortcut.
	self initializeKeystrokes! !

!KMCatcherMorph methodsFor: 'initialization' stamp: ''!
initializeKeystrokes
	keystrokes := OrderedCollection new.! !

!KMCatcherMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Indicate unaccepted edits, conflicts etc."

	super drawOn: aCanvas. 
	focused ifTrue: [
		self theme drawTextAdornmentFor: self color: Color orange on: aCanvas]! !

!KMCatcherMorph methodsFor: 'event handling' stamp: ''!
allowsKeymapping
	^ false! !

!KMCatcherMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self layoutPolicy: TableLayout new.
	self listCentering: #center.
	self width: 300.
	self height: 25.
	self color: (self theme textEditorDisabledFillStyleFor: self).
	self borderStyle: (self theme textEditorDisabledBorderStyleFor: self).
	labelMorph := StringMorph contents: ''.
	self addMorph: labelMorph.
	edited := false.
	focused := false.
	self initializeKeystrokes.! !

!KMCatcherMorph methodsFor: 'event handling' stamp: ''!
keyboardFocusChange: aBoolean
	super keyboardFocusChange: aBoolean.
	focused := aBoolean.
	focused
		ifTrue: [ self color: (self theme textEditorNormalFillStyleFor: self) ]
		ifFalse: [ self color: (self theme textEditorDisabledFillStyleFor: self) ].
	^ true! !

!KMCatcherMorph methodsFor: 'api' stamp: ''!
keystrokes: someKeystrokes
	keystrokes := someKeystrokes.
	self showKeystrokes.! !

!KMCatcherMorph methodsFor: 'private' stamp: ''!
showKeystrokes
	self setMessage: self shortcutString.! !

!KMCatcherMorph methodsFor: 'event handling' stamp: ''!
showContextMenu
	| menu |
	menu := MenuMorph new defaultTarget: self.
	
	edited 
		ifTrue: [
			menu add: 'accept' selector: #accept.
			menu add: 'clear' selector: #clear.
			menu add: 'cancel' selector: #cancel.
			].
		
	menu popUpInWorld! !

!KMCatcherMorph methodsFor: 'accessing' stamp: ''!
setMessage: aMessage 
	labelMorph contents: aMessage! !

!KMCatcherMorph methodsFor: 'accessing' stamp: ''!
balloonText
	^ 'Click to edit shortcut.  Right click to open context menu.'! !

!KMCatcherMorph methodsFor: 'event handling' stamp: ''!
keymapSetting: aSetting
	keymapSetting := aSetting.
	self initialShortcut: keymapSetting shortcut.! !

!KMCatcherMorph methodsFor: 'initialization' stamp: ''!
showInitialShortcut
	self setMessage: initialShortcut asString.! !

!KMCatcherMorph methodsFor: 'halos and balloon help' stamp: ''!
wantsBalloon
	^ true! !

!KMCatcherMorph methodsFor: 'initialization' stamp: ''!
initialShortcut: aShortcut
	initialShortcut := aShortcut.
	self showInitialShortcut.
	self initializeKeystrokes.! !

!KMCatcherMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: event
	^ focused! !

!KMCatcherMorph methodsFor: 'event handling' stamp: ''!
keyStroke: aKeyStroke 
	edited := true.
	self keystrokes add: aKeyStroke.
	self showKeystrokes.! !

!KMCatcherMorph methodsFor: 'api' stamp: ''!
keystrokes
	^ keystrokes! !

!KMCatcherMorph methodsFor: 'event handling' stamp: ''!
mouseDown: event 
	super mouseDown: event.
	event yellowButtonPressed 
		ifTrue: [ self showContextMenu ]
		ifFalse: [ self activeHand newKeyboardFocus: self ]! !

!KMCatcherMorph methodsFor: 'api' stamp: ''!
accept
	| shortcut |
	shortcut := self shortcut.
	keymapSetting accept: shortcut.
	self initialShortcut: shortcut.
	edited := false.! !

!KMCatcherMorph methodsFor: 'event handling' stamp: ''!
clear
	self keystrokes removeAll.
	self showKeystrokes.! !

!KMCatcherMorph methodsFor: 'api' stamp: ''!
shortcut
	| theKeystrokes |
	theKeystrokes := self keystrokes.
	theKeystrokes 
		ifEmpty: [ ^ KMNoShortcut new ].
		
	^ theKeystrokes allButFirst 
		inject: theKeystrokes first asKeyCombination 
		into: [ :acum :each | 
			acum , each asKeyCombination ]! !

!KMCatcherMorph methodsFor: 'api' stamp: ''!
shortcutString
	| shortcut |
	self keystrokes 
		ifEmpty: [ ^ '' ].
	shortcut := self shortcut.
	^ shortcut asString! !

!KMCatcherMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: event
	^ true! !

!KMCatcherMorph class methodsFor: 'instance creation' stamp: ''!
for: aModel
	^ (self new)
		keymapSetting: aModel;
		yourself! !

!KMCategory commentStamp: ''!
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: 'binding' stamp: ''!
asKmCategoryIn: aKmRepository

	"Maybe we should validate we exist in the repository?"
	^ self! !

!KMCategory methodsFor: 'matching' stamp: ''!
onMatchWith: anEventBuffer notify: aMatchListener andDo: aBlock
	self keymaps do: [ :entry | 
		entry onMatchWith: anEventBuffer 
			notify: aMatchListener 
			andDo: aBlock ].! !

!KMCategory methodsFor: 'associating' stamp: ''!
addKeymapEntry: aKeymapEntry at: aPlatform
	(self entriesAt: aPlatform) add: aKeymapEntry! !

!KMCategory methodsFor: 'testing' stamp: ''!
matchesCompletely: aString
	^ self keymaps anySatisfy: [ :entry | 
		entry matchesCompletely: aString ]! !

!KMCategory methodsFor: 'accessing' stamp: ''!
keymaps
	^self allEntries keymaps! !

!KMCategory methodsFor: 'printing' stamp: ''!
displayStringOn: stream
	super displayStringOn: stream.
	^ stream
		nextPut: $(;
		nextPutAll: self name asString;
		nextPut: $)! !

!KMCategory methodsFor: 'initialization' stamp: ''!
buildKeymapOnMethod: method

	self addKeymapEntry: (self perform: method selector)! !

!KMCategory methodsFor: 'associating' stamp: ''!
removeKeymapEntry: aKeymapEntry

	[ self commonEntries remove: aKeymapEntry ] 
	on: Error
	do: [ self platformEntries remove: aKeymapEntry ]! !

!KMCategory methodsFor: 'associating' stamp: ''!
hasKeymapNamed: aKeymapEntryName at: aPlatform
	^ (self entriesAt: aPlatform) hasKeymapNamed: aKeymapEntryName! !

!KMCategory methodsFor: 'binding' stamp: ''!
installAsGlobalCategory

	KMRepository default setAsGlobalCategory: self! !

!KMCategory methodsFor: 'accessing' stamp: ''!
name: aCategorySymbol 
	name := aCategorySymbol! !

!KMCategory methodsFor: 'associating' stamp: ''!
keymapNamed: aKeymapEntryName at: aPlatform
	^(self entriesAt: aPlatform) keymapNamed: aKeymapEntryName! !

!KMCategory methodsFor: 'associating' stamp: ''!
hasKeymapNamed: aKeymapEntryName
	^self allEntries hasKeymapNamed: aKeymapEntryName! !

!KMCategory methodsFor: 'accessing' stamp: ''!
entriesAt: aPlatform
	platforms ifNil: [ platforms := Dictionary new ].
	^platforms at: aPlatform ifAbsentPut: [ KMStorage new ].! !

!KMCategory methodsFor: 'binding' stamp: ''!
bindToObject: anObject andMorph: aMorph
	
	^ KMCategoryBinding target: anObject morph: aMorph category: self.! !

!KMCategory methodsFor: 'accessing' stamp: ''!
categoryName
	^ name! !

!KMCategory methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self class methods
		select: [ :m | m isShortcutDeclaration ]
		thenDo: [ :m | self buildKeymapOnMethod: m ]! !

!KMCategory methodsFor: 'associating' stamp: ''!
keymapNamed: aKeymapEntryName
	^self allEntries keymapNamed: aKeymapEntryName! !

!KMCategory methodsFor: 'associating' stamp: ''!
platformEntries
	^self entriesAt: Smalltalk os platformFamily! !

!KMCategory methodsFor: 'associating' stamp: ''!
allEntries
	^self commonEntries, self platformEntries! !

!KMCategory methodsFor: 'associating' stamp: ''!
commonEntries
	^self entriesAt: #all! !

!KMCategory methodsFor: 'binding' stamp: ''!
keymapForShortcut: aShortcut

	^ self allEntries keymapForShortcut: aShortcut! !

!KMCategory methodsFor: 'testing' stamp: ''!
matches: aString
	^ self keymaps anySatisfy: [ :entry | 
		entry matches: aString ]! !

!KMCategory methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!KMCategory methodsFor: 'associating' stamp: ''!
addKeymapEntry: aKeymapEntry 
	self commonEntries add: aKeymapEntry.! !

!KMCategory class methodsFor: 'instance creation' stamp: ''!
named: aCategorySymbol
	^ (self new)
		name: aCategorySymbol;
		yourself! !

!KMCategoryBinding commentStamp: ''!
I am the reification of the relation morph<->category, created when a morph gets attached a category of shortcuts.!
!KMCategoryBinding methodsFor: 'matching' stamp: ''!
partialMatch
	"do nothing"! !

!KMCategoryBinding methodsFor: 'iterating' stamp: ''!
nextForKmChain: aKMDispatchChain
	^self target! !

!KMCategoryBinding methodsFor: 'matching' stamp: ''!
verifyMatchWith: anEventBuffer notifying: aListener thenDoing: anAction
	self flag: #pharoFixMe. "ugly hack with array of listeners"
	category 
		onMatchWith:  anEventBuffer
		notify: { self . aListener } " first we have to tell the dispatcher "
		andDo: anAction! !

!KMCategoryBinding methodsFor: 'matching' stamp: ''!
completeMatch: aKeymap buffer: aBuffer
	KMLog logCompleteMatch: aKeymap.
	KMBuffer uniqueInstance completeMatch.
	aKeymap action cull: target value cull: morph cull: aBuffer first.! !

!KMCategoryBinding methodsFor: 'accessing' stamp: ''!
category: aCategory
	category := aCategory! !

!KMCategoryBinding methodsFor: 'accessing' stamp: ''!
category

	^ category! !

!KMCategoryBinding methodsFor: 'matching' stamp: ''!
noMatch
	"do nothing"! !

!KMCategoryBinding methodsFor: 'accessing' stamp: ''!
morph

	^ morph! !

!KMCategoryBinding methodsFor: 'accessing' stamp: ''!
morph: aMorph
	morph := aMorph! !

!KMCategoryBinding methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		print: category name;
		nextPut: $).! !

!KMCategoryBinding methodsFor: 'binding' stamp: ''!
keymapForShortcut: aKey
	
	^ category keymapForShortcut: aKey! !

!KMCategoryBinding methodsFor: 'accessing' stamp: ''!
target

	^ target! !

!KMCategoryBinding methodsFor: 'accessing' stamp: ''!
target: aTarget
	target := aTarget! !

!KMCategoryBinding class methodsFor: 'instance creation' stamp: ''!
target: aTarget morph: aMorph category: aCategory
	^self new
		target: aTarget;
		category: aCategory;
		morph: aMorph;
		yourself! !

!KMCategoryTarget commentStamp: ''!
I am the reification of the relation morph<->category, created when a morph gets attached a category of shortcuts.!
!KMCategoryTarget methodsFor: 'matching' stamp: ''!
partialMatch
	"do nothing"! !

!KMCategoryTarget methodsFor: 'iterating' stamp: ''!
nextForKmChain: aKMDispatchChain
	^self target! !

!KMCategoryTarget methodsFor: 'matching' stamp: ''!
verifyMatchWith: anEventBuffer notifying: aListener thenDoing: anAction
	self flag: #pharoFixMe. "ugly hack with array of listeners"
	category 
		onMatchWith:  anEventBuffer
		notify: { self . aListener } " first we have to tell the dispatcher "
		andDo: anAction! !

!KMCategoryTarget methodsFor: 'matching' stamp: ''!
completeMatch: aKeymap buffer: aBuffer
	KMLog logCompleteMatch: aKeymap.
	KMBuffer uniqueInstance completeMatch.
	aKeymap action cull: target value cull: morph cull: aBuffer first.! !

!KMCategoryTarget methodsFor: 'accessing' stamp: ''!
category: aCategory
	category := aCategory! !

!KMCategoryTarget methodsFor: 'accessing' stamp: ''!
category

	^ category! !

!KMCategoryTarget methodsFor: 'matching' stamp: ''!
noMatch
	"do nothing"! !

!KMCategoryTarget methodsFor: 'accessing' stamp: ''!
morph

	^ morph! !

!KMCategoryTarget methodsFor: 'accessing' stamp: ''!
morph: aMorph
	morph := aMorph! !

!KMCategoryTarget methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		print: category name;
		nextPut: $).! !

!KMCategoryTarget methodsFor: 'accessing' stamp: ''!
target

	^ target! !

!KMCategoryTarget methodsFor: 'accessing' stamp: ''!
target: aTarget
	target := aTarget! !

!KMCategoryTarget class methodsFor: 'instance creation' stamp: ''!
target: aTarget morph: aMorph category: aCategory
	^self new
		target: aTarget;
		category: aCategory;
		morph: aMorph;
		yourself! !

!KMCategoryTest commentStamp: ''!
SUnit tests for key mapping categories!
!KMCategoryTest methodsFor: 'tests' stamp: ''!
testCreateExistentCategoryFails
	| categoryToAdd |
	categoryToAdd := KMCategory named: #TestCategory.
	
	self assert: self categoryContainer categories size equals: 0.
	self categoryContainer addCategory: categoryToAdd.
	self assert: self categoryContainer categories size equals: 1.
	self should: [self categoryContainer addCategory: categoryToAdd] raise: Error! !

!KMCategoryTest methodsFor: 'tests' stamp: ''!
testAddKeymapToCategory
	| categoryToAdd entry |
	categoryToAdd := KMCategory named: #TestCategory.
	entry := KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [ "nothing" ].

	self assert: (categoryToAdd allEntries) size equals: 0.
	categoryToAdd addKeymapEntry: entry.
	self assert: (categoryToAdd allEntries) size equals: 1! !

!KMCategoryTest methodsFor: 'tests' stamp: ''!
testCreateUnexistentCategory
	| categoryToAdd |
	categoryToAdd := KMCategory named: #TestCategory.
	
	self assert: self categoryContainer categories size equals: 0.
	self categoryContainer addCategory: categoryToAdd.
	self assert: self categoryContainer categories size equals: 1.
	self assert: (self categoryContainer includesCategory: categoryToAdd)! !

!KMCategoryTest methodsFor: 'accessing' stamp: ''!
categoryContainer
	^ KMFactory keymapContainer! !

!KMCombinationTest commentStamp: ''!
SUnit tests for key combinations!
!KMCombinationTest methodsFor: 'tests' stamp: ''!
testWindowsAndUnixMetaShouldBeCtrl
	OSPlatform current isMacOS ifTrue: [ ^ self skip ].
	self assert: $n meta equals: $n ctrl.
	self assert: $n ctrl equals: $n meta.
	self assert: $n meta shift equals: $n ctrl shift.
	self assert: $n ctrl shift equals: $n meta shift! !

!KMCombinationTest methodsFor: 'tests' stamp: ''!
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: [:each | each platform]) allSatisfy: [ :p | p = #all ])! !

!KMCombinationTest methodsFor: 'tests' stamp: ''!
testPlatformDependentShortcut
	| shortcut |
	shortcut := $a ctrl win.
	
	self assert: shortcut shortcut equals: $a ctrl.
	
	self assert: shortcut platform equals: #Windows! !

!KMCombinationTest methodsFor: 'tests' stamp: ''!
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)! !

!KMCombinationTest methodsFor: 'tests' stamp: ''!
testMacDependentShortcut
	| shortcut |
	shortcut := $a ctrl mac.
	
	self assert: shortcut shortcut equals: $a ctrl.
	
	self assert: shortcut platform equals: #MacOSX! !

!KMCombinationTest methodsFor: 'tests' stamp: ''!
testMacMetaShouldBeCmd
	OSPlatform current isMacOS ifFalse: [ ^ self skip ].
	self assert: $n meta equals: $n command.
	self assert: $n command equals: $n meta.
	self assert: $n meta shift equals: $n command shift.
	self assert: $n command shift equals: $n meta shift! !

!KMCombinationTest methodsFor: 'tests' stamp: ''!
testWindowsDependentShortcut
	| shortcut |
	shortcut := $a ctrl win.
	
	self assert: shortcut shortcut equals: $a ctrl.
	
	self assert: shortcut platform equals: #Windows! !

!KMCombinationTest methodsFor: 'tests' stamp: ''!
testUnixDependentShortcut
	| shortcut |
	shortcut := $a ctrl unix.
	
	self assert: shortcut shortcut equals: $a ctrl.
	
	self assert: shortcut platform equals: #Unix! !

!KMCombinationTest methodsFor: 'tests' stamp: ''!
testShortcutIsSimpleCombination
	| shortcut |
	shortcut := $a command.
	self assert: (shortcut includes: shortcut).
	self assert: shortcut shortcut equals: shortcut! !

!KMCommandModifier commentStamp: ''!
I represent the default modifier key for the current platform, late bound to Meta or Ctrl key modifier depending on the platform.!
!KMCommandModifier methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	identifier := #k.
	name := 'Cmd'! !

!KMCommandModifier methodsFor: 'matching' stamp: ''!
matchesEvent: aKeyboardEvent
	^  aKeyboardEvent commandKeyPressed! !

!KMCommandModifier methodsFor: 'accessing' stamp: ''!
eventCode
	^ 64! !

!KMCommandModifier methodsFor: 'printing' stamp: ''!
printingPosition
	^1! !

!KMCompleteMatch commentStamp: ''!
I am an announcement raised when there is a full match between the key buffer and a shortcut.!
!KMCompleteMatch methodsFor: 'accessing' stamp: ''!
event
	^ event! !

!KMCompleteMatch methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!KMCompleteMatch methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!KMCompleteMatch methodsFor: 'accessing' stamp: ''!
event: anObject
	event := anObject! !

!KMCompleteMatch class methodsFor: 'instance creation' stamp: ''!
event: event from: source

	^ self new
		event: event;
		source: source;
		yourself! !

!KMComposedModifier commentStamp: ''!
I represent a composed key modifier. I contain a collection of modifiers that should match with a keyboard event.

Look at my superclass for a more detailed explanaition.!
!KMComposedModifier methodsFor: 'combining' stamp: ''!
modifiedBy: modifier
	modifiers add: modifier.
	self updateIdentifier.! !

!KMComposedModifier methodsFor: 'combining' stamp: ''!
shift
	modifiers add: KMModifier shift! !

!KMComposedModifier methodsFor: 'printing' stamp: ''!
printOsRepresentationOn: aStream
	| modifiersSorted |
	modifiersSorted := modifiers asSortedCollection: [ : a : b | a printingPosition < b printingPosition ].
	modifiersSorted
		do: [ :modifier| modifier printOsRepresentationOn: aStream ]
		separatedBy: [ aStream << $+ ].! !

!KMComposedModifier methodsFor: 'comparing' stamp: ''!
= aShortcut
	(aShortcut isKindOf: self class)
		ifFalse: [^ false].
	^ (aShortcut modifiers includesAll: modifiers) and: [ modifiers includesAll: aShortcut modifiers ]! !

!KMComposedModifier methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	modifiers := OrderedCollection new.! !

!KMComposedModifier methodsFor: 'comparing' stamp: ''!
hash
	^ modifiers hash! !

!KMComposedModifier methodsFor: 'combining' stamp: ''!
command
	modifiers add: KMModifier command! !

!KMComposedModifier methodsFor: 'matching' stamp: ''!
matchesEvent: aKeyboardEvent
	^ modifiers allSatisfy: [:modifier|
		modifier matchesEvent: aKeyboardEvent]! !

!KMComposedModifier methodsFor: 'combining' stamp: ''!
control
	modifiers add: KMModifier ctrl! !

!KMComposedModifier methodsFor: 'printing' stamp: ''!
symbol
	^ String streamContents: [ :stream | 
		self modifiers do: [ :e | 
			stream << e symbol ] ]! !

!KMComposedModifier methodsFor: 'printing' stamp: ''!
printOn: aStream
	modifiers
		do: [ :modifier| modifier printOn: aStream ]
		separatedBy: [ aStream << ' + ' ].! !

!KMComposedModifier methodsFor: 'combining' stamp: ''!
meta
	modifiers add: KMModifier meta! !

!KMComposedModifier methodsFor: 'accessing' stamp: ''!
updateIdentifier
	identifier := String streamContents: [ :aStream|
			modifiers do: [ :modifier| 
				aStream << modifier identifier]].
	identifier := identifier asSymbol! !

!KMComposedModifier methodsFor: 'combining' stamp: ''!
alt
	modifiers add: KMModifier alt! !

!KMComposedModifier methodsFor: 'accessing' stamp: ''!
modifiers
	^ modifiers! !

!KMComposedModifier methodsFor: 'combining' stamp: ''!
ctrl
	self control! !

!KMComposedModifier methodsFor: 'combining' stamp: ''!
+ modified
	^ modified asKeyCombination modifiedBy: self! !

!KMCtrlModifier commentStamp: ''!
I represent the Ctrl key modifier. Look at my superclass for a more detailed explanaition.!
!KMCtrlModifier methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	identifier := #c.
	name := 'Ctrl'.! !

!KMCtrlModifier methodsFor: 'matching' stamp: ''!
matchesEvent: aKeyboardEvent
	^ aKeyboardEvent controlKeyPressed! !

!KMCtrlModifier methodsFor: 'accessing' stamp: ''!
eventCode
	^16! !

!KMCtrlModifier methodsFor: 'printing' stamp: ''!
printingPosition
	^3! !

!KMDescriptionPresenter commentStamp: ''!
A KMDescription is a window showing the description of shortcuts for a specified set of symbols reprensenting KMCategories!
!KMDescriptionPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	categoryList := self newDropList.
	shortcutList := self newTable.
	actionBar := self newActionBar.

	categoryList displayBlock: [ :category | category name ].

	shortcutList
		addColumn: (SpStringTableColumn title: 'Shortcut' evaluated: #shortcut);
		addColumn: (SpStringTableColumn title: 'Name' evaluated: #name);
		addColumn: (SpStringTableColumn title: 'Description' evaluated: #description);
		beResizable.

	actionBar
		addLast:
			(SpButtonPresenter new
				action: [ self window close ];
				label: 'Close';
				yourself)! !

!KMDescriptionPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	aWindowPresenter
		title: 'Shortcuts description';
		initialExtent: 600 @ 350! !

!KMDescriptionPresenter methodsFor: 'api' stamp: ''!
categories: aCollectionOfSymbols
	categoryList items: (aCollectionOfSymbols collect: [ :e | KMRepository default categoryForName: e ])! !

!KMDescriptionPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	categoryList
		transmitTo: shortcutList
		transform: [ :category | (category entriesAt: #all) keymaps sorted: [ :keymap | keymap shortcut asString ] ascending ]! !

!KMDescriptionPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #categoryList withConstraints: [ :c | c height: 25 ];
		add: #shortcutList;
		add: #actionBar withConstraints: [ :c | c height: 25 ];
		yourself! !

!KMDescriptionPresenter class methodsFor: 'examples' stamp: ''!
example
	self new
		categories: #(GlobalShortcuts MonticelloShortcuts TextEditor);
		openWithSpec! !

!KMDispatchChain commentStamp: ''!
I am an object that controls the dispatch order of keymaps given a hierarchy of morphs.
!
!KMDispatchChain methodsFor: 'initialization' stamp: ''!
dispatcher: aDispatcher
	dispatcher := aDispatcher.
	self target: dispatcher target.! !

!KMDispatchChain methodsFor: 'dispatching' stamp: ''!
dispatch: aKeyboardEvent
	self do: [ :targetToDispatch |
		targetToDispatch dispatch: KMBuffer uniqueInstance buffer copy.
		aKeyboardEvent wasHandled ifTrue: [ ^self ].
	].
	"This should be a noMatch event"
	aKeyboardEvent wasHandled ifFalse: [ KMBuffer uniqueInstance clearBuffer ]! !

!KMDispatchChain methodsFor: 'iterating' stamp: ''!
do: aBlock
	| currentTarget |
	currentTarget := initialTarget.
	[ currentTarget isNil ]
		whileFalse: [
			aBlock value: currentTarget.
			currentTarget := currentTarget nextForKmChain: self.
		]! !

!KMDispatchChain methodsFor: 'initialization' stamp: ''!
startOn: anInitialTarget
	initialTarget := anInitialTarget.! !

!KMDispatchChain methodsFor: 'iterating' stamp: ''!
target
	^target! !

!KMDispatchChain methodsFor: 'initialization' stamp: ''!
target: aTarget
	target := aTarget! !

!KMDispatchChain class methodsFor: 'instance creation' stamp: ''!
from: anInitialTarget andDispatcher: aDispatcher
	^self new
			dispatcher: aDispatcher;
			startOn: anInitialTarget;
			yourself! !

!KMDispatchChainTest commentStamp: ''!
SUnit tests for testing the dispatch chain!
!KMDispatchChainTest methodsFor: 'tests' stamp: ''!
testPassesOnTheTarget
	| chain dispatcher passed |
	dispatcher := KMDispatcher target: Morph new.
	passed := false.
	chain := KMDispatchChain from: (KMGlobalDispatcher new) andDispatcher: dispatcher.
	chain do: [ :t | t == dispatcher target ifTrue: [ passed := true ] ].
	self assert: passed! !

!KMDispatchChainTest methodsFor: 'tests' stamp: ''!
testTargetDoesNotIterateTheNil
	| chain |
	chain := KMDispatchChain from: (KMGlobalDispatcher new) andDispatcher: (KMDispatcher new).
	chain do: [ :target | self assert: target notNil ]! !

!KMDispatchChainTest methodsFor: 'tests' stamp: ''!
testGlobalIsFirst
	| chain first |
	first := nil.
	chain := KMDispatchChain from: (KMGlobalDispatcher new) andDispatcher: (KMDispatcher new).
	chain do: [ :target | first ifNil: [ first := target ] ].
	self assert: first isGlobalDispatcher! !

!KMDispatcher commentStamp: ''!
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: 'dispatching' stamp: ''!
perInstanceTarget
	^KMCategoryBinding target: morph morph: morph category: self directKeymaps.! !

!KMDispatcher methodsFor: 'dispatching' stamp: ''!
dispatchKeystroke: aKeyEvent

	| chain |
	KMLog log: aKeyEvent.

	KMBuffer uniqueInstance addEvent: aKeyEvent.

	chain := KMDispatchChain from: (KMGlobalDispatcher new dispatcher: self; yourself) andDispatcher: self.
	chain dispatch: aKeyEvent.! !

!KMDispatcher methodsFor: 'match' stamp: ''!
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: 'building' stamp: ''!
bindKeyCombination: aShortcut toAction: anAction
	self directKeymaps 
		addKeymapEntry: (KMKeymap
			shortcut: aShortcut 
			action: anAction)! !

!KMDispatcher methodsFor: 'match' stamp: ''!
completeMatch: aKeymapEntry buffer: aBuffer
	KMLog logCompleteMatchBetween: morph and: aKeymapEntry.
	KMBuffer uniqueInstance completeMatch.
	self announcer announce: (KMCompleteMatch event: currentEvent from: self).! !

!KMDispatcher methodsFor: 'building' stamp: ''!
attachCategory: aCategory targetting: anObject
	
	|  category categoryTarget |
	category := aCategory asKmCategoryIn: KMRepository default.
	categoryTarget := category bindToObject: anObject andMorph: morph.
	self targets add: categoryTarget.! !

!KMDispatcher methodsFor: 'match' stamp: ''!
noMatch! !

!KMDispatcher methodsFor: 'building' stamp: ''!
detachKeymapCategory: aCategoryName targetting: anObject
	self targets
		detect: [ :tgt | tgt target = anObject and: [ tgt category name = aCategoryName ] ]
		ifFound: [ :categoryTarget | self targets remove: categoryTarget ]
		ifNone: [ self error: 'Category ' , aCategoryName , ' is not attached to ' , morph asString ]! !

!KMDispatcher methodsFor: 'dispatching' stamp: ''!
keymapObservers
	| o |
	o := OrderedCollection with: self perInstanceTarget.
	o addAll: self targets.
	^ o! !

!KMDispatcher methodsFor: 'building' stamp: ''!
detachKeymapCategory: aCategoryName

	self detachKeymapCategory: aCategoryName targetting: morph! !

!KMDispatcher methodsFor: 'dispatching' stamp: ''!
directKeymaps
	^directKeymaps ifNil: [ directKeymaps := KMCategory new ]! !

!KMDispatcher methodsFor: 'building' stamp: ''!
detachAllKeymapCategories

	self targets removeAll! !

!KMDispatcher methodsFor: 'building' stamp: ''!
removeKeyCombination: aShortcut
	| keymap removalTarget |

	removalTarget := self directKeymaps.
	
	keymap := self keymapForShortcut: aShortcut.
	keymap ifNil: [ 
		self targets do: [ :e | (e keymapForShortcut: aShortcut) 
			ifNotNil: [ :s | 
				removalTarget := e category.
				keymap := s ] ] ].
	keymap ifNil: [ ^ self ].
	
	removalTarget removeKeymapEntry: keymap! !

!KMDispatcher methodsFor: 'initialization' stamp: ''!
reset
	self resetTargets.
	self resetPerInstanceTarget! !

!KMDispatcher methodsFor: 'match' stamp: ''!
announcer

	^ self target announcer! !

!KMDispatcher methodsFor: 'accessing' stamp: ''!
target: aTarget
	target := aTarget.
	morph := target morph.
	"self announcer weak
		on: MorphLostFocus send: #clearBuffer to: KMBuffer uniqueInstance."! !

!KMDispatcher methodsFor: 'dispatching' stamp: ''!
targets
	^targets ifNil: [ targets := Set new ]! !

!KMDispatcher methodsFor: 'building' stamp: ''!
attachCategory: aCategory
	self attachCategory: aCategory targetting: morph! !

!KMDispatcher methodsFor: 'testing' stamp: ''!
includesKeymapCategory: aCategoryName targetting: anObject

	^self targets anySatisfy: [ :tgt | 
		tgt target = anObject and: [ tgt category name = aCategoryName ] ]! !

!KMDispatcher methodsFor: 'testing' stamp: ''!
includesKeymapCategory: aCategoryName 

	^self includesKeymapCategory: aCategoryName targetting: morph! !

!KMDispatcher methodsFor: 'building' stamp: ''!
attachCategory: aCategoryName onProperty: aProperty
	self targets add: (KMCategoryBinding 
						target: [ morph perform: aProperty ] 
						morph: morph 
						category: (KMRepository default categoryForName: aCategoryName) )! !

!KMDispatcher methodsFor: 'dispatching' stamp: ''!
dispatch: anEventBuffer inCategories: categories

	(self keymapObserversForCategories: categories) do: [ :aTarget | 
		"nice hack to stop in the first listener"
		aTarget 
			verifyMatchWith: anEventBuffer 
			notifying: self
			thenDoing: [ ^self ] ].
	self noMatch! !

!KMDispatcher methodsFor: 'dispatching' stamp: ''!
dispatch: anEventBuffer

	self keymapObservers do: [ :aTarget | 
		"nice hack to stop in the first listener"
		aTarget 
			verifyMatchWith: anEventBuffer 
			notifying: self
			thenDoing: [ ^self ] ].
	self noMatch! !

!KMDispatcher methodsFor: 'initialize' stamp: ''!
resetTargets
    targets := nil! !

!KMDispatcher methodsFor: 'building' stamp: ''!
keymapForShortcut: aShortcut

	^ self directKeymaps keymapForShortcut: aShortcut! !

!KMDispatcher methodsFor: 'dispatching' stamp: ''!
keymapObserversForCategories: categories

	^categories collect: [ :cat | KMCategoryBinding 
									target: target realTarget 
									morph: target morph 
									category: cat ].! !

!KMDispatcher methodsFor: 'match' stamp: ''!
buffer
	^ KMBuffer uniqueInstance buffer! !

!KMDispatcher methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForKeysFor: aStep
	<stSpotterOrder: 15>
		
	aStep listProcessor
			title: 'Keys';
			allCandidates: [ (self gtAllKeyCategoryPairs collect: [:each | each key]) asOrderedCollection ];
			itemName: [ :aKeymap | 
				aKeymap shortcut displayString, 
				(aKeymap name ifNil: [ '' ] ifNotNil: [ ' [', aKeymap name,']' ]) ];
			candidatesLimit: 5;
			filter: StFilterSubstring! !

!KMDispatcher methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!KMDispatcher methodsFor: 'initialize' stamp: ''!
resetPerInstanceTarget
	directKeymaps := nil! !

!KMDispatcher class methodsFor: 'instance creation' stamp: ''!
target: aTargetSelector morph: aMorph
	^ (self new)
		target: (KMTarget for: aTargetSelector in: aMorph);
		yourself! !

!KMDispatcher class methodsFor: 'instance creation' stamp: ''!
target: aTarget
	^ self target: #yourself morph: aTarget! !

!KMDispatcherTest commentStamp: ''!
SUnit tests for the key mapping dispatcher!
!KMDispatcherTest methodsFor: 'tests' stamp: ''!
testNoMultiTrigger
	| bm1 bm2 flag1 flag2 category otherCategory |
	category := KMCategory named: #TestBlah.
	otherCategory := KMCategory named: #TestFoo.
	KMRepository default addCategory: category.
	KMRepository default addCategory: otherCategory.
	
	bm1 := BorderedMorph new.
	bm1 attachKeymapCategory: #TestBlah.
	flag1 := false.

	category addKeymapEntry: (KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [flag1 := true]).
	bm2 := Morph new.
	bm2 attachKeymapCategory: #TestFoo.
	
	flag2 := false.

	otherCategory addKeymapEntry: (KMKeymap named: #Bar shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [flag2 := true]).
	bm1 addMorphBack: bm2.
	
	{self eventKey: $a. self eventKey: $b. self eventKey: $c}
		do: [:e | bm2 dispatchKeystrokeForEvent: e].
	self deny: flag1.
	self assert: flag2! !

!KMDispatcherTest methodsFor: 'tests' stamp: ''!
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! !

!KMDispatcherTest methodsFor: 'tests' stamp: ''!
testNoStaggeredTrigger
	"Once a key sequence is recognized by a keymapper, all other  
	keymappers should clear their buffers"
	| bm1 bm2 flag1 flag2 category otherCategory bufferBefore |
	
	category := KMCategory named: #TestBlah.
	otherCategory := KMCategory named: #TestFoo.
	
	KMRepository default addCategory: category.
	KMRepository default addCategory: otherCategory.
	
	bm1 := BorderedMorph new.
	bm1 attachKeymapCategory: category.
	
	flag1 := false.
	category addKeymapEntry: ( KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [flag1 := true]).

	bm2 := Morph new.
	bm2 attachKeymapCategory: otherCategory.
	flag2 := false.

	otherCategory addKeymapEntry: (KMKeymap named: #Bar shortcut: $a asKeyCombination, $b asKeyCombination action:  [flag2 := true]).
	bm1 addMorphBack: bm2.
	bufferBefore := bm2 kmDispatcher buffer copy.
	{self eventKey: $a. self eventKey: $b. self eventKey: $c}
		do: [:e | bm2 dispatchKeystrokeForEvent: e].
	flag1 ifTrue: [ bufferBefore inspect ].
	self deny: flag1.
	self assert: flag2! !

!KMDispatcherTest methodsFor: 'tests' stamp: ''!
keymapContainer
	^ KMRepository default! !

!KMDispatcherTest methodsFor: 'tests' stamp: ''!
testBuffering
	| morph flag category event1 event2 event3|
	category := KMCategory named: #TestBlah.
	KMRepository default addCategory: category.
	
	morph := BorderedMorph new.
	morph kmDispatcher reset.
	flag := false.

	category addKeymapEntry: (KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [flag := true]).
	category addKeymapEntry: (KMKeymap named: #Bar shortcut: $p asKeyCombination, $p asKeyCombination action: []).
	morph attachKeymapCategory: #TestBlah.

	event1 := self eventKey: $a.
	morph kmDispatcher
		dispatchKeystroke: event1.
	self assert: morph kmDispatcher buffer size equals: 1.
	self assert: morph kmDispatcher buffer first equals: event1.
	
	event2 := self eventKey: $b.
	morph kmDispatcher
		dispatchKeystroke: event2.
	self assert: morph kmDispatcher buffer size equals: 2.
	self assert: morph kmDispatcher buffer first equals: event1.
	self assert: morph kmDispatcher buffer second equals: event2.
	
	event3 := self eventKey: $c.
	morph kmDispatcher
		dispatchKeystroke: event3.
	self assert: morph kmDispatcher buffer isEmpty.
	
	self assert: flag! !

!KMFactory commentStamp: ''!
I am a class used to access some of the main classes of Keymapping. See my class side to have an idea of what can I give you.!
!KMFactory class methodsFor: 'accessing' stamp: ''!
keymapContainer
	^ KMRepository default! !

!KMGlobalDispatcher commentStamp: ''!
I am a dispatcher that dispatches the global keymappings.!
!KMGlobalDispatcher methodsFor: 'iterating' stamp: ''!
nextForKmChain: aKMDispatchChain 
	^aKMDispatchChain target! !

!KMGlobalDispatcher methodsFor: 'testing' stamp: ''!
isGlobalDispatcher
	^true! !

!KMGlobalDispatcher methodsFor: 'initialization' stamp: ''!
dispatcher: aDispatcher
	dispatcher := aDispatcher! !

!KMGlobalDispatcher methodsFor: 'dispatching' stamp: ''!
dispatch: anEventBuffer
	dispatcher
		dispatch: anEventBuffer
		inCategories: KMRepository default globalCategories! !

!KMKeyCombination commentStamp: ''!
I'm an abstract class representing a key combination. I'm can represent several cases of key presses:

- simple key presses: pressing a single key, as a letter or number, or others like tab or space
- modified key presses: a simple key + a modifier like shift or alt
- option key presses: a list of key presses where only one of them should be valid
- chained shortcuts: a sequence of shortcuts

My more important protocols are:

- matching: contains methods to control if a key combination is equals to other or matches a sequence of keyboard events
- combining: defines simple ways to combine shorcut objects, like chaining them or modifying them

For more information, look at my subclasses.!
!KMKeyCombination methodsFor: 'iterating' stamp: ''!
combinationsDo: aBlock
	aBlock value: self! !

!KMKeyCombination methodsFor: 'keymap building' stamp: ''!
value: aBuilder
	^ self! !

!KMKeyCombination methodsFor: 'converting' stamp: ''!
asKeyCombination
	^self! !

!KMKeyCombination methodsFor: 'comparing' stamp: ''!
= aShortcut
	^ aShortcut isKindOf: self species! !

!KMKeyCombination methodsFor: 'matching' stamp: ''!
includes: aShortcut
	^self = aShortcut! !

!KMKeyCombination methodsFor: 'comparing' stamp: ''!
hash
	^ self species hash! !

!KMKeyCombination methodsFor: 'printing' stamp: ''!
printOsRepresentationOn: aStream
	self shortcut modifier ifNotNil: [: modifier |  
		modifier printOsRepresentationOn: aStream.
		aStream << $+].
	self shortcut character printOn: aStream! !

!KMKeyCombination methodsFor: 'combining' stamp: ''!
unix
	^KMPlatformSpecificKeyCombination with: self onPlatform: #Unix! !

!KMKeyCombination methodsFor: 'combining' stamp: ''!
| aShortcut
	^KMKeyCombinationChoice withShortcuts: { self . aShortcut }! !

!KMKeyCombination methodsFor: 'matching' stamp: ''!
matchesCompletely: aKeyboardEvent
	^ self = aKeyboardEvent asKeyCombination! !

!KMKeyCombination methodsFor: 'combining' stamp: ''!
win
	^KMPlatformSpecificKeyCombination with: self onPlatform: #Windows! !

!KMKeyCombination methodsFor: 'accessing - platform' stamp: ''!
platformCharacter

	^ ''! !

!KMKeyCombination methodsFor: 'accessing' stamp: ''!
shortcut
	^self! !

!KMKeyCombination methodsFor: 'converting' stamp: ''!
asShortcut
	^ self asKeyCombination! !

!KMKeyCombination methodsFor: 'printing' stamp: ''!
printOsRepresentation
	^String streamContents: [ : stream | self printOsRepresentationOn: stream ]! !

!KMKeyCombination methodsFor: 'keymap building' stamp: ''!
named: keymapName do: anActionBlock
	^ KMKeymap
		named: keymapName
		shortcut: self
		action: anActionBlock! !

!KMKeyCombination methodsFor: 'printing' stamp: ''!
prettyPrintOn: aStream

	aStream << self shortcut modifier symbol.
	self shortcut character name printOn: aStream! !

!KMKeyCombination methodsFor: 'combining' stamp: ''!
mac
	^KMPlatformSpecificKeyCombination with: self onPlatform: #MacOSX! !

!KMKeyCombination methodsFor: 'printing' stamp: ''!
acceptVisitor: aKMShortcutPrinter 

	^ aKMShortcutPrinter visitSingleShortcut: self! !

!KMKeyCombination methodsFor: 'keymap building' stamp: ''!
named: keymapName do: anActionBlock withDescription: aDescription
	^ KMKeymap
		named: keymapName
		shortcut: self
		action: anActionBlock
		description: aDescription! !

!KMKeyCombination methodsFor: 'accessing' stamp: ''!
platform
	^#all! !

!KMKeyCombination methodsFor: 'matching' stamp: ''!
matches: anEventBuffer

	^ anEventBuffer size = 1 and:
		[self matchesCompletely: anEventBuffer first]! !

!KMKeyCombination methodsFor: 'combining' stamp: ''!
, aShortcut
	^ KMKeyCombinationSequence first: self next: aShortcut asKeyCombination! !

!KMKeyCombination methodsFor: '*Spec-Core' stamp: ''!
currentCharacter

	^ ''! !

!KMKeyCombination methodsFor: 'accessing - platform' stamp: ''!
platformModifier

	^ nil! !

!KMKeyCombination class methodsFor: 'instance creation' stamp: ''!
fromKeyboardEvent: evt
	| modifier control command shift alt |
	control := evt controlKeyPressed.
	command := evt commandKeyPressed.
	shift := evt shiftPressed.
	alt := evt altKeyPressed.
	(shift | command | control | alt)
		ifFalse: [^ evt key asKeyCombination ].
	modifier := KMNoShortcut new.
	control
		ifTrue: [ modifier := modifier + KMModifier ctrl ].
	command
		ifTrue: [ modifier := modifier + KMModifier command ].
	shift
		ifTrue: [ modifier := modifier + KMModifier shift ].
	alt
		ifTrue: [ modifier := modifier + KMModifier alt ].
	^ modifier + evt key asKeyCombination! !

!KMKeyCombination class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self == KMKeyCombination! !

!KMKeyCombinationChoice commentStamp: ''!
I representing a choice between key combinations.

A keyboard event will match with me when any of my key combinations matches with it.!
!KMKeyCombinationChoice methodsFor: 'iterating' stamp: ''!
combinationsDo: aBlock
	^shortcuts do: aBlock! !

!KMKeyCombinationChoice methodsFor: 'accessing' stamp: ''!
shortcuts: someShortcuts
	shortcuts := someShortcuts! !

!KMKeyCombinationChoice methodsFor: 'comparing' stamp: ''!
= another

	^ shortcuts anySatisfy: [ :each | another = each ]! !

!KMKeyCombinationChoice methodsFor: 'matching' stamp: ''!
includes: aShortcut
	^shortcuts includes: aShortcut! !

!KMKeyCombinationChoice methodsFor: 'printing' stamp: ''!
prettyPrintOn: aStream

	(shortcuts select:[ :e | e platform = Smalltalk os platformFamily or: [ e platform = #all ] ])
		do: [ :e | e prettyPrintOn: aStream ]
		separatedBy: [ aStream << ' | ' ]! !

!KMKeyCombinationChoice methodsFor: 'combining' stamp: ''!
| aShortcut
	^KMKeyCombinationChoice withShortcuts: (shortcuts copyWith: aShortcut)! !

!KMKeyCombinationChoice methodsFor: 'matching' stamp: ''!
matchesCompletely: anEventBuffer
	
	^ shortcuts anySatisfy: [ :each | each matchesCompletely: anEventBuffer ]! !

!KMKeyCombinationChoice methodsFor: 'accessing - platform' stamp: ''!
platformCharacter

	shortcuts do: [ :each | 
		each platformCharacter ifNotNil: [ :char | ^ char ] ].
	^ nil! !

!KMKeyCombinationChoice methodsFor: 'matching' stamp: ''!
matches: anEventBuffer
	
	^ shortcuts anySatisfy: [ :each | each matches: anEventBuffer ]! !

!KMKeyCombinationChoice methodsFor: '*Spec-Core' stamp: ''!
currentCharacter
	| candidates |
	
	candidates := shortcuts 
		collect: [ :each | each currentCharacter ] 
		thenSelect: [ :each | each isNotNil ].
		
	^ candidates 
		ifEmpty: [ nil ]
		ifNotEmpty: [ candidates first ]! !

!KMKeyCombinationChoice methodsFor: 'iterating' stamp: ''!
collect: aBlock
	^shortcuts collect: aBlock! !

!KMKeyCombinationChoice methodsFor: 'accessing - platform' stamp: ''!
platformModifier

	shortcuts do: [ :each | 
		each platformModifier ifNotNil: [ :mod | ^ mod ] ].
	^ nil! !

!KMKeyCombinationChoice class methodsFor: 'instance creation' stamp: ''!
withShortcuts: someShortcuts
	^self new
			shortcuts: someShortcuts;
			yourself! !

!KMKeyCombinationSequence commentStamp: ''!
I represent a sequence of key combinations.

In order to have a match between me and a user's key presses, all user events must match all of my inner shortcuts in the same exact order.

To create a sequence of key combinations use the #, message. Like for example:

$a command , $b shift!
!KMKeyCombinationSequence methodsFor: 'comparing' stamp: ''!
= aShortcut
	^ super = aShortcut and: [ shortcuts = aShortcut sequence ]! !

!KMKeyCombinationSequence methodsFor: 'printing' stamp: ''!
prettyPrintOn: aStream

	shortcuts 
		do: [ :e | e prettyPrintOn: aStream ]
		separatedBy: [ aStream << ' + ' ]! !

!KMKeyCombinationSequence methodsFor: 'printing' stamp: ''!
acceptVisitor: aKMShortcutPrinter 
	
	^ aKMShortcutPrinter visitCombinationShortcut: self! !

!KMKeyCombinationSequence methodsFor: 'accessing' stamp: ''!
first: aShortcut
	self addShortcut: aShortcut! !

!KMKeyCombinationSequence methodsFor: 'comparing' stamp: ''!
hash
	^ shortcuts hash! !

!KMKeyCombinationSequence methodsFor: 'accessing' stamp: ''!
next: aShortcut
	self addShortcut: aShortcut! !

!KMKeyCombinationSequence methodsFor: 'printing' stamp: ''!
printOn: aStream
	shortcuts 
		do: [ :shortcut| shortcut printOn: aStream]
		separatedBy: [ aStream nextPutAll: ' , '].! !

!KMKeyCombinationSequence methodsFor: 'matching' stamp: ''!
matches: anEventBuffer
	|maxIndex|
	maxIndex := anEventBuffer size min: shortcuts size.
	1 to: maxIndex do: [:index|
		((shortcuts at: index) = (anEventBuffer at: index) asKeyCombination)
			ifFalse: [ ^ false]].
	^ true.! !

!KMKeyCombinationSequence methodsFor: 'matching' stamp: ''!
beginsWith: aShortcut 
	
	^ self sequence first = aShortcut! !

!KMKeyCombinationSequence methodsFor: 'combining' stamp: ''!
, aShortcut
	self addShortcut: aShortcut asKeyCombination.! !

!KMKeyCombinationSequence methodsFor: 'accessing' stamp: ''!
addShortcut: aShortcut
	self sequence add: aShortcut! !

!KMKeyCombinationSequence methodsFor: 'accessing' stamp: ''!
sequence
	^ shortcuts ifNil: [ shortcuts := OrderedCollection new ]! !

!KMKeyCombinationSequence methodsFor: 'combining' stamp: ''!
+ aCharacter 
	| last |
	last := self sequence last.
	self sequence removeLast.
	self addShortcut: last + aCharacter.! !

!KMKeyCombinationSequence methodsFor: 'printing' stamp: ''!
platformModifier

	self sequence do: [ :each | ^ each platformModifier ].
	
	^ nil! !

!KMKeyCombinationSequence class methodsFor: 'instance creation' stamp: ''!
first: aShortcut next: anotherShortcut
	^ (self new)
		first: aShortcut;
		next: anotherShortcut;
		yourself! !

!KMKeymap commentStamp: ''!
I am the real keymap.  I have an action to evaluate when my keymap sequence is pressed.!
!KMKeymap methodsFor: 'accessing' stamp: ''!
shortcutHasChangedBy: aShortcut
	self defaultShortcut = self shortcut ifTrue: [ self shortcut: aShortcut ].
	self defaultShortcut: aShortcut! !

!KMKeymap methodsFor: 'comparing' stamp: ''!
= aKeymap
	self == aKeymap
		ifTrue: [ ^ true ].
	self species = aKeymap species
		ifFalse: [ ^ false ].
	^action = aKeymap action and: [ shortcut = aKeymap shortcut and: [ name = aKeymap name ] ]! !

!KMKeymap methodsFor: 'matching' stamp: ''!
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 methodsFor: 'comparing' stamp: ''!
hash
	^action hash bitXor: (shortcut hash bitXor: name hash)! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
defaultShortcut
	^defaultShortcut! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
description
	^description ifNil: [ '' ]! !

!KMKeymap methodsFor: 'matching' stamp: ''!
matchesCompletely: aShortcut
	^ self shortcut matchesCompletely: aShortcut! !

!KMKeymap methodsFor: 'printing' stamp: ''!
displayStringOn: aStream
	aStream 
		nextPutAll: self name displayString;
		nextPutAll: ' on ';
		nextPutAll: self shortcut displayString;
		nextPutAll: ' do ' ;
		nextPutAll: self action displayString! !

!KMKeymap methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		print: self name ;
		nextPutAll: ' on ';
		print: self shortcut ;
		nextPutAll: ' do ' ;
		print: self action ;
		cr.! !

!KMKeymap methodsFor: 'executing' stamp: ''!
executeActionTargetting: target
	^ self action cull: target cull: target! !

!KMKeymap methodsFor: 'matching' stamp: ''!
notifyCompleteMatchTo: aListener buffer: aBuffer
	| listeners |
	aListener isCollection ifTrue: [ listeners := aListener ] ifFalse: [ listeners := { aListener } ].
	listeners do: [ :l | l completeMatch: self buffer: aBuffer ].! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
name: aName
	name := aName! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
shortcut
	^ shortcut! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
hasName
	^name notNil! !

!KMKeymap methodsFor: 'initialization' stamp: ''!
reset

	self shortcut: self defaultShortcut.! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
action: anAction
	action := anAction! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
shortcut: aShortcut
	shortcut := aShortcut.! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
key
	^ name! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
action
	^ action! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
defaultShortcut: aShortcut
	defaultShortcut := aShortcut.! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
description: aDescription
	description := aDescription asString! !

!KMKeymap methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
disable

	self shortcut: KMNoShortcut new.! !

!KMKeymap methodsFor: 'matching' stamp: ''!
notifyPartialMatchTo: aListener
	| listeners |

	listeners := aListener isCollection 
		ifTrue: [ aListener ] 
		ifFalse: [ { aListener } ].
	listeners do: [ :each | each partialMatch ]! !

!KMKeymap methodsFor: 'matching' stamp: ''!
matches: anEventBuffer

	^ anEventBuffer
		ifEmpty: [ false ]
		ifNotEmpty: [ self shortcut matches: anEventBuffer ]! !

!KMKeymap methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!KMKeymap class methodsFor: 'instance creation' stamp: ''!
named: keymapName shortcut: aShortcut action: anAction
	^ (self new)
		name: keymapName;
		defaultShortcut: aShortcut;
		shortcut: aShortcut;
		action: anAction;
		yourself! !

!KMKeymap class methodsFor: 'instance creation' stamp: ''!
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: ''!
shortcut: aShortcut action: anAction
	^ (self new)
		defaultShortcut: aShortcut;
		shortcut: aShortcut;
		action: anAction;
		yourself! !

!KMKeymapBuilder commentStamp: ''!
I am a specific builder to configure one shortcut.!
!KMKeymapBuilder methodsFor: 'building' stamp: ''!
category: aCategoryName shortcut: aShortcutCombination do: actionBlock description: aDescription
	"actionBlock - can take 3 optional arguments: target, morph, and keyboard event"
	aShortcutCombination combinationsDo: [ :combination |
		KMRepository default
			initializeKeymap: shortcutName
			executingOn: combination shortcut
			doing: actionBlock
			inCategory: aCategoryName
			platform: combination platform
			description: aDescription
	]! !

!KMKeymapBuilder methodsFor: 'accessing' stamp: ''!
platform: aPlatform
	platform := aPlatform! !

!KMKeymapBuilder methodsFor: 'building' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
shortcutName: aShortcutName
	shortcutName := aShortcutName! !

!KMKeymapBuilder methodsFor: 'building' stamp: ''!
category: aCategoryName default: aShortcut do: anAction description: aDescription
	KMRepository default
		initializeKeymap: shortcutName
		executingOn: aShortcut
		doing: anAction
		inCategory: aCategoryName
		platform: platform
		description: aDescription! !

!KMKeymapBuilder class methodsFor: 'instance creation' stamp: ''!
for: aShortcutName platform: aPlatform
	^self new 
		shortcutName: aShortcutName;
		platform: aPlatform;
		yourself! !

!KMKeymapBuilderTest commentStamp: ''!
SUnit tests for key map builder!
!KMKeymapBuilderTest methodsFor: 'tests' stamp: ''!
testAddKeymapCreatesShortcut
	KMRepository default
		initializeKeymap: #test
		executingOn: $r ctrl, $r asKeyCombination, $r asKeyCombination
		doing: [ :receiver | "nothing" ]
		inCategory: #Testing
		platform: #all.
	
	self assert: (KMRepository default categoryForName: #Testing) allEntries size equals: 1! !

!KMKeymapBuilderTest methodsFor: 'tests' stamp: ''!
testAttachKeymapAndExecuteExecutes
	| executed morphToTest |
	executed := false.
	
	KMFactory keymapContainer
		initializeKeymap: #test
		executingOn: $a asKeyCombination, $a asKeyCombination, $a asKeyCombination
		doing: [ :receiver | executed := true ]
		inCategory: #Testing
		platform: #all.

	"KMFactory keymapContainer attachCategoryName: #Testing to: Morph."
	
	morphToTest := Morph new.
	morphToTest attachKeymapCategory: #Testing.
	
	{self eventKey: $a. self eventKey: $a. self eventKey: $a}
		do: [:e | morphToTest dispatchKeystrokeForEvent: e].
		
	self assert: executed! !

!KMKeymapBuilderTest methodsFor: 'tests' stamp: ''!
testAddKeymapCreatesCategory
	self assertEmpty: KMRepository default categories.

	KMRepository default
		initializeKeymap: #test
		executingOn: $r ctrl , $r asKeyCombination , $r asKeyCombination
		doing: [ :receiver | "nothing" ]
		inCategory: #Testing
		platform: #all.

	self assert: (KMRepository default includesCategoryNamed: #Testing).
	self assert: KMRepository default categories size equals: 1! !

!KMKeymapTest commentStamp: ''!
SUnit tests for the key map!
!KMKeymapTest methodsFor: 'tests' stamp: ''!
keymapContainer
	^ KMRepository default! !

!KMKeymapTest methodsFor: 'tests' stamp: ''!
testExecute
	| bm flag category |
	category := KMCategory named: #TestFoo.
	KMRepository default addCategory: category.
	bm := Morph new.
	bm attachKeymapCategory: #TestFoo.
	flag := false.
	category
		addKeymapEntry:
			(KMKeymap named: #Foo shortcut: $a asKeyCombination , $b asKeyCombination , $c asKeyCombination action: [ flag := true ]).
	category addKeymapEntry: (KMKeymap named: #Bar shortcut: $p asKeyCombination , $p asKeyCombination action: [  ]).
	{(self eventKey: $a).
	(self eventKey: $b).
	(self eventKey: $c)} do: [ :e | bm dispatchKeystrokeForEvent: e ].
	self assert: flag! !

!KMKeymapTest methodsFor: 'tests' stamp: ''!
testMatching
	| category blockAction a b c p|
	
	a := self eventKey: $a.
	b := self eventKey: $b.
	c := self eventKey: $c.
	p := self eventKey: $p.
	
	blockAction := [self error: 'error'].
	
	category := KMCategory named: #testCategory.
	category addKeymapEntry:  (KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: blockAction).
	category addKeymapEntry:  (KMKeymap named: #Fum shortcut: $p asKeyCombination, $p asKeyCombination action: blockAction).

	self assert: (category matches: {a}).
	self deny: (category matches: {b}).
	self assert: (category matches: {a. b}).
	self assert: (category matchesCompletely: {a. b. c}).
	self assert: (category matches: {p}).
	self assert: (category matchesCompletely: {p. p.}).
	self deny: (category matches: {a. p. p}).
	self deny: (category matches: {self eventKey: $l. self eventKey: $m. self eventKey: $n. self eventKey: $o})! !

!KMLog commentStamp: ''!
I am a simple log utility that can be enabled by sending the #setDebug and disabled by using #removeDebug. I trace the keymapping events.!
!KMLog class methodsFor: 'debugging' stamp: ''!
removeDebug
	<script>
	debug := false! !

!KMLog class methodsFor: 'class initialization' stamp: ''!
initialize 
	debug := false! !

!KMLog class methodsFor: 'logging' stamp: ''!
log: aKeyEvent
	debug 	ifFalse: [ ^ self ].
	self traceCr: aKeyEvent printString! !

!KMLog class methodsFor: 'debugging' stamp: ''!
setDebug
	<script>
	debug := true! !

!KMLog class methodsFor: 'logging' stamp: ''!
logPartialMatch: anEvent
	debug 
		ifFalse: [ ^ self ].
	self traceCr: 'Partial match: ' , anEvent printString! !

!KMLog class methodsFor: 'logging' stamp: ''!
logCompleteMatch: aKeymap
	debug
		ifFalse: [ ^ self ].
	self traceCr: 'Complete match: ' , aKeymap printString! !

!KMLog class methodsFor: 'logging' stamp: ''!
logCompleteMatchBetween: aMorph and: aKeymap
	debug 
		ifFalse: [ ^ self ].
	self
		traceCr: aMorph printString , ' Complete match: ' , aKeymap printString! !

!KMMetaModifier commentStamp: ''!
I represent the Meta or Command key modifier. Look at my superclass for a more detailed explanaition.!
!KMMetaModifier methodsFor: 'printing' stamp: ''!
printOsRepresentationOn: aStream
	aStream << Smalltalk os menuShortcutModifierString! !

!KMMetaModifier methodsFor: 'comparing' stamp: ''!
= aShortcut

	^ aShortcut = OSPlatform current defaultModifier! !

!KMMetaModifier methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	identifier := #m.
	name := 'Meta'.! !

!KMMetaModifier methodsFor: 'comparing' stamp: ''!
hash
	"We should change the implementation of shortcuts to not use = for matching"
	| tmp |
	tmp :=  identifier hash.
	^ tmp! !

!KMMetaModifier methodsFor: 'accessing' stamp: ''!
identifier

	^ OSPlatform current defaultModifier identifier! !

!KMMetaModifier methodsFor: 'matching' stamp: ''!
matchesEvent: aKeyboardEvent
	^ OSPlatform current defaultModifier matchesEvent: aKeyboardEvent! !

!KMMetaModifier methodsFor: 'accessing' stamp: ''!
eventCode

	^ OSPlatform current defaultModifier eventCode! !

!KMMetaModifier methodsFor: 'matching' stamp: ''!
matches: aKeyboardEvent
	^ aKeyboardEvent asKeyCombination modifier = OSPlatform current defaultModifier! !

!KMMetaModifier methodsFor: 'printing' stamp: ''!
printingPosition
	^1! !

!KMModifiedKeyCombination commentStamp: ''!
I represent key combinations combining a single key + a modifier.

The modifier could be a single modifier key (look at my subclasses) or a combination of them. For example, valid modified key combinations could be:

- shift + a
- ctrl + shift + c

To create a modified key combinations use the #command, #alt, #control or #shift messages. Like for example:

$a command
$b shift
$1 control
$z alt!
!KMModifiedKeyCombination methodsFor: 'combining' stamp: ''!
modifiedBy: aModifier
	^self character asKeyCombination modifiedBy: modifier + aModifier.! !

!KMModifiedKeyCombination methodsFor: 'combining' stamp: ''!
shift
	^ self modifiedBy: KMModifier shift! !

!KMModifiedKeyCombination methodsFor: 'accessing' stamp: ''!
character
	^ character! !

!KMModifiedKeyCombination methodsFor: 'comparing' stamp: ''!
= aShortcut
	super = aShortcut
		ifFalse: [ ^ false ]. 
	 modifier = aShortcut modifier
		ifFalse: [ ^ false ].
	aShortcut character = character
		ifFalse: [ ^ false ].
	^ true! !

!KMModifiedKeyCombination methodsFor: 'accessing' stamp: ''!
modifier
	^ modifier! !

!KMModifiedKeyCombination methodsFor: 'comparing' stamp: ''!
hash
	^ character hash + modifier hash! !

!KMModifiedKeyCombination methodsFor: 'accessing' stamp: ''!
character: aCharacter 
	character := aCharacter.! !

!KMModifiedKeyCombination methodsFor: 'combining' stamp: ''!
command
	^ self modifiedBy: KMModifier command! !

!KMModifiedKeyCombination methodsFor: 'accessing' stamp: ''!
key

	^ self character key.! !

!KMModifiedKeyCombination methodsFor: 'matching' stamp: ''!
matchesEvent: aKeyboardEvent

	^ (self modifier matchesEvent: aKeyboardEvent) 
		and: [self character matchesEvent: aKeyboardEvent]! !

!KMModifiedKeyCombination methodsFor: 'combining' stamp: ''!
control
	^ self modifiedBy: KMModifier ctrl! !

!KMModifiedKeyCombination methodsFor: 'printing' stamp: ''!
printOn: aStream
	modifier printOn: aStream.
	aStream << ' + '.
	character printOn: aStream.! !

!KMModifiedKeyCombination methodsFor: 'combining' stamp: ''!
meta
	^ self modifiedBy: KMModifier meta! !

!KMModifiedKeyCombination methodsFor: 'accessing - platform' stamp: ''!
platformCharacter
	
	^ self character key! !

!KMModifiedKeyCombination methodsFor: 'matching' stamp: ''!
beginsWith: aKMShortcut 

	^ self = aKMShortcut! !

!KMModifiedKeyCombination methodsFor: 'combining' stamp: ''!
alt
	^ self modifiedBy: KMModifier alt! !

!KMModifiedKeyCombination methodsFor: 'accessing' stamp: ''!
modifier: aModifier
	modifier := aModifier! !

!KMModifiedKeyCombination methodsFor: '*Spec-Core' stamp: ''!
currentCharacter
	
	^ self character key! !

!KMModifiedKeyCombination methodsFor: 'combining' stamp: ''!
ctrl
	^ self control! !

!KMModifiedKeyCombination methodsFor: 'accessing - platform' stamp: ''!
platformModifier
	
	^ self modifier! !

!KMModifiedKeyCombination class methodsFor: 'instance creation' stamp: ''!
modifier: aModifier character: aCharacter
	^ (self new)
		modifier: aModifier;
		character: aCharacter;
		yourself! !

!KMModifier commentStamp: ''!
I'm an abstract class representing a key modifier. A modifier is a key that is pressed to modify the value of a following key. For example, valid modifiers are Alt, Ctrl, Cmd (only for macosx), Shift. Additionally, I could be a composed modifier, combining several of the named above. For example, I could have a value of Alt + Ctrl.!
!KMModifier methodsFor: 'combining' stamp: ''!
modifiedBy: modifier
	^ KMComposedModifier new
		modifiedBy: modifier;
		modifiedBy: self;
		yourself! !

!KMModifier methodsFor: 'printing' stamp: ''!
printOsRepresentationOn: aStream
	aStream << name asLowercase! !

!KMModifier methodsFor: 'comparing' stamp: ''!
= aShortcut
	super = aShortcut
		ifFalse: [ ^ false ].
	^ aShortcut eventCode = self eventCode! !

!KMModifier methodsFor: 'comparing' stamp: ''!
hash
	^ self eventCode hash! !

!KMModifier methodsFor: 'accessing' stamp: ''!
identifier
	^ identifier! !

!KMModifier methodsFor: 'matching' stamp: ''!
matchesEvent: aKeyboardEvent
	self subclassResponsibility! !

!KMModifier methodsFor: 'comparing' stamp: ''!
species

	^ KMModifier! !

!KMModifier methodsFor: 'printing' stamp: ''!
symbol
	^ '⌘'! !

!KMModifier methodsFor: 'accessing' stamp: ''!
eventCode
	"No modifiers"
	
	^ 0.! !

!KMModifier methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream << name! !

!KMModifier methodsFor: 'matching' stamp: ''!
matches: aKeyboardEvent
	self shouldNotImplement! !

!KMModifier methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!KMModifier methodsFor: 'printing' stamp: ''!
printingPosition
	^self subclassResponsibility! !

!KMModifier methodsFor: 'combining' stamp: ''!
+ modifier
	^ modifier asKeyCombination modifiedBy: self! !

!KMModifier class methodsFor: 'instance creation' stamp: ''!
shift
	^ KMShiftModifier new! !

!KMModifier class methodsFor: 'instance creation' stamp: ''!
command
	^ KMCommandModifier new! !

!KMModifier class methodsFor: 'instance creation' stamp: ''!
control
	^ KMCtrlModifier new! !

!KMModifier class methodsFor: 'instance creation' stamp: ''!
meta
	^ KMMetaModifier new! !

!KMModifier class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == KMModifier! !

!KMModifier class methodsFor: 'instance creation' stamp: ''!
alt
	^ KMAltModifier new! !

!KMModifier class methodsFor: 'instance creation' stamp: ''!
ctrl
	^ KMCtrlModifier new! !

!KMNamedCharKeyCombination commentStamp: ''!
Similar to KMUntypeableSingleKeyCombination I am used for special keys that don't only rely on their key character.

The difference to KMUntypeableSingleKeyCombination is that I am
typeable but in shortcut descriptions I use a special name for my character. 

For example, a key combnation for the space key is a KMNamedCharKeyCombination and will be printed as
"Shift + SPACE"
rather than
"Shift +  " !
!KMNamedCharKeyCombination methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!KMNamedCharKeyCombination methodsFor: 'accessing' stamp: ''!
name: aSymbol
	name := aSymbol! !

!KMNamedCharKeyCombination class methodsFor: 'instance creation' stamp: ''!
space
	^ self
		key: Character space
		name: 'Space'! !

!KMNamedCharKeyCombination class methodsFor: 'instance creation' stamp: ''!
key: aCharacter name: aString 
	^ self new
		key: aCharacter;
		name: aString;
		yourself! !

!KMNamedCharKeyCombination class methodsFor: 'initialization' stamp: ''!
newSpecialKeys
"Build a new dictionary that maps untypable characters to symbols for instacation creation methods on this class. For now, only for SPACE Key"
	| dictionary |
	dictionary := Dictionary new.
	#(#space) do: [ :symbol | dictionary at: (Character perform: symbol) put: symbol ].
	^ dictionary! !

!KMNamedCharKeyCombination class methodsFor: 'accessing' stamp: ''!
specialKeys
	^ specialKeys ifNil: [ specialKeys := self newSpecialKeys ]! !

!KMNamedCharKeyCombination class methodsFor: 'testing' stamp: ''!
ifSpecialKey: aCharacter do: aBlock
	"Lookup if aCharacter needs to be handled by me, if so use one of the instance creation function for creating the corresponding KeyCombination."
	 self specialKeys at: aCharacter ifPresent: [ :symbol |
		aBlock value: (self perform: symbol) ]! !

!KMNoKeymap commentStamp: ''!
I am a Null object representing the absence of a Keymap.!
!KMNoKeymap methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
shortcut
	^ KMNoShortcut new! !

!KMNoModifier commentStamp: ''!
I represent the absense of a key modifier. I fulfill the role of a null pattern, having as default no printing and not matching.!
!KMNoModifier methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	identifier := #''.
	name := ''.! !

!KMNoShortcut commentStamp: ''!
I do not match with any keyboard event.

I respond to the Null object pattern, since I represent the inexistance of a key combination.!
!KMNoShortcut methodsFor: 'matching' stamp: ''!
matchesCompletely: anEventBuffer
	^ false! !

!KMNoShortcut methodsFor: 'printing' stamp: ''!
printOn: aStream! !

!KMNoShortcut methodsFor: 'matching' stamp: ''!
matches: anEventBuffer
	^ false! !

!KMNoShortcut methodsFor: 'combining' stamp: ''!
, aShortcut
	^ aShortcut! !

!KMNoShortcut methodsFor: 'combining' stamp: ''!
+ aKMModifier
	^ aKMModifier! !

!KMOSXShortcutPrinter commentStamp: ''!
I'm an util to convert a shortcut into the representation used in OSX
!
!KMOSXShortcutPrinter methodsFor: 'visiting' stamp: ''!
mapSpecialCharacter: char 

	char = KeyboardKey enter ifTrue: [ ^ self class symbolTableAt: #Enter ifAbsent: [ 'Enter' ] ].	
	(char = (KeyboardKey fromCharacter: Character space))
		ifTrue: [ ^ self class symbolTableAt: #Space ifAbsent: [ 'Space' ] ].	
	^ char name asUppercase! !

!KMOSXShortcutPrinter methodsFor: 'visiting' stamp: ''!
basicModifierStringsOf: aShortcut

	| list |
	list := super basicModifierStringsOf: aShortcut.
	list replaceAll: 'Meta' with: 'Cmd'.
	^ list! !

!KMOSXShortcutPrinter methodsFor: 'visiting' stamp: ''!
visitSingleShortcut: aShortcut

	| keyParts symbols char |
	keyParts := self shortcutModifiersOf: aShortcut.
	symbols := keyParts inject: '' into: [ :s :each | 
		           s , (self class
			            symbolTableAt: each
			            ifAbsent: [ each capitalized ]) ].
	char := self mapSpecialCharacter: aShortcut platformCharacter.
	^ symbols , char asString! !

!KMPartialMatch commentStamp: ''!
A KMPartialMatch is an announcement raised when a partial match is completed!
!KMPartialMatch methodsFor: 'accessing' stamp: ''!
event
	^ event! !

!KMPartialMatch methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!KMPartialMatch methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!KMPartialMatch methodsFor: 'accessing' stamp: ''!
event: anObject
	event := anObject! !

!KMPartialMatch class methodsFor: 'instance creation' stamp: ''!
event: event from: source

	^ self new
		event: event;
		source: source;
		yourself! !

!KMPerInstanceTest commentStamp: ''!
SUnit tests for key mapping per instance!
!KMPerInstanceTest methodsFor: 'tests' stamp: ''!
testAddMoreThanOneHandler
	| flag morph |
	flag := 0.
	morph := Morph new.
	morph on: $i do: [ flag := flag + 1 ].
	morph on: $j do: [ flag := flag + 6 ].
	{ self eventKey: $i. self eventKey: $j }
		do: [:e | morph dispatchKeystrokeForEvent: e].
	self assert: flag equals: 7! !

!KMPlatformSpecificKeyCombination commentStamp: ''!
I represent a platform specific key combination, one that should only be launched for a particular platform such as windows, unix or mac.

I'm a sort of decorator of a key combination.!
!KMPlatformSpecificKeyCombination methodsFor: 'iterating' stamp: ''!
combinationsDo: aBlock
	aBlock value: self! !

!KMPlatformSpecificKeyCombination methodsFor: 'comparing' stamp: ''!
= aShortcut
	platform = aShortcut platform
		ifFalse: [ ^ false ].
	^ shortcut = aShortcut shortcut! !

!KMPlatformSpecificKeyCombination methodsFor: 'accessing' stamp: ''!
platform: aPlatform
	platform := aPlatform! !

!KMPlatformSpecificKeyCombination methodsFor: 'comparing' stamp: ''!
hash
	^ platform hash bitXor: shortcut hash! !

!KMPlatformSpecificKeyCombination methodsFor: 'printing' stamp: ''!
prettyPrintOn: aStream

	self platform = #MacOSX
		ifTrue: [ shortcut prettyPrintOn: aStream ]
		ifFalse: [ shortcut printOn: aStream ]! !

!KMPlatformSpecificKeyCombination methodsFor: 'accessing' stamp: ''!
shortcut: aShortcut
	shortcut := aShortcut! !

!KMPlatformSpecificKeyCombination methodsFor: 'combining' stamp: ''!
| aShortcut
	^KMKeyCombinationChoice withShortcuts: { self . aShortcut }! !

!KMPlatformSpecificKeyCombination methodsFor: 'testing' stamp: ''!
matchesCompletely: aCollection

	self platform == Smalltalk os platformFamily ifFalse: [ ^ false ].	
	^ self shortcut matchesCompletely: aCollection! !

!KMPlatformSpecificKeyCombination methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream << ' ('.
	shortcut printOn: aStream.
	aStream << ' on '.
	aStream print: platform.
	aStream << ')'! !

!KMPlatformSpecificKeyCombination methodsFor: 'accessing' stamp: ''!
platform
	^platform! !

!KMPlatformSpecificKeyCombination methodsFor: 'testing' stamp: ''!
matches: aCollection

	self platform == Smalltalk os platformFamily ifFalse: [ ^ false ].	
	^ self shortcut matches: aCollection! !

!KMPlatformSpecificKeyCombination methodsFor: 'accessing - platform' stamp: ''!
platformCharacter

	^ (self platform = #all or: [ self platform = OSPlatform current platformFamily ])
		ifTrue: [ self shortcut platformCharacter ]
		ifFalse: [ nil ]! !

!KMPlatformSpecificKeyCombination methodsFor: 'accessing' stamp: ''!
shortcut
	^shortcut! !

!KMPlatformSpecificKeyCombination methodsFor: '*Spec-Core' stamp: ''!
currentCharacter

	^ (self platform = #all or: [ self platform = OSPlatform current platformFamily ])
		ifTrue: [ self shortcut currentCharacter ]
		ifFalse: [ nil ]! !

!KMPlatformSpecificKeyCombination methodsFor: 'accessing - platform' stamp: ''!
platformModifier

	^ (self platform = #all or: [ self platform = OSPlatform current platformFamily ])
		ifTrue: [ self shortcut platformModifier ]
		ifFalse: [ nil ]! !

!KMPlatformSpecificKeyCombination class methodsFor: 'instance creation' stamp: ''!
with: aShortcut onPlatform: aPlatform
	^self new
			shortcut: aShortcut;
			platform: aPlatform;
			yourself! !

!KMPragmaKeymapBuilder commentStamp: ''!
I am a singleton object, subscribed to system events, to listen to the creation of methods marked with the <keymap> and keymap:> pragmas.

When I listen one of those events, I reinitialize the KMRepository default instance and reload it with all declared keymaps.!
!KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: ''!
itemReceiver
	^ model! !

!KMPragmaKeymapBuilder methodsFor: 'registrations handling' stamp: ''!
collectRegistrations
	| menu |
	menu := PragmaMenuAndShortcutRegistration model: self.
	self pragmas
		do: [ :prg | 
			prg methodClass instanceSide
				perform: prg methodSelector
				with:
					(menu
						platform: prg arguments;
						yourself) ].
	self interpretRegistration: menu! !

!KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: ''!
pragmaKeywords
	"Returns the pragmas keyword used to select pragmas"
	^  self class pragmas! !

!KMPragmaKeymapBuilder methodsFor: 'private' stamp: ''!
interpretRegistration: aRegistration
	
	aRegistration handOutItems do: [:item || node |
		node := KMKeymapBuilder 
					for: item shortcut
					platform: item platform.
		item help 
			ifNil: [
				node
					category: item category
					shortcut: item default
					do: item action ]
			ifNotNil:[ 
				node
					category: item category
					shortcut: item default
					do: item action
					description: item help ]]! !

!KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: ''!
builder
	^ self! !

!KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!KMPragmaKeymapBuilder methodsFor: 'dependencies' stamp: ''!
release
	model := nil.
	super release.! !

!KMPragmaKeymapBuilder methodsFor: 'initialization' stamp: ''!
reset
	self collectRegistrations! !

!KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!KMPragmaKeymapBuilder methodsFor: 'registrations handling' stamp: ''!
pragmas

	"Return all pragmas which keyword is self pragmaKeyword"

	^ (self pragmaKeywords flatCollect: [ :each | Pragma allNamed: each ]) 
		  select: [ :prg | prg methodSelector numArgs = 1 ]! !

!KMPragmaKeymapBuilder class methodsFor: 'instance creation' stamp: ''!
initialize
	<script>
	self uniqueInstance reset! !

!KMPragmaKeymapBuilder class methodsFor: 'private' stamp: ''!
methodAnnouncementReceived: anAnnouncement
	| method |
	method := anAnnouncement methodAffected.
	method ifNil: [ ^self ].
	method hasPragma ifFalse: [ ^self ].
	(method pragmas anySatisfy: [:pragma | self pragmas includes: pragma selector] )
		ifTrue: [ self uniqueInstance reset ]! !

!KMPragmaKeymapBuilder class methodsFor: 'instance creation' stamp: ''!
uniqueInstance
	^UniqueInstace ifNil: [ UniqueInstace := self new ]! !

!KMPragmaKeymapBuilder class methodsFor: 'instance creation' stamp: ''!
release
	SystemAnnouncer uniqueInstance unsubscribe: self.
	self uniqueInstance release! !

!KMPragmaKeymapBuilder class methodsFor: 'system-events' stamp: ''!
registerInterestToSystemAnnouncement
	<systemEventRegistration>
	SystemAnnouncer uniqueInstance 
		unsubscribe: self.
	SystemAnnouncer uniqueInstance weak 
		when: MethodAdded, MethodModified, MethodRemoved 
		send: #methodAnnouncementReceived: 
		to: self.! !

!KMPragmaKeymapBuilder class methodsFor: 'instance creation' stamp: ''!
pragmas
	^#(#keymap #keymap:)! !

!KMRepository commentStamp: ''!
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: 'keymaps' stamp: ''!
attach: aCategory to: aClass
	(self categoryHolders includesKey: aClass) 
		ifFalse: [ self categoryHolders at: aClass put: Set new ].
	
	(self categoryHolders at: aClass) add: aCategory! !

!KMRepository methodsFor: 'accessing' stamp: ''!
categories
	^ categories ifNil: [ categories := Dictionary new ]! !

!KMRepository methodsFor: 'keymaps' stamp: ''!
attachCategoryName: aCategorySymbol to: aClass 
	self attach: (self ensureCategoryByName: aCategorySymbol) to: aClass.! !

!KMRepository methodsFor: 'testing' stamp: ''!
includesCategory: aCategory
	^ self categories includes: aCategory! !

!KMRepository methodsFor: 'accessing' stamp: ''!
initializeKeymap: shortcutName executingOn: shortcut doing: action inCategory: categoryName platform: aPlatform description: aDescription
	| category entry |
	category := self ensureCategoryByName: categoryName.
	(category hasKeymapNamed: shortcutName at: aPlatform) not
		ifTrue: [
			entry := shortcut asKeyCombination named: shortcutName do: action withDescription: aDescription.
			category addKeymapEntry: entry at: aPlatform.
			]
		ifFalse:[
			entry := category keymapNamed: shortcutName at: aPlatform.
			entry shortcutHasChangedBy: shortcut asKeyCombination.
			entry action: action.
			entry description: aDescription
			]! !

!KMRepository methodsFor: 'associating' stamp: ''!
addCategory: aCategory
	(self includesCategory: aCategory)
		ifTrue: [ self error: 'a Category named ' , aCategory name, ' already exists.' ].
	self categories at: aCategory name put: aCategory.! !

!KMRepository methodsFor: 'global' stamp: ''!
setAsGlobalCategory: aGlobalCategory
	| category |
	category := aGlobalCategory asKmCategoryIn: self.
	(self globalCategories includes: category)
		ifFalse: [ self globalCategories add: category ]! !

!KMRepository methodsFor: 'accessing' stamp: ''!
categoryHolders
	^ categoryHolders ifNil: [ categoryHolders := Dictionary new ]! !

!KMRepository methodsFor: 'accessing' stamp: ''!
categoryForName: aCategorySymbol
	^ self categories at: aCategorySymbol ifAbsentPut: [ KMCategory named: aCategorySymbol ]! !

!KMRepository methodsFor: 'accessing' stamp: ''!
initializeKeymap: shortcutName executingOn: shortcut doing: action inCategory: categoryName platform: aPlatform
	^self initializeKeymap: shortcutName executingOn: shortcut doing: action inCategory: categoryName platform: aPlatform description: ''! !

!KMRepository methodsFor: 'testing' stamp: ''!
includesCategoryNamed: aCategorySymbol
	^ self categories includesKey: aCategorySymbol! !

!KMRepository methodsFor: 'accessing' stamp: ''!
ensureCategoryByName: aCategorySymbol
	| category |
	(self includesCategoryNamed: aCategorySymbol)
		ifFalse: [ 
			category := KMCategory named: aCategorySymbol.
			self addCategory: category ]
		ifTrue: [ category := self categoryForName: aCategorySymbol ].
	^ category! !

!KMRepository methodsFor: 'global' stamp: ''!
globalCategories
	^globalCategories ifNil: [ globalCategories := OrderedCollection new ]! !

!KMRepository methodsFor: 'accessing' stamp: ''!
keymapNamed: aKeymapName inCategory: aKeymapCategory
	^ (self categoryForName: aKeymapCategory) keymapNamed: aKeymapName! !

!KMRepository class methodsFor: 'instance creation' stamp: ''!
default
	^ Singleton ifNil: [ Singleton := self new ]! !

!KMRepository class methodsFor: 'class initialization' stamp: ''!
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 currentWorld setProperty: #kmDispatcher toValue: nil.
	self default: self new.
	KMCategory allSubclasses
		select: [ :c | c isGlobalCategory ]
		thenDo: [ :c | c new installAsGlobalCategory ].
	KMPragmaKeymapBuilder uniqueInstance reset.! !

!KMRepository class methodsFor: 'instance creation' stamp: ''!
default: aDefault
	^ Singleton := aDefault! !

!KMRepository class methodsFor: '*Keymapping-Pragmas' stamp: ''!
cleanUp
	self reset! !

!KMShiftModifier commentStamp: ''!
I represent the Shift key modifier. Look at my superclass for a more detailed explanaition.!
!KMShiftModifier methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	identifier := #s.
	name := 'Shift'.! !

!KMShiftModifier methodsFor: 'matching' stamp: ''!
matchesEvent: aKeyboardEvent
	^ aKeyboardEvent shiftPressed! !

!KMShiftModifier methodsFor: 'accessing' stamp: ''!
eventCode
	^8! !

!KMShiftModifier methodsFor: 'printing' stamp: ''!
printingPosition
	^4! !

!KMShortcutDeclaration commentStamp: ''!
I represent a shortcut declaration for the settings pharo framework.!
!KMShortcutDeclaration methodsFor: 'accessing' stamp: ''!
realValue: aShortcut
	self realValue accept: aShortcut.! !

!KMShortcutDeclaration methodsFor: 'accessing' stamp: ''!
defaultValue
	^self realValue defaultShortcut! !

!KMShortcutDeclaration methodsFor: 'accessing' stamp: ''!
categoryName: aCategoryName
	categoryName := aCategoryName! !

!KMShortcutDeclaration methodsFor: 'accessing' stamp: ''!
realValue
	"Answer the value of realValue"

	^ declaration
		ifNil: [
			declaration := KMShortcutSetting for: self shortcutName in: self categoryName]! !

!KMShortcutDeclaration methodsFor: 'accessing' stamp: ''!
shortcutName: aShortcutName
	shortcutName := aShortcutName! !

!KMShortcutDeclaration methodsFor: 'accessing' stamp: ''!
shortcutName
	^shortcutName! !

!KMShortcutDeclaration methodsFor: 'accessing' stamp: ''!
categoryName
	^categoryName! !

!KMShortcutHandler commentStamp: ''!
I am a shortcut handler that installs keymappings in the system.!
!KMShortcutHandler methodsFor: 'shortcut-handling' stamp: ''!
handleKeystroke: aKeystrokeEvent inMorph: aMorph

	aMorph handleKeystrokeWithKeymappings: aKeystrokeEvent! !

!KMShortcutPrinter commentStamp: ''!
I'm an util to convert a shortcut into the representation used in a platform (they change, as the shortcut themselves are different sometimes)
!
!KMShortcutPrinter methodsFor: 'visiting' stamp: ''!
mapSpecialCharacter: char 

	char = KeyboardKey enter ifTrue: [ ^ 'Enter' ].
	char = (KeyboardKey fromCharacter: Character space) ifTrue: [ ^ 'Space' ].
	^ char	 name! !

!KMShortcutPrinter methodsFor: 'private' stamp: ''!
basicModifierStringsOf: aShortcut
		
	^ (aShortcut platformModifier asString substrings: '+') collect: [:each | each trimBoth]! !

!KMShortcutPrinter methodsFor: 'visiting' stamp: ''!
visitSingleShortcut: aShortcut

	| char |
	char := self mapSpecialCharacter: aShortcut platformCharacter.
	^ String streamContents: [ :stream | 
		(self shortcutModifiersOf: aShortcut) ifNotEmpty: [ :modifiers |  
			modifiers
			  do: [ :each | stream << each ]
			  separatedBy: [ stream << '+' ].
			stream << '+' ].
		stream << char ]! !

!KMShortcutPrinter methodsFor: 'private' stamp: ''!
shortcutModifiersOf: aShortcut
	| modifiers |
	
	modifiers := self basicModifierStringsOf: aShortcut.
	modifiers replaceAll: 'Meta' with: 'Ctrl'.
	
	"Ensure shift is first"
	((modifiers includes: 'Shift') 
		and: [ modifiers first ~= 'Shift' ])
		ifTrue: [ modifiers := (modifiers copyWithout: 'Shift') copyWithFirst: 'Shift' ].
	
	^ modifiers! !

!KMShortcutPrinter methodsFor: 'visiting' stamp: ''!
visitCombinationShortcut: aShortcut

	^ (aShortcut sequence collect: [ :e | self visitSingleShortcut: e ]) joinUsing: ','! !

!KMShortcutPrinter class methodsFor: 'instance creation' stamp: ''!
toString: aShortcut

	^ aShortcut acceptVisitor: OSPlatform current shortcutPrinter! !

!KMShortcutPrinter class methodsFor: 'private' stamp: ''!
createSymbolTable

	^ Dictionary newFromPairs: { 
		#Cmd. 		(Character value: 16r2318) asString.
		#Meta. 	(Character value: 16r2318) asString.
		#Alt. 		(Character value: 16r2325) asString. 
		#Ctrl.  	(Character value: 16r2303) asString. 
		#Shift. 	(Character value: 16r21E7) asString.
		#Enter. 	(Character value: 16r23ce) asString }! !

!KMShortcutPrinter class methodsFor: 'private' stamp: ''!
symbolTable

	^ SymbolTable ifNil: [ SymbolTable := self createSymbolTable ]! !

!KMShortcutPrinter class methodsFor: 'private' stamp: ''!
symbolTableAt: anObject ifAbsent: aBlock

	^ self symbolTable 
		at: anObject 
		ifAbsent: aBlock! !

!KMShortcutPrinterTest methodsFor: 'accessing' stamp: ''!
platform: anObject
	platform := anObject! !

!KMShortcutPrinterTest methodsFor: 'accessing' stamp: ''!
shortcut: anObject
	shortcut := anObject! !

!KMShortcutPrinterTest methodsFor: 'accessing' stamp: ''!
result
	^ result! !

!KMShortcutPrinterTest methodsFor: 'tests' stamp: ''!
testSingleKeyCombinationIsPrintedWithoutSeparators
	| printed |

	printed := Character arrowLeft asKeyCombination acceptVisitor: platform shortcutPrinter.
	self assert: printed equals: 'LEFT'.
	
	printed := Character arrowRight asKeyCombination acceptVisitor: platform shortcutPrinter.
	self assert: printed equals: 'RIGHT'! !

!KMShortcutPrinterTest methodsFor: 'accessing' stamp: ''!
result: anObject
	result := anObject! !

!KMShortcutPrinterTest methodsFor: 'accessing' stamp: ''!
platform
	^ platform! !

!KMShortcutPrinterTest methodsFor: 'tests' stamp: ''!
testPrintShortcut
	| printed |

	printed := shortcut acceptVisitor: platform shortcutPrinter.
	self assert: printed equals: result! !

!KMShortcutPrinterTest methodsFor: 'accessing' stamp: ''!
shortcut
	^ shortcut! !

!KMShortcutPrinterTest class methodsFor: 'building suites' stamp: ''!
testParameters
	| cmd ctrl alt shift enter |

	cmd :=	 (Character value: 16r2318) asString.
	alt := (Character value: 16r2325) asString. 
	ctrl := (Character value: 16r2303) asString. 
	shift := (Character value: 16r21E7) asString.
	enter := (Character value: 16r23ce) asString.

	^ super testParameters
		"linux"
		addCase: { #platform -> UnixPlatform new. #shortcut -> $n meta. #result -> 'Ctrl+N' };
		addCase: { #platform -> UnixPlatform new. #shortcut -> $n command. #result -> 'Cmd+N' };
		addCase: { #platform -> UnixPlatform new. #shortcut -> $n control. #result -> 'Ctrl+N' };
		addCase: { #platform -> UnixPlatform new. #shortcut -> $n alt. #result -> 'Alt+N' };
		addCase: { #platform -> UnixPlatform new. #shortcut -> $n shift. #result -> 'Shift+N' };
		addCase: { 
			#platform -> UnixPlatform new. 
			#shortcut -> $n shift alt control command. 
			#result -> 'Shift+Alt+Ctrl+Cmd+N' };
		addCase: { 
			#platform -> UnixPlatform new. 
			#shortcut -> Character cr shift. 
			#result -> 'Shift+Enter' };
		"windows"
		addCase: { #platform -> WinPlatform new. #shortcut -> $n meta. #result -> 'Ctrl+N' };
		addCase: { #platform -> WinPlatform new. #shortcut -> $n command. #result -> 'Cmd+N' };
		addCase: { #platform -> WinPlatform new. #shortcut -> $n control. #result -> 'Ctrl+N' };
		addCase: { #platform -> WinPlatform new. #shortcut -> $n alt. #result -> 'Alt+N' };
		addCase: { #platform -> WinPlatform new. #shortcut -> $n shift. #result -> 'Shift+N' };
		addCase: { 
			#platform -> WinPlatform new. 
			#shortcut -> $n shift alt control command. 
			#result -> 'Shift+Alt+Ctrl+Cmd+N' };
		addCase: { 
			#platform -> WinPlatform new. 
			#shortcut -> Character cr shift. 
			#result -> 'Shift+Enter' };
		"mac"
		addCase: { #platform -> MacOSPlatform new. #shortcut -> $n command. #result -> (cmd, 'N') };
		addCase: { #platform -> MacOSPlatform new. #shortcut -> $n control. #result -> (ctrl, 'N') };
		addCase: { #platform -> MacOSPlatform new. #shortcut -> $n alt. #result -> (alt, 'N') };
		addCase: { #platform -> MacOSPlatform new. #shortcut -> $n shift. #result -> (shift, 'N') };
		addCase: { 
			#platform -> MacOSPlatform new. 
			#shortcut -> $n shift alt control command. 
			#result -> (shift, alt, ctrl, cmd, 'N') };
		addCase: { 
			#platform -> MacOSPlatform new. 
			#shortcut -> Character cr shift. 
			#result -> (shift, enter) };
		addCase: { #platform -> MacOSPlatform new. #shortcut -> ($n shift , $m shift). #result -> (shift, 'N' , ',' , shift , 'M') };
		addCase: { #platform -> UnixPlatform new. #shortcut -> ($n shift , $m shift). #result -> 'Shift+N,Shift+M' };
		addCase: { #platform -> WinPlatform new. #shortcut -> ($n shift , $m shift). #result -> 'Shift+N,Shift+M' };
		addCase: { #platform -> MacOSPlatform new. #shortcut -> ($n control , $m control). #result -> (ctrl, 'N' , ',' , ctrl , 'M') };
		addCase: { #platform -> UnixPlatform new. #shortcut -> ($n control , $m control). #result -> 'Ctrl+N,Ctrl+M' };
		addCase: { #platform -> WinPlatform new. #shortcut -> ($n control , $m control). #result -> 'Ctrl+N,Ctrl+M' }! !

!KMShortcutSetting commentStamp: ''!
I represent a shortcut setting. I relate a keymap with its default shortcut and its current shortcut, so it can be mutated.!
!KMShortcutSetting methodsFor: 'accessing' stamp: ''!
action: anActionBlock
	action := anActionBlock! !

!KMShortcutSetting methodsFor: 'accessing' stamp: ''!
defaultShortcut
	^ self keymap defaultShortcut! !

!KMShortcutSetting methodsFor: 'accessing' stamp: ''!
category: aCategory
	category := aCategory! !

!KMShortcutSetting methodsFor: 'accessing' stamp: ''!
keystrokes
	^ self keymap shortcut! !

!KMShortcutSetting methodsFor: 'accessing' stamp: ''!
shortcut
	^ self keymap shortcut! !

!KMShortcutSetting methodsFor: 'accessing' stamp: ''!
shortcutName: aShortcutName
	shortcutName := aShortcutName! !

!KMShortcutSetting methodsFor: 'setting' stamp: ''!
accept: aShortcut 
	self keymap shortcut: aShortcut! !

!KMShortcutSetting methodsFor: 'accessing' stamp: ''!
keymap
	^ KMFactory keymapContainer keymapNamed: shortcutName inCategory: category! !

!KMShortcutSetting class methodsFor: 'settings' stamp: ''!
settingInputWidgetForNode: aSettingNode
	| catcherMorph theme |
	theme := UITheme builder.
	catcherMorph := KMCatcherMorph for: aSettingNode realValue.
	^ theme newRow: {catcherMorph}! !

!KMShortcutSetting class methodsFor: 'instance creation' stamp: ''!
for: aShortcutName in: aCategory
	^ (self new)
		shortcutName: aShortcutName;
		category: aCategory;
		yourself! !

!KMShortcutTest commentStamp: ''!
SUnit tests for key mapping shortcuts!
!KMShortcutTest methodsFor: 'tests' stamp: ''!
testCreation
	self assert: ($e asKeyCombination isKindOf: KMSingleKeyCombination).
	self assert: ($e ctrl isKindOf: KMModifiedKeyCombination).
	self assert: ($e ctrl alt shift command isKindOf: KMModifiedKeyCombination).! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testEventCodes
	self assert: $s meta modifier eventCode 
		  equals: OSPlatform current defaultModifier eventCode! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testShiftKeySucceds
	^ self assert: $e shift equals: $e shift! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testBadComposedCmdShortcutFails
	^ self should: [ KMModifier ctrl ctrl ] raise: Error! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testSingleShortcutsMatch
	|a one home |
	a := self eventKey: $a.
	one := self eventKey: 1 asCharacter.
	home := self eventKey: Character home.
	
	self assert: ($a asKeyCombination matches: {a}).
	self assert: (1 asKeyCombination matches: {one}).
	self assert: (Character home asKeyCombination matches: {home}).
	
	self deny: ($b asKeyCombination matches: {a}).
	
	self assert: ($a asKeyCombination matchesCompletely: {a}).
	self assert: (1 asKeyCombination matchesCompletely: {one})! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testTripleChainShortcutSucceds
	^ self assert: ($e ctrl , $e ctrl , $d ctrl) equals: ($e ctrl , $e ctrl , $d ctrl)! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testCmdShiftSucceds
	^ self assert: ($1 shift ctrl matches: {self eventKey: $1 alt: false ctrl: true command: false shift: true})! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testAsString
	self assert: $a asShortcut asString equals: 'A'.
	self assert: $A asShortcut asString equals: 'Shift + A'.
	self assert: $a ctrl asString equals: 'Ctrl + A'.
	self assert: $A ctrl asString equals: 'Shift + Ctrl + A'.
	self assert: $A command asString equals: 'Shift + Cmd + A'.
	self assert: $A alt asString equals: 'Shift + Alt + A'.
	self assert: $b command asString equals: 'Cmd + B'.
	self assert: $c shift asString equals: 'Shift + C'.
	self assert: $d alt asString equals: 'Alt + D'.
	self assert: $e ctrl command asString equals: (KMCtrlModifier new asString ,' + ' , KMCommandModifier new asString,' + E')! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testChainSimpleCharsSucceds
	^ self assert: ($e ctrl , $e) equals: ($e ctrl , $e)! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testComplexChainMatches
	|eCtrl eShift f|
	
	f := self eventKey: $f.
	eCtrl := self eventKey: $e ctrl: true.
	eShift := self eventKey: $e shift: true.
		
	self assert: (($e ctrl, $e shift, $f) matches: {eCtrl}).
	self assert: (($e ctrl, $e shift, $f) matches: {eCtrl. eShift}).
	self assert: (($e ctrl, $e shift, $f) matches: {eCtrl. eShift. f}).

	self deny: (($e ctrl, $e shift, $f) matchesCompletely: {eCtrl}).
	self deny: (($e ctrl, $e shift, $f) matchesCompletely: {eCtrl. eShift}).
	self assert: (($e ctrl, $e shift, $f) matchesCompletely: {eCtrl. eShift. f})! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testCmdKeySucceds
	^ self assert: $e ctrl equals: $e ctrl! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testModifiedShortcutsMatch
	|a oneShift oneCommand oneCommandShift|
	
	a := self eventKey: $a ctrl: true.
	oneShift := self eventKey: $1 shift: true.
	oneCommand := self eventKey: $1 command: true.
	oneCommandShift := self eventKey: $1 alt: false ctrl: false command: true shift: true.
	
	self assert: ($a ctrl matches: {a}).
	self assert: ($1 shift matches: {oneShift}).
	self assert: ($1 command matches: {oneCommand}).
	self assert: ($1 command shift matches: {oneCommandShift}).
	
	self deny: ($a ctrl matches: {self eventKey: $a command: true}).
	
	self deny: ($i command shift matches: {self eventKey: $i command: true}).
	self assert: ($i ctrl shift matches: {self eventKey: $i alt: false ctrl: true command: false shift: true}).
	self deny: ($i ctrl matches: {self eventKey: $i alt: false ctrl: true command: false shift: true}).
	
	self assert: ($a ctrl matchesCompletely: {a}).
	self assert: ($1 shift matchesCompletely: {oneShift}).
	self assert: ($1 command matchesCompletely: {oneCommand}).
	self assert: ($1 command shift matchesCompletely: {oneCommandShift})! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testChainShortcutSucceds
	^ self assert: ($e ctrl , $e ctrl) equals: ($e ctrl , $e ctrl)! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testSimpleChainMatches
	|e eCtrl |
	e := self eventKey: $e.
	eCtrl := self eventKey: $e ctrl: true.
	
	self assert: (($e ctrl, $e) matches: {eCtrl}).
	
	"A full shortcut should not match a bigger buffer ever"
	self deny: ($e ctrl matches: {eCtrl. e}).
	
	self deny: (($e ctrl, $e) matches: {eCtrl. self eventKey: $a}).
	self deny: ($e ctrl matches: {e})! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testCmdIntegerSucceds
	^ self assert: 1 ctrl equals: 1 ctrl! !

!KMShortcutTest methodsFor: 'tests' stamp: ''!
testChainIntegerSucceds
	^ self assert: ($e ctrl , 1) equals: ($e ctrl , 1)! !

!KMSingleKeyCombination commentStamp: ''!
I represent a single key press, the simplest key combination.

I match with a keyboard event when that event key is the same as me and the key event is not modified.

To create a single key combination use the #asShortcut message. Like for example:

$a asShortcut!
!KMSingleKeyCombination methodsFor: 'combining' stamp: ''!
modifiedBy: aModifier
	^ KMModifiedKeyCombination modifier: aModifier character: self! !

!KMSingleKeyCombination methodsFor: 'comparing' stamp: ''!
= aShortcut
	^ super = aShortcut and: [ aShortcut key = key ]! !

!KMSingleKeyCombination methodsFor: 'accessing' stamp: ''!
modifier

	^ KMNoModifier new.! !

!KMSingleKeyCombination methodsFor: 'comparing' stamp: ''!
hash
	^ key hash! !

!KMSingleKeyCombination methodsFor: 'printing' stamp: ''!
prettyPrintOn: aStream

	self printOn: aStream! !

!KMSingleKeyCombination methodsFor: 'matching' stamp: ''!
matchesEvent: aKeyboardEvent
	^ self key asLowercase = aKeyboardEvent modifiedCharacter asLowercase! !

!KMSingleKeyCombination methodsFor: 'accessing' stamp: ''!
key
	^ key! !

!KMSingleKeyCombination methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: self name! !

!KMSingleKeyCombination methodsFor: 'accessing - platform' stamp: ''!
platformCharacter

	^ key! !

!KMSingleKeyCombination methodsFor: 'accessing' stamp: ''!
name
	^ self key name! !

!KMSingleKeyCombination methodsFor: 'accessing' stamp: ''!
key: aKeyString
	key := aKeyString.! !

!KMSingleKeyCombination methodsFor: '*Spec-Core' stamp: ''!
currentCharacter

	^ key! !

!KMSingleKeyCombination methodsFor: 'accessing - platform' stamp: ''!
platformModifier

	^ self modifier! !

!KMSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
from: aCharacterOrInteger
	| aCharacter |
	aCharacter := aCharacterOrInteger asCharacter.
	
	^ (KeyboardKey fromCharacter: aCharacter) asKeyCombination! !

!KMSingleKeyCombination class methodsFor: 'accessing' stamp: ''!
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.]! !

!KMStorage commentStamp: ''!
I am a storage of shortcuts. I store and provide facilities to access named and annonimous shortcuts.!
!KMStorage methodsFor: 'accessing' stamp: ''!
add: aKeymap
	aKeymap hasName
		ifTrue: [ namedRegistry at: aKeymap name put: aKeymap ]
		ifFalse: [ anonymousRegistry add: aKeymap ].! !

!KMStorage methodsFor: 'initialization' stamp: ''!
initialize
	anonymousRegistry := Set new.
	namedRegistry := Dictionary new.! !

!KMStorage methodsFor: 'accessing' stamp: ''!
keymapNamed: aKmName
	^namedRegistry at: aKmName! !

!KMStorage methodsFor: 'accessing' stamp: ''!
keymaps
	^anonymousRegistry , namedRegistry values! !

!KMStorage methodsFor: 'accessing' stamp: ''!
size
	^self keymaps size! !

!KMStorage methodsFor: 'accessing' stamp: ''!
keymapForShortcut: aShortcut

	^ namedRegistry
		detect: [ :keymap | keymap shortcut = aShortcut ]
		ifNone: [ 
			anonymousRegistry
				detect: [ :keymap | keymap shortcut = aShortcut ]
				ifNone: [ nil ] ]! !

!KMStorage methodsFor: 'accessing' stamp: ''!
, aKMStorage
	^self class new
		addAll: self keymaps;
		addAll: aKMStorage keymaps.! !

!KMStorage methodsFor: 'accessing' stamp: ''!
addAll: keymaps
	keymaps do: [ :km | self add: km ].! !

!KMStorage methodsFor: 'accessing' stamp: ''!
hasKeymapNamed: aKmName
	^namedRegistry includesKey: aKmName! !

!KMStorage methodsFor: 'accessing' stamp: ''!
remove: aKeymap
	aKeymap hasName
		ifTrue: [ namedRegistry removeKey: aKeymap name ]
		ifFalse: [ anonymousRegistry remove: aKeymap ].! !

!KMTarget commentStamp: ''!
I am the reification of the Keymap target.  I am the one that receives the actions.!
!KMTarget methodsFor: 'accessing' stamp: ''!
targetSelector: aTargetSelector
	targetSelector := aTargetSelector! !

!KMTarget methodsFor: 'iterating' stamp: ''!
nextForKmChain: aKMDispatchChain 
	^self ownerTarget! !

!KMTarget methodsFor: 'accessing' stamp: ''!
dispatch: buffer

	morph kmDispatcher dispatch: buffer! !

!KMTarget methodsFor: 'accessing' stamp: ''!
morph
	^morph! !

!KMTarget methodsFor: 'accessing' stamp: ''!
morph: aMorph
	morph := aMorph! !

!KMTarget methodsFor: 'accessing' stamp: ''!
ownerTarget
	morph owner ifNil: [ ^nil ].
	^morph owner kmDispatcher target.! !

!KMTarget methodsFor: 'accessing' stamp: ''!
realTarget
	^morph perform: self targetSelector! !

!KMTarget methodsFor: 'accessing' stamp: ''!
targetSelector
	^targetSelector ifNil: [ #yourself ]! !

!KMTarget methodsFor: 'protocol' stamp: ''!
announcer

	^ self morph announcer! !

!KMTarget class methodsFor: 'instance creation' stamp: ''!
for: aTarget in: aMorph
	^ (self new)
		targetSelector: aTarget;
		morph: aMorph;
		yourself! !

!KMUntypeableSingleKeyCombination commentStamp: ''!
I am an abstract class for all single key combinations that correspond to characters that cannot be typed directly.!
!KMUntypeableSingleKeyCombination methodsFor: 'accessing' stamp: ''!
symbol: aString
	
	symbol := aString! !

!KMUntypeableSingleKeyCombination methodsFor: 'printing' stamp: ''!
symbol
	"I return the visual symbol for this shortcut.
	For instance for the Arrow Up key I contain a string with an arrow up key symbol: ↑ and now the Character arrowUp."
	^ symbol! !

!KMUntypeableSingleKeyCombination methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!KMUntypeableSingleKeyCombination methodsFor: 'accessing' stamp: ''!
name: aString
	name := aString! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
delete
	^ self
		key: Character delete
		name: 'Delete'
		symbol: '⌦'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
arrowDown
	^ self
		key: Character arrowDown
		name: 'Down Arrow'
		symbol: '↓'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
pageUp
	^ self
		key: Character pageUp
		name: 'Page Up'
		symbol: '⇞'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
arrowLeft
	^ self
		key: Character arrowLeft
		name: 'Left Arrow'
		symbol: '←'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
tab
	^ self
		key: Character tab
		name: 'Tab'
		symbol: '⇥'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
arrowUp
	^ self
		key: Character arrowUp
		name: 'Up Arrow'
		symbol: '↑'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'initialization' stamp: ''!
newSpecialKeys
	"Build a new dictionary that maps untypable characters to symbols for instacation creation methods on this class."
	| dictionary |
	dictionary := Dictionary new.
	 #(home enter end backspace tab pageUp pageDown escape arrowLeft arrowRight arrowUp arrowDown delete)
		do: [  :symbol |
			dictionary at: (Character perform: symbol) put: symbol ].
	^ dictionary! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
pageDown
	^ self
		key: Character pageDown
		name: 'Page Down'
		symbol: '⇟'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
arrowRight
	^ self
		key: Character arrowRight
		name: 'Right Arrow'
		symbol: '→'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
enter
	^ self
		key: Character enter
		name: 'Enter'
		symbol: '↩'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
backspace
	^ self
		key: Character backspace
		name: 'Backspace'
		symbol: '⌫'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
end
	^ self
		key: Character end
		name: 'End'
		symbol: '↘'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
home
	^ self
		key: Character home
		name: 'Home'
		symbol: '↖'! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
key: aCharacter name: aString symbol: aVisualString
	^ self new
		key: aCharacter;
		name: aString;
		symbol: aVisualString;
		yourself! !

!KMUntypeableSingleKeyCombination class methodsFor: 'testing' stamp: ''!
ifSpecialKey: aCharacter do: aBlock
	"Lookup if aCharacter needs to be handled by me, if so use one of the instance creation function for creating the corresponding KeyCombination."
	 self specialKeys at: aCharacter ifPresent: [ :symbol |
		aBlock value: (self perform: symbol) ]! !

!KMUntypeableSingleKeyCombination class methodsFor: 'accessing' stamp: ''!
specialKeys
	^specialKeys
		ifNil: [ 
			specialKeys := self newSpecialKeys ]! !

!KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: ''!
escape
	^ self
		key: Character escape
		name: 'Escape'
		symbol: '⎋'! !

!Key commentStamp: ''!
Key was deprecated in Pharo 9 in favor of KeyboardKey.
Replace your usages.

For more information, please check the comment in KeyboardKey.!
!Key class methodsFor: 'testing' stamp: 'nil'!
isDeprecated
	^true! !

!KeyNotFound commentStamp: ''!
I am KeyNotFound, an exception indicating that a key was not found in a Dictionary.!
!KeyNotFound methodsFor: 'accessing' stamp: ''!
key
	^ self object! !

!KeyNotFound methodsFor: 'accessing' stamp: ''!
key: aKey
	self object: aKey! !

!KeyNotFound methodsFor: 'private' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		stream << 'key '.
		stream print: self object.
		stream << ' not found in '.
		stream print: self collection class ]! !

!KeyPrinterMorph commentStamp: ''!
I am a morph that prints the keys in the keyboard events.
Open the utility using:

    KeyPrinterMorph open

then click into it to activate the window and press keys on
your keyboard to display the key code.!
!KeyPrinterMorph methodsFor: 'display' stamp: ''!
preOpenInWorld: aWorld

	self extent: 400@200! !

!KeyPrinterMorph methodsFor: 'event handling' stamp: ''!
mouseDown: event 
	super mouseDown: event.
	self activeHand newKeyboardFocus: self! !

!KeyPrinterMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	^ true! !

!KeyPrinterMorph methodsFor: 'event handling' stamp: ''!
keyDown: anEvent
	UIManager default inform: anEvent key asString.! !

!KeyPrinterMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^ true! !

!KeyPrinterMorph methodsFor: 'display' stamp: ''!
defaultLabel

	^ 'KeyPrinter (click/activate and press a key)'! !

!KeyPrinterMorph class methodsFor: 'open/close' stamp: ''!
open
	<script>
	
	self new openInWorld! !

!KeyboardEvent commentStamp: ''!
I am a keyboard event. I contain the char code of the event pressed, the modifiers pressed, and the keycode of the key pressed.!
!KeyboardEvent methodsFor: 'testing' stamp: ''!
hasSpecialCTRLKeyValue
"
	4 - Character end
	1 - Character home
"

	^ self controlKeyPressed and: [ keyValue <= 26 & (keyValue ~= 4) & (keyValue ~= 1) ]! !

!KeyboardEvent methodsFor: 'keymapping' stamp: ''!
asKeyCombination
	^ KMKeyCombination fromKeyboardEvent: self! !

!KeyboardEvent methodsFor: 'comparing' stamp: ''!
= aMorphicEvent
	super = aMorphicEvent ifFalse:[^false].
	buttons = aMorphicEvent buttons ifFalse: [^ false].
	keyValue = aMorphicEvent keyValue ifFalse: [^ false].
	^ true! !

!KeyboardEvent methodsFor: 'accessing' stamp: ''!
wasHandled

	^ super wasHandled or: [ supressNextKeyPress ]! !

!KeyboardEvent methodsFor: 'comparing' stamp: ''!
hash
	^buttons hash + keyValue hash! !

!KeyboardEvent methodsFor: 'keymapping' stamp: ''!
modifiedCharacter
	self flag: #hack.
	"Hack me.  When Ctrl is pressed, the key ascii value is not right and we have to do something ugly"
	^(self hasSpecialCTRLKeyValue and: [ (#(MacOSX Windows) includes: Smalltalk os platformFamily) ])
    	ifTrue: [ (self keyValue + $a asciiValue - 1) asCharacter ]    
		ifFalse: [ 
			Smalltalk os isWindows 
				ifTrue: [ self keyCharacter asLowercase ]
				ifFalse: [ self keyCharacter ] ]! !

!KeyboardEvent methodsFor: 'testing' stamp: ''!
isKeyUp
	^self type == #keyUp! !

!KeyboardEvent methodsFor: 'testing' stamp: ''!
isMouseMove
	^false! !

!KeyboardEvent methodsFor: 'accessing' stamp: ''!
supressNextKeyPress: anObject

	supressNextKeyPress := anObject! !

!KeyboardEvent methodsFor: 'testing' stamp: ''!
isKeyDown
	^self type == #keyDown! !

!KeyboardEvent methodsFor: 'testing' stamp: ''!
isKeyboard
	^true! !

!KeyboardEvent methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Print the receiver on a stream"

	aStream nextPut: $[.
	aStream nextPutAll: type; nextPutAll: ' '''.
	self printKeyStringOn: aStream.
	aStream nextPut: $'.
	aStream nextPut: $]! !

!KeyboardEvent methodsFor: 'private' stamp: ''!
setType: aSymbol buttons: anInteger position: pos keyValue: aValue hand: aHand stamp: stamp
	type := aSymbol.
	buttons := anInteger.
	position := pos.
	keyValue := aValue.
	source := aHand.
	wasHandled := false.
	timeStamp := stamp.! !

!KeyboardEvent methodsFor: 'keyboard' stamp: ''!
keyValue
	"Answer the ascii value for this keystroke. This is defined only for keystroke events."

	^ keyValue! !

!KeyboardEvent methodsFor: 'accessing' stamp: ''!
supressNextKeyPress

	^ supressNextKeyPress! !

!KeyboardEvent methodsFor: 'keyboard' stamp: ''!
scanCode
	^scanCode! !

!KeyboardEvent methodsFor: 'keymapping' stamp: ''!
asShortcut
	^ self asKeyCombination! !

!KeyboardEvent methodsFor: 'keyboard' stamp: ''!
keyCharacter
	"Answer the character corresponding this keystroke. This is defined only for keystroke events."

	^Unicode value: charCode! !

!KeyboardEvent methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	supressNextKeyPress := false.! !

!KeyboardEvent methodsFor: 'dispatching' stamp: ''!
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: 'private' stamp: ''!
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: 'testing' stamp: ''!
isKeystroke
	^self type == #keystroke! !

!KeyboardEvent methodsFor: 'keyboard' stamp: ''!
key
	^ key ifNil: [key := Smalltalk os keyForValue: keyValue]! !

!KeyboardEvent methodsFor: 'printing' stamp: ''!
printKeyStringOn: aStream
	"Print a readable string representing the receiver on a given stream"

	| kc inBrackets firstBracket keyString |
	kc := self keyCharacter.
	inBrackets := false.
	firstBracket := [ inBrackets ifFalse: [ aStream nextPut: $<. inBrackets := true ]].
	self controlKeyPressed ifTrue: [ 	firstBracket value. aStream nextPutAll: 'Ctrl-' ].
	self commandKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Cmd-' ].
	(buttons anyMask: 32) ifTrue: [ firstBracket value. aStream nextPutAll: 'Opt-' ].
	(self shiftPressed and: [ keyValue between: 1 and: 31 ])
		ifTrue: [ firstBracket value. aStream nextPutAll: 'Shift-' ].

	self hasSpecialCTRLKeyValue
			ifTrue:
				[aStream nextPut: (keyValue + $a asciiValue - 1) asCharacter]
			ifFalse: 
				[keyString := (kc caseOf: {
					[ Character space ] -> [ ' ' ].
					[ Character tab ] -> [ 'tab' ].
					[ Character cr ] -> [ 'cr' ].
					[ Character lf ] -> [ 'lf' ].
					[ Character enter ] -> [ 'enter' ].

					[ Character backspace ] -> [ 'backspace' ].
					[ Character delete ] -> [ 'delete' ].

					[ Character escape ] -> [ 'escape' ].

					[ Character arrowDown ] -> [ 'down' ].
					[ Character arrowUp ] -> [ 'up' ].
					[ Character arrowLeft ] -> [ 'left' ].
					[ Character arrowRight ] -> [ 'right' ].

					[ Character end ] -> [ 'end' ].
					[ Character home ] -> [ 'home' ].
					[ Character pageDown ] -> [ 'pageDown' ].
					[ Character pageUp ] -> [ 'pageUp' ].

					[ Character euro ] -> [ 'euro' ].
					[ Character insert ] -> [ 'insert' ].

				} otherwise: [ String with: kc ]).
				keyString size > 1 ifTrue: [ firstBracket value ].
				aStream nextPutAll: keyString].

	inBrackets ifTrue: [aStream nextPut: $> ]! !

!KeyboardEvent methodsFor: 'initialize' stamp: ''!
scanCode: anInt
	scanCode := anInt! !

!KeyboardEvent methodsFor: 'keyboard' stamp: ''!
key: aKeyboardKey
	key := aKeyboardKey! !

!KeyboardEvent methodsFor: 'printing' stamp: ''!
storeOn: aStream

	aStream nextPutAll: type.
	aStream space.
	self timeStamp storeOn: aStream.
	aStream space.
	position x asInteger storeOn: aStream.
	aStream space.
	position y asInteger storeOn: aStream.
	aStream space.
	buttons storeOn: aStream.
	aStream space.
	keyValue storeOn: aStream.
	aStream space.
	charCode storeOn: aStream.
	aStream space.
	scanCode storeOn: aStream.! !

!KeyboardEvent methodsFor: 'keyboard' stamp: ''!
keyString
	"Answer the string value for this keystroke. This is defined only for keystroke events."

	^ String streamContents: [ :s | self printKeyStringOn: s ]! !

!KeyboardKey commentStamp: ''!
I represent a keyboard Key, I am independent from the text issued from myself.
That is, when you press e.g., the combination Alt + A, you get the Character å (as in "an instance of Character") in a text event, but in the KeyDown/Up events you get an instance of myself, the KeyboardKey A (see section Keys vs Characters below).

# Implementation details

I keep a flyweight of Keys that can be accessed by id or name.

```
KeyboardKey value: anID.
KeyboardKey named: 'RETURN'.
```

The ID of a key corresponds to the keycodes in Unix's X11 key mapping.
Such ID was chosen because Unix X11 is a super set of the keys supported in Win32 and Cocoa.

Internally I also keep a mapping between Win32 and Cocoa keycodes to X11's keycodes.
See my class side:
```
valueForWindowsPlatform:
valueForUnixPlatform:
valueForMacOSXPlatform:
```

# Keys vs Characters

KeyboardKeys and characters do not have a 1 to 1 mapping. Be careful that keys and Characters do not represent the same thing, specially when we are outside of the english alphabet. In such cases, a Key like E could trigger a Character like e or € depending on the configured keyboard layout and key combinations done. This is specially trickier in asian alphabets.

For backwards compatibility, I provide a helper method that tries to do a mapping in the direction Character -> key (see fromCharacter:) but should be used sparingly and it will be deprecated in the future.!
!KeyboardKey methodsFor: 'testing' stamp: 'nil'!
isArrowUp

	^ {KeyboardKey up . KeyboardKey keypadUp} includes: self! !

!KeyboardKey methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
shift

	^ KMModifier shift + self! !

!KeyboardKey methodsFor: 'testing' stamp: 'nil'!
isUnkownKey
	 ^self name == self class unknownKeyName! !

!KeyboardKey methodsFor: 'comparing' stamp: 'nil'!
= other

	^ self species = other species
		and: [ self value = other value ]! !

!KeyboardKey methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
asKeyCombination

	^ KMSingleKeyCombination new
		  key: self;
		  yourself! !

!KeyboardKey methodsFor: 'comparing' stamp: 'nil'!
hash

	^ self species hash bitXor: self value hash! !

!KeyboardKey methodsFor: 'initialization' stamp: 'nil'!
withValue: aValue
	self withValue: aValue andName: self class unknownKeyName! !

!KeyboardKey methodsFor: 'initialization' stamp: 'nil'!
withValue: aValue andName: aName
	value := aValue.
	name := aName! !

!KeyboardKey methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
command

	^ KMModifier command + self! !

!KeyboardKey methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
control

	^ KMModifier control + self! !

!KeyboardKey methodsFor: 'testing' stamp: 'nil'!
isArrowLeft

	^ {KeyboardKey left . KeyboardKey keypadLeft} includes: self! !

!KeyboardKey methodsFor: 'testing' stamp: 'nil'!
isArrowDown

	^ {KeyboardKey down . KeyboardKey keypadDown} includes: self! !

!KeyboardKey methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	aStream
		nextPutAll: 'Key ';
		nextPutAll: name;
		nextPutAll: ' code: (';
		print: value;
		nextPutAll: ')'! !

!KeyboardKey methodsFor: 'testing' stamp: 'nil'!
isArrowRight

	^ {KeyboardKey right . KeyboardKey keypadRight} includes: self! !

!KeyboardKey methodsFor: 'accessing' stamp: 'nil'!
value
	^ value! !

!KeyboardKey methodsFor: 'accessing' stamp: 'nil'!
name
	^name! !

!KeyboardKey methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
meta

	^ KMModifier meta + self! !

!KeyboardKey methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
alt

	^ KMModifier alt + self! !

!KeyboardKey methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
ctrl

	^ KMModifier ctrl + self! !

!KeyboardKey class methodsFor: 'instance creation' stamp: 'nil'!
named: aString ifNone: aBlock
	"Returns the instance of myself having aString as name.
	
	 (KeyboardKey named: 'SHIFT_L') >>> (KeyboardKey value: 65505)
	"
	
	^ KeyNameTable at: aString ifAbsent: aBlock! !

!KeyboardKey class methodsFor: 'instance creation' stamp: 'nil'!
value: aKeyValue
	^KeyCodeTable at: aKeyValue! !

!KeyboardKey class methodsFor: 'macos' stamp: 'nil'!
initializeMacOSVirtualKeyTable
	self flag: #pharoTodo. "Some values are missing, need to gather them from users who are able to."
	MacosVirtualKeyTable := Dictionary new.
	MacosVirtualKeyTable
		at: 16r24 put: (self value: 16rff0d); " kVK_Return                    = 0x24"
		at: 16r30 put: (self value: 16rff09); "  kVK_Tab                       = 0x30"
		at: 16r31 put: (self value: 16rff80); "  kVK_Space                     = 0x31"
		at: 16r33 put: (self value: 16rFF08); "  kVK_Backspace                 = 0x33 "
		at: 16r35 put: (self value: 16rff1b); "  kVK_Escape                    = 0x35"
		at: 16r37 put: (self value: 16rffe7); "  kVK_Command                   = 0x37"
		at: 16r38 put: (self value: 16rffe1); "  kVK_Shift                     = 0x38"
		at: 16r39 put: (self value: 16rffe5); "  kVK_CapsLock                  = 0x39"
		at: 16r3A put: (self value: 16rffe9); "  kVK_Option                    = 0x3A"
		at: 16r3B put: (self value: 16rffe3); "  kVK_Control                   = 0x3B"
		at: 16r3C put: (self value: 16rffe2); "  kVK_RightShift                = 0x3C"
		at: 16r3D put: (self value: 16rffea); "  kVK_RightOption               = 0x3D"
		at: 16r3E put: (self value: 16rffe4); "  kVK_RightControl              = 0x3E"
		at: 16r3F put: (self value: 16r08f6); "  kVK_Function                  = 0x3F"
		at: 16r48 put: (self value: 16r48); "  kVK_VolumeUp                  = 0x48"  "Not mapped"
		at: 16r49 put: (self value: 16r49); "  kVK_VolumeDown                = 0x49" "Not mapped"
		at: 16r4A put: (self value: 16r4A); "  kVK_Mute                      = 0x4A" "Not mapped"
		at: 16r7A put: (self value: 16rffbe); "  kVK_F1                        = 0x7A"
		at: 16r78 put: (self value: 16rffbf); "  kVK_F2                        = 0x78"
		at: 16r63 put: (self value: 16rffc0); "  kVK_F3                        = 0x63"
		at: 16r76 put: (self value: 16rffc1); "  kVK_F4                        = 0x76"
		at: 16r60 put: (self value: 16rffc2); "  kVK_F5                        = 0x60"
		at: 16r61 put: (self value: 16rffc3); "  kVK_F6                        = 0x61"
		at: 16r62 put: (self value: 16rffc4); "  kVK_F7                        = 0x62"
		at: 16r64 put: (self value: 16rffc5); "  kVK_F8                        = 0x64"
		at: 16r65 put: (self value: 16rffc6); "  kVK_F9                        = 0x65"
		at: 16r67 put: (self value: 16rffc8); "  kVK_F11                       = 0x67"
		at: 16r6D put: (self value: 16rffc7); "  kVK_F10                       = 0x6D"
		at: 16r6F put: (self value: 16rffc9); "  kVK_F12                       = 0x6F"
		"at: 16r72 put: (self value: 16r72);" "  kVK_Help                      = 0x72" "Not mapped"
		at: 16r73 put: (self value: 16rff50); "  kVK_Home                      = 0x73"
		at: 16r74 put: (self value: 16rff55); "  kVK_PageUp                    = 0x74"
		at: 16r75 put: (self value: 16rffff); "  kVK_ForwardDelete             = 0x75"
		at: 16r77 put: (self value: 16rff57); "  kVK_End                       = 0x77"
		at: 16r79 put: (self value: 16rff56); "  kVK_PageDown                  = 0x79"
		at: 16r7B put: (self value: 16rff96); "  kVK_LeftArrow                 = 0x7B"
		at: 16r7C put: (self value: 16rff98); "  kVK_RightArrow                = 0x7C"
		at: 16r7D put: (self value: 16rff99); "  kVK_DownArrow                 = 0x7D"
		at: 16r7E put: (self value: 16rff97); "  kVK_UpArrow                   = 0x7E"
		at: 16r00 put: (self value: 16r41); "kVK_ANSI_A                    = 0x00"
		at: 16r0B put: (self value: 16r42); "  kVK_ANSI_B                    = 0x0B"
		at: 16r08 put: (self value: 16r43); "  kVK_ANSI_C                    = 0x08"
		at: 16r02 put: (self value: 16r44); "  kVK_ANSI_D                    = 0x02"
		at: 16r0E put: (self value: 16r45); "  kVK_ANSI_E                    = 0x0E"
		at: 16r03 put: (self value: 16r46); "  kVK_ANSI_F                    = 0x03"
		at: 16r05 put: (self value: 16r47); "  kVK_ANSI_G                    = 0x05"
		at: 16r04 put: (self value: 16r48); "  kVK_ANSI_H                    = 0x04"
		at: 16r22 put: (self value: 16r49); "  kVK_ANSI_I                    = 0x22"
		at: 16r26 put: (self value: 16r4a); "  kVK_ANSI_J                    = 0x26"
		at: 16r28 put: (self value: 16r4b); "  kVK_ANSI_K                    = 0x28"
		at: 16r25 put: (self value: 16r4c); "  kVK_ANSI_L                    = 0x25"
		at: 16r2E put: (self value: 16r4d); "  kVK_ANSI_M                    = 0x2E"
		at: 16r2D put: (self value: 16r4e); "  kVK_ANSI_N                    = 0x2D"
		at: 16r1F put: (self value: 16r4f); "  kVK_ANSI_O                    = 0x1F"
		at: 16r23 put: (self value: 16r50); "  kVK_ANSI_P                    = 0x23"
		at: 16r0C put: (self value: 16r51); "  kVK_ANSI_Q                    = 0x0C"
		at: 16r0F put: (self value: 16r52); "  kVK_ANSI_R                    = 0x0F"
		at: 16r01 put: (self value: 16r53); "  kVK_ANSI_S                    = 0x01"
		at: 16r11 put: (self value: 16r54); "  kVK_ANSI_T                    = 0x11"
		at: 16r20 put: (self value: 16r55); "  kVK_ANSI_U                    = 0x20"
		at: 16r09 put: (self value: 16r56); "  kVK_ANSI_V                    = 0x09"
		at: 16r0D put: (self value: 16r57); "  kVK_ANSI_W                    = 0x0D"
		at: 16r07 put: (self value: 16r58); "  kVK_ANSI_X                    = 0x07"
		at: 16r10 put: (self value: 16r59); "  kVK_ANSI_Y                    = 0x10"
		at: 16r06 put: (self value: 16r5a); "  kVK_ANSI_Z                    = 0x06"
		
		at: 16r1D put: (self value: 16r30); "  kVK_ANSI_0                    = 0x1D"
		at: 16r12 put: (self value: 16r31); "  kVK_ANSI_1                    = 0x12"
		at: 16r13 put: (self value: 16r32); "  kVK_ANSI_2                    = 0x13"
		at: 16r14 put: (self value: 16r33); "  kVK_ANSI_3                    = 0x14"
		at: 16r15 put: (self value: 16r34); "  kVK_ANSI_4                    = 0x15"
		at: 16r17 put: (self value: 16r35); "  kVK_ANSI_5                    = 0x17"
		at: 16r16 put: (self value: 16r36); "  kVK_ANSI_6                    = 0x16"
		at: 16r1A put: (self value: 16r37); "  kVK_ANSI_7                    = 0x1A"
		at: 16r1C put: (self value: 16r38); "  kVK_ANSI_8                    = 0x1C"
		at: 16r19 put: (self value: 16r39); "  kVK_ANSI_9                    = 0x19"

		at: 16r1B put: (self value: 16r2d); "  kVK_ANSI_Minus                = 0x1B"
		at: 16r18 put: (self value: 16r3d); "  kVK_ANSI_Equal                = 0x18"
		at: 16r21 put: (self value: 16r5b); "  kVK_ANSI_LeftBracket          = 0x21"
		at: 16r1E put: (self value: 16r5d); "  kVK_ANSI_RightBracket         = 0x1E"
		at: 16r27 put: (self value: 16r27); "  kVK_ANSI_Quote                = 0x27"
		at: 16r29 put: (self value: 16r3b); "  kVK_ANSI_Semicolon            = 0x29"
		at: 16r2A put: (self value: 16r5c); "  kVK_ANSI_Backslash            = 0x2A"
		at: 16r2B put: (self value: 16r2c); "  kVK_ANSI_Comma                = 0x2B"
		at: 16r2C put: (self value: 16r2f); "  kVK_ANSI_Slash                = 0x2C"
		at: 16r2F put: (self value: 16r2e); "  kVK_ANSI_Period               = 0x2F"
		at: 16r32 put: (self value: 16r60); "  kVK_ANSI_Grave                = 0x32"
		at: 16r41 put: (self value: 16rffae); "  kVK_ANSI_KeypadDecimal        = 0x41"
		at: 16r43 put: (self value: 16rffaa); "  kVK_ANSI_KeypadMultiply       = 0x43"
		at: 16r45 put: (self value: 16rffab); "  kVK_ANSI_KeypadPlus           = 0x45"
		at: 16r47 put: (self value: 16r47); "  kVK_ANSI_KeypadClear          = 0x47" "Not mapped"
		at: 16r4B put: (self value: 16rffaf); "  kVK_ANSI_KeypadDivide         = 0x4B"
		at: 16r4C put: (self value: 16rff8d); "  kVK_ANSI_KeypadEnter          = 0x4C"
		at: 16r4E put: (self value: 16rffad); "  kVK_ANSI_KeypadMinus          = 0x4E"
		at: 16r51 put: (self value: 16rffbd); "  kVK_ANSI_KeypadEquals         = 0x51"
		at: 16r52 put: (self value: 16rffb0); "  kVK_ANSI_Keypad0              = 0x52"
		at: 16r53 put: (self value: 16rffb1); "  kVK_ANSI_Keypad1              = 0x53"
		at: 16r54 put: (self value: 16rffb2); "  kVK_ANSI_Keypad2              = 0x54"
		at: 16r55 put: (self value: 16rffb3); "  kVK_ANSI_Keypad3              = 0x55"
		at: 16r56 put: (self value: 16rffb4); "  kVK_ANSI_Keypad4              = 0x56"
		at: 16r57 put: (self value: 16rffb5); "  kVK_ANSI_Keypad5              = 0x57"
		at: 16r58 put: (self value: 16rffb6); "  kVK_ANSI_Keypad6              = 0x58"
		at: 16r59 put: (self value: 16rffb7); "  kVK_ANSI_Keypad7              = 0x59"
		at: 16r5B put: (self value: 16rffb8); "  kVK_ANSI_Keypad8              = 0x5B"
		at: 16r5C put: (self value: 16rffb9) "  kVK_ANSI_Keypad9              = 0x5C"! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
L
	^ self named: 'L'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
S
	^ self named: 'S'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
pageUp
	
	^ self named: 'PAGE_UP'! !

!KeyboardKey class methodsFor: 'instance creation' stamp: 'nil'!
fromCharacter: aCharacter
	"For backwards compatibility mainly.
	Return the key that should correspond to some character.
	Handle normal ascii characters and special control keys only (enter, tab space...)
	
	 (KeyboardKey fromCharacter: $a) >>> KeyboardKey A
	"
	
	^ self keyFromCharacterTable at: aCharacter ifAbsent: [ self named: aCharacter asString asUppercase ]! !

!KeyboardKey class methodsFor: 'key table' stamp: 'nil'!
initializeKeyTable
	KeyCodeTable := Dictionary new.
	KeyNameTable := Dictionary new.
	#(
		16r0000 Null
		16r08f6 Function "XK_function"
		16rff08 BackSpace "XK_BackSpace"
		16rff09 Tab "XK_Tab"
		16rff0a Linefeed "XK_Linefeed"
		16rff0b Clear "XK_Clear"
		16rff0d Return "XK_Return"
		16rff13 Pause "XK_Pause"
		16rff14 Scroll_Lock "XK_Scroll_Lock"
		16rff15 Sys_Req "XK_Sys_Req"
		16rff1b Escape "XK_Escape"
		16rffff Delete "XK_Delete"
		16rff50 Home "XK_Home"
		16rff51 Left "XK_Left"
		16rff52 Up "XK_Up"
		16rff53 Right "XK_Right"
		16rff54 Down "XK_Down"
		16rff55 Prior "XK_Prior"
		16rfe03 Level3Shift "XK_ISO_Level3_Shift"
		16r00a1 ExclamationDown "XK_exclamdown"
		16r00bf QuestionDown "XK_questiondown"
		16r00f1 NTilde "XK_ntilde"
		16r00d1 CapitalNTilde "XK_ntilde"
		16r00ba Masculine "XK_masculine"
		16r00e7 CCedilla "XK_ccedilla"
		16r00c7 CapitalCCedilla "XK_ccedilla"
		16r00aa FeminineOrdinal "XK_ordfeminine"
		16r00b7 MiddlePoint "XK_periodcentered"
		"16rff55 Prior ""XK_Prior"
		16rff55 Page_Up "XK_Page_Up"
		"16rff56 Next" "XK_Next"
		16rff56 Page_Down "XK_Page_Down"
		16rff57 End "XK_End"
		16rff58 Begin "XK_Begin"
		16rff80 KP_Space "XK_KP_Space"
		16rff89 KP_Tab "XK_KP_Tab"
		16rff8d KP_Enter "XK_KP_Enter"
		16rff91 KP_F1 "XK_KP_F1"
		16rff92 KP_F2 "XK_KP_F2"
		16rff93 KP_F3 "XK_KP_F3"
		16rff94 KP_F4 "XK_KP_F4"
		16rff95 KP_Home "XK_KP_Home"
		16rff96 KP_Left "XK_KP_Left"
		16rff97 KP_Up "XK_KP_Up"
		16rff98 KP_Right "XK_KP_Right"
		16rff99 KP_Down "XK_KP_Down"
		16rff9a KP_Prior "XK_KP_Prior"
		16rff9a KP_Page_Up "XK_KP_Page_Up"
		16rff9b KP_Next "XK_KP_Next"
		16rff9b KP_Page_Down "XK_KP_Page_Down"
		16rff9c KP_End "XK_KP_End"
		16rff9d KP_Begin "XK_KP_Begin"
		16rff9e KP_Insert "XK_KP_Insert"
		16rff9f KP_Delete "XK_KP_Delete"
		16rffbd KP_Equal "XK_KP_Equal"
		16rffaa KP_Multiply "XK_KP_Multiply"
		16rffab KP_Add "XK_KP_Add"
		16rffac KP_Separator "XK_KP_Separator"
		16rffad KP_Subtract "XK_KP_Subtract"
		16rffae KP_Decimal "XK_KP_Decimal"
		16rffaf KP_Divide "XK_KP_Divide"
		16rffb0 KP_0 "XK_KP_0"
		16rffb1 KP_1 "XK_KP_1"
		16rffb2 KP_2 "XK_KP_2"
		16rffb3 KP_3 "XK_KP_3"
		16rffb4 KP_4 "XK_KP_4"
		16rffb5 KP_5 "XK_KP_5"
		16rffb6 KP_6 "XK_KP_6"
		16rffb7 KP_7 "XK_KP_7"
		16rffb8 KP_8 "XK_KP_8"
		16rffb9 KP_9 "XK_KP_9"
		16rffbe F1 "XK_F1"
		16rffbf F2 "XK_F2"
		16rffc0 F3 "XK_F3"
		16rffc1 F4 "XK_F4"
		16rffc2 F5 "XK_F5"
		16rffc3 F6 "XK_F6"
		16rffc4 F7 "XK_F7"
		16rffc5 F8 "XK_F8"
		16rffc6 F9 "XK_F9"
		16rffc7 F10 "XK_F10"
		16rffc8 F11 "XK_F11"
		16rffc9 F12 "XK_F12"
		16rffe1 Shift_L "XK_Shift_L"
		16rffe2 Shift_R "XK_Shift_R"
		16rffe3 Control_L "XK_Control_L"
		16rffe4 Control_R "XK_Control_R"
		16rffe5 Caps_Lock "XK_Caps_Lock"
		16rffe6 Shift_Lock "XK_Shift_Lock"
		16rffe7 Meta_L "XK_Meta_L"
		16rffe8 Meta_R "XK_Meta_R"
		16rffe9 Alt_L "XK_Alt_L"
		16rffea Alt_R "XK_Alt_R"
		16rffeb Super_L "XK_Super_L"
		16rffec Super_R "XK_Super_R"
		16rffed Hyper_L "XK_Hyper_L"
		16rffee Hyper_R "XK_Hyper_R"
		16rfe50 dead_grave "XK_dead_grave"
		16rfe51 dead_acute "XK_dead_acute"
		16rfe52 dead_circumflex "XK_dead_circumflex"
		16rfe53 dead_tilde "XK_dead_tilde"
		16rfe53 dead_perispomeni "XK_dead_perispomeni"
		16rfe54 dead_macron "XK_dead_macron"
		16rfe55 dead_breve "XK_dead_breve"
		16rfe56 dead_abovedot "XK_dead_abovedot"
		16rfe57 dead_diaeresis "XK_dead_diaeresis"
		16rfe58 dead_abovering "XK_dead_abovering"
		16rfe59 dead_doubleacute "XK_dead_doubleacute"
		16rfe5a dead_caron "XK_dead_caron"
		16rfe5b dead_cedilla "XK_dead_cedilla"
		16rfe5c dead_ogonek "XK_dead_ogonek"
		16rfe5d dead_iota "XK_dead_iota"
		16rfe5e dead_voiced_sound "XK_dead_voiced_sound"
		16rfe5f dead_semivoiced_sound "XK_dead_semivoiced_sound"
		16rfe60 dead_belowdot "XK_dead_belowdot"
		16rfe61 dead_hook "XK_dead_hook"
		16rfe62 dead_horn "XK_dead_horn"
		16rfe63 dead_stroke "XK_dead_stroke"
		16rfe64 dead_abovecomma "XK_dead_abovecomma"
		16rfe64 dead_psili "XK_dead_psili"
		16rfe65 dead_abovereversedcomma "XK_dead_abovereversedcomma"
		16rfe65 dead_dasia "XK_dead_dasia"
		16rfe66 dead_doublegrave "XK_dead_doublegrave"
		16rfe67 dead_belowring "XK_dead_belowring"
		16rfe68 dead_belowmacron "XK_dead_belowmacron"
		16rfe69 dead_belowcircumflex "XK_dead_belowcircumflex"
		16rfe6a dead_belowtilde "XK_dead_belowtilde"
		16rfe6b dead_belowbreve "XK_dead_belowbreve"
		16rfe6c dead_belowdiaeresis "XK_dead_belowdiaeresis"
		16rfe6d dead_invertedbreve "XK_dead_invertedbreve"
		16rfe6e dead_belowcomma "XK_dead_belowcomma"
		16rfe6f dead_currency "XK_dead_currency"
		16r0020 space "XK_space"
		16r0021 exclam "XK_exclam"
		16r0022 quotedbl "XK_quotedbl"
		16r0023 numbersign "XK_numbersign"
		16r0024 dollar "XK_dollar"
		16r0025 percent "XK_percent"
		16r0026 ampersand "XK_ampersand"
		16r0027 apostrophe "XK_apostrophe"
		"16r0027 quoteright" "XK_quoteright"
		16r0028 parenleft "XK_parenleft"
		16r0029 parenright "XK_parenright"
		16r002a asterisk "XK_asterisk"
		16r002b plus "XK_plus"
		16r002c comma "XK_comma"
		16r002d minus "XK_minus"
		16r002e period "XK_period"
		16r002f slash "XK_slash"
		16r0030 0 "XK_0"
		16r0031 1 "XK_1"
		16r0032 2 "XK_2"
		16r0033 3 "XK_3"
		16r0034 4 "XK_4"
		16r0035 5 "XK_5"
		16r0036 6 "XK_6"
		16r0037 7 "XK_7"
		16r0038 8 "XK_8"
		16r0039 9 "XK_9"
		16r003a colon "XK_colon"
		16r003b semicolon "XK_semicolon"
		16r003c less "XK_less"
		16r003d equal "XK_equal"
		16r003e greater "XK_greater"
		16r003f question "XK_question"
		16r0040 at "XK_at"
		16r0041 A "XK_A"
		16r0042 B "XK_B"
		16r0043 C "XK_C"
		16r0044 D "XK_D"
		16r0045 E "XK_E"
		16r0046 F "XK_F"
		16r0047 G "XK_G"
		16r0048 H "XK_H"
		16r0049 I "XK_I"
		16r004a J "XK_J"
		16r004b K "XK_K"
		16r004c L "XK_L"
		16r004d M "XK_M"
		16r004e N "XK_N"
		16r004f O "XK_O"
		16r0050 P "XK_P"
		16r0051 Q "XK_Q"
		16r0052 R "XK_R"
		16r0053 S "XK_S"
		16r0054 T "XK_T"
		16r0055 U "XK_U"
		16r0056 V "XK_V"
		16r0057 W "XK_W"
		16r0058 X "XK_X"
		16r0059 Y "XK_Y"
		16r005a Z "XK_Z"
		16r005b bracketleft "XK_bracketleft"
		16r005c backslash "XK_backslash"
		16r005d bracketright "XK_bracketright"
		16r005e asciicircum "XK_asciicircum"
		16r005f underscore "XK_underscore"
		16r0060 grave "XK_grave"
		"16r0060 quoteleft" "XK_quoteleft"
		16r007b braceleft "XK_braceleft"	
		16r007c bar "XK_bar"
		16r007d braceright "XK_braceright"
		16r007e asciitilde "XK_asciitilde"
		16rff63 Insert "XK_Insert"
		16rff7f Num_Lock "XK_Num_Lock"
		
		16rffca F13	 "XK_F13"
		16rffcb F14	 "XK_F14"
		16rffcc F15	 "XK_F15"
		16rffcd F16	 "XK_F16"
		16rffce F17	 "XK_F17"
		16rffcf F18	 "XK_F18"
		16rffd0 F19	 "XK_F19"
		16rffd1 F20	 "XK_F20"
		16rffd2 F21	 "XK_F21"
		16rffd3 F22	 "XK_F22"
		16rffd4 F23	 "XK_F23"
		16rffd5 F24	 "XK_F24"
			
		16rff60 Select "XK_Select"
		16rff61 Print "XK_Print"
		16rff62 Execute "XK_Execute"
		16rff63 Insert "XK_Insert"
		16rff65 Undo "XK_Undo"
		16rff66 Redo "XK_Redo"
		16rff67 Menu "XK_Menu"
		16rff68 Find "XK_Find"
		16rff69 Cancel "XK_Cancel"
		16rff6a Help "XK_Help"
		16rff6b Break "XK_Break"

		16rff15 Sys_Req "XK_Sys_Req"
		16rfd1d PrintScreen "XK_3270_PrintScreen"
		16rfd1b ExSelect "XK_3270_ExSelect"
		16rfd1c CursorSelect "XK_3270_CursorSelect"

		16r1008FF57 Copy "XF86XK_Copy"
		16r1008FF58 Cut "XF86XK_Cut"
		16r1008FF6D Paste "XF86XK_Paste"

		)
			pairsDo: [ :keyCode :keyname |
			|key|
			key := self basicNew withValue: keyCode andName: keyname asString asUppercase asSymbol.
			KeyCodeTable at: keyCode put: key.
			KeyNameTable at: key name put: key.
		].! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
F
	^ self named: 'F'! !

!KeyboardKey class methodsFor: 'windows' stamp: 'nil'!
windowsVirtualKeyTable

	WindowsVirtualKeyTable ifNil: [ self initializeWindowsVirtualKeyTable. ].
	^WindowsVirtualKeyTable! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
H
	^ self named: 'H'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
K
	^ self named: 'K'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
keypadEnter

	^ self named: 'KP_ENTER'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
equal

	^ self named: 'EQUAL'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
pageDown

	^ self named: 'PAGE_DOWN'! !

!KeyboardKey class methodsFor: 'unix' stamp: 'nil'!
unixVirtualKeyTable
	UnixVirtualKeyTable ifNil: [ self initializeUnixVirtualKeyTable. ].
	^UnixVirtualKeyTable! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
home
	
	^ self named: 'HOME'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
up

	^ self named: 'UP'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
U
	^ self named: 'U'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
C
	^ self named: 'C'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
escape

	^ self named: 'ESCAPE'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
Q
	^ self named: 'Q'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
delete

	^ self named: 'DELETE'! !

!KeyboardKey class methodsFor: 'class initialization' stamp: 'nil'!
initialize
	self
		initializeKeyTable;
		initializeMacOSVirtualKeyTable;
		initializeUnixVirtualKeyTable;
		initializeWindowsVirtualKeyTable;
		initializeKeyFromCharacterCompatibilityTable! !

!KeyboardKey class methodsFor: 'macos' stamp: 'nil'!
valueForMacOSXPlatform: aKeyValue

	^self macOSVirtualKeyTable at: aKeyValue ifAbsent: [ (self basicNew withValue: aKeyValue andName: #Unknown) ] ! !

!KeyboardKey class methodsFor: 'instance creation' stamp: 'nil'!
fromCharacter: aCharacter ifNone: aBlock
	"For backwards compatibility mainly.
	Return the key that should correspond to some character.
	Handle normal ascii characters and special control keys only (enter, tab space...)
	
	 (KeyboardKey fromCharacter: $a) >>> KeyboardKey A
	"
	
	^ self keyFromCharacterTable
		at: aCharacter 
		ifAbsent: [ 
			self
				named: aCharacter asString asUppercase
				ifNone: aBlock ]! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
left

	^ self named: 'LEFT'! !

!KeyboardKey class methodsFor: 'unknownKeys' stamp: 'nil'!
unknownKeyName
	^#Unknown! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
T
	^ self named: 'T'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
E
	^ self named: 'E'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
keypadRight

	^ self named: 'KP_RIGHT'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
keypadUp

	^ self named: 'KP_UP'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
backspace

	^ self named: 'BACKSPACE'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
end
	
	^ self named: 'END'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
A
	^ self named: 'A'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
Z
	^ self named: 'Z'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
P
	^ self named: 'P'! !

!KeyboardKey class methodsFor: 'unix' stamp: 'nil'!
initializeUnixVirtualKeyTable
	self flag: #pharoTodo. "Some values are missing, need to gather them from users who are able to."
	UnixVirtualKeyTable := Dictionary new.
	UnixVirtualKeyTable
		at: Character cr asciiValue put: (self value: 16rff0d); " kVK_Return       = 0x24"
		at: Character tab asciiValue put: (self value: 16rff09); "  kVK_Tab        = 0x30"
		at: Character space asciiValue put: (self value: 16rff80); "  kVK_Space    = 0x31"
		at: Character delete asciiValue put: (self value: 16rffff); "  kVK_Delete  = 0x33"
		at: Character escape asciiValue put: (self value: 16rff1b); "  kVK_Escape  = 0x35"
		at: 8 put: (self value: 16rff08); "  kVK_Command                           = 0x37"
		at: -1 put: (self value: 16rffe7); "  kVK_Command                          = 0x37"
		at: 255 put: (self value: 16rffe1); "  kVK_Shift                           = 0x38"
		at: -1 put: (self value: 16rffe5); "  kVK_CapsLock                         = 0x39"
		at: 247 put: (self value: 16rffe9); "  kVK_Option                          = 0x3A"
		at: 251 put: (self value: 16rffe3); "  kVK_Control                         = 0x3B"
		at: 254 put: (self value: 16rffe2); "  kVK_RightShift                      = 0x3C"
      at: 246 put: (self value: 16rffea); " kVK_RightOption                      = 0x3D"
      at: 250 put: (self value: 16rffe4); " kVK_RightControl                     = 0x3E"
		at: -1 put: (self value: 16r08f6); "  kVK_Function                         = 0x3F"
		at: -1 put: (self value: 16r48); "  kVK_VolumeUp                           = 0x48"  "Not mapped"
		at: -1 put: (self value: 16r49); "  kVK_VolumeDown                         = 0x49" "Not mapped"
		at: -1 put: (self value: 16r4A); "  kVK_Mute                               = 0x4A" "Not mapped"
		at: -1 put: (self value: 16rffbe); "  kVK_F1                               = 0x7A"
		at: -1 put: (self value: 16rffbf); "  kVK_F2                               = 0x78"
		at: -1 put: (self value: 16rffc0); "  kVK_F3                               = 0x63"
		at: -1 put: (self value: 16rffc1); "  kVK_F4                               = 0x76"
		at: -1 put: (self value: 16rffc2); "  kVK_F5                               = 0x60"
		at: -1 put: (self value: 16rffc3); "  kVK_F6                               = 0x61"
		at: -1 put: (self value: 16rffc4); "  kVK_F7                               = 0x62"
		at: -1 put: (self value: 16rffc5); "  kVK_F8                               = 0x64"
		at: -1 put: (self value: 16rffc6); "  kVK_F9                               = 0x65"
		at: -1 put: (self value: 16rffc8); "  kVK_F11                              = 0x67"
		at: -1 put: (self value: 16rffc7); "  kVK_F10                              = 0x6D"
		at: -1 put: (self value: 16rffc9); "  kVK_F12                              = 0x6F"
		"at: -1 put: (self value: 16r72);" "  kVK_Help                               = 0x72" "Not mapped"
		at: Character home asciiValue put: (self value: 16rff50); "  kVK_Home      = 0x73"
		at: Character pageUp asciiValue put: (self value: 16rff55); "  kVK_PageUp  = 0x74"
		at: Character delete asciiValue put: (self value: 16rffff); "  kVK_ForwardDelete   = 0x75"
		at: Character end asciiValue put: (self value: 16rff57); "  kVK_End                = 0x77"
		at: Character pageDown asciiValue put: (self value: 16rff56); "  kVK_PageDown      = 0x79"
		at: Character arrowLeft asciiValue put: (self value: 16rff96); "  kVK_LeftArrow    = 0x7B"
		at: Character arrowRight asciiValue put: (self value: 16rff98); "  kVK_RightArrow  = 0x7C"
		at: Character arrowDown asciiValue put: (self value: 16rff99); "  kVK_DownArrow    = 0x7D"
		at: Character arrowUp asciiValue put: (self value: 16rff97); "  kVK_UpArrow        = 0x7E"
		at: $a asciiValue put: (self value: 16r41); "kVK_ANSI_A                    = 0x00"
		at: $b asciiValue put: (self value: 16r42); "  kVK_ANSI_B                  = 0x0B"
		at: $c asciiValue put: (self value: 16r43); "  kVK_ANSI_C                  = 0x08"
		at: $d asciiValue put: (self value: 16r44); "  kVK_ANSI_D                  = 0x02"
		at: $e asciiValue put: (self value: 16r45); "  kVK_ANSI_E                  = 0x0E"
		at: $f asciiValue put: (self value: 16r46); "  kVK_ANSI_F                  = 0x03"
		at: $g asciiValue put: (self value: 16r47); "  kVK_ANSI_G                  = 0x05"
		at: $h asciiValue put: (self value: 16r48); "  kVK_ANSI_H                  = 0x04"
		at: $i asciiValue put: (self value: 16r49); "  kVK_ANSI_I                  = 0x22"
		at: $j asciiValue put: (self value: 16r4a); "  kVK_ANSI_J                  = 0x26"
		at: $k asciiValue put: (self value: 16r4b); "  kVK_ANSI_K                  = 0x28"
		at: $l asciiValue put: (self value: 16r4c); "  kVK_ANSI_L                  = 0x25"
		at: $m asciiValue put: (self value: 16r4d); "  kVK_ANSI_M                  = 0x2E"
		at: $n asciiValue put: (self value: 16r4e); "  kVK_ANSI_N                  = 0x2D"
		at: $o asciiValue put: (self value: 16r4f); "  kVK_ANSI_O                  = 0x1F"
		at: $p asciiValue put: (self value: 16r50); "  kVK_ANSI_P                  = 0x23"
		at: $q asciiValue put: (self value: 16r51); "  kVK_ANSI_Q                  = 0x0C"
		at: $r asciiValue put: (self value: 16r52); "  kVK_ANSI_R                  = 0x0F"
		at: $s asciiValue put: (self value: 16r53); "  kVK_ANSI_S                  = 0x01"
		at: $t asciiValue put: (self value: 16r54); "  kVK_ANSI_T                  = 0x11"
		at: $u asciiValue put: (self value: 16r55); "  kVK_ANSI_U                  = 0x20"
		at: $v asciiValue put: (self value: 16r56); "  kVK_ANSI_V                  = 0x09"
		at: $w asciiValue put: (self value: 16r57); "  kVK_ANSI_W                  = 0x0D"
		at: $x asciiValue put: (self value: 16r58); "  kVK_ANSI_X                  = 0x07"
		at: $y asciiValue put: (self value: 16r59); "  kVK_ANSI_Y                  = 0x10"
		at: $z asciiValue put: (self value: 16r5a). "  kVK_ANSI_Z                  = 0x06"
	
	"Map also uppercase letters.
	Old VM events use the ascii value of characters in linux to refer to keys.
	Work it around by making lowercase and uppercase letters both refer to the same key"
	($A to: $Z) do: [ :c |
		UnixVirtualKeyTable at: c asciiValue put: (UnixVirtualKeyTable at: c asLowercase asciiValue) ].
		
	UnixVirtualKeyTable
		at: $0 asciiValue put: (self value: 16r30); "  kVK_ANSI_0                  = 0x1D"
		at: $1 asciiValue put: (self value: 16r31); "  kVK_ANSI_1                  = 0x12"
		at: $2 asciiValue put: (self value: 16r32); "  kVK_ANSI_2                  = 0x13"
		at: $3 asciiValue put: (self value: 16r33); "  kVK_ANSI_3                  = 0x14"
		at: $4 asciiValue put: (self value: 16r34); "  kVK_ANSI_4                  = 0x15"
		at: $5 asciiValue put: (self value: 16r35); "  kVK_ANSI_5                  = 0x17"
		at: $6 asciiValue put: (self value: 16r36); "  kVK_ANSI_6                  = 0x16"
		at: $7 asciiValue put: (self value: 16r37); "  kVK_ANSI_7                  = 0x1A"
		at: $8 asciiValue put: (self value: 16r38); "  kVK_ANSI_8                  = 0x1C"
		at: $9 asciiValue put: (self value: 16r39); "  kVK_ANSI_9                  = 0x19"

		at: $- asciiValue put: (self value: 16r2d); "  kVK_ANSI_Minus              = 0x1B"
		at: $= asciiValue put: (self value: 16r3d); "  kVK_ANSI_Equal              = 0x18"
		at: $[ asciiValue put: (self value: 16r5b); "  kVK_ANSI_LeftBracket        = 0x21"
		at: $] asciiValue put: (self value: 16r5d); "  kVK_ANSI_RightBracket       = 0x1E"
		at: $' asciiValue put: (self value: 16r27); "  kVK_ANSI_Quote              = 0x27"
		at: $; asciiValue put: (self value: 16r3b); "  kVK_ANSI_Semicolon          = 0x29"
		at: $/ asciiValue put: (self value: 16r5c); "  kVK_ANSI_Backslash          = 0x2A"
		at: $, asciiValue put: (self value: 16r2c); "  kVK_ANSI_Comma              = 0x2B"
		at: $\ asciiValue put: (self value: 16r2f); "  kVK_ANSI_Slash              = 0x2C"
		at: $. asciiValue put: (self value: 16r2e); "  kVK_ANSI_Period             = 0x2F"
		at: $` asciiValue put: (self value: 16r60)"; ""  kVK_ANSI_Grave              = 0x32""
		at: 1 put: (self value: 16rffae); ""  kVK_ANSI_KeypadDecimal                = 0x41""
		at: 1 put: (self value: 16rffaa); ""  kVK_ANSI_KeypadMultiply               = 0x43""
		at: 1 put: (self value: 16rffab); ""  kVK_ANSI_KeypadPlus                   = 0x45""
		at: 1 put: (self value: 16r47); ""  kVK_ANSI_KeypadClear                    = 0x47"" ""Not mapped""
		at: 1 put: (self value: 16rffaf); ""  kVK_ANSI_KeypadDivide                 = 0x4B""
		at: 1 put: (self value: 16rff8d); ""  kVK_ANSI_KeypadEnter                  = 0x4C""
		at: 1 put: (self value: 16rffad); ""  kVK_ANSI_KeypadMinus                  = 0x4E""
		at: 1 put: (self value: 16rffbd); ""  kVK_ANSI_KeypadEquals                 = 0x51""
		at: 1 put: (self value: 16rffb0); ""  kVK_ANSI_Keypad0                      = 0x52""
		at: 1 put: (self value: 16rffb1); ""  kVK_ANSI_Keypad1                      = 0x53""
		at: 1 put: (self value: 16rffb2); ""  kVK_ANSI_Keypad2                      = 0x54""
		at: 1 put: (self value: 16rffb3); ""  kVK_ANSI_Keypad3                      = 0x55""
		at: 1 put: (self value: 16rffb4); ""  kVK_ANSI_Keypad4                      = 0x56""
		at: 1 put: (self value: 16rffb5); ""  kVK_ANSI_Keypad5                      = 0x57""
		at: 1 put: (self value: 16rffb6); ""  kVK_ANSI_Keypad6                      = 0x58""
		at: 1 put: (self value: 16rffb7); ""  kVK_ANSI_Keypad7                      = 0x59""
		at: 1 put: (self value: 16rffb8); ""  kVK_ANSI_Keypad8                      = 0x5B""
		at: 1 put: (self value: 16rffb9) ""  kVK_ANSI_Keypad9                       = 0x5C"""! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
keypadDown

	^ self named: 'KP_DOWN'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
lessThan

	^ self named: 'LESS'! !

!KeyboardKey class methodsFor: 'instance creation' stamp: 'nil'!
keyFromCharacterTable

	KeyFromCharacterTable ifNil: [ self initializeKeyFromCharacterCompatibilityTable ].
	^ KeyFromCharacterTable! !

!KeyboardKey class methodsFor: 'windows' stamp: 'nil'!
initializeWindowsVirtualKeyTable
	self flag: #pharoTodo. "Some values are missing, need to gather them from users who are able to."
	WindowsVirtualKeyTable := Dictionary new.
	WindowsVirtualKeyTable
		at: 16r0d put: (self value: 16rff0d); " kVK_Return                    = 0x24"
		at: 16r09 put: (self value: 16rff09); "  kVK_Tab                       = 0x30"
		at: 16r20 put: (self value: 16rff80); "  kVK_Space                     = 0x31"
		at: 16r2e put: (self value: 16rffff); "  kVK_Delete                    = 0x33"
		at: 16r1b put: (self value: 16rff1b); "  kVK_Escape                    = 0x35"
		at: 16r5B put: (self value: 16rff08); "  kVK_Command                   = 0x37"
		at: 16r5c put: (self value: 16rffe7); "  kVK_Command                   = 0x37"
		at: 16r10 put: (self value: 16rffe1); "  kVK_Shift                     = 0x38"
		at: 16r14 put: (self value: 16rffe5); "  kVK_CapsLock                  = 0x39"
		at: 16r12 put: (self value: 16rffe9); "  kVK_Option                    = 0x3A"
		at: 16r11 put: (self value: 16rffe3); "  kVK_Control                   = 0x3B"
		at: 16ra0 put: (self value: 16rffe2); "  kVK_RightShift                = 0x3C"
		at: 16ra5 put: (self value: 16rffea); "  kVK_RightOption               = 0x3D"
		at: 16ra3 put: (self value: 16rffe4); "  kVK_RightControl              = 0x3E"
		at: -1 put: (self value: 16r08f6); "  kVK_Function                  = 0x3F"
		at: 16raf put: (self value: 16r48); "  kVK_VolumeUp                  = 0x48"  "Not mapped"
		at: 16rae put: (self value: 16r49); "  kVK_VolumeDown                = 0x49" "Not mapped"
		at: 16rad put: (self value: 16r4A); "  kVK_Mute                      = 0x4A" "Not mapped"
		at: 16r70 put: (self value: 16rffbe); "  kVK_F1                        = 0x7A"
		at: 16r71 put: (self value: 16rffbf); "  kVK_F2                        = 0x78"
		at: 16r72 put: (self value: 16rffc0); "  kVK_F3                        = 0x63"
		at: 16r73 put: (self value: 16rffc1); "  kVK_F4                        = 0x76"
		at: 16r74 put: (self value: 16rffc2); "  kVK_F5                        = 0x60"
		at: 16r75 put: (self value: 16rffc3); "  kVK_F6                        = 0x61"
		at: 16r76 put: (self value: 16rffc4); "  kVK_F7                        = 0x62"
		at: 16r77 put: (self value: 16rffc5); "  kVK_F8                        = 0x64"
		at: 16r78 put: (self value: 16rffc6); "  kVK_F9                        = 0x65"
		at: 16r79 put: (self value: 16rffc8); "  kVK_F11                       = 0x67"
		at: 16r7a put: (self value: 16rffc7); "  kVK_F10                       = 0x6D"
		at: 16r7b put: (self value: 16rffc9); "  kVK_F12                       = 0x6F"
		"at: 16r2f put: (self value: 16r72);" "  kVK_Help                      = 0x72" "Not mapped"
		at: 16r24 put: (self value: 16rff50); "  kVK_Home                      = 0x73"
		at: 16r21 put: (self value: 16rff55); "  kVK_PageUp                    = 0x74"
		at: 16r2e put: (self value: 16rffff); "  kVK_ForwardDelete             = 0x75"
		at: 16r23 put: (self value: 16rff57); "  kVK_End                       = 0x77"
		at: 16r22 put: (self value: 16rff56); "  kVK_PageDown                  = 0x79"
		at: 16r1c put: (self value: 16rff96); "  kVK_LeftArrow                 = 0x7B"
		at: 16r1d put: (self value: 16rff98); "  kVK_RightArrow                = 0x7C"
		at: 16r1f put: (self value: 16rff99); "  kVK_DownArrow                 = 0x7D"
		at: 16r1e put: (self value: 16rff97); "  kVK_UpArrow                   = 0x7E"
		at: 16r41 put: (self value: 16r41); "kVK_ANSI_A                    = 0x00"
		at: 16r42 put: (self value: 16r42); "  kVK_ANSI_B                    = 0x0B"
		at: 16r43 put: (self value: 16r43); "  kVK_ANSI_C                    = 0x08"
		at: 16r44 put: (self value: 16r44); "  kVK_ANSI_D                    = 0x02"
		at: 16r45 put: (self value: 16r45); "  kVK_ANSI_E                    = 0x0E"
		at: 16r46 put: (self value: 16r46); "  kVK_ANSI_F                    = 0x03"
		at: 16r47 put: (self value: 16r47); "  kVK_ANSI_G                    = 0x05"
		at: 16r48 put: (self value: 16r48); "  kVK_ANSI_H                    = 0x04"
		at: 16r49 put: (self value: 16r49); "  kVK_ANSI_I                    = 0x22"
		at: 16r4a put: (self value: 16r4a); "  kVK_ANSI_J                    = 0x26"
		at: 16r4b put: (self value: 16r4b); "  kVK_ANSI_K                    = 0x28"
		at: 16r4c put: (self value: 16r4c); "  kVK_ANSI_L                    = 0x25"
		at: 16r4d put: (self value: 16r4d); "  kVK_ANSI_M                    = 0x2E"
		at: 16r4e put: (self value: 16r4e); "  kVK_ANSI_N                    = 0x2D"
		at: 16r4f put: (self value: 16r4f); "  kVK_ANSI_O                    = 0x1F"
		at: 16r50 put: (self value: 16r50); "  kVK_ANSI_P                    = 0x23"
		at: 16r51 put: (self value: 16r51); "  kVK_ANSI_Q                    = 0x0C"
		at: 16r52 put: (self value: 16r52); "  kVK_ANSI_R                    = 0x0F"
		at: 16r53 put: (self value: 16r53); "  kVK_ANSI_S                    = 0x01"
		at: 16r54 put: (self value: 16r54); "  kVK_ANSI_T                    = 0x11"
		at: 16r55 put: (self value: 16r55); "  kVK_ANSI_U                    = 0x20"
		at: 16r56 put: (self value: 16r56); "  kVK_ANSI_V                    = 0x09"
		at: 16r57 put: (self value: 16r57); "  kVK_ANSI_W                    = 0x0D"
		at: 16r58 put: (self value: 16r58); "  kVK_ANSI_X                    = 0x07"
		at: 16r59 put: (self value: 16r59); "  kVK_ANSI_Y                    = 0x10"
		at: 16r5a put: (self value: 16r5a); "  kVK_ANSI_Z                    = 0x06"
		
		at: $0 asciiValue put: (self value: 16r30); "  kVK_ANSI_0                    = 0x1D"
		at: $1 asciiValue put: (self value: 16r31); "  kVK_ANSI_1                    = 0x12"
		at: $2 asciiValue put: (self value: 16r32); "  kVK_ANSI_2                    = 0x13"
		at: $3 asciiValue put: (self value: 16r33); "  kVK_ANSI_3                    = 0x14"
		at: $4 asciiValue put: (self value: 16r34); "  kVK_ANSI_4                    = 0x15"
		at: $5 asciiValue put: (self value: 16r35); "  kVK_ANSI_5                    = 0x17"
		at: $6 asciiValue put: (self value: 16r36); "  kVK_ANSI_6                    = 0x16"
		at: $7 asciiValue put: (self value: 16r37); "  kVK_ANSI_7                    = 0x1A"
		at: $8 asciiValue put: (self value: 16r38); "  kVK_ANSI_8                    = 0x1C"
		at: $9 asciiValue put: (self value: 16r39); "  kVK_ANSI_9                    = 0x19"

		at: 16rbd put: (self value: 16r2d); "  kVK_ANSI_Minus                = 0x1B"
		at: $= asciiValue put: (self value: 16r3d); "  kVK_ANSI_Equal                = 0x18"
		at: 16rdb put: (self value: 16r5b); "  kVK_ANSI_LeftBracket          = 0x21"
		at: 16rdd put: (self value: 16r5d); "  kVK_ANSI_RightBracket         = 0x1E"
		at: 1 put: (self value: 16r27); "  kVK_ANSI_Quote                = 0x27"
		at: 16rba put: (self value: 16r3b); "  kVK_ANSI_Semicolon            = 0x29"
		at: 16rbf put: (self value: 16r5c); "  kVK_ANSI_Backslash            = 0x2A"
		at: 16rbc put: (self value: 16r2c); "  kVK_ANSI_Comma                = 0x2B"
		at: 16rdc put: (self value: 16r2f); "  kVK_ANSI_Slash                = 0x2C"
		at: 16rbe put: (self value: 16r2e); "  kVK_ANSI_Period               = 0x2F"
		at: 16rc0 put: (self value: 16r60); "  kVK_ANSI_Grave                = 0x32"
		at: 16r6e put: (self value: 16rffae); "  kVK_ANSI_KeypadDecimal        = 0x41"
		at: 16r6a put: (self value: 16rffaa); "  kVK_ANSI_KeypadMultiply       = 0x43"
		at: 16r6b put: (self value: 16rffab); "  kVK_ANSI_KeypadPlus           = 0x45"
		at: 16r0c put: (self value: 16r47); "  kVK_ANSI_KeypadClear          = 0x47" "Not mapped"
		at: 16r6f put: (self value: 16rffaf); "  kVK_ANSI_KeypadDivide         = 0x4B"
		at: 16r0d put: (self value: 16rff8d); "  kVK_ANSI_KeypadEnter          = 0x4C"
		at: 16r6d put: (self value: 16rffad); "  kVK_ANSI_KeypadMinus          = 0x4E"
		at: 1 put: (self value: 16rffbd); "  kVK_ANSI_KeypadEquals         = 0x51"
		at: 16r60 put: (self value: 16rffb0); "  kVK_ANSI_Keypad0              = 0x52"
		at: 16r61 put: (self value: 16rffb1); "  kVK_ANSI_Keypad1              = 0x53"
		at: 16r62 put: (self value: 16rffb2); "  kVK_ANSI_Keypad2              = 0x54"
		at: 16r63 put: (self value: 16rffb3); "  kVK_ANSI_Keypad3              = 0x55"
		at: 16r64 put: (self value: 16rffb4); "  kVK_ANSI_Keypad4              = 0x56"
		at: 16r65 put: (self value: 16rffb5); "  kVK_ANSI_Keypad5              = 0x57"
		at: 16r66 put: (self value: 16rffb6); "  kVK_ANSI_Keypad6              = 0x58"
		at: 16r67 put: (self value: 16rffb7); "  kVK_ANSI_Keypad7              = 0x59"
		at: 16r68 put: (self value: 16rffb8); "  kVK_ANSI_Keypad8              = 0x5B"
		at: 16r69 put: (self value: 16rffb9) "  kVK_ANSI_Keypad9              = 0x5C"! !

!KeyboardKey class methodsFor: 'windows' stamp: 'nil'!
valueForWindowsPlatform: aKeyCode

	^self windowsVirtualKeyTable at: aKeyCode ifAbsent: [ (self basicNew withValue: aKeyCode andName: #Unknown) ] ! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
R
	^ self named: 'R'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
comma
	
	^ self named: 'COMMA'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
doubleQuote

	^ self named: 'QUOTEDBL'! !

!KeyboardKey class methodsFor: 'instance creation' stamp: 'nil'!
named: aString
	"Returns the instance of myself having aString as name.
	
	 (KeyboardKey named: 'SHIFT_L') >>> (KeyboardKey value: 65505)
	"
	
	^ KeyNameTable at: aString! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
tab

	^ self named: 'TAB'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
down

	^ self named: 'DOWN'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
Y
	^ self named: 'Y'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
parenthesisLeft
	
	^ self named: 'PARENLEFT'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
D
	^ self named: 'D'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
bracketLeft
	
	^ self named: 'BRACKETLEFT'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
W
	^ self named: 'W'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
keypadLeft

	^ self named: 'KP_LEFT'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
J
	^ self named: 'J'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
right

	^ self named: 'RIGHT'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
V
	^ self named: 'V'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
M
	^ self named: 'M'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
X
	^ self named: 'X'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
singleQuote

	^ self named: 'APOSTROPHE'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
O
	^ self named: 'O'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
I
	^ self named: 'I'! !

!KeyboardKey class methodsFor: 'key table' stamp: 'nil'!
initializeKeyFromCharacterCompatibilityTable
	KeyFromCharacterTable := Dictionary new.
	{ 
		Character backspace 	. #Backspace "XK_BackSpace".
		Character tab 			. #Tab "XK_Tab".
		Character cr 			. #Return "XK_Return".
		Character escape		. #Escape "XK_Escape".
		Character home			. #Home "XK_Home".
		Character arrowLeft 	. #Left "XK_Left".
		Character arrowUp 		. #Up "XK_Up".
		Character arrowRight 	. #Right "XK_Right".
		Character arrowDown 	. #Down "XK_Down".
		Character pageUp 		. #Page_Up "XK_Page_Up".
		Character pageDown 	. #Page_Down "XK_Page_Down".
		Character end 			. #End "XK_End".
		Character space 		. #Space "XK_Space".
		$/ 							. #SLASH.
		$] 							. #BRACKETLEFT.
		$[ 							. #BRACKETRIGHT.
		$( 							. #parenleft.
		$) 							. #parenright.
		$< 							. #less.
		$< 							. #greater.
		$| 							. #bar.
		$- 							. #minus}
			pairsDo: [ :character :keyname |
				KeyFromCharacterTable at: character put: (self named: keyname asUppercase) ].! !

!KeyboardKey class methodsFor: 'macos' stamp: 'nil'!
macOSVirtualKeyTable
	MacosVirtualKeyTable ifNil: [ self initializeMacOSVirtualKeyTable. ].
	^MacosVirtualKeyTable! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
space

	^ self named: 'SPACE'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
minus
	
	^ self named: 'MINUS'! !

!KeyboardKey class methodsFor: 'unix' stamp: 'nil'!
valueForUnixPlatform: aKeyValue

	^self unixVirtualKeyTable at: aKeyValue ifAbsent: [ (self basicNew withValue: aKeyValue) ] ! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
enter

	^ self named: 'RETURN'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
B
	^ self named: 'B'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
G
	^ self named: 'G'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
N
	^ self named: 'N'! !

!KeyboardKey class methodsFor: 'accessing' stamp: 'nil'!
braceLeft
	
	^ self named: 'BRACELEFT'! !

!KeyboardKeyTest commentStamp: ''!
A KeyboardKeyTest is a test class for testing the behavior of KeyboardKey!
!KeyboardKeyTest methodsFor: 'tests' stamp: ''!
testNamed
	"These assertions have been written using data available in KeyboardKey class>>#initializeKeyTable"
	self assert: (KeyboardKey named: 'SHIFT_L') equals: (KeyboardKey value: 65505).
	
	self assert: (KeyboardKey named: 'LEFT') equals: (KeyboardKey value: 65361).
	
	self assert: (KeyboardKey named: 'ALT_R') equals: (KeyboardKey value: 65514).
	
	self should: [ KeyboardKey named: 'a' ] raise: NotFound. "We do not distinguish 'a' FROM 'A', it is always 'A'."
	
	self assert: (KeyboardKey named: 'A') equals: (KeyboardKey value: 65).! !

!KeyboardKeyTest methodsFor: 'tests' stamp: ''!
testValue
	| key |
	key := KeyboardKey value: 65505.
	self assert: key value equals: 65505.
	self assert: key name equals: 'SHIFT_L'.
	
	key := KeyboardKey value: 65361.
	self assert: key value equals: 65361.
	self assert: key name equals: 'LEFT'.
	
	key := KeyboardKey value: 65514.
	self assert: key value equals: 65514.
	self assert: key name equals: 'ALT_R'.
	
	self should: [ KeyboardKey value: 97 ] raise: NotFound. "We do not distinguish 'a' FROM 'A', it is always 'A'."
	
	key := KeyboardKey value: 65.
	self assert: key value equals: 65.
	self assert: key name equals: 'A'.! !

!KeyboardKeyTest methodsFor: 'tests' stamp: ''!
testEqual 

	self 
		assert: (KeyboardKey fromCharacter: Character arrowUp) 
		equals: (KeyboardKey new 
			withValue: 65362;
			yourself)! !

!KeyedTree commentStamp: ''!
Provides path based access to elements contained in the receiver and any subtrees.

### Example
```
(KeyedTree new
	at: 1 put: 'One';
	at: 2 put: 'Two';
	at: 'Tree' put: (KeyedTree new
					at: $a put: 'Tree-A';
					at: $b put: 'Tree-B';
					yourself);
	yourself) atPath: #('Tree' $b)
```!
!KeyedTree methodsFor: 'accessing' stamp: ''!
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: ''!
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: ''!
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: ''!
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: 'copying' stamp: ''!
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
				ifNotNil: [ Association
						key: assoc key
						value:
							((assoc value isKindOf: KeyedTree)
								ifTrue: [ assoc value copy ]
								ifFalse: [ assoc value ]) ] ]! !

!KeyedTree methodsFor: 'printing' stamp: ''!
putFormattedTextOn: aStream withDescriptions: aKeyedTree level: indentLevel indentString: aString
	"Place a print of the receiver and associated description on the given stream with the given indentation level."

	
	(self keys asSortedCollection: self sortBlock) do: [:k | | v |
		indentLevel timesRepeat: [aStream nextPutAll: aString].
		aStream nextPutAll: k printString.
		v := self at: k.
		(v isKindOf: self class)
			ifTrue: [aStream cr.
					v
						putFormattedTextOn: aStream
						withDescriptions: (aKeyedTree at: k ifAbsent: [self class new])
						level: indentLevel + 1
						indentString: aString]
			ifFalse: [aStream
						nextPutAll: ' : ';
						nextPutAll: v printString;
						tab; tab;
						nextPutAll: (aKeyedTree at: k ifAbsent: ['nondescript']) printString.
					aStream cr]]! !

!KeyedTree methodsFor: 'accessing' stamp: ''!
subtrees
	"Answer the subtrees of the receiver."

	^(self select: [:v | v isKindOf: KeyedTree]) values! !

!KeyedTree methodsFor: 'removing' stamp: ''!
removePath: anArray ifAbsent: aBlock
	"Remove and answer the element referenced by the given path.
	Answer the value of aBlock if not found."

	|element|
	anArray isEmpty
		ifTrue: [^self].
	element := self.
	anArray allButLastDo: [:key |
		element := element at: key ifAbsent: [^aBlock value]].
	^element removeKey: anArray last ifAbsent: aBlock! !

!KeyedTree methodsFor: 'printing' stamp: ''!
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: ''!
formattedText
	"Answer a string or text representing the receiver with indentation and, possibly, markup."

	|str|
	str := String new writeStream.
	self putFormattedTextOn: str level: 0 indentString: '  '.
	^str contents! !

!KeyedTree methodsFor: 'removing' stamp: ''!
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: 'accessing' stamp: ''!
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: 'adding' stamp: ''!
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)
						ifFalse: [ subtree := self at: k put: v species new ].
					subtree merge: v ]
				ifFalse: [ self at: k put: v ] ]! !

!KeyedTree methodsFor: 'accessing' stamp: ''!
sortBlock
	"Answer the block to sort tree keys with."

	^[:a :b | [a <= b] on: Error do: [a class name <= b class name]]! !

!KeyedTree methodsFor: 'printing' stamp: ''!
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! !

!KeyedTreeTest commentStamp: ''!
SUnit tests for keyed trees!
!KeyedTreeTest methodsFor: 'tests' stamp: ''!
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: 'tests' stamp: ''!
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: 'tests' stamp: ''!
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: 'tests' stamp: ''!
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: 'tests' stamp: ''!
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: 'tests' stamp: ''!
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: 'tests' stamp: ''!
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: 'tests' stamp: ''!
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: 'tests' stamp: ''!
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}].! !

!LGitAbstractCloneOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fetchOptions
	^ self prim_fetch_opts! !

!LGitAbstractCloneOptions methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self withReturnHandlerDo: [
		self
			clone_init_options: self
			version: LGitOptionsVersionsEnum  git_clone_options_version_1 ].
	self prim_fetch_opts prim_proxy_opts prim_type: LGitProxyTypeEnum git_proxy_auto! !

!LGitAbstractCloneOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
remoteCallback: aRemoteCallback
	self prim_remote_cb: aRemoteCallback! !

!LGitAbstractCloneOptions methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
clone_init_options: opts version: version 

	self subclassResponsibility! !

!LGitAbstractCloneOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fetchOptions: _fetchOptions
	fetchOptions := _fetchOptions.
	self prim_fetch_opts: fetchOptions! !

!LGitAbstractCloneOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
checkoutOptions
	^ self prim_checkout_opts! !

!LGitAbstractCloneOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
remoteCallback
	^ self prim_remote_cb! !

!LGitAbstractCloneOptions class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
withCredentialsCallback: aBlock
	| credentialsCallback callbacks fetchOptions  |
	credentialsCallback := LGitCredAcquireCallback on: aBlock.

	callbacks := self ffiLibrary uniqueInstance remoteCallbacksStructureClass defaults
		credentials: credentialsCallback;
		yourself.

	fetchOptions := self ffiLibrary uniqueInstance fetchOptionsStructureClass defaults
		callbacks: callbacks;
		yourself.

	^ self defaults
		fetchOptions: fetchOptions;
		yourself.! !

!LGitAbstractCloneOptions class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isAbstract

	^ self == LGitAbstractCloneOptions! !

!LGitAbstractCloneOptions class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
withCredentialsProvider: provider
	| fetchOptions |
	fetchOptions := self ffiLibrary uniqueInstance fetchOptionsStructureClass defaults
		callbacks: (self ffiLibrary uniqueInstance remoteCallbacksStructureClass withProvider: provider);
		yourself.

	^ self defaults
		fetchOptions: fetchOptions
		yourself.! !

!LGitAbstractError commentStamp: 'TorstenBergmann 6/2/2021 20:40'!
Abstract superclass for git errors!
!LGitAbstractError methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
initialize

	super initialize.
	self messageText: LGitError lastMessage! !

!LGitAbstractError methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
object: anObject

	object := anObject! !

!LGitAbstractError methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
object

	^ object! !

!LGitAbstractError methodsFor: '*Iceberg-Libgit' stamp: ''!
acceptError: aVisitor
	^ aVisitor visitGenericError: self! !

!LGitAbstractError class methodsFor: 'signalling' stamp: ' 1/5/2022 21:01:26'!
signalWith: anObject

	^ self new
		object: anObject;
		signal! !

!LGitAbstractError class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isAbstract 

	^self == LGitAbstractError! !

!LGitAbstractFetchOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
callbacks
	^ self prim_callbacks! !

!LGitAbstractFetchOptions methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self withReturnHandlerDo: [
		self
			fetch_init_options: self
			version: LGitOptionsVersionsEnum git_fetch_options_version_1 ].
	self prim_proxy_opts prim_type: LGitProxyTypeEnum git_proxy_auto! !

!LGitAbstractFetchOptions methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
fetch_init_options: opts version: version
	
	self subclassResponsibility! !

!LGitAbstractFetchOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
callbacks: _callbacks
	callbacks := _callbacks.
	self prim_callbacks: callbacks! !

!LGitAbstractFetchOptions class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isAbstract

	^ self == LGitAbstractFetchOptions! !

!LGitAbstractPushOptions commentStamp: 'Guille 5/19/2020 14:23'!
https://libgit2.org/libgit2/#v1.0.0/type/git_push_options

git_push_options
Controls the behavior of a git_push object.

unsigned int	version

unsigned int	pb_parallelism
If the transport being used to push to the remote requires the creation of a pack file, this controls the number of worker threads used by the packbuilder when creating that pack file to be sent to the remote. If set to 0, the packbuilder will auto-detect the number of threads to create. The default value is 1.

git_remote_callbacks	callbacks
Callbacks to use for this push operation

git_proxy_options	proxy_opts
Proxy options to use, by default no proxy is used.

git_strarray	custom_headers
Extra headers for this push operation

Defined in: git2/remote.h!
!LGitAbstractPushOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
callbacks
	^ self prim_callbacks! !

!LGitAbstractPushOptions methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
push_init_options: options version: version
	
	self subclassResponsibility! !

!LGitAbstractPushOptions methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self withReturnHandlerDo: [
		self
			push_init_options: self
			version: LGitOptionsVersionsEnum git_push_options_version_1 ].
	 self prim_proxy_opts prim_type: LGitProxyTypeEnum git_proxy_auto! !

!LGitAbstractPushOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
callbacks: _callbacks
	callbacks := _callbacks.
	^ self prim_callbacks: callbacks! !

!LGitAbstractPushOptions class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isAbstract

	^ self == LGitAbstractPushOptions! !

!LGitAbstractRemoteCallbacks methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_init_callbacks: opts version: version 
	
	self subclassResponsibility! !

!LGitAbstractRemoteCallbacks methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self withReturnHandlerDo: [
		self
			remote_init_callbacks: self
			version: LGitStructVersionsEnum git_remote_callbacks_version_1 ]! !

!LGitAbstractRemoteCallbacks methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
credentials
	^ self prim_credentials! !

!LGitAbstractRemoteCallbacks methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
credentials: aCredentialsCallback
	credentialsCallback := aCredentialsCallback.
	self prim_credentials: credentialsCallback! !

!LGitAbstractRemoteCallbacks methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
certificateCheck: aCallback
	certificateCheckCallback := aCallback.
	self prim_certificate_check: aCallback! !

!LGitAbstractRemoteCallbacks methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
pushTransferProgress: aCallback
	pushTransferProgress := aCallback.
	self prim_push_transfer_progress: aCallback! !

!LGitAbstractRemoteCallbacks methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
transferProgress: aCallback
	transferProgressCallback := aCallback.
	self prim_transfer_progress: aCallback! !

!LGitAbstractRemoteCallbacks class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
putCredentialsType: types username: username provider: provider onto: output  

	(types anyMask: 1 << 1) ifTrue: [ 
		^ provider sshCredentialsClass 
			createFrom: provider 
			username: username
			onto: output ].

	(types anyMask: 1 << 0) ifTrue: [ 
		^ LGitCredentialsPlaintext createFrom: provider onto: output ].

	^ -1! !

!LGitAbstractRemoteCallbacks class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
newCertificateCheckCallback
	self flag: #fixMe. "I need to skip the verification of certificate because on macOS, 
	libgit2 has problems to be compiled with Secure framework, and if compiled with 
	openssl instead, openssl for macOS does not checks agains the certificates installed 
	at S.O., so it will fail almost always. This is, of course, a workaround... eventually 
	libgit2 will work :P"
	^ LGitTransportCertificateCheckCallback on: [ :cert :value :host :payload  |
		1 ]! !

!LGitAbstractRemoteCallbacks class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isAbstract

	^ self == LGitAbstractRemoteCallbacks! !

!LGitAbstractRemoteCallbacks class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
defaults
	^ super defaults 
		certificateCheck: self newCertificateCheckCallback;
		yourself! !

!LGitAbstractRemoteCallbacks class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
withProvider: provider

	^ self defaults
		credentials: (self newCredentialsCallbackFor: provider);
		certificateCheck: self newCertificateCheckCallback;
		yourself! !

!LGitAbstractRemoteCallbacks class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
newCredentialsCallbackFor: provider
	^ LGitCredAcquireCallback
		on: [ :output :url :username_from_url :allowed_types :data | 
			"Allowed types are defined in git_credtype_t 
		https://github.com/libgit2/libgit2/blob/HEAD/include/git2/transport.h#L81-111"
			self
				putCredentialsType: allowed_types
				username: username_from_url
				provider: provider
				onto: output ]! !

!LGitAnnotatedCommit commentStamp: 'TorstenBergmann 6/2/2021 22:23'!
See [https://libgit2.org/libgit2/#HEAD/group/annotated](https://libgit2.org/libgit2/#HEAD/group/annotated)!
!LGitAnnotatedCommit methodsFor: 'initialize' stamp: ' 1/5/2022 21:01:26'!
annotated_commit_from_ref: ref
	^ self ffiCall: #(
		int git_annotated_commit_from_ref #(
			LGitAnnotatedCommit * self , 
			LGitRepository repository ,
			LGitReference ref)) 
		options: #()! !

!LGitAnnotatedCommit methodsFor: 'initialize' stamp: ' 1/5/2022 21:01:26'!
initializeFromRef: anLGitReference

	self withReturnHandlerDo: [ 
		self annotated_commit_from_ref: anLGitReference
	].

	self autoRelease! !

!LGitAnnotatedCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
annotated_commit_id

	 ^ self ffiCallSafely: #(LGitId * git_annotated_commit_id #(self)) options: #()! !

!LGitAnnotatedCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
id

	^ self annotated_commit_id! !

!LGitAnnotatedCommit class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #annotated_commit_free:! !

!LGitAnnotatedCommit class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromRef: anLGitReference
	^ (self of: anLGitReference repository) initializeFromRef: anLGitReference! !

!LGitAnnotatedCommit class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
annotated_commit_free: handle
	^ self
		ffiCallSafely: #(void git_annotated_commit_free #(void *handle))
		options: #()! !

!LGitBlame commentStamp: 'TorstenBergmann 6/2/2021 22:14'!
Opaque structure to hold blame results

See [https://libgit2.org/libgit2/#HEAD/type/git_blame](https://libgit2.org/libgit2/#HEAD/type/git_blame)!
!LGitBlame methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
numberOfHunks
	^ self blame_get_hunk_count: self! !

!LGitBlame methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blame_get_hunk_byline: blame lineno: lineno
	"todo: using LGitBlameHunk* as return value causes random crashes"
	
	^ self
		ffiCallSafely: #(void * git_blame_get_hunk_byline #(self , size_t lineno))
		options: #()! !

!LGitBlame methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
hunkAtLineNumber: anInteger
	"first line has index 1"
	^ LGitBlameHunk fromExternalAddress: (
		self
			blame_get_hunk_byline: self
			lineno: anInteger)! !

!LGitBlame methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blame_get_hunk_byindex: blame index: index
	"todo: using LGitBlameHunk* as return value causes random crashes"
	
	^ self
		ffiCallSafely: #(void * git_blame_get_hunk_byindex #(self , uint32 index))
		options: #()! !

!LGitBlame methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blame_buffer: out reference: reference buffer: buffer buffer_len: buffer_len
	
	^ self
		ffiCall:
			#(FFIInt32 git_blame_buffer #(LGitBlame *self , LGitBlame reference , String buffer , size_t buffer_len))
		options: #()! !

!LGitBlame methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blame_file: out repo: repo path: path options: options
	
	^ self
		ffiCall:
			#(int git_blame_file #(LGitBlame * self , LGitRepository repo , String path , LGitBlameOptions * options))
		options: #()! !

!LGitBlame methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blame_get_hunk_count: blame
	
	^ self
		ffiCallSafely: #(uint32 git_blame_get_hunk_count #(self))
		options: #()! !

!LGitBlame methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
getForReference: aFileReference
	^ self withReturnHandlerDo: [
		self
			blame_file: self
			repo: self repository
			path: ((aFileReference relativeTo: self repository repositoryReference) printWithDelimiter: $/)
			options: LGitBlameOptions defaults ]! !

!LGitBlame methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
hunkAt: anInteger
	"use 1 based offset"
	^ LGitBlameHunk fromExternalAddress: (
		self
			blame_get_hunk_byindex: self
			index: anInteger - 1)! !

!LGitBlame class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #blame_free:! !

!LGitBlame class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository on: aFileReference
	^ (self of: aRepository)
		getForReference: aFileReference;
		yourself! !

!LGitBlame class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blame_free: handle
	^ self ffiCallSafely: #(void git_blame_free #(void *handle)) options: #()! !

!LGitBlameFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_blame_track_copies_same_commit_copies
	^ self basicNew
		value: 4;
		yourself! !

!LGitBlameFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_blame_track_copies_same_file
	^ self basicNew
		value: 1;
		yourself! !

!LGitBlameFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_blame_track_copies_same_commit_moves
	^ self basicNew
		value: 2;
		yourself! !

!LGitBlameFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_blame_normal
	^ self basicNew
		value: 0;
		yourself! !

!LGitBlameFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_blame_first_parent
	^ self basicNew
		value: 16;
		yourself! !

!LGitBlameFlagTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^ #(
		"Normal blame the default"
		GIT_BLAME_NORMAL 0
		"Track lines that have moved within a file (like `git blame -M`).
		 * NOT IMPLEMENTED."
		GIT_BLAME_TRACK_COPIES_SAME_FILE 1
		"Track lines that have moved across files in the same commit (like `git blame -C`).
		 * NOT IMPLEMENTED."
		GIT_BLAME_TRACK_COPIES_SAME_COMMIT_MOVES 2
		"Track lines that have been copied from another file that exists in the
		 * same commit (like `git blame -CC`). Implies SAME_FILE.
		 * NOT IMPLEMENTED."
		GIT_BLAME_TRACK_COPIES_SAME_COMMIT_COPIES 4
		"Track lines that have been copied from another file that exists in *any*
		 * commit (like `git blame -CCC`). Implies SAME_COMMIT_COPIES.
		 * NOT IMPLEMENTED."
		GIT_BLAME_TRACK_COPIES_ANY_COMMIT_COPIES 8
		"Restrict the search of commits to those reachable following only the
		 * first parents."
		GIT_BLAME_FIRST_PARENT 16
	)! !

!LGitBlameFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_blame_track_copies_any_commit_copies
	^ self basicNew
		value: 8;
		yourself! !

!LGitBlameHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
finalStartLineNumber
	^ self prim_final_start_line_number! !

!LGitBlameHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
originalPath
	^ self prim_orig_path readStringUTF8! !

!LGitBlameHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
finalCommitId
	^ self prim_final_commit_id! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_orig_commit_id: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_ORIG_COMMIT_ID put: anObject getHandle length: LGitId byteSize! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_final_signature
	"This method was automatically generated"
	^LGitSignature fromHandle: (handle pointerAt: OFFSET_PRIM_FINAL_SIGNATURE)! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_lines_in_hunk: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_LINES_IN_HUNK put: anObject! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_orig_path: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_ORIG_PATH put: anObject getHandle.! !

!LGitBlameHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
originalCommitId
	^ self prim_orig_commit_id! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_final_signature: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_FINAL_SIGNATURE put: anObject getHandle.! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_orig_signature
	"This method was automatically generated"
	^LGitSignature fromHandle: (handle pointerAt: OFFSET_PRIM_ORIG_SIGNATURE)! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_final_start_line_number
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_FINAL_START_LINE_NUMBER! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_orig_signature: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_ORIG_SIGNATURE put: anObject getHandle.! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_orig_commit_id
	"This method was automatically generated"
	^ LGitId fromHandle: (handle referenceStructAt: OFFSET_PRIM_ORIG_COMMIT_ID length: LGitId byteSize) asExternalAddress! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_final_start_line_number: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_FINAL_START_LINE_NUMBER put: anObject! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_orig_start_line_number: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_ORIG_START_LINE_NUMBER put: anObject! !

!LGitBlameHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
finalSignature	
	^ self prim_final_signature! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_boundary
	"This method was automatically generated"
	^handle booleanAt: OFFSET_PRIM_BOUNDARY! !

!LGitBlameHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
boundary
	^ self prim_boundary! !

!LGitBlameHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
originalStartLineNumber
	^ self prim_orig_start_line_number! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_final_commit_id: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_FINAL_COMMIT_ID put: anObject getHandle length: LGitId byteSize! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_lines_in_hunk
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_LINES_IN_HUNK! !

!LGitBlameHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
originalSignature	
	^ self prim_orig_signature! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_boundary: anObject
	"This method was automatically generated"
	handle booleanAt: OFFSET_PRIM_BOUNDARY put: anObject! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_final_commit_id
	"This method was automatically generated"
	^ LGitId fromHandle: (handle referenceStructAt: OFFSET_PRIM_FINAL_COMMIT_ID length: LGitId byteSize) asExternalAddress! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_orig_start_line_number
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_ORIG_START_LINE_NUMBER! !

!LGitBlameHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_orig_path
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_ORIG_PATH) type: ExternalType char asPointerType! !

!LGitBlameHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
numberOfLines
	^ self prim_lines_in_hunk! !

!LGitBlameHunk class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
		size_t lines_in_hunk "is the number of lines in this hunk"
		LGitId final_commit_id "is the OID of the commit where this line was last changed."
		size_t final_start_line_number "is the 1-based line number where this hunk begins, in the final version of the file"
		LGitSignature * final_signature
		LGitId orig_commit_id "is the OID of the commit where this hunk was found. This will usually be the same as final_commit_id, except when GIT_BLAME_TRACK_COPIES_ANY_COMMIT_COPIES has been specified."
		String orig_path "is the path to the file where this hunk originated, as of the commit specified by orig_commit_id."
		size_t orig_start_line_number "is the 1-based line number where this hunk begins in the file named by orig_path in the commit specified by orig_commit_id."
		LGitSignature * orig_signature
		Boolean boundary "is 1 iff the hunk has been tracked to a boundary commit (the root, or the commit specified in git_blame_options.oldest_commit)"
	)! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_max_line: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_MAX_LINE put: anObject! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_oldest_commit
	"This method was automatically generated"
	^ LGitId fromHandle: (handle referenceStructAt: OFFSET_PRIM_OLDEST_COMMIT length: LGitId byteSize)! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_min_match_characters
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PRIM_MIN_MATCH_CHARACTERS! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_newest_commit: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_NEWEST_COMMIT put: anObject getHandle length: LGitId byteSize! !

!LGitBlameOptions methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self withReturnHandlerDo: [
		self
			blame_init_options: self
			version: LGitOptionsVersionsEnum git_blame_options_version_1 ]! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_oldest_commit: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_OLDEST_COMMIT put: anObject getHandle length: LGitId byteSize! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_newest_commit
	"This method was automatically generated"
	^ LGitId fromHandle: (handle referenceStructAt: OFFSET_PRIM_NEWEST_COMMIT length: LGitId byteSize)! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_FLAGS put: anObject! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_max_line
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_MAX_LINE! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_FLAGS! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_min_line
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_MIN_LINE! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_min_line: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_MIN_LINE put: anObject! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_min_match_characters: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PRIM_MIN_MATCH_CHARACTERS put: anObject! !

!LGitBlameOptions methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blame_init_options: opts version: version
	^ self
		ffiCall: #(int git_blame_init_options(LGitBlameOptions * self, LGitOptionsVersionsEnum version))
		options: #( )! !

!LGitBlameOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitBlameOptions class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
		LGitOptionsVersionsEnum version
		uint32 flags "is a combination of the git_blame_flag_t values above."
		uint16 min_match_characters "is the lower bound on the number of alphanumeric characters that must be detected as moving/copying within a file for it to associate those lines with the parent commit. The default value is 20. This value only takes effect if any of the GIT_BLAME_TRACK_COPIES_* flags are specified."
		LGitId newest_commit "is the id of the newest commit to consider. The default is HEAD."
		LGitId oldest_commit "is the id of the oldest commit to consider. The default is the first commit encountered with a NULL parent."
		size_t min_line "is the first line in the file to blame. The default is 1 (line numbers start with 1)."
		size_t max_line "is the last line in the file to blame. The default is the last line of the file."
	)! !

!LGitBlob commentStamp: 'TorstenBergmann 6/2/2021 22:00'!
A git blob can be related to files and other associated content inside the directory!
!LGitBlob methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
get_id_data

	^ self blob_id: self! !

!LGitBlob methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
= anObject

	^ self == anObject or: [
		self class == anObject class and: [
			self isReady and: [
				anObject isReady and: [
					self id = anObject id ] ] ] ]! !

!LGitBlob methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
names

	| names |
	names := OrderedCollection new.
	self repository head object tree allEntriesDo: [ :rootPath :entry :payload |
		entry repository: self repository.
		entry object = self ifTrue: [ names add: entry filename ].
		0 ].
	
	^ names! !

!LGitBlob methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blob_rawcontent: blob
	
	^ self ffiCallSafely: #(void * git_blob_rawcontent #(self)) options: #()! !

!LGitBlob methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blob_rawsize: blob
	
	^ self ffiCallSafely: #(int64 git_blob_rawsize #(self)) options: #()! !

!LGitBlob methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
hash

	^ self contents hash! !

!LGitBlob methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blob_id: blob
	
	^ self ffiCallSafely: #(void * git_blob_id #(self)) options: #()! !

!LGitBlob methodsFor: 'private - accessing' stamp: ' 1/5/2022 21:01:26'!
binaryContents

	| bytes |
	"freeing not required. See #rawBuffer"
	bytes := ByteArray new: self rawSize.
	LibC memCopy: self rawBuffer to: bytes size: bytes size.
	^ bytes! !

!LGitBlob methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isBinary

	^ self blob_is_binary: self! !

!LGitBlob methodsFor: 'private - accessing' stamp: ' 1/5/2022 21:01:26'!
rawSize

	^ self blob_rawsize: self! !

!LGitBlob methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blob_lookup: blob repo: repo id: objectId
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_blob_lookup #(LGitBlob * blob , LGitRepository repo , LGitId * objectId))
		options: #()! !

!LGitBlob methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blob_is_binary: blob
	
	^ self ffiCallSafely: #(Boolean git_blob_is_binary #(self)) options: #()! !

!LGitBlob methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
contents

	^ self isBinary
		ifTrue:  [ self binaryContents ]
		ifFalse: [ self rawBuffer readStringUTF8 ]! !

!LGitBlob methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
lookup

	self withReturnHandlerDo: [ self
		blob_lookup: self 
		repo: self repository
		id: self id ].
	self autoRelease! !

!LGitBlob methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream

	self id objectPrintOn: aStream! !

!LGitBlob methodsFor: 'private - accessing' stamp: ' 1/5/2022 21:01:26'!
rawBuffer
	"freeing not required (see http://libgit2.github.com/libgit2/#HEAD/group/blob/git_blob_rawcontent)"
	
	^ self blob_rawcontent: self! !

!LGitBlob methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isBlob

	^ true! !

!LGitBlob class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository fromExternalCollection: aCollection
	| id |
	self assert: (aCollection class = ByteArray or: [ aCollection class classSide canUnderstand: #asExternalTypeOn: ]).
	id := LGitId new.
	self
		blob_create_frombuffer: id
		repo: aRepository
		buffer: aCollection
		len: aCollection size.
	^ (self of: aRepository)
		initializeWithId: id;
		yourself! !

!LGitBlob class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blob_free: handle
	
	^ self
		ffiCallSafely: 	#(void git_blob_free(void *handle))
		options: #()! !

!LGitBlob class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blob_create_frombuffer: objectId repo: repo buffer: buffer len: len
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_blob_create_frombuffer #(LGitId * objectId , LGitRepository repo , void  *buffer , size_t len))
		options: #()! !

!LGitBlob class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository fromString: aString
	^ self of: aRepository fromExternalCollection: aString! !

!LGitBlob class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isType: aType
	^ aType = LGitObjectTypeEnum git_obj_blob! !

!LGitBlob class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
blob_create_fromdisk: objectId repo: repo path: path
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_blob_create_fromdisk #(LGitId * objectId , LGitRepository repo , FFIExternalString path))
		options: #()! !

!LGitBlob class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #blob_free:! !

!LGitBlob class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository fromFile: aFileReference
	| id |
	id := LGitId new.
	self blob_create_fromdisk: id repo: aRepository path: aFileReference fullName.
	^ (self of: aRepository)
		initializeWithId: id;
		yourself! !

!LGitBlob class methodsFor: 'accessing - defaults' stamp: ' 1/5/2022 21:01:26'!
defaultFilemode
	^ LGitFilemodeEnum git_filemode_blob! !

!LGitBranchIterator commentStamp: 'TorstenBergmann 6/2/2021 22:15'!
Iterator type for branches

See [https://libgit2.org/libgit2/#HEAD/type/git_branch_iterator](https://libgit2.org/libgit2/#HEAD/type/git_branch_iterator)!
!LGitBranchIterator methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
branch_iterator_new: out repo: repo list_flags: list_flags
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_branch_iterator_new #(LGitBranchIterator * self , LGitRepository repo , LGitBranchTypeEnum list_flags))
		options: #()! !

!LGitBranchIterator methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
branchesDo: aBlock
	| returnCode branchType reference finishedCode isLocal |
	
	returnCode := LGitReturnCodeEnum git_ok.
	finishedCode := LGitReturnCodeEnum git_iterover.
	branchType := LGitWriteBackValueUInt new.
	
	[ 
		reference := LGitReference of: self repository.
		returnCode := self branch_next: reference out_type: branchType.
		isLocal := branchType value = LGitBranchTypeEnum git_branch_local value.
		returnCode = finishedCode 
	] 
	whileFalse: [ aBlock cull: reference cull: isLocal ]! !

!LGitBranchIterator methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
branch_next: out out_type: out_type
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_branch_next #(
				LGitReference * out ,
				LGitWriteBackValueUInt * out_type,
				LGitBranchIterator self))
		options: #()! !

!LGitBranchIterator methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
iterate: aLGitBranchTypeEnum
	self repository signalIfNotReady.
	self withReturnHandlerDo: [
		self
			branch_iterator_new: self
			repo: self repository
			list_flags: aLGitBranchTypeEnum ]! !

!LGitBranchIterator class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
remoteBranchesOf: repository do: aBlock
	self 
		of: repository 
		branchType: LGitBranchTypeEnum git_branch_remote
		do: aBlock! !

!LGitBranchIterator class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository branchType: aLGitBranchTypeEnum do: aBlock
	^ (self of: aRepository)
		iterate: aLGitBranchTypeEnum;
		branchesDo: aBlock! !

!LGitBranchIterator class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
localBranchesOf: repository do: aBlock
	self 
		of: repository 
		branchType: LGitBranchTypeEnum git_branch_local
		do: aBlock! !

!LGitBranchIterator class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #branch_iterator_free:! !

!LGitBranchIterator class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
allBranchesOf: repository do: aBlock

	self 
		of: repository 
		branchType: LGitBranchTypeEnum git_branch_all
		do: aBlock! !

!LGitBranchIterator class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
branch_iterator_free: handle
	
	^ self
		ffiCallSafely: #(void git_branch_iterator_free #(void *handle))
		options: #()! !

!LGitBranchTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_branch_all
	^ self basicNew
		value: 3;
		yourself! !

!LGitBranchTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_branch_remote
	^ self basicNew
		value: 2;
		yourself! !

!LGitBranchTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_BRANCH_LOCAL 1
	GIT_BRANCH_REMOTE 2
	GIT_BRANCH_ALL 3
)! !

!LGitBranchTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_branch_local
	^ self basicNew
		value: 1;
		yourself! !

!LGitBuf methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
free
	"Free the memory referred to by the git_buf.

	Note that this does not free the git_buf itself, just the memory pointed to by buffer->ptr. This 	will not free the memory if it looks like it was not allocated internally, but it will clear the 	buffer back to the empty state."

	self class signature_free: handle! !

!LGitBuf methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_ptr
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_PTR) type: ExternalType char asPointerType! !

!LGitBuf methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_size
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_SIZE! !

!LGitBuf methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_asize
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_ASIZE! !

!LGitBuf methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_ptr: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_PTR put: anObject getHandle.! !

!LGitBuf methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_size: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_SIZE put: anObject! !

!LGitBuf methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_asize: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_ASIZE put: anObject! !

!LGitBuf class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
signature_free: handle 
	^ self
		ffiCallSafely: #(void git_buf_free(void *handle))
		options: #(  )! !

!LGitBuf class methodsFor: 'field definition' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
		char * ptr;
		size_t asize;
		size_t size;
	)
	
	"self rebuildFieldAccessors"! !

!LGitBufferSignatureCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (void **out, LGitDiffFile *file, char *buf, size_t buflen, void *payload))! !

!LGitCallError commentStamp: 'TorstenBergmann 6/2/2021 20:41'!
A callout error for git!
!LGitCallError class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isAbstract

	^ self == LGitCallError! !

!LGitCallReturnHandler commentStamp: 'TorstenBergmann 6/2/2021 20:13'!
Callback handler for LibGit error codes!
!LGitCallReturnHandler class methodsFor: 'lookup' stamp: ' 1/5/2022 21:01:26'!
for: aReturnCode

	^ (self allSubclasses reject: #isAbstract)
		  detect: [ :class | class canHandle: aReturnCode ]
		  ifNone: [ LGitNoReturnCodeHandlerDefined signal ]! !

!LGitCallReturnHandler class methodsFor: 'signalling' stamp: ' 1/5/2022 21:01:26'!
signalWith: anError

	^ self new
		  messageText: anError message;
		  object: anError type;
		  signal! !

!LGitCallReturnHandler class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
handledReturnCodes

	^ { (self name allButFirst: 5) asLowercase asSymbol }! !

!LGitCallReturnHandler class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isAbstract

	^ self == LGitCallReturnHandler! !

!LGitCallReturnHandler class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isError

	^ true! !

!LGitCallReturnHandler class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
canHandle: aReturnCode

	^ self handledReturnCodes anySatisfy: [ :symbol | 
		  aReturnCode symbol = symbol ]! !

!LGitCallback commentStamp: 'TorstenBergmann 6/2/2021 22:34'!
Common superclass for libgit callback functions!
!LGitCallback methodsFor: 'instance initialization' stamp: ' 1/5/2022 21:01:26'!
initializeNull

	self 
		signature: self class fnSpec 
		block: [].
	self beNull! !

!LGitCallback class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
null
	^ self new initializeNull! !

!LGitCallback class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
on: aBlock
	^ self 
		signature: self fnSpec 
		block: aBlock! !

!LGitCallout commentStamp: 'TorstenBergmann 6/2/2021 22:05'!
A callout object for git!
!LGitCheckoutNotifyCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (LGitCheckoutNotifyTypeEnum why, String path, LGitDiffFile *baseline, LGitDiffFile *target, LGitDiffFile *workdir, void *payload))! !

!LGitCheckoutNotifyTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_notify_conflict
	^ self basicNew
		value: 1;
		yourself! !

!LGitCheckoutNotifyTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_notify_dirty
	^ self basicNew
		value: 2;
		yourself! !

!LGitCheckoutNotifyTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_notify_none
	^ self basicNew
		value: 0;
		yourself! !

!LGitCheckoutNotifyTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_notify_all
	^ self basicNew
		value: 65535;
		yourself! !

!LGitCheckoutNotifyTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_CHECKOUT_NOTIFY_NONE 0
	GIT_CHECKOUT_NOTIFY_CONFLICT 1
	GIT_CHECKOUT_NOTIFY_DIRTY 2
	GIT_CHECKOUT_NOTIFY_UPDATED 4
	GIT_CHECKOUT_NOTIFY_UNTRACKED 8
	GIT_CHECKOUT_NOTIFY_IGNORED 16
	GIT_CHECKOUT_NOTIFY_ALL 65535
)! !

!LGitCheckoutNotifyTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_notify_ignored
	^ self basicNew
		value: 16;
		yourself! !

!LGitCheckoutNotifyTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_notify_updated
	^ self basicNew
		value: 4;
		yourself! !

!LGitCheckoutNotifyTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_notify_untracked
	^ self basicNew
		value: 8;
		yourself! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_target_directory
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_TARGET_DIRECTORY) type: ExternalType char asPointerType! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_target_directory: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_TARGET_DIRECTORY put: anObject getHandle.! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_their_label
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_THEIR_LABEL) type: ExternalType char asPointerType! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_notify_cb
	"This method was automatically generated"
	^LGitCheckoutNotifyCallback forAddress: ((handle pointerAt: OFFSET_PRIM_NOTIFY_CB) asInteger)! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_notify_flags
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_NOTIFY_FLAGS! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_perfdata_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_PERFDATA_PAYLOAD put: anObject getHandle.! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_file_mode
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_FILE_MODE! !

!LGitCheckoutOptions methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self withReturnHandlerDo: [
		self
			checkout_init_options: self
			version: LGitOptionsVersionsEnum git_checkout_options_version_1 ]! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_ancestor_label
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_ANCESTOR_LABEL) type: ExternalType char asPointerType! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_paths: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_PATHS put: anObject getHandle length: LGitStringArray byteSize! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_file_mode: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_FILE_MODE put: anObject! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_baseline: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_BASELINE put: anObject getHandle.! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_dir_mode
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_DIR_MODE! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_progress_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_PROGRESS_PAYLOAD put: anObject getHandle.! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_baseline_index: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_BASELINE_INDEX put: anObject getHandle.! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_dir_mode: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_DIR_MODE put: anObject! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_notify_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_NOTIFY_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_ancestor_label: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_ANCESTOR_LABEL put: anObject getHandle.! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_strategy: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_CHECKOUT_STRATEGY put: anObject! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_disable_filters: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_DISABLE_FILTERS put: anObject! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_our_label
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_OUR_LABEL) type: ExternalType char asPointerType! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_progress_cb
	"This method was automatically generated"
	^LGitCheckoutProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PROGRESS_CB) asInteger)! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_progress_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_PROGRESS_PAYLOAD) type: ExternalType void asPointerType! !

!LGitCheckoutOptions methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
checkout_init_options: opts version: version 
	^ self
		ffiCall: #(int git_checkout_init_options(LGitCheckoutOptions * self, LGitOptionsVersionsEnum version))
		options: #(  )! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_baseline_index
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_BASELINE_INDEX) type: ExternalType void asPointerType! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_their_label: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_THEIR_LABEL put: anObject getHandle.! !

!LGitCheckoutOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
progressCallback: anIceGitCheckoutProgress 

	progressCallback := anIceGitCheckoutProgress.
	self prim_progress_cb: anIceGitCheckoutProgress! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_disable_filters
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_DISABLE_FILTERS! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_perfdata_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PERFDATA_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_perfdata_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_PERFDATA_PAYLOAD) type: ExternalType void asPointerType! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_paths
	"This method was automatically generated"
	^ LGitStringArray fromHandle: (handle referenceStructAt: OFFSET_PRIM_PATHS length: LGitStringArray byteSize)! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_file_open_flags: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_FILE_OPEN_FLAGS put: anObject! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_notify_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_NOTIFY_PAYLOAD put: anObject getHandle.! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_strategy
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_CHECKOUT_STRATEGY! !

!LGitCheckoutOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
checkoutStrategy: aCheckoutStrategyEnum
	self prim_checkout_strategy: aCheckoutStrategyEnum value! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_perfdata_cb
	"This method was automatically generated"
	^LGitCheckoutPerfDataCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PERFDATA_CB) asInteger)! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_our_label: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_OUR_LABEL put: anObject getHandle.! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_notify_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_NOTIFY_PAYLOAD) type: ExternalType void asPointerType! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_progress_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PROGRESS_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_notify_flags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_NOTIFY_FLAGS put: anObject! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_baseline
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_BASELINE) type: ExternalType void asPointerType! !

!LGitCheckoutOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_file_open_flags
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_FILE_OPEN_FLAGS! !

!LGitCheckoutOptions class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		LGitOptionsVersionsEnum version;

		uint checkout_strategy; "< default will be a dry run "

		int disable_filters;    "< don't apply filters like CRLF conversion "
		uint dir_mode;  "< default is 0755 "
		uint file_mode; "< default is 0644 or 0755 as dictated by blob "
		int file_open_flags;    "< default is O_CREAT | O_TRUNC | O_WRONLY "

		uint notify_flags; "< see `git_checkout_notify_t` above "
		LGitCheckoutNotifyCallback notify_cb;
		void *notify_payload;

		" Optional callback to notify the consumer of checkout progress. "
		LGitCheckoutProgressCallback progress_cb;
		void *progress_payload;

		" When not zeroed out, array of fnmatch patterns specifying which
		 *  paths should be taken into account, otherwise all files.  Use
		 *  GIT_CHECKOUT_DISABLE_PATHSPEC_MATCH to treat as simple list.
		 "
		LGitStringArray paths;

		" The expected content of the working directory; defaults to HEAD.
		 *  If the working directory does not match this baseline information,
		 *  that will produce a checkout conflict.
		 "
		LGitTree *baseline;

		" Like `baseline` above, though expressed as an index.  This
		 *  option overrides `baseline`.
		 "
		LGitIndex *baseline_index; "< expected content of workdir, expressed as an index. "

		String target_directory; "< alternative checkout path to workdir "

		String ancestor_label; "< the name of the common ancestor side of conflicts "
		String our_label; "< the name of the *our* side of conflicts "
		String their_label; "< the name of the *their* side of conflicts "

		" Optional callback to notify the consumer of performance data. "
		LGitCheckoutPerfDataCallback perfdata_cb;
		void *perfdata_payload;
	)! !

!LGitCheckoutPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_mkdir_calls: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_MKDIR_CALLS put: anObject! !

!LGitCheckoutPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_stat_calls
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_STAT_CALLS! !

!LGitCheckoutPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_stat_calls: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_STAT_CALLS put: anObject! !

!LGitCheckoutPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_chmod_calls
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_CHMOD_CALLS! !

!LGitCheckoutPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_mkdir_calls
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_MKDIR_CALLS! !

!LGitCheckoutPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_chmod_calls: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_CHMOD_CALLS put: anObject! !

!LGitCheckoutPerfData class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
		size_t mkdir_calls;
		size_t stat_calls;
		size_t chmod_calls;
	)! !

!LGitCheckoutPerfDataCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(void (LGitCheckoutPerfData *perfdata, void *payload))! !

!LGitCheckoutProgressCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(void (String* path, size_t completed_steps, size_t total_steps, void* payload))! !

!LGitCheckoutStrategyEnum commentStamp: 'MaxLeske 8/13/2015 11:06'!
/**
 * Checkout behavior flags
 *
 * In libgit2, checkout is used to update the working directory and index
 * to match a target tree.  Unlike git checkout, it does not move the HEAD
 * commit for you - use `git_repository_set_head` or the like to do that.
 *
 * Checkout looks at (up to) four things: the "target" tree you want to
 * check out, the "baseline" tree of what was checked out previously, the
 * working directory for actual files, and the index for staged changes.
 *
 * You give checkout one of three strategies for update:
 *
 * - `GIT_CHECKOUT_NONE` is a dry-run strategy that checks for conflicts,
 *   etc., but doesn't make any actual changes.
 *
 * - `GIT_CHECKOUT_FORCE` is at the opposite extreme, taking any action to
 *   make the working directory match the target (including potentially
 *   discarding modified files).
 *
 * - `GIT_CHECKOUT_SAFE` is between these two options, it will only make
 *   modifications that will not lose changes.
 *
 *                         |  target == baseline   |  target !!= baseline  |
 *    ---------------------|-----------------------|----------------------|
 *     workdir == baseline |       no action       |  create, update, or  |
 *                         |                       |     delete file      |
 *    ---------------------|-----------------------|----------------------|
 *     workdir exists and  |       no action       |   conflict (notify   |
 *       is !!= baseline    | notify dirty MODIFIED | and cancel checkout) |
 *    ---------------------|-----------------------|----------------------|
 *      workdir missing,   | notify dirty DELETED  |     create file      |
 *      baseline present   |                       |                      |
 *    ---------------------|-----------------------|----------------------|
 *
 * To emulate `git checkout`, use `GIT_CHECKOUT_SAFE` with a checkout
 * notification callback (see below) that displays information about dirty
 * files.  The default behavior will cancel checkout on conflicts.
 *
 * To emulate `git checkout-index`, use `GIT_CHECKOUT_SAFE` with a
 * notification callback that cancels the operation if a dirty-but-existing
 * file is found in the working directory.  This core git command isn't
 * quite "force" but is sensitive about some types of changes.
 *
 * To emulate `git checkout -f`, use `GIT_CHECKOUT_FORCE`.
 *
 *
 * There are some additional flags to modified the behavior of checkout:
 *
 * - GIT_CHECKOUT_ALLOW_CONFLICTS makes SAFE mode apply safe file updates
 *   even if there are conflicts (instead of cancelling the checkout).
 *
 * - GIT_CHECKOUT_REMOVE_UNTRACKED means remove untracked files (i.e. not
 *   in target, baseline, or index, and not ignored) from the working dir.
 *
 * - GIT_CHECKOUT_REMOVE_IGNORED means remove ignored files (that are also
 *   untracked) from the working directory as well.
 *
 * - GIT_CHECKOUT_UPDATE_ONLY means to only update the content of files that
 *   already exist.  Files will not be created nor deleted.  This just skips
 *   applying adds, deletes, and typechanges.
 *
 * - GIT_CHECKOUT_DONT_UPDATE_INDEX prevents checkout from writing the
 *   updated files' information to the index.
 *
 * - Normally, checkout will reload the index and git attributes from disk
 *   before any operations.  GIT_CHECKOUT_NO_REFRESH prevents this reload.
 *
 * - Unmerged index entries are conflicts.  GIT_CHECKOUT_SKIP_UNMERGED skips
 *   files with unmerged index entries instead.  GIT_CHECKOUT_USE_OURS and
 *   GIT_CHECKOUT_USE_THEIRS to proceed with the checkout using either the
 *   stage 2 ("ours") or stage 3 ("theirs") version of files in the index.
 *
 * - GIT_CHECKOUT_DONT_OVERWRITE_IGNORED prevents ignored files from being
 *   overwritten.  Normally, files that are ignored in the working directory
 *   are not considered "precious" and may be overwritten if the checkout
 *   target contains that file.
 *
 * - GIT_CHECKOUT_DONT_REMOVE_EXISTING prevents checkout from removing
 *   files or folders that fold to the same name on case insensitive
 *   filesystems.  This can cause files to retain their existing names
 *   and write through existing symbolic links.
 */!
!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_none
	^ self basicNew
		value: 0;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_dont_remove_existing
	^ self basicNew
		value: 4194304;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_dont_update_index
	^ self basicNew
		value: 256;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_remove_ignored
	^ self basicNew
		value: 64;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_dont_write_index
	^ self basicNew
		value: 8388608;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_skip_unmerged
	^ self basicNew
		value: 1024;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_update_submodules
	^ self basicNew
		value: 65536;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_force
	^ self basicNew
		value: 2;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_conflict_style_merge
	^ self basicNew
		value: 1048576;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_use_theirs
	^ self basicNew
		value: 4096;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_conflict_style_diff3
	^ self basicNew
		value: 2097152;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_dont_overwrite_ignored
	^ self basicNew
		value: 524288;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_disable_pathspec_match
	^ self basicNew
		value: 8192;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'enum description' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^ #(
		GIT_CHECKOUT_NONE  0 "< default is a dry run, no actual updates "

		" Allow safe updates that cannot overwrite uncommitted data "
		GIT_CHECKOUT_SAFE  "1 bitShift: 0" 1

		" Allow all updates to force working directory to look like index "
		GIT_CHECKOUT_FORCE  "1 bitShift: 1" 2


		" Allow checkout to recreate missing files "
		GIT_CHECKOUT_RECREATE_MISSING  "1 bitShift: 2" 4

		" Allow checkout to make safe updates even if conflicts are found "
		GIT_CHECKOUT_ALLOW_CONFLICTS  "1 bitShift: 4" 16

		" Remove untracked files not in index (that are not ignored) "
		GIT_CHECKOUT_REMOVE_UNTRACKED  "1 bitShift: 5" 32

		" Remove ignored files not in index "
		GIT_CHECKOUT_REMOVE_IGNORED  "1 bitShift: 6" 64

		" Only update existing files, don't create new ones "
		GIT_CHECKOUT_UPDATE_ONLY  "1 bitShift: 7" 128

		"
		 * Normally checkout updates index entries as it goes; this stops that.
		 * Implies `GIT_CHECKOUT_DONT_WRITE_INDEX`.
		 "
		GIT_CHECKOUT_DONT_UPDATE_INDEX  "1 bitShift: 8" 256

		" Don't refresh index/config/etc before doing checkout "
		GIT_CHECKOUT_NO_REFRESH  "1 bitShift: 9" 512

		" Allow checkout to skip unmerged files "
		GIT_CHECKOUT_SKIP_UNMERGED  "1 bitShift: 10" 1024
		" For unmerged files, checkout stage 2 from index "
		GIT_CHECKOUT_USE_OURS  "1 bitShift: 11" 2048
		" For unmerged files, checkout stage 3 from index "
		GIT_CHECKOUT_USE_THEIRS  "1 bitShift: 12" 4096

		" Treat pathspec as simple list of exact match file paths "
		GIT_CHECKOUT_DISABLE_PATHSPEC_MATCH  "1 bitShift: 13" 8192

		" Ignore directories in use, they will be left empty "
		GIT_CHECKOUT_SKIP_LOCKED_DIRECTORIES  "1 bitShift: 18" 262144

		" Don't overwrite ignored files that exist in the checkout target "
		GIT_CHECKOUT_DONT_OVERWRITE_IGNORED  "1 bitShift: 19" 524288

		" Write normal merge files for conflicts "
		GIT_CHECKOUT_CONFLICT_STYLE_MERGE  "1 bitShift: 20" 1048576

		" Include common ancestor data in diff3 format files for conflicts "
		GIT_CHECKOUT_CONFLICT_STYLE_DIFF3  "1 bitShift: 21" 2097152

		" Don't overwrite existing files or folders "
		GIT_CHECKOUT_DONT_REMOVE_EXISTING  "1 bitShift: 22" 4194304

		" Normally checkout writes the index upon completion; this prevents that. "
		GIT_CHECKOUT_DONT_WRITE_INDEX  "1 bitShift: 23" 8388608

		"
		 * THE FOLLOWING OPTIONS ARE NOT YET IMPLEMENTED
		 "

		" Recursively checkout submodules with same options (NOT IMPLEMENTED) "
		GIT_CHECKOUT_UPDATE_SUBMODULES  "1 bitShift: 16" 65536
		" Recursively checkout submodules if HEAD moved in super repo (NOT IMPLEMENTED) "
		GIT_CHECKOUT_UPDATE_SUBMODULES_IF_CHANGED  "1 bitShift: 17" 131072
)! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_remove_untracked
	^ self basicNew
		value: 32;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_safe_create
	^ self basicNew
		value: 2;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_update_only
	^ self basicNew
		value: 128;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_allow_conflicts
	^ self basicNew
		value: 16;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_update_submodules_if_changed
	^ self basicNew
		value: 131072;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_safe
	^ self basicNew
		value: 1;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_no_refresh
	^ self basicNew
		value: 512;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_use_ours
	^ self basicNew
		value: 2048;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_recreate_missing
	^ self basicNew
		value: 4;
		yourself! !

!LGitCheckoutStrategyEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_skip_locked_directories
	^ self basicNew
		value: 262144;
		yourself! !

!LGitCloneLocalTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_clone_local_auto
	^ self basicNew
		value: 0;
		yourself! !

!LGitCloneLocalTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_clone_no_local
	^ self basicNew
		value: 2;
		yourself! !

!LGitCloneLocalTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^ #(
			GIT_CLONE_LOCAL_AUTO 0
			GIT_CLONE_LOCAL 1
			GIT_CLONE_NO_LOCAL 2
			GIT_CLONE_LOCAL_NO_LINKS 3
		)! !

!LGitCloneLocalTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_clone_local
	^ self basicNew
		value: 1;
		yourself! !

!LGitCloneLocalTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_clone_local_no_links
	^ self basicNew
		value: 3;
		yourself! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_local
	"This method was automatically generated"
	^LGitCloneLocalTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_LOCAL)! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_fetch_opts
	"This method was automatically generated"
	^ LGitFetchOptionsV02x fromHandle: (handle referenceStructAt: OFFSET_PRIM_FETCH_OPTS length: LGitFetchOptionsV02x byteSize)! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_REMOTE_CB_PAYLOAD put: anObject getHandle.! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_bare
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_BARE! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_branch: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_CHECKOUT_BRANCH put: anObject getHandle.! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CHECKOUT_OPTS put: anObject getHandle length: LGitCheckoutOptions byteSize! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_local: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_LOCAL put: anObject value! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_branch
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_CHECKOUT_BRANCH) type: ExternalType char asPointerType! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb
	"This method was automatically generated"
	^LGitRemoteCreateCallback forAddress: ((handle pointerAt: OFFSET_PRIM_REMOTE_CB) asInteger)! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_REPOSITORY_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_fetch_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_FETCH_OPTS put: anObject getHandle length: LGitFetchOptionsV02x byteSize! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_bare: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_BARE put: anObject! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_REPOSITORY_CB_PAYLOAD put: anObject getHandle.! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_REMOTE_CB_PAYLOAD) type: ExternalType void asPointerType! !

!LGitCloneOptionsV02x methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
clone_init_options: opts version: version 
	^ self
		ffiCall: #(LGitReturnCodeEnum git_clone_init_options(LGitCloneOptionsV02x *opts, LGitOptionsVersionsEnum version))
		options: #(  )! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_REPOSITORY_CB_PAYLOAD) type: ExternalType void asPointerType! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_REMOTE_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb
	"This method was automatically generated"
	^LGitRepositoryCreateCallback forAddress: ((handle pointerAt: OFFSET_PRIM_REPOSITORY_CB) asInteger)! !

!LGitCloneOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_opts
	"This method was automatically generated"
	^ LGitCheckoutOptions fromHandle: (handle referenceStructAt: OFFSET_PRIM_CHECKOUT_OPTS length: LGitCheckoutOptions byteSize)! !

!LGitCloneOptionsV02x class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		LGitOptionsVersionsEnum version;
		
		"
		 * These options are passed to the checkout step. To disable
		 * checkout, set the `checkout_strategy` to
		 * `GIT_CHECKOUT_NONE`.
		 "
		LGitCheckoutOptions checkout_opts;

		"
		 * Options which control the fetch, including callbacks.
		 *
		 * The callbacks are used for reporting fetch progress, and for acquiring
		 * credentials in the event they are needed.
		 "
		#LGitFetchOptionsV02x fetch_opts;

		"
		 * Set to zero (false) to create a standard repo, or non-zero
		 * for a bare repo
		 "
		int bare;

		"
		 * Whether to use a fetch or copy the object database.
		 "
		LGitCloneLocalTypeEnum local;

		"
		 * The name of the branch to checkout. NULL means use the
		 * remote's default branch.
		 "
		String checkout_branch;

		"
		 * A callback used to create the new repository into which to
		 * clone. If NULL, the 'bare' field will be used to determine
		 * whether to create a bare repository.
		 "
		LGitRepositoryCreateCallback repository_cb;

		"
		 * An opaque payload to pass to the git_repository creation callback.
		 * This parameter is ignored unless repository_cb is non-NULL.
		 "
		void *repository_cb_payload;

		"
		 * A callback used to create the git_remote, prior to its being
		 * used to perform the clone operation. See the documentation for
		 * git_remote_create_cb for details. This parameter may be NULL,
		 * indicating that git_clone should provide default behavior.
		 "
		LGitRemoteCreateCallback remote_cb;

		"
		 * An opaque payload to pass to the git_remote creation callback.
		 * This parameter is ignored unless remote_cb is non-NULL.
		 "
		void *remote_cb_payload;
	)! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_local
	"This method was automatically generated"
	^LGitCloneLocalTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_LOCAL)! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_fetch_opts
	"This method was automatically generated"
	^ LGitFetchOptionsV100 fromHandle: (handle referenceStructAt: OFFSET_PRIM_FETCH_OPTS length: LGitFetchOptionsV100 byteSize)! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_REMOTE_CB_PAYLOAD put: anObject getHandle.! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_bare
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_BARE! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_branch: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_CHECKOUT_BRANCH put: anObject getHandle.! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CHECKOUT_OPTS put: anObject getHandle length: LGitCheckoutOptions byteSize! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_local: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_LOCAL put: anObject value! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_branch
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_CHECKOUT_BRANCH) type: ExternalType char asPointerType! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb
	"This method was automatically generated"
	^LGitRemoteCreateCallback forAddress: ((handle pointerAt: OFFSET_PRIM_REMOTE_CB) asInteger)! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_REPOSITORY_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_fetch_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_FETCH_OPTS put: anObject getHandle length: LGitFetchOptionsV100 byteSize! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_bare: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_BARE put: anObject! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_REPOSITORY_CB_PAYLOAD put: anObject getHandle.! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_REMOTE_CB_PAYLOAD) type: ExternalType void asPointerType! !

!LGitCloneOptionsV100 methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
clone_init_options: opts version: version 
	^ self
		ffiCall: #(LGitReturnCodeEnum git_clone_init_options(LGitCloneOptionsV100 *opts, LGitOptionsVersionsEnum version))
		options: #(  )! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_REPOSITORY_CB_PAYLOAD) type: ExternalType void asPointerType! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_REMOTE_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb
	"This method was automatically generated"
	^LGitRepositoryCreateCallback forAddress: ((handle pointerAt: OFFSET_PRIM_REPOSITORY_CB) asInteger)! !

!LGitCloneOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_opts
	"This method was automatically generated"
	^ LGitCheckoutOptions fromHandle: (handle referenceStructAt: OFFSET_PRIM_CHECKOUT_OPTS length: LGitCheckoutOptions byteSize)! !

!LGitCloneOptionsV100 class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		LGitOptionsVersionsEnum version;
		
		"
		 * These options are passed to the checkout step. To disable
		 * checkout, set the `checkout_strategy` to
		 * `GIT_CHECKOUT_NONE`.
		 "
		LGitCheckoutOptions checkout_opts;

		"
		 * Options which control the fetch, including callbacks.
		 *
		 * The callbacks are used for reporting fetch progress, and for acquiring
		 * credentials in the event they are needed.
		 "
		LGitFetchOptionsV100 fetch_opts;

		"
		 * Set to zero (false) to create a standard repo, or non-zero
		 * for a bare repo
		 "
		int bare;

		"
		 * Whether to use a fetch or copy the object database.
		 "
		LGitCloneLocalTypeEnum local;

		"
		 * The name of the branch to checkout. NULL means use the
		 * remote's default branch.
		 "
		String checkout_branch;

		"
		 * A callback used to create the new repository into which to
		 * clone. If NULL, the 'bare' field will be used to determine
		 * whether to create a bare repository.
		 "
		LGitRepositoryCreateCallback repository_cb;

		"
		 * An opaque payload to pass to the git_repository creation callback.
		 * This parameter is ignored unless repository_cb is non-NULL.
		 "
		void *repository_cb_payload;

		"
		 * A callback used to create the git_remote, prior to its being
		 * used to perform the clone operation. See the documentation for
		 * git_remote_create_cb for details. This parameter may be NULL,
		 * indicating that git_clone should provide default behavior.
		 "
		LGitRemoteCreateCallback remote_cb;

		"
		 * An opaque payload to pass to the git_remote creation callback.
		 * This parameter is ignored unless remote_cb is non-NULL.
		 "
		void *remote_cb_payload;
	)! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_local
	"This method was automatically generated"
	^LGitCloneLocalTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_LOCAL)! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_fetch_opts
	"This method was automatically generated"
	^ LGitFetchOptionsV120 fromHandle: (handle referenceStructAt: OFFSET_PRIM_FETCH_OPTS length: LGitFetchOptionsV120 byteSize)! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_REMOTE_CB_PAYLOAD put: anObject getHandle.! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_bare
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_BARE! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_branch: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_CHECKOUT_BRANCH put: anObject getHandle.! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CHECKOUT_OPTS put: anObject getHandle length: LGitCheckoutOptions byteSize! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_local: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_LOCAL put: anObject value! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_branch
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_CHECKOUT_BRANCH) type: ExternalType char asPointerType! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb
	"This method was automatically generated"
	^LGitRemoteCreateCallback forAddress: ((handle pointerAt: OFFSET_PRIM_REMOTE_CB) asInteger)! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_REPOSITORY_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_fetch_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_FETCH_OPTS put: anObject getHandle length: LGitFetchOptionsV120 byteSize! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_bare: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_BARE put: anObject! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_REPOSITORY_CB_PAYLOAD put: anObject getHandle.! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_REMOTE_CB_PAYLOAD) type: ExternalType void asPointerType! !

!LGitCloneOptionsV120 methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
clone_init_options: opts version: version 
	^ self
		ffiCall: #(LGitReturnCodeEnum git_clone_init_options(LGitCloneOptionsV120 *opts, LGitOptionsVersionsEnum version))
		options: #(  )! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_REPOSITORY_CB_PAYLOAD) type: ExternalType void asPointerType! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_REMOTE_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_repository_cb
	"This method was automatically generated"
	^LGitRepositoryCreateCallback forAddress: ((handle pointerAt: OFFSET_PRIM_REPOSITORY_CB) asInteger)! !

!LGitCloneOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_checkout_opts
	"This method was automatically generated"
	^ LGitCheckoutOptions fromHandle: (handle referenceStructAt: OFFSET_PRIM_CHECKOUT_OPTS length: LGitCheckoutOptions byteSize)! !

!LGitCloneOptionsV120 class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		LGitOptionsVersionsEnum version;
		
		"
		 * These options are passed to the checkout step. To disable
		 * checkout, set the `checkout_strategy` to
		 * `GIT_CHECKOUT_NONE`.
		 "
		LGitCheckoutOptions checkout_opts;

		"
		 * Options which control the fetch, including callbacks.
		 *
		 * The callbacks are used for reporting fetch progress, and for acquiring
		 * credentials in the event they are needed.
		 "
		LGitFetchOptionsV120 fetch_opts;

		"
		 * Set to zero (false) to create a standard repo, or non-zero
		 * for a bare repo
		 "
		int bare;

		"
		 * Whether to use a fetch or copy the object database.
		 "
		LGitCloneLocalTypeEnum local;

		"
		 * The name of the branch to checkout. NULL means use the
		 * remote's default branch.
		 "
		String checkout_branch;

		"
		 * A callback used to create the new repository into which to
		 * clone. If NULL, the 'bare' field will be used to determine
		 * whether to create a bare repository.
		 "
		LGitRepositoryCreateCallback repository_cb;

		"
		 * An opaque payload to pass to the git_repository creation callback.
		 * This parameter is ignored unless repository_cb is non-NULL.
		 "
		void *repository_cb_payload;

		"
		 * A callback used to create the git_remote, prior to its being
		 * used to perform the clone operation. See the documentation for
		 * git_remote_create_cb for details. This parameter may be NULL,
		 * indicating that git_clone should provide default behavior.
		 "
		LGitRemoteCreateCallback remote_cb;

		"
		 * An opaque payload to pass to the git_remote creation callback.
		 * This parameter is ignored unless remote_cb is non-NULL.
		 "
		void *remote_cb_payload;
	)! !

!LGitCommit commentStamp: 'NicoPasserini 11/3/2016 15:40'!
A LGitCommit represents a specific commit and the associate information.

Instance Variables
	handle:		NBExternalObject

handle
	- the handle to the external data object
!
!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_message: commit
	
	^ self ffiCallSafely: #(String git_commit_message #(self)) options: #()! !

!LGitCommit methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
= anObject

	^ self == anObject or: [ 
		self class == anObject class and: [
			self isReady and: [
				anObject isReady and: [
					self id = anObject id ] ] ] ]! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_author: commit
	
	^ self
		ffiCallSafely: #(LGitSignature * git_commit_author #(self))
		options: #()! !

!LGitCommit methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
get_id_data

	^ self commit_id: self! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
parents

	| parentCount |
	parentCount := self numberOfParents.
	^ Array
		new: parentCount
		streamContents: [ :stream | 
			1 to: parentCount do: [ :i | 
				stream nextPut: (self parentAt: i) ] ]! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_time: commit
	
	^ self ffiCallSafely: #(int64 git_commit_time #(self)) options: #()! !

!LGitCommit methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isDescendantOf: aCommit

	^ (self repo: self repository graph: self id descendant_of: aCommit id) == 1! !

!LGitCommit methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isCommit

	^ true! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
parentAt: index
	"Answer the parent at number index (1-based)."

	| parentOid |
	parentOid := LGitId
		fromHandle: (self commit_parent_id: self n: (index - 1)) getHandle.
	^ self class of: self repository fromId: parentOid! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
entryByPath: aString ifAbsent: aBlock

	^ self tree entryByPath: aString ifAbsent: aBlock! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
owner

	^ self 
		ffiCallSafely: #(void *git_commit_owner(self)) 
		options: #()! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_parentcount: commit
	
	^ self ffiCallSafely: #(uint git_commit_parentcount #(self)) options: #()! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_tree: tree_out commit: commit
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_commit_tree #(LGitTree *tree_out , self))
		options: #()! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_time_offset: commit
	
	^ self ffiCallSafely: #(int git_commit_time_offset #(self)) options: #()! !

!LGitCommit methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
lookup

	self withReturnHandlerDo: [ 
		self
			commit_lookup: self
			repo: self repository
			id: self id ].
	self autoRelease! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
authorStruct

	^ self commit_author: self! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
committer

	^ self commit_committer: self! !

!LGitCommit methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream

	self id hexString in: [ :hexId |
		aStream
			nextPutAll: (hexId first: 7);
			nextPutAll: '...';
			nextPutAll: (hexId last: 7);
			nextPutAll: ', ';
			nextPutAll: self message surroundedBySingleQuotes ]! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
merge_result: out commit: anotherCommit options: options

	^ self ffiCallSafely: #(
		LGitReturnCodeEnum git_merge_commits(
			LGitIndex *out, 
			LGitRepository repository, 
			LGitCommit self, 
			LGitCommit anotherCommit, 
			LGitMergeOptions *options))
		options: #()! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
committerStruct

	^ self commit_committer: self! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_message_encoding: commit
	
	^ self
		ffiCallSafely: #(String git_commit_message_encoding #(self))
		options: #()! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
author

	^ self commit_author: self! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_committer: commit
	
	^ self
		ffiCallSafely: #(LGitSignature * git_commit_committer #(self))
		options: #()! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
numberOfParents

	^ self commit_parentcount: self! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repo: repo graph: commit descendant_of: ancestor

	^ self 
		ffiCallSafely: #(int git_graph_descendant_of(LGitRepository repo, LGitId *commit, LGitId *ancestor))
		options: #()! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
time

	| time offset |
	time := self commit_time: self.
	offset := self commit_time_offset: self.
	^ LGitTime new
		time: time;
		offset: offset;
		yourself! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
entryByPath: aString

	^ self tree entryByPath: aString! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
tree

	| tree |
	tree := LGitTree of: self repository.
	self commit_tree: tree commit: self.
	^ tree! !

!LGitCommit methodsFor: '*Iceberg-Core' stamp: ''!
changesFileNamed: fileName
	| lookup myVersion parentVersions |
	lookup := [:commit | [ commit entryByPath: fileName ] on: Error do: [ nil ]].
	myVersion := lookup value: self.
	parentVersions := self parents collect: lookup.
	
	^ (myVersion 
		ifNil: [ parentVersions includes: nil ]
		ifNotNil: [ parentVersions anySatisfy: [ :version | 
				version notNil and: [ version objectId = myVersion objectId ]]]) not
! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
rawHeader

	^ self commit_raw_header: self! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
name
	
	^ id hexString! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_raw_header: aCommit

	^ self ffiCallSafely: #(const char * git_commit_raw_header(self))! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_parent_id: commit n: n
	<todo: 'using LGitId * as return type causes a crash'>
	
	^ self
		ffiCallSafely: #(void *git_commit_parent_id #(self , uint n))
		options: #()! !

!LGitCommit methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
hasParents
	^ self numberOfParents > 0! !

!LGitCommit methodsFor: '*Iceberg' stamp: ''!
asIcebergObjectInRepository: iceRepository
	^ iceRepository commitFromGitCommit: self! !

!LGitCommit methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isMerge

	^ self numberOfParents > 1! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_lookup: commit repo: repo id: objectId
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_commit_lookup #(LGitCommit * commit , LGitRepository repo , LGitId * objectId))
		options: #()! !

!LGitCommit methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
merge: anotherCommit

	"Merge two commits, producing a git_index that reflects the result of the merge."
	| index | 
	index := LGitIndex of: self repository.
	self withReturnHandlerDo: [ 
		self merge_result: index commit: anotherCommit options: LGitMergeOptions defaults.
	].

	"There is a bug on libgit2 and we need to set the owner of the index (because it is not
	setting it)"
	index hackOwner: self repository.
	
	^ index! !

!LGitCommit methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
message
	<todo: 'use encoding to properly read the message'>
	
	| encoding |
	encoding := self commit_message_encoding: self.
	^ self commit_message: self! !

!LGitCommit methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_id: commit
	
	^ self ffiCallSafely: #(void * git_commit_id #(self)) options: #()! !

!LGitCommit class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isType: aType

	^ aType = LGitObjectTypeEnum git_obj_commit! !

!LGitCommit class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector

	^ #commit_free:! !

!LGitCommit class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository fromHexString: aCommitId

	^ self of: aRepository fromId: (LGitId fromHexString: aCommitId)! !

!LGitCommit class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_free: handle
	
	^ self ffiCallSafely: #(void git_commit_free #(void *handle)) options: #()! !

!LGitCommitBuilder commentStamp: 'TorstenBergmann 6/2/2021 22:22'!
A commit builder for git!
!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
updateReference: aReference
	updateReference := aReference! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
commitId: anLGitId
	commitId := anLGitId! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
message: aString
	message := aString! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
parents
	^ parents ifNil: [ parents := #() ]! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
author
	^ author ifNil: [
		author := self repository defaultSignature ]! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
messageEncoding: aString
	messageEncoding := aString! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
tree
	<todo: 'use proper exceptions'>
	^ tree ifNil: [ self error: 'need an existing tree here' ]! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
writtenCommit
	<todo: 'use proper exceptions'>
	commitId ifNil: [ self error: 'haven''t written the commit yet!!' ].
	^ LGitCommit of: self repository fromId: self commitId! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
updateReference
	^ updateReference! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
author: anLGitSignature
	author := anLGitSignature! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
commitId
	^ commitId ifNil: [ commitId := LGitId new ]! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
messageEncoding
	^ messageEncoding ifNil: [ 'UTF-8' ]! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
committer: anLGitSignature
	committer := anLGitSignature! !

!LGitCommitBuilder methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
writeCommit
	| parentsPointer |
	self withReturnHandlerDo: [ 
		self assert: (self parents allSatisfy: #isReady).
		parentsPointer := self parents
			ifNotEmpty: [ (LGitExternalCommitArray fromCollection: self parents) getHandle ]
			ifEmpty: [ ExternalAddress null ].
	self withReturnHandlerDo: [ 
		self
			commit_create: self commitId
			"libgit2 asserts the identity of this repository and the one it retrieves for the tree, so they need to be the same here"
			repo: self tree owner 
			update_ref: self updateReference
			author: self author
			committer: self committer
			message_encoding: self messageEncoding
			message: self message
			tree: self tree
			parent_count: self parents size
			parents: parentsPointer] ]! !

!LGitCommitBuilder methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
commit_create: theCommitId repo: repo update_ref: update_ref author: theAuthor committer: theCommitter message_encoding: message_encoding message: theMessage tree: theTree parent_count: parent_count parents: parentsPointer
	
	<todo:
		'try to use original function signature instead of passing ExternalAddress as last arg'>
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_commit_create #(LGitId * theCommitId , LGitRepository repo , String update_ref , LGitSignature * theAuthor , LGitSignature * theCommitter , String message_encoding , String theMessage , LGitTree theTree , size_t parent_count , void *parentsPointer))
		options: #(optCoerceNilToNull)! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
committer
	^ committer ifNil: [ 
		committer := self repository defaultSignature ]! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
message
	^ message ifNil: [ message := 'empty message' ]! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
tree: anLGitTree
	tree := anLGitTree! !

!LGitCommitBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
parents: aCollection
	parents := aCollection! !

!LGitCommitStore methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
forReferencePrintOn: aStream
	
	aStream nextPutAll: 'git://'! !

!LGitCommitStore methodsFor: 'public' stamp: ' 1/5/2022 21:01:26'!
basenameFromEntry: aLGitTreeEntry 
	
	^ aLGitTreeEntry filename! !

!LGitCommitStore methodsFor: 'error signalling' stamp: ' 1/5/2022 21:01:26'!
basicOpen: path writable: aBoolean 
	
	^ self
		nodeAt: path
		ifPresent: [ :aMemoryFileSystemEntry | aMemoryFileSystemEntry ]
		ifAbsent: [ 
			aBoolean
				ifFalse: [ self signalFileDoesNotExist: path ]
				ifTrue: [ self createFile: path ] ]! !

!LGitCommitStore methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
delimiter
	
	^ $/! !

!LGitCommitStore methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
nodeAt: anAbsolutePath ifPresent: aBlockClosure ifAbsent: aBlockClosure3 
	
	anAbsolutePath isRoot ifTrue: [ ^ aBlockClosure value: commit tree ].	
	^ aBlockClosure value: (commit tree
		entryByPath: anAbsolutePath pathString
		ifAbsent: [ ^ aBlockClosure3 value ])! !

!LGitCommitStore methodsFor: 'abstract' stamp: ' 1/5/2022 21:01:26'!
basicSizeOf: aLGitTreeEntry 
	
	^ (self basicIsDirectory: aLGitTreeEntry)
		ifTrue: [ 0 ]
		ifFalse: [ aLGitTreeEntry object rawSize ]! !

!LGitCommitStore methodsFor: 'abstract' stamp: ' 1/5/2022 21:01:26'!
basicEntry: directoryEntry path: aPath nodesDo: aBlock
	
	directoryEntry entries do: [ :each | aBlock value: each ]! !

!LGitCommitStore methodsFor: 'abstract' stamp: ' 1/5/2022 21:01:26'!
basicIsDirectory: aNode
	
	^ aNode object isTree! !

!LGitCommitStore methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
commit: anIceGitCommit 
	commit := anIceGitCommit! !

!LGitCommitStore methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
handleClass
	
	^ LGitFileHandle! !

!LGitCommitStore methodsFor: 'abstract' stamp: ' 1/5/2022 21:01:26'!
basicCreationTimeOf: aLGitTreeEntry 
	
	^ commit time asDateAndTime! !

!LGitCommitStore methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
humanReadableSIByteSize
	
	^ 0! !

!LGitCommitStore methodsFor: 'abstract' stamp: ' 1/5/2022 21:01:26'!
basicIsFile: aLGitTreeEntry 
	
	^ aLGitTreeEntry object isBlob! !

!LGitCommitStore class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
on: aLGitCommit 
	
	^ self new
		commit: aLGitCommit;
		yourself! !

!LGitCompletionCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (LGitRemoteCompletionTypeEnum type, void *argument))! !

!LGitConfig commentStamp: 'NicoPasserini 2/8/2017 00:51'!
/** Memory representation of a set of config files */
typedef struct git_config git_config;

https://libgit2.github.com/libgit2/#HEAD/type/git_config
!
!LGitConfig methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
config_set_string: name to: value

	^ self ffiCallSafely:
			#(LGitReturnCodeEnum git_config_set_string(
				self, 
				String name, 
				String value))
		options: #()! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
email
	
	^ self getString: 'user.email' ifAbsent: [ NotFound signalFor: 'user.email' ]! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
getString: name ifPresent: presentBlock ifAbsent: absentBlock
	| buf |
	buf := LGitBuf new.
	^ [
		self config_get_string: name output: buf.
		buf prim_ptr readStringUTF8
			ifNotEmpty: presentBlock
			ifEmpty: absentBlock
	]
	ensure: [ buf free ]! !

!LGitConfig methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
config_get_bool: name to: out

	^ self ffiCallSafely:
			#(LGitReturnCodeEnum git_config_get_bool(
				int *out,
				self, 
				String name))
		options: #()! !

!LGitConfig methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
config_set_bool: name to: value

	^ self ffiCallSafely:
			#(LGitReturnCodeEnum git_config_set_bool(
				self, 
				String name, 
				Boolean value))
		options: #()! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
globalConfigurationPath
	| outHandle |

	outHandle := ByteString new: 256.
	self config_find_global_path: outHandle.
	^ outHandle! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
unset: name
	^ self config_delete_entry: name! !

!LGitConfig methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
config_open_global: out

	^ self ffiCallSafely: #(int git_config_open_global("LGitConfig **"void **out, self))! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
setBoolean: name to: value
	self config_set_bool: name to: value! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
openGlobal
	| outHandle |

	outHandle := ExternalAddress null.
	self config_open_global: outHandle.
	^ (self class fromHandle: outHandle) autoRelease! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
getBoolean: name
	| out |
	
	out := ByteArray new: FFIInt32 externalTypeSize.
	self config_get_bool: name to: out.
	^ (out signedLongAt: 1) ~= 0! !

!LGitConfig methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
config_delete_entry: name

	^ self ffiCallSafely:
			#(LGitReturnCodeEnum git_config_delete_entry(
				self, 
				String name))
		options: #()! !

!LGitConfig methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
config_find_global_path: out

	^ self ffiCallSafely: #(int git_config_find_global(String* out))! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
email: aString 
	
	self setString: 'user.email' to: aString! !

!LGitConfig methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
config_get_string: name output: output

	^ self ffiCallSafely:
			#(LGitReturnCodeEnum git_config_get_string_buf(
				LGitBuf* output, 
				self, 
				String name))
		options: #()! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
username: aString 
	
	self setString: 'user.name' to: aString! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
getString: name ifAbsent: aBlock
	^ self getString: name ifPresent: #yourself ifAbsent: aBlock! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
username
	
	^ self getString: 'user.name' ifAbsent: [ NotFound signalFor: 'user.name' ]! !

!LGitConfig methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
setString: name to: aString

	self config_set_string: name to: aString! !

!LGitConfig class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector

	^ #config_free:! !

!LGitConfig class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
config_free: handle

	^ self
		ffiCallSafely: #(void git_config_free #(void *handle))
		options: #()! !

!LGitCredAcquireCallback commentStamp: 'MaxLeske 3/1/2015 16:57'!
/**
 * Signature of a function which acquires a credential object.
 *
 * - cred: The newly created credential object.
 * - url: The resource for which we are demanding a credential.
 * - username_from_url: The username that was embedded in a "user@host"
 *                          remote url, or NULL if not included.
 * - allowed_types: A bitmask stating which cred types are OK to return.
 * - payload: The payload provided when specifying this callback.
 * - returns 0 for success, < 0 to indicate an error, > 0 to indicate
 *       no credential was acquired
 */!
!LGitCredAcquireCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
signature: signature "<String>" block: aBlock "<BlockClosure>"
	super signature: signature block: (self wrapBlock: aBlock)! !

!LGitCredAcquireCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
wrapBlock: aBlock

	^[ :credAddress :url :username_from_url :allowed_types :data |
		aBlock valueWithArguments: (Array
			with: (LGitCredentials fromHandle: credAddress) 
			with: url
			with: username_from_url
			with: allowed_types 
			with: data) ]! !

!LGitCredAcquireCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (LGitCredentials **cred, String url, String username_from_url, uint allowed_types, void *data))! !

!LGitCredentials methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credtype: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_CREDTYPE put: anObject value! !

!LGitCredentials methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credtype
	"This method was automatically generated"
	^LGitCredentialsTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_CREDTYPE)! !

!LGitCredentials methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createWith: aStructure
	self subclassResponsibility! !

!LGitCredentials methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_FREE) type: ExternalType void asPointerType! !

!LGitCredentials methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_FREE put: anObject getHandle.! !

!LGitCredentials methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
username: aString
	username := aString! !

!LGitCredentials methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
passphrase: aString
	passphrase := aString! !

!LGitCredentials methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
username
	^ username! !

!LGitCredentials methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
passphrase
	^ passphrase! !

!LGitCredentials class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
	LGitCredentialsTypeEnum credtype;
	LGitCredentialsFreeCallout free;
	)! !

!LGitCredentialsFreeCallout methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
credentials: credentials
	^ self
		ffiCallSafely: #(void #(LGitCredentials * credentials))
		options: #(optMayGC)! !

!LGitCredentialsPlaintext methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credtype: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_CREDTYPE put: anObject value! !

!LGitCredentialsPlaintext methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credtype
	"This method was automatically generated"
	^LGitCredentialsTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_CREDTYPE)! !

!LGitCredentialsPlaintext methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createWith: aStructure
	<todo: 'use exceptions instead of assertions'>
	self assert: self username isEmptyOrNil not.
	self assert: self passphrase isEmptyOrNil not.

	self withReturnHandlerDo: [ 
		self 
			cred_userpass_plaintext_new: aStructure
			username: self username
			password: self passphrase ]! !

!LGitCredentialsPlaintext methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
cred_userpass_plaintext_new: out username: usernameString password: password 
	^self ffiCallSafely: #(
		LGitReturnCodeEnum git_cred_userpass_plaintext_new(
			LGitCredentials * out, 
			String username, 
			String password)
	) options: #(  )! !

!LGitCredentialsPlaintext methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_FREE) type: ExternalType void asPointerType! !

!LGitCredentialsPlaintext methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_FREE put: anObject getHandle.! !

!LGitCredentialsPlaintext methodsFor: '*Iceberg-Adapters' stamp: ''!
readFrom: credentials
	self username: credentials username.
	self passphrase: credentials password.  
! !

!LGitCredentialsPlaintext class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
createFrom: provider onto: lgitCredentials
	| credentials |
	[
		credentials := self new.
		provider providePlaintextCredentialsTo: credentials.
		credentials createWith: lgitCredentials.
		^ 0
	]
	on: LGitNoCredentialsProvided do: [ :e | 
		LGitError setError: 'Invalid username and/or password provided.'.				
		^ -1 ]! !

!LGitCredentialsPlaintext class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
username: username passphrase: passphrase
	^ self new
		username: username;
		passphrase: passphrase;
		yourself! !

!LGitCredentialsSSH commentStamp: '<historical>'!
I'm a set of credentials who asks public/private keys from from files (in case you need something different than what is answered by ssh-agent, provided by LGitCredentialsSSHAgent)!
!LGitCredentialsSSH methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
setGitUsernameIn: aStructure
	self withReturnHandlerDo: [ 
		self cred_username_new: aStructure username: 'git'
	]! !

!LGitCredentialsSSH methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credtype: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_CREDTYPE put: anObject value! !

!LGitCredentialsSSH methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credtype
	"This method was automatically generated"
	^LGitCredentialsTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_CREDTYPE)! !

!LGitCredentialsSSH methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
publicKeyReference: aFileReference
	publicKeyReference := aFileReference! !

!LGitCredentialsSSH methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createWith: aStructure
	<todo: 'use exceptions instead of assertions'>
	self assert: self username isEmptyOrNil not.
	self assert: self publicKeyReference exists.
	self assert: self privateKeyReference exists.

	self withReturnHandlerDo: [ 
		self 
			cred_ssh_key_new: aStructure
			username: self username
			publickey: self publicKeyReference fullName
			privatekey: self privateKeyReference fullName
			passphrase: self passphrase ]! !

!LGitCredentialsSSH methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
cred_username_new: out username: usernameString
	^ self 
		ffiCallSafely: #(int git_cred_username_new (LGitCredentials * out, String usernameString)) 
		options: #()! !

!LGitCredentialsSSH methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
publicKeyReference
	^ publicKeyReference! !

!LGitCredentialsSSH methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_FREE) type: ExternalType void asPointerType! !

!LGitCredentialsSSH methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_FREE put: anObject getHandle.! !

!LGitCredentialsSSH methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
privateKeyReference: aFileReference
	privateKeyReference := aFileReference! !

!LGitCredentialsSSH methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
privateKeyReference
	^ privateKeyReference! !

!LGitCredentialsSSH methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
cred_ssh_key_new: out username: usernameString publickey: publickey privatekey: privatekey passphrase: passphraseString
	^self ffiCallSafely: 
		#(int git_cred_ssh_key_new(
			LGitCredentials * out, 
			String usernameString, 
			String publickey, 
			String privatekey, 
			String passphraseString)) options: #(  )! !

!LGitCredentialsSSH methodsFor: '*Iceberg-Adapters' stamp: ''!
readFrom: credentials
	self username: credentials username.
	self passphrase: credentials keyPassphrase.  
	self publicKeyReference: credentials publicKey asFileReference.
	self privateKeyReference: credentials privateKey asFileReference! !

!LGitCredentialsSSH class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
createFrom: provider username: username onto: lgitCredentials
	 ^ self createFrom: provider onto: lgitCredentials! !

!LGitCredentialsSSH class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
createFrom: provider onto: lgitCredentials
	| credentials |
	
 	^ [
		credentials := self new.
		provider provideSshCredentialsTo: credentials.
		credentials createWith: lgitCredentials.
		0
	]
	on: LGitNoCredentialsProvided do: [ 
		LGitError setError: 'Invalid ssh keys in provided files.'.		
		-1 ]! !

!LGitCredentialsSSH class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
username: username passphrase: passphrase publicKeyReference: publicKeyFileReference privateKeyReference: privateKeyFileReference
	^ self new
		username: username;
		passphrase: passphrase;
		publicKeyReference: publicKeyFileReference;
		privateKeyReference: privateKeyFileReference;
		yourself! !

!LGitCredentialsSSHAgent commentStamp: '<historical>'!
I'm a set of credentials who feeds from the ssh-agent client.!
!LGitCredentialsSSHAgent methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credtype: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_CREDTYPE put: anObject value! !

!LGitCredentialsSSHAgent methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credtype
	"This method was automatically generated"
	^LGitCredentialsTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_CREDTYPE)! !

!LGitCredentialsSSHAgent methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createWith: aName onto: aStructure
	<todo: 'use exceptions instead of assertions'>
	self assert: aName isEmptyOrNil not.

	self withReturnHandlerDo: [ 
		self cred_ssh_key_new: aStructure username: aName ]! !

!LGitCredentialsSSHAgent methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_FREE) type: ExternalType void asPointerType! !

!LGitCredentialsSSHAgent methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_FREE put: anObject getHandle.! !

!LGitCredentialsSSHAgent methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
cred_ssh_key_new: out username: aName
	^ self ffiCallSafely: #(int git_cred_ssh_key_from_agent(LGitCredentials *out, String aName))! !

!LGitCredentialsSSHAgent class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
createFrom: provider username: username onto: lgitCredentials
	| credentials |
	
	[  
		credentials := self new.
		provider provideSshAgentCredentialsTo: credentials.	
		credentials createWith: username onto: lgitCredentials.
		^ 0 ]
	on: LGitNoCredentialsProvided do: [ 
		LGitError setError: 'No ssh-agent suitable credentials found.'.
		^ -1 ]! !

!LGitCredentialsTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_credtype_ssh_custom
	^ self basicNew
		value: 4;
		yourself! !

!LGitCredentialsTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_credtype_default
	^ self basicNew
		value: 8;
		yourself! !

!LGitCredentialsTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_CREDTYPE_USERPASS_PLAINTEXT 1
	GIT_CREDTYPE_SSH_KEY 2
	GIT_CREDTYPE_SSH_CUSTOM 4
	GIT_CREDTYPE_DEFAULT 8
)! !

!LGitCredentialsTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_credtype_userpass_plaintext
	^ self basicNew
		value: 1;
		yourself! !

!LGitCredentialsTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_credtype_ssh_key
	^ self basicNew
		value: 2;
		yourself! !

!LGitDatabase commentStamp: 'TorstenBergmann 6/2/2021 22:04'!
A git database!
!LGitDeltaTypeEnum commentStamp: 'MaxLeske 8/13/2015 10:32'!
/**
 * What type of change is described by a git_diff_delta?
 *
 * `GIT_DELTA_RENAMED` and `GIT_DELTA_COPIED` will only show up if you run
 * `git_diff_find_similar()` on the diff object.
 *
 * `GIT_DELTA_TYPECHANGE` only shows up given `GIT_DIFF_INCLUDE_TYPECHANGE`
 * in the option flags (otherwise type changes will be split into ADDED /
 * DELETED pairs).
 */!
!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_unmodified
	^ self basicNew
		value: 0;
		yourself! !

!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_untracked
	^ self basicNew
		value: 7;
		yourself! !

!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_unreadable
	^ self basicNew
		value: 9;
		yourself! !

!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_ignored
	^ self basicNew
		value: 6;
		yourself! !

!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_renamed
	^ self basicNew
		value: 4;
		yourself! !

!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_modified
	^ self basicNew
		value: 3;
		yourself! !

!LGitDeltaTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_DELTA_UNMODIFIED 0 "no changes"
	GIT_DELTA_ADDED 1 "entry does not exist in old version"
	GIT_DELTA_DELETED 2 "entry does not exist in new version"
	GIT_DELTA_MODIFIED 3 "entry content changed between old and new"
	GIT_DELTA_RENAMED 4 "entry was renamed between old and new"
	GIT_DELTA_COPIED 5 "entry was copied from another old entry"
	GIT_DELTA_IGNORED 6 "entry is ignored item in workdir"
	GIT_DELTA_UNTRACKED 7 "entry is untracked item in workdir"
	GIT_DELTA_TYPECHANGE 8 "type of entry changed between old and new"
	GIT_DELTA_UNREADABLE 9 "entry is unreadable"
	GIT_DELTA_CONFLICTED 10 "< entry in the index is conflicted"
)! !

!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_added
	^ self basicNew
		value: 1;
		yourself! !

!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_conflicted
	^ self basicNew
		value: 10;
		yourself! !

!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_typechange
	^ self basicNew
		value: 8;
		yourself! !

!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_copied
	^ self basicNew
		value: 5;
		yourself! !

!LGitDeltaTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_delta_deleted
	^ self basicNew
		value: 2;
		yourself! !

!LGitDiff commentStamp: 'TorstenBergmann 6/2/2021 22:21'!
See [https://libgit2.org/libgit2/#HEAD/group/diff](https://libgit2.org/libgit2/#HEAD/group/diff)!
!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_get_delta: diff idx: idx
	<todo: 'use LGitDiffDelta* as return type'>
	
	^ self
		ffiCallSafely: #(void *git_diff_get_delta #(self , size_t idx))
		options: #()! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
deltasDo: aBlock
	^ 1 to: self numberOfDeltas do: [ :index | aBlock value: (self deltaAt: index) ]! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_blob_to_buffer: old_blob old_as_path: old_as_path buffer: buffer buffer_len: buffer_len buffer_as_path: buffer_as_path options: options file_cb: file_cb hunk_cb: hunk_cb line_cb: line_cb payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_diff_blob_to_buffer #(LGitBlob old_blob , String old_as_path , String buffer , size_t buffer_len , String buffer_as_path , LGitDiffOptions * options , LGitDiffFileCallback file_cb , LGitDiffHunkCallback hunk_cb , LGitDiffLineCallback line_cb , void * payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
diffTree: oldTree toIndex: index options: anLGitDiffOptions
	self withReturnHandlerDo: [
		self
			diff_tree_to_index: self
			repo: self repository
			old_tree: oldTree
			index: index
			opts: anLGitDiffOptions ]! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_num_deltas: diff
	
	^ self ffiCallSafely: #(size_t git_diff_num_deltas #(self)) options: #()! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_print: diff format: format print_cb: print_cb payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_diff_print #(self , LGitDiffFormatTypeEnum format , LGitDiffLineCallback print_cb , void *payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_find_similar: diff diff_find_options: options
	
	^ self ffiCallSafely: #(LGitReturnCodeEnum git_diff_find_similar #(self, LGitDiffFindOptions *options)) options: #()! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
diffTree: oldTree toTree: newTree options: anLGitDiffOptions
	self withReturnHandlerDo: [
		self
			diff_tree_to_tree: self
			repo: self repository
			old_tree: oldTree
			new_tree: newTree
			opts: anLGitDiffOptions ]! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_get_stats: out diff: diff
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_diff_get_stats #(LGitDiffStats * out , self))
		options: #()! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_tree_to_tree: diff repo: repo old_tree: old_tree new_tree: new_tree opts: opts
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_diff_tree_to_tree #(LGitDiff * diff , LGitRepository repo , LGitTree old_tree , LGitTree new_tree , LGitDiffOptions * opts))
		options: #()! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
diffIndexToWorkDir
	self diffIndexToWorkDirOptions: LGitDiffOptions defaults! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
diffTree: oldTree toIndex: index
	
	self
		diffTree: oldTree
		toIndex: index
		options: LGitDiffOptions defaults! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_is_sorted_icase: diff
	
	^ self ffiCallSafely: #(Boolean git_diff_is_sorted_icase #(self)) options: #()! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_num_deltas_of_type: diff type: type
	
	^ self
		ffiCallSafely: #(size_t git_diff_num_deltas_of_type #(self , LGitDeltaTypeEnum type))
		options: #()! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
diffIndexToWorkDirOptions: anLGitDiffOptions
	self withReturnHandlerDo: [
		self
			diff_index_to_workdir: self
			repo: self repository
			index: self repository index
			opts: anLGitDiffOptions ]! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
diffFindSimilar: options
	^ self withReturnHandlerDo: [
		self
			diff_find_similar: self
			diff_find_options: options ]! !

!LGitDiff methodsFor: 'enumerating' stamp: ' 1/5/2022 21:01:26'!
filesDo: filesBlockOrNil binaryFilesDo: binaryBlockOrNil hunksDo: hunksBlockOrNil linesDo: linesBlockOrNil
	^ self
		diff_foreach: self
		file_cb: (filesBlockOrNil 
			ifNotNil: [ LGitDiffFileCallback on: filesBlockOrNil ]
			ifNil: [ LGitDiffFileCallback null ])
		binary_cb: (binaryBlockOrNil 
			ifNotNil: [ 	LGitDiffBinaryCallback on: binaryBlockOrNil ]
			ifNil: [ LGitDiffBinaryCallback null ])
		hunk_cb: (hunksBlockOrNil 
			ifNotNil: [ 	LGitDiffHunkCallback on: hunksBlockOrNil ]
			ifNil: [ LGitDiffHunkCallback null ])
		line_cb: (linesBlockOrNil 
			ifNotNil: [ 	LGitDiffLineCallback on: linesBlockOrNil ]
			ifNil: [ LGitDiffLineCallback null ])
		payload: ExternalAddress null! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
diffFindSimilar
	^ self diffFindSimilar: LGitDiffFindOptions defaults! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_foreach: diff file_cb: file_cb binary_cb: binary_cb hunk_cb: hunk_cb line_cb: line_cb payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_diff_foreach #(self , LGitDiffFileCallback file_cb , LGitDiffBinaryCallback binary_cb , LGitDiffHunkCallback hunk_cb , LGitDiffLineCallback line_cb , void * payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
deltaAt: anInteger
	"use 1 based offset as in Smalltalk"
	^ LGitDiffDelta fromHandle: (
		self
			diff_get_delta: self
			idx: anInteger - 1) getHandle! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_tree_to_workdir: diff repo: repo old_tree: old_tree opts: opts
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_diff_tree_to_workdir #(LGitDiff * self , LGitRepository repo , LGitTree old_tree , LGitDiffOptions * opts))
		options: #()! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_index_to_workdir: diff repo: repo index: index opts: opts
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_diff_index_to_workdir #(LGitDiff * self , LGitRepository repo , LGitIndex index , LGitDiffOptions * opts))
		options: #()! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
numberOfDeltas
	^ self diff_num_deltas: self! !

!LGitDiff methodsFor: '*Iceberg-Core' stamp: ''!
includesFileNamed: path
	^ (self filesDo: [ :delta :second :third | 
		| modifiedFileName |
		modifiedFileName := delta newFile path.
		(modifiedFileName beginsWith: path) asAlien
	]) asBoolean.
! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_tree_to_workdir_with_index: diff repo: repo old_tree: old_tree opts: opts
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_diff_tree_to_workdir_with_index #(LGitDiff * self , LGitRepository repo , LGitTree old_tree , LGitDiffOptions * opts))
		options: #()! !

!LGitDiff methodsFor: '*Iceberg-Core' stamp: ''!
filesDo: aBlockClosure 
	^ self filesDo: aBlockClosure binaryFilesDo: aBlockClosure hunksDo: nil linesDo: nil		
! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_status_char: status
	
	^ self
		ffiCallSafely: #(Character git_diff_status_char #(LGitDeltaTypeEnum status))
		options: #()! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_get_perfdata: out diff: diff
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_diff_get_perfdata #(LGitDiffPerfData * out , self))
		options: #()! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_tree_to_index: diff repo: repo old_tree: old_tree index: index opts: opts
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_diff_tree_to_index #(LGitDiff * self , LGitRepository repo , LGitTree old_tree , LGitIndex index , LGitDiffOptions * opts))
		options: #()! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
deltas
	^ Array
		new: self numberOfDeltas
		streamContents: [ :stream |
			self deltasDo: [ :delta | stream nextPut: delta ] ]! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_buffers: old_buffer old_len: old_len old_as_path: old_as_path new_buffer: new_buffer new_len: new_len new_as_path: new_as_path options: options file_cb: file_cb hunk_cb: hunk_cb line_cb: line_cb payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_diff_buffers #(FFIVoid * old_buffer , size_t old_len , String old_as_path , void *new_buffer , size_t new_len , String new_as_path , LGitDiffOptions * options , LGitDiffFileCallback file_cb , LGitDiffHunkCallback hunk_cb , LGitDiffLineCallback line_cb , void * payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
diffTree: oldTree toTree: newTree
	self
		diffTree: oldTree
		toTree: newTree
		options: LGitDiffOptions defaults! !

!LGitDiff methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
patchAt: anInteger
	^ LGitPatch
		fromDiff: self
		at: anInteger! !

!LGitDiff methodsFor: '*Iceberg-Core' stamp: ''!
files
	| deltaFiles |
	
	deltaFiles := Set new.
	self filesDo: [ :delta :ignored1 :ignored2 | 
		deltaFiles add: delta newFile path.
		0 "Continue" ].
	^ deltaFiles! !

!LGitDiff methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_blobs: old_blob old_as_path: old_as_path new_blob: new_blob new_as_path: new_as_path options: options file_cb: file_cb hunk_cb: hunk_cb line_cb: line_cb payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_diff_blobs (LGitBlob old_blob , String old_as_path , LGitBlob new_blob , String new_as_path , LGitDiffOptions *options , LGitDiffFileCallback file_cb , LGitDiffHunkCallback hunk_cb , LGitDiffLineCallback line_cb , void *payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitDiff class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_free: handle
	
	^ self ffiCallSafely: #(void git_diff_free #(void *handle)) options: #()! !

!LGitDiff class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #diff_free:! !

!LGitDiffBinary commentStamp: 'MaxLeske 8/13/2015 14:22'!
/** Structure describing the binary contents of a diff. */!
!LGitDiffBinary methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_file: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_OLD_FILE put: anObject getHandle length: LGitDiffBinaryFile byteSize! !

!LGitDiffBinary methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_file
	"This method was automatically generated"
	^ LGitDiffBinaryFile fromHandle: (handle referenceStructAt: OFFSET_PRIM_OLD_FILE length: LGitDiffBinaryFile byteSize)! !

!LGitDiffBinary methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_contains_data: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_CONTAINS_DATA put: anObject! !

!LGitDiffBinary methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_file: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_NEW_FILE put: anObject getHandle length: LGitDiffBinaryFile byteSize! !

!LGitDiffBinary methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_contains_data
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_CONTAINS_DATA! !

!LGitDiffBinary methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_file
	"This method was automatically generated"
	^ LGitDiffBinaryFile fromHandle: (handle referenceStructAt: OFFSET_PRIM_NEW_FILE length: LGitDiffBinaryFile byteSize)! !

!LGitDiffBinary class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(	
		uint contains_data;
		LGitDiffBinaryFile old_file; "< The contents of the old file."
		LGitDiffBinaryFile new_file; "< The contents of the new file."
	)! !

!LGitDiffBinaryCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
signature: signature "<String>" block: aBlock "<BlockClosure>"
	super signature: signature block: (self wrapBlock: aBlock)! !

!LGitDiffBinaryCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
wrapBlock: aThreeArgBlock

	^[ :deltaAddress :binary :payload |
		aThreeArgBlock 
			value: (LGitDiffDelta fromHandle: deltaAddress) 
			value: (LGitDiffBinary fromHandle: binary) 
			value: payload ]! !

!LGitDiffBinaryCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (LGitDiffDelta *delta, LGitDiffBinary *binary, void *payload))! !

!LGitDiffBinaryFile commentStamp: 'MaxLeske 8/13/2015 14:22'!
/** The contents of one of the files in a binary diff. */!
!LGitDiffBinaryFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_datalen
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_DATALEN! !

!LGitDiffBinaryFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_inflatedlen
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_INFLATEDLEN! !

!LGitDiffBinaryFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_inflatedlen: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_INFLATEDLEN put: anObject! !

!LGitDiffBinaryFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_data
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_DATA) type: ExternalType void asPointerType! !

!LGitDiffBinaryFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_TYPE put: anObject value! !

!LGitDiffBinaryFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_data: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_DATA put: anObject getHandle.! !

!LGitDiffBinaryFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_datalen: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_DATALEN put: anObject! !

!LGitDiffBinaryFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_type
	"This method was automatically generated"
	^LGitDiffBinaryTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_TYPE)! !

!LGitDiffBinaryFile class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		" The type of binary data for this file. "
		LGitDiffBinaryTypeEnum type;

		" The binary data, deflated. is char* originally, but I do not want to get the \0"
		void *data;

		" The length of the binary data. "
		size_t datalen;

		" The length of the binary data after inflation. "
		size_t inflatedlen;
	)! !

!LGitDiffBinaryTypeEnum commentStamp: 'MaxLeske 8/13/2015 14:28'!
/**
 * When producing a binary diff, the binary data returned will be
 * either the deflated full ("literal") contents of the file, or
 * the deflated binary delta between the two sides (whichever is
 * smaller).
 */!
!LGitDiffBinaryTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_binary_delta
	^ self basicNew
		value: 2;
		yourself! !

!LGitDiffBinaryTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_binary_none
	^ self basicNew
		value: 0;
		yourself! !

!LGitDiffBinaryTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
		" There is no binary delta. "
		GIT_DIFF_BINARY_NONE 0

		" The binary data is the literal contents of the file. "
		GIT_DIFF_BINARY_LITERAL 1

		" The binary data is the delta from one side to the other. "
		GIT_DIFF_BINARY_DELTA 2
	)! !

!LGitDiffBinaryTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_binary_literal
	^ self basicNew
		value: 1;
		yourself! !

!LGitDiffDelta commentStamp: 'MaxLeske 7/4/2015 17:03'!
I represent the difference between two entities (e.g. two files). If one of the entities is new or deleted the "nfiles" field will hold be set to 1, otherwise it will be set to 2.!
!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_status: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_STATUS put: anObject value! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_status
	"This method was automatically generated"
	^LGitDeltaTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_STATUS)! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_nfiles: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PRIM_NFILES put: anObject! !

!LGitDiffDelta methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
oldFile
	^ self prim_old_file! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_file: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_OLD_FILE put: anObject getHandle length: LGitDiffFile byteSize! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_similarity: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PRIM_SIMILARITY put: anObject! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_FLAGS put: anObject! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_file
	"This method was automatically generated"
	^ LGitDiffFile fromHandle: (handle referenceStructAt: OFFSET_PRIM_OLD_FILE length: LGitDiffFile byteSize)! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_FLAGS! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_similarity
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PRIM_SIMILARITY! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_file: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_NEW_FILE put: anObject getHandle length: LGitDiffFile byteSize! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_nfiles
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PRIM_NFILES! !

!LGitDiffDelta methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
status
	^ self prim_status! !

!LGitDiffDelta methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
numberOfFiles
	^ self prim_nfiles! !

!LGitDiffDelta methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_file
	"This method was automatically generated"
	^ LGitDiffFile fromHandle: (handle referenceStructAt: OFFSET_PRIM_NEW_FILE length: LGitDiffFile byteSize)! !

!LGitDiffDelta methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
newFile
	^ self prim_new_file! !

!LGitDiffDelta class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDescForWindows
	^#(	
	LGitDeltaTypeEnum status
	uint32 flags
	"for RENAMED and COPIED, value 0-100"
	uint32 similarity
	"number of files in this delta"
	uint32 nfiles
	LGitDiffFile old_file
	LGitDiffFile new_file
	)! !

!LGitDiffDelta class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	"Since it seems to be a problem with the alignment of this structure in particular
	 and windows, we need to create a special definition (to ensure everything will go 
	 to the correct place). This is a bit ugly, but is the easiest way I found."
	OSPlatform current isWindows 
		ifTrue: [ ^ self fieldsDescForWindows ]. 
	
	^#(	
	LGitDeltaTypeEnum status
	uint32 flags
	"for RENAMED and COPIED, value 0-100"
	uint16 similarity
	"number of files in this delta"
	uint16 nfiles
	LGitDiffFile old_file
	LGitDiffFile new_file
	)! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_id
	"This method was automatically generated"
	^ LGitId fromHandle: (handle referenceStructAt: OFFSET_PRIM_ID length: LGitId byteSize)! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_size
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_PRIM_SIZE! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_mode
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PRIM_MODE! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_FLAGS put: anObject! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_path: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_PATH put: anObject getHandle.! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_FLAGS! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_mode: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PRIM_MODE put: anObject! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_path
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_PATH) type: ExternalType char asPointerType! !

!LGitDiffFile methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
size
	^ self prim_size! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_id: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_ID put: anObject getHandle length: LGitId byteSize! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_id_abbrev
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PRIM_ID_ABBREV! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_size: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_PRIM_SIZE put: anObject! !

!LGitDiffFile methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_id_abbrev: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PRIM_ID_ABBREV put: anObject! !

!LGitDiffFile methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
id
	^ self prim_id! !

!LGitDiffFile methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
path
	^ self prim_path readStringUTF8! !

!LGitDiffFile class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
	LGitId id
	String path
	int64 size
	uint32 flags
	uint16 mode
	uint16 id_abbrev
	)! !

!LGitDiffFileCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
signature: signature "<String>" block: aBlock "<BlockClosure>"
	super signature: signature block: (self wrapBlock: aBlock)! !

!LGitDiffFileCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
wrapBlock: aThreeArgBlock

	^[ :deltaAddress :progress :payload |
		aThreeArgBlock 
			value: (LGitDiffDelta fromHandle: deltaAddress) 
			value: progress
			value: payload ]! !

!LGitDiffFileCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (LGitDiffDelta * delta, float progress, void *payload))! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_metric: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_METRIC put: anObject getHandle length: LGitDiffSimilarityMetric byteSize! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_break_rewrite_threshold: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PRIM_BREAK_REWRITE_THRESHOLD put: anObject! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_rename_from_rewrite_threshold: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PRIM_RENAME_FROM_REWRITE_THRESHOLD put: anObject! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitDiffFindOptions methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self withReturnHandlerDo: [
		self
			diff_find_init_options: self
			version: LGitOptionsVersionsEnum git_diff_find_options_version_1 ]! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_break_rewrite_threshold
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PRIM_BREAK_REWRITE_THRESHOLD! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags: diffFindTypeEnum
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_FLAGS put: diffFindTypeEnum value! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_copy_threshold
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PRIM_COPY_THRESHOLD! !

!LGitDiffFindOptions methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_find_init_options: opts version: version
	^ self
		ffiCall: #(LGitReturnCodeEnum git_diff_find_init_options(LGitDiffFindOptions * self, LGitOptionsVersionsEnum version))
		options: #(  )! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags
	"This method was automatically generated"
	^ LGitDiffFindTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_FLAGS)! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_rename_limit
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_RENAME_LIMIT! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_rename_threshold
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PRIM_RENAME_THRESHOLD! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_copy_threshold: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PRIM_COPY_THRESHOLD put: anObject! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_rename_limit: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_RENAME_LIMIT put: anObject! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_metric
	"This method was automatically generated"
	^ LGitDiffSimilarityMetric fromHandle: (handle referenceStructAt: OFFSET_PRIM_METRIC length: LGitDiffSimilarityMetric byteSize)! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitDiffFindOptions methodsFor: 'accessing - structure variables' stamp: ' 1/5/2022 21:01:26'!
flags: diffFlags
	self prim_flags: diffFlags! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_rename_from_rewrite_threshold
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PRIM_RENAME_FROM_REWRITE_THRESHOLD! !

!LGitDiffFindOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_rename_threshold: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PRIM_RENAME_THRESHOLD put: anObject! !

!LGitDiffFindOptions class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		LGitOptionsVersionsEnum version;

		"Combination of git_diff_find_t values (default GIT_DIFF_FIND_BY_CONFIG).
		 NOTE: if you don't explicitly set this, `diff.renames` could be set
		 to false, resulting in `git_diff_find_similar` doing nothing."
		uint32 flags;

		" Similarity to consider a file renamed (default 50) "
		uint16 rename_threshold;
		" Similarity of modified to be eligible rename source (default 50) "
		uint16 rename_from_rewrite_threshold;
		" Similarity to consider a file a copy (default 50) "
		uint16 copy_threshold;
		" Similarity to split modify into delete/add pair (default 60) "
		uint16 break_rewrite_threshold;

		"Maximum similarity sources to examine for a file (somewhat like
		 git-diff's `-l` option or `diff.renameLimit` config) (default 200)"
		size_t rename_limit;

		" Pluggable similarity metric; pass NULL to use internal metric "
		LGitDiffSimilarityMetric metric;
	)! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_break_rewrites_for_renames_only
	^ self basicNew
		value: 32768;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_all
	^ self basicNew
		value: 255;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_rewrites
	^ self basicNew
		value: 16;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_by_config
	^ self basicNew
		value: 0;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_remove_unmodified
	^ self basicNew
		value: 65536;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_ignore_whitespace
	^ self basicNew
		value: 4096;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_break_rewrites
	^ self basicNew
		value: 32;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_renames_from_rewrites
	^ self basicNew
		value: 2;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_dont_ignore_whitespace
	^ self basicNew
		value: 8192;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	<todo: 'enum defines 0 twice (one commented out). Use second enum?'>
	^#(
	" Obey `diff.renames`. Overridden by any other GIT_DIFF_FIND_... flag. "
	GIT_DIFF_FIND_BY_CONFIG 0

	" Look for renames? (`--find-renames`) "
	GIT_DIFF_FIND_RENAMES 1

	" Consider old side of MODIFIED for renames? (`--break-rewrites=N`) "
	GIT_DIFF_FIND_RENAMES_FROM_REWRITES 2

	" Look for copies? (a la `--find-copies`). "
	GIT_DIFF_FIND_COPIES 4

	" Consider UNMODIFIED as copy sources? (`--find-copies-harder`).
	 *
	 * For this to work correctly use GIT_DIFF_INCLUDE_UNMODIFIED when
	 * the initial `git_diff` is being generated.
	 "
	GIT_DIFF_FIND_COPIES_FROM_UNMODIFIED 8

	" Mark significant rewrites for split (`--break-rewrites=/M`) "
	GIT_DIFF_FIND_REWRITES 16
	" Actually split large rewrites into delete/add pairs "
	GIT_DIFF_BREAK_REWRITES 32
	" Mark rewrites for split and break into delete/add pairs "
	GIT_DIFF_FIND_AND_BREAK_REWRITES 48

	" Find renames/copies for UNTRACKED items in working directory.
	 *
	 * For this to work correctly use GIT_DIFF_INCLUDE_UNTRACKED when the
	 * initial `git_diff` is being generated (and obviously the diff must
	 * be against the working directory for this to make sense).
	 "
	GIT_DIFF_FIND_FOR_UNTRACKED 64

	" Turn on all finding features. "
	GIT_DIFF_FIND_ALL 255

	" Measure similarity ignoring leading whitespace (default) "
	"GIT_DIFF_FIND_IGNORE_LEADING_WHITESPACE 0"
	" Measure similarity ignoring all whitespace "
	GIT_DIFF_FIND_IGNORE_WHITESPACE 4096
	" Measure similarity including all data "
	GIT_DIFF_FIND_DONT_IGNORE_WHITESPACE 8192
	" Measure similarity only by comparing SHAs (fast and cheap) "
	GIT_DIFF_FIND_EXACT_MATCH_ONLY 16384

	" Do not break rewrites unless they contribute to a rename.
	 *
	 * Normally GIT_DIFF_FIND_AND_BREAK_REWRITES will measure the self-
	 * similarity of modified files and split the ones that have changed a
	 * lot into a DELETE / ADD pair.  Then the sides of that pair will be
	 * considered candidates for rename and copy detection.
	 *
	 * If you add this flag in and the split pair is *not* used for an
	 * actual rename or copy then the modified record will be restored to
	 * a regular MODIFIED record instead of being split.
	 "
	GIT_DIFF_BREAK_REWRITES_FOR_RENAMES_ONLY 32768

	" Remove any UNMODIFIED deltas after find_similar is done.
	 *
	 * Using GIT_DIFF_FIND_COPIES_FROM_UNMODIFIED to emulate the
	 * --find-copies-harder behavior requires building a diff with the
	 * GIT_DIFF_INCLUDE_UNMODIFIED flag.  If you do not want UNMODIFIED
	 * records in the final result pass this flag to have them removed.
	 "
	GIT_DIFF_FIND_REMOVE_UNMODIFIED 65536
	)! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_renames
	^ self basicNew
		value: 1;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_for_untracked
	^ self basicNew
		value: 64;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_and_break_rewrites
	^ self basicNew
		value: 48;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_copies_from_unmodified
	^ self basicNew
		value: 8;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_exact_match_only
	^ self basicNew
		value: 16384;
		yourself! !

!LGitDiffFindTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_copies
	^ self basicNew
		value: 4;
		yourself! !

!LGitDiffFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_flag_valid_id
	^ self basicNew
		value: 2;
		yourself! !

!LGitDiffFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_flag_binary
	^ self basicNew
		value: 0;
		yourself! !

!LGitDiffFlagTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_DIFF_FLAG_BINARY 0 "file(s) treated as binary data"
	GIT_DIFF_FLAG_NOT_BINARY 1 "file(s) treated as text data"
	GIT_DIFF_FLAG_VALID_ID  2 "`id` value is known correct"
	)! !

!LGitDiffFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_flag_not_binary
	^ self basicNew
		value: 1;
		yourself! !

!LGitDiffFormatTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_format_raw
	^ self basicNew
		value: 3;
		yourself! !

!LGitDiffFormatTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_format_name_only
	^ self basicNew
		value: 4;
		yourself! !

!LGitDiffFormatTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_DIFF_FORMAT_PATCH        1 "full git diff"
	GIT_DIFF_FORMAT_PATCH_HEADER 2 "just the file headers of patch"
	GIT_DIFF_FORMAT_RAW          3 "like git diff --raw"
	GIT_DIFF_FORMAT_NAME_ONLY    4 "like git diff --name-only"
	GIT_DIFF_FORMAT_NAME_STATUS  5 "like git diff --name-status"
	)! !

!LGitDiffFormatTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_format_patch
	^ self basicNew
		value: 1;
		yourself! !

!LGitDiffFormatTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_format_name_status
	^ self basicNew
		value: 5;
		yourself! !

!LGitDiffFormatTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_format_patch_header
	^ self basicNew
		value: 2;
		yourself! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_header_len
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_HEADER_LEN! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_start: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_OLD_START put: anObject! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_start
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_OLD_START! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_header_len: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_HEADER_LEN put: anObject! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_lines
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_OLD_LINES! !

!LGitDiffHunk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_patch_get_hunk: out lines_in_hunk: lines_in_hunk patch: patch hunk_idx: hunk_idx
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_patch_get_hunk(LGitDiffHunk * self, LGitWriteBackValueSizeT lines_in_hunk, LGitPatch patch, size_t hunk_idx))
		options: #(  )! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_start
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_NEW_START! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_lines
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_NEW_LINES! !

!LGitDiffHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
newStart
	^ self prim_new_start! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_lines: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_OLD_LINES put: anObject! !

!LGitDiffHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
oldStart
	^ self prim_old_start! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_header: anObject
	"This method was automatically generated"
	handle replaceFrom: OFFSET_PRIM_HEADER to: OFFSET_PRIM_HEADER + 127 with: anObject getHandle startingAt: 1! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_header
	"This method was automatically generated"
	^(FFITypeArray ofType: #FFICharacterType size: 128) fromHandle: (handle copyFrom: OFFSET_PRIM_HEADER to: OFFSET_PRIM_HEADER + 127)! !

!LGitDiffHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
newNumberOfLines
	^ self prim_new_lines! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_lines: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_NEW_LINES put: anObject! !

!LGitDiffHunk methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_start: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_NEW_START put: anObject! !

!LGitDiffHunk methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
oldNumberOfLines
	^ self prim_old_lines! !

!LGitDiffHunk class methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
initialize
	Char128 := FFITypeArray ofType: #char size: 128! !

!LGitDiffHunk class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
	int old_start "Starting line number in old_file"
	int old_lines "Number of lines in old_file"
	int new_start "Starting line number in new_file"
	int new_lines "Number of lines in new_file"
	size_t header_len "Number of bytes in header text"
	Char128 header "Header text, NUL-byte terminated" 
		)! !

!LGitDiffHunkCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
signature: signature "<String>" block: aBlock "<BlockClosure>"
	super signature: signature block: (self wrapBlock: aBlock)! !

!LGitDiffHunkCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
wrapBlock: aBlock

	^[ :deltaAddress :hunkAddress :payload |
		aBlock 
			value: (LGitDiffDelta fromHandle: deltaAddress) 
			value: (LGitDiffHunk fromHandle: hunkAddress)
			value: payload ]! !

!LGitDiffHunkCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (LGitDiffDelta *delta, LGitDiffHunk *hunk, void *payload))! !

!LGitDiffLine methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
oldLineNumber
	^ self prim_old_lineno! !

!LGitDiffLine methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
newLineNumber
	^ self prim_new_lineno! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_content
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_CONTENT) type: ExternalType char asPointerType! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_content_len: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_CONTENT_LEN put: anObject! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_lineno
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_OLD_LINENO! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_content: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_CONTENT put: anObject getHandle.! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_content_len
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_CONTENT_LEN! !

!LGitDiffLine methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
size
	^ self prim_content_len! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_content_offset
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_PRIM_CONTENT_OFFSET! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_lineno: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_OLD_LINENO put: anObject! !

!LGitDiffLine methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
content
	^ (self prim_content getHandle copyFrom: 1 to: self prim_content_len) asString! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_lineno: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_NEW_LINENO put: anObject! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_lineno
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_NEW_LINENO! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_num_lines
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_NUM_LINES! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_num_lines: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_NUM_LINES put: anObject! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_content_offset: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_PRIM_CONTENT_OFFSET put: anObject! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_origin: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_ORIGIN put: anObject value! !

!LGitDiffLine methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_origin
	"This method was automatically generated"
	^LGitDiffLineTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_ORIGIN)! !

!LGitDiffLine class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
	LGitDiffLineTypeEnum	  origin       "A git_diff_line_t value"
	int    old_lineno   "Line number in old file or -1 for added line"
	int    new_lineno   "Line number in new file or -1 for deleted line"
	int    num_lines    "Number of newline characters in content"
	size_t content_len  "Number of bytes of data"
	int64 content_offset "Offset in the original file to the content"
	String content "Pointer to diff text, not NUL-byte terminated"
	)! !

!LGitDiffLineCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
signature: signature "<String>" block: aBlock "<BlockClosure>"
	super signature: signature block: (self wrapBlock: aBlock)! !

!LGitDiffLineCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
wrapBlock: aFourArgBlock

	^[ :deltaAddress :hunkAddress :lineAddress :payload |
		aFourArgBlock 
			value: (LGitDiffDelta fromHandle: deltaAddress) 
			value: (LGitDiffHunk fromHandle: hunkAddress)
			value: (LGitDiffLine fromHandle: lineAddress)
			value: payload ]! !

!LGitDiffLineCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (LGitDiffDelta *delta, LGitDiffHunk *hunk, LGitDiffLine *line, void *payload))! !

!LGitDiffLineTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_line_context
	^ self basicNew
		value: $ ;
		yourself! !

!LGitDiffLineTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_line_deletion
	^ self basicNew
		value: $-;
		yourself! !

!LGitDiffLineTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_line_hunk_hdr
	^ self basicNew
		value: $H;
		yourself! !

!LGitDiffLineTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_line_binary
	^ self basicNew
		value: $B;
		yourself! !

!LGitDiffLineTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^{
	 "These values will be sent to `git_diff_line_cb` along with the line"
	#GIT_DIFF_LINE_CONTEXT.   '$ '.
	#GIT_DIFF_LINE_ADDITION.  '$+'.
	#GIT_DIFF_LINE_DELETION.  '$-'.

	#GIT_DIFF_LINE_CONTEXT_EOFNL. '$='."Both files have no LF at end"
	#GIT_DIFF_LINE_ADD_EOFNL. '$>'.    "Old has no LF at end new does"
	#GIT_DIFF_LINE_DEL_EOFNL. '$<'.    "Old has LF at end new does not"

	"The following values will only be sent to a `git_diff_line_cb` when
	 * the content of a diff is being formatted through `git_diff_print`.
	"
	#GIT_DIFF_LINE_FILE_HDR.  '$F'.
	#GIT_DIFF_LINE_HUNK_HDR.  '$H'.
	#GIT_DIFF_LINE_BINARY.    '$B' "For 'Binary files x and y differ'"
	}! !

!LGitDiffLineTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_line_context_eofnl
	^ self basicNew
		value: $=;
		yourself! !

!LGitDiffLineTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_line_del_eofnl
	^ self basicNew
		value: $<;
		yourself! !

!LGitDiffLineTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_line_file_hdr
	^ self basicNew
		value: $F;
		yourself! !

!LGitDiffLineTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_line_add_eofnl
	^ self basicNew
		value: $>;
		yourself! !

!LGitDiffLineTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_line_addition
	^ self basicNew
		value: $+;
		yourself! !

!LGitDiffNotifyCallback commentStamp: 'EstebanLorenzano 2/5/2018 10:10'!
Diff notification callback function.

https://libgit2.github.com/libgit2/#HEAD/group/callback/git_diff_notify_cb

The callback will be called for each file, just before the git_delta_t gets inserted into the diff.

When the callback: - returns < 0, the diff process will be aborted. - returns > 0, the delta will not be inserted into the diff, but the diff process continues. - returns 0, the delta is inserted into the diff, and the diff process continues.

!
!LGitDiffNotifyCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (LGitDiff *diff_so_far, LGitDiffDelta *delta_to_add, String matched_pathspec, void *payload))! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_ignore_case
	^ self basicNew
		value: 1024;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_show_untracked_content
	^ self basicNew
		value: 33554432;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_include_untracked
	^ self basicNew
		value: 8;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_skip_binary_check
	^ self basicNew
		value: 8192;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_recurse_untracked_dirs
	^ self basicNew
		value: 16;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_include_unreadable_as_untracked
	^ self basicNew
		value: 131072;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_reverse
	^ self basicNew
		value: 1;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_minimal
	^ self basicNew
		value: 536870912;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_include_unmodified
	^ self basicNew
		value: 32;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_ignore_whitespace
	^ self basicNew
		value: 4194304;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_normal
	^ self basicNew
		value: 0;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_ignore_whitespace_change
	^ self basicNew
		value: 8388608;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_update_index
	^ self basicNew
		value: 32768;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_recurse_ignored_dirs
	^ self basicNew
		value: 4;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_ignore_whitespace_eol
	^ self basicNew
		value: 16777216;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_ignore_filemode
	^ self basicNew
		value: 256;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_include_unreadable
	^ self basicNew
		value: 65536;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_patience
	^ self basicNew
		value: 268435456;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_enable_fast_untracked_dirs
	^ self basicNew
		value: 16384;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_include_ignored
	^ self basicNew
		value: 2;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_disable_pathspec_match
	^ self basicNew
		value: 4096;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_include_typechange_trees
	^ self basicNew
		value: 128;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_include_typechange
	^ self basicNew
		value: 64;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_show_unmodified
	^ self basicNew
		value: 67108864;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	"Normal diff, the default"
	GIT_DIFF_NORMAL 0

	"
	 * Options controlling which files will be in the diff
	"

	"Reverse the sides of the diff"
	GIT_DIFF_REVERSE 1

	"Include ignored files in the diff"
	GIT_DIFF_INCLUDE_IGNORED 2

	"Even with GIT_DIFF_INCLUDE_IGNORED, an entire ignored directory
	 *  will be marked with only a single entry in the diff; this flag
	 *  adds all files under the directory as IGNORED entries, too.
	"
	GIT_DIFF_RECURSE_IGNORED_DIRS 4

	"Include untracked files in the diff"
	GIT_DIFF_INCLUDE_UNTRACKED 8

	"Even with GIT_DIFF_INCLUDE_UNTRACKED, an entire untracked
	 *  directory will be marked with only a single entry in the diff
	 *  (a la what core Git does in `git status`); this flag adds *all*
	 *  files under untracked directories as UNTRACKED entries, too.
	"
	GIT_DIFF_RECURSE_UNTRACKED_DIRS 16

	"Include unmodified files in the diff"
	GIT_DIFF_INCLUDE_UNMODIFIED 32

	"Normally, a type change between files will be converted into a
	 *  DELETED record for the old and an ADDED record for the new; this
	 *  options enabled the generation of TYPECHANGE delta records.
	"
	GIT_DIFF_INCLUDE_TYPECHANGE 64

	"Even with GIT_DIFF_INCLUDE_TYPECHANGE, blob->tree changes still
	 *  generally show as a DELETED blob.  This flag tries to correctly
	 *  label blob->tree transitions as TYPECHANGE records with new_file's
	 *  mode set to tree.  Note: the tree SHA will not be available.
	"
	GIT_DIFF_INCLUDE_TYPECHANGE_TREES 128

	"Ignore file mode changes"
	GIT_DIFF_IGNORE_FILEMODE 256

	"Treat all submodules as unmodified"
	GIT_DIFF_IGNORE_SUBMODULES 512

	"Use case insensitive filename comparisons"
	GIT_DIFF_IGNORE_CASE 1024

	"If the pathspec is set in the diff options, this flags means to
	 *  apply it as an exact match instead of as an fnmatch pattern.
	"
	GIT_DIFF_DISABLE_PATHSPEC_MATCH 4096

	"Disable updating of the `binary` flag in delta records.  This is
	 *  useful when iterating over a diff if you don't need hunk and data
	 *  callbacks and want to avoid having to load file completely.
	"
	GIT_DIFF_SKIP_BINARY_CHECK 8192

	"When diff finds an untracked directory, to match the behavior of
	 *  core Git, it scans the contents for IGNORED and UNTRACKED files.
	 *  If *all* contents are IGNORED, then the directory is IGNORED; if
	 *  any contents are not IGNORED, then the directory is UNTRACKED.
	 *  This is extra work that may not matter in many cases.  This flag
	 *  turns off that scan and immediately labels an untracked directory
	 *  as UNTRACKED (changing the behavior to not match core Git).
	"
	GIT_DIFF_ENABLE_FAST_UNTRACKED_DIRS 16384

	"When diff finds a file in the working directory with stat
	 * information different from the index, but the OID ends up being the
	 * same, write the correct stat information into the index.  Note:
	 * without this flag, diff will always leave the index untouched.
	"
	GIT_DIFF_UPDATE_INDEX 32768

	"Include unreadable files in the diff"
	GIT_DIFF_INCLUDE_UNREADABLE 65536
	
	"Include unreadable files in the diff"
	GIT_DIFF_INCLUDE_UNREADABLE_AS_UNTRACKED 131072

	"
	 * Options controlling how output will be generated
	"

	"Treat all files as text, disabling binary attributes & detection"
	GIT_DIFF_FORCE_TEXT 1048576
	"Treat all files as binary, disabling text diffs"
	GIT_DIFF_FORCE_BINARY 2097152

	"Ignore all whitespace"
	GIT_DIFF_IGNORE_WHITESPACE 4194304
	"Ignore changes in amount of whitespace"
	GIT_DIFF_IGNORE_WHITESPACE_CHANGE 8388608
	"Ignore whitespace at end of line"
	GIT_DIFF_IGNORE_WHITESPACE_EOL 16777216

	"When generating patch text, include the content of untracked
	 *  files.  This automatically turns on GIT_DIFF_INCLUDE_UNTRACKED but
	 *  it does not turn on GIT_DIFF_RECURSE_UNTRACKED_DIRS.  Add that
	 *  flag if you want the content of every single UNTRACKED file.
	"
	GIT_DIFF_SHOW_UNTRACKED_CONTENT 33554432

	"When generating output, include the names of unmodified files if
	 *  they are included in the git_diff.  Normally these are skipped in
	 *  the formats that list files (e.g. name-only, name-status, raw).
	 *  Even with this, these will not be included in patch format.
	"
	GIT_DIFF_SHOW_UNMODIFIED 67108864

	"Use the 'patience diff' algorithm"
	GIT_DIFF_PATIENCE 268435456
	"Take extra time to find minimal diff"
	GIT_DIFF_MINIMAL 536870912

	"Include the necessary deflate / delta information so that `git-apply`
	 *  can apply given diff information to binary files.
	"
	GIT_DIFF_SHOW_BINARY 1073741824
	)! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_ignore_submodules
	^ self basicNew
		value: 512;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_force_text
	^ self basicNew
		value: 1048576;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_show_binary
	^ self basicNew
		value: 1073741824;
		yourself! !

!LGitDiffOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_force_binary
	^ self basicNew
		value: 2097152;
		yourself! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_ignore_submodules
	"This method was automatically generated"
	^LGitSubmoduleIgnoreTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_IGNORE_SUBMODULES)! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_pathspec
	"This method was automatically generated"
	^ LGitStringArray fromHandle: (handle referenceStructAt: OFFSET_PRIM_PATHSPEC length: LGitStringArray byteSize)! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_notify_cb
	"This method was automatically generated"
	^LGitDiffNotifyCallback forAddress: ((handle pointerAt: OFFSET_PRIM_NOTIFY_CB) asInteger)! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_prefix: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_NEW_PREFIX put: anObject getHandle.! !

!LGitDiffOptions methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self withReturnHandlerDo: [
		self
			diff_init_options: self
			version: LGitOptionsVersionsEnum git_diff_options_version_1 ]! !

!LGitDiffOptions methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_init_options: opts version: version
	^ self
		ffiCall: #(LGitReturnCodeEnum git_diff_init_options(LGitDiffOptions * self, LGitOptionsVersionsEnum version))
		options: #(  )! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_interhunk_lines: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_INTERHUNK_LINES put: anObject! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_prefix: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_OLD_PREFIX put: anObject getHandle.! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_notify_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_NOTIFY_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_progress_cb
	"This method was automatically generated"
	^LGitDiffProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PROGRESS_CB) asInteger)! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_max_size
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_PRIM_MAX_SIZE! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_ignore_submodules: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_IGNORE_SUBMODULES put: anObject value! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_new_prefix
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_NEW_PREFIX) type: ExternalType char asPointerType! !

!LGitDiffOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
pathspec: aPathSpec
	^ self prim_pathspec: aPathSpec! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_interhunk_lines
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_INTERHUNK_LINES! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_pathspec: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_PATHSPEC put: anObject getHandle length: LGitStringArray byteSize! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_FLAGS put: anObject! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_context_lines
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_CONTEXT_LINES! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_FLAGS! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_old_prefix
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_OLD_PREFIX) type: ExternalType char asPointerType! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_notify_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_NOTIFY_PAYLOAD put: anObject getHandle.! !

!LGitDiffOptions methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
pathspec
	^ self prim_pathspec! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_max_size: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_PRIM_MAX_SIZE put: anObject! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_context_lines: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_CONTEXT_LINES put: anObject! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_id_abbrev
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PRIM_ID_ABBREV! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_notify_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_NOTIFY_PAYLOAD) type: ExternalType void asPointerType! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_id_abbrev: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PRIM_ID_ABBREV put: anObject! !

!LGitDiffOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_progress_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PROGRESS_CB
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitDiffOptions class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		LGitOptionsVersionsEnum version      "version for the struct"
		uint32 flags            "defaults to GIT_DIFF_NORMAL"

		"options controlling which files are in the diff"

		LGitSubmoduleIgnoreTypeEnum ignore_submodules "submodule ignore rule"
		LGitStringArray       pathspec     "defaults to include all paths"
		LGitDiffNotifyCallback notify_cb
		LGitDiffProgressCallback progress_cb
		void *notify_payload

		"options controlling how to diff text is generated"

		uint32    context_lines    "defaults to 3"
		uint32    interhunk_lines  "defaults to 0"
		uint16    id_abbrev       "default 'core.abbrev' or 7 if unset"
		int64   max_size         "defaults to 512MB"
		String old_prefix       "defaults to 'a'"
		String new_prefix       "defaults to 'b'"
	)! !

!LGitDiffPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_VERSION! !

!LGitDiffPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_oid_calculations: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_OID_CALCULATIONS put: anObject! !

!LGitDiffPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_stat_calls
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_STAT_CALLS! !

!LGitDiffPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_stat_calls: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_STAT_CALLS put: anObject! !

!LGitDiffPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_oid_calculations
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_OID_CALCULATIONS! !

!LGitDiffPerfData methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject! !

!LGitDiffPerfData class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
	uint version
	size_t stat_calls "Number of stat() calls performed"
	size_t oid_calculations "Number of ID calculations"
	)! !

!LGitDiffProgressCallback commentStamp: 'EstebanLorenzano 2/5/2018 10:11'!
Diff progress callback.

https://libgit2.github.com/libgit2/#HEAD/group/callback/git_diff_progress_cb

Called before each file comparison.!
!LGitDiffProgressCallback methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (LGitDiff *diff_so_far, String old_path, String new_path, void *payload))! !

!LGitDiffProgressCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (LGitDiff *diff_so_far, String old_path, String new_path, void *payload))! !

!LGitDiffSimilarityMetric methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_file_signature
	"This method was automatically generated"
	^LGitFileSignatureCallback forAddress: ((handle pointerAt: OFFSET_PRIM_FILE_SIGNATURE) asInteger)! !

!LGitDiffSimilarityMetric methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_buffer_signature: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_BUFFER_SIGNATURE
		put: (anObject 
			ifNotNil: [ ExternalAddress fromAddress: anObject thunk address ]
			ifNil: [ ExternalAddress null ])! !

!LGitDiffSimilarityMetric methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free_signature: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_FREE_SIGNATURE
		put: (anObject 
			ifNotNil: [ ExternalAddress fromAddress: anObject thunk address ]
			ifNil: [ ExternalAddress null ])! !

!LGitDiffSimilarityMetric methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_similarity: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_SIMILARITY
		put: (anObject 
			ifNotNil: [ ExternalAddress fromAddress: anObject thunk address ]
			ifNil: [ ExternalAddress null ])! !

!LGitDiffSimilarityMetric methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_PAYLOAD put: anObject getHandle.! !

!LGitDiffSimilarityMetric methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_PAYLOAD) type: ExternalType void asPointerType! !

!LGitDiffSimilarityMetric methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_file_signature: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_FILE_SIGNATURE
		put: (anObject 
			ifNotNil: [ ExternalAddress fromAddress: anObject thunk address ]
			ifNil: [ ExternalAddress null ])! !

!LGitDiffSimilarityMetric methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_similarity
	"This method was automatically generated"
	^LGitSimilarityCallback forAddress: ((handle pointerAt: OFFSET_PRIM_SIMILARITY) asInteger)! !

!LGitDiffSimilarityMetric methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free_signature
	"This method was automatically generated"
	^LGitFreeSignatureCallback forAddress: ((handle pointerAt: OFFSET_PRIM_FREE_SIGNATURE) asInteger)! !

!LGitDiffSimilarityMetric methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_buffer_signature
	"This method was automatically generated"
	^LGitBufferSignatureCallback forAddress: ((handle pointerAt: OFFSET_PRIM_BUFFER_SIGNATURE) asInteger)! !

!LGitDiffSimilarityMetric class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
"
int (*file_signature)(
		void **out, const git_diff_file *file,
		const char *fullpath, void *payload);
	int (*buffer_signature)(
		void **out, const git_diff_file *file,
		const char *buf, size_t buflen, void *payload);
	void (*free_signature)(void *sig, void *payload);
	int (*similarity)(int *score, void *siga, void *sigb, void *payload);
	void *payload;
"
	^#(
	LGitFileSignatureCallback file_signature;
	LGitBufferSignatureCallback buffer_signature;
	LGitFreeSignatureCallback free_signature;
	LGitSimilarityCallback similarity;
	void *payload;
	)! !

!LGitDiffStats commentStamp: 'TorstenBergmann 6/2/2021 22:22'!
See [https://libgit2.org/libgit2/#HEAD/group/diff](https://libgit2.org/libgit2/#HEAD/group/diff)!
!LGitDiffStats methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_stats_files_changed: stats
	
	^ self
		ffiCallSafely: #(size_t git_diff_stats_files_changed #(self))
		options: #()! !

!LGitDiffStats methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_stats_deletions: stats
	
	^ self
		ffiCallSafely: #(size_t git_diff_stats_deletions #(self))
		options: #()! !

!LGitDiffStats methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_stats_insertions: stats
	
	^ self
		ffiCallSafely: #(size_t git_diff_stats_insertions #(self))
		options: #()! !

!LGitDiffStats methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_stats_to_buf: out stats: stats format: format width: width
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_diff_stats_to_buf #(LGitBuffer out , self , LGitDiffStatsFormatTypeEnum format , size_t width))
		options: #()! !

!LGitDiffStats class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_stats_free: handle
	
	^ self ffiCallSafely: #(void git_diff_stats_free #(void *handle)) options: #()! !

!LGitDiffStats class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #diff_stats_free:! !

!LGitDiffStatsFormatTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_stats_short
	^ self basicNew
		value: 2;
		yourself! !

!LGitDiffStatsFormatTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_stats_include_summary
	^ self basicNew
		value: 8;
		yourself! !

!LGitDiffStatsFormatTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	"No stats"
	GIT_DIFF_STATS_NONE 0

	"Full statistics equivalent of `--stat`"
	GIT_DIFF_STATS_FULL 1

	"Short statistics equivalent of `--shortstat`"
	GIT_DIFF_STATS_SHORT 2

	"Number statistics equivalent of `--numstat`"
	GIT_DIFF_STATS_NUMBER 4

	"Extended header information such as creations renames and mode changes equivalent of `--summary`"
	GIT_DIFF_STATS_INCLUDE_SUMMARY 8
	)! !

!LGitDiffStatsFormatTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_stats_number
	^ self basicNew
		value: 4;
		yourself! !

!LGitDiffStatsFormatTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_stats_full
	^ self basicNew
		value: 1;
		yourself! !

!LGitDiffStatsFormatTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_stats_none
	^ self basicNew
		value: 0;
		yourself! !

!LGitDirectionEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_direction_push
	^ self basicNew
		value: 1;
		yourself! !

!LGitDirectionEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_direction_fetch
	^ self basicNew
		value: 0;
		yourself! !

!LGitDirectionEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_DIRECTION_FETCH 0
	GIT_DIRECTION_PUSH 1
)! !

!LGitError commentStamp: 'TorstenBergmann 6/2/2021 22:42'!
Error structure for git!
!LGitError methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_klass: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_KLASS put: anObject value! !

!LGitError methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_klass
	"This method was automatically generated"
	^LGitErrorTypeEnum fromInteger: (handle signedLongAt: OFFSET_PRIM_KLASS)! !

!LGitError methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_message: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_MESSAGE put: anObject getHandle.! !

!LGitError methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
message
	^ self isNull
		ifFalse: [ self prim_message readStringUTF8 ]
		ifTrue: [ 'no error message set by libgit2' ]! !

!LGitError methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
type
	^ self isNull
		ifFalse: [ self prim_klass ]
		ifTrue: [ nil ]! !

!LGitError methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_message
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_MESSAGE) type: ExternalType char asPointerType! !

!LGitError class methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
setError: aString
	self giterr_set_str: aString! !

!LGitError class methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
last
	| externalData |
	externalData := self giterr_last.
	^ self fromHandle: externalData getHandle! !

!LGitError class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
giterr_clear
	^ self ffiCallSafely: #(void giterr_clear()) options: #(  )! !

!LGitError class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
giterr_set_str: string
	"GIT_EUSER = -7"
	^ self ffiCallSafely: #(void giterr_set_str(-7, String string))! !

!LGitError class methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
lastMessage
	^ self last message! !

!LGitError class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
giterr_last
	^ self ffiCallSafely: #(void *giterr_last()) options: #(  )! !

!LGitError class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
	String message;
	LGitErrorTypeEnum klass;
	)! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_os
	^ self basicNew
		value: 2;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_rebase
	^ self basicNew
		value: 29;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_ssl
	^ self basicNew
		value: 16;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_regex
	^ self basicNew
		value: 8;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_nomemory
	^ self basicNew
		value: 1;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_config
	^ self basicNew
		value: 7;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_odb
	^ self basicNew
		value: 9;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_invalid
	^ self basicNew
		value: 3;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_object
	^ self basicNew
		value: 11;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_tag
	^ self basicNew
		value: 13;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_zlib
	^ self basicNew
		value: 5;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_net
	^ self basicNew
		value: 12;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_indexer
	^ self basicNew
		value: 15;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_index
	^ self basicNew
		value: 10;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_cherrypick
	^ self basicNew
		value: 27;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_revert
	^ self basicNew
		value: 25;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_describe
	^ self basicNew
		value: 28;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_fetchhead
	^ self basicNew
		value: 21;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_filter
	^ self basicNew
		value: 24;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_tree
	^ self basicNew
		value: 14;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_reference
	^ self basicNew
		value: 4;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_callback
	^ self basicNew
		value: 26;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_none
	^ self basicNew
		value: 0;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_checkout
	^ self basicNew
		value: 20;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_stash
	^ self basicNew
		value: 19;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^ #(
		GITERR_NONE 0
		GITERR_NOMEMORY		1
		GITERR_OS				2
		GITERR_INVALID		3	
		GITERR_REFERENCE		4
		GITERR_ZLIB			5
		GITERR_REPOSITORY	6
		GITERR_CONFIG	7
		GITERR_REGEX	8
		GITERR_ODB	9
		GITERR_INDEX			10
		GITERR_OBJECT			11
		GITERR_NET				12
		GITERR_TAG			13
		GITERR_TREE			14
		GITERR_INDEXER		15
		GITERR_SSL				16
		GITERR_SUBMODULE	17
		GITERR_THREAD		18
		GITERR_STASH			19
		GITERR_CHECKOUT		20
		GITERR_FETCHHEAD	21
		GITERR_MERGE			22
		GITERR_SSH	23
		GITERR_FILTER 24
		GITERR_REVERT	25
		GITERR_CALLBACK	26
		GITERR_CHERRYPICK	27
		GITERR_DESCRIBE	28
		GITERR_REBASE	29
		GITERR_FILESYSTEM	30)! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_filesystem
	^ self basicNew
		value: 30;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_submodule
	^ self basicNew
		value: 17;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_repository
	^ self basicNew
		value: 6;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_merge
	^ self basicNew
		value: 22;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_ssh
	^ self basicNew
		value: 23;
		yourself! !

!LGitErrorTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
giterr_thread
	^ self basicNew
		value: 18;
		yourself! !

!LGitExternalArray commentStamp: 'MaxLeske 7/14/2015 09:09'!
I provide general implementations for my subclasses that represent dedicated arrays of a certain type.!
!LGitExternalArray class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
onAddress: handle size: numberOfElements

	^ self fromHandle: handle type: self type size: numberOfElements! !

!LGitExternalArray class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
externalNew: numberOfElements

	^ self 
		externalNewType: self type 
		size: numberOfElements! !

!LGitExternalArray class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
type

	^ self subclassResponsibility! !

!LGitExternalCommitArray commentStamp: 'MaxLeske 7/13/2015 17:10'!
I represent an external array of commits.!
!LGitExternalCommitArray methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
at: anIndex put: aLGitCommit
	^ super at: anIndex put: aLGitCommit getHandle! !

!LGitExternalCommitArray methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
at: anIndex
	^ LGitCommit fromHandle: (super at: anIndex)! !

!LGitExternalCommitArray class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromCollection: aCollection

	| instance |
	instance := self externalNew: aCollection size.
	aCollection withIndexDo: [ :commit :index |
		instance at: index put: commit ].
	
	^ instance! !

!LGitExternalCommitArray class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
type 
	^ LGitCommit! !

!LGitExternalEnumerationInt32 commentStamp: 'TorstenBergmann 6/2/2021 23:18'!
Exernal enum for git based on In32!
!LGitExternalEnumerationInt32 class methodsFor: 'accessing - defaults' stamp: ' 1/5/2022 21:01:26'!
defaultRepresentationType

	^ FFIInt32 new! !

!LGitExternalEnumerationUInt32 commentStamp: 'MaxLeske 3/17/2014 13:57'!
See the comment in NBExternalEnumeration. I am a copy of NBExternalEnumeration with the exception that I inherit from Object, not from SharedPool.!
!LGitExternalEnumerationUInt32 methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
value: anInteger

	value := anInteger! !

!LGitExternalEnumerationUInt32 methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
= anEnumInst

	^ self class == anEnumInst class and: [
		self value = anEnumInst value ]! !

!LGitExternalEnumerationUInt32 methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
hash

	^ self className hash bitXor: self value hash! !

!LGitExternalEnumerationUInt32 methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
symbol
	<todo: 'now we can handle enums which define the same value multiple times, but in case of this handler, we don''t know which name we need to associate with the return value. This is basically random...'>
	
	^ self class declaration
		keyAtValue: self value
		ifAbsent: [ nil ]! !

!LGitExternalEnumerationUInt32 methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isPartOfBitFlag: anInteger
	"A bit flag may be composed of several values, where every bit
	represents the state of one flag. Therefore, a 2 bit value can
	represent 2 different flags, for instance. The #bitAnd: operation
	will mask all other flags.
	
	For some reason the libgit2 folks thought it would make sense to
	use flags of value 0 in bit flags. That forces one to check for zero
	(on the entire word)	explicitly. WTF."
		
	^ self value isZero
		ifTrue: [ anInteger isZero ]
		ifFalse: [ (self value bitAnd: anInteger) = self value ]! !

!LGitExternalEnumerationUInt32 methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
printOn: stream

	super printOn: stream.

	value isInteger 		" temp: due to a uffi bug (?) sometimes value == self"
		ifFalse: [ ^ self ].

	stream nextPut: $(;
		nextPutAll: self symbol asString;
		nextPutAll: ' [';
		nextPutAll: self value asString;
		nextPut: $];
		nextPut: $)! !

!LGitExternalEnumerationUInt32 methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
value

	^ value! !

!LGitExternalEnumerationUInt32 class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
makeSelectorsLegalIn: aDictionary

	aDictionary associationsDo: [ :nameToValue |
		| selector |
		selector := nameToValue key asLowercase asSymbol.
		nameToValue key: selector ]! !

!LGitExternalEnumerationUInt32 class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
new

	^ self shouldNotImplement! !

!LGitExternalEnumerationUInt32 class methodsFor: 'class initialization' stamp: ' 1/5/2022 21:01:26'!
buildDeclaration
	| dictionary |
	self removeOldAccessors.
	dictionary := self literalDeclaration.
	self compileAccessorsFrom: dictionary.
	
	^ declaration := dictionary! !

!LGitExternalEnumerationUInt32 class methodsFor: 'converting' stamp: ' 1/5/2022 21:01:26'!
asExternalTypeOn: generator

	^ FFIExternalEnumerationType 
		objectClass: self 
		representationType: self representationType! !

!LGitExternalEnumerationUInt32 class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromInteger: anInteger

	^self basicNew
		value: anInteger;
		yourself! !

!LGitExternalEnumerationUInt32 class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
includes: aSymbol

	^ self declaration includesKey: aSymbol! !

!LGitExternalEnumerationUInt32 class methodsFor: 'class initialization' stamp: ' 1/5/2022 21:01:26'!
initialize

	declaration := nil.
	representationType := nil! !

!LGitExternalEnumerationUInt32 class methodsFor: 'class initialization' stamp: ' 1/5/2022 21:01:26'!
removeOldAccessors

	declaration ifNil: [ ^ self ].
	
	declaration keysDo: [ :selector |
		self class removeSelector: selector ]! !

!LGitExternalEnumerationUInt32 class methodsFor: 'class initialization' stamp: ' 1/5/2022 21:01:26'!
compileAccessorsFrom: aDictionary

	aDictionary keysAndValuesDo: [ :symbol :value |
		self class
			compile: (String streamContents: [ :stream |
				stream
					nextPutAll: symbol asString; cr; tab;
					nextPutAll: '^ self basicNew'; cr; tab; tab;
					nextPutAll: 'value: ';
					nextPutAll: value asString;
					nextPutAll: ';'; cr; tab; tab;
					nextPutAll: 'yourself' ])
			classified: 'accessing - values' ]! !

!LGitExternalEnumerationUInt32 class methodsFor: 'accessing - defaults' stamp: ' 1/5/2022 21:01:26'!
defaultRepresentationType
	^ FFIUInt32 new! !

!LGitExternalEnumerationUInt32 class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
representationType

	^ representationType ifNil: [ 
		  representationType := self defaultRepresentationType ]! !

!LGitExternalEnumerationUInt32 class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
literalDeclaration

	| dictionary |
	dictionary := self enumDecl in: [ :decl |
		decl isDictionary
			ifTrue: [ decl ]
			ifFalse: [ Dictionary newFromPairs: decl ] ].
		
	self makeSelectorsLegalIn: dictionary.
	^ dictionary! !

!LGitExternalEnumerationUInt32 class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl

	^ #()! !

!LGitExternalEnumerationUInt32 class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
declaration
	^ declaration ifNil: [ declaration := self literalDeclaration ]! !

!LGitExternalObject commentStamp: 'TorstenBergmann 6/2/2021 23:18'!
External object for libgit!
!LGitExternalObject methodsFor: 'initialize-release' stamp: ' 1/5/2022 21:01:26'!
free

	handle isExternalAddress ifFalse: [ ^ self ].
	self class finalizeResourceData: handle.
	self assert: handle isNull! !

!LGitExternalObject methodsFor: 'signalling' stamp: ' 1/5/2022 21:01:26'!
signalIfNotReady

	self ifNotReady: [ self signalNotReady ]! !

!LGitExternalObject methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibrary

	^ self class ffiLibrary! !

!LGitExternalObject methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiNull

	^ FFIExternalObject null! !

!LGitExternalObject methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibraryName

	^ self class ffiLibraryName! !

!LGitExternalObject methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
ifNotReady: aBlock
	"Use extra block so compiler can optimize"

	self isReady ifFalse: [ aBlock value ]! !

!LGitExternalObject methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
printOn: aStream

	| title |
	title := self class name.
	aStream
		nextPutAll: (title first isVowel ifTrue: [ 'an ' ] ifFalse: [ 'a ' ]);
		nextPutAll: title.
		
	(self shouldContinuePrintingOn: aStream) ifFalse: [ ^ self ].
	
	aStream nextPutAll: ' ('.
	self objectPrintOn: aStream.
	aStream nextPut: $)! !

!LGitExternalObject methodsFor: 'argument validation' stamp: ' 1/5/2022 21:01:26'!
validate: anObject shouldBe: aClass

	self class validate: anObject shouldBe: aClass! !

!LGitExternalObject methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isReady

	^ self isNull not! !

!LGitExternalObject methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec options: options
	<ffiCalloutTranslator>

	^ self ffiCall: fnSpec options: options! !

!LGitExternalObject methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
shouldContinuePrintingOn: aStream

	self ifNotReady: [ aStream nextPutAll: ' (<not initialized>)' ].
	
	^ self isReady! !

!LGitExternalObject methodsFor: 'signalling' stamp: ' 1/5/2022 21:01:26'!
signalNotReady

	LGitObjectNotInitialized signalWith: self! !

!LGitExternalObject methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec
	<ffiCalloutTranslator>
	
	^ self ffiCall: fnSpec! !

!LGitExternalObject methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream! !

!LGitExternalObject methodsFor: 'exit code handling' stamp: ' 1/5/2022 21:01:26'!
withReturnHandlerDo: callBlock

	^ callBlock value handleLGitReturnCode! !

!LGitExternalObject class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!LGitExternalObject class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!LGitExternalObject class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!LGitExternalObject class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!LGitExternalObject class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!LGitExternalObject class methodsFor: 'argument validation' stamp: ' 1/5/2022 21:01:26'!
validate: anObject shouldBe: aClass
	"I allow for nil values."
	(anObject isNil or: [ anObject isKindOf: aClass ])
		ifFalse: [ LGitIllegalArgument signalWith: anObject shouldBe: aClass ]! !

!LGitExternalObject class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!LGitExternalObject class methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec
	<ffiCalloutTranslator>
	
	^ self ffiCall: fnSpec! !

!LGitExternalObject class methodsFor: 'finalization' stamp: ' 1/5/2022 21:01:26'!
finalizeResourceData: aHandle
	"Call the class specific free frunction if aHandle is still a valid external address."
	aHandle isNull ifTrue: [ ^self ].
	self perform: self freeFunctionSelector with: aHandle.
	aHandle beNull! !

!LGitExternalObject class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
object_free: handle 
	"We pass a handle in here instead of the object. We can't pass the object since that
	has already been gc'ed."
	^self ffiCallSafely: #(void git_object_free(void *handle)) options: #(  )! !

!LGitExternalObject class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!LGitExternalObject class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!LGitExternalObject class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibrary
	^LGitLibrary uniqueInstance! !

!LGitExternalObject class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!LGitExternalObject class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!LGitExternalObject class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!LGitExternalObject class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!LGitExternalObject class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!LGitExternalObject class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #object_free:! !

!LGitExternalObject class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!LGitExternalObject class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!LGitExternalObject class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!LGitExternalObject class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!LGitExternalObject class methodsFor: 'exit code handling' stamp: ' 1/5/2022 21:01:26'!
withReturnHandlerDo: callBlock
	^ callBlock value handleLGitReturnCode! !

!LGitExternalObject class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!LGitExternalObject class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!LGitExternalObject class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibraryName
	^self ffiLibrary libraryName! !

!LGitExternalObject class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!LGitExternalObject class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!LGitExternalObject class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!LGitExternalObject class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!LGitExternalObject class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!LGitExternalObject class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!LGitExternalObject class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!LGitExternalObject class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!LGitExternalObject class methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec options: options
	<ffiCalloutTranslator>

	^ self ffiCall: fnSpec options: options! !

!LGitExternalObject class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!LGitExternalObject class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!LGitExternalObject class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromHandle: aHandle
	^self basicNew setHandle: aHandle! !

!LGitExternalStringArray commentStamp: 'MaxLeske 7/13/2015 17:12'!
I represent an external array of strings. Since strings are of variable size, they can not be easily represented by the general implementation.
I take care of converting regular strings to external ones (which allocates and reserves the memory) and reading strings from memory.

I override #free to ensure that the memory for the external strings is correctly freed.!
!LGitExternalStringArray methodsFor: 'initialize-release' stamp: ' 1/5/2022 21:01:26'!
free
	1 to: self size do: [ :index | 
		(self primAt: index) free ].
	
	super free! !

!LGitExternalStringArray methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
at: index put: aString
	^ super at: index put: aString asLGitExternalString getHandle! !

!LGitExternalStringArray methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
primAt: anInteger
	^ super at: anInteger! !

!LGitExternalStringArray methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
at: anInteger
	^ (self primAt: anInteger) readStringUTF8! !

!LGitExternalStringArray class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromCollection: aCollection

	| instance |
	instance := self externalNew: aCollection size.
	aCollection withIndexDo: [ :element :index |
		instance at: index put: element ].
	
	^ instance! !

!LGitExternalStringArray class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
type

	^ 'char*'! !

!LGitExternalStructure commentStamp: 'MaxLeske 3/1/2015 20:36'!
Important: structs in libgit2 are usually freed by libgit2 itself.
	We therefore disable freeing of structs during GC to prevent invalid
	memory accesses. However, users of any struct need to make sure that
	they free the struct (using a manual #free send) iff it is necessary.
	Otherwise the structs will leak and we can't reclaim the space once the
	object representing the struct has been collected!
!LGitExternalStructure methodsFor: 'initialize-release' stamp: ' 1/5/2022 21:01:26'!
free

	(handle isExternalAddress and: [ handle isNull not ])
		ifTrue: [ 
			self class finalizeResourceData: handle.
			self assert: handle isNull ]! !

!LGitExternalStructure methodsFor: 'signalling' stamp: ' 1/5/2022 21:01:26'!
signalIfNotReady

	self ifNotReady: [ self signalNotReady ]! !

!LGitExternalStructure methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibrary

	^ self class ffiLibrary! !

!LGitExternalStructure methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiNull

	^ FFIExternalObject null! !

!LGitExternalStructure methodsFor: 'initialize-release' stamp: ' 1/5/2022 21:01:26'!
autoRelease
	"Some LGit structures need specialised free functions. Use the same autoRelease functionality
	as FFIExternalReference to achieve this.

	Note: subclasses should implement #resourceData
	and #finalizeResourceData: on class side"
	
	FFIExternalResourceManager addResource: self! !

!LGitExternalStructure methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isExternal
	"answer true if data referenced by receiver located in external heap, or just in object memory "
	^ handle notNil and: [
		handle isExternalAddress ]! !

!LGitExternalStructure methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibraryName

	^ self class ffiLibraryName! !

!LGitExternalStructure methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
ifNotReady: aBlock
	"Use extra block so compiler can optimize"

	self isReady ifFalse: [ aBlock value ]! !

!LGitExternalStructure methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
printOn: aStream

	| title |
	title := self class name.
	aStream
		nextPutAll: (title first isVowel ifTrue: [ 'an ' ] ifFalse: [ 'a ' ]);
		nextPutAll: title.
		
	(self shouldContinuePrintingOn: aStream) ifFalse: [ ^ self ].
	
	aStream nextPutAll: ' ('.
	self objectPrintOn: aStream.
	aStream nextPut: $)! !

!LGitExternalStructure methodsFor: 'argument validation' stamp: ' 1/5/2022 21:01:26'!
validate: anObject shouldBe: aClass

	self class validate: anObject shouldBe: aClass! !

!LGitExternalStructure methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isReady

	^ true! !

!LGitExternalStructure methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec options: options
	<ffiCalloutTranslator>

	^ self ffiCall: fnSpec options: options! !

!LGitExternalStructure methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
shouldContinuePrintingOn: aStream

	^ true! !

!LGitExternalStructure methodsFor: 'initialize-release' stamp: ' 1/5/2022 21:01:26'!
resourceData

	^ self getHandle! !

!LGitExternalStructure methodsFor: 'signalling' stamp: ' 1/5/2022 21:01:26'!
signalNotReady

	LGitObjectNotInitialized signalWith: self! !

!LGitExternalStructure methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec
	<ffiCalloutTranslator>
	
	^ self ffiCall: fnSpec! !

!LGitExternalStructure methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream! !

!LGitExternalStructure methodsFor: 'exit code handling' stamp: ' 1/5/2022 21:01:26'!
withReturnHandlerDo: callBlock

	^ callBlock value handleLGitReturnCode! !

!LGitExternalStructure class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!LGitExternalStructure class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!LGitExternalStructure class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!LGitExternalStructure class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!LGitExternalStructure class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!LGitExternalStructure class methodsFor: 'argument validation' stamp: ' 1/5/2022 21:01:26'!
validate: anObject shouldBe: aClass
	"I allow for nil values."
	(anObject isNil or: [ anObject isKindOf: aClass ])
		ifFalse: [ LGitIllegalArgument signalWith: anObject shouldBe: aClass ]! !

!LGitExternalStructure class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!LGitExternalStructure class methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec
	<ffiCalloutTranslator>
	
	^ self ffiCall: fnSpec! !

!LGitExternalStructure class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
finalizeResourceData: aHandle
	"Call the class specific free frunction if aHandle is still a valid external address."
	aHandle isNull ifTrue: [ ^self ].
	self perform: self freeFunctionSelector with: aHandle.
	aHandle beNull! !

!LGitExternalStructure class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!LGitExternalStructure class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!LGitExternalStructure class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibrary
	^LGitLibrary uniqueInstance! !

!LGitExternalStructure class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!LGitExternalStructure class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!LGitExternalStructure class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!LGitExternalStructure class methodsFor: 'managing accessors' stamp: ' 1/5/2022 21:01:26'!
removeAccessor: aSelector
	self package removeMethod: (self
		compiledMethodAt: aSelector
		ifAbsent: [ ^ self ]).
		
	^ super removeAccessor: aSelector! !

!LGitExternalStructure class methodsFor: 'managing accessors' stamp: ' 1/5/2022 21:01:26'!
createAccessorsFor: fieldName 
	"Define read/write accessors for the given field"
	| code |

	code := fieldName,'
	"This method was automatically generated"
	<primitive: #primitiveNativeCall module: #NativeBoostPlugin error: errorCode>
	
	^ self fieldAt: ' , fieldName printString.
	Author useAuthor: 'NativeBoost' during: [ 
		| selector |
		selector := self compileSilently: code classified: (self protocolForField: fieldName).
		self package addMethod: (self compiledMethodAt: selector) ].
	
	code := fieldName,': anObject
	"This method was automatically generated"
	<primitive: #primitiveNativeCall module: #NativeBoostPlugin error: errorCode>
	
	^ self fieldAt: ' , fieldName printString , ' put: anObject'.
	Author useAuthor: 'NativeBoost' during: [ 
		| selector |
		selector := self compileSilently: code classified: (self protocolForField: fieldName).
		self package addMethod: (self compiledMethodAt: selector) ]! !

!LGitExternalStructure class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!LGitExternalStructure class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!LGitExternalStructure class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #free:! !

!LGitExternalStructure class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!LGitExternalStructure class methodsFor: 'managing accessors' stamp: ' 1/5/2022 21:01:26'!
protocolForField: aString
	^ self fieldNamesAndProtocols
		at: aString
		ifAbsent: [ 'libgit-fields' ]! !

!LGitExternalStructure class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!LGitExternalStructure class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!LGitExternalStructure class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!LGitExternalStructure class methodsFor: 'exit code handling' stamp: ' 1/5/2022 21:01:26'!
withReturnHandlerDo: callBlock
	^ callBlock value handleLGitReturnCode! !

!LGitExternalStructure class methodsFor: 'managing accessors' stamp: ' 1/5/2022 21:01:26'!
fieldNamesAndProtocols
	^ Dictionary new! !

!LGitExternalStructure class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromExternalAddress: anAddress
	anAddress isNull
		ifTrue: [ ^ nil ].
	^ self fromHandle: anAddress getHandle! !

!LGitExternalStructure class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!LGitExternalStructure class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
free: aHandle
	aHandle free! !

!LGitExternalStructure class methodsFor: 'managing accessors' stamp: ' 1/5/2022 21:01:26'!
generatedFieldProtocolName
	^ 'libgit-fields'! !

!LGitExternalStructure class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!LGitExternalStructure class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibraryName
	^self ffiLibrary libraryName! !

!LGitExternalStructure class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!LGitExternalStructure class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!LGitExternalStructure class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!LGitExternalStructure class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!LGitExternalStructure class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!LGitExternalStructure class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!LGitExternalStructure class methodsFor: 'managing accessors' stamp: ' 1/5/2022 21:01:26'!
fieldSpec
	^ LGitExternalStructureFieldParser new  
		parseFields: self fieldsDesc structure: self.! !

!LGitExternalStructure class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!LGitExternalStructure class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!LGitExternalStructure class methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec options: options
	<ffiCalloutTranslator>

	^ self ffiCall: fnSpec options: options! !

!LGitExternalStructure class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!LGitExternalStructure class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!LGitExternalStructureFieldParser commentStamp: 'TorstenBergmann 6/2/2021 21:24'!
Specific field parsing adoptions for git structure!
!LGitExternalStructureFieldParser methodsFor: 'parsing' stamp: ' 1/5/2022 21:01:26'!
parseFields: fields structure: structClass

	| stream type fieldName generator |
	
	stream := fields readStream.
	generator := FFICallout new requestor: structClass.

	fieldSpec := FFIExternalStructureFieldSpec new.
	[ stream atEnd ] whileFalse: [ | arity |
		type := generator resolveType: stream next. 
		arity := 0.
		[stream peek = #* ] whileTrue: [
			arity := arity + 1.
			stream next ].
		type pointerArity: arity.
		
		fieldName := ('prim_', stream next) asSymbol.
		fieldName isSymbol ifFalse: [ self error: 'invalid field name'].
		(fieldSpec fieldNames includes: fieldName) ifTrue: [ 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." 

		fieldSpec addField: fieldName type: type. 
	
		stream peek == #';' ifTrue: [ stream next ]].
	
	^ self fieldSpec! !

!LGitExternalUInt8Array commentStamp: 'MaxLeske 7/15/2015 10:31'!
My elements are 8 bit unsigned integers.!
!LGitExternalUInt8Array methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
type 
	^ FFIUInt8! !

!LGitExternalUInt8Array class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
type

	^ FFIUInt32! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_fetchhead: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_UPDATE_FETCHHEAD put: anObject! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CUSTOM_HEADERS put: anObject getHandle length: LGitStringArray byteSize! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_download_tags
	"This method was automatically generated"
	^LGitRemoteAutotagOptionTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_DOWNLOAD_TAGS)! !

!LGitFetchOptionsV02x methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
fetch_init_options: opts version: version
	^ self
		ffiCall: #(LGitReturnCodeEnum git_fetch_init_options(LGitFetchOptionsV02x *opts, LGitOptionsVersionsEnum version))
		options: #(  )! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CALLBACKS put: anObject getHandle length: LGitRemoteCallbacksV02x byteSize! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_PROXY_OPTS put: anObject getHandle length: LGitProxyOptions byteSize! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks
	"This method was automatically generated"
	^ LGitRemoteCallbacksV02x fromHandle: (handle referenceStructAt: OFFSET_PRIM_CALLBACKS length: LGitRemoteCallbacksV02x byteSize)! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_prune: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_PRUNE put: anObject value! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts
	"This method was automatically generated"
	^ LGitProxyOptions fromHandle: (handle referenceStructAt: OFFSET_PRIM_PROXY_OPTS length: LGitProxyOptions byteSize)! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers
	"This method was automatically generated"
	^ LGitStringArray fromHandle: (handle referenceStructAt: OFFSET_PRIM_CUSTOM_HEADERS length: LGitStringArray byteSize)! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_prune
	"This method was automatically generated"
	^LGitFetchPruneTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_PRUNE)! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_download_tags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_DOWNLOAD_TAGS put: anObject value! !

!LGitFetchOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_fetchhead
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_UPDATE_FETCHHEAD! !

!LGitFetchOptionsV02x class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
		LGitOptionsVersionsEnum version;

		"
		 * Callbacks to use for this fetch operation
		 "
		#LGitRemoteCallbacksV02x callbacks;

		"
		 * Whether to perform a prune after the fetch
		 "
		LGitFetchPruneTypeEnum prune;

		"
		 * Whether to write the results to FETCH_HEAD. Defaults to
		 * on. Leave this default in order to behave like git.
		 "
		int update_fetchhead;

		"
		 * Determines how to behave regarding tags on the remote, such
		 * as auto-downloading tags for objects we're downloading or
		 * downloading all of them.
		 *
		 * The default is to auto-follow tags.
		 "
		LGitRemoteAutotagOptionTypeEnum download_tags;

		"
	    * Proxy options to use, by default no proxy is used.
	   "
		LGitProxyOptions proxy_opts;

		"
	  	 * Extra headers for this fetch operation
	 	"
		LGitStringArray custom_headers;
	)! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_fetchhead: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_UPDATE_FETCHHEAD put: anObject! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CUSTOM_HEADERS put: anObject getHandle length: LGitStringArray byteSize! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_download_tags
	"This method was automatically generated"
	^LGitRemoteAutotagOptionTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_DOWNLOAD_TAGS)! !

!LGitFetchOptionsV100 methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
fetch_init_options: opts version: version
	^ self
		ffiCall: #(LGitReturnCodeEnum git_fetch_init_options(LGitFetchOptionsV100 *opts, LGitOptionsVersionsEnum version))
		options: #(  )! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CALLBACKS put: anObject getHandle length: LGitRemoteCallbacksV100 byteSize! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_PROXY_OPTS put: anObject getHandle length: LGitProxyOptions byteSize! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks
	"This method was automatically generated"
	^ LGitRemoteCallbacksV100 fromHandle: (handle referenceStructAt: OFFSET_PRIM_CALLBACKS length: LGitRemoteCallbacksV100 byteSize)! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_prune: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_PRUNE put: anObject value! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts
	"This method was automatically generated"
	^ LGitProxyOptions fromHandle: (handle referenceStructAt: OFFSET_PRIM_PROXY_OPTS length: LGitProxyOptions byteSize)! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers
	"This method was automatically generated"
	^ LGitStringArray fromHandle: (handle referenceStructAt: OFFSET_PRIM_CUSTOM_HEADERS length: LGitStringArray byteSize)! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_prune
	"This method was automatically generated"
	^LGitFetchPruneTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_PRUNE)! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_download_tags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_DOWNLOAD_TAGS put: anObject value! !

!LGitFetchOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_fetchhead
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_UPDATE_FETCHHEAD! !

!LGitFetchOptionsV100 class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
		LGitOptionsVersionsEnum version;

		"
		 * Callbacks to use for this fetch operation
		 "
		#LGitRemoteCallbacksV100 callbacks;

		"
		 * Whether to perform a prune after the fetch
		 "
		LGitFetchPruneTypeEnum prune;

		"
		 * Whether to write the results to FETCH_HEAD. Defaults to
		 * on. Leave this default in order to behave like git.
		 "
		int update_fetchhead;

		"
		 * Determines how to behave regarding tags on the remote, such
		 * as auto-downloading tags for objects we're downloading or
		 * downloading all of them.
		 *
		 * The default is to auto-follow tags.
		 "
		LGitRemoteAutotagOptionTypeEnum download_tags;

		"
	    * Proxy options to use, by default no proxy is used.
	   "
		LGitProxyOptions proxy_opts;

		"
	  	 * Extra headers for this fetch operation
	 	"
		LGitStringArray custom_headers;
	)! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_fetchhead: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_UPDATE_FETCHHEAD put: anObject! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CUSTOM_HEADERS put: anObject getHandle length: LGitStringArray byteSize! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_download_tags
	"This method was automatically generated"
	^LGitRemoteAutotagOptionTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_DOWNLOAD_TAGS)! !

!LGitFetchOptionsV120 methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
fetch_init_options: opts version: version
	^ self
		ffiCall: #(LGitReturnCodeEnum git_fetch_init_options(LGitFetchOptionsV120 *opts, LGitOptionsVersionsEnum version))
		options: #(  )! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CALLBACKS put: anObject getHandle length: LGitRemoteCallbacksV120 byteSize! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_PROXY_OPTS put: anObject getHandle length: LGitProxyOptions byteSize! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks
	"This method was automatically generated"
	^ LGitRemoteCallbacksV120 fromHandle: (handle referenceStructAt: OFFSET_PRIM_CALLBACKS length: LGitRemoteCallbacksV120 byteSize)! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_prune: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_PRUNE put: anObject value! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts
	"This method was automatically generated"
	^ LGitProxyOptions fromHandle: (handle referenceStructAt: OFFSET_PRIM_PROXY_OPTS length: LGitProxyOptions byteSize)! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers
	"This method was automatically generated"
	^ LGitStringArray fromHandle: (handle referenceStructAt: OFFSET_PRIM_CUSTOM_HEADERS length: LGitStringArray byteSize)! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_prune
	"This method was automatically generated"
	^LGitFetchPruneTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_PRUNE)! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_download_tags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_DOWNLOAD_TAGS put: anObject value! !

!LGitFetchOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_fetchhead
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_UPDATE_FETCHHEAD! !

!LGitFetchOptionsV120 class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
		LGitOptionsVersionsEnum version;

		"
		 * Callbacks to use for this fetch operation
		 "
		#LGitRemoteCallbacksV120 callbacks;

		"
		 * Whether to perform a prune after the fetch
		 "
		LGitFetchPruneTypeEnum prune;

		"
		 * Whether to write the results to FETCH_HEAD. Defaults to
		 * on. Leave this default in order to behave like git.
		 "
		int update_fetchhead;

		"
		 * Determines how to behave regarding tags on the remote, such
		 * as auto-downloading tags for objects we're downloading or
		 * downloading all of them.
		 *
		 * The default is to auto-follow tags.
		 "
		LGitRemoteAutotagOptionTypeEnum download_tags;

		"
	    * Proxy options to use, by default no proxy is used.
	   "
		LGitProxyOptions proxy_opts;

		"
	  	 * Extra headers for this fetch operation
	 	"
		LGitStringArray custom_headers;
	)! !

!LGitFetchPruneTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_fetch_no_prune
	^ self basicNew
		value: 2;
		yourself! !

!LGitFetchPruneTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_fetch_prune_unspecified
	^ self basicNew
		value: 0;
		yourself! !

!LGitFetchPruneTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^ #(
		"
		 * Use the setting from the configuration
		 "
		GIT_FETCH_PRUNE_UNSPECIFIED 0
		"
		 * Force pruning on
		 "
		GIT_FETCH_PRUNE 1
		"
		 * Force pruning off
		 "
		GIT_FETCH_NO_PRUNE 2
	)! !

!LGitFetchPruneTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_fetch_prune
	^ self basicNew
		value: 1;
		yourself! !

!LGitFileHandle methodsFor: 'public' stamp: ' 1/5/2022 21:01:26'!
binaryReadStream
	^ self readStream! !

!LGitFileHandle methodsFor: 'public' stamp: ' 1/5/2022 21:01:26'!
open

	entry := self basicOpen! !

!LGitFileHandle methodsFor: 'public' stamp: ' 1/5/2022 21:01:26'!
readStream

	^ ZnBufferedReadStream on: (LGitReadStream on: entry object).! !

!LGitFileSignatureCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (void **out, LGitDiffFile *file, String fullpath, void *payload))! !

!LGitFilemodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_filemode_new
	^ self basicNew
		value: 0;
		yourself! !

!LGitFilemodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_filemode_link
	^ self basicNew
		value: 40960;
		yourself! !

!LGitFilemodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_filemode_blob
	^ self basicNew
		value: 33188;
		yourself! !

!LGitFilemodeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_FILEMODE_NEW 0
	GIT_FILEMODE_TREE 16384
	GIT_FILEMODE_BLOB 33188
	GIT_FILEMODE_BLOB_EXECUTABLE 33261
	GIT_FILEMODE_LINK 40960
	GIT_FILEMODE_COMMIT 57344
)! !

!LGitFilemodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_filemode_tree
	^ self basicNew
		value: 16384;
		yourself! !

!LGitFilemodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_filemode_commit
	^ self basicNew
		value: 57344;
		yourself! !

!LGitFilemodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_filemode_blob_executable
	^ self basicNew
		value: 33261;
		yourself! !

!LGitFreeSignatureCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(void (void *sig, void *payload))! !

!LGitFunctionReturn commentStamp: 'TorstenBergmann 6/2/2021 23:09'!
A function as return value!
!LGitFunctionReturn methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
value: anObject
	value := anObject! !

!LGitFunctionReturn methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
methodSelector
	^ methodSelector! !

!LGitFunctionReturn methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
methodSelector: aSymbol
	methodSelector := aSymbol! !

!LGitFunctionReturn methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
value
	^ value! !

!LGitFunctionReturn methodsFor: 'handling' stamp: ' 1/5/2022 21:01:26'!
handleLGitReturnCode
	^ self value handleLGitReturnCode! !

!LGitFunctionReturn class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
methodSelector: aSymbol value: anObject
	^ self new
		methodSelector: aSymbol;
		value: anObject;
		yourself! !

!LGitId commentStamp: '<historical>'!
I'm an unique identity of any object (commit, tree, blob, tag).

https://libgit2.github.com/libgit2/#HEAD/type/git_oid

NOTE: This might be replaces by an FFITypeArray in the future.!
!LGitId methodsFor: 'converting' stamp: ' 1/5/2022 21:01:26'!
asByteArray

	| array id |
	array := ByteArray new: 20.
	id := self prim_id.
	1
		to: id size
		do: [ :index |
			array
				at: index
				put: (id at: index) asInteger ].
			
	^ array! !

!LGitId methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
oid_fmt: aByteArray size: anInteger id: objectId
	"Format a git_oid into a partial hex string"

	^self ffiCall: #(void git_oid_nfmt(void *aByteArray, int anInteger, LGitId * self))! !

!LGitId methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
= anObject

	^ self == anObject
		or: [ self class = anObject class
			and: [ self compare: anObject ] ]! !

!LGitId methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_id
	"This method was automatically generated"
	
	^(FFITypeArray ofType: #FFIUInt8 size: 20) fromHandle: (handle copyFrom: OFFSET_PRIM_ID to: OFFSET_PRIM_ID + 19)! !

!LGitId methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
oid_pathfmt: out id: id

	^ self ffiCallSafely: #(void git_oid_pathfmt(void *out, LGitId * self)) options: #(  )! !

!LGitId methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
asRelativePathString

	| string |
	string := String new: 41.
	string pin.
	self oid_pathfmt: string id: self.
	string unpin.
	^ string! !

!LGitId methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
oid_cmp: a b: b

	^self ffiCallSafely: #(int git_oid_cmp(LGitId * self, LGitId * b)) options: #(  )! !

!LGitId methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
hexString
	"Answer a hex string representation of the receiver"
	
	| buffer |

	self isExternal
		ifFalse: [ ^ handle hex ].
	buffer := ByteArray new: 40.
	buffer pin.
	self oid_fmt: buffer size: 40 id: self.
	buffer unpin.
	^ buffer asString! !

!LGitId methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
compare: anId

	^ (self 
		oid_cmp: self
		b: anId) isZero! !

!LGitId methodsFor: 'converting' stamp: ' 1/5/2022 21:01:26'!
asInteger

	^ self asByteArray asInteger! !

!LGitId methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_id: anObject
	"This method was automatically generated"
	
	handle replaceFrom: OFFSET_PRIM_ID to: OFFSET_PRIM_ID + 19 with: anObject getHandle startingAt: 1! !

!LGitId methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
initializeWithByteArray: aByteArray

	| externalArray |
	externalArray := Byte20 externalNew.
	handle := externalArray getHandle.
	externalArray
		replaceFrom: 1
		to: externalArray size
		with: aByteArray.
	self prim_id: externalArray! !

!LGitId methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
internalize
	"Copy the data of this object over to Smalltalk memory if it is currently external.
	Now we can keep on using this object after the containing object (Blob, Tree or Commit)
	has been freed."
	
	(handle isExternalAddress and: [
		handle isNull not ]) ifFalse: [ ^ self ].
	
	handle := handle
		copyFrom: 1
		to: self class byteSize! !

!LGitId methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream
	aStream nextPutAll: self hexString surroundedBySingleQuotes! !

!LGitId class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromByteArray: aByteArray

	^ self basicNew
		initializeWithByteArray: aByteArray;
		initialize;
		yourself! !

!LGitId class methodsFor: 'class initialization' stamp: ' 1/5/2022 21:01:26'!
initialize

	Byte20 := FFITypeArray
		ofType: 'uint8'
		size: 20! !

!LGitId class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromHexString: aString

	^ self fromByteArray: (ByteArray readHexFrom: aString)! !

!LGitId class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc

	^#(
		Byte20 id
	)! !

!LGitIllegalArgument commentStamp: 'TorstenBergmann 6/2/2021 21:12'!
An illegal argument have been given!
!LGitIllegalArgument methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
expectedClass: anObject
	expectedClass := anObject! !

!LGitIllegalArgument methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
expectedClass
	^ expectedClass! !

!LGitIllegalArgument methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
messageText
	^ 'libgit2 ffi call expects a(n) {1} but instead received {2}'
			format: {self expectedClass. self object}! !

!LGitIllegalArgument class methodsFor: 'signalling' stamp: ' 1/5/2022 21:01:26'!
signalWith: anObject shouldBe: aClass
	^ self new
		object: anObject;
		expectedClass: aClass;
		signal;
		yourself! !

!LGitIndex commentStamp: 'TorstenBergmann 6/2/2021 22:02'!
The Git index is used as a staging area between your working directory and your repository. One can use the index to build up a set of changes thatone wants to commit together.!
!LGitIndex methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
hasEntry: aString

	^ self withReturnHandlerDo: [ 
		self
			index_find: nil
			index: self
			path: aString ]! !

!LGitIndex methodsFor: 'enumerating' stamp: ' 1/5/2022 21:01:26'!
entriesSelect: aBlock

	| entries |
	entries := OrderedCollection new.
	self allFilesStatusDo: [ :path :status :payload |
		(aBlock value: path value: status) ifTrue: [ entries add: {path. status. payload} ].
		0 ].
	
	^ entries! !

!LGitIndex methodsFor: 'enumerating' stamp: ' 1/5/2022 21:01:26'!
allFilesStatusDo: aBlock
	"The callback is passed the path of the file, the status (a combination of the git_status_t values above) and the payload data pointer passed into this function.

If the callback returns a non-zero value, this function will stop looping and return that value to caller."

	self withReturnHandlerDo: [ 
		self
			status_foreach: self repository
			callback: (LGitStatusCallback on: aBlock)
			payload: nil ]! !

!LGitIndex methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
addAll

	| pathspec |
	pathspec := LGitStringArray withAll: #().
	self withReturnHandlerDo: [ 
		self
			index_add_all: self
			pathspec: pathspec
			flags: 0
			callback: (LGitIndexMatchedPathCallback on: [ :a :b :c | 0 ])
			payload: ExternalAddress null ]! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_write

	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_index_write #(self))
		options: #()! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
status_file: status_flags repo: repo path: path
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_status_file #(LGitWriteBackValueUInt status_flags, LGitRepository repo, String path))
		options: #()! !

!LGitIndex methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
entryCount

	^ self index_entrycount: self! !

!LGitIndex methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
hasConflicts

	^ self index_has_conflicts asBoolean! !

!LGitIndex methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
owner

	^ self index_owner! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_update_all: index pathspec: pathspec callback: callback payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_index_update_all #(self, LGitStringArray *pathspec, LGitIndexMatchedPathCallback callback, void *payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_owner

	^ self ffiCallSafely: #(LGitRepository * git_index_owner (LGitIndex self)) options: #()! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_path

	^ self
		ffiCallSafely: #(String git_index_path #(self))
		options: #()! !

!LGitIndex methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
path

	^ self index_path! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_find: at_pos index: index path: path
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_index_find #(LGitWriteBackValueSizeT *at_pos , self, String path))
		options: #(optCoerceNilToNull)! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_add_all: index pathspec: pathspec flags: flags callback: callback payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_index_add_all #(
				self, 
				LGitStringArray *pathspec, 
				uint flags, 
				LGitIndexMatchedPathCallback callback, 
				void *payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_entrycount: index
	
	^ self ffiCallSafely: #(size_t git_index_entrycount #(self)) options: #()! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_read: index force: force
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_index_read #(self , Boolean force))
		options: #()! !

!LGitIndex methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isDirty: aFileReference

	| intValue |
	intValue := LGitWriteBackValueInt new.
	self withReturnHandlerDo: [
		self
			status_file: intValue
			repo: self repository
			path: ((aFileReference relativeTo: self repository repositoryReference) printWithDelimiter: $/) ].
		
	^ intValue value isZero not! !

!LGitIndex methodsFor: 'hack' stamp: ' 1/5/2022 21:01:26'!
hackOwner: aRepository
	"There is a bug in version 0.23 of libgit2, the returned index does not have an 
	 owner (a pointer to a repository), as you would expect from the documentation. 
	This breaks libgit encapsulation, and will probably fail if updating to a newer 
	version, but anyway if we migrate this bug should be fixed."
	self flag: #fixMe. "When possible :)"
	"
	NOTE: is Smalltalk wordSize + 1 because the structure is something like: 
	struct git_index {
		git_refcount rc;
 		...
	}
	
	then:
	
	struct git_refcount { 
		git_atomic refcount;
		void *owner;
	}
	
	and finally: 
	git_atomic = int -> 32bits
	git_atomic = int64_t -> 64bits
	
	So we need to ensure the owner is set properly.
	"
	self handle 
		pointerAt: Smalltalk wordSize + 1
		put: repository handle! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_has_conflicts 
	^ self ffiCallSafely: #(LGitReturnCodeEnum git_index_has_conflicts #(self)) options: #()! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_write_tree: out index: index
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_index_write_tree #(LGitId * out , self))
		options: #()! !

!LGitIndex methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
checkout

	self withReturnHandlerDo: [ 
		self checkout_index_withOptions: 
			(LGitCheckoutOptions defaults
				checkoutStrategy: LGitCheckoutStrategyEnum git_checkout_force;
				yourself) ]! !

!LGitIndex methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
removeAll

	| pathspec |
	pathspec := LGitStringArray withAll: #().
	self withReturnHandlerDo: [ 
		self
			index_remove_all: self
			pathspec: pathspec
			callback: (LGitIndexMatchedPathCallback on: [ :a :b :c | 0 ])
			payload: nil ]! !

!LGitIndex methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
updateAll

	| pathspec |
	pathspec := LGitStringArray withAll: { '*' }.
	self withReturnHandlerDo: [ 
		self
			index_update_all: self
			pathspec: pathspec
			callback: (LGitIndexMatchedPathCallback on: [ :a :b :c | 0 ])
			payload: nil ]! !

!LGitIndex methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
writeTreeAndReturnOid

	| oid |
	oid := LGitId externalNew.
	self withReturnHandlerDo: [ 
		self
			index_write_tree: oid
			index: self ].
		
	^ oid! !

!LGitIndex methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isBeingTracked: aString

	| intValue |
	(self repository repositoryReference resolve: aString) isDirectory ifTrue: [ ^ true ].
	
	intValue := LGitWriteBackValueUInt new.
	self withReturnHandlerDo: [ 
		self
			status_file: intValue
			repo: self repository
			path: aString ].

	^ (LGitStatusTypeEnum  git_status_wt_new isPartOfBitFlag: intValue value) not! !

!LGitIndex methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
addAll: pathSpecs

	| pathspec |
	pathspec := LGitStringArray withAll: pathSpecs.
	self withReturnHandlerDo: [ 
		self
			index_add_all: self
			pathspec: pathspec
			flags: 0
			callback: (LGitIndexMatchedPathCallback on: [ :a :b :c | 0 ])
			payload: ExternalAddress null ]! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
checkout_index_withOptions: opts

	^ self
		ffiCallSafely: #(LGitReturnCodeEnum 
			git_checkout_index(
				LGitRepository repository, 
				self, 
				LGitCheckoutOptions *opts))
		options: #()! !

!LGitIndex methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
forceRefresh

	self withReturnHandlerDo: [ 
		self
			index_read: self
			force: true ]! !

!LGitIndex methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
writeToDisk

	self withReturnHandlerDo: [ self index_write ]! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_remove_all: index pathspec: pathspec callback: callback payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_index_remove_all #(self, LGitStringArray * pathspec, LGitIndexMatchedPathCallback callback, void *payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitIndex methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
status_foreach: repo callback: callback payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_status_foreach #(LGitRepository repo, LGitStatusCallback callback, void * payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitIndex class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
index_free: handle
	
	^ self ffiCallSafely: #(void git_index_free #(void *handle)) options: #()! !

!LGitIndex class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #index_free:! !

!LGitIndexMatchedPathCallback commentStamp: '<historical>'!
I define a git_index_matched_path_cb.

https://libgit2.github.com/libgit2/#HEAD/group/callback/git_index_matched_path_cb!
!LGitIndexMatchedPathCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (String path, String matched_pathspec, void *payload))! !

!LGitLibrary commentStamp: 'TorstenBergmann 6/2/2021 23:08'!
Libgit2 library!
!LGitLibrary methodsFor: 'accessing - platform' stamp: ' 1/5/2022 21:01:26'!
preMethodBuildContext: sender builder: builder spec: functionSpec

	sender method methodClass isClassSide ifTrue: [ ^ self ].

	(sender method literals includesAnyOf: #(#ffiCallSafely: #ffiCallSafely:options:))
		ifTrue: [  
					builder
						pushReceiver;
						send: #signalIfNotReady]! !

!LGitLibrary methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fetchOptionsStructureClass

	"Find the correct class depending on the libgit version we are using"
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1))
		ifTrue: [ ^ LGitFetchOptionsV02x ].
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1 2))
		ifTrue: [ ^ LGitFetchOptionsV100 ].
		
	^ LGitFetchOptionsV120! !

!LGitLibrary methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
forgetInitializationState

	initialized := nil! !

!LGitLibrary methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
recordInitializationFailure

	initialized := false! !

!LGitLibrary methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
recordInitializationSuccess

	initialized ifNil: [initialized := true]! !

!LGitLibrary methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeLibGit2
	[ self libgit2_init.
	self recordInitializationSuccess ]
		on: Error
		do: [ :ex | 
			self recordInitializationFailure.
			ex pass ]! !

!LGitLibrary methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
libgit2_version: major minor: minor rev: rev
	"Return the version of the libgit2 library being currently used."
	^self ffiCall: #(void git_libgit2_version(LGitWriteBackValueInt major, LGitWriteBackValueInt minor, LGitWriteBackValueInt rev))! !

!LGitLibrary methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
libgit2_shutdown
	^self ffiCall: #(int git_libgit2_shutdown())! !

!LGitLibrary methodsFor: 'accessing - platform' stamp: ' 1/5/2022 21:01:26'!
macModuleName
	| pluginDir |
	pluginDir := Smalltalk vm binary parent / 'Plugins'.
	"We look first for version 1.0.0. If not found, we look for version 0.2x"
	#('libgit2.1.0.0.dylib' 'libgit2.0.25.1.dylib')
		detect: [ :each | (pluginDir / each) exists ] 
		ifFound: [ :libName | ^ (pluginDir / libName) fullName ].

	self error: 'Module not found.'! !

!LGitLibrary methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
shutdownLibGit2
	[ self isInitialized
		ifTrue: [ self libgit2_shutdown ] ]
		ensure: [ self forgetInitializationState ]! !

!LGitLibrary methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
remoteCallbacksStructureClass

	"Find the correct class depending on the libgit version we are using"
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1))
		ifTrue: [ ^ LGitRemoteCallbacksV02x ].
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1 2))
		ifTrue: [ ^ LGitRemoteCallbacksV100 ].

	^ LGitRemoteCallbacksV120! !

!LGitLibrary methodsFor: 'accessing - platform' stamp: ' 1/5/2022 21:01:26'!
unix32LibraryName

	^ FFIUnix32LibraryFinder findAnyLibrary: #(
		"This name is wrong, but some versions of the VM has this library shipped with the bad name"
		'libgit2.1.0.0.so' 
		'libgit2.so.1.0.0' 
		'libgit2.so.1.0' 
		'libgit2.so.0.25.1')! !

!LGitLibrary methodsFor: 'accessing - platform' stamp: ' 1/5/2022 21:01:26'!
unixModuleName

	| pluginDir |
	pluginDir := Smalltalk vm binary parent.
	#('libgit2.so.1.0.0' 'libgit2.so.0.25.1')
		detect: [ :each | (pluginDir / each) exists ] 
		ifFound: [ :libName | ^ (pluginDir / libName) fullName ].

	self error: 'Module not found.'! !

!LGitLibrary methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isVersionLessThan: versionArray
	"checks if the library version is smaller than a version.
	a version array is an array  with the form #(MAJOR) or #(MAJOR MINOR)"
	
	^  self 
		isVersion: self version 
		lessThan: versionArray! !

!LGitLibrary methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
libgit2_features
	"Query compile time options for libgit2."
	
	^self ffiCall: #(int git_libgit2_features())! !

!LGitLibrary methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
version
	"self uniqueInstance version"

	| major minor rev |
	
	major := LGitWriteBackValueInt new.
	minor := LGitWriteBackValueInt new.
	rev := LGitWriteBackValueInt new.
	
	self libgit2_version: major minor: minor rev: rev.
	^Array with: major value with: minor value with: rev value! !

!LGitLibrary methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
pushOptionsStructureClass

	"Find the correct class depending on the libgit version we are using"
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1))
		ifTrue: [ ^ LGitPushOptionsV02x ].
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1 2))
		ifTrue: [ ^ LGitPushOptionsV100 ].
	
	^ LGitPushOptionsV120! !

!LGitLibrary methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
isVersion: version lessThan: versionArray
	"checks if the library version is smaller than a version.
	a version array is an array  with the form #(MAJOR) or #(MAJOR MINOR)"

	versionArray withIndexDo: [ :each :index |
		(version at: index) < each
			ifTrue: [ ^ true ] ].
		
	^ false! !

!LGitLibrary methodsFor: 'accessing - platform' stamp: ' 1/5/2022 21:01:26'!
win32LibraryName

	^ FFIWindowsLibraryFinder findAnyLibrary: #('libgit2-1-0-0.dll' 'libgit2.dll')! !

!LGitLibrary methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
libgit2_init
	^self ffiCall: #(int git_libgit2_init())! !

!LGitLibrary methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isInitialized

	^initialized == true! !

!LGitLibrary methodsFor: 'accessing - platform' stamp: ' 1/5/2022 21:01:26'!
unix64LibraryName

	^ FFIUnix64LibraryFinder findAnyLibrary: #(
		"This name is wrong, but some versions of the VM has this library shipped with the bad name"
		'libgit2.1.0.0.so' 
		'libgit2.so.1.0.0' 
		'libgit2.so.1.0'
		'libgit2.so.1.1'
		'libgit2.so.1.2'
		'libgit2.so.1.3' 
		'libgit2.so.0.25.1')! !

!LGitLibrary methodsFor: 'accessing - platform' stamp: ' 1/5/2022 21:01:26'!
win32ModuleName

	| pluginDir |
	pluginDir := Smalltalk vm binary parent.
	"We look first for version 1.0.0. If not found, we look for version 0.2x"
	#('libgit2-1-0-0.dll' 'libgit2.dll')
		detect: [ :each | (pluginDir / each) exists ] 
		ifFound: [ :libName | ^ (pluginDir / libName) fullName ].
	
	self error: 'Libgit library not found in ', pluginDir pathString! !

!LGitLibrary methodsFor: 'accessing - platform' stamp: ' 1/5/2022 21:01:26'!
macLibraryName

	^ FFIMacLibraryFinder findAnyLibrary: #('libgit2.1.0.1.dylib' 'libgit2.1.0.0.dylib' 'libgit2.0.25.1.dylib')! !

!LGitLibrary class methodsFor: 'class initialization' stamp: ' 1/5/2022 21:01:26'!
initialize
	"Required to reset the Initialized flag on image startup.
	Force libgit initialization since we just installed libgit.
	Otherwise this would cause a libgit crash"
	
	Smalltalk addToStartUpList: self.
	self uniqueInstance initializeLibGit2! !

!LGitLibrary class methodsFor: 'system startup' stamp: ' 1/5/2022 21:01:26'!
shutDown: quitting

	quitting ifFalse: [ ^ self ].
	self uniqueInstance shutdownLibGit2.! !

!LGitLibrary class methodsFor: 'system startup' stamp: ' 1/5/2022 21:01:26'!
startUp: isImageStarting

	isImageStarting ifTrue: [ self uniqueInstance initializeLibGit2 ]! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_metric: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_METRIC put: anObject getHandle.! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_file_favor
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_FILE_FAVOR! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_default_driver: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_DEFAULT_DRIVER put: anObject getHandle.! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_target_limit: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_TARGET_LIMIT put: anObject! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitMergeOptions methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self withReturnHandlerDo: [
		self
			merge_init_options: self
			version: LGitOptionsVersionsEnum git_merge_options_version_1 ]! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_target_limit
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_TARGET_LIMIT! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_FLAGS put: anObject! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_recursion_limit: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_RECURSION_LIMIT put: anObject! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_flags
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_FLAGS! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_rename_threshold
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_RENAME_THRESHOLD! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_file_favor: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_FILE_FAVOR put: anObject! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_file_flags
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_FILE_FLAGS! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_recursion_limit
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_RECURSION_LIMIT! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_file_flags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_FILE_FLAGS put: anObject! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitMergeOptions methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
merge_init_options: opts version: version 
	^ self
		ffiCall: #(int git_merge_init_options(
			LGitMergeOptions * self, 
			LGitOptionsVersionsEnum version))
		options: #()! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_default_driver
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_DEFAULT_DRIVER) type: ExternalType char asPointerType! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_metric
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_METRIC) type: ExternalType void asPointerType! !

!LGitMergeOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_rename_threshold: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_RENAME_THRESHOLD put: anObject! !

!LGitMergeOptions class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	"https://libgit2.github.com/libgit2/#HEAD/type/git_merge_options"
	^#(
		LGitOptionsVersionsEnum version;
		uint32 flags; "Should be: git_merge_flag_t"
		uint rename_threshold;
		uint target_limit;
		void* metric; "Should be: git_diff_similarity_metric *"
		uint recursion_limit;
		String default_driver;
		uint32 file_favor; "Should be: git_merge_favor_flag_t"
		uint32 file_flags; "Should be: git_merge_file_flag_t"
	)! !

!LGitNoCredentialsProvided commentStamp: 'EstebanLorenzano 2/8/2017 16:19'!
I'm an error thrown in callbacks when no credentials has been found.
Callbacks supplying credentials HAVE to throw this error and not one created by themselves (because libgit2 aborts processing with this exception and not with others). !
!LGitNoReturnCodeHandlerDefined commentStamp: 'TorstenBergmann 6/2/2021 21:13'!
A return code handler is missing!
!LGitObject commentStamp: 'TorstenBergmann 6/2/2021 22:04'!
Common superclass for git objects!
!LGitObject methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isBlob

	^ false! !

!LGitObject methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
object

	^ self! !

!LGitObject methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
get_id_data

	^ self object_id: self! !

!LGitObject methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
object_id: obj
	
	^ self
		ffiCallSafely: #(void * git_object_id #(self))
		options: #()! !

!LGitObject methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
object_lookup: object repo: repo id: oid type: type
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_object_lookup #(LGitObject * object , LGitRepository repo , LGitId * oid , LGitObjectTypeEnum type))
		options: #()! !

!LGitObject methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
object_short_id: out
	
	^ self
		ffiCallSafely: #(LGitObjectTypeEnum git_object_short_id(LGitBuf *out, self))
		options: #()! !

!LGitObject methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
type

	^ self object_type: self! !

!LGitObject methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
object_dup: dest from: source
	
	^ self
		ffiCall: #(LGitObjectTypeEnum git_object_dup(LGitObject *dest, LGitObject source))
		options: #()! !

!LGitObject methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isTag

	^ false! !

!LGitObject methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isCommit

	^ false! !

!LGitObject methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isTree

	^ false! !

!LGitObject methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
lookup

	self withReturnHandlerDo: [ self
		object_lookup: self 
		repo: self repository
		id: self id 
		type: LGitObjectTypeEnum git_obj_any ]! !

!LGitObject methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
object_type: obj
	
	^ self
		ffiCallSafely: #(LGitObjectTypeEnum git_object_type #(self))
		options: #()! !

!LGitObject methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
shortId

	| buf shortId |
	buf := LGitBuf new.
	self object_short_id: buf.
	shortId := buf prim_ptr readStringUTF8.
	buf free.
	^ shortId! !

!LGitObject methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream

	self id ifNil: [ ^ self ].
	
	aStream nextPutAll: self id hexString! !

!LGitObject methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
id

	| data |
	(id notNil or: [ self isNull ]) ifTrue: [ ^ id ].

	data := self get_id_data.
	id := LGitId fromHandle: data getHandle.
	id internalize.
	^ id! !

!LGitObject methodsFor: 'converting' stamp: ' 1/5/2022 21:01:26'!
concreteObject

	^ (self class classFor: self type)
		  of: self repository
		  fromId: self id! !

!LGitObject methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
initializeWithId: gitOid

	id := gitOid.
	self lookup! !

!LGitObject class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
object_free: handle 
	^self ffiCallSafely: #(void git_object_free(void *handle)) options: #(  )! !

!LGitObject class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isType: aType
	^ self subclassResponsibility! !

!LGitObject class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #object_free:! !

!LGitObject class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
newFromReference: aReference
	^self of: aReference repository fromId: aReference targetId! !

!LGitObject class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository fromId: id
	^ (self of: aRepository)
		initializeWithId: id;
		yourself! !

!LGitObject class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
classFor: aType
	^ self subclasses detect: [ :class | class isType: aType ]! !

!LGitObjectNotFound commentStamp: 'TorstenBergmann 6/2/2021 21:13'!
An object in git was not found!
!LGitObjectNotInitialized commentStamp: 'TorstenBergmann 6/2/2021 21:13'!
An object in git was not initialized
!
!LGitObjectTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_obj__ext2
	^ self basicNew
		value: 5;
		yourself! !

!LGitObjectTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_obj_tag
	^ self basicNew
		value: 4;
		yourself! !

!LGitObjectTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_obj_blob
	^ self basicNew
		value: 3;
		yourself! !

!LGitObjectTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_obj_ref_delta
	^ self basicNew
		value: 7;
		yourself! !

!LGitObjectTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_obj_tree
	^ self basicNew
		value: 2;
		yourself! !

!LGitObjectTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_obj_ofs_delta
	^ self basicNew
		value: 6;
		yourself! !

!LGitObjectTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_obj__ext1
	^ self basicNew
		value: 0;
		yourself! !

!LGitObjectTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_OBJ_ANY -2
	GIT_OBJ_BAD -1
	GIT_OBJ__EXT1 0
	GIT_OBJ_COMMIT 1
	GIT_OBJ_TREE 2
	GIT_OBJ_BLOB 3
	GIT_OBJ_TAG 4
	GIT_OBJ__EXT2 5
	GIT_OBJ_OFS_DELTA 6
	GIT_OBJ_REF_DELTA 7
)! !

!LGitObjectTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_obj_any
	^ self basicNew
		value: -2;
		yourself! !

!LGitObjectTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_obj_bad
	^ self basicNew
		value: -1;
		yourself! !

!LGitObjectTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_obj_commit
	^ self basicNew
		value: 1;
		yourself! !

!LGitOdb commentStamp: 'TorstenBergmann 6/2/2021 22:11'!
A git Object DB!
!LGitOdb class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #odb_free:! !

!LGitOdb class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
odb_free: handle
	
	^ self ffiCallSafely: #(void git_odb_free #(void *handle)) options: #()! !

!LGitOdbWritepack commentStamp: 'TorstenBergmann 6/2/2021 22:31'!
This class knows how to write the generic presentation of a package, provided by the pack builder, to the object database (odb). 	!
!LGitOdbWritepack methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
free
	self prim_free writepack: self! !

!LGitOdbWritepack methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
appendWithBuffer: anAddress length: anInteger progress: aTransferProgress
	| data callout|
	data := self prim_append.
	callout := LGitWritepackAppendCallout fromHandle: data getHandle.

	^ callout
		writepack: self
		buffer: anAddress
		length: anInteger
		progress: aTransferProgress! !

!LGitOdbWritepack methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_append: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_APPEND put: anObject getHandle.! !

!LGitOdbWritepack methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_commit: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_COMMIT put: anObject getHandle.! !

!LGitOdbWritepack methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_backend: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_BACKEND put: anObject getHandle.! !

!LGitOdbWritepack methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
commitWithProgress: aTransferProgress
	self withReturnHandlerDo: [
		self prim_commit
			writepack: self
			progress: aTransferProgress ]! !

!LGitOdbWritepack methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_append
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_APPEND) type: ExternalType void asPointerType! !

!LGitOdbWritepack methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_commit
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_COMMIT) type: ExternalType void asPointerType! !

!LGitOdbWritepack methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_FREE) type: ExternalType void asPointerType! !

!LGitOdbWritepack methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_free: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_FREE put: anObject getHandle.! !

!LGitOdbWritepack methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
odb_write_pack: out db: db progress_cb: progress_cb progress_payload: progress_payload 
	^ self
		ffiCallSafely: #(#LGitReturnCodeEnum git_odb_write_pack(LGitOdbWritepack * self, LGitOdb db, LGitTransferProgressCallback progress_cb, void * progress_payload))
		options: #( optMayGC optCoerceNilToNull )! !

!LGitOdbWritepack methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_backend
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_BACKEND) type: ExternalType void asPointerType! !

!LGitOdbWritepack class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
	"git_odb_backend *" void *backend; "Using void* because I didn't mapped the structure git_odb_backend"
	LGitWritepackAppendCallout append;
	LGitWritepackCommitCallout commit;
	LGitWritepackFreeCallout free;
	)! !

!LGitOpenFlagEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_repository_open_bare
	^ self basicNew
		value: 4;
		yourself! !

!LGitOpenFlagEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_repository_open_cross_fs
	^ self basicNew
		value: 2;
		yourself! !

!LGitOpenFlagEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_repository_open_no_search
	^ self basicNew
		value: 1;
		yourself! !

!LGitOpenFlagEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_REPOSITORY_OPEN_NO_SEARCH 1
	GIT_REPOSITORY_OPEN_CROSS_FS 2
	GIT_REPOSITORY_OPEN_BARE 4
)! !

!LGitOpeningRepositoryError commentStamp: 'TorstenBergmann 6/2/2021 21:14'!
There was an error opening a git repository!
!LGitOptionsVersionsEnum commentStamp: 'MaxLeske 7/17/2015 13:37'!
I map names to versions for all the option structs.!
!LGitOptionsVersionsEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_checkout_options_version_1
	^ self basicNew
		value: 1;
		yourself! !

!LGitOptionsVersionsEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_merge_options_version_1
	^ self basicNew
		value: 1;
		yourself! !

!LGitOptionsVersionsEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_clone_options_version_1
	^ self basicNew
		value: 1;
		yourself! !

!LGitOptionsVersionsEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_BLAME_OPTIONS_VERSION_1 1
	GIT_CHECKOUT_OPTIONS_VERSION_1 1
	GIT_CLONE_OPTIONS_VERSION_1 1
	GIT_DIFF_OPTIONS_VERSION_1 1
	GIT_DIFF_FIND_OPTIONS_VERSION_1 1
	GIT_FETCH_OPTIONS_VERSION_1 1
	GIT_PUSH_OPTIONS_VERSION_1 1
	)! !

!LGitOptionsVersionsEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_options_version_1
	^ self basicNew
		value: 1;
		yourself! !

!LGitOptionsVersionsEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_push_options_version_1
	^ self basicNew
		value: 1;
		yourself! !

!LGitOptionsVersionsEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_diff_find_options_version_1
	^ self basicNew
		value: 1;
		yourself! !

!LGitOptionsVersionsEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_blame_options_version_1
	^ self basicNew
		value: 1;
		yourself! !

!LGitOptionsVersionsEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_fetch_options_version_1
	^ self basicNew
		value: 1;
		yourself! !

!LGitPackBuilder commentStamp: 'TorstenBergmann 6/2/2021 22:12'!
Builder for a git pack.

See [https://libgit2.org/libgit2/#HEAD/type/git_packbuilder](https://libgit2.org/libgit2/#HEAD/type/git_packbuilder)!
!LGitPackBuilder methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
packbuilder_new: out repo: repo
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_packbuilder_new #(LGitPackBuilder * self , LGitRepository repo))
		options: #()! !

!LGitPackBuilder methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
packbuilder_insert_commit: pb id: id
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_packbuilder_insert_commit #(self , LGitId * id))
		options: #(optMayGC)! !

!LGitPackBuilder methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
packbuilder_insert_tree: pb id: id
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_packbuilder_insert_tree #(self , LGitId * id))
		options: #(optMayGC)! !

!LGitPackBuilder methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
packbuilder_foreach: pb cb: cb payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_packbuilder_foreach #(self , LGitPackbuilderForeachCallback cb ,  void *payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitPackBuilder class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #packbuilder_free:! !

!LGitPackBuilder class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
packbuilder_free: handle
	
	^ self
		ffiCallSafely: #(void git_packbuilder_free #(void *handle))
		options: #()! !

!LGitPackbuilderForeachCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
signature: signature "<String>" block: aBlock "<BlockClosure>"
	super signature: signature block: (self wrapBlock: aBlock)! !

!LGitPackbuilderForeachCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
wrapBlock: aBlock

	^[ :buffer :length :payload |
		aBlock 
			value: buffer 
			value: length
			value: payload ]! !

!LGitPackbuilderForeachCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (void *buffer, int length, void *payload))! !

!LGitPackbuilderForeachPayload methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_writepack: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_WRITEPACK put: anObject getHandle.! !

!LGitPackbuilderForeachPayload methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
stats
	^ self prim_stats! !

!LGitPackbuilderForeachPayload methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
stats: aTransferProgress
	self prim_stats: aTransferProgress! !

!LGitPackbuilderForeachPayload methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
writepack
	^ self prim_writepack! !

!LGitPackbuilderForeachPayload methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_stats
	"This method was automatically generated"
	^LGitTransferProgress fromHandle: (handle pointerAt: OFFSET_PRIM_STATS)! !

!LGitPackbuilderForeachPayload methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_progress_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_PROGRESS_PAYLOAD put: anObject getHandle.! !

!LGitPackbuilderForeachPayload methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_writepack
	"This method was automatically generated"
	^LGitOdbWritepack fromHandle: (handle pointerAt: OFFSET_PRIM_WRITEPACK)! !

!LGitPackbuilderForeachPayload methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_stats: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_STATS put: anObject getHandle.! !

!LGitPackbuilderForeachPayload methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
writepack: aWritepack
	self prim_writepack: aWritepack! !

!LGitPackbuilderForeachPayload methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_progress_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_PROGRESS_PAYLOAD) type: ExternalType void asPointerType! !

!LGitPackbuilderForeachPayload methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_progress_cb
	"This method was automatically generated"
	^LGitTransferProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PROGRESS_CB) asInteger)! !

!LGitPackbuilderForeachPayload methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_progress_cb: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PROGRESS_CB
		put: (anObject 
			ifNotNil: [ ExternalAddress fromAddress: anObject thunk address ]
			ifNil: [ ExternalAddress null ])! !

!LGitPackbuilderForeachPayload class methodsFor: 'field definition' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		LGitTransferProgress *stats;
		LGitTransferProgressCallback *progress_cb;
		void *progress_payload;
		LGitOdbWritepack *writepack;
	)! !

!LGitPackbuilderProgressCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (int stage, uint32 current, uint32 total, void *payload))! !

!LGitPatch commentStamp: 'TorstenBergmann 6/2/2021 22:07'!
A patch in git!
!LGitPatch methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
patch_get_line_in_hunk: out patch: patch hunk_idx: hunk_idx line_of_hunk: line_of_hunk
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_patch_get_line_in_hunk #(LGitDiffLine * out , self , size_t hunk_idx , size_t line_of_hunk))
		options: #()! !

!LGitPatch methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
patch_get_hunk: out lines_in_hunk: lines_in_hunk patch: patch hunk_idx: hunk_idx
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_patch_get_hunk #(
				LGitDiffHunk **out , 
				LGitWriteBackValueSizeT *lines_in_hunk, 
				LGitPatch *patch, 
				size_t hunk_idx))
		options: #()! !

!LGitPatch methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
printDiff
	^ String new: 500 streamContents: [ :stream |
		self printDiffOn: stream ]! !

!LGitPatch methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
fromDiff: aDiff at: anInteger
	"use 1 based offset as in Smalltalk"
	self withReturnHandlerDo: [
		self
			patch_from_diff: self
			diff: aDiff
			idx: anInteger - 1 ].
	self autoRelease! !

!LGitPatch methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
patch_from_buffers: out old_buffer: old_buffer old_len: old_len old_as_path: old_as_path new_buffer: new_buffer new_len: new_len new_as_path: new_as_path opts: opts
	self flag: #todo. "This one doesnt seems to exist anymore. Instead I think it is git_patch_from_blob_and_buffer"
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_patch_from_blobuffers #(LGitPatch * self , FFIVoid * old_buffer , FFIUInt32 old_len , String old_as_path , String new_buffer , FFIUInt32 new_len , String new_as_path , LGitDiffOptions * opts))
		options: #()! !

!LGitPatch methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
patch_print: patch print_cb: print_cb payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_patch_print #(self , LGitDiffLineCallback print_cb , void *payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitPatch methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
printDiffOn: aStream
	| callback |
	callback := LGitDiffLineCallback on: [ :delta :hunk :line :payload |
		aStream nextPutAll: line content. 0 ].
	
	self withReturnHandlerDo: [
		self
			patch_print: self
			print_cb: callback
			payload: nil ]! !

!LGitPatch methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
patch_from_blobs: out old_blob: old_blob old_as_path: old_as_path new_blob: new_blob new_as_path: new_as_path opts: opts
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_patch_from_blobs #(LGitPatch * self , LGitBlob old_blob , String old_as_path , LGitBlob new_blob , String new_as_path , LGitDiffOptions * opts))
		options: #()! !

!LGitPatch methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
hunkAt: anInteger
	| hunk lines |
	hunk := LGitDiffHunk externalNew.
	lines := LGitWriteBackValueSizeT new.
	self withReturnHandlerDo: [
		self
			patch_get_hunk: hunk
			lines_in_hunk: lines patch: self
			hunk_idx: anInteger ].
		
	^ hunk! !

!LGitPatch methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
patch_from_blob_and_buffer: out old_blob: old_blob old_as_path: old_as_path buffer: buffer buffer_len: buffer_len buffer_as_path: buffer_as_path opts: opts
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_patch_from_blob_and_buffer #(LGitPatch * self , LGitBlob old_blob , String old_as_path , String buffer , FFIUInt32 buffer_len , String buffer_as_path , LGitDiffOptions * opts))
		options: #()! !

!LGitPatch methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
patch_get_delta: patch
	
	^ self
		ffiCallSafely: #(LGitDiffDelta * git_patch_get_delta #(self))
		options: #()! !

!LGitPatch methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
patch_from_diff: out diff: diff idx: idx
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_patch_from_diff #(LGitPatch * self , LGitDiff diff , size_t idx))
		options: #()! !

!LGitPatch class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #diff_patch_free:! !

!LGitPatch class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromDiff: aDiff at: anInteger
	^ (self of: aDiff repository)
		fromDiff: aDiff at: anInteger;
		yourself! !

!LGitPatch class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
diff_patch_free: handle
	
	^ self ffiCallSafely: #(void git_patch_free #(void *handle)) options: #()! !

!LGitPathSpec commentStamp: 'TorstenBergmann 6/2/2021 22:12'!
I'm a compiled pathspec (used to match)

See [https://libgit2.github.com/libgit2/#HEAD/type/git_pathspec](https://libgit2.github.com/libgit2/#HEAD/type/git_pathspec)!
!LGitPathSpec methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
createNewWithAll: aCollection
	| strings |
	strings := LGitStringArray withAll: aCollection.
	self withReturnHandlerDo: [
		self
			pathspec_new: self
			with: strings ].
	self autoRelease! !

!LGitPathSpec methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
initializeWithAll: aCollection
	self initialize.
	self createNewWithAll: aCollection! !

!LGitPathSpec methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
pathspec_new: out with: pathspec
	^ self 
		ffiCall: #(int git_pathspec_new(LGitPathSpec *self, LGitStringArray *pathspec))
		options: #()! !

!LGitPathSpec class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
pathspec_free: handle
	^ self ffiCallSafely: #(void git_pathspec_free (void *handle)) options: #()! !

!LGitPathSpec class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
withAll: aCollection
	^ self basicNew 
		initializeWithAll: aCollection;
		yourself! !

!LGitPathSpecFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_pathspec_find_failures
	^ self basicNew
		value: 16;
		yourself! !

!LGitPathSpecFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_pathspec_no_match_error
	^ self basicNew
		value: 8;
		yourself! !

!LGitPathSpecFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_pathspec_failures_only
	^ self basicNew
		value: 32;
		yourself! !

!LGitPathSpecFlagTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_PATHSPEC_DEFAULT 0
	"forces match to ignore case; otherwise match will use native case sensitivity of platform filesystem"
	GIT_PATHSPEC_IGNORE_CASE 1
	"forces case sensitive match; otherwise match will use native case sensitivity of platform filesystem"
	GIT_PATHSPEC_USE_CASE 2
	"disables glob patterns and just uses simple string comparison for matching"
	GIT_PATHSPEC_NO_GLOB 4
	"means the match functions return error code GIT_ENOTFOUND if no matches are found; otherwise no matches is still success (return 0) but git_pathspec_match_list_entrycount will indicate 0 matches."
	GIT_PATHSPEC_NO_MATCH_ERROR 8
	"means that the git_pathspec_match_list should track which patterns matched which files so that at the end of the match we can identify patterns that did not match any files."
	GIT_PATHSPEC_FIND_FAILURES 16
	"means that the git_pathspec_match_list does not need to keep the actual matching filenames. Use this to just test if there were any matches at all or in combination with GIT_PATHSPEC_FIND_FAILURES to validate a pathspec."
	GIT_PATHSPEC_FAILURES_ONLY 32
)! !

!LGitPathSpecFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_pathspec_ignore_case
	^ self basicNew
		value: 1;
		yourself! !

!LGitPathSpecFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_pathspec_no_glob
	^ self basicNew
		value: 4;
		yourself! !

!LGitPathSpecFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_pathspec_use_case
	^ self basicNew
		value: 2;
		yourself! !

!LGitPathSpecFlagTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_pathspec_default
	^ self basicNew
		value: 0;
		yourself! !

!LGitPathSpecMatchList commentStamp: 'TorstenBergmann 6/2/2021 22:20'!
Match list for a git pathspec!
!LGitPathSpecMatchList methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
pathspec_match_diff: out diff: diff flags: flags ps: ps
	
	^ self
		ffiCall:
			#(int git_pathspec_match_diff #(LGitPathSpecMatchList * self , LGitDiff diff , LGitPathSpecFlagTypeEnum flags , LGitPathSpec ps))
		options: #()! !

!LGitPathSpecMatchList methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
pathspec_match_list_diff_entry: m pos: pos
	
	^ self
		ffiCallSafely:
			#(LGitDiffDelta git_pathspec_match_list_diff_entry #(LGitPathSpecMatchList m , size_t pos))
		options: #()! !

!LGitPathSpecMatchList class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
pathspec_match_list_free: handle
	
	^ self
		ffiCallSafely: #(void git_pathspec_match_list_free #(void *handle))
		options: #()! !

!LGitPathSpecMatchList class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #pathspec_match_list_free:! !

!LGitProxyOptions commentStamp: '<historical>'!
/**
 * Options for connecting through a proxy
 *
 * Note that not all types may be supported, depending on the platform
 * and compilation options.
 */!
!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_certificate_check: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_CERTIFICATE_CHECK
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitProxyOptions methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self withReturnHandlerDo: [
		self
			proxy_init_options: self getHandle getHandle
			version: LGitOptionsVersionsEnum git_fetch_options_version_1 ]! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_url: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_URL put: anObject getHandle.! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credentials: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_CREDENTIALS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_PAYLOAD put: anObject getHandle.! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_PAYLOAD) type: ExternalType void asPointerType! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_TYPE put: anObject value! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_certificate_check
	"This method was automatically generated"
	^LGitTransportCertificateCheckCallback forAddress: ((handle pointerAt: OFFSET_PRIM_CERTIFICATE_CHECK) asInteger)! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credentials
	"This method was automatically generated"
	^LGitCredAcquireCallback forAddress: ((handle pointerAt: OFFSET_PRIM_CREDENTIALS) asInteger)! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_url
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_URL) type: ExternalType char asPointerType! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitProxyOptions methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
proxy_init_options: opts version: version
	^ self
		ffiCall: #(LGitReturnCodeEnum git_proxy_init_options(void *handle, LGitOptionsVersionsEnum version))
		options: #(  )! !

!LGitProxyOptions methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_type
	"This method was automatically generated"
	^LGitProxyTypeEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_TYPE)! !

!LGitProxyOptions class methodsFor: 'field definition' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
	LGitOptionsVersionsEnum version;

	"/**
	 * The type of proxy to use, by URL, auto-detect.
	 */"
	LGitProxyTypeEnum type;

	"/**
	 * The URL of the proxy.
	 */"
	String url;

	"/**
	 * This will be called if the remote host requires
	 * authentication in order to connect to it.
	 *
	 * Returning GIT_PASSTHROUGH will make libgit2 behave as
	 * though this field isn't set.
	 */"
	LGitCredAcquireCallback credentials;

	"/**
	 * If cert verification fails, this will be called to let the
	 * user make the final decision of whether to allow the
	 * connection to proceed. Returns 1 to allow the connection, 0
	 * to disallow it or a negative value to indicate an error.
	 */"
   LGitTransportCertificateCheckCallback certificate_check;

	"/**
	 * Payload to be provided to the credentials and certificate
	 * check callbacks.
	 */"
	void *payload;
	)! !

!LGitProxyTypeEnum commentStamp: '<historical>'!
/**
 * The type of proxy to use.
 */!
!LGitProxyTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_proxy_auto
	^ self basicNew
		value: 1;
		yourself! !

!LGitProxyTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_proxy_specified
	^ self basicNew
		value: 2;
		yourself! !

!LGitProxyTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_proxy_none
	^ self basicNew
		value: 0;
		yourself! !

!LGitProxyTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^ #(
	"/**
	 * Do not attempt to connect through a proxy
	 *
	 * If built against libcurl, it itself may attempt to connect
	 * to a proxy if the environment variables specify it.
	 */"
	GIT_PROXY_NONE 0
	"/**
	 * Try to auto-detect the proxy from the git configuration.
	 */"
	GIT_PROXY_AUTO 1
	"/**
	 * Connect via the URL given in the options
	 */"
	GIT_PROXY_SPECIFIED 2
	)! !

!LGitPushNegotiationCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (LGitPushUpdate **updates, size_t len, void *payload))! !

!LGitPushOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_pb_parallelism
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_PB_PARALLELISM! !

!LGitPushOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_pb_parallelism: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_PB_PARALLELISM put: anObject! !

!LGitPushOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitPushOptionsV02x methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
push_init_options: options version: version
	self
		ffiCall: #(LGitReturnCodeEnum git_push_init_options(LGitPushOptionsV02x *options, LGitOptionsVersionsEnum version))
		options: #()! !

!LGitPushOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CUSTOM_HEADERS put: anObject getHandle length: LGitStringArray byteSize! !

!LGitPushOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CALLBACKS put: anObject getHandle length: LGitRemoteCallbacksV02x byteSize! !

!LGitPushOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_PROXY_OPTS put: anObject getHandle length: LGitProxyOptions byteSize! !

!LGitPushOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks
	"This method was automatically generated"
	^ LGitRemoteCallbacksV02x fromHandle: (handle referenceStructAt: OFFSET_PRIM_CALLBACKS length: LGitRemoteCallbacksV02x byteSize)! !

!LGitPushOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts
	"This method was automatically generated"
	^ LGitProxyOptions fromHandle: (handle referenceStructAt: OFFSET_PRIM_PROXY_OPTS length: LGitProxyOptions byteSize)! !

!LGitPushOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers
	"This method was automatically generated"
	^ LGitStringArray fromHandle: (handle referenceStructAt: OFFSET_PRIM_CUSTOM_HEADERS length: LGitStringArray byteSize)! !

!LGitPushOptionsV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitPushOptionsV02x class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
	LGitOptionsVersionsEnum version;

	"
	 * If the transport being used to push to the remote requires the creation
	 * of a pack file, this controls the number of worker threads used by
	 * the packbuilder when creating that pack file to be sent to the remote.
	 *
	 * If set to 0, the packbuilder will auto-detect the number of threads
	 * to create. The default value is 1.
	 "
	uint pb_parallelism;

	"
	 * Callbacks to use for this push operation
	 "
	#LGitRemoteCallbacksV02x callbacks;
		
	"
	* Proxy options to use, by default no proxy is used.
	"
	LGitProxyOptions proxy_opts;

	"
	 * Extra headers for this push operation
	"
	LGitStringArray custom_headers;
)! !

!LGitPushOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_pb_parallelism
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_PB_PARALLELISM! !

!LGitPushOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_pb_parallelism: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_PB_PARALLELISM put: anObject! !

!LGitPushOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitPushOptionsV100 methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
push_init_options: options version: version
	self
		ffiCall: #(LGitReturnCodeEnum git_push_init_options(LGitPushOptionsV100 *options, LGitOptionsVersionsEnum version))
		options: #()! !

!LGitPushOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CUSTOM_HEADERS put: anObject getHandle length: LGitStringArray byteSize! !

!LGitPushOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CALLBACKS put: anObject getHandle length: LGitRemoteCallbacksV100 byteSize! !

!LGitPushOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_PROXY_OPTS put: anObject getHandle length: LGitProxyOptions byteSize! !

!LGitPushOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks
	"This method was automatically generated"
	^ LGitRemoteCallbacksV100 fromHandle: (handle referenceStructAt: OFFSET_PRIM_CALLBACKS length: LGitRemoteCallbacksV100 byteSize)! !

!LGitPushOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts
	"This method was automatically generated"
	^ LGitProxyOptions fromHandle: (handle referenceStructAt: OFFSET_PRIM_PROXY_OPTS length: LGitProxyOptions byteSize)! !

!LGitPushOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers
	"This method was automatically generated"
	^ LGitStringArray fromHandle: (handle referenceStructAt: OFFSET_PRIM_CUSTOM_HEADERS length: LGitStringArray byteSize)! !

!LGitPushOptionsV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitPushOptionsV100 class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
	LGitOptionsVersionsEnum version;

	"
	 * If the transport being used to push to the remote requires the creation
	 * of a pack file, this controls the number of worker threads used by
	 * the packbuilder when creating that pack file to be sent to the remote.
	 *
	 * If set to 0, the packbuilder will auto-detect the number of threads
	 * to create. The default value is 1.
	 "
	uint pb_parallelism;

	"
	 * Callbacks to use for this push operation
	 "
	LGitRemoteCallbacksV100 callbacks;
		
	"
	* Proxy options to use, by default no proxy is used.
	"
	LGitProxyOptions proxy_opts;

	"
	 * Extra headers for this push operation
	"
	LGitStringArray custom_headers;
)! !

!LGitPushOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_pb_parallelism
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_PB_PARALLELISM! !

!LGitPushOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_pb_parallelism: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_PB_PARALLELISM put: anObject! !

!LGitPushOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitOptionsVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitPushOptionsV120 methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
push_init_options: options version: version
	self
		ffiCall: #(LGitReturnCodeEnum git_push_init_options(LGitPushOptionsV120 *options, LGitOptionsVersionsEnum version))
		options: #()! !

!LGitPushOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CUSTOM_HEADERS put: anObject getHandle length: LGitStringArray byteSize! !

!LGitPushOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_CALLBACKS put: anObject getHandle length: LGitRemoteCallbacksV120 byteSize! !

!LGitPushOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_PROXY_OPTS put: anObject getHandle length: LGitProxyOptions byteSize! !

!LGitPushOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_callbacks
	"This method was automatically generated"
	^ LGitRemoteCallbacksV120 fromHandle: (handle referenceStructAt: OFFSET_PRIM_CALLBACKS length: LGitRemoteCallbacksV120 byteSize)! !

!LGitPushOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_proxy_opts
	"This method was automatically generated"
	^ LGitProxyOptions fromHandle: (handle referenceStructAt: OFFSET_PRIM_PROXY_OPTS length: LGitProxyOptions byteSize)! !

!LGitPushOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_custom_headers
	"This method was automatically generated"
	^ LGitStringArray fromHandle: (handle referenceStructAt: OFFSET_PRIM_CUSTOM_HEADERS length: LGitStringArray byteSize)! !

!LGitPushOptionsV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitPushOptionsV120 class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^ #(
	LGitOptionsVersionsEnum version;

	"
	 * If the transport being used to push to the remote requires the creation
	 * of a pack file, this controls the number of worker threads used by
	 * the packbuilder when creating that pack file to be sent to the remote.
	 *
	 * If set to 0, the packbuilder will auto-detect the number of threads
	 * to create. The default value is 1.
	 "
	uint pb_parallelism;

	"
	 * Callbacks to use for this push operation
	 "
	LGitRemoteCallbacksV120 callbacks;
		
	"
	* Proxy options to use, by default no proxy is used.
	"
	LGitProxyOptions proxy_opts;

	"
	 * Extra headers for this push operation
	"
	LGitStringArray custom_headers;
)! !

!LGitPushOptionsVersionEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
lgit_push_options_version_1
	^ self basicNew
		value: 1;
		yourself! !

!LGitPushOptionsVersionEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^ #(
			LGIT_PUSH_OPTIONS_VERSION_1 1
		)! !

!LGitPushStatusForeachCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (char *arg1, char *arg2, void *arg3))! !

!LGitPushTransferProgressCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (uint current, uint total, size_t bytes, void *payload))! !

!LGitPushUpdate methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_dst: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_DST put: anObject getHandle length: LGitId byteSize! !

!LGitPushUpdate methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_dst_refname
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_DST_REFNAME) type: ExternalType char asPointerType! !

!LGitPushUpdate methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_src
	"This method was automatically generated"
	^ LGitId fromHandle: (handle referenceStructAt: OFFSET_PRIM_SRC length: LGitId byteSize)! !

!LGitPushUpdate methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_dst
	"This method was automatically generated"
	^ LGitId fromHandle: (handle referenceStructAt: OFFSET_PRIM_DST length: LGitId byteSize)! !

!LGitPushUpdate methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_src_refname: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_SRC_REFNAME put: anObject getHandle.! !

!LGitPushUpdate methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_dst_refname: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_DST_REFNAME put: anObject getHandle.! !

!LGitPushUpdate methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_src_refname
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_SRC_REFNAME) type: ExternalType char asPointerType! !

!LGitPushUpdate methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_src: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_SRC put: anObject getHandle length: LGitId byteSize! !

!LGitPushUpdate class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		"
		 * The source name of the reference
		 "
		String src_refname;
		"
		 * The name of the reference to update on the server
		 "
		String dst_refname;
		"
		 * The current target of the reference
		 "
		LGitId src
		"
		 * The new target for the reference
		 "
		LGitId dst
	)! !

!LGitPushUpdateReferenceCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (String refname, String status, void *data))! !

!LGitReadStream methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
position
	
	^ position! !

!LGitReadStream methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
initialize
	super initialize.
	position := 0! !

!LGitReadStream methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
gitBlob: aBlob
	gitBlob := aBlob! !

!LGitReadStream methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isBinary
	"We always give binary data from git.
	It is the user's reponsibility to decode it"
	^ true! !

!LGitReadStream methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
size

	^ gitBlob rawSize! !

!LGitReadStream methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
readInto: aBuffer startingAt: start count: bytesToRead
	| limit |
	limit := bytesToRead min: (self size - position).
	LibC
		memCopy: gitBlob rawBuffer + position
		to: aBuffer
		size: limit.
	position := position + limit.
	^ limit! !

!LGitReadStream methodsFor: 'initialize-release' stamp: ' 1/5/2022 21:01:26'!
close
	
	"Do nothing, we should not free git's blob"! !

!LGitReadStream methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
atEnd
	
	^ position = self size! !

!LGitReadStream class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
on: aBlob
	
	^ self new
		gitBlob: aBlob;
		yourself! !

!LGitRefSpec commentStamp: 'MaxLeske 4/18/2014 11:59'!
Use:
	LGitRefSpec fromString: '+refs/heads/*:refs/remotes/origin/*'.

Note: The asterisk wildcard (*) matches all refs of a given path (not explicitly documented in the below).

From the git-fetch man page:

<refspec>
           The format of a <refspec> parameter is an optional plus +, followed by the source
           ref <src>, followed by a colon :, followed by the destination ref <dst>.

           The remote ref that matches <src> is fetched, and if <dst> is not empty string,
           the local ref that matches it is fast-forwarded using <src>. If the optional plus
           + is used, the local ref is updated even if it does not result in a fast-forward
           update.

               Note
               If the remote branch from which you want to pull is modified in non-linear
               ways such as being rewound and rebased frequently, then a pull will attempt a
               merge with an older version of itself, likely conflict, and fail. It is under
               these conditions that you would want to use the + sign to indicate
               non-fast-forward updates will be needed. There is currently no easy way to
               determine or declare that a branch will be made available in a repository
               with this behavior; the pulling user simply must know this is the expected
               usage pattern for a branch.

               Note
               You never do your own development on branches that appear on the right hand
               side of a <refspec> colon on Pull: lines; they are to be updated by git
               fetch. If you intend to do development derived from a remote branch B, have a
               Pull: line to track it (i.e.  Pull: B:remote-B), and have a separate branch
               my-B to do your development on top of it. The latter is created by git branch
               my-B remote-B (or its equivalent git checkout -b my-B remote-B). Run git
               fetch to keep track of the progress of the remote side, and when you see
               something new on the remote branch, merge it into your development branch
               with git pull . remote-B, while you are on my-B branch.

               Note
               There is a difference between listing multiple <refspec> directly on git pull
               command line and having multiple Pull: <refspec> lines for a <repository> and
               running git pull command without any explicit <refspec> parameters. <refspec>
               listed explicitly on the command line are always merged into the current
               branch after fetching. In other words, if you list more than one remote refs,
               you would be making an Octopus. While git pull run without any explicit
               <refspec> parameter takes default <refspec>s from Pull: lines, it merges only
               the first <refspec> found into the current branch, after fetching all the
               remote refs. This is because making an Octopus from remote refs is rarely
               done, while keeping track of multiple remote heads in one-go by fetching more
               than one is often useful.
Some short-cut notations are also supported.

           o    tag <tag> means the same as refs/tags/<tag>:refs/tags/<tag>; it requests
               fetching everything up to the given tag.

           o   A parameter <ref> without a colon fetches that ref into FETCH_HEAD, and
               updates the remote-tracking branches (if any).!
!LGitRefSpec methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
destination
	^ destination ifNil: [ '' ]! !

!LGitRefSpec methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
printOn: aStream
	self isForced ifTrue: [ aStream nextPut: $+ ].
	aStream
		nextPutAll: self source;
		nextPut: $:;
		nextPutAll: self destination! !

!LGitRefSpec methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
source
	^ source ifNil: [ '' ]! !

!LGitRefSpec methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
destination: aString
	destination := aString! !

!LGitRefSpec methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isForced
	^ forced ifNil: [ false ]! !

!LGitRefSpec methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
source: aString
	source := aString! !

!LGitRefSpec methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
beForced
	forced := true! !

!LGitRefSpec methodsFor: 'intialization' stamp: ' 1/5/2022 21:01:26'!
initializeFromString: aString
	<todo: 'use exceptions instead of assertions'>
	| stream |

	self assert: ('(\+?\w(\w|\-|\.|/)*)?\:\w(\w|\-|\.|/)*' asRegex matches: aString).
	
	stream := aString readStream.
	[
		(stream peek = $+) ifTrue: [ 
			self beForced.
			stream next ].
		self source: (stream upTo: $:).
		self destination: stream upToEnd ] ensure: [ stream close ]! !

!LGitRefSpec class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromString: aString
	^ self new
		initializeFromString: aString;
		yourself! !

!LGitReference commentStamp: 'TorstenBergmann 6/2/2021 22:20'!
A LGitReference represents the reference to a git object. References can be symbolic as for instance HEAD or a branch etc.
See [https://libgit2.org/libgit2/#HEAD/group/reference](https://libgit2.org/libgit2/#HEAD/group/reference)

Instance Variables
	handle:		NBExternalObject
	repoHandle:	NBExternalObject

handle
	- the reference to the external object representing the reference

repoHandle
	- the reference to the repository in which the reference is contained
!
!LGitReference methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
targetId
	| data oId |
	data := self reference_target: self.
	data getHandle isNull
		ifTrue: [ ^ nil ].
	oId := LGitId fromExternalAddress: data.
	oId internalize.
	^ oId! !

!LGitReference methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
upstream
	| upstream | 
	upstream  := self class of: self repository.

	[ self withReturnHandlerDo: [
		self branch_upstream: upstream local: self
	]] 
	on: LGit_GIT_ENOTFOUND do: [ ^ nil ].
	^ upstream! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_lookup: out repo: repo name: name
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_reference_lookup #(LGitReference * self , LGitRepository repo , String name))
		options: #()! !

!LGitReference methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
= anObject
	self class == anObject class ifFalse: [ ^ false ].
	
	^ self == anObject or: [
		(self 
			reference_cmp: self 
			ref2: anObject) = LGitReturnCodeEnum git_ok  ]! !

!LGitReference methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isLocal
	^ self reference_is_remote not! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_symbolic_create: out repo: repo name: name target: target force: force log_message: log_message
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_reference_symbolic_create #(LGitReference * self , LGitRepository repo , String name , String target , Boolean force , String log_message))
		options: #(optCoerceNilToNull)! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_create: out repo: repo name: name id: id force: force log_message: log_message
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_reference_create #(LGitReference * self , LGitRepository repo , String name , LGitId * id , Boolean force , String log_message))
		options: #(optCoerceNilToNull)! !

!LGitReference methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
basename
	^ self name copyAfterLast: $/! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_resolve: out ref: ref
	
	^ self
		ffiCall: #(LGitReturnCodeEnum git_reference_resolve #(LGitReference * out , self))
		options: #()! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_type: ref
	
	^ self
		ffiCallSafely: #(LGitReferenceTypeEnum git_reference_type #(self))
		options: #()! !

!LGitReference methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
setTarget: aReference
	self setTargetId: aReference object id! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
branch_upstream: out local: local
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_branch_upstream #(LGitReference * out , self))
		options: #()! !

!LGitReference methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
owner
	^ self ffiCallSafely: #(void * git_reference_owner #(self)) options: #()! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_is_tag	
	^ self ffiCallSafely: #(int git_reference_is_tag #(self)) options: #()! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_name: ref
	
	^ self ffiCallSafely: #(String git_reference_name #(self)) options: #()! !

!LGitReference methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream
	aStream nextPutAll: self name surroundedBySingleQuotes! !

!LGitReference methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createDirect: nameString target: aGitId force: aBoolean
	self withReturnHandlerDo: [ 
		self
			reference_create: self
			repo: self repository
			name: nameString
			id: aGitId
			force: aBoolean
			log_message: 'created reference ', nameString ]! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_is_branch: ref
	
	^ self ffiCallSafely: #(int git_reference_is_branch #(self)) options: #()! !

!LGitReference methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
annotatedCommit
	^ LGitAnnotatedCommit fromRef: self! !

!LGitReference methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
object
	self isDirect 
		ifFalse: [ ^ self resolve object ].

	^(LGitObject of: self repository fromId: self targetId) concreteObject! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_is_remote
	^ self ffiCallSafely: #(Boolean git_reference_is_remote #(self)) options: #()! !

!LGitReference methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isDirect
	^ (self reference_type: self) = LGitReferenceTypeEnum git_ref_oid! !

!LGitReference methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isHead
	^ (self branch_is_head: self) = 1! !

!LGitReference methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isBranch
	^ (self reference_is_branch: self) = 1! !

!LGitReference methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isSymbolic
	^ (self reference_type: self) = LGitReferenceTypeEnum git_ref_symbolic! !

!LGitReference methodsFor: 'initialize-release' stamp: ' 1/5/2022 21:01:26'!
initializeOn: aHandle in: aRepo
	handle := aHandle.
	self repository: aRepo.! !

!LGitReference methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isTag
	^ self reference_is_tag = 1! !

!LGitReference methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
resolve
	| resolved |
	self isDirect 
		ifTrue: [ ^ self ].
	resolved := self class of: self repository.
	self withReturnHandlerDo: [ self reference_resolve: resolved ref: self ].
	^ resolved! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_symbolic_set_target: out ref: ref target: target log_message: log_message
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_reference_symbolic_set_target #(LGitReference * self , LGitReference ref , String target , String log_message))
		options: #()! !

!LGitReference methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
setUpstream: upstreamName
	self withReturnHandlerDo: [
		self branch_set_upstream: upstreamName
	]! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
branch_set_upstream: upstream
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_branch_set_upstream #(self , String upstream))
		options: #()! !

!LGitReference methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
name
	^ self reference_name: self! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
branch_is_head: branch
	
	^ self ffiCallSafely: #(int git_branch_is_head #(self)) options: #()! !

!LGitReference methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
pushUpstream
	  
	^ self repository config 
		getString: 'remote.pushDefault'
		ifPresent: [ :pushRemoteName |
			self repository 
				lookupBranch: self upstream basename
				inRemote: pushRemoteName ]
		ifAbsent: [ self upstream ]! !

!LGitReference methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
shortName
	^ self isLocal 
		ifTrue: [ self basename ]
		ifFalse: [ self name withoutPrefix: 'refs/remotes/']! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_cmp: ref1 ref2: ref2
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_reference_cmp #(self , LGitReference ref2))
		options: #()! !

!LGitReference methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
setTargetId: aGitId
	| newRef |
	newRef := LGitReference of: self repository.
	self
		withReturnHandlerDo: [ 
			self
				reference_set_target: newRef
				ref: self
				id: aGitId
				log_message: 'set ' , self name , ' to ' , aGitId hexString ]! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_target: ref
	<todo: 'using LGitId* as return value causes random crashes'>
	
	^ self ffiCallSafely: #(void * git_reference_target #(self)) options: #()! !

!LGitReference methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createSymbolic: nameString target: targetString force: aBoolean
	self withReturnHandlerDo: [ 
		self
			reference_symbolic_create: self
			repo: self repository
			name: nameString
			target: targetString
			force: aBoolean
			log_message: 'created reference ', nameString ]! !

!LGitReference methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_set_target: out ref: ref id: id log_message: log_message
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_reference_set_target #(LGitReference * out , self , LGitId * id , String log_message))
		options: #()! !

!LGitReference class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #reference_free:! !

!LGitReference class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_free: handle
	^ self
		ffiCallSafely: #(void git_reference_free #(void *handle))
		options: #()! !

!LGitReferenceTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_ref_symbolic
	^ self basicNew
		value: 2;
		yourself! !

!LGitReferenceTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_REF_INVALID 0
	GIT_REF_OID 1
	GIT_REF_SYMBOLIC 2
	GIT_REF_LISTALL 3
)! !

!LGitReferenceTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_ref_invalid
	^ self basicNew
		value: 0;
		yourself! !

!LGitReferenceTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_ref_listall
	^ self basicNew
		value: 3;
		yourself! !

!LGitReferenceTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_ref_oid
	^ self basicNew
		value: 1;
		yourself! !

!LGitRemote commentStamp: 'TorstenBergmann 6/2/2021 22:19'!
See [https://libgit2.org/libgit2/#HEAD/group/remote](https://libgit2.org/libgit2/#HEAD/group/remote)!
!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
addPush
	self withReturnHandlerDo: [ 
		self
			remote_add_push: self repository
			remote: self remoteName
			refspec: self fetchSpec ]! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
pullWithFetchOptions: fetchOptions
	<todo: 'check for conflicts'>
	self repository isReady ifFalse: [  ^ self ].

	self lookup.
	
	self withReturnHandlerDo: [ 
		self
			remote_fetch: self
			refspecs: nil
			opts: fetchOptions
			reflog_message: 'automatic pull from libgit2' ].
	
	"assume that there are no conflicts and fast-forwad to FETCH_HEAD"
	self repository fastForward! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
fetchWithCredentials: aCredentialsProvider refSpec: aRefSpec

	^ self fetchWithCredentials: aCredentialsProvider andProgressCallback: nil refSpec: aRefSpec! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
fetchWithCredentials: aCredentialsProvider
	
	^ self
		fetchWithCredentials: aCredentialsProvider
		refSpec: nil! !

!LGitRemote methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
hasFetchSpec
	^ self fetchSpec notNil! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
refSpecs 
	| specs |
	specs := LGitStringArray externalNew autoRelease.
	self withReturnHandlerDo: [ 
		self remote_get_fetch_refspecs: specs ].
	^ specs strings! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
remoteName: aString
	remoteName := aString! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_fetch: remote refspecs: refspecs opts: opts reflog_message: message
	
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1)) ifTrue: [
		^ self remote_fetch_v0251: remote refspecs: refspecs opts: opts reflog_message: message. ].
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1 2)) ifTrue: [ 
		^ self remote_fetch_v100: remote refspecs: refspecs opts: opts reflog_message: message ].
	
	^ self remote_fetch_v120: remote refspecs: refspecs opts: opts reflog_message: message! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_push_v0251: remote refspecs: refspecs opts: opts
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_push #(self , LGitStringArray * refspecs , LGitPushOptionsV02x *opts))
		options: #(optCoerceNilToNull)! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
remoteName
	^ remoteName! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ls
	"I list all HEADS in connected remotes (you will need to #connectFetch or 
	#connectPushWithCredentials: first)"
	| out sizeBuf heads size |
	
	sizeBuf := ByteArray new: FFISizeT externalTypeSize.
	out := ExternalAddress new.
	
	self withReturnHandlerDo: [ 
		self remote_ls: out size: sizeBuf ].
	
	size := sizeBuf signedLongAt: 1.
	heads := Array new: size. 
	1 to: size do: [ :index | 
		heads at: index put: (LGitRemoteHead fromHandle: (out pointerAt: 1)).
		out := out + FFIExternalType pointerSize ].
	
	^ heads! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
fetchWithMessage: aString
	self create.
		
	self withReturnHandlerDo: [ 
		self
			remote_fetch: self
			refspecs: nil
			opts: self ffiLibrary uniqueInstance fetchOptionsStructureClass defaults
			reflog_message: aString ]! !

!LGitRemote methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream
	aStream nextPutAll: self remoteName! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
addFetch
	self withReturnHandlerDo: [ 
		self
			remote_add_fetch: self repository
			remote: self remoteName
			refspec: self fetchSpec ]! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
delete
	self withReturnHandlerDo: [
		self
			remote_delete: self repository
			name: self remoteName ]! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
pushWithRefSpec: aRefSpec pushOptions: pushOptions
	| refspecs return |
	refspecs := LGitStringArray withAll: { aRefSpec asString }.
	return := self withReturnHandlerDo: [
		self
			remote_push: self
			refspecs: refspecs
			opts: pushOptions ].
		
	^ return! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_delete: repo name: name
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_delete #(LGitRepository repo , String name))
		options: #()! !

!LGitRemote methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
createWithFetchSpec
	self withReturnHandlerDo: [ 
		self
			remote_create_with_fetchspec: self
			repo: self repository
			name: self remoteName
			url: self url
			fetch: self fetchSpec ]! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
create
	<todo: 'use exceptions instead of assertions'>
	self assert: url notNil.
	self assert: self repository isReady.
	
	[ self hasFetchSpec
		ifFalse: [ self createWithoutSpec ]
		ifTrue: [ self createWithFetchSpec ] ]
			on: LGit_GIT_EEXISTS
			do: [ "all good then" ]! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_connect: remote direction: direction callbacks: remoteCallbacks
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_connect #(self , LGitDirectionEnum direction , LGitRemoteCallbacks * remoteCallbacks))
		options: #()! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_push_v100: remote refspecs: refspecs opts: opts

	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_push #(self , LGitStringArray *refspecs , LGitPushOptionsV100 *opts))
		options: #(optCoerceNilToNull)! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_ls: out size: size
	"
	Since I will take a lost of addresses, I'm interested on 2nd level of 'out', that's why 
	I transform `const git_remote_head ***out` into `void **out`
	This is the original function: 
		int git_remote_ls(const git_remote_head ***out, size_t *size, git_remote *remote)"
	^ self ffiCallSafely: #( LGitReturnCodeEnum git_remote_ls ( void **out, size_t *size, self ))! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_add_fetch: repo remote: remote refspec: refspec
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_add_fetch #(LGitRepository repo , String remote String refspec))
		options: #()! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_push: remote refspecs: refspecs opts: opts
	
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1))
		ifTrue: [ ^ self remote_push_v0251: remote refspecs: refspecs opts: opts ].
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1 2))
		ifTrue: [ ^ self remote_push_v100: remote refspecs: refspecs opts: opts ].
	
	^ self remote_push_v120: remote refspecs: refspecs opts: opts! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fetchSpec
	^ fetchSpec! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
fetchWithMessage: aString credentials: aCredentialsProvider 
	self create.
		
	self withReturnHandlerDo: [ 
		self
			remote_fetch: self
			refspecs: nil
			opts: (self ffiLibrary uniqueInstance fetchOptionsStructureClass defaults
				callbacks: (self ffiLibrary uniqueInstance remoteCallbacksStructureClass withProvider: aCredentialsProvider);
				yourself)
			reflog_message: aString ]! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
connectPushWithCredentials: aCredentialsProvider
	self withReturnHandlerDo: [ 
		self 
			remote_connect: self 
			direction: LGitDirectionEnum git_direction_push
			callbacks: (self ffiLibrary uniqueInstance remoteCallbacksStructureClass withProvider: aCredentialsProvider) ]! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_push_v120: remote refspecs: refspecs opts: opts

	^ self ffiCallSafely: #(LGitReturnCodeEnum git_remote_push #(
			self, 
			LGitStringArray *refspecs, 
			LGitPushOptionsV120 *opts))
		options: #(optCoerceNilToNull)! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
connectFetchWithCredentials: aCredentialsProvider
	self withReturnHandlerDo: [ 
		self 
			remote_connect: self 
			direction: LGitDirectionEnum git_direction_fetch
			callbacks: (self ffiLibrary uniqueInstance remoteCallbacksStructureClass withProvider: aCredentialsProvider) ]! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
fetchWithCredentials: aCredentialsProvider andProgressCallback: progressCallback refSpec: aRefSpec
	| refSpecs callbacks |
	self isReady ifFalse: [ self create ].
	refSpecs := aRefSpec ifNotNil: [LGitStringArray withAll: { aRefSpec asString }].
	self withReturnHandlerDo: [ 
		callbacks := self ffiLibrary uniqueInstance remoteCallbacksStructureClass withProvider: aCredentialsProvider.
		progressCallback ifNotNil: [callbacks transferProgress: progressCallback].

		self
			remote_fetch: self
			refspecs: refSpecs
			opts: (self ffiLibrary uniqueInstance fetchOptionsStructureClass defaults
				callbacks: callbacks;
				yourself)
			reflog_message: nil ]! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
fetch
	self isReady ifFalse: [ self create ].

	self withReturnHandlerDo: [ 
		self
			remote_fetch: self
			refspecs: self ffiNull handle
			opts: (self ffiLibrary uniqueInstance fetchOptionsStructureClass defaults
				callbacks: self ffiLibrary uniqueInstance remoteCallbacksStructureClass defaults;
				yourself)
			reflog_message: nil ]! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
url
	^ url! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_fetch_v0251: remote refspecs: refspecs opts: opts reflog_message: reflog_message
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_fetch #(self , LGitStringArray * refspecs , LGitFetchOptionsV02x * opts , String reflog_message))
		options: #(optCoerceNilToNull)! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
setUrl: aString
	self withReturnHandlerDo: [ 
		self
			remote_set_url: self repository
			remote: self remoteName
			url: aString]! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
lookup
	self withReturnHandlerDo: [ 
		self
			remote_lookup: self
			repo: self repository
			name: self remoteName.
		self url: self remote_url ].
	self flag: #todo. "shouldn't be autoreleased?"! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_fetch_v120: remote refspecs: refspecs opts: opts reflog_message: reflog_message
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_fetch #(self , LGitStringArray * refspecs , LGitFetchOptionsV120 * opts , String reflog_message))
		options: #(optCoerceNilToNull)! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_update_tips: remote callbacks: remoteCallbacks update_fetchhead: update_fetchhead download_tags: download_tags reflog_message: reflog_message
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_update_tips #(self , LGitRemoteCallbacks * remoteCallbacks , Boolean update_fetchhead , LGitRemoteAutotagOptionTypeEnum download_tags , String reflog_message))
		options: #(optStringOrNull)! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_create: out repo: repo name: name url: urlString
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_remote_create #(LGitRemote * self , LGitRepository repo , String name , String urlString))
		options: #()! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_get_fetch_refspecs: array
	^ self ffiCallSafely: #(int git_remote_get_fetch_refspecs(LGitStringArray *array, self))! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
connectFetch
	self withReturnHandlerDo: [ 
		self 
			remote_connect: self 
			direction: LGitDirectionEnum git_direction_fetch
			callbacks: self ffiLibrary uniqueInstance remoteCallbacksStructureClass defaults ]! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fetchSpec: aRefSpec
	fetchSpec := aRefSpec! !

!LGitRemote methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
fetchWithCredentials: aCredentialsProvider andProgressCallback: progressCallback
	
	^ self
		fetchWithCredentials: aCredentialsProvider
		andProgressCallback: progressCallback
		refSpec: nil! !

!LGitRemote methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
url: aString
	url := aString! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_fetch_v100: remote refspecs: refspecs opts: opts reflog_message: reflog_message
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_fetch #(self , LGitStringArray * refspecs , LGitFetchOptionsV100 * opts , String reflog_message))
		options: #(optCoerceNilToNull)! !

!LGitRemote methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
createWithoutSpec
	self withReturnHandlerDo: [ 
		self
			remote_create: self
			repo: self repository
			name: self remoteName
			url: self url ]! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_create_with_fetchspec: out repo: repo name: name url: urlString fetch: fetch
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_remote_create_with_fetchspec #(LGitRemote * self , LGitRepository repo , String name , String urlString , String fetch))
		options: #()! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_add_push: repo remote: remote refspec: refspec
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_add_push #(LGitRepository repo , String remote , String refspec))
		options: #()! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_lookup: out repo: repo name: name
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_remote_lookup #(LGitRemote * self , LGitRepository repo , String name))
		options: #()! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_url
	^ self
		ffiCallSafely: #(String git_remote_url #(self))
		options: #()! !

!LGitRemote methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_set_url: repo remote: remote url: urlString
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_remote_set_url #(LGitRepository repo , String remote , String urlString))
		options: #()! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
usernameSsh
	^ self credentials
		at: #usernameSsh
		ifAbsentPut: [ 
			UIManager default 
				request: 'What''s your username for SSH (probably "git")?'
				initialAnswer: 'git' ]! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
password: aString
	self credentials
		at: #password
		put: aString! !

!LGitRemote class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository named: aString
	^ self of: aRepository named: aString url: nil! !

!LGitRemote class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository named: nameString url: urlString fetchSpec: aRefSpec
	^ (self of: aRepository)
		remoteName: nameString;
		url: urlString;
		fetchSpec: aRefSpec;
		yourself! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
username
	^ self credentials
		at: #username
		ifAbsentPut: [ UIManager default request: 'What''s your account name?' ]! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
keyFilePublicPath
	^ self credentials
		at: #keyFilePublicPath
		ifAbsentPut: [ UIManager default request: 'Path to your public key file (/home/foo/.ssh/key.pub)?' ]! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
resetCredentials
	Credentials := nil! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
password
	^ self credentials
		at: #password
		ifAbsentPut: [ UIManager default request: 'What''s the password for your account?' ]! !

!LGitRemote class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #remote_free:! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
keyPassPhrase: aString
	self credentials
		at: #keyPassPhrase
		put: aString! !

!LGitRemote class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_free: handle
	
	^ self ffiCallSafely: #(void git_remote_free #(void *handle)) options: #()! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
keyFilePrivatePath: aString
	self credentials
		at: #keyFilePrivatePath
		put: aString! !

!LGitRemote class methodsFor: 'convenience' stamp: ' 1/5/2022 21:01:26'!
credentialsSsh
	^ LGitCredentialsSSH
		username: self usernameSsh
		passphrase: self keyPassPhrase
		publicKeyReference: self keyFilePublicPath asFileReference
		privateKeyReference: self keyFilePrivatePath asFileReference! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
keyFilePublicPath: aString
	self credentials
		at: #keyFilePublicPath
		put: aString! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
usernameSsh: aString
	self credentials
		at: #usernameSsh
		put: aString! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
keyPassPhrase
	^ self credentials
		at: #keyPassPhrase
		ifAbsentPut: [ UIManager default request: 'Passphrase of your private key file?' ]! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
keyFilePrivatePath
	^ self credentials
		at: #keyFilePrivatePath
		ifAbsentPut: [ UIManager default request: 'Path to your private key file (/home/foo/.ssh/key)?' ]! !

!LGitRemote class methodsFor: 'convenience' stamp: ' 1/5/2022 21:01:26'!
credentialsPlaintext
	^ LGitCredentialsPlaintext
		username: self username
		passphrase: self password! !

!LGitRemote class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
credentials
	^ Credentials ifNil: [ Credentials := SmallDictionary new ]! !

!LGitRemote class methodsFor: 'accessing - credentials' stamp: ' 1/5/2022 21:01:26'!
username: aString
	self credentials
		at: #username
		put: aString! !

!LGitRemote class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository named: nameString url: urlString
	^ self
		of: aRepository
		named: nameString
		url: urlString
		fetchSpec: nil! !

!LGitRemoteAutotagOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_remote_download_tags_auto
	^ self basicNew
		value: 1;
		yourself! !

!LGitRemoteAutotagOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_remote_download_tags_unspecified
	^ self basicNew
		value: 0;
		yourself! !

!LGitRemoteAutotagOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_remote_download_tags_none
	^ self basicNew
		value: 2;
		yourself! !

!LGitRemoteAutotagOptionTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^ #(
		"
		 * Use the setting from the configuration.
		 "
		GIT_REMOTE_DOWNLOAD_TAGS_UNSPECIFIED 0
		"
		 * Ask the server for tags pointing to objects we're already
		 * downloading.
		 "
		GIT_REMOTE_DOWNLOAD_TAGS_AUTO 1
		"
		 * Don't ask for any tags beyond the refspecs.
		 "
		GIT_REMOTE_DOWNLOAD_TAGS_NONE 2
		"
		 * Ask for the all the tags.
		 "
		GIT_REMOTE_DOWNLOAD_TAGS_ALL 3
	)! !

!LGitRemoteAutotagOptionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_remote_download_tags_all
	^ self basicNew
		value: 3;
		yourself! !

!LGitRemoteCallbacksV02x commentStamp: 'Guille 5/12/2020 11:33'!
Version of git_remote_callbacks structure for libgit 0.2x

git_remote_callbacks
The callback settings structure

Set the callbacks to be called by the remote when informing the user about the progress of the network operations.

unsigned int	version
The version

git_transport_message_cb	sideband_progress
Textual progress from the remote. Text send over the progress side-band will be passed to this function (this is the 'counting objects' output).

int (*)(git_remote_completion_t, void *)	completion

git_credential_acquire_cb	credentials
This will be called if the remote host requires authentication in order to connect to it. Returning GIT_PASSTHROUGH will make libgit2 behave as though this field isn't set.

git_transport_certificate_check_cb	certificate_check
If cert verification fails, this will be called to let the user make the final decision of whether to allow the connection to proceed. Returns 0 to allow the connection or a negative value to indicate an error.

git_indexer_progress_cb	transfer_progress
During the download of new data, this will be regularly called with the current count of progress done by the indexer.

int (*)(const char *, const git_oid *, const git_oid *, void *)	update_tips

git_packbuilder_progress	pack_progress
Function to call with progress information during pack building. Be aware that this is called inline with pack building operations, so performance may be affected.

git_push_transfer_progress_cb	push_transfer_progress
Function to call with progress information during the upload portion of a push. Be aware that this is called inline with pack building operations, so performance may be affected.

git_push_update_reference_cb	push_update_reference
See documentation of git_push_update_reference_cb

git_push_negotiation	push_negotiation
Called once between the negotiation step and the upload. It provides information about what updates will be performed.

git_transport_cb	transport
Create the transport to use for this operation. Leave NULL to auto-detect.

void *	payload
This will be passed to each of the callbacks in this struct as the last parameter.

Defined in: git2/remote.h!
!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_transfer_progress
	"This method was automatically generated"
	^LGitPushTransferProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PUSH_TRANSFER_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_certificate_check: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_CERTIFICATE_CHECK
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_tips: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_UPDATE_TIPS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_pack_progress
	"This method was automatically generated"
	^LGitPackbuilderProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PACK_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitStructVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_pack_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PACK_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_negotiation
	"This method was automatically generated"
	^LGitPushNegotiationCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PUSH_NEGOTIATION) asInteger)! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_completion
	"This method was automatically generated"
	^LGitCompletionCallback forAddress: ((handle pointerAt: OFFSET_PRIM_COMPLETION) asInteger)! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_transfer_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PUSH_TRANSFER_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_certificate_check
	"This method was automatically generated"
	^LGitTransportCertificateCheckCallback forAddress: ((handle pointerAt: OFFSET_PRIM_CERTIFICATE_CHECK) asInteger)! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_completion: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_COMPLETION
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_update_reference: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PUSH_UPDATE_REFERENCE
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_sideband_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_SIDEBAND_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_transport: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_TRANSPORT put: anObject getHandle.! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_init_callbacks: opts version: version

	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_remote_init_callbacks(LGitRemoteCallbacksV02x *opts, LGitStructVersionsEnum version))
		options: #(  )! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_sideband_progress
	"This method was automatically generated"
	^LGitTransportMessageCallback forAddress: ((handle pointerAt: OFFSET_PRIM_SIDEBAND_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_transport
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_TRANSPORT) type: ExternalType void asPointerType! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credentials: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_CREDENTIALS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_PAYLOAD put: anObject getHandle.! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_transfer_progress
	"This method was automatically generated"
	^LGitTransferProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_TRANSFER_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_PAYLOAD) type: ExternalType void asPointerType! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_negotiation: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PUSH_NEGOTIATION
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_tips
	"This method was automatically generated"
	^LGitUpdateTipsCallback forAddress: ((handle pointerAt: OFFSET_PRIM_UPDATE_TIPS) asInteger)! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_transfer_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_TRANSFER_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credentials
	"This method was automatically generated"
	^LGitCredAcquireCallback forAddress: ((handle pointerAt: OFFSET_PRIM_CREDENTIALS) asInteger)! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitRemoteCallbacksV02x methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_update_reference
	"This method was automatically generated"
	^LGitPushUpdateReferenceCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PUSH_UPDATE_REFERENCE) asInteger)! !

!LGitRemoteCallbacksV02x class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		LGitStructVersionsEnum version;
		"
		 * Textual progress from the remote. Text send over the
		 * progress side-band will be passed to this function (this is
		 * the 'counting objects' output.
		 "
		LGitTransportMessageCallback sideband_progress;

		"
		 * Completion is called when different parts of the download
		 * process are done (currently unused).
		 "
		LGitCompletionCallback completion;

		"
		 * This will be called if the remote host requires
		 * authentication in order to connect to it.
		 *
		 * Returning GIT_PASSTHROUGH will make libgit2 behave as
		 * though this field isn't set.
		 "
		LGitCredAcquireCallback credentials;

		"
		 * If cert verification fails, this will be called to let the
		 * user make the final decision of whether to allow the
		 * connection to proceed. Returns 1 to allow the connection, 0
		 * to disallow it or a negative value to indicate an error.
		 "
	   LGitTransportCertificateCheckCallback certificate_check;

		"
		 * During the download of new data, this will be regularly
		 * called with the current count of progress done by the
		 * indexer.
		 "
		LGitTransferProgressCallback transfer_progress;

		"
		 * Each time a reference is updated locally, this function
		 * will be called with information about it.
		 "
		LGitUpdateTipsCallback update_tips;

		"
		 * Function to call with progress information during pack
		 * building. Be aware that this is called inline with pack
		 * building operations, so performance may be affected.
		 "
		LGitPackbuilderProgressCallback pack_progress;

		"
		 * Function to call with progress information during the
		 * upload portion of a push. Be aware that this is called
		 * inline with pack building operations, so performance may be
		 * affected.
		 "
		LGitPushTransferProgressCallback push_transfer_progress;

		"
		 * Called for each updated reference on push. If `status` is
		 * not `NULL`, the update was rejected by the remote server
		 * and `status` contains the reason given.
		 "
		LGitPushUpdateReferenceCallback push_update_reference;

		"
		 * Called once between the negotiation step and the upload. It
		 * provides information about what updates will be performed.
		 "
		LGitPushNegotiationCallback push_negotiation;

		"
		 * Create the transport to use for this operation. Leave NULL
		 * to auto-detect.
		 "
		LGitTransport transport;

		"
		 * This will be passed to each of the callbacks in this struct
		 * as the last parameter.
		 "
		void *payload;
	)! !

!LGitRemoteCallbacksV100 commentStamp: 'Guille 5/12/2020 11:32'!
Version of git_remote_callbacks structure for libgit 1.0.0

https://libgit2.org/libgit2/#v1.0.0/type/git_remote_callbacks

git_remote_callbacks
The callback settings structure

Set the callbacks to be called by the remote when informing the user about the progress of the network operations.

unsigned int	version
The version

git_transport_message_cb	sideband_progress
Textual progress from the remote. Text send over the progress side-band will be passed to this function (this is the 'counting objects' output).

int (*)(git_remote_completion_t, void *)	completion

git_credential_acquire_cb	credentials
This will be called if the remote host requires authentication in order to connect to it. Returning GIT_PASSTHROUGH will make libgit2 behave as though this field isn't set.

git_transport_certificate_check_cb	certificate_check
If cert verification fails, this will be called to let the user make the final decision of whether to allow the connection to proceed. Returns 0 to allow the connection or a negative value to indicate an error.

git_indexer_progress_cb	transfer_progress
During the download of new data, this will be regularly called with the current count of progress done by the indexer.

int (*)(const char *, const git_oid *, const git_oid *, void *)	update_tips

git_packbuilder_progress	pack_progress
Function to call with progress information during pack building. Be aware that this is called inline with pack building operations, so performance may be affected.

git_push_transfer_progress_cb	push_transfer_progress
Function to call with progress information during the upload portion of a push. Be aware that this is called inline with pack building operations, so performance may be affected.

git_push_update_reference_cb	push_update_reference
See documentation of git_push_update_reference_cb

git_push_negotiation	push_negotiation
Called once between the negotiation step and the upload. It provides information about what updates will be performed.

git_transport_cb	transport
Create the transport to use for this operation. Leave NULL to auto-detect.

void *	payload
This will be passed to each of the callbacks in this struct as the last parameter.

git_url_resolve_cb	resolve_url
Resolve URL before connecting to remote. The returned URL will be used to connect to the remote instead.

Defined in: git2/remote.h!
!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_transfer_progress
	"This method was automatically generated"
	^LGitPushTransferProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PUSH_TRANSFER_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_certificate_check: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_CERTIFICATE_CHECK
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_tips: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_UPDATE_TIPS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_pack_progress
	"This method was automatically generated"
	^LGitPackbuilderProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PACK_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitStructVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_pack_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PACK_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_negotiation
	"This method was automatically generated"
	^LGitPushNegotiationCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PUSH_NEGOTIATION) asInteger)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_completion
	"This method was automatically generated"
	^LGitCompletionCallback forAddress: ((handle pointerAt: OFFSET_PRIM_COMPLETION) asInteger)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_transfer_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PUSH_TRANSFER_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_certificate_check
	"This method was automatically generated"
	^LGitTransportCertificateCheckCallback forAddress: ((handle pointerAt: OFFSET_PRIM_CERTIFICATE_CHECK) asInteger)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_completion: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_COMPLETION
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_update_reference: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PUSH_UPDATE_REFERENCE
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_sideband_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_SIDEBAND_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_transport: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_TRANSPORT put: anObject getHandle.! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_init_callbacks: opts version: version

	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_remote_init_callbacks(LGitRemoteCallbacksV100 *opts, LGitStructVersionsEnum version))
		options: #(  )! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_sideband_progress
	"This method was automatically generated"
	^LGitTransportMessageCallback forAddress: ((handle pointerAt: OFFSET_PRIM_SIDEBAND_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_transport
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_TRANSPORT) type: ExternalType void asPointerType! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credentials: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_CREDENTIALS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_PAYLOAD put: anObject getHandle.! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_transfer_progress
	"This method was automatically generated"
	^LGitTransferProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_TRANSFER_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_PAYLOAD) type: ExternalType void asPointerType! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_negotiation: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PUSH_NEGOTIATION
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_tips
	"This method was automatically generated"
	^LGitUpdateTipsCallback forAddress: ((handle pointerAt: OFFSET_PRIM_UPDATE_TIPS) asInteger)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_transfer_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_TRANSFER_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_credentials
	"This method was automatically generated"
	^LGitCredAcquireCallback forAddress: ((handle pointerAt: OFFSET_PRIM_CREDENTIALS) asInteger)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_resolve_url
	"This method was automatically generated"
	^LGitURLResolveCallback forAddress: ((handle pointerAt: OFFSET_PRIM_RESOLVE_URL) asInteger)! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_resolve_url: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_RESOLVE_URL
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV100 methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_update_reference
	"This method was automatically generated"
	^LGitPushUpdateReferenceCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PUSH_UPDATE_REFERENCE) asInteger)! !

!LGitRemoteCallbacksV100 class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	
	^ #(
		LGitStructVersionsEnum version;
		"
		 * Textual progress from the remote. Text send over the
		 * progress side-band will be passed to this function (this is
		 * the 'counting objects' output.
		 "
		LGitTransportMessageCallback sideband_progress;

		"
		 * Completion is called when different parts of the download
		 * process are done (currently unused).
		 "
		LGitCompletionCallback completion;

		"
		 * This will be called if the remote host requires
		 * authentication in order to connect to it.
		 *
		 * Returning GIT_PASSTHROUGH will make libgit2 behave as
		 * though this field isn't set.
		 "
		LGitCredAcquireCallback credentials;

		"
		 * If cert verification fails, this will be called to let the
		 * user make the final decision of whether to allow the
		 * connection to proceed. Returns 1 to allow the connection, 0
		 * to disallow it or a negative value to indicate an error.
		 "
	   LGitTransportCertificateCheckCallback certificate_check;

		"
		 * During the download of new data, this will be regularly
		 * called with the current count of progress done by the
		 * indexer.
		 "
		LGitTransferProgressCallback transfer_progress;

		"
		 * Each time a reference is updated locally, this function
		 * will be called with information about it.
		 "
		LGitUpdateTipsCallback update_tips;

		"
		 * Function to call with progress information during pack
		 * building. Be aware that this is called inline with pack
		 * building operations, so performance may be affected.
		 "
		LGitPackbuilderProgressCallback pack_progress;

		"
		 * Function to call with progress information during the
		 * upload portion of a push. Be aware that this is called
		 * inline with pack building operations, so performance may be
		 * affected.
		 "
		LGitPushTransferProgressCallback push_transfer_progress;

		"
		 * Called for each updated reference on push. If `status` is
		 * not `NULL`, the update was rejected by the remote server
		 * and `status` contains the reason given.
		 "
		LGitPushUpdateReferenceCallback push_update_reference;

		"
		 * Called once between the negotiation step and the upload. It
		 * provides information about what updates will be performed.
		 "
		LGitPushNegotiationCallback push_negotiation;

		"
		 * Create the transport to use for this operation. Leave NULL
		 * to auto-detect.
		 "
		LGitTransport transport;

		"
		 * This will be passed to each of the callbacks in this struct
		 * as the last parameter.
		 "
		void *payload;

		"
		 * Resolve URL before connecting to remote. The returned URL will be used to connect to the remote instead.
		"		
		LGitURLResolveCallback resolve_url
	)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_transfer_progress
	"This method was automatically generated"
	^LGitPushTransferProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PUSH_TRANSFER_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_certificate_check: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_CERTIFICATE_CHECK
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_tips: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_UPDATE_TIPS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_pack_progress
	"This method was automatically generated"
	^LGitPackbuilderProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PACK_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_version
	"This method was automatically generated"
	^LGitStructVersionsEnum fromInteger: (handle unsignedLongAt: OFFSET_PRIM_VERSION)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_pack_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PACK_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_negotiation
	"This method was automatically generated"
	^LGitPushNegotiationCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PUSH_NEGOTIATION) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_completion
	"This method was automatically generated"
	^LGitCompletionCallback forAddress: ((handle pointerAt: OFFSET_PRIM_COMPLETION) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_transfer_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PUSH_TRANSFER_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_certificate_check
	"This method was automatically generated"
	^LGitTransportCertificateCheckCallback forAddress: ((handle pointerAt: OFFSET_PRIM_CERTIFICATE_CHECK) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_completion: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_COMPLETION
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_update_reference: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PUSH_UPDATE_REFERENCE
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_sideband_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_SIDEBAND_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_ready: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_REMOTE_READY
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_transport: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_TRANSPORT put: anObject getHandle.! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_init_callbacks: opts version: version

	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_remote_init_callbacks(LGitRemoteCallbacksV120 *opts, LGitStructVersionsEnum version))
		options: #(  )! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_sideband_progress
	"This method was automatically generated"
	^LGitTransportMessageCallback forAddress: ((handle pointerAt: OFFSET_PRIM_SIDEBAND_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_transport
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_TRANSPORT) type: ExternalType void asPointerType! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_credentials: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_CREDENTIALS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_payload: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_PAYLOAD put: anObject getHandle.! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_transfer_progress
	"This method was automatically generated"
	^LGitTransferProgressCallback forAddress: ((handle pointerAt: OFFSET_PRIM_TRANSFER_PROGRESS) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_payload
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_PAYLOAD) type: ExternalType void asPointerType! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_negotiation: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_PUSH_NEGOTIATION
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_update_tips
	"This method was automatically generated"
	^LGitUpdateTipsCallback forAddress: ((handle pointerAt: OFFSET_PRIM_UPDATE_TIPS) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_transfer_progress: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_TRANSFER_PROGRESS
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_credentials
	"This method was automatically generated"
	^LGitCredAcquireCallback forAddress: ((handle pointerAt: OFFSET_PRIM_CREDENTIALS) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_resolve_url
	"This method was automatically generated"
	^LGitURLResolveCallback forAddress: ((handle pointerAt: OFFSET_PRIM_RESOLVE_URL) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_VERSION put: anObject value! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_remote_ready
	"This method was automatically generated"
	^LGitRemoteReadyCallback forAddress: ((handle pointerAt: OFFSET_PRIM_REMOTE_READY) asInteger)! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_resolve_url: anObject
	"This method was automatically generated"
	handle 
		pointerAt: OFFSET_PRIM_RESOLVE_URL
		put: (anObject 
			ifNotNil: [ anObject thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!LGitRemoteCallbacksV120 methodsFor: 'libgit-fields' stamp: ' 1/5/2022 21:01:26'!
prim_push_update_reference
	"This method was automatically generated"
	^LGitPushUpdateReferenceCallback forAddress: ((handle pointerAt: OFFSET_PRIM_PUSH_UPDATE_REFERENCE) asInteger)! !

!LGitRemoteCallbacksV120 class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	
	^ #(
		LGitStructVersionsEnum version;
		"
		 * Textual progress from the remote. Text send over the
		 * progress side-band will be passed to this function (this is
		 * the 'counting objects' output.
		 "
		LGitTransportMessageCallback sideband_progress;

		"
		 * Completion is called when different parts of the download
		 * process are done (currently unused).
		 "
		LGitCompletionCallback completion;

		"
		 * This will be called if the remote host requires
		 * authentication in order to connect to it.
		 *
		 * Returning GIT_PASSTHROUGH will make libgit2 behave as
		 * though this field isn't set.
		 "
		LGitCredAcquireCallback credentials;

		"
		 * If cert verification fails, this will be called to let the
		 * user make the final decision of whether to allow the
		 * connection to proceed. Returns 1 to allow the connection, 0
		 * to disallow it or a negative value to indicate an error.
		 "
	   LGitTransportCertificateCheckCallback certificate_check;

		"
		 * During the download of new data, this will be regularly
		 * called with the current count of progress done by the
		 * indexer.
		 "
		LGitTransferProgressCallback transfer_progress;

		"
		 * Each time a reference is updated locally, this function
		 * will be called with information about it.
		 "
		LGitUpdateTipsCallback update_tips;

		"
		 * Function to call with progress information during pack
		 * building. Be aware that this is called inline with pack
		 * building operations, so performance may be affected.
		 "
		LGitPackbuilderProgressCallback pack_progress;

		"
		 * Function to call with progress information during the
		 * upload portion of a push. Be aware that this is called
		 * inline with pack building operations, so performance may be
		 * affected.
		 "
		LGitPushTransferProgressCallback push_transfer_progress;

		"
		 * Called for each updated reference on push. If `status` is
		 * not `NULL`, the update was rejected by the remote server
		 * and `status` contains the reason given.
		 "
		LGitPushUpdateReferenceCallback push_update_reference;

		"
		 * Called once between the negotiation step and the upload. It
		 * provides information about what updates will be performed.
		 "
		LGitPushNegotiationCallback push_negotiation;

		"
		 * Create the transport to use for this operation. Leave NULL
		 * to auto-detect.
		 "
		LGitTransport transport;

		"
		 *
	    * Callback when the remote is ready to connect.
		"
		LGitRemoteReadyCallback remote_ready;

		"
		 * This will be passed to each of the callbacks in this struct
		 * as the last parameter.
		 "
		void *payload;

		"
		 * Resolve URL before connecting to remote. The returned URL will be used to connect to the remote instead.
		"		
		LGitURLResolveCallback resolve_url
	)! !

!LGitRemoteCompletionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_remote_completion_download
	^ self basicNew
		value: 0;
		yourself! !

!LGitRemoteCompletionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_remote_completion_indexing
	^ self basicNew
		value: 1;
		yourself! !

!LGitRemoteCompletionTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_REMOTE_COMPLETION_DOWNLOAD 0
	GIT_REMOTE_COMPLETION_INDEXING 1
	GIT_REMOTE_COMPLETION_ERROR 2
)! !

!LGitRemoteCompletionTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_remote_completion_error
	^ self basicNew
		value: 2;
		yourself! !

!LGitRemoteCreateCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (void **out, LGitRepository repo, String name, String url, void *payload))! !

!LGitRemoteHead commentStamp: 'EstebanLorenzano 1/5/2017 16:00'!
I'm a description of a reference advertised by a remote server, given out on `ls` calls.

https://libgit2.github.com/libgit2/#HEAD/type/git_remote_head!
!LGitRemoteHead methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_symref_target
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_SYMREF_TARGET) type: ExternalType char asPointerType! !

!LGitRemoteHead methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_local
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_LOCAL! !

!LGitRemoteHead methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_loid
	"This method was automatically generated"
	^ LGitId fromHandle: (handle referenceStructAt: OFFSET_PRIM_LOID length: LGitId byteSize)! !

!LGitRemoteHead methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_name: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_NAME put: anObject getHandle.! !

!LGitRemoteHead methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_local: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_LOCAL put: anObject! !

!LGitRemoteHead methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_oid
	"This method was automatically generated"
	^ LGitId fromHandle: (handle referenceStructAt: OFFSET_PRIM_OID length: LGitId byteSize)! !

!LGitRemoteHead methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_name
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_NAME) type: ExternalType char asPointerType! !

!LGitRemoteHead methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_loid: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_LOID put: anObject getHandle length: LGitId byteSize! !

!LGitRemoteHead methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
name 
	^ (self prim_name) readStringUTF8! !

!LGitRemoteHead methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_oid: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_OID put: anObject getHandle length: LGitId byteSize! !

!LGitRemoteHead methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_symref_target: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_SYMREF_TARGET put: anObject getHandle.! !

!LGitRemoteHead class methodsFor: 'field definition' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	"self rebuildFieldAccessors"
	^#(
	int local; " available locally "
	LGitId oid;
	LGitId loid;
	String name;
	"
	 * If the server send a symref mapping for this ref, this will
	 * point to the target.
	"
	String symref_target;
	)! !

!LGitRemoteReadyCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (void *remote, int direction, void *payload))! !

!LGitRepository commentStamp: 'TorstenBergmann 6/2/2021 22:13'!
A LGitRepository represents a git repository. See [https://libgit2.org/libgit2/#HEAD/type/git_repository](https://libgit2.org/libgit2/#HEAD/type/git_repository)

Instance Variables
	handle:		NBExternalObject

handle
	- reference to the external object
!
!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_config: config
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_repository_config(LGitConfig *config, self))
		options: #()! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
mergeBaseBetween: aLGitId and: aLGitId2 
	| base |
	base := LGitId new.
	self withReturnHandlerDo: [ self merge_base: base between: aLGitId and: aLGitId2 ].
	^ base! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_set_head: refname log_message: log_message
	
	^ self
		ffiCallSafely:
			#(int git_repository_set_head #(self , String refname , String log_message))
		options: #()! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
branches
	^ OrderedCollection new: 10 streamContents: [ :stream |
		self branchesDo: [ :reference | stream nextPut: reference ] ]! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_head: reference of: repository
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_repository_head #(LGitReference * reference , self))
		options: #()! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
workingDirectory
	^ workingDirectory ifNil: [
			workingDirectory := self withReturnHandlerDo: [
				(self repository_workdir: self) asFileReference ] ]! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
remote_list: out
	^ self 
		ffiCallSafely: #( int git_remote_list ( LGitStringArray *out, self ) ) 
		options: #()! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
database
	| database |
	database := LGitOdb new.
	self withReturnHandlerDo: [
		self
			repository_odb: database
			repo: self ].
		
	^ database! !

!LGitRepository methodsFor: 'enumerating' stamp: ' 1/5/2022 21:01:26'!
remoteBranchesDo: aBlock
	LGitBranchIterator remoteBranchesOf: self do: aBlock! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
clone: aString options: cloneOptions to: aFileReference
	<todo: 'use exceptions instead of assertion'>
	self assert: aString isEmptyOrNil not.
	self assert: aFileReference notNil.
	self assert: cloneOptions notNil.
	
	aFileReference ensureCreateDirectory.
	
	self withReturnHandlerDo: [ 
		self 
			clone: self
			url: aString
			local_path: aFileReference pathString
			options: cloneOptions getHandle ]! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
setHead: aLGitReference
	self withReturnHandlerDo: [ 
		self
			repository_set_head: aLGitReference name
			log_message: 'set head to refs/heads/' , aLGitReference name ]! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
checkout_treeish: treeish opts: opts
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_checkout_tree #(self , LGitObject treeish , LGitCheckoutOptions * opts))
		options: #()! !

!LGitRepository methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isDirty: aFileReference
	^ self index isDirty: aFileReference! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revparse_single: out repo: repo spec: spec
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_revparse_single #(LGitObject * out , self , String spec))
		options: #()! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createBranch: aString target: aGitReference force: aBoolean
	<todo: 'this method belongs somewhere else'>
	| reference |
	reference := LGitReference of: self.
	reference 
		createDirect: 'refs/heads/' , aString 
		target: aGitReference object id 
		force: aBoolean.
	^ reference! !

!LGitRepository methodsFor: 'lookup' stamp: ' 1/5/2022 21:01:26'!
lookupBranch: branchName inRemote: remoteName
	^ self lookupRemoteBranch: remoteName, '/', branchName! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
cloneLocal: aString
	self clone: aString! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_open_ext: out path: path flags: flags ceiling_dirs: ceiling_dirs
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_repository_open_ext #(LGitRepository * out , String path , LGitOpenFlagEnum flags , String ceiling_dirs))
		options: #(optCoerceNilToNull optStringOrNull)! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
create
	self exists ifTrue: [ ^ self ].
	
	self repositoryReference ensureCreateDirectory! !

!LGitRepository methodsFor: 'enumerating' stamp: ' 1/5/2022 21:01:26'!
localBranchesDo: aBlock
	LGitBranchIterator localBranchesOf: self do: aBlock! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
packHead
	<todo: 'This method is distructive. It will delete *all* objects, including those not in the pack (not reachable from head'>
	"USE VERY CAREFULLY"
	
	self createPackForReference: self head.
	self deleteAllLooseObjectsForReference: self head! !

!LGitRepository methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isBare
	^ self repository_is_bare: self! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createBranchFromOrigin: branchName
	| remoteBranchName remoteBranch localBranch |
	remoteBranchName := 'origin/', branchName.
	remoteBranch := self lookupRemoteBranch: remoteBranchName.
	localBranch := self createBranch: branchName target: remoteBranch.
	localBranch setUpstream: remoteBranchName.
	^ localBranch! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
resetTo: target resetType: aResetType checkoutOptions: checkout_opts

	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_reset(self, LGitObject target, LGitResetTypeEnum aResetType, LGitCheckoutOptions *checkout_opts))
		options: #()! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
merge_heads: heads length: length merge_options: mergeOptions checkout_options: checkoutOptions
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_merge #(
				self , 
				FFIExternalArray heads ,
				int length , 
				LGitMergeOptions * mergeOptions ,
				LGitCheckoutOptions * checkoutOptions))
		options: #()! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initBare: aBoolean
	self withReturnHandlerDo: [
		self
			repository_init: self
			path: self repositoryReference pathString
			is_bare: aBoolean ].
	self autoRelease! !

!LGitRepository methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isProperRepository
	| return |
	return := self
		repository_open_ext: self
		path: self repositoryReference pathString
		flags: LGitOpenFlagEnum git_repository_open_no_search
		ceiling_dirs: nil.
		
	^ return isOk! !

!LGitRepository methodsFor: 'enumerating' stamp: ' 1/5/2022 21:01:26'!
branchesDo: aBlock
	LGitBranchIterator localBranchesOf: self do: aBlock.! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
open
	self withReturnHandlerDo: [
		self
			repository_open: self
			bare_path: self repositoryReference pathString ].
	self beOpen! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_is_unborn: repo
	^ self ffiCallSafely: #( Boolean git_repository_head_unborn (self) ) options: #()! !

!LGitRepository methodsFor: 'enumerating' stamp: ' 1/5/2022 21:01:26'!
allBranchesDo: aBlock
	LGitBranchIterator allBranchesOf: self do: aBlock! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
cloneOptionsStructureClass

	"Find the correct class depending on the libgit version we are using"
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1))
		ifTrue: [ ^ LGitCloneOptionsV02x ].
	(self ffiLibrary uniqueInstance isVersionLessThan: #(1 2))
		ifTrue: [ ^ LGitCloneOptionsV100 ].
	
	^ LGitCloneOptionsV120! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
fetchFrom: remoteName 
	(LGitRemote of: self named: remoteName) 
		lookup; 
		fetch! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_is_empty: repo
	
	^ self ffiCallSafely: #(Boolean git_repository_is_empty #(self)) options: #()! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_is_bare: repo
	
	^ self ffiCallSafely: #(Boolean git_repository_is_bare #(self)) options: #()! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
head
	| head |
	head := LGitReference of: self.
	self withReturnHandlerDo: [ self repository_head: head of: self ].
	^ head! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
workingDirectoryName
	^ self isBare
			ifTrue: [ nil ]
			ifFalse: [ self workingDirectory basename ]! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_init: out path: path is_bare: is_bare
	
	^ self
		ffiCall:
			#(int git_repository_init #(LGitRepository * out , String path , Boolean is_bare))
		options: #()! !

!LGitRepository methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
createPackForReference: aReference
	| odb walk packbuilder writepack stats packbuilderPayload progresscb packbuilderCallback |
	odb := self database.
	walk := (LGitRevwalk of: self)
		beSortedByCommitTime;
		pushReference: aReference;
		yourself.
	packbuilder := LGitPackBuilder new.
	packbuilder packbuilder_new: packbuilder repo: self.	"hideCallback := LG2RevwalkHideCb on: [ :oid :payload |  ].
	LG2RevwalkH uniqueInstance
		revwalk_add_hide_cb: walk
		hide_cb: hideCallback
		payload: nil."
	[ walk hasNext ] whileTrue: [ 
		| commit tree |
		commit := walk next.
		tree := commit tree.
		packbuilder
			packbuilder_insert_commit: packbuilder id: commit id;
			packbuilder_insert_tree: packbuilder id: tree id.
		commit free.
		tree free ].
	progresscb := LGitTransferProgressCallback on: [ :progress :data | 0 ].
	writepack := LGitOdbWritepack externalNew.
	writepack
		odb_write_pack: writepack
		db: odb
		progress_cb: progresscb
		progress_payload: ExternalAddress null.
	writepack := LGitOdbWritepack fromHandle: writepack getHandle pointer.
	stats := LGitTransferProgress externalNew.
	packbuilderPayload := LGitPackbuilderForeachPayload externalNew.
	packbuilderCallback := LGitPackbuilderForeachCallback
		on: [ :buffer :length :payload | payload writepack appendWithBuffer: buffer length: length progress: payload stats ].
	packbuilderPayload
		writepack: writepack;
		stats: stats.
	packbuilder packbuilder_foreach: packbuilder cb: packbuilderCallback payload: packbuilderPayload.
	writepack commitWithProgress: stats! !

!LGitRepository methodsFor: 'lookup' stamp: ' 1/5/2022 21:01:26'!
lookupBranch: name type: branchType
	| reference |
	reference := LGitReference of: self.
	self withReturnHandlerDo: [ 
		self
			branch_lookup: reference
			branch_name: name
			branch_type: branchType
	].
	^ reference! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
checkout_head_opts: opts
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_checkout_head #(self , LGitCheckoutOptions * opts))
		options: #()! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
new_signature: out name:name email:email time:time
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_signature_new #(void **out , String name, String email, LGitTime time, 0))
		options: #()! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
tags
	| array strings |
	array := LGitStringArray externalNew.
	self withReturnHandlerDo: [
		self
			tag_list: array
			repo: self ].
	strings := array strings.
	array free.
	^ strings! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
branch_lookup: out branch_name: branch_name branch_type: branch_type
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_branch_lookup #(LGitReference * out , self , String branch_name , LGitBranchTypeEnum branch_type))
		options: #()! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
cloneRemote: aRemote signature: aSignature branch: aString
	self
		cloneRemote: aRemote
		signature: aSignature
		branch: aString
		checkoutOptions: LGitCheckoutOptions defaults! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
signature_default: out repo: repo
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_signature_default #(void **out , self))
		options: #()! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createBranch: aString force: aBoolean
	<todo: 'this method belongs somewhere else and should allow to specify the target'>
	| reference |
	reference := LGitReference of: self.
	reference createSymbolic: 'refs/heads/' , aString target: 'refs/dummy' force: aBoolean.
	^ reference! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_index: out repo: repo
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_repository_index #(LGitIndex * out , self))
		options: #()! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_odb: out repo: repo
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_repository_odb #(LGitOdb * out , self))
		options: #()! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
signatureWithName: name email: email dateTime: dateTime
	| signaturePointer time |
	signaturePointer := ExternalAddress new.
	time := LGitTime fromDateAndTime: dateTime.
	self
		withReturnHandlerDo: [ self
				new_signature: signaturePointer
				name: name
				email: email
				time: time ].
	^ LGitSignature fromHandle: signaturePointer! !

!LGitRepository methodsFor: 'lookup' stamp: ' 1/5/2022 21:01:26'!
lookupBranch: name remote: isRemote
	^ isRemote
		ifTrue: [ self lookupRemoteBranch: (name withoutPrefix: 'refs/remotes/') ]
		ifFalse: [ self lookupLocalBranch: name ]! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
config
	| config |
	config := (LGitConfig of: self) autoRelease.
	self withReturnHandlerDo: [ self repository_config: config ].
	^ config! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
cloneRemote: aRemote  signature: aSignature branch: aString checkoutOptions: options
	<todo: 'use exceptions instead of assertions'>
	self assert: aRemote hasFetchSpec.
	
	self withReturnHandlerDo: [
		self 
			clone_into: self
			remote: aRemote
			co_opts: options
			branch: aString
			signature: aSignature ]! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_open: out bare_path: bare_path
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_repository_open #(LGitRepository * out , String bare_path))
		options: #()! !

!LGitRepository methodsFor: 'lookup' stamp: ' 1/5/2022 21:01:26'!
lookupLocalBranch: name ifAbsent: aBlock
	^ [ self lookupLocalBranch: name ]
		on: LGit_GIT_ENOTFOUND 
		do: aBlock! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createTag: aString targetId: aGitId force: aBoolean
	"Create a tag. Based on #createBranch:targetId:force:"

	| reference |
	reference := LGitReference of: self.
	reference
		createDirect: 'refs/tags/', aString
		target: aGitId
		force: aBoolean.
	^ reference! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
merge_base: out between: one and: two
	^ self ffiCallSafely: #(	LGitReturnCodeEnum git_merge_base #(
			LGitId * out, 
			self, 
			LGitId * one, 
			LGitId * two))
		options: #()! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
defaultSignature
	| signaturePointer |
	signaturePointer := ExternalAddress new.
	self withReturnHandlerDo: [ self signature_default: signaturePointer repo: self ].
	^ LGitSignature fromHandle: signaturePointer! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
git_branch_delete: gitReference
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_branch_delete #(LGitReference gitReference))
		options: #()! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
git_tag_delete: aTagName
	"int git_tag_delete(git_repository *repo, const char *tag_name);"
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_tag_delete(self , String aTagName))
		options: #()! !

!LGitRepository methodsFor: 'lookup' stamp: ' 1/5/2022 21:01:26'!
lookupRemoteBranch: name ifAbsent: aBlock
	^ [ self lookupRemoteBranch: name ]
		on: LGit_GIT_ENOTFOUND 
		do: aBlock! !

!LGitRepository methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isInitialized
	^ self isReady! !

!LGitRepository methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream
	aStream nextPutAll: self repositoryReference fullName.
	self isBare 
		ifTrue: [ aStream nextPutAll: ' [bare]' ]! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
checkout_treeish: treeish
	"treeish can be a commit, tag or tree (or NULL to use HEAD)"
	self withReturnHandlerDo: [ 
		self
			checkout_treeish: treeish
			opts:
				(LGitCheckoutOptions defaults
					checkoutStrategy: LGitCheckoutStrategyEnum git_checkout_safe;
					yourself) ].! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
revparse: aString
	"See git-rev-parse documentation.

	Examples:
		repository revparse: 'HEAD' 	# last commit
		repository revparse: 'HEAD~5'	# 5 commits back from last commit
		repository revparse: 'develop'	# last commit from develop branch
	"

	| object |
	self assert: aString notNil.
	self assert: aString trimBoth notEmpty.
	object := LGitObject of: self.
	self withReturnHandlerDo: [ 
		self
			revparse_single: object
			repo: self
			spec: aString ].
	^ object concreteObject! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tag_list: tag_names repo: repo
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_tag_list #(LGitStringArray * tag_names , LGitRepository repo))
		options: #()! !

!LGitRepository methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
exists
	^ self repositoryReference exists! !

!LGitRepository methodsFor: 'lookup' stamp: ' 1/5/2022 21:01:26'!
lookupBranch: name
	"DO NOT USE: This should be deprecated, but causes a lot of problems."
	"self deprecated: 'Use #lookupBranch:isRemote: instead'."
	self flag: #todo. "Remove this method."
	^ (name includes: $/)
		ifTrue: [ self lookupRemoteBranch: (name withoutPrefix: 'refs/remotes/') ]
		ifFalse: [ self lookupLocalBranch: name ]! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
cloneRemote: aRemote signature: aSignature
	self
		cloneRemote: aRemote
		signature: aSignature
		branch: 'master'! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
clone: aString withCredentials: aCredentialsProvider 
	| cloneOptions |
	cloneOptions := self cloneOptionsStructureClass withCredentialsProvider: aCredentialsProvider.
	self
		clone: aString
		options: cloneOptions! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createBranch: aString targetId: aGitId force: aBoolean
	<todo: 'this method belongs somewhere else'>
	| reference |
	reference := LGitReference of: self.
	reference createDirect: 'refs/heads/' , aString target: aGitId force: aBoolean.
	^ reference! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
cloneHttps: aString
	<todo: 'use exceptions instead of assertion'>
	self assert: (aString beginsWith: 'https://').
	
	self clone: aString! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
cloneSsh: aString
	| credentials cloneOptions |
	credentials := LGitRemote credentialsSsh.
	cloneOptions := self cloneOptionsStructureClass withCredentialsCallback: 
		[ :cred :url :username_from_url :allowed_types :data | 
			allowed_types = 32 
				ifTrue: [ credentials setGitUsernameIn: cred ]
				ifFalse: [ credentials createWith: cred ].
			0 
		].
	
	self
		clone: aString
		options: cloneOptions! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
init
	self initBare: false! !

!LGitRepository methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isUnborn
	^ self repository_is_unborn: self! !

!LGitRepository methodsFor: 'lookup' stamp: ' 1/5/2022 21:01:26'!
lookup: name
	| reference |
	reference := LGitReference of: self.
	self withReturnHandlerDo: [
		self
			reference_lookup: reference
			repo: self
			shorthand: name ].
		
	^ reference! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
clone: out url: url local_path: local_path options: options
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_clone (LGitRepository *out, String url, String local_path, #void *options))
		options: #(optCoerceNilToNull)! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
merge: aLGitAnnotatedCommit 
	| heads |
	heads := (FFIExternalArray externalNewType: LGitAnnotatedCommit size: 1) autoRelease;
		at: 1 put: aLGitAnnotatedCommit handle;
		yourself.

	self withReturnHandlerDo: [
		self merge_heads: heads 
			length: 1 
			merge_options: LGitMergeOptions defaults
			checkout_options: LGitCheckoutOptions defaults 
	]! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
clone: aString options: cloneOptions
	self
		clone: aString
		options: cloneOptions
		to: self repositoryReference! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
branchNames
	^ self branches collect: #name! !

!LGitRepository methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isEmpty
	self exists ifFalse: [ ^ true ].
	
	^ self repository_is_empty: self! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
clone: aString
	| cloneOptions |
	cloneOptions := self cloneOptionsStructureClass defaults.
	self
		clone: aString
		options: cloneOptions! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
checkoutHead
	self withReturnHandlerDo: [ 
		self checkout_head_opts: (
			LGitCheckoutOptions defaults
				checkoutStrategy: LGitCheckoutStrategyEnum git_checkout_safe;
				yourself) ]! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_workdir: repo
	
	^ self ffiCallSafely: #(String git_repository_workdir #(self)) options: #()! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
origin
	^ (LGitRemote of: self named: 'origin') lookup; yourself! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
addRemote: aName url: anUrl
	(LGitRemote of: self named: aName url: anUrl) createWithoutSpec! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
deleteBranch: aGitReference

	(self git_branch_delete: aGitReference) handleLGitReturnCode! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
resetHardTo: target checkoutOptions: options

	^ self
		resetTo: target
		resetType: LGitResetTypeEnum git_reset_hard
		checkoutOptions: options! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
fastForward
	<todo: 'check for conflicts'>
	"currently forces fastForward in every case"
	self head resolve setTarget: (self lookup: 'FETCH_HEAD')! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
checkout: aString options: options
	<todo: 'use proper exceptions'>
	self assert: aString notNil.
	self assert: aString trimBoth notEmpty.
	[ 
		| branch |
		branch := self 
			lookupLocalBranch: aString 
			ifAbsent: [ self createBranchFromOrigin: aString ].
		self setHead: branch.
		self resetHardTo: branch object checkoutOptions: options
	] 
	on: LGit_GIT_EINVALIDSPEC, LGit_GIT_ENOTFOUND do: [
		"aString is not a valid branch name, so try to find a corresponding treeish using revparse, 
		this will handle stuff like 'master~1'"
		| commitish | 
		commitish := self revparse: aString.
		self setHeadDetached: commitish.
		self resetHardTo: commitish object checkoutOptions: options.
	].! !

!LGitRepository methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isOpen
	^ isOpen ifNil: [ false ]! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
index
	| index |
	index := LGitIndex of: self.
	self withReturnHandlerDo: [ self repository_index: index repo: self ].
	^ index! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
beOpen
	isOpen := true! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
repositoryReference
	^ repositoryPath! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
reference_lookup: out repo: repo shorthand: shorthand
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_reference_lookup #(LGitReference * out , self , String shorthand))
		options: #()! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_set_head_detached: commitish
	
	^ self
		ffiCallSafely:
			#(int git_repository_set_head_detached #(self, LGitId * commitish))
		options: #()! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
allBranches
	^ OrderedCollection new: 10 streamContents: [ :stream |
		self allBranchesDo: [ :reference | 
			stream nextPut: reference ] ]! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
checkout: aString
	
	self checkout: aString options: (LGitCheckoutOptions defaults
		checkoutStrategy: LGitCheckoutStrategyEnum git_checkout_safe;
		yourself)! !

!LGitRepository methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
resetHardTo: target

	^ self
		resetHardTo: target
		checkoutOptions: (LGitCheckoutOptions defaults
			checkoutStrategy: LGitCheckoutStrategyEnum git_checkout_force;
			yourself)! !

!LGitRepository methodsFor: 'lookup' stamp: ' 1/5/2022 21:01:26'!
lookupLocalBranch: name
	^ self lookupBranch: name type: LGitBranchTypeEnum git_branch_local! !

!LGitRepository methodsFor: 'lookup' stamp: ' 1/5/2022 21:01:26'!
lookupRemoteBranch: name
	^ self lookupBranch: name type: LGitBranchTypeEnum git_branch_remote! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
setHeadDetached: commitish
	self withReturnHandlerDo: [ 
		self repository_set_head_detached: commitish id
	]! !

!LGitRepository methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createBranch: aString target: aGitReference
	<todo: 'this method belongs somewhere else'>
	^ self createBranch: aString target: aGitReference force: false! !

!LGitRepository methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
allRemotes
	| out |
	
	out := LGitStringArray externalNew autoRelease.
	self remote_list: out.
	^ out strings collect: [ :each | (LGitRemote of: self named: each) lookup ]! !

!LGitRepository methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
initializeOn: aFileReference
	repositoryPath := aFileReference! !

!LGitRepository methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
deleteAllLooseObjectsForReference: aReference
	(self repositoryReference / '.git' / 'objects') children
		select: [ :entry | entry basename ~= 'pack' ]
		thenDo: [ :entry | entry deleteAll ].
	
	"raise an exception if not resolvable"
	self head
	
"	| walker oid baseReference |
	walker := LGitRevwalkType new.
	LG2RevwalkH uniqueInstance
		revwalk_new: walker
		repo: self.
	LG2RevwalkH uniqueInstance
		revwalk_sorting: walker
		sort_mode: 2.
	LG2RevwalkH uniqueInstance
		revwalk_push_ref: walker
		refname: aReference name.

	baseReference := aReference repository repositoryReference / '.git' / 'objects'.
	oid := LGitId new.
	[ (LG2RevwalkH uniqueInstance
		revwalk_next: oid
		walk: walker) isZero ] whileTrue: [
			| fileReference |
			fileReference := baseReference resolve: oid asRelativePathString.
			fileReference delete.
			fileReference parent hasChildren ifFalse: [ fileReference parent delete ] ]"! !

!LGitRepository class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
new
	self error: 'This class should be instantiated with a give path.'! !

!LGitRepository class methodsFor: 'finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #repository_free:! !

!LGitRepository class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
repository_free: handle
	
	^ self ffiCallSafely: #(void git_repository_free #(void *handle)) options: #()! !

!LGitRepository class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
on: aFileReference
	^ self basicNew
		initialize;
		initializeOn: aFileReference! !

!LGitRepositoryCreateCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (LGitRepository **out, String path, Boolean bare, void *payload))! !

!LGitRepositoryNotFound commentStamp: 'TorstenBergmann 6/2/2021 21:14'!
A git repository was not found!
!LGitRepositoryObject commentStamp: 'TorstenBergmann 6/2/2021 21:11'!
Common superclass for objects with a git repo!
!LGitRepositoryObject methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
repository

	^ repository! !

!LGitRepositoryObject methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
repository: aRepository

	repository := aRepository! !

!LGitRepositoryObject class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
new
	self error: 'Use #of: to create an instance of ', self name! !

!LGitRepositoryObject class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository
	^ self basicNew
		initialize;
		repository: aRepository;
		yourself! !

!LGitResetTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_reset_mixed
	^ self basicNew
		value: 2;
		yourself! !

!LGitResetTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_reset_soft
	^ self basicNew
		value: 1;
		yourself! !

!LGitResetTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_reset_hard
	^ self basicNew
		value: 3;
		yourself! !

!LGitResetTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^ #(
		GIT_RESET_SOFT  1 "Move the head to the given commit"
		GIT_RESET_MIXED 2 "SOFT plus reset index to the commit"
		GIT_RESET_HARD  3 "MIXED plus changes in working tree discarded"
	)! !

!LGitReturnCodeEnum methodsFor: '*Iceberg-Core' stamp: ''!
asBoolean
	^ self value = 0 ifTrue: false ifFalse: 
		[ self value = 1 ifTrue: true ifFalse: 
		[ self error: self printString, ' can''t be converted to a boolean' ]]! !

!LGitReturnCodeEnum methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isOk
	^ value = 0! !

!LGitReturnCodeEnum methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
handlers
	^ self class handlers! !

!LGitReturnCodeEnum methodsFor: 'handling' stamp: ' 1/5/2022 21:01:26'!
handleLGitReturnCode
	| handler |
	self isOk
		ifTrue: [ ^ self ].
	handler := self handlers
		at: self symbol
		ifAbsent: [ LGitNoReturnCodeHandlerDefined signalWith: self ].
	^ handler isError
		ifTrue: [ handler signalWith: LGitError last ]
		ifFalse: [ self ]! !

!LGitReturnCodeEnum class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
setUpHandlers
	^ (self declaration associations collect: [ :nameToValue |
		nameToValue key -> (LGitCallReturnHandler for: (self perform: nameToValue key)) ]) asDictionary! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_eapplied
	^ self basicNew
		value: -18;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_ok
	^ self basicNew
		value: 0;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_enonfastforward
	^ self basicNew
		value: -11;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_passthrough
	^ self basicNew
		value: -30;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_euncommitted
	^ self basicNew
		value: -22;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_emodified
	^ self basicNew
		value: -15;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_eunmerged
	^ self basicNew
		value: -10;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_enotfound
	^ self basicNew
		value: -3;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_einvalidspec
	^ self basicNew
		value: -12;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_ebufs
	^ self basicNew
		value: -6;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_epeel
	^ self basicNew
		value: -19;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_ecertificate
	^ self basicNew
		value: -17;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_eunbornbranch
	^ self basicNew
		value: -9;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_econflict
	^ self basicNew
		value: -13;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_eauth
	^ self basicNew
		value: -16;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_elocked
	^ self basicNew
		value: -14;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_error
	^ self basicNew
		value: -1;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_eeof
	^ self basicNew
		value: -20;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_einvalid
	^ self basicNew
		value: -21;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_eexists
	^ self basicNew
		value: -4;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_iterover
	^ self basicNew
		value: -31;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'enum description' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^ #(
			GIT_OK           0		"< No error "

			GIT_ERROR       -1		"< Generic error "
			GIT_ENOTFOUND   -3		"< Requested object could not be found "
			GIT_EEXISTS     -4		"< Object exists preventing operation "
			GIT_EAMBIGUOUS  -5		"< More than one object matches "
			GIT_EBUFS       -6		"< Output buffer too short to hold data "

			"GIT_EUSER is a special error that is never generated by libgit2
			 * code.  You can return it from a callback (e.g to stop an iteration)
			 * to know that it was generated by the callback and not by libgit2.
			 "
			GIT_EUSER       -7

			GIT_EBAREREPO         -8	"< Operation not allowed on bare repository "
			GIT_EUNBORNBRANCH     -9	"< HEAD refers to branch with no commits "
			GIT_EUNMERGED        -10	"< Merge in progress prevented operation "
			GIT_ENONFASTFORWARD  -11	"< Reference was not fast-forwardable "
			GIT_EINVALIDSPEC     -12	"< Name/ref spec was not in a valid format "
			GIT_ECONFLICT        -13	"< Checkout conflicts prevented operation "
			GIT_ELOCKED          -14	"< Lock file prevented operation "
			GIT_EMODIFIED        -15	"< Reference value does not match expected "
			GIT_EAUTH            -16      "< Authentication error "
			GIT_ECERTIFICATE     -17      "< Server certificate is invalid "
			GIT_EAPPLIED         -18	"< Patch/merge has already been applied "
			GIT_EPEEL            -19      "< The requested peel operation is not possible "
			GIT_EEOF             -20      "< Unexpected EOF "
			GIT_EINVALID         -21      "< Invalid operation or input "
			GIT_EUNCOMMITTED     -22	"< Uncommitted changes in index prevented operation "

			GIT_PASSTHROUGH      -30	"< Internal only "
			GIT_ITEROVER         -31	"< Signals end of iteration with iterator "
		)! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_ebarerepo
	^ self basicNew
		value: -8;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'handlers' stamp: ' 1/5/2022 21:01:26'!
handlers
	^ handlers ifNil: [ handlers := self setUpHandlers ]! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_eambiguous
	^ self basicNew
		value: -5;
		yourself! !

!LGitReturnCodeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_euser
	^ self basicNew
		value: -7;
		yourself! !

!LGitRevwalk commentStamp: 'TorstenBergmann 6/2/2021 22:18'!
See [https://libgit2.org/libgit2/#HEAD/group/revwalk](https://libgit2.org/libgit2/#HEAD/group/revwalk)!
!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
beSortedParentsBeforeChildren
	self basicSort: LGitRevwalkSortTypeEnum git_sort_topological! !

!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
pushRange: range
	self withReturnHandlerDo: [ self revwalk_push_range: range ]! !

!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
pushHead
	self withReturnHandlerDo: [ self revwalk_push_head: self ]! !

!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
pushCommit: aLGitId 
	self withReturnHandlerDo: [ self revwalk_push: aLGitId ]! !

!LGitRevwalk methodsFor: 'walking' stamp: ' 1/5/2022 21:01:26'!
select: selectionBlock thenDo: actionBlock
	self do: [ :result | 
		(selectionBlock value: result) 
			ifTrue: [ actionBlock value: result ] ]! !

!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
hideReference: aReference
	self withReturnHandlerDo: [
		self
			revwalk_hide_ref: self
			refname: aReference name ]! !

!LGitRevwalk methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
basicNext
	"Note: in the C code you would check the return code to see when the loop is over.

	This method uses instances variables to enable more Smalltalk like looping:
	[ walk hasNext ] whileTrue: [ walk next ]."
	| previousCommit nextId |
	previousCommit := currentCommit.
	nextId := self basicNextObjectId.
	currentCommit := self hasNext
		ifTrue: [
			LGitCommit
				of: self repository
				fromId: nextId ]
		ifFalse: [ nil ].
	
	^ previousCommit! !

!LGitRevwalk methodsFor: 'walking' stamp: ' 1/5/2022 21:01:26'!
do: aBlock
	[ self hasNext ] whileTrue: [ 
		aBlock value: self next
	]! !

!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
hideCommit: aLGitId
	self withReturnHandlerDo: [ self revwalk_hide: aLGitId ]! !

!LGitRevwalk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_next: out walk: walk
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_revwalk_next #(LGitId * out , self))
		options: #()! !

!LGitRevwalk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_push_head: walk
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_revwalk_push_head #(self))
		options: #()! !

!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
reset
	self withReturnHandlerDo: [ self revwalk_reset: self ]! !

!LGitRevwalk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_hide_ref: walk refname: refname
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_revwalk_hide_ref #(self , String refname))
		options: #()! !

!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
beSortedReverse
	self basicSort: LGitRevwalkSortTypeEnum git_sort_reverse! !

!LGitRevwalk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_push_ref: walk refname: refname
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_revwalk_push_ref #(self , String refname))
		options: #()! !

!LGitRevwalk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_sorting: walk sort_mode: sort_mode
	
	^ self
		ffiCallSafely: #(void git_revwalk_sorting #(self , uint sort_mode))
		options: #()! !

!LGitRevwalk methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
hasNext
	^ hasNext ifNil: [
		self basicNext.
		hasNext ]! !

!LGitRevwalk methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
basicSort: sortingEnum
	sorting := sorting
		ifNil: [ sortingEnum value ]
		ifNotNil: [ sorting bitOr: sortingEnum value ].
		
	self withReturnHandlerDo: [
		self
			revwalk_sorting: self
			sort_mode: sorting ]! !

!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
next
	self hasNext ifFalse: [ ^ LGit_GIT_ITEROVER signal ].
	
	^ self basicNext! !

!LGitRevwalk methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
basicNextObjectId
	| nextId returnCode |
	nextId := LGitId new.
	returnCode := self
		revwalk_next: nextId
		walk: self.
	(returnCode ~= LGitReturnCodeEnum git_iterover and: [ 
		returnCode ~= LGitReturnCodeEnum git_ok ]) ifTrue: [ returnCode handleLGitReturnCode ].
	hasNext := returnCode ~= LGitReturnCodeEnum git_iterover.
	
	^ nextId! !

!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
pushReference: aReference
	self withReturnHandlerDo: [
		self
			revwalk_push_ref: self
			refname: aReference name ]! !

!LGitRevwalk methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
createNew
	self withReturnHandlerDo: [
		self
			revwalk_new: self
			repo: self repository ]! !

!LGitRevwalk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_new: out repo: repo
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_revwalk_new #(LGitRevwalk * self , LGitRepository repo))
		options: #()! !

!LGitRevwalk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_push: commitId
	^ self 
		ffiCallSafely:
			#(LGitReturnCodeEnum git_revwalk_push #(self , LGitId * commitId))
		options: #()! !

!LGitRevwalk methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
beSortedByCommitTime
	self basicSort: LGitRevwalkSortTypeEnum git_sort_time! !

!LGitRevwalk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_hide: commitId
	^ self 
		ffiCallSafely:
			#(LGitReturnCodeEnum git_revwalk_hide #(self , LGitId * commitId))
		options: #()! !

!LGitRevwalk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_push_range: range
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_revwalk_push_range #(self , String range))
		options: #()! !

!LGitRevwalk methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_reset: revwalk
	
	^ self ffiCallSafely: #(void git_revwalk_reset #(self)) options: #()! !

!LGitRevwalk class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #revwalk_free:! !

!LGitRevwalk class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
revwalk_free: handle
	
	^ self ffiCallSafely: #(void git_revwalk_free #(void *handle)) options: #()! !

!LGitRevwalk class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: aRepository
	^ (super of: aRepository)
		createNew;
		yourself! !

!LGitRevwalkSortTypeEnum commentStamp: 'MaxLeske 3/1/2015 16:39'!
/**
 * Sort the repository contents in no particular ordering;
 * this sorting is arbitrary, implementation-specific
 * and subject to change at any time.
 * This is the default sorting for new walkers.
 */
#define GIT_SORT_NONE			(0)

/**
 * Sort the repository contents in topological order
 * (parents before children); this sorting mode
 * can be combined with time sorting.
 */
#define GIT_SORT_TOPOLOGICAL (1 << 0)
/**
 * Sort the repository contents by commit time;
 * this sorting mode can be combined with
 * topological sorting.
 */
#define GIT_SORT_TIME			(1 << 1)

/**
 * Iterate through the repository contents in reverse
 * order; this sorting mode can be combined with
 * any of the above.
 */
#define GIT_SORT_REVERSE		(1 << 2)!
!LGitRevwalkSortTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_sort_time
	^ self basicNew
		value: 2;
		yourself! !

!LGitRevwalkSortTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_SORT_NONE 0
	GIT_SORT_TOPOLOGICAL 1
	GIT_SORT_TIME 2
	GIT_SORT_REVERSE 4
	)! !

!LGitRevwalkSortTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_sort_reverse
	^ self basicNew
		value: 4;
		yourself! !

!LGitRevwalkSortTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_sort_topological
	^ self basicNew
		value: 1;
		yourself! !

!LGitRevwalkSortTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_sort_none
	^ self basicNew
		value: 0;
		yourself! !

!LGitSignature commentStamp: '<historical>'!
A LGitSignature represents the information of a specific person for a commit.

Instance Variables
	email:		ByteString
	name:		ByteString
	when:		DateAndTime!
!LGitSignature methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_when: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_PRIM_WHEN put: anObject getHandle length: LGitTime byteSize! !

!LGitSignature methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
email
	^ self prim_email readStringUTF8! !

!LGitSignature methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
= anObject
	^ self == anObject
		or: [ self class == anObject class
			and: [ self name = anObject name
				and: [ self email = anObject email
					and: [ self dateAndTime = anObject dateAndTime ] ] ] ]! !

!LGitSignature methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
hash
	^ ((self name hash bitXor: self email hash) bitXor: self email hash) bitXor: self dateAndTime hash! !

!LGitSignature methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_name: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_NAME put: anObject getHandle.! !

!LGitSignature methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_name
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_NAME) type: ExternalType char asPointerType! !

!LGitSignature methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_when
	"This method was automatically generated"
	^ LGitTime fromHandle: (handle referenceStructAt: OFFSET_PRIM_WHEN length: LGitTime byteSize)! !

!LGitSignature methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
name
	^ self prim_name readStringUTF8! !

!LGitSignature methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
name: aString
	self prim_name: aString asLGitExternalString! !

!LGitSignature methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
email: aString
	self prim_email: aString asLGitExternalString! !

!LGitSignature methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_email
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_EMAIL) type: ExternalType char asPointerType! !

!LGitSignature methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_email: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_EMAIL put: anObject getHandle.! !

!LGitSignature methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
dateAndTime
	^ self prim_when asDateAndTime! !

!LGitSignature methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream
	aStream
		nextPutAll: self name;
		nextPutAll: ' <';
		nextPutAll: self email;
		nextPutAll: '> '.
	self dateAndTime printOn: aStream! !

!LGitSignature methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
dateAndTime: aDateAndTime
	self prim_when: (LGitTime fromDateAndTime: aDateAndTime)! !

!LGitSignature class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
name: nameString email: emailString when: dateAndTime
	"Allocate an instance on the external heap and initialize it.
	Use autoRelease so the data will be freed when the instance is gc'ed."
	^ self externalNew
			name: nameString;
			email: emailString;
			dateAndTime: dateAndTime;
			autoRelease;
			yourself! !

!LGitSignature class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
signature_free: handle 
	^ self
		ffiCallSafely: #(void git_signature_free(void *handle))
		options: #(  )! !

!LGitSignature class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		char * name;
		char * email;
		LGitTime when;
	)! !

!LGitSignature class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
name: nameString email: emailString
	^ self name: nameString email: emailString when: DateAndTime now! !

!LGitSimilarityCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (int *score, void *siga, void *sigb, void *payload))! !

!LGitStatusCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (String path, uint status_flags, void *payload))! !

!LGitStatusList commentStamp: 'TorstenBergmann 6/2/2021 22:21'!
See [https://libgit2.org/libgit2/#HEAD/group/status](https://libgit2.org/libgit2/#HEAD/group/status)!
!LGitStatusList methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
status_list_get_perfdata: out status: status
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_status_list_get_perfdata #(LGitPerfData * out , self))
		options: #()! !

!LGitStatusList class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #status_list_free:! !

!LGitStatusList class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
status_list_free: handle
	
	^ self
		ffiCallSafely: #(void git_status_list_free #(void *handle))
		options: #()! !

!LGitStatusTypeEnum commentStamp: 'MaxLeske 8/13/2015 10:34'!
/**
 * Status flags for a single file.
 *
 * A combination of these values will be returned to indicate the status of
 * a file.  Status compares the working directory, the index, and the
 * current HEAD of the repository.  The `GIT_STATUS_INDEX` set of flags
 * represents the status of file in the index relative to the HEAD, and the
 * `GIT_STATUS_WT` set of flags represent the status of the file in the
 * working directory relative to the index.
 */!
!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_wt_deleted
	^ self basicNew
		value: 512;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_index_deleted
	^ self basicNew
		value: 4;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_index_modified
	^ self basicNew
		value: 2;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_wt_new
	^ self basicNew
		value: 128;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_index_new
	^ self basicNew
		value: 1;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_index_renamed
	^ self basicNew
		value: 8;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_conflicted
	^ self basicNew
		value: 32768;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_ignored
	^ self basicNew
		value: 16384;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_current
	^ self basicNew
		value: 0;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
		GIT_STATUS_CURRENT  0
		GIT_STATUS_INDEX_NEW         "1 bitShift: 0" 1
		GIT_STATUS_INDEX_MODIFIED    "1 bitShift: 1" 2
		GIT_STATUS_INDEX_DELETED     "1 bitShift: 2" 4
		GIT_STATUS_INDEX_RENAMED     "1 bitShift: 3" 8
		GIT_STATUS_INDEX_TYPECHANGE  "1 bitShift: 4" 16
		GIT_STATUS_WT_NEW            "1 bitShift: 7" 128
		GIT_STATUS_WT_MODIFIED       "1 bitShift: 8" 256
		GIT_STATUS_WT_DELETED        "1 bitShift: 9" 512
		GIT_STATUS_WT_TYPECHANGE     "1 bitShift: 10" 1024
		GIT_STATUS_WT_RENAMED        "1 bitShift: 11" 2048
		GIT_STATUS_WT_UNREADABLE     "1 bitShift: 12" 4096
		GIT_STATUS_IGNORED           "1 bitShift: 14" 16384
		GIT_STATUS_CONFLICTED        "1 bitShift: 15" 32768
)! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_wt_renamed
	^ self basicNew
		value: 2048;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_wt_unreadable
	^ self basicNew
		value: 4096;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_wt_typechange
	^ self basicNew
		value: 1024;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_index_typechange
	^ self basicNew
		value: 16;
		yourself! !

!LGitStatusTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_status_wt_modified
	^ self basicNew
		value: 256;
		yourself! !

!LGitStringArray methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_count
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_COUNT! !

!LGitStringArray methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
strings
	| externalArray |
	self count = 0
		ifTrue: [ ^ #() ].
	externalArray := LGitExternalStringArray 
		onAddress: self prim_strings getHandle 
		size: self count.
	^externalArray asArray! !

!LGitStringArray methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_strings: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PRIM_STRINGS put: anObject getHandle.! !

!LGitStringArray methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
count: anInteger
	self prim_count: anInteger! !

!LGitStringArray methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
strings: aCollection
	| array |
	array := LGitExternalStringArray fromCollection: aCollection.
	self prim_strings: array! !

!LGitStringArray methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
count
	^ self prim_count! !

!LGitStringArray methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_strings
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PRIM_STRINGS) type: ExternalType void asPointerType! !

!LGitStringArray methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_count: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_COUNT put: anObject! !

!LGitStringArray class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
strarray_free: handle
	"libgit2 will also free all the strings in this struct"
	
	^ self
		ffiCallSafely: #(void git_strarray_free(void *handle))
		options: #()! !

!LGitStringArray class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #strarray_free:! !

!LGitStringArray class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
		LGitExternalStringArray * strings;
		size_t count;
	)! !

!LGitStringArray class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
withAll: stringCollection
	"Allocate an instance on the external heap and initialize it with
	<stringCollection>. Use autoRelease so the data will be freed when
	the instance is gc'ed."
	^ self externalNew
		count: stringCollection size;
		strings: stringCollection;
		autoRelease;
		yourself! !

!LGitStructVersionsEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
		GIT_REMOTE_CALLBACKS_VERSION_1 1
	)! !

!LGitStructVersionsEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_remote_callbacks_version_1
	^ self basicNew
		value: 1;
		yourself! !

!LGitStructWithDefaults methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
initialize
	super initialize.
	
	"Options are only ever used during a single setup function call.
	The contents of the struct are then copied to a libgit2 internal
	struct."
	self autoRelease! !

!LGitStructWithDefaults methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
initializeWithDefaults
	self subclassResponsibility! !

!LGitStructWithDefaults class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
defaults
	^ self externalNew
		initializeWithDefaults;
		yourself! !

!LGitSubmoduleIgnoreTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_submodule_ignore_dirty
	^ self basicNew
		value: 3;
		yourself! !

!LGitSubmoduleIgnoreTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_submodule_ignore_untracked
	^ self basicNew
		value: 2;
		yourself! !

!LGitSubmoduleIgnoreTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_submodule_ignore_default
	^ self basicNew
		value: 0;
		yourself! !

!LGitSubmoduleIgnoreTypeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_SUBMODULE_IGNORE_RESET     -1 "reset to on-disk value"

	GIT_SUBMODULE_IGNORE_NONE      1  "any change or untracked == dirty"
	GIT_SUBMODULE_IGNORE_UNTRACKED 2  "dirty if tracked files change"
	GIT_SUBMODULE_IGNORE_DIRTY     3  "only dirty if HEAD moved"
	GIT_SUBMODULE_IGNORE_ALL       4  "never dirty"

	GIT_SUBMODULE_IGNORE_DEFAULT   0
)! !

!LGitSubmoduleIgnoreTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_submodule_ignore_none
	^ self basicNew
		value: 1;
		yourself! !

!LGitSubmoduleIgnoreTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_submodule_ignore_reset
	^ self basicNew
		value: -1;
		yourself! !

!LGitSubmoduleIgnoreTypeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_submodule_ignore_all
	^ self basicNew
		value: 4;
		yourself! !

!LGitTag commentStamp: 'NicoPasserini 11/3/2016 15:40'!
A LGitTag represents a git tag and the associate information.

Instance Variables
	handle:		NBExternalObject

handle
	- the handle to the external data object
!
!LGitTag methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tag_name
	^ self ffiCallSafely: #(String git_tag_name #(self)) options: #()! !

!LGitTag methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
name
	^ self tag_name! !

!LGitTag methodsFor: '*Iceberg-Adapters' stamp: ''!
asIcebergObjectInRepository: backend
	^ IceTag named: self name inRepository: backend! !

!LGitTag methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
object
	| peeled |
	peeled := LGitObject of: self repository.
	self tag_peel: peeled.
	^ peeled concreteObject! !

!LGitTag methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tag_peel: result
	^ self
		ffiCallSafely: #(#LGitReturnCodeEnum git_tag_peel(LGitObject *result, self))
		options: #()! !

!LGitTag class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isType: aType
	^ aType = LGitObjectTypeEnum git_obj_tag! !

!LGitTag class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #tag_free:! !

!LGitTag class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tag_free: handle
	^ self ffiCallSafely: #(void git_tag_free #(void *handle)) options: #()! !

!LGitTime methodsFor: 'converting' stamp: ' 1/5/2022 21:01:26'!
asDateAndTime
	^ (DateAndTime fromUnixTime: self time) 
		offset: self offset;
		yourself! !

!LGitTime methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
= anObject
	^ self == anObject
		or: [ self class == anObject class
			and: [ self time = anObject time
				and: [  self offset = anObject offset ] ] ]! !

!LGitTime methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
hash
	^ (super hash bitXor: self time) bitXor: self offset! !

!LGitTime methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_time: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_PRIM_TIME put: anObject! !

!LGitTime methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
offset: anInteger
	self prim_offset: anInteger! !

!LGitTime methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
time
	^ self prim_time! !

!LGitTime methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_offset: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PRIM_OFFSET put: anObject! !

!LGitTime methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
offset
	^ self prim_offset! !

!LGitTime methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
time: anInteger
	^ self prim_time: anInteger! !

!LGitTime methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_time
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_PRIM_TIME! !

!LGitTime methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream
	self asDateAndTime printOn: aStream! !

!LGitTime methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_offset
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PRIM_OFFSET! !

!LGitTime class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromDateAndTime: aDateAndTime
	^ self new 
		time: aDateAndTime asUnixTime;
		offset: aDateAndTime offset asMinutes asInteger;
		yourself! !

!LGitTime class methodsFor: 'fields description' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
	int64 time;
	int offset;
	)! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_indexed_objects
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_INDEXED_OBJECTS! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_received_objects: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_RECEIVED_OBJECTS put: anObject! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_total_deltas: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_TOTAL_DELTAS put: anObject! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_local_objects: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_LOCAL_OBJECTS put: anObject! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_received_objects
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_RECEIVED_OBJECTS! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_total_deltas
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_TOTAL_DELTAS! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_received_bytes: anObject
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_RECEIVED_BYTES put: anObject! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_indexed_deltas: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_INDEXED_DELTAS put: anObject! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_indexed_objects: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_INDEXED_OBJECTS put: anObject! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_local_objects
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_LOCAL_OBJECTS! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_received_bytes
	"This method was automatically generated"
	^handle platformSizeTAt: OFFSET_PRIM_RECEIVED_BYTES! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_total_objects: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_PRIM_TOTAL_OBJECTS put: anObject! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_indexed_deltas
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_INDEXED_DELTAS! !

!LGitTransferProgress methodsFor: 'libgit - fields' stamp: ' 1/5/2022 21:01:26'!
prim_total_objects
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_PRIM_TOTAL_OBJECTS! !

!LGitTransferProgress class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fieldsDesc
	^#(
	uint total_objects;
	uint indexed_objects;
	uint received_objects;
	uint local_objects;
	uint total_deltas;
	uint indexed_deltas;
	size_t received_bytes;
	)! !

!LGitTransferProgressCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (LGitTransferProgress *stats, void *payload))! !

!LGitTransport commentStamp: 'TorstenBergmann 6/2/2021 22:28'!
The Git transport is a simple, unauthenticated server that takes the command with which the client wishes to communicate and executes it and connects it to the requesting process.!
!LGitTransportCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int git_transport_cb(LGitTransport *out, LGitRemote owner, void *param))! !

!LGitTransportCertificateCheckCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (void *cert, int valid, String host, void *payload))! !

!LGitTransportMessageCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (String str, int len, void *payload))! !

!LGitTree commentStamp: 'TorstenBergmann 6/2/2021 22:03'!
A git repository can support multiple working trees!
!LGitTree methodsFor: 'traversing' stamp: ' 1/5/2022 21:01:26'!
subTreeEntries
	^ self entries select: [ :entry |
		entry type = LGitObjectTypeEnum git_obj_tree ]! !

!LGitTree methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isEmpty
	^ self entries isEmpty! !

!LGitTree methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
get_id_data
	^ self tree_id: self! !

!LGitTree methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
= anObject
	^ self == anObject or: [ 
		self class == anObject class and: [ 
			self isReady and: [
				anObject isReady and: [
					self id = anObject id ] ] ] ]! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
names
	<todo: 'decide what to do with this:
	- will not work for trees not referenced from head (e.g. in an older commit)
	- very slow for large repositories because every entry is visited'>
	| names |
	names := OrderedCollection new.
	self repository head object tree allEntriesDo: [ :name :entry :payload |
		entry repository: self repository.
		entry object = self ifTrue: [ names add: name ].
		0 ].
	
	^ names! !

!LGitTree methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
hash
	^ super hash bitXor: self id asInteger! !

!LGitTree methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_owner: tree
	
	^ self ffiCallSafely: #(LGitRepository git_tree_owner #(self)) options: #()! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
entryByName: aString 
	^ self entryByName: aString ifAbsent: [ 
		self error: ('Entry {1} is not present in tree {2}' format: {aString. self})].! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
entryByRelativePath: aString ifAbsent: aBlock
    | entry |
    entry := (LGitTreeEntry of: self repository) autoRelease.
    self tree_entry_bypath: entry path: aString.
    ^ entry isNull
        ifTrue: [ aBlock value ]
        ifFalse: [ 
            entry repository: self repository.
            entry ]! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
relativePath: aString
    "remove leading / characters"
        ^ aString trimLeft: [ :c | c = $/ ]! !

!LGitTree methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_id: tree
	
	^ self ffiCallSafely: #(void * git_tree_id #(self)) options: #()! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
entryByPath: aString ifAbsent: aBlock
    ^ self 
        entryByRelativePath: (self relativePath: aString)
        ifAbsent: aBlock! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
owner
	^ self tree_owner: self! !

!LGitTree methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
lookup
	self withReturnHandlerDo: [
		self
			tree_lookup: self
			repo: self repository
			id: self id ].
	self autoRelease! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
matchesPathSpec: aPathSpec
	^ (self 
		pathspec_match: aPathSpec 
		flags: LGitPathSpecFlagTypeEnum git_pathspec_no_match_error) == 0! !

!LGitTree methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream
	aStream
		nextPutAll: 'number of entries: ';
		nextPutAll: self size asString! !

!LGitTree methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entry_byindex: tree idx: idx
	
	^ self
		ffiCallSafely: #(LGitTreeEntry git_tree_entry_byindex #(self , size_t idx))
		options: #()! !

!LGitTree methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
pathspec_match: ps flags: flags
	^ self ffiCallSafely: #(int git_pathspec_match_tree(0, self, LGitPathSpecFlagTypeEnum flags, LGitPathSpec ps))! !

!LGitTree methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entry_byname: tree name: name
	
	^ self
		ffiCallSafely: #(LGitTreeEntry git_tree_entry_byname #(self , String name))
		options: #()! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
entryByName: aString ifAbsent: aBlock
	| entry |
	entry := self tree_entry_byname: self name: aString.
	(entry isNil or: [ entry isNull ])
		ifTrue: [ ^aBlock value ].
	entry repository: self repository.
	^entry! !

!LGitTree methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_walk: tree mode: mode callback: callback payload: payload
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_tree_walk #(LGitTree tree , LGitTreewalkModeEnum mode , LGitTreewalkCallback callback , void *payload))
		options: #(optMayGC optCoerceNilToNull)! !

!LGitTree methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entrycount: tree
	
	^ self ffiCallSafely: #(int git_tree_entrycount #(self)) options: #()! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
diffTo: aTree
	| diff |
	diff := LGitDiff of: self repository.
	diff 
		diffTree: self 
		toTree: aTree.
	^ diff! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
entryByPath: aString 
	^ self entryByPath: aString ifAbsent: [ 
		self error: ('Entry {1} is not present in tree {2}' format: {aString. self})].! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
diffTo: aTree options: options
	| diff |
	diff := LGitDiff of: self repository.
	diff 
		diffTree: self 
		toTree: aTree
		options: options.
	^ diff! !

!LGitTree methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isLeaf
	^ self entries noneSatisfy: [ :entry |
		entry type = LGitObjectTypeEnum git_obj_tree  ]! !

!LGitTree methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entry_bypath: out path: path
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_tree_entry_bypath #(LGitTreeEntry * out, self, String path))
		options: #()! !

!LGitTree methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isTree
	^ true! !

!LGitTree methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
size
	^ self tree_entrycount: self! !

!LGitTree methodsFor: 'enumerating' stamp: ' 1/5/2022 21:01:26'!
allEntriesDo: aBlock
	"The entries will be traversed in the specified order, children subtrees will be automatically loaded as required, and the callback will be called once per entry with the current (relative) root for the entry and the entry data itself.

If the callback returns a positive value, the passed entry will be skipped on the traversal (in pre mode). A negative value stops the walk."
	self withReturnHandlerDo: [ 
		self
			tree_walk: self
			mode: LGitTreewalkModeEnum git_treewalk_pre
			callback: (LGitTreewalkCallback on: aBlock)
			payload: ExternalAddress null ]! !

!LGitTree methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_lookup: out repo: repo id: objectId
	
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_tree_lookup #(LGitTree * out , LGitRepository repo , LGitId * objectId))
		options: #()! !

!LGitTree methodsFor: 'traversing' stamp: ' 1/5/2022 21:01:26'!
entries
	| entryCount |
	entryCount := self tree_entrycount: self.
	
	^ Array new: entryCount streamContents: [ :stream |
		0 to: entryCount - 1 do: [ :i || entry |
			entry := self tree_entry_byindex: self idx: i.
			entry parent: self.
			entry repository: self repository.
			stream nextPut: entry ] ]! !

!LGitTree class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isType: aType
	^ aType = LGitObjectTypeEnum git_obj_tree! !

!LGitTree class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #tree_free:! !

!LGitTree class methodsFor: 'accessing - defaults' stamp: ' 1/5/2022 21:01:26'!
defaultFilemode
	^ LGitFilemodeEnum git_filemode_tree! !

!LGitTree class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_free: handle
	
	^ self ffiCallSafely: #(void git_tree_free #(void *handle)) options: #()! !

!LGitTreeBuilder commentStamp: 'TorstenBergmann 6/2/2021 22:17'!
Builder for working trees

See [https://libgit2.org/libgit2/#HEAD/group/treebuilder](https://libgit2.org/libgit2/#HEAD/group/treebuilder)!
!LGitTreeBuilder methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
treebuilder_clear: bld
	
	^ self ffiCallSafely: #(void git_treebuilder_clear #(self)) options: #()! !

!LGitTreeBuilder methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
treebuilder_write: id bld: bld
	
	^ self
		ffiCallSafely: #(LGitReturnCodeEnum git_treebuilder_write #(LGitId * id , self))
		options: #()! !

!LGitTreeBuilder methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
initializeWithTree: aTree
	self withReturnHandlerDo: [
		self
			treebuilder_new: self
			repo: self repository
			source: (aTree ifNotNil: #handle) ]! !

!LGitTreeBuilder methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
treebuilder_new: out repo: repo source: source
	^ self
		ffiCall:
			#(LGitReturnCodeEnum git_treebuilder_new #(LGitTreeBuilder * out , LGitRepository repo , void * source))
		options: #(+ optCoerceNilToNull)! !

!LGitTreeBuilder methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
addEntryWithId: oidStruct filename: aString filemode: anInteger
	self withReturnHandlerDo: [ 
			self
				treebuilder_insert: (LGitTreeEntry of: self repository)
				bld: self
				filename: aString
				id: oidStruct
				filemode: anInteger ]! !

!LGitTreeBuilder methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
getEntryNamed: aString
	| entry |
	entry := self
		treebuilder_get: self
		filename: aString.
	entry repository: self repository.
	
	^ entry! !

!LGitTreeBuilder methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
createNew
	self withReturnHandlerDo: [ 
		self 
			treebuilder_new: self
			repo: self repository
			source: self ffiNull handle ]! !

!LGitTreeBuilder methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
addEntry: aLGitObject filename: aString
	self 
		addEntryWithId: aLGitObject id 
		filename: aString 
		filemode: aLGitObject class defaultFilemode! !

!LGitTreeBuilder methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
write
	| id errorCode |
	id := LGitId new.
	errorCode := self
		treebuilder_write: id
		bld: self.
		
	errorCode ~= 0 ifTrue: [ LGitWritingTreeFailed ].
	
	^ id! !

!LGitTreeBuilder methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
newTree
	^ LGitTree of: self repository fromId: self write! !

!LGitTreeBuilder methodsFor: 'operations' stamp: ' 1/5/2022 21:01:26'!
clear
	self treebuilder_clear: self! !

!LGitTreeBuilder methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
treebuilder_get: bld filename: filename
	
	^ self
		ffiCallSafely: #(LGitTreeEntry git_treebuilder_get #(self , String filename))
		options: #()! !

!LGitTreeBuilder methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
treebuilder_insert: out bld: bld filename: filename id: id filemode: filemode
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_treebuilder_insert #(LGitTreeEntry * out , self , String filename , LGitId * id , LGitFilemodeEnum filemode))
		options: #()! !

!LGitTreeBuilder class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #treebuilder_free:! !

!LGitTreeBuilder class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
treebuilder_free: handle
	
	^ self
		ffiCallSafely: #(void git_treebuilder_free #(void *handle))
		options: #()! !

!LGitTreeBuilder class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
of: repository fromTree: aTree
	^ (self of: repository)
		initializeWithTree: aTree;
		yourself! !

!LGitTreeBuilder class methodsFor: 'instance creation' stamp: ' 1/5/2022 21:01:26'!
fromTree: aTree
	self validate: aTree shouldBe: LGitTree.
	^ self of: aTree repository fromTree: aTree! !

!LGitTreeEntry commentStamp: 'TorstenBergmann 6/2/2021 22:03'!
An entry in a git tree!
!LGitTreeEntry methodsFor: 'traversing' stamp: ' 1/5/2022 21:01:26'!
subTreeEntries
	^ self object subTreeEntries! !

!LGitTreeEntry methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entry_cmp: e1 e2: e2
	
	^ self
		ffiCallSafely: #(int git_tree_entry_cmp #(self , LGitTreeEntry e2))
		options: #()! !

!LGitTreeEntry methodsFor: 'comparing' stamp: ' 1/5/2022 21:01:26'!
= anObject
	^ self == anObject or: [
		self class == anObject class and: [ 
			self isReady and: [ 
				anObject isReady and: [ 
					self compare: anObject ] ] ] ]! !

!LGitTreeEntry methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
filename
	^ self tree_entry_name: self! !

!LGitTreeEntry methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entry_type: entry
	
	^ self
		ffiCallSafely: #(LGitObjectTypeEnum git_tree_entry_type #(self))
		options: #()! !

!LGitTreeEntry methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
parent: aLGitTree 
	
	parent := aLGitTree! !

!LGitTreeEntry methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
entryByPath: aString ifAbsent: aBlock
	^ self object entryByPath: aString ifAbsent: aBlock! !

!LGitTreeEntry methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entry_to_object: object_out repo: repo entry: entry
	
	^ self
		ffiCallSafely:
			#(LGitReturnCodeEnum git_tree_entry_to_object #(LGitObject * object_out , LGitRepository repo , self))
		options: #()! !

!LGitTreeEntry methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream 
	aStream nextPutAll: self filename surroundedBySingleQuotes! !

!LGitTreeEntry methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
type
	^ self tree_entry_type: handle! !

!LGitTreeEntry methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entry_id: entry
	
	^ self ffiCallSafely: #(void * git_tree_entry_id #(self)) options: #()! !

!LGitTreeEntry methodsFor: '*Iceberg-Adapters' stamp: ''!
readStreamDo: aBlock
	^ aBlock value: (ReadStream on: self object contents asString)! !

!LGitTreeEntry methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
object
	| object |
	object := (LGitObject classFor: self type) of: self repository.
	self withReturnHandlerDo: [
		self
			tree_entry_to_object: object
			repo: self repository
			entry: self ].
		
	^ object! !

!LGitTreeEntry methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
objectId
	^ LGitId fromExternalAddress: (self tree_entry_id: self)! !

!LGitTreeEntry methodsFor: 'external resource management' stamp: ' 1/5/2022 21:01:26'!
autoRelease
	"don't"! !

!LGitTreeEntry methodsFor: '*Iceberg-Adapters' stamp: ''!
tree
	^ self object! !

!LGitTreeEntry methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
entryByPath: aString 
	^ self object entryByPath: aString! !

!LGitTreeEntry methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isLeaf

	^ self object isTree! !

!LGitTreeEntry methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entry_name: entry
	
	^ self ffiCallSafely: #(String git_tree_entry_name #(self)) options: #()! !

!LGitTreeEntry methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entry_filemode: entry
	
	^ self
		ffiCallSafely: #(LGitFilemodeEnum git_tree_entry_filemode #(self))
		options: #()! !

!LGitTreeEntry methodsFor: '*Iceberg-Adapters' stamp: ''!
name
	^ self filename! !

!LGitTreeEntry methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
compare: aTreeEntry
	^ (self
		tree_entry_cmp: self
		e2: aTreeEntry) isZero! !

!LGitTreeEntry methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fileMode
	^ self tree_entry_filemode: self! !

!LGitTreeEntry methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isBlob
	^ self object isBlob! !

!LGitTreeEntry methodsFor: 'traversing' stamp: ' 1/5/2022 21:01:26'!
entries
	^ self object entries! !

!LGitTreeEntry class methodsFor: 'libgit - finalization' stamp: ' 1/5/2022 21:01:26'!
freeFunctionSelector
	^ #tree_entry_free:! !

!LGitTreeEntry class methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
tree_entry_free: handle
	
	^ self
		ffiCallSafely: #(void git_tree_entry_free #(void *handle))
		options: #()! !

!LGitTreewalkCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
signature: signature "<String>" block: aBlock "<BlockClosure>"
	super signature: signature block: (self wrapBlock: aBlock)! !

!LGitTreewalkCallback methodsFor: 'initialization' stamp: ' 1/5/2022 21:01:26'!
wrapBlock: aThreeArgBlock

	^[ :rootPath :entryAddress :payload |
		aThreeArgBlock 
			value: rootPath 
			value: (LGitTreeEntry fromHandle: entryAddress)
			value: payload ]! !

!LGitTreewalkCallback class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^#(int (String name, LGitTreeEntry entry, void *payload))! !

!LGitTreewalkModeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_treewalk_pre
	^ self basicNew
		value: 0;
		yourself! !

!LGitTreewalkModeEnum class methodsFor: 'accessing - values' stamp: ' 1/5/2022 21:01:26'!
git_treewalk_post
	^ self basicNew
		value: 1;
		yourself! !

!LGitTreewalkModeEnum class methodsFor: 'enum declaration' stamp: ' 1/5/2022 21:01:26'!
enumDecl
	^#(
	GIT_TREEWALK_PRE 0
	GIT_TREEWALK_POST 1
)! !

!LGitURLResolveCallback commentStamp: 'Guille 4/17/2020 19:18'!
git_url_resolve_cb
Callback to resolve URLs before connecting to remote

git_buf *	 url_resolved The buffer to write the resolved URL to

const char *	url The URL to resolve

int direction	GIT_DIRECTION_FETCH or GIT_DIRECTION_PUSH

void *	payload	Payload provided by the caller

returns

int 0 on success, GIT_PASSTHROUGH or an error
If you return GIT_PASSTHROUGH, you don't need to write anything to url_resolved.

signature
int git_url_resolve_cb(git_buf *url_resolved, const char *url, int direction, void *payload);

Defined in: git2/remote.h!
!LGitURLResolveCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec

	^ #( int ( LGitBuf* ) )! !

!LGitUpdateTipsCallback class methodsFor: 'callback spec' stamp: ' 1/5/2022 21:01:26'!
fnSpec
	^ #(int (String refname, LGitId *a, LGitId *b, void * data))! !

!LGitWriteBackValue commentStamp: 'TorstenBergmann 6/2/2021 23:15'!
Abstract superclass for value we write back from libgit2 as external value holders!
!LGitWriteBackValue class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isAbstract

	^ self == LGitWriteBackValue! !

!LGitWriteBackValueInt commentStamp: 'TorstenBergmann 6/2/2021 23:13'!
External int value holder!
!LGitWriteBackValueInt class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
typeDecl

	^ 'int'! !

!LGitWriteBackValueSizeT commentStamp: 'TorstenBergmann 6/2/2021 23:14'!
External size_t value holder!
!LGitWriteBackValueSizeT class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
typeDecl

	^ 'size_t'! !

!LGitWriteBackValueUInt commentStamp: 'TorstenBergmann 6/2/2021 23:14'!
External unit value holder!
!LGitWriteBackValueUInt class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
typeDecl

	^ 'uint'! !

!LGitWritepackAppendCallout methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
writepack: writepack buffer: buffer length: length progress: progress
	
	^ self
		ffiCallSafely:
			#(int #(LGitOdbWritepack * writepack , void * buffer , int length , LGitTransferProgress * progress))
		options: #(optMayGC)! !

!LGitWritepackCommitCallout methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
writepack: writepack progress: progress
	^ self
		ffiCallSafely: #(int #(LGitOdbWritepack *writepack , LGitTransferProgress *progress))
		options: #(optMayGC)! !

!LGitWritepackFreeCallout methodsFor: 'libgit - calls' stamp: ' 1/5/2022 21:01:26'!
writepack: writepack
	^ self ffiCallSafely: #(void #(LGitOdbWritepack *writepack)) options: #()! !

!LGitWritingTreeFailed commentStamp: 'TorstenBergmann 6/2/2021 21:14'!
Writing of a git tree failed!
!LGit_GIT_EAMBIGUOUS commentStamp: 'TorstenBergmann 6/2/2021 20:27'!
Return handler for GIT_EAMBIGUOUS - More than one object matches!
!LGit_GIT_EAPPLIED commentStamp: 'TorstenBergmann 6/2/2021 20:38'!
Return handler for GIT_EAPPLIED - Patch/merge has already been applied!
!LGit_GIT_EAUTH commentStamp: 'TorstenBergmann 6/2/2021 20:27'!
Return handler for GIT_EAUTH - Authentication error!
!LGit_GIT_EBAREREPO commentStamp: 'TorstenBergmann 6/2/2021 20:28'!
Return handler for GIT_EBAREREPO - Operation not allowed on bare repository!
!LGit_GIT_EBUFS commentStamp: 'TorstenBergmann 6/2/2021 20:28'!
Return handler for GIT_EBUFS - Output buffer too short to hold data!
!LGit_GIT_ECERTIFICATE commentStamp: 'TorstenBergmann 6/2/2021 20:37'!
Return handler for GIT_ECERTIFICATE - Server certificate is invalid!
!LGit_GIT_ECONFLICT commentStamp: 'TorstenBergmann 6/2/2021 20:29'!
Return handler for GIT_ECONFLICT - Internal only!
!LGit_GIT_ECONFLICT methodsFor: '*Iceberg-Libgit' stamp: ''!
acceptError: aVisitor
	^ aVisitor visitECONFLICT: self! !

!LGit_GIT_EEOF commentStamp: 'TorstenBergmann 6/2/2021 20:08'!
Return handler for GIT_EEOF!
!LGit_GIT_EEOF methodsFor: '*Iceberg-Libgit' stamp: ''!
acceptError: aVisitor

	^ aVisitor visitEEOF: self! !

!LGit_GIT_EEXISTS commentStamp: 'TorstenBergmann 6/2/2021 20:36'!
Return handler for GIT_EEXISTS - Object exists preventing operation!
!LGit_GIT_EEXISTS methodsFor: 'visiting' stamp: ' 1/5/2022 21:01:26'!
acceptError: aVisitor

	^ aVisitor visitEEXISTS: self! !

!LGit_GIT_EINVALID commentStamp: 'TorstenBergmann 6/2/2021 20:08'!
Return handler for GIT_EINVALID!
!LGit_GIT_EINVALIDSPEC commentStamp: 'TorstenBergmann 6/2/2021 20:36'!
Return handler for GIT_EINVALIDSPEC - Name/ref spec was not in a valid format!
!LGit_GIT_ELOCKED commentStamp: 'TorstenBergmann 6/2/2021 20:08'!
Return handler for GIT_ELOCKED!
!LGit_GIT_EMODIFIED commentStamp: 'TorstenBergmann 6/2/2021 20:09'!
Return handler for GIT_EMODIFIED!
!LGit_GIT_ENONFASTFORWARD commentStamp: 'TorstenBergmann 6/2/2021 20:35'!
Return handler for GIT_ENONFASTFORWARD - Reference was not fast-forwardable!
!LGit_GIT_ENOTFOUND commentStamp: 'TorstenBergmann 6/2/2021 20:35'!
Return handler for GIT_ENOTFOUND - Requested object could not be found!
!LGit_GIT_ENOTFOUND methodsFor: '*Iceberg-Libgit' stamp: ''!
acceptError: aVisitor
	^ aVisitor visitENOTFOUND: self! !

!LGit_GIT_EORPHANEDHEAD commentStamp: 'TorstenBergmann 6/2/2021 20:11'!
Return handler for GIT_EORPHANEDHEAD!
!LGit_GIT_EPEEL commentStamp: 'TorstenBergmann 6/2/2021 20:32'!
Return handler for GIT_EPEEL - The requested peel operation is not possible!
!LGit_GIT_ERROR commentStamp: 'TorstenBergmann 6/2/2021 20:31'!
Return handler for GIT_ERROR - Generic error!
!LGit_GIT_ERROR methodsFor: '*Iceberg-Libgit' stamp: ''!
acceptError: aVisitor
	^ aVisitor visitERROR: self! !

!LGit_GIT_EUNBORNBRANCH commentStamp: 'TorstenBergmann 6/2/2021 20:33'!
Return handler for GIT_EUNBORNBRANCH - HEAD refers to branch with no commits!
!LGit_GIT_EUNCOMMITTED commentStamp: 'TorstenBergmann 6/2/2021 20:33'!
Return handler for GIT_EUNCOMMITTED - Uncommitted changes in index prevented operation!
!LGit_GIT_EUNMERGED commentStamp: 'TorstenBergmann 6/2/2021 20:30'!
Return handler for GIT_EUNMERGED - Merge in progress prevented operation!
!LGit_GIT_EUSER commentStamp: 'TorstenBergmann 6/2/2021 20:12'!
Return handler for GIT_USER!
!LGit_GIT_EUSER methodsFor: '*Iceberg-Libgit' stamp: ''!
acceptError: aVisitor
	^ aVisitor visitEUSER: self! !

!LGit_GIT_ITEROVER commentStamp: 'TorstenBergmann 6/2/2021 20:30'!
Return handler for GIT_ITEROVER - Signals end of iteration with iterator!
!LGit_GIT_ITEROVER methodsFor: 'signaling' stamp: ' 1/5/2022 21:01:26'!
signal
	"don't signal, everything is fine"
	^ self! !

!LGit_GIT_OK commentStamp: 'TorstenBergmann 6/2/2021 20:29'!
Return handler for GIT_OK - No error!
!LGit_GIT_OK methodsFor: 'signaling' stamp: ' 1/5/2022 21:01:26'!
signal
	"don't signal, everything is fine"
	^ self! !

!LGit_GIT_OK class methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isError
	^ false! !

!LGit_GIT_PASSTHROUGH commentStamp: 'TorstenBergmann 6/2/2021 20:34'!
Return handler for GIT_PASSTHROUGH - A user-configured callback refused to act!
!LIFOQueue commentStamp: ''!
This is a thread-safe LIFO (last-in-first-out) queue (also known as stack) implementation,
based on atomic operations.
!
!LIFOQueue methodsFor: 'stack-compliant protocol' stamp: ''!
errorEmptyStack
	self error: 'this stack is empty'! !

!LIFOQueue methodsFor: 'initialization' stamp: ''!
initialize
	| dummy |
	dummy := self newItem.
	dummy next: nil; object: dummy.
	head := dummy.! !

!LIFOQueue methodsFor: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
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: ''!
nextOrNil
	^ self nextIfNone: [ nil ]! !

!LIFOQueue methodsFor: 'stack-compliant protocol' stamp: ''!
push: anObject
	^ self nextPut: anObject! !

!LIFOQueue methodsFor: 'stack-compliant protocol' stamp: ''!
pop

	^ self nextIfNone: [ self errorEmptyStack ]! !

!LIFOQueue methodsFor: 'accessing' stamp: ''!
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: ''!
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: ''!
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! !

!LIFOQueueTest commentStamp: ''!
SUnit tests for LIFO queues!
!LIFOQueueTest methodsFor: 'tests' stamp: ''!
testBasics
	| q |
	q := self newQueue.
	
	q nextPut: 5.
	
	self assert: q next equals: 5.
	
	q nextPut: 10.
	
	self assert: q nextOrNil equals: 10.
	
	self assert: q nextOrNil isNil! !

!LIFOQueueTest methodsFor: 'instance creation' stamp: ''!
newQueue

	^ LIFOQueue new! !

!LIFOQueueTest methodsFor: 'tests' stamp: ''!
testContention1

	| q r1 r2 |
	q := self newQueue.
	q nextPut: 10.
	q nextPut: 5.

	self assert: q nextOrNil equals: 5.

	[ r1 := q next ] fork.
	[ r2 := q next ] fork.
	Processor  yield.   "let the above two threads block"
	
	q nextPut: 10.
	Processor yield.

	self assert: r1 equals: 10.
	self assert: r2 equals: 10.
	self assert: q nextOrNil isNil! !

!LIFOQueueTest methodsFor: 'tests' stamp: ''!
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 equals: 1000.
	self assert: q nextOrNil isNil! !

!LRUCache commentStamp: ''!
I am LRUCache.
I am a Cache.

I am a limited cache that evicts the least recently used entries. My implementation is properly O(1).

Implementation Notes

The key/value pairs in the cache are held as Associations in a DoubleLinkedList, lruList, ordered from least to most recently used.

The keyIndex Dictionary maps from each key to the actual DoubleLink inside lruList holding the matching key/value pair.

New pairs are added at the end of the list.

In case of a hit, a pair gets promoted to the end of the list (most recently used).

In case of a full cache, the first pair of the list gets evicted (least recently used).

See #validateInvariantWith: where the relationship between the 2 datastructures is checked.


Example 1

Suppose we have to compute the prime factors of some numbers, 
and that this is a slow operation. If we repeatedly do the same
computation, we could speed this up with a cache.

To get a reasonable hit rate, we generate 50 random numbers below 100."

	primeFactorsCache := LRUCache new.
	
	50 timesRepeat: [
		| n |
		n := 100 atRandom.
		primeFactorsCache
			at: n ifAbsentPut: [ n primeFactors ] ].
	
	primeFactorsCache hitRatio asFloat.

Example 2

Fibonacci numbers are defined as follows:

 F(0)=0
 F(1)=1
 F(n)=F(n-1)+F(n-2)

This is a relatively slow recursive process, especially
since the same number is computed more than once,
a cache can help. Let's find out the hit rate.

Setting a factory block is an alternative way to define
a cache's functionality in one single place."	

	fibCache := LRUCache new.

	fibCache 
		maximumWeight: 32;
		factory: [ :key |
			key < 2
				ifTrue: [ key ]
				ifFalse: [ (fibCache at: key - 1) + (fibCache at: key - 2) ] ].

	fibCache at: 40. "102334155"

	fibCache hitRatio asFloat.!
!LRUCache methodsFor: 'testing' stamp: ''!
isEmpty
	"Return true when the receiver contains no entries."
	
	^ keyIndex isEmpty! !

!LRUCache methodsFor: 'private' stamp: ''!
validateInvariantWith: assertable
	"The keyIndex maps keys to double linked list nodes that hold 
	a key value association, whose key must match the index key"
	keyIndex keysAndValuesDo: [ :key :link |
		assertable assert: link value key = key ].
	"When iterating over all key value pairs, each key lookup up
	through the index should see the correct key and value in 
	the double linked list node"
	self keysAndValuesDo: [ :key :value |
		| link |
		link := keyIndex at: key.
		assertable assert: link value value = value.
		assertable assert: link value key = key ].
	"When iterating over all keys, each key can be present only once"
	Set new in: [ :keysSeen |
		self keysAndValuesDo: [ :key :value |
			assertable assert: (keysSeen includes: key) not.
			keysSeen add: key ] ]! !

!LRUCache methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	keyIndex := Dictionary new.
	lruList := DoubleLinkedList new! !

!LRUCache methodsFor: 'private' stamp: ''!
addWeight: value 
	weight add: value.
	[ weight isBelowMaximum ]
		whileFalse: [ 
			self isEmpty
				ifTrue: [ self error: 'Weight of single value being added exceeds maximum' ]
				ifFalse: [ self evict ] ]! !

!LRUCache methodsFor: 'accessing' stamp: ''!
at: key put: value
	"Populate me by storing value for key. Return value. 
	This is neither a hit nor a miss. Statistics remain unchanged.
	Overwrite if already present without promotion. 
	This could result in the least recently used key/value pair 
	being removed when the specified maximum cache weight is exceeded."
	
	self critical: [ | association link |
		association := keyIndex
			associationAt: key
			ifAbsent: [
				association := self newAssociationKey: key value: value.
				self addWeight: value.
				link := lruList addLast: association.
				keyIndex at: key put: link.
				^ value ].
		link := association value.
		weight remove: link value value.
		self addWeight: value.
		link value value: value.
		^ value ]! !

!LRUCache methodsFor: 'private' stamp: ''!
handleHit: association
	| link |
	statistics addHit.
	link := association value.
	self promote: link.
	^ link value value! !

!LRUCache methodsFor: 'private' stamp: ''!
handleMiss: association
	| link |
	statistics addMiss.
	self addWeight: association value.
	link := lruList addLast: association.
	keyIndex at: association key put: link.
	^ association value! !

!LRUCache methodsFor: '*System-Caching-Tests' stamp: ''!
testSupportGetCachedAssociations
	| result |
	result := OrderedCollection new.
	self keysAndValuesDo: [ :key :value |
		result add: (key -> value)
		].
	^result asArray.
! !

!LRUCache methodsFor: 'removing' stamp: ''!
removeAll
	"Remove all key/value pairs that I currently hold,
	effectiley resetting me, but not my statistics."
	
	self critical: [
		lruList removeAll.
		keyIndex removeAll.
		weight reset ]! !

!LRUCache methodsFor: 'accessing - statistics' stamp: ''!
size
	"Return the count of items currently present."
	
	^ keyIndex size! !

!LRUCache methodsFor: 'private' stamp: ''!
evict
	| link value |
	link := lruList removeFirst.
	value := link value.
	weight remove: value value.
	keyIndex removeKey: value key! !

!LRUCache methodsFor: 'enumerating' stamp: ''!
keysAndValuesDo: block
	"Execute block with each key and value present in me.
	This will be from least to most recently used."
	
	lruList do: [ :link |
		block 
			value: link key 
			value: link value ]! !

!LRUCache methodsFor: 'accessing' stamp: ''!
at: key ifAbsentPut: block
	"If key is present in the cache, return the associated value.
	This is a hit and makes that key/value pair the most recently used.
	If key is absent, use block to compute a new value and cache it.
	Block can optionally take one argument, the key. 
	This is a miss and will create a new key/value pair entry.
	Furthermore this could result in the least recently used key/value pair 
	being removed when the specified maximum cache weight is exceeded."

	self critical: [ | association |
		association := keyIndex
			associationAt: key
			ifAbsent: [ | value |
				value := block cull: key.
				"Sadly we have to check the presence of key again 
				in case of the block execution already added the entry"
				keyIndex 
					associationAt: key 
					ifAbsent: [
						association := self newAssociationKey: key value: value.
						^ self handleMiss: association ] ].
		^ self handleHit: association ]! !

!LRUCache methodsFor: 'private' stamp: ''!
promote: link
	lruList removeLink: link.
	lruList addLast: link! !

!LRUCache methodsFor: 'private' stamp: ''!
newAssociationKey: key value: value
	^ Association key: key value: value! !

!LRUCache methodsFor: 'removing' stamp: ''!
removeKey: key ifAbsent: block
	"If I currently cache key, remove the entry.
	Execute block when key is currently absent.
	Return the removed value."
	
	^ self critical: [
		(self includesKey: key)
			ifTrue: [ | link value |
				link := keyIndex removeKey: key.
				lruList removeLink: link.
				value := link value value.
				weight remove: value.
				value ]
			ifFalse: block ]! !

!LRUCache methodsFor: 'testing' stamp: ''!
includesKey: key
	"Return true when the receiver has a value cached for key."
	
	^ keyIndex includesKey: key! !

!LRUCacheTest commentStamp: ''!
I am NeoLRUCacheTests.
!
!LRUCacheTest methodsFor: 'testing' stamp: ''!
testThreeHitSameOne
	| cache |
	cache := self newCache.
	cache at: #x ifAbsentPut: [ 100 ].
	cache at: #y ifAbsentPut: [ 200 ].
	cache at: #z ifAbsentPut: [ 300 ].
	self assert: (cache at: #x ifAbsentPut: [ self fail ]) equals: 100.
	self assert: (cache at: #y ifAbsentPut: [ self fail ]) equals: 200.
	self assert: (cache at: #z ifAbsentPut: [ self fail ]) equals: 300.
	3 timesRepeat: [ 	
		self assert: (cache at: #x ifAbsentPut: [ self fail ]) equals: 100 ].
	self assert: cache hits equals: 6.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testEmpty
	| emptyCache |
	emptyCache := self newCache.
	self assertEmpty: emptyCache.
	self assert: emptyCache size isZero.
	self assert: emptyCache hits isZero.
	self assert: emptyCache misses isZero.
	self assert: emptyCache hitRatio isZero.
	self assert: emptyCache totalWeight isZero.
	self deny: (emptyCache includesKey: #foo).
	emptyCache keysAndValuesDo: [ :key :value | self fail ]! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
test5kClasses
	| cache data |
	(cache := self newCache)
		maximumWeight: 1024.
	data := Object allSubclasses first: 5*1024.
	data do: [ :each |
		cache at: each name ifAbsentPut: [ each ] ].
	cache validateInvariantWith: self.
	self assert: cache size equals: 1024.
	data shuffled do: [ :each |
		cache at: each name ifAbsentPut: [ each ] ].
	self assert: cache size equals: 1024.
	cache validateInvariantWith: self.	
	data 
		select: [ :each | cache includesKey: each name ]
		thenDo: [ :each | cache at: each name ifAbsentPut: [ self fail ] ].
	self assert: cache hits >= 1024.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testAdditionInIfAbsentPut
	| cache |
	cache := self newCache.
	cache at: #foo ifAbsentPut: [ 100 ].
	self assert: (cache at: #foo ifAbsentPut: [ self fail ]) equals: 100.
	"Add an entry for bar in the block computing the value to add"
	cache at: #bar ifAbsentPut: [ cache at: #bar ifAbsentPut: [ 200 ] ].
	self assert: (cache at: #bar ifAbsentPut: [ self fail ]) equals: 200.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testEviction
	| cache |
	cache := self newCache.
	cache maximumWeight: 16.
	1 to: 20 do: [ :each |
		cache at: each asWords ifAbsentPut: [ each ] ].
	self assert: cache size equals: 16.
	self assert: cache totalWeight equals: 16.
	5 to: 20 do: [ :each |
		self assert: (cache includesKey: each asWords).
		self 
			assert: (cache at: each asWords ifAbsentPut: [ self fail ]) 
			equals: each ].
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testPrimeFactors

	| cache data |
	cache := self newCache.
	cache maximumWeight: 512.
	cache factory: [ :key | key ].
	data := Array streamContents: [ :out |
		1 to: 4096 do: [ :each |
			each primeFactorsOn: out.
			out nextPut: each ] ].
	data := data collect: [ :each | each asWords ].
	data do: [ :each | cache at: each ].
	self assert: cache totalWeight equals: 512.
	self assert: cache hitRatio > (7/10).
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testRandomAccess
	| cache data random keys |
	(cache := self newCache)
		maximumWeight: 4.
	data := (1 to: 16) collect: [ :each | each asWords ].
	data do: [ :each |
		cache at: each ifAbsentPut: [ each ] ].
	cache validateInvariantWith: self.
	self assert: cache size equals: 4.
	random := data shuffled.
	random do: [ :each |
		cache at: each ifAbsentPut: [ each ] ].
	self assert: cache size equals: 4.
	cache validateInvariantWith: self.	
	keys := data select: [ :each | cache includesKey: each ].
	keys do: [ :each | cache at: each ifAbsentPut: [ self fail ] ].
	self assert: cache hits >= 4.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testFibonacci
	"After an idea by Jan Vrany.
	Recursively enter the cache and its access protection"
	
	| fibCache |
	fibCache := self newCache.
	fibCache 
		maximumWeight: 32;
		beThreadSafe;
		factory: [ :key |
			key < 2
				ifTrue: [ key ]
				ifFalse: [ (fibCache at: key - 1) + (fibCache at: key - 2) ] ].
	self assert: (fibCache at: 40) equals: 102334155! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testCustomWeight
	| cache |
	(cache := self newCache)
		computeWeight: #sizeInMemory;
		maximumWeight: 64.
	cache at: 1 ifAbsentPut: [ ByteArray new: 1 ].
	self assert: cache totalWeight equals: (ByteArray new: 1) sizeInMemory.
	2 to: 10 do: [ :each | 
		cache at: each ifAbsentPut: [ ByteArray new: each ] ].
	self assert: cache size equals: 3.
	self 
		assert: cache totalWeight 
		equals: ((8 to: 10) collect: [ :each | (ByteArray new: each) sizeInMemory ]) sum.
	self assert: (cache at: 10 ifAbsentPut: [ self fail ]) equals: (ByteArray new: 10).
	self deny: (cache includesKey: 1)! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testTwo
	| cache |
	cache := self newCache.
	cache at: #foo ifAbsentPut: [ 100 ].
	cache at: #bar ifAbsentPut: [ 200 ].
	self assert: (cache at: #foo ifAbsentPut: [ self fail ]) equals: 100.
	self assert: (cache at: #bar ifAbsentPut: [ self fail ]) equals: 200.
	self assert: cache hitRatio equals: 2/4.
	self assert: (cache at: #bar ifAbsentPut: [ self fail ]) equals: 200.
	self assert: (cache at: #foo ifAbsentPut: [ self fail ]) equals: 100.
	self assert: cache hitRatio equals: 4/6.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testOne
	| cache |
	cache := self newCache.
	cache at: #foo ifAbsentPut: [ 100 ].
	self assert: (cache includesKey: #foo).
	self deny: cache isEmpty.
	self assert: cache size equals: 1.
	self assert: cache totalWeight equals: 1.
	self assert: cache hits isZero.
	self assert: cache misses equals: 1.
	self assert: cache hitRatio isZero.
	self deny: (cache includesKey: #bar).
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testFixedAccess
	| cache data keys |
	(cache := self newCache)
		maximumWeight: 4.
	data := (1 to: 16) collect: [ :each | each asWords ].
	data do: [ :each |
		cache at: each ifAbsentPut: [ each ] ].
	cache validateInvariantWith: self.
	self assert: cache size equals: 4.
	(#(14 15) collect: #asWords) do: [ :each |
		cache at: each ifAbsentPut: [ each ] ].
	self assert: cache size equals: 4.
	cache validateInvariantWith: self.	
	keys := data select: [ :each | cache includesKey: each ].
	keys do: [ :each | cache at: each ifAbsentPut: [ self fail ] ].
	self assert: cache hits >= 4.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testOneHit
	| cache value |
	cache := self newCache.
	cache at: #foo ifAbsentPut: [ 100 ].
	self assert: (cache includesKey: #foo).
	self assert: cache hits equals: 0.
	self assert: cache misses equals: 1.
	value := cache at: #foo ifAbsentPut: [ self fail ].
	self assert: value equals: 100.
	self assert: cache hits equals: 1.
	self assert: cache misses equals: 1.
	cache validateInvariantWith: self
	! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testAt
	| cache |
	cache := self newCache.
	self should: [ cache at: #foo ] raise: KeyNotFound.
	cache at: #foo ifAbsentPut: [ 100 ].
	self assert: (cache at: #foo) equals: 100.
	cache removeKey: #foo.
	self should: [ cache at: #foo ] raise: KeyNotFound! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testFactory
	| cache |
	cache := self newCache.
	cache maximumWeight: 5.
	cache factory: [ :key | key * 2 ].
	#( 1 2 3 4 1 5 6 7 8 1 ) do: [ :each |
		 cache at: each ].
	self assert: cache size equals: 5.
	self assert: cache hits equals: 2.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testRemoveOne
	| cache |
	cache := self newCache.
	cache at: #foo ifAbsentPut: [ 100 ].
	cache removeKey: #foo.
	self assertEmpty: cache.
	self assert: cache size isZero.
	self assert: cache totalWeight isZero.
	self deny: (cache includesKey: #foo).
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testEnumeration
	| cache data keys values |
	cache := self newCache.
	data := Dictionary new.
	1 to: 10 do: [ :each | data at: each asWords put: each ].
	data keysAndValuesDo: [ :key :value |
		cache at: key ifAbsentPut: [ value ] ].
	keys := Array new writeStream.
	values := Array new writeStream.
	cache keysAndValuesDo: [ :key :value |
		self assert: (data at: key) equals: value.
		keys nextPut: key.
		values nextPut: value ].
	self assert: keys contents asSet equals: data keys asSet.
	self assert: values contents asSet equals: data values asSet.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testTenThreadSafe
	| cache |
	cache := self newCache.
	cache beThreadSafe.
	1 to: 10 do: [ :each |
		cache at: each asWords ifAbsentPut: [ each ] ].
	self assert: cache size equals: 10.
	1 to: 10 do: [ :each |
		self 
			assert: (cache at: each asWords ifAbsentPut: [ self fail ]) 
			equals: each ].
	self assert: cache hitRatio equals: 1/2.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
test6k
	| cache |
	(cache := self newCache)
		maximumWeight: 600.
	1 to: 6000 do: [ :each |
		cache at: each ifAbsentPut: [ each * 2 ] ].
	self assert: cache size equals: 600.
	self assert: (cache includesKey: 5401).
	self deny: (cache includesKey: 5400).
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testThree
	| cache |
	cache := self newCache.
	cache at: #x ifAbsentPut: [ 100 ].
	cache at: #y ifAbsentPut: [ 200 ].
	cache at: #z ifAbsentPut: [ 300 ].
	self assert: (cache at: #x ifAbsentPut: [ self fail ]) equals: 100.
	self assert: (cache at: #y ifAbsentPut: [ self fail ]) equals: 200.
	self assert: (cache at: #z ifAbsentPut: [ self fail ]) equals: 300.
	self assert: cache hitRatio equals: 3/6.
	self assert: (cache at: #z ifAbsentPut: [ self fail ]) equals: 300.
	self assert: (cache at: #y ifAbsentPut: [ self fail ]) equals: 200.
	self assert: (cache at: #x ifAbsentPut: [ self fail ]) equals: 100.
	self assert: cache hitRatio equals: 6/9.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testRemoveAll
	| cache |
	cache := self newCache.
	1 to: 10 do: [ :each | cache at: each ifAbsentPut: [ each ] ].
	cache removeAll.
	self assertEmpty: cache.
	self assert: cache size isZero.
	self assert: cache totalWeight isZero.
	self assert: cache misses equals: 10.
	self assert: cache hits isZero.
	self deny: (cache includesKey: 1).
	cache keysAndValuesDo: [ :key :value | self fail ].
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testPopulate
	| cache data |
	cache := self newCache.
	cache at: #foo put: 1.
	self assert: cache hits isZero.
	self assert: cache misses isZero.
	self assert: cache size equals: 1.
	self assert: (cache at: #foo) equals: 1.
	cache at: #foo put: 2.
	self assert: cache size equals: 1.
	self assert: (cache at: #foo) equals: 2.
	cache := self newCache.
	data := { #x->1. #y->2. #z->3 } asDictionary.
	cache addAll: data.
	self assert: cache hits isZero.
	self assert: cache misses isZero.
	self assert: cache size equals: 3.
	data keysAndValuesDo: [ :key :value |
		self assert: (cache at: key) equals: value ]! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testOneHitTwice
	| cache value |
	cache := self newCache.
	cache at: #foo ifAbsentPut: [ 100 ].
	value := cache at: #foo ifAbsentPut: [ self fail ].
	self assert: value equals: 100.
	value := cache at: #foo ifAbsentPut: [ self fail ].
	self assert: value equals: 100.
	self assert: cache hitRatio equals: 2/3.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testTen
	| cache |
	cache := self newCache.
	1 to: 10 do: [ :each |
		cache at: each asWords ifAbsentPut: [ each ] ].
	self assert: cache size equals: 10.
	1 to: 10 do: [ :each |
		self assert: (cache includesKey: each asWords) ].
	1 to: 10 do: [ :each |
		self 
			assert: (cache at: each asWords ifAbsentPut: [ self fail ]) 
			equals: each ].
	self assert: cache hitRatio equals: 1/2.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testRemoveOneOfThree
	| cache |
	cache := self newCache.
	cache at: #x ifAbsentPut: [ 100 ].
	cache at: #y ifAbsentPut: [ 200 ].
	cache at: #z ifAbsentPut: [ 300 ].
	cache removeKey: #y.
	self assert: cache size equals: 2.
	self assert: cache totalWeight equals: 2.
	self assert: (cache at: #x ifAbsentPut: [ self fail ]) equals: 100.
	self deny: (cache includesKey: #y).
	self assert: (cache at: #z ifAbsentPut: [ self fail ]) equals: 300.
	cache validateInvariantWith: self! !

!LRUCacheTest methodsFor: 'accessing' stamp: ''!
newCache
	^ LRUCache new! !

!LRUCacheTest methodsFor: 'testing' stamp: ''!
testFactoryStyle
	| cache factory |
	cache := self newCache.
	cache maximumWeight: 5.
	factory := [ :key | key * 2 ].
	#( 1 2 3 4 1 5 6 7 8 1 ) do: [ :each |
		 cache at: each ifAbsentPut: factory ].
	self assert: cache size equals: 5.
	self assert: cache hits equals: 2.
	cache validateInvariantWith: self! !

!LabelClicked commentStamp: ''!
I am an announcement raised when someone click on the label of a CheckboxMorph!
!LabelClicked methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!LabelClicked methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!LabelClicked methodsFor: 'accessing' stamp: ''!
stateChanged
	^ stateChanged! !

!LabelClicked methodsFor: 'accessing' stamp: ''!
stateChanged: anObject
	stateChanged := anObject! !

!LabelClicked class methodsFor: 'instance creation' stamp: ''!
source: source stateChanged: stateChanged

	^ self new
		source: source;
		stateChanged: stateChanged;
		yourself! !

!LabelMorph commentStamp: ''!
String morph with enablement support. When disabled the text will appear inset.!
!LabelMorph methodsFor: 'update' stamp: ''!
updateText
	"Update the text contents."

	self model ifNotNil: [
		self getTextSelector ifNotNil: [
			self contents: (self model perform: self getTextSelector)]]! !

!LabelMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Draw based on enablement."

	super drawOn: aCanvas.

	(self enabled not and: [ self disabledStyle = #inset ])	ifTrue: [
		aCanvas
			drawString: self contents
			in: (self stringBounds translateBy: 1)
			font: self fontToUse
			color: self theme lightBackgroundColor.
	].! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
disabledStyle: anObject
	"Set the value of disabledStyle"

	disabledStyle := anObject.
	self changed! !

!LabelMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		disabledStyle: #plain;
		enabled: true! !

!LabelMorph methodsFor: 'layout' stamp: ''!
minWidth
	"Answer the minmum width of the receiver.
	Based on font and contents."

	^self valueOfProperty: #minWidth ifAbsent: [self measureContents x] "allow override"! !

!LabelMorph methodsFor: 'protocol' stamp: ''!
interactionState: aSymbol
	"Backstop here to prevent 'legacy' color handling being applied from
	pluggable buttons."! !

!LabelMorph methodsFor: 'updating' stamp: ''!
update: aSymbol 
	"Refer to the comment in View|update:."

	aSymbol == self getEnabledSelector ifTrue:
		[self updateEnabled.
		^ self].
	aSymbol == self getTextSelector ifTrue:
		[self updateText.
		^ self]! !

!LabelMorph methodsFor: 'protocol' stamp: ''!
disable
	"Disable the receiver."
	
	self enabled: false! !

!LabelMorph methodsFor: 'initialization' stamp: ''!
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: 'protocol' stamp: ''!
enable
	"Enable the receiver."
	
	self enabled: true! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
enabled
	"Answer the value of enabled"

	^enabled! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
stringColor

	^ self enabled
		ifTrue: [ self color ]
		ifFalse: [ self theme labelDisabledColorFor: self ]! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: aColor! !

!LabelMorph methodsFor: 'updating' stamp: ''!
updateEnabled
	"Update the enablement state."

	self model ifNotNil: [
		self getEnabledSelector ifNotNil: [
			self enabled: (self model perform: self getEnabledSelector)]]! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
getTextSelector: aSymbol

	getTextSelector := aSymbol.
	self updateText! !

!LabelMorph methodsFor: 'layout' stamp: ''!
minHeight
	"Answer the receiver's minimum height.
	based on font height."
	
	^self fontToUse height rounded max: super minHeight! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector
	"Answer the value of getEnabledSelector"

	^ getEnabledSelector! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	"Set the value of enabled"

	enabled == aBoolean ifFalse: [
		enabled := aBoolean.
		self
			changed: #enabled;
			changed]! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
disabledStyle
	"Answer the value of disabledStyle"

	^ disabledStyle! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector: anObject
	"Set the value of getEnabledSelector"

	getEnabledSelector := anObject.
	self updateEnabled! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
model
	"Answer the value of model"

	^model! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
getTextSelector

	^ getTextSelector! !

!LabelMorph methodsFor: 'accessing' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: aCanvas
	"Draw based on enablement."

	| pc |
	pc := self owner
		ifNil: [ self paneColor ]
		ifNotNil: [ 
			self owner color isTransparent
				ifTrue: [ self owner paneColor ]
				ifFalse: [ self owner color ] ].
	aCanvas
		clipBy: self bounds
		during: [ 
			aCanvas pathTransform
				restoreAfter: [ 
					aCanvas pathTransform translateX: self left Y: self top + self fontToUse ascent.
					aCanvas
						setFont: self fontToUse;
						setPaint:
								(self enabled
										ifTrue: [ self color ]
										ifFalse: [ pc muchDarker ]);
						drawString: self contents ] ]! !

!LabelMorph class methodsFor: 'instance creation' stamp: ''!
newLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new text label whose model is aModel"

	^ ( self contents: aString font: self labelFont )
		model: aModel;
		getEnabledSelector: enabledSel! !

!LabelMorph class methodsFor: 'instance creation' stamp: ''!
newLabel: aString
	"Answer a new text label morph."

	^self
		newLabelFor: nil
		label: aString
		getEnabled: nil! !

!LabelMorph class methodsFor: 'examples' stamp: ''!
exampleDisableInset
	"self exampleDisable"
	<sampleInstance>
	^ (self newLabel: 'A Label')
		disable;
		disabledStyle: #inset;
		changeFont;
		openInWindow! !

!LabelMorph class methodsFor: 'examples' stamp: ''!
example
	"self example"
	<sampleInstance>
	^ (self newLabel: 'A Label') openInWindow! !

!LabelMorph class methodsFor: 'instance creation' stamp: ''!
labelFont
	"in the future should access an instance variable"
		
	^StandardFonts defaultFont! !

!LabelMorph class methodsFor: 'examples' stamp: ''!
exampleDisable
	"self exampleDisable"
	<sampleInstance>
	^ (self newLabel: 'A Label')
		disable;
		openInWindow! !

!LabelPresenter commentStamp: ''!
A LabelPresenter is a spec presenter for Labels.
See AbstractWidgetPresenter

self example

I provide the following variables and their accessors
- label is the text displayed that I display.

I am specializing defaultColor to change the color of my text.

todo
- emphasis!
!LabelPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	labelHolder := '' asValueHolder.
	emphasis := #().
	labelHolder whenChangedDo: [ self changed: #getText ].! !

!LabelPresenter methodsFor: 'api' stamp: ''!
label: aText
	"<api: #string getter: #label>"
	"Set the text of the label"
	
	labelHolder value: aText! !

!LabelPresenter methodsFor: 'api' stamp: ''!
emphasis
	^ emphasis! !

!LabelPresenter methodsFor: 'api' stamp: ''!
emphasis: anEmphasis
	"accepts a symbol or an array of symbols: #bold, #italic, #underline, #narrow, #struck"

	emphasis := anEmphasis isSymbol
		ifTrue: [ {anEmphasis} ]
		ifFalse: [ anEmphasis ].
	self changed: #emphasis: with: {emphasis}! !

!LabelPresenter methodsFor: 'api-valueHolder' stamp: ''!
labelHolder
	"To register actions to be done when the label changes."
	^ labelHolder! !

!LabelPresenter methodsFor: 'initialization' stamp: ''!
defaultColor
	^ self theme textColor! !

!LabelPresenter methodsFor: 'api' stamp: ''!
label
	"<api: #inspect>"

	^ labelHolder value! !

!LabelPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(LabelAdapter
		adapt: #(model))! !

!LabelPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #LabelAdapter! !

!LabelPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Label Morph'! !

!LabelledContainer commentStamp: ''!
I am an elementary Spec widget that adds a LabelPresenter at another widget.

self example

I provide the method content: that take a class in parameter, it instantiates it in the variable subwidget and add it at the focusOrder. Note it does not reset the focusOrder.

I provide accessors for the label and the subwidget, but I specialize doesNotUnderstand: to send the message at the subwidget.

I provide four layouts on my class side, to chose the position of the label.!
!LabelledContainer methodsFor: 'error handling' stamp: ''!
doesNotUnderstand: aMessage
	^ aMessage sendTo: subwidget! !

!LabelledContainer methodsFor: 'accessing' stamp: ''!
label: aString
	label label: aString! !

!LabelledContainer methodsFor: 'initialization' stamp: ''!
initializeWidgets
	label := self instantiate: LabelPresenter.! !

!LabelledContainer methodsFor: 'accessing' stamp: ''!
subwidget
	^ subwidget! !

!LabelledContainer methodsFor: 'initialization' stamp: ''!
content: aWidgetClass
	subwidget := self instantiate: aWidgetClass.
	self focusOrder add: subwidget! !

!LabelledContainer methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!LabelledContainer methodsFor: 'accessing' stamp: ''!
subwidget: anObject
	subwidget := anObject! !

!LabelledContainer class methodsFor: 'specs' stamp: ''!
labelBottom
	<spec>
	^ SpecLayout composed
		newColumn: [ :column | 
			column
				add: #subwidget origin: 0 @ 0 corner: 1 @ 0.9;
				add: #label origin: 0 @ 0.9 corner: 1 @ 1 ];
		yourself! !

!LabelledContainer class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self abstractExample.
	example content: ButtonPresenter.
	example subwidget
		label: 'I am a button'.
	example openDialogWithSpec.
	^ example! !

!LabelledContainer class methodsFor: 'specs' stamp: ''!
labelTop
	<spec: #default>
	^ SpecLayout composed
		newColumn: [ :column | 
			column
				add: #label origin: 0 @ 0 corner: 1 @ 0.1;
				add: #subwidget origin: 0 @ 0.1 corner: 1 @ 1 ];
		yourself! !

!LabelledContainer class methodsFor: 'specs' stamp: ''!
labelRight
	<spec>
	^ SpecLayout composed
		newRow: [ :row | 
			row
				add: #subwidget origin: 0 @ 0 corner: 0.8 @ 1;
				add: #label origin: 0.8 @ 0 corner: 1 @ 1 ];
		yourself! !

!LabelledContainer class methodsFor: 'examples' stamp: ''!
abstractExample
	| example |
	example := self new.
	example
		title: self name asString , ' example';
		label: 'I am a label'.
	^ example! !

!LabelledContainer class methodsFor: 'specs' stamp: ''!
labelLeft
	<spec>
	^ SpecLayout composed
		newRow: [ :row | 
			row
				add: #label origin: 0 @ 0 corner: 0.2 @ 1;
				add: #subwidget origin: 0.2 @ 0 corner: 1 @ 1 ];
		yourself! !

!LabelledDropList commentStamp: ''!
I am a LabelledContainer specialized to manage a DropListPresenter.
See LabelledContainer

self example

I provide the accessor dropList to be more intuitive than subwidget.

I provide shortcuts for the most common methods of the droplist api to avoid the use of the DoesNotUnderstand or the writing of long chain of accessors.!
!LabelledDropList methodsFor: 'api - shortcuts' stamp: ''!
emptyList
	^self dropList emptyList! !

!LabelledDropList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectedItemChanged: aBlock
	self dropList whenSelectedItemChanged: aBlock! !

!LabelledDropList methodsFor: 'api - shortcuts' stamp: ''!
selectedItem
	^self dropList selectedItem! !

!LabelledDropList methodsFor: 'initialization' stamp: ''!
initializeWidgets
super initializeWidgets.
	self content: DropListPresenter! !

!LabelledDropList methodsFor: 'api - shortcuts' stamp: ''!
setIndex: anIndex
	^self dropList setIndex: anIndex! !

!LabelledDropList methodsFor: 'api - shortcuts' stamp: ''!
listSize
	^self dropList listSize! !

!LabelledDropList methodsFor: 'api - shortcuts' stamp: ''!
resetSelection
	^self dropList resetSelection! !

!LabelledDropList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionIndexChanged: aBlock
	self dropList whenSelectionIndexChanged: aBlock! !

!LabelledDropList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionChanged: aBlock
	self dropList whenSelectionChanged: aBlock! !

!LabelledDropList methodsFor: 'api - shortcuts' stamp: ''!
items: aList
	^self dropList items: aList! !

!LabelledDropList methodsFor: 'api - shortcuts' stamp: ''!
displayBlock: aBlock
	^self dropList displayBlock: aBlock! !

!LabelledDropList methodsFor: 'accessing' stamp: ''!
dropList
	^ self subwidget! !

!LabelledDropList class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self abstractExample.
example
		items: {'item 1' . 'item 2'};
		displayBlock: [ :item | item asString ];
		extent: 400 @ 50;
		openWithSpec.
	^ example! !

!LabelledDropList class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ super labelLeft
! !

!LabelledDropListButton commentStamp: ''!
I am a LabelledContainer specialized to manage a DropListButton.
See LabelledContainer

self example

I provide the accessors dropListButton to be more intuitive than subwidget, and the shortcuts button and dropList.

I provide shortcuts for the most common methods to avoid the use of the DoesNotUnderstand or the writing of long chain of accessors.!
!LabelledDropListButton methodsFor: 'api - shortcuts' stamp: ''!
action: aBlock
	^self button action: aBlock! !

!LabelledDropListButton methodsFor: 'api - shortcuts' stamp: ''!
emptyList
	^self dropList emptyList! !

!LabelledDropListButton methodsFor: 'events - shortcuts' stamp: ''!
whenSelectedItemChanged: aBlock
	self dropList
		whenSelectedItemChanged: aBlock! !

!LabelledDropListButton methodsFor: 'api - shortcuts' stamp: ''!
selectedItem
	^ self dropList selectedItem! !

!LabelledDropListButton methodsFor: 'initialization' stamp: ''!
initializeWidgets
super initializeWidgets.
	self content: DropListButton.! !

!LabelledDropListButton methodsFor: 'api - shortcuts' stamp: ''!
setIndex: anIndex
	^ self dropList setIndex: anIndex! !

!LabelledDropListButton methodsFor: 'api - shortcuts' stamp: ''!
listSize
	^ self dropList listSize! !

!LabelledDropListButton methodsFor: 'api - shortcuts' stamp: ''!
resetSelection
^	self dropList resetSelection! !

!LabelledDropListButton methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionIndexChanged: aBlock
	self dropList
		whenSelectionIndexChanged: aBlock! !

!LabelledDropListButton methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionChanged: aBlock
	self dropList
		whenSelectionChanged: aBlock! !

!LabelledDropListButton methodsFor: 'accessing' stamp: ''!
dropListButton
	^ subwidget! !

!LabelledDropListButton methodsFor: 'api - shortcuts' stamp: ''!
items: aList
	^self dropList items: aList! !

!LabelledDropListButton methodsFor: 'accessing' stamp: ''!
button
	^ self dropListButton button! !

!LabelledDropListButton methodsFor: 'api - shortcuts' stamp: ''!
displayBlock: aBlock
	^self dropList displayBlock: aBlock! !

!LabelledDropListButton methodsFor: 'accessing' stamp: ''!
dropList
	^ self dropListButton dropList! !

!LabelledDropListButton methodsFor: 'api - shortcuts' stamp: ''!
icon: anIcon
^	self button icon: anIcon! !

!LabelledDropListButton class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self abstractExample.
	example button label: 'I am a button'.
	example
		items: {'item 1' . 'item 2'};
		displayBlock: [ :item | item asString ];
		extent: 550 @ 50;
		openWithSpec.
	^ example! !

!LabelledDropListButton class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ super labelLeft ! !

!LabelledDropListButton class methodsFor: 'examples' stamp: ''!
exampleUse
	<sampleInstance>
	| example |
	example := self new.
	example button label: 'Add'.
	example label: 'Compose your team';
		displayBlock: [ :item | item asString ];
		items: {'Swordian' . 'Gardian' . 'Wizard' . 'Sniper'};
		extent: 300 @ 120;
		title: 'LabelDropButton example of use';
		openWithSpec: #labelTop.
	^ example! !

!LabelledInputTextDropList commentStamp: ''!
I am a LabelledContainer specialized to manage a InputTextDropList.
See LabelledContainer

self example

I provide the accessors inputTextDropList to be more intuitive than subwidget, and the shortcuts input and dropList.

I provide shortcuts for the most common methods to avoid the use of the DoesNotUnderstand or the writing of long chain of accessors.!
!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
emptyList
	^ self dropList emptyList! !

!LabelledInputTextDropList methodsFor: 'accessing' stamp: ''!
input
	^ self inputTextDropList input! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
selectedItem
	^ self dropList selectedItem! !

!LabelledInputTextDropList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectedItemChanged: aBlock
	self dropList
		whenSelectedItemChanged: aBlock! !

!LabelledInputTextDropList methodsFor: 'initialization' stamp: ''!
initializeWidgets
super initializeWidgets.
	self content: InputTextDropList.! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
encrypted: aBoolean
	^ self input encrypted: aBoolean! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
setIndex: anIndex
^ 	self dropList setIndex: anIndex! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
listSize
	^ self dropList listSize! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
text: aText
	^ self input text: aText! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
resetSelection
	^ self dropList resetSelection! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
acceptOnCR: aBoolean
	^ self input acceptOnCR: aBoolean! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
ghostText: aText
	^ self input ghostText: aText! !

!LabelledInputTextDropList methodsFor: 'accessing' stamp: ''!
inputTextDropList
	^ subwidget! !

!LabelledInputTextDropList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionChanged: aBlock
	self dropList
		whenSelectionChanged: aBlock! !

!LabelledInputTextDropList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionIndexChanged: aBlock
	self dropList
		whenSelectionIndexChanged: aBlock! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
entryCompletion: anEntryCompletion
	^ self input entryCompletion: anEntryCompletion! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
items: aList
^ 	self dropList items: aList! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
beEncrypted
	^ self input beEncrypted! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
displayBlock: aBlock
	^ self dropList displayBlock: aBlock! !

!LabelledInputTextDropList methodsFor: 'accessing' stamp: ''!
dropList
	^  self inputTextDropList dropList! !

!LabelledInputTextDropList methodsFor: 'api - shortcuts' stamp: ''!
text
	^ self input text! !

!LabelledInputTextDropList class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self abstractExample.
	example
		ghostText: 'ghost text';
		items: {'item 1' . 'item 2'};
		displayBlock: [ :item | item asString ];
		extent: 450 @ 50;
		openWithSpec.
	^ example! !

!LabelledInputTextDropList class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ super labelLeft ! !

!LabelledList commentStamp: ''!
I am a LabelledContainer specialized to manage a ListPresenter.
See LabelledContainer

self example

I provide the accessor list to be more intuitive than subwidget.

I provide shortcuts for the most common methods of the list api to avoid the use of the DoesNotUnderstand or the writing of long chain of accessors.!
!LabelledList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectedItemChanged: aBlock
self list whenSelectedItemChanged: aBlock! !

!LabelledList methodsFor: 'api - shortcuts' stamp: ''!
beMultipleSelection
	^ self list beMultipleSelection! !

!LabelledList methodsFor: 'api - shortcuts' stamp: ''!
selectedItem
	^ self list selectedItem! !

!LabelledList methodsFor: 'api - shortcuts' stamp: ''!
sortingBlock: aBlock
	^self list sortingBlock: aBlock! !

!LabelledList methodsFor: 'initialization' stamp: ''!
initializeWidgets
super initializeWidgets.
	self content: ListPresenter! !

!LabelledList methodsFor: 'api - shortcuts' stamp: ''!
filteringBlock: aBlock
	^ self list filteringBlock: aBlock! !

!LabelledList methodsFor: 'api - shortcuts' stamp: ''!
listSize
	^ self list listSize! !

!LabelledList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionIndexChanged: aBlock
	self list whenSelectionIndexChanged: aBlock! !

!LabelledList methodsFor: 'events - shortcuts' stamp: ''!
whenSelectionChanged: aBlock
	self list whenSelectionChanged: aBlock! !

!LabelledList methodsFor: 'api - shortcuts' stamp: ''!
selectAll
	^ self list selectAll! !

!LabelledList methodsFor: 'api - shortcuts' stamp: ''!
items: aList
	^ self list items: aList! !

!LabelledList methodsFor: 'api - shortcuts' stamp: ''!
selectedItems
	^ self list selectedItems! !

!LabelledList methodsFor: 'api - shortcuts' stamp: ''!
displayBlock: aBlock
	^self list displayBlock: aBlock! !

!LabelledList methodsFor: 'accessing' stamp: ''!
list
	^ self subwidget! !

!LabelledList class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self abstractExample.
	example
		items: {'item 1' . 'item 2'};
		openWithSpec.
	^ example! !

!LabelledSliderInput commentStamp: ''!
I am a LabelledContainer specialized to manage a SliderInput.
See LabelledContainer

self example

I provide the accessors sliderInput to be more intuitive than subwidget, and the shortcuts input and slider.

I provide shortcuts for the most common methods to avoid the use of the DoesNotUnderstand or the writing of long chain of accessors.!
!LabelledSliderInput methodsFor: 'accessing' stamp: ''!
value: aNumber
	^ self sliderInput value: aNumber! !

!LabelledSliderInput methodsFor: 'api - shortcuts' stamp: ''!
absoluteValue: aBoolean
	^ self sliderInput absoluteValue: aBoolean! !

!LabelledSliderInput methodsFor: 'accessing' stamp: ''!
input
	^ subwidget input! !

!LabelledSliderInput methodsFor: 'api - shortcuts' stamp: ''!
absoluteValue
	^ self sliderInput absoluteValue! !

!LabelledSliderInput methodsFor: 'accessing' stamp: ''!
sliderInput
	^ subwidget! !

!LabelledSliderInput methodsFor: 'initialization' stamp: ''!
initializeWidgets
	super initializeWidgets.
	self content: SliderInput ! !

!LabelledSliderInput methodsFor: 'api - events' stamp: ''!
whenValueChangedDo: aBlock
	self sliderInput whenValueChangedDo: aBlock! !

!LabelledSliderInput methodsFor: 'accessing' stamp: ''!
slider
	^ subwidget slider! !

!LabelledSliderInput methodsFor: 'api - shortcuts' stamp: ''!
min: aNumber
	^ self sliderInput min: aNumber! !

!LabelledSliderInput methodsFor: 'accessing' stamp: ''!
value
	^ self sliderInput value! !

!LabelledSliderInput methodsFor: 'api - shortcuts' stamp: ''!
autoAccept
	^ self sliderInput autoAccept! !

!LabelledSliderInput methodsFor: 'api - shortcuts' stamp: ''!
autoAccept: aBoolean
	^ self sliderInput autoAccept: aBoolean! !

!LabelledSliderInput methodsFor: 'api - shortcuts' stamp: ''!
max: aNumber
	^ self sliderInput max: aNumber! !

!LabelledSliderInput class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self new
		min: 0;
		max: 250;
		autoAccept: true;
		value: 120;
		extent: 400 @ 50;
		title: 'LabelledSliderInput example';
		openWithSpec.
	^ example! !

!LabelledTextInput commentStamp: ''!
I am a LabelledContainer specialized to manage a TextInputFieldPresenter.
See LabelledContainer

self example

I provide the accessor input to be more intuitive than subwidget.

I provide shortcuts for the most common methods of the TextInputFieldPresenter api to avoid the use of the DoesNotUnderstand or the writing of long chain of accessors.!
!LabelledTextInput methodsFor: 'accessing' stamp: ''!
input
	^ self subwidget! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
removeEntryCompletion
	^self input removeEntryCompletion! !

!LabelledTextInput methodsFor: 'initialization' stamp: ''!
initializeWidgets
	super initializeWidgets.
	self content: TextInputFieldPresenter.! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
encrypted: aBoolean
	^self input encrypted: aBoolean! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
text: aText
	self input text: aText! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
acceptOnCR: aBoolean
	^ self input acceptOnCR: aBoolean! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
ghostText: aText
	^self input ghostText: aText! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
acceptBlock: aBlockWithOneArgument
	^ self input acceptBlock: aBlockWithOneArgument! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
selectAll
	^self input selectAll! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
entryCompletion: anEntryCompletion
	^self input entryCompletion: anEntryCompletion! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
beEncrypted
	^ self input beEncrypted! !

!LabelledTextInput methodsFor: 'events - shortcuts' stamp: ''!
whenTextIsAccepted: aBlock
	self input whenTextIsAccepted: aBlock! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
autoAccept: aBoolean
	^ self input autoAccept: aBoolean! !

!LabelledTextInput methodsFor: 'events - shortcuts' stamp: ''!
whenTextChanged: aBlock
	self input whenTextChanged: aBlock! !

!LabelledTextInput methodsFor: 'api - shortcuts' stamp: ''!
text
	^self input text! !

!LabelledTextInput class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self abstractExample.
	example input ghostText: 'Tilt'.
example
		extent: 400 @ 50;
		openWithSpec.
	^ example! !

!LabelledTextInput class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ super labelLeft! !

!LargeInteger commentStamp: ''!
I represent integers of more than 30 bits.  These values are beyond the range of SmallInteger, and are encoded here as an array of 8-bit digits. !
!LargeInteger methodsFor: 'converting' stamp: ''!
asFloat
	"Answer a Float that best approximates the value of the receiver.
	This algorithm is optimized to process only the significant digits of a LargeInteger.
	And it does honour IEEE 754 round to nearest even mode in case of excess precision (see details below)."
	
	"How numbers are rounded in IEEE 754 default rounding mode:
	A shift is applied so that the highest 53 bits are placed before the floating point to form a mantissa.
	The trailing bits form the fraction part placed after the floating point.
	This fractional number must be rounded to the nearest integer.
	If fraction part is 2r0.1, exactly between two consecutive integers, there is a tie.
	The nearest even integer is chosen in this case.
	Examples (First 52bits of mantissa are omitted for brevity):
	2r0.00001 is rounded downward to 2r0
	2r1.00001 is rounded downward to 2r1
	2r0.1 is a tie and rounded to 2r0 (nearest even)
	2r1.1 is a tie and rounded to 2r10 (nearest even)
	2r0.10001 is rounded upward to 2r1
	2r1.10001 is rounded upward to 2r10
	Thus, if the next bit after floating point is 0, the mantissa is left unchanged.
	If next bit after floating point is 1, an odd mantissa is always rounded upper.
	An even mantissa is rounded upper only if the fraction part is not a tie."
	
	"Algorihm details:
	The floating point hardware can perform the rounding correctly with several excess bits as long as there is a single inexact operation.
	This can be obtained by splitting the mantissa plus excess bits in two part with less bits than Float precision.
	Note 1: the inexact flag in floating point hardware must not be trusted because in some cases the operations would be exact but would not take into account some bits that were truncated before the Floating point operations.
	Note 2: the floating point hardware is presumed configured in default rounding mode."
	
	| mantissa shift excess result n |

	"Check how many bits excess the maximum precision of a Float mantissa."
	excess := self highBitOfMagnitude - Float precision.
	excess > 7
		ifTrue:
			["Remove the excess bits but seven."
			mantissa := self bitShiftMagnitude: 7 - excess.
			shift := excess - 7.
			"An even mantissa with a single excess bit immediately following would be truncated.
			But this would not be correct if above shift has truncated some extra bits.
			Check this case, and round excess bits upper manually."
			((mantissa byteAt: 1) = 2r01000000 and: [self anyBitOfMagnitudeFrom: 1 to: shift])
				ifTrue: [mantissa := mantissa + 1]]
		ifFalse:
			[mantissa := self.
			shift := 0].

	"There will be a single inexact round off at last iteration"
	result := (mantissa byteAt: (n := mantissa bytesCount)) asFloat.
	[(n := n - 1) > 0] whileTrue: [
		result := 256.0 * result + (mantissa byteAt: n) asFloat].
	^result timesTwoPower: shift.! !

!LargeInteger methodsFor: 'comparing' stamp: ''!
< 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."

	<primitive: 23>
	^super < anInteger! !

!LargeInteger methodsFor: 'system primitives' stamp: ''!
byteAt: 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."

	<primitive: 60>
	self bytesCount < index
		ifTrue: [^0]
		ifFalse: [^super at: index]! !

!LargeInteger methodsFor: 'arithmetic' stamp: ''!
* 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. "

	<primitive: 29>
	^super * anInteger! !

!LargeInteger methodsFor: 'comparing' stamp: ''!
hash
	^ self bytesCount <= 8
		ifTrue: [ self ]
		ifFalse: [ ByteArray hashBytes: self startingWith: self species hash ]! !

!LargeInteger methodsFor: 'bit manipulation' stamp: ''!
hashMultiply
	"Truncate to 28 bits and try again"

	^(self bitAnd: 16rFFFFFFF) hashMultiply! !

!LargeInteger methodsFor: 'arithmetic' stamp: ''!
rem: aNumber 
	"Remainder defined in terms of quo:. See super rem:.
	This is defined only to speed up case of large integers."

	<primitive: 20>
	 aNumber isInteger
		ifTrue:
			[| ng rem |
			ng := self negative == aNumber negative == false.
			rem := (self digitDiv: aNumber neg: ng) at: 2.
			^ rem normalize].
	^super rem: aNumber! !

!LargeInteger methodsFor: 'arithmetic' stamp: ''!
/ 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. "

	<primitive: 30>
	^super / anInteger! !

!LargeInteger methodsFor: '*Math-Operations-Extensions' stamp: ''!
isPrime
	"Answer true if the receiver is a prime number. Use a probabilistic implementation	 that
	is much faster for large integers, and that is correct to an extremely high statistical
	level of confidence (effectively deterministic)."

	^ self isProbablyPrime! !

!LargeInteger methodsFor: 'arithmetic' stamp: ''!
\\\ anInteger 
	"a faster modulo method for use in DSA. Be careful if you try to use this elsewhere"

	^(self digitDiv: anInteger neg: false) second! !

!LargeInteger methodsFor: 'printing' stamp: ''!
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! !

!LargeInteger methodsFor: 'comparing' stamp: ''!
> 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."

	<primitive: 24>
	^super > anInteger! !

!LargeInteger methodsFor: 'arithmetic' stamp: ''!
\\ aNumber 
	"Primitive. Take the receiver modulo the argument. The result is the
	remainder rounded towards negative infinity, of the receiver divided
	by the argument. Fail if the argument is 0. Fail if either the argument
	or the result is not a SmallInteger or a LargePositiveInteger less than
	2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."

	<primitive: 31>
	aNumber isInteger
		ifTrue:
			[| neg qr q r |
			neg := self negative == aNumber negative == false.
			qr := self digitDiv: aNumber neg: neg.
			q := qr first normalize.
			r := qr last normalize.
			^(q negative
				ifTrue: [r isZero not]
				ifFalse: [q isZero and: [neg]])
					ifTrue: [r + aNumber]
					ifFalse: [r]].
	^super \\ aNumber! !

!LargeInteger methodsFor: 'converting' stamp: ''!
withAtLeastNDigits: desiredLength

	| new |

	self size >= desiredLength ifTrue: [^self].
	new := self class new: desiredLength.
	new
		replaceFrom: 1 
		to: self size 
		with: self 
		startingAt: 1.
	^new! !

!LargeInteger methodsFor: 'arithmetic' stamp: ''!
- 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."

	<primitive: 22>
	^super - anInteger! !

!LargeInteger methodsFor: 'comparing' stamp: ''!
>= 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."

	<primitive: 26>
	^super >= anInteger! !

!LargeInteger methodsFor: 'system primitives' stamp: ''!
bytesCount
	"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."

	<primitive: 62>
	self primitiveFailed! !

!LargeInteger methodsFor: 'system primitives' stamp: ''!
byteAt: 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."

	<primitive: 61>
	^super at: index put: value! !

!LargeInteger methodsFor: 'testing' stamp: ''!
mightBeASquare
	self subclassResponsibility! !

!LargeInteger methodsFor: 'system primitives' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	^ super replaceFrom: start to: stop with: replacement startingAt: repStart! !

!LargeInteger methodsFor: 'arithmetic' stamp: ''!
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."

	<primitive: 33>
	^super quo: anInteger! !

!LargeInteger methodsFor: 'arithmetic' stamp: ''!
// 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. "

	<primitive: 32>
	^super // anInteger! !

!LargeInteger methodsFor: 'bit manipulation' stamp: ''!
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 bytesCount.
	[(lastDigit := self byteAt: realLength) = 0]
		whileTrue: [(realLength := realLength - 1) = 0 ifTrue: [^ 0]].
	^ lastDigit highBitOfPositiveReceiver + (8 * (realLength - 1))! !

!LargeInteger methodsFor: 'testing' stamp: ''!
isLarge
	^true! !

!LargeInteger methodsFor: 'arithmetic' stamp: ''!
+ 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."

	<primitive: 21>
	^super + anInteger! !

!LargeInteger methodsFor: 'comparing' stamp: ''!
<= 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."

	<primitive: 25>
	^super <= anInteger! !

!LargeNegativeInteger commentStamp: ''!
Just like LargePositiveInteger, but represents a negative number.!
!LargeNegativeInteger methodsFor: 'converting' stamp: ''!
asFloat
	^super asFloat negated! !

!LargeNegativeInteger methodsFor: '*Math-Operations-Extensions' stamp: ''!
log
	^DomainError signal: 'log is only defined for x > 0' from: 0! !

!LargeNegativeInteger methodsFor: '*Math-Operations-Extensions' stamp: ''!
sqrt
	"Answer the square root of the receiver."
	^ DomainError signal: 'sqrt undefined for number less than zero.'! !

!LargeNegativeInteger methodsFor: 'printing' stamp: ''!
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: 'arithmetic' stamp: ''!
negated
	^ self copyto: (LargePositiveInteger new: self bytesCount)! !

!LargeNegativeInteger methodsFor: 'arithmetic' stamp: ''!
abs
	^ self negated! !

!LargeNegativeInteger methodsFor: 'testing' stamp: ''!
mightBeASquare
	^false! !

!LargeNegativeInteger methodsFor: 'converting' stamp: ''!
normalize
	"Check for leading zeroes and return shortened copy if so"
	| sLen val len oldLen minVal |
	<primitive: 'primNormalizeNegative' module: 'LargeIntegers'>
	"First establish len = significant length"
	len := oldLen := self bytesCount.
	[len = 0 ifTrue: [^0].
	(self byteAt: len) = 0]
		whileTrue: [len := len - 1].

	"Now check if in SmallInteger range.
	 Fast compute SmallInteger minVal digitLength"
	sLen := SmallInteger minVal < -16r40000000
				ifTrue: [8]
				ifFalse: [4].
	len <= sLen ifTrue:
		[minVal := SmallInteger minVal.
		(len < sLen
		 or: [(self byteAt: 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 byteAt: i)].
					^ val].
		1 to: sLen do:  "If all digits same, then = minVal"
			[:i | (self byteAt: i) = (minVal byteAt: 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: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper
	^ self >= -4294967295
		ifTrue: [ aGeneralMapper mapAndTraceByClusterName: self to: FLNegative32SmallIntegerCluster ]
		ifFalse: [ aGeneralMapper visitBytesObject: self]! !

!LargeNegativeInteger methodsFor: 'testing' stamp: ''!
sign
	"Optimization. Answer -1 since receiver is less than 0."

	^ -1! !

!LargeNegativeInteger methodsFor: 'testing' stamp: ''!
positive
	"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
	See also strictlyPositive"

	^ false! !

!LargeNegativeInteger methodsFor: 'testing' stamp: ''!
signBit
	"Optimization."

	^1! !

!LargeNegativeInteger methodsFor: 'testing' stamp: ''!
negative
	"Answer whether the receiver is mathematically negative."

	^ true! !

!LargeNegativeInteger methodsFor: 'bit manipulation' stamp: ''!
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: 'testing' stamp: ''!
strictlyPositive
	"Answer whether the receiver is mathematically positive."

	^ false! !

!LargeNegativeInteger methodsFor: 'bit manipulation' stamp: ''!
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 bytesCount 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 byteAt: digitIndex) negated bitAt: bitIndex].
	(self byteAt: 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 byteAt: digitIndex) bitAt: bitIndex)! !

!LargeNegativeInteger methodsFor: '*Math-Operations-Extensions' stamp: ''!
ln
	^DomainError signal: 'ln is only defined for x > 0' from: 0! !

!LargeNegativeIntegerTest commentStamp: ''!
SUnit tests for large negative integers!
!LargeNegativeIntegerTest methodsFor: 'tests - printing' stamp: ''!
testStoreOn
	| integer |
	integer := SmallInteger minVal - 1.
	
	"Store on adds a space before a negative number to avoid mistaking it with a - message"
	self
		assert: integer class equals: LargeNegativeInteger;
		assert: (String streamContents: [ :s | integer storeOn: s ]) equals: ' ', integer asString! !

!LargeNegativeIntegerTest methodsFor: 'tests' stamp: ''!
testSqrt
	self should: [(SmallInteger minVal - 1) sqrt] raise: DomainError! !

!LargeNegativeIntegerTest methodsFor: 'tests' stamp: ''!
testEmptyTemplate
	"Check that an uninitialized instance behaves reasonably."

	| i |
	i := LargeNegativeInteger new: 4.
	self assert: i size equals: 4.
	self assert: i printString equals: '-0'.
	self assert: i normalize equals: 0! !

!LargeNegativeIntegerTest methodsFor: 'tests' stamp: ''!
testMinimumNegativeIntegerArithmetic
	"We are speaking of minimum integer in underlying hardware here.
	In 2-complement, abs(INT_MIN) = (INT-MAX+1) and thus overflows hardware register.
	Since some old VM forgot this edge case they may fail and it's better to be aware of it.
	http://code.google.com/p/cog/issues/detail?id=92
	http://bugs.squeak.org/view.php?id=7705
	We only test the cases of 32 and 64 bit signed integers."

	#(32 64) do: [:nBits |
		| largePositiveInt largeNegativeInt |
		largePositiveInt := (1 << (nBits - 1)).
		largeNegativeInt := largePositiveInt negated.
		self assert: (largeNegativeInt >> 3) equals: (largeNegativeInt bitInvert >> 3) bitInvert.
		self assert: (largeNegativeInt + 1) equals: (largePositiveInt - 1) negated.
		self assert: (largeNegativeInt - -1) equals: (largePositiveInt - 1) negated.
		self assert: (largeNegativeInt // -1) equals: largePositiveInt.
		self assert: (largeNegativeInt \\ -1) equals: 0.
		self assert: (largeNegativeInt rem: -1) equals: 0.
		self assert: (largeNegativeInt quo: -1) equals: largePositiveInt.
		self assert: (largeNegativeInt * -1) equals: largePositiveInt.
		self assert: (largeNegativeInt / -1) equals: largePositiveInt]! !

!LargeNegativeIntegerTest methodsFor: 'tests' stamp: ''!
testDenormalizedPrintString
	"Check that an un-normalized instance behaves reasonably."

	| i i0 |
	i := LargeNegativeInteger new: 4.
	i basicAt: 2 put: 255.
	self assert: i size equals: 4.
	self assert: i printString equals: '-65280'.
	self assert: i normalize equals: -65280.
	self assert: (i normalize isMemberOf: SmallInteger).
	i0 := LargeNegativeInteger new: 0.
	self assert: i0 size equals: 0.
	self assert: i0 printString equals: '-0'.
	self assert: i0 normalize equals: 0.
	self assert: (i0 normalize isMemberOf: SmallInteger)! !

!LargeNegativeIntegerTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ LargeNegativeInteger! !

!LargeNegativeIntegerTest methodsFor: 'tests' stamp: ''!
testByteAt

	| lni |
	lni := -114605103402541699037609980192546360895434064385.
	1 to: 20 do: [:i | | digit |
		digit := lni byteAt: i.
		self assert: i equals: digit]! !

!LargeNegativeIntegerTest methodsFor: 'tests' stamp: ''!
testDigitLength

	| lni |
	lni := -114605103402541699037609980192546360895434064385.
	self assert: 20 equals: lni bytesCount! !

!LargeNegativeIntegerTest methodsFor: 'tests' stamp: ''!
testReplaceFromToWithStartingAt

	| lni20 lni7 |
	lni20 := LargeNegativeInteger new: 20.
	1 to: 20 do: [:i | lni20 byteAt: i put: i].
	lni7 := LargeNegativeInteger new: 7.
	1 to: 7 do: [:i | lni7 byteAt: i put: 11 - i].
	lni20 replaceFrom: 6 to: 10 with: lni7 startingAt: 2.
	"unmodified digits"
	(1 to: 5) , (11 to: 20) do: [:e | | digit |
		digit := lni20 byteAt: e.
		self assert: e equals: digit].
	"replaced digits"
	6 to: 10 do: [:e | | digit replacementDigit |
		digit := lni20 byteAt: e.
		replacementDigit := lni7 byteAt: e - 4.
		self assert: replacementDigit equals: digit]! !

!LargeNegativeIntegerTest methodsFor: 'tests' stamp: ''!
testDigitAtPut

	| lni |
	lni := LargeNegativeInteger new: 20.
	1 to: 20 do: [:i | lni byteAt: i put: i].
	self assert: -114605103402541699037609980192546360895434064385 equals: lni! !

!LargePositiveInteger commentStamp: ''!
I represent positive integers of more than 30 bits (ie, >= 1073741824).  These values are beyond the range of SmallInteger, and are encoded here as an array of 8-bit digits.  Care must be taken, when new values are computed, that any result that COULD BE a SmallInteger IS a SmallInteger (see normalize).

Note that the bit manipulation primitives, bitAnd:, bitShift:, etc., = and ~= run without failure (and therefore fast) if the value fits in 32 bits.  This is a great help to the simulator.!
!LargePositiveInteger methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
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: 'bit manipulation' stamp: ''!
hashMultiply
	"This is a multiplication of hashes by 1664525 mod 2^28 written to avoid overflowing into large integers.
	 The primitive is able to perform the operation with modulo arihmetic.
	
	Example of usage:
	  hash
	    ^ (super hash + variableName hash) hashMultiply 	
	"
	
	<primitive: 159>
	"Truncate to 28 bits and try again"
	^(self bitAnd: 16rFFFFFFF) hashMultiply! !

!LargePositiveInteger methodsFor: 'arithmetic' stamp: ''!
negated 
	^ (self copyto: (LargeNegativeInteger new: self bytesCount))
		normalize  "Need to normalize to catch SmallInteger minVal"! !

!LargePositiveInteger methodsFor: 'arithmetic' stamp: ''!
abs! !

!LargePositiveInteger methodsFor: 'testing' stamp: ''!
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 byteAt: 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: 'converting' stamp: ''!
normalize
	"Check for leading zeroes and return shortened copy if so"
	| sLen val len oldLen |
	<primitive: 'primNormalizePositive' module:'LargeIntegers'>
	"First establish len = significant length"
	len := oldLen := self bytesCount.
	[len = 0 ifTrue: [^0].
	(self byteAt: len) = 0]
		whileTrue: [len := len - 1].

	"Now check if in SmallInteger range.  Fast compute SmallInteger maxVal digitLength"
	sLen := SmallInteger maxVal > 16r3FFFFFFF
				ifTrue: [8]
				ifFalse: [4].
	(len <= sLen
	 and: [(self byteAt: sLen) <= (SmallInteger maxVal byteAt: sLen)])
		ifTrue: ["If so, return its SmallInt value"
				val := 0.
				len to: 1 by: -1 do:
					[:i | val := (val *256) + (self byteAt: i)].
				^ val].

	"Return self, or a shortened copy"
	len < oldLen
		ifTrue: [^ self growto: len]
		ifFalse: [^ self]! !

!LargePositiveInteger methodsFor: 'printing' stamp: ''!
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 bytesCount = 0 or: [(self byteAt: self bytesCount) = 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: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper
	^ self <= 4294967295 
		ifTrue: [ aGeneralMapper  mapAndTraceByClusterName: self to: FLPositive32SmallIntegerCluster ]
		ifFalse: [ aGeneralMapper visitBytesObject: self]! !

!LargePositiveInteger methodsFor: 'testing' stamp: ''!
sign
	"Optimization. Answer 1 since receiver is greater than 0."

	^ 1! !

!LargePositiveInteger methodsFor: 'testing' stamp: ''!
positive
	"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
	See also strictlyPositive"

	^ true! !

!LargePositiveInteger methodsFor: 'testing' stamp: ''!
signBit
	"Optimization."

	^0! !

!LargePositiveInteger methodsFor: 'testing' stamp: ''!
negative
	"Answer whether the receiver is mathematically negative."

	^ false! !

!LargePositiveInteger methodsFor: 'bit manipulation' stamp: ''!
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: 'testing' stamp: ''!
strictlyPositive
	"Answer whether the receiver is mathematically positive."

	^ true! !

!LargePositiveInteger methodsFor: 'bit manipulation' stamp: ''!
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 bytesCount ifTrue: [^0].
	bitIndex := anInteger - 1 \\ 8 + 1.
	^(self byteAt: digitIndex) bitAt: bitIndex! !

!LargePositiveInteger methodsFor: '*Math-Operations-Extensions' stamp: ''!
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! !

!LargePositiveIntegerTest commentStamp: ''!
SUnit tests for large positive integers!
!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
testDigitAt

	| lpi |
	lpi := 114605103402541699037609980192546360895434064385.
	1 to: 20 do: [:i | | digit |
		digit := lpi byteAt: i.
		self assert: i equals: digit]! !

!LargePositiveIntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testMultDicAddSub
	| n f f1 |
	n := 100.
	f := 100 factorial.
	f1 := f * (n + 1).
	n timesRepeat: [ f1 := f1 - f ].
	self assert: f1 equals: f.
	n timesRepeat: [ f1 := f1 + f ].
	self assert: f1 // f equals: n + 1.
	self
		assert: f1 negated
		equals: (Number readFrom: '-' , f1 printString)! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
x13kbits
	"Return a 13 kilo bits integer"
	^(15 to: 44 by: 4)
				inject: 9753102468
				into: [:big :bits | big * big << bits + bits]! !

!LargePositiveIntegerTest methodsFor: 'tests - printing' stamp: ''!
testStoreOn
	| integer |
	integer := SmallInteger maxVal + 1.
	self
		assert: integer class equals: LargePositiveInteger;
		assert: (String streamContents: [ :s | integer storeOn: s ]) equals: integer asString! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
testSqrt
	self assert: (SmallInteger maxVal + 1) sqrt equals: (SmallInteger maxVal + 1) asFloat sqrt.! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
x92kbits
	"Return a 92 kilo bits integer"
	^(11 to: 51 by: 4)
			inject: 1357924680
			into: [:big :bits | big * big << bits + bits]! !

!LargePositiveIntegerTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testLargeSqrtFloor
	"This test fails if a careless implementation naivly factors out the power of two (remove the trailing zeroes up to lowBit).
	This was the case in a previous implementation, so this is a non regression test."

	| large root |
	large := (SmallInteger maxVal << 100) + 1 << 100.
	root := large sqrtFloor.
	self assert: root squared <= large.
	self assert: (root + 1) squared > large! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
x106kbits
	"Return a 106 kilo bits integer"
	^(15 to: 55 by: 4)
				inject: 9876543210
				into: [:big :bits | big * big << bits + bits]! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
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: ''!
testEmptyTemplate
	"Check that an uninitialized instance behaves reasonably."

	| i |
	i := LargePositiveInteger new: 4.
	self assert: i size equals: 4.
	self assert: i printString equals: '0'.
	self assert: i normalize equals: 0! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
assertSqrtCorrectlyRoundedForExponent: exp
	"Requires exp > Float precision, so that f ulp/2 is integer"
	{1.5. 1.25 squared. 2.0 predecessor} do: [:sf |
		| f xe xp xm |
		
		f := sf timesTwoPower: exp.
	
		"make two integers around the pivot"
		xe := f asInteger + (f ulp asInteger / 2).
		xm := xe squared - 1.
		xp := xe squared + 1.
		self assert: xe squared sqrt equals: xe.
		self assert: xe squared sqrt isInteger.
	
		"check rounding when result is near f squared"
		self assert: xm sqrt equals: f.
		self assert: xm sqrt isFloat.
		self assert: xp sqrt equals: f successor.
		self assert: xp sqrt isFloat.
	
		"same in the other direction"
		xe := f asInteger - (f ulp asInteger / 2).
		xm := xe squared - 1.
		xp := xe squared + 1.
		self assert: xe squared sqrt equals: xe.
		self assert: xe squared sqrt isInteger.
	
		"check rounding when result is near f squared"
		self assert: xm sqrt equals: f predecessor.
		self assert: xm sqrt isFloat.
		self assert: xp sqrt equals: f.
		self assert: xp sqrt isFloat].! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
testNormalize
	"Check normalization and conversion to/from SmallInts"

	self assert: SmallInteger maxVal + 1 - 1 identicalTo: SmallInteger maxVal.
	self assert: SmallInteger maxVal + 3 - 6 identicalTo: SmallInteger maxVal - 3.
	self should: SmallInteger minVal - 1 + 1 == SmallInteger minVal.
	self assert: SmallInteger minVal - 3 + 6 identicalTo: SmallInteger minVal + 3! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
testDenormalizedPrintString
	"Check that an un-normalized instance behaves reasonably."

	| i i0 |
	i := LargePositiveInteger new: 4.
	i basicAt: 2 put: 255.
	self assert: i size equals: 4.
	self assert: i printString equals: '65280'.
	self assert: i normalize equals: 65280.
	self assert: (i normalize isMemberOf: SmallInteger).
	i0 := LargePositiveInteger new: 0.
	self assert: i0 size equals: 0.
	self assert: i0 printString equals: '0'.
	self assert: i0 normalize equals: 0.
	self assert: (i0 normalize isMemberOf: SmallInteger)! !

!LargePositiveIntegerTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ LargePositiveInteger! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
testDigitLength

	| lpi |
	lpi := 114605103402541699037609980192546360895434064385.
	self assert: 20 equals: lpi bytesCount! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
testReplaceFromToWithStartingAt

	| lpi20 lpi7 |
	lpi20 := LargePositiveInteger new: 20.
	1 to: 20 do: [:i | lpi20 byteAt: i put: i].
	lpi7 := LargePositiveInteger new: 7.
	1 to: 7 do: [:i | lpi7 byteAt: i put: 11 - i].
	lpi20 replaceFrom: 6 to: 10 with: lpi7 startingAt: 2.
	"unmodified digits"
	(1 to: 5) , (11 to: 20) do: [:e | | digit |
		digit := lpi20 byteAt: e.
		self assert: e equals: digit].
	"replaced digits"
	6 to: 10 do: [:e | | digit replacementDigit |
		digit := lpi20 byteAt: e.
		replacementDigit := lpi7 byteAt: e - 4.
		self assert: replacementDigit equals: digit]! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
x23kbits
	"Return a 23 kilo bits integer"
	^(11 to: 44 by: 4)
			inject: 1234567890
			into: [:big :bits | big * big << bits + bits]! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
testDigitAtPut

	| lpi |
	lpi := LargePositiveInteger new: 20.
	1 to: 20 do: [:i | lpi byteAt: i put: i].
	self assert: 114605103402541699037609980192546360895434064385 equals: lpi! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: ''!
testReciprocalModulo
	| large r |
	large := 1 bitShift: 48.
	r := Random seed: 46912151.
	4691
		timesRepeat: [ | a b c t |
			a := (r nextInteger: large) + 1.
			b := (r nextInteger: large) + 1.
			a > b
				ifTrue: [ t := a.
					a := b.
					b := t ].
			(a gcd: b) = 1
				ifTrue: [ c := a reciprocalModulo: b.
					self assert: a * c \\ b equals: 1 ]
				ifFalse: [ self should: [ a reciprocalModulo: b ] raise: Error ] ]! !

!LayoutCell commentStamp: ''!
I am used in table layouts to hold temporary values while the layout is being computed.

Instance variables:
	target 		<Morph>		The morph contained in this cell
	cellSize 		<Point>		The size of the cell
	extraSpace 	<nil | Point>	Additional space to add after this cell
	nextCell 	<nil | LayoutCell>	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: ''!
hSpaceFill
	^self flags anyMask: 1! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
addExtraSpace: aPoint
	extraSpace := extraSpace
		ifNil: [ aPoint ]
		ifNotNil: [ extraSpace + aPoint ]! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
nextCell
	^nextCell! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
extraSpace: aPoint
	extraSpace := aPoint! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
cellSize: aPoint
	cellSize := aPoint! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
extraSpace
	^extraSpace ifNil:[0@0]! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
vSpaceFill
	^self flags anyMask: 2! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
hSpaceFill: aBool
	flags := aBool ifTrue:[self flags bitOr: 1] ifFalse:[self flags bitClear: 1].! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
size
	| n cell |
	n := 0.
	cell := self.
	[cell isNil] whileFalse: 
			[n := n + 1.
			cell := cell nextCell].
	^n! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
vSpaceFill: aBool
	flags := aBool ifTrue:[self flags bitOr: 2] ifFalse:[self flags bitClear: 2].! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
cellSize
	^cellSize! !

!LayoutCell methodsFor: 'collection' stamp: ''!
do: aBlock
	aBlock value: self.
	nextCell ifNotNil:[nextCell do: aBlock].! !

!LayoutCell methodsFor: 'collection' stamp: ''!
inject: thisValue into: binaryBlock 
	"Accumulate a running value associated with evaluating the argument, 
	binaryBlock, with the current value of the argument, thisValue, and the 
	receiver as block arguments. For instance, to sum the numeric elements 
	of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + 
	next]."

	| nextValue |
	nextValue := thisValue.
	self do: [:each | nextValue := binaryBlock value: nextValue value: each].
	^nextValue! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
target
	^target! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
nextCell: aCell
	nextCell := aCell! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
flags
	^flags ifNil: [ 0 ]! !

!LayoutCell methodsFor: 'accessing' stamp: ''!
target: newTarget
	target := newTarget! !

!LayoutClassScope commentStamp: ''!
I am layout scope for classes.!
!LayoutClassScope methodsFor: 'testing' stamp: ''!
hasSlots
	self size > 0 
		ifTrue: [ ^ true ].
	^ parentScope hasSlots! !

!LayoutClassScope methodsFor: 'comparing' stamp: ''!
= other
	super = other
		ifFalse: [ ^ false ].
	
	self size = other size
		ifFalse: [ ^ false ].
	
	1 to: self size do:  [ :index|
		(self at: index) = (other at: index)
			ifFalse: [ ^ false ]].
	
	^ self parentScope = other parentScope.! !

!LayoutClassScope methodsFor: 'accessing' stamp: ''!
parentScope
	^ parentScope! !

!LayoutClassScope methodsFor: 'comparing' stamp: ''!
hash
	| hash |
	hash := super hash.
	1 to: self size do: [ :i | 
		hash := (hash + (self at: i) hash) hashMultiply].
	^ hash + self parentScope hash hashMultiply.! !

!LayoutClassScope methodsFor: 'accessing' stamp: ''!
fieldSize
	^ parentScope fieldSize + self ownFieldSize.! !

!LayoutClassScope methodsFor: 'accessing' stamp: ''!
ownFieldSize
	|result|
	result := 0.
	self do: [ :slot | result := result + slot size ].
	^ result! !

!LayoutClassScope methodsFor: 'accessing' stamp: ''!
slots
	| result |
	result := OrderedCollection new.
	self do: [ :slot |  result add: slot].
	^ result asArray! !

!LayoutClassScope methodsFor: 'accessing' stamp: ''!
allVisibleSlots
	| result |
	result := parentScope allVisibleSlots.
	self do: [ :slot | 
		slot isVisible 
			ifTrue: [ result add: slot ]].
	^ result! !

!LayoutClassScope methodsFor: 'testing' stamp: ''!
hasFields
	self do: [ :slot | 
		slot size > 0 
			ifTrue: [ ^ true ]].
	^ parentScope hasFields! !

!LayoutClassScope methodsFor: 'enumerating' stamp: ''!
hasBindingThatBeginsWith: aString
	"Answer true if there is a Slot name that begins with aString, false otherwise"
	
	self allSlotsDo: [:each | 
		(each name beginsWith: aString)
			ifTrue:[^true]].
	^false! !

!LayoutClassScope methodsFor: 'flattening' stamp: ''!
flatten
	| result |
	result := parentScope flatten.
	result addAll: self.
	^ result! !

!LayoutClassScope methodsFor: 'copying' stamp: ''!
postCopy
	parentScope := parentScope copy.
	1 to: self size do: [ :index | 
		self at: index put: (self at: index) copy ]! !

!LayoutClassScope methodsFor: 'printing' stamp: ''!
printOn: aStream
	
	super printOn: aStream.
	self allVisibleSlots printElementsOn: aStream.! !

!LayoutClassScope methodsFor: 'accessing' stamp: ''!
parentScope: aLayoutScope
	parentScope := aLayoutScope! !

!LayoutClassScope methodsFor: 'enumerating' stamp: ''!
reverseDo: aBlock
	|size|
	size := self size.
	1 to: size do: [ :index |
		aBlock value: (self at: (1 + size - index)) ]! !

!LayoutClassScope methodsFor: 'accessing' stamp: ''!
visibleSlots
	| result |
	result := OrderedCollection new.
	self do: [ :slot | 
		slot isVisible 
			ifTrue: [ result add: slot ]].
	^ result asArray! !

!LayoutClassScope methodsFor: 'enumerating' stamp: ''!
do: aBlock
	1 to: self size do: [ :index |
		aBlock value: (self at: index) ]! !

!LayoutClassScope methodsFor: 'enumerating' stamp: ''!
allSlotsDo: aBlock
	parentScope allSlotsDo: aBlock.
	self do: aBlock! !

!LayoutClassScope methodsFor: 'enumerating' stamp: ''!
withIndexDo: elementAndIndexBlock 
	"Just like do: except that the iteration index supplies the second argument to the block"
	1 to: self size do:
		[:index |
		elementAndIndexBlock
			value: (self at: index)
			value: index]! !

!LayoutClassScope methodsFor: 'testing' stamp: ''!
ifNotEmpty: aBlock
	"This scope is not empty so we evaluate the block"
	aBlock value: self! !

!LayoutEmptyScope commentStamp: ''!
I am the last layout scope in a scope chain.!
!LayoutEmptyScope methodsFor: 'testing' stamp: ''!
hasSlots
	^ false! !

!LayoutEmptyScope methodsFor: 'accessing' stamp: ''!
visibleSlots
	^ #()! !

!LayoutEmptyScope methodsFor: 'accessing' stamp: ''!
fieldSize
	^ 0! !

!LayoutEmptyScope methodsFor: 'accessing' stamp: ''!
ownFieldSize
	^ 0! !

!LayoutEmptyScope methodsFor: 'enumerating' stamp: ''!
allSlotsDo: aBlock! !

!LayoutEmptyScope methodsFor: 'accessing' stamp: ''!
allVisibleSlots
	^ OrderedCollection new! !

!LayoutEmptyScope methodsFor: 'testing' stamp: ''!
hasFields
	^ false! !

!LayoutEmptyScope methodsFor: 'testing' stamp: ''!
hasBindingThatBeginsWith: aString
	^false! !

!LayoutEmptyScope methodsFor: 'flattening' stamp: ''!
flatten
	^ OrderedCollection new! !

!LayoutEmptyScope methodsFor: 'testing' stamp: ''!
ifNotEmpty: aBlock
	"This scope is empty so we do nothing"! !

!LayoutEmptyScope class methodsFor: 'accessing' stamp: ''!
instance
	^ instance ifNil: [ instance := self new ]! !

!LayoutFrame commentStamp: ''!
I define a transformation frame relative to some rectangle. I'm basic data structure used for graphics.

Do not use fractions: fractionsOrNil offsets: offsetsOrNil or fractions: fractionsOrNil if you do not have already the rectangles that should be passed as arguments.

If you are creating the rectangles representing the numbers you need, better use the accessors. For example like this.  

	(LayoutFrame identity
			topOffset: topHeight;
			bottomFraction: 0;
			bottomOffset: self buttonsBarHeight;
			leftOffset: -1;
			rightOffset: 1)	

Use printOnForHelpingMigration: if you want to inspect the object.

Instance variables:
	leftFraction 
	topFraction 
	rightFraction 
	bottomFraction 	<Float>		The fractional distance (between 0 and 1) to place the morph in its owner's bounds
	leftOffset 
	topOffset 
	rightOffset 
	bottomOffset 	<Integer>	Fixed pixel offset to apply after fractional positioning (e.g., "10 pixel right of the center of the owner")!
!LayoutFrame methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
isHorizontallyResizeable

	^ self rightFraction ~= self leftFraction! !

!LayoutFrame methodsFor: 'layout' stamp: ''!
layout: oldBounds in: newBounds
	"Return the proportional rectangle insetting the given bounds"

	^ self transform: newBounds! !

!LayoutFrame methodsFor: 'comparing' stamp: ''!
= aFrame
	^self species = aFrame species
		and:[ self leftFraction == aFrame leftFraction
		and:[ self leftOffset == aFrame leftOffset
		and:[ self topFraction == aFrame topFraction
		and:[ self topOffset == aFrame topOffset
		and:[ self rightFraction == aFrame rightFraction
		and:[ self rightOffset == aFrame rightOffset
		and:[ self bottomFraction == aFrame bottomFraction
		and:[ self bottomOffset == aFrame bottomOffset]]]]]]]]! !

!LayoutFrame methodsFor: 'comparing' stamp: ''!
hash
	^(((((((( self species hash
		+ leftFraction hash) hashMultiply
		+ leftOffset hash) hashMultiply
		+ topFraction hash) hashMultiply
		+ topOffset hash) hashMultiply
		+ rightFraction hash) hashMultiply
		+ rightOffset hash) hashMultiply
		+ bottomFraction hash) hashMultiply
		+ bottomOffset hash) hashMultiply! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
rightFraction: aNumber offset: anInteger

	rightFraction := aNumber.
	rightOffset := anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
leftFraction: aNumber offset: anInteger

	leftFraction := aNumber.
	leftOffset := anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
topOffset: anInteger
	topOffset := anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
leftOffset: anInteger
	leftOffset := anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
topFraction: aNumber offset: anInteger

	topFraction := aNumber.
	topOffset := anInteger! !

!LayoutFrame methodsFor: 'converting' stamp: ''!
asArray
	 
	^ { leftFraction . 
		topFraction .
		rightFraction .
		bottomFraction .	
		leftOffset .
		topOffset .
		rightOffset .
		bottomOffset }! !

!LayoutFrame methodsFor: 'layout' stamp: ''!
center: targetMorph with: anotherMorph
	"Change the receiver to center the targetMorph with anotherMorph. 
	Note the targetMorph is the morph on which the receiver will be applied.
	anotherMorph is often the morph containing the targetMorph. 
	"
	
	self topOffset: (anotherMorph height - targetMorph height) // 2.
	self leftOffset: (anotherMorph width - targetMorph width) // 2.! !

!LayoutFrame methodsFor: 'printing' stamp: ''!
isSelfEvaluating
	^ false! !

!LayoutFrame methodsFor: '*Polymorph-Widgets-override' stamp: ''!
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: 'printing' stamp: ''!
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: 'accessing' stamp: ''!
leftFraction
	^leftFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
rightFraction
	^rightFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
rightOffset
	^rightOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
rightOffset: anInteger
	rightOffset := anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
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: 'objects from disk' stamp: ''!
negateBottomRightOffsets

	bottomOffset := bottomOffset negated.
	rightOffset := rightOffset negated.! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
bottomOffset: anInteger
	bottomOffset := anInteger! !

!LayoutFrame methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
isVerticallyResizeable

	^ self bottomFraction ~= self topFraction! !

!LayoutFrame methodsFor: 'initialization' stamp: ''!
initialize
	"initialize defaults:
	 - all offsets are zero
	 - fraction frame is maximum"
	leftOffset := rightOffset := topOffset := bottomOffset := 0.
	
	leftFraction := topFraction := 0.
	rightFraction := bottomFraction := 1.! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
rightFraction: aNumber
	rightFraction := aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
bottomFraction
	^ bottomFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
topLeftOffset: aPoint
	"If you construct a point on purpose to call this method, better use directly the correct accessors, i.e. 
	topLeftOffset: 100 @ 200
	=> 
	topOffset: 200.
	leftOffset: 100. 
	"
	topOffset := aPoint y.
	leftOffset := aPoint x.! !

!LayoutFrame methodsFor: 'testing' stamp: ''!
hasNoOffsets

	^ leftOffset = 0 and: [rightOffset = 0  and: [ topOffset = 0 and: [ bottomOffset = 0 ]]].! !

!LayoutFrame methodsFor: 'converting' stamp: ''!
asLayoutFrame
	 ^self! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
topFraction: aNumber
	topFraction := aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
leftOffset
	^leftOffset! !

!LayoutFrame methodsFor: 'printing' stamp: ''!
printOnForHelpingMigration: aStream
	aStream
		nextPutAll: '(' ;
		nextPutAll: self className;
		nextPutAll: ' identity'; cr;
		nextPutAll: 'topOffset: ';
		print: self topOffset; cr;
		nextPutAll: 'bottomFraction: ';
		print: self bottomFraction; cr;
		nextPutAll: 'bottomOffset: ';
		print: self bottomOffset; cr;
		nextPutAll: 'leftOffset: ';
		print: self leftOffset; cr;
		nextPutAll: 'rightOffset: ';
		print: self rightOffset;
		nextPutAll: ') '! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
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: 'transforming' stamp: ''!
transform: outerReferenceRectangle
	"Answer a new rectangle which transformed by receiver relative to outerReferenceRectangle.
	If it is not possible to place a outerReferenceRectangle *inside*  this reference rectangle, then result will be zero-width (or zero-height) rectangle. Basically you transform to obtain a subrectangle area inside the reference rectangle"
	
	|  left right top bottom |
	left := (outerReferenceRectangle left + (outerReferenceRectangle width * leftFraction) + leftOffset) rounded asInteger.
	right := (outerReferenceRectangle right - (outerReferenceRectangle width * (1 - rightFraction)) + rightOffset) rounded asInteger.
	top:= (outerReferenceRectangle top + (outerReferenceRectangle height * topFraction) + topOffset ) rounded asInteger.
	bottom:= (outerReferenceRectangle bottom - (outerReferenceRectangle height * (1 - bottomFraction)) + bottomOffset) rounded asInteger. 
	
	right < left ifTrue: [ right := left ].
	bottom < top ifTrue: [ bottom := top ].
	
	^ Rectangle left: left right: right top: top bottom: bottom! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
bottomFraction: aNumber offset: anInteger

	bottomFraction := aNumber.
	bottomOffset := anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
bottomRightOffset: aPoint
	"If you construct a point on purpose to call this method, better use directly the correct accessors, i.e. 
	bottomRightOffset: 100 @ 200
	=> 
	bottomOffset: 200.
	rightOffset: 100. 
	"

	bottomOffset := aPoint y.
	rightOffset := aPoint x.! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
leftFraction: aNumber
	leftFraction := aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
bottomOffset
	^bottomOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
topOffset
	^topOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
bottomFraction: aNumber
	bottomFraction := aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: ''!
topFraction
	^topFraction! !

!LayoutFrame class methodsFor: 'instance creation' stamp: ''!
identity
	"by default a layout frame is initialized to represent the identity transformation"
	^ self new! !

!LayoutFrameTest commentStamp: ''!
SUnit tests for class LayoutFrame!
!LayoutFrameTest methodsFor: 'tests' stamp: ''!
testSpaceFill
	| lf rectangle |
	lf := LayoutFrame identity.
	rectangle := lf layout: nil in: (50 @ 10 corner: 150 @ 70).
	self assert: (50 @ 10 corner: 150 @ 70) equals: rectangle! !

!LayoutFrameTest methodsFor: 'tests' stamp: ''!
testTransform
	"the transform: operation is transforming a layoutFrame relatively to the reference rectangle: basically you transform to obtain a subrectangle area inside the reference rectangle"

	| 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) equals: rectangle! !

!LayoutFrameTest methodsFor: 'tests' stamp: ''!
testTransformReturnASubArea
	"the transform: operation is transforming a layoutFrame relatively to the reference rectangle: basically you transform to obtain a subrectangle area inside the reference rectangle"

	| lf rectangle refRectangle |
	lf := LayoutFrame new
		leftOffset: 10;
		topOffset: 10;
		rightOffset: -10;
		bottomOffset: -10;
		yourself.
	refRectangle := 0 @ 0 extent: 100 @ 200.
	rectangle := lf transform: refRectangle.
	self assert: rectangle width equals: 80.
	self assert: rectangle height equals: 180! !

!LayoutFrameTest methodsFor: 'tests - conversion' stamp: ''!
testAsLayoutFrame
	| frame |
	
	"do not use this method. Do not create an explicit array to create a layout
	only use it, if you are given an array from somewhere else"
	frame := #(0.66 0.5 1 0.77 1 2 3 25) asLayoutFrame.
	self assert: frame leftFraction equals: 0.66.
	self assert: frame topFraction equals: 0.5.
	self assert: frame leftOffset equals: 1.
	self assert: frame topOffset equals: 2.
	
	self assert: frame rightFraction equals: 1.
	self assert: frame bottomFraction equals: 0.77.
	self assert: frame rightOffset equals: 3.
	self assert: frame bottomOffset equals: 25.! !

!LayoutFrameTest methodsFor: 'tests' stamp: ''!
testTransformReturnEmptyRectangleWhenNotPossibleToPlace
	"the transform: operation is transforming a layoutFrame relatively to the reference rectangle: basically you transform to obtain a subrectangle area inside the reference rectangle"

	| lf rectangle refRectangle |
	lf := LayoutFrame new
		leftOffset: 10;
		topOffset: 10;
		rightOffset: -10;
		bottomOffset: -10;
		yourself.
	refRectangle := 0 @ 0 extent: 10 @ 10.
	rectangle := lf transform: refRectangle.
	self assert: rectangle width equals: 0.
	self assert: rectangle height equals: 0! !

!LayoutFrameTest methodsFor: 'tests' stamp: ''!
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) equals: rectangle! !

!LayoutFrameTest methodsFor: 'tests' stamp: ''!
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) equals: rectangle! !

!LayoutFrameTest methodsFor: 'tests' stamp: ''!
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) equals: rectangle! !

!LayoutFrameTest methodsFor: 'tests - conversion' stamp: ''!
testIdentity
	self assert: LayoutFrame new equals: LayoutFrame identity! !

!LayoutPolicy commentStamp: ''!
A LayoutPolicy defines how submorphs of some morph should be arranged. Subclasses of the receiver define concrete layout policies.!
!LayoutPolicy methodsFor: 'layout' stamp: ''!
layout: aMorph in: newBounds
	"Compute the layout for the given morph based on the new bounds"! !

!LayoutPolicy methodsFor: 'layout' stamp: ''!
flushLayoutCache
	"Flush any cached information associated with the receiver"! !

!LayoutPolicy methodsFor: 'utilities' stamp: ''!
indexForInserting: aMorph at: aPoint in: someMorph
	"Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion."
	^1 "front-most"! !

!LayoutPolicy methodsFor: 'layout' stamp: ''!
minExtentOf: aMorph in: newBounds
	"Return the minimal size aMorph's children would require given the new bounds"
	^0@0! !

!LayoutPolicy methodsFor: 'testing' stamp: ''!
isTableLayout
	^false! !

!LayoutPolicy methodsFor: 'testing' stamp: ''!
isProportionalLayout
	^false! !

!LayoutProperties commentStamp: ''!
This class provides a compact bit encoding for the most commonly used layout properties.!
!LayoutProperties methodsFor: 'table defaults' stamp: ''!
wrapCentering
	^#topLeft! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
maxCellSize
	^SmallInteger maxVal! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
wrapDirection
	^#none! !

!LayoutProperties methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	hResizing := vResizing := #rigid.
	disableLayout := false.! !

!LayoutProperties methodsFor: 'accessing' stamp: ''!
hResizing
	^hResizing! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
cellSpacing
	"Default"
	^#none! !

!LayoutProperties methodsFor: 'accessing' stamp: ''!
disableTableLayout
	^disableLayout! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
layoutInset
	^0! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
listCentering
	"Default"
	^#topLeft! !

!LayoutProperties methodsFor: 'accessing' stamp: ''!
hResizing: aSymbol
	hResizing := aSymbol! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
minCellSize
	^0! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
reverseTableCells
	^false! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
rubberBandCells
	^false! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
cellPositioning
	^#center! !

!LayoutProperties methodsFor: 'accessing' stamp: ''!
disableTableLayout: aBool
	disableLayout := aBool! !

!LayoutProperties methodsFor: 'accessing' stamp: ''!
vResizing
	^vResizing! !

!LayoutProperties methodsFor: 'accessing' stamp: ''!
vResizing: aSymbol
	vResizing := aSymbol! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
cellInset
	"Default"
	^0! !

!LayoutProperties methodsFor: 'testing' stamp: ''!
includesTableProperties
	^false! !

!LayoutProperties methodsFor: 'table defaults' stamp: ''!
listDirection
	"Default"
	^#topToBottom! !

!LayoutProperties methodsFor: 'converting' stamp: ''!
asTableLayoutProperties
	^(TableLayoutProperties new)
		hResizing: self hResizing;
		vResizing: self vResizing;
		disableTableLayout: self disableTableLayout;
		yourself! !

!LayoutProperties methodsFor: 'initialize' stamp: ''!
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: ''!
listSpacing
	"Default"
	^#none! !

!LazyClassListExample commentStamp: ''!
LazyClassListExample new openOn: Object
!
!LazyClassListExample methodsFor: 'accessing' stamp: ''!
treeMorphClass
	^ LazyMorphTreeMorph! !

!LazyClassListExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>

	^LazyClassListExample new openOn: Object! !

!LazyClassVariable commentStamp: ''!
A class variable that is lazy initialized with a default value. 

Lazy initialized variables are implemented in Smalltalk by doing a nil check in the read accessor method.

This class variable instead does the nil check as part of the variable read operation.

#name => LazyClassVariable default: 5.

#name => LazyClassVariable defaultBlock: [ 'a bloc' ].

#name => LazyClassVariable defaultBlock: [ :object | 'a bloc, parameter is the class' ].!
!LazyClassVariable methodsFor: 'meta-object-protocol' stamp: ''!
read
	"if the value is nil, we evaluate the default block with the object as a potential parameter"
	^ super read ifNil: [ 
		default isBlock 
			ifTrue: [ self write: (default cull: self definingClass) ] 
			ifFalse: [ self write: default ] ]! !

!LazyClassVariable methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	"generate bytecode for '<varname> ifNil: [<varname> := default cull: self]'"
	aMethodBuilder
		pushLiteralVariable: self;
		pushDup;
		pushLiteral: nil;
		send: #==;
		jumpAheadTo: #target if: false;
		popTop;
		pushLiteral: default.
	default isBlock ifTrue: [ 
		aMethodBuilder	
			pushReceiver;
			send: #definingClass;
			send: #cull:].
	aMethodBuilder
		storeIntoLiteralVariable: self;
		jumpAheadTarget: #target! !

!LazyClassVariableTest methodsFor: 'tests' stamp: ''!
testLazyClassVariablePrint
	| classVariable |
	classVariable := #myClassVar => LazyClassVariable default: 5 .
	self assert: classVariable printString equals: '#myClassVar => LazyClassVariable default: 5'.
	classVariable := #myClassVar => LazyClassVariable default: [ 5 ].
	self assert: classVariable printString equals: '#myClassVar => LazyClassVariable default: [ 5 ]'.
	"if the default is really a block"
	classVariable := #myClassVar => LazyClassVariable default: [ 5 ].
	self assert: classVariable printString equals: '#myClassVar => LazyClassVariable default: [ 5 ]' ! !

!LazyClassVariableTest methodsFor: 'tests' stamp: ''!
testLazyClassVarReadReflective
	| classVar |
	classVar := #ClassVar => LazyClassVariable default: 5.
	aClass := self make: [ :builder | builder sharedVariables: {classVar}].

	self assert: classVar read equals: 5.
	classVar write: 10.
	self assert: classVar read equals: 10
	
	
	
	
	! !

!LazyClassVariableTest methodsFor: 'tests' stamp: ''!
testLazyClassVarReadReflectiveBlock
	| classVar |
	classVar := #ClassVar => LazyClassVariable default: [5].
	aClass := self make: [ :builder | builder sharedVariables: {classVar}].

	self assert: classVar read equals: 5.
	classVar write: 10.
	self assert: classVar read equals: 10
	
	
	
	
	! !

!LazyClassVariableTest methodsFor: 'tests' stamp: ''!
testLazyClassVarCompiled
	| classVar |
	classVar := #ClassVar => LazyClassVariable default: 5.
	aClass := self make: [ :builder | builder sharedVariables: {classVar}].

	self compileAccessorsFor: classVar.
	self assert: aClass new ClassVar equals: 5.
	aClass new ClassVar: 6.
	self assert: aClass new ClassVar equals: 6
	
	

	! !

!LazyListMorph commentStamp: ''!
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: 'row management' stamp: ''!
unselectRow: index
	"Unselect the index-th row."
	
	selectedRows remove: index ifAbsent: [^self].
	self invalidRect: (self selectionFrameForRow: index)! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	listItems isEmpty
		ifTrue: [^ self].
		
	aCanvas fillRectangle: aCanvas clipRect color: (self theme listNormalFillStyleFor: self).
		
	"self drawSelectionOn: aCanvas."
	(self topVisibleRowForCanvas: aCanvas)
		to: (self bottomVisibleRowForCanvas: aCanvas) 
		do: [:row | 
			
			(listSource itemSelectedAmongMultiple: row)
				ifTrue: [ self drawBackgroundForSelectedRow: row on: aCanvas]
				ifFalse: [
					(listSource searchedElement = row)
						ifTrue: [ self drawBackgroundForSearchedRow: row on: aCanvas]
						ifFalse: [
							(listSource backgroundColorFor: row)
								ifNotNil: [:col |
									self drawBackgroundForRow: row on: aCanvas color: col ]]].
						
			selectedRow = row ifTrue: [ self drawSelectionOn: aCanvas ].
			(listSource separatorAfterARow: row) ifTrue: [ self drawSeparatorAfter: row on: aCanvas ].
			self
				display: (self item: row)
				atRow: row
				on: aCanvas].
		
	listSource potentialDropRow > 0
		ifTrue: [self highlightPotentialDropRow: listSource potentialDropRow on: aCanvas]! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
drawSelectionOn: aCanvas
	"Draw the selection background."
	
	selectedRow ifNil: [ ^self ].
	selectedRow = 0 ifTrue: [ ^self ].
	self drawBackgroundForSelectedRow: selectedRow on: aCanvas! !

!LazyListMorph methodsFor: 'row management' stamp: ''!
isRowSelected: row 
	"Answer true if the arg row is selected"
	^ ((selectedRow notNil
				and: [row = selectedRow])
			or: [listSource itemSelectedAmongMultiple: row])! !

!LazyListMorph methodsFor: 'row management' stamp: ''!
selectRow: index
	"Select the index-th row."
	
	selectedRows add: index.
	self invalidRect: (self selectionFrameForRow: index)! !

!LazyListMorph methodsFor: 'accessing' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
athensDrawBackgroundForRow: row on: aCanvas color: aColor

	aCanvas setPaint: aColor.
	aCanvas drawShape: (self selectionFrameForRow: row)! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
adjustWidth
	"private.  Adjust our width to match that of the underlying list"
	self width: ((listSource width max: self hUnadjustedScrollRange) + 20).! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
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: ''!
font
	"return the font used for drawing.  The response is never nil"
	^font! !

!LazyListMorph methodsFor: 'initialization' stamp: ''!
listSource: aListSource
	"set the source of list items -- typically a PluggableListMorph"
	listSource := aListSource.
	self listChanged! !

!LazyListMorph methodsFor: 'row management' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
athensDrawSelectionOn: anAthensCanvas 
	
	selectedRow ifNil: [ ^self ].
	selectedRow = 0 ifTrue: [ ^self ].
	self athensDrawBackgroundForSelectedRow: selectedRow on: anAthensCanvas! !

!LazyListMorph methodsFor: 'accessing' stamp: ''!
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: 'drawing' stamp: ''!
drawBackgroundForSearchedRow: row on: aCanvas
	
	self drawBackgroundForRow: row on: aCanvas color: listSource secondarySelectionColor! !

!LazyListMorph methodsFor: 'list management' stamp: ''!
selectedRow
	"return the currently selected row, or nil if none is selected"
	^selectedRow! !

!LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
themeChanged
	self color: self theme textColor.
	super themeChanged! !

!LazyListMorph methodsFor: 'list access' stamp: ''!
getListSize
	"return the number of items in the list"
	^listSource 
		ifNil: [ 0 ]
		ifNotNil: [ :source | source getListSize]! !

!LazyListMorph methodsFor: 'list access' stamp: ''!
getListItem: index
	"grab a list item directly from the model"
	^listSource getListItem: index! !

!LazyListMorph methodsFor: '*Athens-Morphic' stamp: ''!
athensDrawBackgroundForSearchedRow: row on: aCanvas 

	aCanvas setPaint: listSource secondarySelectionColor.
	aCanvas drawShape: (self selectionFrameForRow: row)! !

!LazyListMorph methodsFor: '*Athens-Morphic' stamp: ''!
athensHighlightPotentialDropRow: row on: anAthensCanvas
	| drawBounds |
	drawBounds := self drawBoundsForRow: row.
	drawBounds := drawBounds intersect: self bounds ifNone: [ ^ self ].
	anAthensCanvas setStrokePaint: Color blue.
	anAthensCanvas drawShape: drawBounds! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
adjustHeight
	"private.  Adjust our height to match that of the underlying list"
	self height: (listItems size max: 1) * font height! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
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: 'row management' stamp: ''!
listChanged
	"set newList to be the list of strings to display"
	listItems := Array new: self getListSize withAll: nil.
	self removeAllMorphs.
	selectedRow := nil.
	selectedRows := PluggableSet integerSet.
	maxWidth := nil. "recompute"
	self adjustHeight.
	self adjustWidth.
	self changed.! !

!LazyListMorph methodsFor: '*Athens-Morphic' stamp: ''!
athensDisplay: item atRow: row on: aCanvas
	"Display the given item at the given row on the given
	canvas."

	| c backgroundColor drawBounds |

	drawBounds := self drawBoundsForRow: row.
	c := self colorForRow: row.
	backgroundColor := self backgroundColorForRow: row.
	item listRenderOn: aCanvas asCanvasWrapper
		atRow: row
		bounds: drawBounds
		color: c
		backgroundColor: backgroundColor 
		from: self.
	row = self mouseDownRow
		ifTrue: [ 
			(aCanvas setStrokePaint: c)
				width: 1;
				dashes: {1} offset: 0.
			aCanvas drawShape: (self selectionFrameForRow: row) ]! !

!LazyListMorph methodsFor: 'row management' stamp: ''!
colorForRow: row
	"Answer the color for the row text."

	^ (self isRowSelected: row )
		ifTrue: [ self theme selectedItemListTextColor  ]
		ifFalse: [ self theme listTextColor ]! !

!LazyListMorph methodsFor: '*Athens-Morphic' stamp: ''!
athensDrawBackgroundForSelectedRow: row on: aCanvas 

	aCanvas setPaint: listSource selectionColorToUse.
	aCanvas drawShape: (self selectionFrameForRow: row)! !

!LazyListMorph methodsFor: 'row management' stamp: ''!
display: item atRow: row on: aCanvas
	"Display the given item at the given row on the given
	canvas."

	| itemColor backgroundColor drawBounds |
	drawBounds := self drawBoundsForRow: row.
	itemColor := self colorForRow: row.
	backgroundColor := self backgroundColorForRow: row.
	item
		listRenderOn: aCanvas
		atRow: row
		bounds: drawBounds
		color: itemColor
		backgroundColor: backgroundColor 
		from: self.
		
	row = self mouseDownRow
		ifTrue: [ 
			aCanvas
				frameRectangle: (self selectionFrameForRow: row)
				width: 1
				colors: {itemColor. (Color transparent)}
				dashes: #(1 1) ]! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
bottomVisibleRowForCanvas: aCanvas
        "return the bottom visible row in aCanvas's clip rectangle"
        ^self rowAtLocation: aCanvas clipRect bottomLeft.! !

!LazyListMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: aCanvas
	listItems isEmpty
		ifTrue: [^ self].
	"self drawSelectionOn: aCanvas."
	1 to: listItems size do: [:row |
		(listSource itemSelectedAmongMultiple: row)
			ifTrue: [ self athensDrawBackgroundForSelectedRow: row on: aCanvas]
			ifFalse: [
				(listSource searchedElement = row)
					ifTrue: [ self athensDrawBackgroundForSearchedRow: row on: aCanvas]
					ifFalse: [
						(listSource backgroundColorFor: row)
							ifNotNil: [:col |
								self athensDrawBackgroundForRow: row on: aCanvas color: col ]]].
					
			selectedRow = row ifTrue: [ self athensDrawSelectionOn: aCanvas ].
			(listSource separatorAfterARow: row) ifTrue: [ self athensDrawSeparatorAfter: row on: aCanvas ].
			self
				athensDisplay: (self item: row)
				atRow: row
				on: aCanvas].
		
	listSource potentialDropRow > 0
		ifTrue: [self athensHighlightPotentialDropRow: listSource potentialDropRow on: aCanvas]! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
highlightPotentialDropRow: row  on: aCanvas
	| drawBounds  |
	drawBounds := self drawBoundsForRow: row.
	drawBounds := drawBounds intersect: self bounds ifNone: [ ^ self ].
	aCanvas frameRectangle: drawBounds color: Color blue! !

!LazyListMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self color: self theme textColor.
	font := StandardFonts listFont.
	listItems := #().
	selectedRows := PluggableSet integerSet.
	self adjustHeight! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
topVisibleRowForCanvas: aCanvas
        "return the top visible row in aCanvas's clip rectangle"
        ^self rowAtLocation: aCanvas clipRect topLeft.! !

!LazyListMorph methodsFor: 'row management' stamp: ''!
hUnadjustedScrollRange
"Ok, this is a bit messed up. We need to return the width of the widest item in the list. If we grab every item in the list, it defeats the purpose of LazyListMorph. If we don't, then we don't know the size. 

This is a compromise -- find the widest of the first 30 items, then double it, This width will be updated as new items are installed, so it will always be correct for the visible items. If you know a better way, please chime in."

	| itemsToCheck item index |
	"Check for a cached value"
	maxWidth ifNotNil:[^maxWidth].

	listItems isEmpty ifTrue: [^0]. "don't set maxWidth if empty do will be recomputed when there are some items"
	"Compute from scratch"
	itemsToCheck := 30 min: (listItems size).
	maxWidth := 0. 

	"Check the first few items to get a representative sample of the rest of the list."
	index := 1.
	[index < itemsToCheck] whileTrue:
		[ item := self getListItem: index. "Be careful not to actually install this item"
		maxWidth := maxWidth max: (item widthToDisplayInList: self).
		index:= index + 1.
		].

	"Add some initial fudge if we didn't check all the items."
	(itemsToCheck < listItems size) ifTrue:[maxWidth := maxWidth*2].

	^maxWidth! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
font: newFont
	font := (newFont ifNil: [ TextStyle default defaultFont ]).
	self adjustHeight.
	self changed.! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
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: 'row management' stamp: ''!
backgroundColorForRow: row 
	"Answer the color for the row text."
	^ (self isRowSelected: row )
		ifTrue: [ listSource selectionColorToUse ]
		ifFalse: [ self theme backgroundColor ]! !

!LazyListMorph methodsFor: 'drawing' stamp: ''!
drawBackgroundForSelectedRow: row on: aCanvas

	self drawBackgroundForRow: row on: aCanvas color: listSource selectionColorToUse! !

!LazyListMorph methodsFor: 'list management' stamp: ''!
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: ''!
drawBoundsForRow: row
	"calculate the bounds that row should be drawn at.  This might be outside our bounds!!"

	| topLeft drawBounds item height |
	item := [ self getListItem: row ]
		on: SubscriptOutOfBounds
		do: [ :ex | self getListItem: (row min: self getListSize) ].
	height := item heightToDisplayInList: self.
	topLeft := self topLeft x @ (self topLeft y + ((row - 1) * height)).
	drawBounds := topLeft extent: self width @ height.
	^ drawBounds! !

!LazyListMorph methodsFor: 'list access' stamp: ''!
item: index
	"return the index-th item, using the 'listItems' cache"
	| newItem itemWidth |
	(index between: 1 and: listItems size)
		ifFalse: [ "there should have been an update, but there wasn't!!"  ^self getListItem: index].
	(listItems at: index) ifNil: [ 
		newItem := self getListItem: index.
		"Update the width cache."
		maxWidth ifNotNil:[
			itemWidth := newItem widthToDisplayInList: self.
			itemWidth > maxWidth ifTrue:[
				maxWidth := itemWidth.
				self adjustWidth.
			]].
		listItems at: index put: newItem ].
	^listItems at: index! !

!LazyListMorph methodsFor: 'row management' stamp: ''!
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: 'row management' stamp: ''!
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: ''!
mouseDownRow
	"Answer the row that should have mouse down highlighting if any."

	^self valueOfProperty: #mouseDownRow! !

!LazyListMorph methodsFor: 'row management' stamp: ''!
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! !

!LazyMorphListMorph commentStamp: ''!
Support for morph lists in PluggableMorphListMorph.!
!LazyMorphListMorph methodsFor: 'accessing' stamp: ''!
userString
	"Do I have a text string to be searched on?"

	^ String
		streamContents: [ :stream | 
			1 to: self getListSize do: [ :i | 
				(self getListItem: i) submorphs detect: [ :morph | morph userString notNil ] ifFound: [ :morph | stream nextPutAll: morph userString ].
				stream cr ] ]! !

!LazyMorphListMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		changeTableLayout;
		cellPositioning: #topLeft;
		cellInset: 2;
		vResizing: #shrinkWrap;
		hResizing: #rigid! !

!LazyMorphListMorph methodsFor: 'accessing' stamp: ''!
selectRow: index
	"select the index-th row"
	selectedRows add: index.
	self invalidRect: (self drawBoundsForRow: index)! !

!LazyMorphListMorph methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
adjustWidth
	"private.  Adjust our height to match the length of the underlying list"
	
	self width: (listSource innerBounds width max: self hUnadjustedScrollRange).! !

!LazyMorphListMorph methodsFor: 'accessing' stamp: ''!
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: 'drawing' stamp: ''!
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: 'accessing' stamp: ''!
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: 'private' stamp: ''!
adjustHeight
	"private.  Adjust our height to match the length of the underlying list.
	Automatic with table layout."! !

!LazyMorphListMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawSubmorphsOnAthensCanvas: anAthensCanvas 
	"Display submorphs back to front"

	| drawBlock|
	submorphs isEmpty ifTrue: [^self].
	drawBlock := [:canvas | | i |
		(self topVisibleRowForCanvas: anAthensCanvas) to: (self bottomVisibleRowForCanvas: anAthensCanvas) do: [ :row |
			i := self item: row.
			canvas fullDrawMorph: i]].
	self clipSubmorphs 
		ifTrue: [anAthensCanvas clipBy: (anAthensCanvas clipRect intersect: self clippingBounds ifNone: [ ^ self ]) during: drawBlock]
		ifFalse: [drawBlock value: anAthensCanvas]! !

!LazyMorphListMorph methodsFor: 'accessing' stamp: ''!
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: 'drawing' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
athensDisplay: item atRow: row on: aCanvas
	"Display the given item at the given row on the given canvas."

	row = self mouseDownRow
		ifTrue: [ 
			(aCanvas setStrokePaint: (self colorForRow: row))
				width: 1;
				dashes: {1} offset: 0.
			aCanvas drawShape: (self selectionFrameForRow: row) ]! !

!LazyMorphListMorph methodsFor: 'drawing' stamp: ''!
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)! !

!LazyMorphTreeMorph commentStamp: ''!
I am a MorphTreeMorph, but I only render the rows lazily as they appear on screen. 

Caveat: There is no rendering in the background. This means that if a row takes too long to render, you can experience a shorter or longer freeze when scrolling.!
!LazyMorphTreeMorph methodsFor: 'initialize - release' stamp: ''!
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: ''!
buildRowMorphsFrom: aNodeMorph
	self buildRowMorphsFrom: aNodeMorph increment: self lazyIncrement.! !

!LazyMorphTreeMorph methodsFor: 'initialize - release' stamp: ''!
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: ''!
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: ''!
lazyIncrement: anInteger
	lazyIncrement := anInteger! !

!LazyMorphTreeMorph methodsFor: 'lazy tree' stamp: ''!
indentingItemClass
	
	^ LazyMorphTreeNodeMorph! !

!LazyMorphTreeMorph methodsFor: 'initialize - release' stamp: ''!
lazyIncrement
	^ lazyIncrement ifNil: [ lazyIncrement := 20 ]! !

!LazyMorphTreeNodeMorph commentStamp: ''!
A node for "lazy drawing" in a morphic based tree!
!LazyMorphTreeNodeMorph methodsFor: 'initialization' stamp: ''!
initRow! !

!LazyMorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
drawOn: aCanvas
	drawable
		ifFalse: [container buildRowMorphsFrom: self]
		ifTrue: [super drawOn: aCanvas]! !

!LazyMorphTreeNodeMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	drawable := false! !

!LazyMorphTreeNodeMorph methodsFor: 'drawing' stamp: ''!
drawable
	^ drawable ifNil: [false]! !

!LazyMorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
drawSubmorphsOn: aCanvas
	drawable ifFalse: [^ self].
	super drawSubmorphsOn: aCanvas.! !

!LazyMorphTreeNodeMorph methodsFor: 'drawing' stamp: ''!
drawable: aBoolean
	drawable := aBoolean.! !

!LazySlot commentStamp: ''!
A slot that is lazy initialized with a default value. 

Lazy initialized instance variables are implemented in Smalltalk by doing a nil check in the read accessor method.

The slot instead does the nil check as part of the slot read operation.

#name => LazySlot default: 5.

#name => LazySlot defaultBlock: [ 'a bloc' ].

#name => LazySlot defaultBlock: [ :object | 'a bloc, parameter is the instance' ].!
!LazySlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	"if the value is nil, we evaluate the default block with the object as a potential parameter"
	^ (super read: anObject) ifNil: [ 
		default isBlock 
			ifTrue: [ self write: (default cull: anObject) to: anObject] 
			ifFalse: [ self write: default to: anObject]]! !

!LazySlot methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	"generate bytecode for '<varname> ifNil: [<varname> := default cull: self]'"
	aMethodBuilder
		pushInstVar: index;
		pushDup;
		pushLiteral: nil;
		send: #==;
		jumpAheadTo: #target if: false;
		popTop;
		pushLiteral: default.
	default isBlock ifTrue: [ 
		aMethodBuilder	
			pushReceiver;
			send: #cull:].
	aMethodBuilder
		storeInstVar: index;
		jumpAheadTarget: #target! !

!LazySlotTest methodsFor: 'tests' stamp: ''!
testLazySlotReadReflective
	| slot object|
	slot := #slot1 => LazySlot default: 5.
	aClass := self make: [ :builder | builder slots: {slot} ].
	
	"test reflective write and read"
	object := aClass new.

	self assert: (slot read: object) equals: 5.
	slot write: 10 to: object.
	self assert: (slot read: object) equals: 10
	
	
	
	
	! !

!LazySlotTest methodsFor: 'tests' stamp: ''!
testLazySlotCompiled
	| slot object|
	slot := #slot1 => LazySlot default: 5 .
	aClass := self make: [ :builder | builder slots: {slot}].

	object := aClass new.
	"now compile an accessor and read"
	self compileAccessorsFor: slot.
	self assert: object slot1 equals: 5
	

	! !

!LazySlotTest methodsFor: 'tests' stamp: ''!
testLazySlotReadReflectiveBlock
	| slot object|
	slot := #slot1 => LazySlot default: [:o | o class] .
	aClass := self make: [ :builder | builder slots: {slot } ].
	
	"test reflective write and read"
	object := aClass new.

	self assert: (slot read: object) equals: aClass.
	slot write: 10 to: object.
	self assert: (slot read: object) equals: 10
	
	
	
	
	! !

!LazySlotTest methodsFor: 'tests' stamp: ''!
testLazySlotPrint
	| slot |
	slot := #mySlot => LazySlot default: 5 .
	self assert: slot printString equals: '#mySlot => LazySlot default: 5'.
	slot := #mySlot => LazySlot default: [ 5 ].
	self assert: slot printString equals: '#mySlot => LazySlot default: [ 5 ]'.
	"if the default is really a block"
	slot := #mySlot => LazySlot default: [ 5 ].
	self assert: slot printString equals: '#mySlot => LazySlot default: [ 5 ]' ! !

!LegacyClassDefinitionPrinter methodsFor: 'public API' stamp: ''!
metaclassDefinitionString

	^ String streamContents: [:stream |
		stream print: forClass.
		stream
			crtab;
			nextPutAll: 'instanceVariableNames: ';
			store: forClass instanceVariablesString ]! !

!LegacyClassDefinitionPrinter methodsFor: 'public API' stamp: ''!
traitedMetaclassDefinitionString

	^ self metaclassDefinitionString! !

!LegacyClassDefinitionPrinter methodsFor: 'delegating' stamp: ''!
expandedDefinitionString
	"We do not support expansion on legacy syntax so we shortcut the double dispatch call."
	^ self definitionString! !

!LegacyClassDefinitionPrinter methodsFor: 'template' stamp: ''!
testClassDefinitionTemplateInPackage: aString

	^ String streamContents: [ :s |
			s nextPutAll: 'TestCase subclass: #MyTest' ; crtab.
			s nextPutAll: 'instanceVariableNames: '''' '; crtab. 
			s nextPutAll: 'classVariableNames: '''''; crtab.
			s nextPutAll: 'poolDictionaries: '''''; crtab.
			s nextPutAll: 'category ''', aString, '''' ]! !

!LegacyClassDefinitionPrinter methodsFor: 'public API' stamp: ''!
classDefinitionString

	"Answer a String that defines the receiver in the old format using poolDictionaries and category.
	e.g,  
	'Object subclass: #Point
		instanceVariableNames: ''x y''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Kernel-BasicObjects'''
	"

	| aStream |
	aStream := (String new: 800) writeStream.
	forClass superclass
		ifNil: [aStream nextPutAll: 'ProtoObject']
		ifNotNil: [aStream nextPutAll: forClass superclass name].
	aStream nextPutAll: forClass kindOfSubclass;
			store: forClass name.
	(forClass hasTraitComposition) ifTrue: [
		aStream cr; tab; nextPutAll: 'uses: ';
			nextPutAll: forClass traitCompositionString].
	aStream cr; tab; nextPutAll: 'instanceVariableNames: ';
			store: forClass instanceVariablesString.
	aStream cr; tab; nextPutAll: 'classVariableNames: ';
			store: forClass classVariablesString.
	aStream cr; tab; nextPutAll: 'poolDictionaries: ';
			store: forClass sharedPoolsString.
	aStream cr; tab; nextPutAll: 'category: ';
			store: forClass category asString.

	forClass superclass ifNil: [ 
		aStream nextPutAll: '.'; cr.
		aStream nextPutAll: forClass name.
		aStream space; nextPutAll: 'superclass: nil'. ].

	^ aStream contents! !

!LegacyClassDefinitionPrinter methodsFor: 'public API' stamp: ''!
traitDefinitionString

	^ String streamContents: [ :s | 
		s 
			nextPutAll: 'Trait named: ';
			nextPutAll:	forClass name printString;
			cr; tab; 
			nextPutAll: ' uses: ';
			nextPutAll: forClass traitComposition traitCompositionExpression; 
			cr;
			tab;
			nextPutAll: ' package: ';
			nextPutAll: forClass category asString printString
	]! !

!LegacyClassDefinitionPrinter methodsFor: 'template' stamp: ''!
classDefinitionTemplateInPackage: aString

	^ String streamContents: [ :s |
			s nextPutAll: 'Object subclass: #MyClass' ; crtab.
			s nextPutAll: 'instanceVariableNames: '''' '; crtab. 
			s nextPutAll: 'classVariableNames: '''''; crtab.
			s nextPutAll: 'poolDictionaries: '''''; crtab.
			s nextPutAll: 'category ''', aString, '''' ]! !

!LegacyClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testSystemAnnouncerClass
	
	self 
		assert: (self forClass: SystemAnnouncer class) 
		equals: 'SystemAnnouncer class
	instanceVariableNames: ''announcer'''! !

!LegacyClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testArrayedCollectionWithPoolDictionary

	self assert: (self forClass: ExampleForTestWithSharedPool)
		equals: 'ArrayedCollection subclass: #ExampleForTestWithSharedPool
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''ChronologyConstants''
	category: ''Kernel-Tests-Classes'''! !

!LegacyClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testByteString

	self 
		assert: (self forClass: ByteString) 
		equals: 'String variableByteSubclass: #ByteString
	instanceVariableNames: ''''
	classVariableNames: ''NonAsciiMap''
	poolDictionaries: ''''
	category: ''Collections-Strings-Base'''! !

!LegacyClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testMetaclassClass
	
	self 
		assert: (self forClass: Metaclass class) 
		equals: 'Metaclass class
	instanceVariableNames: '''''! !

!LegacyClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testPoint

	self 
		assert: (self forClass: Point)
		equals: 'Object subclass: #Point
	instanceVariableNames: ''x y''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''Kernel-BasicObjects'''! !

!LegacyClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testProtoObject
	
	self
		assert: (self forClass: ProtoObject)
		equals: 'ProtoObject subclass: #ProtoObject
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''Kernel-Objects''.
ProtoObject superclass: nil'! !

!LegacyClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testArray

	self 
		assert: (self forClass: Array) 
		equals: 'ArrayedCollection variableSubclass: #Array
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''Collections-Sequenceable-Base'''! !

!LegacyClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testMetaclass
	
	self
		assert: (self forClass: Metaclass)
		equals: 'ClassDescription subclass: #Metaclass
	instanceVariableNames: ''thisClass''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''Kernel-Classes'''! !

!LegacyClassDefinitionPrinterTest methodsFor: 'helpers' stamp: ''!
forClass: aClass
	^ (ClassDefinitionPrinter legacy for: aClass) definitionString! !

!LegacyClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testClassSideDoesNotShowPackage

	self assert: (self forClass: ContextTest class) equals: 'ContextTest class
	instanceVariableNames: '''''! !

!LegacyClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testChronologyConstants

	self
		assert: (self forClass: ChronologyConstants)
		equals: 'SharedPool subclass: #ChronologyConstants
	instanceVariableNames: ''''
	classVariableNames: ''DayNames DaysInMonth HoursInDay MicrosecondsInDay MinutesInHour MonthNames NanosInMillisecond NanosInSecond SecondsInDay SecondsInHour SecondsInMinute SqueakEpoch''
	poolDictionaries: ''''
	category: ''Kernel-Chronology'''! !

!Lesson commentStamp: ''!
A lesson is a simple data object holding a name and an associated text that will be displayed by
the tutorialPlayer. 
!
!Lesson methodsFor: 'accessing' stamp: ''!
lesson: aString
	lesson := aString! !

!Lesson methodsFor: 'accessing' stamp: ''!
title: aString
	title := aString! !

!Lesson methodsFor: 'accessing' stamp: ''!
lesson
	^ lesson ifNil: [lesson := '']! !

!Lesson methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.  
	aStream 
		nextPutAll: '(';
		nextPutAll: self title;
		nextPutAll: ')'.! !

!Lesson methodsFor: 'accessing' stamp: ''!
title
	^ title ifNil: [title := '']! !

!Lesson class methodsFor: 'instance creation' stamp: ''!
title: aStringForTitle lesson: aStringForLesson
	^ self new title: aStringForTitle; lesson: aStringForLesson; yourself.! !

!LessonInstanciationTest commentStamp: ''!
SUnit tests for lessons!
!LessonInstanciationTest methodsFor: 'tests' stamp: ''!
testTitleLessonCreation
	| firstLesson secondLesson |
	firstLesson := Lesson title: 'First lesson' lesson: 'Pharo rules!!'.
	secondLesson := Lesson title: 'Second lesson' lesson: 'PharoTutorial is cool'.
	
	self assert: firstLesson title equals: 'First lesson'.
	self assert: firstLesson lesson equals: 'Pharo rules!!'.
	
	self assert: secondLesson title equals: 'Second lesson'.
	self assert: secondLesson lesson equals: 'PharoTutorial is cool'.! !

!LessonInstanciationTest methodsFor: 'tests' stamp: ''!
testNewLessonHaveEmptyStringForTitleLesson
	| newLesson  |
	newLesson := Lesson new.
	self assert: newLesson title equals: ''.
	self assert: newLesson lesson equals: ''.! !

!LessonView commentStamp: ''!
A LessonView displays a Lesson instance.

LessonView new open!
!LessonView methodsFor: 'gui' stamp: ''!
buildWindow
	^ SystemWindow labelled: 'PrStef lesson'.! !

!LessonView methodsFor: 'accessing' stamp: ''!
doItContext
	^ nil! !

!LessonView methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	window := self buildWindow.
	shoutMorph := self buildText.
	window addMorph: shoutMorph frame: (0 @ 0 corner: 1 @ 1).
	window extent: 600 @ 450.! !

!LessonView methodsFor: 'accessing' stamp: ''!
shoutAboutToStyle: aPluggableShoutMorphOrView
	^ true! !

!LessonView methodsFor: 'accessing' stamp: ''!
sourceTextModel
	^ sourceTextModel ifNil: [ sourceTextModel := RubScrolledTextModel new interactionModel: self ].! !

!LessonView methodsFor: 'gui' stamp: ''!
open
	"menu: #shoutMorphFillMenu:."
	window openInWorld! !

!LessonView methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass
	^ nil! !

!LessonView methodsFor: 'accessing' stamp: ''!
window 
	^ window! !

!LessonView methodsFor: 'gui' stamp: ''!
shoutMorphFillMenu: aMenu
	^ aMenu addAllFrom: self menu! !

!LessonView methodsFor: 'accessing' stamp: ''!
doItReceiver
	^ nil! !

!LessonView methodsFor: 'gui' stamp: ''!
menu
	^ (PragmaMenuBuilder pragmaKeyword: #LessonViewContextMenu model: self) menu.! !

!LessonView methodsFor: 'gui' stamp: ''!
showLesson: aLesson withTitle: aString
	self window setLabel: aString.
	self sourceTextModel setText: aLesson lesson.
	self isOpenInWindow ifFalse: [ self open ]! !

!LessonView methodsFor: 'gui' stamp: ''!
close
	window delete.! !

!LessonView methodsFor: 'accessing' stamp: ''!
shoutMorph
	^ shoutMorph! !

!LessonView methodsFor: 'accessing' stamp: ''!
bindings

	"dynamic variable binding not needed for Lessons"

	^ Dictionary new! !

!LessonView methodsFor: 'gui' stamp: ''!
buildText
	| scrolledText |
	scrolledText := self sourceTextModel newScrolledText
		beForSmalltalkScripting;
		beWrapped;
		yourself.
	scrolledText textArea font: StandardFonts codeFont.
	^ scrolledText! !

!LessonView methodsFor: 'testing' stamp: ''!
isOpenInWindow
	^ self currentWorld systemWindows includes: window! !

!LessonView methodsFor: 'accessing' stamp: ''!
text
	^ self sourceTextModel getText asString! !

!LessonView class methodsFor: 'gui' stamp: ''!
menuOn: aBuilder
	<LessonViewContextMenu>
	
	(aBuilder item: #'Do it' translated)
		keyText: 'd';
		selector: #doIt;
		help: nil;
		iconName: #smallDoIt.
	(aBuilder item: #'Print it' translated)
		keyText: 'p';
		selector: #printIt;
		help: nil;
		iconName: #smallPrintIt.
	(aBuilder item: #'Inspect it' translated)
		keyText: 'i';
		selector: #inspectIt;
		help: nil;
		iconName: #smallInspectIt.! !

!LibC commentStamp: ''!
I'm a module defining access to standard LibC. 
I'm available under Linux and OSX.
Under windows I provide similar functionality through the functions defined in msvcrt.dll!
!LibC methodsFor: 'api - misc' stamp: ''!
memCopy: src to: dest size: n
	^ self
		ffiCall: #(#void #* #memcpy #(#void #* #dest #, #const #void #* #src #, #size_t #n))! !

!LibC methodsFor: 'api - piping' stamp: ''!
pipe: command mode: mode
	"Initiate pipe streams to or from a process."

	^self ffiCall: (Smalltalk os isWindows
							ifTrue:  [ #(void* _popen(char* command, char* mode)) ]
							ifFalse: [ #(void* popen(char* command, char* mode)) ])

	
			 ! !

!LibC methodsFor: 'api - processes' stamp: ''!
currentProcessId
	"Returns the process identifier (PID) of the calling process."
 
	 ^self ffiCall: #(int getpid(void)) ! !

!LibC methodsFor: 'api - piping' stamp: ''!
pipeClose: stream
	"Close the given pipe stream."

	^self ffiCall: (Smalltalk os isWindows
							ifTrue: [ #(int* _pclose(void* stream)) ]
							ifFalse: [ #(int* pclose(void* stream)) ])! !

!LibC methodsFor: 'process actions' stamp: ''!
runCommand: cmd

	^self system: cmd! !

!LibC methodsFor: 'api - misc' stamp: ''!
system: command
	^ self ffiCall: #(int system #(char * command))! !

!LibC methodsFor: 'process actions' stamp: ''!
resultOfCommand: cmd
	|file last s |
	file := self pipe: cmd mode: 'r'.
	s := String new writeStream.
	[[ last := (self fgetc: file) value.
	  last = 16rFFFFFFFF ] whileFalse: [ 	 
			s nextPut: (Character value: last)
	]] ensure: [ self pipeClose: file ].
	^s contents! !

!LibC methodsFor: 'api - accessing' stamp: ''!
fgetc: stream
	"Get character from stream."
	 
	 ^self ffiCall: #(int* fgetc(void* stream))! !

!LibC methodsFor: 'private - accessing' stamp: ''!
win32LibraryName
	"While this is not a 'libc' properly, msvcrt has the functions we are defining here"
	^ 'msvcrt.dll'! !

!LibC methodsFor: 'api - processes' stamp: ''!
parentProcessId
	"Returns the process ID of the parent of the calling process."
	 
	 ^self ffiCall: #(int getppid(void))! !

!LibC methodsFor: 'private - accessing' stamp: ''!
unixLibraryName
	^ 'libc.so.6'! !

!LibC methodsFor: 'private - accessing' stamp: ''!
macLibraryName
	^ 'libc.dylib'! !

!LibC class methodsFor: 'api - misc' stamp: ''!
memCopy: from to: to size: size
	^ self uniqueInstance  
		memCopy: from 
		to: to 
		size: size! !

!LibC class methodsFor: 'api - piping' stamp: ''!
pipe: command mode: mode
	"Initiate pipe streams to or from a process."
	
	^ self uniqueInstance pipe: command mode: mode! !

!LibC class methodsFor: 'api - piping' stamp: ''!
pipeClose: stream
	"Close the given pipe stream."
	
	^ self uniqueInstance pipeClose: stream! !

!LibC class methodsFor: 'process actions' stamp: ''!
runCommand: aCommand

	^self uniqueInstance system: aCommand  ! !

!LibC class methodsFor: 'api - misc' stamp: ''!
system: command
	^ self uniqueInstance system: command! !

!LibC class methodsFor: 'process actions' stamp: ''!
resultOfCommand: aCommand

	^self uniqueInstance resultOfCommand: aCommand  ! !

!LibC class methodsFor: 'api - accessing' stamp: ''!
fgetc: aCStream
	"Get character from the given C stream."
	
	^self uniqueInstance fgetc: aCStream! !

!LimitedWriteStream commentStamp: ''!
A LimitedWriteStream is a specialized WriteStream that has a maximum size of the collection it streams over. When this limit is reached a special limitBlock is executed. This can for example be used to "bail out" of lengthy streaming operations before they have finished.  For a simple example take a look at the universal Object printString.

The message SequenceableCollection class streamContents:limitedTo: creates a LimitedWriteStream. In this case it prevents very large (or possibly recursive) object structures to "overdo" their textual representation. !
!LimitedWriteStream methodsFor: 'private' stamp: ''!
pastEndPut: anObject
	collection size >= limit ifTrue: [limitBlock value].  "Exceptional return"
	^ super pastEndPut: anObject! !

!LimitedWriteStream methodsFor: 'accessing' stamp: ''!
limit: anInteger
	limit := anInteger.

	position > limit
		ifTrue: [
			position := limit.
			limitBlock value ]! !

!LimitedWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: anObject
	"Ensure that the limit is not exceeded"

	position >= limit
		ifTrue: [ limitBlock value ]
		ifFalse: [ super nextPut: anObject ].
	^ anObject! !

!LimitedWriteStream methodsFor: 'accessing' stamp: ''!
limitBlock: aBlock
	limitBlock := aBlock! !

!LimitedWriteStream methodsFor: 'accessing' stamp: ''!
limit
	^ limit! !

!LimitedWriteStream methodsFor: 'initialization' stamp: ''!
setLimit: anInteger limitBlock: aBlock
	"Limit the numer of elements this stream will write..."
	limit := anInteger.

	"Execute this (typically ^ contents) when that limit is exceded"
	limitBlock := aBlock.

	"To support legacy users, this test must be here too"
	position > limit
		ifTrue: [
			position := limit.
			limitBlock value ]! !

!LimitedWriteStream methodsFor: 'accessing' stamp: ''!
limitBlock
	^ limitBlock! !

!LimitedWriteStream methodsFor: 'accessing' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
on: aCollection
	^ (self basicNew on: aCollection)
		setLimit: self defaultLimit
		limitBlock: nil! !

!LimitedWriteStream class methodsFor: 'accessing' stamp: ''!
defaultLimit
	^ 1000! !

!LimitedWriteStream class methodsFor: 'instance creation' stamp: ''!
with: aCollection
	^ (self basicNew with: aCollection)
		setLimit: self defaultLimit
		limitBlock: nil! !

!LimitedWriteStream class methodsFor: 'instance creation' stamp: ''!
on: aCollection limit: anInteger limitBlock: aLimitBlock
	^ (self basicNew on: aCollection)
		setLimit: anInteger
		limitBlock: aLimitBlock! !

!LimitedWriteStream class methodsFor: 'instance creation' stamp: ''!
on: aCollection from: firstIndex to: lastIndex
	^ (self basicNew on: aCollection from: firstIndex to: lastIndex)
		setLimit: self defaultLimit
		limitBlock: nil! !

!LimitedWriteStream class methodsFor: 'instance creation' stamp: ''!
with: aCollection from: firstIndex to: lastIndex
	^ (self basicNew with: aCollection from: firstIndex to: lastIndex)
		setLimit: self defaultLimit
		limitBlock: nil! !

!LimitedWriteStreamTest commentStamp: ''!
SUnit test clss for LimitedWriteStream!
!LimitedWriteStreamTest methodsFor: 'tests' stamp: ''!
testLimitBlock
	| stream overLimit limitBlock |
	stream := self newStream.
	overLimit := false.
	limitBlock := [ overLimit := true ].
	self
		assert: stream limitBlock isNil;
		assert: (stream limitBlock: limitBlock) identicalTo: stream;
		assert: stream limitBlock identicalTo: limitBlock;
		deny: overLimit! !

!LimitedWriteStreamTest methodsFor: 'tests' stamp: ''!
testNextPutAll
	| stream overLimit |
	super testNextPutAll.
	stream := self streamClass on: String new limit: self stringSize limitBlock: [ overLimit := true ].
	overLimit := false.
	self
		assert: (stream nextPutAll: self string) equals: self string;
		assert: stream position equals: self stringSize;
		assert: stream contents equals: self string;
		deny: overLimit.
	self
		assert: (stream nextPutAll: self string) equals: self string;
		assert: stream position equals: self stringSize;
		assert: stream contents equals: self string;
		assert: overLimit! !

!LimitedWriteStreamTest methodsFor: 'tests' stamp: ''!
testOnLimitLimitBlock
	| collection overLimit limitBlock stream |
	collection := String new.
	overLimit := false.
	limitBlock := [ overLimit := true ].
	stream := self streamClass on: collection limit: self stringSize limitBlock: limitBlock.
	self
		assert: stream originalContents identicalTo: collection;
		assert: stream position isZero;
		assert: stream limit equals: self stringSize;
		assert: stream limitBlock equals: limitBlock;
		deny: overLimit! !

!LimitedWriteStreamTest methodsFor: 'accessing' stamp: ''!
streamClass
	^ LimitedWriteStream! !

!LimitedWriteStreamTest methodsFor: 'tests' stamp: ''!
testWithFromTo
	"like with: except it paritions its argument collection first using the
	from:/to: indexes"

	| stream overLimit |
	super testWithFromTo.

	stream := self streamClass with: self string , self string from: 1 to: self stringSize.
	overLimit := false.
	stream
		limit: self stringSize * 2;
		limitBlock: [ overLimit := true ].
	self string
		withIndexDo: [ :each :i | 
			self
				assert: (stream nextPut: each) equals: each;
				assert: stream position equals: self stringSize + i;
				assert: stream contents equals: self string , (self string first: i);
				deny: overLimit ].
	self string
		do: [ :each | 
			overLimit := false.
			self
				assert: (stream nextPut: each) equals: each;
				assert: stream position equals: self stringSize * 2;
				assert: stream contents equals: self string , self string;
				assert: overLimit ]! !

!LimitedWriteStreamTest methodsFor: 'tests' stamp: ''!
testWith
	"like on: except it starts writing at the end of its argument collection,
	and the initial position is the collection size and the initial contents
	is the collection"

	| stream overLimit |
	super testWith.

	stream := self streamClass with: self string.
	overLimit := false.
	stream
		limit: self stringSize * 2;
		limitBlock: [ overLimit := true ].
	self string
		withIndexDo: [ :each :i | 
			self
				assert: (stream nextPut: each) equals: each;
				assert: stream position equals: self stringSize + i;
				assert: stream contents equals: self string , (self string first: i);
				deny: overLimit ].
	self string
		do: [ :each | 
			overLimit := false.
			self
				assert: (stream nextPut: each) equals: each;
				assert: stream position equals: self stringSize * 2;
				assert: stream contents equals: self string , self string;
				assert: overLimit ]! !

!LimitedWriteStreamTest methodsFor: 'tests' stamp: ''!
testSetLimitLimitBlock
	| stream overLimit |
	stream := self newStream.
	overLimit := false.
	self assert: (stream setLimit: self stringSize limitBlock: [ overLimit := true ]) identicalTo: stream.
	stream nextPutAll: self string.
	self deny: overLimit.

	self stringSize - 1 to: 0 by: -1 do: [ :i | 
		overLimit := false.
		"ensure the new block argument is used when the new limit is less than
		the position by setting it to nil first"
		self assert: (stream setLimit: stream position limitBlock: nil) identicalTo: stream.
		self deny: overLimit.
		self assert: (stream setLimit: i limitBlock: [ overLimit := true ]) identicalTo: stream.
		self assert: overLimit ]! !

!LimitedWriteStreamTest methodsFor: 'tests' stamp: ''!
testOn
	| stream |
	super testOn.
	stream := self newStream.
	self
		assert: stream limit equals: self streamClass defaultLimit;
		assert: stream limitBlock isNil! !

!LimitedWriteStreamTest methodsFor: 'tests' stamp: ''!
testOnFromTo
	| stream |
	super testOnFromTo.
	stream := self streamClass on: self string , self string from: self stringSize + 1 to: self stringSize * 2.
	self
		assert: stream limit equals: self streamClass defaultLimit;
		assert: stream limitBlock isNil! !

!LimitedWriteStreamTest methodsFor: 'tests' stamp: ''!
testLimit
	| stream overLimit |
	stream := self newStream.
	overLimit := false.
	stream
		limitBlock: [ overLimit := true ];
		nextPutAll: self string.
	self
		assert: stream limit equals: self streamClass defaultLimit;
		assert: (stream limit: self stringSize) identicalTo: stream;
		assert: stream limit equals: self stringSize;
		deny: overLimit.

	self stringSize - 1 to: 0 by: -1 do: [ :i | 
		overLimit := false.
		self
			assert: (stream limit: i) identicalTo: stream;
			assert: stream limit equals: i;
			assert: stream position equals: i;
			assert: stream contents equals: (self string first: i);
			assert: overLimit ]! !

!LimitedWriteStreamTest methodsFor: 'tests' stamp: ''!
testNextPut
	| stream overLimit |
	super testNextPut.

	stream := self streamClass on: String new limit: self stringSize limitBlock: [ overLimit := true ].
	overLimit := false.
	self string
		withIndexDo: [ :each :i | 
			self
				assert: (stream nextPut: each) equals: each;
				assert: stream position equals: i;
				assert: stream contents equals: (self string first: i);
				deny: overLimit ].
	self string
		do: [ :each | 
			overLimit := false.
			self
				assert: (stream nextPut: each) equals: each;
				assert: stream position equals: self stringSize;
				assert: stream contents equals: self string;
				assert: overLimit ]! !

!LineMorph commentStamp: ''!
This is really only a shell for creating single-segment straight-line Shapes.!
!LineMorph class methodsFor: 'instance creation' stamp: ''!
new
	^ self from: 0@0 to: 50@50 color: Color black width: 2! !

!LineMorph class methodsFor: 'instance creation' stamp: ''!
from: startPoint to: endPoint color: lineColor width: lineWidth

	^ self vertices: {startPoint. endPoint}
			color: Color black borderWidth: lineWidth borderColor: lineColor! !

!LineSegment commentStamp: ''!
This class represents a straight line segment between two points

Instance variables:
	start	<Point>	start point of the line
	end		<Point>	end point of the line
!
!LineSegment methodsFor: 'bezier clipping' stamp: ''!
bezierClipCurve: aCurve
	^self bezierClipCurve: aCurve epsilon: 1! !

!LineSegment methodsFor: 'accessing' stamp: ''!
bounds
	"Return the bounds containing the receiver"
	^(start min: end) corner: (start max: end)! !

!LineSegment methodsFor: 'testing' stamp: ''!
isBezier2Segment
	"Return true if the receiver is a quadratic bezier segment"
	^false! !

!LineSegment methodsFor: 'converting' stamp: ''!
asBezier2Points: error
	^Array with: start with: start with: end! !

!LineSegment methodsFor: 'converting' stamp: ''!
asLineSegment
	"Represent the receiver as a straight line segment"
	^self! !

!LineSegment methodsFor: 'testing' stamp: ''!
hasZeroLength
	"Return true if the receiver has zero length"
	^start = end! !

!LineSegment methodsFor: 'testing' stamp: ''!
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: 'printing' stamp: ''!
printOn: aStream
	"Print the receiver on aStream"
	aStream 
		nextPutAll: self class name;
		nextPutAll:' from: ';
		print: start;
		nextPutAll: ' to: ';
		print: end;
		space.! !

!LineSegment methodsFor: 'converting' stamp: ''!
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: 'accessing' stamp: ''!
degree
	^1! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
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: ''!
length
	"Return the length of the receiver"
	^start distanceTo: end! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
valueAtEnd
	"Evaluate the receiver at it's end point (e.g., self valueAtEnd = (self valueAt: 1.0))"
	^end! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
valueAt: parameter
	"Evaluate the receiver at the given parametric value"
	^start + (end - start * parameter)! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
controlPointsDo: aBlock
	aBlock value: start; value: end! !

!LineSegment methodsFor: 'bezier clipping' stamp: ''!
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: 'initialize' stamp: ''!
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: ''!
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: 'vector functions' stamp: ''!
controlPoints
	^{start. end}! !

!LineSegment methodsFor: 'converting' stamp: ''!
asTangentSegment
	^LineSegment from: end-start to: end-start! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
sideOfPoint: aPoint
	"Return the side of the receiver this point is on. The method returns
		-1: if aPoint is left
		 0: if aPoint is on
		+1: if a point is right
	of the receiver."
	| dx dy px py |
	dx := end x - start x.
	dy := end y - start y.
	px := aPoint x - start x.
	py := aPoint y - start y.
	^((dx * py) - (px * dy)) sign
"
	(LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@-50.
	(LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@50.
	(LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@0.
"! !

!LineSegment methodsFor: 'testing' stamp: ''!
isLineSegment
	"Return true if the receiver is a line segment"
	^true! !

!LineSegment methodsFor: 'testing' stamp: ''!
isStraight
	"Return true if the receiver represents a straight line"
	^true! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
tangentAt: parameter
	"Return the tangent at the given parametric value along the receiver"
	^end - start! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
tangentAtEnd
	"Return the tangent for the last point"
	^(end - start)! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
tangentAtMid
	"Return the tangent for the last point"
	^(end - start)! !

!LineSegment methodsFor: 'private' stamp: ''!
debugDrawAt: offset
	| canvas |
	canvas := Display getCanvas.
	canvas translateBy: offset during:[:aCanvas|
		self lineSegmentsDo:[:p1 :p2|
			aCanvas line: p1 rounded to: p2 rounded width: 1 color: Color black.
		].
	].! !

!LineSegment methodsFor: 'converting' stamp: ''!
asBezier2Segment
	"Represent the receiver as quadratic bezier segment"
	^Bezier2Segment from: start to: end! !

!LineSegment methodsFor: 'converting' stamp: ''!
asIntegerSegment
	"Convert the receiver into integer representation"
	^self species from: start asIntegerPoint to: end asIntegerPoint! !

!LineSegment methodsFor: 'accessing' stamp: ''!
direction
	^end - start! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
tangentAtStart
	"Return the tangent for the last point"
	^(end - start)! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
lineSegmentsDo: aBlock
	"Evaluate aBlock with the receiver's line segments"
	aBlock value: start value: end! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
asBezier2Curves: err
	^Array with: self! !

!LineSegment methodsFor: 'intersection' stamp: ''!
roundTo: quantum
	start := start roundTo: quantum.
	end := end roundTo: quantum.! !

!LineSegment methodsFor: 'initialize' stamp: ''!
from: startPoint to: endPoint
	"Initialize the receiver"
	start := startPoint.
	end := endPoint.! !

!LineSegment methodsFor: 'accessing' stamp: ''!
end: aPoint
	end := aPoint! !

!LineSegment methodsFor: 'accessing' stamp: ''!
start
	"Return the start point"
	^start! !

!LineSegment methodsFor: 'private' stamp: ''!
debugDraw
	^self debugDrawAt: 0@0.! !

!LineSegment methodsFor: 'accessing' stamp: ''!
end
	"Return the end point"
	^end! !

!LineSegment methodsFor: 'accessing' stamp: ''!
start: aPoint
	start := aPoint! !

!LineSegment methodsFor: 'bezier clipping' stamp: ''!
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: 'vector functions' stamp: ''!
lineSegments: steps do: aBlock
	"Evaluate aBlock with the receiver's line segments"
	aBlock value: start value: end! !

!LineSegment methodsFor: 'vector functions' stamp: ''!
valueAtStart
	"Evaluate the receiver at it's start point (e.g., self valueAtEnd = (self valueAt: 0.0))"
	^start! !

!LineSegment methodsFor: 'converting' stamp: ''!
reversed
	^self class controlPoints: self controlPoints reversed! !

!LineSegment class methodsFor: 'utilities' stamp: ''!
intersectFrom: startPt with: startDir to: endPt with: endDir
	"Compute the intersection of two lines, e.g., compute alpha and beta for
		startPt + (alpha * startDir) = endPt + (beta * endDir).
	Reformulating this yields
		(alpha * startDir) - (beta * endDir) = endPt - startPt.
	or
		(alpha * startDir) + (-beta * endDir) = endPt - startPt.
	or
		(alpha * startDir x) + (-beta * endDir x) = endPt x - startPt x.
		(alpha * startDir y) + (-beta * endDir y) = endPt y - startPt y.
	which is trivial to solve using Cramer's rule. Note that since
	we're really only interested in the intersection point we need only
	one of alpha or beta since the resulting intersection point can be
	computed based on either one."
	| det deltaPt alpha |
	det := (startDir x * endDir y) - (startDir y * endDir x).
	det = 0.0 ifTrue:[^nil]. "There's no solution for it"
	deltaPt := endPt - startPt.
	alpha := (deltaPt x * endDir y) - (deltaPt y * endDir x).
	alpha := alpha / det.
	"And compute intersection"
	^startPt + (alpha * startDir)! !

!LineSegment class methodsFor: 'instance creation' stamp: ''!
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: 'geometry' stamp: ''!
fromPoints: pts
	^self from: pts first to: pts third via: pts second! !

!LineSegment class methodsFor: 'instance creation' stamp: ''!
from: startPoint to: endPoint
	^self new from: startPoint to: endPoint! !

!LineSegment class methodsFor: 'geometry' stamp: ''!
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! !

!LinearGradientPaint commentStamp: ''!
I represent a linear gradient paint.
My start and stop points defining 
the position and direction of gradient fill 
in user space coordinates,
so that the ramp color at 0 maps to starting point
and ramp color at 1 maps to stop point of linear gradient.



Also check the comment of my superclass to know better how and when you can use me.
!
!LinearGradientPaint methodsFor: '*Roassal3-Colors' stamp: ''!
asScale 
	| sc |
	sc := NSScale linear.
	sc domain: (colorRamp collect: #key).
	sc range: (colorRamp collect: #value).
	^ sc! !

!LinearGradientPaint methodsFor: 'accessing' stamp: ''!
stop

	^ stop! !

!LinearGradientPaint methodsFor: 'converting' stamp: ''!
asAthensPaintOn: aCanvas
	^ aCanvas surface
			createLinearGradient: self colorRamp
				start: self start 
				stop: self stop! !

!LinearGradientPaint methodsFor: 'accessing' stamp: ''!
stop: anObject
	
	stop := anObject! !

!LinearGradientPaint methodsFor: 'accessing' stamp: ''!
start

	^ start! !

!LinearGradientPaint methodsFor: 'accessing' stamp: ''!
start: anObject
	
	start := anObject! !

!LinearGradientPaint class methodsFor: 'instance creation' stamp: ''!
from: aStartPoint  to: aStopPoint
	^ self new start: aStartPoint; stop: aStopPoint; yourself.! !

!Link commentStamp: ''!
An instance of me is a simple record of a pointer to another Link. I am an abstract class; my concrete subclasses, for example, Process, can be stored in a LinkedList structure.!
!Link methodsFor: 'converting' stamp: ''!
asLink
	^self! !

!Link methodsFor: 'dispatched' stamp: ''!
asLinkPrepend: anObject

	^ self class nextLink: self! !

!Link methodsFor: 'accessing' stamp: ''!
nextLink
	"Answer the link to which the receiver points."

	^nextLink! !

!Link methodsFor: 'accessing' stamp: ''!
nextLink: aLink 
	"Store the argument, aLink, as the link to which the receiver refers. 
	Answer aLink."

	^nextLink := aLink! !

!Link class methodsFor: 'instance creation' stamp: ''!
nextLink: aLink 
	"Answer an instance of me referring to the argument, aLink."

	^self new nextLink: aLink; yourself! !

!LinkInstallerTest methodsFor: 'links - updating' stamp: ''!
testPropagateNewClassScopedLinks
	"When adding a class scoped link from a node,
	it must also be added to all anonymous classes with copy of this node and link."

	| metalink metalink2 node anonNode |		
	node := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast allChildren atRandom.

	metalink := MetaLink new.
	metalink2 := MetaLink new.
	node link: metalink2 forObject: obj1.

	"The link shall not be present in the anon class node"
	anonNode := metalink2 linkInstaller findSubNode: node in: (obj1 class >> #exampleIfTrueIfFalse) ast.
	self deny: (anonNode links includes: metalink).

	"After adding a link to the base class, it must be present on the copied node
	in the anonymous subclass"
	node link: metalink.
	self assert: (anonNode links includes: metalink)! !

!LinkInstallerTest methodsFor: 'links - updating' stamp: ''!
testMethodRemoved
	"When removing a method for which there was an object specific link,
	all links must be removed"

	| metalink node |
	obj1 compileTemporaryMethods.
	node := (ReflectivityExamples >> #methodToBeRemoved) ast allChildren atRandom.

	"Putting a link on a random node should migrate the object to an anonymous subclass"
	metalink := MetaLink new.
	node link: metalink forObject: obj1.
	self removeClassAccessControlForTests: obj1.
	self assert: obj1 class isAnonymous.

	"Removing the original method should remove all object specific links and
	migrate back the object to its original class"
	ReflectivityExamples removeSelector: #methodToBeRemoved.
	self deny: obj1 class isAnonymous.
	self assert: obj1 class identicalTo: ReflectivityExamples.
	self deny: metalink hasNodes.
	self assert: (metalink linkInstaller linkToNodesMapper findNodeLike: node forObject: obj1) isNil! !

!LinkInstallerTest methodsFor: 'links - installing' stamp: ''!
testTwoMetaLinksOneObject
	"Two metalinks for one object of a particular class. Other instances of this class must remain unaffected."

	| metalink metalink2 | 
	self flag: 'Split this test into smaller ones !!'.	

	"The MetaLink must change the tag value to 1 before #exampleMethod"
	metalink := MetaLink new.
	metalink selector: #value.
	metalink metaObject: [ obj1 tagExec: 1 ].
	metalink control: #before.
	(obj1 class >> #exampleMethod) ast link: metalink forObject: obj1.

	"The second MetaLink must add 1 to tag value after #exampleMethod"
	metalink2 := MetaLink new.
	metalink2 selector: #value.
	metalink2 metaObject: [ obj1 tagExec: obj1 tag + 1 ].
	metalink2 control: #before.
	(obj1 class >> #exampleMethod) ast link: metalink2 forObject: obj1.

	"Only the object on which has been installed is affected"
	obj1 tagExec: 0.
	obj1 exampleMethod.
	obj2 exampleMethod.
	self assert: obj1 tag equals: 2.
	self assert: obj2 tag equals: nil.

	"After removing the links, the object is not affected anymore.
	We should also test that one likn can be removed while the other stays active."
	(obj1 class >> #exampleMethod) ast removeLink: metalink forObject: obj1.
	(obj1 class >> #exampleMethod) ast removeLink: metalink2 forObject: obj1.
	metalink uninstall.
	metalink2 uninstall.
	obj1 tagExec: nil.
	obj1 exampleMethod.
	obj2 exampleMethod.
	self assert: obj1 tag equals: nil.
	self assert: obj2 tag equals: nil! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testNodesRemovedFromLinkWhenMethodRemoved
	"Ensures that when a method is removed and a permalink is present, the nodes are removed from the link as they do not exist anymore"
	
	|methodNode link|
	ReflectivityExamples2 new generateNewMethodWithInstVarAccess.
	methodNode := (ReflectivityExamples2 >> #methodWithInstVarAccess) ast.
	
	link := MetaLink new.	 
	link installOnVariableNamed: #instVar for: ReflectivityExamples2 option: #all instanceSpecific: false.	
	self assert: link nodes size equals: 8.
	
	ReflectivityExamples2 new removeNewMethodWithInstVarAccess.	
	self assert: link nodes size equals: 4.
	link uninstall 
	

	
	! !

!LinkInstallerTest methodsFor: 'links - removing' stamp: ''!
testRemovingMethodNodes
	| metalink metalink2 node1 node2 |

	metalink := MetaLink new.
	metalink2 := MetaLink new.
	
	(ReflectivityExamples >> #exampleIfTrueIfFalse) ast link: metalink forObject: obj1.
	(ReflectivityExamples >> #exampleIfTrueIfFalse) ast allChildren last link: metalink2 forObject: obj1.
	self removeClassAccessControlForTests: obj1.
	
	node1 := (ReflectivityExamples >> #exampleIfTrueIfFalse)ast.
	node2 := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast allChildren last.
	
	node1 removeLink: metalink forObject: obj1.	
	self assert: obj1 class isAnonymous.
	
	node2 removeLink: metalink2 forObject: obj1.
	self deny: obj1 class isAnonymous! !

!LinkInstallerTest methodsFor: 'links - updating' stamp: ''!
testMethodModified
	"When modifying a method for which there was an object specific link,
	all links must be removed"

	| metalink node |
	obj1 compileTemporaryMethods.
	node := (ReflectivityExamples >> #methodToBeModified) ast allChildren atRandom.

	"Putting a link on a random node should migrate the object to an anonymous subclass"
	metalink := MetaLink new.
	node link: metalink forObject: obj1.
	self removeClassAccessControlForTests: obj1.
	self assert: obj1 class isAnonymous.

	"Modifyinh the original method should remove all object specific links and
	migrate back the object to its original class"
	ReflectivityExamples compile: 'methodToBeModified ^' , Time now printString printString.
	self deny: obj1 class isAnonymous.
	self assert: obj1 class identicalTo: ReflectivityExamples.
	self deny: metalink hasNodes.
	self assert: (metalink linkInstaller linkToNodesMapper findNodeLike: node forObject: obj1) isNil! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testUninstallLinkOnSlotOrVar
	| link linkRegistry permalink |
	link := MetaLink new.
	linkRegistry := link linkInstaller linksRegistry.
	
	link installOnVariableNamed: #instVar
		for: ReflectivityExamples2
		option: #all
		instanceSpecific: false.
		
	"After installing, registry must be correct"	
	permalink := (linkRegistry permaLinksFor:link) asArray first.
	self assert: (linkRegistry slotSourcesAt: ReflectivityExamples2) asArray first asArray first
		identicalTo: permalink slotOrVariable.
	self assert: (linkRegistry registeredTargetsAt: permalink slotOrVariable) asArray first 
		identicalTo: permalink.
		
	"After uninstalling, registry must be cleared"
	link uninstall.
	self assertEmpty: link nodes.
	self assertEmpty: (linkRegistry permaLinksFor:link).
	self assertEmpty: (linkRegistry slotSourcesAt: ReflectivityExamples2) flattened.
	self assertEmpty: (linkRegistry registeredTargetsAt: permalink slotOrVariable).
	
	link installOnVariableNamed: #classVar
		for: ReflectivityExamples2 new
		option: #all
		instanceSpecific: false.
	
	"After installing, registry must be correct"	
	permalink := (linkRegistry permaLinksFor:link) asArray first.
	self assert: (linkRegistry slotSourcesAt: ReflectivityExamples2) flattened first 
		identicalTo: permalink slotOrVariable.
	self assert: (linkRegistry registeredTargetsAt: permalink slotOrVariable) flattened first 
		identicalTo: permalink.
	
	"After uninstalling, registry must be cleared"
	link uninstall.
	self assertEmpty: link nodes.
	self assertEmpty: (linkRegistry permaLinksFor:link).
	self assertEmpty: (linkRegistry slotSourcesAt: ReflectivityExamples2) flattened.
	self assertEmpty: (linkRegistry registeredTargetsAt: permalink slotOrVariable)! !

!LinkInstallerTest methodsFor: 'links - installing' stamp: ''!
testObjectsAreWeakReferenced

	| metalink weakArray |
	metalink := MetaLink new.
	(obj1 class >> #exampleMethod) ast link: metalink forObject: obj1.
	weakArray := WeakArray with: obj1.
	
	self assert: weakArray first identicalTo: obj1.
	obj1 := nil.
	Smalltalk garbageCollect.	
	self assert: weakArray first equals: nil
! !

!LinkInstallerTest methodsFor: 'links - installing' stamp: ''!
testUninstallOneMetaLinkManyObjects
	"Globally uninstalling a link installed on many objects
		- link should not be active anymore
		- objects must recover their original classes"

	| counter metalink |	
	counter := 0.
	
	metalink := MetaLink new.
	metalink selector: #value.
	metalink metaObject: [ counter := counter + 1 ].
	metalink control: #before.
	(obj1 class >> #exampleMethod) ast link: metalink forObject: obj1.
	(obj2 class >> #exampleMethod) ast link: metalink forObject: obj2.
	(obj4 class >> #exampleMethod) ast link: metalink forObject: obj4.

	"The link is removed from 2 out of 3 objects. It should stay active on this last object"
	(obj1 class >> #exampleMethod) ast removeLink: metalink forObject: obj1.
	(obj4 class >> #exampleMethod) ast removeLink: metalink forObject: obj4.

	"Original method must execute and only object 2 increases the counter"
	obj1 exampleMethod.
	self assert: counter equals: 0.
	obj2 exampleMethod.
	self assert: counter equals: 1.
	obj4 exampleMethod.
	self assert: counter equals: 1.! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testSlotOrVarLinksRemainAfterMethodModificationForObject
	|methodNode link obj|

	obj := ReflectivityExamples2 new.
	ReflectivityExamples2 new resetModifiedMethodWithInstVarAccess.
	methodNode := (ReflectivityExamples2 >> #modifiedMethodWithInstVarAccess) ast.
	
	link := MetaLink new.	
	link installOnVariableNamed: #instVar for: obj option: #all instanceSpecific: true.

	self assert: link nodes size equals: 12.
	"self halt."
	ReflectivityExamples2 new modifyMethodWithInstVarAccess.
	self assert: link nodes size equals: 10.
	self assert: (link nodes allSatisfy: [:n| n links includes: link ]).
	link uninstall ! !

!LinkInstallerTest methodsFor: 'nodes' stamp: ''!
testFindingAnonymousNodes
	| link varNode instance objectSpecificVarNode |
	varNode := (ReflectivityExamples >> #exampleSendNoReturn) ast allChildren atRandom.

	link := MetaLink new.
	instance := ReflectivityExamples new.

	varNode link: link forObject: instance.
	objectSpecificVarNode := link linkInstaller linkToNodesMapper findNodeLike: varNode forObject: instance.

	self deny: varNode identicalTo: objectSpecificVarNode.
	self assert: varNode equals: objectSpecificVarNode! !

!LinkInstallerTest methodsFor: 'links - installing' stamp: ''!
testMetaLinkOnOneObject
	"Only one metalink for on object of a particular class. Other instances of this class must remain unaffected."

	| metalink |

	"The MetaLink must change the tag value to 1 before #exampleMethod"
	metalink := MetaLink new.
	metalink selector: #value.
	metalink metaObject: [ obj1 tagExec: 1 ].
	metalink control: #before.
	(obj1 class >> #exampleMethod) ast link: metalink forObject: obj1.

	"Only the object on which has been installed is affected"
	obj1 exampleMethod.
	obj2 exampleMethod.
	self assert: obj1 tag equals: 1.
	self assert: obj2 tag equals: nil.

	"After removing the link, the object is not affected anymore"
	(obj1 class >> #exampleMethod) ast removeLink: metalink forObject: obj1.
	obj1 tagExec: nil.
	obj1 exampleMethod.
	obj2 exampleMethod.
	self assert: obj1 tag equals: nil.
	self assert: obj2 tag equals: nil! !

!LinkInstallerTest methodsFor: 'links - installing' stamp: ''!
testUninstallLink
	"A link which is object specific must be removed from every possible node when uninstalled throug the MetaLink uninstall api"

	| metalink node |
	metalink := MetaLink new.
	
	(ReflectivityExamples >> #exampleIfTrueIfFalse) ast link: metalink.
	(ReflectivityExamples >> #exampleIfTrueIfFalse) ast link: metalink forObject: obj1.
	
	node := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast.
	metalink uninstall.
	
	self deny: obj1 class isAnonymous.
	self assert: node links isEmpty! !

!LinkInstallerTest methodsFor: 'links - installing' stamp: ''!
testLinkTargetsObjectsByIdentity
	|link ast set|
	link := MetaLink new metaObject: Halt; selector: #now.
	ast := (Set >> #add:) ast.
	
	set := Set new.
	set link: link toAST: ast.
	self should:[set add: 1] raise: Halt.
	
	set := Set new.
	set link: link toAST: ast.
	self should:[set add: 1] raise: Halt.! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testLinkOnClassVarForObject
	| link obj |
	link := MetaLink new.
	obj := ReflectivityExamples2 new.
	
	link installOnVariableNamed: #classVar for: obj option: #read instanceSpecific: false.
	self assert: link nodes size equals: 2.
	self assert: (link nodes allSatisfy: [:node| node isRead]).
	self assert: (link nodes allSatisfy: [:node| node name = #classVar]).		
	link uninstall.
	self assert: link nodes isEmpty.
	
	link installOnVariableNamed:  #classVar for: obj option: #write instanceSpecific: false.
	self assert: link nodes size equals: 2.
	self assert: (link nodes allSatisfy: [:node| node isAssignment]).
	self assert: (link nodes allSatisfy: [:node| node variable name = #classVar]).			
	link uninstall.
	self assert: link nodes isEmpty.
	
	link installOnVariableNamed: #classVar for: obj option: #all instanceSpecific: false.
	self assert: link nodes size equals: 4.	
	link uninstall.
	self assert: link nodes isEmpty.
	
	! !

!LinkInstallerTest methodsFor: 'links - removing' stamp: ''!
testRemovingMetaLinkOnOneObject
	"When removing a link from an object, the object looses the behavior brought by the link"

	| metalink |

	"The MetaLink must change the tag value to 1 before #exampleIfTrueIfFalse"
	metalink := MetaLink new.
	metalink selector: #value.
	metalink metaObject: [ obj1 tagExec: 1 ].
	metalink control: #before.
	(obj1 class >> #exampleIfTrueIfFalse) ast link: metalink forObject: obj1.

	"Only the object on which has been installed is affected"
	obj1 exampleIfTrueIfFalse.
	self assert: obj1 tag equals: 1.

	"After removing the link, the object is not affected anymore"
	(obj1 class >> #exampleIfTrueIfFalse) ast removeLink: metalink forObject: obj1.
	obj1 tagExec: nil.
	obj1 exampleIfTrueIfFalse.
	self assert: obj1 tag equals: nil! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testSlotOrVarLinksAddedAfterMethodAdditionForObject
	
	|methodNode link obj|

	methodNode := (ReflectivityExamples2 >> #methodWithInstVarAccess) ast.
	obj := ReflectivityExamples2 new.
	ReflectivityExamples2 new removeNewMethodWithInstVarAccess.
	
	link := MetaLink new.	
	link installOnVariableNamed: #instVar for: obj option: #all instanceSpecific: true.

	self assert: link nodes size equals: 4.
	
	ReflectivityExamples2 new generateNewMethodWithInstVarAccess.
	
	self assert: link nodes size equals: 8.
	link uninstall 
	

	
	! !

!LinkInstallerTest methodsFor: 'links - installing' stamp: ''!
testUninstallLinkFromNode
	"A link which is object specific must be removed from every possible node when uninstalled throug the MetaLink uninstall api"

	| metalink node |
	metalink := MetaLink new.
	
	(ReflectivityExamples >> #exampleIfTrueIfFalse) ast link: metalink.
	(ReflectivityExamples >> #exampleIfTrueIfFalse) ast link: metalink forObject: obj1.
	self removeClassAccessControlForTests: obj1.
	
	node := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast.
	self assert: obj1 class isAnonymous.
	self assert: metalink nodes size equals: 2.
	self assert: (metalink nodes includes: node).
	self assert: (metalink nodes includes: ((obj1 class >> #exampleIfTrueIfFalse) ast)).
	
	node removeLink: metalink forObject: obj1.
	
	self deny: obj1 class isAnonymous.
	self assert: metalink nodes size equals: 1.
	self assert: (metalink nodes includes: node)! !

!LinkInstallerTest methodsFor: 'running' stamp: ''!
removeClassAccessControlForTests: anObject
	anObject realClass removeSelector: #class! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testNodesRemovedFromLinkWhenMethodRemovedFromObject
	"Ensures that when a method is removed and a permalink is present, the nodes are removed from the link as they do not exist anymore"
	
	|link obj|
	ReflectivityExamples2 new generateNewMethodWithInstVarAccess.
	obj := ReflectivityExamples2 new.
	
	link := MetaLink new.	

	link installOnVariableNamed: #instVar for: obj option: #all instanceSpecific: true.	
	
	self assert: link nodes size equals: 8.	
	self assert: (link nodes allSatisfy: [:node| (obj class >> #newMethodWithInstVarAccess) ast allChildren includes: node]) .
	ReflectivityExamples2 new removeNewMethodWithInstVarAccess.	
	self assert: link nodes size equals: 4.
	
	link uninstall.
	self assert: link nodes isEmpty
	

	
	! !

!LinkInstallerTest methodsFor: 'links - updating' stamp: ''!
testPropagateClassScopedLinksRemoval
	"When removing a class scoped link from a node,
	it must also be removed from all anonymous classes with copy of this node and link."

	| metalink metalink2 node anonNode |	
	
	node := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast allChildren atRandom.

	metalink := MetaLink new.
	node link: metalink.
		
	metalink2 := MetaLink new.
	node link: metalink2 forObject: obj1.

	"The link is removed from the original class"
	anonNode := metalink linkInstaller findSubNode: node in: (obj1 class >> #exampleIfTrueIfFalse) ast.
	node removeLink: metalink.

	"The link shall not be present in the anon class node"
	self deny: (anonNode links includes: metalink)! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testLinkOnClassVar
	| link|
	link := MetaLink new.
	
	link installOnVariableNamed: #classVar for: ReflectivityExamples2 option: #read instanceSpecific: false.
	self assert: link nodes size equals: 2.
	self assert: (link nodes allSatisfy: [:node| node isRead]).
	self assert: (link nodes allSatisfy: [:node| node name = #classVar]).		
	link uninstall.
	self assert: link nodes isEmpty.
	
	link installOnVariableNamed: #classVar for: ReflectivityExamples2 option: #write instanceSpecific: false.
	self assert: link nodes size equals: 2.
	self assert: (link nodes allSatisfy: [:node| node isAssignment]).
	self assert: (link nodes allSatisfy: [:node| node variable name = #classVar]).			
	link uninstall.
	self assert: link nodes isEmpty.
	
	link installOnVariableNamed: #classVar for: ReflectivityExamples2 option: #all instanceSpecific: false.
	self assert: link nodes size equals: 4.	
	link uninstall.
	self assert: link nodes isEmpty.
	
	! !

!LinkInstallerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	Smalltalk garbageCollectMost.
	MetaLink uninstallAll.
	Smalltalk garbageCollectMost.
	obj1 := ReflectivityExamples new.
	obj2 := ReflectivityExamples new.
	obj3 := ReflectivityExamples new.
	obj4 := ReflectivityExamples2 new! !

!LinkInstallerTest methodsFor: 'nodes' stamp: ''!
testCallToSuper
	| obj link node |
	obj := ReflectivityExamples2Subclass new.
	node := (ReflectivityExamples2Subclass  >> #methodWithOverrides) ast.
	link := MetaLink new.	

	node link: link forObject: obj.
	
	self assert: obj methodWithOverrides equals: 'top + down'! !

!LinkInstallerTest methodsFor: 'links - installing' stamp: ''!
testOneMetaLinkClassAndObjects
	"Installs a MetaLink on one class. Installs another MetaLink on one instance of this class.
	- all instances of the class must be affected by the first MetaLink
	- only one specific instance must be affected by the second MetaLink"

	| counter metalink metalink2 |
	self flag: 'Split this test into smaller ones !!'.
	counter := 0.

	"First MetaLink affects all objects"
	metalink := MetaLink new.
	metalink selector: #value.
	metalink metaObject: [counter := counter + 1].
	metalink control: #before.
	(ReflectivityExamples >> #exampleMethod) ast link: metalink.	
	
	"The second MetaLink affects only object 3"
	metalink2 := MetaLink new.
	metalink2 selector: #value.
	metalink2 metaObject: [counter := counter + 2].
	metalink2 control: #before.
	(ReflectivityExamples >> #exampleMethod) ast link: metalink2 forObject: obj3.
	
	"Original method must execute as usual"
	self assert: counter equals: 0.
	obj1 exampleMethod.
	self assert: counter equals: 1.
	obj2 exampleMethod.
	self assert: counter equals: 2.
	
	"For object 3, the first MetaLink must be active and increase counter by 1.
	The second MetaLink must affect only this object and increase counter by 2.
	The counter value must be increased by 3."
	obj3 exampleMethod.
	self assert: counter equals: 5.

	"The link is removed from the 3 objects."
	(ReflectivityExamples >> #exampleMethod) ast removeLink: metalink.	

	"Original method must execute as usual"
	obj1 exampleMethod.
	self assert: counter equals: 5.
	obj2 exampleMethod.
	self assert: counter equals: 5.

	"Object 3 still has its instance specific link"
	obj3 exampleMethod.
	self assert: counter equals: 7.! !

!LinkInstallerTest methodsFor: 'running' stamp: ''!
tearDown
	ReflectivityExamples2 new removeModifiedMethodWithInstVarAccess.
	ReflectivityExamples new removeTemporaryMethods.
	Smalltalk garbageCollectMost.
	MetaLink uninstallAll.
	Smalltalk garbageCollectMost.
	super tearDown.! !

!LinkInstallerTest methodsFor: 'links - removing' stamp: ''!
testRemovingNodes
	| metalink metalink2 node1 node2 |

	metalink := MetaLink new.
	metalink2 := MetaLink new.
	
	(ReflectivityExamples >> #exampleIfTrueIfFalse) ast allChildren first link: metalink forObject: obj1.
	(ReflectivityExamples >> #exampleIfTrueIfFalse) ast allChildren fourth link: metalink2 forObject: obj1.
	self removeClassAccessControlForTests: obj1.
	
	node1 := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast allChildren first.
	node2 := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast allChildren fourth.
	
	node1 removeLink: metalink forObject: obj1.
	self assert: obj1 class isAnonymous.
	
	node2 removeLink: metalink2 forObject: obj1.
	self deny: obj1 class isAnonymous! !

!LinkInstallerTest methodsFor: 'links - removing' stamp: ''!
testRemovingNodeFromObject
	| metalink metalink2 |
	
	"Two links are put on the object which is migrated to an anon subclass."
	metalink := MetaLink new.
	(obj1 class lookupSelector: #exampleMethod) ast link: metalink forObject: obj1.
	metalink2 := MetaLink new.
	(obj1 class lookupSelector: #exampleSendNoReturn) ast link: metalink2 forObject: obj1.
	self removeClassAccessControlForTests: obj1.

	"The two nodes must now exist in the anon subclass"
	self shouldnt: [ obj1 class >> #exampleSendNoReturn ] raise: KeyNotFound.
	self shouldnt: [ obj1 class >> #exampleMethod ] raise: KeyNotFound.

	"After removing metalink2, the node it was put on must be removed from the anon subclass."
	(obj1 class >> #exampleSendNoReturn) ast removeLink: metalink2 forObject: obj1.
	self should: [ obj1 class >> #exampleSendNoReturn ] raise: KeyNotFound.
	self deny: (obj1 class lookupSelector: #exampleSendNoReturn) isNil! !

!LinkInstallerTest methodsFor: 'links - removing' stamp: ''!
testRemovingNodesWithSuper
	| obj link node |
	obj := ReflectivityExamples2Subclass new.
	node := (ReflectivityExamples2Subclass >> #methodWithOverrides) ast.
	link := MetaLink new.
	node link: link forObject: obj.
	self removeClassAccessControlForTests: obj.
	self assert: obj class isAnonymous.
	node removeLink: link forObject: obj.
	self deny: obj class isAnonymous! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testPermaLinkNotInstalledOnObjectIfExistsInClass
	
	|link obj|
	ReflectivityExamples2 new generateNewMethodWithInstVarAccess.
	obj := ReflectivityExamples2 new.
	
	link := MetaLink new.	

	link installOnVariableNamed: #instVar for: ReflectivityExamples2 option: #all instanceSpecific: true.
	self assert: link nodes size equals: 8.	
			
	link installOnVariableNamed: #instVar for: obj option: #all instanceSpecific: true.
	self assert: link nodes size equals: 8.		
	
	link uninstall.
	ReflectivityExamples2 new removeNewMethodWithInstVarAccess.	
	! !

!LinkInstallerTest methodsFor: 'nodes' stamp: ''!
testLinkOnRBProgramNode
	| link varNode instance objectSpecificVarNode |
	varNode := (ReflectivityExamples >> #exampleSendNoReturn) ast allChildren atRandom.
	link := MetaLink new.

	instance := ReflectivityExamples new.
	varNode link: link forObject: instance.
	objectSpecificVarNode := link linkInstaller linkToNodesMapper findNodeLike: varNode forObject: instance.

	self deny: varNode hasMetalink.
	self assert: objectSpecificVarNode hasMetalink.
	self assert: objectSpecificVarNode links asArray first identicalTo: link! !

!LinkInstallerTest methodsFor: 'links - updating' stamp: ''!
testPropagateNewClassScopedLinksOnMethodNode
	"When adding a class scoped link from a node,
	it must also be added to all anonymous classes with copy of this node and link."

	| metalink metalink2 node anonNode |	
	node := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast.
	
	metalink := MetaLink new.
	metalink2 := MetaLink new.
	node link: metalink2 forObject: obj1.

	"The link shall not be present in the anon class node"
	anonNode := (obj1 class >> #exampleIfTrueIfFalse) ast.
	self deny: (anonNode links includes: metalink).

	"After adding a link to the base class, it must be present on the copied node
	in the anonymous subclass"
	node link: metalink.
	self assert: (anonNode links includes: metalink)! !

!LinkInstallerTest methodsFor: 'links - installing' stamp: ''!
testMetaLinkWithAnonymousClasses
	| metalink |
	"We just need to link a MetaLink to an object"
	metalink := MetaLink new.
	(obj1 class >> #exampleMethod) ast link: metalink forObject: obj1.
	self removeClassAccessControlForTests: obj1.
	
	"One of the 2 objects must have migrated to another class"
	self assert: obj1 class ~= obj2 class.
	self assert: obj1 class superclass identicalTo: ReflectivityExamples.
	self assert: obj2 class identicalTo: ReflectivityExamples.

	"After removing the link, the object is back to its original class"
	(obj1 class >> #exampleMethod) ast removeLink: metalink forObject: obj1.
	self assert: obj1 class identicalTo: ReflectivityExamples.
	self assert: obj2 class identicalTo: ReflectivityExamples! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testLinkOnTempVar
	| methodNode link variable |
	methodNode := (ReflectivityExamples2 >> #methodWithTempVarAccess) ast.
	link := MetaLink new.
	variable := (ReflectivityExamples2 >> #methodWithTempVarAccess) temporaryVariableNamed: #temp.
	
	link installOnVariable: variable
		for: ReflectivityExamples2
		option: #read
		instanceSpecific: false.
	self assert: link nodes size equals: 2.
	self assert: (link nodes allSatisfy: [ :node | node isRead ]).
	self assert: (link nodes allSatisfy: [ :node | node name = #temp ]).
	self assert: (link nodes allSatisfy: [ :node | node isTempVariable ]).
	link uninstall.
	self assert: link nodes isEmpty.
	
	variable := (ReflectivityExamples2 >> #methodWithTempVarAccess) temporaryVariableNamed: #temp.
	link installOnVariable: variable
		for: ReflectivityExamples2
		option: #write
		instanceSpecific: false.
	self assert: link nodes size equals: 2.
	self assert: (link nodes allSatisfy: [ :node | node isAssignment ]).
	self assert: (link nodes allSatisfy: [ :node | node variable name = #temp ]).
	self assert: (link nodes allSatisfy: [ :node | node variable isTempVariable ]).
	link uninstall.
	self assert: link nodes isEmpty.
	
	variable := (ReflectivityExamples2 >> #methodWithTempVarAccess) temporaryVariableNamed: #temp.
	link installOnVariable: variable
		for: ReflectivityExamples2
		option: #all
		instanceSpecific: false.
	self assert: link nodes size equals: 4.
	link uninstall.
	self assert: link nodes isEmpty! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testSlotOrVarLinksRemainAfterMethodModification
	|methodNode link|

	ReflectivityExamples2 new resetModifiedMethodWithInstVarAccess.
	methodNode := (ReflectivityExamples2 >> #modifiedMethodWithInstVarAccess) ast.
	
	link := MetaLink new.	
	link installOnVariableNamed: #instVar for: ReflectivityExamples2 option: #all instanceSpecific: false.

	self assert: link nodes size equals: 12.
	
	ReflectivityExamples2 new modifyMethodWithInstVarAccess.
		
	self assert: link nodes size equals: 10.
	self assert: (link nodes allSatisfy: [:n| n links includes: link ]).
	link uninstall 
! !

!LinkInstallerTest methodsFor: 'links - updating' stamp: ''!
testPropagateClassScopedLinksOnMethodNode
	"When class scoped links exist on a method node,
	they must also be added to all anonymous classes with copy of this node and link."

	| metalink metalink2 node anonNode |

	node := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast.

	metalink := MetaLink new.
	node link: metalink.
	
	metalink2 := MetaLink new.
	node link: metalink2 forObject: obj1.
	
	anonNode := (obj1 class >> #exampleIfTrueIfFalse) ast.
	
	self assert: (anonNode links includes: metalink)! !

!LinkInstallerTest methodsFor: 'nodes' stamp: ''!
testCallToSuperWithArgs
	| obj link node |
	obj := ReflectivityExamples2Subclass new.
	node := (ReflectivityExamples2Subclass  >> #methodWithOverrides:with:) ast.
	link := MetaLink new.	

	node link: link forObject: obj.
	
	self assert: (obj methodWithOverrides: 'top' with: 'down') equals: 'topdowntopdown'! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testLinkOnTempVarForObject
	|  link obj temp |
	
	link := MetaLink new.
	obj := ReflectivityExamples2 new.
	temp := (ReflectivityExamples2>>#methodWithTempVarAccess) lookupVar: #temp.
	
	link installOnVariable: temp
		for: obj
		option: #read
		instanceSpecific: false.
	self assert: link nodes size equals: 2.
	self assert: (link nodes allSatisfy: [ :node | node isRead ]).
	self assert: (link nodes allSatisfy: [ :node | node name = #temp ]).
	self assert: (link nodes allSatisfy: [ :node | node isTempVariable ]).
	link uninstall.
	self assert: link nodes isEmpty.
	temp := (ReflectivityExamples2>>#methodWithTempVarAccess) lookupVar: #temp.
	
	link installOnVariable: temp
		for: obj
		option: #write
		instanceSpecific: false.
	self assert: link nodes size equals: 2.
	self assert: (link nodes allSatisfy: [ :node | node isAssignment]).
	self assert: (link nodes allSatisfy: [ :node | node variable name = #temp ]).
	self assert: (link nodes allSatisfy: [ :node | node variable isTempVariable ]).
	link uninstall.
	self assert: link nodes isEmpty.
	
	temp := (ReflectivityExamples2>>#methodWithTempVarAccess) lookupVar: #temp.
	
	link installOnVariable: temp
		for: obj
		option: #all
		instanceSpecific: false.
	self assert: link nodes size equals: 4.
	link uninstall.
	self assert: link nodes isEmpty! !

!LinkInstallerTest methodsFor: 'nodes' stamp: ''!
testPropagateLinksOnRBProgramNode
	| link link2 varNode instance objectSpecificVarNode |
	varNode := (ReflectivityExamples >> #exampleSendNoReturn) ast allChildren atRandom.
	link := MetaLink new.
	link2 := MetaLink new.
	varNode link: link.

	instance := ReflectivityExamples new.
	varNode link: link2 forObject: instance.
	objectSpecificVarNode := link2 linkInstaller linkToNodesMapper findNodeLike: varNode forObject: instance.

	self assert: varNode links size equals: 1.
	self assert: varNode links asArray first identicalTo: link.

	self assert: objectSpecificVarNode links size equals: 2.
	self assert: (objectSpecificVarNode links includes: link).
	self assert: (objectSpecificVarNode links includes: link2)! !

!LinkInstallerTest methodsFor: 'links - updating' stamp: ''!
testPropagateClassScopedLinksRemovalFromMethodNode
	"When removing a class scoped link from a method node,
	it must also be removed from all anonymous classes with copy of this node and link."

	| metalink metalink2 node anonNode |	
	
	node := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast.

	metalink := MetaLink new.
	node link: metalink.
		
	metalink2 := MetaLink new.
	node link: metalink2 forObject: obj1.

	"The link is removed from the original class"
	anonNode := (obj1 class >> #exampleIfTrueIfFalse) ast.
	node removeLink: metalink.

	"The link shall not be present in the anon class node"
	self deny: (anonNode links includes: metalink)! !

!LinkInstallerTest methodsFor: 'permalinks' stamp: ''!
testSlotOrVarLinksAddedAfterMethodAddition
	
	|methodNode link|
	methodNode := (ReflectivityExamples2 >> #methodWithInstVarAccess) ast.
	ReflectivityExamples2 new removeNewMethodWithInstVarAccess.
	
	link := MetaLink new.	
	link installOnVariableNamed: #instVar for: ReflectivityExamples2 option: #all instanceSpecific: false.

	self assert: link nodes size equals: 4.
	
	ReflectivityExamples2 new generateNewMethodWithInstVarAccess.
	
	self assert: link nodes size equals: 8.
	link uninstall 
	

	
	! !

!LinkInstallerTest methodsFor: 'links - updating' stamp: ''!
testPropagateClassScopedLinks
	"When class scoped links exist on a node,
	they must also be added to all anonymous classes with copy of this node and link."

	| metalink metalink2 node anonNode |		
	node := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast allChildren atRandom.

	metalink := MetaLink new.
	node link: metalink.
	
	metalink2 := MetaLink new.
	node link: metalink2 forObject: obj1.
	self removeClassAccessControlForTests: obj1.
	
	anonNode := metalink linkInstaller findSubNode: node in: (obj1 class >> #exampleIfTrueIfFalse) ast.
	
	self assert: anonNode links size equals: 2.
	self assert: (anonNode links includes: metalink)! !

!LinkInstallerTest methodsFor: 'links - installing' stamp: ''!
testOneMetaLinkManyObjects
	| counter metalink |
	counter := 0.
	metalink := MetaLink new.
	metalink selector: #value.
	metalink metaObject: [ counter := counter + 1 ].
	metalink control: #before.
	(obj1 class >> #exampleMethod) ast link: metalink forObject: obj1.
	(obj2 class >> #exampleMethod) ast link: metalink forObject: obj2.
	(obj4 class >> #exampleMethod) ast link: metalink forObject: obj4.

	"Original method must execute as usual while the counter is increased"
	self assert: counter equals: 0.
	obj1 exampleMethod.
	self assert: counter equals: 1.
	obj2 exampleMethod.
	self assert: counter equals: 2.
	obj4 exampleMethod.
	self assert: counter equals: 3! !

!LinkedList commentStamp: ''!
I am a sequential collection where adjecent objects are linked.
I can store any kind of objects that I will wrap into a Link (See implementation points).
I act pretty much as an OrderedCollection, but my access times differs: the method #atIndex: is depending of the number of elements so is not constant. In the worse case, the whole list must be crossed.
Using the message #addFirst: / #removeLast causes the receiver to behave as a stack; using #addLast: / #removeFirst causes the receiver to behave as a queue.

I use the Link class (or his subclasses) in my implementation. 

### Public API and Key Messages

- #new / #withAll: aCollection / #with: anObject 	are common constructors
- #add: anObject / #at: anIndex put: anObject 	allow to add new elements to myself.
- #remove: anObject 	allow to remove an element.
- #do: aBlock / #collect: aBlock / #select: aBlock / #reject: aBlock 	are common iterators.

### Example 

 	"There is many ways to create a LinkedList, here are some:"
```
	linkedList := LinkedList new.
	linkedList
		add: 'one';
		add: 'two';
		addFirst: 'zero';
		addLast: 'three'.
	linkedList.		"returns: a LinkedList('zero' 'one' 'two' 'three')"

	"or"
	linkedList := LinkedList with: 'one' with: 'two' with: 'three'.
	linkedList.		"returns: a LinkedList('one' 'two' 'three')"

	"or from an other collection (here an Array)"
	linkedList := LinkedList withAll: #('one' 'two' 'three').
	linkedList.		"returns: a LinkedList('one' 'two' 'three')"

	"Some manipulations"
	linkedList := LinkedList new.
	linkedList
		add: 1;
		add: 2.
	linkedList.		"returns: a LinkedList(1 2)"
	linkedList remove: 1.
	linkedList.		"returns: a LinkedList(2)"

	"A last one"
	linkedList := LinkedList with: $b with: $c with: $a.
	linkedList sort: [ :first :second | first < second ].			"returns: a LinkedList($a $b $c)"
	linkedList collect: [ :element | element asUppercase ].	"returns:  a LinkedList($A $B $C)"
	linkedList select: [ :element | element >= $b ].			"returns:  a LinkedList($b $c)"
	linkedList do: [ :element | element inspect ].
	linkedList asArray									"returns: #($a $b $c)"
```
			
### Internal Representation and Key Implementation Points.

Instance Variables
- firstLink:		 <Link> 	A link that contains the first value of the LinkedList.
- lastLink:		 <Link> 	A link that contains the last value of the LinkedList.

If you attempt to add any object into a LinkedList that is not a Link, it will automatically be wrapped by a ValueLink.!
!LinkedList methodsFor: 'testing' stamp: 'nil'!
isEmpty

	^firstLink isNil! !

!LinkedList methodsFor: 'private' stamp: 'nil'!
linkAt: index ifAbsent: errorBlock

	| i |
	i := 0.
	self linksDo: [:link |
		(i := i + 1) = index ifTrue: [^ link]].
	^ errorBlock value! !

!LinkedList methodsFor: 'adding' stamp: 'nil'!
add: aLinkOrObject
	"Add aLink to the end of the receiver's list. Answer aLink."

	^self addLast: aLinkOrObject! !

!LinkedList methodsFor: 'removing' stamp: 'nil'!
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: 'adding' stamp: 'nil'!
add: aLinkOrObject afterLink: otherLink

	"Add otherLink  after link in the list. Answer aLink."

	| savedLink aLink |
	lastLink == otherLink ifTrue: [^ self addLast: aLinkOrObject].
	savedLink := otherLink nextLink.
	aLink := aLinkOrObject asLink.
	otherLink nextLink: aLink.
	aLink nextLink:  savedLink.
	^aLink.! !

!LinkedList methodsFor: 'enumerating' stamp: 'nil'!
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: 'nil'!
linksDo: aBlock

	| aLink |
	aLink := firstLink.
	[aLink == nil ] whileFalse:
		[
		aBlock value: aLink.
		aLink := aLink nextLink]! !

!LinkedList methodsFor: 'enumerating' stamp: 'nil'!
collect: collectBlock thenReject: rejectBlock
	"Optimized version of SequenceableCollection>>#collect:#thenReject:"

	| newCollection newElement |
	newCollection := self class new.
	self
		do: [ :each | 
			newElement := collectBlock value: each.
			(rejectBlock value: newElement)
				ifFalse: [ newCollection add: newElement ] ].
	^ newCollection! !

!LinkedList methodsFor: 'copying' stamp: 'nil'!
copyWithout: oldElement
	|newInst| 
	newInst := self class new.
	self do: [:each | each = oldElement ifFalse: [newInst add: each]].
	^newInst! !

!LinkedList methodsFor: 'removing' stamp: 'nil'!
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: 'nil'!
removeLink: aLink
	^self removeLink: aLink ifAbsent: [self error: 'no such method!!']! !

!LinkedList methodsFor: 'adding' stamp: 'nil'!
add: link before: otherLinkOrObject
	"Add otherLink  after link in the list. Answer aLink."

	| otherLink |
	otherLink := self linkAt: (self indexOf: otherLinkOrObject).
	^ self add: link beforeLink: otherLink! !

!LinkedList methodsFor: 'enumerating' stamp: 'nil'!
collect: collectBlock thenSelect: selectBlock
	"Optimized version of SequenceableCollection>>#collect:#thenSelect:"

	| newCollection newElement |
	newCollection := self class new.
	self
		do: [ :each | 
			newElement := collectBlock value: each.
			(selectBlock value: newElement)
				ifTrue: [ newCollection add: newElement ] ].
	^ newCollection! !

!LinkedList methodsFor: 'enumerating' stamp: 'nil'!
select: selectBlock thenDo: doBlock
	"Optimized version of SequenceableCollection>>#select:thenDo:"

	self
		do: [ :each | 
				(selectBlock value: each)
					ifTrue: [ doBlock value: each ] ]! !

!LinkedList methodsFor: 'accessing' stamp: 'nil'!
at: index

	^(self linkAt: index) value! !

!LinkedList methodsFor: 'accessing' stamp: 'nil'!
indexOf: anElement startingAt: start ifAbsent: exceptionBlock
	"Answer the index of the first occurrence 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: 'enumerating' stamp: 'nil'!
do: aBlock

	| aLink |
	aLink := firstLink.
	[aLink == nil] whileFalse:
		[aBlock value: aLink value.
		 aLink := aLink nextLink]! !

!LinkedList methodsFor: 'accessing' stamp: 'nil'!
first
	"Answer the first link. Create an error notification if the receiver is 
	empty."
^self firstLink value! !

!LinkedList methodsFor: 'accessing' stamp: 'nil'!
last
	"Answer the last link. Create an error notification if the receiver is 
	empty."


	^self lastLink value! !

!LinkedList methodsFor: 'private' stamp: 'nil'!
linkOf: anObject 
	^ self
		linkOf: anObject
		ifAbsent: [self error: 'No such element']! !

!LinkedList methodsFor: 'private' stamp: 'nil'!
linkOf: anObject ifAbsent: errorBlock 
	
	self
		linksDo: [:el | el value = anObject
				ifTrue: [^ el]].
	^ errorBlock value! !

!LinkedList methodsFor: 'removing' stamp: 'nil'!
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: 'enumerating' stamp: 'nil'!
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: 'nil'!
reject: rejectBlock
	"Optimized version of SequenceableCollection>>#reject:"

	| newCollection |
	newCollection := self class new.
	self
		do: [ :each | 
			(rejectBlock value: each)
				ifFalse: [ newCollection add: each ] ].
	^ newCollection! !

!LinkedList methodsFor: 'sorting' stamp: 'nil'!
sort: aBlock
	|aLinkedList|
	self isEmpty ifTrue: [ ^self ].
	aLinkedList := LinkedList newFrom: (self asArray sort: aBlock).
	firstLink := aLinkedList firstLink.
	lastLink := aLinkedList lastLink.! !

!LinkedList methodsFor: 'removing' stamp: 'nil'!
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: 'adding' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
lastLink
	"Answer the last link. Create an error notification if the receiver is 
	empty."

	self emptyCheck.
	^lastLink! !

!LinkedList methodsFor: 'enumerating' stamp: 'nil'!
select: selectBlock thenCollect: collectBlock
	"Optimized version of SequenceableCollection>>#select:thenCollect:"

	| newCollection |
	newCollection := self class new.
	self
		do: [ :each | 
			(selectBlock value: each)
				ifTrue: [ newCollection add: (collectBlock value: each) ] ].
	^ newCollection! !

!LinkedList methodsFor: 'accessing' stamp: 'nil'!
firstLink
	"Answer the first link. Create an error notification if the receiver is 
	empty."

	self emptyCheck.
	^firstLink! !

!LinkedList methodsFor: 'private' stamp: 'nil'!
species

	^ Array! !

!LinkedList methodsFor: 'accessing' stamp: 'nil'!
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: 'nil'!
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: 'accessing' stamp: 'nil'!
at: index put: anObject

	^self at: index putLink: (self linkOf: anObject ifAbsent: [anObject asLink])! !

!LinkedList methodsFor: 'accessing' stamp: 'nil'!
at: index putLink: aLink 
	| previousLink nextLink |
	"Please don't put a link which is already in the list, or you will create an infinite loop"
	(self validIndex: index)
		ifFalse: [^ self errorOutOfBounds].
	index = 1
		ifTrue: [aLink nextLink: self firstLink nextLink.
			firstLink := aLink.
			aLink nextLink ifNil: [lastLink := aLink].
			^ aLink].
	previousLink := self linkAt: index - 1.
	nextLink := previousLink nextLink nextLink.
	
	nextLink ifNil: [
		aLink nextLink: self lastLink
	] ifNotNil: [
		aLink nextLink: nextLink.
	].

	previousLink nextLink: aLink.

	nextLink ifNil: [
		lastLink := aLink.
		aLink nextLink: nil.
	].

	^ aLink! !

!LinkedList methodsFor: 'adding' stamp: 'nil'!
add: link after: otherLinkOrObject
	"Add otherLink  after link in the list. Answer aLink."

	| otherLink |
	otherLink := self linkAt: (self indexOf: otherLinkOrObject).
	^ self add: link afterLink: otherLink! !

!LinkedList methodsFor: 'adding' stamp: 'nil'!
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: 'copying' stamp: 'nil'!
postCopy
	| aLink |
	super postCopy.
	firstLink ifNotNil: [
		aLink := firstLink := firstLink copy.
		[aLink nextLink isNil] whileFalse: [aLink nextLink: (aLink := aLink nextLink copy)].
		lastLink := aLink].! !

!LinkedList methodsFor: 'copying' stamp: 'nil'!
copyWith: newElement
	^self copy add: newElement; yourself! !

!LinkedList methodsFor: 'removing' stamp: 'nil'!
removeAll
	"Implementation note: this has to be fast"

	firstLink := lastLink := nil! !

!LinkedList methodsFor: 'accessing' stamp: 'nil'!
size
	"Answer how many elements the receiver contains."

	| tally |
	tally := 0.
	self do: [:each | tally := tally + 1].
	^ tally! !

!LinkedList methodsFor: 'private' stamp: 'nil'!
linkAt: index

	^self linkAt: index ifAbsent: [ self errorSubscriptBounds: index]! !

!LinkedList methodsFor: 'enumerating' stamp: 'nil'!
reject: rejectBlock thenCollect: collectBlock
	"Optimized version of SequenceableCollection>>#reject:thenCollect:"

	| newCollection |
	newCollection := self class new.
	self
		do: [ :each | 
			(rejectBlock value: each)
				ifFalse: [ newCollection add: (collectBlock value: each) ] ].
	^ newCollection! !

!LinkedList methodsFor: 'private' stamp: 'nil'!
validIndex: index
	 ^index > 0
			and: [index <= self size]! !

!LinkedList methodsFor: 'removing' stamp: 'nil'!
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 class methodsFor: 'stream creation' stamp: 'nil'!
new: size streamContents: aBlock
	^ self withAll: (super new: size streamContents: aBlock)! !

!LinkedList class methodsFor: 'instance creation' stamp: 'nil'!
new: anInt
	"LinkedList don't need capacity"
	^self new! !

!LinkedList class methodsFor: 'accessing' stamp: 'nil'!
streamSpecies
	^ Array! !

!LinkedList class methodsFor: 'instance creation' stamp: 'nil'!
newFrom: aCollection
	"Answer an instance with same elements as aCollection."
	^self new
		addAll: aCollection;
		yourself! !

!LinkedListTest commentStamp: ''!
A set of test cases which thoroughly test functionality of the LinkedList class.!
!LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutFirst

	| result |
	result := self nonEmpty copyWithoutFirst.
	
	self assert: result size equals: (self nonEmpty size - 1).
	
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (self nonEmpty at: (i + 1))]! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
collection
	^ self nonEmpty! !

!LinkedListTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne)! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
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: ''!
elementInForElementAccessing
" return an element inculded in 'accessCollection '"
	^ elementIn! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testBasicCollectThenDo

	| result index |
	index := 0.
	result := self collectionWithoutNilElements 
		collect: [ :each | nil ]
		thenDo: [ :each | 
			self assert: each isNil.
			index := index + 1]	.
			
	self assert: result equals: self collectionWithoutNilElements.
	self assert: index equals: self collectionWithoutNilElements size.! !

!LinkedListTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAt

	| subcollection index collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 1.
	self assert: index equals: 1.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 2.
	self assert: index equals: 0! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirstNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!LinkedListTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithElementAlreadyIn

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	oldSize := collection size.
	anElement := self element.
	self assert: (collection includes: anElement).
	
	added := collection addIfNotPresent: anElement.
	
	self assert: added == anElement .	"test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: oldSize! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSubcollectionAccessTest

	self moreThan3Elements.
	self assert: self moreThan3Elements size > 2! !

!LinkedListTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index between bounds of 'nonEmpty'"

	^ self nonEmpty size! !

!LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!LinkedListTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllSuchThat

	| el aSubCollection |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := self nonEmptyWithoutEqualElements copyWithout: el.
	self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | aSubCollection includes: each ].
	
	self assert: self nonEmptyWithoutEqualElements size equals: 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each equals: el ]! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
test03addFirst
	self assertEmpty: list.

	list addFirst: link1.
	self assert: list size equals: 1.
	self assert: list first equals: link1.

	list addFirst: link2.
	self assert: list size equals: 2.
	self assert: list first equals: link2.
	self assert: list second equals: link1.

	list addFirst: link3.
	self assert: list size equals: 3.
	self assert: list first equals: link3.
	self assert: list second equals: link2.
	self assert: list third equals: link1.

	list addFirst: link4.
	self assert: list size equals: 4.
	self assert: list first equals: link4.
	self assert: list second equals: link3.
	self assert: list third equals: link2.
	self assert: list fourth equals: link1! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
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: 'requirements' stamp: ''!
moreThan3Elements
	" return a collection including atLeast 3 elements"
	^ collectionWithoutEqualElements! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
testSort
	| aLinkedList |
	aLinkedList := LinkedList with: 1 with: 2.
	aLinkedList sort: [ :a :b | a > b ].
	self assert: aLinkedList equals: (LinkedList with: 2 with: 1)! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDoEmpty
	| result |
	result := OrderedCollection new.
	self empty reverseDo: [ :each | result add: each ].

	self assertEmpty: result! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenCollect

	| result index selectIndex pivot |
	
	index := 0.
	selectIndex := 0.
	pivot := self collectionWithoutNilElements anyOne.
	
	result := self collectionWithoutNilElements 
		select: [ :each | 
			selectIndex := selectIndex + 1.
			"reject the first element"
			selectIndex > 1 ]
		thenCollect: [ :each | 
			self assert: each notNil.
			index := index + 1.
			pivot ].
			
	self assert: result ~= self collectionWithoutNilElements.
	self assert: selectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.
	
	self assert: (self collectionWithoutNilElements occurrencesOf: pivot) equals: 1.
	"should be > 1 for standard collection and = 1 for those that do not allow exact duplicates"
	self assert: (result occurrencesOf: pivot) >= 1.! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollect
	
	| result firstCollection secondCollection index  |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	result := firstCollection  with: secondCollection collect:
		[:a :b |
		( index := index + 1).
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals:  b.
		b].
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (secondCollection  at: i)].
	self assert: result size = secondCollection size! !

!LinkedListTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
moreThan4Elements

" return a collection including at leat 4 elements"
	^ collectionWithoutEqualElements! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLastNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testRejectAllThenDo
	| result |
	
	result := self collectionWithoutNilElements 
		reject: [ :each | each notNil ] 
		thenDo: [ :each | self fail ].
	
	self assert: result equals: self collectionWithoutNilElements! !

!LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
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' stamp: ''!
test05addBefore
	self assertEmpty: list.

	list add: link1.
	self assert: list size equals: 1.
	self assert: list first identicalTo: link1.

	list add: link2 before: link1.
	self assert: list size equals: 2.
	self assert: list first identicalTo: link2.
	self assert: list second identicalTo: link1.

	list add: link3 before: link2.
	self assert: list size equals: 3.
	self assert: list first identicalTo: link3.
	self assert: list second identicalTo: link2.
	self assert: list third identicalTo: link1.

	list add: link4 before: link3.
	self assert: list size equals: 4.
	self assert: list first identicalTo: link4.
	self assert: list second identicalTo: link3.
	self assert: list third identicalTo: link2.
	self assert: list fourth identicalTo: link1! !

!LinkedListTest methodsFor: 'tests - empty' stamp: ''!
testIfEmptyifNotEmpty
	self assert: (self empty ifEmpty: [ true ] ifNotEmpty: [ false ]).
	self assert: (self nonEmpty ifEmpty: [ false ] ifNotEmpty: [ true ])! !

!LinkedListTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!LinkedListTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter
	
	| result allElementsAsString tmp |
	
	result := String streamContents: [ :aStream |
		tmp := OrderedCollection new.
		self nonEmpty do: [:each | tmp add: each asString].
		self nonEmpty printOn: aStream delimiter: ', ' ].
	
	allElementsAsString := (result findBetweenSubstrings: ', ').
	
	1 to: allElementsAsString size do:
		[:i | 
		self assert: (tmp occurrencesOf:(allElementsAsString at:i)) equals: (allElementsAsString  occurrencesOf:(allElementsAsString at:i)) ].! !

!LinkedListTest methodsFor: 'tests - empty' stamp: ''!
testNotEmpty
	self assert: self nonEmpty notEmpty.
	self deny: self empty notEmpty! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenDoOnEmpty
	self assertEmpty: (self empty select: [ :e | self fail ] thenDo: [ self fail ])! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsCollect
	| index result |
	index := 0.

	result := self nonEmptyMoreThan1Element
		pairsCollect: [ :each1 :each2 | 
			self assert: (self nonEmptyMoreThan1Element indexOf: each2) equals: (index := index + 2).
			(self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1) ].

	result do: [ :each | self assert: each ]! !

!LinkedListTest methodsFor: 'tests - adding' stamp: ''!
testTAddAll

	| added collection toBeAdded |
	collection := self collectionWithElement.
	toBeAdded := self otherCollection.
	added := collection addAll: toBeAdded.
	self assert: added == toBeAdded .	"test for identiy because #addAll: has not reason to copy its parameter."
	self assert: (collection includesAll: toBeAdded )! !

!LinkedListTest methodsFor: 'tests - empty' stamp: ''!
testIfNotEmptyifEmpty
	self assert: (self empty ifNotEmpty: [ false ] ifEmpty: [ true ]).
	self assert: (self nonEmpty ifNotEmpty: [ true ] ifEmpty: [ false ])! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testNoneSatisfy

	| element |
	self assert: ( self collectionWithoutNilElements  noneSatisfy: [:each | each notNil not ] ).
	element := self collectionWithoutNilElements anyOne.
	self deny: ( self collectionWithoutNilElements  noneSatisfy: [:each | (each = element)not ] ).! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testCollectThenSelectOnEmpty
	self assertEmpty: (self empty collect: [ :e | self fail ] thenSelect: [ :e | self fail ])! !

!LinkedListTest methodsFor: 'tests - empty' stamp: ''!
testIfNotEmpty
	self empty ifNotEmpty: [ self assert: false ].
	self nonEmpty ifNotEmpty: [ self assert: true ].
	self assert: (self nonEmpty ifNotEmpty: [ :s | s ]) = self nonEmpty! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
nonEmptyMoreThan1Element
" return a collection that don't includes equl elements'" 
	^collectionWithoutNil! !

!LinkedListTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printElementsOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	1 to: allElementsAsString size do:
		[:i | 
		self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString  occurrencesOf:(allElementsAsString at:i)).
			].! !

!LinkedListTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOf

	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element) equals: (collection indexOf: element)! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
testAtRandom

	| result |
	result := self nonEmpty atRandom.
	self assert: (self nonEmpty includes: result)! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!LinkedListTest methodsFor: 'tests - swap' stamp: ''!
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 - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenDo

	| result index selectIndex |
	
	index := 0.
	selectIndex := 0.
	
	result := self collectionWithoutNilElements 
		select: [ :each | 
			selectIndex := selectIndex + 1.
			"reject the first element"
			selectIndex > 1 ]
		thenDo: [ :each | 
			self assert: each notNil.
			index := index + 1]	.
			
	self assert: result equals: self collectionWithoutNilElements.
	self assert: selectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.! !

!LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringOne
	
	"self assert: self oneItemCol asCommaString = '1'.
	self assert: self oneItemCol asCommaStringAnd = '1'."

	self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString).
	self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString)! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	^ elementNotIn! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRequirementsOfTAddTest

	self collectionWithElement.
	self otherCollection.
	self element.
	self assert: (self collectionWithElement includes: self element).
	self deny: (self otherCollection includes: self element)! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
anotherElementNotIn
" return an element included  in 'collection' "
	^ elementNotIn! !

!LinkedListTest methodsFor: 'tests - remove' stamp: ''!
testRemoveIfAbsent
 
	| el res |
	el := self elementNotIn.
	res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ].
	self assert: res equals: 33! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
test07addAfter
	self assertEmpty: list.

	list add: link1.
	self assert: list size equals: 1.
	self assert: list first identicalTo: link1.

	list add: link2 after: link1.
	self assert: list size equals: 2.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.

	list add: link3 after: link1.
	self assert: list size equals: 3.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link3.
	self assert: list third identicalTo: link2.

	list add: link4 after: link1.
	self assert: list size equals: 4.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link4.
	self assert: list third identicalTo: link3.
	self assert: list fourth identicalTo: link2! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
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 equals: #(1 3).
	l add: (self class new n: 2) after: first.
	self assert: (l collect: [ :e | e n ]) asArray equals: #(1 2 3)! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureEmptyTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
testFirstSecondThird

	self assert: self moreThan4Elements first equals: (self moreThan4Elements at: 1).
	self assert: self moreThan4Elements second equals: (self moreThan4Elements at: 2).
	self assert: self moreThan4Elements third equals: (self moreThan4Elements at: 3).
	self assert: self moreThan4Elements fourth equals: (self moreThan4Elements at: 4)! !

!LinkedListTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterEmpty
	| result |
	result := self empty copyAfter: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
collectionClass
	"Return the class to be used to create instances of the class tested"
	
	^ LinkedList! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureBeginsEndsWithTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self assert: self nonEmpty size > 1.
	self empty.
	self assertEmpty: self empty! !

!LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!LinkedListTest methodsFor: 'tests - adding' stamp: ''!
testTAdd
	| added |
	added := self otherCollection add: self element.
	self assert: added equals: self element.	"equality or identity ?"
	self assert: (self otherCollection includes: self element)! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
accessCollection
	^collectionWithoutEqualElements! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
testAtIfAbsent

	| 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' stamp: ''!
testMiddle

	self assert: self moreThan4Elements middle equals: (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! !

!LinkedListTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
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 - iterating' stamp: ''!
testAllSatisfyEmpty

	self assert: ( self empty allSatisfy: [:each | false]).! !

!LinkedListTest methodsFor: 'tests - copying same contents' stamp: ''!
testReverse

	| result |
	result := self nonEmpty reversed.	
	"verify content of 'result: '"
	1 to: result size do:
		[:i | self assert: ((result at: i) 
			= (self nonEmpty at: (self nonEmpty size - i + 1)))].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
elementNotIn
	^ Link new! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTRemoveTest
	| duplicate |
	self empty.
	self nonEmptyWithoutEqualElements.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	duplicate := true.
	self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ].
	self deny: duplicate.
	self elementNotIn.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! !

!LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenDo

	| result index rejectIndex |
	
	index := 0.
	rejectIndex := 0.
	
	result := self collectionWithoutNilElements 
		reject: [ :each | 
			rejectIndex := rejectIndex + 1.
			"reject the first element"
			rejectIndex = 1 ]
		thenDo: [ :each | 
			self assert: each notNil.
			index := index + 1]	.
			
	self assert: result equals: self collectionWithoutNilElements.
	self assert: rejectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
testBeforeIfAbsent

	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 - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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 - sorting' stamp: ''!
testIsSorted
	self assert: self sortedInAscendingOrderCollection isSorted.
	self deny: self unsortedCollection isSorted! !

!LinkedListTest methodsFor: 'accessing' stamp: ''!
n: number
	n := number.! !

!LinkedListTest methodsFor: 'tests - subcollections access' stamp: ''!
testLastNElements

	| result |
	result := self moreThan3Elements last: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i + 1) ].
	self assert: result size equals: (self moreThan3Elements size - 1).
	self 
		should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ]
		raise: Error! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
test14removeIfAbsent
	list add: link1.

	self assert: list size equals: 1.
	self assert: list first identicalTo: link1.

	list remove: link1.
	self assertEmpty: list.

	[ list remove: link1 ]
		on: Error
		do: [ ^ self ].

	"The execution should not get here. If yes, something went wrong."
	self fail! !

!LinkedListTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result:=''.
	aStream:= ReadWriteStream on: result.
	self nonEmpty printNameOn: aStream.
	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ]
		ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
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: ''!
collectionWithSortableElements
	" return a collection only including elements that can be sorted (understanding '<' )"
	^ collection5Elements! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
testRemoveAll
	| list2 |
	list add: link1.
	list add: link2.
	list add: link3.
	list add: link4.
	list2 := list copy.
	list removeAll.

	self assert: list size equals: 0.
	self assert: list2 size = 4 description: 'the copy has not been modified'! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButFirstDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButFirstDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i +1))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element size-1)! !

!LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLastEmpty
	| result |
	result := self empty copyUpToLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testBasicCollectEmpty
	| res |
	res := self empty collect: [ :each | each class ].
	self assertEmpty: res! !

!LinkedListTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAtIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!LinkedListTest methodsFor: 'tests - index access' stamp: ''!
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 - iterate on sequenced reable collections' stamp: ''!
testWithDoError
	
	self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error! !

!LinkedListTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithNewElement

	| added oldSize collection elem |
	collection := self otherCollection.
	oldSize := collection size.
	elem := self element.
	self deny: (collection includes: elem ).
	
	added := collection  addIfNotPresent: elem .
	self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: (oldSize + 1).! !

!LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingStartWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty .
	result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ).
	
	"verify content of 'result' : "
	1 to: 2   do:
		[:i | self assert: ( element ) = ( result at:(i) ) ].
	
	3 to: result size do:
		[:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ].

	"verify size of 'result' :"
	self assert: result size = (self nonEmpty size + 2).! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDoEmpty
	| result |
	result := OrderedCollection new.

	self empty keysAndValuesDo: [ :i :value | result add: value + i ].

	self assertEmpty: result! !

!LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithSequenceable

	| result index element |
	index := self indexInNonEmpty.
	element := self nonEmpty at: index.
	result := self nonEmpty copyWith: (element ).
	
	self assert: result size equals: (self nonEmpty size + 1).
	self assert: result last equals: element.
	
	1 to: (result size - 1) do:
		[ :i | self assert: (result at: i) equals: ( self nonEmpty at: i)]! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexCollect
	
	| result index collection |
	index := 0.
	collection := self nonEmptyMoreThan1Element .
	result := collection  withIndexCollect: [:each :i | 
		self assert: i equals: (index := index + 1).	
		self assert: i equals: (collection  indexOf: each).
		each ]. 
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (collection at: i)].
	self assert: result size equals: collection size! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
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: 'requirements' stamp: ''!
elementInForIndexAccessing
" return an element included in 'accessCollection' "
	^ elementIn! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDetectSequenced
	"Testing that detect keep the first element returning true for sequenceable collections"

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element  detect: [:each | each notNil ].
	self assert: result equals: element! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
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 - index access' stamp: ''!
testLastIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection last.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: 99! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testCollectThenDoOnEmpty
	self assertEmpty: (self empty collect: [ :e | self fail ] thenDo: [ self fail ])! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenDoOnEmpty
	self assertEmpty: (self empty reject: [ :e | self fail ] thenDo: [ self fail ])! !

!LinkedListTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWithInsertion
	| result  indexOfSubcollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: ( indexOfSubcollection - 1 ) with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'' : '"
	
	1 to: (indexOfSubcollection -1) do: 
		[
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i)=(result at: i)
		].
	
	" middle part containing replacementCollection : "
	indexOfSubcollection  to: (indexOfSubcollection  + self replacementCollection size-1) do: 
		[
		:i |
		self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 ))
		].
	
	" end part :"
	(indexOfSubcollection  + self replacementCollection size) to: (result size) do:
		[:i|
		self assert: (result at: i)=(self collectionWith1TimeSubcollection  at: (i-self replacementCollection size))].
	
	" verify size: "	
	self assert: result size=(self collectionWith1TimeSubcollection  size + self replacementCollection size).! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopySameContentsTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testDo2
	"dc: Bad test, it assumes that a new instance of #speciesClass allows addition with #add:. This is not the case of Interval for which species is Array."
	"res := self speciesClass new.  
	self collection do: [:each | res add: each class].
	self assert: res = self result. "
	| collection cptElementsViewed cptElementsIn |
	collection := self collectionWithoutNilElements.
	cptElementsViewed := 0.
	cptElementsIn := OrderedCollection new.
	collection do: 
		[ :each | 
		cptElementsViewed := cptElementsViewed + 1.
		" #do doesn't iterate with the same objects than those in the collection for FloatArray( I don' t know why ) . That's why I use #includes: and not #identityIncludes:  '"
		(collection includes: each) ifTrue: [
			" the collection used doesn't include equal elements. Therefore each element viewed should not have been viewed before "
			( cptElementsIn includes: each ) ifFalse: [ cptElementsIn add: each ] .
			]. 
		].
	self assert: cptElementsViewed = collection size.
	self assert: cptElementsIn size  = collection size.! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenCollect

	| result index selectIndex pivot |
	
	index := 0.
	selectIndex := 0.
	pivot := self collectionWithoutNilElements anyOne.
	
	result := self collectionWithoutNilElements 
		reject: [ :each | 
			selectIndex := selectIndex + 1.
			"reject the first element"
			selectIndex = 1 ]
		thenCollect: [ :each | 
			self assert: each notNil.
			index := index + 1.
			pivot ].
			
	self assert: result ~= self collectionWithoutNilElements.
	self assert: selectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.
	
	self assert: (self collectionWithoutNilElements occurrencesOf: pivot) equals: 1.
	"should be > 1 for standard collection and = 1 for those that do not allow exact duplicates"
	self assert: (result occurrencesOf: pivot) >= 1.! !

!LinkedListTest methodsFor: 'running' stamp: ''!
tearDown
	list := nil.
	link1 := nil.
	link2 := nil.
	link3 := nil.
	link4 := nil.
	
	link := nil.
	nonEmpty := nil.
	otherList := nil.
	
	super tearDown! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLast

	| index |
	self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last.

	index := self moreThan4Elements indexOf: self elementInForElementAccessing.
	self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
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 equals: #(1 2).
	l add: third after: second.
	self assert: (l collect: [ :e | e n ]) asArray equals: #(1 2 3).
	l addLast: fourth.
	self assert: (l collect: [ :e | e n ]) asArray equals: #(1 2 3 4)! !

!LinkedListTest methodsFor: 'tests - swap' stamp: ''!
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: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self collection anyOne! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
test02addLast
	self assertEmpty: list.

	list addLast: link1.
	self assert: list size equals: 1.
	self assert: list first equals: link1.

	list addLast: link2.
	self assert: list size equals: 2.
	self assert: list first equals: link1.
	self assert: list second equals: link2.

	list addLast: link3.
	self assert: list size equals: 3.
	self assert: list first equals: link1.
	self assert: list second equals: link2.
	self assert: list third equals: link3.

	list addLast: link4.
	self assert: list size equals: 4.
	self assert: list first equals: link1.
	self assert: list second equals: link2.
	self assert: list third equals: link3.
	self assert: list fourth equals: link4! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	^ nonEmpty ifNil: [nonEmpty := LinkedList with: 5 with: 4 with: 3 with: 2 with: 1 with: self element]! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenCollectOnEmpty
	self assertEmpty: (self empty select: [ :e | self fail ] thenCollect: [ self fail ])! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
elementNotInForIndexAccessing
" return an element not included in 'accessCollection' "
	^ elementNotIn! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithoutEqualElements
" return a collection without equal elements "
	^ collectionWithoutEqualElements! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testCollectFromTo
	
	| result |
	result:=self nonEmptyMoreThan1Element 
		collect: [ :each | each ]
		from: 1
		to: (self nonEmptyMoreThan1Element size - 1).
		
	1 to: result size
		do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ].
	self assert: result size = (self nonEmptyMoreThan1Element size - 1)! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
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 - remove' stamp: ''!
testRemoveAllFoundIn

	| el aSubCollection   |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn.
	self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection.
	
	self assert: self nonEmptyWithoutEqualElements size equals: 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each equals: el ]! !

!LinkedListTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfIfAbsent

	| collection |
	collection := self collectionMoreThan1NoDuplicates.
	self assert: (collection 
			indexOf: collection first
			ifAbsent: [ 33 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 33 ]) equals: 33! !

!LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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' stamp: ''!
test04addBefore
	self assertEmpty: list.

	list add: link1.
	self assert: list size equals: 1.
	self assert: list first identicalTo: link1.

	list add: link2 before: link1.
	self assert: list size equals: 2.
	self assert: list first identicalTo: link2.
	self assert: list second identicalTo: link1.

	list add: link3 before: link1.
	self assert: list size equals: 3.
	self assert: list first identicalTo: link2.
	self assert: list second identicalTo: link3.
	self assert: list third identicalTo: link1.

	list add: link4 before: link1.
	self assert: list size equals: 4.
	self assert: list first identicalTo: link2.
	self assert: list second identicalTo: link3.
	self assert: list third identicalTo: link4.
	self assert: list fourth identicalTo: link1! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testAnySastify

	| element |
	" when all elements satisty the condition, should return true :"
	self assert: ( self collectionWithoutNilElements anySatisfy: [:each | each notNil ]).
	
	" when only one element satisfy the condition, should return true :"
	element := self collectionWithoutNilElements anyOne.
	self assert: ( self collectionWithoutNilElements  anySatisfy: [:each | (each = element)  ]   ).
	
	" when all elements don't satisty the condition, should return false :"
	self deny: ( self collectionWithoutNilElements anySatisfy: [:each | (each notNil) not ]).! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFromToDo
	
	| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each].
	
	1 to: (self nonEmptyMoreThan1Element  size -1) do:
		[:i | self assert: (self nonEmptyMoreThan1Element at:i) = (result at:i) ].

	self assert: result size = (self nonEmptyMoreThan1Element size - 1).! !

!LinkedListTest methodsFor: 'tests - copying same contents' stamp: ''!
testReversed

	| result |
	result := self nonEmpty reversed.
	
	"Verify content"
	result withIndexDo:
		[:el :i | self assert: el equals: (self nonEmpty at: (self nonEmpty size - i + 1))].

	"Verify size"
	self assert: result size=self nonEmpty size.! !

!LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
result
	"Returns a collection of the classes of elements in #collection"
	 ^ collectResult! !

!LinkedListTest methodsFor: 'tests - empty' stamp: ''!
empty
	^ list! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
element
	^ link ifNil: [link := ValueLink value: 42. "so that we can recognize this link"]! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDo
	| result |
	result := OrderedCollection new.
	self nonEmpty reverseDo: [: each | result add: each].
	
	1 to: result size do:
		[:i|
		self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))]! !

!LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
collectionWith1TimeSubcollection
" return a collection including 'oldSubCollection'  only one time "
	^ self oldSubCollection! !

!LinkedListTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty
	| result |
	result := self empty occurrencesOf: self collectionWithoutEqualElements anyOne.
	self assert: result equals: 0! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenCollectEmpty
	self assertEmpty: (self empty reject: [ :e | self fail ] thenCollect: [ :each | self fail ])! !

!LinkedListTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWith
	
	self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst).
	self assert: (self nonEmpty endsWith: self nonEmpty).
	self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!LinkedListTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	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 - sorting' stamp: ''!
testSortedUsingBlock
	| result tmp |
	result := self unsortedCollection sorted:  [:a :b | a>b]..
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLastEmpty
	| result |
	result := self empty copyAfterLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!LinkedListTest methodsFor: 'tests - empty' stamp: ''!
testIsEmptyOrNil
	self assert: self empty isEmptyOrNil.
	self deny: self nonEmpty isEmptyOrNil! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testDoSeparatedBy
	| string expectedString beforeFirst |
	
	string := ''.
	self collectionWithoutNilElements  
		do: [ :each | string := string , each asString ]
		separatedBy: [ string := string , '|' ].
		
	expectedString := ''.
	beforeFirst := true.
	self collectionWithoutNilElements  do: 
		[ :each | 
		beforeFirst = true 
			ifTrue: [ beforeFirst := false ]
			ifFalse: [ expectedString := expectedString , '|' ].
		expectedString := expectedString , each asString ].
	self assert: expectedString = string! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan1NoDuplicates
	" return a collection of size 5 without equal elements"
	^ collectionWithoutEqualElements! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
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 - subcollections access' stamp: ''!
testAllButFirstNElements

	| allButFirst collection |
	collection := self moreThan3Elements.
	allButFirst := collection allButFirst: 2.
	allButFirst withIndexDo: 
		 [:el :i | self assert: el equals: (collection at: i + 2) ].
	self assert: allButFirst size + 2 equals: collection size! !

!LinkedListTest methodsFor: 'accessing' stamp: ''!
n
	^n! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testRejectNoReject

	| res |
	res := self collectionWithoutNilElements  reject: [:each | each notNil not].
	self assert: res size = self collectionWithoutNilElements size.! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
" return a collection of size 1 including one element"
	^ nonEmpty1Element! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
test13remove
	list add: link1.
	list add: link2.
	list add: link3.
	list add: link4.

	self assert: list size equals: 4.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.
	self assert: list third identicalTo: link3.
	self assert: list fourth identicalTo: link4.

	list remove: link1.
	self assert: list size equals: 3.
	self assert: list first identicalTo: link2.
	self assert: list second identicalTo: link3.
	self assert: list third identicalTo: link4.

	list remove: link4.
	self assert: list size equals: 2.
	self assert: list first identicalTo: link2.
	self assert: list second identicalTo: link3.

	list remove: link2.
	self assert: list size equals: 1.
	self assert: list first identicalTo: link3.

	list remove: link3.
	self assertEmpty: list! !

!LinkedListTest methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWith
	
	self assert: (self nonEmpty beginsWith: (self nonEmpty copyUpTo: self nonEmpty last)).
	self assert: (self nonEmpty beginsWith: self nonEmpty).
	self deny: (self nonEmpty beginsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
sortedInAscendingOrderCollection
	"Return a collection sorted in ascending order"
	^ sortedCollection! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
test10removeFirst
	list add: link1.
	list add: link2.
	list add: link3.
	list add: link4.

	self assert: list size equals: 4.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.
	self assert: list third identicalTo: link3.
	self assert: list fourth identicalTo: link4.

	list removeFirst.
	self assert: list size equals: 3.
	self assert: list first identicalTo: link2.
	self assert: list second identicalTo: link3.
	self assert: list third identicalTo: link4.

	list removeFirst.
	self assert: list size equals: 2.
	self assert: list first identicalTo: link3.
	self assert: list second identicalTo: link4.

	list removeFirst.
	self assert: list size equals: 1.
	self assert: list first identicalTo: link4.

	list removeFirst.
	self assertEmpty: list! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testSelectNoneThenCollect
	| result |
	result := self collectionWithoutNilElements select: [ :each | each isNil ] thenCollect: [ :each | self fail ].

	self assertEmpty: result! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest
	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
indexInForCollectionWithoutDuplicates
" return an index between 'collectionWithoutEqualsElements'  bounds"
	^ 2! !

!LinkedListTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopy

	| result |
	result := self nonEmpty shallowCopy.
	
	"Verfy content"
	self nonEmpty withIndexDo:
		[:el :i | self assert: (result at:i) equals: (self nonEmpty at:i)].
	
	"Verify size"
	self assert: result size equals: self nonEmpty size.! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty.
	result := self nonEmpty forceTo: (self nonEmpty size + 2) paddingWith: element.
	
	"Verify content of 'result'"
	self nonEmpty withIndexDo:
		[:el :index | self assert: el equals: (result at: index) ].
	
	(result size - 1) to: result size do:
		[:i | self assert: (result at:i) equals: element ].

	"Verify size of 'result'"
	self assert: result size equals: self nonEmpty size + 2! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsDo

	| index |
	index:=1.
	
	self nonEmptyMoreThan1Element  pairsDo: 
		[:each1 :each2 | 
		self assert: (self nonEmptyMoreThan1Element at:index) equals: each1.
		self assert: (self nonEmptyMoreThan1Element at:(index+1)) equals: each2.
		index := index + 2 ].
	
	self nonEmptyMoreThan1Element size odd
		ifTrue:[ self assert: index equals: self nonEmptyMoreThan1Element size ]
		ifFalse:[ self assert: index equals: (self nonEmptyMoreThan1Element size+1) ]! !

!LinkedListTest methodsFor: 'tests - empty' stamp: ''!
testIfEmpty
	self nonEmpty ifEmpty: [ self assert: false ].
	self empty ifEmpty: [ self assert: true ]! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
testAtWrap
	"
	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 - subcollections access' stamp: ''!
testAllButLast

	| abf col |
	col := self moreThan3Elements.
	abf := col allButLast.
	self deny: abf last = col last.
	self assert: abf size + 1 equals: col size! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexDo

	|  indexes elements |
	indexes:= OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:value :i  |
			indexes  add: (i).
			elements add: value ].
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:el :i |
			self assert: (indexes at: i) equals: i.
			self assert: (elements at: i) equals: el ].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
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' stamp: ''!
test01add

	self assertEmpty: list.
	list add: link1.
	self assert: list size equals: 1.
	self assert: list first equals: link1.

	list add: link2.
	self assert: list size equals: 2.
	self assert: list first equals: link1.
	self assert: list second equals: link2.

	list add: link3.
	self assert: list size equals: 3.
	self assert: list first equals: link1.
	self assert: list second equals: link2.
	self assert: list third equals: link3.

	list add: link4.
	self assert: list size equals: 4.
	self assert: list first equals: link1.
	self assert: list second equals: link2.
	self assert: list third equals: link3.
	self assert: list fourth equals: link4.

	list add: nil.
	self assert: list size equals: 5.
	self assert: list first equals: link1.
	self assert: list second equals: link2.
	self assert: list third equals: link3.
	self assert: list fourth equals: link4.
	self assert: list fifth equals: nil! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testBasicCollect

	| res index |
	index := 0.
	res := self collectionWithoutNilElements collect: [ :each | 
		index := index + 1.
		each ].
	
	res do: [ :each | 
		self assert: (self collectionWithoutNilElements occurrencesOf: each) = (res occurrencesOf: each)].
	self assert: index equals: self collectionWithoutNilElements size.! !

!LinkedListTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!LinkedListTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!LinkedListTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLastNElements

	| allButLast collection |
	collection := self moreThan3Elements.
	allButLast := collection allButLast: 2.
	allButLast withIndexDo: [:el :i | self assert: el equals: (collection at: i) ].
	self assert: allButLast size + 2 equals: collection size! !

!LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	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 - begins ends with' stamp: ''!
testsBeginsWithEmpty
	
	self deny: (self nonEmpty beginsWith:(self empty)).
	self deny: (self empty beginsWith:(self nonEmpty))! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithOrWithoutSpecificElementsTest

	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self indexInNonEmpty.
	self assert: self indexInNonEmpty > 0.
	self assert: self indexInNonEmpty <= self nonEmpty size! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testSelect

	| result element |
	result := self collectionWithoutNilElements select: [ :each | each notNil].
	self assert: result size equals: self collectionWithoutNilElements size.
	
	element := self collectionWithoutNilElements anyOne.
	result := self collectionWithoutNilElements select: [ :each | (each = element) not].
	self assert: result size equals: (self collectionWithoutNilElements size - 1).! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
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: 'tests - copying with or without' stamp: ''!
testCopyWithFirst

	| index element result |
	index:= self indexInNonEmpty .
	element:= self nonEmpty at: index.
	
	result := self nonEmpty copyWithFirst: element.	
	
	self assert: result size = (self nonEmpty size + 1).
	self assert: result first = element .
	
	2 to: result size do:
	[ :i |
	self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! !

!LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpTo

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection   copyUpTo: (collection  at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at:i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testCollectOnEmpty
	self assertEmpty: (self empty collect: [ :e | self fail ])! !

!LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLast

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection copyUpToLast: (collection at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at: i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
otherCollection
	^ otherList ifNil: [otherList := LinkedList with: Link new with: Link new]! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateTest
	| res |
	self collectionWithoutNilElements.
	self assert: (self collectionWithoutNilElements occurrencesOf: nil) = 0.
	res := true.
	self collectionWithoutNilElements detect: [ :each | (self collectionWithoutNilElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testReject

	| res element |
	res := self collectionWithoutNilElements reject: [:each | each notNil not].
	self assert: res size = self collectionWithoutNilElements size.
	
	element := self collectionWithoutNilElements anyOne.
	res := self collectionWithoutNilElements  reject: [:each | each = element].
	self assert: res size = (self collectionWithoutNilElements size - 1).! !

!LinkedListTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementReallyRemovesElement

	| size |
	size := self nonEmptyWithoutEqualElements size.
	self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne.
	self assert: size - 1 equals: self nonEmptyWithoutEqualElements size! !

!LinkedListTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			lastIndexOf: element
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 99 ]) equals: 99! !

!LinkedListTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
" return a collection for wich each element is not included in 'nonEmpty' "
	^ collectionWithoutNil! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
test12remove
	list add: link1.
	list add: link2.
	list add: link3.
	list add: link4.

	self assert: list size equals: 4.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.
	self assert: list third identicalTo: link3.
	self assert: list fourth identicalTo: link4.

	list remove: link3.
	self assert: list size equals: 3.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.
	self assert: list third identicalTo: link4.

	list remove: link2.
	self assert: list size equals: 2.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link4.

	list remove: link1.
	self assert: list size equals: 1.
	self assert: list first identicalTo: link4.

	list remove: link4.
	self assertEmpty: list! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0SortingArrayedTest
	| tmp sorted |
	" an unsorted collection of number "
	self unsortedCollection.
	self unsortedCollection do: [ :each | each isNumber ].
	sorted := true.
	self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ].
	self deny: sorted.	" a collection of number sorted in an ascending order"
	self sortedInAscendingOrderCollection.
	self sortedInAscendingOrderCollection do: [ :each | each isNumber ].
	tmp := self sortedInAscendingOrderCollection at: 1.
	self sortedInAscendingOrderCollection
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	firstCollection  with: secondCollection do:
		[:a :b |
		index := index + 1.
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals: b ]! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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 - iterate on sequenced reable collections' stamp: ''!
testGroupsOfAtATimeCollect
	| groupsOf2 |
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: [ :x | x ]).
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: #yourself).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 2 atATimeCollect: [ :x | x ].
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 2.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 2 ]).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 3 atATimeCollect: #yourself.
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 3.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 3 ]).! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testSumNumbers
	|result|
	result:= self collectionWithoutNilElements 
		sumNumbers: [ :ele | ele notNil ifTrue: [ 1 ] ifFalse: [ 0 ]].
	
	self assert: self collectionWithoutNilElements size = result! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
elementToAdd
" return an element of type 'nonEmpy' elements'type'"
	^ ValueLink value: 77! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithReplacementTest
	self replacementCollection.
	self oldSubCollection.
	self collectionWith1TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
test06addAfter
	self assertEmpty: list.

	list add: link1.
	self assert: list size equals: 1.
	self assert: list first identicalTo: link1.

	list add: link2 after: link1.
	self assert: list size equals: 2.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.

	list add: link3 after: link2.
	self assert: list size equals: 3.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.
	self assert: list third identicalTo: link3.

	list add: link4 after: link3.
	self assert: list size equals: 4.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.
	self assert: list third identicalTo: link3.
	self assert: list fourth identicalTo: link4! !

!LinkedListTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAtIfAbsent
	| absent subcollection collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ].
	self deny: absent.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ].
	self assert: absent! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
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 - converting' stamp: ''!
testAsSet
 	"Test with a collection without equal elements"
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
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 equals: #(1 2).
	l add: (self class new n: 3) after: last.
	self assert: (l collect: [ :e | e n ]) asArray equals: #(1 2 3)! !

!LinkedListTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWithEmpty
	
	self deny: (self nonEmpty endsWith: self empty).
	self deny: (self empty endsWith: self nonEmpty)! !

!LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLast

	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection copyAfterLast: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!LinkedListTest methodsFor: 'tests - sequenceable' stamp: ''!
testAtPut
	| ll |
	ll := LinkedList new.
	ll add: 1.
	ll at: 1 put: 2.
	self assert: (ll at: 1) equals: 2! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testRejectEmpty

	| res |
	res := self empty reject: [:each | each odd].
	self assert: res size = self empty size! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
collectionWithElement
	"Returns a collection that already includes what is returned by #element."
	^ self collection! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testInjectInto
	|result|
	result:= self collectionWithoutNilElements 
		inject: 0
		into: [:inj :ele | ele notNil ifTrue: [ inj + 1 ]].
	
	self assert: self collectionWithoutNilElements size = result .! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
elementNotInForOccurrences
" return an element notIncluded in #collectionWithoutEqualElements"
	^ elementNotIn! !

!LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutIndex

	| result index |	
	index := self indexInNonEmpty.
	result := self nonEmpty copyWithoutIndex: index.
	
	"Verify content of result"
	result withIndexDo: 
		[:element :i | 
		 i <  index ifTrue: [ self assert: element equals: (self nonEmpty at: i) ].
		 i >= index ifTrue: [ self assert: element equals: (self nonEmpty at: (i + 1)) ]].
	
	"Verify size of result"
	self assert: result size equals: (self nonEmpty size - 1)! !

!LinkedListTest methodsFor: 'running' stamp: ''!
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 .
	unsortedCollection := LinkedList new addAll: #(57 937 92 49 0 78 -87); yourself.
	sortedCollection := LinkedList new addAll: #(-87 0 49 57 78 92 937); yourself.
	"sameAttendAndBegining := 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: 'tests - iterating' stamp: ''!
testNoneSatisfyEmpty

	self assert: ( self empty noneSatisfy: [:each | false]).! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
testSorted
	| result tmp unsorted |
	unsorted := self unsortedCollection.
	result := unsorted sorted.
	self deny: unsorted == result.
	tmp := result at: 1.
	result
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringMore

	"self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'.
	self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3'"

	| result resultAnd index allElementsAsString |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
 
	index := 1.
	(result findBetweenSubstrings: ',' )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 findBetweenSubstrings: ',' ).
	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 - sorting' stamp: ''!
testIsSortedBy
	self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]).
	self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]).! !

!LinkedListTest methodsFor: 'tests - swap' stamp: ''!
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 - element accessing' stamp: ''!
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 - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
testLast

	self assert: self moreThan4Elements last equals: (self moreThan4Elements at: self moreThan4Elements size)! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
replacementCollection
" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection'  " 
	^ collectionWithoutNil! !

!LinkedListTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopyEmpty
	| result |
	result := self empty shallowCopy.
	self assertEmpty: result! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
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 equals: #(1 2).
	l add: (self class new n: 3) after: last.
	self assert: (l collect: [ :e | e n ]) asArray equals: #(1 2 3)! !

!LinkedListTest methodsFor: 'accessing' stamp: ''!
nextLink
	^nextLink! !

!LinkedListTest methodsFor: 'accessing' stamp: ''!
nextLink: aLink
	nextLink := aLink! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testDetectIfNone

	| res element |
	res := self collectionWithoutNilElements  detect: [:each | each notNil not] ifNone: [100].
	self assert: res  = 100.
	
	element := self collectionWithoutNilElements anyOne.
	res := self collectionWithoutNilElements  detect: [:each | each = element] ifNone: [100].
	self assert: res  = element.! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
howMany: aSubCollection in: collection
" return an integer representing how many time 'subCollection'  appears in 'collection'  "
	| tmp nTime |
	tmp := collection.
	nTime:= 0.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				nTime := nTime + 1.
				1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.]
				]
			ifFalse: [tmp := tmp copyWithoutFirst.]
		 ].
	
	^ nTime.! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateSequencedReadableTest
	| res |
	self nonEmptyMoreThan1Element.
	self assert: self nonEmptyMoreThan1Element size > 1.

	self empty.
	self assertEmpty: self empty.

	res := true.
	self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
unsortedCollection
"Return a collection that is not yet sorted"
	^ unsortedCollection! !

!LinkedListTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExists

	| el res |
	el := self nonEmptyWithoutEqualElements anyOne.
	res := self nonEmptyWithoutEqualElements remove: el.
	self assert: res == el! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDo! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessTest
	| res |
	self collectionMoreThan1NoDuplicates.
	self assert: self collectionMoreThan1NoDuplicates size equals: 5.
	res := true.
	self collectionMoreThan1NoDuplicates detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res equals: false.
	self elementInForIndexAccessing.
	self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing).
	self elementNotInForIndexAccessing.
	self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! !

!LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!LinkedListTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testSelectNoneThenDo
	| result |
	
	result := self collectionWithoutNilElements 
		select: [ :each | each isNil ] 
		thenDo: [ self fail ].
	
	self assert: result equals: self collectionWithoutNilElements! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
" return a collection of elements included in 'nonEmpty'  "
	^ self nonEmpty! !

!LinkedListTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!LinkedListTest methodsFor: 'tests - copying with replacement' stamp: ''!
firstIndexesOf: aSubCollection in: collection
" return an OrderedCollection with the first indexes of the occurrences of subCollection in  collection "
	| tmp result currentIndex |
	tmp:= collection.
	result:= OrderedCollection new.
	currentIndex := 1.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				result add: currentIndex.
				1 to: aSubCollection size do: 
					[:i | 
					tmp := tmp copyWithoutFirst.
					currentIndex := currentIndex + 1]
				]
			ifFalse: [
				tmp := tmp copyWithoutFirst.
				currentIndex := currentIndex +1.
				]
		 ].
	
	^ result.! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
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 - remove' stamp: ''!
testRemoveAllError
	| el aSubCollection |
	el := self elementNotIn.
	aSubCollection := self nonEmptyWithoutEqualElements copyWith: el.

	self should: [ self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
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 equals: #(1 3).
	l add: (self class new n: 2) after: first.
	self assert: (l collect: [ :e | e n ]) asArray equals: #(1 2 3)! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
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 - copying part of sequenceable' stamp: ''!
testCopyFromTo
	| result  index collection |
	collection := self collectionWithoutEqualElements .
	index :=self indexInForCollectionWithoutDuplicates .
	result := collection   copyFrom: index  to: collection  size .
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at:i) equals: (collection  at: (i + index - 1))].
	
	"Verify size"
	self assert: result size equals: (collection  size - index + 1)! !

!LinkedListTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn
	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	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 - iterating' stamp: ''!
testSelectOnEmpty
	self assertEmpty: (self empty select: [ :e | self fail ])! !

!LinkedListTest methodsFor: 'tests - subcollections access' stamp: ''!
testFirstNElements

	| result |
	result := self moreThan3Elements first: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i) ].
	
	self assert: result size equals: (self moreThan3Elements size - 1).
	self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: SubscriptOutOfBounds! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeWithIdentityTest

	| anElement |
	self collectionWithCopyNonIdentical.
	anElement := self collectionWithCopyNonIdentical anyOne.
	self deny: anElement == anElement copy! !

!LinkedListTest methodsFor: 'tests - sequenceable' stamp: ''!
testAtPutOutsideBounds
	| ll |
	ll := LinkedList new.
	self should: [ ll at: 1 put: 1 ] raise: SubscriptOutOfBounds! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
elementNotInForElementAccessing
" return an element not included in 'accessCollection' "
	^ elementNotIn! !

!LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	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 - swap' stamp: ''!
testSwapStartAndEnd
	|aList|
	aList := LinkedList with: 5 with: 4 with: 3 with: 2 with: 1.
	
	aList swap: 1 with: 5.
	self assert: (aList at: 1) equals: 1.
	self assert: (aList at: 5) equals: 5.
	self assert: aList first equals: 1.
	self assert: aList last equals: 5.! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDo
	"| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		result add: (value+i)].
	
	1 to: result size do:
		[:i|
		self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]"
	|  indexes elements |
	indexes := OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		indexes  add: (i).
		elements add: value].
	
	(1 to: self nonEmptyMoreThan1Element size )do:
		[ :i |
		self assert: (indexes at: i) equals: i.
		self assert: (elements at: i) equals: (self nonEmptyMoreThan1Element at: i).	
		].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
" return a collection that doesn't includes a nil element "
	^collectionWithoutNil! !

!LinkedListTest methodsFor: 'tests - swap' stamp: ''!
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 - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ' ).
	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 - index access' stamp: ''!
testIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!LinkedListTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testDetect

	| res element |
	element := self collectionWithoutNilElements anyOne .
	 
	res := self collectionWithoutNilElements  detect: [:each | each = element].
	self assert: (res  = element).! !

!LinkedListTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfSequenceableTest
	self collectionWithoutEqualElements.
	self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ].
	self indexInForCollectionWithoutDuplicates.
	self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size.
	self empty.
	self assertEmpty: self empty! !

!LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result index |
	delim := ', '.
	result := ''.
	multiItemStream := ReadWriteStream on: result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	index:=1.
	(result findBetweenSubstrings: delim)do:
		[:each |
			self assert: each= ((self nonEmpty at:index) asString).
			index:=index+1 ]! !

!LinkedListTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!LinkedListTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!LinkedListTest methodsFor: 'tests - sorting' stamp: ''!
testSortUsingSortBlock
	| result tmp |
	result := self unsortedCollection sort: [:a :b | a>b].
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
subCollectionNotIn
" return a collection for which at least one element is not included in 'accessCollection' "
	^ collectionWithoutNil! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testAllSatisfy

	| element |
	" when all element  satisfy the condition, should return true : "
	self assert: ( self collectionWithoutNilElements  allSatisfy: [:each | (each notNil) ] ).
	
	" when all element don't satisfy the condition, should return false : "
	self deny: ( self collectionWithoutNilElements  allSatisfy: [:each | (each notNil) not ] ).
	
	" when only one element doesn't satisfy the condition' should return false'"
	element := self collectionWithoutNilElements anyOne.
	self deny: ( self collectionWithoutNilElements  allSatisfy: [:each | (each = element) not] ).! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedElementAccessTest

	self moreThan4Elements.
	self assert: self moreThan4Elements size >= 4.
	self subCollectionNotIn.
	self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ].
	self elementNotInForElementAccessing.
	self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing).
	self elementInForElementAccessing.
	self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! !

!LinkedListTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWith
	| result  indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1.
	lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection  size -1.
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: lastIndexOfOldSubcollection   with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'  "
	
	1 to: (indexOfSubcollection  - 1) do: 
		[ 
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i) = (result at: i)
		].
	
	" middle part containing replacementCollection : "
	
	(indexOfSubcollection ) to: ( lastIndexOfReplacementCollection  ) do: 
		[
		:i |
		self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1))
		].
	
	" end part :"
	1 to: (result size - lastIndexOfReplacementCollection   ) do:
		[ 
		:i |
		self assert: (result at: ( lastIndexOfReplacementCollection  + i  ) ) = (self collectionWith1TimeSubcollection  at: ( lastIndexOfOldSubcollection  + i  ) ).
		].! !

!LinkedListTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOfIAbsent
	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) 
	     equals: 1.

	self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) 
		  equals: 55! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastError

	self 
		should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ]
		raise: Error! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLast

	| element result |
	element := self nonEmptyMoreThan1Element at: self nonEmptyMoreThan1Element size.
	result := self nonEmptyMoreThan1Element findLast: [:each | each =element].
	
	self assert: result equals: self nonEmptyMoreThan1Element size! !

!LinkedListTest methodsFor: 'tests - copying same contents' stamp: ''!
testShuffled
	| result |
	result := self nonEmpty shuffled .
	
	"verify content of 'result: '"
	result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size.! !

!LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToEmpty
	| result |
	result := self empty copyUpTo: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!LinkedListTest methodsFor: 'tests - creating' stamp: ''!
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 - remove' stamp: ''!
testRemoveElementFromEmpty

	self 
		should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ]
		raise: Error! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButLastDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButLastDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i ))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element  size-1)! !

!LinkedListTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollectError

	self should: [ self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error! !

!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := firstCollection size.
	
	firstCollection  reverseWith: secondCollection do:
		[:a :b |
	
		self assert: (firstCollection at: index) equals: a. 
		self assert: (secondCollection at: index) equals: b.
			(index := index - 1)]! !

!LinkedListTest methodsFor: 'tests - element accessing' stamp: ''!
testAtOutOfBounds

	self 
		should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ]
		raise: Error.
	self 
		should: [ self moreThan4Elements at: -1 ]
		raise: Error! !

!LinkedListTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!LinkedListTest methodsFor: 'tests - copy' stamp: ''!
testCopyNonEmptyWithoutAll

	| res |
	res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove.
	"here we do not test the size since for a non empty set we would get a problem.
	Then in addition copy is not about duplicate management. The element should 
	be in at the end."
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ].
	self nonEmpty do: 
		[ :each | 
		(self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! !

!LinkedListTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWith1Occurrence
	| 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 - occurrencesOf' stamp: ''!
testOccurrencesOf
	| collection |
	collection := self collectionWithoutEqualElements .
	
	collection do: [ :each | self assert: (collection occurrencesOf: each) equals: 1 ]! !

!LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfter
	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection   copyAfter: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!LinkedListTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!LinkedListTest methodsFor: 'tests' stamp: ''!
test11removeLast
	list add: link1.
	list add: link2.
	list add: link3.
	list add: link4.

	self assert: list size equals: 4.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.
	self assert: list third identicalTo: link3.
	self assert: list fourth identicalTo: link4.

	list removeLast.
	self assert: list size equals: 3.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.
	self assert: list third identicalTo: link3.

	list removeLast.
	self assert: list size equals: 2.
	self assert: list first identicalTo: link1.
	self assert: list second identicalTo: link2.

	list removeLast.
	self assert: list size equals: 1.
	self assert: list first identicalTo: link1.

	list removeFirst.
	self assertEmpty: list! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
speciesClass
	
	^LinkedList! !

!LinkedListTest methodsFor: 'tests - includes' stamp: ''!
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 - iterate on sequenced reable collections' stamp: ''!
testFindFirst

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element findFirst: [:each | each = element].
	
	self assert: result equals: 1! !

!LinkedListTest methodsFor: 'tests - subcollections access' stamp: ''!
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 - includes' stamp: ''!
testIdentityIncludes
	" test the comportement in presence of elements 'includes' but not 'identityIncludes' "

	" can not be used by collections that can't include elements for wich copy doesn't return another instance "

	| collection element |
	self collectionWithCopyNonIdentical.
	collection := self collectionWithCopyNonIdentical.
	element := collection anyOne copy.	"self assert: (collection includes: element)."
	self deny: (collection identityIncludes: element)! !

!LinkedListTest methodsFor: 'tests - empty' stamp: ''!
testIsEmpty
	self assert: self empty isEmpty.
	self deny: self nonEmpty isEmpty! !

!LinkedListTest methodsFor: 'tests - index access' stamp: ''!
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) equals: index! !

!LinkedListTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
	" return a collection not including equal elements "

	^ collectionWithoutEqualElements! !

!LinkedListTest methodsFor: 'tests - iterating' stamp: ''!
testRejectAllThenCollect
	| result |
	result := self collectionWithoutNilElements reject: [ :each | each notNil ] thenCollect: [ :each | self fail ].

	self assertEmpty: result! !

!LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |
	delim := ', '.
	result := ''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!LinkedListTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!LinkedListTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!LinkedListTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!LinkedListTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!LinkedListTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!LinkedListTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!LinkedListTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!LinkedListTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!LinkedListTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!LinkedListTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!LinkedListTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!LinkedListTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!LinkedListTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!LinkedListTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!LinkedListTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!LinkedListTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!LinkedListTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!LinkedListTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!LinkedListTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!LinkedListTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!LinkedListTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!LinkedListTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!LinkedListTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!LinkedListTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!LinkedListTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!LinkedListTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!LinkedListTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!LinkedListTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!LinkedListTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ListDialogWindow commentStamp: ''!
A ListDialogWindow is a dialog window used to search an element into a list.
A text field is provided to on the fly reduce the field or search!
!ListDialogWindow methodsFor: 'events' stamp: ''!
listKeystrokeUp
	listIndex = 1 
		ifTrue: [ 
			self listIndex: 0.
			self giveFocusToSearch.
			^ true].
	^ false.! !

!ListDialogWindow methodsFor: 'display' stamp: ''!
displayBlock: aBlock

	displayBlock := aBlock! !

!ListDialogWindow methodsFor: 'accessing' stamp: ''!
answer
	^ answer! !

!ListDialogWindow methodsFor: 'protocol' stamp: ''!
initialFilter: aString
	searchMorph content: aString.! !

!ListDialogWindow methodsFor: 'actions' stamp: ''!
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: 'item creation' stamp: ''!
buildBrowseButton

	^ (PluggableButtonMorph
		on: self
		getState: #state
		action: #browseAction)
		label: 'Browse';
		yourself! !

!ListDialogWindow methodsFor: 'items creation' stamp: ''!
buildListMorph
	^ listMorph := PluggableListMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		on: self
			list: #list
			selected: #listIndex
			changeSelected: #listIndex:
			menu: nil
			keystroke: nil;
		keystrokeSelector: #listKeystroke:;
		doubleClickSelector: #doubleClickOk;
		wrapSelector: #displayItem:;
		yourself! !

!ListDialogWindow methodsFor: 'events' stamp: ''!
searchKeystrokeDown
	|interval|
	interval := searchMorph selectionInterval .
	((interval last == searchMorph content size)
	and: [ interval last < interval first ])
		ifFalse: [ ^ false ].
		
	self giveFocusToList.
	^ true! !

!ListDialogWindow methodsFor: 'events' stamp: ''!
searchKeystroke: event
	
	searchMorph content ifNil: [ ^ false ].
	
	(event keyCharacter = Character arrowDown )
		ifTrue: [ ^ self searchKeystrokeDown ].
		
	(event keyCharacter = Character arrowUp)
		ifTrue: [ ^ self searchKeystrokeUp ].! !

!ListDialogWindow methodsFor: 'button behavior' stamp: ''!
browseBlock

	^ browseBlock! !

!ListDialogWindow methodsFor: 'actions' stamp: ''!
ok

	(acceptNewEntry and: [ list isEmpty ]) ifTrue: [ 
		self answer: self searchString ].
	
	self answer ifNil: [ self searchAccept: self searchString ].
	
	self 
		cancelled: false;
		delete! !

!ListDialogWindow methodsFor: 'actions' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self newOKButton isDefault: true. self buildBrowseButton. self newCancelButton}! !

!ListDialogWindow methodsFor: 'accessing' stamp: ''!
acceptNewEntry: aBoolean

	acceptNewEntry := aBoolean! !

!ListDialogWindow methodsFor: 'button behavior' stamp: ''!
browseBlock: aBlock

	browseBlock := aBlock! !

!ListDialogWindow methodsFor: 'instance creation' stamp: ''!
chooseFromOwner: aMorph

	self openModal.
	^ self answer! !

!ListDialogWindow methodsFor: 'row management' stamp: ''!
listChanged
	self changed: #list.! !

!ListDialogWindow methodsFor: 'open/close' stamp: ''!
initialAnswer: aString

	searchMorph content: aString.! !

!ListDialogWindow methodsFor: 'display' stamp: ''!
displayItem: anItem

	^ self displayBlock cull: anItem cull: self! !

!ListDialogWindow methodsFor: 'morphic protocol' stamp: ''!
searchAccept: aString
	self searchUpdate: aString.
	list detect: [ :item | (self displayItem: item) = aString ] ifFound: [ :item | ^ self accept: item ].
	acceptNewEntry
		ifTrue: [ ^ self accept: aString ]
		ifFalse: [ 
			list size = 1
				ifTrue: [ ^ self accept: list first ] ].
	list ifNotEmpty: [ ^ self giveFocusToList ]! !

!ListDialogWindow methodsFor: 'events' stamp: ''!
searchKeystrokeUp
	(searchMorph selectionInterval last == 0)
		ifFalse: [ ^ false ].
		
	self listIndex: list size.
	self giveFocusToList.
	^ true! !

!ListDialogWindow methodsFor: 'morphic protocol' stamp: ''!
list
	^ list! !

!ListDialogWindow methodsFor: 'accessing' stamp: ''!
searchString
	^ searchMorph searchString! !

!ListDialogWindow methodsFor: 'actions' stamp: ''!
cancel

	self answer: nil.
	super cancel! !

!ListDialogWindow methodsFor: 'display' stamp: ''!
displayBlock

	^ displayBlock! !

!ListDialogWindow methodsFor: 'button behavior' stamp: ''!
browseAction
	| aString tmp block |
	aString := searchMorph content.
	list detect: [ :item | (self displayItem: item) = aString ] ifFound: [ :item | self accept: item ].
	tmp := answer.
	block := self browseBlock.
	[ block value: tmp ] fork.
	self cancel! !

!ListDialogWindow methodsFor: 'open/close' stamp: ''!
initialExtent
	^ 300 @ 400! !

!ListDialogWindow methodsFor: 'initialization' stamp: ''!
initialize

	list := #().
	listIndex := 0.
	isResizeable := true.
	listBlock := [ :regex| #() ].
	displayBlock := [:e | e printString ].
	browseBlock :=  [:tmp | tmp browse ].
	pattern := '.' asRegexIgnoringCase.
	acceptNewEntry := false.
	
	super initialize.! !

!ListDialogWindow methodsFor: 'focus handling' stamp: ''!
defaultFocusMorph

	^ searchMorph! !

!ListDialogWindow methodsFor: 'items creation' stamp: ''!
buildSearchMorph
	^ searchMorph := SearchMorph new
			model: self;
			acceptSelector: #searchAccept:;
			updateSelector: #searchUpdate:;
			searchList: self class searchList;
			yourself.! !

!ListDialogWindow methodsFor: 'focus handling' stamp: ''!
giveFocusToSearch
	searchMorph takeKeyboardFocus.! !

!ListDialogWindow methodsFor: 'events' stamp: ''!
listKeystrokeDown
	listIndex = list size
		ifTrue: [ 
			self listIndex: 0.
			self giveFocusToSearch.
			^ true].
	^ false.! !

!ListDialogWindow methodsFor: 'morphic protocol' stamp: ''!
searchUpdate: aString

	pattern := '.' asRegexIgnoringCase.
	
	aString isEmptyOrNil ifFalse: [
		pattern := [aString asRegexIgnoringCase] on: RegexSyntaxError do: [ aString ]].
	
	self updateList.! !

!ListDialogWindow methodsFor: 'protocol' stamp: ''!
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: 'accessing' stamp: ''!
answer: anObject
	answer := anObject! !

!ListDialogWindow methodsFor: 'actions' stamp: ''!
doubleClickOk
	self listIndex ~= 0
		ifTrue: [ self ok ]! !

!ListDialogWindow methodsFor: 'focus handling' stamp: ''!
giveFocusToList
	list ifEmpty: [ ^ self giveFocusToSearch].
	
	self listIndex: (( listIndex max: 1 ) min: list size).
	listMorph takeKeyboardFocus.! !

!ListDialogWindow methodsFor: 'private' stamp: ''!
no
	"overwrite de default"! !

!ListDialogWindow methodsFor: 'accessing' stamp: ''!
acceptNewEntry

	^ acceptNewEntry! !

!ListDialogWindow methodsFor: 'button behavior' stamp: ''!
state

	^ false! !

!ListDialogWindow methodsFor: 'private' stamp: ''!
yes
	"overwrite de default"! !

!ListDialogWindow methodsFor: 'morphic protocol' stamp: ''!
updateList
	"update the displayed list in a separate thread to avoid UI blocking"
	
	"if there is already a background thread running for the new list discard it"
	listCreationProcess ifNotNil: [
		listCreationProcess terminate].
	
	"no pattern given => empty list"
	pattern ifNil: [ ^ list :=#() ].
	
	"fork off a possibly costly list calculation"
	listCreationProcess := [
		list := listBlock value: pattern.
		"make sure the ui is updated in a synchronized manner"
		self defer: [self listChanged]] fork.! !

!ListDialogWindow methodsFor: 'events' stamp: ''!
listKeystroke: event
	event keyCharacter = Character arrowUp 
		ifTrue: [ ^ self listKeystrokeUp ].
		
	event keyCharacter = Character arrowDown 
		ifTrue: [ ^ self listKeystrokeDown ].! !

!ListDialogWindow methodsFor: 'morphic protocol' stamp: ''!
listIndex: aNumber
	listIndex := aNumber.
	self answer: (list at: listIndex ifAbsent: [ nil ]).
	self changed: #listIndex.! !

!ListDialogWindow methodsFor: 'morphic protocol' stamp: ''!
listIndex
	^ listIndex! !

!ListDialogWindow methodsFor: 'protocol' stamp: ''!
accept: anItem
	self answer: anItem.
	self ok.! !

!ListDialogWindow class methodsFor: 'accessing' stamp: ''!
searchList
	^ searchList ifNil: [ searchList := OrderedCollection new ]! !

!ListDialogWindow class methodsFor: 'instance creation' stamp: ''!
chooseFromOwner: aMorph

	^ self new chooseFromOwner: aMorph! !

!ListItemWrapper commentStamp: ''!
Contributed by Bob Arning as part of the ObjectExplorer package.
!
!ListItemWrapper methodsFor: 'converting' stamp: ''!
withoutListWrapper

	^item withoutListWrapper! !

!ListItemWrapper methodsFor: 'dropping/grabbing' stamp: ''!
sendSettingMessageTo: aModel

	aModel 
		perform: (self settingSelector ifNil: [^self])
		with: self withoutListWrapper! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
highlightingColor
	^ self theme selectionColor! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
hasContents

	^self contents isEmpty not! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
setItemFromBlock: aBlock

	self setItem: aBlock value! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
balloonText

	^nil! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
setItem: anObject model: aModel

	item := anObject.
	model := aModel.! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
setItem: anObject

	item := anObject! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
settingSelector

	^nil! !

!ListItemWrapper methodsFor: 'testing' stamp: ''!
wantsDroppedObject: anotherItem

	^false! !

!ListItemWrapper methodsFor: 'testing' stamp: ''!
canBeDragged

	^true! !

!ListItemWrapper methodsFor: 'converting' stamp: ''!
asString

	^item asString! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
icon
	"Answer a form to be used as icon"
	^ nil! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
item: newItem
	item := newItem! !

!ListItemWrapper methodsFor: 'testing' stamp: ''!
handlesMouseOver: evt

	^false! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
preferredColor
	^ nil! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
contents

	^Array new! !

!ListItemWrapper methodsFor: 'testing' stamp: ''!
hasEquivalentIn: aCollection
	^ aCollection anySatisfy: [ :each | each withoutListWrapper = item withoutListWrapper ]! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
item
	"Answer the item. It is useful!!"
	
	^item! !

!ListItemWrapper methodsFor: 'accessing' stamp: ''!
model
	"Answer the model. It is useful!!"
	
	^model! !

!ListItemWrapper methodsFor: 'dropping/grabbing' stamp: ''!
acceptDroppingObject: anotherItem

	^item acceptDroppingObject: anotherItem! !

!ListItemWrapper class methodsFor: 'instance creation' stamp: ''!
with: anObject

	^self new setItem: anObject! !

!ListItemWrapper class methodsFor: 'instance creation' stamp: ''!
with: anObject model: aModel

	^self new setItem: anObject model: aModel! !

!ListPresenter commentStamp: ''!
A ListPresenter is an applicative presenter which handle a basic list.
See AbstractWidgetPresenter

self example
self example2
self example3

You can also have a look at ExampleListPresenter >> exampleRegisteredColor and ListSelectionPresenter for more examples.

I provide the following variables and their accessors
- backgroundColorBlock should convert an item in the color in the background in the line of this item.
- displayBlock should convert an item in something that can be displayed in a list, use asStringOrText by default.
- filteringBlock should convert an item in a boolean representing if the item will be displayed, initialize with self defaultFilteringBlock.
- multiSelection is a boolean representing if several items can be selected in the same time, it have shortcut beMultipleSelection and beSingleSelection.
- sortingBlock should convert two items in a boolean representing if the first item must be place before the second, initialize with self defaultSortingBlock.

Blocks should be set before items.

I provide the following methods
- items: to set the list with the elements of the collection in parameter
- getIndex is the getter of the index of the selected item or the last selected item.
- getList is the getter of the list.
- listSize is the number of items.


todo
- allowToSelect
- autoDeselect
- menu
- listItems
- clickOnSelectedItem
- getSelectionStateFor:
- listElementAt:ifAbsent:
- refresh ...
- select ... , setSelected ...
- updateList
!
!ListPresenter methodsFor: 'api' stamp: ''!
menu: aBlock
	"<api: #block getter: #menu registration: #whenMenuChanged:>"
	"Set the block used to defined the menu"
	
	menuHolder value: aBlock! !

!ListPresenter methodsFor: 'private' stamp: ''!
refreshListItems

	listItemsCache := nil.
	^ self changed: #listElementAt:! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenAutoDeselectChanged: aBlock
	"Set a block to value when the value of autoDeselect has changed"
	
	autoDeselect whenChangedDo: aBlock! !

!ListPresenter methodsFor: 'api' stamp: ''!
resetFilteringBlock
	"<api: #do>"
	"Reset the filtering block with the default value which consists in showing everything"

	filteringBlockHolder value: self defaultFilteringBlock! !

!ListPresenter methodsFor: 'private' stamp: ''!
resetListSelection
	"Reset the selection manager for multiple selection lists"
	
	multiSelectionHolder removeAll! !

!ListPresenter methodsFor: 'private' stamp: ''!
getSelectionStateFor: anIndex
	"Return the current state of the item -if selected or not - in a multiple selection list"
	"Answer true if the item at index _anIndex_ is selected"
	
	^ (multiSelectionHolder at: anIndex ifAbsent: [ ^ false ]) == true! !

!ListPresenter methodsFor: 'private' stamp: ''!
listElementAt: anIndex ifAbsent: aBlock	
	"Return the item at index _anIndex_"
	
	^ self listItems at: anIndex ifAbsent: aBlock! !

!ListPresenter methodsFor: 'private' stamp: ''!
setSelectionStateFor: anIndex at: aBoolean
	"Set the selection state of the item at index _anIndex_ in the case of multiple selection list"

	self allowToSelect ifFalse: [ ^ self ].
	^ multiSelectionHolder at: anIndex put: aBoolean! !

!ListPresenter methodsFor: 'private' stamp: ''!
selectedItemHolder

	^ selectionHolder selection! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionIndexChanged: aBlock
	"Set a block to value when the selection index has changed"
	
	selectionHolder index whenChangedDo: aBlock! !

!ListPresenter methodsFor: 'api' stamp: ''!
selectedIndexes
	"<api: #inspect>"
	"Return the indexes of selected items on the case of a multiple selection list"
	
	^ multiSelectionHolder keys select: [:index | multiSelectionHolder at: index ]! !

!ListPresenter methodsFor: 'api' stamp: ''!
sortingBlock
	"<api: #inspect>"
	"Return the ordering of the items"
	
	^ sortingBlockHolder value! !

!ListPresenter methodsFor: 'initialization' stamp: ''!
defaultFilteringBlock 
	^ [:col | col]! !

!ListPresenter methodsFor: 'initialization' stamp: ''!
registerEvents

	listHolder whenChangedDo: [ self refreshListItems ].
	filteringBlockHolder whenChangedDo: [ self refreshListItems ].
	selectionHolder index whenChangedDo: [ self changed: #getIndex ].
	multiSelection whenChangedDo: [ :b | self changed: { #setMultipleSelection: . b } ].
	wrapBlockHolder whenChangedDo:[ self changed: #listElementAt: ].
	backgroundColorBlock whenChangedDo: [ self refreshListItems ].
	autoDeselect whenChangedDo: [ :boolean | self changed: #autoDeselect: with: { boolean }].
	sortingBlockHolder
		whenChangedDo: [ 
			listHolder value: (listHolder value sorted: sortingBlockHolder value).
			self changed: #listElementAt: ].
! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenSortingBlockChanged: aBlock
	"Set a block to value when the sorting block has changed"
	
	sortingBlockHolder whenChangedDo: aBlock! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenMenuChanged: aBlock
	"Set a block to value when the menu block has changed"
	
	menuHolder whenChangedDo: aBlock! !

!ListPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self initializeValueHolders.	
	self registerEvents.

	self
		bindKeyCombination: Character space
		toAction: [ self clickOnSelectedItem ]! !

!ListPresenter methodsFor: 'api' stamp: ''!
allowToSelect: aBoolean
	"<api: #boolean getter: #allowToSelect registration: #whenAllowToSelectChanged:>"
	"Set if the list items can be selected or not"

	allowToSelect value: aBoolean.
	aBoolean 
		ifFalse: [ self resetSelection ].! !

!ListPresenter methodsFor: 'api' stamp: ''!
selectedIndex
	"<api: #inspect>"
	"Return the index of the selected item
	In the case of a multiple selection list, it returns the last selected item"

	^ self getIndex! !

!ListPresenter methodsFor: 'api' stamp: ''!
selectedItem
	"<api: #inspect>"
	"Return the selected item.
	In the case of a multiple selection list, it returns the last selected item"
	
	^ self selectedItemHolder value! !

!ListPresenter methodsFor: 'initialization' stamp: ''!
initializeValueHolders
	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.
	backgroundColorBlock := [ :item :index | self theme backgroundColor ] asValueHolder.
	autoDeselect := true asValueHolder.
	listAnnouncer := Announcer new.
! !

!ListPresenter methodsFor: 'api' stamp: ''!
backgroundColorBlock
	"<api: #inspect>"
	"Return the block use to compute the background color for each item"

	^ backgroundColorBlock value! !

!ListPresenter methodsFor: 'private' stamp: ''!
setIndex: anIndex
	"Set the index of the selected item when you click on an item"

	self allowToSelect ifFalse: [ ^ self ].
	self okToChange ifFalse: [ ^ self ].
	selectionHolder index value: anIndex.
	selectionHolder selection value: (self listElementAt: anIndex).! !

!ListPresenter methodsFor: 'api' stamp: ''!
sortingBlock: aBlock
	"<api: #block getter: #sortingBlock registration: #whenSortingBlockChanged:>"
	"To set the ordering of the items"
	
	sortingBlockHolder value: aBlock! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenFilteringBlockChanged: aBlock
	"Set a block to value when the filtering block block has changed"
	
	filteringBlockHolder whenChangedDo: aBlock! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenAllowToSelectChanged: aBlock
	"Set a block to value when the value of allowToSelect has changed"
	
	allowToSelect whenChangedDo: aBlock! !

!ListPresenter methodsFor: 'api' stamp: ''!
menu
	"<api: #inspect>"
	"Return the block used to defined the menu"
	
	^ menuHolder value! !

!ListPresenter methodsFor: 'initialization' stamp: ''!
defaultSortingBlock 
	^ [:a :b | true]! !

!ListPresenter methodsFor: 'api' stamp: ''!
backgroundColorFor: anItem at: index

	^ self backgroundColorBlock cull: anItem cull: index! !

!ListPresenter methodsFor: 'api' stamp: ''!
listItems
	"<api: #inspect>"
	"Return the items of the list. They are your domain specific items"
	
	^ listItemsCache ifNil: [ listItemsCache :=  filteringBlockHolder value value: listHolder value ]
	! !

!ListPresenter methodsFor: 'api' stamp: ''!
beSingleSelection
	"<api: #do>"
	"Make list selection single"

	self multiSelection: false! !

!ListPresenter methodsFor: 'private' stamp: ''!
wrapItem: anObject index: index
	"Return the item _anObject_ wrapped"

	^ wrapBlockHolder value cull: anObject cull: index! !

!ListPresenter methodsFor: 'api' stamp: ''!
multiSelection: aBoolean
	"<api: #boolean getter: #multiSelection registration: #whenMultiSelectionChanged:>"

	"Make the list selection become multiple if aBoolean is true.
	Otherwise set the selection as single"

	multiSelection value: aBoolean! !

!ListPresenter methodsFor: 'api' stamp: ''!
filteringBlock
	"<api: #inspect>"
	"Return the filtering of the items"
	
	^ filteringBlockHolder value! !

!ListPresenter methodsFor: 'api' stamp: ''!
getIndex
	"Return the index of the selected item"
	
	^  selectionHolder index value! !

!ListPresenter methodsFor: 'api' stamp: ''!
multiSelection
	"<api: #inspect>"
	"Return true if the list has a multiple selection.
	False if the list has a single selection"
	
	^ multiSelection value! !

!ListPresenter methodsFor: 'private' stamp: ''!
listElementAt: anIndex
	"Return the item at index _anIndex_"
	
	^ self listItems at: anIndex ifAbsent: [ nil ]! !

!ListPresenter methodsFor: 'api' stamp: ''!
selectAll
	self listItems withIndexDo: [ :each :i | self setSelectionStateFor: i at: true ].
	self changed: #listElementAt:! !

!ListPresenter methodsFor: 'api' stamp: ''!
resetSortingBlock
	"<api: #do>"
	"Reset the sortering block with the default value which consists in not sorting"

	sortingBlockHolder value: self defaultSortingBlock! !

!ListPresenter methodsFor: 'api' stamp: ''!
getList

	^ listHolder value! !

!ListPresenter methodsFor: 'private' stamp: ''!
clickOnSelectedItem
	| item |
	item := self selectedItem.
	^ (item notNil and: [ item respondsTo: #click ])
		ifTrue: [ item click ]
		ifFalse: [ false ]! !

!ListPresenter methodsFor: 'api' stamp: ''!
autoDeselect
	"<api: #inspect>"
	"Return whether the list items can be selected if it's already the selected item"
	"If true, clicking again on the selected item will unselect it"

	^ autoDeselect value! !

!ListPresenter methodsFor: 'api' stamp: ''!
beMultipleSelection
	"<api: #do>"
	"Make list selection multiple"

	self multiSelection: true! !

!ListPresenter methodsFor: 'api' stamp: ''!
displayBlock
	"<api: #inspect>"
	"Return the one argument block used to wrap your domain specific items.
	The block should return something that can be displayed in a list - like a String or a Text"
	
	^ wrapBlockHolder value! !

!ListPresenter methodsFor: 'api' stamp: ''!
selectedItemsSorted
	
	"return all the selected items sorted by their index"

	^ (multiSelectionHolder keys 
			select: [:index | multiSelectionHolder at: index ]) sort 
				collect: [:index | self listElementAt: index ]! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenBackgroundColorBlockChanged: aBlock
	"Set a block to value when the backgroundColorBlock has changed"
	
	backgroundColorBlock whenChangedDo: aBlock! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenListChanged: aBlock
	"Specify a block to value after the contents of the list has changed"
	"Basically when you set a new list of items"
	"<api: #event>"
	| block |
	block := [ :announcement :ann | 
	aBlock
		cull: announcement newValue
		cull: announcement oldValue
		cull: announcement
		cull: ann ].
	
	listAnnouncer
		when: ValueChanged
		do: block! !

!ListPresenter methodsFor: 'api' stamp: ''!
filteringBlock: aBlock
	"<api: #block getter: #filteringBlock registration: #whenFilteringBlockChanged:>"
	"To set the filtering of the items"
	
	filteringBlockHolder value: aBlock! !

!ListPresenter methodsFor: 'api' stamp: ''!
listSize
	"<api: #inspect>"
	"Return the size of the list"
	
	^ self listItems size! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectedItemChanged: aBlock
	"Set a block to value when the select item is changed"
	
	selectionHolder selection whenChangedDo: aBlock! !

!ListPresenter methodsFor: 'api' stamp: ''!
backgroundColorBlock: aBlock
	"<api: #block getter: #backgroundColorBlock registration: #whenBackgroundColorBlockChanged:>"
	"Set the block used to compute an item background"

	backgroundColorBlock value: aBlock! !

!ListPresenter methodsFor: 'api' stamp: ''!
allowToSelect
	"<api: #inspect>"
	"Return whether the list items can be selected or not"

	^ allowToSelect value! !

!ListPresenter methodsFor: 'api' stamp: ''!
autoDeselect: aBoolean
	"<api: #boolean getter: #autoDeselect registration: #whenAutoSelectChanged:>"
	"Set if the list items can be selected again"

	autoDeselect value: aBoolean! !

!ListPresenter methodsFor: 'api' stamp: ''!
resetSelection
	"<api: #do>"
	"Unselect every items"

	selectionHolder reset.
	multiSelectionHolder removeAll! !

!ListPresenter methodsFor: 'private' stamp: ''!
menu: aMenu shifted: aBoolean
	"Build the menu when you right click on an item"

	^ menuHolder value cull: aMenu cull: aBoolean! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenDisplayBlockChanged: aBlock
	"Set a block to value when the filtering block has changed"
	
	wrapBlockHolder whenChangedDo: aBlock! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionChanged: aBlock
	"Set a block to value when the selection of the list has 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.
	multiSelectionHolder whenChangedDo: aBlock.! !

!ListPresenter methodsFor: 'api' stamp: ''!
items: aList
	"Set the items of the list.
	aList is a collection of your domain specific items.
	Use a two stages notification (issue 7420)."

	"<api: #st getter: #listItems registration: #whenListChanged:>"
	| oldContents |
	oldContents := listHolder value.
	listHolder value: (aList sorted: sortingBlockHolder value).
	listAnnouncer announce: (ValueChanged oldValue: oldContents newValue: listHolder value)! !

!ListPresenter methodsFor: 'api' stamp: ''!
setSelectedIndex: anIndex
	"<api: #integer min: 0 max: #listSize getter: #selectedIndex registration: #whenSelectionIndexChanged:>"
	"Set the index of the item you want to be selected"
	| idx selection |
	
	self allowToSelect ifFalse: [ ^ self ].
	self okToChange ifFalse: [ ^ self ].
	
	idx := anIndex min: self listSize.
	selection := self 
					listElementAt: idx 
					ifAbsent: [ idx := 0.
								nil ].

	selectionHolder index value: idx.
	selectionHolder selection value: selection.! !

!ListPresenter methodsFor: 'api' stamp: ''!
selectedItems
	"<api: #inspect>"
	"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 ]! !

!ListPresenter methodsFor: 'api - events' stamp: ''!
whenMultiSelectionChanged: aBlock
	"Set a block to value when the multiSelection value has changed"
	
	multiSelection whenChangedDo: aBlock! !

!ListPresenter methodsFor: 'private' stamp: ''!
wrapItem: anObject 
	"Return the item _anObject_ wrapped"

	^ wrapBlockHolder value cull: anObject ! !

!ListPresenter methodsFor: 'api' stamp: ''!
updateList
	"<api: #do>"
	"Refresh the list"
	
	self changed: #listElementAt:.
	self resetSelection! !

!ListPresenter methodsFor: 'api' stamp: ''!
setSelectedItem: anItem
	"<api: #st getter: #selectedItem registration: #whenSelectedItemChanged:>"
	"Set the item you want to be selected"
	| index |

	self okToChange ifFalse: [ ^ self ].
	index := self listItems identityIndexOf: anItem ifAbsent: [ ^ self ].
	selectionHolder index value: index.
	selectionHolder selection value: anItem! !

!ListPresenter methodsFor: 'api' stamp: ''!
displayBlock: aBlock
	"<api: #block getter:#displayBlock registration: #whenDisplayBlockChanged:>"
	"Set the one argument block used to wrap your domain specific items.
	The block should return something that can be displayed in a list - like a String or a Text"
	
	wrapBlockHolder value: aBlock! !

!ListPresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self
		new
		openWithSpec;
		items: Smalltalk allClasses! !

!ListPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(ListAdapter
		adapt: #(model))! !

!ListPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ListAdapter! !

!ListPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'List'! !

!LiteralVariable commentStamp: ''!
I am abstract. Subclasses of me model meta objects for global variables (Class, Global, Pool), called "Literal Variables" in Smalltalk.

I am polymorphic with Association, modeling the binding of the global in either the Smalltalk globals, Undeclared or classPools. Previously I was a subclass of Associations but it leaded to many duplicated methods with other non literal variables (slots and temps).

When chaning emit* methods, do not forget to recompile exisiting code:

aGlobal usingMethods do: #recompile 

***NOTE***
When moving binding from Undeclared, we change the class of that binding to either ClassVariable or GlobalVariable.

==> when we use Global subclasses, we will either need to restrict adding variables or add a slow path where we create a new binding and update all users. But this can be done later.!
!LiteralVariable methodsFor: 'accessing' stamp: ''!
value: anObject
	value := anObject! !

!LiteralVariable methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
asCalypsoVariableOf: declarationClass
	"it is variable compatible object. Generally variable objects should have declaring class.
	Then it will be not needed and simplified"
	self isGlobalVariable ifTrue: [ ^ClyGlobalVariable on: self ]. 
	
	^ClyClassVariable on: self visibleFrom: declarationClass "scope getClass"! !

!LiteralVariable methodsFor: 'comparing' stamp: ''!
= anAssociation

	^ super = anAssociation and: [value = anAssociation value]! !

!LiteralVariable methodsFor: 'comparing' stamp: ''!
hash
	"Hash is reimplemented because = is implemented."

	^name hash! !

!LiteralVariable methodsFor: 'testing' stamp: ''!
isReadIn: aCompiledCode
	^aCompiledCode readsRef: self! !

!LiteralVariable methodsFor: 'comparing' stamp: ''!
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! !

!LiteralVariable methodsFor: 'converting' stamp: ''!
asClassVariable	
	^self! !

!LiteralVariable methodsFor: 'printing' stamp: ''!
printOn: aStream

	name printOn: aStream.
	aStream nextPutAll: '->'.
	value printOn: aStream! !

!LiteralVariable methodsFor: 'testing' stamp: ''!
analogousCodeTo: anAssociation
	^ self = anAssociation! !

!LiteralVariable methodsFor: 'testing' stamp: ''!
isGlobalClassNameBinding
	^ self value isClassOrTrait
		and: [ (name == self value name) or: [ self value isObsolete ] ]! !

!LiteralVariable methodsFor: 'testing' stamp: ''!
isSelfEvaluating
	^ self key isSelfEvaluating and: [self value isSelfEvaluating]! !

!LiteralVariable methodsFor: 'testing' stamp: ''!
isAccessedIn: aMethod 
	
	^aMethod accessesRef: self! !

!LiteralVariable methodsFor: 'accessing' stamp: ''!
name: aString 
	self key: aString asSymbol! !

!LiteralVariable methodsFor: 'debugging' stamp: ''!
write: aValue inContext: aContext
	self isWritable ifFalse: [ 
		^self error: 'Variable ' , name, ' is read only'].

	^value := aValue! !

!LiteralVariable methodsFor: 'testing' stamp: ''!
isLiteralVariable
	^true! !

!LiteralVariable methodsFor: 'printing' stamp: ''!
definitionString
	"Every subclass that adds state must redefine either this method or #printOn:"
	^ self printString! !

!LiteralVariable methodsFor: 'testing' stamp: ''!
isReferenced
	"my subclasses override this if they know better"

	^ Smalltalk globals allBehaviors anySatisfy: [ :behavior | 
		  behavior hasMethodAccessingVariable: self ]! !

!LiteralVariable methodsFor: 'queries' stamp: ''!
usingMethods
	^SystemNavigation new allReferencesToBinding: self! !

!LiteralVariable methodsFor: 'meta-object-protocol' stamp: ''!
write: anObject
	self value: anObject.
	^anObject! !

!LiteralVariable methodsFor: 'queries' stamp: ''!
definingClass
	"The class defining the variable. For Globals, return nil"
	^Smalltalk globals allClasses detect: [ :class | class hasClassVariable: self ] ifNone: [ nil ]! !

!LiteralVariable methodsFor: 'testing' stamp: ''!
isWrittenIn: aCompiledCode
	^aCompiledCode writesRef: self! !

!LiteralVariable methodsFor: 'accessing' stamp: ''!
key 
	^name! !

!LiteralVariable methodsFor: '*Calypso-SystemQueries' stamp: ''!
printAsConstantQueryItem
	^self key! !

!LiteralVariable methodsFor: 'accessing' stamp: ''!
key: aKey value: anObject 
	"Store the arguments as the variables of the receiver."

	name := aKey.
	value := anObject! !

!LiteralVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitLiteralVariableNode: aNode! !

!LiteralVariable methodsFor: 'debugging' stamp: ''!
readInContext: aContext
	^self value! !

!LiteralVariable methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!LiteralVariable methodsFor: 'class building' stamp: ''!
installingIn: aClass
	"I am called by the class builder. This way a class variable can change the class it is installed in"! !

!LiteralVariable methodsFor: 'accessing' stamp: ''!
key: anObject 
	name := anObject! !

!LiteralVariable methodsFor: 'testing' stamp: ''!
isWritable
	"Literal variables are writable, if they aren't global bindings for class names, like
 #Object -> Object "

	^ (self isGlobalVariable and: [ self isGlobalClassNameBinding ]) not! !

!LiteralVariable methodsFor: 'meta-object-protocol' stamp: ''!
read
	^self value! !

!LiteralVariable methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	aMethodBuilder
		pushLiteral: self;
		send: #read! !

!LiteralVariable methodsFor: 'code generation' stamp: ''!
emitStore: aMethodBuilder
	| tempName |
	tempName := '0TempForStackManipulation'.
	aMethodBuilder
		addTemp: tempName;
		storeTemp: tempName;
		popTop;
		pushLiteral: self;
		pushTemp: tempName;
		send: #write:! !

!LiteralVariable methodsFor: 'testing' stamp: ''!
isVariableBinding
	"Maybe we should deprecate this and use isLiteralVariable instead"
	^true! !

!LiteralVariable methodsFor: 'accessing' stamp: ''!
scope
	^self definingClass! !

!LiteralVariable methodsFor: 'printing' stamp: ''!
storeOn: aStream
	"Store in the format (key->value)"
	aStream nextPut: $(.
	name storeOn: aStream.
	aStream nextPutAll: '->'.
	value storeOn: aStream.
	aStream nextPut: $)! !

!LiteralVariable class methodsFor: 'gt-inspector-extension' stamp: ''!
gtInspectorAllVariablesIn: composite
 	"This provides a list of all defined Class or Global Variables"
 	<gtInspectorPresentationOrder: 20>
 	composite list 
 		title: 'All Defined Variables';
 		display: [ self allSubclasses sorted: #name ascending ];
 		tags: [ :each | { each package name } ];
 		when: [self == LiteralVariable  ].! !

!LiteralVariable class methodsFor: 'instance creation' stamp: ''!
key: newKey value: newValue
	"Answer an instance of me with the arguments as the key and value of 
	the association."

	^self basicNew key: newKey value: newValue! !

!LiteralVariable class methodsFor: 'instance creation' stamp: ''!
key: aKey 
	"Answer an instance of me with the argument as the lookup up."

	^self basicNew key: aKey! !

!LiteralVariableTest methodsFor: 'tests' stamp: ''!
testComparison

	| var1 var2 |
	var1 := LiteralVariable key: #var1 value: 'value1'.
	var2 := LiteralVariable key: #var1 value: 'value1' copy.
	self assert: var1 equals: var2.
	self assert: var1 hash equals: var2 hash.

	var2 value: #value2.
	self deny: var1 equals: var2.
	self deny: var1 equals: #var1 -> var1 value
! !

!LiteralVariableTest methodsFor: 'tests' stamp: ''!
testIsVariableBinding

	| var1 |
	var1 := LiteralVariable key: #var1 value: #value1.
	
	self assert: var1 isVariableBinding! !

!LiteralVariableTest methodsFor: 'tests' stamp: ''!
testLiteralEquality

	| var1 var2 |
	var1 := LiteralVariable key: #var1 value: #value1.
	self assert: (var1 literalEqual: var1).
	
	var2 := LiteralVariable key: #var1 value: #value1.
	self deny: (var1 literalEqual: var2).! !

!LoadableProject commentStamp: ''!
I represent the metadata of a loadable project.
These projects are selected by the Pharo contributors and the selected versions are guarantee to work with the current image.

This projects holds the metadata to show to the users, to recover the readme from the GitHub project and to load it using metacello.!
!LoadableProject methodsFor: 'actions' stamp: ''!
load

	Metacello new
		baseline: self baselineName;
		repository: self repositoryWithVersion;
		load: self group.! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
baselineName
	
	^ baselineName! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
summary: anObject
	summary := anObject! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
group
	^ group! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
description

	^ description ifNil: [ description := self fetchDescription ]! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
version: anObject
	version := anObject! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
repositoryWithVersion
	
	^ 'github://' , self repository , ':' , self version! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
summary
	^ summary! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!LoadableProject methodsFor: 'private' stamp: ''!
readMeUrl

	^ ('https://raw.githubusercontent.com/{1}/{2}/README.md' format: { repository. version }) asUrl! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
baselineName: aString
 
	baselineName := aString! !

!LoadableProject methodsFor: 'private' stamp: ''!
fetchDescription

	| request |
	request := ZnEasy get: self readMeUrl.
	
	^ request isError
		ifTrue: [ nil ]
		ifFalse: [ request contents ]! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
group: anObject
	group := anObject! !

!LoadableProject methodsFor: 'accessing' stamp: ''!
repository: aRepository

	repository := aRepository! !

!LoadableProject class methodsFor: 'instance creation' stamp: ''!
named: aString

	^ self new name: aString; yourself! !

!LoadableProject class methodsFor: 'instance creation' stamp: ''!
allProjects 
	
	^ { 	self new
				name: 'Microdown';
				baselineName: 'Microdown';
				repository: 'pillar-markup/Microdown';
				version: 'dev';
				group: #default;
				yourself. 
			self new 
				name: 'Beautiful Comments';
				baselineName: 'BeautifulComments';				
				repository: 'pillar-markup/BeautifulComments';
				version: 'master';
				summary: 'A nice extension of Pharo to support class comments in Microdown and nice rendering.';
				group: #default;
				yourself.
			self new 
				name: 'Serial Port Support';
				baselineName: 'SerialPort';				
				repository: 'tesonep/SerialPort';
				version: 'main';
				summary: 'An UFFI implementation of the SerialPort connection';
				group: #default;
				yourself.
			self new 
				name: 'Roassal3.0';
				baselineName: 'Roassal3';				
				repository: 'ObjectProfile/Roassal3';
				version: 'v0.9.9b';
				summary: 'Roassal3 is an agile visualization engine for Pharo 8 and Pharo 9. Roassal was created to enable interactive data visualization.';
				group: #( 'Core' 'Tests');
				yourself}! !

!LocalRecursionStopper commentStamp: ''!
The LocalRecursionStopper provides an easy way to check if we are in a recursion and execute code just once in a recursion.

LocalRecursionStopper during:  aBlock.

executes a block just once in a recursion in current process. If aBlock fork new process which call same code then LocalRecursionStopper wil not stop it. That's the difference to RecursionStopper which works globally.

A LocalRecursionStopper value is a collection of active methods which are currently called from within LocalRecrusionStopper>>#during: this means that recursion stopper can be used multiple places without one blocking the other!
!LocalRecursionStopper class methodsFor: 'api' stamp: ''!
during: aBlock
	<debuggerCompleteToSender>
	self stopMethod: thisContext sender compiledCode method during: aBlock! !

!LocalRecursionStopper class methodsFor: 'private' stamp: ''!
activeMethods
	^self value ifNil: [ self value: IdentitySet new. self value ]! !

!LocalRecursionStopper class methodsFor: 'private' stamp: ''!
stopMethod: aMethod during: aBlock

	| activeMethods |
	activeMethods := self activeMethods.
	(activeMethods includes: aMethod) ifTrue: [ ^ self ].
	
	activeMethods add: aMethod.
	
	aBlock ensure: [ activeMethods remove: aMethod ]! !

!LocalRecursionStopperTest commentStamp: ''!
SUnit tests for class  LocalRecursionStopper!
!LocalRecursionStopperTest methodsFor: 'accessing' stamp: ''!
mixedMethod

	LocalRecursionStopper during: [ 
		self assert: value equals: 0.
		value := value + 1.
		LocalRecursionStopper during: [ 
			value := value + 1.
		].
		self assert: value equals: 1.
		self mixedMethod.
		self assert: value equals: 1.		
	].
	
	LocalRecursionStopper during: [ 
		self assert: value equals: 1.
		^ 2
	].

	self assert: value equals: 1.
	^ value! !

!LocalRecursionStopperTest methodsFor: 'accessing' stamp: ''!
recursion
	
	LocalRecursionStopper during: [ self recursion ].! !

!LocalRecursionStopperTest methodsFor: 'running' stamp: ''!
tearDown

	fork ifNotNil: [ fork terminate. fork := nil ].
	super tearDown! !

!LocalRecursionStopperTest methodsFor: 'tests' stamp: ''!
testWithComplexRecursion

	self complexRecursion! !

!LocalRecursionStopperTest methodsFor: 'accessing' stamp: ''!
complexRecursion
	
	LocalRecursionStopper during: [ self complexRecursionFirstCall ].! !

!LocalRecursionStopperTest methodsFor: 'tests' stamp: ''!
testNoRecursion

	LocalRecursionStopper during: [ value := value + 1 ].

	self assert: value equals: 1! !

!LocalRecursionStopperTest methodsFor: 'accessing' stamp: ''!
complexRecursionFirstCall

	LocalRecursionStopper during: [ self complexRecursionLastCall ]! !

!LocalRecursionStopperTest methodsFor: 'tests' stamp: ''!
testWithRecursion

	self recursion! !

!LocalRecursionStopperTest methodsFor: 'accessing' stamp: ''!
complexRecursionLastCall
	
	self complexRecursion! !

!LocalRecursionStopperTest methodsFor: 'tests' stamp: ''!
testMixedMethod

	| result |

	result := self mixedMethod.
	
	self assert: result equals: 2! !

!LocalRecursionStopperTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	value := 0! !

!LocalRecursionStopperTest class methodsFor: 'running' stamp: ''!
defaultTimeLimit
	"Those tests are supposed to be fast. 
	But with broken LocalRecursionStopper they will hang the image.
	Therefore this small allowed time for tests to fail quickly if they are broken"
	^100 milliSeconds! !

!LocalTimeZone commentStamp: ''!
I am the local time zone which will use the system's current time offset dynamically.

This is the default timezone.!
!LocalTimeZone methodsFor: 'converting' stamp: ''!
asFixedTimeZone
	"Convert this dynamic timezone to one with a fixed offset."
	^ TimeZone
		offset: self offset
		name: 'Fixed Local Time'
		abbreviation: self abbreviation! !

!LocalTimeZone methodsFor: 'accessing' stamp: ''!
abbreviation
	^ String streamContents: [ :s |
		s nextPutAll: 'LT'; print: self offset hours; nextPut: $:.
		s nextPutAll: (self offset minutes printPaddedWith: $0 to: 2) ].! !

!LocalTimeZone methodsFor: 'primitives' stamp: ''!
primOffset
	"The offset from UTC in minutes, with positive offsets being towards the east.
	(San Francisco is in UTC -07*60 and Paris is in UTC +02*60 (daylight savings is not in effect)."
	<primitive:'primitiveTimezoneOffset' module: 'LocalePlugin'>
	^ 0! !

!LocalTimeZone methodsFor: 'accessing' stamp: ''!
name
	^ 'Local Time'! !

!LocalTimeZone methodsFor: 'accessing' stamp: ''!
offset
	^ self primOffset minutes! !

!LocalVariable commentStamp: ''!
I model local Variables!
!LocalVariable methodsFor: 'comparing' stamp: ''!
hash

	^ name hash bitXor: (usage hash bitXor: scope hash).! !

!LocalVariable methodsFor: 'accessing' stamp: ''!
usage

	^ usage! !

!LocalVariable methodsFor: 'debugging' stamp: ''!
write: aValue inContext: aContext

	^self writeFromContext: aContext scope: aContext astScope value: aValue! !

!LocalVariable methodsFor: 'escaping' stamp: ''!
markRepeatedWrite
	"same as write"
	self markWrite.
	usage := #repeatedWrite! !

!LocalVariable methodsFor: 'read/write usage' stamp: ''!
analyzeWrite: aVariableNode by: aSemanticAnalyzer
	super analyzeWrite: aVariableNode by: aSemanticAnalyzer.

	aSemanticAnalyzer analyzeLocalVariableWrite: self! !

!LocalVariable methodsFor: 'debugging' stamp: ''!
readFromLocalContext: aContext

	^ aContext tempAt: self index! !

!LocalVariable methodsFor: 'read/write usage' stamp: ''!
isWrite
	^ usage = #write or: [ self isRepeatedWrite ]! !

!LocalVariable methodsFor: 'debugging' stamp: ''!
writeFromLocalContext: aContext put: aValue

	^ aContext tempAt: self index put: aValue! !

!LocalVariable methodsFor: 'accessing' stamp: ''!
index: anObject
	index := anObject! !

!LocalVariable methodsFor: 'read/write usage' stamp: ''!
isRead
	^usage = #read! !

!LocalVariable methodsFor: 'testing' stamp: ''!
isLocalVariable

	^true! !

!LocalVariable methodsFor: 'escaping' stamp: ''!
isEscaping
	^escaping = #escapingRead or: [escaping = #escapingWrite]! !

!LocalVariable methodsFor: 'queries' stamp: ''!
astNodes
	^scope node methodNode variableNodes select: [ :each | each variable == self]! !

!LocalVariable methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	escaping := false.! !

!LocalVariable methodsFor: 'accessing' stamp: ''!
originalVar
	^ self! !

!LocalVariable methodsFor: 'debugging' stamp: ''!
writeFromContext: aContext scope: contextScope value: aValue

	| definitionContext |
	definitionContext := contextScope lookupDefiningContextForVariable: self startingFrom: aContext.
	^self writeFromLocalContext: definitionContext put: aValue! !

!LocalVariable methodsFor: 'read/write usage' stamp: ''!
analyzeRead: aVariableNode by: aSemanticAnalyzer
	super analyzeRead: aVariableNode by: aSemanticAnalyzer.

	aSemanticAnalyzer analyzeLocalVariableRead: self! !

!LocalVariable methodsFor: 'testing' stamp: ''!
isDefinedByBlock
	"true if a variable node is defined by a block"
	^scope isBlockScope! !

!LocalVariable methodsFor: 'debugging' stamp: ''!
readInContext: aContext

	| contextScope |
	contextScope := aContext astScope.
	^self readFromContext: aContext scope: contextScope! !

!LocalVariable methodsFor: 'escaping' stamp: ''!
escaping
	^escaping! !

!LocalVariable methodsFor: 'escaping' stamp: ''!
isEscapingWrite
	^escaping = #escapingWrite! !

!LocalVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitLocalVariableNode: aNode! !

!LocalVariable methodsFor: 'converting' stamp: ''!
asDoItVariableFrom: aContext
	^ DoItVariable fromContext: aContext variable: self! !

!LocalVariable methodsFor: 'read/write usage' stamp: ''!
markRead
	"reading does not change a #write, nor an #arg"
	usage ifNil: [usage := #read]! !

!LocalVariable methodsFor: 'accessing' stamp: ''!
usage: anObject

	usage := anObject! !

!LocalVariable methodsFor: 'read/write usage' stamp: ''!
isRepeatedWrite
	^usage = #repeatedWrite! !

!LocalVariable methodsFor: 'emitting' stamp: ''!
emitStore: methodBuilder

	methodBuilder storeTemp: name.! !

!LocalVariable methodsFor: 'converting' stamp: ''!
createCopiedVariableFor: aScope
	^ CopiedLocalVariable new
			originalVar: self originalVar;
			name: self name;
			escaping: self escaping;
			usage: self usage;
			scope: aScope! !

!LocalVariable methodsFor: 'initialization' stamp: ''!
scope: aLexicalScope

	scope := aLexicalScope! !

!LocalVariable methodsFor: 'comparing' stamp: ''!
= aTempVar

	^aTempVar class = self class 
		and: [aTempVar scope = self scope 
		and: [aTempVar name = self name
		and: [aTempVar usage = self usage]]].! !

!LocalVariable methodsFor: 'testing' stamp: ''!
isRemote
	^false! !

!LocalVariable methodsFor: 'escaping' stamp: ''!
markWrite

	"if an escaping var is wrote to later, it needs to be remote"
	self isEscaping 
		ifTrue: [self markEscapingWrite].
	"write is the strongest use: a read is turned into a write"
	usage := #write.! !

!LocalVariable methodsFor: 'escaping' stamp: ''!
markEscapingRead
	escaping = #escapingWrite ifFalse: [escaping := #escapingRead]! !

!LocalVariable methodsFor: 'testing' stamp: ''!
isUsed
	"when the var is never read or written, it is not used"
	^ usage isNotNil! !

!LocalVariable methodsFor: 'printing' stamp: ''!
printOn: stream

	stream nextPutAll: self name! !

!LocalVariable methodsFor: 'debugging' stamp: ''!
readFromContext: aContext scope: contextScope
	| definitionContext |
	definitionContext := contextScope lookupDefiningContextForVariable: self startingFrom: aContext.
	^ self readFromLocalContext: definitionContext! !

!LocalVariable methodsFor: 'read/write usage' stamp: ''!
isUninitialized

	^ self isWrite not! !

!LocalVariable methodsFor: 'testing' stamp: ''!
isAccessedIn: aMethod

	^ self isUsed and: [ aMethod == self method ]! !

!LocalVariable methodsFor: 'testing' stamp: ''!
isTempVectorTemp
	^false! !

!LocalVariable methodsFor: 'escaping' stamp: ''!
markEscapingWrite
	escaping := #escapingWrite.
	self isRepeatedWrite ifFalse: [usage := #write]! !

!LocalVariable methodsFor: 'testing' stamp: ''!
isReferenced
	^ self isUsed! !

!LocalVariable methodsFor: 'testing' stamp: ''!
isCopying
	^false! !

!LocalVariable methodsFor: 'accessing' stamp: ''!
index
	^ index ifNil: [ 
		"if the index is nil, we are in an AST after name analysis but before
		IR generation. To fill the the index, we generate the ir."
		scope node methodNode ir. 
		index ifNil: [ self error: 'no temp index, should never happen' ] ]! !

!LocalVariable methodsFor: 'testing' stamp: ''!
isStoringTempVector
	"I am a temp that stores a temp vector. Those generated temps have a invalid name starting with 0"
	^name first = $0.! !

!LocalVariable methodsFor: 'queries' stamp: ''!
method
	^scope node methodNode compiledMethod! !

!LocalVariable methodsFor: 'queries' stamp: ''!
usingMethods

	^ self isUsed ifTrue: [ { self method } ] ifFalse: [ #(  ) ]! !

!LocalVariable methodsFor: 'converting' stamp: ''!
asString

	^ self name! !

!LocalVariable methodsFor: 'escaping' stamp: ''!
isEscapingRead
	^escaping = #escapingRead! !

!LocalVariable methodsFor: 'emitting' stamp: ''!
emitValue: methodBuilder

	methodBuilder pushTemp: name.! !

!LocalVariable methodsFor: 'escaping' stamp: ''!
escaping: anObject
	escaping := anObject! !

!LocalVariable methodsFor: 'accessing' stamp: ''!
scope
	"this is the scope that the variable is declared in"
	^ scope! !

!LocalVariable class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ self = LocalVariable! !

!Locale commentStamp: ''!
Main comment stating the purpose of this class and relevant relationship to other classes.



	http://www.w3.org/WAI/ER/IG/ert/iso639.htm
	http://www.oasis-open.org/cover/iso639a.html
	See also
	http://oss.software.ibm.com/cvs/icu/~checkout~/icuhtml/design/language_code_issues.html
	http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.10
	
ISO 3166
http://mitglied.lycos.de/buran/knowhow/codes/locales/
!
!Locale methodsFor: 'accessing' stamp: ''!
isoCountry
	^self localeID isoCountry! !

!Locale methodsFor: 'system primitives' stamp: ''!
primDST
	"Returns boolean if DST  (daylight saving time) is active or not"
	<primitive:'primitiveDaylightSavings' module: 'LocalePlugin'>
	^false! !

!Locale methodsFor: 'system primitives' stamp: ''!
primCurrencySymbol
	"Returns string with currency symbol"
	<primitive: 'primitiveCurrencySymbol' module:'LocalePlugin'>
	^'$'! !

!Locale methodsFor: 'accessing' stamp: ''!
localeID
	^id! !

!Locale methodsFor: 'accessing' stamp: ''!
localeID: anID
	id := anID! !

!Locale methodsFor: 'accessing' stamp: ''!
isoLocale
	"<language>-<country>"
	^self isoCountry
		ifNil: [self isoLanguage]
		ifNotNil: [self isoLanguage , '-' , self isoCountry]! !

!Locale methodsFor: 'system primitives' stamp: ''!
primLanguage
	"returns string with language tag according to ISO 639"
	<primitive:'primitiveLanguage' module: 'LocalePlugin'>
	^'en'! !

!Locale methodsFor: 'system primitives' stamp: ''!
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."
	<primitive:'primitiveVMOffsetToUTC' module: 'LocalePlugin'>
	^0! !

!Locale methodsFor: 'system primitives' stamp: ''!
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)."
	<primitive:'primitiveTimezoneOffset' module: 'LocalePlugin'>
	^0! !

!Locale methodsFor: 'printing' stamp: ''!
printOn: aStream 
	super printOn: aStream.
	aStream nextPutAll:  '(' ; print: id ; nextPutAll:  ')'! !

!Locale methodsFor: 'system primitives' stamp: ''!
primMeasurement
	"Returns boolean denoting metric(true) or imperial(false)."
	<primitive:'primitiveMeasurementMetric' module: 'LocalePlugin'>
	^true
! !

!Locale methodsFor: 'accessing' stamp: ''!
determineLocale
	self localeID: self determineLocaleID! !

!Locale methodsFor: 'system primitives' stamp: ''!
primDecimalSymbol
	"Returns string with e.g. '.' or ','"
	<primitive:'primitiveDecimalSymbol' module: 'LocalePlugin'>
	^'.'! !

!Locale methodsFor: 'system primitives' stamp: ''!
primDigitGrouping
	"Returns string with e.g. '.' or ',' (thousands etc)"
	<primitive:'primitiveDigitGroupingSymbol' module: 'LocalePlugin'>
	^','! !

!Locale methodsFor: 'accessing' stamp: ''!
isoLanguage
	^self localeID isoLanguage! !

!Locale methodsFor: 'system primitives' stamp: ''!
primCountry
	"Returns string with country tag according to ISO 639"
	<primitive: 'primitiveCountry' module: 'LocalePlugin'>
	^'FR'! !

!Locale methodsFor: 'system primitives' stamp: ''!
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"
	<primitive:'primitiveLongDateFormat' module: 'LocalePlugin'>
	^'dddd, mmmm d, yyyy'
! !

!Locale methodsFor: 'system primitives' stamp: ''!
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)"
	<primitive:'primitiveTimeFormat' module: 'LocalePlugin'>
	^'h:mmx'
! !

!Locale methodsFor: 'system primitives' stamp: ''!
primCurrencyNotation
	"Returns boolean if symbol is pre- (true) or post-fix (false)"
	<primitive: 'primitiveCurrencyNotation' module: 'LocalePlugin'>
	^true! !

!Locale methodsFor: 'private' stamp: ''!
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 ifNotNil: [ isoLang iso2 ]! !

!Locale methodsFor: 'system primitives' stamp: ''!
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"
	<primitive:'primitiveShortDateFormat' module: 'LocalePlugin'>
	^'m/d/yy'
! !

!Locale methodsFor: 'accessing' stamp: ''!
determineLocaleID
	"Locale current determineLocaleID"
	| langCode isoLang countryCode isoCountry |
	langCode := self fetchISO2Language.
	isoLang := langCode
		ifNil: [^self localeID]
		ifNotNil: [langCode].
	countryCode := self primCountry copyUpTo: 0 asCharacter.
	isoCountry := countryCode
		ifNil: [^LocaleID isoLanguage: isoLang]
		ifNotNil: [countryCode].
	^LocaleID isoLanguage: isoLang isoCountry: isoCountry! !

!Locale class methodsFor: 'private' stamp: ''!
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: ''!
defaultLocales
	
	"return IDs of default locales"
	
	^ #(de en ja 'ja-kids' nl no sv)! !

!Locale class methodsFor: 'platform specific' stamp: ''!
defaultEncodingName: languageSymbol 
	| encodings platformName osVersion |
	platformName := Smalltalk os platformName.
	osVersion := Smalltalk os version.
	encodings := self platformEncodings at: languageSymbol
				ifAbsent: [self platformEncodings at: #default].
	encodings at: platformName ifPresent: [:encoding | ^encoding].
	encodings at: platformName , ' ' , osVersion
		ifPresent: [:encoding | ^encoding].
	^encodings at: #default! !

!Locale class methodsFor: 'initialization' stamp: ''!
initialize
	SessionManager default 
		registerSystemClassNamed: self name! !

!Locale class methodsFor: 'accessing' stamp: ''!
current

	^ Current ifNil: [ Current := self determineCurrentLocale ]! !

!Locale class methodsFor: 'accessing' stamp: ''!
languageSymbol: languageSymbol
	"Locale languageSymbol: #Deutsch"

	^self isoLanguage: (LanguageSymbols at: languageSymbol)! !

!Locale class methodsFor: 'announcing' stamp: ''!
localeAnnouncer
	^localeAnnouncer ifNil: [ localeAnnouncer := Announcer new ]! !

!Locale class methodsFor: 'accessing' stamp: ''!
localeID: id
	^self knownLocales at: id ifAbsentPut: [Locale new localeID: id]! !

!Locale class methodsFor: 'settings' stamp: ''!
activated
	^ Activated ifNil: [Activated := false]! !

!Locale class methodsFor: 'accessing' stamp: ''!
platformEncodings
	PlatformEncodings isEmptyOrNil ifTrue: [ self initializePlatformEncodings ].
	^PlatformEncodings
! !

!Locale class methodsFor: 'accessing' stamp: ''!
currentPlatform: locale during: aBlock 
	"Alter current locale during a block"
	| savedLocale |
	savedLocale := self current.
	[self switchTo: locale.
	aBlock value]
		ensure: [self switchTo: savedLocale]! !

!Locale class methodsFor: 'accessing' stamp: ''!
switchTo: locale

	| announcement |
	Current localeID = locale localeID ifTrue: [ ^ self ].
	announcement := LocaleChanged from: Current to: locale.
	Current := locale.
	self localeAnnouncer announce: announcement! !

!Locale class methodsFor: 'accessing' stamp: ''!
switchToID: localeID
	"Locale switchToID: (LocaleID isoLanguage: 'de') "

	self switchTo: (Locale localeID: localeID)! !

!Locale class methodsFor: 'accessing' stamp: ''!
isoLanguage: isoLanguage isoCountry: isoCountry
	^self localeID: (LocaleID  isoLanguage: isoLanguage isoCountry: isoCountry)! !

!Locale class methodsFor: 'private' stamp: ''!
knownLocales
	"KnownLocales := nil"
	^KnownLocales ifNil: [KnownLocales := self initKnownLocales]! !

!Locale class methodsFor: 'settings' stamp: ''!
activated: aBoolean
	Activated := aBoolean! !

!Locale class methodsFor: 'accessing' stamp: ''!
isoLanguage: isoLanguage
	^self isoLanguage: isoLanguage isoCountry: nil! !

!Locale class methodsFor: 'accessing' stamp: ''!
stringForLanguageNameIs: localeID 
	"Answer a string for a menu determining whether the given  
	symbol is the project's natural language"
	^ (self current localeID = localeID
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, localeID displayLanguage! !

!Locale class methodsFor: 'system startup' stamp: ''!
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: ''!
initKnownLocales
	| locales |
	locales := Dictionary new.

	"Init the locales for which we have translations"
	self defaultLocales do: [:id |
		locales at: id put: (self new localeID: id)].
	^locales! !

!Locale class methodsFor: 'system startup' stamp: ''!
localTimeZone
	^ LocalTimeZone new! !

!Locale class methodsFor: 'initialization' stamp: ''!
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'.
! !

!LocaleAnnouncementTest commentStamp: ''!
Unit test locale announcements!
!LocaleAnnouncementTest methodsFor: 'running' stamp: ''!
tearDown

	Locale localeAnnouncer unsubscribe: self.
	Locale classVarNamed: 'Current' put: saveCurrent.
	super tearDown! !

!LocaleAnnouncementTest methodsFor: 'events' stamp: ''!
localeWasChanged: anAnnouncement

	catchedAnnouncement := anAnnouncement ! !

!LocaleAnnouncementTest methodsFor: 'private - accessing' stamp: ''!
frenchLocale

	^ Locale isoLanguage: 'fr'! !

!LocaleAnnouncementTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	saveCurrent := Locale current.
	Locale localeAnnouncer when: LocaleChanged send: #localeWasChanged: to: self! !

!LocaleChanged commentStamp: ''!
Announce that a locale was changed!
!LocaleChanged methodsFor: 'accessing' stamp: ''!
oldLocale
	^ oldLocale! !

!LocaleChanged methodsFor: 'accessing' stamp: ''!
oldLocale: anObject
	oldLocale := anObject! !

!LocaleChanged methodsFor: 'accessing' stamp: ''!
newLocale
	^ newLocale! !

!LocaleChanged methodsFor: 'accessing' stamp: ''!
newLocale: anObject
	newLocale := anObject! !

!LocaleChanged class methodsFor: 'instance creation' stamp: ''!
from: oldLocale to: newLocale

	^(self new)
		oldLocale: oldLocale;
		newLocale: newLocale;
		yourself! !

!LocaleChangedTest commentStamp: ''!
Unit tests for LocaleChanged announcement!
!LocaleChangedTest methodsFor: 'tests' stamp: ''!
testInstanceCreation
	| instance |
	instance := LocaleChanged from: self englishLocale to: self germanLocale.
	
	self 
		assert: instance oldLocale equals: self englishLocale;
		assert: instance newLocale equals: self germanLocale 
	! !

!LocaleChangedTest methodsFor: 'private - accessing' stamp: ''!
englishLocale
	^ Locale isoLanguage: 'en'! !

!LocaleChangedTest methodsFor: 'private - accessing' stamp: ''!
germanLocale
	^ Locale isoLanguage: 'de'! !

!LocaleID commentStamp: ''!
The ID for localization!
!LocaleID methodsFor: 'accessing' stamp: ''!
isoCountry
	^isoCountry! !

!LocaleID methodsFor: 'accessing' stamp: ''!
displayLanguage
	| language |
	language := (ISOLanguageDefinition iso2LanguageTable
				at: self isoLanguage
				ifAbsent: [^ self isoLanguage]) language.
	^ self isoCountry
		ifNil: [language]
		ifNotNil: [language , ' (' , self displayCountry , ')']! !

!LocaleID methodsFor: 'comparing' stamp: ''!
= anotherObject
	self class == anotherObject class
		ifFalse: [^false].
	^self isoLanguage = anotherObject isoLanguage
		and: [self isoCountry = anotherObject isoCountry]! !

!LocaleID methodsFor: 'printing' stamp: ''!
posixName
	"(LocaleID isoString: 'es-MX') posixName"
	"(LocaleID isoString: 'es') posixName"
	"language[_territory]"
	^ self isoCountry
		ifNil: [self isoLanguage]
		ifNotNil: [self isoLanguage , '_' , self isoCountry]! !

!LocaleID methodsFor: 'comparing' stamp: ''!
hash
	^self isoLanguage hash bitXor: self isoCountry hash! !

!LocaleID methodsFor: 'testing' stamp: ''!
hasParent
	^self isoCountry notNil! !

!LocaleID methodsFor: 'accessing' stamp: ''!
isoString
	^self asString! !

!LocaleID methodsFor: 'initialize' stamp: ''!
isoLanguage: langString isoCountry: countryStringOrNil
	isoLanguage := langString.
	isoCountry := countryStringOrNil! !

!LocaleID methodsFor: 'printing' stamp: ''!
printOn: stream
	"<language>-<country>"
	stream nextPutAll: self isoLanguage.
	self isoCountry
		ifNotNil: [stream nextPut: $-; nextPutAll: self isoCountry]! !

!LocaleID methodsFor: 'accessing' stamp: ''!
parent
	^self class isoLanguage: self isoLanguage! !

!LocaleID methodsFor: 'accessing' stamp: ''!
isoLanguage
	^isoLanguage! !

!LocaleID methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' isoString: '.
	aStream nextPutAll: '''' , self printString , ''''.
	aStream nextPut: $).
! !

!LocaleID methodsFor: 'accessing' stamp: ''!
displayCountry
	^(ISOLanguageDefinition iso2Countries at: self isoCountry asUppercase ifAbsent: [ self isoCountry ]) ! !

!LocaleID class methodsFor: 'instance creation' stamp: ''!
isoString: isoString
	"Parse the isoString (<language>-<country>) 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: 'accessing' stamp: ''!
current
	^Locale current localeID! !

!LocaleID class methodsFor: 'instance creation' stamp: ''!
isoLanguage: langString isoCountry: countryStringOrNil
	^self new isoLanguage: langString isoCountry: countryStringOrNil! !

!LocaleID class methodsFor: 'accessing - defaults' stamp: ''!
default
	^ self isoLanguage: 'en'! !

!LocaleID class methodsFor: 'instance creation' stamp: ''!
isoLanguage: langString
	^self isoLanguage: langString isoCountry: nil! !

!LocaleID class methodsFor: 'instance creation' stamp: ''!
posixName: aString 
	^ self
		isoString: (aString copyReplaceAll: '_' with: '-')! !

!LocaleIDTest commentStamp: ''!
A unit test class for class LocaleID!
!LocaleIDTest methodsFor: 'tests' stamp: ''!
testComparision

	self deny: self germanLocaleID equals: self frenchLocaleID.
	self assert: self germanLocaleID equals: self germanLocaleID.	! !

!LocaleIDTest methodsFor: 'tests' stamp: ''!
testFromSingleISOString

	| locale |
	locale := LocaleID isoString: 'en'.
	self 
		assert: locale isoLanguage equals: 'en';
		assert: locale isoCountry isNil! !

!LocaleIDTest methodsFor: 'tests' stamp: ''!
testInstanceCreationWithISOLanguageAndCountry

	|locale|
	locale := LocaleID isoLanguage: 'zh' isoCountry: 'CN'.
	self 
		assert: locale isoLanguage equals: 'zh';
		assert: locale isoCountry equals: 'CN'! !

!LocaleIDTest methodsFor: 'tests' stamp: ''!
testFromISOString

	| locale |
	locale := LocaleID isoString: 'en-us'.
	self 
		assert: locale isoLanguage equals: 'en';
		assert: locale isoCountry equals: 'us'! !

!LocaleIDTest methodsFor: 'tests - test data' stamp: ''!
frenchLocaleID

	^LocaleID isoLanguage: 'fr'! !

!LocaleIDTest methodsFor: 'tests' stamp: ''!
testHashing

	self assert: self germanLocaleID hash equals: self germanLocaleID hash.
	self assert: self frenchLocaleID hash equals: self frenchLocaleID hash.	
! !

!LocaleIDTest methodsFor: 'tests - test data' stamp: ''!
germanLocaleID

	^LocaleID isoLanguage: 'de'! !

!LocaleIDTest methodsFor: 'tests' stamp: ''!
testInstanceCreationWithISOLanguage

	|germanLocale|
	germanLocale := LocaleID isoLanguage: 'de'.
	self assert: germanLocale isoLanguage equals: 'de'! !

!LocaleIDTest methodsFor: 'tests' stamp: ''!
testPosixNameConversion

	| locale |
	locale := LocaleID posixName: 'en_us'.
	self 
		assert: locale isoLanguage equals: 'en';
		assert: locale isoCountry equals: 'us'! !

!LocaleIDTest methodsFor: 'tests' stamp: ''!
testPrintString

	| locale |
	locale := LocaleID isoString: 'en-us'.	
	self assert: locale printString equals: 'en-us'
! !

!LocaleTest commentStamp: ''!
A unit test class for class Locale!
!LocaleTest methodsFor: 'tests' stamp: ''!
testCurrent

	self assert: Locale current notNil
	! !

!LockableTabMorph commentStamp: ''!
I am a tab which can be locked/unlocked with according action and icon!
!LockableTabMorph methodsFor: 'private' stamp: ''!
setLockedIcon

	closeIcon image: self class lockedIcon.! !

!LockableTabMorph methodsFor: 'accessing' stamp: ''!
closeable: anObject

	closeable := anObject.
	anObject 
		ifTrue: [ self setUnlockedIcon ]
		ifFalse: [ self setLockedIcon ]! !

!LockableTabMorph methodsFor: 'private' stamp: ''!
setUnlockedIcon

	closeIcon image: self class closeIcon.! !

!LockableTabMorph methodsFor: 'protocol' stamp: ''!
showCloseIcon

	closeIcon show! !

!LockableTabMorph class methodsFor: 'icons' stamp: ''!
lockedIcon

	^ Icons
		at: #lockedIcon
		ifAbsentPut: [ self lockedIconContents ]! !

!LockableTabMorph class methodsFor: 'icons - contents' stamp: ''!
lockedIconContents

	^ Form
		extent: 12@12
		depth: 32
		fromArray: #(0 0 0 807082779 3175894092 4235885178 4235885178 3159116876 807082779 0 0 0 0 0 1107296256 4286545791 4290164406 3801519766 3801519766 4290230199 4286545791 1107296256 0 0 0 0 3578020932 4290295992 2284991026 335741699 335741699 2285122612 4290361785 3578020932 0 0 0 301989888 3899288170 4019755160 738197504 0 0 738197504 4019228816 3900011893 301989888 0 33554432 1478500384 4100746348 4137458844 2436709693 2035898713 2035898713 2436907072 4135814019 4102325380 1478171419 33554432 234881024 3429723501 4291611852 4292532954 4292072403 4292072403 4292072403 4292072403 4292401368 4291809231 3429723501 234881024 251658240 3480120942 4291546059 4292138196 4292269782 4292006610 4292006610 4292269782 4292138196 4291546059 3480120942 251658240 251658240 3479857770 4290559164 4291217094 4291743438 4285493103 4285493103 4291743438 4291282887 4290559164 3479857770 251658240 251658240 3479726184 4290098613 4290756543 4291151301 4286743170 4286743170 4291151301 4290756543 4290230199 3479726184 251658240 251658240 3479660391 4289967027 4290624957 4290822336 4289703855 4289703855 4290822336 4290624957 4290032820 3479726184 251658240 268435456 3530057832 4290230199 4290888129 4290888129 4291019715 4291019715 4290888129 4290888129 4290230199 3530123625 268435456 150994944 2939631415 4283979864 4284308829 4284374622 4284374622 4284374622 4284374622 4284308829 4284045657 2939697208 150994944)
		offset: 0@0! !

!LogDebugger commentStamp: ''!
I am an abstract class defining the behavior of debugger that will log the error.!
!LogDebugger class methodsFor: 'opening api' stamp: ''!
messageToPrintFrom: aDebugSession
	^ String
		streamContents: [ :s | 
			s
				<< 'ERROR. Here is the stack:';
				<< OSPlatform current lineEnding.
			aDebugSession interruptedContext shortDebugStackOn: s ]! !

!LogDebugger class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = LogDebugger! !

!LogicalFont commentStamp: ''!
I describe a font.!
!LogicalFont methodsFor: 'testing' stamp: ''!
isBoldOrBolder
	^(weightValue ifNil:[400]) >= 700! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
weightValue
	"Answer the value of weightValue"

	^ weightValue ifNil: [ weightValue := 400 ]! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
isTTCFont
	^self realFont isTTCFont! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray

	^ self realFont
		  widthAndKernedWidthOfLeft: leftCharacter
		  right: rightCharacterOrNil
		  into: aTwoElementArray! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
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: '*System-Settings-Browser' stamp: ''!
withSizeIncrementedBy: anInteger
	^ self class 
		familyName: self familyName 
		fallbackFamilyNames: self fallbackFamilyNames
		pointSize: self pointSize + anInteger
		stretchValue: self stretchValue
		weightValue: self weightValue
		slantValue: self slantValue ! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
pointSize: aNumber
	pointSize := aNumber! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
displayStrikeoutOn: aGrafPort from: aPoint to: aPoint3 
	^self realFont displayStrikeoutOn: aGrafPort from: aPoint to: aPoint3! !

!LogicalFont methodsFor: 'testing' stamp: ''!
isItalicOrOblique
	slantValue ifNil:[slantValue := 0].
	^slantValue = 1 or:[slantValue = 2]! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
ascent
	^self realFont ascent! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
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: 'private' stamp: ''!
findRealFont
	"for now just get a strike"
	"^((TextStyle named: StrikeFont defaultFontKey) fontOfPointSize: pointSize)
		emphasized: emphasis"
	^LogicalFontManager current bestFontFor: self! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
descent
	^self realFont descent! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
familyName: aString
	familyName := aString! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
stretchValue
	"Answer the value of stretchValue"

	^ stretchValue ifNil:[stretchValue := 5]! !

!LogicalFont methodsFor: 'metrics' stamp: ''!
underlineThickness

	^ self realFont underlineThickness! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
slantValue
	"Answer the value of slantValue"

	^ slantValue ifNil:[slantValue := 0]! !

!LogicalFont methodsFor: 'testing' stamp: ''!
isItalic
	^self isItalicOrOblique! !

!LogicalFont methodsFor: 'initialization' stamp: ''!
initialize: aFont

	familyName := aFont familyName.
	emphasis := aFont emphasis.! !

!LogicalFont methodsFor: '*Athens-Text' stamp: ''!
getPreciseHeight
	^ self realFont getPreciseHeight! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
setEmphasis: code

	emphasis := code! !

!LogicalFont methodsFor: '*Athens-Text' stamp: ''!
getPreciseDescent
	^ self realFont getPreciseDescent! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
linearWidthOf: aCharacter
	^self realFont linearWidthOf: aCharacter! !

!LogicalFont methodsFor: '*System-Settings-Browser' stamp: ''!
acceptSettings: aVisitor
	^ aVisitor visitLogicalFont: self! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
hasGlyphsForAll: asciiString
	
	^self realFont hasGlyphsForAll: asciiString! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
height
	^self realFont height! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
characterToGlyphMap
	"Provided only for accelerating text scanning thru primitive 103 - see super."
	^self realFont characterToGlyphMap! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
xTable
	"Provided only for accelerating text scanning thru primitive 103 - see super."

	^ self realFont xTable! !

!LogicalFont methodsFor: 'testing' stamp: ''!
isRegular
	^emphasis = 0! !

!LogicalFont methodsFor: '*Athens-Text' stamp: ''!
getPreciseAscent
	^ self realFont getPreciseAscent! !

!LogicalFont methodsFor: 'testing' stamp: ''!
isBold
	^self isBoldOrBolder! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
widthOfString: aString

	^ self realFont widthOfString: aString! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
slantValue: anObject
	"Set the value of slantValue"

	slantValue := anObject! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
hasDistinctGlyphsForAll: asciiString
	
	^self realFont hasDistinctGlyphsForAll: asciiString! !

!LogicalFont methodsFor: 'derivatives' stamp: ''!
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: 'accessing' stamp: ''!
fallbackFamilyNames: aSequencableCollection
	fallbackFamilyNames := aSequencableCollection! !

!LogicalFont methodsFor: 'derivatives' stamp: ''!
derivativeFonts

	derivatives ifNil: [^ #()].
	^derivatives copyWithout: nil! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
forceNotItalic
	"leave oblique style in place"
	slantValue = 1 ifTrue:[slantValue := 0].! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
familySizeFace
	"should have default in AbstractFont"
	^{self familyName. self pointSize. self emphasis}! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
fallbackFamilyNames
	^fallbackFamilyNames! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
installOn: a foregroundColor: b backgroundColor: c
	^self realFont installOn: a foregroundColor: b backgroundColor: c! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
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: ''!
isSymbolFont
	
	^self realFont isSymbolFont! !

!LogicalFont methodsFor: 'emphasis' stamp: ''!
emphasisString
	^AbstractFont emphasisStringFor: emphasis! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
familyNames
	"Answer an array containing the receiver's familyName
	followed by any fallbackFamilyNames"
	|answer|
	answer := {familyName}.
	fallbackFamilyNames ifNotNil:[
		answer := answer, fallbackFamilyNames].
	^answer! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
widthOfString: aString from: startIndex to: stopIndex

	^ self realFont widthOfString: aString from: startIndex to: stopIndex! !

!LogicalFont methodsFor: 'emphasis' stamp: ''!
emphasis: code
	
	^self emphasized: code! !

!LogicalFont methodsFor: 'glyph lookup' stamp: ''!
characterRenderingOptimizedFormAt: aCharacter
	^ self realFont characterRenderingOptimizedFormAt: aCharacter! !

!LogicalFont methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		cr;
		nextPutAll: ' familyName: ';
		print: familyName ;
		cr;
		nextPutAll: ' emphasis: ';
		print: emphasis ;
		cr;
		nextPutAll: ' pointSize: ';
		print: pointSize ;
		cr;
		nextPutAll: ' realFont: ';
		print: realFont ;
		nextPutAll: ' weight: ';
		print: weightValue ;
		nextPutAll: ' stretch: ';
		print: stretchValue ;
		nextPutAll: ' slant: ';
		print: slantValue! !

!LogicalFont methodsFor: '*Text-Scanning' stamp: ''!
scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX
	"scan a multibyte character string"
	^self realFont scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX! !

!LogicalFont methodsFor: 'emphasis' stamp: ''!
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 ].
	newWeight := (validCode anyMask: self class squeakWeightBold)
		ifTrue: [ self class weightBold max: weightValue ]
		ifFalse: [ weightValue ].
	newSlant := ((validCode anyMask: self class squeakSlantItalic) and: [ self isItalicOrOblique not ])
		ifTrue: [ self class slantItalic ]
		ifFalse: [ 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: 'derivatives' stamp: ''!
derivativeFontsAt: index put: aFont

	derivatives ifNil:[derivatives := Array new: 32].
	derivatives at: index put: aFont! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
forceBold
	weightValue := (self weightValue max: 700).! !

!LogicalFont methodsFor: 'testing' stamp: ''!
hasSubPixelAntiAliasing
	^ self realFont hasSubPixelAntiAliasing! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
forceNotBold
	"anything other than bold (700) is not changed.
	we only remove boldness that can be put back with 
	a TextAttribute bold."
	
	self weightValue = 700 
		ifTrue:[weightValue := 400].! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
displayUnderlineOn: aGrafPort from: aPoint to: aPoint3 
	^self realFont displayUnderlineOn: aGrafPort from: aPoint to: aPoint3! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
forceItalicOrOblique
	self slantValue = 0 ifTrue:[slantValue := 1]! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
lineGrid

	^realFont lineGrid! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
realFont
	realFont ifNil:[ realFont := self findRealFont ].
	realFont validate.
	^ realFont! !

!LogicalFont methodsFor: 'metrics' stamp: ''!
underlineTop

	^ self realFont underlineTop! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
maxAscii
	"???
	what to do if realFont happens to be a StrikeFontSet?"
	^SmallInteger maxVal! !

!LogicalFont methodsFor: '*Athens-Text' stamp: ''!
getGlyphWidth: aCharacter 
	^ self realFont getGlyphWidth: aCharacter! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
stretchValue: anObject
	"Set the value of stretchValue"

	stretchValue := anObject! !

!LogicalFont methodsFor: '*Athens-Text' stamp: ''!
glyphRendererOn: anAthensBalloonSurface 
	^ self realFont glyphRendererOn: anAthensBalloonSurface! !

!LogicalFont methodsFor: '*Text-Scanning' stamp: ''!
scanByteCharactersFrom: startIndex to: stopIndex in: aByteString with: aCharacterScanner rightX: rightX
	"scan a single byte character string"
	^self realFont scanByteCharactersFrom: startIndex to: stopIndex in: aByteString with: aCharacterScanner rightX: rightX! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
clearRealFont
	realFont := nil! !

!LogicalFont methodsFor: 'emphasis' stamp: ''!
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: 'metrics' stamp: ''!
strikeoutThickness

	^ self realFont strikeoutThickness! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
fontArray
	| real | 
	real := self realFont.
	^real isFontSet 
		ifTrue: [real fontArray] 
		ifFalse: [{self}]! !

!LogicalFont methodsFor: '*Athens-Text' stamp: ''!
asFreetypeFont
	^ self realFont asFreetypeFont! !

!LogicalFont methodsFor: 'derivatives' stamp: ''!
derivativeFont: newFont mainFont: ignore
	self derivativeFont: newFont! !

!LogicalFont methodsFor: 'metrics' stamp: ''!
strikeoutTop

	^ self realFont strikeoutTop! !

!LogicalFont methodsFor: '*System-Settings-Browser' stamp: ''!
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: 'forwarded to realFont' stamp: ''!
descentKern
	^self realFont descentKern! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
baseKern
	^self realFont baseKern! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
weightValue: anObject
	"Set the value of weightValue"

	weightValue := anObject! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
familyName
	^familyName! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
characterFormAt: aCharacter
	^self realFont characterFormAt: aCharacter! !

!LogicalFont methodsFor: 'accessing' stamp: ''!
pointSize
	^pointSize! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
widthOf: anObject

	^ self realFont widthOf: anObject! !

!LogicalFont methodsFor: 'printing' stamp: ''!
storeOn: aStream

	aStream 
		nextPutAll: 'LogicalFont';
		nextPutAll: '
		familyName: '; 
		print: self familyName  ;
		nextPutAll: '
		pointSize: '; 
		print: self pointSize ;
		nextPutAll: '
		stretchValue: '; 
		print: self stretchValue ;
		nextPutAll: '
		weightValue: '; 
		print: self weightValue ;
		nextPutAll: '
		slantValue: '; 
		print: self slantValue.! !

!LogicalFont methodsFor: 'forwarded to realFont' stamp: ''!
kerningLeft: leftChar right: rightChar
	^self realFont kerningLeft: leftChar right: rightChar! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightBlack

	^ 900! !

!LogicalFont class methodsFor: 'instance creation' stamp: ''!
new

	^ self all add: super new! !

!LogicalFont class methodsFor: 'instance creation' stamp: ''!
familyName: familyName fallbackFamilyNames: fallbackFamilyNames pointSize: pointSize

	^ self
		  familyName: familyName
		  fallbackFamilyNames: fallbackFamilyNames
		  pointSize: pointSize
		  stretchValue: 5
		  weightValue: 400
		  slantValue: 0! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantNormal

	^ 0! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchExtraCondensed

	^ 2! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchUltraCondensed

	^ 1! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchExtraCompressed

	^ 1! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchCondensed

	^ 3! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchUltraExtended

	^ 9! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightUltraBold

	^ 800! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightLight

	^ 300! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantKursiv

	^ 1! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
squeakSlantItalic

	^ 2! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchNarrow

	^ 4! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightNord

	^ 900! !

!LogicalFont class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default
		registerGuiClassNamed: self name! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantBook

	^ 0! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchExpanded

	^ 7! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightBold

	^ 700! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightExtraThin

	^ 100! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightHeavy

	^ 900! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
squeakWeightBold

	^ 1! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantItalic

	^ 1! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchCompressed

	^ 2! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchSemiExpanded

	^ 6! !

!LogicalFont class methodsFor: 'accessing' stamp: ''!
all
	^all ifNil:[
		all := WeakSet new
			addAll: self allInstances;
			yourself]! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightExtraBlack

	^ 950! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightSemiBold

	^ 600! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchUltraCompressed

	^ 1! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightUltraLight
	^200! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchRegular

	^ 5! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchExtended

	^ 7! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightExtraBold

	^ 800! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantRegular

	^ 0! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantUpright

	^ 0! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchUltraExpanded

	^ 9! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantCursive

	^ 1! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightMedium

	^ 500! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
squeakStretchCondensed

	^ 8! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchSemiCondensed

	^ 4! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightUltraThin

	^ 100! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantRoman

	^ 0! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantInclined

	^ 2! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightUltraBlack

	^ 950! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchExtraExtended

	^ 8! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightUltra

	^ 800! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantBackslanted

	^ 2! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchExtraExpanded

	^ 8! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightRegular

	^ 400! !

!LogicalFont class methodsFor: 'system startup' stamp: ''!
shutDown: quitting

	self allSubInstances do: [ :i | i clearRealFont ]! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightDemi

	^ 600! !

!LogicalFont class methodsFor: 'instance creation' stamp: ''!
familyName: familyName pointSize: pointSize stretchValue: stretch weightValue: weight slantValue: slant

	^ self
		  familyName: familyName
		  fallbackFamilyNames: nil
		  pointSize: pointSize
		  stretchValue: stretch
		  weightValue: weight
		  slantValue: slant! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightThin

	^ 100! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchCompact

	^ 4! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightDemiBold

	^ 600! !

!LogicalFont class methodsFor: 'instance creation' stamp: ''!
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: ''!
familyName: familyName pointSize: pointSize

	^ self
		  familyName: familyName
		  fallbackFamilyNames: nil
		  pointSize: pointSize
		  stretchValue: 5
		  weightValue: 400
		  slantValue: 0! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantOblique

	^ 2! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchWide

	^ 6! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
stretchSemiExtended

	^ 6! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
weightExtraLight

	^ 200! !

!LogicalFont class methodsFor: 'emphasis values' stamp: ''!
slantSlanted

	^ 2! !

!LogicalFontManager commentStamp: ''!
I reference all font families available in the  system.

For example:

LogicalFontManager current allFamilies.

FreeTypeFontSelectorDialogWindow new open.
!
!LogicalFontManager methodsFor: 'accessing' stamp: ''!
addFontProvider: aFontProvider

	fontProviders addLast: aFontProvider! !

!LogicalFontManager methodsFor: 'font lookup' stamp: ''!
bestFontFor: aLogicalFont
	"look up best font from the receivers fontProviders"
	
	^self bestFontFor: aLogicalFont whenFindingAlternativeIgnoreAll: Set new! !

!LogicalFontManager methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	fontProviders := OrderedCollection new: 10! !

!LogicalFontManager methodsFor: 'font lookup' stamp: ''!
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: 'font families' stamp: ''!
allFamilies
	"answer an Array containing all the font families from the receiver's fontProviders,
	together with any TextStyle font families, sorted by family name"

	| answer textStyleFamilies |
	answer := Set new.
	fontProviders do: [ :each | answer addAll: each families ].
	textStyleFamilies := TextStyle knownTextStylesWithoutDefault
		collect: [ :textStyleName | 
			TextStyleAsFontFamily new
				textStyle: (TextStyle named: textStyleName);
				familyName: textStyleName;
				yourself ].	"reject any textStyles whose defaultFont also appears as a fontFamily"
	textStyleFamilies := textStyleFamilies
		reject: [ :textStyleFamily | 
			| textStyleFamilyName |
			textStyleFamilyName := textStyleFamily textStyle defaultFont familyName.
			answer anySatisfy: [ :fontFamily | fontFamily familyName = textStyleFamilyName ] ].
	answer addAll: textStyleFamilies.
	^ (answer asSortedCollection: [ :a :b | a familyName <= b familyName ]) asArray! !

!LogicalFontManager methodsFor: '*Fonts-Infrastructure-Tests' stamp: ''!
identityIncludesFontProvider: aFreeTypeFontProvider 
	^ fontProviders identityIncludes: aFreeTypeFontProvider! !

!LogicalFontManager class methodsFor: 'accessing' stamp: ''!
current
 	
	^current ifNil: [current := self defaultCurrent ]! !

!LogicalFontManager class methodsFor: 'instance creation' stamp: ''!
defaultCurrent
	^self new! !

!LogicalFontManager class methodsFor: 'accessing' stamp: ''!
unload
	current ifNotNil: [current initialize].
	current := nil.! !

!LogicalFontManager class methodsFor: 'class initialization' stamp: ''!
reset

	current := nil! !

!LogicalFontManagerTest commentStamp: ''!
A LogicalFontManagerTest is a test class for testing the behavior of LogicalFontManager!
!LogicalFontManagerTest methodsFor: 'tests' stamp: ''!
testHasCurrentFreeTypeFontProvider
	"If it fails, LogicalFontManager unload should be called."
	self assert: (LogicalFontManager current identityIncludesFontProvider: self currentProviderOrError)! !

!LogicalFontManagerTest methodsFor: 'accessing' stamp: ''!
currentProviderOrError
	| provider |
	provider := FreeTypeFontProvider readSlotNamed: #current.
	self assert: provider notNil.
	^ provider! !

!LogicalFontStoredSetting commentStamp: ''!
I am responsible for storing information about LogicalFont objects.!
!LogicalFontStoredSetting methodsFor: 'accessing' stamp: ''!
weightValue
	^ weightValue! !

!LogicalFontStoredSetting methodsFor: 'accessing' stamp: ''!
fallbackFamilyNames
	^ fallbackFamilyNames! !

!LogicalFontStoredSetting methodsFor: 'accessing' stamp: ''!
stretchValue: anInteger 
	stretchValue := anInteger! !

!LogicalFontStoredSetting methodsFor: 'accessing' stamp: ''!
stretchValue
	^ stretchValue! !

!LogicalFontStoredSetting methodsFor: 'accessing' stamp: ''!
weightValue: anInteger 
	weightValue := anInteger ! !

!LogicalFontStoredSetting methodsFor: 'accessing' stamp: ''!
slantValue
	^ slantValue! !

!LogicalFontStoredSetting methodsFor: 'accessing' stamp: ''!
realValue
	^ (self class environment at: self fontClassName)
				familyName: self familyName 
				fallbackFamilyNames: self fallbackFamilyNames 
				pointSize: self pointSize 
				stretchValue: self stretchValue
				weightValue: self weightValue 
				slantValue: self slantValue! !

!LogicalFontStoredSetting methodsFor: 'accessing' stamp: ''!
slantValue: anInteger 
	slantValue := anInteger ! !

!LogicalFontStoredSetting methodsFor: 'accessing' stamp: ''!
fallbackFamilyNames: aCollectionOrNil 
	fallbackFamilyNames := aCollectionOrNil ! !

!LoginFailedException commentStamp: ''!
Exception for signaling login failures of protocol clients.
!
!LoginFailedException methodsFor: 'exceptiondescription' stamp: ''!
isResumable
	"Resumable so we can give the user another chance to login"

	^true! !

!LongMessageDialogWindow commentStamp: ''!
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: 'building' stamp: ''!
newContentMorph
	"Answer a new content morph."

	self iconMorph: self newIconMorph.
	self textMorph: self newTextMorph.
	^self newGroupboxFor: (
		(self newRow: {self iconMorph. self textMorph})
			cellPositioning: #top;
			vResizing: #spaceFill)! !

!LongMessageDialogWindow methodsFor: 'accessing' stamp: ''!
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: 'building' stamp: ''!
newTextMorph
	"Answer a new text editor morph."

	|tm|
	tm := (self
		newTextEditorFor: self
		getText: #entryText
		setText: #entryText:
		getEnabled: nil)
			beForPlainText;
			minWidth: Display width // 4;
			minHeight: Display height // 4;
			beReadOnly.
	^tm! !

!LongMessageDialogWindow methodsFor: 'accessing' stamp: ''!
entryText
	"Answer the value of entryText"

	^ entryText! !

!LongMessageDialogWindow methodsFor: 'accessing' stamp: ''!
entryText: anObject
	"Set the value of entryText"

	entryText := anObject.
	self changed: #entryText! !

!LongMessageDialogWindow methodsFor: 'testing' stamp: ''!
isResizeable
	"Answer whether we are not we can be resized."

	^true! !

!LookupKey commentStamp: ''!
I represent a key for looking up entries in a data structure. Subclasses of me, such as Association, typically represent dictionary entries.!
!LookupKey methodsFor: 'testing' stamp: ''!
< aLookupKey 
	"Refer to the comment in Magnitude|<."

	^key < aLookupKey key! !

!LookupKey methodsFor: 'comparing' stamp: ''!
= aLookupKey
	^ self species = aLookupKey species
		ifTrue: [ key = aLookupKey key ]
		ifFalse: [ false ]! !

!LookupKey methodsFor: 'accessing' stamp: ''!
name

	^ self key isString
		ifTrue: [self key]
		ifFalse: [self key printString]! !

!LookupKey methodsFor: 'comparing' stamp: ''!
hash
	"Hash is reimplemented because = is implemented."

	^key hash! !

!LookupKey methodsFor: 'accessing' stamp: ''!
key
	"Answer the lookup key of the receiver."

	^key! !

!LookupKey methodsFor: 'accessing' stamp: ''!
key: anObject 
	"Store the argument, anObject, as the lookup key of the receiver."

	key := anObject! !

!LookupKey methodsFor: 'printing' stamp: ''!
printOn: aStream

	key printOn: aStream! !

!LookupKey class methodsFor: 'instance creation' stamp: ''!
key: aKey 
	"Answer an instance of me with the argument as the lookup up."

	^self basicNew key: aKey! !

!LucidaGrandeRegular commentStamp: ''!
I'm a stub to load Lucida Grande font in system. 
As is, it works just for macs, but the idea is to use it for showing shortcut symbols... which has sense just un mac :)!
!LucidaGrandeRegular class methodsFor: 'accessing' stamp: ''!
fontContents
	^ self fontReference 
		binaryReadStreamDo: [ :stream | stream contents ]! !

!LucidaGrandeRegular class methodsFor: 'class initialization' stamp: ''!
initialize 
	self canBeInstalled 
		ifTrue: [ EmbeddedFreeTypeFontInstaller registerFont: self ]! !

!LucidaGrandeRegular class methodsFor: 'accessing' stamp: ''!
fontDirectory
	"Lucida Grande comes in mac system, at that directory. 
	 Not happy with the hardcoding, but it should not change"
	^ '/System/Library/Fonts' asFileReference! !

!LucidaGrandeRegular class methodsFor: 'accessing' stamp: ''!
originalFileName
	^ 'LucidaGrande.ttc'! !

!LucidaGrandeRegular class methodsFor: 'testing' stamp: ''!
canBeInstalled 
	"This font can be installed just in Macs *and* if font exists"
	^ OSPlatform current isMacOS and: [ self fontReference exists ]! !

!LucidaGrandeRegular class methodsFor: 'accessing' stamp: ''!
fontReference 
	^ self fontDirectory / self originalFileName! !

!LzwGifDecoder commentStamp: ''!
I implement the modified Lempel-Ziv-Welch (LZW) algorithm for lossless GIF decompression. My primary purpose is to decode streams of bytes that have been encoded with this modified version of LZW as used in the GIF standard.

My instances require, at minimum, a maximum code size (via #maxCode:), a minimum code size (via #minimumCodeSize:), and of course a stream of bytes to decode (via #codeStream:). Once these are set, implementors can simply send the #decode message, which will respond with a decoded ByteArray.

Optionally, implementors can make use of the #onDecodedBit: message, which takes a Block with a single argument corresponding to a decoded bit. This Block is called each time a complete byte/bit-level value for the bitmap has been decoded.

For an example of use, see GIFReadWriter >> #readBitDataOnFrame:.

I am separated out from GIFReadWriter for clarity and better debugging.



See:
https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch
https://www.w3.org/Graphics/GIF/spec-gif89a.txt

!
!LzwGifDecoder methodsFor: 'api' stamp: ''!
decode
	| currentCode prevCode outStream |
	self initializeTables.
	outStream := WriteStream with: (ByteArray new).
	numLeftoverBits := 0.
	currentCode := self nextCode.
	currentCode = clearCode ifFalse: [ ^ self error: 'First code on the stream should always be the clear code!!' ].
	
	"The first real code simply gets output
	onto the stream, then we enter the loop"
	currentCode := self nextCode.
	self writeBit: currentCode on: outStream.
	prevCode := currentCode.
	currentCode := self nextCode.
	[ currentCode = eoiCode ] whileFalse: [ 
		currentCode = clearCode
			ifTrue: [ 
				self initializeTables.
				currentCode := self nextCode.
				self
					writeBit: (suffixTable at: (currentCode + 1))
					on: outStream.
				prevCode := nil ]
			ifFalse: [ self handleCode: currentCode withPreviousCode: prevCode on: outStream ].
		prevCode := currentCode.
		currentCode := self nextCode ].
	^ outStream contents.! !

!LzwGifDecoder methodsFor: 'accessing' stamp: ''!
maxCode: anInteger 
	maxCode := anInteger! !

!LzwGifDecoder methodsFor: 'accessing' stamp: ''!
onDecodedBit: aBlock
	"This block will be executed once each time a new
	value is decoded from the stream, with the value
	as the sole argument passed to the block"
	outBlock := aBlock! !

!LzwGifDecoder methodsFor: 'private - packing' stamp: ''!
nextByte
	| nextChunkSize |
	codeStreamBuffer atEnd
		ifTrue: [ 
			nextChunkSize := codeStream next.
			nextChunkSize = 0 ifTrue: [ ^ self error: 'Next chunk size was 0!!' ].
			codeStreamBuffer := (codeStream next: nextChunkSize) readStream ].
	^ codeStreamBuffer next.! !

!LzwGifDecoder methodsFor: 'writing' stamp: ''!
writeBit: anInteger on: aWriteStream
	"Write the incoming decoded value onto a
	writestream. If I have an outBlock set, 
	send this value also"
	aWriteStream nextPut: anInteger.
	outBlock ifNil: [ ^ self ].
	outBlock value: anInteger.! !

!LzwGifDecoder methodsFor: 'private - packing' stamp: ''!
peekByte
	| nextChunkSize |
	codeStreamBuffer atEnd
		ifTrue: [ 
			nextChunkSize := codeStream next.
			nextChunkSize = 0 ifTrue: [ ^ self error: 'Next chunk size is 0!!' ].
			codeStreamBuffer := (codeStream next: nextChunkSize) readStream ].
	^ codeStreamBuffer peek.! !

!LzwGifDecoder methodsFor: 'private' stamp: ''!
codeStream: aReadableStream 
	"Set the stream of encoded bytes we will decode
	to be the internal codeStream. We read off the first
	byte immediately, which tells us how many subsequent bytes
	to use in our buffer for decoding"
	| chunkSize |
	codeStream := aReadableStream.
	chunkSize := codeStream next.
	codeStreamBuffer := ReadStream on: (codeStream next: chunkSize).! !

!LzwGifDecoder methodsFor: 'private' stamp: ''!
checkCodeSize
	"Ensure that the next available code to enter
	into the table is not equal to the bitMask.
	If it is, we increment the code size and update the
	mask value."
	nextAvailableCode := nextAvailableCode + 1.
	(nextAvailableCode bitAnd: bitMask) = 0
		ifTrue: [ 
			"GIF89a specifies a 'deferred' clearCode
			implementation, which means we keep going
			with the current table even if its full but
			a clear hasn't been found. We use the max
			code size at that point."
			nextAvailableCode >= maxCode ifTrue: [ ^ self ].
			codeSize := codeSize + 1.
			bitMask := bitMask + nextAvailableCode ].! !

!LzwGifDecoder methodsFor: 'initialization' stamp: ''!
initializeTables
	"The two arrays are our lookup tables.
	We do this instead of Dictionaries because
	the method is much, much faster"
	prefixTable := Array new: (maxCode).
	suffixTable := Array new: (maxCode).
	
	"The initial code size and mask settings
	also get reinitialized each time"
	codeSize := minimumCodeSize + 1.
	clearCode := (1 bitShift: minimumCodeSize).
	eoiCode := clearCode + 1.
	nextAvailableCode := clearCode + 2.
	bitMask := (1 bitShift: codeSize) - 1.
	
	"Fill the tables with the initial values"
	1 to: clearCode do: [ :n |
		prefixTable at: n put: (n - 1).
		suffixTable at: n put: (n - 1) ].! !

!LzwGifDecoder methodsFor: 'private' stamp: ''!
nextCode
	| integer numBitsRead newRemainder shiftAmount byte |
	"Retrieve the next code of codeSize bits.
	Store the remaining bits etc for later computation"
	integer := 0.
	numLeftoverBits = 0
		ifTrue: [ 
			numBitsRead := 8.
			shiftAmount := 0 ]
		ifFalse: [ 
			numBitsRead := numLeftoverBits.
			shiftAmount := numLeftoverBits - 8 ].
		[ numBitsRead < codeSize ] whileTrue: [ 
			byte := self nextByte.
			byte == nil ifTrue: [ ^ eoiCode ].
			integer := integer + (byte bitShift: shiftAmount).
			shiftAmount := shiftAmount + 8.
			numBitsRead := numBitsRead + 8 ].
		(newRemainder := numBitsRead - codeSize) = 0
			ifTrue: [ byte := self nextByte ]
			ifFalse: [ byte := self peekByte ].
		byte == nil ifTrue: [ ^ eoiCode ].
		numLeftoverBits := newRemainder.
		^ integer + (byte bitShift: shiftAmount) bitAnd: bitMask.! !

!LzwGifDecoder methodsFor: 'private' stamp: ''!
handleCode: anInteger withPreviousCode: prevInteger on: aWriteStream
	"Check for the code in the tables
	and perform the appropriate LZW action"
	| first searchIndex searchStack |
	"The code already exists in the table"
	anInteger < nextAvailableCode
		ifTrue: [ 
			anInteger < clearCode
				"If it's less than the clearCode
				then it is one of the original entries
				and we can simply use the suffix"
				ifTrue: [ 
					first := (suffixTable at: (anInteger + 1)).
					self writeBit: first on: aWriteStream ]
				"Otherwise we need to loop backwards along
				the prefix index values and take the suffix each
				time"
				ifFalse: [ 
					searchStack := Stack new.
					searchIndex := anInteger + 1.
					[ searchIndex > clearCode ] whileTrue: [ 
						searchStack push: (suffixTable at: searchIndex).
						searchIndex := (prefixTable at: searchIndex) + 1 ].
					searchStack push: (suffixTable at: searchIndex).
					first := searchStack first.
					searchStack do: [ :int |
						self writeBit: int on: aWriteStream ] ]. 
			]
		ifFalse: [ 
			"Here, the incoming code is not yet in the code tables"
			prevInteger < clearCode
				ifTrue: [ 
					first := (suffixTable at: (prevInteger + 1)).
					self
						writeBit: first on: aWriteStream;
						writeBit: first on: aWriteStream.
					 ]
				ifFalse: [ 
					searchStack := Stack new.
					searchIndex := prevInteger + 1.
					[ searchIndex > clearCode ] whileTrue: [ 
						searchStack push: (suffixTable at: searchIndex).
						searchIndex := (prefixTable at: searchIndex) + 1 ].
					searchStack push: (suffixTable at: searchIndex).
					first := searchStack first.
					searchStack do: [ :int |
						self writeBit: int on: aWriteStream ].
					self writeBit: first on: aWriteStream ]. 
			].
		"We add prevCode and the new
		suffix to a new entry in the code table, but
		only if we aren't at the max. NOTE: due to
		GIF 89a spec's 'deferred clear', if you get to
		the maxCode and haven't seen a clear, you stop
		writing to the tables but continue querying."
		nextAvailableCode >= maxCode
			ifFalse: [ 
				suffixTable at: (nextAvailableCode + 1) put: first.
				prefixTable at: (nextAvailableCode + 1) put: prevInteger ].
		self checkCodeSize.! !

!LzwGifDecoder methodsFor: 'accessing' stamp: ''!
minimumCodeSize: anInteger 
	minimumCodeSize := anInteger! !

!LzwGifEncoder commentStamp: ''!
I implement the modified Lempel-Ziv-Welch (LZW) algorithm for lossless GIF bitmap compression. My primary purpose is to encode/compress streams of bitmap bytes as specified by the GIF standard.

My instances require at minimum:
- A size of bytes in a row of bitmap bits for the image (#rowByteSize:)
- The extent of the image being encoded (#extent:)
- An array of bits in a bitmap (as bytes) for encoding (sent with #encode:)
- A stream of Bytes on which to output the encoded bytes (#codeStream:)
- A minimum code size as specified from GIF header information (#minimimCodeSize:)

Once all of these are set, implementors simply send the #encode: message along with a
collection of bitmap values as bytes that need to be encoded. Instead of responding with a collection of encoded bytes, #encode: will write to the output stream specified by #codeStream: directly.

For an example of use, see GIFReadWriter >> #writeBitData:

NOTE: LZW compression for GIFs is complex and the #encode: method is largely taken verbatim from Kazuki Yasumatsu's 1995 Squeak implementation (as opposed to the Decoder, which was heavily refactored for readability and comprehension). Any contributions to fleshing this out in a comprehensible way are much appreciated!!

See:
https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch
https://www.w3.org/Graphics/GIF/spec-gif89a.txt!
!LzwGifEncoder methodsFor: 'accessing' stamp: ''!
rowByteSize: anInteger
	rowByteSize := anInteger! !

!LzwGifEncoder methodsFor: 'private' stamp: ''!
checkSettings
	"Ensure that the appropriate variables
	that are needed for proper encoding
	have been set"
	codeStream ifNil: [ ^ self error: 'You must set a codeStream (byte stream) to write onto!!' ].
	dimensions ifNil: [ ^ self error: 'You must provide the extent of the image we will encode!!' ].
	rowByteSize ifNil: [ ^ self error: 'You must provide a rowByteSize for the supplied image bits!!' ].! !

!LzwGifEncoder methodsFor: 'private' stamp: ''!
flushBuffer
	"Write out the current codeStreamBuffer size,
	followed by its actual contents, to the true
	output codeStream"
	codeStreamBuffer isEmpty ifTrue: [ ^ self ].
	codeStream
		nextPut: codeStreamBuffer size;
		nextPutAll: codeStreamBuffer contents.
	codeStreamBuffer := (ByteArray new: 256) writeStream.! !

!LzwGifEncoder methodsFor: 'private - bits access' stamp: ''!
flushBits
	numLeftoverBits = 0 ifFalse: 
		[ self nextBytePut: bitBuffer.
		numLeftoverBits := 0 ].
	self flushBuffer! !

!LzwGifEncoder methodsFor: 'private - encoding' stamp: ''!
readPixelFrom: bits
	"Using the current x and y positions and
	the specified byte size for a row, determine
	the value for the next pixel in the provided bits"
	| pixel |
	yPos >= (dimensions y) ifTrue: [ ^ nil ].
	pixel := bits byteAt: yPos * rowByteSize + xPos + 1.
	self updatePixelPosition.
	^ pixel! !

!LzwGifEncoder methodsFor: 'accessing' stamp: ''!
codeStream: aByteStream
	codeStream := aByteStream.! !

!LzwGifEncoder methodsFor: 'private' stamp: ''!
checkCodeSize
	"Determine whether or not we need to increment
	the codeSize"
	(nextAvailableCode > maxCode and: [ codeSize < 12 ])
		ifTrue: [ 
			codeSize := codeSize + 1.
			maxCode := (1 bitShift: codeSize) - 1 ].! !

!LzwGifEncoder methodsFor: 'accessing' stamp: ''!
dimensions: anExtentPoint
	"Set the extent (as point) of the
	image that will be encoded"
	dimensions := anExtentPoint! !

!LzwGifEncoder methodsFor: 'converting' stamp: ''!
encode: bits
	| maxBits maxMaxCode tSize tShift fCode ent pixel index nomatch disp |
	self checkSettings.
	xPos := yPos := 0.
	codeStream nextPut: minimumCodeSize.
	bitBuffer := 0.
	numLeftoverBits := 0.
	codeStreamBuffer := WriteStream on: (ByteArray new: 256).
	self initializeParameters.
	
	"These temp vars are taken from the
	original GIFReadWriter implementation"
	maxBits := 12.
	maxMaxCode := 1 bitShift: maxBits.
	tSize := 5003.
	prefixTable := Array new: tSize.
	suffixTable := Array new: tSize.
	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 ].
	
	"We immediately write the clearCode
	to the output stream"
	self writeCodeAndCheckCodeSize: clearCode.
	
	"This loop is also taken from the original
	GIFReadWriter implementation"
	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.
					nextAvailableCode < maxMaxCode 
						ifTrue: 
							[ prefixTable 
								at: index
								put: nextAvailableCode.
							suffixTable 
								at: index
								put: fCode.
							nextAvailableCode := nextAvailableCode + 1 ]
						ifFalse: 
							[ self writeCodeAndCheckCodeSize: clearCode.
							1 
								to: tSize
								do: 
									[ :i | 
									suffixTable 
										at: i
										put: -1 ].
							self initializeParameters ] ] ] ].
	prefixTable := suffixTable := nil.
	self writeCodeAndCheckCodeSize: ent.
	self writeCodeAndCheckCodeSize: eoiCode.
	self flushBits.
	codeStream nextPut: 0.! !

!LzwGifEncoder methodsFor: 'private - packing' stamp: ''!
nextBytePut: anInteger
	"Write a complete byte to the output byteStream.
	Be sure to reset one we reach the limit, which is
	255 for GIF files. Then write the length of the next
	byte chunks to the stream also"
	codeStreamBuffer nextPut: anInteger.
	codeStreamBuffer size >= 254
		ifTrue: [ self flushBuffer ].! !

!LzwGifEncoder methodsFor: 'initialization' stamp: ''!
initializeParameters
	"The initial code size and mask settings
	also get reinitialized each time"
	codeSize := minimumCodeSize + 1.
	clearCode := (1 bitShift: minimumCodeSize).
	eoiCode := clearCode + 1.
	nextAvailableCode := clearCode + 2.
	maxCode := (1 bitShift: codeSize) - 1.! !

!LzwGifEncoder methodsFor: 'private' stamp: ''!
updatePixelPosition
	"Increment the xPos. If we are at the width
	position, set xPos to 0 and increment the yPos"
	xPos := xPos + 1.
	xPos >= (dimensions x) ifFalse: [ ^ self ].
	xPos := 0.
	yPos := yPos + 1.! !

!LzwGifEncoder methodsFor: 'writing' stamp: ''!
writeCodeAndCheckCodeSize: aCode
	self nextCodePut: aCode.
	self checkCodeSize.! !

!LzwGifEncoder methodsFor: 'accessing' stamp: ''!
extent: anExtentPoint
	"Set the extent (as point) of the
	image that will be encoded"
	dimensions := anExtentPoint! !

!LzwGifEncoder methodsFor: 'private - bits access' stamp: ''!
nextCodePut: anInteger
	"Attempt to put the bits on the
	output stream. If we have remaining bits,
	then we need to use bitwise operations to
	fill the next byte properly before putting
	it on the output stream"
	| numBitsWritten shiftCount newInteger |
	shiftCount := 0.
	numLeftoverBits = 0
		ifTrue: [ 
			numBitsWritten := 8.
			newInteger := anInteger ]
		ifFalse: [ 
			numBitsWritten := numLeftoverBits.
			newInteger := bitBuffer + (anInteger bitShift: 8 - numLeftoverBits) ].
	[ numBitsWritten < codeSize ] whileTrue: [ 
		self nextBytePut: ((newInteger bitShift: shiftCount) bitAnd: 255).
		shiftCount := shiftCount - 8.
		numBitsWritten := numBitsWritten + 8 ].
	(numLeftoverBits := numBitsWritten - codeSize) = 0
		ifTrue: [ self nextBytePut: (newInteger bitShift: shiftCount) ]
		ifFalse: [ bitBuffer := newInteger bitShift: shiftCount ].
	^ anInteger! !

!LzwGifEncoder methodsFor: 'accessing' stamp: ''!
minimumCodeSize: anInteger
	minimumCodeSize := anInteger! !

!MCAddition commentStamp: ''!
A MCAddition represents the operation to add an entity to a snapshot. !
!MCAddition methodsFor: 'accessing' stamp: 'nil'!
basicApplyTo: anObject
	anObject addDefinition: definition! !

!MCAddition methodsFor: 'accessing' stamp: 'nil'!
baseDefinition
	^ nil! !

!MCAddition methodsFor: 'initializing' stamp: 'nil'!
intializeWithDefinition: aDefinition
	definition := aDefinition! !

!MCAddition methodsFor: '*Iceberg-Changes' stamp: ''!
myVersionOn: aDiff

	^ aDiff versionFromDefinition: definition! !

!MCAddition methodsFor: 'accessing' stamp: 'nil'!
targetDefinition
	^ definition! !

!MCAddition methodsFor: '*MonticelloGUI' stamp: ''!
summary

	^ definition summary! !

!MCAddition methodsFor: 'accessing' stamp: 'nil'!
targetClass
	^definition actualClass ! !

!MCAddition methodsFor: '*Iceberg-Changes' stamp: ''!
theirVersionOn: aDiff

	^ nil! !

!MCAddition methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	^ self iconNamed: #changeAdd! !

!MCAddition methodsFor: 'accessing' stamp: 'nil'!
toSource
	^ definition diffSource! !

!MCAddition methodsFor: 'accessing' stamp: 'nil'!
definition
	^ definition! !

!MCAddition methodsFor: 'accessing' stamp: 'nil'!
fromSource
	^ ''! !

!MCAddition methodsFor: 'accessing' stamp: 'nil'!
inverse
	^ MCRemoval of: definition! !

!MCAddition methodsFor: 'testing' stamp: 'nil'!
isClassPatch
	^definition isClassDefinition! !

!MCAddition methodsFor: 'testing' stamp: 'nil'!
isAddition
	^ true! !

!MCAddition class methodsFor: 'instance creation' stamp: 'nil'!
of: aDefinition
	^ self new intializeWithDefinition: aDefinition! !

!MCAncestry commentStamp: ''!
Abstract superclass of records of ancestry.!
!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
ancestors
	^ ancestors ifNil: [#()]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
ancestorString
	^ String streamContents:
		[:s | self ancestors do: [:ea | s nextPutAll: ea name] separatedBy: [s nextPutAll: ', ']]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
allAncestorsDo: aBlock
	self ancestors do:
		[:ea |
		aBlock value: ea.
		ea allAncestorsDo: aBlock]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
commonAncestorWith: aNode
	| commonAncestors |
	commonAncestors := self commonAncestorsWith: aNode.
	^ commonAncestors at: 1 ifAbsent: [nil]! !

!MCAncestry methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	ancestors := #().
	stepChildren := #()! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
isRelatedTo: aVersionInfo
	^ aVersionInfo timeStamp < self timeStamp
		ifTrue: [self hasAncestor: aVersionInfo]
		ifFalse: [aVersionInfo hasAncestor: self]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
allAncestorsOnPathTo: aVersionInfo
	^ MCFilteredVersionSorter new
		target: aVersionInfo;
		addAllVersionInfos: self ancestors;
		sortedVersionInfos! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
hasAncestor: aVersionInfo
	^ self
		hasAncestor: aVersionInfo
		alreadySeen: OrderedCollection new! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
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: 'nil'!
stepChildren
	^ stepChildren ifNil: [#()]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
ancestorStringWithout: packageName
	^ String streamContents:
		[:s | self ancestors do: [:ea | s nextPutAll: (ea nameWithout: packageName)] separatedBy: [s nextPutAll: ', ']]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
ancestorsDoWhileTrue: aBlock
	self ancestors do:
		[:ea |
		(aBlock value: ea) ifTrue: 
			[ea ancestorsDoWhileTrue: aBlock]]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
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: 'nil'!
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: 'nil'!
withBreadthFirstAncestors
	^ (Array with: self), self breadthFirstAncestors! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
breadthFirstAncestors
	^ Array streamContents: [:s | self breadthFirstAncestorsDo: [:ea | s nextPut: ea]]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'nil'!
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: 'nil'!
stepChildrenString
	^ String streamContents:
		[:s | self stepChildren do: [:ea | s nextPutAll: ea name] separatedBy: [s nextPutAll: ', ']]! !

!MCAncestryTest methodsFor: 'building' stamp: ''!
twoPersonTree
	^ self treeFrom:
		#(c1
			((a4
				((a1)
				(b3
					((b2
						((a1)))))))
			(b5
				((b2
					((a1)))))))! !

!MCAncestryTest methodsFor: 'building' stamp: ''!
tree
	^ self treeFrom:
		#(c1
			((e2
				((e1
					((a1
						(('00')))))))
			(a2
				((a1
					(('00')))))
			(b3
				((b2
					((b1
						((b0
							(('00')))))))
				(a1
					(('00')))))
			(d1)))! !

!MCAncestryTest methodsFor: 'building' stamp: ''!
versionForName: name in: tree
	(tree name = name) ifTrue: [^ tree].
	
	tree ancestors do: [:ea | (self versionForName: name in: ea) ifNotNil: [:v | ^ v]].
	
	^ nil! !

!MCAncestryTest methodsFor: 'asserting' stamp: ''!
assertCommonAncestorOf: leftName and: rightName is: ancestorName in: tree
	self assertCommonAncestorOf: leftName and: rightName in: (Array with: ancestorName) in: tree! !

!MCAncestryTest methodsFor: 'tests' stamp: ''!
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) equals: a1.
	self assert: (b3 commonAncestorWith: q2) equals: a1.
	self assert: (q2 commonAncestorWith: c1) equals: a1.
	self assert: (c1 commonAncestorWith: q2) equals: a1.
	q1 addStepChild: c1.
	self assert: (q2 commonAncestorWith: c1) equals: q1.
	self assert: (c1 commonAncestorWith: q2) equals: q1.
	c2 := MCWorkingAncestry new addAncestor: c1.
	self assert: (q2 commonAncestorWith: c2) equals: q1.
	self assert: (c2 commonAncestorWith: q2) equals: q1! !

!MCAncestryTest methodsFor: 'tests' stamp: ''!
testPathToMissingAncestor
	self assertEmpty: (self tree allAncestorsOnPathTo: MCVersionInfo new)! !

!MCAncestryTest methodsFor: 'asserting' stamp: ''!
assertNamesOf: versionInfoCollection are: nameArray

	| names |
	names := versionInfoCollection collect: [ :ea | ea name ].
	self assert: names asArray equals: nameArray! !

!MCAncestryTest methodsFor: 'asserting' stamp: ''!
assertCommonAncestorOf: leftName and: rightName in: options in: tree
	| left right ancestor |
	left := self versionForName: leftName in: tree.
	right := self versionForName: rightName in: tree.
	
	ancestor := left commonAncestorWith: right.
	
	self assert: (options includes: ancestor name)! !

!MCAncestryTest methodsFor: 'tests' stamp: ''!
testLinearPath
	self assertPathTo: #b1 is: #(b3 b2)! !

!MCAncestryTest methodsFor: 'tests' stamp: ''!
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: 'asserting' stamp: ''!
assertPathTo: aSymbol is: anArray
	self
		assertNamesOf: (self tree allAncestorsOnPathTo: (self treeFrom: {aSymbol}))
		are: anArray! !

!MCAnnouncementTest methodsFor: 'tests' stamp: ''!
testMCVersionSaved
	| announcements version repository |
	version := self mockVersion.
	repository := MCDictionaryRepository new.
	announcements := OrderedCollection new.

	SystemAnnouncer uniqueInstance weak when: MCVersionSaved send: #add: to: announcements.

	repository storeVersion: version.

	SystemAnnouncer uniqueInstance unsubscribe: announcements.

	self assert: announcements size equals: 1.
	self assert: announcements anyOne version identicalTo: version.
	self assert: announcements anyOne repository identicalTo: repository! !

!MCBitbucketRepository methodsFor: 'private' stamp: ''!
normalizeTagsData: jsonObject
  "return a dictionay mapping the tag name to the commit SHA"

  | tagDict |
  jsonObject
    at: 'error'
    ifPresent: [ :errorObject | 
      self
        error:
          'Error accessing tags for bitbucket project: ' , self projectPath printString
            , ' -> ' , (errorObject at: 'message') printString
            ,
              ((errorObject at: 'detail')
                ifNil: [ '' ]
                ifNotNil: [ :detail | ' :: ' , detail printString ]) ].
  tagDict := Dictionary new.
  jsonObject
    keysAndValuesDo: [ :tag :tagObject | 
      | sha |
      sha := tagObject at: 'node'.
      tagDict at: tag put: sha ].
  ^ tagDict! !

!MCBitbucketRepository methodsFor: 'private' stamp: ''!
projectTagsUrlFor: projectPath2
  ^ 'https://bitbucket.org/api/1.0/repositories/' , projectPath2 , '/tags'! !

!MCBitbucketRepository methodsFor: '*Iceberg-Adapters' stamp: ''!
scpUrl
	^ 'git@bitbucket.org:', projectPath, '.git'! !

!MCBitbucketRepository methodsFor: '*Iceberg-Adapters' stamp: ''!
httpsUrl
	^ 'https://bitbucket.org/', projectPath, '.git'! !

!MCBitbucketRepository class methodsFor: 'private' stamp: ''!
projectZipUrlFor: projectPath versionString: versionString
  ^ 'https://bitbucket.org/' , projectPath , '/get/' , versionString , '.zip'! !

!MCBitbucketRepository class methodsFor: 'testing' stamp: ''!
isEnabled

	^true! !

!MCBitbucketRepository class methodsFor: 'instance creation' stamp: ''!
createRepositoryFromSpec: aRepositorySpec on: aPlatform
	^ aPlatform createBitbucketRepository: aRepositorySpec! !

!MCBitbucketRepository class methodsFor: 'accessing' stamp: ''!
basicDescription
  ^ 'bitbucket'! !

!MCBitbucketRepository class methodsFor: 'accessing' stamp: ''!
cacheDirectoryPath
  <preference: 'BitBucket Cache' category: 'Metacello' description: '' type:
    #'String'>
  ^ super cacheDirectoryPath! !

!MCBitbucketRepository class methodsFor: '*Metacello-Platform' stamp: ''!
urlSchemes
	^ #(bitbucket)! !

!MCBitbucketRepository class methodsFor: 'testing' stamp: ''!
isAvailableFor: type
	^ type = 'bitbucket'! !

!MCBitbucketRepository class methodsFor: '*Metacello-Platform' stamp: ''!
basicFromUrl: aZnUrl 
	^ self location: aZnUrl asString! !

!MCCacheRepository commentStamp: ''!
I am a special monticello directory-based repository that is used for the global monticello cache.

Most other repositories will first query the default cache repository for existing files before handling the request by themselves. For instance an http repository will first check if the file is in the caceh before doing a "slow" download.!
!MCCacheRepository methodsFor: 'initialization' stamp: 'nil'!
initialize
	cacheEnabled := true.
	super initialize.! !

!MCCacheRepository methodsFor: 'storing' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
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: 'utilities' stamp: 'nil'!
disable
	cacheEnabled := false.! !

!MCCacheRepository methodsFor: 'storing' stamp: 'nil'!
storeVersion: aVersion
	cacheEnabled == true ifFalse: [ ^ self ].
	^ super storeVersion: aVersion.! !

!MCCacheRepository methodsFor: 'utilities' stamp: 'nil'!
enable
	cacheEnabled := true! !

!MCCacheRepository methodsFor: 'instance creation' stamp: 'nil'!
newFileNames 
	^ self allFileNames difference: self seenFileNames! !

!MCCacheRepository methodsFor: 'interface' stamp: 'nil'!
versionWithInfo: aVersionInfo ifAbsent: errorBlock
	(self allFileNamesForVersionNamed: aVersionInfo name) do: [:fileName | | version |
			version := self versionFromFileNamed: fileName.
			version info = aVersionInfo ifTrue: [^ version]].
	^ errorBlock value! !

!MCCacheRepository methodsFor: 'accessing' stamp: 'nil'!
seenFileNames
	^ seenFiles ifNil: [seenFiles := OrderedCollection new]! !

!MCCacheRepository methodsFor: 'accessing' stamp: 'nil'!
cacheForPackage: aPackage
	packageCaches ifNil: [packageCaches := Dictionary new].
	^ packageCaches at: aPackage ifAbsentPut: [MCPackageCache new]! !

!MCCacheRepository methodsFor: 'utilities' stamp: 'nil'!
disableCacheDuring: aBlock
	self disable.
	aBlock ensure: [ self enable ].! !

!MCCacheRepository methodsFor: 'private' stamp: 'nil'!
loadVersionFromFileNamed: aString
	
	^ self versionReaderForFileNamed: aString do: [:r | r version]! !

!MCCacheRepository methodsFor: 'accessing' stamp: 'nil'!
versionInfoForFileNamed: aString
	^ self infoCache 
		at: aString 
		ifAbsentPut: [ self versionReaderForFileNamed: aString do: [:r | r info]]! !

!MCCacheRepository class methodsFor: 'accessing settings' stamp: 'nil'!
cacheDirectory: directory
	"directory - can be an absolutePathString (to interface with the settings framework), or aFileReference"
 
	default := self new directory: directory asFileReference.! !

!MCCacheRepository class methodsFor: 'initialize-release' stamp: 'nil'!
initialize
	self resetIfInvalid! !

!MCCacheRepository class methodsFor: 'accessing settings' stamp: 'nil'!
cacheDirectory
	^self uniqueInstance directory asAbsolute
	! !

!MCCacheRepository class methodsFor: 'defaults' stamp: 'nil'!
defaultDirectory
	| directories |
	directories := {
		((FileLocator localDirectory / 'package-cache') asFileReference).	
		(FileLocator temp).	
		(FileLocator home)}.
	directories
		do: [ :directory | 
			[ ^ directory ensureCreateDirectory; yourself ]
				on: Error do: [ "ignore and try the next directory" ] ].
	Error signal: 'Can''t create a package-cache'! !

!MCCacheRepository class methodsFor: 'accessing' stamp: 'nil'!
description
	^ nil! !

!MCCacheRepository class methodsFor: 'utilities' stamp: 'nil'!
resetIfInvalid
	default notNil and: [ default directory ifAbsent: [ default := nil ] ]! !

!MCCacheRepository class methodsFor: 'accessing' stamp: 'nil'!
uniqueInstance
	self resetIfInvalid.
	^ default ifNil: [default := self new directory: self defaultDirectory]! !

!MCCacheRepository class methodsFor: 'accessing' stamp: 'nil'!
default
	"This should be deleted as soon as Metacello is fixed"
	self flag: #toBeDeleted.			
	^ self uniqueInstance ! !

!MCCacheRepository class methodsFor: 'class initialization' stamp: 'nil'!
reset

	default := nil.! !

!MCCacheRepository class methodsFor: 'utilities' stamp: 'nil'!
disableCacheDuring: aBlock
	self uniqueInstance disableCacheDuring: aBlock! !

!MCChangeNotificationTest methodsFor: 'private' stamp: ''!
foreignMethod
	"see testForeignMethodModified"! !

!MCChangeNotificationTest methodsFor: 'tests' stamp: ''!
testCoreMethodModified
	| event |
	workingCopy modified: false.
	event := self modifiedEventFor: #one ofClass: self mockClassA.
	MCWorkingCopy methodModified: event.
	self assert: workingCopy modified! !

!MCChangeNotificationTest methodsFor: 'tests' stamp: ''!
testExtMethodModified
	| event method |
	workingCopy modified: false.
	method := workingCopy packageSet extensionMethods first.
	event := self modifiedEventFor: method selector ofClass: method methodClass.
	MCWorkingCopy methodModified: event.
	self assert: workingCopy modified! !

!MCChangeNotificationTest methodsFor: 'tests' stamp: ''!
testForeignMethodModified
	| event |
	workingCopy modified: false.
	event := self modifiedEventFor: #foreignMethod ofClass: self class.
	MCWorkingCopy methodModified: event.
	self deny: workingCopy modified! !

!MCChangeNotificationTest methodsFor: 'events' stamp: ''!
modifiedEventFor: aSelector ofClass: aClass
	| method |
	method := aClass compiledMethodAt: aSelector.
	^ MethodModified 
		methodChangedFrom: method
		to: method
		oldProtocol: nil
! !

!MCChangeNotificationTest methodsFor: 'running' stamp: ''!
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'."
		super setUp.	
      workingCopy := MCWorkingCopy forPackage: self mockPackage.! !

!MCChangeSelectionRequest commentStamp: ''!
Notify about a change selection request!
!MCChangeSelectionRequest methodsFor: 'accessing' stamp: 'nil'!
patch: aPatch
	patch := aPatch! !

!MCChangeSelectionRequest methodsFor: 'accessing' stamp: 'nil'!
label: aString
	label := aString! !

!MCChangeSelectionRequest methodsFor: '*MonticelloGUI' stamp: ''!
defaultAction
	^ (MCChangeSelector new patch: patch; label: label) showModally! !

!MCChangeSelectionRequest methodsFor: 'accessing' stamp: 'nil'!
patch
	^ patch! !

!MCChangeSelectionRequest methodsFor: 'accessing' stamp: 'nil'!
label
	^ label! !

!MCChangeSelector commentStamp: ''!
Monticello selector for changes.!
!MCChangeSelector methodsFor: 'actions' stamp: ''!
cancel
	self answer: nil! !

!MCChangeSelector methodsFor: 'multi-selection' stamp: ''!
listSelectionAt: aNumber
	^ self kept includes: (self items at: aNumber)! !

!MCChangeSelector methodsFor: 'selection' stamp: ''!
selectNone
	kept := Set new.
	self changed: #list! !

!MCChangeSelector methodsFor: 'accessing' stamp: ''!
kept
	^ kept ifNil: [kept := Set new]! !

!MCChangeSelector methodsFor: 'emulating' stamp: ''!
select
	self answer: (MCPatch operations: kept)! !

!MCChangeSelector methodsFor: 'multi-selection' stamp: ''!
listSelectionAt: aNumber put: aBoolean
	| item |
	item := self items at: aNumber.
	aBoolean
		ifTrue: [self kept add: item ]
		ifFalse: [self kept remove: item ifAbsent: []]! !

!MCChangeSelector methodsFor: 'morphic ui' stamp: ''!
widgetSpecs
	 ^#(
		((buttonRow) (0 0 1 0) (0 0 0 30))
		((multiListMorph:selection:listSelection:menu: list selection listSelectionAt: methodListMenu:) (0 0 1 0.4) (0 30 0 0))
		((buttonRow: #(('Select All' selectAll 'select all changes') ('Select None' selectNone 'select no changes'))) (0 0.4 1 0.4) (0 0 0 30))
		((textMorph: text) (0 0.4 1 1) (0 30 0 0))
		)

	! !

!MCChangeSelector methodsFor: 'morphic ui' stamp: ''!
buttonSpecs
	^ #((Select select 'Select these changes')
		 (Cancel cancel 'Cancel the operation')
		)! !

!MCChangeSelector methodsFor: 'selection' stamp: ''!
selectAll
	kept addAll: self items.
	self changed: #list! !

!MCChangeSelector methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^ 'Change Selector'! !

!MCClassDefinition commentStamp: ''!
A MCClassDefinition represents a class.!
!MCClassDefinition methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor
	aVisitor visitClassDefinition: self.
	(self hasClassInstanceVariables or: [self hasClassTraitComposition])
		ifTrue: [aVisitor visitMetaclassDefinition: self].
! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
classInstanceVariables

	variables ifNil: [ ^ #() ].

	^self needsSlotClassDefinition 
		ifTrue: [ self variablesOfType: #isClassInstanceVariable]
		ifFalse: [self classInstanceVariablesString asSlotCollection]! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
traitCompositionString
	^self traitComposition ifNil: ['{}'].! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
selectVariables: aSelector
	^ variables select: [:v | v perform: aSelector] thenCollect: [:v | v name]! !

!MCClassDefinition methodsFor: '*Ring-Monticello' stamp: ''!
ensureRingDefinitionIn: anRGEnvironment package: anRGPackage
	
	| def |
	
	def := self ensureRingDefinitionIn: anRGEnvironment.
	def package: anRGPackage.
	def category: def tags first. "fix tags to do not contain package names"
	^ def! !

!MCClassDefinition methodsFor: 'comparing' stamp: 'nil'!
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: 'testing' stamp: 'nil'!
hasComment
	^ comment isEmptyOrNil not! !

!MCClassDefinition methodsFor: 'initializing' stamp: 'nil'!
addVariables: aCollection ofType: aClass
	variables addAll: (aCollection collect: [:var | aClass name: var asString]).! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
description
	^ Array with: name
! !

!MCClassDefinition methodsFor: 'testing' stamp: 'nil'!
isCodeDefinition
	^ true! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
source
	^ self definitionString! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
summary
	^ name! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
poolDictionaries
	^ self selectVariables: #isPoolImport! !

!MCClassDefinition methodsFor: '*Iceberg' stamp: ''!
fullDefinitionString
	^ String streamContents: [:stream | 
		self printDefinitionOn: stream.
		stream cr; cr.
		stream << self comment ]! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
classTraitComposition
	^classTraitComposition! !

!MCClassDefinition methodsFor: 'initializing' stamp: 'nil'!
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: 'installing' stamp: 'nil'!
load
	self createClass! !

!MCClassDefinition methodsFor: 'comparing' stamp: 'nil'!
provisions
	^ Array with: name! !

!MCClassDefinition methodsFor: 'installing' stamp: 'nil'!
createVariableFromString: aString
	^[ Smalltalk compiler evaluate: aString ] 
		on: Error 
		do: [ 
			"if an error happens, we parse the slot definition to an ast.
			and create a UndefinedSlot"
			| ast slotName |
			ast := RBParser parseExpression: aString. 
			slotName := ast receiver value. 
			UndefinedSlot named: slotName ast: ast  ]! !

!MCClassDefinition methodsFor: 'installing' stamp: 'nil'!
variablesOfType: aSymbol
	"version for complex vars, { definition . definition }"
	^(self selectVariables: aSymbol) 
		collect: [:each | self createVariableFromString: each]
		as: Array! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
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: 'installing' stamp: 'nil'!
unload
	Smalltalk globals removeClassNamed: name! !

!MCClassDefinition methodsFor: '*Ring-Definitions-Monticello' stamp: 'nil'!
asRingDefinition
	| ring |

	ring:= (RGClassDefinition named:  self className)
		category: self category;
		superclassName: self superclassName;  
		traitCompositionSource: self traitCompositionString;
		addInstanceVariables: self instVarNames;
		addClassVariables: self classVarNames;
		addSharedPools: self poolDictionaries;
		comment: self comment;
		stamp: self commentStamp;
		definitionSource: self definitionString;
		withMetaclass.
	ring classSide 
		traitCompositionSource: self classTraitCompositionString;
		addInstanceVariables: self classInstVarNames;
		definitionSource: self classDefinitionString.
	^ring! !

!MCClassDefinition methodsFor: 'testing' stamp: 'nil'!
hasTraitComposition
	^self traitCompositionString ~= '{}'! !

!MCClassDefinition methodsFor: 'initializing' stamp: 'nil'!
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 withInternalLineEndings.
	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: 'accessing' stamp: 'nil'!
actualClass
	^ Smalltalk globals classNamed: self className! !

!MCClassDefinition methodsFor: 'storing' stamp: 'nil'!
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: 'printing' stamp: 'nil'!
classInstanceVariablesString

	^ self stringForVariablesOfType: #isClassInstanceVariable! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
sortKey
	^ self className! !

!MCClassDefinition methodsFor: 'comparing' stamp: 'nil'!
= aDefinition
	^ super = aDefinition
		and: [ superclassName = aDefinition superclassName
		and: [ self traitCompositionString = aDefinition traitCompositionString
		and: [ self classTraitCompositionString = aDefinition classTraitCompositionString
		and: [ category = aDefinition category
		and: [ type = aDefinition type and: [ self sortedVariables = aDefinition sortedVariables and: [ comment = aDefinition comment ] ] ] ] ] ] ]! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
classInstVarNames
	^ self selectVariables: #isClassInstanceVariable! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
variables
	^ variables ifNil: [ variables := OrderedCollection  new ]! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
sharedPoolsString
	^ self stringForSortedVariablesOfType: #isPoolImport! !

!MCClassDefinition methodsFor: 'installing' stamp: 'nil'!
stringForVariablesOfType: aSymbol
	^ String streamContents:
		[:stream |
		(self selectVariables: aSymbol) 
			do: [:ea | stream nextPutAll: ea]
			separatedBy: [stream space]]! !

!MCClassDefinition methodsFor: 'comparing' stamp: 'nil'!
requirements
	^ ((superclassName == #nil) or: [superclassName asString beginsWith: 'AnObsolete'])
		ifTrue: [self poolDictionaries]
		ifFalse: [(Array with: superclassName), self poolDictionaries]! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
traitCompositionCompiled
	^(Smalltalk compiler evaluate: self traitCompositionString) asTraitComposition ! !

!MCClassDefinition methodsFor: 'testing' stamp: 'nil'!
hasClassTraitComposition
	^self classTraitCompositionString ~= '{}'! !

!MCClassDefinition methodsFor: 'testing' stamp: 'nil'!
isClassDefinition
	^ true! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
traitComposition
	^traitComposition! !

!MCClassDefinition methodsFor: 'annotations' stamp: 'nil'!
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: 'printing' stamp: 'nil'!
printMetaDefinitionOn: stream
	stream 
		nextPutAll: self className;
		nextPutAll: ' class'; cr; tab.
	self printDefinitionBodyOn: stream! !

!MCClassDefinition methodsFor: 'installing' stamp: 'nil'!
stringForSortedVariablesOfType: aSymbol
	^ String streamContents:
		[:stream |
		(self selectVariables: aSymbol) asSortedCollection
			do: [:ea | stream nextPutAll: ea]
			separatedBy: [stream space]]! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
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: 'nil'!
className
	^ name! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
type
	^ type! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
definitionString
	^ String streamContents: [:stream | self printDefinitionOn: stream]! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
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: ' ].
	type = #immediate ifTrue: [ ^ ' immediateSubclass: ' ].
	type = #ephemeron ifTrue: [ ^ ' ephemeronSubclass: ' ].
	type = #DoubleByteLayout ifTrue: [ ^' variableDoubleByteSubclass: ' ].
	type = #DoubleWordLayout ifTrue: [ ^' variableDoubleWordSubclass: ' ].
	"To support user defined layouts (load them as normal classes), we just return the default"
	^ ' subclass: '! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
instanceVariablesString
	^ self stringForVariablesOfType: #isInstanceVariable! !

!MCClassDefinition methodsFor: '*Ring-Monticello' stamp: ''!
ring2LayoutType

	^ (Dictionary newFrom: {	
		#compiledMethod -> RGCompiledMethodLayout. 
		#bytes -> RGByteLayout. 
		#immediate -> RGImmediateLayout. 
		#words -> RGWordLayout. 
		#week -> RGWeakLayout.
		#variable -> RGVariableLayout.
		#ephemeron -> RGEphemeronLayout.
		#normal -> RGFixedLayout.
		#weak -> RGWeakLayout.
		#DoubleByteLayout -> RGDoubleByteLayout.
		#DoubleWordLayout -> RGDoubleWordLayout
	}) at: type.		
! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
classTraitCompositionString
	^self classTraitComposition ifNil: ['{}'].! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
commentStamp
	^ commentStamp! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
classVarNames
	^(self selectVariables: #isClassVariable) asArray sort! !

!MCClassDefinition methodsFor: 'installing' stamp: 'nil'!
needsSlotClassDefinition
	"this checks if any ivar or class var is using more than just standard definitions.
	Complex vars are encoded with a string that starts with a # or one that has a space"
	
	^self variables anySatisfy: [:var | (var name beginsWith:'#') or: [ var name includes: Character space ]]! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
category
	^ category! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
superclassName
	^ superclassName! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
classVariables
	^self needsSlotClassDefinition 
		ifTrue: [self sortedVariablesOfType: #isClassVariable ]
		ifFalse: [(self classVariablesString substrings: ' ') collect: [:x | x asSymbol => ClassVariable]].
! !

!MCClassDefinition methodsFor: 'installing' stamp: 'nil'!
createClass
	| superClass |
	"Ignore Context definition because of troubles with class migration on bootstrapped image. Temporary solution."
	name = #Context
		ifTrue: [ Context comment = comment 
						ifFalse: [ Context comment: comment stamp: commentStamp ].
					^ self ].
	superClass := superclassName == #nil
		ifFalse: [ Smalltalk globals at: superclassName ].
	^ [ Smalltalk classInstaller
		make: [ :builder | 
			builder
				superclass: superClass;
				name: name;
				layoutClass: (ObjectLayout layoutForType: type);
				slots: self instanceVariables;
				sharedVariables: self classVariables;
				sharedPools: self sharedPoolsString;
				classSlots: self classInstanceVariables;
				traitComposition: self traitCompositionCompiled;
				classTraitComposition: self classTraitCompositionCompiled;
				comment: comment stamp: commentStamp;
				category: category;
				environment: superClass environment ] ]
		on: Warning , DuplicatedVariableError
		do: [ :ex | ex resume ]! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
instanceVariables
	^self needsSlotClassDefinition 
		ifTrue: [self variablesOfType: #isInstanceVariable]
		ifFalse: [self instanceVariablesString asSlotCollection]! !

!MCClassDefinition methodsFor: 'initializing' stamp: 'nil'!
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 withInternalLineEndings.
	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: 'accessing' stamp: 'nil'!
comment
	^ comment! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
printDefinitionBodyOn: stream

	self hasClassTraitComposition ifTrue: [
		stream
			nextPutAll: 'uses: ';
			nextPutAll: self classTraitCompositionString;
			cr; tab ].
	stream
		nextPutAll: ' instanceVariableNames: '; 
		store: self classInstanceVariablesString! !

!MCClassDefinition methodsFor: 'installing' stamp: 'nil'!
sortedVariablesOfType: aSymbol
	"version for complex vars, { definition . definition }"
	^(((self selectVariables: aSymbol) asSortedCollection collect: [:each | Smalltalk compiler evaluate: each])) asArray.
		! !

!MCClassDefinition methodsFor: '*Ring-Monticello' stamp: ''!
asRGDefinition

	^ self ensureRingDefinitionIn: RGEnvironment new! !

!MCClassDefinition methodsFor: '*Ring-Monticello' stamp: ''!
ensureRingDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		| def metaclassDef |
		def := anRGEnvironment ensureClassNamed: self className asSymbol.
		metaclassDef := anRGEnvironment ensureClassNamed: (self className, ' class') asSymbol.
		def metaclass: metaclassDef.
		def traitComposition: (self traitCompositionFrom: self traitComposition parent: def).			
		metaclassDef traitComposition: (self traitCompositionFrom: self classTraitComposition parent: metaclassDef).			
		(self superclassName = #nil)
			ifTrue: [ def superclass: def ]
			ifFalse: [ def superclass: (anRGEnvironment ensureClassNamed: superclassName ) ].
		def category: self category.
		def layout: (self ring2LayoutType parent: def).
		metaclassDef layout: (RGFixedLayout parent: metaclassDef). 
		def comment: (
			(RGComment parent: def) 
				content: self comment;
				author: (self authorForStamp: self commentStamp);
				time: (self timeForStamp: self commentStamp);
				yourself).
		self variables do: [ :each |
			(each class type = #instance) ifTrue: [
				(each name includes: $>) 
					ifFalse: [ def layout addSlot: (RGInstanceVariableSlot named: each name parent: def layout)]
					ifTrue: [ 
						| unknownSlot |
						unknownSlot := RGUnknownSlot named: ((each name copyUpTo: $=) copyWithout: $#) trimBoth parent: def layout.
						unknownSlot expression: (each name copyAfter: $>) trimBoth.
						def layout addSlot: unknownSlot]].
			(each class type = #class) ifTrue: [ 
				def addClassVariable: (RGClassVariable named: each name parent: def)].
			(each class type = #classInstance) ifTrue: [ 
				metaclassDef layout addSlot: (RGInstanceVariableSlot named: each name parent: metaclassDef layout)].
			(each class type = #pool) ifTrue: [ 
				def addSharedPool: (RGPoolVariable named: each name parent: def)]. ]. 
		def]. 
	! !

!MCClassDefinition methodsFor: '*Iceberg-Adapters' stamp: ''!
classCategory
	"Avoid direct use of #category, because MCClassDefinitions and 
	MCMethodDefinition use the same message for different things. "
	^ self category! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
instVarNames
	^ self selectVariables: #isInstanceVariable! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
classTraitCompositionCompiled
		^(Smalltalk compiler evaluate: self classTraitCompositionString) asTraitComposition ! !

!MCClassDefinition methodsFor: '*Iceberg-Changes' stamp: ''!
removeMetaSideVariables
	
	variables := variables reject: [ :e | e isClassInstanceVariable ].
! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'nil'!
classDefinitionString
	"Answer a string describing the class-side definition."
	
	^String streamContents: [:stream | self printClassDefinitionOn: stream]! !

!MCClassDefinition methodsFor: 'testing' stamp: 'nil'!
hasClassInstanceVariables
	^ (self selectVariables: #isClassInstanceVariable) isEmpty not! !

!MCClassDefinition methodsFor: 'printing' stamp: 'nil'!
classVariablesString
	^ self stringForSortedVariablesOfType: #isClassVariable! !

!MCClassDefinition class methodsFor: 'obsolete' stamp: 'nil'!
name: nameString superclassName: superclassString category: categoryString instVarNames: ivarArray comment: commentString

	^ self
		name: nameString
		superclassName: superclassString
		traitComposition: '{}'
		classTraitComposition: '{}'
		category: categoryString
		instVarNames: ivarArray
		classVarNames: ''
		poolDictionaryNames: ''
		classInstVarNames: ''
		type: #normal
		comment: commentString
		commentStamp: nil! !

!MCClassDefinition class methodsFor: 'instance creation' stamp: 'nil'!
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 new
		initializeWithName: nameString
		superclassName: superclassString
		traitComposition: traitCompositionString
		classTraitComposition: classTraitCompositionString
		category: categoryString
		instVarNames: ivarArray
		classVarNames: cvarArray
		poolDictionaryNames: poolArray
		classInstVarNames: civarArray
		type: typeSymbol
		comment: commentString
		commentStamp: stampString! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
testCreation
	| d |
	d :=  self mockClassA asClassDefinition.
	self assert: d className equals: #MCMockClassA.
	self assert: d superclassName equals: #MCMock.
	self assert: d type equals: #normal.
	self assert: d category equals: self mockCategoryName.
	self assert: d instVarNames asArray equals: #('ivar').
	self assert: d classVarNames asArray equals: #('CVar' 'InitializationOrder').
	self assert: d classInstVarNames asArray equals: #().
	self assert: d comment isString.
	self assert: d comment equals: self classAComment.
	self assert: d commentStamp equals: self mockClassA organization commentStamp! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
testEqualsSensitivity
	| message a b defA args defB |
	
	message := MessageSend 
		receiver: MCClassDefinition 
		selector:#name:superclassName:traitComposition:classTraitComposition:category:instVarNames:classVarNames:poolDictionaryNames:classInstVarNames:type:comment:commentStamp:.
	
	a := #(ClassA SuperA '{}' '{}' CategoryA #(iVarA) #(CVarA) #(PoolA) #(ciVarA) typeA 'A comment' 'A').
	b := #(ClassB SuperB 'T' 'T classTrait' 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 equals: defB ]! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
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: 'running' stamp: ''!
tearDown
	testingEnvironment at: #MCMockClassC ifPresent: [ :c | c removeFromSystem ].
	super tearDown! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
testValidTraitComposition4
	"Related to http://code.google.com/p/pharo/issues/detail?id=2598"

	| d className cls |
	className := 'MCMockClassC'.
	d := MCClassDefinition
		name: className
		superclassName: 'Object'
		traitComposition: 'Trait1 - {#c1}'
		classTraitComposition: '{}'
		category: self mockCategoryName
		instVarNames: #()
		classVarNames: #()
		poolDictionaryNames: #()
		classInstVarNames: #()
		type: #normal
		comment: (self commentForClass: className)
		commentStamp: (self commentStampForClass: className).
	d load.
	self assert: (testingEnvironment hasClassNamed: 'MCMockClassC').
	cls := testingEnvironment at: #MCMockClassC.
	self assert: (cls selectors includesAll: {#c}).
	self deny: (cls selectors includesAnyOf: {#c1})! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
testEquals
	| a b |
	a := self mockClass: 'ClassA' super: 'SuperA'.
	b := self mockClass: 'ClassA' super: 'SuperA'.
	self assert: a equals: b! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
testKindOfSubclass
	| classes |
	classes := {self mockClassA. String. Context. WeakArray. Float. CompiledMethod. DoubleByteArray . DoubleWordArray }.
	classes do: [:c | | d |
		d :=  c asClassDefinition.
		self assert: d kindOfSubclass equals: c kindOfSubclass.
	].! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
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: ''!
testValidTraitComposition3
	"Related to http://code.google.com/p/pharo/issues/detail?id=2148"

	| d className cls |
	className := 'MCMockClassC'.
	d := MCClassDefinition
		name: className
		superclassName: 'Object'
		traitComposition: 'Trait1 + Trait2'
		classTraitComposition: '{}'
		category: self mockCategoryName
		instVarNames: #()
		classVarNames: #()
		poolDictionaryNames: #()
		classInstVarNames: #()
		type: #normal
		comment: (self commentForClass: className)
		commentStamp: (self commentStampForClass: className).
	d load.
	self assert: (testingEnvironment hasClassNamed: 'MCMockClassC').
	cls := testingEnvironment at: #MCMockClassC.
	self assert: (cls includesSelector: #c1).
	self assert: (cls includesSelector: #c2).
	self assert: ((testingEnvironment at: #MCMockClassC) traitComposition allTraits includes: Trait1).
	self assert: ((testingEnvironment at: #MCMockClassC) traitComposition allTraits includes: Trait2)! !

!MCClassDefinitionTest methodsFor: 'private' stamp: ''!
classAComment
	^ self class classAComment! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
testValidTraitComposition
	"Related to http://code.google.com/p/pharo/issues/detail?id=2148"

	| d className cls |
	className := 'MCMockClassC'.
	d := MCClassDefinition
		name: className
		superclassName: 'Object'
		traitComposition: '{Trait1}'
		classTraitComposition: '{}'
		category: self mockCategoryName
		instVarNames: #()
		classVarNames: #()
		poolDictionaryNames: #()
		classInstVarNames: #()
		type: #normal
		comment: (self commentForClass: className)
		commentStamp: (self commentStampForClass: className).
	d load.
	self assert: (testingEnvironment hasClassNamed: 'MCMockClassC').
	cls := testingEnvironment at: #MCMockClassC.
	self assert: (cls includesSelector: #c1).
	self assert: ((testingEnvironment at: #MCMockClassC) traitComposition allTraits includes: Trait1)! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
testLoadAndUnload
	| d c |
	d := self mockClass: 'MCMockClassC' super: 'Object'.
	d load.
	self assert: (testingEnvironment hasClassNamed: 'MCMockClassC').
	c := testingEnvironment classNamed: 'MCMockClassC'.
	self assert: (c isKindOf: Class).
	self assert: c superclass equals: Object.
	self assertEmpty: c instVarNames.
	self assertEmpty: c classVarNames.
	self assertEmpty: c sharedPools.
	self assert: c category equals: self mockCategoryName.
	self assert: c organization classComment equals: (self commentForClass: 'MCMockClassC').
	self assert: c organization commentStamp equals: (self commentStampForClass: 'MCMockClassC').
	d unload.
	self deny: (testingEnvironment hasClassNamed: 'MCMockClassC')! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
testValidTraitComposition2
	"Related to http://code.google.com/p/pharo/issues/detail?id=2148"

	| d className cls |
	className := 'MCMockClassC'.
	d := MCClassDefinition
		name: className
		superclassName: 'Object'
		traitComposition: 'Trait1'
		classTraitComposition: '{}'
		category: self mockCategoryName
		instVarNames: #()
		classVarNames: #()
		poolDictionaryNames: #()
		classInstVarNames: #()
		type: #normal
		comment: (self commentForClass: className)
		commentStamp: (self commentStampForClass: className).
	d load.
	self assert: (testingEnvironment hasClassNamed: 'MCMockClassC').
	cls := testingEnvironment at: #MCMockClassC.
	self assert: (cls includesSelector: #c1).
	self assert: ((testingEnvironment at: #MCMockClassC) traitComposition allTraits includes: Trait1)! !

!MCClassDefinitionTest methodsFor: 'tests' stamp: ''!
testDefinitionString
	| d |
	d := self mockClassA asClassDefinition.
	self assert: d definitionString equals: self mockClassA oldDefinition.! !

!MCClassDefinitionTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	testingEnvironment at: #MCMockClassC ifPresent: [ :c | c removeFromSystem ]! !

!MCClassDefinitionTest class methodsFor: 'private - accessing' stamp: ''!
classAComment
	^ 'This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.'! !

!MCClassDefinitionTest class methodsFor: 'private - accessing' stamp: ''!
classACommentStamp
	^  'cwp 8/10/2003 16:43'! !

!MCClassDefinitionTest class methodsFor: 'utilities' stamp: ''!
restoreClassAComment
	"This is an utility class to restore the class comment in a mock class used by the test"
	<script>
	
	self environment
		at: #MCMockClassA
		ifPresent: [ :a | a classComment: self classAComment stamp: self classACommentStamp ]! !

!MCClassInstanceVariableDefinition commentStamp: ''!
A MCClassInstanceVariableDefinition represents a class instance variable.!
!MCClassInstanceVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isClassInstanceVariable
	^ true! !

!MCClassInstanceVariableDefinition class methodsFor: 'accessing' stamp: 'nil'!
type
	^ #classInstance! !

!MCClassTraitDefinition commentStamp: ''!
A class trait definition!
!MCClassTraitDefinition methodsFor: 'comparing' stamp: 'nil'!
= aDefinition
	^ super = aDefinition
		and: [ baseTrait = aDefinition baseTrait
		and: [ self classTraitCompositionString = aDefinition classTraitCompositionString
		and: [ category = aDefinition category ] ] ]! !

!MCClassTraitDefinition methodsFor: 'comparing' stamp: 'nil'!
hash
	| hash |
	hash := String stringHash: baseTrait initialHash: 0.
	hash := String stringHash: self classTraitCompositionString initialHash: hash.
	category ifNotNil: [ :cat | hash := String stringHash: cat initialHash: hash ].
	^ hash! !

!MCClassTraitDefinition methodsFor: '*MonticelloTonel-Core' stamp: ' 1/5/2022 20:56:19'!
isTraitDefinition
	^ true! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
description
	^ Array with: baseTrait with: classTraitComposition! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
requirements
	^Array with: baseTrait! !

!MCClassTraitDefinition methodsFor: 'printing' stamp: 'nil'!
printDefinitionOn: stream
	stream
		nextPutAll: self baseTrait;
		nextPutAll: ' classTrait';
		cr;
		tab;
		nextPutAll: 'uses: ';
		nextPutAll: self classTraitCompositionString! !

!MCClassTraitDefinition methodsFor: 'testing' stamp: 'nil'!
isClassDefinition
	"Traits are treated the same like classes."
	
	^ true! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
source
	^self definitionString! !

!MCClassTraitDefinition methodsFor: 'printing' stamp: 'nil'!
summary
	^self baseTrait , ' classTrait'
! !

!MCClassTraitDefinition methodsFor: '*Iceberg-Core' stamp: ''!
traitComposition
	^ self classTraitComposition ! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
classTraitComposition
	^classTraitComposition

! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
className
	^self baseTrait! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
definitionString
	^self baseTrait , ' classTrait
	uses: ' , self classTraitCompositionString.
! !

!MCClassTraitDefinition methodsFor: 'installing' stamp: 'nil'!
load	
	self class compiler evaluate: self definitionString! !

!MCClassTraitDefinition methodsFor: 'initialization' stamp: 'nil'!
initializeWithBaseTraitName: aTraitName classTraitComposition: aString
	baseTrait := aTraitName.
	classTraitComposition := aString! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
classTraitCompositionString
	^ self classTraitComposition ifNil: [ '{}' ]! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
category
	^ category ifNil: [
		(Smalltalk classOrTraitNamed: self baseTrait)
			ifNotNil: [ :bTrait | bTrait category ]
			ifNil: [ self error: 'Can''t detect the category' ] ]! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
baseTrait
	^baseTrait
! !

!MCClassTraitDefinition methodsFor: '*Ring-Definitions-Monticello' stamp: 'nil'!
asRingDefinition

	^(RGMetatraitDefinition named:  baseTrait)
		traitCompositionSource: self classTraitCompositionString;
		definitionSource: self definitionString;
		yourself! !

!MCClassTraitDefinition methodsFor: '*Ring-Monticello' stamp: ''!
asRGDefinition

	^ self ensureRingDefinitionIn: RGEnvironment new! !

!MCClassTraitDefinition methodsFor: '*Ring-Monticello' stamp: ''!
ensureRingDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		| def traitDef |
		def := anRGEnvironment ensureMetaclassTraitNamed: (self baseTrait, ' classTrait') asSymbol.
		traitDef := anRGEnvironment ensureTraitNamed: (self baseTrait) asSymbol.
		def baseTrait: traitDef.
		traitDef classTrait: def.
		def traitComposition: (self traitCompositionFrom: self classTraitComposition parent: def).
		traitDef category: self category. "makes no sense for metaclass trait"
		def]. 
	! !

!MCClassTraitDefinition methodsFor: 'initialization' stamp: 'nil'!
initializeWithBaseTraitName: aTraitName classTraitComposition: aString category: aCategoryString
	baseTrait := aTraitName.
	classTraitComposition := aString.
	category := aCategoryString! !

!MCClassTraitDefinition methodsFor: '*Iceberg-Adapters' stamp: ''!
classCategory
	^ self category! !

!MCClassTraitDefinition methodsFor: '*Ring-Definitions-Monticello' stamp: 'nil'!
classDefinitionString

	^self definitionString! !

!MCClassTraitDefinition methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor
	^ aVisitor visitClassTraitDefinition: self! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
sortKey
	^ self baseTrait , '.classTrait'! !

!MCClassTraitDefinition class methodsFor: 'instance creation' stamp: 'nil'!
baseTraitName: aString classTraitComposition: classTraitCompositionString
	^ self baseTraitName: aString classTraitComposition: classTraitCompositionString category: nil! !

!MCClassTraitDefinition class methodsFor: 'instance creation' stamp: 'nil'!
baseTraitName: aString classTraitComposition: classTraitCompositionString category: aCategoryString
	^ self new
		initializeWithBaseTraitName: aString
		classTraitComposition: classTraitCompositionString
		category: aCategoryString! !

!MCClassTraitParser commentStamp: ''!
MCClassTraitParser identifies classTrait. !
!MCClassTraitParser methodsFor: 'actions' stamp: 'nil'!
addDefinitionsTo: aCollection
	| tokens  definition traitCompositionString |
	tokens := source parseLiterals.
	traitCompositionString := (source readStream
		match: 'uses:';
		upToEnd) trimBoth.
	definition := MCClassTraitDefinition
		baseTraitName: (tokens at: 1) 
		classTraitComposition: traitCompositionString.
	aCollection add: definition
! !

!MCClassTraitParser class methodsFor: 'factory identification hook' stamp: 'nil'!
pattern
	^ '*classTrait*uses:*'! !

!MCClassVariableDefinition commentStamp: ''!
A MCClassVariableDefinition represent a class variable.!
!MCClassVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isClassVariable
	^ true! !

!MCClassVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isOrderDependend
	^false! !

!MCClassVariableDefinition class methodsFor: 'accessing' stamp: 'nil'!
type
	^ #class! !

!MCCodeTool commentStamp: ''!
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: ''!
classListMenu: aMenu 

	^aMenu addList: #(
		-
		('Browse full (b)'			browseMethodFull)
		('Browse hierarchy (h)'		classHierarchy)
		-
		('Show hierarchy'			methodHierarchy))! !

!MCCodeTool methodsFor: 'menus' stamp: ''!
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: 'subclassresponsibility' stamp: ''!
selectedMessageName
	"Answer the name of the selected message"
	self subclassResponsibility! !

!MCCodeTool methodsFor: 'menus' stamp: ''!
copySelector
	"Copy the selected selector to the clipboard"

	| selector |
	(selector := self selectedMessageName) ifNotNil:
		[Clipboard clipboardText: selector asString]! !

!MCCodeTool methodsFor: 'subclassresponsibility' stamp: ''!
selectedClass
	"Answer the class that is selected, or nil"
	self subclassResponsibility! !

!MCCodeTool methodsFor: 'menus' stamp: ''!
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
							on: internalStream ]
					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
								forClass: patchOp definition actualClass]]
					ifNil:
						[internalStream nextChunkPut: patchOp definition className, ' removeFromSystem']]].
		CodeExporter writeSourceCodeFrom: internalStream baseName: fileName isSt: true]! !

!MCCodeTool methodsFor: 'menus' stamp: ''!
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: 'subclassresponsibility' stamp: ''!
selectedClassOrMetaClass
	"Answer the class that is selected, or nil"
	self subclassResponsibility! !

!MCCodeTool methodsFor: 'menus' stamp: ''!
methodHierarchy
	"Create and schedule a method browser on the hierarchy of implementors."

	self systemNavigation methodHierarchyBrowserForClass: self selectedClassOrMetaClass
		selector: self selectedMessageName! !

!MCCodeTool methodsFor: 'menus' stamp: ''!
browseMethodFull
	"Create and schedule a full Browser and then select the current class and message."

	| myClass |
	(myClass := self selectedClassOrMetaClass) ifNotNil:
		[Smalltalk tools browser openOnClass: myClass selector: self selectedMessageName]! !

!MCCodeTool methodsFor: 'menus' stamp: ''!
browseVersions
	"Create and schedule a message set browser on all versions of the 
	currently selected message selector."
	
	Smalltalk tools versionBrowser  
		browseVersionsForClass:  self selectedClassOrMetaClass 
		selector: self selectedMessageName
		! !

!MCCodeTool methodsFor: 'subclassresponsibility' stamp: ''!
selectedMessageCategoryName
	"Answer the method category of the method that is selected, or nil"
	self subclassResponsibility! !

!MCCodeTool methodsFor: 'menus' stamp: ''!
methodListMenu: aMenu
	"Build the menu for the selected method, if any."
	
	self selectedMessageName 
		ifNil: [ items notEmpty ifTrue: [aMenu add: 'FileOut (o)'	selector: #fileOutMessage]]
		ifNotNil: [
			aMenu addList:#(
				('Browse full (b)' 						browseMethodFull)
				('Browse hierarchy (h)'					classHierarchy)
				-
				('FileOut (o)'							fileOutMessage)
				('Copy selector (c)'						copySelector)).
			aMenu addList: #(
				-
				('Browse senders (n)'						browseSendersOfMessages)
				('Browse implementors (m)'					browseMessages)
				('Inheritance (i)'						methodHierarchy)
				('Versions (v)'							browseVersions)) ].
	^ aMenu
! !

!MCCodeTool methodsFor: 'menus' stamp: ''!
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: ''!
browseSendersOfMessages
	"Present a menu of the currently selected message, as well as all messages sent by it.  Open a message set browser of all senders of the selector chosen."

	self systemNavigation browseAllSendersOf: (self selectedMessageName ifNil: [ ^nil ])! !

!MCConfiguration commentStamp: ''!
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: 'accessing' stamp: ''!
log
	^log ifNil: [Transcript]! !

!MCConfiguration methodsFor: 'accessing' stamp: ''!
dependencies: aCollection
	dependencies := aCollection! !

!MCConfiguration methodsFor: 'logging' stamp: ''!
logError: aString
	self log
		cr; nextPutAll: 'ERROR: ';
		nextPutAll: aString; cr;
		flush.
! !

!MCConfiguration methodsFor: 'actions' stamp: ''!
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: 'logging' stamp: ''!
logWarning: aString
	self log
		cr; nextPutAll: 'WARNING: ';
		nextPutAll: aString; cr;
		flush.
! !

!MCConfiguration methodsFor: 'actions' stamp: ''!
upgrade
	^self class upgradeIsMerge
		ifTrue: [self upgradeByMerging]
		ifFalse: [self upgradeByLoading]! !

!MCConfiguration methodsFor: 'accessing' stamp: ''!
log: aStream
	log := aStream.! !

!MCConfiguration methodsFor: 'private' stamp: ''!
suppressMergeDialogWhile: aBlock
	^aBlock 
		on: MCMergeResolutionRequest
		do: [:request | request autoMerge ]! !

!MCConfiguration methodsFor: 'accessing' stamp: ''!
fileName
	^ self name, '.', self writerClass extension
! !

!MCConfiguration methodsFor: 'private' stamp: ''!
mergeVersionsSilently: aCollection

	^self suppressMergeDialogWhile: [self mergeVersions: aCollection]! !

!MCConfiguration methodsFor: 'accessing' stamp: ''!
summary
	^String streamContents: [:stream |
		self dependencies
			do: [:ea | stream nextPutAll: ea versionInfo name; cr ]]! !

!MCConfiguration methodsFor: 'accessing' stamp: ''!
name: aString
	name := aString! !

!MCConfiguration methodsFor: 'faking' stamp: ''!
changes
	^MCPatch operations: #()! !

!MCConfiguration methodsFor: 'accessing' stamp: ''!
dependencies
	^dependencies ifNil: [dependencies := OrderedCollection new]! !

!MCConfiguration methodsFor: 'testing' stamp: ''!
isCacheable
	^false! !

!MCConfiguration methodsFor: 'actions' stamp: ''!
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: 'private' stamp: ''!
versionNamed: verName for: aDependency from: repo

	| baseName fileName ver |
	(repo filterFileNames: repo cachedFileNames forVersionNamed: verName) ifNotEmpty: [:cachedNames |
		fileName := cachedNames anyOne.
		ProgressNotification signal: '' extra: 'Using cached ', fileName.
		ver := repo versionFromFileNamed: fileName].
	ver ifNil: [
		baseName := self diffBaseFor: aDependency.
		(baseName notNil and: [baseName ~= verName and: [repo includesVersionNamed: baseName]]) ifTrue: [
			fileName := (MCDiffyVersion nameForVer: verName base: baseName), '.mcd'.
			ProgressNotification signal: '' extra: 'Downloading ', fileName.
			ver := repo versionFromFileNamed: fileName]].
	ver ifNil: [
		fileName := verName, '.mcz'.
		ProgressNotification signal: '' extra: 'Downloading ', fileName.
		ver := repo versionFromFileNamed: fileName].
	^ver! !

!MCConfiguration methodsFor: 'faking' stamp: ''!
info
	^MCVersionInfo new! !

!MCConfiguration methodsFor: 'private' stamp: ''!
mergeVersions: aCollection

	| merger |
	aCollection isEmpty ifTrue: [^0].
	merger := MCVersionMerger new.
	aCollection do: [:each | merger addVersion: each].
	merger mergeWithNameLike: self nameForChangeset.
	^ aCollection size! !

!MCConfiguration methodsFor: 'actions' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	super initialize.
	log := DefaultLog.! !

!MCConfiguration methodsFor: 'private' stamp: ''!
loadVersions: aCollection

	| loader |
	aCollection isEmpty ifTrue: [^0].
	loader := MCVersionLoader new.
	aCollection do: [:each | loader addVersion: each].
	loader loadWithNameLike: self nameForChangeset.
	^ aCollection size! !

!MCConfiguration methodsFor: 'logging' stamp: ''!
logUpdate: aPackage with: aVersion
	self log
		cr; nextPutAll: ('========== <1s> ==========' expandMacrosWith: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: ('>>> <1s> <<<' expandMacrosWith:ver name) ; cr;
							nextPutAll: ver message; cr; flush]]]! !

!MCConfiguration methodsFor: 'copying' stamp: ''!
postCopy
	dependencies := dependencies shallowCopy.
	repositories := repositories shallowCopy.! !

!MCConfiguration methodsFor: 'private' stamp: ''!
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: '*MonticelloGUI' stamp: ''!
browse

	^ (MCConfigurationBrowser new configuration: self) show! !

!MCConfiguration methodsFor: 'actions' stamp: ''!
fileOutOn: aStream
	self writerClass fileOut: self on: aStream! !

!MCConfiguration methodsFor: 'actions' stamp: ''!
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: 'accessing' stamp: ''!
name
	^name! !

!MCConfiguration methodsFor: 'private' stamp: ''!
nameForChangeset
	^self name ifNil: [self class name]! !

!MCConfiguration methodsFor: 'accessing' stamp: ''!
repositories
	^repositories ifNil: [repositories := OrderedCollection new]! !

!MCConfiguration methodsFor: 'updating' stamp: ''!
updateFromImage
	self dependencies: (self dependencies collect: [:dep |
		dep package hasWorkingCopy
			ifTrue: [
				dep package workingCopy in: [:wc |
					MCVersionDependency package: wc package info: wc ancestors first]]
			ifFalse: [dep]]).
! !

!MCConfiguration methodsFor: 'accessing' stamp: ''!
writerClass
	^ MCMcmWriter ! !

!MCConfiguration methodsFor: 'accessing' stamp: ''!
repositories: aCollection
	repositories := aCollection! !

!MCConfiguration methodsFor: 'private' stamp: ''!
diffBaseFor: aDependency
	| wc |
	aDependency package hasWorkingCopy ifFalse: [^nil].
	wc := aDependency package workingCopy.
	wc ancestors ifEmpty: [^nil].
	^wc ancestors first name! !

!MCConfiguration methodsFor: 'private' stamp: ''!
depsSatisfying: selectBlock versionDo: verBlock displayingProgress: progressString
	| repoMap count |
	repoMap := Dictionary new.
	self repositories do: [:repo |
		MCRepositoryGroup default addRepository: repo.
		repo allVersionNames
			ifEmpty: [self logWarning: 'cannot read from ', repo description]
			ifNotEmpty: [:all | all do: [:ver | repoMap at: ver put: repo]]].

	count := 0.
	self dependencies do: [:dep |
		| ver repo |
		ver := dep versionInfo name.
		repo := repoMap 
					at: ver 
					ifAbsent: 
						[self logError: 'Version ', ver, ' not found in any repository'.
						self logError: 'Aborting'.
						^count].
		(selectBlock value: dep) 
			ifTrue: [| new |
					new := self versionNamed: ver for: dep from: repo.
					new ifNil: 
							[self logError: 'Could not download version ', ver, ' from ', repo description.
							self logError: 'Aborting'.
							^count]
						ifNotNil: 
							[ self logUpdate: dep package with: new.
							ProgressNotification signal: '' extra: 'Installing ', ver.
							verBlock value: new.
							count := count + 1]].
		dep package workingCopy repositoryGroup addRepository: repo.
	] displayingProgress: progressString.
	^count! !

!MCConfiguration methodsFor: 'updating' stamp: ''!
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 class methodsFor: 'converting' stamp: ''!
repositoryToArray: aRepository
	^ {aRepository description}! !

!MCConfiguration class methodsFor: 'accessing' stamp: ''!
defaultLog
	"Answer the default configuration log"
	^DefaultLog! !

!MCConfiguration class methodsFor: 'utilities' stamp: ''!
whatChangedFrom: oldConfig to: newConfig on: aStream
	"MCConfiguration
		whatChangedFrom:  ReleaseBuilderPloppDeveloper config20060201PloppBeta
		to:  ReleaseBuilderPloppDeveloper config20060215premaster" 

	| oldDeps |
	oldDeps := Dictionary new.
	oldConfig dependencies do: [:old | oldDeps at: old package put: old].

	newConfig dependencies do: [:new | | old |
		old := oldDeps removeKey: new package ifAbsent: [nil].
		old ifNotNil: [old := old versionInfo].
		self changesIn: new package from: old to: new versionInfo on: aStream.
	].

	oldDeps do: [:old |
		self changesIn: old package from: old versionInfo to: nil on: aStream.
	].
! !

!MCConfiguration class methodsFor: 'converting' stamp: ''!
repositoryFromArray: anArray
	^ MCRepositoryGroup default repositories
		detect: [:repo | repo description = anArray first]
		ifNone: [
			MCHttpRepository
				location: anArray first
				user: ''
				password: '']! !

!MCConfiguration class methodsFor: 'settings' stamp: ''!
upgradeIsMerge: aBoolean
	UpgradeIsMerge := aBoolean! !

!MCConfiguration class methodsFor: 'converting' stamp: ''!
dependencyToArray: aDependency
	^ {
		aDependency package name . 
		aDependency versionInfo name . 
		aDependency versionInfo id asString }! !

!MCConfiguration class methodsFor: 'utilities' stamp: ''!
whatChangedFrom: oldConfig to: newConfig
	"MCConfiguration
		whatChangedFrom: ReleaseBuilderPloppDeveloper config20060201PloppBeta
		to:  ReleaseBuilderPloppDeveloper config20060215premaster"

	self
		whatChangedFrom: oldConfig
		to: newConfig
		on: Smalltalk tools transcript! !

!MCConfiguration class methodsFor: 'converting' stamp: ''!
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: 'accessing' stamp: ''!
defaultLog: aStream
	"Set the default configuration log"
	DefaultLog := aStream.! !

!MCConfiguration class methodsFor: 'utilities' stamp: ''!
changesIn: aPackage from: oldInfo to: newInfo on: aStream
	| printBlock newVersion |
	(newInfo = oldInfo)
		ifTrue: [^self].
	aStream cr; nextPutAll: '----------------- ', aPackage name, ' ------------------'; cr.

	newInfo 
		ifNil: [^aStream cr; nextPutAll: 'REMOVED'; cr].

	oldInfo 
		ifNil: [^aStream cr; nextPutAll: 'ADDED'; cr].

	"get actual version for full ancestry"
	newVersion := MCRepositoryGroup default versionWithInfo: newInfo.

	printBlock := [:ver | 
		aStream cr; 
			nextPutAll: (ver name copyAfterLast: $-);
			nextPutAll:  ' (', (ver date printFormat: #(1 2 0 $. 1 1 2)), ', '.
		ver time print24: true showSeconds: false on: aStream.
		aStream nextPutAll: ')'; cr; 
			nextPutAll: ver message; cr].

	(newVersion info hasAncestor: oldInfo)
		ifTrue: [(newVersion info allAncestorsOnPathTo: oldInfo)
			reverseDo: printBlock].
	newVersion info in: printBlock.
	aStream flush! !

!MCConfiguration class methodsFor: 'instance creation' stamp: ''!
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: ''!
upgradeIsMerge
	^ UpgradeIsMerge ifNil: [UpgradeIsMerge := false]! !

!MCConfigurationBrowser commentStamp: ''!
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: 'dependencies' stamp: ''!
selectedPackage
	^ self selectedDependency ifNotNil: [:dep | dep package]! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: ''!
dependencies: aCollection
	self configuration dependencies: aCollection.
	self changed: #dependencyList; changed: #description
! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: ''!
repositoryIndex: anInteger
	repositoryIndex := anInteger.
	repositoryIndex > 0
		ifTrue: [self dependencyIndex: 0].
	self changed: #repositoryIndex; changed: #description.
	self changedButtons.! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: ''!
configuration
	^configuration ifNil: [configuration := MCConfiguration new]! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: ''!
pickRepository
	^self pickRepositorySatisfying: [:ea | true]
! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: ''!
repositoryMenu: aMenu
	^self fillMenu: aMenu fromSpecs: #(
		('Add repository...' addRepository)
	)! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
upgrade
	self configuration upgrade.
	self changed: #dependencyList; changed: #description
! !

!MCConfigurationBrowser methodsFor: 'dependencies' stamp: ''!
checkDependencies
	^self checkModified and: [self checkMissing]! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: ''!
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: 'description' stamp: ''!
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: 'morphic ui' stamp: ''!
pickConfig
	self pickRepository ifNotNil: [:repo |
		| configs index |
		configs := Cursor wait showWhile: [
			repo allFileNames
				select: [:ea | MCMcmReader canReadFileNamed: ea]
				thenCollect: [:ea | ea copyUpToLast: $.]].
		configs isEmpty ifTrue: [^self inform: 'no configs found in ', repo description].
		configs := configs asSortedCollection: [:a :b |
			(a copyAfterLast: $.) asNumber > (b copyAfterLast: $.) asNumber].
		index := UIManager default chooseFrom: configs title: 'config:' translated.
		index = 0 ifFalse: [^Cursor wait showWhile: [
			repo versionFromFileNamed: (configs at: index), '.', MCMcmReader extension]]].
	^nil! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
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: 'repositories' stamp: ''!
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: ''!
repositoryList
	^self repositories collect: [:ea | ea description]
! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
up
	self canMoveUp
		ifFalse: [ ^ self ].
	self list swap: self index with: self index - 1.
	self index: self index - 1.
	self changedList! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: ''!
maxIndex
	^ self list size! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: ''!
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: 'morphic ui' stamp: ''!
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: ''!
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: 'selection' stamp: ''!
repositoryIndex
	^repositoryIndex ifNil: [0]! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
load
	self configuration load.
	self changed: #dependencyList; changed: #description
! !

!MCConfigurationBrowser methodsFor: 'repositories' stamp: ''!
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: 'morphic ui' stamp: ''!
initialExtent
	^ 350@500! !

!MCConfigurationBrowser methodsFor: 'description' stamp: ''!
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: 'dependencies' stamp: ''!
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: ''!
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: 'actions' stamp: ''!
installMenu

	| menu |
	menu := UIManager default newMenuIn: self for: self.
	menu add: 'load packages' selector: #load.
	menu add: 'merge packages' selector: #merge.
	menu add: 'upgrade packages' selector: #upgrade.
	menu popUpInWorld.! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
updateMenu

	| menu |
	menu := UIManager default
				 newMenuIn: self for: self.
	menu add: 'update from image' selector: #updateFromImage.
	menu add: 'update from repositories' selector: #updateFromRepositories.
	menu popUpInWorld.! !

!MCConfigurationBrowser methodsFor: 'testing' stamp: ''!
includesPackage: aPackage
	^self dependencies anySatisfy: [:each | each package = aPackage]! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
merge
	self configuration merge.
	self changed: #dependencyList; changed: #description
! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: ''!
changedButtons
	self changed: #canMoveDown.
	self changed: #canMoveUp.
	self changed: #canRemove.! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: ''!
configuration: aConfiguration
	configuration := aConfiguration! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: ''!
repositories
	^ self configuration repositories! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: ''!
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: 'selection' stamp: ''!
updateIndex
	self index > 0 ifTrue: [self index: (self index min: self maxIndex)]! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
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 |
			self crTrace: '',aRepository,' storeVersion: ', eachVersion.
			aRepository storeVersion: eachVersion
		]
	]
! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: ''!
changedList
	self dependencyIndex > 0 ifTrue: [ ^ self changed: #dependencyList ].
	self repositoryIndex > 0 ifTrue: [ ^ self repositoryListChanged ].
	self error: 'nothing selected'! !

!MCConfigurationBrowser methodsFor: 'updating' stamp: ''!
updateFromRepositories
	self configuration updateFromRepositories.
	self changed: #dependencyList; changed: #description
! !

!MCConfigurationBrowser methodsFor: 'dependencies' stamp: ''!
selectedDependency
	^ self dependencies at: self dependencyIndex ifAbsent: []! !

!MCConfigurationBrowser methodsFor: 'testing' stamp: ''!
canRemove
	^self index > 0! !

!MCConfigurationBrowser methodsFor: 'dependencies' stamp: ''!
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: 'morphic ui' stamp: ''!
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: 'actions' stamp: ''!
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: 'selection' stamp: ''!
selectDependency: aDependency
	self dependencyIndex: (self dependencies indexOf: aDependency)! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: ''!
dependencies
	^self configuration dependencies
! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
down
	self canMoveDown
		ifFalse: [ ^ self ].
	self list swap: self index with: self index + 1.
	self index: self index + 1.
	self changedList! !

!MCConfigurationBrowser methodsFor: 'dependencies' stamp: ''!
checkModified
	| modified |
	modified := self dependencies select: [:dep |
		dep isFulfilled and: [dep package workingCopy modified]].
	
	^modified isEmpty or: [
		self selectDependency: modified anyOne.
		self confirm: (String streamContents: [:strm |
			strm nextPutAll: 'These packages are modified:'; cr.
			modified do: [:dep | strm nextPutAll: dep package name; cr].
			strm nextPutAll: 'Do you still want to store?'])]
	! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: ''!
dependencyIndex
	^dependencyIndex ifNil: [0]! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: ''!
dependencyIndex: anInteger
	dependencyIndex := anInteger.
	dependencyIndex > 0
		ifTrue: [self repositoryIndex: 0].
	self changed: #dependencyIndex; changed: #description.
	self changedButtons.! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: ''!
selectRepository: aRepository
	self repositoryIndex: (self repositories indexOf: aRepository)! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
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: 'repositories' stamp: ''!
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: 'testing' stamp: ''!
canMoveUp
	^self index > 1! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: ''!
index
	^self dependencyIndex max: self repositoryIndex! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: ''!
list
	self dependencyIndex > 0 ifTrue: [^self dependencies].
	self repositoryIndex > 0 ifTrue: [^self repositories].
	^#()! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
loadMenu

	| menu |
	menu := UIManager default newMenuIn: self for: self.
	menu add: 'update from image' selector: #updateFromImage.
	menu add: 'update from repositories' selector: #updateFromRepositories.
	menu popUpInWorld.
! !

!MCConfigurationBrowser methodsFor: 'repositories' stamp: ''!
selectedRepository
	^ self repositories at: self repositoryIndex ifAbsent: []! !

!MCConfigurationBrowser methodsFor: 'updating' stamp: ''!
updateFromImage
	self configuration updateFromImage.
	self changed: #dependencyList; changed: #description
! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: ''!
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: 'testing' stamp: ''!
canMoveDown
	^self index between: 1 and: self maxIndex - 1 ! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: ''!
remove
	self canRemove
		ifFalse: [ ^ self ].
	self list removeAt: self index.
	self changedList.
	self updateIndex! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: ''!
repositories: aCollection
	^self configuration repositories: aCollection
! !

!MCConfigurationBrowser class methodsFor: 'opening' stamp: ''!
open
	<script>
	^self new show! !

!MCCredentialsRequest commentStamp: ''!
I am used to prompt in a UI indepentent way for a username and a password.
If the user successfully entered the two strings I return an MCServerCredential if not I return nil.!
!MCCredentialsRequest methodsFor: 'exceptiondescription' stamp: ''!
defaultAction
	
	username := UIManager default
			request: self userMessagePrompt
			initialAnswer: self username
			title: 'User' translated.
	(username isNil or: [ username isEmpty ])
		ifTrue: [ ^ nil ].
	password := UIManager default
			requestPassword: self passwordMessagePrompt.
	^ MCServerCredentials user: username password: password! !

!MCCredentialsRequest methodsFor: 'accessing' stamp: ''!
url: anObject
	url := anObject! !

!MCCredentialsRequest methodsFor: 'accessing' stamp: ''!
password: anObject
	password := anObject! !

!MCCredentialsRequest methodsFor: 'accessing' stamp: ''!
url
	^ url! !

!MCCredentialsRequest methodsFor: 'accessing' stamp: ''!
password
	^ password! !

!MCCredentialsRequest methodsFor: 'accessing' stamp: ''!
passwordMessagePrompt
	^ 'Please enter a password for ', self url asString! !

!MCCredentialsRequest methodsFor: 'accessing' stamp: ''!
username: anObject
	username := anObject! !

!MCCredentialsRequest methodsFor: 'accessing' stamp: ''!
username
	^ username! !

!MCCredentialsRequest methodsFor: 'accessing' stamp: ''!
userMessagePrompt
	^ 'Please enter a username for ', self url asString! !

!MCCredentialsRequest class methodsFor: 'signalling' stamp: ''!
signalUrl: aUrl username: username password: password
	^ self new 
		url: aUrl;
		username: username;
		password: password;
		signal! !

!MCCredentialsRequest class methodsFor: 'signalling' stamp: ''!
signalUrl: aUrl
	^ self new 
		url: aUrl;
		signal! !

!MCDataStream commentStamp: ''!
This is the save-to-disk facility. A DataStream can store one or more objects in a persistent form.

To handle objects with sharing and cycles, you must use a
ReferenceStream instead of a DataStream.  (Or SmartRefStream.)  ReferenceStream is typically
faster and produces smaller files because it doesn't repeatedly write the same Symbols.

Here is the way to use DataStream and ReferenceStream:
	rr := ReferenceStream fileNamed: 'test.obj'.
	rr nextPut: <your object>.
	rr close.

To get it back:
	rr := ReferenceStream fileNamed: 'test.obj'.
	<your object> := 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: 'write and read' stamp: 'nil'!
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: '*Monticello-OldDataStreamCompatibility' stamp: ''!
readWordArray
	"PRIVATE -- Read the contents of a WordArray."
	^ WordArray newFromStream: byteStream
	"Size is number of long words."! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
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: 'nil'!
writeString: aString
	"PRIVATE -- Write the contents of a String."

	| length |
	(length := aString size) < 192
		ifTrue: [byteStream nextPut: length]
		ifFalse: 
			[byteStream nextPut: (length byteAt: 4)+192.
			byteStream nextPut: (length byteAt: 3).
			byteStream nextPut: (length byteAt: 2).
			byteStream nextPut: (length byteAt: 1)].
	byteStream nextPutAll: aString asByteArray.! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
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: 'nil'!
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: 'nil'!
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: 'nil'!
objectIfBlocked: anObject
	"We don't do any blocking"

	^ anObject! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
writeFalse: aFalse
    "PRIVATE -- Write the contents of a False."! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
writeNil: anUndefinedObject
    "PRIVATE -- Write the contents of an UndefinedObject."! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
contents
	^byteStream contents! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
writeSymbol: aSymbol
    "PRIVATE -- Write the contents of a Symbol."

    self writeString: aSymbol! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
atEnd
    "Answer true if the stream is at the end."

    ^ byteStream atEnd! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
writeInstance: anObject
    "PRIVATE -- Write the contents of an arbitrary instance."

    ^ anObject storeDataOn: self! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
readClass
	^ self error: 'Classes cannot be materialized with DataStream'! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
writeClass: aClass
    ^ self error: 'Classes cannot be serialized with DataStream'! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
byteStream
	^ byteStream! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
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: 'nil'!
next
	"Answer the next object in the stream."
	| type selector anObject  internalObject |

	type := byteStream next.
	type ifNil: [
		byteStream close.	"clean up"
		byteStream position = 0 
			ifTrue: [self error: 'The file did not exist in this directory'] 
			ifFalse: [self error: 'Unexpected end of object file'].
		^ nil].
	type = 0 ifTrue: [
		byteStream close.	"clean up"
		self error: 'Expected start of object, but found 0'.
		^ nil].

	selector := self class readSelectors at: type 
		ifAbsent:[ 
				byteStream close.
				self error: 'Unrecognised type id. You should load the Monticello-OldDataStreamCompatibility package'
		].
	
	anObject := self perform: selector. "A method that recursively
		calls next (readArray, readInstance, objectAt:) must save &
		restore the current reference position."

		"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.
	^ self maybeBeginReference: internalObject! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
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."
	
	^ self class 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: '*Monticello-OldDataStreamCompatibility' stamp: ''!
readBitmap
	"PRIVATE -- Read the contents of a Bitmap."
	^ Bitmap newFromStream: byteStream
	"Note that the reader knows that the size is in long words, but the data is in bytes."! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
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: 'other' stamp: 'nil'!
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: 'nil'!
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: 'other' stamp: 'nil'!
size
    "Answer the stream's size."

    ^ byteStream size! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
readTrue
    "PRIVATE -- Read the contents of a True."

    ^ true! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
setCurrentReference: refPosn
    "PRIVATE -- Set currentReference to refPosn.
     Noop here. Cf. ReferenceStream."! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
writeInteger: anInteger
	"PRIVATE -- Write the contents of a SmallInteger."

	byteStream nextInt32Put: anInteger	"signed!!!!!!!!!!"! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
readSymbol
    "PRIVATE -- Read the contents of a Symbol."
    ^ self readString asSymbol! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
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: 'nil'!
readInteger
    "PRIVATE -- Read the contents of a SmallInteger."

    ^ byteStream nextInt32	"signed!!!!!!"! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
readNil
    "PRIVATE -- Read the contents of an UndefinedObject."

    ^ nil! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
writeByteArray: aByteArray
	"PRIVATE -- Write the contents of a ByteArray."

	byteStream nextNumber: 4 put: aByteArray size.
	"May have to convert types here..."
	byteStream nextPutAll: aByteArray.! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
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: '*Monticello-OldDataStreamCompatibility' stamp: ''!
writeFloat: aFloat
	"PRIVATE -- Write the contents of a Float.
	  We support 8-byte Floats here."

	byteStream nextNumber: 4 put: (aFloat at: 1).
	byteStream nextNumber: 4 put: (aFloat at: 2).
! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
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: '*Monticello-OldDataStreamCompatibility' stamp: ''!
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: '*Monticello-OldDataStreamCompatibility' stamp: ''!
readStringOld

   ^ byteStream nextStringOld! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
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: 'nil'!
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 := self class writeSelectors at: typeID.
	self perform: selector with: objectToStore.

	^ anObject! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
setStream: aStream
	"PRIVATE -- Initialization method."

	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: 'nil'!
close
	"Close the stream."

	| bytes |
	byteStream closed 
		ifFalse: [
			bytes := byteStream position.
			byteStream close]
		ifTrue: [bytes := 'unknown'].
	^ bytes! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
writeTrue: aTrue
    "PRIVATE -- Write the contents of a True."! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
flush
    "Guarantee that any writes to me are actually recorded on disk."

    ^ byteStream flush! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
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: 'initialization' stamp: 'nil'!
reset
    "Reset the stream."

    byteStream reset! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
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' stamp: 'nil'!
maybeBeginReference: internalObject
	"Do nothing.  See ReferenceStream|maybeBeginReference:"

	^ internalObject! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
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: 'nil'!
readFalse
    "PRIVATE -- Read the contents of a False."

    ^ false! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
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: '*Monticello-OldDataStreamCompatibility' stamp: ''!
readFloat
	"PRIVATE -- Read the contents of a Float.
	 This is the fast way to read a Float.
	 We support 8-byte Floats here.  Non-IEEE"

	| new |
	new := Float new: 2.		"To get an instance"
	new at: 1 put: (byteStream nextNumber: 4).
	new at: 2 put: (byteStream nextNumber: 4).
	^ new! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
readUser
	"Reconstruct both the private class and the instance.  Still used??"
	^ self readInstance.		"Will create new unique class"
! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
beginReference: anObject
    "We're starting to read anObject. Remember it and its reference
     position (if we care; ReferenceStream cares). Answer the
     reference position."

    ^ 0! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
errorWriteReference: anInteger
    "PRIVATE -- Raise an error because this case of nextPut:'s perform:
     shouldn't be called."

    self error: 'This should never be called'! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
getCurrentReference
    "PRIVATE -- Return the currentReference posn.
     Overridden by ReferenceStream."

    ^ 0! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
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: '*Monticello-OldDataStreamCompatibility' stamp: ''!
readByteArray
	"PRIVATE -- Read the contents of a ByteArray."

	| count |
	count := byteStream nextNumber: 4.
	^ byteStream next: count  "assume stream is in binary mode"
! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
rootObject: anObject
	"Return the object at the root of the tree we are filing out.  "

	topCall := anObject! !

!MCDataStream methodsFor: 'other' stamp: 'nil'!
rootObject
	"Return the object at the root of the tree we are filing out.  "

	^ topCall! !

!MCDataStream methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
writeWordLike: aWordArray
	"Note that we put the class name before the size."

	self nextPut: aWordArray class name.
	aWordArray writeOn: byteStream
	"Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!!  Reader must know that size is in long words or double-bytes."! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
readArray
	"PRIVATE -- Read the contents of an Array.
	 We must do beginReference: here after instantiating the Array
	 but before reading its contents, in case the contents reference
	 the Array. beginReference: will be sent again when we return to
	 next, but that's ok as long as we save and restore the current
	 reference position over recursive calls to next."
	| count array refPosn |

	count := byteStream nextNumber: 4.

	refPosn := self beginReference: (array := Array new: count).		"relative pos"
	1 to: count do: [:i |
		array at: i put: self next].
	self setCurrentReference: refPosn.		"relative pos"
	^ array! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
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: 'nil'!
readString

	| length aByteArray |
	length := byteStream next.		"first byte."
	length >= 192 ifTrue: [length := length - 192.
		1 to: 3 do: [:ii | length := length * 256 + byteStream next]].
	aByteArray := ByteArray new: length.

	byteStream nextInto: aByteArray.
	
	"An ascii string..."
	^ aByteArray asString.! !

!MCDataStream methodsFor: 'write and read' stamp: 'nil'!
writeArray: anArray
	"PRIVATE -- Write the contents of an Array."

	byteStream nextNumber: 4 put: anArray size.
	self nextPutAll: anArray.! !

!MCDataStream class methodsFor: 'instance creation' stamp: 'nil'!
detectFile: aBlock do: anotherBlock
	^ aBlock value
		ifNotNil: [ :file | 
			[ anotherBlock value: file ]
				ensure: [ file close ] ]! !

!MCDataStream class methodsFor: 'initialize-release' stamp: 'nil'!
readSelectors
	ReadSelectors ifNil: [ self initializeTypeMap ].
	^ReadSelectors ! !

!MCDataStream class methodsFor: 'instance creation' stamp: 'nil'!
new
	^ self basicNew! !

!MCDataStream class methodsFor: 'initialize-release' stamp: 'nil'!
registerClass: aClass atIndex: anIndex usingReadSelector: readSelector usingWriteSelector: writeSelector
	self typeMap at: aClass put: anIndex.
	self readSelectors at: anIndex put: readSelector.
	self writeSelectors at: anIndex put: writeSelector! !

!MCDataStream class methodsFor: 'initialize-release' stamp: 'nil'!
initialize
	self initializeTypeMap ! !

!MCDataStream class methodsFor: 'instance creation' stamp: 'nil'!
readOnlyFileNamed:  aString
	"Here is the way to use DataStream and ReferenceStream:
	
	|rr|
	rr := ReferenceStream fileNamed: 'test.obj'.
	rr nextPut: 'Zork'.
	rr close.
"

	^ self on: aString asFileReference binaryReadStream! !

!MCDataStream class methodsFor: 'instance creation' stamp: 'nil'!
on: aStream
	"Open a new DataStream onto a low-level I/O stream."

	^ self basicNew setStream: aStream
! !

!MCDataStream class methodsFor: 'initialize-release' stamp: 'nil'!
typeMap
	TypeMap ifNil: [ self initializeTypeMap ].
	^ TypeMap! !

!MCDataStream class methodsFor: 'instance creation' stamp: 'nil'!
readOnlyFileNamed: fileName do: aBlock
	"Returns the result of aBlock."
	
	^ self detectFile: [ self readOnlyFileNamed: fileName ] do: aBlock! !

!MCDataStream class methodsFor: 'instance creation' stamp: 'nil'!
fileNamed: fileName do: aBlock
	"Returns the result of aBlock."
	
	^ self detectFile: [ self fileNamed: fileName ] do: aBlock! !

!MCDataStream class methodsFor: 'initialize-release' stamp: 'nil'!
writeSelectors
	WriteSelectors ifNil: [ self initializeTypeMap ].
	^ WriteSelectors! !

!MCDataStream class methodsFor: 'instance creation' stamp: 'nil'!
newFileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:
	|rr|
	rr := ReferenceStream fileNamed: 'test.obj'.
	rr nextPut: 'Zork'.
	rr close.
"
	| fileReference |
	fileReference := aString asFileReference.
	fileReference exists ifTrue: [ FileExists signalWith: fileReference ].
	^ self on: fileReference binaryWriteStream! !

!MCDataStream class methodsFor: 'initialize-release' stamp: 'nil'!
registerReaderSelector: aSelector atIndex: index
	self readSelectors at: index put: aSelector! !

!MCDataStream class methodsFor: 'initialize-release' stamp: 'nil'!
initializeTypeMap
	"TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats.  nextPut: writes these IDs to the data stream.  NOTE: Changing these type ID numbers will invalidate all extant data stream files.  Adding new ones is OK.  
	Classes named here have special formats in the file.  If such a class has a subclass, it will use type 9 and write correctly.  It will just be slow.  (Later write the class name in the special format, then subclasses can use the type also.)
	 See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:"

	"MCDataStream initialize"

	TypeMap := WeakKeyDictionary new: 80.	"sparse for fast hashing"
	ReadSelectors := WeakValueDictionary new: 80.
	WriteSelectors := WeakValueDictionary new: 80.

	"These are all the type ids used in serialization and deserealization. The Missing types id are optional for Monticello, see package 
	Monticello-OldDataStreamCompatibility for the registering of the older types ids."
	self
		registerClass: UndefinedObject
		atIndex: 1
		usingReadSelector: #readNil
		usingWriteSelector: #writeNil:.
	self
		registerClass: True
		atIndex: 2
		usingReadSelector: #readTrue
		usingWriteSelector: #writeTrue:.
	self
		registerClass: False
		atIndex: 3
		usingReadSelector: #readFalse
		usingWriteSelector: #writeFalse:.
	self
		registerClass: SmallInteger
		atIndex: 4
		usingReadSelector: #readInteger
		usingWriteSelector: #writeInteger:.
	self
		registerClass: ByteSymbol
		atIndex: 6
		usingReadSelector: #readSymbol
		usingWriteSelector: #writeSymbol:.
	self
		registerClass: Array
		atIndex: 8
		usingReadSelector: #readArray
		usingWriteSelector: #writeArray:.
	"Type id 9 is special."
	self registerReaderSelector: #readInstance atIndex: 9.
	self registerWriterSelector: #writeInstance: atIndex: 9.
	
	self
		registerClass: ByteString
		atIndex: 17
		usingReadSelector: #readString
		usingWriteSelector: #writeString:.
		
	self registerClass: WideString
		atIndex: 20
		usingReadSelector: #readWordLike
		usingWriteSelector: #writeWordLike:! !

!MCDataStream class methodsFor: 'instance creation' stamp: 'nil'!
fileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:

| rr |
rr := ReferenceStream fileNamed: 'test.obj'.
rr nextPut: 'Zork'.
rr close.
"

	^ self on: aString asFileReference binaryWriteStream! !

!MCDataStream class methodsFor: 'instance creation' stamp: 'nil'!
oldFileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:

	|rr |
	rr := ReferenceStream oldFileNamed: 'test.obj'.
	^ rr nextAndClose.
"

	| strm fileReference |
	fileReference := aString asFileReference.
	fileReference exists ifFalse: [ ^ nil ].
	strm := self on: fileReference binaryWriteStream.
	^ strm! !

!MCDataStream class methodsFor: 'instance creation' stamp: 'nil'!
streamedRepresentationOf: anObject

	| file |
	file := (ByteArray new: 5000) writeStream.
	(self on: file) nextPut: anObject.
	^file contents! !

!MCDataStream class methodsFor: 'cleanup' stamp: 'nil'!
cleanUp
	"Re-initialize DataStream to avoid hanging onto obsolete classes"

	self initialize! !

!MCDataStream class methodsFor: 'initialize-release' stamp: 'nil'!
registerWriterSelector: aSelector atIndex: anIndex
	self writeSelectors at: anIndex put: aSelector! !

!MCDataStreamTest methodsFor: 'accessing' stamp: ''!
testFileName
	^ self class name,'_', testSelector , '_test'! !

!MCDataStreamTest methodsFor: 'testing' stamp: ''!
testFileNamed
	| testString fileName |
	"Given"
	fileName := self testFileName.
	testString := 'testString'.
	"When"
	[  MCDataStream fileNamed: fileName do: [ :streamType | streamType nextPut: testString ].
	"Then"
	 MCDataStream readOnlyFileNamed: fileName do: [ :streamType | self assert: streamType next equals: testString ] ]
		ensure: [ (FileSystem disk workingDirectory / fileName) ensureDelete ]! !

!MCDataStreamTest methodsFor: 'testing' stamp: ''!
testReadOnlyFileNamed
	| testString fileName file |
	"Given"
	fileName := self testFileName.
	testString := 'testString'.
	"When"
	[ MCDataStream fileNamed: fileName do: [ :streamType | streamType nextPut: testString ].
	"Then"
	file := MCDataStream readOnlyFileNamed: fileName.
	self assert: file next equals: testString.
	file close ]
		ensure: [ fileName asFileReference delete ]! !

!MCDefinition commentStamp: ''!
A MCDefinition is the root of inheritance of entities representing code. !
!MCDefinition methodsFor: 'installing' stamp: 'nil'!
loadOver: aDefinition
	self load
	! !

!MCDefinition methodsFor: 'printing' stamp: 'nil'!
summarySuffixOver: previousDefinition
	^self source = previousDefinition source
		ifTrue: [ ' (source same but rev changed)' ]
		ifFalse: [ ' (changed)' ]! !

!MCDefinition methodsFor: 'comparing' stamp: 'nil'!
<= other
	^ self sortKey <= other sortKey! !

!MCDefinition methodsFor: 'comparing' stamp: 'nil'!
= aDefinition
	^(aDefinition isKindOf: MCDefinition) and: [self isRevisionOf: aDefinition]! !

!MCDefinition methodsFor: '*Ring-Monticello' stamp: ''!
ensureRingDefinitionIn: anRGEnvironment package: anRGPackage
	
	"by default do not set the package"

	^ self ensureRingDefinitionIn: anRGEnvironment.
	! !

!MCDefinition methodsFor: 'accessing' stamp: 'nil'!
fullClassName
	"Answer the className by default."
	
	^self className! !

!MCDefinition methodsFor: 'comparing' stamp: 'nil'!
hash
	^ self description hash! !

!MCDefinition methodsFor: 'comparing' stamp: 'nil'!
isRevisionOf: aDefinition
	^ (aDefinition isKindOf: MCDefinition) and: [aDefinition description = self description]! !

!MCDefinition methodsFor: 'accessing' stamp: 'nil'!
description
	self subclassResponsibility! !

!MCDefinition methodsFor: 'accessing' stamp: 'nil'!
requirements
	^ #()! !

!MCDefinition methodsFor: '*MonticelloTonel-Core' stamp: ' 1/5/2022 20:56:19'!
isTraitDefinition
	^ false! !

!MCDefinition methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: '(', self summary, ')'! !

!MCDefinition methodsFor: 'testing' stamp: 'nil'!
isClassDefinition
	^false! !

!MCDefinition methodsFor: 'accessing' stamp: 'nil'!
source
	^ self subclassResponsibility.! !

!MCDefinition methodsFor: 'printing' stamp: 'nil'!
summary
	self subclassResponsibility ! !

!MCDefinition methodsFor: 'installing' stamp: 'nil'!
postloadOver: aDefinition
	self postload! !

!MCDefinition methodsFor: '*Ring-Monticello' stamp: ''!
authorForStamp: stamp
	
	^ stamp isEmptyOrNil
		ifTrue: [ '<historical>']
		ifFalse: [ stamp substrings first].! !

!MCDefinition methodsFor: 'testing' stamp: 'nil'!
isClassDefinitionExtension
	"Answer true if this definition extends the regular class definition"
	^false! !

!MCDefinition methodsFor: '*Ring-Monticello' stamp: ''!
timeForStamp: stamp

	^ stamp
		ifNil: [ 	DateAndTime new]
		ifNotNil: [ 
			| substrings |
			substrings := stamp substrings.
			([(DateAndTime fromString: (' ' join: substrings allButFirst ))] on: Exception do: [DateAndTime epoch]) ]. 
	! !

!MCDefinition methodsFor: 'annotations' stamp: 'nil'!
printAnnotations: requests on: aStream
	"Add a string for an annotation pane, trying to fulfill the browser annotationRequests."

	aStream nextPutAll: 'not yet implemented'! !

!MCDefinition methodsFor: '*Iceberg-Changes' stamp: ''!
addAnalysisToPackageChangeSet: aPackageChangeSet change: aChange
	aPackageChangeSet addChange: aChange! !

!MCDefinition methodsFor: 'accessing' stamp: 'nil'!
className
	"Answer the class name here or nil if not applicable."
	
	^nil! !

!MCDefinition methodsFor: '*Ring-Monticello' stamp: ''!
traitCompositionFrom: aStringOrNil parent: aBehavior
	
	| composition transformations |
	
	composition := RGTraitComposition parent: aBehavior.

	aStringOrNil ifNil: [ ^ composition ].

	transformations := RGTraitCompositionVisitor new parse: aStringOrNil for: composition.
	transformations do: [ :each |
		composition addTransformation: each ].
	^ composition! !

!MCDefinition methodsFor: '*Iceberg-changes' stamp: ''!
isFileDefinition
	
	^ false! !

!MCDefinition methodsFor: 'installing' stamp: 'nil'!
load
	! !

!MCDefinition methodsFor: 'accessing' stamp: 'nil'!
provisions
	^ #()! !

!MCDefinition methodsFor: 'installing' stamp: 'nil'!
addMethodAdditionTo: aCollection
	self load! !

!MCDefinition methodsFor: 'comparing' stamp: 'nil'!
isSameRevisionAs: aDefinition
	^ self = aDefinition! !

!MCDefinition methodsFor: 'installing' stamp: 'nil'!
unload! !

!MCDefinition methodsFor: '*Ring-Monticello' stamp: ''!
ensureRingDefinitionIn: anRGEnvironment

	"do nothing by default"! !

!MCDefinition methodsFor: 'comparing' stamp: 'nil'!
fullTimeStamp
	^ DateAndTime current! !

!MCDefinition methodsFor: '*Iceberg-Changes' stamp: ''!
addToPackageDiff: anIcePackageDiff leftSnapshot: anObject rightSnapshot: anObject1 
	
	self subclassResponsibility! !

!MCDefinition methodsFor: 'installing' stamp: 'nil'!
postload! !

!MCDefinition methodsFor: 'testing' stamp: 'nil'!
isMethodDefinition
	^false! !

!MCDefinition methodsFor: 'accessing' stamp: 'nil'!
actualClass
	"Since the targetClass call on a patch operation will fail
	otherwise."
	
	^nil! !

!MCDefinition methodsFor: 'accessing' stamp: 'nil'!
definition

	^ self! !

!MCDefinition methodsFor: 'testing' stamp: 'nil'!
isOrganizationDefinition
	^false! !

!MCDefinition methodsFor: 'testing' stamp: 'nil'!
isScriptDefinition
	^false! !

!MCDefinition methodsFor: '*Iceberg-Changes' stamp: ''!
buildOn: anIceDiffBuilder
	
	self subclassResponsibility! !

!MCDefinition methodsFor: 'accessing' stamp: 'nil'!
diffSource
	^ self source! !

!MCDefinition methodsFor: 'comparing' stamp: 'nil'!
sortKey
	self subclassResponsibility ! !

!MCDefinitionIndex commentStamp: ''!
I'm a simple container of MCDefinitions which can be added or removed.!
!MCDefinitionIndex methodsFor: 'adding' stamp: 'nil'!
add: aDefinition
	^ definitions at: aDefinition description put: aDefinition! !

!MCDefinitionIndex methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	definitions := Dictionary new! !

!MCDefinitionIndex methodsFor: 'accessing' stamp: 'nil'!
definitionLike: aDefinition ifPresent: foundBlock ifAbsent: errorBlock
	| definition |
	definition := definitions at: aDefinition description ifAbsent: [].
	^ definition
		ifNil: errorBlock
		ifNotNil: [foundBlock value: definition]! !

!MCDefinitionIndex methodsFor: 'accessing' stamp: 'nil'!
definitions
	^ definitions values! !

!MCDefinitionIndex methodsFor: 'removing' stamp: 'nil'!
remove: aDefinition
	definitions removeKey: aDefinition description ifAbsent: []! !

!MCDefinitionIndex methodsFor: 'adding' stamp: 'nil'!
addAll: aCollection
	aCollection do: [:ea | self add: ea]! !

!MCDefinitionIndex class methodsFor: 'instance creation' stamp: 'nil'!
definitions: aCollection
	^ self new addAll: aCollection! !

!MCDependencySorter commentStamp: ''!
A MCDependencySorter computes the dependencies to a set of entities.!
!MCDependencySorter methodsFor: 'private' stamp: 'nil'!
addProvision: anObject
	| newlySatisfied |
	provided add: anObject.
	newlySatisfied := required removeKey: anObject ifAbsent: [#()].
	self addAll: newlySatisfied.! !

!MCDependencySorter methodsFor: 'building' stamp: 'nil'!
add: anItem
	| requirements |
	requirements := self unresolvedRequirementsFor: anItem.
	requirements isEmpty
		ifTrue: [self addToOrder: anItem]
		ifFalse: [self addRequirements: requirements for: anItem].
	^ anItem! !

!MCDependencySorter methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	provided := Set new.
	required := Dictionary new.
	orderedItems := OrderedCollection new.! !

!MCDependencySorter methodsFor: 'private' stamp: 'nil'!
itemsRequiring: anObject
	^ required at: anObject ifAbsentPut: [Set new]! !

!MCDependencySorter methodsFor: 'building' stamp: 'nil'!
addExternalProvisions: aCollection
	(aCollection intersection: self externalRequirements)
		do: [:ea | self addProvision: ea]! !

!MCDependencySorter methodsFor: 'private' stamp: 'nil'!
addRequirement: reqObject for: itemObject
	(self itemsRequiring: reqObject) add: itemObject! !

!MCDependencySorter methodsFor: 'private' stamp: 'nil'!
addToOrder: anItem
	orderedItems add: anItem.
	anItem provisions do: [:ea | self addProvision: ea].! !

!MCDependencySorter methodsFor: 'accessing' stamp: 'nil'!
externalRequirements
	| unloaded providedByUnloaded |
	unloaded := self itemsWithMissingRequirements.
	providedByUnloaded := (unloaded flatCollect: [:e | e provisions]) asSet.
	^ required keys reject: [:ea | providedByUnloaded includes: ea ]! !

!MCDependencySorter methodsFor: 'building' stamp: 'nil'!
addAll: aCollection
	aCollection asArray sort do: [:ea | self add: ea]! !

!MCDependencySorter methodsFor: 'private' stamp: 'nil'!
unresolvedRequirementsFor: anItem
	^ anItem requirements difference: provided! !

!MCDependencySorter methodsFor: 'private' stamp: 'nil'!
addRequirements: aCollection for: anObject
	aCollection do: [:ea | self addRequirement: ea for: anObject]! !

!MCDependencySorter methodsFor: 'sorting' stamp: 'nil'!
orderedItems
	^ orderedItems! !

!MCDependencySorter methodsFor: 'accessing' stamp: 'nil'!
itemsWithMissingRequirements
	| items |
	items := Set new.
	required do: [:ea | items addAll: ea].
	^ items
! !

!MCDependencySorter class methodsFor: 'public' stamp: 'nil'!
sortItems: aCollection
	| sorter |
	sorter := self items: aCollection.
	sorter externalRequirements do: [:req  | sorter addProvision: req].
	^ sorter orderedItems.! !

!MCDependencySorter class methodsFor: 'instance creation' stamp: 'nil'!
items: aCollection
	^ self new addAll: aCollection! !

!MCDependencySorterTest methodsFor: 'tests' stamp: ''!
testCycle
	self assertItems: #(
		(a (x) (y))
		(b (y) (x)))
	orderAs: #()
	withRequired: #()
	toLoad: #(a b)	! !

!MCDependencySorterTest methodsFor: 'tests' stamp: ''!
testMultiRequirementOrdering
	self assertItems: #(
		(a (x) (z))
		(b (y) ())
		(c (z) ())
		(d () (x y z)))
		orderAs: #(b c a d)
		withRequired: #()
		toLoad: #()! !

!MCDependencySorterTest methodsFor: 'asserting' stamp: ''!
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 equals: depOrder.
	missing := sorter externalRequirements.
	self assert: missing asSet equals: missingDeps asSet.
	unloadable := (sorter itemsWithMissingRequirements collect: [ :ea | ea name ]) asArray.
	self assert: unloadable asSet equals: unloadableItems asSet! !

!MCDependencySorterTest methodsFor: 'tests' stamp: ''!
testSimpleOrdering
	self assertItems: #((a (x) ())
								 (c () (y))
								 (b (y) (x)))
		orderAs: #(a b c)
		withRequired: #()
		toLoad: #()! !

!MCDependencySorterTest methodsFor: 'building' stamp: ''!
itemWithSpec: anArray
	^ MCMockDependentItem new
		name: anArray first;
		provides: anArray second;
		requires: anArray third! !

!MCDependencySorterTest methodsFor: 'tests' stamp: ''!
testUnusedAlternateProvider
	self assertItems: #(
		(a (x) (z))
		(b () (x))
		(c (x) ()))
	orderAs: #(c b)
	withRequired: #(z)
	toLoad: #(a)	! !

!MCDependencySorterTest methodsFor: 'asserting' stamp: ''!
assertItems: anArray orderAs: depOrder withRequired: missingDeps toLoad: unloadableItems
	self assertItems: anArray orderAs: depOrder withRequired: missingDeps  toLoad: unloadableItems  extraProvisions: #()! !

!MCDependencySorterTest methodsFor: 'tests' stamp: ''!
testSimpleUnresolved
	self assertItems: #(
		(a () (z)))
	orderAs: #()
	withRequired: #(z)
	toLoad: #(a)
		! !

!MCDependencySorterTest methodsFor: 'tests' stamp: ''!
testCascadingUnresolved
	self assertItems: #(
		(a (x) (z))
		(b () (x))
		(c () ()))
	orderAs: #(c)
	withRequired: #(z)
	toLoad: #(a b)	! !

!MCDependencySorterTest methodsFor: 'tests' stamp: ''!
testExtraProvisions
	self assertItems:
		#((a (x) (z))
		(b () (x)))
	orderAs: #(a b)
	withRequired: #()
	toLoad: #()	
	extraProvisions: #(x z)! !

!MCDependencySorterTest class methodsFor: 'testing' stamp: ''!
isUnitTest
	^false! !

!MCDependentsWrapper commentStamp: ''!
Specialized list item wrapper for dependents!
!MCDependentsWrapper methodsFor: 'comparing' stamp: ''!
= anMCDependentsWrapper

	self class = anMCDependentsWrapper class ifFalse: [^ false].
	^ (self item package name = anMCDependentsWrapper item package name) and: [self model = anMCDependentsWrapper model].
! !

!MCDependentsWrapper methodsFor: 'accessing' stamp: ''!
hasContents
	^item requiredPackages isEmpty not! !

!MCDependentsWrapper methodsFor: 'comparing' stamp: ''!
hash
	^ (self item package name hash * 37) + self model hash 
! !

!MCDependentsWrapper methodsFor: 'converting' stamp: ''!
asString
	^item description! !

!MCDependentsWrapper methodsFor: 'accessing' stamp: ''!
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]! !

!MCDictionaryRepository commentStamp: ''!
A dictionary repository (in nemory)!
!MCDictionaryRepository methodsFor: '*Gofer-Core' stamp: ''!
goferPriority
	^ 10! !

!MCDictionaryRepository methodsFor: 'comparing' stamp: 'nil'!
= other
	^ self == other! !

!MCDictionaryRepository methodsFor: 'accessing' stamp: 'nil'!
dictionary: aDictionary

	dict := aDictionary! !

!MCDictionaryRepository methodsFor: 'comparing' stamp: 'nil'!
hash

	^ self identityHash! !

!MCDictionaryRepository methodsFor: 'interface' stamp: 'nil'!
includesVersionNamed: aString
	^ dict anySatisfy: [:ea | ea info name = aString]! !

!MCDictionaryRepository methodsFor: 'initialization' stamp: 'nil'!
initialize

	super initialize.
	dict := Dictionary new.
! !

!MCDictionaryRepository methodsFor: 'storing' stamp: 'nil'!
basicStoreVersion: aVersion
	dict at: aVersion info put: aVersion! !

!MCDictionaryRepository methodsFor: '*Metacello-MC' stamp: ''!
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: 'accessing' stamp: 'nil'!
description: aString

	description := aString ! !

!MCDictionaryRepository methodsFor: 'accessing' stamp: 'nil'!
dictionary

	^ dict! !

!MCDictionaryRepository methodsFor: 'accessing' stamp: 'nil'!
description

	^ description ifNil: ['cache']! !

!MCDictionaryRepository methodsFor: '*MonticelloGUI' stamp: ''!
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: 'accessing' stamp: 'nil'!
sortedVersionInfos
	| sorter |
	sorter := MCVersionSorter new.
	self allVersionInfos do: [:ea | sorter addVersionInfo: ea].
	^ sorter sortedVersionInfos
! !

!MCDictionaryRepository methodsFor: '*metacello-platform' stamp: ''!
possiblyNewerVersionsOfAnyOf: versionNames 

	^#()! !

!MCDictionaryRepository methodsFor: 'interface' stamp: 'nil'!
versionWithInfo: aVersionInfo ifAbsent: errorBlock
	^ dict at: aVersionInfo ifAbsent: errorBlock! !

!MCDictionaryRepository methodsFor: 'accessing' stamp: 'nil'!
allVersionInfos
	^ dict values collect: [:ea | ea info]! !

!MCDictionaryRepository methodsFor: 'accessing' stamp: 'nil'!
versionFrom: aVersionReferenceString
	^ self dictionary detect: [ :version | version info name = aVersionReferenceString ]! !

!MCDictionaryRepository methodsFor: 'testing' stamp: 'nil'!
includesVersionWithInfo: aVersionInfo
	^ dict includesKey: aVersionInfo! !

!MCDictionaryRepository methodsFor: '*Gofer-Core' stamp: ''!
goferReferences
	^ self allVersionInfos collect: [ :each | GoferResolvedReference name: each name repository: self ]! !

!MCDictionaryRepository methodsFor: '*Metacello-MC' stamp: ''!
asRepositorySpecFor: aMetacelloMCProject

	| desc |
	desc := self description.
	desc ifNil: [ desc := 'dictionary://Metacello_Dictionary' ].
	^(aMetacelloMCProject repositorySpec)
		description:  desc;
	 	type: 'dictionary';
		yourself! !

!MCDictionaryRepository methodsFor: 'accessing' stamp: 'nil'!
closestAncestorVersionFor: anAncestry ifNone: errorBlock
	^ anAncestry breadthFirstAncestors
		detect: [ :ea | self includesVersionWithInfo: ea ]
		ifFound: [ :info | self versionWithInfo: info ]
		ifNone: errorBlock! !

!MCDictionaryRepository class methodsFor: '*Metacello-MC' stamp: ''!
createRepositoryFromSpec: aRepositorySpec on: aPlatform
	^ aPlatform createDictionaryRepository: aRepositorySpec! !

!MCDictionaryRepository class methodsFor: '*Metacello-MC' stamp: ''!
isAvailableFor: type
	^ type = 'dictionary'! !

!MCDictionaryRepositoryTest methodsFor: 'utilities' stamp: ''!
deleteNode: aNode
	dict removeKey: aNode! !

!MCDictionaryRepositoryTest methodsFor: 'utilities' stamp: ''!
dictionary
	^ dict ifNil: [dict := Dictionary new]! !

!MCDictionaryRepositoryTest methodsFor: 'actions' stamp: ''!
addVersion: aVersion
	dict at: aVersion info put: aVersion! !

!MCDictionaryRepositoryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	repository :=  MCDictionaryRepository new dictionary: self dictionary! !

!MCDiffyVersion commentStamp: ''!
A diffy version!
!MCDiffyVersion methodsFor: 'accessing' stamp: 'nil'!
baseInfo
	^ base! !

!MCDiffyVersion methodsFor: 'operations' stamp: 'nil'!
baseSnapshot
       | baseVersion |
       baseVersion := self workingCopy repositoryGroup versionWithInfo: base.
       baseVersion ifNil: [ self error: 'Missing snapshot: ', self baseInfo name].
       ^ baseVersion snapshot! !

!MCDiffyVersion methodsFor: 'initialization' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
fileName
	^ (self class nameForVer: info name base: base name), '.', self writerClass extension! !

!MCDiffyVersion methodsFor: 'accessing' stamp: 'nil'!
summary
	^ '(Diff against ', self baseInfo name, ')', String cr, super summary! !

!MCDiffyVersion methodsFor: 'accessing' stamp: 'nil'!
writerClass
	^ MCMcdWriter ! !

!MCDiffyVersion methodsFor: 'accessing' stamp: 'nil'!
patch
	^ patch! !

!MCDiffyVersion methodsFor: 'accessing' stamp: 'nil'!
snapshot
	^ snapshot ifNil: [snapshot := MCPatcher apply: patch to: self baseSnapshot]! !

!MCDiffyVersion methodsFor: 'testing' stamp: 'nil'!
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: 'testing' stamp: 'nil'!
isDiffy
	^ true! !

!MCDiffyVersion class methodsFor: 'instance creation' stamp: 'nil'!
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: 'nil'!
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: 'nil'!
canonicalNameFor: aFileName
	^(self nameForVer: (self verNameFrom: aFileName)
		base: (self baseNameFrom: aFileName))
			, '.', MCMcdReader extension
! !

!MCDiffyVersion class methodsFor: 'name utilities' stamp: 'nil'!
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: 'nil'!
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: 'nil'!
verNameFrom: diffName
	^diffName copyUpTo: $(! !

!MCDirectoryRepository commentStamp: ''!
A metacello repository in a directory !
!MCDirectoryRepository methodsFor: 'testing' stamp: 'nil'!
includesFileNamed: aString
	"HACK: speed up the cache hits"
	^ (directory / aString) exists.! !

!MCDirectoryRepository methodsFor: '*Gofer-Core' stamp: ''!
goferPriority
	^ 5! !

!MCDirectoryRepository methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	directory := FileSystem workingDirectory! !

!MCDirectoryRepository methodsFor: 'accessing' stamp: 'nil'!
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: 'comparing' stamp: 'nil'!
hash
	^ directory hash! !

!MCDirectoryRepository methodsFor: 'testing' stamp: 'nil'!
includesVersionNamed: aString
	"avoid slow default implementation and directly check for existing files"
	^ (self allFileNamesForVersionNamed: aString) isEmpty not! !

!MCDirectoryRepository methodsFor: 'interface' stamp: 'nil'!
loadAllFileNames
	^ (directory entries sort: [:a :b | a modificationTime >= b modificationTime]) collect: [:ea | ea basename]! !

!MCDirectoryRepository methodsFor: 'accessing' stamp: 'nil'!
directory: aDirectory
	directory := aDirectory! !

!MCDirectoryRepository methodsFor: 'accessing' stamp: 'nil'!
description
	^ directory fullName! !

!MCDirectoryRepository methodsFor: 'i/o' stamp: 'nil'!
writeStreamForFileNamed: aString replace: shouldReplace do: aBlock

	| file |
	file := directory / aString.

	shouldReplace ifTrue: [ file ensureDelete ].

	file binaryWriteStreamDo: aBlock! !

!MCDirectoryRepository methodsFor: 'accessing' stamp: 'nil'!
directory
	^ directory! !

!MCDirectoryRepository methodsFor: 'loading' stamp: 'nil'!
pathForFileNamed: aFileName
  ^ (directory / aFileName) fullName! !

!MCDirectoryRepository methodsFor: 'testing' stamp: 'nil'!
isValid
	^directory exists! !

!MCDirectoryRepository methodsFor: '*Metacello-MC' stamp: ''!
asRepositorySpecFor: aMetacelloMCProject
  ""

  ^ directory asRepositorySpecFor: aMetacelloMCProject! !

!MCDirectoryRepository methodsFor: '*MonticelloGUI' stamp: ''!
openAndEditTemplateCopy
	^self class morphicConfigure! !

!MCDirectoryRepository methodsFor: 'i/o' stamp: 'nil'!
readStreamForFileNamed: aString do: aBlock
	| val |
	directory / aString binaryReadStreamDo: [ :stream|
		val := aBlock value: stream ].
	^ val! !

!MCDirectoryRepository class methodsFor: 'accessing' stamp: 'nil'!
defaultDirectoryName
	^ DefaultDirectoryName ifNil: [ FileSystem workingDirectory fullName].! !

!MCDirectoryRepository class methodsFor: '*Metacello-MC' stamp: ''!
createRepositoryFromSpec: aRepositorySpec on: aPlatform
	^ aPlatform createDirectoryRepository: aRepositorySpec! !

!MCDirectoryRepository class methodsFor: 'accessing' stamp: 'nil'!
description
	^ 'directory'! !

!MCDirectoryRepository class methodsFor: '*Metacello-MC' stamp: ''!
isAvailableFor: type
	^ type = 'directory'! !

!MCDirectoryRepository class methodsFor: 'accessing' stamp: 'nil'!
defaultDirectoryName: aDirectoryName
	DefaultDirectoryName := aDirectoryName.! !

!MCDirectoryRepository class methodsFor: 'instance creation' stamp: 'nil'!
morphicConfigure
	^ (UIManager default chooseDirectoryFrom: self defaultDirectoryName asFileReference) ifNotNil:
		[:directory |
		self new directory: directory]! !

!MCDirectoryRepositoryTest methodsFor: 'running' stamp: ''!
tearDown

	self directory ensureDeleteAll.
	super tearDown! !

!MCDirectoryRepositoryTest methodsFor: 'accessing' stamp: ''!
directory
	directory ifNil:
		[directory := 'mctest' asFileReference.
		directory ensureCreateDirectory].
	^ directory! !

!MCDirectoryRepositoryTest methodsFor: 'actions' stamp: ''!
addVersion: aVersion
	
	(directory / aVersion fileName) asFileReference
		binaryWriteStreamDo: [ :stream |
			aVersion fileOutOn: stream ]! !

!MCDirectoryRepositoryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	repository := MCDirectoryRepository new directory: self directory! !

!MCDoItParser commentStamp: ''!
A MCDoItParser is a simple 'parser' which understand the addDefinitionsTo: message. Each parser can use the source
and add definitions to the list of entities that is passed to them.

MCDoitParser invokes automatically its subclasses to parse the correct source.

Each Doit entities (entities which are defined as doits) extend this entry point to add specific behavior.!
!MCDoItParser methodsFor: 'accessing' stamp: 'nil'!
source
	^ source! !

!MCDoItParser methodsFor: 'accessing' stamp: 'nil'!
source: aString
	source := aString! !

!MCDoItParser methodsFor: 'actions' stamp: 'nil'!
addDefinitionsTo: aCollection
	self subclassResponsibility ! !

!MCDoItParser class methodsFor: 'private' stamp: 'nil'!
concreteSubclasses
	^ self allSubclasses reject: [:c | c isAbstract]! !

!MCDoItParser class methodsFor: 'instance creation' stamp: 'nil'!
subclassForDoit: aString
	^ self concreteSubclasses detect: [:ea | ea pattern match: aString] ifNone: []! !

!MCDoItParser class methodsFor: 'instance creation' stamp: 'nil'!
forDoit: aString
	^ (self subclassForDoit: aString) ifNotNil: [:c | c new source: aString]! !

!MCDoItParser class methodsFor: 'testing' stamp: 'nil'!
isAbstract
	^ self pattern isNil! !

!MCDoItParser class methodsFor: 'factory identification hook' stamp: 'nil'!
pattern
	"return a pattern matching expression to identify the parser corresponding to the expression.
	Subclasses should specialize it."

	^ nil! !

!MCFileBasedRepository commentStamp: ''!
A file based metacello repository!
!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
allFileNames
	cacheFileNames == true ifFalse: [ ^ self loadAllFileNames ].
	^ allFileNames ifNil: [
			allFileNames := self loadAllFileNames]! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
filterFileNames: aCollection forVersionNamed: aString
	^ aCollection select: [:ea | (self versionNameFromFileName: ea) = aString] ! !

!MCFileBasedRepository methodsFor: 'private' stamp: 'nil'!
flushCache
	cache := nil! !

!MCFileBasedRepository methodsFor: 'caching' stamp: 'nil'!
resizeCache: aDictionary
	[aDictionary size <= self maxCacheSize] whileFalse:
		[aDictionary removeKey: aDictionary keys atRandom]! !

!MCFileBasedRepository methodsFor: 'private' stamp: 'nil'!
updateCachedVersionFromFileName: aString with: aVersion
	self resizeCache: cache.
	(aVersion notNil and: [aVersion isCacheable]) ifTrue: [cache at: aString put: aVersion].
! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
allFileNamesForVersionNamed: aString
	^ self filterFileNames: self readableFileNames forVersionNamed: aString! !

!MCFileBasedRepository methodsFor: 'testing' stamp: 'nil'!
includesVersionNamed: aString
	^ self allVersionNames includes: aString! !

!MCFileBasedRepository methodsFor: 'interface' stamp: 'nil'!
loadAllFileNames
	self subclassResponsibility! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
readableFileNames
	| all cached new emptyFilenamelength |
	"<hyphenated-package-name>.<dotted.branch.tag>-<initials>.<count>.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"
	
	"Another stupid way to remove filename when using filetree repositories."
	all := all reject: [ :each | each beginsWith: '.filetree' ].
	
	cached := self cachedFileNames.	"in memory"
	new := all difference: cached.
	^ (cached asArray, new)
		select: [:ea | self canReadFileNamed: ea]! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
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: '*MonticelloFileTree-Core' stamp: ''!
retrieveVersionsWithPackageNames: packageNames
	| packageDescriptions |
	packageDescriptions := self packageDescriptionsFromReadableFileNames.
	packageNames addAll: (packageDescriptions collect: [ :packageDescription | packageDescription first ]).
	^ packageDescriptions select: [ :each | (each at: 3) isNumber ]! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
cache
	^ cache ifNil: [cache := Dictionary new]! !

!MCFileBasedRepository methodsFor: 'loading' stamp: 'nil'!
pathForFileNamed: aFileName
  ^ aFileName! !

!MCFileBasedRepository methodsFor: '*Gofer-Core' stamp: ''!
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: 'accessing' stamp: 'nil'!
allVersionNames
	^ self readableFileNames collect: [:ea | self versionNameFromFileName: ea]! !

!MCFileBasedRepository methodsFor: 'loading' stamp: 'nil'!
notCachedVersionWithInfo: aVersionInfo 
	(self allFileNamesForVersionNamed: aVersionInfo name)
		do: [ :fileName | 
			| version |
			version := self versionFromRepositoryFromFileNamed: fileName.
			version info = aVersionInfo
				ifTrue: [ ^ version ] ].
	^ nil! !

!MCFileBasedRepository methodsFor: 'adding' stamp: 'nil'!
addVersionInformationExtractedFrom: readableFileName to: versions
	| name |
	name := (readableFileName copyUpToLast: $.) copyUpTo: $(.
	name last isDigit
		ifTrue: [ 
			versions
				add:
					{(name copyUpToLast: $-).	"pkg name"
					((name copyAfterLast: $-) copyUpTo: $.).	"user"
					(((name copyAfterLast: $-) copyAfter: $.) asInteger ifNil: [ 0 ]).	"version"
					readableFileName }]! !

!MCFileBasedRepository methodsFor: 'private' stamp: 'nil'!
loadNotCachedVersionFromFileNamed: aString
	
	^ self versionReaderForFileNamed: aString do: [:r | r version]! !

!MCFileBasedRepository methodsFor: 'private' stamp: 'nil'!
loadVersionFromFileNamed: aString

	(MCCacheRepository uniqueInstance includesFileNamed: aString)
		ifTrue: [ ^ MCCacheRepository uniqueInstance loadVersionFromFileNamed: aString].
	
	^ self versionReaderForFileNamed: aString do: [:r | r version]! !

!MCFileBasedRepository methodsFor: 'testing' stamp: 'nil'!
includesFileNamed: aString
	"slow default implementation"
	^ self allFileNames includes: aString! !

!MCFileBasedRepository methodsFor: '*MonticelloFileTree-Core' stamp: ''!
packageDescriptionsFromReadableFileNames
	^ self readableFileNames
		collect: [ :each | 
			| name |
			name := (each copyUpToLast: $.) copyUpTo: $(.
			name last isDigit
				ifFalse: [ 
					{name.
					''.
					''.
					each} ]
				ifTrue: [ 
					| packageName author versionNumber |
					packageName := name copyUpToLast: $-.
					author := (name copyAfterLast: $-) copyUpTo: $..
					versionNumber := ((name copyAfterLast: $-) copyAfter: $.) asInteger ifNil: [ 0 ].
					{packageName.
					author.
					versionNumber.
					each} ] ]! !

!MCFileBasedRepository methodsFor: '*Metacello-MC' stamp: ''!
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: '*MonticelloGUI' stamp: ''!
morphicOpen: aWorkingCopy
	(MCFileRepositoryInspector repository: self workingCopy: aWorkingCopy)
		show! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
versionFromFileNamed: aFileName
	| version |
	version := self cache
			 at: aFileName 
			 ifAbsent: [ self loadVersionFromFileNamed: aFileName ].
	self updateCachedVersionFromFileName: aFileName with: version.
	^ version! !

!MCFileBasedRepository methodsFor: 'storing' stamp: 'nil'!
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: 'caching' stamp: 'nil'!
cacheAllFileNamesDuring: aBlock
	cacheFileNames == true ifTrue: [ ^ aBlock value ].
	allFileNames := nil.
	cacheFileNames := true.	
	^ aBlock ensure: [
		allFileNames := nil.
		cacheFileNames := false]! !

!MCFileBasedRepository methodsFor: 'caching' stamp: 'nil'!
cachedFileNames
	^cache == nil
		ifTrue: [#()]
		ifFalse: [cache keys]! !

!MCFileBasedRepository methodsFor: 'storing' stamp: 'nil'!
storeVersion: aVersion

	(self includesFileNamed: aVersion fileName) ifTrue: [ ^ self ].
	^ super storeVersion: aVersion.! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
versionsWithPackageNames
	| versions |
	versions := OrderedCollection new.
	self readableFileNames
		do: [ :each | 
		      self addVersionInformationExtractedFrom: each to: versions ].
	^ versions! !

!MCFileBasedRepository methodsFor: 'testing' stamp: 'nil'!
canReadFileNamed: aString
	| reader |
	reader := MCVersionReader readerClassForFileNamed: aString.
	^ reader notNil! !

!MCFileBasedRepository methodsFor: 'caching' stamp: 'nil'!
maxCacheSize
	^ 512! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
versionNameFromFileName: aFileName
	^ (aFileName copyUpToLast: $.) copyUpTo: $(! !

!MCFileBasedRepository methodsFor: 'loading' stamp: 'nil'!
loadVersionInfoFromFileNamed: aString
	^ self versionReaderForFileNamed: aString do: [:r | r info]
	! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
versionFrom: aVersionReferenceString
	^ self loadVersionFromFileNamed: aVersionReferenceString , '.mcz'! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
versionFromRepositoryFromFileNamed: aFileName
	| version |
	version := self cache
			 at: aFileName 
			 ifAbsent: [ self loadNotCachedVersionFromFileNamed: aFileName ].
	self updateCachedVersionFromFileName: aFileName with: version.
	^ version! !

!MCFileBasedRepository methodsFor: 'actions' stamp: 'nil'!
versionReaderForFileNamed: aString do: aBlock
^ self
		readStreamForFileNamed: aString
		do: [:s |
			(MCVersionReader readerClassForFileNamed: aString) ifNotNil:
				[:class | aBlock value: (class on: s fileName: (self pathForFileNamed: aString))]]! !

!MCFileBasedRepository methodsFor: 'interface' stamp: 'nil'!
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 versionFromRepositoryFromFileNamed: fileName.
				version info = aVersionInfo ifTrue: [^ version]].
			^ errorBlock value].! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
versionInfoFromFileNamed: aFileName
	self cache 
		at: aFileName
		ifPresent: [:version | ^ version info].
	^ self loadVersionInfoFromFileNamed: aFileName! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
allFileNamesOrCache
	cacheFileNames == true ifFalse: [ ^ self allFileNames ].
	^ allFileNames ifNil: [
			allFileNames := self allFileNames]! !

!MCFileBasedRepository methodsFor: 'accessing' stamp: 'nil'!
closestAncestorVersionFor: anAncestry ifNone: errorBlock
	^ self
		cacheAllFileNamesDuring: [ 
			anAncestry breadthFirstAncestorsDo: [ :ancestorInfo | (self notCachedVersionWithInfo: ancestorInfo) ifNotNil: [ :v | ^ v ] ].
			^ errorBlock value ]! !

!MCFileBasedRepository methodsFor: 'storing' stamp: 'nil'!
writeStreamForFileNamed: aString do: aBlock
	^ self writeStreamForFileNamed: aString replace: false do: aBlock! !

!MCFileBasedRepository class methodsFor: 'actions' stamp: 'nil'!
flushAllCaches
	self allSubInstancesDo: [:ea | ea flushCache]! !

!MCFileBasedRepository class methodsFor: 'settings' stamp: 'nil'!
monticelloSettingsOn: aBuilder  
	<systemsettings>  
	(aBuilder group: #monticello)
		label: 'Monticello';
		parent: #SCM;
		description: 'All Monticello settings';
		with: [ 
			(aBuilder setting: #defaultDirectoryName)
				type: #Directory;
				target: MCDirectoryRepository;
				description: 'The path of a directory where you want to start out when choosing local repository locations' ;
				default: FileSystem workingDirectory fullName;
				label: 'Default local repository directory'.
			(aBuilder setting: #cacheDirectory)
				type: #Directory;
				target: MCCacheRepository;
				default: (FileLocator localDirectory / 'package-cache') asFileReference;
				description: 'The path of the local repository cache';
				label: 'Local cache directory'.	
				
				].! !

!MCFileBasedRepository class methodsFor: 'accessing' stamp: 'nil'!
urlSchemes
	^ #(file)! !

!MCFileBasedRepository class methodsFor: 'instance creation' stamp: 'nil'!
basicFromUrl: aZnUrl 
	^ MCDirectoryRepository new directory: aZnUrl asFileReference! !

!MCFileBasedRepository class methodsFor: 'cleanup' stamp: 'nil'!
cleanUp
	"Flush caches"

	self flushAllCaches.! !

!MCFileInTest methodsFor: 'running' stamp: ''!
tearDown
	(diff isNil or: [diff isEmpty not])
		 ifTrue: [expected updatePackage: self mockPackage].
	MCDataStream initialize.
	super tearDown! !

!MCFileInTest methodsFor: 'testing' stamp: ''!
alterInitialState
	self mockClassA touchCVar! !

!MCFileInTest methodsFor: 'asserting' stamp: ''!
assertNoChange
	| actual |
	actual := MCSnapshotResource takeSnapshot.
	diff := actual patchRelativeToBase: expected.
	self assertEmpty: diff! !

!MCFileInTest methodsFor: 'testing' stamp: ''!
assertInitializersOrder
	| initializationOrder |
	initializationOrder := self mockClassA initializationOrder.
	self assert: initializationOrder equals: 2! !

!MCFileInTest methodsFor: 'testing' stamp: ''!
assertInitializersCalled
	| cvar |
	cvar := self mockClassA cVar.
	self assert: cvar equals: #initialized! !

!MCFileInTest methodsFor: 'testing' stamp: ''!
assertSuccessfulLoadWith: aBlock
	stream reset.
	aBlock value.
	self assertNoChange.
	self assertInitializersCalled.
	self assertInitializersOrder! !

!MCFileInTest methodsFor: 'testing' stamp: ''!
testStWriter
	
	self
		assertFileOutFrom: MCStWriter
		canBeFiledInWith: [ CodeImporter evaluateReadStream: stream readStream].
! !

!MCFileInTest methodsFor: 'testing' stamp: ''!
assertFileOutFrom: writerClass canBeFiledInWith: aBlock
	(writerClass on: stream) writeSnapshot: self mockSnapshot.
	self alterInitialState.
	self assertSuccessfulLoadWith: aBlock.
	self mockPackage unload.
	self assertSuccessfulLoadWith: aBlock.
! !

!MCFileInTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	expected := self mockSnapshot.
	stream := ReadWriteStream on: ''! !

!MCFileRepositoryInspector commentStamp: ''!
I'm a monticello tool composed of three panes to browse repositories and the packages they contain. You get an instance of me when you click on a repository in Monticello browser and press open. 

My left pane presents the packages, my right one their versions and the bottom one the commit log of the selected package versions.

I underline the packages you already loaded, and highlight the ones you don't have updated to the last version. I also highlight the versions you did not load yet.

Example: I can browse packages of PharoInbox with:
(MCFileRepositoryInspector 
	repository: (MCHttpRepository
					location: 'http://www.squeaksource.com/PharoInbox'
					user: ''
					password: '')
	workingCopy: nil) show.
	
COTDC - S.Ducasse, G.Polito, L.Laffont!
!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
packageList
	^ packageList ! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageSelection: aNumber
	"Track a package change to have the ancestors list loaded."

	"selectedPackage is the selected package name :("

	selectedPackage := aNumber isZero
		ifFalse: [ (self packageList at: aNumber) asString ].
	selectedPackageAncestors := nil.
	self versionSelection: 0.
	self
		changed: #packageSelection;
		changed: #versionList! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageListMenu: aMenu
	^aMenu! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
refresh
	loadedPackages := Set new.
	versions := repository retrieveVersionsWithPackageNames: Set new.
	newer := Set new.
	loaded := Set new.
	MCWorkingCopy allManagers
		do: [ :workingCopy | | versionsForPackage |
			workingCopy ancestors do: [ :ancestor | loaded add: ancestor name ].
			versionsForPackage := versions select: [ :v | v first = workingCopy package name ].
			versionsForPackage
				do: [ :aVersionArray | 
					workingCopy ancestors
						do: [ :ancestor |
							(ancestor versionNumber < aVersionArray third
								or: [ ancestor versionNumber = aVersionArray third and: [ ancestor author ~= aVersionArray second ] ])
								ifTrue: [ newer add: ancestor name ] ] ] ].
					
	self
		packageListUpdate;
		changed: #versionList! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionList
	| result sortBlock |
	result := selectedPackage 
		ifNil: [ versions ifNil: [ ^ #() ]]
		ifNotNil: [ (versions ifNil: [ ^ #() ]) select: [ :each | selectedPackage = each first ] ].
	sortBlock := (self orderSpecs at: order) value.
	sortBlock ifNotNil: [
		result := result asSortedCollection: [:a :b | [sortBlock value: a value: b] on: Error do: [true]]].
	
	versionPattern ifNotEmpty: [
		result := result select: [ :package| package fourth asLowercase includesSubstring: versionPattern ]].
					
	^ result collect: [ :each | self versionHighlight: each fourth ]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
buttonSpecs
	^#(('Refresh' refresh 'refresh the version-list')
		(Save saveChanges 'Save the local changes')) , super buttonSpecs! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
version
	^ version ifNil:
		[Cursor wait showWhile:
			[version := repository versionFromFileNamed: selectedVersion]]! !

!MCFileRepositoryInspector methodsFor: 'accessing' stamp: ''!
selectedPackageAncestors
	selectedPackageAncestors
		ifNil: [ 
			selectedPackage
				ifNotNil: [ 
					(MCWorkingCopy registry at: (MCPackage named: selectedPackage) ifAbsent: [  ])
						ifNotNil: [ :aWorkingCopy | selectedPackageAncestors := aWorkingCopy ancestry breadthFirstAncestors collect: [:each | each name] ] ] ].
	^ selectedPackageAncestors! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionHighlight: aString

	^ Text
		string: aString
		attribute: (self versionHighlightEmphasis: aString)! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionSearchAccept: string
	| aString |

	aString := string ifNil: [ '' ].
	versionPattern = aString asLowercase ifTrue: [ ^ self ].
	versionPattern := aString asLowercase.

	versionProcess ifNotNil: [ versionProcess terminate ].
	versionProcess := [ self changed: #versionList ] fork.! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
invalidatePackageAncestryCache
	"Invalidate the ancestry cache so the ancestor list is correctly styled/formatted in the version list i.e., underlined if loaded, bold if not loaded"
	selectedPackageAncestors := nil! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionInfo
	^ versionInfo ifNil: [versionInfo := repository versionInfoFromFileNamed: selectedVersion]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^'Repository: ' , repository description! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionSelection
	^self versionList indexOf: selectedVersion! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
saveChanges
	| currentRepository workingCopy |
	
	currentRepository := repository. "This can be changed elsewhere while processing"
	workingCopy := MCWorkingCopy forPackage: (MCPackage new name: selectedPackage).
	(workingCopy newVersionIn: currentRepository) ifNotNil: [:v |
		(MCVersionInspector new version: v) show.
		Cursor wait showWhile: [currentRepository storeVersion: v].
		MCCacheRepository uniqueInstance cacheAllFileNamesDuring: 
			[currentRepository cacheAllFileNamesDuring: 
				[v allAvailableDependenciesDo:
					[:dep |
					(currentRepository includesVersionNamed: dep info name)
						ifFalse: [currentRepository storeVersion: dep]]]]]! !

!MCFileRepositoryInspector methodsFor: 'actions' stamp: ''!
load
	self hasVersion
		ifFalse: [ ^ self ].
	self version isCacheable
		ifTrue: [ version workingCopy repositoryGroup addRepository: repository ].
	super load.
	self invalidatePackageAncestryCache.
	self refresh! !

!MCFileRepositoryInspector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	loaded := Set new.
	loadedPackages := Set new.
	versionPattern := ''.
	packagePattern := ''.
	packageList := #()! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
initialExtent
	^ 640 @ 480! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
order: anInteger
	self class order: (order := anInteger).
	self changed: #versionList.! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
orderString: anIndex
	^String streamContents: [ :stream |
		order = anIndex
			ifTrue: [ stream nextPutAll: '<yes>' ]
			ifFalse: [ stream nextPutAll: '<no>' ].
		stream nextPutAll: (self orderSpecs at: anIndex) key ]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionHighlightEmphasis: aString
	"Appearence. This code attempts to show the following:
		- a currently loaded version of the package: underlined.
		- a version of a not loaded package: bold.
		- a newer version of a loaded package: bold.
		- a version not in the ancestry of the currently loaded and
		selected package: bold.
	All those tests are made on the version name and number, not the package
	UUID, so they are not reliable. The least reliable test is the 'newer' check.
	"

	| versionName packageName |
	versionName := (aString copyUpToLast: $.) copyUpTo: $(.
	packageName := versionName copyUpToLast: $-.
	(packageName includes: $.) ifTrue: [ packageName := packageName copyUpTo: $. ].
	(loaded includes: versionName) ifTrue: [ ^ TextEmphasis underlined ].
	selectedPackage = packageName
		ifTrue: [ self selectedPackageAncestors
				ifNotNil: [ ^ (selectedPackageAncestors includes: versionName)
						ifTrue: [ TextEmphasis normal ]
						ifFalse: [ TextEmphasis bold ] ] ].
	(newer includes: versionName) ifTrue: [ ^ TextEmphasis bold ].
	(loadedPackages includes: packageName) ifFalse: [ ^ TextEmphasis bold ].
	^ TextEmphasis normal! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionListMenu: aMenu
	1 to: self orderSpecs size do: [ :index |
		aMenu addUpdating: #orderString: target: self selector: #order: argumentList: { index } ].
	^aMenu! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageSearchField
	^ SearchMorph new
		model: self;
		setIndexSelector: #packageSearchAccept:;
		updateSelector: #packageSearchAccept:;
		searchList: self class packageSearchList;
		yourself! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
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:selection:menu:icon: . #packageList . #packageSelection . #packageListMenu: . #packageIcon:}.{0. 0. 0.5. 0.6}. {0. searchBarOffset+3. 0. 0}}.
		
		{{#versionSearchField}.   {0.5. 0. 1. 0}.   {0. 30. 0. searchBarOffset}}.
		{{#listMorph:. #version}. {0.5. 0. 1. 0.6}. {0. searchBarOffset+3. 0. 0.}}.
		
		{{#textMorph:. #summary}. {0. 0.6. 1. 1}.   {0. 0. 0. 0.}}}! !

!MCFileRepositoryInspector methodsFor: 'actions' stamp: ''!
merge
	super merge.
	self invalidatePackageAncestryCache.
	self refresh.
! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
hasVersion
	^ selectedVersion notNil! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionSearchField
	^ SearchMorph new
		model: self;
		setIndexSelector: #versionSearchAccept:;
		updateSelector: #versionSearchAccept:;
		searchList: self class versionSearchList;
		yourself! !

!MCFileRepositoryInspector methodsFor: 'accessing' stamp: ''!
setRepository: aFileBasedRepository workingCopy: aWorkingCopy
	order := self class order.
	repository := aFileBasedRepository.
	
	aWorkingCopy
		ifNil: [ selectedPackage := self packageList isEmpty ifFalse: [self packageList first asString]]
		ifNotNil: [ selectedPackage := aWorkingCopy ancestry ancestorString copyUpToLast: $-.
			selectedPackage ifEmpty: [
				selectedPackage := aWorkingCopy package name ]]. 
	
	[ self refresh.
	MCWorkingCopy addDependent: self.] fork.
! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageIcon: aPackage
	| p |
	newer ifNil: [ newer := #() ].
	(loaded anySatisfy: [ :each | each beginsWith: aPackage , '-' ])
		ifFalse: [ ^ self iconNamed: #emptyPackageIcon ].

	"If newer collection includes our package it means we have an older mcz version loaded"
	(newer anySatisfy: [ :each | each beginsWith: aPackage , '-' ])
		ifTrue: [ ^ self iconNamed: #newerPackagesAvailableIcon ].
	p := RPackageOrganizer default
		packageNamed: aPackage
		ifAbsent: [ nil ].
	p ifNil: [ ^ self iconNamed: #emptyPackageIcon ].
	^ p isDirty
		ifFalse: [ self iconNamed: #packageIcon ]
		ifTrue: [ self iconNamed: #dirtyPackageIcon ]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageSelection
	^self packageList ifNotNil: [
		^ self packageList indexOf: selectedPackage
	]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageListUpdate
	| result packageNames |	
	
	"Within fork, make no changes to object state until end with assignment wrapped by #defer:"
	
	packageListUpdateProcess ifNotNil: [ packageListUpdateProcess terminate ].	
	packageListUpdateProcess := 
	[	versions ifNotNil: 
		[	result := Set new: versions size.
			versions do: [ :each | result add: each first ].
			
			"sort loaded packages first, then alphabetically"
			packageNames := Set new: loaded size.
			loaded do: [ :each |
				packageNames add: (each copyUpToLast: $-). ].
			
			result := result asArray sort: [ :a :b |
				| loadedA loadedB |
				loadedA := packageNames includes: a.
				loadedB := packageNames includes: b.
				loadedA = loadedB 
					ifTrue: [ a < b ]
					ifFalse: [ loadedA ] ].
	
			packagePattern ifNotEmpty: [
				result := result select: [ :packageName |  packageName asLowercase includesSubstring: packagePattern ]].
			 
			UIManager default defer:
			[	packageList := result.
				self changed: #packageList.
				self changed: #versionList.
			]
		]
	] fork.! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageSearchAccept: string
	| aString |

	aString := string ifNil: [ '' ].
	packagePattern = aString asLowercase ifTrue: [ ^ self ].
	packagePattern :=  aString asLowercase.

   	self packageListUpdate.! !

!MCFileRepositoryInspector class methodsFor: 'accessing' stamp: ''!
order: anInteger
	Order := anInteger! !

!MCFileRepositoryInspector class methodsFor: 'accessing' stamp: ''!
order
	^ Order ifNil: [ Order := 5 ]! !

!MCFileRepositoryInspector class methodsFor: 'accessing' stamp: ''!
packageSearchList
	^ packageSearchList ifNil: [ packageSearchList := OrderedCollection new] ! !

!MCFileRepositoryInspector class methodsFor: 'instance creation' stamp: ''!
repository: aFileBasedRepository workingCopy: aWorkingCopy
	^self new
		setRepository: aFileBasedRepository workingCopy: aWorkingCopy;
		yourself! !

!MCFileRepositoryInspector class methodsFor: 'accessing' stamp: ''!
versionSearchList
	^ versionSearchList ifNil: [ versionSearchList := OrderedCollection new ] ! !

!MCFileTreeAbstractReader commentStamp: ''!
Abstract reader superclass for FileTree!
!MCFileTreeAbstractReader methodsFor: 'utilities' stamp: ''!
definitionFromFile: directoryEntry inDirectory: aDirectory
    | defs reader |
    directoryEntry ifNil: [ ^ nil ].
    self fileUtils
        readStreamFor: directoryEntry name
        in: aDirectory
        do: [ :fileStream |
            reader := MCStReader on: fileStream.
            defs := reader definitions.
		defs size <= 1
                ifFalse: [ self error: 'we should be writing exactly 1 definition per file' ] ].
    defs size = 0
        ifTrue: [ ^ nil ].
    ^ defs first! !

!MCFileTreeAbstractReader methodsFor: 'accessing' stamp: ''!
fileUtils
    ^ MCFileTreeFileUtils current! !

!MCFileTreeAbstractReader methodsFor: 'accessing' stamp: ''!
monticelloMetaDirName
    ^ self class monticelloMetaDirName! !

!MCFileTreeAbstractReader methodsFor: 'utilities' stamp: ''!
addClassAndMethodDefinitionsFromDirectoryEntries: entries
	| timestamp |
	self noMethodMetaData
		ifTrue: [ timestamp := self info author , ' ' , self info date mmddyyyy , ' '
				, self info time print24 ].
	entries
		do: [ :element | 
			element isDirectory
				ifTrue: [ | directory |
					directory := self fileUtils directoryFromEntry: element.
					((self separateMethodMetaAndSource or: [ self noMethodMetaData ])
						ifTrue: [ self loadableDefinitionsFrom: directory ]
						ifFalse: [ directory entries ])
						do: [ :file | 
							| definition |
							(definition := self
								definitionFromFile: file
								inDirectory: directory)
								ifNotNil: [ definition isMethodDefinition
										ifTrue: [ self separateMethodMetaAndSource
												ifTrue: [ directory
														fileNamed: definition selector asString , '.meta'
														do:
															[ :fileStream | definition setTimeStamp: (Author fixStamp: fileStream contents) ] ].
											self noMethodMetaData
												ifTrue: [ definition setTimeStamp: timestamp ] ].
									definitions add: definition ] ] ] ]! !

!MCFileTreeAbstractReader methodsFor: 'utilities' stamp: ''!
addDefinitionFromFile: directoryEntry inDirectory: aDirectory
    (self definitionFromFile: directoryEntry inDirectory: aDirectory) ifNotNil: [ :def | definitions add: def ]! !

!MCFileTreeAbstractReader methodsFor: 'testing' stamp: ''!
noMethodMetaData
    ^ self packageProperties at: 'noMethodMetaData' ifAbsent: [ false ]! !

!MCFileTreeAbstractReader methodsFor: 'utilities' stamp: ''!
loadDependencies
    | dependencyDir directoryPath |
    directoryPath := self monticelloMetaDirName , self fileUtils pathNameDelimiter asString , 'dependencies'.
    dependencyDir := self fileUtils directoryFromPath: directoryPath relativeTo: packageDirectory.
    (self fileUtils directoryExists: dependencyDir)
        ifFalse: [ ^ dependencies := #() ].
    dependencies := OrderedCollection new.
    dependencyDir entries
        do: [ :entry | 
            dependencies
                add:
                    (MCVersionDependency
                        package: (MCPackage named: entry name)
                        info:
                            (self extractInfoFrom: (self parseMember: 'dependencies' , self fileUtils pathNameDelimiter asString , entry name))) ].
    dependencies := dependencies asArray! !

!MCFileTreeAbstractReader methodsFor: 'testing' stamp: ''!
separateMethodMetaAndSource
    ^ self packageProperties at: 'separateMethodMetaAndSource' ifAbsent: [ false ]! !

!MCFileTreeAbstractReader methodsFor: 'testing' stamp: ''!
hasMonticelloMetadata
    ^ (self fileUtils
		filePathExists: 'version'
		relativeTo:
			(self fileUtils
				directoryFromPath: MCFileTreeStCypressWriter monticelloMetaDirName
				relativeTo: packageDirectory))
		or:
			[ (self fileUtils
				filePathExists: 'version'
				relativeTo: packageDirectory)
				and:
					[ self fileUtils
						filePathExists: 'package'
						relativeTo: packageDirectory ] ]
! !

!MCFileTreeAbstractReader methodsFor: 'utilities' stamp: ''!
addClassAndMethodDefinitionsFromDirectory: aDirectory
    self subclassResponsibility! !

!MCFileTreeAbstractReader methodsFor: 'utilities' stamp: ''!
isLoadableDefinitionFile: entry

	"Reject hidden files"
	(entry name beginsWith: '.') ifTrue: [ ^ false ].

	^ entry name endsWith: '.st'! !

!MCFileTreeAbstractReader methodsFor: 'utilities' stamp: ''!
loadableDefinitionsFrom: directory
	^ directory entries select: [ :entry | self isLoadableDefinitionFile: entry ]! !

!MCFileTreeAbstractReader methodsFor: 'accessing' stamp: ''!
basicVersion
	^ (MCVersion new)
		setPackage: self package
			info: self info
			snapshot: self snapshot
			dependencies: self dependencies;
		yourself! !

!MCFileTreeAbstractReader methodsFor: 'utilities' stamp: ''!
loadDefinitions
    | entries |
    definitions := OrderedCollection new.
    entries := packageDirectory entries.
    self
        addDefinitionFromFile: (entries detect: [ :entry | entry name beginsWith: 'categories' ] ifNone: [  ])
            inDirectory: packageDirectory;
        addClassAndMethodDefinitionsFromDirectory: packageDirectory;
        addDefinitionFromFile: (entries detect: [ :entry | entry name beginsWith: 'initializers' ] ifNone: [  ])
            inDirectory: packageDirectory! !

!MCFileTreeAbstractReader methodsFor: 'accessing' stamp: ''!
packageProperties
    packageProperties
        ifNil: [ 
            packageProperties := Dictionary new.
            (packageDirectory entries detect: [ :entry | entry name = '.filetree' ] ifNone: [  ])
                ifNotNil: [ :configEntry | 
                    configEntry
                        readStreamDo: [ :fileStream | 
                            | jsonObject structureVersion |
                            [ 
                            (jsonObject := STON fromStream: fileStream) isFloat
                                ifTrue: [ 
                                    "
							0.0 - original structure
							0.1 - separate files for method metaData (timestamp) and source
							0.2 - no method metaData file"
                                    packageProperties := Dictionary new.
                                    structureVersion := jsonObject printShowingDecimalPlaces: 1.
                                    packageProperties at: 'noMethodMetaData' put: structureVersion = '0.2'.
                                    packageProperties at: 'separateMethodMetaAndSource' put: structureVersion = '0.1' ]
                                ifFalse: [ 
                                    packageProperties := jsonObject.
                                    ((packageProperties at: 'noMethodMetaData' ifAbsent: [ false ])
                                        and: [ packageProperties at: 'separateMethodMetaAndSource' ifAbsent: [ false ] ])
                                        ifTrue: [ self error: 'noMethodMetaData and separateMethodMetaAndSource cannot both be true' ] ] ]
                                on: Error
                                do: [ :ex | 
                                    SystemNotification signal:
                                                'Error reading package properties (.filetree): ' , packageDirectory pathName , ' :: ' , ex description ] ] ] ].
    ^ packageProperties! !

!MCFileTreeAbstractReader methodsFor: 'accessing' stamp: ''!
packageDirectory: aDirectoryName
    packageDirectory := self fileUtils directoryFromPath: aDirectoryName relativeTo: stream! !

!MCFileTreeAbstractReader methodsFor: 'utilities' stamp: ''!
parseMember: fileName
    | directory tokens |
    directory := self fileUtils directoryFromPath: self monticelloMetaDirName relativeTo: packageDirectory.
    self fileUtils readStreamFor: fileName in: directory do: [ :fileStream | tokens := self scanner scan: fileStream ].
    ^ self associate: tokens! !

!MCFileTreeAbstractReader class methodsFor: 'accessing' stamp: ''!
monticelloMetaDirName
    ^ '.'! !

!MCFileTreeAbstractReader class methodsFor: 'reading' stamp: ''!
on: s fileName: f
	^ (self on: s)
		packageDirectory: f;
		yourself! !

!MCFileTreeAbstractStWriter commentStamp: ''!
Abstract superclass for FileTree writers!
!MCFileTreeAbstractStWriter methodsFor: 'writing' stamp: ''!
writeMethodDefinition: definition
    stWriter visitMethodDefinition: definition! !

!MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: ''!
visitMetaclassDefinition: definition
    "handled by class definition"

! !

!MCFileTreeAbstractStWriter methodsFor: 'writing' stamp: ''!
writeTraitDefinition: definition
    stWriter writeClassDefinition: definition.
    definition hasComment 
        ifTrue: [stWriter writeClassComment: definition].! !

!MCFileTreeAbstractStWriter methodsFor: 'initialization' stamp: ''!
initialize
    stWriter := MCFileTreePackageStructureStWriter new
        initializers: (initializers := Set new);
        yourself.
    orderedClassNames := OrderedCollection new.
    orderedTraitNames := OrderedCollection new.! !

!MCFileTreeAbstractStWriter methodsFor: 'private' stamp: ''!
monticelloMetaDirName
    ^ self class monticelloMetaDirName! !

!MCFileTreeAbstractStWriter methodsFor: 'initialization' stamp: ''!
writePropertiesFile
    self
        writeInDirectoryName: '.'
        fileName: ''
        extension: '.filetree'
        visit: [ stWriter writeProperties ]! !

!MCFileTreeAbstractStWriter methodsFor: 'initialize-release' stamp: ''!
writeBasicDefinitions: aCollection
    "the correct initialization order is unknown if some classes are missing in the image"

    self writePropertiesFile.
    stWriter acceptVisitor: self forDefinitions: aCollection.
    self writeInitializers! !

!MCFileTreeAbstractStWriter methodsFor: 'initialization' stamp: ''!
writeDefinitions: aCollection
    "the correct initialization order is unknown if some classes are missing in the image"

    self writeBasicDefinitions: aCollection! !

!MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: ''!
visitClassDefinition: definition
    self subclassResponsibility! !

!MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: ''!
visitScriptDefinition: definition
    self flag: #'skippedForNow'! !

!MCFileTreeAbstractStWriter methodsFor: 'private' stamp: ''!
directoryForDirectoryNamed: directoryNameOrPath
    ^ directoryNameOrPath = '.'
        ifTrue: [ stream packageFileDirectory ]
        ifFalse: [ stream subPackageFileDirectoryFor: directoryNameOrPath ]! !

!MCFileTreeAbstractStWriter methodsFor: 'private' stamp: ''!
repository
  ^ stream repository! !

!MCFileTreeAbstractStWriter methodsFor: 'initialization' stamp: ''!
writeInitializers
    self
        writeInDirectoryName: self monticelloMetaDirName
        fileName: 'initializers'
        extension: '.st'
        visit: [ 
            stWriter
                writePresentInitializers;
                writeAbsentInitializers ]! !

!MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: ''!
visitTraitDefinition: definition
    self subclassResponsibility! !

!MCFileTreeAbstractStWriter methodsFor: 'private' stamp: ''!
setFileStream: file
    stWriter stream: file! !

!MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: ''!
visitOrganizationDefinition: defintion
    self
        writeInDirectoryName: self monticelloMetaDirName
        fileName: 'categories'
        extension: '.st'
        visit: [ defintion categories do: [ :cat | stWriter writeCategory: cat ] ]! !

!MCFileTreeAbstractStWriter methodsFor: 'writing' stamp: ''!
writeClassTraitDefinition: definition
    stWriter visitClassTraitDefinition: definition.
! !

!MCFileTreeAbstractStWriter methodsFor: 'private' stamp: ''!
fileNameForSelector: selector
    ^ (selector == #'/'
        ifTrue: [ 'encoded slash' ]
        ifFalse: [ 
            (selector includes: $/)
                ifTrue: [ 'encoded' , selector copyReplaceAll: '/' with: ' slash ' ]
                ifFalse: [ selector ] ]) asString! !

!MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: ''!
visitMethodDefinition: definition
    self subclassResponsibility! !

!MCFileTreeAbstractStWriter methodsFor: 'writing' stamp: ''!
writeClassDefinition: definition
    stWriter writeClassDefinition: definition.
    (definition hasClassInstanceVariables or: [definition hasClassTraitComposition])
        ifTrue: [ stWriter writeMetaclassDefinition: definition ].
    definition hasComment
        ifTrue: [ stWriter writeClassComment: definition ]! !

!MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: ''!
visitClassTraitDefinition: definition
    self subclassResponsibility! !

!MCFileTreeAbstractStWriter methodsFor: 'accessing' stamp: ''!
fileUtils
    ^ MCFileTreeFileUtils current! !

!MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: ''!
writeInDirectoryName: directoryNameOrPath fileName: fileName extension: ext visit: visitBlock
    | directory |
    directory := self directoryForDirectoryNamed: directoryNameOrPath.
    self fileUtils
        writeStreamFor: fileName , ext
        in: directory
        do: [ :fileStream |
            self setFileStream: (ZnNewLineWriterStream on: fileStream) forLf.
            visitBlock value ]! !

!MCFileTreeAbstractStWriter class methodsFor: 'accessing' stamp: ''!
monticelloMetaDirName
    ^ '.'! !

!MCFileTreeAbstractStWriter class methodsFor: 'writing' stamp: ''!
on: aStream
    MCFileTreePackageStructureStWriter useCypressWriter
        ifTrue: [ ^ MCFileTreeStCypressWriter new stream: aStream ].
    ^ (MCFileTreePackageStructureStWriter useSnapShotWriter
        ifTrue: [ MCFileTreeStSnapshotWriter ]
        ifFalse: [ MCFileTreeStWriter ]) new stream: aStream! !

!MCFileTreeAbstractStWriter class methodsFor: 'accessing' stamp: ''!
readerClass
	^ MCStReader! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
directoryPathString: aDirectory
    ^ aDirectory pathString! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
directoryFromPath: directoryPath relativeTo: aDirectory
    ^ aDirectory resolveString: directoryPath! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
readStreamFor: filePath in: aDirectory do: aBlock
    "temporary hack for Pharo-1.4"

    ^ (aDirectory resolveString: filePath)
        readStreamDo: [ :fileStream | 
            | stream |
            stream := ReadStream on: fileStream contents asString.
            stream reset.
            aBlock value: stream ]! !

!MCFileTreeFileSystemUtils class methodsFor: 'initialization' stamp: ''!
initialize
    "self initialize"

    self install! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
directoryFromPath: directoryPath
    ^ (AbsolutePath from: directoryPath delimiter: self pathNameDelimiter) asFileReference! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
pathNameDelimiter
    ^ DiskStore activeClass delimiter! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
directoryFromEntry: directoryEntry
    ^ directoryEntry asFileReference! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
directoryExists: aDirectory
    ^ aDirectory isDirectory! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
ensureDirectoryExists: aDirectory
    aDirectory ensureCreateDirectory! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
default
    ^ DiskStore activeClass createDefault defaultWorkingDirectory asFileReference! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
filePathExists: filePath relativeTo: aDirectory
    ^ (aDirectory resolveString: filePath) isFile! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
resolvePath: path in: aDirectory
    ^ aDirectory resolveString: path! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
writeStreamFor: filePath in: aDirectory do: aBlock
    (aDirectory resolveString: filePath) 
		ensureDelete;
		writeStreamDo: aBlock! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
parentDirectoryOf: aDirectory
    ^ aDirectory parent! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
deleteAll: aDirectory
    ^ aDirectory deleteAll! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
ensureFilePathExists: fileNameOrPath relativeTo: aDirectory
    (aDirectory resolveString: fileNameOrPath) parent ensureCreateDirectory! !

!MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: ''!
directoryName: aDirectory
    ^ aDirectory basename! !

!MCFileTreeFileUtils commentStamp: ''!
Utility class for file access!
!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
directoryPathString: aDirectory
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
directoryFromPath: directoryPath relativeTo: aDirectory
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
readStreamFor: filePath in: aDirectory do: aBlock
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'accessing' stamp: ''!
current
    ^ Current! !

!MCFileTreeFileUtils class methodsFor: 'initialization' stamp: ''!
install
    Current := self! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
directoryFromPath: directoryPath
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
pathNameDelimiter
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
buildPathFrom: pathCollection
    ^ String
        streamContents: [ :stream | pathCollection do: [ :element | stream nextPutAll: element ] separatedBy: [ stream nextPut: self pathNameDelimiter ] ]! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
directoryExists: aDirectory
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
ensureDirectoryExists: aDirectory
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
default
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
filePathExists: filePath relativeTo: aDirectory
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
resolvePath: path in: aDirectory
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
writeStreamFor: filePath in: aDirectory do: aBlock
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
parentDirectoryOf: aDirectory
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
deleteAll: aDirectory
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
ensureFilePathExists: fileNameOrPath relativeTo: aDirectory
    self subclassResponsibility! !

!MCFileTreeFileUtils class methodsFor: 'utilities' stamp: ''!
directoryName: aDirectory
    self subclassResponsibility! !

!MCFileTreePackageStructureStWriter commentStamp: ''!
Writer for a package structure!
!MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: ''!
writeAbsentInitializers
	(self absentInitializers asSortedCollection: [ :a :b | a key <= b key ])
		do: [ :association | stream nextPutAll: association value contents ]! !

!MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: ''!
writeMethodPreamble: definition
    stream
        cr;
        nextPut: $!!;
        nextPutAll: definition fullClassName;
        nextPutAll: ' methodsFor: ';
        nextPutAll: definition category asString printString;
        nextPutAll: '!!';
        cr! !

!MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: ''!
writeDefinitions: aCollection
	"the correct initialization order is unknown if some classes are missing in the image"

	initializers := Set new.
	self
		acceptVisitor: self forDefinitions: aCollection;
		writePresentInitializers;
		writeAbsentInitializers! !

!MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: ''!
writeProperties
    stream
        nextPut: ${;
        cr;
        nextPutAll: '    "noMethodMetaData" : true,';
        cr;
        nextPutAll: '    "separateMethodMetaAndSource" : false';
        cr;
        nextPut: $};
        cr! !

!MCFileTreePackageStructureStWriter methodsFor: 'accessing' stamp: ''!
absentInitializers
	^ initializers reject: [ :each | Smalltalk hasClassNamed: each key ]! !

!MCFileTreePackageStructureStWriter methodsFor: 'accessing' stamp: ''!
presentInitializers
	^ initializers select: [ :each | Smalltalk hasClassNamed: each key ]! !

!MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: ''!
writePresentInitializers
	| orderedClasses presentInitializers |
	presentInitializers := self presentInitializers.
	orderedClasses := (Class
		superclassOrder: (presentInitializers collect: [ :each | Smalltalk classOrTraitNamed: each key ]))
		collect: [ :each | each name ].
	orderedClasses
		do: [ :className | stream nextPutAll: (presentInitializers detect: [ :each | each key = className ]) value contents ]! !

!MCFileTreePackageStructureStWriter methodsFor: 'visiting' stamp: ''!
acceptVisitor: aVisitor forDefinitions: aCollection
	(MCDependencySorter sortItems: aCollection)
		do: [ :ea | ea accept: aVisitor ]
		displayingProgress: 'Writing definitions...'! !

!MCFileTreePackageStructureStWriter methodsFor: 'accessing' stamp: ''!
initializers: aCollection
	initializers := aCollection! !

!MCFileTreePackageStructureStWriter class methodsFor: 'accessing' stamp: ''!
useCypressWriter
    "MCFileTreeRepository defaultPackageExtension:'.package'"

    "MCFileTreeRepository defaultPackageExtension:'.pkg'"

    ^ true! !

!MCFileTreePackageStructureStWriter class methodsFor: 'accessing' stamp: ''!
useSnapShotWriter
    ^ MCFileTreeRepository defaultPackageExtension = '.pkg'! !

!MCFileTreeRepository commentStamp: ''!
A file tree repository!
!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
goferVersionFrom: aVersionReference
    "until we no longer find .tree directories in the wild"

    ((self readableFileNames collect: [ :fileName | self fileDirectoryOn: fileName ])
        select: [ :packageDirectory | self fileUtils directoryExists: packageDirectory ])
        collect: [ :packageDirectory | 
            (self versionInfoForPackageDirectory: packageDirectory) name = aVersionReference name
                ifTrue: [ ^ self loadVersionFromFileNamed: (self fileUtils directoryName: packageDirectory) ] ].
    ^ nil! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
filterFileNames: aCollection forVersionNamed: aString
	^ aCollection select: [:ea | (self versionNameFromFileName: ea) = aString]! !

!MCFileTreeRepository methodsFor: 'private' stamp: ''!
flushCache
  "force properties to be reread ... if the directory exists, otherwise let nature
   take it's course"

  super flushCache.
  directory
    ifNotNil: [ 
      (MCFileTreeFileUtils current directoryExists: directory)
        ifTrue: [ 
          repositoryProperties := nil.
          self repositoryProperties ] ]! !

!MCFileTreeRepository methodsFor: '*Metacello-FileTree' stamp: ''!
repositoryVersionString
  "extract a version string from the repository ... if possible"

  (MetacelloPlatform current gitCommitShaFor: self directory fullName)
    ifNotNil: [ :sha | ^ sha ].
  ^ super repositoryVersionString! !

!MCFileTreeRepository methodsFor: 'private' stamp: ''!
propertyFileExtension
  ^ self repositoryProperties
    at: 'propertyFileExtension'
    ifAbsent: [ self class defaultPropertyFileExtension ]! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
allFileNamesForVersionNamed: aString
	^ self filterFileNames: self readableFileNames forVersionNamed: aString! !

!MCFileTreeRepository methodsFor: 'private' stamp: ''!
propertyFileExtension: propertyFileExtension
  self class validatePropertyFileExtension: propertyFileExtension.
  self repositoryProperties
    at: 'propertyFileExtension'
    put: propertyFileExtension.
  self writeRepositoryProperties! !

!MCFileTreeRepository methodsFor: '*Ring-Monticello' stamp: ''!
asRingEnvironmentWith: packageNames

	| anRGEnvironment |
	anRGEnvironment := RGEnvironment new.
	anRGEnvironment announcer suspendAllWhile: [ 
		(packageNames) do: [ :pn | 
			| snap defs package version |
			package := anRGEnvironment ensurePackageNamed: pn asSymbol.
			version := self loadVersionFromFileNamed: pn, '.package'.
			snap := version snapshot.

			defs := snap definitions.
			defs do: [ :each |			
				each ensureRingDefinitionIn: anRGEnvironment package: package ]
			displayingProgress: 'snap'.] 
		 displayingProgress: 'version'.
		].		
			
	anRGEnvironment clean.
	anRGEnvironment behaviorsDo: [ :beh |
		beh superclass == beh ifTrue: [ beh superclass: nil. ] ].			
	^ anRGEnvironment ! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
directory: aDirectory
  super directory: aDirectory.
  repositoryProperties := nil.	"force properties to be reloaded from new location"
  self repositoryProperties	"NOW"! !

!MCFileTreeRepository methodsFor: 'descriptions' stamp: ''!
description
    ^ self class description , super description! !

!MCFileTreeRepository methodsFor: 'private' stamp: ''!
parseName: aString extension: extension
    ^ self class parseName: aString extension: extension! !

!MCFileTreeRepository methodsFor: 'i/o' stamp: ''!
writeStreamForFileNamed: aString replace: aBoolean do: aBlock
	self error: 'we do not open a single stream, but write multiple files'! !

!MCFileTreeRepository methodsFor: '*Metacello-FileTree' stamp: ''!
metacelloProjectClassFor: aScriptEngine
    aScriptEngine versionString isEmptyOrNil
        ifFalse: [ 
            "If we have a version in the script, then a BaselineOf is not being referenced...use a MetacelloMCProject
	    	 see https://github.com/dalehenrich/metacello-work/issues/7"
            ^ super metacelloProjectClassFor: aScriptEngine ].
    ^ MetacelloMCBaselineProject! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
asRepositorySpecFor: aMetacelloMCProject
    ^ aMetacelloMCProject repositorySpec
        description: self description;
        type: 'filetree';
        yourself! !

!MCFileTreeRepository methodsFor: 'actions' stamp: ''!
packageDescriptionFromPackageDirectory: packageDirectory
    | filename info extension |
    filename := self fileUtils current directoryName: packageDirectory.
    extension := filename copyFrom: (filename lastIndexOf: $.) to: filename size.
    ^ ((self packageExtension ~= '.package'
        and: [ 
            (self fileUtils filePathExists: 'version' relativeTo: packageDirectory)
                and: [ self fileUtils filePathExists: 'package' relativeTo: packageDirectory ] ])
        or: [ 
            | dir |
            dir := self fileUtils
                directoryFromPath: MCFileTreeStCypressWriter monticelloMetaDirName
                relativeTo: packageDirectory.
            self fileUtils directoryExists: dir ])
        ifTrue: [ 
            info := self versionInfoForPackageDirectory: packageDirectory.
            self parseName: info name extension: extension ]
        ifFalse: [ 
            {(filename copyFrom: 1 to: (filename lastIndexOf: $.) - 1).
            'cypress'.
            1.
            filename} ]! !

!MCFileTreeRepository methodsFor: 'actions' stamp: ''!
versionInfoForPackageDirectory: packageDirectory
    ^ ((MCReader readerClassForFileNamed: (self fileUtils directoryName: packageDirectory))
        on: (self fileUtils parentDirectoryOf: packageDirectory)
        fileName: (self fileUtils directoryName: packageDirectory))
        loadVersionInfo;
        info! !

!MCFileTreeRepository methodsFor: '*Metacello-FileTree' stamp: ''!
repositoryDescription
  ^ self description , ' [' , self repositoryVersionString , ':'
    , self repositoryBranchName , ']'! !

!MCFileTreeRepository methodsFor: 'i/o' stamp: ''!
readStreamForFileNamed: aString do: aBlock
    ^ aBlock value: self directory! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
fileUtils
    ^ MCFileTreeFileUtils current! !

!MCFileTreeRepository methodsFor: 'testing' stamp: ''!
writeRepositoryProperties
  self fileUtils
    writeStreamFor: '.filetree'
    in: self directory
    do: [ :fileStream | 
      | keyCount propertyCount |
      repositoryProperties
        ifNil: [ repositoryProperties := self defaultRepositoryProperties ].
      keyCount := repositoryProperties size.
      propertyCount := 0.
      fileStream nextPutAll: '{'.
      repositoryProperties
        keysAndValuesDo: [ :propertyName :propertyValue | 
          propertyCount := propertyCount + 1.
          fileStream
            nextPut: $";
            nextPutAll: propertyName asString;
            nextPutAll: '" : "';
            nextPutAll: propertyValue asString;
            nextPut: $";
            yourself.
          propertyCount < keyCount
            ifTrue: [ 
              fileStream
                nextPutAll: ',';
                lf ] ].
      fileStream nextPutAll: ' }' ]
! !

!MCFileTreeRepository methodsFor: 'actions' stamp: ''!
packageDescriptionsFromReadableFileNames
    ^ ((self readableFileNames collect: [ :fileName | self fileDirectoryOn: fileName ])
        select: [ :packageDirectory | self fileUtils directoryExists: packageDirectory ])
        collect: [ :packageDirectory | self packageDescriptionFromPackageDirectory: packageDirectory ]! !

!MCFileTreeRepository methodsFor: '*Metacello-FileTree' stamp: ''!
resetDirectory
	directory := nil! !

!MCFileTreeRepository methodsFor: 'actions' stamp: ''!
fileDirectoryOn: directoryPath
    ^ self fileUtils directoryFromPath: directoryPath relativeTo: self directory! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
versionFromFileNamed: aString
	^ self loadVersionFromFileNamed: aString! !

!MCFileTreeRepository methodsFor: 'storing' stamp: ''!
basicStoreVersion: aVersion
  self readonly
    ifTrue: [ 
      ^ self error: 'The filetree repository: ' , self description printString
            , ' was created read only.' ].
  MCFileTreeWriter fileOut: aVersion on: self! !

!MCFileTreeRepository methodsFor: 'caching' stamp: ''!
cachedFileNames
	^ #()! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
readonly: anObject
	readonly := anObject! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
defaultRepositoryProperties
  ^ Dictionary new
    at: 'packageExtension' put: self class defaultPackageExtension;
    at: 'propertyFileExtension' put: self propertyFileExtension;
    yourself! !

!MCFileTreeRepository methodsFor: 'testing' stamp: ''!
canReadFileNamed: aString
    ^ (aString endsWith: self packageExtension)
        or: [ 
            (aString endsWith: '.tree')
                or: [ 
                    "Cypress format"
                    aString endsWith: '.package' ] ]! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
repositoryProperties

	repositoryProperties
		ifNil: [ repositoryProperties := Dictionary new.
			(self fileUtils directoryExists: directory)
				ifFalse: [ self
						error:
							'filetree:// repository '
								, (self fileUtils directoryPathString: self directory) printString
								, ' does not exist.' ].
			self directory entries
				detect: [ :entry | entry name = '.filetree' ]
				ifFound: [ :configEntry | 
					configEntry
						readStreamDo: [ :fileStream | repositoryProperties := STON fromStream: fileStream ] ]
				ifNone: [ repositoryProperties := self defaultRepositoryProperties.
					self writeRepositoryProperties ] ].
	^ repositoryProperties! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
versionNameFromFileName: aString
	| description |
	description := self packageDescriptionFromPackageDirectory: (self fileDirectoryOn: aString).
	^ description first , '-' , description second , '.' , description third printString! !

!MCFileTreeRepository methodsFor: 'interface' stamp: ''!
versionWithInfo: aVersionInfo ifAbsent: errorBlock
	(self allFileNamesForVersionNamed: aVersionInfo name)
		ifNotEmpty: [ :aCollection | ^ self versionFromFileNamed: aCollection first ].
	^ errorBlock value! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
versionFrom: aVersionReferenceString
    "until we no longer find .tree directories in the wild"

    (self readableFileNames collect: [ :fileName | self fileDirectoryOn: fileName ])
        select: [ :packageDirectory | self fileUtils directoryExists: packageDirectory ]
        thenCollect: [ :packageDirectory | 
            (self versionInfoForPackageDirectory: packageDirectory) name = aVersionReferenceString
                ifTrue: [ ^ self loadVersionFromFileNamed: (self fileUtils directoryName: packageDirectory) ] ].
    ^ nil! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
readonly
    readonly ifNil: [ readonly := false ].
    ^ readonly! !

!MCFileTreeRepository methodsFor: '*Metacello-FileTree' stamp: ''!
repositoryBranchName
  "extract a branch name from the repository ... if possible"

  (MetacelloPlatform current gitBranchNameFor: self directory fullName)
    ifNotNil: [ :sha | ^ sha ].
  ^ super repositoryBranchName! !

!MCFileTreeRepository methodsFor: '*Ring-Monticello' stamp: ''!
asRingEnvironment

	| anRGEnvironment |
	anRGEnvironment := RGEnvironment new.
	anRGEnvironment announcer suspendAllWhile: [ 
		self allFileNames do: [ :pn | 
			| snap defs package version |
			package := anRGEnvironment ensurePackageNamed: (pn withoutSuffix: '.package') asSymbol.
			version := self loadVersionFromFileNamed: pn.
			snap := version snapshot.

			defs := snap definitions.
			defs do: [ :each |			
				each ensureRingDefinitionIn: anRGEnvironment package: package ]
			displayingProgress: 'snapshot'.] 
		 displayingProgress: 'versions'.
		].		
			
	anRGEnvironment clean.
	anRGEnvironment behaviorsDo: [ :beh |
		beh superclass == beh ifTrue: [ beh superclass: nil. ] ].			
	^ anRGEnvironment ! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
versionInfoFromFileNamed: aString
	^ self loadVersionInfoFromFileNamed: aString! !

!MCFileTreeRepository methodsFor: 'private' stamp: ''!
packageExtension
  ^ self repositoryProperties
    at: 'packageExtension'
    ifAbsent: [ self class defaultPackageExtension ]! !

!MCFileTreeRepository methodsFor: 'accessing' stamp: ''!
allFileNames
    ^ (self directory entries select: [ :entry | entry isDirectory and: [ self canReadFileNamed: entry name ] ])
        collect: [ :entry | entry name ]! !

!MCFileTreeRepository class methodsFor: 'utilities' stamp: ''!
parseName: aString
    ^ self parseName: aString extension: self defaultPackageExtension! !

!MCFileTreeRepository class methodsFor: 'accessing' stamp: ''!
validatePropertyFileExtension: aString
  "see Issue #90: https://github.com/dalehenrich/filetree/issues/90"

  (#('.json' '.ston') includes: aString)
    ifFalse: [ self error: 'Unsupported property file extension: ' , aString printString ]! !

!MCFileTreeRepository class methodsFor: 'accessing' stamp: ''!
defaultPropertyFileExtension: aString
  "self defaultPropertyFileExtension:'.ston'"

  self validatePropertyFileExtension: aString.
  defaultPropertyFileExtension := aString! !

!MCFileTreeRepository class methodsFor: '*Metacello-MC' stamp: ''!
createRepositoryFromSpec: aRepositorySpec on: aPlatform
	^ aPlatform createFiletreeRepository: aRepositorySpec! !

!MCFileTreeRepository class methodsFor: 'instance creation' stamp: ''!
description
    ^ 'filetree://'! !

!MCFileTreeRepository class methodsFor: 'utilities' stamp: ''!
parseName: aString extension: extension
    "picked up from GoferVersionReference>>parseName:"

    | basicName package branch author versionNumber packageName |
    basicName := aString last isDigit
        ifTrue: [ aString ]
        ifFalse: [ (aString copyUpToLast: $.) copyUpTo: $( ].
    package := basicName copyUpToLast: $-.
    (package includes: $.)
        ifFalse: [ branch := '' ]
        ifTrue: [ 
            branch := '.' , (package copyAfter: $.).
            package := package copyUpTo: $. ].
    author := (basicName copyAfterLast: $-) copyUpToLast: $..
    versionNumber := (basicName copyAfterLast: $-) copyAfterLast: $..
    (versionNumber notEmpty and: [ versionNumber allSatisfy: [ :each | each isDigit ] ])
        ifTrue: [ versionNumber := versionNumber asNumber ]
        ifFalse: [ versionNumber := 0 ].
    packageName := package , branch.
    ^ {packageName.
    author.
    versionNumber.
    (packageName , extension)}! !

!MCFileTreeRepository class methodsFor: 'accessing' stamp: ''!
defaultPackageExtension
    ".tree, .pkg, .package are the only formats supported at the moment:
	.tree         - original structure
	.pkg          - snapshot structure
	.package - cypress structure"

    defaultPackageExtension
        ifNil: [ 
            defaultPackageExtension := MCFileTreePackageStructureStWriter useCypressWriter
                ifTrue: [ '.package' ]
                ifFalse: [ '.pkg' ] ].
    ^ defaultPackageExtension! !

!MCFileTreeRepository class methodsFor: 'utilities' stamp: ''!
urlAsFileReference: aZnUrl
	"Extracted from ZnUrl since the scheme is restricted.
	We need to keep host as a segment part."

	| path |
	path := aZnUrl host
		ifNotNil: [ 
			((aZnUrl host = #/) and: [ aZnUrl pathSegments isEmpty ])
				ifTrue: [ ^ FileSystem root ].
			aZnUrl pathSegments copyWithFirst: aZnUrl host ]
		ifNil: [ aZnUrl pathSegments].

	(path ifNotEmpty: [ path first = #'.' or: [ path first = #'..' ] ])
		ifTrue: [ ^ (RelativePath withAll: path) asFileReference ].

	^ (AbsolutePath withAll: path) asFileReference ! !

!MCFileTreeRepository class methodsFor: 'accessing' stamp: ''!
urlSchemes
	^ #(#filetree)! !

!MCFileTreeRepository class methodsFor: '*Metacello-MC' stamp: ''!
isAvailableFor: type
	^ type = 'filetree'! !

!MCFileTreeRepository class methodsFor: 'instance creation' stamp: ''!
basicFromUrl: aZnUrl
	^ self new directory: (self urlAsFileReference: aZnUrl)! !

!MCFileTreeRepository class methodsFor: 'accessing' stamp: ''!
defaultPropertyFileExtension
  defaultPropertyFileExtension
    ifNil: [ defaultPropertyFileExtension := '.json' ].
  ^ defaultPropertyFileExtension! !

!MCFileTreeRepository class methodsFor: 'accessing' stamp: ''!
defaultPackageExtension: aString
    ".tree and .pkg are the only two formats supported at the moment"

    "self defaultPackageExtension:'.package'"

    (#('.tree' '.pkg' '.package') includes: aString)
        ifFalse: [ self error: 'Unsupported package extension: ' , aString printString ].
    defaultPackageExtension := aString! !

!MCFileTreeStCypressReader commentStamp: ''!
Reader for Cypress format

see https://github.com/CampSmalltalk/Cypress!
!MCFileTreeStCypressReader methodsFor: 'private' stamp: ''!
isPropertyFile: entry
	^ entry name = 'properties.ston' or: [ entry name = 'properties.json']! !

!MCFileTreeStCypressReader methodsFor: 'utilities' stamp: ''!
addTraitDefinitionFrom: traitPropertiesDict comment: traitComment
    definitions
        add:
            (MCTraitDefinition
                name: (traitPropertiesDict at: 'name')
                traitComposition: (traitPropertiesDict at: 'traitcomposition' ifAbsent: [ '{}' ])
                category: (traitPropertiesDict at: 'category' ifAbsent: [ self packageNameFromPackageDirectory ])
					instVarNames: (traitPropertiesDict at: 'instvars' ifAbsent: [ #() ])
					classInstVarNames: ''
					classTraitComposition: nil
					comment: traitComment
					commentStamp: (traitPropertiesDict at: 'commentStamp' ifAbsent: [ '' ])).
    traitPropertiesDict at: 'classtraitcomposition' ifPresent: [:classTraitComposition |
        definitions
             add:
                (MCClassTraitDefinition
                    baseTraitName: (traitPropertiesDict at: 'name')
                    classTraitComposition: classTraitComposition)].! !

!MCFileTreeStCypressReader methodsFor: 'utilities' stamp: ''!
addClassDefinitionFrom: classPropertiesDict comment: classComment
  | categoryName className |
  className := classPropertiesDict at: 'name'.
  categoryName := classPropertiesDict
    at: 'category'
    ifAbsent: [ self packageNameFromPackageDirectory ].
  self validateClassCategory: categoryName for: className.
  definitions
    add:
      (MCClassDefinition
        name: className
        superclassName: (classPropertiesDict at: 'super')
        traitComposition: (classPropertiesDict at: 'traitcomposition' ifAbsent: [ '{}' ])
        classTraitComposition: (classPropertiesDict at: 'classtraitcomposition' ifAbsent: [ '{}' ])
        category: categoryName
        instVarNames: (classPropertiesDict at: 'instvars' ifAbsent: [ #() ])
        classVarNames: (classPropertiesDict at: 'classvars' ifAbsent: [ #() ])
        poolDictionaryNames: (classPropertiesDict at: 'pools' ifAbsent: [ #() ])
        classInstVarNames:
          (classPropertiesDict at: 'classinstvars' ifAbsent: [ #() ])
        type: (classPropertiesDict at: 'type' ifAbsent: [ 'normal' ]) asSymbol
        comment: classComment
        commentStamp: (classPropertiesDict at: 'commentStamp' ifAbsent: [ '' ]))

! !

!MCFileTreeStCypressReader methodsFor: 'accessing' stamp: ''!
packageNameFromPackageDirectory
    | filename2 |
    filename2 := self fileUtils directoryName: packageDirectory.
    ^ filename2 copyFrom: 1 to: (filename2 lastIndexOf: $.) - 1! !

!MCFileTreeStCypressReader methodsFor: 'accessing' stamp: ''!
loadPackage
    self hasMonticelloMetadata
        ifTrue: [ ^ super loadPackage ].
    package := MCPackage named: self packageNameFromPackageDirectory! !

!MCFileTreeStCypressReader methodsFor: 'validation' stamp: ''!
verifyCategory: categoryName matches: basicPackageName
  "https://github.com/dalehenrich/filetree/issues/136"

  "copied from PackageInfo>>category:matches: and GoferVersionReference>>parseName:"

  | prefixSize catSize packagePrefix |
  categoryName ifNil: [ ^ false ].
  packagePrefix := basicPackageName.
  (packagePrefix includes: $.)
    ifTrue: [ 
      "exclude branch name"
      packagePrefix := packagePrefix copyUpTo: $. ].
  catSize := categoryName size.
  prefixSize := packagePrefix size.
  catSize < prefixSize
    ifTrue: [ ^ false ].
  (categoryName findString: packagePrefix startingAt: 1 caseSensitive: false)
    = 1
    ifFalse: [ ^ false ].
  ^ (categoryName at: packagePrefix size + 1 ifAbsent: [ ^ true ]) = $-! !

!MCFileTreeStCypressReader methodsFor: 'utilities' stamp: ''!
addTraitAndMethodDefinitionsFromEntry: classEntry
	| classDirectory classPropertiesDict classComment entries methodPropertiesDict |
	classDirectory := self fileUtils directoryFromEntry: classEntry.
	entries := classDirectory entries.
	entries
		detect: [ :entry | self isPropertyFile: entry ]
		ifFound: [ :propertyEntry | 
			propertyEntry
				readStreamDo: [ :fileStream | classPropertiesDict := STON fromStream: fileStream ] ].
	entries
		detect: [ :entry | entry name = 'README.md' ]
		ifFound: [ :commentEntry | 
			commentEntry
				readStreamDo: [ :fileStream | classComment := fileStream contents ] ]
		ifNone: [ classComment := '' ].
	methodPropertiesDict := Dictionary new.
	entries
		detect: [ :entry | self isMethodPropertyFile: entry ]
		ifFound: [ :propertyEntry | 
			propertyEntry
				readStreamDo:
					[ :fileStream | "Issue 33: https://github.com/dalehenrich/filetree/issues/33" methodPropertiesDict := STON fromStream: fileStream ] ].
	self
		addTraitDefinitionFrom: classPropertiesDict
		comment: classComment withInternalLineEndings.
	self
		addMethodDefinitionsForClass: (classPropertiesDict at: 'name')
		methodProperties: methodPropertiesDict
		in: entries! !

!MCFileTreeStCypressReader methodsFor: 'validation' stamp: ''!
validateClassCategory: categoryName for: className
  "https://github.com/dalehenrich/filetree/issues/136"

  "class category must match the package name ... guard against manual editing mistakes"

  | prefix |
  prefix := self packageNameFromPackageDirectory.
  (self verifyCategory: categoryName matches: prefix)
    ifTrue: [ ^ self ].
  self
    error:
      'Class category name ' , categoryName printString , ' for the class '
        , className printString , ' is inconsistent with the package name '
        , prefix printString! !

!MCFileTreeStCypressReader methodsFor: 'utilities' stamp: ''!
addClassAndMethodDefinitionsFromEntry: classEntry
	| classDirectory classPropertiesDict classComment entries methodPropertiesDict |
	classDirectory := self fileUtils directoryFromEntry: classEntry.
	entries := classDirectory entries.
	entries
		detect: [ :entry | self isPropertyFile: entry ]
		ifFound: [ :propertyEntry | 
			propertyEntry
				readStreamDo: [ :fileStream | classPropertiesDict := STON fromStream: fileStream ] ].
	entries
		detect: [ :entry | entry name = 'README.md' ]
		ifFound: [ :commentEntry | 
			commentEntry
				readStreamDo: [ :fileStream | classComment := fileStream contents ] ].
	methodPropertiesDict := Dictionary new.
	entries
		detect: [ :entry | self isMethodPropertyFile: entry ]
		ifFound: [ :propertyEntry | 
			propertyEntry
				readStreamDo:
					[ :fileStream | "Issue 33: https://github.com/dalehenrich/filetree/issues/33" methodPropertiesDict := STON fromStream: fileStream ] ].
	self
		addClassDefinitionFrom: classPropertiesDict
		comment: classComment withInternalLineEndings.
	self
		addMethodDefinitionsForClass: (classPropertiesDict at: 'name')
		methodProperties: methodPropertiesDict
		in: entries! !

!MCFileTreeStCypressReader methodsFor: 'utilities' stamp: ''!
addMethodDefinitionsForClass: className methodProperties: methodProperties in: entries extensionMethod: extensionMethod
	entries
		do: [ :entry | 
			| classIsMeta |
			classIsMeta := false.
			entry name = 'class' ifTrue: [ classIsMeta := true ].
			(entry name = 'instance' or: [ entry name = 'class' ])
				ifTrue: [ (self loadableDefinitionsFrom: (self fileUtils directoryFromEntry: entry))
						do: [ :methodEntry | 
							methodEntry
								readStreamDo: [ :fileStream | 
									| category source timestamp selector |
									category := fileStream nextLine.
									source := fileStream upToEnd.
									selector := self methodSelectorFor: source.
									timestamp := methodProperties at: (classIsMeta ifTrue: [ 'class' ] ifFalse: [ 'instance' ]) ifPresent: [ :map | map at: selector asString ifAbsent: [  ] ].	"Issue 33: https://github.com/dalehenrich/filetree/issues/33"
									timestamp ifNil: [ timestamp := self info author , ' ' , self info date mmddyyyy , ' ' , self info time print24 ].
									extensionMethod ifTrue: [ self validateExtensionMethodCategory: category for: className selector: selector ].
									definitions
										add:
											(MCMethodDefinition
												className: className
												classIsMeta: classIsMeta
												selector: selector
												category: category
												timeStamp: timestamp
												source: source) ] ] ] ]! !

!MCFileTreeStCypressReader methodsFor: 'utilities' stamp: ''!
addClassAndMethodDefinitionsFromDirectory: aDirectory
    aDirectory entries
        do: [ :entry | 
            (entry name endsWith: '.trait')
                ifTrue: [ self addTraitAndMethodDefinitionsFromEntry: entry ].
            (entry name endsWith: '.class')
                ifTrue: [ self addClassAndMethodDefinitionsFromEntry: entry ].
            (entry name endsWith: '.extension')
                ifTrue: [ self addExtensionClassAndMethodDefinitionsFromEntry: entry ] ]! !

!MCFileTreeStCypressReader methodsFor: 'utilities' stamp: ''!
methodSelectorFor: source
    ^ Object compilerClass new parseSelector: source
! !

!MCFileTreeStCypressReader methodsFor: 'utilities' stamp: ''!
addMethodDefinitionsForClass: className methodProperties: methodProperties in: entries
  ^ self
    addMethodDefinitionsForClass: className
    methodProperties: methodProperties
    in: entries
    extensionMethod: false! !

!MCFileTreeStCypressReader methodsFor: 'utilities' stamp: ''!
addExtensionClassAndMethodDefinitionsFromEntry: classEntry
	| classDirectory classPropertiesDict methodPropertiesDict entries |
	classDirectory := self fileUtils directoryFromEntry: classEntry.
	entries := classDirectory entries.
	entries
		detect: [ :entry | self isPropertyFile: entry ]
		ifFound: [ :propertyEntry | 
			propertyEntry
				readStreamDo: [ :fileStream | classPropertiesDict := STON fromStream: fileStream ] ].
	methodPropertiesDict := Dictionary new.
	entries
		detect: [ :entry | self isMethodPropertyFile: entry ]
		ifFound: [ :propertyEntry | 
			propertyEntry
				readStreamDo:
					[ :fileStream | "Issue 33: https://github.com/dalehenrich/filetree/issues/33" methodPropertiesDict := STON fromStream: fileStream ] ].
	self
		addMethodDefinitionsForClass: (classPropertiesDict at: 'name')
		methodProperties: methodPropertiesDict
		in: entries
		extensionMethod: true! !

!MCFileTreeStCypressReader methodsFor: 'private' stamp: ''!
isMethodPropertyFile: entry
	^ entry name = 'methodProperties.ston' or: [ entry name = 'methodProperties.json']! !

!MCFileTreeStCypressReader methodsFor: 'accessing' stamp: ''!
basicVersion
    self hasMonticelloMetadata
        ifTrue: [ ^ super basicVersion ].
    ^ MCVersion new
        setPackage: self package
            info: self info
            snapshot: self snapshot
            dependencies: #();
        yourself! !

!MCFileTreeStCypressReader methodsFor: 'utilities' stamp: ''!
loadDefinitions
    | entries directory |
    definitions := OrderedCollection new.
    directory := self fileUtils directoryFromPath: self monticelloMetaDirName relativeTo: packageDirectory.
    (self fileUtils directoryExists: directory)
        ifTrue: [ 
            		entries := directory entries.
            		self
                			addDefinitionFromFile: (entries detect: [ :entry | entry name beginsWith: 'categories' ] ifNone: [  ])
                			inDirectory: directory ]
	ifFalse: [definitions add: (MCOrganizationDefinition categories: {self packageNameFromPackageDirectory }) ].
    self addClassAndMethodDefinitionsFromDirectory: packageDirectory.
    (self fileUtils directoryExists: directory)
        ifTrue: [ 
            self
                addDefinitionFromFile: (entries detect: [ :entry | entry name beginsWith: 'initializers' ] ifNone: [  ])
                inDirectory: directory ]! !

!MCFileTreeStCypressReader methodsFor: 'accessing' stamp: ''!
loadVersionInfo
  self hasMonticelloMetadata
    ifTrue: [ ^ info := self extractInfoFrom: (self parseMember: 'version') ].
  info := MCVersionInfo
    name: self packageNameFromPackageDirectory , '-cypress.1'
    id: UUID new
    message: 'fabricated from a Cypress format repository'
    date: Date today
    time: Time now
    author: ''
    ancestors: #()
    stepChildren: #()
! !

!MCFileTreeStCypressReader methodsFor: 'validation' stamp: ''!
validateExtensionMethodCategory: categoryName for: className selector: selector
  "https://github.com/dalehenrich/filetree/issues/136"

  "method category must match the package name for extension methods... guard against manual editing mistakes"

  "extracted from PackageInfo>>isForeignClassExtension:"

  | prefix |
  prefix := '*' , self packageNameFromPackageDirectory asLowercase.
  categoryName
    ifNotNil: [ 
      (categoryName isEmpty not
        and: [ 
          categoryName first = $*
            and: [ 
              "asLowercase needed in GemStone 3.1.0.6?"
              self verifyCategory: categoryName asLowercase matches: prefix ] ])
        ifTrue: [ ^ self ] ].
  self
    error:
      'Method protocol ' , categoryName printString , ' for the method '
        , selector asString printString , ' in class ' , className printString
        , ' is inconsistent with the package name ' , prefix printString
! !

!MCFileTreeStCypressReader class methodsFor: 'accessing' stamp: ''!
extension
    ^ 'package'! !

!MCFileTreeStCypressReader class methodsFor: 'accessing' stamp: ''!
monticelloMetaDirName
    ^ MCFileTreeStCypressWriter monticelloMetaDirName! !

!MCFileTreeStCypressWriter commentStamp: ''!
Writer for Cypress format 

see https://github.com/CampSmalltalk/Cypress!
!MCFileTreeStCypressWriter methodsFor: 'writing' stamp: ''!
writeMethodDefinition: definition
    fileStream
        nextPutAll: definition category;
        lf;
        nextPutAll: definition source withUnixLineEndings! !

!MCFileTreeStCypressWriter methodsFor: 'writing' stamp: ''!
writeTraitDefinition: definition
    | properties compositionString |
    properties := Dictionary new.
    properties at: 'name' put: definition className.
    definition traitCompositionString
        ifNotNil: [ :property | 
            property ~= '{}'
                ifTrue: [ properties at: 'traitcomposition' put: property ] ].
    " handle the classTrait case "
    compositionString := self classTraitDefinitions at: definition className ifPresent: [:classTraitDefinition |
	classTraitDefinition classTraitCompositionString ].
    compositionString ifNil: [ compositionString := definition classTraitCompositionString ].
    compositionString~= '{}'
                ifTrue: [ properties at: 'classtraitcomposition' put: compositionString ] .
    properties at: 'category' put: definition category.
    properties at: 'commentStamp' put: definition commentStamp.
    properties at: 'instvars' put: definition instVarNames asArray.
    properties at: 'classinstvars' put: definition classInstVarNames asArray.
    STON put: properties asJsonOnStreamPretty: fileStream! !

!MCFileTreeStCypressWriter methodsFor: 'initialization' stamp: ''!
propertyFileExtension
  ^ self repository propertyFileExtension! !

!MCFileTreeStCypressWriter methodsFor: 'writing' stamp: ''!
writeExtensionClassDefinition: definition
    | properties |
    properties := Dictionary new.
    properties at: 'name' put: definition className.
    STON put: properties asJsonOnStreamPretty: fileStream! !

!MCFileTreeStCypressWriter methodsFor: 'initialization' stamp: ''!
writePropertiesFile
  | properties |
  properties := Dictionary new.
  properties at: 'noMethodMetaData' put: true.
  properties at: 'separateMethodMetaAndSource' put: false.
  properties at: 'useCypressPropertiesFile' put: true.
  self
    writeInDirectoryName: '.'
    fileName: ''
    extension: '.filetree'
    visit: [ STON put: properties asJsonOnStreamPretty: fileStream ].
  self
    writeInDirectoryName: '.'
    fileName: 'properties'
    extension: self propertyFileExtension
    visit: [ STON put: (Dictionary new) asJsonOnStreamPretty: fileStream ]! !

!MCFileTreeStCypressWriter methodsFor: 'writing' stamp: ''!
writeMethodDefinition: methodDefinition to: methodPath
  self shouldNotImplement! !

!MCFileTreeStCypressWriter methodsFor: 'private' stamp: ''!
fileNameMapFor: aMethodDefinitionCollection
  "https://github.com/dalehenrich/filetree/issues/92"

  "answer a dictionary that maps each definition selector to a filename that is guaranteed unique on case insensitive file systems.
  Segregate instance and class side methods. Key is true for class method map, false for instance method map"

  | map filenameMetaMap |
  map := Dictionary new.
  aMethodDefinitionCollection
    do: [ :mDef | 
      | sel col metaKey methMap |
      "sort into bins by lowercase selector. "
      metaKey := mDef classIsMeta.
      methMap := map
        at: metaKey
        ifAbsent: [ map at: metaKey put: Dictionary new ].
      sel := mDef selector asLowercase.
      col := methMap
        at: sel
        ifAbsent: [ methMap at: sel put: OrderedCollection new ].
      col add: mDef ].
  filenameMetaMap := Dictionary new.
  map
    keysAndValuesDo: [ :metaKey :methMap | 
      | filenameMap |
      filenameMap := filenameMetaMap
        at: metaKey
        ifAbsent: [ filenameMetaMap at: metaKey put: Dictionary new ].
      methMap values
        do: [ :col | 
          | selector sortedCol |
          col size = 1
            ifTrue: [ 
              | def |
              "no need to distinguish filename"
              def := col at: 1.
              filenameMap
                at: def selector
                put: (self fileNameForSelector: def selector) ]
            ifFalse: [ 
              "tack on postfix to guarantee  file names are uniique on case insensitive file systems"
              sortedCol := col sorted: [ :a :b | a asString <= b asString ].
              (1 to: sortedCol size) do: [ :index | 
                | def filename |
                def := sortedCol at: index.
                filename := self fileNameForSelector: def selector.
                filename := filename , '..' , index printString.
                filenameMap at: def selector put: filename ] ] ] ].
  ^ filenameMetaMap! !

!MCFileTreeStCypressWriter methodsFor: 'initialization' stamp: ''!
writeDefinitions: aCollection
  | classDirExtension extensionClasses extensionMethodDefinitions extensionMethodMap methodHolders |
  self writeBasicDefinitions: aCollection.
  extensionClasses := OrderedCollection new.
  extensionMethodDefinitions := OrderedCollection new.
  methodHolders := self classDefinitions, self traitDefinitions.
  self methodDefinitions
    keysAndValuesDo: [ :className :extensionMethods | 
      methodHolders
        at: className
        ifAbsent: [ 
          extensionClasses add: className.
          extensionMethodDefinitions addAll: extensionMethods ] ].
  extensionClasses
    do: [ :className | self methodDefinitions removeKey: className ].
    self writeMethodHolderDefinitions: self traitDefinitions extension: '.trait' to: '' do: [ :definition :classPath |
	self writeTraitDefinition: definition to: classPath. ].
  self
    writeMethodHolderDefinitions: self classDefinitions
    extension: '.class'
    to: ''
    do: [ :definition :classPath | self writeClassDefinition: definition to: classPath ].
  classDirExtension := '.extension'.
  extensionMethodMap := Dictionary new.
  extensionMethodDefinitions
    do: [ :methodDefinition | 
      | classPath methodPath |
      (extensionMethodMap
        at: methodDefinition className
        ifAbsent: [ extensionMethodMap at: methodDefinition className put: OrderedCollection new ])
        add: methodDefinition.
      classPath := methodDefinition className , classDirExtension
        , self fileUtils pathNameDelimiter asString.
      self writeExtensionClassDefinition: methodDefinition to: classPath ].
  extensionMethodMap
    keysAndValuesDo: [ :className :classMethodDefinitions | 
      | classPath filenameMetaMap |
      filenameMetaMap := self fileNameMapFor: classMethodDefinitions.
      classMethodDefinitions
        do: [ :methodDefinition | 
          | filename methodPath |
          filename := (filenameMetaMap at: methodDefinition classIsMeta)
            at: methodDefinition selector.
          classPath := methodDefinition className , classDirExtension
            , self fileUtils pathNameDelimiter asString.
          methodPath := classPath
            ,
              (methodDefinition classIsMeta
                ifTrue: [ 'class' ]
                ifFalse: [ 'instance' ])
            , self fileUtils pathNameDelimiter asString.
          self
            writeMethodDefinition: methodDefinition
            to: methodPath
            filename: filename ].
      classPath := className , classDirExtension
        , self fileUtils pathNameDelimiter asString.
      self
        writeInDirectoryName: classPath
        fileName: 'methodProperties'
        extension: self propertyFileExtension
        visit: [ self writeMethodProperties: classMethodDefinitions ] ]
! !

!MCFileTreeStCypressWriter methodsFor: 'writing' stamp: ''!
writeMethodDefinition: methodDefinition to: methodPath filename: filename
  self
    writeInDirectoryName: methodPath
    fileName: filename
    extension: '.st'
    visit: [ self writeMethodDefinition: methodDefinition ]! !

!MCFileTreeStCypressWriter methodsFor: 'writing' stamp: ''!
writeTraitDefinition: definition to: classPath
  self
    writeInDirectoryName: classPath
    fileName: 'README'
    extension: '.md'
    visit: [ self writeClassComment: definition ].
  self
    writeInDirectoryName: classPath
    fileName: 'properties'
    extension: self propertyFileExtension
    visit: [ self writeTraitDefinition: definition ].
  self
    writeInDirectoryName: classPath
    fileName: 'methodProperties'
    extension: self propertyFileExtension
    visit: [ 
      self
        writeMethodProperties:
          (self methodDefinitions at: definition className ifAbsent: [ #() ]) ]! !

!MCFileTreeStCypressWriter methodsFor: 'writing' stamp: ''!
writeClassComment: definition
    fileStream nextPutAll: definition comment withUnixLineEndings! !

!MCFileTreeStCypressWriter methodsFor: 'private' stamp: ''!
setFileStream: aStream
    super setFileStream: aStream.
    fileStream := aStream! !

!MCFileTreeStCypressWriter methodsFor: 'initialize-release' stamp: ''!
writeMethodProperties: classMethodDefinitions
    "Issue 33: https://github.com/dalehenrich/filetree/issues/33"

    | properties classMethodsMap instanceMethodMap |
    properties := Dictionary new.
    properties at: 'class' put: (classMethodsMap := Dictionary new).
    properties at: 'instance' put: (instanceMethodMap := Dictionary new).
    classMethodDefinitions
        do: [ :methodDefinition | 
            (methodDefinition classIsMeta
                ifTrue: [ classMethodsMap ]
                ifFalse: [ instanceMethodMap ]) at: methodDefinition selector asString put: methodDefinition timeStamp ].
    STON put: properties asJsonOnStreamPretty: fileStream! !

!MCFileTreeStCypressWriter methodsFor: 'private' stamp: ''!
fileNameForSelector: selector
  ^ self class fileNameForSelector: selector
! !

!MCFileTreeStCypressWriter methodsFor: 'writing' stamp: ''!
writeClassDefinition: definition
    | properties |
    properties := Dictionary new.
    properties at: 'name' put: definition className.
    properties at: 'super' put: definition superclassName.
    definition traitCompositionString
        ifNotNil: [ :property | 
            "Issue #48: https://github.com/dalehenrich/filetree/issues/48"
            property ~= '{}'
                ifTrue: [ properties at: 'traitcomposition' put: property ] ].
    definition classTraitCompositionString
        ifNotNil: [ :property | 
            "Issue #48: https://github.com/dalehenrich/filetree/issues/48"
            property ~= '{}'
                ifTrue: [ properties at: 'classtraitcomposition' put: property ] ].
    properties at: 'category' put: definition category.
    properties at: 'instvars' put: definition instVarNames asArray.
    properties at: 'classvars' put: definition classVarNames asArray.
    properties at: 'pools' put: definition poolDictionaries asArray.
    properties at: 'classinstvars' put: definition classInstVarNames asArray.
    properties at: 'type' put: definition type asString.
    properties at: 'commentStamp' put: definition commentStamp.
    STON put: properties asJsonOnStreamPretty: fileStream! !

!MCFileTreeStCypressWriter methodsFor: 'writing' stamp: ''!
writeClassDefinition: definition to: classPath
  self
    writeInDirectoryName: classPath
    fileName: 'README'
    extension: '.md'
    visit: [ self writeClassComment: definition ].
  self
    writeInDirectoryName: classPath
    fileName: 'properties'
    extension: self propertyFileExtension
    visit: [ self writeClassDefinition: definition ].
  self
    writeInDirectoryName: classPath
    fileName: 'methodProperties'
    extension: self propertyFileExtension
    visit: [ 
      self
        writeMethodProperties:
          (self methodDefinitions at: definition className ifAbsent: [ #() ]) ]! !

!MCFileTreeStCypressWriter methodsFor: 'writing' stamp: ''!
writeExtensionClassDefinition: definition to: classPath
  self
    writeInDirectoryName: classPath
    fileName: 'properties'
    extension: self propertyFileExtension
    visit: [ self writeExtensionClassDefinition: definition ]! !

!MCFileTreeStCypressWriter class methodsFor: 'initialization' stamp: ''!
initialize
    "self initialize"

    "force initialization of specials ..."

    specials := nil! !

!MCFileTreeStCypressWriter class methodsFor: 'accessing' stamp: ''!
monticelloMetaDirName
    ^ 'monticello.meta'! !

!MCFileTreeStCypressWriter class methodsFor: 'accessing' stamp: ''!
specials
    ^ specials ifNil: [ specials := self initializeSpecials ]! !

!MCFileTreeStCypressWriter class methodsFor: 'accessing' stamp: ''!
fileNameForSelector: selector
  ^ (selector includes: $:)
    ifTrue: [ 
      selector
        collect: [ :each | 
          each = $:
            ifTrue: [ $. ]
            ifFalse: [ each ] ] ]
    ifFalse: [ 
      (self specials includes: selector first)
        ifFalse: [ selector ]
        ifTrue: [ 
          | output |
          output := String new writeStream.
          output nextPut: $^.
          selector
            do: [ :each | 
              output
                nextPutAll:
                  ((self specials includes: each)
                    ifTrue: [ self specials at: each ]
                    ifFalse: [ each asString ]) ]
            separatedBy: [ output nextPut: $. ].
          output contents ] ]
! !

!MCFileTreeStCypressWriter class methodsFor: 'private' stamp: ''!
initializeSpecials
    | map |
    map := Dictionary new.
    map
        at: $+ put: 'plus';
        at: $- put: 'minus';
        at: $= put: 'equals';
        at: $< put: 'less';
        at: $> put: 'more';
        at: $% put: 'percent';
        at: $& put: 'and';
        at: $| put: 'pipe';
        at: $* put: 'star';
        at: $/ put: 'slash';
        at: $\ put: 'backslash';
        at: $~ put: 'tilde';
        at: $? put: 'wat';
        at: $, put: 'comma';
        at: $@ put: 'at'.
    map keys do: [ :key | map at: (map at: key) put: key ].
    ^ map
! !

!MCFileTreeStReader commentStamp: ''!
A reader for Smalltalk code!
!MCFileTreeStReader methodsFor: 'utilities' stamp: ''!
addClassAndMethodDefinitionsFromDirectory: aDirectory
    self addClassAndMethodDefinitionsFromDirectoryEntries: aDirectory entries! !

!MCFileTreeStReader class methodsFor: 'accessing' stamp: ''!
extension
	^ 'tree'! !

!MCFileTreeStSnapshotReader commentStamp: ''!
Snapshot reader!
!MCFileTreeStSnapshotReader methodsFor: 'utilities' stamp: ''!
addClassAndMethodDefinitionsFromDirectory: aDirectory
    | snapshot classes entries extensions |
    snapshot := self fileUtils directoryFromPath: 'snapshot' relativeTo: aDirectory.
    classes := self fileUtils directoryFromPath: 'classes' relativeTo: snapshot.
    (self fileUtils directoryExists: classes)
        ifTrue: [ 
            self addClassAndMethodDefinitionsFromDirectoryEntries: (entries := classes entries).	"load .st files from subdirectories (*.class) of snapshot/classes ... class defintions"
            entries
                do: [ :classDirectoryEntry | 
                    | classDirectory |
                    classDirectory := self fileUtils directoryFromEntry: classDirectoryEntry.
                    self addClassAndMethodDefinitionsFromDirectoryEntries: classDirectory entries	"load .st files from subdirectories (class or instance) of snapshot/classes/*.class ... method definitions" ] ].
    extensions := self fileUtils directoryFromPath: 'extensions' relativeTo: snapshot.
    (self fileUtils directoryExists: extensions)
        ifTrue: [ 
            extensions entries
                do: [ :classDirectoryEntry | 
                    | classDirectory |
                    classDirectory := self fileUtils directoryFromEntry: classDirectoryEntry.
                    self addClassAndMethodDefinitionsFromDirectoryEntries: classDirectory entries	"load .st files from subdirectories (class or instance) of snapshot/extensions/*.class ... method definitions" ] ]! !

!MCFileTreeStSnapshotReader class methodsFor: 'accessing' stamp: ''!
extension
    ^ 'pkg'! !

!MCFileTreeStSnapshotWriter commentStamp: ''!
Snapshot writer!
!MCFileTreeStSnapshotWriter methodsFor: 'writing' stamp: ''!
writeMethodHolderDefinitions: aCollection extension: extension to: basePath do: aBlock
  aCollection
    keysAndValuesDo: [ :className :definition | 
      | classPath instanceMethodPath classMethodPath filenameMetaMap theMethodDefinitions |
      classPath := basePath , definition className , extension
        , self fileUtils pathNameDelimiter asString.
      aBlock value: definition value: classPath.
      instanceMethodPath := classPath , 'instance'
        , self fileUtils pathNameDelimiter asString.
      classMethodPath := classPath , 'class'
        , self fileUtils pathNameDelimiter asString.
      theMethodDefinitions := self methodDefinitions
        at: className
        ifAbsent: [ #() ].
      filenameMetaMap := self fileNameMapFor: theMethodDefinitions.
      theMethodDefinitions
        do: [ :methodDefinition | 
          | filename |
          filename := (filenameMetaMap at: methodDefinition classIsMeta)
            at: methodDefinition selector.
          methodDefinition classIsMeta
            ifTrue: [ 
              self
                writeMethodDefinition: methodDefinition
                to: classMethodPath
                filename: filename ]
            ifFalse: [ 
              self
                writeMethodDefinition: methodDefinition
                to: instanceMethodPath
                filename: filename ] ] ]
! !

!MCFileTreeStSnapshotWriter methodsFor: 'accessing' stamp: ''!
classTraitDefinitions
    classTraitDefinitions ifNil: [ classTraitDefinitions := Dictionary new ].
    ^ classTraitDefinitions! !

!MCFileTreeStSnapshotWriter methodsFor: 'writing' stamp: ''!
writeMethodDefinition: methodDefinition to: methodPath
    | filename |
    filename := self fileNameForSelector: methodDefinition selector.
    self
        writeInDirectoryName: methodPath
        fileName: filename
        extension: '.st'
        visit: [ self writeMethodDefinition: methodDefinition ]! !

!MCFileTreeStSnapshotWriter methodsFor: 'initialization' stamp: ''!
writeDefinitions: aCollection
  | basePath extensionClasses extensionMethodDefinitions methodHolders |
  self writeBasicDefinitions: aCollection.
  basePath := 'snapshot' , self fileUtils pathNameDelimiter asString , 'classes'
    , self fileUtils pathNameDelimiter asString.
  extensionClasses := OrderedCollection new.
  extensionMethodDefinitions := OrderedCollection new.
  methodHolders := self classDefinitions, self traitDefinitions.
  self methodDefinitions
    keysAndValuesDo: [ :className :extensionMethods | 
      methodHolders
        at: className
        ifAbsent: [ 
          extensionClasses add: className.
          extensionMethodDefinitions addAll: extensionMethods ] ].
  extensionClasses
    do: [ :className | self methodDefinitions removeKey: className ].
    self writeMethodHolderDefinitions: self traitDefinitions extension: '.trait' to: basePath do: [ :definition :classPath |
	self writeTraitDefinition: definition to: classPath.
	self classTraitDefinitions at: definition className ifPresent: [:classTraitDefinition |
		self writeClassTraitDefinition: classTraitDefinition to: classPath ] ].
  self
    writeMethodHolderDefinitions: self classDefinitions
    extension: '.class'
    to: basePath
    do: [ :definition :classPath | self writeClassDefinition: definition to: classPath ].
  basePath := 'snapshot' , self fileUtils pathNameDelimiter asString
    , 'extensions' , self fileUtils pathNameDelimiter asString.
  extensionMethodDefinitions
    do: [ :methodDefinition | 
      | methodPath |
      methodPath := basePath , methodDefinition className , '.class'
        , self fileUtils pathNameDelimiter asString
        ,
          (methodDefinition classIsMeta
            ifTrue: [ 'class' ]
            ifFalse: [ 'instance' ])
        , self fileUtils pathNameDelimiter asString.
      self writeMethodDefinition: methodDefinition to: methodPath ]
! !

!MCFileTreeStSnapshotWriter methodsFor: 'visiting' stamp: ''!
visitClassDefinition: definition
    orderedClassNames add: definition className.
    self classDefinitions at: definition className put: definition! !

!MCFileTreeStSnapshotWriter methodsFor: 'writing' stamp: ''!
writeTraitDefinition: definition to: traitPath
    self
        writeInDirectoryName: traitPath
        fileName: definition className
        extension: '.st'
        visit: [ self writeTraitDefinition: definition ]! !

!MCFileTreeStSnapshotWriter methodsFor: 'writing' stamp: ''!
writeClassTraitDefinition: definition to: traitPath
    self
        writeInDirectoryName: traitPath
        fileName: definition className, '_classTrait'
        extension: '.st'
        visit: [ self writeClassTraitDefinition: definition ]! !

!MCFileTreeStSnapshotWriter methodsFor: 'accessing' stamp: ''!
classDefinitions
    classDefinitions ifNil: [ classDefinitions := Dictionary new ].
    ^ classDefinitions! !

!MCFileTreeStSnapshotWriter methodsFor: 'visiting' stamp: ''!
visitTraitDefinition: definition
    orderedTraitNames add: definition className.
    self traitDefinitions at: definition className put: definition! !

!MCFileTreeStSnapshotWriter methodsFor: 'accessing' stamp: ''!
traitDefinitions
    traitDefinitions ifNil: [ traitDefinitions := Dictionary new ].
    ^ traitDefinitions! !

!MCFileTreeStSnapshotWriter methodsFor: 'visiting' stamp: ''!
visitMethodDefinition: definition
    (self methodDefinitions
        at: definition className
        ifAbsent: [ self methodDefinitions at: definition className put: OrderedCollection new ]) add: definition! !

!MCFileTreeStSnapshotWriter methodsFor: 'writing' stamp: ''!
writeClassDefinition: definition to: classPath
    self
        writeInDirectoryName: classPath
        fileName: definition className
        extension: '.st'
        visit: [ self writeClassDefinition: definition ]! !

!MCFileTreeStSnapshotWriter methodsFor: 'accessing' stamp: ''!
methodDefinitions
    methodDefinitions ifNil: [ methodDefinitions := Dictionary new ].
    ^ methodDefinitions! !

!MCFileTreeStSnapshotWriter methodsFor: 'visiting' stamp: ''!
visitClassTraitDefinition: definition
    orderedTraitNames add: definition className, ' classTrait'.
    self classTraitDefinitions at: definition className put: definition! !

!MCFileTreeStWriter commentStamp: ''!
A writer for Smalltalk code!
!MCFileTreeStWriter methodsFor: 'visiting' stamp: ''!
visitClassDefinition: definition
    orderedClassNames add: definition className.
    self
        writeInDirectoryName: definition className
        fileName: definition className
        extension: '.st'
        visit: [ self writeClassDefinition: definition ]! !

!MCFileTreeStWriter methodsFor: 'visiting' stamp: ''!
visitTraitDefinition: definition
    orderedTraitNames add: definition className.
    self
        writeInDirectoryName: definition className
        fileName: definition className
        extension: '.st'
        visit: [ self writeTraitDefinition: definition ]! !

!MCFileTreeStWriter methodsFor: 'visiting' stamp: ''!
visitMethodDefinition: definition
    | filename directoryname |
    directoryname := definition classIsMeta
        ifTrue: [ definition className , '_class' ]
        ifFalse: [ definition className ].
    filename := self fileNameForSelector: definition selector.
    self
        writeInDirectoryName: directoryname
        fileName: filename
        extension: '.st'
        visit: [ self writeMethodDefinition: definition ]! !

!MCFileTreeStWriter methodsFor: 'visiting' stamp: ''!
visitClassTraitDefinition: definition
    orderedTraitNames add: definition className, ' classTrait'.
    self
        writeInDirectoryName: definition className
        fileName: definition className, '_classTrait'
        extension: '.st'
        visit: [ self writeClassTraitDefinition: definition ]! !

!MCFileTreeVersionInfoWriter commentStamp: ''!
Write for the version info!
!MCFileTreeVersionInfoWriter methodsFor: 'serialization' stamp: ''!
writeVersionInfo: aVersionInfo
	(self isWritten: aVersionInfo)
		ifTrue: [^ stream nextPutAll: '(id '; print: aVersionInfo id asString; nextPut: $) ].
	stream nextPut: $(.
	#(name message id date time author) do: [:sel | 
		stream 
			nextPutAll: sel; space;
			print: (((aVersionInfo perform: sel) ifNil: ['']) asString  ); space ].
	stream nextPutAll: 'ancestors ('.
	aVersionInfo ancestors do: [:ea | self writeVersionInfo: ea].
	stream nextPutAll: ') stepChildren ('.
	aVersionInfo stepChildren do: [:ea | self writeVersionInfo: ea].
	stream nextPutAll: '))'.
	
	self wrote: aVersionInfo! !

!MCFileTreeWriter commentStamp: ''!
Writer for the file tree!
!MCFileTreeWriter methodsFor: 'accessing' stamp: ''!
fileUtils
    ^ MCFileTreeFileUtils current! !

!MCFileTreeWriter methodsFor: 'visiting' stamp: ''!
initializePackageFileDirectoryCache
    cachedPackageFileDirectoryEntries := Dictionary new.
    self packageFileDirectory entries
        do: [ :entry | 
            entry isDirectory
                ifTrue: [ cachedPackageFileDirectoryEntries at: entry name put: (self fileUtils directoryFromEntry: entry) ] ]! !

!MCFileTreeWriter methodsFor: 'accessing' stamp: ''!
snapshotWriterClass
	^ MCFileTreeAbstractStWriter! !

!MCFileTreeWriter methodsFor: 'serializing' stamp: ''!
serializeVersionInfo: aVersionInfo
	infoWriter ifNil: [infoWriter := MCFileTreeVersionInfoWriter new].
	^ String streamContents: [:s |
		infoWriter stream: s.
		infoWriter writeVersionInfo: aVersionInfo]! !

!MCFileTreeWriter methodsFor: 'writing' stamp: ''!
packageFileDirectory
    packageFileDirectory
        ifNil: [ packageFileDirectory := self fileUtils directoryFromPath: directory relativeTo: stream directory ].
    ^ packageFileDirectory! !

!MCFileTreeWriter methodsFor: 'visiting' stamp: ''!
writeVersion: aVersion
    | members |
    directory := (members := MCFileTreeRepository parseName: aVersion info name) last.
    self deleteExistingPackageStructureFor: members.
    self fileUtils ensureDirectoryExists: self packageFileDirectory.
    self initializePackageFileDirectoryCache.
    super writeVersion: aVersion! !

!MCFileTreeWriter methodsFor: 'writing' stamp: ''!
repository
  ^ stream! !

!MCFileTreeWriter methodsFor: 'writing' stamp: ''!
flush
	! !

!MCFileTreeWriter methodsFor: 'writing' stamp: ''!
addString: string at: fileNameOrPath
    "fileNameOrPath may have one or two elements"

    | utils fullPath path |
    utils := MCFileTreeFileUtils current.
    path := MCFileTreePackageStructureStWriter useCypressWriter
        ifTrue: [ 
            fullPath := utils
                buildPathFrom:
                    {(MCFileTreeStCypressWriter monticelloMetaDirName).
                    fileNameOrPath}.
            utils ensureFilePathExists: fullPath relativeTo: self packageFileDirectory.
            fullPath ]
        ifFalse: [ fileNameOrPath ].
    string isEmpty
        ifFalse: [ utils writeStreamFor: path in: self packageFileDirectory do: [ :file | file nextPutAll: string ] ]! !

!MCFileTreeWriter methodsFor: 'writing' stamp: ''!
addString: string at: fileNameOrPath encodedTo: ignored
    "fileNameOrPath may have one or two elements"
    "encodeTo: arg, because FileTree uses UTF8 by default"

    | utils fullPath path |
    utils := MCFileTreeFileUtils current.
    path := MCFileTreePackageStructureStWriter useCypressWriter
        ifTrue: [ 
            fullPath := utils
                buildPathFrom:
                    {(MCFileTreeStCypressWriter monticelloMetaDirName).
                    fileNameOrPath}.
            utils ensureFilePathExists: fullPath relativeTo: self packageFileDirectory.
            fullPath ]
        ifFalse: [ fileNameOrPath ].
    string isEmpty
        ifFalse: [ utils writeStreamFor: path in: self packageFileDirectory do: [ :file | file nextPutAll: string ] ]! !

!MCFileTreeWriter methodsFor: 'visiting' stamp: ''!
writeSnapshot: aSnapshot
	(self snapshotWriterClass on: self) writeDefinitions: aSnapshot definitions! !

!MCFileTreeWriter methodsFor: 'visiting' stamp: ''!
deleteExistingPackageStructureFor: members
    "destroy .tree and .pkg directory structure .. otherwise it won't be pretty"

    | alternateDirName alternateDir packageDirectoryName |
    (self fileUtils directoryExists: self packageFileDirectory)
        ifTrue: [ self fileUtils deleteAll: self packageFileDirectory ].
    packageDirectoryName := self fileUtils directoryName: self packageFileDirectory.
    alternateDirName := (packageDirectoryName endsWith: '.pkg')
        ifTrue: [ members first , '.tree' ]
        ifFalse: [ 
            (packageDirectoryName endsWith: '.tree')
                ifTrue: [ members first , '.pkg' ]
                ifFalse: [ 
                    (packageDirectoryName endsWith: '.package')
                        ifTrue: [ members first , '.pkg' ] ] ].
    alternateDirName
        ifNotNil: [ 
            alternateDir := self fileUtils directoryFromPath: alternateDirName relativeTo: stream directory.
            (self fileUtils directoryExists: alternateDir)
                ifTrue: [ self fileUtils deleteAll: alternateDir ] ]! !

!MCFileTreeWriter methodsFor: 'visiting' stamp: ''!
subPackageFileDirectoryFor: directoryNameOrPath
    ^ cachedPackageFileDirectoryEntries
        at: directoryNameOrPath
        ifAbsentPut: [ 
            | dir |
            dir := self fileUtils directoryFromPath: directoryNameOrPath relativeTo: self packageFileDirectory.
            self fileUtils ensureDirectoryExists: dir.
            dir ]! !

!MCFileTreeWriter class methodsFor: 'accessing' stamp: ''!
readerClass
    "don't expect this message to be sent"

    self shouldNotImplement! !

!MCFilteredVersionSorter commentStamp: ''!
Sort filtered versions !
!MCFilteredVersionSorter methodsFor: 'adding' stamp: 'nil'!
addVersionInfo: aVersionInfo
	(aVersionInfo hasAncestor: target)
		ifTrue: [super addVersionInfo: aVersionInfo]
! !

!MCFilteredVersionSorter methodsFor: 'private' stamp: 'nil'!
processVersionInfo: aVersionInfo
	| success |
	aVersionInfo = target ifTrue: [^ true].
	(aVersionInfo hasAncestor: target) ifFalse: [^false].
	self pushLayer.
	success := (self knownAncestorsOf: aVersionInfo) anySatisfy:
				[:ea | self processVersionInfo: ea].
	self popLayer.
	success ifTrue: [self addToCurrentLayer: aVersionInfo].
	^ success	! !

!MCFilteredVersionSorter methodsFor: 'accessing' stamp: 'nil'!
target: aVersionInfo
	target := aVersionInfo! !

!MCFrontier commentStamp: ''!
Utility class!
!MCFrontier methodsFor: 'accessing' stamp: 'nil'!
frontier
	^frontier! !

!MCFrontier methodsFor: 'initialization' stamp: 'nil'!
frontier: f bag: remaining
	frontier := f asOrderedCollection.
	bag := remaining! !

!MCFrontier methodsFor: 'advancing' stamp: 'nil'!
remove: aVersionInfo
	frontier remove: aVersionInfo.
	aVersionInfo ancestors  do:
		[ :ancestor |
			bag remove: ancestor.
			(bag occurrencesOf: ancestor) = 0
				ifTrue: [frontier add: ancestor]].
	^aVersionInfo! !

!MCFrontier methodsFor: 'advancing' stamp: 'nil'!
removeAll: collection
	collection do: [ :n | self remove: n]! !

!MCFrontier class methodsFor: 'instance creation' stamp: 'nil'!
frontierOn: aVersionInfo and: otherVersionInfo
	^ self frontierOnAll: (Array with: aVersionInfo with: otherVersionInfo)! !

!MCFrontier class methodsFor: 'instance creation' stamp: 'nil'!
frontierOn: aVersionInfo
	^ self frontierOnAll: (Array with: aVersionInfo)! !

!MCFrontier class methodsFor: 'instance creation' stamp: 'nil'!
frontierOnAll: aCollection
	| remaining  allVersions |
	remaining := Bag new.
	allVersions := (aCollection flatCollect: [:ea | ea withBreadthFirstAncestors]) asSet.
	allVersions do: [:ea | remaining addAll: ea ancestors].
	^self new frontier: aCollection bag: remaining! !

!MCFtpRepository commentStamp: ''!
I am an monticello repository implementation for the FTP protocol.!
!MCFtpRepository methodsFor: 'accessing' stamp: ''!
user: userString
	user := userString! !

!MCFtpRepository methodsFor: '*metacello-testsplatform' stamp: ''!
host

	^host! !

!MCFtpRepository methodsFor: 'interface' stamp: ''!
loadAllFileNames
	^ self clientDo:
		[:client |
		self parseDirectoryListing: client getDirectory]! !

!MCFtpRepository methodsFor: 'accessing' stamp: ''!
directory: dirPath
	directory := dirPath! !

!MCFtpRepository methodsFor: 'required' stamp: ''!
description
	^ 'ftp://', host, '/', directory! !

!MCFtpRepository methodsFor: 'accessing' stamp: ''!
password: passwordString
	password := passwordString! !

!MCFtpRepository methodsFor: 'enumerating' stamp: ''!
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: 'required' stamp: ''!
writeStreamForFileNamed: aString replace: ignoreBoolean do: aBlock

	self clientDo:
			[:client |
			client binary.
			client putFileStreamContents: (ByteArray streamContents: aBlock) readStream as: aString]! !

!MCFtpRepository methodsFor: '*metacello-testsplatform' stamp: ''!
directory

	^directory! !

!MCFtpRepository methodsFor: '*metacello-pharocommonplatform' stamp: ''!
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: 'accessing' stamp: ''!
host: hostname
	host := hostname! !

!MCFtpRepository methodsFor: 'parsing' stamp: ''!
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: 'required' stamp: ''!
readStreamForFileNamed: aString do: aBlock
	
	^ self clientDo: [:client | 
		client binary.
		aBlock value: (client getFileNamed: aString) asByteArray readStream]! !

!MCFtpRepository class methodsFor: 'accessing' stamp: ''!
templateCreationSelector
	^ #host:directory:user:password: ! !

!MCFtpRepository class methodsFor: '*MonticelloGUI' stamp: ''!
fillInTheBlankRequest
	^ 'FTP Repository:'

	! !

!MCFtpRepository class methodsFor: '*Metacello-MC' stamp: ''!
createRepositoryFromSpec: aRepositorySpec on: aPlatform
	^ aPlatform createFtpRepository: aRepositorySpec! !

!MCFtpRepository class methodsFor: 'accessing' stamp: ''!
description
	^ 'FTP'! !

!MCFtpRepository class methodsFor: 'instance creation' stamp: ''!
host: host directory: directory user: user password: password
	^ self new
		host: host;
		directory: directory;
		user: user;
		password: password! !

!MCFtpRepository class methodsFor: 'accessing' stamp: ''!
urlSchemes
	^ #(ftp)! !

!MCFtpRepository class methodsFor: '*Metacello-MC' stamp: ''!
isAvailableFor: type
	^ type = 'ftp'! !

!MCFtpRepository class methodsFor: 'accessing' stamp: ''!
creationTemplate
	^
'MCFtpRepository
	host: ''modules.blopy.org''
	directory: ''mc''
	user: ''blop''
	password: ''pilou'''
	! !

!MCFtpRepository class methodsFor: 'instance creation' stamp: ''!
basicFromUrl: aZnUrl
	^ self
		host: (aZnUrl hasPort ifTrue: [ aZnUrl host, ':', aZnUrl port asString ] ifFalse: [ aZnUrl host ])
		directory: aZnUrl path "MCFtpRepository assumes NO prefixed / in the path"
		user: (aZnUrl username ifNil: [ '' ])
		password: (aZnUrl password ifNil: [ '' ])! !

!MCFtpRepository class methodsFor: '*MonticelloGUI' stamp: ''!
morphicConfigure
	^ self fillInTheBlankConfigure! !

!MCGemstoneRepository commentStamp: ''!
An explicit subclass of MCHttpRepository to provide a template for gemstone repositories.!
!MCGemstoneRepository methodsFor: 'interface' stamp: ''!
includesVersionNamed: aString
	"directly do a filename check since the server only stores mcz"
	^ self includesFileNamed: aString, '.mcz'! !

!MCGemstoneRepository class methodsFor: 'accessing' stamp: ''!
description
	^ 'ss3.gemstone.com'! !

!MCGemstoneRepository class methodsFor: 'accessing' stamp: ''!
baseURL
	^ 'http://ss3.gemtalksystems.com/ss/'! !

!MCGemstoneRepository class methodsFor: 'testing' stamp: ''!
isResponsibleFor: aUrl
	^ (aUrl includesSubstring: 'ss3.gemstone.com/') or: [  aUrl includesSubstring: 'ss3.gemtalksystems.com/' ]! !

!MCGitBasedNetworkRepository methodsFor: 'private' stamp: ''!
validateLocalRepository
	| dir |

	dir := self calculateRepositoryDirectory.
	(dir = localRepository directory 
		and: [ MCFileTreeFileUtils current directoryExists: dir ]) 
		ifTrue: [ ^ self ].
	self flushCache.
 	self resolveLocalRespository.! !

!MCGitBasedNetworkRepository methodsFor: 'initialization' stamp: ''!
projectPath: aProjectPath projectVersion: aProjectVersion repoPath: aRepoPath
  self projectPath: aProjectPath.
  self projectVersion: aProjectVersion.	"Important that projectVersion be set AFTER projectPath"
  self repoPath: aRepoPath! !

!MCGitBasedNetworkRepository methodsFor: 'private' stamp: ''!
calculateRepositoryDirectory
	 | directory |
	
	directory := self class
		projectDirectoryFrom: self projectPath
		version: self projectVersion.
	self repoPath isEmpty ifFalse: [
		directory := MetacelloPlatform current
			directoryFromPath: self repoPath
 			relativeTo: directory ].
		
	^ directory! !

!MCGitBasedNetworkRepository methodsFor: 'initialization' stamp: ''!
flushCache
  "the directory acts like a cache since we download the directory from a git-based repository (github, bitbucket, etc.)"
	| directory |

	[ localRepository flushCache ]
	on: Error
	do: [ :ex | 
		SystemNotification signal: 'Error for: ' , self description printString , ' during flushCache: ', ex description printString ].
	self class flushDownloadCache.
	
	directory := self calculateRepositoryDirectory.
	directory exists 
		ifTrue: [ localRepository directory: directory ]
		ifFalse: [ localRepository resetDirectory ]! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
repositoryVersionString
  "for git-based network repos, answer the SHA associated with the download: a commit SHA or tag SHA"

  | versionComponents versionElement pathElements gitBasedPath repositoryDirPath projectDirPath projectDir projectVersionDir |
  repositoryDirPath := self directory fullName.
  projectDir := self class cacheDirectoryFor: self projectPath.
  projectVersionDir := MCFileTreeFileUtils current
    directoryFromPath: self projectVersion
    relativeTo: projectDir.
  projectDirPath := projectVersionDir fullName.
  (repositoryDirPath beginsWith: projectDirPath)
    ifFalse: [ ^ self projectVersion ].
  gitBasedPath := repositoryDirPath
    copyFrom: projectDirPath size + 2
    to: repositoryDirPath size.
  pathElements := gitBasedPath findTokens: '/'.
  versionElement := pathElements at: 1.
  versionComponents := versionElement findTokens: '-'.
  ^ versionComponents last! !

!MCGitBasedNetworkRepository methodsFor: 'comparing' stamp: ''!
hash
    ^ self description hash! !

!MCGitBasedNetworkRepository methodsFor: 'testing' stamp: ''!
includesVersionNamed: aString
	^ self localRepository includesVersionNamed: aString! !

!MCGitBasedNetworkRepository methodsFor: 'private' stamp: ''!
normalizeTagsData: jsonObject
  ^ self subclassResponsibility! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
repoPath: anObject
    repoPath := anObject! !

!MCGitBasedNetworkRepository methodsFor: 'private' stamp: ''!
downloadJSONTags
  | tagsUrl jsonObject |
  tagsUrl := self projectTagsUrlFor: self projectPath.
  jsonObject := MetacelloPlatform current
    downloadJSON: tagsUrl
    username: self class siteUsername
    pass: self class sitePassword.
  ^ self normalizeTagsData: jsonObject! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
projectVersion: aString
  "Important that projectVersion be set AFTER projectPath, as projectPath needed for resolving projectVersionPattern"

  | x |
  aString
    ifNil: [ 
      projectVersion := aString.
      ^ self ].
  (x := aString
    findDelimiters:
      {$#.
      $*.
      $?}
    startingAt: 1) <= aString size
    ifTrue: [ self resolveProjectVersionPattern: aString ]
    ifFalse: [ projectVersion := aString ]! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
projectVersion
    (projectVersion == nil or: [ projectVersion isEmpty ])
        ifTrue: [ projectVersion := 'master' ].
    ^ projectVersion! !

!MCGitBasedNetworkRepository methodsFor: 'descriptions' stamp: ''!
description
  | desc |
  desc := self class description , self projectPath , ':'
    , self projectVersionEscaped.
  self repoPath isEmpty
    ifTrue: [ ^ desc ].
  ^ desc , '/' , self repoPath! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
goferVersionFrom: aVersionReference
	self flag: #review. "This will fail in non filtree(cypress) formats, but I need to 
	 implement it to make the tests pass. A better approach maybe to look at those tests 
	 and try to implement them better."
	^ self localRepository goferVersionFrom: aVersionReference! !

!MCGitBasedNetworkRepository methodsFor: '*Iceberg' stamp: ''!
createIcebergRepositoryWithFallbackFor: remote url: remoteUrl
	| urlToUse  |
	
	urlToUse := remoteUrl.
	[ ^ self createIcebergRepositoryFor: urlToUse ]
	on: IceAuthenticationError do: [ :e |
		self traceCr: ('I got an error while cloning: {1}. I will try to clone the HTTPS variant.' format: { e messageText }). 
		urlToUse := remote httpsUrl.
		e retry ]! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
directory
  ^ self localRepository directory! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
possiblyNewerVersionsOfAnyOf: someVersions
	^ self localRepository possiblyNewerVersionsOfAnyOf: someVersions! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
projectPath: anObject
    projectPath := anObject! !

!MCGitBasedNetworkRepository methodsFor: 'private' stamp: ''!
projectTagsUrlFor: aProjectPath
	self subclassResponsibility! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
metacelloProjectClassFor: aScriptEngine
    ^ MetacelloMCBaselineProject! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
goferReferences
	"delegate collection to local repository, but change them to be from *this* repository."

	^ self localRepository goferReferences 
		collect: [ :each | 
			GoferResolvedReference 
				name: each name 
				repository: self ]! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
asRepositorySpecFor: aMetacelloMCProject
  ^ aMetacelloMCProject repositorySpec
    description: self description;
    type: self class basicDescription;
    yourself! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
projectVersionPattern
  "do not set projectVersionPattern unless it _is_ a pattern: includes $#, %*, or $?"

  projectVersionPattern ifNil: [ ^ self projectVersion ].
  ^ projectVersionPattern! !

!MCGitBasedNetworkRepository methodsFor: 'private' stamp: ''!
resolveProjectVersionPattern: aString
  "aString must conform to the syntax for MetacelloVersionNumber with the exception that aString may have a leading $v which is stripped before conversion to a MetacelloVersionNumber patterm"

  | patternString tagDictionary matchingTags tagAssocs sortedMatchingTags theTag |
  self projectPath
    ifNil: [ self error: 'projectPath must be set to resolve project version pattern.' ].
  patternString := (self class projectVersionFromString: aString) asString.
  tagDictionary := self downloadJSONTags.
  tagAssocs := tagDictionary keys
    collect: [ :tagName | 
      | tagVersion |
      tagVersion := self class projectVersionFromString: tagName.
      tagVersion -> tagName ].
  matchingTags := tagAssocs select: [ :assoc | assoc key match: patternString ].
  matchingTags isEmpty
    ifTrue: [ 
      projectVersion := aString.
      ^ self
        error:
          'No tags matching the pattern ' , aString printString
            , ' found for repository description '
            , self description printString ].
  sortedMatchingTags := matchingTags asArray sort: [ :a :b | a key <= b key ].
  theTag := sortedMatchingTags last.
  projectVersionPattern := aString.
  projectVersion := theTag value! !

!MCGitBasedNetworkRepository methodsFor: '*Iceberg' stamp: ''!
getOrCreateIcebergRepository
	| remoteUrl |
	
	remoteUrl := self perform: Iceberg remoteTypeSelector.
	^ IceRepository registry 
		detect: [ :repo | repo isCloneOfUrl: remoteUrl ]
		ifNone: [ | remote |
			remote := IceGitRemote url: remoteUrl.
			self createIcebergRepositoryWithFallbackFor: remote url: remoteUrl ]! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
repoPath
  repoPath ifNil: [ repoPath := '' ].
  ^ repoPath! !

!MCGitBasedNetworkRepository methodsFor: '*Iceberg' stamp: ''!
httpUrl

	^ self httpsUrl copyReplaceAll: 'https://' with: 'http://'! !

!MCGitBasedNetworkRepository methodsFor: 'private' stamp: ''!
ensureLocalRepository
	localRepository ifNotNil: [ ^ self ].
	self resolveLocalRespository! !

!MCGitBasedNetworkRepository methodsFor: '*Iceberg' stamp: ''!
httpsUrl

	self subclassResponsibility! !

!MCGitBasedNetworkRepository methodsFor: 'initialize-release' stamp: ''!
hasNoLoadConflicts: anMCGitBasedRepository
  (anMCGitBasedRepository isKindOf: self class)
    ifFalse: [ ^ false ].
  ^ self projectPath = anMCGitBasedRepository projectPath
    and: [ 
      self repoPath = anMCGitBasedRepository repoPath
        and: [ self projectVersion = anMCGitBasedRepository projectVersion ] ]! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
projectVersionPattern: aString
  "do not set projectVersionPattern unless it _is_ a pattern: includes $#, %*, or $?"

  projectVersionPattern := aString! !

!MCGitBasedNetworkRepository methodsFor: 'private' stamp: ''!
localRepository
	self ensureLocalRepository.
	self validateLocalRepository.
	^ localRepository! !

!MCGitBasedNetworkRepository methodsFor: '*Iceberg' stamp: ''!
createIcebergRepositoryFor: remoteUrl
	| builder repository |
	builder := IceRepositoryCreator new 
		url: remoteUrl;
		subdirectory: repoPath;
		commitishName: self projectVersion;
		ensureProjectFile;
		yourself.

	[ repository := builder createRepository ]
	on: IceDuplicatedRepository 
	do: [ :e | 
		e resignalAs: (IceMetacelloDuplicatedNotification new
			builder: builder;
			yourself)  ].
	
	repository register.
	
	^ repository! !

!MCGitBasedNetworkRepository methodsFor: 'storing' stamp: ''!
storeVersion: aVersion
	^ self localRepository storeVersion: aVersion! !

!MCGitBasedNetworkRepository methodsFor: 'initialization' stamp: ''!
flushForScriptGet

	self class 
		flushProjectEntry: self projectPath 
		version: self projectVersion.
    self localRepository flushForScriptGet! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
projectVersionEscaped
  | pv |
  pv := self projectVersion.
  (projectVersion includes: $/)
    ifTrue: [ ^ pv copyReplaceAll: '/' with: '\/' ].
  ^ pv! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
repositoryBranchName
  "for git-based network repos, answer the value of the projectVersion field"

  ^ self projectVersion! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
versionFrom: aVersionReferenceString
	^ self localRepository versionFrom: aVersionReferenceString! !

!MCGitBasedNetworkRepository methodsFor: 'testing' stamp: ''!
isValid
    ^ true! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
versionWithInfo: aVersionInfo ifAbsent: errorBlock
	^ self localRepository 
		versionWithInfo: aVersionInfo 
		ifAbsent: errorBlock! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
closestAncestorVersionFor: anAncestry ifNone: errorBlock
	^ self localRepository 
		closestAncestorVersionFor: anAncestry 
		ifNone: errorBlock! !

!MCGitBasedNetworkRepository methodsFor: 'private' stamp: ''!
resolveLocalRespository
	| directory directoryPath |
  
	directory := self calculateRepositoryDirectory.
	directoryPath := MCFileTreeFileUtils current directoryPathString: directory.
	directory ifAbsent: [ self error: 'Local directory ', directoryPath, ' does not exist.' ].
	localRepository := MetacelloPlatform current createRepository: (MetacelloRepositorySpec new 
		description: 'filetree://', directoryPath;
		yourself)! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
projectPath
    ^ projectPath! !

!MCGitBasedNetworkRepository methodsFor: 'initialization' stamp: ''!
canUpgradeTo: anMCGitBasedRepository
  (anMCGitBasedRepository isKindOf: self class)
    ifFalse: [ ^ false ].
  ^ self projectPath = anMCGitBasedRepository projectPath
    and: [ self repoPath = anMCGitBasedRepository repoPath ]! !

!MCGitBasedNetworkRepository methodsFor: 'accessing' stamp: ''!
allFileNames
	self flag: #review. "This will fail in non filtree(cypress) formats, but I need to 
	 implement it to make the tests pass. A better approach maybe to look at those tests 
	 and try to implement them better."
	^ self localRepository allFileNames! !

!MCGitBasedNetworkRepository class methodsFor: 'accessing' stamp: ''!
downloadCache
  repoDownloadCache ifNil: [ repoDownloadCache := Dictionary new ].
  ^ repoDownloadCache! !

!MCGitBasedNetworkRepository class methodsFor: 'site credentials' stamp: ''!
sitePassword: aString
  sitePassword := aString! !

!MCGitBasedNetworkRepository class methodsFor: 'testing' stamp: ''!
isEnabled

	^false! !

!MCGitBasedNetworkRepository class methodsFor: 'instance creation' stamp: ''!
location: locationUrl
    ^ self location: locationUrl version: nil! !

!MCGitBasedNetworkRepository class methodsFor: 'accessing' stamp: ''!
description
  ^ self basicDescription , '://'! !

!MCGitBasedNetworkRepository class methodsFor: 'private' stamp: ''!
parseProjectVersionField: parseBlock desc: desc versionDelim: versionDelim
  "Issue #234: have to allow for commitish containing slashes"

  | strm done escaped repoDelim |
  strm := WriteStream on: String new.
  repoDelim := versionDelim + 1.
  escaped := done := false.
  [ done ]
    whileFalse: [ 
      | char |
      repoDelim > desc size
        ifTrue: [ done := true ]
        ifFalse: [ 
          char := desc at: repoDelim.
          char == $\
            ifTrue: [ 
              escaped
                ifTrue: [ 
                  "$\ not legal in branch name ... literally ignored"
                  escaped := false ]
                ifFalse: [ escaped := true ] ]
            ifFalse: [ 
              char == $/
                ifTrue: [ 
                  escaped
                    ifFalse: [ done := true ] ].
              done
                ifFalse: [ strm nextPut: char ].
              escaped := false ].
          repoDelim := repoDelim + 1 ] ].
  repoDelim := repoDelim - 1.
  parseBlock
    value: strm contents
    value: (desc copyFrom: repoDelim + 1 to: desc size)! !

!MCGitBasedNetworkRepository class methodsFor: 'accessing' stamp: ''!
basicDescription
  ^ self subclassResponsibility! !

!MCGitBasedNetworkRepository class methodsFor: 'accessing' stamp: ''!
cacheDirectoryPath: aString
  self
    cacheDirectory:
      (aString
        ifEmpty: [  ]
        ifNotEmpty: [ MetacelloPlatform current fileHandleOn: aString ])! !

!MCGitBasedNetworkRepository class methodsFor: 'utilities' stamp: ''!
flushProjectEntry: projectPath version: versionString
    self downloadCache removeKey: (self downloadCacheKey: projectPath version: versionString) ifAbsent: [  ]! !

!MCGitBasedNetworkRepository class methodsFor: 'private' stamp: ''!
resetCacheDirectoryIfInvalid
  "Reset if invalid"

  repoCacheDirectory notNil
    and: [ 
      (MCFileTreeFileUtils current directoryExists: repoCacheDirectory)
        ifFalse: [ repoCacheDirectory := nil ] ]! !

!MCGitBasedNetworkRepository class methodsFor: 'private' stamp: ''!
projectZipUrlFor: projectPath versionString: versionString
  self subclassResponsibility! !

!MCGitBasedNetworkRepository class methodsFor: 'private' stamp: ''!
cacheDirectoryFor: projectPath
	| cacheDirectory projectDirectory |
	
	cacheDirectory := self cacheDirectory.
	projectDirectory := MetacelloPlatform current directoryFromPath: projectPath relativeTo: cacheDirectory.
	MetacelloPlatform current ensureDirectoryExists: projectDirectory.
	^ projectDirectory! !

!MCGitBasedNetworkRepository class methodsFor: 'private' stamp: ''!
cacheDirectory: aDirectory
  "explicitly set repoCacheDirectory"

  repoCacheDirectory := aDirectory! !

!MCGitBasedNetworkRepository class methodsFor: 'initialization' stamp: ''!
initialize
  "self initialize"

	(Smalltalk classNamed: #SessionManager)
		ifNotNil: [ :c | c default perform: #registerNetworkClassNamed: with: self name ]
		ifNil:[ Smalltalk addToStartUpList: self ].
  self flushDownloadCache.
  self resetCacheDirectoryIfInvalid! !

!MCGitBasedNetworkRepository class methodsFor: 'private' stamp: ''!
cacheDirectory
  self resetCacheDirectoryIfInvalid.
  repoCacheDirectory ifNil: [ repoCacheDirectory := self defaultCacheDirectory ].
  ^ repoCacheDirectory! !

!MCGitBasedNetworkRepository class methodsFor: 'private' stamp: ''!
defaultCacheDirectory
  | defaultDirectory cacheDirectory |
  defaultDirectory := MetacelloPlatform current defaultDirectory.
  cacheDirectory := MetacelloPlatform current
    directoryFromPath: self basicDescription , '-cache'
    relativeTo: defaultDirectory.
  MetacelloPlatform current ensureDirectoryExists: cacheDirectory.
  ^ cacheDirectory! !

!MCGitBasedNetworkRepository class methodsFor: 'utilities' stamp: ''!
projectDirectoryFrom: projectPath version: versionString
	| mcPlatform theCacheDirectory projectDirectory downloadCacheKey cachePath pid |
	downloadCacheKey := self
		downloadCacheKey: projectPath
		version: versionString.
	mcPlatform := MetacelloPlatform current.
	theCacheDirectory := mcPlatform
		directoryFromPath: versionString
		relativeTo: (self cacheDirectoryFor: projectPath).
	cachePath := self downloadCache at: downloadCacheKey ifAbsent: [  ].
	(cachePath isNil
		or: [ (projectDirectory := mcPlatform
				directoryFromPath: cachePath
				relativeTo: theCacheDirectory) exists not ])
		ifTrue: [ | url archive directory zipFileName |
			MetacelloScriptGitBasedDownloadNotification new
				projectPath: projectPath;
				versionString: versionString;
				signal.	"for testing purposes"
			mcPlatform ensureDirectoryExists: theCacheDirectory.
			url := self
				projectZipUrlFor: projectPath
				versionString: versionString.
			pid := mcPlatform processPID.
			zipFileName := mcPlatform
				tempFileFor:
					self basicDescription , '-' , pid , '-'
						, (downloadCacheKey select: [ :c | c isAlphaNumeric ])
				suffix: '.zip'.
			archive := mcPlatform
				downloadZipArchive: url
				to: zipFileName.
			directory := mcPlatform
				directoryFromPath: (cachePath := archive members first fileName)
				relativeTo: theCacheDirectory.
			mcPlatform closeZipArchive: archive.
			directory exists
				ifTrue: [ mcPlatform deleteFileNamed: zipFileName ]
				ifFalse: [ mcPlatform
						extractRepositoryFrom: zipFileName
						to: theCacheDirectory fullName ].
			self downloadCache at: downloadCacheKey put: cachePath.
			projectDirectory := mcPlatform
				directoryFromPath: cachePath
				relativeTo: theCacheDirectory ].
	^ projectDirectory! !

!MCGitBasedNetworkRepository class methodsFor: 'instance creation' stamp: ''!
location: locationUrl version: versionString
    ^ self parseLocation: locationUrl version: versionString! !

!MCGitBasedNetworkRepository class methodsFor: 'site credentials' stamp: ''!
sitePassword
  ^ sitePassword! !

!MCGitBasedNetworkRepository class methodsFor: 'accessing' stamp: ''!
cacheDirectoryPath
  ^ MCFileTreeFileUtils current directoryPathString: self cacheDirectory! !

!MCGitBasedNetworkRepository class methodsFor: 'accessing' stamp: ''!
isAbstract
    "abstract as far as creating new repositories interactively? yes"

    ^ true! !

!MCGitBasedNetworkRepository class methodsFor: 'private' stamp: ''!
parseLocation: locationUrl version: versionString
  "self 
	parseLocation: 'github://dalehenrich/MetacelloRepository:master/monticello/repos/itory/path'
	version: nil
     "

  | projectPath projectVersion repoPath headerSize desc projectDelim repoDelim versionDelim |
  headerSize := self description size.
  desc := locationUrl.
  desc := desc copyFrom: headerSize + 1 to: desc size.
  projectVersion := repoPath := nil.
  projectDelim := desc indexOf: $/.
  repoDelim := desc indexOf: $/ startingAt: projectDelim + 1.
  (versionDelim := desc indexOf: $:) == 0
    ifTrue: [ 
      repoDelim == 0
        ifTrue: [ projectPath := desc ]
        ifFalse: [ 
          projectPath := desc copyFrom: 1 to: repoDelim - 1.
          repoPath := desc copyFrom: repoDelim + 1 to: desc size ] ]
    ifFalse: [ 
      projectPath := desc copyFrom: 1 to: versionDelim - 1.
      repoDelim == 0
        ifTrue: [ projectVersion := desc copyFrom: versionDelim + 1 to: desc size ]
        ifFalse: [ 
          projectPath := desc copyFrom: 1 to: versionDelim - 1.
          self
            parseProjectVersionField: [ :pv :rp | 
              projectVersion := pv.
              repoPath := rp ]
            desc: desc
            versionDelim: versionDelim ] ].
  versionString ~~ nil
    ifTrue: [ projectVersion := versionString ].
  ^ self new
    projectPath: projectPath
    projectVersion: projectVersion
    repoPath: repoPath! !

!MCGitBasedNetworkRepository class methodsFor: 'version patterns' stamp: ''!
projectVersionFromString: aString
  "strip leading $v if present and return an instance of MetacelloVersionNumber"

  | versionString |
  versionString := aString.
  (versionString beginsWith: 'v')
    ifTrue: [ versionString := versionString copyFrom: 2 to: versionString size ].
  ^ MetacelloVersionNumber fromString: versionString! !

!MCGitBasedNetworkRepository class methodsFor: 'accessing' stamp: ''!
downloadCacheKey: projectPath version: versionString
  ^ projectPath , ':::' , versionString! !

!MCGitBasedNetworkRepository class methodsFor: 'site credentials' stamp: ''!
siteUsername: aString
  siteUsername := aString! !

!MCGitBasedNetworkRepository class methodsFor: 'system startup' stamp: ''!
startUp: resuming
    "Flush the GitHub download cache"

    resuming
        ifTrue: [ self flushDownloadCache ]! !

!MCGitBasedNetworkRepository class methodsFor: 'site credentials' stamp: ''!
siteUsername: username sitePassword: pass
  "MCBitbucketRepository siteUsername: '' sitePassword: ''"

  "MCGitHubRepository siteUsername: '' sitePassword: ''"

  self
    siteUsername: username;
    sitePassword: pass! !

!MCGitBasedNetworkRepository class methodsFor: 'site credentials' stamp: ''!
siteUsername
  ^ siteUsername! !

!MCGitBasedNetworkRepository class methodsFor: 'initialization' stamp: ''!
flushDownloadCache
  "self flushDownloadCache"

  repoDownloadCache := nil! !

!MCGitHubRepository methodsFor: 'private' stamp: ''!
normalizeTagsData: jsonObject
  "return a dictionay mapping the tag name to the commit SHA"

  | tagDict |
  jsonObject isDictionary
    ifTrue: [ 
      jsonObject
        at: 'message'
        ifPresent: [ :errorString | 
          self
            error:
              'Error accessing tags for github project: ' , self projectPath printString
                , ' -> ' , errorString printString ] ].
  tagDict := Dictionary new.
  jsonObject
    do: [ :tagObject | 
      | tag commit |
      tag := tagObject at: 'name'.
      commit := tagObject at: 'commit'.
      tagDict at: tag put: (commit at: 'sha') ].
  ^ tagDict! !

!MCGitHubRepository methodsFor: '*Iceberg-Adapters' stamp: ''!
commitIdFor: aMCWorkingCopy ifFound: aBlockClosure 
	(aMCWorkingCopy repositoryGroup includes: self)
		ifTrue: [ aBlockClosure value: self commitId ]! !

!MCGitHubRepository methodsFor: 'private' stamp: ''!
projectTagsUrlFor: projectPath2
  ^ 'https://api.github.com/repos/' , projectPath2 , '/tags'! !

!MCGitHubRepository methodsFor: '*Iceberg-Adapters' stamp: ''!
commitId
	"This kind of repo is associated to a specific commit that was downloaded, 
	sadly the only way to know it is to parse the directory name."
	| repoRoot |
	repoRoot := self repoPath isEmpty ifTrue: [ self directory ] ifFalse: [ self directory parent ].
	^ repoRoot basename copyAfterLast: $-.! !

!MCGitHubRepository methodsFor: 'private' stamp: ''!
downloadJSONTags
  | tagsUrl jsonObject |
  tagsUrl := self projectTagsUrlFor: self projectPath.
  jsonObject := MetacelloPlatform current
    downloadJSON: tagsUrl
    eTagsCache: self class eTagsCache
    eTagsKey: self projectPath
    username: self class siteUsername
    pass: self class sitePassword.
  ^ self normalizeTagsData: jsonObject! !

!MCGitHubRepository methodsFor: '*Iceberg-Adapters' stamp: ''!
scpUrl
	^ 'git@github.com:', projectPath, '.git'! !

!MCGitHubRepository methodsFor: '*Iceberg-Adapters' stamp: ''!
httpsUrl
	^ 'https://github.com/', projectPath, '.git'! !

!MCGitHubRepository class methodsFor: 'private' stamp: ''!
projectZipUrlFor: projectPath versionString: versionString
  ^ 'https://github.com/' , projectPath , '/zipball/' , versionString! !

!MCGitHubRepository class methodsFor: 'private' stamp: ''!
cacheDirectory: aDirectory
  "use class var to survive upgrade when MCGitHubRepository moved to subclass of MCGitBasedRepository"

  CacheDirectory := aDirectory! !

!MCGitHubRepository class methodsFor: 'private' stamp: ''!
cacheDirectory
  "use class var to survive upgrade when MCGitHubRepository moved to subclass of MCGitBasedRepository"

  self resetCacheDirectoryIfInvalid.
  ^ CacheDirectory ifNil: [ self defaultCacheDirectory ].! !

!MCGitHubRepository class methodsFor: 'testing' stamp: ''!
isEnabled

	^true! !

!MCGitHubRepository class methodsFor: 'instance creation' stamp: ''!
createRepositoryFromSpec: aRepositorySpec on: aPlatform
	^ aPlatform createGithubRepository: aRepositorySpec! !

!MCGitHubRepository class methodsFor: 'accessing' stamp: ''!
basicDescription
  ^ 'github'! !

!MCGitHubRepository class methodsFor: 'accessing' stamp: ''!
cacheDirectoryPath
  <preference: 'GitHub Cache' category: 'Metacello' description: '' type:
    #'String'>
  ^ super cacheDirectoryPath! !

!MCGitHubRepository class methodsFor: 'accessing' stamp: ''!
eTagsCache
  "To avoid GitHub rate limiting problems, we are caching the ETags for the tag request: https://developer.github.com/v3/#conditional-requests"

  ETagsCache ifNil: [ ETagsCache := Dictionary new ].
  ^ ETagsCache! !

!MCGitHubRepository class methodsFor: 'private' stamp: ''!
resetCacheDirectoryIfInvalid
  "use class var to survive upgrade when MCGitHubRepository moved to subclass of MCGitBasedRepository"

  "Reset if invalid"

  CacheDirectory notNil
    and: [ 
      (MCFileTreeFileUtils current directoryExists: CacheDirectory)
        ifFalse: [ CacheDirectory := nil ] ]! !

!MCGitHubRepository class methodsFor: '*Metacello-Platform' stamp: ''!
urlSchemes
	^ #(github)! !

!MCGitHubRepository class methodsFor: 'testing' stamp: ''!
isAvailableFor: type
	^ type = 'github'! !

!MCGitHubRepository class methodsFor: '*Iceberg-Adapters' stamp: ''!
commitIdFor: aWorkingCopy
	^ aWorkingCopy repositoryGroup repositories 
		detect: [ :repo | repo isKindOf: self ] 
		ifFound: #commitId
		ifNone: nil
! !

!MCGitHubRepository class methodsFor: '*Metacello-Platform' stamp: ''!
basicFromUrl: aZnUrl 
	^ self location: aZnUrl asString! !

!MCGitHubRepository class methodsFor: 'initialization' stamp: ''!
flushDownloadCache
  "use class var to survive upgrade when MCGitHubRepository moved to subclass of MCGitBasedRepository"

  "self flushDownloadCache"

  DownloadCache := nil! !

!MCGitHubRepository class methodsFor: 'accessing' stamp: ''!
downloadCache
  "use class var to survive upgrade when MCGitHubRepository moved to subclass of MCGitBasedRepository"

  DownloadCache ifNil: [ DownloadCache := Dictionary new ].
  ^ DownloadCache! !

!MCGitHubRepository class methodsFor: 'initialization' stamp: ''!
flushETagsCache
  "mainly needed for tests .... but if you want to pare down object consumption..."

  "self flushETagsCache"

  ETagsCache := nil! !

!MCGitRemoteRepository commentStamp: ''!
I am a repository managing projects hosted on generic git repositories.

I accept urls of the kind: 

https://github.com/user/project.git
git@github.com:user/project.git

WARNING: This repository is meant to be used with iceberg and it will not work with plain Monticello/Metacello (because there is no way to know how to download a zip)!
!MCGitRemoteRepository methodsFor: 'accessing' stamp: ''!
scpUrl

	^ '{1}@{2}/{3}.git' format: { 
		self user. 
		self host. 
		self path }! !

!MCGitRemoteRepository methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.! !

!MCGitRemoteRepository methodsFor: 'accessing' stamp: ''!
host

	^ host! !

!MCGitRemoteRepository methodsFor: 'private - initialization' stamp: ''!
parseLocation: aString

	(#('http:' 'https:') 
		anySatisfy: [ :each | aString beginsWith: each ])
		ifTrue: [ self parseHTTPLocation: aString ]
		ifFalse: [ self parseSSHLocation: aString ]! !

!MCGitRemoteRepository methodsFor: 'private - initialization' stamp: ''!
parseHTTPLocation: aString
	| url |

	url := aString asUrl.
	host := url host.
	port := url port.
	path := self pathFrom: url path! !

!MCGitRemoteRepository methodsFor: 'accessing' stamp: ''!
user

	^ user! !

!MCGitRemoteRepository methodsFor: 'private - initialization' stamp: ''!
parseSSHLocation: aString
	| segments |
	
	segments := aString substrings: '@:'.
	user := segments first.
	host := segments second.
	path := self pathFrom: segments third! !

!MCGitRemoteRepository methodsFor: 'accessing' stamp: ''!
port

	^ port! !

!MCGitRemoteRepository methodsFor: 'accessing' stamp: ''!
projectPath

	^ self path! !

!MCGitRemoteRepository methodsFor: 'accessing' stamp: ''!
path

	^ path! !

!MCGitRemoteRepository methodsFor: 'private - initialization' stamp: ''!
pathFrom: aString

	^ (aString endsWith: '.git')
		ifTrue: [ aString allButLast: 4 ]
		ifFalse: [ aString ]! !

!MCGitRemoteRepository methodsFor: 'accessing' stamp: ''!
httpsUrl

	^ 'https://{1}{2}/{3}.git' format: { 
		self host. 
		self port 
			ifNotNil: [ ':', self port asString ]
			ifNil: [ '' ].
		self path }! !

!MCGitRemoteRepository class methodsFor: 'accessing' stamp: ''!
description

  ^ self basicDescription , ':'! !

!MCGitRemoteRepository class methodsFor: 'accessing' stamp: ''!
basicDescription

  ^ 'git'! !

!MCGitRemoteRepository class methodsFor: 'private' stamp: ''!
parseLocation: aLocation version: aVersion 

	^ self new
	parseLocation: (aLocation allButFirst: self description size);
	yourself ! !

!MCGitlabRepository commentStamp: ''!
Description
--------------------

I am a repository managing projects hosted on gitlab.com or a self hosted gitlab.

I am able to manage schemes such has:

- gitlab://pharo-project/pharo:master/src
- gitlab://pharo-project/pharo:master
- gitlab://pharo-project/pharo
- gitlab://git.pharo.org:pharo-project/pharo:master/src
- gitlab://git.pharo.org:pharo-project/pharo:master
- gitlab://git.pharo.org:pharo-project/pharo
- gitlab://git.pharo.org:1234:pharo-project/pharo:master/src
- gitlab://git.pharo.org:1234:pharo-project/pharo:master
- gitlab://git.pharo.org:1234:pharo-project/pharo

	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	hostname:		<aString>			The hostname of the repository. By default gitlab.com. Can also be the URL of the self hosted gitlab.
	sshPort:		<aString>			Non default SSH port.
!
!MCGitlabRepository methodsFor: 'accessing' stamp: ''!
sshPort
	^ sshPort! !

!MCGitlabRepository methodsFor: 'accessing' stamp: ''!
sshPort: anObject
	sshPort := anObject! !

!MCGitlabRepository methodsFor: 'accessing' stamp: ''!
hostname
	^ hostname! !

!MCGitlabRepository methodsFor: 'private' stamp: ''!
projectTagsUrlFor: aProjectPath
	^ 'https://<1s>/api/v4/projects/<2s>/repository/tags' expandMacrosWith: self hostname with: aProjectPath! !

!MCGitlabRepository methodsFor: 'initialization' stamp: ''!
hostname: aString 
	hostname := aString! !

!MCGitlabRepository methodsFor: '*Iceberg' stamp: ''!
scpUrl
	"If the sshPort is not nil it means that we have a non default ssh port. Thus we need to add `ssh://` and th port number to the scheme"

	^ self sshPort
		ifNil: [ 'git@<1s>:<2s>.git' expandMacrosWith: self hostname with: projectPath ]
		ifNotNil: [ :port | 'ssh://git@<1s>:<2s>/<3s>.git' expandMacrosWith: self hostname with: port with: projectPath ]! !

!MCGitlabRepository methodsFor: '*Iceberg' stamp: ''!
httpsUrl
	^ 'https://<1s>/<2s>.git' expandMacrosWith: self hostname with: projectPath! !

!MCGitlabRepository class methodsFor: 'testing' stamp: ''!
isEnabled

	^ true! !

!MCGitlabRepository class methodsFor: 'accessing' stamp: ''!
basicDescription
  ^ 'gitlab'! !

!MCGitlabRepository class methodsFor: 'private' stamp: ''!
defaultHostname
	^ 'gitlab.com'! !

!MCGitlabRepository class methodsFor: 'accessing' stamp: ''!
cacheDirectoryPath
  <preference: 'Gitlab Cache' category: 'Metacello' description: '' type:
    #'String'>
  ^ super cacheDirectoryPath! !

!MCGitlabRepository class methodsFor: 'private' stamp: ''!
parseLocation: locationUrl version: versionString
	"Gitlab can be self hosted, so we need some way to tell in the location the service url and not use gitlab.com in 
	a hardcoded way.
	This parsing extensions supports adding the hostname before the project owner name:
	Eg. gitlab://selfhostedgitlab.com:owner/project
	If no hostname is specified default to the old behavior (using gitlab.com)
	"

	| location hostAndOwner |
	"Remove gitlab:// prefix"
	location := locationUrl copyFrom: self description size + 1 to: locationUrl size.
	"Take the next chunk up to the first / and split it to get the hostname and owner"
	hostAndOwner := (location copyFrom: 1 to: (location indexOf: $/)) splitOn: $:.
	^ hostAndOwner size = 1
		ifTrue: [ "No hostname specified, so use the default one"
			(super parseLocation: locationUrl version: versionString)
				hostname: self defaultHostname;
				yourself ]
		ifFalse: [ | newLocationUrl hostname sshPort numberOfCharactersToRemoveFromLocation |
			hostname := hostAndOwner first.
			numberOfCharactersToRemoveFromLocation := hostname size + 2.
			"If the hostAndOwner array has 3 parts, we have a ssh port"
			hostAndOwner size > 2
				ifTrue: [ sshPort := hostAndOwner second.
					numberOfCharactersToRemoveFromLocation := numberOfCharactersToRemoveFromLocation + sshPort size + 1 ].	
			newLocationUrl := self description , (location copyFrom: numberOfCharactersToRemoveFromLocation to: location size).
			"Reuse the parsing omitting the hostname"
			(super parseLocation: newLocationUrl version: versionString)
				hostname: hostname;
				sshPort: sshPort;
				yourself ]! !

!MCGitlabRepositoryTest methodsFor: 'tests' stamp: ''!
testSelfHostedLocation
	| repository |
	repository := MCGitlabRepository location: 'gitlab://git.pharo.org:pharo-project/pharo:master/src'.
	self
		assert: repository hostname equals: 'git.pharo.org';
		assert: repository projectPath equals: 'pharo-project/pharo';
		assert: repository projectVersion equals: 'master';
		assert: repository repoPath equals: 'src';
		assert: repository sshPort isNil.

	repository := MCGitlabRepository location: 'gitlab://git.pharo.org:pharo-project/pharo:master'.
	self
		assert: repository hostname equals: 'git.pharo.org';
		assert: repository projectPath equals: 'pharo-project/pharo';
		assert: repository projectVersion equals: 'master';
		assertEmpty: repository repoPath;
		assert: repository sshPort isNil.

	repository := MCGitlabRepository location: 'gitlab://git.pharo.org:pharo-project/pharo'.
	self
		assert: repository hostname equals: 'git.pharo.org';
		assert: repository projectPath equals: 'pharo-project/pharo';
		assert: repository projectVersion equals: 'master';
		assertEmpty: repository repoPath;
		assert: repository sshPort isNil! !

!MCGitlabRepositoryTest methodsFor: 'tests' stamp: ''!
testProjectTagsUrlFor
	| repository |
	repository := MCGitlabRepository location: 'gitlab://pharo-project/pharo:master/src'.
	self assert: (repository projectTagsUrlFor: 'pharo-project/pharo') equals: 'https://gitlab.com/api/v4/projects/pharo-project/pharo/repository/tags'.

	"Self-hosted instance"
	repository := MCGitlabRepository location: 'gitlab://git.pharo.org:pharo-project/pharo:master/src'.
	self assert: (repository projectTagsUrlFor: 'pharo-project/pharo') equals: 'https://git.pharo.org/api/v4/projects/pharo-project/pharo/repository/tags'! !

!MCGitlabRepositoryTest methodsFor: 'tests' stamp: ''!
testSelfHostedLocationWithNonDefaultSSHPort
	| repository |
	repository := MCGitlabRepository location: 'gitlab://git.pharo.org:1234:pharo-project/pharo:master/src'.
	self
		assert: repository hostname equals: 'git.pharo.org';
		assert: repository projectPath equals: 'pharo-project/pharo';
		assert: repository projectVersion equals: 'master';
		assert: repository repoPath equals: 'src';
		assert: repository sshPort equals: '1234'.

	repository := MCGitlabRepository location: 'gitlab://git.pharo.org:1234:pharo-project/pharo:master'.
	self
		assert: repository hostname equals: 'git.pharo.org';
		assert: repository projectPath equals: 'pharo-project/pharo';
		assert: repository projectVersion equals: 'master';
		assertEmpty: repository repoPath;
		assert: repository sshPort equals: '1234'.

	repository := MCGitlabRepository location: 'gitlab://git.pharo.org:1234:pharo-project/pharo'.
	self
		assert: repository hostname equals: 'git.pharo.org';
		assert: repository projectPath equals: 'pharo-project/pharo';
		assert: repository projectVersion equals: 'master';
		assertEmpty: repository repoPath;
		assert: repository sshPort equals: '1234'! !

!MCGitlabRepositoryTest methodsFor: 'tests' stamp: ''!
testLocation
	| repository |
	repository := MCGitlabRepository location: 'gitlab://pharo-project/pharo:master/src'.
	self
		assert: repository hostname equals: 'gitlab.com';
		assert: repository projectPath equals: 'pharo-project/pharo';
		assert: repository projectVersion equals: 'master';
		assert: repository repoPath equals: 'src';
		assert: repository sshPort isNil.

	repository := MCGitlabRepository location: 'gitlab://pharo-project/pharo:master'.
	self
		assert: repository hostname equals: 'gitlab.com';
		assert: repository projectPath equals: 'pharo-project/pharo';
		assert: repository projectVersion equals: 'master';
		assertEmpty: repository repoPath;
		assert: repository sshPort isNil.

	repository := MCGitlabRepository location: 'gitlab://pharo-project/pharo'.
	self
		assert: repository hostname equals: 'gitlab.com';
		assert: repository projectPath equals: 'pharo-project/pharo';
		assert: repository projectVersion equals: 'master';
		assertEmpty: repository repoPath;
		assert: repository sshPort isNil! !

!MCHttpRepository commentStamp: ''!
I am general http repository for monticello.
I support the general protocol for listing files in a remote repository.!
!MCHttpRepository methodsFor: 'actions' stamp: ''!
flushCache
	super flushCache.
	readerCache := nil.! !

!MCHttpRepository methodsFor: 'i/o' stamp: ''!
loadAllFileNames
	| client |
	self displayProgress: 'Loading all file names from ', self description during: [
		client := self httpClient.
		client
			ifFail: [ :exception | 
				(exception className beginsWith: 'Zn')
					ifTrue: [ MCRepositoryError signal: 'Could not access ', self location, ': ', exception printString ]
					ifFalse: [ exception pass ] ];
			url: self locationWithTrailingSlash;
			queryAt: 'C' put: 'M;O=D';	"legacy that some servers maybe expect"
			get.
		self assertNonBinaryResponse: client response ].
	^ self parseFileNamesFromStream: client contents readStream! !

!MCHttpRepository methodsFor: 'accessing' stamp: ''!
location
	^ location! !

!MCHttpRepository methodsFor: 'accessing' stamp: ''!
location: aUrlString
	location := aUrlString! !

!MCHttpRepository methodsFor: 'actions' stamp: ''!
locationWithTrailingSlash
	^ (self location endsWith: '/')
		ifTrue: [self location]
		ifFalse: [self location, '/']! !

!MCHttpRepository methodsFor: 'accessing' stamp: ''!
description
	^ self location! !

!MCHttpRepository methodsFor: 'private' stamp: ''!
entityStreamContents: aBlock
	"Generate output in a buffer because we need the length"
	
	| stream |
	stream := ReadWriteStream on: ByteArray new.
	aBlock value: stream.
	stream reset.
	^ (ZnStreamingEntity type: ZnMimeType applicationOctetStream)
		stream: stream;
		contentLength: stream size;
		yourself! !

!MCHttpRepository methodsFor: 'printing' stamp: ''!
displayStringOn: aStream
	aStream nextPutAll: self location! !

!MCHttpRepository methodsFor: 'accessing' stamp: ''!
credentials: mcServerCredentials
	self user: mcServerCredentials username.
	self password: mcServerCredentials password.! !

!MCHttpRepository methodsFor: 'accessing' stamp: ''!
password: passwordString
	password := passwordString! !

!MCHttpRepository methodsFor: 'i/o' stamp: ''!
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: 'actions' stamp: ''!
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 := userAndPassword base64Decoded decodeWith: #null].
					userAndPassword := userAndPassword findTokens: $:.
					^aBlock value: userAndPassword first 
						value: userAndPassword second 
					]
			]
		]
	].
	^nil! !

!MCHttpRepository methodsFor: 'i/o' stamp: ''!
writeStreamForFileNamed: aString replace: ignoreBoolean do: aBlock
	| entity |
	entity := self entityStreamContents: aBlock.
	self displayProgress: 'Uploading ', aString during: [
		self httpClient
			entity: entity;
			ifFail: [ :exception | 
				(exception isKindOf: ZnHttpUnsuccessful) 
					ifTrue: [ ^ self handleUnsuccessfulResponse: exception response ].
				self error: 'Could not save ', aString, ': ', exception printString ];
			url: (self urlForFileNamed: aString);
			put ]! !

!MCHttpRepository methodsFor: 'accessing' stamp: ''!
user
	self userAndPasswordFromSettingsDo: [:usr :pwd | ^usr].
	"not in settings"
	user isEmptyOrNil ifFalse: [ ^user ].
	^ ''! !

!MCHttpRepository methodsFor: 'actions' stamp: ''!
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: '*Metacello-MC' stamp: ''!
asRepositorySpecFor: aMetacelloMCProject

	^(aMetacelloMCProject repositorySpec)
		description:  self description;
	 	type: 'http';
		yourself! !

!MCHttpRepository methodsFor: 'i/o' stamp: ''!
readStreamForFileNamed: aString do: aBlock
	| client |
	self displayProgress: 'Downloading ', aString during: [
		client := self httpClient.
		client
			ifFail: [ :exception | self error: 'Could not load ', aString, ': ', exception printString ];
			get: (self urlForFileNamed: aString).
		self assertBinaryResponse: client response.
		"immediately cache the version and avoid an unnecessary serialization"
		self cacheRawVersionNamed: aString stream: client contents ].
	^ aBlock value: client contents readStream! !

!MCHttpRepository methodsFor: 'converting' stamp: ''!
asCreationTemplate
	^self class creationTemplateLocation: self location user: user password: password! !

!MCHttpRepository methodsFor: 'actions' stamp: ''!
retryOnCredentialRequest: aBlock
	aBlock	on: MCPermissionDenied do: [ :error | |credentials| 
		credentials := MCCredentialsRequest 
							signalUrl: self location
							username: self user
							password: self password.
		credentials 
			ifNotNil: [ 
				self credentials: credentials.
				^ self retryOnCredentialRequest: aBlock ]]! !

!MCHttpRepository methodsFor: 'accessing' stamp: ''!
user: userString
	user := userString! !

!MCHttpRepository methodsFor: 'private' stamp: ''!
assertBinaryResponse: response 

	response contentType isBinary ifFalse: [ 
		MCRepositoryError signal: 'Expected a binary response instead of ', response contentType printString ].! !

!MCHttpRepository methodsFor: 'i/o' stamp: ''!
handleUnsuccessfulResponse: aZnResponse
	(#(403 401) includes: aZnResponse code)
		ifTrue: [ MCPermissionDenied signalFor: self ].
	Error signal: 'Could not save version.'! !

!MCHttpRepository methodsFor: 'storing' stamp: ''!
storeVersion: aVersion
	self retryOnCredentialRequest: [ super storeVersion: aVersion ]! !

!MCHttpRepository methodsFor: 'actions' stamp: ''!
urlForFileNamed: aString
	^ self locationWithTrailingSlash, aString urlEncoded! !

!MCHttpRepository methodsFor: 'accessing' stamp: ''!
credentials
	^ MCServerCredentials user: self user password: self password! !

!MCHttpRepository methodsFor: 'accessing' stamp: ''!
project
	"Return a project name"
	^ (self location splitOn: $/) last! !

!MCHttpRepository methodsFor: 'actions' stamp: ''!
password
	self userAndPasswordFromSettingsDo: [:usr :pwd | ^pwd].

	self user isEmpty ifTrue: [^password ifNil: ['']].

	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: 'i/o' stamp: ''!
cacheRawVersionNamed: aString stream: contents
	"directly forward the contents to the cache repository. 
	this avoids and unnecessary serialization step"
	MCCacheRepository uniqueInstance 
		writeStreamForFileNamed: aString 
		replace: true 
		do: [ :s| s nextPutAll: contents ]! !

!MCHttpRepository methodsFor: 'actions' stamp: ''!
versionReaderForFileNamed: aString do: aBlock
	^ (self versionReaderForFileNamed: aString) ifNotNil: aBlock! !

!MCHttpRepository methodsFor: 'private' stamp: ''!
assertNonBinaryResponse: response 
	
	response contentType isBinary ifTrue: [ MCRepositoryError signal: 'Did not expect a binary response but got ', response contentType printString ].! !

!MCHttpRepository methodsFor: 'actions' stamp: ''!
parseFileNamesFromStream: aStream
	| names fullName |
	names := OrderedCollection new.
	[aStream atEnd] whileFalse:
		[[aStream upTo: $<. {$a. $A. nil} includes: aStream next] whileFalse.
		aStream upTo: $".
		aStream atEnd ifFalse: [
			fullName := aStream upTo: $".
			names add: fullName urlDecoded ]].
	^ names! !

!MCHttpRepository methodsFor: 'private' stamp: ''!
httpClient
	"Return a new, specifically configured instance of the HTTP client for internal use.
	Note how we request GZIP compression and will signal progress."

	^ ZnClient new
		systemPolicy;
		beOneShot;
		username: self user password: self password;
	
		signalProgress: true;
		yourself! !

!MCHttpRepository class methodsFor: 'creation template' stamp: ''!
creationTemplateLocation: location user: user password: password
	^
self name, '
	location: {1}
	user: {2}
	password: {3}' format: {location printString. user printString. password printString}! !

!MCHttpRepository class methodsFor: 'instance creation' stamp: ''!
project: aProjectIdentifier
	^ self location: self baseURL, aProjectIdentifier! !

!MCHttpRepository class methodsFor: 'instance creation' stamp: ''!
pharoInboxRepository
	^ self location: 'http://smalltalkhub.com/mc/Pharo/Pharo60Inbox/main'.! !

!MCHttpRepository class methodsFor: 'instance creation' stamp: ''!
location: location
	^ MCServerRegistry uniqueInstance 
		repositoryAt: location credentialsDo: [ :username :password |
			(self repositoryClassFor: location) new
				location: location;
				user: username;
				password: password;
				yourself ]! !

!MCHttpRepository class methodsFor: 'instance creation' stamp: ''!
location: aUrl user: user password: password

	| result |
	result := self location: aUrl.
	user ifNotEmpty: [
		result
			user: user;
			password: password ].
	^ result.! !

!MCHttpRepository class methodsFor: '*MonticelloGUI' stamp: ''!
fillInTheBlankRequest
	^ 'HTTP Repository:'
			! !

!MCHttpRepository class methodsFor: '*Metacello-MC' stamp: ''!
createRepositoryFromSpec: aRepositorySpec on: aPlatform
	^ aPlatform createHttpRepository: aRepositorySpec! !

!MCHttpRepository class methodsFor: 'accessing' stamp: ''!
description
	^ 'HTTP'! !

!MCHttpRepository class methodsFor: 'accessing' stamp: ''!
baseURL
	^ ''! !

!MCHttpRepository class methodsFor: 'initialization' stamp: ''!
clearPasswords
	self allSubInstancesDo: [:ea | ea password: ''].
! !

!MCHttpRepository class methodsFor: 'instance creation' stamp: ''!
pharoRepository
	^ self location: 'http://smalltalkhub.com/mc/Pharo/Pharo60/main'.! !

!MCHttpRepository class methodsFor: 'instance creation' stamp: ''!
repositoryClassFor: location
	MCHttpRepository subclassesDo: [ :subclass | 
		(subclass isResponsibleFor: location)
			ifTrue: [ ^ subclass ]].
	^ MCHttpRepository! !

!MCHttpRepository class methodsFor: 'testing' stamp: ''!
isResponsibleFor: aURLString
	"Override in subclasses to enable custom instances for certain URLs"
	^ true! !

!MCHttpRepository class methodsFor: 'accessing' stamp: ''!
urlSchemes
	^ #(http https)! !

!MCHttpRepository class methodsFor: 'creation template' stamp: ''!
creationTemplate
	^self creationTemplateLocation: self baseURL
		user: ''
		password: ''
! !

!MCHttpRepository class methodsFor: '*Metacello-MC' stamp: ''!
isAvailableFor: type
	^ self = MCHttpRepository and: [ type = 'http' ]! !

!MCHttpRepository class methodsFor: 'instance creation' stamp: ''!
basicFromUrl: aZnUrl
	^ aZnUrl hasUsername
		ifFalse: [ self location: aZnUrl location ]
		ifTrue: [ (self repositoryClassFor: aZnUrl location) new
				location: aZnUrl location;
				user: aZnUrl username;
				password: aZnUrl password;
				yourself  ]! !

!MCHttpRepository class methodsFor: '*MonticelloGUI' stamp: ''!
morphicConfigure
	^ self fillInTheBlankConfigure! !

!MCInstanceVariableDefinition commentStamp: ''!
A MCInstanceVariableDefinition represents an instance variable definition.!
!MCInstanceVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isInstanceVariable
	^ true! !

!MCInstanceVariableDefinition class methodsFor: 'accessing' stamp: 'nil'!
type
	^ #instance! !

!MCLazyVersionInfo commentStamp: ''!
A MCLazyVersionInfo puts ancestor and stepChilds data in WeakArrays to allow their memory to be reclaimed and reloaded on demand.

For all purposes, a MCLazyVersionInfo behaves exactly like a MCVersionInfo with the same data, but:
- let the ancestry (and step children) be garbage collected
- and reload that ancestry (and stepChildren) from the MC repositories when accessed (MCLazyVersionInfo>>loadAncestorsAndStepChildren for the reload, MCLazyVersionInfo>>ancestors and MCLazyVersionInfo>>stepChildren for the access).

MCLazyVersionInfo is installed just as the ancestor in a MCWorkingAncestry (the direct ancestry of a WorkingCopy, which is the state all packages take when they are loaded in an image). It allows a MCWorkingAncestry to still know which package it is coming from, and, of course, the MCLazyVersionInfo to be able to reload the relevant ancestry from the right package.

Once installed, by flushing the Monticello package cache, all the stored ancestry is garbage collected, except the roots of those ancestry trees, which are the MCLazyVersionInfo instances inside the MCWorkingAncestry instances.

Warnings:

- Algorithms which traverse the entire ancestry chain of all packages will force a reload of all the packages contained in the image, which is a time and memory and network consuming process...

- It degrades gracefully when reloading becomes impossible (returns an empty ancestry, keeps knowledge of the fact some ancestry is missing, reloading a full ancestry on when possible). This has been tested.


!
!MCLazyVersionInfo methodsFor: 'private' stamp: 'nil'!
setAncestors: someAncestors
	"Unused in MCVersionInfo"

	"It is there to allow a certain customisation with lazy stuff without kernel dependencies on LRUCache"

	ancestors := WeakArray withAll: someAncestors! !

!MCLazyVersionInfo methodsFor: 'initialization' stamp: 'nil'!
lazy
	^ self! !

!MCLazyVersionInfo methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	ancestors := WeakArray new.
	stepChildren := WeakArray new! !

!MCLazyVersionInfo methodsFor: 'private' stamp: 'nil'!
setStepChildren: someStepChildren
	"Unused in MCVersionInfo"

	"It is there to allow a certain customisation with lazy stuff without kernel dependencies on LRUCache"

	stepChildren := WeakArray withAll: someStepChildren! !

!MCLazyVersionInfo methodsFor: '*MonticelloGUI' stamp: ''!
loadAncestorsAndStepChildren
	"This code scans all the repositories to find the exact package version and reload the relevant info."

	"Transient failures, such as the lack of network connectivity, will return nothing and no errors from this code."

	"Cache loaded version info, but try not to add a nil at that space? Can't do that with LRUCache>>#at:ifAbsentPut:"

	((MCTool mcVersionCache includesKey: id)
		ifTrue: [ MCTool mcVersionCache at: id ]
		ifFalse:
			[ (MCRepositoryGroup default
				in: [ :r | r versionWithInfo: self ifNone: [  ] ])
				ifNil: [  ]
				ifNotNil:
					[ :aVersion | 
					MCTool mcVersionCache at: id put: aVersion.
					aVersion ] ])
		ifNotNil:
			[ :aVersion | 
			ancestors := WeakArray withAll: aVersion info ancestors.
			stepChildren := WeakArray withAll: aVersion info stepChildren ]! !

!MCLazyVersionInfo methodsFor: 'comparing' stamp: 'nil'!
species
	"Make this class equivalent to a MCVersionInfo in all regards."

	^ self class superclass! !

!MCLazyVersionInfo methodsFor: 'accessing' stamp: 'nil'!
stepChildren
	"Ensure we load step children as appropriate if necessary."

	(stepChildren anySatisfy: #isNil)
		ifTrue: [ self loadAncestorsAndStepChildren ].
	(stepChildren anySatisfy: #isNil)
		ifTrue: [ ^ #() ].
	^ stepChildren! !

!MCLazyVersionInfo methodsFor: 'initialization' stamp: 'nil'!
initializeWithName: vName id: aUUID message: aString date: aDate time: aTime author: initials ancestors: aCollection stepChildren: stepCollection
	name := vName.
	id := aUUID.
	message := aString.
	date := aDate ifNil: [ Date today ].
	time := aTime.
	author := initials.
	ancestors := WeakArray withAll: aCollection.
	stepChildren := WeakArray withAll: stepCollection! !

!MCLazyVersionInfo methodsFor: 'accessing' stamp: 'nil'!
ancestors
	"Ensure we load ancestors as appropriate if necessary. Failure to load force us to return an empty set to avoid errors, but we'll keep track of the fact that this failure may be transient and that we can continue."

	(ancestors anySatisfy: #isNil)
		ifTrue: [ self loadAncestorsAndStepChildren ].
	(ancestors anySatisfy: #isNil)
		ifTrue: [ ^ #() ].
	^ ancestors! !

!MCLazyVersionInfo class methodsFor: 'class initialization' stamp: 'nil'!
initialize
	self install! !

!MCLazyVersionInfo class methodsFor: 'instance creation' stamp: 'nil'!
from: aVersionInfo
	^ self new
		initializeWithName: aVersionInfo name
		id: aVersionInfo id
		message: aVersionInfo message
		date: aVersionInfo date
		time: aVersionInfo time
		author: aVersionInfo author
		ancestors: aVersionInfo ancestors
		stepChildren: aVersionInfo stepChildren! !

!MCLazyVersionInfo class methodsFor: 'class initialization' stamp: 'nil'!
install
	"Install the lazy mc versions on..."

	"self install"

	MCWorkingAncestry
		allInstancesDo: [ :each | each ancestors: (each ancestors collect: [ :e | MCLazyVersionInfo from: e ]) ].
	MCFileBasedRepository flushAllCaches.
	Smalltalk garbageCollect! !

!MCMcdReader commentStamp: ''!
Reader for an MCD format!
!MCMcdReader methodsFor: 'loading' stamp: 'nil'!
loadPatch
	| old new |
	(self zip memberNamed: 'patch.bin') ifNotNil:
		[:m | [^ patch := (MCDataStream on: m contentStream) next ]
			on: Error do: [:fallThrough |]].
	definitions := OrderedCollection new.
	(self zip membersMatching: 'old/*')
		do: [:m | self extractDefinitionsFrom: m].
	old := definitions asArray.
	definitions := OrderedCollection new.
	(self zip membersMatching: 'new/*')
		do: [:m | self extractDefinitionsFrom: m].
	new := definitions asArray.
	^ patch := self buildPatchFrom: old to: new.
	! !

!MCMcdReader methodsFor: 'accessing' stamp: 'nil'!
baseInfo
	^ baseInfo ifNil: [self loadBaseInfo]! !

!MCMcdReader methodsFor: 'loading' stamp: 'nil'!
loadBaseInfo
	^ baseInfo := self extractInfoFrom: (self parseMember: 'base')! !

!MCMcdReader methodsFor: 'accessing' stamp: 'nil'!
patch
	^ patch ifNil: [self loadPatch]! !

!MCMcdReader methodsFor: 'accessing' stamp: 'nil'!
basicVersion
	^ MCDiffyVersion
		package: self package
		info: self info
		dependencies: self dependencies
		baseInfo: self baseInfo
		patch: self patch! !

!MCMcdReader methodsFor: 'loading' stamp: 'nil'!
buildPatchFrom: oldDefinitions to: newDefinitions
	^ MCPatch
		fromBase: (MCSnapshot fromDefinitions: oldDefinitions)
		target: (MCSnapshot fromDefinitions: newDefinitions)! !

!MCMcdReader class methodsFor: 'accessing' stamp: 'nil'!
extension
	^ 'mcd'! !

!MCMcdWriter commentStamp: ''!
Writing MCD format!
!MCMcdWriter methodsFor: 'writing' stamp: 'nil'!
writePatch: aPatch
	| old new |
	old := OrderedCollection new.
	new := OrderedCollection new.
	aPatch operations do:
		[:ea |
		ea isRemoval ifTrue: [old add: ea definition].
		ea isAddition ifTrue: [new add: ea definition].
		ea isModification ifTrue: [old add: ea baseDefinition. new add: ea definition]].
	self writeOldDefinitions: old.
	self writeNewDefinitions: new.
	self addString: (self serializeInBinary: aPatch) at: 'patch.bin'.! !

!MCMcdWriter methodsFor: 'writing' stamp: 'nil'!
writeNewDefinitions: aCollection
	self addString: (self serializeDefinitions: aCollection) at: 'new/source.', self snapshotWriterClass extension encodedTo: 'utf8'.! !

!MCMcdWriter methodsFor: 'visiting' stamp: 'nil'!
writeDefinitions: aVersion
	self writeBaseInfo: aVersion baseInfo.
	self writePatch: aVersion patch.! !

!MCMcdWriter methodsFor: 'writing' stamp: 'nil'!
writeOldDefinitions: aCollection
	self addString: (self serializeDefinitions: aCollection) at: 'old/source.', self snapshotWriterClass extension encodedTo: 'utf8'.! !

!MCMcdWriter methodsFor: 'writing' stamp: 'nil'!
writeBaseInfo: aVersionInfo
	| string |
	string := self serializeVersionInfo: aVersionInfo.
	self addString: string at: 'base' encodedTo: 'utf8'.
! !

!MCMcdWriter class methodsFor: 'accessing' stamp: 'nil'!
readerClass
	^ MCMcdReader! !

!MCMcmReader commentStamp: ''!
Reader for Metacello MCM!
!MCMcmReader methodsFor: 'accessing' stamp: ''!
configuration
	configuration ifNil: [self loadConfiguration].
	"browser modifies configuration, but the reader might get cached"
	^configuration copy! !

!MCMcmReader methodsFor: 'accessing' stamp: ''!
fileName: aString
	fileName := aString! !

!MCMcmReader methodsFor: 'accessing' stamp: ''!
version
	^self configuration! !

!MCMcmReader methodsFor: 'accessing' stamp: ''!
loadConfiguration
	stream reset.
	configuration := MCConfiguration fromArray: (MCScanner scan: stream).
	configuration name: self configurationName.
! !

!MCMcmReader methodsFor: 'accessing' stamp: ''!
loadVersionInfo
	info := self configuration! !

!MCMcmReader methodsFor: 'accessing' stamp: ''!
configurationName
	^fileName ifNotNil: [(fileName findTokens: '/\:') last copyUpToLast: $.]! !

!MCMcmReader class methodsFor: 'accessing' stamp: ''!
extension
	^ 'mcm'! !

!MCMcmReader class methodsFor: 'instance creation' stamp: ''!
on: aStream fileName: aFileName
	| reader |
	reader := self on: aStream.
	reader fileName: aFileName.
	^reader! !

!MCMcmWriter commentStamp: ''!
Writer for Metacello MCM!
!MCMcmWriter methodsFor: 'writing' stamp: ''!
close
	stream close! !

!MCMcmWriter methodsFor: 'writing' stamp: ''!
writeConfiguration: aConfiguration

	stream nextPut: $(.

	aConfiguration repositories do: [:ea | 
		stream cr.
		stream nextPutAll: 'repository '.
		(MCConfiguration repositoryToArray: ea) printElementsOn: stream].

	aConfiguration dependencies do: [:ea | 
		stream cr.
		stream nextPutAll: 'dependency '.
		(MCConfiguration dependencyToArray: ea) printElementsOn: stream].

	stream cr.
	stream nextPut: $).
	stream cr.! !

!MCMcmWriter class methodsFor: 'accessing' stamp: ''!
readerClass
	^ MCMcmReader! !

!MCMcmWriter class methodsFor: 'writing' stamp: ''!
fileOut: aConfiguration on: aStream
	| inst |
	inst := self on: aStream.
	inst writeConfiguration: aConfiguration.
	inst close.
	
! !

!MCMczInstallerTest methodsFor: 'accessing' stamp: ''!
fileStream
	^ self fileName asFileReference
		ensureDelete;
		binaryWriteStream.! !

!MCMczInstallerTest methodsFor: 'running' stamp: ''!
tearDown
	expected snapshot updatePackage: self mockPackage.
	self deleteFile.
	super tearDown! !

!MCMczInstallerTest methodsFor: 'assertions' stamp: ''!
assertNoChange
	| actual |
	actual := MCSnapshotResource takeSnapshot.
	diff := actual patchRelativeToBase: expected snapshot.
	self assertEmpty: diff! !

!MCMczInstallerTest methodsFor: 'assertions' stamp: ''!
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 equals: d ] ] ].
	info ancestors with: (dict at: #ancestors) do: [ :i :d | self assertDict: d matchesInfo: i ]! !

!MCMczInstallerTest methodsFor: 'tests' stamp: ''!
testInstallFromStream

	| array |
	array := ByteArray streamContents: [:stream |.
		MCMczWriter fileOut: expected on: stream.
	].
	MczInstaller installStream: array readStream.
	self assertNoChange.
	self assertVersionInfoPresent.
	! !

!MCMczInstallerTest methodsFor: 'accessing' stamp: ''!
fileName
	^ 'InstallerTest.mcz'! !

!MCMczInstallerTest methodsFor: 'utilities' stamp: ''!
deleteFile
	self fileName asFileReference ensureDelete! !

!MCMczInstallerTest methodsFor: 'assertions' stamp: ''!
assertVersionInfoPresent
	| dict info |
	dict := MczInstaller versionInfo at: self mockPackage name.
	info := expected info.
	self assertDict: dict matchesInfo: info.! !

!MCMczInstallerTest methodsFor: 'tests' stamp: ''!
testInstallFromFile
	| stream |
	stream := self fileStream.
	MCMczWriter fileOut: expected on: stream.
	stream close.
	
	MczInstaller installFileNamed: self fileName.
	self assertNoChange.! !

!MCMczInstallerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	expected := self mockVersion.
	self change: #one toReturn: 2.! !

!MCMczInstallerTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ (Smalltalk hasClassNamed: #MczInstaller) not
		! !

!MCMczInstallerTest class methodsFor: 'accessing' stamp: ''!
suite
	^ (Smalltalk hasClassNamed: #MczInstaller)
		ifTrue: [ super suite ]
		ifFalse: [ self classForTestSuite new name: self name asString ]! !

!MCMczReader commentStamp: ''!
Reader for an MCZ format!
!MCMczReader methodsFor: 'parsing' stamp: 'nil'!
extractDependencyFrom: zipMember
	^ MCVersionDependency
		package: (MCPackage named: (zipMember fileName copyAfterLast: $/))
		info: (self extractInfoFrom: (self parseMember: zipMember))! !

!MCMczReader methodsFor: 'private' stamp: 'nil'!
contentStreamForMember: member
	^[(member contentStreamFromEncoding: 'utf8') text] on: ZnInvalidUTF8
		do: [:exc | 
			"Case of legacy encoding, presumably it is latin-1 and we do not need to do anything
			But if contents starts with a null character, it might be a case of WideString encoded in UTF-32BE"
			| str |
			str := (member contentStreamFromEncoding: 'latin1') text.
			(str peek = Character null and: [ str size \\ 4 = 0 ])
				ifTrue: [str := (WideString fromByteArray: str contents asByteArray) readStream].
			exc return: str]! !

!MCMczReader methodsFor: 'accessing' stamp: 'nil'!
filename
	^ filename! !

!MCMczReader methodsFor: 'converting' stamp: 'nil'!
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: 'loading' stamp: 'nil'!
loadPackage
	| dict |
	dict := self parseMember: 'package'.
	package := MCPackage named: (dict at: #name)! !

!MCMczReader methodsFor: 'parsing' stamp: 'nil'!
contentsForMember: member
	^[(member contentStreamFromEncoding: 'utf8') contents] on: ZnInvalidUTF8
		do: [:exc | 
			"Case of legacy encoding, presumably it is latin-1.
			But if contents starts with a null character, it might be a case of WideString encoded in UTF-32BE"
			| str |
			str := (member contentStreamFromEncoding: 'latin1').
			exc return: ((str peek = Character null and: [ str size \\ 4 = 0 ])
				ifTrue: [WideString fromByteArray: str contents asByteArray]
				ifFalse: [str contents])]! !

!MCMczReader methodsFor: 'loading' stamp: 'nil'!
loadDependencies
	dependencies := (self zip membersMatching: 'dependencies/*') collect: [:m | self extractDependencyFrom: m].
	dependencies := dependencies asArray.
! !

!MCMczReader methodsFor: 'parsing' stamp: 'nil'!
extractDefinitionsFrom: member
	| reader |
	(MCSnapshotReader readerClassForFileNamed: member fileName)
		ifNotNil: [:rc |
			reader := rc on: (self contentsForMember: member) readStream.
			definitions addAll: reader definitions]
! !

!MCMczReader methodsFor: 'utilities' stamp: 'nil'!
extractInfoFrom: dict
	^MCWorkingCopy infoFromDictionary: dict cache: self infoCache! !

!MCMczReader methodsFor: 'accessing' stamp: 'nil'!
scanner
	^ MCScanner! !

!MCMczReader methodsFor: 'accessing' stamp: 'nil'!
zip
	stream closed ifTrue: [
		zip := nil].
	zip ifNil: [
		zip := ZipArchive new.
		zip readFrom: (stream closed
        ifTrue: [	filename asFileReference binaryReadStream ]
        ifFalse: [ stream ])
	].
	^ zip! !

!MCMczReader methodsFor: 'accessing' stamp: 'nil'!
filename: aString
	filename := aString! !

!MCMczReader methodsFor: 'accessing' stamp: 'nil'!
infoCache
	^ infoCache ifNil: [infoCache := Dictionary new]! !

!MCMczReader methodsFor: 'loading' stamp: 'nil'!
loadDefinitions
	definitions := OrderedCollection new.
	(self zip memberNamed: 'snapshot.bin') ifNotNil:
		[:m | [^ definitions := (MCDataStream on: m contents readStream) next definitions ]
			on: Error do: [:fallThrough |]].
	"otherwise"
	(self zip membersMatching: 'snapshot/*')
		do: [:m | self extractDefinitionsFrom: m].
! !

!MCMczReader methodsFor: 'loading' stamp: 'nil'!
loadVersionInfo

	info := self extractInfoFrom: (self parseMember: 'version')! !

!MCMczReader methodsFor: 'parsing' stamp: 'nil'!
parseMember: memberOrName
	| member tokens |
	member := self zip member: memberOrName.
	tokens := (self contentsForMember: member) parseLiterals first.
	^ self associate: tokens! !

!MCMczReader class methodsFor: 'accessing' stamp: 'nil'!
extension
	^ 'mcz'! !

!MCMczReader class methodsFor: 'accessing' stamp: 'nil'!
on: s fileName: f
	^ (self on: s)
		filename: f;
		yourself! !

!MCMczReader class methodsFor: 'testing' stamp: 'nil'!
supportsVersions
	^ true! !

!MCMczReader class methodsFor: 'testing' stamp: 'nil'!
supportsDependencies
	^ true! !

!MCMczWriter commentStamp: ''!
Writing MCZ format!
!MCMczWriter methodsFor: 'serializing' stamp: 'nil'!
serializePackage: aPackage
	^ '(name ''', aPackage name, ''')'! !

!MCMczWriter methodsFor: 'accessing' stamp: 'nil'!
snapshotWriterClass
	^ MCStWriter! !

!MCMczWriter methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	zip := ZipArchive new.
! !

!MCMczWriter methodsFor: 'accessing' stamp: 'nil'!
format
	^ '1'! !

!MCMczWriter methodsFor: 'serializing' stamp: 'nil'!
serializeDefinitions: aCollection
	^String streamContents: [:aStream |
		| writer |
		writer := self snapshotWriterClass on: aStream.
		writer writeDefinitions: aCollection]! !

!MCMczWriter methodsFor: 'serializing' stamp: 'nil'!
serializeVersionInfo: aVersionInfo
	infoWriter ifNil: [infoWriter := MCVersionInfoWriter new].
	^ String streamContents: [:s |
		infoWriter stream: s.
		infoWriter writeVersionInfo: aVersionInfo]! !

!MCMczWriter methodsFor: 'visiting' stamp: 'nil'!
writeDefinitions: aVersion
	self writeSnapshot: aVersion snapshot! !

!MCMczWriter methodsFor: 'serializing' stamp: 'nil'!
serializeInBinary: aSnapshot
	
	^ ByteArray streamContents: [ :str | | writer |
		writer := MCDataStream on: str.
		writer nextPut: aSnapshot ]! !

!MCMczWriter methodsFor: 'visiting' stamp: 'nil'!
writePackage: aPackage
	self addString: (self serializePackage: aPackage) at: 'package' encodedTo: 'utf8'! !

!MCMczWriter methodsFor: 'visiting' stamp: 'nil'!
writeVersion: aVersion
	self writeFormat.
	self writePackage: aVersion package.
	self writeVersionInfo: aVersion info.
	self writeDefinitions: aVersion.
	aVersion dependencies do: [:ea | self writeVersionDependency: ea]! !

!MCMczWriter methodsFor: 'visiting' stamp: 'nil'!
writeVersionInfo: aVersionInfo
	| string |
	string := self serializeVersionInfo: aVersionInfo.
	self addString: string at: 'version' encodedTo: 'utf8'.
! !

!MCMczWriter methodsFor: 'visiting' stamp: 'nil'!
writeFormat
"	self addString: self format at: 'format'."! !

!MCMczWriter methodsFor: 'writing' stamp: 'nil'!
flush
	zip writeTo: stream.! !

!MCMczWriter methodsFor: 'accessing' stamp: 'nil'!
zip
	^ zip! !

!MCMczWriter methodsFor: 'writing' stamp: 'nil'!
addString: string at: path
	| member |
	member := zip addString: string as: path.
	member desiredCompressionMethod: ZipArchive compressionDeflated 
	! !

!MCMczWriter methodsFor: 'writing' stamp: 'nil'!
addString: string at: path encodedTo: encodingName
	| member |
	member := zip addString: (string encodeWith: encodingName) as: path.
	member desiredCompressionMethod: ZipArchive compressionDeflated 
	! !

!MCMczWriter methodsFor: 'visiting' stamp: 'nil'!
writeSnapshot: aSnapshot
	self addString: (self serializeDefinitions: aSnapshot definitions) at: 'snapshot/source.', self snapshotWriterClass extension encodedTo: 'utf8'.
	self addString: (self serializeInBinary: aSnapshot) at: 'snapshot.bin'! !

!MCMczWriter methodsFor: 'visiting' stamp: 'nil'!
writeVersionDependency: aVersionDependency
	| string |
	string := (self serializeVersionInfo: aVersionDependency versionInfo).
	self addString: string at: 'dependencies/', aVersionDependency package name encodedTo: 'utf8'! !

!MCMczWriter class methodsFor: 'accessing' stamp: 'nil'!
readerClass
	^ MCMczReader! !

!MCMczWriter class methodsFor: 'writing' stamp: 'nil'!
fileOut: aVersion on: aStream
	| inst |
	inst := self on: aStream.
	inst writeVersion: aVersion.
	inst flush.
	
! !

!MCMergeBrowser commentStamp: ''!
Browser to merge changes!
!MCMergeBrowser methodsFor: 'actions' stamp: ''!
cancel
	self answer: false! !

!MCMergeBrowser methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^ 'Merge Browser'! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
selectionIsConflicted
	selection ifNil: [ ^ false ].
	^ selection isConflict! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
innerButtonRow
	^ self buttonRow:
		#((Keep chooseRemote 'keep the selected change' selectionIsConflicted)
		  (Reject chooseLocal 'reject the selected change' selectionIsConflicted))! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
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: 'actions' stamp: ''!
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: 'actions' stamp: ''!
chooseLocal
	"Notify the potential new state of canMerge."
	
	self conflictSelectionDo:
		[selection chooseLocal.
		self changed: #text; changed: #list; changed: #canMerge]! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
conflictSelectionDo: aBlock
	self selectionIsConflicted
		ifTrue: aBlock
		ifFalse: [self inform: 'You must have a conflict selected']! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
chooseAllNewerConflicts
	"Notify the potential new state of canMerge."
	
	conflicts do: [ :ea | ea chooseNewer ].
	self changed: #text; changed: #list; changed: #canMerge! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
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: ''!
getOperationMenu: aMenu
	^ aMenu! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
merger: aMerger
	merger := aMerger.
	items := aMerger operations asSortedCollection.
	conflicts := aMerger conflicts sort: [:a :b | a operation <= b operation].! !

!MCMergeBrowser methodsFor: 'morphic ui' stamp: ''!
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: 'actions' stamp: ''!
chooseAllOlderConflicts
	"Notify the potential new state of canMerge."
	
	conflicts do: [ :ea | ea chooseOlder ].
	self changed: #text; changed: #list; changed: #canMerge! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
chooseRemote
	"Notify the potential new state of canMerge."
	
	self conflictSelectionDo:
		[selection chooseRemote.
		self changed: #text; changed: #list; changed: #canMerge]! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
merge
	merger isMerged
		ifFalse: [self inform: 'You must resolve all the conflicts first']
		ifTrue: [self answer: true] ! !

!MCMergeBrowser methodsFor: 'morphic ui' stamp: ''!
widgetSpecs
	"ToolBuilder doesn't know about innerButtonRow. Made explicit here."

	^#(
		((buttonRow) (0 0 1 0) (0 0 0 30))
		((listMorph:selection:menu: list selection methodListMenu:) (0 0 1 0.4) (0 30 0 0))
		((buttonRow: #((Keep chooseRemote 'keep the selected change' selectionIsConflicted)
		  (Reject chooseLocal 'reject the selected change' selectionIsConflicted))) (0 0.4 1 0.4) (0 0 0 32))
		((textMorph: text) (0 0.4 1 1) (0 32 0 0))
		)
! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
canMerge
	^ merger isMerged! !

!MCMergeBrowser methodsFor: 'morphic ui' stamp: ''!
getMenu: aMenu
	selection ifNil: [^ aMenu].
	^ self selectionIsConflicted
		ifTrue: [self getConflictMenu: aMenu]
		ifFalse: [self getOperationMenu: aMenu]! !

!MCMergeBrowser methodsFor: 'accessing' stamp: ''!
items
	^ conflicts, items! !

!MCMergeBrowser methodsFor: 'morphic ui' stamp: ''!
selection: aNumber
	"Notify change of conflicts too."
	
	super selection: aNumber.
	self changed: #selectionIsConflicted! !

!MCMergeBrowser methodsFor: 'actions' stamp: ''!
clearChoice
	self conflictSelectionDo:
		[selection clearChoice.
		self changed: #text; changed: #list]! !

!MCMergeBrowser class methodsFor: 'instance creation' stamp: ''!
resolveConflictsInMerger: aMerger
	| inst |
	inst := self new merger: aMerger.
	^ inst showModally ifNil: [false]! !

!MCMergeOrLoadWarning commentStamp: ''!
A MCMergeOrLoadWarning is a simple warning used when amerge or a load action may override existing entities.!
!MCMergeOrLoadWarning methodsFor: 'actions' stamp: 'nil'!
cancel
	^ self resume: nil! !

!MCMergeOrLoadWarning methodsFor: 'actions' stamp: 'nil'!
load
	^ self resume: true! !

!MCMergeOrLoadWarning methodsFor: 'exceptionDescription' stamp: 'nil'!
defaultAction
	^ ( UIManager default
		confirm: self messageText
		trueChoice: 'Load'
		falseChoice: 'Merge'
		cancelChoice: 'Cancel'
		default: nil ).! !

!MCMergeOrLoadWarning methodsFor: 'accessing' stamp: 'nil'!
versions: aCollection
	versions := aCollection! !

!MCMergeOrLoadWarning methodsFor: 'actions' stamp: 'nil'!
merge
	^ self resume: false! !

!MCMergeOrLoadWarning methodsFor: 'accessing' stamp: 'nil'!
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 class methodsFor: 'signalling' stamp: 'nil'!
signalFor: aVersionCollection
	^ self new
		versions: aVersionCollection;
		signal! !

!MCMergeRecord commentStamp: ''!
A record for merging!
!MCMergeRecord methodsFor: 'initialization' stamp: 'nil'!
initializeWithVersion: aVersion
	version := aVersion! !

!MCMergeRecord methodsFor: 'actions' stamp: 'nil'!
updateWorkingCopy
	self isAncestorMerge ifFalse:
		[self imageIsClean
			ifTrue: [version workingCopy loaded: version]
			ifFalse: [version workingCopy merged: version]]! !

!MCMergeRecord methodsFor: 'accessing' stamp: 'nil'!
mergePatch
	^ mergePatch ifNil: [mergePatch := version snapshot patchRelativeToBase: self ancestorSnapshot]! !

!MCMergeRecord methodsFor: 'testing' stamp: 'nil'!
imageIsClean
	| ancestors |
	ancestors := version workingCopy ancestors.
	^ ancestors size = 1
		and: [(ancestors first = self ancestorInfo)
				and: [self imagePatch isEmpty]]! !

!MCMergeRecord methodsFor: 'accessing' stamp: 'nil'!
packageSnapshot
	^ packageSnapshot ifNil: [packageSnapshot := version package snapshot]! !

!MCMergeRecord methodsFor: 'accessing' stamp: 'nil'!
imagePatch
	^ imagePatch ifNil: [imagePatch := self packageSnapshot patchRelativeToBase: self ancestorSnapshot]! !

!MCMergeRecord methodsFor: 'accessing' stamp: 'nil'!
version
	^ version! !

!MCMergeRecord methodsFor: 'testing' stamp: 'nil'!
isAncestorMerge
	^ version workingCopy ancestry hasAncestor: version info! !

!MCMergeRecord methodsFor: 'accessing' stamp: 'nil'!
ancestorInfo
	^ ancestorInfo ifNil: [ancestorInfo := version info commonAncestorWith: version workingCopy ancestry]! !

!MCMergeRecord methodsFor: 'accessing' stamp: 'nil'!
ancestorSnapshot
	^ ancestorSnapshot ifNil: [ancestorSnapshot := version workingCopy findSnapshotWithVersionInfo: self ancestorInfo]! !

!MCMergeRecord class methodsFor: 'instance creation' stamp: 'nil'!
version: aVersion
	^ self basicNew initializeWithVersion: aVersion! !

!MCMergeResolutionRequest commentStamp: ''!
Notify to resolve conflicts by merging!
!MCMergeResolutionRequest methodsFor: '*Tool-Diff' stamp: ''!
defaultAction
	"Modally open a merge tool."
	
	^self viewMerger! !

!MCMergeResolutionRequest methodsFor: 'actions' stamp: 'nil'!
resolve
	self pass! !

!MCMergeResolutionRequest methodsFor: 'accessing' stamp: 'nil'!
merger: aMerger
	merger := aMerger! !

!MCMergeResolutionRequest methodsFor: '*Tool-Diff' stamp: ''!
viewPatchMerger
	"Open a modal diff tools browser to perform the merge."

	^ UIManager default merge: self merger informing: messageText.! !

!MCMergeResolutionRequest methodsFor: 'actions' stamp: 'nil'!
merge
	self resume: true! !

!MCMergeResolutionRequest methodsFor: '*Tool-Diff' stamp: ''!
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: 'testing' stamp: 'nil'!
hasConflicts
	^ self merger hasConflicts! !

!MCMergeResolutionRequest methodsFor: 'actions' stamp: 'nil'!
autoMerge
	"If there are not conflicts, merge, otherwise delegate to the UI"
	self hasConflicts
		ifTrue: [ self resolve ]
		ifFalse: [ self merge ]! !

!MCMergeResolutionRequest methodsFor: 'accessing' stamp: 'nil'!
merger
	^ merger! !

!MCMerger commentStamp: ''!
A MCMerger is an abstract responsible for performing merge operations and detecting conflicts.!
!MCMerger methodsFor: 'operations' stamp: 'nil'!
load
	| loader |
	loader := MCPackageLoader new.
	loader provisions addAll: self provisions.
	self applyTo: loader.
	loader load! !

!MCMerger methodsFor: 'accessing' stamp: 'nil'!
provisions
	^ #()! !

!MCMerger methodsFor: 'accessing' stamp: 'nil'!
operations
	^ #()! !

!MCMerger methodsFor: 'testing' stamp: 'nil'!
isMerged
	^ self conflicts allSatisfy: [:ea | ea isResolved]! !

!MCMerger methodsFor: 'accessing' stamp: 'nil'!
mergedSnapshot
	^ MCPatcher apply: self to: self baseSnapshot! !

!MCMerger methodsFor: 'testing' stamp: 'nil'!
hasConflicts
	^ self conflicts notEmpty! !

!MCMerger methodsFor: 'operations' stamp: 'nil'!
loadWithNameLike: baseName
	| loader |
	loader := MCPackageLoader new.
	loader provisions addAll: self provisions.
	self applyTo: loader.
	loader loadWithNameLike: baseName! !

!MCMerger methodsFor: 'operations' stamp: 'nil'!
applyTo: anObject
	self isMerged ifFalse: [self error: 'You must resolve all the conflicts first'].
	self operations do: [:ea | ea applyTo: anObject]! !

!MCMerger methodsFor: 'accessing' stamp: 'nil'!
conflicts	
	^ self operations select: #isConflict
! !

!MCMerger methodsFor: 'operations' stamp: 'nil'!
addConflictWithOperation: anOperation
	self operations add: anOperation beConflict! !

!MCMergingTest methodsFor: 'tests' stamp: ''!
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: ''!
testIdenticalModification
	self
		assertMerge: #(a2 b1)
				with: #(a2 b1)
				base: #(a1 b1)
				
				gives: #(a2 b1)
				conflicts: #()! !

!MCMergingTest methodsFor: 'tests' stamp: ''!
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: ''!
testSimultaneousRemove
	self assertMerge: #(a1)
				with: #(a1)
				base: #(a1 b1)
				
				gives: #(a1)
				conflicts: #()! !

!MCMergingTest methodsFor: 'asserting' stamp: ''!
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 equals: conflictResult asSet! !

!MCMergingTest methodsFor: 'tests' stamp: ''!
testSimultaneousModification
	self assertMerge: #(a2)
				with: #(a3)
				base: #(a1)
				
				gives: #(a3)
				conflicts: #((a3 a2)).! !

!MCMergingTest methodsFor: 'emulating' stamp: ''!
snapshotWithElements: anArray

	^ MCSnapshot
		fromDefinitions: (anArray collect: [:t | self mockToken: t])! !

!MCMergingTest methodsFor: 'tests' stamp: ''!
testSubtractiveConflictlessMerge
	self assertMerge: #(a1 b1)
				with: #()
				base: #(a1)
				
				gives: #(b1)
				conflicts: #()! !

!MCMergingTest methodsFor: 'emulating' stamp: ''!
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: 'tests' stamp: ''!
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 assertEmpty: conflicts! !

!MCMergingTest methodsFor: 'tests' stamp: ''!
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: ''!
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 assertEmpty: conflicts! !

!MCMergingTest methodsFor: 'asserting' stamp: ''!
assert: aCollection hasElements: anArray

	self assert: (aCollection collect: [ :ea | ea token ]) asSet equals: anArray asSet! !

!MCMergingTest methodsFor: 'tests' stamp: ''!
testComplexConflictlessMerge
	self 
		assertMerge: #(a1 b1 d1)
				with: #(a2 c1)
				base: #(a1 c1 d1)
				
				gives: #(a2 b1)
				conflicts: #()! !

!MCMergingTest methodsFor: 'tests' stamp: ''!
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 assertEmpty: conflicts! !

!MCMergingTest methodsFor: 'tests' stamp: ''!
testAdditiveConflictlessMerge
	self
		assertMerge: #(a1 b1)
				with: #(a1 c1)
				base: #(a1)
			
				gives: #(a1 b1 c1)
				conflicts: #()! !

!MCMethodDefinition commentStamp: ''!
A MCMethodDefinition represents a method definition. 
It captures the following information.

Instance Variables
	category:		<Object>
	classIsMeta:		<Object>
	className:		<Object>
	selector:		<Object>
	source:		<Object>
	timeStamp:		<Object>

!
!MCMethodDefinition methodsFor: 'comparing' stamp: 'nil'!
= aDefinition
	^ super = aDefinition
		and: [ aDefinition category = self category
		and: [ aDefinition source withInternalLineEndings = self source withInternalLineEndings ] ]! !

!MCMethodDefinition methodsFor: '*Ring-Monticello' stamp: ''!
ensureRingDefinitionIn: anRGEnvironment package: anRGPackage
	
	| def  |
	
	def := self ensureRingDefinitionIn: anRGEnvironment.
	def package: anRGPackage.

	^ def
! !

!MCMethodDefinition methodsFor: 'printing' stamp: 'nil'!
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: 'comparing' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
timeStamp
	^ timeStamp! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'nil'!
isOverrideMethod
	"this oughta check the package"
	^ self isExtensionMethod and: [category endsWith: '-override']! !

!MCMethodDefinition methodsFor: 'printing' stamp: 'nil'!
description
	^ Array	
		with: className
		with: selector
		with: classIsMeta! !

!MCMethodDefinition methodsFor: 'comparing' stamp: 'nil'!
requirements
	^ Array with: className! !

!MCMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isCodeDefinition
	^ true! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
source
	^ source! !

!MCMethodDefinition methodsFor: 'printing' stamp: 'nil'!
summary

	^ className asString , '>>' , selector printString! !

!MCMethodDefinition methodsFor: '*MonticelloFileTree-Core' stamp: ''!
setTimeStamp: aString
    ^ timeStamp := aString! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'nil'!
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 instanceSide initialize ] ].
	"Postloading of FFI fields. This code will be called when loading FFI structures that are not by default in the image. This is NOT dead code."
	self isExternalStructureFieldDefinition
		ifTrue: [self actualClass instanceSide compileFields].! !

!MCMethodDefinition methodsFor: 'annotations' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
className
	^className! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
classIsMeta
	^ classIsMeta! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'nil'!
isExtensionMethod
	^ category beginsWith: '*'! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'nil'!
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 instanceSide inheritsFrom: externalStructure]) == true]]
! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
load
	self actualClass
		compile: source
		classified: category
		withStamp: timeStamp
		notifying: nil! !

!MCMethodDefinition methodsFor: '*Iceberg-Changes' stamp: ''!
method
	^ self actualClass >> self selector! !

!MCMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isLoadable
	^self actualClass notNil! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
selector
	^selector! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'nil'!
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: 'printing' stamp: 'nil'!
shortSummaryPrefix

	^ self definition selector asString! !

!MCMethodDefinition methodsFor: 'accessing - backward' stamp: 'nil'!
category
	"Please favor protocol instead of category. We want to have method protocol and class package and tag = a category"
	^ category! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'nil'!
overridenMethodOrNil
	"Answer the method that I've overriden on load. 

	Preconditions: 
	  - self actualClass is installed in the System Dictionary.
	  - self isOverrideMethod is true."
	
	| realMethod |
	realMethod := self actualClass
		compiledMethodAt: self selector
		ifAbsent: [ ^ nil ].
		
	^ SourceFiles
		changeRecordsFor: realMethod asRingDefinition
		detect: [ :protocol | protocol ~= category ]! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'nil'!
unload
	"Unload me. If I represent an override method, then restore the overriden version. If not, just remove the selector from the class."

	| previousVersion |
	self isOverrideMethod ifTrue: [ previousVersion := self overridenMethodOrNil ].

	previousVersion
		ifNil: [ 
			self actualClass ifNotNil: [ :class | 
				self removeSelector: selector fromClass: class ] ]
		ifNotNil: [ previousVersion fileIn ]! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'nil'!
removeSelector: aSelector fromClass: aClass
	"Safely remove the given selector from the target class.
	Be careful not to remove the selector when it has wandered
	to another package, but remove the category if it is empty."

	| newProtocol |
	newProtocol := aClass organization categoryOfElement: aSelector.
	newProtocol
		ifNotNil: [ 
			"If moved to and fro extension, ignore removal"
			(category beginsWith: '*') = (newProtocol beginsWith: '*')
				ifFalse: [ ^ self ].	"Check if moved between different extension categories"
			((category beginsWith: '*') and: [ category ~= newProtocol ])
				ifTrue: [ ^ self ] ].
	aClass removeSelector: aSelector.
	aClass organization removeProtocolIfEmpty: category! !

!MCMethodDefinition methodsFor: '*Ring-Definitions-Monticello' stamp: 'nil'!
asRingDefinition

	^RGMethodDefinition new
		name: self selector;
		parentName: self className;
		isMetaSide: self classIsMeta;
		protocol: self protocol;
		sourceCode: self source;    
		stamp: self timeStamp! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
fullTimeStamp
	^ DateAndTime fromMethodTimeStamp: timeStamp! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
protocol
	"Return in which protocol (conceptual groups of methods) the receiver is grouped into."
	^ category! !

!MCMethodDefinition methodsFor: '*Ring-Monticello' stamp: ''!
asRGDefinition

"	method2 := (Object>>#isRingObject) asRingDefinition.
	self assert: method2 class equals: RGMethod.	
	self assert: method2 selector equals: #isRingObject.
	self assert: method2 parent name equals: #Object.

	self deny: (method2 environment == env1)."

	^ self ensureRingDefinitionIn: RGEnvironment new
	
! !

!MCMethodDefinition methodsFor: '*Ring-Monticello' stamp: ''!
ensureRingDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		| def classDef metaclassDef parent protocol |
		classDef := anRGEnvironment ensureClassNamed: self className asSymbol.
		
		classDef isTrait 
			ifFalse: [ 
				metaclassDef := anRGEnvironment ensureClassNamed: (self className, ' class') asSymbol.
				classDef metaclass: metaclassDef.
				metaclassDef baseClass: classDef.]
			ifTrue: [ 
				metaclassDef := anRGEnvironment ensureMetaclassTraitNamed: (self className, ' classTrait') asSymbol.
				classDef classTrait: metaclassDef.
				metaclassDef baseTrait. classDef.].
				
		parent := self classIsMeta 
			ifFalse: [ classDef ]
			ifTrue: [ metaclassDef ].
		
		def := RGMethod named: self selector parent: parent.
		parent addLocalMethod: def.
			
		def sourceCode: self source.
		def author: (self authorForStamp: self timeStamp).
		def time: (self timeForStamp: self timeStamp).
		
		protocol := parent ensureProtocolNamed: self category asSymbol.
		parent addProtocol: protocol.
		def protocol: protocol.
		def 
	]! !

!MCMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isMethodDefinition
	^true! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
actualClass
	^ Smalltalk globals
		at: className
		ifPresent: [ :class | 
			classIsMeta
				ifTrue: [ class classSide ]
				ifFalse: [ class ] ]! !

!MCMethodDefinition methodsFor: 'serializing' stamp: 'nil'!
initializeWithClassName: classString
classIsMeta: metaBoolean
selector: selectorString
category: catString
timeStamp: timeString
source: sourceString
	className := classString asSymbol.
	selector := selectorString asSymbol.
	category := (catString asSymbol) ifEmpty: [#'as yet unclassified'].
	timeStamp := timeString.
	classIsMeta := metaBoolean.
	source := sourceString withInternalLineEndings.
! !

!MCMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isInitializer
	^ selector = #initialize and: [classIsMeta]
	! !

!MCMethodDefinition methodsFor: '*Iceberg-Changes' stamp: ''!
buildOn: anIcePackageDiff 
	self shouldBeImplemented.! !

!MCMethodDefinition methodsFor: '*Iceberg-Adapters' stamp: ''!
classCategory
	^ self actualClass ifNotNil: #category ifNil: [ RPackage defaultPackageName ]
! !

!MCMethodDefinition methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor
	^ aVisitor visitMethodDefinition: self! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
diffSource
	^'"protocol: ', self protocol,'"
', self source.! !

!MCMethodDefinition methodsFor: 'comparing' stamp: 'nil'!
sortKey
	^ sortKey
		ifNil: [ sortKey := self className , '.'
				,
					(self classIsMeta
						ifTrue: [ 'meta' ]
						ifFalse: [ 'nonmeta' ]) , '.' , self selector ]! !

!MCMethodDefinition class methodsFor: 'initialization' stamp: 'nil'!
initialize
	SessionManager default
		registerSystemClassNamed: self name! !

!MCMethodDefinition class methodsFor: 'settings' stamp: 'nil'!
initializersEnabled: aBoolean

	InitializersEnabled := aBoolean! !

!MCMethodDefinition class methodsFor: 'instance creation' stamp: 'nil'!
className: classString
selector: selectorString
category: catString
timeStamp: timeString
source: sourceString
	^ self	className: classString
			classIsMeta: false
			selector: selectorString
			category: catString
			timeStamp: timeString
			source: sourceString! !

!MCMethodDefinition class methodsFor: 'initialization' stamp: 'nil'!
flushMethodCache
	"We do not named this method flushCache because it would override an important class methods."
	Definitions := nil.! !

!MCMethodDefinition class methodsFor: 'system startup' stamp: 'nil'!
shutDown
	"Free up all cached monticello method definitions"
	self flushMethodCache ! !

!MCMethodDefinition class methodsFor: 'settings' stamp: 'nil'!
initializersEnabled

	^ InitializersEnabled ifNil: [true]! !

!MCMethodDefinition class methodsFor: 'initialization' stamp: 'nil'!
cachedDefinitions
	^ Definitions 
		ifNil: [ Definitions := WeakIdentityKeyDictionary new ]! !

!MCMethodDefinition class methodsFor: 'instance creation' stamp: 'nil'!
className: classString classIsMeta: metaBoolean selector: selectorString category: catString timeStamp: timeString source: sourceString
	^ self new
		initializeWithClassName: classString
		classIsMeta: metaBoolean
		selector: selectorString
		category: catString
		timeStamp: timeString
		source: sourceString! !

!MCMethodDefinition class methodsFor: 'cleanup' stamp: 'nil'!
cleanUp
	"Flush caches"

	self shutDown.! !

!MCMethodDefinitionTest methodsFor: 'running' stamp: ''!
ownPackage
	^ MCWorkingCopy forPackage: (MCPackage named: 'Monticello')! !

!MCMethodDefinitionTest methodsFor: 'running' stamp: ''!
tearDown
      self restoreMocks.
      extensionPackage unregister.
		extensionPackage := nil.
      self class compile: 'override ^ 1' classified: 'mocks'.
      self ownPackage modified: isModified.
		super tearDown
       "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: ''!
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: ''!
testCannotLoad
	| definition |
	definition := self
		mockMethod: #kjahs87
		class: 'NoSuchClass'
		source: 'kjahs87 ^self'
		meta: false.
	self should: [ definition load ] raise: Error.
	self assertEmpty: (navigation allImplementorsOf: #kjahs87)! !

!MCMethodDefinitionTest methodsFor: 'mocks' stamp: ''!
override ^ 1! !

!MCMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testRevertOldMethod
	| definition changeRecord |
	Object compile: 'yourself ^ self' classified: '*MonticelloMocks'.
	definition := (Object>>#yourself) asMCMethodDefinition.
	changeRecord := definition overridenMethodOrNil.
	self assert: changeRecord notNil.
	self assert: changeRecord category equals: 'accessing'.
	changeRecord fileIn! !

!MCMethodDefinitionTest methodsFor: 'testing' stamp: ''!
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 := (self class>>#override) asMCMethodDefinition.
	self assert: definition isOverrideMethod.
	self assert: self override equals: 4.
	definition unload.
	self assert: self override equals: 2.
	self assert: (self class>>#override) category equals: '*foobarbaz'! !

!MCMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testMethodDefinitionWithEmptyProtocolIsClassifiedAsAsYetUnclassified

	| methodDef |
	methodDef := (MCMethodDefinition
			className: #Object
			classIsMeta: false
			selector: #name
			category: '' 
			timeStamp: nil
			source: 'name
	^ self printString').
	self assert: methodDef category equals: #'as yet unclassified'.! !

!MCMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testLoadAndUnload
	|definition|
	definition := self mockMethod: #one class: 'MCMockClassA' source: 'one ^2' meta: false.
	self assert: self mockInstanceA one equals: 1.
	definition load.
	self assert: self mockInstanceA one equals: 2.
	definition unload.
	self deny: (self mockInstanceA respondsTo: #one)! !

!MCMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testRevertOverrideMethod
	| definition |
	self class compile: 'override ^ 2' classified: self mockOverrideMethodCategory.
	definition := (self class>>#override) asMCMethodDefinition.
	self assert: definition isOverrideMethod.
	self assert: self override equals: 2.
	definition unload.
	self assert: self override equals: 1.
	self assert: (RGMethodDefinition realClass: self class selector: #override) category equals: 'mocks'! !

!MCMethodDefinitionTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	extensionPackage := (MCWorkingCopy forPackage: (MCPackage named: 'FooBarBaz')).
	navigation := (testingEnvironment hasClassNamed: #SystemNavigation)
		ifTrue: [ (testingEnvironment at: #SystemNavigation) new ]
		ifFalse: [ Smalltalk ].
	isModified := self ownPackage modified! !

!MCMock commentStamp: ''!
Common superclass for mocks!
!MCMock class methodsFor: 'as yet unclassified' stamp: 'nil'!
wantsChangeSetLogging
	^ false! !

!MCMockAPoolDictionary commentStamp: ''!
Mocking a pool!
!MCMockASubclass methodsFor: 'as yet unclassified' stamp: ''!
variables
	^ x + Y + MCMockClassA! !

!MCMockASubclass methodsFor: 'as yet unclassified' stamp: ''!
variables2
	^ ivar + CVar! !

!MCMockASubclass class methodsFor: 'as yet unclassified' stamp: ''!
initialize

	InitializationOrder := InitializationOrder
		ifNil: [ -100 ] "let the test fail"
		ifNotNil: [ InitializationOrder + 1.]! !

!MCMockClassA commentStamp: ''!
This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.!
!MCMockClassA methodsFor: 'numeric' stamp: ''!
c
	^ 'c1'! !

!MCMockClassA methodsFor: 'boolean' stamp: ''!
moreTruth

	^ true! !

!MCMockClassA methodsFor: 'numeric' stamp: ''!
two
	^ 2! !

!MCMockClassA methodsFor: 'boolean' stamp: ''!
truth
	^ true! !

!MCMockClassA methodsFor: 'drag''n''drop' stamp: ''!
q! !

!MCMockClassA methodsFor: 'numeric' stamp: ''!
a
	^ 'a2'! !

!MCMockClassA methodsFor: 'numeric' stamp: ''!
one
	^ 1! !

!MCMockClassA methodsFor: 'numeric' stamp: ''!
d
	^ 'd'! !

!MCMockClassA methodsFor: 'boolean' stamp: ''!
falsehood
	^ false! !

!MCMockClassA methodsFor: 'numeric' stamp: ''!
b
	^ 'b1'! !

!MCMockClassA class methodsFor: 'as yet unclassified' stamp: ''!
initialize
	CVar := #initialized.
	InitializationOrder := 1.
! !

!MCMockClassA class methodsFor: 'as yet unclassified' stamp: ''!
cVar
	^ CVar! !

!MCMockClassA class methodsFor: 'as yet unclassified' stamp: ''!
touchCVar
	CVar := #touched! !

!MCMockClassA class methodsFor: 'as yet unclassified' stamp: ''!
one

	^ 1! !

!MCMockClassA class methodsFor: 'as yet unclassified' stamp: ''!
initializationOrder

	^ InitializationOrder! !

!MCMockClassB commentStamp: ''!
This comment has a bang!! Bang!! Bang!!!
!MCMockClassB methodsFor: 'accessing' stamp: ''!
ivarb

	^ ivarb! !

!MCMockClassB class methodsFor: 'accessing' stamp: ''!
ciVar

	^ ciVar! !

!MCMockClassB class methodsFor: 'accessing' stamp: ''!
cVar

	^ CVar! !

!MCMockClassD methodsFor: 'as yet unclassified' stamp: ''!
one
	^ 1! !

!MCMockClassE class methodsFor: 'as yet unclassified' stamp: ''!
two
	^ 2! !

!MCMockDefinition commentStamp: ''!
A mock definition used for testing purposes!
!MCMockDefinition methodsFor: 'comparing' stamp: 'nil'!
= definition
	self == definition
		ifTrue: [ ^ true ].
	self species = definition species
		ifFalse: [ ^ false ].
	^definition token = token! !

!MCMockDefinition methodsFor: 'comparing' stamp: 'nil'!
hash

	^ token hash! !

!MCMockDefinition methodsFor: 'comparing' stamp: 'nil'!
description

	^ token first! !

!MCMockDefinition methodsFor: 'printing' stamp: 'nil'!
summary

	^ token! !

!MCMockDefinition methodsFor: 'converting' stamp: 'nil'!
asString

	^ token! !

!MCMockDefinition methodsFor: 'accessing' stamp: 'nil'!
token

	^ token! !

!MCMockDefinition methodsFor: 'printing' stamp: 'nil'!
printString

	^ token! !

!MCMockDefinition methodsFor: 'accessing' stamp: 'nil'!
token: aString

	token := aString! !

!MCMockDefinition class methodsFor: 'compiling' stamp: 'nil'!
wantsChangeSetLogging
	^ false! !

!MCMockDefinition class methodsFor: 'accessing' stamp: 'nil'!
token: aString

	^ self new token: aString! !

!MCMockDependency commentStamp: ''!
A test object mocking a dependency!
!MCMockDependency methodsFor: 'comparing' stamp: ''!
= other
	^ self name = other name! !

!MCMockDependency methodsFor: 'comparing' stamp: ''!
hash
	^ self name hash! !

!MCMockDependency methodsFor: 'mocks' stamp: ''!
uuidForName: aName 
	| nm id |
	nm := aName asString.
	id := '00000000-0000-0000-0000-0000000000' 
				, (nm size = 1 ifTrue: [nm , '0'] ifFalse: [nm]).
	^UUID fromString: id! !

!MCMockDependency methodsFor: 'accessing' stamp: ''!
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: ''!
children
	^ children collect: [:ea | self class fromTree: ea]! !

!MCMockDependency methodsFor: 'resolving' stamp: ''!
resolve
	^ self hasResolution
		ifTrue: [MCVersion new
					setPackage: MCSnapshotResource mockPackage
					info: self mockVersionInfo
					snapshot: MCSnapshotResource current snapshot
					dependencies: self children]
		ifFalse: [nil]! !

!MCMockDependency methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!MCMockDependency methodsFor: 'resolving' stamp: ''!
hasResolution
	^ hasResolution! !

!MCMockDependency methodsFor: 'mocks' stamp: ''!
mockVersionInfo
	^ MCVersionInfo
		name: self name
		id: (self uuidForName: name)
		message: ''
		date: nil
		time: nil
		author: ''
		ancestors: #()! !

!MCMockDependency class methodsFor: 'instance creation' stamp: ''!
fromTree: anArray 
	^ self new initializeWithTree: anArray! !

!MCMockDependentItem commentStamp: ''!
Mock for dependency testing!
!MCMockDependentItem methodsFor: 'accessing' stamp: 'nil'!
provisions

	^ provides ifNil: [#()]! !

!MCMockDependentItem methodsFor: 'accessing' stamp: 'nil'!
requires: anArray

	requires := anArray! !

!MCMockDependentItem methodsFor: 'comparing' stamp: 'nil'!
requirements

	^ requires ifNil: [#()]! !

!MCMockDependentItem methodsFor: 'accessing' stamp: 'nil'!
name

	^ name! !

!MCMockDependentItem methodsFor: 'accessing' stamp: 'nil'!
name: aString

	name := aString! !

!MCMockDependentItem methodsFor: 'accessing' stamp: 'nil'!
provides: anArray

	provides := anArray! !

!MCMockDependentItem methodsFor: 'comparing' stamp: 'nil'!
<= other
	^ self name <= other name! !

!MCModification commentStamp: ''!
A MCModification represents the operation to modify an entity to a snapshot. !
!MCModification methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	^ self iconNamed: #changeUpdate! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
basicApplyTo: anObject
	anObject modifyDefinition: obsoletion to: modification! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
summarySuffix
	^ modification summarySuffixOver: obsoletion
! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
baseDefinition
	^ obsoletion! !

!MCModification methodsFor: 'testing' stamp: 'nil'!
isModification
	^ true! !

!MCModification methodsFor: '*Iceberg-Changes' stamp: ''!
myVersionOn: aDiff

	^ aDiff versionFromDefinition: modification! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
targetDefinition
	^ modification! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
obsoletion
	^ obsoletion! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
targetClass
	^ obsoletion actualClass! !

!MCModification methodsFor: '*Tool-Diff' stamp: ''!
diffFromSource
	"Answer fromSource of the modification. If a class patch then answer
	the fromSource with the class-side definition and comment appended."
	
	^self isClassPatch
		ifTrue: [self fromSource, String cr, String cr,
				obsoletion classDefinitionString, String cr, String cr,
				obsoletion commentStamp, String cr,
				obsoletion comment]
		ifFalse: [obsoletion diffSource]! !

!MCModification methodsFor: 'initializing' stamp: 'nil'!
initializeWithBase: base target: target
	obsoletion := base.
	modification := target.! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
modification
	^ modification! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
toSource
	^ modification diffSource! !

!MCModification methodsFor: '*Tool-Diff' stamp: ''!
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: 'nil'!
definition
	^ modification! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
fromSource
	^ obsoletion source! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
inverse
	^ MCModification of: modification to: obsoletion! !

!MCModification methodsFor: 'testing' stamp: 'nil'!
isClassPatch
	^obsoletion isClassDefinition! !

!MCModification methodsFor: 'accessing' stamp: 'nil'!
printAnnotations: request on: aStream
	aStream nextPutAll: 'old: '.
	obsoletion printAnnotations: request on: aStream.
	aStream cr.
	aStream nextPutAll: 'new: '.
	modification printAnnotations: request on: aStream.! !

!MCModification methodsFor: '*Iceberg-Changes' stamp: ''!
asIceOperationOn: aNode diff: anIceDiff 
	
	^ MCModification
		of: aNode
		to: aNode! !

!MCModification methodsFor: '*Tool-Diff' stamp: ''!
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: '*Iceberg-Changes' stamp: ''!
theirVersionOn: aDiff

	^ aDiff versionFromDefinition: obsoletion! !

!MCModification methodsFor: 'printing' stamp: 'nil'!
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 class methodsFor: 'instance creation' stamp: 'nil'!
of: base to: target
	^ self new initializeWithBase: base target: target! !

!MCMultiPackageLoader commentStamp: ''!
A PackageLoader doing some additional cross-package checks!
!MCMultiPackageLoader methodsFor: 'private' stamp: 'nil'!
analyze
	| index |
	index := MCDefinitionIndex definitions: additions.
	removals removeAllSuchThat: [:removal |
		(index definitionLike: removal
			ifPresent: [:addition | obsoletions at: addition put: removal]
			ifAbsent: []) notNil].
	super analyze! !

!MCNoChangesException commentStamp: ''!
Notify that no changes have to be merged!
!MCNoChangesException methodsFor: 'accessing' stamp: 'nil'!
defaultAction
	self inform: 'No changes'! !

!MCOldDataStreamExtensions commentStamp: ''!
This is an extension class for the MCDataStream, it should only used if you need backward compatibility. But we have tested that is only needed because is "copy-pasted" code. MC is not using at all the defined types id. 

This package is unloadeable.!
!MCOldDataStreamExtensions class methodsFor: 'class initialization' stamp: ''!
initialize
	MCDataStream registerReaderSelector: #readStringOld atIndex: 5.
	MCDataStream registerClass: ByteArray atIndex: 7  usingReadSelector: #readByteArray usingWriteSelector: #writeByteArray:.
	MCDataStream registerReaderSelector: #readReference atIndex: 10.
	MCDataStream registerClass: Bitmap atIndex: 11  usingReadSelector: #readBitmap usingWriteSelector: #writeBitmap:.
	" 12 is for Classes but never worked".
	MCDataStream registerReaderSelector: #readInstace atIndex: 13.
	MCDataStream registerClass: Float atIndex: 14  usingReadSelector: #readFloat usingWriteSelector: #writeFloat:.
	MCDataStream registerClass: Rectangle atIndex: 15  usingReadSelector: #readRectangle usingWriteSelector: #writeRectangle:.	
	MCDataStream registerReaderSelector: #readShortInst atIndex: 16.
	MCDataStream registerClass: WordArray atIndex: 18  usingReadSelector: #readWordArray usingWriteSelector: #writeBitmap:.	
	MCDataStream registerReaderSelector: #readMethod atIndex: 21.

	! !

!MCOrganizationDefinition commentStamp: ''!
A MCOrganizationDefinition represents a category change. !
!MCOrganizationDefinition methodsFor: 'private' stamp: 'nil'!
reorderCategories: allCategories original: oldCategories

	^ allCategories
		detect: [ :ea | categories includes: ea ]
		ifFound: [ :first | 
			((allCategories copyUpTo: first)
				copyWithoutAll: oldCategories , categories) , categories
				,
					((allCategories copyAfter: first)
						copyWithoutAll: oldCategories , categories) ]
		ifNone: [ allCategories ]! !

!MCOrganizationDefinition methodsFor: 'comparing' stamp: 'nil'!
= aDefinition

	^ (super = aDefinition)
		and: [ self categories size = aDefinition categories size and: [ self categories includesAll: aDefinition categories ] ].! !

!MCOrganizationDefinition methodsFor: 'accessing' stamp: 'nil'!
categories
	^ categories! !

!MCOrganizationDefinition methodsFor: 'comparing' stamp: 'nil'!
hash
	^ (self species hash 
		bitXor: super hash)
		bitXor: self categories hash! !

!MCOrganizationDefinition methodsFor: '*Tool-Diff' stamp: ''!
patchWrapper
	"Answer a wrapper for a patch tree for the receiver."

	^PSMCOrganizationChangeWrapper with: self! !

!MCOrganizationDefinition methodsFor: 'accessing' stamp: 'nil'!
shortSummaryPrefix

	^ self definition description last! !

!MCOrganizationDefinition methodsFor: 'accessing' stamp: 'nil'!
description
	^ Array with: #organization with: self fullDescription! !

!MCOrganizationDefinition methodsFor: 'private' stamp: 'nil'!
fullDescription
	self categories ifEmpty: [ ^ self commonPrefix ].
	^ String
		streamContents: [ :stream | 
			| first |
			first := self categories first.
			stream << first.
			self categories allButFirst
				do: [ :c | 
					| part |
					part := c withoutPrefix: first.
					stream << $| << part ] ]! !

!MCOrganizationDefinition methodsFor: 'unloading' stamp: 'nil'!
unload
	categories
		do: [ :category | 
			(SystemOrganization isEmptyCategoryNamed: category)
				ifTrue: [ SystemOrganization removeCategory: category ] ]! !

!MCOrganizationDefinition methodsFor: 'accessing' stamp: 'nil'!
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: 'nil'!
source
	^ String streamContents:
		[:s |
		categories do: [:ea | s nextPutAll: ea] separatedBy: [s cr]]! !

!MCOrganizationDefinition methodsFor: 'accessing' stamp: 'nil'!
summary
	^ categories asArray printString! !

!MCOrganizationDefinition methodsFor: '*Ring-Definitions-Monticello' stamp: 'nil'!
asRingDefinition

	^RGOrganization new
		categories: self categories;
		yourself  ! !

!MCOrganizationDefinition methodsFor: 'installing' stamp: 'nil'!
postloadOver: oldDefinition
	SystemOrganization categories:
		(self
			reorderCategories: SystemOrganization categories
			original: (oldDefinition ifNil: [#()] ifNotNil: [oldDefinition categories]))! !

!MCOrganizationDefinition methodsFor: '*Iceberg-Changes' stamp: ''!
addToPackageDiff: anIcePackageDiff leftSnapshot: leftSnapshot rightSnapshot: rightSnapshot 
	
	^ anIcePackageDiff ensureOrganization: categories! !

!MCOrganizationDefinition methodsFor: '*Iceberg-Core' stamp: ''!
iceClass
	^ nil! !

!MCOrganizationDefinition methodsFor: '*Iceberg-Core' stamp: ''!
icePackage
	"TODO: Refactor this, see https://github.com/npasserini/iceberg/issues/42"
	self categories 
		ifNotEmpty: [ ^ Iceberg packageForCategoryNamed: (self categories anyOne) ]
	 	ifEmpty: nil
! !

!MCOrganizationDefinition methodsFor: 'testing' stamp: 'nil'!
isOrganizationDefinition
	^ true! !

!MCOrganizationDefinition methodsFor: '*Iceberg-Changes' stamp: ''!
addAnalysisToPackageChangeSet: aPackageChangeSet change: aChange
	aPackageChangeSet addOrganisationChange: aChange! !

!MCOrganizationDefinition methodsFor: 'accessing' stamp: 'nil'!
categories: aCollection
	"ensure the categories are sorted alphabetically, so the merge don't take it as a conflict"
	categories := aCollection sorted asArray! !

!MCOrganizationDefinition methodsFor: 'accessing' stamp: 'nil'!
accept: aVisitor
	^ aVisitor visitOrganizationDefinition: self! !

!MCOrganizationDefinition methodsFor: 'private' stamp: 'nil'!
basicCommonPrefix
	"Answers the minimum common denominator on package names contained in the monticello package. 
	 It can answer a package in the form X-Y-, with a minus at end..."
	| stream  |
	categories isEmpty ifTrue: [ ^ '' ].
	
	stream := String new writeStream.
	categories first withIndexDo: [:c :index |
		categories do: [:each |
			(each at: index ifAbsent: []) = c 
				ifFalse: [ ^ stream contents ] ].
		stream nextPut: c ].
	
	^stream contents! !

!MCOrganizationDefinition methodsFor: 'accessing' stamp: 'nil'!
sortKey
	^ '<organization>'! !

!MCOrganizationDefinition class methodsFor: 'instance creation' stamp: 'nil'!
categories: aCollection
	^ self new categories: aCollection! !

!MCOrganizationTest methodsFor: 'tests' stamp: ''!
testReorderingWithRemovals
	| dec cats newCats |
	dec := MCOrganizationDefinition categories: #(A B C) copy.
	cats := #(X Y B Z C A Q).
	newCats := dec reorderCategories: cats original: #(Y B C A Q).
	self assert: newCats asArray equals: #(X A B C Z)! !

!MCOrganizationTest methodsFor: 'tests' stamp: ''!
testReorderingWithNoCategoriesInVersion
	| dec cats newCats |
	dec := MCOrganizationDefinition categories: #().
	cats := #(X Y B Z C A Q).
	newCats := dec reorderCategories: cats original: #().
	self assert: newCats asArray equals: cats! !

!MCOrganizationTest methodsFor: 'tests' stamp: ''!
testReordering
	| dec cats newCats |
	dec := MCOrganizationDefinition categories: #(A B C) copy.
	cats := #(X Y B Z C A Q).
	newCats := dec reorderCategories: cats original: #(B C A).
	self assert: newCats asArray equals: #(X Y A B C Z Q)! !

!MCOrganizationTest methodsFor: 'tests' stamp: ''!
testLoadAndUnload
	| category |
	category := 'TestPackageToUnload'.
	SystemOrganization addCategory: category.
	(MCOrganizationDefinition categories: { category }) unload.
	self deny: (SystemOrganization includesCategory: category)! !

!MCPTest methodsFor: 'constants' stamp: ''!
defaultBounds
	"the default bounds for morphs"
	^ 0 @ 0 corner: 50 @ 40! !

!MCPTest methodsFor: 'constants' stamp: ''!
defaultTop
	"the default top for morphs"
	^ self defaultBounds top! !

!MCPTest methodsFor: 'tests' stamp: ''!
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 equals: newTop;
		assert: morph bounds equals: newBounds! !

!MCPackage commentStamp: ''!
MCPackage represents a package. It is merely a wrapper on top of a package set or packageInfo.

Strangely enough it does not inherit from MCDefinition.

Its most important method is snapshot which returns a snapshot with all the entities that should be saved. !
!MCPackage methodsFor: 'working copies' stamp: 'nil'!
workingCopy
	^ MCWorkingCopy forPackage: self.! !

!MCPackage methodsFor: 'comparing' stamp: 'nil'!
= other
	^ other species = self species and: [other name = name]! !

!MCPackage methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterMonticelloWorkingCopyFor: aStep
	<stSpotterOrder: 1>
	aStep listProcessor
		title: 'Monticello Working Copy';
		allCandidates: [ Array with: self workingCopy ];
		itemIcon: [ Smalltalk ui icons iconNamed: #versionControlIcon ];
		filter: StFilterSubstring! !

!MCPackage methodsFor: 'comparing' stamp: 'nil'!
hash
	^ name asLowercase hash! !

!MCPackage methodsFor: 'accessing' stamp: 'nil'!
packageSet
	^ RPackageSet named: name! !

!MCPackage methodsFor: 'accessing' stamp: 'nil'!
correspondingRPackage

	^ RPackageOrganizer default packageNamed: self name asSymbol ifAbsent: [ nil ]! !

!MCPackage methodsFor: 'printing' stamp: 'nil'!
displayStringOn: aStream
	aStream nextPutAll: self name! !

!MCPackage methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: name;
		nextPut: $)! !

!MCPackage methodsFor: 'working copies' stamp: 'nil'!
unload
	^ self workingCopy unload! !

!MCPackage methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForPackageFor: aStep
	<stSpotterOrder: 2>
	aStep listProcessor
		title: 'Packages';
		allCandidates: [ Array with: self correspondingRPackage ];
		itemName: [ :package | package name ];
		itemIcon: [ Smalltalk ui icons iconNamed: #packageIcon ];
		filter: StFilterSubstring! !

!MCPackage methodsFor: 'testing' stamp: 'nil'!
isDirty
	
	^ self workingCopy
		ifNil: [ false ]
		ifNotNil: [ :wc | wc modified ]! !

!MCPackage methodsFor: 'accessing' stamp: 'nil'!
name
	^ name! !

!MCPackage methodsFor: 'accessing' stamp: 'nil'!
name: aString
	name := aString! !

!MCPackage methodsFor: 'accessing' stamp: 'nil'!
snapshot
	| rPackageSet definitions categories |
	rPackageSet := self packageSet.
	definitions := OrderedCollection new.
	categories := rPackageSet categoryNames asArray.
	categories isEmpty 
		ifFalse: [ definitions add: (MCOrganizationDefinition categories: categories) ].
		
	rPackageSet methods 
		do: [:ea | definitions add: ea asMCMethodDefinition] 
		displayingProgress: [ :ea| 'Snapshotting methods...' ].
				
	rPackageSet definedClasses 
		do: [:ea | definitions addAll: ea classDefinitions] 
		displayingProgress: [ :ea| 'Snapshotting class ', ea asString ].
		
	^ MCSnapshot fromDefinitions: definitions
! !

!MCPackage methodsFor: '*Iceberg' stamp: ''!
basicSnapshot
	| rPackageSet definitions categories |
	rPackageSet := self packageSet.
	definitions := OrderedCollection new.
	categories := rPackageSet categoryNames asArray.
	categories isEmpty 
		ifFalse: [ definitions add: (MCOrganizationDefinition categories: categories) ].
		
	rPackageSet methods 
		do: [:ea | definitions add: ea asMCMethodDefinition].
		
	rPackageSet definedClasses 
		do: [:ea | definitions addAll: ea classDefinitions].
		
	^ MCSnapshot fromDefinitions: definitions
! !

!MCPackage methodsFor: 'working copies' stamp: 'nil'!
hasWorkingCopy
	^ MCWorkingCopy registry includesKey: self! !

!MCPackage methodsFor: 'printing' stamp: 'nil'!
storeOn: aStream
	aStream
		nextPutAll: 'MCPackage';
		space; nextPutAll: 'named: '; store: name.! !

!MCPackage class methodsFor: 'instance creation' stamp: 'nil'!
named: aString
	^ self new name: aString! !

!MCPackageCache commentStamp: ''!
I'm a kind of cache for versions and filenames of packages.!
!MCPackageCache methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	sorter := MCVersionSorter new.
	fileNames := Dictionary new.! !

!MCPackageCache methodsFor: 'accessing' stamp: 'nil'!
versionInfos
	^ sorter sortedVersionInfos ! !

!MCPackageCache methodsFor: 'accessing' stamp: 'nil'!
recordVersionInfo: aVersionInfo forFileNamed: aString
	fileNames at: aVersionInfo put: aString.
	sorter addVersionInfo: aVersionInfo! !

!MCPackageLoader commentStamp: ''!
A MCPackageLoader is responsible for loading packages.  It gets used by VersionLoader, so it is eventually responsible for loading everything.

Instance Variables
	additions:		<Definitions>  Definitions that need to be added
	errorDefinitions:		<Object>
	obsoletions:		<Object>
	provisions:		<Object>
	removals:		<Object>
	requirements:		<Object>
	unloadableDefinitions:		<Object>
	methodAdditions  <MethodAdditions> MethodDefinitions corresponding to the Definitions in "additions" that have been added so far.
!
!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
useNewChangeSetNamedLike: baseName during: aBlock
	^self useChangeSetNamed: (ChangeSet uniqueNameLike: baseName) during: aBlock! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
shouldWarnAboutErrors
	^ errorDefinitions isEmpty not and: [false "should make this a setting ?"]! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
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: 'patch ops' stamp: 'nil'!
modifyDefinition: old to: new
	self addDefinition: new.
	obsoletions at: new put: old.! !

!MCPackageLoader methodsFor: 'public' stamp: 'nil'!
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: 'nil'!
basicLoadDefinitions

	"FIXME. Do a separate pass on loading class definitions as the very first thing.
	This is a workaround for a problem with the so-called 'atomic' loading (you wish!!)
	which isn't atomic at all but mixes compilation of methods with reshapes of classes.

	Since the method is not installed until later, any class reshape in the middle *will*
	affect methods in subclasses that have been compiled before. There is probably
	a better way of dealing with this by ensuring that the sort order of the definition lists
	superclass definitions before methods for subclasses but I need this NOW, and adding
	an extra pass ensures that methods are compiled against their new class definitions."

	additions do: [ :each | self loadClassDefinition: each ] displayingProgress: 'Loading classes...'.
	additions do: [ :each | self tryToLoad: each           ] displayingProgress: 'Compiling methods...'.
	removals  do: [ :each | each unload                    ] displayingProgress: 'Cleaning up...'.
	
	self shouldWarnAboutErrors ifTrue: [ self warnAboutErrors ].
	errorDefinitions do: [ :each | each addMethodAdditionTo: methodAdditions ] displayingProgress: 'Reloading erroneous definitions...'.
	
	methodAdditions do: [ :each | each installMethod ].
	methodAdditions do: [ :each | each notifyObservers ].
	additions       do: [ :each | each postloadOver: (self obsoletionFor: each) ] displayingProgress: 'Initializing...'.
	! !

!MCPackageLoader methodsFor: 'public' stamp: 'nil'!
installSnapshot: aSnapshot
	| patch |
	patch := aSnapshot patchRelativeToBase: MCSnapshot empty.
	patch applyTo: self.
! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
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: 'public' stamp: 'nil'!
loadWithNameLike: baseName
	self validate.
	self useNewChangeSetNamedLike: baseName during: [self basicLoad]! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
basicLoad
    errorDefinitions := OrderedCollection new.
    SourceFiles deferFlushDuring: [self basicLoadDefinitions].! !

!MCPackageLoader methodsFor: 'public' stamp: 'nil'!
loadWithName: baseName
	self validate.
	self useChangeSetNamed: baseName during: [self basicLoad]! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
useChangeSetNamed: baseName during: aBlock
	"Use the named change set, or create one with the given name."
	| oldChanges newChanges |
	oldChanges := ChangeSet current.
	newChanges := (ChangeSet named: baseName) ifNil: [ ChangeSet new name: baseName ].
	ChangeSet newChanges: newChanges.
	aBlock ensure: [ ChangeSet newChanges: oldChanges ].
! !

!MCPackageLoader methodsFor: 'patch ops' stamp: 'nil'!
removeDefinition: aDefinition
	removals add: aDefinition! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
loadClassDefinition: aDefinition

	[ aDefinition isClassDefinition 
		ifTrue: [ aDefinition load ]
	] on: Error do: [ 
		errorDefinitions add: aDefinition ].! !

!MCPackageLoader methodsFor: 'patch ops' stamp: 'nil'!
addDefinition: aDefinition
	additions add: aDefinition! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
obsoletionFor: aDefinition
	^ obsoletions at: aDefinition ifAbsent: [nil]! !

!MCPackageLoader methodsFor: 'public' stamp: 'nil'!
load
	self validate.
	self useNewChangeSetDuring: [self basicLoad].
	MCMethodDefinition cachedDefinitions finalizeValues.! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
sorterForItems: aCollection
	| sorter |
	sorter := MCDependencySorter items: aCollection.
	sorter addExternalProvisions: self provisions.
	^ sorter! !

!MCPackageLoader methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	additions := OrderedCollection new.
	removals := OrderedCollection new.
	obsoletions := Dictionary new.
	methodAdditions := OrderedCollection new. 
! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
provisions
	^ provisions ifNil: [provisions := Set withAll: Smalltalk globals keys]! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
tryToLoad: aDefinition
	[aDefinition addMethodAdditionTo: methodAdditions] on: Error do: [errorDefinitions add: aDefinition].! !

!MCPackageLoader methodsFor: 'public' stamp: 'nil'!
unloadPackage: aPackage
	self updatePackage: aPackage withSnapshot: MCSnapshot empty.
	MCMethodDefinition cachedDefinitions finalizeValues.! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
orderedAdditions
	^ additions! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
warnAboutErrors
	self notify: self errorDefinitionWarning.
! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
useNewChangeSetDuring: aBlock
	^self useNewChangeSetNamedLike: 'MC' during: aBlock! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
validate
	self analyze.
	unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
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: 'nil'!
warnAboutDependencies 
	self notify: self dependencyWarning! !

!MCPackageLoader methodsFor: 'private' stamp: 'nil'!
orderDefinitionsForLoading: aCollection
	^ (self sorterForItems: aCollection) orderedItems! !

!MCPackageLoader class methodsFor: 'public' stamp: 'nil'!
unloadPackage: aPackage
	self new
		unloadPackage: aPackage;
		loadWithNameLike: aPackage name, '-unload'! !

!MCPackageLoader class methodsFor: 'public' stamp: 'nil'!
updatePackage: aPackage withSnapshot: aSnapshot
	self new
		updatePackage: aPackage withSnapshot: aSnapshot;
		load! !

!MCPackageLoader class methodsFor: 'public' stamp: 'nil'!
installSnapshot: aSnapshot
	self new
		installSnapshot: aSnapshot;
		load! !

!MCPackageManager commentStamp: ''!
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	<MCPackage>
	modified	<Boolean>

Class Instance Variables:
	registry	<Dictionary>!
!MCPackageManager methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	modified := false.
! !

!MCPackageManager methodsFor: 'accessing' stamp: 'nil'!
packageSet
	^ package packageSet! !

!MCPackageManager methodsFor: 'printing' stamp: 'nil'!
displayStringOn: stream
	stream nextPutAll: self package name! !

!MCPackageManager methodsFor: 'accessing' stamp: 'nil'!
modified
	^ modified! !

!MCPackageManager methodsFor: 'accessing' stamp: 'nil'!
packageName
	^ package name! !

!MCPackageManager methodsFor: 'operations' stamp: 'nil'!
unregister
	self class registry 
		removeKey: package
		ifAbsent: [ ^ self ].
	self class changed: (Array with: #unregistered with: package).
	self announcer announce: (MCWorkingCopyDeleted workingCopy: self package: package)! !

!MCPackageManager methodsFor: 'accessing' stamp: 'nil'!
modified: aBoolean
	modified = aBoolean
		ifTrue: [ ^ self ].
	modified := aBoolean.
	self changed: #modified.
	modified
		ifFalse: [ 
			ChangesLog default logChange: '"' , self packageName , '"' ].
	self announcer announce: (MCPackageModified package: self package)
	! !

!MCPackageManager methodsFor: 'accessing' stamp: 'nil'!
packageNameWithStar
	^ modified
		ifTrue: ['* ', self packageName]
		ifFalse: [self packageName]! !

!MCPackageManager methodsFor: 'accessing' stamp: 'nil'!
package
	^ package! !

!MCPackageManager methodsFor: 'private' stamp: 'nil'!
announcer
	^self class announcer! !

!MCPackageManager methodsFor: 'initialization' stamp: 'nil'!
initializeWithPackage: aPackage
	package := aPackage.
	self initialize.! !

!MCPackageManager class methodsFor: 'accessing' stamp: 'nil'!
registry
	^ registry ifNil: [registry := Dictionary new]! !

!MCPackageManager class methodsFor: 'accessing' stamp: 'nil'!
allManagers
	^ self registry values! !

!MCPackageManager class methodsFor: 'initialize' stamp: 'nil'!
initialize
	"Remove this later"

	self unregisterForNotifications.! !

!MCPackageManager class methodsFor: 'event registration' stamp: 'nil'!
unregisterForNotifications
	SystemAnnouncer uniqueInstance unsubscribe: self! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
methodMoved: anEvent
	self managersForPackage: anEvent oldPackage do: [ :mgr | mgr modified: true ].
	self managersForPackage: anEvent newPackage do: [ :mgr | mgr modified: true ].! !

!MCPackageManager class methodsFor: 'accessing' stamp: 'nil'!
forPackage: aPackage
	^ self registry 
		at: aPackage 
		ifAbsent: [|mgr|
			mgr := self new initializeWithPackage: aPackage.
			self registry at: aPackage put: mgr.
			self announcer announce: (MCWorkingCopyCreated workingCopy: mgr package: aPackage).
			mgr ]! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
managersForClass: aClass selector: aSelector do: aBlock
	^self managersForClass: aClass category: (aClass organization categoryOfElement: aSelector) do: aBlock! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
classModified: anEvent
	self 
		managersForClass: anEvent classAffected 
		do:[ :mgr | mgr modified: true ].! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
managersForClass: aClass do: aBlock

	| rPackage |
	rPackage := aClass package.

	self registry do: [:mgr |
		(mgr packageSet packages includes: rPackage)
			ifTrue: [aBlock value: mgr]]! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
managersForPackage: aPackage do: aBlock
	self registry do: [:mgr | 
		(mgr packageSet includesSystemCategory: aPackage name) ifTrue: [
			aBlock value: mgr.
		]
	].! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
bestMatchingManagerForCategory: aSystemCategory do: aBlock
	| bestMatches bestMatchingManagerAndPackage |
	bestMatches := OrderedCollection new.
	self registry do: [ :mgr |
		| candidatePackages bestMatchingPackage |
		candidatePackages := mgr packageSet packages select: [ :package |
			package name asUppercase beginsWith: aSystemCategory asUppercase ].
		bestMatchingPackage := candidatePackages detectMin: [ :package |
			package name size ].
		bestMatchingPackage ifNotNil: [
			bestMatches add: mgr -> bestMatchingPackage ] ].
	bestMatchingManagerAndPackage := bestMatches detectMin: [ :managerAndPackage |
			managerAndPackage value name size ].
	bestMatchingManagerAndPackage ifNotNil: [ :managerAndPackage |
		aBlock value: managerAndPackage key ]! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
packageRenamed: anAnnouncement
	self allManagers 
		detect: [ :each | each packageName = anAnnouncement newName ]
		ifFound: [ :newPackage | newPackage modified: true ].
	(self allManagers 
		detect: [ :each | each packageName = anAnnouncement oldName ])
		unload.! !

!MCPackageManager class methodsFor: 'event registration' stamp: 'nil'!
registerInterestOnSystemChangesOnAnnouncer: anAnnouncer
	anAnnouncer weak
		when: RPackageRenamed send: #packageRenamed: to: self;
		when: ClassAdded, ClassModifiedClassDefinition, ClassCommented , ClassParentRenamed send: #classModified: to: self;
		when: ClassRenamed send:#classRenamed: to:self;
		when: ClassRepackaged send: #classMoved: to: self;
		when: ClassRemoved send: #classRemoved: to: self;
		when: MethodAdded, MethodModified, MethodRecategorized send: #methodModified: to: self;
		when: MethodRepackaged send: #methodMoved: to: self;
		when: MethodRemoved send: #methodRemoved: to: self.! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
methodModified: anEvent

	"If the method has just been loaded by monticello itself, do not mark it as dirty"
	anEvent propertyAt: #eventSource ifPresent: [ :source |
		source == self class package name
			ifTrue: [ ^ self ]].

   "trait methods aren't handled here"
	anEvent isProvidedByATrait
		ifTrue: [ ^ self ].
		
	^ self
		managersForClass: anEvent methodClass
		selector: anEvent selector
		do: [ :mgr | mgr modified: true ]! !

!MCPackageManager class methodsFor: 'private' stamp: 'nil'!
announcer: anAnnouncer
	PrivateAnnouncer := anAnnouncer! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
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: 'nil'!
methodRemoved: anEvent
	self managersForClass: anEvent methodClass category: anEvent protocol do:[:mgr| mgr modified: true].
! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
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"

	"Note. Class protocols returns symbols and not Protocol instances!!"
	(RPackageOrganizer default
		packageMatchingExtensionName: anEvent categoryName) ifNotNil: [ :package |
			package mcWorkingCopy ifNotNil: [ :workingCopy | workingCopy modified: true ] ].
		
	anEvent classAffected protocols, anEvent classAffected classSide protocols
		do: [ :aProtocolName | 
			(aProtocolName beginsWith: '*')
				ifTrue:
					[ (RPackageOrganizer default
						packageMatchingExtensionName: aProtocolName allButFirst trimBoth)
							ifNotNil: [ :package |
								package mcWorkingCopy ifNotNil: [ :workingCopy |
									workingCopy modified: true ] ] ] ]! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
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
		bestMatchingManagerForCategory: aSystemCategory
		do: [ :mgr |
			aBlock value: mgr.
			foundOne := true ].

   foundOne ifTrue: [ ^self ].
	[  "Loop over categories until we found a matching one"
		self registry keys detect: [ :aPackage | aPackage name sameAs: cat ]
			ifFound: [:aPackage | | mgr | 
				mgr := self registry at: aPackage.
				aBlock value: mgr. 
				foundOne := true. 
				false] 
			ifNone: [ 
				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: 'nil'!
classRenamed: anEvent
	self classModified: anEvent.
	anEvent classAffected extendingPackages
		do: [ :pkg | self managersForPackage: pkg do: [ :mgr | mgr modified: true ] ]! !

!MCPackageManager class methodsFor: 'private' stamp: 'nil'!
announcer
	^PrivateAnnouncer ifNil: [ SystemAnnouncer uniqueInstance  ]! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'nil'!
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.! !

!MCPackageManagerTest methodsFor: 'tests' stamp: ''!
testClassRemoved
	
	classToRemove := self class classInstaller make: [ :aBuilder | 
			aBuilder 
				name: ('A' , UUID new asString36) asSymbol;
				package: package2 name].
	
	package1 mcWorkingCopy modified: false.
	package2 mcWorkingCopy modified: false.
	
	classToRemove removeFromSystem.
	classToRemove := nil.
	
	self assert: package1 mcWorkingCopy modified not.
	self assert: package2 mcWorkingCopy modified.
	
	
	! !

!MCPackageManagerTest methodsFor: 'tests' stamp: ''!
testClassAdded

	self assert: package1 mcWorkingCopy modified not.
	self assert: package2 mcWorkingCopy modified not.
	
	classToRemove := self class classInstaller make: [ :aBuilder | 
			aBuilder 
				name: ('A' , UUID new asString36) asSymbol;
				package: package2 name].
	
	self assert: package1 mcWorkingCopy modified not.
	self assert: package2 mcWorkingCopy modified
	
! !

!MCPackageManagerTest methodsFor: 'running' stamp: ''!
tearDown
	
	classToRemove ifNotNil: [ classToRemove removeFromSystem ].
	
	package1 unregister.
	package2 unregister.
	MCPackageManager registry
		removeKey: mcPackage1 ifAbsent: [ ];
		removeKey: mcPackage2 ifAbsent: [ ].
	super tearDown	! !

!MCPackageManagerTest methodsFor: 'tests' stamp: ''!
testManagersForCategoryDo
	"Consider the following package structure:
		Renraku
		Renraku-Help

		and a method extension with the protocol '*renraku'.
		MCPackageManager>>methodModified: should only mark 'Renraku' as modified,
		not 'Renraku-Help'"

	| managers |
	self assert: (MCPackageManager registry includesKey: mcPackage1).
	self assert: (MCPackageManager registry includesKey: mcPackage2).

	managers := OrderedCollection new.
	MCPackageManager managersForCategory: mcPackage1 name do: [ :manager | managers add: manager ].

	self assert: managers size equals: 1.
	self assert: managers first package identicalTo: mcPackage1.

	managers := OrderedCollection new.
	MCPackageManager managersForCategory: mcPackage2 name do: [ :manager | managers add: manager ].

	self assert: managers size equals: 1.
	self assert: managers first package identicalTo: mcPackage2! !

!MCPackageManagerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	package1 := (RPackage named: #A, UUID new asString36) register.
	package2 := (RPackage named: package1 name, #'-SubPart') register.
	mcPackage1 := MCPackage named: package1 name.
	mcPackage2 := MCPackage named: package2 name.
	"register MC packages"
	MCPackageManager
		forPackage: mcPackage1;
		forPackage: mcPackage2! !

!MCPackageModified commentStamp: ''!
An MCPackageModified is raised when a MCPackage is modified!
!MCPackageModified methodsFor: 'accessing' stamp: 'nil'!
package: anObject
	
		package := anObject! !

!MCPackageModified methodsFor: 'accessing' stamp: 'nil'!
package

		^ package! !

!MCPackageModified methodsFor: '*Calypso-SystemPlugins-Monticello-Queries' stamp: ''!
affectsPackages
	 
	^true! !

!MCPackageModified class methodsFor: 'instance creation' stamp: 'nil'!
package: aMCPackage

	^ self new package: aMCPackage! !

!MCPackageTest methodsFor: 'running' stamp: ''!
tearDown
	self mockSnapshot install.
	MCDataStream initialize. "MCMockClassG ends up in the DataStream TypeMap -- we need to reset"
	super tearDown! !

!MCPackageTest methodsFor: 'private' stamp: ''!
aMethodRemoved: anEvent
	"Force cleaning of the protocol."

	(anEvent protocol = self mockExtensionMethodCategory and: [ anEvent methodClass == MCSnapshotTest ])
		ifTrue: [ anEvent methodClass organization removeProtocolIfEmpty: self mockExtensionMethodCategory ]! !

!MCPackageTest methodsFor: 'tests' stamp: ''!
testUnload
	| mock |
	self mockPackage unload.
	self deny: (testingEnvironment hasClassNamed: #MCMockClassA).
	self deny: (MCSnapshotTest includesSelector: #mockClassExtension).
	self deny: (MCSnapshotTest  organization protocolNamed: self mockExtensionMethodCategory) notNil.
	mock := testingEnvironment at: #MCMock.
	self assert: (mock subclasses detect: [ :c | c name = #MCMockClassA ] ifNone: [  ]) isNil! !

!MCPackageTest methodsFor: 'tests' stamp: ''!
testUnloadWithAdditionalTracking
	"This is to test against another entity removing the extension protocol as well."

	| mock |
	SystemAnnouncer uniqueInstance when: MethodRemoved send: #aMethodRemoved: to: self.
	self assert: (SystemAnnouncer uniqueInstance hasSubscriber: self ).
	self mockPackage unload.
	self deny: (testingEnvironment hasClassNamed: #MCMockClassA).
	self deny: (MCSnapshotTest includesSelector: #mockClassExtension).
	self deny: (MCSnapshotTest  organization protocolNamed: self mockExtensionMethodCategory) notNil.
	mock := testingEnvironment at: #MCMock.
	self assert: (mock subclasses detect: [ :c | c name = #MCMockClassA ] ifNone: [  ]) isNil.
	SystemAnnouncer uniqueInstance unsubscribe: self.
	self deny: (SystemAnnouncer uniqueInstance hasSubscriber: self ).
! !

!MCPatch commentStamp: ''!
I represent a set of patch operations which can be applied by sending message applyTo: to my instances. !
!MCPatch methodsFor: 'accessing' stamp: 'nil'!
hasConflict
	^ self operations anySatisfy: [ :change| change isConflict ]! !

!MCPatch methodsFor: 'querying' stamp: 'nil'!
isEmpty
	^ operations isEmpty! !

!MCPatch methodsFor: 'intializing' stamp: 'nil'!
initializeWithOperations: aCollection
	operations := aCollection! !

!MCPatch methodsFor: 'accessing' stamp: 'nil'!
operations
	^ operations! !

!MCPatch methodsFor: '*MonticelloGUI' stamp: ''!
browse

	^ (MCPatchBrowser forPatch: self) show! !

!MCPatch methodsFor: 'intializing' stamp: 'nil'!
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: 'applying' stamp: 'nil'!
applyTo: anObject
	operations do: [:ea | ea applyTo: anObject].
! !

!MCPatch class methodsFor: 'instance creation' stamp: 'nil'!
operations: aCollection
	^ self basicNew initializeWithOperations: aCollection! !

!MCPatch class methodsFor: 'instance creation' stamp: 'nil'!
fromBase: baseSnapshot target: targetSnapshot
	^ self new initializeWithBase: baseSnapshot target: targetSnapshot! !

!MCPatchBrowser commentStamp: ''!
The Monticello patch browser!
!MCPatchBrowser methodsFor: 'text' stamp: ''!
text
	^ selection ifNil: [''] ifNotNil: [selection source]! !

!MCPatchBrowser methodsFor: 'accessing' stamp: ''!
patch: aPatch
	items := aPatch operations asSortedCollection! !

!MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: ''!
selectedMessageName
	| definition |
	selection ifNil: [ ^nil ].
	(definition := selection definition) ifNil: [ ^nil ].
	definition isMethodDefinition ifFalse: [ ^nil ].
	^definition  selector! !

!MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: ''!
selectedClass
	| definition |
	selection ifNil: [ ^ nil ].
	(definition := selection definition) ifNil: [ ^ nil ].
	definition isMethodDefinition
		ifFalse: [ ^ nil ].
	^ Smalltalk globals at: definition className ifAbsent: [  ]! !

!MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: ''!
selectedClassOrMetaClass
	| definition |
	selection ifNil: [ ^nil ].
	(definition := selection definition) ifNil: [ ^nil ].
	definition isMethodDefinition ifFalse: [ ^nil ].
	^definition actualClass! !

!MCPatchBrowser methodsFor: 'text' stamp: ''!
text: aTextOrString
	self changed: #text! !

!MCPatchBrowser methodsFor: 'selecting' stamp: ''!
selection
	^ selection 
		ifNil: [0]
		ifNotNil: [self items indexOf: selection]! !

!MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: ''!
selectedMessageCategoryName
	| definition |
	selection ifNil: [ ^nil ].
	(definition := selection definition) ifNil: [ ^nil ].
	definition isMethodDefinition ifFalse: [ ^nil ].
	^definition category! !

!MCPatchBrowser methodsFor: 'morphic ui' stamp: ''!
buttonSpecs
	^ #((Invert invert 'Show the reverse set of changes')
		 (Export export 'Export the changes as a change set'))! !

!MCPatchBrowser methodsFor: 'morphic ui' stamp: ''!
widgetSpecs
	 ^#(
		((listMorph:selection:menu:keystroke: list selection methodListMenu: methodListKey:from:) (0 0 1 0.4) (0 0 0 0))
		((textMorph: text) (0 0.4 1 1))
		) 

	! !

!MCPatchBrowser methodsFor: 'actions' stamp: ''!
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 = '<working' ]) ifTrue: [ ^tokens first, '-to-working' ].
	tokens size = 2 ifFalse: [ ^'InstalledPatches' ].
	^'{1}-to-{2}' format: tokens ! !

!MCPatchBrowser methodsFor: '*Tool-Diff' stamp: ''!
methodListMenu: aMenu

	selection 
		ifNotNil: [ 
			aMenu addList: #(
				('Install'	 installSelection)
				('Diff'	diffSelection)
				('Revert'	 revertSelection)
				-)].
	super methodListMenu: aMenu.
	^ aMenu
! !

!MCPatchBrowser methodsFor: 'actions' stamp: ''!
revertSelection
	| loader |
	selection ifNotNil:
		[loader := MCPackageLoader new.
		selection inverse applyTo: loader.
		loader loadWithName: self changeSetNameForInstall ]! !

!MCPatchBrowser methodsFor: 'selecting' stamp: ''!
invert
	items := items collect: [:ea | ea inverse].
	self changed: #list; changed: #text; changed: #selection! !

!MCPatchBrowser methodsFor: 'accessing' stamp: ''!
items
	^ items! !

!MCPatchBrowser methodsFor: '*Tool-Diff' stamp: ''!
diffSelection
	"Open a diff browser on the selection."
	
	selection ifNotNil:
		[selection diff]! !

!MCPatchBrowser methodsFor: 'actions' stamp: ''!
installSelection
	| loader |
	selection ifNotNil:
		[loader := MCPackageLoader new.
		selection applyTo: loader.
		loader loadWithName: self changeSetNameForInstall ]! !

!MCPatchBrowser methodsFor: 'selecting' stamp: ''!
selection: aNumber
	selection := aNumber = 0 ifFalse: [self items at: aNumber].
	self changed: #selection; changed: #text.! !

!MCPatchBrowser methodsFor: 'accessing' stamp: ''!
list
	^ self items collect: [:ea | ea summary]! !

!MCPatchBrowser methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^ 'Patch Browser'! !

!MCPatchBrowser class methodsFor: 'instance creation' stamp: ''!
forPatch: aPatch
	^ self new patch: aPatch! !

!MCPatchOperation commentStamp: ''!
I'm an abstract class that represent an single delta element between two packages: removal, addition or modification.!
!MCPatchOperation methodsFor: '*Tool-Diff' stamp: ''!
shortSummary
	"Answer a short summary of the receiver."

	^self shortSummaryPrefix , self shortSummarySuffix! !

!MCPatchOperation methodsFor: '*MonticelloGUI' stamp: ''!
sourceText
	^ self isClassPatch 
		ifTrue: [(TextDiffBuilder from: self fromSource to: self toSource) buildDisplayPatch]
		ifFalse: [TextDiffBuilder buildDisplayPatchFrom:  self fromSource to: self toSource inClass: self targetClass]
! !

!MCPatchOperation methodsFor: '*Iceberg-Changes' stamp: ''!
asIceOperationOn: aNode diff: anIceDiff
	
	^ MCAddition of: aNode! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
localDefinition
	^ self baseDefinition! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
chooseLocal
	isApplicable := false! !

!MCPatchOperation methodsFor: '*Iceberg-Changes' stamp: ''!
myVersionOn: aDiff
	
	self subclassResponsibility! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
isRemoteNewer
	^ self localDefinition fullTimeStamp < self remoteDefinition fullTimeStamp! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
isLocalNewer
	^ self localDefinition fullTimeStamp > self remoteDefinition fullTimeStamp! !

!MCPatchOperation methodsFor: '*MonticelloGUI' stamp: ''!
source
	"I am call on the changes/merge tools of Monticello if you disable the 'Use Polymorph difference tool' on your setting."

	^ self localChosen
		ifTrue: [ self fromSource ]
		ifFalse: [ self sourceText ]! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
remoteChosen
	^ isApplicable ~~ false! !

!MCPatchOperation methodsFor: '*MonticelloGUI' stamp: ''!
summary
	| attribute |
	attribute := 
		self isResolved
			ifTrue: [self remoteChosen ifTrue: [#underlined] ifFalse: [#struckOut]]
			ifFalse: [#bold].
	^ Text string:( self definition summary, self summarySuffix) attribute: (TextEmphasis perform: attribute)! !

!MCPatchOperation methodsFor: '*Iceberg-Changes' stamp: ''!
theirVersionOn: aDiff 
	
	self subclassResponsibility! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
chooseRemote
	isApplicable := true! !

!MCPatchOperation methodsFor: '*Iceberg-TipUI' stamp: ''!
canBeBrowsed
	^ true! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
printAnnotations: requests on: aStream
	"Add a string for an annotation pane, trying to fulfill the CodeHolder annotationRequests"

	self definition printAnnotations: requests on: aStream.! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
status
	^ self isResolved
		ifFalse: ['']
		ifTrue: [self remoteChosen
					ifFalse: ['L']
					ifTrue: ['R']]! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
beNonConflict
	isConflict := false.
	isApplicable := true.! !

!MCPatchOperation methodsFor: '*Tool-Diff' stamp: ''!
diff
	"Open a diff browser on the changes."
! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
chooseNewer
	self isLocalNewer 
		ifTrue: [ self chooseLocal ]
		ifFalse: [ self isRemoteNewer ifTrue: [ self chooseRemote ]]! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
remoteDefinition
	^ self targetDefinition! !

!MCPatchOperation methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	self beNonConflict! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
isResolved
	^ isConflict and: [ isApplicable notNil ]! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
localChosen
	^ isApplicable == false
! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
isModification
	^ false! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
beConflict
	isConflict := true.
	isApplicable := nil. "not resolved"! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
operation
	"for compatibility with MCConflict interface"
	^ self! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
summarySuffix
	^ ''! !

!MCPatchOperation methodsFor: '*Tool-Diff' stamp: ''!
patchWrapper
	"Answer a wrapper for a patch tree for the receiver."

	^PSMCPatchOperationWrapper with: self! !

!MCPatchOperation methodsFor: '*Tool-Diff' stamp: ''!
shortSummaryPrefix
	"Answer a short summary prefix of the receiver."

	^ self definition summary! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
prefixForOperation: aSymbol
	aSymbol == #insert ifTrue: [^ '+'].
	aSymbol == #remove ifTrue: [^ '-'].
	^ ' '! !

!MCPatchOperation methodsFor: '*Tool-Diff' stamp: ''!
targetClassName
	"Answer the full class *name* of the target since the class may no longer exist."
	
	^self definition fullClassName! !

!MCPatchOperation methodsFor: '*Tool-Diff' stamp: ''!
shortSummarySuffix
	"Answer a short summary suffix of the receiver."

	^self fromSource = self toSource
		ifTrue: [' (revision changed)']
		ifFalse: ['']! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
targetClass
	self subclassResponsibility.! !

!MCPatchOperation methodsFor: '*Tool-Diff' stamp: ''!
diffToSource
	"Answer toSource of the operation for a diff tool."
	
	^self toSource! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
isRemoval
	^ false! !

!MCPatchOperation methodsFor: '*Tool-Diff' stamp: ''!
diffFromSource
	"Answer fromSource of the operation for a diff tool."
	
	^self fromSource! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
definition
	^ self subclassResponsibility ! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
inverse
	self subclassResponsibility! !

!MCPatchOperation methodsFor: 'applying operation' stamp: 'nil'!
applyTo: anObject

	(self isConflict and: [self isResolved not] ) ifTrue: [
		self error: 'Cannot continue until this conflict has been resolved' ].
	
	self remoteChosen ifTrue: [ self basicApplyTo: anObject ].! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
chooseOlder
	self isRemoteNewer 
		ifTrue: [ self chooseLocal ]
		ifFalse: [ self isLocalNewer ifTrue: [ self chooseRemote ]]! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
isAddition
	^ false! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
isConflict
	^ isConflict == true! !

!MCPatchOperation methodsFor: 'testing' stamp: 'nil'!
isClassPatch
	^false! !

!MCPatchOperation methodsFor: 'comparing' stamp: 'nil'!
<= other
	^ self definition <= other definition! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nil'!
clearChoice
	isApplicable := nil! !

!MCPatchTest methodsFor: 'running' stamp: ''!
tearDown
	self restoreMocks.
	super tearDown! !

!MCPatchTest methodsFor: 'tests' stamp: ''!
testPatchContents
	self assert: patch operations size equals: 1.
	self assert: patch operations first isModification.
	self assert: patch operations first definition selector equals: #one! !

!MCPatchTest methodsFor: 'running' stamp: ''!
setUp
	|rev1 rev2|
	super setUp.
	rev1 :=  MCSnapshotResource takeSnapshot.
	self change: #one toReturn: 2.
	rev2 :=  MCSnapshotResource takeSnapshot.
	patch := rev2 patchRelativeToBase: rev1.
	self change: #one toReturn: 1.! !

!MCPatcher commentStamp: ''!
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: 'adding' stamp: 'nil'!
addDefinition: aDefinition
	definitions add: aDefinition! !

!MCPatcher methodsFor: 'initialization' stamp: 'nil'!
initializeWithSnapshot: aSnapshot
	definitions := MCDefinitionIndex definitions: aSnapshot definitions! !

!MCPatcher methodsFor: 'operations' stamp: 'nil'!
modifyDefinition: baseDefinition to: targetDefinition
	self addDefinition: targetDefinition! !

!MCPatcher methodsFor: 'accessing' stamp: 'nil'!
patchedSnapshot
	^ MCSnapshot fromDefinitions: definitions definitions! !

!MCPatcher methodsFor: '*Iceberg' stamp: ''!
definitions
	^ definitions! !

!MCPatcher methodsFor: 'operations' stamp: 'nil'!
removeDefinition: aDefinition
	definitions remove: aDefinition! !

!MCPatcher class methodsFor: 'instance creation' stamp: 'nil'!
snapshot: aSnapshot
	^ self new initializeWithSnapshot: aSnapshot! !

!MCPatcher class methodsFor: 'public' stamp: 'nil'!
apply: aPatch to: aSnapshot
	| loader |
	loader := self snapshot: aSnapshot.
	aPatch applyTo: loader.
	^ loader patchedSnapshot! !

!MCPermissionDenied commentStamp: ''!
I am signalled when a repositroy cannot save or access a version.!
!MCPermissionDenied methodsFor: 'accessing' stamp: ''!
repository
	^ repository! !

!MCPermissionDenied methodsFor: 'accessing' stamp: ''!
repository: anObject
	repository := anObject! !

!MCPermissionDenied class methodsFor: 'signalling' stamp: ''!
signalFor: aRepository
	^ self new
		repository: aRepository;
		signal! !

!MCPoolImportDefinition commentStamp: ''!
A MCPoolImportDefinition represents a pool definition.!
!MCPoolImportDefinition methodsFor: 'testing' stamp: 'nil'!
isPoolImport
	^ true! !

!MCPoolImportDefinition methodsFor: 'testing' stamp: 'nil'!
isOrderDependend
	^false! !

!MCPoolImportDefinition class methodsFor: 'accessing' stamp: 'nil'!
type
	^ #pool! !

!MCPostscriptDefinition commentStamp: ''!
A postscript evaluated after load!
!MCPostscriptDefinition methodsFor: '*Iceberg-Changes' stamp: ''!
addToPackageChangeSet: anIcePackageChangeSet 
	"By doing nothing, this definition will not be shown in the changes tree."! !

!MCPostscriptDefinition methodsFor: 'installing' stamp: 'nil'!
postload
	self evaluate! !

!MCPostscriptDefinition methodsFor: 'accessing' stamp: 'nil'!
sortKey
	^ 'zzz' "force to the end so it gets loaded late"! !

!MCPostscriptDefinition class methodsFor: 'accessing' stamp: 'nil'!
scriptSelector
	^ #postscript! !

!MCPreambleDefinition commentStamp: ''!
A preamble evaluated before load!
!MCPreambleDefinition methodsFor: 'installing' stamp: 'nil'!
load
	super load.
	self evaluate! !

!MCPreambleDefinition class methodsFor: 'accessing' stamp: 'nil'!
scriptSelector
	^ #preamble! !

!MCReader commentStamp: ''!
Common superclass for Monticello readers!
!MCReader methodsFor: 'accessing' stamp: 'nil'!
stream: aStream
	stream := aStream! !

!MCReader methodsFor: 'accessing' stamp: 'nil'!
stream
	stream closed ifTrue: [ stream open ].
	^ stream
	! !

!MCReader class methodsFor: 'testing' stamp: 'nil'!
concreteSubclasses
	^ self allSubclasses reject: [:c | c isAbstract]! !

!MCReader class methodsFor: 'testing' stamp: 'nil'!
readerClassForFileNamed: fileName
	^ self concreteSubclasses
		detect: [:c | c canReadFileNamed: fileName]
		ifNone: [nil]! !

!MCReader class methodsFor: 'instance creation' stamp: 'nil'!
on: aStream name: aFileName
	| class |
	class := self readerClassForFileNamed: aFileName.
	^ class
		ifNil: [self error: 'Unsupported format: ', aFileName]
		ifNotNil: [class on: aStream]! !

!MCReader class methodsFor: 'instance creation' stamp: 'nil'!
on: aStream
	^ self new stream: aStream! !

!MCReader class methodsFor: 'testing' stamp: 'nil'!
canReadFileNamed: fileName
	| ext |
	ext := (self extension beginsWith: '.')
		ifTrue: [ self extension ]
		ifFalse: [ '.', self extension ].
	^ (fileName endsWith: ext)	! !

!MCReader class methodsFor: 'testing' stamp: 'nil'!
isAbstract
	^ (self respondsTo: #extension) not! !

!MCReleaseTest methodsFor: 'tests' stamp: ''!
testMonticelloInitializersAreEnabledByDefault

	"Monticello should by default have this option enabled.
	If this is not the case, the image cannot be released, as it will break users that expect class initializations to be run automatically"

	self assert: MCMethodDefinition initializersEnabled.! !

!MCRemoval commentStamp: ''!
A MCRemoval represents the removal of an entity of a given snapshot.!
!MCRemoval methodsFor: 'accessing' stamp: 'nil'!
basicApplyTo: anObject
	anObject removeDefinition: definition! !

!MCRemoval methodsFor: 'accessing' stamp: 'nil'!
summarySuffix
	^ ' (removed)'! !

!MCRemoval methodsFor: 'accessing' stamp: 'nil'!
baseDefinition
	^ definition! !

!MCRemoval methodsFor: 'initializing' stamp: 'nil'!
intializeWithDefinition: aDefinition
	definition := aDefinition! !

!MCRemoval methodsFor: '*Iceberg-Changes' stamp: ''!
myVersionOn: aDiff

	^ nil! !

!MCRemoval methodsFor: 'accessing' stamp: 'nil'!
targetDefinition
	^ nil! !

!MCRemoval methodsFor: 'accessing' stamp: 'nil'!
targetClass
	^ definition actualClass! !

!MCRemoval methodsFor: '*Iceberg-Changes' stamp: ''!
theirVersionOn: aDiff

	^ aDiff versionFromDefinition: definition! !

!MCRemoval methodsFor: 'testing' stamp: 'nil'!
isRemoval
	^ true! !

!MCRemoval methodsFor: '*Iceberg-TipUI' stamp: ''!
icon
	^ self iconNamed: #changeRemove! !

!MCRemoval methodsFor: 'accessing' stamp: 'nil'!
toSource
	^ ''! !

!MCRemoval methodsFor: '*Iceberg-TipUI' stamp: ''!
canBeBrowsed
	^ false! !

!MCRemoval methodsFor: 'accessing' stamp: 'nil'!
definition
	^ definition! !

!MCRemoval methodsFor: 'accessing' stamp: 'nil'!
fromSource
	^ definition diffSource! !

!MCRemoval methodsFor: 'accessing' stamp: 'nil'!
inverse
	^ MCAddition of: definition! !

!MCRemoval methodsFor: 'testing' stamp: 'nil'!
isClassPatch
	^definition isClassDefinition! !

!MCRemoval class methodsFor: 'instance creation' stamp: 'nil'!
of: aDefinition
	^ self new intializeWithDefinition: aDefinition! !

!MCRemovalPostscriptDefinition commentStamp: ''!
A postscript evaluated after unloading/removing!
!MCRemovalPostscriptDefinition methodsFor: 'installing' stamp: 'nil'!
unload
	super unload.
	self evaluate! !

!MCRemovalPostscriptDefinition class methodsFor: 'accessing' stamp: 'nil'!
scriptSelector
	^ #postscriptOfRemoval ! !

!MCRemovalPreambleDefinition commentStamp: ''!
A preamble evaluated before unloading/removing!
!MCRemovalPreambleDefinition methodsFor: 'installing' stamp: 'nil'!
unload
	super unload.
	self evaluate! !

!MCRemovalPreambleDefinition methodsFor: 'accessing' stamp: 'nil'!
sortKey
	^ 'zzz' "force to the end so it gets unloaded early"! !

!MCRemovalPreambleDefinition class methodsFor: 'accessing' stamp: 'nil'!
scriptSelector
	^ #preambleOfRemoval! !

!MCRepository commentStamp: ''!
A Metacello repository!
!MCRepository methodsFor: 'adding' stamp: 'nil'!
addTo: aRepository
	^ aRepository addBasicRepository: self! !

!MCRepository methodsFor: 'comparing' stamp: 'nil'!
= other
	^ other species = self species and: [other description = self description]! !

!MCRepository methodsFor: 'interface' stamp: 'nil'!
versionWithInfo: aVersionInfo
	^ self versionWithInfo: aVersionInfo ifAbsent: [nil]! !

!MCRepository methodsFor: 'comparing' stamp: 'nil'!
hash
	^ self description hash! !

!MCRepository methodsFor: 'interface' stamp: 'nil'!
includesVersionNamed: aString
	self subclassResponsibility! !

!MCRepository methodsFor: '*Metacello-Core' stamp: ''!
repositoryVersionString
  "extract a version string from the repository ... if possible"

  ^ ''! !

!MCRepository methodsFor: '*Iceberg-Adapters' stamp: ''!
commitIdFor: aMCWorkingCopy ifFound: aBlockClosure 
	"Do nothing. By default MCRepositories can not provide a commitId for you."! !

!MCRepository methodsFor: '*Metacello-MC' stamp: ''!
projectVersion: aString
    "noop"! !

!MCRepository methodsFor: 'accessing' stamp: 'nil'!
description
	^ self class name! !

!MCRepository methodsFor: 'printing' stamp: 'nil'!
displayStringOn: aStream
	aStream nextPutAll: self description! !

!MCRepository methodsFor: 'accessing' stamp: 'nil'!
possiblyNewerVersionsOfAnyOf: someVersions
	^#()! !

!MCRepository methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self description;
		nextPut: $).! !

!MCRepository methodsFor: '*MonticelloFileTree-Core' stamp: ''!
retrieveVersionsWithPackageNames: packageNames
    ^ self readableFileNames
        collect: [ :each | 
            | name |
            name := (each copyUpToLast: $.) copyUpTo: $(.
            name last isDigit
                ifFalse: [ 
                    Array
                        with: name
                        with: ''
                        with: ''
                        with: each ]
                ifTrue: [ 
                    Array
                        with: (packageNames add: (name copyUpToLast: $-))
                        with: ((name copyAfterLast: $-) copyUpTo: $.)
                        with: ((name copyAfterLast: $-) copyAfter: $.) asInteger
                        with: each	"pkg name"	"user"	"version" ] ]! !

!MCRepository methodsFor: '*Metacello-MC' stamp: ''!
metacelloProjectClassFor: aScriptEngine
    ^ MetacelloMCProject! !

!MCRepository methodsFor: '*Gofer-Core' stamp: ''!
goferReferences
	^ #()! !

!MCRepository methodsFor: '*Metacello-MC' stamp: ''!
asRepositorySpecFor: aMetacelloMCProject

	self subclassResponsibility! !

!MCRepository methodsFor: '*MonticelloGUI' stamp: ''!
openAndEditTemplateCopy
	^ self class fillInTheBlankConfigure: (self asCreationTemplate ifNil: [^nil])! !

!MCRepository methodsFor: '*Metacello-Core' stamp: ''!
repositoryDescription
  "return a description that includes a repositoryVersionString and repositoryBranchName if present"

  ^ self description! !

!MCRepository methodsFor: 'converting' stamp: 'nil'!
asCreationTemplate
	^ self creationTemplate! !

!MCRepository methodsFor: '*Gofer-Core' stamp: ''!
goferPriority
	^ 0! !

!MCRepository methodsFor: 'error handling' stamp: 'nil'!
error: aString 
	^ MCRepositoryError new signal: aString! !

!MCRepository methodsFor: '*MonticelloGUI' stamp: ''!
morphicOpen: aWorkingCopy
	self subclassResponsibility ! !

!MCRepository methodsFor: 'storing' stamp: 'nil'!
basicStoreVersion: aVersion
	self subclassResponsibility! !

!MCRepository methodsFor: 'storing' stamp: 'nil'!
storeDependencies: aVersion
	MCCacheRepository uniqueInstance cacheAllFileNamesDuring: 
		[self cacheAllFileNamesDuring: 
			[aVersion allAvailableDependenciesDo:
				[:dep |
					(self includesVersionNamed: dep info name)
						ifFalse: [self storeVersion: dep]]]]! !

!MCRepository methodsFor: '*MonticelloGUI' stamp: ''!
morphicOpen
	self morphicOpen: nil! !

!MCRepository methodsFor: 'storing' stamp: 'nil'!
storeVersion: aVersion
	self basicStoreVersion: aVersion.
	SystemAnnouncer uniqueInstance
		announce: (MCVersionSaved version: aVersion repository: self)! !

!MCRepository methodsFor: 'interface' stamp: 'nil'!
versionWithInfo: aVersionInfo ifAbsent: aBlock
	self subclassResponsibility ! !

!MCRepository methodsFor: 'accessing' stamp: 'nil'!
versionFrom: aVersionReferenceString
	self error: 'Unable to load from ' , self printString! !

!MCRepository methodsFor: '*Metacello-Core' stamp: ''!
flushForScriptGet
    "noop"! !

!MCRepository methodsFor: '*Metacello-Core' stamp: ''!
repositoryBranchName
  "extract a branch name from the repository ... if possible"

  ^ ''! !

!MCRepository methodsFor: 'testing' stamp: 'nil'!
isValid
	^true! !

!MCRepository methodsFor: 'accessing' stamp: 'nil'!
creationTemplate
	^ creationTemplate! !

!MCRepository methodsFor: 'accessing' stamp: 'nil'!
closestAncestorVersionFor: anAncestry ifNone: errorBlock
	anAncestry breadthFirstAncestorsDo:
		[:ancestorInfo |
		(self versionWithInfo: ancestorInfo) ifNotNil: [:v | ^ v]].
	^ errorBlock value! !

!MCRepository methodsFor: 'accessing' stamp: 'nil'!
creationTemplate: aString
	self creationTemplate ifNotNil: [ self error: 'Creation template already set for this MCRepository instance.' ].
	
	creationTemplate := aString.! !

!MCRepository class methodsFor: 'request handling' stamp: 'nil'!
fillInTheBlankRequest
	self subclassResponsibility.! !

!MCRepository class methodsFor: '*Metacello-Core' stamp: ''!
createRepositoryFromSpec: aRepositorySpec on: aPlatform
	self subclassResponsibility! !

!MCRepository class methodsFor: 'accessing' stamp: 'nil'!
description
	^ nil! !

!MCRepository class methodsFor: '*Metacello-Core' stamp: ''!
findFiletreeAlternateFormat: aRepositorySpec ifFound: aBlock
	| repositoryClass |
	repositoryClass := self allSubclasses detect: [ :each | each isFiletreeAlternateFormat: aRepositorySpec ] ifNone: [ nil ].
	
	^ repositoryClass ifNotNil: [ aBlock cull: repositoryClass ]! !

!MCRepository class methodsFor: '*MonticelloGUI' stamp: ''!
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: 'instance creation' stamp: 'nil'!
fromUrl: aUrlOrString 
	| url |
	url := aUrlOrString asUrl.

	^ self allSubclasses 
		detect: [ :each | 
			(each class includesSelector: #urlSchemes)
			and: [ each urlSchemes includes: url scheme ] ]
		ifFound: [ :repositoryClass | repositoryClass basicFromUrl: url ]
		ifNone: [ MCRepositoryError signal: 'Cannot instantiate a repository from the url: ', url asString ]! !

!MCRepository class methodsFor: 'testing' stamp: 'nil'!
isAbstract
	^ self description isNil! !

!MCRepository class methodsFor: '*Metacello-Core' stamp: ''!
newRepositoryFromSpec: aRepositorySpec on: aPlatform

	^ self allSubclasses
		detect: [ :each | each isAvailableFor: aRepositorySpec type ]
		ifFound: [ :repositoryClass | 
			repositoryClass
				createRepositoryFromSpec: aRepositorySpec
				on: aPlatform ]
		ifNone: [ self error: 'Unknown repository type: ' , aRepositorySpec description ]! !

!MCRepository class methodsFor: 'accessing' stamp: 'nil'!
urlSchemes
	"Returns the URL schemes used to describe this repository"
	^ #()! !

!MCRepository class methodsFor: '*Metacello-Core' stamp: ''!
isAvailableFor: type
	^ false! !

!MCRepository class methodsFor: 'accessing' stamp: 'nil'!
creationTemplate
	self subclassResponsibility.! !

!MCRepository class methodsFor: '*Metacello-Core' stamp: ''!
isFiletreeAlternateFormat: aRepositorySpec
	^ false! !

!MCRepository class methodsFor: 'accessing' stamp: 'nil'!
allConcreteSubclasses
	^ self withAllSubclasses reject: [:ea | ea isAbstract]! !

!MCRepository class methodsFor: 'instance creation' stamp: 'nil'!
morphicConfigure
	^ self new! !

!MCRepository class methodsFor: '*MonticelloGUI' stamp: ''!
fillInTheBlankConfigure
	^ self fillInTheBlankConfigure: self creationTemplate
			! !

!MCRepositoryAdded commentStamp: ''!
Announcement sent when a Repository is added to a Repository group.!
!MCRepositoryAdded methodsFor: 'accessing' stamp: 'nil'!
repository
	^ repository! !

!MCRepositoryAdded methodsFor: 'accessing' stamp: 'nil'!
repository: anObject
	repository := anObject! !

!MCRepositoryAuthorizationTest methodsFor: 'tests' stamp: ''!
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: ''!
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: ''!
testStoredCredentialsUsesMostSpecific

	| repo registry nestedRepo |
	[
		nestedRepo := self exampleServerUrl, '/ss3'.
		registry := MCServerRegistry uniqueInstance.
		registry on: self exampleServerUrl beUser: 'myusername' withPassword: 'mypassword'.
		registry on: nestedRepo beUser: 'myss3username' withPassword: 'myss3password'.
		
		repo := MCHttpRepository location: nestedRepo.
		
		self assert: repo user equals: 'myss3username'.
		self assert: repo password equals: 'myss3password'.
	] ensure: [
		registry
			removeCredentialsFor: self exampleServerUrl;
			removeCredentialsFor: nestedRepo ].! !

!MCRepositoryAuthorizationTest methodsFor: 'asserting' stamp: ''!
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: ''!
testNoCredentials

	| repo |
	repo := MCHttpRepository location: self exampleServerUrl.
	self assert: repo user equals: ''.
	self assert: repo password equals: ''.! !

!MCRepositoryAuthorizationTest methodsFor: 'tests' stamp: ''!
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: 'accessing' stamp: ''!
exampleServerUrl
	<sampleInstance>

	^ 'http://www.squeaksource.com'.! !

!MCRepositoryError commentStamp: ''!
I am an MC-specific errror!
!MCRepositoryGroup commentStamp: ''!
A singleton class, holds the list of repositories. Can look for a requested VersionInfo among its repositories.!
!MCRepositoryGroup methodsFor: 'adding' stamp: 'nil'!
addTo: aRepository
	^ aRepository addRepositoryGroup: self! !

!MCRepositoryGroup methodsFor: 'accessing' stamp: 'nil'!
disableCache
	useCache := false! !

!MCRepositoryGroup methodsFor: 'testing' stamp: 'nil'!
includes: aRepository
	^ self repositories includes: aRepository! !

!MCRepositoryGroup methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	repositories := OrderedCollection new! !

!MCRepositoryGroup methodsFor: 'interface' stamp: 'nil'!
includesVersionNamed: aString
	" check for existing version name in parallel over all repositories "
	| results |

	results := Array new: self repositories size.
	
	self repositories doWithIndex: [:repository :index | 
		" fork of test for each repository "
		results 
			at: index 
			put: (repository includesVersionNamed: aString) ].

	" check if any repository included the given versionName already"
	^ results anySatisfy: [:result| result = true ]	! !

!MCRepositoryGroup methodsFor: 'interface' stamp: 'nil'!
versionWithInfo: aVersionInfo
	^self versionWithInfo: aVersionInfo ifNone: [ self error: 'Could not find version ', aVersionInfo name printString,'. Maybe you need to add a repository?' ]! !

!MCRepositoryGroup methodsFor: 'adding' stamp: 'nil'!
addRepository: aRepository
	aRepository addTo: self.
	^ aRepository! !

!MCRepositoryGroup methodsFor: 'enumerating' stamp: 'nil'!
repositoriesDo: aBlock
	self repositories do: [:ea | [aBlock value: ea] on: Error do: []]! !

!MCRepositoryGroup methodsFor: 'adding' stamp: 'nil'!
addRepositoryGroup: aRepositoryGroup
	aRepositoryGroup repositoriesDo: [ :each | 
		each addTo: self ]! !

!MCRepositoryGroup methodsFor: 'accessing' stamp: 'nil'!
useCache
	^ useCache ifNil: [
		useCache := true
	]! !

!MCRepositoryGroup methodsFor: 'accessing' stamp: 'nil'!
removeRepository: aRepository
	repositories remove: aRepository ifAbsent: [ ^ self ].
	self announceRepositoryRemoved: aRepository! !

!MCRepositoryGroup methodsFor: '*metacello-testsmc' stamp: ''!
removeIdenticalRepository: aRepository
  1 to: repositories size do: [ :index | 
    (repositories at: index) == aRepository
      ifTrue: [ 
        repositories removeAt: index.
        ^ self ] ]! !

!MCRepositoryGroup methodsFor: 'accessing' stamp: 'nil'!
repositories
	^ (self useCache 
		ifTrue: [Array with: MCCacheRepository uniqueInstance] 
		ifFalse: [Array new]) , repositories select: #isValid! !

!MCRepositoryGroup methodsFor: 'accessing' stamp: 'nil'!
versionWithInfo: aVersionInfo ifNone: aBlock
	self repositoriesDo: [:ea | (ea versionWithInfo: aVersionInfo) ifNotNil: [:v | ^ v]].
	^aBlock value! !

!MCRepositoryGroup methodsFor: 'adding' stamp: 'nil'!
addBasicRepository: aRepository
	((repositories includes: aRepository) 
	or: [ aRepository == MCCacheRepository uniqueInstance ])
		ifFalse: [
			repositories add: aRepository.
			self announceRepositoryAdded: aRepository.
			self class default addRepository: aRepository ].
	^ aRepository! !

!MCRepositoryGroup methodsFor: 'private' stamp: 'nil'!
announceRepositoryRemoved: aRepository
	SystemAnnouncer uniqueInstance
		announce:
			(MCRepositoryRemoved new
				repository: aRepository;
				yourself)! !

!MCRepositoryGroup methodsFor: 'private' stamp: 'nil'!
announceRepositoryAdded: aRepository
	SystemAnnouncer uniqueInstance
		announce:
			(MCRepositoryAdded new
				repository: aRepository;
				yourself)! !

!MCRepositoryGroup class methodsFor: 'instance creation' stamp: 'nil'!
withRepositories: aCollection 
	| group |
	group  := self new.
	aCollection do: [ :each | group addRepository: each ].
	^ group 
		! !

!MCRepositoryGroup class methodsFor: 'accessing' stamp: 'nil'!
default
	^ default ifNil: [default := self new]! !

!MCRepositoryInspector commentStamp: ''!
Inspector for a repository!
!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionSelection
	^ versions indexOf: selectedVersion! !

!MCRepositoryInspector methodsFor: 'actions' stamp: ''!
load
	self hasVersion
		ifFalse: [ ^ self ].
	super load.
	self version workingCopy repositoryGroup addRepository: repository! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
sortedVersions
	| sorter |
	sorter := MCVersionSorter new.
	sorter addAllVersionInfos: versions.
	^ sorter sortedVersionInfos select: [:ea | versions includes: ea]! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageList
	^ packages collect: [:ea | ea name]! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
initialExtent
	^450@300! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageSelection: aNumber
	selectedPackage := aNumber isZero ifFalse: [ packages at: aNumber ].
	versions := repository versionsAvailableForPackage: selectedPackage.
	self changed: #packageSelection; changed: #versionList! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageListMenu: aMenu
	^aMenu! !

!MCRepositoryInspector methodsFor: 'actions' stamp: ''!
refresh
	packages := repository packages.
	self changed: #packageList.
	self packageSelection: self packageSelection.
! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionList
	^ self sortedVersions collect: [:ea | ea name]! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionSelection: aNumber
	selectedVersion := aNumber isZero
		ifTrue: [ nil ]
		ifFalse: [ versions at: aNumber ].
	self
		changed: #versionSelection;
		changed: #summary! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
versionListMenu: aMenu
	^aMenu! !

!MCRepositoryInspector methodsFor: 'accessing' stamp: ''!
summary
	^ selectedVersion
		ifNotNil: [selectedVersion summary]
		ifNil: ['']! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
widgetSpecs
	^#(	((buttonRow) (0 0 1 0) (0 0 0 30))
		((listMorph: package) (0 0 0.5 0.6) (0 30 0 0))
		((listMorph: version) (0.5 0 1 0.6) (0 30 0 0))
		((textMorph: summary) (0 0.6 1 1) (0 0 0 0)) )! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
buttonSpecs
	^#(('Refresh' refresh 'refresh the version-list')) , super buttonSpecs! !

!MCRepositoryInspector methodsFor: 'testing' stamp: ''!
hasVersion
	^ selectedVersion notNil! !

!MCRepositoryInspector methodsFor: 'accessing' stamp: ''!
version
	^ version ifNil: [version := repository versionWithInfo: selectedVersion]! !

!MCRepositoryInspector methodsFor: 'accessing' stamp: ''!
setRepository: aRepository workingCopy: aWorkingCopy
	repository := aRepository.
	aWorkingCopy ifNotNil: [ selectedPackage := aWorkingCopy package].
	self refresh! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
packageSelection
	^ packages indexOf: selectedPackage! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^'Repository: ' , repository description! !

!MCRepositoryInspector class methodsFor: 'instance creation' stamp: ''!
repository: aFileBasedRepository workingCopy: aWorkingCopy
	^self new
		setRepository: aFileBasedRepository workingCopy: aWorkingCopy;
		yourself! !

!MCRepositoryRemoved commentStamp: ''!
Announcement sent when a Repository is removed from  a Repository group.!
!MCRepositoryRemoved methodsFor: 'accessing' stamp: 'nil'!
repository
	^ repository! !

!MCRepositoryRemoved methodsFor: 'accessing' stamp: 'nil'!
repository: anObject
	repository := anObject! !

!MCRepositoryTest commentStamp: ''!
Abstract superclass for Repository tests!
!MCRepositoryTest methodsFor: 'accessing' stamp: ''!
snapshotAt: aVersionInfo
	^ (repository versionWithInfo: aVersionInfo) snapshot! !

!MCRepositoryTest methodsFor: 'asserting' stamp: ''!
assertMissing: aVersionInfo
	self assert: (repository versionWithInfo: aVersionInfo) isNil! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
testCanCreateHttpRepositoryFromUrl
	repository := MCRepository fromUrl: 'http://mydomain.com'.
	self assert: (repository isKindOf: MCHttpRepository) ! !

!MCRepositoryTest methodsFor: 'actions' stamp: ''!
addVersionWithSnapshot: aSnapshot name: aString
	| version |
	version := self versionWithSnapshot: aSnapshot name: aString.
	self addVersion: version.
	^ version info! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
testCannotCreateDictionaryRepositoryFromUrl
	self
		should: [ MCRepository fromUrl: 'dict://foo' ]
		raise: MCRepositoryError! !

!MCRepositoryTest methodsFor: 'tests - input data' stamp: ''!
homeDirectoryUrl
	^ FileLocator home asFileReference asZnUrl! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
testCanCreateFiletreeRepositoryFromUrl
	repository := MCRepository fromUrl: (self homeDirectoryUrl scheme: 'filetree') asString.
	self assert: (repository isKindOf: MCFileTreeRepository) ! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
testCanCreateGitHubRepositoryFromUrl
	repository := MCRepository fromUrl: 'github://dalehenrich/MetacelloRepository:master/monticello/repos/itory/path'.
	self assert: (repository isKindOf: MCGitHubRepository) ! !

!MCRepositoryTest methodsFor: 'building' stamp: ''!
snapshot2
	^ (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: #('x'))))! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
testCanCreateHttpsRepositoryFromUrl
	repository := MCRepository fromUrl: 'https://mydomain.com'.
	self assert: (repository isKindOf: MCHttpRepository) ! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
testCanCreateFtpRepositoryFromUrl
	repository := MCRepository fromUrl: 'ftp://ftp.example.com/examples'.
	self assert: (repository isKindOf: MCFtpRepository) ! !

!MCRepositoryTest methodsFor: 'building' stamp: ''!
versionWithSnapshot: aSnapshot name: aString
	| info |
	info := self mockVersionInfo: aString. 
	^ MCVersion 
		package: (MCPackage new name: aString)
		info: info
		snapshot: aSnapshot! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
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: ''!
testAddAndLoad
	| node |
	node := self addVersionWithSnapshot: self snapshot1 name: 'rev1'.
	self assert: (self snapshotAt: node) equals: self snapshot1! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
testCanCreateFileRepositoryFromUrl
	repository := MCRepository fromUrl: 'file:///tmp'.
	self assert: (repository isKindOf: MCFileBasedRepository) ! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
testCanCreateFiletreeRepositoryFromUrlWithRelativePath
	repository := MCRepository fromUrl: 'filetree://.' asUrl.
	self assert: (repository isKindOf: MCFileTreeRepository) ! !

!MCRepositoryTest methodsFor: 'actions' stamp: ''!
addVersion: aVersion
	self subclassResponsibility ! !

!MCRepositoryTest methodsFor: 'actions' stamp: ''!
saveSnapshot2
	^ self saveSnapshot: self snapshot2 named: 'rev2'! !

!MCRepositoryTest methodsFor: 'building' stamp: ''!
snapshot1
	^ (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: #('y'))))! !

!MCRepositoryTest methodsFor: 'actions' stamp: ''!
saveSnapshot1
	^ self saveSnapshot: self snapshot1 named: 'rev1'! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
testLoadMissingNode
	| node |
	node := MCVersionInfo new.
	self assertMissing: node! !

!MCRepositoryTest methodsFor: 'actions' stamp: ''!
saveSnapshot: aSnapshot named: aString
	| version |
	version := self versionWithSnapshot: aSnapshot name: aString.
	repository storeVersion: version.
	^ version info
	! !

!MCRepositoryTest methodsFor: 'tests' stamp: ''!
testStoreAndLoad
	| node node2 |
	node := self saveSnapshot1.
	node2 := self saveSnapshot2.
	self assert: (self snapshotAt: node) equals: self snapshot1.
	self assert: (self snapshotAt: node2) equals: self snapshot2! !

!MCRepositoryTest methodsFor: 'asserting' stamp: ''!
assertVersionInfos: aCollection
	self assert: repository allVersionInfos asSet equals: aCollection asSet! !

!MCRepositoryTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = MCRepositoryTest! !

!MCSaveVersionDialog commentStamp: ''!
Monticello's dialog that allows the user to change the version name and to enter a message for the commit log.!
!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: ''!
cancel
	self answer: nil! !

!MCSaveVersionDialog methodsFor: 'log message history' stamp: ''!
maxLogMessageHistory

	^ self maxLogMessageHistory! !

!MCSaveVersionDialog methodsFor: 'accessing' stamp: ''!
versionName
	^ name! !

!MCSaveVersionDialog methodsFor: 'log message history' stamp: ''!
addAsLastLogMessage: aString

	self class addAsLastLogMessage: aString! !

!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: ''!
initialExtent 
	^ 400@300! !

!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: ''!
setDefaultFocus
	(self findTextMorph: #logMessage)
		textArea selectAll;
		takeKeyboardFocus! !

!MCSaveVersionDialog methodsFor: 'accessing' stamp: ''!
versionName: aString
	name := aString.
	self changed: #versionName! !

!MCSaveVersionDialog methodsFor: 'accessing' stamp: ''!
logMessage: aString
	message := aString.
	self changed: #logMessage! !

!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: ''!
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: ''!
widgetSpecs
	^ #(	
		((textMorph: versionName) (0 0 1 0) (0 0 0 30))
		((textMorph: logMessage) (0 0 1 1) (0 30 0 -30))
		((buttonRow) (0 1 1 1) (0 -40 0 0))
		)! !

!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: ''!
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: ''!
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: ''!
textMorph: aMorph
	"here the text field is not used for code editing"
	^(super textMorph: aMorph) beForPlainText! !

!MCSaveVersionDialog methodsFor: 'log message history' stamp: ''!
previousMessages

	^ self class previousMessages! !

!MCSaveVersionDialog methodsFor: 'accessing' stamp: ''!
logMessage
	^ message ifNil: ['empty log message']! !

!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^ 'Edit Version Name and Log Message:'! !

!MCSaveVersionDialog class methodsFor: 'history' stamp: ''!
maxLogMessageHistory

	^ 15! !

!MCSaveVersionDialog class methodsFor: 'history' stamp: ''!
addAsLastLogMessage: aString

	((self previousMessages size > 0) and: [self previousMessages first = aString])
		ifTrue: [ ^ self ].
		
	self previousMessages addFirst: aString.
	(self previousMessages size > self maxLogMessageHistory)
		ifTrue: [self previousMessages removeLast]! !

!MCSaveVersionDialog class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallSaveAsIcon! !

!MCSaveVersionDialog class methodsFor: 'history' stamp: ''!
previousMessages

	^ PreviousMessages ifNil: [ PreviousMessages := OrderedCollection new]! !

!MCScanner commentStamp: ''!
I scan / tokenize metadata  (package name, version info, ancestry, dependencies, ...) found in .mcz files.

For example, try:

MCScanner scan:  '(name ''MyPackage-ll.6'' message ''Fix bug xxx'' id ''b21dbd73-f1c3-2746-a3cc-92f1d4edea28'')' readStream!
!MCScanner methodsFor: 'actions' stamp: 'nil'!
next
	"This would be slightly simpler using recursion but it risks a stack overflow 
	 for some packages on some platforms, so we implement it using a local stack."

	| stack |
	stack := Stack with: Stack new.
	[
		| c |
		stream skipSeparators.
		c := stream peek.
		"We essentially ignore the $# symbol and expect what follows to be a symbol or array"
		c = $# ifTrue: [ c := stream next; peek ].
		"Note that #'foo' will be treated as a String, not a Symbol"
		c = $' ifTrue: [ stack top push: self nextString ] ifFalse: [
		"Any alphanumeric, including an integer, is treated as a Symbol even if not preceeded by a $#"
		c isAlphaNumeric ifTrue: [ stack top push: self nextSymbol ] ifFalse: [
		"For an array, start a new level on the stack"
		c = $( ifTrue: [ stream next. stack push: Stack new ] ifFalse: [
		"At the end of an array, so add it to the previous level"
		c = $) ifTrue: [ | x | stream next. x := stack pop. stack top push: x asArray reverse ] ifFalse: [ 
		"Unexpected token"
		self error: 'Unknown token type' ]]]].
		"Keep looping while we are in an array"
		1 < stack size.
	] whileTrue: [].
	^stack top top! !

!MCScanner methodsFor: 'actions' stamp: 'nil'!
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: 'nil'!
nextString
	^ stream nextDelimited: $'! !

!MCScanner methodsFor: 'accessing' stamp: 'nil'!
stream: aStream
	stream := aStream! !

!MCScanner methodsFor: 'actions' stamp: 'nil'!
nextSymbol
	^ (String streamContents:
		[:s |
		[stream peek isAlphaNumeric] whileTrue: [s nextPut: stream next]]) asSymbol
			! !

!MCScanner class methodsFor: 'public api' stamp: 'nil'!
scanTokens: aString
	"compatibility"
	^ Array with: (self scan: aString readStream)! !

!MCScanner class methodsFor: 'public api' stamp: 'nil'!
scan: aStream
	^ (self new stream: aStream) next! !

!MCScannerTest methodsFor: 'tests' stamp: ''!
test4
	self assertScans: #(a '23' (x () ')''q' y12)).! !

!MCScannerTest methodsFor: 'tests' stamp: ''!
test6
	self should: [MCScanner scan: '(a b' readStream] raise: Error! !

!MCScannerTest methodsFor: 'asserting' stamp: ''!
assertScans: anArray
	self assert: (MCScanner scan: anArray printString readStream) equals: anArray! !

!MCScannerTest methodsFor: 'tests' stamp: ''!
test3
	self assert: (MCScanner scan: '(a #b c)' readStream) equals: #(a #b c)! !

!MCScannerTest methodsFor: 'tests' stamp: ''!
test5
	self assertScans: #((a) b)! !

!MCScannerTest methodsFor: 'tests' stamp: ''!
test1
	self assertScans: #(a '23' (x))! !

!MCScannerTest methodsFor: 'tests' stamp: ''!
test2
	self assertScans: 'it''s alive'! !

!MCScriptDefinition commentStamp: ''!
Common superclass for script definitions!
!MCScriptDefinition methodsFor: 'installing' stamp: 'nil'!
load
	self installScript! !

!MCScriptDefinition methodsFor: 'comparing' stamp: 'nil'!
= aDefinition
	^ (super = aDefinition)
		and: [script = aDefinition script]! !

!MCScriptDefinition methodsFor: 'accessing' stamp: 'nil'!
packageSet
	^ RPackageSet named: packageName! !

!MCScriptDefinition methodsFor: 'accessing' stamp: 'nil'!
description
	^ Array with: packageName with: self scriptSelector! !

!MCScriptDefinition methodsFor: 'installing' stamp: 'nil'!
unload
	self installScript: nil! !

!MCScriptDefinition methodsFor: 'accessing' stamp: 'nil'!
source
	^ script! !

!MCScriptDefinition methodsFor: 'accessing' stamp: 'nil'!
summary
	^ packageName, ' ', self scriptSelector! !

!MCScriptDefinition methodsFor: 'accessing' stamp: 'nil'!
script
	^ script! !

!MCScriptDefinition methodsFor: 'installing' stamp: 'nil'!
installScript
	self installScript: script! !

!MCScriptDefinition methodsFor: 'accessing' stamp: 'nil'!
packageName
	^ packageName! !

!MCScriptDefinition methodsFor: 'initializing' stamp: 'nil'!
initializeWithScript: aString packageName: packageString
	script := aString.
	packageName := packageString! !

!MCScriptDefinition methodsFor: 'testing' stamp: 'nil'!
isScriptDefinition
	^true! !

!MCScriptDefinition methodsFor: 'installing' stamp: 'nil'!
installScript: aString
	| sel pi |
	sel := (self scriptSelector, ':') asSymbol.
	pi := self packageSet.
	(pi respondsTo: sel)
		ifTrue: [pi perform: sel with: aString]! !

!MCScriptDefinition methodsFor: 'accessing' stamp: 'nil'!
scriptSelector
	^ self class scriptSelector! !

!MCScriptDefinition methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor
	aVisitor visitScriptDefinition: self! !

!MCScriptDefinition methodsFor: 'installing' stamp: 'nil'!
evaluate
	self class compiler evaluate: script! !

!MCScriptDefinition methodsFor: 'accessing' stamp: 'nil'!
sortKey
	^ '!!', self scriptSelector "force to the front so it gets loaded first"! !

!MCScriptDefinition class methodsFor: 'accessing' stamp: 'nil'!
subclassForScriptSelector: selectorString
	^self allSubclasses detect: [:ea | ea scriptSelector = selectorString]! !

!MCScriptDefinition class methodsFor: 'instance creation' stamp: 'nil'!
scriptSelector: selectorString script: aString packageName: packageString
	^ (self subclassForScriptSelector: selectorString)
		script: aString packageName: packageString! !

!MCScriptDefinition class methodsFor: 'instance creation' stamp: 'nil'!
script: aString packageName: packageString
	^ self new initializeWithScript: aString packageName: packageString! !

!MCScriptDefinition class methodsFor: 'instance creation' stamp: 'nil'!
from: aPackageInfo
	^ self script: (aPackageInfo perform: self scriptSelector) contents asString packageName: aPackageInfo name! !

!MCScriptDefinition class methodsFor: 'accessing' stamp: 'nil'!
scriptSelector
	self subclassResponsibility! !

!MCScriptParser commentStamp: ''!
A MCScriptParser identifies script and add MCScriptDefinition. !
!MCScriptParser methodsFor: 'actions' stamp: 'nil'!
addDefinitionsTo: aCollection
	| tokens definition |
	tokens := source parseLiterals.
	definition := MCScriptDefinition
		scriptSelector: tokens second allButLast
		script: tokens third
		packageName: tokens first third.
	aCollection add: definition.! !

!MCScriptParser class methodsFor: 'factory identification hook' stamp: 'nil'!
pattern
	^'(PackageInfo named: *'! !

!MCSerializationTest methodsFor: 'mocks' stamp: ''!
mockDiffyVersion
	| repos workingCopy base next |
	repos := MCDictionaryRepository new.
	workingCopy := MCWorkingCopy forPackage: self mockPackage.
	workingCopy repositoryGroup addRepository: repos.
	MCRepositoryGroup default removeRepository: repos.
	base := self mockVersion.
	repos storeVersion: base.
	self change: #a toReturn: 'a2'.
	next := self mockVersionWithAncestor: base.
	^ next asDiffAgainst: base	! !

!MCSerializationTest methodsFor: 'asserting' stamp: ''!
assertSnapshotsMatchWith: writerClass
	| readerClass expected stream actual |
	readerClass := writerClass readerClass.
	expected := self mockSnapshot.
	stream := ReadWriteStream on: ''.
	(writerClass on: stream) writeSnapshot: expected.
	actual := readerClass snapshotFromStream: stream reset.
	self assertSnapshot: actual matches: expected.! !

!MCSerializationTest methodsFor: 'asserting' stamp: ''!
assertExtensionProvidedBy: aClass
	aClass readerClass extension! !

!MCSerializationTest methodsFor: 'asserting' stamp: ''!
assertVersionsMatchWith: writerClass
	| stream readerClass expected actual |
	readerClass := writerClass readerClass.
	expected := self mockVersion.
	stream := ReadWriteStream on: ByteArray new.
	writerClass fileOut: expected on: stream.
	actual := readerClass versionFromStream: stream reset.
	self assertVersion: actual matches: expected.! !

!MCSerializationTest methodsFor: 'testing' stamp: ''!
testMcdSerialization
	| stream expected actual |
	expected := self mockDiffyVersion.
	stream := ReadWriteStream on: ByteArray new.
	MCMcdWriter fileOut: expected on: stream.
	actual := MCMcdReader versionFromStream: stream reset.
	self assertVersion: actual matches: expected.! !

!MCSerializationTest methodsFor: 'testing' stamp: ''!
testMczSerialization
	self assertVersionsMatchWith: MCMczWriter.
	self assertExtensionProvidedBy: MCMczWriter.
	self assertVersionInfosMatchWith: MCMczWriter.
	self assertDependenciesMatchWith: MCMczWriter.! !

!MCSerializationTest methodsFor: 'testing' stamp: ''!
testStSerialization
	self assertSnapshotsMatchWith: MCStWriter.! !

!MCSerializationTest methodsFor: 'asserting' stamp: ''!
assertDependenciesMatchWith: writerClass
	| stream readerClass expected actual |
	readerClass := writerClass readerClass.
	expected := self mockVersionWithDependencies.
	stream := ReadWriteStream on: ByteArray new.
	writerClass fileOut: expected on: stream.
	actual := (readerClass on: stream reset) dependencies.
	self assert: actual equals: expected dependencies.! !

!MCSerializationTest methodsFor: 'asserting' stamp: ''!
assertVersionInfosMatchWith: writerClass
	| stream readerClass expected actual |
	readerClass := writerClass readerClass.
	expected := self mockVersion.
	stream := ReadWriteStream on: ByteArray new.
	writerClass fileOut: expected on: stream.
	actual := readerClass versionInfoFromStream: stream reset.
	self assert: actual equals: expected info.! !

!MCServerCredentials commentStamp: ''!
I store a username and password.
!
!MCServerCredentials methodsFor: 'private' stamp: ''!
password: aString 

	password := aString.! !

!MCServerCredentials methodsFor: 'accessing' stamp: ''!
password

	^ password.! !

!MCServerCredentials methodsFor: 'private' stamp: ''!
username: aString 

	username := aString.! !

!MCServerCredentials methodsFor: 'accessing' stamp: ''!
username

	^ username.! !

!MCServerCredentials class methodsFor: 'instance creation' stamp: ''!
user: nameString password: passwordString

	^ self new
			username: nameString;
			password: passwordString;
			yourself.! !

!MCServerRegistry commentStamp: ''!
Registry for metacello servers!
!MCServerRegistry methodsFor: '*Monticello-Tests' stamp: ''!
removeCredentialsFor: aString 

	registry removeKey: aString.! !

!MCServerRegistry methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	registry := Dictionary new.! !

!MCServerRegistry methodsFor: 'public' stamp: ''!
on: repositoryUrl beUser: nameString withPassword: passwordString

	| credentials |
	credentials := MCServerCredentials user: nameString password: passwordString.
	registry at: repositoryUrl put: credentials.! !

!MCServerRegistry methodsFor: 'private' stamp: ''!
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 methodsFor: 'instance creation' stamp: ''!
uniqueInstance

	^ uniqueInstance ifNil: [ uniqueInstance := self new ].! !

!MCSmalltalkhubRepository commentStamp: ''!
I am specialized version of an MCHttpRepository for http://smalltalkhub.com.
I support a faster mcz listing that does not rely on parsing an html size.!
!MCSmalltalkhubRepository methodsFor: 'converting' stamp: ''!
asCreationTemplate
	^self class 
		creationTemplateOwner: self owner project: self project user: user password: password! !

!MCSmalltalkhubRepository methodsFor: 'interface' stamp: ''!
includesFileNamed: aString
	"avoid the slower default method and simply do a head request "
	self httpClient
		numberOfRetries: 0;
		ifFail: [ :exception | 
			((exception isKindOf: ZnHttpUnsuccessful) and: [ exception response isNotFound ])
				ifTrue: [ ^ false ].
			exception pass];
		head: (self urlForFileNamed: aString).
	^ true! !

!MCSmalltalkhubRepository methodsFor: 'accessing' stamp: ''!
project: aString
	
	project := aString! !

!MCSmalltalkhubRepository methodsFor: 'interface' stamp: ''!
includesVersionNamed: aString
	"directly do a filename check since the server only stores mcz"
	^ self includesFileNamed: aString, '.mcz'! !

!MCSmalltalkhubRepository methodsFor: 'interface' stamp: ''!
loadAllFileNames
	| client |
	client := self httpClient.
	client
		ifFail: [ :exception | self error: 'Could not access ', self location, ': ', exception printString ];
		url: self locationWithTrailingSlash;
		queryAt: 'format' put: 'raw';
		get.
	self assertNonBinaryResponse: client response.
	^ self parseFileNamesFromStream: client contents! !

!MCSmalltalkhubRepository methodsFor: 'accessing' stamp: ''!
location
	^ 'http://smalltalkhub.com/mc/', self owner, '/', self project, '/main/' ! !

!MCSmalltalkhubRepository methodsFor: 'accessing' stamp: ''!
location: aUrlString
	| pathSegments |
	(self class isResponsibleFor: aUrlString)
		ifFalse: [ Error signal: 'Please provide a smalltalkhub url' ].
	"extract the smalltalkhub properties from the path part in the given URL"
	pathSegments := aUrlString asZnUrl pathSegments reject: [ :each | each = 'mc' ].
	self owner: pathSegments first.
	self project: pathSegments second.! !

!MCSmalltalkhubRepository methodsFor: 'accessing' stamp: ''!
locationWithTrailingSlash
	^ self location! !

!MCSmalltalkhubRepository methodsFor: 'accessing' stamp: ''!
project
	
	^ project! !

!MCSmalltalkhubRepository methodsFor: 'accessing' stamp: ''!
owner: aString
	
	owner := aString! !

!MCSmalltalkhubRepository methodsFor: 'accessing' stamp: ''!
owner
	
	^ owner! !

!MCSmalltalkhubRepository methodsFor: 'interface' stamp: ''!
parseFileNamesFromStream: aNewLineDelimitedString
	^ aNewLineDelimitedString 
		ifNil: [ ^ OrderedCollection new ]
		ifNotNil: [ aNewLineDelimitedString substrings: String crlf ]! !

!MCSmalltalkhubRepository class methodsFor: 'creation template' stamp: ''!
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: 'accessing' stamp: ''!
description
	^ 'smalltalkhub.com'! !

!MCSmalltalkhubRepository class methodsFor: 'accessing' stamp: ''!
smalltalkhubUrl
	^ 'http://', self hostName, '/'! !

!MCSmalltalkhubRepository class methodsFor: 'accessing' stamp: ''!
baseURL
	^ self smalltalkhubUrl, 'mc/'! !

!MCSmalltalkhubRepository class methodsFor: 'instance creation' stamp: ''!
owner: owner project: project 
	^ self
		owner: owner
		project: project
		user: String empty
		password: String empty! !

!MCSmalltalkhubRepository class methodsFor: 'accessing' stamp: ''!
hostName
	^ 'smalltalkhub.com'! !

!MCSmalltalkhubRepository class methodsFor: 'testing' stamp: ''!
isResponsibleFor: aUrl
	^ aUrl includesSubstring: self hostName! !

!MCSmalltalkhubRepository class methodsFor: 'creation template' stamp: ''!
creationTemplate
	^self creationTemplateOwner: ''
		project: ''
		user: ''
		password: ''
! !

!MCSmalltalkhubRepository class methodsFor: 'instance creation' stamp: ''!
owner: owner project: project user: user password: password
	^ self new
		owner: owner;
		project: project;
		user: user;
		password: password;
		yourself! !

!MCSnapshot commentStamp: ''!
MCSnapshot represents a list of entities compared to a given base entities. 

It holds a list of definitions (instances of MCDefinition subclasses). It can install these entities or update a package.!
!MCSnapshot methodsFor: 'comparing' stamp: 'nil'!
= other
	self == other
		ifTrue: [ ^ true ].
	self species = other species
		ifFalse: [ ^ false ].
	^ definitions asArray = other definitions asArray! !

!MCSnapshot methodsFor: 'loading' stamp: 'nil'!
updatePackage: aPackage
	MCPackageLoader updatePackage: aPackage withSnapshot: self! !

!MCSnapshot methodsFor: 'comparing' stamp: 'nil'!
hash
	^ definitions asArray hash! !

!MCSnapshot methodsFor: 'patching' stamp: 'nil'!
patchRelativeToBase: aSnapshot
	^ MCPatch fromBase: aSnapshot target: self! !

!MCSnapshot methodsFor: 'loading' stamp: 'nil'!
install
	MCPackageLoader installSnapshot: self! !

!MCSnapshot methodsFor: 'accessing' stamp: 'nil'!
definitions
	^ definitions! !

!MCSnapshot methodsFor: 'accessing' stamp: 'nil'!
classDefinitionNamed: aName ifAbsent: aBlock

	^ classDefinitionCache at: aName ifAbsent: aBlock! !

!MCSnapshot methodsFor: 'initializing' stamp: 'nil'!
initializeWithDefinitions: aCollection
	
	definitions := aCollection.
	classDefinitionCache := Dictionary new.
	definitions do: [ :e |
		e isClassDefinition ifTrue: [ 
			classDefinitionCache
				at: e className
				put: e ] ]! !

!MCSnapshot methodsFor: '*Ring-Monticello' stamp: ''!
importInto: anRGEnvironment asPackageNamed: aPackageName

	| anRGPacakgeDefinition |
	anRGPacakgeDefinition := anRGEnvironment ensurePackageNamed: aPackageName.
	self definitions do: [ :each |
		each ensureRingDefinitionIn: anRGEnvironment package: anRGPacakgeDefinition ].

	^ anRGPacakgeDefinition! !

!MCSnapshot class methodsFor: 'instance creation' stamp: 'nil'!
empty
	^ self fromDefinitions: #()! !

!MCSnapshot class methodsFor: 'instance creation' stamp: 'nil'!
fromDefinitions: aCollection
	^ self new initializeWithDefinitions: aCollection! !

!MCSnapshotBrowser commentStamp: ''!
Browser for snapshots!
!MCSnapshotBrowser methodsFor: 'menus' stamp: ''!
categoryListMenu: aMenu 
	categorySelection
		ifNotNil: [aMenu
				add: (categorySelection = '*Extensions'
						ifTrue: ['Load all extension methods']
						ifFalse: ['Load class category {1}' format: {categorySelection}])
				selector: #loadCategorySelection].
	^ aMenu! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
selectedMessageName
	^methodSelection ifNotNil: [^ methodSelection selector ].
! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
selectedClass
	classSelection ifNil: [ ^ nil ].
	^ Smalltalk globals at: classSelection ifAbsent: [ nil ]! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: ''!
categoryList
	^ self visibleCategories! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
selectedMessageCategoryName
	^protocolSelection! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: ''!
methodSelection
	^ methodSelection
			ifNil: [0] 
			ifNotNil: [self visibleMethods indexOf: methodSelection]! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: ''!
signalSwitchChanged
	self protocolSelection: 0.
	self 
		changed: #switchIsInstance;
		changed: #switchIsComment;
		changed: #switchIsClass;
		changed: #protocolList;
		changed: #methodList;
		changed: #text.! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: ''!
protocolSelection
	^ protocolSelection 
		ifNil: [0]
		ifNotNil: [self visibleProtocols indexOf: protocolSelection]! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
extensionClassNames
	^ (self allClassNames difference: self packageClassNames) asSortedCollection! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: ''!
classSelection
	^ classSelection ifNil: [0] ifNotNil: [self visibleClasses indexOf: classSelection]! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: ''!
switchBeInstance
	switch := #instance.
	self signalSwitchChanged.! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
allClassNames
	^ (items 
		select: [:ea | (ea isOrganizationDefinition | ea isScriptDefinition) not]
		thenCollect: [:ea | ea className]) asSet.
! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: ''!
switchIsClass
	^ switch = #class! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: ''!
loadClassSelection
	classSelection ifNil: [ ^ self ].
	self packageClasses
		detect: [ :ea | ea className = classSelection ]
		ifFound: [ :packageClass | 
			packageClass load.
			self methodsForSelectedClass do: [ :m | m load ] ]! !

!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: ''!
initialExtent
	^ 650@400.! !

!MCSnapshotBrowser methodsFor: 'text' stamp: ''!
text: aTextOrString
	self changed: #text! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass
	| class |
	classSelection ifNil: [ ^ nil ].
	class := Smalltalk globals at: classSelection ifAbsent: [ ^ nil ].
	^ self switchIsClass
		ifTrue: [ class class ]
		ifFalse: [ class ]! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
packageClasses
	^ items select: [:ea | ea isClassDefinition]! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: ''!
categorySelection: aNumber
	categorySelection := aNumber = 0 ifFalse: [self visibleCategories at: aNumber].
	self classSelection: 0.
	self changed: #categorySelection;
		changed: #classList.
! !

!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: ''!
widgetSpecs

	 ^#(
		((listMorph: category) (0 0 0.25 0.4))
		((listMorph: class) (0.25 0 0.50 0.4) (0 0 0 -30))
		((listMorph: protocol) (0.50 0 0.75 0.4))
		((listMorph:selection:menu:keystroke:  methodList methodSelection methodListMenu: methodListKey:from:) (0.75 0 1 0.4))
		((buttonRow) (0.25 0.4 0.5 0.4) (0 -30 0 0))
		((textMorph: text) (0 0.4 1 1))
		) ! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: ''!
methodListMenu: aMenu 
	super methodListMenu: aMenu.
	( self selectedMessageName notNil and: [ methodSelection isLoadable ] )
		ifTrue: [ aMenu addLine; add: 'Load method' selector: #loadMethodSelection ].
	^ aMenu! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: ''!
switchBeComment
	switch := #comment.
	self signalSwitchChanged.! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: ''!
visibleMethods
	^ classSelection 
		ifNil: [#()]
		ifNotNil: [self methodsForSelectedProtocol]! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: ''!
loadProtocolSelection
	protocolSelection ifNil: [ ^self ].
	self methodsForSelectedProtocol do: [ :m | m load ].! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: ''!
packageOrganizations
	^ items select: [:ea | ea isOrganizationDefinition]! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: ''!
visibleCategories
	^ ((self packageOrganizations flatCollect: [ :ea | ea categories ]),
		(self packageClasses collect: [ :ea | ea category ]),
			(self hasExtensions ifTrue: [{ self extensionsCategory }] ifFalse: [#()]))
				asSet asSortedCollection! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: ''!
classListMenu: aMenu 
	classSelection ifNil: [ ^aMenu ].
	super classListMenu: aMenu.
	aMenu
		addLine;
		add: ('Load class {1}'  format: {classSelection})
		selector: #loadClassSelection.
	^ aMenu! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
methodsForSelectedClassCategory
	| visibleClasses |
	visibleClasses := self visibleClasses.
	^ items select: [:ea | (visibleClasses includes: ea className) 
								and: [ea isMethodDefinition
									and: [ea classIsMeta = self switchIsClass]]].! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: ''!
classList
	^ self visibleClasses! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: ''!
methodList
	^ self visibleMethods collect: [:ea | ea selector]! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
methodsForSelectedClass
	^ items select: [:ea | (ea className = classSelection) 
							and: [ea isMethodDefinition
									and: [ea classIsMeta = self switchIsClass]]].! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
extensionsCategory
	^ '*Extensions'! !

!MCSnapshotBrowser methodsFor: 'text' stamp: ''!
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: 'menus' stamp: ''!
inspectSelection
	^ self methodSelection inspect! !

!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: ''!
buttonSpecs
	^ #(('instance' switchBeInstance 'show instance' buttonEnabled switchIsInstance)
		('?' switchBeComment 'show comment' buttonEnabled switchIsComment)
		('class' switchBeClass 'show class' buttonEnabled switchIsClass))! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: ''!
switchIsInstance
	switch ifNil: [switch := #instance].
	^ switch = #instance.! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
methodsForSelectedProtocol
	| methods |
	protocolSelection ifNil: [^ Array new].
	methods := self methodsForSelectedClass asOrderedCollection.
	(protocolSelection = '-- all --') 
		ifFalse: [methods removeAllSuchThat: [:ea | ea category ~= protocolSelection]].
	^ methods 
	
								! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: ''!
protocolList
	^ self visibleProtocols! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: ''!
loadMethodSelection
	methodSelection ifNil: [ ^self ].
	methodSelection load.! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: ''!
protocolSelection: anInteger
	protocolSelection := (anInteger = 0 ifFalse: [self visibleProtocols at: anInteger]).
	self methodSelection: 0.
	self changed: #protocolSelection;
		changed: #methodList.! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: ''!
switchBeClass
	switch := #class.
	self signalSwitchChanged.! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: ''!
switchIsComment
	^ switch = #comment.! !

!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^ 'Snapshot Browser'! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: ''!
protocolListMenu: aMenu 
	protocolSelection
		ifNotNil: [aMenu
				add: ('Load protocol ''{1}''' format: {protocolSelection})
				selector: #loadProtocolSelection ].
	^ aMenu! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: ''!
methodSelection: aNumber
	methodSelection := aNumber = 0 ifFalse: [self visibleMethods at: aNumber].
	self changed: #methodSelection; changed: #text.! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: ''!
loadCategorySelection
	"Load the entire selected category"
	categorySelection ifNil: [ ^self ].
	self methodsForSelectedClassCategory do: [ :m | m load ].! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: ''!
visibleClasses
	^ categorySelection = self extensionsCategory
		ifTrue: [self extensionClassNames]
		ifFalse: [self packageClasses
					select: [:ea | ea category = categorySelection]
					thenCollect: [:ea | ea className]].! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: ''!
classSelection: aNumber
	classSelection := aNumber = 0 ifFalse: [self visibleClasses at: aNumber].
	self protocolSelection: 0.
	self changed: #classSelection; 
		changed: #protocolList;
		changed: #methodList.
! !

!MCSnapshotBrowser methodsFor: 'text' stamp: ''!
scriptDefinitionString
	| defs |
	defs := items select: [:ea | ea isScriptDefinition].
	defs isEmpty ifTrue: [^'(package defines no scripts)'].
	
	^ String streamContents: [:stream | 
		defs asArray sort 
			do: [:ea | stream nextPutAll: '---------- package ';
					nextPutAll: ea scriptSelector;
					nextPutAll: ' ----------'; cr;
					nextPutAll: ea script; cr]
			separatedBy: [stream cr]].! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
hasExtensions
	^self extensionClassNames notEmpty! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
snapshot: aSnapshot
	items := aSnapshot definitions asSortedCollection.
	self categorySelection: 0.! !

!MCSnapshotBrowser methodsFor: 'text' stamp: ''!
classCommentString
	^ items
		detect: [ :ea | ea isClassDefinition and: [ ea className = classSelection ] ]
		ifFound: [ :classDefinition | classDefinition comment ]
		ifNone: [ '' ]! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: ''!
categorySelection
	^ categorySelection ifNil: [0] ifNotNil: [self visibleCategories indexOf: categorySelection]! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: ''!
packageClassNames
	^ self packageClasses collect: [:ea | ea className]! !

!MCSnapshotBrowser methodsFor: 'text' stamp: ''!
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: 'listing' stamp: ''!
visibleProtocols
	| methods protocols |
	self switchIsComment ifTrue: [^ Array new].
	methods := self methodsForSelectedClass.
	protocols := (methods collect: [:ea | ea category]) asSet asSortedCollection.
	protocols add: AllProtocol defaultName.
	^ protocols ! !

!MCSnapshotBrowser methodsFor: 'text' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
forSnapshot: aSnapshot
	^ self new snapshot: aSnapshot! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: ''!
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: ''!
testProtocolIsCleared
	self clickOnListItem: self mockCategoryName.
	self clickOnListItem: 'MCMockASubclass'.
	self clickOnListItem: 'as yet unclassified'.
	self clickOnListItem: 'MCMockClassA'.
	
	self denyAListHasSelection: 'as yet unclassified'.! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: ''!
classABooleanMethods
	^ #(falsehood moreTruth truth)! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: ''!
classADefinitionString

	^ self mockClassA oldDefinition! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: ''!
denyAListHasSelection: aString
	| found |
	found := true.
	self listMorphs 
			detect: [:m | m selection = aString]
			ifNone: [found := false].
	self deny: found.! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: ''!
falsehoodMethodSource
	^ 'falsehood
	^ false'! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: ''!
assertButtonOn: aString
	self assert: (self findButtonWithLabel: aString) getModelState.
	! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: ''!
annotationTextMorph
	^ (self morphsOfClass: TextMorph) first! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: ''!
testFourColumns
	self assert: self listMorphs size equals: 4! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: ''!
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: ''!
testMethodIsCleared
	self clickOnListItem: self mockCategoryName.
	self clickOnListItem: 'MCMockClassA'.
	self clickOnListItem: 'boolean'.
	self clickOnListItem: 'falsehood'.
	self clickOnListItem: AllProtocol defaultName.
	
	self denyAListHasSelection: 'falsehood'.! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: ''!
assertAListMatches: strings
	| lists |
	lists := self listMorphs collect: [:each | each getList].
	lists
		detect: [ :list|
			(list size = strings size) and: [list includesAll: strings]]
		ifNone: [ 
			self fail: 'Could not find all "', strings asArray asString, '" ', 
						'in any of "', (lists collect: #asArray) asArray asString, '"'  ].! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: ''!
denyAListIncludesAnyOf: anArrayOfStrings
	| found |
	found := true.
	self listMorphs 
			detect: [:m | m getList includesAnyOf: anArrayOfStrings]
			ifNone: [found := false].
	self deny: found.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: ''!
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: 'private' stamp: ''!
definedClasses
	^ MCSnapshotResource current definitions 
		select: [:def | def isClassDefinition] 
		thenCollect: [:def | def className].! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: ''!
textMorph
	^ (self morphsOfClass: RubPluggableTextMorph) last! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: ''!
findListContaining: aString
	^ self listMorphs detect: [:m | m getList includes: aString]! !

!MCSnapshotBrowserTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := MCSnapshotBrowser forSnapshot: MCSnapshotResource current snapshot.
	morph := model buildWindow.! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: ''!
denyButtonOn: aString
	self deny: (self findButtonWithLabel: aString) getModelState.
	! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: ''!
classAProtocols
	^ self protocolsForClass: self mockClassA.! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: ''!
allMethods
	^ MCSnapshotResource current definitions
		select: [:def | def isMethodDefinition]
		thenCollect: [:def | def selector]		! !

!MCSnapshotBrowserTest methodsFor: 'simulating' stamp: ''!
clickOnListItem: aString
	| listMorph |
	listMorph := self findListContaining: aString.
	listMorph changeModelSelection: (listMorph getList indexOf: aString).! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: ''!
classAClassProtocols
	^ self protocolsForClass: self mockClassA class.! !

!MCSnapshotBrowserTest methodsFor: 'simulating' stamp: ''!
clickOnButton: aString
	(self findButtonWithLabel: aString) performAction.! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: ''!
listMorphs
	^ self morphsOfClass: PluggableListMorph! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: ''!
protocolsForClass: aClass
	^ aClass organization allCategories
! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: ''!
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: ''!
testTextPane
	self textMorph! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: ''!
classAclassDefinitionString

	^ (ClassDefinitionPrinter oldPharo for: self mockClassA class) definitionString! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: ''!
assertButtonExists: aString
	self buttonMorphs detect: [:m | m label = aString] ifNone: [self assert: false].
				! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: ''!
findButtonWithLabel: aString
	^ self buttonMorphs detect: [:m | m label = aString]! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: ''!
testThreeButtons
	self assertButtonExists: 'instance'.
	self assertButtonExists: '?'.
	self assertButtonExists: 'class'.! !

!MCSnapshotBrowserTest methodsFor: 'selecting' stamp: ''!
selectMockClassA
	self clickOnListItem: self mockCategoryName.
	self clickOnListItem: 'MCMockClassA'.
	! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: ''!
assertTextIs: aString

	self 
		assert: self textMorph text 
		equals: aString! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: ''!
testNoSelection
	self assertAListMatches: self allCategories.
	self denyAListIncludesAnyOf: self definedClasses.
	self denyAListIncludesAnyOf: self allProtocols.
	self denyAListIncludesAnyOf: self allMethods.
	"and if there I need to see the packages scripts (or none)"
	self assertTextIs: '(package defines no scripts)'.! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: ''!
morphsOfClass: aMorphClass
	| morphs |
	morphs := OrderedCollection new.
	morph allMorphsDo: [:m | (m isKindOf: aMorphClass) ifTrue: [morphs add: m]].
	^ morphs! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: ''!
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: 'private' stamp: ''!
classAComment
	^ self mockClassA organization classComment.! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: ''!
buttonMorphs
	^ self morphsOfClass: PluggableButtonMorph! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: ''!
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: 'private' stamp: ''!
allProtocols
	^ MCSnapshotResource current definitions
		select: [:def | def isMethodDefinition]
		thenCollect: [:def | def category]		! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: ''!
testComment
	self clickOnButton: '?'.
	self assertTextIs: ''.
	
	self clickOnListItem: self mockCategoryName.
	self assertTextIs: ''.
	
	self clickOnListItem: 'MCMockClassA'.
	self assertTextIs: self classAComment.! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: ''!
assertAListIncludes: anArrayOfStrings
	self listMorphs 
			detect: [:m | m getList includesAll: anArrayOfStrings]
			ifNone: [self assert: false].! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: ''!
allCategories
	^ Array with: model extensionsCategory with: self mockCategoryName.! !

!MCSnapshotReader commentStamp: ''!
I am an abstract class defining the interface for reading sources containing class and method definitions.
I should define loadDefinitions as a subclassResponsibility, but don't.
MCVersionReader could be a subclass of me for reading sources containing additional metadata, but isn't. 

I'm useless and can be safely removed. I'm only referenced in MCMczReader>>extractDefinitionsFrom: and it can be replaced by MCReader.!
!MCSnapshotReader methodsFor: 'accessing' stamp: 'nil'!
definitions
	definitions ifNil: [self loadDefinitions].
	^ definitions! !

!MCSnapshotReader methodsFor: 'accessing' stamp: 'nil'!
snapshot
	^ MCSnapshot fromDefinitions: self definitions! !

!MCSnapshotReader class methodsFor: 'accessing' stamp: 'nil'!
snapshotFromStream: aStream
	^ (self on: aStream) snapshot! !

!MCSnapshotResource commentStamp: ''!
A test resource mocking a snapshot!
!MCSnapshotResource methodsFor: 'accessing' stamp: ''!
definitions
	^ snapshot definitions! !

!MCSnapshotResource methodsFor: 'accessing' stamp: ''!
snapshot
	^ snapshot! !

!MCSnapshotResource methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	snapshot := self class takeSnapshot.! !

!MCSnapshotResource class methodsFor: 'accessing' stamp: ''!
takeSnapshot
	^ self mockPackage snapshot! !

!MCSnapshotResource class methodsFor: 'accessing' stamp: ''!
mockPackage
	^ (MCPackage new name: self mockPackageName)! !

!MCSnapshotResource class methodsFor: 'accessing' stamp: ''!
mockPackageName
	^ 'MonticelloMocks'! !

!MCSnapshotTest methodsFor: 'tests' stamp: ''!
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: 'running' stamp: ''!
tearDown 

	| package |
	package := 'Monticello-Snapshot-Mock' asPackageIfAbsent: [nil].
	package ifNotNil: [ package removeFromSystem ].
	super tearDown.! !

!MCSnapshotTest methodsFor: 'tests' stamp: ''!
testClassWithClassTraitCompositionHasTraitComposition

	| definitions def |
	definitions :=  self createSnapshotWithClassWithClassSideTraits definitions.
	def := self lookupClass: #C1 in: definitions.
	
	self assert: def hasClassTraitComposition.


! !

!MCSnapshotTest methodsFor: 'utilities' stamp: ''!
lookupClass: aName in: definitions
	^ definitions
		detect: [ :aDef | aDef isClassDefinition and: [ aDef className = aName ] ]! !

!MCSnapshotTest methodsFor: '*MonticelloMocks' stamp: ''!
mockClassExtension

	"I change the protocol of this method to resolve the failing test: MCChangeNotificationTest >> testExtMethodModified. This test basically test that when we modified an extension method, the extended package is marked as 'modified'. The problem is that Monticello treat differently a classic method from an extension method, and this only by checking if the protocol name start with a star. Therefore, if the protocol does not match the extending package name, the extending package name will never be notified, and the test will fail. " ! !

!MCSnapshotTest methodsFor: 'tests' stamp: ''!
testTraitWithClassTraitCompositionHasTraitComposition

	| definitions def |
	definitions :=  self createSnapshotWithTraitWithClassSideTraits definitions.
	def := self lookupTrait: #T3 in: definitions.
	
	self assert: def hasClassTraitComposition.


! !

!MCSnapshotTest methodsFor: 'utilities' stamp: ''!
lookupTrait: aName in: definitions 

	^ definitions detect: [ :aDef | aDef isTraitDefinition and: [ aDef className = aName ] ]! !

!MCSnapshotTest methodsFor: 'running' stamp: ''!
createSnapshotWithTraitWithClassSideTraits

	| t1 t2 t3 |
	
	RPackageOrganizer default registerPackageNamed: 'Monticello-Snapshot-Mock'.

	t1 := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #T1;
			package:  'Monticello-Snapshot-Mock';
			beTrait ].					

	t2 := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #T2;
			package:  'Monticello-Snapshot-Mock';
			beTrait ].					

	t3 := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #T3;
			traitComposition: t1 + t2;
			classTraitComposition: (t1 classTrait + t2 classTrait - #m1);
			package:  'Monticello-Snapshot-Mock';
			beTrait ].					

	^ (MCWorkingCopy forPackage: (MCPackage new name: 'Monticello-Snapshot-Mock')) snapshot. ! !

!MCSnapshotTest methodsFor: 'tests' stamp: ''!
testTraitWithClassTraitCompositionHasCorrectTraitComposition

	| definitions def |
	definitions :=  self createSnapshotWithTraitWithClassSideTraits definitions.
	def := self lookupTrait: #T3 in: definitions.
	
	self assert: def classTraitComposition equals: '(T1 classTrait + T2 classTrait) - {#m1}'

! !

!MCSnapshotTest methodsFor: 'tests' stamp: ''!
testClassWithClassTraitCompositionHasCorrectTraitComposition

	| definitions def |
	definitions :=  self createSnapshotWithClassWithClassSideTraits definitions.
	def := self lookupClass: #C1 in: definitions.
	
	self assert: def classTraitComposition equals: '(T1 classTrait + T2 classTrait) - {#m1}'

! !

!MCSnapshotTest methodsFor: 'running' stamp: ''!
createSnapshotWithClassWithClassSideTraits

	| t1 t2 |
	
	RPackageOrganizer default registerPackageNamed: 'Monticello-Snapshot-Mock'.
	
	t1 := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #T1;
			package:  'Monticello-Snapshot-Mock';
			beTrait ].					

	t2 := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #T2;
			package:  'Monticello-Snapshot-Mock';
			beTrait ].					

	self class classInstaller make: [ :aBuilder | 
			aBuilder 
				name: #C1;
				traitComposition: t1 + t2;
				classTraitComposition: (t1 classTrait + t2 classTrait - #m1);
				package: 'Monticello-Snapshot-Mock'].

	^ (MCWorkingCopy forPackage: (MCPackage new name: 'Monticello-Snapshot-Mock')) snapshot. ! !

!MCSnapshotTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	snapshot :=  self mockSnapshot.! !

!MCSortingTest methodsFor: 'building' stamp: ''!
classNamed: aSymbol
	^ MCClassDefinition
		name: aSymbol
		superclassName: #Object
		category: ''
		instVarNames: #()
		comment: ''! !

!MCSortingTest methodsFor: 'tests' stamp: ''!
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 equals: 1! !

!MCSortingTest methodsFor: 'building' stamp: ''!
sortKeyFor: aDefinition
	^ String streamContents:
		[:s |
		aDefinition description
			do: [:ea | s nextPutAll: ea asString]
			separatedBy: [s nextPut: $.]]! !

!MCSortingTest methodsFor: 'actions' stamp: ''!
sortDefinitions: aCollection
	^ aCollection asSortedCollection asArray! !

!MCSortingTest methodsFor: 'tests' stamp: ''!
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}) equals: {A . aAm . bAm . cAm . aA . bA . cA . B . aB . bB}! !

!MCSortingTest methodsFor: 'building' stamp: ''!
methodNamed: aSymbol class: className meta: aBoolean
	^ MCMethodDefinition
		className: className
		classIsMeta: aBoolean
		selector: aSymbol
		category: ''
		timeStamp: ''
		source: ''! !

!MCSortingTest class methodsFor: 'testing' stamp: ''!
isUnitTest
	^false! !

!MCSqueaksourceRepository commentStamp: ''!
I am a specialized MCHttpRepository for http://squeaksource.com.
I optimize checks for existing files by doing a head request instead of reloading the whole file list first.!
!MCSqueaksourceRepository methodsFor: 'interface' stamp: ''!
includesFileNamed: aString
	
	"avoid the slower default method and simply do a head request "
	self httpClient
		numberOfRetries: 0;
		ifFail: [ :exception | 
			((exception isKindOf: ZnHttpUnsuccessful) and: [ exception response isNotFound ])
				ifTrue: [ ^ false ].
			exception pass];
		head: (self urlForFileNamed: aString).
		
	^ true! !

!MCSqueaksourceRepository methodsFor: 'interface' stamp: ''!
includesVersionNamed: aString
	"directly do a filename check since the server only stores mcz"
	^ self includesFileNamed: aString, '.mcz'! !

!MCSqueaksourceRepository class methodsFor: 'accessing' stamp: ''!
description
	^ 'squeaksource.com'! !

!MCSqueaksourceRepository class methodsFor: 'creation template' stamp: ''!
baseURL
	^ 'http://squeaksource.com/'! !

!MCSqueaksourceRepository class methodsFor: 'testing' stamp: ''!
isResponsibleFor: aUrl
	^ aUrl includesSubstring: 'squeaksource.com/'! !

!MCStReader commentStamp: ''!
I read Category/Classes/Methodes/.... definitions from Monticello source.st file format.

See also MCStWriter.

Example:

|source|
source := String streamContents: [:aStream| |writer|
    writer := MCStWriter on: aStream.
    writer writeDefinitions: {True asClassDefinition. False asClassDefinition}.
].

(MCStReader on: source readStream) definitions explore.!
!MCStReader methodsFor: 'reading' stamp: 'nil'!
commentStampFor: aRingClass
	^ aRingClass hasComment
		ifTrue: [ aRingClass comment stamp ]
		ifFalse: [ nil ]! !

!MCStReader methodsFor: 'reading' stamp: 'nil'!
categoryFromDoIt: aString
	| tokens  |
	tokens := aString parseLiterals.
	tokens size = 3 ifFalse: [self error: 'Unrecognized category definition'].
	^ tokens at: 3! !

!MCStReader methodsFor: 'reading' stamp: 'nil'!
classDefinitionFrom: aRingClass
	| tokens traitCompositionString lastIndex classTraitCompositionString |
	tokens := aRingClass definitionSource parseLiterals.
	traitCompositionString := (aRingClass definitionSource readStream
		match: 'uses:';
		upToAll: 'instanceVariableNames:') trimBoth.
	classTraitCompositionString := (aRingClass classSide definitionSource 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: aRingClass)
		type: (self typeOfSubclass: (tokens at: 2))
		comment: (self commentFor: aRingClass)
		commentStamp: (self commentStampFor: aRingClass)! !

!MCStReader methodsFor: 'reading' stamp: 'nil'!
typeOfSubclass: aSymbol
	#(
		(subclass: normal)
		(named: normal)
		(variableSubclass: variable)
		(variableByteSubclass: bytes)
		(variableWordSubclass: words)
		(weakSubclass: weak)
		) do: [:ea | ea first = aSymbol ifTrue: [^ ea second]].
	self error: 'Unrecognized class definition'! !

!MCStReader methodsFor: 'adding' stamp: 'nil'!
addDefinitionsFromDoit: aString
	(MCDoItParser forDoit: aString) ifNotNil:
		[:parser |
		parser addDefinitionsTo: definitions]! !

!MCStReader methodsFor: 'reading' stamp: 'nil'!
classInstVarNamesFor: aRingClass
	| tokens |
	
	self flag: #traits.
	aRingClass classSide hasDefinitionSource ifFalse: [^ #()].
	tokens := aRingClass classSide definitionSource parseLiterals.
	"tokens size = 4 ifFalse: [self error: 'Unrecognized metaclass definition']."
	^ tokens last findTokens: ' '! !

!MCStReader methodsFor: 'reading' stamp: 'nil'!
methodDefinitionsFor: aRingClass

	^ aRingClass methods collect: 
		[ :each | each asMCMethodDefinition ]! !

!MCStReader methodsFor: 'reading' stamp: 'nil'!
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: 'evaluating' stamp: 'nil'!
loadDefinitions
	| filePackage |
	filePackage := RingChunkImporter fromStream: self readStream.
	definitions := OrderedCollection new.
	filePackage classes
		do: [ :ringClass |
			ringClass hasDefinitionSource
				ifTrue: [definitions add:
						(self classDefinitionFrom: ringClass)].
			definitions addAll: (self methodDefinitionsFor: ringClass).
			definitions addAll: (self methodDefinitionsFor: ringClass classSide) ].
	filePackage doIts 
		do: [ :ea | self addDefinitionsFromDoit: ea contents ].
	! !

!MCStReader methodsFor: 'evaluating' stamp: 'nil'!
readStream
	^ ('!!!!

', stream contents) readStream! !

!MCStReader methodsFor: 'reading' stamp: 'nil'!
commentFor: aRingClass

	^ aRingClass hasComment
		ifTrue: [ aRingClass comment content asString ]
		ifFalse: [ '' ]! !

!MCStReader class methodsFor: 'accessing' stamp: 'nil'!
extension
	^ 'st'! !

!MCStReaderTest methodsFor: 'util' stamp: ''!
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.!!
!! !!

'! !

!MCStReaderTest methodsFor: 'tests' stamp: ''!
testCommentWithStyle
	| reader |
	reader := MCStReader on: self commentWithStyle readStream.
	reader definitions! !

!MCStReaderTest methodsFor: 'tests' stamp: ''!
testMethodWithStyle
	| reader |
	reader := MCStReader on: self methodWithStyle readStream.
	self assert: reader definitions first isMethodDefinition.! !

!MCStReaderTest methodsFor: 'util' stamp: ''!
commentWithStyle
	^ '!!AEDesc commentStamp: ''<historical>'' 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: ''!
commentWithoutStyle
	^ '
CharacterScanner subclass: #CanvasCharacterScanner
	instanceVariableNames: ''canvas fillBlt foregroundColor runX lineY ''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''Morphic-Support''!!

!!CanvasCharacterScanner commentStamp: ''<historical>'' 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: 'tests' stamp: ''!
testCommentWithoutStyle
	| reader |
	reader := MCStReader on: self commentWithoutStyle readStream.
	self assert: (reader definitions anySatisfy: [:ea | ea isMethodDefinition]).! !

!MCStWriter commentStamp: ''!
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: 'nil'!
visitMetaclassDefinition: definition
	self writeMetaclassDefinition: definition! !

!MCStWriter methodsFor: 'accessing' stamp: 'nil'!
writeInitializers: aBoolean

	writeInitializers := aBoolean! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
chunkContents: aBlock
	stream
		cr;
		nextPut: (String streamContents: aBlock);
		cr! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
writeMethodPreamble: definition
	self chunkContents: [:str |
		stream bang.
		str nextPutAll: definition className asString.
		definition classIsMeta ifTrue:
			[ str nextPutAll: ' class' ].
		str
			nextPutAll: ' methodsFor: ';
			nextPutAll: definition category asString printString;
			nextPutAll: ' stamp: ';
			nextPutAll: definition timeStamp asString printString
		]! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
basicChunkContents: aBlock
	stream nextPut: (String streamContents: aBlock)! !

!MCStWriter methodsFor: 'visiting' stamp: 'nil'!
visitClassDefinition: definition
	self writeClassDefinition: definition.
	definition hasClassInstanceVariables ifTrue: [self writeMetaclassDefinition: definition].
	definition hasComment ifTrue: [self writeClassComment: definition].! !

!MCStWriter methodsFor: 'visiting' stamp: 'nil'!
visitScriptDefinition: definition
	self writeScriptDefinition: definition
! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
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 |
		self chunkContents: [ :str | str nextPutAll: (presentInitializers detect: [:each | each key = className]) value contents] ].
	
	(notPresentInitializers asSortedCollection: [:a :b | a key <= b key]) do: [:association |
		self chunkContents: [ :str | str  nextPutAll: association value contents ] ].! !

!MCStWriter methodsFor: 'accessing' stamp: 'nil'!
writeInitializers

	"answer if class initializers should be written"

	^ writeInitializers ifNil: [ writeInitializers := true ]! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
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: 'nil'!
writeCategory: categoryName
	stream
		nextChunkPut: 'SystemOrganization addCategory: ', categoryName printString;
		cr! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
writeClassComment: definition

	self chunkContents: [ :str |
		stream bang.
		str nextPutAll: definition className;
			nextPutAll: ' commentStamp: ';
			store: definition commentStamp;
			nextPutAll: ' prior: 0' ].
	self basicChunkContents: [ :str | str nextPutAll: definition comment ].
	stream cr.! !

!MCStWriter methodsFor: 'initialization' stamp: 'nil'!
stream: aStream

	stream := ChunkWriteStream on: aStream! !

!MCStWriter methodsFor: 'visiting' stamp: 'nil'!
visitTraitDefinition: definition
	self writeClassDefinition: definition.
	definition hasComment ifTrue: [self writeClassComment: definition].! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
writeMethodSource: definition
	self basicChunkContents: [:str | str nextPutAll: definition source ].! !

!MCStWriter methodsFor: 'visiting' stamp: 'nil'!
visitOrganizationDefinition: defintion
	defintion categories do: [:cat | self writeCategory: cat].
! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
writeClassDefinition: definition
	self chunkContents: [:s | definition printDefinitionOn: s].! !

!MCStWriter methodsFor: 'visiting' stamp: 'nil'!
visitMethodDefinition: definition
	self writeMethodPreamble: definition.
	self writeMethodSource: definition.
	self writeMethodPostscript.
	self writeInitializers ifTrue: [ 
		self writeMethodInitializer: definition ].! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
writeScriptDefinition: definition
	self chunkContents: [:str | 
		str nextPutAll: (
			'(PackageInfo named: {1}) {2}: {3}'
			format: {
				"{1}" definition packageName printString.
				"{2}" definition scriptSelector. 
				"{3}" definition script printString
			}) ]! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
writeMethodPostscript
	self basicChunkContents: [:str | str space ].
	stream cr.! !

!MCStWriter methodsFor: 'visiting' stamp: 'nil'!
visitClassTraitDefinition: definition
	self chunkContents: [:s | s
		nextPutAll: definition baseTrait;
		nextPutAll: ' classTrait';
		cr; tab;
		nextPutAll: 'uses: ';
		nextPutAll: (definition classTraitComposition ifNil: ['{}'])]
! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
writeSnapshot: aSnapshot
	self writeDefinitions: aSnapshot definitions! !

!MCStWriter methodsFor: 'writing' stamp: 'nil'!
writeMethodInitializer: aMethodDefinition
	
	aMethodDefinition isInitializer ifTrue: [ 
		self chunkContents: [ :str |
			str nextPutAll: aMethodDefinition className, ' initialize'.
			initializers add: (aMethodDefinition className -> str) ]
		].! !

!MCStWriter class methodsFor: 'accessing' stamp: 'nil'!
readerClass
	^ MCStReader! !

!MCStWriterTest methodsFor: 'data' stamp: ''!
expectedMethodDefinitionWithBangs
	^ '
!!MCStWriterTest methodsFor: ''testing'' stamp: ''''!!
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: ''!
testClassDefinitionB
	writer visitClassDefinition: (self mockClassB asClassDefinition).
	self assertContentsOf: stream match: self expectedClassDefinitionB.
	! !

!MCStWriterTest methodsFor: 'asserting' stamp: ''!
assertContentsOf: strm match: expected
	| actual |
	actual := strm contents.
	self assert: actual size equals: expected size.
	actual with: expected do: [ :a :e | self assert: a equals: e ]! !

!MCStWriterTest methodsFor: 'testing' stamp: ''!
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: ''!
testClassDefinitionA
	writer visitClassDefinition: (self mockClassA asClassDefinition).
	self assertContentsOf: stream match: self expectedClassDefinitionA.
	stream := ChunkReadStream on: stream contents readStream.
	2 timesRepeat: [self assertChunkIsWellFormed: stream next]! !

!MCStWriterTest methodsFor: 'testing' stamp: ''!
testNotLoadedClassMethod
	"Check that the chunk header is correct for a class method of a class that isn't part of the running system"
	| definition methodStream methodWriter |

	definition := MCMethodDefinition
		className: #NotALoadedClass
		classIsMeta: true
		selector: #reset
		category: 'imagine'
		timeStamp: nil
		source: 'reset

    ^self doReset'.
	methodStream := String new writeStream.
	methodWriter := MCStWriter new
		stream: methodStream;
		yourself.

	methodWriter writeMethodPreamble: definition.
	self assert: methodStream contents trimBoth
			equals: '!!NotALoadedClass class methodsFor: ''imagine'' stamp: ''nil''!!'.
! !

!MCStWriterTest methodsFor: 'asserting' stamp: ''!
assertAllChunksAreWellFormed
	stream := ChunkReadStream on: stream contents readStream.
	self assertChunkIsWellFormed: stream next.! !

!MCStWriterTest methodsFor: 'data' stamp: ''!
expectedOrganizationDefinition
	^ 'SystemOrganization addCategory: #MonticelloMocks!!
'! !

!MCStWriterTest methodsFor: 'data' stamp: ''!
expectedClassMethodDefinition

	^ '\s*!!MCMockClassA class methodsFor\: ''as yet unclassified'' stamp\: ''[/:\s\w]*''!!\s*one\s*\^ 1!! !!\s*'.! !

!MCStWriterTest methodsFor: 'testing' stamp: ''!
testClassMethodDefinition
	writer visitMethodDefinition: (RGMethodDefinition realClass: self mockClassA class selector: #one) asMCMethodDefinition.
	self assert: (stream contents matchesRegex: self expectedClassMethodDefinition).
	
	stream := ChunkReadStream on: stream contents readStream.
	
	self assert: stream next isAllSeparators.
	self assertChunkIsWellFormed: stream next.
	self assertMethodChunkIsWellFormed: stream next.
	self assert: stream next isAllSeparators ! !

!MCStWriterTest methodsFor: 'testing' stamp: ''!
expectedInitializerASubclass
	^ 'MCMockASubclass initialize'! !

!MCStWriterTest methodsFor: 'testing' stamp: ''!
expectedInitializerA
	^ 'MCMockClassA initialize'! !

!MCStWriterTest methodsFor: 'testing' stamp: ''!
testInitializerDefinition
	|chunk lastChunk penultChunk|
	writer writeSnapshot: self mockSnapshot.
	stream := ChunkReadStream on: stream contents readStream.
	
	[stream atEnd] whileFalse:
		[chunk := stream next.
		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: ''!
testOrganizationDefinition
	| definition |
	definition := MCOrganizationDefinition categories: 
					(self mockPackage packageSet systemCategories).
	writer visitOrganizationDefinition: definition.
	self assertContentsOf: stream match: self expectedOrganizationDefinition.
	self assertAllChunksAreWellFormed.! !

!MCStWriterTest methodsFor: 'data' stamp: ''!
expectedMethodDefinition
	^ '\s*!!MCMockClassA methodsFor\: ''numeric'' stamp\: ''[/:\s\w]*''!!\s*one\s*\^ 1!! !!\s*'! !

!MCStWriterTest methodsFor: 'asserting' stamp: ''!
assertMethodChunkIsWellFormed: chunk
	self class compiler
		source: chunk readStream;
		class: UndefinedObject;
		failBlock: [self assert: false];
		compile.
	! !

!MCStWriterTest methodsFor: 'data' stamp: ''!
expectedClassDefinitionA
 ^ '
MCMock subclass: #MCMockClassA
	instanceVariableNames: ''ivar''
	classVariableNames: ''CVar InitializationOrder''
	poolDictionaries: ''''
	category: ''MonticelloMocks''!!

!!MCMockClassA commentStamp: '''' prior: 0!!
This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.!!
'! !

!MCStWriterTest methodsFor: 'testing' stamp: ''!
testMethodDefinitionWithBangs

	| methodDefinition |
	
	methodDefinition := (RGMethodDefinition 
		realClass: self class
		selector: #methodWithBangs) asMCMethodDefinition.	
	methodDefinition setTimeStamp: ''.
	writer visitMethodDefinition: methodDefinition.
										
	self assertContentsOf: stream contents match: self expectedMethodDefinitionWithBangs.
	
	stream := ChunkReadStream on: stream contents readStream.
	
	self assert: stream next isAllSeparators.
	self assertChunkIsWellFormed: stream next.
	self assertMethodChunkIsWellFormed: stream next.
	self assert: stream next isAllSeparators ! !

!MCStWriterTest methodsFor: 'asserting' stamp: ''!
assertChunkIsWellFormed: chunk
	self class compiler
		source:  chunk readStream ;
		class: UndefinedObject;
		noPattern: true;
		failBlock:  [self assert: false];
		compile! !

!MCStWriterTest methodsFor: 'data' stamp: ''!
expectedClassDefinitionB
 ^ '
MCMock subclass: #MCMockClassB
	instanceVariableNames: ''ivarb''
	classVariableNames: ''CVar''
	poolDictionaries: ''MCMockAPoolDictionary''
	category: ''MonticelloMocks''!!

MCMockClassB class
	instanceVariableNames: ''ciVar''!!

!!MCMockClassB commentStamp: '''' prior: 0!!
This comment has a bang!!!! Bang!!!! Bang!!!!!!
'! !

!MCStWriterTest methodsFor: 'testing' stamp: ''!
testMethodDefinition
	writer visitMethodDefinition: (RGMethodDefinition realClass: self mockClassA selector: #one) asMCMethodDefinition.
	self assert: (stream contents matchesRegex: self expectedMethodDefinition).
	
	stream := ChunkReadStream on: stream contents readStream.
	
	self assert: stream next isAllSeparators.
	self assertChunkIsWellFormed: stream next.
	self assertMethodChunkIsWellFormed: stream next.
	self assert: stream next isAllSeparators ! !

!MCStWriterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	stream := String new writeStream.
	writer := MCStWriter on: stream.
! !

!MCSubDirectoryRepository commentStamp: ''!
A MCDirectoryRepository that looks in subdirectories too.!
!MCSubDirectoryRepository methodsFor: 'i/o' stamp: 'nil'!
splitNameVersionExtensionFor: aBaseName

	| file version |
	file := aBaseName asFileReference.
	version := (file extensions at: file extensions size - 1) asNumber.
	^ { (file base copyUpTo: $.). version. file extension }.
	
	
	
! !

!MCSubDirectoryRepository methodsFor: 'interface' stamp: 'nil'!
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: 'enumeration' stamp: 'nil'!
allDirectories
	^directory allDirectories ! !

!MCSubDirectoryRepository methodsFor: 'i/o' stamp: 'nil'!
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 asSeconds ]]).	"minimum age"
		fileScore := fileScore isEmpty ifTrue: [ SmallInteger maxVal  ]
			ifFalse: [ fileScore min ].
		possible add: { dirScore. fileScore. dir } ].
	
	^ (possible first third) / aBaseName! !

!MCSubDirectoryRepository methodsFor: 'user interface' stamp: 'nil'!
description
	^ (directory / '*') fullName
! !

!MCSubDirectoryRepository methodsFor: 'i/o' stamp: 'nil'!
writeStreamForFileNamed: aString replace: shouldReplace do: aBlock 

	| fileReference |
	fileReference := (self findFullNameForWriting: aString).
	fileReference parent ensureCreateDirectory.
	shouldReplace ifTrue: [ fileReference ensureDelete ].
	fileReference binaryWriteStreamDo: [ :stream | aBlock value: stream ]! !

!MCSubDirectoryRepository methodsFor: 'i/o' stamp: 'nil'!
readStreamForFileNamed: aString do: aBlock

	| fileReference |
	fileReference := (self findFullNameForReading: aString) reference.
	fileReference binaryReadStreamDo: [ :stream | ^ aBlock value: stream ].! !

!MCSubDirectoryRepository methodsFor: 'i/o' stamp: 'nil'!
findFullNameForReading: aBaseName
	"Answer the latest version of aBaseName"
	^((directory glob: [ :each | each basename = aBaseName])
		sorted: [ :a :b | a modificationTime < b modificationTime ])
		first.! !

!MCSubDirectoryRepository class methodsFor: 'user interface' stamp: 'nil'!
description
	^ 'directory with subdirectories'! !

!MCSubDirectoryRepositoryTest commentStamp: ''!
I am not a subclass of MCRepositoryTest because my purpose was to show that a bug had been fixed and my author didn't feel like implementing all the reuirements of MCRepositoryTests!
!MCSubDirectoryRepositoryTest methodsFor: 'tests' stamp: ''!
testIssue7368
	"This is not a usage example. Hopefully the ugly private method under test will be refactored out of existence soon ;)"

	| collection |
	collection := MCSubDirectoryRepository new splitNameVersionExtensionFor: 'Spec-Core-AuthorName.120.mcz'.
	self assert: collection first equals: 'Spec-Core-AuthorName'.
	self assert: collection second equals: 120.
	self assert: collection third equals: 'mcz'.! !

!MCSystemCategoryParser commentStamp: ''!
A MCSystemCategoryParser extracts or set a category/protocol to the corresponding MCOrganizationDefinition.!
!MCSystemCategoryParser methodsFor: 'accessing' stamp: 'nil'!
category
	| tokens  |
	tokens := source parseLiterals.
	tokens size = 3 ifFalse: [self error: 'Unrecognized category definition'].
	^ tokens at: 3! !

!MCSystemCategoryParser methodsFor: 'actions' stamp: 'nil'!
addDefinitionsTo: aCollection
	| definition |
	definition := aCollection 
					detect: [:ea | ea isOrganizationDefinition ] 
					ifNone: [aCollection add: (MCOrganizationDefinition categories: #())].
	definition categories: (definition categories copyWith: self category).! !

!MCSystemCategoryParser class methodsFor: 'factory identification hook' stamp: 'nil'!
pattern
	^ 'SystemOrganization*'! !

!MCTestCase commentStamp: ''!
Abstract superclass for monticello tests!
!MCTestCase methodsFor: 'mocks' stamp: ''!
mockVersionWithAncestor: aMCVersion 
	^ MCVersion
		package: self mockPackage
		info: (self mockVersionInfoWithAncestor: aMCVersion info)
		snapshot: self mockSnapshot! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockVersionWithDependencies
	^ MCVersion 
		package: self mockPackage
		info: self mockVersionInfo
		snapshot: self mockSnapshot
		dependencies: self mockDependencies! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockSnapshot
	^ MCSnapshotResource current snapshot! !

!MCTestCase methodsFor: 'compiling' stamp: ''!
restoreMocks
	self mockSnapshot updatePackage: self mockPackage! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockClass: className super: superclassName
	^ MCClassDefinition
		name:  className
		superclassName:  superclassName
		traitComposition: '{}'
		classTraitComposition: '{}'
		category: self mockCategoryName
		instVarNames: #()
		classVarNames: #()
		poolDictionaryNames: #()
		classInstVarNames: #()
		type: #normal
		comment: (self commentForClass: className)
		commentStamp: (self commentStampForClass: className)! !

!MCTestCase methodsFor: 'asserting' stamp: ''!
assertPackage: actual matches: expected
	self assert: actual equals: expected! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockVersion
	^ MCVersion 
		package: self mockPackage
		info: self mockVersionInfo
		snapshot: self mockSnapshot! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockExtensionMethodCategory
	^ '*MonticelloMocks'! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockVersionName
	^ 'MonticelloTest-xxx.1'! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockDependencies
	^ Array with: (MCVersionDependency package: self mockEmptyPackage info: (self mockVersionInfo: 'x'))! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
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: ''!
mockInstanceA
	^ self mockClassA new! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
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: ''!
commentStampForClass: name
	^ 'tester-', name,  ' 1/1/2000 00:00'! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockPackage
	^ MCSnapshotResource mockPackage! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockCategoryName
	^ 'MonticelloMocks'! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
commentForClass: name
	^ 'This is a comment for ', name! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockVersionInfo
	^ self treeFrom: #(d ((b ((a))) (c)))! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
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: ''!
mockMessageString
	^ 'A version generated for testing purposes.'! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockToken: aSymbol
	^ MCMockDefinition token: aSymbol! !

!MCTestCase methodsFor: 'asserting' stamp: ''!
assertVersion: actual matches: expected
	self assertPackage: actual package matches: expected package.	
	self assertVersionInfo: actual info matches: expected info.
	self assertSnapshot: actual snapshot matches: expected snapshot.! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockEmptyPackage
	^ MCPackage named: 'Mock empty package'! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockOverrideMethodCategory
	^ self mockExtensionMethodCategory, '-override'! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockClassB
	^ testingEnvironment at: #MCMockClassB! !

!MCTestCase methodsFor: 'asserting' stamp: ''!
assertSnapshot: actual matches: expected
	| diff |
	diff := actual patchRelativeToBase: expected.
	self assert: diff isEmpty
! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
mockClassA
	^ testingEnvironment at: #MCMockClassA! !

!MCTestCase methodsFor: 'asserting' stamp: ''!
assertVersionInfo: actual matches: expected
	self assert: actual name equals: expected name.
	self assert: actual message equals: expected message.
	self assert: actual ancestors size equals: expected ancestors size.
	actual ancestors with: expected ancestors do: [ :a :e | self assertVersionInfo: a matches: e ]! !

!MCTestCase methodsFor: 'mocks' stamp: ''!
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: 'compiling' stamp: ''!
compileClass: aClass source: source category: category
	aClass compileSilently: source classified: category! !

!MCTestCase methodsFor: 'running' stamp: ''!
runCase
	MCCacheRepository disableCacheDuring: [ ^ super runCase ].! !

!MCTestCase methodsFor: 'compiling' stamp: ''!
change: aSelector toReturn: anObject
	self 
		compileClass: self mockClassA 
		source: aSelector, ' ^ ', anObject printString 
		category: 'numeric'! !

!MCTestCase class methodsFor: 'testing' stamp: ''!
isUnitTest
	^false! !

!MCTestCase class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = MCTestCase! !

!MCTestCase class methodsFor: 'accessing' stamp: ''!
resources
	^ Array with: MCSnapshotResource! !

!MCThreeWayMerger commentStamp: ''!
A MCThreeWayMerger is more advanced merge operation.
Operations are subclasses of MCPatchOperation:  addition (MCAddition), modification of an entity (MCModification ) and removal (MCRemoval).
!
!MCThreeWayMerger methodsFor: 'operations' stamp: 'nil'!
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: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	index := MCDefinitionIndex new.
	provisions := Set new! !

!MCThreeWayMerger methodsFor: 'accessing' stamp: 'nil'!
provisions
	^ provisions! !

!MCThreeWayMerger methodsFor: 'operations' stamp: 'nil'!
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: 'nil'!
removalForDefinition: aDefinition
	^ operations ifNotNil:
		[operations
			detect: [:ea | (ea definition isRevisionOf: aDefinition) and: [ea isRemoval]]
			ifNone: []]! !

!MCThreeWayMerger methodsFor: 'operations' stamp: 'nil'!
baseSnapshot
	^ (MCSnapshot fromDefinitions: index definitions)! !

!MCThreeWayMerger methodsFor: 'accessing' stamp: 'nil'!
operations
	^ operations ifNil: [operations := OrderedCollection new]! !

!MCThreeWayMerger methodsFor: 'operations' stamp: 'nil'!
modificationConflictForDefinition: aDefinition
	^ self conflicts 
		detect: [:ea |
			(ea definition isRevisionOf: aDefinition) and:
				[ea operation isModification]] 
		ifNone: []! !

!MCThreeWayMerger methodsFor: 'operations' stamp: 'nil'!
removeOperation: anOperation
	operations remove: anOperation! !

!MCThreeWayMerger methodsFor: 'operations' stamp: 'nil'!
addOperation: anOperation
	self operations add: anOperation! !

!MCThreeWayMerger methodsFor: 'operations' stamp: 'nil'!
applyPatch: aPatch
	aPatch applyTo: self! !

!MCThreeWayMerger methodsFor: 'operations' stamp: 'nil'!
redundantAdds
	^ redundantAdds ifNil: [redundantAdds := Set new]! !

!MCThreeWayMerger methodsFor: 'operations' stamp: 'nil'!
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: 'nil'!
addBaseSnapshot: aSnapshot
	aSnapshot definitions do:
		[:ea |
		index add: ea.
		provisions addAll: ea provisions]! !

!MCThreeWayMerger class methodsFor: 'instance creation' stamp: 'nil'!
base: aSnapshot target: targetSnapshot ancestor: ancestorSnapshot
	^ self base: aSnapshot patch: (targetSnapshot patchRelativeToBase: ancestorSnapshot)! !

!MCThreeWayMerger class methodsFor: 'instance creation' stamp: 'nil'!
base: aSnapshot patch: aPatch
	aPatch isEmpty ifTrue: [MCNoChangesException signal].
	^ self new
		addBaseSnapshot: aSnapshot;
		applyPatch: aPatch;
		yourself
		! !

!MCTool commentStamp: ''!
Common superclass for Monticello tools

Placeholder for a MCVersionCache for MCLazyVersionInfo!
!MCTool methodsFor: 'morphic ui' stamp: ''!
showModally
	modal := true.
	self window openModal.
	morph := nil.
	^ modalValue! !

!MCTool methodsFor: 'utilities' stamp: ''!
allManagers

	^ MCWorkingCopy allManagers ! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
buttonSelected
	^ false! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
buttonEnabled
	^ true! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
buttonRow
	^ self buttonRow: self buttonSpecs! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
setDefaultFocus
	"set the default focus on the morph elements.
	specializ this in subclasses"! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
treeMorph: listSymbol selection: selectionSymbol menu: menuSymbol
	^ SimpleHierarchicalListMorph
		on: self
		list: listSymbol
		selected: selectionSymbol
		changeSelected: (selectionSymbol, ':') asSymbol
		menu: menuSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
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: ''!
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: ''!
buttonSpecs
	^ #()! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
listMorph: listSymbol selection: selectionSymbol menu: menuSymbol
	^ PluggableListMorph
		on: self
		list: listSymbol
		selected: selectionSymbol
		changeSelected: (selectionSymbol, ':') asSymbol
		menu: menuSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
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: ''!
accept
	" do nothing by default"! !

!MCTool methodsFor: 'utilities' stamp: ''!
interactionModel
	^ self! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
close
	self window delete! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
findTextMorph: aSymbol
	^ morph submorphs detect: [:ea | (ea respondsTo: #getTextSelector) and: [ea getTextSelector = aSymbol]] ifNone: []! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
listMorph: listSymbol selection: selectionSymbol menu: menuSymbol icon: iconSelector
	^ (PluggableIconListMorph
		on: self
		list: listSymbol
		selected: selectionSymbol
		changeSelected: (selectionSymbol, ':') asSymbol
		menu: menuSymbol)
			getIconSelector: iconSelector;
			yourself! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
getMenu: aMenu
	^aMenu! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
listMorph: listSymbol
	^ self
		listMorph: (listSymbol, 'List') asSymbol
		selection: (listSymbol, 'Selection') asSymbol
		menu: (listSymbol, 'ListMenu:') asSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
performButtonAction: anActionSelector enabled: anEnabledSelector
	(self perform: anEnabledSelector) 
		ifTrue: [ self perform: anActionSelector ]! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
label
	^ label ifNil: [self defaultLabel]! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
preferredColor  
	^ (Color r: 0.627 g: 0.69 b: 0.976)! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
treeMorph: listSymbol
	^ self
		treeMorph: (listSymbol, 'Tree') asSymbol
		selection: (listSymbol, 'SelectionWrapper') asSymbol
		menu: (listSymbol, 'TreeMenu:') asSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
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: ''!
shoutAboutToStyle: aPluggableShoutMorphOrView
	^ false! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
initialExtent
	^ 500@500! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
label: aString
	label := aString! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
arrowKey: aCharacter from: aPluggableListMorph 
	"backstop"! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
fillMenu: aMenu fromSpecs: anArray
	anArray do:
		[:spec |
		aMenu
			add: spec first
			target: self
			selector: spec second
			argumentList: (spec allButFirst: 2)].
	^ aMenu! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
listMorph: listSymbol selection: selectionSymbol
	^ PluggableListMorph
		on: self
		list: listSymbol
		selected: selectionSymbol
		changeSelected: (selectionSymbol, ':') asSymbol! !

!MCTool methodsFor: 'accessing' stamp: ''!
minimumExtent
	"Answer the minumum extent for the tool."
	
	^100@100! !

!MCTool methodsFor: 'opening' stamp: ''!
showLabelled: labelString
	
	modal := false.
	self label: labelString.
	self window openInWorld.
	self setDefaultFocus.
	^ self window.! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
summary: aString
	" do nothing by default"! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
window
	^ morph ifNil: [morph := self buildWindow]! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
menu
	" returns nil to let the editing mode offer the right menu"
	^ nil! !

!MCTool methodsFor: 'opening' stamp: ''!
show
	"Open the tool returning the window."

	modal := false.
	self window openInWorld.
	self setDefaultFocus.
	^ self window! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
answer: anObject
	modalValue := anObject.
	self close.! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
findListMorph: aSymbol
	^ morph submorphs detect: [:ea | (ea respondsTo: #getListSelector) and: [ea getListSelector = aSymbol]] ifNone: []! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
widgetSpecs
	^ #()! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
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: ''!
textMorph: aSymbol
	| textMorph |
	textMorph := RubPluggableTextMorph new
		getTextSelector: aSymbol;
		setTextSelector: (aSymbol , ':') asSymbol;
		on: self;
		beWrapped;
		hScrollbarShowNever;
		beForSmalltalkScripting;
		yourself.
	textMorph announcer when: RubTextAcceptRequest send: #accept to: self.
	textMorph hasUnacceptedEdits: false.
	^ textMorph! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
defaultAnnotationPaneHeight 
	"Answer the receiver's preferred default height for new annotation panes."
	^ 25! !

!MCTool methodsFor: 'morphic ui' stamp: ''!
buttonState
	^ false! !

!MCTool class methodsFor: 'accessing' stamp: ''!
mcVersionCache
	^ MCVersionCache
		ifNil: [ MCVersionCache := LRUCache new maximumWeight: 32 ]! !

!MCTool class methodsFor: 'class initialization' stamp: ''!
initMCVersionCache
	MCVersionCache := nil! !

!MCTool class methodsFor: 'utilities' stamp: ''!
newRepository
	"Create a new monticello repository"
	| 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]! !

!MCTool class methodsFor: 'class initialization' stamp: ''!
flushMCVersionCache
	MCVersionCache := nil.
	Smalltalk garbageCollect! !

!MCTraitDefinition commentStamp: ''!
A MCTraitDefinition represents a trait.!
!MCTraitDefinition methodsFor: 'initializing' stamp: 'nil'!
initializeWithName: classNameString 
	traitComposition:  traitCompositionString
	category:  categoryString
	instVarNames: ivarArray
	comment:  commentString  
	commentStamp:   commentStampString
					
		name := classNameString asSymbol.
		traitComposition := traitCompositionString.
	    category := categoryString.
		comment := commentString withInternalLineEndings.
		commentStamp :=  commentStampString ifNil: [self defaultCommentStamp].
		variables := OrderedCollection  new.
		self addVariables: ivarArray ofType: MCInstanceVariableDefinition.
! !

!MCTraitDefinition methodsFor: 'comparing' stamp: 'nil'!
= 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: [self classTraitCompositionString = aDefinition classTraitCompositionString
		and: [category = aDefinition category
		and: [self slotDefinitionString = aDefinition slotDefinitionString
		and: [self classInstVarNames  = aDefinition classInstVarNames  
		and: [comment = aDefinition comment]]]]]]]! !

!MCTraitDefinition methodsFor: 'initializing' stamp: 'nil'!
initializeWithName: classNameString 
	traitComposition:  traitCompositionString
	classTraitComposition: aClassTraitComposition
	category:  categoryString
	instVarNames: ivarArray
	comment:  commentString  
	commentStamp:   commentStampString
					
		name := classNameString asSymbol.
		traitComposition := traitCompositionString.
	    category := categoryString.
		comment := commentString withInternalLineEndings.
		commentStamp :=  commentStampString ifNil: [self defaultCommentStamp].
		variables := OrderedCollection  new.
		self addVariables: ivarArray ofType: MCInstanceVariableDefinition.
		
	classTraitComposition := aClassTraitComposition! !

!MCTraitDefinition methodsFor: 'comparing' stamp: 'nil'!
hash
	| hash |
	hash := String stringHash: name initialHash: 0.
	hash := String stringHash: self traitCompositionString initialHash: hash.
	hash := String stringHash: (category ifNil: ['']) initialHash: hash.
	^ hash
! !

!MCTraitDefinition methodsFor: 'printing' stamp: 'nil'!
slotDefinitionString

	variables ifNil: [ ^ '{ }' ].

	^ self needsSlotClassDefinition 
		ifTrue: [ self instanceVariables asString ]
		ifFalse: [ 
			String streamContents: [ :stream |
				stream nextPutAll: '{ '.
				self instanceVariables 
					do: [ :each | stream print: each name ]
					separatedBy: [ stream nextPutAll: ' . ' ].
				stream nextPutAll: ' }']]! !

!MCTraitDefinition methodsFor: '*MonticelloTonel-Core' stamp: ' 1/5/2022 20:56:19'!
isTraitDefinition
	^ true! !

!MCTraitDefinition methodsFor: 'printing' stamp: 'nil'!
printClassDefinitionOn: stream

	^ self printMetaDefinitionOn: stream! !

!MCTraitDefinition methodsFor: 'comparing' stamp: 'nil'!
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.)"

	self hasTraitComposition
		ifFalse: [ ^ Array new ].

	^ (((RBParser parseExpression: self traitCompositionString)
		allChildren select: [ :e | e isVariable ])
		collect: [ :e | e name ]
		as: Set) asArray! !

!MCTraitDefinition methodsFor: 'initialization' stamp: 'nil'!
initializeWithName: classNameString traitComposition: traitCompositionString category: categoryString instVarNames: ivarArray classTraitComposition: classTraitCompositionString classInstVarNames: civarArray comment: commentString commentStamp: commentStampString
	self
		initializeWithName: classNameString
		traitComposition: traitCompositionString
		category: categoryString
		instVarNames: ivarArray
		classInstVarNames: civarArray
		comment: commentString
		commentStamp: commentStampString.

		classTraitComposition := classTraitCompositionString! !

!MCTraitDefinition methodsFor: 'installing' stamp: 'nil'!
createClass
	| trait |
	
	trait := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: name;
			traitComposition: (Smalltalk compiler evaluate: self traitCompositionString);
			slots: self instanceVariables;
			package:  category;
			beTrait ].					


	trait ifNotNil: [
		trait classComment: comment stamp: commentStamp.
		self classInstanceVariables ifNotEmpty: [
			trait classSide slots: self classInstanceVariables ]].
	^trait! !

!MCTraitDefinition methodsFor: 'initializing' stamp: 'nil'!
initializeWithName: classNameString 
	traitComposition:  traitCompositionString
	category:  categoryString
	instVarNames: ivarArray
	classInstVarNames: civarArray
	comment:  commentString  
	commentStamp:   commentStampString
					
		name := classNameString asSymbol.
		traitComposition := traitCompositionString.
	    category := categoryString.
		comment := commentString withInternalLineEndings.
		commentStamp :=  commentStampString ifNil: [self defaultCommentStamp].
		variables := OrderedCollection  new.
		self addVariables: ivarArray ofType: MCInstanceVariableDefinition.
		self addVariables: civarArray ofType: MCClassInstanceVariableDefinition.! !

!MCTraitDefinition methodsFor: 'printing' stamp: 'nil'!
printDefinitionOn: stream
	stream nextPutAll: 'Trait named: #', self className;
		 cr;
		 tab;
		 nextPutAll: 'uses: ';
		 nextPutAll: self traitCompositionString;
		 cr.

	self instanceVariablesString isEmpty ifFalse: [
			stream 
				tab;
				nextPutAll: 'instanceVariableNames: ';
				nextPut: $';
		 		nextPutAll: self instanceVariablesString;
				nextPut: $';
				cr ].
		
	stream
		 tab;
		 nextPutAll: 'package: ';
		 store: self category asString
! !

!MCTraitDefinition methodsFor: '*Ring-Definitions-Monticello' stamp: 'nil'!
asRingDefinition

	| ring |
	ring := ( RGTraitDefinition named: self className)
		category: self category;
		superclassName: self superclassName;  
		traitCompositionSource: self traitCompositionString;
		comment: self comment;
		stamp: self commentStamp;
		definitionSource: self definitionString;
		withMetaclass.
		
	ring classSide 
		traitCompositionSource: self classTraitCompositionString;
		definitionSource: self classDefinitionString.
	^ring! !

!MCTraitDefinition methodsFor: '*Ring-Monticello' stamp: ''!
ensureRingDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		| def classTraitDef |
		def := anRGEnvironment ensureTraitNamed: self className asSymbol.
		classTraitDef := anRGEnvironment ensureMetaclassTraitNamed: (self className, ' classTrait') asSymbol.
		def classTrait: classTraitDef.
		classTraitDef baseTrait: def.
		def traitComposition: (self traitCompositionFrom: self traitComposition parent: def).
"		classTraitDef traitComposition: (self traitCompositionFrom: self classTraitComposition parent: classTraitDef)".		
		((self superclassName = #nil) or: [ self superclassName isNil "for traits"])
			ifTrue: [ def superclass: def ]
			ifFalse: [ def superclass: (anRGEnvironment ensureClassNamed: superclassName ) ].
		def category: self category.
		def comment: (
			(RGComment parent: def) 
				content: self comment;
				author: (self authorForStamp: self commentStamp);
				time: (self timeForStamp: self commentStamp);
				yourself).
		def]. 
	! !

!MCTraitDefinition methodsFor: 'initializing' stamp: 'nil'!
initializeWithName: classNameString 
	traitComposition:  traitCompositionString
	category:  categoryString
	comment:  commentString  
	commentStamp:   commentStampString
					
		name := classNameString asSymbol.
		traitComposition := traitCompositionString.
	     category := categoryString.
		comment := commentString withInternalLineEndings.
		variables := OrderedCollection  new.
		commentStamp :=  commentStampString ifNil: [self defaultCommentStamp]
! !

!MCTraitDefinition methodsFor: '*Ring-Definitions-Monticello' stamp: 'nil'!
printMetaDefinitionOn: stream

	stream nextPutAll: self className, ' classTrait'.
	self printDefinitionBodyOn: stream
! !

!MCTraitDefinition methodsFor: 'printing' stamp: 'nil'!
classSlotDefinitionString

	^ self needsSlotClassDefinition 
		ifTrue: [ self classInstanceVariables asString ]
		ifFalse: [ 
			String streamContents: [ :stream |
				stream nextPutAll: '{ '.
				self classInstanceVariables 
					do: [ :each | stream print: each name ]
					separatedBy: [ stream nextPutAll: ' . ' ].
				stream nextPutAll: ' }']]! !

!MCTraitDefinition methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor
	^ aVisitor visitTraitDefinition: self
! !

!MCTraitDefinition methodsFor: 'testing' stamp: 'nil'!
hasClassInstanceVariables
	^ false

! !

!MCTraitDefinition methodsFor: '*Ring-Definitions-Monticello' stamp: 'nil'!
classDefinitionString
	"Answer a string describing the class-side definition."
	
	^String streamContents: [:stream | self printMetaDefinitionOn: stream]! !

!MCTraitDefinition class methodsFor: 'instance creation api' stamp: 'nil'!
name: classNameString traitComposition: traitCompositionString category: categoryString instVarNames: ivarArray classInstVarNames: civarArray classTraitComposition: classTraitCompositionString comment: commentString commentStamp: commentStamp

	^ self new
		initializeWithName: classNameString
		traitComposition: traitCompositionString
		category: categoryString
		instVarNames: ivarArray
		classTraitComposition: classTraitCompositionString
		classInstVarNames: civarArray
		comment: commentString
		commentStamp: commentStamp

		! !

!MCTraitDefinition class methodsFor: 'instance creation' stamp: 'nil'!
name: classNameString traitComposition: traitCompositionString category: categoryString comment: commentString commentStamp: aString5 

	^ self new
		initializeWithName: classNameString
		traitComposition: traitCompositionString
		category: categoryString
		instVarNames: ''
		classTraitComposition: nil
		classInstVarNames: ''
		comment: commentString
		commentStamp: aString5
! !

!MCTraitParser commentStamp: ''!
A MCTraitParser extracts an MCTraitDefinition from the source.!
!MCTraitParser methodsFor: 'actions' stamp: 'nil'!
addDefinitionsTo: aCollection
	| node compositionIndex categoryIndex slotsIndex traitName traitCompositionString slotsArray argumentNode categoryString definition |
	 
	node := RBParser parseExpression: source.
	
	node selector caseOf: { 
		[#named:] -> [ 
			compositionIndex := nil. slotsIndex := nil. categoryIndex := nil ].
		[#named:uses:] -> [ 
			compositionIndex := 2. slotsIndex := nil. categoryIndex := nil ].
		[#named:uses:category:] -> [ 
			compositionIndex := 2. slotsIndex := nil. categoryIndex := 3 ].
		[#named:uses:package:] -> [ 
			compositionIndex := 2. slotsIndex := nil. categoryIndex := 3 ].
		[#named:uses:slots:category:] -> [ 
			compositionIndex := 2. slotsIndex := 3. categoryIndex := 4 ].
		[#named:uses:slots:package:] -> [ 
			compositionIndex := 2. slotsIndex := 3. categoryIndex := 4 ]
	} otherwise: [ self error: 'Unknown trait building selector' ].

	traitName := node arguments first value.

	traitCompositionString := compositionIndex 
		ifNotNil: [ 
			argumentNode := node arguments at: compositionIndex.
			argumentNode source copyFrom: argumentNode sourceInterval first to: argumentNode sourceInterval last ]
		ifNil: [ '' ].

	slotsArray := slotsIndex 
		ifNotNil: [ 
			argumentNode := node arguments at: slotsIndex.
			argumentNode statements collect: [ :each |
				each source copyFrom: each sourceInterval first to: each sourceInterval last ] ]
		ifNil: [ Array new ].

	categoryString := categoryIndex 
		ifNotNil: [ 
			argumentNode := node arguments at: categoryIndex.
			argumentNode source copyFrom: argumentNode sourceInterval first to: argumentNode sourceInterval last ]
		ifNil: [ 'Unclassified' ].

	definition := MCTraitDefinition
		name: traitName
		traitComposition: traitCompositionString
		category:  categoryString
		instVarNames:  slotsArray
		classInstVarNames: ''
		classTraitComposition: nil
		comment:  ''  
		commentStamp: ''.
		
	aCollection add: definition.! !

!MCTraitParser class methodsFor: 'factory identification hook' stamp: 'nil'!
pattern
	^ 'Trait named:*'! !

!MCVariableDefinition commentStamp: ''!
A MCVariableDefinition represents a variable.!
!MCVariableDefinition methodsFor: 'comparing' stamp: 'nil'!
= other
	^ (self species = other species)
		and: [self name = other name]! !

!MCVariableDefinition methodsFor: 'comparing' stamp: 'nil'!
hash
	^ name hash! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isClassVariable
	^ false! !

!MCVariableDefinition methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(; nextPutAll: self name; nextPut: $)! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isPoolImport
	^ false! !

!MCVariableDefinition methodsFor: 'accessing' stamp: 'nil'!
name
	^ name! !

!MCVariableDefinition methodsFor: 'accessing' stamp: 'nil'!
name: aString
	name := aString! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isOrderDependend
	^true! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isClassInstanceVariable
	^ false! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isInstanceVariable
	^ false! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isClassInstanceVariableDefinition
	^ false! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isInstanceVariableDefinition
	^ false! !

!MCVariableDefinition class methodsFor: 'instance creation' stamp: 'nil'!
name: aString
	^ self new name: aString
	! !

!MCVersion commentStamp: ''!
A Metacello version!
!MCVersion methodsFor: 'actions' stamp: 'nil'!
addToCache
	MCCacheRepository uniqueInstance storeVersion: self! !

!MCVersion methodsFor: '*MonticelloGUI' stamp: ''!
open
	(MCVersionInspector new version: self) show! !

!MCVersion methodsFor: 'enumerating' stamp: 'nil'!
withAllDependenciesDo: aBlock ifUnresolved: failBlock
	| dict |
	dict := Dictionary new.
	self allDependenciesNotIn: dict do: aBlock ifUnresolved: failBlock.
	aBlock value: self! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
fileName
	^ info name, '.', self writerClass extension! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
loadCompletePackageSnapshot
	| definitions |
	definitions := OrderedCollection withAll: package snapshot definitions.
	
	self dependencies 
		do: [ :each| definitions addAll: each package snapshot definitions ]
		displayingProgress: [ :item| 'Loading dependencies from: ', item package name ].
	
	^ MCSnapshot fromDefinitions: definitions
	
	! !

!MCVersion methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(; print: self info; nextPut: $).! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
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: 'enumerating' stamp: 'nil'!
allAvailableDependenciesDo: aBlock
	
	self dependencies do:
		[:ea |
		[ | version |version := ea resolve.
		version allAvailableDependenciesDo: aBlock.
		aBlock value: version]
			on: Error do: []]! !

!MCVersion methodsFor: 'enumerating' stamp: 'nil'!
allDependenciesDo: aBlock
	self allDependenciesDo: aBlock ifUnresolved: [:ignored | true]! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
changes
	^ self completeSnapshot patchRelativeToBase: self completePackageSnapshot! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
dependencies
	^ dependencies ifNil: [#()]! !

!MCVersion methodsFor: 'testing' stamp: 'nil'!
canOptimizeLoading
	"Answer wether I can provide a patch for the working copy without the usual diff pass"
	^false! !

!MCVersion methodsFor: 'testing' stamp: 'nil'!
isCacheable
	^true! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
completeSnapshot
	^ completeSnapshot ifNil: [ completeSnapshot := self loadCompleteSnapshot ]! !

!MCVersion methodsFor: 'initialization' stamp: 'nil'!
setPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection
	package := aPackage.
	info := aVersionInfo.
	snapshot := aSnapshot.
	dependencies := aCollection! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
info
	^ info! !

!MCVersion methodsFor: 'actions' stamp: 'nil'!
adopt
	self workingCopy adopt: self! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
workingCopy
	^ package workingCopy! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
completePackageSnapshot
	"Answer with a snapshot of current working copy of this package and all its dependencies."
	^self loadCompletePackageSnapshot! !

!MCVersion methodsFor: 'actions' stamp: 'nil'!
load
	MCVersionLoader loadVersion: self! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
loadCompleteSnapshot
	|definitions|
	
	definitions := OrderedCollection withAll: self snapshot definitions.
	
	self dependencies 
		do: [ :each| definitions addAll: each resolve completeSnapshot definitions ]
		displayingProgress: [ :item| 'Loading dependencies from: ', item package name ].
	
	^ MCSnapshot fromDefinitions: definitions! !

!MCVersion methodsFor: 'enumerating' stamp: 'nil'!
allDependenciesDo: aBlock ifUnresolved: failBlock
	| dict |
	dict := Dictionary new.
	self allDependenciesNotIn: dict do: aBlock ifUnresolved: failBlock! !

!MCVersion methodsFor: 'enumerating' stamp: 'nil'!
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: '*Iceberg-Adapters' stamp: ''!
directoryName
	^ (MCFileTreeRepository parseName: self info name) first , '.package'! !

!MCVersion methodsFor: 'converting' stamp: 'nil'!
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: '*MonticelloGUI' stamp: ''!
browse

	^ (MCSnapshotBrowser forSnapshot: self completeSnapshot)
		showLabelled: 'Snapshot of ', self fileName! !

!MCVersion methodsFor: 'actions' stamp: 'nil'!
fileOutOn: aStream
	self writerClass fileOut: self on: aStream! !

!MCVersion methodsFor: 'actions' stamp: 'nil'!
merge
	MCVersionMerger mergeVersion: self! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
writerClass
	^ MCMczWriter ! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
snapshot
	"lazily load snapshot..."
	snapshot isBlock ifTrue: [ 
		snapshot := snapshot value ].
	^ snapshot! !

!MCVersion methodsFor: 'initialization' stamp: 'nil'!
initializeWithPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection
	package := aPackage.
	info := aVersionInfo.
	snapshot := aSnapshot.
	dependencies := aCollection.
	self addToCache.! !

!MCVersion methodsFor: 'enumerating' stamp: 'nil'!
withAllDependenciesDo: aBlock
	self allDependenciesDo: aBlock ifUnresolved: [:ignored |].
	aBlock value: self! !

!MCVersion methodsFor: 'accessing' stamp: 'nil'!
package
	^ package! !

!MCVersion methodsFor: 'testing' stamp: 'nil'!
isDiffy
	^ false! !

!MCVersion class methodsFor: 'instance creation' stamp: 'nil'!
package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection
	^ self new initializeWithPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection! !

!MCVersion class methodsFor: 'instance creation' stamp: 'nil'!
package: aPackage info: aVersionInfo snapshot: aSnapshot
	^ self package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: #()! !

!MCVersion class methodsFor: 'instance creation' stamp: 'nil'!
package: aPackage info: aVersionInfo
	^ self package: aPackage info: aVersionInfo snapshot: aPackage snapshot! !

!MCVersion class methodsFor: 'instance creation' stamp: 'nil'!
package: aPackage
	^ self package: aPackage info: MCVersionInfo new! !

!MCVersionDependency commentStamp: ''!
Dependencies!
!MCVersionDependency methodsFor: 'testing' stamp: 'nil'!
isFulfilledBy: anAncestry
	^ anAncestry ancestors includes: versionInfo! !

!MCVersionDependency methodsFor: 'comparing' stamp: 'nil'!
= other
	^ other species = self species
		and: [other versionInfo = versionInfo
				and: [other package = package]]! !

!MCVersionDependency methodsFor: 'comparing' stamp: 'nil'!
hash
	^ versionInfo hash! !

!MCVersionDependency methodsFor: 'accessing' stamp: 'nil'!
repositoryGroup
	^ self package workingCopy repositoryGroup! !

!MCVersionDependency methodsFor: 'initialization' stamp: 'nil'!
initializeWithPackage: aPackage info: aVersionInfo
	package := aPackage.
	versionInfo := aVersionInfo! !

!MCVersionDependency methodsFor: 'testing' stamp: 'nil'!
isCurrent
	^ package hasWorkingCopy
		and: [self isFulfilled
			and: [package workingCopy modified not]]! !

!MCVersionDependency methodsFor: 'resolving' stamp: 'nil'!
resolve
	^ self repositoryGroup
		versionWithInfo: versionInfo
		ifNone: [ MCRepositoryGroup default versionWithInfo: versionInfo ifNone: []]! !

!MCVersionDependency methodsFor: 'testing' stamp: 'nil'!
isOlder
	"Answer true if I represent an older version of a package that is loaded."
	^ package hasWorkingCopy
		and: [self isFulfilled not
			and: [ self isFulfilledByAncestors
				and: [package workingCopy modified not]]]! !

!MCVersionDependency methodsFor: 'testing' stamp: 'nil'!
isFulfilledByAncestors
	^ package hasWorkingCopy
		and: [self isFulfilledByAncestorsOf: package workingCopy ancestry]! !

!MCVersionDependency methodsFor: 'testing' stamp: 'nil'!
isFulfilledByAncestorsOf: anAncestry
	^ anAncestry hasAncestor: versionInfo! !

!MCVersionDependency methodsFor: 'testing' stamp: 'nil'!
isFulfilled
	^package hasWorkingCopy
		and: [self isFulfilledBy: package workingCopy ancestry]! !

!MCVersionDependency methodsFor: 'accessing' stamp: 'nil'!
package
	^ package! !

!MCVersionDependency methodsFor: 'accessing' stamp: 'nil'!
versionInfo
	^ versionInfo! !

!MCVersionDependency class methodsFor: 'instance creation' stamp: 'nil'!
package: aPackage info: aVersionInfo
	^ self basicNew initializeWithPackage: aPackage info: aVersionInfo! !

!MCVersionHistoryBrowser commentStamp: ''!
Browser for version history!
!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
index
	"Answer the value of index"

	^ index! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
selection: aNumber
	index := aNumber.
	self changed: #selection; changed: #summary! !

!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: ''!
spawnHistory
	MCVersionHistoryBrowser new
		ancestry: self selectedInfo;
		package: package;
		show! !

!MCVersionHistoryBrowser methodsFor: '*Tool-Diff' stamp: ''!
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: '*Tool-Diff' stamp: ''!
viewChanges: otherInfo
	"View the changes between a prior version and this version."
	
	self
		viewChanges: (self selectedSnapshot patchRelativeToBase: (self snapshotForInfo: otherInfo))
		from: otherInfo name
		to: self selectedInfo name! !

!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: ''!
initialExtent
	^ 440@169.
	! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
repositoryGroup
	^ MCRepositoryGroup default! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
selectedSnapshot
	^ self snapshotForInfo: self selectedInfo! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
baseSnapshot
	^ self snapshotForInfo: ancestry! !

!MCVersionHistoryBrowser methodsFor: '*Tool-Diff' stamp: ''!
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: ''!
infos
	^ infos ifNil: [infos := ancestry withBreadthFirstAncestors]! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
selection
	^ index ifNil: [0]! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
summary
	| selInfo |
	selInfo := self selectedInfo.
	^ selInfo 
		ifNil: ['']
		ifNotNil: [selInfo summary]! !

!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: ''!
widgetSpecs
	^ #(
		((listMorph:selection:menu: list selection getMenu:) (0 0 0.3 1))
		((textMorph: summary) (0.3 0 1 1))
	 	)! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
snapshotForInfo: aVersionInfo
	^ (self repositoryGroup versionWithInfo: aVersionInfo) snapshot! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
ancestry: anAncestry
	ancestry := anAncestry! !

!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: ''!
getMenu: aMenu
	index < 1 ifTrue: [^ aMenu].
	self fillMenu: aMenu fromSpecs: 
		(Array streamContents: [ :stream |
			index > 1 ifTrue: [ stream nextPut: (Array with: 'view changes -> ', ancestry name with: #viewChanges) ].
			self selectedInfo ancestors do: [:parent |
				stream nextPut: {'view changes <- ', parent name . #viewChanges: . parent}].
			stream nextPut: #('spawn history' spawnHistory)]).
	^ aMenu! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
index: anObject
	"Set the value of index"

	index := anObject! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
package: aMCPackage
	package := aMCPackage! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
selectedInfo
	^ self infos at: self selection ifAbsent: [nil]! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: ''!
list
	^ self infos collect: [:ea | ea name]! !

!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^ ancestry name, ' History'! !

!MCVersionInfo commentStamp: ''!
Adds to the record of ancestry, other identifying details.!
!MCVersionInfo methodsFor: 'private' stamp: 'nil'!
setAncestors: someAncestors
	"Unused in MCVersionInfo"

	"It is there to allow a certain customisation with lazy stuff without kernel dependencies on LRUCache"

	ancestors := someAncestors! !

!MCVersionInfo methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
allAncestors
	^ (self allAncestorsTo: OrderedCollection new)
		sort: [ :a :b | a timeStamp >= b timeStamp ]! !

!MCVersionInfo methodsFor: 'comparing' stamp: 'nil'!
= other
	^ other species = self species
		and: [other hasID: id]! !

!MCVersionInfo methodsFor: 'initialization' stamp: 'nil'!
lazy
	^ MCLazyVersionInfo from: self! !

!MCVersionInfo methodsFor: 'comparing' stamp: 'nil'!
hash
	^ id hash! !

!MCVersionInfo methodsFor: 'private' stamp: 'nil'!
setStepChildren: someStepChildren
	"Unused in MCVersionInfo"

	"It is there to allow a certain customisation with lazy stuff without kernel dependencies on LRUCache"

	stepChildren := someStepChildren! !

!MCVersionInfo methodsFor: 'private' stamp: 'nil'!
loadAncestorsAndStepChildren
	"This code scans all the repositories to find the exact package version and reload the relevant info."

	"Transient failures, such as the lack of network connectivity, will return nothing and no errors from this code."

	"Unused in MCVersionInfo, used only in MCLazyVersionInfo."

	"It is there to allow a certain customisation with lazy stuff without kernel dependencies on LRUCache"

	(MCRepositoryGroup default
		in: [ :r | r versionWithInfo: self ifNone: [  ] ])
		ifNotNil:
			[ :aVersion | 
			self setAncestors: aVersion info ancestors.
			self setStepChildren: aVersion info stepChildren ]! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'nil'!
timeStamp
	^ DateAndTime date: date time: time! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'nil'!
versionNumber
	^ ((self name copyAfterLast: $-) copyAfter: $.) asInteger! !

!MCVersionInfo methodsFor: 'printing' stamp: 'nil'!
displayStringOn: stream
	stream nextPutAll: self name! !

!MCVersionInfo methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(; nextPutAll: self name; nextPut: $)
	! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'nil'!
summary
	^ String streamContents:
		[:s |
		s
			nextPutAll: self summaryHeader; cr; cr;
			nextPutAll: self message.
		]! !

!MCVersionInfo methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterAncestorsFor: aStep
	<stSpotterOrder: 1>
	self flag: 'rewrite for direct streaming - get rid of recursion'.
	aStep listProcessor
		title: 'Ancestors';
		allCandidates: [ self allAncestors ];
		filter: StFilterSubstring! !

!MCVersionInfo methodsFor: 'converting' stamp: 'nil'!
asDictionary
	^ Dictionary new
		at: #name put: name;
		at: #id put: id asString;
		at: #message put: message;
		at: #date put: date;
		at: #time put: time;
		at: #author put: author;
		at: #ancestors put: (self ancestors collect: [:a | a asDictionary]);
		yourself! !

!MCVersionInfo methodsFor: 'pillaging' stamp: 'nil'!
date
	^ date! !

!MCVersionInfo methodsFor: 'pillaging' stamp: 'nil'!
id
	^ id ! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'nil'!
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: 'pillaging' stamp: 'nil'!
author
	^ author! !

!MCVersionInfo methodsFor: 'pillaging' stamp: 'nil'!
time
	^ time! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'nil'!
nameWithout: packageName
	| result |
	result := self name.
	(result beginsWith: packageName , '-') ifTrue: [
		result := result copyFrom: packageName size + 2 to: result size].
	^result! !

!MCVersionInfo methodsFor: 'initialization' stamp: 'nil'!
initializeWithName: vName id: aUUID message: aString date: aDate time: aTime author: initials ancestors: aCollection stepChildren: stepCollection
	name := vName.
	id := aUUID.
	message := aString.
	date := aDate ifNil: [ Date today ].
	time := aTime.
	author := initials.
	ancestors := aCollection.
	stepChildren := stepCollection! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'nil'!
timeString
	^ date asString, ', ', time asString! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'nil'!
name
	^ name ifNil: ['<working copy>']! !

!MCVersionInfo methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
allAncestorsTo: aCollection
	self ancestors do: [ :versionInfo | 
		" do not add/process ancestry-branches which have already been added/processed "
		(aCollection includes: versionInfo) ifFalse: [ 
			aCollection add: versionInfo.
			versionInfo allAncestorsTo: aCollection ] ].
	^ aCollection! !

!MCVersionInfo methodsFor: 'private' stamp: 'nil'!
hasID: aUUID
	^ id = aUUID! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'nil'!
message
	^ message ifNil: ['']! !

!MCVersionInfo class methodsFor: 'instance creation' stamp: 'nil'!
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! !

!MCVersionInfo class methodsFor: 'instance creation' stamp: 'nil'!
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: #()! !

!MCVersionInfoWriter commentStamp: ''!
I serialize an MCVersionInfo into a given stream.
If the version info has been serialized before I output a compacted version consiting of the id.
!
!MCVersionInfoWriter methodsFor: 'serialization' stamp: 'nil'!
wrote: aVersionInfo
	self written add: aVersionInfo! !

!MCVersionInfoWriter methodsFor: 'serialization' stamp: 'nil'!
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 encodeWith: 'latin-1' ) asString; space ].
	stream nextPutAll: 'ancestors ('.
	aVersionInfo ancestors do: [:ea | self writeVersionInfo: ea].
	stream nextPutAll: ') stepChildren ('.
	aVersionInfo stepChildren do: [:ea | self writeVersionInfo: ea].
	stream nextPutAll: '))'.
	
	self wrote: aVersionInfo! !

!MCVersionInfoWriter methodsFor: 'accessing' stamp: 'nil'!
written
	^ written ifNil: [written := Set new]! !

!MCVersionInfoWriter methodsFor: 'testing' stamp: 'nil'!
isWritten: aVersionInfo
	^ self written includes: aVersionInfo! !

!MCVersionInspector commentStamp: ''!
I am a tool that visually represents an MCVersion. 

While I can be opened on anMCVersion, you've probably seen me most often after saving a package in the Monticello Browser. 

I have buttons to perform common version-related actions - like browsing, loading, and viewing changes. In my main text area, I display the following information about my version - name, author, timestamp, UUID, ancestors and log message.!
!MCVersionInspector methodsFor: 'actions' stamp: ''!
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: ''!
load
	Cursor wait showWhile: [self version load]! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: ''!
initialExtent
	^ 400@200! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: ''!
pickRepository
	| index |
	index := UIManager default chooseFrom: (self repositories collect: [:ea | ea description])
				title: 'Repository:'.
	^ index = 0 ifFalse: [self repositories at: index]! !

!MCVersionInspector methodsFor: '*Tool-Diff' stamp: ''!
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: ''!
version: aVersion
	version := aVersion! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: ''!
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: 'accessing' stamp: ''!
summary
	^self hasVersion
		ifTrue: [ self versionSummary ]
		ifFalse: [ String new ]! !

!MCVersionInspector methodsFor: 'accessing' stamp: ''!
versionSummary
	^ self version summary! !

!MCVersionInspector methodsFor: 'actions' stamp: ''!
browse

	^ self version browse! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: ''!
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: 'testing' stamp: ''!
hasVersion
	^version notNil! !

!MCVersionInspector methodsFor: 'actions' stamp: ''!
history
	(MCVersionHistoryBrowser new ancestry: self versionInfo) show! !

!MCVersionInspector methodsFor: 'actions' stamp: ''!
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: ''!
merge
	self version merge! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: ''!
repositories
	^ MCRepositoryGroup default repositories! !

!MCVersionInspector methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: ''!
widgetSpecs
	^ #(
		((buttonRow) (0 0 1 0) (0 0 0 30))
		((textMorph: summary) (0 0 1 1) (0 30 0 0))
		)! !

!MCVersionInspector methodsFor: 'accessing' stamp: ''!
versionInfo
	^ self version info! !

!MCVersionInspector methodsFor: 'actions' stamp: ''!
diff
	| ancestorVersion |
	self pickAncestor ifNotNil:
		[:ancestor |
		ancestorVersion := self version workingCopy repositoryGroup versionWithInfo: ancestor.
		(self version asDiffAgainst: ancestorVersion) open]! !

!MCVersionInspector methodsFor: 'actions' stamp: ''!
save
	
	self pickRepository 
		ifNotNil: [ :ea | 
			self version dependencies do: [ :each | ea storeVersion: each resolve ]. 
			ea storeVersion: self version ]! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^ 'Version: ', self version info name! !

!MCVersionInspector class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^ #smallSaveIcon! !

!MCVersionLoader commentStamp: ''!
A MCVersionLoader is responsible for loading a given version. !
!MCVersionLoader methodsFor: 'private' stamp: 'nil'!
announceLoadStart: aString
	SystemAnnouncer uniqueInstance announce: (MCVersionLoaderStarted new
		versionLoader: self;
		label: aString; 
		yourself)! !

!MCVersionLoader methodsFor: 'loading' stamp: 'nil'!
load
	RPackageSet withCacheDo: [   
		| version |
		version := versions first. 
		[ self ensurePackage: version package.
		  self loadWithNameLike: version info name ] asJob
				title: 'Loading ', version info name asString;
				run ]! !

!MCVersionLoader methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	versions := OrderedCollection new! !

!MCVersionLoader methodsFor: 'loading' stamp: 'nil'!
mergeVersions
	|merger|
	merger :=  MCVersionMerger new.
	merger addVersions: self localModifications.
	merger merge.! !

!MCVersionLoader methodsFor: 'checking' stamp: 'nil'!
checkIfDepIsOlder: aDependency
	^ aDependency isOlder not 
		or: [self confirm: 'load older dependency ', aDependency versionInfo name , '?']! !

!MCVersionLoader methodsFor: '*Epicea-Triggering' stamp: ''!
asEpiceaEvent

	^ EpMonticelloVersionsLoad versions: versions! !

!MCVersionLoader methodsFor: 'private' stamp: 'nil'!
announceLoadStop: aString
	SystemAnnouncer uniqueInstance announce: (MCVersionLoaderStopped new
		versionLoader: self;
		label: aString; 
		yourself)! !

!MCVersionLoader methodsFor: 'testing' stamp: 'nil'!
hasVersions

	^ versions isEmpty not! !

!MCVersionLoader methodsFor: '*Metacello-MC' stamp: ''!
versions

	^versions! !

!MCVersionLoader methodsFor: 'testing' stamp: 'nil'!
hasLocalModifications
	^ self localModifications isEmpty not
	! !

!MCVersionLoader methodsFor: 'private' stamp: 'nil'!
announceLoad: aString do: aBlock
	| returnValue |
	returnValue := nil.
	[ self announceLoadStart: aString ] ensure: [ 
		[ returnValue := aBlock value ] ensure: [ 
			self announceLoadStop: aString ] ].
	^ returnValue! !

!MCVersionLoader methodsFor: '*Epicea-Triggering' stamp: ''!
isEpiceaInterestingJobOwner

	^ true! !

!MCVersionLoader methodsFor: 'checking' stamp: 'nil'!
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: 'nil'!
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: 'loading' stamp: 'nil'!
loadWithNameLike: aString
	" this is THE central entrypoint for all loading (gopher, metacello, monticello, ...) "
	^ self announceLoad: aString do: [ self basicLoadWithNameLike: aString ]! !

!MCVersionLoader methodsFor: 'loading' stamp: 'nil'!
addVersion: aVersion
	aVersion dependencies do: [ :ea | self addDependency: ea].
	versions add: aVersion.
! !

!MCVersionLoader methodsFor: 'checking' stamp: 'nil'!
depAgeIsOk: aDependency
	^ aDependency isOlder not 
		or: [self confirm: 'load older dependency ', aDependency versionInfo name , '?']! !

!MCVersionLoader methodsFor: 'checking' stamp: 'nil'!
checkForModificationsIfCancel: cancelBlock ifMerge: mergeBlock
	| modifications |
	
	"first check if there are local packages which are dirty"
	modifications := self localModifications.
	modifications isEmpty ifTrue: [ ^ self].
	
	"ask the user what to do.. merge | overwrite | abort"
	^ self warnAboutLosingChangesTo: modifications ifCancel: cancelBlock ifMerge: mergeBlock! !

!MCVersionLoader methodsFor: 'loading' stamp: 'nil'!
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: 'private' stamp: 'nil'!
ensurePackage: mcPackage 
	RPackageOrganizer default registerPackageNamed: mcPackage name 
		! !

!MCVersionLoader methodsFor: 'private' stamp: 'nil'!
basicLoadWithNameLike: 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: 'checking' stamp: 'nil'!
localModifications
	^ versions select: [:ea | ea package workingCopy modified].
	! !

!MCVersionLoader class methodsFor: 'public api' stamp: 'nil'!
loadVersion: aVersion
	self new
		addVersion: aVersion;
		load! !

!MCVersionLoaderStarted commentStamp: ''!
Announcement sent when a Version is starting to load!
!MCVersionLoaderStarted methodsFor: 'accessing' stamp: 'nil'!
label: anObject
	label := anObject! !

!MCVersionLoaderStarted methodsFor: 'accessing' stamp: 'nil'!
versionLoader: anObject
	versionLoader := anObject! !

!MCVersionLoaderStarted methodsFor: 'accessing' stamp: 'nil'!
versionLoader
	^ versionLoader! !

!MCVersionLoaderStarted methodsFor: 'accessing' stamp: 'nil'!
label
	^ label! !

!MCVersionLoaderStopped commentStamp: ''!
Announcement sent when a Version has finished loading!
!MCVersionLoaderStopped methodsFor: 'accessing' stamp: 'nil'!
label: anObject
	label := anObject! !

!MCVersionLoaderStopped methodsFor: 'accessing' stamp: 'nil'!
versionLoader: anObject
	versionLoader := anObject! !

!MCVersionLoaderStopped methodsFor: 'accessing' stamp: 'nil'!
versionLoader
	^ versionLoader! !

!MCVersionLoaderStopped methodsFor: 'accessing' stamp: 'nil'!
label
	^ label! !

!MCVersionMerger commentStamp: ''!
Merge versions!
!MCVersionMerger methodsFor: 'actions' stamp: 'nil'!
gatherChanges
	records do: [:ea | merger addBaseSnapshot: ea packageSnapshot].
	records do: [:ea | merger applyPatch: ea mergePatch].! !

!MCVersionMerger methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	records := OrderedCollection new.
	merger := MCThreeWayMerger new.! !

!MCVersionMerger methodsFor: 'actions' stamp: 'nil'!
merge

	self gatherChanges.

	self resolveConflicts ifTrue:
		[merger load.
		records do: [:ea | ea updateWorkingCopy].
		^ true].
	
	^ false! !

!MCVersionMerger methodsFor: 'adding' stamp: 'nil'!
addVersions: aCollection
	aCollection do: [ :version|
		self addVersion: version].! !

!MCVersionMerger methodsFor: 'adding' stamp: 'nil'!
addVersion: aVersion
	
	records add: (MCMergeRecord version: aVersion).
	aVersion dependencies 
		do: [:ea | | dep |
			dep := ea resolve.
			(records anySatisfy: [:r | r version = dep]) 
				ifFalse: [self addVersion: dep]]
		displayingProgress: [ :ea| 'Searching dependency: ', ea package name]! !

!MCVersionMerger methodsFor: 'actions' stamp: 'nil'!
resolveConflicts
	(records allSatisfy: [:ea | ea isAncestorMerge]) 
		ifTrue: [
			MCNoChangesException signal. 
			^ false].
		
	^ ((MCMergeResolutionRequest new merger: merger)
			signal: 'Merging ', records first version info name) = true! !

!MCVersionMerger methodsFor: 'actions' stamp: 'nil'!
mergeWithNameLike: baseName

	self gatherChanges.
	
	self resolveConflicts ifTrue:
		[merger loadWithNameLike: baseName.
		records do: [:ea | ea updateWorkingCopy]].! !

!MCVersionMerger class methodsFor: 'action' stamp: 'nil'!
mergeVersion: aVersion
	self new
		addVersion: aVersion;
		mergeWithNameLike: aVersion info name! !

!MCVersionNameAndMessageRequest commentStamp: ''!
Notify to requests for version name and message!
!MCVersionNameAndMessageRequest methodsFor: '*MonticelloGUI' stamp: ''!
defaultAction
	^ MCSaveVersionDialog new
		versionName: suggestion;
		logMessage: suggestedLogComment;
		showModally! !

!MCVersionNameAndMessageRequest methodsFor: 'accessing' stamp: 'nil'!
suggestedName: aString
	suggestion := aString! !

!MCVersionNameAndMessageRequest methodsFor: 'accessing' stamp: 'nil'!
suggestedName
	^ suggestion! !

!MCVersionNameAndMessageRequest methodsFor: 'accessing' stamp: 'nil'!
suggestedLogComment

	^ suggestedLogComment! !

!MCVersionNameAndMessageRequest methodsFor: 'accessing' stamp: 'nil'!
suggestedLogComment: aLogMessage

	suggestedLogComment := aLogMessage! !

!MCVersionReader commentStamp: ''!
A version reader!
!MCVersionReader methodsFor: 'accessing' stamp: 'nil'!
definitions
	definitions ifNil: [self loadDefinitions].
	^ definitions! !

!MCVersionReader methodsFor: 'loading' stamp: 'nil'!
loadPackage
	self subclassResponsibility ! !

!MCVersionReader methodsFor: 'loading' stamp: 'nil'!
loadDependencies
	self subclassResponsibility ! !

!MCVersionReader methodsFor: 'accessing' stamp: 'nil'!
version
	^ self basicVersion! !

!MCVersionReader methodsFor: 'accessing' stamp: 'nil'!
dependencies
	dependencies ifNil: [self loadDependencies].
	^ dependencies! !

!MCVersionReader methodsFor: 'accessing' stamp: 'nil'!
snapshot
	^ MCSnapshot fromDefinitions: self definitions! !

!MCVersionReader methodsFor: 'accessing' stamp: 'nil'!
basicVersion
	^ MCVersion
		package: self package
		info: self info
		snapshot: [ self snapshot ]
		dependencies: self dependencies! !

!MCVersionReader methodsFor: 'loading' stamp: 'nil'!
loadDefinitions
	self subclassResponsibility ! !

!MCVersionReader methodsFor: 'loading' stamp: 'nil'!
loadVersionInfo
	self subclassResponsibility! !

!MCVersionReader methodsFor: 'accessing' stamp: 'nil'!
info
	info ifNil: [self loadVersionInfo].
	^ info! !

!MCVersionReader methodsFor: 'accessing' stamp: 'nil'!
package
	package ifNil: [self loadPackage].
	^ package! !

!MCVersionReader class methodsFor: '*MonticelloFileServices' stamp: ''!
serviceOpenVersion
	^ (SimpleServiceEntry
		provider: self
		label: 'Open version'
		selector: #openVersionFromStream:
		description: 'Open a package version'
		buttonLabel: 'Open')
		argumentGetter: [ :fileList | fileList binaryReadStream ]! !

!MCVersionReader class methodsFor: '*MonticelloFileServices' stamp: ''!
fileReaderServicesForFile: fullName suffix: suffix
	<fileService>
	self subclassesDo:[:class |
	^ ((suffix = class extension) or: [ suffix = '*' ])
		ifTrue: [class services]
		ifFalse: [Array new: 0]]
		! !

!MCVersionReader class methodsFor: '*MonticelloFileServices' stamp: ''!
serviceLoadVersion
	^ (SimpleServiceEntry
		provider: self
		label: 'Load version'
		selector: #loadVersionStream:fromDirectory:
		description: 'Load a package version'
		buttonLabel: 'Load')
		argumentGetter: [ :fileList | { fileList binaryReadStream . fileList parent } ]! !

!MCVersionReader class methodsFor: 'reading' stamp: 'nil'!
versionFromStream: aStream
	^ (self on: aStream) version! !

!MCVersionReader class methodsFor: '*MonticelloFileServices' stamp: ''!
loadVersionStream: stream fromDirectory: directory
	| version repository |
	repository := MCDirectoryRepository new directory: directory.
	version := self versionFromStream: stream.
	version workingCopy repositoryGroup addRepository: repository.
	version load.
! !

!MCVersionReader class methodsFor: 'reading' stamp: 'nil'!
on: s fileName: f
	^ self on: s! !

!MCVersionReader class methodsFor: '*MonticelloFileServices' stamp: ''!
mergeVersionStream: stream
	(self versionFromStream: stream) merge! !

!MCVersionReader class methodsFor: 'reading' stamp: 'nil'!
versionFromFile: fileName
	^ self file: fileName streamDo: [:stream | self versionFromStream: stream]! !

!MCVersionReader class methodsFor: '*MonticelloFileServices' stamp: ''!
openVersionFromStream: stream
	(self versionFromStream: stream) open! !

!MCVersionReader class methodsFor: '*MonticelloFileServices' stamp: ''!
services
	^ Array 
		with: self serviceLoadVersion
		with: self serviceMergeVersion
		with: self serviceOpenVersion! !

!MCVersionReader class methodsFor: 'actions - file' stamp: 'nil'!
openVersionFile: fileName
	(self versionFromFile: fileName) open! !

!MCVersionReader class methodsFor: 'actions - file' stamp: 'nil'!
mergeVersionFile: fileName
	(self versionFromFile: fileName) merge! !

!MCVersionReader class methodsFor: 'reading' stamp: 'nil'!
versionInfoFromStream: aStream
	^ (self on: aStream) info! !

!MCVersionReader class methodsFor: 'actions - file' stamp: 'nil'!
loadVersionFile: fileName
	| version |
	version := self versionFromFile: fileName.
	version workingCopy repositoryGroup addRepository:
		(MCDirectoryRepository new directory: fileName asFileReference).
	version load.
! !

!MCVersionReader class methodsFor: '*MonticelloFileServices' stamp: ''!
serviceMergeVersion
	^ (SimpleServiceEntry
		provider: self
		label: 'Merge version'
		selector: #mergeVersionStream:
		description: 'Merge a package version into the image'
		buttonLabel: 'Merge')
		argumentGetter: [ :fileList | fileList binaryReadStream ]! !

!MCVersionReader class methodsFor: 'reading' stamp: 'nil'!
file: fileName streamDo: aBlock
	
	^ fileName asFileReference
		readStreamDo: [ :file | aBlock value: file]! !

!MCVersionSaved commentStamp: ''!
I announce that a MCVersion was saved into a MCRepository.!
!MCVersionSaved methodsFor: 'comparing' stamp: 'nil'!
= another

	^ (self class = another class
		and: [ self version = another version ])
		and: [ self repository = another repository ]! !

!MCVersionSaved methodsFor: 'comparing' stamp: 'nil'!
hash

	^ (self class hash
		bitXor: self version hash)
		bitXor: self repository hash! !

!MCVersionSaved methodsFor: 'accessing' stamp: 'nil'!
repository

	^ repository! !

!MCVersionSaved methodsFor: 'printing' stamp: 'nil'!
printOn: aStream

	super printOn: aStream.
	
	aStream 
		nextPut: $(;
		nextPutAll: version info name;
		nextPut: $@;
		nextPutAll: repository description;
		nextPut: $).! !

!MCVersionSaved methodsFor: 'accessing' stamp: 'nil'!
version

	^ version! !

!MCVersionSaved methodsFor: 'initialization' stamp: 'nil'!
initializeWithVersion: aMCVersion repository: aMCRepository

	self initialize.
	
	version := aMCVersion.
	repository := aMCRepository.! !

!MCVersionSaved class methodsFor: 'instance creation' stamp: 'nil'!
version: aMCVersion repository: aMCRepository

	^ self basicNew
		initializeWithVersion: aMCVersion
		repository: aMCRepository;
		yourself! !

!MCVersionSorter commentStamp: ''!
Sort versions!
!MCVersionSorter methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	stepparents := Dictionary new.
	roots := OrderedCollection new.! !

!MCVersionSorter methodsFor: 'private' stamp: 'nil'!
popLayer
	depthIndex := depthIndex - 1! !

!MCVersionSorter methodsFor: 'accessing' stamp: 'nil'!
stepParentsOf: aVersionInfo
	^ (stepparents at: aVersionInfo ifAbsentPut: [Set new])! !

!MCVersionSorter methodsFor: 'private' stamp: 'nil'!
pushLayer
	depthIndex := depthIndex + 1.
	depthIndex > layers size ifTrue: [layers add: OrderedCollection new].
	! !

!MCVersionSorter methodsFor: 'accessing' stamp: 'nil'!
allAncestorsOf: aVersionInfo
	| all |
	all := Set new.
	self addAllAncestorsOf: aVersionInfo to: all.
	^ all! !

!MCVersionSorter methodsFor: 'accessing' stamp: 'nil'!
sortedVersionInfos
	layers := OrderedCollection with: OrderedCollection new.
	depthIndex := 1.
	depths := Dictionary new.
	roots do: [:ea | self processVersionInfo: ea].
	^ layers flatCollect: [:ea | ea]! !

!MCVersionSorter methodsFor: 'adding' stamp: 'nil'!
addAllAncestorsOf: aVersionInfo to: aSet
	(aSet includes: aVersionInfo) ifTrue: [^ self].
	aSet add: aVersionInfo.
	(self knownAncestorsOf: aVersionInfo) do:
		[:ea |
		self addAllAncestorsOf: ea to: aSet]! !

!MCVersionSorter methodsFor: 'accessing' stamp: 'nil'!
knownAncestorsOf: aVersionInfo
	^ aVersionInfo ancestors, (self stepParentsOf: aVersionInfo) asArray! !

!MCVersionSorter methodsFor: 'adding' stamp: 'nil'!
addVersionInfo: aVersionInfo
	roots add: aVersionInfo.
	self registerStepChildrenOf: aVersionInfo seen: Set new! !

!MCVersionSorter methodsFor: 'accessing' stamp: 'nil'!
layers
	^ layers! !

!MCVersionSorter methodsFor: 'private' stamp: 'nil'!
processVersionInfo: aVersionInfo
	(self addToCurrentLayer: aVersionInfo) ifTrue:
		[self pushLayer.
		(self knownAncestorsOf: aVersionInfo) do: [:ea | self processVersionInfo: ea].
		self popLayer]
! !

!MCVersionSorter methodsFor: 'private' stamp: 'nil'!
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: 'adding' stamp: 'nil'!
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: 'adding' stamp: 'nil'!
addAllVersionInfos: aCollection
	aCollection do: [:ea | self addVersionInfo: ea]! !

!MCVersionTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	visited := OrderedCollection new.! !

!MCVersionTest methodsFor: 'tests' stamp: ''!
testAllAvailablePostOrder
	self 
		assert: #allAvailableDependenciesDo: 
		orders: #(a ((b (d e)) c)) 
		as: #(d e b c)! !

!MCVersionTest methodsFor: 'tests' stamp: ''!
testWithAllUnresolved
	self 
		assert: #withAllDependenciesDo:ifUnresolved: 
		orders: #(a ((b (d e)) (c missing)))
		as: #(d e b a)
		unresolved: #(c)! !

!MCVersionTest methodsFor: 'building' stamp: ''!
versionFromTree: sexpr
	^ (self dependencyFromTree: sexpr) resolve! !

!MCVersionTest methodsFor: 'tests' stamp: ''!
testDependencyOrder
	self 
		assert: #allDependenciesDo: 
		orders: #(a (b c)) 
		as: #(b c)! !

!MCVersionTest methodsFor: 'tests' stamp: ''!
testWithAllMissing
	self 
		assert: #withAllDependenciesDo: 
		orders: #(a ((b (d e)) (c missing))) 
		as: #(d e b a)! !

!MCVersionTest methodsFor: 'tests' stamp: ''!
testWithAll
	self 
		assert: #withAllDependenciesDo: 
		orders: #(a ((b (d e)) c)) 
		as: #(d e b c a)! !

!MCVersionTest methodsFor: 'tests' stamp: ''!
testAllMissing
	self 
		assert: #allDependenciesDo: 
		orders: #(a ((b (d e)) (c missing))) 
		as: #(d e b)! !

!MCVersionTest methodsFor: 'tests' stamp: ''!
testAllUnresolved
	self 
		assert: #allDependenciesDo:ifUnresolved: 
		orders: #(a ((b (d e)) (c missing)))
		as: #(d e b)
		unresolved: #(c)! !

!MCVersionTest methodsFor: 'tests' stamp: ''!
testPostOrder
	self 
		assert: #allDependenciesDo: 
		orders: #(a ((b (d e)) c)) 
		as: #(d e b c)! !

!MCVersionTest methodsFor: 'building' stamp: ''!
dependencyFromTree: sexpr
	^ MCMockDependency fromTree: sexpr! !

!MCVersionTest methodsFor: 'asserting' stamp: ''!
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 equals: expected.
	self assert: missing asArray equals: unresolved! !

!MCVersionTest methodsFor: 'asserting' stamp: ''!
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 equals: array! !

!MCWorkingAncestry commentStamp: ''!
The interim record of ancestry for a working copy, gets merged version added to the ancestry, and is used to create the VersionInfo when the working copy becomes a version. !
!MCWorkingAncestry methodsFor: 'accessing' stamp: 'nil'!
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: 'initialization' stamp: 'nil'!
lazy
	^ self! !

!MCWorkingAncestry methodsFor: 'accessing' stamp: 'nil'!
ancestors: anObject
	ancestors := anObject collect: [ :a | a lazy ]! !

!MCWorkingAncestry methodsFor: 'accessing' stamp: 'nil'!
summary
	^ 'Ancestors: ', self ancestorString! !

!MCWorkingAncestry methodsFor: 'adding' stamp: 'nil'!
addStepChild: aVersionInfo
	stepChildren := stepChildren copyWith: aVersionInfo lazy! !

!MCWorkingAncestry methodsFor: 'accessing' stamp: 'nil'!
name
	^ '<working copy>'! !

!MCWorkingAncestry methodsFor: 'adding' stamp: 'nil'!
addAncestor: aNode
	ancestors := (self ancestors reject: [ :each | aNode hasAncestor: each ]) copyWith: aNode lazy! !

!MCWorkingCopy commentStamp: ''!
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	<MCAncestry>
	ancestry	<MCWorkingAncestry>
	counter	<Number>
	repositoryGroup	<MCRepositoryGroup>
	requiredPackages	<Collection>!
!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
newVersionWithName: nameString message: messageString in: aRepository
	
	| info deps |
	info := ancestry infoWithName: nameString message: messageString.
	ancestry := MCWorkingAncestry new addAncestor: info.
	self modified: true; modified: false.
	
	deps := self collectDependenciesWithMessage: messageString in: aRepository.
	
	(self repositoryGroup includes: aRepository) 
		ifFalse: [ self repositoryGroup addRepository: aRepository ].

	^ MCVersion
		package: package
		info: info
		snapshot: package snapshot
		dependencies: deps! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
adopt: aVersion
	ancestry addAncestor: aVersion info.
	self changed.! !

!MCWorkingCopy methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterPackageRepositoriesFor: aStep
	<stSpotterOrder: 10>
	aStep listProcessor
		title: 'Package repositories';
		allCandidates: [ self repositoryGroup repositories ];
		itemName: [ :item | item description ];
		actLogic: [ :item :step |
			step exit.
			self spotterCommit: self in: item ];
		filter: StFilterSubstring! !

!MCWorkingCopy methodsFor: 'private' stamp: 'nil'!
possiblyNewerVersionsIn: aRepository

	^aRepository possiblyNewerVersionsOfAnyOf: self ancestors! !

!MCWorkingCopy methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterCommit: workingCopy in: aRepository
	| newVersion |

	newVersion := workingCopy newVersionIn: aRepository.
	newVersion ifNil: [ ^ self ].
	Cursor wait showWhile: [
		[ 	aRepository storeVersion: newVersion.
			aRepository storeDependencies: newVersion ] 
		ensure: [ (MCVersionInspector new version: newVersion) show ]]! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
description
	^ self packageNameWithStar, ' (', (ancestry ancestorStringWithout: self packageName), ')'! !

!MCWorkingCopy methodsFor: 'private' stamp: 'nil'!
possiblyNewerVersions

	^Array streamContents: [:strm |
		self repositoryGroup repositories do: [:repo |
			strm nextPutAll: (self possiblyNewerVersionsIn: repo)]]! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
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: 'private' stamp: 'nil'!
uniqueVersionNameIn: aRepository
	|versionName|
	counter := nil.
	'Creating unique version number' 
		displayProgressFrom: 0 
		to: 1 
		during: [ :arg|
			[versionName := self nextVersionName.
			aRepository includesVersionNamed: versionName] whileTrue ].
	^ versionName! !

!MCWorkingCopy methodsFor: '*Metacello-MC' stamp: ''!
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: 'nil'!
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 := OrderedCollection withAll: package snapshot definitions.
	
	self requiredPackages 
		do: [ :aPackage| definitions addAll: aPackage workingCopy completeSnapshot definitions ]
		displayingProgress: [ :item| 'Loading dependencies from: ', item name ].
	
	^ MCSnapshot fromDefinitions: definitions! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
requirePackage: aPackage
	(self requiredPackages includes: aPackage) ifFalse: [requiredPackages add: aPackage]! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
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: '*Iceberg-Adapters' stamp: ''!
loadedVersion
	self ancestors do: [ :ancestor |
		(self repositoryGroup 
			versionWithInfo: ancestor
			ifNone: [ MCRepositoryGroup default versionWithInfo: ancestor ifNone: [] ])
			ifNotNil: [ :version | ^ version ]
	].
! !

!MCWorkingCopy methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	ancestry := MCWorkingAncestry new! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
ancestry
	^ ancestry! !

!MCWorkingCopy methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterAllRepositoriesFor: aStep
	<stSpotterOrder: 20>
	aStep listProcessor
		title: 'All other repositories';
		allCandidates: [ MCRepositoryGroup default repositories \ self repositoryGroup repositories ];
		itemName: [ :item | item description ];
		actLogic: [ :item :step | 
			step exit.
			self spotterCommit: self in: item ];
		filter: StFilterSubstring! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
collectDependenciesWithMessage: messageString in: aRepository
	
	^ self requiredPackages collect: [:aPackage | 
			MCVersionDependency
				package: aPackage
				info:  (aPackage workingCopy 
					currentVersionInfoWithMessage: messageString 
					in: aRepository) ]
	! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
needsSaving
	^ self modified or: [self requiredPackages anySatisfy: [:ea | ea workingCopy needsSaving]]! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
currentVersionInfoWithMessage: aMessageString in: aRepository
	^ (self needsSaving or: [ancestry ancestors isEmpty])
		ifTrue: [ (self newVersionWithMessage: aMessageString in: aRepository) info ]
		ifFalse: [ancestry ancestors first]! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
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: 'nil'!
clearRequiredPackages
	requiredPackages := nil! !

!MCWorkingCopy methodsFor: 'private' stamp: 'nil'!
requestVersionNameAndMessageWithSuggestion: aString
	^ (MCVersionNameAndMessageRequest new suggestedName: aString) signal! !

!MCWorkingCopy methodsFor: 'private' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
nextAncestors
	^ self versionInfo 
		ifNotNil: [ :versionInfo | versionInfo ancestors ]
		ifNil: [ #() ]! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
unload
	"Unloads mcpackage, rpackage, classes and method extensions from this working copy"
	| postUnloadAction |
	
	postUnloadAction := [].
	self package correspondingRPackage ifNotNil: [ :anRPackage |
		anRPackage packageManifestOrNil ifNotNil: [ :manifest |
			postUnloadAction := manifest postUnloadAction.
			manifest preUnload ]].
	MCPackageLoader unloadPackage: self package.		
	package packageSet unregister.
	self unregister.
	postUnloadAction value.
	
! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
currentVersionInfo
	^ (self needsSaving or: [ancestry ancestors isEmpty])
		ifTrue: [ (self newVersionIn: self repositoryGroup) 
						ifNotNil: [ :version | version info ] ]
		ifFalse: [ancestry ancestors first]! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
merge: targetVersion
	| ancestorInfo merger ancestorSnapshot packageSnapshot |
	targetVersion dependencies do: [:ea | ea resolve merge].
	ancestorInfo := targetVersion info commonAncestorWith: ancestry.
	
	ancestorInfo = targetVersion info ifTrue: [^ MCNoChangesException signal].
	
	packageSnapshot := package snapshot.
	ancestorSnapshot := ancestorInfo
							ifNotNil: [(self findSnapshotWithVersionInfo: ancestorInfo)]
							ifNil: [self notifyNoCommonAncestorWith: targetVersion.  MCSnapshot empty].
	
	(ancestry ancestors size = 1
		and: [ancestry ancestors first = ancestorInfo
				and: [(packageSnapshot patchRelativeToBase: ancestorSnapshot) isEmpty]])
				ifTrue: [^ targetVersion load].
	
	merger := MCThreeWayMerger 
				base: packageSnapshot
				target: targetVersion snapshot
				ancestor: ancestorSnapshot.
	((MCMergeResolutionRequest new merger: merger)
		signal: 'Merging ', targetVersion info name) = true 
			ifTrue:[
				merger loadWithNameLike: targetVersion info name.
				ancestry addAncestor: targetVersion info ].
	self changed! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
versionInfo: aVersionInfo
	ancestry := MCWorkingAncestry new addAncestor: aVersionInfo! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
allAncestors
	^ self versionInfo 
		ifNotNil: [ :versionInfo | versionInfo allAncestors ]
		ifNil: [ #() ]! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
removeRequiredPackage: aPackage

	requiredPackages remove: aPackage ifAbsent: []
! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
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: 'private' stamp: 'nil'!
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: 'repositories' stamp: 'nil'!
repositoryGroup
	^ repositoryGroup ifNil: [repositoryGroup := MCRepositoryGroup new]! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
theCachedRepository

	^ MCCacheRepository uniqueInstance.! !

!MCWorkingCopy methodsFor: 'private' stamp: 'nil'!
versionSeparator
	^ $_! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
changesRelativeToRepository: aRepository
	^ self completeSnapshot patchRelativeToBase: (self closestAncestorSnapshotIn: aRepository).! !

!MCWorkingCopy methodsFor: 'private' stamp: 'nil'!
findSnapshotWithVersionInfo: aVersionInfo
    "when an ancestor inside the ancestor chain is not found, does not pass nil instead.
    With this change we can now browse history and delta between them without having to 
    have the complete history"
    "instead of asking for the user to add a new repository, or copy the the missing package we simply
    return an empty Snapshot by returning nil"

    ^ aVersionInfo
        ifNil: [MCSnapshot empty]
        ifNotNil: [(self repositoryGroup versionWithInfo: aVersionInfo ifNone: [nil])
            ifNil: [MCSnapshot empty]
            ifNotNil: [:aVersion | aVersion snapshot]]! !

!MCWorkingCopy methodsFor: 'printing' stamp: 'nil'!
displayStringOn: stream
	ancestry ancestors isEmpty 
		ifTrue: [ 
			super displayStringOn: stream. stream nextPutAll: ' (unsaved)' ]
		ifFalse: [ 
			ancestry ancestors first displayStringOn: stream.
			self needsSaving ifTrue: [ stream nextPutAll: ' (modified)' ] ]
		! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
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 flattened
! !

!MCWorkingCopy methodsFor: 'printing' stamp: 'nil'!
printOn: aStream

	super printOn: aStream.
	package name ifNotNil: [ aStream 
										nextPutAll: '(' ; 
										print: package name ;
 										nextPut: $)]! !

!MCWorkingCopy methodsFor: 'repositories' stamp: 'nil'!
repositoryGroup: aRepositoryGroup
	repositoryGroup := aRepositoryGroup! !

!MCWorkingCopy methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterAncestorsFor: aStep
	<stSpotterOrder: 2>
	self flag: #maybeRewriteForDirectStreaming.
	aStep listProcessor
		title: 'Ancestors';
		allCandidates: [ self allAncestors ];
		filter: StFilterSubstring! !

!MCWorkingCopy methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterPackageFor: aStep
	<stSpotterOrder: 21>
	self flag: #maybeRewriteForDirectStreaming.
	aStep listProcessor
		title: 'Packages';
		allCandidates: [ self package correspondingRPackage 
			ifNotNil: [ :rpackage | { rpackage } ] 
			ifNil: [ { } ] ];
		itemName: [ :item | item name ];
		itemIcon: [ Smalltalk ui icons iconNamed: #packageIcon ];
		filter: StFilterSubstring! !

!MCWorkingCopy methodsFor: '*Iceberg' stamp: ''!
ancestry: anAncestry

	ancestry := anAncestry! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
newVersionIn: aRepository
	^ (self requestVersionNameAndMessageWithSuggestion: (self uniqueVersionNameIn: aRepository)) 
		ifNotNil: [:pair |
			self 
				newVersionWithName: pair first trimBoth 
				message: pair last 
				in: aRepository ].
! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
versionInfo
	^ self ancestors 
		ifNotEmpty: [ :list | list first ] 
		ifEmpty: [ nil ]! !

!MCWorkingCopy methodsFor: '*Iceberg' stamp: ''!
info
	^ self versionInfo! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
merged: aVersion
	ancestry addAncestor: aVersion info.
	aVersion dependencies do: [:ea | self requirePackage: ea package].
	self changed! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'nil'!
newVersionWithMessage: aMessageString in: aRepository
	^ self 
		newVersionWithName: (self uniqueVersionNameIn: aRepository)  
		message: aMessageString
		in: aRepository.

	"^ (self requestVersionNameAndMessageWithSuggestion: self uniqueVersionName) ifNotNil:
		[:pair |
		self newVersionWithName: pair first message: aMessageString].
	"! !

!MCWorkingCopy methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterMonticelloPackageFor: aStep
	<stSpotterOrder: 21>
	aStep listProcessor
		title: 'Monticello Package';
		allCandidates: [ Array with: self package ];
		itemIcon: [ Smalltalk ui icons iconNamed: #monticelloPackageIcon ];
		filter: StFilterSubstring! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
requiredPackages
	^ requiredPackages ifNil: [requiredPackages := OrderedCollection new]! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
snapshot
	^ self package snapshot! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'nil'!
ancestors
	^ ancestry ancestors! !

!MCWorkingCopy class methodsFor: 'event registration' stamp: 'nil'!
registerForNotifications
	"self registerForNotifications"
	<systemEventRegistration>
	
	MCPackageManager announcer: nil.
	SystemAnnouncer uniqueInstance unsubscribe: self.
	self registerInterestOnSystemChangesOnAnnouncer: SystemAnnouncer uniqueInstance.! !

!MCWorkingCopy class methodsFor: 'querying' stamp: 'nil'!
hasPackageNamed: aName
	" self hasPackageNamed: 'ConfigurationOfFuel' "

	^ MCWorkingCopy allManagers
		anySatisfy: [ :each | each packageName = aName ]! !

!MCWorkingCopy class methodsFor: 'private' stamp: 'nil'!
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)] onErrorDo: [nil])
			time: ([Time fromString: (aDictionary at: #time)] onErrorDo: [nil])
			author: (aDictionary at: #author ifAbsent: [''])
			ancestors: (self ancestorsFromArray: (aDictionary at: #ancestors ifAbsent: []) cache: cache)
			stepChildren: (self ancestorsFromArray: (aDictionary at: #stepChildren ifAbsent: []) cache: cache)]! !

!MCWorkingCopy class methodsFor: 'initialize' stamp: 'nil'!
initialize
	"self initialize"
	registry ifNotNil: [ registry rehash ].
	self registerForNotifications.! !

!MCWorkingCopy class methodsFor: 'private' stamp: 'nil'!
ancestorsFromArray: anArray cache: cacheDictionary
	"While using recursion is simpler, it runs a risk of stack overflow for packages with many ancestors,
	 so we use a local stack to pre-load the cache in reverse order. 
	 The original code remains on the last line, so the intermediate code 
	 does not change the external behavior. "

	| index stack |
	anArray ifNil: [^nil].
	stack := OrderedCollection withAll: anArray.
	index := 1.
	[ index <= stack size ] whileTrue: [
		| dict id |
		dict := stack at: index.
		id := (dict at: #id) asString.
		(cacheDictionary includesKey: id) ifFalse: [
			stack addAll: (dict at: #ancestors ifAbsent: [#()]).
		].
		index := index + 1.
	].
	stack reverseDo: [:each | 
		self infoFromDictionary: each cache: cacheDictionary.
	].
	^ anArray collect: [:dict | self infoFromDictionary: dict cache: cacheDictionary]! !

!MCWorkingCopyBrowser commentStamp: ''!
Browser for working copies!
!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
dirtyPackages
	^ self workingCopies select: [:copy | copy needsSaving].
! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
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: 'actions' stamp: ''!
addRepository
	self class newRepository ifNotNil: [:repos | 
		self addRepository: repos.
		workingCopy ifNil: [ repos morphicOpen: nil ]].
! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
recompilePackage
	workingCopy package packageSet methods
		do: [:ea | ea actualClass recompile: ea selector]
		displayingProgress: 'Recompiling...'! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
getShowOnlyRepositoriesFromWorkingCopySettings
	^#('All' 'Package')! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopySearchField
	^ SearchMorph new
		model: self;
		setIndexSelector: #workingCopySearchAccept:; 
		searchList: self class workingCopySearchList;
		updateSelector: #workingCopySearchAccept:;
		yourself
! !

!MCWorkingCopyBrowser methodsFor: 'updating' stamp: ''!
windowIsClosing
	
	SystemAnnouncer uniqueInstance unsubscribe: self.! !

!MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: ''!
collectConfigurationMenuSpecs
	| menuSpecs | 
	menuSpecs := (Pragma allNamed: #'contextMenu:' in: self class)
		select: [ :each | (each argumentAt: 1) = #configuration ].
		
	^ menuSpecs 
		inject: #()
		into: [ :all :each | all, (each method valueWithReceiver: self arguments: #()) ]
	! !

!MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: ''!
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: 'morphic ui' stamp: ''!
repositories
	"Return the list of MCRepository, typically SmalltalkHubRepository. This methods drives what is displayed on the list on the right hand side of the working copy browser.
	It contains at least one cache repository, corresponding to the local package cache"
	| repositories |
	repositories := self repositoryGroup repositories.
	
	"filter the repository list if there is a search string"
	repositoryPattern ifNotEmpty: [
		repositories := repositories select: [ :each| each description asLowercase includesSubstring: repositoryPattern ]].
	^ repositories! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
changedButtons
	self changed: #hasWorkingCopy.
	self changed: #canSave.
	self changed: #canBackport.
	self changed: #hasRepository.
! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopySearchAdd: aString 
	self workingCopySearchList: (self workingCopySearchList
			remove: aString
			ifAbsent: [];
			 yourself).
	self workingCopySearchList size = self workingCopySearchMaxSize
		ifTrue: [self workingCopySearchList removeLast].
	self workingCopySearchList addFirst: aString ! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
viewHistory
	workingCopy ifNotNil:
		[(MCWorkingHistoryBrowser new
				ancestry: workingCopy ancestry;
				package: workingCopy package)
			label:  'Version History: ',  workingCopy packageName;
			show]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
repository: aRepository
	repository := aRepository.
	workingCopy ifNotNil: [self defaults at: workingCopy put: aRepository]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
addRepositoryToPackage

	self repository
		ifNotNil: [ :repos | 
			((SearchFacade mcPackageSearchRejectAll: [ :aPackage | aPackage repositoryGroup includes: repos ] withInitialFilter: nil)
				chooseFromOwner: self window)
				ifNotNil: [ :wc | 
					workingCopy := wc.
					workingCopy repositoryGroup addRepository: repos.
					self repository: repos.
					self
						changed: #workingCopySelection;
						repositoryListChanged;
						changed: #repositorySelection.
					self changedButtons ] ]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
canSave
	^ self hasWorkingCopy and: [self hasRepository]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
currentShowOnlyRepositoriesFromWorkingCopy
	^showOnlyRepositoriesFromWorkingCopy ifTrue: [ 2] 
	ifFalse: [ 1] ! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
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: ''!
workingCopySearchAccept: string
	| aString |

	aString := string ifNil: [ '' ].
	workingCopyPattern = aString asLowercase ifTrue: [ ^ self ].
	workingCopyPattern := aString asLowercase.
		
	packageProcess ifNotNil: [ packageProcess terminate ].	
	packageProcess := [ self workingCopyListChanged ] fork.! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
basicSaveVersionIn: aRepository
	| newVersion waitForVersion |
	waitForVersion := Semaphore new.
	
	UIManager default defer: [
		newVersion := workingCopy newVersionIn: aRepository.
		waitForVersion signal ].
	
	Processor activeProcess == UIManager default uiProcess
		ifFalse: [ waitForVersion wait ].
	newVersion ifNil: [ ^ self ]. 
	
	Cursor wait showWhile: [[ 
		self
			storeVersion: newVersion in: aRepository;
			storeDependencies: newVersion in: aRepository.] 
			ensure: [ (MCVersionInspector new version: newVersion) show ]]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
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: 'menu spec' stamp: ''!
historyMenuSpec

	^ #(#('Browse package' #browseWorkingCopy)
		#('View changes' #viewChanges) 
		#('View history' #viewHistory))
! !

!MCWorkingCopyBrowser methodsFor: 'updating' stamp: ''!
updateRepositoryList
	self repositoryListChanged.
	self changed: #repositorySelection.
	self changedButtons.! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
repository
	^ repository! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
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: ''!
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: 'menu spec' stamp: ''!
buttonSpecs
	^ #(#('+Package' #addWorkingCopy 'Add a new package and make it the working copy')
		#('+Config' #addMetacelloConfiguration 'Add a new metacello configuration')
		#('Browse' #browseWorkingCopy 'Browse the working copy of the selected package' #hasWorkingCopy)
		#('Changes' #viewChanges 'View the working copy''s changes relative to the installed version from the repository' #canSave)
	 	#('+Repository' #addRepository 'Add an existing repository to the list of those visible')
		#('Save' #saveVersion 'Save the working copy as a new version to the selected repository' #canSave)
		#('Open' #openRepository 'Open a browser on the selected repository' #hasRepository))! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
unsortedWorkingCopies
	^ self allManagers ! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
browseWorkingCopy
	workingCopy ifNotNil:
		[(MCSnapshotBrowser forSnapshot: workingCopy completeSnapshot)
			label: 'Snapshot Browser: ', workingCopy packageName;
			show]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
repositorySearchAccept: string
	| aString |

	aString := string ifNil: [ '' ].
	repositoryPattern = aString asLowercase ifTrue: [ ^ self ].
	repositoryPattern := aString asLowercase.
		
	repositoryProcess ifNotNil: [ repositoryProcess terminate ].
	repositoryProcess := [ self repositoryListChanged ] fork.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
editScript: scriptSymbol

	| script |
	script := workingCopy packageSet perform: scriptSymbol.
	script openLabel: scriptSymbol asString, ' of the Package ', workingCopy package name.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopy: wc
	workingCopy := wc.
	self changed: #workingCopySelection; repositoryListChanged.
	self changedButtons.
! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopies
	^ (self orderSpecs size = order
		ifTrue: [ self allManagers select: [ :each | each modified ] ]
		ifFalse: [ self allManagers ])
			asSortedCollection: (self orderSpecs at: order) value.! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
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: 'morphic ui' stamp: ''!
workingCopyTreeChildren: aWrapper
	^ aWrapper contents! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
orderString: anIndex
	^ String streamContents: [ :stream |
		order = anIndex
			ifTrue: [ stream nextPutAll: '<yes>' ]
			ifFalse: [ stream nextPutAll: '<no>' ].
		stream nextPutAll: (self orderSpecs at: anIndex) key ]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
openRepository
	self repository ifNotNil: [:repos | 
		repos morphicOpen: workingCopy ]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
repositorySearchField
	^ SearchMorph new
		model: self;
		setIndexSelector: #repositorySearchAccept:; 
		updateSelector: #repositorySearchAccept:;
		searchList: self class repositorySearchList;
		yourself! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopyListChanged
	self changed: #workingCopyList.
	self changed: #workingCopyTree.
	self changed: #workingCopyTreePath.
	self changedButtons.
! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
flushAllCaches
	| beforeBytes afterBytes beforeVersions afterVersions |
	Cursor wait showWhile: [
		beforeBytes := Smalltalk garbageCollect.
		beforeVersions := MCVersion allSubInstances size.
		MCFileBasedRepository flushAllCaches.
		afterBytes := Smalltalk garbageCollect.
		afterVersions := MCVersion allSubInstances size.
	].
	^self inform: (beforeVersions - afterVersions) asString, ' versions flushed', String cr,
 		(afterBytes - beforeBytes) asStringWithCommas, ' bytes reclaimed'! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopyList
	^ self workingCopies collect:
		[:ea |
		(workingCopy notNil and: [workingCopy requiredPackages includes: ea package])
			ifTrue: [Text string: ea description]
			ifFalse: [ea description]]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
inspectWorkingCopy
	workingCopy ifNotNil: [workingCopy inspect]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
repositorySelection
	"Return the index of the selected repository.
	May return 0, which means that no repository is selected"
	^ self repositories indexOf: self repository! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopySelectionWrapper
	^workingCopyWrapper! !

!MCWorkingCopyBrowser methodsFor: '*Tool-Diff' stamp: ''!
viewChanges
	"View the changes made in the working copy."
	
	| patch |
	'Finding changes' displayProgressFrom: 0 to: 10 during:[:bar|
		self canSave ifTrue:[
		bar current: 1.
		patch := workingCopy changesRelativeToRepository: self repository].
		patch ifNil: [^ self].
		bar current: 3.
		patch isEmpty
			ifTrue: [
				workingCopy modified: false.
				bar current: 10.
				MCNoChangesException signal ]
			ifFalse: [
				workingCopy modified: true.
				bar current: 5.
				self
					viewChanges: patch
					from: workingCopy  packageName, ' (', workingCopy ancestry ancestorString, ')'
					to: ('Modified {1}' translated format: {workingCopy description})]]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
repositoryIcon: a
	^ self iconNamed: #monticelloPackageIcon! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
viewPastComments
	"Visualize past comments on a package."

       workingCopy ifNotNil:
               [(UIManager default
                       edit: (String streamContents:
                                       [:s|
                                       "Ignore the initial MCWorkingAncestry instance."
                                       workingCopy ancestry topologicalAncestors allButFirst
                                               do: [:versionInfo|
                                                       s nextPutAll: versionInfo summary]
                                               separatedBy: [s cr; cr"; next: 32 put: $-; cr; cr"]])
                       label: 'Version History: ',  workingCopy packageName) ]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopyListMenu: aMenu

	workingCopy ifNil: [ ^ aMenu ].
	(workingCopy package name beginsWith: 'ConfigurationOf') ifTrue: [
		self fillMenu: aMenu fromSpecs: self collectConfigurationMenuSpecs.
		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: 'menu spec' stamp: ''!
unloadPackageMenuSpec

	^ #(#('Unload package' #unloadPackage)
		#('Delete working copy' #deleteWorkingCopy))! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopyTreePath
	workingCopy ifNil: [^ OrderedCollection new].
	^ OrderedCollection with: workingCopyWrapper.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopyTreeMenu: aMenu
	^ self workingCopyListMenu: aMenu! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
setShowOnlyRepositoriesFromWorkingCopy: anIndex
	showOnlyRepositoriesFromWorkingCopy  := (anIndex = 2).
	self repositorySelection: 0.
	self repositoryListChanged.
! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
unloadPackage
	workingCopy unload.
	self workingCopySelection: 0.
	self workingCopyListChanged.! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
addWorkingCopy
	| name |
	
	name := UIManager default request: 'Name of package:'.
	name isEmptyOrNil ifFalse: [
		RPackageOrganizer default registerPackageNamed: name.		
		workingCopy := MCWorkingCopy forPackage: (MCPackage new name: name).
		workingCopyWrapper := MCDependentsWrapper with: workingCopy model: self.
		self repositorySelection: 0 ].
	
	self 
		workingCopyListChanged; 
		changed: #workingCopySelection; 
		repositoryListChanged.
	self changedButtons.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
repositoryList
	"Return the list of repository names. Only String are returned"
	| repositories |
	repositories := self repositories.

	^ repositories collect: [:ea | ea description]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
loadRepositories


	CodeImporter evaluateFileNamed: 'MCRepositories.st'.
	self repositoryListChanged.
	self changedButtons.
! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
addRequiredPackage
	| chosen |
	workingCopy
		ifNotNil: [ :wc | 
			chosen := (SearchFacade mcPackageSearchRejectAll: [ :ea | ea = wc or: [ wc requiredPackages includes: ea package ] ])
				chooseFromOwner: self window.
			chosen
				ifNotNil: [ 
					wc requirePackage: chosen package.
					self workingCopyListChanged ] ]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopyTree
	| workingCopies |
	workingCopies := self workingCopies.
	
	"filter the working copy list if there is a serach string"
	workingCopyPattern ifNotEmpty: [ 
		workingCopies := workingCopies select: [ :each| each package name asLowercase includesSubstring: workingCopyPattern ]].
			
	^ workingCopies collect: [:each| MCDependentsWrapper with: each model: self].! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
editRepository
	| newRepo |
	newRepo := self repository openAndEditTemplateCopy.
	newRepo ifNotNil: [ 
		(newRepo isKindOf: MCRepository)
			ifFalse: [ 
				self inform: 'Got a ', newRepo class name, ' instead of a Monticello Repository'].
		self flag: 'Is this ugly? yes!!'.
		self repository becomeForward: newRepo ].
	self repositoryListChanged! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
hasRepository
	^ self repository notNil! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
repositoryListMenu: aMenu
	self repository ifNil: [^ aMenu].
	self fillMenu: aMenu fromSpecs: self repositoryMenuSpec.
	^ aMenu
				! !

!MCWorkingCopyBrowser methodsFor: 'initialization' stamp: ''!
registerToAnnouncer
	SystemAnnouncer uniqueInstance weak
		when: MCPackageModified send: #update: to: self;
		when: MCWorkingCopyCreated send: #update: to: self;
		when: MCWorkingCopyDeleted send: #update: to: self;
		when: MCRepositoryAdded send: #updateRepositoryList to: self;
		when: MCRepositoryRemoved send: #updateRepositoryList to: self.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
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: 'actions' stamp: ''!
deleteWorkingCopy
	workingCopy unregister.
	self workingCopySelection: 0.
	self workingCopyListChanged.! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
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"
			RPackageOrganizer default registerPackageNamed: name.
			
			"Select the package"
			workingCopy := MCWorkingCopy forPackage: (MCPackage new name: name).
			repository ifNotNil: [ workingCopy repositoryGroup addRepository: repository ].
			workingCopyWrapper := nil.
			workingCopy modified: true.
			self workingCopySelection: 0.
			self repositorySelection: 0 ].

	self workingCopyListChanged; 
		changed: #workingCopySelection;
		repositoryListChanged.
	self changedButtons.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
initialExtent
	^ 650.0 @ 420.0! !

!MCWorkingCopyBrowser methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	order := self class order.
	showOnlyRepositoriesFromWorkingCopy := true.
	self registerToAnnouncer.
	workingCopyPattern := ''.
	repositoryPattern := ''! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
order: anInteger
	"
	Set the order of the listed working copies
	anInteger represents the order of the mcworkingcopies in the MCBrowser. Its value is between 0 and the number of entries in MCFileRepositoryInspector >> orderSpecs
	"
	
	self class order: (order := anInteger).
	self changed: #workingCopyList; changed: #workingCopyTree! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
repositoryListChanged
	self changed: #repositoryList.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
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: 'menu spec' stamp: ''!
widgetSpecs
	| searchBarOffset |
	
	searchBarOffset := 30 + StandardFonts defaultFont height + 10.
	
	^ {
		"send fractions offsets"
		{{#buttonRow}. {0. 0. 1. 0}. {0. 0. 0. 30.}}.
		
		{{#workingCopySearchField}. {0. 0. 0.5. 0.}. {0. 30. 0. searchBarOffset.}}.
		{{#treeMorph:. #workingCopy}. {0. 0. 0.5. 1}. {0. searchBarOffset+3. 0. 0.}}.
		
		{{#repositorySearchField}. {0.5. 0. 0.85. 0.}. {0. 30. 0. searchBarOffset.}}.
		{{#showOnlyRepositoriesFromWorkingCopyField}. { 0.85. 0. 1. 0.}. { 0. 30. 0. searchBarOffset .}}.
		{{#listMorph:selection:menu:icon: . #repositoryList . #repositorySelection . #repositoryListMenu: . #repositoryIcon:}. {0.5. 0. 1. 1}. {0. searchBarOffset+3. 0. 0.}}.
		}.! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
clearRequiredPackages
	workingCopy ifNotNil:
		[:wc |
		wc clearRequiredPackages.
		self workingCopyListChanged]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
canBackport
	^ self hasWorkingCopy and: [workingCopy needsSaving not]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
saveRepositories

	'MCRepositories.st' asFileReference writeStreamDo: [:f |
		MCRepositoryGroup default repositoriesDo: [:r |
			r asCreationTemplate ifNotNil: [:template |
				f nextPutAll: 'MCRepositoryGroup default addRepository: (', template , ')!!'; cr]]]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopySelection: aNumber
	self workingCopy: 
		(aNumber = 0 
			ifTrue: [nil]
			ifFalse: [self workingCopies at: aNumber]).	! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
revertPackage
	self pickAncestorVersionInfo ifNotNil: [:info |
		(self repositoryGroup versionWithInfo: info
			ifNone: [^self inform: 'No repository found for ', info name]
		) load]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
saveVersion
	self canSave ifFalse: [ ^ self ].
	"fork the whole version creation "
	[ self basicSaveVersionIn: self repository ] fork! !

!MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: ''!
revertPackageMenuSpec

	^ #(#('Revert package...' #revertPackage) 
			   #('Recompile package' #recompilePackage)
			   #('Backport package...' #backportChanges)
			   #('Inspect package' #inspectWorkingCopy))
! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
storeDependencies: newVersion in: aRepository
	aRepository storeDependencies: newVersion ! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
repositoryGroup
	"Return the group of repository displayed in the monticello browser"
	(showOnlyRepositoriesFromWorkingCopy and: [ workingCopy isNotNil ])
		ifTrue: [ ^ workingCopy repositoryGroup ].
	^ MCRepositoryGroup default! !

!MCWorkingCopyBrowser methodsFor: '*Tool-Diff' stamp: ''!
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: 'updating' stamp: ''!
update: anAnnouncement
	self workingCopyListChanged.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopyTreeLabel: aWrapper
	^ aWrapper asString! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopySelectionWrapper: aWrapper
	workingCopyWrapper := aWrapper.
	self changed: #workingCopySelectionWrapper.
	self workingCopy: (aWrapper ifNotNil:[aWrapper item])! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
defaults
	^ defaults ifNil: [defaults := Dictionary new]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
addRequiredDirtyPackage
	| dirtyPackages |
	
	dirtyPackages := self dirtyPackages.
	
	workingCopy ifNotNil: [:wc |
		dirtyPackages do: [:required |
			wc = required
				ifFalse: [ wc requirePackage: required package]]].
	
	self workingCopyListChanged! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopySelection
	^ self workingCopies indexOf: workingCopy! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
storeVersion: newVersion in: aRepository
	aRepository storeVersion: newVersion! !

!MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: ''!
packageMenuSpec

	^ #(#('Add required package' #addRequiredPackage)
		#('Add all dirty packages as required' #addRequiredDirtyPackage)
		#('Remove required package' #removeRequiredPackage)
		#('Clear required packages' #clearRequiredPackages)
		#('View past comments' #viewPastComments))
! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
hasWorkingCopy
	^ workingCopy notNil! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopySearchMaxSize
	^self class workingCopySearchMaxSize! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
workingCopyTreeHasChildren: aWrapper
	^ aWrapper hasContents! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	^ 'Monticello Browser'! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
showOnlyRepositoriesFromWorkingCopyField
	^(DropListMorph
		on: self 
		list: #getShowOnlyRepositoriesFromWorkingCopySettings
		selected: #currentShowOnlyRepositoriesFromWorkingCopy
		changeSelected: #setShowOnlyRepositoriesFromWorkingCopy:)
		listPaneColor: Color transparent;
		yourself			
! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
pickWorkingCopy
	^self pickWorkingCopySatisfying: [ :c | true ]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
buildWindow 	

	|window|
	window := super buildWindow.
	self repositoryListChanged.
	^window! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
addRepositoryToWorkingCopy
	workingCopy ifNotNil:
		[:wc |
			workingCopy repositoryGroup addRepository: self repository.
			self
				changed: #workingCopySelection;
				repositoryListChanged;
				changed: #repositorySelection.
			self changedButtons]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
removeRepository
	self repository ifNotNil:
		[:repos |
		self repositoryGroup removeRepository: repos.
		self repositorySelection: (1 min: self repositories size)].
	self repositoryListChanged.
	self changedButtons.
! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
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: 'morphic ui' stamp: ''!
repositorySearchMaxSize
	^self class repositorySearchMaxSize! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: ''!
addRepository: aRepository
	self repository: aRepository.
	self repositoryGroup addRepository: aRepository.
	self updateRepositoryList.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: ''!
repositoryMaxSearchSize
	^self class repositoryMaxSearchSize! !

!MCWorkingCopyBrowser class methodsFor: 'settings' stamp: ''!
order: anInteger
	"
	anInteger represents the order of the mcworkingcopies in the MCBrowser. Its value is between 0 and the number of entries in MCFileRepositoryInspector >> orderSpecs
	"
	Order := anInteger! !

!MCWorkingCopyBrowser class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	self new show! !

!MCWorkingCopyBrowser class methodsFor: 'settings' stamp: ''!
order
	"
	anInteger represents the order of the mcworkingcopies in the MCBrowser. Its value is between 0 and the number of entries in MCFileRepositoryInspector >> orderSpecs
	"
	^ Order ifNil: [ Order := 2 ]! !

!MCWorkingCopyBrowser class methodsFor: 'settings' stamp: ''!
repositorySearchMaxSize
	^ repositorySearchMaxSize ifNil: [repositorySearchMaxSize := 15]
! !

!MCWorkingCopyBrowser class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#versionControlIcon! !

!MCWorkingCopyBrowser class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	registry register: self as: #monticelloBrowser! !

!MCWorkingCopyBrowser class methodsFor: 'settings' stamp: ''!
workingCopySearchList
	^ workingCopySearchList ifNil: [ workingCopySearchList := OrderedCollection new ].! !

!MCWorkingCopyBrowser class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #'Monticello Browser (Legacy)')
		parent: #Versioning;
		action: [ Smalltalk tools openMonticelloBrowser ];
		order: 2;
		keyText: 'o, p';
		help: '(Deprecated) Source code versioning system to manage Smalltalk code.';
		icon: Smalltalk tools monticelloBrowser taskbarIcon! !

!MCWorkingCopyBrowser class methodsFor: 'settings' stamp: ''!
repositorySearchList
	^ repositorySearchList ifNil: [ repositorySearchList := OrderedCollection new ].! !

!MCWorkingCopyBrowser class methodsFor: 'settings' stamp: ''!
workingCopySearchMaxSize
	^ workingCopySearchMaxSize ifNil: [workingCopySearchMaxSize := 15]
! !

!MCWorkingCopyBrowserTest commentStamp: ''!
This class is testing Monticello initialization!
!MCWorkingCopyBrowserTest methodsFor: 'tests' stamp: ''!
testDefault
	"When opened, there are plenty of packages, ie., working copies that are listed"
	self assert: browser workingCopies notNil.
	self assert: browser workingCopies notEmpty.
	
	"When opening, there is no repository selected"
	self assert: browser repository isNil.
	
	"No repository is selected"
	self assert: browser repositorySelection equals: 0! !

!MCWorkingCopyBrowserTest methodsFor: 'tests' stamp: ''!
testRepositories
	self assert: browser repositories notNil.
	self assert: browser repositories notEmpty.
	self assert: browser repositoryGroup notNil.
	self assert: browser repositoryGroup repositories size equals: browser repositories size. ! !

!MCWorkingCopyBrowserTest methodsFor: 'tests' stamp: ''!
testRepositoriesIncludeCache
	"At least one cache is present in the list of repositories"
	self assert: (browser repositories anySatisfy: [ :r | r class == MCCacheRepository ])! !

!MCWorkingCopyBrowserTest methodsFor: 'tests' stamp: ''!
testRepositoryList
	self assert: browser repositoryList notNil.
	self assert: browser repositoryList notEmpty. 
	self assert: browser repositoryList size equals: browser repositories size.
	self assert: (browser repositoryList allSatisfy: [ :r | r isString ]).! !

!MCWorkingCopyBrowserTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	browser := MCWorkingCopyBrowser new.! !

!MCWorkingCopyCreated commentStamp: ''!
A MCWorkingCopyCreated is a announcement raised when a new MCWorkingCopy is created!
!MCWorkingCopyCreated methodsFor: 'accessing' stamp: 'nil'!
workingCopy
	^ workingCopy! !

!MCWorkingCopyCreated methodsFor: 'accessing' stamp: 'nil'!
workingCopy: anObject
	workingCopy := anObject! !

!MCWorkingCopyCreated methodsFor: 'accessing' stamp: 'nil'!
package: anObject
	package := anObject! !

!MCWorkingCopyCreated methodsFor: 'accessing' stamp: 'nil'!
package
	^ package! !

!MCWorkingCopyCreated class methodsFor: 'instance creation' stamp: 'nil'!
workingCopy: aWC package: package

	^ self new
		workingCopy: aWC;
		package: package;
		yourself! !

!MCWorkingCopyCreated class methodsFor: 'instance creation' stamp: 'nil'!
workingCopy: workingCopy

	^ self new
		workingCopy: workingCopy;
		yourself! !

!MCWorkingCopyDeleted commentStamp: ''!
A MCWorkingCopyDeleted class is an announcement raised when a MCWorkingCopy is removed!
!MCWorkingCopyDeleted methodsFor: 'accessing' stamp: 'nil'!
workingCopy
	^ workingCopy! !

!MCWorkingCopyDeleted methodsFor: 'accessing' stamp: 'nil'!
workingCopy: anObject
	workingCopy := anObject! !

!MCWorkingCopyDeleted methodsFor: 'accessing' stamp: 'nil'!
package: anObject
	package := anObject! !

!MCWorkingCopyDeleted methodsFor: 'accessing' stamp: 'nil'!
package
	^ package! !

!MCWorkingCopyDeleted class methodsFor: 'instance creation' stamp: 'nil'!
workingCopy: aWC package: package

	^ self new
		workingCopy: aWC;
		package: package;
		yourself! !

!MCWorkingCopyDeleted class methodsFor: 'instance creation' stamp: 'nil'!
workingCopy: workingCopy

	^ self new
		workingCopy: workingCopy;
		yourself! !

!MCWorkingCopyForExtensionsTest methodsFor: 'running' stamp: ''!
tearDown
	'ATestPackage' asPackage removeFromSystem.
	'AnotherTestPackage' asPackage removeFromSystem.
	Object
		compiledMethodAt: #testingMethod
		ifPresent: [ Object removeSelector: #testingMethod ].
	('Atestpackage-something-else' asPackageIfAbsent: [ nil ])
		ifNotNil: [ :package | package removeFromSystem ].
	MCWorkingCopy registry
		at: (MCPackage named: 'atestpackage-something-else')
		ifPresent: [ :aWC | aWC unload ].
	super tearDown! !

!MCWorkingCopyForExtensionsTest methodsFor: 'tests' stamp: ''!
testAddingExtensionMethodNotMatchingPackage

	| aClass |
	RPackageOrganizer default createPackageNamed: 'ATestPackage'.
	RPackageOrganizer default createPackageNamed: 'AnotherTestPackage'.

	aClass := self class classInstaller make: [ :aBuilder | 
		aBuilder 
			name: #ATestClass;
			package: 'AnotherTestPackage'].

	aClass compile: 'testingMethod ^ 42 ' classified: '*atestpackage-something-else'.
	
	self deny: (RPackageOrganizer default includesPackageNamed: 'Atestpackage-something-else').
	self assert: ('ATestPackage' asPackage extendedClasses includes: aClass).

	MCWorkingCopy registry at: (MCPackage named: 'atestpackage-something-else') ifPresent: [ self fail ].	! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
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 equals: 1! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
testSelectiveBackport
	| inst base intermediate final |
	inst := self mockInstanceA.
	base := self snapshot.
	self assert: inst one equals: 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 equals: 1.
	self assert: inst two equals: 3.
	self assert: workingCopy ancestry ancestors size equals: 1.
	self assert: workingCopy ancestry ancestors first equals: base info.
	self assert: workingCopy ancestry stepChildren size equals: 1.
	self assert: workingCopy ancestry stepChildren first equals: final info! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
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 equals: 1.
	self assert: inst two equals: 3.

	self merge: mother.
	self assert: inst one equals: 2.
	self assert: inst two equals: 3! !

!MCWorkingCopyTest methodsFor: 'running' stamp: ''!
tearDown
	workingCopy unregister.
	self restoreMocks.
	self clearPackageCache.
	Author fullName: savedName.
	super tearDown! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
testOptimizedLoad
	| inst base diffy |
	inst := self mockInstanceA.
	base := self snapshot.
	self change: #one toReturn: 2.
	self assert: inst one equals: 2.
	diffy := self snapshot asDiffAgainst: base.
	self deny: diffy canOptimizeLoading.
	self load: base.
	self assert: inst one equals: 1.
	self assert: diffy canOptimizeLoading.
	self load: diffy.
	self assert: inst one equals: 2! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
testSnapshotAndLoad
	| base inst |
	inst := self mockInstanceA.
	base := self snapshot.
	self change: #one toReturn: 2.
	self assert: inst one equals: 2.
	self load: base.
	self assert: inst one equals: 1! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
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 equals: 1.
	self assert: inst two equals: 2.
	self merge: mother1.
	self assert: inst one equals: 2.
	self assert: inst two equals: 2.
	self change: #one toReturn: 7.
	self assert: inst one equals: 7.
	self assert: inst two equals: 2.
	self merge: mother2.
	self assert: inst one equals: 7.
	self assert: inst two equals: 3! !

!MCWorkingCopyTest methodsFor: 'asserting' stamp: ''!
assertNumberWhenSavingTo: aRepository is: aNumber
	| name |
	name := nil.
	[ aRepository storeVersion: (workingCopy newVersionIn: aRepository) ]
		on: MCVersionNameAndMessageRequest
		do: [ :n | 
			name := n suggestedName.
			n resume: (Array with: name with: '') ].
	self assert: name equals: self packageName , '-' , Author fullName , '.' , aNumber asString! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
testRepositoryFallback
	| version |
	version := self snapshot.
	self assert: (repositoryGroup versionWithInfo: version info) identicalTo: version.
	versions removeKey: version info.
	versions2 at: version info put: version.
	self assert: (repositoryGroup versionWithInfo: version info) identicalTo: version.
	versions2 removeKey: version info.
	self should: [ repositoryGroup versionWithInfo: version info ] raise: Error! !

!MCWorkingCopyTest methodsFor: 'accessing' stamp: ''!
description
	^ self class name! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
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 equals: 2! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
testRedundantMerge
	| base |
	base := self snapshot.
	self merge: base.
	self merge: base! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
testDoubleRepeatedMerge
	| base motherA1 motherA2 motherB1 motherB2 inst |
	base := self snapshot.
	self change: #a toReturn: 'a1'.
	motherA1 := self snapshot.
	self change: #c toReturn: 'c1'.
	motherA2 := self snapshot.
	self load: base.
	self change: #b toReturn: 'b1'.
	motherB1 := self snapshot.
	self change: #d toReturn: 'd1'.
	motherB2 := self snapshot.
	self load: base.
	self merge: motherA1.
	self merge: motherB1.
	self change: #a toReturn: 'a2'.
	self change: #b toReturn: 'b2'.
	self snapshot.
	self merge: motherA2.
	self merge: motherB2.
	inst := self mockInstanceA.
	self assert: inst a equals: 'a2'.
	self assert: inst b equals: 'b2'.
	self assert: inst c equals: 'c1'.
	self assert: inst d equals: 'd1'! !

!MCWorkingCopyTest methodsFor: 'asserting' stamp: ''!
assertNameWhenSavingTo: aRepository is: aString
	| name |
	name := nil.
	[ aRepository storeVersion: (workingCopy newVersionIn: aRepository) ]
		on: MCVersionNameAndMessageRequest
		do: [ :n | 
			name := n suggestedName.
			n resume: (Array with: name with: '') ].
	self assert: name equals: aString! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
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: 'private' stamp: ''!
packageName
	^ self mockPackage name! !

!MCWorkingCopyTest methodsFor: 'actions' stamp: ''!
snapshot
	| version |
	[version := workingCopy newVersionIn: workingCopy repositoryGroup]
		on: MCVersionNameAndMessageRequest
		do: [:n | n resume: (Array with: n suggestedName with: '')].
	versions at: version info put: version.
	^ version! !

!MCWorkingCopyTest methodsFor: 'running' stamp: ''!
clearPackageCache
	| dir |
	dir := MCCacheRepository uniqueInstance directory.
"	(dir filesMatching: 'MonticelloMocks*') do: [:ea | ea ensureDeleted ]."
	(dir filesMatching: 'MonticelloTest*') do: [:ea | ea ensureDelete].
	(dir filesMatching: 'rev*') do: [:ea | ea ensureDelete].
	(dir filesMatching: 'foo-*') do: [:ea | ea ensureDelete].
	(dir filesMatching: 'foo2-*') do: [:ea | ea ensureDelete].! !

!MCWorkingCopyTest methodsFor: 'actions' stamp: ''!
load: aVersion
	aVersion load! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
testBackport
	| inst base final backported ancestry |
	inst := self mockInstanceA.
	base := self snapshot.

	self assert: inst one equals: 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 equals: 2.
	self assert: inst two equals: 3.
	ancestry := workingCopy ancestry.
	self assert: ancestry ancestors size equals: 1.
	self assert: ancestry ancestors first equals: base info.
	self assert: ancestry stepChildren size equals: 1.
	self assert: ancestry stepChildren first equals: 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 equals: 1.
	self assert: ancestry ancestors first equals: base info.
	self assert: ancestry stepChildren size equals: 1.
	self assert: ancestry stepChildren first equals: backported info! !

!MCWorkingCopyTest methodsFor: 'actions' stamp: ''!
basicMerge: aVersion
	aVersion merge! !

!MCWorkingCopyTest methodsFor: 'actions' stamp: ''!
merge: aVersion
	[[self basicMerge: aVersion]
		on: MCMergeResolutionRequest do: [:n | n merge ]]
			on: MCNoChangesException do: [:n | ]! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: ''!
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: 'running' stamp: ''!
setUp
	| repos1 repos2 |
	super setUp.
	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'.! !

!MCWorkingHistoryBrowser commentStamp: ''!
Browser for working history!
!MCWorkingHistoryBrowser methodsFor: 'accessing' stamp: ''!
baseSnapshot
	^ package snapshot! !

!MCWriter commentStamp: ''!
Common superclass for metacello writers!
!MCWriter methodsFor: 'accessing' stamp: 'nil'!
stream: aStream
	stream := aStream! !

!MCWriter methodsFor: 'accessing' stamp: 'nil'!
stream
	^ stream! !

!MCWriter class methodsFor: 'accessing' stamp: 'nil'!
extension
	^ self readerClass extension! !

!MCWriter class methodsFor: 'writing' stamp: 'nil'!
on: aStream
	^ self new stream: aStream! !

!MCWriter class methodsFor: 'accessing' stamp: 'nil'!
readerClass
	^ self subclassResponsibility ! !

!MD5 commentStamp: ''!
This class implements the MD5 128-bit one-way hash function. It uses the MD5Plugin for better performance. Some methods are taken from the original version of MD5NonPrimitive.!
!MD5 methodsFor: 'initialization' stamp: ''!
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: ''!
finalValue

	^state! !

!MD5 methodsFor: 'accessing' stamp: ''!
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 into: (ByteArray new: 64).
		(aPositionableStream atEnd not and: [buf size = 64])
			ifTrue: [self processBuffer: buf]
			ifFalse: [
				bitLength := (aPositionableStream position - startPosition) * 8.
				self processFinalBuffer: buf bitLength: bitLength]].

	^ self finalValue! !

!MD5 methodsFor: 'private - buffers' stamp: ''!
primProcessBuffer: aByteArray withState: s

	<primitive: 'primitiveProcessBufferWithState' module: 'MD5Plugin'>
	self primitiveFailed! !

!MD5 methodsFor: 'private - buffers' stamp: ''!
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: ''!
processBuffer: aByteArray

	self primProcessBuffer: aByteArray withState: state.
	! !

!MD5 methodsFor: 'private - buffers' stamp: ''!
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 methodsFor: 'instance creation' stamp: ''!
new
	^ self isPluginAvailable
		ifTrue: [ self basicNew ]
		ifFalse: [ MD5NonPrimitive basicNew ]! !

!MD5 class methodsFor: 'accessing' stamp: ''!
hashSize
	^ 16! !

!MD5 class methodsFor: 'accessing' stamp: ''!
blockSize
	^ 64! !

!MD5 class methodsFor: 'testing' stamp: ''!
isPluginAvailable

	<primitive: 'primitivePluginAvailable' module: 'MD5Plugin'>
	^false! !

!MD5NonPrimitive commentStamp: ''!
This class implements the MD5 128-bit one-way hash function.  It relies on
the ThirtyTwoBitRegister class supplied as part of the "Digital Signatures"
functionality included in Squeak 2.7.  As of this date (1/20/2000), the
U.S. Government has lifted many of the previous restrictions on the export
of encryption software, but you should check before exporting anything
including this code.  MD5 is commonly used for some secure Internet
protocols, including authentication in HTTP, which is why I wrote it.

Submitted by Duane Maxwell

!
!MD5NonPrimitive methodsFor: 'private - functions' stamp: ''!
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 - buffers' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"Some magic numbers to get the process started"
	state := OrderedCollection newFrom: { 
			(ThirtyTwoBitRegister new load: 1732584193).
			(ThirtyTwoBitRegister new load: 4023233417).
			(ThirtyTwoBitRegister new load: 2562383102).
			(ThirtyTwoBitRegister new load: 271733878)
		 }! !

!MD5NonPrimitive methodsFor: 'private - functions' stamp: ''!
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 - rounds' stamp: ''!
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 - functions' stamp: ''!
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 - functions' stamp: ''!
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: ''!
hX: x Y: y Z: z
	" compute 'x xor y xor z'"
	^ x copy bitXor: y; bitXor: z

	! !

!MD5NonPrimitive methodsFor: 'private - functions' stamp: ''!
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: ''!
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: ''!
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: ''!
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 - buffers' stamp: ''!
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 - rounds' stamp: ''!
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 methodsFor: 'class initialization' stamp: ''!
initialize
	"MD5NonPrimitive 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 )
	 }! !

!MD5Test commentStamp: ''!
SUnit tests for MD5!
!MD5Test methodsFor: 'testing' stamp: ''!
testWikipedia1
	self 
		assert: (MD5 hashMessage: 'The quick brown fox jumps over the lazy dog') hex 
		equals: '9e107d9d372bb6826bd81d3542a419d6'! !

!MD5Test methodsFor: 'testing' stamp: ''!
testEmpty
	
	self 
		assert: (MD5 hashMessage: '') hex 
		equals: 'd41d8cd98f00b204e9800998ecf8427e'! !

!MD5Test methodsFor: 'testing' stamp: ''!
testLargeCharacterStream
	"Regression test"

	| string |
	string := String streamContents: [ :out | 10 timesRepeat: [ out << Character alphabet ] ].
	hash := MD5 hashStream: string readStream.
	self assert: hash hex equals: '4e6405697346169610a3a39991c48321'! !

!MD5Test methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ MD5 ! !

!MD5Test methodsFor: 'testing' stamp: ''!
testWikipedia2
	self 
		assert: (MD5 hashMessage: 'The quick brown fox jumps over the lazy dog.') hex 
		equals: 'e4d909c290d0fb1ca068ffaddf22cbd0'! !

!MFClassA commentStamp: ''!
I'm a dummy class just to have a package that is not empty.!
!MFClassA methodsFor: 'as yet unclassified' stamp: ''!
method
	"This variable is there to trigger the 'Temporary variable not read or written' critics rule for the test SmallintManifestCheckerTest>>testCriticsOf rule"
	|foo|! !

!MFClassB commentStamp: ''!
I'm a dummy class for test purposes  !
!MFClassB methodsFor: 'as yet unclassified' stamp: ''!
method3
	"This variable is there to trigger the 'Temporary variable not read or written' critics rule for the test SmallintManifestCheckerTest>>testCriticsOf rule"
	|foo|! !

!MFClassB methodsFor: 'as yet unclassified' stamp: ''!
method2
	"This variable is there to trigger the 'Temporary variable not read or written' critics rule for the test SmallintManifestCheckerTest>>testCriticsOf rule"
	|foo|
	"Having a line of code (for example the following one) here is necessary not to fail the tests SmallintManifestCheckerTest>>testIsToDo and SmallintManifestCheckerTest>>testToDoOf"
	1.! !

!MIMEDocument commentStamp: ''!
a MIME object, along with its type and the URL it was found at (if any)!
!MIMEDocument methodsFor: '*Network-Mail' stamp: ''!
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 currentLine |
	self isMultipart ifFalse: 
		[ ^ #() ].
	parseStream := self content readStream.
	currLine := ''.
	[ '--*' match: currLine ] whileFalse: [ currLine := parseStream nextLine ].
	separator := currLine copy.

	msgStream := ZnFastLineReader on: parseStream.
	messages := OrderedCollection new.
	currentLine := ''.
	[ parseStream atEnd or: [ currentLine beginsWith: separator ] ] whileFalse: [
		| message |
		message := String streamContents: [:strm |
			[(currentLine := msgStream nextLine) isNil] whileFalse: [ 
				strm nextPutAll: currentLine; cr]].
		messages add: message.
		currentLine := msgStream nextLine ].
	^ messages collect: [ :e | MailMessage from: e ]! !

!MIMEDocument methodsFor: 'testing' stamp: ''!
isJpeg
	^ self mainType = 'image'
		and: [ #('jpeg' 'jpg') includes: self subType ]! !

!MIMEDocument methodsFor: 'accessing' stamp: ''!
contentStream
	"Answer a RWBinaryOrTextStream on the contents."

	contentStream
		ifNil: [contentStream := contents
				ifNil: [self contentStreamOnURI]
				ifNotNil: [self contents readStream]].
	^contentStream! !

!MIMEDocument methodsFor: 'private' stamp: ''!
contentStreamOnURI
	^self uri contentStream! !

!MIMEDocument methodsFor: 'testing' stamp: ''!
isGif
	^ self mainType = 'image'
		and: [self subType = 'gif']! !

!MIMEDocument methodsFor: 'private' stamp: ''!
contents: contentStringOrBytes mimeType: aMimeType uri: aURI
	type := aMimeType.
	contents := contentStringOrBytes.
	uri := aURI! !

!MIMEDocument methodsFor: 'accessing' stamp: ''!
discardContents
	contents := nil.
	self discardContentStream! !

!MIMEDocument methodsFor: 'files' stamp: ''!
saveToFile: pathString
	pathString asFileReference 
		binaryWriteStreamDo: [ :out | 
			out nextPutAll: self contents ]! !

!MIMEDocument methodsFor: 'private' stamp: ''!
contentStream: aStream mimeType: aMimeType uri: aUri
	type := aMimeType.
	contentStream := aStream.
	uri := aUri! !

!MIMEDocument methodsFor: 'testing' stamp: ''!
isMultipartAlternative
	"whether the document is in a multipart format where the parts are alternates"
	^ self contentType = 'multipart/alternative'! !

!MIMEDocument methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: self class name;
		nextPutAll: ' (';
		print: self mimeType;
		nextPutAll: ', '.
	contents
		ifNotNil: [ aStream
			print: self contents size;
			nextPutAll: ' bytes)' ]
		ifNil: [ aStream nextPutAll: 'unknown size)' ].! !

!MIMEDocument methodsFor: 'accessing' stamp: ''!
type: mimeType
	type := mimeType! !

!MIMEDocument methodsFor: 'accessing' stamp: ''!
url
	"Answer the URL the receiver was downloaded from.  It may legitimately be nil."

	^ uri ifNotNil:[uri asString asUrl]! !

!MIMEDocument methodsFor: 'accessing' stamp: ''!
mimeType
	^type! !

!MIMEDocument methodsFor: 'private' stamp: ''!
discardContentStream
	contentStream ifNotNil: [contentStream close].
	contentStream := nil! !

!MIMEDocument methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
getContentFromStream
	| streamContents |
	streamContents := self contentStream contents.
	self discardContentStream.
	^streamContents! !

!MIMEDocument methodsFor: 'testing' stamp: ''!
isPnm
	^ self mainType = 'image'
		and: [self subType = 'pnm']! !

!MIMEDocument methodsFor: 'accessing' stamp: ''!
subType
	^self mimeType sub! !

!MIMEDocument methodsFor: 'accessing' stamp: ''!
uri: aURI
	uri := aURI! !

!MIMEDocument methodsFor: 'testing' stamp: ''!
isPng
	^ self mainType = 'image'
		and: [self subType = 'png']! !

!MIMEDocument methodsFor: 'accessing' stamp: ''!
mainType
	^self mimeType main! !

!MIMEDocument methodsFor: 'accessing' stamp: ''!
uri
	"Answer the URL the receiver was downloaded from.  It may legitimately be nil."

	^uri! !

!MIMEDocument methodsFor: 'compatibility' stamp: ''!
contentType
	^self mimeType asString! !

!MIMEDocument methodsFor: 'private' stamp: ''!
privateContent: aString
	contents := aString! !

!MIMEDocument methodsFor: 'compatibility' stamp: ''!
content
	^self contents! !

!MIMEDocument methodsFor: 'testing' stamp: ''!
isMultipart
	^self mainType = 'multipart'! !

!MIMEDocument class methodsFor: 'compatibility' stamp: ''!
guessContentTypeFromExtension: ext
	"guesses a content type from the extension"
	^(self guessTypeFromExtension: ext) asString! !

!MIMEDocument class methodsFor: 'compatibility' stamp: ''!
resetMIMEdatabase
	"no-op for catching Kom override"! !

!MIMEDocument class methodsFor: 'compatibility' stamp: ''!
guessTypeFromExtension: ext
	"guesses a content type from the extension"
	^self guessTypeFromName: ext! !

!MIMEDocument class methodsFor: 'instance creation' stamp: ''!
contents: content mimeType: aMimeType uri: aURL
	"create a MIMEDocument with the given content-type and content"
	"MIMEDocument mimeType: 'text/plain' asMIMEType content: 'This is a test'"
	
	^self new contents: content mimeType: aMimeType uri: aURL! !

!MIMEDocument class methodsFor: 'instance creation' stamp: ''!
content: aString
	^self contentType: self defaultContentType  content: aString! !

!MIMEDocument class methodsFor: 'instance creation' stamp: ''!
contentStream: aStream
	^ self 
		contentStream: aStream 
		mimeType: self defaultMIMEType! !

!MIMEDocument class methodsFor: 'instance creation' stamp: ''!
contentStream: aStream mimeType: aMimeType 
	"create a MIMEDocument with the given content-type and contentStream"
	"MIMEDocument mimeType: 'text/plain' asMIMEType contentStream: (ReadStream on: 'This is a test')"
	
	^self contentStream: aStream mimeType: aMimeType uri: aStream uri! !

!MIMEDocument class methodsFor: 'content-types' stamp: ''!
contentTypeFormData
	^'application/x-www-form-urlencoded'! !

!MIMEDocument class methodsFor: 'instance creation' stamp: ''!
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: 'compatibility' stamp: ''!
guessTypeFromName: url
	"guesses a content type from the url"
	
	| extension |
	extension := url asString copyAfterLast: $..
	^ ZnMimeType
		forFilenameExtension: extension
		ifAbsent: [ nil ]! !

!MIMEDocument class methodsFor: 'compatibility' stamp: ''!
contentType: aMIMEType content: content
	"create a MIMEDocument with the given content-type and content"
	"MIMEDocument contentType: 'text/plain' content: 'This is a test'"
	
	^ self new
		privateContent: content;
		type: aMIMEType asZnMimeType;
		yourself! !

!MIMEDocument class methodsFor: 'content-types' stamp: ''!
contentTypeXml
	^'text/xml'! !

!MIMEDocument class methodsFor: 'compatibility' stamp: ''!
contentType: type content: content url: url
	^ self 
		contents: content 
		mimeType: type asZnMimeType 
		uri: url! !

!MIMEDocument class methodsFor: 'accessing' stamp: ''!
defaultMIMEType
	^ ZnMimeType default! !

!MIMEDocument class methodsFor: 'content-types' stamp: ''!
contentTypeMultipart
	^'multipart/form-data'! !

!MIMEDocument class methodsFor: 'compatibility' stamp: ''!
defaultContentType
	^self defaultMIMEType asString! !

!MIMEDocument class methodsFor: 'instance creation' stamp: ''!
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: 'content-types' stamp: ''!
contentTypePlainText
	^'text/plain'! !

!MIMEDocument class methodsFor: 'instance creation' stamp: ''!
contents: aString
	^ self 
		contents: aString 
		mimeType: self defaultMIMEType! !

!MIMEDocument class methodsFor: 'content-types' stamp: ''!
contentTypeHtml
	^'text/html'! !

!MIMEHeaderValue commentStamp: ''!
I contain the value portion of a MIME-compatible header.

I must be only initialized with the value and not the field name.  E.g. in processing
	Subject: This is the subject
the MIMEHeaderValue should be given only 'This is the subject'

For traditional non-MIME headers, the complete value returned for mainValue and paramaters returns an empty collection.

For MIME headers, both mainValue and parameters are used.!
!MIMEHeaderValue methodsFor: 'accessing' stamp: ''!
mainValue
	^mainValue! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: ''!
parameters
	^parameters! !

!MIMEHeaderValue methodsFor: 'printing' stamp: ''!
asHeaderValue
	| strm |
	strm := (String new: 20) writeStream.
	strm nextPutAll: mainValue.
	parameters
		associationsDo: [ :e | 
			strm
				nextPut: $;;
				nextPutAll: e key;
				nextPutAll: '="';
				nextPutAll: e value;
				nextPutAll: '"' ].
	^ strm contents! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: ''!
parameters: anObject
	parameters := anObject! !

!MIMEHeaderValue methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream 
		nextPutAll: ': ';
		nextPutAll: self asHeaderValue! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: ''!
mainValue: anObject
	mainValue := anObject! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: ''!
parameterAt: aParameter put: value
	parameters at: aParameter put: value! !

!MIMEHeaderValue class methodsFor: 'instance creation' stamp: ''!
fromTraditionalHeader: aString
	"This is a traditional non-MIME header (like Subject:) and so should be stored whole"

	| newValue |
	newValue := self new.
	newValue mainValue: aString.
	newValue parameters: #().
	^newValue! !

!MIMEHeaderValue class methodsFor: 'instance creation' stamp: ''!
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 
			findAnySubstring: '='
			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: ''!
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 ]! !

!MOPTestClassA methodsFor: 'local' stamp: ''!
c

	^ 'Trait3>>c'! !

!MOPTestClassA methodsFor: 'local' stamp: ''!
c3

	^ 'Trait3>>c3'! !

!MOPTestClassA methodsFor: 'trait2 - c' stamp: ''!
c2

	^ 'Trait2>>c2'! !

!MOPTestClassA class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MOPTestClassA class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MOPTestClassA class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MOPTestClassA class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MOPTestClassA class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MOPTestClassA class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MOPTestClassA class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MOPTestClassA class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MOPTestClassA class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MOPTestClassA class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MOPTestClassA class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MOPTestClassA class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MOPTestClassA class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MOPTestClassA class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MOPTestClassA class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MOPTestClassA class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MOPTestClassA class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MOPTestClassA class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MOPTestClassA class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MOPTestClassA class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MOPTestClassA class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MOPTestClassA class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MOPTestClassA class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MOPTestClassA class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MOPTestClassA class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MOPTestClassA class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MOPTestClassA class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MOPTestClassA class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MOPTestClassA class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MOPTestClassB methodsFor: 'trait1 - c' stamp: ''!
c

	^ 'Trait1>>c'! !

!MOPTestClassB methodsFor: 'trait1 - c' stamp: ''!
c1

	^ 'Trait1>>c1'! !

!MOPTestClassB methodsFor: 'trait2 - c' stamp: ''!
c2

	^ 'Trait2>>c2'! !

!MOPTestClassB class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MOPTestClassB class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MOPTestClassB class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MOPTestClassB class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MOPTestClassB class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MOPTestClassB class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MOPTestClassB class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MOPTestClassB class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MOPTestClassB class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MOPTestClassB class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MOPTestClassB class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MOPTestClassB class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MOPTestClassB class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MOPTestClassB class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MOPTestClassB class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MOPTestClassB class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MOPTestClassB class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MOPTestClassB class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MOPTestClassB class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MOPTestClassB class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MOPTestClassB class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MOPTestClassB class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MOPTestClassB class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MOPTestClassB class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MOPTestClassB class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MOPTestClassB class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MOPTestClassB class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MOPTestClassB class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MOPTestClassB class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MOPTestClassC methodsFor: 'local' stamp: ''!
c

	^ 'C>>c'! !

!MOPTestClassC methodsFor: 'trait2 - c' stamp: ''!
c2

	^ 'Trait2>>c2'! !

!MOPTestClassC class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MOPTestClassC class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MOPTestClassC class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MOPTestClassC class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MOPTestClassC class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MOPTestClassC class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MOPTestClassC class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MOPTestClassC class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MOPTestClassC class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MOPTestClassC class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MOPTestClassC class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MOPTestClassC class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MOPTestClassC class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MOPTestClassC class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MOPTestClassC class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MOPTestClassC class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MOPTestClassC class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MOPTestClassC class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MOPTestClassC class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MOPTestClassC class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MOPTestClassC class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MOPTestClassC class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MOPTestClassC class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MOPTestClassC class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MOPTestClassC class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MOPTestClassC class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MOPTestClassC class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MOPTestClassC class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MOPTestClassC class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MOPTestClassD methodsFor: 'trait2 - c' stamp: ''!
c

	^ 'Trait2>>c'! !

!MOPTestClassD methodsFor: 'trait2 - c' stamp: ''!
c3

	^ 'Trait2>>c2'! !

!MOPTestClassD methodsFor: 'trait2 - c' stamp: ''!
c2

	^ 'Trait2>>c2'! !

!MOPTestClassD class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MOPTestClassD class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MOPTestClassD class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MOPTestClassD class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MOPTestClassD class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MOPTestClassD class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MOPTestClassD class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MOPTestClassD class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MOPTestClassD class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MOPTestClassD class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MOPTestClassD class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MOPTestClassD class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MOPTestClassD class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MOPTestClassD class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MOPTestClassD class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MOPTestClassD class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MOPTestClassD class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MOPTestClassD class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MOPTestClassD class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MOPTestClassD class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MOPTestClassD class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MOPTestClassD class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MOPTestClassD class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MOPTestClassD class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MOPTestClassD class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MOPTestClassD class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MOPTestClassD class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MOPTestClassD class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MOPTestClassD class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MOPTraitTest methodsFor: 'tests' stamp: ''!
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 equals: #c.
	self assert: (MOPTestClassC>>#c) selector equals: #c.
	self assert: (Trait3>>#c) selector equals: #c.
	self assert: (Trait3>>#c2) selector equals: #c2.
	self assert: (MOPTestClassD>>#c3) selector equals: #c3.! !

!MOPTraitTest methodsFor: 'tests' stamp: ''!
testOrigin
	"The origin of a compiledMethod is its defining class or trait."

	| aliasedMethod |
	self assert: (MOPTestClassC >> #c) origin equals: MOPTestClassC.
	self assert: (MOPTestClassA >> #c) origin equals: Trait3.
	self assert: (Trait3 >> #c2) origin equals: Trait2.
	self assert: (MOPTestClassA >> #c2) origin equals: Trait2.
	self assert: (MOPTestClassB >> #c) origin equals: Trait1.
	self assert: (MOPTestClassD >> #c3) origin equals: Trait2.
	self assert: (MOPTestClassD >> #c2) origin equals: Trait2.

	aliasedMethod := MOPTestClassD >> #c3.
	self assert: aliasedMethod origin identicalTo: aliasedMethod originMethod methodClass! !

!MOPTraitTest methodsFor: 'tests' stamp: ''!
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 equals: Trait1.
	self assert: (Trait2>>#c) methodClass equals: Trait2.
	self assert: (MOPTestClassC>>#c) methodClass equals: MOPTestClassC.
	self assert: (MOPTestClassC>>#c2) methodClass equals: MOPTestClassC.
	self assert: (MOPTestClassD>>#c) methodClass equals: MOPTestClassD.
	self assert: (MOPTestClassD>>#c2) methodClass equals: MOPTestClassD.
	self assert: (MOPTestClassD>>#c3) methodClass equals: MOPTestClassD.
	self assert: (MOPTestClassA>>#c2) methodClass equals: MOPTestClassA.
	! !

!MacOSPlatform commentStamp: ''!
I am a an object representing a Mac OS (pre OSX) platform. Use myself to access platform specific features.
!
!MacOSPlatform methodsFor: '*System-Sources' stamp: ''!
potentialLocationsOfSourcesFile
	^ {
		"Take care of .app that have a 'Resources' folder as a sibling of the vm binary"
		Smalltalk vm fullPath asFileReference parent parent / 'Resources'.
		Smalltalk vm directory.
		Smalltalk vm fullPath asFileReference parent.
		FileLocator systemApplicationSupport.
		FileLocator userApplicationSupport.
	}! !

!MacOSPlatform methodsFor: 'accessing' stamp: 'nil'!
defaultMaximumPathLength
		"This method returns the default maximum path length for the getCurrentWorkingDirectory implementation. MacOS default PATH_MAX is 1024.  PATH_MAX is needed to avoid buffer overflow. In case PATH_MAX is not sufficient the method currentWorkingDirectoryWithBufferSize: can be used to give desired buffer size."
	 ^1024
! !

!MacOSPlatform methodsFor: '*Network-Kernel' stamp: ''!
configureHttpProxy

	InternetConfiguration configureHttpProxy! !

!MacOSPlatform methodsFor: 'accessing' stamp: 'nil'!
menuShortcutString
	^ 'cmd'! !

!MacOSPlatform methodsFor: 'testing' stamp: 'nil'!
isMacOS
	^ true! !

!MacOSPlatform methodsFor: '*Keymapping-Core' stamp: ''!
shortcutPrinter
	
	^ KMOSXShortcutPrinter new! !

!MacOSPlatform methodsFor: '*Spec2-Core' stamp: ''!
configureApplication: anApplication configuration: aConfiguration
	
	aConfiguration configureOSX: anApplication! !

!MacOSPlatform methodsFor: 'accessing' stamp: 'nil'!
family
	^#MacOS! !

!MacOSPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiLibraryName: aLibrary 
	^ aLibrary macLibraryName! !

!MacOSPlatform methodsFor: 'accessing' stamp: 'nil'!
keyForValue: aKeyValue
	^KeyboardKey valueForMacOSXPlatform: aKeyValue.! !

!MacOSPlatform methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
defaultModifier

	^ KMModifier command! !

!MacOSPlatform methodsFor: 'accessing' stamp: 'nil'!
lineEnding

	^ String lf! !

!MacOSPlatform methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor

	^ aVisitor visitMacOS: self! !

!MacOSPlatform class methodsFor: 'testing' stamp: 'nil'!
isMacOS

	^ Smalltalk vm operatingSystemName = 'Mac OS'! !

!MacOSResolver commentStamp: ''!
I am an expert on Mac OS X filesystem conventions. I resolve origins according to these conventions.!
!MacOSResolver methodsFor: 'origins' stamp: ''!
userApplicationSupport
	<origin>
	^self userLibrary / 'Application Support'! !

!MacOSResolver methodsFor: 'origins' stamp: ''!
library
	^ self userLibrary! !

!MacOSResolver methodsFor: 'origins' stamp: ''!
userLibrary
	<origin>
	^  self home / 'Library'! !

!MacOSResolver methodsFor: 'origins' stamp: ''!
temp
	^ '/tmp' asFileReference! !

!MacOSResolver methodsFor: 'origins' stamp: ''!
cache
	^ self library / 'Caches'! !

!MacOSResolver methodsFor: 'origins' stamp: ''!
home
	^ self directoryFromEnvVariableNamed: 'HOME'! !

!MacOSResolver methodsFor: 'origins' stamp: ''!
preferences 
	^ self home / 'Library' / 'Preferences'! !

!MacOSResolver methodsFor: 'origins' stamp: ''!
systemLibrary
	<origin>
	^  FileSystem disk root / 'Library'! !

!MacOSResolver methodsFor: 'origins' stamp: ''!
systemApplicationSupport
	<origin>
	^ self systemLibrary / 'Application Support'! !

!MacOSResolver class methodsFor: 'accessing' stamp: ''!
platformName
	^  'Mac OS'! !

!MacOSXPlatform commentStamp: ''!
I am a an object representing a MacOSX platform. Use myself to access platform specific features.

Please keep me polymorphic to the the other platform objects.

To get the current platform, you can evaluate:

OSPlatform current.!
!MacOSXPlatform methodsFor: 'accessing' stamp: 'nil'!
family
	^#MacOSX! !

!MacOSXPlatform methodsFor: 'testing' stamp: 'nil'!
isMacOSX
	^ true! !

!MacOSXPlatform methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor

	^ aVisitor visitMacOSX: self! !

!MacOSXPlatform methodsFor: '*OSWindow-SDL2' stamp: ''!
sdlPlatform

	^ SDLOSXPlatform new! !

!MacOSXPlatform class methodsFor: 'testing' stamp: 'nil'!
isActivePlatform
	^ self isMacOS! !

!MacRomanTextConverter commentStamp: ''!
Text converter for Mac Roman.  An encoding used for the languages originated from Western Europe area.!
!MacRomanTextConverter class methodsFor: 'initialization' stamp: ''!
initialize
	self initializeTables! !

!MacRomanTextConverter class methodsFor: 'initialization' stamp: ''!
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 )! !

!MacRomanTextConverter class methodsFor: 'accessing' stamp: ''!
encodingNames 

	^ #('mac-roman' ) copy
! !

!MacStore commentStamp: ''!
I'm a specific store for OSX file systems!
!MacStore methodsFor: '*Zinc-Resource-Meta-Core' stamp: 'nil'!
mimeTypesAt: aPath
	"Return a list of MIME types applicable to the receiver. This default implementation uses the file name extension to figure out what we're looking at but specific subclasses may use other means of figuring out what the type of some file is. Some systems like the macintosh use meta data on the file to indicate data type"
	"| typeCreator type | 
	typeCreator := self getMacFileTypeAndCreator: ((self fullNameFor: fileName)).
	type := (typeCreator at: 1) asLowercase.
	^TypeToMimeMappings at: type ifAbsent:[super mimeTypesFor: fileName]"
	self flag: 'TODO: properly implement the mac os version'.
	^ super mimeTypesAt: aPath! !

!MacStore class methodsFor: 'current' stamp: ''!
isActiveClass
	^ Smalltalk os isMacOS! !

!MacStore class methodsFor: 'current' stamp: ''!
readOnlyVariant

	^ ReadOnlyMacStore! !

!Magnitude commentStamp: ''!
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: 'testing' stamp: ''!
< aMagnitude 
	"Answer whether the receiver is less than the argument."

	^self subclassResponsibility! !

!Magnitude methodsFor: '*Math-Operations-Extensions' stamp: ''!
compareWith: anotherMagnitude ifLesser: lesserBlock ifEqual: equalBlock ifGreater: greaterBlock

	^ self < anotherMagnitude
		ifTrue: lesserBlock
		ifFalse: [ 
			self = anotherMagnitude
				ifTrue: equalBlock
				ifFalse: greaterBlock ]! !

!Magnitude methodsFor: 'comparing' stamp: ''!
= aMagnitude 
	"Compare the receiver with the argument and answer with true if the 
	receiver is equal to the argument. Otherwise answer false."

	^self subclassResponsibility! !

!Magnitude methodsFor: 'testing' stamp: ''!
>= aMagnitude 
	"Answer whether the receiver is greater than or equal to the argument."

	^aMagnitude <= self! !

!Magnitude methodsFor: 'comparing' stamp: ''!
hash
	"Hash must be redefined whenever = is redefined."

	^self subclassResponsibility! !

!Magnitude methodsFor: '*Iceberg-Libgit' stamp: ''!
iceSemanticVersion
	^ IceSemanticVersion major: self asInteger minor: 0 patch: 0! !

!Magnitude methodsFor: '*SortFunctions-Core-comparing' stamp: ''!
threeWayCompareTo: anotherObject
	"Do a three-way comparison between the receiver and anotherObject, returning
	-1 if self < anotherObject
	0 if self = anotherObject
	1 if self > anotherObject
	This assumes a total order in accordance with the mathematical law of trichotomy.
	See also:  http://en.wikipedia.org/wiki/Three-way_comparison"

	^ self = anotherObject
		ifTrue: [ 0 ]
		ifFalse: [ self < anotherObject
				ifTrue: [ -1 ]
				ifFalse: [ 1 ] ]! !

!Magnitude methodsFor: 'comparing' stamp: ''!
min: aMagnitude 
	"Answer the receiver or the argument, whichever has the lesser 
	magnitude."

	self < aMagnitude
		ifTrue: [^self]
		ifFalse: [^aMagnitude]! !

!Magnitude methodsFor: 'comparing' stamp: ''!
min: maxValue max: minValue
	"Take the minimum between self and maxValue, then the maximum with minValue"
	"(10 min: 20 max: 5) >>> 10"
	"(10 min: 20 max: 11) >>> 11"
	"(24 min: 20 max: 5) >>> 20"

	^ (self min: maxValue) max: minValue! !

!Magnitude methodsFor: 'testing' stamp: ''!
> aMagnitude 
	"Answer whether the receiver is greater than the argument."

	^aMagnitude < self! !

!Magnitude methodsFor: 'testing' stamp: ''!
between: min and: max 
	"Answer whether the receiver is less than or equal to the argument, max, 
	and greater than or equal to the argument, min."

	^self >= min and: [self <= max]! !

!Magnitude methodsFor: 'comparing' stamp: ''!
beBetween: minValue and: maxValue
	"Answer my value constrained to the interval [minValue ; maxValue]
	I take care of the situation where minValue > maxValue"
	"(10 beBetween: 12 and: 20) >>> 12"
	"(10 beBetween: 20 and: 12) >>> 12"
	"(13 beBetween: 12 and: 20) >>> 13"
	"(12 beBetween: 12 and: 20) >>> 12"
	"(100 beBetween: 12 and: 20) >>> 20"
 
	^ minValue <= maxValue 
		ifTrue: [ (self min: maxValue) max: minValue ]
		ifFalse: [ (self min: minValue) max: maxValue ]! !

!Magnitude methodsFor: 'testing' stamp: ''!
<= aMagnitude 
	"Answer whether the receiver is less than or equal to the argument."

	^(self > aMagnitude) not! !

!Magnitude methodsFor: 'comparing' stamp: ''!
max: aMagnitude 
	"Answer the receiver or the argument, whichever has the greater 
	magnitude."

	self > aMagnitude
		ifTrue: [^self]
		ifFalse: [^aMagnitude]! !

!Magnitude class methodsFor: '*Tool-Finder' stamp: ''!
approvedSelectorsForMethodFinder

	^ self selectors! !

!Magnitude class methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
systemIconName

	^ #magnitudeIcon! !

!MagnitudeTest commentStamp: ''!
A MagnitudeTest is a test class for testing the behavior of Magnitude!
!MagnitudeTest methodsFor: 'tests' stamp: ''!
testMax

	| huge |
	self assert: ( 2 max: 3) equals: 3.
	huge := Float fmax asInteger + 1.
	self assert: (Float fmax max: huge) equals: huge.
	self assert: (1/3 max: 0.33333333333333333333333333333333333333333) equals: 1/3! !

!MagnitudeTest methodsFor: 'tests' stamp: ''!
testBetweenAnd
	self assert: (3 between: 0 and: 5).
	self assert: (5.0 between: 5.0 and: 5.0).
	self assert: (Date today between: Date today +1 and: Date today +3) not! !

!MagnitudeTest methodsFor: 'tests' stamp: ''!
testThreeWayCompareTo

	self assert: ($b threeWayCompareTo: $a) equals: 1.
	self assert: ($a threeWayCompareTo: $b) equals: -1.
	self assert: ($b threeWayCompareTo: $b ) equals: 0.! !

!MagnitudeTest methodsFor: 'tests' stamp: ''!
testBeBetweenAnd
	"inside"
	self assert: (10 beBetween: 5 and: 20) equals: 10.
	self assert: (10 beBetween: 20 and: 5) equals: 10.
	"equal to one end interval"
	self assert: (5 beBetween: 5 and: 20) equals: 5.
	self assert: (5 beBetween: 20 and: 5) equals: 5.
	self assert: (20 beBetween: 5 and: 20) equals: 20.
	self assert: (20 beBetween: 20 and: 5) equals: 20.
	"below"
	self assert: (1 beBetween: 5 and: 20) equals: 5.
	self assert: (1 beBetween: 20 and: 5) equals: 5.
	"above"
	self assert: (30 beBetween: 5 and: 20) equals: 20.
	self assert: (30 beBetween: 20 and: 5) equals: 20.! !

!MagnitudeTest methodsFor: 'tests' stamp: ''!
testCompareWithIfLesserIfEqualIfGreater

	self assert: ($b compareWith: $a ifLesser: [ 1 ] ifEqual: [ 2 ] ifGreater: [3]) equals: 3.
	self assert: ($a compareWith: $b ifLesser: [ 1 ] ifEqual: [ 2 ] ifGreater: [3]) equals: 1.
	self assert: ($b compareWith: $b ifLesser: [ 1 ] ifEqual: [ 2 ] ifGreater: [3]) equals: 2.! !

!MagnitudeTest methodsFor: 'tests' stamp: ''!
testMin

	| huge aThirdFloat |
	self assert: ( 2 min: 3) equals: 2.
	huge := Float fmax asInteger + 1.
	self assert: (Float fmax min: huge) equals: Float fmax.
	aThirdFloat := 0.33333333333333333333333333333333333333333.
	self assert: (1/3 min: aThirdFloat) equals: aThirdFloat! !

!MagnitudeTest methodsFor: 'tests' stamp: ''!
testMinMax

	self assert: (10 min: 20 max: 12) equals: 12.
	self assert: (13  min: 20 max: 12) equals: 13.
	self assert: (12 min: 20 max: 12) equals: 12.
	self assert: (100  min: 20 max: 12) equals: 20.
	self assert: (42 min: 50 max: 40) equals: 42.
	self assert: (42 min: 50 max: 45) equals: 45.
	self assert: (42 min: 40 max: 30) equals: 40! !

!MailAddressParser commentStamp: ''!
Parse mail addresses.  The basic syntax is:

	addressList := MailAddressParser addressesIn: aString

This currently only returns the bare addresses, but it could also return a list of the address "source codes".  For example, if you give it "Joe <joe@foo>, <jane>", it will currently return a list ('joe@foo' 'jane').  It would be nice to also get a list ('Joe <joe@foo>'  '<jane>').!
!MailAddressParser methodsFor: 'building address list' stamp: ''!
startNewAddress
	"set up data structures to begin a new address"

	curAddrTokens notNil
		ifTrue: [ self error: 'starting new address before finishing the last one!!' ].
	curAddrTokens := OrderedCollection new! !

!MailAddressParser methodsFor: 'building address list' stamp: ''!
finishAddress
	"we've finished one address.  Bundle it up and add it to the list of addresses"
	| address |

	address := String streamContents: [ :str |
		curAddrTokens do: [ :tok | str nextPutAll: tok text ] ].

	addresses addFirst: address.

	curAddrTokens := nil.! !

!MailAddressParser methodsFor: 'parsing' stamp: ''!
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: ''!
removePhrase
	"skip most characters to the left of this"

	[
		tokens isNotEmpty and: [
			#(Atom QuotedString $. $@) includes: (tokens last type) ]
	] whileTrue: [ tokens removeLast ].! !

!MailAddressParser methodsFor: 'parsing' stamp: ''!
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: ''!
grabAddressesAndNames
	
	storeNames := true.
	self grabAddresses.
	addresses := addresses collect: [:a |
		a isString 
			ifTrue: [{'' . a}]
			ifFalse: [a] ].
	^ addresses! !

!MailAddressParser methodsFor: 'parsing' stamp: ''!
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: ''!
grabName

	| name |
	name := ''.
	[tokens notEmpty and: [#(Atom QuotedString $. $@) includes: (tokens last type) ]] 
		whileTrue: [ name := ' ' join: {tokens removeLast text copyWithoutAll: '"'. name} ].
	^ name trimBoth! !

!MailAddressParser methodsFor: 'building address list' stamp: ''!
addToAddress
	"add the last token to the address.  removes the token from the collection"
	curAddrTokens addFirst: (tokens removeLast)! !

!MailAddressParser methodsFor: 'parsing' stamp: ''!
grabAddressWithRoute
	"grab an address of the form 'Descriptive Text <real.address@c.d.e>"

	| name |
	
	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 finishAddress.
	name := self grabName.
	storeNames ifTrue: [addresses addFirst: {name . addresses removeFirst}].! !

!MailAddressParser methodsFor: 'initialization' stamp: ''!
initialize: tokenList
	tokens := tokenList asOrderedCollection copy.
	addresses := OrderedCollection new.
	storeNames := false.! !

!MailAddressParser class methodsFor: 'parsing' stamp: ''!
addressesIn: aString
	"return a collection of the bare addresses listed in aString"
	| tokens |
	tokens := MailAddressTokenizer tokensIn: aString.
	^(self new initialize: tokens) grabAddresses! !

!MailAddressParser class methodsFor: 'parsing' stamp: ''!
addressesAndNamePairsIn: aString
	"return a collection of the addresses and the corresponding names listed in aString"
	| tokens |
	tokens := MailAddressTokenizer tokensIn: aString.
	^(self new initialize: tokens) grabAddressesAndNames! !

!MailAddressParserTest commentStamp: ''!
This is the unit test for the class MailAddressParser. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- there is a chapter in the PharoByExample book (http://pharobyexample.org)
	- the sunit class category!
!MailAddressParserTest methodsFor: 'tests' stamp: ''!
testAddressesIn

	| testString correctAnswer |

	testString := 'joe@lama.com, joe2@lama.com joe3@lama.com joe4 , Not an Address <joe5@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 <lex>'.

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) equals:  correctAnswer! !

!MailAddressParserTest methodsFor: 'tests' stamp: ''!
testAmpersand

	| testString correctAnswer |

	testString := '&@example.com, romeo&julia@verona.it'.

	correctAnswer := #('&@example.com' 'romeo&julia@verona.it') asOrderedCollection.

	self assert: (MailAddressParser addressesIn: testString) equals: correctAnswer! !

!MailAddressParserTest methodsFor: 'tests' stamp: ''!
testAddressesAndNamePairsIn

	| address |
	address := MailAddressParser addressesAndNamePairsIn: 'first last <person@company.com>'.
	self assert: address size equals: 1.
	self assert: address first equals: #('first last' 'person@company.com')! !

!MailAddressToken commentStamp: ''!
a single token from an RFC822 mail address.  Used internally in MailAddressParser!
!MailAddressToken methodsFor: 'printing' stamp: ''!
printOn: aStream
	
	aStream 
		nextPut: $[;
	 	print: self type ;
		nextPut: $|;
		nextPutAll: self text;
		nextPut: $].! !

!MailAddressToken methodsFor: 'private' stamp: ''!
type: type0  text: text0
	type := type0.
	text := text0.! !

!MailAddressToken methodsFor: 'accessing' stamp: ''!
type
	^type! !

!MailAddressToken methodsFor: 'accessing' stamp: ''!
text
	^text! !

!MailAddressToken class methodsFor: 'instance creation' stamp: ''!
type: type  text: text
	^self new type: type text: text! !

!MailAddressTokenizer commentStamp: ''!
Divides an address into tokens, as specified in RFC 822.  Used by MailAddressParser.!
!MailAddressTokenizer methodsFor: 'tokenizing' stamp: ''!
nextAtom
	| start end |
	start := pos.
	pos := self indexOfNextNonAtomIn: text startingAt: start ifAbsent: [ text size + 1].
	end := pos - 1.
	^MailAddressToken
		type: #Atom
		text: (text copyFrom: start to: end)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: ''!
skipSeparators
	pos := text indexOfAnyOf: CSNonSeparators  startingAt: pos  ifAbsent: [ text size + 1 ].! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: ''!
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: 'stream protocol' stamp: ''!
peek
	cachedToken ifNil: [ cachedToken := self nextToken. ].
	
	^cachedToken! !

!MailAddressTokenizer methodsFor: 'stream protocol' stamp: ''!
next
	| ans |
	cachedToken ifNil: [ ^self nextToken ].
	ans := cachedToken.
	cachedToken := nil.
	^ans! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: ''!
nextComment
	| start nestLevel paren |
	start := pos.
	pos := pos + 1.
	nestLevel := 1.
	[ nestLevel > 0 ]
		whileTrue: [ 
			pos := text indexOfAnyOf: CSParens startingAt: pos ifAbsent: [ 0 ].
			pos = 0
				ifTrue: [ self error: 'unterminated comment.  ie, more (''s than )''s' ].
			paren := self nextChar.
			nestLevel := paren = $(
				ifTrue: [ nestLevel + 1 ]
				ifFalse: [ nestLevel - 1 ] ].
	^ MailAddressToken type: #Comment text: (text copyFrom: start to: pos - 1)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: ''!
nextChar
	self atEndOfChars ifTrue: [ ^nil ].
	pos := pos + 1.
	^text at: (pos-1)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: ''!
indexOfNextNonAtomIn: aString startingAt: startIndex ifAbsent: absentBlock
	"Answer the index of the next non-atom character after startIndex in aString.
	If not found, answer absentBlock value"

	| index indexChar stringSize |

	stringSize := aString size.
	"First try the primitive (which only handles code points < 256)"
	index := aString indexOfAnyOf: CSNonAtom startingAt: startIndex ifAbsent: absentBlock.
	(index > stringSize or: [ (aString at: index) codePoint < 256 ]) ifTrue: 
		[ ^index ].

	"#indexOfAnyOf:startingAt:ifAbsent: has stopped at a character with a code point above 255.
	Manually step forward until we find a non-atom character or the end of the string"
	indexChar := aString at: index.
	[ index <= stringSize and: 
		[ (CSNonAtom includes: indexChar) not or: 
		[ indexChar codePoint > 255 ] ] ] whileTrue:
			[ index := index + 1.
			index <= stringSize ifTrue:
				[ indexChar := aString at: index ] ].
	^index! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: ''!
peekChar
	^text at: pos ifAbsent: [ nil ]! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: ''!
atEndOfChars
	^pos > text size! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: ''!
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: ''!
nextSpecial
	| c |
	c := self nextChar.
	^MailAddressToken type: c  text: c asString.! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: ''!
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: 'stream protocol' stamp: ''!
atEnd
	^ self peek isNil! !

!MailAddressTokenizer methodsFor: 'initialization' stamp: ''!
initialize: aString
	text := aString.
	pos := 1.! !

!MailAddressTokenizer class methodsFor: 'initialization' stamp: ''!
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: '!!#$%&''*+-/=?^_`{|}~'.
	"RFC 6531 allows characters with value > 127 encoded as UTF-8, which means values between 128 and 255 may appear as part of atoms."
	atomChars addAll: ((Character value: 128) to: (Character value: 255)).

	CSNonAtom :=  atomChars complement.! !

!MailAddressTokenizer class methodsFor: 'instance creation' stamp: ''!
forString: aString
	^self basicNew initialize: aString! !

!MailAddressTokenizer class methodsFor: 'instance creation' stamp: ''!
tokensIn: aString
	"return a collection of the tokens in aString"
	^(self forString: aString) upToEnd! !

!MailAddressTokenizerTest methodsFor: 'tests' stamp: ''!
testTokensInUnicode
	"RFC6531 (February 2012) allows character values > 127.
	Check that the parser handles values greater than 255 (which require multi-byte encoding)"

	| email tokens tokensCollection |

	email := 'first last <person@company.com>' copy.
	email
		at: 3 put: 345 asCharacter;
		at: 15 put: 345 asCharacter.
	tokens := MailAddressTokenizer tokensIn: email.
	tokensCollection := tokens collect: [ :each |
		each type -> each text ] as: Array.
	self 
		assert: tokensCollection
		equals: {
			#Atom->('first' copy
				at: 3 put: 345 asCharacter;
				yourself). 
			#Atom->'last' copy. 
			$<->'<'. 
			#Atom->('person' copy
				at: 3 put: 345 asCharacter;
				yourself). 
			$@->'@'. 
			#Atom->'company'. 
			$.->'.'. 
			#Atom->'com'. 
			$>->'>'}! !

!MailAddressTokenizerTest methodsFor: 'tests' stamp: ''!
testTokensInLatin
	"RFC6531 (February 2012) allows character values > 127.
	Check that the parser handles values between 128 and 255 (which can be correctly represented with single byte encoding)"

	| email tokens tokensCollection |

	email := 'first last <person@company.com>' copy.
	email
		at: 2 put: 237 asCharacter;
		at: 14 put: 233 asCharacter.
	tokens := MailAddressTokenizer tokensIn: email.
	tokensCollection := tokens collect: [ :each |
		each type -> each text ] as: Array.
	self 
		assert: tokensCollection
		equals: {
			#Atom->('first' copy
				at: 2 put: 237 asCharacter;
				yourself). 
			#Atom->'last' copy. 
			$<->'<'. 
			#Atom->('person' copy
				at: 2 put: 233 asCharacter;
				yourself). 
			$@->'@'. 
			#Atom->'company' copy. 
			$.->'.'. 
			#Atom->'com' copy. 
			$>->'>'}! !

!MailAddressTokenizerTest methodsFor: 'tests' stamp: ''!
testTokensInAscii
	"Basic test that the tokenizer returns the correct values"

	| tokens tokensCollection |

	tokens := MailAddressTokenizer tokensIn: 'first last <person@company.com>'.
	tokensCollection := tokens collect: [ :each |
		each type -> each text ] as: Array.
	self 
		assert: tokensCollection
		equals: {#Atom->'first'. #Atom->'last'. $<->'<'. #Atom->'person'. $@->'@'. #Atom->'company'. $.->'.'. #Atom->'com'. $>->'>'}! !

!MailComposition commentStamp: ''!
a message being composed.  When finished, it will be submitted via a Celeste.!
!MailComposition methodsFor: 'accessing' stamp: ''!
submit
	| message |
	"submit the message"
	self textModel hasUnacceptedEdits
		ifTrue: [ self textModel acceptEditsInView ].
	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: ''!
open
	"open an interface"
	self openInMorphic! !

!MailComposition methodsFor: 'interface' stamp: ''!
addAttachment
	| fileSelected |
	self textModel hasUnacceptedEdits
		ifTrue: [ self textModel acceptEditsInView ].
	fileSelected := UIManager default chooseFullFileNameMatching: nil.
	fileSelected ifNil: [ ^ self ].
	fileSelected
		writeStreamDo: [ :stream | 
			stream binary.
			self
				messageText:
					((MailMessage from: self messageText asString)
						addAttachmentFrom: stream withName: fileSelected basename;
						text;
						yourself) ]! !

!MailComposition methodsFor: 'interface' stamp: ''!
sendMailMessage: aMailMessage
	self messageText: aMailMessage text! !

!MailComposition methodsFor: 'accessing' stamp: ''!
textModel
	^ textModel ifNil: [ textModel := RubScrolledTextModel new interactionModel: self ]! !

!MailComposition methodsFor: 'accessing' stamp: ''!
smtpServer
	^self class smtpServer! !

!MailComposition methodsFor: 'interface' stamp: ''!
menuGet: aMenu shifted: shifted
	
	aMenu addList: {
		{'Find...(f)' .	#find}.
		{'Find again (g)' . #findAgain}.
		{'Set search string (h)' . #setSearchString}.
		#-.
		{'Accept (s)' . #accept}.
		{'Send message' .  #submit}}.
	^aMenu.! !

!MailComposition methodsFor: 'private' stamp: ''!
breakLinesInMessage: message
	"reformat long lines in the specified message into shorter ones"

	"multipart message; process the top-level parts.  HACK: the parts are modified in place"

	message body mainType = 'text'
		ifTrue: [ 
			| newBodyText "it's a single-part text message.  reformat the text" |
			newBodyText := self breakLines: message bodyText atWidth: 72.
			message body: (MIMEDocument contentType: message body contentType content: newBodyText).
			^ self ].
	message body isMultipart
		ifFalse: [ ^ self ].
	message parts
		do: [ :part | 
			part body mainType = 'text'
				ifTrue: [ 
					| newBodyText |
					newBodyText := self breakLines: part bodyText atWidth: 72.
					part body: (MIMEDocument contentType: part body contentType content: newBodyText) ] ].
	message regenerateBodyFromParts! !

!MailComposition methodsFor: 'accessing' stamp: ''!
messageText: aText
	"change the current text"
	messageText := aText.
	self changed: #messageText.
	^true! !

!MailComposition methodsFor: 'interface' stamp: ''!
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.
	textMorph := self textModel newScrolledText
		beForPlainText;
		beWrapped;
		yourself.
	textMorph menuProvider: self selector:  #menuGet:shifted:.
	morphicWindow addMorph: textMorph frame: (0 @ 0.1 corner: 1 @ 1).
	buttonsList := AlignmentMorph newRow.
	sendButton := PluggableButtonMorph on: self getState: nil action: #submit.
	sendButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'send message';
		setBalloonText: 'Accept any unaccepted edits and add this to the queue of messages to be sent';
		onColor: Color white offColor: Color white.
	buttonsList addMorphBack: sendButton.
	attachmentButton := PluggableButtonMorph on: self getState: nil action: #addAttachment.
	attachmentButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'add attachment';
		setBalloonText: 'Send a file with the message';
		onColor: Color white offColor: Color white.
	buttonsList addMorphBack: attachmentButton.
	morphicWindow addMorph: buttonsList frame: (0 @ 0 extent: 1 @ 0.1).
	morphicWindow openInWorld! !

!MailComposition methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
messageText
	"return the current text"
	^messageText.! !

!MailComposition class methodsFor: 'instance creation' stamp: ''!
sendMailMessage: aMailMessage
	| newComposition |
	newComposition := self new.
	newComposition messageText: aMailMessage text; open! !

!MailComposition class methodsFor: 'smtp server' stamp: ''!
setSmtpServer: aString
	SmtpServer := aString! !

!MailComposition class methodsFor: 'smtp server' stamp: ''!
smtpServer
	"Answer the server for sending email"

	self isSmtpServerSet
		ifFalse: [self setSmtpServer].
	SmtpServer isEmpty ifTrue: [
		self error: 'no SMTP server specified' ].

	^SmtpServer! !

!MailComposition class methodsFor: 'smtp server' stamp: ''!
isSmtpServerSet
	^ SmtpServer notNil and: [SmtpServer notEmpty]! !

!MailComposition class methodsFor: 'smtp server' stamp: ''!
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.! !

!MailMessage commentStamp: ''!
I represent an Internet mail or news message.

	text - the raw text of my message
	body - the body of my message, as a MIMEDocument
	fields - a dictionary mapping lowercased field names into collections of MIMEHeaderValue's
	parts - if I am a multipart message, then this is a cache of my parts!
!MailMessage methodsFor: 'parsing' stamp: ''!
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: 'accessing' stamp: ''!
text
	"the full, unprocessed text of the message"
	text ifNil: [ self regenerateText ].
	^text! !

!MailMessage methodsFor: 'initialization' stamp: ''!
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: 'parsing' stamp: ''!
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
		ifFalse: [ ^ self ].
	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: 'multipart' stamp: ''!
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: ''!
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: 'initialization' stamp: ''!
setField: fieldName toString: fieldValue
	^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! !

!MailMessage methodsFor: 'fields-convenience' stamp: ''!
subject: aString
	self setField: 'subject' toString: aString! !

!MailMessage methodsFor: 'multipart' stamp: ''!
attachmentSeparator
	^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters
		at: 'boundary' ifAbsent: [^nil]! !

!MailMessage methodsFor: 'accessing' stamp: ''!
recipientList

	^ (self to findTokens: $,) collect: [ :e | e trimLeft ]! !

!MailMessage methodsFor: 'printing/formatting' stamp: ''!
bodyTextFormatted
	"Answer a version of the text in my body suitable for display.  This will parse multipart forms, decode HTML, and other such things"

	"check for multipart"

	self body isMultipart
		ifTrue: [ 
			"check for alternative forms"
			self body isMultipartAlternative
				ifTrue: [ 
					"it's multipart/alternative.  search for a part that we can display, biasing towards nicer formats"
					#('text/html' 'text/plain')
						do: [ :format | 
							self parts
								do: [ :part | 
									part body contentType = format
										ifTrue: [ ^ part bodyTextFormatted ] ] ].	"couldn't find a desirable part to display; just display the first part"
					^ self parts first bodyTextFormatted ].	"not alternative parts.  put something for each part"
			^ Text
				streamContents: [ :str | 
					self parts
						do: [ :part | 
							((#('text' 'multipart') includes: part body mainType) or: [ part body contentType = 'message/rfc822' ])
								ifTrue: [ 
									"try to inline the message part"
									str nextPutAll: part bodyTextFormatted ]
								ifFalse: [ 
									| descript |
									str cr.
									descript := part name ifNil: [ 'attachment' ].
									str nextPutAll: (Text string: '[' , descript , ']' attribute: (TextMessageLink message: part)) ] ] ] ].	"check for HTML"
	self body contentType = 'text/html'
		ifTrue: [ 
			Smalltalk globals
				at: #HtmlParser
				ifPresent: [ :htmlParser | ^ (htmlParser parse: body content readStream) formattedText ] ].	"check for an embedded message"
	self body contentType = 'message/rfc822'
		ifTrue: [ ^ (MailMessage from: self body content) formattedText ].	"nothing special--just return the text"
	^ body content! !

!MailMessage methodsFor: 'accessing' stamp: ''!
date
	"Answer a date string for this message."

	^(Date fromSeconds: self time + (Date year: 1980 day: 1 ) asSeconds) 
		printFormat: #(2 1 3 47 1 2)! !

!MailMessage methodsFor: 'parsing' stamp: ''!
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 notEmpty 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: ''!
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:
		<day> <monthName> <year>		(5 April 1982; 5-APR-82)
		<monthName> <day> <year>		(April 5, 1982)
		<monthNumber> <day> <year>		(4/5/82)
	In addition, the date may be preceded by the day of the week and an optional comma, such as:
		Tue, November 14, 1989"

	| day month year |
	self skipWeekdayName: aStream.
	aStream peek isDigit ifTrue: [day := Integer readFrom: aStream].
	[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
	aStream peek isLetter
		ifTrue:		"month name or weekday name"
			[month := (String new: 10) writeStream.
			 [aStream peek isLetter] whileTrue: [month nextPut: aStream next].
			 month := month contents.
			 day ifNil:		"name/number..."
				[[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
				 (aStream peek isDigit) ifFalse: [^nil].
				 day := Integer readFrom: aStream]]
		ifFalse:		"number/number..."
			[month := Date nameOfMonth: day.
			 day := Integer readFrom: aStream].
	[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
	(aStream peek isDigit) ifFalse: [^nil].
	year := Integer readFrom: aStream.
	^Date year: year month: month day: day! !

!MailMessage methodsFor: 'fields' stamp: ''!
fieldsNamed: aString ifAbsent: aBlock
	"return a list of all fields with the given name"
	^fields at: aString asLowercase ifAbsent: aBlock! !

!MailMessage methodsFor: 'accessing' stamp: ''!
cc

	^self fieldsNamed: 'cc' separatedBy: ', '! !

!MailMessage methodsFor: 'accessing' stamp: ''!
to
	^self fieldsNamed: 'to' separatedBy: ', '! !

!MailMessage methodsFor: 'accessing' stamp: ''!
body
	"return just the body of the message"
	^body! !

!MailMessage methodsFor: 'initialization' stamp: ''!
initialize
	"initialize as an empty message"

	super initialize.
	text := String cr.
	fields := Dictionary new.
	body := MIMEDocument contentType: 'text/plain' content: String cr! !

!MailMessage methodsFor: 'printing/formatting' stamp: ''!
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: 'fields-convenience' stamp: ''!
from: senderString
	self setField: 'from' toString: senderString! !

!MailMessage methodsFor: 'multipart' stamp: ''!
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: 'printing/formatting' stamp: ''!
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: 'multipart' stamp: ''!
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: 'fields' stamp: ''!
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: ''!
hasFieldNamed: aString
	^fields includesKey: aString asLowercase! !

!MailMessage methodsFor: 'fields' stamp: ''!
removeFieldNamed: name
	"remove all fields with the specified name"
	fields removeKey: name ifAbsent: []! !

!MailMessage methodsFor: 'fields' stamp: ''!
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: 'multipart' stamp: ''!
parts
	parts ifNil: [self parseParts].
	^ parts! !

!MailMessage methodsFor: 'printing/formatting' stamp: ''!
viewImageInBody
	| stream image |
	stream := self body contentStream.
	image := Form fromBinaryStream: stream.
	(ImageMorph withForm: image) openInWorld! !

!MailMessage methodsFor: 'fields-convenience' stamp: ''!
date: aDate
	self setField: 'date' toString: aDate! !

!MailMessage methodsFor: 'fields-convenience' stamp: ''!
to: aStringOrCollection
	self setField: 'to' toString: aStringOrCollection asEmailHeaderString! !

!MailMessage methodsFor: 'multipart' stamp: ''!
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: 'printing' stamp: ''!
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: 'accessing' stamp: ''!
fields
	"return the internal fields structure.  This is private and subject to change!!"
	^ fields! !

!MailMessage methodsFor: 'multipart' stamp: ''!
addMixedPart: newPart
	self makeMultipart: 'mixed' with: newPart.! !

!MailMessage methodsFor: 'printing/formatting' stamp: ''!
viewBody
	"open a viewer on the body of this message"
	self containsViewableImage
		ifTrue: [^ self viewImageInBody].
	UIManager default  
		longMessage: self bodyTextFormatted
		title: (self name ifNil: ['(a message part)'])! !

!MailMessage methodsFor: 'printing/formatting' stamp: ''!
formattedText
	"Answer a version of my text suitable for display.  This cleans up the header, decodes HTML, and things like that"

	
	^ self cleanedHeader asText, String cr , self bodyTextFormatted! !

!MailMessage methodsFor: 'accessing' stamp: ''!
from

	^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! !

!MailMessage methodsFor: 'initialization' stamp: ''!
body: newBody
	"change the body"
	body := newBody.
	text := nil.! !

!MailMessage methodsFor: 'printing/formatting' stamp: ''!
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;
						nextPutAll: ': ';
						nextPutAll: 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;
						nextPutAll: ': ';
						nextPutAll: fValue;
						cr ] ].
	^ new contents! !

!MailMessage methodsFor: 'multipart' stamp: ''!
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: ''!
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 currentLine |
	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: [ self traceCr: 'Ignoring bad attachment separater'.
			parts := #().
			^ self ].
	separator := '--' , separator trimRight.
	parseStream := self bodyText readStream.
	msgStream := ZnFastLineReader on: parseStream.

	"Throw away everything up to and including the first separator"
	currentLine := ''.
	[ currentLine trimRight = separator or: [ "Match the separator" currentLine trimRight = (separator , '--') ] ]
		whileFalse: [ currentLine := msgStream nextLine ].

	"Skip the separator"
	currentLine := msgStream nextLine.

	"Extract each of the multi-parts as strings"
	messages := OrderedCollection new.
	[ parseStream atEnd ] whileFalse: [ | message |
		message := String streamContents: [ :stream |
			[ currentLine trimRight = separator or: [ "Match the separator" currentLine trimRight = (separator , '--') ] ]
				whileFalse: [
					stream nextPutAll: currentLine.
					currentLine := msgStream nextLine ].
		].
		messages add: msgStream message.
		"Skip the separator"
		currentLine := msgStream nextLine
	].
	parts := messages collect: [ :e | MailMessage from: e ]! !

!MailMessage methodsFor: 'printing/formatting' stamp: ''!
format
	"Replace the text of this message with a formatted version."
	"NOTE: This operation discards extra header fields."

	text := self formattedText.! !

!MailMessage methodsFor: 'accessing' stamp: ''!
time
	| dateField |
	dateField := (self fieldNamed: 'date' ifAbsent: [ ^0 ]) mainValue.
	^ [self timeFrom: dateField] onErrorDo: [Date today asSeconds].! !

!MailMessage methodsFor: 'initialization' stamp: ''!
fromRfc822: 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: 'parsing' stamp: ''!
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: 'testing' stamp: ''!
containsViewableImage
	^self body isJpeg | self body isGif | self body isPng! !

!MailMessage methodsFor: 'sending' stamp: ''!
sendOn: serverString 

	SMTPClient deliver: self usingServer: serverString.! !

!MailMessage methodsFor: 'parsing' stamp: ''!
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: 'printing/formatting' stamp: ''!
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 ].
		str nextPutAll: encodedBodyText contents]! !

!MailMessage methodsFor: 'accessing' stamp: ''!
subject

		^(self fieldNamed: 'subject' ifAbsent: [ ^'' ])  mainValue! !

!MailMessage methodsFor: 'accessing' stamp: ''!
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: 'parsing' stamp: ''!
timeFrom: aString 
	"Parse the date and time (rfc822) and answer the result as the number of seconds 
	since the start of 1980."
	| s t rawDelta delta plusOrMinus |
	s := aString readStream.

	"date part"
	t := ((self readDateFrom: s) ifNil: [ Date today ]) asSeconds.
	[ s atEnd or: [ s peek isAlphaNumeric ] ] whileFalse: [ s next ].

	"time part"
	s atEnd ifFalse: 
		[ "read time part (interpreted as local, regardless of sender's timezone)"
		s peek isDigit ifTrue: [ t := t + (Time readFrom: s) asSeconds ] ].
	s skipSeparators.

	"Check for a numeric time zone offset"
	('+-' includes: s peek) ifTrue: 
		[ plusOrMinus := s next.
		rawDelta := s peek isDigit 
			ifTrue: [ Integer readFrom: s ]
			ifFalse: [ 0 ].
		delta := (rawDelta // 100 * 60 + (rawDelta \\ 100)) * 60.
		t := plusOrMinus = $+ 
			ifTrue: [ t - delta ]
			ifFalse: [ t + delta ] ].

	"We ignore text time zone offsets like EST, GMT, etc..."
	^ t - (Date year: 1980 day: 1) asSeconds

	"MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 -500'"
	"MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 --500'"
	"MailMessage new timeFrom: 'on, 04 apr 2001 14:57:32'"! !

!MailMessage methodsFor: 'accessing' stamp: ''!
bodyText
	"return the text of the body of the message"
	^body content! !

!MailMessage methodsFor: 'printing/formatting' stamp: ''!
excerpt
	"Return a short excerpt of the text of the message"

	^ self bodyText withSeparatorsCompacted truncateWithElipsisTo: 60! !

!MailMessage methodsFor: 'multipart' stamp: ''!
addAlternativePart: newPart
	self makeMultipart: 'alternative' with: newPart.! !

!MailMessage methodsFor: 'multipart' stamp: ''!
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 class methodsFor: 'preferences' stamp: ''!
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: 'instance creation' stamp: ''!
from: aString
	"Initialize a new instance from the given string."

	^ self new from: aString! !

!MailMessage class methodsFor: 'utilities' stamp: ''!
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: 'instance creation' stamp: ''!
empty
	"return a message with no text and no header"

	^self new! !

!MailMessage class methodsFor: 'utilities' stamp: ''!
monthDayTime24StringFrom: aSecondCount
	| aDate aTime |
	"From the date/time represented by aSecondCount, produce a string which indicates the date and time in the compact form
             ddMMMhhmm		where dd is a two-digit day-of-month, MMM is the alpha month abbreviation and hhmm is the time on a 24-hr clock.

          Utilities monthDayTime24StringFrom: Time primSecondsClock
"

	aDate := Date fromSeconds: aSecondCount.
	aTime := Time fromSeconds: aSecondCount \\ 86400.

	^ (aDate dayOfMonth asTwoCharacterString), 
		(aDate monthName copyFrom: 1 to: 3), 
		(aTime hhmm24)! !

!MailMessage class methodsFor: 'instance creation' stamp: ''!
fromRfc822: aString
	"Initialize a new instance from the given string."

	^ self new fromRfc822: aString! !

!MailMessage class methodsFor: 'utilities' stamp: ''!
dateTimeSuffix
	"Answer a string which indicates the date and time, intended for use in building fileout filenames, etc."

	^self monthDayTime24StringFrom: Time primUTCSecondsClock! !

!MailMessage class methodsFor: 'utilities' stamp: ''!
dateStampNow
	"Return the current date and time formatted per RFC5322  e.g.  'Thu, 18 Feb 1999 20:38:51 -0500'"

	^	DateAndTime now asEmailString.! !

!MailMessage class methodsFor: 'instance creation' stamp: ''!
from: senderString to: recipients about: subjectString asFollows: bodyString 

	^ (self fromRfc822: Character lf asString, bodyString)
			from: senderString;
			date: self dateStampNow;
			subject: subjectString;
			to: recipients;
			yourself.! !

!MailMessageTest commentStamp: ''!
SUnit tests for MailMessage!
!MailMessageTest methodsFor: 'tests' stamp: ''!
testMultiPartMixed
	| m txt html  part1 part2 |
	
	txt := 'This is plain text.'.
	html :=  '<html><head></head><body>This is html.</body></html>'.
	
	m := MailMessage empty
			addMixedPart: txt contentType: 'text/plain'; 
			addMixedPart: html contentType: 'text/html';
			yourself.

	self 
		assert: ((m fields at: 'content-type') at: 1) mainValue asLowercase equals: 'multipart/mixed'; 
		assert: m parts size equals: 2.

	part1 := m parts at: 1.
	part2 := m parts at: 2.

	self 
		assert: ((part1 fields at: 'content-type') at: 1) mainValue asLowercase equals: 'text/plain';
		assert: part1 body content equals: txt.
	
	self 
		assert: ((part2 fields at: 'content-type') at: 1) mainValue asLowercase equals: 'text/html';
		assert: part2 body content equals: html! !

!MailMessageTest methodsFor: 'tests' stamp: ''!
testMultiPartAlternative
	| m txt html  part1 part2 |
	
	txt := 'This is plain text.'.
	html :=  '<html><head></head><body>This is html.</body></html>'.
	
	m := MailMessage empty
	 		addAlternativePart: txt contentType: 'text/plain'; 
	 		addAlternativePart: html contentType: 'text/html';
			yourself.

	self 
		assert: ((m fields at: 'content-type') at: 1) mainValue asLowercase equals: 'multipart/alternative'; 
		assert: m parts size equals: 2.

	part1 := m parts at: 1.
	part2 := m parts at: 2.

	self 
		assert: ((part1 fields at: 'content-type') at: 1) mainValue asLowercase equals: 'text/plain';
		assert: part1 body content equals: txt.
	
	self 
		assert: ((part2 fields at: 'content-type') at: 1) mainValue asLowercase equals: 'text/html';
		assert: part2 body content equals: html! !

!MailMessageTest methodsFor: 'tests' stamp: ''!
testAttachment
	"Test if the attachment of a file to a mail works.
		Create a file and attach it to a MailMessage. After that, delete the file.
		Compare both mail texts but remove the CelesteAttachment string before because this is a random string."

	| theMailMessage theResultMailText theFilename |
	theMailMessage := MailMessage empty
		addAlternativePart: 'This is plain text.' contentType: 'text/plain';
		addAlternativePart: '<html><head></head><body>This is html text</body></html>'
			contentType: 'text/html';
		yourself.
	theFilename := 'testfile.txt'.
	(File named: theFilename)
		writeStreamDo: [ :stream | 
			stream
				nextPutAll: 'This is the text of the mail attachment to be generated' ].
	theMailMessage
		addAttachmentFrom: (File named: theFilename) openForWrite
		withName: theFilename.
	theMailMessage setField: 'from' toString: 'test@test.de'.
	theMailMessage regenerateBodyFromParts.
	theResultMailText := theMailMessage text.
	File deleteFile: theFilename.
	self
		assert:
			((theResultMailText findTokens: '--==')
				reject: [ :each | 'CelesteAttachment*' match: each ])
		equals:
			(('Mime-version: 1.0
From: test@test.de
Content-type: multipart/alternative;boundary="==CelesteAttachment57344=="



--==CelesteAttachment57344==
Content-type: text/plain

This is plain text.
--==CelesteAttachment57344==
Content-type: text/html

<html><head></head><body>This is html text</body></html>
--==CelesteAttachment57344==
Content-transfer-encoding: base64
Content-disposition: attachment;filename="testfile.txt"
Content-type: application/octet-stream

VGhpcyBpcyB0aGUgdGV4dCBvZiB0aGUgbWFpbCBhdHRhY2htZW50IHRvIGJlIGdlbmVyYXRl
ZA==
--==CelesteAttachment57344==--
' findTokens: '--==')
				reject: [ :each | 'CelesteAttachment*' match: each ])! !

!MailMessageTest methodsFor: 'tests' stamp: ''!
testRecipientList

	| message |
	message := MailMessage fromRfc822: 'To: pharo-project@lists.gforge.inria.fr, pharo-users@lists.gforge.inria.fr'.
	
	self 
		assert: message recipientList size equals: 2;
		assert: message recipientList first equals: 'pharo-project@lists.gforge.inria.fr';	
		assert: message recipientList second equals: 'pharo-users@lists.gforge.inria.fr'! !

!MailMessageTest methodsFor: 'tests' stamp: ''!
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" <to1@mail.com>
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 fromRfc822: text.

	self 
		assert: message text equals: text;
		assert: message subject equals: 'RE: Windows 2000 on your laptop';
		assert: message from equals: 'mdr@scn.rg (Me Ru)';
		assert: message date equals: '2/20/01';
		assert: message time equals: 667133573;
		assert: message to equals: '"Greg Y" <to1@mail.com>, to2@no.scn.org, to2also@op.org';
		assert: message cc equals: 'cc1@scn.org, cc1also@test.org, cc2@scn.org'! !

!MailMessageTest methodsFor: 'tests' stamp: ''!
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
To\: pharo-project@lists.gforge.inria.fr, pharo-users@lists.gforge.inria.fr
Subject\: Great Progress

Pharo is getting so cool!!
')! !

!MalBfsNode methodsFor: 'initialization' stamp: ''!
initialize 

	nextEdges := OrderedCollection new.! !

!MalBfsNode methodsFor: 'accessing' stamp: ''!
firstDepth: anObject
	firstDepth := anObject! !

!MalBfsNode methodsFor: 'testing' stamp: ''!
visited

	^ firstDepth notNil! !

!MalBfsNode methodsFor: 'edges' stamp: ''!
to: aNode edge: anEdge

	self nextEdges add: anEdge! !

!MalBfsNode methodsFor: 'accessing' stamp: ''!
nextEdges

	^ nextEdges! !

!MalBfsNode methodsFor: 'accessing' stamp: ''!
firstDepth
	^ firstDepth! !

!MalBfsNode methodsFor: 'setting' stamp: ''!
notVisited

	firstDepth := nil! !

!MalBfsNode class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MalBfsNode class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MalBfsNode class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MalBfsNode class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MalBfsNode class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MalBfsNode class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MalBfsNode class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MalBfsNode class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MalBfsNode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalBfsNode class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MalBfsNode class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MalBfsNode class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MalBfsNode class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MalBfsNode class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MalBfsNode class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MalBfsNode class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MalBfsNode class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MalBfsNode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalBfsNode class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MalBfsNode class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MalBfsNode class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MalBfsNode class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MalBfsNode class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MalBfsNode class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MalBfsNode class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MalBfsNode class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MalBfsNode class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MalBfsNode class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MalBfsNode class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MalBreadthFirstSearchPath commentStamp: ''!
Breadth-first search (BFS) is an algorithm for traversing or searching tree or graph data structures. It starts at the tree root (or some arbitrary node of a graph, sometimes referred to as a `search key') and explores the neighbor nodes first, before moving to the next level neighbours. (source: Wikipedia)!
!MalBreadthFirstSearchPath methodsFor: 'running' stamp: ''!
runFrom: startModel to: endModel
	self
		start: (self findNode: startModel);
		end: (self findNode: endModel).
	^ self run! !

!MalBreadthFirstSearchPath methodsFor: 'configuration' stamp: ''!
edgeClass

	^ MalGraphEdge! !

!MalBreadthFirstSearchPath methodsFor: 'configuration' stamp: ''!
nodeClass

	^ MalBfsNode! !

!MalBreadthFirstSearchPath methodsFor: 'private' stamp: ''!
end: aDijsktraNode
	end := aDijsktraNode! !

!MalBreadthFirstSearchPath methodsFor: 'running' stamp: ''!
run
	
	| path |
	fifo := OrderedCollection withAll: start nextEdges.
	start firstDepth: 0.
	path := self run: 1.
	start notVisited .
	^ path! !

!MalBreadthFirstSearchPath methodsFor: 'private' stamp: ''!
start
	^ start! !

!MalBreadthFirstSearchPath methodsFor: 'private' stamp: ''!
end
	^ end! !

!MalBreadthFirstSearchPath methodsFor: 'private' stamp: ''!
start: aDijsktraNode
	start := aDijsktraNode.! !

!MalBreadthFirstSearchPath methodsFor: 'running' stamp: ''!
run: depth
	| edge path next |
	edge := fifo removeFirst.
	next := edge to.
	^ next = end
		ifTrue: [ OrderedCollection with: edge from model with: end model ]
		ifFalse:
			[ next visited
				ifFalse:
					[ fifo addAll: next nextEdges.
					next firstDepth: depth ].	"only add edges if node not already visited (avoid cycles on the path)"
			path := self run: depth + 1.	"continue recursion"
			(depth = next firstDepth) "out of stack"
				ifTrue: [
					(path first = next model) "backtrack along the path"
						ifTrue: [ path addFirst: edge from model ].	
					"reset visited for next run"
					next notVisited ].
			path ]	"stop recursion, start backtrack"! !

!MalBreadthFirstSearchPathTest methodsFor: 'tests' stamp: ''!
testAseGraph
	MalGraphFixture aseCircuitGraph: bfsp.
	self assert: (#($a $b $c) hasEqualElements: (bfsp runFrom: $a to: $c)).
	self assert: (#($d $b $c) hasEqualElements: (bfsp runFrom: $d to: $c)).
	self assert: (#($e $a) hasEqualElements: (bfsp runFrom: $e to: $a)).
	self assert: (#($a $b $d $e) hasEqualElements: (bfsp runFrom: $a to: $e)).
	self assert: (#($d $b $c $f) hasEqualElements: (bfsp runFrom: $d to: $f)).
	self should: [ bfsp runFrom: $f to: $a ] raise: Error! !

!MalBreadthFirstSearchPathTest methodsFor: 'tests' stamp: ''!
testSimpleGraph
	MalGraphFixture simpleGraph: bfsp.
	self assert: (#($a $b $c) hasEqualElements: (bfsp runFrom: $a to: $c)).
	self assert: (#($d $c) hasEqualElements: (bfsp runFrom: $d to: $c))! !

!MalBreadthFirstSearchPathTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	bfsp := MalBreadthFirstSearchPath new! !

!MalCircuitSpanningEdges methodsFor: 'configuration' stamp: ''!
edgeClass

	^ MalCseEdge! !

!MalCircuitSpanningEdges methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	circuits := OrderedCollection new. "use that instead of Set"
	dijkstra := MalDijkstra new.! !

!MalCircuitSpanningEdges methodsFor: 'configuration' stamp: ''!
nodeClass

	^ MalDijkstraNode! !

!MalCircuitSpanningEdges methodsFor: 'private' stamp: ''!
doUnvisitedEdges: aBlock

	self edges do: [:e|
		e cseVisited ifFalse: [
			aBlock value: e
		]
	]! !

!MalCircuitSpanningEdges methodsFor: 'running' stamp: ''!
findDirectCircuits

	"detect direct circuits"
	| returnNode returnEdge |
	self doUnvisitedEdges: [:e|
		[returnNode := e to.
		 returnEdge := returnNode nextEdges
				detect: [:re| re to == e from].
		 "found a direct circuit"
		 e cseVisited: true.
		 returnEdge cseVisited: true.
		 self addCircuit: (OrderedCollection with: e from model with: e to model)
		] on: Error do: [ "did not find a return edge, so there is no direct circuit"]				
	]! !

!MalCircuitSpanningEdges methodsFor: 'running' stamp: ''!
findIndirectCircuits
	
	"for each unvisited edge, pop and detect circuit with Dijsktra, backtrack"
	dijkstra privateNodes: self nodes; privateEdges: self edges.
	self doUnvisitedEdges: [:e|
		dijkstra reset.
		dijkstra start: e to; end: e from; run. "find circuit leading back from e target to e source"
		(dijkstra pathWeight ~= Float infinity) ifTrue: [
			self addCircuit: (dijkstra backtrack: dijkstra end edgeDo: [:x| x cseVisited: true]).
			"we have the path from e target to e source, and all edges 
			 marked as visited between.
			 We have to mark the seeding edge"
			e cseVisited: true ]
		]! !

!MalCircuitSpanningEdges methodsFor: 'running' stamp: ''!
run
	self flag: #pharoTodo.	"for stability, we should sort edges by their label"
	self findDirectCircuits.
	self findIndirectCircuits! !

!MalCseEdge methodsFor: 'accessing' stamp: ''!
cseVisited: aBoolean
	cseVisited := aBoolean! !

!MalCseEdge methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	self cseVisited: false.! !

!MalCseEdge methodsFor: 'accessing' stamp: ''!
cseVisited
	^ cseVisited! !

!MalCyclesCoverage methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self useNodeDecomposition! !

!MalCyclesCoverage methodsFor: 'running' stamp: ''!
directCircuit: aCollection

	^ self normalize: (OrderedCollection 
		with: aCollection first model 
		with: aCollection second model)! !

!MalCyclesCoverage methodsFor: 'running' stamp: ''!
useCircuitSpan

	sccExtractorClass := MalCircuitSpanningEdges! !

!MalCyclesCoverage methodsFor: 'accessing' stamp: ''!
circuits
	^ circuits! !

!MalCyclesCoverage methodsFor: 'running' stamp: ''!
useNodeDecomposition

	sccExtractorClass := MalSccNodeDecomposition! !

!MalCyclesCoverage methodsFor: 'accessing' stamp: ''!
retrieveCircuitsFromSccExtractor: sccExtractor

	sccExtractor circuits do: [:c |
		circuits add: (c collect: [:n| n model]) ]! !

!MalCyclesCoverage methodsFor: 'running' stamp: ''!
run

	super run.
	circuits := OrderedCollection new.
	self stronglyConnectedComponents do: [:scc|
		(scc size > 2) ifTrue: [|sccExtractor|
			sccExtractor := sccExtractorClass new.
			sccExtractor nodes: scc.
			"graph injection remove outgoing edges from SCC"
			sccExtractor edges: scc from: #yourself toAll: #nextNodes.
			sccExtractor run.
			self retrieveCircuitsFromSccExtractor: sccExtractor ].
		(scc size = 2) ifTrue: [
			circuits add: (self directCircuit: scc) ]. "direct circuit"
		]! !

!MalCyclesCoverage methodsFor: 'running' stamp: ''!
useEdgeDecomposition

	sccExtractorClass := MalSccEdgeDecomposition! !

!MalCyclesCoverage methodsFor: 'running' stamp: ''!
normalize: aCollectionOfNodes

	| firstNode perm |
	firstNode := aCollectionOfNodes detectMin: [:n| n printString ].
	perm := aCollectionOfNodes copy.
	[ firstNode = perm first ] whileFalse: [
		perm addLast: perm removeFirst ].
	^ perm! !

!MalCyclesCoverage class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MalCyclesCoverage class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MalCyclesCoverage class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MalCyclesCoverage class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MalCyclesCoverage class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MalCyclesCoverage class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MalCyclesCoverage class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MalCyclesCoverage class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MalCyclesCoverage class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalCyclesCoverage class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MalCyclesCoverage class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MalCyclesCoverage class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MalCyclesCoverage class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MalCyclesCoverage class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MalCyclesCoverage class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MalCyclesCoverage class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MalCyclesCoverage class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MalCyclesCoverage class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalCyclesCoverage class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MalCyclesCoverage class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MalCyclesCoverage class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MalCyclesCoverage class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MalCyclesCoverage class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MalCyclesCoverage class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MalCyclesCoverage class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MalCyclesCoverage class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MalCyclesCoverage class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MalCyclesCoverage class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MalCyclesCoverage class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MalCyclesCoverageTest methodsFor: 'tests - cse' stamp: ''!
testAseSccWithCse
	| cse |
	cse := MalCircuitSpanningEdges new.
	MalGraphFixture aseSccGraph: cse.
	cse run.
	self assert: 4 equals: cse circuits size.
	self assert: (#($a $b) hasEqualElements: cse circuits first).
	self assert: (#($b $d) hasEqualElements: cse circuits second).
	self assert: (#($c $d $b) hasEqualElements: cse circuits third).
	self assert: (#($e $a $b $d) hasEqualElements: cse circuits fourth)! !

!MalCyclesCoverageTest methodsFor: 'tests - snd' stamp: ''!
testAseCircuitWithSnd
	MalGraphFixture aseCircuitGraph: cc.
	cc run.
	self assert: 5 equals: cc circuits size.
	#(($g $h) ($b $d) ($a $b) ($b $c $d) ($a $b $d $e)) do: [:c|
			self assert: (cc circuits anySatisfy: [:ci| c hasEqualElements: ci ])].! !

!MalCyclesCoverageTest methodsFor: 'testing' stamp: ''!
testNormalize
	self assert: (#($a $b) hasEqualElements: (cc normalize: #($a $b) asOrderedCollection)).
	self assert: (#($a $b) hasEqualElements: (cc normalize: #($b $a) asOrderedCollection)).
	self assert: (#($b $c $d) hasEqualElements: (cc normalize: #($c $d $b) asOrderedCollection)).
	self assert: (#($a $e $b $f $d) hasEqualElements: (cc normalize: #($e $b $f $d $a) asOrderedCollection))! !

!MalCyclesCoverageTest methodsFor: 'tests - sed' stamp: ''!
testAseSccWithSed
	| sed circuits |
	sed := MalSccEdgeDecomposition new.
	MalGraphFixture aseSccGraph: sed.
	sed run.
	self assert: 4 equals: sed circuits size.
	circuits := sed circuits asOrderedCollection.
	#(#($b $d) #($a $b) #($b $c $d) #($a $b $d $e))
		do: [ :c | self assert: (circuits anySatisfy: [ :ci | c hasEqualElements: ci ]) ]! !

!MalCyclesCoverageTest methodsFor: 'tests - snd' stamp: ''!
testAseSccWithSnd
	| sed circuits |
	sed := MalSccNodeDecomposition new.
	MalGraphFixture aseSccGraph: sed.
	sed run.
	self assert: 4 equals: sed circuits size.
	circuits := sed circuits asOrderedCollection.
	#(#($b $d) #($a $b) #($b $c $d) #($a $b $d $e))
		do: [ :c | self assert: (circuits anySatisfy: [ :ci | c hasEqualElements: ci ]) ]! !

!MalCyclesCoverageTest methodsFor: 'tests - cse' stamp: ''!
testAseCircuitWithCse
	cc useCircuitSpan.
	MalGraphFixture aseCircuitGraph: cc.
	cc run.
	self assert: 5 equals: cc circuits size.
	#(#($g $h) #($b $d) #($a $b) #($b $c $d) #($a $b $d $e))
		do: [ :c | self assert: (cc circuits anySatisfy: [ :ci | c hasEqualElements: (cc normalize: ci) ]) ]! !

!MalCyclesCoverageTest methodsFor: 'tests - sed' stamp: ''!
testAseCircuitWithSed
	cc useEdgeDecomposition.
	MalGraphFixture aseCircuitGraph: cc.
	cc run.
	self assert: 5 equals: cc circuits size.
	#(#($g $h) #($b $d) #($a $b) #($b $c $d) #($a $b $d $e))
		do: [ :c | self assert: (cc circuits anySatisfy: [ :ci | c hasEqualElements: ci ]) ]! !

!MalCyclesCoverageTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	cc := MalCyclesCoverage new! !

!MalDijkstra commentStamp: ''!
Dijkstra's algorithm is an algorithm for finding the shortest paths between nodes in a graph, which may represent, for example, road networks. It was conceived by computer scientist Edsger W. Dijkstra in 1956 and published in 1959. The algorithm exists in many variants; Dijkstra's original variant found the shortest path between two nodes, but a more common variant fixes a single node as the "source" node and finds shortest paths from the source to all other nodes in the graph, producing a shortest path tree. (source: Wikipedia)!
!MalDijkstra methodsFor: 'running' stamp: ''!
runFrom: startModel to: endModel

	self start: (self findNode: startModel); end: (self findNode: endModel).
	self run.
	^ self pathWeight! !

!MalDijkstra methodsFor: 'configuration' stamp: ''!
edgeClass

	^ MalDijkstraEdge! !

!MalDijkstra methodsFor: 'configuration' stamp: ''!
nodeClass

	^ MalDijkstraNode! !

!MalDijkstra methodsFor: 'running' stamp: ''!
pathWeight
	^ self end pathWeight! !

!MalDijkstra methodsFor: 'backtracking' stamp: ''!
backtrack: b

	| p |
	b pathWeight = Float infinity
		ifTrue: [ ^ #() ]. "no solution"
	^ b = self start
		ifTrue: [ OrderedCollection with: b model ]
		ifFalse: [
			p := b previousNodes detectMin: [:n | n pathWeight].
			(self backtrack: p) add: b model; yourself ].! !

!MalDijkstra methodsFor: 'running' stamp: ''!
traverse: node

	self flag: #pharoTodo. "optimize traversal of nodes"
	node nextEdges do: [:edge |
		edge isVisited ifFalse: [
			edge to pathWeight: (edge to pathWeight min: (node pathWeight + edge weight)).
			edge visited: true.
			self traverse: edge to ]]! !

!MalDijkstra methodsFor: 'backtracking' stamp: ''!
backtrack 

	^ self backtrack: self end! !

!MalDijkstra methodsFor: 'private' stamp: ''!
end: aDijsktraNode
	end := aDijsktraNode! !

!MalDijkstra methodsFor: 'running' stamp: ''!
run
	
	self traverse: self start! !

!MalDijkstra methodsFor: 'private' stamp: ''!
end
	^ end! !

!MalDijkstra methodsFor: 'initialization' stamp: ''!
reset
	self nodes do: [ :n | n pathWeight: Float infinity ].
	self edges do: [ :e | e visited: false ]! !

!MalDijkstra methodsFor: 'private' stamp: ''!
start
	^ start! !

!MalDijkstra methodsFor: 'private' stamp: ''!
start: aDijsktraNode
	start := aDijsktraNode.
	aDijsktraNode pathWeight: 0! !

!MalDijkstra methodsFor: 'backtracking' stamp: ''!
backtrack: b edgeDo: aBlock
	"special purpose backtracking for CSE: backtrack through edge and do something on each edge 
	while traversing.
	 do not check if there is a solution (pathWeight ~= Float infinity)"

	| pe p |
	^ b = self start
		ifTrue: [ OrderedCollection with: b model ]
		ifFalse: [
			pe := b previousEdges detectMin: [:e | e from pathWeight].
			p := pe from.
			aBlock value: pe.
			(self backtrack: p edgeDo: aBlock) add: b model; yourself ].! !

!MalDijkstraEdge methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	weight := 1.
	visited := false! !

!MalDijkstraEdge methodsFor: 'accessing' stamp: ''!
visited: aBoolean

	visited := aBoolean! !

!MalDijkstraEdge methodsFor: 'accessing' stamp: ''!
isVisited

	^ visited! !

!MalDijkstraNode methodsFor: 'accessing' stamp: ''!
previousEdges

	^ previousEdges! !

!MalDijkstraNode methodsFor: 'initialization' stamp: ''!
initialize

	previousNodes := OrderedCollection new.
	previousEdges := OrderedCollection new.
	nextEdges := OrderedCollection new.
	pathWeight := Float infinity "initialization for Dijsktra"! !

!MalDijkstraNode methodsFor: 'accessing' stamp: ''!
previousNodes

	^ previousNodes! !

!MalDijkstraNode methodsFor: 'accessing' stamp: ''!
pathWeight
	^ pathWeight! !

!MalDijkstraNode methodsFor: 'edges' stamp: ''!
to: aNode edge: anEdge

	self nextEdges add: anEdge! !

!MalDijkstraNode methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll: ' - ';
		nextPutAll: pathWeight asString! !

!MalDijkstraNode methodsFor: 'accessing' stamp: ''!
from: aNode edge: anEdge

	self previousNodes add: aNode.
	self previousEdges add: anEdge! !

!MalDijkstraNode methodsFor: 'accessing' stamp: ''!
nextEdges

	^ nextEdges! !

!MalDijkstraNode methodsFor: 'accessing' stamp: ''!
pathWeight: anObject
	pathWeight := anObject! !

!MalDijkstraNode class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MalDijkstraNode class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MalDijkstraNode class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MalDijkstraNode class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MalDijkstraNode class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MalDijkstraNode class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MalDijkstraNode class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MalDijkstraNode class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MalDijkstraNode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalDijkstraNode class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MalDijkstraNode class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MalDijkstraNode class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MalDijkstraNode class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MalDijkstraNode class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MalDijkstraNode class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MalDijkstraNode class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MalDijkstraNode class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MalDijkstraNode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalDijkstraNode class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MalDijkstraNode class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MalDijkstraNode class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MalDijkstraNode class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MalDijkstraNode class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MalDijkstraNode class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MalDijkstraNode class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MalDijkstraNode class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MalDijkstraNode class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MalDijkstraNode class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MalDijkstraNode class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MalDijkstraTest methodsFor: 'tests' stamp: ''!
testAseBasicCircuit
	MalGraphFixture aseCircuitGraph: dijsktra.

	self assert: 1 equals: (dijsktra runFrom: $a to: $b).
	dijsktra reset.
	self assert: 3 equals: (dijsktra runFrom: $a to: $e).
	dijsktra reset.
	self assert: 2 equals: (dijsktra runFrom: $c to: $b).
	dijsktra reset.
	self assert: 5 equals: (dijsktra runFrom: $a to: $h).
	dijsktra reset.
	self assert: Float infinity equals: (dijsktra runFrom: $h to: $a)! !

!MalDijkstraTest methodsFor: 'tests' stamp: ''!
testAseBasicCircuitBacktrack
	MalGraphFixture aseCircuitGraph: dijsktra.

	self assert: (#($a $b) hasEqualElements: (dijsktra runFrom: $a to: $b; backtrack)).
	dijsktra reset.
	self assert: (#($a $b $d $e) hasEqualElements: (dijsktra runFrom: $a to: $e; backtrack)).
	dijsktra reset.
	self assert: (#($c $d $b) hasEqualElements: (dijsktra runFrom: $c to: $b; backtrack)).
	dijsktra reset.
	self assert: (#($a $b $c $f $g $h) hasEqualElements: (dijsktra runFrom: $a to: $h; backtrack)).
	dijsktra reset.
	self assert: (#() hasEqualElements: (dijsktra runFrom: $h to: $a; backtrack))! !

!MalDijkstraTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	dijsktra := MalDijkstra new! !

!MalDisjointSetNode methodsFor: 'accessing' stamp: ''!
find
	^ self = parent ifTrue: [ self ] ifFalse: [ parent find ]! !

!MalDisjointSetNode methodsFor: 'private - accessing' stamp: ''!
parent: anObject
	parent := anObject! !

!MalDisjointSetNode methodsFor: 'accessing' stamp: ''!
makeSet
	parent := self! !

!MalDisjointSetNode methodsFor: 'private - accessing' stamp: ''!
parent
	^ parent! !

!MalDisjointSetNode methodsFor: 'accessing' stamp: ''!
union: aDSNode

	aDSNode find parent: self find! !

!MalDisjointSetNode methodsFor: 'accessing' stamp: ''!
label

	^ 'DSN '! !

!MalDisjointSets methodsFor: 'configuration' stamp: ''!
nodeClass

	^ MalDisjointSetsNextNode! !

!MalDisjointSets methodsFor: 'running' stamp: ''!
run

	"partition nodes by connectivity"
	self nodes do: [:n|
		n nextNodes do: [:next | 
			n union: next ]].
	components := Dictionary new.
	self nodes inject: components into: [:d :n |
		(d at: n find ifAbsentPut: [OrderedCollection new]) add: n. d ]! !

!MalDisjointSets methodsFor: 'accessing' stamp: ''!
components

	^ (components keys collect: [:parent| 
		(components at: parent) collect: [:n| n model] ]) asOrderedCollection! !

!MalDisjointSetsNextNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self makeSet.
	nextNodes := OrderedCollection new! !

!MalDisjointSetsNextNode methodsFor: 'accessing' stamp: ''!
to: targetNode
	self nextNodes add: targetNode! !

!MalDisjointSetsNextNode methodsFor: 'accessing' stamp: ''!
nextNodes

	^ nextNodes! !

!MalDisjointSetsTest methodsFor: 'tests' stamp: ''!
test3Components
	| components twoNodes threeNodes singleNodeC |
	ds nodes: (1 to: 6).
	ds edges: {(1 -> 2) . (2 -> 3) . (4 -> 5)} from: #key to: #value.
	ds run.
	components := ds components.

	self assert: 3 equals: components size.
	twoNodes := components detect: [ :c | c size = 2 ].
	threeNodes := components detect: [ :c | c size = 3 ].
	singleNodeC := components detect: [ :c | c size = 1 ].
	self assert: ((1 to: 3) hasEqualElements: threeNodes).
	self assert: ((4 to: 5) hasEqualElements: twoNodes).
	self assert: 6 equals: singleNodeC anyOne! !

!MalDisjointSetsTest methodsFor: 'tests' stamp: ''!
test2Components
	| components twoNodes threeNodes |
	ds nodes: (1 to: 5).
	ds edges: {(1 -> 2) . (2 -> 3) . (4 -> 5)} from: #key to: #value.
	ds run.
	components := ds components.

	self assert: 2 equals: components size.
	twoNodes := components detect: [ :c | c size = 2 ].
	threeNodes := components detect: [ :c | c size = 3 ].
	self assert: ((1 to: 3) hasEqualElements: threeNodes).
	self assert: ((4 to: 5) hasEqualElements: twoNodes)! !

!MalDisjointSetsTest methodsFor: 'tests' stamp: ''!
test1Component
	| components |
	ds nodes: (1 to: 5).
	ds edges: {(1 -> 2) . (2 -> 3) . (4 -> 5) . (1 -> 5)} from: #key to: #value.
	ds run.
	components := ds components.

	self assert: 1 equals: components size.
	self assert: ((1 to: 5) hasEqualElements: components first)! !

!MalDisjointSetsTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	ds := MalDisjointSets new! !

!MalDominance methodsFor: 'configuration' stamp: ''!
nodeClass

	^ MalDominanceNode! !

!MalDominance methodsFor: 'running' stamp: ''!
run

	| source |
	self nodes do: [ :n | n makeSet ].
	self nodes do: [ :n | n hasUniqueSource ifTrue: [ 
								source := n firstSource.
								source flagUnique.
								source union: n ] ]! !

!MalDominanceNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	previousNodes := OrderedCollection new.
	uniqueSource := false! !

!MalDominanceNode methodsFor: 'accessing' stamp: ''!
from: sourceNode

	previousNodes add: sourceNode! !

!MalDominanceNode methodsFor: 'accessing' stamp: ''!
previousNodes
	^ previousNodes! !

!MalDominanceNode methodsFor: 'accessing' stamp: ''!
isDominant
	"A node is dominant if it has been flagged as the unique Source by one of its target
	 AND it is its own parent in the partition"
	^ uniqueSource and: [self find = self]! !

!MalDominanceNode methodsFor: 'accessing' stamp: ''!
flagUnique

	uniqueSource := true! !

!MalDominanceNode methodsFor: 'accessing' stamp: ''!
dominantNode

	^ self find! !

!MalDominanceNode methodsFor: 'accessing' stamp: ''!
firstSource

	^ previousNodes first! !

!MalDominanceNode methodsFor: 'accessing' stamp: ''!
hasUniqueSource
	^ self previousNodes size = 1! !

!MalDominanceNode methodsFor: 'accessing' stamp: ''!
isDominated

	^ self isDominant not and: [self find isDominant]! !

!MalDominanceNode methodsFor: 'accessing' stamp: ''!
label

	^ 'Dm '! !

!MalDominanceTest methodsFor: 'tests' stamp: ''!
testCycle
	| a b c |
	MalGraphFixture cycleGraph: dom.
	dom run.
	dom nodes
		do: [ :n | 
			n model = $c
				ifTrue: [
					self assert: n isDominant.
					self deny: n isDominated ]
				ifFalse: [ self deny: n isDominant.
					n model = $d
						ifTrue: [ self deny: n isDominated ]
						ifFalse: [ self assert: n isDominated ] ] ].
	a := dom findNode: $a.
	b := dom findNode: $b.
	c := dom findNode: $c.
	self assert: a find equals: c.
	self assert: b find equals: c! !

!MalDominanceTest methodsFor: 'tests' stamp: ''!
testSimple
	| a b c d |
	MalGraphFixture simpleGraph: dom.
	dom run.
	dom nodes
		do: [ :n | 
			n model = $a
				ifTrue: [ 
					self assert: n isDominant.
					self deny: n isDominated ]
				ifFalse: [ self deny: n isDominant ] ].
	a := dom findNode: $a.
	b := dom findNode: $b.
	c := dom findNode: $c.
	d := dom findNode: $d.
	self assert: b find equals: a.
	self deny: c isDominated.
	self deny: d isDominated! !

!MalDominanceTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	dom := MalDominance new! !

!MalGraphAlgorithm commentStamp: ''!
I'm the common superclass for all graphs related algorithms.
I store edges and nodes and provides convenience methods to add, access and find nodes or edges.

Once configured, send the run message to execute the algorithm.!
!MalGraphAlgorithm methodsFor: 'private' stamp: ''!
sortNodes
	self canUseSortedNodes ifFalse: [ ^self ].
	self nodes sort: nodeSortBlock.! !

!MalGraphAlgorithm methodsFor: 'building - graph' stamp: ''!
addNodeFor: aModel
	^ self 
		findNode: aModel
		ifAbsent: [ nodes add: (self nodeClass with: aModel) ]! !

!MalGraphAlgorithm methodsFor: 'building - graph' stamp: ''!
addNodesFrom: model childrenBlock: childrenBlock
	"recursively add nodes from the model"
	| parent |
	model ifNil: [ ^ self ].

	self
		findNode: model
		ifFound: [ ^ self "Prevent cycles. Do not add a node already added." ].

	parent := self addNodeFor: model.
	(childrenBlock value: model)
		do: [ :child | 
				self addNodesFrom: child childrenBlock: childrenBlock.
				self addEdge: { parent model . child } from: #first to: #second ]! !

!MalGraphAlgorithm methodsFor: 'adding' stamp: ''!
nodesFromSet: aSet
	"Ensure that the collection do not contains any duplicated item"

	self assert: aSet class == Set.
	nodes addAll: (aSet collect: [ :aModel | self nodeClass with: aModel ])! !

!MalGraphAlgorithm methodsFor: 'private' stamp: ''!
findBinaryBlock: aModel
	"New implementation of the algos to have better performances to find nodes"
	^ [ :aNode | 
	aNode model = aModel
		ifTrue: [ 0 ]
		ifFalse: [ aModel hash < aNode model hash
				ifTrue: [ -1 ]
				ifFalse: [ 1 ] ] ]! !

!MalGraphAlgorithm methodsFor: 'accessing' stamp: ''!
findNode: aModel ifAbsent: aBlock
	self canUseSortedNodes
		ifFalse: [ ^ self nodes detect: [ :node | node model = aModel ] ifNone: aBlock ].
^ self nodes
		findBinary: (self findBinaryBlock: aModel) ifNone: aBlock! !

!MalGraphAlgorithm methodsFor: 'running' stamp: ''!
run

	self subclassResponsibility! !

!MalGraphAlgorithm methodsFor: 'testing' stamp: ''!
canUseSortedNodes
	"New implementation of the algos to have better performances to find nodes"

	"If nodes are sorted following this block, the find method will be a lot faster. The block should be set on the run method and the nodes sorted at this moment"

	^ nodeSortBlock isNotNil! !

!MalGraphAlgorithm methodsFor: 'accessing' stamp: ''!
edges
	^ edges! !

!MalGraphAlgorithm methodsFor: 'private' stamp: ''!
privateEdges: aCollection

	edges := aCollection! !

!MalGraphAlgorithm methodsFor: 'configuration' stamp: ''!
edgeClass
	^ nil! !

!MalGraphAlgorithm methodsFor: 'building - graph' stamp: ''!
edges: aCollection from: source toAll: targets
	aCollection
		do: [ :eModel | 
			(targets value: eModel)
				do: [ :target | 
					self
						addEdge:
							{(source value: eModel).
							target}
						from: #first
						to: #second ] ]! !

!MalGraphAlgorithm methodsFor: 'accessing' stamp: ''!
graph
	^ {self nodes . self edges}! !

!MalGraphAlgorithm methodsFor: 'initialization' stamp: ''!
initialize
	nodes := OrderedCollection new.
	edges := OrderedCollection new.! !

!MalGraphAlgorithm methodsFor: 'accessing' stamp: ''!
nodes
	^ nodes! !

!MalGraphAlgorithm methodsFor: 'configuration' stamp: ''!
nodeClass
	^ MalGraphNode! !

!MalGraphAlgorithm methodsFor: 'accessing' stamp: ''!
nodeSortBlock: aBlockClosure 
	nodeSortBlock := aBlockClosure! !

!MalGraphAlgorithm methodsFor: 'private' stamp: ''!
addEdge: eModel from: source to: target
	| edge sourceNode targetNode |
	sourceNode := self findNode: (source value: eModel) ifAbsent: [ ^ nil ].
	targetNode := self findNode: (target value: eModel) ifAbsent: [ ^ nil ].
	^ self edgeClass
		ifNil: [ sourceNode to: targetNode.
			targetNode from: sourceNode.
			nil ]
		ifNotNil: [ edge := self edgeClass with: eModel.
			sourceNode to: targetNode edge: edge.
			targetNode from: sourceNode edge: edge.
			edge from: sourceNode.
			edge to: targetNode.
			self edges add: edge.
			edge ]! !

!MalGraphAlgorithm methodsFor: 'building - graph' stamp: ''!
edges: aCollection from: source to: target
	aCollection 
		do: [ :eModel |	self addEdge: eModel from: source to: target ]! !

!MalGraphAlgorithm methodsFor: 'building - graph' stamp: ''!
nodes: aNodeList
	aNodeList 
		do: [ :model |	self addNodeFor: model ]! !

!MalGraphAlgorithm methodsFor: 'building - graph' stamp: ''!
edges: aCollection from: source to: target weight: weightFunction
	| edge |
	aCollection 
		do: [ :eModel |
			edge := self addEdge: eModel from: source to: target.
			edge ifNotNil: [edge weight: (weightFunction value: eModel)] ]! !

!MalGraphAlgorithm methodsFor: 'private' stamp: ''!
privateNodes: aCollection

	nodes := aCollection! !

!MalGraphAlgorithm methodsFor: 'accessing' stamp: ''!
findNode: aModel
	self canUseSortedNodes
		ifFalse: [ ^ self nodes detect: [ :aNode | aNode model = aModel ] ].
	^ self nodes findBinary: (self findBinaryBlock: aModel)! !

!MalGraphAlgorithm methodsFor: 'accessing' stamp: ''!
findNode: aModel ifFound: aBlock
	self canUseSortedNodes
		ifFalse: [ ^ self nodes detect: [ :node | node model = aModel ] ifFound: aBlock ].
	"New implementation of the algos to have better performances to find nodes"
	self notYetImplemented! !

!MalGraphAlgorithm methodsFor: 'accessing' stamp: ''!
findEdge: aModel
	^ self edges detect: [:edge | edge model = aModel]! !

!MalGraphAlgorithm methodsFor: 'private' stamp: ''!
ensureNodesAreSorted
	"New implementation of the algos to have better performances to find nodes"
	"If one change is made in the node list, one should call again sortNodes"

	nodeSortBlock ifNotNil: [ ^ self ].
	self nodeSortBlock: [ :a :b | a model hash <= b model hash ].
	self sortNodes! !

!MalGraphAlgorithmTest commentStamp: ''!
A MalGraphAlgorithmTest is a test class for testing the behavior of MalGraphAlgorithm!
!MalGraphAlgorithmTest methodsFor: 'tests' stamp: ''!
testAddNodesFromChildrenBlock
	| builder |
	builder := MalGraphReducer new.
	builder addNodesFrom: String childrenBlock: [ :parent | parent subclasses ].

	self assert: builder nodes size equals: 6.
	self assertCollection: (builder nodes collect: [:each | each model]) hasSameElements: (String allSubclasses copyWith: String).
	self assertCollection: ((builder findNode: Symbol) nextNodes collect: [:each | each model]) hasSameElements: {ByteSymbol . WideSymbol}.
	self assertCollection: ((builder findNode: Symbol) previousNodes collect: [:each | each model]) hasSameElements: {String}.
	self assert: (builder findNode: ByteSymbol) nextNodes isEmpty! !

!MalGraphEdge commentStamp: ''!
I represent an edge in a graph.  I'm part of the edges of a MalGraphAlgorithm and I link two MalNode together.

Public API and Key Messages
- from
- to 
- model 
 
Instance Variables
	from: <MalNode>
	to: <MalNode>
	model: <Object>!
!MalGraphEdge methodsFor: 'accessing' stamp: ''!
to
	^ to! !

!MalGraphEdge methodsFor: 'accessing' stamp: ''!
from: anObject
	from := anObject! !

!MalGraphEdge methodsFor: 'accessing' stamp: ''!
to: anObject
	to := anObject! !

!MalGraphEdge methodsFor: 'printing' stamp: ''!
printOn: aStream
	self from printOn: aStream.
	aStream nextPutAll: ' -> '.
	self to printOn: aStream! !

!MalGraphEdge methodsFor: 'accessing' stamp: ''!
model: aModel
	
	model := aModel! !

!MalGraphEdge methodsFor: 'accessing' stamp: ''!
asTuple

	^ {from model. to model}! !

!MalGraphEdge methodsFor: 'accessing' stamp: ''!
from
	^ from! !

!MalGraphEdge methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!MalGraphEdge class methodsFor: 'instance creation' stamp: ''!
with: aModel

	^ self new model: aModel! !

!MalGraphEdge class methodsFor: 'instance creation' stamp: ''!
with: aModel from: srcNode to: dstNode
	| edge |
	edge := self new.
	edge model: aModel.
	edge from: srcNode.
	edge to: dstNode.
	^ edge.! !

!MalGraphEdgeTest methodsFor: 'tests' stamp: ''!
testPrintString
	self
		assert: (MalGraphEdge with: 'model' from: 'from' to: 'to') printString
		equals:  '''from'' -> ''to'''.! !

!MalGraphFixture commentStamp: ''!
Description
--------------------

I am a facade containing some behavior used by MooseAlgos tests.!
!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
complexCycleGraph: builder

	| nodes edges |
	nodes := $a to: $h.
	edges := #(($a $b) ($a $c) ($a $g) ($b $e) ($c $b) ($c $d) ($d $f) ($f $c) ($g $h) ($g $d) ($h $g)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
nestedCycleGraph: builder

	| nodes edges |
	nodes := $a to: $i.
	edges := #(($a $b) ($b $c) ($c $d) ($d $e) ($e $a) ($b $e) ($e $b) ($e $f) ($f $g) ($g $h) ($h $f) ($g $i) ($i $g)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
withoutCyclesComplexGraph: builder
	"for longest path algo"

	| nodes edges |
	nodes :=  #($a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s).
	edges := #(
		($a $e) ($a $g)
		($b $c) ($b $h)
		($c $o) ($c $q)
		($d $f) ($d $i)
		($f $i)
		($g $f)
		($h $d)
		($i $r)
		($j $k) ($j $l)
		($l $m) ($l $n)
		($o $p)
		($q $p)
		($p $s)
		($r $s)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
moduleGraph2: builder
	"sample graph from Habib et al for modular decomposition"

	| nodes edges |
	nodes :=  #($u $w $v $z $a $b $c $d).
	edges := #(
		($u $w)
		($w $a) ($w $b) ($w $c) ($w $d) ($w $v)
		($v $b) ($v $d) ($v $z)
		($z $b)
		($a $d)
		($c $v) ($c $z)
		($d $b) ($d $z)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
dependencyGraph: builder

	| nodes edges |
	nodes := $a to: $k.
	edges := #(($a $b) ($a $c) ($c $a) ($c $k) ($d $e) ($d $g) ($d $i) ($e $c) ($e $f) ($f $j) ($g $f) ($g $h) ($g $i) ($h $j)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
aseCircuitGraph: builder

	| nodes edges |
	nodes := $a to: $h.
	edges := #(($a $b) ($b $a) ($b $c) ($b $d) ($c $d) ($c $f) ($d $b) ($d $e) ($e $a) ($f $g) ($g $h) ($h $g)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
aseWeightedCircuitGraph: builder

	| nodes edges |
	nodes := $a to: $h.
	edges := #(($a $b 1) ($b $a 1) ($b $c 1) ($b $d 1) ($c $d 1) ($c $f 1) ($d $b 1) ($d $e 1) ($e $a 1) ($f $g 1) ($g $h 1) ($h $g 1)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second weight: #third.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
moduleGraph: builder

	| nodes edges |
	nodes := #('v1' 'v2' 'v3' 'v4' 'v5'	'v6' 'v7' 'v8' 'v9' 'v10' 'v11').
	edges := #(
		('v1' 'v2') ('v1' 'v3') ('v1' 'v4')
		('v2' 'v4') ('v2' 'v5') ('v2' 'v6') ('v2' 'v7')
		('v3' 'v4') ('v3' 'v5') ('v3' 'v6') ('v3' 'v7')
		('v4' 'v2') ('v4' 'v3') ('v4' 'v5') ('v4' 'v6') ('v4' 'v7')
		('v5' 'v6') ('v5' 'v7')
		('v6' 'v8') ('v6' 'v9') ('v6' 'v10') ('v6' 'v11')
		('v7' 'v8') ('v7' 'v9') ('v7' 'v10') ('v7' 'v11')
		('v8' 'v9') ('v8' 'v10') ('v8' 'v11')
		('v9' 'v10') ('v9' 'v11')).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
withoutCyclesMediumGraph: builder
	"for longest path algo"

	| nodes edges |
	nodes :=  #($a $b $c $d $e $f $g $h).
	edges := #(
		($a $e) ($a $g)
		($b $c) ($b $h)
		($d $f)
		($g $f)
		($h $d) ).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
simpleGraph: builder

	| nodes edges |
	nodes := $a to: $d.
	edges := #(($a $b) ($b $c) ($d $c)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
simpleWeightedGraph: builder

	| nodes edges |
	nodes := 1 to: 5.
	edges := #((1 2 5) (1 3 4) (2 3 2) (3 4 5) (2 4 3) (4 5 1) (5 1 2) (1 5 3)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second weight: #third.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
aseSccGraph: builder

	| nodes edges |
	nodes := $a to: $e.
	edges := #(($a $b) ($b $a) ($b $c) ($b $d) ($c $d) ($d $b) ($d $e) ($e $a)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
complexWeightedGraph: builder

	| nodes edges |
	nodes := $a to: $s.
	edges := #(($a $b 30) ($b $s 1) ($b $p 4) ($b $c 30) ($d $e 30) ($d $f 20) ($d $j 10) ($e $a 15) ($f $m 8) ($g $h 20) ($g $r 3) ($i $a 14) ($i $k 4) ($i $d 3) ($j $q 5) ($k $l 10) ($k $g 5) ($m $n 7) ($m $o 6) ($n $c 5) ($p $b 5) ($q $i 4)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second weight: #third.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
complexCycleGraph2: builder
	| nodes edges |
	nodes := $a to: $i.
	edges := #( #($a $b) 	#($a $f)	
					#($b $e) 	#($b $f) 
					#($c $b) 	#($c $a) 	#($c $e) 	#($c $f) 	#($c $g) 	#($c $d) 
					#($d $b)
					#($e $b) 	#($e $d) 	#($e $h) 
					#($f $b) 	#($f $e) 	#($f $d) 
					#($g $b) 	#($g $a) 	#($g $e) 	#($g $f) 	#($g $d) 	#($g $i) ).
	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphFixture class methodsFor: 'fixtures' stamp: ''!
cycleGraph: builder

	| nodes edges |
	nodes := $a to: $d.
	edges := #(($a $b) ($b $c) ($c $a) ($d $c)).

	builder nodes: nodes.
	builder edges: edges from: #first to: #second.
	^ builder! !

!MalGraphNode commentStamp: ''!
Default representation of a graph vertice (node).!
!MalGraphNode methodsFor: 'accessing' stamp: ''!
from: sourceNode! !

!MalGraphNode methodsFor: 'accessing' stamp: ''!
to: targetNode! !

!MalGraphNode methodsFor: 'printing' stamp: ''!
printOn: stream
	stream nextPutAll: self label.
	model printOn: stream! !

!MalGraphNode methodsFor: 'accessing' stamp: ''!
to: targetNode edge: anEdge! !

!MalGraphNode methodsFor: 'accessing' stamp: ''!
from: sourceNode edge: anEdge! !

!MalGraphNode methodsFor: 'accessing' stamp: ''!
model: aModel

	model := aModel! !

!MalGraphNode methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!MalGraphNode methodsFor: 'accessing' stamp: ''!
label

	^ 'N '! !

!MalGraphNode class methodsFor: 'instance creation' stamp: ''!
with: aModel

	^ self new model: aModel! !

!MalGraphReducer commentStamp: ''!
The reduced graph of G is the graph G where each strongly connected components was merged into one vertice / node.

circuitsNodes instance variable will collect all nodes created by merging nodes in a circuit.!
!MalGraphReducer methodsFor: 'updating' stamp: ''!
removeMergedNodes
	nodes removeAll: (circuitNodes flatCollect: #mergedNodes)! !

!MalGraphReducer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	circuitNodes := OrderedCollection new.
	circuits := OrderedCollection new! !

!MalGraphReducer methodsFor: 'computing' stamp: ''!
nextNodesFor: aNodeList
	"compute next nodes for the future node replacing aNodeList"
	^ ((aNodeList flatCollect: #nextNodes as: Set)
		difference: aNodeList) asOrderedCollection! !

!MalGraphReducer methodsFor: 'merging' stamp: ''!
mergeNodesInCircuit: aNodeList
	| sortedNodes |
	"ensure that we get the same order in nodes part of a cycle. MalTarjan uses a dictionary and order depends on model hash that can differ from a machine to another one."
	sortedNodes := aNodeList sort: [ :one :other | one model < other model ].
	circuitNodes add: (self nodeClass new
		mergedNodes: sortedNodes;
		model: (sortedNodes collect: [:each | each model]);
		nextNodes: (self nextNodesFor: sortedNodes);
		previousNodes: (self previousNodesFor: sortedNodes);
		yourself)! !

!MalGraphReducer methodsFor: 'configuration' stamp: ''!
nodeClass
	^ MalReducedGraphNode! !

!MalGraphReducer methodsFor: 'updating' stamp: ''!
removeReferencesToMergedNodes
	circuitNodes do: 
		[ :circuitNode |
		self 
			updateReferencesTo: circuitNode mergedNodes
			by: circuitNode.
		self removeCircularDependenciesFrom: circuitNode ]! !

!MalGraphReducer methodsFor: 'merging' stamp: ''!
mergeNodesInCircuits
	circuits do: [ :each | self mergeNodesInCircuit: each ].
	self removeReferencesToMergedNodes.
	self removeMergedNodes.
	self addCircuitNodes! !

!MalGraphReducer methodsFor: 'updating' stamp: ''!
updateNextNodesOf: mergedNode replacing: aNodeList by: anotherNode
	mergedNode nextNodes
		do: [ :node | 
			node previousNodes
				removeAllFoundIn: aNodeList;
				addIfNotPresent: anotherNode ]! !

!MalGraphReducer methodsFor: 'updating' stamp: ''!
addCircuitNodes
	nodes addAll: circuitNodes! !

!MalGraphReducer methodsFor: 'running' stamp: ''!
findCircuits
	| tarjanCircuits |
	tarjanCircuits := MalTarjan new
		nodesAndNextFrom: nodes;
		run;
		circuits.
	circuits := tarjanCircuits 
		collect: [ :circuit | 
			circuit collect: [ :each | self findNode: each model ] ]! !

!MalGraphReducer methodsFor: 'updating' stamp: ''!
updateReferencesTo: aNodeList by: anotherNode
	aNodeList do: 
		[ :mergedNode | 
		self 
			updatePreviousNodesOf: mergedNode
			replacing: aNodeList
			by: anotherNode.
		self 
			updateNextNodesOf: mergedNode
			replacing: aNodeList
			by: anotherNode ]! !

!MalGraphReducer methodsFor: 'computing' stamp: ''!
previousNodesFor: aNodeList
	"compute previous nodes for the future node replacing aNodeList"
	^ ((aNodeList flatCollect: #previousNodes as: Set)
		difference: aNodeList) asOrderedCollection! !

!MalGraphReducer methodsFor: 'running' stamp: ''!
run
	self findCircuits.
	self mergeNodesInCircuits.
	^ self nodes! !

!MalGraphReducer methodsFor: 'updating' stamp: ''!
updatePreviousNodesOf: mergedNode replacing: aNodeList by: anotherNode
	mergedNode previousNodes
		do: [ :node | 
			node nextNodes
				removeAllFoundIn: aNodeList;
				addIfNotPresent: anotherNode ]! !

!MalGraphReducer methodsFor: 'updating' stamp: ''!
removeCircularDependenciesFrom: circuitNode
	circuitNode nextNodes removeAllSuchThat: [ :each | each = circuitNode ].
	circuitNode previousNodes removeAllSuchThat: [ :each | each = circuitNode ]! !

!MalGraphReducerTest methodsFor: 'helpers' stamp: ''!
assertNodes: aNodeList doesNotInclude: anotherNodeList
	aNodeList 
		collect: [:each | each model]
		thenDo: 
			[ :model | 
			self 
				deny: ((anotherNodeList collect: [:each | each model]) includes: model)
				description: model asString , ' should not be referenced!!' ]! !

!MalGraphReducerTest methodsFor: 'tests' stamp: ''!
testPreviousNodesFor
	| nodes |
	MalGraphFixture complexCycleGraph2: graphReducer.
	nodes := {(graphReducer findNode: $f) . (graphReducer findNode: $g)}.
	self
		assert: ((graphReducer previousNodesFor: nodes) collect: #model as: SortedCollection) asArray
		equals: #($a $b $c)! !

!MalGraphReducerTest methodsFor: 'tests' stamp: ''!
testGraphReducingWhenNoCycle
	| initialGraph |
	MalGraphFixture simpleGraph: graphReducer.
	initialGraph := graphReducer graph copy.
	graphReducer run.
	self assert: initialGraph equals: graphReducer graph! !

!MalGraphReducerTest methodsFor: 'tests' stamp: ''!
testNextNodesFor
	| nodes |
	MalGraphFixture complexCycleGraph2: graphReducer.
	nodes := {(graphReducer findNode: $f) . (graphReducer findNode: $g)}.
	self
		assert: ((graphReducer nextNodesFor: nodes) collect: #model as: SortedCollection) asArray
		equals: #($a $b $d $e $i)! !

!MalGraphReducerTest methodsFor: 'tests' stamp: ''!
testNoCycle
	MalGraphFixture complexCycleGraph2: graphReducer.
	graphReducer run.
	graphReducer nodes do:
		[ :node | 
		self 
			deny: ((node nextNodes includes: node) or: [ node previousNodes includes: node ])
			description: node asString, ' node is in cycle!!' ]! !

!MalGraphReducerTest methodsFor: 'helpers' stamp: ''!
mergedNodesIn: aNodeList
	^ (aNodeList select: [ :node | node mergedNodes notNil ]) flatCollect: #mergedNodes! !

!MalGraphReducerTest methodsFor: 'tests' stamp: ''!
testComplexCycle2
	MalGraphFixture complexCycleGraph2: graphReducer.
	graphReducer run.
	self assert: graphReducer nodes size equals: 6.
	self assert: (graphReducer nodes at: 6) mergedNodes size equals: 4! !

!MalGraphReducerTest methodsFor: 'tests' stamp: ''!
testMergedNodesNotReferencedInNextNodes
	MalGraphFixture complexCycleGraph2: graphReducer.
	graphReducer run.

	self 
		assertNodes: (graphReducer nodes flatCollect: #nextNodes) 
		doesNotInclude: (self mergedNodesIn: graphReducer nodes)! !

!MalGraphReducerTest methodsFor: 'tests' stamp: ''!
testMergedNodesNotReferencedInPreviousNodes
	MalGraphFixture complexCycleGraph2: graphReducer.
	graphReducer run.

	self 
		assertNodes: (graphReducer nodes flatCollect: #previousNodes) 
		doesNotInclude: (self mergedNodesIn: graphReducer nodes)! !

!MalGraphReducerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	graphReducer := MalGraphReducer new! !

!MalGraphStructure methodsFor: 'configuration' stamp: ''!
edgeClass

	^ edgeClass! !

!MalGraphStructure methodsFor: 'accessing' stamp: ''!
edgeModels

	^ self edges collect: [:e | e model]! !

!MalGraphStructure methodsFor: 'configuration' stamp: ''!
nodeClass

	^ nodeClass! !

!MalGraphStructure methodsFor: 'running' stamp: ''!
run
	self shouldNotImplement! !

!MalGraphStructure methodsFor: 'configuration' stamp: ''!
nodeClass: anObject
	nodeClass := anObject! !

!MalGraphStructure methodsFor: 'accessing' stamp: ''!
nodeModels

	^ self nodes collect: [:n | n model]! !

!MalGraphStructure methodsFor: 'configuration' stamp: ''!
edgeClass: anObject
	edgeClass := anObject! !

!MalHal methodsFor: 'logging' stamp: ''!
showLevels
	^ String
		streamContents: [ :s | 
			self hierarchyLevels
				keysAndValuesDo: [ :k :v | 
					s print: k.
					v
						do: [ :n | 
							s
								space;
								print: n ].
					s cr ] ]! !

!MalHal methodsFor: 'configuration' stamp: ''!
nodeClass
	^ MalHalNode! !

!MalHal methodsFor: 'running' stamp: ''!
mainLoop
	| cnode touchedCycle |
	[ nodesToVisit isEmpty ]
		whileFalse: [ 
			cnode := nodesToVisit removeFirst.
			cnode nextNodes
				do: [ :next | 
					touchedCycle := next markHNumber: cnode hNumber + 1.
					nodesToVisit addAll: touchedCycle ].
			nodesToVisit addAll: cnode nextNodes ]! !

!MalHal methodsFor: 'accessing' stamp: ''!
hierarchyLevels
	| map level |
	map := Dictionary new.
	self nodes do: [ :node | 
		level := map 
			at: node hNumber 
			ifAbsentPut: [OrderedCollection new].
		level add: node
	].
	^ map! !

!MalHal methodsFor: 'running' stamp: ''!
initializeHal
	| entryNodes |
	nodesToVisit := OrderedCollection new.
	self nodes do: #removeCycleFromEdges.
	entryNodes := self nodes select: #isSource.
	entryNodes do: [ :n | n hNumber: 0 ].
	nodesToVisit addAll: entryNodes! !

!MalHal methodsFor: 'running' stamp: ''!
run
	super run.
	self initializeHal.
	self mainLoop! !

!MalHalNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	previousNodes := Set new! !

!MalHalNode methodsFor: 'accessing' stamp: ''!
from: aHalNode
	previousNodes add: aHalNode! !

!MalHalNode methodsFor: 'accessing' stamp: ''!
previousNodes
	^ previousNodes! !

!MalHalNode methodsFor: 'hal-algorithm' stamp: ''!
markHNumber: anInteger

	self hNumber: anInteger.
	self isInCycle ifTrue: [
		^ self markCycleWith: anInteger
	].
	^ OrderedCollection new! !

!MalHalNode methodsFor: 'accessing' stamp: ''!
to: aNode
	super to: aNode.
	aNode previousNodes add: self! !

!MalHalNode methodsFor: 'accessing' stamp: ''!
previousNodes: anObject
	previousNodes := anObject! !

!MalHalNode methodsFor: 'testing' stamp: ''!
isSink

	^ self nextNodes isEmpty! !

!MalHalNode methodsFor: 'accessing' stamp: ''!
hNumber: anObject
	hNumber := anObject! !

!MalHalNode methodsFor: 'hal-algorithm' stamp: ''!
removeCycleFromEdges

	self nextNodes removeAllFoundIn: self cycleNodes.
	self previousNodes removeAllFoundIn: self cycleNodes! !

!MalHalNode methodsFor: 'testing' stamp: ''!
isSource

	^ self previousNodes isEmpty! !

!MalHalNode methodsFor: 'accessing' stamp: ''!
label

	^ 'Ha '! !

!MalHalNode methodsFor: 'accessing' stamp: ''!
hNumber
	^ hNumber! !

!MalHalNode methodsFor: 'hal-algorithm' stamp: ''!
markCycleWith: anInteger

	self cycleNodes do: [ :next | next hNumber: anInteger ].
	^ self cycleNodes! !

!MalHalTest methodsFor: 'tests' stamp: ''!
testCycle
	(MalGraphFixture cycleGraph: hal) run.
	self assert: (hal findNode: $a) hNumber equals: 1.
	self assert: (hal findNode: $b) hNumber equals: 1.
	self assert: (hal findNode: $c) hNumber equals: 1.
	self assert: (hal findNode: $d) hNumber equals: 0.
	hal showLevels! !

!MalHalTest methodsFor: 'tests' stamp: ''!
testModuleGraph2
	(MalGraphFixture moduleGraph2: hal) run.
	self assert: (hal findNode: $u) hNumber equals: 0.
	self assert: (hal findNode: $w) hNumber equals: 1.
	self assert: (hal findNode: $a) hNumber equals: 2.
	self assert: (hal findNode: $c) hNumber equals: 2.
	self assert: (hal findNode: $v) hNumber equals: 3.
	self assert: (hal findNode: $d) hNumber equals: 4.
	self assert: (hal findNode: $z) hNumber equals: 5.
	self assert: (hal findNode: $b) hNumber equals: 6.
	hal showLevels! !

!MalHalTest methodsFor: 'tests' stamp: ''!
testModuleGraph
	(MalGraphFixture moduleGraph: hal) run.
	self assert: (hal findNode: 'v1') hNumber equals: 0.
	self assert: (hal findNode: 'v2') hNumber equals: 1.
	self assert: (hal findNode: 'v3') hNumber equals: 1.
	self assert: (hal findNode: 'v4') hNumber equals: 1.
	self assert: (hal findNode: 'v5') hNumber equals: 2.
	self assert: (hal findNode: 'v6') hNumber equals: 3.
	self assert: (hal findNode: 'v7') hNumber equals: 3.
	self assert: (hal findNode: 'v8') hNumber equals: 4.
	self assert: (hal findNode: 'v9') hNumber equals: 5.
	self assert: (hal findNode: 'v10') hNumber equals: 6.
	self assert: (hal findNode: 'v11') hNumber equals: 6.
	hal showLevels! !

!MalHalTest methodsFor: 'tests' stamp: ''!
testNestedCycle
	(MalGraphFixture nestedCycleGraph: hal) run.
	self assert: (hal findNode: $a) hNumber equals: 0.
	self assert: (hal findNode: $b) hNumber equals: 0.
	self assert: (hal findNode: $c) hNumber equals: 0.
	self assert: (hal findNode: $d) hNumber equals: 0.
	self assert: (hal findNode: $e) hNumber equals: 0.
	self assert: (hal findNode: $f) hNumber equals: 1.
	self assert: (hal findNode: $g) hNumber equals: 1.
	self assert: (hal findNode: $h) hNumber equals: 1.
	self assert: (hal findNode: $i) hNumber equals: 1.
	hal showLevels! !

!MalHalTest methodsFor: 'tests' stamp: ''!
testComplexCycle
	(MalGraphFixture complexCycleGraph: hal) run.
	self assert: (hal findNode: $a) hNumber equals: 0.
	self assert: (hal findNode: $b) hNumber equals: 3.
	self assert: (hal findNode: $c) hNumber equals: 2.
	self assert: (hal findNode: $d) hNumber equals: 2.
	self assert: (hal findNode: $e) hNumber equals: 4.
	self assert: (hal findNode: $f) hNumber equals: 2.
	self assert: (hal findNode: $g) hNumber equals: 1.
	self assert: (hal findNode: $h) hNumber equals: 1.
	hal showLevels! !

!MalHalTest methodsFor: 'tests' stamp: ''!
testSimpleGraph
	(MalGraphFixture simpleGraph: hal) run.
	self assert: (hal findNode: $a) hNumber equals: 0.
	self assert: (hal findNode: $d) hNumber equals: 0.
	self assert: (hal findNode: $b) hNumber equals: 1.
	self assert: (hal findNode: $c) hNumber equals: 2.
	hal showLevels! !

!MalHalTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	hal := MalHal new! !

!MalHits methodsFor: 'running' stamp: ''!
computeHubsFor: aNode

	aNode hub: (aNode nextNodes inject: 0 into: [:s :n| s + n auth])! !

!MalHits methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	k := 20! !

!MalHits methodsFor: 'running' stamp: ''!
initializeNodes

	self nodes do: [:n|
		n auth: 1.0; hub: 1.0
	]! !

!MalHits methodsFor: 'configuration' stamp: ''!
k
	^ k! !

!MalHits methodsFor: 'configuration' stamp: ''!
nodeClass

	^ MalHitsNode! !

!MalHits methodsFor: 'running' stamp: ''!
computeAuthoritiesFor: aNode

	aNode auth: (aNode previousNodes inject: 0 into: [:s :n| s + n hub])! !

!MalHits methodsFor: 'running' stamp: ''!
run

	|i|
	i := 1.
	self initializeNodes.
	[i = k] whileFalse: [
		self nodes do: [:n|
			self computeAuthoritiesFor: n].
		self nodes do: [:n|
			self computeHubsFor: n].
		self normalize: self nodes.
"		Transcript cr; show: i; show: ': '.
		self nodes do: [:n|
			Transcript show: n printString]."
	i := i + 1]! !

!MalHits methodsFor: 'configuration' stamp: ''!
k: anObject
	k := anObject! !

!MalHits methodsFor: 'running' stamp: ''!
normalize: aCollectionOfNodes

	| authNorm hubNorm |
	authNorm := aCollectionOfNodes inject: 0 into: [:s :n| s + n auth].
	hubNorm := aCollectionOfNodes inject: 0 into: [:s :n| s + n hub].
	authNorm = 0 ifTrue: [authNorm := 1].
	hubNorm = 0 ifTrue: [hubNorm := 1].
	aCollectionOfNodes do: [:n|
		n auth: (n auth / authNorm).
		n hub: (n hub / hubNorm)]! !

!MalHitsFixtureTest methodsFor: 'tests' stamp: ''!
testCycle
	MalGraphFixture cycleGraph: hits.
	self shouldnt: [ hits run ] raise: Error! !

!MalHitsFixtureTest methodsFor: 'tests' stamp: ''!
testSimpleW
	MalGraphFixture simpleWeightedGraph: hits.
	self shouldnt: [ hits run ] raise: Error! !

!MalHitsFixtureTest methodsFor: 'tests' stamp: ''!
testNestedCycle
	MalGraphFixture nestedCycleGraph: hits.
	self shouldnt: [ hits run ] raise: Error! !

!MalHitsFixtureTest methodsFor: 'tests' stamp: ''!
testComplexCycle
	MalGraphFixture complexCycleGraph: hits.
	self shouldnt: [ hits run ] raise: Error! !

!MalHitsFixtureTest methodsFor: 'tests' stamp: ''!
testSimple
	MalGraphFixture simpleGraph: hits.
	self shouldnt: [ hits run ] raise: Error! !

!MalHitsFixtureTest methodsFor: 'tests' stamp: ''!
testComplexWCycle
	MalGraphFixture complexWeightedGraph: hits.
	self shouldnt: [ hits run ] raise: Error! !

!MalHitsFixtureTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	hits := MalHits new! !

!MalHitsNode methodsFor: 'accessing' stamp: ''!
hub: anObject
	hub := anObject! !

!MalHitsNode methodsFor: 'accessing' stamp: ''!
auth
	^ auth! !

!MalHitsNode methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPut: $(.
	self model printOn: aStream.
	aStream space.
	self auth printOn: aStream showingDecimalPlaces: 2.
	aStream space.
	self hub printOn: aStream showingDecimalPlaces: 2.
	aStream nextPutAll: ')'.! !

!MalHitsNode methodsFor: 'accessing' stamp: ''!
auth: anObject
	auth := anObject! !

!MalHitsNode methodsFor: 'accessing' stamp: ''!
hub
	^ hub! !

!MalHitsNode methodsFor: 'accessing' stamp: ''!
label

	^ 'H '! !

!MalHitsNodeTest methodsFor: 'tests' stamp: ''!
testPrintString
	|node|
	node := MalHitsNode new
		model: 'model';
		auth: 7;
		hub: 11;
		yourself.
	self assert: node printString equals: '(''model'' 7.00 11.00)'.! !

!MalKruskal commentStamp: ''!
Kruskal's algorithm is a greedy algorithm in graph theory that finds a minimum spanning tree for a connected weighted graph. This means it finds a subset of the edges that forms a tree that includes every vertex, where the total weight of all the edges in the tree is minimized. If the graph is not connected, then it finds a minimum spanning forest (a minimum spanning tree for each connected component).

See https://en.wikipedia.org/wiki/Kruskal%27s_algorithm!
!MalKruskal methodsFor: 'configuration' stamp: ''!
edgeClass
	^ MalWeightedEdge! !

!MalKruskal methodsFor: 'configuration' stamp: ''!
minSpanningTree
	sortBlock := [:e1 :e2 | e1 weight < e2 weight]! !

!MalKruskal methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self minSpanningTree! !

!MalKruskal methodsFor: 'configuration' stamp: ''!
nodeClass
	^ MalDisjointSetNode! !

!MalKruskal methodsFor: 'configuration' stamp: ''!
sortBlock: aBlock
	sortBlock := aBlock! !

!MalKruskal methodsFor: 'running' stamp: ''!
run
	| treeEdges |
	treeEdges := OrderedCollection new.
	nodes do: #makeSet.
	(edges asSortedCollection: sortBlock)
		reject: [ :edge | edge from find = edge to find ]
		thenDo: [ :edge | 
			edge from union: edge to.
			treeEdges add: edge ].
	^ treeEdges! !

!MalKruskal methodsFor: 'configuration' stamp: ''!
maxSpanningTree
	sortBlock := [:e1 :e2 | e1 weight > e2 weight]! !

!MalKruskalTest methodsFor: 'tests' stamp: ''!
testMaxSpanningTree
	| tree expectedEdges |
	MalGraphFixture simpleWeightedGraph: kruskal.
	kruskal maxSpanningTree.
	tree := kruskal run collect: [ :e | e asTuple ].

	expectedEdges := #(#(1 2 5) #(3 4 5) #(1 3 4) #(1 5 3)).
	expectedEdges do: [ :e | self assert: (tree includes: e) ].
	tree do: [ :e | self assert: (expectedEdges includes: e) ]! !

!MalKruskalTest methodsFor: 'tests' stamp: ''!
testMinSpanningTree1
	| tree expectedEdges |
	MalGraphFixture complexWeightedGraph: kruskal.
	tree := kruskal run collect: [ :e | e asTuple ].

	expectedEdges := #(#($a $b 30) #($b $s 1) #($b $p 4) #($d $f 20) #($e $a 15) #($f $m 8) #($g $h 20) #($g $r 3) #($i $a 14) #($i $k 4) #($i $d 3) #($j $q 5) #($k $l 10) #($k $g 5) #($m $n 7) #($m $o 6) #($n $c 5) #($q $i 4)).
	"self assert: tree asArray equals: expectedEdges."
	expectedEdges do: [ :e | self assert: (tree includes: e) ].
	tree do: [ :e | self assert: (expectedEdges includes: e) ]! !

!MalKruskalTest methodsFor: 'tests' stamp: ''!
testMaxSpanningTree2
	| tree expectedEdges |
	MalGraphFixture complexWeightedGraph: kruskal.
	kruskal maxSpanningTree.
	tree := kruskal run collect: [ :e | e asTuple ].

	expectedEdges := #(#($a $b 30) #($b $s 1) #($b $c 30) #($d $e 30) #($d $f 20) #($d $j 10) #($e $a 15) #($f $m 8) #($g $h 20) #($g $r 3) #($i $a 14) #($i $k 4) #($j $q 5) #($k $l 10) #($k $g 5) #($m $n 7) #($m $o 6) #($p $b 5)).
	expectedEdges do: [ :e | self assert: (tree includes: e) ].
	tree do: [ :e | self assert: (expectedEdges includes: e) ]! !

!MalKruskalTest methodsFor: 'tests' stamp: ''!
testMinSpanningTree
	| tree expectedEdges |
	MalGraphFixture simpleWeightedGraph: kruskal.
	tree := kruskal run collect: [ :e | e asTuple ].

	expectedEdges := #(#(4 5 1) #(5 1 2) #(2 3 2) #(2 4 3)).
	self assert: tree asArray equals: expectedEdges.
	expectedEdges do: [ :e | self assert: (tree includes: e) ].
	tree do: [ :e | self assert: (expectedEdges includes: e) ]! !

!MalKruskalTest methodsFor: 'tests' stamp: ''!
testUnionFind
	| node1 node2 node3 node4 |
	nodes
		do: [ :node | 
			self assert: node parent equals: nil.
			node makeSet.
			self assert: node parent equals: node.
			self assert: node find equals: node ].
	node1 := nodes at: 1.
	node2 := nodes at: 2.
	node3 := nodes at: 3.
	node4 := nodes at: 4.
	node1 union: node2.
	self assert: node1 find equals: node1.
	self assert: node2 find equals: node1.
	node2 union: node3.
	self assert: node2 find equals: node1.
	self assert: node3 find equals: node1.
	self assert: node3 parent equals: node1.
	node4 union: node1.
	nodes do: [ :node | self assert: node find equals: node4 ].
	self assert: node1 parent equals: node4.
	self assert: node2 parent equals: node1.
	self assert: node3 parent equals: node1.
	self assert: node4 parent equals: node4! !

!MalKruskalTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	kruskal := MalKruskal new.
	nodes := OrderedCollection new.
	nodes add: MalDisjointSetNode new.
	nodes add: MalDisjointSetNode new.
	nodes add: MalDisjointSetNode new.
	nodes add: MalDisjointSetNode new! !

!MalLongestPath commentStamp: ''!
A MalLongestPath is the implementation of the longest path algo.
This is working only on graph not weighted and without circuits

See tests for more informations
!
!MalLongestPath methodsFor: 'computing' stamp: ''!
computeLeafNodes
	self leafNodes: (self nodes select: [ :node | node nextEdges isEmpty ])! !

!MalLongestPath methodsFor: 'configuration' stamp: ''!
edgeClass
	^ MalGraphEdge! !

!MalLongestPath methodsFor: 'initialization' stamp: ''!
initializeRootNodes
	self computeRootNodes.
	self setRanks: self rootNodes at: 0! !

!MalLongestPath methodsFor: 'computing' stamp: ''!
computeRootNodes
	self rootNodes: (self nodes select: [ :node | node previousEdges isEmpty ])! !

!MalLongestPath methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	maxIterations := -1.
	previousRanks := OrderedCollection new! !

!MalLongestPath methodsFor: 'configuration' stamp: ''!
nodeClass
	^ MalDijkstraNode! !

!MalLongestPath methodsFor: 'accessing' stamp: ''!
rootNodes: aCollectionOfNodes
	rootNodes := aCollectionOfNodes! !

!MalLongestPath methodsFor: 'testing' stamp: ''!
isCompleted
	maxIterations isZero
		ifTrue: [ self error: 'Algorithm should be finished by now...'.
			^ true ].
	^ (self leafNodes anySatisfy: [ :node | node pathWeight = Float infinity ]) not! !

!MalLongestPath methodsFor: 'accessing' stamp: ''!
leafNodes: aCollectionOfNodes
	leafNodes := aCollectionOfNodes! !

!MalLongestPath methodsFor: 'accessing' stamp: ''!
rootNodes
	^ rootNodes! !

!MalLongestPath methodsFor: 'computing' stamp: ''!
computeStep
	| currentRank |
	self isCompleted ifTrue: [ ^ self ].
	currentRank := OrderedCollection new.
	(self nodes difference: previousRanks)
		select: [ :node | previousRanks includesAll: node previousNodes ]
		thenDo: [ :node | 
			currentRank add: node.
			node pathWeight: (node previousNodes max: [ :maxNode | maxNode pathWeight ]) + 1 ].
	previousRanks addAll: currentRank.
	maxIterations := maxIterations - 1.
	self computeStep! !

!MalLongestPath methodsFor: 'running' stamp: ''!
run
	self ensureNodesAreSorted.
	self initializeRootNodes.
	self computeLeafNodes.
	previousRanks addAll: self rootNodes.
	maxIterations := self nodes size + 20.
	self computeStep! !

!MalLongestPath methodsFor: 'accessing' stamp: ''!
leafNodes
	^ leafNodes! !

!MalLongestPath methodsFor: 'setting' stamp: ''!
setRanks: collectionOfNodes at: aRank
	collectionOfNodes do: [ :aNode | aNode pathWeight: aRank ]! !

!MalLongestPathTest methodsFor: 'tests' stamp: ''!
testRunInSimpleGraph
	MalGraphFixture simpleGraph: longestPath.
	longestPath run.
	self assert: ($a to: $d) hasWeight: #(0 1 2 0)! !

!MalLongestPathTest methodsFor: 'tests' stamp: ''!
testRootNodesInSimpleGraph

	MalGraphFixture simpleGraph: longestPath.
	longestPath computeRootNodes.
	self assert: (longestPath rootNodes collect: [:each | each model]) equals: #($a $d) asOrderedCollection! !

!MalLongestPathTest methodsFor: 'tests' stamp: ''!
testRootNodesRankIsZeroInSimpleGraph

	MalGraphFixture simpleGraph: longestPath.
	longestPath initializeRootNodes.
	self assert: (longestPath rootNodes collect: [:each | each model]) equals: #($a $d) asOrderedCollection.
	self assert: (longestPath rootNodes collect: [:each | each pathWeight]) equals: #(0 0) asOrderedCollection! !

!MalLongestPathTest methodsFor: 'tests' stamp: ''!
testRootNodesInWithoutCyclesMediumGraph

	MalGraphFixture withoutCyclesMediumGraph: longestPath.
	longestPath computeRootNodes.
	self assert: (longestPath rootNodes collect: [:each | each model]) equals: #($a $b) asOrderedCollection! !

!MalLongestPathTest methodsFor: 'tests' stamp: ''!
testLeafNodesInSimpleGraph
	MalGraphFixture simpleGraph: longestPath.
	longestPath computeLeafNodes.
	self assert: (longestPath leafNodes collect: [:each | each model]) equals: #($c) asOrderedCollection! !

!MalLongestPathTest methodsFor: 'tests' stamp: ''!
testRunInWithoutCyclesComplexGraph
	MalGraphFixture withoutCyclesComplexGraph: longestPath.
	longestPath run.
	self assert: ($a to: $s) hasWeight: #(0 0 1 2 1 3 1 1 4 0 1 1 2 2 2 3 2 5 6)! !

!MalLongestPathTest methodsFor: 'helpers' stamp: ''!
assert: aCollectionOfNodesModel hasWeight: values
	self assert: aCollectionOfNodesModel size equals: values size.
	aCollectionOfNodesModel
		withIndexDo: [ :element :index | self assert: (longestPath findNode: element) pathWeight equals: (values at: index) ]! !

!MalLongestPathTest methodsFor: 'tests' stamp: ''!
testRunIsCompletedInSimpleGraph
	MalGraphFixture simpleGraph: longestPath.
	longestPath run.
	self assert: longestPath isCompleted! !

!MalLongestPathTest methodsFor: 'tests' stamp: ''!
testRunInWithoutCyclesMediumGraph
	MalGraphFixture withoutCyclesMediumGraph: longestPath.
	longestPath run.
	self assert: ($a to: $h) hasWeight: #(0 0 1 2 1 3 1 1)! !

!MalLongestPathTest methodsFor: 'tests' stamp: ''!
testIsCompletedInSimpleGraph
	MalGraphFixture simpleGraph: longestPath.
	longestPath computeLeafNodes.
	self deny: longestPath isCompleted! !

!MalLongestPathTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	longestPath := MalLongestPath new! !

!MalNodeWithNext commentStamp: ''!
A basic node able to host the model and to represent edges with no additional class.
Edges are navigable in one way through the nextNodes instance variable.!
!MalNodeWithNext methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	nextNodes := OrderedCollection new! !

!MalNodeWithNext methodsFor: 'setting' stamp: ''!
nextNodes: aNodeList
	nextNodes := aNodeList! !

!MalNodeWithNext methodsFor: 'accessing' stamp: ''!
to: targetNode
	self nextNodes add: targetNode! !

!MalNodeWithNext methodsFor: 'testing' stamp: ''!
isLeaf
	^ self nextNodes isEmpty! !

!MalNodeWithNext methodsFor: 'accessing' stamp: ''!
nextNodes
	^ nextNodes! !

!MalNodeWithPreviousAndNext commentStamp: ''!
A basic node able to host the model and to represent edges with no additional class.
Edges are navigable in both way through the nextNodes and prevousNodes instances variables.!
!MalNodeWithPreviousAndNext methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	previousNodes := OrderedCollection new! !

!MalNodeWithPreviousAndNext methodsFor: 'accessing' stamp: ''!
from: sourceNode
	self previousNodes add: sourceNode! !

!MalNodeWithPreviousAndNext methodsFor: 'accessing' stamp: ''!
previousNodes
	^ previousNodes! !

!MalNodeWithPreviousAndNext methodsFor: 'testing' stamp: ''!
isRoot
	^ self previousNodes isEmpty! !

!MalNodeWithPreviousAndNext methodsFor: 'setting' stamp: ''!
previousNodes: aNodeList
	previousNodes := aNodeList! !

!MalReducedGraphNode commentStamp: ''!
Node used by the MalReducedGraph algorithm.
It has an additional instance variable to track merged nodes.!
!MalReducedGraphNode methodsFor: 'setting' stamp: ''!
mergedNodes: aNodeList
	mergedNodes := aNodeList! !

!MalReducedGraphNode methodsFor: 'accessing' stamp: ''!
mergedNodes
	^ mergedNodes! !

!MalReducedGraphNode methodsFor: 'accessing' stamp: ''!
label
	^ ''! !

!MalSccEdgeDecomposition methodsFor: 'configuration' stamp: ''!
edgeClass
	^ MalGraphEdge! !

!MalSccEdgeDecomposition methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	bfsp := MalBreadthFirstSearchPath new.! !

!MalSccEdgeDecomposition methodsFor: 'configuration' stamp: ''!
nodeClass
	^ MalBfsNode! !

!MalSccEdgeDecomposition methodsFor: 'running' stamp: ''!
run
	bfsp 
		privateNodes: self nodes;
		privateEdges: self edges.
	self edges do: [:e||c|
		c := self 
			bfsPathFrom: e to 
			to: e from.
		self addCircuit: (self normalize: c) ]! !

!MalSccEdgeDecomposition methodsFor: 'running' stamp: ''!
bfsPathFrom: startNode to: endNode
	^ bfsp
		start: startNode;
		end: endNode;
		run! !

!MalSccEdgeDecomposition methodsFor: 'running' stamp: ''!
normalize: aCollectionOfNodes

	| firstNode perm |
	firstNode := aCollectionOfNodes detectMin: [:n| n printString ].
	perm := aCollectionOfNodes copy.
	[ firstNode = perm first ] whileFalse: [
		perm addLast: perm removeFirst ].
	^ perm! !

!MalSccEdgeDecomposition class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MalSccEdgeDecomposition class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MalSccEdgeDecomposition class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MalSccEdgeDecomposition class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MalSccEdgeDecomposition class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MalSccEdgeDecomposition class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MalSccEdgeDecomposition class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MalSccEdgeDecomposition class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MalSccEdgeDecomposition class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalSccEdgeDecomposition class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MalSccEdgeDecomposition class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MalSccEdgeDecomposition class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MalSccEdgeDecomposition class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MalSccEdgeDecomposition class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MalSccEdgeDecomposition class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MalSccEdgeDecomposition class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MalSccEdgeDecomposition class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MalSccEdgeDecomposition class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalSccEdgeDecomposition class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MalSccEdgeDecomposition class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MalSccEdgeDecomposition class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MalSccEdgeDecomposition class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MalSccEdgeDecomposition class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MalSccEdgeDecomposition class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MalSccEdgeDecomposition class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MalSccEdgeDecomposition class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MalSccEdgeDecomposition class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MalSccEdgeDecomposition class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MalSccEdgeDecomposition class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MalSccExtractor commentStamp: ''!
A utility class to easily get circuits, i.e. SCC with more than one node.!
!MalSccExtractor methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	circuits := Set new.! !

!MalSccExtractor methodsFor: 'accessing' stamp: ''!
addCircuit: aCollectionOfNodes
	
	circuits add: aCollectionOfNodes! !

!MalSccExtractor methodsFor: 'accessing' stamp: ''!
circuits
	^ circuits! !

!MalSccNodeDecomposition methodsFor: 'configuration' stamp: ''!
nodeClass

	^ MalSndNode! !

!MalSccNodeDecomposition methodsFor: 'running' stamp: ''!
retrieveCircuit: aNode
	| c i |
	c := OrderedCollection new.
	i := aNode.
	[ i notNil ]
		whileTrue: [ c addFirst: i model.
			i := i bfsAncestor ].
	^ c! !

!MalSccNodeDecomposition methodsFor: 'running' stamp: ''!
run

	self nodes do: [:n|
		self run: n
	]! !

!MalSccNodeDecomposition methodsFor: 'running' stamp: ''!
normalize: aCollectionOfNodes

	| firstNode perm |
	firstNode := aCollectionOfNodes detectMin: [:n| n printString ].
	perm := aCollectionOfNodes copy.
	[ firstNode = perm first ] whileFalse: [
		perm addLast: perm removeFirst ].
	^ perm! !

!MalSccNodeDecomposition methodsFor: 'running' stamp: ''!
run: aNode

	| fifo visited ancestors |
	visited := Set new.
	ancestors := aNode previousNodes.
	aNode bfsAncestor: nil.
	fifo := OrderedCollection with: aNode.
	[ancestors isEmpty] whileFalse: [ |p|
		p := fifo removeFirst.
		p nextNodes do: [:next|
			((visited includes: next) or: [fifo includes: next])
				ifFalse: [
					next bfsAncestor: p.
					fifo addLast: next ].
			(ancestors includes: next)
				ifTrue: [ |c|
					c := self retrieveCircuit: next.
					self addCircuit: (self normalize: c).
					ancestors remove: next ]
		].
		visited add: p ]! !

!MalSccNodeDecomposition class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MalSccNodeDecomposition class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MalSccNodeDecomposition class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MalSccNodeDecomposition class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MalSccNodeDecomposition class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MalSccNodeDecomposition class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MalSccNodeDecomposition class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MalSccNodeDecomposition class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MalSccNodeDecomposition class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalSccNodeDecomposition class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MalSccNodeDecomposition class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MalSccNodeDecomposition class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MalSccNodeDecomposition class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MalSccNodeDecomposition class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MalSccNodeDecomposition class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MalSccNodeDecomposition class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MalSccNodeDecomposition class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MalSccNodeDecomposition class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalSccNodeDecomposition class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MalSccNodeDecomposition class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MalSccNodeDecomposition class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MalSccNodeDecomposition class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MalSccNodeDecomposition class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MalSccNodeDecomposition class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MalSccNodeDecomposition class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MalSccNodeDecomposition class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MalSccNodeDecomposition class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MalSccNodeDecomposition class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MalSccNodeDecomposition class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MalSndNode methodsFor: 'accessing' stamp: ''!
visited: anObject
	visited := anObject! !

!MalSndNode methodsFor: 'accessing' stamp: ''!
bfsAncestor: anObject
	bfsAncestor := anObject! !

!MalSndNode methodsFor: 'accessing' stamp: ''!
visited
	^ visited! !

!MalSndNode methodsFor: 'accessing' stamp: ''!
bfsAncestor
	^ bfsAncestor! !

!MalTEdgeNode methodsFor: 'edges' stamp: ''!
previousEdges

	self explicitRequirement! !

!MalTEdgeNode methodsFor: 'edges' stamp: ''!
to: aNode edge: anEdge

	self nextEdges add: anEdge! !

!MalTEdgeNode methodsFor: 'edges' stamp: ''!
from: aNode edge: anEdge

	self previousEdges add: anEdge! !

!MalTEdgeNode methodsFor: 'edges' stamp: ''!
nextEdges

	self explicitRequirement! !

!MalTEdgeNode classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MalTEdgeNode classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MalTEdgeNode classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MalTEdgeNode classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MalTEdgeNode classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MalTEdgeNode classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MalTEdgeNode classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MalTEdgeNode classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MalTEdgeNode classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalTEdgeNode classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MalTEdgeNode classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MalTEdgeNode classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MalTEdgeNode classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MalTEdgeNode classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MalTEdgeNode classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MalTEdgeNode classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MalTEdgeNode classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MalTEdgeNode classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalTEdgeNode classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MalTEdgeNode classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MalTEdgeNode classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MalTEdgeNode classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MalTEdgeNode classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MalTEdgeNode classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MalTEdgeNode classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MalTEdgeNode classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MalTNormalize methodsFor: 'running' stamp: ''!
normalize: aCollectionOfNodes

	| firstNode perm |
	firstNode := aCollectionOfNodes detectMin: [:n| n printString ].
	perm := aCollectionOfNodes copy.
	[ firstNode = perm first ] whileFalse: [
		perm addLast: perm removeFirst ].
	^ perm! !

!MalTNormalize classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MalTNormalize classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MalTNormalize classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MalTNormalize classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MalTNormalize classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MalTNormalize classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MalTNormalize classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MalTNormalize classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MalTNormalize classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalTNormalize classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MalTNormalize classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MalTNormalize classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MalTNormalize classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MalTNormalize classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MalTNormalize classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MalTNormalize classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MalTNormalize classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MalTNormalize classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalTNormalize classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MalTNormalize classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MalTNormalize classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MalTNormalize classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MalTNormalize classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MalTNormalize classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MalTNormalize classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MalTNormalize classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MalTarjan commentStamp: ''!
I implement the well known Tarjan's algorithm. My purpose is to find the strongly connected components (aka circuits /cycles) of a graph in O(m+n).
See https://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm for more details.!
!MalTarjan methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	nodes := Dictionary new! !

!MalTarjan methodsFor: 'accessing' stamp: ''!
nodes
	^ nodes values! !

!MalTarjan methodsFor: 'configuration' stamp: ''!
nodeClass
	^ MalTarjanNode! !

!MalTarjan methodsFor: 'accessing' stamp: ''!
stronglyConnectedComponents
	^ sccs ifNil: [ self run ]! !

!MalTarjan methodsFor: 'running' stamp: ''!
putOnStack: aTarjanNode
	stack push: aTarjanNode.
	aTarjanNode inStack: true. "I use a flag to avoid stack access"! !

!MalTarjan methodsFor: 'running' stamp: ''!
popStackAndUpdateCurrentScc: aComponent until: aTarjanNode
	| currentNode |
	[ currentNode := stack pop.
	currentNode popped.
	aComponent add: currentNode ] 
		doWhileFalse: [ currentNode = aTarjanNode ].
	sccs add: aComponent.
	aComponent do: [ :each | each cycleNodes: aComponent ]! !

!MalTarjan methodsFor: 'accessing' stamp: ''!
circuits
	^ self stronglyConnectedComponents
		select: [ :each | each size > 1 ]! !

!MalTarjan methodsFor: 'testing' stamp: ''!
isRootNode: aTarjanNode
	^ aTarjanNode tarjanIndex = aTarjanNode tarjanLowlink! !

!MalTarjan methodsFor: 'building - graph' stamp: ''!
nodes: aCollection
	aCollection do: [ :model |
		nodes at: model put: (self nodeClass with: model)
	]! !

!MalTarjan methodsFor: 'running' stamp: ''!
traverse: aTarjanNode
	| component |
	aTarjanNode tarjanIndex: runningIndex.
	aTarjanNode tarjanLowlink: runningIndex.
	runningIndex := runningIndex + 1.
	self putOnStack: aTarjanNode.
	self traverseChildrenOf: aTarjanNode.
	(self isRootNode: aTarjanNode)
		ifFalse: [ ^ self ].
	component := OrderedCollection new.	"start new SCC"
	self popStackAndUpdateCurrentScc: component until: aTarjanNode! !

!MalTarjan methodsFor: 'accessing' stamp: ''!
findNode: aModel ifAbsent: aBlock
	^ nodes 
		at: aModel
		ifAbsent: aBlock! !

!MalTarjan methodsFor: 'running' stamp: ''!
run
	sccs := OrderedCollection new.
	stack := Stack new.
	runningIndex := 0.
	self nodes
		do: [ :n | 
			n isTarjanUndefined
				ifTrue: [ self traverse: n ] ].
	^ sccs! !

!MalTarjan methodsFor: 'running' stamp: ''!
traverseChildrenOf: aTarjanNode
	aTarjanNode nextNodes
		do: [ :next | 
			next isTarjanUndefined
				ifTrue: [ self traverse: next.
							aTarjanNode tarjanLowlink: (aTarjanNode tarjanLowlink min: next tarjanLowlink) ]
				ifFalse: [ next inStack
								ifTrue: [ aTarjanNode tarjanLowlink: (aTarjanNode tarjanLowlink min: next tarjanIndex) ] ] ]! !

!MalTarjan methodsFor: 'setting' stamp: ''!
nodesAndNextFrom: aNodeList
	aNodeList 
		do: [ :node | 
				nodes 
					at: node model
					put: (self nodeClass with: node model) ].
	aNodeList 
		do: [ :node |
			node nextNodes 
				do: [ :each |
						(self findNode: node model) 
							to: (self findNode: each model) ] ]! !

!MalTarjanNode commentStamp: ''!
Node type used by the MalTarjan algorithm.
Edges are not representated as full objects. We just keep a list of next nodes (following described directed edges).!
!MalTarjanNode methodsFor: 'setting' stamp: ''!
cycleNodes: anObject
	cycleNodes := anObject copy
		remove: self ;
		yourself! !

!MalTarjanNode methodsFor: 'setting' stamp: ''!
tarjanLowlink: anInteger
	lowlink := anInteger! !

!MalTarjanNode methodsFor: 'setting' stamp: ''!
tarjanIndex: anInteger
	index := anInteger! !

!MalTarjanNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	nextNodes := Set new.
	index := -1.
	inStack := false! !

!MalTarjanNode methodsFor: 'accessing' stamp: ''!
tarjanLowlink
	^ lowlink! !

!MalTarjanNode methodsFor: 'setting' stamp: ''!
inStack: anObject
	inStack := anObject! !

!MalTarjanNode methodsFor: 'accessing' stamp: ''!
cycleNodes
	^ cycleNodes! !

!MalTarjanNode methodsFor: 'accessing' stamp: ''!
inStack
	^ inStack! !

!MalTarjanNode methodsFor: 'setting' stamp: ''!
popped
	self inStack: false! !

!MalTarjanNode methodsFor: 'testing' stamp: ''!
isInCycle
	^ self cycleNodes isNotEmpty! !

!MalTarjanNode methodsFor: 'testing' stamp: ''!
isTarjanUndefined
	^ index = -1! !

!MalTarjanNode methodsFor: 'accessing' stamp: ''!
label
	^ 'T '! !

!MalTarjanNode methodsFor: 'accessing' stamp: ''!
tarjanIndex
	^ index! !

!MalTarjanTest methodsFor: 'tests' stamp: ''!
testCycle
	| a b c cycleNodesOfA |
	MalGraphFixture cycleGraph: tarjan.
	tarjan run.
	a := tarjan findNode: $a.
	b := tarjan findNode: $b.
	c := tarjan findNode: $c.
	cycleNodesOfA := Set with: b with: c.
	self assert: a isInCycle.
	self assert: b isInCycle.
	self assert: c isInCycle.
	self deny: (tarjan findNode: $d) isInCycle.
	self assert: (a cycleNodes includesAll: cycleNodesOfA).
	self assert: (cycleNodesOfA includesAll: a cycleNodes)! !

!MalTarjanTest methodsFor: 'tests' stamp: ''!
testNestedCycle
	| a b c cycleNodesOfC d f e g h cycleNodesOfI i |
	MalGraphFixture nestedCycleGraph: tarjan.
	tarjan run.
	a := tarjan findNode: $a.
	b := tarjan findNode: $b.
	c := tarjan findNode: $c.
	d := tarjan findNode: $d.
	e := tarjan findNode: $e.
	f := tarjan findNode: $f.
	g := tarjan findNode: $g.
	h := tarjan findNode: $h.
	i := tarjan findNode: $i.
	cycleNodesOfC := Set
		with: a
		with: b
		with: d
		with: e.
	cycleNodesOfI := Set with: f with: g with: h.
	tarjan nodes do: [ :n | self assert: n isInCycle ].
	self assert: (c cycleNodes includesAll: cycleNodesOfC).
	self assert: (cycleNodesOfC includesAll: c cycleNodes).
	self assert: (i cycleNodes includesAll: cycleNodesOfI).
	self assert: (cycleNodesOfI includesAll: i cycleNodes)! !

!MalTarjanTest methodsFor: 'tests' stamp: ''!
testNoCycle
	MalGraphFixture simpleGraph: tarjan.
	tarjan run.
	tarjan nodes do: [ :n | self deny: n isInCycle ]! !

!MalTarjanTest methodsFor: 'tests' stamp: ''!
testComplexCycle2
	| circuits |
	MalGraphFixture complexCycleGraph2: tarjan.
	circuits := tarjan
		run;
		circuits.
	#($a $c $g $h $i) do: [ :each | self deny: (tarjan findNode: each) isInCycle ].
	self assert: circuits size equals: 1.
	self assert: ((circuits first collect: [:each | each model]) includesAll: #($b $d $e $f))! !

!MalTarjanTest methodsFor: 'tests' stamp: ''!
testComplexCycle
	| a b c cycleNodesOfC d f e g h |
	MalGraphFixture complexCycleGraph: tarjan.
	tarjan run.
	a := tarjan findNode: $a.
	b := tarjan findNode: $b.
	c := tarjan findNode: $c.
	d := tarjan findNode: $d.
	e := tarjan findNode: $e.
	f := tarjan findNode: $f.
	g := tarjan findNode: $g.
	h := tarjan findNode: $h.
	cycleNodesOfC := Set with: d with: f.
	self deny: a isInCycle.
	self deny: b isInCycle.
	self assert: c isInCycle.
	self assert: d isInCycle.
	self assert: f isInCycle.
	self deny: e isInCycle.
	self assert: g isInCycle.
	self assert: h isInCycle.
	self assert: (c cycleNodes includesAll: cycleNodesOfC).
	self assert: (cycleNodesOfC includesAll: c cycleNodes).
	self assert: (g cycleNodes hasEqualElements: (Array with: h)).
	self assert: (h cycleNodes hasEqualElements: (Array with: g))! !

!MalTarjanTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	tarjan := MalTarjan new! !

!MalTopologicalSorting commentStamp: ''!
From wikipedia:
A topological sort (sometimes abbreviated topsort or toposort) or topological ordering of a directed graph is a linear ordering of its vertices such that for every directed edge uv from vertex u to vertex v, u comes before v in the ordering. For instance, the vertices of the graph may represent tasks to be performed, and the edges may represent constraints that one task must be performed before another; in this application, a topological ordering is just a valid sequence for the tasks. A topological ordering is possible if and only if the graph has no directed cycles, that is, if it is a directed acyclic graph (DAG). Any DAG has at least one topological ordering, and algorithms are known for constructing a topological ordering of any DAG in linear time.!
!MalTopologicalSorting methodsFor: 'private' stamp: ''!
computeVerticesWithNoIncomingEdge
	verticesWithNoIncomingEdge := nodes select: [ :node | node previousNodes isEmpty ]! !

!MalTopologicalSorting methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	sortedElements := OrderedCollection new! !

!MalTopologicalSorting methodsFor: 'private' stamp: ''!
removeVerticeWithNoIncomingEdge
	| vertice |
	
	vertice := verticesWithNoIncomingEdge anyOne.
	verticesWithNoIncomingEdge remove: vertice.
	^ vertice! !

!MalTopologicalSorting methodsFor: 'configuration' stamp: ''!
nodeClass
	^ MalNodeWithPreviousAndNext! !

!MalTopologicalSorting methodsFor: 'private' stamp: ''!
removeEdgesOf: aNode
	aNode nextNodes 
		do: [ :node |
				node previousNodes remove: aNode.
				node previousNodes 
					ifEmpty: [ verticesWithNoIncomingEdge add: node ] ].
	aNode nextNodes: #().! !

!MalTopologicalSorting methodsFor: 'private' stamp: ''!
graphHasEdges
	^ (nodes allSatisfy: [ :node | node nextNodes isEmpty ]) not! !

!MalTopologicalSorting methodsFor: 'running' stamp: ''!
run
	self computeVerticesWithNoIncomingEdge.
	[ verticesWithNoIncomingEdge isEmpty ]
		whileFalse: [ | node |
			node := self removeVerticeWithNoIncomingEdge.
			sortedElements addLast: node.
			self removeEdgesOf: node ].
	self graphHasEdges
		ifTrue: [ Error signal: 'Not a DAG (Directed Acyclic Graph)' ].
	^ sortedElements reverse! !

!MalTopologicalSortingTest commentStamp: ''!
A MalTopologicalSortingTest is a test class for testing the behavior of MalTopologicalSorting!
!MalTopologicalSortingTest methodsFor: 'tests' stamp: ''!
testSortWithCycle
	MalGraphFixture cycleGraph: sorter.
	self should: [ sorter run ] raise: Error! !

!MalTopologicalSortingTest methodsFor: 'tests' stamp: ''!
testSortWithReducedGraph

	| graphReducer result |
	graphReducer := MalGraphReducer new.
	MalGraphFixture complexCycleGraph2: graphReducer.
	sorter privateNodes: graphReducer run.
	result := sorter run collect: [:each | each model].

	self assert: (result at: 1) equals: $h.
	self assertCollection: (result at: 2) hasSameElements: #($e $f $d $b).
	self assert: (result at: 3) equals: $i.
	self assert: (result at: 4) equals: $a.
	self assert: (result at: 5) equals: $g.
	self assert: (result at: 6) equals: $c! !

!MalTopologicalSortingTest methodsFor: 'tests' stamp: ''!
testSortWithoutCyclesComplexGraph
	MalGraphFixture withoutCyclesComplexGraph: sorter.
	self
		assertCollection: (sorter run collect: [ :item | item model ] as: Array)
		equals: #($s $r $i $f $p $n $m $d $q $o $l $k $h $c $g $e $j $b $a)! !

!MalTopologicalSortingTest methodsFor: 'tests' stamp: ''!
testSortStringHierarchy
	| result |
	sorter addNodesFrom: String childrenBlock: [ :class | class subclasses ].

	result := sorter run collect: [ :item | item model ] as: Array.

	self assertCollection: (result first: 2) hasSameElements: {WideSymbol . ByteSymbol}.
	self assertCollection: (result copyFrom: 3 to: 5) hasSameElements: {Symbol . WideString . ByteString}.
	self assert: result last equals: String! !

!MalTopologicalSortingTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	sorter := MalTopologicalSorting new! !

!MalWeightedEdge commentStamp: ''!
I represent a weighted edge in a graph. 

Public API and Key Messages
- weight
 
Instance Variables
	weight: <Number>!
!MalWeightedEdge methodsFor: 'printing' stamp: ''!
printOn: aStream
	self from printOn: aStream.
	aStream nextPutAll: ' -> '.
	self to printOn: aStream.
	aStream nextPutAll: ' ('.
	self weight printOn: aStream.
	aStream nextPut: $).! !

!MalWeightedEdge methodsFor: 'accessing' stamp: ''!
weight: anObject
	weight := anObject! !

!MalWeightedEdge methodsFor: 'accessing' stamp: ''!
weight
	^ weight! !

!MalWeightedEdge methodsFor: 'accessing' stamp: ''!
asTuple

	^ {from model. to model. weight}! !

!MalWeightedEdgeTest methodsFor: 'tests' stamp: ''!
testPrintString
	|edge|
	edge := MalWeightedEdge with: 'model' from: 'from' to: 'to'.
	edge weight: 7.
	self assert: edge printString equals: '''from'' -> ''to'' (7)'.! !

!MalWeightedHits methodsFor: 'configuration' stamp: ''!
edgeClass

	^ MalWeightedEdge! !

!MalWeightedHits methodsFor: 'running' stamp: ''!
computeHubsFor: aNode

	aNode hub: (aNode nextEdges inject: 0 into: [:s :e| s + (e weight * e to auth)])! !

!MalWeightedHits methodsFor: 'configuration' stamp: ''!
nodeClass

	^ MalWeightedHitsNode! !

!MalWeightedHits methodsFor: 'running' stamp: ''!
computeAuthoritiesFor: aNode

	aNode auth: (aNode previousEdges inject: 0 into: [:s :e| s + (e weight * e from hub)])! !

!MalWeightedHitsNode methodsFor: 'accessing' stamp: ''!
previousEdges

	^ previousEdges! !

!MalWeightedHitsNode methodsFor: 'edges' stamp: ''!
to: aNode edge: anEdge

	self nextEdges add: anEdge! !

!MalWeightedHitsNode methodsFor: 'edges' stamp: ''!
from: aNode edge: anEdge

	self previousEdges add: anEdge! !

!MalWeightedHitsNode methodsFor: 'accessing' stamp: ''!
nextEdges

	^ nextEdges! !

!MalWeightedHitsNode methodsFor: 'accessing' stamp: ''!
label

	^ 'WH '! !

!MalWeightedHitsNode class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MalWeightedHitsNode class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MalWeightedHitsNode class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MalWeightedHitsNode class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MalWeightedHitsNode class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MalWeightedHitsNode class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MalWeightedHitsNode class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MalWeightedHitsNode class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MalWeightedHitsNode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalWeightedHitsNode class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MalWeightedHitsNode class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MalWeightedHitsNode class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MalWeightedHitsNode class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MalWeightedHitsNode class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MalWeightedHitsNode class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MalWeightedHitsNode class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MalWeightedHitsNode class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MalWeightedHitsNode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MalWeightedHitsNode class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MalWeightedHitsNode class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MalWeightedHitsNode class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MalWeightedHitsNode class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MalWeightedHitsNode class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MalWeightedHitsNode class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MalWeightedHitsNode class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MalWeightedHitsNode class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MalWeightedHitsNode class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MalWeightedHitsNode class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MalWeightedHitsNode class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ManifestASTCore commentStamp: ''!
Manifest for AST-Core package!
!ManifestASTCore class methodsFor: 'meta data' stamp: ''!
rejectRules
^ #('LawOfDemeterRule')! !

!ManifestASTCore class methodsFor: 'meta data' stamp: ''!
ruleEquivalentSuperclassMethodsRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#RBProgramNode #isBlock #false)) #'2013-03-29T18:06:26.929+01:00') )! !

!ManifestASTCore class methodsFor: 'meta data' stamp: ''!
ruleRefersToClassRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#'RBLiteralNode class' #literalToken: #true)) #'2013-03-29T18:06:27.069+01:00') )! !

!ManifestASTCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Abstract')! !

!ManifestASTCore class methodsFor: 'meta data' stamp: ''!
ruleLongMethodsRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#RBParser #parseBlockArgsInto: #false)) #'2013-03-29T18:06:27.028000001+01:00') #(#(#RGMethodDefinition #(#RBParser #patchLiteralArrayToken #false)) #'2013-03-29T18:06:27.030000002+01:00') #(#(#RGMethodDefinition #(#RBConfigurableFormatter #needsParenthesisFor: #false)) #'2013-03-29T18:06:27.030000009+01:00') #(#(#RGMethodDefinition #(#RBParser #parsePrimitiveObject #false)) #'2013-03-29T18:06:27.028000002+01:00') #(#(#RGMethodDefinition #(#RBFormatter #needsParenthesisFor: #false)) #'2013-03-29T18:06:27.028+01:00') #(#(#RGMethodDefinition #(#RBFormatter #formatMessage:cascade: #false)) #'2013-03-29T18:06:27.03+01:00') #(#(#RGMethodDefinition #(#'RBConfigurableFormatter class' #initialize #true)) #'2013-03-29T18:06:27.030000001+01:00') #(#(#RGMethodDefinition #(#RBParseTreeRewriter #visitCascadeNode: #false)) #'2013-03-29T18:06:27.030000004+01:00') #(#(#RGMethodDefinition #(#'RBConfigurableFormatter class' #settingsOn: #true)) #'2013-03-29T18:06:27.030000006+01:00') #(#(#RGMethodDefinition #(#RBProgramNode #matchList:index:against:index:inContext: #false)) #'2013-03-29T18:06:27.030000008+01:00') #(#(#RGMethodDefinition #(#RBMessageNode #replaceSourceWithMessageNode: #false)) #'2013-03-29T18:06:27.030000003+01:00') #(#(#RGMethodDefinition #(#RBParser #parseCascadeMessage #false)) #'2013-03-29T18:06:27.030000007+01:00') )! !

!ManifestASTCore class methodsFor: 'meta data' stamp: ''!
ruleSendsDifferentSuperRuleV1TODO
^ #(#(#(#RGMethodDefinition #(#RBMessageNode #replaceSourceWithMessageNode: #false)) #'2013-03-29T18:06:27.369+01:00') )! !

!ManifestASTCoreTests commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestASTCoreTests class methodsFor: 'code-critics' stamp: ''!
ruleGRTemporaryNeitherReadNorWrittenRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#ASTEvaluationTest #testEvaluateForContext #false)) #'2019-07-05T11:16:20.959329+02:00') )! !

!ManifestAnnouncementsCore commentStamp: ''!
A package with classes for the announcement framwork - an event notification framework.!
!ManifestAnnouncementsCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Abstract')! !

!ManifestAthensBalloon commentStamp: ''!
Please describe the package using the class comment of the included manifest class. The manifest class also includes other additional metadata for the package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestAthensBalloon class methodsFor: 'code-critics' stamp: ''!
ruleUnaryAccessingMethodWithoutReturnRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#AthensBalloonImagePaint #repeat #false)) #'2021-06-21T23:01:31.97848+02:00') )! !

!ManifestBaselineOfAthens commentStamp: ''!
I manage the loading of Athens project for the Pharo bootstrap.!
!ManifestBaselineOfEnlumineurFormatter commentStamp: ''!
This package is a prettyprinter or formatter for Pharo. It embellishes our code with love. 

Enlumineur in french, illuminator in english,  is the name of people in middleage and after that puts gold on nice books and worked on lettrines. 

in english: "a person who paints manuscripts, books, etc., with designs in color, gold, or the like."

For the record: 
"Enlumineur: Personne, le plus souvent un scribe ou un copiste du Moyen Âge, qui conçoit les enluminures."
"enluminures: Ornements en couleur, tels que fleurons, vignettes, lettres ornées, sujets à personnages, qui décorent les manuscrits du Moyen Âge."!
!ManifestBaselineOfMicrodown commentStamp: ''!
The Microdown project is a parser and document model for Microdown a clean and lean Markdown. 
See `#'Microdown'`!
!ManifestBeaconCore commentStamp: ''!
Please describe the package using the class comment of the included manifest class. The manifest class also includes other additional metadata for the package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestBeaconCore class methodsFor: 'code-critics' stamp: ''!
ruleClassNotReferencedRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#TranscriptLogger)) #'2021-10-27T17:54:25.753664+00:00') #(#(#RGClassDefinition #(#CircularMemoryLogger)) #'2021-10-27T17:54:55.481727+00:00') )! !

!ManifestBeaconCore class methodsFor: 'code-critics' stamp: ''!
ruleRefersToClassRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'SignalLogger class' #startSingleGlobalLogger #true)) #'2021-10-27T17:42:20.023221+00:00') )! !

!ManifestBeaconCore class methodsFor: 'code-critics' stamp: ''!
ruleBadMessageRule2V1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#Beacon #loggersOf: #false)) #'2021-10-27T17:36:35.297975+00:00') )! !

!ManifestBeaconCore class methodsFor: 'code-critics' stamp: ''!
ruleCodeCruftLeftInMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#TranscriptLogger #nextPut: #false)) #'2021-10-27T17:50:25.160819+00:00') )! !

!ManifestBeaconCoreTests commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestBeaconCoreTests class methodsFor: 'code-critics' stamp: ''!
ruleRBBadMessageRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#WrapperSignalTest #testAsBeaconSignalTransformsIntoWrapperSignal #false)) #'2019-09-16T11:41:03.590505+02:00') )! !

!ManifestCalypsoSystemPluginsSUnitBrowser commentStamp: ''!
I am a plugin for Calypso browser.

I add tools and commands to Calypso related to SUnit.

For example I add commands to run tests or commands to generate and jump to tests.!
!ManifestCalypsoSystemPluginsSUnitBrowser class methodsFor: 'code-critics' stamp: ''!
ruleRBTempsReadBeforeWrittenRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#TClyGenerateTestClass #testClassFor: #false)) #'2018-11-12T15:00:23.227476+01:00') )! !

!ManifestClapCore commentStamp: ''!
Clap is a parser for command-line arguments.

The general process in Clap has three steps:

1. We start from a static specification of a command, its parameters, and their behavior.

   The command specification is recursively composed from instances of ClapCommand (a named command or sub-command with flags and positional parameters), ClapFlag (a keyword representing an option or naming a parameter) and ClapPositional (a value passed in sequence).

2. At invocation time, we build a context to match the specification against an actual sequence of arguments coming from the shell.

3. The resulting context is an activation of the command, which can be evaluated.
 
   The activation is a structured record of the parameters that matched the invocation and how; at its root, the context provides access to external resources such as the standard I/O streams.
!
!ManifestCodeExport commentStamp: ''!
Package manifest for package metadata!
!ManifestCodeExport class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Slot-Core' #'Collections-Abstract')! !

!ManifestCodeExportTraits commentStamp: ''!
Package includes trait extensions useful for export of code!
!ManifestCodeImport commentStamp: ''!
Package manifest for package metadata!
!ManifestCodeImport class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'RPackage-Core' #'Collections-Abstract')! !

!ManifestCodeImportCommandLineHandlers commentStamp: ''!
A package containing command line handlers to import code.!
!ManifestCodeImportCommandLineHandlers class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#UIManager #'Collections-Abstract' #'System-Support')! !

!ManifestCollectionsAbstract commentStamp: ''!
Package manifest for package metadata!
!ManifestCollectionsAbstract class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'Regex-Core' #'Collections-Strings' #'Collections-Streams' #'Collections-Support' #'Collections-Unordered' #Kernel #'Collections-Sequenceable' #'Collections-Native')! !

!ManifestCollectionsAbstract class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Collections-Abstract'! !

!ManifestCollectionsAbstractTraits commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestCollectionsAbstractTraits class methodsFor: 'code-critics' stamp: ''!
ruleExcessiveArgumentsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#TSortable #mergeFirst:middle:last:into:by: #false)) #'2020-06-26T09:33:14.853351+02:00') #(#(#RGMethodDefinition #(#TSortable #mergeSortFrom:to:src:dst:by: #false)) #'2020-06-26T09:33:26.566053+02:00') )! !

!ManifestCollectionsArithmetic commentStamp: ''!
This package only makes extensions to existing collection classes by adding the arithmetic protocols. 
Such protocols allow one to perform in particular vector-operations on collection!
!ManifestCollectionsArithmetic class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Collections-Arithmetic'! !

!ManifestCollectionsArithmetic class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'Collections-Native' #'Collections-Unordered' #'Collections-Sequenceable' #Kernel #'Collections-Abstract')! !

!ManifestCollectionsAtomic commentStamp: ''!
Package for thread-safe collections with atomic operations!
!ManifestCollectionsAtomic class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Collections-Atomic'! !

!ManifestCollectionsAtomic class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#Kernel)! !

!ManifestCollectionsAtomic class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams')! !

!ManifestCollectionsDoubleLinkedList commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestCollectionsDoubleLinkedList class methodsFor: 'code-critics' stamp: ''!
ruleCollectionProtocolRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#DoubleLinkedList #addAll: #false)) #'2020-11-13T21:03:12.373876+01:00') #(#(#RGMethodDefinition #(#DoubleLinkedList #collect: #false)) #'2020-11-13T21:03:27.372294+01:00') )! !

!ManifestCollectionsDoubleLinkedListTests commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestCollectionsDoubleLinkedListTests class methodsFor: 'code-critics' stamp: ''!
ruleReUsesAddRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#DoubleLinkedListTest)) #'2020-03-27T12:31:42.565385+01:00') )! !

!ManifestCollectionsDoubleLinkedListTests class methodsFor: 'code-critics' stamp: ''!
ruleUsesAddRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#DoubleLinkedListTest)) #'2020-06-12T14:46:39.462891+02:00') )! !

!ManifestCollectionsNative commentStamp: ''!
Arrays of native types: byte, word, float and integer!
!ManifestCollectionsNative class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'Collections-Abstract' #Kernel #'Collections-Strings')! !

!ManifestCollectionsNative class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams')! !

!ManifestCollectionsNative class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Collections-Native'! !

!ManifestCollectionsSequenceable commentStamp: ''!
Sequenceable collections: arrays, intervals, ordered collections and dictionaries, etc.!
!ManifestCollectionsSequenceable class methodsFor: 'meta-data' stamp: 'nil'!
dependencies
	^ #(#'Collections-Strings' #'Collections-Streams' #'Collections-Unordered' #Kernel #'Collections-Abstract')! !

!ManifestCollectionsSequenceable class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#'Collections-Support' #'System-Support')! !

!ManifestCollectionsSequenceable class methodsFor: 'meta-data' stamp: 'nil'!
packageName
	^ #'Collections-Sequenceable'! !

!ManifestCollectionsStack commentStamp: ''!
I only contain a Stack implementation.!
!ManifestCollectionsStack class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'Collections-Sequenceable')! !

!ManifestCollectionsStack class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Collections-Stack'! !

!ManifestCollectionsStreams commentStamp: ''!
All Stream hierarchy: read/write stream!
!ManifestCollectionsStreams class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'Collections-Strings' #'Collections-Support' #'Collections-Sequenceable' #Kernel #'Collections-Native')! !

!ManifestCollectionsStreams class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#UIManager #'Collections-Abstract')! !

!ManifestCollectionsStreams class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Collections-Streams'! !

!ManifestCollectionsStrings commentStamp: ''!
Contains String, ByteString, Symbol, ByteSymbol, WideSymbol and WideString!
!ManifestCollectionsStrings class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'Collections-Streams' #'Collections-Weak' #'Collections-Native' #'Collections-Support' #Kernel #'Collections-Sequenceable' #'Multilingual-Encodings' #'Collections-Abstract')! !

!ManifestCollectionsStrings class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'System-Support' )! !

!ManifestCollectionsStrings class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Collections-Strings'! !

!ManifestCollectionsSupport commentStamp: ''!
Some basic classes used in collections: `Link`, `Association`, `Weak*`, `CharacterSet`, `SetElement`, etc.

###Character Sets
There are a number of options for holding sets of characters:
`Set`, `CharacterSet` and `WideCharacterSet` can all be used where the set is empty by default and characters are explicitly added.
`CharacterSetComplement` is used where all characters are in the set by default and characters are explicitly excluded.
!
!ManifestCollectionsSupport class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'Collections-Strings' #'Collections-Native' #'Collections-Unordered' #Kernel #'Collections-Abstract')! !

!ManifestCollectionsSupport class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams')! !

!ManifestCollectionsSupport class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Collections-Support'! !

!ManifestCollectionsTests commentStamp: ''!
I contain tests for collections!
!ManifestCollectionsTests class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'Collections-Streams' #'System-Finalization' #'Collections-Native' #'Collections-Abstract' #'Collections-Weak' #'Collections-Stack' #'Collections-Strings' #'Collections-Sequenceable' #'SUnit-Core' #Kernel #'Graphics-Primitives' #'Collections-Support' #'Collections-Unordered' #'System-Support' #'Collections-Atomic' #'Multilingual-Encodings')! !

!ManifestCollectionsTests class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Math-Operations-Extensions')! !

!ManifestCollectionsTests class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #CollectionsTests! !

!ManifestCollectionsUnordered commentStamp: ''!
I contain collections that do not care about the order of the elements they contain.
Main classes: Bag, Dictionary, Matrix, Set!
!ManifestCollectionsUnordered class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'Collections-Strings' #'Collections-Support' #Kernel #'Collections-Sequenceable' #'Collections-Abstract')! !

!ManifestCollectionsUnordered class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'Math-Operations-Extensions' #'System-Support')! !

!ManifestCollectionsUnordered class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Collections-Unordered'! !

!ManifestCollectionsWeak commentStamp: ''!
All weak collections!
!ManifestCollectionsWeak class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'System-Finalization' #'Collections-Support' #'Collections-Sequenceable' #'Collections-Unordered' #'Collections-Abstract' #Kernel)! !

!ManifestCollectionsWeak class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'System-Support' #'Collections-Streams')! !

!ManifestCollectionsWeak class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Collections-Weak'! !

!ManifestColors commentStamp: ''!
Support for colors and color maps!
!ManifestColors class methodsFor: 'code-critics' stamp: ''!
ruleClassNameInSelectorRuleV1FalsePositive
	^ #(#(#(#RGMetaclassDefinition #(#'Color class' #Color)) #'2021-10-04T22:19:47.752887+02:00') )! !

!ManifestColors class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams')! !

!ManifestCompression commentStamp: ''!
Package for compression utilities like ZIP and other!
!ManifestCompression class methodsFor: 'code-critics' stamp: 'nil'!
ruleClassNameInSelectorRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'ZipArchive class' #isZipArchive: #true)) #'2020-04-30T09:18:38.202597+02:00') )! !

!ManifestCompression class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#Jobs #'System-Support' #'System-Changes' #'Collections-Abstract')! !

!ManifestDebuggerActions commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestDeprecated10 commentStamp: ''!
I contain the deprecated code of Pharo 10. I'll be removed in Pharo 11.!
!ManifestDeprecated10 class methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!ManifestDeprecated90 commentStamp: ''!
I contain the deprecated code of Pharo 9. I'll be removed in Pharo 10.!
!ManifestDeprecated90 class methodsFor: 'testing' stamp: ''!
isDeprecated
	^ true! !

!ManifestEmergencyDebugger commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestEmergencyDebugger class methodsFor: 'code-critics' stamp: ''!
ruleReToDoRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#EDEmergencyDebugger #composeStackText #false)) #'2020-04-10T12:25:37.258447+02:00') )! !

!ManifestEpiceaTests commentStamp: ''!
Please describe the package using the class comment of the included manifest class. The manifest class also includes other additional metadata for the package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestEpiceaTests class methodsFor: 'code-critics' stamp: ''!
ruleEmptyExceptionHandlerRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#EpDisabledIntegrationTest #testDisableDuringWithInterruption #false)) #'2021-11-27T00:09:09.223669+01:00') )! !

!ManifestFileSystemCore commentStamp: ''!
This package contains the core of Pharo's FileSystem manager. 

It offers an expressive and elegant object-oriented design. 

A documentation of this library is available in the Deep Into Pharo book, «Chapter 3: Files with FileSystem».!
!ManifestFileSystemCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'System-Support' #'System-Platforms' #'Zinc-Character-Encoding-Core' #'AST-Core' #'System-Settings-Core' #'FileSystem-Disk')! !

!ManifestFileSystemDisk commentStamp: ''!
This package contains the disk management of Pharo's FileSystem manager. 

Its responsibility is to provid a common API for the different OS's disks. 

A documentation of this library is available in the Deep Into Pharo book, «Chapter 3: Files with FileSystem».!
!ManifestFileSystemDisk class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Abstract' #'Collections-Strings' #'System-Support')! !

!ManifestFileSystemMemory commentStamp: ''!
This package contains a memory file system part of Pharo's FileSystem manager. 

It allow to emulate a file system directly into the memory of the computer. This memory file system can be used during tests for two reasons:
- To avoid to write temporary files (it will also help when Pharo is stored in a read only environment)
- To speed up the tests executions

A documentation of this library is available in the Deep Into Pharo book, «Chapter 3: Files with FileSystem».!
!ManifestFileSystemPath commentStamp: ''!
This package contains the path management of Pharo's FileSystem manager. 

It is responsible for the modelisation of absolute and relative paths in the file system.

A documentation of this library is available in the Deep Into Pharo book, «Chapter 3: Files with FileSystem».!
!ManifestFileSystemPath class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'Collections-Abstract')! !

!ManifestFileSystemTestsCore commentStamp: ''!
This package contains the core tests of Pharo's FileSystem manager. 

A documentation of this library is available in the Deep Into Pharo book, «Chapter 3: Files with FileSystem».!
!ManifestFileSystemTestsDisk commentStamp: ''!
This package contains the disk tests of Pharo's FileSystem manager.

A documentation of this library is available in the Deep Into Pharo book, «Chapter 3: Files with FileSystem».!
!ManifestFileSystemTestsDisk class methodsFor: 'code-critics' stamp: ''!
ruleAssertEqualSignIntoAssertEqualsV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#DiskFileSystemTest #testEqual #false)) #'2019-03-29T13:41:22.736554+01:00') )! !

!ManifestFileSystemTestsMemory commentStamp: ''!
This package contains the memory tests of Pharo's FileSystem manager. 

A documentation of this library is available in the Deep Into Pharo book, «Chapter 3: Files with FileSystem».!
!ManifestFileSystemZip commentStamp: ''!
This package contains the zip implementation of Pharo's FileSystem manager. 

It make it possible to look over zip archives.

A documentation of this library is available in the Deep Into Pharo book, «Chapter 3: Files with FileSystem».!
!ManifestFiles commentStamp: ''!
Includes file and directory handling as well as file streams!
!ManifestFiles class methodsFor: 'code-critics' stamp: 'nil'!
ruleRBClassNameInSelectorRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'File class' #deleteFile: #true)) #'2018-05-14T09:42:47.857795-07:00') )! !

!ManifestFiles class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#'System-Support' #'Zinc-Character-Encoding-Core' #'FileSystem-Core' #'Collections-Abstract' #'System-Platforms')! !

!ManifestFlashbackDecompiler commentStamp: ''!
Flashback is a Decompiler for Pharo code.

My job is to decompile a compiledMethod to get valid Abstract Syntax Tree (AST).!
!ManifestFlashbackDecompilerTests commentStamp: ''!
Includes unit tests for Flashback - a Decomplier for Pharo code!
!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleAssignmentInIfTrueRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FBDExamples #exampleIfFalseIfTrue2 #false)) #'2020-10-23T22:09:15.457352+02:00') )! !

!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleGuardingClauseRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FBDExamples #exampleIfTrueForEffectNested #false)) #'2020-10-23T22:11:42.525199+02:00') )! !

!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleBadMessageRule2V1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FBDExamples #exampleCaseOf #false)) #'2020-10-23T22:05:42.169628+02:00') #(#(#RGMethodDefinition #(#FBDExamples #exampleCaseOf2 #false)) #'2020-10-23T22:05:56.503687+02:00') #(#(#RGMethodDefinition #(#FBDExamples #exampleCaseOf3 #false)) #'2020-10-23T22:06:12.663971+02:00') #(#(#RGMethodDefinition #(#FBDExamples #exampleCaseOf4 #false)) #'2020-10-23T22:06:37.803427+02:00') #(#(#RGMethodDefinition #(#FBDExamples #exampleCaseOf5 #false)) #'2020-10-23T22:06:52.696106+02:00') #(#(#RGMethodDefinition #(#FBDExamples #exampleCaseOf7 #false)) #'2020-10-23T22:07:20.994769+02:00') #(#(#RGMethodDefinition #(#FBDExamples #exampleCaseOf8 #false)) #'2020-10-23T22:07:27.684839+02:00') #(#(#RGMethodDefinition #(#FBDExamples #exampleCaseOfOtherwise #false)) #'2020-10-23T22:07:55.351219+02:00') )! !

!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleReGuardClauseRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FBDExamples #exampleIfTrueForEffectNested #false)) #'2020-10-23T22:11:39.607515+02:00') )! !

!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleUsesAddRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FBDExamples #exampleCascadeIfTrueIfFalse2 #false)) #'2020-10-23T22:04:02.8472+02:00') )! !

!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleDeadBlockRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FBDExamples #noRemoteReadInBlock #false)) #'2020-10-23T22:26:51.217826+02:00') #(#(#RGMethodDefinition #(#FBDExamples #noRemoteReadNestedBlocks #false)) #'2020-10-23T22:27:11.025787+02:00') #(#(#RGMethodDefinition #(#FBDExamples #singleRemoteReadNestedBlocks #false)) #'2020-10-23T22:28:30.113023+02:00') )! !

!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleMinMaxRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FBDExamples #exampleIfTrueAssign #false)) #'2020-10-23T22:11:22.078885+02:00') )! !

!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleWhileTrueRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FBDExamples #exampleToDo #false)) #'2020-10-23T22:21:15.909488+02:00') #(#(#RGMethodDefinition #(#FBDExamples #exampleWhileTrue #false)) #'2020-10-23T22:23:42.18587+02:00') )! !

!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleReturnsIfTrueRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FBDExamples #exampleIfFalse2 #false)) #'2020-10-23T22:08:49.69856+02:00') #(#(#RGMethodDefinition #(#FBDExamples #exampleIfTrue2 #false)) #'2020-10-23T22:11:05.040374+02:00') #(#(#RGMethodDefinition #(#FBDExamples #exampleSimpleBlockLocalIfNested #false)) #'2020-10-23T22:19:41.855023+02:00') )! !

!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleToDoCollectRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FBDExamples #exampleToDo3 #false)) #'2020-10-23T22:21:30.445095+02:00') )! !

!ManifestFlashbackDecompilerTests class methodsFor: 'code-critics' stamp: ''!
ruleExtraBlockRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#FBDExamples)) #'2020-10-23T22:01:24.485282+02:00') )! !

!ManifestFontsAbstract commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestFontsAbstract class methodsFor: 'code-critics' stamp: ''!
ruleRefersToClassRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'AbstractFont class' #update: #true)) #'2020-10-23T18:10:25.07485+02:00') )! !

!ManifestFormCanvasCore commentStamp: ''!
Provide specific canvas for rendering on Form and interface to the pluggin (BalloonPlugin) that accelerates rendering operations!
!ManifestFuelCore commentStamp: ''!
# Fuel

A general-purpose object serialization framework developed in Pharo. Fuel is developed under the MIT license.
Description

- Concrete
We don't aspire to have a dialect-interchange format. This enables us to serialize special objects like contexts, block closures, exceptions, compiled methods and classes. Although there are ports to other dialects, Fuel development is Pharo-centric.
- Flexible
Depending on the context, there could be multiple ways of serializing the same object. For example, a class can be considered either a global or a regular object. In the former case, it will be encoded just its name; in the latter case, the class will be encoded in detail, with its method dictionary, etc.
- Fast
We worry about to have the best performance. We developed a complete benchmark suite to help analyse the performance with diverse sample sets, as well as compare against other serializers. Our pickling algorithm allows outstanding materialization performance, as well as very good serialization performance too.
- Object-Oriented Design

From the beginning it was a constraint to have a good object-oriented design and to do not need any special support from the VM. In addition, Fuel has a complete test suite, with a high coverage. We also worry about writing comments on classes and methods.
Properties

-Binary format.
-Object-Oriented design.
-No special VM-support needed.
-Modular (clear division in packages).
-Can serialize/materialize not only plain objects but also classes, traits, methods, closures, contexts, packages, etc.
-Support for global references.
-Very customizable: ignore certain instance variables, substitute objects by others, pre and post serialization and materialization actions, etc.
-Supports class rename and class reshape.
-Good test coverage (almost 600 unit tests).
-Large suite of benchmarks.
!
!ManifestFuelCore class methodsFor: 'meta data' stamp: ''!
ruleConsistencyCheckRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#Float #serializeOn: #false)) #'2013-02-25T14:50:01.564000001+01:00') )! !

!ManifestFuelCore class methodsFor: 'meta data' stamp: ''!
ruleIfTrueBlocksRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#FLLightGeneralMapper #visitSubstitution:by:onRecursionDo: #false)) #'2013-02-25T14:50:01.650000001+01:00') )! !

!ManifestGeometryTests commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestGeometryTests class methodsFor: 'code-critics' stamp: ''!
ruleRBStringConcatenationRuleV1FalsePositive
	^ #(#(#(#RGPackage #(#'Geometry-Tests')) #'2018-12-18T15:06:35.385668+01:00') )! !

!ManifestGoferCore commentStamp: ''!
Please describe the package using the class comment of the included manifest class. The manifest class also includes other additional metadata for the package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestGoferCore class methodsFor: 'code-critics' stamp: ''!
ruleCollectionMessagesToExternalObjectRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#GoferChanges #addReference: #false)) #'2021-07-23T19:30:50.698573+02:00') )! !

!ManifestGraphicsDisplayObjects commentStamp: ''!
Package hosting graphics related display objects like Form and other!
!ManifestGraphicsDisplayObjects class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #( #'Collections-Streams')! !

!ManifestGraphicsPrimitives commentStamp: ''!
Primitive graphics support such as support for BitBlt and Bitmaps!
!ManifestGrowl commentStamp: ''!
Growl is a small Morph extension to display notifications on the screen.

Freely inspired from the MIT Snarl developed by Tony Garnock-Jones.!
!ManifestGrowl class methodsFor: 'code-critics' stamp: ''!
ruleRBRefersToClassRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#GrowlMorph #activeGrowlMorphs #false)) #'2018-06-27T18:15:02.892206+02:00') )! !

!ManifestGrowl class methodsFor: 'code-critics' stamp: ''!
ruleRBBadMessageRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#GrowlMorph #activeGrowlMorphs #false)) #'2018-06-27T18:15:09.571924+02:00') )! !

!ManifestHermes commentStamp: ''!
Hermes is a tool to binary serialize/deserialize behavior.
It uses the basic elements in the bootstrapped image, so it can be used to load code in a really small image.

Basically it contains the packages: 

   - Hermes: Core classes and behavior to load the code in the image. This is loaded in the default image. This package is loaded by the bootstrap process, so it should be small.
   - Hermes-Exporter: It has all the behavior to export the classes, traits and methods. This is not loaded in the default image, as  it is only used to export the code. This decition minimizes the footprint of hermes in the bootstrapped image.
   - Hermes-Extensions: This package extends the behavior of the core package. This allows to load extra behavior after the bootstrap image is generated. This is loaded by Hermes it self. 

To Load code check: HEInstaller and HermesCommandLineHandler. 
To Export code check the comments in the Hermes-Exporter package.!
!ManifestHermes class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'RPackage-Core' #Files #'Collections-Abstract')! !

!ManifestHeuristicCompletionModel commentStamp: ''!
HeuristicCompletion is a code completion engine using generators and herustics. Instead of query the entire system and generate lots of potentially intermediate collections that we need to concatenate, copy, grow, iterate all those sub-collections in order. Generators provide a stream-like access to those collections (and sequences of collections) without scanning the full system eagerly.

# Architecture
This completion engine is done out of three main components:

- lazy fetchers implemented using generators (cf. CoFetcher),
- a completion object that works as a result-set (cf. CoResultSet),
- and several completion heuristics that are decided depending on the code being completed by looking at the AST (cf. CoASTNodeFetcherHeuristic).

# Plugging different heuristics

This completion engine is meant to be pluggable. New heuristics can be introduced, or the ones in the system can be completely replaced. If you want to implement your own completion you need to subclass CoASTResultSetBuilder or CoResultSetBuilder. CoASTResultSetBuilder provides already common behavior when basic the code completion algorithm on the AST. Then the completion engine can be configured with the required result set builder.

CoCompletionEngine new
    complishonBuilder: MyResultSetBuilder new;
    yourself

## Subclassing CoResultSetBuilder
The system will provide your builder with a completion context, and will then call buildComplishon. You need to redefine buildComplishon and return a CoResultSet.

## Subclassing CoASTResultSetBuilder
The system will provide your builder with a completion context, and will then call a default version of buildComplishon. By default it will parse the source code to get an AST, get the AST node corresponding to the caret position, and make a double dispatch on the node. As a result, the ASTResultSetBuilder will be sent a corresponding visit* with the corresponding node. You need to redefine visit* and return a CoResultSet configured depending on the AST node.

## Subclassing CoASTHeuristicsResultSetBuilder
CoASTHeuristicsResultSetBuilder is an CoASTResultSetBuilder based on heuristics. It has three sets of heuristics: one for messages, one for variables, and one for methods. You can redefine messageHeuristic, methodHeuristic or variablesHeuristic to change one of them.!
!ManifestHeuristicCompletionModel class methodsFor: 'code-critics' stamp: ''!
ruleReTempsReadBeforeWrittenRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#CoFetcher #next: #false)) #'2020-03-26T14:50:53.739628+01:00') #(#(#RGMethodDefinition #(#CoTypeInferencer #visitCascadeNode: #false)) #'2020-03-26T14:50:59.173856+01:00') )! !

!ManifestHeuristicCompletionModel class methodsFor: 'code-critics' stamp: ''!
ruleReSendsDifferentSuperRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'CoSystemEnvironment class' #forSmalltalkGlobals #true)) #'2020-03-26T14:29:31.095031+01:00') )! !

!ManifestHeuristicCompletionModel class methodsFor: 'code-critics' stamp: ''!
ruleReUsesTrueRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#CoTypeInferencer #visitMessageNode:receiverType: #false)) #'2020-03-26T14:21:20.676631+01:00') )! !

!ManifestHeuristicCompletionModel class methodsFor: 'code-critics' stamp: ''!
ruleReInspectorPresentationsNonlazyCodeV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#CoStaticBenchmarks #gtResultsTableIn: #false)) #'2020-03-26T14:49:28.1129+01:00') )! !

!ManifestHiedra commentStamp: ''!
Hiedra is a Pharo project to visually connect items in a history-like graph.

It uses Athens, and provides support for Morphic and Spec.!
!ManifestHiedraExamples commentStamp: ''!
Hiedra is a Pharo project to visually connect items in a history-like graph.

It uses Athens, and provides support for Morphic and Spec.

I contains the examples of the project.!
!ManifestHiedraTests commentStamp: ''!
Hiedra is a Pharo project to visually connect items in a history-like graph.

It uses Athens, and provides support for Morphic and Spec.

I contain the tests of the project.!
!ManifestIceberg commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIceberg class methodsFor: 'code-critics' stamp: ''!
ruleRBRefersToClassRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'IceRepository class' #isAbstract #true)) #'2018-03-13T18:40:58.956177+01:00') )! !

!ManifestIceberg class methodsFor: 'meta-data' stamp: ''!
description

	^ 'Iceberg is a set of tools that allow one to handle git repositories directly from a Pharo image. Right now we support only git, but Iceberg is designed to allow other code versioning systems in the future. The final aim of Iceberg is to become the default repository manager for Pharo-core, allowing for smoother and faster integration of contributions, as well as better branch and version management.

Repository : https://github.com/pharo-vcs/iceberg

This package contains the core classes of Iceberg.'! !

!ManifestIceberg class methodsFor: 'code-critics' stamp: ''!
ruleRBTempsReadBeforeWrittenRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#IceRepository #outgoingCommits #false)) #'2016-06-16T17:24:18.524965+02:00') #(#(#RGMethodDefinition #(#IceMCGitRepository #outgoingCommits #false)) #'2016-07-06T15:14:46.350843+02:00') )! !

!ManifestIceberg class methodsFor: 'code-critics' stamp: ''!
ruleRBUtilityMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#IceRepository #fetchFrom: #false)) #'2018-03-13T16:34:52.218313+01:00') )! !

!ManifestIcebergLibgit commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIcebergLibgit class methodsFor: 'meta-data' stamp: ''!
description

	^ 'I contains the core of the libgit binding of Iceberg. 

Libgit is a backend of Iceberg using the LibGit2 (https://libgit2.github.com/) to manage git communication. This package contains to code common to all export format. '! !

!ManifestIcebergLibgitFiletree commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIcebergLibgitFiletree class methodsFor: 'meta-data' stamp: ''!
description

	^ 'I contain the libgit binding for the FileTree export format. 

Iceberg can manage different export format and FileTree is one of them. It will export with a file per method format. The pro of this format is that it is easy to get a fine grained history. The cons of this format is that it will create a lot of small files. When a project contains a lot of small file it takes much more space on the disk because of the file system''s blocs minimum space. Also it can cause troubles on windows because of the long names of methods. '! !

!ManifestIcebergLibgitTonel commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIcebergLibgitTonel class methodsFor: 'meta-data' stamp: ''!
description

	^ 'I contain the libgit binding for the Tonel export format. 

Iceberg can manage different export format and Tonel is one of them. It will export with a file per class format. The cons of this format is that it is not easy to get a fine grained history. The pros of this format is that it will create bigger files than FileTree. When a project contains a lot of small file it takes much more space on the disk because of the file system''s blocs minimum space. Tonel also reduce the troubles on windows because of the long files names that can produce FileTree. '! !

!ManifestIcebergMetacelloIntegration commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIcebergMetacelloIntegration class methodsFor: 'meta-data' stamp: ''!
description

	^ 'I contains the code related to the Metacello integration of Iceberg. 

Metacello is a Smalltalk''s package manager. It help to creation configurations for project to load them and their dependencies.'! !

!ManifestIcebergPlugin commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIcebergPlugin class methodsFor: 'meta-data' stamp: ''!
description

	^ 'I contains a plugin manager for Iceberg. 

This plugin manager allow to extends Iceberg''s functionnalities with modularity.'! !

!ManifestIcebergPluginGitHub commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIcebergPluginGitHub class methodsFor: 'meta-data' stamp: ''!
description

	^ 'I contains a plugin to ease the integration of Iceberg with GitHub''s services.

It provides, for example, the possibility to manage pull requests. '! !

!ManifestIcebergPluginMetacello commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIcebergPluginMigration commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIcebergPluginPharo commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIcebergTipUI commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestIcebergTipUI class methodsFor: 'code-critics' stamp: ''!
ruleReGuardClauseRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#IceTipEditProjectDialog #initializeMessagePanel #false)) #'2021-01-05T16:19:22.928248-03:00') )! !

!ManifestIcebergTipUI class methodsFor: 'code-critics' stamp: ''!
ruleNotEliminationRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#IceTipBrowser #hasSelectedItem #false)) #'2020-12-17T18:54:45.342746-03:00') #(#(#RGMethodDefinition #(#IceTipRepositoryBrowser #initializeSidebarTree #false)) #'2021-01-05T16:19:22.920159-03:00') )! !

!ManifestIcebergTipUI class methodsFor: 'code-critics' stamp: ''!
ruleAnySatisfyRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#IceTipEditProjectDialog #guessFormatFromDirectory: #false)) #'2021-01-05T16:19:22.932793-03:00') )! !

!ManifestJobs commentStamp: ''!
This package contains the code related to Jobs.

Jobs are a way to manage the run of a task and optionnaly make it easier to notify the user of the progress. They also announce the progress of the task (when it begins, progress and ends).

The main class to use is Job. Here is an example:

[:job | job title: 'Let us get started'.
	1 to: 10 do: [:each |
		job
			progress: (0.1 * each);
			title: 'Youpi ', each printString.
		100 milliSeconds wait.
		] ]  asJob run!
!ManifestJobsTests commentStamp: ''!
This package contains the code related to the tests of Jobs.

See the comment of Jobs package for more informations.!
!ManifestKernel commentStamp: ''!
Core classes of Pharo Smalltalk including basic objects, types, exceptions, process, etc.!
!ManifestKernel class methodsFor: 'code-critics' stamp: ''!
ruleRBRefersToClassRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'Character class' #allByteCharacters #true)) #'2019-01-28T20:55:28.683846+01:00') )! !

!ManifestKernel class methodsFor: 'code-critics' stamp: ''!
ruleRBClassNameInSelectorRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'Character class' #allCharacters #true)) #'2019-01-28T20:55:17.784869+01:00') #(#(#RGMethodDefinition #(#'Character class' #allByteCharacters #true)) #'2019-01-28T20:55:32.378368+01:00') )! !

!ManifestKernel class methodsFor: 'code-critics' stamp: ''!
ruleRBBadMessageRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'Delay class' #delaySchedulerClass: #true)) #'2016-12-07T10:58:09.403079+08:00') #(#(#RGMethodDefinition #(#'Character class' #constantNameFor: #true)) #'2019-01-28T20:56:52.112604+01:00') )! !

!ManifestKernel class methodsFor: 'meta-data - dependency analyser' stamp: ''!
ignoredDependencies
	^ #('Reflectivity' 'Regex-Core' 'System-Settings-Core' 'FFI-Kernel')! !

!ManifestKernel class methodsFor: 'meta-data' stamp: ''!
dependencies
	^ #(#'System-Announcements' #'System-CommandLine' #'Collections-Strings' #'Slot-Core' #'Collections-Unordered' #'Collections-Streams' #Files #'System-Object Events' #'Collections-Abstract' #'Collections-Native' #'Collections-Support' #'System-Support' #'Multilingual-Encodings' #'Collections-Sequenceable' #'NewValueHolder-Core' #'System-Sources' #Compiler #'OpalCompiler-Core' #'System-Finalization' #Traits #'Collections-Weak' #UIManager)! !

!ManifestKernel class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'System-Settings-Core' #'System-Sources' #'System-Platforms' #'Shift-ClassBuilder' #'Regex-Core' #'RPackage-Core' #'Zinc-Character-Encoding-Core' #Reflectivity #'Shift-ClassInstaller')! !

!ManifestKernel class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #Kernel! !

!ManifestKernel class methodsFor: 'code-critics' stamp: ''!
ruleReDeadMethodV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'Character class' #characterSet: #true)) #'2019-01-28T20:56:23.286894+01:00') )! !

!ManifestKernelChronologyExtras commentStamp: ''!
Please describe the package using the class comment of the included manifest class. The manifest class also includes other additional metadata for the package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestKernelChronologyExtras class methodsFor: 'code-critics' stamp: ''!
ruleClassNameInSelectorRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'Time class' #dateAndTimeFromSeconds: #true)) #'2021-06-24T08:33:11.204551+02:00') )! !

!ManifestKernelTests commentStamp: ''!
I contain tests for the Kernel package.!
!ManifestKernelTests class methodsFor: 'metadata' stamp: ''!
dependencies
	^ #(#'Graphics-Primitives' #'RPackage-Core' #'System-Announcements' #'Morphic-Core' #'Morphic-Base' #'System-Changes' #'Collections-Strings' #'Collections-Unordered' #'Slot-Core' #Jobs #'Collections-Streams' #'FileSystem-Disk' #'System-Support' #'Text-Core' #'Collections-Abstract' #CollectionsTests #'Collections-Support' #'Collections-Sequenceable' #'SUnit-Core' #Tests #'OpalCompiler-Core' #Traits #Kernel #'Collections-Weak' #UIManager)! !

!ManifestKernelTests class methodsFor: 'metadata' stamp: ''!
packageName
	^ #KernelTests! !

!ManifestKernelTests class methodsFor: 'code-critics' stamp: ''!
ruleRBModifiesCollectionRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#ClassHierarchyTest #testSubclassInstVar #false)) #'2019-06-26T12:47:46.581134+02:00') )! !

!ManifestKernelTestsExtended commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestKernelTraits commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestKernelTraits class methodsFor: 'code-critics' stamp: ''!
ruleNotEliminationRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#TComparable #'<=' #false)) #'2020-05-02T12:57:13.088697+02:00') )! !

!ManifestKernelTraits class methodsFor: 'code-critics' stamp: ''!
ruleBetweenAndRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#TComparable #between:and: #false)) #'2020-05-02T12:57:07.451697+02:00') )! !

!ManifestLibGitCore commentStamp: '<historical>'!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestLibGitCore class methodsFor: 'meta data' stamp: ' 1/5/2022 21:01:26'!
rejectRules
^ #()! !

!ManifestLibGitCore class methodsFor: 'code-critics' stamp: ' 1/5/2022 21:01:26'!
ruleRBNoClassCommentRuleV1FalsePositive
^ #(#(#(#RGClassDefinition #(#LGitPushOptionsV02x)) #'2015-07-17T12:59:06.388548+02:00') )! !

!ManifestLibGitCore class methodsFor: 'meta data' stamp: ' 1/5/2022 21:01:26'!
ruleIfTrueBlocksRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#LGitExternalObject #ifNotReady: #false)) #'2014-11-14T16:52:32.831129+01:00') )! !

!ManifestLibGitCore class methodsFor: 'meta data' stamp: ' 1/5/2022 21:01:26'!
rejectClasses
^ #()! !

!ManifestLibGitCore class methodsFor: 'meta data' stamp: ' 1/5/2022 21:01:26'!
ruleIfTrueReturnsRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#LGitReference #= #false)) #'2014-11-14T16:52:32.91457+01:00') #(#(#RGMethodDefinition #(#LGitReference #= #false)) #'2014-11-14T16:52:32.915066+01:00') )! !

!ManifestLibGitCore class methodsFor: 'code-critics' stamp: ' 1/5/2022 21:01:26'!
ruleRBAbstractClassRuleV1FalsePositive
^ #(#(#(#RGMetaclassDefinition #(#'LGitExternalEnumerationUInt32 class' #LGitExternalEnumerationUInt32)) #'2015-07-18T14:21:49.402159+02:00') )! !

!ManifestManifestCore commentStamp: ''!
Support for package Manifest creation!
!ManifestManifestCore class methodsFor: 'meta data' stamp: ''!
rejectRules
^ #('LawOfDemeterRule' 'MethodHasNoTimeStampRule')! !

!ManifestManifestCore class methodsFor: 'meta data' stamp: ''!
ruleClassNotReferencedRuleV1FalsePositive
^ #(#(#(#RGClassDefinition #(#RBRemoveAssignmentWithoutEffectRule)) #'2013-03-22T15:13:33.961+01:00') )! !

!ManifestManifestCore class methodsFor: 'meta data' stamp: ''!
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: ''!
ruleSentNotImplementedRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#ClassDescription #criticNameOn: #false)) #'2013-03-22T11:32:46.828+01:00') )! !

!ManifestManifestCore class methodsFor: 'meta data' stamp: ''!
ruleConsistencyCheckRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#TheManifestBuilder #addItem:wihtComment:selector: #false)) #'2013-02-01T15:29:51.672000001+01:00') #(#(#RGMethodDefinition #(#'RGMetaclassDefinition class' #manifestReadOn: #true)) #'2013-02-01T15:29:51.672000002+01:00') #(#(#RGMethodDefinition #(#'RGMethodDefinition class' #manifestReadOn: #true)) #'2013-02-01T15:29:51.672000003+01:00') )! !

!ManifestManifestCore class methodsFor: 'meta data' stamp: ''!
ruleCodeCruftLeftInMethodsRuleV1TODO
^ #(#(#(#RGMethodDefinition #(#TheManifestBuilder #hash #false)) #'2013-02-06T15:08:33.234+01:00') )! !

!ManifestManifestCore class methodsFor: 'meta data' stamp: ''!
ruleImplementedNotSentRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#TheManifestBuilder #addTruePositive:of:version: #false)) #'2013-02-01T15:29:52.678000007+01:00') #(#(#RGMethodDefinition #(#SmalllintManifestChecker #isTruePositive:forRuleId:versionId: #false)) #'2013-02-01T15:29:52.678000011+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #removeManifestOf: #false)) #'2013-02-01T15:29:52.678000012+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #dateOfToDo:onRule:version: #false)) #'2013-02-01T15:29:52.678000013+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #dateOfTruePositive:onRule:version: #false)) #'2013-02-01T15:29:52.67800001+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #removeAllManifest #false)) #'2013-02-01T15:29:52.678000006+01:00') #(#(#RGMethodDefinition #(#'RBLintRule class' #uniqueIdentifierNumber #true)) #'2013-02-01T15:29:52.678000008+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #installTruePositiveOf:version: #false)) #'2013-02-01T15:29:52.678000009+01:00') )! !

!ManifestManifestCore class methodsFor: 'meta data' stamp: ''!
ruleContainsRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#TheManifestBuilder #commentOfFalsePositive:onRule:version: #false)) #'2013-02-01T15:29:52.876+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #commentOfToDo:onRule:version: #false)) #'2013-02-01T15:29:52.876000001+01:00') #(#(#RGMethodDefinition #(#SmalllintManifestChecker #criticsOf: #false)) #'2013-02-08T16:35:58.019+01:00') )! !

!ManifestManifestCore class methodsFor: 'meta data' stamp: ''!
ruleBadMessageRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#TheManifestBuilder #hasTruePositiveOf:version: #false)) #'2013-02-01T15:29:51.978000008+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #hasFalsePositiveOf:version: #false)) #'2013-02-01T15:29:51.978000006+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #rejectRules #false)) #'2013-02-01T15:29:51.978000007+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #hasToDoOf:version: #false)) #'2013-02-01T15:29:51.978000005+01:00') )! !

!ManifestManifestTests commentStamp: ''!
Tests for Manifests!
!ManifestMathOperationsExtensions commentStamp: ''!
Additional math operations!
!ManifestMicrodown commentStamp: ''!
I define a parser and code model for MicroDown.
Microdown is a smaller mardown than but mardown, but it is more extensible. 
It supports the default markdown features:
- Header
- Lists
- Paragraph
- Code with arguments: key=val&key2=val2
- Quote
- Table
- Emphasis 
- Figures and links

But also 
- Environment with arguments
- Anchors
- Annotated paragraph
- Math with arguments
- and more intra block elements such as extensible markups, raw, math, and references.

### In Pharo Image Syntax Essence in 2 seconds

```language=undefined

	#Header

	```language=Pharo&caption=Beautiful&label=Fig1
	code
	```
	> Boring quote block 
	> Don't use me!!

   [Pharo is cool](http://pharo.org)

   - item 1
     1. sub item 1 
     3. sub item 2
   - item 2 

  `in text` but for pharo hyper links  to class, method and package
  `Point`, `Point class`, `Point>>#setX:setY:`, `#’Microdown-Tests’ (for packages)
```



### Implementation notes

I follow the design mentioned in [https://github.github.com/gfm](https://github.github.com/gfm), in particular the parsing strategy in appendix A.

In short, the strategy is that at any point in time, we might have a number of children of the root which are "open". The deepest in open in the tree is called "current". All the parents of current are open. 

When a new line is read we do the following:

1. Check if the new line can be consumed by current.
   - as part of this a child of current can be made which can consume the new line
2. If current cannot consume the new line, we close current, move current to its parent, and repeat 1.
3. The root node can consume anything, for instance by making new nodes for storing the new line.
4. The root node is not closed until input is exhausted

The other packages in this repository are the extensions made to produce Pillar model. 
Such packages should be moved in the future to other location (probably pillar itself).

### Acknowledgments
I was implemented by S. Ducasse, L. Dargaud and G. Polito. It is based on the work on markdown parsing of K. Osterbye. !
!ManifestMonticello commentStamp: ''!
Includes the Monticello source code control system.!
!ManifestMonticello class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
ignoredDependencies
	^ #(#'Graphics-Primitives' #'FFI-Kernel' #'System-Settings-Core')! !

!ManifestMonticello class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#'Graphics-Primitives' #'OpalCompiler-Core' #Jobs #'Random-Core' #'FFI-Kernel' #'Ring-Definitions-Monticello' #'System-Settings-Core' #'FileSystem-Disk')! !

!ManifestMonticelloGUI commentStamp: ''!
Provides the graphical user interface (UI) for Monticello source code management system!
!ManifestMonticelloOldDataStreamCompatibility commentStamp: ''!
Compatibility package for old data streams!
!ManifestMorphicBase commentStamp: ''!
Basic classes for Morphic - a direct-manipulation User Interface (UI) construction kit !
!ManifestMorphicBase class methodsFor: 'code-critics' stamp: ''!
ruleRBRefersToClassRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'StringMorph class' #exampleManyStringMorphs #true)) #'2017-09-29T14:22:14.93688+02:00') )! !

!ManifestMorphicBase class methodsFor: 'code-critics' stamp: ''!
ruleRefersToClassRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'CircleMorph class' #example #true)) #'2021-11-23T21:02:44.097019+01:00') #(#(#RGMethodDefinition #(#'EllipseMorph class' #example #true)) #'2021-11-23T21:04:02.130492+01:00') #(#(#RGMethodDefinition #(#'CircleMorph class' #exampleBadExtent #true)) #'2021-11-23T21:05:37.844402+01:00') )! !

!ManifestMorphicBase class methodsFor: 'code-critics' stamp: ''!
ruleRBClassNameInSelectorRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'StringMorph class' #exampleManyStringMorphs #true)) #'2017-09-29T14:22:18.600353+02:00') )! !

!ManifestMorphicWidgetsMenubar commentStamp: ''!
This package contains a Menubar for Pharo. 

This Menubar can be displayed at the top of the Pharo window. It uses the worldMenu pragma to build the menu.

For more informations check the comment of MenubarMorph.!
!ManifestMorphicWidgetsPluggable commentStamp: ''!
Pluggable widgets for morphic!
!ManifestMultilingualEncodings commentStamp: ''!
Different Encodings for Multilingual support!
!ManifestMultilingualEncodings class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'Collections-Abstract')! !

!ManifestNECompletion commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestNECompletion class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Tool-Registry' #'OpalCompiler-Core' #'Tool-Base' #'Text-Core' #'Collections-Abstract')! !

!ManifestNativeBrowser commentStamp: ''!
Native-Browser is a package adding to the system the possibility of opening a directory in the native OS file browser 

Currently working on:
- OSX (32/64)
- Linux (32/64)
- Windows (32/64)

You can use it like this:

```
FileSystem workingDirectory openInOSFileBrowser.

NativeBrowserOpenVisitor openOn: FileLocator home.
```!
!ManifestNetworkKernel commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestNetworkKernel class methodsFor: 'code-critics' stamp: ''!
ruleRBRefersToClassRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'HTTPProgress class' #example #true)) #'2019-07-05T10:28:44.466329+02:00') )! !

!ManifestNetworkUUID commentStamp: ''!
A package providing Universally Unique Identifiers (UUID) following RFC4122.!
!ManifestNetworkUUID class methodsFor: 'meta-data - dependency analyser' stamp: ''!
ignoredDependencies
	^ #(#'Network-Kernel')! !

!ManifestNetworkUUID class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Abstract')! !

!ManifestNewToolsInspectorExtensions commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestNewToolsSpotterProcessors commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestNewToolsSpotterProcessors class methodsFor: 'code-critics' stamp: ''!
ruleReClassNotReferencedRuleV1FalsePositive
	^ #(#(#(#RGPackageDefinition #(#'NewTools-Spotter-Processors')) #'2020-03-26T18:37:51.234976+01:00') )! !

!ManifestNewValueHolderCore commentStamp: ''!
Implementation for a new value holder!
!ManifestNewValueHolderCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams')! !

!ManifestNumberParser commentStamp: ''!
NumberParser is parsing and building numbers from string/stream.!
!ManifestOSWindowSDL2 commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestOSWindowSDL2 class methodsFor: 'code-critics' stamp: ''!
ruleUnaryAccessingMethodWithoutReturnRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#OSSDL2BackendWindow #hide #false)) #'2020-07-20T09:01:23.699228+02:00') )! !

!ManifestOmbu commentStamp: ''!
Ombu is part of Epicea. It provides simple persistence. 

By default, Ombu uses STON to write the events when they are announced in the system.!
!ManifestOpalCompilerCore class methodsFor: 'code-critics' stamp: ''!
rejectRules
^ #('SearchingLiteralRule' 'ExcessiveArgumentsRule' 'LongMethodsRule' 'ClassInstVarNotInitializedRule' 'UsesAddRule' 'ExcessiveMethodsRule' 'MissingYourselfRule' 'ExcessiveVariablesRule' 'TempsReadBeforeWrittenRule' 'AbstractClassRule' 'IfTrueReturnsRule')! !

!ManifestOpalCompilerCore class methodsFor: 'code-critics' stamp: ''!
ruleClassNotReferencedRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#OpalEncoderForLongFormV3PlusClosures)) #'2015-08-17T13:55:18.528985+02:00') )! !

!ManifestOpalCompilerCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
ignoredDependencies
	^ #(#'Morphic-Base' #'System-Settings-Core')! !

!ManifestOpalCompilerCore class methodsFor: 'code-critics' stamp: ''!
ruleAssignmentInIfTrueRuleV1TruePositive
^ #(#(#(#RGMethodDefinition #(#OpalCompiler #from:class:context:notifying: #false)) #'2012-12-18T17:43:24.703000001+01:00') )! !

!ManifestOpalCompilerCore class methodsFor: 'code-critics' stamp: ''!
ruleTempsReadBeforeWrittenRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#IRSequence #absorbJumpToSingleInstr: #false)) #'2012-12-19T08:10:39.177+01:00') )! !

!ManifestOpalCompilerCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Morphic-Base' #'System-Settings-Core' #CodeExport #'System-Announcements' #'System-Sources')! !

!ManifestOpalCompilerCore class methodsFor: 'code-critics' stamp: ''!
ruleImplementedNotSentRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#OCASTTranslatorForEffect #emitIfFalse: #false)) #'2012-12-18T17:41:36.969+01:00') #(#(#RGMethodDefinition #(#OCASTTranslatorForEffect #emitIfTrue: #false)) #'2012-12-18T17:41:39.446+01:00') #(#(#RGMethodDefinition #(#OCASTTranslatorForEffect #emitIfNotNil: #false)) #'2012-12-18T17:41:41.777+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitCaseOf: #false)) #'2012-12-18T17:42:01.724+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitToByDo: #false)) #'2012-12-18T17:42:03.557+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitToDo: #false)) #'2012-12-18T17:42:05.34+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitIfNotNil: #false)) #'2012-12-18T17:42:07.349+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitIfNil: #false)) #'2012-12-18T17:42:09.472+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitCaseOfOtherwise: #false)) #'2012-12-18T17:42:11.795+01:00') #(#(#RGMethodDefinition #(#BytecodeEncoder #sizeCallPrimitive: #false)) #'2015-08-17T13:56:21.549128+02:00') )! !

!ManifestOpalCompilerCore class methodsFor: 'code-critics' stamp: ''!
ruleToDoCollectRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#IRBytecodeScope #args #false)) #'2012-12-19T08:16:58.474000001+01:00') #(#(#RGMethodDefinition #(#IRBytecodeScope #temps #false)) #'2012-12-19T08:17:19.677+01:00') )! !

!ManifestOpalCompilerCore class methodsFor: 'code-critics' stamp: ''!
ruleVariableAssignedLiteralRuleV1FalsePositive
^ #(#(#(#RGClassDefinition #(#IRMethod)) #'2012-12-19T08:13:54.508+01:00') )! !

!ManifestOpalCompilerCore class methodsFor: 'code-critics' stamp: ''!
ruleBadMessageRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#OCASTTranslator #initialize #false)) #'2013-05-23T08:43:44.793471+02:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitCaseOf: #false)) #'2013-05-23T08:43:44.793471+02:00') #(#(#RGMethodDefinition #(#OpalCompiler #evaluate #false)) #'2013-05-23T08:43:44.793471+02:00') )! !

!ManifestOpalCompilerTests methodsFor: 'code-critics' stamp: ''!
ruleGuardClauseRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#OCContextTempMappingTest #testAccessingVariablesInOptimizedBlock2 #false)) #'2015-04-09T21:02:04.919962+02:00') )! !

!ManifestOpalCompilerTests methodsFor: 'code-critics' stamp: ''!
ruleTempsReadBeforeWrittenRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#OCContextTempMappingTest #testAccessingTempsVectorInBlock2 #false)) #'2015-04-09T21:02:04.945558+02:00') )! !

!ManifestOpalCompilerTests methodsFor: 'code-critics' stamp: ''!
ruleOnlyReadOrWrittenTemporaryRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#OCContextTempMappingTest #testAccessingVariablesInOptimizedBlock2 #false)) #'2015-04-09T21:02:04.928132+02:00') #(#(#RGMethodDefinition #(#OCContextTempMappingTest #testAccessingTempsVectorInBlock #false)) #'2015-04-09T21:02:04.927985+02:00') #(#(#RGMethodDefinition #(#OCContextTempMappingTest #testAccessingVariablesInOptimizedBlock #false)) #'2015-04-09T21:02:04.927828+02:00') #(#(#RGMethodDefinition #(#OCContextTempMappingTest #testAccessingVariablesInBlock #false)) #'2015-04-09T21:02:04.928107+02:00') )! !

!ManifestOpalCompilerTests methodsFor: 'code-critics' stamp: ''!
ruleExtraBlockRuleV1FalsePositive
^ #(#(#(#RGMethodDefinition #(#OCContextTempMappingTest #testAccessingMultipleVariablesInVector #false)) #'2015-04-09T21:02:04.935487+02:00') #(#(#RGMethodDefinition #(#OCContextTempMappingTest #testAccessingTempsVectorInBlock #false)) #'2015-04-09T21:02:04.935425+02:00') #(#(#RGMethodDefinition #(#OCContextTempMappingTest #testAccessingVariablesInBlock #false)) #'2015-04-09T21:02:04.935457+02:00') )! !

!ManifestPharoBootstrapInitialization commentStamp: ''!
Initializations done during image bootstrap process!
!ManifestPharoBootstrapInitialization class methodsFor: 'meta-data - dependency analyser' stamp: ''!
ignoredDependencies
	^ #(#'SUnit-Core')! !

!ManifestPharoBootstrapInitialization class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'System-Finalization')! !

!ManifestPharoBootstrapInitialization class methodsFor: 'meta-data - dependency analyser' stamp: ''!
packageName
	^ #'PharoBootstrap-Initialization'! !

!ManifestPharoDocComment commentStamp: ''!
This package supports the handling (syntax highlighting and first class manipulation) of small executable examples inline in method comment. 

Assuming the following method is defined

AbstractFileReference >> basename
            "Returns the basename, i.e. /foo/gloops.taz basename is 'gloops.taz'"
            "'/foo/gloops.taz' asFileReference basename >>> 'gloops.taz'"
            ^ self fullPath basename

The following expression allows one to access to the expression and its expected result. 

[[[
| doc |
doc := (AbstractFileReference >> #basename) ast pharoDocCommentNodes.
doc first expression 
> '/foo/gloops.taz' asFileReference basename
doc result
>  'gloops.taz'
]]]

The code browser will show a little icon with the executed examples.  In that case you will get the original expression, its returned result and the expected result. 

Now you can also execute manually the expression and you will get a pair containing the result of the 


Implementation Notes

- may be PharoDocCommentNode and PharoDocCommentExpression should be subclass of ProgramNode.
- questions for nicolai
	it would be nice to address 
		example expression expressionCode 
- I renamed expression and result into expressionNode, resultNode. To be able to make the difference between an expression, its expected value and its effective value. 		
	!
!ManifestProfStefHelp commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestRPackageCore commentStamp: ''!
Manifest for RPackage-Core!
!ManifestRPackageCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#UIManager)! !

!ManifestRandomCore commentStamp: ''!
Package providing Random Number generation!
!ManifestRandomCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
ignoredDependencies
	^ #(#Transcript)! !

!ManifestRandomCore class methodsFor: 'accessing' stamp: ''!
packageName
	^ 'Random-Core'! !

!ManifestRefactoringChanges commentStamp: ''!
Please describe the package using the class comment of the included manifest class. The manifest class also includes other additional metadata for the package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestRefactoringChanges class methodsFor: 'code-critics' stamp: ''!
ruleUtilityMethodsRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#RBRefactoryChangeFactory)) #'2021-10-08T23:52:53.51808+02:00') )! !

!ManifestRefactoringCore commentStamp: ''!
Please describe the package using the class comment of the included manifest class. The manifest class also includes other additional metadata for the package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestReferenceFinderCore commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestReferenceFinderCore class methodsFor: 'code-critics' stamp: ''!
ruleRBBadMessageRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#ReferenceFinder #_object:instVarAt: #false)) #'2019-07-13T17:57:52.391956+02:00') )! !

!ManifestReferenceFinderCore class methodsFor: 'code-critics' stamp: ''!
ruleRBUtilityMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#ReferenceFinder #_object:instVarAt: #false)) #'2019-07-13T17:57:56.103956+02:00') #(#(#RGMethodDefinition #(#ReferenceFinder #_objectClass: #false)) #'2019-07-13T17:58:01.445956+02:00') #(#(#RGMethodDefinition #(#ReferenceFinder #_objectSize: #false)) #'2019-07-13T17:58:07.452956+02:00') #(#(#RGMethodDefinition #(#ReferenceFinder #_object:at: #false)) #'2019-07-13T17:58:22.138956+02:00') )! !

!ManifestReflectivity commentStamp: ''!
Extensions to the standard reflection features of Smalltalk like MetaLinks and other!
!ManifestRegexCore commentStamp: ''!
Support for regular expressions.!
!ManifestRegexCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Abstract')! !

!ManifestRenraku commentStamp: ''!
Renraku is a framework for defining and processing quality rules. The framework operates with three main concepts: entities, rules and critiques.

!!!! Entities
Entities are not a part of Renraku, but Renraku is validating entities. Theoretically entity can be any object, but in practice we mostly focus on code entities such as methods, classes, packages, AST nodes.

!!!! Rules
Rules are the objects that describe constraints about entities. A rule can check an entity and produce critiques that describe the violations of the entity according to the rule.

!!!! Critiques
Critique is an object that binds an entity with a rule that is violated by that entity. The critique describes a specific violation, and may provide a solutions to fix it.!
!ManifestRingDefinitionsContainers commentStamp: ''!
Deprecated package for Ring Core containerss!
!ManifestRingDefinitionsContainers class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'Collections-Abstract' #'Collections-Strings' #'System-Support')! !

!ManifestRingDefinitionsCore commentStamp: ''!
Manifest for DEPRECATED package of Ring!
!ManifestRingDefinitionsCore class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#'Collections-Abstract' #'Collections-Strings' #'Collections-Streams' #'System-Sources')! !

!ManifestRingDefinitionsMonticello commentStamp: ''!
Deprecated ring extensions for Monticello.!
!ManifestRingDefinitionsMonticello class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'Collections-Abstract')! !

!ManifestRingDefinitionsTestsContainers commentStamp: ''!
Manifest for DEPRECATED package for Ring containers tests!
!ManifestRingDefinitionsTestsCore commentStamp: ''!
Manifest for DEPRECATED package of Ring tests!
!ManifestRingDefinitionsTestsMonticello commentStamp: ''!
Manifest for DEPRECATED package for Ring monticello tests!
!ManifestRingOldChunkImporter commentStamp: ''!
Manifest for deprecated Ring-Deprecated-ChunkImporter package!
!ManifestRingOldChunkImporter class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#'OpalCompiler-Core' #'FileSystem-Core' #'Collections-Abstract' #'Collections-Strings' #'System-Support')! !

!ManifestSUnitCore commentStamp: ''!
Core package for the SUnit unit testing framework!
!ManifestSUnitCore class methodsFor: 'code-critics' stamp: ''!
ruleStringConcatenationRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#ClassFactoryForTestCase #cleanUpChangeSetForClassNames: #false)) #'2021-12-05T23:07:46.009058+01:00') )! !

!ManifestSUnitCore class methodsFor: 'code-critics' stamp: ''!
ruleExcessiveArgumentsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#ClassFactoryForTestCase #newSubclassOf:uses:instanceVariableNames:classVariableNames:category: #false)) #'2021-12-05T23:11:40.799968+01:00') #(#(#RGMethodDefinition #(#ClassFactoryForTestCase #newSubclassOf:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: #false)) #'2021-12-05T23:12:15.813959+01:00') #(#(#RGMethodDefinition #(#ClassFactoryForTestCase #redefineClass:subclassOf:uses:instanceVariableNames:classVariableNames:poolDictionaries:package: #false)) #'2021-12-05T23:13:13.110809+01:00') )! !

!ManifestSUnitCore class methodsFor: 'code-critics' stamp: ''!
ruleUtilityMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#ClassTestCase #categoriesForClass: #false)) #'2021-12-05T23:37:26.237093+01:00') )! !

!ManifestShiftClassInstaller commentStamp: ''!
ShiftClassInstaller (responsible of installing a class in the system) and related classes!
!ManifestShiftClassInstaller class methodsFor: 'code-critics' stamp: ''!
ruleRBBadMessageRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#ShiftClassInstaller #fixSlotScope: #false)) #'2019-07-25T11:05:26.260339+02:00') )! !

!ManifestShout commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestShout class methodsFor: 'code-critics' stamp: ''!
ruleRBBadMessageRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SHRBTextStyler #unstyledTextFrom: #false)) #'2019-07-11T10:39:24.675084+02:00') )! !

!ManifestSlotCore commentStamp: ''!
Core package for Slot support!
!ManifestSlotCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'System-Settings-Core')! !

!ManifestSpec2AdaptersMorphic commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I am implementing the spec layer between presenters and the morphic widgets. I will be used when the morphic backend of Spec is selected to build the Morphic widgets during the GUI creation.!
!ManifestSpec2AdaptersMorphic class methodsFor: 'code-critics' stamp: ''!
ruleGTExampleNotDefinedRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#SpAbstractMorphicAdapter)) #'2016-07-01T15:56:13.367433+02:00') )! !

!ManifestSpec2AdaptersMorphic class methodsFor: 'code-critics' stamp: ''!
ruleCollectionMessagesToExternalObjectRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SpMorphicButtonBarAdapter #addModelTo: #false)) #'2020-11-13T23:10:31.921402+01:00') )! !

!ManifestSpec2AdaptersMorphic class methodsFor: 'code-critics' stamp: ''!
ruleRBOverridesDeprecatedMethodRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SpMorphicMenuItemAdapter #name #false)) #'2016-07-01T15:56:13.381999+02:00') )! !

!ManifestSpec2AdaptersMorphic class methodsFor: 'code-critics' stamp: ''!
ruleCollectionProtocolRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SpMorphicDialogWindowAdapter #buildButtonBar #false)) #'2020-11-13T22:08:25.752583+01:00') #(#(#RGMethodDefinition #(#SpMorphicButtonBarAdapter #addModelTo: #false)) #'2020-11-13T23:10:24.35015+01:00') )! !

!ManifestSpec2AdaptersMorphic class methodsFor: 'code-critics' stamp: ''!
ruleUtilityMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SpMorphicTextAdapter #setWrapWord:to: #false)) #'2020-11-13T22:40:20.610215+01:00') )! !

!ManifestSpec2AdaptersStub commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain stubs adapter to test Spec without any backend.!
!ManifestSpec2BackendTests commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain backend specific tests for Spec2.!
!ManifestSpec2CommandLine commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain command line useful for Spec. With them the user will be able to do things such as browsing the applications present in the image or launch an application in headless when the backend used is not the Pharo one.!
!ManifestSpec2Commander2 commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain a layer of compatibility for the Commander 2 project.

Commander 2 is a project to create commands following the Command design pattern. With the compatibility layer you can add icons or shortcuts to your commands and integrate them easily in your presenters.!
!ManifestSpec2Commander2Tests commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain test about the integration of Commander 2 in Spec.!
!ManifestSpec2Commands commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I am a package whose responsibility is to define the commands that will be used by Spec.!
!ManifestSpec2Core commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain the core of Spec 2. By core I mean all the code defining the basics of Spec and the basic widgets users should use to build their applications.!
!ManifestSpec2Core class methodsFor: 'code-critics' stamp: ''!
ruleExcessiveVariablesRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#SpPresenter)) #'2016-07-01T15:56:13.372336+02:00') #(#(#RGClassDefinition #(#SpAbstractWidgetPresenter)) #'2016-07-01T15:56:13.372528+02:00') )! !

!ManifestSpec2Core class methodsFor: 'code-critics' stamp: ''!
ruleGTExampleNotDefinedRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#SpPresenter)) #'2016-07-01T15:56:13.363445+02:00') )! !

!ManifestSpec2Core class methodsFor: 'code-critics' stamp: ''!
ruleUsesTrueRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'DiffPresenter class' #exampleWithOptions #true)) #'2016-07-01T15:56:13.475288+02:00') )! !

!ManifestSpec2Core class methodsFor: 'code-critics' stamp: ''!
ruleRBOverridesDeprecatedMethodRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SpMenuItemPresenter #name #false)) #'2016-07-01T15:56:13.378417+02:00') )! !

!ManifestSpec2Core class methodsFor: 'code-critics' stamp: ''!
ruleExcessiveMethodsRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#SpPresenter)) #'2016-07-01T15:56:13.465539+02:00') )! !

!ManifestSpec2Core class methodsFor: 'code-critics' stamp: ''!
ruleImplementedNotSentRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'TreePresenter class' #exampleWithNoSpecifiedNodes #true)) #'2016-07-01T15:56:13.496495+02:00') #(#(#RGMethodDefinition #(#'DiffPresenter class' #exampleWithoutOptions #true)) #'2016-07-01T15:56:13.496444+02:00') #(#(#RGMethodDefinition #(#'DiffPresenter class' #exampleWithOptions #true)) #'2016-07-01T15:56:13.496455+02:00') #(#(#RGMethodDefinition #(#'TreePresenter class' #exampleWithCustomColumnsAndNodesAndChildren #true)) #'2016-07-01T15:56:13.496426+02:00') #(#(#RGMethodDefinition #(#'TreePresenter class' #exampleOfAutoRefreshOnExpand #true)) #'2016-07-01T15:56:13.496465+02:00') #(#(#RGMethodDefinition #(#'TreePresenter class' #exampleWithCustomColumnsAndNodes #true)) #'2016-07-01T15:56:13.496478+02:00') )! !

!ManifestSpec2Core class methodsFor: 'code-critics' stamp: ''!
ruleLongMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SpAbstractWidgetPresenter #initialize #false)) #'2016-07-01T15:56:13.356024+02:00') #(#(#RGMethodDefinition #(#SpPresenter #initialize #false)) #'2016-07-01T15:56:13.355982+02:00') )! !

!ManifestSpec2Examples commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain examples of Spec usages.!
!ManifestSpec2Help commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain help for the HelpBrowser explaining how to use Spec 2.!
!ManifestSpec2Interactions commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain code to manage interactions with the user.!
!ManifestSpec2Layout commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain the layouts used by presenters to position their elements.!
!ManifestSpec2MorphicBackendTests commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain the Morphic specific tests of Spec.!
!ManifestSpec2Tests commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain the tests of Spec2-Core. Those are the tests of Presenters that are independant of the backend used by the user.!
!ManifestSpec2Tests class methodsFor: 'code-critics' stamp: ''!
ruleRBSentNotImplementedRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#SpUIThemeDecoratorTest)) #'2018-10-10T14:57:43.139752+02:00') #(#(#RGMethodDefinition #(#RadioButtonGroupPresenterTest #testRebuildWidget #false)) #'2018-10-10T14:59:58.802602+02:00') )! !

!ManifestSpec2Transmission commentStamp: ''!
I am a package part of the Spec 2 project.

Spec is a framework in Pharo for describing user interfaces. It allows for the construction of a wide variety of UIs; from small windows with a few but- tons up to complex tools like a debugger. Indeed, multiple tools in Pharo are written in Spec, e.g., Iceberg, Change Sorter, Critics Browser, and the Pharo debugger.

I contain the code for a syntactic sugar of Spec allowing the developer to define the flow of its data using transmissions.!
!ManifestSpecCore commentStamp: ''!
Core package for the Spec UI framework!
!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleExcessiveVariablesRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#ComposablePresenter)) #'2016-07-01T15:56:13.372336+02:00') #(#(#RGClassDefinition #(#AbstractWidgetPresenter)) #'2016-07-01T15:56:13.372528+02:00') )! !

!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleUnwindBlocksRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'SpecInterpreter class' #interpretASpec:model:selector: #true)) #'2016-07-01T15:56:13.479538+02:00') )! !

!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleSubclassResponsibilityNotDefinedRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'ComposablePresenter class' #defaultSpec #true)) #'2016-07-01T15:56:13.461086+02:00') )! !

!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleGTExampleNotDefinedRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#ComposablePresenter)) #'2016-07-01T15:56:13.363445+02:00') )! !

!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleUsesTrueRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'DiffPresenter class' #exampleWithOptions #true)) #'2016-07-01T15:56:13.475288+02:00') )! !

!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleRBOverridesDeprecatedMethodRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#MenuItemPresenter #name #false)) #'2016-07-01T15:56:13.378417+02:00') )! !

!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleEqualsTrueRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#ListPresenter #getSelectionStateFor: #false)) #'2016-07-01T15:56:13.455728+02:00') )! !

!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleExcessiveMethodsRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#ComposablePresenter)) #'2016-07-01T15:56:13.465539+02:00') )! !

!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleImplementedNotSentRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'TreePresenter class' #exampleWithNoSpecifiedNodes #true)) #'2016-07-01T15:56:13.496495+02:00') #(#(#RGMethodDefinition #(#'DiffPresenter class' #exampleWithoutOptions #true)) #'2016-07-01T15:56:13.496444+02:00') #(#(#RGMethodDefinition #(#'DiffPresenter class' #exampleWithOptions #true)) #'2016-07-01T15:56:13.496455+02:00') #(#(#RGMethodDefinition #(#'TreePresenter class' #exampleWithCustomColumnsAndNodesAndChildren #true)) #'2016-07-01T15:56:13.496426+02:00') #(#(#RGMethodDefinition #(#'TreePresenter class' #exampleOfAutoRefreshOnExpand #true)) #'2016-07-01T15:56:13.496465+02:00') #(#(#RGMethodDefinition #(#'TreePresenter class' #exampleWithCustomColumnsAndNodes #true)) #'2016-07-01T15:56:13.496478+02:00') )! !

!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleRBEquivalentSuperclassMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'ComposablePresenter class' #iconNamed: #true)) #'2018-11-07T14:51:01.186582+01:00') )! !

!ManifestSpecCore class methodsFor: 'code-critics' stamp: ''!
ruleLongMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#AbstractWidgetPresenter #initialize #false)) #'2016-07-01T15:56:13.356024+02:00') #(#(#RGMethodDefinition #(#ComposablePresenter #initialize #false)) #'2016-07-01T15:56:13.355982+02:00') )! !

!ManifestSpecCore class methodsFor: 'deprecation' stamp: ''!
isDeprecated
	"Spec should be replaced by Spec 2"

	^ true! !

!ManifestSpecLayout commentStamp: ''!
Layouts and layout actions for Spec UI framework!
!ManifestSpecLayout class methodsFor: 'code-critics' stamp: ''!
ruleExcessiveArgumentsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SpecLayout #add:top:bottom:left:right: #false)) #'2016-07-01T15:56:13.487439+02:00') #(#(#RGMethodDefinition #(#SpecLayout #add:withSpec:top:bottom:left:right: #false)) #'2016-07-01T15:56:13.487448+02:00') #(#(#RGMethodDefinition #(#SpecLayout #add:withSpec:origin:corner:offsetOrigin:offsetCorner: #false)) #'2016-07-01T15:56:13.487458+02:00') #(#(#RGMethodDefinition #(#SpecLayout #newColumn:origin:corner:offsetOrigin:offsetCorner: #false)) #'2016-07-01T15:56:13.487419+02:00') #(#(#RGMethodDefinition #(#SpecLayout #newRow:origin:corner:offsetOrigin:offsetCorner: #false)) #'2016-07-01T15:56:13.487404+02:00') #(#(#RGMethodDefinition #(#SpecLayout #add:origin:corner:offsetOrigin:offsetCorner: #false)) #'2016-07-01T15:56:13.487429+02:00') #(#(#RGMethodDefinition #(#SpecLayout #setOffsetsFor:top:left:bottom:right:borderWidth: #false)) #'2016-07-01T15:56:13.487382+02:00') )! !

!ManifestSpecLayout class methodsFor: 'deprecation' stamp: ''!
isDeprecated
	"Spec should be replaced by Spec 2"

	^ true! !

!ManifestSpecMorphicAdapters commentStamp: ''!
Morphic specific spec adapters!
!ManifestSpecMorphicAdapters class methodsFor: 'code-critics' stamp: ''!
ruleGTExampleNotDefinedRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#AbstractMorphicAdapter)) #'2016-07-01T15:56:13.367433+02:00') )! !

!ManifestSpecMorphicAdapters class methodsFor: 'code-critics' stamp: ''!
ruleRBOverridesDeprecatedMethodRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#MorphicMenuItemAdapter #name #false)) #'2016-07-01T15:56:13.381999+02:00') )! !

!ManifestSpecMorphicAdapters class methodsFor: 'deprecation' stamp: ''!
isDeprecated
	"Spec should be replaced by Spec 2"

	^ true! !

!ManifestSpecPolyWidgets class methodsFor: 'deprecation' stamp: ''!
isDeprecated
	"Spec should be replaced by Spec 2"

	^ true! !

!ManifestSpecStubAdapter class methodsFor: 'deprecation' stamp: ''!
isDeprecated
	"Spec should be replaced by Spec 2"

	^ true! !

!ManifestSystemAnnouncements commentStamp: ''!
Package to provide system wide announcements for Pharo image!
!ManifestSystemBasicCommandLineHandler commentStamp: ''!
Package to provide basic command line handling.!
!ManifestSystemBasicCommandLineHandler class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #( #'Collections-Strings' #'Collections-Abstract')! !

!ManifestSystemBasicCommandLineHandlerTests commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestSystemBasicCommandLineHandlerTests class methodsFor: 'code-critics' stamp: ''!
ruleRBBadMessageRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#STCommandLineHandlerTest)) #'2019-06-30T23:16:50.788113+02:00') )! !

!ManifestSystemChanges commentStamp: ''!
Packacke with support for system changes recorded in changesets!
!ManifestSystemChanges class methodsFor: 'code-critics' stamp: 'nil'!
ruleClassNameInSelectorRuleV1FalsePositive
	^ #(#(#(#RGMetaclassDefinition #(#'ChangeSet class' #ChangeSet)) #'2021-10-04T20:06:46.530781+02:00') )! !

!ManifestSystemChanges class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#CodeExport #'OpalCompiler-Core' #'FileSystem-Disk' #'Collections-Abstract')! !

!ManifestSystemCommandLine commentStamp: ''!
Terminal / Command line support!
!ManifestSystemCommandLine class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'System-Support')! !

!ManifestSystemCommandLineHandler commentStamp: ''!
Default command line handling!
!ManifestSystemCommandLineHandler class methodsFor: 'meta-data - dependency analyser' stamp: ''!
ignoredDependencies
	^ #(#'System-Settings-Core' #StartupPreferences)! !

!ManifestSystemCommandLineHandler class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'FileSystem-Core' #'System-Settings-Core' #'System-Support')! !

!ManifestSystemFileRegistry commentStamp: ''!
Provide service registration to handle specific file extension!
!ManifestSystemFileRegistry class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'FileSystem-Core' #'Collections-Abstract')! !

!ManifestSystemFinalization commentStamp: ''!
Finalization and Ephemerons!
!ManifestSystemHashing commentStamp: ''!
Contains different hashing algorithms!
!ManifestSystemHashing class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'System-Platforms' #'Collections-Abstract')
! !

!ManifestSystemLocalization commentStamp: ''!
Localization support!
!ManifestSystemLocalization class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'System-Platforms' #'Collections-Abstract')! !

!ManifestSystemModel class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#'Collections-Abstract')! !

!ManifestSystemObjectEvents commentStamp: ''!
System support for object events (change/update mechanism)!
!ManifestSystemObjectEvents class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Abstract')! !

!ManifestSystemPlatforms commentStamp: ''!
Support for different OS platforms!
!ManifestSystemPlatforms class methodsFor: 'meta-data - dependency analyser' stamp: 'nil'!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'Collections-Abstract')! !

!ManifestSystemSessionManager commentStamp: ''!
Image session management!
!ManifestSystemSessionManager class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'System-Support') ! !

!ManifestSystemSources commentStamp: ''!
Support for source and changes files!
!ManifestSystemSources class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Announcements-Core' #'Collections-Abstract')! !

!ManifestSystemSupport commentStamp: ''!
General support for the Pharo system like access to the VM or image!
!ManifestSystemSupport class methodsFor: 'code-critics' stamp: ''!
ruleInconsistentMethodClassificationRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SystemDictionary #at:put: #false)) #'2021-11-02T18:04:16.398839+01:00') #(#(#RGMethodDefinition #(#SystemDictionary #removeKey:ifAbsent: #false)) #'2021-11-02T18:06:16.506535+01:00') )! !

!ManifestSystemSupport class methodsFor: 'code-critics' stamp: ''!
ruleBadMessageRule2V1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SystemDictionary #poolUsers #false)) #'2021-11-02T17:56:27.52638+01:00') #(#(#RGMethodDefinition #(#SystemDictionary #fillCaches #false)) #'2021-11-02T17:58:27.713429+01:00') )! !

!ManifestSystemSupport class methodsFor: 'code-critics' stamp: ''!
ruleClassNameInSelectorRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#'Author class' #useAuthor:during: #true)) #'2020-06-15T21:10:09.714675+02:00') )! !

!ManifestSystemSupport class methodsFor: 'meta-data - dependency analyser' stamp: ''!
ignoredDependencies
	^ #(#'System-Settings-Core' #'Graphics-Primitives')! !

!ManifestSystemSupport class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Support' #'System-Settings-Core' #'System-Platforms')! !

!ManifestSystemSupport class methodsFor: 'code-critics' stamp: ''!
ruleUtilityMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SystemDictionary #veryDeepCopyWith: #false)) #'2021-11-02T18:14:26.131262+01:00') )! !

!ManifestSystemSupportTests commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestSystemSupportTests class methodsFor: 'code-critics' stamp: ''!
ruleStringConcatenationRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#SystemNavigationTest #testIsMessageSentInSystemWithClassesActuallySendngTheMessage #false)) #'2020-11-13T09:41:27.659044+01:00') #(#(#RGMethodDefinition #(#SystemNavigationTest #testIsMessageSentInSystemWithTheSelectorInsideAnArray #false)) #'2020-11-13T09:41:36.301311+01:00') )! !

!ManifestSystemSupportTests class methodsFor: 'code-critics' stamp: ''!
ruleRefersToClassRuleV1FalsePositive
	^ #(#(#(#RGPackageDefinition #(#'System-Support-Tests')) #'2020-11-13T09:08:21.683585+01:00') )! !

!ManifestTextCore commentStamp: ''!
Handling of Text and related text attributes!
!ManifestTextCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Fonts-Abstract' #'AST-Core')! !

!ManifestTextScanning commentStamp: ''!
Contains classes caring about text scanning!
!ManifestToolBase commentStamp: ''!
Basic tools and tool registry!
!ManifestToolDependencyAnalyser commentStamp: ''!
Dependency analyzer tool and related classes!
!ManifestToolDiff commentStamp: ''!
Package to support displaying changes in the form of diffs for tools!
!ManifestToolExternalBrowser commentStamp: ''!
Package for hosting browsers to acces external infos (like *.cs files and other)!
!ManifestTranscriptCore commentStamp: ''!
Primary package for Transcript related implementation!
!ManifestTranscriptCore class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'System-Support')! !

!ManifestTranscriptNonInteractive commentStamp: ''!
Package for hosting classes to provide non-interactive Transcript (for headless scenario or other)!
!ManifestTranscriptNonInteractive class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Strings' #'System-Support')! !

!ManifestTranscriptTool commentStamp: ''!
Package for hosting the tool related part of Transcript!
!ManifestUIManager commentStamp: ''!
Package for the UI Manager and related classes!
!ManifestUIManager class methodsFor: 'meta-data - dependency analyser' stamp: ''!
ignoredDependencies
	^ #(#CodeImport #'FileSystem-Core' #Files #'Graphics-Display Objects' #'Transcript-NonInteractive' #'System-Settings-Core')! !

!ManifestUIManager class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Collections-Streams' #'System-Support' #'System-Settings-Core')! !

!ManifestUndefinedClassesTests commentStamp: ''!
Please describe the package using the class comment of the included manifest class. The manifest class also includes other additional metadata for the package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestUndefinedClassesTests class methodsFor: 'code-critics' stamp: ''!
ruleUtilityMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#UndefinedClassTest #createClassFromDefinitionString: #false)) #'2021-11-17T07:23:16.420579+01:00') )! !

!ManifestUnicodeInitialization commentStamp: ''!
Class extensions on other Pharo packages in order to give them access to mappings of Unicode values !
!ManifestUnicodeInitialization class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #(#'Zinc-HTTP' #'Zinc-Resource-Meta-Core' #'AST-Core' #'Collections-Streams' #'Collections-Abstract')! !

!ManifestUnifiedFFITests commentStamp: ''!
I store metadata for this package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser!
!ManifestUnifiedFFITests class methodsFor: 'code-critics' stamp: ''!
ruleRBLiteralArrayContainsCommaRuleV1FalsePositive
	^ #(#(#(#RGPackageDefinition #(#'UnifiedFFI-Tests')) #'2019-07-05T11:49:09.935226+02:00') )! !

!ManifestUnifiedFFITests class methodsFor: 'code-critics' stamp: ''!
ruleGRTemporaryNeitherReadNorWrittenRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FFICalloutAPITest #testByteArrayToExternalAddress #false)) #'2019-07-05T11:54:43.174226+02:00') )! !

!ManifestUnifiedFFITests class methodsFor: 'code-critics' stamp: ''!
ruleRBRefersToClassRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FFICompilerPluginTest #testDecompilationOfFFIMethodShouldHaveNamedArgs #false)) #'2019-07-05T11:57:50.898226+02:00') )! !

!ManifestUnifiedFFITests class methodsFor: 'code-critics' stamp: ''!
ruleRBTempsReadBeforeWrittenRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FFICalloutAPITest #testCallWithObjectCreation #false)) #'2019-07-05T11:52:01.493226+02:00') )! !

!ManifestUnifiedFFITests class methodsFor: 'code-critics' stamp: ''!
ruleRBLiteralArrayContainsSuspiciousTrueFalseOrNilRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FFIFunctionParserTest #testParseFunction #false)) #'2019-07-05T12:04:26.431226+02:00') )! !

!ManifestUnifiedFFITests class methodsFor: 'code-critics' stamp: ''!
ruleRBLongMethodsRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FFICalloutTest #testBuildingFnSpec #false)) #'2019-07-05T11:56:50.062226+02:00') )! !

!ManifestUnifiedFFITests class methodsFor: 'code-critics' stamp: ''!
ruleRBShouldntRaiseErrorRuleV1FalsePositive
	^ #(#(#(#RGMethodDefinition #(#FFICalloutAPITest #testCallWithObjectCreation #false)) #'2019-07-05T11:52:11.496226+02:00') #(#(#RGMethodDefinition #(#FFICalloutAPITest #testCallWithObjectParameter #false)) #'2019-07-05T11:52:27.292226+02:00') #(#(#RGMethodDefinition #(#FFICalloutAPITest #testCallWithSelfParameter #false)) #'2019-07-05T11:52:42.022226+02:00') )! !

!ManifestUnifiedFFITests class methodsFor: 'code-critics' stamp: ''!
ruleRBUncommonMessageSendRuleV1FalsePositive
	^ #(#(#(#RGClassDefinition #(#FFIExternalEnumerationTest)) #'2019-07-05T12:00:45.523226+02:00') )! !

!ManyTestResourceTestCase commentStamp: ''!
SUnit tests for handling of many test resources!
!ManyTestResourceTestCase methodsFor: 'utilities' stamp: ''!
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 methodsFor: 'running' stamp: ''!
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 class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^true! !

!ManyTestResourceTestCase class methodsFor: 'accessing' stamp: ''!
resources
	^super resources
		, (Array with: SimpleTestResourceA with: SimpleTestResourceB)! !

!Margin commentStamp: ''!
I represent a margin (for now of rectangle-based operations).

It can be expressed as different objects:

- A number. When specified using a number, it sets all the four values to be the same.

- A point. When specified as a point, pairs top/bottom and left/right take their values from a point y and x. 

- Four numbers. They represent all the four directions.

- A rectangle. (do not use this version because it is proposed just for migration and it may force you to create an unnecessary rectangle).
!
!Margin methodsFor: 'operations' stamp: ''!
insetRectangle: aRectangle
	"Answer a rectangle whose size has been reduced by the receiver. The limitation is that since a rectangle topleft is always less than its bottomright you may have a some cases that are not possible to express. For that you should use a margin object instead of a rectangle."
	
	| l r t b |
	l := aRectangle left 	+ self left.
	r := left max: aRectangle right - self right.
	t := aRectangle top + self top.
	b := top max: aRectangle bottom - self bottom.
	
	^ Rectangle left: l right: r top: t bottom: b! !

!Margin methodsFor: 'accessing' stamp: ''!
bottom
	^ bottom! !

!Margin methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self setTop: 0 left: 0 bottom: 0 right: 0! !

!Margin methodsFor: 'accessing' stamp: ''!
right
	^ right! !

!Margin methodsFor: 'accessing' stamp: ''!
width 
	"Width represents the size (width) of the rubber of the margin, this is why we add right and left margins."
	^ self right + self left! !

!Margin methodsFor: 'initialization' stamp: ''!
fromNumber: anInteger

	self setTop: anInteger 
		left: anInteger 
		bottom: anInteger 
		right: anInteger! !

!Margin methodsFor: 'accessing' stamp: ''!
left
	^ left! !

!Margin methodsFor: 'initialization' stamp: ''!
fromRectangle: aRectangle
	"Pay attention do not use this method but prefer top:left:bottom:right:"
	
	self setTop: aRectangle top 
		left: aRectangle left 
		bottom: aRectangle bottom 
		right: aRectangle right! !

!Margin methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.

	aStream 
		nextPutAll: ' top: ';
		print: top;
		nextPutAll: ' left: ';
		print: left;
		nextPutAll: ' bottom: ';
		print: bottom;
		nextPutAll: ' right: ';
		print: right.! !

!Margin methodsFor: 'accessing' stamp: ''!
height
	"Height represents the height of the rubber of the margin this is why we add bottom and top margins."
	^ self bottom + self top! !

!Margin methodsFor: 'converting' stamp: ''!
asMargin
	^ self! !

!Margin methodsFor: 'testing' stamp: ''!
isZero

	^ (0 = top) 
		and: [ (0 = left) 
				and: [ (0 = right) 
					and: [ 0 = bottom]]]! !

!Margin methodsFor: 'accessing' stamp: ''!
top
	^ top! !

!Margin methodsFor: 'operations' stamp: ''!
expandRectangle: aRectangle
	"Answer a rectangle whose size has been expanded by the receiver which represents each rectangle corner."
	
	^ Rectangle 
		left: aRectangle left - self left 
		right: aRectangle right + self right 
		top: aRectangle top - self top 
		bottom: aRectangle bottom + self bottom! !

!Margin methodsFor: 'operations' stamp: ''!
extendRectangle: aRectangle
	"Answer a rectangle whose size has been expanded (without changing its origin) by the receiver which represents each rectangle corner."
	
	^ Rectangle 
		origin: aRectangle origin 
		corner: aRectangle corner + (self width @ self height)! !

!Margin methodsFor: 'private' stamp: ''!
setTop: topNumber left: leftNumber bottom: bottomNumber right: rightNumber 

	top := topNumber.
	left := leftNumber.
	bottom := bottomNumber. 
	right := rightNumber.! !

!Margin methodsFor: 'initialization' stamp: ''!
fromPoint: aPoint

	self setTop: aPoint y 
		left: aPoint x 
		bottom: aPoint y 
		right: aPoint x! !

!Margin class methodsFor: 'instance creation' stamp: ''!
fromNumber: aNumber
	"Create a margin whose four values are the same and based on anInteger"
	
	^ self new fromNumber: aNumber; yourself! !

!Margin class methodsFor: '*Tool-Finder' stamp: ''!
approvedSelectorsForMethodFinder

	^ self selectors! !

!Margin class methodsFor: 'instance creation' stamp: ''!
left: leftNumber right: rightNumber top: topNumber  bottom: bottomNumber 

	^ self new setTop: topNumber left: leftNumber bottom: bottomNumber right: rightNumber! !

!Margin class methodsFor: 'will be deprecated' stamp: ''!
fromRectangle: aRectangle
	"Create a margin with four values based on aRectangle using exactly top, left, bottom, right semantics. Pay attention that most of the time you should not use this method but prefer top:left:bottom:right:. The reason is that using rectangle may force you to create rectangles with negative extent which is totally wrong and bogus."
	
	^ self new fromRectangle: aRectangle; yourself! !

!Margin class methodsFor: 'instance creation' stamp: ''!
top: topNumber left: leftNumber bottom: bottomNumber right: rightNumber 

	^ self new setTop: topNumber left: leftNumber bottom: bottomNumber right: rightNumber! !

!Margin class methodsFor: 'instance creation' stamp: ''!
left: leftNumber top: topNumber right: rightNumber bottom: bottomNumber 

	^ self new setTop: topNumber left: leftNumber bottom: bottomNumber right: rightNumber! !

!Margin class methodsFor: 'instance creation' stamp: ''!
fromPoint: aPoint
	"Create a margin whose values are based on the point value: top and bottom are y and left right are x."
	
	^ self new fromPoint: aPoint; yourself! !

!MarginBorder commentStamp: ''!
Border with customisable inner margin.!
!MarginBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 	
	^ true! !

!MarginBorderStyle commentStamp: ''!
Border with customisable inner margin.!
!MarginBorderStyle methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		margin: 0! !

!MarginBorderStyle methodsFor: 'accessing' stamp: ''!
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! !

!MarginBorderStyle methodsFor: 'accessing' stamp: ''!
margin
	"Answer the value of margin"

	^ margin! !

!MarginBorderStyle methodsFor: 'accessing' stamp: ''!
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.! !

!MarginBorderStyle methodsFor: 'accessing' stamp: ''!
margin: anObject
	"Set the value of margin"

	margin := anObject! !

!MarginTest commentStamp: ''!
SUnit tests for class Margin!
!MarginTest methodsFor: 'tests' stamp: ''!
testHeight
	"Height represents the height of the rubber of the margin this is why we add them."
	| margin |
	margin := Margin top: 10 left: 20 bottom: 30 right: 40.
	self assert: margin height equals: 40! !

!MarginTest methodsFor: 'tests' stamp: ''!
testExpandRectangle

	| rect |
	rect := 2 asMargin expandRectangle: (0@0 extent: 10@10).
	self assert: rect equals: ((2@2) negated extent: 14@14).
	
	rect := ( 2@1 ) asMargin expandRectangle: (0@0 extent: 10@10).
	self assert: rect equals: ((2@1) negated extent: 14@12).
	
	rect := (Margin top: 1 left: 2 bottom: 3 right: 4) expandRectangle: (0@0 extent: 10@10).
	self assert: rect equals: ((2@1) negated extent: 16@14)! !

!MarginTest methodsFor: 'tests' stamp: ''!
testFromPoint

	| margin |

	margin := Margin fromPoint: 2@1.
	
	self 
		assert: margin left 		equals: 2;
		assert: margin right 		equals: 2;
		assert: margin top 		equals: 1;
		assert: margin bottom 	equals: 1;
		assert: margin width 		equals: 4;
		assert: margin height 	equals: 2.! !

!MarginTest methodsFor: 'tests' stamp: ''!
testWidth
	"Width represents the height of the rubber of the margin this is why we add them."
	| margin |
	margin := Margin top: 10 left: 20 bottom: 30 right: 40.
	self assert: margin width equals: 60! !

!MarginTest methodsFor: 'tests' stamp: ''!
testConstruction
	| margin |
	margin := Margin
		top: 1
		left: 2
		bottom: 3
		right: 4.

	self assert: margin asMargin identicalTo: margin.

	self
		assert: margin left equals: 2;
		assert: margin right equals: 4;
		assert: margin top equals: 1;
		assert: margin bottom equals: 3;
		assert: margin width equals: 6;
		assert: margin height equals: 4! !

!MarginTest methodsFor: 'tests' stamp: ''!
testExtendRectangle

	| rect |
	rect := 2 asMargin extendRectangle: (0@0 extent: 10@10).
	self assert: rect equals: (0@0 extent: 14@14).
	
	rect := ( 2@1 ) asMargin extendRectangle: (0@0 extent: 10@10).
	self assert: rect equals: (0@0 extent: 14@12).
	
	rect := (Margin top: 1 left: 2 bottom: 3 right: 4) extendRectangle: (0@0 extent: 10@10).
	self assert: rect equals: (0@0 extent: 16@14)! !

!MarginTest methodsFor: 'tests' stamp: ''!
testInitialization
	| margin |
	margin := Margin new.

	self assert: margin asMargin identicalTo: margin.

	self
		assert: margin left equals: 0;
		assert: margin right equals: 0;
		assert: margin top equals: 0;
		assert: margin bottom equals: 0;
		assert: margin width equals: 0;
		assert: margin height equals: 0;
		assert: margin isZero equals: true! !

!MarginTest methodsFor: 'tests' stamp: ''!
testInsetRectangle

	| rect |
	rect := 2 asMargin insetRectangle: (0@0 extent: 10@10).
	self assert: rect equals: (2@2 extent: 6@6).
	
	rect := (2@1) asMargin insetRectangle: (0@0 extent: 10@10).
	self assert: rect equals: (2@1 extent: 6@8).
	
	rect := (Margin top: 1 left: 2 bottom: 3 right: 4) insetRectangle: (0@0 extent: 10@10).
	self assert: rect equals: (2@1 extent: 4@6)! !

!MatrixTransform2x3 commentStamp: ''!
This class represents a transformation for points, that is a combination of scale, offset, and rotation. It is implemented as a 2x3 matrix containing the transformation from the local coordinate system in the global coordinate system. Thus, transforming points from local to global coordinates is fast and cheap whereas transformations from global to local coordinate systems are relatively expensive.

Implementation Note: It is assumed that the transformation deals with Integer points. All transformations will return Integer coordinates (even though float points may be passed in here).!
!MatrixTransform2x3 methodsFor: 'accessing' stamp: ''!
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: 'element access' stamp: ''!
a22: value
	 self at: 5 put: value! !

!MatrixTransform2x3 methodsFor: 'comparing' stamp: ''!
= aMatrixTransform2x3 
	| length |
	<primitive: 'primitiveEqual' module: 'FloatArrayPlugin'>
	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: 'transforming points' stamp: ''!
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: 'comparing' stamp: ''!
hash
	| result |
	<primitive: 'primitiveHashArray' module: 'FloatArrayPlugin'>
	result := 0.
	1 
		to: self size
		do: [ :i | result := result + (self basicAt: i) ].
	^ result bitAnd: 536870911! !

!MatrixTransform2x3 methodsFor: 'converting' stamp: ''!
asMatrixTransform2x3
	^self! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: ''!
a23: value
	 self at: 6 put: value! !

!MatrixTransform2x3 methodsFor: 'testing' stamp: ''!
isMatrixTransform2x3
	"Return true if the receiver is 2x3 matrix transformation"
	^true! !

!MatrixTransform2x3 methodsFor: 'testing' stamp: ''!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."
	<primitive: 'primitiveIsPureTranslation' module: 'Matrix2x3Plugin'>
	^self a11 = 1.0 and:[self a12 = 0.0 and:[self a22 = 0.0 and:[self a21 = 1.0]]]! !

!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: ''!
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 |
	EndianDetector isLittleEndian ifTrue: 
		[ 1 
			to: self basicSize
			do: 
				[ :i | 
				w := self basicAt: i.
				b1 := w byteAt: 1.
				b2 := w byteAt: 2.
				b3 := w byteAt: 3.
				b4 := w byteAt: 4.
				w := (b1 << 24) + (b2 << 16) + (b3 << 8) + b4.
				self 
					basicAt: i
					put: w ] ]! !

!MatrixTransform2x3 methodsFor: 'composing' stamp: ''!
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 |
	<primitive: 'primitiveComposeMatrix' module: 'Matrix2x3Plugin'>
	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: 'element access' stamp: ''!
a23
	 ^self at: 6! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: ''!
a21: value
	 self at: 4 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: ''!
a11: value
	 self at: 1 put: value! !

!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: ''!
byteSize
	^self basicSize * self bytesPerBasicElement! !

!MatrixTransform2x3 methodsFor: 'printing' stamp: ''!
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: 'initialize' stamp: ''!
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: 'accessing' stamp: ''!
at: index
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: ''!
a12: value
	 self at: 2 put: value! !

!MatrixTransform2x3 methodsFor: 'private' stamp: ''!
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: ''!
setScale: aPoint 
	"Set the raw scale in the receiver"
	| pt |
	pt := aPoint asPoint.
	self a11: pt x asFloat.
	self a22: pt y asFloat! !

!MatrixTransform2x3 methodsFor: 'composing' stamp: ''!
composedWithLocal: aTransformation
	"Return the composition of the receiver and the local transformation passed in"
	aTransformation isMatrixTransform2x3 ifFalse:[^super composedWithLocal: aTransformation].
	^self composedWithLocal: aTransformation asMatrixTransform2x3 into: self class new! !

!MatrixTransform2x3 methodsFor: 'testing' stamp: ''!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."
	<primitive: 'primitiveIsIdentity' module: 'Matrix2x3Plugin'>
	^self isPureTranslation and:[self a13 = 0.0 and:[self a23 = 0.0]]! !

!MatrixTransform2x3 methodsFor: 'accessing' stamp: ''!
offset
	^self a13 @ self a23! !

!MatrixTransform2x3 methodsFor: 'transforming points' stamp: ''!
transformDirection: aPoint 
	"Transform aPoint from local coordinates into global coordinates"
	| x y |
	x := aPoint x * self a11 + (aPoint y * self a12).
	y := aPoint x * self a21 + (aPoint y * self a22).
	^ x @ y! !

!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: ''!
writeOn: aStream
	aStream nextWordsPutAll: self.! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: ''!
a12
	^self at: 2! !

!MatrixTransform2x3 methodsFor: 'private' stamp: ''!
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: 'transforming points' stamp: ''!
localPointToGlobal: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	<primitive: 'primitiveTransformPoint' module: 'Matrix2x3Plugin'>
	^(self transformPoint: aPoint) rounded! !

!MatrixTransform2x3 methodsFor: 'transforming points' stamp: ''!
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: 'accessing' stamp: ''!
offset: aPoint
	self a13: aPoint x asFloat.
	self a23: aPoint y asFloat.! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: ''!
a13: value
	 self at: 3 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: ''!
a22
	 ^self at: 5! !

!MatrixTransform2x3 methodsFor: 'accessing' stamp: ''!
at: index put: value
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	value isFloat 
		ifTrue:[self basicAt: index put: value asIEEE32BitWord]
		ifFalse:[self at: index put: value asFloat].
	^value! !

!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: ''!
bytesPerBasicElement
	"Answer the number of bytes that each of my basic elements requires.
	In other words:
		self basicSize * self bytesPerBasicElement
	should equal the space required on disk by my variable sized representation."
	^4! !

!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: ''!
localBoundsToGlobal: aRectangle
	"Transform aRectangle from local coordinates into global coordinates"
	^self localBounds: aRectangle toGlobal: Rectangle new! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: ''!
a13
	^self at: 3! !

!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: ''!
globalBoundsToLocal: aRectangle
	"Transform aRectangle from global coordinates into local coordinates"
	^self globalBounds: aRectangle toLocal: Rectangle new! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: ''!
a21
	 ^self at: 4! !

!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: ''!
globalBounds: srcRect toLocal: dstRect
	"Transform aRectangle from global coordinates into local coordinates"
	<primitive: 'primitiveInvertRectInto' module: 'Matrix2x3Plugin'>
	^super globalBoundsToLocal: srcRect! !

!MatrixTransform2x3 methodsFor: 'transforming points' stamp: ''!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	<primitive: 'primitiveInvertPoint' module: 'Matrix2x3Plugin'>
	^(self invertPoint: aPoint) rounded! !

!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: ''!
localBounds: srcRect toGlobal: dstRect
	"Transform aRectangle from local coordinates into global coordinates"
	<primitive: 'primitiveTransformRectInto' module: 'Matrix2x3Plugin'>
	^super localBoundsToGlobal: srcRect! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: ''!
a11
	^self at: 1! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: ''!
identity
	^self new setScale: 1.0! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: ''!
withRotation: angle
	^self new setAngle: angle! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: ''!
new
	^self new: 6! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: ''!
withOffset: aPoint
	^self identity setOffset: aPoint! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: ''!
newFromStream: s
	"Only meant for my subclasses that are raw bits and word-like.  For quick unpack form the disk."
	^ s nextWordsInto: (self new: 6)! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: ''!
withScale: aPoint
	^self new setScale: aPoint! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: ''!
withAngle: angle
	^self new setAngle: angle! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: ''!
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)
"! !

!MczInstaller commentStamp: ''!
An installer for Monticello files with the *.mcz extension. 

   MczInstaller installFileNamed: 'MyKillerApp-Core-Author.1.mcz'!
!MczInstaller methodsFor: 'accessing' stamp: ''!
recordVersionInfo
	Versions 
		at: self extractPackageName 
		put: self extractVersionInfo! !

!MczInstaller methodsFor: 'utilities' stamp: ''!
versions: aVersionList anySatisfy: aDependencyID
	^ aVersionList anySatisfy: [:version | 
			aDependencyID = (version at: #id)
				or: [self versions: (version at: #ancestors) anySatisfy: aDependencyID]]! !

!MczInstaller methodsFor: 'private' stamp: ''!
contentStreamForMember: member
	^[(member contentStreamFromEncoding: 'utf8') text] on: ZnInvalidUTF8
		do: [:exc | 
			"Case of legacy encoding, presumably it is latin-1 and we do not need to do anything
			But if contents starts with a null character, it might be a case of WideString encoded in UTF-32BE"
			| str |
			str := (member contentStreamFromEncoding: 'latin1') text.
			(str peek = Character null and: [ str size \\ 4 = 0 ])
				ifTrue: [str := (WideString fromByteArray: str contents asByteArray) readStream].
			exc return: str]! !

!MczInstaller methodsFor: 'installation' stamp: ''!
install
	| sources |
	zip := ZipArchive new.
	zip readFrom: stream.
	self checkDependencies ifFalse: [^false].
	self recordVersionInfo.
	sources := (zip membersMatching: 'snapshot/*') 
				asSortedCollection: [:a :b | a fileName < b fileName].
	sources do: [:src | self installMember: src].! !

!MczInstaller methodsFor: 'accessing' stamp: ''!
extractVersionInfo
	^ self extractInfoFrom: (self parseMember: 'version')! !

!MczInstaller methodsFor: 'utilities' stamp: ''!
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: ''!
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: 'parsing' stamp: ''!
contentsForMember: member
	^[(member contentStreamFromEncoding: 'utf8') contents] on: ZnInvalidUTF8
		do: [:exc | 
			"Case of legacy encoding, presumably it is latin-1.
			But if contents starts with a null character, it might be a case of WideString encoded in UTF-32BE"
			| str |
			str := (member contentStreamFromEncoding: 'latin1').
			exc return: ((str peek = Character null and: [ str size \\ 4 = 0 ])
				ifTrue: [WideString fromByteArray: str contents asByteArray]
				ifFalse: [str contents])]! !

!MczInstaller methodsFor: 'installation' stamp: ''!
installMember: member
	 
	self useNewChangeSetDuring:
		[ CodeImporter evaluateReadStream: (self contentsForMember: member) readStream.
		]! !

!MczInstaller methodsFor: 'utilities' stamp: ''!
useNewChangeSetDuring: aBlock
	| changeHolder oldChanges newChanges |
	changeHolder := ChangeSet.
	oldChanges := ChangeSet current.
	newChanges := ChangeSet new name: (ChangeSet uniqueNameLike: self extractPackageName).
	changeHolder newChanges: newChanges.
	[ aBlock value ] ensure: [changeHolder newChanges: oldChanges].! !

!MczInstaller methodsFor: 'accessing' stamp: ''!
stream: aStream
	stream := aStream! !

!MczInstaller methodsFor: 'utilities' stamp: ''!
extractInfoFrom: dict
	dict at: #id put: (UUID fromString: (dict at: #id)).
	dict at: #date ifPresent: [:d | d isEmpty ifFalse: [dict at: #date put: (Date fromString: d)]].
	dict at: #time ifPresent: [:t | t isEmpty ifFalse: [dict at: #time put: (Time readFrom: t readStream)]].
	dict at: #ancestors ifPresent: [:a | dict at: #ancestors put: (a collect: [:ea | self extractInfoFrom: ea])].
	^ dict! !

!MczInstaller methodsFor: 'accessing' stamp: ''!
zip
	^zip! !

!MczInstaller methodsFor: 'accessing' stamp: ''!
extractPackageName
	^ (self parseMember: 'package') at: #name.
	! !

!MczInstaller methodsFor: 'utilities' stamp: ''!
parseMember: memberOrName
	| member tokens |
	member := self zip member: memberOrName.
	tokens := (self contentsForMember: member) parseLiterals first.
	^ self associate: tokens! !

!MczInstaller class methodsFor: 'installing' stamp: ''!
installStream: aStream
	(self on: aStream) install! !

!MczInstaller class methodsFor: 'System-FileRegistry' stamp: ''!
extension
	^ 'mcz'! !

!MczInstaller class methodsFor: 'System-FileRegistry' stamp: ''!
fileReaderServicesForFile: fileName suffix: suffix
	<fileService>
	^({ self extension. '*' } includes: suffix)
		ifTrue: [ self services ]
		ifFalse: [#()].
! !

!MczInstaller class methodsFor: 'System-FileRegistry' stamp: ''!
initialize
	self clearVersionInfo! !

!MczInstaller class methodsFor: 'System-FileRegistry' stamp: ''!
serviceLoadVersion
	^ SimpleServiceEntry
		provider: self
		label: 'Load'
		selector: #loadVersionFile:
		description: 'Load a package version'! !

!MczInstaller class methodsFor: 'versioninfo' stamp: ''!
storeVersionInfo: aVersion
	Versions 
		at: aVersion package name
		put: aVersion info asDictionary! !

!MczInstaller class methodsFor: 'instance creation' stamp: ''!
on: aStream
	^ self new stream: aStream! !

!MczInstaller class methodsFor: 'System-FileRegistry' stamp: ''!
services
	^ Array with: self serviceLoadVersion! !

!MczInstaller class methodsFor: 'System-FileRegistry' stamp: ''!
loadVersionFile: fileName
	self installFileNamed: fileName
! !

!MczInstaller class methodsFor: 'versioninfo' stamp: ''!
clearVersionInfo
	Versions := Dictionary new! !

!MczInstaller class methodsFor: 'versioninfo' stamp: ''!
versionInfo
	^ Versions! !

!MczInstaller class methodsFor: 'installing' stamp: ''!
installFileNamed: aFileName
	self installStream: aFileName asFileReference binaryReadStream! !

!MemoryDirectoryEntry commentStamp: ''!
Instances of this class represent a directory entry in a memory file system. So basically this class provides similar behavior as a DiscDirectoryEntry but for a memory file system.!
!MemoryDirectoryEntry methodsFor: 'accessing' stamp: ''!
modificationTime

	^reference modificationTime! !

!MemoryDirectoryEntry methodsFor: 'testing' stamp: ''!
isFile

	^reference isFile! !

!MemoryDirectoryEntry methodsFor: 'testing' stamp: ''!
isReadable
	"The Memory File System doesn't have any access controls"

	^true! !

!MemoryDirectoryEntry methodsFor: 'accessing' stamp: ''!
creationTime

	^reference creationTime! !

!MemoryDirectoryEntry methodsFor: 'accessing' stamp: ''!
deviceId
	"Simulate the device id with the file systemss hash"

	^reference store hash! !

!MemoryDirectoryEntry methodsFor: 'accessing' stamp: ''!
posixPermissions
	"Answer the receivers posix permissions.
	The memory file system doesn't have any access controls"
	
	^8r777! !

!MemoryDirectoryEntry methodsFor: 'accessing' stamp: ''!
fileSize
	"Simulate the device id with the file systems hash"

	^reference fileSize! !

!MemoryDirectoryEntry methodsFor: 'accessing' stamp: ''!
size 
	^reference size! !

!MemoryDirectoryEntry methodsFor: 'testing' stamp: ''!
isWritable
	"The Memory File System doesn't have any access controls"

	^true! !

!MemoryDirectoryEntry methodsFor: 'accessing' stamp: ''!
inode
	"Simulate the inode with the file hash"

	^reference hash! !

!MemoryDirectoryEntry methodsFor: 'testing' stamp: ''!
isDirectory

	^reference isDirectory! !

!MemoryFileSystemDirectory commentStamp: ''!
I represent a memory file system entry for a directory!
!MemoryFileSystemDirectory methodsFor: 'testing' stamp: ''!
isDirectory
	^ true! !

!MemoryFileSystemDirectory methodsFor: 'accessing' stamp: ''!
fileEntryAt: aFileName ifPresent: aBlock
	^ entries at: aFileName ifPresent: aBlock! !

!MemoryFileSystemDirectory methodsFor: 'accessing' stamp: ''!
entries
	^ entries! !

!MemoryFileSystemDirectory methodsFor: 'accessing' stamp: ''!
fileEntryAt: aFileName ifAbsent: aBlock
	^ entries at: aFileName ifAbsent: aBlock! !

!MemoryFileSystemDirectory methodsFor: 'accessing' stamp: ''!
fileEntryRemove: aFileName ifAbsent: absentBlock
	| deletedEntry |
	deletedEntry := entries removeKey: aFileName ifAbsent: [ ^ absentBlock value ].
	modificationTime := DateAndTime now.
	^ deletedEntry! !

!MemoryFileSystemDirectory methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	entries := Dictionary new.! !

!MemoryFileSystemDirectory methodsFor: 'creation' stamp: ''!
ensureCreateDirectory: aDirectoryName
	^ self 
		fileEntryAt: aDirectoryName
		put: (self class named: aDirectoryName)! !

!MemoryFileSystemDirectory methodsFor: 'creation' stamp: ''!
ensureCreateFile: aFileName
	^ self 
		fileEntryAt: aFileName 
		put: (MemoryFileSystemFile named: aFileName)! !

!MemoryFileSystemDirectory methodsFor: 'accessing' stamp: ''!
fileEntryAt: aFileName
	^ entries at: aFileName! !

!MemoryFileSystemDirectory methodsFor: 'accessing' stamp: ''!
fileEntryAt: aFileName put: anEntry
	^ entries 
		at: aFileName 
		ifAbsentPut: [
			self modified.
			anEntry ]! !

!MemoryFileSystemDirectory methodsFor: 'accessing' stamp: ''!
fileSize
	^ 0! !

!MemoryFileSystemDirectory methodsFor: 'accessing' stamp: ''!
fileEntryRemove: aFileName
	^ self fileEntryRemove: aFileName ifAbsent: [ FileDoesNotExistException signalWith: aFileName ]! !

!MemoryFileSystemDirectory methodsFor: 'accessing' stamp: ''!
fileEntriesIncludes: aFileName
	^ entries includesKey: aFileName! !

!MemoryFileSystemDirectory methodsFor: 'enumeration' stamp: ''!
fileEntriesDo: aBlock
	
	entries keys sort do: [ :fileName|
		aBlock value: (entries at: fileName)].! !

!MemoryFileSystemEntry commentStamp: ''!
I am an abstract file system entry for a memory file system.
My subclasses should specialize on the kind of file they are.!
!MemoryFileSystemEntry methodsFor: 'accessing' stamp: ''!
modificationTime
	^ modificationTime! !

!MemoryFileSystemEntry methodsFor: 'testing' stamp: ''!
isFile
	^ self isDirectory not! !

!MemoryFileSystemEntry methodsFor: 'initialization' stamp: ''!
initialize 
	creationTime := modificationTime := DateAndTime now.
	super initialize! !

!MemoryFileSystemEntry methodsFor: 'accessing' stamp: ''!
creationTime
	
	^ creationTime! !

!MemoryFileSystemEntry methodsFor: 'accessing' stamp: ''!
basename
	^ basename! !

!MemoryFileSystemEntry methodsFor: 'accessing' stamp: ''!
fileSize
	self subclassResponsibility! !

!MemoryFileSystemEntry methodsFor: 'accessing' stamp: ''!
basename: aString
	basename := aString! !

!MemoryFileSystemEntry methodsFor: 'private' stamp: ''!
modified
	modificationTime := DateAndTime now.! !

!MemoryFileSystemEntry methodsFor: 'accessing' stamp: ''!
modificationTime: anObject
	
	modificationTime := anObject! !

!MemoryFileSystemEntry methodsFor: 'testing' stamp: ''!
isDirectory
	self subclassResponsibility! !

!MemoryFileSystemEntry class methodsFor: 'instance creation' stamp: ''!
named: aFileName
	^ self new
		basename: aFileName;
		yourself! !

!MemoryFileSystemFile commentStamp: ''!
I represent a memory file system entry for a regular file!
!MemoryFileSystemFile methodsFor: 'open/close' stamp: ''!
basicOpen
	closed := false! !

!MemoryFileSystemFile methodsFor: 'accessing' stamp: ''!
internalSize
	^ bytes size! !

!MemoryFileSystemFile methodsFor: 'accessing' stamp: ''!
truncateTo: aSize
	bytes size = aSize
		ifFalse: [ bytes := bytes size < aSize
				ifTrue: [ (ByteArray new: aSize)
						replaceFrom: 1
						to: bytes size
						with: bytes
						startingAt: 1 ]
				ifFalse: [ bytes copyFrom: 1 to: aSize ] ].
	size := bytes size.
	self modified! !

!MemoryFileSystemFile methodsFor: 'accessing' stamp: ''!
fileSize
	^ size! !

!MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: ''!
at: index
	index > bytes size
		ifTrue: [ SubscriptOutOfBounds
				signalFor: index
				lowerBound: (1 min: bytes size)
				upperBound: bytes size
				in: self ].
	^ bytes at: index! !

!MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: ''!
grow
	self grownBy: self sizeIncrement! !

!MemoryFileSystemFile methodsFor: 'open/close' stamp: ''!
close
	 closed := true! !

!MemoryFileSystemFile methodsFor: 'streams' stamp: ''!
binaryWriteStream
	^ MemoryFileWriteStream on: self! !

!MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: ''!
writeStreamDo: aBlock
	ByteArray
		streamContents: [ :aStream | 
			aBlock value: aStream.
			bytes := aStream contents ].
	self updateSize: bytes size! !

!MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: ''!
readStream
	^ ReadStream on: self bytes asString from: 1 to: size! !

!MemoryFileSystemFile methodsFor: 'accessing' stamp: ''!
sizeIncrement
	^ (bytes size min: 20) max: 1024! !

!MemoryFileSystemFile methodsFor: 'testing' stamp: ''!
isDirectory
	^ false! !

!MemoryFileSystemFile methodsFor: 'streams-compatibility' stamp: ''!
binaryReadStream
	^ ReadStream on: self bytes from: 1 to: size! !

!MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: ''!
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.
	self modified! !

!MemoryFileSystemFile methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	bytes := #[].
	size := 0.
	closed := false! !

!MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: ''!
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.
	self modified! !

!MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: ''!
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: 'testing' stamp: ''!
closed
	^ closed! !

!MemoryFileSystemFile methodsFor: 'private' stamp: ''!
updateContents: aCollection
	bytes := aCollection.
	self updateSize: aCollection size! !

!MemoryFileSystemFile methodsFor: 'accessing' stamp: ''!
size

	^ size! !

!MemoryFileSystemFile methodsFor: 'accessing' stamp: ''!
truncate
	self truncateTo: size! !

!MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: ''!
copyFrom: from to: position
	^ bytes copyFrom: from to: position! !

!MemoryFileSystemFile methodsFor: 'accessing' stamp: ''!
bytes
	^ bytes! !

!MemoryFileSystemFile methodsFor: 'accessing' stamp: ''!
grownBy: length
	bytes := bytes grownBy: length.
	self modified! !

!MemoryFileSystemFile methodsFor: 'private' stamp: ''!
updateSize: newSize
	size := newSize.
	self modified! !

!MemoryFileSystemTest commentStamp: ''!
SUnit tests for MemoryFileSystem!
!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testModifiedTimeWhenFileCreated
	self assert: (filesystem / 'file.txt') ensureCreateFile modificationTime notNil! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testModifiedTimeWhenHandleTruncated
	| modifiedTime fileReference handle |
	fileReference := (filesystem / 'file.txt') ensureCreateFile.
	handle := fileReference openWritable: true.
	modifiedTime := self lastModificationTimeOf: fileReference.
	handle truncate.
	self assert: modifiedTime notNil.
	self deny: modifiedTime equals: fileReference modificationTime! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testNotEqualWhenCreatingNewMemoryFileSystem
	| other |
	other := FileSystem memory.
	self deny: other equals: filesystem! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testCurrentEqual
	| other another |
	another := FileSystem currentMemoryFileSystem.
	other := FileSystem currentMemoryFileSystem.
	self assert: other equals: another! !

!MemoryFileSystemTest methodsFor: 'private' stamp: ''!
createFilesIn: root from: anArray
	"Helper method to create a directory hierarchy with files."

	| dir path |

	dir := (root / anArray first) createDirectory.
	anArray allButFirstDo: [ :each |
		each isArray ifTrue: 
			[ self createFilesIn: dir from: each ]
		ifFalse: 
			[ (path := dir / each) writeStreamDo: [ :stream |
				stream nextPutAll: path pathString ] ] ]! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testCopyFromto

	| fileReference buffer |

	fileReference := filesystem root / 'test.file'.
	buffer := 'test data'.
	filesystem
		copyFrom: buffer readStream 
		to: fileReference path.
	self assert: fileReference contents equals: buffer.! !

!MemoryFileSystemTest methodsFor: 'initialization' stamp: ''!
createFileSystem
	^ FileSystem memory! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testEnsureCreateFileDoesNotOverwriteExistingContent
	| file |
	file := filesystem root / 'a.txt'.
	file writeStreamDo: [ :s | s nextPutAll: 'ok' ].
	self assert: file contents equals: 'ok'.
	
	file ensureCreateFile.

	self assert: file contents equals: 'ok'.! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testModifiedTimeWhenFileModifiedByWriteStream
	| modifiedTime fileReference |
	fileReference := (filesystem / 'file.txt') ensureCreateFile.
	modifiedTime := self lastModificationTimeOf: fileReference.
	fileReference writeStreamDo: [ :aStream | aStream nextPutAll: 'data' ].
	self assert: modifiedTime notNil.
	self deny: modifiedTime equals: fileReference modificationTime! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testModifiedTimeWhenFileModifiedWithBinaryWriteStream
	| modifiedTime fileReference data |
	fileReference := (filesystem / 'file.txt') ensureCreateFile.
	modifiedTime := self lastModificationTimeOf: fileReference.
	data := 'some data'.
	fileReference binaryWriteStreamDo: [ :aStream | aStream nextPutAll: data asByteArray ].
	self assert: modifiedTime notNil.
	self deny: modifiedTime equals: fileReference modificationTime.
	self
		assert: data asByteArray
		equals: (fileReference binaryReadStreamDo: [ :aStream | aStream upToEnd ]).
	self assert: data equals: (fileReference readStreamDo: [ :aStream | aStream upToEnd ])! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testDirectoryMoveToRename
	"Test the scenario where the source is a directory, the destination doesn't exist (its parent does) and they are on separate file systems, i.e. move and rename the source to the destination."
	| srcFS destFS src dest count f33 |

	srcFS := filesystem workingDirectory.
	destFS := FileSystem memory workingDirectory.
	self createFilesIn: srcFS from: #(
		src
		f11
		f12
		#(
			d11
			f21
			f22
			#(
				d21
				f31
				f32)
			#(
				d22
				f33
				f34))).

	[src := srcFS / 'src'.
	count := src allChildren size.
	dest := (destFS / 'dest') ensureCreateDirectory / 'renamed'.
	f33 := dest / 'd11/d22/f33'.
	src copy moveTo: dest.
	self deny: src exists.
	self assert: dest allChildren size equals: count.
	self assert: f33 exists.
	self assert: f33 contents equals: '/src/d11/d22/f33']
		ensure: 
			[ src exists ifTrue: [ src deleteAll ].
			dest exists ifTrue: [ dest deleteAll ] ].! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testStreamWriteAndRead
	"Test writing custom collection and reading it [partially] back."
	
	| writer reader testData |
	testData := ByteArray new: 50 streamContents: [ :out |
						1 to: 50 do: [ :i | out nextPut: i ]
					].
	writer := (filesystem / 'test.out') binaryWriteStream.
	writer next: 20 putAll: testData startingAt: 10.
	writer position: 10; nextPutAll: #[1 2 3 4 5].
	self assert: writer position equals: 15.
	writer close.

	reader := (filesystem / 'test.out') binaryReadStream.
	self assert: reader size equals: 15.
	self assert: (reader next: 15)
			equals: #[10 11 12 13 14 15 16 17 18 19 1 2 3 4 5].

	^ self! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testIsMemoryFileSystem
	self assert: filesystem isMemoryFileSystem.! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
lastModificationTimeOf: fileReference
	"DateAndTime primUTCMicrosecondsClock is not precise across all OS so put in slight delay between calling modificationTime"

	^ [ fileReference modificationTime ]
		ensure: [ (Delay forMilliseconds: 100) wait ]! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testNotEqualWhenRequestingMemoryFileSystem
	| other |
	other := self createFileSystem.
	self deny: other equals: filesystem! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testDirectoryMoveTo
	"Test the scenario where the source is a directory, the destination is an existing directory and they are on separate file systems."
	| srcFS destFS src dest count f33 |

	srcFS := filesystem workingDirectory.
	destFS := FileSystem memory workingDirectory.
	self createFilesIn: srcFS from: #(
		src
		f11
		f12
		#(
			d11
			f21
			f22
			#(
				d21
				f31
				f32)
			#(
				d22
				f33
				f34))).

	[src := srcFS / 'src'.
	count := src allChildren size.
	dest := destFS / 'dest'.
	dest ensureCreateDirectory.
	f33 := dest / 'src/d11/d22/f33'.
	src copy moveTo: dest.
	self deny: src exists.
	self assert: (dest / 'src') allChildren size equals: count.
	self assert: f33 exists.
	self assert: f33 contents equals: '/src/d11/d22/f33']
		ensure: 
			[ src exists ifTrue: [ src deleteAll ].
			dest exists ifTrue: [ dest deleteAll ] ].! !

!MemoryFileSystemTest methodsFor: 'tests' stamp: ''!
testModifiedTimeWhenFileWrittenTo
	| modifiedTime fileReference |
	fileReference := (filesystem / 'file.txt') ensureCreateFile.
	modifiedTime := self lastModificationTimeOf: fileReference.
	fileReference binaryWriteStreamDo: [ :aStream | aStream nextPutAll: 'data' asByteArray ].
	self assert: modifiedTime notNil.
	self deny: modifiedTime equals: fileReference modificationTime! !

!MemoryFileWriteStream commentStamp: ''!
A file write stream - but within memory!
!MemoryFileWriteStream methodsFor: 'positioning' stamp: ''!
position
	^ self stream position! !

!MemoryFileWriteStream methodsFor: 'positioning' stamp: ''!
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."

	self stream position: anInteger! !

!MemoryFileWriteStream methodsFor: 'opening-closing' stamp: ''!
closed
	^ file closed! !

!MemoryFileWriteStream methodsFor: 'accessing' stamp: ''!
file: aMemoryFileSystemFile 
	file := aMemoryFileSystemFile! !

!MemoryFileWriteStream methodsFor: 'testing' stamp: ''!
isBinary
	^ self stream isBinary! !

!MemoryFileWriteStream methodsFor: 'writing' stamp: ''!
next: anInteger putAll: aCollection startingAt: anInteger3 
	
	self stream next: anInteger putAll: aCollection startingAt: anInteger3! !

!MemoryFileWriteStream methodsFor: 'accessing' stamp: ''!
size
	^ file size! !

!MemoryFileWriteStream methodsFor: 'writing' stamp: ''!
nextPut: aCollection
	^ self stream nextPut: aCollection! !

!MemoryFileWriteStream methodsFor: 'opening-closing' stamp: ''!
close
	self flush.
	self stream close.
	file close! !

!MemoryFileWriteStream methodsFor: 'accessing' stamp: ''!
stream
	^ stream ifNil: [ stream := WriteStream on: file bytes from: 1 to: file size ]! !

!MemoryFileWriteStream methodsFor: 'writing' stamp: ''!
flush
	| contents |
	contents := self stream contents.
	(contents size > 0)
		ifTrue: [ file updateContents: contents ]! !

!MemoryFileWriteStream methodsFor: 'writing' stamp: ''!
nextPutAll: aCollection
	^ self stream nextPutAll: aCollection! !

!MemoryFileWriteStream methodsFor: 'positioning' stamp: ''!
setToEnd
	^ self stream setToEnd! !

!MemoryFileWriteStream class methodsFor: 'instance creation' stamp: ''!
on: aFile

	^ self new
		file: aFile;
		yourself! !

!MemoryHandle commentStamp: ''!
I provide "primitives" for doing IO on files in a MemoryFileSystem. I delegate most of my actions to the MemoryFile. This way there is only one place needed where the data is stored.!
!MemoryHandle methodsFor: 'streams' stamp: ''!
binaryReadStream

	^ entry binaryReadStream! !

!MemoryHandle methodsFor: 'public' stamp: ''!
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: ''!
open
	entry := self basicOpen! !

!MemoryHandle methodsFor: 'public' stamp: ''!
at: index put: anObject
	^ entry at: index put: anObject! !

!MemoryHandle methodsFor: 'public' stamp: ''!
at: index read: aCollection startingAt: start count: count 
	^ entry at: index read: aCollection startingAt: start count: count! !

!MemoryHandle methodsFor: 'public' stamp: ''!
truncateTo: anInteger
	entry truncateTo: anInteger! !

!MemoryHandle methodsFor: 'accessing' stamp: ''!
size
	"Return the size for the internal entry"
	^ entry internalSize! !

!MemoryHandle methodsFor: 'public' stamp: ''!
at: index
	^ entry at: index! !

!MemoryHandle methodsFor: 'stream-protocol' stamp: ''!
copyFrom: from to: position
	^ entry copyFrom: from to: position! !

!MemoryHandle methodsFor: 'private' stamp: ''!
grow
	entry grow! !

!MemoryHandle methodsFor: 'public' stamp: ''!
sync
	self flush! !

!MemoryHandle methodsFor: 'public' stamp: ''!
truncate
	entry truncate! !

!MemoryHandle methodsFor: 'public' stamp: ''!
close
	self isOpen ifFalse: [ ^ self ].
	self truncate.
	entry := nil! !

!MemoryHandle methodsFor: 'testing' stamp: ''!
isOpen
	^ entry notNil! !

!MemoryHandle methodsFor: 'streams' stamp: ''!
binaryWriteStream
	
	^ entry binaryWriteStream! !

!MemoryHandle methodsFor: 'public' stamp: ''!
flush
	self truncate! !

!MemoryHandle methodsFor: 'stream-protocol' stamp: ''!
grownBy: length
	entry grownBy: length! !

!MemoryHandleTest commentStamp: ''!
SUnit tests for memory handles, the tests may be found in superclass!
!MemoryHandleTest methodsFor: 'running' stamp: ''!
createFileSystem
	^ FileSystem memory! !

!MemoryLogger commentStamp: ''!
This signal logger simply records the signals that it receives.

###Example1: Instance usage

```
	(MemoryLogger new 
		runDuring: [ 
			StringSignal emit: 'This is a message' ]	)
				inspect.
```

###Example 2: Global usage

```
	MemoryLogger reset.
	MemoryLogger start.
	StringSignal emit: 'This is a message' .
	MemoryLogger instance recordings inspect.
	MemoryLogger stop.
```!
!MemoryLogger methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	mutex := Mutex new.
	self reset.
	announcer := Announcer new.
! !

!MemoryLogger methodsFor: 'accessing' stamp: ''!
recordings
	"It answers a copy of the recorded collection to not grant
	access to the users to a shared resource that should only be 
	modified via the mutex"
	^ recordings copy! !

!MemoryLogger methodsFor: 'utilities' stamp: ''!
nextPut: aSignal
	mutex critical: [
		recordings add: aSignal ].
	"the announcement is passed forward so that potential viewers
	can refresh when something changes. we do not create another announcement
	because it is not needed given that the only thing that can happen is
	for a new announcement to be recorded"
	self announcer announce: aSignal! !

!MemoryLogger methodsFor: 'initialize' stamp: ''!
reset
	"it simply removes all recordings without
	affecting the running status of the logger"
	mutex critical: [
		recordings := OrderedCollection new ]! !

!MemoryLogger methodsFor: 'ston persistence' stamp: ''!
saveStonFile: aFileReference

	"Save the receiver to the supplied file name"

	| stream |
	stream := ZnCharacterWriteStream
		          on: (GZipWriteStream on: aFileReference asFileReference nextVersion binaryWriteStream)
		          encoding: 'utf8'.
	[ STON put: self onStreamPretty: stream ] ensure: [ stream close ]! !

!MemoryLogger methodsFor: 'accessing' stamp: ''!
announcer 
	"The announcer announces to potential watchers (typically viewers)
	that a new signal was recorded"
	^ announcer! !

!MemoryLogger class methodsFor: 'accessing' stamp: ''!
writePeriod: aDuration

	WritePeriod := aDuration! !

!MemoryLogger class methodsFor: 'private' stamp: ''!
writeLoop
	"Write the default instance out to a file every WritePeriod"

	[ self instance saveStonFile: self writeFilename.
	self writePeriod wait ] repeat.! !

!MemoryLogger class methodsFor: 'accessing' stamp: ''!
writePeriod

	^ WritePeriod ifNil: [ WritePeriod := 60 seconds ]! !

!MemoryLogger class methodsFor: 'saving' stamp: ''!
startAutoSaving
	"Write the default instance to a file every WritePeriod"
	<script>
	
	WriteProcess ifNotNil: [ self error: 'Write process already running' ].

	WriteProcess := [ self writeLoop ]
		                forkAt: Processor userInterruptPriority
		                named: self class name , ' auto-save'! !

!MemoryLogger class methodsFor: 'saving' stamp: ''!
stopAutoSaving
	"Terminate writing the default instance to a file every WritePeriod"
	<script>
		
	WriteProcess ifNil: [ ^ self ].
	WriteProcess terminate.
	100 milliSeconds wait.
	WriteProcess isTerminated ifFalse: [ 
		self error: 'Unable to terminate auto-save process' ].
	WriteProcess := nil! !

!MemoryLogger class methodsFor: 'accessing' stamp: ''!
writeFilename: aFilename

	WriteFilename := aFilename ! !

!MemoryLogger class methodsFor: 'accessing' stamp: ''!
writeFilename

	^ WriteFilename ifNil: [ 
		  WriteFilename := String streamContents: [ :stream | 
			                   stream
				                   << self name;
				                   << '-';
				                   print: LibC uniqueInstance currentProcessId;
				                   << '.stgz' ] ]! !

!MemoryLogger class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	
	self instance reset! !

!MemoryLogger class methodsFor: 'saving' stamp: ''!
fromStonFile: aFileReference

	| logger |

	logger := aFileReference asFileReference binaryReadStreamDo: [ :bstream |
		STON fromStream: (ZnCharacterReadStream 
			on: (GZipReadStream on: bstream)
			encoding: 'utf8') ].
	^logger! !

!MemoryLoggerTest methodsFor: 'testing' stamp: ''!
testRecordOneSignal
	| logger |
	logger := MemoryLogger new runDuring: [ StringSignal emit: 'test' ].
	self assert: logger recordings size equals: 1.
	self assert: logger recordings first message equals: 'test'! !

!MemoryLoggerTest methodsFor: 'testing' stamp: ''!
testRunDuringStopsAtTheEnd
	| logger |
	logger := MemoryLogger new.
	logger runDuring: [ 
		self assert: logger isRunning ].
	self assert: logger isRunning not! !

!MemoryLoggerTest methodsFor: 'testing' stamp: ''!
testRecordTwoSignalsInTheRightOrder
	| logger |
	logger := MemoryLogger new 
					runDuring: [ 
						StringSignal emit: 'test1'.
						StringSignal emit: 'test2' ].
	self assert: logger recordings size equals: 2.
	self assert: logger recordings first message equals: 'test1'.
	self assert: logger recordings last message equals: 'test2'! !

!MemoryStore commentStamp: ''!
I'm a specific store for memory file system!
!MemoryStore methodsFor: 'public' stamp: ''!
checkName: aString fixErrors: fixErrors
	aString ifEmpty: [ self error: 'zero length file name' ].
	^ aString! !

!MemoryStore methodsFor: 'printing' stamp: ''!
forReferencePrintOn: aStream
	aStream nextPutAll: 'memory://'! !

!MemoryStore methodsFor: 'private' stamp: ''!
basicEntry: entry nodesDo: aBlock
	entry fileEntriesDo: aBlock! !

!MemoryStore methodsFor: 'private' stamp: ''!
nodeAt: aPath ifPresent: presentBlock ifAbsent: absentBlock
	| current |
	aPath isRoot
		ifTrue: [ ^ presentBlock value: self root ].
	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: ''!
replaceFile: path in: aBlock
	^ self
		nodeAt: path parent
		ifPresent: [ :entry | | old new |
			entry isDirectory
				ifFalse: [ self signalFileDoesNotExist: path ].
			old := entry fileEntryAt: path basename ifAbsent: [ self signalFileDoesNotExist: path ].
			new := aBlock value: old.
			entry fileEntryAt: path basename put: new ]
		ifAbsent: [ self signalFileDoesNotExist: path ]! !

!MemoryStore methodsFor: 'private' stamp: ''!
basicSizeOf: aMemoryFileSystemEntry
	"Return the basic size of aMemoryFileSystemEntry"
	^ aMemoryFileSystemEntry fileSize! !

!MemoryStore methodsFor: 'private' stamp: ''!
basicEntry: directoryEntry path: aPath nodesDo: aBlock
	directoryEntry fileEntriesDo: aBlock! !

!MemoryStore methodsFor: 'private' stamp: ''!
createFile: aPath
	^ self
		nodeAt: aPath parent
		ifPresent: [ :entry | 
			entry isDirectory
				ifTrue: [ entry ensureCreateFile: aPath basename ]]
		ifAbsent: [ self signalDirectoryDoesNotExist: aPath parent ]! !

!MemoryStore methodsFor: 'testing' stamp: ''!
isMemoryFileSystem
	^ true! !

!MemoryStore methodsFor: 'accessing' stamp: ''!
root
	^ root! !

!MemoryStore methodsFor: 'private' stamp: ''!
basicIsDirectory: aMemoryFileSystemEntry
	^ aMemoryFileSystemEntry isDirectory! !

!MemoryStore methodsFor: 'private' stamp: ''!
basicIsSymlink: aNode
	^false! !

!MemoryStore methodsFor: 'private' stamp: ''!
basicPosixPermissions: anEntry
	^ 8r777! !

!MemoryStore methodsFor: 'private' stamp: ''!
basicIsFile: aMemoryFileSystemEntry
	^ aMemoryFileSystemEntry isFile! !

!MemoryStore methodsFor: 'private' stamp: ''!
basicModificationTimeOf: aMemoryFileSystemEntry
	"Return the basic modification time of aMemoryFileSystemEntry"
	^ aMemoryFileSystemEntry modificationTime! !

!MemoryStore methodsFor: 'testing' stamp: ''!
isReadable: aPath
	"Answer a boolean indicating whether the supplied path is a readable entry (directory or file).
	MemoryStore doesn't implement access controls, always true if the file exists."

	^self exists: aPath! !

!MemoryStore methodsFor: 'initialization' stamp: ''!
initialize 
	root := MemoryFileSystemDirectory new! !

!MemoryStore methodsFor: 'public' stamp: ''!
basenameFromEntry: aMemoryFileSystemEntry
	^ aMemoryFileSystemEntry basename! !

!MemoryStore methodsFor: 'private' stamp: ''!
basicOpen: path writable: aBoolean
	^ self
		nodeAt: path
		ifPresent: [ :aMemoryFileSystemEntry | 
			aMemoryFileSystemEntry
				basicOpen;
				yourself ]
		ifAbsent: [ aBoolean
				ifFalse: [ self signalFileDoesNotExist: path ]
				ifTrue: [ self createFile: path ] ]! !

!MemoryStore methodsFor: 'private' stamp: ''!
copy: sourcePath ifAbsent: absentBlock to: destinationPath ifPresent: presentBlock fileSystem: aFilesystem
        | sourceNode destinationNode |

        sourceNode := self
                nodeAt: sourcePath
                ifPresent: [ :source | source ]
                ifAbsent: [ ^ absentBlock value].

        sourceNode isDirectory
                ifTrue: [ ^ absentBlock value ].

        destinationNode := self
                nodeAt: destinationPath parent
                ifPresent: [ :destination |  destination ]
                ifAbsent: [ ^ self signalDirectoryDoesNotExist: destinationPath parent ].

        destinationNode isFile
                ifTrue: [ self signalDirectoryDoesNotExist: destinationPath parent ].

        (destinationNode fileEntriesIncludes: destinationPath basename)
                ifTrue: [ "cannot overwrite existing file"^ presentBlock value ].

        destinationNode
                fileEntryAt: destinationPath basename
                put: (sourceNode copy
                                        basename: destinationPath basename;
                                        yourself)! !

!MemoryStore methodsFor: 'public' stamp: ''!
createDirectory: path
	| parent |
	parent := path parent.
	^ self
		nodeAt: parent
		ifPresent: [ :entry | 
			entry
				fileEntryAt: path basename
				ifPresent: [ :node | 
					node isDirectory
						ifTrue: [ self signalDirectoryExists: path ]
						ifFalse: [ self signalFileExists: path ] ].
			entry ensureCreateDirectory: path basename  ]
		ifAbsent: [ self signalDirectoryDoesNotExist: parent ]! !

!MemoryStore methodsFor: 'private' stamp: ''!
nodeAt: aPath
	| current |
	current := self root.
	aPath do: [ :segment | 
		current isDirectory
			ifTrue: [ current := current fileEntryAt: segment ifAbsent: [ ^ FileDoesNotExistException signalWith: aPath ]]
			ifFalse: [ ^ FileDoesNotExistException signalWith: aPath ]].
	^ current! !

!MemoryStore methodsFor: 'public' stamp: ''!
rename: sourcePath to: destinationPath
	| sourceEntry destinationParentEntry newName |
	
	sourceEntry := self nodeAt: sourcePath.
	newName := destinationPath basename.
	
	destinationParentEntry := self nodeAt: destinationPath parent.
	
	destinationParentEntry isDirectory
		ifFalse: [ Error signal: 'Copy destination has to be a directory' ].
	destinationParentEntry 
		fileEntryAt: newName
		ifPresent: [ Error signal: 'Destination file exists already' ].
		
	destinationParentEntry 
		fileEntryAt: newName
		put: sourceEntry.
	sourceEntry basename: newName.
	
	
	(self nodeAt: sourcePath parent)
		fileEntryRemove: sourcePath basename! !

!MemoryStore methodsFor: 'accessing' stamp: ''!
isRegular: aPath
	"Answer a boolean indicating whether the entry at aPath is writable.
	Memory store only supports regular files."

	^self isFile: aPath! !

!MemoryStore methodsFor: 'public' stamp: ''!
delete: path
	self 
		nodeAt: path parent
		ifPresent: [ :dict | 
			dict fileEntryRemove: path basename ifAbsent: [ FileDoesNotExistException signalWith: path ]] 
		ifAbsent: [ DirectoryDoesNotExist signalWith: path parent ]! !

!MemoryStore methodsFor: 'accessing' stamp: ''!
handleClass
	^ MemoryHandle! !

!MemoryStore methodsFor: 'testing' stamp: ''!
isWritable: aPath
	"Answer a boolean indicating whether the supplied path is a writable entry (directory or file).
	MemoryStore doesn't implement access controls, always true if the file exists."

	^self exists: aPath! !

!MemoryStore methodsFor: 'private' stamp: ''!
basicCreationTimeOf: aMemoryFileSystemEntry
	"Returns the creation date of aMemoryFileSystemEntry"
	^ aMemoryFileSystemEntry creationTime! !

!MemoryStore methodsFor: 'public' stamp: ''!
entryFromNode: node path: path for: aFileSystem

	| entryPath |
	entryPath := path / (self basenameFromEntry: node).
	^MemoryDirectoryEntry reference: (FileReference fileSystem: aFileSystem path: entryPath).! !

!MemoryStore class methodsFor: 'system startup' stamp: ''!
startUp
	self reset! !

!MemoryStore class methodsFor: 'class initialization' stamp: ''!
initialize
	"self initialize"

	SessionManager default registerSystemClassNamed: self name! !

!MemoryStore class methodsFor: 'current' stamp: ''!
currentFileSystem
	^ CurrentFS ifNil: [ CurrentFS := FileSystem store: MemoryStore new ]! !

!MemoryStore class methodsFor: 'public' stamp: ''!
delimiter
	^ $/! !

!MemoryStore class methodsFor: 'public' stamp: ''!
separator 
	^ $:! !

!MemoryStore class methodsFor: 'public' stamp: ''!
isCaseSensitive
	^ true! !

!MemoryStore class methodsFor: 'class initialization' stamp: ''!
reset
	CurrentFS := nil! !

!MenuCapturingMorph commentStamp: ''!
It's difficult to test whether menus appear because the test might block the UI thread and prevent it.

I use Morphic stepping to monitor the world for a new menu. If I find one, you can get it by sending me #menu.!
!MenuCapturingMorph methodsFor: 'stepping and presenter' stamp: ''!
step

	menu := self currentWorld submorphs detect: [ :m | m isKindOf: MenuMorph ] ifNone: [ menu ].
	menu
		ifNotNil: [ menu delete.
			self delete
			]! !

!MenuCapturingMorph methodsFor: 'menu' stamp: ''!
menu

	^ menu.! !

!MenuGroupPresenter commentStamp: ''!
I am a group of menu items.

I am part of a menu (MenuPresenter), and groups items (MenuItemPresenter) by meaning.

You can also have a look at ApplicationWithToolbar for a full example of how to use them.

I provide the following methods
- addItem: use the block in parameter to initialize a new item, then add it in my collection.
- addMenuItem: add the item in parameter in my collection.
- isEmpty return a boolean representing if my collection is empty.
- menuItems getter of my collection.


todo
- autoRefresh
- buildWithSpecLayout:
- fromSpec:!
!MenuGroupPresenter methodsFor: 'testing' stamp: ''!
isEmpty

	^ items isEmpty! !

!MenuGroupPresenter methodsFor: 'api-building' stamp: ''!
fromSpec: aSpec

	aSpec addToMenuGroupModel: self! !

!MenuGroupPresenter methodsFor: 'api' stamp: ''!
autoRefresh: aBoolean

	autoRefresh value: aBoolean! !

!MenuGroupPresenter methodsFor: 'api' stamp: ''!
addItem: aBlock
	| item |
	
	item := MenuItemPresenter new.
	aBlock value: item.
	self addMenuItem: item! !

!MenuGroupPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	items := OrderedCollection new asValueHolder.
	autoRefresh := nil asValueHolder.
	autoRefresh whenChangedDo: [ :aBoolean | self menuItems do: [ :each | each autoRefresh: aBoolean ] ]! !

!MenuGroupPresenter methodsFor: 'api' stamp: ''!
menuItems

	^ items value! !

!MenuGroupPresenter methodsFor: 'api' stamp: ''!
autoRefresh

	^ autoRefresh value! !

!MenuGroupPresenter methodsFor: 'private' stamp: ''!
addMenuItem: aMenuItem

	items add: aMenuItem.
	self autoRefresh 
		ifNotNil: [ aMenuItem autoRefresh: self autoRefresh ]! !

!MenuGroupPresenter methodsFor: 'private' stamp: ''!
buildWithSpecLayout: aSpecLayout
	"Build the widget using the spec name provided as argument"
	| adapter widget|
	adapter := self adapterFrom: aSpecLayout model: self.
	widget := adapter asWidget.
	self announce: (WidgetBuilt model: self widget: widget).
	^ widget! !

!MenuGroupPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(MenuGroupAdapter
		adapt: #(model))! !

!MenuGroupPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #MenuGroupAdapter! !

!MenuItemMorph commentStamp: ''!
I represent an item in a menu.



Instance variables:
	isEnabled 	<Boolean>	True if the menu item can be executed.
	subMenu 	<MenuMorph | nil>	The submenu to activate automatically when the user mouses over the item.
	isSelected 	<Boolean>	True if the item is currently selected.
	target 		<Object>		The target of the associated action.
	selector 		<Symbol>	The associated action.
	arguments 	<Array>		The arguments for the associated action.
	icon		<Form | nil>	An optional icon form to be displayed to my left.

!
!MenuItemMorph methodsFor: 'drawing' stamp: ''!
drawSubmenuMarkerOn: aCanvas
	| subMenuMarker subMenuMarkerPosition |
	self hasSubMenu
		ifFalse: [ ^ self ].
	subMenuMarker := self subMenuMarker.
	subMenuMarkerPosition := (self right - subMenuMarker width) @ ((self top + self bottom - subMenuMarker height) // 2).
	aCanvas paintImage: subMenuMarker at: subMenuMarkerPosition! !

!MenuItemMorph methodsFor: 'private' stamp: ''!
upArrow

	^ UpArrow! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
deselectTimeOut: evt
	"Deselect timout. Now really deselect"

	owner selectedItem == self
		ifTrue: [ 
			evt hand newMouseFocus: owner.
			owner selectItem: nil event: evt ]! !

!MenuItemMorph methodsFor: 'testing' stamp: ''!
shouldBeHighlighted
	^ isSelected and: [ isEnabled ]! !

!MenuItemMorph methodsFor: 'private' stamp: ''!
onImage
	"Return the form to be used for indicating an on marker"
	| form |
	form := Form extent: (self fontToUse ascent-2) asPoint depth: 16.
	(form getCanvas)
		frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.8) 
			borderWidth: 1 borderColor: Color black;
		fillRectangle: (form boundingBox insetBy: 2) fillStyle: Color black.
	^form! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
themeChanged
	"Also pass on to the submenu if any."

	super themeChanged.
	self subMenu ifNotNil:[ :m | m themeChanged ]! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
invokeWithEvent: evt
	"Perform the action associated with the given menu item."

	| w |
	self isEnabled ifFalse: [^ self].
	owner ifNotNil:[self isStayUpItem ifFalse:[
		self flag: #workAround. "The tile system invokes menus straightforwardly so the menu might not be in the world."
		(w := self world) ifNotNil:[
			owner deleteIfPopUp: evt.
			"Repair damage before invoking the action for better feedback"
			w displayWorldSafely]]].
	selector ifNil:[^self].
	Cursor normal showWhile: [ | selArgCount |  "show cursor in case item opens a new MVC window"
		(selArgCount := selector numArgs) = 0
			ifTrue:
				[target perform: selector]
			ifFalse:
				[selArgCount = arguments size
					ifTrue: [target perform: selector withArguments: arguments]
					ifFalse: [target perform: selector withArguments: (arguments copyWith: evt)]].
		self showShortcut.
		self changed].! !

!MenuItemMorph methodsFor: 'copying' stamp: ''!
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: 'selecting' stamp: ''!
deselect: evt
	self isSelected: false.
	subMenu ifNotNil: [
		owner ifNotNil:[owner activeSubmenu: nil].
		self removeAlarm: #deselectTimeOut:].! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
hasMarker
	"Answer whether the receiver has a marker morph."
	^self hasSubmorphs! !

!MenuItemMorph methodsFor: 'private' stamp: ''!
selectionTextColor
	^ color negated! !

!MenuItemMorph methodsFor: 'testing' stamp: ''!
isMenuItemMorph
	^ true! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
subMenu: aMenuMorph

	subMenu := aMenuMorph.
	self changed.! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
icon: aForm 
	"change the the receiver's icon"
	icon := aForm.! !

!MenuItemMorph methodsFor: 'drawing' stamp: ''!
drawIconOn: aCanvas
	| iconForm |
	self hasIcon ifFalse: [ ^ self ].
	
	iconForm := self iconForm.
	aCanvas translucentImage: iconForm at: bounds left @ (self top + ((self height - iconForm height) // 2))! !

!MenuItemMorph methodsFor: 'private' stamp: ''!
rightArrow

	^ SubMenuMarker! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
target: anObject

	target := anObject.! !

!MenuItemMorph methodsFor: 'drawing' stamp: ''!
menuStringBounds
	| stringBounds |
	stringBounds := bounds.
	self hasIcon ifTrue: [ | iconForm |
		iconForm := self iconForm.
		stringBounds := stringBounds left: stringBounds left + iconForm width + 2 ].
	self hasMarker ifTrue: [ 
		stringBounds := stringBounds left: stringBounds left + self submorphBounds width + 8 ].
	^ stringBounds top: (stringBounds top + stringBounds bottom - self fontToUse height) // 2! !

!MenuItemMorph methodsFor: 'private' stamp: ''!
bottomArrow

	^ BottomArrow! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
hasIcon
	"Answer whether the receiver has an icon."
	^ icon notNil! !

!MenuItemMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"

	super initialize.
	""

	contents := ''.
	hasFocus := false.
	isEnabled := true.
	isSelected := false.
	font := StandardFonts menuFont.
	self
		hResizing: #spaceFill;
		vResizing: #shrinkWrap! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
arguments

	^ arguments! !

!MenuItemMorph methodsFor: 'selecting' stamp: ''!
adjacentTo
	^ {self bounds topRight + (10 @ 0). self bounds topLeft}! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
doButtonAction
	"Called programattically, this should trigger the action for which the receiver is programmed"

	self invokeWithEvent: nil! !

!MenuItemMorph methodsFor: 'private' stamp: ''!
leftArrow

	^ LeftArrow! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
mouseEnter: evt
	"The mouse entered the receiver"

	owner ifNotNil: [owner stayUp ifFalse: [self mouseEnterDragging: evt]].! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
activateOwnerMenu: evt
	"Activate our owner menu; e.g., pass control to it.
	 If it does not contain the pointer position, pass it through the owner chain."

	| popUpOwner |
	(owner isNil or: [ owner isMenuMorph not ]) ifTrue: [ ^ false ].
	(owner fullContainsPoint: evt position)
		ifTrue: [ 
			owner activate: evt.
			^ true ].
	popUpOwner := owner popUpOwner.
	[ popUpOwner ]
		whileNotNil: [ 
			(popUpOwner owner fullContainsPoint: evt position)
				ifTrue: [ 
					popUpOwner owner activate: evt.
					^ true ]
				ifFalse: [ popUpOwner := popUpOwner owner popUpOwner ] ].
	^ false! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
selector

	^ selector! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
showShortcut

	ShortcutReminder showShortcut: self! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
enabled
	"Delegate to exisitng method."

	^self isEnabled! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
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 deselect: evt.
	self invokeWithEvent: evt.! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
handlesMouseDown: evt

	^ true! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
isStayUpItem

	^selector == #toggleStayUp:! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
target

	^ target! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
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: #pharoFixMe.
	(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.
	(#('<on>' '<off>' '<yes>' '<no>') includes: marker) 
		ifFalse: [^super contents: aString].
	self contentString: aString.	"remember actual string"
	marker := (marker = '<on>' or: [marker = '<yes>']) ~= inverse 
				ifTrue: [self onImage]
				ifFalse: [self offImage].
	super contents:  (aString copyFrom: markerIndex + 1 to: aString size)].
	"And set the marker"
	marker := ImageMorph new form: marker.
	marker position: self left @ (self top + 2).
	self addMorphFront: marker! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
hasIconOrMarker
	"Answer whether the receiver has an icon or a marker."
	^ self hasIcon or: [ self hasMarker ]! !

!MenuItemMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawSubMenuMarkerOnAthensCanvas: anAthensCanvas
	self hasSubMenu
		ifFalse: [ ^ self ].
	anAthensCanvas pathTransform
		restoreAfter: [ 
			anAthensCanvas pathTransform translateX: self extent x - self subMenuMarker width Y: 0.
			anAthensCanvas pathTransform translateX: 0 Y: (self subMenuMarker height //2).
			anAthensCanvas setPaint: self subMenuMarker.
			anAthensCanvas drawShape: (0 @ 0 extent: self subMenuMarker extent) ]! !

!MenuItemMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawIconOnAthensCanvas: anAthensCanvas
	self hasIcon
		ifFalse: [ ^ self ].
	anAthensCanvas setPaint: self iconForm.
	anAthensCanvas drawShape: (0 @ 0 extent: self iconForm extent).
	anAthensCanvas pathTransform translateX: self iconForm width + 2 Y: 0! !

!MenuItemMorph methodsFor: 'initialization' stamp: ''!
deleteIfPopUp: evt
	"Recurse up for nested pop ups"
	owner ifNotNil:[owner deleteIfPopUp: evt].! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
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: 'drawing' stamp: ''!
drawOn: aCanvas
	| stringColor |
	stringColor := self shouldBeHighlighted
		ifTrue: [ aCanvas fillRectangle: self bounds fillStyle: self selectionFillStyle.
			self selectionTextColor ]
		ifFalse: [ color ].
	self drawIconOn: aCanvas.
	aCanvas
		drawString: self contents
		in: self menuStringBounds
		font: self fontToUse
		color: stringColor.
	self drawSubmenuMarkerOn: aCanvas! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
isEnabled

	^ isEnabled! !

!MenuItemMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawBackgroundOnAthensCanvas: anAthensCanvas
	(isSelected and: [ isEnabled ])
		ifFalse: [ ^ self ].
	anAthensCanvas setPaint: self selectionFillStyle.
	anAthensCanvas drawShape: (0 @ 0 extent: self extent)! !

!MenuItemMorph methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterPreview: aBuilder

	^ self balloonText spotterPreview: aBuilder! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
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: 'accessing' stamp: ''!
arguments: aCollection

	arguments := aCollection.! !

!MenuItemMorph methodsFor: 'selecting' stamp: ''!
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: 'events' stamp: ''!
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: 'selecting' stamp: ''!
isSelected: aBoolean

	isSelected := aBoolean.
	self changed.! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
mouseLeave: evt
	"The mouse has left the interior of the receiver..."

	owner ifNotNil: [owner stayUp ifFalse: [self mouseLeaveDragging: evt]]! !

!MenuItemMorph methodsFor: '*NewTools-Spotter-Processors' stamp: ''!
withAllLeafItemsDo: aBlockClosure

	self subMenu ifNil: [ ^ aBlockClosure cull: self ].
	self subMenu items do: [ :anItem | anItem withAllLeafItemsDo: aBlockClosure ]! !

!MenuItemMorph methodsFor: 'private' stamp: ''!
selectionFillStyle
	"answer the fill style to use with the receiver is the selected  
	element"

	Display depth <= 2 ifTrue: [ ^ Color gray ].
	^ self theme menuSelectionColor! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
icon
	"answer the receiver's icon"
	^ icon! !

!MenuItemMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawLabelOnAthensCanvas: anAthensCanvas
	anAthensCanvas pathTransform translateX: 0 Y: self fontToUse getPreciseAscent.
			anAthensCanvas
				setPaint: self color;
				setFont: self fontToUse;
				drawString: contents.! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
handlesMouseOver: anEvent
	^true! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
keyText: anObject
	"Set the value of keyText"

	keyText := anObject! !

!MenuItemMorph methodsFor: 'meta actions' stamp: ''!
deselectItem
	| item |
	self isSelected: false.
	subMenu ifNotNil: [subMenu deleteIfPopUp].
	(owner isMenuMorph) ifTrue:
		[item := owner popUpOwner.
		(item isMenuItemMorph) ifTrue: [item deselectItem]].! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	"Delegate to exisitng method."

	self isEnabled: aBoolean! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
contents: aString
	^self contents: aString withMarkers: true! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
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: 'private' stamp: ''!
iconForm
	"private - answer the form to be used as the icon"
	^ isEnabled
		ifTrue: [self icon]
		ifFalse: [self icon asGrayScale]! !

!MenuItemMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	| bnd |
	bnd := self bounds topLeft + self layoutInset.
	anAthensCanvas pathTransform
		restoreAfter: [ 
			anAthensCanvas pathTransform translateBy: bnd.
			self drawBackgroundOnAthensCanvas: anAthensCanvas.
			self drawIconAndLabelOnAthensCanvas: anAthensCanvas.
			self drawSubMenuMarkerOnAthensCanvas: anAthensCanvas ]! !

!MenuItemMorph methodsFor: 'testing' stamp: ''!
isEnabled: aBoolean

	isEnabled = aBoolean ifTrue: [^ self].
	isEnabled := aBoolean.
	self color: (aBoolean ifTrue: [Color black] ifFalse: [Color gray]).! !

!MenuItemMorph methodsFor: 'initialization' stamp: ''!
defaultBounds
"answer the default bounds for the receiver"
	^ 0 @ 0 extent: 10 @ 10! !

!MenuItemMorph methodsFor: '*SUnit-Support-UITesting' stamp: ''!
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: 'copying' stamp: ''!
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: 'events' stamp: ''!
handlesMouseOverDragging: evt
	^true! !

!MenuItemMorph methodsFor: 'layout' stamp: ''!
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: 'grabbing' stamp: ''!
aboutToBeGrabbedBy: aHand
	"Don't allow the receiver to act outside a Menu"
	| menu box |
	(owner notNil and:[owner hasSubmorphs ]) 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: 'accessing' stamp: ''!
contentString
	^self valueOfProperty: #contentString! !

!MenuItemMorph methodsFor: 'private' stamp: ''!
subMenuMarker
	"private - answer the form to be used as submenu marker"
	 ^ self rightArrow! !

!MenuItemMorph methodsFor: 'meta actions' stamp: ''!
wantsHaloFromClick
	"Only if I'm not a lonely submenu"
	^owner notNil and:[ owner hasSubmorphs ]! !

!MenuItemMorph methodsFor: 'grabbing' stamp: ''!
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: 'selecting' stamp: ''!
isSelected
	^ isSelected! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
selector: aSymbol

	selector := aSymbol.! !

!MenuItemMorph methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
stActDefault
	self doButtonAction! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
contentString: aString 
	aString ifNil: [self removeProperty: #contentString]
		ifNotNil: [self setProperty: #contentString toValue: aString]! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
mouseDown: evt
	"Handle a mouse down event. Menu items get activated when the mouse is over them."

	(evt shiftPressed and: [ self isEditable ])
		ifTrue: [^ super mouseDown: evt].  "enable label editing"
	evt hand newMouseFocus: owner. "Redirect to menu for valid transitions"
	owner selectItem: self event: evt.! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
hasSubMenu: aMenuMorph
	subMenu ifNil:[^false].
	subMenu == aMenuMorph ifTrue:[^true].
	^subMenu hasSubMenu: aMenuMorph! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
contents: aString withMarkers: aBool
	^self contents: aString withMarkers: aBool inverse: false! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
hasSubMenu
	"Return true if the receiver has a submenu"
	^subMenu notNil! !

!MenuItemMorph methodsFor: 'layout' stamp: ''!
minHeight
	| iconHeight |
	iconHeight := self hasIcon
				ifTrue: [self icon height + 2]
				ifFalse: [0].
	^ self fontToUse height max: iconHeight! !

!MenuItemMorph methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
keyText
	"Answer the value of keyText"

	^ keyText! !

!MenuItemMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawIconAndLabelOnAthensCanvas: anAthensCanvas
	anAthensCanvas pathTransform
		restoreAfter: [ 
			self drawIconOnAthensCanvas: anAthensCanvas.
			self drawLabelOnAthensCanvas: anAthensCanvas ]! !

!MenuItemMorph methodsFor: 'accessing' stamp: ''!
subMenu

	^ subMenu! !

!MenuItemMorph methodsFor: 'events' stamp: ''!
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
		ifNil: [ owner selectItem: nil event: evt ]
		ifNotNil: [ self addAlarm: #deselectTimeOut: with: evt after: 500 ]! !

!MenuItemMorph class methodsFor: 'initialization' stamp: ''!
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) asFormOfDepth: 32.
	BottomArrow := SubMenuMarker rotateBy: 90.
	LeftArrow := SubMenuMarker rotateBy: 180.
	UpArrow := SubMenuMarker rotateBy: 270.! !

!MenuItemPresenter commentStamp: ''!
I represent a menu item.

You can also have a look at ApplicationWithToolbar for a full example of how to use them.

I collaborate with MenuGroupPresenter to manage me.

I provide the following variables and their accessors
- name is the text I display.
- icon is the text I display.
- description is the text I display in my tooltip.
- action is the action to perform when I am clicked.
- subMenu is the submenu to display when I am clicked.

Usually I do NOT have an action AND a submenu.

todo
- autoRefresh
- enabled
- fromSpec:
- performMenuActionWith:
- shortcut is ..., the shortcut is displayed near my name.
- state!
!MenuItemPresenter methodsFor: 'accessing' stamp: ''!
action: aBlock

	action value: aBlock! !

!MenuItemPresenter methodsFor: 'api-building' stamp: ''!
fromSpec: aSpec

	aSpec addToMenuItemModel: self! !

!MenuItemPresenter methodsFor: 'accessing' stamp: ''!
autoRefresh: aBlock

	autoRefresh value: aBlock! !

!MenuItemPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	action := [] asValueHolder.
	enabled := true asValueHolder.
	state := nil asValueHolder.
	description := nil asValueHolder.
	name := '' asValueHolder.
	shortcut := nil asValueHolder.
	subMenu := nil asValueHolder.
	autoRefresh := false asValueHolder.
	icon := nil asValueHolder! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
shortcut: aShortcut

	shortcut value: aShortcut! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
iconName: aSymbol

	icon value: (self iconNamed: aSymbol)! !

!MenuItemPresenter methodsFor: 'accessing' stamp: ''!
action

	^ action value! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
description: aString

	description value: aString! !

!MenuItemPresenter methodsFor: 'accessing' stamp: ''!
state: aBoolean

	state value: aBoolean! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
description

	^ description value! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
performMenuActionWith: aMenuItem
	| en |
	
	en := self enabled.
	en isBlock ifTrue: [ en := en value ].
	en ifFalse: [ ^ self ].
	
	action value cull: aMenuItem ! !

!MenuItemPresenter methodsFor: 'accessing' stamp: ''!
autoRefresh

	^ autoRefresh value! !

!MenuItemPresenter methodsFor: 'accessing' stamp: ''!
enabled

	^ enabled value! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
name

	^ name value! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
icon

	^ icon value! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
name: aString

	name value: aString! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
shortcut

	^ shortcut value! !

!MenuItemPresenter methodsFor: 'accessing' stamp: ''!
state

	^ state value! !

!MenuItemPresenter methodsFor: 'accessing' stamp: ''!
enabled: aBoolean

	enabled value: aBoolean! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
subMenu: aMenuModel

	subMenu value: aMenuModel! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
icon: anIcon

	icon value: anIcon! !

!MenuItemPresenter methodsFor: 'api' stamp: ''!
subMenu

	^ subMenu value! !

!MenuItemPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(MenuItemAdapter
		adapt: #(model))! !

!MenuItemPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #MenuItemAdapter! !

!MenuLineMorph commentStamp: ''!
A MenuLineMorph is a item separator in menu.
!
!MenuLineMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	self theme flatMenu 
		ifFalse: [
			aCanvas
				fillRectangle: (bounds topLeft corner: bounds rightCenter)
				color: self baseColor twiceDarker .
			aCanvas
				fillRectangle: (bounds leftCenter corner: bounds bottomRight)
				color: self baseColor twiceLighter ]
		ifTrue: [
			aCanvas
				fillRectangle: (bounds topLeft corner: bounds bottomRight)
				color: self baseColor ]! !

!MenuLineMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self hResizing: #spaceFill; vResizing: #spaceFill.! !

!MenuLineMorph methodsFor: 'layout' stamp: ''!
minWidth
	"Answer the receiver's minWidth"
	^  10 * self displayScaleFactor! !

!MenuLineMorph methodsFor: 'testing' stamp: ''!
isMenuLineMorph
	^ true! !

!MenuLineMorph methodsFor: 'private' stamp: ''!
baseColor
	^ self theme autoMenuColor
		ifTrue: [ owner color twiceDarker ]
		ifFalse: [ 
			self theme currentSettings flatMenu
				ifFalse: [ owner color ]
				ifTrue: [ owner color twiceDarker ] ]! !

!MenuLineMorph methodsFor: 'layout' stamp: ''!
minHeight
	"Answer the receiver's minHeight"
	^ self theme menuBorderWidth! !

!MenuLineMorph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	self theme flatMenu
		ifFalse: [ 
			anAthensCanvas setPaint: self baseColor twiceDarker.
			anAthensCanvas drawShape: (bounds topLeft corner: bounds rightCenter).
			anAthensCanvas setPaint: self baseColor twiceLighter.
			anAthensCanvas drawShape: (bounds leftCenter corner: bounds bottomRight) ]
		ifTrue: [ 
			anAthensCanvas setPaint: self baseColor.
			anAthensCanvas drawShape: (bounds topLeft corner: bounds bottomRight) ]! !

!MenuMorph commentStamp: ''!
Instance variables:
	defaultTarget 	<Object>				The default target for creating menu items
	selectedItem		<MenuItemMorph> 	The currently selected item in the receiver
	stayUp 			<Boolean>			True if the receiver should stay up after clicks
	popUpOwner 	<MenuItemMorph>	The menu item that automatically invoked the receiver, if any.
	activeSubMenu 	<MenuMorph>		The currently active submenu.!
!MenuMorph methodsFor: 'accessing' stamp: ''!
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: 'construction' stamp: ''!
addToggle: aString selector: aSymbol
	"Append a menu item with the given label. If the item is selected,
	it will send the given selector to the default target object."

	self addToggle: aString
		target: defaultTarget
		selector: aSymbol
		getStateSelector: nil
		argumentList: EmptyArray! !

!MenuMorph methodsFor: 'construction' stamp: ''!
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: 'construction' stamp: ''!
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: 'modal control' stamp: ''!
modalSelection: anObject
	selection := anObject.
	self deleteIfPopUp! !

!MenuMorph methodsFor: '*Tool-FileList' stamp: ''!
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: 'events' stamp: ''!
pinboxClicked

	self stayUp: true.
	"todo improve (make the pinbox toggleable perhaps?"! !

!MenuMorph methodsFor: 'construction' stamp: ''!
balloonTextForLastItem: balloonText
	submorphs last setBalloonText: balloonText! !

!MenuMorph methodsFor: 'private' stamp: ''!
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: (aWorld activeHand position y) + 1)).
	delta = (0 @ 0) ifFalse: [self position: self position + delta]! !

!MenuMorph methodsFor: 'construction' stamp: ''!
add: aLabelString target: anObject selector: aSymbol iconName: iconName
	"Append a menu item with the given label and the iconName. If the item is selected, it will send the given selector to the target object."

	^ (self
		add: aLabelString
		target: anObject
		selector: aSymbol
		argumentList: EmptyArray)
		icon: (self iconNamed: iconName);
		yourself! !

!MenuMorph methodsFor: 'menu' stamp: ''!
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: 'events' stamp: ''!
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]].
	"If we aren't under the hand anymore, transfer to the owner"
   (self fullContainsPoint: evt position) ifFalse:[
	popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: evt) ifTrue:[^self]]]! !

!MenuMorph methodsFor: 'events' stamp: ''!
recordFiltering: matchString
	self setProperty: #matchString toValue: matchString! !

!MenuMorph methodsFor: 'copying' stamp: ''!
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: '*Tool-FileList' stamp: ''!
addServices: services for: served extraLines: linesArray

	services withIndexDo: [:service :i |
		self 
		addService: service for: served;
		balloonTextForLastItem: service description.
		(service usingLineAfter or: [linesArray includes: i]) 
			ifTrue: [ self addLine ]
	].
! !

!MenuMorph methodsFor: 'construction' stamp: ''!
add: aLabelString 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: aLabelString
		target: anObject
		selector: aSymbol
		argumentList: EmptyArray.! !

!MenuMorph methodsFor: 'initialization' stamp: ''!
delete

	activeSubMenu ifNotNil:[activeSubMenu delete].
	^super delete! !

!MenuMorph methodsFor: 'events' stamp: ''!
activateFromKeyboard: evt
	"Receiver should be activated; e.g., so that control passes correctly."
	evt hand newMouseFocus: self.
	self activate: evt.
	self takeKeyboardFocus.
	self moveSelectionDown: 1 event: evt! !

!MenuMorph methodsFor: 'private' stamp: ''!
selectedItem
	^selectedItem! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
lastSelection
	"Return the label of the last selected item or nil."

	^selectedItem ifNotNil: [selectedItem selector].! !

!MenuMorph methodsFor: 'control' stamp: ''!
displayAt: aPoint during: aBlock
	"Add this menu to the Morphic world during the execution of the given block."
	self currentWorld addMorph: self centeredNear: aPoint.
	self world displayWorld.  "show myself"
	aBlock value.
	self delete! !

!MenuMorph methodsFor: 'construction' stamp: ''!
addAllFromPragma: aString target: anObject
	self addAllFrom: (PragmaMenuBuilder 
		pragmaKeyword: aString
		model: anObject)
		menu! !

!MenuMorph methodsFor: 'construction' stamp: ''!
addUpdating: aWordingSelector target: aTarget selector: aSymbol

	self addUpdating: aWordingSelector target: aTarget selector: aSymbol argumentList: EmptyArray! !

!MenuMorph methodsFor: 'menu' stamp: ''!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'add title...' selector: #addTitle.
	aCustomMenu add: 'set target...' selector: #setTarget:.
	defaultTarget ifNotNil: [
		aCustomMenu add: 'add item...' selector: #addItem].
	aCustomMenu add: 'add line' selector: #addLine.
	(self items anySatisfy: [ :any | any hasSubMenu ]) ifTrue: [
		 aCustomMenu add: 'detach submenu' selector: #detachSubMenu: ].! !

!MenuMorph methodsFor: 'control' stamp: ''!
popUpInWorld: aWorld
	"Present this menu under control of the given hand."
	^self popUpAt: aWorld primaryHand position forHand: aWorld primaryHand in: aWorld! !

!MenuMorph methodsFor: 'private' stamp: ''!
setDefaultParameters
	"change the receiver's appareance parameters"

	self
		color: self theme settings derivedMenuColor;
		borderWidth: self theme menuBorderWidth;
		borderColor: self theme menuBorderColor.
	 self theme settings flatMenu 
		ifFalse: [
			self borderStyle: BorderStyle thinGray.
			self
				hasDropShadow: true;
				shadowColor:  self theme menuShadowColor;
				shadowOffset: 1 @ 1].
	self layoutInset: 3.
	self cellInset: 0@1.! !

!MenuMorph methodsFor: 'menu' stamp: ''!
setInvokingView: invokingView
	"Re-work every menu item of the form
		<target> perform: <selector>
	to the form
		<target> perform: <selector> orSendTo: <invokingView>.
	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: 'construction' stamp: ''!
add: aLabelString 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."
	"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: aLabelString
		target: defaultTarget
		selector: aSymbol
		argumentList: EmptyArray.! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
popUpOwner
	"Return the current pop-up owner that is the menu item that automatically initiated the receiver."
	^popUpOwner! !

!MenuMorph methodsFor: 'actions' stamp: ''!
adoptPaneColor: paneColor
	"Change our color."
	
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	self color: paneColor! !

!MenuMorph methodsFor: 'events' stamp: ''!
rightArrowStroked: evt
	"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.
			^ true ].
		
	^ false! !

!MenuMorph methodsFor: 'dropping/grabbing' stamp: ''!
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: 'events' stamp: ''!
handlesMouseDown: evt
	^true! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
rootMenu
	popUpOwner ifNil: [^ self].
	popUpOwner owner ifNil: [^ self].
	^ popUpOwner owner rootMenu! !

!MenuMorph methodsFor: 'keyboard control' stamp: ''!
removeMatchString
	"Remove the matchString, if any."
	self setProperty: #matchString toValue: String new.
	self displayFiltered: nil! !

!MenuMorph methodsFor: 'construction' stamp: ''!
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: 'invoking' stamp: ''!
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.
	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."
	
  ^ self
		invokeAt: self currentWorld activeHand position
		in: self currentWorld! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
popUpOwner: aMenuItemMorph
	"Set the current pop-up owner"
	popUpOwner := aMenuItemMorph.! !

!MenuMorph methodsFor: 'events' stamp: ''!
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 
			ifEmpty: [ 0@0 ]
			ifNotEmpty: [ :col | col first position - self position. ]
	] ifNotNil: [ selectedItem 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: ''!
keyDown: evt
	"Handle keboard item matching."

	| matchString key selectable |
	key := evt key.
	(key = KeyboardKey enter or: [key = KeyboardKey keypadEnter])
		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 ].
	key = KeyboardKey escape
		ifTrue: [ "escape key"
			self
				valueOfProperty: #matchString
				ifPresentDo: [ :str | 
					str isEmpty
						ifFalse: [ "If filtered, first ESC removes filter"
							self setProperty: #matchString toValue: String new.
							self selectItem: nil event: evt.
							^ self displayFiltered: evt ] ].
			"If a stand-alone menu, just delete it"
			popUpOwner ifNil: [ ^ self delete ].
			"If a sub-menu, then deselect, and return focus to outer menu"
			^ self deselectAndFocusOutermenuOn: evt ].

	"Left arrow key - If we are in a submenu, then we remove myself (i.e., the current morph) and move the focus to the owner popup"
	key isArrowLeft ifTrue: [ ^ self leftArrowStroked: evt ].

	"Right arrow key - If the selected menu item has a submenu, then we move the focus to the submenu "
	key isArrowRight ifTrue: [ (self rightArrowStroked: evt) ifTrue: [ ^ self ] ].
	key isArrowUp ifTrue: [ ^ self moveSelectionDown: -1 event: evt ].	"up arrow key"
	key isArrowDown ifTrue: [ ^ self moveSelectionDown: 1 event: evt ].	"down arrow key"
	key = KeyboardKey pageUp ifTrue: [ ^ self moveSelectionDown: -5 event: evt ].	"page up key"
	key = KeyboardKey pageDown ifTrue: [ ^ self moveSelectionDown: 5 event: evt ].	"page down key"

	"If we reach this point, it means that we are editing the filter associated to each menu. "
	"In case ther eis no filter associated to the menu, we simply create one"
	matchString := self valueOfProperty: #matchString ifAbsentPut: [ String new ].

	"If we press the backspace, then we simply remove the last character from matchString"
	(key = KeyboardKey backspace and: [ matchString notEmpty ])
		ifTrue: [ matchString := matchString allButLast.
			self recordFiltering: matchString.
			self displayFiltered: evt ].! !

!MenuMorph methodsFor: 'keyboard control' stamp: ''!
displayFiltered: evt
	| matchStr matches feedbackMorph |

	matchStr := self valueOfProperty: #matchString.
	matches := self menuItems 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 lastSubmorph 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. (Yet :D)"
       (evt notNil and: [ matches size >= 1 ]) 
		ifTrue: [self selectItem: matches first event: evt]! !

!MenuMorph methodsFor: 'menu' stamp: ''!
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: 'events' stamp: ''!
activate: evt
	"Receiver should be activated; e.g., so that control passes correctly."
	evt hand newMouseFocus: self! !

!MenuMorph methodsFor: 'control' stamp: ''!
popUpInWorld
	"Present this menu in the current World"

	^ self popUpInWorld: self currentWorld! !

!MenuMorph methodsFor: 'actions' stamp: ''!
toggleStayUp

	^stayUp := stayUp not! !

!MenuMorph methodsFor: 'construction' stamp: ''!
add: aLabelString 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: aLabelString
		target: target
		selector: aSymbol
		argumentList: (Array with: arg)! !

!MenuMorph methodsFor: 'copying' stamp: ''!
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"! !

!MenuMorph methodsFor: 'menu' stamp: ''!
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: '*SUnit-Support-UITesting' stamp: ''!
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: 'control' stamp: ''!
selectItem: aMenuItem event: anEvent
	selectedItem ifNotNil:[selectedItem deselect: anEvent].
	selectedItem := aMenuItem.
	selectedItem ifNotNil:[selectedItem select: anEvent].! !

!MenuMorph methodsFor: 'events' stamp: ''!
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: 'keyboard control' stamp: ''!
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: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher
	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #MorphFocusNavigation! !

!MenuMorph methodsFor: 'construction' stamp: ''!
addMenuItem: anItem
	"Like addMorphBack: but returns the argument. The return value is used by the
	#addToggle:target:selector: and #addTarget:selector: families of messages."

	self addMorphBack: anItem.
	^ anItem! !

!MenuMorph methodsFor: 'construction' stamp: ''!
add: aLabelString selector: aSymbol argument: arg

	^ self add: aLabelString
		target: defaultTarget
		selector: aSymbol
		argumentList: (Array with: arg)! !

!MenuMorph methodsFor: 'construction' stamp: ''!
add: aLabelString subMenu: aMenuMorph 
	"Append the given submenu with the given label."
	self
		add: aLabelString
		icon: nil
		subMenu: aMenuMorph! !

!MenuMorph methodsFor: 'modal control' stamp: ''!
modalSelection
	^ selection! !

!MenuMorph methodsFor: 'private' stamp: ''!
invokeMetaMenu: evt
	stayUp ifFalse:[^self]. "Don't allow this"
	^super invokeMetaMenu: evt! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
embeddable: aBoolean
	self setProperty: #embeddable toValue: aBoolean! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
lastItem

	submorphs reverseDo: [ :each | (each isMenuItemMorph) ifTrue: [ ^each ] ].
	^submorphs last! !

!MenuMorph methodsFor: 'construction' stamp: ''!
addLine
	"Append a divider line to this menu. Suppress duplicate lines."
	(self hasItems and: [ self lastSubmorph isMenuLineMorph not ])
		ifTrue: [ self addMorphBack: MenuLineMorph new ].
		
		
		
	"(self hasItems)
		ifTrue: [ self addMorphBack: MenuLineMorph new .self addMorphBack: MenuLineMorph new]."
		
	"Looks ok when allowing more than one line after another line...."! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
menuItems
	^submorphs select: [ :m | m isMenuItemMorph ]! !

!MenuMorph methodsFor: 'keyboard control' stamp: ''!
keyboardFocusChange: aBoolean
	"Notify change due to green border for keyboard focus"
	super keyboardFocusChange: aBoolean.
	self changed! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
stayUp

	^ stayUp! !

!MenuMorph methodsFor: 'keyboard control' stamp: ''!
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: 'control' stamp: ''!
popUpEvent: evt in: aWorld
	"Present this menu in response to the given event."

	| aHand aPosition |
	aHand := evt ifNotNil: [evt hand] ifNil: [ self activeHand ].
	aPosition := aHand position truncated.
	^ self popUpAt: aPosition forHand: aHand in: aWorld! !

!MenuMorph methodsFor: 'construction-UIManager' stamp: ''!
addTitle

	| string |
	string := UIManager default request: 'Title for this menu?'.
	string isEmptyOrNil ifTrue: [^ self].
	self addTitle: string.! !

!MenuMorph methodsFor: 'utilities' stamp: ''!
addSeparator
	
	self addMenuItem: MenuLineMorph new! !

!MenuMorph methodsFor: 'actions' stamp: ''!
themeChanged
	"Update the colour if specified."

	self color: (self theme menuColorFor: nil).
	super themeChanged! !

!MenuMorph methodsFor: 'construction' stamp: ''!
add: aLabelString icon: aForm subMenu: aMenuMorph
	"Append the given submenu with the given label."

	self addToggle: aLabelString target: nil selector: nil.
	self lastItem
		icon: aForm;
		subMenu: aMenuMorph.
	^ self! !

!MenuMorph methodsFor: 'control' stamp: ''!
deselectAndFocusOutermenuOn: anEvent
	"deselect and return focus to outer menu"

	self selectItem: nil event: anEvent.
	anEvent hand newMouseFocus: popUpOwner owner.
	^ anEvent hand newKeyboardFocus: popUpOwner owner! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
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: 'menu' stamp: ''!
detachSubMenu: evt
	| possibleTargets item subMenu index |
	possibleTargets := self items select:[ :any | any hasSubMenu].
	possibleTargets isEmpty ifTrue: [ ^self ].
	
	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: 'construction' stamp: ''!
addUpdating: aWordingSelector selector: aSymbol

	self addUpdating: aWordingSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray! !

!MenuMorph methodsFor: 'control' stamp: ''!
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: ''!
layoutItems
	"decorate aMenu with icons"

	| maxIconWidth |
	maxIconWidth := 0.

	self items do: [:item | 
		item icon ifNotNil: [maxIconWidth := maxIconWidth max: item icon width].
		item hasSubMenu ifTrue: [item subMenu layoutItems]].
	maxIconWidth isZero 
		ifFalse: [self addBlankIconsIfNecessary: (Smalltalk ui icons blankIconOfWidth: maxIconWidth)].! !

!MenuMorph methodsFor: 'menu' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	super initialize.

	self setDefaultParameters.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	stayUp := false.
	self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber.
	self theme currentSettings preferRoundCorner ifTrue: [ self useRoundedCorners ]! !

!MenuMorph methodsFor: 'construction-title' stamp: ''!
createTitleMorph

	titleMorph ifNotNil: [ titleMorph delete ].
	titleMorph := MenuTitleMorph new.
	
	titleMorph 
	on: #mouseDown send: #mouseDownInTitle: to: self.
	"maxCellSize:World width /2;"
	
	self addMorphFront: titleMorph.! !

!MenuMorph methodsFor: 'keyboard control' stamp: ''!
moveUp: evt 
	^self moveSelectionDown: -1 event: evt! !

!MenuMorph methodsFor: 'menu' stamp: ''!
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: 'construction' stamp: ''!
addAllFrom: aMenuMorph
	"This is a fast add..."
	
	aMenuMorph submorphsDo: [ :m | self addMorphBack: m ]! !

!MenuMorph methodsFor: 'filtering' stamp: ''!
getFiltering: matchString
	^ self valueOfProperty: #matchString ifAbsentPut: [ String new ]! !

!MenuMorph methodsFor: 'private' stamp: ''!
restoreFocus: originalFocusHolder in: aWorld
	"restore only if current focus holder is nil "

	aWorld primaryHand keyboardFocus ifNotNil: [ ^ self ].
	originalFocusHolder ifNotNil: [ aWorld primaryHand newKeyboardFocus: originalFocusHolder ]! !

!MenuMorph methodsFor: 'menu' stamp: ''!
removeStayUpItems

	self menuItems
		select: [ :menuItem | menuItem isStayUpItem ]
		thenDo: [ :each | each delete ].! !

!MenuMorph methodsFor: 'events' stamp: ''!
keyStroke: evt
	"Handle keboard item matching."

	| matchString char asc 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.

	"If we reach this point, it means that we are editing the filter associated to each menu. "
	"In case ther eis no filter associated to the menu, we simply create one"
	matchString := self valueOfProperty: #matchString ifAbsentPut: [ String new ].

	"No need to go further if the character is not alphanumeric, i.e., not useful for filtering"
	char isAlphaNumeric ifFalse: [ ^ self ].

	matchString := matchString , char asString.
	self recordFiltering: matchString.
	self displayFiltered: evt! !

!MenuMorph methodsFor: 'construction' stamp: ''!
addList: aList
	"Add the given items to this menu, where each item is a pair (<string> <actionSelector>)..  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 translated selector: tuple second.
					(tuple size > 2 and: [ tuple third notNil ])
						ifTrue: [ self balloonTextForLastItem: tuple third translated ].
					(tuple size > 3 and: [ tuple fourth notNil ])
						ifTrue: [ self lastItem icon: (self iconNamed: tuple fourth) ] ] ]! !

!MenuMorph methodsFor: 'actions' stamp: ''!
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 isMenuItemMorph]) ifTrue: [
		popUpOwner isSelected: false.
		(popUpOwner owner isMenuMorph)
			ifTrue: [popUpOwner owner deleteIfPopUp]].! !

!MenuMorph methodsFor: 'events' stamp: ''!
updateColor
	"Update the color of the menu."

	self theme preferGradientFill
		ifFalse: [ ^ self ].
	self fillStyle: (self theme menuFillStyleFor: self).	
	"update the title color"
	
	titleMorph ifNotNil: [ :tm | tm fillStyle: (self theme menuTitleFillStyleFor: tm )]! !

!MenuMorph methodsFor: 'control' stamp: ''!
activeSubmenu: aSubmenu 
	activeSubMenu
		ifNotNil: [activeSubMenu delete].
	activeSubMenu := aSubmenu.! !

!MenuMorph methodsFor: 'events' stamp: ''!
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: 'construction-title' stamp: ''!
buildTitle: aBlock 
	
"
	Example usage:

	menu buildTitle: [ :titleMorph | titleMorph
		title: 'aCoolTitle';
		icon: self theme icons alertIcon;
		withCloseBox;
		withPinBox;
		color: Color purple		
	].
"
	
	titleMorph ifNil: [ self createTitleMorph ].
	
	aBlock value: titleMorph.! !

!MenuMorph methodsFor: 'construction-title' stamp: ''!
addTitle: aString
	"Add a title line at the top of this menu."
	
	 self buildTitle: [ :tm | tm title: aString ].! !

!MenuMorph methodsFor: 'testing' stamp: ''!
isMenuMorph
	^ true! !

!MenuMorph methodsFor: 'events' stamp: ''!
leftArrowStroked: evt
	"If a stand-alone menu, do nothing"
	popUpOwner ifNil: [ ^ self ].
	"If a sub-menu, then deselect, and return focus to outer menu"
	^ self deselectAndFocusOutermenuOn: evt! !

!MenuMorph methodsFor: 'construction-title' stamp: ''!
addTitle: aString icon: aForm
	"Add a title line at the top of this menu."
	
	aForm ifNil: [ ^self addTitle: aString ].
	
	self buildTitle: [ :tm | tm 
		title: aString;
		icon: aForm
	].! !

!MenuMorph methodsFor: 'control' stamp: ''!
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: 'drawing' stamp: ''!
drawOn: aCanvas 
	"Draw the menu. Add keyboard-focus feedback if appropriate"

	super drawOn: aCanvas.

	(self activeHand notNil
			and: [ self activeHand keyboardFocus == self
					and: [self rootMenu hasProperty: #hasUsedKeyboard]])
		ifTrue: [
			aCanvas
				frameAndFillRectangle: self innerBounds
				fillColor: Color transparent
				borderWidth: self theme menuBorderWidth
				borderColor: self theme menuKeyboardFocusColor
		].! !

!MenuMorph methodsFor: 'control' stamp: ''!
popUpNoKeyboard
	"Present this menu in the current World, *not* allowing keyboard input into the menu"

	^ self popUpAt: self activeHand position forHand: self activeHand in: self currentWorld allowKeyboard: false! !

!MenuMorph methodsFor: 'construction-UIManager' stamp: ''!
addItem

	| string sel |
	string := UIManager default request: 'Label for new item?'.
	string isEmpty ifTrue: [^ self].
	sel := UIManager default request: 'Selector?'.
	sel isEmpty ifFalse: [sel := sel asSymbol].
	self add: string selector: sel.! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
defaultTarget: anObject
	"Set the default target for adding menu items."

	defaultTarget := anObject.! !

!MenuMorph methodsFor: 'dropping/grabbing' stamp: ''!
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: 'construction' stamp: ''!
add: aLabelString 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: aLabelString
		target: target
		selector: aSymbol
		getStateSelector: nil
		enablementSelector: nil
		argumentList: argList! !

!MenuMorph methodsFor: 'control' stamp: ''!
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: ''!
popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean 
	"Present this menu at the given point under control of the given  
	hand."
	| evt |
	aWorld submorphs
		select: [ :each | (each isKindOf: MenuMorph)
			and: [each stayUp not]]
		thenCollect: [ :menu | menu delete].

	self items isEmpty
		ifTrue: [^ self].

	self layoutItems.
	"precompute width"
	self
		positionAt: aPoint
		relativeTo: (selectedItem
				ifNil: [self items first])
		inWorld: aWorld.
	aWorld addMorphFront: self.
	"Acquire focus for valid pop up behavior"
	hand newMouseFocus: self.
	aBoolean
		ifTrue: [hand newKeyboardFocus: self].
	evt := hand lastEvent.
	(evt isKeyboard
			or: [evt isMouse
					and: [evt anyButtonPressed not]])
		ifTrue: ["Select first item if button not down"
			self moveSelectionDown: 1 event: evt].
	self updateColor.
	self changed! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
stayUp: aBoolean

	stayUp := aBoolean.
	
	titleMorph ifNotNil: [ titleMorph updatePinForm ].! !

!MenuMorph methodsFor: 'invoking' stamp: ''!
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."
	"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." 
	| originalFocusHolder |
	originalFocusHolder := aWorld primaryHand keyboardFocus.
	self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean.
	MorphicRenderLoop new doOneCycleWhile: [ self isInWorld ].
	self delete.
	self restoreFocus: originalFocusHolder in: aWorld.
	^ selection ifNil: [ selectedItem ifNotNil: [selectedItem target] ]! !

!MenuMorph methodsFor: '*NewTools-Spotter-Processors' stamp: ''!
withAllLeafItemsDo: aBlockClosure 
	
	self items do: [:anItem | anItem withAllLeafItemsDo: aBlockClosure]! !

!MenuMorph methodsFor: 'construction' stamp: ''!
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: 'keyboard control' stamp: ''!
moveDown: evt 
	^self moveSelectionDown: 1 event: evt! !

!MenuMorph methodsFor: 'construction' stamp: ''!
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: 'construction' stamp: ''!
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 <yes> or <no>, the on/off state of the menu item will reflect it."
 
	|aString str|
	aString := (MessageSend receiver: target selector: wordingSelector) valueWithEnoughArguments: argList.
	self flag: #pharoFixMe.
	(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: 'control' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"Draw the menu. Add keyboard-focus feedback if appropriate"

	super drawOnAthensCanvas: anAthensCanvas.
	(self activeHand notNil and: [ self activeHand keyboardFocus == self and: [ self rootMenu hasProperty: #hasUsedKeyboard ] ])
		ifTrue: [ 
			(anAthensCanvas setStrokePaint: self theme menuKeyboardFocusColor) width: self theme menuBorderWidth.
			anAthensCanvas drawShape: self innerBounds ]! !

!MenuMorph methodsFor: 'actions' stamp: ''!
addIfNeededTitle: aTitle andIcon: anIcon

	(aTitle notNil or: [ anIcon notNil ])
		ifTrue: [ self addTitle: aTitle icon: anIcon ]! !

!MenuMorph methodsFor: '*SUnit-Support-UITesting' stamp: ''!
choose: aString 

	| item |
	item := self itemWithWording: aString.
	item ifNil: [ self error: 'Menu does not have "', aString, '" item' ].
	item simulateClick.! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
commandKeyHandler
	"Answer the receiver's commandKeyHandler"

	^ self valueOfProperty: #commandKeyHandler ifAbsent: [nil]! !

!MenuMorph methodsFor: 'testing' stamp: ''!
hasItems
	"Answer if the receiver has menu items"
	^ submorphs anySatisfy: [:each | each isMenuItemMorph ]! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
embeddable
	^self valueOfProperty: #embeddable ifAbsent: [ false ].! !

!MenuMorph methodsFor: 'accessing' stamp: ''!
defaultTarget
	^defaultTarget! !

!MenuMorph methodsFor: 'keyboard control' stamp: ''!
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 isMenuItemMorph) 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: 'construction' stamp: ''!
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: 'construction' stamp: ''!
addWithLabel: aLabelString enablement: anEnablementSelector action: aSymbol
	"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 flag: #pharoToDeprecate.
	self
		addToggle: aLabelString
		target: defaultTarget
		selector: aSymbol
		getStateSelector: nil
		enablementSelector: anEnablementSelector
		argumentList: EmptyArray! !

!MenuMorph methodsFor: 'testing' stamp: ''!
hasSubMenu: aMenuMorph

	^submorphs anySatisfy: [ :m | m isMenuItemMorph and: (m hasSubMenu: aMenuMorph) ]! !

!MenuMorph methodsFor: 'invoking' stamp: ''!
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: 'accessing' stamp: ''!
items
	"Returns menu items filtering out menu lines"
	^self menuItems! !

!MenuMorph methodsFor: 'private' stamp: ''!
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: 'events' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!MenuMorph class methodsFor: 'images' stamp: ''!
closeBoxImage
	"Supplied here because we don't necessarily have ComicBold"

	^ CloseBoxImage ifNil: [CloseBoxImage := SystemWindow closeBoxImage]! !

!MenuMorph class methodsFor: 'instance creation' stamp: ''!
initialize
	"MenuMorph initialize"
	PushPinImage := nil! !

!MenuMorph class methodsFor: 'instance creation' stamp: ''!
entitled: aString
	"Answer a new instance of me with the given title."

	^ self new addTitle: aString! !

!MenuMorph class methodsFor: 'examples' stamp: ''!
example
	"MenuMorph example openInHand"
	<example>
	<sampleInstance>
	
	| menu |
	menu := MenuMorph new.
	menu buildTitle: [ :menuTitle | menuTitle
		onlyCloseAndPinable
	].
	menu add: 'apples' selector: #apples.
	menu add: 'oranges' selector: #oranges.
	menu addLine.
	"menu addLine. " "extra lines ignored" 
	menu add: 'peaches' selector: #peaches.
	menu addLine.
	menu add: 'pears' selector: #pears.
	menu addLine.
	^ menu popUpInWorld! !

!MenuMorph class methodsFor: 'instance creation' stamp: ''!
fromList: anArray 
	"Construct a menu from an array of descriptions. See #addList comment"

	^ self new addList: anArray.! !

!MenuMorph class methodsFor: 'utilities' stamp: ''!
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. Do not invoke this method - it is here to help in case of mini system, better use
	UIManager default confirm: 'Is is the question?' "

	^ self confirm: queryString trueChoice: 'Yes' translated falseChoice: 'No' translated! !

!MenuMorph class methodsFor: 'private - utilities' stamp: ''!
chooseFrom: aList values: valueList lines: linesArray title: queryString
	"Choose an item from the given list. Answer the index of the selected item.  Do not invoke this method - it is here to help in case of mini system, better use UIManager default"
	
	"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 invokeModal.
	^result! !

!MenuMorph class methodsFor: 'private - utilities' stamp: ''!
chooseFrom: aList lines: linesArray title: queryString
	"Choose an item from the given list. Answer the index of the selected item. Do not invoke this method - it is here to help in case of mini system, better use UIManager default"
	
	
	"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 invokeModal.
	^result! !

!MenuMorph class methodsFor: 'private - utilities' stamp: ''!
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.  Do not invoke this method - it is here to help in case of mini system, better use UIManager default"
	"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: 'private - utilities' stamp: ''!
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.  Do not invoke this method - it is here to help in case of mini system, better use UIManager default"

	"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 iconNamed: #confirmIcon).
	menu
		add: trueChoice
		target: aBlock
		selector: #value:
		argument: true.
	menu
		add: falseChoice
		target: aBlock
		selector: #value:
		argument: false.
	[ menu invokeModal.
	result isNil ] whileTrue.
	^ result! !

!MenuMorph class methodsFor: 'images' stamp: ''!
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]! !

!MenuPresenter commentStamp: ''!
I am a simple presenter describing a menu.
See AbstractWidgetPresenter

I only contains a list of menu groups (MenuGroupPresenter). Each group is separated by a splitter.

I provide the following variables and their accessors
- addGroup: use the block in parameter to initialize a new group, then add it in my collection.
- addMenuGroup: add the group in parameter in my collection.
- menuGroups getter of my collection.


todo
- addAllFromPragma:target:
- applyTo: activate the shortcut of the items of my groups.
- autoRefresh
- buildWithSpecAsPopup
- fromSpec:
- icon
- neglect:
- openWithSpecAt:
- printOn:
- title , addTitle:
!
!MenuPresenter methodsFor: 'private' stamp: ''!
addMenuGroup: aMenuGroup

	groups add: aMenuGroup.
	self autoRefresh 
		ifNotNil: [ aMenuGroup autoRefresh: self autoRefresh ]! !

!MenuPresenter methodsFor: 'api' stamp: ''!
autoRefresh: aBoolean

	autoRefresh value: aBoolean! !

!MenuPresenter methodsFor: 'api-building' stamp: ''!
fromSpec: aSpec

	aSpec addToMenuModel: self! !

!MenuPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	groups := OrderedCollection new asValueHolder.
	title := nil asValueHolder.
	icon := nil asValueHolder.
	autoRefresh := nil asValueHolder.
	autoRefresh whenChangedDo: [ :aBoolean | self menuGroups do: [ :each | each autoRefresh: aBoolean ] ]! !

!MenuPresenter methodsFor: 'api' stamp: ''!
openWithSpecAt: aPosition

	self buildWithSpecAsPopup.
	self changed: #openAt: with: { aPosition }! !

!MenuPresenter methodsFor: 'api' stamp: ''!
iconName: aSymbol

	icon value: (self iconNamed: aSymbol)! !

!MenuPresenter methodsFor: 'api' stamp: ''!
title: aString

	title value: aString! !

!MenuPresenter methodsFor: 'api-building' stamp: ''!
addAllFromPragma: pragma target: target

	self fromSpec: (PragmaMenuBuilder 
		pragmaKeyword: pragma
		model: target) menuSpec! !

!MenuPresenter methodsFor: 'api' stamp: ''!
addGroup: aBlock
	| group |
	
	group := MenuGroupPresenter new.
	aBlock value: group.
	self addMenuGroup: group! !

!MenuPresenter methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	self title value
		ifNotNil: [ :t | 
			aStream
				nextPutAll: ' ''';
				nextPutAll: t;
				nextPutAll: '''' ]! !

!MenuPresenter methodsFor: 'api' stamp: ''!
autoRefresh

	^ autoRefresh value! !

!MenuPresenter methodsFor: 'api' stamp: ''!
menuGroups

	^ groups value! !

!MenuPresenter methodsFor: 'api' stamp: ''!
neglect: aModel

	aModel neglectMenuModel: self! !

!MenuPresenter methodsFor: 'api' stamp: ''!
icon

	^ icon value! !

!MenuPresenter methodsFor: 'api' stamp: ''!
applyTo: aModel

	aModel applyMenuModel: self! !

!MenuPresenter methodsFor: 'adding' stamp: ''!
addTitle: aString
	title value: aString! !

!MenuPresenter methodsFor: 'api' stamp: ''!
icon: anIcon

	icon value: anIcon! !

!MenuPresenter methodsFor: 'api' stamp: ''!
title

	^ title value! !

!MenuPresenter methodsFor: 'api' stamp: ''!
buildWithSpecAsPopup

	^ self buildWithSpec: #popup! !

!MenuPresenter class methodsFor: 'specs' stamp: ''!
popup
	<spec>
	
	^ #(MenuAdapter
		adaptAsPopup: #(model))! !

!MenuPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(MenuAdapter
		adapt: #(model))! !

!MenuPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #MenuAdapter! !

!MenuRegistration commentStamp: ''!
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 
	<worldMenuExample> 
	(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 <worldMenuExample> 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
	<myMenuTest>
	(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
	<myMenuTest>
	(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
	<myMenuTest>
	(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
	<myMenuTest>
	(aBuilder item: #'Wozy')
		parent: #CoolTool;
		order: 1.0
		
AnotherClassSomewhere class>>myWozySystemConfigOn: aBuilder
	<myMenuTest>
	(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
	<myMenuTest>
	(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
	<myMenuTest>
	(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:		<Boolean>
	itemList:		<SortedCollection>
	order:		<Number>
	owner:		<MenuRegistration>
	parentName:		<Symbol>
	spec:		<PluggableMenuItemSpec>

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: 'accessing' stamp: ''!
addItem: anItem 
	"Add a MenuRegistration"
	self ensureItemList add: anItem! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
enabledBlock
	^ self spec enabledBlock! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
itemReceiver
	^ self target ifNil: [owner itemReceiver]! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
parentName
	^ parentName! !

!MenuRegistration methodsFor: '*Morphic-Base' stamp: ''!
iconName: aSymbol
	"instead of forcing clients to refer to an icon builder such Smalltalk ui icons 
	this message encapsulates it inside the builder itself. When removing uses of Smalltalk ui icons it avoid to force to subclass class with menu to inherit from Model."
	
	self icon: (Smalltalk ui icons iconNamed: aSymbol)! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
ensureItemList
	"Return the list of MenuRegistration instances"
	^ itemList ifNil: [itemList := OrderedCollection new]! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
itemList: aCollection
	"Set the list of MenuRegistration"
	 itemList := aCollection! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
owner
	^ owner! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
parentName: aSymbol
	parentName := aSymbol! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
assignOrderWithBlock: aBlock 
	"Compute recursively MenuRegistration order"
	self itemList 
		ifNotNil: [self itemList: (aBlock value: self itemList).
				self itemList do: [:rded | rded assignOrderWithBlock: aBlock]]! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
spec
	"return my PluggableMenuItemSpec"
	^ spec ifNil: [spec := PluggableMenuItemSpec new]! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
model
	^ self builder model! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
label 
	"return my label"
	^ self spec label! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
icon: aForm
	"set the icon that is shown in the menu"
	self spec icon: aForm! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
removeItem: anItem
	"Remove a MenuRegistration"
	self itemList remove: anItem! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
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: ''!
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: 'initialization' stamp: ''!
initialize
	super initialize.
	isGroup := false! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
label: aLabel
	"set the label that is shown in the menu"
	self spec label: aLabel! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
order: aNumber 
	"Set the value of order"

	order := aNumber! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
builder
	^ owner builder! !

!MenuRegistration methodsFor: 'sub item creating' stamp: ''!
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: ''!
newSubItem
	| reg |
	reg := self class owner: self.
	self addItem: reg.
	^ reg! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
precondition: aValuable
	precondition := aValuable! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
enabledBlock: aBlock

	self spec enabledBlock: aBlock! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
target
	^ self spec action ifNotNil: [:action | action receiver]! !

!MenuRegistration methodsFor: 'sub item creating' stamp: ''!
group: aSymbol
	^ (self item: aSymbol) isGroup: true! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
precondition
	^ precondition ifNil: [[true]]! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
arguments: anArray
	"set the arguments for an item with an action"
	self spec action 
		ifNil: [self spec action: (MessageSend receiver: self itemReceiver selector: nil arguments: anArray)]
		ifNotNil: [self spec action arguments: anArray]! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
sort: aSortBlock
	"Sort the tree recursively"
	self itemList
		ifNotNil: [
		self itemList: (self itemList asSortedCollection: aSortBlock).
		self itemList do: [:rded | rded sort: aSortBlock] ]! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
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: ''!
parent: aSymbol
	self parentName: aSymbol! !

!MenuRegistration methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream 
		<< ' ( ';
		print: self name; 
		<< ' ) '! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
name: aSymbol
	"set my name (should be unique over all menu items"
	self spec name: aSymbol! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
keyText: aString
	self spec keyText: aString! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
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: 'accessing' stamp: ''!
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 ifNotNil: [ result itemNamed: aName ]! !

!MenuRegistration methodsFor: 'initialization' stamp: ''!
reset
	itemList 
		ifNotNil: [
			itemList do: [:i | i reset].
			itemList := nil].
	spec := nil! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
isGroup: aBoolean
	isGroup := aBoolean! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
order
	^ order! !

!MenuRegistration methodsFor: 'accessing' stamp: ''!
itemList
	"Return my children"
	^ itemList! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
help: anHelpText
	"set the help text"
	self spec help: anHelpText! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
withSeparatorAfter
	"add a separator line after me"
	self spec separator: true! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
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: 'accessing' stamp: ''!
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: ''!
owner: anItem
	owner := anItem! !

!MenuRegistration methodsFor: 'spec accessing' stamp: ''!
name
	"returns my name which is used as a key (should unique over all the menu items"
	^ self spec name! !

!MenuRegistration methodsFor: 'initialization' stamp: ''!
release
	itemList := nil.
	self releaseActionMap.! !

!MenuRegistration methodsFor: 'sub item creating' stamp: ''!
with: aBlock
	self builder currentRoot: self while: aBlock! !

!MenuRegistration class methodsFor: 'instance creation' stamp: ''!
owner: aMenuRegistration
	^ self new owner: aMenuRegistration! !

!MenuRegistrationExample commentStamp: ''!
I'm here to show you how to use the menu registration. See class side methods and try it with:
----------------
(PragmaMenuBuilder pragmaKeyword: 'worldMenuExample' model: nil) menu popUpInWorld
----------------
!
!MenuRegistrationExample class methodsFor: 'menu actions' stamp: ''!
saveAs
	Smalltalk saveAs.! !

!MenuRegistrationExample class methodsFor: 'menu declaring' stamp: ''!
pharoItemsOn: aBuilder 
	<worldMenuExample> 
	(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: ''!
mostUsedToolsOn: aBuilder 
	<worldMenuExample>
	(aBuilder group: #Tools)
		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.
			]! !

!MenuRegistrationExample class methodsFor: 'menu declaring' stamp: ''!
theme
	"Answer the ui theme that provides controls."

	^ Smalltalk ui theme! !

!MenuRegistrationExample class methodsFor: 'menu declaring' stamp: ''!
pragmaKeyword
	^ 'worldMenuExample'! !

!MenuRegistrationExample class methodsFor: 'menu actions' stamp: ''!
saveAndQuit
	Smalltalk snapshot: true andQuit: true! !

!MenuRegistrationExample class methodsFor: 'menu declaring' stamp: ''!
myOwnCoolMenuRegistrationOn: aBuilder 
	<worldMenuExample>
	(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: ''!
myOwnCoolToolRegistrationOn: aBuilder 
	<worldMenuExample> 
	(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: ''!
toolsOn: aBuilder 
	<worldMenuExample>
	(aBuilder item: #Tools)
		order: 1.0;
		target: Smalltalk tools;
		iconName: #smallDoItIcon;
		withSeparatorAfter;
		with: [(aBuilder item: #Transcript) selector: #openTranscript; icon: Smalltalk tools transcript  taskbarIcon. 
			(aBuilder item: #'File Browser') selector: #openFileList; icon: Smalltalk tools fileList taskbarIcon.
			(aBuilder item: #'Process Browser') selector: #openProcessBrowser; icon: Smalltalk tools processBrowser taskbarIcon;
				 withSeparatorAfter]! !

!MenuRegistrationExample class methodsFor: 'menu actions' stamp: ''!
quitSession
	Smalltalk
		snapshot: (UIManager default confirm: 'Save changes before quitting?' translated orCancel: [ ^ self ])
		andQuit: true! !

!MenuTitleMorph commentStamp: ''!
This is a TitleMorph used by MenuMorph.

"
	Example usage:

	| menu |
	
	menu := MenuMorph new.

	menu buildTitle: [ :titleMorph | titleMorph
		title: 'aCoolTitle';
		icon: self theme icons alertIcon;
		withCloseBox;
		withPinBox;
		color: Color purple		
	].

	... " add items" ...
	
	menu popUpInWorld
!
!MenuTitleMorph methodsFor: 'construction-defined' stamp: ''!
bigTitle: aTitle

	self 
	withCloseBox;
	title: aTitle;
	font: StandardFonts windowTitleFont;
	withPinBox.! !

!MenuTitleMorph methodsFor: 'construction' stamp: ''!
withPinBox

	pinBox ifNotNil: [ pinBox delete ].	
		
	pinBox := self 
		iconButtonCalling: #pinBoxClicked 
		withForm: self pinForm scaledByDisplayScaleFactor
		helpText: 'Keep this menu up'.	
			
	self addMorph: pinBox asElementNumber: 4! !

!MenuTitleMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	self 
	listDirection: #leftToRight;
	vResizing: #shrinkWrap;
	wrapCentering: #topLeft;
	cellPositioning: #center;
	cellSpacing: #none;
	layoutInset: 2;
	clipSubmorphs: true! !

!MenuTitleMorph methodsFor: 'private - creation' stamp: ''!
boxExtent

	^ (18 @ 18) * self displayScaleFactor! !

!MenuTitleMorph methodsFor: 'construction' stamp: ''!
title: aString

	titleContainer ifNotNil: [ titleContainer delete ].
	
	titleContainer := AlignmentMorph newColumn.
	titleContainer 
	color: Color transparent;
	hResizing: #spaceFill;
	vResizing: #shrinkWrap;
	wrapCentering: #center;
	layoutInset: 0;
	layoutChanged.
	
	aString translated linesDo: [ :line |
		titleContainer addMorphBack: (StringMorph contents: line font: StandardFonts menuFont)
	].
	
	pinBox ifNotNil: [ ^self addMorph: titleContainer inFrontOf: pinBox ].
	
	self addMorphBack: titleContainer! !

!MenuTitleMorph methodsFor: 'construction' stamp: ''!
font: aFont

	titleContainer ifNil: [ ^self ]. "should really not happen!!"
	
	titleContainer submorphsDo: [ :stringMorph | stringMorph font: aFont ].! !

!MenuTitleMorph methodsFor: 'event handling' stamp: ''!
pinBoxClicked

	owner toggleStayUp.
	
	self updatePinForm! !

!MenuTitleMorph methodsFor: 'rounding' stamp: ''!
wantsRoundedCorners
	^ color isTransparent not and: [ owner wantsRoundedCorners ]! !

!MenuTitleMorph methodsFor: 'construction-defined' stamp: ''!
onlyCloseAndPinable

	self 
	withCloseBox;
	title: '';
	withPinBox.! !

!MenuTitleMorph methodsFor: 'private - creation' stamp: ''!
iconButtonCalling: aSelector withForm: aForm helpText: aText

	^IconicButtonMorph new target: self;
		actionSelector: aSelector;
		labelGraphic: aForm;
		color: Color transparent;
		extent: self boxExtent;
		borderWidth: 0;
		helpText: aText translated;
		yourself! !

!MenuTitleMorph methodsFor: 'pinning' stamp: ''!
pinColor

	^owner stayUp ifTrue: [ Color gray lighter ] ifFalse: [ Color black ]! !

!MenuTitleMorph methodsFor: 'construction' stamp: ''!
withCloseBox

	closeBox ifNotNil: [ closeBox delete ].	
		
	closeBox := self 
		iconButtonCalling: #closeBoxClicked 
		withForm: self theme menuCloseForm 
		helpText: 'Close this menu'.
		
	self addMorph: closeBox asElementNumber: 1! !

!MenuTitleMorph methodsFor: 'pinning' stamp: ''!
updatePinForm

	pinBox ifNotNil: [ pinBox labelGraphic: self pinForm; extent: self boxExtent ].! !

!MenuTitleMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	^ self theme settings flatMenu 
		ifFalse: [#inset]
		ifTrue: [self theme settings derivedMenuColor muchDarker]! !

!MenuTitleMorph methodsFor: 'pinning' stamp: ''!
pinForm

	^CircleMorph new
		extent: 8@8;
		borderWidth: 2;
		color: self pinColor;
		imageForm! !

!MenuTitleMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	
	^self theme menuTitleColorFor: nil! !

!MenuTitleMorph methodsFor: 'event handling' stamp: ''!
closeBoxClicked

	owner ifNotNil: [ :o | o delete ]! !

!MenuTitleMorph methodsFor: 'construction' stamp: ''!
icon: aForm

	icon ifNotNil: [ icon delete ].
	icon := aForm asMorph.

	closeBox ifNotNil: [ ^self addMorph: icon after: closeBox  ].

	self addMorphFront: icon! !

!MenuTitleMorph methodsFor: 'rounding' stamp: ''!
roundedCorners

	^#(1 4)! !

!MenubarItemMorph commentStamp: ''!
Description
--------------------

I am a specialization of the MenuItemMorph for the Menubar. I adapt the look of the Morph to fit the design of the menubar.!
!MenubarItemMorph methodsFor: 'drawing' stamp: ''!
menuStringBounds
	| oldBounds |
	oldBounds := super menuStringBounds.
	^ oldBounds left: (oldBounds left + oldBounds right - self measureContents x) // 2! !

!MenubarItemMorph methodsFor: 'drawing' stamp: ''!
drawSubmenuMarkerOn: aCanvas

	"Nothing"! !

!MenubarItemMorph methodsFor: 'private' stamp: ''!
selectionFillStyle
	^ self theme menubarItemSelectionFillStyleFor: self! !

!MenubarItemMorph methodsFor: 'private' stamp: ''!
selectionTextColor
	^ self theme menubarItemSelectionTextColorFor: self! !

!MenubarItemMorph methodsFor: 'drawing' stamp: ''!
drawIconOn: aCanvas
	| iconForm x y |
	self hasIcon ifFalse: [ ^ self ].
	
	iconForm := self iconForm.
	x := (self menuStringBounds left - iconForm width - 5 ).
	y := (self top + ((self height - iconForm height) // 2)).
	
	aCanvas translucentImage: iconForm at: x @ y! !

!MenubarMenuMorph commentStamp: ''!
Description
--------------------

I am a specialization of the MenuMorph for the Menubar. I adapt the keyboard navigation of the menubar.!
!MenubarMenuMorph methodsFor: 'events' stamp: ''!
sendRightArrowPressedToMenubarOwner: evt
	popUpOwner owner isMenubar
		ifTrue:
			[ "This is a submenu of a MenubarItemMorph, we give back the focus and move one right." popUpOwner owner keyStroke: evt ]
		ifFalse:
			[ "In that case we have submenus in submenus, we delegate the action to our parent menu" popUpOwner owner sendRightArrowPressedToMenubarOwner: evt ]! !

!MenubarMenuMorph methodsFor: 'events' stamp: ''!
rightArrowStroked: evt
	"If the super return false it's probably because we need to give back the focus to the menubar and move to the right."

	(super rightArrowStroked: evt)
		ifTrue: [ ^ true ].
	popUpOwner
		ifNotNil: [ self deselectAndFocusOutermenuOn: evt.
			self sendRightArrowPressedToMenubarOwner: evt.
			^ true ].
	^ false! !

!MenubarMenuMorph methodsFor: 'events' stamp: ''!
leftArrowStroked: evt
	| keyboardFocus |
	super leftArrowStroked: evt.
	
	"If the menu is a submenu of a MenubarItemMorph then we need to give back the focus but also move the MenubarItemMorph selected one left."
	keyboardFocus := evt hand keyboardFocus.
	keyboardFocus isMenubar ifTrue: [ keyboardFocus keyStroke: evt ]! !

!MenubarMorph commentStamp: ''!
Description
--------------------

I am a Morph of the form of a Menubar that can be displayed at the top of the World. 

You can disable me with: `self showMenubar: false`.

For now, when you open me, by default I will use the world menu pragma to collect the items to display. If you want a custom menu, just update the WorldMenu pragma to use.
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	menuBarItems:		<aCollection>	A collection of items to show at the root of the Menubar. Those items can also contains submenus.
!
!MenubarMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self cellInset: 7! !

!MenubarMorph methodsFor: 'construction' stamp: ''!
newMenuItem
	
	^ MenubarItemMorph new! !

!MenubarMorph methodsFor: 'adding' stamp: ''!
drawSubmenuMarkerOn: aCanvas

	"Nothing"! !

!MenubarMorph methodsFor: 'accessing' stamp: ''!
open
	self menuBarItems
		do: [ :each | 
			self
				add: each label
				icon: each icon
				help: each help
				subMenu: (each subMenu ifNotNil: #asMenubarMenuMorph)
				action: each action
				keyText: each keyText.
			each separator
				ifTrue: [ self addSeparator ] ].
	self
		adhereToTop;
		openInWorld! !

!MenubarMorph methodsFor: 'accessing' stamp: ''!
menuBarItems: anObject
	menuBarItems := anObject! !

!MenubarMorph methodsFor: 'accessing' stamp: ''!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu."
	
	^false! !

!MenubarMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	^ self theme menubarBorderWidthFor: self! !

!MenubarMorph methodsFor: 'construction' stamp: ''!
addSeparator
	self addMorphBack: MenubarSeparatorMorph new! !

!MenubarMorph methodsFor: 'accessing' stamp: ''!
repelsMorph: aMorph event: ev
	^ true! !

!MenubarMorph methodsFor: 'accessing' stamp: ''!
menuBarItems
	^ menuBarItems! !

!MenubarMorph methodsFor: 'testing' stamp: ''!
isMenubar
	^ true! !

!MenubarMorph methodsFor: 'recategorized' stamp: ''!
rejectsEvent: anEvent
	(anEvent isMouse and: [ anEvent isMouseDown ]) ifTrue: [ ^ (self submorphs anySatisfy: [ :each | each containsPoint: anEvent cursorPoint ]) not ].
	
	^ super rejectsEvent: anEvent! !

!MenubarMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^ self theme menubarFillStyleFor: self! !

!MenubarMorph methodsFor: 'initialization' stamp: ''!
wantsGradientByDefault
	^ false! !

!MenubarMorph class methodsFor: 'setting' stamp: ''!
menubarSettingOn: aBuilder
	<systemsettings>
	(aBuilder setting: #showMenubar)
		target: self;
		parent: #morphic;
		label: 'Show menubar';
		default: true;
		description: 'Whether the world''s menubar should be shown or not.'! !

!MenubarMorph class methodsFor: 'accessing' stamp: ''!
showMenubar: aBoolean
	ShowMenubar := aBoolean.
	self reset! !

!MenubarMorph class methodsFor: 'instance creation' stamp: ''!
initialize
	self showMenubar: true.
	self install.
	self reset! !

!MenubarMorph class methodsFor: 'accessing' stamp: ''!
showMenubar
	^ ShowMenubar! !

!MenubarMorph class methodsFor: 'instance creation' stamp: ''!
methodAnnouncementReceived: anAnnouncement

	(anAnnouncement methodAffected hasPragmaNamed: #worldMenu)
		ifTrue: [ self reset ]! !

!MenubarMorph class methodsFor: 'instance creation' stamp: ''!
closeAll

	self currentWorld submorphs
		select: [ :e | e isKindOf: MenubarMorph ]
		thenDo: [ :e | e delete ].! !

!MenubarMorph class methodsFor: 'instance creation' stamp: ''!
install
	"Unsubscribe to subscribe only once"
	SystemAnnouncer uniqueInstance unsubscribe: self.
	SystemAnnouncer uniqueInstance weak
		when: MethodAnnouncement
		send: #methodAnnouncementReceived: to: self.! !

!MenubarMorph class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	
	self showMenubar ifFalse: [ ^ self ].

	self new
		menuBarItems: self currentWorld worldState menuBuilder menuSpec items;
		open.! !

!MenubarMorph class methodsFor: 'class initialization' stamp: ''!
reset

	<script>
	self closeAll.
	self open.! !

!MenubarSeparatorMorph commentStamp: ''!
Description
--------------------

I am a simple morph used by the MenubarMorph to add some separators. Use me via the #addSeparator method of MenubarMorph.!
!MenubarSeparatorMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		color: self defaultColor;
		borderWidth: self defaultBorderWidth! !

!MenubarSeparatorMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	^ 0! !

!MenubarSeparatorMorph methodsFor: 'theme' stamp: ''!
themeChanged
	super themeChanged.
	self
		color: self defaultColor;
		borderWidth: self defaultBorderWidth! !

!MenubarSeparatorMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^ Color transparent! !

!MenubarSeparatorMorph methodsFor: 'initialization' stamp: ''!
defaultLabel
	^ '|'! !

!MergeDiffMorph commentStamp: ''!
A morph to display merge differences and allow to merge them
with clickable icons on the spitter!
!MergeDiffMorph methodsFor: 'actions' stamp: ''!
newJoinMorph
	"Answer a new join morph."

	^super newJoinMorph
		when: #joinClicked send: #update: to: self with: #joinClicked! !

!MergeDiffMorph methodsFor: 'accessing' stamp: ''!
allowJoinClicks
	"Answer the value of allowJoinClicks"

	^ allowJoinClicks! !

!MergeDiffMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		allowJoinClicks: true! !

!MergeDiffMorph methodsFor: 'obsolete' stamp: ''!
indicateSrc
	"Change the indicators of the joins to the src side."

	self joinMappings do: [:section |
		section selectionState: #src].
	self
		changed;
		changed: #selectedDifferences! !

!MergeDiffMorph methodsFor: 'actions' stamp: ''!
update: aspect
	"A join has probably changed its selection state."

	super update: aspect.
	aspect == #joinClicked
		ifTrue: [self
				changed;
				changed: #selectedDifferences]! !

!MergeDiffMorph methodsFor: 'accessing' stamp: ''!
allowJoinClicks: anObject
	"Set the value of allowJoinClicks"

	allowJoinClicks := anObject! !

!MergeDiffMorph methodsFor: 'actions' stamp: ''!
compositeText
	"Answer the composite text based on the selection state
	of the joins."

	^self joinMorph compositeText
	! !

!MergeDiffMorph methodsFor: 'actions' stamp: ''!
calculatedJoinMappings
	"Specify click allowance for each section."
	
	^super calculatedJoinMappings do: [:j |
		j allowClick: self allowJoinClicks]! !

!MergeDiffMorph methodsFor: 'obsolete' stamp: ''!
indicateDst
	"Change the indicators of the joins to the dst side."

	self joinMappings do: [:section |
		section selectionState: #dst].
	self
		changed;
		changed: #selectedDifferences! !

!MergeDiffMorph methodsFor: 'actions' stamp: ''!
joinSectionClass
	"Answer the class to use for a new join section."

	^MergeJoinSection! !

!MergeDiffMorph class methodsFor: 'examples' stamp: ''!
example2

	(MergeDiffMorph 
		from: 'test' to: 'test2')
		openInWindow ! !

!MergeDiffMorph class methodsFor: 'examples' stamp: ''!
example

	MergeDiffMorph new openInWindow ! !

!MergeJoinSection commentStamp: ''!
A join section usable for merging!
!MergeJoinSection methodsFor: 'accessing' stamp: ''!
stateIcon
	"Answer the state icon to use."

	self wantsClick ifFalse: [^nil].
	^self stateIcons at: (self selectionStates indexOf: self selectionState)! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
allowClick
	"Answer the value of allowClick"

	^ allowClick! !

!MergeJoinSection methodsFor: 'drawing' stamp: ''!
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: 'accessing' stamp: ''!
allowClick: anObject
	"Set the value of allowClick"

	allowClick := anObject! !

!MergeJoinSection methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	self
		allowClick: true;
		selected: false;
		selectionState: #dst;
		stateIcons: self defaultStateIcons;
		selectedBorderColor: Color black.
	super initialize! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
selectedBorderColor: anObject
	"Set the value of selectedBorderColor"

	selectedBorderColor := anObject! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
stateIcons
	"Answer the value of stateIcons"

	^ stateIcons! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
selected: aBoolean
	"Set the value of selected"

	selected := aBoolean.
	self
		updateHighlights;
		changed: #selected! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
stateIcons: anObject
	"Set the value of stateIcons"

	stateIcons := anObject! !

!MergeJoinSection methodsFor: 'actions' stamp: ''!
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: 'testing' stamp: ''!
wantsClick
	"Allow if explictly enabled and super."

	^self allowClick and: [super wantsClick]! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
stateIconBounds
	"Answer the bounds of the state icon."
	
	|i|
	i := self stateIcon ifNil: [^nil].
	^self shape bounds center - (i extent // 2)
		extent: i extent! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
selected
	"Answer the value of selected"

	^ selected! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
defaultStateIcons
	"Answer the default state icons."

	^ {(self iconNamed: #smallBackIcon) . (self iconNamed: #smallForwardIcon) .
	(self iconNamed: #smallOkIcon) . (self iconNamed: #smallCancelIcon)}! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
selectedBorderColor
	"Answer the value of selectedBorderColor"

	^ selectedBorderColor! !

!MergeJoinSection methodsFor: 'actions' stamp: ''!
clicked
	"The receiver or a highlight was clicked."

	self wantsClick ifFalse: [^false].
	self selectNextState.
	^true! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
borderColorToUse
	"Answer the border color to use based on the selection state."
	
	^self selected
		ifTrue: [self selectedBorderColor]
		ifFalse: [super borderColorToUse]! !

!MergeJoinSection methodsFor: 'actions' stamp: ''!
selectNextState
	"Set the selection state to the next one with wraparound."

	self selectionState: (
		self selectionStates at: (
			(self selectionStates indexOf: self selectionState) \\
				self selectionStates size + 1))! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
selectionState: anObject
	"Set the value of selectionState"

	selectionState := anObject! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
selectionStates
	"Answer the valid selection states in order."

	^#(src dst both neither)! !

!MergeJoinSection methodsFor: 'testing' stamp: ''!
containsPoint: aPoint
	"Answer whether the receiver contains the given point."

	^(super containsPoint: aPoint) or: [
		self stateIcon notNil and: [self stateIconBounds containsPoint: aPoint]]! !

!MergeJoinSection methodsFor: 'accessing' stamp: ''!
selectionState
	"Answer the value of selectionState"

	^ selectionState! !

!MeshGradientPaint commentStamp: ''!
I am a gradient that is defined by the composition of multiple patches.!
!MeshGradientPaint methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	patches := OrderedCollection new.! !

!MeshGradientPaint methodsFor: 'accessing' stamp: ''!
patches
	^ patches! !

!MeshGradientPaint methodsFor: 'converting' stamp: ''!
asAthensPaintOn: aCanvas
	^ aCanvas surface
		createMeshGradientWithPatches: patches! !

!MeshGradientPaint methodsFor: 'adding' stamp: ''!
addPatch: patch
	patches add: patch! !

!MeshGradientPaint methodsFor: 'adding' stamp: ''!
addTriangleWithPoints: controlPoints colors: colors
	self assert: controlPoints size = 3.
	self assert: colors size = 3.
	^ self addPatch: (TrianglePaintPatch controlPoints: controlPoints colors: colors)! !

!MeshGradientPaint methodsFor: 'adding' stamp: ''!
addCoonsPatchWithPoints: controlPoints colors: colors
	self assert: controlPoints size = 12.
	self assert: colors size = 4.
	^ self addPatch: (CoonsPaintPatch controlPoints: controlPoints colors: colors)! !

!MeshGradientPaint methodsFor: 'adding' stamp: ''!
addCircleSliceCenter: center radius: radius startAngle: sliceStartAngle endAngle: sliceEndAngle colors: colors
	| sliceStartPoint sliceEndPoint f sliceControlPoint1 sliceControlPoint2 sliceCenter |
	sliceStartPoint := Point r: radius theta: sliceStartAngle.
	sliceEndPoint := Point r: radius theta: sliceEndAngle.

"Circle subdivision algorithm from: https://blogs.igalia.com/dpino/2020/06/11/renderization-of-conic-gradients/ [October, 2020]"
	f := ( ((sliceEndAngle - sliceStartAngle) / 4) tan) * 4 / 3.
	sliceControlPoint1 := (sliceStartPoint x - (f * sliceStartPoint y)) @ (sliceStartPoint y + (f * sliceStartPoint x)).
	sliceControlPoint2 := (sliceEndPoint x + (f * sliceEndPoint y)) @ (sliceEndPoint y - (f * sliceEndPoint x)).
	
	"Transform the control points to the actual center."
	sliceCenter := center.
	sliceStartPoint := sliceStartPoint + center.
	sliceControlPoint1 := sliceControlPoint1 + center.
	sliceControlPoint2 := sliceControlPoint2 + center.
	sliceEndPoint := sliceEndPoint + center.

	self
		buildPatchWith: [ :patchBuilder |
			patchBuilder
				moveTo: sliceCenter;
				lineTo: sliceStartPoint;
				curveVia: sliceControlPoint1 and: sliceControlPoint2 to: sliceEndPoint;
				lineTo: sliceCenter;
				colors: colors
		].! !

!MeshGradientPaint methodsFor: 'accessing' stamp: ''!
patches: aListOfPatches
	patches := aListOfPatches copy! !

!MeshGradientPaint methodsFor: 'adding' stamp: ''!
buildPatchWith: aBlock
	^ self addPatch: (GenericPaintPatch new buildBlock: aBlock)! !

!Message commentStamp: ''!
I represent a selector and its argument values.
	
Generally, the system does not use instances of Message for efficiency reasons. However, when a message is not understood by its receiver, the interpreter will make up an instance of me in order to capture the information involved in an actual message transmission. This instance is sent it as an argument with the message doesNotUnderstand: to the receiver.!
!Message methodsFor: 'sending' stamp: ''!
sendTo: receiver
	"answer the result of sending this message to receiver"

	^ receiver perform: selector withArguments: args! !

!Message methodsFor: 'accessing' stamp: ''!
sends: aSelector
	"answer whether this message's selector is aSelector"

	^selector == aSelector! !

!Message methodsFor: 'sending' stamp: ''!
sentTo: receiver
	"answer the result of sending this message to receiver"

	^ lookupClass
		ifNil: [ receiver perform: selector withArguments: args]
		ifNotNil: [ receiver perform: selector withArguments: args inSuperclass: lookupClass]! !

!Message methodsFor: 'accessing' stamp: ''!
argument: newValue
	"Change the first argument to newValue and answer self"

	args at: 1 put: newValue! !

!Message methodsFor: 'accessing' stamp: ''!
arguments
	"Answer the arguments of the receiver."

	^args! !

!Message methodsFor: 'accessing' stamp: ''!
numArgs
	"Answer the number of arguments in this message"

	^args size! !

!Message methodsFor: 'accessing' stamp: ''!
selector
	"Answer the selector of the receiver."

	^selector! !

!Message methodsFor: 'private' stamp: ''!
setSelector: aSymbol

	selector := aSymbol.! !

!Message methodsFor: 'accessing' stamp: ''!
lookupClass

	^ lookupClass! !

!Message methodsFor: 'converting' stamp: ''!
asSendTo: anObject
	^MessageSend message: self to: anObject! !

!Message methodsFor: 'testing' stamp: ''!
hasArguments
	^args notEmpty! !

!Message methodsFor: 'private' stamp: ''!
lookupClass: aClass

	lookupClass := aClass! !

!Message methodsFor: 'comparing' stamp: ''!
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: ''!
printOn: stream

	args isEmpty ifTrue: [^ stream nextPutAll: selector].
	args with: selector keywords do: [:arg :word |
		stream nextPutAll: word.
		stream space.
		arg printOn: stream.
		stream space.
	].
	stream skip: -1.! !

!Message methodsFor: 'accessing' stamp: ''!
argument
	"Answer the first (presumably sole) argument"

	^args at: 1! !

!Message methodsFor: 'private' stamp: ''!
setSelector: aSymbol arguments: anArray

	selector := aSymbol.
	args := anArray! !

!Message methodsFor: 'printing' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol
	"Answer an instance of me with unary selector, aSymbol."

	^self new setSelector: aSymbol arguments: (Array new: 0)! !

!Message class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol argument: anObject 
	"Answer an instance of me whose selector is aSymbol and single 
	argument is anObject."

	^self new setSelector: aSymbol arguments: { anObject }! !

!Message class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol arguments: anArray 
	"Answer an instance of me with selector, aSymbol, and arguments, 
	anArray."

	^self new setSelector: aSymbol arguments: anArray! !

!MessageBrowser commentStamp: ''!
A MessageBrowser is a UI to browse a list of method, regardless of what they could be.

example: 

MessageBrowser new
	openWithSpec;
	messages: (SystemNavigation new allSendersOf: #at:)
	yourself!
!MessageBrowser methodsFor: 'private' stamp: ''!
intervalOf: aSelector inCode: aText of: aMethod
	aMethod compiledMethod ifNil: [  ^ 0 to: 0 ].
	^ (self sourceIntervalOf: aSelector in: aMethod ast) ifEmpty: [ self searchedString: aSelector asString in: aText ]! !

!MessageBrowser methodsFor: 'announcements' stamp: ''!
shouldRefreshItem: item fromAnnouncement: anAnnouncement
	"The refreshing block contains a block that accepts an item of the list, the received announcement and the message browser.
	It will anwer a boolean indicating if the modified item should be refreshed.
	
	Concretely, this is used to know if the contents of the selected message should be refreshed"

	^ refreshingBlock cull: item cull: anAnnouncement cull: self! !

!MessageBrowser methodsFor: 'private' stamp: ''!
intervalOf: aSelector inCommentText: aText
	^ self searchedString: aSelector asString in: aText! !

!MessageBrowser methodsFor: 'announcements' stamp: ''!
handleMethodRemoved: anAnnouncement
	| item selection removeItem |
	self isDisplayed
		ifFalse: [ ^ self ].
	refreshingBlock ifNil: [ ^ self ].
	self okToChange
		ifFalse: [ ^ self ].

	"Item is a compiled methed, where the list is populated with RGMethod"
	item := anAnnouncement method.
	(item methodClass notNil and: [ item methodClass isObsolete not ])
		ifFalse: [ ^ self ].
	selection := messageList selectedIndex.
	removeItem := self selectedMessage.
	(removeItem notNil
		and: [ removeItem methodClass = item methodClass
				and: [ removeItem selector = item selector ] ])
		ifTrue: [ textModel hasUnacceptedEdits: false ].
	self
		messages:
			(self messages
				remove: item asFullRingDefinition ifAbsent: [ nil ];
				yourself).
	self setSelectedIndex: selection! !

!MessageBrowser methodsFor: 'accessing' stamp: ''!
selectedClass
	^ self selectedMethod origin! !

!MessageBrowser methodsFor: 'text selection' stamp: ''!
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: 'accessing' stamp: ''!
textModel
	
	^ textModel! !

!MessageBrowser methodsFor: 'announcements' stamp: ''!
handleMethodModified: anAnnouncement
	| item oldItem sel index text list edits |
	self isDisplayed
		ifFalse: [ ^ self ].
	refreshingBlock ifNil: [ ^ self ].
	item := anAnnouncement newMethod.
	oldItem := anAnnouncement oldMethod.
	sel := self selectedMessage.
	sel ifNil: [ ^ self ].
	(sel methodClass = oldItem methodClass
		and: [ sel selector = oldItem selector ])
		ifFalse: [ ^ self ].
	(self shouldRefreshItem: item fromAnnouncement: anAnnouncement)
		ifFalse: [ ^ self ].
	edits := textModel hasUnacceptedEdits.
	edits
		ifTrue: [ text := textModel pendingText ].
	index := messageList selectedIndex.
	list := self messages
		remove: sel ifAbsent: [  ];
		add: item asFullRingDefinition;
		"to ensure it's still a RGMethod"
			yourself.
	self messages: list.
	self setSelectedIndex: index.
	edits
		ifFalse: [ ^ self ].
	textModel pendingText: text.
	textModel hasEditingConflicts: true! !

!MessageBrowser methodsFor: 'announcements' stamp: ''!
methodAdded: anAnnouncement
	"this method forces the announcement to be handled in the UI process"
	UIManager default defer: [ 
		self handleMethodAdded: anAnnouncement ]! !

!MessageBrowser methodsFor: 'api' stamp: ''!
topologicSort: aBoolean
	^ messageList topologicSort: aBoolean! !

!MessageBrowser methodsFor: 'api' stamp: ''!
refreshingBlock: aBlock
	refreshingBlock := aBlock! !

!MessageBrowser methodsFor: 'api' stamp: ''!
setRefreshingBlockForImplementorsOf: aSelector
	self refreshingBlock: [ :message | message selector = aSelector ]! !

!MessageBrowser methodsFor: 'initialization' stamp: ''!
initializeDropList

	toolbarPresenter 
		addItemLabeled: 'Source' do: [ self textConverter: SourceMethodConverter new ];
		addItemLabeled: 'Time stamp' do: [ self textConverter: TimeStampMethodConverter new ]! !

!MessageBrowser methodsFor: 'announcements - registration' stamp: ''!
registerToAnnouncements

	SystemAnnouncer uniqueInstance weak		
		when: MethodAdded send: #methodAdded: to: self;
		when: MethodModified send: #methodModified: to: self;
		when: MethodRecategorized send: #methodRecategorized: to: self;
		when: MethodRemoved send: #methodRemoved: to: self;
		when: ClassRenamed send: #classRenamed: to: self! !

!MessageBrowser methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self registerToAnnouncements.
	self announcer when: SpWidgetBuilt send: #buildUpdateTitle to: self! !

!MessageBrowser methodsFor: 'initialization' stamp: ''!
setFocus

	self focusOrder
		add: messageList;
		add: toolbarPresenter;
		add: textModel! !

!MessageBrowser methodsFor: 'api' stamp: ''!
sortingBlock: aBlock
	messageList sortingBlock: aBlock! !

!MessageBrowser methodsFor: 'announcements' stamp: ''!
methodRecategorized: aMethod! !

!MessageBrowser methodsFor: 'initialization' stamp: ''!
buildUpdateTitle
	"Trying to have a clean subscription, this method is called in #initialize"

	self updateTitle.
	textModel text: textModel text! !

!MessageBrowser methodsFor: 'private' stamp: ''!
windowIsClosing
	
	SystemAnnouncer uniqueInstance unsubscribe: self! !

!MessageBrowser methodsFor: 'api' stamp: ''!
updateTitle
	self withWindowDo: [ :window | window title: self title ]! !

!MessageBrowser methodsFor: 'text selection' stamp: ''!
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' stamp: ''!
installIconStylerFor: anItem
	"icons styler are only supported for method definitions (not nil / not for comment definitions    
	 (those may occure for comment or general string searches))"

	(self isMethodDefinition: anItem)
		ifFalse: [ ^ self ].
	
	IconStyler withStaticStylers 
		styleText: self textModel 
		withAst: anItem ast.! !

!MessageBrowser methodsFor: 'api' stamp: ''!
topologicSort
	^ messageList topologicSort! !

!MessageBrowser methodsFor: 'private' stamp: ''!
selectItem: item

	toolbarPresenter method: item.
	textModel beForMethod: item.
	textModel text: (self textConverter
		method: item;
		getText).
	self installIconStylerFor: item! !

!MessageBrowser methodsFor: 'private' stamp: ''!
packageNameForItem: anItem
	^ anItem package ifNil: [ '' ] ifNotNil: [ :package | package name ]! !

!MessageBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters
	super initializePresenters.

	textModel := self newCode.
	refreshingBlock := [ :item | true ].

	self
		initializeDropList;
		setFocus! !

!MessageBrowser methodsFor: 'initialization' stamp: ''!
connectPresenters
	messageList
		whenSelectionChangedDo: [ :selection | self selectItem: selection selectedItem ];
		whenModelChangedDo: [ self updateTitle ].
	textModel whenSubmitDo: [ :text | (self accept: text notifying: nil) notNil ]! !

!MessageBrowser methodsFor: 'accessing' stamp: ''!
textConverter: aTextConverter
	super textConverter: aTextConverter.
	textModel syntaxHighlight: self textConverter shouldShout .
	textModel text: self textConverter getText.! !

!MessageBrowser methodsFor: 'private' stamp: ''!
accept: text notifying: notifyer

	^ self selectedMessage ifNotNil: [ :message | 
		message methodClass 
			compile: text 
			classified: message protocol
			notifying: notifyer ]! !

!MessageBrowser methodsFor: 'api' stamp: ''!
selectIndex: anIndex
	messageList selectIndex: anIndex! !

!MessageBrowser methodsFor: 'messageList interface' stamp: ''!
open

	^self openWithSpec! !

!MessageBrowser methodsFor: 'private' stamp: ''!
codeFont
	^ StandardFonts codeFont! !

!MessageBrowser methodsFor: 'announcements' stamp: ''!
handleClassRenamed: anAnnouncement
	| items selectedIndex |
	items := self messages
		collect: [ :method | 
			| interestedClassName interestedClass |
			interestedClassName := anAnnouncement oldName.
			interestedClass := anAnnouncement classRenamed.
			method  methodClass isClassSide
				ifTrue: [ interestedClassName := interestedClassName , ' class'.
					interestedClass := interestedClass classSide ].
			method methodClass name = interestedClassName
				ifTrue: [ interestedClass >> method selector ]
				ifFalse: [ method ] ].
	selectedIndex := messageList selectedIndex.
	self messages: items! !

!MessageBrowser methodsFor: 'accessing' stamp: ''!
toolbarPresenter
	
	^ toolbarPresenter! !

!MessageBrowser methodsFor: 'text selection' stamp: ''!
sourceIntervalOf: aSelector in: aMethodNode
    | senderNode |
    senderNode := aMethodNode allChildren detect: [ :x | x isMessage and: [ x selector = aSelector ] ] ifNone: [ ^ #() ].
    ^ senderNode keywordsPositions first to: senderNode keywordsPositions last + senderNode keywords last size - 1 ! !

!MessageBrowser methodsFor: 'announcements' stamp: ''!
handleMethodAdded: anAnnouncement
	| item sel text boolean |

	self isDisplayed ifFalse: [ ^ self ].
	refreshingBlock ifNil: [ ^ self ].
	
	item := anAnnouncement method.
	
	(self shouldRefreshItem: item fromAnnouncement: anAnnouncement) ifFalse: [ ^ self ].
	((item methodClass notNil) and:[item methodClass isObsolete not]) ifFalse: [ ^ self ].
	
	boolean := textModel hasUnacceptedEdits.
	boolean ifTrue: [ text := textModel pendingText ].
	
	sel := self selectedMessage.
	self messages: (self messages add: item asFullRingDefinition; yourself).
	self selectedMessage: sel.
	
	boolean ifTrue: [ textModel pendingText: text ]! !

!MessageBrowser methodsFor: 'api' stamp: ''!
messages
	^ messageList messages! !

!MessageBrowser methodsFor: 'api' stamp: ''!
selectedMessage: aMessage
	messageList selectMessage: aMessage! !

!MessageBrowser methodsFor: 'announcements' stamp: ''!
classRenamed: anAnnouncement 
	"this method forces the announcement to be handled in the UI process"
	UIManager default defer: [ 
		self handleClassRenamed: anAnnouncement ]! !

!MessageBrowser methodsFor: 'private' stamp: ''!
methodClassNameForItem: anItem
	^ anItem methodClass ifNotNil: [ :class | class name ] ifNil: [ '' ]! !

!MessageBrowser methodsFor: 'accessing' stamp: ''!
selectedMethod
	^ messageList selectedMethod! !

!MessageBrowser methodsFor: 'private' stamp: ''!
title
	^ self class title , ' [' , messageList numberOfElements printString , ']'! !

!MessageBrowser methodsFor: 'api-events' stamp: ''!
whenSelectedItemChanged: aBlock 
	messageList whenSelectedItemChanged: aBlock ! !

!MessageBrowser methodsFor: 'api' stamp: ''!
messages: aCollection
	messageList messages: aCollection! !

!MessageBrowser methodsFor: 'announcements' stamp: ''!
methodModified: anAnnouncement
	"this method forces the announcement to be handled in the UI process"
	UIManager default defer:  [	
		self handleMethodModified: anAnnouncement ]! !

!MessageBrowser methodsFor: 'text selection' stamp: ''!
autoSelect: aSelector
	textModel
		readSelectionBlock:
			[ :text | 
			self selectedMessage ifNotNil:
					[ :msg | (self isMethodDefinition: msg)
						ifFalse: [ self intervalOf: aSelector inCommentText: text ] 
						ifTrue: [ self intervalOf: aSelector inCode: text of: msg ] ] ]! !

!MessageBrowser methodsFor: 'api' stamp: ''!
setRefreshingBlockForSendersOf: aSelector
	| specialIndex |
	specialIndex := Smalltalk specialSelectorIndexOrNil: aSelector.
	self refreshingBlock: [:method | 
		method hasSelector: aSelector specialSelectorIndex: specialIndex ]! !

!MessageBrowser methodsFor: 'announcements' stamp: ''!
methodRemoved: anAnnouncement
	"this method forces the announcement to be handled in the UI process"
	UIManager default defer:  [ 
		self handleMethodRemoved: anAnnouncement ]! !

!MessageBrowser methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	super initializeWindow: aWindowPresenter.
	aWindowPresenter
		title: self title;
		windowIcon: self taskbarIcon;
		askOkToClose: true! !

!MessageBrowser methodsFor: 'accessing' stamp: ''!
textModel: aModel
	
	textModel := aModel! !

!MessageBrowser class methodsFor: 'instance creation' stamp: ''!
browse: aCollection asImplementorsOf: aSymbol 
	"Special Version that sets the correct refreshing Block for Implentors Browser"
	^ self new
		setRefreshingBlockForImplementorsOf: aSymbol;
		messages: aCollection;
		title: 'Implementors of ', aSymbol printString;
		open! !

!MessageBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newTopToBottom
		add: #messageList;
		add: (SpBoxLayout newTopToBottom
			add: #toolbarPresenter expand: false;
			add: #textModel;
			yourself);
		yourself! !

!MessageBrowser class methodsFor: 'instance creation' stamp: ''!
browse: aCollection title: aString
	"Special Version that sets the correct refreshing Block for Implentors Browser"
	^ self new
		messages: aCollection;
		title: aString;
		open! !

!MessageBrowser class methodsFor: 'instance creation' stamp: ''!
browse: aCollection
	"Special Version that sets the correct refreshing Block for Implentors Browser"
	^ self new
		messages: aCollection;
		open! !

!MessageBrowser class methodsFor: 'instance creation' stamp: ''!
browse: aCollection asSendersOf: aSymbol 
	"Special Version that sets the correct refreshing Block for Senders Browser"
	^ self new
		setRefreshingBlockForSendersOf: aSymbol;
		autoSelect: aSymbol;
		messages: aCollection;
		title: 'Senders of ', aSymbol printString;
		open! !

!MessageBrowser class methodsFor: 'tool registration' stamp: ''!
registerToolsOn: registry

	"Add ourselves to registry. See [Smalltalk tools]" 
	registry register: self as: #messageList! !

!MessageBrowser class methodsFor: 'instance creation' stamp: ''!
browseImplementorsOf: aSymbol 
	"Special Version that sets the correct refreshing Block for Implentors Browser"
	^ self browse: aSymbol implementors asImplementorsOf: aSymbol! !

!MessageBrowser class methodsFor: 'instance creation' stamp: ''!
browseSendersOf: aSymbol 
	"Special Version that sets the correct refreshing Block for Implentors Browser"
	^ self browse: aSymbol senders asSendersOf: aSymbol! !

!MessageBrowser class methodsFor: 'instance creation - old' stamp: ''!
openMessageList: messageList name: aString autoSelect: aSelector refreshingBlockSelector: aRefreshingBlockSelector
	
	| browser |
	browser := self new
		messages: messageList;
		title: aString;
		autoSelect: aSelector;
		yourself.
		
	aRefreshingBlockSelector ifNotNil:[(browser perform: aRefreshingBlockSelector with: aSelector)].
	^browser open
	
				
! !

!MessageBrowser class methodsFor: 'specs' stamp: ''!
title
	^ 'Message Browser'! !

!MessageBrowser class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for an instance of the receiver in a task bar"

	^#referencesIcon! !

!MessageBrowser class methodsFor: 'instance creation' stamp: ''!
browse: aCollection title: aString autoSelect: aSelectString
	"Special Version that sets the correct refreshing Block for Implentors Browser"
	^ self new
		messages: aCollection;
		title: aString;
		autoSelect: aSelectString;
		open! !

!MessageCatcher commentStamp: ''!
Any message sent to me is returned as a Message object.

"Message catcher" creates an instance of me.
!
!MessageCatcher methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage

	accumulator ifNotNil: [accumulator add: aMessage].
	^ aMessage! !

!MessageCatcher methodsFor: 'private' stamp: ''!
privAccumulator: collection

	accumulator := collection! !

!MessageCatcher methodsFor: 'private' stamp: ''!
privAccumulator

	^ accumulator! !

!MessageDialogWindow commentStamp: ''!
Dialog window displaying a message with a single OK button. Escape/return will close. Icon is a themed information icon.!
!MessageDialogWindow methodsFor: 'actions' stamp: ''!
newContentMorph
	"Answer a new content morph."

	self iconMorph: self newIconMorph.
	self textMorph: self newTextMorph.
	^self newGroupboxFor: (self newRow: {self iconMorph. self textMorph})! !

!MessageDialogWindow methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	textFont:= self defaultTextFont! !

!MessageDialogWindow methodsFor: 'open/close' stamp: ''!
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: 'accessing' stamp: ''!
minimumWidth
	
	^ (self lineLengths max + 100) min: Display width.! !

!MessageDialogWindow methodsFor: 'initialization' stamp: ''!
defaultTextFont
	^self theme textFont! !

!MessageDialogWindow methodsFor: 'private' stamp: ''!
newTextMorph
	"Answer a text morph."
	^self newText: ' '! !

!MessageDialogWindow methodsFor: 'theme' stamp: ''!
playOpenSound
	"Play the themed sound for opening.
	Do nothing at present, done by the UIManager."! !

!MessageDialogWindow methodsFor: 'accessing' stamp: ''!
iconMorph

	^ iconMorph ifNil: [ iconMorph := self newIconMorph ]! !

!MessageDialogWindow methodsFor: 'private' stamp: ''!
lineLengths

	^ self textLines collect: [ :line | self textFont widthOfString: line ].! !

!MessageDialogWindow methodsFor: 'accessing' stamp: ''!
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: ''!
textFont
	"Answer the text font."
	
	^textFont! !

!MessageDialogWindow methodsFor: 'private' stamp: ''!
textLines

	^ self textMorph text asString lines.! !

!MessageDialogWindow methodsFor: 'theme' stamp: ''!
themeChanged
	"Update the icon."

	super themeChanged.
	self iconMorph image: self icon! !

!MessageDialogWindow methodsFor: 'actions' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self newOKButton isDefault: true}! !

!MessageDialogWindow methodsFor: 'visual properties' stamp: ''!
icon
	"Answer an icon for the receiver."

	^ self iconNamed: #infoIcon! !

!MessageDialogWindow methodsFor: 'accessing' stamp: ''!
textFont: aFont
	"Set the text font."
	
	textFont :=  aFont.
	self textMorph ifNotNil: [:m | m font: aFont]! !

!MessageDialogWindow methodsFor: 'accessing' stamp: ''!
textMorph: anObject
	"Set the value of textMorph"

	textMorph := anObject! !

!MessageDialogWindow methodsFor: 'accessing' stamp: ''!
iconMorph: anObject
	"Set the value of iconMorph"

	iconMorph := anObject! !

!MessageDialogWindow methodsFor: 'private' stamp: ''!
newIconMorph
	"Answer an icon for the receiver."
	
	^ImageMorph new form: self icon! !

!MessageDialogWindow methodsFor: 'accessing' stamp: ''!
textMorph
	"Answer the value of textMorph"

	^ textMorph! !

!MessageDialogWindow class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallInfoIcon! !

!MessageList commentStamp: ''!
I am a presenter listing messages. 

I am used by more complexe browsers such as MessageBrowser or VersionBrowser.
	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	cachedHierarchy:		<aDictionary>	 	A cache keeping info about the level of a class in the list.
	listModel:				<aListPresenter>	A list presenter to show all the messages.
	model:						<aTool>				A model grouping generic methods for managing packages/classes/groups/methods from a browser
	topologySort:			<aBoolean>		 	A boolean to know if we should use a topology sort or not.
!
!MessageList methodsFor: 'api - events' stamp: ''!
whenSelectedDo: aBlock

	listPresenter whenSelectedDo: aBlock! !

!MessageList methodsFor: 'sorting' stamp: ''!
sortClassesInCachedHierarchy: aMethodDefinition b: otherMethodDefinition
	"This method checks wether the cached inheritance hierarchy of a method should be before than the one of another method.
	It compares alphabetically the hierarchy using #compare:
	If both are alphabetically equals, it uses the size the hierarchy.
	We do not know why this is done like this."
	| aMethodHierarchy otherMethodHierarchy minSize|
	aMethodHierarchy := cachedHierarchy at: aMethodDefinition.
	otherMethodHierarchy := cachedHierarchy at: otherMethodDefinition.
	
	minSize := aMethodHierarchy size min: otherMethodHierarchy size.
	
	1 to: minSize do: [ :i | |compare|
		compare := (aMethodHierarchy at: i) printString compare: (otherMethodHierarchy at: i) printString.
		compare ~~ 2
			ifTrue: [  ^ compare == 1 ]].
	^  aMethodHierarchy size < otherMethodHierarchy size! !

!MessageList methodsFor: 'selecting' stamp: ''!
selectIndex: anInteger

	listPresenter selectIndex: anInteger! !

!MessageList methodsFor: 'accessing' stamp: ''!
locationOf: anItem
	^ String
		streamContents: [ :aStream | 
			3 to: (cachedHierarchy at: anItem) size do: [ :i | aStream << '    ' ].
			aStream << (self methodClassNameForItem: anItem) << ' ('.
			anItem isFromTrait
				ifTrue: [ aStream
						<< anItem compiledMethod origin name;
						space ].
			aStream << (self protocolNameForItem: anItem) << ')' ]! !

!MessageList methodsFor: 'actions' stamp: ''!
browseMethod

	self currentMethod ifNotNil: [ :aMethod | aMethod browse ]! !

!MessageList methodsFor: 'actions' stamp: ''!
browseSendersOfMessage

	self currentMethod ifNotNil: [ :aMethod |
		model browseSendersOfMessagesFrom: aMethod selector ]! !

!MessageList methodsFor: 'private' stamp: ''!
currentMethod

	^ method! !

!MessageList methodsFor: 'testing' stamp: ''!
cacheHierarchyForClasses: aCollection
	cachedHierarchy := self buildHierarchyForMessages: aCollection.! !

!MessageList methodsFor: 'accessing' stamp: ''!
messages
	^ listPresenter items! !

!MessageList methodsFor: 'accessing' stamp: ''!
numberOfElements
	^ listPresenter listSize! !

!MessageList methodsFor: 'api' stamp: ''!
contextMenu: aMenuPresenter
	listPresenter contextMenu: aMenuPresenter! !

!MessageList methodsFor: 'private' stamp: ''!
protocolNameForItem: anItem
	^ anItem category ifNil: [ '' ]! !

!MessageList methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aMethod 

	method := aMethod! !

!MessageList methodsFor: 'accessing' stamp: ''!
selectMessage: aMessage
	listPresenter selectItem: aMessage! !

!MessageList methodsFor: 'accessing' stamp: ''!
topologicSort: anObject
	topologySort := anObject! !

!MessageList methodsFor: 'accessing' stamp: ''!
model 
	^model! !

!MessageList methodsFor: 'private' stamp: ''!
methodClassNameForItem: anItem
	^ anItem methodClass ifNotNil: [ :class | class name ] ifNil: [ '' ]! !

!MessageList methodsFor: 'api - events' stamp: ''!
whenModelChangedDo: aBlock
	listPresenter whenModelChangedDo: aBlock! !

!MessageList methodsFor: 'accessing' stamp: ''!
selectedMethod
	self selectedMessage ifNil: [ ^ nil ].

	^ self selectedMessage compiledMethod! !

!MessageList methodsFor: 'testing' stamp: ''!
buildHierarchyForMessages: messages
	| result classes |
	self topologicSort ifFalse: [ 
		result := IdentityDictionary new.
		messages do: [:m | result at: m put: {} ].
		^ result ].
	
	result := Dictionary new.	
	classes := (messages collect: [ :each | each 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! !

!MessageList methodsFor: 'accessing' stamp: ''!
listPresenter

	^ listPresenter! !

!MessageList methodsFor: 'initialization' stamp: ''!
initialize
	topologySort := true.
	model := AbstractTool new.
	super initialize! !

!MessageList methodsFor: 'selecting' stamp: ''!
selectedIndex
	^ listPresenter selection selectedIndex! !

!MessageList methodsFor: 'private-focus' stamp: ''!
ensureKeyBindingsFor: aWidget
	aWidget bindKeyCombination: PharoShortcuts current browseShortcut toAction: [ self browseMethod ].
	aWidget bindKeyCombination: PharoShortcuts current inspectItShortcut toAction: [ self inspectMethod ].
	aWidget bindKeyCombination: PharoShortcuts current browseImplementorsShortcut toAction: [ self browseMessages ].
	aWidget bindKeyCombination: PharoShortcuts current browseSendersShortcut toAction: [ self browseSendersOfMessage ].
	aWidget bindKeyCombination: PharoShortcuts current browseReferencesShortcut toAction: [ self browseClassRefs ].
	aWidget bindKeyCombination: PharoShortcuts current browseVersionsShortcut toAction: [ self browseVersions ].
	aWidget bindKeyCombination: PharoShortcuts current removeShortcut toAction: [ self removeMethods ]! !

!MessageList methodsFor: 'api' stamp: ''!
sortingBlock: aBlock
	listPresenter sortingBlock: aBlock! !

!MessageList methodsFor: 'api - events' stamp: ''!
whenSelectionChangedDo: aBlock

	listPresenter whenSelectionChangedDo: aBlock! !

!MessageList methodsFor: 'actions' stamp: ''!
browseMessages
	self currentMethod ifNotNil: [ :aMethod |
		 model browseMessagesFrom: aMethod selector ]! !

!MessageList methodsFor: 'accessing' stamp: ''!
selectorOf: anItem
	^ anItem selector! !

!MessageList methodsFor: 'actions' stamp: ''!
browseVersions

	self currentMethod ifNotNil: [ :aMethod |
		model browseVersionsFrom: aMethod compiledMethod ]! !

!MessageList methodsFor: 'accessing' stamp: ''!
messages: aCollection
	self cacheHierarchyForClasses: aCollection.
	listPresenter items: cachedHierarchy keys asOrderedCollection.
	listPresenter listSize > 0 ifTrue: [ listPresenter selectIndex: 1 ]! !

!MessageList methodsFor: 'accessing' stamp: ''!
topologicSort
	^ topologySort! !

!MessageList methodsFor: 'private' stamp: ''!
packageOf: anItem
	^ '[' , (self packageNameForItem: anItem) , ']'! !

!MessageList methodsFor: 'actions' stamp: ''!
removeMethods

	self currentMethod ifNotNil: [ :aMethod |
		model removeMethod: aMethod inClass: aMethod methodClass ]! !

!MessageList methodsFor: 'private' stamp: ''!
packageNameForItem: anItem
	^ anItem package ifNil: [ '' ] ifNotNil: [ :package | package name ]! !

!MessageList methodsFor: 'accessing' stamp: ''!
messageListMenu
	^ self newMenu
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Browse full...';
						shortcut: $b meta;
						action: [ self selectedMethod browse ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Inspect method...';
						shortcut: $i meta;
						action: [ self selectedMethod inspect ] ] ];
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Remove method...';
						shortcut: $x meta;
						action: [ self selectedMethod removeFromSystem ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Senders of...';
						shortcut: $n meta;
						action: [ model browseSendersOfMessagesFrom: self selectedMethod selector ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Implementors of...';
						shortcut: $m meta;
						action: [ model browseMessagesFrom: self selectedMethod selector ] ] ];
		addItem: [ :anItem | 
			anItem
				name: 'Users of...';
				shortcut: $N meta;
				action: [ model browseClassRefsOf: self selectedMethod methodClass ] ];
		addItem:
			[ :anItem | 
			anItem
				name: 'Versions...';
				shortcut: $v meta;
				action: [ model browseVersionsFrom: self selectedMethod ] ] yourself! !

!MessageList methodsFor: 'initialization' stamp: ''!
initializePresenters
	listPresenter := self newTable.

	listPresenter
		sortingBlock: [ :a :b | self sortClassesInCachedHierarchy: a b: b ];
		addColumn: (SpStringTableColumn title: 'Location' evaluated: [ :item | self locationOf: item ]);
		addColumn: (SpStringTableColumn title: 'Selector' evaluated: [ :item | self selectorOf: item ]);
		addColumn: (SpStringTableColumn title: 'Package' evaluated: [ :item | self packageOf: item ]);
		beResizable.
		
	self contextMenu: self messageListMenu! !

!MessageList methodsFor: 'actions' stamp: ''!
browseClassRefs

	self currentMethod ifNotNil: [ :aMethod | 
		model browseClassRefsOf: aMethod methodClass ]! !

!MessageList methodsFor: 'actions' stamp: ''!
inspectMethod

	self currentMethod ifNotNil: [ :aMethod | aMethod inspect ]! !

!MessageList methodsFor: 'accessing' stamp: ''!
selectedMessage
	^ listPresenter selection selectedItem! !

!MessageList class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: #listPresenter;
		yourself! !

!MessageNotUnderstood commentStamp: ''!
This exception is provided to support Object>>doesNotUnderstand:.!
!MessageNotUnderstood methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
stDebuggerInspectorNodesFor: aStDebuggerContext

	^ aStDebuggerContext doesNotUnderstandNodesFor: self! !

!MessageNotUnderstood methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	reachedDefaultHandler := false! !

!MessageNotUnderstood methodsFor: 'accessing' stamp: ''!
message: aMessage

	message := aMessage! !

!MessageNotUnderstood methodsFor: 'accessing' stamp: ''!
reachedDefaultHandler
	^reachedDefaultHandler! !

!MessageNotUnderstood methodsFor: 'accessing' stamp: ''!
defaultAction

	reachedDefaultHandler := true.
	super defaultAction.! !

!MessageNotUnderstood methodsFor: 'accessing' stamp: ''!
receiver: obj

	receiver := obj! !

!MessageNotUnderstood methodsFor: 'private' stamp: ''!
isResumable
	"Determine whether an exception is resumable."

	^true! !

!MessageNotUnderstood methodsFor: 'accessing' stamp: ''!
receiver
	"Answer the receiver that did not understand the message"

	^ receiver! !

!MessageNotUnderstood methodsFor: 'accessing' stamp: ''!
message
	"Answer the selector and arguments of the message that failed."

	^message! !

!MessageNotUnderstood methodsFor: 'accessing' stamp: ''!
description

	"Returns a textual description of the exception (based on the message instance variable). If message is nil, it returns the defaultDescription instead."

	message ifNil: [ ^ self defaultDescription ].
	message lookupClass == UndefinedObject ifTrue: [ 
		^ message selector printString , ' was sent to nil' ].

	^ 'Instance of ' , message lookupClass printString
	  , ' did not understand ' , message selector printString! !

!MessageNotUnderstood methodsFor: 'accessing' stamp: ''!
messageText
	"Return an exception's message text."
	
	^ messageText 
			ifNil:
				[message 
					ifNil: [super messageText]
					ifNotNil: [
						message lookupClass == UndefinedObject
							ifTrue: ['receiver of "{1}" is nil' format: {message selector asString}]
							ifFalse: ['Message not understood: ', message lookupClass printString, ' >> #', message selector asString]]]! !

!MessageNotUnderstoodTest commentStamp: ''!
A MessageNotUnderstoodTest is a test class for testing the behavior of MessageNotUnderstood!
!MessageNotUnderstoodTest methodsFor: 'tests' stamp: ''!
testMessageText

	| messageText |
	[ 1 a ]
		on: Error
		do: [ :e | messageText := e messageText ].
	self
		assert: messageText
		equals: 'Message not understood: SmallInteger >> #a'! !

!MessageNotUnderstoodTest methodsFor: 'tests' stamp: ''!
testDescription

	| defaultDescription messageNotUndestoodDescription |
	defaultDescription := ''.
	messageNotUndestoodDescription := ''.
	"Note that in the following line, the IDE complaints that the method doesn't exists. This is intentional."
	[ Object aMessageThatDoesntExistsIntentiallyRequested ]
		on: MessageNotUnderstood
		do: [ :ex | 
			defaultDescription := ex defaultDescription.
			messageNotUndestoodDescription := ex description ].
	self deny: defaultDescription equals: messageNotUndestoodDescription! !

!MessageSend commentStamp: ''!
Instances of MessageSend encapsulate messages send to objects. Arguments can be either predefined or supplied when the message send is performed. 

Use #value to perform a message send with its predefined arguments and #valueWithArguments: if additonal arguments have to supplied.

Structure:
 receiver		Object -- object receiving the message send
 selector		Symbol -- message selector
 arguments		Array -- bound arguments!
!MessageSend methodsFor: 'evaluating' stamp: ''!
value: anObject

  ^ receiver 
    perform: selector 
    with: anObject! !

!MessageSend methodsFor: 'comparing' stamp: ''!
= anObject
	^ anObject species == self species 
		and: [receiver == anObject receiver
		and: [selector == anObject selector
		and: [arguments = anObject arguments]]]! !

!MessageSend methodsFor: 'comparing' stamp: ''!
hash
	^ receiver hash bitXor: selector hash! !

!MessageSend methodsFor: 'accessing' stamp: ''!
numArgs
	"Answer the number of arguments in this message"

	^arguments size! !

!MessageSend methodsFor: 'accessing' stamp: ''!
arguments: anArray
	arguments := anArray! !

!MessageSend methodsFor: 'accessing' stamp: ''!
receiver
	^ receiver! !

!MessageSend methodsFor: 'evaluating' stamp: ''!
value: anObject1 value: anObject2

	^ receiver 
		perform: selector 
		with: anObject1
		with: anObject2! !

!MessageSend methodsFor: 'evaluating' stamp: ''!
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: 'printing' stamp: ''!
printOn: aStream

        aStream
                nextPutAll: self class name;
                nextPut: $(.
        selector printOn: aStream.
        aStream nextPutAll: ' -> '.
        receiver printOn: aStream.
        aStream nextPut: $)! !

!MessageSend methodsFor: 'evaluating' stamp: ''!
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: '*TaskIt' stamp: ''!
asTask
	^ TKTTask valuable: self! !

!MessageSend methodsFor: 'private' stamp: ''!
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 methodsFor: 'evaluating' stamp: ''!
cull: arg
	^ selector numArgs = 0 
		ifTrue: [ self value ]
		ifFalse: [ self value: arg ].! !

!MessageSend methodsFor: 'converting' stamp: ''!
asMinimalRepresentation
	^self! !

!MessageSend methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!MessageSend methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!MessageSend methodsFor: 'evaluating' stamp: ''!
value: anObject1 value: anObject2 value: anObject3

	^ receiver 
		perform: selector 
		with: anObject1
		with: anObject2
		with: anObject3! !

!MessageSend methodsFor: 'accessing' stamp: ''!
selector: aSymbol
	selector := aSymbol! !

!MessageSend methodsFor: 'converting' stamp: ''!
asWeakMessageSend

	^ WeakMessageSend
		receiver: receiver
		selector: selector
		arguments: arguments copy! !

!MessageSend methodsFor: 'evaluating' stamp: ''!
cull: arg1 cull: arg2
	^ selector numArgs < 2 
		ifTrue: [ self cull: arg1]
		ifFalse: [ self value: arg1 value: arg2 ]! !

!MessageSend methodsFor: 'testing' stamp: ''!
isMessageSend
	^true! !

!MessageSend methodsFor: 'evaluating' stamp: ''!
value
  "Send the message and answer the return value"

  arguments ifNil: [^ receiver perform: selector].

  ^ receiver 
    perform: selector 
    withArguments: (self collectArguments: arguments)! !

!MessageSend methodsFor: 'testing' stamp: ''!
isValid
	^true! !

!MessageSend methodsFor: 'accessing' stamp: ''!
receiver: anObject
	receiver := anObject! !

!MessageSend methodsFor: 'evaluating' stamp: ''!
valueWithArguments: anArray

	^ receiver 
		perform: selector 
		withArguments: (self collectArguments: anArray)! !

!MessageSend methodsFor: 'accessing' stamp: ''!
message
	^Message selector: selector arguments: arguments! !

!MessageSend class methodsFor: 'instance creation' stamp: ''!
receiver: anObject selector: aSymbol
	^ self receiver: anObject selector: aSymbol arguments: #()! !

!MessageSend class methodsFor: 'instance creation' stamp: ''!
receiver: anObject selector: aSymbol arguments: anArray
	^ self new
		receiver: anObject;
		selector: aSymbol;
		arguments: anArray! !

!MessageSend class methodsFor: 'instance creation' stamp: ''!
message: aMessage to: anObject
	^ self receiver: anObject selector: aMessage selector arguments: aMessage arguments! !

!MessageSend class methodsFor: 'instance creation' stamp: ''!
receiver: anObject selector: aSymbol argument: aParameter
	^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter)! !

!MessageSendDebugAction commentStamp: ''!
A MessageSendDebugAction is an action that sends a message to a receiver with the right amount of arguments. 

To specify the receiver subclasses have to override the method #receiver. Furthermoe subclasses must specify an id. The selector is optional as the id will be used if no selector is present/


Instance Variables
	id:		<Object>
	selector:		<Object>

id
	- xxxxx

selector
	- xxxxx
!
!MessageSendDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ help! !

!MessageSendDebugAction methodsFor: 'actions' stamp: ''!
executeAction
	
	self receiver 
		perform: self selector
		withEnoughArguments: self arguments! !

!MessageSendDebugAction methodsFor: 'accessing' stamp: ''!
id: aSymbol
	
	id := aSymbol! !

!MessageSendDebugAction methodsFor: 'accessing' stamp: ''!
arguments

	^ #()! !

!MessageSendDebugAction methodsFor: 'accessing' stamp: ''!
selector

	^ selector ifNil: [ self id ]! !

!MessageSendDebugAction methodsFor: 'accessing' stamp: ''!
help: anObject
	help := anObject! !

!MessageSendDebugAction methodsFor: 'accessing' stamp: ''!
receiver

	^ nil! !

!MessageSendDebugAction methodsFor: 'accessing' stamp: ''!
selector: aSymbol

	selector := aSymbol! !

!MessageSendDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ id! !

!MessageTally commentStamp: ''!
My instances observe and report the amount of time spent in methods.

NOTE: a higher-level user interface (combining the MessageTally result tree with a method browser) is available from TimeProfileBrowser. Note that TimeProfileBrowser was not fancy with the different setting possibilities.

	TimeProfileBrowser spyOn:  [20 timesRepeat: 
			[Transcript show: 100 factorial printString]]
	

Strategies
-----------
MessageTally provides two different strategies available for profiling:

* spyOn: and friends use a high-priority Process to interrupt the block or process being spied on at periodic intervals. The interrupted call stack is then examined for caller information. See below for an example showing different settings

* tallySends: and friends use the interpreter simulator to run the block, recording every method call.

The two give you different results:

	* spyOn: gives you a view of where the time is being spent in your program, at least on a rough statistical level (assuming you've run the 	block for long enough and have a high enough poll rate). If you're trying to optimize your code, start here and optimize the methods where 	most of the time is being spent first.

	* tallySends: gives you accurate counts of how many times methods get called, and by exactly which route. If you're debugging, or trying to 	figure out if a given method is getting called too many times, this is your tool.

Q: How do you interpret MessageTally>>tallySends
A: The methods #tallySends and #spyOn: measure two very different quantities, but broken down in the same who-called-who format.  #spyOn: is approximate, but more indicative of real time spent, whereas #tallySends is exact and a precise record of how many times each method got executed.

Examples
----------

Here you can see all the processes computation time
	
		[1000 timesRepeat: [3.14159 printString. Processor yield]] fork.
		[1000 timesRepeat: [30 factorial. Processor yield]] fork.
		[1000 timesRepeat: [30 factorial. Processor yield]] fork.
		MessageTally spyAllOn: [ (Delay forMilliseconds: 100) wait] 


Settings
---------
You can change the printing format (that is, the whitespace and string compression) by using these instance methods: 
	maxClassNameSize:
	maxClassPlusSelectorSize:
	maxTabs:

You can change the default polling period (initially set to 1) by calling
	MessageTally defaultPollPeriod: numberOfMilliseconds


To understand the difference
----------------------------------
Here we see all the processes
	[1000 timesRepeat: [
		100 timesRepeat: [120 factorial].
		(Delay forMilliseconds: 10) wait
		]] forkAt: 45 named: '45'.
	MessageTally spyAllOn: [10000 timesRepeat: [1.23 printString]]
	
	
Here we only see the execution of the expression [10000 timesRepeat: [1.23 printString]
	[1000 timesRepeat: [
		100 timesRepeat: [120 factorial].
		(Delay forMilliseconds: 10) wait
		]] forkAt: 45 named: '45'.
	MessageTally spyOn: [10000 timesRepeat: [1.23 printString]]
	
Here we only check the exact message sends: this is not a pc-sampling approach
	[1000 timesRepeat: [
		100 timesRepeat: [120 factorial].
		(Delay forMilliseconds: 10) wait
		]] forkAt: 45 named: '45'.
	MessageTally tallySends: [10000 timesRepeat: [1.23 printString]]
	


!
!MessageTally methodsFor: 'tallying' stamp: ''!
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 sender) ifNil: [
		^ (self bumpBy: count) tallyPath: context in: aProcess by: count].
	
	"Find the node for the sending context (or add it if necessary)"
	^ (self tally: sender in: aProcess by: count) tallyPath: context in: aProcess by: count! !

!MessageTally methodsFor: 'comparing' stamp: ''!
< aMessageTally 
	"Refer to the comment in Magnitude|<."

	^tally > aMessageTally tally! !

!MessageTally methodsFor: 'comparing' stamp: ''!
hash
	"Hash is reimplemented because = is implemented."

	^method hash! !

!MessageTally methodsFor: 'tallying' stamp: ''!
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: 'initialization' stamp: ''!
spyEvery: millisecs onProcess: aProcess forMilliseconds: msecDuration
	"Create a spy and spy on the given process at the specified rate."
	| myDelay time0 endTime observedProcess sem |
	(aProcess isKindOf: Process)
		ifFalse: [self error: 'spy needs a Process here'].
	self class: aProcess suspendedContext receiver class method: aProcess suspendedContext method.
	"set up the probe"
	observedProcess := aProcess.
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	endTime := time0 + msecDuration.
	sem := Semaphore new.
	gcStats := Smalltalk vm getParameters.
	Timer ifNotNil: [ self error: 'it seems a tally is already running' ].
	Timer := [
			[
				| startTime |
				startTime := Time millisecondClockValue.
				myDelay wait.
				self
					tally: Processor preemptedProcess suspendedContext
					in: (observedProcess == Processor preemptedProcess ifTrue: [ observedProcess ] ifFalse: [nil])
					"tally can be > 1 if ran a long primitive"
					by: (Time millisecondClockValue - startTime) // millisecs.
				startTime < endTime
			] whileTrue.
			sem signal.
		] newProcess.
	Timer priority: Processor timingPriority-1.
		"activate the probe and evaluate the block"
	Timer resume.
	"activate the probe and wait for it to finish"
	sem wait.
	"Collect gc statistics"
	Smalltalk vm getParameters keysAndValuesDo: [ :idx :gcVal | 
		gcVal isNumber ifTrue: [ gcStats at: idx put: (gcVal - (gcStats at: idx)) ] ].
	time := Time millisecondClockValue - time0! !

!MessageTally methodsFor: 'private' stamp: ''!
copyWithTally: hitCount
	^ (self class new class: class method: method)
		reportOtherProcesses: reportOtherProcesses;
		process: process;
		bump: hitCount! !

!MessageTally methodsFor: 'comparing' stamp: ''!
isPrimitives
	"Detect pseudo node used to carry tally of local hits"
	^ receivers isNil! !

!MessageTally methodsFor: 'printing' stamp: ''!
printSenderCountsOn: aStream
	| mergedSenders |
	mergedSenders := IdentityDictionary new.
	senders do: [ :node | | mergedNode |
		mergedNode := mergedSenders at: node method ifAbsent: [ nil ].
		mergedNode
			ifNil: [ mergedSenders at: node method put: node ]
			ifNotNil: [ mergedNode bump: node tally ]].
	mergedSenders asSortedCollection do: [ :node | 
		10 to: node tally printString size by: -1 do: [ :i | aStream space].
		node printOn: aStream total: tally totalTime: nil tallyExact: true]! !

!MessageTally methodsFor: 'printing format' stamp: ''!
maxClassPlusSelectorSize: aNumber
	maxClassPlusSelectorSize := aNumber! !

!MessageTally methodsFor: 'reporting' stamp: ''!
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: 'printing' stamp: ''!
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: ''!
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: 'initialization' stamp: ''!
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: 'collecting leaves' stamp: ''!
bump: hitCount
	tally := tally + hitCount! !

!MessageTally methodsFor: 'accessing' stamp: ''!
tally
	"Answer the receiver's number of tally."

	^tally! !

!MessageTally methodsFor: 'printing' stamp: ''!
printOn: aStream total: total totalTime: totalTime tallyExact: isExact 

	isExact 
		ifTrue: [
			| myTally |
			myTally := tally.
			receivers == nil 
				ifFalse: [receivers do: [:r | myTally := myTally - r tally]].
			aStream
				print: myTally;
				space]
		ifFalse: [
			| percentage |
			percentage := tally asFloat / total * 100.0.
			aStream
				nextPutAll: (percentage printShowingDecimalPlaces: 1);
				nextPutAll: '% {';
				print: (percentage * totalTime / 100) rounded;
				nextPutAll: 'ms} '].
	receivers 
		ifNil: [
			aStream
				nextPutAll: 'primitives';
				cr]
		ifNotNil: [
			| className aSelector aClass |
			aSelector := method selector.
			aClass := method methodClass.
			className := aClass name contractTo: self maxClassNameSize.
			aStream
				nextPutAll: class name;
				nextPutAll: (aClass = class 
							ifTrue: ['>>']
							ifFalse: ['(' , aClass name , ')>>']);
				nextPutAll: (aSelector 
							contractTo: self maxClassPlusSelectorSize - className size);
				cr]! !

!MessageTally methodsFor: 'printing format' stamp: ''!
maxClassNameSize: aNumber
	maxClassNameSize := aNumber! !

!MessageTally methodsFor: 'accessing' stamp: ''!
theClass
	"Return the class of the object receiver related to this tally"
	
	 ^ class! !

!MessageTally methodsFor: 'comparing' stamp: ''!
sonsOver: threshold
	"Returns all the sons that are not below a certain threshold. threshold is a number."
	| hereTally sons |
	(receivers isNil or: [ receivers isEmpty ]) 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: ''!
spyEvery: millisecs on: aBlock
	"Create a spy and spy on the given block at the specified rate."
	"Spy only on the active process (in which aBlock is run)"

	| myDelay time0 observedProcess |
	aBlock isBlock
		ifFalse: [ self error: 'spy needs a block here' ].
	self class: aBlock receiver class method: aBlock method.
		"set up the probe"
	observedProcess := Processor activeProcess.
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	gcStats := Smalltalk vm getParameters.
	Timer ifNotNil: [ self error: 'it seems a tally is already running' ].
	Timer := [
		[ true ] whileTrue: [
			| startTime |
			startTime := Time millisecondClockValue.
			myDelay wait.
			self
				tally: Processor preemptedProcess suspendedContext
				in: (observedProcess == Processor preemptedProcess ifTrue: [observedProcess] ifFalse: [nil])
				"tally can be > 1 if ran a long primitive"
				by: (Time millisecondClockValue - startTime) // millisecs].
		nil] newProcess.
	Timer priority: Processor timingPriority-1.
		"activate the probe and evaluate the block"
	Timer resume.
	^ aBlock ensure: [
		"cancel the probe and return the value"
		"Could have already been terminated. See #terminateTimerProcess"
		Timer ifNotNil: [
			Timer terminate.
			Timer := nil ].
		"Collect gc statistics"
		Smalltalk vm getParameters keysAndValuesDo: [ :idx :gcVal | 
			gcVal isNumber ifTrue: [ gcStats at: idx put: (gcVal - (gcStats at: idx))]].
		time := Time millisecondClockValue - time0]! !

!MessageTally methodsFor: 'accessing' stamp: ''!
reportOtherProcesses: aBoolean
	reportOtherProcesses := aBoolean! !

!MessageTally methodsFor: 'printing' stamp: ''!
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: 'reporting' stamp: ''!
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: 'initialization' stamp: ''!
spyAllEvery: millisecs on: aBlock
	"Create a spy and spy on the given block at the specified rate."
	"Spy all the system processes"

	| myDelay time0 |
	aBlock isBlock
		ifFalse: [ self error: 'spy needs a block here' ].
	self class: aBlock receiver class method: aBlock method.
		"set up the probe"
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	gcStats := Smalltalk vm getParameters.
	Timer ifNotNil: [ self error: 'it seems a tally is already running' ].
	Timer := [
		[true] whileTrue: [
			| startTime observedProcess |
			startTime := Time millisecondClockValue.
			myDelay wait.
			observedProcess := Processor preemptedProcess.
			self
				tally: observedProcess suspendedContext
				in: observedProcess
				"tally can be > 1 if ran a long primitive"
				by: (Time millisecondClockValue - startTime) // millisecs].
		nil] newProcess.
	Timer priority: Processor timingPriority-1.
		"activate the probe and evaluate the block"
	Timer resume.
	^ aBlock ensure: [
		"cancel the probe and return the value"
		"Could have already been terminated. See #terminateTimerProcess"
		Timer ifNotNil: [
			Timer terminate.
			Timer := nil ].
		"Collect gc statistics"
		Smalltalk vm getParameters keysAndValuesDo: [ :idx :gcVal | 
			gcVal isNumber ifTrue: [ gcStats at: idx put: (gcVal - (gcStats at: idx))]].
		time := Time millisecondClockValue - time0]! !

!MessageTally methodsFor: 'private' stamp: ''!
primitives: anInteger

	tally := anInteger.
	receivers := nil! !

!MessageTally methodsFor: 'printing format' stamp: ''!
maxTabs: aNumber
	maxTabs := aNumber! !

!MessageTally methodsFor: 'accessing' stamp: ''!
process
	"Return the profiled process"
	
	^process! !

!MessageTally methodsFor: 'comparing' stamp: ''!
= aMessageTally

	self species == aMessageTally species ifFalse: [^ false].
	^ aMessageTally method == method 
		and: [ aMessageTally process == process ]! !

!MessageTally methodsFor: 'printing format' stamp: ''!
maxClassPlusSelectorSize
	^maxClassPlusSelectorSize! !

!MessageTally methodsFor: 'accessing' stamp: ''!
receivers 
	^ receivers ! !

!MessageTally methodsFor: 'collecting leaves' stamp: ''!
leavesInto: leafDict fromSender: senderTally

	| rcvrs |
	rcvrs := self sonsOver: 0.
	rcvrs isEmpty
		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: 'printing' stamp: ''!
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: ''!
displayStringOn: aStream
	self displayIdentifierOn: aStream.
	aStream 
		nextPutAll: ' (';
		nextPutAll: self tally printString;
		nextPutAll: ')'! !

!MessageTally methodsFor: 'printing' stamp: ''!
printOn: aStream 
	| aSelector className |
	(class isNil or: [method isNil]) ifTrue: [^super printOn: aStream].
	aSelector := method selector.
	className := method methodClass name.
	aStream
		nextPutAll: (class name contractTo: self maxClassNameSize);
		nextPutAll: '(';
		nextPutAll: (className  contractTo: self maxClassNameSize);
		nextPutAll: ')';
		nextPutAll: ' >> ';
		nextPutAll: (aSelector 
					contractTo: self maxClassPlusSelectorSize - className size)! !

!MessageTally methodsFor: 'comparing' stamp: ''!
> aMessageTally 
	"Refer to the comment in Magnitude|>."

	^tally < aMessageTally tally! !

!MessageTally methodsFor: 'private' stamp: ''!
close

	Timer ifNotNil: [ Timer terminate ].
	Timer := nil.
	class := method := tally := receivers := nil! !

!MessageTally methodsFor: 'tallying' stamp: ''!
bumpBy: count

	tally := tally + count! !

!MessageTally methodsFor: 'private' stamp: ''!
class: aClass method: aMethod

	class := aClass.
	method := aMethod.
	tally := 0.
	receivers := Array new: 0! !

!MessageTally methodsFor: 'printing format' stamp: ''!
maxClassNameSize
	^maxClassNameSize! !

!MessageTally methodsFor: 'tallying' stamp: ''!
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 sender) ifNil: [
		^ (self bumpBy: count) tallyPath: context by: count].
	
	"Find the node for the sending context (or add it if necessary)"
	^ (self tally: sender by: count) tallyPath: context by: count! !

!MessageTally methodsFor: 'printing' stamp: ''!
rootPrintOn: aStream total: total totalTime: totalTime threshold: threshold

	| groups |
	groups := (self sonsOver: threshold) groupedBy: [ :aTally | aTally process] having: [ :g | true ].
	groups do: [ :g |
		| sons p |
		sons := g asArray sort.
		p := g anyOne process.
		(reportOtherProcesses or: [ p notNil ]) ifTrue: [
			aStream nextPutAll: '--------------------------------'; cr.
			aStream nextPutAll: 'Process: ',  (p ifNil: [ 'other processes'] ifNotNil: [ p browserPrintString]); cr.
			aStream nextPutAll: '--------------------------------'; cr.
			sons do: [ :son |
				son
					treePrintOn: aStream
					tabs: OrderedCollection new
					thisTab: ''
					total: total
					totalTime: totalTime
					tallyExact: false
					orThreshold: threshold]].
	]! !

!MessageTally methodsFor: 'accessing' stamp: ''!
method
	"Return the compiled method associated to this tally"
	
	^method! !

!MessageTally methodsFor: 'tallying' stamp: ''!
tallyPath: context by: count
	| aMethod path |
	aMethod := context method.
	
	"Find the correct child (if there)"
	receivers do: [ :oldTally | 
		oldTally method == aMethod ifTrue: [path := oldTally]].
	
	"Add new child if needed"
	path ifNil: [
		path := self class new class: context receiver class method: aMethod.
		path reportOtherProcesses: reportOtherProcesses.
		receivers := receivers copyWith: path].
	
	^ path bumpBy: count! !

!MessageTally methodsFor: 'printing' stamp: ''!
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: 'accessing' stamp: ''!
time
	"Answer the receiver's run time."

	^time! !

!MessageTally methodsFor: 'collecting leaves' stamp: ''!
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: 'accessing' stamp: ''!
reportOtherProcesses
	^ reportOtherProcesses! !

!MessageTally methodsFor: 'accessing' stamp: ''!
process: aProcess
	process := aProcess! !

!MessageTally methodsFor: 'reporting' stamp: ''!
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: 'collecting leaves' stamp: ''!
into: leafDict fromSender: senderTally 
	| leafNode |
	leafNode := leafDict at: method
				ifAbsentPut: 
					[ (self class new class: class method: method)
						process: process;
						reportOtherProcesses: reportOtherProcesses ].
					
	leafNode bump: tally fromSender: senderTally! !

!MessageTally methodsFor: 'printing format' stamp: ''!
maxTabs
	^maxTabs! !

!MessageTally class methodsFor: 'examples' stamp: ''!
example

	[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]! !

!MessageTally class methodsFor: 'spying' stamp: ''!
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"
	
	| node |
	node := self new.
	node reportOtherProcesses: aBoolean.
	node
		spyEvery: self defaultPollPeriod
		onProcess: aProcess
		forMilliseconds: msecDuration.
	fileName asFileReference writeStreamDo: [ :out | node report: out ]! !

!MessageTally class methodsFor: 'defaults' stamp: ''!
defaultMaxClassPlusSelectorSize
	"Return the default maximum width of the class plus selector together (not counting the '>>')"
	^100! !

!MessageTally class methodsFor: 'defaults' stamp: ''!
defaultPollPeriod: numberOfMilliseconds
	"Set the default number of milliseconds between interrupts for spyOn: and friends.
	This should be faster for faster machines."
	DefaultPollPeriod := numberOfMilliseconds! !

!MessageTally class methodsFor: 'spying' stamp: ''!
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.
	StandardWindow new
		withText:
				(String streamContents: [ :s |  node report: s cutoff: aNumber; close ])
			label: 'Spy Results';
		openInWorld.
	^ result! !

!MessageTally class methodsFor: 'spying' stamp: ''!
tallySendsTo: receiver inBlock: aBlock showTree: treeOption closeAfter: closeAfter
	^ self tallySendsTo: receiver inBlock: aBlock showTree: treeOption closeAfter: closeAfter openResultWindow: true! !

!MessageTally class methodsFor: 'public' stamp: ''!
spyOn: aBlock toFileNamed: fileName reportOtherProcesses: aBoolean
	"Spy on the evaluation of aBlock. Write the data collected on a file
	named fileName."

	| value node |
	node := self new.
	node reportOtherProcesses: aBoolean.
	value := node spyEvery: self defaultPollPeriod on: aBlock.
	fileName asFileReference writeStreamDo: [ :out | node report: out ].
	^ value! !

!MessageTally class methodsFor: 'spying' stamp: ''!
spyOn: aBlock reportOtherProcesses: aBoolean cutoff: aNumber openResultWindow: openResultWindow

	^ self 
		spyOn: aBlock 
		reportOtherProcesses: aBoolean 
		cutoff: aNumber 
		openResultWindow: openResultWindow 
		closeAfter: true! !

!MessageTally class methodsFor: 'private' stamp: ''!
terminateTimerProcess
	<script>
	Timer ifNotNil: [ Timer terminate ].
	Timer := nil! !

!MessageTally class methodsFor: 'spying' stamp: ''!
spyAllOn: aBlock
	"Spy on all the processes in the system"
	<script: 'self example'>
	^ self spyAllOn: aBlock cutoff: 1! !

!MessageTally class methodsFor: 'spying' stamp: ''!
spyOnProcess: aProcess forMilliseconds: msecDuration 

	^self spyOnProcess: aProcess forMilliseconds: msecDuration reportOtherProcesses: false
! !

!MessageTally class methodsFor: 'spying' stamp: ''!
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: ''!
tallySendsTo: receiver inBlock: aBlock showTree: treeOption closeAfter: closeAfter openResultWindow: openResultWindow
	"
	MessageTally tallySends: [3.14159 printString]
	"
	"This method uses the simulator to count the number of calls on each method
	invoked in evaluating aBlock. If receiver is not nil, then only sends
	to that receiver are tallied.
	Results are presented as leaves, sorted by frequency,
	preceded, optionally, by the whole tree."
	| prev tallies startTime totalTime |
	startTime := Time millisecondClockValue.
	tallies := self new class: aBlock receiver class method: aBlock method.
	tallies reportOtherProcesses: true.	"Do NOT filter nodes with nil process"
	prev := aBlock.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			current == prev ifFalse: 
				["call or return"
				prev sender ifNotNil: 
					["call only"
					(receiver isNil or: [current receiver == receiver])
						ifTrue: [tallies tally: current by: 1]].
				prev := current]].

	totalTime := Time millisecondClockValue - startTime // 1000.0 roundTo: 0.01.
	openResultWindow ifTrue: [
		StandardWindow new 
			withText: (String streamContents:
				[:s |
				s nextPutAll: 'This simulation took ' , totalTime printString
								, ' seconds.'; cr.
				treeOption
					ifTrue: [ tallies fullPrintExactOn: s ]
					ifFalse: [ tallies leavesPrintExactOn: s ].
				])
			 label: 'Spy Results';
			openInWorld ].
	closeAfter ifTrue: [ tallies close ].
	^ tallies! !

!MessageTally class methodsFor: 'spying' stamp: ''!
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: [ 
			StandardWindow new
				withText: (String streamContents: [ :s | node report: s cutoff: aNumber ]) label: 'Spy Results';
				openInWorld ].
	closeAfter
		ifTrue: [ node close ].
	^ node! !

!MessageTally class methodsFor: 'spying' stamp: ''!
spyOn: aBlock cutoff: aNumber

	^self spyOn: aBlock reportOtherProcesses: false cutoff: aNumber! !

!MessageTally class methodsFor: 'spying' stamp: ''!
tallySendsTo: receiver inBlock: aBlock showTree: treeOption
	^ self tallySendsTo: receiver inBlock: aBlock showTree: treeOption closeAfter: true! !

!MessageTally class methodsFor: 'spying' stamp: ''!
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: 'examples' stamp: ''!
exampleSpyForSeconds

	self spyFor: 2! !

!MessageTally class methodsFor: 'spying' stamp: ''!
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: ''!
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.
	StandardWindow new
		withText:  (String streamContents: [:s | node report: s])
		 label: 'Spy Results';
		openInWorld.! !

!MessageTally class methodsFor: 'defaults' stamp: ''!
defaultMaxTabs
	"Return the default number of tabs after which leading white space is compressed"
	^120! !

!MessageTally class methodsFor: 'public' stamp: ''!
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: ''!
time: aBlock

	^ Time millisecondsToRun: aBlock! !

!MessageTally class methodsFor: 'defaults' stamp: ''!
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: ''!
defaultMaxClassNameSize
	"Return the default maximum width of the class name alone"
	^50! !

!MessageTallyTest commentStamp: ''!
SUnit tests for MessageTally!
!MessageTallyTest methodsFor: 'basic' stamp: ''!
testInstantiation

	| messageTally |
	messageTally := MessageTally new.
	self assert: messageTally time equals: 0.
	self assert: messageTally tally equals: 0! !

!MessageTallyTest methodsFor: 'tallying' stamp: ''!
testTallySends
	| tally thisMethod allProcesses processUsedByTally tallyForPrintString tallyForPrintStringBase blockToTest |
	allProcesses := Process allInstances.

	blockToTest := [ 3.14159s printString ].

	tally := MessageTally
		tallySendsTo: nil
		inBlock: blockToTest
		showTree: true
		closeAfter: false
		openResultWindow: false.

	"tally is for this test block. In FullBlocks the method is the CompiledBlock and not the CompiledMethod"
	thisMethod := blockToTest method.
	self assert: tally hash equals: thisMethod hash.
	self assert: tally method identicalTo: thisMethod.
	self assert: tally theClass identicalTo: 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 equals: 2.

	"--------"
	tallyForPrintString := tally receivers second.
	"Since 3.14159s is a ScaledDecimal"
	self assert: (tallyForPrintString theClass includesBehavior: ScaledDecimal).
	"the executed method is Number>>printString"
	self assert: tallyForPrintString method identicalTo: Number >> #printString.
	self assert: tallyForPrintString tally >= 50.

	"--------"
	tallyForPrintStringBase := tallyForPrintString receivers first.
	"The receiver is still a ScaledDecimal"
	self assert: (tallyForPrintString theClass includesBehavior: ScaledDecimal).
	"the executed method is Number>>printStringBase: this time"
	self assert: tallyForPrintStringBase method identicalTo: Number >> #printStringBase:.
	self assert: tallyForPrintStringBase tally >= 50.

	"The method printStringBase: calls two methods:
	   SequenceableCollection class >> streamContents: and ScaledDecimal >> printOn:base:"

	self assert: tallyForPrintStringBase receivers size equals: 1.
	self assert: tallyForPrintStringBase receivers first tally >= 50.

	"We close to explicitly release reference of the process, the class and methods"
	tally close! !

!MessageTallyTest methodsFor: 'tallying' stamp: ''!
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: 'sampling' stamp: ''!
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: ''!
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
	! !

!MetaClassTest methodsFor: 'tests' stamp: ''!
testHasClassVarNamed

	self assert: (Object class hasClassVarNamed: #DependentsFields).
	self deny: (Object class hasClassVarNamed: #CompilerClass)! !

!MetaClassTest methodsFor: 'tests' stamp: ''!
testclassVarNames

	self assert: (Object class classVarNames includes: #DependentsFields).
	
	"A class and it's meta-class share the class variables"
	self assert: Object class classVarNames equals: Object classVarNames! !

!MetaClassTest methodsFor: 'tests' stamp: ''!
testHasBindingThatBeginsWith
	self assert: (SmalltalkImage class hasBindingThatBeginsWith: 'Compiler').
	self assert: (SmalltalkImage class hasBindingThatBeginsWith: 'Object').
	
	"Pools are looked up, too"
	self assert: (TimeZone class hasBindingThatBeginsWith: 'DaysInMo')! !

!MetaLink commentStamp: ''!
Metalinks are used to annotate AST nodes. An annotated AST is expanded, compiled and executed on the fly thanks to the ReflectiveMethod/CompiledMethod twin. 

For a given node, metalinks can be put at different positions:

- before: The metalink is executed before the execution of the node.  
- instead: The metalink is executed insted the node.
- after: The metalink is executed after the execution of the node.
(... later: onError,  Do we have an #around instead of #instead?)

Not all the nodes provide all the position. For example, literals don't provide onError and onSuccess positions.

Public API:

- metaObject: The target object to call
- selector: send this selector
- condition:  turn link on/off 
- level: Meta Level at which the link is active

------ Examples -----

MetaLink new 
	metaObject: Halt;
	selector: #now.
	
MetaLink new 
	metaObject: [ self halt ];
	selector: #value.!
!MetaLink methodsFor: 'private' stamp: ''!
reificationsFor: aBlockOrBoolean
	(aBlockOrBoolean isKindOf: Boolean) ifTrue: [ ^#() ].
	(aBlockOrBoolean isKindOf: RFCondition) ifTrue: [^aBlockOrBoolean reifications].
	^aBlockOrBoolean argumentNames.! !

!MetaLink methodsFor: 'accessing' stamp: ''!
condition
	^condition! !

!MetaLink methodsFor: 'options' stamp: ''!
hasOption: aSymbol
	^options includes: aSymbol! !

!MetaLink methodsFor: 'accessing' stamp: ''!
allReifications
	| reifications |
	"we only check reification, that is symbols."
	reifications := (self arguments select: [:each | each isSymbol]) asSet. 
	self metaObject isSymbol ifTrue: [reifications add: self metaObject].
	
	self conditionArguments ifNil: [  
		self condition ifNotNil: [reifications addAll: (self reificationsFor: self condition)]]
		ifNotNil: [reifications addAll: self conditionArguments ].
	
	^reifications! !

!MetaLink methodsFor: 'accessing' stamp: ''!
metaLinkOptions: anArray
	self options: anArray! !

!MetaLink methodsFor: 'accessing' stamp: ''!
level
	<metaLinkOptions: #( + optionDisabledLink)>
	^ level! !

!MetaLink methodsFor: 'link api' stamp: ''!
metaObject: anObject
	metaObject := anObject.
	self optionInlineMetaObject ifTrue: [^self invalidate].
	nodes do: [ :node | | methodNode |
		methodNode := node methodNode.
		(methodNode metaLinkOptionsFromClassAndMethod includes: #optionInlineMetaObject)
			 ifTrue: [ methodNode method invalidate ] ].
	
	! !

!MetaLink methodsFor: 'installing' stamp: ''!
announceRemove: node
	self optionAnnounce ifTrue: [SystemAnnouncer uniqueInstance announce: (MetalinkChanged linkRemoved: self fromNode: node)]! !

!MetaLink methodsFor: 'options' stamp: ''!
optionArgsAsArray: aBoolean
	"If this option is set to true, this metalink will send the required reified elements to its metaobject as one single array instead of as multiple arguments"
	aBoolean
		ifTrue: [ options add: #argsAsArray ] 
		ifFalse: [ options remove: #argsAsArray ifAbsent:[] ]! !

!MetaLink methodsFor: 'options' stamp: ''!
optionInlineMetaObject
	^ options includes: #optionInlineMetaObject! !

!MetaLink methodsFor: 'accessing' stamp: ''!
options: anArray 
	self parseOptions: anArray! !

!MetaLink methodsFor: 'installing' stamp: ''!
installOnVariable: aVariable
	nodes add: aVariable! !

!MetaLink methodsFor: 'link api' stamp: ''!
control: aRFLinkControl
	control:= aRFLinkControl.
	self invalidate.! !

!MetaLink methodsFor: 'initialization' stamp: ''!
initialize
	nodes := IdentitySet new.
	control := #before.
	selector := #value.
	arguments := #().
	options := Set new.
	self parseOptions: self class defaultOptions.! !

!MetaLink methodsFor: 'accessing' stamp: ''!
selector
	^selector
	! !

!MetaLink methodsFor: 'accessing' stamp: ''!
arguments
	^arguments! !

!MetaLink methodsFor: 'installing' stamp: ''!
checkForCompatibilityWith: aNode
	| supported |
	
	supported := Set new.
	RFReification subclasses do: [:plugin |
		(plugin entities anySatisfy: [:class | aNode isKindOf: class]) ifTrue: [
		supported add: plugin key]].
	self allReifications do: [ :each | (supported includes: each) ifFalse: [^false  ]  ].
	^true! !

!MetaLink methodsFor: 'accessing' stamp: ''!
control
	^control
	! !

!MetaLink methodsFor: 'accessing' stamp: ''!
option: anArray 
	self parseOptions: anArray! !

!MetaLink methodsFor: 'reflective api' stamp: ''!
enable
	"turn on link reflectively if it has been turned off"
	self condition: (self condition originalLinkCondition)
	"self hasReifiedCondition
		ifTrue: [self condition enable]."
	
! !

!MetaLink methodsFor: 'accessing' stamp: ''!
linkInstaller
	^ self class linkInstaller! !

!MetaLink methodsFor: 'options' stamp: ''!
optionCompileOnLinkInstallation
	^ options includes: #optionCompileOnLinkInstallation! !

!MetaLink methodsFor: 'installing - link installer' stamp: ''!
installOnVariable: aVariable for: aClassOrObject option: option instanceSpecific: instanceSpecific

	| permalink |
	permalink := self permaLinkFor: aClassOrObject option: option instanceSpecific: instanceSpecific.
	^ self linkInstaller installPermaLink: permalink onVariable: aVariable! !

!MetaLink methodsFor: 'installing' stamp: ''!
installOn: aNode 
	nodes add: aNode
	! !

!MetaLink methodsFor: 'installing' stamp: ''!
invalidate
	nodes do: [ :node | node invalidate ]! !

!MetaLink methodsFor: 'options' stamp: ''!
optionOneShot
	^ options includes: #optionOneShot! !

!MetaLink methodsFor: 'printing' stamp: ''!
printString
	| ws keywords |
	ws := WriteStream on: String new.
	ws nextPutAll: 'Link'.
	ws space.
	ws nextPutAll: (self control ifNil: [ '' ]).
	ws space.
	ws nextPutAll: metaObject printString.
	ws space.
	selector isKeyword ifFalse: [ 
		ws nextPutAll: selector asString.
		^ ws contents ].
	keywords := selector separateKeywords splitOn: '  '.
	(arguments isEmpty or: [ keywords size ~= arguments size ]) ifTrue: [ 
		ws nextPutAll: 'Error: wrong number of arguments'.
		^ ws contents ].
	keywords with: arguments do: [ :keyword :argument | 
		ws nextPutAll: keyword.
		ws space.
		ws nextPutAll: argument printString.
		ws space ].
	^ ws contents! !

!MetaLink methodsFor: 'installing - link installer' stamp: ''!
unlinkFromNode: aNode forObject: anObject

	self linkInstaller uninstall: self fromNode: aNode forObject: anObject! !

!MetaLink methodsFor: 'installing - link installer' stamp: ''!
installOnVariableNamed: aName for: aClassOrObject option: option instanceSpecific: instanceSpecific

	| permalink variable |
	permalink := self permaLinkFor: aClassOrObject option: option instanceSpecific: instanceSpecific.
	variable := permalink targetObjectOrClass nonAnonymousClass lookupVar: aName.
	^ self linkInstaller installPermaLink: permalink onVariable: variable! !

!MetaLink methodsFor: 'options' stamp: ''!
optionAnnounce: aBoolean
	aBoolean
		ifTrue: [ options add: #optionAnnounce ] 
		ifFalse: [ options remove: #optionAnnounce ifAbsent:[] ]! !

!MetaLink methodsFor: 'installing - link installer' stamp: ''!
permaLinkFor: aClassOrObject option: option instanceSpecific: instanceSpecific
	| permaLink |
	permaLink := PermaLink new.
	permaLink persistenceType: option.
	permaLink isInstanceSpecific: instanceSpecific.
	permaLink slotOrVarClass: aClassOrObject.
	permaLink link: self.
	^ permaLink! !

!MetaLink methodsFor: 'private' stamp: ''!
doesNotUnderstand: message

	(message selector isUnary and: [ message selector beginsWith: 'option'] )
		ifTrue: [ ^ options includes: message selector ].
		
	^ super doesNotUnderstand: message! !

!MetaLink methodsFor: 'installing - link installer' stamp: ''!
linkToNode: aNode forObject: anObject

	self linkInstaller install: self onNode: aNode forObject: anObject! !

!MetaLink methodsFor: 'options' stamp: ''!
optionDisabledLink: aBoolean
	aBoolean
		ifTrue: [ options add: #optionDisabledLink ] 
		ifFalse: [ options remove: #optionDisabledLink ifAbsent:[] ]! !

!MetaLink methodsFor: 'options' stamp: ''!
optionArgsAsArray
	^ options includes: #argsAsArray! !

!MetaLink methodsFor: 'link api' stamp: ''!
arguments: anArray
	"anArray - elements can be either:
		- aSymbol, which will be converted into an instance of RFReification. For a list of reifications available to the node to which you wish to link, do: `aNode availableReifications`. If you don't have the particular node handy, since the reifications depend only on the node's class, you can also do e.g. `RBMethodNode new availableReifications`
		- anRBNode"

	arguments := anArray.
	self invalidate.! !

!MetaLink methodsFor: 'options' stamp: ''!
optionOneShot: aBoolean
	aBoolean
		ifTrue: [ options add: #optionOneShot ] 
		ifFalse: [ options remove: #optionOneShot ifAbsent:[] ]! !

!MetaLink methodsFor: 'private' stamp: ''!
parseOptions: optionsArray

	options parseOptions: optionsArray! !

!MetaLink methodsFor: 'link api' stamp: ''!
level: anObject
	level := anObject.
	self invalidate.! !

!MetaLink methodsFor: 'testing' stamp: ''!
hasNodes
	^ nodes notEmpty! !

!MetaLink methodsFor: 'testing' stamp: ''!
hasReifiedCondition
	self hasCondition ifFalse: [ ^false ].
	^self condition isKindOf: RFCondition! !

!MetaLink methodsFor: 'accessing' stamp: ''!
methods
	^nodes flatCollect: [ :entity |
		(entity isKindOf: RBProgramNode) 
			ifTrue: [ {entity methodNode compiledMethod}  ]
			ifFalse: [ entity usingMethods ] ]! !

!MetaLink methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inpectionDefiniton
	<inspectorPresentationOrder: 920 title: 'Definition'>
	^ SpTextPresenter new 
		text: (self definitionString);
		yourself! !

!MetaLink methodsFor: 'accessing' stamp: ''!
conditionArguments
	^conditionArguments! !

!MetaLink methodsFor: 'options' stamp: ''!
optionDisabledLink
	^ options includes: #optionDisabledLink! !

!MetaLink methodsFor: 'options' stamp: ''!
optionMetalevel
	^ options includes: #optionMetalevel! !

!MetaLink methodsFor: 'installing' stamp: ''!
uninstall
	"An uninstalled metaLink may not be re-installable. If you want to be sure you can reinstall it, please use #disable and #enable.
	Cases when this metalink cannot be reinstalled:
		- the method the AST node belongs to has been recompiled
		- the image was saved (i.e. the ASTCache was reset)"
	self linkInstaller uninstallFromAllAnonymousNodes: self.
	self linkInstaller uninstallPermaLinkFor: self.
	nodes do: [ :node | node removeLink: self ].
	nodes removeAll ! !

!MetaLink methodsFor: 'printing' stamp: ''!
definitionString
	^String streamContents: [ :str |
		str nextPutAll: 'MetaLink new'.
		str cr;tab.
		str nextPutAll: 'metaObject: '; nextPutAll: metaObject printString; nextPut: $;.
		str cr;tab.
		str nextPutAll: 'selector: '; nextPutAll: selector printString; nextPut: $;.
		str cr;tab.
		str nextPutAll: 'arguments: '; nextPutAll: arguments printString; nextPut: $;.
		str cr;tab.
		str nextPutAll: 'control: '; nextPutAll: control printString; nextPut: $;.
		self hasMetaLevel ifTrue: [  
			str cr;tab.
			str nextPutAll: 'level: '; nextPutAll: level printString; nextPut: $;.
			].
		self hasCondition ifTrue: [
			str cr;tab.
			str nextPutAll: 'condition: '; nextPutAll: condition printString; nextPut: $;.
			].
		str cr;tab.
		str nextPutAll: 'options: '; nextPutAll: options asArray printString; nextPut: $..
	]! !

!MetaLink methodsFor: 'accessing' stamp: ''!
metaObject
	^ metaObject! !

!MetaLink methodsFor: 'options' stamp: ''!
optionAnnounce
	^ options includes: #optionAnnounce! !

!MetaLink methodsFor: 'testing' stamp: ''!
hasCondition	
	^condition notNil! !

!MetaLink methodsFor: 'accessing' stamp: ''!
nodes
	^nodes! !

!MetaLink methodsFor: 'options' stamp: ''!
optionInlineCondition
	^ options includes: #optionInlineCondition! !

!MetaLink methodsFor: 'options' stamp: ''!
optionMetalevel: aBoolean
	aBoolean
		ifTrue: [ options add: #optionMetalevel ] 
		ifFalse: [ options remove: #optionMetalevel ifAbsent:[] ]! !

!MetaLink methodsFor: 'installing' stamp: ''!
announceInstall: node
	self optionAnnounce ifTrue: [SystemAnnouncer uniqueInstance announce: (MetalinkChanged linkAdded: self toNode: node)]! !

!MetaLink methodsFor: 'installing' stamp: ''!
removeNode: aNode
	"Silently remove aNode from the nodes list.
	No effect if aNode was not initially present."
	self hasNodes ifFalse:[^self].
	nodes remove: aNode ifAbsent:[]! !

!MetaLink methodsFor: 'reflective api' stamp: ''!
disable
	"turn off link reflectively while keeping the condition"
	self hasReifiedCondition
		ifFalse: [self condition: (RFCondition for: condition)].
	self condition disable.! !

!MetaLink methodsFor: 'link api' stamp: ''!
condition: aCondition arguments: anArray
	self condition: aCondition.
	conditionArguments := anArray.

	
! !

!MetaLink methodsFor: 'link api' stamp: ''!
selector: aSymbol
	selector := aSymbol.
	self invalidate.! !

!MetaLink methodsFor: 'options' stamp: ''!
optionInlineMetaObject: aBoolean
	aBoolean
		ifTrue: [ options add: #optionInlineMetaObject ] 
		ifFalse: [ options remove: #optionInlineMetaObject ifAbsent:[] ]! !

!MetaLink methodsFor: 'link api' stamp: ''!
condition: aCondition
	condition:= aCondition.
	self optionInlineCondition ifTrue: [^self invalidate].
	nodes do: [ :node |  | methodNode |
		methodNode := node methodNode.
		(methodNode metaLinkOptionsFromClassAndMethod includes: #optionInlineCondition)
			 ifTrue: [ methodNode method invalidate ] ].
	

	
! !

!MetaLink methodsFor: 'ast' stamp: ''!
valueInContext: aBlock
	| process |
	"We need to take care that all code called here can not have active metalinks. We use copies of methods if we call system methods"
	process := Processor rfactiveProcess.
	(process isActive: self level)
		ifFalse: [ ^ self ].
	process shiftLevelUp.
	[aBlock value] rfEnsure: [process shiftLevelDown]
	! !

!MetaLink methodsFor: 'options' stamp: ''!
optionCompileOnLinkInstallation: aBoolean
	aBoolean
		ifTrue: [ options add: #optionCompileOnLinkInstallation ] 
		ifFalse: [ options remove: #optionCompileOnLinkInstallation ifAbsent:[] ]! !

!MetaLink methodsFor: 'testing' stamp: ''!
hasMetaLevel
	^level notNil! !

!MetaLink methodsFor: 'options' stamp: ''!
optionInlineCondition: aBoolean
	aBoolean
		ifTrue: [ options add: #optionInlineCondition ] 
		ifFalse: [ options remove: #optionInlineCondition ifAbsent:[] ]! !

!MetaLink methodsFor: 'installing' stamp: ''!
announceChange
	self optionAnnounce ifTrue: [SystemAnnouncer uniqueInstance announce: (MetalinkChanged new link: self)]! !

!MetaLink methodsFor: 'accessing' stamp: ''!
options
	^options! !

!MetaLink class methodsFor: 'cleanup' stamp: ''!
uninstallAll
	<script>
	self linkInstaller uninstallSuperJumpLinks.
	self allInstances do: #uninstall.
	self linkInstaller unsubscribeFromAnnouncers.
	linkInstaller := nil! !

!MetaLink class methodsFor: 'accessing' stamp: ''!
linkInstaller
	^linkInstaller 
		ifNil: [ linkInstaller := MetaLinkInstaller new ]! !

!MetaLink class methodsFor: 'options' stamp: ''!
defaultOptions
	^ #(
	+ optionInlineMetaObject            "meta object is inlined by default."
	+ optionInlineCondition              "condition is inlined by default."
	- optionCompileOnLinkInstallation   "generate compiledMethod on link installation"
	- optionOneShot                     "remove link after first activation"
	- optionMetalevel                   "force level: 0 for the link"
	- optionDisabledLink                "links are active by default"
	+ optionWeakAfter 						  "do not use #ensure: for #after "
	- optionAnnounce                    "do we announce adding / removing links? Slow"
	- argsAsArray                       "pass all arguments in one array. By default off as it adds an array creation"
	- optionStyler							  "should the metalink be visualized in the Tools?"
	)! !

!MetaLinkAnonymousClassBuilder commentStamp: ''!
I build anonymous subclasses for object with instance specific MetaLinks. 

I can compile methods in those subclasses, and provide access to anonymous classes;

I also handle the migration of an object from its original class to an anonymous subclass and vice versa.

I consider that for one anonymous subclass i hold one object reference. I therefore cannot work as is with other clients using anonymous subclasses.!
!MetaLinkAnonymousClassBuilder methodsFor: 'compiling' stamp: ''!
compileClassAccessorForAnonymousClass: anAnonymousClass
	self classAccessorsForAnonymousClasses
		do: [ :sourceCode | anAnonymousClass compile: sourceCode ]! !

!MetaLinkAnonymousClassBuilder methodsFor: 'initialize' stamp: ''!
initialize
	classes := Dictionary new.
	migratedObjects := WeakIdentityKeyDictionary new! !

!MetaLinkAnonymousClassBuilder methodsFor: 'migration' stamp: ''!
migrateObjectToOriginalClass: anObject
	| class |
	class := anObject class.
	class isAnonymous
		ifFalse: [ ^ self ].
	migratedObjects removeKey: class.
	class superclass adoptInstance: anObject! !

!MetaLinkAnonymousClassBuilder methodsFor: 'compiling' stamp: ''!
compileMethodFrom: aNode in: anAnonymousClass
	| selector source |
	selector := aNode methodNode selector.
	(anAnonymousClass methodDict at: selector ifAbsent: [ nil ]) ifNotNil: [ :compiledMethod | ^ compiledMethod ].
	source := aNode methodNode source.
	anAnonymousClass compile: source.	
	^ anAnonymousClass >> selector! !

!MetaLinkAnonymousClassBuilder methodsFor: 'accessing' stamp: ''!
classAccessorsForAnonymousClasses
	^{'class
		thisContext sender methodClass == MetaLinkAnonymousClassBuilder 
			ifTrue:[^self realClass].
		^self originalClass'.
		
	'originalClass
		^super class superclass'.
		
	'realClass
		^super class'				
	}! !

!MetaLinkAnonymousClassBuilder methodsFor: 'accessing' stamp: ''!
compiledMethodsOfSelector: selector inClasses: someClasses
	^ (someClasses select: [ :ac | ac selectors includes: selector ])
		collect: [ :ac | ac compiledMethodAt: selector ]! !

!MetaLinkAnonymousClassBuilder methodsFor: 'creation' stamp: ''!
newAnonymousSubclassFor: aClass
	| anonSubclass |
	anonSubclass := aClass newAnonymousSubclass.
	(classes at: aClass ifAbsentPut: WeakSet new)
		add: anonSubclass.
	self compileClassAccessorForAnonymousClass: anonSubclass.
	^ anonSubclass! !

!MetaLinkAnonymousClassBuilder methodsFor: 'migration' stamp: ''!
migrateObject: anObject toAnonymousClass: anonClass
	anObject class == anonClass
		ifTrue: [ ^ self ].
	anonClass adoptInstance: anObject.
	migratedObjects at: anonClass put: (WeakArray with: anObject)! !

!MetaLinkAnonymousClassBuilder methodsFor: 'creation' stamp: ''!
removeMethodNode: aNode fromObject: anObject
	anObject class isAnonymous ifFalse:[^self].
	anObject class removeSelector: aNode methodNode selector.
! !

!MetaLinkAnonymousClassBuilder methodsFor: 'creation' stamp: ''!
anonymousClassForObject: anObject
	"Building the anonymous subclass for an object.
	If the object already is instance of an anonymous class, its class is returned as is.
	Otherwise an anonymous class is derived from its class.
	There is a single anonymous class by adapted object (1-1 relationship)."

	| class |
	class := anObject class.
	^ class isAnonymous
		ifTrue: [ class ]
		ifFalse: [ self newAnonymousSubclassFor: class ]! !

!MetaLinkAnonymousClassBuilder methodsFor: '*Reflectivity-Tests' stamp: ''!
requestClassOfObject: anObject 
	^anObject class! !

!MetaLinkAnonymousClassBuilder methodsFor: 'accessing' stamp: ''!
anonSubclassesFor: aClass
	^ classes at: aClass ifAbsent: [ ^ Array new ]! !

!MetaLinkAnonymousClassBuilder methodsFor: 'accessing' stamp: ''!
compiledMethodsOfSelector: selector inAnonSubClassesOf: class
	| anonSubClasses |
	anonSubClasses := self anonSubclassesFor: class.
	^ self compiledMethodsOfSelector: selector inClasses: anonSubClasses! !

!MetaLinkAnonymousClassBuilder methodsFor: 'accessing' stamp: ''!
allSubclassesOf: class withSelector: selector
	| subclasses |
	class isAnonymous
		ifTrue: [ ^ OrderedCollection with: class ].
	subclasses := self anonSubclassesFor: class.
	^ (subclasses select: [ :c | c selectors includes: selector ]) asOrderedCollection! !

!MetaLinkAnonymousClassBuilder methodsFor: '*Reflectivity-Tests' stamp: ''!
migratedObjects
	^ migratedObjects! !

!MetaLinkAnonymousClassBuilder methodsFor: 'accessing' stamp: ''!
soleInstanceOf: anAnonymousClass
	| weakArray |
	anAnonymousClass
		ifNil: [ 
			"Because anonymous subclasses are weakly referenced by the builder,
			we assume other tools could do the same and ask for the sole instance
			of a nilled reference (e.g., recovered from a weak array).
			In that case (anAnonymousClass isNil), we want to avoid to look into
			the registry because it also holds weak references to anonymous classes.
			It would then find a nil key associated to a nil object, and produce a
			ValueNotFound error while we'rere expecting to be warn that the anonymous
			class is not there anymore (KeyNotFound)."
			KeyNotFound signalFor: anAnonymousClass in: migratedObjects ].
	weakArray := migratedObjects at: anAnonymousClass.
	(weakArray isEmpty or: [ weakArray first isNil ])
		ifTrue: [ ValueNotFound
				signalFor: anAnonymousClass
				in: (migratedObjects at: anAnonymousClass) ].
	^ weakArray first! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testMigrateObjectToAnonymousClass
	|class subclass realClass originalClass currentClass|
	class := object class.
	subclass := builder newAnonymousSubclassFor: class.
	builder migrateObject: object toAnonymousClass: subclass.
	
	realClass := object realClass.
	self assert: realClass identicalTo: subclass.
	self assert: (builder soleInstanceOf: realClass) identicalTo: object.
	
	originalClass := object originalClass.	
	currentClass := object class.	
	self assert: currentClass identicalTo: class.
	self assert: currentClass identicalTo: originalClass
	! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testAnonymousClassForObject
	
	|originalClass anonClass|
	originalClass := object class.
	anonClass := builder anonymousClassForObject: object.	
	
	self assert: anonClass superclass identicalTo: originalClass.
	self assert: anonClass isAnonymous.
	self assert: (builder anonymousClassForObject: anonClass new) identicalTo: anonClass
	 
! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testMigrateObjectToOriginalClass
	|class subclass|
	class := object class.
	subclass := builder newAnonymousSubclassFor: class.
	builder migrateObject: object toAnonymousClass: subclass.	
	builder migrateObjectToOriginalClass: object.
	
	self should: [ object realClass ] raise: MessageNotUnderstood.
	self should: [ object originalClass ] raise: MessageNotUnderstood.
	self assert: object class identicalTo: class.
	
	! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testNewAnonymousSubclass
	|class|
	class := (builder newAnonymousSubclassFor: ReflectivityExamples).
	self assert: class isAnonymous.
	self assert: class superclass identicalTo: ReflectivityExamples.
	self assert: class new class identicalTo: ReflectivityExamples
! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testRemoveMethodNodeFromObject
	|node anonClass|
	node := (object class >> #exampleAssignment) ast.
	
	builder removeMethodNode: node fromObject: object.	
	self deny: object class isAnonymous.
	self assertCollection: object class selectors includesAll: {#exampleAssignment}.
	
	anonClass := object class newAnonymousSubclass.
	anonClass compile: 'exampleAssignment ^self'.
	anonClass adoptInstance: object.
	
	self assert: object class isAnonymous.
	self assertCollection: object class selectors includesAll: {#exampleAssignment}.
	
	builder removeMethodNode: node fromObject: object.
	self denyCollection: object class selectors includesAll: {#exampleAssignment}! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testEmptyAnonSubclasses
	self assertCollection: (builder anonSubclassesFor: ReflectivityExamples) equals: Array new
! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testWeakMigratedObjectsRegistry	 
	|originalClass anonClass|
	originalClass := object class.
	anonClass := builder anonymousClassForObject: object.	
	builder migrateObject: object toAnonymousClass: anonClass.
	
	self assert: (builder soleInstanceOf: anonClass) identicalTo: object.
	self assertCollection: (builder anonSubclassesFor: originalClass) includesAll: {anonClass}.
	
	object := nil.	
	Smalltalk garbageCollect.
	self should: [builder soleInstanceOf: anonClass] raise: ValueNotFound.
	
	anonClass := nil.
	Smalltalk garbageCollect.	
	self assert: (builder migratedObjects allSatisfy: [:e| e isNil]).
	self should: [builder soleInstanceOf: nil] raise: KeyNotFound! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testCompileMethodFromIn
	|node anonClass compiledMethod|
	node := (ReflectivityExamples >> #exampleAssignment) ast statements first.
	anonClass := ReflectivityExamples newAnonymousSubclass.
	compiledMethod := builder compileMethodFrom: node in: anonClass.
	
	self assert: compiledMethod methodClass identicalTo: anonClass.
	self assert: compiledMethod sourceCode equals: node methodNode sourceCode
	 
! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testAnonSubclassesRegistering
	|subclasses|
	subclasses := WeakSet with: (builder newAnonymousSubclassFor: ReflectivityExamples).
	self assertCollection: (builder anonSubclassesFor: ReflectivityExamples) equals: subclasses
! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testCompiledMethodsOfSelectorinClasses
	| anonClass1 anonClass2 compiledMethods |
	anonClass1 := ReflectivityExamples newAnonymousSubclass.
	anonClass2 := ReflectivityExamples newAnonymousSubclass.
	
	anonClass1 compile: 'exampleAssignment ^self'.
	compiledMethods := builder
		compiledMethodsOfSelector: #exampleAssignment
		inClasses: {anonClass1. anonClass2}.
		
	self assert: compiledMethods size equals: 1.
	self assert: compiledMethods asArray first methodClass identicalTo: anonClass1! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testCompileClassAccessorForAnonymousClass
	| class |
	class := ReflectivityExamples newAnonymousSubclass.
	builder compileClassAccessorForAnonymousClass: class.
	self
		assert: (class methodDict at: #class) sourceCode
		equals: builder classAccessorsForAnonymousClasses first.
	self
		assert: (class methodDict at: #originalClass) sourceCode
		equals: builder classAccessorsForAnonymousClasses second.
	self
		assert: (class methodDict at: #realClass) sourceCode
		equals: builder classAccessorsForAnonymousClasses third.! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testAllSubclassesOfWithSelector
	| anonClass1 anonClass2 compiledMethods |
	anonClass1 := builder newAnonymousSubclassFor: ReflectivityExamples.
	anonClass2 := builder newAnonymousSubclassFor: ReflectivityExamples.
	
	anonClass1 compile: 'exampleAssignment ^self'.
	compiledMethods := builder 
		allSubclassesOf: ReflectivityExamples 
		withSelector: #exampleAssignment.
		
	self assert: compiledMethods size equals: 1.
	self assert: compiledMethods asArray first identicalTo: anonClass1! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testCompiledMethodsOfSelectorInAnonSubClassesOf
	| anonClass compiledMethods |
	anonClass := builder newAnonymousSubclassFor: ReflectivityExamples.
	anonClass compile: 'exampleAssignment ^self'.
	compiledMethods := builder
		compiledMethodsOfSelector: #exampleAssignment
		inAnonSubClassesOf: ReflectivityExamples.
		
	self assert: compiledMethods size equals: 1.
	self assert: compiledMethods asArray first methodClass identicalTo: anonClass ! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'tests' stamp: ''!
testClassAccessFromClassBuilder
	|class subclass realClass|
	class := object class.
	subclass := builder newAnonymousSubclassFor: class.
	builder migrateObject: object toAnonymousClass: subclass.
	
	"Anonymous class is hidden from the system: `object class` returns the original class"
	self assert: object class identicalTo: class.
	
	"The metalink class builder, however, sees the anonymous class when calling `object class`"
	realClass := object realClass.
	self assert: realClass identicalTo: subclass.
	self assert: (builder requestClassOfObject: object) identicalTo: realClass! !

!MetaLinkAnonymousClassBuilderTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
	super setUp.
	builder := MetaLinkAnonymousClassBuilder new.
	object := ReflectivityExamples new! !

!MetaLinkIconStyler commentStamp: ''!
I'm in charge to style an ast when there are metalink in the ast!
!MetaLinkIconStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	^ [ aNode links inspect ]! !

!MetaLinkIconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^(Color orange alpha: 0.1)! !

!MetaLinkIconStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode
	^ 'Metalinks...'! !

!MetaLinkIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode

	^ aNode hasMetaLinks and: [ 
		  aNode links anySatisfy: [ :link | link hasOption: #optionStyler ] ]! !

!MetaLinkIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #smallDebugIcon ! !

!MetaLinkInstaller commentStamp: ''!
#TODO and notes
- Should we replace method operations (copying, removing) by ast manipulation ?
- Peer reviews... ?
- For now, only method nodes can be affected by object specific links.

#document inst vars and their usage
anonSubclassesRegistry <Dictionary: (Class -> WeakSet of: AnonymousClass)> This table contains for a given class all its anonymous subclasses for which there are instance specific links. Each anonymous class has exactly one instance.

nodesForObjects <WeakKeyDictionary (Object -> WeakSet of: RBMethodNode)>

links <WeakKeyDictionary (MetaLink -> WeakSet of: Object)> For each instance specific link, stores all objects it does affect. Used only for counting the number of objects affected by a given link. Maybe could be removed and replaced by a computation.

#document basic usage of the link installer

#Installing
When a link is put on a specific object, an anonymous subclass of the object's class is generated and the object is migrated to this subclass. There is a 1-1 mapping between objects an their anonymous class. That means that if we put two instance specific links on two objects of class A, these objects will migrate to two different anonymous subclasses of A. However, putting a new instance specific link to one of these objects will preserve its anonymous class and will not migrate the object to another subclass.
	
If aNode is in the original class of anObject and if there are class scoped links on this node,  they are installed in the new node of the anonymous subclass. It is necessary to preserve the original instrumentation of a node which are meant to be applied for all instances of the class.

#Uninstalling
We know we can remove a node in an anonymous subclass when there are no more instance specific links on this node. There may be "class scoped" links remaining, but the node can be removed because all these links are present on the superclass node that was copied down in the subclass.

When there are no more nodes specific to a given object, the object is migrated back to its superclass. As there is only one anonymous subclass per object, it is expected that the anonymous subclass is garbaged and the object is now an instance of its original class.

#Linking and unlinking subtleties
As already said, when putting a link on a node for a specific object an anonymous subclass is generated  and the node is copied down from the origin class to its anonymous subclass. When adding or removing a new link to the node in the original class, we ensure that this link is also added/removed from all nodes copies in the corresponding anonymous subclasses.

#Listening for code changes
The link installer listens for method source code changes and  must update its anonymous classes nodes with those changes. Not done yet. See LinkInstaller >> #methodChanged:

Also there is the problem of renaming a method in a class for which an anonymous subclass with a copy of this method has been made.














!
!MetaLinkInstaller methodsFor: 'links' stamp: ''!
propagateLinkAddition: link forNode: aNode
	"When:
		- a node has been copied down in anonymous subclasses
		- a link is added to this node in the original class
		> we must ensure that this link is also added in anonymous subclasses with the same node"
	(self collectAnonymousAstsFor: aNode) do: [ :ast | ast link: link ]! !

!MetaLinkInstaller methodsFor: 'nodes' stamp: ''!
uninstallNode: aNode forObject: anObject
	self removeNode: aNode forObject: anObject.
	(linkToNodesMapper findNodesForObject: anObject) 
		ifEmpty: [ anonSubclassesBuilder migrateObjectToOriginalClass: anObject ]! !

!MetaLinkInstaller methodsFor: 'installation' stamp: ''!
uninstall: aMetaLink fromNode: aNode forObject: anObject
	| node |
	node := linkToNodesMapper findNodeLike: aNode forObject: anObject.
	node ifNil: [ ^ self ].
	node removeLink: aMetaLink.
	self uninstallNode: node forObject: anObject.
	aMetaLink removeNode: node! !

!MetaLinkInstaller methodsFor: 'installation' stamp: ''!
install: aMetaLink onNode: aNode forObject: anObject
	| anonClass ast |
	
	linksRegistry addMetaLink: aMetaLink forObject: anObject.
	anonClass := anonSubclassesBuilder anonymousClassForObject: anObject.
	ast := self astFromNode: aNode forObject: anObject inClass: anonClass.
	ast link: aMetaLink.
	anonSubclassesBuilder migrateObject: anObject toAnonymousClass: anonClass! !

!MetaLinkInstaller methodsFor: 'links' stamp: ''!
linkAllFromNode: aNode into: copyNode
	"If aNode is the original ast node from which a copy was made - namely copyNode,
	and if this node has links, we need to add them to copyNode."
	
	aNode hasMetaLinks
		ifTrue: [	aNode links do: [ :link | copyNode linkIfAbsent: link ] ].
		
	aNode allChildren
		do: [ :c | 
			c hasMetaLinks
				ifTrue: [ | node |
					node := self findSubNode: c in: copyNode.
					c links do: [ :link | node linkIfAbsent: link ] ] ]! !

!MetaLinkInstaller methodsFor: 'permalinks' stamp: ''!
recursiveRemoveMethodNode: methodNode fromPermaLinks: permalink
	"Remove nodes from the link tied to permalink.
	These nodes can be any node in methodNode's children (itself included).
	Doesn't care if the link doesn't know the node, as we have no way of knowing."
	
	permalink link nodes remove: methodNode ifAbsent: [  ].
	methodNode allChildren do: [ :node | permalink link nodes remove: node ifAbsent: [  ] ]! !

!MetaLinkInstaller methodsFor: 'nodes' stamp: ''!
removeAllAnonymousNodesIn: methodNode fromAnonSubclassesOf: aClass
	"Will check for every ast nodes in methodNode (included) if instance specific links do exist.
	If they exist, they are uninstalled."

	| selector anonClassesWithSelector |
	self flag: 'Code a bit complicated: refactoring ?'.
	selector := methodNode selector.
	anonClassesWithSelector := anonSubclassesBuilder allSubclassesOf: aClass withSelector: selector.
	anonClassesWithSelector
		do: [ :c | 
			| object anonMethodNode anonNodes |
			object := anonSubclassesBuilder soleInstanceOf: c.
			anonMethodNode := (c >> selector) ast.

			"Getting all nodes in the method with links,
			they are instance specific because located 
			in the sole instance of a anonymous class"
			anonNodes := anonMethodNode allChildren select: [ :n | n hasMetaLinks ].

			"We remove the existing links"
			anonNodes do: [ :node | node links do: [ :link | self uninstall: link fromNode: node forObject: object ]].

			"We remove links from the anonymous method node if any"
			anonMethodNode hasMetaLinks
				ifTrue: [ anonMethodNode links do: [ :link | self uninstall: link fromNode: anonMethodNode forObject: object ]. anonMethodNode links removeAll ] ].
	
	"Method nodes are implicetely removed from anonymous subclasses,
	and object are silently moved back to their original class
	if no instance-specific links do exist for them"
	! !

!MetaLinkInstaller methodsFor: 'permalinks' stamp: ''!
nodesForPermaLink: permalink toBeInstalledIn: method
	"Looking for nodes from method where to install the permalink.
	That means that each of these nodes has no links, 
	or that the link hosted by permalink is not present in their link set."
	| slotOrVar persistenceType nodes |
	slotOrVar := permalink slotOrVariable.
	persistenceType := permalink persistenceType.
	nodes := (slotOrVar accessingNodesFor: persistenceType) asIdentitySet 
					select: [ :node | node methodNode method = method ].
	^ nodes select: [ :node | node hasMetaLinks not or: [ (node links includes: permalink link) not ] ]! !

!MetaLinkInstaller methodsFor: 'nodes' stamp: ''!
removeNode: aNode forObject: anObject
	(self canRemoveMethodNodeContaining: aNode)
		ifTrue: [ self removeSuperJumpsFor: aNode.
			anonSubclassesBuilder removeMethodNode: aNode fromObject: anObject ].
	linkToNodesMapper removeNode: aNode forObject: anObject! !

!MetaLinkInstaller methodsFor: 'permalinks' stamp: ''!
removePermaLinksNodesReferencesFor: aMethodNode
	"Remove all permalink references of permalinks for aMethodNode (if any).
	It includes all permalink installed on any child of aMethodNode or
	any copy of aMethodNode in anonymous classes (including their children)."

	| class anonClasses selector permalinks |
	class := aMethodNode methodClass.
	selector := aMethodNode selector.
	anonClasses := anonSubclassesBuilder allSubclassesOf: class withSelector: selector.
	permalinks := self findPermaLinksForSelector: selector inClass: class.
	permalinks
		do: [ :permalink | 
			| methodNodes |
			methodNodes := IdentitySet with: aMethodNode.
			permalink isInstanceSpecific
				ifTrue: [ methodNodes addAll: (anonClasses collect: [ :anonClass | (anonClass >> selector) ast ]) ].
			methodNodes do: [ :methodNode | self recursiveRemoveMethodNode: methodNode fromPermaLinks: permalink ] ]! !

!MetaLinkInstaller methodsFor: 'nodes' stamp: ''!
canRemoveMethodNodeContaining: aNode
	| methodNode allNodes |
	methodNode := aNode methodNode.
	allNodes := methodNode allChildren select: [ :c | c hasMetaLinks ].
	methodNode hasMetaLinks
		ifTrue: [ allNodes add: methodNode ].
	^ allNodes allSatisfy: [ :node | (linksRegistry isNodeWithInstanceSpecificLinks: node) not ]! !

!MetaLinkInstaller methodsFor: 'updating' stamp: ''!
methodAdded: aMethodAdded
	self reinstallPermaLinksForMethod: aMethodAdded methodAdded! !

!MetaLinkInstaller methodsFor: 'nodes' stamp: ''!
astFromNode: aNode forObject: anObject inClass: anonClass
	"Getting the ast node in the anonymous class.
	If it does not exists, it is copied in the anon class from the original node."

	^ (linkToNodesMapper findNodeLike: aNode forObject: anObject)
		ifNil: [ | copyNode |
			copyNode := self copyNode: aNode inClass: anonClass.
			linkToNodesMapper addNode: copyNode forObject: anObject ]! !

!MetaLinkInstaller methodsFor: 'permalinks' stamp: ''!
reinstallPermaLink: permalink onNode: node
	| link instances |
	link := permalink link.
	permalink isInstanceSpecific
		ifFalse: [ node link: link.
			^ self ].
	instances := (linksRegistry objectsForLink: link)
		select: [ :i | i originalClass = permalink slotOrVarClass ].
	instances do: [ :instance | node link: link forObject: instance ]! !

!MetaLinkInstaller methodsFor: 'accessing - private tests' stamp: ''!
linksRegistry
	^ linksRegistry ! !

!MetaLinkInstaller methodsFor: 'permalinks' stamp: ''!
findPermaLinksForSelector: selector inClass: class
	"Permalinks in class for selector are all permalinks installed on:
	- class
	- any anonymous subclass of class implementing selector"

	| classes |
	classes := OrderedCollection with: class.
	classes addAll: (anonSubclassesBuilder allSubclassesOf: class withSelector: selector).
	^ linksRegistry permaLinksForClasses: classes! !

!MetaLinkInstaller methodsFor: 'nodes' stamp: ''!
copyNode: aNode inClass: anAnonymousClass
	| methodNode node |
	methodNode := aNode methodNode.
	node := self compileMethodNodeFor: aNode in: anAnonymousClass.
	self linkAllFromNode: methodNode into: node.
	self installSuperJumpLinksInMethodNode: node.
	aNode = methodNode
		ifTrue: [ ^ node ].
	^ node allChildren detect: [ :n | n isEquivalentTo: aNode ]! !

!MetaLinkInstaller methodsFor: 'installation' stamp: ''!
uninstallFromAllAnonymousNodes: aMetaLink
	| objectsForLink |
	(linksRegistry isLinkObjectSpecific: aMetaLink) ifFalse:[^self].
	objectsForLink := linksRegistry objectsForLink: aMetaLink.
	objectsForLink
		do: [ :object | 
			aMetaLink nodes
				do: [ :node | 
					(linkToNodesMapper isNode: node ownedBy: object)
						ifTrue: [ self uninstall: aMetaLink fromNode: node forObject: object ] ] ]! !

!MetaLinkInstaller methodsFor: 'nodes' stamp: ''!
compileMethodNodeFor: aNode in: anAnonymousClass
	^ (anonSubclassesBuilder compileMethodFrom: aNode in: anAnonymousClass) ast! !

!MetaLinkInstaller methodsFor: 'initialization' stamp: ''!
initialize
	anonSubclassesBuilder := MetaLinkAnonymousClassBuilder new.
	linksRegistry := MetaLinkRegistry new.
	linkToNodesMapper := MetaLinkNodesMapper new.
	superJumpLinks := OrderedCollection new.
	
	SystemAnnouncer uniqueInstance weak when: MethodModified send: #methodChanged: to: self.
	SystemAnnouncer uniqueInstance weak when: MethodRemoved send: #methodRemoved: to: self.
	SystemAnnouncer uniqueInstance weak when: MethodAdded send: #methodAdded: to: self! !

!MetaLinkInstaller methodsFor: 'lookup' stamp: ''!
installSuperJumpLinksInMethodNode: node
	"Installs a metalink wich provokes a super jump: 
	when sending a message to super in an anonymous class, 
	instead of starting the lookup in the super class (wich is the original class of the object),
	the lookup is started in the super super class (which is the intented superclass)."

	(node allChildren select: [ :n | n isSuperVariable ])
		do: [ :superNode | 
			| messageSendNode superSuperClass link |
			messageSendNode := superNode parent.
			superSuperClass := node methodClass superclass superclass.
			link := MetaLink new.
			link control: #instead.
			link arguments: #(arguments receiver).
			link selector: #value:value:.
			link metaObject: [ :args :receiver | receiver perform: messageSendNode selector withArguments: args inSuperclass: superSuperClass ].
			superJumpLinks add: link.
			messageSendNode link: link ]! !

!MetaLinkInstaller methodsFor: 'accessing - private tests' stamp: ''!
linkToNodesMapper
	^ linkToNodesMapper! !

!MetaLinkInstaller methodsFor: 'nodes' stamp: ''!
collectAnonymousAstsFor: aNode
	"Collects all ast nodes that are copies of aNode in anonymous subclasses
	of aNode class."

	| methodNode selector methodClass methods |
	methodNode := aNode methodNode.
	selector := methodNode selector.
	methodClass := methodNode methodClass.
	methods := anonSubclassesBuilder compiledMethodsOfSelector: selector inAnonSubClassesOf: methodClass.
	^ methods
		collect: [ :method | 
			| anonMethodNode |
			anonMethodNode := method ast.
			aNode isMethod
				ifTrue: [ anonMethodNode ]
				ifFalse: [ self findSubNode: aNode in: anonMethodNode ] ]! !

!MetaLinkInstaller methodsFor: 'lookup' stamp: ''!
uninstallSuperJumpLinks
	superJumpLinks do: [ :link | link uninstall ]! !

!MetaLinkInstaller methodsFor: 'permalinks' stamp: ''!
installPermaLink: aPermaLink onVariable: aVariable
	aPermaLink slotOrVariable: aVariable.
	self registerAndInstallPermaLink: aPermaLink forTarget: aVariable! !

!MetaLinkInstaller methodsFor: 'links' stamp: ''!
propagateLinkRemoval: link forNode: aNode
	"When:
		- a link has been copied down in anonymous subclasses
		- this link has to be removed in the original class
		> we must ensure that this link is also removed in anonymous subclasses with the same node"

	(self collectAnonymousAstsFor: aNode) do: [ :ast | ast removeLink: link ]! !

!MetaLinkInstaller methodsFor: 'updating' stamp: ''!
methodRemoved: aMethodRemoved
	| methodNode methodClass |
	methodNode := aMethodRemoved methodRemoved compiledMethod ast.
	self removePermaLinksNodesReferencesFor: methodNode.
	methodClass := aMethodRemoved methodOrigin.
	methodClass isAnonymous
		ifTrue: [ ^ self ].
	self
		removeAllAnonymousNodesIn: methodNode
		fromAnonSubclassesOf: methodClass! !

!MetaLinkInstaller methodsFor: 'nodes' stamp: ''!
findSubNode: node in: methodNode
	^ methodNode allChildren detect: [ :child | child isEquivalentTo: node ] ifNone: [ nil ]! !

!MetaLinkInstaller methodsFor: 'permalinks' stamp: ''!
registerAndInstallPermaLink: aPermaLink forTarget: aSlotOrVar
	| nodes |
	(linksRegistry canReinstallPermaLink: aPermaLink)
		ifFalse: [ ^ self ].
		
	linksRegistry registerPermaLink: aPermaLink.
	
	nodes := (aSlotOrVar accessingNodesFor: aPermaLink persistenceType) asIdentitySet.
	aPermaLink targetObjectOrClass link: aPermaLink link toNodes: nodes! !

!MetaLinkInstaller methodsFor: 'updating' stamp: ''!
methodChanged: aMethodChanged
	| methodNode methodClass |
	methodNode := aMethodChanged oldMethod compiledMethod ast.
	methodClass := aMethodChanged oldMethod methodClass.
	self removePermaLinksNodesReferencesFor: methodNode.
	methodClass isAnonymous
		ifTrue: [ ^ self ].	
	self removeAllAnonymousNodesIn: methodNode fromAnonSubclassesOf: methodClass.
	self reinstallPermaLinksForMethod: aMethodChanged newMethod! !

!MetaLinkInstaller methodsFor: 'permalinks' stamp: ''!
uninstallPermaLinkFor: link
	linksRegistry unregisterPermaLinksFor: link! !

!MetaLinkInstaller methodsFor: 'permalinks' stamp: ''!
reinstallPermaLinksForMethod: method
	| permalinks |
	permalinks := linksRegistry permaLinksForMethod: method.
	permalinks
		do: [ :permalink | 
			| nodes |
			nodes := self nodesForPermaLink: permalink toBeInstalledIn: method.
			nodes do: [ :node | self reinstallPermaLink: permalink onNode: node ] ]! !

!MetaLinkInstaller methodsFor: 'lookup' stamp: ''!
removeSuperJumpsFor: methodNode
	| nodesWithLinks |
	nodesWithLinks := methodNode allChildren select: [ :c | c hasMetaLinks ].
	superJumpLinks
		do: [ :link | 
			(nodesWithLinks anySatisfy: [ :node | node links includes: link ])
				ifTrue: [ link uninstall ] ]! !

!MetaLinkInstaller methodsFor: 'initialization' stamp: ''!
unsubscribeFromAnnouncers
	SystemAnnouncer uniqueInstance unsubscribe: self! !

!MetaLinkNodesMapper commentStamp: ''!
I map how instance specific links are put on nodes, in different ways.

I provide an interface to easily and fastly find a links for a given node or nodes for a given link.!
!MetaLinkNodesMapper methodsFor: 'mapping' stamp: ''!
findNodesForObject: anObject
	^ nodesForObjects at: anObject ifAbsent: [ #() ]! !

!MetaLinkNodesMapper methodsFor: 'mapping' stamp: ''!
findNodeLike: aNode forObject: anObject
	| nodesForObject |
	nodesForObject := nodesForObjects at: anObject ifAbsent: [ #() ].
	^ nodesForObject detect: [ :node | node isEquivalentTo: aNode ] ifNone: [ nil ]! !

!MetaLinkNodesMapper methodsFor: 'initialize' stamp: ''!
initialize
	objectsForNodes := WeakIdentityKeyDictionary new.
	nodesForObjects := WeakIdentityKeyDictionary new! !

!MetaLinkNodesMapper methodsFor: 'mapping' stamp: ''!
isNode: aNode ownedBy: anObject
	^(nodesForObjects at: anObject ifAbsent:[^false]) includes: aNode! !

!MetaLinkNodesMapper methodsFor: 'mapping' stamp: ''!
removeNode: aNode forObject: anObject
	"I am just a helper object, if someone asks me to remove a node or an object
	that i don't know, i don't raise any errors"
	(nodesForObjects at: anObject) remove: aNode ifAbsent:[].
	(objectsForNodes at: aNode) remove: anObject ifAbsent:[]! !

!MetaLinkNodesMapper methodsFor: 'mapping' stamp: ''!
addNode: aNode forObject: anObject
	(nodesForObjects at: anObject ifAbsentPut: [ IdentitySet new ]) add: aNode.
	(objectsForNodes at: aNode ifAbsentPut: [ WeakSet new ]) add: anObject.
	^ aNode! !

!MetaLinkObjectAPITest methodsFor: 'common api' stamp: ''!
testLinkToClassVarNameReads
	| link instance |
	link := self link.

	"For all instances"
	instance := ReflectivityExamples2 new.
	ReflectivityExamples2 link: link toClassVariableNamed: #classVar option: #read.
	self assert: tag isEmpty.

	instance methodWithClassVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ]).

	"For instance only"
	link uninstall.
	tag := OrderedCollection new.
	instance link: link toClassVariableNamed: #classVar option: #read.

	instance methodWithClassVarAccess.
	ReflectivityExamples2 new methodWithClassVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'common api' stamp: ''!
testLinkToTempVarNameReads
	| link instance |
	link := self link.
	instance := ReflectivityExamples2 new.

	"For all instances"
	ReflectivityExamples2
		link: link
		toTemporaryNamed: #temp
		inMethod: #methodWithTempVarAccess
		option: #read.
	self assert: tag isEmpty.

	instance methodWithTempVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ]).

	"For instance only"
	link uninstall.
	tag := OrderedCollection new.
	instance
		link: link
		toTemporaryNamed: #temp
		inMethod: #methodWithTempVarAccess
		option: #read.

	instance methodWithTempVarAccess.
	ReflectivityExamples2 new methodWithTempVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'object - api' stamp: ''!
testLinkObjectToAST
	| link instance instance2 |
	link := self link.

	instance := ReflectivityExamples2 new.
	instance2 := ReflectivityExamples2 new.

	instance link: link toAST: (ReflectivityExamples2 >> #exampleMethod) ast.
	self assert: tag isEmpty.

	instance exampleMethod.
	instance2 exampleMethod.
	self assert: tag size equals: 1.
	self assert: tag first identicalTo: instance! !

!MetaLinkObjectAPITest methodsFor: 'running' stamp: ''!
tearDown
	MetaLink uninstallAll.
	super tearDown.! !

!MetaLinkObjectAPITest methodsFor: 'class api' stamp: ''!
testLinkClassToTempVarNamed
	| link instance |
	link := self linkForTemp.

	ReflectivityExamples2 link: link toTemporaryNamed: #temp inMethod: #methodWithTempVarAccess.
	self assert: tag isEmpty.

	instance := ReflectivityExamples2 new.
	instance methodWithTempVarAccess.

	self assert: tag size equals: 4.
	self assert: (tag allSatisfy: [ :t | t = 'ok' ])! !

!MetaLinkObjectAPITest methodsFor: 'initialization' stamp: ''!
link
	^ MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(object);
		control: #after! !

!MetaLinkObjectAPITest methodsFor: 'initialization' stamp: ''!
linkForTemp
	| okNode |
	okNode := RBLiteralValueNode value: 'ok'.
	^ MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: (Array with: okNode);
		control: #after! !

!MetaLinkObjectAPITest methodsFor: 'object - api' stamp: ''!
testLinkObjectToSlotNamed
	| link instance |
	link := self link.

	instance := ReflectivityExamples2 new.

	instance link: link toSlotNamed: #instVar.
	self assert: tag isEmpty.

	instance methodWithInstVarAccess.
	ReflectivityExamples2 new methodWithInstVarAccess.

	self assert: tag size equals: 4.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'class api' stamp: ''!
testLinkClassToSlotNamedUninstall
	| link instance |
	link := self link.

	ReflectivityExamples2 link: link toSlotNamed: #instVar.
	self assert: tag isEmpty.
	instance := ReflectivityExamples2 new.
	instance methodWithInstVarAccess.
	self assert: tag size equals: 2.
	
	link uninstall.
	instance methodWithInstVarAccess.
	self assert: tag size equals: 2! !

!MetaLinkObjectAPITest methodsFor: 'common api' stamp: ''!
testLinkToSlotNamedWrites
	| link instance |
	link := self link.
	instance := ReflectivityExamples2 new.

	"For all instances"
	ReflectivityExamples2 link: link toSlotNamed: #instVar option: #write.
	self assert: tag isEmpty.

	instance methodWithInstVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ]).

	"For instance only"
	link uninstall.
	tag := OrderedCollection new.
	instance link: link toSlotNamed: #instVar option: #write.

	instance methodWithInstVarAccess.
	ReflectivityExamples2 new methodWithInstVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'common api' stamp: ''!
testLinkToTempVarNameWrites
	| link instance |
	link := self link.
	instance := ReflectivityExamples2 new.

	"For all instances"
	ReflectivityExamples2
		link: link
		toTemporaryNamed: #temp
		inMethod: #methodWithTempVarAccess
		option: #write.
	self assert: tag isEmpty.

	instance methodWithTempVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ]).

	"For instance only"
	link uninstall.
	tag := OrderedCollection new.
	instance
		link: link
		toTemporaryNamed: #temp
		inMethod: #methodWithTempVarAccess
		option: #write.

	instance methodWithTempVarAccess.
	ReflectivityExamples2 new methodWithTempVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'class api' stamp: ''!
testLinkClassToAST
	| link instance |
	link := self link.

	ReflectivityExamples2 link: link toAST: (ReflectivityExamples2 >> #exampleMethod) ast.
	self assert: tag isEmpty.
	instance := ReflectivityExamples2 new.
	instance exampleMethod.
	self assert: tag size equals: 1.
	self assert: tag first identicalTo: instance! !

!MetaLinkObjectAPITest methodsFor: 'class api' stamp: ''!
testLinkClassToClassVarNamed
	| link instance |
	link := self link.

	ReflectivityExamples2 link: link toClassVariableNamed: #classVar.
	self assert: tag isEmpty.

	instance := ReflectivityExamples2 new.
	instance methodWithClassVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'common api' stamp: ''!
testLinkToClassVarNameWrites
	| link instance |
	link := self link.

	"For all instances"
	instance := ReflectivityExamples2 new.
	ReflectivityExamples2 link: link toClassVariableNamed: #classVar option: #write.
	self assert: tag isEmpty.

	instance methodWithClassVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ]).

	"For instance only"
	link uninstall.
	tag := OrderedCollection new.
	instance link: link toClassVariableNamed: #classVar option: #write.

	instance methodWithClassVarAccess.
	ReflectivityExamples2 new methodWithClassVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'common api' stamp: ''!
testLinkToClassVarNameAll
	| link instance |
	link := self link.

	"For all instances"
	instance := ReflectivityExamples2 new.
	ReflectivityExamples2 link: link toClassVariableNamed: #classVar option: #all.
	self assert: tag isEmpty.

	instance methodWithClassVarAccess.

	self assert: tag size equals: 4.
	self assert: (tag allSatisfy: [ :t | t == instance ]).

	"For instance only"
	link uninstall.
	tag := OrderedCollection new.
	instance link: link toClassVariableNamed: #classVar option: #all.

	instance methodWithClassVarAccess.
	ReflectivityExamples2 new methodWithClassVarAccess.

	self assert: tag size equals: 4.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'class api' stamp: ''!
testLinkClassToSlotNamed
	| link instance |
	link := self link.

	ReflectivityExamples2 link: link toSlotNamed: #instVar.
	self assert: tag isEmpty.

	instance := ReflectivityExamples2 new.
	instance methodWithInstVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'object - api' stamp: ''!
testLinkObjectToTempVarName
	| link instance |
	link := self link.

	instance := ReflectivityExamples2 new.

	instance link: link toTemporaryNamed: #temp inMethod: #methodWithTempVarAccess.
	self assert: tag isEmpty.

	instance methodWithTempVarAccess.
	ReflectivityExamples2 new methodWithTempVarAccess.

	self assert: tag size equals: 4.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'tagging' stamp: ''!
tagExec: aTag
	tag add: aTag! !

!MetaLinkObjectAPITest methodsFor: 'common api' stamp: ''!
testLinkToTempVarNameAll
	| link instance |
	link := self link.
	instance := ReflectivityExamples2 new.

	"For all instances"
	ReflectivityExamples2
		link: link
		toTemporaryNamed: #temp
		inMethod: #methodWithTempVarAccess
		option: #all.
	self assert: tag isEmpty.

	instance methodWithTempVarAccess.

	self assert: tag size equals: 4.
	self assert: (tag allSatisfy: [ :t | t == instance ]).

	"For instance only"
	link uninstall.
	tag := OrderedCollection new.
	instance
		link: link
		toTemporaryNamed: #temp
		inMethod: #methodWithTempVarAccess
		option: #all.

	instance methodWithTempVarAccess.
	ReflectivityExamples2 new methodWithTempVarAccess.

	self assert: tag size equals: 4.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'common api' stamp: ''!
testLinkToSlotNamedAll
	| link instance |
	link := self link.
	instance := ReflectivityExamples2 new.

	"For all instances"
	ReflectivityExamples2 link: link toSlotNamed: #instVar option: #all.
	self assert: tag isEmpty.

	instance methodWithInstVarAccess.

	self assert: tag size equals: 4.
	self assert: (tag allSatisfy: [ :t | t == instance ]).

	"For instance only"
	link uninstall.
	tag := OrderedCollection new.
	instance link: link toSlotNamed: #instVar option: #all.

	instance methodWithInstVarAccess.
	ReflectivityExamples2 new methodWithInstVarAccess.

	self assert: tag size equals: 4.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'common api' stamp: ''!
testLinkToSlotNamedReads
	| link instance |
	link := self link.
	instance := ReflectivityExamples2 new.

	"For all instances"
	ReflectivityExamples2 link: link toSlotNamed: #instVar option: #read.
	self assert: tag isEmpty.

	instance methodWithInstVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ]).

	"For instance only"
	link uninstall.
	tag := OrderedCollection new.
	instance link: link toSlotNamed: #instVar option: #read.

	instance methodWithInstVarAccess.
	ReflectivityExamples2 new methodWithInstVarAccess.

	self assert: tag size equals: 2.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'object - api' stamp: ''!
testLinkObjectToClassVarName
	| link instance |
	link := self link.

	instance := ReflectivityExamples2 new.

	instance link: link toClassVariableNamed: #classVar.
	self assert: tag isEmpty.

	instance methodWithClassVarAccess.
	ReflectivityExamples2 new methodWithClassVarAccess.

	self assert: tag size equals: 4.
	self assert: (tag allSatisfy: [ :t | t == instance ])! !

!MetaLinkObjectAPITest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	tag := OrderedCollection new.
	MetaLink uninstallAll ! !

!MetaLinkRegistry commentStamp: ''!
I register specific kind of links that are instance specific and/or "permanent".

I do not install links, i only know informations necessary to find helpful information for link installation (target instances, link count, nodes...).

### Instance specific links

These links are installed for a given object. 

links <WeakKeyDictionary> I reference target objects (values) for which a link has been installed on (key)

Note that instance specific links can be put on other nodes for other objects and/or classes. An instance specific link can also be a regular link active for all instances of an other classes, or even be put on an other node in the class of the object.

### PermaLinks

These links are installed on slots, temporary variables or class variables. I hold explicit specifications of all the kind of nodes the link should permanently be installed on.

Specifications can be of kind for a given var: 
- #read install on all read nodes of var
- #write install on all assignment nodes of var 
- #all both read and write nodes of var

Usecases:

- A link is put on all reads of slot s of class C. If a new method reading s is added in C, i must hold necessary informations to find the new read nodes of s in the new method. I neither find the nodes nor install links on them myself.

- A link is put on all assignments of slot s of class C. If a method with an assignement of s is modified in C, in must hold necessary informations to check if there is still any assignements nodes of s in this method, and update the link accordingly (i.e. reinstall it on these new nodes if they do exist)

In both these usecases, i provide fast and convenient access to the needed informations.!
!MetaLinkRegistry methodsFor: 'permalinks' stamp: ''!
removePermalinkSlotOrVarFromClassRegistry: permaLink

	(self slotSourcesAt: permaLink slotOrVarClass) do: [ :set | 
		set remove: permaLink slotOrVariable ifAbsent: [  ] ]! !

!MetaLinkRegistry methodsFor: 'permalinks' stamp: ''!
hasPermaLinks: aLink
	^ permalinks keys includes: aLink! !

!MetaLinkRegistry methodsFor: 'adding' stamp: ''!
addMetaLink: aLink forObject: anObject
	(links at: aLink ifAbsentPut: WeakSet new) add: anObject! !

!MetaLinkRegistry methodsFor: 'permalinks' stamp: ''!
canReinstallPermaLink: permalink
	^ (self hasPermaLinks: permalink link) not
		or: [ | slotsOrVarsWithPermalink |
			slotsOrVarsWithPermalink := self slotSourcesAt: permalink slotOrVarClass.
			slotsOrVarsWithPermalink flattened noneSatisfy: [ :slotOrVar | permalink slotOrVariable == slotOrVar ] ]! !

!MetaLinkRegistry methodsFor: 'initialize' stamp: ''!
initialize
	links := WeakKeyDictionary new.
	permalinks := WeakKeyDictionary new.
	slotSources := WeakKeyDictionary new.
	permanentTargets := WeakKeyDictionary new! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
isLinkObjectSpecific: aLink
	^ links keys includes: aLink! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
isNodeWithInstanceSpecificLinks: node
	^ (self countObjectSpecificLinksIn: node links) > 0! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
registeredTargetsAt: slotOrVariable ifAbsentPut: aBlock
	^ permanentTargets at: slotOrVariable ifAbsentPut: aBlock! !

!MetaLinkRegistry methodsFor: 'permalinks' stamp: ''!
permaLinksFor: aLink
	^ permalinks at: aLink ifAbsent: [ #() ]! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
slotSourcesAt: aClass ifAbsent: aBlock

	| registeredClasses |
	registeredClasses := slotSources keys select: [ :c | 
		                     c isInClassHierarchyOf: aClass ].
	registeredClasses isEmpty ifTrue: [ ^ aBlock value ].
	^ registeredClasses collect: [ :c | slotSources at: c ]! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
unregisterTarget: slotOrVariable
	permanentTargets removeKey: slotOrVariable ifAbsent: [  ]! !

!MetaLinkRegistry methodsFor: 'permalinks' stamp: ''!
permaLinksForClasses: targetClasses
	| allPermalinks |
	allPermalinks := permalinks values flattened.
	^ allPermalinks select: [ :p | (targetClasses select: [ :c | p notNil and: [ c == p slotOrVarClass ] ]) notEmpty ]! !

!MetaLinkRegistry methodsFor: 'permalinks' stamp: ''!
removePermaLinkFromPermanentTarget: permaLink
	| targetForPermaLink |
	targetForPermaLink := self
		registeredTargetsAt: permaLink slotOrVariable.
	targetForPermaLink remove: permaLink ifAbsent: [  ].
	targetForPermaLink isEmpty
		ifTrue: [ self unregisterTarget: permaLink slotOrVariable ]! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
unregisterPermaLinksFor: aLink
	| permaLinks |
	permaLinks := (self permaLinksFor: aLink) ifEmpty: [ ^ self ].
	permaLinks
		do: [ :permaLink | 
			self removePermaLinkFromPermanentTarget: permaLink.
			self removePermalinkSlotOrVarFromClassRegistry: permaLink ].
	permalinks removeKey: aLink! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
registeredTargetsAt: slotOrVariable
	^ permanentTargets at: slotOrVariable ifAbsent: [ WeakSet new ]! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
slotSourcesAt: aClass
	^ self slotSourcesAt:  aClass ifAbsent: [Array with: Set new ]! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
countObjectSpecificLinksIn: someLinks
	someLinks ifNil:[^0].
	^ (someLinks select: [ :link | self isLinkObjectSpecific: link ]) size! !

!MetaLinkRegistry methodsFor: 'permalinks' stamp: ''!
registerPermaLink: aPermaLink
	| registeredTargets registeredLinks registeredSlots |
	registeredTargets := self registeredTargetsAt: aPermaLink slotOrVariable ifAbsentPut: [ Set new ].
	registeredTargets add: aPermaLink.
	
	registeredLinks := permalinks at: aPermaLink link ifAbsentPut: [ Set new ].
	registeredLinks add: aPermaLink.
	
	registeredSlots := self slotSourcesAt: aPermaLink slotOrVarClass ifAbsentPut: [ Set new ].
	registeredSlots add: aPermaLink slotOrVariable! !

!MetaLinkRegistry methodsFor: 'permalinks' stamp: ''!
permaLinksForMethod: method

	| class targets |
	class := method methodClass.
	targets := (self slotSourcesAt: class) flattened.
	^ (permanentTargets associationsSelect: [ :assoc | 
		   targets includes: assoc key ]) values flattened select: [ 
		  :permalink | permalink slotOrVarClass isInClassHierarchyOf: class ]! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
slotSourcesAt: aClass ifAbsentPut: aBlock
	^ slotSources at: aClass ifAbsentPut: aBlock! !

!MetaLinkRegistry methodsFor: 'registry access' stamp: ''!
objectsForLink: aMetaLink
	^ links at: aMetaLink ifAbsent: [ WeakSet new ]! !

!MetaLinkRegistryTest methodsFor: 'tests' stamp: ''!
testSlotSourcesConsiderClassesHierarchy

	| slotSources |
	slotSources := (registry
		                slotSourcesAt: ReflectivityExamples2Subclass
		                ifAbsent: [ nil ]) flattened.
	self assert: slotSources size equals: 1.
	self
		assert: slotSources asArray first
		identicalTo: permalink slotOrVariable ! !

!MetaLinkRegistryTest methodsFor: 'tests' stamp: ''!
testPermaLinksForMethod
	|plinks|
	plinks := registry permaLinksForMethod: ReflectivityExamples2Subclass>>#useInstVarInSubclass.
	self assert: plinks size equals: 1.
	self assert: plinks first identicalTo: permalink ! !

!MetaLinkRegistryTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.

	registry := MetaLinkRegistry new.
	permalink := PermaLink new.
	permalink slotOrVarClass: ReflectivityExamples2.
	permalink slotOrVariable: (ReflectivityExamples2 lookupVar: #instVar2).
	registry registerPermaLink: permalink.
	registry slotSourcesAt: ReflectivityExamples2 ifAbsentPut: [ 
		Set new
			add: permalink slotOrVariable;
			yourself ]! !

!MetaLinkTest commentStamp: ''!
Tests for MetaLink!
!MetaLinkTest methodsFor: 'tests - options' stamp: ''!
testLinkOption
	| link |
	link := MetaLink new 
		options: #(+option1 -option2).
	
	self assert: link option1.
	self deny: link option2.! !

!MetaLinkTest methodsFor: 'tests - options' stamp: ''!
testOptionFor

	self assert: (((ReflectivityExamples>>#exampleMethodWithMetaLinkOptions) ast optionsFor: MetaLink new) includes: #optionCompileOnLinkInstallation).
	self assert: (((ReflectivityExamples class>>#exampleMethodWithMetaLinkOptionsViaClass) ast optionsFor: MetaLink new) includes: #optionCompileOnLinkInstallation).! !

!MetaLinkTest methodsFor: 'tests - simple' stamp: ''!
testReificationError
	| link |
	link := MetaLink new 
		metaObject: #unknown.
	self should: [ (ReflectivityExamples>>#exampleMethod) ast link: link ] raise: Error.
	self should: [ (ReflectivityExamples classVariableNamed: #ClassVar) link: link ] raise: Error.! !

!MetaLinkTest methodsFor: 'tests - simple' stamp: ''!
testControlLink
	| link |
	link := MetaLink new
		metaObject: [ 1 + 2 ];
		control: #after.
	self assert: link metaObject value equals: 3.
	self assert: link selector equals: #value.
	self assert: link control equals: #after! !

!MetaLinkTest methodsFor: 'tests - simple' stamp: ''!
testBlockLink
	| link |
	link := MetaLink new metaObject: [ 1 + 2 ].
	self assert: link metaObject value equals: 3.
	self assert: link selector equals: #value! !

!MetaLinkTest methodsFor: 'tests - misc' stamp: ''!
testAvailableReifications
	self assert: (RBMessageNode new availableReifications includes: #receiver).
	self assert: (RBMessageNode new availableReifications includes: #value).
	self assert: ((ReflectivityExamples classVariableNamed: #ClassVar) availableReifications includes: #name).
	self deny: ((ReflectivityExamples classVariableNamed: #ClassVar) availableReifications includes: #selector).! !

!MetaLinkTest methodsFor: 'tests - simple' stamp: ''!
testControlInstead
	| link |
	link := MetaLink new
		metaObject: [ 1 + 2 ];
		control: #instead.
	self assert: link metaObject value equals: 3.
	self assert: link selector equals: #value.
	self assert: link control equals: #instead.
	self deny: (ReflectivityExamples >> #exampleMethod) ast hasMetalinkInstead! !

!MetaLinkTest methodsFor: 'tests - misc' stamp: ''!
testDefintionString
	| metaLink |
	metaLink := MetaLink new
		metaObject: nil;
		arguments: #();
		condition: [ true ].
	self assert: (Smalltalk compiler evaluate: metaLink definitionString) definitionString equals: metaLink definitionString! !

!MetaLinkTest methodsFor: 'tests - options' stamp: ''!
testLinkOptionsDefault
	| link |
	link := MetaLink new.

	self assert: link optionInlineMetaObject.
	self deny: link optionCompileOnLinkInstallation.! !

!MetaLinkTest methodsFor: 'tests - simple' stamp: ''!
testSimpleHaltLink
	| link |
	link := MetaLink new
		metaObject: Halt;
		selector: #now.
	self assert: link metaObject equals: Halt.
	self assert: link selector equals: #now! !

!MetaLinkTest methodsFor: 'tests - simple' stamp: ''!
testConditionLink
	| link |
	link := MetaLink new
		metaObject: [ 1 + 2 ];
		condition: true.
	self assert: link metaObject value equals: 3.
	self assert: link selector equals: #value.
	self assert: link condition.
	self assert: link hasCondition! !

!Metacello commentStamp: ''!
# Metacello User Guide

In this guide we'll take a walk through a couple of common development
scenarios and highlight some of the features of the *Metacello Scripting
API*.

*For installatation and more detailed documentation on the Metacello
Scripting API, see the [Metcello Scripting API Documentation][1].*

## Introduction

The number one job of the *Metacello Scripting API* is to simplify the
job of loading projects into your image. As you are probably all
too aware, today it's a two step process where you first load the
configuration into your image using [Gofer][2] and then load your
project using Metacello:

```Smalltalk
Gofer new
  package: 'ConfigurationOfSeaside30';
  squeaksource: 'MetacelloRepository';
  load.
((Smalltalk at: #ConfigurationOfSeaside30) version: #stable) load.
```

In the early days of Metacello (and Gofer) this was a great improvement
over the alternatives, but today, years after the introduction of
Metacello, there should be a better way...and there is.
Using the *Metacello Scripting API* the above expression reduces to the
following:

```Smalltalk
Metacello new
	repository: 'github://SeasideSt/Seaside:v3.4.6/repository';
	baseline: 'Seaside';
	load.
```

## Loading

In this example of the [`load` command][5] we are leveraging a couple of
default values, namely the `version` of the project and the `repository` where the
**BaselineOfSeaside** package can be found:

```Smalltalk
Metacello new
	repository: 'github://SeasideSt/Seaside:v3.4.6/repository';
	baseline: 'Seaside';
	load.
```

You can also specify the full [repository description][3] as follows:

```Smalltalk
Metacello new
	baseline: 'Seaside';
	repository: 'github://SeasideSt/Seaside:v3.4.6/repository';
  	load.
```

##Listing

Once you've loaded one or more projects into your image, you may want to
list them. The following is an example of the [`list` command][6]:

```Smalltalk
Metacello image
	baseline: [ :spec | true ];
	list.
```

The `image` message tells Metacello that you'd like to look
at only loaded baselines. 

The *block* argument to the
`baseline:` message is used to *select* against the list of loaded
[MetacelloProjectSpec][7] instances in the [registry][8].

The `list` command itself returns a list of [MetacelloProjectSpec][7] instances that can be printed, inspected or otherwise manipulated.

In addition to a *select block*, you can specify a *select collection*
specifying the names of the projects you'd like to select:

```Smalltalk
Metacello registry
	baseline: #('Seaside' 'MetacelloPreview');
	list.
```

The `registry` message tells Metacello that you'd like to
look at all projects in the [registry][8] whether or not they are loaded.

The *collection* argument to the `baseline:` message is used to
*select* against the list of project names in the [registry][8].

## Getting

Once you've loaded a project into your image the next logical step is
upgrading your project to a new version. 

Let's say that a new `#stable` version of Seaside has been released
and that you want to upgrade. This is a two step process: 

* [get a new version of the configuration][11]
* [load the new version][12]

### Get a new version of the configuration

The following expression gets the latest version of the
baseline:

```Smalltalk
Metacello image
	baseline: 'Seaside';
	get.
```

By using the `image` message, you can leverage the fact that the [registry][8] remembers
from which repository you loaded the original version of the baseline.

The `get` command simply downloads the latest version of the
configuration package from the repository.

You may download the configuration from a different repository:

```Smalltalk
Metacello image
	baseline: 'Seaside30';
	repository: 'github://path/to/repository';
	get.
```

The `get` command will update the [registry][8] with the new
repository location information.

You may also use the `get` command to load a baseline for a project
into your image without actually loading the project itself:

```Smalltalk
Metacello image
	baseline: 'SeasideRest';
	repository: 'github://SeasideSt/Seaside:v3.4.6/repository';
	get.
```

The 'SeasideRest' project information will be registered in the [registry][8] and marked
as *unloaded*.

### Load the new version

Once you've got a new copy of the Seaside30 configuration loaded into your image, you may
upgrade your image with the following expression:

```Smalltalk
Metacello image
	baseline: 'Seaside';
	load.
```

By using the `image` message, you are asking Metacello to look the
project up in the [registry][8] before performing the
operation, so it isn't necessary to supply all of the project details for every
command operation.

Of course, the `load` command updates the [registry][8].

In this case you use the `registry` message to indicate that you are
interested in both *loaded* and *unloaded* projects.

##Locking

Let's say that you are using an older version of Seaside (say 3.0.5)
instead of the #stable version (3.0.7) and that your application doesn't
work with newer versions of Seaside (you've tried and it's more work
to get you application to work with the newer version of Seaside than
it's worth).

Let's also say that you want to try out something in the
SeasideRest project, but when you try loading SeasideRest, you end up
having Seaside 3.0.7 loaded as well. 

This is an unfortunate side effect of Metacello trying to *do the right
thing*, only in your case it is the wrong thing.

Fortunately, the [`lock` command][9] can give you control. First you
need to `lock` the Seaside project:

```Smalltalk
Metacello image
  baseline: 'Seaside';
  lock.
```

The `image` message tells Metacello to do a lookup in the list of loaded
projects and then to put a lock on the loaded version of the project.

After a project is locked, a project trying to load it will just skip it.
Notice that you are responsible for any problem product of this lock.

## Unlocking

You can unlock your project by executing:

```Smalltalk
Metacello image
  baseline: 'Seaside';
  unlock.
```

[1]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md
[2]: http://www.lukas-renggli.ch/blog/gofer
[3]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#repository-descriptions
[4]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#repository-shortcuts
[5]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#loading
[6]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#listing
[7]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#metacelloprojectspec
[8]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#metacello-project-registry
[9]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#locking
[10]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#metacello-version-numbers
[11]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloUserGuide.md#get-a-new-version-of-the-configuration
[12]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloUserGuide.md#load-the-new-version!
!Metacello methodsFor: 'api options' stamp: ''!
onConflictUseIncoming: incomingProjects useLoaded: loadedProjects
  self
    onConflict: [ :ex :loaded :incoming | 
      (incomingProjects includes: incoming baseName)
        ifTrue: [ ex useIncoming ]
        ifFalse: [ 
          (loadedProjects includes: incoming baseName)
            ifTrue: [ ex useLoaded ] ].
      ex pass ]! !

!Metacello methodsFor: 'private' stamp: ''!
addStatement: selector args: args
    self statements add: selector -> args! !

!Metacello methodsFor: 'api options' stamp: ''!
onConflictUseIncoming
  self onConflict: [ :ex :loaded :incoming | ex useIncoming ]! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
filetreeDirectory: directoryName
  self repository: 'filetree://' , directoryName! !

!Metacello methodsFor: 'api options' stamp: ''!
onLockBreak: projectNames
  self
    onLock: [ :ex :loaded :incoming | 
      (projectNames includes: loaded baseName)
        ifTrue: [ ex break ]
        ifFalse: [ ex honor ] ]! !

!Metacello methodsFor: 'api options' stamp: ''!
onDowngrade: aBlock
    self addStatement: #'onDowngrade:' args: {aBlock}! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
smalltalkhubUser: userName project: projectName
  self
    repository:
      'http://smalltalkhub.com/mc/' , userName , '/' , projectName , '/main'! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
gemsource: projectName
  self repository: 'http://seaside.gemtalksystems.com/ss/' , projectName! !

!Metacello methodsFor: 'api options' stamp: ''!
silently
    "no progress bars"

    self addStatement: #'silently:' args: {true}! !

!Metacello methodsFor: 'api options' stamp: ''!
onUpgradeUseLoaded
  self onUpgrade: [ :ex :loaded :incoming | ex useLoaded ]! !

!Metacello methodsFor: 'accessing' stamp: ''!
executorSpec: anAssoc
    executorSpec := anAssoc! !

!Metacello methodsFor: 'api actions' stamp: ''!
load
  ^ self execute: #'load:' args: #(#())! !

!Metacello methodsFor: 'api actions' stamp: ''!
unlock
  "unlock projects in registry"

  ^ self execute: #'unlock' args: #()! !

!Metacello methodsFor: 'api options' stamp: ''!
onUpgrade: aBlock
    self addStatement: #'onUpgrade:' args: {aBlock}! !

!Metacello methodsFor: 'api options' stamp: ''!
onWarningLog
  self
    onWarning: [ :ex | 
      MetacelloNotification signal: ex description.
      ex resume ]! !

!Metacello methodsFor: 'api options' stamp: ''!
onConflictUseLoaded
  self onConflict: [ :ex :loaded :incoming | ex useLoaded ]! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
renggli: projectName
    self repository: 'http://source.lukas-renggli.ch/' , projectName! !

!Metacello methodsFor: 'accessing' stamp: ''!
scriptExecutor
    ^ (self class scriptExecutorClass: self executorSpec) new! !

!Metacello methodsFor: 'api projectSpec' stamp: ''!
className: className
    self addStatement: #'classNameArg:' args: {className}! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
swasource: projectName
    self repository: 'http://www.hpi.uni-potsdam.de/hirschfeld/squeaksource/' , projectName! !

!Metacello methodsFor: 'api options' stamp: ''!
ignoreImage
    "ignore image state"

    self addStatement: #'ignoreImage:' args: {true}! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
blueplane: projectName
    self repository: 'http://squeaksource.blueplane.jp/' , projectName! !

!Metacello methodsFor: 'api projectSpec' stamp: ''!
configuration: projectName
    self addStatement: #'configurationArg:' args: {projectName}! !

!Metacello methodsFor: 'api actions' stamp: ''!
lock
  "lock projects in registry"

  ^ self execute: #'lock' args: #()! !

!Metacello methodsFor: 'api actions' stamp: ''!
load: required
  ^ self execute: #'load:' args: {required}! !

!Metacello methodsFor: 'accessing' stamp: ''!
statements: anObject
	statements := anObject! !

!Metacello methodsFor: 'api projectSpec' stamp: ''!
repository: repositoryDescription
    self addStatement: #'repositoryArg:' args: {repositoryDescription}! !

!Metacello methodsFor: 'api options' stamp: ''!
onDowngradeUseIncoming
  self onDowngrade: [ :ex :loaded :incoming | ex useIncoming ]! !

!Metacello methodsFor: 'api options' stamp: ''!
onLock: aBlock
  self addStatement: #'onLock:' args: {aBlock}! !

!Metacello methodsFor: 'accessing' stamp: ''!
executorSpec
    executorSpec ifNil: [ executorSpec := #'MetacelloScriptApiExecutor' -> 'batch' ].
    ^ executorSpec! !

!Metacello methodsFor: 'api projectSpec' stamp: ''!
project: projectName
    self addStatement: #'projectArg:' args: {projectName}! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
squeakfoundation: projectName
    self repository: 'http://source.squeakfoundation.org/' , projectName! !

!Metacello methodsFor: 'api options' stamp: ''!
onWarning: aBlock
  self addStatement: #'onWarning:' args: {aBlock}! !

!Metacello methodsFor: 'api options' stamp: ''!
repositoryOverrides: aRepositoryDescriptionCollection
    self addStatement: #'repositoryOverrides:' args: {aRepositoryDescriptionCollection}! !

!Metacello methodsFor: 'api options' stamp: ''!
onLockBreak
  self onLock: [ :ex :loaded :incoming | ex break ]! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
ss3: projectName
    self squeaksource3: projectName! !

!Metacello methodsFor: 'api actions' stamp: ''!
fetch: required
  ^ self execute: #'fetch:' args: {required}! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
squeaksource: projectName
    self repository: 'http://www.squeaksource.com/' , projectName! !

!Metacello methodsFor: 'api projectSpec' stamp: ''!
baseline: projectName
    self addStatement: #'baselineArg:' args: {projectName}! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
croquet: projectName
    self repository: 'http://hedgehog.software.umn.edu:8888/' , projectName! !

!Metacello methodsFor: 'api actions' stamp: ''!
fetch
  ^ self execute: #'fetch:' args: #(#())! !

!Metacello methodsFor: 'api actions' stamp: ''!
record: required
  ^ self execute: #'record:' args: {required}! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
squeaksource3: projectName
  self repository: 'http://ss3.gemtalksystems.com/ss/' , projectName! !

!Metacello methodsFor: 'api actions' stamp: ''!
unregister
  "unlock projects in registry"

  ^ self execute: #'unregister' args: #()! !

!Metacello methodsFor: 'api options' stamp: ''!
onDowngradeUseIncoming: projectNames
  self
    onDowngrade: [ :ex :loaded :incoming | 
      (projectNames includes: loaded baseName)
        ifTrue: [ ex useIncoming ]
        ifFalse: [ ex useLoaded ] ]! !

!Metacello methodsFor: 'api options' stamp: ''!
cacheRepository: aRepositoryDescription
    self addStatement: #'cacheRepository:' args: {aRepositoryDescription}! !

!Metacello methodsFor: 'private' stamp: ''!
execute: selector args: args
  | script |
  script := self statements copy.
  script add: selector -> args.
  ^ self scriptExecutor execute: script! !

!Metacello methodsFor: 'api actions' stamp: ''!
list
  "list projects in registry"

  ^ self execute: #'list' args: #()! !

!Metacello methodsFor: 'api actions' stamp: ''!
locked
  "list of locked projects in registry"

  ^ self
    project: [ :projectSpec | projectSpec isLocked ];
    list! !

!Metacello methodsFor: 'accessing' stamp: ''!
statements
    statements ifNil: [ statements := OrderedCollection new ].
    ^ statements! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
swa: projectName
    self swasource: projectName! !

!Metacello methodsFor: 'api projectSpec' stamp: ''!
version: versionString
    self addStatement: #'versionArg:' args: {versionString}! !

!Metacello methodsFor: 'api actions' stamp: ''!
register
  "change registered project"

  ^ self execute: #'register' args: #()! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
impara: projectName
    self repository: 'http://source.impara.de/' , projectName! !

!Metacello methodsFor: 'api actions' stamp: ''!
get
  "resolve project name in given repository and return an instance of MetacelloProject resolved from a ConfigurationOf or BaselineOf"

  ^ self execute: #'get' args: #()! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
wiresong: projectName
    self repository: 'http://source.wiresong.ca/' , projectName! !

!Metacello methodsFor: 'api actions' stamp: ''!
record
  ^ self execute: #'record:' args: #(#())! !

!Metacello methodsFor: 'api options' stamp: ''!
onUpgradeUseLoaded: projectNames
  self
    onUpgrade: [ :ex :loaded :incoming | 
      (projectNames includes: loaded baseName)
        ifTrue: [ ex useLoaded ]
        ifFalse: [ ex useIncoming ] ]! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
githubUser: userName project: projectName commitish: commitish path: path
  | branchOrCommitOrTag |
  branchOrCommitOrTag := commitish.
  branchOrCommitOrTag isEmpty
    ifTrue: [ branchOrCommitOrTag := 'master' ].
  self
    repository:
      'github://' , userName , '/' , projectName , ':' , branchOrCommitOrTag , '/'
        , path! !

!Metacello methodsFor: 'api options' stamp: ''!
onConflict: aBlock
    self addStatement: #'onConflict:' args: {aBlock}! !

!Metacello methodsFor: 'api repository shortcuts' stamp: ''!
bitbucketUser: userName project: projectName commitish: commitish path: path
  | branchOrCommitOrTag |
  branchOrCommitOrTag := commitish.
  branchOrCommitOrTag isEmpty
    ifTrue: [ branchOrCommitOrTag := 'master' ].
  self
    repository:
      'bitbucket://' , userName , '/' , projectName , ':' , branchOrCommitOrTag , '/'
        , path! !

!Metacello class methodsFor: 'instance creation' stamp: ''!
registry
    ^ self new
        executorSpec: #'MetacelloScriptRegistryExecutor' -> 'batch';
        yourself! !

!Metacello class methodsFor: 'instance creation' stamp: ''!
classic
    "set the options such that the load performed will be identical to the classic ConfigurationOf load:
	(ConfigurationOfExample project version: '1.0') load
	
	#classic forces Metacello to look at image state to determine which version of a project is loaded instead of using
		the registry to tell us explicitly which version of a project is loaded .. image state is not PRECISE"

    "useCurrentVersion is a 'private' option for enforcing classic rules, so it's not part of scripting api"

    ^ self new
        onUpgrade: [ :ex | ex allow ];
        onConflict: [ :ex | ex allow ];
        addStatement: #'useCurrentVersion:' args: {true};
        yourself! !

!Metacello class methodsFor: 'private' stamp: ''!
scriptExecutorClass
    ^ self scriptExecutorClass: {(#'MetacelloScriptApiExecutor' -> 'batch')}! !

!Metacello class methodsFor: 'instance creation' stamp: ''!
registrations
  ^ MetacelloProjectRegistration registry registrations! !

!Metacello class methodsFor: 'instance creation' stamp: ''!
image
    ^ self new
        executorSpec: #'MetacelloScriptImageExecutor' -> 'batch';
        yourself! !

!Metacello class methodsFor: 'private' stamp: ''!
scriptExecutorClass: anExecutorSpec
    self environment at: anExecutorSpec key ifAbsent: [ ConfigurationOf ensureMetacello: anExecutorSpec value ].
    ^ self environment at: anExecutorSpec key! !

!MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: ''!
extractVersionPragmas

	| aDict |
	aDict := Dictionary new.
	self extractPragmas: #version: into: aDict.
	^aDict! !

!MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: ''!
extractDefaultSymbolicVersionPragmas

	| aDict |
	aDict := Dictionary new.
	self extractPragmas: #defaultSymbolicVersion: into: aDict.
	^aDict! !

!MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: ''!
extractAllVersionPragmas

	| aDict |
	aDict := Dictionary new.
	self extractPragmas: #version: into: aDict.
	self extractPragmas: #version:imports: into: aDict.
	^aDict! !

!MetacelloAbstractConstructor methodsFor: 'accessing' stamp: ''!
configurationClass

	^self subclassResponsibility! !

!MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: ''!
extractSymbolicVersionPragmas

	| aDict |
	aDict := Dictionary new.
	self extractPragmas: #symbolicVersion: into: aDict.
	^aDict! !

!MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: ''!
extractCommonDefaultSymbolicVersionPragmas

	| aDict |
	aDict := Dictionary new.
	self extractPragmas: #defaultSymbolicVersion: for: ConfigurationOf into: aDict.
	^aDict! !

!MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: ''!
extractVersionImportPragmas

	| aDict |
	aDict := Dictionary new.
	self extractPragmas: #version:imports: into: aDict.
	^aDict! !

!MetacelloAbstractConstructor methodsFor: 'private' stamp: ''!
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: ''!
extractPragmas: pragmaKeyword into: versionDict

	^self extractPragmas: pragmaKeyword for: self configurationClass into: versionDict! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveToAllPackagesIn: aVersionSpec visited: visited

	| packages |
	packages := Dictionary new.
	self resolveToAllPackagesIn: aVersionSpec into: packages visited: visited.
	^packages values asOrderedCollection! !

!MetacelloAbstractPackageSpec methodsFor: 'printing' stamp: ''!
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: '*Metacello-MC' stamp: ''!
resolveToPackagesIn: aVersionSpec andProjects: andProjectsBool visited: visited
  ^ self resolveToPackagesIn: aVersionSpec visited: visited! !

!MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: ''!
includes: aCollection

	aCollection setIncludesInMetacelloPackage: self! !

!MetacelloAbstractPackageSpec methodsFor: 'adding' stamp: ''!
addToMetacelloPackages: aMetacelloPackagesSpec

	aMetacelloPackagesSpec addMember: 
		(aMetacelloPackagesSpec addMember 
			name: self name;
			spec: self;
			yourself)! !

!MetacelloAbstractPackageSpec methodsFor: 'private' stamp: ''!
requiredSpecsForPackageOrdering: aVersionSpec
  ^ self specs: self requires forPackageOrdering: aVersionSpec! !

!MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: ''!
mergeIntoMetacelloPackages: aMetacelloPackagesSpec

	aMetacelloPackagesSpec addMember: 
		(aMetacelloPackagesSpec mergeMember 
			name: self name;
			spec: self;
			yourself)! !

!MetacelloAbstractPackageSpec methodsFor: 'private' stamp: ''!
setIncludes: aCollection

	includes := aCollection! !

!MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: ''!
includes

	includes == nil ifTrue: [ includes := #() ].
	^includes! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
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: 'accessing' stamp: ''!
answers: aListOfPairs

	self setAnswers: aListOfPairs! !

!MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: ''!
mergeMap

	| map |
	map := super mergeMap.
	map at: #requires put: requires.
	map at: #includes put: includes.
	map at: #answers put: answers.
	^map! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
updatePackageRepositoriesFor: aVersionSpec
	"noop by default"
	
	^true! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
file 
	"MetacelloPackageSpec compatibility"
	
	^nil! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
version 
	"MetacelloPackageSpec compatibility"
	
	^nil! !

!MetacelloAbstractPackageSpec methodsFor: 'private' stamp: ''!
specs: specNames forPackageOrdering: aVersionSpec
  | packageOrProjectSpecs |
  packageOrProjectSpecs := Set new.
  specNames
    do: [ :specName | 
      | spec |
      "get project/group/package specs"
      spec := aVersionSpec
        packageNamed: specName
        ifAbsent: [ 
          MetacelloNameNotDefinedError
            signal:
              'project group, or package named: ' , specName printString
                ,
                  ' not found when used in requires: or includes: field of package: '
                , self name printString , ' for version: '
                , aVersionSpec versionString , ' of '
                , aVersionSpec projectLabel , '.'.
          nil	"return nil if resumed" ].
      spec
        ifNotNil: [ 
          packageOrProjectSpecs
            addAll: (spec resolveSpecsForPackageOrdering: aVersionSpec) ] ].
  ^ packageOrProjectSpecs! !

!MetacelloAbstractPackageSpec methodsFor: 'testing' stamp: ''!
hasRepository
    ^ false! !

!MetacelloAbstractPackageSpec methodsFor: 'printing' stamp: ''!
label

	^self name! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
repositorySpecs

	^#()! !

!MetacelloAbstractPackageSpec methodsFor: 'removing' stamp: ''!
removeFromMetacelloPackages: aMetacelloPackagesSpec

	aMetacelloPackagesSpec addMember: 
		(aMetacelloPackagesSpec removeMember 
			name: self name;
			spec: self;
			yourself)! !

!MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: ''!
nonOverridable

	^#( includes requires answers )! !

!MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: ''!
referencedSpec

	^self! !

!MetacelloAbstractPackageSpec methodsFor: 'copying' stamp: ''!
postCopy

	super postCopy.
	requires := requires copy.
	includes := includes copy.
	answers := answers copy.! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
isPackageLoaded

	^false! !

!MetacelloAbstractPackageSpec methodsFor: 'private' stamp: ''!
resolveSpecsForPackageOrdering: aVersionSpec
  ^ {self}! !

!MetacelloAbstractPackageSpec methodsFor: 'private' stamp: ''!
includeSpecNamesForPackageOrdering: aVersionSpec
  ^ self specs: self includesForPackageOrdering forPackageOrdering: aVersionSpec! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
forceUpdatePackageSpec: updatedSpecs using: anMCLoader

	^self updatePackageSpec: updatedSpecs using: anMCLoader! !

!MetacelloAbstractPackageSpec methodsFor: 'private' stamp: ''!
requiresSpecsForPackageOrdering: aVersionSpec
  ^ {self}! !

!MetacelloAbstractPackageSpec methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForRequiresFor: aStep
	<stSpotterOrder: 2>
	aStep listProcessor
		title: 'Requires';
		allCandidates: [ self requires ];
		itemName: [ :item | item name ];
		filter: StFilterSubstring;
		wantsToDisplayOnEmptyQuery: true! !

!MetacelloAbstractPackageSpec methodsFor: 'private' stamp: ''!
setRequires: aCollection

	requires := aCollection! !

!MetacelloAbstractPackageSpec methodsFor: 'printing' stamp: ''!
configMethodCascadeOn: aStream member: aMember last: lastCascade indent: indent

	self subclassResponsibility! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
visitingWithPackages: packages
	"noop"! !

!MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: ''!
requires: aCollection

	aCollection setRequiresInMetacelloPackage: self! !

!MetacelloAbstractPackageSpec methodsFor: 'private' stamp: ''!
requiredSpecNamesForPackageOrdering: aVersionSpec
  ^ (self requiredSpecsForPackageOrdering: aVersionSpec)
    collect: [ :spec | spec name ]! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
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: ''!
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: 'printing' stamp: ''!
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: 'accessing' stamp: ''!
name: aString
    ((aString at: 1) isSeparator or: [ (aString at: aString size) isSeparator ])
        ifTrue: [ self error: 'Names are not allowed to have leading or trailing blanks: ' , aString printString ].
    name := aString! !

!MetacelloAbstractPackageSpec methodsFor: 'private' stamp: ''!
setAnswers: aCollection

	answers := aCollection! !

!MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: ''!
answers

	^answers ifNil: [ answers := #() ].! !

!MetacelloAbstractPackageSpec methodsFor: 'visiting' stamp: ''!
projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock

	self subclassResponsibility! !

!MetacelloAbstractPackageSpec methodsFor: 'private' stamp: ''!
includesForPackageOrdering
  ^ #()! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
loadUsing: aLoader gofer: gofer

	^self subclassResponsibility! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveToPackagesIn: aVersionSpec visited: visited

	^self subclassResponsibility! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveToLoadableSpec

	^self! !

!MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: ''!
name

	^name! !

!MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: ''!
requires

	requires == nil ifTrue: [ requires := #() ].
	^requires! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
packagesNeedSavingVisited: visitedProjects using: repos into: aCollection
	"noop by default"! !

!MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: ''!
mergeSpec: anotherSpec

	| newSpec map anotherRequires anotherIncludes anotherAnswers |
	newSpec := super mergeSpec: anotherSpec.
	map := anotherSpec mergeMap.
	anotherSpec name ~~ nil 
		ifTrue: [ newSpec name: anotherSpec name ].
	(anotherRequires := map at: #requires) ~~ nil
		ifTrue: [ newSpec setRequires: self requires, anotherRequires ].
	(anotherIncludes := map at: #includes) ~~ nil
		ifTrue: [ newSpec setIncludes: self includes, anotherIncludes ].
	(anotherAnswers := map at: #answers) ~~ nil
		ifTrue: [ newSpec setAnswers: self answers, anotherAnswers ].
	^newSpec! !

!MetacelloAbstractPackageSpec methodsFor: '*Metacello-MC' stamp: ''!
getFile
  "MetacelloPackageSpec compatibility"

  ^ nil! !

!MetacelloAbstractPackageSpec methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForIncludesFor: aStep
	<stSpotterOrder: 1>
	aStep listProcessor
		title: 'Includes';
		allCandidates: [ self includes ];
		itemName: [ :item | item name ];
		filter: StFilterSubstring;
		wantsToDisplayOnEmptyQuery: true! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
setProject: aProject

	project := aProject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
includes: anObject
    self root includes: anObject constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
project: aString copyFrom: oldSpecName with: aBlock
    self root
        project: aString
        copyFrom: oldSpecName
        with: aBlock
        constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
repository: description username: username password: password
    self root
        repository: description
        username: username
        password: password
        constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
fileForProject: aString
    self root file: aString! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
versionString: anObject
    self root versionString: anObject constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
includesForPackage: anObject
    self root includes: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoriesForPackage: aBlock
    self repositoriesForSpec: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
root

	^root! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
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: 'accessing' stamp: ''!
root: aMetacelloSpec
    root := aMetacelloSpec! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
package: aString
    self root package: aString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
valueForValueHolder: anObject
    self root value: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
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' stamp: ''!
import: aString provides: aCollection
  "import names defined in baseline <aString> to be used when loading the version

	
		spec baseline: 'Sample' with: [ spec repository: 'github://dalehenrich/sample:master/repository' ].
		spec import: 'Sample' provides: #('Sample Core');
		spec baseline: 'Example' with: [ spec repository: 'github://dalehenrich/example:master/repository' ].
		spec import: 'Example' provides: #('Example Core')]	
	 "

  self root import: aString provides: aCollection constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'validation' stamp: ''!
validateDoItSelector: anObject

	anObject == nil ifTrue: [ ^ self ].
	anObject isSymbol ifFalse: [ self error: 'Invalid message selector for doit: ', anObject printString ].! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
timestamp: aBlockOrStringOrDateAndTime
    "Define timestamp field of version spec (MetacelloMCVersionSpec).
	 If <aBlockOrStringOrDateAndTime> is a String, the version spec timetamp is set to the String.
	 If <aBlockOrStringOrDateAndTime> is a DateAndTime, the version spec timetamp is set to the printString of the DateAndTime.
	If <aBlockOrStringOrDateAndTime> is a Block, the specifications in <aBlockOrStringOrDateAndTime> are applied to the timestamp spec (MetacelloValueHolderSpec). Not Recommended!!
	
		spec timestamp: '10/7/2009 14:40'.
		
		spec timestamp: DateAndTime now'.
		
		spec timestamp: [
			spec value: '10/7/2009 14:40'. ].
    "

    self root timestamp: aBlockOrStringOrDateAndTime constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
description: aBlockOrString
    "Define description field of version spec (MetacelloMCVersionSpec).
	 If <aBlockOrString> is a String, the version spec blessing is set to the String. It is recommended to use a Symbol.
	If <aBlockOrString> is a Block, the specifications in <aBlockOrString> are applied to the blessing spec (MetacelloValueHolderSpec). Not Recommended!!
	
		spec description: 'Descriptive comment'.
		
		spec description: [
			spec value: 'Descriptive comment'.
	 "

    self root description: aBlockOrString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
groupForVersion: aString with: aStringOrCollection
    | spec |
    spec := self project groupSpec
        name: aString;
        includes: aStringOrCollection;
        yourself.
    self root packages merge: spec! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
project: aString with: aBlockOrString
    self root project: aString with: aBlockOrString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
symbolicVersion: aSymbol

	symbolicVersion := aSymbol! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
groupForVersion: aString overrides: aStringOrCollection
    | spec |
    spec := self project groupSpec
        name: aString;
        includes: aStringOrCollection;
        yourself.
    self root packages add: spec! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
baseline: aString with: aBlockOrString
    self root baseline: aString with: aBlockOrString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setDescriptionWithString: aString

	self root description: aString! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoriesForProject: aBlock
    self repositoriesForSpec: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
postLoadDoIt: aSymbol
    self root postLoadDoIt: aSymbol constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoryForVersion: anObject
    self repositoryForSpec: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
configuration: aString with: aBlockOrString
    self root configuration: aString with: aBlockOrString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
repository: anObject
    self root repository: anObject constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
projectPackage: aBlock
    "projectPackage spec data folded into project spec"

    self root projectPackage: aBlock constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
fileForPackage: aString
    self root file: aString! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
projectForVersion: aString copyFrom: oldSpecName with: aBlock
    | spec projectSpec |
    projectSpec := self project projectSpec
        name: aString;
        yourself.
    spec := self project projectReferenceSpec
        name: aString;
        projectReference: projectSpec;
        yourself.
    self root packages copy: oldSpecName to: spec.
    self with: projectSpec during: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
requires: anObject
    self root requires: anObject constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
postLoadDoItForSpec: aSymbol
    self validateDoItSelector: aSymbol.
    self root postLoadDoIt: aSymbol! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setTimestampWithString: aString

	self root timestamp: aString! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
versionForProject: anObject
    self versionStringForProject: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
projectForVersion: aString
    self project: aString with: ''! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoryForVersion: aString username: username password: password
    self repositoryForSpec: aString username: username password: password! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
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' stamp: ''!
package: aString overrides: aBlock
    self root package: aString overrides: aBlock constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
preLoadDoIt: aSymbol
    self root preLoadDoIt: aSymbol constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
configurationClass

	^self configuration class! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
preLoadDoItForVersion: aSymbol
    self preLoadDoItForSpec: aSymbol! !

!MetacelloAbstractVersionConstructor methodsFor: 'initialization' stamp: ''!
reset
    attributeMap := attributeOrder := nil! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
projectForVersion: aString overrides: aBlock
    | spec projectSpec |
    projectSpec := self project projectSpec
        name: aString;
        yourself.
    spec := self project projectReferenceSpec
        name: aString;
        projectReference: projectSpec;
        yourself.
    self root packages add: spec.
    self with: projectSpec during: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
baselineForVersion: aString
    self setBaseline: aString! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
packageForVersion: aString
    | spec |
    spec := self project packageSpec
        name: aString;
        yourself.
    self root packages add: spec! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
supplyingAnswers: aCollection
    self root supplyingAnswers: aCollection constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
projectForVersion: aString with: aBlockOrString
    aBlockOrString setProject: aString withInMetacelloConfig: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setPackage: aString withString: aFile

	| spec |
	spec := 
		(self project packageSpec)
			name: aString;
			file: aFile;
			yourself.
	self root packages merge: spec.! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
loadsForProject: anObject
    self root loads: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
configurationForVersion: aString with: aBlock
    aBlock setConfiguration: aString withInMetacelloConfig: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
authorForVersion: aBlockOrString
    aBlockOrString setAuthorInMetacelloConfig: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
attributeOrder

	attributeOrder == nil ifTrue: [ attributeOrder := OrderedCollection new ].
	^attributeOrder! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
author: aBlockOrString
    "Define author field of version spec (MetacelloMCVersionSpec).
	 If <aBlockOrString> is a String, the version spec author is set to the String.
	If <aBlockOrString> is a Block, the specifications in <aBlockOrString> are applied to the author spec (MetacelloValueHolderSpec). Not Recommended!!
	
		spec author: 'dkh'.
		
		spec author: [
			spec value: 'dkh'. ].
	 "

    self root author: aBlockOrString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
descriptionForVersion: aBlockOrString
    aBlockOrString setDescriptionInMetacelloConfig: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
project
    project == nil
        ifTrue: [ project := self projectClass new ].
    ^ project! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setFor: attributeList version: aString
    "conditional symbolicVersion support"

    attributeList asMetacelloAttributeList
        do: [ :attribute | 
            self attributeMap at: attribute put: aString.
            self addAttribute: attribute ]! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
preLoadDoItForPackage: aSymbol
    self preLoadDoItForSpec: aSymbol! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
loads: aStringOrCollection
  self root loads: aStringOrCollection constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoryForRepositories: anObject
    self repositoryForSpec: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
timestampForVersion: aBlockOrStringOrDateAndTime
    aBlockOrStringOrDateAndTime setTimestampInMetacelloConfig: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
project: aString overrides: aBlock
    self root project: aString overrides: aBlock constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setAuthorWithString: aString

	self root author: aString! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
value: anObject
    self root value: anObject constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
importForVersion: aString
    self root import: aString! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
addAttribute: anAttribute

	self attributeOrder add: anAttribute! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoriesForVersion: aBlock
    self repositoriesForSpec: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
configuration

	^configuration! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
postLoadDoItForVersion: aSymbol
    self postLoadDoItForSpec: aSymbol! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
blessingForVersion: aBlockOrString
    aBlockOrString setBlessingInMetacelloConfig: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setProject: aString withBlock: aBlock
    | spec projectSpec |
    projectSpec := self project projectSpec
        name: aString;
        yourself.
    spec := self project projectReferenceSpec
        name: aString;
        projectReference: projectSpec;
        yourself.
    self root packages merge: spec.
    self with: projectSpec during: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
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 spec callbacks' stamp: ''!
repositoryForProject: anObject
    self repositoryForSpec: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
postLoadDoItForPackage: aSymbol
    self postLoadDoItForSpec: aSymbol! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
for: attributeListOrSymbol version: aString
    "conditional symbolicVersion support"

    attributeListOrSymbol setForVersion: aString withInMetacelloConfig: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoryForProject: aString username: username password: password
    self repositoryForSpec: aString username: username password: password! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
removePackage: aString
    self root removePackage: aString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
preLoadDoItForSpec: aSymbol
    self validateDoItSelector: aSymbol.
    self root preLoadDoIt: aSymbol! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setBaseline: aString withBlock: aBlock
    | projectSpec |
    projectSpec := self setBaseline: aString.
    self with: projectSpec during: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
group: aString with: aStringOrCollection
    self root group: aString with: aStringOrCollection constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
packageForVersion: packageName with: aBlockOrString
    aBlockOrString setPackage: packageName withInMetacelloConfig: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoryForRepositories: aString username: username password: password
    self repositoryForVersion: aString username: username password: password! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
nameForProject: aString
    self root name: aString! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
requiresForPackage: anObject
    self root requires: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
className: aString
    "Define className field of a project spec (MetacelloMCProjectSpec).
	
		spec project: 'CoolBrowser' with: [
			spec className: 'ConfigurationOfCoolBrowser'. ].

	The className field is OPTIONAL in the project spec. If omitted, the className will be created by prepending 'ConfigurationOf' to the project name.
	 "

    self root className: aString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: '*metacello-mc-accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
preLoadDoItForProject: aSymbol
    self preLoadDoItForSpec: aSymbol! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
file: aString
    "Define file field of a package spec (MetacelloPackageSpec) or project spec (MetacelloMCProjectSpec).

	For a package spec, the file: field is optional in a baseline. In a baseline, the file field may be used to specify a package branch for the package:
	
		spec package: 'MyPackage' with: [
			spec file: 'MyPackage.gemstone'. ]'.

	The file: field is required in a version. In a version, the file field defines the explicit version of the package to be loaded:
	
		spec package: 'MyPackage' with: [
			spec file: 'MyPackage.gemstone-dkh.1'. ]'.

	The following may be used as a short cut for specifying the file field in a version:

		spec package: 'MyPackage' with: 'MyPackage.gemstone-dkh.1'.

	For a project spec, the file field specifies the name of the Monticello package that contains the configuration. If you are using the convention of 
	naming the class and package usingthe  'ConfigurationOf' prefix, then there is no need to specify the file field:
	
		spec project: 'MyProject' with: [
			spec file: 'ConfigurationMyProject'.

	It should only be used when the package name for the configuration is different from the name of the project:

		spec project: 'MyProject' with: [
			spec file: 'MyProject-Metacello'.
	 "

    self root file: aString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
removeGroup: aString
    self root removeGroup: aString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoryForSpec: anObject
    self root repository: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoryForPackage: aString username: username password: password
    self repositoryForSpec: aString username: username password: password! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
configuration: aConfig

	configuration := aConfig! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
removeGroupForVersion: aString
    | spec |
    spec := self project groupSpec
        name: aString;
        yourself.
    self root packages remove: spec! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoriesForSpec: aBlock
    self with: self root repositories during: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
supplyingAnswersForPackage: anObject
    self root answers: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
package: packageName with: aBlockOrString
    "Define specification for package <packageName>.
	 If <aBlockOrString> is a String (or Symbol), the String is expected to be a version (or symbolic version).
	If <aBlockOrString> is a Block, the specifications in <aBlockOrString> are applied to the project:
	
		spec package: 'MyPackage' with: '1.0'.
		
		spec package: 'MyPackage' with: [
			spec file:'MyPackage-dkh.1'.
			spec repository: '/opt/gemstone/repository'.
	 "

    self root package: packageName with: aBlockOrString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
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 spec callbacks' stamp: ''!
classNameForProject: aString
    self root className: aString! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setConfiguration: aString withBlock: aBlock
    | spec projectSpec |
    projectSpec := self project configurationOfProjectSpec
        name: aString;
        yourself.
    spec := self project projectReferenceSpec
        name: aString;
        projectReference: projectSpec;
        yourself.
    self root packages merge: spec.
    self with: projectSpec during: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
for: attributeListOrSymbol do: aBlock
    "conditional version support"

    attributeListOrSymbol setForDo: aBlock withInMetacelloConfig: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
project: aString
    self root project: aString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
removeProjectForVersion: aString
    | spec |
    spec := self project projectReferenceSpec
        name: aString;
        yourself.
    self root packages remove: spec! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setBlessingWithString: aString

	self root blessing: aString! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
group: aString overrides: aStringOrCollection
    self root group: aString overrides: aStringOrCollection constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
postLoadDoItForProject: aSymbol
    self postLoadDoItForSpec: aSymbol! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
versionForVersion: anObject
    self versionStringForVersion: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
operatorForProject: anObject
    self root operator: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
baseline: aString
    self root baseline: aString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
blessing: aBlockOrString
    "Define blessing field of version spec (MetacelloMCVersionSpec).
	 If <aBlockOrString> is a String, the version spec blessing is set to the String. It is recommended to use a Symbol.
	If <aBlockOrString> is a Block, the specifications in <aBlockOrString> are applied to the blessing spec (MetacelloValueHolderSpec). Not Recommended!!
	
		spec blessing: #release.
		
		spec blessing: [
			spec value: #release. ].
	
	The blessing should typically be set to one of three values:
		#baseline - indicating that the version spec is specifying a baseline version
		#development - indicating that the version spec is not stabilized and will change over time
		#release - indicating that the version spec has stabilized and will NOT change over time
	 "

    self root blessing: aBlockOrString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'private' stamp: ''!
evaluatePragma: pragma
	currentContext := pragma.
	[ self configuration 
		perform: (MetacelloPlatform current selectorForPragma: pragma) 
		with: self ] 
	ensure: [ currentContext := nil ]! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
name: anObject
    self root name: anObject constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
versionStringForProject: anObject
    self root versionString: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'private' stamp: ''!
with: aMetacelloSpec during: aBlock
    | previousRoot |
    previousRoot := self root.
    self root: aMetacelloSpec.
    aBlock
        ensure: [ self root: previousRoot ]! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
attributeMap

	attributeMap == nil ifTrue: [ attributeMap := Dictionary new ].
	^attributeMap! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
projectPackageForProject: aBlock
    self with: self root during: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
importForVersion: aString provides: anArray
  self root import: aString provides: anArray! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
operator: anObject
    self root operator: anObject constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
removeProject: aString
    self root removeProject: aString constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
repositoryForSpec: aString username: username password: password
    self root repository: aString username: username password: password! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
removePackageForVersion: aString
    | spec |
    spec := self project packageSpec
        name: aString;
        yourself.
    self root packages remove: spec! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
import: aStringOrCollection
  "import names defined in baseline <aString> to be used when loading the version

		spec baseline: 'Sample' with: [ spec repository: 'github://dalehenrich/sample:master/repository' ].
		spec import: 'Sample' ]
	
	or a list of names for multiple project imports:
	
		spec baseline: 'Sample' with: [ spec repository: 'github://dalehenrich/sample:master/repository' ].
		spec baseline: 'Example' with: [ spec repository: 'github://dalehenrich/example:master/repository' ].
		spec import: #('Sample' 'Example')]	
	 "

  self root import: aStringOrCollection constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setBaseline: aString
    | spec projectSpec |
    projectSpec := self project baselineOfProjectSpec
        name: aString;
        className: 'BaselineOf' , aString;
        yourself.
    spec := self project projectReferenceSpec
        name: aString;
        projectReference: projectSpec;
        yourself.
    self root packages merge: spec.
    ^ projectSpec! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
version: anObject
    self root version: anObject constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
setDescriptionWithBlock: aBlock

	| spec |
	(spec := self root getDescription) == nil
		ifTrue: [ 
			spec := self project valueHolderSpec.
			self root setDescription: spec ].
	self with: spec during: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
packageForVersion: aString overrides: aBlock
    | spec |
    spec := self project packageSpec
        name: aString;
        yourself.
    self root packages add: spec.
    self with: spec during: aBlock! !

!MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: ''!
symbolicVersion

	^symbolicVersion! !

!MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: ''!
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 spec callbacks' stamp: ''!
repositoryForPackage: anObject
    self repositoryForSpec: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
versionStringForVersion: anObject
    self versionStringForProject: anObject! !

!MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: ''!
repositories: aBlock
    self root repositories: aBlock constructor: self! !

!MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: ''!
baselineForVersion: aString with: aBlock
    aBlock setBaseline: aString withInMetacelloConfig: self! !

!MetacelloAbstractVersionConstructor class methodsFor: 'method generation' stamp: ''!
symbolicMethodSelectorAndPragma: selector symbolicVersionSymbol: symbolicVersionSymbol on: strm
	strm
		nextPutAll: selector asString , ' spec';
		cr;
		tab;
		nextPutAll: '<symbolicVersion: #' , symbolicVersionSymbol asString printString;
		nextPutAll: '>';
		cr! !

!MetacelloAddMemberSpec methodsFor: 'actions' stamp: ''!
applyToList: aListSpec

	aListSpec add: self! !

!MetacelloAddMemberSpec methodsFor: 'actions' stamp: ''!
applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock

	addBlock value: self! !

!MetacelloAddMemberSpec methodsFor: 'accessing' stamp: ''!
methodUpdateSelector

	^#overrides:! !

!MetacelloAllowConflictingProjectUpgrade methodsFor: 'exception handling' stamp: ''!
defaultAction
  self existingProjectRegistration locked
    ifTrue: [ 
      "https://github.com/dalehenrich/metacello-work/issues/263"
      ^ self useIncoming ].
  ^ MetacelloConflictingProjectError
    signal:
      'Load Conflict between existing ' , self existingProjectRegistration printString
        , ' and ' , self newProjectRegistration printString! !

!MetacelloAllowConflictingProjectUpgrade methodsFor: 'handlers' stamp: ''!
handleResolutionFor: aScriptEngine
    ^ aScriptEngine handleConflict: self! !

!MetacelloAllowConflictingProjectUpgrade methodsFor: 'accessing' stamp: ''!
operationString
  ^ 'load with conflicts'! !

!MetacelloAllowLockedProjectChange methodsFor: 'exception handling' stamp: ''!
break
  ^ self allow! !

!MetacelloAllowLockedProjectChange methodsFor: 'exception handling' stamp: ''!
defaultAction
  Warning
    signal:
      'LOCK ENFORCED: Attempt to ' , self operationString printString
        , ' new project: ' , self newProjectRegistration printString printString
        , ' when existing project: '
        , self existingProjectRegistration printString printString
        , ' is locked. New project not loaded. Use #onLock: to intercept.'.
  ^ self disallow! !

!MetacelloAllowLockedProjectChange methodsFor: 'handlers' stamp: ''!
handleResolutionFor: aScriptEngine
  ^ aScriptEngine handleLock: self! !

!MetacelloAllowLockedProjectChange methodsFor: 'exception handling' stamp: ''!
honor
  ^ self disallow! !

!MetacelloAllowLockedProjectChange methodsFor: 'private' stamp: ''!
checkAllowed
  "noop ... if user decided to allow lock to be broken, then so be it"! !

!MetacelloAllowLockedProjectChange methodsFor: 'accessing' stamp: ''!
operationString
  ^ operationString! !

!MetacelloAllowLockedProjectChange methodsFor: 'accessing' stamp: ''!
operationString: aString
  operationString := aString! !

!MetacelloAllowProjectDowngrade methodsFor: 'exception handling' stamp: ''!
defaultAction
  "Default for Downgrade is to disallow, but still should check for locks"

  self checkAllowed.
  ^ super defaultAction! !

!MetacelloAllowProjectDowngrade methodsFor: 'handlers' stamp: ''!
handleResolutionFor: aScriptEngine
    ^ aScriptEngine handleDowngrade: self! !

!MetacelloAllowProjectDowngrade methodsFor: 'handlers' stamp: ''!
handleOnDownGrade: onDownGradeBlock onUpgrade: onUpgradeBlock
    ^ onDownGradeBlock cull: self cull: self existingProjectRegistration cull: self newProjectRegistration! !

!MetacelloAllowProjectDowngrade methodsFor: 'accessing' stamp: ''!
operationString
  ^ 'downgrade to'! !

!MetacelloAllowProjectUpgrade methodsFor: 'exception handling' stamp: ''!
defaultAction
    "Default for Upgrade is to allow"

    self checkAllowed.
    ^ self newProjectRegistration! !

!MetacelloAllowProjectUpgrade methodsFor: 'handlers' stamp: ''!
handleResolutionFor: aScriptEngine
    ^ aScriptEngine handleUpgrade: self! !

!MetacelloAllowProjectUpgrade methodsFor: 'handlers' stamp: ''!
handleOnDownGrade: onDownGradeBlock onUpgrade: onUpgradeBlock
    ^ onUpgradeBlock cull: self cull: self existingProjectRegistration cull: self newProjectRegistration! !

!MetacelloAllowProjectUpgrade methodsFor: 'accessing' stamp: ''!
operationString
  ^ 'upgrade to'! !

!MetacelloAlternateResource methodsFor: 'accessing' stamp: ''!
versionReferences
	^ versionReferences! !

!MetacelloAlternateResource methodsFor: 'accessing' stamp: ''!
monticelloRepository
	^ monticelloRepository! !

!MetacelloAlternateResource methodsFor: 'running' stamp: ''!
setUpVersionReferences
	"self reset"

	versionReferences := OrderedCollection new.
	versionReferences
		add: (GoferVersionReference name: 'GoferBar-dkh.24');
		add: (GoferVersionReference name: 'GoferBar-dkh.25');
		add: (GoferVersionReference name: 'GoferFoo-dkh.75');
		add: (GoferVersionReference name: 'GoferFoo-dkh.104')! !

!MetacelloAlternateResource methodsFor: 'running' stamp: ''!
setUpMonticelloRepository
	"This method builds a fake repository with the version references from #buildReferences."

	monticelloRepository := MCDictionaryRepository new.
	versionReferences do: [ :reference |
		monticelloRepository basicStoreVersion: (MCVersion new
			setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
			info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
			snapshot: (MCSnapshot fromDefinitions: (Array
				with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol))
				with: (MCClassDefinition name: reference packageName asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: '')))
			dependencies: #()) ]! !

!MetacelloAlternateResource methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self
		setUpVersionReferences;
		setUpMonticelloRepository! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: ''!
baseline20Fan: spec 
	"self reset"
	<version: '2.0-baseline'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec blessing: #baseline.
		spec 
			package: 'GoferFan';
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
baseline60Foo: spec 
	"self reset"
	<version: '6.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferFoo' with:'GoferFoo-lr.4';
			package: 'GoferBar' with: 'GoferBar-lr.1';
			package: 'GoferFaux' with: 'GoferFaux-tg.34';
			package: 'GoferBeau' with: 'GoferBeau-dkh.55';
			yourself.
		spec
			group: '1' with: #('GoferFoo' 'GoferBar');
			group: '2' with: #('1' 'GoferFaux');
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: ''!
baseline20MethodSourceFan

	^(self class sourceCodeAt: #baseline20Fan:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'accessing' stamp: ''!
monticelloRepository
	^ monticelloRepository! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
setUpConfigurationOfAtomicFoo
    "self reset"

    | reference className definitionArray |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfAtomicFoo-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: className)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline20Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline20MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline25Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline25MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'version20Foo:'
        category: 'cat'
        timeStamp: ''
        source: self version20MethodSourceFoo)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #())! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
version20MethodSourceFoo

	^(self class sourceCodeAt: #version20Foo:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: ''!
baseline62MethodSourceProjectIssue86

	^(self class sourceCodeAt: #baseline62ProjectIssue86:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: ''!
setUpConfigurationOfUmbrellaA
    "self reset"

    | reference className definitionArray |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfUmbrellaA-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: className)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'version50Umbrella:'
        category: 'cat'
        timeStamp: ''
        source: self version50MethodSourceUmbrella)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #())! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
baseline25Foo: spec 
	"self reset"
	<version: '2.5-baseline'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec blessing: #baseline.
		spec 
			package: 'GoferFoo' with: [spec requires: 'GoferFan' ];
			yourself.
		spec 
			project: 'GoferFan' with: [ "requires GoferBeau"
				spec
					className: 'MetacelloTestConfigurationOfAtomicFan';
					versionString: '2.0-baseline';
					loads: 'GoferFan';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: ''!
postLoad31baseline
	"Throw an error if GoferFar isn't loaded"

	Smalltalk at: #GoferFar ifAbsent: [ self error: 'GoferFar should be loaded' ]! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
baseline61Foo: spec 
	"self reset"
	<version: '6.1'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferFoo' with:'GoferFoo-lr.4';
			package: 'GoferBar' with: 'GoferBar-lr.1';
			package: 'GoferFaux' with: 'GoferFaux-tg.34';
			package: 'GoferBeau' with: 'GoferBeau-dkh.55';
			yourself.
		spec
			group: '1' with: #('GoferFoo' 'GoferBar');
			group: '2' with: #('GoferFoo' 'GoferBeau');
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
baseline61MethodSourceFoo

	^(self class sourceCodeAt: #baseline61Foo:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: ''!
version50Umbrella: spec 
	"self reset"
	<version: '5.0'>
	
	spec for: #common do: [
		spec 
			project: 'Umbrella' with: [
				spec
					className: 'MetacelloTestConfigurationOfLinearFoo';
					versionString: '5.0';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
version51Foo: spec 
	"self reset"
	<version: '5.1'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec blessing: #release.
		spec 
			package: 'GoferUmbrella' with: 'GoferUmbrella-lr.5';
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: ''!
baseline61MethodSourceProjectIssue86

	^(self class sourceCodeAt: #baseline61ProjectIssue86:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
linearProjectMethodSource

	^(self class sourceCodeAt: #project) asString copyReplaceAll: 'atomic' with: 'linear'! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: ''!
setUpConfigurationOfAtomicFan
    "self reset"

    | reference className definitionArray |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfAtomicFan-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: className)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline20Fan:'
        category: 'cat'
        timeStamp: ''
        source: self baseline20MethodSourceFan).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline31Fan:'
        category: 'cat'
        timeStamp: ''
        source: self baseline31MethodSourceFan).
    (MCMethodDefinition
        className: className asString
        selector: 'postLoad31baseline'
        category: 'cat'
        timeStamp: ''
        source: self postLoad31baselineMethodSource)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #())! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: ''!
setUpConfigurationOfUmbrellaB
    "self reset"

    | reference className definitionArray |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfUmbrellaB-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: className)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'version51Umbrella:'
        category: 'cat'
        timeStamp: ''
        source: self version51MethodSourceUmbrella)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #())! !

!MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: ''!
baseline62ProjectIssue86: spec 
	"projects and packages"
	"self reset"
	<version: '6.2'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'A' with: [
				spec
					className: 'MetacelloTestConfigurationOfLinearFoo';
					versionString: '6.2';
					loads: #('1');
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			project: 'B' with: [
				spec
					className: 'MetacelloTestConfigurationOfLinearFoo';
					versionString: '6.2';
					loads: #('2');
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self
		setUpMonticelloRepository;
		setUpConfigurationOfAtomicFoo;
		setUpConfigurationOfLinearFoo;
		setUpConfigurationOfAtomicFan;
		setUpConfigurationOfUmbrellaA;
		setUpConfigurationOfUmbrellaB;
		setUpConfigurationOfProjectIssue86;
		yourself! !

!MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: ''!
baseline61ProjectIssue86: spec 
	"projects and packages"
	"self reset"
	<version: '6.1'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'A' with: [
				spec
					className: 'MetacelloTestConfigurationOfLinearFoo';
					versionString: '6.1';
					loads: #('1');
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			project: 'B' with: [
				spec
					className: 'MetacelloTestConfigurationOfLinearFoo';
					versionString: '6.1';
					loads: #('2');
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: ''!
baseline60ProjectIssue86: spec 
	"projects and packages"
	"self reset"
	<version: '6.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'A' with: [
				spec
					className: 'MetacelloTestConfigurationOfLinearFoo';
					versionString: '6.0';
					loads: #('1');
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			project: 'B' with: [
				spec
					className: 'MetacelloTestConfigurationOfLinearFoo';
					versionString: '6.0';
					loads: #('2');
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: ''!
baseline31MethodSourceFan

	^(self class sourceCodeAt: #baseline31Fan:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: ''!
version50MethodSourceUmbrella

	^(self class sourceCodeAt: #version50Umbrella:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: ''!
version51MethodSourceUmbrella

	^(self class sourceCodeAt: #version51Umbrella:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
baseline62Foo: spec 
	"self reset"
	<version: '6.2'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferFoo' with:'GoferFoo-lr.4';
			package: 'GoferBar' with: 'GoferBar-lr.1';
			package: 'GoferFaux' with: 'GoferFaux-tg.34';
			package: 'GoferBeau' with: 'GoferBeau-dkh.55';
			yourself.
		spec
			group: '1' with: #('GoferFoo' 'GoferBar');
			group: '2' with: #('GoferFoo' );
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: ''!
baseline60MethodSourceProjectIssue86

	^(self class sourceCodeAt: #baseline60ProjectIssue86:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
baseline25MethodSourceFoo

	^(self class sourceCodeAt: #baseline25Foo:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
version51MethodSourceFoo

	^(self class sourceCodeAt: #version51Foo:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
version20Foo: spec 
	"self reset"
	<version: '2.0' imports: #('2.0-baseline')>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec blessing: #release.
		spec 
			package: 'GoferBar' with: 'GoferBar-dkh.1';
			package: 'GoferFoo' with: 'GoferFoo-dkh.4';
			package: 'GoferBeau' with: 'GoferBeau-dkh.15';
			package: 'GoferFaux' with: 'GoferFaux-tg.30';
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
project
	"self reset"

	| constructor project |
	"Construct Metacello project"
	constructor := MetacelloVersionConstructor on: self.
	project := constructor project.
	project loader: 
		((project loaderClass new)
			shouldDisablePackageCache: true;
			yourself).
	project loadType: #atomic.
	^project! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
baseline20MethodSourceFoo

	^(self class sourceCodeAt: #baseline20Foo:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: ''!
baseline31Fan: spec 
	"self reset"
	<version: '3.1-baseline'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec postLoadDoIt: #postLoad31baseline.
		spec 
			package: 'GoferBar';
			package: 'GoferBeau' with: [ 
				spec 
					requires: 'GoferBar';
					includes: #('GoferFoo' ) ]; 
			package: 'GoferFar' with: [ spec requires: #('GoferFoo' ) ]; 
			yourself.
		spec 
			project: 'GoferFoo' with: [ "requires GoferBeau"
				spec
					className: 'MetacelloTestConfigurationOfLinearFoo';
					versionString: '2.0';
					loads: 'GoferFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
projectMethodSource

	^(self class sourceCodeAt: #project) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
version50MethodSourceFoo

	^(self class sourceCodeAt: #version50Foo:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: ''!
version51Umbrella: spec 
	"self reset"
	<version: '5.1'>
	
	spec for: #common do: [
		spec 
			project: 'Umbrella' with: [
				spec
					className: 'MetacelloTestConfigurationOfLinearFoo';
					versionString: '5.1';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
baseline62MethodSourceFoo

	^(self class sourceCodeAt: #baseline62Foo:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: ''!
postLoad31baselineMethodSource

	^(self class sourceCodeAt: #postLoad31baseline) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: ''!
setUpConfigurationOfProjectIssue86
    "self reset"

    | reference className definitionArray |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue86-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: className)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self linearProjectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline60ProjectIssue86:'
        category: 'cat'
        timeStamp: ''
        source: self baseline60MethodSourceProjectIssue86).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline61ProjectIssue86:'
        category: 'cat'
        timeStamp: ''
        source: self baseline61MethodSourceProjectIssue86).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline62ProjectIssue86:'
        category: 'cat'
        timeStamp: ''
        source: self baseline62MethodSourceProjectIssue86)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #())! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
projectClassMethodSource

	^(self class class sourceCodeAt: #project) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
baseline60MethodSourceFoo

	^(self class sourceCodeAt: #baseline60Foo:) asString! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
setUpConfigurationOfLinearFoo
    "self reset"

    | reference className definitionArray |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfLinearFoo-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: className)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self linearProjectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline20Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline20MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'version20Foo:'
        category: 'cat'
        timeStamp: ''
        source: self version20MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'version50Foo:'
        category: 'cat'
        timeStamp: ''
        source: self version50MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'version51Foo:'
        category: 'cat'
        timeStamp: ''
        source: self version51MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline60Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline60MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline61Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline61MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline62Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline62MethodSourceFoo)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #())! !

!MetacelloAtomicConfigurationResource methodsFor: 'running' stamp: ''!
setUpMonticelloRepository
	"This method builds a fake repository with the version references from #buildReferences."
	"self reset"

	monticelloRepository := MCDictionaryRepository new.! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
version50Foo: spec 
	"self reset"
	<version: '5.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec blessing: #release.
		spec 
			package: 'GoferUmbrella' with: 'GoferUmbrella-dkh.4';
			yourself ].! !

!MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: ''!
baseline20Foo: spec 
	"self reset"
	<version: '2.0-baseline'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec blessing: #baseline.
		spec 
			package: 'GoferBar';
			package: 'GoferFoo';
			package: 'GoferBeau';
			package: 'GoferFaux';
			yourself ].! !

!MetacelloAtomicConfigurationResource class methodsFor: 'accessing' stamp: ''!
project

	^self new project! !

!MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: ''!
loadAtomicLoadDirective: aLoaderDirective gofer: aGofer

	aLoaderDirective loadDirectives do: [:directive | directive loadUsing: self gofer: aGofer ].! !

!MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: ''!
preloads

	preloads == nil ifTrue: [ preloads := OrderedCollection new ].
	^ preloads! !

!MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: ''!
loadUsing: aLoaderDirective gofer: aGofer

	self loadDirectives isEmpty ifTrue: [ ^self ].
	aLoaderDirective loadAtomicLoadDirective: self gofer: aGofer.! !

!MetacelloAtomicLoadDirective methodsFor: 'enumerating' stamp: ''!
prepostLoadDirectivesDo: aBlock

	self preloads do: [:directive | directive prepostLoadDirectivesDo: aBlock ].
	self loadDirectives do: [:directive | directive prepostLoadDirectivesDo: aBlock ].
	self postloads do: [:directive | directive prepostLoadDirectivesDo: aBlock ].! !

!MetacelloAtomicLoadDirective methodsFor: 'loading' stamp: ''!
loadPreloadDirective: aPreloadDirective 
	"accumulate preloads"

	self preloads add: aPreloadDirective! !

!MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: ''!
packageloads: anObject
	packageloads := anObject! !

!MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: ''!
loadLinearLoadDirective: aLoaderDirective gofer: aGofer

	self finalizeLoad: aGofer.
	super loadLinearLoadDirective: aLoaderDirective gofer: aGofer! !

!MetacelloAtomicLoadDirective methodsFor: 'enumerating' stamp: ''!
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: 'accessing' stamp: ''!
packageloads

	packageloads == nil ifTrue: [ packageloads := OrderedCollection new ].
	^ packageloads! !

!MetacelloAtomicLoadDirective methodsFor: 'loading' stamp: ''!
loadPostloadDirective: aPostloadDirective
	"accumulate postloads"

	self postloads add: aPostloadDirective! !

!MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: ''!
postloads

	postloads == nil ifTrue: [ postloads := OrderedCollection new ].
	^ postloads! !

!MetacelloAtomicLoadDirective methodsFor: 'loading' stamp: ''!
loadPackageDirective: aPackageLoadDirective gofer: aGofer
	"accumulate packages"
	
	self packageloads add: aPackageLoadDirective! !

!MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: ''!
finalizeLoad: aGofer
	"load the accumulated packages (if any), reset the package list"

	| pkgLoads |
	self preloads do: [:directive | super loadPreloadDirective: directive ].
	preloads := nil.
	(pkgLoads := self packageloads) notEmpty 
		ifTrue: [
			self loader loadingSpecLoader 
				loadPackageDirectives: pkgLoads 
				gofer: aGofer.
			self packageloads: nil ].
	self postloads do: [:directive | super loadPostloadDirective: directive ].
	postloads := nil! !

!MetacelloAtomicLoadDirective methodsFor: 'enumerating' stamp: ''!
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: 'accessing' stamp: ''!
title

	^'atomic load'! !

!MetacelloAtomicMonticelloResource methodsFor: 'accessing' stamp: ''!
versionReferences
	^ versionReferences! !

!MetacelloAtomicMonticelloResource methodsFor: 'accessing' stamp: ''!
monticelloRepository
	^ monticelloRepository! !

!MetacelloAtomicMonticelloResource methodsFor: 'running' stamp: ''!
setUpDependency
	"self reset"

	| reference |
	reference := GoferVersionReference name: 'GoferUmbrella-dkh.4'.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: (Array
				with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol))
				with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: '')))
		dependencies: (Array 
				with: (MCVersionDependency 
						package: (MetacelloTestsMCPackage new name: 'GoferBarDependency') 
						info: (monticelloRepository versionInfoFromVersionNamed: 'GoferBarDependency-lr.30')) 
				with: (MCVersionDependency 
						package: (MetacelloTestsMCPackage new name: 'GoferFooDependency') 
						info: (monticelloRepository versionInfoFromVersionNamed: 'GoferFooDependency-lr.30'))))! !

!MetacelloAtomicMonticelloResource methodsFor: 'running' stamp: ''!
setUpVersionReferences
	"self reset"

	versionReferences := OrderedCollection new.
	versionReferences
		add: ((GoferVersionReference name: 'GoferFan-dkh.1') -> #GoferFar);
		add: ((GoferVersionReference name: 'GoferBar-dkh.1') -> #Object);
		add: ((GoferVersionReference name: 'GoferFoo-dkh.4') -> #GoferBeau);
		add: ((GoferVersionReference name: 'GoferFoo-dkh.5') -> #GoferBeau);
		add: ((GoferVersionReference name: 'GoferBeau-dkh.15') -> #GoferBar);
		add: ((GoferVersionReference name: 'GoferFaux-tg.30') -> #Object);
		add: ((GoferVersionReference name: 'GoferFar-dkh.4') -> #GoferFoo);
		add: ((GoferVersionReference name: 'GoferBarDependency-dkh.4') -> #Object);
		add: ((GoferVersionReference name: 'GoferFooDependency-lr.4') -> #Object);
		add: ((GoferVersionReference name: 'GoferBarDependency-lr.30') -> #Object);
		add: ((GoferVersionReference name: 'GoferFooDependency-lr.30') -> #Object);
		add: ((GoferVersionReference name: 'GoferBarDependency-lr.35') -> #Object);
		add: ((GoferVersionReference name: 'GoferFooDependency-lr.35') -> #Object);
		yourself! !

!MetacelloAtomicMonticelloResource methodsFor: 'running' stamp: ''!
setUpMonticelloRepository
	"This method builds a fake repository with the version references from #buildReferences."

	monticelloRepository := MCDictionaryRepository new.
	versionReferences do: [ :assoc | | reference superclassName |
		reference := assoc key.
		superclassName := assoc value.
		monticelloRepository basicStoreVersion: (MCVersion new
			setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
			info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
			snapshot: (MCSnapshot fromDefinitions: (Array
				with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol))
				with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: superclassName category: reference packageName asSymbol instVarNames: #() comment: '')))
			dependencies: #()) ]! !

!MetacelloAtomicMonticelloResource methodsFor: 'running' stamp: ''!
setUpNewerDependency
	"self reset"

	| reference |
	reference := GoferVersionReference name: 'GoferUmbrella-lr.5'.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: (Array
				with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol))
				with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: '')))
		dependencies: (Array 
				with: (MCVersionDependency 
						package: (MetacelloTestsMCPackage new name: 'GoferBarDependency') 
						info: (monticelloRepository versionInfoFromVersionNamed: 'GoferBarDependency-lr.35')) 
				with: (MCVersionDependency 
						package: (MetacelloTestsMCPackage new name: 'GoferFooDependency') 
						info: (monticelloRepository versionInfoFromVersionNamed: 'GoferFooDependency-lr.35'))))! !

!MetacelloAtomicMonticelloResource methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self
		setUpVersionReferences;
		setUpMonticelloRepository;
		setUpDependency;
		setUpNewerDependency! !

!MetacelloBaseConfiguration commentStamp: ''!
You should be using ConfigurationOf instead of MetacelloBaseConfiguration. 

The class is being kept around because many extant Metacello configurations use MetacelloBaseConfiguration as a sentinel class to indicate whether or not Metacello is loaded..

Once the Metacello scripting API becomes prevalent (the api has it's own ensureMetacello logic) this class can be removed.!
!MetacelloBaselineConstructor commentStamp: ''!
##MetacelloBaselineConstructor

**MetacelloBaselineConstructor** extracts the #baseline pragma from a **BaselineOfConfiguration** and produces a **MetacelloVersion**:.

```Smalltalk
MetacelloBaselineConstructor on: BaselineOfExample
```
!
!MetacelloBaselineConstructor methodsFor: 'pragma extraction' stamp: ''!
extractBaselinePragmaFor: aClass
    | pragmas |
    pragmas := Pragma allNamed: #'baseline' in: aClass.
    pragmas isEmpty
        ifTrue: [ ^ self error: 'No #baseline pragma found' ].
    ^ pragmas first! !

!MetacelloBaselineConstructor methodsFor: 'private' stamp: ''!
calculate: aConfig project: aProject
    | pragma versionMap versionSpec |
    self configuration: aConfig.
    pragma := self extractBaselinePragmaFor: aConfig class.
    self
        setProject:
            (aProject
                ifNil: [ 
                    [ aConfig class project ]
                        on: MessageNotUnderstood
                        do: [ :ex | ex return: nil ] ]).
    versionSpec := self project versionSpec.
    self root: versionSpec.
    self evaluatePragma: pragma.
    versionMap := Dictionary new.
    self project attributes
        do: [ :attribute | 
            | blockList |
            (blockList := self attributeMap at: attribute ifAbsent: [  ]) ~~ nil
                ifTrue: [ blockList do: [ :block | self with: versionSpec during: block ] ] ].
    versionSpec versionString: self project singletonVersionName.
    versionMap at: versionSpec versionString put: versionSpec createVersion.
    self project map: versionMap.
    self project configuration: aConfig! !

!MetacelloBaselineConstructor methodsFor: '*metacello-mc-accessing' stamp: ''!
projectClass
    ^ MetacelloMCBaselineProject! !

!MetacelloBaselineConstructor methodsFor: 'initialization' stamp: ''!
on: aConfig
    self calculate: aConfig project: nil! !

!MetacelloBaselineConstructor methodsFor: 'initialization' stamp: ''!
on: aConfig project: aProject
    self calculate: aConfig project: aProject! !

!MetacelloBaselineConstructor class methodsFor: 'instance creation' stamp: ''!
on: aConfig
    ^ self new
        on: aConfig;
        yourself! !

!MetacelloBaselineConstructor class methodsFor: 'instance creation' stamp: ''!
on: aConfig project: aProject
    ^ self new
        on: aConfig project: aProject;
        yourself! !

!MetacelloBaselineOfMethodSpec methodsFor: 'method generation' stamp: ''!
methodSource
  | strm |
  strm := WriteStream on: String new.
  self methodSelectorAndPragma: self selector imports: self imports 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! !

!MetacelloBaselineOfMethodSpec methodsFor: 'accessing' stamp: ''!
versionString
  ^ MetacelloMCBaselineProject singletonVersionName! !

!MetacelloBaselineOfMethodSpec methodsFor: 'method generation' stamp: ''!
methodSelectorAndPragma: aSelector imports: importList on: strm
  strm
    nextPutAll: aSelector asString , ' spec';
    cr;
    tab;
    nextPutAll: '<baseline>'! !

!MetacelloBaselineSpecGenerator methodsFor: 'accessing' stamp: ''!
projectSpecCreationBlock
    ^ [ :projectName | {(MetacelloMCBaselineProject new baselineOfProjectSpec name: projectName)} ]! !

!MetacelloBaselineSpecGenerator methodsFor: 'accessing' stamp: ''!
projectSpecListBlock
    ^ [ MetacelloProjectRegistration baselineProjectSpecs ]! !

!MetacelloBaselineSpecGenerator methodsFor: 'accessing' stamp: ''!
projectSpecLookupBlock
    ^ [ :projectName | 
    {(MetacelloProjectRegistration
        projectSpecForClassNamed: (MetacelloScriptEngine baselineNameFrom: projectName)
        ifAbsent: [  ])} ]! !

!MetacelloBasicScriptingTestCase methodsFor: 'running' stamp: ''!
tearDownPackageList
  ^ #('ConfigurationOfExternalX' 'ConfigurationOfExternalXX' 'ConfigurationOfExternal' 'ConfigurationOfExternalXXX' 'ConfigurationOfExternalIV' 'ConfigurationOfExternalIV' 'BaselineOfExternalX' 'BaselineOfGithubRefXX' 'BaselineOfGithubRefIV' 'BaselineOfGithubRefV' 'BaselineOfGithubRefVI' 'BaselineOfGithubRefVII' 'BaselineOfExternal' 'BaselineOfExternalX' 'External-CoreX' 'Sample-CoreX' 'ConfigurationOfMetacelloExample' 'GoferFoo' 'Sample-Core' 'Sample-Platform' 'Sample-Tests' 'External-Core' 'ExternalCore' 'External-Tests' 'BaselineOfGithubRefVIII' 'BaselineOfGithubRefIX' 'MarianosImage' 'BaselineOfGithubRefXI' 'BaselineOfGithubRefXII' 'BaselineOfGithubRefXIII')! !

!MetacelloBasicScriptingTestCase methodsFor: 'running' stamp: ''!
configurationRepositoryContents
  ^ #('ConfigurationOfExternalX-dkh.1' 'ConfigurationOfExternalXX-dkh.1' 'ConfigurationOfExternalXXX-dkh.1' 'ConfigurationOfExternalIV-dkh.1' 'MarianosImage-dkh.1')! !

!MetacelloBasicScriptingTestCase methodsFor: 'running' stamp: ''!
sampleRepositoryContents
  ^ #('Sample-CoreX-dkh.1')! !

!MetacelloBasicScriptingTestCase methodsFor: 'running' stamp: ''!
externalRepositoryContents
  ^ #('External-CoreX-dkh.1' 'BaselineOfExternalX-dkh.1' 'BaselineOfGithubRefXX-dkh.1' 'BaselineOfGithubRefIV-dkh.1' 'BaselineOfGithubRefV-dkh.1' 'BaselineOfGithubRefVI-dkh.1' 'BaselineOfGithubRefVII-dkh.1' 'BaselineOfGithubRefVIII-dkh.1' 'BaselineOfGithubRefIX-dkh.1' 'BaselineOfGithubRefXI-dkh.1' 'BaselineOfGithubRefXII-dkh.1' 'BaselineOfGithubRefXIII-dkh.1')! !

!MetacelloBasicScriptingTestCase methodsFor: 'running' stamp: ''!
setUpRepositoryContents
  super setUpRepositoryContents.
  self
    setUpRepositoryContents: self configurationRepositoryContents
    sourceRepo: MetacelloScriptingResource current configurationRepository
    targetRepo: (MCFileTreeRepository new directory: configurationDirectory).
  self
    setUpRepositoryContents: self externalRepositoryContents
    sourceRepo: MetacelloScriptingResource current externalRepository
    targetRepo: (MCFileTreeRepository new directory: externalDirectory).
  self
    setUpRepositoryContents: self sampleRepositoryContents
    sourceRepo: MetacelloScriptingResource current sampleRepository
    targetRepo: (MCFileTreeRepository new directory: sampleDirectory)! !

!MetacelloCachingGoferResolvedReference methodsFor: 'querying' stamp: ''!
workingCopy
	"Answer a working copy or throw an error if not present."

	| pName |
	cachedVersion == nil ifTrue: [ ^super workingCopy ].
	pName := cachedVersion package name.
	^MCWorkingCopy allManagers
		detect: [ :each | pName = each packageName ]
		ifNone: [ self error: 'Working copy for ' , self name , ' not found' ]! !

!MetacelloCachingGoferResolvedReference methodsFor: 'accessing' stamp: ''!
version
	"Answer a Monticello version of the receiver."

	cachedVersion == nil ifTrue: [ cachedVersion := super version ].
	^cachedVersion! !

!MetacelloCannotUpdateReleasedVersionError methodsFor: 'private' stamp: ''!
isResumable
	"Determine whether an exception is resumable."

	^ true! !

!MetacelloCleanNotification methodsFor: 'accessing' stamp: ''!
version: anObject
	version := anObject! !

!MetacelloCleanNotification methodsFor: 'signaling' stamp: ''!
signal: aMetacelloVersion

	self version: aMetacelloVersion.
	^ self signal! !

!MetacelloCleanNotification methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!MetacelloCleanNotification class methodsFor: 'exceptioninstantiator' stamp: ''!
signal: aMetacelloVersion

	^ self new signal: aMetacelloVersion! !

!MetacelloClearStackCacheNotification methodsFor: 'accessing' stamp: ''!
cacheNames: anArray
	cacheNames := anArray! !

!MetacelloClearStackCacheNotification methodsFor: 'accessing' stamp: ''!
cacheNames
	^ cacheNames! !

!MetacelloClearStackCacheNotification methodsFor: 'signaling' stamp: ''!
signal: anArray
	"Signal the occurrence of an exceptional condition with a specified cacheName."

	self cacheNames: anArray.
	^ self signal! !

!MetacelloCommandLineHandler commentStamp: ''!
Command line handler for dealing with Metacello from the command line.

Usage:
metacello --help
metacello install <repository url> (<baseline>|<configuration>) [--version=<version>] [--groups=<group name>,...] [--no-quit] [--no-save]
	<repository url>    A Monticello repository name 
	<baseline>          A valid Metacello Baseline name
	<configuration>     A valid Metacello Configuration name
	<version>           A valid version for the given Configuration (incompatible with Baseline)
	<group name>        A valid Metacello group name(s)
	--help              Show this help message
	--no-quit           Keep the image running after Baseline/Configuration install
	--no-save           Don't save the image after Baseline/Configuration install
	
Examples:
	# Display this help message
	pharo Pharo.image metacello OR pharo Pharo.image metacello --help
	
	# Install group 'Core' and 'Tests' of latest version
	pharo Pharo.image metacello install $REPOS_URL BaselineOfFoo --groups=Core,Tests
	
	# Install a specific version '1.5' and only a specific group 'Tests'
	pharo Pharo.image metacello install $REPOS_URL ConfigurationOfFoo --version=1.5 --groups=Tests
	
	!
!MetacelloCommandLineHandler methodsFor: 'activation' stamp: ''!
checkInputForInstallSubcommand
	(self isBaselineName and: [ self hasVersion ])
		ifTrue: [ Exit signalFailure: 'A baseline can not be used with --version option.' ].
	
	(self isBaselineName or: [ self isConfigurationName ])
		ifFalse: [ Exit signalFailure: 'Not a Baseline nor a Configuration.' ]! !

!MetacelloCommandLineHandler methodsFor: 'activation' stamp: ''!
install
	| metacello |
	metacello := Metacello new.
	self isBaselineName
		ifTrue: [ metacello baseline: self baselineOrConfigurationNameSuffix ].
	self isConfigurationName
		ifTrue: [ metacello configuration: self baselineOrConfigurationNameSuffix ].
	metacello repository: self repositoryUrl.
	self hasVersion
		ifTrue: [ metacello version: self version ].
	self hasGroups
		ifTrue: [ metacello load: self groups ]
		ifFalse: [ metacello load ]! !

!MetacelloCommandLineHandler methodsFor: 'accessing' stamp: ''!
availableSubCommands
	^ #('install')! !

!MetacelloCommandLineHandler methodsFor: 'activation' stamp: ''!
postInstall
	Smalltalk snapshot: self shouldSave andQuit: self shouldQuit! !

!MetacelloCommandLineHandler methodsFor: 'accessing' stamp: ''!
subCommand
	| firstArg |
	firstArg := self argumentAt: 1.
	self checkSubCommand: firstArg.
	^ firstArg! !

!MetacelloCommandLineHandler methodsFor: 'accessing' stamp: ''!
noSave
	^ self hasOption: 'no-save'! !

!MetacelloCommandLineHandler methodsFor: 'testing' stamp: ''!
isConfigurationName
	^ self baselineOrConfigurationName matchesRegex: 'ConfigurationOf.+'! !

!MetacelloCommandLineHandler methodsFor: 'testing' stamp: ''!
hasGroups
	^ self hasOption: 'groups'! !

!MetacelloCommandLineHandler methodsFor: 'accessing' stamp: ''!
baselineOrConfigurationNameSuffix
	self isBaselineName
		ifTrue: [ ^ self baselineOrConfigurationName copyFrom: 'BaselineOf' size + 1 to: self baselineOrConfigurationName size ].
		
	self isConfigurationName
		ifTrue: [ ^ self baselineOrConfigurationName copyFrom: 'ConfigurationOf' size + 1 to: self baselineOrConfigurationName size ]! !

!MetacelloCommandLineHandler methodsFor: 'testing' stamp: ''!
hasVersion
	^ self hasOption: 'version'! !

!MetacelloCommandLineHandler methodsFor: 'accessing' stamp: ''!
baselineOrConfigurationName
	^ self argumentAt: 3! !

!MetacelloCommandLineHandler methodsFor: 'accessing' stamp: ''!
noQuit
	^ self hasOption: 'no-quit'! !

!MetacelloCommandLineHandler methodsFor: 'accessing' stamp: ''!
repositoryUrl
	^ self argumentAt: 2! !

!MetacelloCommandLineHandler methodsFor: 'testing' stamp: ''!
shouldSave
	^ self noSave not! !

!MetacelloCommandLineHandler methodsFor: 'accessing' stamp: ''!
version
	^ self optionAt: 'version'! !

!MetacelloCommandLineHandler methodsFor: 'accessing' stamp: ''!
groups
	^ (self optionAt: 'groups') splitOn: $,! !

!MetacelloCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self activateHelpWithoutArguments
		ifTrue: [ ^ self ].
	self subCommand = 'install'
		ifTrue: [ 
			self
				checkInputForInstallSubcommand;
				install;
				postInstall ]! !

!MetacelloCommandLineHandler methodsFor: 'testing' stamp: ''!
isBaselineName
	^ self baselineOrConfigurationName matchesRegex: 'BaselineOf.+'! !

!MetacelloCommandLineHandler methodsFor: 'testing' stamp: ''!
shouldQuit
	^ self noQuit not! !

!MetacelloCommandLineHandler methodsFor: 'argument validation' stamp: ''!
checkSubCommand: aString 
	(self availableSubCommands includes: aString)
		ifFalse: [
			self exitFailure: ('{1} subcommand does not exists' format: { aString }) ]! !

!MetacelloCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'metacello'! !

!MetacelloCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Install and inspect Metacello Baselines/Configurations from the command line'! !

!MetacelloCommandLineHandlerTest commentStamp: ''!
A MetacelloCommandLineHandlerTest is a test class for testing the behavior of MetacelloCommandLineHandler!
!MetacelloCommandLineHandlerTest methodsFor: 'tests - testing' stamp: ''!
testShouldQuit
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self
		deny: cli noQuit;
		assert: cli shouldQuit.
	
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper' '--no-quit').
	self
		assert: cli noQuit;
		deny: cli shouldQuit! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - accessing' stamp: ''!
testSubCommand
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self assert: cli subCommand equals: 'install'.
	
	cli := self command: #('foo' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self should: [ cli subCommand ] raise: Exit! !

!MetacelloCommandLineHandlerTest methodsFor: 'convenience' stamp: ''!
argumentsWith: aCollection
	^ CommandLineArguments withArguments: aCollection! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - testing' stamp: ''!
testHasVersion
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper' '--version=stable').
	self assert: cli hasVersion.
	
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self deny: cli hasVersion.! !

!MetacelloCommandLineHandlerTest methodsFor: 'convenience' stamp: ''!
command: arguments
	^ MetacelloCommandLineHandler commandLine: (self argumentsWith: arguments)! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - accessing' stamp: ''!
testRepositoryUrl
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self assert: cli repositoryUrl equals: 'github://juliendelplanque/MineSweeper/repository'.! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - accessing' stamp: ''!
testBaselineOrConfigurationNameSuffix
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self assert: cli baselineOrConfigurationNameSuffix equals: 'MineSweeper'.
	
	cli := self command: #('install' 'http://ss3.gemstone.com/ss/MetaRepoForPharo20' 'ConfigurationOfFoo').
	self assert: cli baselineOrConfigurationNameSuffix equals: 'Foo'.! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - activation' stamp: ''!
testCheckInputForInstallSubcommand
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper' '--version=master').
	self should: [ cli checkInputForInstallSubcommand ] raise: Exit.
	
	cli := self command: #('install' 'http://ss3.gemstone.com/ss/MetaRepoForPharo20' 'Foo').
	self should: [ cli checkInputForInstallSubcommand ] raise: Exit.! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - testing' stamp: ''!
testIsConfigurationName
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self deny: cli isConfigurationName.
	
	cli := self command: #('install' 'http://ss3.gemstone.com/ss/MetaRepoForPharo20' 'ConfigurationOfFoo').
	self assert: cli isConfigurationName.! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - testing' stamp: ''!
testShouldSave
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self
		deny: cli noSave;
		assert: cli shouldSave.
		
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper' '--no-save').
	self
		assert: cli noSave;
		deny: cli shouldSave! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - accessing' stamp: ''!
testVersion
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper' '--version=stable').
	self assert: cli version equals: 'stable'! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - testing' stamp: ''!
testHasGroups
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper' '--groups=core,tests').
	self assert: cli hasGroups.
	
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self deny: cli hasGroups.! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - testing' stamp: ''!
testIsBaselineName
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self assert: cli isBaselineName.
	
	cli := self command: #('install' 'http://ss3.gemstone.com/ss/MetaRepoForPharo20' 'ConfigurationOfFoo').
	self deny: cli isBaselineName.! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - accessing' stamp: ''!
testGroups
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper' '--groups=core,tests').
	self assertCollection: cli groups hasSameElements: #('core' 'tests')! !

!MetacelloCommandLineHandlerTest methodsFor: 'tests - accessing' stamp: ''!
testBaselineOrConfigurationName
	| cli |
	cli := self command: #('install' 'github://juliendelplanque/MineSweeper/repository' 'BaselineOfMineSweeper').
	self assert: cli baselineOrConfigurationName equals: 'BaselineOfMineSweeper'.
	
	cli := self command: #('install' 'http://ss3.gemstone.com/ss/MetaRepoForPharo20' 'ConfigurationOfFoo').
	self assert: cli baselineOrConfigurationName equals: 'ConfigurationOfFoo'.! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
shouldDisablePackageCache: anObject
	disablePackageCache := anObject! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
loaderPolicy

	loaderPolicy == nil ifTrue: [ loaderPolicy := MetacelloLoaderPolicy new ].
	^loaderPolicy! !

!MetacelloCommonMCSpecLoader methodsFor: 'versionInfo' stamp: ''!
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: 'actions' stamp: ''!
doingLoads: aBlock
	"escape mechanism for recording and null loaders to skip doing loaderlike things"
	
	aBlock value! !

!MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: ''!
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 ] ].
     MetacelloNotification signal: 'Starting atomic load'.
      loadBlock := [ 
      "pkgLoads do: [:packageLoadDirective |  mcLoader preLoad: packageLoadDirective spec ]."
      goferLoad execute.
      pkgLoads
        do: [ :packageLoadDirective | 
          packageLoadDirective resolvedReference == nil
            ifTrue: [ 
					MetacelloNotification signal: ('Already Loaded -> ' , packageLoadDirective file) level: 2]
            ifFalse: [ 
            		MetacelloNotification signal: ('Loaded -> ' , packageLoadDirective file , ' --- '
                        , packageLoadDirective repository repositoryDescription
                        , ' --- '
                        ,
                          packageLoadDirective resolvedReference repository description) level: 2.
              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 ].
      MetacelloNotification signal: 'Finished atomic load' ]
    displaying: 'Atomic Load...'! !

!MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: ''!
linearLoadPackageSpec: packageSpec gofer: gofer

	self subclassResponsibility! !

!MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: ''!
doLoad

	self subclassResponsibility! !

!MetacelloCommonMCSpecLoader methodsFor: 'repositories' stamp: ''!
repositoriesFrom: aMetacelloMVRepositorySpecs

	^self repositoriesFrom: aMetacelloMVRepositorySpecs ignoreOverrides: false! !

!MetacelloCommonMCSpecLoader methodsFor: 'repositories' stamp: ''!
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: 'private' stamp: ''!
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: [ 
              | spc |
              "package already loaded, don't load again"
              spc := packageSpec copy.
              spc file: info name.
              (MetacelloIgnorePackageLoaded signal: spc)
                ifFalse: [ ^ nil ] ] ] ].
  ^ resolvedReference! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
loaderPolicy: anObject
	loaderPolicy := anObject! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
recordingSpecLoader

	^(MetacelloNullRecordingMCSpecLoader on: self spec)
		shouldDisablePackageCache: self shouldDisablePackageCache;
		loaderPolicy: self loaderPolicy copy;
		yourself! !

!MetacelloCommonMCSpecLoader methodsFor: 'private' stamp: ''!
retryingResolvePackageSpecReferences: packageSpec gofer: gofer
    | retryCount references repositoryError |
    retryCount := 0.
    references := #().
    [ references isEmpty and: [ retryCount < 3 ] ]
        whileTrue: [ 
            retryCount > 0
                ifTrue: [ 
                    MetacelloNotification signal: '...RETRY->' , packageSpec file ].
            references := [ self resolvePackageSpecReferences: packageSpec gofer: gofer ]
                on: Error , GoferRepositoryError
                do: [ :ex | 
                    self class retryPackageResolution
                        ifFalse: [ ex pass ].
                    retryCount >= 2
                        ifTrue: [ 
                            (ex isKindOf: GoferRepositoryError)
                                ifTrue: [ 
                                    "ignore repository errors at this point, in case an alternate repository is in the list "
                                   MetacelloNotification signal: 'gofer repository error: ' , ex description printString , '...ignoring'.
                                    repositoryError := ex.
                                    ex resume: #() ]
                                ifFalse: [ ex pass ] ].
                    ex return: #() ].
            retryCount := retryCount + 1 ].
    references isEmpty
        ifTrue: [ 
            MetacelloNotification signal: '...FAILED->' , packageSpec file.
            (MetacelloPackageSpecResolutionError new
                packageSpec: packageSpec;
                repositories: gofer repositories;
                repositoryError: repositoryError;
                yourself) signal ].
    ^ references! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
operator: aSymbol

	operator := aSymbol! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
fetchingSpecLoader

	^self! !

!MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: ''!
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: 'initialization' stamp: ''!
initialize

	self loaderPolicy! !

!MetacelloCommonMCSpecLoader methodsFor: 'private' stamp: ''!
linearLoadPackageSpecs: packageSpecs repositories: repositories
	
	| gofer |
	gofer := MetacelloGofer new.
	repositories do: [:repo | gofer repository: repo ].
	packageSpecs do: [:pkg | pkg loadUsing: self gofer: gofer ].! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
shouldDisablePackageCache

	disablePackageCache == nil ifTrue: [ disablePackageCache := false ].
	^ disablePackageCache! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
operator

	operator == nil ifTrue: [ ^#= ].
	^operator! !

!MetacelloCommonMCSpecLoader methodsFor: 'versionInfo' stamp: ''!
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: 'doits' stamp: ''!
postLoad: packageOrVersionSpec
	"subclassResponsibility, but it gets called during an upgrade, so leave it as NOOP"! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
ensureSpecLoader
	^ self! !

!MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: ''!
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 ifNil: [ "Package version already loaded into image" ^ self ].
			loadBlock := [ "mcLoader preLoad: packageSpec."
			goferLoad := MetacelloGoferLoad on: aGofer.
			goferLoad addResolved: resolvedReference.
			goferLoad execute.
			MetacelloPlatform current clearCurrentVersionCache	"mcLoader postLoad: packageSpec"
			].
			MetacelloNotification signal:
					'Loading -> ' , resolvedReference name , ' --- '
						, aPackageLoadDirective repository repositoryDescription , ' --- '
						, resolvedReference repository description.
			( answers := packageSpec answers ) notEmpty
				ifTrue: [ loadBlock valueSupplyingMetacelloAnswers: answers ]
				ifFalse: [ loadBlock value ].
			resolvedReference workingCopy repositoryGroup addRepository: aPackageLoadDirective repository.
			MetacelloNotification signal:
					'Loaded -> ' , resolvedReference name , ' --- '
						, aPackageLoadDirective repository repositoryDescription , ' --- '
						, resolvedReference repository description
			]
		displaying: 'Loading ' , packageSpec file! !

!MetacelloCommonMCSpecLoader methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
ignoreImage

	^self loaderPolicy ignoreImage! !

!MetacelloCommonMCSpecLoader methodsFor: 'doits' stamp: ''!
preLoad: packageOrVersionSpec

	self subclassResponsibility! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
loadingSpecLoader

	^self! !

!MetacelloCommonMCSpecLoader methodsFor: 'testing' stamp: ''!
ensureForDevelopment
  ^ true! !

!MetacelloCommonMCSpecLoader methodsFor: 'testing' stamp: ''!
hasRepositoryOverrides

	^self loaderPolicy hasRepositoryOverrides! !

!MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: ''!
repositoryMap

	^self loaderPolicy repositoryMap! !

!MetacelloCommonMCSpecLoader methodsFor: 'packages' stamp: ''!
nameComponentsFrom: aVersionName

	^self class nameComponentsFrom: aVersionName! !

!MetacelloCommonMCSpecLoader class methodsFor: 'accessing' stamp: ''!
retryPackageResolution: aBool
    RetryPackageResolution := aBool! !

!MetacelloCommonMCSpecLoader class methodsFor: 'utilities' stamp: ''!
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! !

!MetacelloCommonMCSpecLoader class methodsFor: 'accessing' stamp: ''!
retryPackageResolution
    "if true, 
		errors during #retryingResolvePackageSpecReferences:gofer: are caught and 
		the resolution is retried 3 times. After the thrid time, a MetacelloPackageSpecResolutionError
		is thrown
	if false,
		an error during #retryingResolvePackageSpecReferences:gofer: will be passed,
		likely resulting in a walkback ... useful for debugging."

    RetryPackageResolution ifNil: [ RetryPackageResolution := true ].
    ^ RetryPackageResolution! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests - alpha/numeric version numbers' stamp: ''!
testAlphaNumericVersion3

	self assert: ((self versionClass fromString: '2.9.9-alpha.2') < (self versionClass fromString: '2.9.10')).! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests - alpha/numeric version numbers' stamp: ''!
testAlphaNumericVersion2

	self assert: ((self versionClass fromString: '2.9.0-alpha.2') < (self versionClass fromString: '2.9.0-alpha.3')).! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion23
	self assert: (MetacelloVersionNumber fromString: '3.0.0.-rc.1') equals: (MetacelloVersionNumber fromString: '3.0.0-rc.1').
	self assert: (MetacelloVersionNumber fromString: '3.0') > (MetacelloVersionNumber fromString: '3.0-rc.1').
	self assert: (MetacelloVersionNumber fromString: '3') > (MetacelloVersionNumber fromString: '3-rc.1').
	self assert: (MetacelloVersionNumber fromString: '3.-rc.1') equals: (MetacelloVersionNumber fromString: '3.0.0-rc.1').
	self assert: (MetacelloVersionNumber fromString: '3.0.-rc.1') equals: (MetacelloVersionNumber fromString: '3.0.0-rc.1').
	self assert: (MetacelloVersionNumber fromString: '3') > (MetacelloVersionNumber fromString: '3.0-rc.1').
	self assert: (MetacelloVersionNumber fromString: '3.0') > (MetacelloVersionNumber fromString: '3.0.0-rc.1')! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion25

	self assert: ((MetacelloVersionNumber fromString: '1.0-beta.24.0.1') < (MetacelloVersionNumber fromString: '1.0-beta.28')).! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion02
	| v1 v2 |
	v1 := self versionClass fromString: '1.1.1'.
	v2 := self versionClass fromString: '1.0.0'.
	self assert: v1 equals: v1.
	self assert: v2 equals: v2.
	self assert: v1 > v2! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion14

	self assert: ((self versionClass fromString: '2.9.0-alpha02') < (self versionClass fromString: '2.9.0-alpha03')).! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion04

	| v1 v2 |
	v1 := self versionClass fromString: '1.0.1'.
	v2 := self versionClass fromString: '1.0.0'.
	self assert: (v1 > v2)! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests - alpha/numeric version numbers' stamp: ''!
testAlphaNumericVersion4

	self assert: ((self versionClass fromString: '2.9.9-alpha.2') < (self versionClass fromString: '2.9.9')).! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests - version increment/decrement' stamp: ''!
testIncrementDecrementVersion
	| version |
	version := self defaultVersion1.
	self assert: version incrementMajorVersion asString equals: '2.0.0'.
	self assert: version decrementMajorVersion asString equals: '1.0.0'.
	self assert: version incrementMinorVersion asString equals: '1.1.0'.
	self assert: version decrementMinorVersion asString equals: '1.0.0'.
	self assert: version incrementPatchVersion asString equals: '1.0.1'.
	self assert: version decrementPatchVersion asString equals: '1.0.0'! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion22
	self assert: (MetacelloVersionNumber fromString: '3.0.0') collapseZeros size equals: 1.
	self assert: (MetacelloVersionNumber fromString: '3.0.0') equals: (MetacelloVersionNumber fromString: '3.0').
	self assert: (MetacelloVersionNumber fromString: '3.0') equals: (MetacelloVersionNumber fromString: '3.0.0')! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests - version increment/decrement' stamp: ''!
testIncrementDecrementVersionNumber
	| version |
	version := self defaultVersion1.
	self assert: version incrementMinorVersionNumber asString equals: '1.0.1'.
	self assert: version decrementMinorVersionNumber asString equals: '1.0.0'! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion01
	self assert: (self versionClass fromString: '1.1.1') versionString equals: '1.1.1'! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'tests - alpha/numeric version numbers' stamp: ''!
testAlphaNumericVersion1

	"Use numeric comparison for pure numbers. If you non-numeric version separate with '-'"
	
	| x y |
	self assert: ((x := self versionClass fromString: '2.9.0') < (y := self versionClass fromString: '2.10.0')).! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'private' stamp: ''!
versionClass
    ^ self subclassResponsibility! !

!MetacelloCommonVersionNumberTestCase methodsFor: 'private' stamp: ''!
defaultVersion1
  ^ self versionClass fromString: '1.0.0'! !

!MetacelloCommonVersionNumberTestCase class methodsFor: 'testing' stamp: ''!
isAbstract
    "Override to true if a TestCase subclass is Abstract and should not have
	TestCase instances built from it"

    ^ self name = #'MetacelloCommonVersionNumberTestCase'! !

!MetacelloConfigTemplate commentStamp: ''!
Copy me to create a new configuration or edit and evaluate the following doits.

        "Create configuration class and initial baseline method"

        MetacelloToolBox 
                createBaseline: '1.0-baseline'
                for: 'MyProject'
                repository: 'http://www.example.com/MyProjectRepository'
                requiredProjects: #('Gofer')
                packages: #('MyProject-Core' 'MyProject-Tests')
                dependencies:
                        {('MyProject-Core' -> #('Gofer')).
                         ('MyProject-Tests' -> #('MyProject-Core'))}
                groups:
                        {('default' -> #('Core')).
                        ('Core' -> #('MyProject-Core')).
                        ('Tests' -> #('MyProject-Tests'))}.

	   "create initial development method from the baseline"

         MetacelloToolBox
               createDevelopment: '1.0'
               for: 'MyProject'
                importFromBaseline: '1.0-baseline'
                description: 'initial version'.
!
!MetacelloConfigTemplate methodsFor: 'accessing' stamp: ''!
project
    ^ project
        ifNil: [ 
            "Bootstrap Metacello if it is not already loaded"
            self class ensureMetacello.
            project := MetacelloMCProject new projectAttributes: self customProjectAttributes.	"Create the Metacello project"
            (Smalltalk at: #'MetacelloVersionConstructor') on: self project: project.	"Construct the project"
            project loadType: #'linear'.	"change to #atomic if desired"
            project ]! !

!MetacelloConfigTemplate methodsFor: 'accessing' stamp: ''!
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 class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #stable) load! !

!MetacelloConfigTemplate class methodsFor: 'private' stamp: ''!
ensureMetacello

	(self baseConfigurationClassIfAbsent: []) ensureMetacello! !

!MetacelloConfigTemplate class methodsFor: 'metacello tool support' stamp: ''!
isMetacelloConfig
	"Answer true and the Metacello tools will operate on you"
	
	^true! !

!MetacelloConfigTemplate class methodsFor: 'development support' stamp: ''!
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"

	<apiDocumentation>
	self ensureMetacello.
	^ ((self environment  at: #MetacelloToolBox) validateConfiguration: self debug: #() recurse: false) inspect! !

!MetacelloConfigTemplate class methodsFor: 'accessing' stamp: ''!
project

	^self new project! !

!MetacelloConfigTemplate class methodsFor: 'development support' stamp: ''!
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."
	<apiDocumentation>! !

!MetacelloConfigTemplate class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #bleedingEdge) load! !

!MetacelloConfigTemplate class methodsFor: 'private' stamp: ''!
ensureMetacelloBaseConfiguration
  self environment 
    at: #'ConfigurationOf'
    ifAbsent: [ 
      | repository version |
      repository := MCHttpRepository
        location: 'http://smalltalkhub.com/mc/dkh/metacello/main'
        user: ''
        password: ''.
      repository
        versionReaderForFileNamed: 'Metacello-Base-dkh.107'
        do: [ :reader | 
          version := reader version.
          version load.
          version workingCopy repositoryGroup addRepository: repository ] ]! !

!MetacelloConfigTemplate class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #development) load! !

!MetacelloConfigTemplate class methodsFor: 'private' stamp: ''!
baseConfigurationClassIfAbsent: aBlock

	^self environment 
		at: #'ConfigurationOf'
		ifAbsent: [ 
			self ensureMetacelloBaseConfiguration.
			self environment  at: #'ConfigurationOf' ifAbsent: aBlock ].! !

!MetacelloConfigTemplateExample commentStamp: ''!
Copy me to create a new configuration or edit and evaluate the following doits.

        "Create configuration class and initial baseline method"

        MetacelloToolBox 
                createBaseline: '1.0-baseline'
                for: 'MyProject'
                repository: 'http://www.example.com/MyProjectRepository'
                requiredProjects: #('Gofer')
                packages: #('MyProject-Core' 'MyProject-Tests')
                dependencies:
                        {('MyProject-Core' -> #('Gofer')).
                         ('MyProject-Tests' -> #('MyProject-Core'))}
                groups:
                        {('default' -> #('Core')).
                        ('Core' -> #('MyProject-Core')).
                        ('Tests' -> #('MyProject-Tests'))}.

	   "create initial development method from the baseline"

         MetacelloToolBox
               createDevelopment: '1.0'
               for: 'MyProject'
                importFromBaseline: '1.0-baseline'
                description: 'initial version'.
!
!MetacelloConfigTemplateExample methodsFor: 'tags' stamp: ''!
stable: spec
	"Symbolic versions can be used to introduce an indirection to a version number.
	The real name used by Metacello is only defined by the following pragma:"
	<symbolicVersion: #stable >
	
	"If another version is stable for a differen Smalltalk use a specific name"
	"spec for: #'pharo1.4.x' version: '0.9'"
	
	"Specfiy which exact version you want to load"
	spec for: #'common' version: '1.0'.! !

!MetacelloConfigTemplateExample methodsFor: 'external projects' stamp: ''!
fileSystemLegacy: spec
	"This is an example of an external project which does not have a configuration yet.
	Note that the package name is only used in the Metacello configuration and does not have be exactly the same as the Monticello project/version name."
	spec package: 'FileSystemLegacy' with: [
		spec 
			repository: 'http://smalltalkhub.com/mc/PharoExtras/FileSystemLegacy/main';
			"if you do not specify a version, automatically the newest version is chose."
			file:  'FileSystem-Legacy-JohanBrichau.2' ]! !

!MetacelloConfigTemplateExample methodsFor: 'versions' stamp: ''!
version10: spec
	"The name for this version is solely defined by the following pragma:"
	<version: '1.0' imports: #('1.0-baseline') >
	"Baselines are used to define more complex setups for your project.
	If you want to use external projects and have fine-graind control of the dependencies between packages use the #imports: part.
	See the #baseline10: for more details."
	
	"Using #for:do: with the #common release specifier the following version declaration is valid for all platforms."
	spec for: #common do: [
		spec 
			description: 'Version 1.0 the current stable release';
			blessing: #release;
			author: 'John Doe';
			timestamp: '2013-05-01'.
		
		"Specify the versions for each package and external project defined in the baseline, here the 1.0-baseline defined in the baseline10 method."
		spec
			"For standard Monticello packages simply refere to the full version name without the extension:"
			package: 'MyProject-Core'  with: 'MyProject-Core-JohnDoe.52';
			package: 'MyProject-Tests' with: 'MyProject-Tests-JohnDoe.73';
			
			"External projects versions are specified using #project:with:.
			Note the project name referes to the name used in the Metacello declaration.
			FuelMetalevel is defined in the #fuelMetalevel: method."
			project: 'FuelMetalevel' with: #stable ].
		
	"If you want to specify different version on other platforms add another #for:do: block with a different version identifier."! !

!MetacelloConfigTemplateExample methodsFor: 'external projects' stamp: ''!
fuelMetalevel: spec

	"Specify a dependency on an external project which has it's own configuration.
	The given project name can be chosen freely, for simplicity use the same name as the configuration or the conditional group you load."
	spec project: 'FuelMetalevel' with: [
		spec 
			repository: 'http://ss3.gemstone.com/ss/Fuel';
			className: 'ConfigurationOfFuel';
			"if you want to load by default a special group usse the #loads: message plus a group name of the external configuration"
			loads: #FuelMetalevel ].! !

!MetacelloConfigTemplateExample methodsFor: 'accessing' stamp: ''!
project

	^ project ifNil: [ 
		"Bootstrap Metacello if it is not already loaded"
		(self class baseConfigurationClassIfAbsent: []) ensureMetacello.
		"Construct Metacello project"
		project := MetacelloMCProject new projectAttributes: self customProjectAttributes. 
		(Smalltalk at: #MetacelloVersionConstructor) on: self project: project.
		project loadType: #linear. "change to #atomic if desired"
		project ]! !

!MetacelloConfigTemplateExample methodsFor: 'versions' stamp: ''!
versionDevelopment: spec
	"version specification for the current development branch, see #version10 for a complete explanation of a version declaration.
	In this case the 'dev' version uses the same baselin as version '1.0':"
	<version: 'dev' imports: #('1.0-baseline') >
	
	"Update this configuration regulrarly with intermediate releases.
	If a version is more stable or should stay accessible copy this 'dev' definition and give it a proper version name on its own.
	For example, in this case you might want to split a new version '1.1' by copying over this definition."
	spec for: #common do: [
		spec 
			description: 'Development Version';
			blessing: #development;
			author: 'John Doe';
			timestamp: '2013-05-09'.
		
		spec
			package: 'MyProject-Core'  with: 'MyProject-Core-JohnDoe.152';
			package: 'MyProject-Tests' with: 'MyProject-Tests-JohnDoe.173';
			"note that for the 'dev' version we rely on the #development version of the external FuleMetalevel project"
			project: 'FuelMetalevel'   with: #development ].! !

!MetacelloConfigTemplateExample methodsFor: 'baselines' stamp: ''!
baseline10: spec
	"Baselines are used by convention in Metacello and essentially are nothing else than normal versions.
	Name the baseline after the first version it was introduced.
	In this case 1.0-baseline was introduced the first time with the 1.0 version defined in the #version10 method.
	Metacello only uses the following tag to figure out the name of this baseline:"
	<version: '1.0-baseline'>

	"Using #common makes this dependency declaration available for all Smalltalks.
	If you need more fine-grained control you can add several #for:do: sections for other releases."
	spec for: #common do: [	
		spec blessing: #baseline.
		"specify the default repository for your project's packages"
		spec repository: 'http://smalltalkhub.com/mc/JohnDoe/MyProject/main'.
	
		"use separate methods for external projects"
		self 
			fuelMetalevel: spec;
			fileSystemLegacy: spec.
		
		"specify the dependencies between packages and projects"
		spec
			"a package without dependencies:"
			package: 'MyProject-Core';
			package: 'MyProject-Tests' with: [ 
				"Specfiy dependencies using the #requires: directive, you can refer to any name here, in this case to an external project"
				spec requires: #('MyProject-Core' 'FuelMetalevel' 'FileSystemLegacy')].
			
		"using groups certain packages and projects can be loaded conditionally"
		spec 
			"load the tests by default"
			group: 'default' with: #('core' 'test');
			group: 'test'    with: #('MyProject-Tests');
			group: 'core'    with: #('MyProject-Core')]! !

!MetacelloConfigTemplateExample methodsFor: 'tags' stamp: ''!
development: spec
	"By convention the development branch should point to a fixed version that is regularly updated and might contain unstable code.
	The name used by Metacello is only defined by the following pragma:"
	<symbolicVersion: #development >
	
	"For the development tag refer to a fixed version which you update if you commit new code.
	Note that you can refer here to any other version name from this configuration"
	spec for: #'common' version: 'dev'.! !

!MetacelloConfigTemplateExample methodsFor: 'accessing' stamp: ''!
customProjectAttributes
	 "Edit to return a collection of any custom attributes e.g. for conditional loading: Array with: #'Condition1' with: #'Condition2.
	For more information see: http://code.google.com/p/metacello/wiki/CustomProjectAttrributes"

	^ #().! !

!MetacelloConfigTemplateExample class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #stable) load! !

!MetacelloConfigTemplateExample class methodsFor: 'private' stamp: ''!
ensureMetacello

	(self baseConfigurationClassIfAbsent: []) ensureMetacello! !

!MetacelloConfigTemplateExample class methodsFor: 'metacello tool support' stamp: ''!
isMetacelloConfig
	"Answer true and the Metacello tools will operate on you"
	
	^true! !

!MetacelloConfigTemplateExample class methodsFor: 'development support' stamp: ''!
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"

	<apiDocumentation>
	self ensureMetacello.
	^ ((self environment at: #MetacelloToolBox) validateConfiguration: self debug: #() recurse: false) inspect! !

!MetacelloConfigTemplateExample class methodsFor: 'accessing' stamp: ''!
project

	^self new project! !

!MetacelloConfigTemplateExample class methodsFor: 'development support' stamp: ''!
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."
	<apiDocumentation>! !

!MetacelloConfigTemplateExample class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #bleedingEdge) load! !

!MetacelloConfigTemplateExample class methodsFor: 'private' stamp: ''!
ensureMetacelloBaseConfiguration

	self environment 
		at: #MetacelloBaseConfiguration
		ifAbsent: [ 
			| repository version |
			repository := MCHttpRepository location: 'http://seaside.gemstone.com/ss/metacello' user: '' password: ''.
			repository
				versionReaderForFileNamed: 'Metacello-Base-DaleHenrichs.2.mcz'
				do: [ :reader | 
					version := reader version.
					version load.
					version workingCopy repositoryGroup addRepository: repository ] ]! !

!MetacelloConfigTemplateExample class methodsFor: 'loading' stamp: ''!
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"

	<apiDocumentation>
	^(self project version: #development) load! !

!MetacelloConfigTemplateExample class methodsFor: 'private' stamp: ''!
baseConfigurationClassIfAbsent: aBlock

	^self environment 
		at: #MetacelloBaseConfiguration
		ifAbsent: [ 
			self ensureMetacelloBaseConfiguration.
			self environment at: #MetacelloBaseConfiguration ifAbsent: aBlock ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: ''!
setUpConfigurationOfProjectIssue171dkh1
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue171-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion20Issue171:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion20Issue171:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version20Issue171:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version20Issue171:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version135ProjectToolBox: spec
	<version: '1.3.5' imports: #('1.2.4-baseline' )>

	spec for: #'common' do: [
		spec repositories: [
			spec
				repository: 'http://www.example.com/ab';
				repository: 'http://www.example.com/ac' ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFee' stamp: ''!
baseline40ProjectFee: spec 
	"projects and packages"
	"self reset"
	<version: '4.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'Foo' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '4.0';
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself.
		spec 
			package: 'GeauxFaux' with: 'GeauxFaux-tg.32';
			package: 'GeauxBeau' with: 'GeauxBeau-dkh.55';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
setUpConfigurationOfProjectIssue119dkh4: ancestors
    "version 4.0"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.4'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion40Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion40Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version40Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version40Issue119:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: ancestors)
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFum' stamp: ''!
baseline40ProjectFum: spec 
	"master"
	"self reset"
	<version: '4.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'Feaux' with: [
				spec
					className: 'MetacelloTestConfigurationOfFeaux';
					versionString: '4.0';
					file: 'MetacelloTestConfigurationOfFeaux';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			project: 'Foo' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '4.0';
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			project: 'ProjectFie' with: [
				spec
					className: 'MetacelloTestConfigurationOfProjectFie';
					versionString: '4.0';
					file: 'MetacelloTestConfigurationOfProjectFie';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			project: 'ProjectFee' with: [
				spec
					className: 'MetacelloTestConfigurationOfProjectFee';
					versionString: '4.0';
					file: 'MetacelloTestConfigurationOfProjectFee';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: ''!
version10Issue156: spec
  "https://github.com/dalehenrich/metacello-work/issues/156"

  <version: '1.0.0'>
  spec
    for: #'common'
    do: [ 
      spec
        configuration: 'Goo'
          with: [ 
              spec
                versionString: '3.0.0';
                repository:
                    'dictionary://Metacello_MczConfiguration_Test_Repository' ];
        yourself ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version108ProjectToolBox: spec
	<version: '1.0.8-baseline'>

	spec for: #'common' do: [
		spec 
			package: 'Example-Core';
			package: 'Example-Tests' with: [
				spec requires: #('Example-Core' ). ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baseline30MethodSourceFoo

	^(self class sourceCodeAt: #baseline30Foo:) asString! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
baseline12C: spec 
	"self reset"
	<version: '1.2'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferFoo' with: 'GoferFoo-lr.1';
			package: 'GeauxBeau' with: 'GeauxBeau-dkh.55';
			yourself. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFie' stamp: ''!
baseline35ProjectFie: spec 
	"just projects"
	"self reset"

	<version: '3.5'>
	spec for: #common do: [
		spec 
			project: 'Foo' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '3.5';
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			project: 'Feaux' with: [
				spec
					className: 'MetacelloTestConfigurationOfFeaux';
					versionString: '4.0';
					file: 'MetacelloTestConfigurationOfFeaux';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFix' stamp: ''!
baseline61Fix: spec 
	"self reset"
	<version: '6.1'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferFoo' with: 'GoferFoo-lr.4';
			package: 'GoferBar' with: 'GoferBar-lr.1';
			package: 'GoferBeau' with: 'GoferBeau-dkh.53';
			package: 'GoferFaux' with: 'GoferFaux-tg.31';
			yourself. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: ''!
baseline40MethodSourceProjectInfinite

	^(self class sourceCodeAt: #baseline40ProjectInfinite:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFeaux' stamp: ''!
baseline40Feaux: spec 
	"self reset"
	<version: '4.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GeauxFoo' with:'GeauxFoo-lr.1';
			package: 'GeauxBar' with: 'GeauxBar.branch-lr.2';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 125' stamp: ''!
baselineVersion30Issue125: spec
    <version: '3.0-baseline' imports: #('2.0-baseline')>
    spec
        for: #(#'attribute1' #'attribute2')
        do: [ 
            spec description: 'MetacelloConfigurationResource>>baselineVersion30Issue125:'.
            spec
                package: 'GoferFaux' with: [ spec requires: 'GoferFoo' ];
                package: 'GoferBeau' with: [ spec requires: 'GoferFaux' ];
                yourself ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version127ProjectToolBox: spec
	<version: '1.2.7-baseline'>

	spec for: #'common' do: [
		spec project: 'Example Project' with: [
				spec
					className: 'MetacelloExampleProjectConfig';
					versionString: '1.0-baseline';
					preLoadDoIt: #'preloadDoIt';
					postLoadDoIt: #'postloadDoIt';
					repository: 'http://www.example.com/ob' ]. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
version40Issue119: spec
    <version: '4.0' imports: #('4.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo' with: '2.0'.
            spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
version20Issue119: spec
    <version: '2.0' imports: #('2.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo' with: '2.0'.
            spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version107ProjectToolBox: spec
	<version: '1.0.7-baseline'>

	spec for: #'common' do: [
		spec 
			package: 'Example-Core' with: [
				spec 
					supplyingAnswers: #( #( 'preload' 'preload answer' ) #( 'postload' 'postload answer' ) );
					preLoadDoIt: #'preloadForSupplyingAnswers';
					postLoadDoIt: #'postloadForSupplyingAnswers'. ];
			package: 'Example-Tests' with: [
				spec supplyingAnswers: #( #( 'string' 'preload answer' ) #( 'symbol' #'abc def' ) #( 'integer' 1 ) #( 'boolean' true ) #( 'another boolean' false ) #( 'character' $a ) ). ]. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
version10Issue119: spec
    <version: '1.0' imports: #('1.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo' with: '2.0'.
            spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
setUpConfigurationOfFoo
    "self reset"

    | reference className definitionArray |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfFoo-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: className)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'bleedingEdgeVersion:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'bleedingEdgeVersion:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline20Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline20MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline30Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline30MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline35Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline35MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline40Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline40MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline50Foo:'
        category: 'cat'
        timeStamp: ''
        source: self baseline50MethodSourceFoo).
    (MCMethodDefinition
        className: className asString
        selector: 'preloadDoIt'
        category: 'cat'
        timeStamp: ''
        source: self preloadDoItMethodSource)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
version21Issue283: spec
  <version: '2.1'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'release'.
      spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
      spec package: 'GoferFoo' with: 'GoferFoo-lr.4' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baselineGoo300Issue156Configuration: spec
  "https://github.com/dalehenrich/metacello-work/issues/156"

  <version: '3.0.0'>
  spec
    for: #'common'
    do: [ 
      spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
      spec
        package: 'GoferGoo' with: 'GoferFoo-lr.1';
        package: 'GoferBar' with: 'GoferBar.branch-lr.1';
        package: 'GoferFaux' with: 'GoferFaux-tg.30';
        package: 'GoferBeau' with: 'GoferBeau-dkh.53';
        yourself ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version113ProjectToolBox: spec
	<version: '1.1.3' imports: #('1.1.3-baseline' )>

	spec for: #'outer' do: [
		spec 
			package: 'Example-Core' with: 'Example-Core-dkh.1';
			package: 'Example-Test' with: 'Example-Test-dkh.1'.

		spec for: #'nested' do: [
			spec package: 'Example-Core' with: 'Example-Core-dkh.2'. ]. ].

	spec for: #'extra' do: [
		spec package: 'Example-Core' with: 'Example-Core-dkh.3'. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
stableVersionDMethodSourceSymbolic

	^(self class sourceCodeAt: #stableVersionD:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version128ProjectToolBox: spec
	<version: '1.2.8-baseline' imports: #('1.2.7-baseline' )>

	spec for: #'common' do: [
		spec project: 'Example Project' with: [
				spec
					preLoadDoIt: nil;
					postLoadDoIt: nil ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
version43Symbolic: spec 
	"self reset"
	<version: '4.3'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec blessing: #development.
		spec 
			package: 'GoferBeau' with: 'GoferBeau-dkh.54';
			package: 'GoferFaux' with:'GoferFaux-tg.33';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
bleedingEdge206B: spec
  "self reset"

  <symbolicVersion: #'bleedingEdge'>
  spec for: #'common' version: '2.1'! !

!MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: ''!
setUpConfigurationOfProjectIssue136dkh2: ancestors
	"self reset"
	
	| reference className definitionArray versionInfo |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue136-dkh.2'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baselineVersion10Issue136:'
						category: 'cat'
						timeStamp: ''
						source: (self class sourceCodeAt: #baselineVersion10Issue136:) asString.
					MCMethodDefinition 
						className: className asString
						selector: 'version10Issue136:'
						category: 'cat'
						timeStamp: ''
						source: (self class sourceCodeAt: #version10Issue136:) asString.
					MCMethodDefinition 
						className: className asString
						selector: 'version11Issue136:'
						category: 'cat'
						timeStamp: ''
						source: (self class sourceCodeAt: #version11Issue136:) asString.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (versionInfo := MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: ancestors)
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #()).
	^versionInfo! !

!MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: ''!
version30Issue156: spec
  "https://github.com/dalehenrich/metacello-work/issues/156"

  <version: '3.0.0'>
  spec
    for: #'common'
    do: [ 
      spec
        configuration: 'Goo'
          with: [ 
              spec
                versionString: '5.0.0';
                repository:
                    'dictionary://Metacello_MczConfiguration_Test_Repository' ];
        yourself ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFie' stamp: ''!
baseline15ProjectFie: spec
  "self reset"

  <version: '1.5'>
  spec
    for: #'common'
    do: [ 
      spec
        configuration: 'Foo'
        with: [ 
          spec
            className: 'MetacelloTestConfigurationOfFoo';
            versionString: '3.5';
            repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
baseline20Fan: spec 
	"self reset"
	<version: '2.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'Foo' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '2.0';
					loads: #('GoferFaux' 'GoferBeau');
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			project: 'Far' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '2.0';
					loads: #('GoferBeau');
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
baselineVersion20Issue154: spec
    <version: '2.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec
                project: 'MetacelloExample'
                    with: [ 
                            spec
                                className: 'ConfigurationOfMetacelloExample';
                                versionString: '1.0';
                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
                yourself ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
version41Symbolic: spec 
	"self reset"
	<version: '4.1'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec blessing: #release.
		spec 
			package: 'GoferBeau' with: 'GoferBeau-dkh.25';
			package: 'GoferFaux' with:'GoferFaux-tg.31';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version124ProjectToolBox: spec
	<version: '1.2.4' imports: #('1.2.4-baseline' )>

	spec for: #'common' do: [
		spec repository: 'http://www.example.com/ac'. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
baseline30MethodSourceFan

	^(self class sourceCodeAt: #baseline30Fan:) asString! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
baselineVersion10Issue154: spec
    <version: '1.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec
                project: 'MetacelloExample'
                    with: [ 
                            spec
                                className: 'ConfigurationOfMetacelloExample';
                                versionString: '1.0';
                                projectPackage: [ 
                                            spec
                                                name: 'ConfigurationOfMetacelloExample';
                                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ];
                yourself ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: ''!
version20Issue171: spec
    <version: '2.0' imports: #('2.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo' with: '2.0'.
            spec package: 'GeauxFoo' with: 'GeauxFoo-lr.1' ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 125' stamp: ''!
version30Issue125: spec
    <version: '3.0' imports: #('3.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'release'.
            spec description: 'MetacelloConfigurationResource>>version30Issue125:'.
            spec
                package: 'GoferFoo' with: 'GoferFoo-lr.4';
                package: 'GoferBar' with: 'GoferBar-jf.1';
                yourself ].
    spec
        for: #'attribute1'
        do: [ 
            spec
                package: 'GoferFaux' with: 'GoferFaux-tg.32';
                package: 'GoferBeau' with: 'GoferBeau-dkh.55';
                yourself ].
    spec
        for: #'attribute2'
        do: [ 
            spec
                package: 'GoferFaux' with: 'GoferFaux-tg.33';
                package: 'GoferBeau' with: 'GoferBeau-dkh.56';
                yourself ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
setUpConfigurationOfSymbolic
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfSymbolic-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'stableVersionD:'
						category: 'cat'
						timeStamp: ''
						source: self stableVersionDMethodSourceSymbolic.
					MCMethodDefinition 
						className: className asString
						selector: 'version40Symbolic:'
						category: 'cat'
						timeStamp: ''
						source: self version40SymbolicMethodSourceSymbolic.
					MCMethodDefinition 
						className: className asString
						selector: 'version41Symbolic:'
						category: 'cat'
						timeStamp: ''
						source: self version41SymbolicMethodSourceSymbolic.
					MCMethodDefinition 
						className: className asString
						selector: 'version42Symbolic:'
						category: 'cat'
						timeStamp: ''
						source: self version42SymbolicMethodSourceSymbolic.
					MCMethodDefinition 
						className: className asString
						selector: 'version43Symbolic:'
						category: 'cat'
						timeStamp: ''
						source: self version43SymbolicMethodSourceSymbolic.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: ''!
version11Issue156: spec
  "https://github.com/dalehenrich/metacello-work/issues/156"

  <version: '1.1.0'>
  spec
    for: #'common'
    do: [ 
      spec
        baseline: 'Goo'
          with: [ spec repository: 'dictionary://Metacello_MczConfiguration_Test_Repository' ];
        yourself ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
baselineVersion10Issue119: spec
    <version: '1.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
            spec
                project: 'Foo '
                    with: [ 
                            spec
                                className: 'MetacelloTestConfigurationOfFoo';
                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
                yourself.
            spec package: 'GoferBar ' ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
setUpIssue77
	"self reset"
	
	self
		setUpIssue77B;
		setUpIssue77C;
		setUpIssue77D! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
setUpConfigurationOfProjectIssue283dkh1
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference
    name: 'ConfigurationOfProjectIssue283-dkh.1'.
  className := reference packageName asSymbol.
  definitionArray := {(MCClassDefinition
    name: className
    superclassName: #'Object'
    category: className
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: true
    selector: 'project'
    category: 'cat'
    timeStamp: ''
    source: self projectClassMethodSource).
  (MCMethodDefinition
    className: className asString
    selector: 'project'
    category: 'cat'
    timeStamp: ''
    source: self projectMethodSource).
  (MCMethodDefinition
    className: className asString
    selector: 'stableVersion283A:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'stableVersion283A:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'bleedingEdge206A:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'bleedingEdge206A:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'version20Issue283:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version20Issue283:') asString)}.
  monticelloRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
baselineVersion12Issue154: spec
    <version: '1.2-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec
                project: 'MetacelloExample'
                    with: [ 
                            spec
                                className: 'ConfigurationOfMetacelloExample';
                                versionString: '1.0';
                                projectPackage: [ 
                                            spec
                                                name: 'MetacelloExampleTestConfigurationIssue154';
                                                file: 'MetacelloExampleTestConfigurationIssue154.gemstone';
                                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ];
                yourself ]! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
setUpConfigurationOfProjectIssue283dkh2: ancestors
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference
    name: 'ConfigurationOfProjectIssue283-dkh.2'.
  className := reference packageName asSymbol.
  definitionArray := {(MCClassDefinition
    name: className
    superclassName: #'Object'
    category: className
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: true
    selector: 'project'
    category: 'cat'
    timeStamp: ''
    source: self projectClassMethodSource).
  (MCMethodDefinition
    className: className asString
    selector: 'project'
    category: 'cat'
    timeStamp: ''
    source: self projectMethodSource).
  (MCMethodDefinition
    className: className asString
    selector: 'stableVersion283B:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'stableVersion283B:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'bleedingEdge206B:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'bleedingEdge206B:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'version20Issue283:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version20Issue283:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'version21Issue283:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version21Issue283:') asString)}.
  monticelloRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: ancestors)
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baseline20MethodSourceFoo

	^(self class sourceCodeAt: #baseline20Foo:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version119ProjectToolBox: spec
	<version: '1.1.9-baseline' imports: #('1.1.4-baseline' )>

	spec for: #'common' do: [
		spec project: 'Example Project' overrides: [
				spec
					className: 'MetacelloExampleProjectConfig';
					versionString: '1.0-baseline';
					preLoadDoIt: #'alternatePreloadForCore';
					repository: 'http://www.example.com/ob' ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
baseline50Fan: spec 
	"self reset"
	<version: '5.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'Foo' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '5.0';
					loads: #('GoferFaux' 'GoferBeau');
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFix' stamp: ''!
baseline61MethodSourceFix

	^(self class sourceCodeAt: #baseline61Fix:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
projectClassMethodSource

	^(self class class sourceCodeAt: #project) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version109ProjectToolBox: spec
	<version: '1.0.9-baseline'>

	spec for: #'common' do: [
		spec 
			package: 'Example-Core';
			package: 'Example-Tests' with: [
				spec includes: #('Example-Core' ). ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version132ProjectToolBox: spec
	<version: '1.3.2-baseline'>

	spec for: #'common' do: [
		spec blessing: #'baseline'.
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. ].

	spec for: #'level1_1' do: [
		spec package: 'GoferBeau' with: 'GoferBeau-dkh.15'.

		spec for: #'level2_1' do: [
			spec package: 'GoferBeau' with: 'GoferBeau-dkh.25'.

			spec for: #'level3_1' do: [
				spec package: 'GoferBeau' with: 'GoferBeau-dkh.53'. ]. ].

		spec for: #'level2_2' do: [
			spec package: 'GoferBeau' with: 'GoferBeau-dkh.54'.

			spec for: #'level3_2' do: [
				spec package: 'GoferBeau' with: 'GoferBeau-dkh.55'. ]. ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version121ProjectToolBox: spec
	<version: '1.2.1-baseline'>

	spec for: #'common' do: [
		spec blessing: #'testBlessing'.
		spec repository: 'http://www.example.com/vor'.
		spec 
			package: 'Example-Core' with: [
				spec 
					includes: #('Example-AddOn' );
					file: 'Example-Core-anon.1';
					repository: 'http://www.example.com/or';
					preLoadDoIt: #'preloadForCore';
					postLoadDoIt: #'postloadForCore:package:'. ];
			package: 'Example-AddOn' with: [
				spec requires: #('Example-Core' ). ];
			package: 'Example-Tests' with: [
				spec requires: #('Example-AddOn' ). ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baseline20Foo: spec 
	"self reset"
	<version: '2.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferFoo' with: 'GoferFoo-lr.1';
			package: 'GoferBar' with: 'GoferBar.branch-lr.1';
			package: 'GoferFaux' with: 'GoferFaux-tg.30';
			package: 'GoferBeau' with: 'GoferBeau-dkh.25';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
setUpConfigurationOfProjectIssue119dkh5: ancestors
    "versions, 4.0, 4.1, 4.2, 4.3, 4.4"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.5'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion40Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion40Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version40Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version40Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version41Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version41Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version42Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version42Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version43Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version43Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version44Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version44Issue119:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: ancestors)
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: ''!
setUpIssue95
	"self reset"
	
	self
		setUpConfigurationOfProjectInfinite;
		setUpConfigurationOfProjectLoop;
		setUpConfigurationOfProjectIssue95;
		yourself! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baselineGooIssue156Baseline: spec
  "https://github.com/dalehenrich/metacello-work/issues/156"

  <baseline>
  spec
    for: #'common'
    do: [ 
      spec
        package: 'GoferFoo' with: 'GoferFoo-lr.1';
        package: 'GoferBar' with: 'GoferBar.branch-lr.1';
        package: 'GoferFaux' with: 'GoferFaux-tg.30';
        package: 'GoferBeau' with: 'GoferBeau-dkh.53';
        yourself ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version115ProjectToolBox: spec
	<version: '1.1.5-baseline' imports: #('1.1.4-baseline' )>

	spec for: #'common' do: [
		spec project: 'Example Project' with: [
				spec
					preLoadDoIt: #'alternatePreloadForCore' ]. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
baselineVersion30Issue119: spec
    <version: '3.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
            spec
                project: 'Foo '
                    with: [ 
                            spec
                                versionString: #'bleedingEdge';
                                className: 'MetacelloTestConfigurationOfFoo';
                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
                yourself.
            spec package: 'GoferBar' ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
setUpConfigurationOfProjectIssue119dkh1
    "version 1.0"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion10Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion10Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version10Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version10Issue119:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
baselineVersion11Issue154: spec
    <version: '1.1-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec
                project: 'MetacelloExample'
                    with: [ 
                            spec
                                className: 'ConfigurationOfMetacelloExample';
                                versionString: '1.0';
                                projectPackage: [ 
                                            spec
                                                name: 'MetacelloExampleTestConfigurationIssue154';
                                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ];
                yourself ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: ''!
setUpConfigurationOfProjectInfinite
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectInfinite-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline40ProjectInfinite:'
						category: 'cat'
						timeStamp: ''
						source: self baseline40MethodSourceProjectInfinite.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
baselineVersion10MetacelloExample: spec
    <version: '1.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
            spec package: 'GoferFoo' ]! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
version20Issue283: spec
  <version: '2.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'release'.
      spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
      spec package: 'GoferFoo' with: 'GoferFoo-lr.2' ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
baselineVersion40Issue119: spec
    <version: '4.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
            spec
                project: 'Foo'
                    with: [ 
                            spec
                                versionString: #'bleedingEdge';
                                className: 'MetacelloTestConfigurationOfFoo';
                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
                yourself.
            spec package: 'GoferBar' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
stableVersionC: spec 
	"self reset"
	<symbolicVersion: #stable>
	
	spec for: #'common' do: [ spec version: '4.2'].
	spec for: #'platformVersion1.x' do: [ spec version: '4.0'].
	spec for: #'platformVersion1.0.x' do: [ spec version: '4.1'].
	spec for: #'platformVersion1.1.x' do: [ spec version: '4.2'].
	spec for: #'platformVersion1.2.x' do: [ spec version: '4.3'].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
baseline40Fan: spec 
	"self reset"
	<version: '4.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'Foo' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '4.0';
					loads: #('GoferFaux' 'GoferBeau');
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
setUpConfigurationOfProjectIssue156
  "https://github.com/dalehenrich/metacello-work/issues/156"

  "self reset"

  self
    setUpIssue156BaselineOfGoo;
    setUpIssue156ConfigurationOfGoo! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
projectVersion10Issue283: spec
  <version: '1.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'release'.
      spec
        configuration: 'ProjectIssue283'
        with: [ 
          spec
            version: #'stable';
            repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baselineGoo400Issue156Configuration: spec
  "https://github.com/dalehenrich/metacello-work/issues/156"

  <version: '4.0.0'>
  spec
    for: #'common'
    do: [ 
      spec
        baseline: 'Goo'
          with: [ spec repository: 'dictionary://Metacello_MczConfiguration_Test_Repository' ];
        import: 'Goo' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version126ProjectToolBox: spec
	<version: '1.2.6-baseline' imports: #('1.2.5-baseline' )>

	spec for: #'common' do: [
		spec package: 'Example-Core' with: [
				spec 
					preLoadDoIt: nil;
					postLoadDoIt: nil. ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
baselineVersion124ProjectToolBox: spec
	<version: '1.2.4-baseline'>

	spec for: #'common' do: [
		spec blessing: #'baseline'.
		spec repository: 'http://www.example.com/aa'. ].

	spec for: #'common' do: [
		spec repository: 'http://www.example.com/ab'. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
symbolicVersionExplicitlyDoesNotExistProjectToolBox: spec
    <symbolicVersion: #'explicitly does not exist'>
    spec for: #'common' version: #'notDefined'! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFee' stamp: ''!
setUpConfigurationOfProjectFee
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectFee-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline40ProjectFee:'
						category: 'cat'
						timeStamp: ''
						source: self baseline40MethodSourceProjectFee.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: ''!
baseline40ProjectIssue95: spec 
	"self reset"
	<version: '4.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'Loop' with: [
				spec
					className: 'MetacelloTestConfigurationOfProjectLoop';
					versionString: '4.0';
					loads: 'GoferFaux';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			project: 'Infinite' with: [
				spec
					className: 'MetacelloTestConfigurationOfProjectInfinite';
					versionString: '4.0';
					loads: 'GeauxBar';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version129ProjectToolBox: spec
	<version: '1.2.9-baseline'>

	spec for: #'common' do: [
		spec 
			project: 'Example Project' with: [
				spec
					className: 'MetacelloExampleProjectConfig';
					versionString: '1.0-baseline';
					preLoadDoIt: #'preloadDoIt';
					postLoadDoIt: #'postloadDoIt';
					repository: 'http://www.example.com/ob' ];
			project: 'Copy Project' copyFrom: 'Example Project' with: [
				spec
					preLoadDoIt: nil;
					postLoadDoIt: nil ]. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
setUpConfigurationOfProjectIssue154dkh1
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfMetacelloProjectIssue154-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion10Issue154:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion10Issue154:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion11Issue154:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion11Issue154:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion12Issue154:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion12Issue154:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion13Issue154:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion13Issue154:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion20Issue154:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion20Issue154:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion30Issue154:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion30Issue154:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
baseline10D: spec 
	"self reset"
	<version: '1.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'C' with: [
				spec
					className: 'MetacelloTestConfigurationOfIssue77C';
					loads: #('GoferFoo');
					versionString: '1.3';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			package: 'GoferBar' with: [
				spec 
					file:'GoferBar-lr.1' ];
			group: 'default' with: #('GoferBar');
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
baseline10MethodSourceD

	^(self class sourceCodeAt: #baseline10D:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
postloadDoIt
	"self reset"

	Smalltalk at: #'Metacello_Configuration_Test_POST_DoIt_Result' put: true! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
baseline13MethodSourceC

	^(self class sourceCodeAt: #baseline13C:) asString! !

!MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: ''!
baselineVersion10Issue115: spec
    <version: '1.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
            spec
                project: 'Foo'
                    with: [ 
                            spec
                                versionString: #'bleedingEdge';
                                className: 'MetacelloTestConfigurationOfFoo';
                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
                yourself.
            spec package: 'GeauxFoo' ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
setUpConfigurationOfProjectIssue119dkh2: ancestors
    "version 2.0"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.2'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion20Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion20Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version20Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version20Issue119:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: ancestors)
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version120ProjectToolBox: spec
	<version: '1.2.0-baseline' imports: #('1.1.4-baseline' )>

	spec for: #'common' do: [
		spec project: 'Copied Example' copyFrom: 'Example Project' with: [
				spec
					preLoadDoIt: #'alternatePreloadForCore' ]. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: ''!
baseline40MethodSourceProjectIssue95

	^(self class sourceCodeAt: #baseline40ProjectIssue95:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version123ProjectToolBox: spec
	<version: '1.2.3-baseline'>

	spec for: #'common' do: [
		spec project: 'Example Project' with: [
				spec
					className: 'MetacelloExampleProjectConfig';
					repository: 'http://www.example.com/ob';
					repository: 'http://www.example.com/or' ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version104ProjectToolBox: spec
	<version: '1.0.4-baseline' imports: #('1.0.2-baseline' )>

	spec for: #'common' do: [
		spec preLoadDoIt: nil. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
setUpConfigurationOfMetacelloExampledkh1
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfMetacelloExample-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion10MetacelloExample:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion10MetacelloExample:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version10MetacelloExample:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version10MetacelloExample:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
baseline40MethodSourceFan

	^(self class sourceCodeAt: #baseline40Fan:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
baseline35Fan: spec 
	"self reset"
	<version: '3.5'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'Foo' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '3.5';
					loads: #('GoferFaux' 'GoferBeau');
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version117ProjectToolBox: spec
	<version: '1.1.7-baseline' imports: #('1.0-baseline' )>

	spec for: #'common' do: [
		spec package: 'Example-Core' overrides: [
				spec preLoadDoIt: #'alternatePreloadForCore'. ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
baseline35MethodSourceFan

	^(self class sourceCodeAt: #baseline35Fan:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baseline30Foo: spec 
	"self reset"
	<version: '3.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferFoo' with: [
				spec 
					preLoadDoIt: #preloadDoIt;
					file: 'GoferFoo-lr.1' ];
			package: 'GoferBar' with: 'GoferBar.branch-lr.1';
			package: 'GoferFaux' with: 'GoferFaux-tg.30';
			package: 'GoferBeau' with: 'GoferBeau-dkh.53';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
setUpConfigurationOfFan
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfFan-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline20Fan:'
						category: 'cat'
						timeStamp: ''
						source: self baseline20MethodSourceFan.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline30Fan:'
						category: 'cat'
						timeStamp: ''
						source: self baseline30MethodSourceFan.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline35Fan:'
						category: 'cat'
						timeStamp: ''
						source: self baseline35MethodSourceFan.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline40Fan:'
						category: 'cat'
						timeStamp: ''
						source: self baseline40MethodSourceFan.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline50Fan:'
						category: 'cat'
						timeStamp: ''
						source: self baseline50MethodSourceFan.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFie' stamp: ''!
baseline25ProjectFie: spec
  "self reset"

  <version: '2.5'>
  spec
    for: #'common'
    do: [ 
      spec
        configuration: 'Foo'
        with: [ 
          spec
            className: 'MetacelloTestConfigurationOfFoo';
            versionString: '3.5';
            repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: ''!
version10Issue136: spec
	<version: '1.0' imports: #('1.0-baseline')>

	spec for: #'common' do: [
		spec blessing: #development.
		spec package: 'GoferBeau' with: 'GoferBeau-dkh.15'. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
version43SymbolicMethodSourceSymbolic

	^(self class sourceCodeAt: #version43Symbolic:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFix' stamp: ''!
baseline60MethodSourceFix

	^(self class sourceCodeAt: #baseline60Fix:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baseline35MethodSourceFoo

	^(self class sourceCodeAt: #baseline35Foo:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
baseline20MethodSourceFan

	^(self class sourceCodeAt: #baseline20Fan:) asString! !

!MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: ''!
version11Issue136: spec
	<version: '1.1' imports: #('1.0-baseline')>

	spec for: #'common' do: [
		spec blessing: #development.
		spec package: 'GoferBeau' with: 'GoferBeau-dkh.25'. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: ''!
baselineVersion10Issue136: spec
	<version: '1.0-baseline'>

	spec for: #'common' do: [
		spec blessing: #baseline.
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferBeau'. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
stableVersionD: spec 
	"self reset"
	<symbolicVersion: #stable>
	
	spec for: #'common' version: '4.2'.
	spec for: #'platformVersion1.x' version: '4.0'.
	spec for: #'platformVersion1.0.x' version: '4.1'.
	spec for: #'platformVersion1.1.x' version: '4.2'.
	spec for: #'platformVersion1.2.x' version: '4.3'.! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version133ProjectToolBox: spec
	<version: '1.3.3-baseline'>

	spec for: #'common' do: [
		spec blessing: #'baseline'.
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. ].

	spec for: #'level1_1' do: [
		spec package: 'GoferBar' with: 'GoferBar-jf.1'.

		spec for: #'level2_1' do: [
			spec package: 'GoferFoo' with: 'GoferFoo-lr.1'.

			spec for: #'level3_1' do: [
				spec package: 'GoferFaux' with: 'GoferFaux-tg.30'. ]. ].

		spec for: #'level2_2' do: [
			spec package: 'GeauxBar' with: 'GeauxBar.branch-lr.2'.

			spec for: #'level3_2' do: [
				spec package: 'GeauxBeau' with: 'GeauxBeau-dkh.55'. ]. ]. ].

	spec for: #'pharo' do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
setUpConfigurationOfProjectIssue119dkh3: ancestors
    "version 3.0"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.3'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion30Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion30Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version30Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version30Issue119:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: ancestors)
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
baselineVersion113ProjectToolBox: spec
	<version: '1.1.3-baseline'>

	spec for: #'outer' do: [
		spec 
			package: 'Example-Core';
			package: 'Example-Test'. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFoe' stamp: ''!
setUpConfigurationOfProjectFoe
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectFoe-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline40ProjectFoe:'
						category: 'cat'
						timeStamp: ''
						source: self baseline40MethodSourceProjectFoe.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: ''!
version21Issue171: spec
    <version: '2.1' imports: #('2.1-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo' with: '2.0'.
            spec package: 'GeauxFoo' with: 'GeauxFoo-lr.1' ]! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
setUpConfigurationOfProjectConfigIssue283dkh1
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference
    name: 'ConfigurationOfProjectConfigIssue283-dkh.1'.
  className := reference packageName asSymbol.
  definitionArray := {(MCClassDefinition
    name: className
    superclassName: #'Object'
    category: className
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: true
    selector: 'project'
    category: 'cat'
    timeStamp: ''
    source: self projectClassMethodSource).
  (MCMethodDefinition
    className: className asString
    selector: 'project'
    category: 'cat'
    timeStamp: ''
    source: self projectMethodSource).
  (MCMethodDefinition
    className: className asString
    selector: 'projectVersion10Issue283:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'projectVersion10Issue283:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'projectVersion20Issue283:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'projectVersion20Issue283:') asString)}.
  monticelloRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFeaux' stamp: ''!
baseline40MethodSourceFeaux

	^(self class sourceCodeAt: #baseline40Feaux:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFum' stamp: ''!
setUpConfigurationOfFum
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfFum-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline40ProjectFum:'
						category: 'cat'
						timeStamp: ''
						source: self baseline40MethodSourceProjectFum.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: ''!
version11Issue115: spec
	<version: '1.1' imports: #('1.0-baseline')>

	spec for: #'common' do: [
		spec blessing: #development.
		spec  project: 'Foo' with: ''.
		spec package: 'GeauxFoo' with: 'GeauxFoo-lr.1'. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: ''!
setUpConfigurationOfProjectLoop
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectLoop-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline40ProjectLoop:'
						category: 'cat'
						timeStamp: ''
						source: self baseline40MethodSourceProjectLoop.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
version50Issue119: spec
    <version: '5.0' imports: #('4.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo' with: '1.0'.
            spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
version10MetacelloExample: spec
    <version: '1.0' imports: #('1.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'release'.
            spec package: 'GoferFoo' with: 'GoferFoo-lr.2' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
preloadDoItMethodSource

	^(self class sourceCodeAt: #preloadDoIt) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version116ProjectToolBox: spec
	<version: '1.1.6-baseline' imports: #('1.1.4-baseline' )>

	spec for: #'common' do: [
		spec project: 'Example Project' with: [
				spec
					preLoadDoIt: #'alternatePreloadForCore' ]. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: ''!
setUpConfigurationOfProjectIssue171dkh2: ancestors
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue171-dkh.2'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion21Issue171:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion21Issue171:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version21Issue171:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version21Issue171:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: ancestors)
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
preloadDoIt
	"self reset"

	Smalltalk at: #'Metacello_Configuration_Test_DoIt_Result' put: true! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
baseline50MethodSourceFan

	^(self class sourceCodeAt: #baseline50Fan:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
version42Symbolic: spec 
	"self reset"
	<version: '4.2'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec blessing: #release.
		spec 
			package: 'GoferBeau' with: 'GoferBeau-dkh.53';
			package: 'GoferFaux' with:'GoferFaux-tg.32';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: ''!
baselineVersion21Issue171: spec
    <version: '2.1-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
            spec
                project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo' ];
                yourself.
            spec package: 'GeauxFoo' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version100ProjectToolBox: spec
	<version: '1.0-baseline'>

	spec for: #'common' do: [
		spec blessing: #'testBlessing'.
		spec 
			package: 'Example-Core' with: [
				spec 
					includes: #('Example-AddOn' );
					file: 'Example-Core-anon.1';
					repository: 'http://www.example.com/or';
					preLoadDoIt: #'preloadForCore';
					postLoadDoIt: #'postloadForCore:package:'. ];
			package: 'Example-AddOn' with: [
				spec requires: #('Example-Core' ). ];
			package: 'Example-Tests' with: [
				spec requires: #('Example-AddOn' ). ]. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: ''!
version10Issue115: spec
	<version: '1.0' imports: #('1.0-baseline')>

	spec for: #'common' do: [
		spec blessing: #development.
		spec  project: 'Foo' .
		spec package: 'GeauxFoo' with: 'GeauxFoo-lr.1'. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 125' stamp: ''!
baselineVersion20Issue125: spec
    <version: '2.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec description: 'MetacelloConfigurationResource>>baselineVersion20Issue125:'.
            spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
            spec
                package: 'GoferFoo';
                package: 'GoferBar' with: [ spec requires: 'GoferFoo' ];
                yourself ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
version44Issue119: spec
    <version: '4.4' imports: #('4.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo' with: 2.0.
            spec package: 'GoferBar ' with: 'GoferBar-jf.1' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFoe' stamp: ''!
baseline40MethodSourceProjectFoe

	^(self class sourceCodeAt: #baseline40ProjectFoe:) asString! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
baselineVersion30Issue154: spec
    <version: '3.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec
                project: 'MetacelloExample'
                    with: [ 
                            spec
                                className: 'ConfigurationOfMetacelloExample';
                                versionString: '1.0';
                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
                yourself ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
baseline10MethodSourceB

	^(self class sourceCodeAt: #baseline10B:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version103ProjectToolBox: spec
	<version: '1.0.3-baseline' imports: #('1.0.2-baseline' )>

	spec for: #'common' do: [
		spec preLoadDoIt: #'alternatePreloadForCore'. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFee' stamp: ''!
baseline40MethodSourceProjectFee

	^(self class sourceCodeAt: #baseline40ProjectFee:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version122ProjectToolBox: spec
	<version: '1.2.2-baseline'>

	spec for: #'common' do: [
		spec project: 'Example Project' with: [
				spec
					className: 'MetacelloExampleProjectConfig';
					repository: 'http://www.example.com/ob' ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
version40Symbolic: spec 
	"self reset"
	<version: '4.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec blessing: #release.
		spec 
			package: 'GoferBeau' with: 'GoferBeau-dkh.15';
			package: 'GoferFaux' with:'GoferFaux-tg.30';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFix' stamp: ''!
setUpConfigurationOfFix
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfFix-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline60Fix:'
						category: 'cat'
						timeStamp: ''
						source: self baseline60MethodSourceFix.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline61Fix:'
						category: 'cat'
						timeStamp: ''
						source: self baseline61MethodSourceFix.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'Issue 125' stamp: ''!
setUpConfigurationOfProjectIssue125
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue125-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: className)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'version30Issue125:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version30Issue125:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion20Issue125:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion20Issue125:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion30Issue125:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion30Issue125:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: ''!
baseline40MethodSourceProjectLoop

	^(self class sourceCodeAt: #baseline40ProjectLoop:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFeaux' stamp: ''!
setUpConfigurationOfFeaux
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfFeaux-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline40Feaux:'
						category: 'cat'
						timeStamp: ''
						source: self baseline40MethodSourceFeaux.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'running' stamp: ''!
setUp
  "self reset"

  super setUp.
  self
    setUpMonticelloRepository;
    setUpConfigurationOfFoo;
    setUpConfigurationOfFeaux;
    setUpConfigurationOfProjectFie;
    setUpConfigurationOfProjectFee;
    setUpConfigurationOfFum;
    setUpConfigurationOfProjectFoe;
    setUpConfigurationOfFan;
    setUpConfigurationOfFix;
    setUpIssue77;
    setUpIssue95;
    setUpConfigurationOfSymbolic;
    setUpConfigurationOfProjectToolBox;
    setUpConfigurationOfProjectIssue115;
    setUpConfigurationOfProjectIssue136;
    setUpConfigurationOfProjectIssue119;
    setUpConfigurationOfProjectIssue171;
    setUpConfigurationOfProjectIssue154;
    setUpConfigurationOfProjectIssue156;
    setUpIssue156ConfigurationOfProjectGoo;
    setUpIssue156ConfigurationOfProjectSoo;
    setUpConfigurationOfProjectFum;
    setUpConfigurationOfProjectIssue125;
    setUpConfigurationOfProjectIssue283;
    yourself! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
setUpIssue77D
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfIssue77D-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline10D:'
						category: 'cat'
						timeStamp: ''
						source: self baseline10MethodSourceD.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
version30Issue119: spec
    <version: '3.0' imports: #('3.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo' with: '2.0'.
            spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
baseline13C: spec 
	"self reset"
	<version: '1.3'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferFoo' with: 'GoferFoo-lr.4';
			package: 'GeauxBeau' with: 'GeauxBeau-dkh.56';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFum' stamp: ''!
baseline10ProjectFum: spec
    "self reset"

    <version: '1.0'>
    spec
        for: #'common'
        do: [ 
            spec
                project: 'Foo'
                    with: [ 
                            spec
                                className: 'MetacelloTestConfigurationOfFoo';
                                versionString: '5.0';
                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
                project: 'Fie'
                    with: [ 
                            spec
                                className: 'MetacelloTestConfigurationOfProjectFie';
                                versionString: '2.5';
                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
                yourself ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
setUpIssue156BaselineOfGoo
  "https://github.com/dalehenrich/metacello-work/issues/156"

  "self reset"

  | reference className definitionArray |
  reference := GoferVersionReference name: 'BaselineOfGoo-dkh.1'.
  className := reference packageName asSymbol.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: className)).
  (MCClassDefinition
    name: className
    superclassName: #'BaselineOf'
    category: className
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    selector: 'baselineGooIssue156Baseline:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'baselineGooIssue156Baseline:') asString)}.
  monticelloRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFix' stamp: ''!
baseline60Fix: spec 
	"self reset"
	<version: '6.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferFoo' with: 'GoferFoo-lr.4';
			package: 'GoferBar' with: 'GoferBar-lr.1';
			package: 'GoferFaux' with: 'GoferFaux-tg.35';
			yourself. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
project
	"self reset"

	| project |
	"Construct Metacello project"
	project := MetacelloMCProject new.
	"Allow for customization of #projectAttributes"
	project projectAttributes: MetacelloConfigurationResource projectAttributes.
	MetacelloVersionConstructor on: self project: project.
	project loader: 
		((project loaderClass new)
			shouldDisablePackageCache: true;
			yourself).
	project loadType: #linear.
	^project! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version125ProjectToolBox: spec
	<version: '1.2.5-baseline' imports: #('1.0-baseline' )>

	spec for: #'common' do: [
		spec package: 'Example-Core' with: [
				spec 
					preLoadDoIt: #'preloadDoIt';
					postLoadDoIt: #'postloadDoIt'. ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version106ProjectToolBox: spec
	<version: '1.0.6-baseline'>

	spec for: #'common' do: [
		spec package: 'Example-Core' with: [
				spec repositories: [
						spec
							repository: 'http://www.example.com/ob';
							repository: 'http://www.example.com/or' ]. ]. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
version43Issue119: spec
    <version: '4.3' imports: #('4.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo ' with: '2.0'.
            spec package: 'GoferBar ' with: 'GoferBar-jf.1' ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: ''!
setUpConfigurationOfProjectIssue95
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue95-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline40ProjectIssue95:'
						category: 'cat'
						timeStamp: ''
						source: self baseline40MethodSourceProjectIssue95.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version134ProjectToolBox: spec
	<version: '1.3.4-baseline'>

	spec for: #'common' do: [
 ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
setUpIssue156ConfigurationOfProjectSoo
  "self reset"

  | reference className definitionArray |
  reference := GoferVersionReference name: 'ConfigurationOfProjectSoo-dkh.1'.
  className := reference packageName asSymbol.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: className)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: className
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    selector: 'version10Issue156:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version10Issue156:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'version11Issue156:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version11Issue156:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'version20Issue156:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version20Issue156:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'version30Issue156:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version30Issue156:') asString)}.
  monticelloRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version102ProjectToolBox: spec
	<version: '1.0.2-baseline'>

	spec for: #'common' do: [
		spec preLoadDoIt: #'preloadForCore'.
		spec postLoadDoIt: #'postloadForCore:package:'.
		spec 
			package: 'Example-Core' with: [
				spec includes: #('Example-AddOn' ). ];
			package: 'Example-AddOn' with: [
				spec requires: #('Example-Core' ). ];
			package: 'Example-Tests' with: [
				spec requires: #('Example-AddOn' ). ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baseline50Foo: spec 
	"self reset"
	<version: '5.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			package: 'GoferFoo' with:'GoferFoo-lr.2';
			package: 'GoferBar' with: 'GoferBar-lr.1';
			package: 'GoferFaux' with: 'GoferFaux-tg.34';
			package: 'GoferBeau' with: 'GoferBeau-dkh.55';
			yourself.
		spec
			group: '1' with: #('GoferFoo' 'GoferBar');
			group: '2' with: #('GoferFoo' 'GoferFaux');
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
stableVersion283B: spec
  "self reset"

  <symbolicVersion: #'stable'>
  spec for: #'common' version: '2.1'! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFum' stamp: ''!
baseline40MethodSourceProjectFum

	^(self class sourceCodeAt: #baseline40ProjectFum:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: ''!
baseline30Fan: spec 
	"self reset"
	<version: '3.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'Foo' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '3.0';
					loads: #('GoferFaux' 'GoferBeau');
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
baseline12MethodSourceC

	^(self class sourceCodeAt: #baseline12C:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFum' stamp: ''!
setUpConfigurationOfProjectFum
    "self reset"

    | reference className definitionArray |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectFum-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: className)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline10ProjectFum:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baseline10ProjectFum:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
version41SymbolicMethodSourceSymbolic

	^(self class sourceCodeAt: #version41Symbolic:) asString! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
setUpConfigurationOfProjectIssue154
    "self reset"

    | versionInfo |
    versionInfo := self setUpConfigurationOfMetacelloExampledkh1.
    versionInfo := self setUpConfigurationOfProjectIssue154dkh1! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baseline50MethodSourceFoo

	^(self class sourceCodeAt: #baseline50Foo:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
version42SymbolicMethodSourceSymbolic

	^(self class sourceCodeAt: #version42Symbolic:) asString! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
setUpConfigurationOfProjectToolBox
    "self reset"

    | reference className definitionArray |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectToolBox-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'postloadDoIt'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'postloadDoIt') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'preloadDoIt'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'preloadDoIt') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'symbolicVersionExplicitlyDoesNotExistProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'symbolicVersionExplicitlyDoesNotExistProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version100ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version100ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version101ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version101ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version102ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version102ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version103ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version103ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version104ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version104ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version105ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version105ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version106ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version106ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version107ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version107ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version108ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version108ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version109ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version109ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version110ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version110ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version111ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version111ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version112ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version112ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion113ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion113ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version113ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version113ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version114ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version114ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version115ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version115ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version116ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version116ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version117ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version117ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version118ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version118ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version119ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version119ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version120ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version120ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version121ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version121ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version122ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version122ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version123ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version123ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion124ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion124ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version124ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version124ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version125ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version125ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version126ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version126ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version127ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version127ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version128ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version128ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version129ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version129ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version130ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version130ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version131ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version131ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version132ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version132ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version133ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version133ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version134ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version134ProjectToolBox:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version135ProjectToolBox:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version135ProjectToolBox:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version111ProjectToolBox: spec
	<version: '1.1.1-baseline'>

	spec for: #'common' do: [
		spec package: 'Example-Core'.

		spec for: #'nested' do: [
			spec package: 'Example-Base'. ]. ].

	spec for: #'extra' do: [
		spec package: 'Example-Test'. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baselineGoo500Issue156Configuration: spec
  "https://github.com/dalehenrich/metacello-work/issues/156"

  <version: '5.0.0'>
  spec
    for: #'common'
    do: [ 
      spec
        baseline: 'Goo'
          with: [ spec repository: 'dictionary://Metacello_MczConfiguration_Test_Repository' ];
        import: 'Goo' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFie' stamp: ''!
baseline40ProjectFie: spec 
	"just projects"
	"self reset"

	<version: '4.0'>
	spec for: #common do: [
		spec 
			project: 'Foo' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '4.0';
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			project: 'Feaux' with: [
				spec
					className: 'MetacelloTestConfigurationOfFeaux';
					versionString: '4.0';
					file: 'MetacelloTestConfigurationOfFeaux';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: ''!
baseline40ProjectLoop: spec 
	"self reset"
	<version: '4.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'Infinite' with: [
				spec
					className: 'MetacelloTestConfigurationOfProjectInfinite';
					versionString: '4.0';
					loads: 'GoferBar';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			package: 'GoferFaux' with: [
				spec
					file:'GoferFaux-tg.30';
					requires: 'Infinite';
					yourself ];
			package: 'GeauxBeau' with: [
				spec
					file: 'GeauxBeau-dkh.55';
					yourself ];
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
version42Issue119: spec
    <version: '4.2' imports: #('4.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo' with: '2.0'.
            spec package: 'GoferBar ' with: 'GoferBar-jf.1' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baseline35Foo: spec
  "self reset"

  <version: '3.5'>
  spec
    for: #'common'
    do: [ 
      spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
      spec
        package: 'GoferFoo' with: 'GoferFoo-lr.1';
        package: 'GoferBar' with: 'GoferBar-lr.1';
        package: 'GoferFaux' with: 'GoferFaux-tg.31';
        package: 'GoferBeau' with: 'GoferBeau-dkh.54';
        yourself.
      spec
        group: '1' with: #('GoferFoo' 'GoferBar');
        group: '2' with: #('GoferFoo' 'GoferFaux');
        yourself ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: ''!
baselineVersion13Issue154: spec
    <version: '1.3-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec
                project: 'MetacelloExample'
                    with: [ 
                            spec
                                className: 'ConfigurationOfMetacelloExample';
                                versionString: '1.0';
                                projectPackage: [ 
                                            spec
                                                file: 'MetacelloExampleTestConfigurationIssue154.gemstone';
                                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ];
                yourself ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: ''!
setUpConfigurationOfProjectIssue136
	"self reset"
	
	| versionInfo |
	versionInfo := self setUpConfigurationOfProjectIssue136dkh1.
	versionInfo := self setUpConfigurationOfProjectIssue136dkh2: {versionInfo}.! !

!MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: ''!
setUpConfigurationOfProjectIssue171
    "self reset"

    | versionInfo |
    versionInfo := self setUpConfigurationOfProjectIssue171dkh1.
    versionInfo := self setUpConfigurationOfProjectIssue171dkh2: {versionInfo}! !

!MetacelloConfigurationResource methodsFor: 'running' stamp: ''!
setUpMonticelloRepository
	"This method builds a fake repository with the version references from #buildReferences."
	"self reset"

	monticelloRepository := MCDictionaryRepository new.! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
baselineVersion20Issue119: spec
    <version: '2.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
            spec
                project: 'Foo'
                    with: [ 
                            spec
                                versionString: #'bleedingEdge';
                                className: 'MetacelloTestConfigurationOfFoo';
                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
                yourself.
            spec package: 'GoferBar ' ]! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
setUpIssue77B
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfIssue77B-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline10B:'
						category: 'cat'
						timeStamp: ''
						source: self baseline10MethodSourceB.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
baseline10B: spec 
	"self reset"
	<version: '1.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'C' with: [
				spec
					className: 'MetacelloTestConfigurationOfIssue77C';
					loads: #('GoferFoo');
					versionString: '1.2';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			package: 'GoferBeau' with: 'GoferBeau-dkh.53';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version130ProjectToolBox: spec
	<version: '1.3.0-baseline'>

	spec for: #'common' do: [
		spec 
			project: 'Example Project' with: [
				spec
					className: 'MetacelloExampleProjectConfig';
					versionString: '1.0-baseline';
					preLoadDoIt: #'preloadDoIt';
					postLoadDoIt: #'postloadDoIt';
					repository: 'http://www.example.com/ob' ];
			project: 'Copy Project' copyFrom: 'Example Project' with: [
				spec repository: 'http://www.example.com/or' ]. ].! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
stableVersion283A: spec
  "self reset"

  <symbolicVersion: #'stable'>
  spec for: #'common' version: '2.0'! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
setUpConfigurationOfProjectIssue119dkh6: ancestors
    "versions 1.0, 2.0. 3.0,4.0, 4.1, 4.2, 4.3, 4.4"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.6'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion10Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion10Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion20Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion20Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion30Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion30Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion40Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion40Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version10Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version10Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version20Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version20Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version30Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version30Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version40Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version40Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version41Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version41Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version42Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version42Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version43Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version43Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version44Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version44Issue119:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: ancestors)
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'accessing' stamp: ''!
monticelloRepository
	^ monticelloRepository! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version101ProjectToolBox: spec
	<version: '1.0.1-baseline'>

	spec for: #'common' do: [
		spec blessing: #'testBlessing'. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version131ProjectToolBox: spec
	<version: '1.3.1-baseline'>

	spec for: #'common' do: [
		spec blessing: #'baseline'. ].

	spec for: #'level1_1' do: [
		spec 
			package: 'Example-Core' with: [
				spec repository: 'http://www.example.com/1'. ];
			package: 'Example-Core' with: [
				spec repository: 'http://www.example.com/2'. ];
			package: 'Example-Core' with: [
				spec repository: 'http://www.example.com/3'. ].

		spec for: #'level2_1' do: [
			spec package: 'Example-Core' with: [
					spec repository: 'http://www.example.com/4'. ].

			spec for: #'level3_1' do: [
				spec package: 'Example-Core' with: [
						spec repository: 'http://www.example.com/5'. ]. ]. ].

		spec for: #'level2_2' do: [
			spec package: 'Example-Core' with: [
					spec repository: 'http://www.example.com/6'. ].

			spec for: #'level3_2' do: [
				spec package: 'Example-Core' with: [
						spec repository: 'http://www.example.com/7'. ]. ]. ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFoe' stamp: ''!
baseline40ProjectFoe: spec 
	"projects and packages"
	"self reset"
	<version: '4.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec 
			project: 'Foo' with: [
				spec
					className: 'MetacelloTestConfigurationOfFoo';
					versionString: '4.0';
					loads: '1';
					file: 'MetacelloTestConfigurationOfFoo';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version105ProjectToolBox: spec
	<version: '1.0.5-baseline'>

	spec for: #'common' do: [
		spec package: 'Example-Core' with: [
				spec repository: 'http://www.example.com/ob'. ]. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: ''!
setUpConfigurationOfProjectIssue136dkh1
	"self reset"
	
	| reference className definitionArray versionInfo |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue136-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baselineVersion10Issue136:'
						category: 'cat'
						timeStamp: ''
						source: (self class sourceCodeAt: #baselineVersion10Issue136:) asString.
					MCMethodDefinition 
						className: className asString
						selector: 'version10Issue136:'
						category: 'cat'
						timeStamp: ''
						source: (self class sourceCodeAt: #version10Issue136:) asString.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (versionInfo := MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #()).
	^versionInfo! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
setUpIssue156ConfigurationOfProjectGoo
  "https://github.com/dalehenrich/metacello-work/issues/156"

  "self reset"

  | reference className definitionArray |
  reference := GoferVersionReference name: 'ConfigurationOfProjectGoo-dkh.1'.
  className := reference packageName asSymbol.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: className)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: className
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    selector: 'version10Issue156:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version10Issue156:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'version11Issue156:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version11Issue156:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'version20Issue156:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version20Issue156:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'version30Issue156:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version30Issue156:') asString)}.
  monticelloRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version112ProjectToolBox: spec
	<version: '1.1.2-baseline'>

	spec for: #'common' do: [
		spec package: 'Example-Core'.

		spec for: #'nested' do: [
			spec 
				package: 'Example-Base';
				package: 'Example-Test-Nested'. ]. ].

	spec for: #'extra' do: [
		spec package: 'Example-Test'. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version118ProjectToolBox: spec
	<version: '1.1.8-baseline' imports: #('1.0-baseline' )>

	spec for: #'common' do: [
		spec package: 'Example-Core' with: [
				spec preLoadDoIt: #'alternatePreloadForCore'. ]. ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: ''!
baselineVersion20Issue171: spec
    <version: '2.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
            spec
                project: 'Foo'
                    with: [ 
                            spec
                                className: 'MetacelloTestConfigurationOfFoo';
                                repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
                yourself.
            spec package: 'GeauxFoo' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFie' stamp: ''!
setUpConfigurationOfProjectFie
    "self reset"

    | reference className definitionArray |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectFie-dkh.1'.
    className := reference packageName asSymbol.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: className)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline15ProjectFie:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baseline15ProjectFie:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline25ProjectFie:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baseline25ProjectFie:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline35ProjectFie:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baseline35ProjectFie:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'baseline40ProjectFie:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baseline40ProjectFie:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
setUpConfigurationOfProjectIssue119dkh7: ancestors
    "versions 5.0"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.7'.
    className := reference packageName asSymbol.
    definitionArray := {(MCClassDefinition
        name: className
        superclassName: #'Object'
        category: className
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectClassMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'project'
        category: 'cat'
        timeStamp: ''
        source: self projectMethodSource).
    (MCMethodDefinition
        className: className asString
        selector: 'baselineVersion40Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineVersion40Issue119:') asString).
    (MCMethodDefinition
        className: className asString
        selector: 'version50Issue119:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version50Issue119:') asString)}.
    monticelloRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: ancestors)
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baseline40MethodSourceFoo

	^(self class sourceCodeAt: #baseline40Foo:) asString! !

!MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: ''!
setUpConfigurationOfProjectIssue115
	"self reset"
	
	| versionInfo |
	versionInfo := self setUpConfigurationOfProjectIssue115dkh1.
	versionInfo := self setUpConfigurationOfProjectIssue115dkh2: {versionInfo}.! !

!MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: ''!
setUpConfigurationOfProjectIssue115dkh2: ancestors
	"self reset"
	
	| reference className definitionArray versionInfo |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue115-dkh.2'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baselineVersion10Issue115:'
						category: 'cat'
						timeStamp: ''
						source: (self class sourceCodeAt: #baselineVersion10Issue115:) asString.
					MCMethodDefinition 
						className: className asString
						selector: 'version10Issue115:'
						category: 'cat'
						timeStamp: ''
						source: (self class sourceCodeAt: #version10Issue115:) asString.
					MCMethodDefinition 
						className: className asString
						selector: 'version11Issue115:'
						category: 'cat'
						timeStamp: ''
						source: (self class sourceCodeAt: #version11Issue115:) asString.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (versionInfo := MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: ancestors)
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #()).
	^versionInfo! !

!MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: ''!
baseline40ProjectInfinite: spec 
	"self reset"
	<version: '4.0'>
	
	spec for: #common do: [
		spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
		spec
			project: 'Loop' with: [
				spec
					className: 'MetacelloTestConfigurationOfProjectLoop';
					versionString: '4.0';
					loads: 'GeauxBeau';
					repository: 'dictionary://Metacello_Configuration_Test_Repository' ];
			yourself.
		spec 
			package: 'GeauxBar' with: [
				spec
					file: 'GeauxBar.branch-lr.2';
					requires: 'Loop';
					yourself ];
			package: 'GoferBar' with: 'GoferBar-lr.1';
			yourself ].! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
version41Issue119: spec
    <version: '4.1' imports: #('4.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec project: 'Foo ' with: '2.0'.
            spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: ''!
version40SymbolicMethodSourceSymbolic

	^(self class sourceCodeAt: #version40Symbolic:) asString! !

!MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: ''!
setUpConfigurationOfProjectIssue115dkh1
	"self reset"
	
	| reference className definitionArray versionInfo |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue115-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baselineVersion10Issue115:'
						category: 'cat'
						timeStamp: ''
						source: (self class sourceCodeAt: #baselineVersion10Issue115:) asString.
					MCMethodDefinition 
						className: className asString
						selector: 'version10Issue115:'
						category: 'cat'
						timeStamp: ''
						source: (self class sourceCodeAt: #version10Issue115:) asString.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (versionInfo := MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #()).
	^versionInfo! !

!MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: ''!
version20Issue156: spec
  "https://github.com/dalehenrich/metacello-work/issues/156"

  <version: '2.0.0'>
  spec
    for: #'common'
    do: [ 
      spec
        configuration: 'Goo'
          with: [ 
              spec
                versionString: '4.0.0';
                repository:
                    'dictionary://Metacello_MczConfiguration_Test_Repository' ];
        yourself ]! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
projectVersion20Issue283: spec
  <version: '2.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'release'.
      spec
        configuration: 'ProjectIssue283'
        with: [ 
          spec
            version: #'bleedingEdge';
            repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
baseline40Foo: spec
  "self reset"

  <version: '4.0'>
  spec
    for: #'common'
    do: [ 
      spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
      spec
        package: 'GoferFoo' with: 'GoferFoo-lr.1';
        package: 'GoferBar' with: 'GoferBar-lr.1';
        package: 'GoferFaux' with: 'GoferFaux-tg.32';
        package: 'GoferBeau' with: 'GoferBeau-dkh.55';
        yourself.
      spec
        group: '1' with: #('GoferFoo' 'GoferBar');
        group: '2' with: #('GoferFoo' 'GoferFaux');
        yourself ]! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
projectMethodSource

	^(self class sourceCodeAt: #project) asString! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
setUpConfigurationOfProjectIssue283
  "self reset"

  | versionInfo |
  versionInfo := self setUpConfigurationOfProjectIssue283dkh1.
  versionInfo := self setUpConfigurationOfProjectIssue283dkh2: {versionInfo}.
  self setUpConfigurationOfProjectConfigIssue283dkh1! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
setUpIssue156ConfigurationOfGoo
  "https://github.com/dalehenrich/metacello-work/issues/156"

  "self reset"

  | reference className definitionArray |
  reference := GoferVersionReference name: 'ConfigurationOfGoo-dkh.1'.
  className := reference packageName asSymbol.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: className)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: className
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    selector: 'baselineGoo300Issue156Configuration:'
    category: 'cat'
    timeStamp: ''
    source:
      (self class sourceCodeAt: #'baselineGoo300Issue156Configuration:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'baselineGoo400Issue156Configuration:'
    category: 'cat'
    timeStamp: ''
    source:
      (self class sourceCodeAt: #'baselineGoo400Issue156Configuration:') asString).
  (MCMethodDefinition
    className: className asString
    selector: 'baselineGoo500Issue156Configuration:'
    category: 'cat'
    timeStamp: ''
    source:
      (self class sourceCodeAt: #'baselineGoo500Issue156Configuration:') asString)}.
  monticelloRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version114ProjectToolBox: spec
	<version: '1.1.4-baseline'>

	spec for: #'common' do: [
		spec project: 'Example Project' with: [
				spec
					className: 'MetacelloExampleProjectConfig';
					versionString: '1.0-baseline';
					preLoadDoIt: #'preloadForProject';
					postLoadDoIt: #'postloadForProject';
					repository: 'http://www.example.com/ob' ]. ].! !

!MetacelloConfigurationResource methodsFor: 'issue 283' stamp: ''!
bleedingEdge206A: spec
  "self reset"

  <symbolicVersion: #'bleedingEdge'>
  spec for: #'common' version: '2.0'! !

!MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: ''!
setUpConfigurationOfProjectIssue119
    "self reset"

    | versionInfo |
    versionInfo := self setUpConfigurationOfProjectIssue119dkh1.
    versionInfo := self setUpConfigurationOfProjectIssue119dkh2: {versionInfo}.
    versionInfo := self setUpConfigurationOfProjectIssue119dkh3: {versionInfo}.
    versionInfo := self setUpConfigurationOfProjectIssue119dkh4: {versionInfo}.
    versionInfo := self setUpConfigurationOfProjectIssue119dkh5: {versionInfo}.
    versionInfo := self setUpConfigurationOfProjectIssue119dkh6: {versionInfo}.
    versionInfo := self setUpConfigurationOfProjectIssue119dkh7: {versionInfo}! !

!MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: ''!
setUpIssue77C
	"self reset"
	
	| reference className definitionArray |
	reference := GoferVersionReference name: 'MetacelloTestConfigurationOfIssue77C-dkh.1'.
	className := reference packageName asSymbol.
	definitionArray := {
					MCOrganizationDefinition categories: (Array with: className).
					MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''.
					MCMethodDefinition 
						className: className asString
						classIsMeta: true
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectClassMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'project'
						category: 'cat'
						timeStamp: ''
						source: self projectMethodSource.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline12C:'
						category: 'cat'
						timeStamp: ''
						source: self baseline12MethodSourceC.
					MCMethodDefinition 
						className: className asString
						selector: 'baseline13C:'
						category: 'cat'
						timeStamp: ''
						source: self baseline13MethodSourceC.
				}.
	monticelloRepository basicStoreVersion: (MCVersion new
		setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
		info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
		snapshot: (MCSnapshot fromDefinitions: definitionArray)
		dependencies: #())! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: ''!
version110ProjectToolBox: spec
	<version: '1.1.0-baseline'>

	spec for: #'common' do: [
		spec 
			package: 'Example-Core';
			package: 'Example-Base';
			package: 'Example-Test1' with: [
				spec 
					requires: #('Example-Base' );
					includes: #('Example-Core' ). ];
			package: 'Example-Test2' with: [
				spec 
					includes: #('Example-Core' );
					supplyingAnswers: #( #( 'captionMatch' 'answer' ) ). ];
			package: 'Example-Test3' with: [
				spec 
					requires: #('Example-Base' );
					supplyingAnswers: #( #( 'captionMatch' 'answer' ) ). ];
			package: 'Example-Test4' with: [
				spec 
					requires: #('Example-Base' );
					includes: #('Example-Core' );
					supplyingAnswers: #( #( 'captionMatch' 'answer' ) ). ]. ].! !

!MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: ''!
bleedingEdgeVersion: spec
    "self reset"

    <symbolicVersion: #'bleedingEdge'>
    spec for: #'common' version: '4.0'! !

!MetacelloConfigurationResource class methodsFor: 'accessing' stamp: ''!
project

	^self new project! !

!MetacelloConfigurationResource class methodsFor: 'accessing' stamp: ''!
projectAttributes: aCollection

	ProjectAttributes := aCollection! !

!MetacelloConfigurationResource class methodsFor: 'accessing' stamp: ''!
projectAttributes

	ProjectAttributes == nil ifTrue: [ ^#() ].
	^ProjectAttributes! !

!MetacelloConfigurationSpecGenerator methodsFor: 'accessing' stamp: ''!
projectSpecCreationBlock
    ^ [ :projectName | {(MetacelloMCProject new configurationOfProjectSpec name: projectName)} ]! !

!MetacelloConfigurationSpecGenerator methodsFor: 'accessing' stamp: ''!
projectSpecListBlock
    ^ [ MetacelloProjectRegistration configurationProjectSpecs ]! !

!MetacelloConfigurationSpecGenerator methodsFor: 'accessing' stamp: ''!
projectSpecLookupBlock
    ^ [ :projectName | 
    {(MetacelloProjectRegistration
        projectSpecForClassNamed: (MetacelloScriptEngine configurationNameFrom: projectName)
        ifAbsent: [  ])} ]! !

!MetacelloCopyMemberSpec methodsFor: 'actions' stamp: ''!
applyToList: aListSpec

	aListSpec copy: self! !

!MetacelloCopyMemberSpec methodsFor: 'accessing' stamp: ''!
sourceName: aString

	sourceName := aString! !

!MetacelloCopyMemberSpec methodsFor: 'actions' stamp: ''!
applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock
    copyBlock value: self! !

!MetacelloCopyMemberSpec methodsFor: 'accessing' stamp: ''!
methodUpdateSelector

	^#copy:! !

!MetacelloCopyMemberSpec methodsFor: 'accessing' stamp: ''!
sourceName

	^sourceName! !

!MetacelloCoreIssue125TestCase methodsFor: 'accessing' stamp: ''!
projectWith: projectAttributes
    | project |
    "Construct Metacello project"
    project := MetacelloProject new.
    project projectAttributes: projectAttributes.
    MetacelloVersionConstructor on: self project: project.
    ^ project! !

!MetacelloCoreIssue125TestCase methodsFor: 'tests' stamp: ''!
testForDoListAtrribute1Active
	"https://github.com/dalehenrich/metacello-work/issues/125"

	| project version expected actual |
	project := self projectWith: #(#attribute1).
	version := project version: '3.0-baseline'.
	expected := 'spec blessing: #''baseline''.
spec preLoadDoIt: #''preloadForCore''.
spec postLoadDoIt: #''postloadForCore:package:''.
spec 
	project: ''Example Project'' with: [
		spec
			className: ''ConfigurationOfExampleProject'';
			versionString: ''1.0-baseline'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'';
			loads: #(''core'' ) ];
	project: ''Extra Project'' with: [
		spec
			className: ''ConfigurationOfExtraProject'';
			versionString: ''1.0-baseline'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'';
			loads: #(''core'' ) ].
spec 
	group: ''Core'' with: #(''Example Project'' );
	group: ''Core'' with: #(''Extra Project'' ).'.
	actual := version spec printString.
	self assert: expected equals: actual! !

!MetacelloCoreIssue125TestCase methodsFor: 'tests' stamp: ''!
testForDoListAttribute1Atrribute2Active
	"https://github.com/dalehenrich/metacello-work/issues/125"

	| project version expected actual |
	project := self projectWith: #(#attribute1 #attribute2).
	version := project version: '3.0-baseline'.
	expected := 'spec blessing: #''baseline''.
spec preLoadDoIt: #''preloadForCore''.
spec postLoadDoIt: #''postloadForCore:package:''.
spec 
	project: ''Example Project'' with: [
		spec
			className: ''ConfigurationOfExampleProject'';
			versionString: ''1.0-baseline'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'';
			loads: #(''core'' ) ];
	project: ''Extra Project'' with: [
		spec
			className: ''ConfigurationOfExtraProject'';
			versionString: ''1.0-baseline'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'';
			loads: #(''core'' ) ];
	project: ''Extra Project'' with: [
		spec
			className: ''ConfigurationOfExtraProject'';
			versionString: ''1.0-baseline'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'';
			loads: #(''core'' ) ].
spec 
	group: ''Core'' with: #(''Example Project'' );
	group: ''Core'' with: #(''Extra Project'' );
	group: ''Core'' with: #(''Extra Project'' ).'.
	actual := version spec printString.
	self assert: expected equals: actual! !

!MetacelloCoreIssue125TestCase methodsFor: 'baselines' stamp: ''!
baseline200: spec
    <version: '2.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec
                preLoadDoIt: #'preloadForCore';
                postLoadDoIt: #'postloadForCore:package:'.
            spec
                project: 'Example Project'
                    with: [ 
                            spec
                                className: 'ConfigurationOfExampleProject';
                                versionString: '1.0-baseline';
                                preLoadDoIt: #'preloadForProject';
                                postLoadDoIt: #'postloadForProject';
                                loads: #('core');
                                yourself ];
                yourself.
            spec group: 'Core' with: #('Example Project') ]! !

!MetacelloCoreIssue125TestCase methodsFor: 'accessing' stamp: ''!
project

	^self projectWith: #()! !

!MetacelloCoreIssue125TestCase methodsFor: 'tests' stamp: ''!
testForDoListAtrribute2Active
	"https://github.com/dalehenrich/metacello-work/issues/125"

	| project version expected actual |
	project := self projectWith: #(#attribute2).
	version := project version: '3.0-baseline'.
	expected := 'spec blessing: #''baseline''.
spec preLoadDoIt: #''preloadForCore''.
spec postLoadDoIt: #''postloadForCore:package:''.
spec 
	project: ''Example Project'' with: [
		spec
			className: ''ConfigurationOfExampleProject'';
			versionString: ''1.0-baseline'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'';
			loads: #(''core'' ) ];
	project: ''Extra Project'' with: [
		spec
			className: ''ConfigurationOfExtraProject'';
			versionString: ''1.0-baseline'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'';
			loads: #(''core'' ) ].
spec 
	group: ''Core'' with: #(''Example Project'' );
	group: ''Core'' with: #(''Extra Project'' ).'.
	actual := version spec printString.
	self assert: expected equals: actual! !

!MetacelloCoreIssue125TestCase methodsFor: 'tests' stamp: ''!
testForDoListNotActive
	"https://github.com/dalehenrich/metacello-work/issues/125"

	| project version expected actual |
	project := self projectWith: #().
	version := project version: '3.0-baseline'.
	expected := 'spec blessing: #''baseline''.
spec preLoadDoIt: #''preloadForCore''.
spec postLoadDoIt: #''postloadForCore:package:''.
spec project: ''Example Project'' with: [
		spec
			className: ''ConfigurationOfExampleProject'';
			versionString: ''1.0-baseline'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'';
			loads: #(''core'' ) ].
spec group: ''Core'' with: #(''Example Project'' ).'.
	actual := version spec printString.
	self assert: expected equals: actual! !

!MetacelloCoreIssue125TestCase methodsFor: 'baselines' stamp: ''!
baseline300: spec
    <version: '3.0-baseline' imports: #('2.0-baseline')>
    spec
        for: #(#'attribute1' #'attribute2')
        do: [ 
            spec
                project: 'Extra Project'
                    with: [ 
                            spec
                                className: 'ConfigurationOfExtraProject';
                                versionString: '1.0-baseline';
                                preLoadDoIt: #'preloadForProject';
                                postLoadDoIt: #'postloadForProject';
                                loads: #('core');
                                yourself ];
                yourself.
            spec group: 'Core' with: #('Extra Project') ]! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'accessing' stamp: ''!
projectWith: projectAttributes
    | project |
    "Construct Metacello project"
    project := MetacelloProject new.
    project projectAttributes: projectAttributes.
    MetacelloVersionConstructor on: self project: project.
    ^ project! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'tests' stamp: ''!
testBleedingEdgeMethod
	| project |
	project := self projectWith: #(#'platformVersion1.x').
	self assert: (project version: #bleedingEdge) equals: project bleedingEdge! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'tests' stamp: ''!
testStableVersionMethod
	| project |
	project := self projectWith: #(#'platformVersion1.x').
	self assert: (project version: #stable) equals: project stableVersion! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'baselines' stamp: ''!
baseline20: spec
    <version: '2.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec
                project: 'Example Project'
                with: [ 
                    spec
                        className: 'MetacelloExampleProjectConfig';
                        versionString: '1.0-baseline';
                        preLoadDoIt: #'preloadForProject';
                        postLoadDoIt: #'postloadForProject';
                        yourself ] ]! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'versions' stamp: ''!
version10: spec
    <version: '1.0' imports: #('1.0-baseline')>
    spec for: #'common' do: [ spec blessing: #'release' ]! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'versions' stamp: ''!
bleedingEdge: spec
    <symbolicVersion: #'bleedingEdge'>
    spec for: #'platformVersion1.x' version: '1.0-baseline'! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'versions' stamp: ''!
stableVersion: spec
    <symbolicVersion: #'stable'>
    spec for: #'platformVersion1.x' version: '1.0'! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'accessing' stamp: ''!
project

	^self projectWith: #()! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'tests' stamp: ''!
testBasicStableVersion
	| project version expected actual |
	project := self projectWith: #(#'platformVersion1.x').
	version := project version: #stable.
	expected := 'spec blessing: #''release''.
spec project: ''Example Project'' with: [
		spec
			className: ''MetacelloExampleProjectConfig'';
			versionString: ''1.0-baseline'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'' ].'.
	actual := version spec printString.
	self assert: expected equals: actual! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'baselines' stamp: ''!
baseline10: spec
    <version: '1.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'baseline'.
            spec
                project: 'Example Project'
                with: [ 
                    spec
                        className: 'MetacelloExampleProjectConfig';
                        versionString: '1.0-baseline';
                        preLoadDoIt: #'preloadForProject';
                        postLoadDoIt: #'postloadForProject';
                        yourself ] ]! !

!MetacelloCoreSymbolicVersionTest methodsFor: 'tests' stamp: ''!
testBasicBleedingEdgeVersion
	| project version expected actual |
	project := self projectWith: #(#'platformVersion1.x').
	version := project version: #bleedingEdge.
	expected := 'spec blessing: #''baseline''.
spec project: ''Example Project'' with: [
		spec
			className: ''MetacelloExampleProjectConfig'';
			versionString: ''1.0-baseline'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'' ].'.
	actual := version spec printString.
	self assert: expected equals: actual! !

!MetacelloCoreVersionQueryTestCase methodsFor: 'accessing' stamp: ''!
projectWith: projectAttributes
    | project |
    "Construct Metacello project"
    project := MetacelloProject new.
    project projectAttributes: projectAttributes.
    MetacelloVersionConstructor on: self project: project.
    ^ project! !

!MetacelloCoreVersionQueryTestCase methodsFor: 'baselines' stamp: ''!
baseline20: spec
    <version: '2.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec
                project: 'UTF8'
                with: [ 
                    spec
                        className: 'MetacelloVersionQueryMiscConfig';
                        versionString: #'stable';
                        loads: #('Misc-UTF8') ].
            spec
                project: 'UTF9'
                with: [ 
                    spec
                        className: 'MetacelloVersionQueryOtherConfig';
                        versionString: '1.0-baseline';
                        loads: #('Misc-UTF8') ].
            spec
                group: 'Core' with: #('UTF8' 'UTF9');
                group: 'Tests' with: #('UTF8');
                group: 'Recursive' with: #('Core' 'Recursive')	"recursive group definition" ]! !

!MetacelloCoreVersionQueryTestCase methodsFor: 'tests' stamp: ''!
testDifference
	| project expected fromVersionString toVersionString report actual |
	project := self project.
	fromVersionString := '1.1-baseline'.
	toVersionString := '2.0-baseline'.
	report := (project version: fromVersionString) difference: (project version: toVersionString).
	report
		from: fromVersionString;
		to: toVersionString;
		configuration: 'Test Configuration'.
	expected := 'Test Configuration ''1.1-baseline'' to ''2.0-baseline''
	Additions:
		UTF9
			'''' to ''1.0-baseline''
	Modifications:
		UTF8
			''1.0-baseline'' to ''stable''
	Removals:
		UTF7
			''1.0-baseline'' to ''''
'.
	actual := report printString.
	self assert: expected equals: actual! !

!MetacelloCoreVersionQueryTestCase methodsFor: 'accessing' stamp: ''!
project

	^self projectWith: #()! !

!MetacelloCoreVersionQueryTestCase methodsFor: 'baselines' stamp: ''!
baseline10: spec
    <version: '1.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec
                project: 'UTF8'
                with: [ 
                    spec
                        className: 'MetacelloVersionQueryMiscConfig';
                        versionString: '1.0-baseline';
                        loads: #('Misc-UTF8') ].
            spec
                group: 'Core' with: #('UTF8');
                group: 'Tests' with: #('UTF8');
                group: 'Recursive' with: #('Core' 'Recursive')	"recursive group definition" ]! !

!MetacelloCoreVersionQueryTestCase methodsFor: 'tests' stamp: ''!
testBaseline10ResolveToLoadableSpecs01
	| project version expected list |
	project := self project.
	version := project version: '1.0-baseline'.
	expected := #('UTF8').
	list := version resolveToLoadableSpecs: #('UTF8').
	self assert: list size equals: expected size.
	list do: [ :pkg | self assert: (expected includes: pkg name) ].
	expected := #('UTF8').
	list := version resolveToLoadableSpecs: #('Recursive').
	self assert: list size equals: expected size.
	list do: [ :pkg | self assert: (expected includes: pkg name) ]! !

!MetacelloCoreVersionQueryTestCase methodsFor: 'tests' stamp: ''!
testBaseline10Projects
	| project version expected list |
	project := self project.
	version := project version: '1.0-baseline'.
	expected := #('UTF8').
	list := version projects.
	self assert: list size equals: expected size.
	list do: [ :pkg | self assert: (expected includes: pkg name) ]! !

!MetacelloCoreVersionQueryTestCase methodsFor: 'baselines' stamp: ''!
baseline11: spec
    <version: '1.1-baseline' imports: #('1.0-baseline')>
    spec
        for: #'common'
        do: [ 
            spec
                project: 'UTF7'
                with: [ 
                    spec
                        className: 'MetacelloVersionQueryMiscConfig';
                        versionString: '1.0-baseline';
                        loads: #('Misc-UTF7') ].
            spec
                group: 'Core' with: #('UTF7');
                group: 'Tests' with: #('UTF7');
                yourself ]! !

!MetacelloCoreVersionQueryTestCase methodsFor: 'tests' stamp: ''!
testBaseline10Groups
	| project version expected list |
	project := self project.
	version := project version: '1.0-baseline'.
	expected := #('Core' 'Tests' 'Recursive').
	list := version groups.
	self assert: list size equals: expected size.
	list do: [ :pkg | self assert: (expected includes: pkg name) ]! !

!MetacelloCypressBaselineProject commentStamp: ''!
The **MetacelloCypressBaselineProject**  is a wrapper for the **BaselineOf** version specification for file-based repositories specific to metadataless export format. (Filetree/Tonel)

It should be used by metadataless repositories (FileTree/Tonel). To use it the **BaselineOf** needs to redefine this method:

```Smalltalk
	projectClass
	    ^ MetacelloMCBaselineProject
```

Metacello has an internal rule to not load Monticello packages of the same version, since they are already loaded. However, when using metadataless repositories the filetree/tonel Monticello package readers typically generate a package name using the author/version `-cypress.1`, which make Metacello think that the versions are the same and the package is not loaded. By including the above method in your baselineof, Metacello will know to ignore the Monticello author/version of the package and always load it.!
!MetacelloCypressBaselineProject methodsFor: 'spec classes' stamp: ''!
baselineOfProjectSpecClass
    ^ MetacelloCypressBaselineProjectSpec! !

!MetacelloCypressBaselineProject methodsFor: 'spec classes' stamp: ''!
packageSpecClass
  ^ MetacelloCypressPackageSpec! !

!MetacelloCypressBaselineProject class methodsFor: 'accessing' stamp: ''!
useCypressPackagesForAllBaselines: aBool
	"self useCypressPackagesForAllBaselines: true"

	UseCypressPackagesForAllBaselines := aBool! !

!MetacelloCypressBaselineProject class methodsFor: 'accessing' stamp: ''!
useCypressPackagesForAllBaselines
  UseCypressPackagesForAllBaselines ifNil: [ ^ false ].
  ^ UseCypressPackagesForAllBaselines! !

!MetacelloCypressBaselineProjectSpec commentStamp: ''!
I am a project spec specific to metadataless projects (filetree/tonel).!
!MetacelloCypressBaselineProjectSpec methodsFor: 'merging' stamp: ''!
validateMergeForSpec: aSpec
	"This method is needed because without it, it is not possible to use a MetacelloCypressBaselineProject kind of project and copy a dependency definition via #project:copyFrom:with:.
	
	Do not remove if you don't really know what you are doing!!"! !

!MetacelloCypressPackageSpec commentStamp: ''!
I am a package spec specific to metadataless projects (filetree/tonel).!
!MetacelloCypressPackageSpec methodsFor: 'fetching' stamp: ''!
searchCacheRepositoryForPackage: searchBlock
  "evaluate the <searchBlock> if you want to search for the package in a local package cache"

  "for Cypress packages the answer is NO!!"! !

!MetacelloCypressPackageSpec methodsFor: 'testing' stamp: ''!
compareCurrentVersion: anOperator targetVersionStatus: statusIgnored using: anMCLoader
  ^ false! !

!MetacelloCypressPackageSpec methodsFor: 'querying' stamp: ''!
isPackageLoaded: aLoader
  MCWorkingCopy allManagers
    detect: [ :wc | wc packageName = self file ]
    ifNone: [ ^ false ].
  ^ true! !

!MetacelloCypressPackageSpec methodsFor: 'querying' stamp: ''!
ancestors
  ^ nil! !

!MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: ''!
configurationRepository
	"MetacelloConfigurationResource reset"

	^ MetacelloConfigurationResource current monticelloRepository! !

!MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: ''!
tearDownPackages: aGoferInstance

	(self hasPackage: 'GoferFoo')
		ifTrue: [ aGoferInstance package: 'GoferFoo' ].
	(self hasPackage: 'GoferBar')
		ifTrue: [ aGoferInstance package: 'GoferBar' ].
	(self hasPackage: 'GoferFaux')
		ifTrue: [ aGoferInstance package: 'GoferFaux' ].
	(self hasPackage: 'GoferBeau')
		ifTrue: [ aGoferInstance package: 'GoferBeau' ].
	(self hasPackage: 'MetacelloTestConfigurationOfFoo')
		ifTrue: [ aGoferInstance package: 'MetacelloTestConfigurationOfFoo' ].! !

!MetacelloDictionaryRepositoryTest methodsFor: 'utilities' stamp: ''!
hasPackage: aString

	^ MCWorkingCopy allManagers
		anySatisfy: [ :each | each packageName = aString ]! !

!MetacelloDictionaryRepositoryTest methodsFor: 'accessing' stamp: ''!
projectWith: projectAttributes

	| project |
	"Construct Metacello project"
	project := MetacelloMCProject new.
	project projectAttributes: projectAttributes.
	MetacelloVersionConstructor on: self project: project.
	project loader: 
		((project loaderClass new)
			shouldDisablePackageCache: true;
			yourself).
	project loadType: self loadType.
	^project! !

!MetacelloDictionaryRepositoryTest methodsFor: 'accessing' stamp: ''!
monticelloRepository
	"MetacelloMonticelloResource reset"
	^ MetacelloMonticelloResource current monticelloRepository! !

!MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: ''!
tearDown
	| aGofer finalWorkingCopyList diff |
	aGofer := Gofer new.
	self tearDownPackages: aGofer.
	aGofer references notEmpty ifTrue: [ aGofer metacelloUnload ].
	testingEnvironment removeKey: #Metacello_Gofer_Test_Repository ifAbsent: [  ].
	testingEnvironment removeKey: #Metacello_Configuration_Test_Repository ifAbsent: [  ].
	testingEnvironment removeKey: #Metacello_Configuration_Test_Alternate_Repository ifAbsent: [  ].
	self tempRepositories do: [ :repo | MCRepositoryGroup default removeIdenticalRepository: repo ].
	MetacelloPlatform current reenableUndefinedSybolUpdates: undefinedSymbols.
	finalWorkingCopyList := MCWorkingCopy allManagers collect: [ :each | each packageName ].
	diff := finalWorkingCopyList difference: initialWorkingCopyList.
	diff
		do: [ :leak | 
			self crTrace: 'leaked package from ' , self printString , ' -> ' , leak printString ].
	self assertEmpty: diff.
	super tearDown! !

!MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: ''!
alternateRepository
	"MetacelloAlternateResource reset"

	^ MetacelloAlternateResource current monticelloRepository! !

!MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: ''!
doSilently

	^true! !

!MetacelloDictionaryRepositoryTest methodsFor: 'accessing' stamp: ''!
loadType

	^#linear! !

!MetacelloDictionaryRepositoryTest methodsFor: 'accessing' stamp: ''!
project

	| constructor project |
	"Construct Metacello project"
	constructor := MetacelloVersionConstructor on: self.
	project := constructor project.
	project loader: 
		((project loaderClass new)
			shouldDisablePackageCache: true;
			yourself).
	project loadType: self loadType.
	^project! !

!MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: ''!
runCase
	| original |
	(self doSilently) ifFalse: [ ^super runCase ].
	original := MetacelloPlatform current bypassGoferLoadUpdateCategories.
	[ 
	MetacelloPlatform current bypassGoferLoadUpdateCategories: true.
	^ MetacelloPlatform current suspendSystemUpdateEventsDuring: [ super runCase ] ]
		ensure: [ MetacelloPlatform current bypassGoferLoadUpdateCategories: original ]! !

!MetacelloDictionaryRepositoryTest methodsFor: 'accessing' stamp: ''!
tempRepositories

	tempRepositories ifNil: [ tempRepositories := OrderedCollection new ].
	^tempRepositories! !

!MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: ''!
setUp
  | repo |
  super setUp.
  MetacelloPlatform current clearPackageCache.
  MetacelloConfigurationResource projectAttributes: nil.
  repo := self monticelloRepository.
  self tempRepositories add: repo.
  gofer repository: repo.
  testingEnvironment at: #'Metacello_Gofer_Test_Repository' put: repo.
  repo := self alternateRepository.
  self tempRepositories add: repo.
  testingEnvironment at: #'Metacello_Configuration_Test_Alternate_Repository' put: repo.
  repo := self configurationRepository.
  self tempRepositories add: repo.
  testingEnvironment at: #'Metacello_Configuration_Test_Repository' put: repo.
  initialWorkingCopyList := MCWorkingCopy allManagers
    collect: [ :each | each packageName ].
  undefinedSymbols := MetacelloPlatform current disableUndefinedSybolUpdates! !

!MetacelloDirective methodsFor: 'enumerating' stamp: ''!
versionDirectivesDo: aBlock! !

!MetacelloDirective methodsFor: 'accessing' stamp: ''!
title

	self subclassResponsibility! !

!MetacelloDirective methodsFor: 'actions' stamp: ''!
addTo: aLoaderDirective

	aLoaderDirective add: self! !

!MetacelloDirective methodsFor: 'actions' stamp: ''!
loadUsing: aLoaderDirective gofer: aGofer

	self subclassResponsibility! !

!MetacelloDirective methodsFor: 'enumerating' stamp: ''!
prepostLoadDirectivesDo: aBlock! !

!MetacelloDirective methodsFor: 'actions' stamp: ''!
versionDo: aBlock! !

!MetacelloDirective methodsFor: 'printing' stamp: ''!
printOn: aStream

	self printOn: aStream indent: 0! !

!MetacelloDirective methodsFor: 'actions' stamp: ''!
packageDo: aBlock! !

!MetacelloDirective methodsFor: 'printing' stamp: ''!
printOn: aStream indent: indent

	indent timesRepeat: [ aStream tab ].
	aStream
		nextPutAll: self title;
		nextPutAll: ' : ';
		nextPutAll: self label.! !

!MetacelloDirective methodsFor: 'accessing' stamp: ''!
loader: aLoader

	loader := aLoader! !

!MetacelloDirective methodsFor: 'enumerating' stamp: ''!
packageDirectivesDo: aBlock! !

!MetacelloDirective methodsFor: 'actions' stamp: ''!
postLoadDo: aBlock! !

!MetacelloDirective methodsFor: 'enumerating' stamp: ''!
prepostLoadDo: aBlock! !

!MetacelloDirective methodsFor: 'printing' stamp: ''!
printString
	"Explicit override of superclass implementation. When you are printing a loadDirective it is annoying to have it truncated."

	^String streamContents: [:s | self printOn: s]! !

!MetacelloDirective methodsFor: 'initialization' stamp: ''!
spec: packageOrVersionSpec loader: aLoader

	spec := packageOrVersionSpec.
	loader := aLoader! !

!MetacelloDirective methodsFor: 'enumerating' stamp: ''!
directivesDo: aBlock

	aBlock value: self! !

!MetacelloDirective methodsFor: 'actions' stamp: ''!
preLoadDo: aBlock! !

!MetacelloDirective methodsFor: 'accessing' stamp: ''!
spec

	^spec! !

!MetacelloDirective methodsFor: 'enumerating' stamp: ''!
versionDirectivesDepthFirstDo: aBlock! !

!MetacelloDirective methodsFor: 'printing' stamp: ''!
label

	^self spec label! !

!MetacelloDirective methodsFor: 'accessing' stamp: ''!
loader

	^loader! !

!MetacelloDirective class methodsFor: 'instance creation' stamp: ''!
loadPackage: aPackageSpec externalReference: externalReference loader: aLoader

	^MetacelloPackageLoadDirective new
		spec: aPackageSpec externalReference: externalReference  loader: aLoader! !

!MetacelloDirective class methodsFor: 'instance creation' stamp: ''!
postLoadSpec: packageOrVersionSpec loader: aLoader

	^MetacelloPostLoadDirective new
		spec: packageOrVersionSpec loader: aLoader! !

!MetacelloDirective class methodsFor: 'instance creation' stamp: ''!
preLoadSpec: packageOrVersionSpec loader: aLoader

	^MetacelloPreLoadDirective new
		spec: packageOrVersionSpec loader: aLoader! !

!MetacelloDirective class methodsFor: 'instance creation' stamp: ''!
loader: aLoader

	^self new
		loader: aLoader! !

!MetacelloEnsureFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
scheduleFetchFor: packageSpec nearestReference: reference
  "latest version in repository already matches the cached reference...schedule a load directive for reference, so ensured load will come from cache"

  ^ self
    scheduleFetchFor: packageSpec
    reference: reference
    message:
      'Fetched -> (nearest) ' , reference name , ' --- '
        , reference repository repositoryDescription , ' --- '
        , reference repository description! !

!MetacelloEnsureFetchingMCSpecLoader methodsFor: 'accessing' stamp: ''!
ensureSpecLoader
	^ self! !

!MetacelloEnsureFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
scheduleFetchFor: packageSpec cachedReference: reference
  "reference already in the cache during fetch ...schedule a load directive for reference, so ensured load will come from cache"

  ^ self
    scheduleFetchFor: packageSpec
    reference: reference
    message:
      'Fetched -> (cached) ' , reference name , ' --- '
        , reference repository repositoryDescription , ' --- '
        , reference repository description! !

!MetacelloErrorInProjectConstructionNotification methodsFor: 'exception description' stamp: ''!
defaultAction
    "Answer false if you want the version recorded in the errorMap.
	Answer true if you want to go ahead and throw the error"

    ^ false! !

!MetacelloErrorInProjectConstructionNotification methodsFor: 'accessing' stamp: ''!
versionString: anObject
	versionString := anObject! !

!MetacelloErrorInProjectConstructionNotification methodsFor: 'accessing' stamp: ''!
exception
	^ exception! !

!MetacelloErrorInProjectConstructionNotification methodsFor: 'accessing' stamp: ''!
versionString
	^ versionString! !

!MetacelloErrorInProjectConstructionNotification methodsFor: 'accessing' stamp: ''!
exception: anObject
	exception := anObject! !

!MetacelloErrorInProjectConstructionNotification class methodsFor: 'instance creation' stamp: ''!
versionString: aString exception: anException
    ^ self new
        versionString: aString;
        exception: anException;
        signal! !

!MetacelloExampleProjectConfig methodsFor: 'baselines' stamp: ''!
baseline10: spec 
	<version: '1.0-baseline'>
	
	spec for: #common do: [
		spec 
			package: 'Example-Core';
			package: 'Example-AddOn' with: [ spec requires: #('Example-Core' ) ];
			package: 'Example-Tests' with: [ spec requires: #('Example-AddOn' ) ];
			package: 'Example-TestsUI' with: [ spec requires: #('Example-UI' 'Example-Tests' ) ];
			package: 'Example-UI' with: [ spec requires: #('Example-AddOn' ) ]].! !

!MetacelloExplicitLoadDirective methodsFor: 'actions' stamp: ''!
explicitLoadUsing: aLoaderDirective gofer: aGofer

	aLoaderDirective loadLinearLoadDirective: self gofer: aGofer.! !

!MetacelloExplicitLoadDirective methodsFor: 'actions' stamp: ''!
loadUsing: aLoaderDirective gofer: aGofer

	aLoaderDirective loadExplicitLoadDirective: self gofer: aGofer.! !

!MetacelloExplicitLoadDirective methodsFor: 'testing' stamp: ''!
isExplicit

	^true! !

!MetacelloExplicitLoadDirective methodsFor: 'actions' stamp: ''!
explicitLoadWithPolicy: aLoadPolicy

	| gofer |
	gofer := MetacelloGofer new.
	gofer disablePackageCache.
	gofer repository: aLoadPolicy cacheRepository.
	self explicitLoadUsing: self gofer: gofer! !

!MetacelloExplicitLoadDirective methodsFor: 'accessing' stamp: ''!
title

	^'explicit load'! !

!MetacelloExternalScriptingTestCase methodsFor: 'running' stamp: ''!
tearDownRepositories
  super tearDownRepositories.
  MCRepositoryGroup default
    removeIdenticalRepository:
      (testingEnvironment at: #'Metacello_XXX_Test_Repository' ifAbsent: [  ]).
  testingEnvironment removeKey: #'Metacello_Config_Test_Repository' ifAbsent: [  ].
  testingEnvironment removeKey: #'Metacello_XXX_Test_Repository' ifAbsent: [  ]! !

!MetacelloExternalScriptingTestCase methodsFor: 'running' stamp: ''!
setUpRepositoryContents
    super setUpRepositoryContents.
    testingEnvironment at: #'Metacello_Config_Test_Repository' put: configurationRepository! !

!MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
scheduleFetchFor: packageSpec reference: reference message: message
	self loaderPolicy resetCacheGofer.
	self preLoad: packageSpec.
	(MetacelloDirective loadPackage: packageSpec externalReference: reference loader: self) addTo: self loadDirective.
	self postLoad: packageSpec.
	MetacelloNotification signal: message! !

!MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
linearLoadPackageSpecs: packageSpecs repositories: repositories
	
	self loaderPolicy 
		pushLinearLoadDirectivesDuring: [ super linearLoadPackageSpecs: packageSpecs repositories: repositories ]
		 for: self! !

!MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: ''!
loadData

	^self loaderPolicy loadData! !

!MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
resolvePackageSpec: packageSpec cachedGofer: gofer

	|  versionReference references |
	versionReference := packageSpec goferLoaderReference.
	(references := versionReference resolveAllWith: gofer) isEmpty 
		ifTrue: [ ^nil ].
	^references last asMetacelloCachingResolvedReference.! !

!MetacelloFetchingMCSpecLoader methodsFor: 'versionInfo' stamp: ''!
ancestorsFor: packageSpec

	^self loadData
		ancestorsFor: packageSpec 
		ifAbsent: [ super ancestorsFor: packageSpec ]! !

!MetacelloFetchingMCSpecLoader methodsFor: 'versionInfo' stamp: ''!
currentVersionInfoFor: packageSpec

	^self loadData
		currentVersionInfoFor: packageSpec 
		ifAbsent: [ super currentVersionInfoFor: packageSpec ]! !

!MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: ''!
ensureSpecLoader
	^ (MetacelloEnsureFetchingMCSpecLoader on: self spec)
		shouldDisablePackageCache: self shouldDisablePackageCache;
		loaderPolicy: self loaderPolicy; "explicitly share the loaderPolicy"
		yourself! !

!MetacelloFetchingMCSpecLoader methodsFor: 'doits' stamp: ''!
postLoad: packageOrVersionSpec

	(MetacelloDirective postLoadSpec: packageOrVersionSpec loader: self)  addTo: self loadDirective! !

!MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
explicitLoadPackageSpecs: packageSpecs repositories: repositories
	
	| directive |
	directive := self loaderPolicy 
		pushExplicitLoadDirectivesDuring: [ super linearLoadPackageSpecs: packageSpecs repositories: repositories ]
		for: self.
	directive explicitLoadWithPolicy: self loaderPolicy.! !

!MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
scheduleFetchFor: packageSpec cachedReference: reference
	"reference already in the cache during fetch ...no need to schedule fetch"

	^ self! !

!MetacelloFetchingMCSpecLoader methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	self loadDirective printOn: aStream.
	aStream nextPut: $)! !

!MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
scheduleFetchFor: packageSpec externalReference: reference
  ^ self
    scheduleFetchFor: packageSpec
    reference: reference
    message:
      'Fetched -> ' , reference name , ' --- '
        , reference repository repositoryDescription , ' --- '
        , reference repository description! !

!MetacelloFetchingMCSpecLoader methodsFor: 'actions' stamp: ''!
linearLoadPackageSpec: packageSpec gofer: gofer
  MetacelloPlatform current
    do: [ 
      | references nearestReference cachedReference externalReference mcVersion loadedVersionInfos |
      cachedReference := nil.
      packageSpec
        searchCacheRepositoryForPackage: [ 
          "check to see if mcz file is already in cacheRepository"
          cachedReference := self
            resolvePackageSpec: packageSpec
            cachedGofer: self loaderPolicy cacheGofer.
          (cachedReference ~~ nil and: [ packageSpec getFile ~~ nil ])
            ifTrue: [ 
              cachedReference name = packageSpec file
                ifTrue: [ 
                  "exact match between packageSpec file and cache"
                  ^ self
                    scheduleFetchFor: packageSpec
                    cachedReference: cachedReference ] ] ].
      references := self
        retryingResolvePackageSpecReferences: packageSpec
        gofer: gofer.	"look up mcz file"
      nearestReference := references last asMetacelloCachingResolvedReference.
      (cachedReference ~~ nil
        and: [ cachedReference name = nearestReference name ])
        ifTrue: [ 
          "latest reference in repository matches cachedReference ... "
          ^ self
            scheduleFetchFor: packageSpec
            nearestReference: nearestReference ].
      (self ignoreImage not
        and: [ (loadedVersionInfos := self ancestorsFor: packageSpec) ~~ nil ])
        ifTrue: [ 
          "If the mcz is already loaded into the image, no need to copy"
          loadedVersionInfos
            do: [ :info | 
              info name = nearestReference name
                ifTrue: [ 
                  | spc |
                  spc := packageSpec copy.
                  spc file: info name.
                  (MetacelloIgnorePackageLoaded signal: spc)
                    ifFalse: [ ^ self ] ] ] ].
      externalReference := (references
        select: [ :ref | ref name = nearestReference name ]) first
        asMetacelloCachingResolvedReference.
      self repositoryMap
        at: externalReference name
        put: externalReference repository.
      (self
        resolveDependencies: externalReference
        nearest: nearestReference
        into: (OrderedCollection with: nearestReference))
        do: [ :reference | 
          | pSpec l |
          mcVersion := reference version.
          (l := (GoferVersionReference name: reference name)
            resolveAllWith: self loaderPolicy cacheGofer) isEmpty
            ifTrue: [ 
              self cacheRepository storeVersion: mcVersion.
              reference == nearestReference
                ifTrue: [ pSpec := packageSpec ]
                ifFalse: [ 
                  pSpec := packageSpec project packageSpec.
                  pSpec name: mcVersion package name ].
              self loadData
                addVersion: mcVersion
                versionInfo: mcVersion info
                resolvedReference: reference
                packageSpec: pSpec ] ].
      self scheduleFetchFor: packageSpec externalReference: externalReference ]
    displaying: 'Fetching ' , packageSpec file! !

!MetacelloFetchingMCSpecLoader methodsFor: 'actions' stamp: ''!
doLoad

	self loaderPolicy copy load! !

!MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
scheduleFetchFor: packageSpec nearestReference: reference
	"latest version in repository already matches the cached reference...no need to schedule fetch"

	^ self! !

!MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: ''!
actionLabel

	^'Fetching '! !

!MetacelloFetchingMCSpecLoader methodsFor: 'doits' stamp: ''!
preLoad: packageOrVersionSpec

	(MetacelloDirective preLoadSpec: packageOrVersionSpec loader: self) addTo: self loadDirective! !

!MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: ''!
loadDirective

	^self loaderPolicy loadDirective! !

!MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: ''!
loadingSpecLoader

	^(MetacelloLoadingMCSpecLoader on: self spec)
		shouldDisablePackageCache: self shouldDisablePackageCache;
		loaderPolicy: self loaderPolicy copy;
		yourself! !

!MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
atomicLoadPackageSpecs: packageSpecs repositories: repositories

	self loaderPolicy 
		pushAtomicLoadDirectivesDuring: [ super linearLoadPackageSpecs: packageSpecs repositories: repositories ]
		for: self! !

!MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: ''!
ensuredMap

	^self loaderPolicy ensuredMap! !

!MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: ''!
cacheRepository

	^self loaderPolicy cacheRepository! !

!MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: ''!
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.
  MetacelloNotification signal: ('Fetched dependency -> ' , reference name , ' --- '
            , reference repository repositoryDescription).
  self resolveDependencies: reference nearest: reference into: coll ].
  retryCount := 0.
  notDone := true.
  coll := OrderedCollection new.
  [ notDone and: [ retryCount < 3 ] ]
    whileTrue: [ 
      retryCount > 0
        ifTrue: [ 
          MetacelloNotification signal: ('...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! !

!MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: ''!
projectPackage: aProjectPackage
    self shouldBeMutable.
    projectPackage := aProjectPackage! !

!MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: ''!
repository: aString username: username password: password
    self repositories repository: aString username: username password: password.
    self projectPackage: nil! !

!MetacelloGenericProjectSpec methodsFor: 'construction' stamp: ''!
repositories: aBlock constructor: aVersionConstructor
    aVersionConstructor repositoriesForProject: aBlock! !

!MetacelloGenericProjectSpec methodsFor: 'merging' stamp: ''!
mergeRepositoriesSpec: anotherRepositories
  self
    repositories:
      (self getRepositories == nil
        ifTrue: [ anotherRepositories ]
        ifFalse: [ self repositories mergeSpec: anotherRepositories ])! !

!MetacelloGenericProjectSpec methodsFor: 'construction' stamp: ''!
repository: aString username: username password: password constructor: aVersionConstructor
    aVersionConstructor repositoryForProject: aString username: username password: password! !

!MetacelloGenericProjectSpec methodsFor: 'loading' stamp: ''!
loadVersion: aVersionOrNil
    self subclassResponsibility! !

!MetacelloGenericProjectSpec methodsFor: 'loading' stamp: ''!
determineCurrentVersionForLoad
    self subclassResponsibility! !

!MetacelloGenericProjectSpec methodsFor: 'merging' stamp: ''!
mergeMap
    | map |
    map := super mergeMap.
    map at: #'repositories' put: repositories.
    ^ map! !

!MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: ''!
getRepositories
    "raw access to iv"

    ^ repositories! !

!MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: ''!
name: aString
    super name: aString.
    self projectPackage: nil! !

!MetacelloGenericProjectSpec methodsFor: 'querying' stamp: ''!
repositoryDescriptions
    ^ self repositorySpecs collect: [ :repoSpec | repoSpec description ]! !

!MetacelloGenericProjectSpec methodsFor: 'scripting' stamp: ''!
metacelloRegistrationHash
    "projectPackage (ignored) repositories"

    ^ super metacelloRegistrationHash bitXor: self repositories metacelloRegistrationHash! !

!MetacelloGenericProjectSpec methodsFor: 'testing' stamp: ''!
hasRepository
    ^ self repositorySpecs notEmpty! !

!MetacelloGenericProjectSpec methodsFor: 'querying' stamp: ''!
repositorySpecs
    repositories ifNil: [ ^ #() ].
    ^ self repositories map values! !

!MetacelloGenericProjectSpec methodsFor: 'scripting' stamp: ''!
hasNoLoadConflicts: aMetacelloProjectSpec
  "'projectPackage repositories'"

  ^ (super hasNoLoadConflicts: aMetacelloProjectSpec)
    and: [ 
      (self repositories isEmpty or: [ aMetacelloProjectSpec repositories isEmpty ])
        or: [ self repositories hasNoLoadConflicts: aMetacelloProjectSpec repositories ] ]! !

!MetacelloGenericProjectSpec methodsFor: 'loading' stamp: ''!
load

    (MetacelloLookupProjectSpecForLoad new
        projectSpec: self;
        yourself) signal performLoad! !

!MetacelloGenericProjectSpec methodsFor: 'scripting' stamp: ''!
mergeScriptRepository: anotherSpec
    self repositories: anotherSpec repositories! !

!MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: ''!
projectPackage
    self subclassResponsibility! !

!MetacelloGenericProjectSpec methodsFor: 'merging' stamp: ''!
nonOverridable
    ^ super nonOverridable , #(#'projectPackage' #'repositories')! !

!MetacelloGenericProjectSpec methodsFor: 'construction' stamp: ''!
repository: anObject constructor: aVersionConstructor
    aVersionConstructor repositoryForProject: anObject! !

!MetacelloGenericProjectSpec methodsFor: 'copying' stamp: ''!
postCopy
    super postCopy.
    repositories := repositories copy.
    projectPackage := nil! !

!MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: ''!
repositories
    repositories ifNil: [ repositories := self project repositoriesSpec ].
    ^ repositories! !

!MetacelloGenericProjectSpec methodsFor: 'scripting' stamp: ''!
compareEqual: aMetacelloProjectSpec
    "'projectPackage repositories'"

    ^ (super compareEqual: aMetacelloProjectSpec)
        and: [ self repositories compareEqual: aMetacelloProjectSpec repositories ]! !

!MetacelloGenericProjectSpec methodsFor: 'merging' stamp: ''!
mergeSpec: anotherSpec
  | newSpec map anotherRepositories |
  newSpec := super mergeSpec: anotherSpec.
  map := anotherSpec mergeMap.
  (anotherRepositories := map at: #'repositories') ~~ nil
    ifTrue: [ newSpec mergeRepositoriesSpec: anotherRepositories ].
  ^ newSpec! !

!MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: ''!
repositories: anObject
    self shouldBeMutable.
    repositories := anObject.
    self projectPackage: nil! !

!MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: ''!
repository: aStringOrMetacelloRepositorySpec
    self repositories repository: aStringOrMetacelloRepositorySpec.
    self projectPackage: nil! !

!MetacelloGenericProjectSpec methodsFor: 'construction' stamp: ''!
projectPackage: aBlock constructor: aVersionConstructor
    aVersionConstructor projectPackageForProject: aBlock! !

!MetacelloGofer methodsFor: 'operations' stamp: ''!
interactiveCommit

	^ self execute: MetacelloGoferCommit! !

!MetacelloGofer methodsFor: 'private' stamp: ''!
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) ]! !

!MetacelloGoferCommit methodsFor: 'running' stamp: ''!
execute: aWorkingCopy
	| version |
	version := MetacelloPlatform current newVersionForWorkingCopy: aWorkingCopy.
	self gofer repositories
		do: [ :repository | repository storeVersion: version ]! !

!MetacelloGoferLoad methodsFor: 'private' stamp: ''!
updateCategories
	MetacelloPlatform current bypassGoferLoadUpdateCategories
		ifFalse: [ super updateCategories ]! !

!MetacelloGoferLoad methodsFor: 'private' stamp: ''!
updateRepositories
	"Noop for Metacello...done by loader itself"! !

!MetacelloGoferPackage methodsFor: 'initialization' stamp: ''!
initializeName: aString packageFilename: packagefilename

	name := aString.
	packageFilename := packagefilename! !

!MetacelloGoferPackage methodsFor: 'private' stamp: ''!
matchesWorkingCopy: aWorkingCopy
	"check that the working copy package name matches the package file name and that the first ancestor's package file name
	 matches the packageName"
	
	| pFilename |
	(pFilename := self packageFilename) == nil ifTrue: [ ^self error: 'cannot match working copy' ].
	(self class 
		packageFileName: pFilename 
		matchesPackageName: aWorkingCopy package name)
			ifTrue: [
				aWorkingCopy ancestry ancestors isEmpty ifTrue: [ ^true ].
				^self class 
					packageFileName: aWorkingCopy ancestry ancestors first name 
					matchesPackageName: self packageName ].
	^false! !

!MetacelloGoferPackage methodsFor: 'accessing' stamp: ''!
workingCopy
	
	workingCopy == nil ifTrue: [ workingCopy := self findWorkingCopy ].
	^workingCopy! !

!MetacelloGoferPackage methodsFor: 'querying' stamp: ''!
ancestors

	| wc |
	(wc := self workingCopy) ~~ nil
		ifTrue: [ 
			wc ancestry ancestors isEmpty not
				ifTrue: [ ^wc ancestry ancestors ]].
	^nil! !

!MetacelloGoferPackage methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
packageFilename

	^packageFilename! !

!MetacelloGoferPackage methodsFor: 'private' stamp: ''!
matches: aLoadableReference
  | pFilename |
  ((pFilename := self packageFilename) == nil
    or: [ self name = self packageFilename ])
    ifTrue: [ ^ super matches: aLoadableReference ].
  aLoadableReference name = pFilename
    ifTrue: [ ^ true ].
  (aLoadableReference name beginsWith: pFilename)
    ifFalse: [ ^ false ].
  ^ aLoadableReference matchesMetacelloGoferPackage: self! !

!MetacelloGoferPackage methodsFor: 'querying' stamp: ''!
currentVersionInfo

	| wc |
	(wc := self workingCopy) ~~ nil
		ifTrue: [ 
			wc ancestry ancestors isEmpty not
				ifTrue: [ ^wc ancestry ancestors first ]].
	^nil! !

!MetacelloGoferPackage methodsFor: 'private' stamp: ''!
matchesMetacelloGoferPackage: aMetacelloGoferPackage
  self
    error:
      'Should not be matching a MetacelloGoferPackage with another MetacelloGoferPackage'! !

!MetacelloGoferPackage class methodsFor: 'package name matching' stamp: ''!
packageFileName: pkgFileName matchesPackageName: wcPkgName
  ^ (pkgFileName beginsWith: wcPkgName)
    ifTrue: [ 
      pkgFileName size = wcPkgName size
        or: [ 
          (pkgFileName at: wcPkgName size + 1) = $-
            or: [ 
              (pkgFileName at: wcPkgName size + 1) = $.
                or: [ (pkgFileName at: wcPkgName size + 1) isDigit ] ] ] ]
    ifFalse: [ 
      pkgFileName size >= wcPkgName size
        ifTrue: [ ^ false ].
      (wcPkgName beginsWith: pkgFileName)
        ifFalse: [ ^ false ].
      ^ (wcPkgName at: pkgFileName size + 1) = $. ]! !

!MetacelloGoferPackage class methodsFor: 'instance creation' stamp: ''!
name: aString packageFilename: packageFilename
	^ self basicNew initializeName: aString packageFilename: packageFilename! !

!MetacelloGroupSpec methodsFor: 'private' stamp: ''!
requiresSpecsForPackageOrdering: aVersionSpec
  "expand the names in the group to a package or project"

  | packageOrProjectSpecs |
  packageOrProjectSpecs := Set new.
  self includes
    do: [ :specName | 
      (aVersionSpec packageNamed: specName ifAbsent: [  ])
        ifNotNil: [ :pkgSpec | 
          packageOrProjectSpecs
            addAll:
              (pkgSpec
                resolveToPackagesIn: aVersionSpec
                andProjects: true
                visited: MetacelloVisitedPackages new) ] ].
  ^ packageOrProjectSpecs! !

!MetacelloGroupSpec methodsFor: 'printing' stamp: ''!
configMethodOn: aStream indent: indent

	aStream 
		tab: indent;
		nextPutAll: 'spec '; cr;
		tab: indent + 1;
		nextPutAll: 'name: ', self name printString, ';'.
	self configMethodBodyOn: aStream hasName: true cascading: false indent: indent + 1.
	aStream nextPut: $.! !

!MetacelloGroupSpec methodsFor: '*Metacello-MC' stamp: ''!
loadUsing: aLoader gofer: gofer
	"noop"! !

!MetacelloGroupSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveToPackagesIn: aVersionSpec andProjects: andProjectsBool visited: visited
  | packages |
  packages := Dictionary new.
  self
    resolveToPackagesIn: aVersionSpec
    andProjects: andProjectsBool
    into: packages
    visited: visited.
  ^ packages values asOrderedCollection! !

!MetacelloGroupSpec methodsFor: 'printing' stamp: ''!
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: '*Metacello-MC' stamp: ''!
resolveToPackagesIn: aVersionSpec andProjects: andProjectsBool 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: [ :prj | 
              andProjectsBool
                ifTrue: [ packages at: prj name put: prj ] ]
            packageDo: [ :pkg | packages at: pkg name put: pkg ]
            groupDo: [ :grp | 
              grp
                resolveToPackagesIn: aVersionSpec
                andProjects: andProjectsBool
                into: packages
                visited: visited ] ] ]! !

!MetacelloGroupSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveToPackagesIn: aVersionSpec into: packages visited: visited
  self
    resolveToPackagesIn: aVersionSpec
    andProjects: false
    into: packages
    visited: visited! !

!MetacelloGroupSpec methodsFor: 'private' stamp: ''!
requiredSpecsForPackageOrdering: aVersionSpec
  ^ #()! !

!MetacelloGroupSpec methodsFor: 'accessing' stamp: ''!
requires: aCollection

	self shouldNotImplement! !

!MetacelloGroupSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveToPackagesIn: aVersionSpec visited: visited
  | packages |
  packages := Dictionary new.
  self
    resolveToPackagesIn: aVersionSpec
    andProjects: false
    into: packages
    visited: visited.
  ^ packages values asOrderedCollection! !

!MetacelloGroupSpec methodsFor: 'private' stamp: ''!
resolveSpecsForPackageOrdering: aVersionSpec
  "expand the names in the group to a package or project"

  | packageOrProjectSpecs |
  packageOrProjectSpecs := Set new.
  self includes
    do: [ :specName | 
      (aVersionSpec packageNamed: specName ifAbsent: [  ])
        ifNotNil: [ :pkgSpec | 
          packageOrProjectSpecs
            addAll:
              (pkgSpec
                resolveToPackagesIn: aVersionSpec
                andProjects: true
                visited: MetacelloVisitedPackages new) ] ].
  ^ packageOrProjectSpecs! !

!MetacelloGroupSpec methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionIncludes
	<inspectorPresentationOrder: 10 title: 'Include'>
	| specs |

	specs := self project version spec packageSpecsInLoadOrder 
		select: [ :each | self includes includes: each name ].
		
	^ SpTablePresenter new
		addColumn: (SpStringTableColumn 
			title: 'Type' 
			evaluated: [ :aSpec | aSpec type ]) 
			beNotExpandable;
		addColumn: (SpStringTableColumn 
			title: 'Name' 
			evaluated: [ :aSpec | aSpec name ]);
		items: (specs sorted: #type ascending, #name ascending);
		yourself	
! !

!MetacelloGroupSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveToLoadableSpec

	^nil! !

!MetacelloGroupSpec methodsFor: 'accessing' stamp: ''!
answers: aListOfPairs

	self shouldNotImplement! !

!MetacelloGroupSpec methodsFor: 'private' stamp: ''!
includeSpecNamesForPackageOrdering: aVersionSpec
  ^ #()! !

!MetacelloGroupSpec methodsFor: 'visiting' stamp: ''!
projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock

	groupBlock value: self! !

!MetacelloGroupSpec methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
type

	^ 'group'! !

!MetacelloGroupSpecTestCase methodsFor: 'tests' stamp: ''!
testGroupMergeSpec
    | groupA groupB group |
    groupA := self groupSpec
        name: 'Platform';
        includes: 'Core';
        yourself.
    groupB := self groupSpec
        name: 'Platform';
        includes: 'Tests';
        yourself.
    group := groupA mergeSpec: groupB.
    self assert: (group includes includes: 'Core').
    self assert: (group includes includes: 'Tests')! !

!MetacelloGroupSpecTestCase methodsFor: 'tests' stamp: ''!
testGroupSpec
	| group |
	group := self groupSpec
		name: 'Platform';
		includes: 'Core';
		yourself.
	self assert: group name equals: 'Platform'.
	self assert: (group includes includes: 'Core').
	group := self groupSpec
		name: 'Platform';
		includes: #('Core');
		yourself.
	self assert: group name equals: 'Platform'.
	self assert: (group includes includes: 'Core').
	self should: [ group requires: #() ] raise: Error.
	self should: [ group answers: #() ] raise: Error.
	group projectDo: [ :ignored | self assert: false ] packageDo: [ :ignored | self assert: false ] groupDo: [ :grp | self assert: group identicalTo: grp ]! !

!MetacelloIgnorePackageLoaded methodsFor: 'accessing' stamp: ''!
packageSpec

   ^packageSpec! !

!MetacelloIgnorePackageLoaded methodsFor: 'accessing' stamp: ''!
defaultAction
  "Default action is to NOT ignore whether or not the package is loaded. 
   Basically allow for package level ignoreImage. "

  ^ false! !

!MetacelloIgnorePackageLoaded methodsFor: 'accessing' stamp: ''!
packageSpec: anObject

   packageSpec := anObject! !

!MetacelloIgnorePackageLoaded class methodsFor: 'signalling' stamp: ''!
signal: aMetacelloPackageSpec

	^(self new packageSpec: aMetacelloPackageSpec) signal! !

!MetacelloIssue108Resource methodsFor: 'accessing' stamp: ''!
versionReferences
	^ versionReferences! !

!MetacelloIssue108Resource methodsFor: 'accessing' stamp: ''!
monticelloRepository
	^ monticelloRepository! !

!MetacelloIssue108Resource methodsFor: 'running' stamp: ''!
setUpVersionReferences
	"self reset"

	versionReferences := OrderedCollection new.
	versionReferences
		add: (GoferVersionReference name: 'GoferBar.gemstone-dkh.68');
		add: (GoferVersionReference name: 'GoferBar.gemstone-dkh.69');
		add: (GoferVersionReference name: 'GoferBar.gemstone-dkh.70');
		add: (GoferVersionReference name: 'GoferBar-dkh.68');
		add: (GoferVersionReference name: 'GoferBar-dkh.69');
		add: (GoferVersionReference name: 'GoferBar-dkh.70');
		yourself! !

!MetacelloIssue108Resource methodsFor: 'running' stamp: ''!
setUpMonticelloRepository
	"This method builds a fake repository with the version references from #buildReferences."

	monticelloRepository := MCDictionaryRepository new.
	versionReferences do: [ :reference |
		monticelloRepository basicStoreVersion: (MCVersion new
			setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
			info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
			snapshot: (MCSnapshot fromDefinitions: (Array
				with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol))
				with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: '')))
			dependencies: #()) ]! !

!MetacelloIssue108Resource methodsFor: 'running' stamp: ''!
setUp
  "https://code.google.com/p/metacello/issues/detail?id=108"

  super setUp.
  self
    setUpVersionReferences;
    setUpMonticelloRepository! !

!MetacelloIssueTestCase methodsFor: 'running' stamp: ''!
configurationRepository
	"MetacelloConfigurationResource reset"

	^ MetacelloConfigurationResource current monticelloRepository! !

!MetacelloIssueTestCase methodsFor: 'running' stamp: ''!
tearDownPackageNames
    ^ {(self projectName)}! !

!MetacelloIssueTestCase methodsFor: 'utilities' stamp: ''!
hasPackage: aString
	| package |
	package := MCWorkingCopy allManagers
		detect: [ :each | each packageName = aString ]
		ifNone: [ nil ].
	^ package notNil! !

!MetacelloIssueTestCase methodsFor: 'accessing' stamp: ''!
projectWith: projectAttributes
    | project |
    "Construct Metacello project"
    project := MetacelloMCProject new.
    project projectAttributes: projectAttributes.
    MetacelloVersionConstructor on: self projectClass new project: project.
    project loader: MetacelloNullRecordingMCSpecLoader new.
    project loader evalDoits: false.
    ^ project! !

!MetacelloIssueTestCase methodsFor: 'accessing' stamp: ''!
monticelloRepository
	"MetacelloMonticelloResource reset"
	^ MetacelloMonticelloResource current monticelloRepository! !

!MetacelloIssueTestCase methodsFor: 'running' stamp: ''!
tearDown
  | aGofer finalWorkingCopyList diff |
  aGofer := Gofer new.
  self tearDownPackageNames
    do: [ :pName | 
      (self hasPackage: pName)
        ifTrue: [ aGofer package: pName ] ].
  aGofer references notEmpty
    ifTrue: [ aGofer metacelloUnload ].
  MCRepositoryGroup default
    removeIdenticalRepository:
        (testingEnvironment at: #'Metacello_Gofer_Test_Repository' ifAbsent: [  ]);
    removeIdenticalRepository:
        (testingEnvironment at: #'Metacello_Configuration_Test_Repository' ifAbsent: [  ]);
    yourself.
  testingEnvironment removeKey: #'Metacello_Gofer_Test_Repository' ifAbsent: [  ].
  testingEnvironment removeKey: #'Metacello_Configuration_Test_Repository' ifAbsent: [  ].
  finalWorkingCopyList := MCWorkingCopy allManagers
    collect: [ :each | each packageName ].
  diff := finalWorkingCopyList difference: initialWorkingCopyList.
  diff
    do: [ :leak | 
      MetacelloNotification signal: ('leaked package from ' , self printString , ' -> ' , leak printString) ].
  self assert: diff isEmpty.
  super tearDown! !

!MetacelloIssueTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ testingEnvironment at: self projectName asSymbol! !

!MetacelloIssueTestCase methodsFor: 'accessing' stamp: ''!
projectName
    ^ self subclassResponsibility! !

!MetacelloIssueTestCase methodsFor: 'accessing' stamp: ''!
project

	^self projectWith: #()! !

!MetacelloIssueTestCase methodsFor: 'running' stamp: ''!
runCase
	| original |
	original := MetacelloPlatform current bypassGoferLoadUpdateCategories.
	[ 
	MetacelloPlatform current bypassGoferLoadUpdateCategories: true.
	^ MetacelloPlatform current suspendSystemUpdateEventsDuring: [ super runCase ] ]
		ensure: [ MetacelloPlatform current bypassGoferLoadUpdateCategories: original ]! !

!MetacelloIssueTestCase methodsFor: 'running' stamp: ''!
setUp
  | repo |
  super setUp.
  MetacelloPlatform current clearPackageCache.
  repo := self monticelloRepository.
  gofer := Gofer new.
  gofer disablePackageCache.
  gofer repository: repo.
  testingEnvironment at: #'Metacello_Gofer_Test_Repository' put: repo.
  repo := self configurationRepository.
  gofer repository: repo.
  testingEnvironment at: #'Metacello_Configuration_Test_Repository' put: repo.
  initialWorkingCopyList := MCWorkingCopy allManagers
    collect: [ :each | each packageName ]! !

!MetacelloLinearLoadDirective methodsFor: 'actions' stamp: ''!
loadUsing: aLoaderDirective gofer: aGofer

	self loadDirectives isEmpty ifTrue: [ ^self ].
	aLoaderDirective loadLinearLoadDirective: self gofer: aGofer.! !

!MetacelloLinearLoadDirective methodsFor: 'accessing' stamp: ''!
title

	^'linear load'! !

!MetacelloLoadData methodsFor: 'testing' stamp: ''!
isEmpty

	^self dataMap isEmpty! !

!MetacelloLoadData methodsFor: 'versionInfo' stamp: ''!
ancestorsFor: packageSpec ifAbsent: aBlock

	^self versionInfoMap 
		at: packageSpec file 
		ifAbsent: [ 
			self  packageNameMap 
				at: packageSpec name
				ifAbsent: aBlock ]! !

!MetacelloLoadData methodsFor: 'accessing' stamp: ''!
packageNameMap

	packageNameMap == nil ifTrue: [ packageNameMap := Dictionary new ].
	^packageNameMap! !

!MetacelloLoadData methodsFor: 'accessing' stamp: ''!
dataMap

	dataMap == nil ifTrue: [ dataMap := Dictionary new ].
	^dataMap! !

!MetacelloLoadData methodsFor: 'enumerating' stamp: ''!
do: aBlock

	self dataMap valuesDo: [:ar |
		aBlock value: (ar at: 1) value: (ar at: 2) value: (ar at: 3) ]! !

!MetacelloLoadData methodsFor: 'accessing' stamp: ''!
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: ''!
versionInfoMap

	versionInfoMap == nil ifTrue: [ versionInfoMap := Dictionary new ].
	^versionInfoMap! !

!MetacelloLoadData methodsFor: 'versionInfo' stamp: ''!
currentVersionInfoFor: packageSpec ifAbsent: aBlock

	^self versionInfoMap 
		at: packageSpec file 
		ifPresent: [ :v | v first ]
		ifAbsent: [ 
			self  packageNameMap 
				at: packageSpec name
				ifPresent: [ :v | v first ]
				ifAbsent: aBlock ]! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
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: 'actions' stamp: ''!
load

	overrideRepositories := Array with: self cacheRepository. "ensure that hasRepositoryOverrides is true"
	self loadDirective loadWithPolicy: self! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
ignoreImage: anObject
	ignoreImage := anObject! !

!MetacelloLoaderPolicy methodsFor: 'initialization' stamp: ''!
initialize

	self 
		repositoryMap; 
		cacheRepository;
		ensuredMap.
	ignoreImage := false! !

!MetacelloLoaderPolicy methodsFor: 'actions' stamp: ''!
pushExplicitLoadDirectivesDuring: aBlock for: aLoader

	| directive |
	directive := MetacelloExplicitLoadDirective loader: aLoader.
	self pushLoadDirective: directive during: aBlock.
	^directive! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
loadData

 	loadData == nil ifTrue: [ loadData := MetacelloLoadData new ].
	^loadData! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
overrideRepositories
	^ overrideRepositories! !

!MetacelloLoaderPolicy methodsFor: 'actions' stamp: ''!
pushAtomicLoadDirectivesDuring: aBlock for: aLoader

	self pushLoadDirective: (MetacelloAtomicLoadDirective loader: aLoader) during: aBlock.! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
repositoryMap: anObject
	repositoryMap := anObject! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
resetCacheGofer

	cacheGofer := nil! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
overrideRepositories: anObject
	overrideRepositories := anObject! !

!MetacelloLoaderPolicy methodsFor: 'private' stamp: ''!
pushLoadDirective: aLoaderDirective during: aBlock

	|  oldRoot |
	self loadDirective add: aLoaderDirective.
	oldRoot := loadDirective.
	loadDirective := aLoaderDirective.
	aBlock ensure: [ loadDirective := oldRoot ].! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
ensuredMap: anObject
	ensuredMap := anObject! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
ignoreImage
	^ ignoreImage! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
loadDirective

	loadDirective == nil ifTrue: [ loadDirective := MetacelloLinearLoadDirective new ].
	^ loadDirective! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
silently

	silently == nil ifTrue: [ silently := false ].
	^ silently! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
silently: anObject
	silently := anObject! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
ensuredMap

	ensuredMap == nil ifTrue: [ ensuredMap := Dictionary new ].
	^ensuredMap! !

!MetacelloLoaderPolicy methodsFor: 'testing' stamp: ''!
hasRepositoryOverrides

	^self overrideRepositories ~~ nil! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
cacheRepository

	cacheRepository == nil ifTrue: [ cacheRepository := MCDictionaryRepository new ].
	^ cacheRepository! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
cacheRepository: anMCRepository

	cacheRepository := anMCRepository.
	"getting a new repository, so wipe out the cacheGofer and ensureMap"
	ensuredMap := cacheGofer := nil! !

!MetacelloLoaderPolicy methodsFor: 'actions' stamp: ''!
pushLinearLoadDirectivesDuring: aBlock for: aLoader

	self pushLoadDirective: (MetacelloLinearLoadDirective loader: aLoader) during: aBlock.! !

!MetacelloLoaderPolicy methodsFor: 'accessing' stamp: ''!
repositoryMap

	repositoryMap == nil ifTrue: [ repositoryMap := Dictionary new ].
	^repositoryMap! !

!MetacelloLoaderPolicy class methodsFor: 'instance creation' stamp: ''!
overrideRepositories: aCollection

	^self new overrideRepositories: aCollection! !

!MetacelloLoadingMCSpecLoader methodsFor: 'accessing' stamp: ''!
fetchingSpecLoader

	^(MetacelloFetchingMCSpecLoader on: self spec)
		shouldDisablePackageCache: self shouldDisablePackageCache;
		loaderPolicy: self loaderPolicy copy;
		yourself! !

!MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: ''!
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: ''!
savePackageUsing: repositorySpecs

	| wc repo repoSpecs newVersion |
	(wc := self spec workingCopy) == nil ifTrue: [ ^false ].
	(wc ancestry ancestors notEmpty and: [ wc modified not])
		ifTrue: [ ^false ].
	repoSpecs := self spec repositorySpecs notEmpty
				ifTrue: [ self spec repositorySpecs ]
				ifFalse: [ repositorySpecs ].
	(self spec getFile == nil or: [ wc ancestry ancestors isEmpty ])
		ifTrue: [ repo := (self repositoriesFrom: repoSpecs ignoreOverrides: true) first ]
		ifFalse: [
			[ 	| newer |
				repo := (self resolveSpec: self spec from: repoSpecs) repository.
				newer := wc possiblyNewerVersionsIn: repo.
				newer isEmpty not 
					ifTrue: [
						(MetacelloPlatform current confirm: 'CAUTION!! These versions in the repository may be newer:', 
							String cr, newer printString, String cr,
							'Do you really want to save this version?') ifFalse: [ ^false ]] ] 
				on: Error 
				do: [:ignored | ^false ] ].
	(newVersion :=  MetacelloPlatform current newVersionForWorkingCopy: wc) == nil ifTrue: [ ^false ].
	repo storeVersion: newVersion.
	^true! !

!MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: ''!
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: ''!
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: ''!
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: 'doits' stamp: ''!
postLoad: packageOrVersionSpec

	| block |
	(block := packageOrVersionSpec postLoadDoItBlock) ~~ nil
		ifTrue: [ block valueWithPossibleArgs: { self. packageOrVersionSpec. } ]! !

!MetacelloLoadingMCSpecLoader methodsFor: 'private' stamp: ''!
linearLoadPackageSpec: packageSpec gofer: gofer
	MetacelloPlatform current
		do: [ | loadBlock goferLoad answers resolvedReference repo |
			resolvedReference := self
				resolvePackageSpec: packageSpec
				gofer: gofer.
			resolvedReference
				ifNil: [ "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 ].
			MetacelloNotification signal:
					'Loaded -> ' , resolvedReference name , ' --- '
						, repo repositoryDescription , ' --- '
						, resolvedReference repository description ]
		displaying: 'Loading ' , packageSpec file! !

!MetacelloLoadingMCSpecLoader methodsFor: 'actions' stamp: ''!
doLoad
	"NOOP"! !

!MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: ''!
repositoryFor: pkgSpec with: gofer

	^([self resolveSpec: pkgSpec with: gofer]
		on: Error
		do: [:ignored | ^nil ]) repository! !

!MetacelloLoadingMCSpecLoader methodsFor: 'accessing' stamp: ''!
actionLabel

	^'Loading '! !

!MetacelloLoadingMCSpecLoader methodsFor: 'doits' stamp: ''!
preLoad: packageOrVersionSpec

	| block |
	(block := packageOrVersionSpec preLoadDoItBlock) ~~ nil
		ifTrue: [ block valueWithPossibleArgs: { self. packageOrVersionSpec. } ]! !

!MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: ''!
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: ''!
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: ''!
repositoryFor: pkgSpec from: repositorySpecs

	^([self resolveSpec: pkgSpec from: repositorySpecs]
		on: Error
		do: [:ignored | ^nil ]) repository! !

!MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: ''!
resolveSpec: pkgSpec with: gofer

	^pkgSpec goferLoaderReference resolveWith: gofer! !

!MetacelloLoadingMCSpecLoader methodsFor: 'packages' stamp: ''!
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! !

!MetacelloLockTest methodsFor: 'tests' stamp: ''!
testRegisterProject

	self 
		denyCollection: (MetacelloProjectRegistration registry baselineProjectSpecs collect: #name)
		includesAny: #('TestToLock2').

	[
		Metacello new baseline: 'TestToLock2'; register.
		self 
			assertCollection: (MetacelloProjectRegistration registry baselineProjectSpecs collect: #name)
			includesAny: #('TestToLock2') ]
	ensure: [ 
		 Metacello new baseline: 'TestToLock2'; unregister ]! !

!MetacelloLockTest methodsFor: 'accessing' stamp: ''!
project

	^ BaselineOfTestToLock1 project! !

!MetacelloLockTest methodsFor: 'tests' stamp: ''!
testLoadLockedWillNotIncludeLockedPackages
	"Using record as a way to determine which packages will be loaded"

	self 
		assertCollection: (self project version record packages collect: #name)
		hasSameElements: #( 
			'Package1'
			'BaselineOfTestToLock2' 
			'TestToLockPackage1' 
			'TestToLockPackage2').
		
	[
		"baseline needs to be registered to be locked"
		Metacello new baseline: 'TestToLock2'; register.
		Metacello new baseline: 'TestToLock2'; lock.
		self 
			assertCollection: (self project version record packages collect: #name)
			hasSameElements: #('Package1') ]
	ensure: [ 
		Metacello new baseline: 'TestToLock2'; unlock. 
		Metacello new baseline: 'TestToLock2'; unregister ]! !

!MetacelloLookupBaselineSpecForEnsureLoad methodsFor: 'exception description' stamp: ''!
defaultAction
	"Answer <true> if you want to ensure the load of the baseline ... default is to load the baseline"

	^ true! !

!MetacelloLookupBaselineSpecForEnsureLoad methodsFor: 'handlers' stamp: ''!
handleResolutionFor: aScriptEngine
	^ aScriptEngine handleLookupBaselineSpecForEnsureLoad: self! !

!MetacelloLookupProjectSpec commentStamp: ''!
**MetacelloLookupProjectSpec** is signalled to allow a handler to substitute a different (equivalent) project spec for fetching or loading purposes!
!MetacelloLookupProjectSpec methodsFor: 'handlers' stamp: ''!
handleResolutionFor: aScriptEngine
    ^ aScriptEngine handleLookupProjectSpec: self! !

!MetacelloLookupProjectSpecForLoad commentStamp: ''!
**MetacelloLookupProjectSpecForLoad** ends up returning an instance of **MetacelloProjectSpecForLoad**!
!MetacelloLookupProjectSpecForLoad methodsFor: 'exception description' stamp: ''!
defaultAction
    "Result of signal should be the MetacelloProjectSpecForLoad to be used to perform the load. 
	Create a MetacelloProjectSpecForLoad and use the overrideProjectSpec: if you want to supply a different projectSpec"

    ^ MetacelloProjectSpecForLoad new
        projectSpec: self projectSpec;
        yourself! !

!MetacelloLookupProjectSpecForLoad methodsFor: 'handlers' stamp: ''!
handleResolutionFor: aScriptEngine
    ^ aScriptEngine handleLookupProjectSpecForLoad: self! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'printing' stamp: ''!
hasClassName
    ^ className ~~ nil and: [ className ~= self constructClassName ]! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'printing' stamp: ''!
configHasVersionString
  ^ false! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'querying' stamp: ''!
repositoryVersionString
  "extract a version string from the repository ... if possible"

  "must parallel implementation of MetacelloMCBaselineProject>>setBaselineRepositoryDescription: we want the same repoSpec"

  | spec repo |
  self repositorySpecs do: [ :repoSpec | spec := repoSpec ].
  [ repo := spec createRepository ]
    on: Error
    do: [ :ex | ^ '' ].
  ^ repo repositoryVersionString! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'construction' stamp: ''!
version: anObject constructor: aVersionConstructor
    self error: 'version: not allowed in a baseline project spec'! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'merging' stamp: ''!
mergeRepositoriesSpec: anotherRepositories
  "anotherRepositories wins ... there can ever only be one repository for the 
   baseline to load from"

  "https://github.com/dalehenrich/metacello-work/issues/251"

  self repositories: anotherRepositories! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'mutability' stamp: ''!
copyForRegistration: aMetacelloProjectRegistration onWrite: aBlock
  | copy |
  aMetacelloProjectRegistration
    baselineProjectSpecIfPresent: [ :spec | 
      copy := spec copy.
      aBlock value: copy.
      aMetacelloProjectRegistration baselineProjectSpec: copy ]
    ifAbsent: [ 
      aMetacelloProjectRegistration
        configurationProjectSpecIfPresent: [ :spec | 
          copy := spec copy.
          aBlock value: copy.
          aMetacelloProjectRegistration configurationProjectSpec: copy ]
        ifAbsent: [ aBlock value: nil ] ]! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'loading' stamp: ''!
determineCurrentVersionForLoad
    ^ self version! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: ''!
canDowngradeTo: aProjectSpec
    "cannot upgrade between baselines"

    ^ false! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'querying' stamp: ''!
version
    self projectClass == nil
        ifTrue: [ ^ nil ].
    ^ self projectClassProject version! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'querying' stamp: ''!
versionString
    ^ versionString ifNil: [ self version ifNotNil: [:v | v versionString] ]! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'printing' stamp: ''!
projectLabel
    ^ 'baseline'! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: ''!
asBaselineProjectSpec
    ^ self! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'testing' stamp: ''!
isBaselineOfProjectSpec
	^ true! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'testing' stamp: ''!
hasConflictWithConfigurationSpec: projectSpec
  "baseline can be loaded on top of a configuration without a conflict"

  ^ false! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: ''!
validateVersionString: issues withDefaultVersionString: ignored
    self versionString
        ifNotNil: [ :vs | 
            | prj |
            prj := self project asBaselineProject.
            vs ~= prj singletonVersionName
                ifTrue: [ 
                    issues
                        add:
                            (MetacelloValidationError
                                configurationClass: self projectClass
                                reasonCode: #'invalidVersionString'
                                callSite:
                                    #'validateForScriptLoad:withDefaultVersionString:withDefaultRepositoryDecription:'
                                explanation:
                                    'version field is incorrect, should be: ' , prj singletonVersionName printString) ] ]! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'querying' stamp: ''!
repositoryBranchName
  "extract a branch name from the repository ... if possible"

  "must parallel implementation of MetacelloMCBaselineProject>>setBaselineRepositoryDescription: we want the same repoSpec"

  | spec repo |
  self repositorySpecs do: [ :repoSpec | spec := repoSpec ].
  repo := spec createRepository.
  ^ repo repositoryBranchName! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'loading' stamp: ''!
ensureConfigurationLoaded: vrsn ensured: ensured
  "answer true if the configuration should be reloaded"

  "see Issue #181 for details ... basically we always want to consider loading the baseline from a project reference, especially if the two project specs are not the same..."

  "https://github.com/dalehenrich/metacello-work/issues/181"

  ^ true! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'loading' stamp: ''!
ensureLoadUsing: aLoader
  "see https://github.com/dalehenrich/metacello-work/issues/244 ... uncoditionally load
   baseline"

  [ super ensureLoadUsing: aLoader ]
    on: MetacelloIgnorePackageLoaded
    do: [ :ex | ex resume: ex packageSpec name = self name ]! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'construction' stamp: ''!
versionString: anObject constructor: aVersionConstructor
    self error: 'versionString: not allowed in a baseline project spec'! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'merging' stamp: ''!
mergeSpec: anotherSpec
    ^ super mergeSpec: anotherSpec asBaselineProjectSpec! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: ''!
asProjectRegistration
    ^ MetacelloProjectRegistration fromMCBaselineProjectSpec: self! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'private' stamp: ''!
constructClassName
    ^ 'BaselineOf' , self name! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'importing' stamp: ''!
mergeImportLoads: aLoadList
    aLoadList
        ifNotNil: [ :otherLoads | self loads ifNil: [ loads := otherLoads ] ifNotNil: [ loads := loads , otherLoads ] ]! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'testing' stamp: ''!
hasConflictWithProjectSpec: projectSpec
	^ projectSpec hasConflictWithBaselineSpec: self! !

!MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: ''!
canUpgradeTo: aProjectSpec
  "cannot upgrade between baselines unless repositories can be upgraded"

  (self repositories canUpgradeTo: aProjectSpec repositories)
    ifTrue: [ ^ true ].
  ^ false! !

!MetacelloMCBaselineProject commentStamp: ''!
The **MetacelloMCBaselineProject**  is a wrapper for the **BaselineOf** version specification for file-based repositories.

There is a single version in a **MetacelloMCBaselineProject**, named *'baseline'*.

A typical **BaselineOf** is specification:

```Smalltalk
baseline: spec
    <baseline>
    spec
        package: 'External-Core';
        package: 'External-Tests' with: [ spec requires: 'External-Core' ];
        yourself.
    spec
        group: 'Core' with: #('External-Core');
        group: 'default' with: #('Core');
        group: 'Tests' with: #('External-Tests');
        yourself
```

The `<baseline>` pragma marks the method containing the baseline specification.!
!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
hasVersion: versionString
    ^ versionString = 'baseline'! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
latestVersionMatching: versionPatternString excludedBlessings: excluded
    ^ nil! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
singletonVersionName
    ^ self class singletonVersionName! !

!MetacelloMCBaselineProject methodsFor: 'scripting' stamp: ''!
projectForScriptEngine: aMetacelloScriptEngine unconditionalLoad: aBool
  "see https://github.com/dalehenrich/metacello-work/issues/244 ... uncoditionally load
   baseline"

  ^ aMetacelloScriptEngine getBaselineProjectUnconditionalLoad: true! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
latestVersionMatching: versionPatternString
    ^ nil! !

!MetacelloMCBaselineProject methodsFor: 'scripting' stamp: ''!
asBaselineProject
    ^ self! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
development
    ^ nil! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
latestVersion: blessing
    ^ nil! !

!MetacelloMCBaselineProject methodsFor: '*Metacello-Cypress' stamp: ''!
packageSpecClass
  "One could argue that Baselines should have done this from the very beginning ... the cost is that every package is fetched (from disk) and the snapshots for every package are created ... the advantage is that you will properly downgrade packages when switching git versions ... for now a class variable is sufficient"

  MetacelloCypressBaselineProject useCypressPackagesForAllBaselines
    ifTrue: [ ^ MetacelloCypressPackageSpec ].
  ^ super packageSpecClass! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
versions
  ^ [ {(self version)} ]
    on: MetacelloVersionDoesNotExistError
    do: [ :ex | ^ #() ]! !

!MetacelloMCBaselineProject methodsFor: 'scripting' stamp: ''!
asConfigurationProject
    ^ MetacelloMCProject new! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
lastVersion
    ^ self version! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
version
    ^ self version: self singletonVersionName! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
latestVersionMatching: versionPatternString includedBlessings: included
    ^ nil! !

!MetacelloMCBaselineProject methodsFor: 'initialization' stamp: ''!
setBaselineRepositoryDescription: aListOrRepositoryDescriptions
    "set #version repositories to < aListOrRepositoryDescriptions>. Should be the directory where the BaselineOf is located."

    aListOrRepositoryDescriptions do: [:desc | self version spec repository: desc]! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
stableVersion
    ^ nil! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
bleedingEdge
    ^ nil! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
symbolicVersionSymbols
    ^ nil! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
latestVersionMatching: versionPatternString includedBlessings: included excludedBlessings: excludedBlessings
    ^ nil! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
currentVersion
    ^ self version isSomethingLoaded
        ifTrue: [ self version ]
        ifFalse: [ nil ]! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
latestVersion
    ^ self version! !

!MetacelloMCBaselineProject methodsFor: 'versions' stamp: ''!
currentVersionAgainst: resolvedPackageAndProjectNames
    ^ nil! !

!MetacelloMCBaselineProject class methodsFor: 'accessing' stamp: ''!
singletonVersionName
    ^ 'baseline'! !

!MetacelloMCBaselineProject class methodsFor: 'accessing' stamp: ''!
versionConstructorClass
    ^ MetacelloBaselineConstructor! !

!MetacelloMCConfigurationOfProjectSpec methodsFor: 'printing' stamp: ''!
hasClassName
    ^ className ~~ nil and: [ className ~= self constructClassName ]! !

!MetacelloMCConfigurationOfProjectSpec methodsFor: 'testing' stamp: ''!
hasConflictWithBaselineSpec: projectSpec
	projectSpec name = self name
		ifFalse: [ ^ true ].
	projectSpec project configuration className = self project configuration className
		ifFalse: [ ^ true ].
	^ ((projectSpec repositories isEmpty or: [ self repositories isEmpty ])
		or: [ projectSpec repositories hasNoLoadConflicts: self repositories ]) not! !

!MetacelloMCConfigurationOfProjectSpec methodsFor: 'mutability' stamp: ''!
copyForRegistration: aMetacelloProjectRegistration onWrite: aBlock
  | copy |
  aMetacelloProjectRegistration
    configurationProjectSpecIfPresent: [ :spec | 
      copy := spec copy.
      aBlock value: copy.
      aMetacelloProjectRegistration configurationProjectSpec: copy ]
    ifAbsent: [ 
      aMetacelloProjectRegistration
        baselineProjectSpecIfPresent: [ :spec | 
          copy := spec copy.
          aBlock value: copy.
          aMetacelloProjectRegistration baselineProjectSpec: copy ]
        ifAbsent: [ aBlock value: nil ] ]! !

!MetacelloMCConfigurationOfProjectSpec methodsFor: 'scripting' stamp: ''!
asConfigurationProjectSpec
    ^ self! !

!MetacelloMCConfigurationOfProjectSpec methodsFor: 'testing' stamp: ''!
isConfigurationOfProjectSpec
	^ true! !

!MetacelloMCConfigurationOfProjectSpec methodsFor: 'printing' stamp: ''!
projectLabel
    ^ 'configuration'! !

!MetacelloMCConfigurationOfProjectSpec methodsFor: 'testing' stamp: ''!
hasConflictWithProjectSpec: projectSpec
	^ projectSpec hasConflictWithConfigurationSpec: self! !

!MetacelloMCConfigurationOfProjectSpec methodsFor: 'scripting' stamp: ''!
asProjectRegistration
    ^ MetacelloProjectRegistration fromMCConfigurationProjectSpec: self! !

!MetacelloMCConfigurationOfProjectSpec methodsFor: 'private' stamp: ''!
constructClassName
    ^ 'ConfigurationOf' , self name! !

!MetacelloMCConfigurationOfProjectSpec methodsFor: 'merging' stamp: ''!
mergeSpec: anotherSpec
    ^ super mergeSpec: anotherSpec asConfigurationProjectSpec! !

!MetacelloMCGroupSpecTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!MetacelloMCNamelessProjectSpec methodsFor: 'mutability' stamp: ''!
copyForRegistration: aMetacelloProjectRegistration onWrite: aBlock
	self error: 'Should be converting to configuration spec for the registration, so we should not get here'! !

!MetacelloMCNamelessProjectSpec methodsFor: 'scripting' stamp: ''!
asProjectSpecForVersion: vrsn
  "I'm a reference spec and my project comes from the project I'm loaded from, not the project I am loading"

  "https://github.com/dalehenrich/metacello-work/issues/331"

  | proj spec |
  proj := vrsn ifNil: [ ^ self ] ifNotNil: [ vrsn versionSpec project ].
  spec := proj configurationOfProjectSpecClass for: proj.
  self copyForScriptingInto: spec.
  spec loader: self loader.
  self assert: (self className beginsWith: 'BaselineOf') not.
  ^ spec! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemovePackageB
    "used by MetacelloAbstractVersionConstructor>>removePackage:"

    | packages removed |
    packages := self packagesSpec.
    packages
        add:
            (self packageSpec
                name: 'Package';
                requires: 'AnotherPackage';
                includes: 'IncludedPackage';
                answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
                file: 'Package-dkh.1';
                preLoadDoIt: #'preLoadDoIt';
                postLoadDoIt: #'postLoadDoIt';
                yourself).
    packages
        remove:
            {(self packageSpec
                name: 'Package';
                yourself)}.
    removed := false.
    packages packageNamed: 'Package' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddPackageC
    "used by MetacelloAbstractVersionConstructor>>package: and MetacelloAbstractVersionConstructor>>package:overrides:"

    | packages |
    packages := self packagesSpec.
    packages
        add:
            {'Platform'.
            'Base'.
            'Tests'}.
    packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    packages packageNamed: 'Base' ifAbsent: [ self assert: false ].
    packages packageNamed: 'Tests' ifAbsent: [ self assert: false ]! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testCopyToPackage
	"not currently used by MetacelloAbstractVersionConstructor"

	| packages package |
	packages := self packagesSpec.
	packages
		add:
			(self packageSpec
				name: 'Package';
				requires: 'AnotherPackage';
				includes: 'IncludedPackage';
				answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
				file: 'Package-dkh.1';
				preLoadDoIt: #preLoadDoIt;
				postLoadDoIt: #postLoadDoIt;
				yourself).
	packages
		copy: 'Package'
		to:
			(self packageSpec
				name: 'PackageCopy';
				yourself).
	package := packages packageNamed: 'PackageCopy' ifAbsent: [ self assert: false ].
	self assert: package name equals: 'PackageCopy'.
	self assert: package requires equals: #('AnotherPackage').
	self assert: package includes equals: #('IncludedPackage').
	self assert: package answers equals: #(#('preload' 'preload answer') #('postload' 'postload answer')).
	self assert: package file equals: 'Package-dkh.1'.
	self assert: package preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: package postLoadDoIt value identicalTo: #postLoadDoIt! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemovePackageC
    "used by MetacelloAbstractVersionConstructor>>removePackage:"

    | packages removed |
    packages := self packagesSpec.
    packages
        add:
            (self packageSpec
                name: 'Package';
                requires: 'AnotherPackage';
                includes: 'IncludedPackage';
                answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
                file: 'Package-dkh.1';
                preLoadDoIt: #'preLoadDoIt';
                postLoadDoIt: #'postLoadDoIt';
                yourself).
    packages remove: {'Package'}.
    removed := false.
    packages packageNamed: 'Package' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testMergePackageD
    "used by MetacelloAbstractVersionConstructor>>package:with:"

    | packages |
    packages := self packagesSpec.
    packages
        add: 'Platform';
        merge: 'Tests'.
    packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    packages packageNamed: 'Tests' ifAbsent: [ self assert: false ]! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemovePackageD
    "used by MetacelloAbstractVersionConstructor>>removePackage:"

    | packages removed |
    packages := self packagesSpec.
    packages
        add:
            (self packageSpec
                name: 'Package';
                requires: 'AnotherPackage';
                includes: 'IncludedPackage';
                answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
                file: 'Package-dkh.1';
                preLoadDoIt: #'preLoadDoIt';
                postLoadDoIt: #'postLoadDoIt';
                yourself).
    packages remove: 'Package'.
    removed := false.
    packages packageNamed: 'Package' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddPackageB
	"used by MetacelloAbstractVersionConstructor>>package: and MetacelloAbstractVersionConstructor>>package:overrides:"

	| packages package |
	packages := self packagesSpec.
	packages
		add:
			{(self packageSpec
				name: 'Package';
				requires: 'AnotherPackage';
				includes: 'IncludedPackage';
				answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
				file: 'Package-dkh.1';
				preLoadDoIt: #preLoadDoIt;
				postLoadDoIt: #postLoadDoIt;
				yourself) . (self packageSpec
				name: 'Package';
				requires: 'AndAnotherPackage';
				includes: 'AndIncludedPackage';
				answers: #(#('postload' 'postload answer'));
				file: 'Package-dkh.2';
				yourself)}.
	package := packages packageNamed: 'Package' ifAbsent: [ self assert: false ].
	self assert: package name equals: 'Package'.
	self assert: package requires equals: #('AndAnotherPackage').
	self assert: package includes equals: #('AndIncludedPackage').
	self assert: package answers equals: #(#('postload' 'postload answer')).
	self assert: package file equals: 'Package-dkh.2'.
	self assert: package preLoadDoIt value identicalTo: nil.
	self assert: package postLoadDoIt value identicalTo: nil! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testMergePackageA
	"used by MetacelloAbstractVersionConstructor>>package:with:"

	| packages package |
	packages := self packagesSpec.
	packages
		add:
			(self packageSpec
				name: 'Package';
				requires: 'AnotherPackage';
				includes: 'IncludedPackage';
				answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
				file: 'Package-dkh.1';
				preLoadDoIt: #preLoadDoIt;
				postLoadDoIt: #postLoadDoIt;
				yourself).
	packages
		merge:
			(self packageSpec
				name: 'Package';
				requires: 'AndAnotherPackage';
				includes: 'AndIncludedPackage';
				answers: #(#('xpostload' 'xpostload answer'));
				file: 'Package-dkh.2';
				yourself).
	package := packages packageNamed: 'Package' ifAbsent: [ self assert: false ].
	self assert: package name equals: 'Package'.
	self assert: package requires equals: #('AnotherPackage' 'AndAnotherPackage').
	self assert: package includes equals: #('IncludedPackage' 'AndIncludedPackage').
	self assert: package answers equals: #(#('preload' 'preload answer') #('postload' 'postload answer') #('xpostload' 'xpostload answer')).
	self assert: package file equals: 'Package-dkh.2'.
	self assert: package preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: package postLoadDoIt value identicalTo: #postLoadDoIt! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemovePackageA
    "used by MetacelloAbstractVersionConstructor>>removePackage:"

    | packages removed |
    packages := self packagesSpec.
    packages
        add:
            (self packageSpec
                name: 'Package';
                requires: 'AnotherPackage';
                includes: 'IncludedPackage';
                answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
                file: 'Package-dkh.1';
                preLoadDoIt: #'preLoadDoIt';
                postLoadDoIt: #'postLoadDoIt';
                yourself).
    packages
        remove:
            (self packageSpec
                name: 'Package';
                yourself).
    removed := false.
    packages packageNamed: 'Package' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testMergePackageB
	"used by MetacelloAbstractVersionConstructor>>package:with:"

	| packages package |
	packages := self packagesSpec.
	packages
		add:
			(self packageSpec
				name: 'Package';
				requires: 'AnotherPackage';
				includes: 'IncludedPackage';
				answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
				file: 'Package-dkh.1';
				preLoadDoIt: #preLoadDoIt;
				postLoadDoIt: #postLoadDoIt;
				yourself).
	packages
		merge:
			{(self packageSpec
				name: 'Package';
				requires: 'AndAnotherPackage';
				includes: 'AndIncludedPackage';
				answers: #(#('xpostload' 'xpostload answer'));
				file: 'Package-dkh.2';
				yourself)}.
	package := packages packageNamed: 'Package' ifAbsent: [ self assert: false ].
	self assert: package name equals: 'Package'.
	self assert: package requires equals: #('AnotherPackage' 'AndAnotherPackage').
	self assert: package includes equals: #('IncludedPackage' 'AndIncludedPackage').
	self assert: package answers equals: #(#('preload' 'preload answer') #('postload' 'postload answer') #('xpostload' 'xpostload answer')).
	self assert: package file equals: 'Package-dkh.2'.
	self assert: package preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: package postLoadDoIt value identicalTo: #postLoadDoIt! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddPackageA
	"used by MetacelloAbstractVersionConstructor>>package: and MetacelloAbstractVersionConstructor>>package:overrides:"

	| packages package |
	packages := self packagesSpec.
	packages
		add:
			(self packageSpec
				name: 'Package';
				requires: 'AnotherPackage';
				includes: 'IncludedPackage';
				answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
				file: 'Package-dkh.1';
				preLoadDoIt: #preLoadDoIt;
				postLoadDoIt: #postLoadDoIt;
				yourself).
	packages
		add:
			(self packageSpec
				name: 'Package';
				requires: 'AndAnotherPackage';
				includes: 'AndIncludedPackage';
				answers: #(#('postload' 'postload answer'));
				file: 'Package-dkh.2';
				yourself).
	package := packages packageNamed: 'Package' ifAbsent: [ self assert: false ].
	self assert: package name equals: 'Package'.
	self assert: package requires equals: #('AndAnotherPackage').
	self assert: package includes equals: #('AndIncludedPackage').
	self assert: package answers equals: #(#('postload' 'postload answer')).
	self assert: package file equals: 'Package-dkh.2'.
	self assert: package preLoadDoIt value identicalTo: nil.
	self assert: package postLoadDoIt value identicalTo: nil! !

!MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddPackageD
    "used by MetacelloAbstractVersionConstructor>>package: and MetacelloAbstractVersionConstructor>>package:overrides:"

    | packages |
    packages := self packagesSpec.
    packages add: 'Platform'.
    packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aProjectIsLoaded
	^aProjectIsLoaded! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedPackageIsNotCurrent
	^ aLoadedPackageIsNotCurrent! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aProjectNotLoaded: aBoolean
	aProjectNotLoaded := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedProjectIsExact: aBoolean
	aLoadedProjectIsExact := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
hasNoPackage: aBoolean
	hasNoPackage := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedPackageIsNotCurrent: aBoolean
	aLoadedPackageIsNotCurrent := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aPackageIsLoaded: aBoolean
	aPackageIsLoaded := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aProjectIsLoaded: aBoolean
	aProjectIsLoaded := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
vrsnStatus
	^vrsnStatus! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
abort
	^ abort! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aProjectNotLoaded
	^aProjectNotLoaded! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
hasNoProject: aBoolean
	hasNoProject := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedPackageIsExact: aBoolean
	aLoadedPackageIsExact := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedPackageIsCurrent: aBoolean
	aLoadedPackageIsCurrent := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'testing' stamp: ''!
isLoadedToSpec: matchBlock
	"all loaded projects and packages match specifications (at least one package loaded)"

	| matchStatus |
	matchStatus := #loadedToSpec.
	(self evaluateStatus: #(#allLoadedToSpec #loadedToSpec))
		ifTrue: [ 
			aPackageIsLoaded & aProjectIsLoaded
				ifTrue: [ 
					(aLoadedPackageIsExact & aLoadedPackageIsCurrent not & aLoadedPackageIsNotCurrent not
						and: [ aLoadedProjectIsExact & aLoadedProjectIsCurrent not & aLoadedProjectIsNotCurrent not ])
						ifTrue: [ matchBlock value: matchStatus ] ]
				ifFalse: [ 
					aPackageIsLoaded
						ifTrue: [ 
							aLoadedPackageIsExact & aLoadedPackageIsCurrent not & aLoadedPackageIsNotCurrent not
								ifTrue: [ matchBlock value: matchStatus ] ]
						ifFalse: [ 
							hasNoPackage & aLoadedProjectIsExact & aLoadedProjectIsCurrent not & aLoadedProjectIsNotCurrent not
								ifTrue: [ matchBlock value: matchStatus ] ] ] ]! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedProjectIsCurrent: aBoolean
	aLoadedProjectIsCurrent := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedPackageIsCurrent
	^ aLoadedPackageIsCurrent! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aPackageNotLoaded: aBoolean
	aPackageNotLoaded := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'testing' stamp: ''!
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: ''!
isAllLoadedToSpec: matchBlock
        "all projects and packages are loaded and match specification"

	(self evaluateStatus: #(#allLoadedToSpec))
		ifTrue: [ 
			((hasNoPackage
				or: [ 
					aPackageIsLoaded & aPackageNotLoaded not & aLoadedPackageIsExact & aLoadedPackageIsNotCurrent not
						& aLoadedPackageIsCurrent not ])
				and: [ 
					hasNoProject
						or: [ 
							aProjectIsLoaded & aProjectNotLoaded not & aLoadedProjectIsExact & aLoadedProjectIsNotCurrent not
								& aLoadedProjectIsCurrent not ] ])
				ifTrue: [ matchBlock value: #allLoadedToSpec ] ]! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aPackageNotLoaded
	^aPackageNotLoaded! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	hasNoPackage := hasNoProject := true.
	aProjectIsLoaded := aPackageIsLoaded := false.
	aLoadedProjectIsExact := aLoadedPackageIsExact := false.
	aLoadedProjectIsCurrent := aLoadedPackageIsCurrent := false.
	aLoadedProjectIsNotCurrent := aLoadedPackageIsNotCurrent := false.
	aProjectNotLoaded := aPackageNotLoaded := false.
	vrsnStatus := Set new.
	abort := false! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
hasNoProject
	^ hasNoProject! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedProjectIsExact
	^ aLoadedProjectIsExact! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'evaulation' stamp: ''!
evaluateStatus: validStatusList
	^self abort
		ifTrue: [ false ]
		ifFalse: [ 
			(self hasNoProject or: [ self vrsnStatus isEmpty ])
				ifTrue: [ true ]
				ifFalse: [ 
					| valid |
					valid := true.
					vrsnStatus
						do: [ :status | 
							(validStatusList includes: status)
								ifFalse: [ valid := false ] ].
					valid ] ]! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aPackageIsLoaded
	^aPackageIsLoaded! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedProjectIsNotCurrent
	^ aLoadedProjectIsNotCurrent! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
abort: aBoolean
	abort := aBoolean! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedPackageIsExact
	^ aLoadedPackageIsExact! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'testing' stamp: ''!
isSomethingLoaded: somethingLoadedBlock
	"at least one package loaded"

	(self evaluateStatus: #(#allLoadedToSpec #loadedToSpec #loadedMatchConstraints #somethingLoaded))
		ifTrue: [ 
			aPackageIsLoaded
				ifTrue: [ somethingLoadedBlock value: #somethingLoaded ] ]! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
hasNoPackage
	^ hasNoPackage! !

!MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: ''!
aLoadedProjectIsNotCurrent: aBoolean
	aLoadedProjectIsNotCurrent := aBoolean! !

!MetacelloMCPartiallyLoadedStatus class methodsFor: 'instance creation' stamp: ''!
new
	^ self basicNew initialize! !

!MetacelloMCProject methodsFor: 'spec classes' stamp: ''!
configurationOfProjectSpecClass
    ^ MetacelloMCConfigurationOfProjectSpec! !

!MetacelloMCProject methodsFor: 'spec classes' stamp: ''!
repositoriesSpecClass

	^MetacelloRepositoriesSpec! !

!MetacelloMCProject methodsFor: 'development support' stamp: ''!
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: ''!
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: 'spec classes' stamp: ''!
packageSpec

	^self packageSpecClass for: self! !

!MetacelloMCProject methodsFor: 'spec classes' stamp: ''!
defaultLoaderClass

	^MetacelloLoadingMCSpecLoader! !

!MetacelloMCProject methodsFor: 'spec classes' stamp: ''!
repositorySpecClass

	^MetacelloRepositorySpec! !

!MetacelloMCProject methodsFor: 'repository updating' stamp: ''!
updatePackageRepositoriesFor: versionString

	| versionSpec |
	(versionSpec := (self version: versionString) versionSpec) packageSpecsInLoadOrder do: [:pkgSpec |
		pkgSpec updatePackageRepositoriesFor: versionSpec ].
	^true! !

!MetacelloMCProject methodsFor: 'development support' stamp: ''!
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: 'spec classes' stamp: ''!
projectSpecClass
	^ MetacelloMCNamelessProjectSpec! !

!MetacelloMCProject methodsFor: 'development support' stamp: ''!
fetchProject
	"fetch the latest version of the configuration package"
	
	^self fetchProject: MetacelloLoaderPolicy new! !

!MetacelloMCProject methodsFor: 'repository creation' stamp: ''!
createRepository: aRepositorySpec

	^ MetacelloPlatform current createRepository: aRepositorySpec! !

!MetacelloMCProject methodsFor: 'development support' stamp: ''!
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 ~~ MetacelloPlatform current defaultPackageCache ]
        ifNone: [ 
          MetacelloNotification signal: ('Using cache repository for ' , self label , ' project package').
          MetacelloPlatform current defaultPackageCache ].
      pkgSpec repository: (repo asRepositorySpecFor: self).
      ^ pkgSpec ].
  ^ nil! !

!MetacelloMCProject methodsFor: 'spec classes' stamp: ''!
baselineOfProjectSpecClass
    ^ MetacelloMCBaselineOfProjectSpec! !

!MetacelloMCProject methodsFor: 'development support' stamp: ''!
saveProject

	| pkgSpec |
	(pkgSpec := self projectPackage) == nil ifTrue: [ ^false ].
	^pkgSpec savePackage! !

!MetacelloMCProject methodsFor: 'development support' stamp: ''!
goferCommitProject: commitMessage

	| pkgSpec |
	(pkgSpec := self projectPackage) == nil ifTrue: [ ^false ].
	^pkgSpec goferCommitPackage: commitMessage! !

!MetacelloMCProject methodsFor: 'development support' stamp: ''!
goferBranch: branchName project: commitMessage
    | pkgSpec |
    pkgSpec := self projectPackage.
    pkgSpec file: pkgSpec name , '.' , branchName.
    ^ pkgSpec goferBranchPackage: branchName message: commitMessage! !

!MetacelloMCProject methodsFor: 'scripting' stamp: ''!
asConfigurationProject
    ^ self! !

!MetacelloMCProject methodsFor: 'spec classes' stamp: ''!
packageSpecClass

	^MetacelloPackageSpec! !

!MetacelloMCProject methodsFor: 'private' stamp: ''!
pragmaKeywords

	^super pragmaKeywords, #(projectPackage:attribute: packages:attribute: repositories:attribute: )! !

!MetacelloMCProject methodsFor: 'spec classes' stamp: ''!
repositorySpec

	^self repositorySpecClass for: self! !

!MetacelloMCProject methodsFor: 'spec classes' stamp: ''!
repositoriesSpec

	^self repositoriesSpecClass for: self! !

!MetacelloMCProject methodsFor: 'development support' stamp: ''!
setBaselineRepositoryDescription: aListOrRepositoryDescriptions
    "noop "! !

!MetacelloMCProject methodsFor: 'spec classes' stamp: ''!
versionSpecClass

	^MetacelloMCVersionSpec! !

!MetacelloMCProject methodsFor: 'development support' stamp: ''!
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: 'scripting' stamp: ''!
projectForScriptEngine: aMetacelloScriptEngine unconditionalLoad: aBool
    ^ aMetacelloScriptEngine getConfigurationProjectUnconditionalLoad: aBool! !

!MetacelloMCProject methodsFor: 'scripting' stamp: ''!
asBaselineProject
    ^ MetacelloMCBaselineProject new! !

!MetacelloMCProjectReferenceSpecTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!MetacelloMCProjectSpec methodsFor: 'private' stamp: ''!
resolveToAllPackagesIn: aVersionSpec visited: visited
    | vrsn |
    visited
        pushProject: [ 
            visited
                visit: self
                doing: [ :spec | 
                    spec ensureProjectLoaded.
                    vrsn := spec version.
                    ^ vrsn
                        allPackagesForSpecNamed: (self loadListForVersion: vrsn)
                        ifAbsent: [ self error: 'invalid loads: spec' ] ] ].
    ^ #()! !

!MetacelloMCProjectSpec methodsFor: 'private - loading' stamp: ''!
ensureProjectFetch: mcLoader

	"projectClass == nil or version == nil"
	mcLoader ensureForDevelopment 
		ifTrue: [ 
			self notifyCleanStackCache.
			self ensureLoadUsing: mcLoader ]
		ifFalse: [ 
			self fetchUsing: mcLoader ].
		
	mcLoader ensuredMap 
		at: self name 
		put: #'present'! !

!MetacelloMCProjectSpec methodsFor: 'loading' stamp: ''!
loadVersion: aVersionOrNil
	"Load the correct version of the project"

	| vrsn mcLoader list |
	self ensureProjectLoaded.
	vrsn := aVersionOrNil.
	vrsn == nil
		ifTrue: [ [ vrsn := self version ]
				on: MetacelloVersionDoesNotExistError
				do: [ :ex | 
					^ (MetacelloProjectSpecLoadError projectSpec: self)
						versionDoesNotExistException: ex;
						signal:
							'No version found for ' , self versionString printString , ' of '
								, self className asString , ' because: ' , ex description ] ].
	mcLoader := self loader copy.
	mcLoader operator: self operator.
	vrsn loader: mcLoader.
	list := (mcLoader ignoreImage
		ifTrue: [ self loadListForVersion: vrsn ]
		ifFalse: [ vrsn
				packageAndProjectNamesToLoad: (self loadListForVersion: vrsn)
				loader: mcLoader ]) asSet.
	MetacelloPlatform current
		useStackCacheDuring: [ :dict | 
			| projectCache cachedList |
			projectCache := dict
				at: self projectClass
				ifAbsent: [ dict at: self projectClass put: Dictionary new ].
			(cachedList := projectCache at: vrsn ifAbsent: [  ]) == nil
				ifTrue: [ projectCache at: vrsn put: list ]
				ifFalse: [ 
					(cachedList size = list size 
					and: [ cachedList allSatisfy: [ :each | list  includes: each ] ])
						ifTrue:
							[ "no need to refetch list ... recursion stoppper (Issue 95)" ^ self ]
						ifFalse: [ projectCache at: vrsn put: list ] ].
			vrsn versionString ~= self versionString
				ifTrue: [ MetacelloNotification signal: (' [' , vrsn versionString , ']') ].
			mcLoader preLoad: self.
			vrsn fetchRequiredFromArray: list.	"do the load"
			(MetacelloProjectSpecLoadedNotification new
				projectSpec: (self copy versionString: vrsn versionString)) signal.
			mcLoader postLoad: self ]
		defaultDictionary: Dictionary new! !

!MetacelloMCProjectSpec methodsFor: 'testing' stamp: ''!
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: 'development support' stamp: ''!
updateForSpawnMethod: sourceSpec
	"This means that this spec was used in a baseline and will be used in a version .... drop all information that isn't useful"
	
	repositories := className := operator := loads := projectPackage := nil.
	sourceSpec ~~ nil ifTrue: [ versionString := sourceSpec versionString ].! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
canDowngradeTo: aMetacelloProjectSpec
    ^ (super canDowngradeTo: aMetacelloProjectSpec) and: [ self file = aMetacelloProjectSpec file ]! !

!MetacelloMCProjectSpec methodsFor: 'querying' stamp: ''!
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: ''!
file
    file ifNil: [ ^ self className ].
    ^ file! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
metacelloRegistrationHash
    "file"

    ^ String stringHash: self file initialHash: super metacelloRegistrationHash! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
asBaselineProjectSpec
    ^ self copyForScriptingInto: (MetacelloMCBaselineOfProjectSpec for: self project asBaselineProject)! !

!MetacelloMCProjectSpec methodsFor: 'accessing' stamp: ''!
baseName
	^ MetacelloScriptEngine baseNameOf: self className! !

!MetacelloMCProjectSpec methodsFor: 'accessing' stamp: ''!
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: 'construction' stamp: ''!
file: aString constructor: aVersionConstructor
    aVersionConstructor fileForProject: aString! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
hasNoLoadConflicts: aMetacelloProjectSpec
  "'projectPackage repositories'"

  ^ (super hasNoLoadConflicts: aMetacelloProjectSpec)
    and: [ self file = aMetacelloProjectSpec file ]! !

!MetacelloMCProjectSpec methodsFor: 'testing' stamp: ''!
hasConflictWithConfigurationSpec: projectSpec
	^ self hasLoadConflicts: projectSpec! !

!MetacelloMCProjectSpec methodsFor: 'private - loading' stamp: ''!
loadProjectIsLocked: version
	"Just inform is already loaded"

	MetacelloProjectSpecLoadedNotification new
		projectSpec: (self copy versionString: version versionString);
		signal! !

!MetacelloMCProjectSpec methodsFor: 'accessing' stamp: ''!
packageFileSpecFor: aMetacelloPackagesSpec

	^(aMetacelloPackagesSpec project projectReferenceSpec)
			name: self name;
			projectReference: self copy;
			yourself.! !

!MetacelloMCProjectSpec methodsFor: 'accessing' stamp: ''!
projectPackage
    projectPackage
        ifNil: [ 
            self className ifNil: [ ^ nil ].
            projectPackage := self project packageSpec.
            projectPackage name: self className.
            self getFile ifNotNil: [ projectPackage file: self file ].
            projectPackage repositories: self getRepositories ].
    ^ projectPackage! !

!MetacelloMCProjectSpec methodsFor: 'accessing' stamp: ''!
className: aString
    super className: aString.
    self projectPackage: nil! !

!MetacelloMCProjectSpec methodsFor: 'querying' stamp: ''!
projectClass
    self className == nil
        ifTrue: [ ^ nil ].
    ^ Smalltalk at: self className asSymbol ifAbsent: [  ]! !

!MetacelloMCProjectSpec methodsFor: 'accessing' stamp: ''!
file: aString
    self shouldBeMutable.
    file := aString.
    self projectPackage: nil! !

!MetacelloMCProjectSpec methodsFor: 'private - loading' stamp: ''!
notifyCleanStackCache
	| pc |

	(pc := self projectClass) ~~ nil
		ifTrue: [ 
 			MetacelloClearStackCacheNotification signal: #(
				#'currentVersion' 
				#'currentVersionAgainst:' 
				#'currentVersionInfo' 
				#'versionConstructor' 
				#'loadableSpecNames'), 
				{ pc } ]! !

!MetacelloMCProjectSpec methodsFor: 'loading' stamp: ''!
ensureConfigurationLoaded: vrsn ensured: ensured
  "answer true if the configuration should be reloaded:
    blessing is #development
    symbolic version (https://github.com/dalehenrich/metacello-work/issues/283)"

  (vrsn blessing == #'development' or: [ self versionString isSymbol ])
    ifTrue: [ 
      ensured ~~ #'latest'
        ifTrue: [ ^ MetacelloScriptEnsureProjectLoadedForDevelopment signal ] ].
  ^ false! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
copyForScriptingInto: aProjectSpec
    ^aProjectSpec
        setName: name;
        className: className;
        versionString: versionString;
        operator: operator;
        setLoads: loads;
        preLoadDoIt: preLoadDoIt;
        postLoadDoIt: postLoadDoIt;
        repositories: repositories copy;
        file: file! !

!MetacelloMCProjectSpec methodsFor: 'loading' stamp: ''!
ensureLoadUsing: aLoader
  | pp |
  pp := (MetacelloLookupProjectSpec new
    projectSpec: self;
    yourself) signal projectPackage.
  pp
    ifNil: [ 
      self
        error:
          'Unable to resolve project package for ' , self name printString
            ,
              '. It is likely that that the configuration referencing this project will not validate properly (see MetacelloToolBox class>>validateConfiguration:).' ].
  pp ensureLoadUsing: aLoader! !

!MetacelloMCProjectSpec methodsFor: 'testing' stamp: ''!
hasConflictWithProjectSpec: projectSpec
  (self className beginsWith: 'BaselineOf')
    ifTrue: [ ^ projectSpec hasConflictWithBaselineSpec: self asBaselineProjectSpec ].
  ^ projectSpec
    hasConflictWithConfigurationSpec: self asConfigurationProjectSpec! !

!MetacelloMCProjectSpec methodsFor: 'querying' stamp: ''!
relativeCurrentVersion
    "currentVersion calculated relative to the loadList"

    | vrsn expanded loadList |
    (vrsn := self versionOrNil) == nil
        ifTrue: [ ^ nil ].
    expanded := [ vrsn expandToLoadableSpecNames: (loadList := self loadListForVersion: vrsn) ]
        on: Error
        do: [ :ex | 
            vrsn blessing == #'development'
                ifTrue: [ 
                    self ensureLoadUsing: self loader.
                    vrsn := self versionOrNil.
                    ex return: (vrsn expandToLoadableSpecNames: loadList) ].
            ex pass ].
    ^ self projectClassProject currentVersionAgainst: expanded! !

!MetacelloMCProjectSpec methodsFor: 'testing' stamp: ''!
isPossibleBaseline

	| vrsn |
	(vrsn := self versionOrNil) == nil ifTrue: [ ^false ].
	(vrsn allPackagesForSpecNamed: (self loadListForVersion: vrsn)) do: [:pkg |
		pkg workingCopy == nil ifTrue: [ ^false ]].
	^true! !

!MetacelloMCProjectSpec methodsFor: 'loading' stamp: ''!
ensureProjectLoaded
  "Ensure that the MetacelloProject is loaded in image. 
	 projectClass == nil or requested version non-existent warrants a project package load."

  "answer true if the projectClass exists"

  (self projectClass == nil
    or: [ 
      self versionOrNil == nil
        or: [ (loader notNil or: [ self isMutable ]) and: [ self loader ignoreImage ] ] ])
    ifTrue: [ 
      | pc |
      (pc := self projectClass) ~~ nil
        ifTrue: [ 
          MetacelloClearStackCacheNotification
            signal:
              #(#'currentVersion' #'currentVersionAgainst:' #'currentVersionInfo' #'versionConstructor' #'loadableSpecNames')
                , {pc} ].
      self projectPackage ifNil: [ ^ true ].
      self ensureLoadUsing: self loader ].
  ^ self projectClass ~~ nil! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
validateForScriptLoad: aScriptEngine withDefaultVersionString: defaultVersionString withDefaultRepositoryDecription: defaultRepositoryDecription
    | issues callSite |
    issues := OrderedCollection new.
    callSite := #'validateForScriptLoad:withDefaultVersionString:withDefaultRepositoryDecription:'.
    self name
        ifNil: [ 
            issues
                add:
                    (MetacelloValidationError
                        configurationClass: self projectClass
                        reasonCode: #'incompleteProjectSpec'
                        callSite: callSite
                        explanation: 'name field required') ].
    self className
        ifNil: [ 
            issues
                add:
                    (MetacelloValidationError
                        configurationClass: self projectClass
                        reasonCode: #'incompleteProjectSpec'
                        callSite: callSite
                        explanation: 'className field required') ].
    self repositories isEmpty
        ifTrue: [ 
            defaultRepositoryDecription
                ifNotNil: [ self repository: defaultRepositoryDecription ]
                ifNil: [ 
                    issues
                        add:
                            (MetacelloValidationError
                                configurationClass: self projectClass
                                reasonCode: #'incompleteProjectSpec'
                                callSite: callSite
                                explanation: 'repository field required') ] ].
    self validateVersionString: issues withDefaultVersionString: defaultVersionString.
    ^ issues! !

!MetacelloMCProjectSpec methodsFor: 'accessing' stamp: ''!
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: 'querying' stamp: ''!
projectClassProject
    "indirection needed when projectClass is _not_ a subclass of MetacelloProject"

    ^ self projectClass new project
        setBaselineRepositoryDescription: self repositoryDescriptions;
        yourself! !

!MetacelloMCProjectSpec methodsFor: 'mutability' stamp: ''!
copyForRegistration: aMetacelloProjectRegistration onWrite: aBlock
    self subclassResponsibility! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
asProjectSpecForVersion: vrsn
  ^ self! !

!MetacelloMCProjectSpec methodsFor: 'loading' stamp: ''!
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 cvs |
    self projectClass == nil
        ifTrue: [ ^ nil ].
    (version := self versionOrNil) == nil
        ifTrue: [ ^ nil ].
    version blessing == #'baseline'
        ifTrue: [ ^ version ].
    self loader ignoreImage
        ifTrue: [ ^ version ].
    prjct := self projectClass new project.
    prjct loader: self loader.
    (currentVersion := prjct currentVersion) == nil
        ifTrue: [ ^ nil ].
    (cvs := currentVersion versionStatus) == #'somethingLoaded'
        ifTrue: [ ^ nil ].
    (#(#'allLoadedToSpec' #'loadedToSpec' #'loadedMatchConstraints') includes: (cvs := currentVersion versionStatus))
        ifTrue: [ 
            (currentVersion perform: self operator with: version)
                ifTrue: [ 
                    "load currentVersion"
                    ^ currentVersion ].	"load version"
            ^ nil ].
    version = currentVersion
        ifTrue: [ ^ currentVersion ].	"I don't believe that it is possible to reach this point in the method, so I will be interested if I run across a case that produces this error"
    (MetacelloProjectSpecLoadConflict projectSpec: self)
        signal:
            'Project load conflict for' , prjct label printString , ' between current version ' , currentVersion printString , '('
                , cvs asString , ') and specified version ' , version printString
                , '. Press resume to continue with load anyway'.
    ^ nil! !

!MetacelloMCProjectSpec methodsFor: 'testing' stamp: ''!
isConfigurationOfProjectSpec
	^ false! !

!MetacelloMCProjectSpec methodsFor: 'loading' stamp: ''!
fetchUsing: aLoader
    (MetacelloLookupProjectSpec new
        projectSpec: self;
        yourself) signal projectPackage fetchUsing: aLoader! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
versionForScriptEngine: aMetacelloScriptEngine
    | prj |
    prj := self projectClass ifNil: [ self project ] ifNotNil: [ self projectClassProject ].
    ^ ((prj projectForScriptEngine: aMetacelloScriptEngine) version: self versionString)
        silently: aMetacelloScriptEngine silently;
        ignoreImage: aMetacelloScriptEngine ignoreImage;
        cacheRepository: aMetacelloScriptEngine cacheRepository;
        repositoryOverrides: aMetacelloScriptEngine repositoryOverrides! !

!MetacelloMCProjectSpec methodsFor: 'testing' stamp: ''!
isBaselineOfProjectSpec
	^ false! !

!MetacelloMCProjectSpec methodsFor: 'testing' stamp: ''!
hasConflictWithBaselineSpec: projectSpec
	^ self hasLoadConflicts: projectSpec! !

!MetacelloMCProjectSpec methodsFor: 'accessing' stamp: ''!
workingCopy
  ^ self projectPackage workingCopy! !

!MetacelloMCProjectSpec methodsFor: 'testing' stamp: ''!
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: ''!
allPackagesLoaded: aLoader
    "answer true if all of the packages (excluding projects) are loaded"

    | vrsn pkgs |
    (vrsn := self versionOrNil) == nil
        ifTrue: [ ^ false ].
    pkgs := OrderedCollection new.
    (self loadListForVersion: vrsn)
        do: [ :nm | 
            vrsn packages
                do: [ :pkg | 
                    (pkg isPackageLoaded: aLoader)
                        ifFalse: [ ^ false ] ] ].
    ^ true! !

!MetacelloMCProjectSpec methodsFor: 'loading' stamp: ''!
ensureLoadedForDevelopmentUsing: mcLoader
  "for #development projects, always need latest version of package when contemplating a load"
  | ensured |

	self isLocked ifTrue: [ 
		mcLoader ensuredMap at: self name put: #'present'.
		^ self ].

	ensured := mcLoader ensuredMap at: self name ifAbsent: [ nil ].	
	self projectClass ifNotNil: [
		self ensureProjectLoaded: mcLoader ensured: ensured.
		^ self ].

  ensured ifNil: [ 
	self ensureProjectFetch: mcLoader ]! !

!MetacelloMCProjectSpec methodsFor: 'development support' stamp: ''!
updatePackageSpec: updatedSpecs
    "Add project copy to updatedSpecs if the current version of the project 
	 is different from the receiver's version"

    | prj currentVersion spec |
    className == nil
        ifTrue: [ ^ self ].
    prj := self projectClassProject.
    (currentVersion := prj currentVersion) = self versionOrNil
        ifTrue: [ ^ self ].
    currentVersion == nil
        ifTrue: [ ^ self ].
    spec := self copy.
    spec versionString: currentVersion versionString.
    updatedSpecs at: spec name put: spec! !

!MetacelloMCProjectSpec methodsFor: 'private - loading' stamp: ''!
ensureProjectLoaded: mcLoader ensured: ensured
	| version |

	version := self versionOrNil.
	version ifNil: [ ^ self ].
	(self ensureConfigurationLoaded: version ensured: ensured)  ifFalse: [ ^ self ].
	
	mcLoader ensureForDevelopment
		ifTrue: [ 
			self notifyCleanStackCache.
			self ensureLoadUsing: mcLoader ]
		ifFalse: [ 
			self projectPackage fetchUsing: mcLoader ].
	mcLoader ensuredMap at: self name put: #'latest'! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
validateVersionString: issues withDefaultVersionString: defaultVersionString
    self versionString
        ifNil: [ 
            defaultVersionString
                ifNotNil: [ self versionString: defaultVersionString ]
                ifNil: [ 
                    issues
                        add:
                            (MetacelloValidationError
                                configurationClass: self projectClass
                                reasonCode: #'incompleteProjectSpec'
                                callSite:
                                    #'validateForScriptLoad:withDefaultVersionString:withDefaultRepositoryDecription:'
                                explanation: 'version field required') ] ]! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
asConfigurationProjectSpec
    ^ self copyForScriptingInto: (MetacelloMCConfigurationOfProjectSpec for: self project asConfigurationProject)! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
compareEqual: aMetacelloProjectSpec
    "'projectPackage repositories'"

    ^ (super compareEqual: aMetacelloProjectSpec) and: [ self file = aMetacelloProjectSpec file ]! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
asProjectSpec
    ^ self! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
asProjectRegistration
  (self className beginsWith: 'BaselineOf')
    ifTrue: [ 
      ^ MetacelloProjectRegistration
        fromMCBaselineProjectSpec: self asBaselineProjectSpec ].
  ^ MetacelloProjectRegistration
    fromMCConfigurationProjectSpec: self asConfigurationProjectSpec! !

!MetacelloMCProjectSpec methodsFor: 'testing' stamp: ''!
compareCurrentVersion: anOperator targetVersionStatus: targetVersionStatus using: anMCLoader
    ^ (MetacelloLookupProjectSpecForLoad new
        projectSpec: self;
        yourself) signal
        performCurrentVersionTestAgainst: self versionOrNil
        operator: anOperator
        targetVersionStatus: targetVersionStatus
        using: anMCLoader! !

!MetacelloMCProjectSpec methodsFor: 'accessing' stamp: ''!
getFile
    "raw access to iv"

    ^ file! !

!MetacelloMCProjectSpec methodsFor: 'scripting' stamp: ''!
canUpgradeTo: aMetacelloProjectSpec
    ^ (super canUpgradeTo: aMetacelloProjectSpec) and: [ self file = aMetacelloProjectSpec file ]! !

!MetacelloMCProjectSpec class methodsFor: 'instance creation' stamp: ''!
new
	self name == #MetacelloMCProjectSpec
		ifTrue: [ self error: 'This class is abstract' ].
	^ super new! !

!MetacelloMCProjectSpecTestCase methodsFor: 'tests' stamp: ''!
testMCProjectMergeSpec
	| projectA projectB project repository |
	projectA := self projectSpec
		name: 'Project';
		projectPackage: self project packageSpec;
		className: 'ConfigurationOfProject';
		repository: 'http://example.com/repository' username: 'dkh' password: 'password';
		repository: '/opt/gemstone/repository';
		yourself.
	projectB := self projectSpec
		name: 'Project';
		projectPackage: self project packageSpec;
		className: 'ConfigurationOfProjectB';
		repository: 'http://example.com/repository' username: 'DaleHenrichs' password: 'secret';
		repository: '/opt/gemstone/repo';
		yourself.
	project := projectA mergeSpec: projectB.
	self assert: project name equals: 'Project'.
	self assert: project className equals: 'ConfigurationOfProjectB'.
	self assert: project projectPackage name equals: project className.
	self assert: project projectPackage file equals: project className.
	repository := project repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := project repositories map at: '/opt/gemstone/repo' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := project repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'DaleHenrichs'.
	self assert: repository password equals: 'secret'! !

!MetacelloMCProjectSpecTestCase methodsFor: 'tests' stamp: ''!
testMCProjectSpec
	| project repository |
	project := self projectSpec.
	project
		name: 'Project';
		projectPackage: self project packageSpec;
		className: 'ConfigurationOfProject';
		repository: 'http://example.com/repository' username: 'dkh' password: 'password';
		repository: '/opt/gemstone/repository';
		yourself.
	self assert: project name equals: 'Project'.
	self assert: project className equals: 'ConfigurationOfProject'.
	self assert: project projectPackage name equals: project className.
	self assert: project projectPackage file equals: project className.
	repository := project repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := project repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'dkh'.
	self assert: repository password equals: 'password'! !

!MetacelloMCProjectSpecTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!MetacelloMCTestsAbstractConfig methodsFor: 'accessing' stamp: ''!
project

	| constructor |
	^project ifNil: [
		"Construct Metacello project"
		constructor := MetacelloVersionConstructor on: self.
		project := constructor project.
		project loader: MetacelloNullRecordingMCSpecLoader new.
		project].! !

!MetacelloMCValueHolderSpecTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!MetacelloMCVersion methodsFor: 'querying' stamp: ''!
defaultPackageNamesToLoad
	"Answer the list of packages and projects to be loaded --> packages already loaded"
	
	^ self defaultPackageNamesToLoad: self spec defaultPackageNames! !

!MetacelloMCVersion methodsFor: 'accessing' stamp: ''!
loaderPolicy

	loaderPolicy == nil ifTrue: [ loaderPolicy := MetacelloLoaderPolicy new ].
	^ loaderPolicy! !

!MetacelloMCVersion methodsFor: 'private' stamp: ''!
doFetchRequiredFromArray: anArray

	| oldPolicy oldBypassProgress displayString |
	displayString := self versionNumber printString, ' of ', self spec projectLabel.
	MetacelloNotification signal: ('Fetching ', displayString, '...').
	oldPolicy := loaderPolicy. 
	oldBypassProgress := MetacelloPlatform current bypassProgressBars.
	self loaderPolicy silently ifTrue: [ MetacelloPlatform current bypassProgressBars: true ].
	[ 	| ans |
		ans := self fetchRequiredFromArray: anArray.
		MetacelloNotification signal: ('...finished ', self versionNumber printString).
		^ans ]
			ensure: [ 
				MetacelloPlatform current bypassProgressBars: oldBypassProgress.
				loaderPolicy := oldPolicy ]! !

!MetacelloMCVersion methodsFor: 'accessing' stamp: ''!
ignoreImage: aBool 
	"by default ignoreImage is false"
	
	self loaderPolicy ignoreImage: aBool! !

!MetacelloMCVersion methodsFor: 'private' stamp: ''!
computeVersionStatus
	"
		#allLoadedToSpec - all projects and packages are loaded and match specification
		#loadedToSpec - all loaded projects and packages match specifications (at least one package loaded)
		#loadedMatchConstraints - all loaded projects and packages match constraints (at least one package loaded)
		#somethingLoaded - at least one package loaded
	"

	self spec computeVersionStatus: [ :status | ^ status ].
	^ #noStatus! !

!MetacelloMCVersion methodsFor: 'querying' stamp: ''!
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 <aString>, answers an empty list"

	^self packagesForSpecNamed: aString ifAbsent: [ ^#() ]! !

!MetacelloMCVersion methodsFor: 'accessing' stamp: ''!
repositoryOverrides: repositoriesCollection 

	self loaderPolicy overrideRepositories: repositoriesCollection! !

!MetacelloMCVersion methodsFor: 'querying' stamp: ''!
currentlyLoadedClassesInVersion

	^self spec currentlyLoadedClassesInVersion! !

!MetacelloMCVersion methodsFor: 'actions' stamp: ''!
fetch: required

	^required fetchRequiredForMetacelloMCVersion: self! !

!MetacelloMCVersion methodsFor: 'private' stamp: ''!
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: ''!
executeLoadFromArray: anArray

	| loader |
	loader := MetacelloMCVersionSpecLoader on: self spec.
	loader required: anArray.
	loaderPolicy notNil ifTrue: [ loader loaderPolicy: loaderPolicy ].
	^loader load! !

!MetacelloMCVersion methodsFor: 'actions' stamp: ''!
fetch

	^self doFetchRequiredFromArray: self spec defaultPackageNames! !

!MetacelloMCVersion methodsFor: 'querying' stamp: ''!
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: 'private' stamp: ''!
loader: aLoader

	self versionSpec loader: aLoader! !

!MetacelloMCVersion methodsFor: 'querying' stamp: ''!
packages
	"Answers the list of packages associated with this version"

	| packages |
	packages := OrderedCollection new.
	self spec projectDo: [:ignored | ] packageDo: [:pkg | packages add: pkg ] groupDo: [:ignored | ].
	^packages! !

!MetacelloMCVersion methodsFor: 'actions' stamp: ''!
record: required

	^required recordRequiredForMetacelloMCVersion: self! !

!MetacelloMCVersion methodsFor: 'querying' stamp: ''!
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 <aString> were loaded."
	"If there is no spec named <aString>, answers an empty list"

	^self allPackagesForSpecNamed: aStringOrArray ifAbsent: [ ^#() ]! !

!MetacelloMCVersion methodsFor: 'private' stamp: ''!
loadRequiredFromArray: anArray

	| displayString |
	displayString := 'Loading ', self versionNumber printString, ' of ', self spec projectLabel.
	MetacelloPlatform current
		do: [ ^self executeLoadFromArray: anArray ]
		displaying: displayString! !

!MetacelloMCVersion methodsFor: 'accessing' stamp: ''!
loaderPolicy: anObject
	loaderPolicy := anObject! !

!MetacelloMCVersion methodsFor: 'accessing' stamp: ''!
silently: aBool 
	"by default silently is false"
	
	self loaderPolicy silently: aBool! !

!MetacelloMCVersion methodsFor: 'accessing' stamp: ''!
cacheRepository: repository 
	"by default cacheRepository is an MCDictionaryRepository"
	
	self loaderPolicy cacheRepository: repository! !

!MetacelloMCVersion methodsFor: 'querying' stamp: ''!
currentlyLoadedExtensionClassesInVersion

	^self spec currentlyLoadedExtensionClassesInVersion! !

!MetacelloMCVersion methodsFor: 'querying' stamp: ''!
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: 'actions' stamp: ''!
load

	^self doLoadRequiredFromArray: self spec defaultPackageNames! !

!MetacelloMCVersion methodsFor: 'querying' stamp: ''!
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 <aString>, aBlock is evaluated"

	| pkgSpec |
	pkgSpec := self spec packageNamed: aString ifAbsent: aBlock.
	^pkgSpec resolveToPackagesIn: self spec visited: MetacelloVisitedPackages new! !

!MetacelloMCVersion methodsFor: 'private' stamp: ''!
doRecordRequiredFromArray: anArray

	| originalLoader oldPolicy displayString oldBypassProgress |
	displayString := self versionNumber printString, ' of ', self spec projectLabel.
	MetacelloNotification signal: ('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.
				MetacelloNotification signal: ('...finished ', self versionNumber printString).
				^ans ]
			displaying: 'Recording ', displayString ]
				ensure: [
					MetacelloPlatform current bypassProgressBars: oldBypassProgress.
					self versionSpec loader: originalLoader.
					loaderPolicy := oldPolicy ]! !

!MetacelloMCVersion methodsFor: 'querying' stamp: ''!
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 <aString> were loaded."
	"If there is no spec named <aString>, aBlock is evaluated"

	^aStringOrArray 
		resolvePackageSpecsNamedForMetacelloMCVersion: self 
		visited: MetacelloVisitedPackages new 
		ifAbsent: aBlock! !

!MetacelloMCVersion methodsFor: 'private' stamp: ''!
doLoadRequiredFromArray: anArray

	| displayString oldPolicy oldBypassProgress |
	displayString := self versionNumber printString, ' of ', self spec projectLabel.
	MetacelloNotification signal: ('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.
		MetacelloNotification signal: ('...finished ', self versionNumber printString).
		^fetchLoader ]
		ensure: [ 
			MetacelloPlatform current bypassProgressBars: oldBypassProgress.
			loaderPolicy := oldPolicy ]! !

!MetacelloMCVersion methodsFor: 'actions' stamp: ''!
record

	^self doRecordRequiredFromArray: self spec defaultPackageNames! !

!MetacelloMCVersion methodsFor: 'actions' stamp: ''!
load: required

	^required loadRequiredForMetacelloMCVersion: self! !

!MetacelloMCVersion methodsFor: 'private' stamp: ''!
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! !

!MetacelloMCVersionSpec methodsFor: 'development support' stamp: ''!
updatedPackageSpecs

	| updatedSpecs mcLoader |
	updatedSpecs := Dictionary new.
	mcLoader := self loader.
	self packages map valuesDo: [:pkg | pkg updatePackageSpec: updatedSpecs using: mcLoader].
	^updatedSpecs! !

!MetacelloMCVersionSpec methodsFor: 'printing' stamp: ''!
configSpawnMethodOn: aStream indent: indent

	super configSpawnMethodOn: aStream indent: indent.
	self configPackagesSpecMethodOn: aStream indent: indent.! !

!MetacelloMCVersionSpec methodsFor: 'testing' stamp: ''!
isLoadedMatchConstraintsAgainst: resolvedPackageAndProjectNames
	"all loaded projects and packages match constraints (at least one package loaded)"

	(self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isLoadedMatchConstraints: [ :ignored | ^ true ].
	^ false! !

!MetacelloMCVersionSpec methodsFor: 'accessing' stamp: ''!
repository: aString username: username password: password
	self repositoriesSpec repository: aString username: username password: password! !

!MetacelloMCVersionSpec methodsFor: 'development support' stamp: ''!
forceUpdatedPackageSpecs

	| updatedSpecs mcLoader |
	updatedSpecs := Dictionary new.
	mcLoader := self loader.
	self packages map valuesDo: [:pkg | pkg forceUpdatePackageSpec: updatedSpecs using: mcLoader].
	^updatedSpecs! !

!MetacelloMCVersionSpec methodsFor: 'querying' stamp: ''!
currentlyLoadedClassesInVersion
  | classes |
  classes := Set new.
  self
    projectDo: [ :ignored |  ]
    packageDo: [ :packageSpec | 
      | wc |
      wc := [ packageSpec workingCopy ]
        on: Error
        do: [ :ex | ex return: nil ].
      wc ~~ nil
        ifTrue: [ classes addAll: (MetacelloPlatform current packageInfoFor: wc) classes ] ]
    groupDo: [ :ignored |  ].
  ^ classes! !

!MetacelloMCVersionSpec methodsFor: 'testing' stamp: ''!
isAllLoadedToSpecAgainst: resolvedPackageAndProjectNames
	"all projects and packages are loaded and match specification"

	(self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isAllLoadedToSpec: [ :ignored | ^ true ].
	^ false! !

!MetacelloMCVersionSpec methodsFor: 'construction' stamp: ''!
package: aString constructor: aVersionConstructor
    aVersionConstructor packageForVersion: aString! !

!MetacelloMCVersionSpec methodsFor: 'construction' stamp: ''!
removePackage: aString constructor: aVersionConstructor
    aVersionConstructor removePackageForVersion: aString! !

!MetacelloMCVersionSpec methodsFor: 'accessing' stamp: ''!
packages
    "leave reference to packages for upgrade purposes"

    packages == nil
        ifTrue: [ ^ super packages ].
    ^ packages! !

!MetacelloMCVersionSpec methodsFor: 'printing' stamp: ''!
configMethodOn: aStream last: last indent: indent
    | spec hasRepositories hasPackageSpecs hasImport |
    hasRepositories := (spec := self repositoriesSpec) ~~ nil and: [ spec list isEmpty not ].
    hasImport := self import ~~ nil.
    hasPackageSpecs := false.
    self packagesSpec list
        do: [ :member | 
            member spec
                projectDo: [ :proj | 
                    member spec name ~~ nil
                        ifTrue: [ hasPackageSpecs := true ] ]
                packageDo: [ :package | 
                    member spec name ~~ nil
                        ifTrue: [ hasPackageSpecs := true ] ]
                groupDo: [ :group | 
                    member spec name ~~ nil
                        ifTrue: [ hasPackageSpecs := true ] ] ].
    self configMethodBasicOn: aStream last: (hasRepositories | hasPackageSpecs | hasImport) not indent: indent.
    hasImport
        ifTrue: [ 
            self
                configMethodValueOn: aStream
                for: self import
                selector: 'import:'
                last: (hasRepositories | hasPackageSpecs) not
                indent: indent ].
    hasRepositories
        ifTrue: [ 
            spec map values size = 1
                ifTrue: [ 
                    aStream
                        tab: indent;
                        nextPutAll: 'spec repository: ';
                        nextPutAll: spec map values first description printString , '.'.
                    hasPackageSpecs
                        ifTrue: [ aStream cr ] ]
                ifFalse: [ 
                    self
                        configMethodOn: aStream
                        for: spec
                        selector: 'repositories:'
                        last: hasPackageSpecs not
                        indent: indent ] ].
    self configPackagesSpecMethodOn: aStream indent: indent.
    last
        ifFalse: [ aStream cr ]! !

!MetacelloMCVersionSpec methodsFor: 'merging' stamp: ''!
mergeMap
    | map |
    map := super mergeMap.
    map at: #'repositories' put: self repositories.
    ^ map! !

!MetacelloMCVersionSpec methodsFor: 'querying' stamp: ''!
packageNames
    "leave reference to packages for upgrade purposes"

    packages == nil
        ifTrue: [ ^ super packageNames ].
    ^ self packages map keys asSet! !

!MetacelloMCVersionSpec methodsFor: 'development support' stamp: ''!
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: 'enumerating' stamp: ''!
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: 'querying' stamp: ''!
currentlyLoadedExtensionClassesInVersion
	| classes |
	classes := Dictionary new.
	self
		projectDo: [ :ignored |  ]
		packageDo: [ :packageSpec | 
			([ packageSpec workingCopy ]
				on: Error
				do: [ :ex | ex return: nil ])
				ifNotNil: [ :workingCopy | 
					| packageInfo |
					packageInfo := MetacelloPlatform current packageInfoFor: workingCopy.
					packageInfo extendedClasses do: [ :cl | classes at: cl put: (packageInfo extensionCategoriesForClass: cl) ] ] ]
		groupDo: [ :ignored |  ].
	^ classes! !

!MetacelloMCVersionSpec methodsFor: 'testing' stamp: ''!
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: ''!
isSomethingLoaded
	"at least one package loaded"
	
	self isPartiallyCurrent isSomethingLoaded: [ :ignored | ^ true ].
	^ false! !

!MetacelloMCVersionSpec methodsFor: 'loading' stamp: ''!
repositorySpecs

	^self repositories map values! !

!MetacelloMCVersionSpec methodsFor: 'testing' stamp: ''!
isSomethingLoadedAgainst: resolvedPackageAndProjectNames
	"at least one package loaded"

	(self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isSomethingLoaded: [ :ignored | ^ true ].
	^ false! !

!MetacelloMCVersionSpec methodsFor: 'accessing' stamp: ''!
computeVersionStatus: matchBlock
	self computeVersionStatus: (self expandToLoadableSpecNames: #('ALL')) matchBlock: matchBlock! !

!MetacelloMCVersionSpec methodsFor: 'construction' stamp: ''!
package: aString overrides: aBlock constructor: aVersionConstructor
    aVersionConstructor packageForVersion: aString overrides: aBlock! !

!MetacelloMCVersionSpec methodsFor: 'enumerating' stamp: ''!
specListProjectDo: projectBlock packageDo: packageBlock groupDo: groupBlock

	self packages specListDo: [:pkgSpec |
		pkgSpec projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock ]! !

!MetacelloMCVersionSpec methodsFor: 'merging' stamp: ''!
nonOverridable
    ^ super nonOverridable , #(#'repositories')! !

!MetacelloMCVersionSpec methodsFor: 'accessing' stamp: ''!
computeVersionStatus: resolvedPackageAndProjectNames matchBlock: matchBlock

	| status |

	status := resolvedPackageAndProjectNames
		ifNil: [ self isPartiallyCurrent ]
		ifNotNil: [ self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames ].
	status isAllLoadedToSpec: matchBlock.
	status isLoadedToSpec: matchBlock.
	status isLoadedMatchConstraints: matchBlock.
	status isSomethingLoaded: matchBlock! !

!MetacelloMCVersionSpec methodsFor: 'testing' stamp: ''!
isLoadedMatchConstraints
	"all loaded projects and packages match constraints (at least one package loaded)"
	
	self isPartiallyCurrent isLoadedMatchConstraints: [ :ignored | ^ true ].
	^ false! !

!MetacelloMCVersionSpec methodsFor: 'testing' stamp: ''!
isAllLoadedToSpec
	"all projects and packages are loaded and match specification"

	self isPartiallyCurrent isAllLoadedToSpec: [ :ignored | ^ true ].
	^ false! !

!MetacelloMCVersionSpec methodsFor: 'copying' stamp: ''!
postCopy
    super postCopy.
    repositories := repositories copy.
    packages := packages copy	"leave reference to packages for upgrade purposes"! !

!MetacelloMCVersionSpec methodsFor: 'querying' stamp: ''!
packageSpecsInLoadOrderForMap: packageMap
  | loadOrder pkgs packageNames importNames importSpec importProjectSpecs importProjectNameMap |
  loadOrder := self packageSpecsInLoadOrder.
  importNames := (packageNames := (packageMap values
    collect: [ :pkg | pkg name ]) asSet) copy.
  (self import isNil and: [ self importArray isNil ])
    ifTrue: [ ^ loadOrder select: [ :pkg | packageNames includes: pkg name ] ].
  loadOrder do: [ :pkg | importNames remove: pkg name ifAbsent: [  ] ].
  pkgs := OrderedCollection new.
  importProjectSpecs := Dictionary new.
  importProjectNameMap := Dictionary new.
  importArray
    ifNotNil: [ 
      loadOrder
        do: [ :pkg | 
          importArray
            do: [ :assoc | 
              assoc key = pkg name
                ifTrue: [ 
                  importProjectSpecs at: pkg name put: pkg.
                  (assoc value select: [ :each | importNames includes: each ])
                    do: [ :each | 
                      (importProjectNameMap
                        at: pkg name
                        ifAbsent: [ importProjectNameMap at: pkg name put: Set new ])
                        add: each ] ] ] ] ].
  self import
    ifNotNil: [ 
      loadOrder
        do: [ :pkg | 
          pkg name = self import
            ifTrue: [ 
              importProjectSpecs at: pkg name put: pkg.
              importProjectNameMap at: pkg name put: importNames ] ] ].
  loadOrder
    do: [ :pkg | 
      (packageNames includes: pkg name)
        ifTrue: [ pkgs add: pkg ].
      importProjectSpecs
        at: pkg name
        ifPresent: [ :importProjectSpec | 
          "insert the imports at this point"
          (importProjectNameMap at: pkg name ifAbsent: [ #() ])
            do: [ :importedName | 
              pkgs
                add:
                  (importSpec := importProjectSpec copy
                    name: importedName;
                    mergeImportLoads: {importedName};
                    yourself).
              importSpec projectReference name: importedName ] ] ].
  ^ pkgs! !

!MetacelloMCVersionSpec methodsFor: 'testing' stamp: ''!
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: 'accessing' stamp: ''!
repositories
	repositories == nil ifTrue: [ repositories := self project repositoriesSpec ].
	^ repositories! !

!MetacelloMCVersionSpec methodsFor: 'testing' stamp: ''!
isLoadedToSpec
	"all loaded projects and packages match specifications (at least one package loaded)"
	
	self isPartiallyCurrent isLoadedToSpec: [ :ignored | ^ true ].
	^ false! !

!MetacelloMCVersionSpec methodsFor: 'development support' stamp: ''!
packagesNeedSavingVisited: visitedProjects into: aCollection

	self packages map valuesDo: [:pkg | pkg packagesNeedSavingVisited: visitedProjects using: self repositories map values into: aCollection ].! !

!MetacelloMCVersionSpec methodsFor: 'accessing' stamp: ''!
repositoriesSpec

	^self repositories! !

!MetacelloMCVersionSpec methodsFor: 'construction' stamp: ''!
package: packageName with: aBlockOrString constructor: aVersionConstructor
    aVersionConstructor packageForVersion: packageName with: aBlockOrString! !

!MetacelloMCVersionSpec methodsFor: 'testing' stamp: ''!
isPartiallyCurrent

	^self isPartiallyCurrentAgainst: (self expandToLoadableSpecNames: #('ALL'))! !

!MetacelloMCVersionSpec methodsFor: 'merging' stamp: ''!
mergeSpec: anotherSpec
    | newSpec map anotherRepositories |
    newSpec := super mergeSpec: anotherSpec.
    map := anotherSpec mergeMap.
    (anotherRepositories := map at: #'repositories') isEmpty not
        ifTrue: [ 
            newSpec
                repositories:
                    (self repositories isEmpty
                        ifTrue: [ anotherRepositories ]
                        ifFalse: [ self repositories mergeSpec: anotherRepositories ]) ].
    ^ newSpec! !

!MetacelloMCVersionSpec methodsFor: 'querying' stamp: ''!
difference: otherVersionSpec
    "Return a dictionary of additions, removals and modifications"

    | report myProjectSpecs myPackageSpecs otherProjectSpecs otherPackageSpecs |
    report := MetacelloVersionDiffReport new.
    myProjectSpecs := Dictionary new.
    myPackageSpecs := Dictionary new.
    self
        projectDo: [ :projectSpec | myProjectSpecs at: projectSpec name put: projectSpec ]
        packageDo: [ :packageSpec | myPackageSpecs at: packageSpec name put: packageSpec ]
        groupDo: [ :ignored |  ].
    otherProjectSpecs := Dictionary new.
    otherPackageSpecs := Dictionary new.
    otherVersionSpec
        projectDo: [ :projectSpec | otherProjectSpecs at: projectSpec name put: projectSpec ]
        packageDo: [ :packageSpec | otherPackageSpecs at: packageSpec name put: packageSpec ]
        groupDo: [ :ignored |  ].
    myProjectSpecs
        valuesDo: [ :myProjectSpec | 
            | otherProjectSpec |
            otherProjectSpec := otherProjectSpecs at: myProjectSpec name ifAbsent: [  ].
            otherProjectSpec == nil
                ifTrue: [ 
                    report removals
                        at: myProjectSpec name
                        put:
                            {(myProjectSpec versionString).
                            ''} ]
                ifFalse: [ 
                    myProjectSpec versionString = otherProjectSpec versionString
                        ifFalse: [ 
                            report modifications
                                at: myProjectSpec name
                                put:
                                    {(myProjectSpec versionString).
                                    (otherProjectSpec versionString)} ] ] ].
    otherProjectSpecs
        valuesDo: [ :otherProjectSpec | 
            (myProjectSpecs at: otherProjectSpec name ifAbsent: [  ]) == nil
                ifTrue: [ 
                    report additions
                        at: otherProjectSpec name
                        put:
                            {''.
                            (otherProjectSpec versionString)} ] ].
    myPackageSpecs
        valuesDo: [ :myPackageSpec | 
            | otherPackageSpec |
            otherPackageSpec := otherPackageSpecs at: myPackageSpec name ifAbsent: [  ].
            otherPackageSpec == nil
                ifTrue: [ 
                    report removals
                        at: myPackageSpec name
                        put:
                            {(myPackageSpec file).
                            ''} ]
                ifFalse: [ 
                    myPackageSpec file = otherPackageSpec file
                        ifFalse: [ 
                            report modifications
                                at: myPackageSpec name
                                put:
                                    {(myPackageSpec file).
                                    (otherPackageSpec file)} ] ] ].
    otherPackageSpecs
        valuesDo: [ :otherPackageSpec | 
            (myPackageSpecs at: otherPackageSpec name ifAbsent: [  ]) == nil
                ifTrue: [ 
                    report additions
                        at: otherPackageSpec name
                        put:
                            {''.
                            (otherPackageSpec file)} ] ].
    ^ report! !

!MetacelloMCVersionSpec methodsFor: 'testing' stamp: ''!
isPossibleBaseline

	self 
		projectDo: [:prj | prj isPossibleBaseline ifFalse: [ ^false ]] 
		packageDo: [:pkg | pkg isPackageLoaded ifFalse: [ ^false ]] 
		groupDo: [:ignored | ].
	^true! !

!MetacelloMCVersionSpec methodsFor: 'accessing' stamp: ''!
repositories: anObject
	repositories := anObject! !

!MetacelloMCVersionSpec methodsFor: 'private' stamp: ''!
versionClass

	^MetacelloMCVersion! !

!MetacelloMCVersionSpec methodsFor: 'accessing' stamp: ''!
repository: aString
	self repositoriesSpec add: aString! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
required

	required == nil ifTrue: [ ^#() ].
	^ required! !

!MetacelloMCVersionSpecLoader methodsFor: 'loading' stamp: ''!
load
  | mcLoader |
  packages := Dictionary new.
  self resolveToLoadableSpecs.
  mcLoader := self loader.
  packages values
    do: [ :pkg | 
      pkg ensureLoadedForDevelopmentUsing: mcLoader.
      (MetacelloIgnorePackageLoaded signal: pkg)
        ifFalse: [ 
          mcLoader ignoreImage
            ifFalse: [ 
              (pkg
                compareCurrentVersion: self operator
                targetVersionStatus: #(#'allLoadedToSpec')
                using: mcLoader)
                ifTrue: [ packages removeKey: pkg name ] ] ] ].
  packages notEmpty
    ifTrue: [ 
      mcLoader preLoad: self versionSpec.
      mcLoader load.
      mcLoader postLoad: self versionSpec ].
  ^ mcLoader! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
loaderPolicy
	^ loaderPolicy! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
operator

	^self loader operator! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
packages

	^packages! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
project

	^self versionSpec project! !

!MetacelloMCVersionSpecLoader methodsFor: 'spec compatibility' stamp: ''!
packageSpecsInLoadOrder
    ^ self versionSpec packageSpecsInLoadOrderForMap: packages! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
name

	^self versionSpec name! !

!MetacelloMCVersionSpecLoader methodsFor: 'loading' stamp: ''!
repositories

	^self repositorySpecs! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
required: anObject
	required := anObject! !

!MetacelloMCVersionSpecLoader methodsFor: 'private' stamp: ''!
resolveToLoadableSpecs
    self versionSpec resolveToLoadableSpecs: required forLoad: true map: packages! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
versionSpec: anObject
	versionSpec := anObject! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
loaderPolicy: anObject
	loaderPolicy := anObject! !

!MetacelloMCVersionSpecLoader methodsFor: 'spec compatibility' stamp: ''!
versionString

	^self versionSpec versionString! !

!MetacelloMCVersionSpecLoader methodsFor: 'loading' stamp: ''!
resolvePackageNames

	packages := Dictionary new.
	self resolveToLoadableSpecs.
	^packages values collect: [:pkg | pkg name ]! !

!MetacelloMCVersionSpecLoader methodsFor: 'spec compatibility' stamp: ''!
repositorySpecs

	| repositoryMap |
	repositoryMap := self versionSpec repositories ~~ nil
		ifTrue: [ self versionSpec repositories map ]
		ifFalse: [ Dictionary new ].
	^repositoryMap values.! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
label

	^self versionSpec label! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
loader

	loader == nil 
		ifTrue: [
			loader := self versionSpec loader copy.
			loader spec: self.
			loaderPolicy notNil ifTrue: [ loader loaderPolicy: loaderPolicy] ].
	^loader! !

!MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: ''!
versionSpec
	^ versionSpec! !

!MetacelloMCVersionSpecLoader class methodsFor: 'instance creation' stamp: ''!
on: aVersionSpec

	^(self new) 
		versionSpec: aVersionSpec;
		yourself! !

!MetacelloMCVersionSpecTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!MetacelloMCVersionSpecTestCase methodsFor: 'tests' stamp: ''!
testMCVersionMergeSpec
	| versionA versionB version repository package group projectReferenceSpec |
	versionA := self versionSpec
		blessing: #baseline;
		versionString: '1.0';
		repository: 'http://example.com/repository' username: 'dkh' password: 'password';
		repository: '/opt/gemstone/repository';
		yourself.
	versionA packages
		merge:
			(self packageSpec
				name: 'Package';
				requires: 'AnotherPackage';
				yourself);
		merge:
			(self groupSpec
				name: 'Platform';
				includes: 'Core';
				yourself);
		merge:
			(self projectReferenceSpec
				name: 'Project';
				projectReference:
					(self projectSpec
						name: 'Project';
						projectPackage: self project packageSpec;
						className: 'ConfigurationOfProjectA';
						repository: 'http://example.com/repository' username: 'dkh' password: 'password';
						repository: '/opt/gemstone/repository';
						yourself));
		yourself.
	versionB := self versionSpec
		blessing: #release;
		versionString: '1.1';
		repository: 'http://example.com/repository' username: 'DaleHenrichs' password: 'secret';
		repository: '/opt/gemstone/repo';
		yourself.
	versionB packages
		merge:
			(self packageSpec
				name: 'Package';
				requires: 'AndAnotherPackage';
				yourself);
		merge:
			(self groupSpec
				name: 'Platform';
				includes: 'Tests';
				yourself);
		merge:
			(self projectReferenceSpec
				name: 'Project';
				projectReference:
					(self projectSpec
						name: 'Project';
						projectPackage: self project packageSpec;
						className: 'ConfigurationOfProjectA';
						repository: 'http://example.com/repository' username: 'DaleHenrichs' password: 'secret';
						repository: '/opt/gemstone/repo';
						yourself));
		yourself.
	version := versionA mergeSpec: versionB.
	self assert: version blessing value equals: #release.
	self assert: version versionString value equals: '1.1'.
	repository := version repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := version repositories map at: '/opt/gemstone/repo' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := version repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'DaleHenrichs'.
	self assert: repository password equals: 'secret'.
	package := version packages packageNamed: 'Package' ifAbsent: [ self assert: false ].
	self assert: package name equals: 'Package'.
	projectReferenceSpec := version packages packageNamed: 'Project' ifAbsent: [ self assert: false ].
	self assert: projectReferenceSpec projectName equals: 'Project'.
	repository := projectReferenceSpec repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := projectReferenceSpec repositories map at: '/opt/gemstone/repo' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := projectReferenceSpec repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'DaleHenrichs'.
	self assert: repository password equals: 'secret'.
	group := version packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
	self assert: (group includes includes: 'Core').
	self assert: (group includes includes: 'Tests')! !

!MetacelloMCVersionSpecTestCase methodsFor: 'tests' stamp: ''!
testMCVersionSpec
	| version projectReferenceSpec group package repository |
	version := self versionSpec
		blessing: #baseline;
		versionString: '1.0';
		repository: 'http://example.com/repository' username: 'dkh' password: 'password';
		repository: '/opt/gemstone/repository';
		yourself.
	version packages
		add:
			(self packageSpec
				name: 'Package';
				requires: 'AnotherPackage';
				includes: 'IncludedPackage';
				answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
				file: 'Package-dkh.1';
				preLoadDoIt: #preLoadDoIt;
				postLoadDoIt: #postLoadDoIt;
				yourself);
		add:
			(self packageSpec
				name: 'AnotherPackage';
				yourself);
		add:
			(self packageSpec
				name: 'IncludedPackage';
				yourself);
		add:
			(self groupSpec
				name: 'Platform';
				includes: 'Core';
				yourself);
		add:
			(self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProjectA';
				versionString: #stable;
				loads: #('MyPackage' 'MyTests');
				preLoadDoIt: #preLoadDoItB;
				postLoadDoIt: #postLoadDoItB;
				yourself);
		yourself.
	self assert: version blessing value equals: #baseline.
	self assert: version versionString value equals: '1.0'.
	repository := version repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := version repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'dkh'.
	self assert: repository password equals: 'password'.
	package := version packages packageNamed: 'Package' ifAbsent: [ self assert: false ].
	self assert: package name equals: 'Package'.
	group := version packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
	self assert: (group includes includes: 'Core').
	projectReferenceSpec := version packages packageNamed: 'Project' ifAbsent: [ self assert: false ].
	self assert: projectReferenceSpec projectName equals: 'Project'.
	self assert: projectReferenceSpec versionString equals: #stable.
	version projectDo: [ :prjct | prjct == projectReferenceSpec ] packageDo: [ :pkg | pkg == package ] groupDo: [ :grp | grp == group ]! !

!MetacelloMCVersionValidator commentStamp: ''!
Performs configuration validation.

For programmatically decoding reason codes use:

  MetacellMCVersionValidator fullDescriptionForReasonCode: <reasonCode>

Warning reason codes:

	#notDevelopmentVersion			- the symbolic version #development refers to a non-development literal version.
	#loadWarning 						- Warning signalled during load [load validation].
	#onlyBaselineVersion 				- one or more baseline versions have been defined, but no non-baseline versions are defined.
	#stableDevelopmentVersion		- a version whose blessing is #development has been declared as a #stable version

Critical Warning reason codes:

	#duplicateVersionDefinitions 		         - there are multiple pragma methods specifying the same version
	#loadDeprecation					         - deprecation warning signalled while loading configuration [load validation]
	#missingRecommendedProjectSpecField - missing recommended fields in project reference (versionString). The versionString should be specified so that #bleedingEdge loads will be predictable and repeatable
	#noLoadableVersions 				         - no non #baseline versions defined in configuration
	#noTests 							         - no test cases defined in loaded configuration [load validation]
	#noVersionSpecified 				         - no version defined for the project reference or package. The version specified in the baseline or the latest version of the project or package in the repository will be used.
	#packageNameMismatch 			         - the name in the packageSpec does not match the name of the mcz file
	#projectClassNameFileMismatch 	         - the class name of the configuration does not match the mcz file containing the configuration
	#testDeprecation 					         - deprecation warning signalled while running configuration tests [load validation]

Error reason codes:

	#cannotResolveVersion 			- the version (project reference or symbolic version) was not found in the specified configuration
	#duplicateNames 					- multiple independent definitions for an entity with same name (project, package, or group)
	#incompleteProjectSpec 			- missing required fields in project reference (className and/or repository)
	#incorrectVersionString 			- the version declared in pragma doesn't match version in versionSpec
	#invalidDoItSelector 				- doit select must be a Symbol
	#invalidVersionString 				- versionString must be a String
	#loadError 							- error occured while loading configuration [load validation]
	#missingVersionImport 			- version specified in import pragma not defined in configuration
	#noVersionsDefined 				- no usable baseline or version defined in configuration ... configuration cannot be loaded
	#projectCreationError 				- error occured while resolving project reference
	#shadowedNames 					- name duplication between packages and projects
	#testFailures						- test failures while running tests [load validation]
	#versionCompositionError 			- error while creating versionSpec from pragmas


!
!MetacelloMCVersionValidator methodsFor: 'private' stamp: ''!
validateVersionSpec: versionSpec
  versionSpec blessing value == #'broken'
    ifTrue: [ ^ self ].
  versionSpec
    projectDo: [ :projectSpec | 
      | referencedProjectSpec |
      projectSpec versionString == nil
        ifTrue: [ 
          self
            recordValidationCriticalWarning:
              'No version specified for the project reference ' , projectSpec name printString
                , ' in version ' , versionSpec versionString printString
            versionString: versionSpec versionString
            callSite: #'validateVersionSpec:'
            reasonCode: #'noVersionSpecified' ].
      referencedProjectSpec := projectSpec referencedSpec.
      versionSpec blessing value == #'baseline'
        ifTrue: [ 
          referencedProjectSpec hasRepository
            ifTrue: [ 
              (referencedProjectSpec file beginsWith: referencedProjectSpec className)
                ifFalse: [ 
                  self
                    recordValidationCriticalWarning:
                      'The class name of project ' , referencedProjectSpec className printString
                        , ' does not match the file name '
                        , referencedProjectSpec file printString
                        , ' in version ' , versionSpec versionString printString
                    versionString: versionSpec versionString
                    callSite: #'validateVersionSpec:'
                    reasonCode: #'projectClassNameFileMismatch' ] ]
            ifFalse: [ 
              self
                recordValidationError:
                  'The specification for the project reference ' , projectSpec name printString
                    , ' in version ' , versionSpec versionString printString
                    , ' is missing the required repository field'
                versionString: versionSpec versionString
                callSite: #'validateVersionSpec:'
                reasonCode: #'incompleteProjectSpec' ] ].
      referencedProjectSpec ensureProjectLoaded
        ifTrue: [ 
          [ projectSpec version ]
            on: MetacelloVersionDoesNotExistError
            do: [ :ex | 
              | explanation |
              explanation := projectSpec versionString == nil
                ifTrue: [ 'the default version' ]
                ifFalse: [ 'version ' , projectSpec versionString printString ].
              self
                recordValidationError:
                  'Cannot resolve ' , explanation , ' for the project reference '
                    , projectSpec name printString , ' in version '
                    , versionSpec versionString printString
                versionString: versionSpec versionString
                callSite: #'validateVersionSpec:'
                reasonCode: #'cannotResolveVersion' ] ] ]
    packageDo: [ :packageSpec | 
      (packageSpec file beginsWith: packageSpec name)
        ifFalse: [ 
          self
            recordValidationCriticalWarning:
              'The name of package ' , packageSpec name printString
                , ' does not match the file name '
                , packageSpec file printString , ' in version '
                , versionSpec versionString printString
            versionString: versionSpec versionString
            callSite: #'validateVersionSpec:'
            reasonCode: #'packageNameMismatch' ].
      packageSpec file = packageSpec name
        ifTrue: [ 
          self
            recordValidationCriticalWarning:
              'No version specified for the package ' , packageSpec name printString
                , ' in version ' , versionSpec versionString printString
            versionString: versionSpec versionString
            callSite: #'validateVersionSpec:'
            reasonCode: #'noVersionSpecified' ] ]
    groupDo: [ :ignored |  ].
  self validateBaselineVersionSpec: versionSpec! !

!MetacelloMCVersionValidator methodsFor: 'loading' stamp: ''!
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: 'private' stamp: ''!
warningReasonCodes
	^ super warningReasonCodes, #(#loadWarning #notDevelopmentVersion #stableDevelopmentVersion)! !

!MetacelloMCVersionValidator methodsFor: 'private' stamp: ''!
criticalWarningReasonCodes
	^ super criticalWarningReasonCodes
		, #(#noLoadableVersions #noTests #testDeprecation #loadDeprecation #noVersionSpecified #'missingRecommendedProjectSpecField' )! !

!MetacelloMCVersionValidator methodsFor: 'loading' stamp: ''!
validateVersionTests: version
	| testCases cleanTests |
	testCases := IdentitySet new.
	cleanTests := true.
	version currentlyLoadedClassesInVersion
		do: [ :class | 
			| isTestCase |
			isTestCase := (class withAllSuperclasses collect: #name) includes: #TestCase.
			"do not use direct inheritance check to avoid direct dependency of Metacello on SUnit"
			(isTestCase 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: ''!
validateBaselineVersionSpec: versionSpec
    | projectNames packageNames groupNames versionMessage |
    self
        validateDoIts: versionSpec
        versionString: versionSpec versionString
        errorMessage: ' version ' , versionSpec versionString printString.
    projectNames := Set new.
    packageNames := Set new.
    groupNames := Set new.
    versionMessage := ' in version ' , versionSpec versionString printString.
    versionSpec
        projectDo: [ :projectSpec | 
            projectSpec resolveProjectSpec className == nil
                ifTrue: [ 
                    self
                        recordValidationError:
                            'Missing required field (className:) for project reference ' , projectSpec name printString , ' in version '
                                , versionSpec versionString printString
                        versionString: versionSpec versionString
                        callSite: #'validateBaselineVersionSpec:'
                        reasonCode: #'incompleteProjectSpec' ].
            projectSpec resolveProjectSpec versionString == nil
                ifTrue: [ 
                    self
                        recordValidationCriticalWarning:
                            'Missing recommended field (versionString:) for project reference ' , projectSpec name printString , ' in version '
                                , versionSpec versionString printString
                        versionString: versionSpec versionString
                        callSite: #'validateBaselineVersionSpec:'
                        reasonCode: #'missingRecommendedProjectSpecField' ].
            projectSpec hasRepository
                ifTrue: [ 
                    (self recurse and: [ projectSpec versionString ~~ nil ])
                        ifTrue: [ 
                            | project |
                            projectSpec resolveProjectSpec ensureProjectLoaded.
                            project := self
                                validateProjectCreationFrom: projectSpec resolveProjectSpec projectClass
                                onError: [ :ex | 
                                    self
                                        recordValidationError: 'Error creating project reference: ' , ex description
                                        versionString: versionSpec versionString
                                        callSite: #'validateBaselineVersionSpec:'
                                        reasonCode: #'projectCreationError'.
                                    nil ].
                            project ~~ nil
                                ifTrue: [ 
                                    self validationReport
                                        addAll:
                                            (self class
                                                validateProject: project
                                                version: projectSpec versionString
                                                debug: self debug
                                                recurse: self recurse
                                                visited: self visited) ] ] ]
                ifFalse: [ 
                    self
                        recordValidationError:
                            'Missing required field (repository:) for project reference ' , projectSpec name printString , ' in version '
                                , versionSpec versionString printString
                        versionString: versionSpec versionString
                        callSite: #'validateBaselineVersionSpec:'
                        reasonCode: #'incompleteProjectSpec' ].
            self
                validateDoIts: projectSpec
                versionString: versionSpec versionString
                errorMessage: projectSpec name printString , versionMessage.
            (projectNames includes: projectSpec name)
                ifTrue: [ 
                    self
                        recordValidationError:
                            'Duplicate projects named' , projectSpec name printString , versionMessage
                        versionString: versionSpec versionString
                        callSite: #'validateBaselineVersionSpec:'
                        reasonCode: #'duplicateNames' ]
                ifFalse: [ projectNames add: projectSpec name ] ]
        packageDo: [ :packageSpec | 
            self
                validateDoIts: packageSpec
                versionString: versionSpec versionString
                errorMessage: packageSpec name printString , versionMessage.
            (packageNames includes: packageSpec name)
                ifTrue: [ 
                    self
                        recordValidationError:
                            'Duplicate packages named' , packageSpec name printString , versionMessage
                        versionString: versionSpec versionString
                        callSite: #'validateBaselineVersionSpec:'
                        reasonCode: #'duplicateNames' ]
                ifFalse: [ projectNames add: packageSpec name ] ]
        groupDo: [ :groupSpec | 
            (groupNames includes: groupSpec name)
                ifTrue: [ 
                    self
                        recordValidationError: 'Duplicate groups named' , groupSpec name printString , versionMessage
                        versionString: versionSpec versionString
                        callSite: #'validateBaselineVersionSpec:'
                        reasonCode: #'duplicateNames' ]
                ifFalse: [ projectNames add: groupSpec name ] ].
    (packageNames intersection: projectNames) notEmpty
        ifTrue: [ 
            self
                recordValidationError: 'Names duplicated between packages and projects' , versionMessage
                versionString: versionSpec versionString
                callSite: #'validateBaselineVersionSpec:'
                reasonCode: #'shadowedNames' ].
    (groupNames intersection: projectNames) notEmpty
        ifTrue: [ 
            self
                recordValidationError: 'Names duplicated between groups and projects' , versionMessage
                versionString: versionSpec versionString
                callSite: #'validateBaselineVersionSpec:'
                reasonCode: #'shadowedNames' ].
    (projectNames intersection: packageNames) notEmpty
        ifTrue: [ 
            self
                recordValidationError: 'Names duplicated between projects and packages' , versionMessage
                versionString: versionSpec versionString
                callSite: #'validateBaselineVersionSpec:'
                reasonCode: #'shadowedNames' ].
    (groupNames intersection: packageNames) notEmpty
        ifTrue: [ 
            self
                recordValidationError: 'Names duplicated between groups and packages' , versionMessage
                versionString: versionSpec versionString
                callSite: #'validateBaselineVersionSpec:'
                reasonCode: #'shadowedNames' ].
    (projectNames intersection: groupNames) notEmpty
        ifTrue: [ 
            self
                recordValidationError: 'Names duplicated between projects and groups' , versionMessage
                versionString: versionSpec versionString
                callSite: #'validateBaselineVersionSpec:'
                reasonCode: #'shadowedNames' ].
    (packageNames intersection: groupNames) notEmpty
        ifTrue: [ 
            self
                recordValidationError: 'Names duplicated between packages and groups' , versionMessage
                versionString: versionSpec versionString
                callSite: #'validateBaselineVersionSpec:'
                reasonCode: #'shadowedNames' ]! !

!MetacelloMCVersionValidator methodsFor: 'loading' stamp: ''!
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: ''!
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: 'private' stamp: ''!
errorReasonCodes
	^ super errorReasonCodes, #(#loadError #testFailures )! !

!MetacelloMCVersionValidator methodsFor: 'private' stamp: ''!
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: 'loading' stamp: ''!
validateProjectVersionLoad: versionString loads: loadList
	| issues project 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 class methodsFor: 'instance creation' stamp: ''!
validateConfigurationLoad: configurationClass version: versionString loads: loadList
	^ ((self new)
		configurationClass: configurationClass;
		yourself) validateProjectVersionLoad: versionString loads: loadList! !

!MetacelloMCVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateConfigurationLoad: configurationClass version: versionString
	^self validateConfigurationLoad: configurationClass version: versionString loads: #()! !

!MetacelloMCVersionValidator class methodsFor: 'private' stamp: ''!
populateReasonCodeDescriptions
    "update MetacelloMCVersionValidator class comment to include any changes to descriptions"

    | dict |
    dict := super populateReasonCodeDescriptions.
    dict
        at: #'notDevelopmentVersion'
            put: 'the symbolic version #development refers to a non-development literal version.';
        at: #'loadWarning' put: 'Warning signalled during load [load validation].';
        at: #'stableDevelopmentVersion'
            put: 'a version whose blessing is #development has been declared as a #stable version.'.	"Warnings"
    dict
        at: #'loadDeprecation' put: 'deprecation warning signalled while loading configuration [load validation].';
        at: #'missingRecommendedProjectSpecField'
            put:
                'missing recommended fields in project reference (versionString). The versionString should be specified so that #bleedingEdge loads will be predictable and repeatable.';
        at: #'noLoadableVersions' put: 'no non #baseline versions defined in configuration.';
        at: #'noTests' put: 'no test cases defined in loaded configuration [load validation].';
        at: #'noVersionSpecified'
            put:
                'no version defined for the project reference or package. The version specified in the baseline or the latest version of the project or package in the repository will be used.';
        at: #'testDeprecation'
            put: 'deprecation warning signalled while running configuration tests [load validation].'.	"Critical Warnings"
    dict
        at: #'loadError' put: 'error occured while loading configuration [load validation].';
        at: #'testFailures' put: 'test failures while running tests [load validation].'.	"Errors"
    ^ dict! !

!MetacelloMCVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateConfigurationLoad: configurationClass
	^ ((self new)
		configurationClass: configurationClass;
		yourself) validateProjectLoad! !

!MetacelloMemberListSpec methodsFor: 'actions' stamp: ''!
copy: aMemberSpec

	self addMember: aMemberSpec! !

!MetacelloMemberListSpec methodsFor: 'testing' stamp: ''!
isEmpty

	^self list isEmpty! !

!MetacelloMemberListSpec methodsFor: 'actions' stamp: ''!
add: aSpec

	self subclassResponsibility! !

!MetacelloMemberListSpec methodsFor: 'private' stamp: ''!
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: 'toolbox support' stamp: ''!
deleteSpec: aSpec
	"remove the spec from list"

	self list
		detect: [ :aMember | aMember spec = aSpec ]
		ifFound: [ :member | self list remove: member ]! !

!MetacelloMemberListSpec methodsFor: 'enumeration' stamp: ''!
select: aBlock 
	| newCollection |
	newCollection := OrderedCollection new.
	self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]].
	^newCollection! !

!MetacelloMemberListSpec methodsFor: 'enumeration' stamp: ''!
specListDo: aBlock

	self list do: [:member |  aBlock value: member spec ]! !

!MetacelloMemberListSpec methodsFor: 'private' stamp: ''!
clearMemberMap

	memberMap := nil.! !

!MetacelloMemberListSpec methodsFor: 'enumeration' stamp: ''!
specListSelect: aBlock 
	| newCollection |
	newCollection := OrderedCollection new.
	self specListDo: [:each | (aBlock value: each) ifTrue: [newCollection add: each]].
	^newCollection! !

!MetacelloMemberListSpec methodsFor: 'enumeration' stamp: ''!
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: ''!
do: aBlock

	self map values do: aBlock! !

!MetacelloMemberListSpec methodsFor: 'actions' stamp: ''!
remove: aSpec

	self subclassResponsibility! !

!MetacelloMemberListSpec methodsFor: 'private' stamp: ''!
mapAdd: aMemberSpec into: map
	
	map at: aMemberSpec name put: aMemberSpec spec! !

!MetacelloMemberListSpec methodsFor: 'enumeration' stamp: ''!
collect: aBlock 
	| newCollection |
	newCollection :=OrderedCollection new.
	self do: [:each | newCollection add: (aBlock value: each)].
	^ newCollection! !

!MetacelloMemberListSpec methodsFor: 'actions' stamp: ''!
copy: specNamed to: aSpec

	self subclassResponsibility! !

!MetacelloMemberListSpec methodsFor: 'accessing' stamp: ''!
list

	list == nil ifTrue: [ list := OrderedCollection new ].
	^list! !

!MetacelloMemberListSpec methodsFor: 'adding' stamp: ''!
addMember: aMember

	self list add: aMember.
	self clearMemberMap! !

!MetacelloMemberListSpec methodsFor: 'accessing' stamp: ''!
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: 'enumeration' stamp: ''!
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: 'private' stamp: ''!
mapCopy: aMemberSpec into: map
    | spec |
    spec := map at: aMemberSpec sourceName ifAbsent: [  ].
    spec == nil
        ifTrue: [ ^ self error: 'Source spec named ' , aMemberSpec sourceName printString , ' not found' ]
        ifFalse: [ 
            spec aboutToCopy.
            map at: aMemberSpec name put: (spec copy mergeSpec: aMemberSpec spec copy) ]! !

!MetacelloMemberListSpec methodsFor: 'copying' stamp: ''!
postCopy

	super postCopy.
	list := list copy.
	self clearMemberMap! !

!MetacelloMemberListSpec methodsFor: 'enumeration' stamp: ''!
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: 'private' stamp: ''!
mapRemove: aMemberSpec into: map
	
	map removeKey: aMemberSpec name ifAbsent: []! !

!MetacelloMemberListSpec methodsFor: 'testing' stamp: ''!
notEmpty

	^self list notEmpty! !

!MetacelloMemberListSpec methodsFor: 'merging' stamp: ''!
mergeSpec: anotherSpec

	| newSpec |
	newSpec := super mergeSpec: anotherSpec.
	newSpec list: self list copy.
	anotherSpec list do: [:groupMember | groupMember applyToList: newSpec ].
	^newSpec! !

!MetacelloMemberListSpec methodsFor: 'actions' stamp: ''!
merge: aSpec

	self subclassResponsibility! !

!MetacelloMemberListSpec methodsFor: 'accessing' stamp: ''!
list: aCollection

	list := aCollection.
	self clearMemberMap! !

!MetacelloMemberListSpec methodsFor: 'enumeration' stamp: ''!
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.' ]! !

!MetacelloMemberSpec methodsFor: 'actions' stamp: ''!
applyToList: aListSpec

	self subclassResponsibility! !

!MetacelloMemberSpec methodsFor: 'printing' stamp: ''!
configMethodOn: aStream indent: indent

	aStream nextPutAll: self class name asString, ' member: ('.
	self spec configMethodOn: aStream indent: indent.
	aStream nextPutAll: ')'.! !

!MetacelloMemberSpec methodsFor: '*Metacello-MC' stamp: ''!
addToMetacelloPackages: aMetacelloPackagesSpec

	aMetacelloPackagesSpec addMember: self! !

!MetacelloMemberSpec methodsFor: 'printing' stamp: ''!
configMethodCascadeOn: aStream last: lastCascade indent: indent

	self spec 
		configMethodCascadeOn: aStream 
		member: self 
		last: lastCascade 
		indent: indent! !

!MetacelloMemberSpec methodsFor: 'actions' stamp: ''!
applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock

	self subclassResponsibility! !

!MetacelloMemberSpec methodsFor: '*Metacello-MC' stamp: ''!
mergeIntoMetacelloPackages: aMetacelloPackagesSpec

	aMetacelloPackagesSpec addMember: self! !

!MetacelloMemberSpec methodsFor: 'accessing' stamp: ''!
methodUpdateSelector

	^self subclassResponsibility! !

!MetacelloMemberSpec methodsFor: '*Metacello-MC' stamp: ''!
mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec

	aMetacelloRepositoriesSpec addMember: self! !

!MetacelloMemberSpec methodsFor: 'accessing' stamp: ''!
name

	^name! !

!MetacelloMemberSpec methodsFor: 'accessing' stamp: ''!
name: aString

	name := aString! !

!MetacelloMemberSpec methodsFor: 'accessing' stamp: ''!
spec: aMetacelloSpec

	spec := aMetacelloSpec! !

!MetacelloMemberSpec methodsFor: '*Metacello-MC' stamp: ''!
addToMetacelloRepositories: aMetacelloRepositoriesSpec

	aMetacelloRepositoriesSpec addMember: self! !

!MetacelloMemberSpec methodsFor: '*Metacello-MC' stamp: ''!
removeFromMetacelloRepositories: aMetacelloRepositoriesSpec

	aMetacelloRepositoriesSpec addMember: self! !

!MetacelloMemberSpec methodsFor: 'accessing' stamp: ''!
sourceName

	^self name! !

!MetacelloMemberSpec methodsFor: 'accessing' stamp: ''!
spec

	^spec! !

!MetacelloMemberSpec methodsFor: '*Metacello-MC' stamp: ''!
removeFromMetacelloPackages: aMetacelloPackagesSpec

	aMetacelloPackagesSpec addMember: self! !

!MetacelloMergeMemberSpec methodsFor: 'actions' stamp: ''!
applyToList: aListSpec

	aListSpec merge: self! !

!MetacelloMergeMemberSpec methodsFor: 'actions' stamp: ''!
applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock

	mergeBlock value: self! !

!MetacelloMergeMemberSpec methodsFor: 'accessing' stamp: ''!
methodUpdateSelector

	^#with:! !

!MetacelloMethodSection methodsFor: 'printing' stamp: ''!
attributePrintString
    | stream |
    stream := WriteStream on: String new.
    self attributes size = 1
        ifTrue: [ stream nextPutAll: '#' , attributes first asString printString ]
        ifFalse: [ 
            stream nextPutAll: '#('.
            self attributes
                do: [ :attribute | 
                    stream
                        nextPutAll: '#' , attribute asString printString;
                        space ].
            stream nextPut: $) ].
    ^ stream contents! !

!MetacelloMethodSection methodsFor: 'accessing' stamp: ''!
attributes
    attributes ifNil: [ attributes := OrderedCollection new ].
    ^ attributes! !

!MetacelloMethodSection methodsFor: 'testing' stamp: ''!
includesAttributeFrom: attributeCollection
    ^ (attributeCollection asSet intersection: self attributes asSet) notEmpty! !

!MetacelloMethodSection methodsFor: 'accessing' stamp: ''!
attributes: aCollectionOrSymbol
    attributes := aCollectionOrSymbol asMetacelloAttributeList! !

!MetacelloMethodSectionPath methodsFor: 'converting' stamp: ''!
asMetacelloAttributePath
    ^ self! !

!MetacelloMethodSectionPath methodsFor: 'converting' stamp: ''!
asAttributeOrPath
    self size = 1
        ifTrue: [ 
            | attribute |
            attribute := self at: 1.
            ^ attribute size = 1
                ifTrue: [ attribute at: 1 ]
                ifFalse: [ attribute ] ].
    ^ self! !

!MetacelloMethodSpec methodsFor: 'accessing' stamp: ''!
methodSections: anObject
	methodSections := anObject! !

!MetacelloMethodSpec methodsFor: 'accessing' stamp: ''!
project: anObject
	project := anObject! !

!MetacelloMethodSpec methodsFor: 'method generation' stamp: ''!
methodSource

	self subclassResponsibility! !

!MetacelloMethodSpec methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!MetacelloMethodSpec methodsFor: 'accessing' stamp: ''!
versionString: aStringOrSymbol
	versionString := aStringOrSymbol! !

!MetacelloMethodSpec methodsFor: 'accessing' stamp: ''!
category: anObject
	category := anObject! !

!MetacelloMethodSpec methodsFor: 'accessing' stamp: ''!
category
	^ category! !

!MetacelloMethodSpec methodsFor: 'method generation' stamp: ''!
compileMethod

	(project configuration class
		compile: self methodSource
		classified: self category) == nil
		ifTrue: [ self error: 'Error compiling the method' ]! !

!MetacelloMethodSpec methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!MetacelloMethodSpec methodsFor: 'accessing' stamp: ''!
project
	^ project! !

!MetacelloMethodSpec methodsFor: 'accessing' stamp: ''!
versionString
	^ versionString! !

!MetacelloMethodSpec methodsFor: 'accessing' stamp: ''!
methodSections

	methodSections == nil ifTrue: [ methodSections := OrderedCollection new ].
	^ methodSections! !

!MetacelloMonticelloResource methodsFor: 'accessing' stamp: ''!
versionReferences
	^ versionReferences! !

!MetacelloMonticelloResource methodsFor: 'accessing' stamp: ''!
monticelloRepository
	^ monticelloRepository! !

!MetacelloMonticelloResource methodsFor: 'running' stamp: ''!
setUpVersionReferences
  "self reset"

  versionReferences := OrderedCollection new.
  versionReferences
    add: (GoferVersionReference name: 'GoferBar.branch-lr.1');
    add: (GoferVersionReference name: 'GoferBar.branch-lr.2');
    add: (GoferVersionReference name: 'GoferBar-jf.1');
    add: (GoferVersionReference name: 'GoferBar-lr.1');
    add: (GoferVersionReference name: 'GoferFoo-lr.1');
    add: (GoferVersionReference name: 'GoferFoo-lr.2');
    add: (GoferVersionReference name: 'GoferFoo-lr.4');
    add: (GoferVersionReference name: 'GoferBeau-dkh.15');
    add: (GoferVersionReference name: 'GoferBeau-dkh.25');
    add: (GoferVersionReference name: 'GoferBeau-dkh.53');
    add: (GoferVersionReference name: 'GoferBeau-dkh.54');
    add: (GoferVersionReference name: 'GoferBeau-dkh.55');
    add: (GoferVersionReference name: 'GoferBeau-dkh.56');
    add: (GoferVersionReference name: 'GoferFaux-tg.30');
    add: (GoferVersionReference name: 'GoferFaux-tg.31');
    add: (GoferVersionReference name: 'GoferFaux-tg.32');
    add: (GoferVersionReference name: 'GoferFaux-tg.33');
    add: (GoferVersionReference name: 'GoferFaux-tg.34');
    add: (GoferVersionReference name: 'GoferFaux-tg.35');
    add: (GoferVersionReference name: 'GeauxBar.branch-lr.2');
    add: (GoferVersionReference name: 'GeauxFoo-lr.1');
    add: (GoferVersionReference name: 'GeauxFaux-tg.32');
    add: (GoferVersionReference name: 'GeauxBeau-dkh.55');
    add: (GoferVersionReference name: 'GeauxBeau-dkh.56');
    add: (GoferVersionReference name: 'Issue339-JanKurs.1');
    add: (GoferVersionReference name: 'Issue339-JanKurs.11');
    add:
        (GoferVersionReference name: 'ConfigurationOfNautilusWithoutPackages-dkh.55');
    add:
        (GoferVersionReference name: 'ConfigurationOfNautilusWithoutPackages-dkh.56');
    add:
        (GoferVersionReference name: 'ConfigurationOfNautilusWithoutPackages-dkh.57');
    add: (GoferVersionReference name: 'ConfigurationOfNautilus-dkh.56');
    add: (GoferVersionReference name: 'ConfigurationOfGlamourSeaside-dkh.55');
    add: (GoferVersionReference name: 'ConfigurationOfGlamourSeaside-dkh.56');
    add: (GoferVersionReference name: 'ConfigurationOfGlamourSeaside-dkh.57');
    add: (GoferVersionReference name: 'ConfigurationOfGlamour-dkh.56');
    yourself! !

!MetacelloMonticelloResource methodsFor: 'running' stamp: ''!
setUpMonticelloRepository
	"This method builds a fake repository with the version references from #buildReferences."

	monticelloRepository := MCDictionaryRepository new.
	versionReferences do: [ :reference |
		monticelloRepository basicStoreVersion: (MCVersion new
			setPackage:  (MetacelloTestsMCPackage new name: reference packageName)
			info: (MCVersionInfo
				name: reference name
				id: UUID new
				message: 'This is a mock version'
				date: Date today
				time: Time now
				author: reference author
				ancestors: #())
			snapshot: (MCSnapshot fromDefinitions: (Array
				with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol))
				with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: '')))
			dependencies: #()) ]! !

!MetacelloMonticelloResource methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self
		setUpVersionReferences;
		setUpMonticelloRepository! !

!MetacelloNameNotDefinedError methodsFor: 'accessing' stamp: ''!
isResumable
  "Pharo and Squeak compatibility"

  ^ true! !

!MetacelloNotification commentStamp: ''!
I am a notification for logging of textual represenation of Metacello events!
!MetacelloNotification class methodsFor: 'exceptioninstantiator' stamp: ''!
signal: message level: aLevel
	"Signal the occurrence of an exceptional condition with a specified textual description."
	
	| outdent |
	
	outdent := ((1 to: (aLevel - 1)) collect: [ :ignore | String tab ]) joinUsing: ''.

	^ super signal: outdent, message! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: ''!
afterLoads

	afterLoads == nil ifTrue: [ afterLoads := OrderedCollection new ].
	^afterLoads! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: ''!
beforeLoads

	beforeLoads == nil ifTrue: [ beforeLoads := OrderedCollection new ].
	^beforeLoads! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'versionInfo' stamp: ''!
currentVersionInfoFor: packageSpec

	^self loadData
		currentVersionInfoFor: packageSpec 
		ifAbsent: [ nil ]! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: ''!
evalDoits: aBool

	evalDoits := aBool! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'actions' stamp: ''!
doingLoads: aBlock
	"escape mechanism for recording and null loaders to skip doing loaderlike things"! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'actions' stamp: ''!
loadPackageDirectives: pkgLoads gofer: aGofer
	"Noop"! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: ''!
loadedRepositories

	| repos |
	repos := OrderedCollection new.
	self repositoryMap values collect: [:coll | repos addAll: coll ].
	^repos! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'doits' stamp: ''!
postLoad: packageOrVersionSpec

	self evalDoits ifFalse: [ ^self ].
	packageOrVersionSpec postLoadDoItBlock ~~ nil
		ifTrue: [ self afterLoads add: packageOrVersionSpec printString, ' load' ].
	super postLoad: packageOrVersionSpec! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: ''!
packages

	| packages |
	packages := OrderedCollection new.
	self loadDirective packageDirectivesDo: [:directive | packages add: directive spec ].
	^packages! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: ''!
evalDoits

	evalDoits == nil ifTrue: [ evalDoits := false ].
	^evalDoits! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'actions' stamp: ''!
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: ''!
loadPackageDirective: aPackageLoadDirective gofer: aGofer
	"Noop"! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: ''!
actionLabel

	^'Recording '! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'doits' stamp: ''!
preLoad: packageOrVersionSpec

	self evalDoits ifFalse: [ ^self ].
	packageOrVersionSpec preLoadDoItBlock ~~ nil
		ifTrue: [ self beforeLoads add: packageOrVersionSpec printString, ' load' ].
	super preLoad: packageOrVersionSpec! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: ''!
loadedPackages

	| packages |
	packages := OrderedCollection new.
	self loadDirective packageDirectivesDo: [:directive | packages add: directive file ].
	^packages! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: ''!
loadingSpecLoader

	^self! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: ''!
recordingSpecLoader

	^self! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'testing' stamp: ''!
ensureForDevelopment

	^false! !

!MetacelloNullRecordingMCSpecLoader methodsFor: 'private' stamp: ''!
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 = MetacelloPlatform current defaultPackageCache ]) ]
    ifFalse: [ 
      self repositoryMap
        at: externalPackageReference packageName
        put:
          (packageSpec repositorySpecs collect: [ :repoSpec | repoSpec createRepository ]) ].
  ^ externalPackageReference! !

!MetacelloOldSemanticVersionNumber class methodsFor: 'private' stamp: ''!
validateVersionNumber: svn against: aString
  "no validation"! !

!MetacelloOldSemanticVersionNumber class methodsFor: 'private' stamp: ''!
integerFromString: aString
  ^ aString asInteger! !

!MetacelloPackageLoadDirective methodsFor: 'actions' stamp: ''!
loadUsing: aLoaderDirective gofer: aGofer

	aLoaderDirective loadPackageDirective: self gofer: aGofer! !

!MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: ''!
resolvedReference
	^ resolvedReference! !

!MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: ''!
repository

	^self externalReference repository! !

!MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: ''!
resolvedReference: anObject
	resolvedReference := anObject! !

!MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: ''!
externalReference
	^ externalReference! !

!MetacelloPackageLoadDirective methodsFor: 'enumerating' stamp: ''!
packageDo: aBlock

	aBlock value: self! !

!MetacelloPackageLoadDirective methodsFor: 'initialization' stamp: ''!
spec: aPackageSpec externalReference: anExternalReference loader: aLoader

	super spec: aPackageSpec loader: aLoader.
	externalReference := anExternalReference! !

!MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: ''!
file

	^self externalReference name! !

!MetacelloPackageLoadDirective methodsFor: 'enumerating' stamp: ''!
packageDirectivesDo: aBlock

	aBlock value: self! !

!MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: ''!
packageName

	^self externalReference packageName! !

!MetacelloPackageLoadDirective methodsFor: 'printing' stamp: ''!
label

	^self file! !

!MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: ''!
title

	^'load'! !

!MetacelloPackageSpec methodsFor: 'accessing' stamp: ''!
goferPackage

	goferPackage == nil 
		ifTrue: [ goferPackage := MetacelloGoferPackage name: self name packageFilename: self file ].
	^goferPackage! !

!MetacelloPackageSpec methodsFor: 'accessing' stamp: ''!
repository: aString username: username password: password

	self repositories repository: aString username: username password: password! !

!MetacelloPackageSpec methodsFor: 'construction' stamp: ''!
repository: aString username: username password: password constructor: aVersionConstructor
    aVersionConstructor repositoryForPackage: aString username: username password: password! !

!MetacelloPackageSpec methodsFor: 'fetching' stamp: ''!
searchCacheRepositoryForPackage: searchBlock
  "evaluate the <searchBlock> if you want to search for the package in a local package cache"

  "for standard mcz repositories the answer is YES!!"

  searchBlock value! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
fetchPackage: aLoaderPolicy

	self fetchUsing: 
		(self loader
			loaderPolicy: aLoaderPolicy;
			yourself)! !

!MetacelloPackageSpec methodsFor: 'construction' stamp: ''!
includes: anObject constructor: aVersionConstructor
    aVersionConstructor includesForPackage: anObject! !

!MetacelloPackageSpec methodsFor: 'construction' stamp: ''!
preLoadDoIt: aSymbol constructor: aVersionConstructor
    aVersionConstructor preLoadDoItForPackage: aSymbol! !

!MetacelloPackageSpec methodsFor: 'construction' stamp: ''!
supplyingAnswers: anObject constructor: aVersionConstructor
    aVersionConstructor supplyingAnswersForPackage: anObject! !

!MetacelloPackageSpec methodsFor: 'development support' stamp: ''!
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: 'testing' stamp: ''!
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"

	| 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: 'merging' stamp: ''!
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: 'querying' stamp: ''!
file

	file == nil ifTrue: [ ^self name ].
	^file! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
packageSpecsInLoadOrder

	^{ self. }! !

!MetacelloPackageSpec methodsFor: 'development support' stamp: ''!
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: ''!
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: 'testing' stamp: ''!
hasRepository
    ^ self repositorySpecs notEmpty! !

!MetacelloPackageSpec methodsFor: 'accessing' stamp: ''!
goferLoaderReference

	^file == nil 
		ifTrue: [ GoferPackageReference name: self name ]
		ifFalse: [ 
			"does Monticello-style #versionInfoFromVersionNamed: matching"
			MetacelloGoferPackage name: self name packageFilename: self file ]! !

!MetacelloPackageSpec methodsFor: 'development support' stamp: ''!
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: 'loading' stamp: ''!
repositorySpecs

	^self repositories map values! !

!MetacelloPackageSpec methodsFor: 'construction' stamp: ''!
file: aString constructor: aVersionConstructor
    aVersionConstructor fileForPackage: aString! !

!MetacelloPackageSpec methodsFor: 'testing' stamp: ''!
currentPackageLoaded: loadedBlock comparing: comarisonOperator notLoaded: notLoadedBlock using: anMCLoader
  "Use currentVersionInfoFor: because it involves the loader and returns versionInfo for a planned load 
	 (atomic loaders) or currently loaded package"

  | wcName vis |
  vis := anMCLoader ancestorsFor: self.
  vis notNil
    ifTrue: [ 
      | fileRef wcRef |
      self getFile == nil
        ifTrue: [ ^ loadedBlock value: false ].
      vis
        do: [ :vi | 
          wcName := vi name.
          fileRef := GoferVersionReference name: self file.
          fileRef versionNumber = 0
            ifTrue: [ 
              "a shame that GoferVersionReference doesn't have better method for recognizing a missing verion number"
              "fix for: https://github.com/dalehenrich/metacello-work/issues/185"
              ^ loadedBlock value: false ].
          wcRef := GoferVersionReference name: wcName.
          (wcRef compare: fileRef using: comarisonOperator)
            ifTrue: [ ^ loadedBlock value: true ] ].
      ^ loadedBlock value: false ].
  ^ notLoadedBlock value: true! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
load

	self explicitLoadUsing: self loader! !

!MetacelloPackageSpec methodsFor: 'accessing' stamp: ''!
setPostLoadDoIt: aSymbol

	postLoadDoIt := aSymbol! !

!MetacelloPackageSpec methodsFor: 'accessing' stamp: ''!
setPreLoadDoIt: aSymbol

	preLoadDoIt := aSymbol! !

!MetacelloPackageSpec methodsFor: 'merging' stamp: ''!
nonOverridable

	^super nonOverridable, #( repositories)! !

!MetacelloPackageSpec methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionRequiresContext: aContext
		
	aContext active: self requires isNotEmpty! !

!MetacelloPackageSpec methodsFor: 'copying' stamp: ''!
postCopy

	super postCopy.
	goferPackage := nil.
	repositories := repositories copy.! !

!MetacelloPackageSpec methodsFor: 'querying' stamp: ''!
isPackageLoaded

	^self isPackageLoaded: self loader! !

!MetacelloPackageSpec methodsFor: 'private' stamp: ''!
extractNameFromFile

	file == nil ifTrue: [ ^nil ].
	^(self loader nameComponentsFrom: self file) first! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
explicitLoadUsing: mcLoader
	| wc fetchingSpecLoader |

	((wc := self workingCopy) notNil and: [ wc needsSaving ]) 
		ifTrue: [ 
			(MetacelloSkipDirtyPackageLoad signal: self)
				ifTrue:  [
					MetacelloNotification signal: ('Skipping load of modified package: ', self file).
					^self]
				ifFalse: [MetacelloNotification signal: ('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: 'accessing' stamp: ''!
file: aString

	file := aString! !

!MetacelloPackageSpec methodsFor: 'development support' stamp: ''!
updatePackageRepositories: repositorySpecs

	| resolvedPackageRef |
	MetacelloNotification signal: ('  Looking up version -> ', self file).
	resolvedPackageRef := self loader resolveSpec: self from: repositorySpecs.
	MetacelloNotification signal: ('Update repositoryGroup -> ', resolvedPackageRef name, ' ' , resolvedPackageRef repository description).
	resolvedPackageRef version workingCopy repositoryGroup addRepository: resolvedPackageRef repository! !

!MetacelloPackageSpec methodsFor: 'querying' stamp: ''!
repositories

	repositories == nil ifTrue: [ repositories := self project repositoriesSpec ].
	^ repositories! !

!MetacelloPackageSpec methodsFor: 'development support' stamp: ''!
forceUpdatePackageSpec: updatedSpecs using: anMCLoader
	
	self updatePackageSpec: updatedSpecs force: true using: anMCLoader! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
ensureLoadUsing: mcLoader
	self explicitLoadUsing: mcLoader ensureSpecLoader! !

!MetacelloPackageSpec methodsFor: 'development support' stamp: ''!
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: 'gofer' stamp: ''!
currentVersionInfo

	^self goferPackage currentVersionInfo! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
postLoadDoIt: anObject

	anObject setPostLoadDoItInMetacelloSpec: self! !

!MetacelloPackageSpec methodsFor: 'accessing' stamp: ''!
repository: aStringOrMetacelloRepositorySpec

	self repositories repository: aStringOrMetacelloRepositorySpec! !

!MetacelloPackageSpec methodsFor: 'construction' stamp: ''!
requires: anObject constructor: aVersionConstructor
    aVersionConstructor requiresForPackage: anObject! !

!MetacelloPackageSpec methodsFor: 'querying' stamp: ''!
getPreLoadDoIt

	^preLoadDoIt! !

!MetacelloPackageSpec methodsFor: 'gofer' stamp: ''!
workingCopyNameFor: anMCLoader

	| vi |
	(vi := anMCLoader currentVersionInfoFor: self) == nil ifTrue: [ ^nil ].
	^vi name! !

!MetacelloPackageSpec methodsFor: 'printing' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
getName
    "raw access to iv"

    ^ name! !

!MetacelloPackageSpec methodsFor: 'construction' stamp: ''!
repositories: aBlock constructor: aVersionConstructor
    aVersionConstructor repositoriesForPackage: aBlock! !

!MetacelloPackageSpec methodsFor: 'visiting' stamp: ''!
visitingWithPackages: packages

	packages at: self name put: self! !

!MetacelloPackageSpec methodsFor: 'development support' stamp: ''!
updatePackageSpec: updatedSpecs using: anMCLoader
	"Add pkg copy to updatedSpecs if the file in current image is different from the receiver's file"
	
	self updatePackageSpec: updatedSpecs force: false using: anMCLoader! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
fetch

	self fetchUsing: self loader! !

!MetacelloPackageSpec methodsFor: 'accessing' stamp: ''!
getRepositories
    "raw access to iv"

    ^ repositories! !

!MetacelloPackageSpec methodsFor: 'accessing' stamp: ''!
preLoadDoIt: anObject

	anObject setPreLoadDoItInMetacelloSpec: self! !

!MetacelloPackageSpec methodsFor: 'querying' stamp: ''!
preLoadDoIt

	^preLoadDoIt! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
repositoryDescriptions
    ^ self repositorySpecs collect: [ :repoSpec | repoSpec description ]! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
fetchUsing: mcLoader

	| fetchingSpecLoader |
	fetchingSpecLoader := mcLoader fetchingSpecLoader.
	fetchingSpecLoader
		linearLoadPackageSpecs: (Array with: self) 
		repositories: (fetchingSpecLoader repositoriesFrom: self repositorySpecs).! !

!MetacelloPackageSpec methodsFor: 'testing' stamp: ''!
compareWorkingCopyNamed: wcName using: comarisonOperator
	| fileRef wcRef |
	fileRef := GoferResolvedReference name: self file.
	wcRef := GoferResolvedReference name: wcName.
	^ wcRef compare: fileRef using: comarisonOperator! !

!MetacelloPackageSpec methodsFor: 'querying' stamp: ''!
isPackageLoaded: aLoader

	^(self workingCopyNameFor: aLoader) ~~ nil! !

!MetacelloPackageSpec methodsFor: 'visiting' stamp: ''!
projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock

	packageBlock value: self! !

!MetacelloPackageSpec methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
type

	^ 'package'! !

!MetacelloPackageSpec methodsFor: 'private' stamp: ''!
includesForPackageOrdering
  ^ self includes! !

!MetacelloPackageSpec methodsFor: 'development support' stamp: ''!
copySpecTo: aRepositorySpec
	"Copy current mcz file to the repository named in aRepositorySpec"

	self loader copySpec: self from: self repositorySpecs to: aRepositorySpec createRepository! !

!MetacelloPackageSpec methodsFor: 'accessing' stamp: ''!
info
	"test compatibility method"

	^self! !

!MetacelloPackageSpec methodsFor: 'printing' stamp: ''!
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: 'loading' stamp: ''!
loadUsing: aLoader gofer: gofer

	^aLoader linearLoadPackageSpec: self gofer: gofer! !

!MetacelloPackageSpec methodsFor: 'construction' stamp: ''!
postLoadDoIt: aSymbol constructor: aVersionConstructor
    aVersionConstructor postLoadDoItForPackage: aSymbol! !

!MetacelloPackageSpec methodsFor: 'gofer' stamp: ''!
workingCopy

	^self goferPackage workingCopy! !

!MetacelloPackageSpec methodsFor: 'querying' stamp: ''!
postLoadDoIt

	^postLoadDoIt! !

!MetacelloPackageSpec methodsFor: 'testing' stamp: ''!
compareRelativeCurrentVersion: anOperator targetVersionStatus: statusIgnored using: anMCLoader

	^self compareCurrentVersion: anOperator targetVersionStatus: statusIgnored using: anMCLoader! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
ensureLoadedForDevelopmentUsing: mcLoader
	"noop"
	
	^true! !

!MetacelloPackageSpec methodsFor: 'loading' stamp: ''!
loadUsing: mcLoader

	self loader doingLoads: [ self explicitLoadUsing: mcLoader ]! !

!MetacelloPackageSpec methodsFor: 'construction' stamp: ''!
repository: anObject constructor: aVersionConstructor
    aVersionConstructor repositoryForPackage: anObject! !

!MetacelloPackageSpec methodsFor: 'private' stamp: ''!
resolveToPackagesIn: aVersionSpec visited: visited

	^{ self }! !

!MetacelloPackageSpec methodsFor: 'printing' stamp: ''!
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: 'querying' stamp: ''!
name

	name == nil ifTrue: [ name := self extractNameFromFile ].
	^name! !

!MetacelloPackageSpec methodsFor: 'development support' stamp: ''!
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: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionRequires
	<inspectorPresentationOrder: 10 title: 'Require'>
	| specs |

	specs := self project version spec packageSpecsInLoadOrder.
	^ SpListPresenter new
		items: (specs select: [ :each | self requires includes: each name ]);
		display: [ :aSpec | aSpec name ];
		yourself! !

!MetacelloPackageSpec methodsFor: 'gofer' stamp: ''!
workingCopyName

	| wc |
	(wc := self workingCopy) == nil ifTrue: [ ^nil ].
	wc ancestry ancestors isEmpty not
		ifTrue: [ ^wc ancestry ancestors first name ].
	^nil! !

!MetacelloPackageSpec methodsFor: 'development support' stamp: ''!
packagesNeedSavingVisited: visitedProjects using: repos into: aCollection

	^self loader packagesNeedSavingUsing: repos into: aCollection! !

!MetacelloPackageSpec methodsFor: 'merging' stamp: ''!
mergeSpec: anotherSpec

	| newSpec map 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: 'testing' stamp: ''!
compareCurrentVersion: anOperator targetVersionStatus: statusIgnored using: anMCLoader

	self 
		currentPackageLoaded: [:bool | ^bool ] 
		comparing: anOperator 
		notLoaded: [:ignored | ^false ]
		using: anMCLoader! !

!MetacelloPackageSpec methodsFor: 'querying' stamp: ''!
repositories: anObject
	repositories := anObject! !

!MetacelloPackageSpec methodsFor: 'querying' stamp: ''!
getPostLoadDoIt

	^postLoadDoIt! !

!MetacelloPackageSpec methodsFor: 'accessing' stamp: ''!
getFile
	"raw access to iv"
	
	^file! !

!MetacelloPackageSpec methodsFor: 'gofer' stamp: ''!
ancestors

	^self goferPackage ancestors! !

!MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: ''!
repositoryError: anObject
	repositoryError := anObject! !

!MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: ''!
packageSpec
	^ packageSpec! !

!MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: ''!
packageSpec: anObject
	packageSpec := anObject! !

!MetacelloPackageSpecResolutionError methodsFor: 'private' stamp: ''!
repositoryString
    | repositoryString |
    repositoryString := ''.
    self repositories do: [ :repo | repositoryString := repositoryString , ' ' , repo description ].
    ^ repositoryString! !

!MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: ''!
description
    "Return a textual description of the exception."

    ^ 'Could not resolve: ' , packageSpec name , ' [' , packageSpec file , ']' , ' in' , self repositoryString
        ,
            (repositoryError == nil
                ifTrue: [ '' ]
                ifFalse: [ 
                    "report repository error to user here, since failure here is likely to be due to earlier repository error"
                    ' ERROR: ' , repositoryError description printString ])! !

!MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: ''!
repositories
	^ repositories! !

!MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: ''!
repositoryError
	^ repositoryError! !

!MetacelloPackageSpecResolutionError methodsFor: 'Signaling' stamp: ''!
signal
  "GemStone needs this to print exception correctly"

  self messageText: self description.
  ^ super signal! !

!MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: ''!
repositories: anObject
	repositories := anObject! !

!MetacelloPackageSpecTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!MetacelloPackageSpecTestCase methodsFor: 'tests' stamp: ''!
testPackageMergeSpec
	| packageA packageB package repository |
	packageA := self packageSpec
		name: 'Package';
		name: 'Package';
		requires: 'AnotherPackage';
		includes: 'IncludedPackage';
		answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
		file: 'Package-dkh.1';
		preLoadDoIt: #preLoadDoIt;
		postLoadDoIt: #postLoadDoIt;
		repository: 'http://example.com/repository' username: 'dkh' password: 'password';
		repository: '/opt/gemstone/repository';
		yourself.
	packageB := self packageSpec
		name: 'Package';
		requires: 'AndAnotherPackage';
		includes: 'AndIncludedPackage';
		answers: #(#('xpostload' 'xpostload answer'));
		file: 'Package-dkh.2';
		repository: 'http://example.com/repository' username: 'DaleHenrichs' password: 'secret';
		repository: '/opt/gemstone/repo';
		yourself.
	package := packageA mergeSpec: packageB.
	self assert: package name equals: 'Package'.
	self assert: package requires equals: #('AnotherPackage' 'AndAnotherPackage').
	self assert: package includes equals: #('IncludedPackage' 'AndIncludedPackage').
	self assert: package answers equals: #(#('preload' 'preload answer') #('postload' 'postload answer') #('xpostload' 'xpostload answer')).
	self assert: package file equals: 'Package-dkh.2'.
	self assert: package preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: package postLoadDoIt value identicalTo: #postLoadDoIt.
	repository := package repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := package repositories map at: '/opt/gemstone/repo' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := package repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'DaleHenrichs'.
	self assert: repository password equals: 'secret'! !

!MetacelloPackageSpecTestCase methodsFor: 'tests' stamp: ''!
testPackageSpec
	| package repository |
	package := self packageSpec
		name: 'Package';
		requires: 'AnotherPackage';
		includes: 'IncludedPackage';
		answers: #(#('preload' 'preload answer') #('postload' 'postload answer'));
		file: 'Package-dkh.1';
		preLoadDoIt: #preLoadDoIt;
		postLoadDoIt: #postLoadDoIt;
		repository: 'http://example.com/repository' username: 'dkh' password: 'password';
		repository: '/opt/gemstone/repository';
		yourself.
	self assert: package name equals: 'Package'.
	self assert: package requires equals: #('AnotherPackage').
	self assert: package includes equals: #('IncludedPackage').
	self assert: package answers equals: #(#('preload' 'preload answer') #('postload' 'postload answer')).
	self assert: package file equals: 'Package-dkh.1'.
	self assert: package preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: package postLoadDoIt value identicalTo: #postLoadDoIt.
	repository := package repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'directory'.
	repository := package repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'dkh'.
	self assert: repository password equals: 'password'! !

!MetacelloPackagesSpec methodsFor: 'accessing' stamp: ''!
applyIncludesTo: orderedSpecs for: pkgSpec firstTime: firstTime for: aVersionSpec
  | movedSpecs baseIndex |
  movedSpecs := Set new.
  baseIndex := orderedSpecs indexOf: pkgSpec.
  (pkgSpec includeSpecNamesForPackageOrdering: aVersionSpec)
    do: [ :includedSpec | 
      | includedSpecName spec |
      includedSpecName := includedSpec name.
      spec := orderedSpecs
        detect: [ :aSpec | aSpec name = includedSpecName ]
        ifNone: [  ].
      (self
        slideIn: orderedSpecs
        spec: spec
        baseIndex: baseIndex
        seen: IdentitySet new
        firstTime: firstTime
        for: aVersionSpec)
        ifTrue: [ movedSpecs add: spec name ] ].
  ^ movedSpecs! !

!MetacelloPackagesSpec methodsFor: 'printing' stamp: ''!
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: 'actions' stamp: ''!
add: aSpec

	aSpec addToMetacelloPackages: self! !

!MetacelloPackagesSpec methodsFor: 'accessing' stamp: ''!
slideIn: orderedSpecs spec: targetSpec baseIndex: baseIndex seen: seen firstTime: firstTime for: aVersionSpec
  | targetIndex requiredSpecNames 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 requiredSpecNamesForPackageOrdering: aVersionSpec)
      includes: baseSpec name)
      ifTrue: [ required := true ] ].
  firstTime
    ifFalse: [ 
      required
        ifFalse: [ ^ false ] ].
  requiredSpecNames := targetSpec
    requiredSpecNamesForPackageOrdering: aVersionSpec.
  targetRequires := orderedSpecs
    select: [ :spec | requiredSpecNames 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
        for: aVersionSpec ].
  ^ true! !

!MetacelloPackagesSpec methodsFor: 'accessing' stamp: ''!
packageSpecsInLoadOrderFor: aVersionSpec
  "order only the packageSpecs and projectSpecs. groupSpec order does not matter"

  | orderedPackageSpecs groupSpecs moved lastMovedSpecs count terminationLimit map specsWithIncludes firstTime groupLoops |
  map := self map.
  orderedPackageSpecs := OrderedCollection new.
  groupSpecs := Set new.
  self list
    do: [ :member | 
      | spec |
      spec := map at: member name ifAbsent: [  ].
      (spec == nil or: [ orderedPackageSpecs includes: spec ])
        ifFalse: [ 
          spec
            projectDo: [ :prjSpec | 
              "specification order is the default order"
              orderedPackageSpecs add: prjSpec ]
            packageDo: [ :pkgSpec | 
              "specification order is the default order"
              orderedPackageSpecs add: pkgSpec ]
            groupDo: [ :groupSpec | groupSpecs add: groupSpec ] ] ].
  orderedPackageSpecs isEmpty
    ifTrue: [ ^ orderedPackageSpecs , groupSpecs asOrderedCollection ].
  moved := true.
  count := 0.
  terminationLimit := orderedPackageSpecs size * 2.
  groupLoops := IdentitySet new.
  [ 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.
      orderedPackageSpecs copy
        do: [ :packageSpec | 
          moved := moved
            or: [ 
              self
                sortPackageSpecs: orderedPackageSpecs
                packageSpec: packageSpec
                groupLoops: groupLoops
                for: aVersionSpec ] ] ].
  lastMovedSpecs := Set new.
  moved := true.
  count := 0.
  specsWithIncludes := orderedPackageSpecs
    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: orderedPackageSpecs
                for: packageSpec
                firstTime: firstTime
                for: aVersionSpec) ].
      result size = lastMovedSpecs size
        ifTrue: [ 
          result
            do: [ :name | 
              (lastMovedSpecs includes: name)
                ifFalse: [ moved := true ] ] ]
        ifFalse: [ moved := true ].
      lastMovedSpecs := result.
      firstTime := false ].
  ^ orderedPackageSpecs , groupSpecs asOrderedCollection! !

!MetacelloPackagesSpec methodsFor: 'private' stamp: ''!
sortPackageSpecs: orderedSpecs packageSpec: packageSpec groupLoops: groupLoops for: aVersionSpec
  | packageIndex moved movePackage targetPackage targetIndex targetSpecNames groupLoopDetected |
  packageIndex := orderedSpecs indexOf: packageSpec.
  moved := movePackage := false.
  targetSpecNames := packageSpec
    requiredSpecNamesForPackageOrdering: aVersionSpec.
  groupLoopDetected := groupLoops includes: packageSpec.
  groupLoopDetected
    ifFalse: [ 
      targetSpecNames
        do: [ :targetPackageOrProjectName | 
          targetPackage := orderedSpecs
            detect: [ :each | each name = targetPackageOrProjectName ]
            ifNone: [ 
              MetacelloNameNotDefinedError
                signal:
                  'project group, or package named: ' , targetPackageOrProjectName printString
                    ,
                      ' not found when used in requires: or includes: field of package: '
                    , packageSpec name printString , ' for version: '
                    , aVersionSpec versionString , ' of '
                    , aVersionSpec projectLabel , '.'.
              nil	"return nil if resumed" ].
          targetIndex := orderedSpecs indexOf: targetPackage.
          (groupLoopDetected not and: [ packageIndex = targetIndex ])
            ifTrue: [ 
              self
                notify:
                  'A group loop has been detected. The package: ' , packageSpec name printString
                    ,
                      ' requires a group that includes itself. If you resume, the group loop will be ignored and details will be written to the system log.'.
              groupLoopDetected := true.
              groupLoops add: packageSpec.
              MetacelloNotification signal: ('Package: ' , packageSpec name printString).
              MetacelloNotification signal: ('Raw Requires:') level: 2.
              packageSpec requires
                do: [ :each | 
                  MetacelloNotification signal: (each asString) level: 3].
              MetacelloNotification signal: (
                    'Package: ' , packageSpec name printString , ' has a group loop:').
				  MetacelloNotification signal: ('Expanded Requires:') level: 2.
              targetSpecNames
                do: [ :each | 
                  MetacelloNotification signal: (each asString) level: 3] ].
          movePackage := movePackage or: [ packageIndex <= targetIndex ].
          false
            ifTrue: [ 
              "use for debugging non-obvious reference loops"
              packageIndex < targetIndex
                ifTrue: [ 
                  MetacelloNotification signal: ('Moving ' , targetPackageOrProjectName , ' from ' , targetIndex printString
                            , ' to ' , packageIndex printString) ] ] ] ].
  groupLoopDetected
    ifTrue: [ 
      "old implementation that does not resolve group names"
      targetSpecNames := packageSpec requires.
      targetSpecNames
        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.
      targetSpecNames
        do: [ :targetPackageOrProjectName | 
          (targetPackage := orderedSpecs
            detect: [ :each | each name = targetPackageOrProjectName ]
            ifNone: [  ]) ~~ nil
            ifTrue: [ targetIndex := targetIndex max: (orderedSpecs indexOf: targetPackage) ] ].
      targetIndex == 0
        ifTrue: [ orderedSpecs add: packageSpec beforeIndex: packageIndex ]
        ifFalse: [ orderedSpecs add: packageSpec afterIndex: targetIndex ] ].
  ^ moved! !

!MetacelloPackagesSpec methodsFor: 'actions' stamp: ''!
remove: aSpec

	aSpec removeFromMetacelloPackages: self! !

!MetacelloPackagesSpec methodsFor: 'actions' stamp: ''!
merge: aSpec

	aSpec mergeIntoMetacelloPackages: self! !

!MetacelloPackagesSpec methodsFor: 'actions' stamp: ''!
copy: specNamed to: spec

	self addMember: 
		(self copyMember 
			name: spec name;
			sourceName: specNamed;
			spec: spec;
			yourself)! !

!MetacelloPackagesSpec methodsFor: 'accessing' stamp: ''!
packageNamed: aString ifAbsent: aBlock

	^self map at: aString ifAbsent: aBlock! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddGroupA
    "used by MetacelloAbstractVersionConstructor>>group:overrides:"

    | packages group |
    packages := self packagesSpec.
    packages
        add:
            (self groupSpec
                name: 'Platform';
                includes: 'Core';
                yourself).
    packages
        add:
            (self groupSpec
                name: 'Platform';
                includes: 'Tests';
                yourself).
    group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    self deny: (group includes includes: 'Core').
    self assert: (group includes includes: 'Tests')! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testMergeProjectB
	"used by MetacelloAbstractVersionConstructor>>project:with:"

	| packages project projectReferenceSpec referenceSpec |
	packages := self packagesSpec.
	project := self projectSpec
		name: 'Project';
		className: 'ConfigurationOfProjectA';
		versionString: #stable;
		loads: #('MyPackage' 'MyTests');
		preLoadDoIt: #preLoadDoItB;
		postLoadDoIt: #postLoadDoItB;
		yourself.
	referenceSpec := self project projectReferenceSpec
		name: project name;
		projectReference: project;
		yourself.
	packages add: referenceSpec.
	project := self projectSpec
		name: 'Project';
		className: 'ConfigurationOfProject';
		versionString: '1.0';
		operator: #<;
		loads: #('MyPackage');
		preLoadDoIt: #preLoadDoIt;
		postLoadDoIt: #postLoadDoIt;
		yourself.
	referenceSpec := self project projectReferenceSpec
		name: project name;
		projectReference: project;
		yourself.
	packages merge: {referenceSpec}.
	projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ].
	project := projectReferenceSpec referencedSpec.
	self assert: project name equals: 'Project'.
	self assert: project className equals: 'ConfigurationOfProject'.
	self assert: project versionString equals: '1.0'.
	self assert: project operator identicalTo: #<.
	self assert: project loads equals: #('MyPackage').
	self assert: project preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: project postLoadDoIt value identicalTo: #postLoadDoIt.
	project projectDo: [ :prjct | self assert: project identicalTo: prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddGroupB
    "used by MetacelloAbstractVersionConstructor>>group:overrides:"

    | packages group |
    packages := self packagesSpec.
    packages
        add:
            {(self groupSpec
                name: 'Platform';
                includes: 'Core';
                yourself).
            (self groupSpec
                name: 'Platform';
                includes: 'Tests';
                yourself)}.
    group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    self deny: (group includes includes: 'Core').
    self assert: (group includes includes: 'Tests')! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemoveProjectA
	"used by MetacelloAbstractVersionConstructor>>removeProject:"

	| packages project projectReferenceSpec removed |
	packages := self packagesSpec.
	packages
		add:
			(self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProject';
				versionString: '1.0';
				operator: #<;
				loads: #('MyPackage');
				preLoadDoIt: #preLoadDoIt;
				postLoadDoIt: #postLoadDoIt;
				yourself).
	projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ].
	project := projectReferenceSpec referencedSpec.
	self assert: project name equals: 'Project'.
	self assert: project className equals: 'ConfigurationOfProject'.
	self assert: project versionString equals: '1.0'.
	self assert: project operator identicalTo: #<.
	self assert: project loads equals: #('MyPackage').
	self assert: project preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: project postLoadDoIt value identicalTo: #postLoadDoIt.
	packages
		remove:
			(self projectReferenceSpec
				name: 'Project';
				yourself).
	removed := false.
	packages packageNamed: 'Project' ifAbsent: [ removed := true ].
	self assert: removed! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testMergeGroupB
    "used by MetacelloAbstractVersionConstructor>>group:with:"

    | packages group |
    packages := self packagesSpec.
    packages
        add:
            (self groupSpec
                name: 'Platform';
                includes: 'Core';
                yourself).
    packages
        merge:
            {(self groupSpec
                name: 'Platform';
                includes: 'Tests';
                yourself)}.
    group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    self assert: (group includes includes: 'Core').
    self assert: (group includes includes: 'Tests')! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddProjectB
	"used by MetacelloAbstractVersionConstructor>>project:overrides:"

	| packages project projectReferenceSpec |
	packages := self packagesSpec.
	packages
		add:
			{(self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProjectA';
				versionString: #stable;
				loads: #('MyPackage' 'MyTests');
				preLoadDoIt: #preLoadDoItB;
				postLoadDoIt: #postLoadDoItB;
				yourself) . (self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProject';
				versionString: '1.0';
				operator: #<;
				loads: #('MyPackage');
				preLoadDoIt: #preLoadDoIt;
				postLoadDoIt: #postLoadDoIt;
				yourself)}.
	projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ].
	self assert: projectReferenceSpec projectName equals: 'Project'.
	self assert: projectReferenceSpec versionString equals: '1.0'.
	self should: [ projectReferenceSpec includes: #() ] raise: Error.
	self should: [ projectReferenceSpec requires: #() ] raise: Error.
	self should: [ projectReferenceSpec answers: #() ] raise: Error.
	projectReferenceSpec
		projectDo: [ :prjct | self assert: projectReferenceSpec identicalTo: prjct ]
		packageDo: [ :ignored | self assert: false ]
		groupDo: [ :ignored | self assert: false ].
	project := projectReferenceSpec referencedSpec.
	self assert: project name equals: 'Project'.
	self assert: project className equals: 'ConfigurationOfProject'.
	self assert: project versionString equals: '1.0'.
	self assert: project operator identicalTo: #<.
	self assert: project loads equals: #('MyPackage').
	self assert: project preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: project postLoadDoIt value identicalTo: #postLoadDoIt.
	project projectDo: [ :prjct | self assert: project identicalTo: prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddProjectA
	"used by MetacelloAbstractVersionConstructor>>project:overrides:"

	| packages project projectReferenceSpec |
	packages := self packagesSpec.
	packages
		add:
			(self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProjectA';
				versionString: #stable;
				loads: #('MyPackage' 'MyTests');
				preLoadDoIt: #preLoadDoItB;
				postLoadDoIt: #postLoadDoItB;
				yourself).
	packages
		add:
			(self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProject';
				versionString: '1.0';
				operator: #<;
				loads: #('MyPackage');
				preLoadDoIt: #preLoadDoIt;
				postLoadDoIt: #postLoadDoIt;
				yourself).
	projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ].
	self assert: projectReferenceSpec projectName equals: 'Project'.
	self assert: projectReferenceSpec versionString equals: '1.0'.
	self should: [ projectReferenceSpec includes: #() ] raise: Error.
	self should: [ projectReferenceSpec requires: #() ] raise: Error.
	self should: [ projectReferenceSpec answers: #() ] raise: Error.
	projectReferenceSpec
		projectDo: [ :prjct | self assert: projectReferenceSpec identicalTo: prjct ]
		packageDo: [ :ignored | self assert: false ]
		groupDo: [ :ignored | self assert: false ].
	project := projectReferenceSpec referencedSpec.
	self assert: project name equals: 'Project'.
	self assert: project className equals: 'ConfigurationOfProject'.
	self assert: project versionString equals: '1.0'.
	self assert: project operator identicalTo: #<.
	self assert: project loads equals: #('MyPackage').
	self assert: project preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: project postLoadDoIt value identicalTo: #postLoadDoIt.
	project projectDo: [ :prjct | self assert: project identicalTo: prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemoveProjectB
	"used by MetacelloAbstractVersionConstructor>>removeProject:"

	| packages project projectReferenceSpec removed |
	packages := self packagesSpec.
	packages
		add:
			(self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProject';
				versionString: '1.0';
				operator: #<;
				loads: #('MyPackage');
				preLoadDoIt: #preLoadDoIt;
				postLoadDoIt: #postLoadDoIt;
				yourself).
	projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ].
	project := projectReferenceSpec referencedSpec.
	self assert: project name equals: 'Project'.
	self assert: project className equals: 'ConfigurationOfProject'.
	self assert: project versionString equals: '1.0'.
	self assert: project operator identicalTo: #<.
	self assert: project loads equals: #('MyPackage').
	self assert: project preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: project postLoadDoIt value identicalTo: #postLoadDoIt.
	packages
		remove:
			{(self projectReferenceSpec
				name: 'Project';
				yourself)}.
	removed := false.
	packages packageNamed: 'Project' ifAbsent: [ removed := true ].
	self assert: removed! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemoveGroupB
    "used by MetacelloAbstractVersionConstructor>>removeGroup:"

    | packages removed |
    packages := self packagesSpec.
    packages
        add:
            {(self groupSpec
                name: 'Platform';
                includes: 'Core';
                yourself).
            (self groupSpec
                name: 'Base';
                includes: 'Base';
                yourself).
            (self groupSpec
                name: 'Tests';
                includes: 'Tests';
                yourself)}.
    packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    packages packageNamed: 'Base' ifAbsent: [ self assert: false ].
    packages packageNamed: 'Tests' ifAbsent: [ self assert: false ].
    packages
        remove:
            {'Base'.
            'Tests'}.
    packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    removed := false.
    packages packageNamed: 'Base' ifAbsent: [ removed := true ].
    self assert: removed.
    removed := false.
    packages packageNamed: 'Tests' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemoveGroupC
    "used by MetacelloAbstractVersionConstructor>>removeGroup:"

    | packages removed |
    packages := self packagesSpec.
    packages
        add:
            {(self groupSpec
                name: 'Platform';
                includes: 'Core';
                yourself).
            (self groupSpec
                name: 'Base';
                includes: 'Base';
                yourself).
            (self groupSpec
                name: 'Tests';
                includes: 'Tests';
                yourself)}.
    packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    packages packageNamed: 'Base' ifAbsent: [ self assert: false ].
    packages packageNamed: 'Tests' ifAbsent: [ self assert: false ].
    packages remove: 'Tests'.
    packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    packages packageNamed: 'Base' ifAbsent: [ self assert: false ].
    removed := false.
    packages packageNamed: 'Tests' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testMergeProjectA
	"used by MetacelloAbstractVersionConstructor>>project:with:"

	| packages project projectReferenceSpec referenceSpec |
	packages := self packagesSpec.
	project := self projectSpec
		name: 'Project';
		className: 'ConfigurationOfProjectA';
		versionString: #stable;
		loads: #('MyPackage' 'MyTests');
		preLoadDoIt: #preLoadDoItB;
		postLoadDoIt: #postLoadDoItB;
		yourself.
	referenceSpec := self project projectReferenceSpec
		name: project name;
		projectReference: project;
		yourself.
	packages add: referenceSpec.
	project := self projectSpec
		name: 'Project';
		className: 'ConfigurationOfProject';
		versionString: '1.0';
		operator: #<;
		loads: #('MyPackage');
		preLoadDoIt: #preLoadDoIt;
		postLoadDoIt: #postLoadDoIt;
		yourself.
	referenceSpec := self project projectReferenceSpec
		name: project name;
		projectReference: project;
		yourself.
	packages merge: referenceSpec.
	projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ].
	project := projectReferenceSpec referencedSpec.
	self assert: project name equals: 'Project'.
	self assert: project className equals: 'ConfigurationOfProject'.
	self assert: project versionString equals: '1.0'.
	self assert: project operator identicalTo: #<.
	self assert: project loads equals: #('MyPackage').
	self assert: project preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: project postLoadDoIt value identicalTo: #postLoadDoIt.
	project projectDo: [ :prjct | self assert: project identicalTo: prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testCopyToProject
	"used by MetacelloAbstractVersionConstructor>>project:copyFrom:with:"

	| packages project referenceSpec |
	packages := self packagesSpec.
	packages
		add:
			(self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProjectA';
				versionString: #stable;
				loads: #('MyPackage' 'MyTests');
				preLoadDoIt: #preLoadDoItB;
				postLoadDoIt: #postLoadDoItB;
				yourself).
	project := self projectSpec
		name: 'ProjectCopy';
		yourself.
	referenceSpec := self project projectReferenceSpec
		name: 'ProjectCopy';
		projectReference: project;
		yourself.
	packages copy: 'Project' to: referenceSpec.
	project := (packages packageNamed: 'ProjectCopy' ifAbsent: [ self assert: false ]) referencedSpec.
	self assert: project name equals: 'ProjectCopy'.
	self assert: project className equals: 'ConfigurationOfProjectA'.
	self assert: project versionString equals: #stable.
	self assert: project operator identicalTo: #>=.
	self assert: project loads equals: #('MyPackage' 'MyTests').
	self assert: project preLoadDoIt value identicalTo: #preLoadDoItB.
	self assert: project postLoadDoIt value identicalTo: #postLoadDoItB! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemoveGroupA
    "used by MetacelloAbstractVersionConstructor>>removeGroup:"

    | packages group removed |
    packages := self packagesSpec.
    packages
        add:
            (self groupSpec
                name: 'Platform';
                includes: 'Core';
                yourself).
    packages
        merge:
            (self groupSpec
                name: 'Platform';
                includes: 'Tests';
                yourself).
    group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    self assert: (group includes includes: 'Core').
    self assert: (group includes includes: 'Tests').
    packages
        remove:
            (self groupSpec
                name: 'Platform';
                includes: 'Core';
                yourself).
    removed := false.
    packages packageNamed: 'Platform' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testMergeGroupA
    "used by MetacelloAbstractVersionConstructor>>group:with:"

    | packages group |
    packages := self packagesSpec.
    packages
        add:
            (self groupSpec
                name: 'Platform';
                includes: 'Core';
                yourself).
    packages
        merge:
            (self groupSpec
                name: 'Platform';
                includes: 'Tests';
                yourself).
    group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    self assert: (group includes includes: 'Core').
    self assert: (group includes includes: 'Tests')! !

!MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: ''!
testCopyToGroup
    "not currently used by MetacelloAbstractVersionConstructor"

    | packages group |
    packages := self packagesSpec.
    packages
        add:
            (self groupSpec
                name: 'Platform';
                includes: 'Core';
                yourself).
    packages
        merge:
            (self groupSpec
                name: 'Platform';
                includes: 'Tests';
                yourself).
    group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ].
    self assert: (group includes includes: 'Core').
    self assert: (group includes includes: 'Tests').
    group := self groupSpec
        name: 'PlatformCopy';
        includes: 'Copy';
        yourself.
    packages copy: 'Platform' to: group.
    group := packages packageNamed: 'PlatformCopy' ifAbsent: [ self assert: false ].
    self assert: (group includes includes: 'Core').
    self assert: (group includes includes: 'Copy').
    self assert: (group includes includes: 'Tests')! !

!MetacelloPharo30Platform commentStamp: ''!
I'm here for backward compatibility. !
!MetacelloPharoCommonPlatform commentStamp: ''!
MetacelloPharoPlatform contains all Pharo specific code to load Metacello.!
!MetacelloPharoCommonPlatform methodsFor: 'reflection' stamp: ''!
copyClass: oldClass as: newName inCategory: newCategoryName
	| copysName class newDefinition |
	copysName := newName asSymbol.
	copysName = oldClass name
		ifTrue: [ ^ oldClass ].
	(Smalltalk globals includesKey: copysName)
		ifTrue: [ ^ self error: copysName , ' already exists' ].
	newDefinition := oldClass definition copyReplaceAll: '#' , oldClass name asString with: '#' , copysName asString printString.
	newDefinition := newDefinition
		copyReplaceAll: 'category: ' , (SystemOrganization categoryOfElement: oldClass name) asString printString
		with: 'category: ' , newCategoryName printString.
	class := self compiler logged: true; evaluate: newDefinition.
	class class instanceVariableNames: oldClass class instanceVariablesString.
	class copyAllCategoriesFrom: oldClass.
	class class copyAllCategoriesFrom: oldClass class.
	class category: newCategoryName.
	^ class! !

!MetacelloPharoCommonPlatform methodsFor: 'utilities' stamp: ''!
authorName: aString

	Author fullName: aString! !

!MetacelloPharoCommonPlatform methodsFor: 'github/bitbucket support' stamp: ''!
downloadJSON: url username: username pass: pass
	"return result of parsing JSON downloaded from url. username:pass may be nil, but calls will be subject to severe rate limits."

	| jsonFileName jsonFile errorFileName |
	jsonFileName := self
		tempFileFor: 'tags-' , self processPID
		suffix: 'json'.
	errorFileName := self
		downloadBasicFile: url
		to: jsonFileName
		username: username
		pass: pass.
	[ jsonFile := self fileHandleOn: jsonFileName.
	jsonFile containingDirectory
		readOnlyFileNamed: jsonFile localName
		do: [ :fileStream | 
			| result |
			result := (Smalltalk at: #MCFileTreeJsonParser)
				parseStream: fileStream self
				deleteFileNamed: errorFileName.
			^ result ] ]
		on: Error
		do: [ :ex | 
			self
				error:
					'Error during download (' , ex description , ') please check the file '
						, errorFileName printString , ' for error message.' ]! !

!MetacelloPharoCommonPlatform methodsFor: 'repository creation' stamp: ''!
createFiletreeRepository: aRepositorySpec
	MCRepository 
		findFiletreeAlternateFormat: aRepositorySpec
		ifFound: [ :repository | 
			^ repository createRepositoryFromSpec: aRepositorySpec on: self ].

	^ super createFiletreeRepository: aRepositorySpec! !

!MetacelloPharoCommonPlatform methodsFor: 'github support' stamp: ''!
extractRepositoryFrom: zipFile to: directory
    "unzip <zipFile> into <directory>"

    | out err proc errorMessage errorFileName |
    errorFileName := self downloadErrorFileNameFor: zipFile.
    out := ('/tmp/zip.out'asFileReference)
		ensureDelete;
		writeStream.
    err := (errorFileName asFileReference)
		ensureDelete;
		writeStream.
    errorMessage := ''.
    [ 
    proc := (self class environment at: #OSProcess) thisOSProcess
        forkJob: '/usr/bin/unzip'
        arguments:
            {'-u'.
            zipFile.
            '-d'.
            directory}
        environment: nil
        descriptors: (Array with: nil with: out with: err).
    proc ifNil: [ self noAccessorAvailable ].
    [ proc isRunning ] whileTrue: [ (Delay forMilliseconds: 100) wait ] ]
        ensure: [ 
            out close.
            err close ].
    errorFileName asFileReference
        binaryReadStreamDo: [ :fileStream | 
            (errorMessage := fileStream upToEnd) notEmpty
                ifTrue: [ self error: 'unzip failure: ' , errorMessage printString ]
                ifFalse: [
                    (self fileHandleOn: '/tmp')
                        deleteFileNamed: zipFile;
                        deleteFileNamed: errorFileName ] ]! !

!MetacelloPharoCommonPlatform methodsFor: 'notification' stamp: ''!
collection: aCollection do: aBlock displaying: aString

	self bypassProgressBars ifTrue: [ ^super collection: aCollection do: aBlock displaying: aString ].
	aCollection 
		do: aBlock
		displayingProgress: aString! !

!MetacelloPharoCommonPlatform methodsFor: 'github support' stamp: ''!
closeZipArchive: anArchive
	
	anArchive close! !

!MetacelloPharoCommonPlatform methodsFor: 'utilities' stamp: ''!
compiler
	^ Smalltalk compilerClass! !

!MetacelloPharoCommonPlatform methodsFor: 'notification' stamp: ''!
do: aBlock displaying: aString

    self bypassProgressBars ifTrue: [ ^ super do: aBlock displaying: aString ].
	
    aString
        displayProgressFrom: 0 to: 2
        during: [:bar |
            bar value: 1.
            aBlock value.
            bar value: 2 ]! !

!MetacelloPharoCommonPlatform methodsFor: 'utilities' stamp: ''!
timestamp

	^Date today mmddyyyy, ' ',
		((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! !

!MetacelloPharoCommonPlatform methodsFor: 'attributes' stamp: ''!
defaultPlatformAttributes
	| attributes versionString |
	((Smalltalk respondsTo: #image) and: [ Smalltalk image respondsTo: #metacelloPlatformAttributes ])
		ifTrue: [ ^ Smalltalk image metacelloPlatformAttributes ].
	attributes := OrderedCollection with: #squeakCommon with: #pharo.
	Smalltalk
		at: #SystemVersion
		ifPresent: [ :cl | 
			versionString := cl current version.
			(((versionString beginsWith: 'Pharo-1') or: [ versionString beginsWith: 'PharoCore1' ])
				or: [ versionString beginsWith: 'Pharo1' ])
				ifTrue: [ 
					attributes add: #'pharo1.x'.
					((versionString beginsWith: 'Pharo-1.0') or: [ versionString beginsWith: 'PharoCore1.0' ])
						ifTrue: [ attributes add: #'pharo1.0.x' ]
						ifFalse: [ 
							((versionString beginsWith: 'Pharo-1.1') or: [ versionString beginsWith: 'Pharo1.1' ])
								ifTrue: [ attributes add: #'pharo1.1.x' ]
								ifFalse: [ 
									((versionString beginsWith: 'Pharo-1.2') or: [ versionString beginsWith: 'Pharo1.2' ])
										ifTrue: [ attributes add: #'pharo1.2.x' ]
										ifFalse: [ 
											(versionString beginsWith: 'Pharo1.3')
												ifTrue: [ attributes add: #'pharo1.3.x' ] ] ] ] ] ].
	^ attributes! !

!MetacelloPharoCommonPlatform methodsFor: 'utilities' stamp: ''!
authorName
	^ Author fullName! !

!MetacelloPharoCommonPlatform methodsFor: 'repository creation' stamp: ''!
createFtpRepository: aRepositorySpec
 	| 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! !

!MetacelloPharoCommonPlatform methodsFor: 'git-based http repo support' stamp: ''!
downloadBasicFile: url to: outputFileName username: username pass: pass
	"download from <url> into <outputFileName>"

	| out err proc errorFileName args |
	"Make a unique name for the error log and ensure that we can write the files"
	errorFileName := self downloadErrorFileNameFor: outputFileName.
	out := (outputFileName asFileReference)
		ensureDelete;
		writeStream.
	err := (errorFileName asFileReference)
		ensureDelete;
		writeStream.
	args := username
		ifNotNil: [ {'-u' . (username , ':' , pass) . '-L' . url} ]
		ifNil: [ {'-L' . url} ].
	proc := (self class environment at: #OSProcess) thisOSProcess
		forkJob: '/usr/bin/curl'
		arguments: args
		environment: nil
		descriptors: (Array with: nil with: out with: err).
	proc ifNil: [ (self class environment at: #OSProcess) noAccessorAvailable ].
	[ proc isRunning ] whileTrue: [ (Delay forMilliseconds: 100) wait ].
	out close.
	err close.
	^ errorFileName! !

!MetacelloPharoCommonPlatform methodsFor: 'github support' stamp: ''!
downloadZipArchive: url to: outputFileName
	"download zip archive from <url> into <outputFileName>"

	| archive zipfile errorFileName |
	errorFileName := self
		downloadBasicFile: url
		to: outputFileName
		username: nil
		pass: nil.
	archive := ZipArchive new.
	zipfile := self fileHandleOn: outputFileName.
	zipfile containingDirectory
		readOnlyFileNamed: zipfile localName
		do: [ :fileStream | 
			[ archive readFrom: fileStream ]
				on: Error
				do: [ :ex | 
					self
						error:
							'Error during download (' , ex description , ') please check the file '
								, errorFileName printString , ' for error message.' ] ].
	self deleteFileNamed: errorFileName.
	^ archive! !

!MetacelloPharoCommonPlatform methodsFor: 'repository creation' stamp: ''!
extractTypeFromDescription: description

	(description beginsWith: 'ftp://') ifTrue: [ ^'ftp' ].
	^super extractTypeFromDescription: description! !

!MetacelloPharoCommonPlatform methodsFor: 'file system' stamp: ''!
deleteFileNamed: filePath
	filePath asFileReference ensureDelete! !

!MetacelloPharoPlatform commentStamp: ''!
Class used to abstract specific code for the Pharo platform.
!
!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
directoryFromPath: adirectoryPath relativeTo: anotherDirectoryPath
	"Get a handle on the following path: anotherDirectoryPath/adirectoryPath"
	^ anotherDirectoryPath resolveString: adirectoryPath! !

!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
recursiveDelete: aDirectory
	"delete this directory and all children of it"

	^  aDirectory deleteAll! !

!MetacelloPharoPlatform methodsFor: 'system' stamp: ''!
selectorForPragma: aPragma
	^ aPragma methodSelector! !

!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
fileHandleOn: aPath
	"Get an handle on a file."

	^ aPath asFileReference! !

!MetacelloPharoPlatform methodsFor: 'github/bitbucket support' stamp: ''!
downloadJSON: url username: username pass: pass
  "return result of parsing JSON downloaded from url. username:pass may be nil, but calls will be subject to severe rate limits."

  | client json |
  client := ZnClient new
    url: url;
    yourself.
  username ifNotNil: [ client username: username password: pass ].
  client get.
  json := client contents.
  ^ STON fromString: json! !

!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
fileFromPath: aFileName relativeTo: aDirectoryPath
	"Get a handle on the following path: anotherDirectoryPath/aFileName"
	^ aDirectoryPath / aFileName! !

!MetacelloPharoPlatform methodsFor: 'github support' stamp: ''!
extractRepositoryFrom: zipFile to: directory
    "unzip <zipFile> into <directory>"
	ZipArchive new 
		readFrom:  zipFile;
		extractAllTo: directory asFileReference.
	zipFile asFileReference delete.! !

!MetacelloPharoPlatform methodsFor: 'pharo 2.0 compat' stamp: ''!
packageInfoFor: aMCWorkingCopy
  "MCPackageManager>>packageInfo is deprecated in Pharo2.0"

  ^ aMCWorkingCopy packageSet! !

!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
defaultDirectory
	"Get the image default directory"
	
	^FileLocator imageDirectory asFileReference! !

!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
fileDirectoryClass
	^FileSystem! !

!MetacelloPharoPlatform methodsFor: 'utilities' stamp: ''!
compiler
	^ self class compiler! !

!MetacelloPharoPlatform methodsFor: 'pharo 2.0 compat' stamp: ''!
registerPackageNamed: packageName
  "PackageInfo deprecated in Pharo3.0"

  ^RPackageSet named: packageName! !

!MetacelloPharoPlatform methodsFor: 'monticello' stamp: ''!
newVersionForWorkingCopy: aWorkingCopy
	^aWorkingCopy newVersionIn: aWorkingCopy repositoryGroup! !

!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
tempFileFor: aName suffix: aSuffixString
	^ (FileLocator temp asFileReference
		/ (FileReference newTempFilePrefix: aName suffix: aSuffixString) basename)
		fullName! !

!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
ensureDirectoryExists: aDirectoryHandle
	"Ensure the directory exists."

	^ aDirectoryHandle ensureCreateDirectory ; yourself! !

!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
readStreamOn: aFileHandle do: aBlock
	"Get a read stream on the file handle and execute some actions on it."
	^ aFileHandle readStreamDo: aBlock! !

!MetacelloPharoPlatform methodsFor: 'system' stamp: ''!
suspendSystemUpdateEventsDuring: aBlock
	"Wraps call to the system evetn manager to tell it that we want to suspend events during execution of aBlock"
	"From Pharo2, we cannot suspend system events since missing events brak the image (rpackage at least should be notified."
	"SystemAnnouncer uniqueInstance suspendAllWhile: aBlock"
	^ aBlock value! !

!MetacelloPharoPlatform methodsFor: 'scripting' stamp: ''!
defaultRepositoryDescription
  ^ 'http://smalltalkhub.com/mc/Pharo/MetaRepoForPharo30/main'! !

!MetacelloPharoPlatform methodsFor: 'utilities' stamp: ''!
string: aString includesSubstring: aSubstring
	"abstract String>>includesSubstring: to have the same message on all supported platforms."

	^aString includesSubstring: aSubstring! !

!MetacelloPharoPlatform methodsFor: 'github support' stamp: ''!
downloadZipArchive: url to: outputFileName
	"download zip archive from <url> into <outputFileName>"

	outputFileName asFileReference ensureDelete.
	[ :bar | 
	bar title: 'Download: ' , url asString , ' to ' , outputFileName.
	[ ZnClient new
		url: url;
		signalProgress: true;
		downloadTo: outputFileName ]
		on: HTTPProgress
		do: [ :progress | 
			progress isEmpty
				ifFalse: [ bar current: progress percentage ].
			progress resume ] ] asJob run.
	^ ZipArchive new readFrom: outputFileName asFileReference! !

!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
parentDirectoryOf: aFileHandler
	"Get the parent directory of this file."
	
	^ aFileHandler parent! !

!MetacelloPharoPlatform methodsFor: 'file system' stamp: ''!
deleteFileNamed: filePath
	filePath asFileReference delete! !

!MetacelloPharoPlatform class methodsFor: 'initialize-release' stamp: ''!
initialize
  self select! !

!MetacelloPlatform methodsFor: 'accessing' stamp: ''!
bypassProgressBars

	bypassProgressBars == nil ifTrue: [ bypassProgressBars := false ].
	^ bypassProgressBars! !

!MetacelloPlatform methodsFor: 'system' stamp: ''!
selectorForPragma: aPragma
	^ aPragma selector! !

!MetacelloPlatform methodsFor: 'caching' stamp: ''!
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: 'github/bitbucket support' stamp: ''!
processPID
  "return pid of process as string if available"

  ^ ''! !

!MetacelloPlatform methodsFor: 'file system' stamp: ''!
fileHandleOn: aPath
	"Get an handle on a file."

	^ self fileDirectoryClass on: aPath! !

!MetacelloPlatform methodsFor: 'github/bitbucket support' stamp: ''!
downloadJSON: url username: username pass: pass
  "return result of parsing JSON downloaded from url. username:pass may be nil, but calls will be subject to severe rate limits."

  self subclassResponsibility! !

!MetacelloPlatform methodsFor: 'notification' stamp: ''!
collection: aCollection do: aBlock displaying: aString

	aCollection do: aBlock! !

!MetacelloPlatform methodsFor: 'accessing' stamp: ''!
bypassGoferLoadUpdateCategories

	bypassGoferLoadUpdateCategories == nil ifTrue: [ bypassGoferLoadUpdateCategories := false ].
	^ bypassGoferLoadUpdateCategories! !

!MetacelloPlatform methodsFor: 'git support' stamp: ''!
gitCommitShaFor: aDirectory
  "return SHA for git repository located at <aDirectory>, if <aDirectory> is not a git repository, return nil"

  ^ nil! !

!MetacelloPlatform methodsFor: 'file system' stamp: ''!
tempFileFor: aName suffix: aSuffixString
	^ '/tmp/' , aName , aSuffixString! !

!MetacelloPlatform methodsFor: 'notification' stamp: ''!
do: aBlock displaying: aString

	aBlock value! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
createTonelRepository: aRepositorySpec
	| cl description headerSize |
	
	cl := Smalltalk at: #'TonelRepository'.
	description := aRepositorySpec description.
	headerSize := (aRepositorySpec type, '://') size.
 	^ cl new 
		directory: (self fileHandleOn: (aRepositorySpec description 
			copyFrom: headerSize + 1 
			to: description size));
		yourself! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
createHttpRepository: aRepositorySpec
	^ MCHttpRepository
        location: aRepositorySpec description
        user: aRepositorySpec username
        password: aRepositorySpec password! !

!MetacelloPlatform methodsFor: 'package cache' stamp: ''!
clearPackageCache
  "make sure that the package cache is empty, by hook or by crook"

  | cache dir |
  cache := self defaultPackageCache.
  cache flushCache.	"GemStone and Pharo1.4"
  dir := cache directory.
  dir ~~ nil
    ifTrue: [ 
      "delete directory - Squeak and Pharo"
      [ self recursiveDelete: dir ]
        on: Error
        do: [ :ignore |  ] ]! !

!MetacelloPlatform methodsFor: 'attributes' stamp: ''!
defaultPlatformAttributes
  | versionString |
  Smalltalk
    at: #'SystemVersion'
    ifPresent: [ :cl | 
      versionString := cl current version.
      (versionString beginsWith: 'Pharo')
        ifTrue: [ ^ #(#'squeakCommon' #'pharo') ].
      (versionString beginsWith: 'Squeak')
        ifTrue: [ ^ #(#'squeakCommon' #'squeak') ].	"see http://code.google.com/p/metacello/issues/detail?id=146"
      (self string: versionString includesSubstring: 'Pharo')
        ifTrue: [ ^ #(#'squeakCommon' #'pharo') ].
      (self string: versionString includesSubstring: 'Squeak')
        ifTrue: [ ^ #(#'squeakCommon' #'squeak') ].
      self error: 'Unrecognized version of Squeak/Pharo: ' , versionString ].
  ^ #(#'gemstone')! !

!MetacelloPlatform methodsFor: 'utilities' stamp: ''!
authorName

	Smalltalk at: #Author ifPresent: [:cl | ^cl perform: #initials ].
	^'no developer initials'! !

!MetacelloPlatform methodsFor: 'tests' stamp: ''!
disableUndefinedSybolUpdates
  "noop for most platforms - needed for GemStone"

  ^ nil! !

!MetacelloPlatform methodsFor: 'github/bitbucket support' stamp: ''!
downloadErrorFileNameFor: zipFileName
  | pid |
  pid := self processPID.
  ^ '/tmp/curl-' , pid , '-' , (zipFileName select: [ :c | c isAlphaNumeric ])
    , '.err'! !

!MetacelloPlatform methodsFor: 'accessing' stamp: ''!
bypassProgressBars: anObject
	bypassProgressBars := anObject! !

!MetacelloPlatform methodsFor: 'tests' stamp: ''!
reenableUndefinedSybolUpdates: undefinedSymbols
  "noop for most platforms - needed for GemStone"! !

!MetacelloPlatform methodsFor: 'utilities' stamp: ''!
string: aString includesSubstring: aSubstring
	"abstract String>>includesSubstring: to have the same message on all supported platforms."

	^aString includesSubString: aSubstring! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
createRepository: aRepositorySpec

	^ MCRepository 
		newRepositoryFromSpec: aRepositorySpec
		on: self! !

!MetacelloPlatform methodsFor: 'git support' stamp: ''!
gitBranchNameFor: aDirectory
  "return current branch for git repository located at <aDirectory>, if <aDirectory> is not a git repository, return nil"

  ^ nil! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
createDictionaryRepository: aRepositorySpec
	| description headerSize globalName |
 
	description := aRepositorySpec description.
	headerSize := 'dictionary://' size.
	globalName := (description copyFrom: headerSize + 1 to: description size) asSymbol.
   
	^ Smalltalk
 		at: globalName
 		ifAbsent: [ 
          Smalltalk
            at: globalName
            put: (MCDictionaryRepository new
					description: description;
					yourself) ]! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
createGithubRepository: aRepositorySpec
	| cl |
	
	cl := Smalltalk at: #'MCGitHubRepository'.
	^ cl location: aRepositorySpec description! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
createDirectoryRepository: aRepositorySpec
	^ MCDirectoryRepository new
		directory: (self fileHandleOn: aRepositorySpec description);
		yourself! !

!MetacelloPlatform methodsFor: 'caching' stamp: ''!
primeStackCacheWith: aDictionary doing: noArgBlock

	self 
		useStackCacheDuring: [:dict | ^noArgBlock value ] 
		defaultDictionary: aDictionary! !

!MetacelloPlatform methodsFor: 'caching' stamp: ''!
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: 'github/bitbucket support' stamp: ''!
fileDirectoryClass
	^ Smalltalk at: #FileDirectory! !

!MetacelloPlatform methodsFor: 'accessing' stamp: ''!
bypassGoferLoadUpdateCategories: anObject
	bypassGoferLoadUpdateCategories := anObject! !

!MetacelloPlatform methodsFor: 'system' stamp: ''!
suspendSystemUpdateEventsDuring: aBlock
	"Wraps call to the system evetn manager to tell it that we want to suspend events during execution of aBlock"
	(Smalltalk at: #SystemChangeNotifier) uniqueInstance doSilently: aBlock! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
extractTypeFromDescription: description
  description == nil
    ifTrue: [ ^ nil ].
  ((description beginsWith: '/') or: [ description second = $: ])
    ifTrue: [ ^ 'directory' ].
  (description beginsWith: 'dictionary://')
    ifTrue: [ ^ 'dictionary' ].
  (description beginsWith: 'filetree://')
    ifTrue: [ ^ 'filetree' ].
  (description beginsWith: 'tonel://')
    ifTrue: [ ^ 'tonel' ].
  (description beginsWith: 'github://')
    ifTrue: [ ^ 'github' ].
  (description beginsWith: 'gitorious://')
    ifTrue: [ ^ 'gitorious' ].
  (description beginsWith: 'bitbucket://')
    ifTrue: [ ^ 'bitbucket' ].
  ^ 'http'! !

!MetacelloPlatform methodsFor: 'file system' stamp: ''!
parentDirectoryOf: aFileHandler
	"Get the parent directory of this file."
	
	^ aFileHandler containingDirectory! !

!MetacelloPlatform methodsFor: 'reflection' stamp: ''!
copyClass: oldClass as: newName inCategory: newCategoryName

	self subclassResponsibility! !

!MetacelloPlatform methodsFor: 'file system' stamp: ''!
directoryFromPath: adirectoryPath relativeTo: anotherDirectoryPath
	"Get a handle on the following path: anotherDirectoryPath/adirectoryPath"
	^ anotherDirectoryPath directoryNamed: adirectoryPath! !

!MetacelloPlatform methodsFor: 'utilities' stamp: ''!
authorName: aString
	"Primarily used for testing"

	self subclassResponsibility! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
createFiletreeRepository: aRepositorySpec
	| cl description headerSize |
	
	cl := Smalltalk at: #'MCFileTreeRepository'.
	description := aRepositorySpec description.
 	headerSize := 'filetree://' size.
	^ cl new 
		directory: (self fileHandleOn: (aRepositorySpec description 
			copyFrom: headerSize + 1 
			to: description size));
		yourself! !

!MetacelloPlatform methodsFor: 'github/bitbucket support' stamp: ''!
extractRepositoryFrom: zipFile to: directory
    "unzip <zipFile> into <directory>"

    self subclassResponsibility! !

!MetacelloPlatform methodsFor: '*Iceberg-Metacello-Integration' stamp: ''!
withMetacelloLoadSessionDo: aBlock 

	aBlock value! !

!MetacelloPlatform methodsFor: 'user interaction' stamp: ''!
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: 'file system' stamp: ''!
defaultDirectory
	"Get the image default directory"
	
	^self fileDirectoryClass default! !

!MetacelloPlatform methodsFor: 'package cache' stamp: ''!
defaultPackageCache
  "Apparently the MCCacheRepository api is changing in Pharo"

  ^ MCCacheRepository default! !

!MetacelloPlatform methodsFor: 'github/bitbucket support' stamp: ''!
closeZipArchive: anArchive
	"do nothing"! !

!MetacelloPlatform methodsFor: 'monticello' stamp: ''!
newVersionForWorkingCopy: aWorkingCopy
  ^ aWorkingCopy newVersion! !

!MetacelloPlatform methodsFor: 'utilities' stamp: ''!
timestamp

	^DateAndTime now printString! !

!MetacelloPlatform methodsFor: 'scripting' stamp: ''!
defaultRepositoryDescription
    ^ 'http://www.squeaksource.com/MetacelloRepository'! !

!MetacelloPlatform methodsFor: 'caching' stamp: ''!
stackCacheFor: cacheName at: key doing: aBlock

	^self stackCacheFor: cacheName cacheClass: Dictionary at: key doing: aBlock! !

!MetacelloPlatform methodsFor: 'github/bitbucket support' stamp: ''!
downloadZipArchive: url to: outputFileName
  "download zip archive from <url> into <outputFileName>"

  self subclassResponsibility! !

!MetacelloPlatform methodsFor: 'file system' stamp: ''!
deleteFileNamed: filePath
	(self fileDirectoryClass on: filePath) containingDirectory deleteFileNamed: (self fileDirectoryClass localNameFor: filePath)! !

!MetacelloPlatform methodsFor: 'transactions' stamp: ''!
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: 'file system' stamp: ''!
recursiveDelete: aDirectory
	"delete this directory and all children of it"

	^  aDirectory recursiveDelete! !

!MetacelloPlatform methodsFor: 'reflection' stamp: ''!
globalNamed: globalName

	^Smalltalk at: globalName! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
packageInfoFor: aMCWorkingCopy
  ^ aMCWorkingCopy packageInfo! !

!MetacelloPlatform methodsFor: 'github/bitbucket support' stamp: ''!
downloadJSON: url eTagsCache: eTagsCache eTagsKey: eTagsKey username: username pass: pass
  "return result of parsing JSON downloaded from url. username:pass may be nil, but calls will be subject to severe rate limits."

  "To minimize GitHub rate limiting problems, we are caching the ETags for the tag request: https://developer.github.com/v3/#conditional-requests"

  ^ self downloadJSON: url username: username pass: pass! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
registerPackageNamed: packageName
  ^ (Smalltalk at: #'PackageInfo') registerPackageName: packageName! !

!MetacelloPlatform methodsFor: 'caching' stamp: ''!
clearCurrentVersionCache
	MetacelloClearStackCacheNotification signal: #(#currentVersion #currentVersionAgainst: #currentVersionInfo)! !

!MetacelloPlatform methodsFor: 'file system' stamp: ''!
ensureDirectoryExists: aDirectoryHandle
	"Ensure the directory exists."

	^ aDirectoryHandle assureExistence ; yourself! !

!MetacelloPlatform methodsFor: 'file system' stamp: ''!
readStreamOn: aFileHandle do: aBlock
	"Get a read stream on the file handle and execute some actions on it."
	| stream |
	stream := aFileHandle readStream.
	^ [ aBlock value: stream ] 
		ensure: [ stream close ]! !

!MetacelloPlatform methodsFor: 'repository creation' stamp: ''!
createBitbucketRepository: aRepositorySpec
	| cl |
	
	cl := Smalltalk at: #'MCBitbucketRepository'.
 	^ cl location: aRepositorySpec description! !

!MetacelloPlatform methodsFor: 'reflection' stamp: ''!
globalNamed: globalName ifAbsent: absentBlock

	^Smalltalk at: globalName ifAbsent: absentBlock! !

!MetacelloPlatform class methodsFor: 'initialize-release' stamp: ''!
initialize
  "noop ... use #select"! !

!MetacelloPlatform class methodsFor: 'accessing' stamp: ''!
current
	Current
		ifNil: [Current := MetacelloPlatform new].
	^ Current! !

!MetacelloPlatform class methodsFor: 'initialize-release' stamp: ''!
unselect
  MetacelloPlatform current class = self
    ifTrue: [ Current := nil ]! !

!MetacelloPlatform class methodsFor: 'initialize-release' stamp: ''!
select
  Current := self new! !

!MetacelloPlatformTestCase methodsFor: 'tests' stamp: ''!
testTempFileFor
	"This should be enough to ensure that https://github.com/dalehenrich/metacello-work/issues/405 doesn't happen again"
	| tempFilePath |

	tempFilePath := MetacelloPlatform current tempFileFor: 'xxx' suffix: '.test'.! !

!MetacelloPostLoadDirective methodsFor: 'actions' stamp: ''!
addTo: aLoaderDirective

	spec postLoadDoIt value ~~ nil ifTrue: [ aLoaderDirective add: self ]! !

!MetacelloPostLoadDirective methodsFor: 'actions' stamp: ''!
loadUsing: aLoaderDirective gofer: aGofer

	aLoaderDirective loadPostloadDirective: self.! !

!MetacelloPostLoadDirective methodsFor: 'actions' stamp: ''!
postLoadDo: aBlock

	aBlock value: self! !

!MetacelloPostLoadDirective methodsFor: 'printing' stamp: ''!
label

	^super label, ' >> ', self spec postLoadDoIt value asString! !

!MetacelloPostLoadDirective methodsFor: 'accessing' stamp: ''!
title

	^'postload'! !

!MetacelloPreLoadDirective methodsFor: 'actions' stamp: ''!
addTo: aLoaderDirective

	spec preLoadDoIt value ~~ nil ifTrue: [ aLoaderDirective add: self ]! !

!MetacelloPreLoadDirective methodsFor: 'actions' stamp: ''!
loadUsing: aLoaderDirective gofer: aGofer

	aLoaderDirective loadPreloadDirective: self.! !

!MetacelloPreLoadDirective methodsFor: 'actions' stamp: ''!
preLoadDo: aBlock

	aBlock value: self! !

!MetacelloPreLoadDirective methodsFor: 'printing' stamp: ''!
label

	^super label, ' >> ', self spec preLoadDoIt value asString! !

!MetacelloPreLoadDirective methodsFor: 'accessing' stamp: ''!
title

	^'preload'! !

!MetacelloPrePostLoadDirective methodsFor: 'enumerating' stamp: ''!
prepostLoadDirectivesDo: aBlock

	aBlock value: self! !

!MetacelloPrePostLoadDirective methodsFor: 'enumerating' stamp: ''!
prepostLoadDo: aBlock

	aBlock value: self! !

!MetacelloPrePostLoadDirective methodsFor: 'actions' stamp: ''!
evaluateSupplyingAnswers: loadBlock

	| answers |
	(answers := self spec answers) notEmpty
		ifTrue: [ loadBlock valueSupplyingMetacelloAnswers: answers ]
		ifFalse: [ loadBlock value]! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
errorMap
	^ errorMap! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
hasVersion: versionString

	self version: versionString ifAbsent: [ ^false ].
	^true! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
currentVersionAgainst: resolvedPackageAndProjectNames

	| cacheKey |

	cacheKey := resolvedPackageAndProjectNames
		ifNil: [ Array with: self configuration class with: nil ]
		ifNotNil: [ 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
						ifNil: [ version spec isPartiallyCurrent ]
						ifNotNil: [ 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
								ifNil: [ cv := version copy.
									cv versionStatus: matchStatus.
									latestSomethingLoaded := cv
									]
							]
					].
			latestSomethingLoaded ifNotNil: [ ^ cache at: cacheKey put: latestSomethingLoaded ].
			^ cache at: cacheKey put: nil
			]! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
groupSpec

	^self groupSpecClass for: self! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
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: 'spec classes' stamp: ''!
projectSpec

	^self projectSpecClass for: self! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
valueHolderSpecClass

	^MetacelloValueHolderSpec! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
configuration
	^ configuration! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
loadType: aSymbol
	"#atomic or #linear"

	loadType := aSymbol! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
latestVersion: blessing

	^(self map values select: [:version | blessing = version blessing ]) detectMax: [:version | version ]! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
loadType
	"#atomic or #linear"

	loadType == nil ifTrue: [ ^#atomic ].
	^loadType! !

!MetacelloProject methodsFor: 'private' stamp: ''!
projectAttributes: aList

	projectAttributes := aList! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
groupSpecClass

	^MetacelloGroupSpec! !

!MetacelloProject methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForVersionsFor: aStep
	<stSpotterOrder: 1>
	self flag: #maybeRewriteForDirectStreaming.
	aStep listProcessor
		title: 'Versions';
		allCandidates: [
			(#( stableVersion currentVersion bleedingEdge development ) 
				collect: [ :each | [ self perform: each ] on: Error do: [  nil ] ]) 
				reject: [ :each | each isNil ] ];
		itemName: [ :version | version versionString ];
		filter: StFilterSubstring;
		wantsToDisplayOnEmptyQuery: true! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
loader: aLoader

	loader := aLoader! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
baselineOfProjectSpec
    ^ self baselineOfProjectSpecClass for: self! !

!MetacelloProject methodsFor: 'private' stamp: ''!
projectPlatformAttributes

	| list aBlock |
	list := OrderedCollection new.
	(aBlock := self projectAttributes) ~~ nil 
		ifTrue: [ list addAll: aBlock value ].
	^self defaultPlatformAttributes, list! !

!MetacelloProject methodsFor: 'private' stamp: ''!
defaultPlatformAttributes

	^ MetacelloPlatform current defaultPlatformAttributes! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
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: 'accessing' stamp: ''!
label

	^self configuration class name! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
loader

	^loader! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
version: aVersionString ifAbsent: aBlock

	^[ self version: aVersionString ] on: MetacelloVersionDoesNotExistError do: [:ex | aBlock value ].! !

!MetacelloProject methodsFor: 'private' stamp: ''!
lookupVersion: aVersionString ifAbsent: aBlock
    "please use version:...this is a private method"

    ^ self map
        at: aVersionString
        ifAbsent: [ 
            (MetacelloVersionDefinitionError project: self project versionString: aVersionString)
                exception: (self errorMap at: aVersionString ifAbsent: [ ^ aBlock value ]);
                signal ]! !

!MetacelloProject methodsFor: 'scripting' stamp: ''!
projectForScriptEngine: aMetacelloScriptEngine
    ^ self projectForScriptEngine: aMetacelloScriptEngine unconditionalLoad: false! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
development

	^self version: #development! !

!MetacelloProject methodsFor: 'private' stamp: ''!
sortedAndFilteredVersions

		^(self map values asArray sort: [:a :b | a >= b ]) select: [:vrsn | (#(structural broken baseline) includes: vrsn blessing) not ].! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
configuration: anObject
	configuration := anObject! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
defaultBlessing

	^#release! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
latestVersionMatching: versionPatternString includedBlessings: included

	^self 
		latestVersionMatching: versionPatternString 
		includedBlessings: included
		excludedBlessings: self excludeFromLatestVersion! !

!MetacelloProject methodsFor: 'loading' stamp: ''!
load: aVersionString

	^(self version: aVersionString) load! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
symbolicVersionMap

	^symbolicVersionMap! !

!MetacelloProject methodsFor: 'private' stamp: ''!
projectAttributes

	projectAttributes ~~ nil ifTrue: [ ^projectAttributes ].
	^#()! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
versionSpecClass

	^MetacelloVersionSpec! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
configurationOfProjectSpecClass
    ^ self subclassResponsibility! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
latestVersionMatching: versionPatternString excludedBlessings: excluded

	^self 
		latestVersionMatching: versionPatternString 
		includedBlessings: #()
		excludedBlessings: excluded! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
versionNumberClass
    versionNumberClass ifNil: [ versionNumberClass := MetacelloVersionNumber ].
    ^ versionNumberClass! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
baselineOfVersionSpecClass
    ^ self subclassResponsibility! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
projectReferenceSpecClass

	^MetacelloProjectReferenceSpec! !

!MetacelloProject methodsFor: 'private' stamp: ''!
platformAttributes

	 ^self projectPlatformAttributes! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
defaultLoaderClass

	^MetacelloSpecLoader! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
errorMap: anObject
    errorMap ifNil: [ errorMap := Dictionary new ].
    errorMap := anObject! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
map: aDictionary

	versionMap := aDictionary! !

!MetacelloProject methodsFor: 'printing' stamp: ''!
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: 'private' stamp: ''!
excludeFromLatestVersion

	^#(structural development broken baseline)! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
versionNumberClass: aClass
    versionNumberClass := aClass! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
projectSpecClass
    ^ MetacelloProjectSpec! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
stableVersion

	^self version: #stable! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
latestVersionMatching: versionPatternString includedBlessings: included excludedBlessings: excludedBlessings

	| excluded |
	excluded := excludedBlessings asSet copy.
	excluded removeAllFoundIn: included.
	^(self map values select: [:version |
		(included isEmpty or: [ included includes: version blessing ]) 
			and: [ (excluded includes: version blessing) not 
				and: [ version versionNumber match: versionPatternString ]]])
		detectMax: [:version | version ]! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
valueHolderSpec

	^self valueHolderSpecClass for: self! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
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: 'accessing' stamp: ''!
symbolicVersionMap: aDictionary

	symbolicVersionMap := aDictionary! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
map
	versionMap ifNil: [ ^ Dictionary new ].
	^ versionMap! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
baselineOfProjectSpecClass
    ^ self subclassResponsibility! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
projectReferenceSpec

	^self projectReferenceSpecClass for: self! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
version: aVersionString
    
    aVersionString isSymbol
        ifTrue: [ 
            | symbolicVersionString |
            symbolicVersionString := self symbolicVersionMap
                at: aVersionString
                ifAbsent: [ (MetacelloSymbolicVersionDoesNotExistError project: self project versionString: aVersionString) signal ].
            symbolicVersionString == #'notDefined'
                ifTrue: [ (MetacelloSymbolicVersionNotDefinedError project: self project versionString: aVersionString) signal ].
            ^ self
                lookupVersion: symbolicVersionString
                ifAbsent: [ (MetacelloSymbolicVersionDoesNotExistError project: self project versionString: symbolicVersionString) signal ] ].
    ^ self
        lookupVersion: aVersionString
        ifAbsent: [ (MetacelloVersionDoesNotExistError project: self project versionString: aVersionString) signal ]! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
versions

	^self map values asArray sort: [:a :b | a <= b ]! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
lastVersion

	| coll |
	coll := (self map values asArray sort: [:a :b | a <= b ]) asOrderedCollection.
	coll isEmpty ifTrue: [ ^nil ].
	^coll last! !

!MetacelloProject methodsFor: 'private' stamp: ''!
pragmaKeywords

	^#(version:attribute: blessing:attribute: description:attribute: required:attribute: groups:attribute: doits:attribute:)! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
loaderClass: aMetacelloSpecLoader

	loaderClass := aMetacelloSpecLoader! !

!MetacelloProject methodsFor: 'accessing' stamp: ''!
project

	^self! !

!MetacelloProject methodsFor: 'private' stamp: ''!
attributes

	^(OrderedCollection with: #common)
		addAll: self platformAttributes;
		yourself! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
loaderClass

	loaderClass == nil ifTrue: [ loaderClass := self defaultLoaderClass ].
	^loaderClass! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
packagesSpec

	^self packagesSpecClass for: self! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
packagesSpecClass

	^MetacelloPackagesSpec! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
bleedingEdge

	^self version: #bleedingEdge! !

!MetacelloProject methodsFor: 'versions' stamp: ''!
symbolicVersionSymbols

	^self symbolicVersionMap keys asArray sort: [:a :b | a <= b ]! !

!MetacelloProject methodsFor: 'scripting' stamp: ''!
projectForScriptEngine: aMetacelloScriptEngine unconditionalLoad: aBool
    ^ self subclassResponsibility! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
configurationOfProjectSpec
    ^ self configurationOfProjectSpecClass for: self! !

!MetacelloProject methodsFor: 'spec classes' stamp: ''!
versionSpec

	^self versionSpecClass for: self! !

!MetacelloProject class methodsFor: 'instance creation' stamp: ''!
new

	| inst |
	inst := self basicNew.
	^inst configuration: inst; yourself! !

!MetacelloProject class methodsFor: 'instance creation' stamp: ''!
on: aConfig

	^self basicNew configuration: aConfig; yourself! !

!MetacelloProject class methodsFor: 'accessing' stamp: ''!
versionConstructorClass
    ^ MetacelloVersionConstructor! !

!MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: ''!
version07: spec 
	<version: '0.7' imports: #('0.7-baseline' )>
	
	spec for: #common do: [
		spec blessing: #release.
		
		spec 
			package: 'Project-Core' with: 'Project-Core-anon.1';
			package: 'Project-Tests' with: 'Project-Tests-anon.1';
			package: 'Example-Core' with: 'Example-Core-anon.12';
			package: 'Example-Tests' with: 'Example-Tests-anon.3';
			package: 'Example-AddOn' with: 'Example-AddOn-anon.1'.].! !

!MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson10
"   [ see method: #baseline10: #version10: ]
In lesson07 it was obvious that we copied the configuration information from 
MetacelloTutorialConfig and adapted it to our project.

There is a better way.

In #baseline10: we've created a project reference for the Example project.

The #className: specifies the name of the class that contains the project metadata. If 
the class is not present in the image, then we know that we need to load the 
configuration for the project.

The #file: and #repository: specifications give us the information needed to load the 
project metadata from a repository.

Finally, the #versionString: and #loads: tell us which version of the project to load 
and which packages to load from the project.

We've named the project reference 'Example ALL' and in the specification for the 
'Project-Core' package, we've specified that 'Example ALL' is required:

  (MetacelloProjectRefTutorialConfig project version: '1.0') load.

Note that the entire Example project is loaded before 'Project-Core'
"! !

!MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: ''!
version11: spec 
	<version: '1.1' imports: #('1.1-baseline' )>
	
	spec for: #common do: [
		spec blessing: #beta.
		
		spec 
			package: 'Project-Core' with: 'Project-Core-anon.1';
			package: 'Project-Tests' with: 'Project-Tests-anon.1'.].! !

!MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson12
"   [ see method: #baseline11: #baseline12: #version12: ]
In #baseline11: there is redundant information for each of the project references. 

In #baseline12: we use the #project:copyFrom:with: method to eliminate the need to 
specify the bulk of the project information twice. 

Evaluate and compare the results of the following expressions:
 
  (MetacelloProjectRefTutorialConfig project version: '1.1') load: 'Project-Core'.
  (MetacelloProjectRefTutorialConfig project version: '1.2') load: 'Project-Core'.

  (MetacelloProjectRefTutorialConfig project version: '1.1') load: 'Project-Tests'.
  (MetacelloProjectRefTutorialConfig project version: '1.2') load: 'Project-Tests'.

"! !

!MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: ''!
version10: spec 
	<version: '1.0' imports: #('1.0-baseline' )>
	
	spec for: #common do: [
		spec blessing: #beta.
		
		spec 
			package: 'Project-Core' with: 'Project-Core-anon.1';
			package: 'Project-Tests' with: 'Project-Tests-anon.1'.].! !

!MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson11
"   [ see method: #baseline11: #version11: ]
As is often the case, it is useful to separate the test package from the core packages 
for a project. 

In #baseline11: we've created two project references. The reference named 
'Example Default' loads the 'default' group and the reference named 'Example Tests' 
loads the 'Tests' group.

We then made 'Project-Core' require 'Example Default' and 'Project-Tests' requires 
'Project-Core' and 'Example Tests'.

Now it is possible to load just the core packages:

  (MetacelloProjectRefTutorialConfig project version: '1.1') load: 'Project-Core'.

or the whole enchilada including tests:

  (MetacelloProjectRefTutorialConfig project version: '1.1') load: 'Project-Tests'.

"! !

!MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: ''!
version13: spec 
	<version: '1.3' imports: #('1.2-baseline' )>
	
	spec for: #common do: [
		spec blessing: #beta.
		spec description: 'Import functionality from the example project, different packages'.

		spec 
			package: 'Project-Core' with: 'Project-Core-anon.1';
			package: 'Project-Tests' with: 'Project-Tests-anon.1';
			project: 'Example Default' with: '1.3';
			project: 'Example Tests' with: '1.3'].! !

!MetacelloProjectRefTutorialConfig methodsFor: 'baselines' stamp: ''!
baseline14: spec 
	<version: '1.4-baseline' imports: #('1.2-baseline' )>
	
	spec for: #common do: [
		spec description: 'Add groups and Project-Extra, extending 1.2-baseline'.
		spec 
			package: 'Project-Core' with: [ spec includes: 'Project-Extra' ];
			package: 'Project-Extra' with: [ spec requires: 'Project-Core' ].
		spec 
			group: 'default' with: #('Project-Core' 'Project-Extra' );
			group: 'Core' with: #('default' );
			group: 'Tests' with: #('Project-Tests' ).].! !

!MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson13
"   [ see method: #version13: ]
In #version13: we are importing the '1.2-baseline', but changing the Example project 
version to 1.3, so project versions can be updated in the verson method jus like 
package versions.

Evaluate and compare the results of these expressions:

  (MetacelloProjectRefTutorialConfig project version: '1.2') load: 'Project-Core'.
  (MetacelloProjectRefTutorialConfig project version: '1.3') load: 'Project-Core'.

  (MetacelloProjectRefTutorialConfig project version: '1.2') load: 'Project-Tests'.
  (MetacelloProjectRefTutorialConfig project version: '1.3') load: 'Project-Tests'.

It is worth noting that in version 1.3 of the Example project, the platform-specific
'Example-Platform' was introduced and nothing special had to be done in the project 
reference to get the package included.
 
"! !

!MetacelloProjectRefTutorialConfig methodsFor: 'accessing' stamp: ''!
project
	"NOTE: The MetacelloNullRecordingMCSpecLoader is being used to prevent packages
		from being loaded, see MetacelloConfigTemplate>>project for an example #project
		method that loads the package for real"

	^ project ifNil: [ | constructor loader |
		"Construct Metacello project"
		constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self.
		project := constructor project.
		loader := MetacelloNullRecordingMCSpecLoader new.
		loader evalDoits: true.
		project loader: loader.
		project ]! !

!MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson07
"   [ see method: #baseline07: #version07: ]
NOTE: you should run through the lessons in MetacellTutorialConfig first.

In this configuration we are defining a project that utilizes the packages from the 
Example project (MetacelloTutorialConfig):  'Example-Core', 'Example-AddOn', 
'Example-Tests' and 2 packages specific to the project: 'Project-Core' and 
'Project-Tests':

  (MetacelloProjectRefTutorialConfig project version: '0.7') load.

"! !

!MetacelloProjectRefTutorialConfig methodsFor: 'baselines' stamp: ''!
baseline07: spec 
	<version: '0.7-baseline'>
	spec
		for: #common
		do: [spec blessing: #baseline.
			spec repository: 'http://www.example.com/Project'.
			spec 
				package: 'Project-Core' with: [
					spec requires: 'Example-Core' ];
				package: 'Project-Tests' with: [
					spec requires: #('Project-Core' 'Example-Tests' )];
				package: 'Example-Core' with: [
					spec repository: 'http://www.example.com/Example'];
				package: 'Example-Tests' with: [
					spec requires: 'Example-Core';
						 repository: 'http://www.example.com/Example'];
				package: 'Example-AddOn' with: [
					spec requires: 'Example-Core';
						 repository: 'http://www.example.com/Example']]! !

!MetacelloProjectRefTutorialConfig methodsFor: 'baselines' stamp: ''!
baseline10: spec 
	<version: '1.0-baseline'>
	
	spec for: #common do: [
		spec blessing: #baseline.
		spec repository: 'http://www.example.com/Project'.
		spec
			project: 'Example ALL' with: [
				spec
					className: 'MetacelloTutorialConfig';
					versionString: '1.0';
					loads: #('ALL' );
					file: 'MetacelloTutorialConfig';
					repository: 'http://seaside.gemstone.com/ss/metacello' ].
		spec 
			package: 'Project-Core' with: [ spec requires: 'Example ALL' ];
			package: 'Project-Tests' with: [ spec requires: 'Project-Core' ].].! !

!MetacelloProjectRefTutorialConfig methodsFor: 'baselines' stamp: ''!
baseline12: spec 
	<version: '1.2-baseline'>
	
	spec for: #common do: [
		spec blessing: #baseline.
		spec repository: 'http://www.example.com/Project'.
		spec
			project: 'Example Default' with: [
				spec
					className: 'MetacelloTutorialConfig';
					versionString: '1.2';
					loads: #('default' );
					file: 'Metacello-Tutorial';
					repository: 'http://seaside.gemstone.com/ss/metacello' ];
			project: 'Example Tests' 
				copyFrom: 'Example Default' 
				with: [ spec loads: #('Tests' ).].
		spec 
			package: 'Project-Core' with: [ spec requires: 'Example Default' ];
			package: 'Project-Tests' with: [ 
				spec requires: #('Project-Core' 'Example Tests' ).].].! !

!MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson14
"   [ see method: #baseline14: #version14: ]
In this lesson we'll cover the querying API for Metacello. The querying API is useful for analyzing the contents and structure of a version.

To start with we'll look at version '1.4' of the MetacelloProjectRefTutorialConfig. You can list the packages in the version:

  (MetacelloProjectRefTutorialConfig project version: '1.4') packages

The list project references:

  (MetacelloProjectRefTutorialConfig project version: '1.4') projects

And the groups:

  (MetacelloProjectRefTutorialConfig project version: '1.4') groups

You can access individual packages/project refs/groups using  the #packageNamed: method. Here you can access the package named: 'Project-Core':

  (MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Project-Core'

The project reference named 'Example Default':

 (MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Example Default'

The group named 'Core':

 (MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Core'

Each of the attributes of the package can be accessed (#requires, #includes, #file, #repository, #preLoadDoIt, and #postLoadDoit). For example:

  ((MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Project-Core') requires

Each of the attributes of the project can be accessed (#className, #versionString, #operator, #loads, #file, and #repository). For example:

  ((MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Example Default') repository

Each of the attributes of the group can be accessed (#includes). For example:

  ((MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'default') includes

When looking at the 'Core' group, there is only one package listed:

  (MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Core'

In the case of the 'Core' group, it is defined in terms of the 'default', which isn't very useful. When looking at the contents of groups you'd like to see the complete list of packages, without having to explicitly expanding each group you encounter. #packagesForSpecNamed: does just that:

  (MetacelloProjectRefTutorialConfig project version: '1.4') packagesForSpecNamed: 'Core'

If you were to load the 'Core' package:

  (MetacelloProjectRefTutorialConfig project version: '1.4') load: 'Core'

You end up seeing the packages from the Example project. If you want to get the list of packages that _would_ be loaded, you can use #allPackagesForSpecNamed:. For example:

  (MetacelloProjectRefTutorialConfig project version: '1.4') allPackagesForSpecNamed: 'Core'

If you use #allPackagesForSpecNamed: with a project refernce name, you'll see the packages that _would_ be loaded:

  (MetacelloProjectRefTutorialConfig project version: '1.4') load: 'Example Default'
  (MetacelloProjectRefTutorialConfig project version: '1.4') allPackagesForSpecNamed: 'Example Default'

You can also send #version to a project reference. This is useful if you want to explicitly walk the tree of projects:

  ((MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Example Default') version

"! !

!MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: ''!
version12: spec 
	<version: '1.2' imports: #('1.2-baseline' )>
	
	spec for: #common do: [
		spec blessing: #beta.
		spec 
			package: 'Project-Core' with: 'Project-Core-anon.1';
			package: 'Project-Tests' with: 'Project-Tests-anon.1'.].! !

!MetacelloProjectRefTutorialConfig methodsFor: 'baselines' stamp: ''!
baseline11: spec 
	<version: '1.1-baseline'>
	
	spec for: #common do: [
		spec blessing: #baseline.
		spec repository: 'http://www.example.com/Project'.

		spec
			project: 'Example Default' with: [
				spec
					className: 'MetacelloTutorialConfig';
					versionString: '1.1';
					loads: #('default' );
					file: 'Metacello-Tutorial';
					repository: 'http://seaside.gemstone.com/ss/metacello' ];
			project: 'Example Tests' with: [
				spec
					className: 'MetacelloTutorialConfig';
					versionString: '1.1';
					loads: #('Tests' );
					file: 'Metacello-Tutorial';
					repository: 'http://seaside.gemstone.com/ss/metacello' ].
		spec 
			package: 'Project-Core' with: [ spec requires: 'Example Default' ];
			package: 'Project-Tests' with: [ 
				spec requires: #('Project-Core' 'Example Tests' ).].].! !

!MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: ''!
version14: spec 
	<version: '1.4' imports: #('1.4-baseline' )>
	
	spec for: #common do: [
		spec blessing: #beta.
		spec description: 'Add groups and Project-Extra'.

		spec
			project: 'Example Default' with: '1.3';
			project: 'Example Tests' with: '1.3'.
		spec 
			package: 'Project-Core' with: 'Project-Core-anon.2';
			package: 'Project-Tests' with: 'Project-Tests-anon.2';
			package: 'Project-Extra' with: 'Project-Extra-anon.1'.].! !

!MetacelloProjectRefTutorialConfig class methodsFor: 'private' stamp: ''!
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]! !

!MetacelloProjectRefTutorialConfig class methodsFor: 'private' stamp: ''!
ensureMetacello
	"Bootstrap Gofer (if necessary), bootstrap ConfigurationOfMetacello (using old Gofer API), then load the latest 
	version of Metacello itself."

	Smalltalk at: #MetacelloProject ifAbsent: [
		Smalltalk at: #Gofer ifAbsent: [
			"Current version of Gofer from which to bootstrap - as of 1.0-beta.15"
			self bootstrapPackage: 'Gofer-lr.83' from: 'http://seaside.gemstone.com/ss/metacello' ].
		Smalltalk at: #Gofer ifPresent: [:goferClass | | gofer |
			gofer := goferClass new
				url: 'http://seaside.gemstone.com/ss/metacello';
				yourself.
			[ gofer addPackage: 'ConfigurationOfMetacello' ] on: Warning do: [:ex | ex resume ].
			gofer load ].
		"load 'default' group of Metacello"
		(Smalltalk at: #ConfigurationOfMetacello) perform: #load ]! !

!MetacelloProjectRefTutorialConfig class methodsFor: 'metacello tool support' stamp: ''!
isMetacelloConfig
	"Answer true and the Metacello tools will operate on you"
	
	^true! !

!MetacelloProjectRefTutorialConfig class methodsFor: 'accessing' stamp: ''!
project

	^self new project! !

!MetacelloProjectReferenceSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveToPackagesIn: aVersionSpec andProjects: andProjectsBool visited: visited
  ^ andProjectsBool
    ifTrue: [ {self} ]
    ifFalse: [ self resolveToPackagesIn: aVersionSpec visited: visited ]! !

!MetacelloProjectReferenceSpec methodsFor: 'printing' stamp: ''!
configMethodCascadeOn: aStream member: aMember last: lastCascade indent: indent
    aMember methodUpdateSelector == #'remove:'
        ifTrue: [ aStream nextPutAll: 'removeProject: ' , self name printString ]
        ifFalse: [ 
            self projectReference == nil
                ifTrue: [ ^ self ].
            aStream nextPutAll: self projectLabel , ': ' , self projectName printString , ' '.
            (aMember methodUpdateSelector == #'copy:' and: [ self projectReference hasNonVersionStringField ])
                ifTrue: [ aStream nextPutAll: 'copyFrom: ' , aMember sourceName printString , ' ' ].
            self projectReference configShortCutMethodOn: aStream member: aMember indent: indent + 1 ].
    lastCascade
        ifTrue: [ aStream nextPut: $. ]
        ifFalse: [ 
            aStream
                nextPut: $;;
                cr ]! !

!MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: ''!
includes: aCollection

	self shouldNotImplement! !

!MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: ''!
versionString: aString

	^self projectReference versionString: aString! !

!MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: ''!
requires: aCollection

	self shouldNotImplement! !

!MetacelloProjectReferenceSpec methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionRecord
	<inspectorPresentationOrder: 20 title: 'Record'>
	| specs |

	specs := (self projectReference version record: (self projectReference loads ifNil: [ #('default') ])) spec packageSpecsInLoadOrder.
	specs := specs reject: [ :each | each name = self name ].
	^ SpTablePresenter new
		addColumn: (SpStringTableColumn 
			title: 'Type' 
			evaluated: [ :aSpec | aSpec type ]) 
			beNotExpandable;
		addColumn: (SpStringTableColumn 
			title: 'Name' 
			evaluated: [ :aSpec | aSpec name ]);
		items: (specs sorted: #type ascending, #name ascending);
		yourself! !

!MetacelloProjectReferenceSpec methodsFor: '*Metacello-MC' stamp: ''!
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: ''!
resolveToAllPackagesIn: aVersionSpec into: packages visited: visited

	(self resolveProjectSpec resolveToAllPackagesIn: aVersionSpec visited: visited) do: [:pkg |
		packages at: pkg put: pkg ]! !

!MetacelloProjectReferenceSpec methodsFor: '*Metacello-MC' stamp: ''!
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: 'accessing' stamp: ''!
answers: aListOfPairs

	self shouldNotImplement! !

!MetacelloProjectReferenceSpec methodsFor: 'merging' stamp: ''!
mergeMap

	| map |
	map := super mergeMap.
	map at: #projectReference put: projectReference.
	^map! !

!MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: ''!
version

	^self projectReference version! !

!MetacelloProjectReferenceSpec methodsFor: '*Metacello-MC' stamp: ''!
versionString

	^self projectReference versionString! !

!MetacelloProjectReferenceSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveProjectSpec

	^self projectReference! !

!MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: ''!
projectLabel
    ^ self projectReference projectLabel! !

!MetacelloProjectReferenceSpec methodsFor: 'loading' stamp: ''!
repositorySpecs

	^self repositories map values! !

!MetacelloProjectReferenceSpec methodsFor: 'testing' stamp: ''!
hasRepository
    ^ self projectReference hasRepository! !

!MetacelloProjectReferenceSpec methodsFor: 'visiting' stamp: ''!
projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock

	projectBlock value: self! !

!MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: ''!
projectReference: anObject
	projectReference := anObject! !

!MetacelloProjectReferenceSpec methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
type

	^ 'project'! !

!MetacelloProjectReferenceSpec methodsFor: 'printing' stamp: ''!
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: 'merging' stamp: ''!
aboutToCopy
    self projectReference className! !

!MetacelloProjectReferenceSpec methodsFor: '*Metacello-MC' stamp: ''!
loadUsing: aLoader gofer: ignored

	| required |
	required := self resolveToLoadableSpec.
	required loader: aLoader.
	^required load! !

!MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: ''!
projectReference
	^ projectReference! !

!MetacelloProjectReferenceSpec methodsFor: 'merging' stamp: ''!
nonOverridable

	^super nonOverridable, #( projectReference )! !

!MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: ''!
referencedSpec

	^self projectReference! !

!MetacelloProjectReferenceSpec methodsFor: 'copying' stamp: ''!
postCopy

	super postCopy.
	projectReference := projectReference copy.! !

!MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: ''!
projectName
	^self projectReference name! !

!MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: ''!
versionOrNil

	^self projectReference versionOrNil! !

!MetacelloProjectReferenceSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveToPackagesIn: aVersionSpec visited: visited

	^#()! !

!MetacelloProjectReferenceSpec methodsFor: '*Metacello-MC' stamp: ''!
resolveToLoadableSpec

	^self resolveProjectSpec resolveToLoadableSpec! !

!MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: ''!
repositories
    ^ self referencedSpec repositories! !

!MetacelloProjectReferenceSpec methodsFor: '*Metacello-MC' stamp: ''!
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: 'merging' stamp: ''!
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: 'querying' stamp: ''!
relativeCurrentVersion

	^self projectReference relativeCurrentVersion! !

!MetacelloProjectReferenceSpec methodsFor: 'importing' stamp: ''!
mergeImportLoads: aLoadList
    self projectReference mergeImportLoads: aLoadList! !

!MetacelloProjectReferenceSpec methodsFor: '*Metacello-MC' stamp: ''!
repository: aStringOrMetacelloRepositorySpec
    ^ self projectReference repository: aStringOrMetacelloRepositorySpec! !

!MetacelloProjectReferenceSpec methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionProject
	<inspectorPresentationOrder: 10 title: 'Project'>
	| specs loadedSpecs |
	
	specs := self projectReference version spec packageSpecsInLoadOrder.
	loadedSpecs := (self projectReference loads ifNil: [ #() ]) 
		ifNotEmpty: [ :loads | specs select: [ :each | loads includes: each name ] ]
		ifEmpty: [ specs ].
	
	^ SpTablePresenter new
		addColumn: (SpStringTableColumn 
			title: 'Type' 
			evaluated: [ :aSpec | aSpec type ]) 
			beNotExpandable;
		addColumn: (SpStringTableColumn 
			title: 'Name' 
			evaluated: [ :aSpec | aSpec name ]);
		items: (loadedSpecs sorted: #type ascending, #name ascending);
		yourself
	! !

!MetacelloProjectReferenceSpecTestCase methodsFor: 'tests' stamp: ''!
testProjectReferenceSpec
	| projectReference project |
	projectReference := self projectReferenceSpec
		name: 'Project';
		projectReference:
			(project := self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProjectA';
				versionString: #stable;
				yourself);
		yourself.
	self assert: projectReference name equals: 'Project'.
	self assert: projectReference projectName equals: 'Project'.
	self assert: projectReference projectReference identicalTo: project.
	self should: [ projectReference includes: #() ] raise: Error.
	self should: [ projectReference requires: #() ] raise: Error.
	self should: [ projectReference answers: #() ] raise: Error.
	projectReference
		projectDo: [ :prjct | self assert: projectReference identicalTo: prjct ]
		packageDo: [ :ignored | self assert: false ]
		groupDo: [ :ignored | self assert: false ]! !

!MetacelloProjectReferenceSpecTestCase methodsFor: 'tests' stamp: ''!
testProjectReferenceMergeSpec
	| projectReferenceA projectReferenceB projectReference project |
	projectReferenceA := self projectReferenceSpec
		name: 'Project';
		projectReference:
			(self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProjectA';
				versionString: #stable;
				yourself);
		yourself.
	projectReferenceB := self projectReferenceSpec
		name: 'Project';
		projectReference:
			(self projectSpec
				name: 'Project';
				className: 'ConfigurationOfProjectB';
				versionString: '1.0';
				yourself);
		yourself.
	projectReference := projectReferenceA mergeSpec: projectReferenceB.
	self assert: projectReference name equals: 'Project'.
	self assert: projectReference projectName equals: 'Project'.
	project := projectReference projectReference.
	self assert: project className equals: 'ConfigurationOfProjectB'.
	self assert: project versionString equals: '1.0'! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
configurationProjectSpecIfAbsent: absentBlock
    ^ configurationProjectSpec ifNil: absentBlock! !

!MetacelloProjectRegistration methodsFor: 'querying' stamp: ''!
currentlyLoadedClassesInProject
	^ self projectSpec currentlyLoadedClassesInVersion asSet! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
locked: anObject
    self shouldBeMutable.
    locked := anObject! !

!MetacelloProjectRegistration methodsFor: 'comparing' stamp: ''!
= aRegistration
    aRegistration class == self class
        ifFalse: [ ^ false ].
    ^ (configurationProjectSpec registrationsCompareEqual: aRegistration configurationProjectSpec)
        and: [ baselineProjectSpec registrationsCompareEqual: aRegistration baselineProjectSpec ]! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
projectSpec
	^ baselineProjectSpec
		ifNil: [ 
			self assert: configurationProjectSpec notNil.
			configurationProjectSpec ]! !

!MetacelloProjectRegistration methodsFor: 'comparing' stamp: ''!
hash
    ^ ((String stringHash: projectName initialHash: 0) bitXor: configurationProjectSpec metacelloRegistrationHash)
        bitXor: baselineProjectSpec metacelloRegistrationHash! !

!MetacelloProjectRegistration methodsFor: 'registration' stamp: ''!
registerProject
    "unconditionally register <newRegistration> ... use with care"

    self class registry registerProjectRegistration: self! !

!MetacelloProjectRegistration methodsFor: 'mutability' stamp: ''!
shouldBeMutable
    self isMutable
        ifTrue: [ ^ self ].
    self error: 'Not allowed to modify an immutable object'! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
currentBranchName
  ^ self configurationProjectSpec
    ifNotNil: [ 
      configurationProjectSpec versionOrNil
        ifNil: [ '' ]
        ifNotNil: [ :vrsn | vrsn blessing asString ] ]
    ifNil: [ baselineProjectSpec repositoryBranchName ]! !

!MetacelloProjectRegistration methodsFor: 'mutability' stamp: ''!
immutable
    mutable := false! !

!MetacelloProjectRegistration methodsFor: 'registration' stamp: ''!
unregisterProject
    self class registry unregisterProjectRegistration: self! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
projectVersion
  | pv |
  pv := self versionInfo projectVersion.
  pv
    ifNil: [ 
      pv := self projectSpec versionOrNil.
      self versionInfo projectVersion: pv ].
  ^ pv! !

!MetacelloProjectRegistration methodsFor: 'mutability' stamp: ''!
copyOnWrite: aBlock
    "assume that only registered projects are immutable ... otherwise you'll get an error"

    | copy |
    self class registry
        registrationFor: self
        ifPresent: [ :existing |  ]
        ifAbsent: [ 
            aBlock value: self.
            ^ self ].
    self unregisterProject.
    copy := self copy.
    aBlock value: copy.
    copy registerProject.
    ^ copy! !

!MetacelloProjectRegistration methodsFor: 'printing' stamp: ''!
printOn: aStream
  | label versionString descriptions |
  self
    configurationProjectSpecIfPresent: [ :spec | 
      label := spec className.
      versionString := spec versionString ]
    ifAbsent: [ 
      "baseline"
      label := self baselineProjectSpec className.
      versionString := '[baseline]' ].
  aStream nextPutAll: label.
  versionString
    ifNil: [ aStream nextPutAll: ' --no version specified--' ]
    ifNotNil: [ 
      aStream
        space;
        nextPutAll: versionString ].
  (descriptions := self repositoryDescriptions) isEmpty
    ifTrue: [ ^ self ].
  aStream nextPutAll: ' from '.
  descriptions size = 1
    ifTrue: [ aStream nextPutAll: descriptions first ]
    ifFalse: [ 
      aStream nextPut: ${.
      descriptions do: [ :description | aStream nextPutAll: description ].
      aStream nextPut: $} ]! !

!MetacelloProjectRegistration methodsFor: 'testing' stamp: ''!
canDowngradeTo: aProjectRegistration
    "true if there are no load conflicts
        OR
       if the load conflicts involved two cofigurations ONLY and a downgrade is allowed"

    (self hasLoadConflicts: aProjectRegistration)
        ifFalse: [ ^ true ].
    configurationProjectSpec
        ifNotNil: [ 
            aProjectRegistration configurationProjectSpec
                ifNotNil: [ 
                    configurationProjectSpec ensureProjectLoaded.
                    ^ configurationProjectSpec canDowngradeTo: aProjectRegistration configurationProjectSpec ] ].
    ^ false! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
baselineProjectSpec: anObject
  "force the registration to be consistent -- difficult for Metacello to 
   repair registrations during load -- I've tried. "

  "https://github.com/dalehenrich/metacello-work/issues/212"

  self shouldBeMutable.
  configurationProjectSpec := nil.
  self assert: anObject isBaselineOfProjectSpec.
  baselineProjectSpec := anObject! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
currentVersionString
  ^ self configurationProjectSpec
    ifNotNil: [ :aSpec | aSpec versionString ]
    ifNil: [ baselineProjectSpec repositoryVersionString ]! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
repositoryDescriptions
    ^ (self configurationProjectSpecIfAbsent: [ self baselineProjectSpec ]) repositoryDescriptions! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
version
    ^ (self configurationProjectSpecIfAbsent: [ ^ MetacelloMCBaselineProject singletonVersionName ]) versionString! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
baseName
	^ self projectSpec baseName! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
baselineProjectSpecIfPresent: presentBlock ifAbsent: absentBlock
     ^ baselineProjectSpec ifNotNil: [ presentBlock cull: baselineProjectSpec ]  ifNil: absentBlock! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
versionInfo
  versionInfo
    ifNil: [ 
      versionInfo := MetacelloProjectRegistrationVersionInfo new.
      self
        configurationProjectSpecIfPresent: [ versionInfo versionString: self version ]
        ifAbsent: [ 
          "do not set versionString for freshly minted baseline ... 
           see https://github.com/dalehenrich/metacello-work/issues/328"
           ] ].
  ^ versionInfo! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
loadedInImage
    loadedInImage ifNil: [ loadedInImage := false ].
    ^ loadedInImage! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
locked
    locked ifNil: [ locked := false ].
    ^ locked! !

!MetacelloProjectRegistration methodsFor: 'mutability' stamp: ''!
mutable
    mutable := true! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
configurationProjectSpecIfPresent: presentBlock ifAbsent: absentBlock
    ^ configurationProjectSpec ifNotNil: [ presentBlock cull: configurationProjectSpec ]  ifNil: absentBlock! !

!MetacelloProjectRegistration methodsFor: 'mutability' stamp: ''!
isMutable
    mutable ifNil: [ ^ true ].
    ^ mutable! !

!MetacelloProjectRegistration methodsFor: 'copying' stamp: ''!
postCopy
    super postCopy.
    mutable := nil! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
projectName
	^ projectName! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
validate
	self isValid
		ifFalse: [ self error: 'Invalid project registration' ]! !

!MetacelloProjectRegistration methodsFor: 'testing' stamp: ''!
hasLoadConflicts: aProjectRegistration
	"5 combinations of loads with no load conflicts:
        No configs and baselines =
        configs = and no baselines
        configs = and baselines =
        configs = and no baseline loaded (self) with a baseline to load (aProjectRegistration)
        config loaded (self), no config to load (aProjectRegistration) and no baseline loaded(self) with a baseline to load (aProjectRegistration) "

	aProjectRegistration validate.
	self isValid
		ifFalse: [ ^ false ].
	^ self projectSpec hasConflictWithProjectSpec: aProjectRegistration projectSpec! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
projectName: anObject
    self shouldBeMutable.
    projectName := anObject! !

!MetacelloProjectRegistration methodsFor: 'testing' stamp: ''!
isValid

	" has a name and one or the other of the projectSpecs is non-nil, but not both ... this is CRITICAL"

	projectName ifNil: [ ^ false ].
	configurationProjectSpec ifNil: [ ^ baselineProjectSpec notNil ].
	^ baselineProjectSpec isNil! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
loadedInImage: anObject
    self shouldBeMutable.
    loadedInImage := anObject! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
configurationProjectSpec
  "only one of baselineProjectSpec or configurationProjectSpec should ever be set"

  ^ configurationProjectSpec! !

!MetacelloProjectRegistration methodsFor: 'lookup' stamp: ''!
lookupBaselineSpec
  baselineProjectSpec ifNotNil: [ :spec | ^ spec ].
  ^ configurationProjectSpec! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
baselineProjectSpec
  "only one of baselineProjectSpec or configurationProjectSpec should ever be set"

  ^ baselineProjectSpec! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
baselineProjectSpecIfAbsent: absentBlock
  ^ baselineProjectSpec ifNil: absentBlock! !

!MetacelloProjectRegistration methodsFor: 'lookup' stamp: ''!
lookupConfigurationSpec
  configurationProjectSpec ifNotNil: [ :spec | ^ spec ].
  ^ baselineProjectSpec! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
merge: aProjectRegistration
  " ... merge is done when a spec has been loaded into the image"

  self shouldBeMutable.
  aProjectRegistration validate.
  aProjectRegistration configurationProjectSpec
    ifNotNil: [ :aSpec |
      configurationProjectSpec := aSpec copy.
      configurationProjectSpec versionOrNil
        ifNotNil: [ :version | 
          "resolve symbolic versions for loaded projects"
          configurationProjectSpec versionString: version versionString ].
      baselineProjectSpec := nil.
      self versionInfo versionString: configurationProjectSpec versionString ]
    ifNil: [ 
      baselineProjectSpec := aProjectRegistration baselineProjectSpec.
      configurationProjectSpec := nil.
      self versionInfo
        versionString: baselineProjectSpec repositoryVersionString ]! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
configurationProjectSpec: anObject
  "force the registration to be consistent -- difficult for Metacello to 
   repair registrations during load -- I've tried. "

  "https://github.com/dalehenrich/metacello-work/issues/212"

  self shouldBeMutable.
  baselineProjectSpec := nil.
  self assert: anObject isConfigurationOfProjectSpec.
  configurationProjectSpec := anObject! !

!MetacelloProjectRegistration methodsFor: 'accessing' stamp: ''!
versionInfo: aMetacelloProjectRegistrationVersionInfo
  versionInfo := aMetacelloProjectRegistrationVersionInfo! !

!MetacelloProjectRegistration methodsFor: 'testing' stamp: ''!
canUpgradeTo: aProjectRegistration
  "true if there are no load conflicts
        OR
       if the load conflicts involved two cofigurations ONLY and an upgrade is allowed"

  (self hasLoadConflicts: aProjectRegistration)
    ifFalse: [ ^ true ].
  configurationProjectSpec
    ifNotNil: [ 
      aProjectRegistration configurationProjectSpec
        ifNotNil: [ 
          configurationProjectSpec copy ensureProjectLoaded.
          ^ configurationProjectSpec
            canUpgradeTo: aProjectRegistration configurationProjectSpec ] ].
  baselineProjectSpec
    ifNotNil: [ 
      aProjectRegistration baselineProjectSpec
        ifNotNil: [ 
          baselineProjectSpec copy ensureProjectLoaded.
          ^ baselineProjectSpec
            canUpgradeTo: aProjectRegistration baselineProjectSpec ] ].
  ^ false! !

!MetacelloProjectRegistration class methodsFor: 'querying' stamp: ''!
projectSpecForClassNamed: aClassName ifAbsent: absentBlock
    ^ self registry projectSpecForClassNamed: aClassName ifAbsent: absentBlock! !

!MetacelloProjectRegistration class methodsFor: 'accessing' stamp: ''!
registry
    Registry ifNil: [ Registry := MetacelloProjectRegistry new ].
    ^ Registry! !

!MetacelloProjectRegistration class methodsFor: 'querying' stamp: ''!
registrationForClassNamed: aClassName ifAbsent: absentBlock
    ^ self registry registrationForClassNamed: aClassName ifAbsent: absentBlock! !

!MetacelloProjectRegistration class methodsFor: 'accessing' stamp: ''!
resetRegistry
    Registry := nil! !

!MetacelloProjectRegistration class methodsFor: 'accessing' stamp: ''!
primeRegistryFromImage
    "MetacelloProjectRegistration primeRegistryFromImage"

    self registry primeRegistryFromImage! !

!MetacelloProjectRegistration class methodsFor: 'registration' stamp: ''!
registerProjectSpec: aProjectSpec ifPresent: presentBlock
    | newRegistration |
    newRegistration := aProjectSpec asProjectRegistration.
    ^ self registry
        registrationFor: newRegistration
        ifPresent: [ :existing | presentBlock value: existing value: newRegistration ]
        ifAbsent: [ newRegistration registerProject ]! !

!MetacelloProjectRegistration class methodsFor: 'accessing' stamp: ''!
configurationClasses
	"Return a set of the Metacello configuration classes that have been loaded into the image."

	"self configurationClasses"

	| answer |
	answer := IdentitySet new.
	ConfigurationOf allSubclasses
		do: [ :cl | 
			(cl includesBehavior: BaselineOf)
				ifFalse: [ answer add: cl ] ].
	Object allSubclasses
		do: [ :cl | 
			(answer includes: cl)
				ifFalse: [ (([ cl isMetacelloConfig ]
						on: Error
						do: [ :ex | ex return: false ])
						and: [ cl name asString beginsWith: 'ConfigurationOf' ])
						ifTrue: [ answer add: cl ] ] ].
	^ answer! !

!MetacelloProjectRegistration class methodsFor: 'mutability' stamp: ''!
copyRegistryRestoreOnErrorWhile: aBlock
  "install copy of registry for duration of <aBlock> execution."

  "registrations will be copied on write during <aBlock> execution."

  "if <aBlock> does not return control to this context, revert to the original
	version of the registry. Otherwise leave the new copy installed."

  | oldRegistry newRegistry |
  oldRegistry := self registry.
  newRegistry := self registry copy.
  self registry: newRegistry.
  aBlock
    ensure: [ 
      "install old version of registry"
      newRegistry := self registry.	"see https://github.com/dalehenrich/metacello-work/issues/210"
      self registry: oldRegistry ].
  self registry: newRegistry	"if control returned, install newRegistry"! !

!MetacelloProjectRegistration class methodsFor: 'querying' stamp: ''!
registrationForProjectSpec: aProjectSpec ifAbsent: absentBlock ifPresent: presentBlock
    | newRegistration |
    newRegistration := aProjectSpec asProjectRegistration.
    self registry
        registrationFor: newRegistration
        ifPresent: [ :existing | ^ presentBlock value: existing value: newRegistration ]
        ifAbsent: [ ^ absentBlock value: newRegistration ]! !

!MetacelloProjectRegistration class methodsFor: 'accessing' stamp: ''!
baselineProjectSpecs
    "MetacelloProjectRegistration baselineProjectSpecs"

    ^ self registry baselineProjectSpecs! !

!MetacelloProjectRegistration class methodsFor: 'instance creation' stamp: ''!
fromMCBaselineProjectSpec: aProjectSpec
    ^ self new
        projectName: aProjectSpec name;
        baselineProjectSpec: aProjectSpec;
        yourself! !

!MetacelloProjectRegistration class methodsFor: 'instance creation' stamp: ''!
fromMCConfigurationProjectSpec: aProjectSpec
    ^ self new
        projectName: aProjectSpec name;
        configurationProjectSpec: aProjectSpec;
        yourself! !

!MetacelloProjectRegistration class methodsFor: 'accessing' stamp: ''!
configurationProjectSpecs
    "MetacelloProjectRegistration configurationProjectSpecs"

    ^ self registry configurationProjectSpecs! !

!MetacelloProjectRegistration class methodsFor: 'accessing' stamp: ''!
projectSpecs
    "MetacelloProjectRegistration projectSpecs"

    ^ self configurationProjectSpecs , self baselineProjectSpecs! !

!MetacelloProjectRegistration class methodsFor: 'accessing' stamp: ''!
registry: aMetacelloProjectRegistry
    Registry := aMetacelloProjectRegistry! !

!MetacelloProjectRegistration class methodsFor: 'accessing' stamp: ''!
classRemoved: aClassRemovalAnnouncement
  "aRemovalAnnouncement is platform-specific ... responds to #itemClass to 
   answer the class that was removed."

  | aClass registration |
  aClass := aClassRemovalAnnouncement itemClass.
  registration := self registry
    registrationForExactClassNamed: aClass name asString
    ifAbsent: [ ^ self ].
  registration unregisterProject! !

!MetacelloProjectRegistration class methodsFor: 'mutability' stamp: ''!
copyRegistryWhile: aBlock
    "install copy of registry for duration of <aBlock> execution."

    "registrations will be copied on write during <aBlock> execution."

    "Unconditionally revert to the original
	version of the registry. Otherwise leave the new copy installed."

    | oldRegistry newRegistry |
    oldRegistry := self registry.
    newRegistry := self registry copy.
    self registry: newRegistry.
    aBlock
        ensure: [ 
            "install old version of registry"
            self registry: oldRegistry ]! !

!MetacelloProjectRegistration class methodsFor: 'accessing' stamp: ''!
baselineClasses
    "Return a set of the Metacello baseline classes that have been loaded into the image."

    "self baselineClasses"

    ^ BaselineOf allSubclasses! !

!MetacelloProjectRegistrationVersionInfo methodsFor: 'accessing' stamp: ''!
versionString: anObject
  versionString := anObject.
  projectVersion := nil! !

!MetacelloProjectRegistrationVersionInfo methodsFor: 'accessing' stamp: ''!
projectVersion: anObject
  projectVersion := anObject! !

!MetacelloProjectRegistrationVersionInfo methodsFor: 'accessing' stamp: ''!
projectVersion
  ^ projectVersion! !

!MetacelloProjectRegistrationVersionInfo methodsFor: 'accessing' stamp: ''!
versionString

   ^versionString! !

!MetacelloProjectRegistrationVersionInfo methodsFor: 'accessing' stamp: ''!
setVersionString: anObject
  "set versionString, only if it does not already have avalue"

  versionString ifNil: [ self versionString: anObject ]! !

!MetacelloProjectRegistry methodsFor: 'accessing' stamp: ''!
isEmpty
  ^ self configurationProjectSpecs isEmpty
    and: [ self baselineProjectSpecs isEmpty ]! !

!MetacelloProjectRegistry methodsFor: 'querying' stamp: ''!
projectSpecForClassNamed: aClassName ifAbsent: absentBlock
    ^ (self configurationRegistry
        at: aClassName
        ifAbsent: [ ^ (self baselineRegistry at: aClassName ifAbsent: [^absentBlock value]) baselineProjectSpec ])
        configurationProjectSpec! !

!MetacelloProjectRegistry methodsFor: 'initialization' stamp: ''!
primeRegisterLoadedProjectSpec: projectSpec
  MetacelloProjectRegistration
    registrationForProjectSpec: projectSpec
    ifAbsent: [ :new | 
      new
        loadedInImage: true;
        registerProject ]
    ifPresent: [ :existing :new | 
      existing
        copyOnWrite: [ :existingCopy | 
          existingCopy loadedInImage: true.
          existing locked
            ifFalse: [ 
              "lock takes precedence when priming from image"
              existingCopy merge: new ] ] ]! !

!MetacelloProjectRegistry methodsFor: 'accessing' stamp: ''!
baselineRegistry
    baselineRegistry ifNil: [ baselineRegistry := Dictionary new ].
    ^ baselineRegistry! !

!MetacelloProjectRegistry methodsFor: 'initialization' stamp: ''!
primeRegistryFromImage: configurationClasses baselineClasses: baselineClasses
  "MetacelloProjectRegistration primeRegistryFromImage"

  self
    primeRegistryFromImage: configurationClasses
    baselineClasses: baselineClasses
    prioritizeConfiguration: false! !

!MetacelloProjectRegistry methodsFor: 'registration' stamp: ''!
registerProjectRegistration: aMetacelloProjectRegistration
  "unconditionally register <newRegistration> ... use with care"

  aMetacelloProjectRegistration configurationProjectSpec copy
    ifNotNil: [ :spec | 
      self configurationRegistry
        at: spec className
        ifPresent: [ :existing | 
          (existing configurationProjectSpec registrationsCompareEqual: spec)
            ifFalse: [ 
              MetacelloNotification signal: ('REGISTRATION OF INCOMPATABLE PROJECTS: ' , existing printString
                        , ' REPLACED BY '
                        , aMetacelloProjectRegistration printString) ] ].
      spec versionOrNil
        ifNotNil: [ :version | 
          "resolve symbolic versions for loaded projects"
          spec versionString: version versionString ].
      aMetacelloProjectRegistration configurationProjectSpec: spec.
      (aMetacelloProjectRegistration respondsTo: #'versionInfo')
        ifTrue: [ aMetacelloProjectRegistration versionInfo setVersionString: spec versionString ].
      spec immutable.
      self configurationRegistry
        at: spec className
        put: aMetacelloProjectRegistration ].
  aMetacelloProjectRegistration baselineProjectSpec
    ifNotNil: [ :spec | 
      self baselineRegistry
        at: spec className
        ifPresent: [ :existing | 
          (existing baselineProjectSpec registrationsCompareEqual: spec)
            ifFalse: [ 
              MetacelloNotification signal: ('REGISTRATION OF INCOMPATABLE PROJECTS: ' , existing printString
                        , ' REPLACED BY '
                        , aMetacelloProjectRegistration printString) ] ].
      (aMetacelloProjectRegistration respondsTo: #'versionInfo')
        ifTrue: [ 
          aMetacelloProjectRegistration versionInfo
            setVersionString: spec repositoryVersionString ].
      spec immutable.
      self baselineRegistry
        at: spec className
        put: aMetacelloProjectRegistration ].
  aMetacelloProjectRegistration immutable! !

!MetacelloProjectRegistry methodsFor: 'initialization' stamp: ''!
primeRegistryFromImage
  "MetacelloProjectRegistration primeRegistryFromImage"

  self primeRegistryFromImage: false! !

!MetacelloProjectRegistry methodsFor: 'registration' stamp: ''!
registrationFor: aMetacelloProjectRegistration ifPresent: presentBlock ifAbsent: absentBlock
    | baseName |
    baseName := aMetacelloProjectRegistration baseName.
    aMetacelloProjectRegistration configurationProjectSpec
        ifNotNil: [ :spec | self configurationRegistry at: spec className ifPresent: [ :existing | ^ presentBlock value: existing ] ].
    aMetacelloProjectRegistration baselineProjectSpec
        ifNotNil: [ :spec | self baselineRegistry at: spec className ifPresent: [ :existing | ^ presentBlock value: existing ] ].
    self configurationRegistry
        at: 'ConfigurationOf' , baseName
        ifPresent: [ :existing | ^ presentBlock value: existing ].
    self baselineRegistry at: 'BaselineOf' , baseName ifPresent: [ :existing | ^ presentBlock value: existing ].
    ^ absentBlock value! !

!MetacelloProjectRegistry methodsFor: 'querying' stamp: ''!
registrationForClassNamed: aClassName ifAbsent: absentBlock
  ^ self
    registrationForExactClassNamed: aClassName
    ifAbsent: [ 
      | baseName |
      baseName := MetacelloScriptEngine baseNameOf: aClassName.
      self configurationRegistry
        at: 'ConfigurationOf' , baseName
        ifPresent: [ :registration | ^ registration ].
      self baselineRegistry
        at: 'BaselineOf' , baseName
        ifPresent: [ :registration | ^ registration ].
      absentBlock value ]! !

!MetacelloProjectRegistry methodsFor: 'copying' stamp: ''!
postCopy
    super postCopy.
    baselineRegistry := self baselineRegistry copy.
    configurationRegistry := self configurationRegistry copy! !

!MetacelloProjectRegistry methodsFor: 'querying' stamp: ''!
registrationForExactClassNamed: aClassName ifAbsent: absentBlock
  self configurationRegistry
    at: aClassName
    ifPresent: [ :registration | ^ registration ].
  self baselineRegistry
    at: aClassName
    ifPresent: [ :registration | ^ registration ].
  ^ absentBlock value! !

!MetacelloProjectRegistry methodsFor: 'accessing' stamp: ''!
registrations
  ^ self baselineRegistry values , self configurationRegistry values! !

!MetacelloProjectRegistry methodsFor: 'accessing' stamp: ''!
baselineProjectSpecs
    "MetacelloProjectRegistration baselineProjectSpecs"

    | projectSpecs |
    projectSpecs := OrderedCollection new.
    self baselineRegistry
        keysAndValuesDo: [ :className :registration | projectSpecs add: (self projectSpecForClassNamed: className ifAbsent: [ self error: 'not expected' ]) ].
    ^ projectSpecs asArray! !

!MetacelloProjectRegistry methodsFor: 'registration' stamp: ''!
unregisterProjectRegistration: aMetacelloProjectRegistration
    aMetacelloProjectRegistration configurationProjectSpec
        ifNotNil: [ :spec | 
            self configurationRegistry
                removeKey: spec className
                ifAbsent: [ self error: 'unexpectedly missing project registration' ] ].
    aMetacelloProjectRegistration baselineProjectSpec
        ifNotNil: [ :spec | self baselineRegistry removeKey: spec className ifAbsent: [ self error: 'unexpectedly missing project registration' ] ]! !

!MetacelloProjectRegistry methodsFor: 'accessing' stamp: ''!
configurationProjectSpecs
    "MetacelloProjectRegistration configurationProjectSpecs"

    | projectSpecs |
    projectSpecs := OrderedCollection new.
    self configurationRegistry
        keysAndValuesDo: [ :className :registration | projectSpecs add: (self projectSpecForClassNamed: className ifAbsent: [ self error: 'not expected' ]) ].
    ^ projectSpecs asArray! !

!MetacelloProjectRegistry methodsFor: 'accessing' stamp: ''!
projectSpecs
    "MetacelloProjectRegistration projectSpecs"

    ^ self configurationProjectSpecs , self baselineProjectSpecs! !

!MetacelloProjectRegistry methodsFor: 'accessing' stamp: ''!
configurationRegistry
    configurationRegistry ifNil: [ configurationRegistry := Dictionary new ].
    ^ configurationRegistry! !

!MetacelloProjectRegistry methodsFor: 'initialization' stamp: ''!
primeRegistryFromImage: prioritizeConfiguration
  "MetacelloProjectRegistration primeRegistryFromImage"

  self
    primeRegistryFromImage: MetacelloProjectRegistration configurationClasses
    baselineClasses: MetacelloProjectRegistration baselineClasses
    prioritizeConfiguration: prioritizeConfiguration! !

!MetacelloProjectRegistry methodsFor: 'initialization' stamp: ''!
primeRegistryCurrentVersionFor: cl
  ^ [ cl project currentVersion ]
    on: Error
    do: [ :ex | 
      Warning
        signal:
          'Error finding current version of ' , cl name asString
            , '. Probably an invalid specification.'.
      nil ]! !

!MetacelloProjectRegistry methodsFor: 'initialization' stamp: ''!
primeRegistryProjectSpecRegistered: projectSpec
  MetacelloProjectRegistration
    registrationForProjectSpec: projectSpec
    ifAbsent: [ :new | ^ false ]
    ifPresent: [ :existing :new | ^ true ]! !

!MetacelloProjectRegistry methodsFor: 'initialization' stamp: ''!
primeRegistryFromImage: configurationClasses baselineClasses: baselineClasses prioritizeConfiguration: prioritizeConfiguration
  "MetacelloProjectRegistration primeRegistryFromImage"

  baselineClasses
    do: [ :cl | 
      (self baselineRegistry includesKey: cl name asString)
        ifFalse: [ 
          "not registered"
          (self primeRegistryCurrentVersionFor: cl)
            ifNotNil: [ :version | 
              | projectSpec |
              projectSpec := (version project projectSpec
                name: (MetacelloScriptEngine baseNameOf: cl name asString);
                repositories: version project projectPackage repositories copy;
                yourself) asBaselineProjectSpec.
              self primeRegisterLoadedProjectSpec: projectSpec ] ] ].
  configurationClasses
    do: [ :cl | 
      (self configurationRegistry includesKey: cl name asString)
        ifFalse: [ 
          "not registered"
          (self primeRegistryCurrentVersionFor: cl)
            ifNotNil: [ :version | 
              | projectSpec repos projectPackage project |
              project := version project.
              projectPackage := project projectPackage.
              repos := nil.
              projectPackage ~~ nil
                ifTrue: [ repos := projectPackage repositories copy ].
              projectSpec := (version project projectSpec
                name: (MetacelloScriptEngine baseNameOf: cl name asString);
                className: cl name asString;
                versionString: version versionString;
                repositories: repos;
                yourself) asConfigurationProjectSpec.
              (prioritizeConfiguration
                or: [ (self primeRegistryProjectSpecRegistered: projectSpec) not ])
                ifTrue: [ 
                  "Configuration override existing registrations or nothing registered yet"
                  self primeRegisterLoadedProjectSpec: projectSpec ] ] ] ]! !

!MetacelloProjectSpec methodsFor: 'printing' stamp: ''!
hasClassName
    ^ className ~~ nil! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
getClassName
    "raw access to iv"

    ^ className! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
compareVersionsEqual: aMetacelloProjectSpec
  | vrsn otherVrsn |
  vrsn := self versionOrNil.
  otherVrsn := aMetacelloProjectSpec versionOrNil.
  vrsn ifNil: [ ^ vrsn = otherVrsn ].
  otherVrsn ifNil: [ ^ false ].
  ^ vrsn versionNumber = otherVrsn versionNumber! !

!MetacelloProjectSpec methodsFor: 'adding' stamp: ''!
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: 'scripting' stamp: ''!
isLocked

  ^ self registration 
	ifNotNil: [ :aRegistration | aRegistration locked ]
	ifNil: [ false ]! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
mergeScriptLoads: aSpec
    self shouldBeMutable.
    aSpec loads
        ifNotNil: [ :otherLoads | self loads ifNil: [ loads := otherLoads ] ifNotNil: [ loads := (loads , otherLoads) asSet asArray ] ].
    self loader: aSpec loader! !

!MetacelloProjectSpec methodsFor: 'construction' stamp: ''!
operator: anObject constructor: aVersionConstructor
    aVersionConstructor operatorForProject: anObject! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
unregisterProject
    ^ MetacelloProjectRegistration
        registrationForProjectSpec: self
        ifAbsent: [  ]
        ifPresent: [ :existing :new | existing unregisterProject ]! !

!MetacelloProjectSpec methodsFor: 'construction' stamp: ''!
version: anObject constructor: aVersionConstructor
    aVersionConstructor versionForProject: anObject! !

!MetacelloProjectSpec methodsFor: 'construction' stamp: ''!
preLoadDoIt: aSymbol constructor: aVersionConstructor
    aVersionConstructor preLoadDoItForProject: aSymbol! !

!MetacelloProjectSpec methodsFor: 'private' stamp: ''!
setName: aStringOrNil
    self shouldBeMutable.
    name := aStringOrNil! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
versionString: anObject
    self shouldBeMutable.
    versionString := anObject! !

!MetacelloProjectSpec methodsFor: 'construction' stamp: ''!
name: aString constructor: aVersionConstructor
    aVersionConstructor nameForProject: aString! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
canDowngradeTo: aMetacelloProjectSpec
  (self className = aMetacelloProjectSpec className
    and: [ self operator == aMetacelloProjectSpec operator ])
    ifFalse: [ ^ false ].
  self versionOrNil == nil
    ifTrue: [ 
      "https://github.com/dalehenrich/metacello-work/issues/198#issuecomment-21737458"
      ^ true ].
  ^ (self compareVersions: aMetacelloProjectSpec usingOperator: self operator)
    not! !

!MetacelloProjectSpec methodsFor: 'merging' stamp: ''!
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: 'accessing' stamp: ''!
file
    ^ self className! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
version
    self subclassResponsibility! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
versionString
	^ versionString! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
metacelloRegistrationHash
    "name className versionString operator loads preLoadDoIt postLoadDoIt"

    | hash |
    hash := String stringHash: name initialHash: 0.
    hash := String stringHash: self className initialHash: hash.
    hash := String stringHash: self versionString initialHash: hash.
    hash := String stringHash: self operator asString initialHash: hash.
    hash := String stringHash: self preLoadDoIt asString initialHash: hash.
    hash := String stringHash: self postLoadDoIt asString initialHash: hash.
    ^ hash bitXor: loads hash! !

!MetacelloProjectSpec methodsFor: 'printing' stamp: ''!
projectLabel
    ^ 'project'! !

!MetacelloProjectSpec methodsFor: 'testing' stamp: ''!
hasRepository
    ^ false! !

!MetacelloProjectSpec methodsFor: 'printing' stamp: ''!
label

	^self name! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
setPostLoadDoIt: aSymbol
    self shouldBeMutable.
    postLoadDoIt := aSymbol! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
hasNoLoadConflicts: aMetacelloProjectSpec
  "same as compareEqual:, except if versionString and/or repositories are not 
	specified for either one, then there are not conflicts"

  ^ self className = aMetacelloProjectSpec className
    and: [ 
      (self compareVersionsEqual: aMetacelloProjectSpec)
        and: [ self operator == aMetacelloProjectSpec operator ] ]! !

!MetacelloProjectSpec methodsFor: 'loading' stamp: ''!
load

	self subclassResponsibility! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
versionKey
	"suitable for using as a unique key for the receiver's version in a dictionary"

	^ self version versionKey! !

!MetacelloProjectSpec methodsFor: 'printing' stamp: ''!
configMethodBodyOn: aStream indent: indent fromShortCut: fromShortCut
  | hasVersionString hasOperator hasProjectPackage hasLoads hasClassName hasPreLoadDoIt hasPostLoadDoIt |
  hasClassName := self hasClassName.
  hasVersionString := self configHasVersionString.
  hasOperator := operator ~~ nil.
  hasProjectPackage := self hasRepository
    or: [ hasClassName & (self getFile ~~ nil) ].
  hasLoads := self loads ~~ nil.
  hasPreLoadDoIt := self getPreLoadDoIt ~~ nil.
  hasPostLoadDoIt := self getPostLoadDoIt ~~ nil.
  hasClassName
    ifTrue: [ 
      hasVersionString | hasOperator | hasProjectPackage | hasLoads
        ifTrue: [ 
          aStream
            cr;
            tab: indent + 1 ]
        ifFalse: [ aStream space ].
      aStream nextPutAll: 'className: ' , self className printString.
      hasVersionString | hasPreLoadDoIt | hasPostLoadDoIt | hasOperator
        | hasLoads | hasProjectPackage
        ifTrue: [ aStream nextPut: $; ] ].
  hasVersionString
    ifTrue: [ 
      | vs |
      hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPreLoadDoIt
        | hasPostLoadDoIt
        ifTrue: [ 
          aStream
            cr;
            tab: indent + 1 ]
        ifFalse: [ aStream space ].
      vs := self versionString.
      aStream nextPutAll: 'versionString: '.
      vs isSymbol
        ifTrue: [ aStream nextPut: $# ].
      aStream nextPutAll: vs asString printString.
      hasPreLoadDoIt | hasPostLoadDoIt | hasOperator | hasProjectPackage
        | hasLoads
        ifTrue: [ aStream nextPut: $; ] ].
  hasPreLoadDoIt
    ifTrue: [ 
      hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPreLoadDoIt
        ifTrue: [ 
          aStream
            cr;
            tab: indent + 1 ]
        ifFalse: [ aStream space ].
      aStream nextPutAll: 'preLoadDoIt: '.
      self preLoadDoIt value isSymbol
        ifTrue: [ 
          aStream
            nextPut: $#;
            nextPutAll: self preLoadDoIt value asString printString ]
        ifFalse: [ aStream nextPutAll: self preLoadDoIt value asString ].
      hasPostLoadDoIt | hasOperator | hasProjectPackage | hasLoads
        ifTrue: [ aStream nextPut: $; ] ].
  hasPostLoadDoIt
    ifTrue: [ 
      hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPostLoadDoIt
        ifTrue: [ 
          aStream
            cr;
            tab: indent + 1 ]
        ifFalse: [ aStream space ].
      aStream nextPutAll: 'postLoadDoIt: '.
      self postLoadDoIt value isSymbol
        ifTrue: [ 
          aStream
            nextPut: $#;
            nextPutAll: self postLoadDoIt value asString printString ]
        ifFalse: [ aStream nextPutAll: self postLoadDoIt value asString ].
      hasOperator | hasProjectPackage | hasLoads
        ifTrue: [ aStream nextPut: $; ] ].
  hasOperator
    ifTrue: [ 
      hasClassName | hasVersionString | hasProjectPackage | hasLoads | hasPreLoadDoIt
        | hasPostLoadDoIt
        ifTrue: [ 
          aStream
            cr;
            tab: indent + 1 ]
        ifFalse: [ aStream space ].
      aStream nextPutAll: 'operator: #' , self operator asString printString.
      hasProjectPackage | hasLoads
        ifTrue: [ aStream nextPut: $; ] ].
  hasLoads
    ifTrue: [ 
      hasClassName | hasVersionString | hasOperator | hasProjectPackage
        | hasPreLoadDoIt | hasPostLoadDoIt
        ifTrue: [ 
          aStream
            cr;
            tab: indent + 1 ]
        ifFalse: [ aStream space ].
      aStream nextPutAll: 'loads: #('.
      self loads do: [ :str | aStream nextPutAll: str printString , ' ' ].
      aStream nextPut: $).
      hasProjectPackage
        ifTrue: [ aStream nextPut: $; ] ].
  hasProjectPackage
    ifTrue: [ 
      | hasName hasRepo |
      hasRepo := self hasRepository.
      hasName := self file ~= self className.
      hasName
        ifTrue: [ 
          hasClassName | hasVersionString | hasOperator | hasLoads | hasPreLoadDoIt
            | hasPostLoadDoIt
            ifTrue: [ 
              aStream
                cr;
                tab: indent + 1 ]
            ifFalse: [ aStream space ].
          aStream nextPutAll: 'file: ' , self file printString.
          hasRepo
            ifTrue: [ aStream nextPut: $; ] ].
      hasRepo
        ifTrue: [ 
          | repos |
          repos := self repositories map values.
          repos size = 1
            ifTrue: [ 
              fromShortCut
                ifTrue: [ 
                  hasClassName | hasVersionString | hasOperator | hasLoads | hasPreLoadDoIt
                    | hasPostLoadDoIt | hasName
                    ifTrue: [ 
                      aStream
                        cr;
                        tab: indent + 1 ]
                    ifFalse: [ aStream space ] ]
                ifFalse: [ 
                  aStream
                    cr;
                    tab: indent + 1 ].
              repos first configMethodCascadeOn: aStream lastCascade: true ]
            ifFalse: [ 
              aStream cr.
              self repositories configMethodCascadeOn: aStream indent: indent ] ] ]! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
projectPackage

	^nil! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
setPreLoadDoIt: aSymbol
    self shouldBeMutable.
    preLoadDoIt := aSymbol! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
className: aString
    self shouldBeMutable.
    className := aString! !

!MetacelloProjectSpec methodsFor: 'printing' stamp: ''!
configShortCutMethodOn: aStream member: aMember indent: indent
  | hasVersionString hasOperator hasProjectPackage hasLoads hasClassName hasPreLoadDoIt hasPostLoadDoIt |
  hasClassName := self hasClassName.
  hasVersionString := self configHasVersionString.
  hasOperator := operator ~~ nil.
  hasProjectPackage := self hasRepository
    or: [ hasClassName & (self getFile ~~ nil or: [ className ~= self name ]) ].
  hasLoads := self loads ~~ nil.
  hasPreLoadDoIt := self getPreLoadDoIt ~~ nil.
  hasPostLoadDoIt := self getPostLoadDoIt ~~ nil.
  hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPreLoadDoIt
    | hasPostLoadDoIt
    ifTrue: [ 
      (aMember methodUpdateSelector == #'copy:'
        or: [ aMember methodUpdateSelector == #'with:' ])
        ifTrue: [ 
          aStream
            nextPutAll: 'with: [';
            cr ]
        ifFalse: [ 
          aStream
            nextPutAll: 'overrides: [';
            cr ].
      aStream
        tab: indent;
        nextPutAll: 'spec'.
      self configMethodBodyOn: aStream indent: indent fromShortCut: true.
      aStream nextPutAll: ' ]'.
      ^ self ].
  hasVersionString
    ifTrue: [ 
      | vs |
      vs := self versionString.
      aStream nextPutAll: 'with: '.
      vs isSymbol
        ifTrue: [ aStream nextPut: $# ].
      aStream nextPutAll: vs asString printString ]! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
versionOrNil

	^[ self version ] on: MetacelloVersionDoesNotExistError do: [:ex | ^nil ].! !

!MetacelloProjectSpec methodsFor: 'testing' stamp: ''!
hasLoadConflicts: aMetacelloProjectSpec
  ^ (self hasNoLoadConflicts: aMetacelloProjectSpec) not! !

!MetacelloProjectSpec methodsFor: 'printing' stamp: ''!
configMethodBodyOn: aStream indent: indent
  ^ self configMethodBodyOn: aStream indent: indent fromShortCut: false! !

!MetacelloProjectSpec methodsFor: 'private' stamp: ''!
constructClassName
    ^ nil! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
postLoadDoIt: anObject

	anObject setPostLoadDoItInMetacelloSpec: self! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
registrationsCompareEqual: aMetacelloProjectSpec
    "name className versionString operator loads preLoadDoIt postLoadDoIt"

    ^ self className = aMetacelloProjectSpec className
        and: [ self versionString = aMetacelloProjectSpec versionString and: [ self operator == aMetacelloProjectSpec operator ] ]! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
getPreLoadDoIt

	^preLoadDoIt! !

!MetacelloProjectSpec methodsFor: 'printing' stamp: ''!
configHasVersionString
  ^ self versionString ~~ nil! !

!MetacelloProjectSpec methodsFor: 'private' stamp: ''!
setLoads: aCollection
    self shouldBeMutable.
    loads := aCollection! !

!MetacelloProjectSpec methodsFor: 'testing' stamp: ''!
hasNonVersionStringField
    | hasVersionString hasOperator hasProjectPackage hasLoads hasClassName hasPreLoadDoIt hasPostLoadDoIt |
    hasClassName := self hasClassName.
    hasVersionString := self versionString ~~ nil.
    hasOperator := operator ~~ nil.
    hasProjectPackage := (self file ~~ nil and: [ hasClassName and: [ self className ~= self name ] ])
        or: [ self hasRepository ].
    hasLoads := self loads ~~ nil.
    hasPreLoadDoIt := self getPreLoadDoIt ~~ nil.
    hasPostLoadDoIt := self getPostLoadDoIt ~~ nil.
    ^ hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPreLoadDoIt | hasPostLoadDoIt! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
currentlyLoadedClassesInVersion
    self versionOrNil ifNotNil: [ :vrsn | ^ vrsn currentlyLoadedClassesInVersion ].
    ^ #()! !

!MetacelloProjectSpec methodsFor: 'construction' stamp: ''!
loads: anObject constructor: aVersionConstructor
    aVersionConstructor loadsForProject: anObject! !

!MetacelloProjectSpec methodsFor: 'private' stamp: ''!
loadListForVersion: vrsn 

	^ (self loads == nil
			or: [self loads isEmpty])
		ifTrue: [vrsn spec defaultPackageNames]
		ifFalse: [self loads]! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
getRepositories
    "raw access to iv"

    ^ nil! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
name: aString
    ((aString at: 1) isSeparator or: [ (aString at: aString size) isSeparator ])
        ifTrue: [ self error: 'Names are not allowed to have leading or trailing blanks: ' , aString printString ].
    self shouldBeMutable.
    name := aString! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
preLoadDoIt

	^preLoadDoIt! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
preLoadDoIt: anObject

	anObject setPreLoadDoItInMetacelloSpec: self! !

!MetacelloProjectSpec methodsFor: 'construction' stamp: ''!
className: aString constructor: aVersionConstructor
    aVersionConstructor classNameForProject: aString! !

!MetacelloProjectSpec methodsFor: 'visiting' stamp: ''!
projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock
    projectBlock value: self! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
className
    className ifNil: [ self name ifNotNil: [ self className: self constructClassName ] ].
    ^ className! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
compareVersions: aMetacelloProjectSpec usingOperator: anOperator
  ^ aMetacelloProjectSpec versionOrNil == nil
    ifTrue: [ 
      "https://github.com/dalehenrich/metacello-work/issues/199#issuecomment-21739622"
      aMetacelloProjectSpec versionString asMetacelloVersionNumber
        perform: anOperator
        with: self version versionNumber ]
    ifFalse: [ ^ aMetacelloProjectSpec version perform: anOperator with: self version ]! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
loads
	^ loads! !

!MetacelloProjectSpec methodsFor: 'printing' stamp: ''!
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: 'accessing' stamp: ''!
operator: anObject
    " #= #~= #> #< #>= #<= #~> "

    self shouldBeMutable.
    operator := anObject! !

!MetacelloProjectSpec methodsFor: 'construction' stamp: ''!
postLoadDoIt: aSymbol constructor: aVersionConstructor
    aVersionConstructor postLoadDoItForProject: aSymbol! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
postLoadDoIt

	^postLoadDoIt! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
operator

	operator == nil ifTrue: [ ^#>= ].
	^ operator! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
registration
    ^ MetacelloProjectRegistration
        registrationForProjectSpec: self
        ifAbsent: [ :ignored |  ]
        ifPresent: [ :existing :new | existing ]! !

!MetacelloProjectSpec methodsFor: 'private' stamp: ''!
resolveToLoadableSpec

	^self copy! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
name

	^name! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
compareEqual: aMetacelloProjectSpec
  "name className versionString operator loads preLoadDoIt postLoadDoIt"

  ^ self className = aMetacelloProjectSpec className
    and: [ 
      (self compareVersionsEqual: aMetacelloProjectSpec)
        and: [ 
          self operator == aMetacelloProjectSpec operator
            and: [ 
              self loads = aMetacelloProjectSpec loads
                and: [ 
                  self preLoadDoIt value == aMetacelloProjectSpec preLoadDoIt value
                    and: [ self postLoadDoIt value == aMetacelloProjectSpec postLoadDoIt value ] ] ] ] ]! !

!MetacelloProjectSpec methodsFor: 'construction' stamp: ''!
versionString: anObject constructor: aVersionConstructor
    aVersionConstructor versionStringForProject: anObject! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
getOperator

	^operator! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
loads: aCollection

	aCollection setLoadsInMetacelloProject: self! !

!MetacelloProjectSpec methodsFor: 'querying' stamp: ''!
getPostLoadDoIt

	^postLoadDoIt! !

!MetacelloProjectSpec methodsFor: 'accessing' stamp: ''!
getFile
    "raw access to iv"

    ^ nil! !

!MetacelloProjectSpec methodsFor: 'scripting' stamp: ''!
canUpgradeTo: aMetacelloProjectSpec
  (self className = aMetacelloProjectSpec className
    and: [ self operator == aMetacelloProjectSpec operator ])
    ifFalse: [ ^ false ].
  self versionOrNil == nil
    ifTrue: [ 
      "https://github.com/dalehenrich/metacello-work/issues/198#issuecomment-21737458"
      ^ true ].
  ^ self compareVersions: aMetacelloProjectSpec usingOperator: self operator! !

!MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: ''!
projectSpec
	^ projectSpec! !

!MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: ''!
useDetermineVersionForLoad: anObject
	useDetermineVersionForLoad := anObject! !

!MetacelloProjectSpecForLoad methodsFor: 'operations' stamp: ''!
performCurrentVersionTestAgainst: vrsn operator: anOperator targetVersionStatus: targetVersionStatus using: anMCLoader
  "answer true if the current state of image is to be left as is"

  | currentVersion existing new |
  vrsn ifNil: [ ^ false ].
  self useDetermineVersionForLoad
    ifTrue: [ 
      | prjct cv |
      self hasOverride
        ifTrue: [ 
          self
            error:
              'unexpected logic combination: useDeterminVersionForLoad & hasOverride' ].
      prjct := self projectSpec projectClassProject.
      prjct loader: anMCLoader.
      (cv := prjct currentVersion) == nil
        ifTrue: [ ^ false ].
      (targetVersionStatus includes: cv versionStatus)
        ifTrue: [ ^ cv perform: anOperator with: vrsn ].
      ^ false ].
  true
    ifTrue: [ 
      "unconditional fail test at this point for Issue #388"
      "https://github.com/dalehenrich/metacello-work/issues/388"
      ^ false ].
  (self hasOverride not or: [ targetVersionStatus ~= #(#'allLoadedToSpec') ])
    ifTrue: [ ^ false ].
  (self overrideProjectSpec allPackagesLoaded: anMCLoader)
    ifFalse: [ 
      "roughly equivalent to versionStatus test above (#'allLoadedToSpec')"
      ^ false ].
  (self overrideProjectSpec
    isPartiallyLoaded: self overrideProjectSpec copy loader)
    ifFalse: [ 
      "if the project is not loaded at all"
      ^ false ].
  (currentVersion := self overrideProjectSpec versionOrNil) ifNil: [ ^ false ].
  currentVersion = vrsn
    ifTrue: [ ^ true ].
  existing := self overrideProjectSpec asProjectRegistration.
  new := self projectSpec asProjectRegistration.
  ^ currentVersion > vrsn
    ifTrue: [ 
      "answer false if downgrade allowed"
      (MetacelloAllowProjectDowngrade new
        existingProjectRegistration: existing;
        newProjectRegistration: new;
        signal) == existing ]
    ifFalse: [ 
      "answer false if upgrade allowed"
      (MetacelloAllowProjectUpgrade new
        existingProjectRegistration: existing;
        newProjectRegistration: new;
        signal) == existing ]! !

!MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: ''!
useDetermineVersionForLoad
    useDetermineVersionForLoad ifNil: [ useDetermineVersionForLoad := true ].
    ^ useDetermineVersionForLoad! !

!MetacelloProjectSpecForLoad methodsFor: 'operations' stamp: ''!
performLoad
  | displayString spec |
  spec := self projectSpec.

displayString := 'Project: ' , spec name.
	
  spec versionString ~~ nil
    ifTrue: [ displayString := displayString , ' ' , spec versionString ].
  	MetacelloNotification signal: displayString.

	spec isLocked ifTrue: [ 
		MetacelloNotification signal: 'Project is locked, skipping.'.
		^ self ].


  self hasOverride
    ifTrue: [ 
      | override |
      override := self overrideProjectSpec copy.
      override mergeScriptLoads: spec.
      override loadVersion: nil ]
    ifFalse: [ 
      | vrsn |
      vrsn := self useDetermineVersionForLoad
        ifTrue: [ spec determineCurrentVersionForLoad ]
        ifFalse: [ spec versionOrNil ].
      (spec asProjectSpecForVersion: vrsn) loadVersion: vrsn ]! !

!MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: ''!
overrideProjectSpec: anObject
	overrideProjectSpec := anObject! !

!MetacelloProjectSpecForLoad methodsFor: 'testing' stamp: ''!
hasOverride
    ^ self overrideProjectSpec ~~ nil! !

!MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: ''!
projectSpec: anObject
	projectSpec := anObject! !

!MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: ''!
overrideProjectSpec
	^ overrideProjectSpec! !

!MetacelloProjectSpecGenerator methodsFor: 'accessing' stamp: ''!
projectSpecCreationBlock
    ^ [ :projectName | {(MetacelloMCProject new projectSpec name: projectName)} ]! !

!MetacelloProjectSpecGenerator methodsFor: 'accessing' stamp: ''!
projectSpecListBlock
    ^ [ MetacelloProjectRegistration projectSpecs ]! !

!MetacelloProjectSpecGenerator methodsFor: 'accessing' stamp: ''!
projectSpecLookupBlock
    ^ [ :projectName | 
    {(MetacelloProjectRegistration
        projectSpecForClassNamed: (MetacelloScriptEngine baselineNameFrom: projectName)
        ifAbsent: [  ]).
    (MetacelloProjectRegistration
        projectSpecForClassNamed: (MetacelloScriptEngine configurationNameFrom: projectName)
        ifAbsent: [  ])} ]! !

!MetacelloProjectSpecGenerator methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!MetacelloProjectSpecGenerator methodsFor: 'accessing' stamp: ''!
target: anObject
	target := anObject! !

!MetacelloProjectSpecLoadConflict methodsFor: 'accessing' stamp: ''!
possibleVersions
    "not applicable to a Conflict error"

    self shouldNotImplement! !

!MetacelloProjectSpecLoadConflict methodsFor: 'accessing' stamp: ''!
versionString
    "not applicable to a Conflict error"

    self shouldNotImplement! !

!MetacelloProjectSpecLoadConflict methodsFor: 'private' stamp: ''!
isResumable
	"Determine whether an exception is resumable."

	^ true! !

!MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: ''!
projectSpec

	^projectSpec! !

!MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: ''!
versionDoesNotExistException: anObject
	versionDoesNotExistException := anObject! !

!MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: ''!
possibleVersions
    ^ self versionDoesNotExistException possibleVersions! !

!MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: ''!
versionDoesNotExistException
	^ versionDoesNotExistException! !

!MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: ''!
projectSpec: aMetacelloMCProjectSpec

	projectSpec := aMetacelloMCProjectSpec! !

!MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: ''!
versionString
    ^ self versionDoesNotExistException versionString! !

!MetacelloProjectSpecLoadError class methodsFor: 'instance creation' stamp: ''!
projectSpec: aMetacelloMCProjectSpec

	^self new
		projectSpec: aMetacelloMCProjectSpec;
		yourself! !

!MetacelloProjectSpecLoadedNotification commentStamp: ''!
**MetacelloLoadProjectSpecVersionNotification** is signalled to indicate that the given project spec was loaded into the image.!
!MetacelloProjectSpecLoadedNotification methodsFor: 'exception description' stamp: ''!
defaultAction
    ^ nil! !

!MetacelloProjectSpecLoadedNotification methodsFor: 'handlers' stamp: ''!
handleResolutionFor: aScriptEngine
    ^ aScriptEngine handleProjectSpecLoaded: self! !

!MetacelloProjectSpecTestCase methodsFor: 'tests' stamp: ''!
testProjectSpec
	| project |
	project := self projectSpec.
	project
		name: 'Project';
		className: 'ConfigurationOfProject';
		versionString: '1.0';
		versionString: #stable;
		operator: #<;
		operator: nil;
		loads: 'MyPackage';
		loads: #('MyPackage' 'MyTests');
		preLoadDoIt: #preLoadDoIt;
		postLoadDoIt: #postLoadDoIt;
		yourself.
	self assert: project name equals: 'Project'.
	self assert: project className equals: 'ConfigurationOfProject'.
	self assert: project versionString equals: #stable.
	self assert: project operator identicalTo: #>=.
	self assert: project loads equals: #('MyPackage' 'MyTests').
	self assert: project preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: project postLoadDoIt value identicalTo: #postLoadDoIt.
	self should: [ project includes: #() ] raise: Error.
	self should: [ project requires: #() ] raise: Error.
	self should: [ project answers: #() ] raise: Error.
	project projectDo: [ :prjct | self assert: project identicalTo: prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ].
	self should: [ project preLoadDoIt: '' ] raise: Error.
	self should: [ project postLoadDoIt: '' ] raise: Error! !

!MetacelloProjectSpecTestCase methodsFor: 'tests' stamp: ''!
testProjectMergeSpec
	| projectA projectB project |
	projectA := self projectSpec
		name: 'Project';
		className: 'ConfigurationOfProject';
		versionString: '1.0';
		loads: #('MyPackage');
		preLoadDoIt: #preLoadDoIt;
		postLoadDoIt: #postLoadDoIt;
		yourself.
	projectB := self projectSpec
		name: 'Project';
		className: 'ConfigurationOfProjectB';
		versionString: #stable;
		operator: #<;
		loads: #('MyPackage' 'MyTests');
		preLoadDoIt: #preLoadDoItB;
		postLoadDoIt: #postLoadDoItB;
		yourself.
	project := projectA mergeSpec: projectB.
	self assert: project name equals: 'Project'.
	self assert: project className equals: 'ConfigurationOfProjectB'.
	self assert: project versionString equals: #stable.
	self assert: project operator identicalTo: #<.
	self assert: project loads equals: #('MyPackage' 'MyTests').
	self assert: project preLoadDoIt value identicalTo: #preLoadDoItB.
	self assert: project postLoadDoIt value identicalTo: #postLoadDoItB! !

!MetacelloReferenceConfig methodsFor: 'accessing' stamp: ''!
project

	^ project ifNil: [ | constructor |
		"Construct Metacello project"
		constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self.
		project := constructor project ]! !

!MetacelloReferenceConfig methodsFor: 'baseline 1.0' stamp: ''!
baseline10: spec 
	<version: '1.0-baseline'>
	
	spec for: #common do: [
		"alternate methods for specifying author, blessing, description, timestamp, preLoadDoIt, postLoadDoit (not recommended)"
		spec blessing: [ spec value: #baseline. ].
		spec description: [ spec value: 'Descriptive comment'. ].
		spec author: [ spec value: 'dkh'. ].
		spec timestamp: [ spec value: '10/7/2009 14:40'. ].
		spec timestamp: [ spec value: (DateAndTime fromString: '10/7/2009 14:40'). ].
		"recommended methods for specifying author, blessing, description, timestamp, preLoadDoIt, postLoadDoit"
		"#development, #baseline, #release, #beta, etc."
		spec blessing: #baseline.									
		spec description: 'Descriptive comment'.
		spec author: 'dkh'.
		spec timestamp: (DateAndTime fromString: '10/7/2009 14:40').
		spec timestamp: '10/7/2009 14:40'.
		spec
			"Before loading packages or projects in this version, send #preloadForVersion to an instance of this config"
			preLoadDoIt: #preloadForVersion;
			"After loading packages or projects in this version, send #postloadForVersion to an instance of this config"
			postLoadDoIt: #postloadForVersion.
		spec repository: 'http://www.example.com/rr'.
		spec repository: 'http://www.example.com/private' username: 'foo' password: 'bar'.
		spec repositories: [
			"One or more repositories may be defined (MCReposioryGroup). Previous forms useful when specifying a single reposiory."
			spec 
				"directory-based repositories"
				repository: '/opt/mc/repository';
				repository: 'c:\pharo\myapp\repo\';
				"ftp-based repository ... note, supported in Pharo/Squeak only"					
				repository: 'ftp://ftp.example.com/repo';
				"dictionary-based repository ... repository stored at `Smalltalk at: #GlobalName`"		
				repository: 'dictionary://GlobalName';				
				repository: 'http://www.example.com/rr';
				repository: 'http://www.example.com/ar';
				repository: 'http://www.example.com/private' username: 'foo' password: 'bar' ].
		spec
			"Create or update a project reference named 'UI Support'"
			project: 'UI Support' with: [							
				"One or more of the following attributes may be defined or changed"
				spec
					"OPTIONAL: Name of config class (i.e., ConfigurationOfXXX), if not specified, className is assumed to be the 
					 name of the project prependended with 'ConfigurationOf'"
					className: 'ConfigurationOfUI';
					"Version of project to be loaded. if theversionString is not specified, then the latest version of the project is used."
					versionString: '1.0';
					"Before loading this project, send #preloadForProject to an instance of this config"
					preLoadDoIt: #preloadForProject;
					"After loading this project, send #postloadForProject to an instance of this config"
					postLoadDoIt: #postloadForProject;
					"OPTIONAL: Version comparison operator #= #~= #> #< #>= #<= #~> "
					operator: #~>; 	
					"OPTIONAL: List of packages to be loaded from project"															
					loads: #('UI-Core' );	
					"Optional: Name of package containing the config, by convention same as className"						
					file: 'ConfigurationOfUI';	
					"Repository where package resides"					
					repository: 'http://www.example.com/r' ];	
			"Create a new project reference to replace existing project reference"
			project: 'UI Support' overrides: [					
				"One or more of the following attributes may be defined"
				spec
					className: 'ConfigurationOfUINew';
					versionString: '1.0';
					operator: #>=;
					loads: #('UI-Core' 'UI-Tests' );
					repository: 'http://www.example.com/r' username: 'foo' password: 'bar' ];
			"Create project reference named 'UI Tests'"
		 	project: 'UI Tests' 
				"based on c copy of 'UI Support' project"									
				copyFrom: 'UI Support' 								
				with: [
					"One or more of the following attributes may be changed"
					spec
						className: 'ConfigurationOfUI';
						versionString: '1.0';
						operator: #~>;
						loads: #('UI-Core' 'UI-Tests' );
						repository: 'http://www.example.com/r'];
			"Change the versionString for 'UI Support' to '1.0.1'"
			project: 'UI Support' with: '1.0.1';	
			"Remove the project reference 'UI Tests'"				
			removeProject: 'UI Tests';
			"Multiple repositories for configuration - config may be found in either repository. 
			 Secondary repository is useful when primary repository may not be available"
			project: 'UI Multi' with: [							
				spec
					className: 'ConfigurationOfMulti';
					repository: 'http://www.example.com/r';
					repository: 'http://www.example.com/s' ].
		"Create or update 'Example-AddOn' package"								
		spec 
			package: 'Example-AddOn' with: [						
				"One or more of the following attributes may be defined or changed"
				spec
					"'Example-Core' must be loaded before 'Example-AddOn'" 
					requires: #('Example-Core' );
					"When 'Example-AddOn' is loaded, load 'Example-UI'"				
					includes: #('Example-UI' );
					"Explicitly oad version 'Example-AddOn-anon.3' of the package"					
					file: 'Example-AddOn-anon.3';					
					repositories: [
						spec 
							"Load 'Example-AddOn' from  the 'http://www.example.com/yar'"
							repository: 'http://www.example.com/yar'; 
							"or 'http://www.example.com/yas' repositores" 
							repository: 'http://www.example.com/yas']; 
					"Before loading 'Example-AddOn' send #preloadForAddOn to an instance of this config"
					preLoadDoIt: #preloadForAddOn;
					"After loading 'Example-AddOn' send #postloadForAddOn to an instance of this config"			
					postLoadDoIt: #postloadForAddOn ];
			"Create a new package to replace existing package"			
			package: 'Example-AddOn' overrides: [					
				"One or more of the following attributes may be defined"
				spec 
					requires: #('Example-Core' 'UI Support' );
					includes: #('Example-UI' );
					file: 'Example-AddOn-anon.7';
					supplyingAnswers: #( #('list of packages' 'Kernel* Collection*'));
					repository: 'http://www.example.com/or' username: 'foo' password: 'bar' ;
					preLoadDoIt: #preloadForAddOn;
					postLoadDoIt: #postloadForAddOn ];
			"Change the package version loaded"
			package: 'Example-AddOn' with:'Example-AddOn-anon.5';	
			"Create 'Example-Core' package in project"					
			package: 'Example-Core';								
			package: 'Example-Tests' with: [
				spec requires: #('Example-Core' ) ];
			package: 'Example-TestsUI' with: [
				spec requires: #('Example-UI' ) ];
			package: 'Example-UI' with: [
				spec requires: #('Example-AddOn' ) ];
			"Remove the package 'Example-Tests'"
			removePackage: 'Example-Tests'.						
		spec
			"Create or update the group 'default', adding 'Example-Core' and 'Example-AddOn' to the group."
			group: 'default' 
				with: 	#('Example-Core' 'Example-AddOn' );
			"Create the group 'default' to replace existing group, consisting of 'Example-Core' and 'Example-AddOn'"	
			group: 'default' 
				overrides:  #('Example-Core' 'Example-Tests' );	
			"Remove the group 'default'"
			removeGroup: 'default' ].! !

!MetacelloReferenceConfig class methodsFor: 'accessing' stamp: ''!
project
  "force new version as workaround for https://code.google.com/p/smalltalk-hub/issues/detail?id=21"

  ^ self new project! !

!MetacelloReferenceTestCase methodsFor: 'testing' stamp: ''!
testReferenceConfigPrintString
	| version string expected x y |
	version := MetacelloReferenceConfig project version: '1.0-baseline'.
	string := self conditionResult: version spec printString.
	expected := self expectedPrintString.
	1 to: string size do: [ :i | 
		(i > expected size or: [ (string at: i) ~= (expected at: i) ])
			ifTrue: [ x := string copyFrom: (i - 25 max: 1) to: (i + 25 min: string size).
				y := expected copyFrom: ((i - 25 max: 1) min: expected size) to: (i + 25 min: expected size).
				Array with: x with: y	"halt" ] ].
	self assert: string equals: expected! !

!MetacelloReferenceTestCase methodsFor: 'testing' stamp: ''!
testReferenceConfig
	| spec map string expected |
	spec := (MetacelloReferenceConfig project version: '1.0-baseline') spec.
	map := spec packages map.
	string := self conditionResult: (map at: 'Example-AddOn') printString.
	expected := 'spec 
	name: ''Example-AddOn'';
	requires: #(''Example-Core'' ''UI Support'' );
	includes: #(''Example-UI'' );
	supplyingAnswers: #( #( ''list of packages'' ''Kernel* Collection*'' ) );
	file: ''Example-AddOn-anon.5'';
	repository: ''http://www.example.com/or'' username: ''foo'' password: ''bar'';
	preLoadDoIt: #''preloadForAddOn'';
	postLoadDoIt: #''postloadForAddOn''.'.
	self assert: string equals: expected.

	string := (map at: 'Example-Core') printString.
	self assert: string equals: 'spec name: ''Example-Core'''.

	string := (map at: 'Example-TestsUI') printString.
	self
		assert: string
		equals:
			'spec 
	name: ''Example-TestsUI'';
	requires: #(''Example-UI'' ).'.

	string := (map at: 'UI Support') printString.
	self
		assert: string
		equals:
			'spec 
	name: ''UI Support'';
	projectReference: [
		spec
			className: ''ConfigurationOfUINew'';
			versionString: ''1.0.1'';
			operator: #''>='';
			loads: #(''UI-Core'' ''UI-Tests'' );
			repository: ''http://www.example.com/r'' username: ''foo'' password: ''bar'' ].'! !

!MetacelloReferenceTestCase methodsFor: 'testing' stamp: ''!
expectedPrintString
    ^ 'spec blessing: #''baseline''.
spec description: ''Descriptive comment''.
spec preLoadDoIt: #''preloadForVersion''.
spec postLoadDoIt: #''postloadForVersion''.
spec author: ''dkh''.
spec timestamp: ''10/7/2009 14:40''.
spec repositories: [
	spec
		repository: ''/opt/mc/repository'';
		repository: ''c:\pharo\myapp\repo\'';
		repository: ''dictionary://GlobalName'';
		repository: ''ftp://ftp.example.com/repo'';
		repository: ''http://www.example.com/ar'';
		repository: ''http://www.example.com/private'' username: ''foo'' password: ''bar'';
		repository: ''http://www.example.com/rr'' ].
spec 
	project: ''UI Support'' with: [
		spec
			className: ''ConfigurationOfUI'';
			versionString: ''1.0'';
			preLoadDoIt: #''preloadForProject'';
			postLoadDoIt: #''postloadForProject'';
			operator: #''~>'';
			loads: #(''UI-Core'' );
			repository: ''http://www.example.com/r'' ];
	project: ''UI Support'' overrides: [
		spec
			className: ''ConfigurationOfUINew'';
			versionString: ''1.0'';
			operator: #''>='';
			loads: #(''UI-Core'' ''UI-Tests'' );
			repository: ''http://www.example.com/r'' username: ''foo'' password: ''bar'' ];
	project: ''UI Tests'' copyFrom: ''UI Support'' with: [
		spec
			className: ''ConfigurationOfUI'';
			versionString: ''1.0'';
			operator: #''~>'';
			loads: #(''UI-Core'' ''UI-Tests'' );
			repository: ''http://www.example.com/r'' ];
	project: ''UI Support'' with: ''1.0.1'';
	removeProject: ''UI Tests'';
	project: ''UI Multi'' with: [
		spec
			className: ''ConfigurationOfMulti'';
			repository: ''http://www.example.com/r'';
			repository: ''http://www.example.com/s'' ].
spec 
	package: ''Example-AddOn'' with: [
		spec 
			requires: #(''Example-Core'' );
			includes: #(''Example-UI'' );
			file: ''Example-AddOn-anon.3'';
			repositories: [
				spec
					repository: ''http://www.example.com/yar'';
					repository: ''http://www.example.com/yas'' ];
			preLoadDoIt: #''preloadForAddOn'';
			postLoadDoIt: #''postloadForAddOn''. ];
	package: ''Example-AddOn'' overrides: [
		spec 
			requires: #(''Example-Core'' ''UI Support'' );
			includes: #(''Example-UI'' );
			supplyingAnswers: #( #( ''list of packages'' ''Kernel* Collection*'' ) );
			file: ''Example-AddOn-anon.7'';
			repository: ''http://www.example.com/or'' username: ''foo'' password: ''bar'';
			preLoadDoIt: #''preloadForAddOn'';
			postLoadDoIt: #''postloadForAddOn''. ];
	package: ''Example-AddOn'' with: ''Example-AddOn-anon.5'';
	package: ''Example-Core'';
	package: ''Example-Tests'' with: [
		spec requires: #(''Example-Core'' ). ];
	package: ''Example-TestsUI'' with: [
		spec requires: #(''Example-UI'' ). ];
	package: ''Example-UI'' with: [
		spec requires: #(''Example-AddOn'' ). ];
	removePackage: ''Example-Tests''.
spec 
	group: ''default'' with: #(''Example-Core'' ''Example-AddOn'' );
	group: ''default'' overrides: #(''Example-Core'' ''Example-Tests'' );
	removeGroup: ''default''.'! !

!MetacelloReferenceTestCase methodsFor: 'testing' stamp: ''!
conditionResult: resultString 
	"GemStone unconditionally prints Symbols with quotes, Squeak and Pharo do not"

	^((((((resultString 
		copyReplaceAll: '#preloadForAddOn' with: '#''preloadForAddOn''')
			copyReplaceAll: '#postloadForAddOn' with: '#''postloadForAddOn''')
				copyReplaceAll: '#baseline' with: '#''baseline''')
					copyReplaceAll: '#preloadForVersion' with: '#''preloadForVersion''')
						copyReplaceAll: '#postloadForVersion' with: '#''postloadForVersion''')
							copyReplaceAll: '#preloadForProject' with: '#''preloadForProject''')
								copyReplaceAll: '#postloadForProject' with: '#''postloadForProject'''! !

!MetacelloRemoveMemberSpec methodsFor: 'actions' stamp: ''!
applyToList: aListSpec

	aListSpec remove: self! !

!MetacelloRemoveMemberSpec methodsFor: 'actions' stamp: ''!
applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock

	removeBlock value: self! !

!MetacelloRemoveMemberSpec methodsFor: 'accessing' stamp: ''!
methodUpdateSelector

	^#remove:! !

!MetacelloRepositoriesSpec methodsFor: 'printing' stamp: ''!
configMethodOn: aStream indent: indent

	aStream 
		tab: indent; 
		nextPutAll: 'spec';
		cr.
	self configMethodCascadeOn: aStream indent: indent! !

!MetacelloRepositoriesSpec methodsFor: 'scripting' stamp: ''!
hasNoLoadConflicts: aMetacelloRepositoriesSpec
  | repositorySpecs anotherRepositorySpecs |
  repositorySpecs := self map values
    sort: [ :a :b | a description <= b description ].
  anotherRepositorySpecs := aMetacelloRepositoriesSpec map values
    sort: [ :a :b | a description <= b description ].
  repositorySpecs size ~= anotherRepositorySpecs size
    ifTrue: [ ^ false ].
  1 to: repositorySpecs size do: [ :index | 
    | repoSpec anotherRepoSpec |
    repoSpec := repositorySpecs at: index.
    anotherRepoSpec := anotherRepositorySpecs at: index.
    (repoSpec hasNoLoadConflicts: anotherRepoSpec)
      ifFalse: [ ^ false ] ].
  ^ true! !

!MetacelloRepositoriesSpec methodsFor: 'actions' stamp: ''!
add: aStringOrSpec

	aStringOrSpec addToMetacelloRepositories: self! !

!MetacelloRepositoriesSpec methodsFor: 'actions' stamp: ''!
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: ''!
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: 'construction' stamp: ''!
repository: anObject constructor: aVersionConstructor
    aVersionConstructor repositoryForRepositories: anObject! !

!MetacelloRepositoriesSpec methodsFor: 'construction' stamp: ''!
repository: aString username: username password: password constructor: aVersionConstructor
    aVersionConstructor repositoryForRepositories: aString username: username password: password! !

!MetacelloRepositoriesSpec methodsFor: 'scripting' stamp: ''!
compareEqual: aMetacelloProjectSpec
    | repositorySpecs anotherRepositorySpecs |
    repositorySpecs := (self map values sort: [ :a :b | a description <= b description ])
        collect: [ :each | each description ].
    anotherRepositorySpecs := (aMetacelloProjectSpec map values sort: [ :a :b | a description <= b description ])
        collect: [ :each | each description ].
    ^ repositorySpecs = anotherRepositorySpecs! !

!MetacelloRepositoriesSpec methodsFor: 'actions' stamp: ''!
remove: aRepositorySpec

	aRepositorySpec removeFromMetacelloRepositories: self! !

!MetacelloRepositoriesSpec methodsFor: 'scripting' stamp: ''!
metacelloRegistrationHash
    ^ ((self map values sort: [ :a :b | a description <= b description ]) collect: [ :each | each description ]) hash! !

!MetacelloRepositoriesSpec methodsFor: 'actions' stamp: ''!
merge: aRepositorySpec

	aRepositorySpec mergeIntoMetacelloRepositories: self! !

!MetacelloRepositoriesSpec methodsFor: 'scripting' stamp: ''!
canUpgradeTo: aMetacelloRepositoriesSpec
  | repositorySpecs anotherRepositorySpecs |
  repositorySpecs := self map values
    sort: [ :a :b | a description <= b description ].
  anotherRepositorySpecs := aMetacelloRepositoriesSpec map values
    sort: [ :a :b | a description <= b description ].
  repositorySpecs size ~= anotherRepositorySpecs size
    ifTrue: [ ^ false ].
  1 to: repositorySpecs size do: [ :index | 
    | repoSpec anotherRepoSpec |
    repoSpec := repositorySpecs at: index.
    anotherRepoSpec := anotherRepositorySpecs at: index.
    (repoSpec canUpgradeTo: anotherRepoSpec)
      ifTrue: [ ^ true ] ].
  ^ false! !

!MetacelloRepositoriesSpec methodsFor: 'actions' stamp: ''!
repository: aStringOrSpec

	aStringOrSpec addToMetacelloRepositories: self! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemoveB
    | repositories removed |
    repositories := self repositoriesSpec.
    repositories
        add:
            (self repositorySpec
                description: 'http://example.com/repository';
                username: 'dkh';
                password: 'password';
                yourself).
    repositories
        remove:
            {(self repositorySpec
                description: 'http://example.com/repository';
                yourself)}.
    removed := false.
    repositories map at: 'http://example.com/repository' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testMergeA
	| repositories repository |
	repositories := self repositoriesSpec.
	repositories
		add:
			(self repositorySpec
				description: 'http://example.com/repository';
				username: 'dkh';
				password: 'password';
				yourself);
		merge:
			(self repositorySpec
				description: 'http://example.com/repository';
				username: 'DaleHenrichs';
				password: 'secret';
				yourself).
	repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: 'http://example.com/repository'.
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'DaleHenrichs'.
	self assert: repository password equals: 'secret'! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddE
	| repositories repository |
	repositories := self repositoriesSpec.
	repositories
		repository: 'http://example.com/repository' username: 'dkh' password: 'password';
		repository: '/opt/gemstone/repository'.
	repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: 'http://example.com/repository'.
	self assert: repository type equals: 'http'.
	repository := repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: '/opt/gemstone/repository'.
	self assert: repository type equals: 'directory'! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddA
	| repositories repository |
	repositories := self repositoriesSpec.
	repositories
		add:
			(self repositorySpec
				description: 'http://example.com/repository';
				username: 'dkh';
				password: 'password';
				yourself);
		add:
			(self repositorySpec
				description: 'http://example.com/repository';
				username: 'DaleHenrichs';
				password: 'secret';
				yourself).
	repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: 'http://example.com/repository'.
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'DaleHenrichs'.
	self assert: repository password equals: 'secret'! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddB
	| repositories repository |
	repositories := self repositoriesSpec.
	repositories
		add:
			(self repositorySpec
				description: 'http://example.com/repository';
				username: 'dkh';
				password: 'password';
				yourself);
		add: '/opt/gemstone/repository'.
	repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: 'http://example.com/repository'.
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'dkh'.
	self assert: repository password equals: 'password'.
	repository := repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: '/opt/gemstone/repository'.
	self assert: repository type equals: 'directory'! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemoveA
    | repositories removed |
    repositories := self repositoriesSpec.
    repositories
        add:
            (self repositorySpec
                description: 'http://example.com/repository';
                username: 'dkh';
                password: 'password';
                yourself).
    repositories
        remove:
            (self repositorySpec
                description: 'http://example.com/repository';
                yourself).
    removed := false.
    repositories map at: 'http://example.com/repository' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemoveC
    | repositories removed |
    repositories := self repositoriesSpec.
    repositories
        add:
            (self repositorySpec
                description: 'http://example.com/repository';
                username: 'dkh';
                password: 'password';
                yourself).
    repositories remove: {'http://example.com/repository'}.
    removed := false.
    repositories map at: 'http://example.com/repository' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddC
	| repositories repository |
	repositories := self repositoriesSpec.
	repositories add: #('http://example.com/repository' '/opt/gemstone/repository').
	repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: 'http://example.com/repository'.
	self assert: repository type equals: 'http'.
	repository := repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: '/opt/gemstone/repository'.
	self assert: repository type equals: 'directory'! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testCopyTo
    | repositories |
    repositories := self repositoriesSpec.
    repositories
        add:
            (self repositorySpec
                description: 'http://example.com/repository';
                username: 'dkh';
                password: 'password';
                yourself).
    self
        should: [ 
            repositories
                copy: 'http://example.com/repository'
                to:
                    (self repositorySpec
                        description: 'http://example.com/alternate/repository';
                        yourself) ]
        raise: Error! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testMergeB
	| repositories repository |
	repositories := self repositoriesSpec.
	repositories
		add:
			(self repositorySpec
				description: 'http://example.com/repository';
				username: 'dkh';
				password: 'password';
				yourself);
		merge: 'http://example.com/repository'.
	repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: 'http://example.com/repository'.
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'dkh'.
	self assert: repository password equals: 'password'! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testRemoveD
    | repositories removed |
    repositories := self repositoriesSpec.
    repositories
        add:
            (self repositorySpec
                description: 'http://example.com/repository';
                username: 'dkh';
                password: 'password';
                yourself).
    repositories remove: 'http://example.com/repository'.
    removed := false.
    repositories map at: 'http://example.com/repository' ifAbsent: [ removed := true ].
    self assert: removed! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testMergeC
	| repositories repository |
	repositories := self repositoriesSpec.
	repositories
		add:
			(self repositorySpec
				description: 'http://example.com/repository';
				username: 'dkh';
				password: 'password';
				yourself);
		merge:
			{(self repositorySpec
				description: 'http://example.com/repository';
				password: 'secret';
				yourself) . (self repositorySpec
				description: 'http://example.com/repository';
				username: 'DaleHenrichs';
				yourself)}.
	repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: 'http://example.com/repository'.
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'DaleHenrichs'.
	self assert: repository password equals: 'secret'! !

!MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: ''!
testAddF
	| repositories repository |
	repositories := self repositoriesSpec.
	repositories
		repository:
			(self repositorySpec
				description: 'http://example.com/repository';
				username: 'dkh';
				password: 'password';
				yourself);
		repository:
			(self repositorySpec
				description: 'http://example.com/repository';
				username: 'DaleHenrichs';
				password: 'secret';
				yourself).
	repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ].
	self assert: repository description equals: 'http://example.com/repository'.
	self assert: repository type equals: 'http'.
	self assert: repository username equals: 'DaleHenrichs'.
	self assert: repository password equals: 'secret'! !

!MetacelloRepositorySpec methodsFor: 'printing' stamp: ''!
configMethodOn: aStream indent: indent

	aStream 
		tab: indent; 
		nextPutAll: 'spec '.
	self configMethodCascadeOn: aStream lastCascade: true! !

!MetacelloRepositorySpec methodsFor: 'mc support' stamp: ''!
hasNoLoadConflicts: aMetacelloRepositorySpec
  self description = aMetacelloRepositorySpec description
    ifTrue: [ ^ true ].
  self type = aMetacelloRepositorySpec type
    ifFalse: [ 
      "if the types are different then we don't need to create the repoitory to 
       know that there will be conflicts"
      ^ false ].
  (#('github' 'gitorious' 'bitbucket') includes: self type)
    ifTrue: [ 
      ^ self createRepository
        hasNoLoadConflicts: aMetacelloRepositorySpec createRepository ].
  ^ false! !

!MetacelloRepositorySpec methodsFor: 'printing' stamp: ''!
configMethodCascadeOn: aStream lastCascade: lastCascade

	aStream nextPutAll: 'repository: ', self description printString.
	(self username isEmpty not or: [ self password isEmpty not ])
		ifTrue: [ aStream nextPutAll: ' username: ', self username printString, ' password: ', self password printString ].
	lastCascade ifFalse: [ aStream nextPut: $;; cr ].! !

!MetacelloRepositorySpec methodsFor: 'accessing' stamp: ''!
description: aString

	description := aString! !

!MetacelloRepositorySpec methodsFor: 'mc support' stamp: ''!
createRepository
  | repo |
  repo := self project createRepository: self.
  ^ MCRepositoryGroup default repositories
    detect: [ :each | each = repo ]
    ifNone: [ 
      MCRepositoryGroup default addRepository: repo.
      repo ]! !

!MetacelloRepositorySpec methodsFor: 'querying' stamp: ''!
description

	^description! !

!MetacelloRepositorySpec methodsFor: 'accessing' stamp: ''!
password: aString

	password := aString! !

!MetacelloRepositorySpec methodsFor: 'accessing' stamp: ''!
type: aString

	type := aString! !

!MetacelloRepositorySpec methodsFor: 'querying' stamp: ''!
password

	password == nil ifTrue: [ password := '' ].
	^password! !

!MetacelloRepositorySpec methodsFor: 'private' stamp: ''!
mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec

	aMetacelloRepositoriesSpec addMember: 
		(aMetacelloRepositoriesSpec mergeMember 
			name: self name;
			spec: self;
			yourself)! !

!MetacelloRepositorySpec methodsFor: 'merging' stamp: ''!
mergeMap
    | map |
    map := super mergeMap.
    map at: #'description' put: description.
    map at: #'type' put: self type.
    map at: #'username' put: username.
    map at: #'password' put: password.
    ^ map! !

!MetacelloRepositorySpec methodsFor: 'querying' stamp: ''!
name

	^self description! !

!MetacelloRepositorySpec methodsFor: 'private' stamp: ''!
removeFromMetacelloRepositories: aMetacelloRepositoriesSpec

	aMetacelloRepositoriesSpec addMember: 
		(aMetacelloRepositoriesSpec removeMember 
			name: self name;
			spec: self;
			yourself)! !

!MetacelloRepositorySpec methodsFor: 'adding' stamp: ''!
addToMetacelloRepositories: aMetacelloRepositoriesSpec

	aMetacelloRepositoriesSpec addMember: 
		(aMetacelloRepositoriesSpec addMember 
			name: self name;
			spec: self;
			yourself)! !

!MetacelloRepositorySpec methodsFor: 'accessing' stamp: ''!
username: aString

	username := aString! !

!MetacelloRepositorySpec methodsFor: 'private' stamp: ''!
extractTypeFromDescription

	^MetacelloPlatform current extractTypeFromDescription: self description! !

!MetacelloRepositorySpec methodsFor: 'querying' stamp: ''!
username

	username == nil ifTrue: [ username := '' ].
	^username! !

!MetacelloRepositorySpec methodsFor: 'querying' stamp: ''!
type

	type == nil ifTrue: [ type := self extractTypeFromDescription ].
	^type! !

!MetacelloRepositorySpec methodsFor: 'mc support' stamp: ''!
canUpgradeTo: aMetacelloRepositorySpec
  self description = aMetacelloRepositorySpec description
    ifTrue: [ ^ true ].
  (#('github' 'gitorious' 'bitbucket') includes: self type)
    ifTrue: [ ^ self createRepository canUpgradeTo: aMetacelloRepositorySpec createRepository ].
  ^ false! !

!MetacelloRepositorySpecTestCase methodsFor: 'tests' stamp: ''!
testRepositorySpec
	| repository |
	repository := self repositorySpec
		description: '/opt/gemstone/repository';
		username: 'dkh';
		password: 'password';
		type: 'directory';
		yourself.
	self assert: repository name equals: repository description.
	self assert: repository description equals: '/opt/gemstone/repository'.
	self assert: repository username equals: 'dkh'.
	self assert: repository password equals: 'password'.
	self assert: repository type equals: 'directory'.
	repository := self repositorySpec
		description: '/opt/gemstone/repository';
		yourself.
	self assert: repository description equals: '/opt/gemstone/repository'.
	self assert: repository type equals: 'directory'.
	repository := self repositorySpec
		description: 'http://example.com/repository';
		yourself.
	self assert: repository description equals: 'http://example.com/repository'.
	self assert: repository type equals: 'http'! !

!MetacelloRepositorySpecTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloMCProject! !

!MetacelloRepositorySpecTestCase methodsFor: 'tests' stamp: ''!
testRepositoryMergeSpec
	| repositoryA repositoryB repository |
	repositoryA := self repositorySpec
		description: '/opt/gemstone/repository';
		username: 'dkh';
		password: 'password';
		type: 'directory';
		yourself.
	repositoryB := self repositorySpec
		description: 'http://example.com/repository';
		password: 'secret';
		yourself.
	repository := repositoryA mergeSpec: repositoryB.
	self assert: repository description equals: 'http://example.com/repository'.
	self assert: repository username equals: 'dkh'.
	self assert: repository password equals: 'secret'.
	self assert: repository type equals: 'http'! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: ''!
testDictionaryRepository
	| project pkg repoSpec repo |
	project := self project.
	pkg := (project version: '1.5-baseline') packageNamed: 'Example-Core'.
	repoSpec := pkg repositorySpecs first.
	self assert: repoSpec type equals: 'dictionary'.
	repo := repoSpec createRepository.
	self assert: repo class identicalTo: MCDictionaryRepository.
	self assert: repo dictionary identicalTo: (testingEnvironment at: #Metacello_Platform_Test_GlobalDictionary) dictionary! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'running' stamp: ''!
tearDown
    
    testingEnvironment removeKey: #'Metacello_Platform_Test_GlobalDictionary' ifAbsent: [  ].
	super tearDown! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: ''!
testAsRepositorySpecFor
	| project testBlock |
	project := self project.
	testBlock := [ :pkg :expectedType1 :expectedType2 | 
	| repoSpec1 repo repoSpec2 |
	repoSpec1 := pkg repositorySpecs first.
	self assert: repoSpec1 type equals: expectedType1.
	repo := repoSpec1 createRepository.
	repoSpec2 := repo asRepositorySpecFor: project.
	self assert: repoSpec2 type equals: expectedType2.
	expectedType1 = expectedType2
		ifTrue: [ self assert: repoSpec1 description equals: repoSpec2 description ]
		ifFalse:
			[ "special case for standard directory type that defaults to MCServerDirectoryRepository" self assert: (repoSpec1 description copyFrom: 'server://' size + 1 to: repoSpec1 description size) equals: repoSpec2 description ] ].
	testBlock value: ((project version: '1.0-baseline') packageNamed: 'Example-Core') value: 'directory' value: 'directory'.
	testBlock value: ((project version: '1.3-baseline') packageNamed: 'Example-Core') value: 'ftp' value: 'ftp'.
	testBlock value: ((project version: '1.4-baseline') packageNamed: 'Example-Core') value: 'http' value: 'http'.
	testBlock value: ((project version: '1.5-baseline') packageNamed: 'Example-Core') value: 'dictionary' value: 'dictionary'! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: ''!
testDirectoryRepository
	| project pkg repoSpec repo |
	project := self project.
	pkg := (project version: '1.0-baseline') packageNamed: 'Example-Core'.
	repoSpec := pkg repositorySpecs first.
	self assert: repoSpec type equals: 'directory'.
	repo := repoSpec createRepository.
	self assert: repo class identicalTo: MCDirectoryRepository.
	self assert: repo description equals: self directoryForPlatform! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: ''!
testFtpRepository
	| project pkg repoSpec repo |
	project := self project.
	pkg := (project version: '1.3-baseline') packageNamed: 'Example-Core'.
	repoSpec := pkg repositorySpecs first.
	self assert: repoSpec type equals: 'ftp'.
	repo := repoSpec createRepository.
	self assert: repo class identicalTo: MCFtpRepository.
	self assert: repo host equals: 'ftp.example.com'.
	self assert: repo directory equals: 'examples'! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'accessing' stamp: ''!
directoryForPlatform 
	| dir |
	"I don't know how to do this in other platforms (not Pharo)"
	dir := '/opt/mcexamples'.
	(Smalltalk classNamed: #OSPlatform) ifNotNil: [ :c | 
		c current isWindows
			ifTrue: [ dir := 'c:\opt\mcexamples' ] ].
	^ dir! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'baselines' stamp: ''!
baseline14: spec
    <version: '1.4-baseline'>
    spec
        for: #'common'
        do: [ 
            spec
                package: 'Example-Core'
                with: [ 
                    spec
                        includes: 'Example-AddOn';
                        file: 'Example-Core-anon.1';
                        repository: 'http://example.com/examples' ] ]! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: ''!
testFileTreeRepository
	"must create repository against an existing directory"

	| project pkg repoSpec repo fileUtils workingDir tempDir repoDir |
	fileUtils := MCFileTreeFileUtils current.
	workingDir := fileUtils default.
	tempDir := fileUtils directoryFromPath: 'temp' relativeTo: workingDir.
	[ fileUtils ensureDirectoryExists: tempDir.
	repoDir := fileUtils directoryFromPath: 'repo' relativeTo: tempDir.
	fileUtils ensureDirectoryExists: repoDir.
	project := self project.
	pkg := (project version: '1.6-baseline') packageNamed: 'Example-Core'.
	repoSpec := pkg repositorySpecs first.
	self assert: repoSpec type equals: 'filetree'.
	repo := repoSpec createRepository.
	self assert: repo class identicalTo: (testingEnvironment at: #MCFileTreeRepository ifAbsent: [  ]).
	MetacelloNotification signal: ('testFileTreeRepository: ' , (fileUtils directoryFromPath: 'temp/repo' relativeTo: fileUtils default) fullName).
	self assert: repo description equals: 'filetree://' , (fileUtils directoryFromPath: 'temp/repo' relativeTo: fileUtils default) fullName ]
		ensure: [ (fileUtils directoryExists: tempDir) ifTrue: [ fileUtils deleteAll: tempDir ] ]! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'accessing' stamp: ''!
project
     "force new version as workaround for https://code.google.com/p/smalltalk-hub/issues/detail?id=21"

	| constructor project |
	"Construct Metacello project"
	constructor := MetacelloVersionConstructor on: self.
	project := constructor project.
	project loader: MetacelloNullRecordingMCSpecLoader new.
	^project! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'baselines' stamp: ''!
baseline16: spec
  <version: '1.6-baseline'>
  spec
    for: #'common'
    do: [ 
      spec
        package: 'Example-Core'
        with: [ 
          spec
            includes: 'Example-AddOn';
            file: 'Example-Core-anon.1';
            repository:
                'filetree://' , MCFileTreeFileUtils current default fullName , '/temp/repo' ] ]! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'baselines' stamp: ''!
baseline10: spec
    <version: '1.0-baseline'>
    spec
        for: #'common'
        do: [ 
            spec
                package: 'Example-Core'
                with: [ 
                    spec
                        includes: 'Example-AddOn';
                        file: 'Example-Core-anon.1';
                        repository: self directoryForPlatform ] ]! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: ''!
testHttpRepository
	| project pkg repoSpec repo |
	project := self project.
	pkg := (project version: '1.4-baseline') packageNamed: 'Example-Core'.
	repoSpec := pkg repositorySpecs first.
	self assert: repoSpec type equals: 'http'.
	repo := repoSpec createRepository.
	self assert: repo class identicalTo: MCHttpRepository.
	self assert: repo description equals: 'http://example.com/examples'! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'baselines' stamp: ''!
baseline13: spec
    <version: '1.3-baseline'>
    spec
        for: #'squeakCommon'
        do: [ 
            spec
                package: 'Example-Core'
                with: [ 
                    spec
                        includes: 'Example-AddOn';
                        file: 'Example-Core-anon.1';
                        repository: 'ftp://ftp.example.com/examples' ] ]! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'baselines' stamp: ''!
baseline15: spec
    <version: '1.5-baseline'>
    spec
        for: #'common'
        do: [ 
            spec
                package: 'Example-Core'
                with: [ 
                    spec
                        includes: 'Example-AddOn';
                        file: 'Example-Core-anon.1';
                        repository: 'dictionary://Metacello_Platform_Test_GlobalDictionary' ] ]! !

!MetacelloRepositorySqueakCommonTestCase methodsFor: 'running' stamp: ''!
setUp
    super setUp.
    testingEnvironment
        at: #'Metacello_Platform_Test_GlobalDictionary'
        put:
            (MCDictionaryRepository new
                description: 'dictionary://Metacello_Platform_Test_GlobalDictionary';
                yourself)! !

!MetacelloResolveProjectUpgrade methodsFor: 'accessing' stamp: ''!
existingProjectRegistration: anObject
	existingProjectRegistration := anObject! !

!MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: ''!
disallow
    "default action"

    self resume: self existingProjectRegistration! !

!MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: ''!
defaultAction
    "Result of signal should be the projectRegistration to be used to perform the load ... default is to disallow"

    ^ self existingProjectRegistration! !

!MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: ''!
useExisting
  "to be deprecated: useLoaded"

  self disallow! !

!MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: ''!
useLoaded
  self disallow! !

!MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: ''!
useNew
  "to be deprecated: useIncoming"

  self allow! !

!MetacelloResolveProjectUpgrade methodsFor: '*Iceberg-Metacello' stamp: ''!
projectName
	
	^ self existingProjectRegistration projectName! !

!MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: ''!
allowEvenIfLocked
  "for internal ScriptEngine use only. from the Scripting API use:
		onLocked: [:ex | ex allow]
		"

  self resume: self newProjectRegistration! !

!MetacelloResolveProjectUpgrade methodsFor: 'accessing' stamp: ''!
existingProjectRegistration
	^ existingProjectRegistration! !

!MetacelloResolveProjectUpgrade methodsFor: 'accessing' stamp: ''!
newProjectRegistration: anObject
	newProjectRegistration := anObject! !

!MetacelloResolveProjectUpgrade methodsFor: 'accessing' stamp: ''!
newProjectRegistration
	^ newProjectRegistration! !

!MetacelloResolveProjectUpgrade methodsFor: 'handlers' stamp: ''!
handleOnDownGrade: onDownGradeBlock onUpgrade: onUpgradeBlock
    self subclassResponsibility! !

!MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: ''!
allow
    self checkAllowed.
    self resume: self newProjectRegistration! !

!MetacelloResolveProjectUpgrade methodsFor: 'private' stamp: ''!
checkAllowed
  self existingProjectRegistration locked
    ifTrue: [ 
      self
        resume:
          (MetacelloAllowLockedProjectChange new
            operationString: self operationString;
            existingProjectRegistration: self existingProjectRegistration;
            newProjectRegistration: self newProjectRegistration;
            signal) ]! !

!MetacelloResolveProjectUpgrade methodsFor: 'accessing' stamp: ''!
operationString
    self subclassResponsibility! !

!MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: ''!
useIncoming
  self allow! !

!MetacelloScriptApiExecutor commentStamp: ''!
MetacelloScriptExecutor decodes script args and launches MetacelloScriptEngine to run for each projectSpec encounters...i,e., primarily here to handl array and block args to configuration:, baseline: or project:.!
!MetacelloScriptApiExecutor methodsFor: 'execution callback' stamp: ''!
executeString: aString do: projectSpecBlock
  singleRoot ifNil: [ self singleRoot: true ].
  (projectSpecGenerator projectSpecCreationBlock value: aString)
    do: [ :projectSpec | 
      projectSpec
        ifNotNil: [ projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ] ]! !

!MetacelloScriptApiExecutor methodsFor: 'execution callback' stamp: ''!
projectSpecsFromRepositoryArg
    | spec repo projectSpecs |
    repositoryArg ifNil: [ ^ #() ].
    spec := (projectSpecGenerator projectSpecCreationBlock value: 'xxx') first.
    repo := spec project createRepository: (spec project repositorySpec description: repositoryArg).
    projectSpecs := OrderedCollection new.
    ((Gofer new disablePackageCache
        repository: repo;
        allResolved) collect: [ :resolvedReference | resolvedReference packageName ]) asSet
        do: [ :packageName | 
            (projectSpecGenerator projectSpecCreationBlock value: (MetacelloScriptEngine baseNameOf: packageName))
                do: [ :projectSpec | 
                    projectSpec className = packageName
                        ifTrue: [ projectSpecs add: (self applyArgsToProjectSpec: projectSpec copy) ] ] ].
    ^ projectSpecs! !

!MetacelloScriptApiExecutor methodsFor: 'execution callback' stamp: ''!
executeCollection: aCollection do: projectSpecBlock
    self projectSpecsFromRepositoryArg
        do: [ :projectSpec | 
            (aCollection includes: (MetacelloScriptEngine baseNameOf: projectSpec className))
                ifTrue: [ projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ] ]! !

!MetacelloScriptApiExecutor methodsFor: '*Iceberg-Metacello-Integration' stamp: ''!
execute: statements

	MetacelloPlatform current withMetacelloLoadSessionDo: [ 
		super execute: statements ]! !

!MetacelloScriptApiExecutor methodsFor: 'execution callback' stamp: ''!
executeBlock: selectBlock do: projectSpecBlock
    (self projectSpecsFromRepositoryArg select: selectBlock)
        do: [ :projectSpec | projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ]! !

!MetacelloScriptEngine commentStamp: ''!
MetacelloScriptEngine runs the execution of the script for one projectSpec!
!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleLookupBaselineSpecForEnsureLoad: exception
  "if requested and registered don't compare equal, then ensure the new baseline is loaded"

  | requested registered |
  requested := exception projectSpec.
  registered := self lookupProjectSpecFor: exception projectSpec.
  ^ exception resume: (registered compareEqual: requested) not! !

!MetacelloScriptEngine methodsFor: 'project lookup' stamp: ''!
setDefaultsAndValidate: aProjectSpec
  "NOTE: aProjectSpec has defaults assigned if versionString or repository missing"

  | issues |
  issues := aProjectSpec
    validateForScriptLoad: self
    withDefaultVersionString: self defaultVersionString
    withDefaultRepositoryDecription: self defaultRepositoryDescription.
  issues isEmpty
    ifTrue: [ ^ self ].
  (MetacelloValidationFailure
    issues: issues
    message: 'Project spec validation failure') signal! !

!MetacelloScriptEngine methodsFor: 'accessing' stamp: ''!
projectSpec
    ^ projectSpec! !

!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleLookupProjectSpecForLoad: exception
  "if overrideProjectSpec is nil, use currentVersion in image, ignoreImage is false"

  | requested override |
  requested := exception projectSpec.
  override := self useCurrentVersion
    ifTrue: [ 
      "don't do lookup in registry if we expect to use the #currentVersion calculation"
      nil ]
    ifFalse: [ 
      | registered |
      registered := self lookupProjectSpecFor: exception projectSpec.
      (registered compareEqual: requested)
        ifFalse: [ 
          "counts as override, only if they differ in some aspect"
          override := registered ] ].
  ^ exception
    resume:
      (MetacelloProjectSpecForLoad new
        projectSpec: requested;
        useDetermineVersionForLoad: self useCurrentVersion;
        overrideProjectSpec: override;
        yourself)! !

!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleEnsureProjectLoadedForDevelopment: exception
    "if useCurrentVersion resume with true, else resume with false"

    ^ exception resume: self useCurrentVersion! !

!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleDowngrade: exception
    ^ (self options at: #'onDowngrade' ifAbsent: [ ^ exception pass ])
        cull: exception
        cull: exception existingProjectRegistration
        cull: exception newProjectRegistration! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
fetch: required
    self
        fetchRecord: [ :version | 
            required isEmpty
                ifTrue: [ version fetch ]
                ifFalse: [ version fetch: required ] ]
        required: required! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
record: required
    self
        fetchRecord: [ :version | 
            required isEmpty
                ifTrue: [ version record ]
                ifFalse: [ version record: required ] ]
        required: required! !

!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleConflict: exception
    ^ (self options at: #'onConflict' ifAbsent: [ ^ exception pass ])
        cull: exception
        cull: exception existingProjectRegistration
        cull: exception newProjectRegistration! !

!MetacelloScriptEngine methodsFor: 'project lookup' stamp: ''!
getBaselineUnconditionalLoad: unconditionalLoad
  | spec |
  spec := self projectSpec.
  Smalltalk
    at: spec className asSymbol
    ifPresent: [ :cl | 
      unconditionalLoad
        ifFalse: [ ^ cl ] ].
  spec := self lookupProjectSpecFor: spec.
  [ spec projectPackage load ]
    on: MetacelloIgnorePackageLoaded
    do: [ :ex | 
      "see https://github.com/dalehenrich/metacello-work/issues/244 ... uncoditionally load
        baseline"
      ex resume: true ].
  ^ Smalltalk at: spec className asSymbol! !

!MetacelloScriptEngine methodsFor: 'accessing' stamp: ''!
root
	^ root! !

!MetacelloScriptEngine methodsFor: 'defaults' stamp: ''!
defaultVersionString
    ^ self class defaultVersionString! !

!MetacelloScriptEngine methodsFor: 'defaults' stamp: ''!
defaultRepositoryDescription
    ^ self class defaultRepositoryDescription! !

!MetacelloScriptEngine methodsFor: 'accessing' stamp: ''!
projectSpec: aProjectSpec
    projectSpec := aProjectSpec! !

!MetacelloScriptEngine methodsFor: 'accessing' stamp: ''!
root: anObject
	root := anObject! !

!MetacelloScriptEngine methodsFor: 'options' stamp: ''!
silently
    ^ self options at: #'silently' ifAbsent: [ false ]! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
unregister
  | spec |
  self setDefaultsAndValidate: self projectSpec copy.	"don't add defaults"
  spec := self projectSpec.
  MetacelloProjectRegistration
    registrationForProjectSpec: spec
    ifAbsent: [ :ignored |  ]
    ifPresent: [ :existing :new | existing unregisterProject ].
  self root: spec! !

!MetacelloScriptEngine methodsFor: 'options' stamp: ''!
cacheRepository
    ^ (MetacelloMCProject new repositorySpec description: (self options at: #'cacheRepository' ifAbsent: [ ^ nil ]))
        createRepository! !

!MetacelloScriptEngine methodsFor: 'project lookup' stamp: ''!
lookupProjectSpecFor: aProjectSpec
	"if there is no conflict, choose new spec"
	| registration |
	
	registration := MetacelloProjectRegistration
		registrationForProjectSpec: aProjectSpec
		ifAbsent: [ :new | new ]
		ifPresent: [ :existing :new | self resolvePresentProject: existing new: new ].
  
	^ registration projectSpec! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
list
  self setDefaultsAndValidateProjectSpec.
  self root: self projectSpec! !

!MetacelloScriptEngine methodsFor: 'accessing' stamp: ''!
options: aDictionary
    options := aDictionary! !

!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleProjectSpecLoaded: exception
    MetacelloProjectRegistration
        registrationForProjectSpec: exception projectSpec
        ifAbsent: [ :new | 
            new
                loadedInImage: true;
                registerProject ]
        ifPresent: [ :existing :new | 
            "unconditionally merge new with existing (updates registration)"
            existing
                copyOnWrite: [ :existingCopy | 
                    existingCopy
                        loadedInImage: true;
                        merge: new ] ].
    exception resume! !

!MetacelloScriptEngine methodsFor: 'private' stamp: ''!
resolvePresentProject: existingRegistration new: newRegistration

	existingRegistration locked 
		ifTrue: [ ^ existingRegistration ].

	^ (existingRegistration hasLoadConflicts: newRegistration)
		ifTrue: [
			((existingRegistration canUpgradeTo: newRegistration)
				ifTrue: [ MetacelloAllowProjectUpgrade new ]
				ifFalse: [
					(existingRegistration canDowngradeTo: newRegistration)
						ifTrue: [ MetacelloAllowProjectDowngrade new ]
						ifFalse: [ MetacelloAllowConflictingProjectUpgrade new ] ])
			existingProjectRegistration: existingRegistration;
			newProjectRegistration: newRegistration;
			signal ]
		ifFalse: [ newRegistration ]! !

!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleWarning: exception
  ^ (self options at: #'onWarning' ifAbsent: [ ^ exception pass ])
    cull: exception! !

!MetacelloScriptEngine methodsFor: 'project lookup' stamp: ''!
setDefaultsAndValidateProjectSpec
  "NOTE: projectSpec has defaults assigned if versionString or repository missing"

  self setDefaultsAndValidate: self projectSpec! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
unlock
  | spec |
  MetacelloProjectRegistration
    copyRegistryRestoreOnErrorWhile: [ 
      self setDefaultsAndValidate: self projectSpec copy.	"don't add defaults"
      spec := self projectSpec.
      MetacelloProjectRegistration
        registrationForProjectSpec: spec
        ifAbsent: [ :ignored |  ]
        ifPresent: [ :existing :new | existing copyOnWrite: [ :existingCopy | existingCopy locked: false ] ].
      self root: spec ]! !

!MetacelloScriptEngine methodsFor: 'options' stamp: ''!
repositoryOverrides
    ^ (self options at: #'repositoryOverrides' ifAbsent: [ ^ nil ])
        collect: [ :description | (MetacelloMCProject new repositorySpec description: description) createRepository ]! !

!MetacelloScriptEngine methodsFor: 'project lookup' stamp: ''!
getConfigurationUnconditionalLoad: unconditionalLoad
    | spec |
    spec := self projectSpec.
    Smalltalk
        at: spec className asSymbol
        ifPresent: [ :cl | 
            unconditionalLoad
                ifFalse: [ ^ cl ] ].
    (spec := self lookupProjectSpecFor: spec) projectPackage load.
    ^ Smalltalk at: spec className asSymbol! !

!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleNotificationsForAction: actionBlock
  [ 
  [ 
  [ 
  actionBlock
    on:
      MetacelloLookupProjectSpec , MetacelloLookupProjectSpecForLoad
        , MetacelloProjectSpecLoadedNotification
        , MetacelloScriptEnsureProjectLoadedForDevelopment
        , MetacelloLookupBaselineSpecForEnsureLoad
    do: [ :ex | 
      "lookup and registration handlers need to be innermost set of handlers ...they may throw option notifications"
      ex handleResolutionFor: self ] ]
    on:
      MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade
        , MetacelloAllowConflictingProjectUpgrade
    do: [ :ex | 
      "option handlers need to be outermost set of handlers ... last line of defense before users are involved"
      ex handleResolutionFor: self ] ]
    on: MetacelloAllowLockedProjectChange
    do: [ :ex | 
      "MetacelloAllowLockedProjectChange need to be outermost handler ... since it is signaled from second line of handlers"
      ex handleResolutionFor: self ] ]
    on: Warning
    do: [ :ex | 
      "Warning is absolute outermost handler"
      self handleWarning: ex ]! !

!MetacelloScriptEngine methodsFor: 'accessing' stamp: ''!
projectName
    ^ self projectSpec name! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
load: required onProjectDownGrade: onDownGradeBlock onProjectUpgrade: onUpgradeBlock
  MetacelloProjectRegistration
    copyRegistryRestoreOnErrorWhile: [ 
      self
        handleNotificationsForAction: [ 
          | version loadedSpec |
          self setDefaultsAndValidateProjectSpec.
          [ loadedSpec := (self lookupProjectSpecFor: self projectSpec) copy ]
            on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade
            do: [ :ex | ex handleOnDownGrade: onDownGradeBlock onUpgrade: onUpgradeBlock ].
          version := loadedSpec versionForScriptEngine: self.
          self
            root:
              (required isEmpty
                ifTrue: [ version load ]
                ifFalse: [ version load: required ]) loadDirective.
          loadedSpec loads: required.
          MetacelloProjectRegistration
            registrationForProjectSpec: loadedSpec
            ifAbsent: [ :new | 
              new
                loadedInImage: true;
                registerProject ]
            ifPresent: [ :existing :new | 
              existing
                copyOnWrite: [ :existingCopy | 
                  existingCopy
                    loadedInImage: true;
                    merge: new ] ] ] ]! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
register
  | spec |
  self setDefaultsAndValidate: self projectSpec copy.	"don't add defaults"
  spec := self projectSpec.
  MetacelloProjectRegistration
    registrationForProjectSpec: spec
    ifAbsent: [ :new | new registerProject ]
    ifPresent: [ :existing :new | existing copyOnWrite: [ :existingCopy | existingCopy merge: new ] ].
  self root: spec! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
fetchRecord: fetchRecordBlock required: required
  MetacelloProjectRegistration
    copyRegistryWhile: [ 
      self
        handleNotificationsForAction: [ 
          | version loadedSpec |
          self setDefaultsAndValidateProjectSpec.
          [ loadedSpec := self lookupProjectSpecFor: self projectSpec ]
            on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade
            do: [ :notification | 
              notification
                handleOnDownGrade: [ :ex :existing :new | ex allowEvenIfLocked ]
                onUpgrade: [ :ex :existing :new | ex allowEvenIfLocked ] ].
          version := loadedSpec versionForScriptEngine: self.
          self root: (fetchRecordBlock value: version) loadDirective ] ]! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
get
  " load a fresh copy from repo"

  | spec projectPackage |
  MetacelloProjectRegistration
    copyRegistryRestoreOnErrorWhile: [ 
      self setDefaultsAndValidateProjectSpec.
      spec := self projectSpec.
      projectPackage := spec projectPackage.
      projectPackage repositorySpecs
        do: [ :repoSpec | repoSpec createRepository flushForScriptGet ].
      self cacheRepository
        ifNotNil: [ :cacheRepository | projectPackage loader loaderPolicy cacheRepository: cacheRepository ].
      projectPackage load.
      self root: (Smalltalk at: spec className asSymbol) project.
      MetacelloProjectRegistration
        registrationForProjectSpec: spec
        ifAbsent: [ :new | new registerProject ]
        ifPresent: [ :existing :new | 
          existing
            copyOnWrite: [ :existingCopy | 
              spec
                copyForRegistration: existingCopy
                onWrite: [ :specCopy | 
                  specCopy
                    ifNil: [ existingCopy merge: new ]
                    ifNotNil: [ specCopy mergeScriptRepository: spec ] ] ] ] ]! !

!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleLookupProjectSpec: exception
    ^ exception
        resume:
            ((self lookupProjectSpecFor: exception projectSpec) ifNil: [ ^ exception resume: exception projectSpec ])! !

!MetacelloScriptEngine methodsFor: 'accessing' stamp: ''!
repositories
    ^ self projectSpec repositories! !

!MetacelloScriptEngine methodsFor: 'options' stamp: ''!
ignoreImage
    ^ self options at: #'ignoreImage' ifAbsent: [ false ]! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
lock
  | spec |
  MetacelloProjectRegistration
    copyRegistryRestoreOnErrorWhile: [ 
      self setDefaultsAndValidate: self projectSpec copy.	"don't add defaults"
      spec := self projectSpec.
      MetacelloProjectRegistration
        registrationForProjectSpec: spec
        ifAbsent: [ :new | 
          new
            locked: true;
            registerProject ]
        ifPresent: [ :existing :new | 
          existing
            copyOnWrite: [ :existingCopy | 
              existingCopy locked: true.
              spec
                copyForRegistration: existingCopy
                onWrite: [ :specCopy | 
                  specCopy
                    ifNil: [ existingCopy merge: new ]
                    ifNotNil: [ 
                      specCopy mergeScriptRepository: spec.
                      spec := specCopy ] ] ] ].
      self root: spec ]! !

!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleLock: exception
  ^ (self options at: #'onLock' ifAbsent: [ ^ exception pass ])
    cull: exception
    cull: exception existingProjectRegistration
    cull: exception newProjectRegistration! !

!MetacelloScriptEngine methodsFor: 'project lookup' stamp: ''!
getBaselineProjectUnconditionalLoad: unconditionalLoad
    | project |
    project := (self getBaselineUnconditionalLoad: unconditionalLoad) project.
    project version spec repositories: self repositories copy.
    ^ project! !

!MetacelloScriptEngine methodsFor: 'project lookup' stamp: ''!
getConfigurationProjectUnconditionalLoad: unconditionalLoad
    ^ (self getConfigurationUnconditionalLoad: unconditionalLoad) project! !

!MetacelloScriptEngine methodsFor: 'handlers' stamp: ''!
handleUpgrade: exception
    ^ (self options at: #'onUpgrade' ifAbsent: [ ^ exception pass ])
        cull: exception
        cull: exception existingProjectRegistration
        cull: exception newProjectRegistration! !

!MetacelloScriptEngine methodsFor: 'actions api' stamp: ''!
load: required
    self
        load: required
        onProjectDownGrade: [ :ex :existing :new | ex allowEvenIfLocked ]
        onProjectUpgrade: [ :ex :existing :new | ex allowEvenIfLocked ]! !

!MetacelloScriptEngine methodsFor: 'accessing' stamp: ''!
options
    options ifNil: [ options := Dictionary new ].
    ^ options! !

!MetacelloScriptEngine methodsFor: 'options' stamp: ''!
useCurrentVersion
    "private option used to implement the classic mode"

    ^ self options at: #'useCurrentVersion' ifAbsent: [ false ]! !

!MetacelloScriptEngine class methodsFor: 'utilities' stamp: ''!
configurationNameFrom: baseName
    "Return the fully-qualified configuration class name."

    ^ (baseName indexOfSubCollection: 'ConfigurationOf') > 0
        ifTrue: [ baseName ]
        ifFalse: [ 'ConfigurationOf' , baseName ]! !

!MetacelloScriptEngine class methodsFor: 'utilities' stamp: ''!
baselineNameFrom: baseName
    "Return the fully-qualified configuration class name."

    ^ (baseName indexOfSubCollection: 'BaselineOf') > 0
        ifTrue: [ baseName ]
        ifFalse: [ 'BaselineOf' , baseName ]! !

!MetacelloScriptEngine class methodsFor: 'defaults' stamp: ''!
defaultVersionString
    DefaultVersionString ifNil: [ DefaultVersionString := #'stable' ].
    ^ DefaultVersionString! !

!MetacelloScriptEngine class methodsFor: 'defaults' stamp: ''!
defaultRepositoryDescription
    DefaultRepositoryDescription
        ifNil: [ DefaultRepositoryDescription := MetacelloPlatform current defaultRepositoryDescription ].
    ^ DefaultRepositoryDescription! !

!MetacelloScriptEngine class methodsFor: 'utilities' stamp: ''!
baseNameOf: className
  ^ (className beginsWith: 'BaselineOf')
    ifTrue: [ className copyFrom: 'BaselineOf' size + 1 to: className size ]
    ifFalse: [ 
      (className beginsWith: 'ConfigurationOf')
        ifTrue: [ className copyFrom: 'ConfigurationOf' size + 1 to: className size ]
        ifFalse: [ className ] ]! !

!MetacelloScriptEngine class methodsFor: 'defaults' stamp: ''!
defaultRepositoryDescription: descriptionOrNil
  DefaultRepositoryDescription := descriptionOrNil! !

!MetacelloScriptEnsureProjectLoadedForDevelopment methodsFor: 'exception handling' stamp: ''!
defaultAction
    "Go ahead and download a new copy of configuration because blessing is #development"

    ^ true! !

!MetacelloScriptEnsureProjectLoadedForDevelopment methodsFor: 'handlers' stamp: ''!
handleResolutionFor: aScriptEngine
    ^ aScriptEngine handleEnsureProjectLoadedForDevelopment: self! !

!MetacelloScriptExecutor commentStamp: ''!
MetacelloScriptExecutor decodes script args and launches MetacelloScriptEngine to run for each projectSpec encounters...i,e., primarily here to handl array and block args to configuration:, baseline: or project:.!
!MetacelloScriptExecutor methodsFor: 'options api' stamp: ''!
onLock: aBlock
  self options at: #'onLock' put: aBlock! !

!MetacelloScriptExecutor methodsFor: 'options api' stamp: ''!
ignoreImage: aBool
    self options at: #'ignoreImage' put: aBool! !

!MetacelloScriptExecutor methodsFor: 'accessing' stamp: ''!
singleRoot: aBool
  singleRoot := aBool! !

!MetacelloScriptExecutor methodsFor: 'options api' stamp: ''!
onWarning: aBlock
  self options at: #'onWarning' put: aBlock! !

!MetacelloScriptExecutor methodsFor: 'options api' stamp: ''!
repositoryOverrides: aRepositoryDescriptionList
    self options at: #'repositoryOverrides' put: aRepositoryDescriptionList! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
classNameArg
    ^ classNameArg! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
baselineArg: anObject
	baselineArg := anObject! !

!MetacelloScriptExecutor methodsFor: 'accessing' stamp: ''!
singleRoot
  singleRoot ifNil: [ singleRoot := false ].
  ^ singleRoot! !

!MetacelloScriptExecutor methodsFor: 'actions api' stamp: ''!
fetch: required
    actionArg := #'fetch:' -> {required}! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
projectArg: anObject
    projectArg := anObject! !

!MetacelloScriptExecutor methodsFor: 'options api' stamp: ''!
onDowngrade: aBlock
    self options at: #'onDowngrade' put: aBlock! !

!MetacelloScriptExecutor methodsFor: 'actions api' stamp: ''!
record: required
    actionArg := #'record:' -> {required}! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
baselineArg
	^ baselineArg! !

!MetacelloScriptExecutor methodsFor: 'execution callback' stamp: ''!
executeCollection: aCollection do: projectSpecBlock
    aCollection
        do: [ :projectName | 
            ((projectSpecGenerator projectSpecLookupBlock value: projectName) select: self projectSpecSelectBlock)
                do: [ :projectSpec | projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ] ]! !

!MetacelloScriptExecutor methodsFor: 'options api' stamp: ''!
useCurrentVersion: aBool
    "private option used to implement the classic mode"

    self options at: #'useCurrentVersion' put: aBool! !

!MetacelloScriptExecutor methodsFor: 'options api' stamp: ''!
silently: aBool
    self options at: #'silently' put: aBool! !

!MetacelloScriptExecutor methodsFor: 'actions api' stamp: ''!
unregister
  actionArg := #'unregister' -> #()! !

!MetacelloScriptExecutor methodsFor: 'accessing' stamp: ''!
roots
    roots ifNil: [ roots := OrderedCollection new ].
    ^ roots! !

!MetacelloScriptExecutor methodsFor: 'options api' stamp: ''!
cacheRepository: aRepositoryDescription
    self options at: #'cacheRepository' put: aRepositoryDescription! !

!MetacelloScriptExecutor methodsFor: 'execution callback' stamp: ''!
executeBlock: selectBlock do: projectSpecBlock
    ((projectSpecGenerator projectSpecListBlock value select: selectBlock) select: self projectSpecSelectBlock)
        do: [ :projectSpec | projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ]! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
projectArg
    ^ projectArg! !

!MetacelloScriptExecutor methodsFor: 'actions api' stamp: ''!
list
  actionArg := #'list' -> #().
  self singleRoot: false! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
classNameArg: anObject
    classNameArg := anObject! !

!MetacelloScriptExecutor methodsFor: 'options api' stamp: ''!
onUpgrade: aBlock
    self options at: #'onUpgrade' put: aBlock! !

!MetacelloScriptExecutor methodsFor: 'actions api' stamp: ''!
unlock
    actionArg := #'unlock' -> #()! !

!MetacelloScriptExecutor methodsFor: 'execution callback' stamp: ''!
projectSpecSelectBlock
    ^ [ :projectSpec | true ]! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
configurationArg
    ^ configurationArg! !

!MetacelloScriptExecutor methodsFor: 'actions api' stamp: ''!
register
  actionArg := #'register' -> #()! !

!MetacelloScriptExecutor methodsFor: 'execution callback' stamp: ''!
executeString: aString do: projectSpecBlock
  singleRoot ifNil: [ self singleRoot: true ].
  ((projectSpecGenerator projectSpecLookupBlock value: aString)
    select: self projectSpecSelectBlock)
    do: [ :projectSpec | projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ]! !

!MetacelloScriptExecutor methodsFor: 'actions api' stamp: ''!
get
    actionArg := #'get' -> #()! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
versionArg
    ^ versionArg! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
configurationArg: anObject
    configurationArg := anObject! !

!MetacelloScriptExecutor methodsFor: 'execution' stamp: ''!
execute: statements
  statements
    do: [ :assoc | 
      assoc value
        ifNil: [ self perform: assoc key ]
        ifNotNil: [ self perform: assoc key withArguments: assoc value ] ].
  projectSpecGenerator := self projectSpecGenerator.
  projectSpecGenerator target
    execute: [ :projectSpec | 
      | engine |
      engine := MetacelloScriptEngine new
        options: self options copy;
        projectSpec: projectSpec;
        yourself.
      engine perform: actionArg key withArguments: actionArg value.
      engine root ifNotNil: [ :root | self roots add: root ] ]
    against: self.
  ^ (self singleRoot and: [ self roots size == 1 ])
    ifTrue: [ self roots first ]
    ifFalse: [ self roots ]! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
versionArg: anObject
    versionArg := anObject! !

!MetacelloScriptExecutor methodsFor: 'actions api' stamp: ''!
lock
    actionArg := #'lock' -> #()! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
repositoryArg: anObject
    repositoryArg := anObject! !

!MetacelloScriptExecutor methodsFor: 'actions api' stamp: ''!
load: required
    actionArg := #'load:' -> {required}! !

!MetacelloScriptExecutor methodsFor: 'execution' stamp: ''!
applyArgsToProjectSpec: aProjectSpec
    classNameArg ifNotNil: [ aProjectSpec className: classNameArg ].
    versionArg ifNotNil: [ aProjectSpec versionString: versionArg ].
    repositoryArg ifNotNil: [ aProjectSpec repository: repositoryArg ].
    ^ aProjectSpec! !

!MetacelloScriptExecutor methodsFor: 'options api' stamp: ''!
onConflict: aBlock
    self options at: #'onConflict' put: aBlock! !

!MetacelloScriptExecutor methodsFor: 'accessing' stamp: ''!
options
    options ifNil: [ options := Dictionary new ].
    ^ options! !

!MetacelloScriptExecutor methodsFor: 'execution' stamp: ''!
projectSpecGenerator
    baselineArg
        ifNotNil: [ 
            configurationArg ifNotNil: [ self error: ' baseline: and configuration: are both be specified' ].
            projectArg ifNotNil: [ self error: ' baseline: and project are both be specified' ].
            ^ MetacelloBaselineSpecGenerator new
                target: baselineArg;
                yourself ].
    configurationArg
        ifNotNil: [ 
            baselineArg ifNotNil: [ self error: ' baseline: and configuration: are both be specified' ].
            projectArg ifNotNil: [ self error: ' configuration and project are both be specified' ].
            ^ MetacelloConfigurationSpecGenerator new
                target: configurationArg;
                yourself ].
    projectArg
        ifNotNil: [ 
            configurationArg ifNotNil: [ self error: ' project and configuration: are both be specified' ].
            baselineArg ifNotNil: [ self error: ' baseline: and project are both be specified' ].
            ^ MetacelloProjectSpecGenerator new
                target: projectArg;
                yourself ].
    self error: 'project, baseline, or configuration not specified'! !

!MetacelloScriptExecutor methodsFor: 'args' stamp: ''!
repositoryArg
    ^ repositoryArg! !

!MetacelloScriptGitBasedDownloadNotification methodsFor: 'accessing' stamp: ''!
versionString: anObject
	versionString := anObject! !

!MetacelloScriptGitBasedDownloadNotification methodsFor: 'accessing' stamp: ''!
projectPath: anObject
	projectPath := anObject! !

!MetacelloScriptGitBasedDownloadNotification methodsFor: 'accessing' stamp: ''!
versionString
	^ versionString! !

!MetacelloScriptGitBasedDownloadNotification methodsFor: 'accessing' stamp: ''!
projectPath
	^ projectPath! !

!MetacelloScriptImageExecutor methodsFor: 'execution callback' stamp: ''!
projectSpecSelectBlock
    ^ [ :projectSpec | 
    projectSpec
        ifNil: [ false ]
        ifNotNil: [ 
            MetacelloProjectRegistration
                registrationForProjectSpec: projectSpec
                ifAbsent: [ false ]
                ifPresent: [ :existingRegistration :newRegistration | existingRegistration loadedInImage ] ] ]! !

!MetacelloScriptNotification methodsFor: 'handlers' stamp: ''!
handleResolutionFor: aScriptEngine
    self subclassResponsibility! !

!MetacelloScriptProjectSpecNotification methodsFor: 'accessing' stamp: ''!
projectSpec
    ^ projectSpec! !

!MetacelloScriptProjectSpecNotification methodsFor: 'exception description' stamp: ''!
defaultAction
    "Result of signal should be the projectSpec to be used to perform the load"

    ^ self projectSpec! !

!MetacelloScriptProjectSpecNotification methodsFor: 'accessing' stamp: ''!
projectSpec: anObject
    projectSpec := anObject! !

!MetacelloScriptRegistryExecutor methodsFor: 'execution callback' stamp: ''!
projectSpecSelectBlock
  ^ [ :projectSpec | projectSpec notNil ]! !

!MetacelloScriptRegistryExecutor methodsFor: 'actions api' stamp: ''!
remove! !

!MetacelloScriptRegistryExecutor methodsFor: 'initialization' stamp: ''!
reset! !

!MetacelloScriptRegistryExecutor methodsFor: 'actions api' stamp: ''!
prime! !

!MetacelloScriptingResource methodsFor: 'invalid configurations' stamp: ''!
invalidConfiguration20: spec
    <version: '2.0.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'release'.
            spec description: 'MetacelloScriptingResource>>invalidConfiguration20: ... missing version:'.
            spec
                project: 'External'
                with: [ 
                    spec
                        className: 'ConfigurationOfExternal';
                        repository:
                                'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
configurationExternalRef090: spec
  <version: '0.9.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'version'.
      spec
        description: 'MetacelloScriptingResource>>configurationExternalRef090:'.
      spec
        project: 'External'
        with: [ 
          spec
            className: 'ConfigurationOfExternal';
            version: '0.9.0';
            repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
versionOfIV: spec
    <version: '0.9.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>baselineOfIV:'.
            spec author: 'dkh'.
            spec timestamp: '5/4/2012 14:16' ].
    spec
        for: #'custom'
        do: [ spec baseline: 'ExternalX' with: [ spec repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
unstableVersionOfX: spec
  "self reset"

  <symbolicVersion: #'unstable'>
  spec for: #'common' version: '0.9.1'! !

!MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: ''!
conflictOf10: spec
    <version: '1.0.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>conflictOf10:'.
            spec author: 'dkh'.
            spec timestamp: '6/1/2012 14:46' ].
    spec
        for: #'custom'
        do: [ 
            spec
                configuration: 'ExternalX'
                with: [ 
                    spec
                        version: '0.9.1';
                        repository: 'dictionary://Metacello_Conflict_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpConfigurationExternalRefdkh2: ancestors
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'ConfigurationOfExternalRef-dkh.2'.
  className := #'ConfigurationOfExternalRef'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configurationExternalRef090:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configurationExternalRef090:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configurationExternalRef091:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configurationExternalRef091:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configurationExternalRef092:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configurationExternalRef092:') asString)}.
  externalRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: ancestors)
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: ''!
externalBaselineXX: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>externalBaselineXX:'.
            spec
                package: 'External-CoreX';
                package: 'External-TestsX' with: [ spec requires: 'External-CoreX' ];
                yourself.
            spec
                group: 'Core' with: #('External-CoreX');
                group: 'default' with: #('Core');
                group: 'Tests' with: #('External-TestsX');
                yourself ]! !

!MetacelloScriptingResource methodsFor: 'invalid configurations' stamp: ''!
setUpInvalidConfigurations
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfInvalidConfigurations-dkh.1'.
    className := #'ConfigurationOfInvalidConfigurations'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'invalidConfiguration10:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'invalidConfiguration10:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'invalidConfiguration20:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'invalidConfiguration20:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'invalidConfiguration30:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'invalidConfiguration30:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
configuration096Issue185: spec
  <version: '0.9.6'>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>configuration0956Issue185:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:'
                    , MetacelloScriptingResource externalCustomIssue185SHA3
                    , '/repository' ];
        import: 'External' ]! !

!MetacelloScriptingResource methodsFor: 'locking' stamp: ''!
lockConfiguration11: spec
  <version: '1.1.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'release'.
      spec description: 'MetacelloScriptingResource>>lockConfiguration11: '.
      spec
        configuration: 'ExternalX'
        with: [ 
          spec
            version: '0.9.1';
            repository: 'dictionary://Metacello_Config_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpBaselineGithubReferenceXI
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfGithubRefXI-dkh.1'.
    className := #'BaselineOfGithubRefXI'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'configurationGithubReferenceV:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'configurationGithubReferenceV:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 32' stamp: ''!
version10Issue47: spec
    <version: '1.0.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>version10Issue47:'.
            spec author: 'dkh'.
            spec timestamp: '6/18/2012 14:34'.
            spec baseline: 'Issue32' ].
    spec
        for: #'custom'
        do: [ spec baseline: 'Issue32' with: [ spec repository: 'dictionary://Metacello_External_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
baselineGithubReferenceVII: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>baselineGithubReferenceVII:'.
            spec
                baseline: 'External Core'
                    with: [ 
                            spec
                                className: 'BaselineOfExternal';
                                loads: 'Core';
                                repository:
                                        'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ];
                project: 'External Tests' copyFrom: 'External Core' with: [ spec loads: 'Tests' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpBaselineGithubReferenceVI
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfGithubRefVI-dkh.1'.
    className := #'BaselineOfGithubRefVI'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'configurationGithubReferenceXXX:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'configurationGithubReferenceXXX:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 339' stamp: ''!
setUpConfigurationIssue339
  "see https://github.com/dalehenrich/metacello-work/issues/339"

  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'ConfigurationOfIssue339-dkh.1'.
  className := #'ConfigurationOfIssue339'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'version100Issue339:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'version100Issue339:') asString)}.
  configurationRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
setUpConfigurationOfExternaldkh2
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'ConfigurationOfExternal-dkh.2'.
  className := #'ConfigurationOfExternal'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'versionOfExternal090:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'versionOfExternal090:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'versionOfExternal091:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'versionOfExternal091:') asString)}.
  externalRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'accessing' stamp: ''!
configurationRepository
    ^ configurationRepository! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
stableVersionOfX: spec
    "self reset"

    <symbolicVersion: #'stable'>
    spec for: #'common' version: '0.9.0'! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
configuration092Issue63: spec
  <version: '0.9.2'>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>configuration092Issue63:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA
                    , '/repository' ];
        package: 'GoferBar'
          with: [ 
              spec
                file: 'GoferBar-lr.1';
                repository: 'dictionary://Metacello_Gofer_Test_Repository' ];
        package: 'GoferFoo'
          with: [ 
              spec
                file: 'GoferFoo-lr.2';
                requires: 'External';
                repository: 'dictionary://Metacello_Gofer_Test_Repository' ];
        import: 'External' ]! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
setUpConfigurationOfExternalXdkh1
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'ConfigurationOfExternalX-dkh.1'.
  className := #'ConfigurationOfExternalX'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'stableVersionOfX:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'stableVersionOfX:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'versionOfX090:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'versionOfX090:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'customProjectAttributes'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
  configurationRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 84' stamp: ''!
version10NestedIssue84: spec
    <version: '1.0.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>version10NestedIssue84:'.
            spec author: 'dkh'.
            spec timestamp: '7/24/2012 19:23'.
            spec repository: 'dictionary://Metacello_Configuration_Test_Repository'.
            spec package: 'External-CoreX' ]! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
configuration092Issue181: spec
  <version: '0.9.2'>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>configuration092Issue181:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:'
                    , MetacelloScriptingResource externalCustomIssue181SHA
                    , '/repository' ];
        import: 'External' ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
baselineGithubReferenceXX: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>baselineGithubReferenceXX:'.
            spec
                baseline: 'External'
                with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: ''!
externalBaselineXXX: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>externalBaselineXXX:'.
            spec
                package: 'External-CoreX';
                package: 'External-TestsX' with: [ spec requires: 'External-CoreX' ];
                yourself.
            spec
                group: 'Core' with: #('External-CoreX');
                group: 'default' with: #('Core');
                group: 'Tests' with: #('External-TestsX');
                yourself ].
    spec
        for: #'custom'
        do: [ 
            spec package: 'External-UIX'.
            spec group: 'UI' with: #('External-UIX') ]! !

!MetacelloScriptingResource methodsFor: 'issue 32' stamp: ''!
setUpBaselineIssue32
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfIssue32-dkh.1'.
    className := #'BaselineOfIssue32'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'postloadDoIt'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'postloadDoIt') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'preloadDoIt'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'preloadDoIt') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'baselineIssue32:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineIssue32:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: ''!
conflictOf12: spec
    <version: '1.2.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>conflictOf12:'.
            spec author: 'dkh'.
            spec timestamp: '6/1/2012 14:46' ].
    spec
        for: #'custom'
        do: [ 
            spec
                configuration: 'ExternalX'
                with: [ 
                    spec
                        operator: #'=';
                        version: '0.9.2';
                        repository: 'dictionary://Metacello_Conflict_Test_Repository'	"#= forces conflict" ] ]! !

!MetacelloScriptingResource methodsFor: 'issue 32' stamp: ''!
preloadDoIt
	"self reset"

	Smalltalk at: #'Metacello_Configuration_Test_DoIt_Result' put: true! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
setUpConfiguration181
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'ConfigurationOfIssue181-dkh.1'.
  className := #'ConfigurationOfIssue181'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configuration091Issue181:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configuration091Issue181:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configuration092Issue181:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configuration092Issue181:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configuration093Issue185:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configuration093Issue185:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configuration094Issue185:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configuration094Issue185:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configuration095Issue185:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configuration095Issue185:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configuration096Issue185:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configuration096Issue185:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configuration097Issue185:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configuration097Issue185:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configuration098Issue215:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configuration098Issue215:') asString)}.
  configurationRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
configuration095Issue185: spec
  <version: '0.9.5'>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>configuration095Issue185:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:'
                    , MetacelloScriptingResource externalCustomIssue185SHA2
                    , '/repository' ];
        import: 'External' ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
configurationExternalRef092: spec
  <version: '0.9.2'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'version'.
      spec
        description: 'MetacelloScriptingResource>>configurationExternalRef092:'.
      spec
        project: 'External'
        with: [ 
          "ConfigurationOfExternal 0.9.2 should not exist"
          spec
            className: 'ConfigurationOfExternal';
            version: '0.9.2';
            repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'issue 399' stamp: ''!
baselineIssue399: spec
  <baseline>
  spec
    for: #'common'
    do: [ 
      spec description: self className , '>>baselineIssue399:'.
      spec package: 'Issue399-Core' ]! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
setUpConfiguration63
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfIssue63-dkh.1'.
    className := #'ConfigurationOfIssue63'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'configuration091Issue63:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'configuration091Issue63:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'configuration092Issue63:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'configuration092Issue63:') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 84' stamp: ''!
setUpConfigurationIssue84
    "see https://github.com/dalehenrich/metacello-work/issues/84"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfIssue84-dkh.1'.
    className := #'ConfigurationOfIssue84'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'version10Issue84:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version10Issue84:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 59' stamp: ''!
versionNumberClass
    ^ MetacelloVersionNumber! !

!MetacelloScriptingResource methodsFor: 'sample repository' stamp: ''!
isSample
    ^ false! !

!MetacelloScriptingResource methodsFor: 'issue 32' stamp: ''!
setUpConfigurationIssue32
    "see https://github.com/dalehenrich/metacello-work/issues/32"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfIssue32-dkh.1'.
    className := #'ConfigurationOfIssue32'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'version10Issue47:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version10Issue47:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'version09Issue32:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version09Issue32:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'external core' stamp: ''!
isExternal
    ^ false! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
configurationGithubReferenceXXX: spec
  <baseline>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>configurationGithubReferenceXXX:'.
      spec
        configuration: 'External'
        with: [ 
          spec
            version: '0.9.0';
            repository: 'http://ss3.gemtalksystems.com/ss/external' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpBaselineGithubReferenceIX
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfGithubRefIX-dkh.1'.
    className := #'BaselineOfGithubRefIX'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'configurationGithubReferenceIV:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'configurationGithubReferenceIV:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: ''!
versionOfMariano: spec
    <version: '0.9.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>versionOfMariano:'.
            spec author: 'dkh'.
            spec timestamp: '5/31/2012 16:04' ].
    spec
        for: #'custom'
        do: [ spec baseline: 'ExternalX' with: [ spec repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: ''!
setUpConfigurationOfExternalXX
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfExternalXX-dkh.1'.
    className := #'ConfigurationOfExternalXX'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'versionOfXX:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'versionOfXX:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: ''!
setUpConfigurationOfConflict
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'ConfigurationOfConflict-dkh.1'.
  className := #'ConfigurationOfConflict'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'conflictOf20:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'conflictOf20:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'conflictOf21:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'conflictOf21:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'conflictOf10:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'conflictOf10:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'conflictOf11:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'conflictOf11:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'conflictOf12:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'conflictOf12:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'customProjectAttributes'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
  configurationRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'invalid configurations' stamp: ''!
invalidConfiguration10: spec
    <version: '1.0.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'release'.
            spec description: 'MetacelloScriptingResource>>invalidConfiguration10: ... missing className:'.
            spec
                project: 'External'
                with: [ 
                    spec
                        version: '0.9.0';
                        repository:
                                'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'issue 84' stamp: ''!
setUpConfigurationNextedIssue84dkh2: ancestors
    "see https://github.com/dalehenrich/metacello-work/issues/84"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfNestedIssue84-dkh.2'.
    className := #'ConfigurationOfNestedIssue84'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'version10NestedIssue84:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version10NestedIssue84:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'versionNumberClass'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'versionNumberClass') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: ancestors)
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
configuration097Issue185: spec
  <version: '0.9.7'>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>configuration0957Issue185:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:'
                    , MetacelloScriptingResource externalCustomIssue185SHA4
                    , '/repository' ];
        import: 'External' ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: ''!
setUpBaselineOfExternalXXX
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfExternalXXX-dkh.1'.
    className := #'BaselineOfExternalXXX'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'externalBaselineXXX:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'externalBaselineXXX:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
setUpConfigurationOfExternalIV
    "see https://github.com/dalehenrich/metacello-work/issues/6"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfExternalIV-dkh.1'.
    className := #'ConfigurationOfExternalIV'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'versionOfIV:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'versionOfIV:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
versionOfXX: spec
    <version: '0.9.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>versionOfXX:'.
            spec author: 'dkh'.
            spec timestamp: '5/4/2012 14:16' ].
    spec
        for: #'custom'
        do: [ 
            spec
                baseline: 'External'
                with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'issue 399' stamp: ''!
setUpIssue399CoreExternaldkh1
  "two packages with same name and version number, but a different class created."

  "this on goes into the external repository"

  "add first package to the package cache, then load a baseline in repo with other package"

  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'Issue399-Core-dkh.1'.
  className := #'Issue399External'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'Object'
    category: reference packageName
    instVarNames: #()
    comment: '')}.
  externalRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: ''!
conflictOf11: spec
    <version: '1.1.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>conflictOf11:'.
            spec author: 'dkh'.
            spec timestamp: '6/1/2012 14:46' ].
    spec
        for: #'custom'
        do: [ 
            spec
                configuration: 'ExternalX'
                with: [ 
                    spec
                        version: '0.9.0';
                        repository: 'dictionary://Metacello_Conflict_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'running' stamp: ''!
setUp
  "self reset"

  super setUp.
  self
    setUpRepositories;
    setUpExternalCore;
    setUpExternalCoreX;
    setUpSampleCore;
    setUpBaselineOfExternalX;
    setUpBaselineOfExternalXX;
    setUpBaselineOfExternalXXX;
    setUpConfigurationOfExternaldkh1;
    setUpConfigurationOfExternaldkh2;
    setUpConfigurationExternalRef;
    setUpConfigurationOfExternalX;
    setUpConfigurationOfExternalXX;
    setUpConfigurationOfExternalXXX;
    setUpConfigurationOfExternalIV;
    setUpBaselineGithubReferenceXX;
    setUpBaselineGithubReferenceIV;
    setUpBaselineGithubReferenceV;
    setUpBaselineGithubReferenceVI;
    setUpBaselineGithubReferenceVII;
    setUpBaselineGithubReferenceVIII;
    setUpBaselineGithubReferenceIX;
    setUpBaselineGithubReferenceXI;
    setUpBaselineGithubReferenceXII;
    setUpBaselineGithubReferenceXIII;
    setUpMarianosImage;
    setUpConfigurationOfConflict;
    setUpInvalidConfigurations;
    setUpConfigurationIssue32;
    setUpBaselineIssue32;
    setUpConfigurationIssue59;
    setUpConfiguration63;
    setUpLockConfigurations;
    setUpConfigurationIssue84;
    setUpConfigurationNextedIssue84;
    setUpConfiguration181;
    setUpBaselineIssue215;
    setUpConfigurationIssue339;
    setUpIssue399! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
configurationGithubReferenceX: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>configurationGithubReferenceX:'.
            spec
                project: 'External'
                with: [ 
                    spec
                        className: 'ConfigurationOfExternal';
                        version: '0.9.0';
                        repository:
                                'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
configurationGithubReferenceIV: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>configurationGithubReferenceIV:'.
            spec
                project: 'External'
                with: [ 
                    spec
                        className: 'ConfigurationOfExternal';
                        version: '0.9.0';
                        repository:
                                'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
setUpConfigurationOfExternalXXX
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfExternalXXX-dkh.1'.
    className := #'ConfigurationOfExternalXXX'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'versionOfXXX:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'versionOfXXX:') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 84' stamp: ''!
setUpConfigurationNextedIssue84dkh1
    "see https://github.com/dalehenrich/metacello-work/issues/84"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfNestedIssue84-dkh.1'.
    className := #'ConfigurationOfNestedIssue84'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'version10NestedIssue84:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version10NestedIssue84:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'versionNumberClass'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'versionNumberClass') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 84' stamp: ''!
version10Issue84: spec
    <version: '1.0.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'release'.
            spec description: 'MetacelloScriptingResource>>version10Issue84:'.
            spec author: 'dkh'.
            spec timestamp: '7/24/2012 19:23'.
            spec
                configuration: 'NestedIssue84'
                with: [ 
                    spec
                        version: '1.0.0';
                        repository: 'dictionary://Metacello_Config_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'issue 399' stamp: ''!
setUpBaselineIssue399Cypress
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'BaselineOfIssue399Cypress-dkh.1'.
  className := #'BaselineOfIssue399Cypress'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'BaselineOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'baselineIssue399:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'baselineIssue399:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'projectClass'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'projectClass') asString)}.
  externalRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpBaselineGithubReferenceV
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfGithubRefV-dkh.1'.
    className := #'BaselineOfGithubRefV'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'configurationGithubReferenceXX:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'configurationGithubReferenceXX:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 32' stamp: ''!
baselineIssue32: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>baselineIssue32:'.
            spec
                package: 'External-CoreX';
                package: 'External-TestsX' with: [ spec requires: 'External-CoreX' ];
                preLoadDoIt: #'preloadDoIt';
                postLoadDoIt: #'postloadDoIt';
                yourself.
            spec
                group: 'Core' with: #('External-CoreX');
                group: 'default' with: #('Core');
                group: 'Tests' with: #('External-TestsX');
                yourself ]! !

!MetacelloScriptingResource methodsFor: 'invalid configurations' stamp: ''!
invalidConfiguration30: spec
    <version: '3.0.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'release'.
            spec description: 'MetacelloScriptingResource>>invalidConfiguration30: ... missing repository:'.
            spec
                project: 'External'
                with: [ 
                    spec
                        className: 'ConfigurationOfExternal';
                        version: '0.9.0' ] ]! !

!MetacelloScriptingResource methodsFor: 'locking' stamp: ''!
lockConfiguration10: spec
    <version: '1.0.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'release'.
            spec description: 'MetacelloScriptingResource>>lockConfiguration10: '.
            spec
                configuration: 'ExternalX'
                with: [ 
                    spec
                        version: '0.9.0';
                        repository: 'dictionary://Metacello_Config_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: ''!
setUpBaselineOfExternalX
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfExternalX-dkh.1'.
    className := #'BaselineOfExternalX'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'externalBaselineX:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'externalBaselineX:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'external core' stamp: ''!
externalAuthorName
    ^ 'dkh'! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
baselineGithubReferenceIV: spec
  <baseline>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>baselineGithubReferenceIV:'.
      spec
        baseline: 'External'
        with: [ spec repository: 'http://ss3.gemtalksystems.com/ss/external' ] ]! !

!MetacelloScriptingResource methodsFor: 'accessing' stamp: ''!
externalRepository
    ^ externalRepository! !

!MetacelloScriptingResource methodsFor: 'locking' stamp: ''!
lockConfiguration14: spec
  <version: '1.4.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'release'.
      spec description: 'MetacelloScriptingResource>>lockConfiguration14: '.
      spec
        configuration: 'ExternalX'
        with: [ 
          spec
            version: #'unstable';
            repository: 'dictionary://Metacello_Config_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
versionOfX091: spec
    <version: '0.9.1'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>versionOfX091:'.
            spec author: 'dkh'.
            spec timestamp: '5/4/2012 14:16' ].
    spec
        for: #'custom'
        do: [ spec baseline: 'ExternalX' with: [ spec repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'issue 399' stamp: ''!
setUpIssue399
  | versionInfo |
  versionInfo := self setUpIssue399CoreSampledkh1.
  versionInfo := self setUpIssue399CoreSampledkh2: {versionInfo}.
  self
    setUpIssue399CoreExternaldkh1;
    setUpBaselineIssue399;
    setUpBaselineIssue399Cypress;
    yourself! !

!MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: ''!
conflictOf20: spec
  <version: '2.0.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'development'.
      spec description: 'MetacelloScriptingResource>>conflictOf20:'.
      spec author: 'dkh'.
      spec timestamp: '6/1/2012 14:46' ].
  spec
    for: #'custom'
    do: [ 
      spec
        configuration: 'ExternalX'
        with: [ 
          spec
            version: '0.9.0';
            repository: 'dictionary://Metacello_Conflict_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'issue 84' stamp: ''!
setUpConfigurationNextedIssue84
    "see https://github.com/dalehenrich/metacello-work/issues/84"

    "self reset"

    | versionInfo |
    versionInfo := self setUpConfigurationNextedIssue84dkh1.
    self setUpConfigurationNextedIssue84dkh2: {versionInfo}! !

!MetacelloScriptingResource methodsFor: 'issue 32' stamp: ''!
version10Issue59: spec
    <version: '1.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>version10Issue59:'.
            spec author: 'dkh'.
            spec timestamp: '6/18/2012 14:34'.
            spec baseline: 'Issue32' ].
    spec
        for: #'custom'
        do: [ spec baseline: 'Issue32' with: [ spec repository: 'dictionary://Metacello_External_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
configuration093Issue185: spec
  <version: '0.9.3'>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>configuration093Issue185:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:'
                    , MetacelloScriptingResource externalCustomIssue185SHA
                    , '/repository' ];
        import: 'External' ]! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
configuration094Issue185: spec
  <version: '0.9.4'>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>configuration094Issue185:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:'
                    , MetacelloScriptingResource externalCustomIssue185SHA1
                    , '/repository' ];
        import: 'External' ]! !

!MetacelloScriptingResource methodsFor: 'issue 399' stamp: ''!
setUpIssue399CoreSampledkh1
  "two packages with same name and version number, but a different class created."

  "this on goes into the sample repository"

  "add first package to the package cache, then load a baseline in repo with other package"

  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'Issue399-Core-dkh.1'.
  className := #'Issue399Sample'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'Object'
    category: reference packageName
    instVarNames: #()
    comment: '')}.
  sampleRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
configurationGithubReferenceXX: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>configurationGithubReferenceXX:'.
            spec
                configuration: 'External'
                with: [ 
                    spec
                        version: '0.9.0';
                        repository:
                                'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'issue 32' stamp: ''!
version09Issue32: spec
    <version: '0.9.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>baselineOfIssue32:'.
            spec author: 'dkh'.
            spec timestamp: '6/18/2012 14:34' ].
    spec
        for: #'custom'
        do: [ spec baseline: 'Issue32' with: [ spec repository: 'dictionary://Metacello_External_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'external repository' stamp: ''!
customProjectAttributes
    ^ #(#custom)! !

!MetacelloScriptingResource methodsFor: 'issue 215' stamp: ''!
configuration098Issue215: spec
  <version: '0.9.8'>
  spec
    for: #'common'
    do: [ 
      spec description: self className , '>>configuration092Issue63:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA
                    , '/repository' ];
        package: 'GoferBar'
          with: [ 
              spec
                file: 'GoferBar-lr.1';
                requires: 'External-Core';
                repository: 'dictionary://Metacello_Gofer_Test_Repository' ];
        package: 'GoferFoo'
          with: [ 
              spec
                file: 'GoferFoo-lr.2';
                requires: 'External-Tests';
                repository: 'dictionary://Metacello_Gofer_Test_Repository' ];
        import: 'External' provides: #('External-Core' 'External-Tests') ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: ''!
setUpBaselineOfExternalXX
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfExternalXX-dkh.1'.
    className := #'BaselineOfExternalXX'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'externalBaselineXX:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'externalBaselineXX:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'external core' stamp: ''!
setUpExternalCore
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'External-Core-dkh.1'.
  className := #'ExternalCore'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'Object'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: true
    selector: 'externalAuthorName'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'externalAuthorName') asString).
  (MCMethodDefinition
    className: 'Object'
    classIsMeta: true
    selector: 'isExternal'
    category: '*external-core'
    timeStamp: ''
    source: (self class sourceCodeAt: #'isExternal') asString)}.
  externalRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpBaselineGithubReferenceXII
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfGithubRefXII-dkh.1'.
    className := #'BaselineOfGithubRefXII'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'baselineGithubReferenceVI:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineGithubReferenceVI:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'sample repository' stamp: ''!
sampleAuthorName
    ^ (Smalltalk at: #'ExternalCore') new externalAuthorName! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
versionOfExternal091: spec
  <version: '0.9.1'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'development'.
      spec description: 'MetacelloScriptingResource>>versionOfExternal091:'.
      spec author: 'dkh'.
      spec timestamp: '5/4/2012 14:16'.
      spec
        baseline: 'External'
        with: [ 
          spec
            repository:
              'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA
                , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
baselineGithubReferenceVI: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>baselineGithubReferenceVI:'.
            spec
                baseline: 'External Core'
                    with: [ 
                            spec
                                className: 'BaselineOfExternal';
                                loads: 'Core';
                                repository:
                                        'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ];
                baseline: 'External Tests'
                    with: [ 
                            spec
                                className: 'BaselineOfExternal';
                                loads: 'Tests';
                                repository:
                                        'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
configuration091Issue181: spec
  <version: '0.9.1'>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>configuration091Issue181:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA
                    , '/repository' ];
        import: 'External' ]! !

!MetacelloScriptingResource methodsFor: 'external core' stamp: ''!
setUpExternalCoreX
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'External-CoreX-dkh.1'.
  className := #'ExternalCoreX'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'Object'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: true
    selector: 'externalAuthorName'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'externalAuthorName') asString).
  (MCMethodDefinition
    className: 'Object'
    classIsMeta: true
    selector: 'isExternal'
    category: '*external-corex'
    timeStamp: ''
    source: (self class sourceCodeAt: #'isExternal') asString)}.
  externalRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: ''!
externalBaselineX: spec
    <baseline>
    spec description: 'MetacelloScriptingResource>>externalBaselineX:'.
    spec
        package: 'External-CoreX';
        package: 'External-TestsX' with: [ spec requires: 'External-CoreX' ];
        yourself.
    spec
        group: 'Core' with: #('External-CoreX');
        group: 'default' with: #('Core');
        group: 'Tests' with: #('External-TestsX');
        yourself! !

!MetacelloScriptingResource methodsFor: 'issue 399' stamp: ''!
projectClass
  "Issue399 uses this to test Cypress package loading"

  ^ Smalltalk at: #'MetacelloCypressBaselineProject'! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
setUpConfigurationOfExternalXdkh2: ancestors
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'ConfigurationOfExternalX-dkh.2'.
  className := #'ConfigurationOfExternalX'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'stableVersionOfX:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'stableVersionOfX:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'unstableVersionOfX:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'unstableVersionOfX:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'versionOfX090:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'versionOfX090:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'versionOfX091:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'versionOfX091:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'customProjectAttributes'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
  configurationRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: ancestors)
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
versionOfXXX: spec
    <version: '0.9.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>versionOfXXX:'.
            spec author: 'dkh'.
            spec timestamp: '5/4/2012 14:16'.
            spec
                baseline: 'External'
                with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'running' stamp: ''!
setUpRepositories
    "self reset"

    configurationRepository := MCDictionaryRepository new.
    externalRepository := MCDictionaryRepository new.
    sampleRepository := MCDictionaryRepository new! !

!MetacelloScriptingResource methodsFor: 'issue 399' stamp: ''!
setUpBaselineIssue399
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'BaselineOfIssue399-dkh.1'.
  className := #'BaselineOfIssue399'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'BaselineOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'baselineIssue399:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'baselineIssue399:') asString)}.
  externalRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
versionOfX090: spec
    <version: '0.9.0'>
    spec
        for: #'common'
        do: [ 
            spec blessing: #'development'.
            spec description: 'MetacelloScriptingResource>>versionOfX090:'.
            spec author: 'dkh'.
            spec timestamp: '5/4/2012 14:16' ].
    spec
        for: #'custom'
        do: [ spec baseline: 'ExternalX' with: [ spec repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
versionOfExternal090: spec
  <version: '0.9.0'>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>versionOfExternal090:'.
      spec repository: 'dictionary://Metacello_Configuration_Test_Repository'.
      spec
        package: 'External-Core' with: 'External-Core-dkh.1';
        yourself ]! !

!MetacelloScriptingResource methodsFor: 'issue 215' stamp: ''!
setUpBaselineIssue215
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'BaselineOfIssue215-dkh.1'.
  className := #'BaselineOfIssue215'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'BaselineOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'postloadDoIt'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'postloadDoIt') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'preloadDoIt'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'preloadDoIt') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'baselineIssue215:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'baselineIssue215:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'customProjectAttributes'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
  configurationRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 399' stamp: ''!
setUpIssue399CoreSampledkh2: ancestors
  "two packages with same name and version number, but a different class created."

  "this on goes into the sample repository"

  "add first package to the package cache, then load a baseline in repo with other package"

  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'Issue399-Core-dkh.2'.
  className := #'Issue399Sample'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'Object'
    category: reference packageName
    instVarNames: #()
    comment: '')}.
  sampleRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: ancestors)
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 339' stamp: ''!
version100Issue339: spec
  "self reset"

  <version: '1.0.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'development'.
      spec description: 'MetacelloScriptingResource>>version100Issue339:'.
      spec repository: 'dictionary://Metacello_Gofer_Test_Repository'.
      spec package: 'Issue339' with: 'Issue339-JanKurs.1' ]! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
setUpConfigurationOfExternalX
    "self reset"

    | versionInfo |
    versionInfo := self setUpConfigurationOfExternalXdkh1.
    versionInfo := self setUpConfigurationOfExternalXdkh2: {versionInfo}! !

!MetacelloScriptingResource methodsFor: 'locking' stamp: ''!
lockConfiguration12: spec
  <version: '1.2.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'release'.
      spec description: 'MetacelloScriptingResource>>lockConfiguration12: '.
      spec
        configuration: 'ExternalX'
        with: [ 
          "bleedingEdge version"
          spec repository: 'dictionary://Metacello_Config_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpBaselineGithubReferenceVIII
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfGithubRefVIII-dkh.1'.
    className := #'BaselineOfGithubRefVIII'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'baselineGithubReferenceV:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineGithubReferenceV:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 63' stamp: ''!
configuration091Issue63: spec
  <version: '0.9.1'>
  spec
    for: #'common'
    do: [ 
      spec description: 'MetacelloScriptingResource>>configuration091Issue63:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA
                    , '/repository' ];
        import: 'External' ]! !

!MetacelloScriptingResource methodsFor: 'issue 59' stamp: ''!
setUpConfigurationIssue59
    "see https://github.com/dalehenrich/metacello-work/issues/59"

    "Use MetacelloVersionNumber instead of MetacelloSematicVersionNumber"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'ConfigurationOfIssue59-dkh.1'.
    className := #'ConfigurationOfIssue59'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'version10Issue59:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'version10Issue59:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'versionNumberClass'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'versionNumberClass') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'sample repository' stamp: ''!
setUpSampleCore
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'Sample-CoreX-dkh.1'.
    className := #'SampleCoreX'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'Object'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: true
        selector: 'sampleAuthorName'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'sampleAuthorName') asString).
    (MCClassDefinition
        name: #'Object'
        superclassName: #'ProtoObject'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: 'Object'
        classIsMeta: true
        selector: 'isSample'
        category: '*sample-core'
        timeStamp: ''
        source: (self class sourceCodeAt: #'isSample') asString)}.
    sampleRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpConfigurationExternalRef
  "self reset"

  | versionInfo |
  versionInfo := self setUpConfigurationExternalRefdkh1.
  versionInfo := self setUpConfigurationExternalRefdkh2: {versionInfo}! !

!MetacelloScriptingResource methodsFor: 'issue 32' stamp: ''!
postloadDoIt
	"self reset"

	Smalltalk at: #'Metacello_Configuration_Test_POST_DoIt_Result' put: true! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
configurationGithubReferenceV: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>configurationGithubReferenceV:'.
            spec
                project: 'External'
                    with: [ 
                            spec
                                className: 'ConfigurationOfExternal';
                                version: '0.9.0';
                                loads: 'Core';
                                repository:
                                        'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ];
                project: 'External Tests' copyFrom: 'External' with: [ spec loads: 'Tests' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
baselineGithubReferenceV: spec
    <baseline>
    spec
        for: #'common'
        do: [ 
            spec description: 'MetacelloScriptingResource>>baselineGithubReferenceV:'.
            spec
                baseline: 'External'
                with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'locking' stamp: ''!
lockConfiguration15: spec
  <version: '1.5.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'release'.
      spec description: self className , '>>lockConfiguration15: '.
      spec
        baseline: 'External'
        with: [ 
          spec
            repository:
              'github://dalehenrich/external:'
                , MetacelloScriptingResource externalCustomIssue185SHA
                , '/repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: ''!
setUpMarianosImage
    "className: test case
	seehttps://github.com/dalehenrich/metacello-work/issues/24"

    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'MarianosImage-dkh.1'.
    className := #'MarianosImage'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'ConfigurationOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'versionOfMariano:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'versionOfMariano:') asString).
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'customProjectAttributes'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
    configurationRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'issue 215' stamp: ''!
baselineIssue215: spec
  <baseline>
  spec
    for: #'common'
    do: [ 
      spec description: self className , '>>baselineGithubReferenceV:'.
      spec
        baseline: 'External'
          with: [ 
              spec
                repository:
                  'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA
                    , '/repository' ];
        import: 'External' provides: #('External-Core' 'External-Tests') ]! !

!MetacelloScriptingResource methodsFor: 'locking' stamp: ''!
setUpLockConfigurations
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference
    name: 'ConfigurationOfLockConfigurations-dkh.1'.
  className := #'ConfigurationOfLockConfigurations'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'lockConfiguration10:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'lockConfiguration10:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'lockConfiguration11:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'lockConfiguration11:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'lockConfiguration12:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'lockConfiguration12:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'lockConfiguration13:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'lockConfiguration13:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'lockConfiguration14:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'lockConfiguration14:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'lockConfiguration15:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'lockConfiguration15:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'customProjectAttributes'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'customProjectAttributes') asString)}.
  configurationRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpBaselineGithubReferenceXIII
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfGithubRefXIII-dkh.1'.
    className := #'BaselineOfGithubRefXIII'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'baselineGithubReferenceVII:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineGithubReferenceVII:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpBaselineGithubReferenceVII
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfGithubRefVII-dkh.1'.
    className := #'BaselineOfGithubRefVII'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'baselineGithubReferenceIV:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineGithubReferenceIV:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: ''!
conflictOf21: spec
  <version: '2.1.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'development'.
      spec description: 'MetacelloScriptingResource>>conflictOf21:'.
      spec author: 'dkh'.
      spec timestamp: '6/1/2012 14:46' ].
  spec
    for: #'custom'
    do: [ 
      spec
        configuration: 'ExternalX'
        with: [ 
          spec
            operator: #'=';
            version: '0.9.1';
            repository: 'dictionary://Metacello_Conflict_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpBaselineGithubReferenceIV
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfGithubRefIV-dkh.1'.
    className := #'BaselineOfGithubRefIV'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'configurationGithubReferenceX:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'configurationGithubReferenceX:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'locking' stamp: ''!
lockConfiguration13: spec
  <version: '1.3.0'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'release'.
      spec description: 'MetacelloScriptingResource>>lockConfiguration13: '.
      spec
        configuration: 'ExternalX'
        with: [ 
          spec
            version: #'stable';
            repository: 'dictionary://Metacello_Config_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'external configurations' stamp: ''!
setUpConfigurationOfExternaldkh1
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'ConfigurationOfExternal-dkh.1'.
  className := #'ConfigurationOfExternal'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'versionOfExternal090:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'versionOfExternal090:') asString)}.
  externalRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpConfigurationExternalRefdkh1
  "self reset"

  | reference className definitionArray versionInfo |
  reference := GoferVersionReference name: 'ConfigurationOfExternalRef-dkh.1'.
  className := #'ConfigurationOfExternalRef'.
  definitionArray := {(MCOrganizationDefinition
    categories: (Array with: reference packageName asSymbol)).
  (MCClassDefinition
    name: className
    superclassName: #'ConfigurationOf'
    category: reference packageName
    instVarNames: #()
    comment: '').
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configurationExternalRef090:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configurationExternalRef090:') asString).
  (MCMethodDefinition
    className: className asString
    classIsMeta: false
    selector: 'configurationExternalRef091:'
    category: 'cat'
    timeStamp: ''
    source: (self class sourceCodeAt: #'configurationExternalRef091:') asString)}.
  externalRepository
    basicStoreVersion:
      (MCVersion new
        setPackage: (MetacelloTestsMCPackage new name: reference packageName)
        info:
          (versionInfo := MCVersionInfo
            name: reference name
            id: UUID new
            message: 'This is a mock version'
            date: Date today
            time: Time now
            author: reference author
            ancestors: #())
        snapshot: (MCSnapshot fromDefinitions: definitionArray)
        dependencies: #()).
  ^ versionInfo! !

!MetacelloScriptingResource methodsFor: 'accessing' stamp: ''!
sampleRepository
    ^ sampleRepository! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
configurationExternalRef091: spec
  <version: '0.9.1'>
  spec
    for: #'common'
    do: [ 
      spec blessing: #'version'.
      spec
        description: 'MetacelloScriptingResource>>configurationExternalRef090:'.
      spec
        project: 'External'
        with: [ 
          spec
            className: 'ConfigurationOfExternal';
            version: '0.9.1';
            repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! !

!MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: ''!
setUpBaselineGithubReferenceXX
    "self reset"

    | reference className definitionArray versionInfo |
    reference := GoferVersionReference name: 'BaselineOfGithubRefXX-dkh.1'.
    className := #'BaselineOfGithubRefXX'.
    definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)).
    (MCClassDefinition
        name: className
        superclassName: #'BaselineOf'
        category: reference packageName
        instVarNames: #()
        comment: '').
    (MCMethodDefinition
        className: className asString
        classIsMeta: false
        selector: 'baselineGithubReferenceXX:'
        category: 'cat'
        timeStamp: ''
        source: (self class sourceCodeAt: #'baselineGithubReferenceXX:') asString)}.
    externalRepository
        basicStoreVersion:
            (MCVersion new
                setPackage: (MetacelloTestsMCPackage new name: reference packageName)
                info:
                    (versionInfo := MCVersionInfo
                        name: reference name
                        id: UUID new
                        message: 'This is a mock version'
                        date: Date today
                        time: Time now
                        author: reference author
                        ancestors: #())
                snapshot: (MCSnapshot fromDefinitions: definitionArray)
                dependencies: #()).
    ^ versionInfo! !

!MetacelloScriptingResource class methodsFor: 'accessing' stamp: ''!
externalConfigurationSHA
    "SHA of commit on 'configuration' branch that should be used with this version of tests (https://github.com/dalehenrich/external)"

    "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break"

    "self reset"

    ^ 'd91949731736bf48879781c29c7365feca461cde'! !

!MetacelloScriptingResource class methodsFor: 'accessing' stamp: ''!
externalCustomIssue234ShortMasterSHA
  "commit on branch issue/234 of External project: 
   master branch
   78b9c1d134fbf76001cc0b1a10e3b1a0c13eec9d"

  ^ '78b9c1d'! !

!MetacelloScriptingResource class methodsFor: 'accessing' stamp: ''!
externalCustomIssue185SHA4
  "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)"

  "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break"

  ^ 'e36dcd023518f4d2a209a482097f5a8ef745ef25'! !

!MetacelloScriptingResource class methodsFor: 'accessing' stamp: ''!
externalCustomSHA
    "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)"

    "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break"

    "self reset"

    ^ '1ac58502ade7814e1590f71d615cca434b1a4fd5'! !

!MetacelloScriptingResource class methodsFor: 'accessing' stamp: ''!
externalCustomIssue185SHA1
  "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)"

  "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break"

  ^ '96cf2ed0a252ce55b7fd5ec4bedf3ad999ca6d23'! !

!MetacelloScriptingResource class methodsFor: 'accessing' stamp: ''!
externalCustomIssue234ShortSHA
  "commit on branch issue/234 of External project: 
   issue/234 branch
x   issue\234 branch
x   issue\\234 branch
x   issue\xxx\branch branch
   issue/xxx/branch branch
x   issue//234 branch
   b57801b1f9386e37c1675cd9f9e04b0c66a3f60b"

  ^ 'b57801b'! !

!MetacelloScriptingResource class methodsFor: 'accessing' stamp: ''!
externalCustomIssue185SHA3
  "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)"

  "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break"

  ^ '11dfa72bc4a956ce0cb5a7603ea39f5abf73ff1c'! !

!MetacelloScriptingResource class methodsFor: 'accessing' stamp: ''!
externalCustomIssue185SHA
  "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)"

  "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break"

  ^ '29efb3d9cb86da55402a543cbef5771e39f864e7'! !

!MetacelloScriptingResource class methodsFor: 'accessing' stamp: ''!
externalCustomIssue185SHA2
  "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)"

  "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break"

  ^ '9e79d0e165bd51f7476d10a07968706f6034a6e6'! !

!MetacelloScriptingResource class methodsFor: 'accessing' stamp: ''!
externalCustomIssue181SHA
  "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)"

  "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break"

  ^ '36ac04abfc3a173de9432a134a718bf14b0a6968'! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
setUpRepositoryContents! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
unloadPackage: packageName
  | aGofer |
  aGofer := Gofer new.
  (self hasPackage: packageName)
    ifTrue: [ aGofer package: packageName ].
  aGofer references notEmpty
    ifTrue: [ aGofer unload ]! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'utilities' stamp: ''!
hasPackage: aString

	^ MCWorkingCopy allManagers
		anySatisfy: [ :each | each packageName = aString ]! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
tearDown
  | finalWorkingCopyList diff |  
  self tearDownPackages.
  self tearDownRepositories.
  MetacelloProjectRegistration registry: registry.
  self disableUndefinedSymbolTracking
    ifTrue: [ MetacelloPlatform current reenableUndefinedSybolUpdates: undefinedSymbols ].
  finalWorkingCopyList := MCWorkingCopy allManagers
    collect: [ :each | each packageName ].
  diff := finalWorkingCopyList difference: initialWorkingCopyList.
  diff
    do: [ :leak | 
      MetacelloNotification signal: ('leaked package from ' , self printString , ' -> ' , leak printString) ].
  self assert: diff isEmpty.
  super tearDown! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
tearDownPackageList
    ^ #()! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
doSilently
    ^ true! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'utilities' stamp: ''!
validate: expectedConfigurationClassName expConfigVersion: expectedConfigurationVersion expConfigRepo: expectedConfigurationRepository expBaselineClassName: expectedBaselineClassName expBaselineVersion: expectedBaselineVersion expBaselineRepo: expectedBaselineRepository
	MetacelloProjectRegistration registry configurationRegistry
		at: expectedConfigurationClassName
		ifPresent: [ :existing | 
			| spec x |
			spec := existing configurationProjectSpec.
			self assert: (x := spec version versionString) equals: expectedConfigurationVersion.
			self assert: (spec repositoryDescriptions includes: expectedConfigurationRepository) ]
		ifAbsent: [ self assert: expectedConfigurationVersion identicalTo: nil ].
	MetacelloProjectRegistration registry baselineRegistry
		at: expectedBaselineClassName
		ifPresent: [ :existing | 
			| spec |
			spec := existing baselineProjectSpec.
			self assert: spec versionString equals: expectedBaselineVersion.
			self assert: (spec repositoryDescriptions includes: expectedBaselineRepository) ]
		ifAbsent: [ self assert: expectedBaselineVersion identicalTo: nil ]! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
disableUndefinedSymbolTracking
  "significant perfomance improvement"

  ^ true! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'utilities' stamp: ''!
verify: packageName loadedFrom: repositoryDescription
    | externalCoreWorkingCopy |
    externalCoreWorkingCopy := MCWorkingCopy allManagers detect: [ :wc | wc packageName = packageName ].
    self
        assert:
            (externalCoreWorkingCopy repositoryGroup repositories
                includes: (MetacelloMCProject new repositorySpec description: repositoryDescription) createRepository)! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'utilities' stamp: ''!
verifyPackageNotLoaded: packageName
	self assert: (MCWorkingCopy allManagers detect: [ :wc | wc packageName = packageName ] ifNone: [  ]) identicalTo: nil! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'utilities' stamp: ''!
validateProjects: specArrays
  specArrays
    do: [ :array | 
      self
        validate: (array at: 1)
        expConfigVersion: (array at: 2)
        expConfigRepo: (array at: 3)
        expBaselineClassName: (array at: 4)
        expBaselineVersion: (array at: 5)
        expBaselineRepo: (array at: 6) ]! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
tearDownRepositories! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
setUpRepositories! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'utilities' stamp: ''!
verify: packageName version: fileName
	| externalCoreWorkingCopy x |
	externalCoreWorkingCopy := MCWorkingCopy allManagers detect: [ :wc | wc packageName = packageName ].
	self assert: (x := externalCoreWorkingCopy ancestors first name) equals: fileName! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
runCase
    | original |
    self doSilently
        ifFalse: [ ^ super runCase ].
    original := MetacelloPlatform current bypassGoferLoadUpdateCategories.
    [ 
    MetacelloPlatform current bypassGoferLoadUpdateCategories: true.
    ^ MetacelloPlatform current suspendSystemUpdateEventsDuring: [ super runCase ] ]
        ensure: [ MetacelloPlatform current bypassGoferLoadUpdateCategories: original ]! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
tearDownPackages
    | aGofer |
    aGofer := Gofer new.
    self tearDownPackageList
        do: [ :packageName | 
            (self hasPackage: packageName)
                ifTrue: [ aGofer package: packageName ] ].
    aGofer references notEmpty
        ifTrue: [ aGofer metacelloUnload ]! !

!MetacelloScriptingStdTstHarnessTestCase methodsFor: 'running' stamp: ''!
setUp
  super setUp.
  MetacelloPlatform current clearPackageCache.
  registry := MetacelloProjectRegistration registry.
  self setUpRepositories.
  self setUpRepositoryContents.
  MetacelloProjectRegistration resetRegistry.
  initialWorkingCopyList := MCWorkingCopy allManagers
    collect: [ :each | each packageName ].
  self disableUndefinedSymbolTracking
    ifTrue: [ undefinedSymbols := MetacelloPlatform current disableUndefinedSybolUpdates ]! !

!MetacelloScriptingTestCase commentStamp: ''!
##MetacelloScriptingTestCase

**MetacelloScriptingTestCase** implements the test suite that validates the **Metacello** scripting API.
!
!MetacelloScriptingTestCase methodsFor: 'accessing' stamp: ''!
samplePath
    ^ 'metacello-tests/sample'! !

!MetacelloScriptingTestCase methodsFor: 'running' stamp: ''!
tearDownRepositories
  super tearDownRepositories.
  configurationDirectory exists
    ifTrue: [ MetacelloPlatform current recursiveDelete: configurationDirectory ].
  externalDirectory exists
    ifTrue: [ MetacelloPlatform current recursiveDelete: externalDirectory ].
  sampleDirectory exists
    ifTrue: [ MetacelloPlatform current recursiveDelete: sampleDirectory ].
  testingEnvironment removeKey: #'Metacello_Configuration_Test_Repository' ifAbsent: [  ].
  testingEnvironment removeKey: #'Metacello_Gofer_Test_Repository' ifAbsent: [  ].
  testingEnvironment
    removeKey: #'Metacello_MczConfiguration_Test_Repository'
    ifAbsent: [  ].
  MCRepositoryGroup default
    removeIdenticalRepository: externalRepository;
    removeIdenticalRepository: monticelloRepository;
    removeIdenticalRepository: mczConfigurationRepository;
    removeIdenticalRepository: configurationRepository! !

!MetacelloScriptingTestCase methodsFor: 'accessing' stamp: ''!
externalPath
    ^ 'metacello-tests/external'! !

!MetacelloScriptingTestCase methodsFor: 'accessing' stamp: ''!
configurationPath
    ^ 'metacello-tests/configuration'! !

!MetacelloScriptingTestCase methodsFor: 'running' stamp: ''!
setUpRepositories
  | defaultDirectory |
  super setUpRepositories.
  defaultDirectory := MetacelloPlatform current defaultDirectory.
  configurationDirectory := MetacelloPlatform current
    directoryFromPath: self configurationPath
    relativeTo: defaultDirectory.
  externalDirectory := MetacelloPlatform current
    directoryFromPath: self externalPath
    relativeTo: defaultDirectory.
  sampleDirectory := MetacelloPlatform current
    directoryFromPath: self samplePath
    relativeTo: defaultDirectory.
  configurationDirectory exists
    ifTrue: [ MetacelloPlatform current recursiveDelete: configurationDirectory ].
  MetacelloPlatform current ensureDirectoryExists: configurationDirectory.
  externalDirectory exists
    ifTrue: [ MetacelloPlatform current recursiveDelete: externalDirectory ].
  MetacelloPlatform current ensureDirectoryExists: externalDirectory.
  sampleDirectory exists
    ifTrue: [ MetacelloPlatform current recursiveDelete: sampleDirectory ].
  MetacelloPlatform current ensureDirectoryExists: sampleDirectory.
  configurationRepository := MetacelloScriptingResource current
    configurationRepository.
  externalRepository := MetacelloScriptingResource current externalRepository.
  testingEnvironment
    at: 'Metacello_Configuration_Test_Repository' asSymbol
    put: externalRepository.
  monticelloRepository := MetacelloMonticelloResource current
    monticelloRepository.
  testingEnvironment
    at: 'Metacello_Gofer_Test_Repository' asSymbol
    put: monticelloRepository.
  mczConfigurationRepository := MetacelloConfigurationResource current
    monticelloRepository.
  testingEnvironment
    at: 'Metacello_MczConfiguration_Test_Repository' asSymbol
    put: mczConfigurationRepository! !

!MetacelloScriptingTestCase methodsFor: 'running' stamp: ''!
setUpRepositoryContents: packageList sourceRepo: sourceRepo targetRepo: targetRepo
    packageList
        do: [ :package | 
            | versionInfo |
            versionInfo := sourceRepo versionInfoFromVersionNamed: package.
            targetRepo storeVersion: (sourceRepo versionWithInfo: versionInfo ifAbsent: [ self assert: false ]) ]! !

!MetacelloSemanticVersionNumber commentStamp: ''!
MetacelloSemanticVersionNumber conforms to version 2.0.0-rc.1 of  [Semantic Versioning 2.0.0-rc.1](http://semver.org/)

The most important thing that you need to know is that: 
**A normal version number MUST take the form X.Y.Z where X, Y, and Z are non-negative integers.**

**Semantic Versioning Specification** extracted from [Semantic versioning 2.0.0-rc.1](https://github.com/mojombo/semver/blob/3c7f2e8df747ea0ca15208fdfc90e3275240184f/semver.md):

Semantic Versioning Specification (SemVer)
------------------------------------------

The key words "MUST", "MUST NOT", "REQUIRED", "SHALL", "SHALL NOT", "SHOULD",
"SHOULD NOT", "RECOMMENDED", "MAY", and "OPTIONAL" in this document are to be
interpreted as described in RFC 2119.

1. Software using Semantic Versioning MUST declare a public API. This API
could be declared in the code itself or exist strictly in documentation.
However it is done, it should be precise and comprehensive.

1. A normal version number MUST take the form X.Y.Z where X, Y, and Z are
non-negative integers. X is the major version, Y is the minor version, and Z
is the patch version. Each element MUST increase numerically by increments of
one. For instance: 1.9.0 -> 1.10.0 -> 1.11.0.

1. Once a versioned package has been released, the contents of that version
MUST NOT be modified. Any modifications must be released as a new version.

1. Major version zero (0.y.z) is for initial development. Anything may change
at any time. The public API should not be considered stable.

1. Version 1.0.0 defines the public API. The way in which the version number
is incremented after this release is dependent on this public API and how it
changes.

1. Patch version Z (x.y.Z | x > 0) MUST be incremented if only backwards
compatible bug fixes are introduced. A bug fix is defined as an internal
change that fixes incorrect behavior.

1. Minor version Y (x.Y.z | x > 0) MUST be incremented if new, backwards
compatible functionality is introduced to the public API. It MUST be
incremented if any public API functionality is marked as deprecated. It MAY be
incremented if substantial new functionality or improvements are introduced
within the private code. It MAY include patch level changes. Patch version
MUST be reset to 0 when minor version is incremented.

1. Major version X (X.y.z | X > 0) MUST be incremented if any backwards
incompatible changes are introduced to the public API. It MAY include minor
and patch level changes. Patch and minor version MUST be reset to 0 when major
version is incremented.

1. A pre-release version MAY be denoted by appending a hyphen and a series of
dot separated identifiers immediately following the patch version. Identifiers
MUST be comprised of only ASCII alphanumerics and dash [0-9A-Za-z-].
Pre-release versions satisfy but have a lower precedence than the associated
normal version. Examples: 1.0.0-alpha, 1.0.0-alpha.1, 1.0.0-0.3.7,
1.0.0-x.7.z.92.

1. A build version MAY be denoted by appending a plus sign and a series of dot
separated identifiers immediately following the patch version or pre-release
version. Identifiers MUST be comprised of only ASCII alphanumerics and dash
[0-9A-Za-z-]. Build versions satisfy and have a higher precedence than the
associated normal version. Examples: 1.0.0+build.1, 1.3.7+build.11.e0f985a.

1. Precedence MUST be calculated by separating the version into major, minor,
patch, pre-release, and build identifiers in that order. Major, minor, and
patch versions are always compared numerically. Pre-release and build version
precedence MUST be determined by comparing each dot separated identifier as
follows: identifiers consisting of only digits are compared numerically and
identifiers with letters or dashes are compared lexically in ASCII sort order.
Numeric identifiers always have lower precedence than non-numeric identifiers.
Example: 1.0.0-alpha < 1.0.0-alpha.1 < 1.0.0-beta.2 < 1.0.0-beta.11 <
1.0.0-rc.1 < 1.0.0-rc.1+build.1 < 1.0.0 < 1.0.0+0.3.7 < 1.3.7+build <
1.3.7+build.2.b8f12d7 < 1.3.7+build.11.e0f985a.

About
-----

The Semantic Versioning specification is authored by [Tom
Preston-Werner](http://tom.preston-werner.com), inventor of Gravatars and
cofounder of GitHub.

If you'd like to leave feedback, please [open an issue on
GitHub](https://github.com/mojombo/semver/issues).


License
-------

Creative Commons - CC BY 3.0
http://creativecommons.org/licenses/by/3.0/
!
!MetacelloSemanticVersionNumber methodsFor: 'private' stamp: ''!
decrementNormalVersionAt: index
  | int col |
  col := self normalVersion.
  int := col at: index.
  int > 0
    ifTrue: [ col at: index put: int - 1 ]! !

!MetacelloSemanticVersionNumber methodsFor: 'comparing' stamp: ''!
< aMetacelloVersionNumber
    aMetacelloVersionNumber species = self species
        ifFalse: [ ^ false ].
    ^ self compareLessThan: aMetacelloVersionNumber! !

!MetacelloSemanticVersionNumber methodsFor: 'operations' stamp: ''!
incrementMinorVersion
  self incrementNormalVersionAt: 2! !

!MetacelloSemanticVersionNumber methodsFor: 'comparing' stamp: ''!
= aMetacelloVersionNumber
    aMetacelloVersionNumber species = self species
        ifFalse: [ ^ false ].
    ^ self compareEqualTo: aMetacelloVersionNumber! !

!MetacelloSemanticVersionNumber methodsFor: 'enumerating' stamp: ''!
do: elementBlock separatedBy: separatorBlock
	"Evaluate the elementBlock for all elements in the receiver,
	and evaluate the separatorBlock between."

	| beforeFirst | 
	beforeFirst := true.
	self do:
		[:each |
		beforeFirst
			ifTrue: [beforeFirst := false]
			ifFalse: [separatorBlock value].
		elementBlock value: each]! !

!MetacelloSemanticVersionNumber methodsFor: 'comparing' stamp: ''!
hash
    ^ self versionComponents hash! !

!MetacelloSemanticVersionNumber methodsFor: 'private' stamp: ''!
incrementNormalVersionAt: index
  | int col |
  col := self normalVersion.
  int := col at: index.
  col at: index put: int + 1! !

!MetacelloSemanticVersionNumber methodsFor: 'printing' stamp: ''!
print: components prefix: prefixChar on: aStream
    | beforeFirst |
    beforeFirst := true.
    components
        do: [ :component | 
            beforeFirst
                ifTrue: [ 
                    beforeFirst := false.
                    prefixChar ifNotNil: [ aStream nextPut: prefixChar ] ]
                ifFalse: [ aStream nextPut: $. ].
            aStream nextPutAll: component asString ]! !

!MetacelloSemanticVersionNumber methodsFor: 'comparing' stamp: ''!
~> aMetacelloVersionNumber

	aMetacelloVersionNumber size == 1 ifTrue: [ ^false ].
	^self >= aMetacelloVersionNumber and: [ self < aMetacelloVersionNumber approximateBase ]! !

!MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: ''!
normalVersion: anObject
	normalVersion := anObject! !

!MetacelloSemanticVersionNumber methodsFor: 'printing' stamp: ''!
printOn: aStream
    self print: self normalVersion prefix: nil on: aStream.
    self print: self preReleaseVersion prefix: $- on: aStream.
    self print: self buildVersion prefix: $+ on: aStream! !

!MetacelloSemanticVersionNumber methodsFor: 'private' stamp: ''!
compareLessThan: myComponents other: otherComponents version: version
	| mySize aSize commonSize count more |
	mySize := myComponents size.
	aSize := otherComponents size.
	commonSize := mySize min: aSize.
	count := 0.
	more := true.
	[ more and: [ count < commonSize ] ]
		whileTrue: [ (myComponents at: count + 1) = (otherComponents at: count + 1)
				ifTrue: [ count := count + 1 ]
				ifFalse: [ more := false ] ].
	count < commonSize ifTrue: [ ^ (myComponents at: count + 1) metacelloSemanticVersionComponentLessThan: (otherComponents at: count + 1) ].
	^ mySize < aSize
		ifTrue: [ mySize = 0
				ifTrue: [ #preRelease == version ifTrue: [ ^ false ].
					^ true ].
			(myComponents at: commonSize) = (otherComponents at: commonSize) ifFalse: [ ^ true ].
			true ]
		ifFalse: [ mySize = aSize ifTrue: [ ^ false ].
			aSize = 0
				ifTrue: [ #build == version ifTrue: [ ^ false ].
					^ true ].
			(myComponents at: commonSize) = (otherComponents at: commonSize) ifFalse: [ ^ false ].
			true ]! !

!MetacelloSemanticVersionNumber methodsFor: 'converting' stamp: ''!
asMetacelloSemanticVersionNumber
    ^ self! !

!MetacelloSemanticVersionNumber methodsFor: 'operations' stamp: ''!
incrementMinorVersionNumber
  self incrementNormalVersionAt: 3! !

!MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: ''!
approximateBase

	| base |
	base := self copyFrom: 1 to: self size - 1.
	base at: base size put: (base at: base size) + 1.
	^base! !

!MetacelloSemanticVersionNumber methodsFor: 'enumerating' stamp: ''!
do: aBlock 
	"Refer to the comment in Collection|do:."
	1 to: self size do:
		[:index | aBlock value: (self at: index)]! !

!MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: ''!
versionString

	| strm |
	strm := WriteStream on: String new.
	self printOn: strm.
	^strm contents! !

!MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: ''!
buildVersion
    buildVersion ifNil: [ buildVersion := #() ].
    ^ buildVersion! !

!MetacelloSemanticVersionNumber methodsFor: 'private' stamp: ''!
compareEqualTo: aMetacelloVersionNumber
    aMetacelloVersionNumber species = self species
        ifFalse: [ ^ false ].
    (self compareEqualTo: self normalVersion other: aMetacelloVersionNumber normalVersion)
        ifFalse: [ ^ false ].
    (self compareEqualTo: self preReleaseVersion other: aMetacelloVersionNumber preReleaseVersion)
        ifFalse: [ ^ false ].
    ^ self compareEqualTo: self buildVersion other: aMetacelloVersionNumber buildVersion! !

!MetacelloSemanticVersionNumber methodsFor: 'operations' stamp: ''!
incrementMajorVersion
  self incrementNormalVersionAt: 1! !

!MetacelloSemanticVersionNumber methodsFor: 'operations' stamp: ''!
incrementPatchVersion
  self incrementNormalVersionAt: 3! !

!MetacelloSemanticVersionNumber methodsFor: 'private' stamp: ''!
compareEqualTo: myComponents other: otherComponents
    | mySize |
    mySize := myComponents size.
    mySize = otherComponents size
        ifFalse: [ ^ false ].
    1 to: mySize do: [ :i | 
        (myComponents at: i) = (otherComponents at: i)
            ifFalse: [ ^ false ] ].
    ^ true! !

!MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: ''!
preReleaseVersion: anObject
	preReleaseVersion := anObject! !

!MetacelloSemanticVersionNumber methodsFor: 'private' stamp: ''!
versionComponents
    ^ self normalVersion , self preReleaseVersion , self buildVersion! !

!MetacelloSemanticVersionNumber methodsFor: 'copying' stamp: ''!
postCopy
  normalVersion := normalVersion copy.
  preReleaseVersion := preReleaseVersion copy.
  buildVersion := buildVersion copy! !

!MetacelloSemanticVersionNumber methodsFor: 'private' stamp: ''!
compareLessThan: aMetacelloVersionNumber
    | myComponents otherComponents defaultResult |
    aMetacelloVersionNumber species = self species
        ifFalse: [ ^ false ].
    myComponents := self normalVersion.
    otherComponents := aMetacelloVersionNumber normalVersion.
    defaultResult := true.
    (self compareEqualTo: myComponents other: otherComponents)
        ifTrue: [ defaultResult := false ]
        ifFalse: [ 
            (self compareLessThan: myComponents other: otherComponents version: #'normal')
                ifFalse: [ ^ false ] ].
    myComponents := self preReleaseVersion.
    otherComponents := aMetacelloVersionNumber preReleaseVersion.
    (self compareEqualTo: myComponents other: otherComponents)
        ifTrue: [ 
            myComponents size > 0
                ifTrue: [ defaultResult := false ] ]
        ifFalse: [ ^ self compareLessThan: myComponents other: otherComponents version: #'preRelease' ].
    myComponents := self buildVersion.
    otherComponents := aMetacelloVersionNumber buildVersion.
    ^ (self compareEqualTo: myComponents other: otherComponents)
        ifTrue: [ defaultResult ]
        ifFalse: [ self compareLessThan: myComponents other: otherComponents version: #'build' ]! !

!MetacelloSemanticVersionNumber methodsFor: 'operations' stamp: ''!
decrementPatchVersion
  self decrementNormalVersionAt: 3! !

!MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: ''!
buildVersion: anObject
	buildVersion := anObject! !

!MetacelloSemanticVersionNumber methodsFor: 'printing' stamp: ''!
asString
	"Answer a string that represents the receiver."

	^ self printString! !

!MetacelloSemanticVersionNumber methodsFor: 'copying' stamp: ''!
copyFrom: start to: stop 
	"Answer a copy of a subset of the receiver, starting from element at 
	index start until element at index stop."

	| newSize new j |
	newSize := stop - start + 1.
	new := self species new: newSize.
	j := 0.
	start to: stop do: [:i |
		new at: j + 1 put: (self at: i).
		j := j + 1 ].
	^new! !

!MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: ''!
normalVersion
    normalVersion ifNil: [ normalVersion := #() ].
    ^ normalVersion! !

!MetacelloSemanticVersionNumber methodsFor: 'operations' stamp: ''!
decrementMinorVersionNumber
  self decrementNormalVersionAt: 3! !

!MetacelloSemanticVersionNumber methodsFor: 'comparing' stamp: ''!
match: aVersionPattern
    "Answer whether the version number of the receiver matches the given pattern string.

	 A Metacello version number is made up of version sequences delimited by the characters $. and $-.
	 The $. introduces a numeric version sequence and $- introduces an alphanumeric version sequence.
	 
	 A version pattern is made up of version pattern match sequences. also delimited by the characters $. 
	 and $-.. Each pattern match sequence is tested against the corresponding version sequence of the 
	 receiver, using the 'standard' pattern matching rules. All sequences must answer true for a match.
	
	 The special pattern sequence '?' is a match for the corresponding version sequence and all subsequent 
	 version sequences. '?' as the version pattern matches all versions. No more version pattern 
	 sequences are permitted once the '?' sequence is used. If used, it is the last version pattern
	 sequence. "

    | patternVersion mySize patternSize components |
    patternVersion := (self class fromString: aVersionPattern forPattern: true) versionComponents.
    components := self versionComponents.
    mySize := components size.
    patternSize := patternVersion size.
    mySize = patternSize
        ifFalse: [ 
            mySize < patternSize
                ifTrue: [ ^ false ].
            (patternVersion at: patternSize) ~= '?'
                ifTrue: [ ^ false ].
            mySize := patternSize ].
    1 to: mySize do: [ :i | 
        | pattern |
        pattern := (patternVersion at: i) asString.
        pattern = '?'
            ifTrue: [ 
                i = mySize
                    ifFalse: [ ^ self error: 'Invalid version match pattern: ' , aVersionPattern printString ] ]
            ifFalse: [ 
                (pattern match: (components at: i) asString)
                    ifFalse: [ ^ false ] ] ].
    ^ true! !

!MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: ''!
preReleaseVersion
    preReleaseVersion ifNil: [ preReleaseVersion := #() ].
    ^ preReleaseVersion! !

!MetacelloSemanticVersionNumber methodsFor: 'operations' stamp: ''!
decrementMinorVersion
  self decrementNormalVersionAt: 2! !

!MetacelloSemanticVersionNumber methodsFor: 'operations' stamp: ''!
decrementMajorVersion
  self decrementNormalVersionAt: 1! !

!MetacelloSemanticVersionNumber class methodsFor: 'instance creation' stamp: ''!
fromString: aString
  | svn |
  svn := self fromString: aString forPattern: false.
  self validateVersionNumber: svn against: aString.
  ^ svn! !

!MetacelloSemanticVersionNumber class methodsFor: 'private' stamp: ''!
isSemanticIdentifier: aString
    "whether the receiver is composed entirely of alphanumerics"

    aString
        do: [ :c | 
            c isAlphaNumeric
                ifFalse: [ 
                    c = $-
                        ifFalse: [ ^ false ] ] ].
    ^ true! !

!MetacelloSemanticVersionNumber class methodsFor: 'private' stamp: ''!
validateVersionNumber: svn against: aString
  svn printString = aString
    ifFalse: [ 
      self
        error:
          'The printString of a semantic version number should be equal to the source version string' ]! !

!MetacelloSemanticVersionNumber class methodsFor: 'private' stamp: ''!
integerFromString: aString
  aString
    detect: [ :char | char isDigit not ]
    ifNone: [ 
      | integer |
      integer := aString asInteger.
      ((aString at: 1) = $0 and: [ aString size > 1 ])
        ifTrue: [ 
          self
            error:
              'invalid version number: normal version component must not have leading 0s'
                , aString asString ].
      ^ integer ].
  self
    error:
      'invalid version number: normal version component must be integer '
        , aString asString! !

!MetacelloSemanticVersionNumber class methodsFor: 'instance creation' stamp: ''!
fromString: aString forPattern: forPattern
  | preRelease build versionString identifierCount normalEnd preReleaseEnd normalComponents preReleaseComponents buildComponents |
  normalComponents := OrderedCollection new.
  preReleaseComponents := OrderedCollection new.
  buildComponents := OrderedCollection new.
  preRelease := aString indexOf: $- startingAt: 1.
  build := aString indexOf: $+ startingAt: 1.
  (build > 0 and: [ preRelease > build ])
    ifTrue: [ preRelease := 0 ].
  normalEnd := preRelease = 0
    ifTrue: [ 
      build = 0
        ifTrue: [ aString size ]
        ifFalse: [ build - 1 ] ]
    ifFalse: [ preRelease - 1 ].
  versionString := aString copyFrom: 1 to: normalEnd.
  identifierCount := 0.
  (versionString findTokens: '.')
    do: [ :subString | 
      | integer |
      forPattern
        ifTrue: [ integer := subString ]
        ifFalse: [ 
          integer := self integerFromString: subString.
          integer < 0
            ifTrue: [ 
              self
                error:
                  'invalid version number: normal version component must be integer '
                    , subString printString ] ].
      normalComponents add: integer.
      identifierCount := identifierCount + 1 ].
  (forPattern not and: [ identifierCount ~= 3 ])
    ifTrue: [ self error: 'invalid version number: normal version must have only 3 components' ].
  preReleaseEnd := build = 0
    ifTrue: [ aString size ]
    ifFalse: [ build - 1 ].
  preRelease > 0
    ifTrue: [ 
      versionString := aString copyFrom: preRelease + 1 to: preReleaseEnd.
      (versionString findTokens: '.')
        do: [ :subString | 
          (forPattern or: [ self isSemanticIdentifier: subString ])
            ifFalse: [ 
              self
                error:
                  'invalid version number: preRelease version component must be one of [0-9A-Za-z-]' ].
          preReleaseComponents
            add:
              (self extractNumericComponent: subString forPattern: forPattern) ] ].
  build > 0
    ifTrue: [ 
      versionString := aString copyFrom: build + 1 to: aString size.
      (versionString findTokens: '.')
        do: [ :subString | 
          (forPattern or: [ self isSemanticIdentifier: subString ])
            ifFalse: [ 
              self
                error:
                  'invalid version number: build version component must be one of [0-9A-Za-z-]' ].
          buildComponents
            add:
              (self extractNumericComponent: subString forPattern: forPattern) ] ].
  ^ self new
    normalVersion: normalComponents;
    preReleaseVersion: preReleaseComponents;
    buildVersion: buildComponents;
    yourself! !

!MetacelloSemanticVersionNumber class methodsFor: 'private' stamp: ''!
extractNumericComponent: subString forPattern: forPattern
    "$. separated components are integers"

    | number |
    forPattern
        ifTrue: [ ^ subString ].
    number := [ subString asNumber ]
        on: Error
        do: [ :ex | ex return: subString ].
    ^ number asString = subString
        ifTrue: [ number ]
        ifFalse: [ subString ]! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion10
	| x y |
	self
		assert:
			(x := (({(self versionClass fromString: '1.0.0') . (self versionClass fromString: '0.7.0') . (self versionClass fromString: '0.8.0').
			(self versionClass fromString: '0.9.0') . (self versionClass fromString: '1.0.1')} sort: [ :a :b | a <= b ]) collect: [ :each | each versionString ]) asArray)
		equals: (y := #('0.7.0' '0.8.0' '0.9.0' '1.0.0' '1.0.1'))! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testIssue392
  "semantic version strings that are actually invalid, but were allowed by MetacelloOldSemanticVersionNumber"

  #('v0.0.1' '00.0.1' '16r00.0.1' '101r.0.1' 'rr101r.0.1')
    do: [ :versionString | 
      MetacelloOldSemanticVersionNumber fromString: versionString.
      self should: [ self versionClass fromString: versionString ] raise: Error ]! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testEqualityComparison
	self deny: '1.0.0+-' asMetacelloSemanticVersionNumber equals: '1.0.0--' asMetacelloSemanticVersionNumber.
	self sampleVersionStrings
		do: [ :versionString | self assert: versionString asMetacelloSemanticVersionNumber equals: versionString asMetacelloSemanticVersionNumber ]! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion19
    self assert: (self versionClass fromString: '1.0.0-beta.0') < (self versionClass fromString: '1.0.0')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'private' stamp: ''!
versionClass
    ^ MetacelloSemanticVersionNumber! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion05
    | v1 v2 |
    v1 := self versionClass fromString: '3.0.0'.
    v2 := self versionClass fromString: '2.0.0'.
    self assert: v1 > v2! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion09
    | v1 v2 |
    v1 := self versionClass fromString: '1.0.0'.
    v2 := self versionClass fromString: '0.7.0'.
    self assert: v1 >= v2.
    self assert: v2 <= v1! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion15
    self assert: (self versionClass fromString: '1.0.0-beta.0') < (self versionClass fromString: '1.0.0-beta.1')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testSemanticVersioningSubsetCompliance
    "subset of sample versions that are compatible with MetacellVersionNumber syntax"

    self
        validateSemanticVersionStrings:
            #('1.0.0-alpha' '1.0.0-alpha.1' '1.0.0-beta.2' '1.0.0-beta.11' '1.0.0-rc.1' '1.0.0')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testSemanticVersioningSpecItem12
    "According to [Semantic Versioning 2.0.0-rc.1](http://semver.org/), the following expression should be true:
	1.0.0-alpha < 1.0.0-alpha.1 < 1.0.0-beta.2 < 1.0.0-beta.11 < 1.0.0-rc.1 < 1.0.0-rc.1+build.1 < 1.0.0 < 
		1.0.0+0.3.7 < 1.3.7+build < 1.3.7+build.2.b8f12d7 < 1.3.7+build.11.e0f985a"

    self
        validateSemanticVersionStrings:
            #('1.0.0-alpha' '1.0.0-alpha.1' '1.0.0-beta.2' '1.0.0-beta.11' '1.0.0-rc.1' '1.0.0-rc.1+build.1' '1.0.0' '1.0.0+0.3.7' '1.3.7+build' '1.3.7+build.2.b8f12d7' '1.3.7+build.11.e0f985a')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests - matching' stamp: ''!
testStandardMatch
    self assert: ((self versionClass fromString: '1.0.0+alpha5.0') match: '1.0.0+alpha#.0').
    self assert: ((self versionClass fromString: '1.1.1') match: '*.*.*').
    self deny: ((self versionClass fromString: '1.1.1') match: '*.*').
    self assert: ((self versionClass fromString: '1.1.0') match: '1.1.*').
    self assert: ((self versionClass fromString: '1.1.0') match: '1.#.*').
    self deny: ((self versionClass fromString: '1.10.0+build.0') match: '1.#.*').
    self assert: ((self versionClass fromString: '1.0.0-alpha5.0') match: '1.0.0-alpha#.0').
    self assert: ((self versionClass fromString: '1.0.0-alpha5+build5.0') match: '1.0.0-alpha5+build#.0').
    self deny: ((self versionClass fromString: '1.0.0-alpha10.0') match: '1.0.0-alpha#.0')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testSemanticVersioning
    self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0-rc.1+build.2' '1.0.0-rc.2+build.0').
    self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0+build.0').
    self validateSemanticVersionStrings: #('1.0.0-alpha' '1.0.0-1').
    self validateSemanticVersionStrings: #('1.0.0-1' '1.0.0+alpha').
    self validateSemanticVersionStrings: #('1.0.0-alpha' '1.0.0+1').
    self validateSemanticVersionStrings: #('1.0.0+alpha' '1.0.0+1').
    self validateSemanticVersionStrings: #('1.0.0--' '1.0.0-a').
    self validateSemanticVersionStrings: #('1.0.0+-' '1.0.0+a').
    self validateSemanticVersionStrings: #('1.0.0-rc.1' '1.0.0' '1.0.0+build.1').
    self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0-rc.1+build.2' '1.0.0-rc.2+build.3').
    self validateSemanticVersionStrings: #('1.0.0-rc.1' '1.0.0-rc.1+build.2' '1.0.0-rc.2').
    self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0-rc.1+build.2' '1.0.0-rc.2').
    self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0-rc.1+build.2' '1.0.0-rc.2+build.2').
    self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0' '1.0.0+build.0').
    self validateSemanticVersionStrings: #('1.0.0+10000' '1.0.0+a').
    self validateSemanticVersionStrings: #('1.0.0-10000' '1.0.0-a')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests - matching' stamp: ''!
testSpecialMatch
    self assert: ((self versionClass fromString: '1.1.0') match: '?').
    self assert: ((self versionClass fromString: '1.0.0-alpha') match: '?').
    self assert: ((self versionClass fromString: '1.0.0-rc.1+build.1') match: '?').
    self assert: ((self versionClass fromString: '1.1.0') match: '*.*.?').
    self assert: ((self versionClass fromString: '1.3.7+build.2.b8f12d7') match: '?').
    self assert: ((self versionClass fromString: '1.3.7+build.11.e0f985a') match: '?').
    self deny: ((self versionClass fromString: '1.1.0') match: '*.*.*-?').
    self deny: ((self versionClass fromString: '1.1.0') match: '*.*.*+?').
    self assert: ((self versionClass fromString: '1.1.1') match: '*.?')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion16
    self assert: (self versionClass fromString: '1.0.0-beta.0') < (self versionClass fromString: '1.0.0')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testLessThanComparison
    self assert: '1.0.0-rc.1+build.1' asMetacelloSemanticVersionNumber < '1.0.0' asMetacelloSemanticVersionNumber.
    self
        assert: '1.0.0-rc.1+build.1' asMetacelloSemanticVersionNumber < '1.0.0+build.0' asMetacelloSemanticVersionNumber.
    self assert: '1.0.0-alpha.1' asMetacelloSemanticVersionNumber < '1.0.0-0.3.7' asMetacelloSemanticVersionNumber.
    self assert: '1.0.0-alpha' asMetacelloSemanticVersionNumber < '1.0.0-alpha.1' asMetacelloSemanticVersionNumber.
    self assert: '1.0.0+-' asMetacelloSemanticVersionNumber < '1.0.0+a' asMetacelloSemanticVersionNumber.
    self assert: '1.0.0-0.3.7' asMetacelloSemanticVersionNumber < '1.0.0-x.7.z.92' asMetacelloSemanticVersionNumber! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testPrinting
	| x vrsn |
	self sampleVersionStrings
		do: [ :versionString | self assert: versionString equals: (x := (vrsn := versionString asMetacelloSemanticVersionNumber) printString) ]! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
sampleVersionStrings
    ^ #('1.0.0+-' '1.0.0-alpha' '1.0.0-alpha.1' '1.0.0-0.3.7' '1.0.0-x.7.z.92')
        , #('1.0.0+build.1' '1.3.7+build.11.e0f985a')
        ,
            #('1.0.0-alpha' '1.0.0-alpha.1' '1.0.0-beta.2' '1.0.0-beta.11' '1.0.0-rc.1' '1.0.0-rc.1+build.1' '1.0.0' '1.0.0+0.3.7' '1.3.7+build' '1.3.7+build.2.b8f12d7' '1.3.7+build.11.e0f985a')
        , #('1.0.0-alp-h-a' '1.0.0-r-c.1' '1.0.0+alp-h-a' '1.0.0+r-c.1')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testSemanticVersioningSpecItem11
    "[Semantic Versioning 2.0.0-rc.1](http://semver.org/)"

    self validateSemanticVersionStrings: #('1.0.0+build.1' '1.3.7+build.11.e0f985a')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion18
    | x y |
    self deny: (x := self versionClass fromString: '1.0.0') < (y := self versionClass fromString: '1.0.0-0').
    self assert: (x := self versionClass fromString: '1.0.0') > (y := self versionClass fromString: '1.0.0-0').
    self assert: (x := self versionClass fromString: '1.0.0') < (y := self versionClass fromString: '1.0.0+0').
    self deny: (x := self versionClass fromString: '1.0.0') > (y := self versionClass fromString: '1.0.0+0')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion17
    self assert: (self versionClass fromString: '1.0.0') > (self versionClass fromString: '1.0.0-0').
    self assert: (self versionClass fromString: '1.0.0') > (self versionClass fromString: '1.0.0-beta.0').
    self assert: (self versionClass fromString: '1.0.0') > (self versionClass fromString: '1.0.0-beta')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
validateSemanticVersionStrings: versionStrings
    | versions version |
    versions := versionStrings collect: [ :each | each asMetacelloSemanticVersionNumber ].
    version := versions at: 1.
    2 to: versions size do: [ :index | 
        | nextVersion |
        nextVersion := versions at: index.
        self assert: version < nextVersion.
        version := nextVersion ]! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testSemanticVersioningSpecItem10
    "[Semantic Versioning 2.0.0-rc.1](http://semver.org/)"

    self validateSemanticVersionStrings: #('1.0.0-alpha' '1.0.0-alpha.1' '1.0.0-0.3.7' '1.0.0-x.7.z.92')! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests - matching' stamp: ''!
testInvalidSpecialMatch
    self should: [ (self versionClass fromString: '1.1.1') match: '?.?.?' ] raise: Error! !

!MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion12
    self deny: (self versionClass fromString: '1.0.0') <= (self versionClass fromString: '0.7.0')! !

!MetacelloSkipDirtyPackageLoad methodsFor: 'accessing' stamp: ''!
packageSpec

	^packageSpec! !

!MetacelloSkipDirtyPackageLoad methodsFor: 'accessing' stamp: ''!
defaultAction
	"Default action is to skip the load of a dirty package"

	^true! !

!MetacelloSkipDirtyPackageLoad methodsFor: 'accessing' stamp: ''!
packageSpec: aMetacelloPackageSpec

	packageSpec := aMetacelloPackageSpec! !

!MetacelloSkipDirtyPackageLoad class methodsFor: 'signalling' stamp: ''!
signal: aMetacelloPackageSpec

	^(self new packageSpec: aMetacelloPackageSpec) signal! !

!MetacelloSpec methodsFor: 'doits' stamp: ''!
doItBlock: selector

	selector == nil ifTrue: [ ^nil ].
	selector numArgs = 0
		ifTrue: [ ^[ self project configuration perform: selector ] ].
	selector numArgs = 1
		ifTrue: [ ^[:aLoader | self project configuration perform: selector with: aLoader ] ].
	selector numArgs = 2
		ifTrue: [ ^[:aLoader :pkgSpec | self project configuration perform: selector with: aLoader with: pkgSpec ] ].
	^nil! !

!MetacelloSpec methodsFor: 'spec creation' stamp: ''!
removeMember

	^MetacelloRemoveMemberSpec for: self project! !

!MetacelloSpec methodsFor: 'mutability' stamp: ''!
shouldBeMutable
    self isMutable
        ifTrue: [ ^ self ].
    self error: 'Not allowed to modify an immutable object'! !

!MetacelloSpec methodsFor: 'merging' stamp: ''!
validateMergeForSpec: aSpec
    aSpec class = self class
        ifFalse: [ 
            self
                error:
                    'The project spec ' , self name printString , ' in project ' , self project label , ' has incompatible specs. '
                        , aSpec class name asString , ' and ' , self class name asString , ' are not compatible.' ]! !

!MetacelloSpec methodsFor: 'spec creation' stamp: ''!
copyMember

	^MetacelloCopyMemberSpec for: self project! !

!MetacelloSpec methodsFor: 'mutability' stamp: ''!
immutable
    mutable := false! !

!MetacelloSpec methodsFor: 'doits' stamp: ''!
preLoadDoItBlock

	^self doItBlock: self preLoadDoIt value! !

!MetacelloSpec methodsFor: 'printing' stamp: ''!
printOn: aStream

	self configMethodOn: aStream indent: 0! !

!MetacelloSpec methodsFor: 'merging' stamp: ''!
mergeMap

	^Dictionary new.! !

!MetacelloSpec methodsFor: 'accessing' stamp: ''!
loader: aLoader
    "We're interested in propogating the loader state, _except_ for the spec"

    self shouldBeMutable.
    loader := aLoader copy.
    loader spec: self! !

!MetacelloSpec methodsFor: 'doits' stamp: ''!
preLoadDoIt
	"noop unless non-nil value returned"
	
	^nil! !

!MetacelloSpec methodsFor: 'querying' stamp: ''!
answers

	^#()! !

!MetacelloSpec methodsFor: 'printing' stamp: ''!
label

	^self printString! !

!MetacelloSpec methodsFor: 'accessing' stamp: ''!
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: 'printing' stamp: ''!
configMethodOn: aStream indent: indent

	self subclassResponsibility! !

!MetacelloSpec methodsFor: 'merging' stamp: ''!
aboutToCopy! !

!MetacelloSpec methodsFor: 'mutability' stamp: ''!
mutable
    mutable := true! !

!MetacelloSpec methodsFor: 'initialization' stamp: ''!
for: aProject
    self shouldBeMutable.
    project := aProject! !

!MetacelloSpec methodsFor: 'doits' stamp: ''!
postLoadDoIt
	"noop unless non-nil value returned"

	^nil! !

!MetacelloSpec methodsFor: 'merging' stamp: ''!
nonOverridable

	^#()! !

!MetacelloSpec methodsFor: 'mutability' stamp: ''!
isMutable
    mutable ifNil: [ ^ true ].
    ^ mutable! !

!MetacelloSpec methodsFor: 'copying' stamp: ''!
postCopy
    super postCopy.
    mutable := nil.
    loader ~~ nil
        ifTrue: [ self loader: loader ].! !

!MetacelloSpec methodsFor: 'querying' stamp: ''!
project

	^project! !

!MetacelloSpec methodsFor: 'doits' stamp: ''!
postLoadDoItBlock

	^self doItBlock: self postLoadDoIt value! !

!MetacelloSpec methodsFor: 'printing' stamp: ''!
configMethodOn: aStream

	self configMethodOn: aStream indent: 0! !

!MetacelloSpec methodsFor: 'merging' stamp: ''!
mergeSpec: aSpec
    | newSpec nonOverridable |
    self validateMergeForSpec: aSpec.
    newSpec := self copy.
    nonOverridable := self nonOverridable.
    aSpec mergeMap
        keysAndValuesDo: [ :key :value | 
            (nonOverridable includes: key)
                ifFalse: [ 
                    value ~~ nil
                        ifTrue: [ newSpec instVarNamed: key asString put: value ] ] ].
    ^ newSpec! !

!MetacelloSpec methodsFor: 'spec creation' stamp: ''!
addMember

	^MetacelloAddMemberSpec for: self project! !

!MetacelloSpec methodsFor: 'spec creation' stamp: ''!
mergeMember

	^MetacelloMergeMemberSpec for: self project! !

!MetacelloSpec methodsFor: 'importing' stamp: ''!
mergeImportLoads: aLoadList
    self error: 'import: can only be used with baseline project specs'! !

!MetacelloSpec methodsFor: 'mutability' stamp: ''!
copyOnWrite: aBlock
    "assume that only registered projects are immutable ... otherwise you'll get an error"

    | copy |
    copy := self copy.
    aBlock value: copy.
    ^ copy! !

!MetacelloSpec class methodsFor: 'instance creation' stamp: ''!
for: aVersionMap

	^(self platformClass new)
		for: aVersionMap;
		yourself! !

!MetacelloSpec class methodsFor: 'accessing' stamp: ''!
platformClass

	^self! !

!MetacelloSpecLoader methodsFor: 'actions' stamp: ''!
load

	self subclassResponsibility! !

!MetacelloSpecLoader methodsFor: 'accessing' stamp: ''!
loadType
	"#atomic or #linear"
	
	^self project loadType! !

!MetacelloSpecLoader methodsFor: 'actions' stamp: ''!
unload

	self subclassResponsibility! !

!MetacelloSpecLoader methodsFor: 'accessing' stamp: ''!
project

	^self spec project! !

!MetacelloSpecLoader methodsFor: 'accessing' stamp: ''!
spec: aMetacelloPackagesSpec

	spec := aMetacelloPackagesSpec! !

!MetacelloSpecLoader methodsFor: 'accessing' stamp: ''!
spec

	^spec! !

!MetacelloSpecLoader class methodsFor: 'instance creation' stamp: ''!
on: aMetacelloPackagesSpec

	^(self new) 
		spec: aMetacelloPackagesSpec;
		yourself! !

!MetacelloSpecTestCase methodsFor: 'specs' stamp: ''!
groupSpec
    ^ self project groupSpec! !

!MetacelloSpecTestCase methodsFor: 'specs' stamp: ''!
projectSpec
    ^ self project projectSpec! !

!MetacelloSpecTestCase methodsFor: 'accessing' stamp: ''!
projectWith: projectAttributes
    | project |
    "Construct Metacello project"
    project := self projectClass new.
    project projectAttributes: projectAttributes.
    MetacelloVersionConstructor on: self project: project.
    project loader: MetacelloNullRecordingMCSpecLoader new.
    ^ project! !

!MetacelloSpecTestCase methodsFor: '*metacello-testsmccore' stamp: ''!
packageSpec
    ^ self project packageSpec! !

!MetacelloSpecTestCase methodsFor: 'specs' stamp: ''!
projectReferenceSpec
    ^ self project projectReferenceSpec! !

!MetacelloSpecTestCase methodsFor: 'accessing' stamp: ''!
projectClass
    ^ MetacelloProject! !

!MetacelloSpecTestCase methodsFor: 'accessing' stamp: ''!
project
    ^ self projectWith: #()! !

!MetacelloSpecTestCase methodsFor: '*metacello-testsmccore' stamp: ''!
repositorySpec
    ^ self project repositorySpec! !

!MetacelloSpecTestCase methodsFor: '*metacello-testsmccore' stamp: ''!
repositoriesSpec
    ^ self project repositoriesSpec! !

!MetacelloSpecTestCase methodsFor: 'specs' stamp: ''!
packagesSpec
    ^ self project packagesSpec! !

!MetacelloSpecTestCase methodsFor: 'specs' stamp: ''!
valueHolderSpec
    ^ self project valueHolderSpec! !

!MetacelloSpecTestCase methodsFor: 'specs' stamp: ''!
versionSpec
    ^ self project versionSpec! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
testCollectionCacheKey
	| x |
	self assert: (Array with: self class with: (Array with: 'faux' with: 'foobar')) equals: (Array with: self class with: (Array with: 'faux' with: 'foobar')).
	self
		deny: (Array with: self class with: (Array with: 'faux' with: 'foobar'))
		equals: (Array with: self class with: (Array with: 'faux' with: 'foobar' with: 'foobaz')).
	self assert: (x := self collectionCacheKey) identicalTo: 6! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
directReturnOfValue

	^MetacelloPlatform current 
		stackCacheFor: #direct
		at: #key 
		doing: [:cache | | value |
			value := cache at: #x ifAbsent: [ 0 ].
			value > 5 ifTrue: [ ^value ].
			value := value + 1.
			cache at: #x put: value.
			self directReturnOfValue ]! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
cachedReturnOfValue

	^MetacelloPlatform current 
		stackCacheFor: #cached
		at: #key 
		doing: [:cache | | value |
			value := cache at: #x ifAbsent: [ 0 ].
			value > 5 
				ifTrue: [ cache at: #key put: value ]
				ifFalse: [ 
					value := value + 1.
					cache at: #x put: value ].
			self cachedReturnOfValue ]! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
testCacheNil
	| x |
	self assert: (x := self cacheNil) identicalTo: nil! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
testDefaultDictionary

	| defaultDictionary |
	defaultDictionary := Dictionary new.
	MetacelloPlatform current 
		useStackCacheDuring: [:dict | 
			self 
				cachedReturnOfValue;
				collectionCacheKey;
				cacheNil;
				directReturnOfValue;
				mixedStack;
				mixedStackCall ] 
		defaultDictionary: defaultDictionary.
	self assert: (defaultDictionary includesKey: #cached).
	self assert: (defaultDictionary includesKey: #cacheNil).
	self assert: (defaultDictionary includesKey: #collection).
	self assert: (defaultDictionary includesKey: #direct).
	self assert: (defaultDictionary includesKey: #mixed).
	self assert: (defaultDictionary includesKey: #mixedStack).! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
testCachedReturn
	| x |
	self assert: (x := self cachedReturnOfValue) identicalTo: 6! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
mixedStack
	^ MetacelloPlatform current
		stackCacheFor: #mixed
		at: #key
		doing: [ :cache | 
			| value |
			value := cache at: #x ifAbsent: [ 0 ].
			value > 3 ifTrue: [ ^ value ].
			value := value + 1.
			cache at: #x put: value.
			self assert: self directReturnOfValue identicalTo: 6.
			self assert: self mixedStackCall identicalTo: 4.
			self mixedStack ]! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
cacheNil

	^MetacelloPlatform current 
		stackCacheFor: #cacheNil
		at: #key 
		doing: [:cache | | value |
			cache at: #key put: nil.
			self cacheNil ]! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
collectionCacheKey

	| key |
	key := Array with: self class with: (Array with: #x with: #y).
	^MetacelloPlatform current 
		stackCacheFor: #collection
		at: key 
		doing: [:cache | | value |
			value := cache at: #x ifAbsent: [ 0 ].
			value > 5 
				ifTrue: [ cache at: key put: value ]
				ifFalse: [ 
					value := value + 1.
					cache at: #x put: value ].
			self collectionCacheKey ]! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
mixedStackCall
	^ MetacelloPlatform current
		stackCacheFor: #mixedStack
		at: #key
		doing: [ :cache | 
			| value |
			value := cache at: #x ifAbsent: [ 0 ].
			value > 3 ifTrue: [ ^ value ].
			value := value + 1.
			cache at: #x put: value.
			self assert: self cachedReturnOfValue identicalTo: 6.
			self mixedStackCall ]! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
testClearCache
	MetacelloPlatform current
		stackCacheFor: #cached
		at: #key
		doing: [ :cache | 
			| value |
			cache at: #x put: 1.
			self assert: (cache at: #x ifAbsent: [  ]) identicalTo: 1.
			MetacelloClearStackCacheNotification signal.
			self assert: (cache at: #x ifAbsent: [  ]) identicalTo: nil ]! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
testDirectReturn
	| x |
	self assert: (x := self directReturnOfValue) identicalTo: 6! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
testMixedStack
	| x |
	self assert: (x := self mixedStack) identicalTo: 4! !

!MetacelloStackCacheTestCase methodsFor: 'tests' stamp: ''!
testPrimeStackCache
	| cached collection cacheNil direct mixed mixedStack block defaultDictionary |
	defaultDictionary := Dictionary new.
	block := [ cached := Dictionary new.
	collection := Dictionary new.
	cacheNil := Dictionary new.
	direct := Dictionary new.
	mixed := Dictionary new.
	mixedStack := Dictionary new.
	MetacelloPlatform current useStackCacheDuring: [ :dict | self cachedReturnOfValue ] defaultDictionary: cached.
	MetacelloPlatform current useStackCacheDuring: [ :dict | self collectionCacheKey ] defaultDictionary: collection.
	MetacelloPlatform current useStackCacheDuring: [ :dict | self cacheNil ] defaultDictionary: cacheNil.
	MetacelloPlatform current useStackCacheDuring: [ :dict | self directReturnOfValue ] defaultDictionary: direct.
	MetacelloPlatform current useStackCacheDuring: [ :dict | self mixedStack ] defaultDictionary: mixed.
	MetacelloPlatform current useStackCacheDuring: [ :dict | self mixedStackCall ] defaultDictionary: mixedStack ].

	"Test without priming stack cache ... each defaultDictionary is used independently"
	block value.
	self assert: ((cached at: #cached) at: #key) identicalTo: 6.
	self assert: ((collection at: #collection) at: #x) identicalTo: 6.
	self assert: ((cacheNil at: #cacheNil) at: #key) identicalTo: nil.
	self assert: ((direct at: #direct) at: #x) identicalTo: 6.
	self assert: ((mixed at: #cached) at: #key) identicalTo: 6.
	self assert: ((mixed at: #mixed) at: #x) identicalTo: 4.
	self assert: ((mixed at: #mixedStack) at: #x) identicalTo: 4.
	self assert: ((mixed at: #direct) at: #x) identicalTo: 6.
	self assert: ((mixedStack at: #cached) at: #key) identicalTo: 6.
	self assert: ((mixedStack at: #mixedStack) at: #x) identicalTo: 4.

	"Prime stack cache with defaultDictionary .... all values should be stored there instead of individual defaults."
	MetacelloPlatform current primeStackCacheWith: defaultDictionary doing: block.
	self assert: ((defaultDictionary at: #cached) at: #key) identicalTo: 6.
	self assert: ((defaultDictionary at: #collection) at: #x) identicalTo: 6.
	self assert: ((defaultDictionary at: #cacheNil) at: #key) identicalTo: nil.
	self assert: ((defaultDictionary at: #direct) at: #x) identicalTo: 6.
	self assert: ((defaultDictionary at: #cached) at: #key) identicalTo: 6.
	self assert: ((defaultDictionary at: #mixed) at: #x) identicalTo: 4.
	self assert: ((defaultDictionary at: #mixedStack) at: #x) identicalTo: 4.
	self assert: ((defaultDictionary at: #direct) at: #x) identicalTo: 6.
	self assert: ((defaultDictionary at: #cached) at: #key) identicalTo: 6.
	self assert: ((defaultDictionary at: #mixedStack) at: #x) identicalTo: 4! !

!MetacelloSymbolicVersionDoesNotExistError methodsFor: 'accessing' stamp: ''!
possibleVersions
    ^ self project symbolicVersionSymbols! !

!MetacelloSymbolicVersionDoesNotExistError methodsFor: 'printing' stamp: ''!
description
    "Return a textual description of the exception."

    ^ 'The symbolic version ' , self versionString printString , ' is not defined in ' , self project label
        , ' for the current platform. Possible symbolic version values include: ' , self possibleVersions printString! !

!MetacelloSymbolicVersionMethodSpec methodsFor: 'method generation' stamp: ''!
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: 'accessing' stamp: ''!
versionString: aStringOrSymbol

	aStringOrSymbol isSymbol ifFalse: [ self error: 'Version symbol ', aStringOrSymbol printString, ' for symbolic version method must be a Symbol' ].
	super versionString: aStringOrSymbol! !

!MetacelloSymbolicVersionMethodSpec methodsFor: 'method generation' stamp: ''!
symbolicMethodSelectorAndPragma: aSelector symbolicVersionSymbol: symbolicVersionSymbol on: strm
	strm
		nextPutAll: aSelector asString , ' spec';
		cr;
		tab;
		nextPutAll: '<symbolicVersion: #' , symbolicVersionSymbol asString printString;
		nextPutAll: '>';
		cr! !

!MetacelloSymbolicVersionMethodSpec methodsFor: 'adding' stamp: ''!
addMethodSection: attribute versionString: aString
    self methodSections
        add:
            (MetacelloSymbolicVersionSpec new
                attributes: attribute asMetacelloAttributeList;
                versionString: aString;
                yourself)! !

!MetacelloSymbolicVersionNotDefinedError methodsFor: 'printing' stamp: ''!
description
    "Return a textual description of the exception."

    ^ 'The symbolic version ' , self versionString printString , ' is EXPLICITLY not defined in ' , self project label
        , ' for the current platform (i.e., symbolic version defined as #notDefined).'! !

!MetacelloSymbolicVersionSpec methodsFor: 'accessing' stamp: ''!
versionString: anObject
	versionString := anObject! !

!MetacelloSymbolicVersionSpec methodsFor: 'accessing' stamp: ''!
versionString
	^ versionString! !

!MetacelloTestsGoferCleanup methodsFor: 'cleaning' stamp: ''!
cleanupProtocols: aWorkingCopy
	"Not needed - for faster test running"! !

!MetacelloTestsGoferUnload methodsFor: 'running' stamp: ''!
execute
	self workingCopies 
		do: [ :copy | self unload: copy ].
	self model load.
	self gofer metacelloCleanup.
	self workingCopies 
		do: [ :copy | self unregister: copy ]! !

!MetacelloTestsGoferUnload methodsFor: 'unloading' stamp: ''!
unloadClasses: aWorkingCopy
	"skip this so that tests run faster"! !

!MetacelloTestsMCPackage methodsFor: '*metacello-testscommonmc' stamp: ''!
species
	^ MCPackage! !

!MetacelloTestsMCPackage methodsFor: '*metacello-testscommonmc' stamp: ''!
packageSet
	"Aiming for speeding up the running of the tests"

	^ MetacelloTestsPackageSet named: name! !

!MetacelloTestsMCPackage methodsFor: '*metacello-testscommonmc' stamp: ''!
packageInfo
	"Aiming for speeding up the running of the tests"

	^ MetacelloTestsPackageSet named: name! !

!MetacelloTestsPackageSet commentStamp: ''!
This class is used to speed up Metacello tests.
!
!MetacelloTestsPackageSet methodsFor: 'listing' stamp: ''!
extensionMethods
	"Test packages don't extend classes and skipping this operation is a significant performance gain for running tests"
	^ #()! !

!MetacelloTestsPackageSet methodsFor: 'listing' stamp: ''!
overriddenMethods
	"Test packages don't override methods and skipping this operation is a significant performance gain for running tests"
	^ #()! !

!MetacelloToolBox commentStamp: ''!
MetacelloToolbox implements a toolbox API for Metacello.

The toolbox methods on the class-side implement scripts for a number of commonly performed Metacello development tasks. The methods should be used in development scripts or GUI tools so that a common implementation is preserved across the toolset.!
!MetacelloToolBox methodsFor: 'testing' stamp: ''!
hasMethodForSymbolicVersion: versionSymbol

	^(self constructor extractSymbolicVersionPragmas at: versionSymbol ifAbsent: [ ^ false ]) size > 0! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
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: ''!
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: ''!
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: (MetacelloPlatform current selectorForPragma: pragma);
        category: (project configuration class whichCategoryIncludesSelector: (MetacelloPlatform current selectorForPragma: pragma));
        versionString: versionSymbol;
        yourself.
    (constructor extractSymbolicVersionSpecsFor: versionSymbol)
        do: [ :symbolicVersionSpec | 
            (aBlock value: symbolicVersionSpec)
                ifTrue: [ self methodSpec addMethodSection: symbolicVersionSpec attributes versionString: symbolicVersionSpec versionString ] ]! !

!MetacelloToolBox methodsFor: 'private' stamp: ''!
configurationNameFrom: baseName	
	^self class configurationNameFrom: baseName! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
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: ''!
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: ''!
commitBaselineOfMethod
  | skipValidation |
  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: ''!
updateVersionMethodForVersion: inputVersionStringOrSymbol versionSpecsDo: aBlock
	^ self
		updateVersionMethodForVersion: inputVersionStringOrSymbol
		updateProjects: true
		updatePackages: true
		versionSpecsDo: aBlock! !

!MetacelloToolBox methodsFor: 'spec creation' stamp: ''!
classicCreateProjectReferenceSpec: projectBaseName
  | configurationName projectReferenceProject versionString |
  configurationName := self configurationNameFrom: projectBaseName.
  projectReferenceProject := (MetacelloPlatform current
    globalNamed: configurationName asSymbol
    ifAbsent: [ 
      self
        error:
          'The project with 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: ''!
createVersion: versionString
	| version  |
	[ version := project version: versionString ]
		on: MetacelloVersionDoesNotExistError
		do: [ :ex | 
			| versionSpec |
			versionSpec := self createVersionSpec: versionString.
			version := versionSpec createVersion.
			project map == nil
				ifTrue: [ project map: Dictionary new ].
			project map at: versionString put: version ].
	^version! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
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: ''!
symbolicVersionMethod: versionSymbol
	(self hasMethodForSymbolicVersion: versionSymbol)
		ifTrue: [ self modifySymbolicVersionMethodFor: versionSymbol ]
		ifFalse: [ 
			self
				createSymbolicVersionMethod: versionSymbol asString , ':'
				inCategory: 'symbolic versions'
				forVersion: versionSymbol ].! !

!MetacelloToolBox methodsFor: 'accessing' stamp: ''!
constructor

	| constructor |
	constructor := MetacelloToolBoxConstructor new.
	constructor configuration: project configuration class new.
	^constructor! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
createBaselineOfMethod: selector inCategory: category
  methodSpec := MetacelloBaselineOfMethodSpec new
    project: project;
    selector: selector;
    category: category;
    yourself! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
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: ''!
modifySymbolicVersionMethodFor: versionSymbol

	^self modifySymbolicVersionMethodFor: versionSymbol symbolicVersionSpecsDo: [:symbolicVersionSpec | true ].! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
updateVersionMethodForVersion: inputVersionStringOrSymbol projectAttributes: projectAttributes updateProjects: updateProjects updatePackages: updatePackages versionSpecsDo: aBlock
    | constructor updatedSpecs fullVersionSpec version coll pragma imports blessing 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: (MetacelloPlatform current selectorForPragma: pragma);
        category: (project configuration class whichCategoryIncludesSelector: (MetacelloPlatform current selectorForPragma:  pragma));
        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: ''!
commitConfiguration: commitComment! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
addBaselineOfSection: sectionAttributeOrPath 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
    addBaselineOfSection: sectionAttributeOrPath
    requiredProjects: projectList
    packages: packageList
    dependencies: dependecies
    includes: #()
    files: #()
    repositories: #()
    preLoadDoIts: #()
    postLoadDoIts: #()
    supplyingAnswers: #()
    groups: groups
    versionSpecsDo: aBlock! !

!MetacelloToolBox methodsFor: 'private' stamp: ''!
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: 'api-configuration' stamp: ''!
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: 'private' stamp: ''!
ensureMetacello
	"noop for now"! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
imports: importList

	self methodSpec imports: importList! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
commitMethod
	| skipValidation |
	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: ''!
modifyVersionMethodForVersion: inputVersionStringOrSymbol
	^ self modifyVersionMethodForVersion: inputVersionStringOrSymbol versionSpecsDo: [ :attribute :versionSpec | true ]! !

!MetacelloToolBox methodsFor: 'spec creation' stamp: ''!
createProjectReferenceSpec: projectBaseName
  | projectSpec |
  projectSpec := (Metacello image
    project: projectBaseName;
    list)
    detect: [ :each | true ]
    ifNone: [ ^ self classicCreateProjectReferenceSpec: projectBaseName ].
  ^ project projectReferenceSpec
    name: projectBaseName;
    projectReference: projectSpec;
    yourself! !

!MetacelloToolBox methodsFor: 'spec creation' stamp: ''!
createVersionSpec: versionString
	| versionSpec |
	versionSpec := project versionSpec.
	versionSpec versionString: versionString.
	^ versionSpec! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
createVersionMethod: selector inCategory: category forVersion: versionString
	
	methodSpec := (MetacelloVersionMethodSpec new)
		project: project;
		selector: selector;
		category: category;
		versionString: versionString;
		yourself.! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
modifyBaselineOf
  | baselineClass constructor pragma baseline |
  baselineClass := project configuration class.
  baseline := baselineClass new.
  constructor := MetacelloToolBoxBaselineConstructor new
    configuration: project configuration class new;
    yourself.
  pragma := constructor extractBaselinePragmaFor: baselineClass.
  constructor extractMethodSectionsForClass: baselineClass.
  methodSpec := MetacelloBaselineOfMethodSpec new
    project: project;
    selector: (MetacelloPlatform current selectorForPragma: pragma);
    category: (baselineClass whichCategoryIncludesSelector: (MetacelloPlatform current selectorForPragma: pragma));
    yourself.
  constructor methodSections
    do: [ :methodSection | self methodSpec methodSections add: methodSection ]! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
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: 'accessing' stamp: ''!
project: aMetacelloProject

	project := aMetacelloProject! !

!MetacelloToolBox methodsFor: 'private' stamp: ''!
updateVersionSpec: versionSpec fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages visited: visitedSpecs updated: updatedSpecs
    versionSpec
        specListProjectDo: [ :spec | 
            (updateProjects and: [ (visitedSpecs includes: spec name) not ])
                ifTrue: [ 
                    | fullProjectSpec |
                    fullProjectSpec := (fullVersionSpec packageNamed: spec name) projectReference.
                    (fullProjectSpec versionString ~~ nil
                        and: [ fullProjectSpec versionString ~~ #'stable' and: [ fullProjectSpec projectClass ~~ nil ] ])
                        ifTrue: [ 
                            | cv |
                            cv := fullProjectSpec projectClassProject currentVersion.
                            cv ~~ nil
                                ifTrue: [ 
                                    cv versionString ~= fullProjectSpec versionString
                                        ifTrue: [ 
                                            spec projectReference versionString: cv versionString.
                                            updatedSpecs add: spec name ] ]
                                ifFalse: [ 
                                    "set to an empty string as a place holder, since we know we should have a version, but we are unable to figure out the version"
                                    spec projectReference versionString: ''.
                                    updatedSpecs add: spec name ] ] ] ]
        packageDo: [ :spec | 
            (updatePackages and: [ (visitedSpecs includes: spec name) not ])
                ifTrue: [ 
                    spec getFile ~~ nil
                        ifTrue: [ 
                            | viName |
                            spec file = ''
                                ifTrue: [ spec file: spec name ].
                            (viName := spec workingCopyNameFor: spec loader) ~~ nil
                                ifTrue: [ 
                                    viName ~= spec file
                                        ifTrue: [ 
                                            spec file: viName.
                                            updatedSpecs add: spec name ].
                                    visitedSpecs add: spec name ] ] ] ]
        groupDo: [ :ignored |  ]! !

!MetacelloToolBox methodsFor: 'spec creation' stamp: ''!
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"
      MetacelloPlatform current registerPackageNamed: configurationName ].
  ^ (MetacelloPlatform current globalNamed: configurationName asSymbol) project! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
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: ''!
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"
      MetacelloPlatform current registerPackageNamed: configurationName ].
  project := (MetacelloPlatform current globalNamed: configurationName asSymbol)
    project! !

!MetacelloToolBox methodsFor: 'accessing' stamp: ''!
methodSpec

	^methodSpec! !

!MetacelloToolBox methodsFor: 'validation' stamp: ''!
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: 'spec creation' stamp: ''!
createGroupSpec: baseName
	^ (self project groupSpec)
		name: baseName;
		yourself! !

!MetacelloToolBox methodsFor: 'private' stamp: ''!
buildMapFrom: mapList for: packageList
	| map |
	map := Dictionary new.
	mapList
		do: [ :assoc | 
			| pkgName pkgSpec |
			pkgName := assoc key.
			(packageList includes: pkgName)
				ifFalse: [ self error: 'package ' , pkgName printString , ' not found in packages.' ].
			map at: pkgName put: assoc value ].
	^ map! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
abortMethod

	project := project configuration class project.	"recalculate project"
	methodSpec := nil! !

!MetacelloToolBox methodsFor: 'spec creation' stamp: ''!
createPackageSpec: baseName
	^ (project packageSpec)
		name: baseName;
		yourself! !

!MetacelloToolBox methodsFor: 'private' stamp: ''!
baselineNameFrom: baseName
  ^ self class baselineNameFrom: baseName! !

!MetacelloToolBox methodsFor: 'validation' stamp: ''!
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: 'private' stamp: ''!
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 occurrence"
                                    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 occurrence"
                                    packageSpecsToDelete add: spec.
                                    fileSpecified remove: spec name ] ] ]
                groupDo: [ :spec | spec updateForSpawnMethod: spec ].
            packageSpecsToDelete do: [ :spec | versionSpec deleteSpec: spec ].
            activeSection
                ifTrue: [ 
                    self
                        updateVersionSpec: versionSpec
                        fullVersionSpec: fullVersionSpec
                        updateProjects: updateProjects
                        updatePackages: updatePackages
                        visited: visitedSpecs
                        updated: updatedSpecs ]
                ifFalse: [ 
                    self
                        clearVersionSpec: versionSpec
                        fullVersionSpec: fullVersionSpec
                        updateProjects: updateProjects
                        updatePackages: updatePackages ] ]! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
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: ''!
addBaselineOfSection: sectionAttributeOrPath requiredProjects: projectList packages: packageList dependencies: dependecies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: groups versionSpecsDo: aBlock
  "
		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.
  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: 'accessing' stamp: ''!
project

	^project! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
modifyVersionMethodForVersion: inputVersionStringOrSymbol versionSpecsDo: aBlock
	^ self
		updateVersionMethodForVersion: inputVersionStringOrSymbol
		updateProjects: false
		updatePackages: false
		versionSpecsDo: aBlock! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
baselineNamed: baseName
  | baselineName |
  "Check if the class does not exist"
  baselineName := self baselineNameFrom: baseName.
  (Smalltalk includesKey: baselineName asSymbol)
    ifFalse: [ 
      "Create the configuration class"
      self ensureMetacello.

		self class classInstaller make: [ :aBuilder | 
			aBuilder 
				name: baselineName asSymbol;
				superclass: BaselineOf;
				package: baselineName].

      MetacelloPlatform current registerPackageNamed: baselineName.
      (MetacelloPlatform current globalNamed: baselineName asSymbol)
        compile: 'baseline: spec <baseline>'
        classified: 'baseline'	"a bit of a hack here to create an initial null basline method" ].
  project := (MetacelloPlatform current globalNamed: baselineName asSymbol)
    project! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
methodSectionsFrom: inputVersionStringOrSymbol do: methodSectionBlock
  | constructor version fromVersionString |
  constructor := self constructor.
  version := project version: inputVersionStringOrSymbol.
  fromVersionString := version versionString.	"resolve symbolic versions"
  constructor extractMethodSectionsFor: fromVersionString.
  constructor methodSectionsDo: methodSectionBlock! !

!MetacelloToolBox methodsFor: 'api-configuration' stamp: ''!
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: ''!
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: ''!
addBaselineOfSection: sectionAttributeOrPath 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
    addBaselineOfSection: sectionAttributeOrPath
    requiredProjects: projectList
    packages: packageList
    dependencies: dependecies
    includes: #()
    files: #()
    repositories: repositories
    preLoadDoIts: #()
    postLoadDoIts: #()
    supplyingAnswers: #()
    groups: groups
    versionSpecsDo: aBlock! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
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."

	<apiDocumentation>
	| 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: 'development support' stamp: ''!
compareVersionsIn: aConfigurationClass
	"Compare the current #stable version to current #development version"

	<apiDocumentation>
	| 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: 'scripts' stamp: ''!
saveConfigurationPackageFor: configurationBasename description: commitMessage
	"Save mcz file that contains the configuration to it's repository."
	
	<apiDocumentation>
	| 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: 'validation' stamp: ''!
validateConfiguration: configurationClass debug: debugList recurse: aBool
	"Check the configuration for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). "

	<apiDocumentation>
	^ MetacelloMCVersionValidator validateConfiguration: configurationClass debug: debugList recurse: aBool! !

!MetacelloToolBox class methodsFor: 'validation' stamp: ''!
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). "

	<apiDocumentation>
	^ MetacelloMCVersionValidator
		validateProject: aMetacelloProject
		version: versionString
		debug: debugList
		recurse: aBool! !

!MetacelloToolBox class methodsFor: 'utilities' stamp: ''!
configurationNameFrom: baseName
    "Return the fully-qualified configuration class name."

    <apiDocumentation>
    ^ MetacelloScriptEngine configurationNameFrom: baseName! !

!MetacelloToolBox class methodsFor: 'development support' stamp: ''!
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
	"

	<apiDocumentation>
	| 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: ''!
saveModifiedPackagesAndConfigurationIn: aConfigurationClass description: commitMessage
	"Save modified mcz files, update and then save the configuration."

	<apiDocumentation>
	| 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: 'help' stamp: ''!
defaultTopic: pageSelector for: aConfigurationClass
	| stream helpTopicClass |
	(helpTopicClass := self helpTopicClass) ifNil: [^self error: 'Help system not installed'].
	stream := WriteStream on: String new.
	pageSelector == #helpInstallation
		ifTrue: [ 
			stream
				nextPutAll: 'To install this configuration, execute the following expression in a workspace:'; cr; tab.
			(aConfigurationClass project hasVersion: #stable)
				ifTrue: [ stream nextPutAll: '(', aConfigurationClass name asString, ' project version: #stable) load.' ]
				ifFalse: [ 
					(aConfigurationClass respondsTo: #load)
						ifTrue: [ stream nextPutAll: aConfigurationClass name asString , ' load.' ]
						ifFalse: [ stream nextPutAll: aConfigurationClass name asString, ' project latestVersion load.' ]].
			^ helpTopicClass perform: #title:contents: withArguments: { 'Installing'.  stream contents} ].
	pageSelector == #helpIntro
		ifTrue: [ 
			stream
				nextPutAll: 'I am a Metacello configuration for the ', (MetacelloToolBox baseNameOfConfiguration: aConfigurationClass), ' project.'.
			^ helpTopicClass perform: #title:contents: withArguments: { 'Intro' . stream contents} ].
	pageSelector == #helpGettingStarted
		ifTrue: [ 
			stream
				nextPutAll: 'I guess you''re on your own:).'.
			^ helpTopicClass perform: #title:contents: withArguments: { 'Getting Started' .stream contents} ].! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
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."

	<apiDocumentation>
	| 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: 'development support' stamp: ''!
releaseDevelopmentVersionIn: aConfigurationClass description: commitMessage
	"Release #development version: set version blessing to #release, update the #development and #stable symbolic version methods and save the configuration."

	<apiDocumentation>
	| 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: ''!
createNewBaselineVersionIn: aConfigurationClass description: creationMessage versionSpecsDo: versionSpecBlock
	"Create a new baseline version based upon #stable version's baseline. Evaluate <versionSpecBlock> for each section.
	 A new baseline should be created if new packages or projects have been added or package dependencies have changed."

	<apiDocumentation>
	| currentVersion existingBaselineVersionString baselineVersionNumber |
	currentVersion := aConfigurationClass project version: #stable.
	existingBaselineVersionString := currentVersion importedVersions first.
	baselineVersionNumber := existingBaselineVersionString asMetacelloVersionNumber incrementMinorVersionNumber.
	self
		createBaseline: baselineVersionNumber versionString
		for: aConfigurationClass name asString
		from: existingBaselineVersionString
		description: creationMessage
		versionSpecsDo: versionSpecBlock! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
createBaselineOf: baselineBasename requiredProjects: projectList packages: packageList repositories: repositories dependencies: dependencies groups: groups
  "Create a new baseline in a BaselinOf 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
	"

  <apiDocumentation>
  | toolbox |
  (toolbox := self baselineNamed: baselineBasename)
    createBaselineOfMethod: 'baseline:' inCategory: 'baseline';
    addBaselineOfSection: #'common'
      requiredProjects: projectList
      packages: packageList
      repositories: repositories
      dependencies: dependencies
      groups: groups
      versionSpecsDo: [ :versionSpec |  ];
    commitBaselineOfMethod.
  ^ toolbox! !

!MetacelloToolBox class methodsFor: 'utilities' stamp: ''!
checkForCriticalValidationIssues: configurationBasename
	"Validate the named configuration and filter out all non-critical issues."
	<apiDocumentation>
	^ (MetacelloMCVersionValidator
		validateConfiguration: (Smalltalk at: (self configurationNameFrom: configurationBasename) asSymbol))
		select: [ :issue | issue isCritical ]! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
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."

	<apiDocumentation>
	| toolbox |
	(toolbox := self configurationNamed: configurationBasename)
		createVersionMethod: 'version' , (self stripVersionStringForSelector: developmentVersionString) , ':'
			inCategory: 'versions'
			forVersion: developmentVersionString;
		addSectionsFrom: existingDevelopmentVersionString
			forBaseline: false
			updateProjects: true
			updatePackages: true
			versionSpecsDo: [ :attribute :versionSpec | 
				attribute == #common
					ifTrue: [ 
						"update the author, blessing, description and timeStamp"
						versionSpec
							author: MetacelloPlatform current authorName;
							description: aString;
							blessing: #development;
							timestamp: MetacelloPlatform current timestamp ].
				true ];
		commitMethod.
	toolbox
		symbolicVersionMethod: #development;
		addSymbolicSection: #common version: developmentVersionString;
		commitMethod.
	^ toolbox! !

!MetacelloToolBox class methodsFor: 'development support' stamp: ''!
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."

	<apiDocumentation>
	| currentVersion existingBaselineVersionString baselineVersionNumber |
	currentVersion := aConfigurationClass project version: #stable.
	existingBaselineVersionString := currentVersion importedVersions first.
	baselineVersionNumber := existingBaselineVersionString asMetacelloVersionNumber incrementMinorVersionNumber.
	self
		createBaseline: baselineVersionNumber versionString
		for: aConfigurationClass name asString
		from: existingBaselineVersionString
		description: creationMessage! !

!MetacelloToolBox class methodsFor: 'validation' stamp: ''!
descriptionForValidationReasonCode: reasonCode
	"Description of validation reasonCode"

	<apiDocumentation>
	^MetacelloMCVersionValidator descriptionForReasonCode: reasonCode! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
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
	"

	<apiDocumentation>
	| 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: 'utilities' stamp: ''!
configurationClasses
    "Return a set of the Metacello configuration classes that have been loaded into the image."

    <apiDocumentation>
    ^ MetacelloProjectRegistration configurationClasses! !

!MetacelloToolBox class methodsFor: 'help' stamp: ''!
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: 'validation' stamp: ''!
copyConfiguration: aConfigurationClass to: metacelloRepositoryString
	"Copy the current configuration mcz file to the given repository (i.e., http: //... or directory://, etc.)"

	<apiDocumentation>
	| project |
	project := aConfigurationClass project.
	project projectPackage
		copySpecTo:
			((project repositorySpec)
				description: metacelloRepositoryString;
				yourself)! !

!MetacelloToolBox class methodsFor: 'utilities' stamp: ''!
baseNameOfConfiguration: aConfigurationClass
	"Return the baseName for the given configuration class."

	<apiDocumentation>
	^self baseNameOf: aConfigurationClass name asString! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
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."

	<apiDocumentation>
	| 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: 'development support' stamp: ''!
updateToLatestPackageVersionsIn: aConfigurationClass description: descriptionString
	"Update the #development version to match currently loaded mcz files."

	"self updateToLatestPackageVersions: '- fixed a bug'"

	<apiDocumentation>
	^self
		updateDevelopment: #development
		for: aConfigurationClass name asString
		updateProjects: false 
		description: descriptionString! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
createBranch: branchName for: configurationBasename description: commitMessage
	"Create a new branch for the project and save the configuration to it's repository."
	
	<apiDocumentation>
	| 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: 'help' stamp: ''!
helpTopicClass

	^self environment at: #HelpTopic ifAbsent: []! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
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."

	<apiDocumentation>
	| toolbox |
	toolbox := self
		createVersion: developmentVersionString
		for: configurationBasename
		from: existingDevelopmentVersionString
		description: aString.
	toolbox
		modifyVersionMethodForVersion: developmentVersionString;
		imports: imports;
		commitMethod.
	^ toolbox! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
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."

  <apiDocumentation>
  | 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 = MetacelloPlatform current defaultPackageCache ] ] ].
      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 := MetacelloPlatform current defaultPackageCache.
  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: 'private' stamp: ''!
stripVersionStringForSelector: versionString

	^((versionString copyWithout: $.) copyWithout: $-) 
		copyReplaceAll: 'baseline' with: ''! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
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."

	<apiDocumentation>
	| 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: 'validation' stamp: ''!
validateBaseline: baselineClass
  "Check the baseline for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). "

  <apiDocumentation>
  ^ self validateBaseline: baselineClass debug: #() recurse: false! !

!MetacelloToolBox class methodsFor: 'utilities' stamp: ''!
platformAttributes
	"Answer the list of platform attributes for the current platform"
	<apiDocumentation>
	^MetacelloPlatform current defaultPlatformAttributes! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
modifyVersion: sourceVersionString for: configurationBasename versionSpecsDo: aBlock
	"Modify the version specifications for the given version"

	<apiDocumentation>
	(self configurationNamed: configurationBasename)
		modifyVersionMethodForVersion: sourceVersionString versionSpecsDo: aBlock;
		commitMethod! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
createBaseline: baselineVersionString for: configurationBasename from: existingBaselineVersionString description: aString versionSpecsDo: versionSpecBlock
	"Create a new baseline version based on the specification in an existing baseline. Evaluate <versionSpecBlock> for each section."

	<apiDocumentation>
	| 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: 'development support' stamp: ''!
createNewDevelopmentVersionIn: aConfigurationClass description: creationMessage
	"Create a new development version using the #stable version as model."

	<apiDocumentation>
	| 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: 'scripts' stamp: ''!
modifyVersion: sourceVersionString for: configurationBasename projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock
	"Modify the project, package and/or group specifications for the given version"

	<apiDocumentation>
	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: 'instance creation' stamp: ''!
configurationNamed: baseName

	^self new 
		configurationNamed: baseName;
		yourself! !

!MetacelloToolBox class methodsFor: 'development support' stamp: ''!
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
	"

	<apiDocumentation>
	| 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: 'scripts' stamp: ''!
releaseEarlyAccessVersion: earlyAccessVersionString for: configurationBasename from: developmentVersionString
	"Update the #development and #earlyAccess symbolic versions."

	<apiDocumentation>
	| 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: ''!
updateDescription: developmentVersionString for: configurationBasename description: message
	"Update description"

	<apiDocumentation>
	^ (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: ''!
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
	"

	<apiDocumentation>
	| 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: 'validation' stamp: ''!
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). "

	<apiDocumentation>
	^ self validateProject: aMetacelloProject version: versionString debug: #() recurse: false! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
modifySymbolicVersion: symbolicVersionSymbol for: configurationBasename attribute: attribute to: versionString
	"Set the value of the symbolic version for the given attribute to the given version string"

	<apiDocumentation>
	| toolbox |
	(toolbox := self configurationNamed: configurationBasename)
		modifySymbolicVersionMethodFor: symbolicVersionSymbol;
		addSymbolicSection: attribute version: versionString;
		commitMethod.
	^ toolbox! !

!MetacelloToolBox class methodsFor: 'validation' stamp: ''!
validateConfiguration: configurationClass
	"Check the configuration for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). "

	<apiDocumentation>
	^ self validateConfiguration: configurationClass debug: #() recurse: false! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
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."

	<apiDocumentation>
	| 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: ''!
releaseVersion: developmentVersionString for: configurationBasename
	"Set the #common blessing to #release and set the #common #stable symbolic version to the given version."

	<apiDocumentation>
	^ self
		releaseVersion: developmentVersionString
		for: configurationBasename
		blessingAttribute: #common
		platformAttribute: #common! !

!MetacelloToolBox class methodsFor: 'utilities' stamp: ''!
baselineNameFrom: baseName
  "Return the fully-qualified baseline class name."

  <apiDocumentation>
  ^ MetacelloScriptEngine baselineNameFrom: baseName! !

!MetacelloToolBox class methodsFor: 'development support' stamp: ''!
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
	"

	<apiDocumentation>
	| currentVersion existingBaselineVersionString |
	currentVersion := aConfigurationClass project version: #development.
	existingBaselineVersionString := currentVersion importedVersions first.
	self
		modifyVersion: existingBaselineVersionString
		section: #common
		for: aConfigurationClass name asString
		repository: repositoryDescription
		requiredProjects: projectList
		packages: packageList
		dependencies: dependencies
		includes: includes
		files: files
		repositories: repositories
		preLoadDoIts: preLoadDoIts
		postLoadDoIts: postLoadDoIts
		supplyingAnswers: supplyingAnswers
		groups: groups! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
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
	"

    <apiDocumentation>
    | 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: ''!
stableVersion: stableVersionString for: configurationBasename platformAttribute: platformAttribute
	<apiDocumentation>
	"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: 'load validation' stamp: ''!
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."

	<apiDocumentation>
	| issues configurationClass toolbox cleanLoadAndTests stableVersion |
	configurationClass := self environment 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: 'development support' stamp: ''!
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: 'validation' stamp: ''!
validateBaseline: baselineClass debug: debugList recurse: aBool
  "Check the baseline for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). "

  <apiDocumentation>
  ^ MetacelloMCVersionValidator
    validateBaseline: baselineClass
    debug: debugList
    recurse: aBool! !

!MetacelloToolBox class methodsFor: 'instance creation' stamp: ''!
baselineNamed: baseName
  ^ self new
    baselineNamed: baseName;
    yourself! !

!MetacelloToolBox class methodsFor: 'private' stamp: ''!
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: 'load validation' stamp: ''!
validatePlatformLoad: platformAttribute for: configurationBasename
	"Validate, Load, and run tests for all versions of the given configuration. Return list of issues."

	<apiDocumentation>
	| issues configurationClass toolbox cleanDevelopmentLoads cleanLoadAndTests stableVersion |
	configurationClass := self environment 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: 'utilities' stamp: ''!
baseNameOf: configurationClassName
  "Return the baseName for the given configuration class name."

  <apiDocumentation>
  ^ (configurationClassName beginsWith: 'ConfigurationOf')
    ifTrue: [ 
      configurationClassName
        copyFrom: 'ConfigurationOf' size + 1
        to: configurationClassName size ]
    ifFalse: [ configurationClassName ]! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
createBaseline: baselineVersionString for: configurationBasename from: existingBaselineVersionString description: aString
	"Create a new baseline version based on the specification in an existing baseline"

	<apiDocumentation>
	^ self
		createBaseline: baselineVersionString
		for: configurationBasename
		from: existingBaselineVersionString
		description: aString
		versionSpecsDo: [ :attribute :versionSpec | true ]! !

!MetacelloToolBox class methodsFor: 'scripts' stamp: ''!
releaseVersion: developmentVersionString for: configurationBasename blessingAttribute: attribute platformAttribute: platformAttribute
	<apiDocumentation>
	"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: 'tool support' stamp: ''!
compiledMethodForVersion: aMetacelloVersion

	| toolbox pragma |
	toolbox := MetacelloToolBox new project: aMetacelloVersion project.
	pragma := (toolbox constructor extractAllVersionPragmas at: aMetacelloVersion versionString ifAbsent: [ ^ nil ]) first.
	^pragma method! !

!MetacelloToolBoxBaselineConstructor methodsFor: 'private' stamp: ''!
evaluateBaselineMethodSection: methodSection
  | versionSpec |
  versionSpec := self project versionSpec.
  methodSection versionSpec: versionSpec.
  currentSection := methodSection.
  self with: versionSpec during: methodSection block.
  methodSection methodSections
    do: [ :ms | self evaluateBaselineMethodSection: ms ]! !

!MetacelloToolBoxBaselineConstructor methodsFor: 'pragma extraction' stamp: ''!
extractBaselinePragmaFor: aClass
    | pragmas |
    pragmas := Pragma allNamed: #'baseline' in: aClass.
    pragmas isEmpty
        ifTrue: [ ^ self error: 'No #baseline pragma found' ].
    ^ pragmas first! !

!MetacelloToolBoxBaselineConstructor methodsFor: 'extraction' stamp: ''!
extractMethodSectionsForClass: aBaselineClass
  | pragma |
  pragma := self extractBaselinePragmaFor: aBaselineClass.
  self evaluatePragma: pragma.
  self methodSections
    do: [ :methodSection | self evaluateBaselineMethodSection: methodSection ]! !

!MetacelloToolBoxBaselineConstructor methodsFor: 'extraction' stamp: ''!
extractMethodSectionsFor: aBaselineClass
  self shouldNotImplement! !

!MetacelloToolBoxConstructor methodsFor: 'enumeration' stamp: ''!
methodSectionsDo: aBlock

	self methodSection: self do: aBlock! !

!MetacelloToolBoxConstructor methodsFor: 'private' stamp: ''!
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: ''!
evaluateMethodSection: methodSection version: sourceVersionString
	| versionSpec |
	versionSpec := self project versionSpec.
	versionSpec versionString: sourceVersionString.
	methodSection versionSpec: versionSpec.
	currentSection := methodSection.
	self with: versionSpec during: methodSection block.
	methodSection methodSections do: [ :ms | self evaluateMethodSection: ms version: sourceVersionString ]! !

!MetacelloToolBoxConstructor methodsFor: 'extraction' stamp: ''!
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: 'api callbacks' stamp: ''!
setFor: attributeList version: aString
    "conditional symbolicVersion support"

    self methodSections
        add:
            (MetacelloSymbolicVersionSpec new
                attributes: attributeList asMetacelloAttributeList;
                versionString: aString;
                yourself)! !

!MetacelloToolBoxConstructor methodsFor: 'api callbacks' stamp: ''!
setFor: attributeList do: aBlock
    "conditional version support"

    | methodSection |
    methodSection := MetacelloVersionMethodSection new
        attributes: attributeList asMetacelloAttributeList;
        block: aBlock;
        yourself.
    currentSection ~~ nil
        ifTrue: [ currentSection addMethodSection: methodSection ]
        ifFalse: [ self methodSections add: methodSection ]! !

!MetacelloToolBoxConstructor methodsFor: 'private' stamp: ''!
methodSection: methodSection do: aBlock

	methodSection methodSections do: aBlock.
	methodSection methodSections do: [ :ms | self methodSection: ms do: aBlock ]! !

!MetacelloToolBoxConstructor methodsFor: 'enumeration' stamp: ''!
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: 'initialization' stamp: ''!
reset
	super reset.	"not needed, but included for completeness"
	methodSections := nil! !

!MetacelloToolBoxConstructor methodsFor: 'private' stamp: ''!
methodSections

	methodSections == nil ifTrue: [ methodSections := OrderedCollection new ].
	^methodSections! !

!MetacelloToolBoxConstructor methodsFor: 'accessing' stamp: ''!
methodSectionAttributes
    | attributes |
    attributes := Set new.
    self methodSectionsDo: [ :methodSection | attributes addAll: methodSection attributes ].
    ^ attributes! !

!MetacelloToolBoxConstructor methodsFor: 'extraction' stamp: ''!
extractSymbolicVersionSpecsFor: sourceVersionSymbol
	| coll 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! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson11Blessing
"   [ see method: #version11: ]
A version can be tagged with a blessing like #alpha, #beta, #release, #development or any 
other tag that you find useful. The blessing for version 1.1 is #development

	(MetacelloTutorialConfig project version: '1.1') blessing.

The default blessing is #release, so even though we didn't specify a blessing for version 
0.5, the blessing is set:

	(MetacelloTutorialConfig project version: '0.5') blessing.
	
For version 1.1, it is important to explicitly set the blessing, because it imports version
'1.0-baseline' whose blessing is #baseline:

	(MetacelloTutorialConfig project version: '1.0-baseline') blessing.

Blessings can be used as a filter. For example, you will notice that the result of the 
following expression is version 0.6, because #stableVersion answers the latest version whose 
blessing is _not_ #development, #broken, or #blessing: 

	MetacelloTutorialConfig project stableVersion.
	MetacelloTutorialConfig project stableVersion load.

The blessing of version 1.1 is #development. To find the latest #development version you 
would execute this expression:

	MetacelloTutorialConfig project latestVersion: #development.
	(MetacelloTutorialConfig project latestVersion: #development) load.

You can get the very last version independent of blessing by executing this expression:

	MetacelloTutorialConfig project bleedingEdge.
	MetacelloTutorialConfig project bleedingEdge load.
	
In general, the #development blessing should be used for any version that is unstable. Once a 
version has stabilized, a different blessing should be applied.

The following expression will load the latest version of all of the packages for the latest 
#baseline version:

	(MetacelloTutorialConfig project latestVersion: #baseline) load.

Since the latest #baseline version should reflect the most up-to-date project structure, executing
the previous expression should load the absolute bleeding edge of the project. 
"! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson10
"   [ see method: #baseline10: #version10: ]
In #baseline10: we've added two things: the 'Example-AddOnTests' package and a specification for 
groups. 

The 'Example-AddOnTests' package has been added to make the idea of needing to group packages a
little more appealing. The package requires 'Example-AddOn' and 'Example-Tests'.

With two Test packages it would be convenient to be able to load all of the tests with a simple
expression like the following:

  (MetacelloTutorialConfig project version: '1.0') load: { 'Tests'. }.

instead of having to explicitly list all of the test projects like this:

  (MetacelloTutorialConfig project version: '1.0') 
	load: { 'Example-Tests'. 'Example-AddOnTests'. }.

This becomes especially useful if over time the project evolves to have more component and test 
packages.

The 'default' group is special in that when a 'default' group is defined, the #load method loads
the members of the 'default' group instead of loading all of the packages:

  (MetacelloTutorialConfig project version: '1.0') load.

If you want to load all of the packages in a project, then the pseudo group 'ALL' may be used as
follows:

  (MetacelloTutorialConfig project version: '1.0') load: 'ALL'.

"! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version03: spec 
	<version: '0.3'>
	
	spec for: #common do: [
		spec 
			package: 'Example-Core' with: [
				spec 
					file: 'Example-Core-anon.10';
					repository: 'http://www.example.com/Example' ];
			package: 'Example-Tests' with: [
				spec 
					file: 'Example-Tests-anon.3';
					repository: 'http://www.example.com/Example' ]].! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version05: spec 
	<version: '0.5'>
	
	spec for: #common do: [
		spec repository: 'http://www.example.com/Example'.
		spec 
			package: 'Example-Core' with: 'Example-Core-anon.11';
			package: 'Example-Tests' with: 'Example-Tests-anon.3';
			package: 'Example-AddOn' with: 'Example-AddOn-anon.1' ].! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version07: spec 
	<version: '0.7' imports: #('0.7-baseline')>
	
	spec for: #common do: [
		spec 
			package: 'Example-Core' with: 'Example-Core-anon.12';
			package: 'Example-Tests' with: 'Example-Tests-anon.3';
			package: 'Example-AddOn' with: 'Example-AddOn-anon.1' ].! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version10: spec 
	<version: '1.0' imports: #('1.0-baseline')>
	
	spec for: #common do: [
		spec 
			package: 'Example-Core' with: 'Example-Core-anon.14';
			package: 'Example-Tests' with: 'Example-Tests-anon.3';
			package: 'Example-AddOn' with: 'Example-AddOn-anon.1';
			package: 'Example-AddOnTests' with: 'Example-AddOnTests-anon.1' ].! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version13: spec 
	<version: '1.3' imports: #('1.3-baseline')>
	
	spec for: #common do: [
		spec blessing: #development.
		spec description: 'Add in doits for Example-Core'.
		spec author: 'dkh'.
		spec timestamp: '10/13/2009 14:27'.
		spec 
			package: 'Example-Core' with: 'Example-Core-anon.17';
			package: 'Example-Tests' with: 'Example-Tests-anon.6';
			package: 'Example-AddOn' with: 'Example-AddOn-anon.1';
			package: 'Example-AddOnTests' with: 'Example-AddOnTests-anon.1' ].
	spec for: #gemstone do: [
		spec package: 'Example-Platform' with: 'Example-Platform.gemstone-dkh.4'.].
	spec for: #pharo do: [
		spec package: 'Example-Platform' with: 'Example-Platform.pharo-dkh.7'.].
	spec for: #squeak do: [
		spec package: 'Example-Platform' with: 'Example-Platform.squeak-dkh.3'.].! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson03
"   [ see method: #version03: ]
For version 0.3, we've updated the package version to 'Example-Core-anon.10' and added an additional 
package 'Example-Tests-anon.3', which can be confirmed by printing the following expression:

  (MetacelloTutorialConfig project version: '0.3') spec

As is often the case, the two packages share the same repository, so specifying a repository with
each package is redundant.

"! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson12DoIts
"  [ see methods: #version12: #preloadForCore #postloadForCore:package: ]
Occassionally, you find that you need to perform an expression either before a package is loaded, or
after a package is loaded. To do that in Metacello, you can define a preLoadDoIt selector and a 
postLoadDoIt selector:

	(MetacelloTutorialConfig project version: '1.2') spec.

If you open a Transcript and execute the following expression, you will see that the pre load and
post load methods were executed:

	(MetacelloTutorialConfig project version: '1.2') load.

The pre/post load methods may take 0, 1 or 2 args. The loader is the first optional argument and the 
loaded packageSpec is the second optional argument.
"! !

!MetacelloTutorialConfig methodsFor: 'baselines' stamp: ''!
baseline07: spec 
	<version: '0.7-baseline'>
	
	spec for: #common do: [
		spec blessing: #baseline.
		spec repository: 'http://www.example.com/Example'.
		
		spec 
			package: 'Example-Core';
			package: 'Example-Tests' with: [ spec requires: 'Example-Core' ];
			package: 'Example-AddOn' with: [ spec requires: 'Example-Core' ] ].! !

!MetacelloTutorialConfig methodsFor: 'baselines' stamp: ''!
baseline10: spec 
	<version: '1.0-baseline'>
	
	spec for: #common do: [
		spec blessing: #baseline.
		spec repository: 'http://www.example.com/Example'.
		
		spec 
			package: 'Example-Core';
			package: 'Example-Tests' with: [ spec requires: 'Example-Core' ];
			package: 'Example-AddOn' with: [ spec requires: 'Example-Core' ];
			package: 'Example-AddOnTests' with: [ 
				spec requires: #('Example-AddOn' 'Example-Tests' ) ].
		spec 
			group: 'default' with: #('Example-Core' 'Example-AddOn' );
			group: 'Tests' with: #('Example-Tests' 'Example-AddOnTests' ) ].! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version01: spec 
	<version: '0.1'>
	
	spec for: #common do: [
		spec 
			package: 'Example-Core' with: [
				spec 
					file: 'Example-Core-anon.8';
					repository: 'http://www.example.com/Example' ] ].! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version12: spec 
	<version: '1.2' imports: #('1.0-baseline')>
	
	spec for: #common do: [
		spec blessing: #development.
		spec description: 'Add in doits for Example-Core'.
		spec author: 'dkh'.
		spec timestamp: '10/12/2009 09:26'.
		spec 
			package: 'Example-Core' with: [
				spec 
					file: 'Example-Core-anon.16';
					preLoadDoIt: #preloadForCore;
					postLoadDoIt: #postloadForCore:package: ];
			package: 'Example-Tests' with: 'Example-Tests-anon.5';
			package: 'Example-AddOn' with: 'Example-AddOn-anon.1';
			package: 'Example-AddOnTests' with: 'Example-AddOnTests-anon.1' ].! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson11Author
"  [ see method: #version11: ]
The author of a version can be defined:

	(MetacelloTutorialConfig project version: '1.1') author.

When using the OB-Metacello tools the author field is automatically updated to reflect the current
author as defined in the image.

"! !

!MetacelloTutorialConfig methodsFor: 'baselines' stamp: ''!
baseline13: spec 
	<version: '1.3-baseline'>
	
	spec for: #common do: [
		spec blessing: #baseline.
		spec repository: 'http://www.example.com/Example'.
		
		spec 
			package: 'Example-Core' with: [
				spec includes: #('Example-Platform' ) ];
			package: 'Example-Tests' with: [ spec requires: 'Example-Core' ];
			package: 'Example-AddOn' with: [ spec requires: 'Example-Core' ];
			package: 'Example-Platform' with: [ spec requires: 'Example-Core' ];
			package: 'Example-AddOnTests' with: [ 
				spec requires: #('Example-AddOn' 'Example-Tests' ) ].
		spec 
			group: 'default' with: #('Example-Core' 'Example-AddOn' );
			group: 'Tests' with: #('Example-Tests' 'Example-AddOnTests' ) ].
	spec for: #gemstone do: [
		spec package: 'Example-Platform' with: 'Example-Platform.gemstone'.].
	spec for: #pharo do: [
		spec package: 'Example-Platform' with: 'Example-Platform.pharo'.].
	spec for: #squeak do: [
		spec package: 'Example-Platform' with: 'Example-Platform.squeak'.].! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson11Descripton
"  [ see method: #version11: ]
A description can be defined for a version:

	(MetacelloTutorialConfig project version: '1.1') description.

"! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version11: spec 
	<version: '1.1' imports: #('1.0-baseline')>
	
	spec for: #common do: [
		spec blessing: #development.
		spec description: 'Example of a complete version specification'.
		spec author: 'dkh'.
		spec timestamp: '10/12/2009 09:26'.
		spec 
			package: 'Example-Core' with: 'Example-Core-anon.15';
			package: 'Example-Tests' with: 'Example-Tests-anon.4';
			package: 'Example-AddOn' with: 'Example-AddOn-anon.1';
			package: 'Example-AddOnTests' with: 'Example-AddOnTests-anon.1' ].! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson06
"   [ see method: #version06: ]
In version 0.6 we've added dependency information in the form of the #requires: directive.
Both 'Example-Tests' and  'Example-AddOn' require 'Example-Core' to be loaded before they are
loaded. Print the following expressions to see that the requires directives are being followed:

  (MetacelloTutorialConfig project version: '0.5') load: { 'Example-Tests'. }.
  (MetacelloTutorialConfig project version: '0.6') load: { 'Example-Tests'. }.
  (MetacelloTutorialConfig project version: '0.6') load: 'Example-AddOn'.
  (MetacelloTutorialConfig project version: '0.6') load: { 'Example-AddOn'. 'Example-Tests'. }.

With version 0.6 we are mixing structural information (required packages and repository) with the
dynamic file version info. It is expected that over time the file version info will change from
version to version while the structural information will remain relatively static.

"! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson11Timestamp
"  [ see method: #version11: ]
The timestamp of a version can be defined:

	(MetacelloTutorialConfig project version: '1.1') timestamp.

When using the OB-Metacello tools the timestamp field is automatically updated to reflect the current
DateAndTime that the update was made.

The timestamp is a String
"! !

!MetacelloTutorialConfig methodsFor: 'doits' stamp: ''!
preloadForCore

	MetacelloNotification signal: '#preloadForCore executed'.! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson11
"   [ see method: #version11: ]
In version 0.11 we've defined a couple of attributes that are expected to be used all of the time
in a version specification:

  #blessing:
  #description:
  #author:
  #timestamp:

The following lessons cover each of these attributes in more detail. 
"! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson08
"   [ see method: #version08: ]
In version 0.8 we've simply updated the package versions, which can be seen by comparing the 
results of loading version 0.7 and 0.8:

  (MetacelloTutorialConfig project version: '0.7') load.
  (MetacelloTutorialConfig project version: '0.8') load.

"! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson02
"  [ see method: #version02: ]
For version 0.2, we've simply updated the package version to 'Example-Core-anon.9', which 
can be confirmed by printing the following expression:

  (MetacelloTutorialConfig project version: '0.2') spec

"! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson13
"  [ see methods: #baseline13: #version13: ]
For version 1.3 we are adding a platform specific package 'Example-Platform'. 'Example-Platform'
requires 'Example-Core'. On GemStone, Pharo and Squeak, a branch of the 'Example-Platform' package 
will be loaded: 'Example-Platform.gemstone', 'Example-Platform.pharo', 'Example-Platform.squeak' 
respectively will be loaded. 

Consequently we've updated the baselines with #baseline13: to reflect the structural changes and
#version13: reflects the package versions.

The platform-specific versions and branches are defined in the #for:do: block for the corresponding
platforms: #gemstone, #pharo, #squeak (in both methods)

The result of the following expression will depend on the platform upon which you are running:

	(MetacelloTutorialConfig project version: '1.3') load.

Note that when you execute the following expresson to load 'Example-Core' that the correct
'Example-Platform' is loaded as well:

	(MetacelloTutorialConfig project version: '1.3') load: 'Example-Core'.

If you look at the specification for 'Example-Core' (in #baseline13:) you will note that 
'Example-Core' #includes: 'Example-Platform'. The #includes: directive means that the package 
'Example-Platform' should be loaded whenever the 'Example-Core' package is loaded.

Also note when you evaluate the following expression that the 'Example-Platform' package is loaded
before 'Example-Tests' as if 'Example-Tests' #requires: 'Example-Platform':

	(MetacelloTutorialConfig project version: '1.3') load: 'Example-Tests'.

When you use the #includes: directive, you are not only specifying that the listed packages should
be loaded when the parent package is loaded, but that the #included: packages should be loaded
_before_ any packages that require the parent package.


"! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson05
"   [ see method: #version05: ]
For version 0.5 we've added an additional package to the mix: 'Example-AddOn':

  (MetacelloTutorialConfig project version: '0.5') spec

Of course, the point of specifiying packages in Metacello is to be able to load versions. Here are
a couple examples of loading versions of the Tutorial. If you print the result of each expression, 
you will see the list of packages in load order (note that for the tutorial, we are using the 
MetacelloNullRecordingMCSpecLoader. This class records which packages are loaded and the order that they are loaded in among other things instead of actually loading the packages.

  (MetacelloTutorialConfig project version: '0.1') load.
  (MetacelloTutorialConfig project version: '0.4') load.
  (MetacelloTutorialConfig project version: '0.5') load.

You will note that in each case, all of the packages associated with the version are loaded, which 
is the default. 

If you want to load a subset of the packages in a project, you may list the packages that you
are interested in as an argument to the #load: method:

  (MetacelloTutorialConfig project version: '0.5') load: { 'Example-Tests'. 'Example-Core' }.

Note that the ordering of the packages is based on the order in which the packages are specified.

If you evaluate the following expression:

  (MetacelloTutorialConfig project version: '0.5') load: { 'Example-Tests'. }.

Only the package is 'Example-Tests'. By default the packages are ordered, but there are no implicit
dependencies.
"! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson04
"   [ see method: #version04: ]
The specification for version 0.4 is basically the same as version 0.3. Instead of listing a 
repository with each package we specify a project repository that applies to all packages.

Compare the printStrings for the specs for each version:

  (MetacelloTutorialConfig project version: '0.3') spec

  (MetacelloTutorialConfig project version: '0.4') spec
"! !

!MetacelloTutorialConfig methodsFor: 'accessing' stamp: ''!
project
	"NOTE: The MetacelloNullRecordingMCSpecLoader is being used to prevent packages
		from being loaded, see MetacelloConfigTemplate>>project for an example #project
		method that loads the package for real"

	^ project ifNil: [ | constructor loader |
		"Construct Metacello project"
		constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self.
		project := constructor project.
		loader := MetacelloNullRecordingMCSpecLoader new.
		loader evalDoits: true.
		project loader: loader.
		project ]! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version02: spec 
	<version: '0.2'>
	
	spec for: #common do: [
		spec 
			package: 'Example-Core' with: [
				spec 
					file: 'Example-Core-anon.9';
					repository: 'http://www.example.com/Example' ] ].! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson07
"   [ see method: #baseline07: and #version07: ]
For version 0.7, we are ceating a baseline version specification which is expected to be used
across several versions and the version specification which is restricted to the file versions.

In method #baseline07: the structure of version '0.7-baseline' is specified. The repository is 
listed, the packages are listed and the required packages are defined. We'll cover the #blessing:
in a later lesson.

In method #version07: the file versions are specified. You will note that the pragma as an #imports: component that specifies the list of versions that this version (version '0.7') is based upon. In 
fact, if you print the spec for '0.7-baseline' and then print the spec for '0.7' you can see that 
'0.7' is a composition of both versions:

   (MetacelloTutorialConfig project version: '0.7-baseline') spec.
   (MetacelloTutorialConfig project version: '0.7') spec.

Of course if you print the '0.6' spec and the '0.7' spec you can see that they specify exactly the
same information in a slightly different way:

  (MetacelloTutorialConfig project version: '0.6') spec.
  (MetacelloTutorialConfig project version: '0.7') spec.

and if you load each of the versions, you will see that they load the same packages, in the same 
order:

  (MetacelloTutorialConfig project version: '0.6') load.
  (MetacelloTutorialConfig project version: '0.7') load.

Finally, even though version '0.7-baseline' does not have explicit package versions, you may load
the version. When the 'real' loader encounters a package name (without version information) it will
attempt to load the latest version of the package from the repository. With the
MetacelloNullRecordingMCSpecLoader the packages names are 'loaded':

  (MetacelloTutorialConfig project version: '0.7-baseline') load.

Of course when a number of developers are working on a project it may be useful to load a
#baseline version so that you get the latest work from all of the project members. 

"! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version08: spec 
	<version: '0.8' imports: #('0.7-baseline')>
	
	spec for: #common do: [
		spec 
			package: 'Example-Core' with: 'Example-Core-anon.15';
			package: 'Example-Tests' with: 'Example-Tests-anon.6';
			package: 'Example-AddOn' with: 'Example-AddOn-anon.2' ].! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson01
" [ see metod: #version01: ]
Version 0.1 represents the simplest version specification possible. 

In the method #version01, version 0.1 is defined with a single package 'Example-Core-anon.8' 
that is loaded from the repository 'http://www.example.com/Example'.

Looking at this method you will notice a couple of things. 

Immediately after the method selector you see the pragma definition:

  <version: '0.1'>

The pragma indicates that the version created in this method should be associated with version 
'0.1' of the Tutorial project.

Looking a little closer you see that the argument to the method, <spec>, is the only variable in
the method and it is used as the receiver to four different messages:

  - #for:do:
  - #package:with:
  - #file: 
  - #repository:

With the evaluation of each block expression, a new object is pushed on a stack and the messages
within the block are sent to the object on the top of the stack.

So the method should be read as:

  Create version '0.1'. The #common code for version '0.1' (#for:do:) consists of a package named 
  'Example-Core' (#package:with:) whose file attribute is 'Example-Core-anon.8' (#file:) and whose 
  repository attribute is 'http://www.example.com/Example' (#repository:).

We can see the spec created for version 0.1 by printing the following expression:

  (MetacelloTutorialConfig project version: '0.1') spec

Note that in creating version '0.1' the #common attribute is extracted out.

In addition to #common, there are pre-defined attributes for each of the platforms upon which
Metacello runs (#pharo, #squeak, #gemstone and #squeakCommon). 

#squeakCommon is used for both #pharo and #squeak.
"! !

!MetacelloTutorialConfig methodsFor: 'lessons' stamp: ''!
lesson14
"
STILL UNDER CONSTRUCTION: Open your browsers on the class MetacelloProjectRefTutorial to continue the tutorial.
"! !

!MetacelloTutorialConfig methodsFor: 'doits' stamp: ''!
postloadForCore: loader package: packageSpec

	MetacelloNotification signal: ('#postloadForCore executed, Loader: ', loader printString, 
			' spec: ', packageSpec printString).! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version06: spec 
	<version: '0.6'>
	
	spec for: #common do: [
		spec repository: 'http://www.example.com/Example'.
		spec 
			package: 'Example-Core' with: 'Example-Core-anon.12';
			package: 'Example-Tests' with: [
				spec 
					file: 'Example-Tests-anon.3';
					requires: 'Example-Core' ];
			package: 'Example-AddOn' with: [
				spec 
					file: 'Example-AddOn-anon.1';
					requires: 'Example-Core' ]].! !

!MetacelloTutorialConfig methodsFor: 'versions' stamp: ''!
version04: spec 
	<version: '0.4'>
	
	spec for: #common do: [
		spec repository: 'http://www.example.com/Example'.
		spec 
			package: 'Example-Core' with: 'Example-Core-anon.10';
			package: 'Example-Tests' with: 'Example-Tests-anon.3' ].! !

!MetacelloTutorialConfig class methodsFor: 'private' stamp: ''!
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]! !

!MetacelloTutorialConfig class methodsFor: 'private' stamp: ''!
ensureMetacello
	"Bootstrap Gofer (if necessary), bootstrap ConfigurationOfMetacello (using old Gofer API), then load the latest 
	version of Metacello itself."

	| env |
	env := self environment.
	env
		at: #MetacelloProject
		ifAbsent: [ env
				at: #Gofer
				ifAbsent:
					[ "Current version of Gofer from which to bootstrap - as of 1.0-beta.15"
					self
						bootstrapPackage: 'Gofer-lr.83'
						from: 'http://seaside.gemstone.com/ss/metacello' ].
			env
				at: #Gofer
				ifPresent: [ :goferClass | 
					| gofer |
					gofer := goferClass new
						url: 'http://seaside.gemstone.com/ss/metacello';
						yourself.
					[ gofer addPackage: 'ConfigurationOfMetacello' ]
						on: Warning
						do: [ :ex | ex resume ].
					gofer load ].
			"load 'default' group of Metacello"
			(env at: #ConfigurationOfMetacello) perform: #load ]! !

!MetacelloTutorialConfig class methodsFor: 'metacello tool support' stamp: ''!
isMetacelloConfig
	"Answer true and the Metacello tools will operate on you"
	
	^true! !

!MetacelloTutorialConfig class methodsFor: 'accessing' stamp: ''!
project

	^self new project! !

!MetacelloValidationCriticalWarning commentStamp: ''!
MetacelloValidationCriticalWarning indicates that there is a logical inconsistency that may not be intentional and that could cause incorrect loads!
!MetacelloValidationCriticalWarning methodsFor: 'testing' stamp: ''!
isCriticalWarning

	^true! !

!MetacelloValidationCriticalWarning methodsFor: 'accessing' stamp: ''!
label

	^'Critical Warning'! !

!MetacelloValidationError commentStamp: ''!
MetacelloValidationError indicates that errors are to be expected if an attempt to use the configuration/version is made!
!MetacelloValidationError methodsFor: 'testing' stamp: ''!
isError

	^true! !

!MetacelloValidationError methodsFor: 'accessing' stamp: ''!
label

	^'Error'! !

!MetacelloValidationFailure methodsFor: 'accessing' stamp: ''!
issues
	^ issues! !

!MetacelloValidationFailure methodsFor: 'accessing' stamp: ''!
issues: anObject
	issues := anObject! !

!MetacelloValidationFailure class methodsFor: 'instance creation' stamp: ''!
issues: anObject message: aString
    ^ self new
        issues: anObject;
        signal: aString! !

!MetacelloValidationIssue methodsFor: 'testing' stamp: ''!
isCriticalWarning

	^false! !

!MetacelloValidationIssue methodsFor: 'accessing' stamp: ''!
callSite: anObject
	callSite := anObject! !

!MetacelloValidationIssue methodsFor: 'accessing' stamp: ''!
callSite
	^ callSite! !

!MetacelloValidationIssue methodsFor: 'testing' stamp: ''!
isCritical

	^self isError or: [ self isCriticalWarning ]! !

!MetacelloValidationIssue methodsFor: 'testing' stamp: ''!
isWarning

	^false! !

!MetacelloValidationIssue methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream
		nextPutAll: self label;
		nextPut: $:;
		space;
		nextPutAll: self explanation.
	self reasonCode ~~ #none
		ifTrue: [ 
			aStream
				space;
				nextPut: ${;
				space;
				print: self reasonCode;
				space;
				nextPut: $} ].
	(self configurationClass ~~ nil or: [ self callSite ~~ nil ])
		ifTrue: [ 
			aStream
				space;
				nextPut: $[;
				space.
			self configurationClass ~~ nil
				ifTrue: [ 
					aStream
						print: self configurationClass name;
						space ].
			self callSite ~~ nil
				ifTrue: [ 
					aStream
						print: self callSite name;
						space ].
			aStream nextPut: $] ]! !

!MetacelloValidationIssue methodsFor: 'accessing' stamp: ''!
reasonCode: anObject
	reasonCode := anObject! !

!MetacelloValidationIssue methodsFor: 'accessing' stamp: ''!
explanation: aString
	explanation := aString! !

!MetacelloValidationIssue methodsFor: 'accessing' stamp: ''!
configurationClass
	^ configurationClass! !

!MetacelloValidationIssue methodsFor: 'accessing' stamp: ''!
configurationClass: aClass
	configurationClass := aClass! !

!MetacelloValidationIssue methodsFor: 'testing' stamp: ''!
isError

	^false! !

!MetacelloValidationIssue methodsFor: 'accessing' stamp: ''!
explanation
	^ explanation! !

!MetacelloValidationIssue methodsFor: 'accessing' stamp: ''!
reasonCode

	reasonCode == nil ifTrue: [ reasonCode := #none ].
	^ reasonCode! !

!MetacelloValidationIssue methodsFor: 'accessing' stamp: ''!
label

	^''! !

!MetacelloValidationIssue class methodsFor: 'instance creation' stamp: ''!
configurationClass: aClass reasonCode: aSymbol callSite: aCallSite explanation: aString

	^(self new)
		configurationClass: aClass;
		reasonCode: aSymbol;
		callSite: aCallSite;
		explanation: aString;
		yourself! !

!MetacelloValidationNotification methodsFor: 'accessing' stamp: ''!
issue: anObject
	issue := anObject! !

!MetacelloValidationNotification methodsFor: 'accessing' stamp: ''!
issue
	^ issue! !

!MetacelloValidationNotification methodsFor: 'signaling' stamp: ''!
signal: aMetacelloValidationIssue

	self issue: aMetacelloValidationIssue.
	^ self signal! !

!MetacelloValidationNotification class methodsFor: 'exceptioninstantiator' stamp: ''!
signal: aMetacelloValidationIssue

	^ self new signal: aMetacelloValidationIssue! !

!MetacelloValidationWarning commentStamp: ''!
MetacelloValidationWarning indicates that there is a logical inconsistency that is not likely to cause any functional problems!
!MetacelloValidationWarning methodsFor: 'testing' stamp: ''!
isWarning

	^true! !

!MetacelloValidationWarning methodsFor: 'accessing' stamp: ''!
label

	^'Warning'! !

!MetacelloValueHolderSpec methodsFor: 'accessing' stamp: ''!
value: anObject
	value := anObject! !

!MetacelloValueHolderSpec methodsFor: 'printing' stamp: ''!
configMethodOn: aStream indent: indent

	aStream tab: indent; nextPutAll: 'spec value: ', self value printString! !

!MetacelloValueHolderSpec methodsFor: 'private' stamp: ''!
setPostLoadDoItInMetacelloSpec: aMetacelloSpec

	aMetacelloSpec setPostLoadDoIt: self! !

!MetacelloValueHolderSpec methodsFor: 'private' stamp: ''!
setAuthorInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setAuthor: self! !

!MetacelloValueHolderSpec methodsFor: 'private' stamp: ''!
setPreLoadDoItInMetacelloSpec: aMetacelloSpec

	aMetacelloSpec setPreLoadDoIt: self! !

!MetacelloValueHolderSpec methodsFor: 'private' stamp: ''!
setDescriptionInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setDescription: self! !

!MetacelloValueHolderSpec methodsFor: 'merging' stamp: ''!
mergeMap

	| map |
	map := super mergeMap.
	map at: #value put: value.
	^map! !

!MetacelloValueHolderSpec methodsFor: 'querying' stamp: ''!
value
	^ value! !

!MetacelloValueHolderSpec methodsFor: 'construction' stamp: ''!
value: anObject constructor: aVersionConstructor
    aVersionConstructor valueForValueHolder: anObject! !

!MetacelloValueHolderSpec methodsFor: 'private' stamp: ''!
setTimestampInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setTimestamp: self! !

!MetacelloValueHolderSpec methodsFor: 'private' stamp: ''!
setBlessingInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setBlessing: self! !

!MetacelloValueHolderSpecTestCase methodsFor: 'tests' stamp: ''!
testValueHolderMergeSpec
	| valueHolderA valueHolderB valueHolder |
	valueHolderA := self valueHolderSpec
		value: 'an Object';
		yourself.
	valueHolderB := self valueHolderSpec
		value: 1.1;
		yourself.
	valueHolder := valueHolderA mergeSpec: valueHolderB.
	self assert: valueHolder value equals: 1.1! !

!MetacelloValueHolderSpecTestCase methodsFor: 'tests' stamp: ''!
testValueHolderSpec
	| valueHolder |
	valueHolder := self valueHolderSpec
		value: 'an Object';
		yourself.
	self assert: valueHolder value equals: 'an Object'! !

!MetacelloVersion methodsFor: 'comparing' stamp: ''!
< aMetacelloVersion

	aMetacelloVersion species = self species ifFalse: [ ^false ].
	^self versionNumber < aMetacelloVersion versionNumber! !

!MetacelloVersion methodsFor: 'comparing' stamp: ''!
= aMetacelloVersion

	aMetacelloVersion species = self species ifFalse: [ ^false ].
	^self versionNumber = aMetacelloVersion versionNumber! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
versionNumber

	^versionNumber! !

!MetacelloVersion methodsFor: 'private' stamp: ''!
computeVersionStatus
    ^ #'noStatus'! !

!MetacelloVersion methodsFor: 'comparing' stamp: ''!
hash

	^self versionNumber hash! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
packageNamed: aString

	^self packageNamed: aString ifAbsent: [ ^nil ].! !

!MetacelloVersion methodsFor: 'accessing' stamp: ''!
basicSpec
    ^ self spec! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
description
    ^ self basicSpec description value! !

!MetacelloVersion methodsFor: 'accessing' stamp: ''!
versionStatus

	versionStatus == nil ifTrue: [ versionStatus := self computeVersionStatus].
	^versionStatus! !

!MetacelloVersion methodsFor: 'comparing' stamp: ''!
~> aMetacelloVersion

	aMetacelloVersion species = self species ifFalse: [ ^false ].
	^self versionNumber ~> aMetacelloVersion versionNumber! !

!MetacelloVersion methodsFor: 'printing' stamp: ''!
printOn: aStream
    | label vs |
    (#(structural broken) includes: self blessing) not
        ifTrue: [ 
            (vs := self versionStatus) == #'somethingLoaded'
                ifTrue: [ aStream nextPutAll: '<>' ].
            vs == #'loadedMatchConstraints'
                ifTrue: [ aStream nextPutAll: '>=' ].
            vs == #'loadedToSpec'
                ifTrue: [ aStream nextPut: $~ ] ].
    self versionNumber printOn: aStream.
    self basicSpec ~~ nil
        ifTrue: [ 
            (label := self projectLabel) isEmpty
                ifFalse: [ aStream nextPutAll: ' [' , label , ']' ] ]! !

!MetacelloVersion methodsFor: 'accessing' stamp: ''!
versionNumber: aVersionNumber

	versionNumber := aVersionNumber! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
timestamp
    ^ self basicSpec timestamp value! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
projects
	"Answers the list of projects associated with this version"

	| projects |
	projects := OrderedCollection new.
	self spec projectDo: [:prj | projects add: prj projectReference ] packageDo: [:ignored | ] groupDo: [:ignored | ].
	^projects! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
versionString

	^self versionNumber versionString! !

!MetacelloVersion methodsFor: 'accessing' stamp: ''!
projectLabel
    ^ self basicSpec projectLabel! !

!MetacelloVersion methodsFor: 'accessing' stamp: ''!
spec

	^spec! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
packageNamed: aString ifAbsent: aBlock

	| pkg |
	(pkg := self spec packageNamed: aString ifAbsent: []) == nil
		ifTrue: [ ^aBlock value ].
	^pkg referencedSpec! !

!MetacelloVersion methodsFor: 'testing' stamp: ''!
isSomethingLoaded
	"at least one project or package has been loaded"
	
	^self spec isSomethingLoaded! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
loader

	^self spec loader! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
resolveToLoadableSpecs: nameList
	"Resolves names in namelist to the  list of packages and projects in the version that would be loaded. Projects are 
	not traversed during the transitive closure. The scope is that of the version itself.
	   If the spec is a package, answer a list including the package and the transitive closure on 
			its #requires: and #includes: fields.
	   If the spec is a project, answer the project.
	   If the spec is a group, answers the list of packages in the #includes: field of the group. 
			Groups in the #includes: field are expanded following the transitive closure on groups"

	^self spec resolveToLoadableSpecs: nameList! !

!MetacelloVersion methodsFor: 'actions' stamp: ''!
load

	^self subclassResponsibility! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
versionKey
    "version printString, without the versionStatus decorations, suitable for using as a unique key for the 
	 receiver in a dictionary"

    ^ String
        streamContents: [ :aStream | 
            | label |
            self versionNumber printOn: aStream.
            self basicSpec ~~ nil
                ifTrue: [ 
                    (label := self projectLabel) isEmpty
                        ifFalse: [ aStream nextPutAll: ' [' , label , ']' ] ] ]! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
blessing
    ^ self basicSpec blessing value! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
author

	^self spec author value! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
expandToLoadableSpecNames: nameList
	"Just like #resolveToLoadableSpecs:, but returns list of spec names instead of specs"
	
	^self spec expandToLoadableSpecNames: nameList! !

!MetacelloVersion methodsFor: 'testing' stamp: ''!
isLoadedMatchConstraints
	"all loaded projects and packages match constraints"
	
	^self spec isLoadedMatchConstraints! !

!MetacelloVersion methodsFor: 'accessing' stamp: ''!
importedVersions: aCollection

	importedVersions := aCollection! !

!MetacelloVersion methodsFor: 'testing' stamp: ''!
isAllLoadedToSpec
	"all projects and packages are loaded and match specification"
	
	^self spec isAllLoadedToSpec! !

!MetacelloVersion methodsFor: 'accessing' stamp: ''!
versionStatus: aSymbol

	versionStatus := aSymbol! !

!MetacelloVersion methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForGroupsFor: aStep
	<stSpotterOrder: 2>
	aStep listProcessor
		title: 'Groups';
		allCandidates: [ self groups ];
		itemName: [ :item | item name ];
		filter: StFilterSubstring;
		wantsToDisplayOnEmptyQuery: true! !

!MetacelloVersion methodsFor: 'actions' stamp: ''!
unload

	^self spec unload! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
project
    ^ self basicSpec project! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
versionNumberFrom: aString
    ^ self versionNumber class fromString: aString! !

!MetacelloVersion methodsFor: 'testing' stamp: ''!
name

	^self versionString! !

!MetacelloVersion methodsFor: 'testing' stamp: ''!
isLoadedToSpec
	"all loaded projects and packages match specifications"
	
	^self spec isLoadedToSpec! !

!MetacelloVersion methodsFor: 'accessing' stamp: ''!
spec: aMetacellVersionSpec

	spec := aMetacellVersionSpec! !

!MetacelloVersion methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForPackagesFor: aStep
	<stSpotterOrder: 3>
	aStep listProcessor
		title: 'Packages';
		allCandidates: [ self packages ];
		itemName: [ :item | item file ];
		filter: StFilterSubstring;
		wantsToDisplayOnEmptyQuery: true! !

!MetacelloVersion methodsFor: 'actions' stamp: ''!
load: required

	^self subclassResponsibility! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
groups
	"Answers the list of groups associated with this version"
	
	| groups |
	groups := OrderedCollection new.
	self spec projectDo: [:ignored | ] packageDo: [:ignored | ] groupDo: [:grp | groups add: grp ].
	^groups! !

!MetacelloVersion methodsFor: 'querying' stamp: ''!
difference: aMetacelloVersion
	"Return a a dictionary of additions, removals and modifications"
	
	^self spec difference: aMetacelloVersion spec! !

!MetacelloVersion methodsFor: 'testing' stamp: ''!
isPossibleBaseline

	^self spec isPossibleBaseline! !

!MetacelloVersion methodsFor: 'accessing' stamp: ''!
importedVersions

	importedVersions == nil ifTrue: [ importedVersions := #() ].
	^importedVersions! !

!MetacelloVersion methodsFor: 'accessing' stamp: ''!
versionSpec

	^self spec! !

!MetacelloVersion class methodsFor: 'instance creation' stamp: ''!
fromString: aString

	^self new versionNumber: aString asMetacelloVersionNumber! !

!MetacelloVersion class methodsFor: 'instance creation' stamp: ''!
fromSpec: aMetacelloVersionSpec
    ^ (self new versionNumber: aMetacelloVersionSpec versionNumber)
        spec: aMetacelloVersionSpec;
        yourself! !

!MetacelloVersionConstructor methodsFor: 'accessing' stamp: ''!
errorMap
    errorMap ifNil: [ errorMap := Dictionary new ].
    ^ errorMap! !

!MetacelloVersionConstructor methodsFor: 'initialization' stamp: ''!
calculate: aConfig project: aProject
    | versionMap symbolicVersionMap executionBlock pragmaDict |
    self setProject: aProject.
    self configuration: aConfig.
    versionMap := Dictionary new.
    symbolicVersionMap := Dictionary new.
    executionBlock := self specResolverBlock.
    self collectAllVersionsFromVersionPragmasInto: versionMap using: executionBlock.
    pragmaDict := self extractVersionImportPragmas.
    self verifyVersionImportPragmas: pragmaDict definedIn: versionMap.
    self collectAllVersionsFromVersionImportPragmasInto: versionMap using: executionBlock satisfiedPragmas: pragmaDict.
    self collectAllSymbolicVersionsFromVersionPragmasInto: symbolicVersionMap using: self symbolicVersionResolverBlock.
    self project map: versionMap.
    self project errorMap: self errorMap.
    self project symbolicVersionMap: symbolicVersionMap.
    self project configuration: aConfig.	"now that we have a nearly complete project, we can collect the defaultSymbolicVersions, which expect the project to be fully constructed"
    self
        collectDefaultSymbolicVersionsFromVersionPragmasFrom: self extractDefaultSymbolicVersionPragmas
        into: symbolicVersionMap
        using: self defaultSymbolicVersionResolverBlock.	"Pick up defaults from MetacelloBaseConfiguration"
    self
        collectDefaultSymbolicVersionsFromVersionPragmasFrom: self extractCommonDefaultSymbolicVersionPragmas
        into: symbolicVersionMap
        using: self commonDefaultSymbolicVersionResolverBlock.	"now resolive symbolicVersions defined as symbolicVersions"
    symbolicVersionMap copy
        keysAndValuesDo: [ :symbolic :original | 
            | versionString visited |
            versionString := original.
            visited := Set new.
            [ 
            visited add: versionString.
            versionString isSymbol and: [ versionString ~~ #'notDefined' ] ]
                whileTrue: [ 
                    versionString := symbolicVersionMap
                        at: versionString
                        ifAbsent: [ self error: 'Cannot resolve symbolic version ' , original printString ].
                    (visited includes: versionString)
                        ifTrue: [ self error: 'Loop detected resolving symbolic version ' , original printString ] ].
            symbolicVersionMap at: symbolic put: versionString ]! !

!MetacelloVersionConstructor methodsFor: 'private' stamp: ''!
commonDefaultSymbolicVersionResolverBlock
	^ self defaultSymbolicVersionResolverBlock: (ConfigurationOf new project: self project)! !

!MetacelloVersionConstructor methodsFor: 'initialization' stamp: ''!
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: 'validation' stamp: ''!
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: ''!
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: ''!
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: ''!
collectAllVersionsFromVersionPragmasInto: versionMap using: executionBlock
    | defined versionPragmaDict |
    versionPragmaDict := self extractVersionPragmas.
    versionPragmaDict
        keysAndValuesDo: [ :versionString :pragmaColl | 
            | versionSpec |
            versionSpec := self project versionSpec.
            versionSpec versionString: versionString.
            defined := false.
            [ 
            pragmaColl
                do: [ :pragma | 
                    executionBlock value: versionSpec value: pragma.
                    defined := true ] ]
                on: Error
                do: [ :ex | 
                    (MetacelloErrorInProjectConstructionNotification versionString: versionSpec versionString exception: ex)
                        ifTrue: [ ^ ex pass ]
                        ifFalse: [ 
                            self errorMap at: versionSpec versionString put: ex.
                            defined := false ] ].
            defined
                ifTrue: [ 
                    self validateVersionString: versionString againstSpec: versionSpec.
                    versionMap at: versionSpec versionString put: versionSpec createVersion ].
            self reset ]! !

!MetacelloVersionConstructor methodsFor: 'private' stamp: ''!
defaultSymbolicVersionResolverBlock: receiver
	^ [ :symbolicVrsn :pragma | 
	| result |
	result := nil.
	(pragma argumentAt: 1) = symbolicVrsn
		ifTrue: [ 
			self symbolicVersion: symbolicVrsn.
			result := [ receiver perform: (MetacelloPlatform current selectorForPragma: pragma) ] 
				on: MetacelloVersionDoesNotExistError 
				do: [ :ex | ex return: nil ] ].
	result ]! !

!MetacelloVersionConstructor methodsFor: 'initialization' stamp: ''!
on: aConfig project: aProject
    | cacheKey cachedProject |
    cacheKey := aConfig class.
    cachedProject := MetacelloPlatform current
        stackCacheFor: #'versionConstructor'
        at: cacheKey
        doing: [ :cache | 
            self calculate: aConfig project: aProject.
            cache at: cacheKey put: self project.
            ^ self ].
    aProject map: cachedProject map.
    aProject errorMap: cachedProject errorMap.
    aProject symbolicVersionMap: cachedProject symbolicVersionMap.
    aProject configuration: aConfig.
    self setProject: aProject! !

!MetacelloVersionConstructor methodsFor: 'private' stamp: ''!
defaultSymbolicVersionResolverBlock
	^ self defaultSymbolicVersionResolverBlock: self configuration! !

!MetacelloVersionConstructor methodsFor: 'private' stamp: ''!
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: ''!
verifyVersionImportPragmas: pragmaDict definedIn: versionMap
    pragmaDict copy
        keysAndValuesDo: [ :versionString :pragmaColl | 
            [ 
            pragmaColl
                do: [ :pragma | 
                    (pragma argumentAt: 2)
                        do: [ :importedVersion | 
                            versionMap
                                at: importedVersion
                                ifAbsent: [ 
                                    pragmaDict
                                        at: importedVersion
                                        ifAbsent: [ 
                                            ^ self
                                                error:
                                                    'The imported version:' , importedVersion printString , ' for version: ' , versionString
                                                        , ' referenced from the method: ' , (MetacelloPlatform current selectorForPragma: pragma) printString
                                                        , ' in configuration ' , configuration class printString
                                                        , ' has not been defined.' ] ] ] ] ]
                on: Error
                do: [ :ex | 
                    (MetacelloErrorInProjectConstructionNotification versionString: versionString exception: ex)
                        ifTrue: [ ^ ex pass ]
                        ifFalse: [ 
                            pragmaDict removeKey: versionString.
                            self errorMap at: versionString put: ex ] ] ]! !

!MetacelloVersionConstructor methodsFor: 'private' stamp: ''!
collectAllVersionsFromVersionImportPragmasInto: versionMap using: executionBlock satisfiedPragmas: pragmaDict
    | defined done completed count |
    done := false.
    completed := IdentitySet new.
    count := 0.
    [ 
    count := count + 1.
    count > 10000
        ifTrue: [ self error: 'Apparent loop in import expansion' ].
    done ]
        whileFalse: [ 
            done := true.
            pragmaDict
                keysAndValuesDo: [ :versionString :pragmaColl | 
                    | versionSpec |
                    versionSpec := nil.
                    defined := false.
                    [ 
                    pragmaColl
                        do: [ :pragma | 
                            (completed includes: pragma)
                                ifFalse: [ 
                                    | imports |
                                    done := false.
                                    imports := pragma argumentAt: 2.
                                    imports
                                        detect: [ :importedVersion | (versionMap includesKey: importedVersion) not ]
                                        ifNone: [ 
                                            imports
                                                do: [ :importedVersion | 
                                                    | version |
                                                    (version := versionMap at: importedVersion ifAbsent: [  ]) ~~ nil
                                                        ifTrue: [ 
                                                            defined := true.
                                                            completed add: pragma.
                                                            versionSpec == nil
                                                                ifTrue: [ versionSpec := version spec copy ]
                                                                ifFalse: [ versionSpec := versionSpec mergeSpec: version spec copy ].
                                                            versionSpec versionString: versionString.
                                                            executionBlock value: versionSpec value: pragma ] ] ] ] ] ]
                        on: Error
                        do: [ :ex | 
                            (MetacelloErrorInProjectConstructionNotification versionString: versionSpec versionString exception: ex)
                                ifTrue: [ ^ ex pass ]
                                ifFalse: [ 
                                    self errorMap at: versionSpec versionString put: ex.
                                 
                                    defined := false ] ].
                    defined
                        ifTrue: [ 
                            | version importedVersions |
                            importedVersions := OrderedCollection new.
                            version := versionSpec createVersion.
                            pragmaColl do: [ :pragma | importedVersions addAll: (pragma argumentAt: 2) ].
                            version importedVersions: importedVersions.
                            self validateVersionString: versionString againstSpec: versionSpec.
                            versionMap at: versionSpec versionString put: version ].
                    self reset ] ]! !

!MetacelloVersionConstructor methodsFor: 'private' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
on: aConfig

	^(self new)
		on: aConfig;
		yourself! !

!MetacelloVersionConstructor class methodsFor: 'instance creation' stamp: ''!
on: aConfig project: aProject

	^(self new)
		on: aConfig project: aProject;
		yourself! !

!MetacelloVersionDefinitionError methodsFor: 'printing' stamp: ''!
description
    "Return a textual description of the exception."

    ^ 'The version ' , self versionString printString , ' is not defined in ' , self project label
        , ' for the current platform, because an exception occurred while creating the version:. '
        , self exception description , '. Evaluate the following to see the error: ''['
        , self project configuration class name asString
        ,
            ' project ] 
	on: MetacelloErrorInProjectConstructionNotification 
	do: [:ex | ex resume: true ].'''
        ,
            '
Possible versions include: ' , self possibleVersions printString! !

!MetacelloVersionDefinitionError methodsFor: 'accessing' stamp: ''!
exception
	^ exception! !

!MetacelloVersionDefinitionError methodsFor: 'accessing' stamp: ''!
exception: anObject
	exception := anObject! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
additions: anObject
	additions := anObject! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
to
	^ to! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
additions
	additions ifNil: [ additions := Dictionary new ].
	^ additions! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
removals
	removals ifNil: [ removals := Dictionary new ].
	^ removals! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
from: anObject
	from := anObject! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
configuration
	^ configuration! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
to: anObject
	to := anObject! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
modifications
	modifications ifNil: [ modifications := Dictionary new ].
	^ modifications! !

!MetacelloVersionDiffReport methodsFor: 'printing' stamp: ''!
printOn: aStream
	| printBlock |
	printBlock := [ :pkgName :ar | 
	aStream
		tab: 2;
		nextPutAll: pkgName asString;
		cr.
	aStream
		tab: 3;
		print: (ar at: 1) asString ;
		nextPutAll: ' to ';
		print: (ar at: 2) asString ;
		cr ].
	aStream
		nextPutAll: self configuration asString;
		space;
		print: from asString ;
		nextPutAll: ' to ';
		print: to asString ;
		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! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
removals: anObject
	removals := anObject! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
configuration: anObject
	configuration := anObject! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
modifications: anObject
	modifications := anObject! !

!MetacelloVersionDiffReport methodsFor: 'accessing' stamp: ''!
from
	^ from! !

!MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: ''!
project: anObject
	project := anObject! !

!MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: ''!
versionString: anObject
	versionString := anObject! !

!MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: ''!
possibleVersions
    ^ self project symbolicVersionSymbols , (self project versions collect: [ :each | each versionString ])! !

!MetacelloVersionDoesNotExistError methodsFor: 'printing' stamp: ''!
description
    "Return a textual description of the exception."

    ^ 'Version ' , self versionString printString , ' is not defined in ' , self project label
        , '. Possible versions include: ' , self possibleVersions printString! !

!MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: ''!
project
	^ project! !

!MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: ''!
versionString
	^ versionString! !

!MetacelloVersionDoesNotExistError methodsFor: 'Signaling' stamp: ''!
signal
  "GemStone needs this to print exception correctly"

  self messageText: self description.
  ^ super signal! !

!MetacelloVersionDoesNotExistError class methodsFor: 'instance creation' stamp: ''!
project: aMetacelloProject versionString: aVersionString

	^(self new)
		project: aMetacelloProject;
		versionString: aVersionString;
		yourself! !

!MetacelloVersionLoadDirective methodsFor: 'actions' stamp: ''!
loadAtomicLoadDirective: aLoaderDirective gofer: aGofer

	aLoaderDirective loadDirectives do: [:directive | directive loadUsing: aLoaderDirective gofer: aGofer ].
	aLoaderDirective finalizeLoad: aGofer.! !

!MetacelloVersionLoadDirective methodsFor: 'accessing' stamp: ''!
loadDirectives: anObject
	loadDirectives := anObject! !

!MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: ''!
versionDirectivesDo: aBlock

	aBlock value: self.
	self loadDirectives do: [:directive | directive versionDirectivesDo: aBlock ].! !

!MetacelloVersionLoadDirective methodsFor: 'actions' stamp: ''!
add: aDirective

	self loadDirectives add: aDirective! !

!MetacelloVersionLoadDirective methodsFor: 'loading' stamp: ''!
loadPreloadDirective: aPreloadDirective 

	| block |
	(block :=  aPreloadDirective spec preLoadDoItBlock) ~~ nil
		ifTrue: [
			MetacelloNotification signal: ('Evaluating -> ', aPreloadDirective spec label, ' >> ', aPreloadDirective spec preLoadDoIt value asString).
			aPreloadDirective evaluateSupplyingAnswers: [ block valueWithPossibleArgs: 
					(Array 
						with: aPreloadDirective loader 
						with: aPreloadDirective spec) ].
			MetacelloNotification signal: ('Evaluated -> ', aPreloadDirective spec label, ' >> ', aPreloadDirective spec preLoadDoIt value asString)]! !

!MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: ''!
packagesDo: aBlock

	self loadDirectives do: [:directive | directive packageDo: aBlock ].! !

!MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: ''!
prepostLoadsDo: aBlock

	self loadDirectives do: [:directive | directive prepostLoadDo: aBlock ].! !

!MetacelloVersionLoadDirective methodsFor: 'loading' stamp: ''!
loadPostloadDirective: aPostloadDirective 

	| block |
	(block :=  aPostloadDirective spec postLoadDoItBlock) ~~ nil
		ifTrue: [
			MetacelloNotification signal: ('Evaluating -> ', aPostloadDirective spec label, ' >> ', aPostloadDirective spec postLoadDoIt value asString).
			aPostloadDirective evaluateSupplyingAnswers: [ block valueWithPossibleArgs: 
					(Array 
						with: aPostloadDirective loader 
						with: aPostloadDirective spec) ].
			MetacelloNotification signal: ('Evaluated -> ', aPostloadDirective spec label, ' >> ', aPostloadDirective spec postLoadDoIt value asString)]! !

!MetacelloVersionLoadDirective methodsFor: 'printing' stamp: ''!
printOn: aStream indent: indent

	super printOn: aStream indent: indent.
	self printLoadDirectivesOn: aStream indent: indent! !

!MetacelloVersionLoadDirective methodsFor: 'actions' stamp: ''!
finalizeLoad: aGofer
	"nothing special for linear loads"! !

!MetacelloVersionLoadDirective methodsFor: 'accessing' stamp: ''!
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: 'printing' stamp: ''!
label

	self spec == nil ifTrue: [ ^'' ].
	^self spec label! !

!MetacelloVersionLoadDirective methodsFor: 'actions' stamp: ''!
loadWithPolicy: aLoadPolicy

	| gofer |
	gofer := MetacelloGofer new.
	gofer disablePackageCache.
	gofer repository: aLoadPolicy cacheRepository.
	self loadUsing: self gofer: gofer! !

!MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: ''!
prepostLoadDirectivesDo: aBlock

	self loadDirectives do: [:directive | directive prepostLoadDirectivesDo: aBlock ].! !

!MetacelloVersionLoadDirective methodsFor: 'actions' stamp: ''!
loadExplicitLoadDirective: aLoaderDirective gofer: aGofer
	"load has already been performed, no need to load again"! !

!MetacelloVersionLoadDirective methodsFor: 'actions' stamp: ''!
loadLinearLoadDirective: aLoaderDirective gofer: aGofer

	aLoaderDirective loadDirectives do: [:directive | directive loadUsing: aLoaderDirective gofer: aGofer ].
	aLoaderDirective finalizeLoad: aGofer.! !

!MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: ''!
versionDo: aBlock

	aBlock value: self.! !

!MetacelloVersionLoadDirective methodsFor: 'loading' stamp: ''!
loadPackageDirective: aPackageLoadDirective gofer: aGofer

	aPackageLoadDirective loader loadingSpecLoader 
		loadPackageDirective: aPackageLoadDirective 
		gofer: aGofer! !

!MetacelloVersionLoadDirective methodsFor: 'testing' stamp: ''!
isExplicit

	^false! !

!MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: ''!
packageDirectivesDo: aBlock

	self loadDirectives do: [:directive | directive packageDirectivesDo: aBlock ].! !

!MetacelloVersionLoadDirective methodsFor: 'printing' stamp: ''!
printLoadDirectivesOn: aStream indent: indent

	self loadDirectives do: [:each |
		aStream cr. 
		each printOn: aStream indent: indent + 1 ].! !

!MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: ''!
directivesDo: aBlock

	aBlock value: self.
	self loadDirectives do: [:directive | directive directivesDo: aBlock ].! !

!MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: ''!
versionsDo: aBlock

	self loadDirectives do: [:directive | directive versionDo: aBlock ].! !

!MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: ''!
versionDirectivesDepthFirstDo: aBlock

	self loadDirectives do: [:directive | directive versionDirectivesDepthFirstDo: aBlock ].
	aBlock value: self.! !

!MetacelloVersionLoadDirective methodsFor: 'accessing' stamp: ''!
loadDirectives

	loadDirectives == nil ifTrue: [ loadDirectives := OrderedCollection new ].
	^ loadDirectives! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
block
	^ block! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
block: anObject
	block := anObject! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
attributeOrPath
    ^ self parent == nil
        ifTrue: [ 
            self attributes size == 1
                ifTrue: [ self attributes first ]
                ifFalse: [ self attributes ] ]
        ifFalse: [ self attributePath ]! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
topParent
	self parent == nil
		ifTrue: [ ^ self ].
	^ self parent topParent! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
parent: anObject
	parent := anObject! !

!MetacelloVersionMethodSection methodsFor: 'printing' stamp: ''!
printOn: aStream
  aStream
    nextPutAll: self class name asString;
    nextPut: $(.
  self versionSpec printOn: aStream.
  aStream nextPut: $)! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
versionSpec: anObject
	versionSpec := anObject! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
addMethodSection: methodSection

	methodSection parent: self.
	self methodSections add: methodSection! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
methodSections

	methodSections ifNil: [ methodSections := OrderedCollection new ].
	^methodSections! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
attributePath
    | path |
    path := MetacelloMethodSectionPath with: self attributes.
    ^ self parent == nil
        ifTrue: [ path ]
        ifFalse: [ self parent attributePath , path ]! !

!MetacelloVersionMethodSection methodsFor: 'accessing' stamp: ''!
versionSpec
	^ versionSpec! !

!MetacelloVersionMethodSpec methodsFor: 'method generation' stamp: ''!
methodSource
    | strm |
    strm := WriteStream on: String new.
    self
        methodSelectorAndPragma: self selector
        imports: self imports
        versionString: self versionString
        on: strm.
    self
        methodSection: self
        pre: [ :methodSection :indent | 
            strm
                cr;
                tab: indent;
                nextPutAll: 'spec for: ' , methodSection attributePrintString , ' do: [';
                cr.
            methodSection versionSpec configMethodOn: strm last: methodSection methodSections isEmpty indent: indent + 1 ]
        last: false
        post: [ :methodSection :indent :last | 
            strm nextPutAll: ' ].'.
            (last or: [ indent = 1 or: [ methodSection methodSections isEmpty and: [ indent = 1 ] ] ])
                ifTrue: [ strm cr ] ]
        indent: 0.
    ^ strm contents! !

!MetacelloVersionMethodSpec methodsFor: 'accessing' stamp: ''!
versionString: aStringOrSymbol

	aStringOrSymbol isSymbol ifTrue: [ self error: 'Version string ', aStringOrSymbol printString, ' for version method must be a String' ].
	super versionString: aStringOrSymbol! !

!MetacelloVersionMethodSpec methodsFor: 'accessing' stamp: ''!
imports: anObject
	imports := anObject! !

!MetacelloVersionMethodSpec methodsFor: 'adding' stamp: ''!
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: 'private' stamp: ''!
methodSection: methodSection pre: preBlock last: last post: postBlock indent: indent
	| list |
	methodSection ~~ self
		ifTrue: [ preBlock value: methodSection value: indent ].
	list := methodSection methodSections.
	1 to: list size
		do: [ :index | | ms | 
			ms := list at: index.
			self
				methodSection: ms
				pre: preBlock
				last: index ~= list size
				post: postBlock
				indent: indent + 1 ].
	methodSection ~~ self
		ifTrue: [ postBlock value: methodSection value: indent value: last ]! !

!MetacelloVersionMethodSpec methodsFor: 'adding' stamp: ''!
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: 'accessing' stamp: ''!
imports
	imports == nil ifTrue: [ imports := #() ].
	^ imports! !

!MetacelloVersionMethodSpec methodsFor: 'method generation' stamp: ''!
methodSelectorAndPragma: aSelector imports: importList versionString: aString on: strm
	strm
		nextPutAll: aSelector asString , ' spec';
		cr;
		tab;
		nextPutAll: '<version: ' , aString printString.
	importList notEmpty
		ifTrue: [ 
			strm nextPutAll: ' imports: #('.
			importList
				do: [ :importVersionString | 
					strm
						nextPutAll: importVersionString printString;
						space ].
			strm nextPut: $) ].
	strm
		nextPutAll: '>';
		cr! !

!MetacelloVersionNumber commentStamp: ''!
# 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: 'private' stamp: ''!
collapseZeros
	"the rule must be that zeros can be collapsed as long as the series of zeros ends in a string term"

	| collection newSize new j lastElementIsStringOrZero canCollapse |
	(self size = 0 or: [ self at: 1 ]) == 0
		ifTrue: [ ^ self ].
	collection := OrderedCollection new.
	lastElementIsStringOrZero := true.
	canCollapse := true.
	self size to: 1 by: -1 do: [ :i | 
		| element |
		element := self at: i.
		(canCollapse and: [ element == 0 ])
			ifTrue: [ 
				lastElementIsStringOrZero
					ifFalse: [ 
						canCollapse := false.
						collection addFirst: element.]]
			ifFalse: [ 
				collection addFirst: element.
				canCollapse := lastElementIsStringOrZero := element isString ] ].
	collection size = self size
		ifTrue: [ ^ self ].
	newSize := collection size.
	new := self species new: newSize.
	j := 0.
	collection
		do: [ :element | 
			new at: j + 1 put: element.
			j := j + 1 ].
	^ new! !

!MetacelloVersionNumber methodsFor: 'comparing' stamp: ''!
< 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: 'operations' stamp: ''!
incrementMinorVersion
  self size < 2
    ifTrue: [ self at: 2 put: 0 ].
  self incrementVersionAt: 2! !

!MetacelloVersionNumber methodsFor: 'comparing' stamp: ''!
= 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: 'enumerating' stamp: ''!
do: elementBlock separatedBy: separatorBlock
	"Evaluate the elementBlock for all elements in the receiver,
	and evaluate the separatorBlock between."

	| beforeFirst | 
	beforeFirst := true.
	self do:
		[:each |
		beforeFirst
			ifTrue: [beforeFirst := false]
			ifFalse: [separatorBlock value].
		elementBlock value: each]! !

!MetacelloVersionNumber methodsFor: 'comparing' stamp: ''!
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: ''!
~> aMetacelloVersionNumber

	aMetacelloVersionNumber size == 1 ifTrue: [ ^false ].
	^self >= aMetacelloVersionNumber and: [ self < aMetacelloVersionNumber approximateBase ]! !

!MetacelloVersionNumber methodsFor: 'printing' stamp: ''!
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: 'converting' stamp: ''!
asMetacelloVersionNumber

	^self! !

!MetacelloVersionNumber methodsFor: 'accessing' stamp: ''!
approximateBase

	| base |
	base := self copyFrom: 1 to: self size - 1.
	base at: base size put: (base at: base size) + 1.
	^base! !

!MetacelloVersionNumber methodsFor: 'enumerating' stamp: ''!
do: aBlock 
	"Refer to the comment in Collection|do:."
	1 to: self size do:
		[:index | aBlock value: (self at: index)]! !

!MetacelloVersionNumber methodsFor: 'operations' stamp: ''!
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: 'accessing' stamp: ''!
versionString

	| strm |
	strm := WriteStream on: String new.
	self printOn: strm.
	^strm contents! !

!MetacelloVersionNumber methodsFor: 'operations' stamp: ''!
incrementMajorVersion
  self incrementVersionAt: 1! !

!MetacelloVersionNumber methodsFor: 'private' stamp: ''!
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: 'operations' stamp: ''!
incrementPatchVersion
  self size < 2
    ifTrue: [ self at: 2 put: 0 ].
  self size < 3
    ifTrue: [ self at: 3 put: 0 ].
  self incrementVersionAt: 3! !

!MetacelloVersionNumber methodsFor: 'private' stamp: ''!
compareLessThan: aMetacelloVersionNumber
	| mySize aSize commonSize count more |
	mySize := self size.
	aSize := aMetacelloVersionNumber size.
	commonSize := mySize min: aSize.
	count := 0.
	more := true.
	[ more and: [ count < commonSize ] ]
		whileTrue: [ (self at: count + 1) = (aMetacelloVersionNumber at: count + 1)
				ifTrue: [ count := count + 1 ]
				ifFalse: [ more := false ] ].
	count < commonSize ifTrue: [ ^ (self at: count + 1) metacelloVersionComponentLessThan: (aMetacelloVersionNumber at: count + 1) ].
	^ mySize < aSize
		ifTrue: [ mySize = 0 ifTrue: [ ^ true ].
			"if the versions at commonSize are equal and the next version slot in aMetacelloVersionNumber 
			 is a string, then it's considered that I'm > aMetacelloVersionNumber
			 (i.e., '2.9.9' is greater than '2.9.9-alpha.2')"
			(self at: commonSize) = (aMetacelloVersionNumber at: commonSize) ifFalse: [ ^ true ].
			(aMetacelloVersionNumber at: commonSize + 1) isString not ]
		ifFalse: [ mySize = aSize ifTrue: [ ^ false ].
			aSize <= 0 ifTrue: [ ^ false ].
			"if the versions at commonSize are equal and the next version slot is a string, 
			 then it's considered that I'm < aMetacelloVersionNumber
			 (i.e., '2.9.9-alpha.2' is less than '2.9.9')"
			(self at: commonSize) = (aMetacelloVersionNumber at: commonSize) ifFalse: [ ^ false ].
			(self at: commonSize + 1) isString ]! !

!MetacelloVersionNumber methodsFor: 'operations' stamp: ''!
decrementPatchVersion
  self size < 2
    ifTrue: [ self at: 2 put: 0 ].
  self size < 3
    ifTrue: [ self at: 3 put: 0 ].
  self decrementVersionAt: 3! !

!MetacelloVersionNumber methodsFor: 'private' stamp: ''!
decrementVersionAt: index
  | int |
  int := self at: index.
  (int := self at: index) isString
    ifFalse: [ 
      int > 0
        ifTrue: [ self at: index put: int - 1 ] ]! !

!MetacelloVersionNumber methodsFor: 'private' stamp: ''!
incrementVersionAt: index
  | int |
  int := self at: index.
  (int := self at: index) isString
    ifFalse: [ self at: index put: int + 1 ]! !

!MetacelloVersionNumber methodsFor: 'copying' stamp: ''!
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: 'operations' stamp: ''!
decrementMinorVersionNumber
	| int |
	self size to: 1 by: -1 do: [ :index | 
		(int := self at: index) isString
			ifFalse: [ 
				int > 0
					ifTrue: [ self at: index put: int - 1 ].
				^ self ] ]! !

!MetacelloVersionNumber methodsFor: 'comparing' stamp: ''!
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: 'operations' stamp: ''!
decrementMajorVersion
  self decrementVersionAt: 1! !

!MetacelloVersionNumber methodsFor: 'operations' stamp: ''!
decrementMinorVersion
  self size < 2
    ifTrue: [ self at: 2 put: 0 ].
  self decrementVersionAt: 2! !

!MetacelloVersionNumber class methodsFor: 'instance creation' stamp: ''!
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: ''!
extractNumericComponent: subString
	"$. separated components are integers"

	| number |
	number := [subString asNumber] 
						on: Error 
						do: [:ex | ex return: subString ].
	^number asString = subString
		ifTrue: [ number ]
		ifFalse: [ subString ]! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion10
	| x y |
	self
		assert:
			(x := (({(self versionClass fromString: '1.0') . (self versionClass fromString: '0.7') . (self versionClass fromString: '0.8').
			(self versionClass fromString: '0.9') . (self versionClass fromString: '1.0.1')} sort: [ :a :b | a <= b ]) collect: [ :each | each versionString ]) asArray)
		equals: (y := #('0.7' '0.8' '0.9' '1.0' '1.0.1'))! !

!MetacelloVersionNumberTestCase methodsFor: 'private' stamp: ''!
versionClass

	^MetacelloVersionNumber! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testCollapseZeros
	self assert: (MetacelloVersionNumber fromString: '1.0-beta.24.0.1') collapseZeros printString equals: '1-beta.24.0.1'.
	self assert: (MetacelloVersionNumber fromString: '1.0-beta.24.0.0.1') collapseZeros printString equals: '1-beta.24.0.0.1'.
	self assert: (MetacelloVersionNumber fromString: '1.0.0-beta.24.0.0.1') collapseZeros printString equals: '1-beta.24.0.0.1'! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion07

	| v1 v2 |
	v1 := self versionClass fromString: '3.0.0'.
	v2 := self versionClass fromString: '2'.
	self assert: (v1 > v2)! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion24
	self assert: (MetacelloVersionNumber fromString: '3.0.3.-rc.1') ~= (MetacelloVersionNumber fromString: '3.0.0.3-rc.1').
	self assert: (MetacelloVersionNumber fromString: '1.0.0.1.0.0') equals: (MetacelloVersionNumber fromString: '1.0.0.1').
	self assert: (MetacelloVersionNumber fromString: '1.0.0.1') ~= (MetacelloVersionNumber fromString: '1..1')! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion03

	| v1 v2 |
	v1 := self versionClass fromString: '1.0.0.1'.
	v2 := self versionClass fromString: '1.0.0'.
	self assert: (v1 > v2)! !

!MetacelloVersionNumberTestCase methodsFor: 'tests - approximately greater than' stamp: ''!
testApproxVersion03

	self assert: '1.1' asMetacelloVersionNumber ~> '1.1' asMetacelloVersionNumber! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion13

	self deny: ((self versionClass fromString: '0.8') <= (self versionClass fromString: '0.7')).
	self deny: ((self versionClass fromString: '0.8.1.8') <= (self versionClass fromString: '0.7.0.5')).! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion16
    self assert: (self versionClass fromString: '1.0-beta.0') < (self versionClass fromString: '1.0').
    self assert: (self versionClass fromString: '1.0-beta.0') < (self versionClass fromString: '1.0.0').
    self assert: (self versionClass fromString: '1.0-beta.0') < (self versionClass fromString: '1.0.0.0')! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion21
	self deny: (MetacelloVersionNumber fromString: '') > (MetacelloVersionNumber fromString: '0').
	self assert: (MetacelloVersionNumber fromString: '') < (MetacelloVersionNumber fromString: '0').
	self assert: (MetacelloVersionNumber fromString: '') equals: (MetacelloVersionNumber fromString: '')! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion11

	| v1 v2 |
	v1 := self versionClass fromString: '1.0.1b'.
	v2 := self versionClass fromString: '1.0.1a'.
	self assert: (v1 >= v2).
	self assert: (v2 <= v1)! !

!MetacelloVersionNumberTestCase methodsFor: 'tests - approximately greater than' stamp: ''!
testApproxVersion01

	self assert: '1.1.1' asMetacelloVersionNumber ~> '1.1' asMetacelloVersionNumber! !

!MetacelloVersionNumberTestCase methodsFor: 'tests - version increment/decrement' stamp: ''!
testIncrementDecrementVersionNumber
	| version |
	super testIncrementDecrementVersionNumber.
	version := '1' asMetacelloVersionNumber.
	self assert: version incrementMinorVersionNumber asString equals: '2'.
	self assert: version decrementMinorVersionNumber asString equals: '1'.
	version := '1.0' asMetacelloVersionNumber.
	self assert: version incrementMinorVersionNumber asString equals: '1.1'.
	self assert: version decrementMinorVersionNumber asString equals: '1.0'.
	version := '1.0.0' asMetacelloVersionNumber.
	self assert: version incrementMinorVersionNumber asString equals: '1.0.1'.
	self assert: version decrementMinorVersionNumber asString equals: '1.0.0'.
	version := '1.0.0.0' asMetacelloVersionNumber.
	self assert: version incrementMinorVersionNumber asString equals: '1.0.0.1'.
	self assert: version decrementMinorVersionNumber asString equals: '1.0.0.0'! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion17
	self assert: (self versionClass fromString: '1.0') equals: (self versionClass fromString: '1.0.0').
	self assert: (self versionClass fromString: '1') equals: (self versionClass fromString: '1.0').
	self assert: (self versionClass fromString: '1') > (self versionClass fromString: '1-0').
	self assert: (self versionClass fromString: '1') > (self versionClass fromString: '1.0-beta.0').
	self assert: (self versionClass fromString: '1') > (self versionClass fromString: '1-beta.0').
	self assert: (self versionClass fromString: '1') > (self versionClass fromString: '1-beta')! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion12

	self deny: ((self versionClass fromString: '1.0') <= (self versionClass fromString: '0.7'))! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion19

	self assert: ((self versionClass fromString: '1.0-beta.0') < (self versionClass fromString: '1')).! !

!MetacelloVersionNumberTestCase methodsFor: 'tests - approximately greater than' stamp: ''!
testApproxVersion02

	self deny: '1.1' asMetacelloVersionNumber ~> '1' asMetacelloVersionNumber! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion05

	| v1 v2 |
	v1 := self versionClass fromString: '3'.
	v2 := self versionClass fromString: '2'.
	self assert: (v1 > v2)! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion09

	| v1 v2 |
	v1 := self versionClass fromString: '1.0'.
	v2 := self versionClass fromString: '0.7'.
	self assert: (v1 >= v2).
	self assert: (v2 <= v1)! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion15

	self assert: ((self versionClass fromString: '1.0-beta.0') < (self versionClass fromString: '1.0-beta.1')).! !

!MetacelloVersionNumberTestCase methodsFor: 'tests - matching' stamp: ''!
testStandardMatch

	self assert: ((self versionClass fromString: '1.1.1') match: '*.*.*').
	self deny: ((self versionClass fromString: '1.1.1') match: '*.*').
	self assert: ((self versionClass fromString: '1.1.0') match: '1.1.*').
	self assert: ((self versionClass fromString: '1.1.0') match: '1.#.*').
	self deny: ((self versionClass fromString: '1.10.0') match: '1.#.*').
	self assert: ((self versionClass fromString: '1-alpha5.0') match: '1-alpha#.0').
	self assert: ((self versionClass fromString: '1.alpha5.0') match: '1-alpha#.0').
	self assert: ((self versionClass fromString: '1.alpha5.0') match: '1.alpha#.0').
	self deny: ((self versionClass fromString: '1-alpha10.0') match: '1-alpha#.0').! !

!MetacelloVersionNumberTestCase methodsFor: 'tests - matching' stamp: ''!
testSpecialMatch

	self assert: ((self versionClass fromString: '1.1') match: '?').
	self assert: ((self versionClass fromString: 'alpha') match: '?').
	self assert: ((self versionClass fromString: '1.1.1.1.1') match: '?').
	self assert: ((self versionClass fromString: '1.alpha5') match: '?').
	self assert: ((self versionClass fromString: '1.1') match: '*.?').
	self assert: ((self versionClass fromString: '1.1') match: '?').
	self assert: ((self versionClass fromString: '10.1.1.1.1') match: '?').
	self deny: ((self versionClass fromString: '1.1') match: '*.*.?').
	self assert: ((self versionClass fromString: '1.1.1') match: '*.?').! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion08

	| v1 v2 |
	v1 := self versionClass fromString: '1.0a6'.
	v2 := self versionClass fromString: '1.0a5'.
	self assert: (v1 > v2)! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion18

	self deny: ((self versionClass fromString: '1.0') < (self versionClass fromString: '1')).
	self deny: ((self versionClass fromString: '1.0') < (self versionClass fromString: '1-0')).! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion20
	self assert: (MetacelloVersionNumber fromString: '') printString equals: ''! !

!MetacelloVersionNumberTestCase methodsFor: 'tests - matching' stamp: ''!
testInvalidSpecialMatch

	self 
		should: [ ((self versionClass fromString: '1.1') match: '?.?') ]
		raise: Error.! !

!MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: ''!
testVersion06

	| v1 v2 |
	v1 := self versionClass fromString: '3.'.
	v2 := self versionClass fromString: '2'.
	self assert: (v1 > v2)! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
getTimestamp
	^timestamp! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
getAuthor
	^author! !

!MetacelloVersionSpec methodsFor: 'printing' stamp: ''!
configSpawnMethodOn: aStream indent: indent

	self configMethodValueOn: aStream for: self getBlessing selector: 'blessing:' last: false indent: indent.
	self configMethodValueOn: aStream for: self getAuthor selector: 'author:' last: false indent: indent.
	self configMethodValueOn: aStream for: self getTimestamp selector: 'timestamp:' last: false indent: indent.! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
project: aString overrides: aBlock constructor: aVersionConstructor
    aVersionConstructor projectForVersion: aString overrides: aBlock! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
removeProject: aString constructor: aVersionConstructor
    aVersionConstructor removeProjectForVersion: aString! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
importArray
  ^ importArray! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
repository: aString username: username password: password constructor: aVersionConstructor
    aVersionConstructor repositoryForVersion: aString username: username password: password! !

!MetacelloVersionSpec methodsFor: 'querying' stamp: ''!
packageNamed: aString

	^self packageNamed: aString ifAbsent: [ nil ]! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
preLoadDoIt: aSymbol constructor: aVersionConstructor
    aVersionConstructor preLoadDoItForVersion: aSymbol! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
description

	description == nil 
		ifTrue: [
			^self project valueHolderSpec
				value: '';
				yourself].
	^ description! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
versionString: anObject
	versionString := anObject! !

!MetacelloVersionSpec methodsFor: 'merging' stamp: ''!
mergeMap
    | map |
    map := super mergeMap.
    map at: #'versionString' put: versionString.
    map at: #'blessing' put: blessing.
    map at: #'description' put: description.
    map at: #'author' put: author.
    map at: #'timestamp' put: timestamp.
    map at: #'preLoadDoIt' put: preLoadDoIt.
    map at: #'postLoadDoIt' put: postLoadDoIt.
    map at: #'packageList' put: self packages.
    ^ map! !

!MetacelloVersionSpec methodsFor: 'querying' stamp: ''!
packageNames
    packageList == nil
        ifTrue: [ ^ #() ].
    ^ self packages map keys asSet! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
baseline: aString constructor: aVersionConstructor
    aVersionConstructor baselineForVersion: aString! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
configuration: aString with: aBlockOrString constructor: aVersionConstructor
    aVersionConstructor configurationForVersion: aString with: aBlockOrString! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
blessing: aBlockOrString constructor: aVersionConstructor
    aVersionConstructor blessingForVersion: aBlockOrString! !

!MetacelloVersionSpec methodsFor: 'querying' stamp: ''!
packageSpecsInLoadOrder
  ^ self packages packageSpecsInLoadOrderFor: self! !

!MetacelloVersionSpec methodsFor: 'querying' stamp: ''!
versionString
	versionString == nil ifTrue: [ ^'' ].
	^ versionString! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
projectLabel

	^self project label! !

!MetacelloVersionSpec methodsFor: 'loading' stamp: ''!
defaultPackageNames
	"if there is a package named 'default' (a group) then it defines the default package names,
	 otherwise answer a list of all of the package names in this version"

	self packages packageNamed: 'default' ifAbsent: [ ^self packageNames ].
	^#('default')! !

!MetacelloVersionSpec methodsFor: 'printing' stamp: ''!
label

	^self versionString, ' [', self projectLabel, ']'! !

!MetacelloVersionSpec methodsFor: 'loading' stamp: ''!
resolveToLoadableSpecs: nameList
  "Resolves names in namelist to the  list of packages and projects in the version that would be loaded. Projects are 
	not traversed during the transitive closure. The scope is that of the version itself.
	   If the spec is a package, answer a list including the package and the transitive closure on 
			its #requires: and #includes: fields.
	   If the spec is a project, answer the project.
	   If the spec is a group, answers the list of packages in the #includes: field of the group. 
			Groups in the #includes: field are expanded following the transitive closure on groups"

  | map |
  map := Dictionary new.
  self resolveToLoadableSpecs: nameList forLoad: false map: map.
  ^ map values! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
packages: anObject
    packageList := anObject! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
setPostLoadDoIt: aSymbol

	postLoadDoIt := aSymbol! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
import: aString provides: anArray
  importArray := importArray
    ifNil: [ {(aString -> anArray)} ]
    ifNotNil: [ importArray , {(aString -> anArray)} ]! !

!MetacelloVersionSpec methodsFor: 'printing' stamp: ''!
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: 'loading' stamp: ''!
expandToLoadableSpecNames: nameList

	| cacheKey names |
	cacheKey := Array with: self label with: nameList.
	^MetacelloPlatform current
		stackCacheFor: #loadableSpecNames
		at: cacheKey
		doing: [ :cache | 
			names := (self resolveToLoadableSpecs: nameList) collect: [:spec | spec name ].
			cache at: cacheKey put: names ].! !

!MetacelloVersionSpec methodsFor: 'merging' stamp: ''!
nonOverridable
    ^ super nonOverridable , #(#'packageList')! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
description: anObject

	anObject setDescriptionInMetacelloVersion: self! !

!MetacelloVersionSpec methodsFor: 'copying' stamp: ''!
postCopy
    super postCopy.
    blessing := blessing copy.
    description := description copy.
    author := author copy.
    timestamp := timestamp copy.
    packageList := packageList copy! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
setPreLoadDoIt: aSymbol

	preLoadDoIt := aSymbol! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
timestamp: anObject

	anObject setTimestampInMetacelloVersion: self! !

!MetacelloVersionSpec methodsFor: 'testing' stamp: ''!
isPartiallyCurrent: notLoadedMatters useEquality: useEquality

	self subclassResponsibility! !

!MetacelloVersionSpec methodsFor: 'private' stamp: ''!
createVersion

	^self versionClass fromSpec: self! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
group: aString overrides: aStringOrCollection constructor: aVersionConstructor
    aVersionConstructor groupForVersion: aString overrides: aStringOrCollection! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
setImport: anArray
  importArray := importArray
    ifNil: [ anArray ]
    ifNotNil: [ importArray , anArray ]! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
baseline: aString with: aBlockOrString constructor: aVersionConstructor
    aVersionConstructor baselineForVersion: aString with: aBlockOrString! !

!MetacelloVersionSpec methodsFor: 'printing' stamp: ''!
configMethodValueOn: aStream for: spec selector: selector last: last indent: indent
	| valuePrintString |
	spec == nil
		ifTrue: [ ^ self ].
	valuePrintString := spec value isSymbol
		ifTrue: [ '#' , spec value asString printString ]
		ifFalse: [ spec value printString ].
	aStream
		tab: indent;
		nextPutAll: 'spec ' , selector , ' ' , valuePrintString , '.'.
	last
		ifFalse: [ aStream cr ]! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
postLoadDoIt: anObject

	anObject setPostLoadDoItInMetacelloSpec: self! !

!MetacelloVersionSpec methodsFor: 'testing' stamp: ''!
isPossibleBaseline
    self subclassResponsibility! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
timestamp: aBlockOrStringOrDateAndTime constructor: aVersionConstructor
    aVersionConstructor timestampForVersion: aBlockOrStringOrDateAndTime! !

!MetacelloVersionSpec methodsFor: 'private' stamp: ''!
versionClass

	^MetacelloVersion! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
getPreLoadDoIt
	^preLoadDoIt! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
getBlessing
	^blessing! !

!MetacelloVersionSpec methodsFor: 'private' stamp: ''!
versionNumber
    ^ self project versionNumberClass fromString: self versionString! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
import: aString provides: anArray constructor: aVersionConstructor
  aVersionConstructor importForVersion: aString provides: anArray! !

!MetacelloVersionSpec methodsFor: 'toolbox support' stamp: ''!
deleteSpec: aSpec
    "remove the spec from packages"

    self packages deleteSpec: aSpec! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
repositories: aBlock constructor: aVersionConstructor
    aVersionConstructor repositoriesForVersion: aBlock! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
author: aBlockOrString constructor: aVersionConstructor
    aVersionConstructor authorForVersion: aBlockOrString! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
packages
    packageList == nil
        ifTrue: [ packageList := self project packagesSpec ].
    ^ packageList! !

!MetacelloVersionSpec methodsFor: 'printing' stamp: ''!
configMethodOn: aStream last: last indent: indent
    | hasPackageSpecs |
    hasPackageSpecs := false.
    self packagesSpec list
        do: [ :member | 
            member spec
                projectDo: [ :proj | 
                    member spec name ~~ nil
                        ifTrue: [ hasPackageSpecs := true ] ]
                packageDo: [ :package | 
                    member spec name ~~ nil
                        ifTrue: [ hasPackageSpecs := true ] ]
                groupDo: [ :group | 
                    member spec name ~~ nil
                        ifTrue: [ hasPackageSpecs := true ] ] ].
    self configMethodBasicOn: aStream last: hasPackageSpecs not indent: indent.
    self configPackagesSpecMethodOn: aStream indent: indent.
    last
        ifFalse: [ aStream cr ]! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
blessing: anObject

	anObject setBlessingInMetacelloVersion: self! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
preLoadDoIt: anObject

	anObject setPreLoadDoItInMetacelloSpec: self! !

!MetacelloVersionSpec methodsFor: 'querying' stamp: ''!
preLoadDoIt

	^preLoadDoIt! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
timestamp

	timestamp == nil 
		ifTrue: [
			^self project valueHolderSpec
				value: '';
				yourself].
	^ timestamp! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
import: aString constructor: aVersionConstructor
    aVersionConstructor importForVersion: aString! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
description: aBlockOrString constructor: aVersionConstructor
    aVersionConstructor descriptionForVersion: aBlockOrString! !

!MetacelloVersionSpec methodsFor: 'enumerating' stamp: ''!
projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock

	self packageSpecsInLoadOrder do: [:pkgSpec |
		pkgSpec projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock ]! !

!MetacelloVersionSpec methodsFor: 'querying' stamp: ''!
packageNamed: aString ifAbsent: aBlock

	^self packageNamed: aString forMap: self packages map ifAbsent: aBlock! !

!MetacelloVersionSpec methodsFor: 'loading' stamp: ''!
resolveToLoadableSpecs: required forLoad: forLoad map: packageMap
  | reqd allReqd map newReqd spec |
  reqd := required copy.
  allReqd := Set new.
  map := self packages map.
  [ reqd isEmpty ]
    whileFalse: [ 
      newReqd := Set new.
      reqd
        do: [ :req | 
          (self
            resolveToLoadableSpec: req
            forLoad: forLoad
            forMap: map
            packages: packageMap)
            do: [ :loadableSpec | 
              newReqd addAll: loadableSpec requires.
              newReqd addAll: loadableSpec includes ] ].
      allReqd addAll: reqd.
      newReqd removeAllFoundIn: allReqd.
      reqd := newReqd ].
  packageMap keys
    do: [ :pkgName | 
      (spec := (packageMap at: pkgName) resolveToLoadableSpec) == nil
        ifTrue: [ packageMap removeKey: pkgName ]
        ifFalse: [ packageMap at: pkgName put: (packageMap at: pkgName) resolveToLoadableSpec ] ]! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
postLoadDoIt: aSymbol constructor: aVersionConstructor
    aVersionConstructor postLoadDoItForVersion: aSymbol! !

!MetacelloVersionSpec methodsFor: 'printing' stamp: ''!
configPackagesSpecMethodOn: aStream indent: indent

	| projectSpecs packageSpecs groupSpecs |
	projectSpecs := OrderedCollection new.
	packageSpecs := OrderedCollection new.
	groupSpecs := OrderedCollection new.
	self packagesSpec list do: [:member |
		member spec 
			projectDo: [:proj | member spec name ~~ nil ifTrue: [ projectSpecs add: member ]]
			packageDo: [:package | member spec name ~~ nil ifTrue: [ packageSpecs add: member ]]
			groupDo: [:group | member spec name ~~ nil ifTrue: [ groupSpecs add: member ]]].
	projectSpecs isEmpty not
		ifTrue: [
			aStream tab: indent; nextPutAll: 'spec '.
			projectSpecs size > 1 ifTrue: [ aStream cr; tab: indent + 1 ].
			1 to: projectSpecs size  do: [:index | 
				(projectSpecs at: index) configMethodCascadeOn: aStream last: index == projectSpecs size indent: indent + 1.
				index ~= projectSpecs size ifTrue: [ aStream tab: indent + 1 ]]].
	packageSpecs isEmpty not
		ifTrue: [
			projectSpecs isEmpty not ifTrue: [ aStream cr ].
			aStream tab: indent; nextPutAll: 'spec '.
			packageSpecs size > 1 ifTrue: [ aStream cr; tab: indent + 1 ].
			1 to: packageSpecs size  do: [:index | 
				(packageSpecs at: index) configMethodCascadeOn: aStream last: index == packageSpecs size indent: indent + 1.
				index ~= packageSpecs size ifTrue: [ aStream tab: indent + 1 ]]].
	groupSpecs isEmpty not
		ifTrue: [
			projectSpecs isEmpty not | packageSpecs isEmpty not ifTrue: [ aStream cr ].
			aStream tab: indent; nextPutAll: 'spec '.
			groupSpecs size > 1 ifTrue: [ aStream cr; tab: indent + 1 ].
			1 to: groupSpecs size  do: [:index | 
				(groupSpecs at: index) configMethodCascadeOn: aStream last: index == groupSpecs size indent: indent + 1.
				index ~= groupSpecs size ifTrue: [ aStream tab: indent + 1 ]]].! !

!MetacelloVersionSpec methodsFor: 'printing' stamp: ''!
configMethodOn: aStream indent: indent

	self configMethodOn: aStream last: true indent: indent! !

!MetacelloVersionSpec methodsFor: 'querying' stamp: ''!
packageNamed: aString forLoad: ignored forMap: map ifAbsent: absentBlock
  "at the end of the day, I don't the forLoad arg is important ... 
   it just ends up triggering an error ... when during a real load, you would 
   not get error. After a decent period of mourning we should just scrub this 
   arg from system"

  | importSpec |
  ^ map
    at: aString
    ifAbsent: [ 
      (self importArray notNil or: [ self import notNil ])
        ifTrue: [ 
          "expect the 'missing' name to be satisfied within context of imported project"
          importArray
            ifNotNil: [ 
              importArray
                do: [ :assoc | 
                  ((assoc value includes: aString) and: [ map includesKey: assoc key ])
                    ifTrue: [ 
                      importSpec := (map at: assoc key)
                        mergeImportLoads: {aString};
                        yourself ] ].
              importSpec ifNotNil: [ ^ importSpec ] ].
          (importSpec isNil and: [ self import notNil ])
            ifTrue: [ 
              ^ (map at: self import ifAbsent: absentBlock)
                mergeImportLoads: {aString};
                yourself ] ].
      (aString = 'default' or: [ aString = 'ALL' ])
        ifTrue: [ 
          self project groupSpec
            name: aString;
            includes: self packageNames;
            yourself ]
        ifFalse: [ absentBlock value ] ]! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
getDescription
	^description! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
project: aString copyFrom: oldSpecName with: aBlock constructor: aVersionConstructor
    aVersionConstructor projectForVersion: aString copyFrom: oldSpecName with: aBlock! !

!MetacelloVersionSpec methodsFor: 'loading' stamp: ''!
resolveToLoadableSpec: aString forLoad: forLoad forMap: map packages: packageMap
    | package |
    package := self
        packageNamed: aString
        forLoad: forLoad
        forMap: map
        ifAbsent: [ ^ self error: 'Name not found: ' , aString ].
    packageMap at: package name put: package.
    ^ {package}! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
blessing

	blessing == nil 
		ifTrue: [
			^self project valueHolderSpec
				value: self project defaultBlessing;
				yourself].
	^ blessing! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
author

	author == nil 
		ifTrue: [
			^self project valueHolderSpec
				value: '';
				yourself].
	^ author! !

!MetacelloVersionSpec methodsFor: 'printing' stamp: ''!
configMethodBasicOn: aStream last: last indent: indent
    | values lastIndex lastBlock |
    last
        ifTrue: [ 
            "need to calculate last statement with a value"
            values := {(self getBlessing).
            (self getDescription).
            (self getPreLoadDoIt).
            (self getPostLoadDoIt).
            (self getAuthor).
            (self getTimestamp)}.
            1 to: values size do: [ :index | 
                (values at: index) ~~ nil
                    ifTrue: [ lastIndex := index ] ].
            lastBlock := [ :arg | arg = lastIndex ] ]
        ifFalse: [ lastBlock := [ :arg | false ] ].
    self
        configMethodValueOn: aStream
        for: self getBlessing
        selector: 'blessing:'
        last: (lastBlock value: 1)
        indent: indent.
    self
        configMethodValueOn: aStream
        for: self getDescription
        selector: 'description:'
        last: (lastBlock value: 2)
        indent: indent.
    self
        configMethodValueOn: aStream
        for: self getPreLoadDoIt
        selector: 'preLoadDoIt:'
        last: (lastBlock value: 3)
        indent: indent.
    self
        configMethodValueOn: aStream
        for: self getPostLoadDoIt
        selector: 'postLoadDoIt:'
        last: (lastBlock value: 4)
        indent: indent.
    self
        configMethodValueOn: aStream
        for: self getAuthor
        selector: 'author:'
        last: (lastBlock value: 5)
        indent: indent.
    self
        configMethodValueOn: aStream
        for: self getTimestamp
        selector: 'timestamp:'
        last: (lastBlock value: 6)
        indent: indent! !

!MetacelloVersionSpec methodsFor: 'querying' stamp: ''!
postLoadDoIt

	^postLoadDoIt! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
project: aString constructor: aVersionConstructor
    aVersionConstructor projectForVersion: aString! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
import: aString
  importName := aString! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
group: aString with: aStringOrCollection constructor: aVersionConstructor
    aVersionConstructor groupForVersion: aString with: aStringOrCollection! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
removeGroup: aString constructor: aVersionConstructor
    aVersionConstructor removeGroupForVersion: aString! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
author: anObject

	anObject setAuthorInMetacelloVersion: self! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
repository: anObject constructor: aVersionConstructor
    aVersionConstructor repositoryForVersion: anObject! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
setBlessing: anObject
	blessing := anObject! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
setDescription: anObject
	description := anObject! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
setTimestamp: anObject
	timestamp := anObject! !

!MetacelloVersionSpec methodsFor: 'querying' stamp: ''!
packageNamed: aString forMap: map ifAbsent: absentBlock
    "import: only allowed to be used with baseline project specs"

    ^ self
        packageNamed: aString
        forLoad: true
        forMap: map
        ifAbsent: absentBlock! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
import
    ^ importName! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
packagesSpec

	^self packages! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
versionString: anObject constructor: aVersionConstructor
    aVersionConstructor versionStringForVersion: anObject! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
setAuthor: anObject
	author := anObject! !

!MetacelloVersionSpec methodsFor: 'merging' stamp: ''!
mergeSpec: anotherSpec
    | newSpec map anotherPackages |
    newSpec := super mergeSpec: anotherSpec.
    map := anotherSpec mergeMap.
    (anotherPackages := map at: #'packageList') isEmpty not
        ifTrue: [ 
            newSpec
                packages:
                    (self packages isEmpty
                        ifTrue: [ anotherPackages ]
                        ifFalse: [ self packages mergeSpec: anotherPackages ]) ].
    ^ newSpec! !

!MetacelloVersionSpec methodsFor: 'querying' stamp: ''!
difference: otherVersionSpec
    "Return a dictionary of additions, removals and modifications"

    | report myProjectSpecs otherProjectSpecs |
    report := MetacelloVersionDiffReport new.
    myProjectSpecs := Dictionary new.
    self
        projectDo: [ :projectSpec | myProjectSpecs at: projectSpec name put: projectSpec ]
        packageDo: [ :ignored |  ]
        groupDo: [ :ignored |  ].
    otherProjectSpecs := Dictionary new.
    otherVersionSpec
        projectDo: [ :projectSpec | otherProjectSpecs at: projectSpec name put: projectSpec ]
        packageDo: [ :ignored |  ]
        groupDo: [ :ignored |  ].
    myProjectSpecs
        valuesDo: [ :myProjectSpec | 
            | otherProjectSpec |
            otherProjectSpec := otherProjectSpecs at: myProjectSpec name ifAbsent: [  ].
            otherProjectSpec == nil
                ifTrue: [ 
                    report removals
                        at: myProjectSpec name
                        put:
                            {(myProjectSpec versionString).
                            ''} ]
                ifFalse: [ 
                    myProjectSpec versionString = otherProjectSpec versionString
                        ifFalse: [ 
                            report modifications
                                at: myProjectSpec name
                                put:
                                    {(myProjectSpec versionString).
                                    (otherProjectSpec versionString)} ] ] ].
    otherProjectSpecs
        valuesDo: [ :otherProjectSpec | 
            (myProjectSpecs at: otherProjectSpec name ifAbsent: [  ]) == nil
                ifTrue: [ 
                    report additions
                        at: otherProjectSpec name
                        put:
                            {''.
                            (otherProjectSpec versionString)} ] ].
    ^ report! !

!MetacelloVersionSpec methodsFor: 'construction' stamp: ''!
project: aString with: aBlockOrString constructor: aVersionConstructor
    aVersionConstructor projectForVersion: aString with: aBlockOrString! !

!MetacelloVersionSpec methodsFor: 'accessing' stamp: ''!
getPostLoadDoIt
	^postLoadDoIt! !

!MetacelloVersionSpecTestCase methodsFor: 'tests' stamp: ''!
testVersionSpec
	| version |
	version := self versionSpec
		blessing: #baseline;
		versionString: '1.0';
		description: 'A description';
		author: 'dkh';
		timestamp: '1/24/2012 09:59';
		preLoadDoIt: #preLoadDoIt;
		postLoadDoIt: #postLoadDoIt;
		yourself.
	self assert: version blessing value equals: #baseline.
	self assert: version versionString value equals: '1.0'.
	self assert: version description value equals: 'A description'.
	self assert: version author value equals: 'dkh'.
	self assert: version timestamp value equals: '1/24/2012 09:59'.
	self assert: version preLoadDoIt value identicalTo: #preLoadDoIt.
	self assert: version postLoadDoIt value identicalTo: #postLoadDoIt.
	self should: [ version preLoadDoIt: '' ] raise: Error.
	self should: [ version postLoadDoIt: '' ] raise: Error! !

!MetacelloVersionSpecTestCase methodsFor: 'tests' stamp: ''!
testVersionSpecCreateVersion
	| spec version |
	spec := self versionSpec
		blessing: #baseline;
		versionString: '1.0';
		description: 'A description';
		author: 'dkh';
		timestamp: '1/24/2012 09:59';
		preLoadDoIt: #preLoadDoIt;
		postLoadDoIt: #postLoadDoIt;
		yourself.
	version := spec createVersion.
	self assert: version class identicalTo: spec versionClass.
	self assert: version spec identicalTo: spec.
	self assert: version versionNumber asString equals: '1.0'.
	self assert: version blessing equals: #baseline.
	self assert: version versionString equals: '1.0'.
	self assert: version description equals: 'A description'.
	self assert: version author equals: 'dkh'.
	self assert: version timestamp equals: '1/24/2012 09:59'! !

!MetacelloVersionSpecTestCase methodsFor: 'tests' stamp: ''!
testVersionMergeSpec
	| versionA versionB version |
	versionA := self versionSpec
		blessing: #baseline;
		versionString: '1.0';
		description: 'A description';
		author: 'dkh';
		timestamp: '1/24/2012 09:59';
		preLoadDoIt: #preLoadDoIt;
		postLoadDoIt: #postLoadDoIt;
		yourself.
	versionB := self versionSpec
		blessing: #release;
		versionString: '1.1';
		description: 'A FULL description';
		author: 'DaleHenrichs';
		timestamp: '1/24/2012 10:22';
		preLoadDoIt: #preLoadDoItB;
		postLoadDoIt: #postLoadDoItB;
		yourself.
	version := versionA mergeSpec: versionB.
	self assert: version blessing value equals: #release.
	self assert: version versionString value equals: '1.1'.
	self assert: version description value equals: 'A FULL description'.
	self assert: version author value equals: 'DaleHenrichs'.
	self assert: version timestamp value equals: '1/24/2012 10:22'.
	self assert: version preLoadDoIt value identicalTo: #preLoadDoItB.
	self assert: version postLoadDoIt value identicalTo: #postLoadDoItB! !

!MetacelloVersionValidator methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
recurse
	recurse == nil ifTrue: [ recurse := false ].
	^ recurse! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
recordValidationCriticalWarning: aString versionString: versionString callSite: callSite reasonCode: aSymbol
	<haltOrBreakpointForTesting>
	"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: ''!
visited: anIdentitySet

	visited := anIdentitySet! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
debug: aCollection
	"Any combination of: #error, #criticalWarning, #warning"

	debug := aCollection! !

!MetacelloVersionValidator methodsFor: 'private' stamp: ''!
validateProjectCreationFrom: aConfigurationClass onError: aBlock
    [ ^ aConfigurationClass project ]
        on: Error , MetacelloValidationNotification , MetacelloErrorInProjectConstructionNotification
        do: [ :ex | 
            (ex isKindOf: MetacelloValidationNotification)
                ifTrue: [ 
                    self validationReport add: ex issue.
                    ex resume ].
            (ex isKindOf: MetacelloErrorInProjectConstructionNotification)
                ifTrue: [ 
                    self
                        recordValidationError:
                            'Error creating version: ' , ex versionString , ' error: ' , ex exception description
                                , ' to reproduce evalutate the following: ''[' , self configurationClass name asString
                                ,
                                    ' project ] on: MetacelloErrorInProjectConstructionNotification do: [:ex | ex resume: true ]'''
                        callSite: #'validateProjectCreationFrom:onError:'
                        reasonCode: #'versionCreationError'.
                    ex resume: false ].
            ^ aBlock value: ex ]! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
visited

	^ visited ifNil: [ visited := IdentitySet new ]! !

!MetacelloVersionValidator methodsFor: 'private' stamp: ''!
criticalWarningReasonCodes
    ^ #(#'packageNameMismatch' #'projectClassNameFileMismatch' #'duplicateVersionDefinitions')! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
validationReport: anObject
	validationReport := anObject! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
configurationClass
	^ configurationClass! !

!MetacelloVersionValidator methodsFor: 'private' stamp: ''!
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: ''!
errorReasonCodes
    ^ #(#'duplicateNames' #'shadowedNames' #'invalidDoItSelector' #'invalidVersionString' #'missingVersionImport' #'projectCreationError' #'noVersionsDefined' #'cannotResolveVersion' #'incompleteProjectSpec' #'incorrectVersionString' #'versionCompositionError' #'versionCreationError')! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
recurse: anObject
	recurse := anObject! !

!MetacelloVersionValidator methodsFor: 'validation' stamp: ''!
validateBaselineOf
  self validatePragmas.
  ^ self validateBaselineProject! !

!MetacelloVersionValidator methodsFor: 'private' stamp: ''!
validateBaselineProject
  | 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: #'validateBaselineProject'
        reasonCode: #'projectCreationError'.
      ^ self validationReport ].
  ^ self validateBaselineProject: project! !

!MetacelloVersionValidator methodsFor: 'validation' stamp: ''!
validateBaselineProject: project
  | version spec |
  (self visited includes: project configuration class)
    ifTrue: [ ^ self validationReport ].
  self visited add: project configuration class.
  version := project version.
  spec := version spec.
  [ self validateBaselineVersionSpec: spec ]
    on: Error
    do: [ :ex | 
      self
        recordValidationError:
          'Error composing version ' , version versionString printString , ': '
            , ex description
        versionString: version versionString
        callSite: #'validateBaselineProject:'
        reasonCode: #'versionCompositionError' ].
  ^ self validationReport! !

!MetacelloVersionValidator methodsFor: 'validation' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
recordValidationCriticalWarning: aString callSite: callSite reasonCode: aSymbol

	^self recordValidationCriticalWarning: aString versionString: nil callSite: callSite reasonCode: aSymbol! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
exludededValidations

	exludededValidations == nil ifTrue: [ exludededValidations := self extractExcludedValidations ].
	^exludededValidations! !

!MetacelloVersionValidator methodsFor: 'pragma extraction' stamp: ''!
extractExcludedValidations

	| exclusionDict |
	exclusionDict := Dictionary new.
	(Pragma 
		allNamed: #excludedValidationIssues:
		in: self configurationClass) do: [:pragma | | exclusions |
			exclusions := pragma argumentAt: 1.
			1 to: exclusions size by: 2 do: [:index |
			exclusionDict 
				at: (exclusions at: index) 
				put: (exclusions at: index + 1) ]].
	^exclusionDict! !

!MetacelloVersionValidator methodsFor: 'private' stamp: ''!
validateVersionSpec: versionSpec

	self subclassResponsibility! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
recordValidationError: aString callSite: callSite reasonCode: aSymbol

	^self recordValidationError: aString versionString: nil callSite: callSite reasonCode: aSymbol! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
recordValidationWarning: aString versionString: versionString callSite: callSite reasonCode: aSymbol
	<haltOrBreakpointForTesting>
	"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: 'private' stamp: ''!
warningReasonCodes
	^ #(#onlyBaselineVersion )! !

!MetacelloVersionValidator methodsFor: 'private' stamp: ''!
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: 'validation' stamp: ''!
validate
	"Issue 5: 
		[]no shadowing of names across project/package/group boundaries
	 Issue 6: 
		[]package version supplied for each package
		[]no released (stable/bleedingEdge) versions (only development version)
		package spec used instead of project spec in baseline (ConfigurationOfPharo-DaleHenrichs.50)
	Issue 20:
		[]pre and post load doits must be symbols, not blocks
	Others:
		[]symbolic versions can be resolved.
		[]Ensure that versions are Strings and symbolic versions are symbols.
	 	[]Ensure that imported versions are defined."

	self validatePragmas.
	^self validateProject! !

!MetacelloVersionValidator methodsFor: 'private' stamp: ''!
validateBaselineVersionSpec: versionSpec

	self subclassResponsibility! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
debug

	debug == nil ifTrue: [ debug := #() ].
	^ debug! !

!MetacelloVersionValidator methodsFor: 'private' stamp: ''!
validateDoIts: aSpec versionString: versionString errorMessage: errorMessage
	| ar |
	ar := {
		#preLoadDoIt.	'preLoadDoIt selector for '.
		#postLoadDoIt.	'postLoadDoIt selector for '.
	}.
	1 to: ar size by: 2 do: [ :i | 
		| selector |
		selector := (aSpec perform: (ar at: i)) value.
		selector ~~ nil
			ifTrue: [ 
				selector isSymbol
					ifFalse: [ 
						self
							recordValidationError: (ar at: i + 1) , errorMessage , ' is not a symbol'
							versionString: versionString
							callSite: #validateDoIts:versionString:errorMessage:
							reasonCode: #invalidDoItSelector ] ] ]! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
configurationClass: anObject
	configurationClass := anObject! !

!MetacelloVersionValidator methodsFor: 'private' stamp: ''!
validateVersionSpecForSymbolicVersion: versionSpec symbolicVersion: symbolicVersionString

	self subclassResponsibility! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
validationReport
	
	validationReport == nil ifTrue: [ validationReport := OrderedCollection new ].
	^ validationReport! !

!MetacelloVersionValidator methodsFor: 'accessing' stamp: ''!
recordValidationError: aString versionString: versionString callSite: callSite reasonCode: aSymbol
	<haltOrBreakpointForTesting>
	"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: ''!
recordValidationWarning: aString callSite: callSite reasonCode: aSymbol

				
	^self recordValidationWarning: aString versionString: nil callSite: callSite reasonCode: aSymbol! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateBaseline: baselineClass
  ^ self validateBaseline: baselineClass debug: #() recurse: false! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateConfiguration: configurationClass

	^self validateConfiguration: configurationClass debug: #() recurse: false! !

!MetacelloVersionValidator class methodsFor: 'private' stamp: ''!
populateReasonCodeDescriptions
    "update MetacelloMCVersionValidator class comment to include any changes to descriptions"

    | dict |
    dict := Dictionary new.
    dict
        at: #'onlyBaselineVersion'
        put: 'one or more baseline versions have been defined, but no non-baseline versions are defined.'.
    dict
        at: #'duplicateVersionDefinitions' put: 'there are multiple pragma methods specifying the same version.';
        at: #'packageNameMismatch' put: 'the name in the packageSpec does not match the name of the mcz file.';
        at: #'projectClassNameFileMismatch'
            put: 'the class name of the configuration does not match the mcz file containing the configuration.';
        at: #'cannotResolveVersion'
            put: 'the version (project reference or symbolic version) was not found in the specified configuration.'.
    dict
        at: #'duplicateNames'
            put: 'multiple independent definitions for an entity with same name (project, package, or group).';
        at: #'incompleteProjectSpec' put: 'missing required fields in project reference (repository, className).';
        at: #'incorrectVersionString' put: 'the version declared in pragma doesn''t match version in versionSpec.';
        at: #'invalidDoItSelector' put: 'doit select must be a Symbol.';
        at: #'invalidVersionString' put: 'versionString must be a String.';
        at: #'missingVersionImport' put: 'version specified in import pragma not defined in configuration.';
        at: #'noVersionsDefined'
            put: 'no usable baseline or version defined in configuration ... configuration cannot be loaded.';
        at: #'projectCreationError' put: 'error occured while resolving project reference.';
        at: #'versionCreationError'
            put:
                'error occured while resolving version specification, error will be thrown if an attempt is made to use the version.';
        at: #'shadowedNames' put: 'name duplication between packages and projects.';
        at: #'versionCompositionError' put: 'error while creating versionSpec from pragmas.'.
    ^ dict! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
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: ''!
validateConfiguration: configurationClass debug: debugList recurse: aBool
	^ ((self new)
		configurationClass: configurationClass;
		debug: debugList;
		recurse: aBool;
		yourself) validate! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
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: ''!
validateProject: aMetacelloProject version: versionString debug: debugList

	^self validateProject: aMetacelloProject version: versionString debug: debugList recurse: false! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateProject: aMetacelloProject recurse: aBool

	^self validateProject: aMetacelloProject debug: #() recurse: aBool! !

!MetacelloVersionValidator class methodsFor: 'accessing' stamp: ''!
reasonCodeDescriptions

	reasonCodeDescriptions ifNil: [ reasonCodeDescriptions := self populateReasonCodeDescriptions ].
	^reasonCodeDescriptions! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateBaseline: baselineClass recurse: aBool
  ^ self validateBaseline: baselineClass debug: #() recurse: aBool! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateBaseline: baselineClass debug: debugList recurse: aBool
  ^ (self new
    configurationClass: baselineClass;
    debug: debugList;
    recurse: aBool;
    yourself) validateBaselineOf! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateProject: aMetacelloProject

	^self validateProject: aMetacelloProject debug: #() recurse: false! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateProject: aMetacelloProject version: versionString debug: debugList recurse: aBool visited: visitied

	^(self new
		configurationClass: aMetacelloProject configuration class;
		debug: debugList;
		recurse: aBool;
		visited: visitied;
		yourself) validateProject: aMetacelloProject version: versionString! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateProject: aMetacelloProject version: versionString

	^self validateProject: aMetacelloProject version: versionString debug: #() recurse: false! !

!MetacelloVersionValidator class methodsFor: 'accessing' stamp: ''!
descriptionForReasonCode: reasonCode
	^ self reasonCodeDescriptions at: reasonCode ifAbsent: [ self error: 'Unknown reasonCode: ' , reasonCode printString ]! !

!MetacelloVersionValidator class methodsFor: 'instance creation' stamp: ''!
validateConfiguration: configurationClass recurse: aBool

	^self validateConfiguration: configurationClass debug: #() recurse: aBool! !

!MetacelloVisitedPackages methodsFor: 'initialization' stamp: ''!
initialize

	groups := Set new.
	packages := Set new.
	projects := Set new.! !

!MetacelloVisitedPackages methodsFor: 'visiting' stamp: ''!
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: ''!
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! !

!Metaclass commentStamp: ''!
My instances add instance-specific behavior to various class-describing objects in the system. This typically includes messages for initializing class variables and instance creation messages particular to a class. There is only one instance of a particular Metaclass, namely the class which is being described. A Metaclass shares the class variables of its instance.
	
[Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus,
	Integer superclass == Number, and
	Integer class superclass == Number class.
However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus,
	Object superclass == nil, and
	Object class superclass == Class.!
!Metaclass methodsFor: 'class hierarchy' stamp: ''!
addSubclass: aClass
	"Do nothing."! !

!Metaclass methodsFor: 'accessing - parallel hierarchy - deprecated' stamp: ''!
hasClassSide
	^ false! !

!Metaclass methodsFor: 'pool variables' stamp: ''!
classPool
	"Answer the dictionary of class variables."

	^self instanceSide classPool! !

!Metaclass methodsFor: 'instance creation' stamp: ''!
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: 'accessing' stamp: ''!
soleInstance
	"The receiver has only one instance. Answer it."

	^thisClass! !

!Metaclass methodsFor: '*CodeExport' stamp: ''!
nonTrivial 
	"Answer whether the receiver has any methods or instance variables."

	^ self instVarNames notEmpty or: [self hasMethods or: [self hasTraitComposition]]! !

!Metaclass methodsFor: '*CodeExport' stamp: ''!
fileOutOn: aFileStream initializing: aBool

	super fileOutOn: aFileStream.
	(aBool and:[ self includesSelector: #initialize ]) ifTrue: [
		aFileStream cr.
		aFileStream cr.
		aFileStream nextChunkPut: thisClass name , ' initialize'.
		aFileStream cr ]! !

!Metaclass methodsFor: '*CodeExport' stamp: ''!
fileOutInitializerOn: aStream
	(self includesSelector: #initialize) ifTrue: 
		[aStream cr.
		aStream nextChunkPut: self soleInstance name , ' initialize'].! !

!Metaclass methodsFor: '*STON-Core' stamp: ''!
stonName
	^ #Class! !

!Metaclass methodsFor: 'accessing' stamp: ''!
environment

	^thisClass environment! !

!Metaclass methodsFor: 'testing' stamp: ''!
hasBindingThatBeginsWith: aString
	"class and pool vars are accessible from the class side the same as the instance side"
	^self instanceSide hasBindingThatBeginsWith: aString! !

!Metaclass methodsFor: '*TraitsV2' stamp: ''!
setTraitComposition: aTraitCompositionOrArray
	
	^ self trait: aTraitCompositionOrArray slots: self slots.! !

!Metaclass methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitMetaclass: self
! !

!Metaclass methodsFor: 'testing' stamp: ''!
isSelfEvaluating
	^self isObsolete not! !

!Metaclass methodsFor: 'compiling' stamp: ''!
wantsChangeSetLogging
	"Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself."

	^ self instanceSide wantsChangeSetLogging! !

!Metaclass methodsFor: '*Shift-ClassInstaller' stamp: ''!
instanceVariableNames: instVarString 
	
	^ self slots: instVarString asSlotCollection ! !

!Metaclass methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asFullRingDefinition

	^ self instanceSide asFullRingDefinition classSide! !

!Metaclass methodsFor: '*TraitsV2' stamp: ''!
trait: aTraitCompositionOrArray
	
	^ self trait: aTraitCompositionOrArray slots: #().! !

!Metaclass methodsFor: '*Reflectivity' stamp: ''!
nonAnonymousClass

	^ self! !

!Metaclass methodsFor: 'instance creation' stamp: ''!
newAnonymousSubclass

	^self instanceSide newAnonymousSubclass class! !

!Metaclass methodsFor: '*Debugger-Model' stamp: ''!
canonicalArgumentName

	^ 'aClass'.! !

!Metaclass methodsFor: 'instance variables' stamp: ''!
addInstVarNamed: aString 
	"Add the argument, aString, as one of the receiver's instance variables."

	| fullString |
	fullString := String streamContents: [:strm |
		self instVarNames do: [:aString2 | strm nextPutAll: aString2; space].
		strm nextPutAll: aString].
	self instanceVariableNames: fullString! !

!Metaclass methodsFor: 'testing' stamp: ''!
isClass

	^ true! !

!Metaclass methodsFor: 'copying' stamp: ''!
postCopy
	"Don't share the reference to the sole instance."

	super postCopy.
	self classLayout: (layout copy host: self).
	thisClass := nil.! !

!Metaclass methodsFor: '*OpalCompiler-Core' stamp: ''!
compiler
	"The compiler is defined on instance-side to be able to customize it for *one* metaclass"
	^ self instanceSide classSideCompiler! !

!Metaclass methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asRingDefinition

	^ self instanceSide asRingDefinition classSide! !

!Metaclass methodsFor: 'compiling' stamp: ''!
binding
	"return an association that can be used as the binding
	 To share it between methods, reuse an existing one if possible"
	^self methodDict 
		ifEmpty: [LiteralVariable key: nil value: self]
		ifNotEmpty: [:dict | dict anyOne classBinding]! !

!Metaclass methodsFor: '*TraitsV2' stamp: ''!
uses: aTraitCompositionOrArray slots: slotArray
	| theClass |
	theClass := self instanceSide.
	
	theClass := theClass classInstaller
		update: theClass
		to: [ :builder | 
			builder
				fillFor: theClass;
				classTraitComposition: aTraitCompositionOrArray asTraitComposition;				
				classSlots: slotArray ].
	^ theClass classSide! !

!Metaclass methodsFor: 'testing' stamp: ''!
isObsolete
	"Return true if the receiver is obsolete"
	^self soleInstance isNil "Either no thisClass"
		or:[self soleInstance classSide ~~ self "or I am not the class of thisClass"
			or:[self soleInstance isObsolete]] "or my instance is obsolete"! !

!Metaclass methodsFor: '*Calypso-SystemQueries' stamp: ''!
visibleMethods

	^ self methods! !

!Metaclass methodsFor: 'fileout' stamp: ''!
expandedDefinitionStringFor: aPrinter

	^ aPrinter expandedMetaclassDefinitionString! !

!Metaclass methodsFor: '*TraitsV2' stamp: ''!
initializeBasicMethods 
	
	"Nothing to do in the metaclass"! !

!Metaclass methodsFor: 'accessing - parallel hierarchy' stamp: ''!
classSide
	"Return the metaclass of the couple class/metaclass. Useful to avoid explicit test."
	"Point classSide >>> Point class"
	"Point class classSide >>> Point class"
	
	^ self! !

!Metaclass methodsFor: 'initialize-release' stamp: ''!
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: 'accessing - instances and variables' stamp: ''!
hasClassVarNamed: aString

	^self instanceSide 
		ifNil: [ false ]
		ifNotNil: [ :class | class hasClassVarNamed: aString ]! !

!Metaclass methodsFor: 'compiling' stamp: ''!
bindingOf: varName

	^self instanceSide classBindingOf: varName! !

!Metaclass methodsFor: 'class hierarchy' stamp: ''!
obsoleteSubclasses
	"Answer the receiver's subclasses."

	self isMetaclassOfClassOrNil ifTrue: [ ^ #() ].
	^ self instanceSide obsoleteSubclasses collect: [ :aSubclass | aSubclass classSide ]! !

!Metaclass methodsFor: 'class hierarchy' stamp: ''!
isMetaclassOfClassOrNil
	
	^ self instanceSide 
		ifNil: [ true ] 
		ifNotNil: [ :nonMetaClass | nonMetaClass == Class ]! !

!Metaclass methodsFor: 'compiling' stamp: ''!
acceptsLoggingOfCompilation
	"Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set.  The metaclass follows the rule of the class itself."

	^ self instanceSide acceptsLoggingOfCompilation! !

!Metaclass methodsFor: 'testing' stamp: ''!
isUsed
	"Metaclasses are used by default"
	^ true! !

!Metaclass methodsFor: 'class hierarchy' stamp: ''!
subclasses
	"Answer the receiver's subclasses."
	
	self isMetaclassOfClassOrNil ifTrue: [ ^ #() ].
	^ self instanceSide subclasses collect: [ :aSubclass | aSubclass classSide ].! !

!Metaclass methodsFor: 'class hierarchy' stamp: ''!
subclassesDo: aBlock
	"Evaluate aBlock for each of the receiver's immediate subclasses."
	
	self isMetaclassOfClassOrNil ifTrue: [ ^ self ].
	self instanceSide subclasses do: [ :each | aBlock value: each classSide ]! !

!Metaclass methodsFor: '*OpalCompiler-Core' stamp: ''!
compilerClass
	"The compiler class is defined on instance-side to be able to customize it for *one* metaclass"
	^ self instanceSide classSideCompilerClass! !

!Metaclass methodsFor: 'testing' stamp: ''!
isAnonymous
	^self soleInstance isAnonymous! !

!Metaclass methodsFor: '*TraitsV2' stamp: ''!
trait: aTraitCompositionOrArray slots: slotArray
	| theClass |
	theClass := self instanceSide.
	
	theClass := theClass classInstaller
		update: theClass
		to: [ :builder | 
			builder
				fillFor: theClass;
				classTraitComposition: aTraitCompositionOrArray asTraitComposition;				
				classSlots: slotArray ].
	^ theClass classSide! !

!Metaclass methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter
		writeObject: self 
		listSingleton: self instanceSide name asSymbol! !

!Metaclass methodsFor: '*Manifest-Core' stamp: ''!
criticTheNonMetaclassClass

	^self instanceSide! !

!Metaclass methodsFor: 'fileout' stamp: ''!
definitionStringFor: aConfiguredPrinter

	^ aConfiguredPrinter metaclassDefinitionString! !

!Metaclass methodsFor: '*TraitsV2' stamp: ''!
uses: aTraitCompositionOrArray
	"This method will be deprecated better use trait."
	
	self trait: aTraitCompositionOrArray slots: #().! !

!Metaclass methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ RGMetaclass named: self name parent: anRGEnvironment.
! !

!Metaclass methodsFor: 'initialization' stamp: ''!
slots: slotCollection 

	| theClass |
	theClass := self instanceSide.
		
	theClass := theClass classInstaller update: theClass to: [ :builder |
		builder
			fillFor: theClass;
			classSlots: slotCollection ].
	^ theClass classSide! !

!Metaclass methodsFor: 'testing' stamp: ''!
isReferenced
	"Metaclasses are never directly referenced in code"
	^false! !

!Metaclass methodsFor: 'instance variables' stamp: ''!
removeSlot: aClassSlot

	^self instanceSide removeClassSlot: aClassSlot! !

!Metaclass methodsFor: 'class hierarchy' stamp: ''!
addObsoleteSubclass: aClass
	"Do nothing."! !

!Metaclass methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier

	"Return self.  Must be created, not copied.  Do not record me."! !

!Metaclass methodsFor: 'compiling' stamp: ''!
possibleVariablesFor: misspelled continuedFrom: oldResults

	^ self instanceSide possibleVariablesFor: misspelled continuedFrom: oldResults! !

!Metaclass methodsFor: 'accessing - instances and variables' stamp: ''!
classVarNames
	"Answer the names of the class variables defined in the receiver's instance."
	
	^self instanceSide 
		ifNil: [ #() ]
		ifNotNil: [ :class | class classVarNames ]! !

!Metaclass methodsFor: '*Epicea-Ring' stamp: ''!
asEpiceaRingDefinition

	| baseClassDefinition |
	baseClassDefinition := self instanceSide asEpiceaRingDefinition.

	^ baseClassDefinition withMetaclass classSide
		  traitCompositionSource: self classSide traitCompositionString;
		  definitionSource: self classSide definitionString;
		  addInstanceVariables: self classSide instVarNames;
		  yourself! !

!Metaclass methodsFor: 'accessing' stamp: ''!
category
	^ self instanceSide category! !

!Metaclass methodsFor: 'class variables' stamp: ''!
classVariables
	"Answer the class variables defined in the receiver's instance."

	^ self instanceSide
		ifNil: [ #() ]
		ifNotNil: [ :class | class classVariables ]! !

!Metaclass methodsFor: '*TraitsV2' stamp: ''!
baseLocalMethods
	^ self instanceSide methodDict! !

!Metaclass methodsFor: 'instance variables' stamp: ''!
addSlot: aClassSlot

	^self instanceSide addClassSlot: aClassSlot! !

!Metaclass methodsFor: 'testing' stamp: ''!
isMeta
	^ true! !

!Metaclass methodsFor: 'accessing' stamp: ''!
name

	"Answer a String that is the name of the receiver, either 'Metaclass' or 
	the name of the receiver's class followed by ' class'."

	^ thisClass ifNil: [ 'a Metaclass' ] ifNotNil: [ thisClass name asString , ' class' ]! !

!Metaclass methodsFor: 'compiling' stamp: ''!
innerBindingOf: varName

	^self instanceSide innerBindingOf: varName! !

!Metaclass methodsFor: 'accessing - parallel hierarchy' stamp: ''!
instanceSide
	"Return the class of the couple class/metaclass. Useful to avoid explicit test."
	"Point instanceSide >>> Point"
	"Point class instanceSide >>> Point"
	
	^ self soleInstance! !

!Metaclass methodsFor: 'class hierarchy' stamp: ''!
removeSubclass: aClass
	"Do nothing."! !

!Metaclass methodsFor: 'pool variables' stamp: ''!
sharedPoolNames
	^#()! !

!Metaclass methodsFor: '*CodeExport' stamp: ''!
fileOutOn: aFileStream

	^ self fileOutOn: aFileStream initializing: true! !

!Metaclass methodsFor: 'compiling' stamp: ''!
sourceCodeTemplate
	"Answer an expression to be edited and evaluated in order to define 
	methods in this class or trait."

	^ 'methodSelectorAndArgumentNames
	"comment stating purpose of class-side method"
	"scope: class-variables  &  class-instance-variables"	
			
	| temporary variable names |
	statements'! !

!Metaclass methodsFor: '*TraitsV2' stamp: ''!
trait: aTraitCompositionOrArray instanceVariableNames: instVarString 
	
	^ self trait: aTraitCompositionOrArray slots: instVarString asSlotCollection! !

!Metaclass methodsFor: '*FluidClassBuilder' stamp: ''!
<< aMetaclass

	"Return a builder of class FluidClassSideClassBuilder. 
	To get a class, this builder should be sent build. This way we can manipulate and test class definition without be forced to get them added to the environment."

	self assert: self soleInstance = aMetaclass soleInstance superclass.

	^ FluidClassSideClassBuilder new
		  superclassToBuild: self soleInstance;
		  nameToBuild: aMetaclass soleInstance name;
		  fillInstanceSideFromClass: aMetaclass soleInstance;
		  yourself! !

!Metaclass methodsFor: '*TraitsV2' stamp: ''!
uses: aTraitCompositionOrArray instanceVariableNames: instVarString 
	"This method will be deprecated better use trait:slots: or trait:instanceVariableNames:"
	^ self uses: aTraitCompositionOrArray slots: instVarString asSlotCollection! !

!Metaclass class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	| theClassName theClass theMetaclass |
	theClassName := stonReader parseListSingleton.
	theClass := self environment at: theClassName.
	theMetaclass := theClass class.
	^ theMetaclass! !

!MetaclassForTraits commentStamp: ''!
I am the metaclass used for traits.
I implement all the behavior for the classSide traits.!
!MetaclassForTraits methodsFor: 'testing' stamp: ''!
isEmpty 
	"Since we can have potential an empty array in the fluid definition (to be revisited) 
	when the trait composition is aTrait it received the message isEmpty and would break
	traitComposition 
		ifNotNil: [ :t | t isEmpty ifFalse: [shiftClassBuilder traitComposition: traitComposition ]]."
	^ false
	! !

!MetaclassForTraits methodsFor: 'testing' stamp: ''!
isTrait
	^ true! !

!MetaclassForTraits methodsFor: 'testing' stamp: ''!
isRejectedMethod: aSelector
	^ (super isRejectedMethod: aSelector)
		or: [ Trait methodDict includesKey: aSelector ]! !

!MetaclassForTraits methodsFor: '*Monticello' stamp: 'nil'!
asMCDefinition

	^MCClassTraitDefinition
		baseTraitName: self instanceSide name
		classTraitComposition: self traitCompositionString
		category: self category
			! !

!MetaclassForTraits methodsFor: '*Ring-TraitsV2Support' stamp: ''!
asRingDefinitionIn: anRGEnvironment

	^ RGMetaclassTrait named: self name parent: anRGEnvironment.
! !

!MetaclassForTraits methodsFor: 'testing' stamp: ''!
isTraitExclusion
	^ false! !

!MetaclassForTraits methodsFor: 'users' stamp: ''!
removeUser: aClass
	
	self users remove: aClass ifAbsent: [  ]! !

!MetaclassForTraits methodsFor: 'accessing' stamp: ''!
users

	^ users ifNil: [ users := IdentitySet new ]! !

!MetaclassForTraits methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream
		nextPutAll: self instanceSide name;
		nextPutAll: ' classTrait'! !

!MetaclassForTraits methodsFor: 'accessing' stamp: ''!
users: anObject
	users := anObject! !

!MetaclassForTraits methodsFor: 'testing' stamp: ''!
isTraitAlias
	^ false! !

!MetaclassForTraits methodsFor: 'converting' stamp: ''!
asTraitComposition
	^ TaClassCompositionElement for: self! !

!MetaclassForTraits methodsFor: 'composition' stamp: ''!
@ anArray
	"I return myself with an aliased method. Check TaAbstractComposition >> #@ for more details"
	^ self asTraitComposition @ anArray! !

!MetaclassForTraits methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary
	"I extend the behavior in TraitedMetaclass propagating the changes to my users"
	super rebuildMethodDictionary ifFalse: [ ^ false].
	self users do: [ :e | e rebuildMethodDictionary ].
	^ true! !

!MetaclassForTraits methodsFor: 'operations' stamp: ''!
- anArray
	"I return myself with a removed method. Check TaAbstractComposition >> #- for more details"

	^ self asTraitComposition - anArray! !

!MetaclassForTraits methodsFor: '*Ring-TraitsV2Support' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGMetaclassTrait named: self name parent: anRGEnvironment]
! !

!MetaclassForTraits methodsFor: 'accessing' stamp: ''!
traitUsers
	^ self users! !

!MetaclassForTraits methodsFor: 'testing' stamp: ''!
isClassTrait
	
	^ true! !

!MetaclassForTraits methodsFor: '*Debugger-Model' stamp: ''!
canonicalArgumentName

	^ 'aTrait'.! !

!MetaclassForTraits methodsFor: '*Epicea' stamp: ''!
asEpiceaRingDefinition

	| baseClassDefinition |
	baseClassDefinition  := self instanceSide asEpiceaRingDefinition.

	^ baseClassDefinition withMetaclass classSide 
		traitCompositionSource: self classSide traitCompositionString;
		definitionSource: self classSide definitionString;
		yourself! !

!MetaclassForTraits methodsFor: '*Ring-TraitsV2Support' stamp: ''!
asRGDefinition

	^ self instanceSide asRGDefinition theMetaClass! !

!MetaclassForTraits methodsFor: 'accessing' stamp: ''!
name

	^ thisClass ifNil: [ 'a MetaclassForTraits' ] ifNotNil: [ thisClass name asString , ' classTrait' ]! !

!MetaclassForTraits methodsFor: 'testing' stamp: ''!
isBaseTrait
	
	^ false! !

!MetaclassForTraits methodsFor: 'organization updating' stamp: ''!
notifyOfRecategorizedSelector: selector from: oldCategory to: newCategory
	"When there is a recategorization of a selector, I propagate the changes to my users"
	super notifyOfRecategorizedSelector: selector from: oldCategory to: newCategory.
	self traitUsers do: [ :e | e recategorizeSelector: selector from: oldCategory to: newCategory ].! !

!MetaclassForTraits methodsFor: 'users' stamp: ''!
addUser: aClass 
	
	self users add: aClass! !

!MetaclassForTraits methodsFor: '*Renraku' stamp: ''!
reBanName

	^ self name, ' (Trait)'! !

!MetaclassForTraits methodsFor: 'fileout' stamp: ''!
expandedDefinitionStringFor: aPrinter

	^ aPrinter expandedTraitClassDefinitionString! !

!MetaclassForTraits methodsFor: 'operations' stamp: ''!
+ anotherTrait
	"I return my self in a sequence with anotherTrait"
	^ self asTraitComposition + anotherTrait asTraitComposition! !

!MetalinkChanged commentStamp: ''!
Announce that a metalink changed!
!MetalinkChanged methodsFor: 'accessing' stamp: ''!
action: anObject
	action := anObject! !

!MetalinkChanged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInClass: aClass
	^ link methods
		anySatisfy: [ :each | each methodClass isNotNil and: [ each origin == aClass ] ]! !

!MetalinkChanged methodsFor: 'accessing' stamp: ''!
node: anObject
	node := anObject! !

!MetalinkChanged methodsFor: 'accessing' stamp: ''!
link
	^ link! !

!MetalinkChanged methodsFor: 'testing' stamp: ''!
isAdd
	^action = #add! !

!MetalinkChanged methodsFor: 'accessing' stamp: ''!
action
	^ action! !

!MetalinkChanged methodsFor: 'accessing' stamp: ''!
node
	^ node! !

!MetalinkChanged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage
	^ link methods
		anySatisfy:
			[ :each | each methodClass isNotNil and: [ each package == aPackage ] ]! !

!MetalinkChanged methodsFor: 'testing' stamp: ''!
isRemove
	^action = #remove! !

!MetalinkChanged methodsFor: 'testing' stamp: ''!
affectsMethod: aMethod

	^link methods anySatisfy: [:each | each compiledMethod == aMethod compiledMethod ]! !

!MetalinkChanged methodsFor: '*Calypso-SystemPlugins-Reflectivity-Queries' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery

	^link methods anySatisfy: [:each | 
		aMethodQuery isAffectedByChangedMethod: each ]! !

!MetalinkChanged methodsFor: 'testing' stamp: ''!
affectsMethods
	^true! !

!MetalinkChanged methodsFor: 'accessing' stamp: ''!
link: anObject
	link := anObject! !

!MetalinkChanged class methodsFor: 'instance creation' stamp: ''!
linkRemoved: link
	^ self new
		link: link;
		action: #remove;
		yourself! !

!MetalinkChanged class methodsFor: 'instance creation' stamp: ''!
linkRemoved: link fromNode: aNode
	^ (self linkRemoved: link)
		node: aNode;
		yourself! !

!MetalinkChanged class methodsFor: 'instance creation' stamp: ''!
linkAdded: link toNode: aNode
	^ (self linkAdded: link)
		node: aNode;
		yourself! !

!MetalinkChanged class methodsFor: 'instance creation' stamp: ''!
linkAdded: link
	^ self new
		link: link;
		action: #add;
		yourself! !

!MetalinkIconStyler commentStamp: ''!
I'm in charge to style an ast when there are metalinks!
!MetalinkIconStyler class methodsFor: 'options' stamp: ''!
shouldStyle
	^false! !

!MethodAdded commentStamp: ''!
This announcement is emitted when we add a method to a class or a trait using:
	=> Behavior >> compile: or TraitBehavior >> compile:!
!MethodAdded methodsFor: 'accessing' stamp: ''!
methodAdded
	^ method! !

!MethodAdded class methodsFor: 'instance creation' stamp: ''!
method: aCompiledMethod
	^self new
		method: aCompiledMethod;
		yourself! !

!MethodAddition commentStamp: ''!
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: 'compilation' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
priorCategoryOrNil
	^ priorCategoryOrNil! !

!MethodAddition methodsFor: 'notifying' stamp: 'nil'!
notifyObservers
	SystemAnnouncer uniqueInstance 
		suspendAllWhile: [myClass organization classify: selector under: category].
	priorMethodOrNil 
		ifNil: [ SystemAnnouncer uniqueInstance
				methodAdded: compiledMethod
				configuredWith: [ :event | 
					event
						propertyAt: #eventSource
						put: #Monticello ] ]
		ifNotNil: [
			SystemAnnouncer uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod oldProtocol: priorCategoryOrNil.
			priorCategoryOrNil = category ifFalse: [
       			SystemAnnouncer uniqueInstance methodRecategorized: compiledMethod oldProtocol: priorCategoryOrNil ] ].
	"The following code doesn't seem to do anything."
	myClass instanceSide noteCompilationOfMethod: compiledMethod meta: myClass isClassSide.
! !

!MethodAddition methodsFor: 'accessing' stamp: 'nil'!
priorCategoryOrNil: anObject
	priorCategoryOrNil := anObject! !

!MethodAddition methodsFor: 'operations' stamp: 'nil'!
installMethod
	SystemAnnouncer uniqueInstance
		suspendAllWhile: [ myClass addSelector: selector withMethod: compiledMethod ]! !

!MethodAddition methodsFor: 'compilation' stamp: 'nil'!
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: 'operations' stamp: 'nil'!
createCompiledMethod
	compiledMethod := myClass compiler 
		source: text asString;
		requestor: requestor;
		failBlock: [ ^nil ];
		compile.
	selector := compiledMethod selector.
	self writeSourceToLog.
	priorMethodOrNil := myClass compiledMethodAt: selector ifAbsent: [ nil ].
	priorCategoryOrNil := myClass organization categoryOfElement: selector! !

!MethodAddition methodsFor: 'operations' stamp: 'nil'!
writeSourceToLog
	logSource ifTrue: [
		myClass logMethodSource: text forMethod: compiledMethod
			inCategory: category withStamp: changeStamp
	].
! !

!MethodAnnouncement commentStamp: ''!
An abstract class for method announcements.!
!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
methodPackage
	^ methodPackage ifNil: [ methodPackage := method package ]! !

!MethodAnnouncement methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInClass: aClass
	^ self classAffected == aClass! !

!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
classAffected
	^ self methodOrigin! !

!MethodAnnouncement methodsFor: 'testing' stamp: ''!
affectsClassExtension
	^self methodAffected isExtension! !

!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
method
	
	^ method! !

!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
methodClass
	^ method methodClass! !

!MethodAnnouncement methodsFor: 'testing' stamp: ''!
affectsMethodsTaggedWith: tagName
	^method isTaggedWith: tagName asSymbol! !

!MethodAnnouncement methodsFor: 'testing' stamp: ''!
affectsClassesExtendedInPackage: aPackage
	^ self isProvidedByExtension and: [ self affectsMethodsDefinedInPackage: aPackage ]! !

!MethodAnnouncement methodsFor: 'testing' stamp: ''!
isProvidedByATrait

	^ self methodOrigin ~= self methodClass
! !

!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
methodOrigin
	^ method origin! !

!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
protocolsAffected
	^{self protocol}! !

!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
selector
	
	^ method selector! !

!MethodAnnouncement methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage

	^methodPackage == aPackage or: [ self methodAffected package == aPackage ]! !

!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
protocol
	
	^ method protocol! !

!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
packagesAffected
	^{self methodPackage}! !

!MethodAnnouncement methodsFor: 'testing' stamp: ''!
isProvidedByExtension
	^self methodOrigin package ~= self methodPackage! !

!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
method: aCompiledMethod
	method := aCompiledMethod.
	methodPackage := aCompiledMethod package! !

!MethodAnnouncement methodsFor: 'testing' stamp: ''!
affectsMethod: aMethod
	^self methodAffected == aMethod! !

!MethodAnnouncement methodsFor: '*Calypso-SystemQueries' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery

	^aMethodQuery isAffectedByChangedMethod: self methodAffected! !

!MethodAnnouncement methodsFor: 'testing' stamp: ''!
affectsPackages
	"any method makes package dirty"
	 
	^true! !

!MethodAnnouncement methodsFor: 'testing' stamp: ''!
affectsMethods
	^true! !

!MethodAnnouncement methodsFor: 'accessing' stamp: ''!
methodAffected
	^self method! !

!MethodChangeRecord commentStamp: ''!
MethodChangeRecords are used to record method changes.  Here is a simple summary of the relationship between the changeType symbol and the recording of prior state

			|	prior == nil			|	prior not nil	
	---------	|----------------------------	|--------------------
	add		|	add					|	change
	---------	|----------------------------	|--------------------
	remove	|	addedThenRemoved	|	remove

Structure:
changeType			symbol -- as summarized above
currentMethod	method
				This is the current version of the method.
				It can be used to assert this change upon entry to a layer. 
infoFromRemoval -- an array of size 2.
				The first element is the source index of the last version of the method.
				The second element is the category in which it was defined, so it
				can be put back there if re-accepted from a version browser.

Note that the above states each have an associated revoke action:
	add --> remove
	change --> change back
	remove --> add back
	addedThenRemoved --> no change
However all of these are accomplished trivially by restoring the original method dictionary.!
!MethodChangeRecord methodsFor: 'printing' stamp: 'nil'!
printOn: strm

	super printOn: strm.
	strm nextPutAll: ' ('; print: changeType; nextPutAll: ')'! !

!MethodChangeRecord methodsFor: 'accessing' stamp: 'nil'!
changeType

	^ changeType! !

!MethodChangeRecord methodsFor: 'infos' stamp: 'nil'!
noteMethodInfoFromRemoval: info
	"Store an array with the source index of the last version of the method,
	and the category in which it was defined (so it can be put back there if
	re-accepted from a version browser)."

	infoFromRemoval := info! !

!MethodChangeRecord methodsFor: 'all changes' stamp: 'nil'!
noteChangeType: newChangeType
	changeType := (changeType == #addedThenRemoved and: [ newChangeType == #change ])
		ifTrue: [ #add ]
		ifFalse: [ newChangeType ]! !

!MethodChangeRecord methodsFor: 'infos' stamp: 'nil'!
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 ]! !

!MethodChunk commentStamp: ''!
I represent the declaration of a method.  My contents are the source code to import, and the category reader is the object who knows the class, category and timestamp where to install the method.

Sending me the message #import makes me install the method into the class.!
!MethodChunk methodsFor: 'accessing' stamp: ''!
stamp
	^ stamp! !

!MethodChunk methodsFor: 'importing' stamp: ''!
methodCompileRequestorFor: aRequestor
	aRequestor ifNotNil: [ aRequestor contents ifNil: [ aRequestor contents: contents ] ].
	^ MethodChunkCompilerRequestor new
		methodChunk: self;
		fileCompileRequestor: aRequestor;
		yourself! !

!MethodChunk methodsFor: 'testing' stamp: ''!
isMethodDeclaration

	^ true! !

!MethodChunk methodsFor: 'accessing' stamp: ''!
stamp: aMethodStamp
	stamp := aMethodStamp! !

!MethodChunk methodsFor: 'accessing' stamp: ''!
category: aCategoryName
	categoryName := aCategoryName! !

!MethodChunk methodsFor: 'importing' stamp: ''!
importFor: requestor logSource: logSource
	self existsBehavior
		ifFalse: [ self handleMissingBehavior ].
	^ [ self targetClass
		compile: contents
		classified: categoryName
		withStamp: stamp
		notifying: (self methodCompileRequestorFor: requestor)
		logSource: logSource ]
		on: ReparseAfterSourceEditing
		do: [ :exception | 
			contents := exception newSource.
			self importFor: requestor logSource: logSource ]! !

!MethodChunk methodsFor: 'accessing' stamp: ''!
methodSelector
	
	^ RBParser parseMethodPattern: self contents! !

!MethodChunk methodsFor: 'printing' stamp: ''!
displayStringOn: stream
	stream nextPutAll: self description! !

!MethodChunk methodsFor: 'accessing' stamp: ''!
description

	^ 'Method ( ', behaviorName , ' >> ' , (contents first: (20 min: contents size)), ' )' , stamp asString! !

!MethodChunk methodsFor: 'accessing' stamp: ''!
category
	^ categoryName! !

!MethodChunk methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	^ aVisitor visitMethodChunk: self! !

!MethodChunk methodsFor: 'importing' stamp: ''!
handleMissingBehavior
	"self error: ('Cannot install method in unexistent behavior {1}' format: {(behaviorName asString)})"
	
	(MissingClassError 
		className: behaviorName asString)
		signal: 'Cannot install method in non-existent behavior ', behaviorName asString! !

!MethodChunk class methodsFor: 'instance creation' stamp: ''!
contents: someContents behaviorName: behaviorName isMeta: isMeta category: categoryName stamp: stamp
	^self new
			contents: someContents;
			behaviorName: behaviorName;
			isMeta: isMeta;
			category: categoryName;
			stamp: stamp;
			yourself! !

!MethodChunkCompilerRequestor commentStamp: ''!
I am an Object used to interact with the OpalCompiler during compilation of a method chunk. I keep a reference to the original input so that error messages can be properly analyzed later-on.!
!MethodChunkCompilerRequestor methodsFor: 'accessing' stamp: ''!
methodChunk: anObject
	methodChunk := anObject! !

!MethodChunkCompilerRequestor methodsFor: 'accessing' stamp: ''!
fileCompileRequestor
	^ fileCompileRequestor! !

!MethodChunkCompilerRequestor methodsFor: 'interactive error protocol' stamp: ''!
notify: message at: location in: code
	| newSource |
	self flag: #hack.
	"Should use the new OPalWarnings directly instead of recreating a SyntaxErrorNotification"
	newSource := SyntaxErrorNotification 
		inClass: STCommandLineHandler
		withCode: code
		doitFlag: false
		errorMessage: message
		location: location.
		
	"If the syntax error notification is resumed, then the source was corrected and we have to announce that parsing can restart."					
	ReparseAfterSourceEditing signalWithNewSource: newSource! !

!MethodChunkCompilerRequestor methodsFor: 'accessing' stamp: ''!
interactive
	^ interactive ifNil: [ false ]! !

!MethodChunkCompilerRequestor methodsFor: 'accessing' stamp: ''!
methodChunk
	^ methodChunk! !

!MethodChunkCompilerRequestor methodsFor: 'accessing' stamp: ''!
interactive: anObject
	interactive := anObject! !

!MethodChunkCompilerRequestor methodsFor: 'accessing' stamp: ''!
fileCompileRequestor: anObject
	fileCompileRequestor := anObject! !

!MethodChunkCompilerRequestor methodsFor: 'interactive error protocol' stamp: ''!
text
	^ methodChunk contents! !

!MethodClassifier commentStamp: ''!
I am a method classifier that sets the protocl of methods using some simple rules.

Example Usage:
	MethodClassifier classify: MyClass >> #mySelector!
!MethodClassifier methodsFor: 'classification-rules' stamp: ''!
protocolByKnownKeywordSuffix: aMethod
	(self protocolForKnownKeywordSuffixOfSelector: aMethod selector)
		ifNotNil: [ :p | protocol := p ]! !

!MethodClassifier methodsFor: 'classification-rules' stamp: ''!
protocolByKnownPragma: aMethod
	self class pragmaMapping
		keysAndValuesDo: [ :pragma :p | 
			(aMethod hasPragmaNamed: pragma)
				ifTrue: [ protocol := p] ]
	! !

!MethodClassifier methodsFor: 'classification' stamp: ''!
superclassProtocol: aMethod
	| currentClass |
	currentClass := aMethod methodClass.
	
	[ currentClass superclass isNil ] whileFalse: [
		currentClass := currentClass superclass.
		(currentClass includesSelector: aMethod selector) 
			ifTrue: [ 
				| possibleProtocol |
				possibleProtocol := (currentClass >> aMethod selector) protocol.
				((possibleProtocol beginsWith: '*') or: 
					(possibleProtocol asSymbol = currentClass package name))
						ifFalse: [ ^ possibleProtocol ]]].
	^ nil.! !

!MethodClassifier methodsFor: 'private' stamp: ''!
protocolForKnownKeywordSuffixOfSelector: aSelector
	"Returns the protocol for the first keyword suffix that equals a keyword
	from aSelector or that a keyword ends with or nil if there isn't one."

	aSelector keywords
		do: [ :each | 
			self class keywordSuffixMapping
				keysAndValuesDo: [ :suffix :p | 
					(each = suffix or: [ each endsWith: suffix ])
						ifTrue: [ ^ p ] ] ].
	^ nil! !

!MethodClassifier methodsFor: 'smartSuggestions - support' stamp: ''!
suggestProtocolFor: aMethod 
	| listToSearch index |
	listToSearch := self listToFindProtocols.
	index := 1.
	[ protocol isNil and: [ index <= listToSearch size ] ] 
	whileTrue: [ self perform: (listToSearch at: index) withArguments: {aMethod}.
		index := index + 1 ].
	^ protocol! !

!MethodClassifier methodsFor: 'classification-rules' stamp: ''!
protocolAccessorFor: 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: [ ^ self ].
	protocol := 'accessing'! !

!MethodClassifier methodsFor: 'classification-rules' stamp: ''!
protocolByOtherImplementors: aMethod
	| protocolBag |
	
	protocolBag := Bag new.
	
	aMethod implementors 
		ifEmpty: [ ^ self ]
		ifNotEmpty: [ :methods |
			methods 
				do: [ :method | 
					((method protocol beginsWith: '*') or: [ method protocol = Protocol unclassified ])
						ifFalse: [ protocolBag add: method protocol ]]
				without: aMethod ].
			
	protocolBag ifEmpty: [ ^ self ].
	protocol := protocolBag sortedCounts first value.! !

!MethodClassifier methodsFor: 'reseting' stamp: ''!
resetProtocol
	protocol := nil! !

!MethodClassifier methodsFor: 'private' stamp: ''!
protocolForKnownPrefixOfSelector: aSelector
	"Returns the protocol for the first prefix that equals aSelector or that
	aSelector starts with if the prefix is followed by a non-lowercase char
	(like $: or $A) or nil if there isn't one."

	| selectorString |
	selectorString := aSelector asString.
	self class prefixMapping
		keysAndValuesDo: [ :prefix :p | 
			(selectorString = prefix
				or: [ (selectorString beginsWith: prefix)
						and: [ (selectorString at: prefix size + 1) isLowercase not ] ])
				ifTrue: [ ^ p ] ].
	^ nil! !

!MethodClassifier methodsFor: 'accessing' stamp: ''!
listToFindProtocols
	^ #(#protocolAccessorFor: #protocolByKnownKeywordSuffix: 
	#protocolByKnownPragma: #protocolByKnownPrefix: 
	#protocolByOtherImplementors: #protocolInSuperclassProtocol:)! !

!MethodClassifier methodsFor: 'classification-rules' stamp: ''!
protocolInSuperclassProtocol: aMethod

	protocol := self superclassProtocol: aMethod! !

!MethodClassifier methodsFor: 'classification-rules' stamp: ''!
protocolByKnownPrefix: aMethod
	(self protocolForKnownPrefixOfSelector: aMethod selector)
		ifNotNil: [ :p | protocol := p ]! !

!MethodClassifier methodsFor: 'classification' stamp: ''!
classify: aMethod

	self suggestProtocolFor: aMethod.
	protocol ifNotNil: [ aMethod protocol: protocol ]


! !

!MethodClassifier methodsFor: 'classification' stamp: ''!
classifyAll: aCollectionOfMethods
	
	aCollectionOfMethods do: [ :method |
		self resetProtocol.
		self classify: method ]! !

!MethodClassifier class methodsFor: 'private' stamp: ''!
buildPrefixMapping
	prefixMapping := Dictionary new
		at: 'accept' put: 'visiting';
		at: 'accepts' put: 'testing';
		at: 'add' put: 'adding';
		at: 'as' put: 'converting';
		at: 'assert' put: 'asserting';
		at: 'at' put: 'accessing';
		at: 'baseline' put: 'baselines';
		at: 'bench' put: 'benchmarking';
		at: 'benchmark' put: 'benchmarking';
		at: 'can' put: 'testing';
		at: 'compile' put: 'compiling';
		at: 'copy' put: 'copying';
		at: 'deny' put: 'asserting';
		at: 'first' put: 'accessing';
		at: 'format' put: 'formatting';
		at: 'from' put: 'instance creation';
		at: 'has' put: 'testing';
		at: 'includes' put: 'testing';
		at: 'index' put: 'accessing';
		at: 'initialize' put: 'initialization';
		at: 'is' put: 'testing';
		at: 'last' put: 'accessing';
		at: 'matches' put: 'testing';
		at: 'max' put: 'accessing';
		at: 'maximum' put: 'accessing';
		at: 'min' put: 'accessing';
		at: 'minimum' put: 'accessing';
		at: 'needs' put: 'testing';
		at: 'new' put: 'instance creation';
		at: 'parse' put: 'parsing';
		at: 'print' put: 'printing';
		at: 'remove' put: 'removing';
		at: 'render' put: 'rendering';
		at: 'requires' put: 'testing';
		at: 'reset' put: 'initialization';
		at: 'set' put: 'initialization';
		at: 'should' put: 'asserting';
		at: 'shouldnt' put: 'asserting';
		at: 'signal' put: 'signalling';
		at: 'sort' put: 'sorting';
		at: 'test' put: 'tests';
		at: 'total' put: 'accessing';
		at: 'version' put: 'versions';
		at: 'visit' put: 'visiting';
		at: 'write' put: 'writing';
		yourself! !

!MethodClassifier class methodsFor: 'private' stamp: ''!
clearMappings
	"self clearMappings"

	prefixMapping := nil.
	keywordSuffixMapping := nil.
	pragmaMapping := nil.! !

!MethodClassifier class methodsFor: 'classification' stamp: ''!
suggestProtocolFor: aMethod
	^ (self new suggestProtocolFor: aMethod) ifNil: [ 'as yet unclassified' ]! !

!MethodClassifier class methodsFor: 'private' stamp: ''!
buildKeywordSuffixMapping
	keywordSuffixMapping := Dictionary new
		at: 'Add:' put: 'adding';
		at: 'AddAll:' put: 'adding';
		at: 'Associations' put: 'accessing';
		at: 'At:' put: 'accessing';
		at: 'Collect:' put: 'enumerating';
		at: 'Detect:' put: 'enumerating';
		at: 'Do:' put: 'enumerating';
		at: 'Includes:' put: 'testing';
		at: 'Keys' put: 'accessing';
		at: 'Reject:' put: 'enumerating';
		at: 'Remove:' put: 'removing';
		at: 'RemoveAll' put: 'removing';
		at: 'RemoveKey:' put: 'removing';
		at: 'Select:' put: 'enumerating';
		at: 'Values' put: 'accessing';
		yourself! !

!MethodClassifier class methodsFor: 'accessing' stamp: ''!
keywordSuffixMapping
	"use a class inst var so subclasses can define custom mappings"
	^ keywordSuffixMapping ifNil: [
		self buildKeywordSuffixMapping.
		keywordSuffixMapping]! !

!MethodClassifier class methodsFor: 'accessing' stamp: ''!
pragmaMapping
	"use a class inst var so subclasses can define custom mappings"
	^ pragmaMapping ifNil: [
		self buildPragmaMapping.
		pragmaMapping]! !

!MethodClassifier class methodsFor: 'accessing' stamp: ''!
prefixMapping
	"use a class inst var so subclasses can define custom mappings"
	^ prefixMapping ifNil: [
		self buildPrefixMapping.
		prefixMapping]! !

!MethodClassifier class methodsFor: 'private' stamp: ''!
buildPragmaMapping
	pragmaMapping := Dictionary new
		at: 'example' put: 'examples';
		at: 'spec' put: 'specs';
		at: 'spec:' put: 'specs';
		at: 'symbolicVersion:' put: 'symbolic versions';
		yourself! !

!MethodClassifier class methodsFor: 'classification' stamp: ''!
classify: aMethod
	^ self new classify: aMethod! !

!MethodClassifier class methodsFor: 'classification' stamp: ''!
classifyAll: aCollectionOfMethods
	^ self new classifyAll: aCollectionOfMethods! !

!MethodClassifierTest commentStamp: ''!
SUnit tests for MethodClassifier!
!MethodClassifierTest methodsFor: 'tests' stamp: ''!
testProtocolForKnownKeywordSuffixOfSelector
	| classifier |
	classifier := MethodClassifier new.
	classifier class keywordSuffixMapping
		keysAndValuesDo: [ :suffix :protocol | 
			self
				assert: (classifier protocolForKnownKeywordSuffixOfSelector: suffix asSymbol) equals: protocol;
				assert: (classifier protocolForKnownKeywordSuffixOfSelector: ('more' , suffix) asSymbol) equals: protocol.
			(suffix endsWith: ':')
				ifTrue: [
					self
						assert: (classifier protocolForKnownKeywordSuffixOfSelector: (suffix , 'more:') asSymbol) equals: protocol;
						assert: (classifier protocolForKnownKeywordSuffixOfSelector: ('more' , suffix , 'more:') asSymbol) equals: protocol.
					self
						deny: (classifier protocolForKnownKeywordSuffixOfSelector: (suffix allButLast , 'More') asSymbol) equals: protocol;
						deny: (classifier protocolForKnownKeywordSuffixOfSelector: (suffix allButLast , 'More:') asSymbol) equals: protocol ]
				ifFalse: [
					self
						deny: (classifier protocolForKnownKeywordSuffixOfSelector: (suffix , 'More') asSymbol) equals: protocol;
						deny: (classifier protocolForKnownKeywordSuffixOfSelector: (suffix , 'More:') asSymbol) equals: protocol ] ]! !

!MethodClassifierTest methodsFor: 'tests' stamp: ''!
testProtocolForKnownPrefixOfSelector
	| classifier |
	classifier := MethodClassifier new.
	classifier class prefixMapping
		keysAndValuesDo: [ :prefix :protocol | 
			self
				assert: (classifier protocolForKnownPrefixOfSelector: prefix asSymbol) equals: protocol;
				assert: (classifier protocolForKnownPrefixOfSelector: (prefix , 'More') asSymbol) equals: protocol;
				assert: (classifier protocolForKnownPrefixOfSelector: (prefix , ':') asSymbol) equals: protocol;
				assert: (classifier protocolForKnownPrefixOfSelector: (prefix , ':more:') asSymbol) equals: protocol.

			"it shouldn't mis-classify 'island' as 'testing' just because it starts with 'is'"
			self deny: (classifier protocolForKnownPrefixOfSelector: (prefix , 'more') asSymbol) equals: protocol ]! !

!MethodConstantTest methodsFor: 'tests' stamp: ''!
testConstPlaceInTransformedMethod

	| transformedMethod const |
	const := self constFromReceiverExpression. 
		
	transformedMethod := self class >> #constFromReceiverExpression. 
	
	self assert: (transformedMethod literals anySatisfy:  [ :each | each == const ])! !

!MethodConstantTest methodsFor: 'tests' stamp: ''!
constFromReceiverExpression

	^DateAndTime now asMethodConstant 
! !

!MethodConstantTest methodsFor: 'tests' stamp: ''!
testAPIFromMessageSendReceiver
	| constInitialResult constSecondResult |
	constInitialResult := self constFromReceiverExpression.
	constSecondResult := self constFromReceiverExpression.

	self assert: constSecondResult identicalTo: constInitialResult! !

!MethodConstantTest methodsFor: 'tests' stamp: ''!
testAPIFromBlock
	| constInitialResult constSecondResult |
	constInitialResult := self constFromBlock: [ DateAndTime now ].
	constSecondResult := self constFromBlock: nil.

	self assert: constSecondResult identicalTo: constInitialResult! !

!MethodConstantTest methodsFor: 'tests' stamp: ''!
sumOfTwoConsts: firstBlock and: secondBlock

	^firstBlock asMethodConstant + secondBlock asMethodConstant! !

!MethodConstantTest methodsFor: 'tests' stamp: ''!
constFromBlock: aBlock

	^aBlock asMethodConstant 
! !

!MethodConstantTest methodsFor: 'tests' stamp: ''!
testTwoConstsInSameMethod

	| result1 result2 |
	result1 := self sumOfTwoConsts: [ 1 ] and: [ 2 ].
	result2 := self sumOfTwoConsts: nil and: nil.
	self assert: result1 equals: 3.
	self assert: result2 equals: 3.! !

!MethodConstantTest methodsFor: 'tests' stamp: ''!
testUsingConstJustInSameMethod
	| values |
	self skip.	"not working for the first call: would need on stack replacement"
	values := OrderedCollection new.
	2 timesRepeat: [ values add: DateAndTime now asMethodConstant ].

	self assert: values first identicalTo: values last! !

!MethodDictionary commentStamp: ''!
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.

About flushCache methods and usage.

The VM caches method lookups in a lookup cache from class,selector pairs to method,primitive pairs, where primitive may be null.  This is called the first-level method lookup cache.  The JIT VM caches message lookups in machine code, so that a particular piece of machine code exists in a state that invokes a method for a specific class very fast by embedding the class reference in a register load and the target method in a call instruction, and having the target method verify this "cache probe" (this is an "in-line cache).  The JIT also caches the translation of a byte coded method to machine code, by hiding a reference to a machine code method in a byte coded method.

These caches can be invalidated in several circumstances:

1a. if one adds or removes a method from a class's method dictionary it may change the correct results of a lookup not merely of the class whose dictionary was updated but also subclasses of the class.
1b. if one replaces a method in a method dictionary this changes the target method for a lookup of the selector for the class and subclasses

2. if one wants to rewrite the byte code or literals of a method, for example because a Slot definition has changed, then if the method has been compiled to machine code, the machine code must be discarded before the new code may be executed

1a & 1b are done via Symbol>>flushCache.  In response the normal VM flushes its first-level method lookup cache, and the JIT also scans all of machine code looking for inline caches with that selector, and voiding them, reverting each send site for that selector to the "unlinked" state.

There used to be confusion in Squeak, which Pharo inherited, that using CompiledMethod>>flushCache was somehow the right way to void caches when updating method dictionaries, flushing the old method in the dictionary, if any, and the new method.  It isn't, precisely because adding or removing methods affects the visibility of inherited methods with the same selector.  So MethodDictionary code should use Symbol>>flushCache, and only once, on each update of a method dictionary.  As a result, the VM will ensure that the necessary send caches are flushed for that selector.

2. is done via CompiledMethod>>flushCache.  In response the VM searches the first-level method lookup cache and removes all entries whose target is the method.  In addition the JIT discards the machine code for the method, and searches for all send sites with that method's machine code as the target and voids them, reverting them to the unlinked state.

The VM must be told to flush the cached state for a compiled method via CompiledMethod>>flushCache and will /try/ and void the state for that method.  But it can't always deal with existing activations of that method, because if there are activations running the machine code, that machine code can't merely be thrown away, and can't be replaced because its length may change, depending on literals or byte codes.  So this kind of byte coded method manipulation needs to be done with case and some understanding of the total system state.!
!MethodDictionary methodsFor: 'enumeration' stamp: ''!
associationsDo: aBlock 

	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (self basicAt: i) ifNotNil:
			[ :key | aBlock value: (Association key: key value: (array at: i))]]! !

!MethodDictionary methodsFor: 'accessing' stamp: ''!
add: anAssociation

	^ self at: anAssociation key put: anAssociation value! !

!MethodDictionary methodsFor: 'enumeration' stamp: ''!
keysDo: aBlock 
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (self basicAt: i) ifNotNil: [ :key | aBlock value: key]]! !

!MethodDictionary methodsFor: 'accessing' stamp: ''!
at: key ifPresent: aBlock

	^(array at: (self findElementOrNil: key))
		ifNotNil: [ :value | aBlock cull: value ]! !

!MethodDictionary methodsFor: 'private' stamp: ''!
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) == nil or: [element == anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element := self basicAt: index) == nil or: [element == anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!MethodDictionary methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
at: key ifAbsent: aBlock

	| index |
	index := self findElementOrNil: key.
	(self basicAt: index) ifNil: [ ^ aBlock value ].
	^ array at: index! !

!MethodDictionary methodsFor: 'enumeration' stamp: ''!
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: 'removing' stamp: ''!
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.
	key flushCache.
	^ removedValue! !

!MethodDictionary methodsFor: 'private' stamp: ''!
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: ''!
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: 'testing' stamp: ''!
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: 'accessing' stamp: ''!
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: 'private' stamp: ''!
swap: oneIndex with: otherIndex

	| element |
	element := self basicAt: oneIndex.
	self basicAt: oneIndex put: (self basicAt: otherIndex).
	self basicAt: otherIndex put: element.
	array swap: oneIndex with: otherIndex! !

!MethodDictionary methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
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].
	array at: index put: value.
	key flushCache. "flush the vm cache by selector"
	self fullCheck.
	value cachePragmas.
	^ value! !

!MethodDictionary methodsFor: 'copying' stamp: ''!
postCopy
	array := array copy! !

!MethodDictionary methodsFor: 'enumeration' stamp: ''!
valuesDo: aBlock 
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (array at: i) ifNotNil: [ :value | aBlock value: value]]! !

!MethodDictionary methodsFor: '*Reflectivity' stamp: ''!
metaLinkOptions
	^{
	#scanFor: -> #( + optionCompileOnLinkInstallation).
	#at:put: -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!MethodDictionary methodsFor: 'accessing' stamp: ''!
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: 'removing' stamp: ''!
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: '*Fuel-Tests-Core' stamp: ''!
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: 'private' stamp: ''!
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: ''!
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 class methodsFor: 'instance creation' stamp: ''!
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: ''!
new: numberOfElements
	"Create an instance large enough to hold numberOfElements methods without growing."
	
	^self newForCapacity: (self sizeFor: numberOfElements)! !

!MethodDictionary class methodsFor: 'initialization' stamp: ''!
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: ''!
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: ''!
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! !

!MethodDictionaryTest commentStamp: ''!
SUnit tests for MethodDictionary!
!MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne).! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testGrowDoublesCapacity
	| methodDictionary oldCapacity |
	methodDictionary := MethodDictionary new.
	oldCapacity := methodDictionary capacity.
	methodDictionary grow.
	self assert: oldCapacity * 2 equals: methodDictionary capacity! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testAssociationAtNonexistantKeyExecutesFailBlock
	| methodSelector result error |
	methodSelector := #inexistant:method:larala:.
	error := #error.
	result := self class methodDict associationAt: methodSelector ifAbsent: [ error ].

	self assert: result equals: error! !

!MethodDictionaryTest methodsFor: 'helpers' stamp: ''!
aValue

	^ self class >> #aValue! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testKeyAtExistantValueCopyReturnsOkKey
	| methodSelector result aMethod |
	methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation.
	aMethod := (self class >> methodSelector) copy.
	result := self class methodDict keyAtValue: aMethod ifAbsent: [ self error ].

	self assert: result equals: methodSelector! !

!MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty ).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!MethodDictionaryTest methodsFor: 'requirements' stamp: ''!
emptyDict
	^ self empty! !

!MethodDictionaryTest methodsFor: 'assertions' stamp: ''!
assertPreservesElements: oldDictionary comparedTo: newDictionary
	self assert: (oldDictionary keys allSatisfy: [ :key |
		(newDictionary includesKey: key) &
		((newDictionary at: key) == (oldDictionary at: key))
		])! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testAssociationAtExistantKeyReturnsOkAssociation
	| methodSelector association |
	methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation.
	association := self class methodDict associationAt: methodSelector ifAbsent: [ self error ].

	self assert: association key equals: methodSelector.
	self assert: association value equals: self class >> methodSelector! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
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 equals: error! !

!MethodDictionaryTest methodsFor: 'tests - removing' stamp: ''!
testRemove

	self should: [self nonEmptyDict remove: nil] raise: Error.
	self should: [self nonEmptyDict remove: nil ifAbsent: ['What ever here']] raise: Error.! !

!MethodDictionaryTest methodsFor: 'requirements' stamp: ''!
keyNotIn
" return a key not included in nonEmpty"
^ #bouba! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testGrowPreservesElements
	| methodDictionary growedMethodDictionary |
	methodDictionary := self class methodDict copy.
	growedMethodDictionary := methodDictionary copy; grow; yourself.

	self assertPreservesElements: methodDictionary comparedTo: growedMethodDictionary.
	self assertPreservesElements: growedMethodDictionary comparedTo: methodDictionary.! !

!MethodDictionaryTest methodsFor: 'tests - removing' stamp: ''!
testKeysAndValuesRemove
	| oldSize collection keyIn |
	
	collection := self nonEmptyDict .
	oldSize := collection  size.
	keyIn := collection keys anyOne.
	
	collection  keysAndValuesRemove: [:key :value | key == self keyNotInNonEmptyDict ].
	self assert: (collection  size = (oldSize )).
	
	collection  keysAndValuesRemove: [:key :value | key == keyIn ].
	self assert: (collection  size = (oldSize - 1)).
	self should: [ collection at: keyIn  ] raise: Error.! !

!MethodDictionaryTest methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testAssociations

	| collection result  |
	collection := self nonEmpty .
	result := collection associations.
	
	self assert: result size = collection size.
	result do: [:assoc | self assert: (assoc value) = (collection at: assoc key) ].
	"keys do: [ :key | self assert: ( result at: key ) = ( collection at: key )] ."! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testAssociationsDoGoesOverEntireDictionary
	| associations |
	associations := MethodDictionary new.
	
	self class methodDict associationsDo:[ :association | associations add: association ].
	
	self assertPreservesElements: self class methodDict comparedTo: associations.! !

!MethodDictionaryTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	^ nonEmptyDict! !

!MethodDictionaryTest methodsFor: 'assertions' stamp: ''!
assertPreservesCapacity: oldDictionary comparedTo: rehashedDictionary
	self assert: oldDictionary capacity equals: rehashedDictionary capacity! !

!MethodDictionaryTest methodsFor: 'tests' stamp: ''!
testBehaviorLocalyDefined
	"method not acquired from a trait or from its superclass"

	self assert: (Object methodDict isKindOf: MethodDictionary).
	self assert: Object selectors asSortedCollection equals: Object selectors asSortedCollection! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testIdentityKeyAtNonExistantValueReturnsFailBlock
	| result error |
	error := #error.

	result := self class methodDict keyAtIdentityValue: self ifAbsent: [ error ].

	self assert: result equals: error! !

!MethodDictionaryTest methodsFor: 'tests - rehashing' stamp: ''!
testRehashPreservesElements
	| oldDictionary rehashedDictionary |
	oldDictionary := self modifiedMethodDictionaryCopy.
	
	rehashedDictionary := oldDictionary copy rehash.
	
	self assertPreservesElements: oldDictionary comparedTo: rehashedDictionary.
	self assertPreservesElements: rehashedDictionary comparedTo: oldDictionary.! !

!MethodDictionaryTest methodsFor: 'helpers' stamp: ''!
anotherValue

	^ self class >> #anotherValue! !

!MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!MethodDictionaryTest methodsFor: 'requirements' stamp: ''!
nonEmptyDifferentFromNonEmptyDict
	" return a dictionary for which all keys are not included in nonEmptyDict"
	^ MethodDictionary new
		at: #nonEmptyDifferentFromNonEmptyDict put: (self class >> #nonEmptyDifferentFromNonEmptyDict)! !

!MethodDictionaryTest methodsFor: 'tests' stamp: ''!
testIncludesKeyLocalyDefined

	self assert: (self class includesSelector: #testIncludesKeyLocalyDefined).! !

!MethodDictionaryTest methodsFor: 'requirements' stamp: ''!
anotherElementNotIn
" return an element different of 'elementNotIn'  not included in 'nonEmpty' "
	^ self class >> #anotherElementNotIn! !

!MethodDictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryRemovingTest
	self nonEmptyDict.
	self denyEmpty: self nonEmptyDict.
	self keyNotInNonEmptyDict.
	self deny: (self nonEmptyDict keys includes: self keyNotInNonEmptyDict)! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testAtNonexistantKeyExecutesFailBlock
	| methodSelector result error |
	methodSelector := #inexistant:method:larala:.
	error := #error.
	result := self class methodDict at: methodSelector ifAbsent: [ error ].

	self assert: result equals: error! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testKeyAtExistantValueReturnsOkKey
	| methodSelector result aMethod |
	methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation.
	aMethod := self class >> methodSelector.
	result := self class methodDict keyAtValue: aMethod ifAbsent: [ self error ].

	self assert: result equals: methodSelector! !

!MethodDictionaryTest methodsFor: 'requirements' stamp: ''!
nonEmptyDict
	^ nonEmptyDict! !

!MethodDictionaryTest methodsFor: 'requirements' stamp: ''!
empty
	^ MethodDictionary new! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testAtExistantKeyReturnsOkCompiledMethod
	| methodSelector method |
	methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation.
	method := self class methodDict at: methodSelector ifAbsent: [ self error ].

	self assert: method class equals: CompiledMethod! !

!MethodDictionaryTest methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testValues
	
	| collection result |
	collection := self nonEmpty .
	result := collection values.
	
	self assert: result size = collection size.
	result do: [:each | self assert: (collection occurrencesOf:each ) = (result occurrencesOf: each) ].! !

!MethodDictionaryTest methodsFor: 'requirements' stamp: ''!
newEmptyDict
	^ MethodDictionary new! !

!MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	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' stamp: ''!
testKeyAtValueIfAbsentLocalyDefined
	self
		assert: (self class methodDict keyAtValue: self class >> #testKeyAtValueIfAbsentLocalyDefined ifAbsent: [  ])
		identicalTo: #testKeyAtValueIfAbsentLocalyDefined.

	self assert: (self class methodDict keyAtValue: Object >> #printOn: ifAbsent: [ #notFound ]) identicalTo: #notFound! !

!MethodDictionaryTest methodsFor: 'requirements' stamp: ''!
keyNotInNonEmptyDict
" return a key not included in nonEmptyDict"
	^ #keyNotInNonEmptyDict! !

!MethodDictionaryTest methodsFor: 'tests - removing' stamp: ''!
testRemoveAllPreservesCapacity
	| methodSelector dictionary oldSize |
	methodSelector := #testRemoveAllPreservesCapacity.
	dictionary := MethodDictionary new.
	dictionary at: methodSelector put: self class >> methodSelector.

	oldSize := dictionary basicSize.
	dictionary removeAll.
	self assert: oldSize equals: dictionary basicSize! !

!MethodDictionaryTest methodsFor: 'helpers' stamp: ''!
anIndex

	^ #aMethodName! !

!MethodDictionaryTest methodsFor: 'setUps' stamp: ''!
modifiedMethodDictionaryCopy
	| copy |
	
	copy := self class methodDict copy.
	copy at: #methodAddedToIncreaseTheDict put: Object >> #=.
	^copy.! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testIdentityKeyAtExistantValueReturnsOkKey
	| methodSelector result aMethod |
	methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation.

	aMethod := self class >> methodSelector.
	result := self class methodDict keyAtIdentityValue: aMethod ifAbsent: [ self error ].

	self assert: result equals: methodSelector! !

!MethodDictionaryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	nonEmptyDict := MethodDictionary new.
	nonEmptyDict at: #setUp put: (self class >> #setUp).
	nonEmptyDict at: #nonEmpty put: (self class >> #nonEmpty).! !

!MethodDictionaryTest methodsFor: 'tests - rehashing' stamp: ''!
testRehashPreservesCapacity
	| oldDictionary rehashedDictionary |
	oldDictionary := self modifiedMethodDictionaryCopy.

	rehashedDictionary := oldDictionary copy rehash.
	
	self assertPreservesCapacity: oldDictionary comparedTo: rehashedDictionary.! !

!MethodDictionaryTest methodsFor: 'requirements' stamp: ''!
elementNotIn
"return an element not included in 'nonEmpty' "

	^ self class >> #elementNotIn! !

!MethodDictionaryTest methodsFor: 'tests - others' stamp: ''!
testKeyAtNonexistantValueExecutesFailBlock
	| result error |
	error := #error.
	result := self class methodDict keyAtValue: self ifAbsent: [ error ].

	self assert: result equals: error! !

!MethodDictionaryTest methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testKeys
	| collection result |
	collection := self nonEmpty.
	result := collection keys.
	result do: [ :key | collection at: key ].
	self assert: result size = collection size.
	self should: [ result detect: [ :each | (result occurrencesOf: each) > 1 ] ] raise: Error! !

!MethodDictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryKeysValuesAssociationsAccess
	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!MethodDictionaryTest methodsFor: 'tests - removing' stamp: ''!
testRemoveKey
	
	| collection oldSize keyIn |
	collection := self nonEmptyDict .
	oldSize := collection size.
	keyIn := collection  keys anyOne.
	
	collection removeKey: keyIn .
	self assert: (collection  size = (oldSize - 1)).
	self should: [ (collection  at: keyIn )] raise: Error.
	
	self should: [collection removeKey: self keyNotInNonEmptyDict ] raise: Error! !

!MethodDictionaryTest methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testKeysSortedSafely
	| collection result |
	collection := self nonEmpty.
	result := collection keysSortedSafely.
	result do: [ :key | collection at: key ].
	self assert: result size = collection size.
	self should: [ result detect: [ :each | (result occurrencesOf: each) > 1 ] ] raise: Error.
	self assert: result asArray isSorted! !

!MethodDictionaryTest methodsFor: 'tests - removing' stamp: ''!
testRemoveKeyIfAbsent
	
	| collection oldSize keyIn value result |
	collection := self nonEmptyDict .
	oldSize := collection size.
	keyIn := collection  keys anyOne.
	value := collection at: keyIn .
	
	result := collection removeKey: keyIn ifAbsent: [888].
	
	self assert: result = value.
	self assert: (collection  size = (oldSize - 1)).
	self should: [ (collection  at: keyIn )] raise: Error.
	
	self assert: (collection removeKey: self keyNotInNonEmptyDict ifAbsent: [888] ) = 888.! !

!MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''!
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: 'requirement' stamp: ''!
speciesClass
	^ MethodDictionary! !

!MethodDictionaryTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!MethodDictionaryTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MethodDictionaryTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MethodDictionaryTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MethodDictionaryTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MethodDictionaryTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MethodDictionaryTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MethodDictionaryTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MethodDictionaryTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MethodDictionaryTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MethodDictionaryTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MethodDictionaryTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MethodDictionaryTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MethodDictionaryTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MethodDictionaryTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MethodDictionaryTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MethodDictionaryTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MethodDictionaryTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MethodDictionaryTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MethodDictionaryTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MethodDictionaryTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MethodDictionaryTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MethodDictionaryTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MethodDictionaryTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MethodDictionaryTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MethodDictionaryTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MethodDictionaryTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MethodDictionaryTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MethodDictionaryTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MethodDictionaryTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MethodFinder commentStamp: ''!
I'm a method finder that will find methods from given examples in an array.
The examples array should contain one object for the receiver, one object per expected argument and then a final object with the expected result.
In other words 
 - a unary method example expects an array of input objects #( receiver ) and an expected result
 - a binary method example expects an array with two input objects #( receiver argument ) and an expected result
 - a keyword method example expects an array with at least two elements  #( receiver argument1 argument2 ... ) and an expected results

The method finder will take the input objects (receiver and arguments) and perform their permutation to be able to find more results.
Then, it will lookup in the receiver's hierarchy the approuved and forbidden methods to run on the hierarchy and run them on the permutation of objects.

NewMethodFinder new findMethodsByExampleInput: #( 1 2 ) andExpectedResult: 3!
!MethodFinder methodsFor: 'public access' stamp: ''!
possibleSolutionsForInput: inputCollection
	| sends |
	sends := OrderedCollection new.
	inputCollection
		permutationsDo: [ :permutation | 
			| foundPermutationSends args receiver |
			args := permutation allButFirst.
			receiver := permutation first.
			foundPermutationSends := (receiver class
				allSelectorsToTestInMethodFinderWithArity: inputCollection size - 1)
				collect:
					[ :method | MethodFinderSend 
									receiver: receiver deepCopy 
									selector: method 
									withArguments: args deepCopy ].
			sends addAll: foundPermutationSends ].
	^ sends! !

!MethodFinder methodsFor: 'public access' stamp: ''!
findMethodsByExampleInput: inputCollection andExpectedResult: expectedResult
	"Search for methods which giving each elements of input returns the corresponding elements of outputs."

	^ (self possibleSolutionsForInput: inputCollection) 
			select: [ :send | send resultIn: expectedResult ].! !

!MethodFinderBottomClass commentStamp: ''!
Test sample for MethodFinderTest!
!MethodFinderBottomClass methodsFor: 'accessing' stamp: ''!
instanceVariable

	^ instanceVariable.! !

!MethodFinderBottomClass methodsFor: 'comparing' stamp: ''!
= other

	^ instanceVariable = other instanceVariable.! !

!MethodFinderBottomClass methodsFor: 'accessing' stamp: ''!
onlyBottomDefinedApprovedMethod

	^self! !

!MethodFinderBottomClass methodsFor: 'accessing' stamp: ''!
otherOneArgumentMethod: s

	^ s, ''! !

!MethodFinderBottomClass methodsFor: 'accessing' stamp: ''!
modifyMethod: x

	instanceVariable := x.
	^ x.! !

!MethodFinderBottomClass methodsFor: 'accessing' stamp: ''!
multipleArgumentsMethod: x and: y

	^ x! !

!MethodFinderBottomClass methodsFor: 'accessing' stamp: ''!
onlyBottomDefinedDisapprovedMethod

	^self! !

!MethodFinderBottomClass methodsFor: 'accessing' stamp: ''!
InApprovedAndInForbiddenSetMethod

	 ^ self! !

!MethodFinderBottomClass methodsFor: 'accessing' stamp: ''!
oneArgumentMethod: x

	^ x + 0! !

!MethodFinderBottomClass class methodsFor: 'method finder' stamp: ''!
approvedSelectorsForMethodFinder

	^#(topDisapprovedButBottomApprovedMethod onlyBottomDefinedApprovedMethod modifyMethod: oneArgumentMethod: otherOneArgumentMethod: InApprovedAndInForbiddenSetMethod)! !

!MethodFinderBottomClass class methodsFor: 'method finder' stamp: ''!
forbiddenSelectorsForMethodFinder

	^#(topApprovedButBottomDisapprovedMethod InApprovedAndInForbiddenSetMethod)! !

!MethodFinderSend commentStamp: ''!
I am a message send that can be tested against an expected result.
If the result of the message send does not correpond to the expected result, or the message send provoked an error, or the comparison raised an error I return false.!
!MethodFinderSend methodsFor: 'accessing' stamp: ''!
selector
	
	^ selector! !

!MethodFinderSend methodsFor: 'accessing' stamp: ''!
arguments

	^arguments! !

!MethodFinderSend methodsFor: 'accessing' stamp: ''!
arguments: anObject

	arguments := anObject! !

!MethodFinderSend methodsFor: 'accessing' stamp: ''!
receiver

	^ receiver! !

!MethodFinderSend methodsFor: 'accessing' stamp: ''!
selector: anObject

	selector := anObject! !

!MethodFinderSend methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream print: receiver.
	aStream space.
	arguments ifEmpty: [^ aStream nextPutAll: selector].
	arguments 
		with: selector keywords 
		do: [:arg :word |
				aStream nextPutAll: word asString.
				aStream space.
				aStream print: arg.
				aStream space ].
	aStream skip: -1.! !

!MethodFinderSend methodsFor: 'public access' stamp: ''!
resultIn: expectedResult

	[ [ ^ expectedResult = self evaluate ]
		onErrorDo: [ :anError | ^ false ] ]
			on: Deprecation
			do: [ :depr | ^ false ]! !

!MethodFinderSend methodsFor: 'accessing' stamp: ''!
receiver: anObject
	receiver := anObject! !

!MethodFinderSend methodsFor: 'public access' stamp: ''!
evaluate
	
	^ receiver perform: selector withArguments: arguments! !

!MethodFinderSend class methodsFor: 'instance creation' stamp: ''!
receiver: r selector: s1 withArguments: args

	^ self new
		receiver: r;
		selector: s1;
		arguments: args;
		yourself! !

!MethodFinderTest commentStamp: ''!
Unit tests for MethodFinder!
!MethodFinderTest methodsFor: 'tests' stamp: ''!
testMethodNotDefinedAndDisapprovedInClassButApprovedInSuperClass
	"If the superclass B of a class defines a methods f which is not
	 redefined in A, then any instance of A should accept f unless
	 f is not approved by A.
	 Indeed let imagine this case :
	     f calls g which is approved in B but dangerous in A.
	     Then f is approved in B but dangerous in B.
	
	 TODO analysis : need to have a forbiden methods set or need that any
	                 methods which is approved by A is in its appovedSet 
	                 even if its only defined in one of its superclasses.
                    1 is more flexible and evolutive as the forbidden methods
                    set is only necesary in these unpracticable case (which
                    are really not frequent), the only advantage of the second
                    solution if that it offers to not calculate the set of 
                    approved mathod going through the superclasses tree.   
	"
	
	|bottom result |
	bottom := MethodFinderBottomClass new.
	result := (MethodFinder new findMethodsByExampleInput: { bottom } andExpectedResult:  bottom).
	self assert: (result includes: #topApprovedButBottomDisapprovedMethod) equals: false.! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testSearchOnClassDoesNotFail

	self shouldnt: [MethodFinder new findMethodsByExampleInput: { Boolean } andExpectedResult: {}] raise: Error.! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testMethodNotDefinedInClassButApprovedInSuperClass
	"If the superclass B of a class defines a methods f which is not
	 redefined in A and which is not forbidden in A, then any instance
	 of A should accept f."
	
	|bottom result |
	bottom := MethodFinderBottomClass new.
	result := (MethodFinder new findMethodsByExampleInput: { bottom } andExpectedResult:  bottom).
	self assert: ((result collect: [:each | each selector]) includes: #onlyTopDefinedApprovedMethod).! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testSideEffects
	"The arguments that we tested should not be changed even if
	 a matching method modifies them"
	
	| bottom result |
	bottom := MethodFinderBottomClass new.
	bottom modifyMethod: 1.
	result := (MethodFinder new findMethodsByExampleInput: { bottom . 5 } andExpectedResult:  5).
	self assert: ((result collect: [:each | each selector]) includes: #modifyMethod:).
	self assert: (bottom instanceVariable) equals: 1.! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testSideEffectsBetweenTestProves
	"The arguments that we tested should not be changed even if
	 a matching method modifies them"
	
	| bottom results |
	bottom := MethodFinderBottomClass new.
	bottom modifyMethod: 1.
	results := MethodFinder new possibleSolutionsForInput: { {1.2.3} . { 4 } }.
	
	"Test we have many results for the following assertion"
	self assert: results size > 10.
	
	"Test we DO copy the objects in the candidates message sends"
	self assert: (results collect: [ :each | each receiver ]) asIdentitySet size equals: results size.! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testExceptionInWrongEqualityReturns

	self should: [ { 1.2.3 } = (3 to: {5}) ] raise: Error. 
	self deny: ((MethodFinderSend receiver: 3 selector: #to: withArguments: { 5 }) resultIn: { 1.2.3 }). ! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testMethodApprovedInClassButDisapprovedInSuperClass
	"If a method f is approved by a class A but disapproved by one of 
	 its superclass, its should be approved for A instance."
	
	|bottom result |
	bottom := MethodFinderBottomClass new.
	result := (MethodFinder new findMethodsByExampleInput: { bottom } andExpectedResult:  bottom).
	self assert: ((result collect: [:each | each selector]) includes: #topDisapprovedButBottomApprovedMethod).! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testExceptionDoesNotStopTheFlow

	| bottom result |
	bottom := MethodFinderBottomClass new.
	result := (MethodFinder new findMethodsByExampleInput: { bottom . 1 } andExpectedResult: 1).
	self assert: ((result collect: [:each | each selector]) includes: #oneArgumentMethod:).! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testPermutation

	"Any order of the args should result in the same responding methods. Thus,
	 `-` should correspond to `5 . 4 -> 1` but also to `4 . 5 -> 1`.
	
	TODO : The result array should be sorted. The method which matches when 
	the arguments are not shuffled is more important than the one where the
	arguments order has to be changed."
	
	
	| bottom res args|
	bottom := MethodFinderBottomClass new.
	args := { bottom . 1 . 2 }.
	res := (MethodFinder new findMethodsByExampleInput: args andExpectedResult: 1).
	args permutationsDo: [ :p |
		self assert: res equals: (MethodFinder new findMethodsByExampleInput: p andExpectedResult: 1).
	].! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testMethodOnlyTopDefinedAndApprovedInTop
	"If a method f is approved by a class A and is not redefined 
	 in a subclass B, then if there is no information on it in B,
	 it should be approved by any instance of B."
	
	|bottom result |
	bottom := MethodFinderBottomClass new.
	result := (MethodFinder new findMethodsByExampleInput: { bottom } andExpectedResult:  bottom).
	self assert: ((result collect: [:each | each selector]) includes: #onlyTopDefinedApprovedMethod).
	! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testMethodOnlyBottomDefinedAndApprovedInBottom
	"If a method f is approved by a class A, then it
	 should be approved by any instance of A"
	
	|bottom result |
	bottom := MethodFinderBottomClass new.
	result := MethodFinder new findMethodsByExampleInput: { bottom } andExpectedResult:  bottom.
	self assert: ((result collect: [:each | each selector]) includes: #onlyBottomDefinedApprovedMethod).
	! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testForbiddenSetIsOverApprovedSet

	| bottom result |
	bottom := MethodFinderBottomClass new.
	result := (MethodFinder new findMethodsByExampleInput: { bottom } andExpectedResult: bottom ).
	self assert: (((result collect: [:each | each selector]) includes: #InApprovedAndInForbiddenSetMethod) not).! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testArgumentsNumber
	"The Method Finder should returns sends with the good number of arguments."
	
	|bottom resultZero resultOne |
	bottom := MethodFinderBottomClass new.
	resultZero := (MethodFinder new findMethodsByExampleInput: { bottom } andExpectedResult: bottom).
	resultOne  := (MethodFinder new findMethodsByExampleInput: { bottom . bottom } andExpectedResult: bottom).
	self assert: ((resultZero collect: [:each | each selector]) allSatisfy: [ :s | s keywords size = 1]).
	self assert: ((resultOne  collect: [:each | each selector]) allSatisfy: [ :s | s keywords size = 1 and: s last = $:]).! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testMethodDisapprovedInClassButApprovedInSuperClass
	"If a method f is disapproved by a class A, it should be disapproved 
	by any instance of A, no matter if A superclass approved it."
	
	|bottom result |
	bottom := MethodFinderBottomClass new.
	result := (MethodFinder new findMethodsByExampleInput: { bottom } andExpectedResult:  bottom).
	self assert: (result includes: #topApprovedButBottomDisapprovedMethod) equals: false.! !

!MethodFinderTest methodsFor: 'tests' stamp: ''!
testMethodNotDefinedInClassAndDisapprovedInSuperClass
	"If the superclass B of a class A defines a not approved method f 
	 which is not approved in A, then any instance of A should not accept f."
	
	|bottom result |
	bottom := MethodFinderBottomClass new.
	result := (MethodFinder new findMethodsByExampleInput: { bottom } andExpectedResult: bottom).
	self assert: (result includes: #onlyTopDefinedDisapprovedMethod) equals: false.! !

!MethodFinderTopClass commentStamp: ''!
Test sample for MethodFinderTest!
!MethodFinderTopClass methodsFor: 'accessing' stamp: ''!
onlyTopDefinedDisaprovedMethod

	^self! !

!MethodFinderTopClass methodsFor: 'tests' stamp: ''!
test
	^ self onlyTopDefinedDisaprovedMethod ! !

!MethodFinderTopClass methodsFor: 'accessing' stamp: ''!
topApprovedButBottomDisapprovedMethod

	^self! !

!MethodFinderTopClass methodsFor: 'accessing' stamp: ''!
topDisapprovedButBottomApprovedMethod

	^self! !

!MethodFinderTopClass methodsFor: 'accessing' stamp: ''!
onlyTopDefinedApprovedMethod
	"comment stating purpose of message"
	^ self! !

!MethodFinderTopClass class methodsFor: 'method finder' stamp: ''!
approvedSelectorsForMethodFinder

	^#(topApprovedButBottomDisapprovedMethod onlyTopDefinedApprovedMethod)! !

!MethodFinderTopClass class methodsFor: 'method finder' stamp: ''!
forbiddenSelectorsForMethodFinder
	^ #(topDisapprovedButBottomApprovedMethod)! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedTempVectorInlinedLoop
"This test is for accessing temp var c within an inlined loop scope. 
Temp var c is written in the loop and closed in a block -> therefore it is in a tempvector. "
	| a b c |
	c := nil.
	a := 1.
	[ c := 42.
	b := thisContext tempNamed:'c' . a < 1 ]
		whileTrue: [ a := a + 1.
				[ c asString ] ].
	^ b! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
helperMethod14: aVisitor
	 [ aVisitor ]
		 on: Error
		 do: [ aVisitor ]! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedTempVectorNestedBlock
	 | a |
      a  := 1.
	^[| b |
		b := a.
		[  
		 b := 2 . thisContext tempNamed: 'b' ] value] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleAccessOuterFromCleanBlock 
	<compilerOptions: #(+ optionCleanBlockClosure)>
	| b |
	b := 1. 
	^[ thisContext tempNamed: 'b' ] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedPutCopying2
	| b |
	b := 1.
	^[ | a |
		 a := b .thisContext tempNamed: 'b' put: 2. thisContext outerContext tempNamed: 'b' ] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleSimpleTemp
	| b |
	b := 1.
	^thisContext tempNamed: 'b'! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedTempCopyingNestedBlock
	
	^[| b |
		b := 1.
		[   | a |
		 a := 2.
		 a := b . thisContext tempNamed: 'b' ] value] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedTempVector2
	| b |
	b := 1.
	^[ | a |
		 b := 2 . thisContext tempNamed: 'b' ] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedPutCopying3
	| b |
	b := 1.
	^[[ | a |
		 a := b .thisContext tempNamed: 'b' put: 2. thisContext outerContext tempNamed: 'b' ] value ] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedPutCopying
	| b |
	b := 1.
	^[ | a |
		 a := b . thisContext tempNamed: 'b'  put: 2. thisContext tempNamed: 'b' ] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedPutTempVector
	| b |
	b := 1.
	^[ | a |
		 b := 2 . thisContext tempNamed: 'b' put: 3. thisContext tempNamed: 'b' ] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedTempVectorInOptimizedBlock
"temp a is in a temp vector and is accessed from with in the optimized ifTrue:ifFalse: block. But 
the definition is not in the outer block, but in the method scope"
	| result a |
	[ a := 1.
	result := true
		ifTrue: [ 1 + (thisContext tempNamed: 'a')]
		ifFalse: [ 4 ] ] value.
	^ result! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedTempVector
	| b |
	b := 1.
	^[ | a |
		 b := 2 . thisContext tempNamed: 'b' ] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
helperMethod13
	| i |
	i := 5.
	[ i=0 ] whileFalse: [ i := i - 1 ].
	^[ 1 + 2 ]! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
ivar
	^ivar! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
helperMethod12
	| i |
	i := 5.
	[ i=0 ] whileFalse: [ i := i - 1 ].! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleCopiedVarFromDeadContext
	^ self defineCopiedVarBecomeDeadContext value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedTempCopyingNestedBlock2
	 | a |
		 a := 2. 
	^[| b | 
		b := 1.
		[  
		 a := b . thisContext tempNamed: 'b' ] value] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedCopying
	| b |
	b := 1.
	^[ | a |
		 a := b . thisContext tempNamed: 'b' ] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedPutTempVector2
	| b |
	b := 1.
	^[ | a |
		 b := 2 . thisContext tempNamed: 'b' put: 3. thisContext outerContext tempNamed: 'b' ] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
exampleTempNamedCopying2
	| b |
	b := 1.
	^[ | a |
		a := b . thisContext tempNamed: 'b' ] value! !

!MethodMapExamples methodsFor: 'examples' stamp: ''!
defineCopiedVarBecomeDeadContext
	| a b |
	b := [ a := 1.a := a + 1. thisContext tempNamed:'a' ].
	^ b! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testTempNamedTempCopyingNestedBlock2
	self
		assert: (self compileAndRunExample: #exampleTempNamedTempCopyingNestedBlock2)
		equals: 1! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedPutTempVector2
	self assert: (self compileAndRunExample: #exampleTempNamedPutTempVector2) equals: 3! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testMethodSourceNodeAtInitialPC

	| method actual |
	method := self class >> testSelector.
	actual := method sourceNodeForPC: method initialPC.
	
	self assert: actual equals: method ast sendNodes first receiver receiver! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedTempVectorNestedBlock
	self assert:  (self compileAndRunExample:  #exampleTempNamedTempVectorNestedBlock ) equals: 2.! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedPutTempVector
	self assert: (self compileAndRunExample: #exampleTempNamedPutTempVector) equals: 3.! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedTempVector
	self assert: (self compileAndRunExample: #exampleTempNamedTempVector) equals: 2! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testBlockWithEnclosedBlockSourceNode
	| sourceNode |
	sourceNode := [ [ ] ] sourceNode.
	self assert: sourceNode equals: (self parseExpression: '[ [ ] ]').! !

!MethodMapTest methodsFor: 'utilities' stamp: ''!
compileMethod: aMethod

	^aMethod parseTree generate: aMethod trailer.! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testDeadContextSourceNode
	| deadContext |
	deadContext := self deadContext.
	self assert: deadContext isDead. 
	self assert: deadContext sourceNode equals: (self class>>#deadContext) ast! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedPutCopying2
	"modifying a copied temp variable will modify the value in the outer context"

	self assert: (self compileAndRunExample: #exampleTempNamedPutCopying2) equals: 2! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleAccessOuterFromCleanBlock
	self assert: (self compileAndRunExample: #exampleAccessOuterFromCleanBlock) equals: 1! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedTempVector2
	self assert: (self compileAndRunExample: #exampleTempNamedTempVector2) equals: 2! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedTempVectorInlinedLoop
	self assert:  (self compileAndRunExample:  #exampleTempNamedTempVectorInlinedLoop ) equals: 42.! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleSimpleTemp
	self assert: (self compileAndRunExample: #exampleSimpleTemp) equals: 1! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
inlinedBlockSourceNode
	1 to: 1 do: [ :i | ^ thisContext sourceNode ].! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testPrimitiveMethodSourceNodeAtInitialPC

	| method actual |
	method := SmallInteger >> #+.
	actual := method sourceNodeForPC: method initialPC.
	
	self assert: actual equals: method ast! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testThisContextSourceNodeInInlinedMessage
	| inlinedBlockSourceNode |
	"we get the method node as this is what created the context"
	inlinedBlockSourceNode := self inlinedBlockSourceNode.
	self assert: (inlinedBlockSourceNode isKindOf: RBMethodNode).! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testMethodSourceNodeAtPC
	self assert: (((Object>>#halt) sourceNodeForPC:  (Smalltalk vm for32bit: 22 for64bit: 42)) isKindOf: RBMessageNode).! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testBlockWithTempsSourceNode
	| sourceNode |
	sourceNode := [ | t1 t2 | ] sourceNode.
	self assert: sourceNode equals: (self parseExpression: '[ | t1 t2 | ]').! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testBlockWithArgAndEnclosedBlockSourceNode
	| sourceNode |
	sourceNode := [ :arg |  [ arg ] ] sourceNode.
	self assert: sourceNode equals: (self parseExpression: '[ :arg | [ arg ] ]').! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedPutCopying3
	"modifying a copied temp variable will modify the value in the outer context"

	self assert: (self compileAndRunExample: #exampleTempNamedPutCopying3) equals: 2! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedTempVectorInOptimizedBlock
	self assert:  (self compileAndRunExample:  #exampleTempNamedTempVectorInOptimizedBlock ) equals: 2.! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testBlockSourceNode
	| sourceNode |
	sourceNode := [ 1 + 2 ] sourceNode.
	self assert: sourceNode equals: (self parseExpression: '[ 1 + 2 ]').! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testTempNamedTempCopyingNestedBlock
	self
		assert: (self compileAndRunExample: #exampleTempNamedTempCopyingNestedBlock)
		equals: 1! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedCopying
	self assert: (self compileAndRunExample: #exampleTempNamedCopying) equals: 1! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedPutCopying
	self assert: (self compileAndRunExample: #exampleTempNamedPutCopying) equals: 2.! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testExampleTempNamedCopying2
	self assert: (self compileAndRunExample: #exampleTempNamedCopying2) equals: 1! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testThisContextSourceNode
	self assert: (thisContext sourceNode isKindOf: RBMethodNode).
	self assert: ([thisContext sourceNode] value isKindOf: RBBlockNode).
	self assert: ([true ifTrue: [thisContext sourceNode]]value isKindOf: RBBlockNode).! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
testBlockAndContextSourceNode
	| block blockNodeViaContext blockNodeViaClosure |
	block := [ blockNodeViaContext := thisContext sourceNode ].
	block value.
	blockNodeViaClosure := block sourceNode.

	self assert: blockNodeViaContext identicalTo: blockNodeViaClosure! !

!MethodMapTest methodsFor: 'tests - temp access' stamp: ''!
testCopiedVarFromDeadContext
	self assert:  (self compileAndRunExample:  #exampleCopiedVarFromDeadContext) equals: 2.! !

!MethodMapTest methodsFor: 'utilities' stamp: ''!
compileAndRunExample: aSelector
	| cm |
	
	cm := self compileMethod:  MethodMapExamples>>aSelector.
	^cm valueWithReceiver:  MethodMapExamples new arguments: #().! !

!MethodMapTest methodsFor: 'tests - ast mapping' stamp: ''!
deadContext
	^ thisContext! !

!MethodMapTest methodsFor: 'helpers' stamp: ''!
parseExpression: aString

	^ RBParser parseExpression: aString! !

!MethodModified commentStamp: ''!
This announcement is emitted 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: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage

	^(super affectsMethodsDefinedInPackage: aPackage) or: [ 
		oldMethod package == aPackage ]! !

!MethodModified methodsFor: 'accessing' stamp: ''!
newMethod

	^ method! !

!MethodModified methodsFor: 'accessing' stamp: ''!
oldMethod
	^ oldMethod! !

!MethodModified methodsFor: 'accessing' stamp: ''!
oldMethod: aCompiledMethod
	oldMethod := aCompiledMethod.! !

!MethodModified methodsFor: 'accessing' stamp: ''!
oldProtocol
	
	^ oldProtocol! !

!MethodModified methodsFor: 'accessing' stamp: ''!
oldProtocol: anObject
	
	oldProtocol := anObject! !

!MethodModified methodsFor: 'testing' stamp: ''!
affectsMethodsTaggedWith: tagName
	^(super affectsMethodsTaggedWith: tagName) or: [ oldProtocol = tagName ]! !

!MethodModified methodsFor: 'testing' stamp: ''!
affectsMethod: aMethod
	^(super affectsMethod: aMethod) or: [oldMethod == aMethod]! !

!MethodModified methodsFor: '*Calypso-SystemQueries' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery

	^(aMethodQuery isAffectedByChangedMethod: self oldMethod) 
		or: [ aMethodQuery isAffectedByChangedMethod: self newMethod]! !

!MethodModified methodsFor: 'accessing' stamp: ''!
newProtocol
	
	^ self protocol! !

!MethodModified class methodsFor: 'instance creation' stamp: ''!
methodChangedFrom: oldMethod to: newMethod oldProtocol: oldProtocol 
	^ self new
		method: newMethod;
		oldMethod: oldMethod;
		oldProtocol: oldProtocol;
		yourself! !

!MethodPragmaTest commentStamp: ''!
SUnit tests for method pragmas!
!MethodPragmaTest methodsFor: 'utilities' stamp: ''!
methodCategory
	^ #generated! !

!MethodPragmaTest methodsFor: 'tests - compiler' stamp: ''!
testCompileCharacter
	self assertPragma: 'foo: $a' givesKeyword: #foo: arguments: #( $a ).
	self assertPragma: 'foo: $ ' givesKeyword: #foo: arguments: #( $  ).! !

!MethodPragmaTest methodsFor: 'tests - compiler' stamp: ''!
testCompileTemps
	"Pragmas should be placeable before and after temps."

	self assert: (self compile: '| temps | <foo>' selector: #zork) pragmas notEmpty.
	self assert: (self compile: '<foo> | temps |' selector: #zork) pragmas notEmpty! !

!MethodPragmaTest methodsFor: 'tests - compiler' stamp: ''!
testCompileFull
	self assertPragma: 'foo: 1' givesKeyword: #foo: arguments: #( 1 ).
	self assertPragma: 'foo: 1 bar: 2' givesKeyword: #foo:bar: arguments: #( 1 2 ).! !

!MethodPragmaTest methodsFor: 'utilities' stamp: ''!
assertPragma: aString givesKeyword: aSymbol arguments: anArray
	| pragma |
	pragma := self pragma: aString selector: #zork.
	self assert: pragma selector equals: aSymbol.
	self assert: pragma arguments equals: anArray! !

!MethodPragmaTest methodsFor: 'tests - compiler' stamp: ''!
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: 'tests - compiler' stamp: ''!
testCompileEmpty
	self assertPragma: 'foo' givesKeyword: #foo arguments: #().! !

!MethodPragmaTest methodsFor: 'tests - primitives' stamp: ''!
testPrimitiveIndexed2
	"This test useses the #identityHash primitive."

	self compile: '<primitive: 75> ^ #idHash' selector: #idHash.
	self assert: self idHash equals: self basicIdentityHash! !

!MethodPragmaTest methodsFor: 'tests - finding' stamp: ''!
testAllNamedFromTo
	| pragmasCompiled pragmasDetected |
	pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
	pragmasDetected := Pragma allNamed: #foo: from: self class to: Object.
	self assert: pragmasDetected equals: pragmasCompiled.
	pragmasDetected := Pragma allNamed: #foo: from: Object to: Object.
	self assertEmpty: pragmasDetected! !

!MethodPragmaTest methodsFor: 'tests - finding' stamp: ''!
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 equals: (pragmasCompiled sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ])! !

!MethodPragmaTest methodsFor: 'tests - finding' stamp: ''!
testAllNamedIn
	| pragmasCompiled pragmasDetected |
	pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
	pragmasDetected := Pragma allNamed: #foo: in: self class.
	self assert: pragmasDetected equals: pragmasCompiled.

	pragmasDetected := Pragma allNamed: #foo: in: Object.
	self assertEmpty: pragmasDetected! !

!MethodPragmaTest methodsFor: 'tests - compiler' stamp: ''!
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: 'tests - method' stamp: ''!
testMethod
	| pragma |
	pragma := self pragma: 'foo' selector: #bar.
	self assert: pragma method identicalTo: self class >> #bar! !

!MethodPragmaTest methodsFor: 'tests - finding' stamp: ''!
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 equals: (pragmasCompiled sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ])! !

!MethodPragmaTest methodsFor: 'tests - compiler' stamp: ''!
testCompileString
	self assertPragma: 'foo: ''''' givesKeyword: #foo: arguments: #( '' ).
	self assertPragma: 'foo: ''bar''' givesKeyword: #foo: arguments: #( 'bar' ).! !

!MethodPragmaTest methodsFor: 'tests' stamp: ''!
testWithArgumentsDo
	| pragma wasHere |
	pragma := Pragma selector: #add:after: arguments: #(1 2).
	self
		assert:
			(pragma
				withArgumentsDo: [ :a :b | 
					self
						assert: a equals: 1;
						assert: b equals: 2.
					wasHere := true ]).
	self assert: wasHere! !

!MethodPragmaTest methodsFor: 'tests - compiler' stamp: ''!
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: 'tests' stamp: ''!
testNumArgs
	| pragma |
	pragma := Pragma selector: #value arguments: #().
	self assert: pragma numArgs equals: 0.
	pragma := Pragma selector: #+ arguments: #(1).
	self assert: pragma numArgs equals: 1.
	pragma := Pragma selector: #value:value: arguments: #(1 2).
	self assert: pragma numArgs equals: 2! !

!MethodPragmaTest methodsFor: 'tests - finding' stamp: ''!
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 equals: (pragmasCompiled sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])! !

!MethodPragmaTest methodsFor: 'utilities' stamp: ''!
pragma: aSymbol selector: aSelector times: anInteger
	^ (self 
		compile: (String streamContents: [ :stream | 
			(1 to: anInteger) asArray shuffled do: [ :each | 
				stream 
					nextPut: $<; nextPutAll: aSymbol; space;
					print: each; nextPut: $>; cr ] ])
		selector: aSelector)
			pragmas.! !

!MethodPragmaTest methodsFor: 'running' stamp: ''!
tearDown
	(self class organization listAtCategoryNamed: self methodCategory)
		do: [ :each | self class removeSelectorSilently: each ].
	self class organization removeCategory: self methodCategory.
	super tearDown! !

!MethodPragmaTest methodsFor: 'tests' stamp: ''!
testArgumentAt
	| pragma |
	pragma := Pragma selector: #value:value:value: arguments: #(3 2 1).
	self assert: (pragma argumentAt: 1) equals: 3.
	self assert: (pragma argumentAt: 2) equals: 2.
	self assert: (pragma argumentAt: 3) equals: 1! !

!MethodPragmaTest methodsFor: 'tests - compiler' stamp: ''!
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: 'tests - primitives' stamp: ''!
testPrimitiveNamed2
	"This test useses the #primPathNameDelimiter primitive."

	self compile: '<primitive: ''primitiveDirectoryDelimitor'' module: ''FilePlugin''> ^ #delim' selector: #delim.
	self assert: self delim equals: File delimiter.! !

!MethodPragmaTest methodsFor: 'tests' stamp: ''!
testSendTo
	| pragma wasHere |
	pragma := Pragma selector: #value:value: arguments: #(1 2).
	self assert:
			(pragma
				sendTo: [ :a :b | 
					self
						assert: a equals: 1;
						assert: b equals: 2.
					wasHere := true ]).
	self assert: wasHere! !

!MethodPragmaTest methodsFor: 'tests - compiler' stamp: ''!
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: 'utilities' stamp: ''!
compile: aString selector: aSelector
	self class 
		compileSilently: aSelector , String lf , aString
		classified: self methodCategory.
	^ self class >> aSelector.! !

!MethodPragmaTest methodsFor: 'tests - method' stamp: ''!
testMethodSelector
	| pragma |
	pragma := self pragma: 'foo' selector: #bar.
	self assert: pragma methodSelector identicalTo: #bar! !

!MethodPragmaTest methodsFor: 'tests - finding' stamp: ''!
testAllNamedInSortedByArgument
	| pragmasCompiled pragmasDetected |
	pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
	pragmasDetected := Pragma allNamed: #foo: in: self class sortedByArgument: 1.
	self assert: pragmasDetected equals: (pragmasCompiled sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])! !

!MethodPragmaTest methodsFor: 'utilities' stamp: ''!
pragma: aString selector: aSelector
	^ (self compile: '<' , aString , '>' selector: aSelector)
		pragmas first.! !

!MethodPragmaTest methodsFor: 'tests - primitives' stamp: ''!
testPrimitiveIndexed1
	"This test useses the #instVarAt: primitive."

	self compile: '<primitive: 74> ^ #inst' selector: #inst.
	self assert: self inst equals: #inst! !

!MethodPragmaTest methodsFor: 'tests - primitives' stamp: ''!
testPrimitiveNamedErrorCode2
	"This test useses the #primitiveDirectoryLookup primitive."

	self compile: '<primitive: ''primitiveDirectoryLookup'' module: ''FilePlugin'' error: errorCode> ^ errorCode' selector: #lookup.
	self assert: self lookup equals: nil.! !

!MethodPragmaTest methodsFor: 'tests - primitives' stamp: ''!
testPrimitiveNamed1
	"This test useses the #primitiveDirectoryLookup primitive."

	self compile: '<primitive: ''primitiveDirectoryLookup'' module: ''FilePlugin''> ^ #lookup' selector: #lookup.
	self assert: self lookup equals: #lookup.! !

!MethodPragmaTest methodsFor: 'tests - pragma' stamp: ''!
testSelector
	| pragma |
	pragma := Pragma selector: #foo: arguments: #(123).
	self assert: pragma selector equals: #foo:! !

!MethodPragmaTest methodsFor: 'tests - pragma' stamp: ''!
testArguments
	| pragma |
	pragma := Pragma selector: #foo: arguments: #(123).
	self assert: pragma arguments equals: #(123)! !

!MethodPragmaTest methodsFor: 'tests - pragma' stamp: ''!
testMessage
	| pragma message |
	pragma := Pragma selector: #foo: arguments: #(123).
	message := pragma message.
	self assert: message selector equals: #foo:.
	self assert: message arguments equals: #(123)! !

!MethodPragmaTest methodsFor: 'tests - method' stamp: ''!
testMethodClass
	| pragma |
	pragma := self pragma: 'foo' selector: #bar.
	self assert: pragma methodClass identicalTo: self class! !

!MethodPragmaTest methodsFor: 'tests - compiled' stamp: ''!
testNoPragma
	| method |
	method := self compile: '' selector: #foo.
	self assert: method pragmas equals: #()! !

!MethodQueryTest commentStamp: ''!
Unit tests for queries on methods!
!MethodQueryTest methodsFor: 'tests' stamp: ''!
testReferencedClasses

	| refs |
	refs := (CompiledMethod >> #referencedClasses) referencedClasses.
	self assertCollection: refs hasSameElements: {IdentitySet}.

	refs := thisContext method referencedClasses.
	self assertCollection: refs hasSameElements: {CompiledMethod. IdentitySet}! !

!MethodRecategorized commentStamp: ''!
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: ''!
oldProtocol
	
	^ oldProtocol! !

!MethodRecategorized methodsFor: 'accessing' stamp: ''!
oldProtocol: anObject
	
	oldProtocol := anObject! !

!MethodRecategorized methodsFor: 'testing' stamp: ''!
affectsMethodsTaggedWith: tagName
	^(super affectsMethodsTaggedWith: tagName) or: [ oldProtocol = tagName ]! !

!MethodRecategorized methodsFor: 'accessing' stamp: ''!
methodRecategorized
	
	^ method! !

!MethodRecategorized methodsFor: 'accessing' stamp: ''!
protocolsAffected
	^{self newProtocol. self oldProtocol}! !

!MethodRecategorized methodsFor: '*Calypso-SystemQueries' stamp: ''!
shouldBeConsideredByCalypsoEnvironment
	"Following case is needed to address problem when class with extension methods is moving into package where these methods are defined. At middle of such refactoring method can be in the state when it returns nil package which is inconsistent system state. It will break Calypso changes processing logic.
	This issue means that repackaging is not performed correctly. But repackaging will be announced with separate event MethodRepackaged. So it is safe to skip recategorization.
	In future this refactoring should be fixed. All objects should be in valid state when any event is triggered"
	^((oldProtocol beginsWith: '*') 
		and: [ self newProtocol = Protocol unclassified ]) not! !

!MethodRecategorized methodsFor: 'accessing' stamp: ''!
newProtocol
	
	^ self protocol! !

!MethodRecategorized class methodsFor: 'instance creation' stamp: ''!
method: aCompiledMethod oldProtocol: anOldProtocol

	^self new
		method: aCompiledMethod;
		oldProtocol: anOldProtocol;
		yourself! !

!MethodRemoved commentStamp: ''!
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: ''!
protocol
	^ protocol! !

!MethodRemoved methodsFor: 'accessing' stamp: ''!
protocol: anObject
	
	protocol := anObject! !

!MethodRemoved methodsFor: 'accessing' stamp: ''!
methodOrigin: anObject
	methodOrigin := anObject ! !

!MethodRemoved methodsFor: 'accessing' stamp: ''!
methodRemoved
	
	^ method! !

!MethodRemoved methodsFor: 'accessing' stamp: ''!
methodOrigin
	^ methodOrigin! !

!MethodRemoved methodsFor: 'testing' stamp: ''!
affectsMethodsTaggedWith: tagName
	^(super affectsMethodsTaggedWith: tagName) or: [ protocol = tagName ]! !

!MethodRemoved class methodsFor: 'instance creation' stamp: ''!
methodRemoved: aCompiledMethod protocol: aProtocol origin: aBehavior
	^self new
		method: aCompiledMethod;
		protocol: aProtocol;
		methodOrigin: aBehavior;
		yourself! !

!MethodRepackaged commentStamp: ''!
Notify about repackaging of a method!
!MethodRepackaged methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage
	^(super affectsMethodsDefinedInPackage: aPackage)
		or: [ oldPackage = aPackage ]! !

!MethodRepackaged methodsFor: 'accessing' stamp: ''!
oldPackage: anObject
	
	oldPackage := anObject! !

!MethodRepackaged methodsFor: 'accessing' stamp: ''!
packagesAffected
	^{oldPackage. newPackage}! !

!MethodRepackaged methodsFor: 'testing' stamp: ''!
affectsPackage: aPackage
	^newPackage == aPackage or: [ oldPackage == aPackage ]! !

!MethodRepackaged methodsFor: 'testing' stamp: ''!
affectsClassExtension
	^true! !

!MethodRepackaged methodsFor: 'testing' stamp: ''!
affectsClassesExtendedInPackage: aPackage
	^(super affectsClassesExtendedInPackage: aPackage)
		or: [ oldPackage = aPackage ]! !

!MethodRepackaged methodsFor: 'accessing' stamp: ''!
methodRepackaged
	
	^ method! !

!MethodRepackaged methodsFor: 'accessing' stamp: ''!
newPackage: anObject
	
	newPackage := anObject! !

!MethodRepackaged methodsFor: 'accessing' stamp: ''!
newPackage
	
	^ newPackage! !

!MethodRepackaged methodsFor: 'accessing' stamp: ''!
oldPackage
	
	^ oldPackage! !

!MethodRepackaged class methodsFor: 'instance creation' stamp: ''!
methodRepackaged: aMethod oldPackage: oldPackage newPackage: newPackage
	^self new
			method: aMethod;
			oldPackage: oldPackage;
			newPackage: newPackage;
			yourself.! !

!MethodToolbar commentStamp: ''!
A MethodToolbar is xxxxxxxxx.

self example!
!MethodToolbar methodsFor: 'initialization' stamp: ''!
initializeWidgets
	browseModel := self newButton.
	usersModel := self newButton.
	sendersModel := self newButton.
	implementorsModel := self newButton.
	versionModel := self newButton.
	dropListModel := self newDropList.
	self
		setFocusOrder;
		setBrowseModel;
		setUsersModel;
		setVersionModel;
		setSendersModel;
		setImplementorsModel! !

!MethodToolbar methodsFor: 'accessing' stamp: ''!
sendersModel

	^ sendersModel! !

!MethodToolbar methodsFor: 'accessing' stamp: ''!
usersModel
	^ usersModel! !

!MethodToolbar methodsFor: 'initialization' stamp: ''!
registerForChanges
	methodHolder
		whenChangedDo:
			[ :contents | 
			| boolean |
			boolean := contents ifNil: [ false ] ifNotNil: [ true ].
			browseModel state: boolean.
			usersModel state: boolean.
			sendersModel state: boolean.
			versionModel state: boolean.
			implementorsModel state: boolean ]! !

!MethodToolbar methodsFor: 'private' stamp: ''!
browseMethod

	methodHolder value
		ifNotNil: [:aMethod | aMethod browse ]! !

!MethodToolbar methodsFor: 'private' stamp: ''!
usersMethod
	methodHolder value methodClass ifNotNil: [ :class | self model browseClassRefsOf: class ]! !

!MethodToolbar methodsFor: 'initialization' stamp: ''!
setImplementorsModel
	
	implementorsModel
		state: false;
		label: 'Implementors';
		action: [ self implementorsMethod ].
	
! !

!MethodToolbar methodsFor: 'private' stamp: ''!
implementorsMethod

	methodHolder value
		ifNotNil: [:aMethod | self model browseMessagesFrom: aMethod selector ]! !

!MethodToolbar methodsFor: 'initialization' stamp: ''!
setBrowseModel
	
	browseModel
		state: false;
		label: 'Browse';
		action: [ self browseMethod ].
	
! !

!MethodToolbar methodsFor: 'accessing' stamp: ''!
browseModel

	^ browseModel! !

!MethodToolbar methodsFor: 'accessing' stamp: ''!
implementorsModel

	^ implementorsModel! !

!MethodToolbar methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!MethodToolbar methodsFor: 'api' stamp: ''!
emptyDropList
	
	dropListModel emptyList! !

!MethodToolbar methodsFor: 'private' stamp: ''!
addAll: aWindow  withSpec: aSpec

	aWindow
		addMorph: (self buildWithSpec: aSpec)
		fullFrame: (LayoutFrame identity bottomFraction: 0; bottomOffset: 30).
		! !

!MethodToolbar methodsFor: 'initialization' stamp: ''!
initialize

	methodHolder := nil asValueHolder.
	model := AbstractTool new.
	
	super initialize.! !

!MethodToolbar methodsFor: 'private' stamp: ''!
sendersMethod

	methodHolder value
		ifNotNil: [:aMethod | self model browseSendersOfMessagesFrom: aMethod selector ]! !

!MethodToolbar methodsFor: 'initialization' stamp: ''!
setFocusOrder

	self focusOrder
		add: browseModel;
		add: usersModel;
		add: sendersModel;
		add: implementorsModel;
		add: versionModel.
		! !

!MethodToolbar methodsFor: 'initialization' stamp: ''!
setVersionModel
	
	versionModel
		state: false;
		label: 'Version';
		action: [ self versionMethod ].
	
! !

!MethodToolbar methodsFor: 'api' stamp: ''!
addItemLabeled: aString do: aBlock

	dropListModel addItemLabeled: aString do: aBlock! !

!MethodToolbar methodsFor: 'accessing' stamp: ''!
dropListModel

	^ dropListModel! !

!MethodToolbar methodsFor: 'accessing' stamp: ''!
versionModel

	^ versionModel! !

!MethodToolbar methodsFor: 'api' stamp: ''!
method: aMethod

	methodHolder value: aMethod! !

!MethodToolbar methodsFor: 'initialization' stamp: ''!
setUsersModel
	usersModel
		state: false;
		label: 'Users';
		action: [ self usersMethod ]! !

!MethodToolbar methodsFor: 'private' stamp: ''!
versionMethod

	methodHolder value
		ifNotNil: [:aMethod | self model browseVersionsFrom: aMethod ]! !

!MethodToolbar methodsFor: 'initialization' stamp: ''!
setSendersModel
	
	sendersModel
		state: false;
		label: 'Senders';
		action: [ self sendersMethod ].
	
! !

!MethodToolbar class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := MethodToolbar new.
	example
		method: ButtonPresenter >> #state:;
		method: nil;
		extent: 550 @ 100;
		openWithSpec.
		^example ! !

!MethodToolbar class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	^ SpecLayout composed
		newRow:
				[ :row | 
			row
				add: #(#model #browseModel);
				add: #(#model #usersModel);
				add: #(#model #sendersModel);
				add: #(#model #implementorsModel);
				add: #(#model #versionModel);
				add: #(#model #dropListModel) ];
		yourself! !

!MethodToolbar class methodsFor: 'specs' stamp: ''!
title

	^ 'Toolbar'! !

!MicAbstractAnnotatedBlock methodsFor: 'accessing' stamp: ''!
body
	^ body! !

!MicAbstractAnnotatedBlock methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	isClosed := false.! !

!MicAbstractAnnotatedBlock methodsFor: 'testing' stamp: ''!
lineMarkup

	^ self subclassResponsibility! !

!MicAbstractAnnotatedBlock methodsFor: 'testing' stamp: ''!
addLineAndReturnNextNode: line
	"line is assumed to be of the form '@@label some text
	
	'
	"

	isClosed
		ifTrue: [ ^ self ].
	label 
		ifNil: [ 
			| indexOfFirstSpace |
			indexOfFirstSpace := line indexOf: Character space.
			label := line copyFrom: self lineMarkup size + 1 to: indexOfFirstSpace - 1.
			body := (line copyFrom: indexOfFirstSpace + 1 to: line size) trim ]
		ifNotNil: [ body := body , String cr , line ]! !

!MicAbstractAnnotatedBlock methodsFor: 'testing' stamp: ''!
canConsumeLine: line
	"return if this block can consume line"

	"it can be dangerous but let us try"
	^ line isNotEmpty ! !

!MicAbstractAnnotatedBlock methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!MicAbstractBlock commentStamp: ''!
I am the abstract node of the block objects generated by `MicroDownParser`.

The root of the parsetree is an instance of `MicRootBlock`.
I have a set of children, and an uplink to my parent.

See the comment of `MicroDownParser` for an overview of the algorithm used in building such parse tree.!
!MicAbstractBlock methodsFor: 'accessing' stamp: ''!
text
	| text |
	text := ''.
	children do: [ :each | text := text , each text ].
	^ text! !

!MicAbstractBlock methodsFor: 'public' stamp: ''!
newBlockFor: line parent: parentBlock
	| newBlockClass |
	newBlockClass := self blockStarterClassFrom: line.
	newBlockClass ifNil: [ ^parentBlock ].
	^ newBlockClass new
		setParser: parser;
		parent: parentBlock;
		addLineAndReturnNextNode: line! !

!MicAbstractBlock methodsFor: 'initialization' stamp: ''!
initialize
	super initialize. 
	children := OrderedCollection new.! !

!MicAbstractBlock methodsFor: 'public' stamp: ''!
closeMe
	"I'm hook for closing elements. By default do nothing."
	
	^ self! !

!MicAbstractBlock methodsFor: 'accessing' stamp: ''!
indent
	^ parent indent! !

!MicAbstractBlock methodsFor: 'testing' stamp: ''!
listItemBlockClass
	^ MicListItemBlock! !

!MicAbstractBlock methodsFor: 'adding' stamp: ''!
children
	^children ! !

!MicAbstractBlock methodsFor: 'public' stamp: ''!
blockExtensionStarterClassFrom: line
	"return the class of a block which can start with line, or nil if none"

	^ nil! !

!MicAbstractBlock methodsFor: 'public' stamp: ''!
addLineAndReturnNextNode: line
	"add line to this node. 
	Notice, the action is allowed to create new nodes in the block tree.
	Returns the node to handle next line - typically self."

	self subclassResponsibility.
	^ self! !

!MicAbstractBlock methodsFor: 'public' stamp: ''!
blockStarterClassFrom: line
	"return the class of a block which can start with line, or nil if none"

	^ (self parser blockStarterClassFrom: line) ifNotNil: [ :c | c alternateBlockClassFor: line ]! !

!MicAbstractBlock methodsFor: 'private' stamp: ''!
parser
	^ parser ! !

!MicAbstractBlock methodsFor: 'public' stamp: ''!
canConsumeLine: line
	"return if this block can consume line"

	^ self subclassResponsibility ! !

!MicAbstractBlock methodsFor: 'adding' stamp: ''!
children: aCollection
 	children := aCollection! !

!MicAbstractBlock methodsFor: 'public' stamp: ''!
computeNestedLevel 

	^ 0! !

!MicAbstractBlock methodsFor: 'private' stamp: ''!
parserClass 
	^ MicroDownParser ! !

!MicAbstractBlock methodsFor: 'adding' stamp: ''!
addChild: childBlock
	children add: childBlock! !

!MicAbstractBlock methodsFor: 'properties' stamp: ''!
hasProperty: aKey
	"Test if the property aKey is present."
	
	^ self properties notNil and: [ self properties includesKey: aKey ]! !

!MicAbstractBlock methodsFor: 'private' stamp: ''!
setParser: aParser
	parser := aParser ! !

!MicAbstractBlock methodsFor: 'public' stamp: ''!
nestedLevel 
	"Return the nesting level of main blocks. Basically only list increases this."
	
	^ 0! !

!MicAbstractBlock class methodsFor: 'public' stamp: ''!
alternateBlockClassFor: line
	"This hook supports extensions of environments. 
	we get <?slide ... and we do not create an environment but a slideBlock"
	^ self! !

!MicAbstractDelimiter commentStamp: ''!
I represent a delimiter used in grammar. I'm abstract.
I'm useful for inline split parsing process.

Methods to overide:
- isCloser, isOpener: answer true or false whether am I a closing markup or an opening markup (I can be both for a format for instance, when markup is the same for both uses)
- type: my type name, as a symbol
- markup (a string)

isActive is true when I must be part of searched delimiters during normal inline split process.
(false for instance for delimiters relative to link or figure since they are analyzed in special procedure)

My index refers to the index character in global string which is parsed.

Always instantiate me with my constructor "index:" to precise it.!
!MicAbstractDelimiter methodsFor: 'testing' stamp: ''!
isActive
	^ self class isActive! !

!MicAbstractDelimiter methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ self class associatedInlineBlock ! !

!MicAbstractDelimiter methodsFor: 'testing' stamp: ''!
isOpener
	^ self class isOpener! !

!MicAbstractDelimiter methodsFor: 'printing' stamp: ''!
printOn: aStream
	| name |
	name := self class name.
	aStream nextPutAll: (self class name copyFrom: 4 to: name size - 'Delimiter' size ).
	aStream nextPut: $:; space ; nextPutAll: self markup
	! !

!MicAbstractDelimiter methodsFor: 'accessing' stamp: ''!
size
	^ self class size! !

!MicAbstractDelimiter methodsFor: 'testing' stamp: ''!
markup
	^ self class markup! !

!MicAbstractDelimiter methodsFor: 'accessing' stamp: ''!
index: anInteger
	index := anInteger! !

!MicAbstractDelimiter methodsFor: 'testing' stamp: ''!
isCloser
	^ self class isCloser! !

!MicAbstractDelimiter methodsFor: 'accessing' stamp: ''!
type
	^ self class type! !

!MicAbstractDelimiter methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!MicAbstractDelimiter class methodsFor: 'testing' stamp: ''!
isActive
	^ true! !

!MicAbstractDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ self subclassResponsibility! !

!MicAbstractDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ self subclassResponsibility ! !

!MicAbstractDelimiter class methodsFor: 'testing' stamp: ''!
isCloserOnly
	^ self isCloser and: self isOpener not! !

!MicAbstractDelimiter class methodsFor: 'accessing' stamp: ''!
size
	^ self markup size! !

!MicAbstractDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ self subclassResponsibility ! !

!MicAbstractDelimiter class methodsFor: 'testing' stamp: ''!
isOpenerOnly
	^ self isCloser not and: [ self isOpener ]! !

!MicAbstractDelimiter class methodsFor: 'testing' stamp: ''!
isBoth
	^ self isCloser and: self isOpener! !

!MicAbstractDelimiter class methodsFor: 'accessing' stamp: ''!
index: anIndex
	^ self new index: anIndex; yourself! !

!MicAbstractDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ self subclassResponsibility ! !

!MicAbstractDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ self subclassResponsibility ! !

!MicAbstractMicrodownTextualBuilder commentStamp: ''!
I'm a copy of Pillar textual canvas. I should be fusioned in my subclass.
We should revisit the API because parsing lines is a not really good design.!
!MicAbstractMicrodownTextualBuilder methodsFor: 'writing text' stamp: ''!
newLine
	self raw: newLineCharacterString.
	lastIsNewLine := true! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing' stamp: ''!
writeLinkDuring: aBlockClosure destination: aString 
	
	self
		writeLinkDuring: aBlockClosure
		destination: aString
		title: nil! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing' stamp: ''!
writeNewLine
	self raw: String cr
	! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing' stamp: ''!
writeDuring: aBlock surroundBy: anOpenerMarkup and: aCloserMarkup

	self raw: anOpenerMarkup.
	aBlock value.
	self raw: aCloserMarkup! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'formatting' stamp: ''!
italic: aText

	self writeText: aText surroundBy: parserClass italicMarkup! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'formatting' stamp: ''!
strike: aText

	self writeText: aText surroundBy: parserClass strikeMarkup! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing' stamp: ''!
writeLinkDuring: aBlockClosure destination: aDestination title: aTitle 

	self raw: '['.
	aBlockClosure ensure: [ 
		self
			raw: '](';
			raw: aDestination.
		
		aTitle ifNotNil: [ 
			self
				raw: ' "';
				raw: aTitle;
				raw: '"'.
		].
		self raw: ')'
	 ]! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing text' stamp: ''!
nextPut: aCharacter
	stream nextPut: aCharacter.
	lastIsNewLine := false! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'initialization' stamp: ''!
setStream: aStream 
	stream := aStream! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'formatting' stamp: ''!
bold: aText

	self writeText: aText surroundBy: parserClass boldMarkup! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'accessing' stamp: ''!
contents
	^ stream contents! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'initialization' stamp: ''!
flush
	stream flush! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing low-level' stamp: ''!
potentialNewLine
	lastIsNewLine ifFalse: [ self newLine ]! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing text' stamp: ''!
line: aString
	self
		nextPutAll: aString;
		newLine! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	stream := (String new: 1000) writeStream.
	parserClass := MicroDownParser.
	newLineCharacterString := String cr.
	lastIsNewLine := true! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing' stamp: ''!
text: aText
	self raw: aText
	! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'initialization' stamp: ''!
setNewLineCharacterString: aLine
	newLineCharacterString := aLine! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'testing' stamp: ''!
lastIsNewLine
	^ lastIsNewLine! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing text' stamp: ''!
space
	stream space! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'formatting' stamp: ''!
monospace: aText

	self writeText: aText surroundBy: parserClass monospaceMarkup! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing' stamp: ''!
writeText: aText surroundBy: aMarkup
	self writeText: aText surroundBy: aMarkup and: aMarkup! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing text' stamp: ''!
nextPutAll: aString
	
	aString do: [ :char | self nextPut: char ]! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing text' stamp: ''!
raw: aString
	stream << aString! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing' stamp: ''!
writeText: aText surroundBy: anOpenerMarkup and: aCloserMarkup
	self
		raw: anOpenerMarkup;
		raw: aText;
		raw: aCloserMarkup! !

!MicAbstractMicrodownTextualBuilder methodsFor: 'writing' stamp: ''!
writeText: aText beginsWith: aMarkup
	self
		raw: aMarkup;
		raw: String space;
		raw: aText! !

!MicAbstractMicrodownTextualBuilder class methodsFor: 'instance creation' stamp: ''!
on: aStream 
	^ self new
		setStream: aStream;
		yourself! !

!MicAnchorBlock commentStamp: ''!
I'm block that represents an anchor to a section. This way text can refer to the anchor to refer to the section. 

```
# A section
@mylovelySection
``` !
!MicAnchorBlock methodsFor: 'accessing' stamp: ''!
label: anObject
	label := anObject! !

!MicAnchorBlock methodsFor: 'public' stamp: ''!
addLineAndReturnNextNode: line
	"# bla
	@myanchor
	"
	label := (line copyFrom: parser anchorMarkup size + 1 to: line size) trim.
	^ self! !

!MicAnchorBlock methodsFor: 'testing' stamp: ''!
hasLabel 
	label ifNil: [ ^ false ].
	^ true! !

!MicAnchorBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitAnchor: self! !

!MicAnchorBlock methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!MicAnchorBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicAnchorBlock ! !

!MicAnchorBlockTest methodsFor: 'tests' stamp: ''!
testModifyLabel
	| mic |
	mic := (parser parse: '@label') children first.
	self assert: mic label equals: 'label'.
	mic label: 'label2'.
	self assert: mic label equals: 'label2'.! !

!MicAnchorReferenceBlock commentStamp: ''!
I represent a reference to a section, figure, environment. I follow the pattern `*@`, label, `@*`

```
See *@fig1@*
```
!
!MicAnchorReferenceBlock methodsFor: 'initialization' stamp: ''!
kind

	^ #anchorReference! !

!MicAnchorReferenceBlock methodsFor: 'visiting' stamp: ''!
openingDelimiter

 	^ MicAnchorReferenceOpenerDelimiter markup! !

!MicAnchorReferenceBlock methodsFor: 'accessing' stamp: ''!
reference: aReference
	reference := aReference! !

!MicAnchorReferenceBlock methodsFor: 'visiting' stamp: ''!
referenceAsHTML	
	| ref |
	self flag: #todo.
	ref := self reference.
	(ref endsWith: '.mic')
		ifTrue: [ ref := (ref copyUpToLast: $.) , '.html' ]
		ifFalse: [ Error signal: 'Reference : ' , ref , ' should end with .pillar or .pier' ].
	^ ref! !

!MicAnchorReferenceBlock methodsFor: 'visiting' stamp: ''!
closingDelimiter

 	^ MicAnchorReferenceCloserDelimiter markup! !

!MicAnchorReferenceBlock methodsFor: 'accessing' stamp: ''!
reference
	^ reference! !

!MicAnchorReferenceBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitAnchorReference: self! !

!MicAnchorReferenceBlock class methodsFor: 'testing' stamp: ''!
isEvaluated
	^ false! !

!MicAnchorReferenceCloserDelimiter commentStamp: ''!
An anchor reference represents a reference to a section, figure, environment. It follows the pattern `*@`, label, `@*`

```
See *@fig1@*
```!
!MicAnchorReferenceCloserDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicAnchorReferenceBlock ! !

!MicAnchorReferenceCloserDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ false! !

!MicAnchorReferenceCloserDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '@*'! !

!MicAnchorReferenceCloserDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ true! !

!MicAnchorReferenceCloserDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #anchorReference ! !

!MicAnchorReferenceOpenerDelimiter commentStamp: ''!
An anchor reference represents a reference to a section, figure, environment. It follows the pattern `*@`, label, `@*`

```
See *@fig1@*
```!
!MicAnchorReferenceOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicAnchorReferenceBlock ! !

!MicAnchorReferenceOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicAnchorReferenceOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '*@'! !

!MicAnchorReferenceOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ false! !

!MicAnchorReferenceOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #anchorReference! !

!MicAnnotatedBlock commentStamp: ''!
I represent a paragraph with the title. My title can only contain a string while my body can contain formatted text.

I'm created with `!!!!paragraph` (such as `@@note` `@@important` in Pillar).

!!!!note This is important so I used exclamatation mark.

### Known limits. 
We should revisit the implementation because there is something unclear. 
Currently we cannot add list for example inside a annotatedBlock.
See [https://github.com/pillar-markup/MicroDown/issues/54](https://github.com/pillar-markup/MicroDown/issues/54)
!
!MicAnnotatedBlock methodsFor: 'accessing' stamp: ''!
textElements

	^ self body! !

!MicAnnotatedBlock methodsFor: 'parse support' stamp: ''!
closeMe
	super closeMe.
	body := self inlineParse: body! !

!MicAnnotatedBlock methodsFor: 'testing' stamp: ''!
lineMarkup
	"Normally !!!!"
	^ parser annotatedParagraphMarkup! !

!MicAnnotatedBlock methodsFor: 'testing' stamp: ''!
addLineAndReturnNextNode: line
	"line is assumed to be of the form '@@label some text
	
	'
	"

	isClosed
		ifTrue: [ ^ self ].
	label 
		ifNil: [ 
			| indexOfFirstSpace |
			indexOfFirstSpace := line indexOf: Character space.
			label := line copyFrom: self lineMarkup size + 1 to: indexOfFirstSpace - 1.
			body := (line copyFrom: indexOfFirstSpace + 1 to: line size) trim ]
		ifNotNil: [ body := body , String cr , line ]! !

!MicAnnotatedBlock methodsFor: 'testing' stamp: ''!
canConsumeLine: line
	"return if this block can consume line"

	"it can be dangerous but let us try"
	^ line isNotEmpty ! !

!MicAnnotatedBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitAnnotated: self! !

!MicAnnotatedBlock methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!MicAnnotatedBlock methodsFor: 'accessing' stamp: ''!
text

	^ String streamContents: [ :s | self textElements do: [ :each | s nextPutAll: each substring ] ]! !

!MicAnnotationBlock commentStamp: ''!
I represent an annotation delimted by `<?` and '?>`: a tag with parameters.

The following is a citation annotation with as parameters the name variable bound to the string 'Duca99a'.

```
?{citation|name=Duca99a}?
```

```
MicroDownParser parse: '?{citation|name=Duca99a}?'

```!
!MicAnnotationBlock methodsFor: 'accessing' stamp: ''!
kind

	^ #annotation! !

!MicAnnotationBlock methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	arguments := OrderedDictionary new! !

!MicAnnotationBlock methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!MicAnnotationBlock methodsFor: 'visiting' stamp: ''!
closeMe 
	| splitter |
	splitter := MicArgumentsSplitter withString: substring.
	name := splitter name trimBoth.
	arguments := splitter arguments.! !

!MicAnnotationBlock methodsFor: 'accessing' stamp: ''!
arguments: anArguments
	arguments := anArguments! !

!MicAnnotationBlock methodsFor: 'accessing' stamp: ''!
openingDelimiter

 	^ MicAnnotationOpenerDelimiter markup! !

!MicAnnotationBlock methodsFor: 'accessing' stamp: ''!
printOn: aStream

	aStream nextPutAll: self openingDelimiter.
	aStream nextPutAll: self substring.
	aStream nextPutAll: self closingDelimiter.! !

!MicAnnotationBlock methodsFor: 'accessing' stamp: ''!
closingDelimiter

 	^ MicAnnotationCloserDelimiter markup! !

!MicAnnotationBlock methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!MicAnnotationBlock methodsFor: 'accessing' stamp: ''!
name: aName
	name := aName! !

!MicAnnotationBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitAnnotation: self! !

!MicAnnotationBlock methodsFor: 'accessing' stamp: ''!
parameterAt: aKey put: aValue
	^ arguments at: aKey put: aValue! !

!MicAnnotationBlock class methodsFor: 'accessing' stamp: ''!
tag
	^ #empty! !

!MicAnnotationBlock class methodsFor: 'instance creation' stamp: ''!
from: aStartInteger to: anEndInteger withSubstring: aString withChildren: aChildren
	
	| splitter tag klass |
	splitter := MicArgumentsSplitter withString: aString.
	tag := splitter name trimBoth.
	self flag: #fixme.
	"we should pass the splitter and not reparse it in closeMe"
	
	klass := self subclasses detect: [ :each | each tag = tag ] ifNone: [ self ].

	^ klass new 
		start: aStartInteger; 
		end: anEndInteger; 
		substring: aString; 
		children: aChildren; 
		cleanSubstring; 
		closeMe; 
		yourself.	! !

!MicAnnotationCloserDelimiter commentStamp: ''!
An anchor reference represents a reference to a section, figure, environment. It follows the pattern `*@`, label, `*`

```
See *@fig1*
```!
!MicAnnotationCloserDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicAnnotationBlock ! !

!MicAnnotationCloserDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ false! !

!MicAnnotationCloserDelimiter class methodsFor: 'accessing' stamp: ''!
markup

	^ '}?'! !

!MicAnnotationCloserDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ true! !

!MicAnnotationCloserDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #annotation! !

!MicAnnotationOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicAnnotationBlock ! !

!MicAnnotationOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicAnnotationOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
markup

	^ '?{'! !

!MicAnnotationOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ false! !

!MicAnnotationOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #annotation! !

!MicArgumentsSplitter commentStamp: ''!
I'm responsible to handle `'width=80&anchor=here'` and in particular to identify the first tag of such expression since it is important for code block.
I copied two utility method from Zinc to make sure that the resulting dictionary is ordered.!
!MicArgumentsSplitter methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments ifNil: [ ^ arguments := self parseQuery ]! !

!MicArgumentsSplitter methodsFor: 'accessing' stamp: ''!
firstTag 
	^ firstTag ifNil: [ 
		firstTag := (stream upTo: $=) asSymbol. 
		stream position: 0.
		^ firstTag ]! !

!MicArgumentsSplitter methodsFor: 'query parsing' stamp: ''!
parseQueryFrom: aStream

	| string index fields |
	fields := OrderedDictionary new.
	[ aStream atEnd ] whileFalse: [
		string := aStream upTo: $&.
		index := string indexOf: $=.
		index > 0
			ifFalse: [ fields at: (self decodePercentForQuery: string) trimBoth asSymbol put: nil ]
			ifTrue: [
				fields
					at: (self decodePercentForQuery: (string copyFrom: 1 to: index - 1)) trimBoth asSymbol
					add: (self decodePercentForQuery: (string copyFrom: index + 1 to: string size)) ] ].
	^ fields! !

!MicArgumentsSplitter methodsFor: 'query parsing' stamp: ''!
parseQuery

	| string index fields |
	fields := OrderedDictionary new.
	[ stream atEnd ] whileFalse: [
		string := stream upTo: $&.
		index := string indexOf: $=.
		index > 0
			ifFalse: [ fields at: (self decodePercentForQuery: string) trimBoth asSymbol put: nil ]
			ifTrue: [
				fields
					at: (self decodePercentForQuery: (string copyFrom: 1 to: index - 1)) trimBoth asSymbol
					add: (self decodePercentForQuery: (string copyFrom: index + 1 to: string size)) ] ].
	^ fields! !

!MicArgumentsSplitter methodsFor: 'accessing' stamp: ''!
stream: aStream
	stream := aStream! !

!MicArgumentsSplitter methodsFor: 'query parsing' stamp: ''!
decodePercentForQuery: string
	^ ZnPercentEncoder new 
		decodePlusAsSpace: true; 
		decode: string! !

!MicArgumentsSplitter methodsFor: 'accessing' stamp: ''!
name
	^ name ifNil: [ ^ name := (stream upTo: self parserClass argumentListStartDelimiter first) contents asString; yourself ]! !

!MicArgumentsSplitter methodsFor: 'accessing' stamp: ''!
parserClass
	^ MicroDownParser ! !

!MicArgumentsSplitter class methodsFor: 'instance creation' stamp: ''!
withStream: aStream
	^ self new stream: aStream; yourself! !

!MicArgumentsSplitter class methodsFor: 'instance creation' stamp: ''!
withString: aString
	^ self new stream: (aString readStream); yourself! !

!MicBlockTest methodsFor: 'tests' stamp: ''!
testPropertyAtIfAbsent
	self assert: (self instance propertyAt: #foo put: 'bar') equals: 'bar'.
	self assert: (self instance propertyAt: #foo ifAbsent: [ 'baz' ]) equals: 'bar'.
	self assert: (self instance propertyAt: #bar ifAbsent: [ 'baz' ]) equals: 'baz'! !

!MicBlockTest methodsFor: 'tests' stamp: ''!
testPropertyAtPut
	self instance propertyAt: #foo put: 'bar'.
	self assert: (self instance propertyAt: #foo) equals: 'bar'.

	self instance propertyAt: #foo put: 'baz'.
	self assert: (self instance propertyAt: #foo) equals: 'baz'! !

!MicBlockTest methodsFor: 'tests' stamp: ''!
testPropertyAt
	self assert: (self instance propertyAt: #foo put: 'bar') equals: 'bar'.
	self assert: (self instance propertyAt: #foo) equals: 'bar'.
	self should: [ self instance propertyAt: #bar ] raise: MicPropertyError! !

!MicBlockTest methodsFor: 'tests' stamp: ''!
testProperties
	self assert: self instance properties isNotNil.
	self instance instVarNamed: 'properties' put: nil.

	self instance propertyAt: #foo put: #bar.
	self instance instVarNamed: 'properties' put: nil.

	self instance propertyAt: #foo ifAbsent: [ nil ].
	self instance instVarNamed: 'properties' put: nil.

	self instance propertyAt: #foo ifAbsentPut: [ #bar ].
	self instance instVarNamed: 'properties' put: nil.

	self instance hasProperty: #foo.
	self instance instVarNamed: 'properties' put: nil! !

!MicBlockTest methodsFor: 'tests' stamp: ''!
testHasProperty
	self deny: (self instance hasProperty: #foo).
	self instance propertyAt: #foo put: 'bar'.
	self assert: (self instance hasProperty: #foo).
	self deny: (self instance hasProperty: #bar)! !

!MicBlockTest methodsFor: 'tests' stamp: ''!
testSanity
	"If this test case fails, there is something wrong with the setup of the test-case."

	self
		assert: self testedClass isAbstract not
		description: 'Unable to test abstract class.'.
	self
		assert: self instance class equals: self testedClass
		! !

!MicBlockTest class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self = MicBlockTest! !

!MicBoldDelimiter commentStamp: ''!
I am the delimiter for bold/strong format.!
!MicBoldDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicBoldFormatBlock ! !

!MicBoldDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicBoldDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '**'! !

!MicBoldDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ true! !

!MicBoldDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #bold! !

!MicBoldFormatBlock commentStamp: ''!
I represent a bold text section. I'm delimited using `**` as in `**bold**` to obtain **bold**.!
!MicBoldFormatBlock methodsFor: 'utilcaca' stamp: ''!
kind
	^ #bold! !

!MicBoldFormatBlock methodsFor: 'utilcaca' stamp: ''!
openingDelimiter

 	^ MicBoldDelimiter markup! !

!MicBoldFormatBlock methodsFor: 'utilcaca' stamp: ''!
closingDelimiter

 	^ MicBoldDelimiter markup! !

!MicBoldFormatBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitBold: self! !

!MicBrokenResource methodsFor: 'converting' stamp: ''!
asFileReference

	^ self error! !

!MicCitationBlock methodsFor: 'accessing' stamp: ''!
ref
	^ arguments at: 'ref' 
		ifAbsent: [ ^ '' ]! !

!MicCitationBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	aVisitor visitCitation: self! !

!MicCitationBlock class methodsFor: 'accessing' stamp: ''!
tag

	^ #citation! !

!MicCitationBlockTest methodsFor: 'tests' stamp: ''!
testDefaultingClassWhenNoTag
	
	| doc |
	doc := MicroDownParser new parse: '?{citation2|key=Duca99a}?'.
	self assert: doc children first children first class equals: MicAnnotationBlock.
	self assert: doc children first children first name equals: 'citation2'.
	self assert: (doc children first children first arguments at: #key) equals: 'Duca99a'.! !

!MicCitationBlockTest methodsFor: 'tests' stamp: ''!
testCreateTheRightCitationObject
	
	| doc |
	doc := MicroDownParser new parse: '?{citation|key=Duca99a}?'.
	self assert: doc children first children first class equals: MicCitationBlock.
	self assert: doc children first children first name equals: 'citation'.
	self assert: (doc children first children first arguments at: #key) equals: 'Duca99a'.! !

!MicCodeBlock commentStamp: ''!
I am a code block. I look like this, starting and ending with three $`
my 'arguments' is just the text from the fourth character up to the end of line.

```
 ```arguments
 line 1
 line 2
 line 3
 ``` 
```

A codeblock does not interpreter its contents. 
You can however specify different tag and multiple argument. 

```
	```language=pharo|caption=A method&label=method 
	pharoMotto 
		^ 'Doing something every is the best way to make progress'
	```
```


For now we do not support the use of multiple backticks. The markup is only 3 backticks. If you want to embed codeblock inside codeblock you must use an extra space. 

```
 ```
  ```
  A nested codeblock
  ```
 ```
```

#### Implementation thoughts
The current implementation stores lines in a single text and this is a bad idea because first what if the user use lf in his text!!
Second if we want to treat lines separatedly we have to reparse it. Now we do not need it so this is good but this is just by chance!!!
!MicCodeBlock methodsFor: 'accessing' stamp: ''!
code
	^ self body! !

!MicCodeBlock methodsFor: 'handle' stamp: ''!
extractFirstLineFrom: aLine
	"language=Pharo&label=fig1&caption=La vie est belle"
	"The first tag is language.
	its value is Pharo."
	
	| lineWithoutMarkup argumentsSplitter |
	lineWithoutMarkup := super extractFirstLineFrom: aLine.
	argumentsSplitter := MicArgumentsSplitter withString: lineWithoutMarkup.
	firstTag := argumentsSplitter firstTag.
	arguments := argumentsSplitter arguments.
	^ lineWithoutMarkup! !

!MicCodeBlock methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	arguments := OrderedDictionary new.! !

!MicCodeBlock methodsFor: 'utilspipi' stamp: ''!
lineStartMarkup
	"a code block is delimited by ``` "
	
	^ self parser codeblockMarkup ! !

!MicCodeBlock methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!MicCodeBlock methodsFor: 'accessing' stamp: ''!
firstTag
	^ firstTag! !

!MicCodeBlock methodsFor: 'public access' stamp: ''!
isEvaluated 
	arguments at: #eval ifAbsent: [ ^ false ].
	^ arguments at: #eval! !

!MicCodeBlock methodsFor: 'accessing' stamp: ''!
hasFirstTag

	^ firstTag isNotEmpty! !

!MicCodeBlock methodsFor: 'accessing' stamp: ''!
firstTagValue
	^ arguments at: self firstTag ifAbsent: [ '' ]! !

!MicCodeBlock methodsFor: 'accessing' stamp: ''!
language
	arguments ifNotEmpty: [ 
		arguments at: #language ifAbsent: [ ^ arguments keys first asString ].
		^ arguments at: #language ].
	^ ''! !

!MicCodeBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitCode: self! !

!MicCodeBlock methodsFor: 'visiting' stamp: ''!
label
	^ arguments at: #label ifAbsent: [ '' ]! !

!MicCodeBlockTest commentStamp: ''!
I'm is a test class for testing the behavior of MicCodeBlock


For now we do not support the use of multiple backticks. 

If you want to embed codeblock inside codeblock you must use an extra space. 

```
 ```
 A nested codeblock
 ```
```!
!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testCodeBlockWithNestedCodeBlock
	"This test shows that we can write a code block inside a code block but that the later is not interpreter."
	
	| source root code textBody |
	textBody := ' ``` 
 my fancy code
 is really cool
 ```'.
	source := parser codeblockMarkup,  String cr, textBody, String cr, parser codeblockMarkup. 
	root := parser parse: source.
	
	self 
		assert: root children size 
		equals: 1.
	code := root children first.
	self assert: code children isEmpty.
	self
		assert: code code
		equals: textBody.
	! !

!MicCodeBlockTest methodsFor: 'tests - first tag' stamp: ''!
testHasFirstTag

	| source codeBlock |
	source := parser codeblockMarkup, 'language=PharoMethod', String cr, 'Color >> asMorph
    ^ Morph new color: self' , String cr, parser codeblockMarkup. 
   codeBlock :=(self parser parse: source) children first.
	self assert:  codeBlock hasFirstTag.
	self assert:  codeBlock firstTag equals: 'language'.! !

!MicCodeBlockTest methodsFor: 'tests - deviation' stamp: ''!
testFourBackQuotes

	| codeBlock |
	codeBlock := parser parse: '```` 
something in the way
````'.

	self assert: codeBlock children first body equals: 'something in the way'! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicCodeBlock ! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testBody
	| source root textBody |
	textBody := 'my fancy code
is really cool'.
	source := parser codeblockMarkup, String cr, textBody, String cr, parser codeblockMarkup. 
	root := parser parse: source.
	self assert: root children first body equals: textBody.
	! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testSingleCodeBlockTwoLines
	| source root code textBody argument |
	textBody := 'my fancy code
is really cool'.
	argument := 'ArgumentGoesHere'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := parser parse: source.
	self 
		assert: root children size 
		equals: 1.
	code := root children first.
	self
		assert: code code
		equals: textBody.
	self 
		assert: (code arguments at: #ArgumentGoesHere) isNil.
	self assert: code firstTag equals: argument! !

!MicCodeBlockTest methodsFor: 'tests - first tag' stamp: ''!
testFirstTagValue

	| source codeBlock |
	source := parser codeblockMarkup, 'language=12', String cr, 'Color >> asMorph
    ^ Morph new color: self' , String cr, parser codeblockMarkup. 
   codeBlock :=(self parser parse: source) children first.
	self assert:  codeBlock firstTagValue equals: '12'.! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testNoFirstTag

	"
	```
Color >> asMorph
    ^ Morph new color: self
	```
	"
	| source root code  textBody argument |
	textBody := 'Color >> asMorph
    ^ Morph new color: self'.
	argument := ''.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := self parser parse: source.
	self assert: root children size equals: 1.
	code := root children first.
	self assert: code firstTag equals: ''.
	self assert: code arguments isEmpty! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testOpenCanConsumeLine
	| source root textBody argument line code |
	
	"ready for code factory"
	textBody := 'my fancy code
is really cool'.
	argument := 'ArgumentGoesHere'.
	source := (parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup) readStream. 
	
	line := source nextLine.
	
	"parsing an empty line make sure that we get the root block node"
	root := parser parse: ''.
	self assert: parser current equals: root.
	
	"now the root block can consume ```xxxx"
	self assert: (root canConsumeLine: line).
	"now we get back an open code block"
	code := parser handleLine: line.
	self assert: code parent equals: root.
	self deny: code isClosed. 
	
	"now new line"
	line := source nextLine.
	self assert: (code canConsumeLine: line). 
	self assert: (code canConsumeLine: parser codeblockMarkup).
	"now a code block is closed."
	self deny: (code canConsumeLine: line). 
	self assert: code isClosed
	
	
	! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testSingleBlockWithArguments

	"
	```language=pharo&caption=Getting a morph for an instance of ==Color==&label=scr:asMorphInColor
Color >> asMorph
    ^ Morph new color: self
	```
	"
	| source root code  textBody argument |
	textBody := 'Color >> asMorph
    ^ Morph new color: self'.
	argument := 'language=pharo&caption=Getting a morph for an instance of ==Color==&label=scr:asMorphInColor'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := self parser parse: source.
	self assert: root children size equals: 1.
	code := root children first.
	self assert: code code equals: textBody.
	self assert: (code arguments at:#language) equals: 'pharo'.
	self assert: code captionElements first substring equals: 'Getting a morph for an instance of ==Color=='.
	self assert: (code arguments at:#label) equals: 'scr:asMorphInColor'.! !

!MicCodeBlockTest methodsFor: 'tests - arguments' stamp: ''!
testAssociations

	"
	```language=pharo&caption=Getting a morph for an instance of ==Color==&label=scr:asMorphInColor
Color >> asMorph
    ^ Morph new color: self
	```
	"
	| source code associations |
	source := parser codeblockMarkup, 'language=pharo&caption=`Color` is a class.&label=scr:asMorphInColor', String cr, 'Color >> asMorph
    ^ Morph new color: self', String cr, parser codeblockMarkup. 

	code := (self parser parse: source) children first.
	associations :=  { ('language' -> 'pharo') . ('caption' -> { MicMonospaceFormatBlock new substring: 'Color' . MicTextBlock new substring: ' is a class.' }) . ('label' -> 'scr:asMorphInColor') }.
	
	self 
		assert: code argumentAssociations first 
		equals: associations first.
	self 
		assert: code argumentAssociations second value first value substring
		equals: associations second value first substring.
	self 
		assert: code argumentAssociations second value first value kind
		equals: associations second value first kind.	
		
	self 
		assert: code argumentAssociations third 
		equals: associations third! !

!MicCodeBlockTest methodsFor: 'tests - first tag' stamp: ''!
testHasFirstTagWithNoFirstTag

	| source codeBlock |
	source := parser codeblockMarkup, String cr,  'my fancy code
is really cool', String cr, parser codeblockMarkup. 
	codeBlock := (parser parse: source) children first.
	self assert: codeBlock firstTagValue equals: ''! !

!MicCodeBlockTest methodsFor: 'tests - deviation' stamp: ''!
testFourBackQuotesClosedByThreeQuotes

	| codeBlock |
	codeBlock := parser parse: '```` 
something in the way
```'.

	self assert: codeBlock children first body equals: 'something in the way'! !

!MicCodeBlockTest methodsFor: 'tests - deviation' stamp: ''!
testThreeBackQuotesClosedByFourQuotes

	| codeBlock |
	codeBlock := parser parse: '``` 
something in the way
````'.

	self assert: codeBlock children first body equals: 'something in the way'! !

!MicCodeBlockTest methodsFor: 'tests - first tag' stamp: ''!
testFirstTagNoValueButContainSpace
	"this is not really good but right now we have it like that."
	"
	```lang uage
Color >> asMorph
    ^ Morph new color: self
	```
	"
	| source root code  textBody argument |
	textBody := 'Color >> asMorph
    ^ Morph new color: self'.
	argument := 'lang uage'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := self parser parse: source.
	self assert: root children size equals: 1.
	code := root children first.
	self assert: code firstTag equals: 'lang uage'.
	self assert: (code arguments at:#'lang uage') isNil! !

!MicCodeBlockTest methodsFor: 'tests - deviation' stamp: ''!
testFourBackQuotesOnMultipleLinesWithText

	| codeBlock |
	codeBlock := parser parse: '
Before	
	
	
````pharo
something in the way
pif
glop or pas glop
````
After
'.

	self assert: codeBlock children second body equals: 'something in the way
pif
glop or pas glop'! !

!MicCodeBlockTest methodsFor: 'tests - first tag' stamp: ''!
testFirstTagNoValue

	"
	```language&caption=Getting a morph for an instance of ==Color==&label=scr:asMorphInColor
Color >> asMorph
    ^ Morph new color: self
	```
	"
	| source root code  textBody argument |
	textBody := 'Color >> asMorph
    ^ Morph new color: self'.
	argument := 'language'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := self parser parse: source.
	self assert: root children size equals: 1.
	code := root children first.
	self assert: code firstTag equals: 'language'.
	self assert: (code arguments at:#language) isNil! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testSingleBlockWithArgumentsWithFormat

	"
	```language=pharo&caption=Getting a morph for an instance of ==Color==&label=scr:asMorphInColor
Color >> asMorph
    ^ Morph new color: self
	```
	"
	| source root code  textBody argument |
	textBody := 'Color >> asMorph
    ^ Morph new color: self'.
	argument := 'language=pharo&caption=`Color` is a class.&label=scr:asMorphInColor'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := self parser parse: source.

	
	code := root children first.
	self assert: code code equals: textBody.
	self assert: code firstTag equals: #language.
	self assert: (code arguments at: #language) equals: 'pharo'.
	
	self assert: code caption equals: 'Color is a class.'.
	self assert: code captionElements first kind equals: 'monospace'.
	self assert: code captionElements first substring equals: 'Color'.
	
	self assert: code captionElements second kind equals: 'basic'.
	self assert: code captionElements second substring equals: ' is a class.'.
	
	self assert: code label equals: 'scr:asMorphInColor'.! !

!MicCodeBlockTest methodsFor: 'tests - deviation' stamp: ''!
testFourBackQuotesOnMultipleLines

	| codeBlock |
	codeBlock := parser parse: '````pharo
something in the way
pif
glop or pas glop
````'.

	self assert: codeBlock children first body equals: 'something in the way
pif
glop or pas glop'! !

!MicCodeBlockTest methodsFor: 'tests - first tag' stamp: ''!
testFirstTagWithValue

	"
	```language=pharo&caption=Getting a morph for an instance of ==Color==&label=scr:asMorphInColor
Color >> asMorph
    ^ Morph new color: self
	```
	"
	| source root code  textBody argument |
	textBody := 'Color >> asMorph
    ^ Morph new color: self'.
	argument := 'language=PharoMethod'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := self parser parse: source.
	self assert: root children size equals: 1.
	code := root children first.
	self assert: code firstTag equals: #language.
	self assert: (code arguments at:#language) equals: 'PharoMethod'! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testSingleCodeBlockListInside
	"This test shows that list inside a codeblock are not managed as list but as plain text."
	
	| source root code textBody argument |
	textBody := '* my fancy code
* is really cool'.
	argument := 'ArgumentGoesHere'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := parser parse: source.
	
	self 
		assert: root children size 
		equals: 1.
	code := root children first.
	self assert: code children isEmpty.
	self
		assert: code code
		equals: textBody.
	self 
		assert: (code arguments at: #ArgumentGoesHere)
		equals: nil! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testSingleCodeBlock
	| source root code  textBody argument |
	textBody := 'my fancy code'.
	argument := 'Argument'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := self parser parse: source.
	self assert: root children size equals: 1.
	code := root children first.
	self assert: code code equals: textBody.
	self assert: (code arguments at: #Argument) isNil.
	self assert: code firstTag equals: argument! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testCanConsumeLine 
	"This test verfies that when a code block is closed it does not consume anymore."
	"It also show that consume is not just blindly do a line starts with the markup 
	since often the first line is consumed by the parent of the block."
	
	| source root textBody argument |
	textBody := 'my fancy code
is really cool'.
	argument := 'ArgumentGoesHere'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := parser parse: source.
	
	"An already created blockNode cannot consume a new code block since no nesting is allowed."
	self deny: (root children first canConsumeLine: '```language=zork').
	
	"An already closed blockNode cannot consume even plain text"
	self deny: (root children first canConsumeLine: 'plain text')! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testHasNOCaption

	"
	```language=pharo&caption=Getting a morph for an instance of ==Color==&label=scr:asMorphInColor
Color >> asMorph
    ^ Morph new color: self
	```
	"
	| source root code  textBody argument |
	textBody := 'Color >> asMorph
    ^ Morph new color: self'.
	argument := 'language=pharo&label=scr:asMorphInColor'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := self parser parse: source.
	
	code := root children first.
	self deny: code hasCaption! !

!MicCodeBlockTest methodsFor: 'tests' stamp: ''!
testHasCaption

	"
	```language=pharo&caption=Getting a morph for an instance of ==Color==&label=scr:asMorphInColor
Color >> asMorph
    ^ Morph new color: self
	```
	"
	| source root code  textBody argument |
	textBody := 'Color >> asMorph
    ^ Morph new color: self'.
	argument := 'language=pharo&caption=Getting a morph for an instance of ==Color==&label=scr:asMorphInColor'.
	source := parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup. 
	root := self parser parse: source.
	
	code := root children first.
	self assert: code hasCaption! !

!MicCodeBlockTest methodsFor: 'tests - deviation' stamp: ''!
testFourBackQuotesWithTextAround

	| codeBlock |
	codeBlock := parser parse: '
Start text here
	
```` 
something in the way
````

Ending text'.

	self assert: codeBlock children second body equals: 'something in the way'! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
testMoreSpaces

	self deny: (self semanticActionClass from: '    ') hasEntity! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
testArrayShouldNotBreak

	self deny: (self semanticActionClass fromTokens: #( 1 #+ 2 #* 3 )) hasEntity.
	self deny: (self semanticActionClass fromTokens: #( 1 #+ 2 #* )) hasEntity! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
testOneSpace

	self deny: (self semanticActionClass from: ' ') hasEntity! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
semanticActionClass

	^ MicSemanticAction! !

!MicCodeSemanticActionTest methodsFor: 'tests - metaclass' stamp: ''!
testReferenceToABrokenMetaClass2

	self assert: (self semanticActionClass from: 'Point grgrgr') entity isNil! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
testTwoBogusElements

	self assert:
		(self semanticActionClass fromTokens: #( 1 #+ )) entity isNil.
	self assert:
		(self semanticActionClass fromTokens: #( true #foo )) entity isNil.
	self assert:
		(self semanticActionClass fromTokens: #( Point #foo )) entity isNil! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
testChevronWithBrokenReceiver

	self assert: (self semanticActionClass fromTokens: #( 1 #>> 2 )) entity isNil.
	self assert: (self semanticActionClass fromTokens: #( true #>> 2 )) entity isNil.
	self assert: (self semanticActionClass fromTokens: #( $t #>> 2 )) entity isNil.
	self assert: (self semanticActionClass fromTokens:  #( ClassThatDoesNotExist #>> 2 )) entity isNil.

	self assert: (self semanticActionClass fromTokens: #( true class #>> 2 )) entity isNil.
	self assert: (self semanticActionClass fromTokens: #( $t class #>> 2 )) entity isNil.
	self assert: (self semanticActionClass fromTokens: #( ClassThatDoesNotExist class #>> 2 )) entity isNil! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
testTwoSpaces

	self deny: (self semanticActionClass from: '  ') hasEntity! !

!MicCodeSemanticActionTest methodsFor: 'tests - package' stamp: ''!
testReferenceToANonExistingPackage

	self assert: (self semanticActionClass from: #Pillar) entity isNil! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
testDoubleDollars

	self deny: (self semanticActionClass from: '$$') hasEntity! !

!MicCodeSemanticActionTest methodsFor: 'tests - methods' stamp: ''!
testReferenceToANonExistingMethodBecauseOfNoSymbol

	self assert: (self semanticActionClass from: 'Point >> setX:setY2:') entity isNil! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
testGlobalAccess

	self assert: (self semanticActionClass fromTokens: #( Transcript )) hasEntity
	"the semantics action is working even if it is refers to a global because the class of global is 
	used by the browse invocation when clicking on it. "! !

!MicCodeSemanticActionTest methodsFor: 'tests - class' stamp: ''!
testReferenceToNonExistingClass

	self deny: (self semanticActionClass from: 'Point22') hasEntity! !

!MicCodeSemanticActionTest methodsFor: 'tests - methods' stamp: ''!
testReferenceToAMethod

	self
		assert: (self semanticActionClass from: 'Point >> #setX:setY:') entity name
		equals: 'Point>>#setX:setY:'! !

!MicCodeSemanticActionTest methodsFor: 'tests - package' stamp: ''!
testReferenceToAPackage

	self
		assert: (self semanticActionClass from: #'''Microdown''') entity name
		equals: 'Microdown'! !

!MicCodeSemanticActionTest methodsFor: 'tests - methods' stamp: ''!
testReferenceToANonExistingMethodBecauseOfBogusClass

	self assert: (self semanticActionClass from: 'Point222 >> #setX:setY:') entity isNil! !

!MicCodeSemanticActionTest methodsFor: 'tests - metaclass' stamp: ''!
testReferenceToABrokenMetaClass

	self assert: (self semanticActionClass from: 'Point2 class') entity isNil! !

!MicCodeSemanticActionTest methodsFor: 'tests - metaclass' stamp: ''!
testReferenceToAMetaClass

	self
		assert: (self semanticActionClass from: 'Point class') entity
		equals: Point class! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
testChevronWithBrokenArguments

	self assert: (self semanticActionClass fromTokens: #( Point #>> 2 )) entity isNil.
	self assert: (self semanticActionClass fromTokens: #( Point class #>> 2 )) entity isNil.

	self assert: (self semanticActionClass fromTokens: #( Point #>> true )) entity isNil.
	self assert: (self semanticActionClass fromTokens: #( Point #>> Point )) entity isNil! !

!MicCodeSemanticActionTest methodsFor: 'tests - methods' stamp: ''!
testReferenceToANonExistingMethod

	self assert: (self semanticActionClass from: 'Point >> 12+3 ') entity isNil! !

!MicCodeSemanticActionTest methodsFor: 'tests - class' stamp: ''!
testReferenceToAClass

	self
		assert: (self semanticActionClass from:  'Point') entity
		equals: Point! !

!MicCodeSemanticActionTest methodsFor: 'test - bogus entry' stamp: ''!
testEmptyString

	self deny: (self semanticActionClass from: '') hasEntity! !

!MicColumnBlock methodsFor: 'accessing' stamp: ''!
width: anObject
	arguments at: #width put: anObject! !

!MicColumnBlock methodsFor: 'accessing' stamp: ''!
width
	^ arguments at: #width! !

!MicColumnBlock methodsFor: 'accessing' stamp: ''!
accept: aVisitor
	^ aVisitor visitColumn: self! !

!MicColumnBlock class methodsFor: 'accessing' stamp: ''!
tag
	^ #column! !

!MicColumnsBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitColumns: self! !

!MicColumnsBlock class methodsFor: 'accessing' stamp: ''!
tag
	^ #columns! !

!MicCommentBlock commentStamp: ''!
A commented line in Pillar is a line starting with %.
A comment does not flow on multiple lines. 
Each line to be commented should start with %.

I should be a subclass of SingleLineBlock and not continuousMarkedBlock.!
!MicCommentBlock methodsFor: 'markups' stamp: ''!
lineMarkup

	^ parser commentedLineMarkup ! !

!MicCommentBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitComment: self! !

!MicContinuousMarkedBlock commentStamp: ''!
I'm an abstract block for blocks requiring a systematic simple character or character sequences at the beginning of each line. The text of the lines are accumulated for now as line without the markup separated by a newline. 

For example 
```
% comment 1
% comment 2
```
produces a single comment object with text as follows:

```
comment 1
comment 2
```


For example 
```
> this is an example
> and another one
```

produces 

> this is an example
> and another one



!
!MicContinuousMarkedBlock methodsFor: 'testing' stamp: ''!
doesLineStartWithMarkup: line
	"return if the line starts with a markup"

	^ line beginsWith: self lineMarkup
	! !

!MicContinuousMarkedBlock methodsFor: 'markups' stamp: ''!
lineMarkup

	^ self subclassResponsibility ! !

!MicContinuousMarkedBlock methodsFor: 'actions' stamp: ''!
addLineAndReturnNextNode: line
	"line is assumed to be of the form 'chararacters some text' e.g., '> some text'
	the prefix spaces after $> are removed"

	| treatedLine |
	treatedLine := self extractLine: line.
	text := text
		ifNil: [ treatedLine ]
		ifNotNil: [ text , String cr , treatedLine ]! !

!MicContinuousMarkedBlock methodsFor: 'testing' stamp: ''!
canConsumeLine: line
	"return if this block can consume line i.e., it starts with sensible characters, e.g., > "

	^ self doesLineStartWithMarkup: line! !

!MicContinuousMarkedBlock methodsFor: 'actions' stamp: ''!
extractLine: line
	^ (line copyFrom: self lineMarkup size + 1 to: line size) trim! !

!MicContinuousMarkedBlock methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!MicDisplayer commentStamp: ''!
I'm a little utils to display come "rich text".

```
MicDisplayer new open
```!
!MicDisplayer methodsFor: 'instance creation' stamp: ''!
open 
	"self new open"
	| window text | 
	window := SystemWindow labelled: 'Beautiful Displayer'.
	window extent: 600@400.
	text := self buildText.
	text setText: self richContents.
	window addMorph: text frame: (0 @ 0 corner: 1 @ 1).
	window openInWorld! !

!MicDisplayer methodsFor: 'instance creation' stamp: ''!
contents1
	^ '## Section Level 2
## About Paragraphs	
Followed by a nice paragraph 
on multiple lines

And another **paragraph** (written in bold) just for the _fun_ (the fun must be in italic) and some ~strike~. 

# Section Level 1
## Section Level 2
### Section Level 3
#### Section Level 4
##### Section Level 5
###### Section Level 6

# About monospace

This is `monospace` and this is `Point>>#degrees` and ` Point `

# Code

```
1 + 2
3 + 4
```





'! !

!MicDisplayer methodsFor: 'instance creation' stamp: ''!
richContents
	^ MicRichTextComposer new visit: (MicroDownParser new parse: self contents)! !

!MicDisplayer methodsFor: 'instance creation' stamp: ''!
contents

	^ '
	
# Lists

- easy 
- peasy
- nice

And some others 

10. Ordered item
   	- unordered1
   - unordered2
11. Ordered item


Here is a list:
- item 1
  1. sub item 1
     pillou pilpu, yes we are on the second line
     and the third line.
  3. sub item 2
- item 2


# Math support

You can use an environment or a simple expression in text such as $C_0 - C_3$ or $f(a) = \\frac{1}{2\\pi i} \\oint_{\\gamma} \\frac{f(z)}{z - a} dz$.

Here are some example of environments:

&
V_i = C_0 - C_3
&

&
\\sin(x) = \\sum_{n=0}^{\\infty} \\frac{(-1)^{n}x^{2n+1}}{(2n+1)!!}
&


# Code 

```language=Pharo&caption=A beautiful code snippet&label=Fig1
1000 factorial / 999 factorial
>>> 1000
```

# Figures 
Here is a figure and a link: [http://pharo.org](http://pharo.org).

!![Pharologo without mic parameters.](https://files.pharo.org/media/logo/logo.png)

!![Pharologo with mic parameters.](https://files.pharo.org/media/logo/logo.png?size=80&caption=Our great figure.)



# Formats and hyperlinks

**Bold**, _italic_, `monospace`

In Pharo, Microdown supports hyperlinks to: 
- classes e.g., `Point`, 
- methodes e.g., `Point class`, `Point>>#setX:setY:`, and 
- packages e.g., `#''Microdown-Tests''` (for packages).


'! !

!MicDisplayer methodsFor: 'instance creation' stamp: ''!
buildText 
 
	| textModel scrolledText |
	textModel := RubScrolledTextModel new interactionModel: self.
	scrolledText := textModel newScrolledText
		beReadOnly;
		beWrapped;
		yourself.
	scrolledText textArea font: StandardFonts codeFont.
	^ scrolledText! !

!MicDisplayer class methodsFor: 'grammar - Script' stamp: ''!
script 
	<script>
	MicDisplayer new open! !

!MicDocumentListBlock methodsFor: 'visiting' stamp: ''!
limit

	^ self arguments at: #limit ifAbsent: [ '3' ]! !

!MicDocumentListBlock methodsFor: 'visiting' stamp: ''!
templates

	^ self arguments at: #templates ifAbsent: [ #() ]! !

!MicDocumentListBlock methodsFor: 'visiting' stamp: ''!
summaryMaxSize

	^ self arguments at: #summaryMaxSize
		ifPresent: [ :size | size asInteger ]
		ifAbsent: [ 500 ]! !

!MicDocumentListBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	^ aVisitor visitDocListAnnotation: self! !

!MicDocumentListBlock methodsFor: 'visiting' stamp: ''!
path

	^ self arguments at: #path! !

!MicDocumentListBlock methodsFor: 'visiting' stamp: ''!
sort

	^ self arguments at: #sort ifAbsent: [ '' ]! !

!MicDocumentListBlock class methodsFor: 'accessing' stamp: ''!
tag 
	^ #documentlist! !

!MicElement methodsFor: 'properties' stamp: ''!
propertyAt: aKey
	"Answer the property value associated with aKey."
	
	^ self propertyAt: aKey ifAbsent: [ MicPropertyError signal: 'Property not found' ]! !

!MicElement methodsFor: 'properties' stamp: ''!
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 |
	self properties ifNil: [ ^ aBlock value ].
	answer := self properties removeKey: aKey ifAbsent: aBlock.
	self properties isEmpty ifTrue: [ properties := nil ].
	^ answer! !

!MicElement methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	properties := OrderedDictionary new! !

!MicElement methodsFor: 'properties' stamp: ''!
propertiesCopy
	self properties ifNil: [ ^ nil ].
	^ self properties collect: [ :each | each copy ]! !

!MicElement methodsFor: 'accessing' stamp: ''!
parent: aBlock
	parent := aBlock.
	aBlock addChild: self! !

!MicElement methodsFor: 'properties' stamp: ''!
removeProperty: aKey
	"Remove the property with aKey. Answer the property or raise an error if aKey isn't found."
	
	^ self removeProperty: aKey ifAbsent: [ MicPropertyError signal: 'Property not found' ]! !

!MicElement methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!MicElement methodsFor: 'properties' stamp: ''!
properties
	^ properties ifNil: [ properties := Dictionary new ]! !

!MicElement methodsFor: 'properties' stamp: ''!
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 := (IdentityDictionary new: 1) ])
		at: aKey put: anObject! !

!MicElement methodsFor: 'properties' stamp: ''!
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 ]! !

!MicElement methodsFor: 'properties' stamp: ''!
propertyAt: aKey ifAbsent: aBlock
	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
	
	^ self properties isNil
		ifTrue: [ aBlock value ]
		ifFalse: [ self properties at: aKey ifAbsent: aBlock ]! !

!MicElement methodsFor: 'public' stamp: ''!
inlineParse: aString
	| inlineParser childrenCol |
	inlineParser := MicInlineParser new.
	childrenCol := inlineParser parse: aString.
	childrenCol do: [ :each | each parent: self ].
	^  childrenCol
! !

!MicElementTest methodsFor: 'factory' stamp: ''!
rootBlockClass
	^ MicRootBlock! !

!MicElementTest methodsFor: 'tests' stamp: ''!
instance

	^ instance ifNil: [ instance := self testedClass new ]! !

!MicElementTest methodsFor: 'factory' stamp: ''!
parser
	^ self parserClass new! !

!MicElementTest methodsFor: 'factory' stamp: ''!
listBlockClass
	^ MicListBlock! !

!MicElementTest methodsFor: 'factory' stamp: ''!
parserClass
	^ MicroDownParser! !

!MicElementTest methodsFor: 'factory' stamp: ''!
orderedListBlockClass
	^ MicOrderedListBlock! !

!MicElementTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	parser := self parser. ! !

!MicElementTest class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self = MicElementTest! !

!MicEnvironmentBlock commentStamp: ''!
An environment is delimited by a start and end markup and it can have an argument list. 
By default I do not handle any form of formatting in the potential arguments.

## Syntax


```
<?

?>
```


This class needs another pass to support nested mic elements inside its delimiter.

In Pillar
```
${begin:column|width=40}$
blah blah
${end:column}$
```

```
${begin:card}$

# I'm Cool

A paragraph about the card.
I will be interpreted as part of the card.

${end:card}$ 
```





This is important to support better column in the future:

```
${slide:title=Class Methods}$

${columns}$

${column:width=60}$

+>file://figures/Point-xy-class-method.png|width=90+

${column:width=40}$

- press the button ==class== to define a class method
- in lectures, we add ==class==

${endColumns}$
```


### Implementation limits
The contents of an environment cannot really contain other blocks.
!
!MicEnvironmentBlock methodsFor: 'accessing' stamp: ''!
extractFirstLineFrom: aLine

	| lineWithoutMarkup argumentsSplitter |
	lineWithoutMarkup := super extractFirstLineFrom: aLine.
	argumentsSplitter := MicArgumentsSplitter withString: lineWithoutMarkup.
	name := argumentsSplitter name trimBoth.
	arguments := argumentsSplitter arguments.
	^ lineWithoutMarkup! !

!MicEnvironmentBlock methodsFor: 'parse support' stamp: ''!
body

	^ String streamContents: [:s |  self bodyElements do: [ :each | s nextPutAll: each substring ] ]! !

!MicEnvironmentBlock methodsFor: 'markups' stamp: ''!
lineStartMarkup

	^ parser environmentOpeningBlockMarkup ! !

!MicEnvironmentBlock methodsFor: 'markups' stamp: ''!
lineStopMarkup
	
	^ parser environmentClosingBlockMarkup ! !

!MicEnvironmentBlock methodsFor: 'accessing' stamp: ''!
arguments
	
	^ arguments! !

!MicEnvironmentBlock methodsFor: 'parse support' stamp: ''!
closeMe

	"this is a temporary solution because normally the parser should populate body with MicBlocks.
	Right now just make sure that we have structured text = inline elements. "
	"body ifNotNil: [ 
		body :=  self inlineParse: body ].
	children := body"! !

!MicEnvironmentBlock methodsFor: 'adding' stamp: ''!
addLineAndReturnNextNode: line
	"add line to this node. 
	Notice, the action is allowed to create new nodes in the block tree.
	Returns the node to handle next line - typically self."
	
	isClosed
		ifTrue: [ ^ self ].
	(self doesLineStartWithStopMarkup: line)
		ifTrue: [ ^ self ].
	firstLine
		ifNil:
			[ firstLine := self extractFirstLineFrom: line ]
		ifNotNil: [ ^ self bodyFromLine: line ].
	^ self! !

!MicEnvironmentBlock methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!MicEnvironmentBlock methodsFor: 'parse support' stamp: ''!
bodyElements

	^ children! !

!MicEnvironmentBlock methodsFor: 'parse support' stamp: ''!
bodyFromLine: line
	
	| newBlock |
	newBlock := (self newBlockFor: line parent: self).
	self parser setCurrent: newBlock.
	^ newBlock! !

!MicEnvironmentBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitEnvironment: self! !

!MicEnvironmentBlock class methodsFor: 'public' stamp: ''!
alternateBlockClassFor: line
	"If there is one subclass with the corresponding tag, returns it, else resturn the current class."
	"line is of the form <?slide|title=Schedule"
	
	"We know that the two first characters are <? else we would be invoked"
	| tag |
	tag := ((line allButFirst: 2) copyUpTo: $|) trimBoth.
	^ self allSubclasses detect: [ :each | each tag = tag ] ifNone: [ self ]
	
	
	! !

!MicEnvironmentBlockTest methodsFor: 'tests - default environment' stamp: ''!
testEnvironmentWithFormat
	"'<?slide
- item 1 
- item 2
?>
'" 
	| source root env environmentName |
	environmentName := 'slide'.
	source := parser environmentOpeningBlockMarkup , environmentName, String cr, 
	 '- item1 **bold**
- item 2

blbababbab bababba', String cr,
	parser environmentClosingBlockMarkup, String cr.
	root :=  parser parse: source.
	
	self assert: root children size equals: 1.
	env := root children first. 

	self assert: env children first children first class equals: MicListItemBlock.
	self assert: env children first children first textElements second class equals: MicBoldFormatBlock 
	! !

!MicEnvironmentBlockTest methodsFor: 'tests - extensions' stamp: ''!
testEnvironmentIsCreatedWhenTagDoesNotMatch

	| source root env environmentName |
	environmentName := 'slideXXX'.
	source := parser environmentOpeningBlockMarkup , environmentName, String cr, 
	 'this is the slide body', String cr,
	parser environmentClosingBlockMarkup, String cr.
	
	root :=  parser parse: source.
	self assert: root children size equals: 1.
	env := root children first. 
	self assert: (env isKindOf: MicEnvironmentBlock). 
	self assert: env name equals: environmentName.
	self assert: env children first children first text equals: 'this is the slide body'
	! !

!MicEnvironmentBlockTest methodsFor: 'tests - default environment' stamp: ''!
testEnvironmentWithMultipleLines
	"'<?card
blbababbab
bababba

toto
?>
'"
	
	| source root env environmentName contents |
	environmentName := 'card'.
	contents := 'blbababbab
bababba

toto'.
	source := parser environmentOpeningBlockMarkup , environmentName
		, String cr , contents , String cr
		, parser environmentClosingBlockMarkup , String cr.
	root := parser parse: source .
	self assert: root children size equals: 1.
	env := root children first.
	self assert: (env isKindOf: MicEnvironmentBlock).
	self assert: env name equals: environmentName.
	self assert: env children size equals: 2.
	self assert: env children first class equals: MicParagraphBlock.
	self assert: env children second class equals: MicParagraphBlock.
	self assert: env children second text equals: 'toto'.! !

!MicEnvironmentBlockTest methodsFor: 'tests - extensions' stamp: ''!
testExtensionClassWithSpaceAndArgIsCreated

		| source root environment environmentName contents |
	environmentName := ' slide'.
	contents := 'blbababbab
bababba

toto'.
	source := parser environmentOpeningBlockMarkup, environmentName, parser argumentListStartDelimiter, 'a=1&b=17&c'
		, String cr , contents , String cr
		, parser environmentClosingBlockMarkup , String cr.
		
	root := parser parse: source.
	self assert: root children size equals: 1.
	environment := root children first.
	self assert: environment name equals: 'slide'.
	self assert: environment class equals: MicSlideBlock.
	self assert: (environment arguments at: 'a') equals: '1'.
	self assert: (environment arguments at: 'b') equals: '17'.
	self assert: (environment arguments at: 'c') equals: nil.
	! !

!MicEnvironmentBlockTest methodsFor: 'tests - default environment' stamp: ''!
testEnvironmentWithAnyNestedElement
	"'<?slide
- item 1 
- item 2
?>
'" 
	| source root env environmentName |
	environmentName := 'slide'.
	source := parser environmentOpeningBlockMarkup , environmentName, String cr, 
	 '- item1 
- item 2

blbababbab bababba', String cr,
	parser environmentClosingBlockMarkup, String cr.
	root :=  parser parse: source.
	
	self assert: root children size equals: 1.
	env := root children first. 
	self assert: (env isKindOf: MicEnvironmentBlock). 
	self assert: env name equals: environmentName.
	
	self assert: env children size equals: 2.
	self assert: env children first class equals: MicUnorderedListBlock.
	self assert: env children first children size equals: 2.
	self assert: env children first children first class equals: MicListItemBlock.
	self assert: env children second class equals: MicParagraphBlock.
	self assert: env children second children first class equals: MicTextBlock.
	! !

!MicEnvironmentBlockTest methodsFor: 'tests - default environment' stamp: ''!
testEnvironmentWithArguments
	 "'<?card|a=1&b=17&c
blbababbab
bababba

toto
?>
'"
	
	| source root environment environmentName contents |
	environmentName := 'card'.
	contents := 'blbababbab
bababba

toto'.
	source := parser environmentOpeningBlockMarkup, environmentName, parser argumentListStartDelimiter, 'a=1&b=17&c'
		, String cr , contents , String cr
		, parser environmentClosingBlockMarkup , String cr.
	root := parser parse: source.
	self assert: root children size equals: 1.
	environment := root children first.
	self assert: environment name equals: 'card'.
	self assert: (environment arguments at: 'a') equals: '1'.
	self assert: (environment arguments at: 'b') equals: '17'.
	self assert: (environment arguments at: 'c') equals: nil.! !

!MicEnvironmentBlockTest methodsFor: 'tests - default environment' stamp: ''!
testedClass 
	^ MicEnvironmentBlock  ! !

!MicEnvironmentBlockTest methodsFor: 'tests - extensions' stamp: ''!
testEnvironmentWithCorrespondingClassIsCreated

	| source root env environmentName |
	environmentName := 'slide'.
	source := parser environmentOpeningBlockMarkup ,  environmentName, String cr, 
	 'this is the slide body', String cr,
	parser environmentClosingBlockMarkup, String cr.
	
	root :=  parser parse: source.
	self assert: root children size equals: 1.
	env := root children first. 
	self assert: (env isKindOf: MicSlideBlock). 
	self assert: env name equals: environmentName.
	self assert: env children first children first text equals: 'this is the slide body'
	! !

!MicEnvironmentBlockTest methodsFor: 'tests - default environment' stamp: ''!
testEnvironment
	"'<?card
blbababbab bababba
?>
'" 
	| source root env environmentName |
	environmentName := 'card'.
	source := parser environmentOpeningBlockMarkup , environmentName, String cr, 
	 'blbababbab bababba', String cr,
	parser environmentClosingBlockMarkup, String cr.
	root :=  parser parse: source.
	self assert: root children size equals: 1.
	env := root children first. 
	self assert: (env isKindOf: MicEnvironmentBlock). 
	self assert: env name equals: environmentName.
	self assert: env children first children first text equals: 'blbababbab bababba'
	! !

!MicEnvironmentBlockTest methodsFor: 'tests - default environment' stamp: ''!
testEnvironmentClosingNotEatingClosingCharacter

	
	| root env |
	root := parser parse: '<?card
to

?>'.
	self assert: root children size equals: 1.
	env := root children first.
	self assert: env children first text equals: 'to'.! !

!MicEnvironmentBlockTest methodsFor: 'tests - default environment' stamp: ''!
testEnvironmentWithNoEmptyBeforeTheEndMarker

	
	| root env |
	root := parser parse: '<?card
Here we are a paragraph and the paragraph should not eat the end of the
environment, else we force writer to enter a new line to declare the end of
the paragraph.
?>'.
	self assert: root children size equals: 1.
	env := root children first.
	self assert: env children first text equals: 'Here we are a paragraph and the paragraph should not eat the end of the
environment, else we force writer to enter a new line to declare the end of
the paragraph.'.! !

!MicEnvironmentBlockTest methodsFor: 'tests - extensions' stamp: ''!
testEnvironmentWiathArgsWithCorrespondingClassIsCreated

		| source root environment environmentName contents |
	environmentName := 'slide'.
	contents := 'blbababbab
bababba

toto'.
	source := parser environmentOpeningBlockMarkup, environmentName, parser argumentListStartDelimiter, 'a=1&b=17&c'
		, String cr , contents , String cr
		, parser environmentClosingBlockMarkup , String cr.
		
	root := parser parse: source.
	self assert: root children size equals: 1.
	environment := root children first.
	self assert: environment name equals: 'slide'.
	self assert: environment class equals: MicSlideBlock.
	self assert: (environment arguments at: 'a') equals: '1'.
	self assert: (environment arguments at: 'b') equals: '17'.
	self assert: (environment arguments at: 'c') equals: nil.
	! !

!MicEnvironmentBlockTest methodsFor: 'tests - default environment' stamp: ''!
testParagraphEnvironmentParagraph
	"
'"
	
	| root |

	root := parser parse: 'What a super day for a ride.
	
<?card
Sunn Special S3

?>

Yes this is a good idea.'.
	
	self assert: root children size equals: 3.
	self assert: root children second children first text equals: 'Sunn Special S3'.
	self assert: root children third text  equals: 'Yes this is a good idea.'.
	
! !

!MicEnvironmentBlockTest methodsFor: 'tests - default environment' stamp: ''!
testEnvironmentWithCodeBlock
 
	| root env |
	root :=  parser parse: '<?slide

This is a nice piece of code
```
1000 factorial /999 factorial
>>> 1000
```
isn''t it
?>
'.
	
	self assert: root children size equals: 1.
	env := root children first. 	
	self assert: env children size equals: 3.
	self assert: env children first class equals: MicParagraphBlock.
	self assert: env children second class equals: MicCodeBlock.
	self assert: env children third class equals: MicParagraphBlock.
	! !

!MicFigureBlock commentStamp: ''!
I am a **figure**.

My syntax is: `!![Here is a nice caption.](https://files.pharo.org/media/logo/logo.png?micAnchor=figanchor&micWidth=80)`

You should get the following picture: 
!![Here is a nice caption.](https://files.pharo.org/media/logo/logo.png?micAnchor=figanchor&micWidth=80)

I have a resources, i.e. an object referencing either a file (in relative or absolute manner) or an Url, that refers to a given image object.

### Implementation notes

What is important to see is that using ? hampers to see the difference between url arguments from microdown ones such as micAnchor and micWitdh. 
But if we use another character such as | `https://files.pharo.org/media/logo/logo.png|micanchor=figanchor&micwidth=80` then it breaks the external tools because they do ignore extra arguments in the expression with ? but they break on parsing |.
Therefore we use ? and we prefix all the microdown specific parameters with mic so that we can identify them. !
!MicFigureBlock methodsFor: 'testing' stamp: ''!
isImageFile
	"Answer whether the file name indicates an image file."

	^ url isImageFile! !

!MicFigureBlock methodsFor: 'accessing' stamp: ''!
kind
	self flag: #todo. 
	"remove me"
 	^ #figure! !

!MicFigureBlock methodsFor: 'testing' stamp: ''!
hasCaption 	
	caption ifNil: [ ^ false ].
	^ true! !

!MicFigureBlock methodsFor: 'accessing' stamp: ''!
query
	^ url query! !

!MicFigureBlock methodsFor: 'accessing' stamp: ''!
arguments
	^ parameters! !

!MicFigureBlock methodsFor: 'visiting' stamp: ''!
closeMe 
	"we used this circumvoluted way to use the parsing on arguments provided by the URL parser,
	even in case of file. so the user can express tmp/figures/goo.png?width=90&anchor=foo"
	| dictionary urlString tempUrl |
	dictionary := OrderedDictionary new. 
	urlString := url asString.
	tempUrl := ZnUrlCopy fromString: urlString.
	tempUrl query ifNotNil: [ :q |
		q keysAndValuesDo: [ :k :v | dictionary at: k put: v  ] ].
	self arguments: dictionary.
	caption := self inlineParse: substring.
	"while the instance variable is named url it will host a file or http url mic resources object"
	url := MicResourceReference fromString: urlString
	
	
	! !

!MicFigureBlock methodsFor: 'accessing' stamp: ''!
arguments: aDictionary
	parameters := aDictionary! !

!MicFigureBlock methodsFor: 'accessing' stamp: ''!
openingDelimiter

 	^ MicFigureNameOpenerDelimiter markup! !

!MicFigureBlock methodsFor: 'accessing' stamp: ''!
parameters
	self deprecated: 'Use arguments instead' transformWith: '`@rec parameters' -> '`@rec arguments'.
	^ parameters ! !

!MicFigureBlock methodsFor: 'accessing' stamp: ''!
parameters: someParameters
	self deprecated: 'Use arguments: instead' transformWith: '`@rec parameters: `@arg' -> '`@rec arguments: `@arg'.
	parameters := someParameters! !

!MicFigureBlock methodsFor: 'accessing' stamp: ''!
resources: micResources

	url := micResources! !

!MicFigureBlock methodsFor: 'printing' stamp: ''!
printOn: aStream
 	
 		aStream nextPut: $!!;
 			nextPut: $[;
 			nextPutAll: self caption;
 			nextPut: $];
 			nextPut: $(.
		url printOn: aStream. 
		aStream nextPut: $).
 		! !

!MicFigureBlock methodsFor: 'accessing' stamp: ''!
originUrl
	^ self properties at: #originUrl ifAbsent: [ 
		^ url ]! !

!MicFigureBlock methodsFor: 'testing' stamp: ''!
isRelativeFilePath
	self flag: #toRemove.
	^ self url isFile and: [ (self url asString beginsWith: 'file:///') not ]! !

!MicFigureBlock methodsFor: 'accessing' stamp: ''!
resources 

	^ url ! !

!MicFigureBlock methodsFor: 'converting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitFigure: self! !

!MicFigureBlockTest methodsFor: 'tests' stamp: ''!
testPrintOnWithParameters
	| figure |
	figure := (splitterClass new parse: '!![caption](http://anURL.org?label=1&title=testFigure)') first.
	self assert: figure printString equals: '!![caption](http://anURL.org?label=1&title=testFigure)'! !

!MicFigureBlockTest methodsFor: 'tests' stamp: ''!
testUrlWithoutMicrodownParameters
	| figure |
	figure := (splitterClass new parse: '!![caption](http://www.Pharo.ORG)') first.
	self assert: figure url printString equals: 'http://www.Pharo.ORG'.
	
	figure := (splitterClass new parse: '!![caption](https://biblio.toutapprendre.com/newbiblio/index.aspx?nolog=1&delog=1)') first.
	self assert: (figure query at: 'nolog') equals: '1'.
	self assert: (figure query at: 'delog') equals: '1'.
! !

!MicFigureBlockTest methodsFor: 'tests' stamp: ''!
testCaption
	| figure |
	figure := (splitterClass new parse: '!![caption with space and dot...](http://www.Pharo.ORG)') first.
	self assert: figure caption equals: 'caption with space and dot...'
	
	! !

!MicFigureBlockTest methodsFor: 'tests - testing' stamp: ''!
testIsNotRelativeFilePath
	| figure |
	figure := (splitterClass new parse: '!![caption](file:///Users/name/figures/test.mic)') first.
	self assert: figure isRelativeFilePath not! !

!MicFigureBlockTest methodsFor: 'tests - testing' stamp: ''!
testIsNotValidImage
	| figure |
	figure := (splitterClass new parse: '!![caption](file://figures/test.mic)') first.
	self assert: figure isImageFile not! !

!MicFigureBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicFigureBlock ! !

!MicFigureBlockTest methodsFor: 'tests' stamp: ''!
testUrlWithMicrodownParameters
	| figure |
	figure := (splitterClass new parse: '!![caption](http://www.Pharo.ORG?micAnchor=fig:pharo)') first.
	self assert: (figure query at: 'micAnchor') equals: 'fig:pharo'.! !

!MicFigureBlockTest methodsFor: 'tests - testing' stamp: ''!
testIsValidImage
	| figure |
	figure := (splitterClass new parse: '!![caption](file://figures/test.png)') first.
	self assert: figure isImageFile! !

!MicFigureBlockTest methodsFor: 'tests - testing' stamp: ''!
testIsNotRelativeFilePathWithUrl
	| figure |
	figure := (splitterClass new parse: '!![caption](http://www.pharo.org)') first.
	self assert: figure resources fullName equals: 'http://www.pharo.org/'! !

!MicFigureBlockTest methodsFor: 'tests - testing' stamp: ''!
testIsRelativeFilePath
	| figure |
	figure := (splitterClass new parse: '!![caption](file://figures/test.mic)') first.
	self assert: figure isRelativeFilePath! !

!MicFigureBlockTest methodsFor: 'tests - testing' stamp: ''!
testIsNotValidImageWithFolder
	| figure |
	figure := (splitterClass new parse: '!![caption](file://figures/)') first.
	self assert: figure isImageFile not! !

!MicFigureBlockTest methodsFor: 'tests' stamp: ''!
testPrintOn
	| figure |
	figure := (splitterClass new parse: '!![caption](http://www.Pharo.ORG)') first.
	self assert: figure asString equals: '!![caption](http://www.Pharo.ORG)'
	
	"not really good but let us make it work"! !

!MicFigureBlockTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	parser := self parser.
	splitterClass := MicInlineParser ! !

!MicFigureNameOpenerDelimiter commentStamp: ''!
I am the opener delimiter for figure name.!
!MicFigureNameOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicFigureBlock! !

!MicFigureNameOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicFigureNameOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '!!['! !

!MicFigureNameOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ false! !

!MicFigureNameOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #figure! !

!MicFootnoteBlock methodsFor: 'accessing' stamp: ''!
note
	arguments ifNotEmpty: [ 
		arguments at: #note ifAbsent: [ ^ '' ].
		^ arguments at: #note ]! !

!MicFootnoteBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	aVisitor visitFootnote: self! !

!MicFootnoteBlock class methodsFor: 'accessing' stamp: ''!
tag

	^ #footnote! !

!MicFootnoteBlockTest methodsFor: 'tests' stamp: ''!
testCreateTheRightFootnoteObject

	| doc |
	doc := MicroDownParser new parse: '?{footnote|note=Duca99a}?'.
	self
		assert: doc children first children first class
		equals: MicFootnoteBlock.
	self
		assert: doc children first children first name
		equals: 'footnote'.
	self
		assert: (doc children first children first arguments at: #note)
		equals: 'Duca99a'! !

!MicFormatBlock methodsFor: 'visiting' stamp: ''!
closeMe
	
	| text |
	
	children ifEmpty: [
			text :=  (MicTextBlock
							from: start
							to: end
							withSubstring: substring
							withChildren: Array empty).
			self children: { text } ]! !

!MicFormatBlock methodsFor: 'accessing' stamp: ''!
wrappedElements
	^ children! !

!MicFormatBlock methodsFor: 'accessing' stamp: ''!
text
	self flag: #fixMe. 
	"we should clarify what is text!! to me it makes no sense."
 	^ String streamContents: [:st | self wrappedElements do: [ :each | st nextPutAll: each text ]]! !

!MicHTTPResource methodsFor: 'converting' stamp: ''!
string: aString

	super string: aString.
	urlOrFileReference := ZnUrlCopy fromString: originalString.! !

!MicHTTPResource methodsFor: 'querying' stamp: ''!
query
	^ urlOrFileReference query! !

!MicHTTPResource methodsFor: 'converting' stamp: ''!
asFileReference

	^ urlOrFileReference asFileReference! !

!MicHTTPResource methodsFor: 'resolving' stamp: ''!
resolvedWithResolver: aResolver
	"I'm url resource so I do not care about a root"
	"Experimental"
	^ (aResolver resolutionSource isKindOf: ZnUrl)
			ifTrue: [
				"we want to resolve over for example http://github.com/pharo-project...."
				MicHTTPResource new 
								originalString: originalString; 
								url: (aResolver resolutionSource withRelativeReference: self path) ]
			ifFalse: [ 
				"Now I resolve again a file system... well this is http so I do not care about the resolver"
				self				
				]

! !

!MicHTTPResource methodsFor: 'testing' stamp: ''!
isWeb

	^ urlOrFileReference isWeb! !

!MicHTTPResource methodsFor: 'resolving' stamp: ''!
resolvedBy: parentPath withResolver: aResolver
	"I'm url resource so I do not care about a root"

	^ (aResolver resolutionSource isKindOf: ZnUrl)
			ifTrue: [
				"we want to resolve over for example http://github.com/pharo-project...."
				MicHTTPResource new 
								originalString: originalString; 
								url: (aResolver resolutionSource withRelativeReference: self path) ]
			ifFalse: [ 
				"Now I resolve again a file system... well this is http so I do not care about the resolver"
				self				
				]

! !

!MicHTTPResource methodsFor: 'converting' stamp: ''!
fullName

	^ urlOrFileReference printString! !

!MicHeaderBlock commentStamp: ''!
I am a header. I'm composed of a number of sharp sign (1 to 6) followed by a space (obligatory) and a text on one line. 

For example 

```
# level 1
## level 2
### level 3
#### level 4
##### level 5
###### level 6
```

produces

# level 1
## level 2
### level 3
#### level 4
##### level 5
###### level 6
!
!MicHeaderBlock methodsFor: 'accessing' stamp: ''!
formattedCode 
	^super formattedCode , '[ ', self level printString, '/', self header, ' ]'! !

!MicHeaderBlock methodsFor: 'accessing' stamp: ''!
header
	
	^ String streamContents: [ :s | children do: [ :e | s nextPutAll: e substring ] ]
	
	! !

!MicHeaderBlock methodsFor: 'parse support' stamp: ''!
closeMe
	super closeMe.
	children :=  self inlineParse: children
! !

!MicHeaderBlock methodsFor: 'accessing' stamp: ''!
level
	^ level! !

!MicHeaderBlock methodsFor: 'testing' stamp: ''!
addLineAndReturnNextNode: line
	"Line is on the form '#### my heading at forth level'"
	level := ('(#+)' asRegex
		matchesPrefix: line;
		subexpression: 1) size.
	children := (line copyFrom: level + 1 to: line size) trim.
	^ self! !

!MicHeaderBlock methodsFor: 'accessing' stamp: ''!
level: anInteger
	level := anInteger
	


! !

!MicHeaderBlock methodsFor: 'accessing' stamp: ''!
headerElements
	
	^ self children
	! !

!MicHeaderBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor 
 	^ aVisitor visitHeader: self! !

!MicHeaderBlockTest commentStamp: ''!
I'm a test class for testing the behavior of MicHeaderBlock!
!MicHeaderBlockTest methodsFor: 'tests' stamp: ''!
testHeaderLevel4
	| source root |
	source := (parser headerMarkup repeat: 4), '    Level four'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	self assert: root children first header equals: 'Level four'.
	self assert: root children first level equals: 4! !

!MicHeaderBlockTest methodsFor: 'running' stamp: ''!
testedClass 
	^ MicHeaderBlock  ! !

!MicHeaderBlockTest methodsFor: 'tests' stamp: ''!
testHeaderLevel1NoSpace
	| source root |
	source := parser headerMarkup, 'Level1'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	self assert: root children first header equals: 'Level1'.
	self assert: root children first level equals: 1! !

!MicHeaderBlockTest methodsFor: 'tests' stamp: ''!
testHeaderLevel6
	| source root |
	source := (parser headerMarkup repeat: 6), '    Level six'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	self assert: root children first header equals: 'Level six'.
	self assert: root children first level equals: 6! !

!MicHeaderBlockTest methodsFor: 'tests' stamp: ''!
testCanConsumeLine

	| root headerString |
	headerString := (parser headerMarkup, ' Level1').
	root := parser parse: headerString.
	self deny: (root children first canConsumeLine: headerString) ! !

!MicHeaderBlockTest methodsFor: 'tests' stamp: ''!
testHeaderLevel1
	| root |
	root := parser parse: (parser headerMarkup, ' Level1').
	self assert: root children size equals: 1.
	self assert: root children first header equals: 'Level1'.
	self assert: root children first level equals: 1! !

!MicHorizontalLineBlock commentStamp: ''!
I'm an horizontal line. I'm expressed by using a new line with `***`

*** the rest of the line is ignored.!
!MicHorizontalLineBlock methodsFor: 'public' stamp: ''!
addLineAndReturnNextNode: line
	"Line is on the form '*** useless and ignored text '"

	^ self! !

!MicHorizontalLineBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor 
 	^ aVisitor visitHorizontalLine: self! !

!MicHorizontalLineBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicHorizontalLineBlock! !

!MicInlineBlockWithUrl commentStamp: ''!
My subclasses manage figures and links.

```
!![Pharologo](https://files.pharo.org/media/logo/logo.png
```

!![Pharologo](https://files.pharo.org/media/logo/logo.png)!
!MicInlineBlockWithUrl methodsFor: 'accessing' stamp: ''!
parser: aParser
	parser := aParser! !

!MicInlineBlockWithUrl methodsFor: 'accessing' stamp: ''!
url: anURL

	url := anURL! !

!MicInlineBlockWithUrl methodsFor: 'accessing' stamp: ''!
parser 
	^ parser! !

!MicInlineBlockWithUrl methodsFor: 'printing' stamp: ''!
printOn: aStream
	| contents |
	contents := children
		            ifEmpty: [ self substring ]
		            ifNotEmpty: [ self childrenPrintOn ].
	aStream
		nextPut: $[;
		nextPutAll: contents;
		nextPut: $];
		nextPut: $(.
	url printOn: aStream.
	aStream nextPut: $)! !

!MicInlineBlockWithUrl methodsFor: 'accessing' stamp: ''!
url
	^ url! !

!MicInlineBlockWithUrl methodsFor: 'accessing' stamp: ''!
closingDelimiter

 	^ MicURLCloserDelimiter markup! !

!MicInlineBlockWithUrl methodsFor: 'accessing' stamp: ''!
localFileOrExternalReference
	^ self class localFileOrExternalReference: url asString! !

!MicInlineBlockWithUrl methodsFor: 'accessing' stamp: ''!
caption
	^ String streamContents: [:st | self captionElements do: [ :each | st nextPutAll: each text ] ] ! !

!MicInlineBlockWithUrl methodsFor: 'visiting' stamp: ''!
captionElements 
	^ caption ifNil: [ OrderedCollection new ]! !

!MicInlineBlockWithUrl class methodsFor: 'instance creation' stamp: ''!
from: aStartInteger to: anEndInteger withKind: aKind withSubstring: aString withChildren: aChildren withURL: aURL withParser: aParser
	^ self new 
		start: aStartInteger; 
		end: anEndInteger; 
		substring: aString; 
		children: aChildren; 
		cleanSubstring; 
		url: aURL;
		parser: aParser;
		closeMe; 
		yourself! !

!MicInlineBlockWithUrl class methodsFor: 'instance creation' stamp: ''!
from: aStartInteger to: anEndInteger withKind: aKind withSubstring: aString withURL: aURL
	^ (self from: aStartInteger to: anEndInteger withKind: aKind withSubstring: aString withChildren: Array empty withURL: aURL)! !

!MicInlineBlockWithUrl class methodsFor: 'private' stamp: ''!
localFileOrExternalReference: aString
	| localFileIndicator |
	localFileIndicator := 'file://'.
	^ (aString beginsWith: localFileIndicator)
			ifTrue: [ aString allButFirst: localFileIndicator size ]
			ifFalse: [ aString ]! !

!MicInlineBlockWithUrl class methodsFor: 'instance creation' stamp: ''!
from: aStartInteger to: anEndInteger withKind: aKind withSubstring: aString withChildren: aChildren withURL: aURL
	^ self new 
		start: aStartInteger; 
		end: anEndInteger; 
		substring: aString; 
		children: aChildren; 
		cleanSubstring; 
		url: aURL;
		closeMe; 
		yourself! !

!MicInlineElement commentStamp: ''!
I am an inline block generated by inline splitter, to parse inline text.

I am characterized by:
- start & end: locations of my opener & closer delimiters in initial string
- substring: concerned text (without delimiters so)
- kind: my type, symbol which must be the same than my relative delimiter type (#basic for normal text)
- children: array in case of nested inline blocks

!
!MicInlineElement methodsFor: 'testing' stamp: ''!
isOnlyChild
	^ children isEmpty! !

!MicInlineElement methodsFor: 'obsolete' stamp: ''!
substring: aSubString
	substring := aSubString! !

!MicInlineElement methodsFor: 'accessing' stamp: ''!
text
 	^ substring! !

!MicInlineElement methodsFor: 'accessing' stamp: ''!
kind
	"we are deprecating the state"
	^ self error! !

!MicInlineElement methodsFor: 'initialization' stamp: ''!
initialize

	super initialize. 
	children := #().
	! !

!MicInlineElement methodsFor: 'visiting' stamp: ''!
closeMe
	"Hook to perform post creation action. The name is the same as for blocks."
	! !

!MicInlineElement methodsFor: 'accessing' stamp: ''!
children
	^ children! !

!MicInlineElement methodsFor: 'accessing' stamp: ''!
parent: aParent
	parent := aParent! !

!MicInlineElement methodsFor: 'printing' stamp: ''!
printOn: aStream

	| contents |
	contents := children 
		ifEmpty: [ self substring ] 
		ifNotEmpty: [ self childrenPrintOn ].
	aStream nextPut: $[;
				nextPutAll: contents;
				nextPut: $];
				nextPut: $(;
				nextPutAll: self kind;
				nextPut: $) 
! !

!MicInlineElement methodsFor: 'accessing' stamp: ''!
children: anArray
	children := anArray! !

!MicInlineElement methodsFor: 'accessing' stamp: ''!
literal
	^ substring copyFrom: start to: end. ! !

!MicInlineElement methodsFor: 'accessing' stamp: ''!
end: anInteger
	end := anInteger! !

!MicInlineElement methodsFor: 'accessing' stamp: ''!
start 	
	^ start! !

!MicInlineElement methodsFor: 'printing' stamp: ''!
childrenPrintOn
	^ (children asString allButFirst: 9) allButLast! !

!MicInlineElement methodsFor: 'accessing' stamp: ''!
end
	^ end! !

!MicInlineElement methodsFor: 'accessing' stamp: ''!
start: anInteger
	start := anInteger ! !

!MicInlineElement methodsFor: 'obsolete' stamp: ''!
substring
	^ substring! !

!MicInlineElement methodsFor: 'operations' stamp: ''!
escapeCharacter
	^ '\'! !

!MicInlineElement methodsFor: 'operations' stamp: ''!
cleanSubstring
	self isOnlyChild ifTrue: [ 
		self substring: ( String streamContents: [:s | 
			(self substring splitOn: self escapeCharacter)
				doWithIndex: [:each :i | 
					(each isEmpty and: i>1) ifTrue: [ s << self escapeCharacter ] ifFalse: [ s << each ] ] ] ) ]! !

!MicInlineElement class methodsFor: 'constructor' stamp: ''!
from: aStartInteger to: anEndInteger withSubstring: aString
	^ self new 
		start: aStartInteger; 
		end: anEndInteger; 
		substring: aString; 
		children: Array empty; 
		cleanSubstring; 
		closeMe;
		yourself.	! !

!MicInlineElement class methodsFor: 'testing' stamp: ''!
isEvaluated
	^ true! !

!MicInlineElement class methodsFor: 'constructor' stamp: ''!
from: aStartInteger to: anEndInteger withSubstring: aString withChildren: aChildren
	^ self new 
		start: aStartInteger; 
		end: anEndInteger; 
		substring: aString; 
		children: aChildren; 
		cleanSubstring; 
		closeMe; 
		yourself.	! !

!MicInlineParser commentStamp: ''!
I'm a parser of block text. I'm responsible to generate text, annotation, format, link, url kind of objects.!
!MicInlineParser methodsFor: 'actions' stamp: ''!
popFrom: aStartIndex to: anEndIndex
	aStartIndex to: anEndIndex do: [ :i | openersStack pop ]
	! !

!MicInlineParser methodsFor: 'initialization' stamp: ''!
initializeDelimiters
	allDelimiters := Dictionary new.
	self abstractDelimiterClass subclasses 
		select: [ :subclass | subclass isActive ]
		thenDo: [ :subclass | allDelimiters 
										at: subclass markup 
										put: subclass ].
	keys := allDelimiters keys.! !

!MicInlineParser methodsFor: 'public' stamp: ''!
parse: aString

	aString ifEmpty: [ ^ Array empty ].
	string := aString.
	^ self read: aString! !

!MicInlineParser methodsFor: 'instance creation' stamp: ''!
newURLInlineBlockWithoutChildren
	^ opener associatedInlineBlock
			from: opener index
			to: closer index + closer size - 1
			withKind: opener type
			withSubstring: correctSubstring
			withURL: correctURL! !

!MicInlineParser methodsFor: 'process' stamp: ''!
linkOrFigureProcess: indexOfAssociateOpener
	"IF we find a ( just after and a ) after again
	THEN we add the associate link or figure inline block
	ELSE we ignore it"
	| startIndex endIndex urlCloserIndex |
	((string allButFirst: (closer index + closer size - 1)) beginsWith: self urlOpenerDelimiterClass markup)
		ifTrue: [ 
			urlCloserIndex := string indexOfSubCollection: self urlCloserDelimiterClass markup startingAt: closer index ifAbsent: [ 0 ].
			(urlCloserIndex > 0) 
				ifTrue: [ 
					startIndex := opener index + opener size.
					endIndex := closer index - 1.
					correctSubstring := string copyFrom: startIndex to: endIndex.
					correctURL := string copyFrom: (closer index + closer size + self urlOpenerDelimiterClass size) to: (urlCloserIndex - 1).
					"Delete openers above in stack, considered as unclosed so ignored"
					self popFrom: 1 to: indexOfAssociateOpener.
					"Add found inline block"
			(openersStack size > 0)
				ifTrue: [ 
					(openersStack size > nestedLevel)
						ifTrue: [ 
							children 
								ifEmpty: [ children add: (self newURLInlineBlockWithCloser: urlCloserIndex) ]
								ifNotEmpty: [ children last add: (self newURLInlineBlockWithCloser: urlCloserIndex) ] ]
						ifFalse: [ children add: (self newURLInlineBlockWithoutChildrenWithCloser: urlCloserIndex) ].
				]
				ifFalse: [ 
					result add: (self newURLInlineBlockWithCloser: urlCloserIndex).
					children := LinkedList new.
				].
			incrementation := urlCloserIndex - index.
			nestedLevel := openersStack size.
				]
				ifFalse: [ "do nothing" ]
		]
		ifFalse: [ "do nothing" ]! !

!MicInlineParser methodsFor: 'instance creation' stamp: ''!
newInlineBlock
	| inlineBlockClass |
	inlineBlockClass := opener associatedInlineBlock.
	(inlineBlockClass isEvaluated) 
		ifTrue: [ 
			^ inlineBlockClass
				from: opener index
				to: closer index + closer size - 1
				withSubstring: correctSubstring
				withChildren: children asArray
		 ]
		ifFalse: [ ^ self newInlineBlockWithoutChildren ]
	! !

!MicInlineParser methodsFor: 'process' stamp: ''!
closerOnlyCase
	"IF delimiter found is a closer which can close an opened inline block
	THEN we add the associate inline block
	ELSE we ignore it"
	| indexOfAssociateOpener typesToFind|
	typesToFind := (#(#linkName #figure) includes: delimiterClass type ) 
		ifTrue: [#(#linkName #figure)] 
		ifFalse: [ Array braceWith: delimiterClass type ].
	indexOfAssociateOpener := openersStack findFirst: [ :each | typesToFind includes: each type ].
	(indexOfAssociateOpener > 0) ifTrue: [ self addInlineBlock: indexOfAssociateOpener ]! !

!MicInlineParser methodsFor: 'instance creation' stamp: ''!
newURLInlineBlockWithoutChildrenWithCloser: aCloserIndex
	^ opener associatedInlineBlock
			from: opener index
			to: aCloserIndex
			withKind: opener type
			withSubstring: correctSubstring
			withURL: correctURL! !

!MicInlineParser methodsFor: 'actions' stamp: ''!
identifyMarkupFor: aString

	keys do: [ :key |
		(aString beginsWith: key) ifTrue: [ 
			incrementation := key size.
			delimiterClass := allDelimiters at: key.
			self delimiterFoundProcess.
			^ self ] ]! !

!MicInlineParser methodsFor: 'actions' stamp: ''!
read: aString
	| next |
	incrementation := 1.
	aString ifEmpty: [ ^ self resultProcess ].
	self identifyMarkupFor: aString.
	"this is stupid to iterate all. We can stop as soon as we found one. "

	aString first = $\ ifTrue: [ 
		incrementation := incrementation + 1 ].
	self indexIncrement: incrementation.
	aString size > incrementation 
		ifTrue: [ next := (aString allButFirst: incrementation)]
		ifFalse: [next := ''].
	^ self read: next.! !

!MicInlineParser methodsFor: 'process' stamp: ''!
resultProcess
	"At the end, we add all basic text between found inline blocks"
	
	result ifEmpty: [ ^ { (self newBasicInlineBlockFrom: 1 to: string size)} ].
	result do: [ :e | 
		| startSubstring endSubstring |
		e substring isEmpty 	
			ifTrue: [ startSubstring := endSubstring := 1 ]
			ifFalse: [  	startSubstring := (string indexOfSubCollection: e substring startingAt: e start) max: 1.
		endSubstring := startSubstring + e substring size - 1 ].
		e children: (self insertBasicText: e children from: startSubstring to: endSubstring) ].
	^ self insertBasicText: result! !

!MicInlineParser methodsFor: 'accessing' stamp: ''!
abstractDelimiterClass
	^ MicAbstractDelimiter! !

!MicInlineParser methodsFor: 'accessing' stamp: ''!
urlOpenerDelimiterClass
	^ MicURLOpenerDelimiter ! !

!MicInlineParser methodsFor: 'process' stamp: ''!
delimiterFoundProcess
	"Case 1: it's a opener only"
	(delimiterClass isOpenerOnly) 
		ifTrue: [ self openerOnlyCase ]
		ifFalse: [ 
					"Case 2: it's both opener and closer"
			(delimiterClass isBoth) 
				ifTrue: [ self bothCase ]
				ifFalse: [ 
							"Case 3: it's a closer only"
							self closerOnlyCase
				]
			]
	
			
			
! !

!MicInlineParser methodsFor: 'actions' stamp: ''!
pushNewOpener
	openersStack push: (delimiterClass index: index)! !

!MicInlineParser methodsFor: 'actions' stamp: ''!
indexIncrement: anInteger
	index := index + anInteger! !

!MicInlineParser methodsFor: 'process' stamp: ''!
addInlineBlock: indexOfAssociateOpener
	| startIndex endIndex |
	opener := openersStack at: indexOfAssociateOpener.
	closer := delimiterClass index: index.
	"Check the linkName or figure case"
	(#(#linkName #figure) includes: opener type ) 
		ifTrue: [ self linkOrFigureProcess: indexOfAssociateOpener ]
		ifFalse: [ 
			startIndex := opener index + opener size.
			endIndex := closer index - 1.
			correctSubstring := string copyFrom: startIndex to: endIndex.
			"Delete openers above in stack, considered as unclosed so ignored"
			self popFrom: 1 to: indexOfAssociateOpener.
			"Add found inline block"
			openersStack size > 0
				ifTrue: [ 
					(openersStack size > nestedLevel)
						ifTrue: [ 
							children 
								ifEmpty: [ children add: self newInlineBlock ]
								ifNotEmpty: [ children last add: self newInlineBlock ] ]
						ifFalse: [ children add: self newInlineBlockWithoutChildren ].
				]
				ifFalse: [ 
					result add: self newInlineBlock.
					children := LinkedList new.
				].
			nestedLevel := openersStack size.
		]! !

!MicInlineParser methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self initializeDelimiters.
	openersStack := Stack new.
	result := LinkedList new.
	children := LinkedList new.
	nestedLevel := 0.
	index := 1.
! !

!MicInlineParser methodsFor: 'instance creation' stamp: ''!
newBasicInlineBlockFrom: stIndex to: eIndex
	^ (MicTextBlock
			from: stIndex
			to: eIndex
			withSubstring: (string copyFrom: stIndex to: eIndex)
			withChildren: Array empty)
			
		"should use copyFrom:to:"! !

!MicInlineParser methodsFor: 'instance creation' stamp: ''!
newURLInlineBlockWithCloser: aCloserIndex
	| inlineBlockClass |
	inlineBlockClass := opener associatedInlineBlock.
	(inlineBlockClass isEvaluated) 
		ifTrue: [ 
			^ inlineBlockClass
				from: opener index
				to: aCloserIndex
				withKind: opener type
				withSubstring: correctSubstring
				withChildren: children asArray
				withURL: correctURL
				withParser: self
		 ]
		ifFalse: [ ^ self newURLInlineBlockWithoutChildren ]
	! !

!MicInlineParser methodsFor: 'instance creation' stamp: ''!
newInlineBlockWithoutChildren
	^ opener associatedInlineBlock
			from: opener index
			to: closer index + closer size - 1
			withSubstring: correctSubstring
			! !

!MicInlineParser methodsFor: 'accessing' stamp: ''!
urlCloserDelimiterClass
	^ MicURLCloserDelimiter! !

!MicInlineParser methodsFor: 'process' stamp: ''!
openerOnlyCase
	self pushNewOpener! !

!MicInlineParser methodsFor: 'accessing' stamp: ''!
allDelimiters
	^ allDelimiters! !

!MicInlineParser methodsFor: 'handle basic text' stamp: ''!
insertBasicText: anArrayOfInlineBlocks 
	withFinalArray: finalArray 
	from: startIndex 
	to: endIndex
	
	anArrayOfInlineBlocks ifEmpty: [ ^ finalArray asArray ].
	(anArrayOfInlineBlocks size = 1) ifTrue: [ 
		| element |
		element := anArrayOfInlineBlocks first.
		finalArray ifEmpty: [ self addATextFrom: startIndex 
										to: element start - 1 
										toFinalArray: finalArray ].
		finalArray add: element.
		self addATextFrom: element end + 1 
			to: endIndex 
			toFinalArray: finalArray.
		^ self insertBasicText: Array empty withFinalArray: finalArray from: startIndex to: endIndex
	].
	finalArray ifEmpty: [ 
		self addATextFrom: startIndex 
			to: anArrayOfInlineBlocks first start - 1 
			toFinalArray: finalArray ].
	finalArray add: anArrayOfInlineBlocks first.
	self 
		addATextFrom: anArrayOfInlineBlocks first end + 1 
		to: anArrayOfInlineBlocks second start - 1 
		toFinalArray: finalArray.

	^ self insertBasicText: anArrayOfInlineBlocks allButFirst 
		withFinalArray: finalArray 
		from: startIndex 
		to: endIndex
	
	
	! !

!MicInlineParser methodsFor: 'handle basic text' stamp: ''!
addATextFrom: start to: end toFinalArray: aFinalArray
	start > end
		ifTrue: [ " do nothing "]
		ifFalse: [ aFinalArray add: (self newBasicInlineBlockFrom: start to: end ) ]! !

!MicInlineParser methodsFor: 'handle basic text' stamp: ''!
insertBasicText: anArrayOfInlineBlocks
	^ self insertBasicText: anArrayOfInlineBlocks withFinalArray: LinkedList new from: 1 to: string size! !

!MicInlineParser methodsFor: 'public' stamp: ''!
start: aString
	self deprecated: 'Use parse: instead' transformWith: '`@receiver start: `@arg' -> '`@receiver parse: `@arg'.
	^ self parse: aString! !

!MicInlineParser methodsFor: 'handle basic text' stamp: ''!
insertBasicText: anArrayOfInlineBlocks from: startIndex to: endIndex
	^ self insertBasicText: anArrayOfInlineBlocks withFinalArray: LinkedList new from: startIndex to: endIndex! !

!MicInlineParser methodsFor: 'process' stamp: ''!
bothCase
	| indexOfAssociateOpener |
	indexOfAssociateOpener := openersStack findFirst: [ :each | delimiterClass type = each type ].
	(openersStack isEmpty or: [ indexOfAssociateOpener = 0])
		ifTrue: [ 
			"We consider the delimiter as a new opener or it's the first opener"
			self pushNewOpener ]
		ifFalse: [ 
			"We consider the delimiter as a closer of last opened inline block"
			self addInlineBlock: indexOfAssociateOpener ]! !

!MicInlineParser methodsFor: 'actions' stamp: ''!
indexIncrement
	^ self indexIncrement: 1! !

!MicInlineParserTest commentStamp: ''!
These tests should be merged in MicrodDownInlineParserTest!
!MicInlineParserTest methodsFor: 'tests - various' stamp: ''!
testNoAnnotation

	| res |
	res := self splitter parse: 'abc'.
	self assert: res first printString equals: 'abc'.

	res := self splitter parse: 'abc def gh'.
	self assert: res first printString equals: 'abc def gh'! !

!MicInlineParserTest methodsFor: 'tests' stamp: ''!
testCurlyBraceDoesNotLeadToProblem
	| mic |
	mic := (self splitter parse:  ' jhkjhk { a }') first.
	self assert: mic substring equals:  ' jhkjhk { a }'! !

!MicInlineParserTest methodsFor: 'tests - figure' stamp: ''!
testFigureWithParametersWithBlank

	"Test the image annotation !![AltText](url)"

	| res |
	res := self splitter parse:
		       'abc!![AltText](my_directory/image.png?label=&width=90)last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals:
			{ 'abc'. '!![AltText](my_directory/image.png?label=&width=90)'.
			'last' }.
	self assert: (res second isKindOf: MicFigureBlock).
	self assert: (res second url isKindOf: MicResourceReference).
	self assert: (res second arguments at: 'label') equals: ''.
	self assert: (res second arguments at: 'width') equals: '90'! !

!MicInlineParserTest methodsFor: 'tests - anchors' stamp: ''!
testAnchorReferenceUnevaluated

	"When isEvaluated class method returns false, like anchor reference's case, inline inside shoudn't be evaluated"

	| res |
	res := self splitter parse: 'abc*@def**not bold**ghi@*xyz'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[def**not bold**ghi](anchorReference)'.
			'xyz' }! !

!MicInlineParserTest methodsFor: 'tests - annotation' stamp: ''!
testSplitAnnotation

	| res |
	res := self splitter parse:
		       'abc',MicAnnotationOpenerDelimiter markup,'type:value|key1=val1&key2=val2',MicAnnotationCloserDelimiter markup,'def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. MicAnnotationOpenerDelimiter markup,'type:value|key1=val1&key2=val2',MicAnnotationCloserDelimiter markup.
			'def' }! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testOverlappingFormat

	| res |
	res := self splitter parse: 'ab**boldstart_ boldend** italicEnd_de'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: #('ab' '[boldstart_ boldend](bold)' ' italicEnd_de')! !

!MicInlineParserTest methodsFor: 'tests - figure' stamp: ''!
testFigure
	"Test the image annotation !![AltText](url)"

	| res |
	res := self splitter parse:
		       'abc!![AltText](my_directory/image.png)last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '!![AltText](my_directory/image.png)'.
			'last' }.
	self assert: (res second isKindOf: MicFigureBlock).
	self assert: (res second url isKindOf: MicResourceReference)
	! !

!MicInlineParserTest methodsFor: 'tests - figure' stamp: ''!
testFigureWithParameters

	"Test the image annotation !![AltText](url)"

	| res |
	res := self splitter parse:
		       'abc!![AltText](my_directory/image.png?label=42&width=90)last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals:
			{ 'abc'. '!![AltText](my_directory/image.png?label=42&width=90)'.
			'last' }.
	self assert: (res second isKindOf: MicFigureBlock).
	self assert: (res second url isKindOf: MicResourceReference).
	self assert: (res second arguments at: 'label') equals: '42'.
	self assert: (res second arguments at: 'width') equals: '90'! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testItalicNestedInBoldWithSpace

	| res |
	res := self splitter parse: 'abc**x_y_z**cba'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[x [y](italic) z](bold)'. 'cba' }! !

!MicInlineParserTest methodsFor: 'tests' stamp: ''!
testWrappedElementOnBold
	| mic |
	mic := (self splitter parse: '**bold**') first.
	self assert: mic class equals: MicBoldFormatBlock.
	self assert: mic substring equals: 'bold'! !

!MicInlineParserTest methodsFor: 'tests' stamp: ''!
testWrappedElementOnNested
	| mic |
	mic := (self splitter parse: '**_italic_**') first.
	self assert: mic wrappedElements first class equals: MicItalicFormatBlock.
	self assert: mic wrappedElements first substring equals: 'italic'.
	self flag: #fixeMe. "should check that we do not have empty mictext"! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testEscapeMonospace
	"When isEvaluated class method returns false, like monospace's case, inline inside shoudn't be evaluated"

	| res |
	self skip.
	res := self splitter parse: 'abc`\`monospace\``efg'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[\`monospace\`](monospace)'. 'efg' }.
	self assert: res second class equals: MicMonospaceFormatBlock! !

!MicInlineParserTest methodsFor: 'access' stamp: ''!
splitter
	^ MicInlineParser new! !

!MicInlineParserTest methodsFor: 'tests to make green again' stamp: ''!
testEscapeCharacterWithNoCharacterAfter

	| res |
	self skip.
	res := self splitter parse: '**bold**\'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { '**bold**\' }! !

!MicInlineParserTest methodsFor: 'tests - escape' stamp: ''!
testEscapeTripleBold
	"Test the escape \ in case of nested formats"

	| res |
	res := self splitter parse:  'c\***bo**la'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: {'c*' . '[bo](bold)' . 'la'}.! !

!MicInlineParserTest methodsFor: 'tests - figure' stamp: ''!
testFigureWithParenthesesInsteadOfBracket
	"Test the image annotation !![AltText](url)"

	| res |
	res := self splitter parse:
		       'abc!!(AltText)(my_directory/image.png)last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc!!(AltText)(my_directory/image.png)last' }! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testMonospaceDoesNotTreatNestedElements

	| res |
	res := self splitter parse: '`[* foo *])`'.
	self assert: res first substring equals: '[* foo *])'! !

!MicInlineParserTest methodsFor: 'tests - link' stamp: ''!
testSplitBlockLinkIncomplete

	| res |
	res := self splitter parse: 'abc[LinkText]last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc[LinkText]last' }.
	self assert: res first class equals: MicTextBlock! !

!MicInlineParserTest methodsFor: 'tests - figure' stamp: ''!
testUnclosedFigure
	"Test the image annotation !![AltText](url)"

	| res |
	res := self splitter parse: 'abc!![AltText]last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc!![AltText]last' }! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testMonospaceUnevaluated
	"When isEvaluated class method returns false, like monospace's case, inline inside shoudn't be evaluated"

	| res |
	res := self splitter parse: 'abc`def**not bold**ghi`xyz'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[def**not bold**ghi](monospace)'.
			'xyz' }.
	self assert: res second class equals: MicMonospaceFormatBlock! !

!MicInlineParserTest methodsFor: 'tests - figure' stamp: ''!
testFigureWithBracketInsteadOfParentheses
	"Test the image annotation !![AltText](url)"

	| res |
	res := self splitter parse:
		       'abc!![AltText][my_directory/image.png]last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc!![AltText][my_directory/image.png]last' }! !

!MicInlineParserTest methodsFor: 'tests - math' stamp: ''!
testMathshouldBeUnevaluated

	"When isEvaluated class method returns false, like math's case, inline inside shoudn't be evaluated"

	| res |
	res := self splitter parse: 'abc$def**not bold**ghi$xyz'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[def**not bold**ghi](math)'.
		'xyz' }! !

!MicInlineParserTest methodsFor: 'tests - escape' stamp: ''!
testEscapeCharacterInNestedCase
	"Test the escape \ in case of nested formats"

	| res |
	res := self splitter parse: 'abc_\**not bold** italic_last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: {'abc' . '[**not bold** italic](italic)' . 'last'}.! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testItalicNestedInBold

	| res |
	res := self splitter parse: 'abc**bold_italic_bold**xyz'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[bold [italic](italic) bold](bold)'.
			'xyz' }! !

!MicInlineParserTest methodsFor: 'tests to make green again' stamp: ''!
testTwoConsecutiveEscapeCharacter
	"we should have just one escape"
	| res |
	self skip.
	res := self splitter start: '\\'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: {'\'}.! !

!MicInlineParserTest methodsFor: 'tests - various' stamp: ''!
testParseEmptyText

	| res |
	res := self splitter parse: ''.
	self assert: res isEmpty! !

!MicInlineParserTest methodsFor: 'tests - escape' stamp: ''!
testEscapeCharacterInNestedLinkName
	"Test the escape \ in case of nested linknames"

	| res |
	res := self splitter parse: 'abc[\[nested\]](myURL)last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[[nested]](myURL)'. 'last' }! !

!MicInlineParserTest methodsFor: 'tests - math' stamp: ''!
testMath

	| res |
	res := self splitter parse: 'abc$	V_i = C_0 - C_3	$def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[	V_i = C_0 - C_3	](math)'.
		'def' }.
	self assert: (res second isKindOf: MicMathInlineBlock)! !

!MicInlineParserTest methodsFor: 'tests - link' stamp: ''!
testSplitBlockLinkWithBracketInsteadOfParentheses

	"Test the link annotation [LinkText](url)"

	| res |
	res := self splitter parse: 'abc[LinkText][myURL]last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc[LinkText][myURL]last' }! !

!MicInlineParserTest methodsFor: 'tests - escape' stamp: ''!
testEscapeCharacter
	"Test the escape \ in simple case (here, bold one)"

	| res |
	res := self splitter parse: 'abc\**test**last'.
	self assert: res first class equals: MicTextBlock.
	
	"The following is plain wrong we are losing the \ information!!"
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc**test**last' }! !

!MicInlineParserTest methodsFor: 'tests - annotation' stamp: ''!
testUnclosedAnnotation

	| res |
	res := self splitter parse: 'abc<?an annotation>def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc<?an annotation>def' }! !

!MicInlineParserTest methodsFor: 'tests - url' stamp: ''!
testUrlObjectInUrlBlocks

	| res |
	res := self splitter parse: 'abc[test](myURL)last'.
	self assert: (res second url isKindOf: MicResourceReference)
! !

!MicInlineParserTest methodsFor: 'tests - link' stamp: ''!
testSplitBlockLink
	"Test the link annotation [LinkText](url)"

	| res |
	res := self splitter parse: 'abc[LinkText](myURL)last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[LinkText](myURL)'. 'last' }.
	self assert: (res second url isKindOf: MicResourceReference)
! !

!MicInlineParserTest methodsFor: 'tests - annotation' stamp: ''!
testAnnotationWithParametersWithBlank

	| res |
	res := self splitter parse: 'abc',MicAnnotationOpenerDelimiter markup,'an annotation|key=&label=42',MicAnnotationCloserDelimiter markup,'def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. MicAnnotationOpenerDelimiter markup,'an annotation|key=&label=42',MicAnnotationCloserDelimiter markup.
			'def' }.
	self assert: (res second isKindOf: MicAnnotationBlock).
	self assert: (res second arguments at: 'key') equals: ''.
	self assert: (res second arguments at: 'label') equals: '42'! !

!MicInlineParserTest methodsFor: 'tests - escape' stamp: ''!
testEscapeCharacterInLinkName
	"Test the escape \ in link description"

	| res |
	res := self splitter parse: 'abc[\**test**](myURL)last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[**test**](myURL)'. 'last' }! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testStrike

	| res |
	res := self splitter parse: 'abc~strike~def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[strike](strike)'. 'def' }.
	self assert: res second class equals: MicStrikeFormatBlock! !

!MicInlineParserTest methodsFor: 'tests - anchors' stamp: ''!
testAnchorReference

	| res |
	res := self splitter parse: 'abc*@anchorA@*def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[anchorA](anchorReference)'.
		'def' }.
	self assert: (res second isKindOf: MicAnchorReferenceBlock)! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testSequenceOfFormats
	"Test with multiple annotations"

	| res |
	res := self splitter parse: 'abc**abc**xyz`xyz`last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[abc](bold)'. 'xyz'. '[xyz](monospace)'.
		'last' }! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testUnclosedBold

	| res |
	res := self splitter parse: 'abc**xyz'.
	self assert: res first printString equals: 'abc**xyz'! !

!MicInlineParserTest methodsFor: 'tests - various' stamp: ''!
testExclamationMark

	"Test that 'bla!!bla' is ok, and not a failed image, same goes for '!![goo]no parenthesis'"

	| res |
	res := self splitter parse: 'bla!!bla'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'bla!!bla' }.
	res := self splitter parse: '!![goo]no parenthesis'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { '!![goo]no parenthesis' }! !

!MicInlineParserTest methodsFor: 'tests - escape' stamp: ''!
testEscapeCharacterAtBeginning
	"Test the escape \ in simple case (here, bold one)"

	| res |
	res := self splitter parse: '\**test**'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { '**test**' }! !

!MicInlineParserTest methodsFor: 'tests - link' stamp: ''!
testSplitBlockLinkWithParenthesesInsteadOfBracket

	"Test the link annotation [LinkText](url)"

	| res |
	res := self splitter parse: 'abc(LinkText)(myURL)last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc(LinkText)(myURL)last' }! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testItalic

	| res |
	res := self splitter parse: 'abc_italics_def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[italics](italic)'. 'def' }.

	res := self splitter parse: 'abc_ ita lics _def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[ ita lics ](italic)'. 'def' }! !

!MicInlineParserTest methodsFor: 'tests - link' stamp: ''!
testParseMissingStartURL
	"Test the link annotation [LinkText]url)"

	| res |
	res := self splitter parse: '[Pharo is cool])'.
	self assert: res first class = MicTextBlock.! !

!MicInlineParserTest methodsFor: 'tests - link' stamp: ''!
testParseMissingStartURLInPresenceOfNestedFormat
	"Test the link annotation [LinkText]url) _*foo*_"

	| res |
	res := self splitter parse: '[LinkText]htt) 
	_*foo*_'.
	self assert: res first class = MicTextBlock.
! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testMultipleSequenceFormats

	"Test with multiple annotations"

	| res |
	res := self splitter parse: 'abc**abc**xyz`xyz`last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[abc](bold)'. 'xyz'. '[xyz](monospace)'.
		'last' }! !

!MicInlineParserTest methodsFor: 'tests - link' stamp: ''!
testParseShitInMiddleURL
	"Test the link annotation [Pharo is cool]khkjhjkh klhkjhkh (http://pharo.org)"

	| res |
	res := self splitter parse:
		       '[Pharo is cool]khkjhjkh klhkjhkh (http://pharo.org)'.

	self assert: res first class = MicTextBlock.
	self assert: res size equals: 1! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testOverlappingFormat2

	| res |
	res := self splitter parse: 'ab**boldstart_ boldend** _italicstart zz italicEnd_de'.
	self
		assert: (res collect: [ :x | x printString ]) ""
		equals: #('ab' '[boldstart_ boldend](bold)' ' ' '[italicstart zz italicEnd](italic)' 'de')! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testUnclosedStrike

	| res |
	res := self splitter parse: 'abc~strikeédef'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc~strikeédef' }! !

!MicInlineParserTest methodsFor: 'tests - math' stamp: ''!
testUnclosedMath

	| res |
	res := self splitter parse: 'abc$	V_i = C_0 - C_3	&def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc$	V_i = C_0 - C_3	&def' }! !

!MicInlineParserTest methodsFor: 'tests to make green again' stamp: ''!
testUrlObjectInUrlBlocks2

	| res |
	res := self splitter parse:
		       'abc[pulse](https://github.com/Ducasse/NewTools-NewHelpBrowser/pulse#merged-pull-requests)last'.
	self assert: (res second url isKindOf: MicResourceReference).
	self flag: #tofix. "substring just returns pulse???"
	self assert: res second url printString  equals: 'https://github.com/Ducasse/NewTools-NewHelpBrowser/pulse#merged-pull-requests'! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testMonospace

	| res |
	res := self splitter parse: 'ab`block`de'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'ab'. '[block](monospace)'. 'de' }! !

!MicInlineParserTest methodsFor: 'tests - raw' stamp: ''!
testRawUnevaluated

	"When isEvaluated class method returns false, like raw's case, inline inside shoudn't be evaluated"

	| res |
	res := self splitter parse: 'abc{{def**not bold**ghi}}xyz'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[def**not bold**ghi](raw)'.
		'xyz' }! !

!MicInlineParserTest methodsFor: 'tests - formats' stamp: ''!
testBold

	| res |
	res := self splitter parse: 'abc**bold**def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[bold](bold)'. 'def' }.
	self assert: res second kind equals: #bold.

	res := self splitter parse: 'abc** b old **def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[ b old ](bold)'. 'def' }.
	self assert: res second kind equals: #bold! !

!MicInlineParserTest methodsFor: 'tests - math' stamp: ''!
testMath2

	| res |
	res := self splitter parse: 'abc$math env$def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[math env](math)'. 'def' }! !

!MicInlineParserTest methodsFor: 'tests - annotation' stamp: ''!
testAnnotationWithParameters

	| res |
	res := self splitter parse:
		       'abc',MicAnnotationOpenerDelimiter markup,'an annotation|key=cite&label=42',MicAnnotationCloserDelimiter markup,'def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. MicAnnotationOpenerDelimiter markup,'an annotation|key=cite&label=42', MicAnnotationCloserDelimiter markup.
			'def' }.
	self assert: (res second isKindOf: MicAnnotationBlock).
	self assert: (res second arguments at: 'key') equals: 'cite'.
	self assert: (res second arguments at: 'label') equals: '42'! !

!MicInlineParserTest methodsFor: 'tests - annotation' stamp: ''!
testSplitBlockAnnotation

	| res |
	res := self splitter parse: 'abc',MicAnnotationOpenerDelimiter markup,'an annotation',MicAnnotationCloserDelimiter markup,'def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. MicAnnotationOpenerDelimiter markup,'an annotation',MicAnnotationCloserDelimiter markup. 'def' }.
	self assert: (res second isKindOf: MicAnnotationBlock)! !

!MicInlineParserTest methodsFor: 'tests - raw' stamp: ''!
testRaw

	| res |
	res := self splitter parse: 'abc{{someRaw}}def'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[someRaw](raw)'. 'def' }! !

!MicInlineParserTest methodsFor: 'tests - link' stamp: ''!
testSplitBlockLinkInlineImage

	| res |
	res := self splitter parse: 'abc[!![alttext](imageurl)](url)last'.
	self
		assert: (res collect: [ :x | x printString ])
		equals: { 'abc'. '[!![alttext](imageurl)](url)'.
			'last' }.
! !

!MicInputfileBlock commentStamp: ''!
may be rename the class later!
!MicInputfileBlock methodsFor: 'accessing' stamp: ''!
originalPath
	^ properties at: #originalPath ifAbsent: [ self path ]! !

!MicInputfileBlock methodsFor: 'testing' stamp: ''!
closeMe
	| p |
	super closeMe.
	p := arguments at: #path ifAbsent: [ 'notfound' ].
	p = 'notfound'
		ifTrue: [ self path: (MicBrokenResource new originalString: substring; yourself) ]
		ifFalse: [self path: (MicResourceReference fromString: (arguments at: #path)) ]! !

!MicInputfileBlock methodsFor: 'accessing' stamp: ''!
path: aPath
	
	arguments at: #'path' put: aPath! !

!MicInputfileBlock methodsFor: 'testing' stamp: ''!
isRelativeFilePath
	^ (self path beginsWith: '/') not! !

!MicInputfileBlock methodsFor: 'accessing' stamp: ''!
fileWithConfiguration: aConfiguration
	"I search my file."
	self flag: 'can be better to use the MicPathResolver'.
	^ aConfiguration baseDirectory resolve: self path! !

!MicInputfileBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	aVisitor visitInputfile: self! !

!MicInputfileBlock methodsFor: 'accessing' stamp: ''!
path
	
	^ self arguments at: #path  ifAbsent: [ ^ 'path is absent' ]! !

!MicInputfileBlock class methodsFor: 'accessing' stamp: ''!
tag 
	^ #inputfile! !

!MicInputfileBlockTest methodsFor: 'tests' stamp: ''!
testMicInputfilePath
	| mic |
	mic := parser parse: '?{inputfile|path=chapters/withStyle.mic}?'.
	self assert: mic children first children first path path pathString equals: 'chapters/withStyle.mic' ! !

!MicInputfileBlockTest methodsFor: 'tests' stamp: ''!
testMicInputfilePathError
	| mic |
	mic := parser parse: '?{inputfile|path:errror=fchapters/withStyle.mic}?'.
	self assert: mic children first children first path class equals: MicBrokenResource.
	self 
		assert: mic children first children first path originalString 
		equals: 'inputfile|path:errror=fchapters/withStyle.mic'! !

!MicInputfileBlockTest methodsFor: 'tests' stamp: ''!
testMicInputfileIsNotRelativeFilePath
	| mic |
	mic := parser parse: '?{inputfile|path=/chapters/withStyle.mic}?'.
	self assert: mic children first children first path path pathString equals: '/chapters/withStyle.mic'! !

!MicInputfileBlockTest methodsFor: 'tests' stamp: ''!
testMicInputfileIsRelativeFilePath
	| mic |
	mic := parser parse: '?{inputfile|path=chapters/withStyle.mic}?'.
	mic children first children first path: mic children first children first originalPath.
	self assert: mic children first children first path path pathString equals: 'chapters/withStyle.mic'! !

!MicInputfileBlockTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	parser := MicroDownParser new! !

!MicItalicDelimiter commentStamp: ''!
I am the delimiter for italic/emphasis format.!
!MicItalicDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicItalicFormatBlock ! !

!MicItalicDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicItalicDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '_'! !

!MicItalicDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ true! !

!MicItalicDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #italic! !

!MicItalicFormatBlock commentStamp: ''!
I represent an italic text section. I'm delimited using `_` as in `_italic_` to obtain _italic_.!
!MicItalicFormatBlock methodsFor: 'accessing' stamp: ''!
kind

	^ #italic! !

!MicItalicFormatBlock methodsFor: 'accessing' stamp: ''!
openingDelimiter

 	^ MicItalicDelimiter markup! !

!MicItalicFormatBlock methodsFor: 'accessing' stamp: ''!
closingDelimiter

 	^ MicItalicDelimiter markup! !

!MicItalicFormatBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitItalic: self! !

!MicLinkBlock commentStamp: ''!
I represent a reference in a text. For example `[http://pharo.org](http://pharo.org)` creates [http://pharo.org](http://pharo.org).!
!MicLinkBlock methodsFor: 'accessing' stamp: ''!
kind

 	^ #linkName! !

!MicLinkBlock methodsFor: 'visiting' stamp: ''!
closeMe
	"testAsFileUrl
	self assert: 'http://localhost:80/foo/bar/doc.txt' asZnUrl asFileUrl isFile.
	self 
		assert: 'http://localhost:80/foo/bar/doc.txt' asZnUrl path 
		equals: 'http://localhost:80/foo/bar/doc.txt' asZnUrl asFileUrl path"
	
	self url: (MicResourceReference fromString: self url).
	caption := self inlineParse: substring.! !

!MicLinkBlock methodsFor: 'accessing' stamp: ''!
openingDelimiter

 	^ MicLinkNameOpenerDelimiter markup! !

!MicLinkBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitLink: self! !

!MicLinkBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicHorizontalLineBlock! !

!MicLinkBlockTest methodsFor: 'tests' stamp: ''!
testUrl

	| link |
	link := (splitterClass new parse: '[caption](http://www.pharo.org:8080)') first.
	self assert: link url printString equals: 'http://www.pharo.org:8080'! !

!MicLinkBlockTest methodsFor: 'tests' stamp: ''!
testPrintOn

	| link |
	link := (splitterClass new parse: '[caption](http://www.pharo.org)') first.
	self assert: link asString equals: '[caption](http://www.pharo.org)'! !

!MicLinkBlockTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	parser := self parser. 
	splitterClass := MicInlineParser! !

!MicLinkNameCloserDelimiter commentStamp: ''!
I am the closer delimiter for link name.!
!MicLinkNameCloserDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ nil! !

!MicLinkNameCloserDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ false! !

!MicLinkNameCloserDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ ']'! !

!MicLinkNameCloserDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ true! !

!MicLinkNameCloserDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #linkName! !

!MicLinkNameOpenerDelimiter commentStamp: ''!
I am the opener delimiter for link name.!
!MicLinkNameOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicLinkBlock ! !

!MicLinkNameOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicLinkNameOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '['! !

!MicLinkNameOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ false! !

!MicLinkNameOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #linkName! !

!MicListBlock commentStamp: ''!
I am an abstract class for the two kind of lists, ordered and unordered.
When I created I automatically add a listitem as my child.
Unordered list line starts with `-`,  ordered list starts with number.
An empty or a wrong indent closes me.

Here is an example:
- bullet list item 1
- bullet list item 2
  1. sublist ordered item 2.1
  3. sublist ordered item 2.2
- bullet list item 3

Indentation (two spaces) matters and is crucial. 
Here is an example
```
- item 1
xx- subitem 1.1
xx- subitem 2.1
- item 2
xx- subitem 2.1
xxxx- subsubitem 2.1.1
xx- subitem 2.2
```
produces:
- item 1
  - subitem 1.1
  - subitem 2.1
- item 2
  - subitem 2.1
    - subsubitem 2.1.1
  - subitem 2.2

Now an ordered list can also contain an unordered list.
1. first
2. second 
   - subitem 2.1
   - subitem 2.2
3. third


!
!MicListBlock methodsFor: 'accessing' stamp: ''!
closeMe
	super closeMe.
	nestedLevel := self computeNestedLevel! !

!MicListBlock methodsFor: 'accessing' stamp: ''!
indent
	^ indent! !

!MicListBlock methodsFor: 'indent' stamp: ''!
indentFromLine: aLine
	"The line is expected to have the form: '<bullet> space+ [text]', where bullet is one of *,+,- or 1. or 1). More than one space is allowed. 
	indentFromLine returns the position of the last character before the text.
	The indentation returned is *the number of characters*, that is, tab counts for but one char."

	| regEx |
	indent ifNotNil: [ ^self ].
	regEx := '(\S+)(\s*)' asRegex.
	regEx matchesPrefix: aLine.
	indent := parent indent + (regEx subexpression: 1) size! !

!MicListBlock methodsFor: 'testing' stamp: ''!
addLineAndReturnNextNode: inLine
	"Create a new item, and insert it into me.
	line is on the format 'markup text'"

	| line |
	inLine ifEmpty: [ ^ self ].
	"A list accept an empty - like that it avoids to close the block (the list) and we can have space between list item.
	Now we do nothing with empty so just do not create new item or whatever."
	line := inLine trim.
	self indentFromLine: line.
	^ self listItemBlockClass new
		setParser: parser; 
		parent: self;
		addLineAndReturnNextNode: (line copyFrom: indent - parent indent to: line size)! !

!MicListBlock methodsFor: 'testing' stamp: ''!
canConsumeLine: line
	"to consume this line there must be a ListItem starting at the right indentation"
	
	(parent indent = 0
		or: [ line beginsWith: (' ' repeat: parent indent) ])
		ifFalse: [ ^ false ].
	^true! !

!MicListBlock methodsFor: 'indent' stamp: ''!
computeNestedLevel
	
	^ self parent computeNestedLevel + 1! !

!MicListBlock methodsFor: 'indent' stamp: ''!
nestedLevel
	"Return the nesting level of main blocks. Basically only list increases this."
	
	^ nestedLevel! !

!MicListItemBlock commentStamp: ''!
I represent one item in a list (ordered or non-ordered)!
!MicListItemBlock methodsFor: 'accessing' stamp: ''!
text
	"Returns a string we should rename text into textString"
	^ String streamContents: [ :s | self textElements do: [:each | s nextPutAll: each substring ]]! !

!MicListItemBlock methodsFor: 'accessing' stamp: ''!
textElements 
	
	^ text ! !

!MicListItemBlock methodsFor: 'testing' stamp: ''!
isAList: normalized

	^ parser isAList: normalized! !

!MicListItemBlock methodsFor: 'visiting' stamp: ''!
closeMe
	super closeMe.
	text := self inlineParse: text.
	! !

!MicListItemBlock methodsFor: 'testing' stamp: ''!
addLineAndReturnNextNode: line
	"add line to this node. 
	Notice, the action is allowed to create new nodes in the block tree.
	Returns the node to handle next line - typically self."
	
	
	| normalized |
	text
		ifNil: [ text := line trim.
			^ self ].
	normalized := line copyFrom: parent indent + 1 to: line size.	"drop indent"
	"SD: I thought that a list item was holding a paragraph but it holds directly text."
		
	(self isAList: normalized)
		ifTrue: [ ^ self newBlockFor: normalized parent: self ]
		ifFalse: [ text := text , String cr , normalized ]! !

!MicListItemBlock methodsFor: 'testing' stamp: ''!
canConsumeLine: line
	"return if this block can consume line"

	^ line beginsWith: (' ' repeat: parent indent)! !

!MicListItemBlock methodsFor: 'accessing' stamp: ''!
computeNestedLevel
	"An item has the same nested level than its parent."
	^ self parent computeNestedLevel! !

!MicListItemBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitListItem: self! !

!MicListItemBlock methodsFor: 'accessing' stamp: ''!
nestedLevel
	"Return the nesting level of main blocks. Basically only list increases this."
	
	^ self parent nestedLevel ! !

!MicLocalFileResource methodsFor: 'converting' stamp: ''!
string: aString

	super string: aString.
	urlOrFileReference := Path from: originalString! !

!MicLocalFileResource methodsFor: 'converting' stamp: ''!
asFileReference

	^ self! !

!MicLocalFileResource methodsFor: 'converting' stamp: ''!
resolvedWithResolver: aResolver
	"Experimental"
	^ (aResolver resolutionSource isKindOf: ZnUrl)
		ifTrue: [ 
			"I'm http://files.pharo.org/...."
			| resolverPath |
			"needed because withRelatedReference: does not handle well http://pharo.org/figures/"
			resolverPath := Path from: aResolver resolutionSource path.
			MicHTTPResource new 
				originalString: originalString; 
				url: (aResolver resolutionSource withRelativeReference: resolverPath) ]
		ifFalse: [ 
			"I have a file reference but no filesystem (for example a pharo image) + and local path"
			| resolverPath |
			resolverPath := aResolver resolutionSource path.
			self class new 
				originalString: originalString; 
				url: (aResolver resolutionSource resolvePath: (resolverPath resolvePath: self path)) ]
			! !

!MicLocalFileResource methodsFor: 'converting' stamp: ''!
resolvedBy: aRoot
	
	^ (aRoot isKindOf: FileReference)
			ifTrue: [ MicLocalFileResource new 
								originalString: originalString; 
								url: (aRoot resolvePath: self path) ]
			ifFalse: [ 
					MicHTTPResource new 
								originalString: originalString;
								url: (aRoot withRelativeReference: originalString) ].! !

!MicLocalFileResource methodsFor: 'converting' stamp: ''!
resolvedBy: parentPath withResolver: aResolver
	
	^ (aResolver resolutionSource isKindOf: ZnUrl)
		ifTrue: [ 
			"I'm http://files.pharo.org/...."
			| resolverPath |
			"needed because withRelatedReference: does not handle well http://pharo.org/figures/"
			resolverPath := Path from: aResolver resolutionSource path.
			MicHTTPResource new 
				originalString: originalString; 
				url: (aResolver resolutionSource withRelativeReference: (resolverPath resolvePath: self path ) pathString) ]
		ifFalse: [ 
			"I have a filesystem + parentPath and local path"
			| resolverPath |
			resolverPath := aResolver resolutionSource path.
			self class new 
				originalString: originalString; 
				url: (aResolver resolutionSource resolvePath: (resolverPath resolvePath: (parentPath resolvePath: self path))) ]
			! !

!MicLocalFileResource methodsFor: 'converting' stamp: ''!
fullName 
	^ urlOrFileReference fullName! !

!MicMathBlock commentStamp: ''!
I'm a math environment. I'm a block it means that I start by a newline with character `&` and optional parameters, and I finish by a line with the same character. 
My body can be on multiple line and may contain LaTeX expressions.

Here is an example 

```
&
V_i = C_0 - C_3
&
```

produces 

&
V_i = C_0 - C_3
&

!
!MicMathBlock methodsFor: 'markups' stamp: ''!
lineStartMarkup
	
	^ parser mathOpeningBlockMarkup! !

!MicMathBlock methodsFor: 'accessing' stamp: ''!
arguments
	self flag: #strange.
	"why this is not called directly during the closeMe phase."
	^ arguments ifNil: [ arguments := ZnResourceMetaUtils parseQueryFrom: firstLine readStream ]! !

!MicMathBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor 
 	^ aVisitor visitMath: self! !

!MicMathBlockTest methodsFor: 'tests' stamp: ''!
testMathBlockWithParametersWithBlank

	| root math |
	root := (MicroDownParser new parse: '

&key=&label=42
V_i = C_0 - C_3 
&
').
	math := root children first.
	self assert: math class equals: MicMathBlock.
	self assert: math firstLine equals: 'key=&label=42'.
	self assert: (math arguments at: 'key') equals: ''.
	self assert: (math arguments at: 'label') equals: '42'! !

!MicMathBlockTest methodsFor: 'tests' stamp: ''!
testMathBlockIsMathBlock

	| root |
	root := (MicroDownParser new parse: '

&
V_i = C_0 - C_3
&


').
	self assert: root children first class equals: MicMathBlock ! !

!MicMathBlockTest methodsFor: 'tests' stamp: ''!
testMathBlockWithParameters

	| root math |
	root := (MicroDownParser new parse: '

&key=cite&label=42
V_i = C_0 - C_3 
&
').
	math := root children first.
	self assert: math class equals: MicMathBlock.
	self assert: math firstLine equals: 'key=cite&label=42'.
	self assert: (math arguments at: 'key') equals: 'cite'.
	self assert: (math arguments at: 'label') equals: '42'! !

!MicMathBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicMathBlock ! !

!MicMathBlockTest methodsFor: 'tests' stamp: ''!
testMathBlockWithParametersCaptionAndFormatting

	| root math |
	root := (MicroDownParser new parse: '

&key=cite&label=42&caption=Ze **great** formula
V_i = C_0 - C_3 
&
').
	math := root children first.
	self assert: math class equals: MicMathBlock.
	self assert: math firstLine equals: 'key=cite&label=42&caption=Ze **great** formula'.
	self assert: (math arguments at: 'key') equals: 'cite'.
	self assert: (math arguments at: 'label') equals: '42'.
	self assert: (math arguments at: 'caption') first kind equals: 'basic'.
	self assert: math caption equals: 'Ze great formula'.
	self assert: math captionElements second kind equals: 'bold' ! !

!MicMathBlockTest methodsFor: 'tests' stamp: ''!
testMathBlockWithBadClosure

	| root |
	"a MicMathBlock can use the MicMathInlineBlock delimiter"
	root := (MicroDownParser new parse: '

&key=cite&label=42
V_i = C_0 - C_3 
$
').
	self assert: root children first body  equals: 'V_i = C_0 - C_3 
$'.! !

!MicMathBlockTest methodsFor: 'tests' stamp: ''!
testMathBlockWithParametersCaption

	| root math |
	root := (MicroDownParser new parse: '

&key=cite&label=42&caption=Ze great formula
V_i = C_0 - C_3 
&
').
	math := root children first.
	self assert: math class equals: MicMathBlock.
	self assert: math firstLine equals: 'key=cite&label=42&caption=Ze great formula'.
	self assert: (math arguments at: 'key') equals: 'cite'.
	self assert: (math arguments at: 'label') equals: '42'.
	self assert: (math arguments at: 'caption') first substring equals: 'Ze great formula'.
	self assert: math caption equals: 'Ze great formula'.! !

!MicMathDelimiter commentStamp: ''!
I'm a delimiter for math inline. An example is $V_i = C_0 - C_3$.
I delimits `MicMathInlineBlock`.!
!MicMathDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicMathInlineBlock ! !

!MicMathDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicMathDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '$'! !

!MicMathDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ true! !

!MicMathDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #math! !

!MicMathInlineBlock commentStamp: ''!
Microdown supports in text math expression as in LaTeX using `$ 1 + 2 $`. Each exporter is then responsible to map the contents to the correct output. For PDF based on LaTeX mathInlineBlock can contain LaTeX, for HTML we expect the same using corresponding math library in JS.

Here are several examples:

#### Example 1
Code: `$V_i = C_0 - C_3$`

$V_i = C_0 - C_3$

#### Example 2
Code: `$a^2 + b^2 = c^2$`

$a^2 + b^2 = c^2$

#### Example 3
Code: `$\\sin(x) = \\sum_{n=0}^{\\infty} \\frac{(-1)^{n}x^{2n+1}}{(2n+1)!!}$`

$\\sin(x) = \\sum_{n=0}^{\\infty} \\frac{(-1)^{n}x^{2n+1}}{(2n+1)!!}$

#### Example 4
Code: `$f(a) = \\frac{1}{2\\pi i} \\oint_{\\gamma} \\frac{f(z)}{z - a} dz$`

$f(a) = \\frac{1}{2\\pi i} \\oint_{\\gamma} \\frac{f(z)}{z - a} dz$
!
!MicMathInlineBlock methodsFor: 'accessing' stamp: ''!
kind

 	^ #math! !

!MicMathInlineBlock methodsFor: 'visiting' stamp: ''!
closeMe 
	self flag: #back. "self halt"! !

!MicMathInlineBlock methodsFor: 'accessing' stamp: ''!
openingDelimiter

 	^ MicMathDelimiter markup! !

!MicMathInlineBlock methodsFor: 'accessing' stamp: ''!
closingDelimiter

 	^ MicMathDelimiter markup! !

!MicMathInlineBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitMathInline: self! !

!MicMathInlineBlock class methodsFor: 'testing' stamp: ''!
isEvaluated
	^ false! !

!MicMetaDataBlock commentStamp: ''!
Pillar, when parsing Pillar files, does not represent metadata as PR object but as plain ston objects. PRMetadata got introduced to support the migration from Pillar to Microdown. 
We will have to learn from doing the migration. 

In Microdown, metadata is a block level expressed as follows:  

```
{
    "title": "Selecting Expressions",
    "author": "S. Ducasse and L. Fabresse with Q. Ducasse",
    "subtitle": "",
    "slidesid": "W1-LiveA-EN"
}
```

This class should be packaged in a separate package because it requires the Pillar extension for books (i.e., package `#'Pillar-Model'`).!
!MicMetaDataBlock methodsFor: 'markups' stamp: ''!
lineStartMarkup

	^ parser metaDataOpeningBlockMarkup! !

!MicMetaDataBlock methodsFor: 'markups' stamp: ''!
lineStopMarkup

	^ parser metaDataClosingBlockMarkup ! !

!MicMetaDataBlock methodsFor: 'markups' stamp: ''!
printOn: aStream

	aStream nextPutAll: 'Metadata: '.
	aStream nextPutAll: (self body asString contractTo: 100)! !

!MicMetaDataBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitMetaData: self! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
strikethroughFormatSample
	^ self surroundWithMarkup: self parserClass strikeMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParameterWithFloatSample
	^ self codeblock: 'ratio=0.8' body: 'bar'
	! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
figureSample
	^ '

!![Foo](/anUrl?label=figureTest&size=80)
'! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
annotatedSample
	^ '!!!!label 
Foo _bar_
'! !

!MicMicrodownSnippetFactory methodsFor: 'annotations' stamp: ''!
annotationSample

	^ '
abc', MicAnnotationOpenerDelimiter markup , 'Foo | value=aFoo&label=42 ', MicAnnotationCloserDelimiter markup ,'def
'! !

!MicMicrodownSnippetFactory methodsFor: 'document' stamp: ''!
lineEndSample

	^  ''! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParameterWithLiteralArraySample
	^ self codeblock: 'foo=#(1 2 true)'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParameterEscapeSample
	^ 'value\==foo'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
orderedListWithTwoItemsSample
	
	^ 
'
1. first
1. second
'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParameterWithSpacesBeforeAndAfterSample
	^ ' foo = true & bar = 2 
'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
unorderedListWithTwoItemsNestedSample

	| listMarkup |
	listMarkup := self parserClass unorderedListMarkup.
	^ self newLine , listMarkup , '~_Foo_~' , self newLine , listMarkup
	  , 'Bar
'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
unorderedListWithTwoItemsBoldSample

	| listMarkup |
	listMarkup := self parserClass unorderedListMarkup.
	^ self newLine , listMarkup , '**Foo**' , self newLine , listMarkup
	  , 'Bar
'! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
anchorReferenceSample
	^ '
*@Foo@*
'! !

!MicMicrodownSnippetFactory methodsFor: 'block' stamp: ''!
commentSample
	^ '% Foo'! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
anchorWithSpaceInsideSample
	^ self parserClass anchorMarkup, 'foo bar'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
nestedBoldFormatSample
	"self new nestedBoldFormatSample"
	^ self surround: (self surround: 'Foo' withMarkup: self parserClass boldMarkup) withMarkup: self parserClass italicMarkup  ! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
paragraphNestedSample
	^ '
this is a **_paragraph_**
'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
orderedListWithTwoItemsStrikeSample
	
	^ 
'
1. ~first~
1. second
'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
orderedListSample
	^ '
1. Foo
'! !

!MicMicrodownSnippetFactory methodsFor: 'document' stamp: ''!
newlineCRLFSample

	^ String crlf! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
superscriptFormatEmptySample
	^ self surround: '' withMarkup: self parserClass superscriptMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
subscriptFormatSample
	^ self surroundWithMarkup: self parserClass subscriptMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
boldFormatEmptySample
	^ self surround: '' withMarkup: self parserClass boldMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
figureItalicSample
	^ '

!![_Foo_](/anUrl?label=figureTest&size=80)
'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
unorderedListWithTwoItemsItalicSample

	| listMarkup |
	listMarkup := self parserClass unorderedListMarkup.
	^ self newLine , listMarkup , '_Foo_' , self newLine , listMarkup
	  , 'Bar
'! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
anchorSample
	^ self parserClass anchorMarkup, 'test'! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
metaDataSample
	^ '{
"author": "Foo"
}
'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
subscriptFormatEmptySample
	^ self surround: '' withMarkup: self parserClass subscriptMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
environmentSample

	^ '
<?Foo|value=aFoo&label=42

Foo

?>'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
nestedOrderedListSample
	^ '
- Foo
- Bar
		1. B
		1. a
		1. r
'! !

!MicMicrodownSnippetFactory methodsFor: 'sample' stamp: ''!
columnSample
	^ '<?column|width=42
	this is a **text**
?>'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
listWithCommentSample
	^ '1. Foo
%Comment
2. Bar'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
figureStrikeSample
	^ '

!![~Foo~](/anUrl?label=figureTest&size=80)
'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParameterWithoutValueSample
	^ 'foo'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
italicFormatEmptySample
	^ self surround: '' withMarkup: self parserClass italicMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerWithNewLineSample

	^ self newLine , self parserClass headerMarkup , 'Foo' , self newLine! !

!MicMicrodownSnippetFactory methodsFor: 'sample' stamp: ''!
simpleTable
	^ '
| aaab | jkhjh |
| --- | --- |
| bar | rab |'! !

!MicMicrodownSnippetFactory methodsFor: 'sample' stamp: ''!
columnsWithChildrenSample
	^ '<?columns|width=42
', self columnSample ,'
', self columnSample,'
?>'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
codeBlockParameterWithLiteralArraySample

	^ self newLine , self codeblock: 'foo=#(1 2 true)'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParameterSample
	^ 'value=foo'! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerWithFormatSampleWithNewLine
	^ self headerWithFormatSample, self newLine! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
monospaceFormatEmptySample
	^ self surround: '' withMarkup: self parserClass monospaceMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
anchorAreTrimedSample
	^ self parserClass anchorMarkup, '  test  '! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerLevel5Sample

	^ self newLine , (self headerLevel: 5)! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
quoteSample
	^ '>  Foo'! !

!MicMicrodownSnippetFactory methodsFor: 'sample' stamp: ''!
simpleTableMoreFormat
	^ '
| **aaab** bbbc _cccd_ | jkhjh |
| --- | --- |
| bar | rab |'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParametersSample
	^ self 
		codeblock:   'foo=true&bar=2'
		body: 'bla'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
orderedListWithTwoItemsItalicSample
	
	^ 
'
1. _first_
1. second
'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
unorderedListWithTwoItemsStrikeSample

	| listMarkup |
	listMarkup := self parserClass unorderedListMarkup.
	^ self newLine , listMarkup , '~Foo~' , self newLine , listMarkup
	  , 'Bar
'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
underlineFormatSample
	^ self surroundWithMarkup: self parserClass underlineMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptWithSpacedParametersSample
	^ self 
		codeblock:   ' foo = true & bar = 2'
		body: 'bla'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
fileFigureSample
	^ '

!![Foo](file://image.png/?label=figureTest&size=80)
'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
figureBoldSample
	^ '

!![**Foo**](/anUrl?label=figureTest&size=80)
'! !

!MicMicrodownSnippetFactory methodsFor: 'sample' stamp: ''!
simpleTableFormat
	^ '
| **aaab** | jkhjh |
| --- | --- |
| bar | rab |'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
surroundWithMarkup: aMarkup
	^ self surround: 'Foo' withMarkup: aMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'utilities' stamp: ''!
space 

	^ String space! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParameterValueSample
	^ '=foo'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptWithNewLineSample

	^ (self codeblockNoParamBody: 'foo') , self newLine! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptWithLanguageSample
	^ self codeblock: 'language=smalltalk' body: 'foo'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
paragraphSample
	^ '
Foo
'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
linkStrikeSample
	^ '
[~Foo~](/anUrl)
'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParametersEscapeSample
	^ 'value=foo\&&bar
'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
strikethroughFormatEmptySample
	^ self surround: '' withMarkup: self parserClass strikeMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParameterTrueByDefaultSample
	^ self codeblock: 'foo' body: 'bar'
	! !

!MicMicrodownSnippetFactory methodsFor: 'sample' stamp: ''!
simpleTableShortRow
	^ '
| aaab | jkhjh |
| --- | --- |
| bar |'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
boldFormatSample
	^ self surroundWithMarkup: self parserClass boldMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
codeblock: param body: body
	
	^ String streamContents: [ :st | 
		st cr.
		st nextPutAll: self parserClass codeblockMarkup. 
		st nextPutAll: param.
		st cr.
		st nextPutAll: body.
		st cr.
		st nextPutAll: self parserClass codeblockMarkup. 
	]! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerLevel2Sample

	^ self newLine , (self headerLevel: 2)! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
unorderedListWithTwoItemsSample

	| listMarkup |
	listMarkup := self parserClass unorderedListMarkup.
	^ self newLine , listMarkup , 'Foo' , self newLine , listMarkup
	  , 'Bar
'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
italicFormatSample
	^ self surroundWithMarkup: self parserClass italicMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptTwoParametersNoValueSample
	^ 'foo&bar
'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
paragraphItalicSample
	^ '
this is a _paragraph_
'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
orderedListEmptySample
	^ '
1. '! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
underlineFormatEmptySample
	^ self surround: '' withMarkup: self parserClass underlineMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'utilities' stamp: ''!
parserClass

	^ MicroDownParser! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParameterWithNoValuesSample
	^ self codeblock: 'foo=' body: 'bar'
! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
superscriptFormatSample
	^ self surroundWithMarkup: self parserClass superscriptMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
codeblock: param 

	^ String streamContents: [ :st | 
		st cr.
		st nextPutAll: self parserClass codeblockMarkup. 
		st nextPutAll: param.
		st cr.
		st nextPutAll: self parserClass codeblockMarkup. 
	]! !

!MicMicrodownSnippetFactory methodsFor: 'document' stamp: ''!
rootSample

	| stream |
	stream := (String new: 10000) writeStream.
	stream
		nextPutAll: self headerLevel2Sample;
		nextPutAll: self newLine;
		nextPutAll: self paragraphNestedSample;
		nextPutAll: self figureSample.
	^ stream contents! !

!MicMicrodownSnippetFactory methodsFor: 'sample' stamp: ''!
tableSample
	^ '| aaab | jkhjh |
| --- | --- |
| bar | rab |
'! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
mathInlineSample
	^ '
$V_i = C_0 - C_3$
'! !

!MicMicrodownSnippetFactory methodsFor: 'document' stamp: ''!
newlineLFSample

	^ String lf! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerWithFormatSample

	^ self newLine , self parserClass headerMarkup , self space
	  , self boldFormatSample! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
linkItalicSample
	^ '
[_Foo_](/anUrl)
'! !

!MicMicrodownSnippetFactory methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	parserClass := MicroDownParser! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
rawFormatSample
	^ '
a{{Foo}}b
'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptWithSpaceAtTheEndSample
		
	 ^ (self codeblockNoParamBody: 'foo'), '  '.

! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
paragraphStrikeSample
	^ '
this is a ~paragraph~
'! !

!MicMicrodownSnippetFactory methodsFor: 'sample' stamp: ''!
inputfileSample
	^ '
?{inputfile | path=Chapters/text.mic}?
'! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
mathParametersSample
	^ '&label=42
Foo
&'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
figureMonospaceSample
	^ '

!![`Foo`](/anUrl?label=figureTest&size=80)
'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptSample
	^ self codeblockNoParamBody: 'foo'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
orderedListWithTwoItemsNestedSample
	
	^ 
'
1. **_first_**
1. second
'! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerLevel3SampleWithNewLine

	^ self newLine , (self headerLevel: 3) , self newLine! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
linkSample
	^ '
[Foo](/anUrl)
'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParametersWithCaptionSample
	^ self 
		codeblock:   'caption=`Color` is beautifull&bar=2'
		body: 'bla'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
unorderedListWithSubListSample

	| listMarkup |
	listMarkup := self parserClass unorderedListMarkup.
	^ self newLine , listMarkup , 'Foo' , self newLine , listMarkup
	  , listMarkup , 'Bar'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
paragraphBoldSample
	^ '
this is a **paragraph**
'! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerLevel: n

	^ String streamContents: [ :st |
		 n timesRepeat: [ st nextPutAll: self parserClass headerMarkup ].
		 st nextPutAll: ' Foo']! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
mathParametersWithCaptionSample
	^ '&caption=`Math` is good&label=42
Foo
&'! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
environmentWithInnerBlockSample
	^ '<?Foo|value=aFoo&label=42
This is a **paragraph**

```language=Smalltalk&caption=`Color` is cool
This is a codeBlock
```
[ this is an _url_ ](/anExternalLink)

?>'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
linkMonospaceSample
	^ '
[`Foo`](/anUrl)
'! !

!MicMicrodownSnippetFactory methodsFor: 'utilities' stamp: ''!
newLine
	^  String cr! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
nestedUnorderedListSample
	^ '
- Foo
- Bar
		- B
		- a
		- r
'! !

!MicMicrodownSnippetFactory methodsFor: 'document' stamp: ''!
newlineCRSample

	^ self newLine! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
horizontalLineSample

	^ parserClass horizontalLineMarkup , self newLine! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
orderedListWithTwoItemsMonospaceSample
	
	^ 
'
1. `first`
1. second
'! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
monospaceFormatSample
	^ self surroundWithMarkup: self parserClass monospaceMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
unorderedListSample

	^ self newLine , self parserClass unorderedListMarkup , 'Foo
'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
unorderedListEmptySample
	^ self parserClass unorderedListMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
unorderedListWithTwoItemsMonospaceSample

	| listMarkup |
	listMarkup := self parserClass unorderedListMarkup.
	^ self newLine , listMarkup , '`Foo`' , self newLine , listMarkup
	  , 'Bar
'! !

!MicMicrodownSnippetFactory methodsFor: 'utilities' stamp: ''!
documentFrom: aString
	^ parserClass new parse: aString! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerWithNestedFormatSampleWithNewLine

	^ self newLine , self parserClass headerMarkup , self space
	  , self nestedBoldFormatSample , self newLine! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
anchorWithNewLineSample

	^ self parserClass anchorMarkup , 'foo' , self newLine! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
linkNestedSample
	^ '
[**_Foo_**](/anUrl)
'! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerLevel4Sample

	^ self newLine , (self headerLevel: 4)! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
surround: aWord withMarkup: aMarkup
	^ (aMarkup, aWord, aMarkup) asString! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerLevel6Sample

	^ self newLine , (self headerLevel: 6)! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
linkBoldSample
	^ '
[**Foo**](/anUrl)
'! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerEmptySample

	^ self newLine , self parserClass headerMarkup! !

!MicMicrodownSnippetFactory methodsFor: 'document' stamp: ''!
lineEndwithNewlineSample

	^ String lf! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
paragraphMonospaceSample
	^ '
this is a `paragraph`
'! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerLevel3Sample

	^ self newLine , (self headerLevel: 3)! !

!MicMicrodownSnippetFactory methodsFor: 'sample' stamp: ''!
simpleTableWithoutHeaderTable
	^ '
| aaab | jkhjh |
| bar | rab |'! !

!MicMicrodownSnippetFactory methodsFor: 'document' stamp: ''!
newlineSample

	^ Smalltalk os lineEnding! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
listMultiSample

	| unordered |
	unordered := self parserClass unorderedListMarkup.

	^ unordered , '1' , self newLine , unordered , unordered , '2'
	  , self newLine , unordered , unordered , unordered , '3'
	  , self newLine , unordered , unordered , '4' , self newLine
	  , unordered , unordered , '5' , self newLine , unordered
	  , unordered , '6' , self newLine , unordered , '7' , self newLine
	  , unordered , '2. 8'! !

!MicMicrodownSnippetFactory methodsFor: 'anchor' stamp: ''!
footnoteSample
	^ MicAnnotationOpenerDelimiter markup ,'footnote|note=Pharo is cool', MicAnnotationCloserDelimiter markup! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
scriptParametersMultipleSample
	^ 'value=foo&bar
'! !

!MicMicrodownSnippetFactory methodsFor: 'list' stamp: ''!
orderedListWithTwoItemsBoldSample
	
	^ 
'
1. **first**
1. second
'! !

!MicMicrodownSnippetFactory methodsFor: 'code block' stamp: ''!
codeblockNoParamBody: body

	^ String streamContents: [ :st | 
		st cr.
		st nextPutAll: self parserClass codeblockMarkup. 
		st cr.
		st nextPutAll: body.
		st cr.
		st nextPutAll: self parserClass codeblockMarkup. 
	]! !

!MicMicrodownSnippetFactory methodsFor: 'format' stamp: ''!
figureNestedSample
	^ '

!![**Foo\_**](/anUrl?label=figureTest&size=80)
'! !

!MicMicrodownSnippetFactory methodsFor: 'sample' stamp: ''!
columnsSample
	^ '<?columns|width=42
?>'! !

!MicMicrodownSnippetFactory methodsFor: 'headers' stamp: ''!
headerLevel1Sample

	^ self newLine , (self headerLevel: 1)! !

!MicMicrodownTextualBuilder commentStamp: ''!
I'm a textual builder for Microdown: Using my API clients can generate text in Microdown format.


I have two kinds of clients.
- some to generate using high level Microdown blocks and text.
  for example using `paragraph: aBlock` I will generate a block and do not force the user to think about newline.
- some to generate pieces of text. For example the Pillar writer will invoke the raw version. For example `rawParagraph: aBlock` just issue a paragraph without taken care about new line.


#### Known limits 
Nested lists are probably not well managed.
In particular since ordered and unordered do not have the same indentation length 
we would have to know all the nested path and not just the level.!
!MicMicrodownTextualBuilder methodsFor: 'element - figure' stamp: ''!
figureURL: aUrl withCaption: aDescriptionBlock

	self rawFigureDescription: aDescriptionBlock.
	self raw: parserClass urlOpenerMarkup.
	self raw: aUrl asString. 
	self raw: parserClass urlCloserMarkup! !

!MicMicrodownTextualBuilder methodsFor: 'ugly line handling' stamp: ''!
lines: aString
	"Output aString and take care of line ending within aString."
	| str |
	str := aString readStream.
	[ str atEnd ] whileFalse: [ | line |
		line := str nextLine.
		str atEnd
			ifTrue: [ self nextPutAll: line ]
			ifFalse: [ self line: line ]
	 ]! !

!MicMicrodownTextualBuilder methodsFor: 'element - header' stamp: ''!
header: aBloc withLevel: anInteger
	self rawHeader: aBloc withLevel: anInteger.
	self newLine! !

!MicMicrodownTextualBuilder methodsFor: 'writing low-level' stamp: ''!
rawHeader: aBloc withLevel: anInteger

	self raw: (parserClass headerMarkup repeat: anInteger).
   self raw: String space.
	self flag: #todo. 
	"in this future once we are sure no one use header: [:b | b...] but [abuilder ..
	we should replace aBloc cull: self by aBloc value"
   aBloc cull: self 
	! !

!MicMicrodownTextualBuilder methodsFor: 'element - format' stamp: ''!
italic: aBlock
	self raw: parserClass italicMarkup.
	aBlock value.
	self raw: parserClass italicMarkup.! !

!MicMicrodownTextualBuilder methodsFor: 'element - list' stamp: ''!
writeStartOfOrderedListIndex: anInteger
	"does not handle for now nesting"
	self raw: anInteger asString, parserClass orderedListSemiMarkup! !

!MicMicrodownTextualBuilder methodsFor: 'element - format' stamp: ''!
mathInline: aText

	self raw: MicMathDelimiter markup.
	self raw: aText.
	self raw: MicMathDelimiter markup.! !

!MicMicrodownTextualBuilder methodsFor: 'element - environment' stamp: ''!
environment: aName body: aBodyBlock arguments: aCol
	self raw: parserClass environmentOpeningBlockMarkup.
	self raw: aName.
	self raw: parserClass argumentListStartDelimiter.
	self rawParameters: aCol asDictionary.
	self newLine.
	aBodyBlock value.
	self newLine.
	self raw: parserClass environmentClosingBlockMarkup! !

!MicMicrodownTextualBuilder methodsFor: 'element - environment' stamp: ''!
environment: aName arguments: aCol
	self raw: parserClass environmentOpeningBlockMarkup.
	self raw: aName.
	self raw: parserClass argumentListStartDelimiter.
	self rawParameters: aCol asDictionary.
	self newLine.
	self raw: parserClass environmentClosingBlockMarkup! !

!MicMicrodownTextualBuilder methodsFor: 'element - figure' stamp: ''!
figureURLString: aString withCaption: aDescriptionBlock
	"aString can be 'http://www.pharo.org or http://www.pharo.org?width=80&language=en'"
	
	self rawFigureDescription: aDescriptionBlock.
	self raw: parserClass urlOpenerMarkup.
	self raw: aString.
	self raw: parserClass urlCloserMarkup.! !

!MicMicrodownTextualBuilder methodsFor: 'element - metadata' stamp: ''!
metaDataFrom: aDictionary 

	self metaDataFromAssociations: aDictionary associations! !

!MicMicrodownTextualBuilder methodsFor: 'ugly line handling' stamp: ''!
root: aBlock
	
	aBlock value! !

!MicMicrodownTextualBuilder methodsFor: 'element - format' stamp: ''!
bold: aBlock
	self raw: parserClass boldMarkup.
	aBlock value.
	self raw: parserClass boldMarkup.! !

!MicMicrodownTextualBuilder methodsFor: 'element - code block' stamp: ''!
codeblockTag: aTag withBody: aString
	self flag: #fixme. 
	"missing first line stuff and we need a block for value of keys
	because we can write ```language=pharo&caption=The **bold** and `mono`
	...
	"

	self raw: parserClass codeblockMarkup.
	self raw: aTag.	
	self newLine.
	self raw: aString.
	self newLine.
	self raw: parserClass codeblockMarkup.! !

!MicMicrodownTextualBuilder methodsFor: 'element - math' stamp: ''!
mathblock: aString firstLineAssociations: aCol withCaption: aCaptionBlock

	self raw: parserClass mathOpeningBlockMarkup.
	aCol do: [ :each | self 
						raw: each key;
						raw: '='.
						each key = #caption
							ifTrue: [ aCaptionBlock value ]
							ifFalse: [ self raw: each value value  ]
						"so that we can put format such as bold in the value"]
			separatedBy: [ self raw: '&' ].
	self newLine.
	self raw: aString.
	self newLine.
	self raw: parserClass mathClosingBlockMarkup.
	self newLine.! !

!MicMicrodownTextualBuilder methodsFor: 'element - code block' stamp: ''!
codeblock: aString 
	self codeblock: aString firstLineAssociations: #() ! !

!MicMicrodownTextualBuilder methodsFor: 'writing during' stamp: ''!
writeIndentedCodeBlockDuring: aBlockClosure 
	"The logic of writeIndentedCodeBlockDuring: only works if the raw: method managing the prefixes
is invoked. Therefore somehow the blockclosure execution should invoke it.
It means that within the context of a visitor the visitText: method should do it."
	
	self
		writePrefix: parserClass preformattedMarkup
		forEachLineDuring: aBlockClosure.! !

!MicMicrodownTextualBuilder methodsFor: 'writing during' stamp: ''!
writePrefix: aString forEachLineDuring: aBlockClosure 
	"The logic of writePrefix:forEachLineDuring: only works if the raw: method managing the prefixes
is invoked. Therefore somehow the blockclosure execution should invoke it.
It means that within the context of a visitor the visitText: method should do it."
	self pushPrefix: aString.
	aBlockClosure ensure: [ self popPrefix ].! !

!MicMicrodownTextualBuilder methodsFor: 'element - paragraph' stamp: ''!
paragraph: aBlock

	self rawParagraph: aBlock.
	self newLine! !

!MicMicrodownTextualBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	prefixStack := OrderedCollection new.
	currentLevel := -1.
	! !

!MicMicrodownTextualBuilder methodsFor: 'element - list' stamp: ''!
unorderedListDuring: aBlockClosure
	"For list we do not emit empty line at the end because we do not want to force the creation of a paragraph 
	in the middle of nested list. And from a builder point of view this is difficult to know it."
	
	self potentialNewLine.
	currentLevel := currentLevel + 1.
	"self
		writePrefix: (self startOfUnorderedListForLevel: currentLevel)
		forEachLineDuring: aBlockClosure."
	aBlockClosure value.
	currentLevel := currentLevel - 1.! !

!MicMicrodownTextualBuilder methodsFor: 'element - quote block' stamp: ''!
quoteBlock: aText

	self writeText: aText beginsWith: parserClass preformattedMarkup! !

!MicMicrodownTextualBuilder methodsFor: 'element - references' stamp: ''!
externalLink: aURL withDescription: aDescriptionBlock

	self raw: parserClass linkNameOpenerMarkup .
	aDescriptionBlock value.
	self raw: parserClass linkNameCloserMarkup.
	self raw: parserClass urlOpenerMarkup.
	self raw: aURL asString.
	self raw: parserClass urlCloserMarkup.! !

!MicMicrodownTextualBuilder methodsFor: 'accessing' stamp: ''!
cell: aCellBlock
	self raw: '| '.
	aCellBlock value.
	self raw: ' '! !

!MicMicrodownTextualBuilder methodsFor: 'element - list' stamp: ''!
orderedListDuring: aBlockClosure
	"For list we do not emit empty line at the end because we do not want to force the creation of a paragraph 
	in the middle of nested list. And from a builder point of view this is difficult to know it."
	currentLevel := currentLevel + 1.
	aBlockClosure value.
	currentLevel := currentLevel - 1.
	"for now we do not care to generate 
	1. 
	2.
	
	but 
	1. 
	1.
	because this is the same"
		! !

!MicMicrodownTextualBuilder methodsFor: 'writing during' stamp: ''!
writeQuoteCodeBlockDuring: aBlockClosure 
	"The logic of writePrefix:forEachLineDuring: only works if the raw: method managing the prefixes
is invoked. Therefore somehow the blockclosure execution should invoke it.
It means that within the context of a visitor the visitText: method should do it."
	self
		writePrefix: parserClass preformattedMarkup, String space
		forEachLineDuring: aBlockClosure! !

!MicMicrodownTextualBuilder methodsFor: 'element - annotated' stamp: ''!
annotated: annotation paragraph:  aBlock
	"!!!!Important 
	
	attention there is not space between the !!!! and the label (annotation in pillar) or we should improve the microdown parser"
	self rawAnnotated: annotation paragraph: aBlock. 
	self newLine
! !

!MicMicrodownTextualBuilder methodsFor: 'ugly line handling' stamp: ''!
withLinesIn: aString do: aBlock separatedBy: anotherBlock
	"this method shows that the PRCommentedLine class is weak because it should encapsulate the way it internally represents lines. Now this is exposed in clients."
	| str |
	str := aString readStream.
	[ str atEnd ]
		whileFalse: [ 
			| line |
			line := str nextLine.
			aBlock value: line.
			str atEnd
				ifFalse: anotherBlock ]! !

!MicMicrodownTextualBuilder methodsFor: 'element - header' stamp: ''!
comment: aText
	self 
		withLinesIn: aText 
		do: [ :line | self writeText: line beginsWith: (parserClass commentedLineMarkup) ] 		separatedBy: [ self newLine ]
	! !

!MicMicrodownTextualBuilder methodsFor: 'accessing' stamp: ''!
headCell
	self raw: '| --- '.! !

!MicMicrodownTextualBuilder methodsFor: 'element - code block' stamp: ''!
codeblock: aString firstLineAssociations: aCol
	self raw: parserClass codeblockMarkup.
	aCol do: [ :each | self 
						raw: each key;
						raw: '=';
						raw: each value value asString
						"so that we can put format such as bold in the value"]
			separatedBy: [ self raw: '&' ].
	self newLine.
	self raw: aString.
	self newLine.
	self raw: parserClass codeblockMarkup.
	self newLine.! !

!MicMicrodownTextualBuilder methodsFor: 'element - list' stamp: ''!
item: aBlock

	self raw: (self startOfUnorderedListForLevel: currentLevel).
	aBlock value.
	self potentialNewLine.! !

!MicMicrodownTextualBuilder methodsFor: 'element - annotated' stamp: ''!
rawAnnotated: annotation paragraph:  aBlock
	"!!!!Important 
	
	attention there is not space between the !!!! and the label (annotation in pillar) or we should improve the microdown parser"
	self
		raw: parserClass annotatedParagraphMarkup;
		raw: annotation; 
		raw: String space;
		rawParagraph: aBlock
	
! !

!MicMicrodownTextualBuilder methodsFor: 'element - list' stamp: ''!
orderedItem: aBlock startingAt: aNumber

	self writeStartOfOrderedListIndex: aNumber.
	aBlock value.
	self newLine.! !

!MicMicrodownTextualBuilder methodsFor: 'private utils' stamp: ''!
popPrefix
	
	prefixStack removeLast! !

!MicMicrodownTextualBuilder methodsFor: 'ugly line handling' stamp: ''!
nextPutAllLines: aString
	self 
		withLinesIn: aString 
		do: [ :line | self nextPutAll: line ] 
		separatedBy: [ self newLine ]! !

!MicMicrodownTextualBuilder methodsFor: 'element - annotated' stamp: ''!
anchor: aLabel

	self raw: parserClass anchorMarkup.
	self raw: aLabel.
! !

!MicMicrodownTextualBuilder methodsFor: 'element - references' stamp: ''!
internalLink: aLabel
	self 
		writeText: aLabel 
		surroundBy: parserClass anchorReferenceOpenerMarkup 
		and: parserClass anchorReferenceCloserMarkup.
	! !

!MicMicrodownTextualBuilder methodsFor: 'element - figure' stamp: ''!
figureURLString: aString withCaption: aDescriptionBlock withParameters: anOrderedDictionary
	"If you specify association of arguments then asSting is not the url but the url without the query part, i.e., http://www.pharo.org/figures/light.png"
	
	anOrderedDictionary
		ifEmpty: [ 
			self figureURLString: aString withCaption: aDescriptionBlock ]
		ifNotEmpty: [ 
			self rawFigureDescription: aDescriptionBlock.
			self raw: parserClass urlOpenerMarkup.
			self raw: aString.
			self raw: parserClass argumentListOfFigureStartDelimiter.
			self rawParameters: anOrderedDictionary.
			self raw: parserClass urlCloserMarkup ]! !

!MicMicrodownTextualBuilder methodsFor: 'element - format' stamp: ''!
strike: aBlock
	self raw: parserClass strikeMarkup.
	aBlock value.
	self raw: parserClass strikeMarkup.! !

!MicMicrodownTextualBuilder methodsFor: 'element - annotated' stamp: ''!
annotatedAnnotation: annotation
	"I'm made to be followed by a paragraph. I manage the space between the annotation/label and the paragraph."
	
	"!!!!Important there is not space between the !!!! and the label (annotation in pillar) or we should improve the microdown parser"
	self
		raw: parserClass annotatedParagraphMarkup;
		raw: annotation;
		raw: String space
	
! !

!MicMicrodownTextualBuilder methodsFor: 'element - format' stamp: ''!
anchorReference: aText

	self raw: parserClass anchorReferenceOpenerMarkup.
	self raw: aText.
	self raw: parserClass anchorReferenceCloserMarkup.! !

!MicMicrodownTextualBuilder methodsFor: 'private utils' stamp: ''!
pushPrefix: aString 
	
	prefixStack addLast: aString! !

!MicMicrodownTextualBuilder methodsFor: 'element - math' stamp: ''!
mathblock: aString firstLineAssociations: aCol

	self raw: parserClass mathOpeningBlockMarkup.
	aCol do: [ :each | self 
						raw: each key;
						raw: '=';
						raw: each value value 
						"so that we can put format such as bold in the value"]
			separatedBy: [ self raw: '&' ].
	self newLine.
	self raw: aString.
	self newLine.
	self raw: parserClass mathClosingBlockMarkup.
	self newLine.! !

!MicMicrodownTextualBuilder methodsFor: 'ugly line handling' stamp: ''!
rawLines: aString
	"Output aString and take care of line ending within aString."
	self withLinesIn: aString do: [ :line | self raw: line ] separatedBy: [ self newLine ]! !

!MicMicrodownTextualBuilder methodsFor: 'element - figure' stamp: ''!
rawParameters: aZnDictionary
	"should be better to use do: separatedBy:"
	
	aZnDictionary keysAndValuesDo: [ :key :value | 
		self raw: key.
		self raw: parserClass argumentListEqualsDelimiter.
		self raw: value asString.
		key = aZnDictionary keys last ifFalse: [ 
			self raw: parserClass argumentListDelimiter ] ]! !

!MicMicrodownTextualBuilder methodsFor: 'writing low-level' stamp: ''!
rawParagraph: aBlock

	aBlock value
	

	
	! !

!MicMicrodownTextualBuilder methodsFor: 'element - list' stamp: ''!
orderedItem: aBlock

	self raw: (self startOfOrderedListForLevel: currentLevel).
	aBlock value.
	self potentialNewLine.
	! !

!MicMicrodownTextualBuilder methodsFor: 'element - annotated' stamp: ''!
annotation: aString arguments: aDictionary

	self raw: MicAnnotationOpenerDelimiter markup.
	self raw: aString.
	aDictionary ifNotEmpty: [ 
		self raw: ' | '.
		aDictionary keysAndValuesDo: [ :key :value | 
			self raw: key.
			self raw: '='.
			self raw: value.
			key = aDictionary keys last ifFalse: [ self raw: '&' ] ] ].
	self raw: MicAnnotationCloserDelimiter markup! !

!MicMicrodownTextualBuilder methodsFor: 'element - code block' stamp: ''!
codeblock: aString firstLineAssociations: aCol withCaption: aCaptionBlock
	self raw: parserClass codeblockMarkup.
	aCol do: [ :each | self 
						raw: each key;
						raw: '='.
						each key = #caption 
							ifTrue: [ aCaptionBlock value ]
						 	ifFalse: [ self raw: each value value  ]
						"so that we can put format such as bold in the value"]
			separatedBy: [ self raw: '&' ].
	self newLine.
	self raw: aString.
	self newLine.
	self raw: parserClass codeblockMarkup.
	self newLine.! !

!MicMicrodownTextualBuilder methodsFor: 'element - figure' stamp: ''!
figureURL: aUrl withCaption: aDescriptionBlock withParameters: anOrderedDictionary
	"If you specify association of arguments then asSting is not the url but the url without the query part, i.e., http://www.pharo.org/figures/light.png"
	
	anOrderedDictionary
		ifEmpty: [ 
			self figureURL: aUrl withCaption: aDescriptionBlock ]
		ifNotEmpty: [ 
			self rawFigureDescription: aDescriptionBlock.
			self raw: parserClass urlOpenerMarkup.
			aUrl scheme ifNotNil: [ :sch | self raw: sch asString, '://' ].
			aUrl authority ifNotNil: [ :auth | self raw: auth asString ].
			self raw: '/'.
			aUrl segments ifNotNil: [:segs | segs do: [:each | self raw: each asString]].
			self raw: parserClass argumentListOfFigureStartDelimiter.
			self rawParameters: anOrderedDictionary.
			self raw: parserClass urlCloserMarkup ]! !

!MicMicrodownTextualBuilder methodsFor: 'element - annotated' stamp: ''!
inputfile: aPathString

	self raw: MicAnnotationOpenerDelimiter markup.
	self raw: 'inputfile | path='.
	self raw: aPathString.
	self raw: MicAnnotationCloserDelimiter markup! !

!MicMicrodownTextualBuilder methodsFor: 'element - figure' stamp: ''!
rawFigureDescription: aBlock

	self raw: parserClass figureOpenerMarkup.
	aBlock value.
	self raw: parserClass linkNameCloserMarkup.! !

!MicMicrodownTextualBuilder methodsFor: 'element - list' stamp: ''!
startOfUnorderedListForLevel: aNumber

	^ ('  ' repeat: aNumber) , parserClass unorderedListMarkup! !

!MicMicrodownTextualBuilder methodsFor: 'element - metadata' stamp: ''!
metaDataFromAssociations: aCollection 
	self raw: '{'; newLine.
	aCollection do: [ :each | 
		self raw: '"';
		raw: each key; 
		raw: '" : "';
		raw: each value;
		raw: '"'
		]
		separatedBy: [ self raw: ' , '].
	self newLine; raw: '}'.! !

!MicMicrodownTextualBuilder methodsFor: 'element - format' stamp: ''!
rawFormat: aText

	self raw: MicRawOpenerDelimiter markup.
	self raw: aText.
	self raw: MicRawCloserDelimiter markup.! !

!MicMicrodownTextualBuilder methodsFor: 'element - header' stamp: ''!
horizontalLine
	self raw: parserClass horizontalLineMarkup.
   self newLine
! !

!MicMicrodownTextualBuilder methodsFor: 'element - list' stamp: ''!
startOfOrderedListForLevel: aNumber

	^ ('  ' repeat: aNumber) ,'1', parserClass orderedListSemiMarkup! !

!MicMicrodownTextualBuilder methodsFor: 'writing low-level' stamp: ''!
raw: aString
	"We have in the prefix potentially many nesting level '> ', '```' and for each new line 
	we want to make sure that prefixes are written prior to aString.
	
	Now lastIsNewLine indicates that we should only do that for new line since 
	raw can be invoked for multiple reasons. Now the logic of writeIndentedCodeBlockDuring: only works if 
	this raw is invoked. 
	"

	lastIsNewLine ifTrue: [ 
		prefixStack do: [ :each |
			super raw: each ].
	].
	super raw: aString.
	lastIsNewLine := false! !

!MicMicrodownTextualBuilderTest commentStamp: ''!
A MicMicrodownTextualBuilderTest is a test class for testing the behavior of MicMicrodownTextualBuilder!
!MicMicrodownTextualBuilderTest methodsFor: 'tests - format' stamp: ''!
testStrike

	self assert: (builder strike: [ builder text: 'Strike']) contents equals: '~Strike~'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testAnnotationNoArgs

	self 
		assert: (builder annotation: 'anAnnotationName' arguments: {} ) contents 
		equals: MicAnnotationOpenerDelimiter markup,'anAnnotationName',MicAnnotationCloserDelimiter markup! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testAnchorReference

	self assert: (builder anchorReference: 'AnchorReference') contents equals: parser class anchorReferenceOpenerMarkup, 'AnchorReference', parser class anchorReferenceCloserMarkup! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - references' stamp: ''!
testExternalLink

	self 
		assert: (builder externalLink: 'anUrl' withDescription: [ builder text: 'aDescription'] ) contents 
		equals: '[aDescription](anUrl)'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - references' stamp: ''!
testExternalLinkWithStrike

	self 
		assert: (builder externalLink: 'anUrl' withDescription:[ builder strike: [ builder text: 'aDescription']] ) 
		contents equals: '[~aDescription~](anUrl)'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - references' stamp: ''!
testExternalLinkWithMonospace

	self 
		assert: (builder externalLink: 'anUrl' withDescription: [ builder monospace: 'aDescription'] ) contents 
		equals: '[`aDescription`](anUrl)'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - figure' stamp: ''!
testFigureWithBold

	self 
		assert: (builder 
						figureURLString: 'http://www.pharo.org/light.jpeg' 
						withCaption: [ builder text: 'it is a';  bold: [ builder text:'beautifull']; text: 'figure' ];				
							contents) contents 
		equals: '!![it is a**beautifull**figure](http://www.pharo.org/light.jpeg)'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests' stamp: ''!
testHeadCell
	self assert: builder headCell contents equals: '| --- '! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testMetaData

	self 
		assert: (builder metaDataFromAssociations: {'label'->'aLabel' . 'size'->'142'}) contents 
		equals: parser metaDataOpeningBlockMarkup , String cr ,'"label" : "aLabel" , "size" : "142"', String cr , parser metaDataClosingBlockMarkup! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - figure' stamp: ''!
testFigureInPresenceOfParagraph
	| dictionnary |
	dictionnary := {'label'->'aLabel' . 'size'->'80'} asOrderedDictionary.
	self 
		assert: (builder 
							root: [ builder paragraph: [ builder text: 'This is some text forming a paragraph and then there is figure.' ].
									builder 
										figureURLString: 'http://www.pharo.org/files/ouf.png' 
										withCaption: [ builder text: 'it is a beautifull figure'] 
										withParameters:  dictionnary ] ;				
							contents) contents 
		equals: 'This is some text forming a paragraph and then there is figure.
!![it is a beautifull figure](http://www.pharo.org/files/ouf.png?label=aLabel&size=80)'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - codeblock' stamp: ''!
exampleTextMultipleLines
	^ 'Hello
Pharo'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - references' stamp: ''!
testExternalLinkWithNested

	self 
		assert: (builder externalLink: 'anUrl' withDescription:[ builder bold: [ builder italic: [ builder text: 'aDescription']]] ) contents 
		equals: '[**_aDescription_**](anUrl)'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testOrderedList

	self 
		assert: (builder orderedListDuring: [  {'item1' . 'item2' . 'item3' } 
							do: [ :each | builder 
												orderedItem: [ builder text: each] ] ]) contents
		equals: '1. item1
1. item2
1. item3
'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - format' stamp: ''!
testItalic

	self assert: (builder italic: [ builder text: 'Italic' ]) contents equals: '_Italic_'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - figure' stamp: ''!
testFigureWithParameters
	| dictionnary |
	dictionnary := {'label'->'aLabel' . 'size'->'80'} asOrderedDictionary.
	self 
		assert: (builder 
							figureURLString: 'http://www.pharo.org/flo.png' 
							withCaption: [builder text: 'it is a beautifull figure'] 
							withParameters:  dictionnary;				
							contents) contents 
		equals: '!![it is a beautifull figure](http://www.pharo.org/flo.png?label=aLabel&size=80)'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testQuote

	self assert: (builder quoteBlock: 'aQuote') contents equals: parser class preformattedMarkup, ' aQuote'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testRawFormat

	self assert: (builder rawFormat: 'aRawFormat') contents equals: MicRawOpenerDelimiter markup, 'aRawFormat', MicRawCloserDelimiter markup! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testEnvironment

	self 
		assert: (builder environment: 'anEnvironmentName' arguments: {'label'->'aLabel' . 'value' -> '42'}) contents 
		equals: '<?anEnvironmentName|label=aLabel&value=42
?>'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testParagraph

	self assert: (builder paragraph: [ builder text: 'aParagraph' ]) contents equals: 'aParagraph', String cr! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests' stamp: ''!
testRawParametersWithNotStringAtValue
	
	builder rawParameters: { 'label'->42 . 'size'->MicTextBlock } asDictionary.
	self assert: builder contents equals: 'label=42&size=MicTextBlock'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testAnchor

	self assert: (builder anchor: 'Anchor') contents equals: parser anchorMarkup, 'Anchor'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - codeblock' stamp: ''!
testCodeBlock

	"```language2=Pharo&caption=`Color` is cool
	Hello
	Pharo
	```"

	| mictext |
	mictext := builder
		           codeblock: self exampleTextMultipleLines
		           firstLineAssociations: { 
				           ('language2' -> 'Pharo') };
		           contents.
	self 
		assert: mictext 
		equals: 
'```language2=Pharo
', self exampleTextMultipleLines, 

'
```
'
! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testHorizontalLine

	self assert: (builder horizontalLine) contents equals: parser horizontalLineMarkup, String cr! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - references' stamp: ''!
testExternalLinkWithBold

	self 
		assert: (builder externalLink: 'anUrl' withDescription:[ builder bold: [ builder text: 'aDescription']] ) contents 
		equals: '[**aDescription**](anUrl)'! !

!MicMicrodownTextualBuilderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	factory := MicMicrodownSnippetFactory new.
	parser := MicroDownParser new.
	builder := parser builder! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - references' stamp: ''!
testExternalLinkWithItalic

	self 
		assert: (builder externalLink: 'anUrl' withDescription:[ builder italic: [ builder text: 'aDescription']] ) contents 
		equals: '[_aDescription_](anUrl)'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testEnvironmentWithBody

	self 
		assert: (builder environment: 'anEnvironmentName' 
					body: [ builder text: 'aText'] 
					arguments: {'label'->'aLabel' . 'value' -> '42'}) contents 
		equals: '<?anEnvironmentName|label=aLabel&value=42
aText
?>'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - codeblock' stamp: ''!
testMathBlockCaptionContainsMonospace

	"```language2=Pharo&caption=`Color` is cool
	Hello
	Pharo
	```"

	| mictext |
	mictext := builder
		           mathblock: self exampleMathTextMultipleLines
		           firstLineAssociations: { 
				           ('label' -> 'Math').
				           ('caption' -> '`Math` is cool') }
					  withCaption: [ builder text: '`Math` is cool'];
		           contents.
	self 
		assert: mictext 
		equals: 
'&label=Math&caption=`Math` is cool
', self exampleMathTextMultipleLines, 

'
&
'
! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testMathInline

	self assert: (builder mathInline: 'x = 2 + y') contents equals: '$x = 2 + y$'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testUnorderedList

	self 
		assert: (builder unorderedListDuring: [  {'item1' . 'item2' . 'item3' } do: [ :each | builder item: [ builder text: each] ] ]) contents
		equals: '- item1
- item2
- item3
'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests' stamp: ''!
testCell

	self
		assert: (builder
		cell: [ 
			builder text: 'this is '.
			builder bold: [ builder text: 'bold' ] ]) contents
		equals: '| this is **bold** '! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - format' stamp: ''!
testMonospace

	self assert: (builder monospace: 'Monospace') contents equals: '`Monospace`'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - format' stamp: ''!
testStrikeInHeader
	
	self assert: (builder 
							header: [ builder 
											text: 'Hello ';
											strike: [ builder text: 'Pharo' ]; 
											text: ' is cool']  withLevel: 1;				
							contents)
			equals: '# Hello ~Pharo~ is cool
'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testInputfile

	self 
		assert: (builder inputfile: 'Chapters/image.png') contents 
		equals: MicAnnotationOpenerDelimiter markup,
					'inputfile | path=Chapters/image.png', MicAnnotationCloserDelimiter markup! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testAnnotation

	self 
		assert: (builder annotation: 'anAnnotationName' arguments: {'label'->'aLabel' . 'value' -> '42'} asDictionary) contents 
		equals: MicAnnotationOpenerDelimiter markup,'anAnnotationName | label=aLabel&value=42',MicAnnotationCloserDelimiter markup! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - format' stamp: ''!
testBold

	self assert: (builder bold: [builder text: 'Bold']) contents equals: '**Bold**'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - codeblock' stamp: ''!
exampleMathTextMultipleLines
	^ 'y = 3
x = 2 + y'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - codeblock' stamp: ''!
testCodeBlockCaptionContainsMonospace

	"```language2=Pharo&caption=`Color` is cool
	Hello
	Pharo
	```"

	| mictext |
	mictext := builder
		           codeblock: self exampleTextMultipleLines
		           firstLineAssociations: { 
				           ('language2' -> 'Pharo').
				           ('caption' -> '`Color` is cool') }
					  withCaption: [ builder text: '`Color` is cool' ];
		           contents.
	self 
		assert: mictext 
		equals: 
'```language2=Pharo&caption=`Color` is cool
', self exampleTextMultipleLines, 

'
```
'
! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - header' stamp: ''!
testHeaderWithItalic

	self 
		assert: (builder 
							header: [ builder text: 'Hello ';
											 italic: [ builder text: 'Pharo' ];
											 text: ' is cool']  withLevel: 1;				
							contents) contents 
		equals: parser headerMarkup , ' Hello _Pharo_ is cool
'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testComment

	self assert: (builder comment: 'Comment') contents equals: parser commentedLineMarkup, ' Comment'! !

!MicMicrodownTextualBuilderTest methodsFor: 'tests - anchor' stamp: ''!
testAnnotated

	self assert: (builder annotated: 'anAnnotation' paragraph:  [ builder text: 'anAnnotatedParagraph' ]) contents equals: '!!!!anAnnotation anAnnotatedParagraph', String cr! !

!MicMinimalConfiguration methodsFor: 'accessing' stamp: ''!
newLine
	^ newLine! !

!MicMinimalConfiguration methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	newLine := String cr.
	headingLevelOffset := 0! !

!MicMinimalConfiguration methodsFor: 'accessing' stamp: ''!
headingLevelOffset
	"To be moved in a subclass when we will deal with the pillar integration.
	Check the senders: it should be a visitor that should be packaged out of Microdown and placed in Pillar-Microdown"
	
	^ headingLevelOffset! !

!MicMinimalConfiguration methodsFor: 'accessing' stamp: ''!
newLine: aString
	newLine := aString! !

!MicMinimalConfiguration methodsFor: 'accessing' stamp: ''!
headingLevelOffset: anObject
	"To be moved in a subclass when we will deal with the pillar integration."
	
	headingLevelOffset := anObject! !

!MicMonospaceDelimiter commentStamp: ''!
I am the delimiter for monospace/inline code format.!
!MicMonospaceDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicMonospaceFormatBlock ! !

!MicMonospaceDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicMonospaceDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '`'! !

!MicMonospaceDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ true! !

!MicMonospaceDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #monospace! !

!MicMonospaceFormatBlock commentStamp: ''!
I represent a monospaced text section. I'm delimited using `\`` as in `\`monospace\`` to obtain `monospace`.!
!MicMonospaceFormatBlock methodsFor: 'accessing' stamp: ''!
kind
	^ #monospace! !

!MicMonospaceFormatBlock methodsFor: 'internal' stamp: ''!
openingDelimiter

 	^ MicMonospaceDelimiter markup! !

!MicMonospaceFormatBlock methodsFor: 'internal' stamp: ''!
closingDelimiter

 	^ MicMonospaceDelimiter markup! !

!MicMonospaceFormatBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitMonospace: self! !

!MicMonospaceFormatBlock class methodsFor: 'testing' stamp: ''!
isEvaluated
	^ false! !

!MicMonospaceFormatBlock class methodsFor: 'testing' stamp: ''!
cleanSubstring
	"does nothing on purpose"! !

!MicOrderedListBlock commentStamp: ''!
I represent an ordered list of list items.

#### Example

Typing 
```
1. first
2. second
   on multiple line 
1. third
Not in third
1. first item of a new list
```

produces
1. first
1. second
   on multiple line 
1. third
Not in third
1. first item of a new list

Notice how the following line of the second item is indented with the previous one.
!
!MicOrderedListBlock methodsFor: 'accessing' stamp: ''!
startIndexFrom: line
	startIndex ifNotNil: [ ^self ].
	startIndex := line asInteger! !

!MicOrderedListBlock methodsFor: 'testing' stamp: ''!
addLineAndReturnNextNode: line
	"Create a new item, and insert it into me."
	"line is on the format '1. item text'"

	line ifEmpty: [ ^ self ].
	self startIndexFrom: line.
	"the startindex is for the list and not for the item. 
	So it is stored once during the creation of the list and just before 
	the creation of the first item."
	^ super addLineAndReturnNextNode: line! !

!MicOrderedListBlock methodsFor: 'testing' stamp: ''!
canConsumeLine: line
	"to consume this line there must be a UnorderdListItem start at the right indentation"
	
	line ifEmpty: [ ^ true ].
	^ (super canConsumeLine: line) and: [line trim  prefixMatchesRegex: '\d+(\.|\))']! !

!MicOrderedListBlock methodsFor: 'accessing' stamp: ''!
startIndex
	^ startIndex! !

!MicOrderedListBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitOrderedList: self! !

!MicOrderedListBlockTest commentStamp: ''!
I'm a test class for testing the behavior of ordered list blocks!
!MicOrderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelListWithNormalNumberingWithEmptyLines
	| root list |
	root :=  parser
		parse:
'1. first item



2. second item'.
	self assert: root children size equals: 1.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list class equals: self orderedListBlockClass.
	self assert: list startIndex equals: 1. 
	self assert: list children second text equals: 'second item'.
	! !

!MicOrderedListBlockTest methodsFor: 'tests' stamp: ''!
testSpawingNewParagraph
	| root |
	root :=  parser
		parse:
'1. first item
   with a follow up
a new paragraph. 
2. second list first item
   follow up of second item'.
	self assert: root children size equals: 3. 
	self assert: root children first children first text equals: 'first item
with a follow up'.
	self assert: root children third startIndex equals: 2.
	self assert: root children third children first text equals: 'second list first item
follow up of second item'.
	! !

!MicOrderedListBlockTest methodsFor: 'tests' stamp: ''!
testEmbeddedUnordered
	| source root list |
	source := 
'1. item 1
   - sublevel item 1
   - sublevel item 2
1. item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children second text equals: 'item 2'.
	self assert: list children first "item 1"
			children first "unordered list"
			children second "sub item"
			text equals: 'sublevel item 2'! !

!MicOrderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelListWithStrangelyNumberedItems
	| root list |
	root := parser
		parse:
			'11. item 1
2. item 2'.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list class equals: self orderedListBlockClass.
	self assert: list startIndex equals: 11. 
	self assert: list children second text equals: 'item 2'! !

!MicOrderedListBlockTest methodsFor: 'tests' stamp: ''!
testNotSpawingNewParagraph
	| root list |
	root :=  parser
		parse:
'1. first item
   with a follow up 
   and another one. 
2. second item
   follow up of second item'.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list class equals: self orderedListBlockClass.
	self assert: list startIndex equals: 1. 
	self assert: list children second text equals: 'second item
follow up of second item'.
	! !

!MicOrderedListBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicOrderedListBlock ! !

!MicOrderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelList2WithNoIndent
	"when we want a paragraph to be part of an item it should be indented "

	| source root list |
	source := 
'19. item 1
expanded as new paragraph
7.  item 2
    part of item2'.
	root := parser parse: source.
	self assert: root children size equals: 3.
	"two lists + one paragraph"	
	list := root children first.
	self assert: list children size equals: 1.
	self assert: list children first text equals: 'item 1'.
	self assert: list  startIndex equals: 19.
	
	self assert: root children last children first text equals: 'item 2
part of item2'! !

!MicOrderedListBlockTest methodsFor: 'tests' stamp: ''!
testTwoLevelList1
	| source root list |
	source := 
'1. item 1
   6) sublevel
1. item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children second text equals: 'item 2'.
	self assert: list children first "item 1"
			children first "ordered list"
			children first "sub item"
			text equals: 'sublevel'! !

!MicOrderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelList2
	| source root list |
	source := 
'19. item 1
    expanded
7.  item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children first text equals: 'item 1
expanded'.
	self assert: list  startIndex equals: 19! !

!MicOrderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelListWithNormalNumbering
	| root list |
	root :=  parser
		parse:
'1. first item
2. second item'.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list class equals: self orderedListBlockClass.
	self assert: list startIndex equals: 1. 
	self assert: list children second text equals: 'second item'.
	! !

!MicOrderedListBlockTest methodsFor: 'tests - nested' stamp: ''!
testNestedLevel2
	| source root list |
	source := 
'1. item 1
   6) sublevel
      1. subsublevel
   7) sublevel2
1. item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	
	self assert: list children first text equals: 'item 1'.
	self assert: list children first nestedLevel equals: 1.
	
	"this is the inner list"
	self assert: list children first children first nestedLevel equals: 2.
	
	"this is the inner list first item"
	self assert: list children first children first children first text equals: 'sublevel'.
	self assert: list children first children first children first nestedLevel equals: 2.
	self assert: list children first children first children second text equals: 'sublevel2'.
	
	self assert: list children first children first children first children first nestedLevel equals: 3.
	self assert: list children first children first children first children first children first nestedLevel equals: 3.
! !

!MicOrderedListBlockTest methodsFor: 'tests - nested' stamp: ''!
testNestedLevel
	| source root list |
	source := 
'1. item 1
   6) sublevel
1. item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	
	self assert: list children first text equals: 'item 1'.
	self assert: list children first nestedLevel equals: 1.
	
	"this is the inner list"
	self assert: list children first children first nestedLevel equals: 2.
	
	"this is the inner list first item"
	self assert: list children first children first children first text equals: 'sublevel'.
	self assert: list children first children first children first nestedLevel equals: 2.
	
! !

!MicOutputStream commentStamp: ''!
I'm a little wrapper on stream to provide a nicer API. In particular I help not hardcoding line ending everywhere.!
!MicOutputStream methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ stream isEmpty! !

!MicOutputStream methodsFor: 'streaming' stamp: ''!
newLine
	self << self configuration newLine! !

!MicOutputStream methodsFor: 'streaming' stamp: ''!
trimLastNewLine
	| newLine |
	newLine := self configuration newLine.
	(newLine isEmpty or: [ stream position < newLine size ])
		ifTrue: [ ^ self ].
	stream position: stream position - newLine size.! !

!MicOutputStream methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	configuration := MicMinimalConfiguration new.! !

!MicOutputStream methodsFor: 'accessing' stamp: ''!
configuration 
	^ configuration! !

!MicOutputStream methodsFor: 'streaming' stamp: ''!
space
	stream space! !

!MicOutputStream methodsFor: 'streaming' stamp: ''!
tab
	stream tab! !

!MicOutputStream methodsFor: 'streaming' stamp: ''!
<< anObject
	anObject isBlock
		ifTrue: anObject
		ifFalse: [ stream << anObject ]! !

!MicOutputStream methodsFor: 'accessing' stamp: ''!
nextPut: aCharacter 
	stream nextPut: aCharacter! !

!MicOutputStream methodsFor: 'initialization' stamp: ''!
setStream: aWriteStream
	stream := aWriteStream! !

!MicOutputStream methodsFor: 'accessing' stamp: ''!
configuration: aConfiguration
	configuration := aConfiguration ! !

!MicOutputStream methodsFor: 'private' stamp: ''!
stream

	^ stream! !

!MicOutputStream methodsFor: 'streaming' stamp: ''!
contents
	^ stream contents! !

!MicOutputStream methodsFor: 'accessing' stamp: ''!
flush
	stream flush! !

!MicOutputStream class methodsFor: 'instance creation' stamp: ''!
on: aStream

	^ self new setStream: aStream; yourself! !

!MicParagraphBlock commentStamp: ''!
I am a plain text paragraph.

If am divided from other paragraphs by either a blank line, or one of the other markups.!
!MicParagraphBlock methodsFor: 'private' stamp: ''!
asUnindented: line
	"return a line where the indentation to my indentation level has been removed"

	^ line copyFrom: self indent + 1 to: line size! !

!MicParagraphBlock methodsFor: 'parse support' stamp: ''!
closeMe

	super closeMe.
	self children: (self inlineParse: text)! !

!MicParagraphBlock methodsFor: 'private' stamp: ''!
isRightlyIndented: line
	"test if line has the appropriate number of spaces at first"

	self indent = 0
		ifTrue: [ ^ true ].
	^ line beginsWith: (' ' repeat: self indent)! !

!MicParagraphBlock methodsFor: 'parsing' stamp: ''!
addLineAndReturnNextNode: line
	"add line to this node. 
	Notice, the action is allowed to create new nodes in the block tree.
	Returns the node to handle next line - typically self."

	text := text
		ifNil: [ line trim ]
		ifNotNil: [ text , String cr , line trim ].
	^ self! !

!MicParagraphBlock methodsFor: 'parsing' stamp: ''!
canConsumeLine: line
	"A paragraph is closed by an empty line, "

	| unIndented |
	"if we are closing block that can contain other elements then do not consume their ends."
	(line isEmpty or: [ #('?>') includes: line]) 
		ifTrue: [ ^ false ].
	(self isRightlyIndented: line)
		ifFalse: [ ^ false ].
	unIndented := self asUnindented: line.
	"if the line was the start of a new block then paragraph does not consume it"
	^ (self blockStarterClassFrom: unIndented) = self class! !

!MicParagraphBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitParagraph: self! !

!MicParagraphBlock methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!MicParagraphBlock class methodsFor: 'instance creation' stamp: ''!
opensBy: aLine
	^ aLine notEmpty ! !

!MicParagraphBlockTest commentStamp: ''!
I'm is a test class for testing the behavior of paragraph block.!
!MicParagraphBlockTest methodsFor: 'tests' stamp: ''!
testHandlingSequenceOfBasicLinesProducesAParagraph

	| root paragraph |
	root := parser parse: ''.
	paragraph := parser handleLine: 'This is'.
	paragraph := parser handleLine: 'Another line'.
	paragraph := parser handleLine: '  And that other line'.
	self assert: paragraph text equals: 'This is
Another line
And that other line'.
	self assert: root children size equals: 1! !

!MicParagraphBlockTest methodsFor: 'tests' stamp: ''!
testSingleParagraph
	| root |
	root := parser parse: 'This is
a paragraph on two lines'.
	self 
		assert: root children first class equals: MicParagraphBlock.
	self assert: root children first children first text equals: 'This is
a paragraph on two lines'.

! !

!MicParagraphBlockTest methodsFor: 'tests' stamp: ''!
testTwoSingleParagraphs
	| root |
	root := parser parse: 'This is

a paragraph on two lines'.
	self assert: root children first text equals: 'This is'.
	self assert: root children second text equals: 'a paragraph on two lines'.
	! !

!MicParagraphBlockTest methodsFor: 'tests' stamp: ''!
testBoldMultipleLinesWithNewLine

	| root |
	root := parser parse: '**Hello is ... cut for real
another line** and more 

a paragraph on two lines**'.

	self
		assert: root children first text
		equals: '**Hello is ... cut for real
another line** and more'.
	self
		assert: root children second text
		equals: 'a paragraph on two lines**'.

	self
		assert:
		(MicInlineParser new parse: root children first text) first kind
		equals: #bold.
	self
		assert:
		(MicInlineParser new parse: root children second text) first kind
		equals: #basic! !

!MicParagraphBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicParagraphBlock ! !

!MicParagraphBlockTest methodsFor: 'tests' stamp: ''!
testCanConsumeLineOtherBlocks

	| root paragraph |
	root := parser parse: ''.
	paragraph := parser handleLine: 'This is'.
	self assert: paragraph equals: parser current.	
	self assert: paragraph text equals: 'This is'.
	
	self deny: (paragraph canConsumeLine: '* Another line').
	self deny: (paragraph canConsumeLine: '```Another line').
	self deny: (paragraph canConsumeLine: '> Another line').
	self deny: (paragraph canConsumeLine: '').
	self deny: (paragraph canConsumeLine: '# Section1').
	self deny: (paragraph canConsumeLine: '- ').
	self deny: (paragraph canConsumeLine: '1.  ').! !

!MicParagraphBlockTest methodsFor: 'tests' stamp: ''!
testCanConsumeLine
	"A list item does not force the creation of a new paragraph when the line is correctly indented.
	currently the implementation does not create a paragraph as a child of list item."
	
	| listitem |
	parser parse: ''. 
	listitem := parser handleLine: '- This is'.
	
	self assert: (listitem canConsumeLine: '  a paragraph in a list item').
	self deny: (listitem canConsumeLine: 'a paragraph in a list item').
	
	parser handleLine: '  a paragraph in a list item'.
	self assert: parser current equals: listitem.
	"pay attention here at this point the closeMe hook as not being executed yet.
	So text is a string and not an array of textElements."  
	self assert: (listitem instVarNamed: 'text') equals: 'This is
a paragraph in a list item'.
	
! !

!MicParagraphBlockTest methodsFor: 'tests' stamp: ''!
testSingleParagraphWithIndentedText
	| source root expected |
	source := 'This is
   a paragraph with spaces
	and one with tabs'.
	expected := 'This is
a paragraph with spaces
and one with tabs'.
	root := parser parse: source.
	self assert: root children first text equals: expected! !

!MicParagraphBlockTest methodsFor: 'tests' stamp: ''!
testANewLineCreatesANewParagraph
	"**Hello 
	
	Pharo**"

	| root |
	root := parser parse: '**Hello is ... cut for real

a paragraph on two lines**'.

	self assert: root children first text equals: '**Hello is ... cut for real'.
	self assert: root children second text equals: 'a paragraph on two lines**'.
	! !

!MicParagraphBlockTest methodsFor: 'tests' stamp: ''!
testCanConsumeLineBasic

	| root paragraph |
	root := parser parse: ''.
	self assert: root equals: parser current.
	
	root canConsumeLine: 'This is'.
	paragraph := parser handleLine: 'This is'.
	self assert: paragraph equals: parser current.
	
	self assert: paragraph text equals: 'This is'.
	self assert: (paragraph canConsumeLine: 'Another line').
	paragraph := parser handleLine: 'Another line'.
	self assert: paragraph text equals: 'This is
Another line'.! !

!MicParserTest methodsFor: 'tests' stamp: ''!
testIsAListStar

	self assert: (parser isAList: '* one')
	! !

!MicParserTest methodsFor: 'tests' stamp: ''!
testIsAListStar2

	self assert: (parser isAList: '  * one' trim)
	! !

!MicParserTest methodsFor: 'tests' stamp: ''!
testEmptyOnMultipleLines
	| source root |
	source := '


'.
	root := parser parse: source.
	self assert: root children size equals: 0
! !

!MicParserTest methodsFor: 'tests' stamp: ''!
testEmpty
	| source root |
	source := ''.
	root := parser parse: source.
	self assert: root children size equals: 0.
! !

!MicParserTest methodsFor: 'tests' stamp: ''!
testIsAListDash

	self assert: (parser isAList: '- one')
	! !

!MicParserTest methodsFor: 'tests' stamp: ''!
testIsAListPlus

	self assert: (parser isAList: '+ one')
	! !

!MicParserTest methodsFor: 'tests' stamp: ''!
testParsingLogic
	| source root textBody argument line code |
	
	"ready for code factory"
	textBody := 'my fancy code
is really cool'.
	argument := 'ArgumentGoesHere'.
	source := (parser codeblockMarkup, argument, String cr, textBody, String cr, parser codeblockMarkup) readStream. 
	
	line := source nextLine.
	"First we get the root block"
	root := parser parse: ''.
	self assert: parser current equals: root.
	self assert: (root canConsumeLine: line).
	code := parser handleLine: line.
	self assert: code parent equals: root.
	self assert: code equals: parser current. 
	
	"now new line"
	parser handleLine: source nextLine.
	self deny:  code isClosed.
	parser handleLine: source nextLine.
	self deny:  code isClosed.
	self assert: code equals: parser current.
	parser handleLine: source nextLine.
	self assert: code isClosed. 
	parser handleLine: 'another line'.
	self deny: code equals: parser current. 
	
	
	
	! !

!MicParserTest methodsFor: 'tests' stamp: ''!
testOnceParsedCurrentShouldBeTheRootblock

	| source root |
	source := 'This is
a paragraph on two lines'.
	root := parser parse: source.
	self assert: parser current == root! !

!MicParserTest methodsFor: 'tests' stamp: ''!
testIsAListNumbered

	self assert: (parser isAList: '11. one')
	! !

!MicParsingError methodsFor: 'accessing' stamp: ''!
line
	^ line! !

!MicParsingError methodsFor: 'accessing' stamp: ''!
line: anObject
	line := anObject! !

!MicPathResolver commentStamp: ''!
`MicPathResolver` resolves paths and urls of the document into absolute references based on the kind of resolutionSource and the kind of paths.

Imagine we have the following file that we want to resolve on a local disk

```
	'SUnit' / 'SUnit.mic'.
	with contents:  '!![aFile](figures/setUp.png)'
```

We should get a figure whose reference is `FileSystem workingDirectory / 'SUnit' / 'figures' / 'setUp.png'`.

Here are the possible combinations

- aPath (e.g., figures/tmp.png) => full path := parent path + path
- aUrl  (`http://files.pharo.org/logos/p.png`) => full path := http://files.pharo.org/logos/p.png

then the root resolution impacts the full path:

- if this is an url e.g., `http://pharo.org/resources` we should get
  - 		`SUnit/figures/setUp.png` => `http://pharo.org/resources/SUnit/figures/setUp.png`
  -      `http://files.pharo.org/logos/p.png` => `http://files.pharo.org/logos/p.png`
- else a file system e.g., `~ducasse/pillar/books/`
  - `SUnit/figures/setUp.png` =>`~ducasse/pillar/books/SUnit/figures/setUp.png`
  - `http://files.pharo.org/logos/p.png` => `http://files.pharo.org/logos/p.png`!
!MicPathResolver methodsFor: 'initialization' stamp: ''!
microdown: aMicrodown

	microdown := aMicrodown! !

!MicPathResolver methodsFor: 'visiting' stamp: ''!
visitInputfile: anInputFile
	
	anInputFile path: (anInputFile path resolvedBy: (Path * originFile parent pathString) withResolver: self)! !

!MicPathResolver methodsFor: 'initialization' stamp: ''!
initialize 
	
	super initialize. 
	self resolutionSource: FileSystem workingDirectory! !

!MicPathResolver methodsFor: 'visiting' stamp: ''!
resolutionSource: aRoot
	"To set as root for resolution, an absolute URL or file reference."
	
	root := aRoot ! !

!MicPathResolver methodsFor: 'visiting' stamp: ''!
visitFigure: aFigure
	originFile 
		ifNotNil: [ 
					aFigure resources: 
						(aFigure resources 
							resolvedBy: (Path * originFile parent pathString) 
							withResolver: self)]
		ifNil: [ aFigure resources: 
						(aFigure resources resolvedWithResolver: self)].
	^ aFigure! !

!MicPathResolver methodsFor: 'visiting' stamp: ''!
resolutionSource
	"Return an URL or a file reference."
	
	^ root ! !

!MicPathResolver methodsFor: 'initialization' stamp: ''!
originFile: aFile
	"Origin file represents the file that is containing the figure or the input file we are resolving."
	
	originFile := aFile! !

!MicPathResolverTest methodsFor: 'dummy tests' stamp: ''!
testNotCallingResolver
	"Using the parser only should not resolve the path, here we only call parse."
	
	| mic |
	mic := parser parse: '!![caption](figures/blop/toto.png)'.
	self assert: (mic children first children first resources fullName endsWith: 'figures/blop/toto.png'). 
	
	mic := microdown parse: '!![caption](/figures/blop/toto.png)'.
	self assert: mic children first children first class equals: MicFigureBlock.
	self assert: (mic children first children first resources fullName endsWith: '/figures/blop/toto.png').

	! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveAbsoluteFileWithURL

	| file mic |
	system := FileSystem memory workingDirectory.
	(system / 'folder') createDirectory.
	file := system / 'folder/file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '# section
!![caption](/documentation/image.png)' ].

	mic := microdown 
		resolverRoot: 'http://www.pharo.org' asUrl;
		resolvedTreeFromFile: file.

	self 
		assert: mic children second children first resources url printString 
		equals: 'http://www.pharo.org/documentation/image.png'.
	
	self 
		assert: mic children second children first resources url printString 
		equals: 'http://www.pharo.org/documentation/image.png'
	! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveRelativeFileWithFileSystem
	| file mic |
	system := FileSystem memory workingDirectory.
	(system / 'folder') createDirectory.
	file := system / 'folder/file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '# section
!![caption](documentation/image.png)' ].

	mic := microdown 
		resolverRoot: system;
		resolvedTreeFromFile: file.

	self 
		assert: mic children second children first resources fullName 
		equals: '/folder/documentation/image.png'.
	
	self 
		assert: mic children second children first resources url  class 
		equals: FileReference.
		
	"Now we try with a working directory and we check that we get a resolved path."
	
	mic := microdown 
		resolverRoot: FileSystem workingDirectory ;
		resolvedTreeFrom: file contents.

	self 
		assert: mic children second children first resources url class 
		equals: FileReference.
	self 
		assert: (mic children second children first resources url absolutePath asString splitOn: $/) size 
			>  #('documentation' 'image.png') size.
			
	! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveRelativeFileWithURL2
	| file mic |
	system := FileSystem memory workingDirectory.
	(system / 'folder') createDirectory.
	file := system / 'folder/file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '# section
!![caption](documentation/image.png)' ].

	mic := microdown 
		resolverRoot: 'http://www.pharo.org/figures' asUrl;
		resolvedTreeFromFile: file.
		
	self 
		assert: mic children second children first resources url printString 
		equals: 'http://www.pharo.org/figures/documentation/image.png'! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveRelativePathWithInputfile
	| file mic |
	system := FileSystem memory.
	(system workingDirectory / 'folder') createDirectory.
	file := system workingDirectory / 'folder' / 'file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '?{inputfile|path=chapters/withStyle.mic}?' ].
	
	mic := microdown 
				resolverRoot: system / '_result';
				resolvedTreeFromFile: file.
				
	self 
		assert: mic children first children first path fullName equals: '/_result/folder/chapters/withStyle.mic'

	! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveNotRelativePathWithInputfile
	
	| file mic |
	system := FileSystem memory workingDirectory.
	(system / 'folder') createDirectory.
	file := system / 'folder' / 'file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '?{inputfile|path=/chapters/withStyle.mic}?' ].

	mic := microdown 
				resolverRoot: system / '_result';
				resolvedTreeFromFile: file.
	
	self assert: mic children first children first path fullName equals:  '/chapters/withStyle.mic'
	! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveAbsoluteResourcesAgainstRootFileSystem
	| file mic |
	system := FileSystem memory workingDirectory.
	(system / 'folder') createDirectory.
	file := system / 'folder/file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '# section
!![caption](/documentation/image.png)' ].

	mic := microdown 
		resolverRoot: system;
		resolvedTreeFromFile: file.

	self 
		assert: mic children second children first resources url fullName 
		equals: '/documentation/image.png'
	! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveAbsoluteFileWithURL2
	| file mic |
	system := FileSystem memory workingDirectory.
	(system / 'folder') createDirectory.
	file := system / 'folder/file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '# section
!![caption](/documentation/image.png)' ].

	mic := microdown 
		resolverRoot: 'http://www.pharo.org/figures/' asUrl;
		resolvedTreeFromFile: file.

	self 
		assert: mic children second children first resources url printString 
		equals: 'http://www.pharo.org/documentation/image.png'
	! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveNotRelativePath
	
	| file mic |
	system := FileSystem memory workingDirectory.
	(system / 'folder') createDirectory.
	file := system / 'folder/file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '# section
!![caption](/folder/figures/image.png)' ].

	mic := microdown 
		resolverRoot: system; 
		resolvedTreeFromFile: file.
		
	self assert: mic children second children first resources fullName equals: '/folder/figures/image.png'.
	self assert: mic children second children first resources isFile
	! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveRelativeResourcesAgainstRootFileSystem
	| file mic |
	system := FileSystem memory workingDirectory.
	(system / 'folder') createDirectory.
	file := system / 'folder/file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '# section
!![caption](documentation/image.png)' ].

	mic := microdown 
		resolverRoot: system;
		resolvedTreeFromFile: file.

	self 
		assert: mic children second children first resources fullName
		equals: '/folder/documentation/image.png'.
	
		
	self 
		assert: mic children second children first resources url fullName
		equals: '/folder/documentation/image.png'
	
! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveRelativeResourcesAgainstSubFolders
	| file mic |
	system := FileSystem memory workingDirectory.
	(system / 'folder') createDirectory.
	file := system / 'folder' / 'file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '# section
!![caption](figures/image.png)' ].

	"now we resolved against folder and not the root of the filesystem"
	mic := microdown 
		resolverRoot: system / 'xxx' / 'subfil' ;
		resolvedTreeFromFile: file.

	self 
		assert: mic children second children first resources path pathString
		equals: '/xxx/subfil/folder/figures/image.png'
	! !

!MicPathResolverTest methodsFor: 'tests' stamp: ''!
testResolveRelativeFileWithURL
	| file mic |
	system := FileSystem memory workingDirectory.
	(system / 'folder') createDirectory.
	file := system / 'folder/file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '# section
!![caption](documentation/image.png)' ].

	mic := microdown 
		resolverRoot: 'http://www.pharo.org' asUrl;
		resolvedTreeFromFile: file.

	self 
		assert: mic children second children first resources url printString 
		equals: 'http://www.pharo.org/documentation/image.png'
	! !

!MicPathResolverTest methodsFor: 'new tests' stamp: ''!
testResolveInContextOfFilePath

	| fileSystem root file|
	fileSystem := FileSystem memory. 
	(fileSystem workingDirectory / 'SUnit') createDirectory.
	file := fileSystem workingDirectory  / 'SUnit' / 'SUnit.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '!![aFile](figures/setUp.png)' ].
	root := (Microdown new 
					resolverRoot: fileSystem workingDirectory;
					resolvedTreeFromFile: file).

	self assert: root children first children first url fullName equals: '/SUnit/figures/setUp.png' ! !

!MicPathResolverTest methodsFor: 'dummy tests' stamp: ''!
testParameterFileNotCallingResolver
	"Using the parser should handle parameters"
	
	| mic |
	mic := parser parse: '!![caption](figures/blop/toto.png?width=90&caption=''Super nice'')'.
	self assert: ('*figures/blop/toto.png*' match: mic children first children first resources fullName). 
	
	
	! !

!MicPathResolverTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	resolver := MicPathResolver new.
	system := FileSystem memory workingDirectory.
	parser := MicroDownParser new.
	microdown := Microdown new! !

!MicQuoteBlock commentStamp: ''!
I represent preformatted paragraph indicated by '> ' at the beginning of each my lines. 
I'm like a preformatted in HTML or Pillar '= '.
Every single line should starts with '> '.

The semantics of microdown quote block is that blocks (code block, header, lists) are not interpreted inside only formatting.

In githubmarkdown the definitions are just super complex and we do not follow them. 
	"A block quote marker consists of 0-3 spaces of initial indent, plus (a) the character > together with a following space, or (b) a single character > not followed by a space."

!
!MicQuoteBlock methodsFor: 'visiting' stamp: ''!
closeMe
	super closeMe.
	
	children := MicInlineParser new parse: text! !

!MicQuoteBlock methodsFor: 'testing' stamp: ''!
lineMarkup

	^ self parser preformattedMarkup! !

!MicQuoteBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitQuote: self! !

!MicQuoteBlockTest commentStamp: ''!
I'm a test class for testing the behavior of MicBlockTextBlock!
!MicQuoteBlockTest methodsFor: 'tests' stamp: ''!
testSingleQuoteBlockFollowedByList
	| source root text list |
	source := '> text1
>    text2
1. first
2. second
3. third'.
	root := parser parse: source.
	self assert: root children size equals: 2.
	text := root children first.
	self
		assert: text text
		equals:
			'text1
text2'.
	list := root children second.
	self assert: list children size equals: 3! !

!MicQuoteBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicQuoteBlock ! !

!MicQuoteBlockTest methodsFor: 'tests' stamp: ''!
testSingleQuoteBlock
	| source root text  |
	source := '> text1
>    text2'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	text := root children first.
	self
		assert: text text
		equals:
			'text1
text2'! !

!MicQuoteBlockTest methodsFor: 'tests' stamp: ''!
testBasicQuoteBlock
	| source root |
	source := '> test1
> test 2'.
	root := parser parse: source.

	self assert: root children first class equals: MicQuoteBlock.
	self assert: root children first text  equals: 'test1
test 2'.
	self flag: #tofix.
"note that this is wrong because the body of a quoteblock is a paragraph and can containsTruePositive: formatting else this is just a code block"! !

!MicQuoteBlockTest methodsFor: 'tests' stamp: ''!
testQuoteBlockDoesNotInterpretOtherBlockMarkup
	| source root text  |
	source := '> text1
>   - text2
> ```languague=pharo
> Yeah cool'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	text := root children first.
	self
		assert: text text
		equals:
			'text1
- text2
```languague=pharo
Yeah cool'! !

!MicQuoteBlockTest methodsFor: 'tests' stamp: ''!
testNotLazy
	"the spec says that the last > could be omitted but we do not support it."
	| source root text  |
	source := '> text1
>   - text2
text3'.
	root := parser parse: source.
	self assert: root children size equals: 2.
	text := root children first.
	self
		assert: text text
		equals:
			'text1
- text2'! !

!MicRawBlock commentStamp: ''!
Raw lets the user place anything (so don't use it).

```
{{ raw contents}}
```!
!MicRawBlock methodsFor: 'accessing' stamp: ''!
kind

 	^ #raw! !

!MicRawBlock methodsFor: 'accessing' stamp: ''!
openingDelimiter

 	^ MicRawOpenerDelimiter markup! !

!MicRawBlock methodsFor: 'accessing' stamp: ''!
closingDelimiter

 	^ MicRawCloserDelimiter markup! !

!MicRawBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitRaw: self! !

!MicRawBlock class methodsFor: 'testing' stamp: ''!
isEvaluated
	^ false! !

!MicRawCloserDelimiter commentStamp: ''!
I am the closer delimiter for raw.!
!MicRawCloserDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicRawBlock ! !

!MicRawCloserDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ false! !

!MicRawCloserDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '}}'! !

!MicRawCloserDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ true! !

!MicRawCloserDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #raw! !

!MicRawOpenerDelimiter commentStamp: ''!
I am the opener delimiter for raw.!
!MicRawOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicRawBlock ! !

!MicRawOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicRawOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '{{'! !

!MicRawOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ false! !

!MicRawOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #raw! !

!MicResourceReference commentStamp: ''!
I represent a file reference or url reference.

Here are the cases that we should handle

- external links
- figures
- inputfiles

For external links we can accept an URL that will be considered as absolute path to the resources http://server/m.mic.
For inputfile and figures we can accept

- an Url http://server/m.mic or http://server/m.png
- a relative path e.g., figures/m.png

## Implementation

url is misleading as an instance variable names since it can be either an url or a file reference.

## Warning

This is class is under heavy development. 
Some API will be dropped. Right now we just wrapped an URL to get the tests passing but we will revisit all the points.

Note that 

```
'file:///toto.png' asUrl isAbsolute 
>>> false
'file://toto.png' asUrl isAbsolute 
>>> true
```
So this is counter intuitive from a simple look.
!
!MicResourceReference methodsFor: 'testing' stamp: ''!
isFile
	
	(originalString last = $/)
		ifTrue: [ ^ false ].
	^ true! !

!MicResourceReference methodsFor: 'testing' stamp: ''!
isImageFile
	"Working both with resolved or not."
	^ #('pcx' 'bmp' 'jpeg' 'xbm' 'pnm' 'ppm' 'gif' 'pam' 'jpg' 'png' 'pbm')
		includes: urlOrFileReference asFileReference extension asLowercase! !

!MicResourceReference methodsFor: 'accessing' stamp: ''!
string: aString

	originalString := aString trimBoth
	
	 ! !

!MicResourceReference methodsFor: 'converting' stamp: ''!
asFileReference

	^ self subclassResponsibility! !

!MicResourceReference methodsFor: 'private' stamp: ''!
url: aString
	
	urlOrFileReference := aString! !

!MicResourceReference methodsFor: 'testing' stamp: ''!
isWeb
	"Answer whether I'm suitable to be opened in a web browser."

	^ false! !

!MicResourceReference methodsFor: 'accessing' stamp: ''!
originalString: aString

	originalString := aString trimBoth.
	
	 ! !

!MicResourceReference methodsFor: 'testing' stamp: ''!
printOn: aStream

	aStream nextPutAll: originalString ! !

!MicResourceReference methodsFor: 'accessing' stamp: ''!
originalString
	
		
	^ originalString ! !

!MicResourceReference methodsFor: 'private' stamp: ''!
url 
	^ urlOrFileReference! !

!MicResourceReference methodsFor: 'private' stamp: ''!
path 
	^ urlOrFileReference! !

!MicResourceReference class methodsFor: 'instance creation' stamp: ''!
fromString: aString
	
	^ (aString beginsWith: 'http')
		ifTrue: [ MicHTTPResource new 
						string: aString; 
						yourself ]
		ifFalse: [ MicLocalFileResource new 
							string: aString;
							yourself ]
		! !

!MicResourceReferenceTest methodsFor: 'tests - file reference conversion' stamp: ''!
testResolvedFileReferenceFromFile
	"Resolution does not change the file reference conversion."
	
	| mf |
	mf := self resourceClass fromString: '/tmp'.
	mf resolvedBy: (Path * '') withResolver: (self resolver: FileSystem workingDirectory).
	self assert: mf asFileReference printString equals: '/tmp'.
	! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testIsFileOfResolvedUrlFile

	| mf |
	mf := self resourceClass fromString: 'http://server/figures/m.png'.
	mf resolvedBy: (Path * '') withResolver: (self resolver: FileSystem workingDirectory).
	self assert: mf isFile.
	! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testIsFileOfUrlFile

	| mf |
	mf := self resourceClass fromString: 'http://server/figures/m.png'.
	self assert: mf isFile.
	! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testResolvedIsImageFile
	
	| mf |
	mf := self resourceClass fromString: '/chapter1/figures/m.png'.
	mf resolvedBy: (Path * '') withResolver: (self resolver:  FileSystem workingDirectory).
	self assert: mf isImageFile.
	! !

!MicResourceReferenceTest methodsFor: 'helper' stamp: ''!
resourceClass

	^ MicResourceReference! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testIsFileOfUrlFolder

	| mf |
	mf := self resourceClass fromString: 'http://server.org/figures/'.
	self deny: mf isFile.
	! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testUnresolvedIsImageFile
	
	| mf |
	mf := self resourceClass fromString: '/chapter1/figures/m.png'.
	self assert: mf isImageFile.
	! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testIsFileOfUrlResolvedFolder

	| mf |
	mf := self resourceClass fromString: 'http://server.org/figures/'.
	mf resolvedBy: (Path * '') withResolver: (self resolver: FileSystem workingDirectory).
	self deny: mf isFile.
	! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testIsFileOfNoUrlFolder

	| mf |
	mf := self resourceClass fromString: 'server.org/figures/'.
	self deny: mf isFile.
	mf := self resourceClass fromString: '/server.org/figures/'.
	self deny: mf isFile.! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testIsFileOfNoUrlFile

	| mf |
	mf := self resourceClass fromString: 'server.org/figures/p.png'.
	self assert: mf isFile.
	mf := self resourceClass fromString: '/server.org/figures/p.png'.
	self assert: mf isFile.! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testIsFileOfResolvedByNoUrlFolder

	| mf |
	mf := self resourceClass fromString: 'server.org/figures/'.
	mf resolvedBy: (Path * '') withResolver: (self resolver: FileSystem workingDirectory).
	self deny: mf isFile.
	mf := self resourceClass fromString: '/server.org/figures/'.
	mf resolvedBy: (Path * '') withResolver: (self resolver: FileSystem workingDirectory).
	self deny: mf isFile.! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testIsFileOfResolvedByNoUrlFile

	| mf |
	mf := self resourceClass fromString: 'server.org/figures/p.png'.
	mf resolvedBy: (Path * '') withResolver: (self resolver: FileSystem workingDirectory).
	self assert: mf isFile.
	
	mf := self resourceClass fromString: '/server.org/figures/p.png'.
	mf resolvedBy: (Path * '') withResolver: (self resolver: FileSystem workingDirectory).
	self assert: mf isFile.! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testResolvedIsRelativeFile
	
	| mf |
	mf := self resourceClass fromString: 'chapter1/figures/m.mic'.
	mf resolvedBy: (Path * '') withResolver: (self resolver:  FileSystem memory workingDirectory).

	self assert: (mf isKindOf: MicLocalFileResource).
	self assert: mf path pathString equals: 'chapter1/figures/m.mic'
	! !

!MicResourceReferenceTest methodsFor: 'tests - file reference conversion' stamp: ''!
testUnresolvedFileReferenceFromFile
	"Resolution does not change the file reference conversion."
	
	| mf |
	mf := self resourceClass fromString: '/chapter1/figures/m.mic'.
	self assert: mf path pathString equals: '/chapter1/figures/m.mic'.
	! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testUrlGetResolved

	
	| mf |
	mf := self resourceClass fromString: 'http://files.pharo.org/logo/pharologo.png'.
	mf resolvedBy: (Path * '') withResolver: (self resolver:  FileSystem memory workingDirectory).
	self assert: (mf isKindOf: MicHTTPResource).
	self assert: (mf url printString) equals: 'http://files.pharo.org/logo/pharologo.png'
	! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testUnResolvedIsRelativeFile
	
	| mf |
	mf := self resourceClass fromString: 'chapter1/figures/m.mic'.
	self assert: (mf isKindOf: MicLocalFileResource).
	self assert: mf path pathString equals: 'chapter1/figures/m.mic'.
	! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testParseFullUrl

	| mf |
	mf := self resourceClass fromString: 'http://server/m.mic'.
	self assert: mf asString equals: 'http://server/m.mic'.
! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
resolver: aFileSystemOrURL

	^ MicPathResolver new resolutionSource: aFileSystemOrURL; yourself! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testResolvedIsAbsoluteFile
	
	| mf |
	mf := self resourceClass fromString: '/chapter1/figures/m.mic'.
	mf resolvedBy: (Path * '') withResolver: (self resolver:  FileSystem memory / 'root2').
	self assert: (mf isKindOf: MicLocalFileResource).
	self assert: mf path pathString equals:  '/chapter1/figures/m.mic'. 
	! !

!MicResourceReferenceTest methodsFor: 'tests' stamp: ''!
testUnresolvedIsAbsoluteFile
	
	| mf |
	mf := self resourceClass fromString: '/chapter1/figures/m.mic'.
	self assert: (mf isKindOf: MicLocalFileResource).
	self assert: mf path pathString equals: '/chapter1/figures/m.mic'.

	! !

!MicRichTextBrush commentStamp: ''!
I am a brush in the canvas-brush pattern.

I represent one kind of `TextAttribute` to be added to a `Text`.!
!MicRichTextBrush methodsFor: 'accessing' stamp: ''!
attribute: anObject
	attribute := anObject! !

!MicRichTextBrush methodsFor: 'accessing' stamp: ''!
canvas: anObject
	canvas := anObject! !

!MicRichTextBrush methodsFor: 'paint' stamp: ''!
paint: aText
	aText addAttribute: attribute ! !

!MicRichTextBrush methodsFor: 'accessing' stamp: ''!
attribute
	^ attribute! !

!MicRichTextBrush methodsFor: 'accessing' stamp: ''!
canvas
	^ canvas! !

!MicRichTextBrush class methodsFor: 'instance creation' stamp: ''!
on: canvas 
	^self new
		canvas: canvas! !

!MicRichTextBrush class methodsFor: 'instance creation' stamp: ''!
on: canvas attribute: attr
	^self new
		canvas: canvas;
		attribute: attr! !

!MicRichTextCanvas commentStamp: ''!
I am a Canvas in the Canvas-Brush pattern. I keep an output stream of type `Text`.
As texts can have multiple annotations, I have a stack of brushes to paint a text with. 
My only method for adding text to my stream is `<<`.!
!MicRichTextCanvas methodsFor: 'public' stamp: ''!
newLineIfNotAlready
	crAtEnd
		ifFalse: [ self newLineBody ].
	crAtEnd := true! !

!MicRichTextCanvas methodsFor: 'public' stamp: ''!
newLine
	self newLineBody.
	crAtEnd := true! !

!MicRichTextCanvas methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	out := WriteStream on: '' asText.
	brushes := OrderedCollection with: (MicRichTextIndentBrush on: self).
	nesting := 0.
	crAtEnd := true. "Prevent newlines in beginning"! !

!MicRichTextCanvas methodsFor: 'public' stamp: ''!
includeAttribute: attr in: aBlock
	brushes addLast: (MicRichTextBrush on: self attribute: attr).
	aBlock value.
	brushes removeLast! !

!MicRichTextCanvas methodsFor: 'private' stamp: ''!
tab
	self << String tab asText! !

!MicRichTextCanvas methodsFor: 'public' stamp: ''!
<< aText
	brushes do: [ :brush | brush paint: aText ].
	out << aText.
	aText ifNotEmpty: [crAtEnd := aText last = Character cr].! !

!MicRichTextCanvas methodsFor: 'private' stamp: ''!
newLineBody
	self << String cr asText! !

!MicRichTextCanvas methodsFor: 'public' stamp: ''!
contents
	^ out contents! !

!MicRichTextCanvas methodsFor: 'accessing' stamp: ''!
nesting
	^ nesting! !

!MicRichTextCanvas methodsFor: 'public' stamp: ''!
includeBrush: aBrush in: aBlock
	"Add for the course of aBlock, a brush (aBrush) to the currently used brushes."
	brushes addLast: aBrush.
	aBlock value.
	brushes removeLast! !

!MicRichTextCanvas methodsFor: 'public' stamp: ''!
indentIn: aBlock 
	nesting := nesting + 1.
	aBlock value.
	nesting := nesting - 1.
	
		! !

!MicRichTextCanvas methodsFor: 'public' stamp: ''!
cr
	self newLine! !

!MicRichTextComposer commentStamp: ''!
I am a visitor that produces rich text (class Text) based on a pillar document model.
I am implemented using a canvas/brush pattern. The class offers multiple configurations: an offline mode, 
a not rendering mode, and a not catching exceptions (to ease debugging).

The main API is the method: `BCRichTextComposer class>>#renderComment:of:`.

Web-based images or LaTeX rendering requires network access and are cached.



!!!!Note The composer should be improved to render better and in nicer ways elements. 

#### Advanced  
For the LaTeX rendering, internet connexion is required. 
You can also turn it off/on doing

```
BCRichTextComposer putOffLine
```

In addition, images fetched via http requests are cached to avoid multiple http requests.
The cache can be reset executing `PRRichTextComposer resetCache`. When the system is off line and an image is requested, a placeholder is computed but not put in the cache. This way when the system is put online the requested elements will be requested and put in the cache (without needing to flush placeholders from the cache).
When the system is online but the request failed I display an uncached placeholder.

It means that web-based images can be prefilled and Pharo images can be provided preloaded. 

When you want to get all the errors (typically to debug and fix them), you can configure the system to stop capturing errors using 

```
PRRichTextComposer captureErrors: false

```
\'


#### Known limits
Monospaced text (e.g., `Point`, `Point class`,  `Point>>#setX:setY:`, or `#'Pillar-ExporterPillar'`) uses TextAction to trigger browser opening on the corresponding element. It would be better to use a TextLink because the styler is aware of them. 

!
!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
annotatedParagraphAnnotationColor: aColor
	annotatedParagraphAnnotationColor := aColor! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
subscriptColor: anObject
	subscriptColor := anObject! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
visitHorizontalLine: anHorizontalLine
	
	canvas includeAttribute: TextEmphasis underlined in: [ canvas << ('     ' repeat: 20) asText ].
	canvas newLine.	! !

!MicRichTextComposer methodsFor: 'images internal' stamp: ''!
rawImageFrom: aURL
	| block |
	self flag: #fixMeOnceNewExceptionIsAvailable.
	block := [ ZnEasy getImageOfType: (ZnMimeType main: 'image' sub: '*') fromUrl: aURL ].
	self class captureErrors
		ifFalse: [ ^ block value ].

	^ [[ block
		on: ZnHttpUnsuccessful 
		do: [ :ex | self unsuccessfulRequestFromUrl: aURL ]]
			on: ZnUnexpectedContentType 
			do: [ :ex | self imageUnexpectedContentFromUrl: aURL ]] on: Error do: [ ] 
		! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
visitHeader: aHeader

	canvas newLineIfNotAlready.
	canvas newLine.
	canvas
		includeAttribute: (self class headerLevelFont: aHeader level)
		in: [ super visitHeader: aHeader ].
	canvas newLine! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
monospaceBackgroundColor

	^ monospaceBackgroundColor! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
visitMathInline: aMicMathInline 
	
	OffLine 
		ifTrue: [ canvas << '$', aMicMathInline text, '$' ]
		ifFalse: [ canvas << (self class latexMathStylerFor: aMicMathInline text)]! !

!MicRichTextComposer methodsFor: 'images' stamp: ''!
renderMathExpression: aString
	
	canvas << (self class latexMathStylerFor: aString)! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
visitParagraph: anObject
	
	"canvas newLineIfNotAlready."
	canvas newLine.
	super visitParagraph: anObject.
	canvas newLine.! !

!MicRichTextComposer methodsFor: 'visiting - list' stamp: ''!
visitOrderedList: anObject
	"here we annotate items with their kind and the depth"
	| counter |
	canvas newLineIfNotAlready.
	canvas indentIn: [counter := 1.
		anObject children
			do: [ :item | 
				item propertyAt: #kind put: #ordered.
				item
					propertyAt: #counter
					put: (self class counterFor: counter atLevel: canvas nesting - 1).
				counter := counter + 1 ].
		super visitOrderedList: anObject ].
	canvas newLine! !

!MicRichTextComposer methodsFor: 'visiting -  format' stamp: ''!
visitText: anInlineBlock
	"we should set attribute because it would override link and others."
	canvas << anInlineBlock substring asText! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
visitLink: aLink

	| attribute |
	attribute := nil.
	aLink url isWeb ifTrue: [
		attribute := TextAction new
			actOnClickBlock: [ WebBrowser openOn: aLink url printString ];
			yourself ].
	attribute
		ifNotNil: [ canvas
			includeAttribute: attribute
			in: [ super visitLink: aLink ] ]
		ifNil: [ super visitLink: aLink ]! !

!MicRichTextComposer methodsFor: 'visiting -  format' stamp: ''!
visitMonospace: anObject
	"Notice - I add a highlight to the backgorund rather than mono-spaced."
	| backgroundColor sem |
	backgroundColor := self monospaceBackgroundColor.
	
	self flag: #fixMe.
	"Right now we stupidly emit TextAction but we should emit TextClassLink and revisit them."
	canvas 
		includeAttribute: (TextBackgroundColor color: backgroundColor) 
		in: [ 
			sem := MicSemanticAction from: anObject text.
			sem hasEntity 
				ifTrue: [ canvas 
								includeAttribute: (TextAction new actOnClickBlock: [ sem entity browse ]) 
								in: [ super visitMonospace: anObject ] ]
				ifFalse: [ super visitMonospace: anObject]].  ! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
superscriptColor
	^ superscriptColor ! !

!MicRichTextComposer methodsFor: 'visiting -  format' stamp: ''!
visitBold: anObject
	canvas 
		includeAttribute: TextEmphasis bold 
		in: [ super visitBold: anObject ]
	! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
visitCode: aCodeBlock
	
	canvas newLineIfNotAlready.
	canvas newLine.
	canvas
		indentIn: [  
			aCodeBlock hasCaption 
				ifTrue: [ 
					canvas 
					includeAttribute: TextEmphasis bold 
					in: [ canvas  << aCodeBlock caption asText; newLine]].
			canvas
				indentIn: [ 
					canvas << (self class  
						style: aCodeBlock body 
						asLanguage: aCodeBlock firstTag)
			] ].
	canvas newLine.
! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
monospaceBackgroundColor: aColor

	monospaceBackgroundColor := aColor! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
visitParameters: anObject
	"do nothing for now"
	
	^ self! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
resizeImage: anImage of: aFigure

	| anchoredImage |
	anchoredImage := anImage.
	aFigure arguments at: #width ifPresent: [ :s | 
		anchoredImage := anImage scaledToSize: s asNumber @ s asNumber ].
	^ anchoredImage! !

!MicRichTextComposer methodsFor: 'images internal' stamp: ''!
imageUnexpectedContentFromUrl: aUrl
	"The request got unexpected content if the image is there so we return it. We do not cache the failing case image form so that we do not polute the cache."
	
	^ ImageCache 
			at: aUrl asString
			ifPresent: [ :i | i ]
			ifAbsent: [ (StringMorph contents: 'The HTTP request ', aUrl asString, ' returned an unexpected content.' ) imageForm  ]
			! !

!MicRichTextComposer methodsFor: 'visiting' stamp: ''!
visit: aDocument
	
	canvas := MicRichTextCanvas new.
	super visit: aDocument.
	^ canvas contents! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
visitMath:  aMicMathEnvironment

	| text |
	text := aMicMathEnvironment body. 
	(OffLine | text isNil)
		ifTrue: [ text 
						ifNotNil: [ canvas << '&'; cr; << text; << '&']
						ifNil: [ canvas << '&'; cr; << 'Your math environment is strange its body is nil'; << '&' ] ]
		ifFalse: [ canvas cr.
					canvas indentIn: [ self renderMathExpression: text ].
					 canvas cr ]! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
subscriptColor
	^ subscriptColor ! !

!MicRichTextComposer methodsFor: 'visiting - list' stamp: ''!
visitListItem: anItem
	| bullet |
	"The depth counter and bullet type in `visitOrderedList` and `visitUnorderedList`"
	bullet := (anItem propertyAt: #kind) = #ordered
		ifTrue: [ (anItem propertyAt: #counter) asString asText , String tab ]
		ifFalse: [ (anItem propertyAt: #bullet) asText , String tab ].
	bullet addAttribute: (TextIndent tabs: canvas nesting - 1).
	canvas newLineIfNotAlready.
	canvas << bullet.
	canvas indentIn: [ super visitListItem: anItem ].
! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
annotatedParagraphColor: aColor
	annotatedParagraphColor := aColor! !

!MicRichTextComposer methodsFor: 'images internal' stamp: ''!
imageOffLineFromUrl: aUrl
	"we are off but the image is there so we return it,"
	^ ImageCache 
			at: aUrl asString
			ifPresent: [ :i | i ]
			ifAbsent: [ (StringMorph contents: 'The HTTP request got unsuccessful. 
When you will be online, you should see: ' , aUrl asString) imageForm  ]
			! !

!MicRichTextComposer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	monospaceBackgroundColor := self theme settings windowColor.
	superscriptColor := self defaultSuperscriptColor.
	subscriptColor := TextColor red.
	annotatedParagraphColor := self defaultAnnotatedParagraphColor.
	annotatedParagraphAnnotationColor := TextEmphasis bold.
	annotatedParagraphAlignment := TextAlignment leftFlush! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
todo 
	^ 'there is too much hspace after a section when it is followed by a paragraph. 
This also because people will not want to to not let a newline between the header and paragraph when writing the text.'! !

!MicRichTextComposer methodsFor: 'initialization' stamp: ''!
defaultAnnotatedParagraphColor
	^ TextColor blue! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
annotatedParagraphColor
	^ annotatedParagraphColor ! !

!MicRichTextComposer methodsFor: 'initialization' stamp: ''!
defaultSuperscriptColor
	^ TextColor blue! !

!MicRichTextComposer methodsFor: 'initialization' stamp: ''!
theme

	^  Smalltalk ui theme! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
annotatedParagraphAnnotationColor
	^ annotatedParagraphAnnotationColor ! !

!MicRichTextComposer methodsFor: 'images internal' stamp: ''!
unsuccessfulRequestFromUrl: aUrl
	
	^ ImageCache 
			at: aUrl asString
			ifPresent: [ :i | i ]
			ifAbsent: [ (StringMorph contents: 'The HTTP request ',  aUrl asString,  ' got unsuccessful.') imageForm  ]
			! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
visitEnvironment: anObject
	self error: 'It was a halt'.
	"What is this textBlock idea? Clean!!"
	anObject name = 'textBlock'
		ifTrue:[
			canvas indentIn: [  
				canvas 
					includeAttribute: TextEmphasis italic  
					in: [self visitFormat: anObject]] ]
		ifFalse: [canvas << ('>>> Environment ' , anObject name , 
						'is not supported in RichText Pillar <<<') asText]! !

!MicRichTextComposer methodsFor: 'visiting - inline elements' stamp: ''!
visitFigure: aFigure
	"Try to read a png file (only one supported right now), else use alt text"
	
	aFigure isImageFile ifTrue: [
	| anchoredImage url |
	url := aFigure url.
	"this url should be renamed resources"
	"this logic has to be revisited with the new resolver."
	
	anchoredImage := url isWeb
		                 ifFalse: [ 
									"should probably fix this."
									(aFigure originPath fileSystem / aFigure url path) isFile
										ifTrue: [ 
											aFigure originPath fileSystem / (aFigure url) path
				                 		binaryReadStreamDo: [ :stream | 
				                 		ImageReadWriter formFromStream: stream ] 
											]
							        ]
		                 ifTrue: [ self cachedImageFromUrl: url url ].
	anchoredImage ifNotNil: [ 
		anchoredImage := self resizeImage: anchoredImage of: aFigure.
		anchoredImage := (String value: 1) asText addAttribute: (TextAnchor new anchoredMorph: anchoredImage).
		canvas << anchoredImage ].
	
	canvas newLine.
	canvas includeAttribute: TextEmphasis bold in: [  ]].
	"	on: Exception
		do: [ self visitChildrenOf: aFigure ]. pay attention url return the rest https://files.pharo.org/media/logo/logo.png%7Csize=80&caption=Our%20great%20figure so we will have to add a method to only return the url part."
	canvas
		tab;
		tab;
		tab;
		<< aFigure caption asText! !

!MicRichTextComposer methodsFor: 'visiting -  format' stamp: ''!
visitItalic: anObject
	canvas 
		includeAttribute: TextEmphasis italic 
		in: [ super visitItalic: anObject ]! !

!MicRichTextComposer methodsFor: 'visiting -  format' stamp: ''!
visitStrike: anObject

	canvas 
		includeAttribute: TextEmphasis struckOut 
		in: [ super visitStrike: anObject ]! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
superscriptColor: anObject
	superscriptColor := anObject! !

!MicRichTextComposer methodsFor: 'accessing' stamp: ''!
annotatedParagrapAlignment
	^ annotatedParagraphAlignment ! !

!MicRichTextComposer methodsFor: 'images' stamp: ''!
cachedImageFromUrl: aUrl
	
	^ OffLine 
		ifFalse: [
			ImageCache 
				at: aUrl asString
				ifAbsentPut: [ self rawImageFrom: aUrl ] ] 
		ifTrue: [ self imageOffLineFromUrl: aUrl ]! !

!MicRichTextComposer methodsFor: 'visiting - document' stamp: ''!
visitAnnotatedParagraph: anAnnotatedParagraph
	self error: 'this was a halt.'.
	canvas newLineIfNotAlready.
	canvas newLine.
	canvas
		includeAttribute: self annotatedParagrapAlignment
		in: [ 
			canvas
				includeAttribute: self annotatedParagraphAnnotationColor
				in: [ canvas << anAnnotatedParagraph annotation capitalized asText ].
			canvas
				includeAttribute: self annotatedParagrapAlignment
				in: [ canvas
						includeAttribute: self annotatedParagraphColor
						in: [ self visitParagraph: anAnnotatedParagraph ] ] ].
	canvas newLine.! !

!MicRichTextComposer methodsFor: 'visiting - list' stamp: ''!
visitUnorderedList: anObject
	canvas newLineIfNotAlready.
	canvas
		indentIn: [ 
			anObject children
				do: [ :item | 
					item propertyAt: #kind put: #unordered.
					item
						propertyAt: #bullet
						put: (self class bulletForLevel: canvas nesting - 1) ].
			super visitUnorderedList: anObject ].
	canvas newLine! !

!MicRichTextComposer class methodsFor: 'styler' stamp: ''!
languageStylerFor: aLanguage

	^ Stylers
		at: aLanguage asLowercase
		ifAbsent: [ self languageStylerFor: 'default' ]! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
resetCache

	ImageCache := Dictionary new! !

!MicRichTextComposer class methodsFor: 'styler' stamp: ''!
defaultStyler: aString
	<codeblockStylerFor: 'default'>
	"Pay attention without this one the logic can loop."
	
	^ self codeStylerFor: aString! !

!MicRichTextComposer class methodsFor: 'private' stamp: ''!
loadExternalImageFromURL: aUrl errorText: errorDesc
	"I return a Text instance with an loaded from a url"
	
	| anchoredImage |
	self flag: #cleanAndRevisit.
	"there is duplication in the visitFigure: method!!!!!!"
	anchoredImage := self imageCache 
		at: aUrl 
		ifAbsentPut: [ 
			[ anchoredImage := (String value: 1) asText
					addAttribute: (TextAnchor new anchoredMorph: (ZnEasy getPng: aUrl)).
				anchoredImage ] 
			on: Exception 
			do: [ errorDesc asText addAttribute: TextColor red ]
		].
	^ anchoredImage ! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
notRendering
	"When notRendering, the comments are just displayed as plain text."
	
	^ NotRendering! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
exampleMicrodown3
	<example>
	(self microdownAsRichText:
					'## Code Blocks
this is just _first_ line

```
Metacello new
   baseline: ''PillarRichTextExporter'';
   repository: ''github://kasperosterbye/PillarRichTextRender'';
   load.
```') inspect

! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
putOffline

	self offline: true! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
initializeStylers
	"self initializeStylers"
	Stylers := Dictionary
		newFromAssociations: ((PragmaCollector
						filter: [ :prg | prg selector = 'codeblockStylerFor:' ]) reset
						collected collect: [ :p | p arguments first asLowercase-> p method ])! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
imageAt: urlString put: aForm	
	"the cache contains results of for example ZnEasy getPng:, i.e., a form"
	
	ImageCache at: urlString put: aForm! !

!MicRichTextComposer class methodsFor: 'settings' stamp: ''!
preferencesSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #comments)
		label: 'Comment rendering';  
		parent: #appearance;
		description: 'All settings concerned with the control of nice comment rendering';
		with: [
		(aBuilder setting: #offline)
			label: 'To enable offline mode';
			target: self;
			default: false;
			description: '
			When online is chosen, requests to external images are only performed when they are not in the image cache (since requesting systematically HTTP may lead of latency. Each figure is cached, so the request is at most done one per external references. When the system is online but the request failed we return a placeholder that is not cached.
			
			When offline, requests to external images are not performed. The cache can be reset executing PRRichTextComposer resetCache. When the system is off line and an image is requested, a placeholder is computed but not put in the cache. This way when the system is put online the requested elements will be requested and put in the cache (without needing to flush placeholders from the cache).'. 
			(aBuilder setting: #notRendering)
				label: 'To disable richtext rendering';
				default: false;
				target: self;
				description: 'Comments are by default rendered via Pillar in Richtext. When this setting is on, they are rendered as plain text (showing their Microdown definitions).'. 
			(aBuilder setting: #captureErrors)
				label: 'To disable rendering error capture';
				default: true;
				target: self;
				description: 'By default if there is an error during the rendering of the comments, various errors are trapped. If you want to get such errors to debug the system, you should turn off this settings.'. 
			
			]! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
latexExample
	<example>

	(MicRichTextComposer new visit: 
		(MicMathInlineBlock new 
		substring:
'V_i = C_0 - C_3
\frac{C_1\cos(\theta_i+C_3)}{C_4+C_1\cos(\theta_i+C_2)}')) inspect! !

!MicRichTextComposer class methodsFor: 'accessing' stamp: ''!
imageCache
	^ imageCache ifNil: [ imageCache := LRUCache new ]! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
exampleMicrodown6
	<example>
	(self microdownAsRichText:
					'### Figures
This is just **first** line. Figures accessed via HTTP requests are cached for speed reasons. 
At max you should get one request per picture.

!![A super nice Pharo logo.](https://files.pharo.org/media/logo/logo.png)

And this is the last line') inspect! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
captureErrors: aBoolean
	"self captureErrors: false"
	CaptureErrors := aBoolean! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
exampleMicrodown9
	<example>
	
	(self microdownAsRichText: 
'In future versions, we should introduce adapted colorizer for expressions and for method bodies.
```language=PharoMethod
foo: arg
	^ arg + self
```
') inspect! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
captureErrors
	
	^ CaptureErrors! !

!MicRichTextComposer class methodsFor: 'styler' stamp: ''!
methodStylerFor: aString
	<codeblockStylerFor:'PharoMethod'>
	
	"when we use a pharo method for an expression the styler breaks for method pattern. So it should be fixed in the future but for now we make sure that at least it does not breaks."
	^[ SHRBTextStyler new 
		isForWorkspace: false; 
		styledTextFor: aString asText ] on: SubscriptOutOfBounds do: [ aString asText ]! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
offline

	^ OffLine! !

!MicRichTextComposer class methodsFor: 'styler' stamp: ''!
textStyler: aString
	<codeblockStylerFor: 'text'>
	
	^aString asText! !

!MicRichTextComposer class methodsFor: 'private' stamp: ''!
headerFonts: anArray

	HeaderFontSizes := anArray! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
putOnline

	self offline: false! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
exampleMicrodown1
	<example>
	(self microdownAsRichText: '### First section
and this is just **first** line 
1. Line 1 More here More here `More here More here` More here More here More here More here More here More here
   - Kasper tries the strange thing Kasper tries the strange thingKasper tries the strange thingKasper tries the strange thingKasper tries the strange thingKasper tries the strange thingKasper tries the strange thing
   - And one more _silly_ thingie
1. Line 2
   - Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla
   - Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla Bla
1. Line 3') inspect! !

!MicRichTextComposer class methodsFor: 'styler' stamp: ''!
codeStylerFor: aString
	<codeblockStylerFor: 'Smalltalk'>
	
	^SHRBTextStyler new 
		isForWorkspace: true; 
		styledTextFor: aString asText! !

!MicRichTextComposer class methodsFor: 'styler' stamp: ''!
latexMathStylerFor: aString
	"<codeblockStylerFor:'latexMath'>
	
	this is totally bogus: this method does not return a styler but just an image."
	
	| expressionUrl |
	expressionUrl := 'https://latex.codecogs.com/png.latex?', aString urlEncoded.
	^self loadExternalImageFromURL: expressionUrl errorText: 'Latex error'.! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
initialize 
	"self initialize"
	self offline: false.
	self notRendering: false.
	self resetCache.
	self headerFontSizes: #(18 14 12 11 10 10).
	self initializeStylers.
	self captureErrors: true.! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
notRendering: aBoolean
	NotRendering := aBoolean! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
exampleMicrodown8
	<example>
	(self microdownAsRichText:
					'```language=PharoExpression
1 + 2 * 3  
```
') inspect! !

!MicRichTextComposer class methodsFor: 'private' stamp: ''!
computeHeaderFonts
	
	HeaderFonts := Array new:  HeaderFontSizes size.
	1 to: HeaderFontSizes size do: [ :index |
		HeaderFonts at: index put: 
			(TextFontReference
				toFont:
					(StrikeFont
						familyName: 'Bitmap Source Sans Pro'
						pointSize: (HeaderFontSizes at: index)))
			  ]! !

!MicRichTextComposer class methodsFor: 'private' stamp: ''!
counterFor: counter atLevel: level
	| kind |
	kind := level % 3.
	kind = 0
		ifTrue: [ ^ counter asString asText , '.' ].
	kind = 1
		ifTrue: [ ^ ($a asInteger + (counter - 1)) asCharacter asText , ')' ].
	kind = 2
		ifTrue: [ ^ ($A asInteger + (counter - 1)) asCharacter asText , ')' ]! !

!MicRichTextComposer class methodsFor: 'styler' stamp: ''!
expressionStylerFor: aString
	<codeblockStylerFor: 'PharoExpression'>
	
	^SHRBTextStyler new 
		isForWorkspace: true; 
		styledTextFor: aString asText! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
render: aString 
	"Render a string, in case of error, just return it."
	
	self notRendering 	
		ifTrue: [ ^ aString ].
	self captureErrors 
		ifFalse: [ ^ self microdownAsRichText: aString ].
	^ [ self microdownAsRichText: aString ] 
			on: STONReaderError, MicParsingError, MessageNotUnderstood, SubclassResponsibility 
			do: [ aString  ]! !

!MicRichTextComposer class methodsFor: 'private' stamp: ''!
headerLevelFont: level
	"I return a font annotation to be used with Attributes"

	^ HeaderFonts at: level! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
exampleMicrodown4
	<example>
	(self microdownAsRichText:
					'## Annotations
this is just _first_ line

!!!!todo remember to do annotations
and this is the second line') inspect! !

!MicRichTextComposer class methodsFor: 'class initialization' stamp: ''!
offline: aBoolean

	OffLine := aBoolean
! !

!MicRichTextComposer class methodsFor: 'styler' stamp: ''!
style: aString asLanguage: aLanguage
	"render aString according to the styler named aLanguage"
	
	| styler |
	styler := self languageStylerFor: aLanguage asLowercase.
	^ styler
		valueWithReceiver: styler methodClass soleInstance 
		arguments: (Array with: aString)! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
renderComment: aString of: aClassOrPackage 
	"Return aString as part of the templated class comment, when rendering is on.
	Else aString."
	
	| builder |
	builder := MicroDownParser builder.
	aClassOrPackage buildMicroDownUsing: builder withComment: aString.
	^ self render: builder contents! !

!MicRichTextComposer class methodsFor: 'private' stamp: ''!
headerFontSizes: anArray

	HeaderFontSizes := anArray.
	self computeHeaderFonts ! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
exampleMicrodown5
	<example>
	(self microdownAsRichText:
					'### Links
This is just first line with an inline web ref [Pharo](http://pharo.org/)

[Click me to go to http://pharo.org](http://pharo.org/)

Here are direct links to classes and method
- `String`
- `String>>#trim`

And this is another line') inspect! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
microdownAsRichText: aString
	
	^ self new visit: (Microdown new resolvedTreeFrom: aString)
! !

!MicRichTextComposer class methodsFor: 'private' stamp: ''!
bulletForLevel: level
	| kind |
	kind := level % 2.
	kind = 0
		ifTrue: [ ^ $• asText ].
	kind = 1
		ifTrue: [ ^ $- asText ]! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
exampleMicrodown11
	<example>
	(self microdownAsRichText:
'### Latex mathematics 
It is possible to render latex math via a web services. Future version will cache the resulting expressions. 

$
 \frac{C_1\cos(\theta_i+C_3)}{C_4+C_1\cos(\theta_i+C_2)}
$

Cool eh?
') inspect! !

!MicRichTextComposer class methodsFor: 'examples' stamp: ''!
exampleMicrodown7
	<example>
	(self microdownAsRichText:
					'# First section

1. `Point` should open a class browser on Point.
2. `Point class` should open a class browser on Point.
3. `Point >> setX:setY:` should open a browser on the correspoding method.
4. `#''Pillar-ExporterRichText''` should open a browser on the package.
5. But `Borrrrrken` does not display the same.
') inspect! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
testHeaderLevel3

	self 
		assertWriting: (self microElementsFrom: sample headerLevel3Sample) 
		include: self headerLevel3! !

!MicRichTextComposerTest methodsFor: 'tests - stylers' stamp: ''!
testStylersAreRegistered

	| defaultStyler |
	defaultStyler := self composerClass languageStylerFor: 'blblbl'.
	self assert: defaultStyler selector equals: #defaultStyler:! !

!MicRichTextComposerTest methodsFor: 'tests - format' stamp: ''!
testBoldFormat

	self assertWriting: (self microElementsFrom: sample boldFormatSample) include: self boldFormat! !

!MicRichTextComposerTest methodsFor: 'helpers' stamp: ''!
richTextFor: aDocument

	^ self composer visit: aDocument! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
headerLevel1

	^ self composerClass headerLevelFont: 1! !

!MicRichTextComposerTest methodsFor: 'skipped tests' stamp: ''!
strikethroughtFormat
	^ TextEmphasis struckOut! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
headerLevel3

	^ self composerClass headerLevelFont: 3! !

!MicRichTextComposerTest methodsFor: 'skipped tests' stamp: ''!
testNestedList
	| source richText runs|
	source := 
'- item 1
  1. sub item 1.1
- item 2
  2. sub item 2.1
  2. sub item 2.2
- item 3'.
	richText := self richTextForString: source.
	runs := richText runs.
	
	"check that 'sub item 2.1' is numbered 'A)' and is rightly indented"
	self assert: (richText asString copyFrom: 35 to: 36) equals: 'A)'.
	self assert: (runs at: 35) first amount equals: 3
	! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
testHeaderLevel4

	self 
		assertWriting: (self microElementsFrom: sample headerLevel4Sample) 
		include: self headerLevel4! !

!MicRichTextComposerTest methodsFor: 'helpers' stamp: ''!
stringOf: aPRDocument
	
	^ (self richTextFor: aPRDocument) string! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
headerLevel6

	^ self composerClass headerLevelFont: 6! !

!MicRichTextComposerTest methodsFor: 'tests - list' stamp: ''!
testOrderedList 
	| source richText runs  |
	source := '1. First item
2. Second item
   on two lines
3. Third item'.
	richText := self richTextForString: source.
	runs := richText runs .
	
	self assert: runs first first class equals: TextIndent.
	self assert: runs first first amount equals: 1.
	self assert: (runs at: 30) "the first o in 'on two lines'" first class equals: TextIndent.
	self assert: (runs at: 30) first amount equals: 2.
	! !

!MicRichTextComposerTest methodsFor: 'skipped tests' stamp: ''!
testFigure

	| source richText obj1  |
	self skip. "Currently getting an error in MicHTTPRessource"
	
	source := 'See !![no image found](https://pharo.org/web/files/pharo.png)'.
	richText := MicRichTextComposer microdownAsRichText: source.

	obj1 := (richText runs at: 10) first. "element 10 is the 'n' in anchor"
	self assert: obj1 class name equals: #TextAction! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
microElementsFrom: aString
	^ sample documentFrom: aString.
	! !

!MicRichTextComposerTest methodsFor: 'skipped tests' stamp: ''!
testItalicFormat 
	| source runs richText |
	source := 'This have been _emphasized_'.
	richText := self richTextForString: source.
	runs := (richText runs ) asArray .
	
	self assert: runs first isEmpty. 
	self assert: ((runs at: 19 "the p in emphasized") includes: self italicFormat ).
	self deny: ((runs at: 6 "the h in have") includes: self italicFormat  ).! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
headerLevel4

	^ self composerClass headerLevelFont: 4! !

!MicRichTextComposerTest methodsFor: 'tests - codeBlock' stamp: ''!
testCodeBlock
	| source runs richText |
	source := '
```arguments
line 1
line 2
```
'.
	richText := self richTextForString: source.
	runs := (richText runs collect: [:run | run collect: [:a| a class]]) asArray .	
	
	self assert: runs first isEmpty. 
	self assert: (runs second includes: TextIndent).
	self assert: richText asString equals: '
line 1
line 2
'! !

!MicRichTextComposerTest methodsFor: 'skipped tests' stamp: ''!
testExternaLink

	| source richText obj1  |
	source := 'See [my anchor](https://pharo.org)'.
	richText := MicRichTextComposer microdownAsRichText: source.

	obj1 := (richText runs at: 10) first. "element 10 is the 'n' in anchor"
	self assert: obj1 class name equals: #TextAction! !

!MicRichTextComposerTest methodsFor: 'tests - format' stamp: ''!
underlineFormat
	^ TextEmphasis underlined! !

!MicRichTextComposerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	sample := MicMicrodownSnippetFactory new.
	parser := MicroDownParser new.! !

!MicRichTextComposerTest methodsFor: 'tests - format' stamp: ''!
italicFormat
	^ TextEmphasis italic! !

!MicRichTextComposerTest methodsFor: 'skipped tests' stamp: ''!
externalLink: aLink
	^ TextAction new actOnClickBlock: [WebBrowser openOn: aLink]! !

!MicRichTextComposerTest methodsFor: 'skipped tests' stamp: ''!
figure: aFigureLink
	| url |
	url := aFigureLink.
	^ TextAnchor new anchoredMorph: (ZnEasy getPng: url)! !

!MicRichTextComposerTest methodsFor: 'tests - list' stamp: ''!
testNewDictionaryAPI
	
	| dict |
	dict := Dictionary newFromAssociations: { #a -> 1  . #b -> 2 }.
	self assert: (dict at: #a) equals: 1! !

!MicRichTextComposerTest methodsFor: 'tests - stylers' stamp: ''!
testStylersForText

	| defaultStyler |
	defaultStyler := self composerClass languageStylerFor: 'text'.
	self assert: defaultStyler selector equals: #textStyler:.
	 "Stylers are used for codeblock, and a test should be included for this"! !

!MicRichTextComposerTest methodsFor: 'helpers' stamp: ''!
composerClass
	^ MicRichTextComposer! !

!MicRichTextComposerTest methodsFor: 'tests - format' stamp: ''!
normalFormat
	^ TextEmphasis normal! !

!MicRichTextComposerTest methodsFor: 'helpers' stamp: ''!
assertWriting: aPRDocument include: expectedAttribute
	self assert: ((self runsOf: aPRDocument) includes: {expectedAttribute})! !

!MicRichTextComposerTest methodsFor: 'helpers' stamp: ''!
richTextForString: aString

	^ self composerClass microdownAsRichText: aString! !

!MicRichTextComposerTest methodsFor: 'tests - list' stamp: ''!
testUnorderedList 
	| source richText runs  |
	source :=  '- First item
- Second item
   on two lines
- Third item'.
	richText := self richTextForString: source.
	runs := richText runs.
	self assert: runs first first class equals: TextIndent.
	self assert: runs first first amount equals: 1.
	self assert: (runs at: 29) "the first o in 'on two lines'" first class equals: TextIndent.
	self assert: (runs at: 29) first amount equals: 2.! !

!MicRichTextComposerTest methodsFor: 'tests - format' stamp: ''!
boldFormat
	^ TextEmphasis bold! !

!MicRichTextComposerTest methodsFor: 'tests - list' stamp: ''!
testListAreCorrectlyNumbered
	| source richText |
	source :=
'1. item 1
1. other item 1
2. item 2
3. item 3
4. item 4'.
	richText := self richTextForString: source. 
	self assert: (richText asString copyFrom: 11 to: 25) equals: '2.	other item 1'.
	self assert: (richText asString copyFrom: 47 to: 55) equals: '5.	item 4'.
	! !

!MicRichTextComposerTest methodsFor: 'tests - format' stamp: ''!
superscriptFormat
	^ TextColor blue! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
testHeaderLevel5

	self 
		assertWriting: (self microElementsFrom: sample headerLevel5Sample) 
		include: self headerLevel5! !

!MicRichTextComposerTest methodsFor: 'tests - codeBlock' stamp: ''!
testCodeBlockWithCaption 
	| source runs richText |
	source := '
```caption=Roger Rabbit
line 1
line 2
```
'.
	richText := self richTextForString: source.
	runs := (richText runs ) asArray .	
	
	self assert: runs first isEmpty. 
	self assert: (runs second anySatisfy: [ :r | r class = TextIndent]).
	self assert: ((runs at: 10) includes: self boldFormat ).
	self assert: richText asString equals: '
Roger Rabbit
line 1
line 2
'! !

!MicRichTextComposerTest methodsFor: 'tests - format' stamp: ''!
monospaceFormat
	^ TextBackgroundColor color: Smalltalk ui theme settings windowColor! !

!MicRichTextComposerTest methodsFor: 'helpers' stamp: ''!
composer
	^ self composerClass new! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
headerLevel2

	^ self composerClass headerLevelFont: 2! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
testHeaderLevel2

	self 
		assertWriting: (self microElementsFrom: sample headerLevel2Sample) 
		include: self headerLevel2! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
testHeaderLevel1

	self 
		assertWriting: (self microElementsFrom: sample headerLevel1Sample) 
		include: self headerLevel1! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
testHeaderLevel6

	self 
		assertWriting: (self microElementsFrom: sample headerLevel6Sample) 
		include: self headerLevel6! !

!MicRichTextComposerTest methodsFor: 'skipped tests' stamp: ''!
testSubscriptFormat
	"Test fails: subscript isn't recognized"
	
	self assert: true.
	! !

!MicRichTextComposerTest methodsFor: 'helpers' stamp: ''!
runsOf: aDocument
	
	^ (self richTextFor: aDocument) runs! !

!MicRichTextComposerTest methodsFor: 'skipped tests' stamp: ''!
testStrikethroughFormat 
	| source runs richText |
	source := 'This have been ~deleted~'.
	richText := self richTextForString: source.
	runs := (richText runs ) asArray .
	
	self assert: runs first isEmpty. 
	self assert: ((runs at: 19 "the l in deleted") includes: self strikethroughtFormat ).
	self deny: ((runs at: 6 "the h in have") includes: self strikethroughtFormat ).! !

!MicRichTextComposerTest methodsFor: 'tests - header' stamp: ''!
headerLevel5

	^ self composerClass headerLevelFont: 5! !

!MicRichTextComposerTest methodsFor: 'skipped tests' stamp: ''!
subscriptFormat
	^ TextColor red! !

!MicRichTextComposerTest methodsFor: 'tests - paragraph' stamp: ''!
testParagraphNotFormat
	| runs richText |
	richText := self richTextFor: (self microElementsFrom: '
foo
barwith a space').
	runs := richText runs.
	self assert: (runs allSatisfy: [ :format | format = #() ] )
! !

!MicRichTextIndentBrush commentStamp: ''!
I am a Brush that paints the `TextIndent` on a `Text`. The actual value of the indent is picked up from the canvas. !
!MicRichTextIndentBrush methodsFor: 'paint' stamp: ''!
paint: aText	
	canvas nesting isZero ifFalse: [  
		aText addAttribute: (TextIndent tabs: canvas nesting) ]! !

!MicRootBlock commentStamp: ''!
I am the root of the github markup tree!
!MicRootBlock methodsFor: 'accessing' stamp: ''!
indent
	^0! !

!MicRootBlock methodsFor: 'testing' stamp: ''!
addLineAndReturnNextNode: line
	"add line to this node. 
	Notice, the action is allowed to create new nodes in the block tree.
	Returns the node to handle next line - typically self."

	| newBlock |
	newBlock := self newBlockFor: line parent: self.
	^ newBlock ! !

!MicRootBlock methodsFor: 'testing' stamp: ''!
canConsumeLine: line
	"The root block can always consume everything no matter what it is."

	^ true! !

!MicRootBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitRoot: self! !

!MicRootBlockTest commentStamp: ''!
I'm a test class for testing the behavior of MicRootBlock!
!MicRootBlockTest methodsFor: 'tests' stamp: ''!
testRootCanConsumeLine
	"a root block can consume anything"
	
	| rootNode | 
	rootNode := MicRootBlock new.
	self assert: (rootNode canConsumeLine: '#').
	self assert: (rootNode canConsumeLine: '- ')! !

!MicRootBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicRootBlock ! !

!MicSameStartStopMarkupBlock commentStamp: ''!
I'm abstract block for the logic of elements which are managed by a 

startMarkup
body 
endMarkup 

My subclass should define lineMarkup!
!MicSameStartStopMarkupBlock methodsFor: 'accessing' stamp: ''!
hasCaption
	^ arguments includesKey:  #caption! !

!MicSameStartStopMarkupBlock methodsFor: 'markups' stamp: ''!
lineStopMarkup

	^ self lineStartMarkup! !

!MicSameStartStopMarkupBlock methodsFor: 'visiting' stamp: ''!
closeMe 
	
	super closeMe.
	self arguments at: #caption 
		ifPresent: [:cp| arguments at: #caption put: (self inlineParse: cp) ]
		! !

!MicSameStartStopMarkupBlock methodsFor: 'accessing' stamp: ''!
arguments: aDictionary
	arguments := aDictionary! !

!MicSameStartStopMarkupBlock methodsFor: 'visiting' stamp: ''!
caption
	^ String streamContents: [:s |  self captionElements do: [ :each | s nextPutAll: each substring ] ]! !

!MicSameStartStopMarkupBlock methodsFor: 'visiting' stamp: ''!
captionElements
	^ arguments at: #caption ifAbsent: [ #() ]! !

!MicSameStartStopMarkupBlock methodsFor: 'accessing' stamp: ''!
argumentAssociations
	^ arguments associations! !

!MicSameStartStopMarkupBlock class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == MicSameStartStopMarkupBlock! !

!MicSemanticAction commentStamp: ''!
I'm a simple class to determine what should be done when a monospaced text is displayed.
I'm like a little interpreter that will compute the entity that should be browsed.
I only work with in image entity.


```language=PharoExpression
| sem |
sem := MicSemanticAction from: 'Point class>>#x:y:'.
sem hasEntity
>>> true
sem browse
```

The following entities can be referenced. 

- A class: `Point`
- A method `Point>>#degrees` as well as a class method `Point class>>x:y:`
- A package: `Microdown`
!
!MicSemanticAction methodsFor: 'instance creation' stamp: ''!
computeEntity
	"Try to guess what the text is:
		Point
		Point >> #setX:setY: 
		Point class >> #setX:setY: 
		#'PackageNameWithDashes'
		"
	| size |
	size := tokens size.
	size > 4 ifTrue: [  ^ self ].
	size = 0 ifTrue: [ ^ self ].
	"either 'Point' for a class or #'''System-Caching''' for a package"
	size = 1 
		ifTrue: [ self getClassOrNil
						ifNil: [self getPackageOrNil ].
					^ self  ].
	
	"only 'Point class'"
	size = 2
		ifTrue: [ self getMetaClassOrNil. ^ self ].
	
	"Point >> #setX:setY:"
	tokens second = '>>'
		ifTrue: [ self getClassOrNil. 
					 self getCompiledMethodFrom: 3  ]
				"Point class >> #x:y:"
		ifFalse: [ tokens second = 'class'
							ifTrue: [ self getMetaClassOrNil.
					 					self getCompiledMethodFrom: 4 ]
							ifFalse: [ ^ self  ] ]! !

!MicSemanticAction methodsFor: 'instance creation' stamp: ''!
getCompiledMethodFrom: start

	"
	| selector |
	selector := String streamContents: [ :str |
		start to: tokens size do: [ :each | str nextPutAll: (tokens at: each) ] ].
	^ selector
	No we do not want to support space in method selector!!
	"
	entity ifNotNil: [  
		entity 
			compiledMethodAt: (tokens at: start) 
			ifPresent: [ :cm | entity := cm ] 
			ifAbsent: [ entity := nil ] ]! !

!MicSemanticAction methodsFor: 'testing' stamp: ''!
hasEntity
	^ entity isNotNil! !

!MicSemanticAction methodsFor: 'instance creation' stamp: ''!
getClassOrNil

	self class environment 
			at: tokens first asString asSymbol  
			ifPresent: [ :cl | entity := cl ]
			ifAbsent: [ ].
	^ entity
				! !

!MicSemanticAction methodsFor: 'instance creation' stamp: ''!
getPackageOrNil
	entity := RPackageOrganizer default packageNamed: tokens first asString ifAbsent: [ nil ].
	^ entity
				! !

!MicSemanticAction methodsFor: 'accessing' stamp: ''!
entity
	^ entity! !

!MicSemanticAction methodsFor: 'instance creation' stamp: ''!
fromTokens: anArray
	
	anArray ifEmpty: [ ^ self].
	tokens := anArray.
	self computeEntity.! !

!MicSemanticAction methodsFor: 'instance creation' stamp: ''!
getMetaClassOrNil

	self class environment 
			at: tokens first asString asSymbol  
			ifPresent: [ :cl | entity := cl. 
					tokens second = 'class' 
						ifTrue: [ entity := entity class ]
						ifFalse: [ entity := nil "because we do not want Point foo" ] ]
			ifAbsent: [ ].
	^ entity
				! !

!MicSemanticAction methodsFor: 'accessing' stamp: ''!
tokens: aCol

	tokens := aCol! !

!MicSemanticAction class methodsFor: 'instance creation' stamp: ''!
from: aString 
	^ self fromTokens: (RBScanner scanTokens: aString)! !

!MicSemanticAction class methodsFor: 'instance creation' stamp: ''!
fromTokens: anArray 
	^ self new fromTokens: anArray; yourself! !

!MicSingleLineBlock commentStamp: ''!
I characterize one liners. 
They do not know consumeLine: beacuse they are composed of only one line. !
!MicSingleLineBlock methodsFor: 'public' stamp: ''!
addLineAndReturnNextNode: line
	"By default skip the rest of the line."

	^ self! !

!MicSingleLineBlock methodsFor: 'testing' stamp: ''!
canConsumeLine: line
	"return if this block can consume line"
	
	^ false ! !

!MicSlideBlock class methodsFor: 'accessing' stamp: ''!
tag

	^ #slide! !

!MicStartStopMarkupBlock commentStamp: ''!
May be in the future we will be able to say that SameMarkup is the same as a StartStop with the same delimiter but for now we do not know. !
!MicStartStopMarkupBlock methodsFor: 'handle' stamp: ''!
extractFirstLineFrom: line
	^ line copyFrom: self lineStartMarkup size + 1 to: line size! !

!MicStartStopMarkupBlock methodsFor: 'accessing' stamp: ''!
body
	^ body! !

!MicStartStopMarkupBlock methodsFor: 'testing' stamp: ''!
doesLineStartWithStopMarkup: line

	"return if the line starts with a stop markup"
	^ line beginsWith: self lineStopMarkup! !

!MicStartStopMarkupBlock methodsFor: 'initialization' stamp: ''!
initialize
	super initialize. 
	isClosed := false! !

!MicStartStopMarkupBlock methodsFor: 'testing' stamp: ''!
isClosed
	^ isClosed		! !

!MicStartStopMarkupBlock methodsFor: 'accessing' stamp: ''!
firstLine: anObject
	firstLine := anObject! !

!MicStartStopMarkupBlock methodsFor: 'testing' stamp: ''!
doesLineStartWithMarkup: line
	"return if the line starts with a markup"

	^ line beginsWith: self lineStartMarkup
	! !

!MicStartStopMarkupBlock methodsFor: 'markups' stamp: ''!
lineStartMarkup

	^ self subclassResponsibility ! !

!MicStartStopMarkupBlock methodsFor: 'markups' stamp: ''!
lineStopMarkup

	^ self subclassResponsibility ! !

!MicStartStopMarkupBlock methodsFor: 'handle' stamp: ''!
addLineAndReturnNextNode: line
	"add line to this node. 
	Notice, the action is allowed to create new nodes in the block tree.
	Returns the node to handle next line - typically self."
	
	isClosed
		ifTrue: [ ^ self ].
	firstLine
		ifNil:
			[ firstLine := self extractFirstLineFrom: line ]
		ifNotNil: [ ^ self bodyFromLine: line ].
	^ self! !

!MicStartStopMarkupBlock methodsFor: 'testing' stamp: ''!
canConsumeLine: line
	"As soon as a line closes a code block, it does not accept anymore any line.
	Indeed imagine 
	
	<
	a line 
	>
	The first line was accepted by its parent (a root block and the code block got created.
	then a line was accepted...
	then the closing line was reached and the code block got closed.)	
	"

	isClosed
		ifTrue: [ ^ false ].
	isClosed := self doesLineStartWithStopMarkup: line.
	^ true! !

!MicStartStopMarkupBlock methodsFor: 'handle' stamp: ''!
bodyFromLine: line
	self flag: #todo. 
	"I do not think that this is a good idea to use a string to represent lines.
	Especially since line contents is not interpreted - no formatting"
	
	body := body ifNil: [ line ] ifNotNil: [ body , String cr , line ]! !

!MicStartStopMarkupBlock methodsFor: 'accessing' stamp: ''!
body: anObject
	body := anObject! !

!MicStartStopMarkupBlock methodsFor: 'accessing' stamp: ''!
firstLine
	^ firstLine! !

!MicStartStopMarkupBlock class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == MicStartStopMarkupBlock! !

!MicStrikeDelimiter commentStamp: ''!
I'm the delimiter for strikethrough format.!
!MicStrikeDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ MicStrikeFormatBlock ! !

!MicStrikeDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicStrikeDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '~'! !

!MicStrikeDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ true! !

!MicStrikeDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #strike! !

!MicStrikeFormatBlock commentStamp: ''!
I represent a strike text section. I'm delimited using `~` as in `~strike~` to obtain ~strike~.!
!MicStrikeFormatBlock methodsFor: 'accessing' stamp: ''!
kind 
	^ #strike! !

!MicStrikeFormatBlock methodsFor: 'accessing' stamp: ''!
openingDelimiter

 	^ MicStrikeDelimiter markup! !

!MicStrikeFormatBlock methodsFor: 'accessing' stamp: ''!
closingDelimiter

 	^ MicStrikeDelimiter markup! !

!MicStrikeFormatBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitStrike: self! !

!MicTableBlock commentStamp: ''!
Support table with a simple and more relax setup than github.
A table is not forced to have a header definition.

```
| aaab | jkhjh |
| --- |
| bar |
```

or 
```
|aaab|jkhjh|
|---|
|bar|
```
or
```
| aaa | bbb |
|ccc |ddd |
```
or 
```
| aaa | bbb
| cc | ddd
```
Block-level elements cannot be inserted in a table.

When a table contains a header it is the first row and all rows should have that size else they are cut. 


Known limits: how to put a pipe in a table? 
No support for \|
!
!MicTableBlock methodsFor: 'testing' stamp: ''!
isHeader: line
	"Return true whether a line is a table header identification i.e., | --- | --- |"
	
	| authorised |
	authorised := {$| . $- . Character space}.
	^  line allButFirst allSatisfy: [ :each | authorised includes: each ].
	! !

!MicTableBlock methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	rows := OrderedCollection new.
	hasHeader := false! !

!MicTableBlock methodsFor: 'parse support' stamp: ''!
closeMe 

	| firstSize |
	firstSize := rows first size.
	rows := rows collect: [ :each | self cut: each toSize: firstSize ].
	rows := rows collect: [ :each | 
		        each collect: [ :e | self inlineParse: e ] ].! !

!MicTableBlock methodsFor: 'markups' stamp: ''!
lineMarkup

	^ parser tableCellMarkup! !

!MicTableBlock methodsFor: 'actions' stamp: ''!
addLineAndReturnNextNode: line
	"line is assumed to be of the form 'chararacters some text' e.g., '> some text'
	the prefix spaces after $> are removed"

	(self isHeader: line)
		ifTrue: [ hasHeader := true ]
		ifFalse: [ rows add: (self extractLine: line) ].
	! !

!MicTableBlock methodsFor: 'actions' stamp: ''!
extractLine: line
	"recondition line starts with |
	
	For now we have 
		| something | something | 
		or 
		| something | something"
		
		^ (line findBetweenSubstrings: #($|)) collect: [ :each | each trim ]
		
				
		! !

!MicTableBlock methodsFor: 'accessing' stamp: ''!
hasHeader
	^ hasHeader! !

!MicTableBlock methodsFor: 'private' stamp: ''!
cut: row toSize: firstSize

	^ row copyFrom: 1 to: ( row size min: firstSize)! !

!MicTableBlock methodsFor: 'accessing' stamp: ''!
rows
	^ rows! !

!MicTableBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitTable: self! !

!MicTextBlock commentStamp: ''!
I'm a special inline block representing the fact that there is not markup. !
!MicTextBlock methodsFor: 'accessing' stamp: ''!
kind

	^ #basic! !

!MicTextBlock methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: self substring.
! !

!MicTextBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	^ aVisitor visitText: self! !

!MicURLCloserDelimiter commentStamp: ''!
I am the closer delimiter for URL.!
!MicURLCloserDelimiter class methodsFor: 'testing' stamp: ''!
isActive
	^ false! !

!MicURLCloserDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ nil! !

!MicURLCloserDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ false! !

!MicURLCloserDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ ')'! !

!MicURLCloserDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ true! !

!MicURLCloserDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #url! !

!MicURLOpenerDelimiter commentStamp: ''!
I'm the opener delimiter for URL.!
!MicURLOpenerDelimiter class methodsFor: 'testing' stamp: ''!
isActive
	^ false! !

!MicURLOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
associatedInlineBlock
	^ nil! !

!MicURLOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isOpener
	^ true! !

!MicURLOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
markup
	^ '('! !

!MicURLOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
isCloser
	^ false! !

!MicURLOpenerDelimiter class methodsFor: 'accessing' stamp: ''!
type
	^ #url! !

!MicUnorderedListBlock commentStamp: ''!
I represent an unordered list of items.

#### Example

Typing
```
- first
- second
  on multiple line 
- third
Not in third
- first item of a new list
```

produces
- first
- second
  on multiple line 
- third
Not in third
- first item of a new list

Notice how the following line of the second item is indented with the previous one.

### Nested lists
A nested item starts aligned to its father. Below the `-` on the second level is aligned with the beginning of item1.

```
- item1
  - second level
    on two lines
- item2
```

It produces


- item1
  - second level
    on two lines
- item2

!
!MicUnorderedListBlock methodsFor: 'testing' stamp: ''!
canConsumeLine: line
	"to consume this line there must be a UnorderdListItem start at the right indentation"

	line ifEmpty: [ ^ true ].
	^ (super canConsumeLine: line) and: [line trim matchesRegex: '(^\* |^- | ^\+).*']! !

!MicUnorderedListBlock methodsFor: 'visiting' stamp: ''!
accept: aVisitor
 	^ aVisitor visitUnorderedList: self! !

!MicUnorderedListBlockTest commentStamp: ''!
I'm a test class for testing the behavior of MicUnorderedListBlock!
!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelList
	| source root list |
	source := 
'- item 1
- item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children second text equals: 'item 2'! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelListSplitWithEmptyLine
	| source root list |
	source := 
'- item 1
- item 2

- item 3 of the same list'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	"root contains a list"
	
	list := root children first.
	self assert: list children size equals: 3.
	self assert: list children first text equals: 'item 1'.
	self assert: list children third text equals: 'item 3 of the same list'.

! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testEmbeddedOrderedWithFormatting
	| source root list item4 |
	source := 
'- item 1
  1. **sublevel** ~item 1~
  4. **sublevel4** ~item 24~
- item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	
	item4 := list children first "item 1"
			children first "unordered list"
			children second.
			
	self assert: item4 text equals: 'sublevel4 item 24'.
	self assert: item4 textElements first kind equals: 'bold'.
	self assert: item4 textElements first substring equals: 'sublevel4'.

	self assert: item4 textElements third kind equals: 'strike'.
	self assert: item4 textElements third substring equals: 'item 24'.! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testEmbeddedOrdered
	| source root list |
	source := 
'- item 1
  1. sublevel item 1
  4. sublevel item 2
- item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children second text equals: 'item 2'.
	self assert: list children first "item 1"
			children first "unordered list"
			children second "sub item"
			text equals: 'sublevel item 2'! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testTwoLevelList
	| source root list |
	source := 
'- item 1
  * sublevel1
  * sublevel2
- item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children second text equals: 'item 2'.
	self assert: list children first "item 1"
			children first "unorded list"
			children first "sub item"
			text equals: 'sublevel1'.
	self assert: list children first "item 1"
			children first "unorded list"
			children second "sub item"
			text equals: 'sublevel2'
			! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testMixing2
	| source root list1 list2 |
	source := 
'
- item 1
  - sub item 1.1
  - sub item 1.2
- item 2

1. item1
   - sub item 1
   - sub item 2
3. item 2
'.
	root := parser parse: source.
	self assert: root children size equals: 2. 
	list1 := root children first.
	self assert: list1 children size equals: 2.
	self assert: list1 children second text equals: 'item 2'.
	
	list2 := root children second.
	self assert: list2 children size equals: 2.
	self assert: list2 children second text equals: 'item 2'.! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testedClass 
	^ MicUnorderedListBlock  ! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelMixedList
	| source root list |
	source := 
'- item 1
* item 2
- item 3'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 3.
	self assert: list children second text equals: 'item 2'! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelList2
	| source root list |
	source := 
'- item 1
  expanded
- item 2'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	"root contains only a list."
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children first text equals: 'item 1
expanded'! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testTwoLevelList1
	| source root list |
	source := 
'- item 1
  - sublevel
- item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children second text equals: 'item 2'.
	self assert: list children first "item 1"
			children first "unorded list"
			children first "sub item"
			text equals: 'sublevel'! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelListStartingWithoutSpaceSplitParagraph2
	| source root list |
	source := 
'- item 1
  expanded
  same indentation no new paragraph
- item 2'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	"root contains a list"
	
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children first text equals: 'item 1
expanded
same indentation no new paragraph'.
	self assert: list children second text equals: 'item 2'.

! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelListWithStar
	| source root list |
	source := 
'* item 1
* item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children second text equals: 'item 2'! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelList2WithFormatting
	| source root list |
	source := 
'- **item 1**
  `expanded`
- item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children first text equals: 'item 1
expanded'.
	self assert: list children first textElements size equals: 3.
	self assert: list children first textElements first kind equals: 'bold'.
	self assert: list children first textElements first substring equals: 'item 1'.
	self assert: list children first textElements third kind equals: 'monospace'.
	self assert: list children first textElements third substring equals: 'expanded'.! !

!MicUnorderedListBlockTest methodsFor: 'tests - nested' stamp: ''!
testNestedLevel2
	| source root list |
	source := 
'- item 1
  - sublevel
    - subsublevel
  - sublevel2
- item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	
	self assert: list children first text equals: 'item 1'.
	self assert: list children first nestedLevel equals: 1.
	
	"this is the inner list"
	self assert: list children first children first nestedLevel equals: 2.
	
	"this is the inner list first item"
	self assert: list children first children first children first text equals: 'sublevel'.
	self assert: list children first children first children first nestedLevel equals: 2.
	self assert: list children first children first children second text equals: 'sublevel2'.
	
	self assert: list children first children first children first children first nestedLevel equals: 3.
	self assert: list children first children first children first children first children first nestedLevel equals: 3.
! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelListStartingWithoutSpaceSplitParagraph
	| source root list |
	source := 
'- item 1
  expanded
and here
- item 2'.
	root := parser parse: source.
	self assert: root children size equals: 3.
	"root contains a list, a paragraph and another list"
	
	list := root children first.
	self assert: list children size equals: 1.
	self assert: list children first text equals: 'item 1
expanded'.
	self assert: root children third children first text equals: 'item 2'.

! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelListWithItemSpawning
	| root list |
	root :=  parser
		parse:
'- first item
  with a follow up 
  and another one. 
- second item
  follow up of second item'.
	list := root children first.
	self assert: list children size equals: 2.
	self assert: list children second text equals: 'second item
follow up of second item'.
	! !

!MicUnorderedListBlockTest methodsFor: 'tests - nested' stamp: ''!
testNestedLevel
	| source root list |
	source := 
'- item 1
  - sublevel
- item 2'.
	root := parser parse: source.
	list := root children first.
	self assert: list children size equals: 2.
	
	self assert: list children first text equals: 'item 1'.
	self assert: list children first nestedLevel equals: 1.
	
	"this is the inner list"
	self assert: list children first children first nestedLevel equals: 2.
	
	"this is the inner list first item"
	self assert: list children first children first children first text equals: 'sublevel'.
	self assert: list children first children first children first nestedLevel equals: 2.
	
! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testMixingOrderedInsideUnorderedWithParagraph
	| source root list1  |
	source := 
'
- item 1
  on 
  multiple lines
   1. sub item 1 
   3. sub item 2
- item 2
'.
	root := parser parse: source.
	self assert: root children size equals: 1. 
	list1 := root children first.
	self assert: list1 children size equals: 2.
	self assert: list1 children second text equals: 'item 2'.
	
	self assert: list1 children first text equals: 'item 1
on 
multiple lines
 1. sub item 1 
 3. sub item 2'.! !

!MicUnorderedListBlockTest methodsFor: 'tests' stamp: ''!
testSingleLevelListSplitWithMultipleEmptyLines
	| source root list |
	source := 
'- item 1
- item 2




- item 3 of the same list'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	"root contains a list"
	
	list := root children first.
	self assert: list children size equals: 3.
	self assert: list children first text equals: 'item 1'.
	self assert: list children third text equals: 'item 3 of the same list'.

! !

!MicroDownParser commentStamp: ''!
# Microdown Parser and Elements

I'm a parser for Microdown, implemented by S. Ducasse, L. Dargaud and G. Polito (2020). 
It is based on K. Osterbye's work on GitHubMarkdown. 

Microdown covers Markdown basis syntax, with great Pillar's features. It's more extensible too.

## MicroDown Syntax in a Nutshell!!

**Headers** (up to 6 levels) >>>> `# Header level 1`

**Unordered list**
```
- item a
  on another line
- item b
   - item b1
   - item b2
- item c
```

produces

- item a
  on another line
- item b
   - item b1
   - item b2
- item c

**Ordered list**
```
1. item one
   1. subitem
2. item two
```
produces 

1. item one
   1. subitem
2. item two


**Codeblock with arguments**
```
 ```language=Pharo&caption=Beautiful&label=Fig1
 some piece of code
 ```
```

produces 

```language=Pharo&caption=Beautiful&label=Fig1
some piece of code
```

**Anchor and its reference** >>>> `\@anchor` and its reference in text with `\*@anchor@*`

**Math environment** (rendered with LaTex in Pharo)
- inline: $\cos(\theta_i+C_3)$ >>>> `\$\cos(\theta_i+C_3)$`
- block: 
```
 $
 \cos(\theta_i+C_3)
 $
```
**Annotated paragraph**
``` 
 !!!!note Then you can write your note
 on several lines, like a normal paragraph
```
**Quote** to indent some lines
```
> This is
> A nice quote
```
**Environment** (called Annotation for inline)
- inline: `\<?keyword|key1=value1&key2=value2?>`
- block: 
```
 <?keyword|key1=value1&key2=value2
 type your content
 ?>
```
**Metadata** as a block
```
 { 
 type your metadata
 }
```

**Table** **@tocomment**

**Horizontal line** >>> `***` alone on a line will define a separator in your text **@todo**

**Comments** don't appear after parsing >>> `% A commented line`

**Inline formats**
- **bold** >>>> `**bold**`
- _italic_ >>>> `\_italic_`
- `monospace` aka inline code >>>> `\`monospace\``

_Note: inline escape character is back slash: \\ ._
_Note: text in monospace is analyzed for you to generate hypertext Pharo code objects!! Isn't it so cool to write a great doc? It is!! Click on them!!_
- `Point` for classes
- `Point class` for class side
- `Point>>#setX:setY:` for methods
- `#'Microdown-Tests'` for packages

**Raw** for your other code (inline) >>>> `\{{ some code }}`

**Link** >>>> `\[link's name](url|key1=value1&key2=value2)`

**Figure** >>>> `\!!\[figure's name](url|key1=value1&key2=value2)`

`!![Pharo logo](https://files.pharo.org/media/logo/logo.png)`
produces

!![Pharo logo](https://files.pharo.org/media/logo/logo.png)


## Implementation

I follow the design mentioned in [https://github.github.com/gfm](https://github.github.com/gfm), in particular the parsing strategy in appendix A.

In short, the strategy is that at any point in time, we might have a number of children of the root which are "open". The deepest in open in the tree is called "current". All the parents of current are open. 

When a new line is read we do the following:

1. Check if the new line can be consumed by current.
   - as part of this, a child of current can be made which can consume the new line. for example when consuming \`\`\` the root block node will create, a new code block that will become current and consume the body of the \`\`\` element then close. 
2. If current cannot consume the new line, we close current, move current to its parent, and repeat 1.
3. The root node can consume anything, for instance by making new nodes for storing the new line.
4. The root node is not closed until input is exhausted.

I do not accept lazy definition. I do not accept three different ways to do the same. Except for bulleted list where `*` and `-` are accepted. 

The spec says:
```
-> document
  -> block_quote
       paragraph
         "Lorem ipsum dolor\nsit amet."
    -> list (type=bullet tight=true bullet_char=-)
         list_item
           paragraph
             "Qui *quodsi iracundia*"
      -> list_item
        -> paragraph
             "aliquando id"
```
Now the implementation for now does not create a paragraph in the list_item element. 
!
!MicroDownParser methodsFor: 'markups' stamp: ''!
unorderedListPlusMarkup

	^ self class unorderedListPlusMarkup! !

!MicroDownParser methodsFor: 'accessing' stamp: ''!
current 

	^ current! !

!MicroDownParser methodsFor: 'parsing' stamp: ''!
parse: aStreamOrString
	"returns the root node of aStreamOrText"

	| inStream line |
	current := root := self newRootBlock
		setParser: self;
		yourself.
	inStream := aStreamOrString isStream 
		ifTrue:  [ aStreamOrString readStream ]
		ifFalse: [  aStreamOrString asString readStream ].
	[ line := inStream nextLine.
	line isNil ] whileFalse: [ self handleLine: line ].
	[ current = root ]
		whileFalse: [ current closeMe.
			current := current parent ].
	^ root! !

!MicroDownParser methodsFor: 'node creation' stamp: ''!
matchUnordered: line
	^ ( line beginsWith: self unorderedListPlusMarkup ) 
		| ( line beginsWith: self unorderedListStarMarkup ) 
		| ( line beginsWith: self unorderedListMarkup )! !

!MicroDownParser methodsFor: 'parsing' stamp: ''!
handleLine: line
	"The logic is the following: 
		-first line is cleaned to avoid noise,
		-then if the current block can consume the line, it manages it and this potentially creates a new block that becomes the current one.
		When the line is not consumed, the current block is closed and its parent becomes the current one and the process is called back to treat the line."
		
	| normalized |
	normalized := line copyReplaceAll: String tab with: String space.
	[ 
	(current canConsumeLine: normalized)
		ifTrue: [ ^ current := current addLineAndReturnNextNode: normalized ]
		ifFalse: [ current closeMe ].
	current := current parent.
	self handleLine: normalized ] on: Error do: [ self handleErrorInLine: line ]! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
annotatedParagraphMarkup
	^ self class annotatedParagraphMarkup! !

!MicroDownParser methodsFor: 'node creation' stamp: ''!
blockStarterClassFrom: line
	"return the class of a block which can start with line, or nil if none"

	line ifEmpty: [ ^ nil ].
	(self matchOrdered: line)
		ifTrue: [ ^ MicOrderedListBlock ]
		ifFalse: [ 
			"the max length of a markup is 3 even if header can be #####"
			1 to: 3 do: [:i |
				line size < i
					ifTrue: [ ^ MicParagraphBlock ].
  				dispatchTable
    		 		 at: (line first: i)
      				ifPresent: [ :blockClass | ^ blockClass ] ]].
	line 
		ifNotEmpty: [ ^ MicParagraphBlock ] 
	! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
argumentListStartDelimiter
	
	^ self class argumentListStartDelimiter! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
environmentOpeningBlockMarkup
	^ self class environmentOpeningBlockMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
mathClosingBlockMarkup
	^ self class mathClosingBlockMarkup! !

!MicroDownParser methodsFor: 'parsing' stamp: ''!
handleErrorInLine: line
		
	^ MicParsingError new 
		line: line;
		signal
	! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
metaDataClosingBlockMarkup
	^ self class metaDataClosingBlockMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
unorderedListMarkup
	^ self class unorderedListMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
unorderedListStarMarkup

	^ self class unorderedListStarMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
boldMarkup

	^ self class boldMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
anchorMarkup
	^ self class anchorMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
commentedLineMarkup

	^ self class commentedLineMarkup! !

!MicroDownParser methodsFor: 'node creation' stamp: ''!
blockStarterClassFromOld: line
	"return the class of a block which can start with line, or nil if none"

	(line beginsWith: self headerMarkup)
		ifTrue: [ ^ MicHeaderBlock ].
	(line beginsWith: self codeblockMarkup)
		ifTrue: [ ^ MicCodeBlock ].
	(self matchUnordered: line)
		ifTrue: [ ^ MicUnorderedListBlock ].
			"this one could be split if we move to a dictionary based structure"
	(self matchOrdered: line)
		ifTrue: [ ^ MicOrderedListBlock ].
				"number followed by . or ). We could treat this one separated and fall back on a dictionary By moving this into the extension for example."
	(line beginsWith: self annotatedParagraphMarkup)
		ifTrue: [ ^ MicAnnotatedBlock ].
	(line beginsWith: self anchorMarkup)
		ifTrue: [ ^ MicAnchorBlock ].
	(line beginsWith: self commentedLineMarkup)
		ifTrue: [ ^ MicCommentBlock ].
	(line beginsWith: self mathOpeningBlockMarkup)
		ifTrue: [ ^ MicMathBlock ].
	(line beginsWith: self environmentOpeningBlockMarkup)
		ifTrue: [ ^ MicEnvironmentBlock ].
	(line beginsWith: self horizontalLineMarkup)
		ifTrue: [ ^ MicHorizontalLineBlock ].
	(line beginsWith: self metaDataOpeningBlockMarkup)
		ifTrue: [ ^ MicMetaDataBlock ].
	(line beginsWith: self preformattedMarkup)
		ifTrue: [ ^ MicQuoteBlock ].	"or '> '??"
	(line beginsWith: self tableCellMarkup)
		ifTrue: [ ^ MicTableBlock ].
	line ifNotEmpty: [ ^ MicParagraphBlock ] ifEmpty: [ ^ nil ]! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
metaDataOpeningBlockMarkup
	^ self class metaDataOpeningBlockMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
orderedListSemiMarkup
	^ self class orderedListSemiMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
argumentListOfFigureStartDelimiter
	
	^ self class argumentListOfFigureStartDelimiter! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
environmentClosingBlockMarkup
	^ self class environmentClosingBlockMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
italicMarkup

	^ self class italicMarkup! !

!MicroDownParser methodsFor: 'testing' stamp: ''!
isAList: normalized
	
	^ (self matchUnordered: normalized) or: [ self matchOrdered: normalized ]! !

!MicroDownParser methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	dispatchTable := Dictionary new.
	"should use a registration with classes, but later"
	dispatchTable at: self anchorMarkup put: MicAnchorBlock.
	dispatchTable at: self headerMarkup put: MicHeaderBlock.
	dispatchTable at: self codeblockMarkup put: MicCodeBlock.
	dispatchTable at: self annotatedParagraphMarkup put: MicAnnotatedBlock.
	dispatchTable at: self commentedLineMarkup put: MicCommentBlock.
	dispatchTable at: self horizontalLineMarkup put: MicHorizontalLineBlock.
	dispatchTable at: self mathOpeningBlockMarkup put: MicMathBlock.
	dispatchTable at: self environmentOpeningBlockMarkup put: MicEnvironmentBlock.
	dispatchTable at: self metaDataOpeningBlockMarkup put: MicMetaDataBlock.
	dispatchTable at: self unorderedListPlusMarkup put: MicUnorderedListBlock.
	dispatchTable at: self unorderedListMarkup put: MicUnorderedListBlock.
	dispatchTable at: self unorderedListStarMarkup put: MicUnorderedListBlock.
	dispatchTable at: self preformattedMarkup put: MicQuoteBlock.
	dispatchTable at: self tableCellMarkup put: MicTableBlock.! !

!MicroDownParser methodsFor: 'parsing' stamp: ''!
newRootBlock
	^ MicRootBlock new! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
tableCellMarkup

	^ self class tableCellMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
codeblockMarkup 
	^ self class codeblockMarkup ! !

!MicroDownParser methodsFor: 'accessing' stamp: ''!
resolver
	^ MicPathResolver new! !

!MicroDownParser methodsFor: 'node creation' stamp: ''!
matchOrdered: line
	^ line prefixMatchesRegex: '\d+(\.|\))'! !

!MicroDownParser methodsFor: 'accessing' stamp: ''!
setCurrent: aBlock
	"aBlock parent = current 
		ifFalse: [ self error: 'When changing current, the current block should be the parent of the new one' ].
	note for me: we could just inforce this. aBlock parent: current.
	No this is not correct since 
	the parent of an item list is the list and this is the list that is parent of environment."	
	current := aBlock! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
horizontalLineMarkup
	^ self class horizontalLineMarkup! !

!MicroDownParser methodsFor: 'accessing' stamp: ''!
builder
	"return a little helper to build microdown correct expression"
	
	^ self class builder! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
headerMarkup 
	^ self class headerMarkup ! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
mathOpeningBlockMarkup
	^ self class mathOpeningBlockMarkup! !

!MicroDownParser methodsFor: 'markups' stamp: ''!
preformattedMarkup 
	^ self class preformattedMarkup ! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
preformattedMarkup

	^ '> '! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
unorderedListMarkups

	^ { self unorderedListPlusMarkup . self unorderedListMarkup . self unorderedListStarMarkup}! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
unorderedListPlusMarkup

	^ '+ '! !

!MicroDownParser class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self parse: self comment! !

!MicroDownParser class methodsFor: 'markup utils' stamp: ''!
argumentListDelimiter
	
	^ '&'! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
linkNameOpenerMarkup
	^ self inlineMarkups at: #linkNameOpener! !

!MicroDownParser class methodsFor: 'instance creation' stamp: ''!
parse: aString

	^ self new parse: aString! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
urlCloserMarkup
	^ self inlineMarkups at: #urlCloser! !

!MicroDownParser class methodsFor: 'markup utils' stamp: ''!
argumentListEqualsDelimiter
	
	^ '='! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
annotatedParagraphMarkup
	^ '!!!!'! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
mathMarkup
	^ self inlineMarkups at: #math! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
environmentOpeningBlockMarkup
	^ '<?'! !

!MicroDownParser class methodsFor: 'markup utils' stamp: ''!
argumentListStartDelimiter
	
	^ '|'! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
figureOpenerMarkup
	^ self inlineMarkups at: #figureOpener! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
linkNameCloserMarkup
	^ self inlineMarkups at: #linkNameCloser! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
inlineMarkup: aType
	^ self inlineMarkups at: aType asSymbol! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
mathClosingBlockMarkup
	
	^ '&'! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
metaDataClosingBlockMarkup
	^ '}'! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
unorderedListMarkup

	^ '- '! !

!MicroDownParser class methodsFor: 'private' stamp: ''!
allBlockNodeClasses
	^ MicAbstractBlock allSubclasses
	! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
boldMarkup
	^ self inlineMarkups at: #bold! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
anchorMarkup
	^ '@'! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
commentedLineMarkup

	^ '%'! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
strikeMarkup
	^ self inlineMarkups at: #strike! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
unorderedListStarMarkup

	^ '* '! !

!MicroDownParser class methodsFor: '*Microdown-MicrodownRichTextComposer' stamp: ''!
convertToRichText: aString
	^ MicRichTextComposer new visit: (self new parse: aString)! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
metaDataOpeningBlockMarkup
	^ '{'! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
orderedListSemiMarkup

	^ '. '! !

!MicroDownParser class methodsFor: 'markup utils' stamp: ''!
argumentListOfFigureStartDelimiter
	
	^ '?'! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
environmentClosingBlockMarkup
	^ '?>'! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
italicMarkup
	^ self inlineMarkups at: #italic! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
anchorReferenceCloserMarkup
	^ self inlineMarkups at: #anchorReferenceCloser! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
tableCellMarkup

	^ '|'! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
codeblockMarkup

	^ '```'! !

!MicroDownParser class methodsFor: 'markup utils' stamp: ''!
inlineMarkups
	^ inlineMarkups ifNil: [ 
		inlineMarkups := Dictionary new.
		MicAbstractDelimiter subclasses 
			do: [ :subclass | 
			| role |
			self flag: #fixMe. 
			"why not pushing this logic in the class themselves? Because a delimiter knows it."
			"for example for there is also a problem with escape which is neither a closer and opener"
			role := subclass isOpener 
				ifTrue: [ subclass isCloser 
								ifTrue: [ '' ] 
								ifFalse: [ 'Opener' ] ] 
				ifFalse: [ 'Closer' ].			
			inlineMarkups
				at: subclass type asString, role
				put: subclass markup ].
			^ inlineMarkups ]! !

!MicroDownParser class methodsFor: 'markup utils' stamp: ''!
resetInlineMarkups
	"self resetInlineMarkups"
	inlineMarkups := nil! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
horizontalLineMarkup
	^ '***'! !

!MicroDownParser class methodsFor: 'private' stamp: ''!
builder
	^ MicMicrodownTextualBuilder new! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
anchorReferenceOpenerMarkup
	^ self inlineMarkups at: #anchorReferenceOpener! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
headerMarkup

	^ '#'! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
urlOpenerMarkup
	^ self inlineMarkups at: #urlOpener! !

!MicroDownParser class methodsFor: 'block markups' stamp: ''!
mathOpeningBlockMarkup

	^ '&'! !

!MicroDownParser class methodsFor: 'inline block markups' stamp: ''!
monospaceMarkup
	^ self inlineMarkups at: #monospace! !

!Microdown commentStamp: ''!
I'm a kind of facade to steer Microdown services.!
!Microdown methodsFor: 'parsing' stamp: ''!
initialize 
	super initialize.
	parser := MicroDownParser new.
	 ! !

!Microdown methodsFor: 'parsing' stamp: ''!
parse: aStreamOrString

	^ parser parse: aStreamOrString! !

!Microdown methodsFor: 'resolving' stamp: ''!
resolvedTreeFromFile: aFileReference
	"This method is needed because when we resolved path we often need to know in which file a given figure or inputFile is written."
	
	file := aFileReference. 
	^ self resolvedTreeFrom: file contents! !

!Microdown methodsFor: 'parsing' stamp: ''!
resolvedTreeFrom: aStreamOrString

	| micTree |
	micTree := parser parse: aStreamOrString.
	self resolver
		microdown: self; 
		originFile: file;
		resolutionSource: self resolverRoot ;
		visit: micTree.
	^ micTree
	! !

!Microdown methodsFor: 'parsing' stamp: ''!
resolverRoot
	
	^ resolverRoot ifNil: [ resolverRoot := FileSystem workingDirectory ]! !

!Microdown methodsFor: 'parsing' stamp: ''!
resolver
	^ MicPathResolver new resolutionSource: self resolverRoot; yourself! !

!Microdown methodsFor: 'parsing' stamp: ''!
resolverRoot: root
	
	resolverRoot := root! !

!Microdown methodsFor: 'parsing' stamp: ''!
builder

	^ parser builder! !

!MicrodownBackSlasher methodsFor: 'accessing' stamp: ''!
initialize
	super initialize.
	stream := (String new: 10000) writeStream.
	allDelimiters := Dictionary new.
	self abstractDelimiterClass subclasses 
		select: [ :subclass | subclass isActive ]
		thenDo: [ :subclass | allDelimiters 
										at: subclass markup 
										put: subclass ].
	keys := allDelimiters keys.! !

!MicrodownBackSlasher methodsFor: 'accessing' stamp: ''!
abstractDelimiterClass
	^ MicAbstractDelimiter! !

!MicrodownBackSlasher methodsFor: 'accessing' stamp: ''!
contents
	^ stream contents! !

!MicrodownBackSlasher methodsFor: 'accessing' stamp: ''!
backSlashString: aString

	aString doWithIndex: [ :each :i | 

		((allDelimiters includesKey: each asString) or:
			 (allDelimiters includesKey:
				  each asString , (aString at: (i + 1 min: aString size)) asString)) 
			ifTrue: [ stream nextPutAll: '\' ].
		stream nextPutAll: each asString ].
	^ stream contents! !

!MicrodownInlineParserTest commentStamp: ''!
The logic is to call the main parser so that the inline elements are in the blocks as after the closeMe phase of a Block (this is where the inline block are parsed). !
!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testStrike

 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc~strikes~def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: 'strikes'.
 	self assert: elements second kind equals: 'strike'.
 	self assert: elements second openingDelimiter equals: '~'! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testStrikesWithoutClosure

 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc~strikesdef'.
 	self assert: elements size equals: 1.
 	self assert: elements first substring equals: 'abc~strikesdef'
! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testBoldsWithoutClosure 

 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc**boldsdef'.
 	self assert: elements size equals: 1.
 	self assert: elements first substring equals: 'abc**boldsdef'
 ! !

!MicrodownInlineParserTest methodsFor: 'tests - structure' stamp: ''!
testStructureOfBoldNestedText

 	| element |
 	element := (self parseAndReturnElementsOfParagraphFor: '**_abc_def**') first.
	self assert: element class equals: MicBoldFormatBlock.
	self assert: element substring equals: '_abc_def'.
	self assert: element children first substring equals: 'abc'.
	self assert: element children first class equals: MicItalicFormatBlock.
	self assert: element children second substring equals: 'def'.
	self assert: element children second class equals: MicTextBlock.
	self assert: element children first children first class equals: MicTextBlock.
	
	! !

!MicrodownInlineParserTest methodsFor: 'parsing' stamp: ''!
parse: aString
	"self new parse: 'foo_abbb_zz' "

	^ self parserClass parse: aString! !

!MicrodownInlineParserTest methodsFor: 'tests - raw' stamp: ''!
testRawWitoutClosure

 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc{{rawsdef'.
 	self assert: elements size equals: 1.
 	self assert: elements first substring equals: 'abc{{rawsdef'! !

!MicrodownInlineParserTest methodsFor: 'tests - raw' stamp: ''!
testRaws
	self rawTestingFor: 'anything'! !

!MicrodownInlineParserTest methodsFor: 'tests - annotations' stamp: ''!
testAnnotationPrintString
 	
	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc',MicAnnotationOpenerDelimiter markup,'footnote | value=A foonote is annotation.&width=90',MicAnnotationCloserDelimiter markup,'def'.
 	self assert: elements size equals: 3.
 	self assert: elements second text equals: 'footnote | value=A foonote is annotation.&width=90'.
	self assert: elements second name equals: 'footnote'.
	self assert: elements second arguments keys equals: #('value' 'width'). ! !

!MicrodownInlineParserTest methodsFor: 'tests - raw' stamp: ''!
testRawsWithMonospace
 	self rawTestingFor: '`monononono`'! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testItalicsAndNestedBolds
 	| elements |
 	elements := (self parseAndReturnElementsOfParagraphFor: 'abc_**italics**_def').
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: '**italics**'.
 	self assert: elements second kind equals: 'italic'.
 	self assert: elements second openingDelimiter equals: '_'! !

!MicrodownInlineParserTest methodsFor: 'tests to make green' stamp: ''!
testRawsDoesNotHandleWellEscape
	self skip.
	self rawTestingFor: 'anything\*foo'.
	! !

!MicrodownInlineParserTest methodsFor: 'tests - raw' stamp: ''!
rawTestingFor: aString

 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc{{', aString, '}}def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: aString.
 	self assert: elements second kind equals: 'raw'.
 	self assert: elements second openingDelimiter equals: '{{'.
 	self assert: elements second closingDelimiter equals: '}}'! !

!MicrodownInlineParserTest methodsFor: 'tests - structure' stamp: ''!
testStructureOfBoldSimpleText

 	| element |
 	element := (self parseAndReturnElementsOfParagraphFor: '**abc def**') first.
	self assert: element class equals: MicBoldFormatBlock.
	self assert: element substring equals: 'abc def'.
	self assert: element children size equals: 1.
	self assert: element children first class equals: MicTextBlock.
	! !

!MicrodownInlineParserTest methodsFor: 'tests - link' stamp: ''!
testLink
 	| elements |
 	elements := (self parseAndReturnElementsOfParagraphFor: 'abc[Pharo.Org](http://www.pharo.org)def').
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
	
 	self assert: elements second caption equals: 'Pharo.Org'.
 	self assert: elements second kind equals: 'linkName'.
	self assert: elements second url printString equals: 'http://www.pharo.org'.
	
	
 	self assert: elements second openingDelimiter equals: '['.
 	self assert: elements second closingDelimiter equals: ')'! !

!MicrodownInlineParserTest methodsFor: 'parsing' stamp: ''!
parser
	^ self parserClass new ! !

!MicrodownInlineParserTest methodsFor: 'tests - structure' stamp: ''!
testStructureOfPlainText

 	| element |
 	element := (self parseAndReturnElementsOfParagraphFor: 'abc') first.
	self assert: element text equals: 'abc'.
	self assert: element class equals: MicTextBlock.
	self assert: element children equals: #()! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testMonospacesWithoutClosure
 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc`monospacesdef'.
 	self assert: elements size equals: 1.
 	self assert: elements first substring equals: 'abc`monospacesdef'
! !

!MicrodownInlineParserTest methodsFor: 'tests - figure' stamp: ''!
testFigure
 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc!![caption](http://www.pharo.org?parameters=value)def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second caption equals: 'caption'.
 	self assert: elements second kind equals: 'figure'.
 	self assert: elements second openingDelimiter equals: '!!['.
 	self assert: elements second closingDelimiter equals: ')'! !

!MicrodownInlineParserTest methodsFor: 'tests - figure' stamp: ''!
testFigureWithParameters

	| elements figure |
	elements := self parseAndReturnElementsOfParagraphFor:
		            '!![caption terminating with a .](http://www.pharo.org/pharoLogo.png?micAnchor=fig2&micWidth=80)'.
	self assert: elements size equals: 1.
	figure := elements first.
	self assert: figure caption equals: 'caption terminating with a .'.
	self assert: figure captionElements first text equals: 'caption terminating with a .'.
	self assert: figure arguments keys size equals: 2! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testItalic
 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc_italics_def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: 'italics'.
 	self assert: elements second kind equals: 'italic'.
 	self assert: elements second openingDelimiter equals: '_'! !

!MicrodownInlineParserTest methodsFor: 'tests - structure' stamp: ''!
testStructureOfAnchorReference

 	| element |
 	element := (self parseAndReturnElementsOfParagraphFor: '  *@anchorReference@*') first.
	self assert: element text equals: 'anchorReference'.
	self assert: element children equals: #()
	! !

!MicrodownInlineParserTest methodsFor: 'parsing' stamp: ''!
parserClass 
	^ MicroDownParser ! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testItalicsAndNestedBoldsWithClosureAfterOpenBolds

 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc_**italics_**def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: '**italics'.
	self assert: elements third substring equals: '**def'.
 	self assert: elements second kind equals: 'italic'.
 	self assert: elements second openingDelimiter equals: '_'
 ! !

!MicrodownInlineParserTest methodsFor: 'tests - annotations' stamp: ''!
testAnnotationsWithoutClosure
 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc<?footnote | value=A foonote is anannotation.def'.
 	self assert: elements size equals: 1.
 	self assert: elements first substring equals: 'abc<?footnote | value=A foonote is anannotation.def'
 ! !

!MicrodownInlineParserTest methodsFor: 'parsing' stamp: ''!
parseAndReturnElementsOfParagraphFor: aString 
 	"self new parse: 'foo_abbb_zz' "
	
 	^ (self parse: aString) children first children
 ! !

!MicrodownInlineParserTest methodsFor: 'tests' stamp: ''!
testEscapeAsLastCharacterDoesNotBreak
	
	| elts  |
	elts  := self parseAndReturnElementsOfParagraphFor:  'ch\'.
	self assert: elts size equals: 1.
	self assert: elts first class  equals: MicTextBlock.
	self assert: elts first substring  equals: 'ch\'.
	
	elts  := self parseAndReturnElementsOfParagraphFor:  'ch\\'.
	self assert: elts size equals: 1.
	self assert: elts first class  equals: MicTextBlock.
	self assert: elts first substring  equals: 'ch\\'.
	
	elts  := self parseAndReturnElementsOfParagraphFor:  'ch\a'.
	self assert: elts size equals: 1.
	self assert: elts first class  equals: MicTextBlock.
	self assert: elts first substring  equals: 'cha'.! !

!MicrodownInlineParserTest methodsFor: 'tests - link' stamp: ''!
testLinkWithParameters
 	| elements |
 	elements := (self parseAndReturnElementsOfParagraphFor: 'abc[GH Ducasse](https://github.com/Ducasse?tab=repositories)def').
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: 'GH Ducasse'.
 	self assert: elements second kind equals: 'linkName'.
	
	self assert: elements second url printString equals: 'https://github.com/Ducasse?tab=repositories'.
	
 	self assert: elements second openingDelimiter equals: '['.
 	self assert: elements second closingDelimiter equals: ')'! !

!MicrodownInlineParserTest methodsFor: 'tests - others' stamp: ''!
testEscape

 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc\_bolds_def'.
 	self assert: elements size equals: 1.
 	self assert: elements first substring equals: 'abc_bolds_def'.
 	self assert: elements first kind equals: 'basic'.
 ! !

!MicrodownInlineParserTest methodsFor: 'tests - raw' stamp: ''!
testRawsWithBold

 	self rawTestingFor: '**bold**'! !

!MicrodownInlineParserTest methodsFor: 'tests - anchors' stamp: ''!
testAnchorRefernce
 	| elements |
 	elements := (self parseAndReturnElementsOfParagraphFor: 'abc*@anchors@*def').
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: 'anchors'.
 	self assert: elements second kind equals: 'anchorReference'.
 	self assert: elements second openingDelimiter equals: '*@'.
 	self assert: elements second closingDelimiter equals: '@*'! !

!MicrodownInlineParserTest methodsFor: 'tests - annotations' stamp: ''!
testAnnotationBasic
 	| elements annotation |
 	elements := self parseAndReturnElementsOfParagraphFor: 'needed ', MicAnnotationOpenerDelimiter markup ,'footnote | value=A foonote is annotation.', MicAnnotationCloserDelimiter markup.
	"pay attention an annotation is inside a paragraph (else this is an environment)"
	annotation := elements second.
	
 	self assert: annotation substring equals: 'footnote | value=A foonote is annotation.'.
	
 	self assert: annotation kind equals: 'annotation'.
 	self assert: annotation openingDelimiter equals: MicAnnotationOpenerDelimiter markup.
 	self assert: annotation closingDelimiter equals: MicAnnotationCloserDelimiter markup
 ! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testBoldsAndCorrectNestedItalics

 	| elements bold italic |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc**_italicitalic_**def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
	bold := elements second.
	italic := bold children first.
	self assert: bold kind equals: 'bold'.
	self assert: italic kind equals: 'italic'.
		
 	self assert: italic substring equals: 'italicitalic'.
	self flag: #fixme. 
	"self assert: bold substring equals: 'italicitalic'"
 	
	

 ! !

!MicrodownInlineParserTest methodsFor: 'tests - raw' stamp: ''!
testRawsDoesNotHandleWellCurly
	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc{{', 'anything}', '}}def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: 'anything'.
	self assert: elements third substring equals: '}def'.
 	self assert: elements second kind equals: 'raw'.
 	self assert: elements second openingDelimiter equals: '{{'.
 	self assert: elements second closingDelimiter equals: '}}'
	! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testMonospace

 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc`monospaces`def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: 'monospaces'.
 	self assert: elements second kind equals: 'monospace'.
 	self assert: elements second openingDelimiter equals: '`'
! !

!MicrodownInlineParserTest methodsFor: 'tests - annotations' stamp: ''!
testAnnotations
 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc',MicAnnotationOpenerDelimiter markup,'footnote | value=A foonote is annotation.',MicAnnotationCloserDelimiter markup,'def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: 'footnote | value=A foonote is annotation.'.
 	self assert: elements second kind equals: 'annotation'.
 	self assert: elements second openingDelimiter equals: MicAnnotationOpenerDelimiter markup.
 	self assert: elements second closingDelimiter equals: MicAnnotationCloserDelimiter markup
 ! !

!MicrodownInlineParserTest methodsFor: 'tests - anchors' stamp: ''!
testAnchorReferenceWithoutClosure
 	| elements |
 	elements := (self parseAndReturnElementsOfParagraphFor: 'abc*@anchorsdef').
 	self assert: elements size equals: 1.
 	self assert: elements first substring equals: 'abc*@anchorsdef'! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testAPIToAccessChildrenOfNestedElements

 	| elements bold |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc**_italicAndBold_ boldOnly**def'.
 	self assert: elements size equals: 3.

	"we can ask text to any element" 
	self assert: elements first substring equals: 'abc'.
	self assert: elements first text equals: 'abc'.
	
	bold := elements second.
	self assert: bold class equals: MicBoldFormatBlock.
	self assert: bold children size equals: 2.
	self assert: bold children first class equals: MicItalicFormatBlock.
	self assert: bold children first children first class equals: MicTextBlock.
	self assert: bold children second text equals: ' boldOnly'.
	self assert: bold children second class equals: MicTextBlock.! !

!MicrodownInlineParserTest methodsFor: 'tests - raw' stamp: ''!
testRawsWithStrike
 	self rawTestingFor: '~strikkkkk~'! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testBold
 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc**bolds**def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
	self assert: elements first class equals: MicTextBlock.
	
 	self assert: elements second substring equals: 'bolds'.
	self assert: elements second class equals: MicBoldFormatBlock.
 	self assert: elements second kind equals: 'bold'.
	self assert: elements second children first class equals: MicTextBlock.
	
 	self assert: elements second openingDelimiter equals: '**'
 ! !

!MicrodownInlineParserTest methodsFor: 'tests - structure' stamp: ''!
testStructureOfAnnotation

 	| element |
 	element := (self parseAndReturnElementsOfParagraphFor: MicAnnotationOpenerDelimiter markup , 'annotation' , MicAnnotationCloserDelimiter markup ) first.
	self assert: element text equals: 'annotation'.
	self assert: element name equals: 'annotation'.
	self assert: element children equals: #()
	! !

!MicrodownInlineParserTest methodsFor: 'tests - others' stamp: ''!
testMath
 	| elements |
 	elements := (self parseAndReturnElementsOfParagraphFor: 'abc$V_i = C_0 - C_3$def').
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: 'V_i = C_0 - C_3'.
 	self assert: elements second kind equals: 'math'.
 	self assert: elements second openingDelimiter equals: '$'! !

!MicrodownInlineParserTest methodsFor: 'tests - structure' stamp: ''!
testStructureOfAnnotationWithParameters

 	| element |
 	element := (self parseAndReturnElementsOfParagraphFor: MicAnnotationOpenerDelimiter markup , 'inputFile|path=PharoTour.mic' , MicAnnotationCloserDelimiter markup ) first.
	self assert: element name equals: 'inputFile'.
	self assert: element children equals: #().
	self assert: element text equals: 'inputFile|path=PharoTour.mic'.
	self assert: (element arguments at: 'path') equals: 'PharoTour.mic'
	! !

!MicrodownInlineParserTest methodsFor: 'tests - raw' stamp: ''!
testRawsHandleWellCurlyIfNotLast
	
	self rawTestingFor: 'anything}88'.
! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testBoldsAndNestedItalicsWithClosureAfterOpenItalics

 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc**_bolds**_def'.
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: '_bolds'.
	self assert: elements third substring equals: '_def'.
 	self assert: elements second kind equals: 'bold'.
 	self assert: elements second openingDelimiter equals: '**'
 ! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testItalicsWithoutClosure

 	| elements |
 	elements := self parseAndReturnElementsOfParagraphFor: 'abc_italicsdef'.
 	self assert: elements size equals: 1.
 	self assert: elements first substring equals: 'abc_italicsdef'! !

!MicrodownInlineParserTest methodsFor: 'tests - raw' stamp: ''!
testRawsWithItalic

 	self rawTestingFor: '_italic_'! !

!MicrodownInlineParserTest methodsFor: 'tests - format' stamp: ''!
testBoldsAndNestedItalics 
 	| elements |
 	elements := (self parseAndReturnElementsOfParagraphFor: 'abc**_bolds_**def').
 	self assert: elements size equals: 3.
 	self assert: elements first substring equals: 'abc'.
 	self assert: elements second substring equals: '_bolds_'.
 	self assert: elements second kind equals: 'bold'.
 	self assert: elements second openingDelimiter equals: '**'
 ! !

!MicrodownParserTest methodsFor: 'tests - table' stamp: ''!
testSimpleTable

	| mic |
	mic := (parser parse: '

| aaab | jkhjh |
| --- | --- |
| bar | rab |

') children first.
	self assert: mic class equals: MicTableBlock.
	self assert: mic rows size equals: 2.
	self assert: mic rows first size equals: 2.
	self assert: mic rows first first first class equals: MicTextBlock! !

!MicrodownParserTest methodsFor: 'tests - metaData' stamp: ''!
testMetaDataMultipleLines

	| source root metadata |
	source := parser metaDataOpeningBlockMarkup , String cr, 
	 '"author": "S Ducasse",', String cr,
	 '"title": "Ze Great Book from Frenchies"', String cr,
	parser metaDataClosingBlockMarkup, String cr.

	root :=  parser parse: source.
	self assert: root children size equals: 1.
	metadata := root children first. 
	self assert: (metadata isKindOf: MicMetaDataBlock). 
	self assert: metadata body equals: '"author": "S Ducasse",
"title": "Ze Great Book from Frenchies"'
	"note that the closing is not part of the body"
	! !

!MicrodownParserTest methodsFor: 'tests - table' stamp: ''!
testSimpleTableWithFormattingWithSomeElements

	| mic |
	mic := (parser parse: '

| **aaab** bbbc _cccd_| jkhjh |
| --- | --- |
| bar | rab |

') children first.
	self assert: mic class equals: MicTableBlock.
	self assert: mic rows size equals: 2.
	self assert: mic rows first size equals: 2.
	self
		assert: mic rows first first first class
		equals: MicBoldFormatBlock.
	self assert: mic rows first first second class equals: MicTextBlock.
	self
		assert: mic rows first first third class
		equals: MicItalicFormatBlock! !

!MicrodownParserTest methodsFor: 'tests - annotated-paragraph' stamp: ''!
testAnnotatedBlockOnMultipleLinesParserLogic

	| source root annotated  line |
	source := (parser annotatedParagraphMarkup , 'important this is an 
important point because...!!') readStream.
	
	"first the root block"
	root := parser parse: ''.
	self assert: parser current equals: root. 
	
	"second the annotated"
	annotated := parser handleLine: source nextLine.
	self assert: parser current equals: annotated.
	self assert: annotated parent equals: root.  
	
	self assert: annotated label equals: 'important'.
	self assert: (annotated instVarNamed: 'body') equals: 'this is an'.
	
	"third the second line"
	line := source nextLine.
	self assert: (annotated canConsumeLine: line).
	annotated := parser handleLine: line.
	self assert: parser current equals: annotated.
	self assert: (annotated instVarNamed: 'body') equals: 'this is an
important point because...!!'.
	! !

!MicrodownParserTest methodsFor: 'tests - metaData' stamp: ''!
testMetaData

	| source root math |
	source := parser metaDataOpeningBlockMarkup , String cr, 
	 '"author": "S Ducasse"', String cr,
	parser metaDataClosingBlockMarkup, String cr.

	root :=  parser parse: source.
	self assert: root children size equals: 1.
	math := root children first. 
	self assert: (math isKindOf: MicMetaDataBlock). 
	self assert: math body equals: '"author": "S Ducasse"'
	"note that the closing is not part of the body"
	! !

!MicrodownParserTest methodsFor: 'tests' stamp: ''!
testEnvironmentCitationWithArguments
	| source root environmentName contents child |
	environmentName := 'cite'.
	contents := 'Hello
Pharo'.

	source := parser environmentOpeningBlockMarkup, environmentName, parser argumentListStartDelimiter, 'a=1&b=17&c'
		, String cr , contents , String cr, String cr, 
		parser environmentClosingBlockMarkup , String cr.
	root := parser parse: source.
	child := root children first.
	self assert: (child isKindOf: MicEnvironmentBlock).
	self assert: child name equals: environmentName.
	self assert: child children first text equals: contents.
	
	self assert: (child arguments at: 'a') equals: '1'.
	self assert: (child arguments at: 'b') equals: '17'.
	self assert: (child arguments at: 'c') equals: nil! !

!MicrodownParserTest methodsFor: 'tests - horizontal line' stamp: ''!
testParseLineWithTwoCharacters 
	
	| document |
	document := parser parse: '
aa'.
	self assert: document children size equals: 1. 
	self assert: document children first class equals: MicParagraphBlock. 
	! !

!MicrodownParserTest methodsFor: 'tests - comments' stamp: ''!
testCommentedLineMarkupInsideLine

	| source root paragraph |
	source := 'this is not the start', parser commentedLineMarkup , 'a comment'.
	root :=  parser parse: source.
	self assert: root children size equals: 1.
	paragraph := root children first. 
	self assert: (paragraph isKindOf: MicParagraphBlock).
	self assert: paragraph text equals: 'this is not the start', parser commentedLineMarkup , 'a comment'
	! !

!MicrodownParserTest methodsFor: 'tests - header' stamp: ''!
testHeaderLevel4
	| source root |
	source := (self parser headerMarkup repeat: 4), '    Level four'.
	root := self parser parse: source.
	self assert: root children size equals: 1.
	self assert: root children first header equals: 'Level four'.
	self assert: root children first level equals: 4! !

!MicrodownParserTest methodsFor: 'tests - environment' stamp: ''!
testEnvironmentEatsNonClosedCodeMarkup
	| source root env environmentName contents |
	environmentName := 'card'.
	contents := '- smalltalk
^ self foo

this is the end.'.
	source := parser environmentOpeningBlockMarkup , environmentName
		, String cr , contents , String cr.
	root := parser parse: source.
	self assert: root children size equals: 1.
	env := root children first.
	self assert: (env isKindOf: MicEnvironmentBlock).
	self assert: env name equals: environmentName.
	self assert: env children size equals: 3.
	self assert: env children third text equals: 'this is the end.'.
	! !

!MicrodownParserTest methodsFor: 'tests - metaData' stamp: ''!
testMetaData2

	| source root metadata |
	source := '{
"authors" : "S. Ducasse" ,
"title" : "Pharo by Example"
}'.

	root :=  parser parse: source.
	self assert: root children size equals: 1.
	metadata := root children first. 
	self assert: (metadata isKindOf: MicMetaDataBlock). 
	self assert: metadata body equals: '"authors" : "S. Ducasse" ,
"title" : "Pharo by Example"'
	"note that the closing is not part of the body"
	! !

!MicrodownParserTest methodsFor: 'running' stamp: ''!
parser 

	^ MicroDownParser new! !

!MicrodownParserTest methodsFor: 'tests - comments' stamp: ''!
testCommentOnMultipleLines

	| source root comment |
	source := parser commentedLineMarkup , 'a comment', String cr.
	source := source, parser commentedLineMarkup , 'a second comment'.
	root :=  parser parse: source.
	self assert: root children size equals: 1.
	comment := root children first. 
	self assert: comment text equals: 'a comment
a second comment'
	! !

!MicrodownParserTest methodsFor: 'tests - horizontal' stamp: ''!
testHorizontalBlock

	| source root horizontal |
	source := parser horizontalLineMarkup, 'ignored ignored ignore', String cr.
	root :=  parser parse: source.
	self assert: root children size equals: 1.
	horizontal := root children first. 
	self assert: (horizontal isKindOf: MicHorizontalLineBlock). 
	! !

!MicrodownParserTest methodsFor: 'tests - math' stamp: ''!
testMathBlock

	| source root math |
	source := parser mathOpeningBlockMarkup , String cr, 
	 '\mathcal{F} = \{ I \subseteq B | support(I) \geq minsup \}', String cr,
	parser mathClosingBlockMarkup, String cr.

	root :=  parser parse: source.
	self assert: root children size equals: 1.
	math := root children first. 
	self assert: (math isKindOf: MicMathBlock). 
	self assert: math body equals: '\mathcal{F} = \{ I \subseteq B | support(I) \geq minsup \}'
	! !

!MicrodownParserTest methodsFor: 'tests - horizontal line' stamp: ''!
testParseLineWithOneCharacter 
	
	| document |
	document := parser parse: '
a'.
	self assert: document children size equals: 1. 
	self assert: document children first class equals: MicParagraphBlock. 
	! !

!MicrodownParserTest methodsFor: 'tests - comments' stamp: ''!
testTwoCommentBlock
	| source root |
	source := '% test1
% test 2'.
	root := parser parse: source.

	self assert: root children first class equals: MicCommentBlock.
	self assert: root children first text equals: 'test1
test 2'! !

!MicrodownParserTest methodsFor: 'tests - annotated-paragraph' stamp: ''!
testAnnotatedBlockWithListParserLogic
	"The test does not test what we want. We want a listblock inside the annotatedBlock"
	|  source root annotated  line |
	self flag: #fixme.
	source := (parser annotatedParagraphMarkup , 'important this is a point
- one
* two ' ) readStream.

 	parser := self parser. 
	
	"first the root block"
	root := parser parse: ''.
	self assert: parser current equals: root. 
	
	"second the annotated"
	annotated := parser handleLine: source nextLine.
	self assert: parser current equals: annotated.
	self assert: annotated parent equals: root.  
	
	self assert: annotated label equals: 'important'.
	self assert: (annotated instVarNamed: 'body') equals: 'this is a point'.
	
	"third the second line"
	line := source nextLine.
	
	self assert: (annotated canConsumeLine: line).
	annotated := parser handleLine: line.
	self assert: parser current equals: annotated.
	self assert: (annotated instVarNamed: 'body') equals: 'this is a point
- one'.

! !

!MicrodownParserTest methodsFor: 'tests - error' stamp: ''!
testError
	self skip. 
	"see if we have an error"
	self should: [ parser parse: '

| aaab | jkhjh |
| --- |
| bar |

'
	] raise: MicParsingError 
	! !

!MicrodownParserTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
	
	super setUp.
	parser := self parser! !

!MicrodownParserTest methodsFor: 'tests - table' stamp: ''!
testSimpleTableWithMoreLongRow

	| mic |
	mic := (parser parse: '

| aaab | jkhjh |
| --- | --- |
| bar | rab | long |

') children first.
	self assert: mic class equals: MicTableBlock.
	self assert: mic rows size equals: 2.
	self assert: mic rows first size equals: 2.
	self assert: mic rows first first first class equals: MicTextBlock! !

!MicrodownParserTest methodsFor: 'tests' stamp: ''!
testParseText
	
	| mic |
	mic := parser parse: 'this is a paragraph
```
this is a code block
```'  asText.
	self assert: mic children size equals: 2.
	self assert: mic children first class equals: MicParagraphBlock.
	self assert: mic children first text equals: 'this is a paragraph'.
	self assert: mic children second class equals: MicCodeBlock.
	self assert: mic children second body equals: 'this is a code block'! !

!MicrodownParserTest methodsFor: 'tests - comments' stamp: ''!
testCommentOnMultipleLinesWithASingleMarkup

	| source root comment |
	source := parser commentedLineMarkup , 'a comment', String cr.
	source := source, 'a second comment'.
	root :=  parser parse: source.
	"we have two commented lines."
	
	self assert: root children size equals: 2.
	comment := root children first. 
	self assert: comment text equals: 'a comment'.
	self assert: root children second text equals: 'a second comment'
	! !

!MicrodownParserTest methodsFor: 'tests - anchor' stamp: ''!
testAnchorBlockFollowingEachOther

	| source root annotated |
	source := parser anchorMarkup, 'label1', String cr.
	source := source, parser anchorMarkup, 'label2'.
	root := parser parse: source.
	self assert: root children size equals: 2.
	annotated := root children first. 
	self assert: annotated label equals: 'label1'.
	
	annotated := root children second. 
	self assert: annotated label equals: 'label2'.
	
! !

!MicrodownParserTest methodsFor: 'tests - comments' stamp: ''!
testCommentSimple

	| source root comment |
	source := parser commentedLineMarkup , 'a comment'.
	root :=  parser parse: source.
	self assert: root children size equals: 1.
	comment := root children first. 
	self assert: comment text equals: 'a comment'
	! !

!MicrodownParserTest methodsFor: 'tests - horizontal line' stamp: ''!
testHorizontalLineBlock
	| source root horizontal |
	source := parser horizontalLineMarkup, 'label1'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	horizontal := root children first. 
	self assert: (horizontal isKindOf: MicHorizontalLineBlock)
	
	



! !

!MicrodownParserTest methodsFor: 'tests - breaking class comments' stamp: ''!
testRBPatternVariableNode
	| paragraph1 paragraph2 paragraph3 |
	
	paragraph1 := parser parse: '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 a list of statements. Combining the @ with the # is not supported.'.
	
	paragraph2 :=  parser parse: '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").
'.
	paragraph3 := parser parse: 'Instance Variables:
	isAnything	<Boolean>	can we match any type of node
	isList	<Boolean>	can we match a list of items (@)
	isLiteral	<Boolean>	only match a literal node (#)
	isStatement	<Boolean>	only match statements (.)
	recurseInto	<Boolean>	search for more matches in the node we match (`)

'! !

!MicrodownParserTest methodsFor: 'tests - annotated-paragraph' stamp: ''!
testAnnotatedBlockOnTwoLinesWithFormatting
	| source root annotated |
	source := parser annotatedParagraphMarkup , 'important **this** is an _important_ 
paragraph on two lines.'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	annotated := root children first. 
	self assert: annotated label equals: 'important'.
	self assert: annotated text equals: 'this is an important
paragraph on two lines.'.
	self assert: annotated textElements first kind equals: 'bold'.
	self assert: annotated textElements third kind equals: 'italic'.! !

!MicrodownParserTest methodsFor: 'tests - anchor' stamp: ''!
testAnchorBlock
	| source root annotated |
	source := parser anchorMarkup, 'label1'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	annotated := root children first. 
	self assert: annotated label equals: 'label1'.
	
! !

!MicrodownParserTest methodsFor: 'tests - math' stamp: ''!
testMathBlockOnMulitpleLines

	| source root math |
	source := parser mathOpeningBlockMarkup , String cr, 
	 '\mathcal{F} = \{ I \subseteq B |', String cr, 'support(I) \geq minsup \}', String cr,
	parser mathClosingBlockMarkup, String cr.

	root :=  parser parse: source.
	self assert: root children size equals: 1.
	math := root children first. 
	self assert: (math isKindOf: MicMathBlock). 
	self assert: math body equals: '\mathcal{F} = \{ I \subseteq B |
support(I) \geq minsup \}'
	! !

!MicrodownParserTest methodsFor: 'tests - annotated-paragraph' stamp: ''!
testAnnotatedBlockTextElements

	| source root annotated |
	source := parser annotatedParagraphMarkup , 'important this is an **important** paragraph on one line.'.
	root :=  parser parse: source.
	self assert: root children size equals: 1.
	annotated := root children first. 
	self assert: root children first textElements first class equals: MicTextBlock.
	self assert: root children first textElements second class equals: MicBoldFormatBlock.
	self assert: root children first textElements third class equals: MicTextBlock
	
! !

!MicrodownParserTest methodsFor: 'tests - horizontal line' stamp: ''!
testParseLineWithThreeCharacters 
	
	| document |
	document := parser parse: '
a`a'.
	self assert: document children size equals: 1. 
	self assert: document children first class equals: MicParagraphBlock. 
	! !

!MicrodownParserTest methodsFor: 'tests - anchor' stamp: ''!
testAnchorMarkupInsideLine

	| source root paragraph |
	source := 'this is not an anchor', parser anchorMarkup, 'label1'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	paragraph := root children first. 
	self assert: (paragraph isKindOf: MicParagraphBlock).
	self assert: paragraph text equals: 'this is not an anchor', parser anchorMarkup, 'label1'.
	
! !

!MicrodownParserTest methodsFor: 'tests - metaData' stamp: ''!
testMetaDataEatsOtherBlocks

	| source root metadata |
	source := parser metaDataOpeningBlockMarkup , String cr, 
	 '"author": "S Ducasse"', String cr,
	parser headerMarkup, 'newheader here'.
	root :=  parser parse: source.
	self assert: root children size equals: 1.
	metadata := root children first. 
	self assert: (metadata isKindOf: MicMetaDataBlock). 
	self assert: metadata body equals: '"author": "S Ducasse"',String cr, parser headerMarkup, 'newheader here'.
	! !

!MicrodownParserTest methodsFor: 'tests - path' stamp: ''!
testParseEmpty

	| file system mic |
	system := FileSystem memory workingDirectory.
	file := system / 'test.mic'.
	(system / 'folder') createDirectory.
	file := system / 'folder/file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: '' ].
	mic := parser parse: file asFileReference contents.
	self assert: mic children isEmpty. 
	self assert: (mic isKindOf: MicRootBlock)! !

!MicrodownParserTest methodsFor: 'tests - annotated-paragraph' stamp: ''!
testAnnotatedBlock

	| source root annotated |
	source := parser annotatedParagraphMarkup , 'important this is an important paragraph on one line.'.
	root :=  parser parse: source.
	self assert: root children size equals: 1.
	annotated := root children first. 
	self assert: annotated label equals: 'important'.
	self assert: annotated text equals: 'this is an important paragraph on one line.'
	
! !

!MicrodownParserTest methodsFor: 'tests - table' stamp: ''!
testSimpleTableWithShortRow

	| mic |
	mic := (parser parse: '

| aaab | jkhjh |
| --- | --- |
| bar |

') children first.
	self assert: mic class equals: MicTableBlock.
	self assert: mic rows size equals: 2.
	self assert: mic rows first size equals: 2.
	self assert: mic rows first first first class equals: MicTextBlock! !

!MicrodownParserTest methodsFor: 'tests - math' stamp: ''!
testMathBlockWithArguments

	| source root math |
	source := parser mathOpeningBlockMarkup, 'label=equation&caption=doNiceMath' , String cr, 
	 '\mathcal{F} = \{ I \subseteq B | support(I) \geq minsup \}', String cr,
	parser mathClosingBlockMarkup, String cr.

	root :=  parser parse: source.
	self assert: root children size equals: 1.
	math := root children first.
	self assert: (math arguments at: 'label') equals: 'equation'.
	self assert: (math arguments at: 'caption') first substring equals: 'doNiceMath'! !

!MicrodownParserTest methodsFor: 'tests - annotated-paragraph' stamp: ''!
testAnnotatedBlockOnTwoLines
	| source root annotated |
	source := parser annotatedParagraphMarkup , 'important this is an important 
paragraph on two lines.'.
	root := parser parse: source.
	self assert: root children size equals: 1.
	annotated := root children first. 
	self assert: annotated label equals: 'important'.
	self assert: annotated text equals: 'this is an important
paragraph on two lines.'
! !

!MicrodownParserTest methodsFor: 'tests - header' stamp: ''!
testHeaderLevel4WithBold

	| source root |
	source := (self parser headerMarkup repeat: 4), 'Level **four** `mono` end'.
	root := self parser parse: source.
	self assert: root children size equals: 1.
	self assert: root children first children first substring equals: 'Level '.
	self assert: root children first children second substring equals: 'four'.
	self assert: root children first children third substring equals: ' '.
	self assert: root children first children fourth substring equals: 'mono'.
	self assert: root children first children fifth substring equals: ' end'.
	self assert: root children first level equals: 4.! !

!MicrodownParserTest methodsFor: 'tests - table' stamp: ''!
testSimpleTableWithFormatting

	| mic |
	mic := (parser parse: '

| **aaab** | jkhjh |
| --- | --- |
| bar | rab |

') children first.
	self assert: mic class equals: MicTableBlock.
	self assert: mic rows size equals: 2.
	self assert: mic rows first size equals: 2.
	self assert: mic rows first first first class equals: MicBoldFormatBlock! !

!MicrodownParserTest methodsFor: 'tests - horizontal' stamp: ''!
testHorizontalBlockFollowedByList

	| source root horizontal |
	source := parser horizontalLineMarkup, 'ignored ignored ignore', String cr, '- item1'.
	root :=  parser parse: source.
	self assert: root children size equals: 2.
	horizontal := root children first. 
	self assert: (horizontal isKindOf: MicHorizontalLineBlock). 
	self assert: (root children second isKindOf: MicUnorderedListBlock). 
	! !

!MicrodownStyleHelpBuilder commentStamp: ''!
I'm an HelpSystem builder which creates an HelpSystem book from a microdown formatted string. 

# Usage

- Create a class-side method on the class you want to put documentation.
- Add the pragma <microdownStyleHelp:> with the title of the book as parameter
- The method should answer the documentation as a String using microdown (see the help syntax on class comment editor).
!
!MicrodownStyleHelpBuilder methodsFor: 'private - extraction' stamp: ''!
helpTag
	^  #help! !

!MicrodownStyleHelpBuilder methodsFor: 'private - extraction' stamp: ''!
helpStopMarker
	^  '</', self helpTag, '>'! !

!MicrodownStyleHelpBuilder methodsFor: 'private - conversion' stamp: ''!
helpTopicFromFormattedString: aString title: aTitle
	| helpString currentLevel section topicStack topic |
	helpString := aString.
	topicStack := Stack new.
	topicStack push: (HelpTopic new title: aTitle).
	currentLevel := 0.
	section := ''.
	helpString 
		linesDo: [:line | 
			(line beginsWith: self sectionStartChar asString)
				ifTrue: [ |  level title |					
					section ~= ''
						ifTrue: [topicStack top contents: section trimLeft.
							section := ''].
					level := 0.
					[(level < line size) and: [(line at: level + 1) = self sectionStartChar]]
						whileTrue: [level := level + 1].
					title := (line copyFrom: level + 1 to: line size) trimLeft.
					level > currentLevel 
						ifTrue: [(level - currentLevel)
							timesRepeat: [topicStack push:  HelpTopic new].
							topicStack top title: title]
						ifFalse: [currentLevel = level
							ifTrue: [topic := topicStack pop.
								topicStack top addSubtopic: topic.
								topicStack push: (HelpTopic new title: title)]
							ifFalse: [
								(currentLevel - level) + 1 
									timesRepeat: [topic := topicStack pop.
										topicStack top addSubtopic: topic].
								topicStack push: (HelpTopic new title: title)]].
					currentLevel := level]
				ifFalse: [section := section, String cr, line]].
	section ~= ''
		ifTrue: [topicStack top contents: section trimLeft].
	[topicStack isEmpty]
		whileFalse: [topic := topicStack pop.
			topicStack isEmpty ifFalse: [topicStack top addSubtopic: topic]].
	^ topic! !

!MicrodownStyleHelpBuilder methodsFor: 'private - extraction' stamp: ''!
helpStartMarker
	^  '<', self helpTag, '>'! !

!MicrodownStyleHelpBuilder methodsFor: 'private - extraction' stamp: ''!
extractHelpContentFromString: aString
	| start stop |
	start := aString findString: self helpStartMarker.
	start := start = 0
		ifTrue: [ 1 ]
		ifFalse: [ start + self helpStartMarker size ].
	stop := aString findString: self helpStopMarker startingAt: start.
	stop := stop = 0
		ifTrue: [ aString size ]
		ifFalse: [ stop - 1 ].
	^ (aString copyFrom: start to: stop) trimBoth! !

!MicrodownStyleHelpBuilder methodsFor: 'building' stamp: ''!
build
	| text extract topic |
	topicToBuild title: 'Midrodown style help' translated.
	self class allHelpPragmas
		do: [ :each | 
			"Its assumed that if the pragma is a single keyword only the title is given
		 and the default syntax applies, otherwise the syntax is given as last parameter
		 on the pragmas keyword message"
			text := each method methodClass instanceSide perform: each method selector.
			extract := self extractHelpContentFromString: text.
			topic := self helpTopicFromFormattedString: extract title: each arguments first.
			topicToBuild addSubtopic: topic ]! !

!MicrodownStyleHelpBuilder methodsFor: 'private - accessing' stamp: ''!
defaultSyntax
	^#microdown! !

!MicrodownStyleHelpBuilder methodsFor: 'private - accessing' stamp: ''!
supportedSyntaxes
	^#(microdown)! !

!MicrodownStyleHelpBuilder methodsFor: 'private - accessing' stamp: ''!
sectionStartChar
	^ $!!! !

!MicrodownStyleHelpBuilder class methodsFor: 'help' stamp: ''!
help
	<microdownStyleHelp: #'Write documentation with Microdown'>
	^ self comment! !

!MicrodownStyleHelpBuilder class methodsFor: 'private - accessing' stamp: ''!
allHelpPragmas
	^ self pragmaKeywords flatCollect: [ :keyword | Pragma allNamed: keyword ]! !

!MicrodownStyleHelpBuilder class methodsFor: 'private - accessing' stamp: ''!
pragmaKeyword
	 ^ #microdownStyleHelp:! !

!MicrodownStyleHelpBuilder class methodsFor: 'private - accessing' stamp: ''!
pragmaKeywords
	 ^ #(microdownStyleHelp:)! !

!MicrodownTest methodsFor: 'tests' stamp: ''!
testResolverRootIsCorrectlyPassedToResolver

	| mic root |
	mic := Microdown new.  
	root := 'http://www.pharo.org' asUrl.
	mic resolverRoot: root.
	self assert: mic resolverRoot equals: mic resolver resolutionSource! !

!MicrodownVisitor commentStamp: ''!
I'm an abstract visitor for Microdown document three. 
By default I visit only the nodes of the domain: it means that I will not visit the label of an annotated paragraph 
or the parameters of an annotation or the URL of a figure because such elements are not represented by subclasses 
of MicElement.
!
!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitRaw: aRawFormat

	! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitHorizontalLine: anHorizontalLineBlock! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitHeader: aHeader

	^  aHeader headerElements do: [ :each | each accept: self ]! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitMathInline: aMicMathInline! !

!MicrodownVisitor methodsFor: 'visiting - list' stamp: ''!
visitUnorderedListItem: anUnorderedList

	^ self visitListItem: anUnorderedList
	! !

!MicrodownVisitor methodsFor: 'visiting - list' stamp: ''!
visitOrderedListItem: anItem

	^ self visitListItem: anItem! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitParagraph: aParagraph

	^ self visitChildrenOf: aParagraph! !

!MicrodownVisitor methodsFor: 'visiting - list' stamp: ''!
visitOrderedList: anOrderedList

	^ anOrderedList children do: [ :each | self visitOrderedListItem: each ]! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitText: aMicTextBlock

	"do nothing"! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitLink: aLink

	aLink captionElements do: [:each | each accept: self ].
! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitMonospace: aFormat

	self visitChildrenOf: aFormat.
! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitBold: aFormat

	self visitChildrenOf: aFormat.
! !

!MicrodownVisitor methodsFor: 'visiting main API' stamp: ''!
visitAll: aCollection

	aCollection do: [ :each | each accept: self ]! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitCode: aCodeBlock 
	 
	^ aCodeBlock captionElements do: [ :each |each accept: self ]
! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitMath: aMicMath

	aMicMath captionElements do: [ :each | each accept: self ]
! !

!MicrodownVisitor methodsFor: 'visiting main API' stamp: ''!
visit: aMicElement

	^ aMicElement accept: self! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitInputfile: anInputfile
	"subclassResponsibility"! !

!MicrodownVisitor methodsFor: 'visiting - list' stamp: ''!
visitListItem: anItem

	anItem textElements do: [ :each | each accept: self ].
	self visitChildrenOf: anItem! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitTable: aTable
	"subclassResponsibility"! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitAnnotation: anAnnotation! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitChildrenOf: aFormat

	aFormat children do: [ :each | each accept: self ]! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitQuote: aQuote
! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitAnnotated: anAnnotated

	^ anAnnotated body do: [ :each | each accept: self ]! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitComment: aComment! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitAnchor: anAnchor! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitEnvironment: anEnvironment

	^ anEnvironment bodyElements do: [ :each | each accept: self ]! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitFigure: aFigure
	
	^ aFigure captionElements do: [:each | each accept: self ]
		! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitItalic: aFormat

	self visitChildrenOf: aFormat.
! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitFootnote: aFootnote
	"subclassResponsibility"! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitMetaData: aMetaData! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitAnchorReference: anAnchorReference! !

!MicrodownVisitor methodsFor: 'visiting - extensions' stamp: ''!
visitCitation: aVisitor! !

!MicrodownVisitor methodsFor: 'visiting' stamp: ''!
visitRoot: aRoot

	^ self visitChildrenOf: aRoot! !

!MicrodownVisitor methodsFor: 'visiting - inline elements' stamp: ''!
visitStrike: aFormat

	self visitChildrenOf: aFormat.
! !

!MicrodownVisitor methodsFor: 'visiting - list' stamp: ''!
visitUnorderedList: anUnorderedList

	^ anUnorderedList children do: [ :each | self visitUnorderedListItem: each ]! !

!MillerScrollPane commentStamp: ''!
A scroll pane to show a miller column list.!
!MillerScrollPane methodsFor: 'private' stamp: ''!
keepShowingPage: aBoolean

	keepShowingPage := aBoolean.
	keepShowingPage ifFalse: [ 
		firstShowingMorph := nil ]! !

!MillerScrollPane methodsFor: 'accessing' stamp: ''!
showMorph: aMorph
	
	keepShowingPage 
		ifTrue: [ firstShowingMorph := aMorph ].
	self basicShowMorph: aMorph! !

!MillerScrollPane methodsFor: 'scrollbars' stamp: ''!
hScrollbarShowWhenNeeded

	super hScrollbarShowWhenNeeded.
	"Since I am showing a scroll bar, I do not need to keep the page."
	self keepShowingPage: false! !

!MillerScrollPane methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	updating := false.
	keepShowingPage := false! !

!MillerScrollPane methodsFor: 'testing' stamp: ''!
isUpdating

	^ updating ifNil: [ updating := false ]! !

!MillerScrollPane methodsFor: 'private' stamp: ''!
basicShowMorph: aMorph

	scroller offset: aMorph topLeft! !

!MillerScrollPane methodsFor: 'scrollbars' stamp: ''!
hScrollbarShowNever

	super hScrollbarShowNever.
	"Since I am showing a scroll bar, I do not need to keep the page."
	self keepShowingPage: true! !

!MillerScrollPane methodsFor: 'events' stamp: ''!
layoutChanged

	self isUpdating ifTrue: [ ^ self ].
	updating := true.
	[ 
	super layoutChanged.
	layoutChangeAction ifNotNil: [ layoutChangeAction value ] ] ensure: [ 
		updating := false ]! !

!MillerScrollPane methodsFor: 'events' stamp: ''!
onLayoutChange: aBlock

	layoutChangeAction := aBlock! !

!MillerScrollPane methodsFor: 'scrollbars' stamp: ''!
vScrollbarNeeded
	"Return whether the vertical scrollbar is needed."

	self vScrollbar showsAlways ifTrue: [ ^ true ].
	self vScrollbar showsNever ifTrue: [ ^ false ].	
 	keepShowingPage ifNil: [ ^ super vScrollbarNeeded ].
	
	^ self scrollTarget height > self innerBounds height! !

!MillerScrollPane methodsFor: 'updating' stamp: ''!
updateScrollbars

	super updateScrollbars.
	firstShowingMorph ifNotNil: [ 
		scroller offset: firstShowingMorph topLeft ]! !

!MimeConverter commentStamp: ''!
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: ''!
mimeStream: anObject
	mimeStream := anObject! !

!MimeConverter methodsFor: 'converting' stamp: ''!
mimeEncode
	"Do conversion reading from dataStream writing to mimeStream"

	self subclassResponsibility! !

!MimeConverter methodsFor: 'accessing' stamp: ''!
dataStream: anObject
	dataStream := anObject! !

!MimeConverter methodsFor: 'accessing' stamp: ''!
mimeStream
	^mimeStream! !

!MimeConverter methodsFor: 'accessing' stamp: ''!
dataStream
	^dataStream! !

!MimeConverter methodsFor: 'converting' stamp: ''!
mimeDecode
	"Do conversion reading from mimeStream writing to dataStream"

	self subclassResponsibility! !

!MimeConverter class methodsFor: 'convenience' stamp: ''!
mimeDecode: aStringOrStream to: outStream 
	self new
		mimeStream: (aStringOrStream isStream 
				ifTrue: [ aStringOrStream ]
				ifFalse: [ aStringOrStream readStream ]);
		dataStream: outStream;
		mimeDecode! !

!MimeConverter class methodsFor: 'convenience' stamp: ''!
mimeEncode: aCollectionOrStream to: outStream 
	self new
		dataStream: (aCollectionOrStream isStream 
				ifTrue: [ aCollectionOrStream ]
				ifFalse: [ aCollectionOrStream readStream ]);
		mimeStream: outStream;
		mimeEncode! !

!MimeConverter class methodsFor: 'convenience' stamp: ''!
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: ''!
mimeEncode: aCollectionOrStream
	^ String streamContents: [:out |
		self mimeEncode: aCollectionOrStream to: out]! !

!MimeConverter class methodsFor: 'convenience' stamp: ''!
mimeDecode: aStringOrStream as: contentsClass
	^ contentsClass streamContents: [:out |
		self mimeDecode: aStringOrStream to: out]! !

!MiniDrTests commentStamp: ''!
A minified version of the DrTest tool.!
!MiniDrTests methodsFor: 'accessing' stamp: ''!
evaluateBackgroundColor

	^ pluginResult backgroundColor! !

!MiniDrTests methodsFor: 'private - actions' stamp: ''!
switchToDrTest

	DrTests
		reloadConfiguration: testsConfiguration
		withResults: pluginResult
		andPlugin: currentPlugin! !

!MiniDrTests methodsFor: 'initialization' stamp: ''!
updateWithResults: results
	self pluginResult: results.
	self updateUI! !

!MiniDrTests methodsFor: 'private - initialization' stamp: ''!
initializeButtons
	super initializeButtons.

	startButton := self newButton.

	startButton
		label: 'run';
		icon: (self iconNamed: #smallUpdate);
		color: (Color gray).
	switchButton
		label: 'Maximize'.
		
	startButton action: [ self runPlugin ]! !

!MiniDrTests methodsFor: 'updating' stamp: ''!
updateUI

	super updateUI.
	startButton color: self evaluateBackgroundColor.
	startButton label: pluginResult summarizeInfo.
	"The next line doesn't work because Spec2 does not handle button label's styles.
	Should be changed at some point"
	startButton label makeAllColor: pluginResult textColor.! !

!MiniDrTests methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	super initializeWindow: aWindowPresenter.
	aWindowPresenter
		title: self title;
		initialExtent: 200 @ 200! !

!MiniDrTests methodsFor: 'accessing' stamp: ''!
currentPlugin: anObject

	currentPlugin := anObject! !

!MiniDrTests methodsFor: 'actions' stamp: ''!
switchUI

	super switchUI.
	self switchToDrTest! !

!MiniDrTests methodsFor: 'accessing' stamp: ''!
title

	^ 'MiniDrTests - ' , currentPlugin pluginName! !

!MiniDrTests methodsFor: 'accessing' stamp: ''!
startButton
	^ startButton! !

!MiniDrTests class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: (SpBoxLayout newLeftToRight
				add: #switchButton;
				yourself)
		expand: false
		fill: true
		padding: 1;
		add: #startButton;
		yourself! !

!MirrorModificationForbidden commentStamp: ''!
This exception is raised when mutating a read-only object using mirror primitives.

I am signaled from MirrorPrimitive methods.!
!MirrorModificationForbidden methodsFor: 'retrying' stamp: ''!
retryModification
	fieldIndex notNil
		ifTrue: [ MirrorPrimitives perform: retrySelector withArguments: {object. fieldIndex. newValue}]
		ifFalse: [MirrorPrimitives perform: retrySelector withArguments: {object. newValue}].
	self resumeUnchecked: newValue! !

!MirrorPrimitives commentStamp: ''!
It is container of all mirror primitives implemented in VM.
Mirror primitives allow to call some primitive on object without sending message to it. It is achived by using receiver as first argument of primitive.

Mirror primitives  violates the principle that each object has sovereign control own state (for example  over the storing of values into its instance variables). But it is essential for the	 debugger. 
	
For details see  Object documentation whatIsAPrimitive.!
!MirrorPrimitives methodsFor: 'help' stamp: ''!
seeClassSide! !

!MirrorPrimitives class methodsFor: 'message performing' stamp: ''!
withReceiver: anObject 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."
	
	<primitive: 84 error: error>
	self primitiveFailed! !

!MirrorPrimitives class methodsFor: 'fields accessing' stamp: ''!
fixedSizeOf: anObject
	"Answer the number of inst vars"

	^(self classOf: anObject) instSize! !

!MirrorPrimitives class methodsFor: 'fields accessing' stamp: ''!
fixedFieldOf: anObject at: anIndex put: newValue 
	"Primitive. Store a value into a fixed variable in the argument anObject.
	 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"

	<primitive: 74>
	anIndex isInteger ifTrue: [
		(anIndex between: 1 and: (self fixedSizeOf: anObject)) 
			ifTrue: [
				(self isObjectReadOnly: anObject) ifTrue: [ 
					^self 
						modificationForbiddenFor: anObject 
						at: anIndex 
						with: newValue
						selector: #fixedFieldOf:at:put:]].
		^self primitiveFail].		
	self errorNonIntegerIndex! !

!MirrorPrimitives class methodsFor: 'fields accessing' stamp: ''!
fixedFieldOf: anObject at: anIndex
	"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"

	<primitive: 73>
	"Access beyond fixed variables."
	^self primitiveFailed! !

!MirrorPrimitives class methodsFor: 'printing' stamp: ''!
print: anObject on: aStream
	| title |
	title := (self classOf: anObject) name.
	aStream 
		nextPutAll: ((title at: 1) isVowel ifTrue: ['an '] ifFalse: ['a ']).
	aStream nextPutAll: title! !

!MirrorPrimitives class methodsFor: 'fields accessing' stamp: ''!
indexableFieldOf: anObject at: anIndex put: newValue
	"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"
	<primitive: 61>
	anIndex isInteger ifTrue:
		[(self classOf: anObject) isVariable
			ifTrue: [(anIndex between: 1 and: (self indexableSizeOf: anObject))
					ifTrue: [
						(self isObjectReadOnly: anObject) ifTrue: [
							^self 
								modificationForbiddenFor: anObject 
								at: anIndex 
								with: newValue
								selector: #indexableFieldOf:at:put:].
						^self errorImproperStore]
					ifFalse: [self errorSubscriptBounds: anIndex]]
			ifFalse: [self errorNotIndexableFor: anObject]].
	
	self errorNonIntegerIndex! !

!MirrorPrimitives class methodsFor: 'message performing' stamp: ''!
withReceiver: receiver tryPrimitive: number withArguments: args
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives"

	<primitive: 118 error: code >
	^self primitiveFailed! !

!MirrorPrimitives class methodsFor: 'errors' stamp: ''!
modificationForbiddenFor: anObject at: fieldIndex with: newObject selector: selector
	
	^(MirrorModificationForbidden 
		for: anObject 
		at: fieldIndex 
		with: newObject 
		retrySelector: selector) signal! !

!MirrorPrimitives class methodsFor: 'message performing' stamp: ''!
withReceiver: receiver 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: 100 error: error>
	selector isSymbol
		ifFalse: [ ^ self error: 'selector argument must be a Symbol' ].
	(self classOf: argArray) == Array
		ifFalse: [ ^ self error: 'argArray must be an Array' ].
	(selector numArgs = self indexableSizeOf: argArray)
		ifFalse: [ ^ self error: 'incorrect number of arguments' ].
	((self classOf: receiver) includesBehavior: lookupClass)
		ifFalse: [ ^ self error: 'lookupClass is not in my inheritance chain' ].
	self primitiveFailed! !

!MirrorPrimitives class methodsFor: 'class relationship' stamp: ''!
setClass: classObject to: anObject
	"Change the class of anObject to classObject"
	
	<primitive: 160 error: ec>
	(self isObjectReadOnly: anObject) 
		ifTrue: [ ^ (ModificationForbidden 
							for: anObject
							at: nil
							with: classObject
							retrySelector: #setClass:to:) signal ]. 
	self primitiveFailed! !

!MirrorPrimitives class methodsFor: 'class relationship' stamp: ''!
classOf: anObject
	"Primitive. Answer the object which is the receiver's class"

	<primitive: 111>
	self primitiveFailed! !

!MirrorPrimitives class methodsFor: 'fields accessing' stamp: ''!
sizeOf: anObject
	"Answer the number of inst vars + number of indexible fields"

	^(self fixedSizeOf: anObject) + (self indexableSizeOf: anObject)! !

!MirrorPrimitives class methodsFor: 'hashes' stamp: ''!
identityHashOf: anObject
	"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"

	<primitive: 75>
	self primitiveFailed! !

!MirrorPrimitives class methodsFor: 'comparison' stamp: ''!
check: anObject identicalTo: anotherObject
	"Answer whether the first and second arguments are the same object (have the
	 same object pointer) without sending a message to the first argument.  This
	 mimics the action of the VM when it compares two object pointers.  Used to
	 simulate the execution machinery by, for example, the debugger.
	 Primitive.  See Object documentation whatIsAPrimitive."

	<primitive: 110>
	self primitiveFailed! !

!MirrorPrimitives class methodsFor: 'fields accessing' stamp: ''!
indexableSizeOf: 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"

	<primitive: 62>
	"The number of indexable fields of fixed-length objects is 0"
	^0! !

!MirrorPrimitives class methodsFor: 'message performing' stamp: ''!
withReceiver: receiver andArguments: argArray execute: compiledMethod
	"Execute compiledMethod against the receiver and the arguments in argArray"

	<primitive: 188>
	^self primitiveFailed! !

!MirrorPrimitives class methodsFor: 'write barrier' stamp: ''!
makeObject: anObject readOnly: aBoolean
	<primitive: 164 error: ec>
	^ self primitiveFail! !

!MirrorPrimitives class methodsFor: 'errors' stamp: ''!
errorNotIndexableFor: anObject
	"Create an error notification that the receiver is not indexable."

	self error: ('Instances of {1} are not indexable' format: {(self classOf: anObject) name})! !

!MirrorPrimitives class methodsFor: 'fields accessing' stamp: ''!
fieldOf: anObject at: anIndex put: newObject
	"Setting newObject into field at anIndex in order: indexable fields -> fixed fields"

	| fixedSize indexableSize |
	fixedSize := self fixedSizeOf: anObject.
	indexableSize := self indexableSizeOf: anObject.
	
	indexableSize = 0
		ifTrue: [ ^self fixedFieldOf: anObject at: anIndex put: newObject].
	fixedSize = 0
		ifTrue: [ ^self indexableFieldOf: anObject at: anIndex put: newObject].
			
	^anIndex > indexableSize
		ifTrue: [self fixedFieldOf: anObject at: anIndex - indexableSize put: newObject]
		ifFalse: [ self indexableFieldOf: anObject at: anIndex put: newObject]! !

!MirrorPrimitives class methodsFor: 'fields accessing' stamp: ''!
fieldOf: anObject at: anIndex
	"Answer field at anIndex in order: indexable fields -> fixed fields"

	| fixedSize indexableSize |
	fixedSize := self fixedSizeOf: anObject.
	indexableSize := self indexableSizeOf: anObject.
	
	indexableSize = 0
		ifTrue: [ ^self fixedFieldOf: anObject at: anIndex].
	fixedSize = 0
		ifTrue: [ ^self indexableFieldOf: anObject at: anIndex].
		
	^anIndex > indexableSize
		ifTrue: [self fixedFieldOf: anObject at: anIndex - indexableSize ]
		ifFalse: [ self indexableFieldOf: anObject at: anIndex ]! !

!MirrorPrimitives class methodsFor: 'write barrier' stamp: ''!
isObjectReadOnly: anObject
	<primitive: 163 error: ec>
	^ self primitiveFail! !

!MirrorPrimitives class methodsFor: 'printing' stamp: ''!
print: anObject
	
	^String streamContents: [ :s |	self print: anObject on: s] limitedTo: 32.
! !

!MirrorPrimitives class methodsFor: 'fields accessing' stamp: ''!
indexableFieldOf: anObject at: anIndex 
	"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."

	<primitive: 60>
	anIndex isInteger ifTrue:
		[(self classOf: anObject) isVariable
			ifTrue: [self errorSubscriptBounds: anIndex]
			ifFalse: [self errorNotIndexableFor: anObject]].
		
	self errorNonIntegerIndex! !

!MirrorPrimitivesTest commentStamp: ''!
Unit tests for mirror primitives.!
!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testChangingIndexableFieldOfFixedObject
	
	self should: [MirrorPrimitives indexableFieldOf: 10@20 at: 1 put: 10] raise: Error! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingIndexableFieldOfFixedObject
	
	self should: [MirrorPrimitives indexableFieldOf: 10@20 at: 1] raise: Error ! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testChangingFixedFieldOfArray

	self should: [ MirrorPrimitives fixedFieldOf: #(1 2) at: 1 put: 10 ] raise: PrimitiveFailed! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingIndexibleSizeOfArray

	| actual |
	
	actual := MirrorPrimitives indexableSizeOf: #(1 2).
	
	self assert: actual equals: 2! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingGeneralFieldOfFixedObject

	| actual  |
	
	actual := MirrorPrimitives fieldOf: 10@20 at: 1.	
	self assert: actual equals: 10.
	
	actual := MirrorPrimitives fieldOf: 10@20 at: 2.	
	self assert: actual equals: 20.
	
	self should: [MirrorPrimitives fieldOf: 10@20 at: 3] raise: PrimitiveFailed! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingIndexibleSizeOfFixedObject

	| actual  |
	
	actual := MirrorPrimitives indexableSizeOf: 0@0.
	
	self assert: actual equals: 0! !

!MirrorPrimitivesTest methodsFor: 'tests - message performing' stamp: ''!
testExecutingPrimitive
	| actual |
	<expectedFailure> "it will be supported by VM at some point"
	
	actual := MirrorPrimitives withReceiver: 100 tryPrimitive: 1 withArguments: #(2).
	
	self assert: actual equals: 102! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testChangingGeneralFieldOfArray
	| object |
	object := #(10 20) copy.
	
	MirrorPrimitives fieldOf: object at: 1 put: 100.	
	self assert: object first equals: 100.
	
	MirrorPrimitives fieldOf: object at: 2 put: 200.	
	self assert: object second equals: 200.
	
	self should: [ MirrorPrimitives fieldOf: object at: 3 put: 500 ] raise: SubscriptOutOfBounds  ! !

!MirrorPrimitivesTest methodsFor: 'tests - message performing' stamp: ''!
testExecutingMethod
	| actual |
	
	actual := MirrorPrimitives withReceiver: 0@0 andArguments: {0@2} execute: (Point >> #distanceTo:).
	
	self assert: actual equals: 2! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingFullSizeOfArray

	| actual |
	
	actual := MirrorPrimitives sizeOf: #(1 2).
	
	self assert: actual equals: 2! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testChangingFixedFieldOfFixedObject

	| object |
	object := 10@20.
	
	MirrorPrimitives fixedFieldOf: object at: 1 put: 100.	
	self assert: object x equals: 100.
	
	MirrorPrimitives fixedFieldOf: object at: 2 put: 200.	
	self assert: object y equals: 200.
	
	self should: [MirrorPrimitives fixedFieldOf: object at: 3 put: 500] raise: PrimitiveFailed! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testChangingFixedFieldOfWeakMessageSend

	| arrayWithInstVars |
	"WeakMessageSend instVarNames #(#selector #shouldBeNil #arguments)"
	arrayWithInstVars := WeakMessageSend receiver: #receiver selector: #selector arguments: #(#args).
	
	MirrorPrimitives fixedFieldOf: arrayWithInstVars at: 1 put: #newSelector.	
	self assert: arrayWithInstVars selector equals: #newSelector.
	
	MirrorPrimitives fixedFieldOf: arrayWithInstVars at: 3 put: #newArgs.	
	self assert: arrayWithInstVars arguments equals: #newArgs.
	
	self
	 	should: [ MirrorPrimitives fixedFieldOf: arrayWithInstVars at: 5 put: 100 ] 
		raise: PrimitiveFailed! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingFixedFieldOfArray
	
	self should: [ MirrorPrimitives fixedFieldOf: #(1 2) at: 1 ] raise: PrimitiveFailed! !

!MirrorPrimitivesTest methodsFor: 'tests - hashes' stamp: ''!
testGettingIdentityHashOfObject

	| actual object |
	object := 0@0.
	
	actual := MirrorPrimitives identityHashOf: object.
	
	self assert: actual equals: object basicIdentityHash! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingGeneralFieldOfArray
	
	| actual |
	actual := MirrorPrimitives fieldOf: #(10 20) at: 1.
	self assert: actual equals: 10.
	
	actual := MirrorPrimitives fieldOf: #(110 20) at: 2.
	self assert: actual equals: 20.
	
	self should: [ MirrorPrimitives fieldOf: #(10 20) at: 3 ] raise: SubscriptOutOfBounds  ! !

!MirrorPrimitivesTest methodsFor: 'tests - message performing' stamp: ''!
testPerformingMessageInSuperclass
	| actual |
	
	actual := MirrorPrimitives withReceiver: 0@0 perform: #printString withArguments: #() inSuperclass: Object.
	
	self assert: actual equals: '(0@0)'! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingIndexableFieldOfWeakMessageSend

	| actual  arrayWithInstVars |
	"WeakMessageSend instVarNames #(#selector #shouldBeNil #arguments)"
	arrayWithInstVars := WeakMessageSend receiver: #receiver selector: #selector arguments: #(#args).
	
	actual := MirrorPrimitives indexableFieldOf: arrayWithInstVars at: 1.	
	self assert: actual equals: #receiver. "receiver is stored as first array item"
	
	self should: [MirrorPrimitives indexableFieldOf: arrayWithInstVars at: 2] raise: SubscriptOutOfBounds! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingFixedSizeOfWeakMessageSend

	| actual arrayWithInstVars |
	arrayWithInstVars := WeakMessageSend new.
	
	actual := MirrorPrimitives fixedSizeOf: arrayWithInstVars.
	
	self assert: actual equals: WeakMessageSend instSize! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testChangingGeneralFieldOfWeakMessageSend

	| arrayWithInstVars |
	"WeakMessageSend instVarNames #(#selector #shouldBeNil #arguments)"
	arrayWithInstVars := WeakMessageSend receiver: #receiver selector: #selector arguments: #(#args).
	
	MirrorPrimitives fieldOf: arrayWithInstVars at: 1 put: #newReceiver.	
	self assert: arrayWithInstVars receiver equals: #newReceiver.

	MirrorPrimitives fieldOf: arrayWithInstVars at: 2 put: #newSelector.	
	self assert: arrayWithInstVars selector equals: #newSelector.
	
	MirrorPrimitives fieldOf: arrayWithInstVars at: 4 put: #newArgs.	
	self assert: arrayWithInstVars arguments equals: #newArgs.
	
	self
	 	should: [MirrorPrimitives fieldOf: arrayWithInstVars at: 5 put: 100] 
		raise: PrimitiveFailed! !

!MirrorPrimitivesTest methodsFor: 'tests - class relationship' stamp: ''!
testChangingClassOfObject

	| classObject object |
	classObject := Association.
	object := 0@1.
	
	MirrorPrimitives setClass: classObject to: object.
	
	self assert: object class equals: classObject.
	self assert: object equals: 0->1! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingFullSizeOfFixedObject

	| actual  |
	
	actual := MirrorPrimitives sizeOf: 0@0.
	
	self assert: actual equals: 2! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingFullSizeOfWeakMessageSend

	| actual arrayWithInstVars |
	arrayWithInstVars := WeakMessageSend new.
	
	actual := MirrorPrimitives sizeOf: arrayWithInstVars.
	
	self assert: actual equals: 1 + WeakMessageSend instSize "receiver of weak message send is stored as first array item"! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingFixedFieldOfFixedObject

	| actual  |
	
	actual := MirrorPrimitives fixedFieldOf: 10@20 at: 1.	
	self assert: actual equals: 10.
	
	actual := MirrorPrimitives fixedFieldOf: 10@20 at: 2.	
	self assert: actual equals: 20.
	
	self should: [ MirrorPrimitives fixedFieldOf: 10@20 at: 3 ] raise: PrimitiveFailed! !

!MirrorPrimitivesTest methodsFor: 'tests - write barrier' stamp: ''!
testChangingIndexableFieldOfReadOnlyArray
	
	| array |
	array := {10. 20}.
	array beReadOnlyObject.
	
	self should: [ MirrorPrimitives indexableFieldOf: array at: 1 put: 5 ] raise: ModificationForbidden! !

!MirrorPrimitivesTest methodsFor: 'tests - message performing' stamp: ''!
testPerformingMessage
	| actual |
	
	actual := MirrorPrimitives withReceiver: 0@0 perform: #distanceTo: withArguments: {0@2}.
	
	self assert: actual equals: 2! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testChangingGeneralFieldOfFixedObject

	| object |
	object := 10@20.
	
	MirrorPrimitives fieldOf: object at: 1 put: 100.	
	self assert: object x equals: 100.
	
	MirrorPrimitives fieldOf: object at: 2 put: 200.	
	self assert: object y equals: 200.
	
	self should: [ MirrorPrimitives fieldOf: object at: 3 put: 500 ] raise: PrimitiveFailed! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingFixedSizeOfArray

	| actual  |
	
	actual := MirrorPrimitives fixedSizeOf: #(1 2).
	
	self assert: actual equals: 0! !

!MirrorPrimitivesTest methodsFor: 'tests - printing' stamp: ''!
testPrintingObject

	| actual |
	actual := MirrorPrimitives print: 0@0.
	
	self assert: actual equals: 'a Point'! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingFixedSizeOfFixedObject

	| actual  |
	
	actual := MirrorPrimitives fixedSizeOf: 0@0.
	
	self assert: actual equals: 2! !

!MirrorPrimitivesTest methodsFor: 'tests - write barrier' stamp: ''!
testChangingFixedFieldOfReadOnlyObject

	| object |
	object := 10@20.
	object beReadOnlyObject.
	
	self should: [MirrorPrimitives fixedFieldOf: object at: 1 put: 500] raise: ModificationForbidden! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingGeneralFieldOfWeakMessageSend

	| actual  arrayWithInstVars |
	"WeakMessageSend instVarNames #(#selector #shouldBeNil #arguments)"
	arrayWithInstVars := WeakMessageSend receiver: #receiver selector: #selector arguments: #(#args).
	
	actual := MirrorPrimitives fieldOf: arrayWithInstVars at: 1.	
	self assert: actual equals: #receiver. "receiver is stored as first array item"
	
	actual := MirrorPrimitives fieldOf: arrayWithInstVars at: 2.	
	self assert: actual equals: #selector.
	
	actual := MirrorPrimitives fieldOf: arrayWithInstVars at: 4.	
	self assert: actual first equals: #args.
	
	self should: [ MirrorPrimitives fieldOf: arrayWithInstVars at: 5 ] raise: PrimitiveFailed! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testChangingIndexableFieldOfArray
	| object |
	object := #(10 20) copy.
	
	MirrorPrimitives indexableFieldOf: object at: 1 put: 100.	
	self assert: object first equals: 100.
	
	MirrorPrimitives indexableFieldOf: object at: 2 put: 200.	
	self assert: object second equals: 200.
	
	self should: [MirrorPrimitives indexableFieldOf: object at: 3 put: 500] raise: SubscriptOutOfBounds ! !

!MirrorPrimitivesTest methodsFor: 'tests - comparison' stamp: ''!
testIdenticalEquality

	| object |
	object := 0@0.
	
	self assert: (MirrorPrimitives check: object identicalTo: object).
	self deny: (MirrorPrimitives check: object identicalTo: 0@0)! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testChangingIndexableFieldOfWeakMessageSend

	| arrayWithInstVars |
	"WeakMessageSend instVarNames #(#selector #shouldBeNil #arguments)"
	arrayWithInstVars := WeakMessageSend receiver: #receiver selector: #selector arguments: #(#args).
	
	MirrorPrimitives indexableFieldOf: arrayWithInstVars at: 1 put: #newReceiver.	
	self assert: arrayWithInstVars receiver equals: #newReceiver.
		
	self
	 	should: [ MirrorPrimitives indexableFieldOf: arrayWithInstVars at: 2 put: 100] 
		raise: SubscriptOutOfBounds ! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingIndexableFieldOfArray
	
	| actual |
	actual := MirrorPrimitives indexableFieldOf: #(10 20) at: 1.
	self assert: actual equals: 10.
	
	actual := MirrorPrimitives indexableFieldOf: #(110 20) at: 2.
	self assert: actual equals: 20.
	
	self should: [MirrorPrimitives indexableFieldOf: #(10 20) at: 3] raise: SubscriptOutOfBounds! !

!MirrorPrimitivesTest methodsFor: 'tests - class relationship' stamp: ''!
testGettingClassOfObject

	| actual |
	actual := MirrorPrimitives classOf: 0@0.
	
	self assert: actual equals: (0@0) class! !

!MirrorPrimitivesTest methodsFor: 'tests - write barrier' stamp: ''!
testRetryingFixedFieldModificationOfReadOnlyObject

	| array actual |
	array := {10. 20}.
	array beReadOnlyObject.
	
	actual := [MirrorPrimitives indexableFieldOf: array at: 1 put: 5. #done] 
		on: ModificationForbidden do: [ :err | 
			array beWritableObject.
			err retryModification ].
	self assert: actual equals: #done.
	self assert: array equals: #(5 20)! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingFixedFieldOfWeakMessageSend

	| actual  arrayWithInstVars |
	"WeakMessageSend instVarNames #(#selector #shouldBeNil #arguments)"
	arrayWithInstVars := WeakMessageSend receiver: #receiver selector: #selector arguments: #(#args).
	
	actual := MirrorPrimitives fixedFieldOf: arrayWithInstVars at: 1.	
	self assert: actual equals: #selector. "receiver is stored as first array item"
	
	actual := MirrorPrimitives fixedFieldOf: arrayWithInstVars at: 3.	
	self assert: actual first equals: #args.
	
	self should: [ MirrorPrimitives fixedFieldOf: arrayWithInstVars at: 5 ] raise: PrimitiveFailed! !

!MirrorPrimitivesTest methodsFor: 'tests - fields accessing' stamp: ''!
testGettingIndexibleSizeOfWeakMessageSend

	| actual arrayWithInstVars |
	arrayWithInstVars := WeakMessageSend new.
	
	actual := MirrorPrimitives indexableSizeOf: arrayWithInstVars.
	
	self assert: actual equals: 1 "receiver of weak message send is stored as first array item"! !

!MirrorPrimitivesTest methodsFor: 'tests - write barrier' stamp: ''!
testMakingObjectReadOnly
	| point |
	point := 10@20.
	MirrorPrimitives makeObject: point readOnly: true.
	self assert: (MirrorPrimitives isObjectReadOnly: point).
	
	[MirrorPrimitives fieldOf: point at: 1 put: 100.
	self assert: false description: 'should raise modification error'] 
		on: ModificationForbidden do: [].
	self assert: point equals: 10@20.

	MirrorPrimitives makeObject: point readOnly: false.
	self deny: (MirrorPrimitives isObjectReadOnly: point).
	
	MirrorPrimitives fieldOf: point at: 1 put: 100.	
	self assert: point equals: 100@20.! !

!MissingClassError commentStamp: ''!
I'm a specialized error that is invoked when trying to load a method for a non existing class. 

By default this exception is not resumable but it can be set and used for example as follow:


	[ FileStream fileIn: aFile ]
		on: MissingClassError
		do: [ :exception | 
				exception defineClass. 
				exception asResumable.
				exception resume. ]
			
			
So we give the possibility to compile and resume compution.
The method defineClass defines a simple class inheriting from Object (or from the class specified using #superclassName:)
The idea is that if later the effective class is loaded its definition will override  this one. !
!MissingClassError methodsFor: 'actions' stamp: ''!
asResumable
	"When sent to the receiver, this one turns into a resumable exception allowing for example to define missing class on the fly."
	resumable := true.! !

!MissingClassError methodsFor: 'actions' stamp: ''!
defineClass

	self class classInstaller make: [ :aBuilder | 
		aBuilder
			name: className asSymbol;
			superclassName: self superclassName;
			package: 'Stub-Classes' ]! !

!MissingClassError methodsFor: 'accessing' stamp: ''!
className: aString

	className := aString! !

!MissingClassError methodsFor: 'accessing' stamp: ''!
superclassName

	^ superclassName ifNil: [ superclassName := 'Object' ]! !

!MissingClassError methodsFor: 'accessing' stamp: ''!
superclassName: aString

	superclassName := aString! !

!MissingClassError methodsFor: 'testing' stamp: ''!
isResumable
	"Determine whether an exception is resumable. By default not but can be resumable using accessors at exception raising time."

	^ resumable ifNil: [ super isResumable ]! !

!MissingClassError class methodsFor: 'instance creation' stamp: ''!
className: aString

	^ self new className: aString; yourself! !

!MockExceptionWithPassAction commentStamp: ''!
I am Exception used in the Weak collection tests which has a custom pass action.
Instead of using the Exception's default pass mechanism I will call a customized block.!
!MockExceptionWithPassAction methodsFor: 'handling' stamp: ''!
pass
	^ passAction cull: self! !

!MockExceptionWithPassAction methodsFor: 'accessing' stamp: ''!
passAction: aValuable
	passAction := aValuable! !

!MockFinalizerAction commentStamp: ''!
I am test object used for the WeakRegisty tests.
Upon finalization I trigger a custom finalizationAction (usually a Block)!
!MockFinalizerAction methodsFor: 'finalization' stamp: ''!
finalizationAction: aValuable
	finalizationAction := aValuable! !

!MockFinalizerAction methodsFor: 'finalization' stamp: ''!
finalizeValues
	finalizationAction value! !

!MockFinalizerAction methodsFor: 'finalization' stamp: ''!
finalize
	finalizationAction value! !

!MockForCompilation commentStamp: ''!
A simple mock with an ivar used by tests to check compilation, instance variable shadowing and other!
!MockForCompilation methodsFor: 'accessing' stamp: ''!
var1

	^ var1! !

!MockForCoverage commentStamp: ''!
A mock class with methods used for testing the coverage plugin of DrTest!
!MockForCoverage methodsFor: 'sample methods' stamp: ''!
method2ForMock: anObject

	^ 1 + anObject! !

!MockForCoverage methodsFor: 'sample methods' stamp: ''!
method1ForMock

	^ 1 + 1! !

!MockLessonView commentStamp: ''!
A LessonView mock for testing purposes!
!MockLessonView methodsFor: 'gui' stamp: ''!
showTutorialNode: aTutorialNode
	lesson:= aTutorialNode lessonInstance.
	title := aTutorialNode title.! !

!MockLessonView methodsFor: 'accessing' stamp: ''!
lesson
	^ lesson! !

!MockLessonView methodsFor: 'gui' stamp: ''!
showLesson: aLesson withTitle: aString
	lesson := aLesson.
	title := aString.! !

!MockLessonView methodsFor: 'testing' stamp: ''!
isOpenInWindow
	^ true! !

!MockLessonView methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!MockMessageSend commentStamp: ''!
I am a message that a MockObject instance has been trained to expect.!
!MockMessageSend methodsFor: 'accessing' stamp: ''!
selector

	^ selector! !

!MockMessageSend methodsFor: 'testing' stamp: ''!
matches: aMessage

	^ (self matchesSelector: aMessage selector) and: [ 
		  self matchesArguments: aMessage arguments ]! !

!MockMessageSend methodsFor: 'testing' stamp: ''!
matchesSelector: aSymbol

	^ selector = aSymbol! !

!MockMessageSend methodsFor: 'evaluating' stamp: ''!
valueWithPossibleArgs: anArray

	^ behavior valueWithPossibleArgs: anArray! !

!MockMessageSend methodsFor: 'initialization' stamp: ''!
on: aSymbol with: anArray do: aBlock

	selector := aSymbol.
	arguments := anArray.
	behavior := aBlock! !

!MockMessageSend methodsFor: 'testing' stamp: ''!
matchesArguments: anArray

	arguments ifNil: [ ^ true ].
	arguments size = anArray size ifFalse: [ ^ false ].
	anArray with: arguments do: [ :actual :expected | 
		(expected ~= MockObject any and: [ actual ~= expected ]) ifTrue: [ 
			^ false ] ].
	^ true! !

!MockMessageSend class methodsFor: 'instance creation' stamp: ''!
on: aSymbol with: anArray do: aBlock

	^ self new
		  on: aSymbol with: anArray do: aBlock;
		  yourself! !

!MockObject commentStamp: ''!
I am a test double object that can be used as a stub, a fake, or a mock.

I provide a simple protocol so that the user can teach me what messages to expect, and how to behave or respond to these messages.

# Usage
A new object can be created with ```MockObject new```, or using the utility methods on the class side _instance creation_ protocol.

The main message to teach a MockObject is ```#on:withArguments:verify:```; the other methods in the _teaching_ protocol all send this message.
This message takes a selector symbol, a collection of arguments, and a block. By sending this message, the mock object is trained to evaluate the block when receiving a message matching the selector and the arguments.
Other variations of this message have more specialized behaviour: ```#on:withArguments:respond:``` will simply return its third argument when the mock receives a matching message; likewise ```:#on:withArguments:``` will return the mock itself.
The other methods in the _teaching_ protocol provide an ergonomic API for this behaviour.

A mock object will expect to receive only the messages it has been trained on, in the same order and number as it was trained. If it receives an unknown message, or a known message but in the wrong order, it will simply return itself.


# Stubs, Fakes, and Mocks
A MockObject can be used as a stub by not using the ```verify:``` variants of the _teaching_ protocol.

It can also be used as a fake by using the ```verify:``` variants with a non-trivial block.

To use the MockObject as a real mock, the user needs to verify its use. This is done by means of the ```TestCase>>verify:``` message. Verification needs to be triggered by the user - it's not automatic.

The ```#verify:``` message will assert 1) that the mock has received all the messages it has been trained on 2) that it has not received only those messages 3) that it has received the messages it has been trained on.!
!MockObject methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	messages isEmpty
		ifTrue: [ failed := true ]
		ifFalse: [ | expected |
			expected := messages removeFirst.
			(expected matches: aMessage)
				ifTrue: [ ^ expected valueWithPossibleArgs: aMessage arguments ]
				ifFalse: [ messages addFirst: expected.
					failed := true ] ]! !

!MockObject methodsFor: 'teaching' stamp: ''!
on: aSelector withArguments: anArray respond: anObject
	"Teach to return anObject on a message whose selector is aSelector and arguments are held in anArray.
	The test will fail if the message arguments do not correspond to the ones in anArray."

	self on: aSelector withArguments: anArray verify: [ anObject ]! !

!MockObject methodsFor: 'teaching' stamp: ''!
on: aSelector with: anObject with: anotherObject respond: aResponseObject
	"Teach to return anotherObject on a message whose selector is aSelector and arguments are is anObject and anotherObject.
	The test will fail if the message arguments do not correspond to anObject and anotherObject."
	
	self
		on: aSelector
		withArguments: { 
				anObject.
				anotherObject }
		verify: [ aResponseObject ]! !

!MockObject methodsFor: 'reflective operations' stamp: ''!
initialize

	super initialize.
	messages := OrderedCollection new.
	failed := false! !

!MockObject methodsFor: 'teaching - verifying' stamp: ''!
on: aSelector verify: aBlock

	self on: aSelector withArguments: nil verify: aBlock! !

!MockObject methodsFor: 'teaching - verifying' stamp: ''!
on: aSymbol with: anObject verify: aBlock

	self on: aSymbol withArguments: { anObject } verify: aBlock! !

!MockObject methodsFor: 'teaching' stamp: ''!
on: aSelector with: anObject
	"Teach to return self on a message whose selector is aSelector and argument is anObject.
	The test will fail if the message argument does not correspond to anObject."
	
	self on: aSelector withArguments: { anObject } respond: self! !

!MockObject methodsFor: 'verifying' stamp: ''!
verifyIn: aTestCase

	aTestCase deny: failed description: 'Incorrect message sequence'.
	aTestCase
		assert: messages isEmpty
		description: 'Mock still has messages pending'! !

!MockObject methodsFor: 'teaching' stamp: ''!
on: aSelector
	"Teach to return self on a message whose selector is aSelector"
	
	self on: aSelector respond: self! !

!MockObject methodsFor: 'teaching' stamp: ''!
on: aSelector with: anObject with: anotherObject with: aThirdObject respond: aResponseObject

	self
		on: aSelector
		withArguments: { 
				anObject.
				anotherObject.
				aThirdObject }
		verify: [ aResponseObject ]! !

!MockObject methodsFor: 'teaching' stamp: ''!
on: aSelector with: anObject respond: anotherObject
	"Teach to return anotherObject on a message whose selector is aSelector and argument is anObject.
	The test will fail if the message argument does not correspond to anObject."
	
	self
		on: aSelector
		withArguments: { anObject }
		verify: [ anotherObject ]! !

!MockObject methodsFor: 'teaching - verifying' stamp: ''!
on: aSymbol withArguments: anArray verify: aBlock
	
	messages add: (MockMessageSend on: aSymbol with: anArray do: aBlock).
	failed := false! !

!MockObject methodsFor: 'teaching' stamp: ''!
on: aSelector respond: anObject
	"Teach to return self on a message whose selector is aSelector"
	
	self on: aSelector withArguments: nil respond: anObject! !

!MockObject methodsFor: 'teaching' stamp: ''!
on: aSymbol with: anObject with: anotherObject with: aThirdObject

	self
		on: aSymbol
		withArguments: { 
				anObject.
				anotherObject.
				aThirdObject }
		respond: self! !

!MockObject methodsFor: 'teaching' stamp: ''!
on: aSelector withArguments: aCollection
	"Teach to return self on a message whose selector is aSelector and arguments are held in aCollection.
	The test will fail if the message arguments do not correspond to the ones in aCollection."
	
	self on: aSelector withArguments: aCollection respond: self! !

!MockObject methodsFor: 'teaching - verifying' stamp: ''!
on: aSymbol with: anObject with: anotherObject verify: aBlock

	self
		on: aSymbol
		withArguments: { 
				anObject.
				anotherObject }
		verify: aBlock! !

!MockObject methodsFor: 'teaching - verifying' stamp: ''!
on: aSymbol with: anObject with: anotherObject with: aThirdObject verify: aBlock

	self
		on: aSymbol
		withArguments: { 
				anObject.
				anotherObject.
				aThirdObject }
		verify: aBlock! !

!MockObject methodsFor: 'teaching' stamp: ''!
on: aSelector with: anObject with: anotherObject
	"Teach to return self on a message whose selector is aSelector and arguments are anObject and anotherObject"
	
	self
		on: aSelector
		withArguments: { 
				anObject.
				anotherObject }
		respond: self! !

!MockObject class methodsFor: 'accessing' stamp: ''!
any

	^ any ifNil: [ any := Object new ]! !

!MockObject class methodsFor: 'instance creation' stamp: ''!
on: aSymbol

	^ self new
		  on: aSymbol;
		  yourself! !

!MockObject class methodsFor: 'instance creation' stamp: ''!
on: aSymbol respond: anObject

	^ self new
		  on: aSymbol respond: anObject;
		  yourself! !

!MockObjectForEventTests class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!MockSettings commentStamp: ''!
I contains some system settings that are used for testing.!
!MockSettings class methodsFor: 'accessing' stamp: ''!
defaultDirectoryName
	^ defaultDirectoryName ifNil: [ defaultDirectoryName := FileLocator workingDirectory ]! !

!MockSettings class methodsFor: 'setting strings' stamp: ''!
twoStoredSettingsSTONString
	^ 
'[
	StoredSetting {
		#settingNodeIdentifier : ''#booleanSetting'',
		#realValue : false
	},
	StoredSetting {
		#settingNodeIdentifier : ''#rangeSetting'',
		#realValue : 55
	}
]'! !

!MockSettings class methodsFor: 'settings' stamp: ''!
booleanSettingNodeOn: aBuilder
	<mocksystemsettings>
	(aBuilder setting: #booleanSetting)
		label: 'Mock boolean setting'.! !

!MockSettings class methodsFor: 'setting strings' stamp: ''!
notExistingClassStoredSettingSTONString
	^ 
'[
	ClassStoredSetting {
		#settingNodeIdentifier : ''#notExistingClassStoredSettingSTONString'',
		#realValue : #MockNotExistingClass
	}
]'! !

!MockSettings class methodsFor: 'accessing' stamp: ''!
booleanSetting: aBoolean
	^ booleanMockSetting := aBoolean! !

!MockSettings class methodsFor: 'accessing' stamp: ''!
nodeSettings
	"self nodeSettings"
	^ self settingTree nodeList! !

!MockSettings class methodsFor: 'settings' stamp: ''!
booleanSettingWithDefault: aValue

	booleanSettingWithDefault := aValue! !

!MockSettings class methodsFor: 'accessing' stamp: ''!
defaultDirectoryName: aFileReference
	defaultDirectoryName := aFileReference! !

!MockSettings class methodsFor: 'settings' stamp: ''!
booleanSettingWithDefaultNodeOn: aBuilder
	<mocksystemsettings>
	
	(aBuilder setting: #booleanSettingWithDefault)
		label: 'Mock boolean setting';
		default: false;
		yourself.! !

!MockSettings class methodsFor: 'accessing' stamp: ''!
storedSettings
	"self storedSettings"
	| builder |
	builder := StoredSettingsFactory new.
	^ self nodeSettings collect: [ :e | builder from: e ]! !

!MockSettings class methodsFor: 'accessing' stamp: ''!
cacheDirectory: aFileReference
	cacheDirectory := aFileReference! !

!MockSettings class methodsFor: 'accessing' stamp: ''!
booleanSetting
	^ booleanMockSetting ifNil: [ booleanMockSetting := true ]! !

!MockSettings class methodsFor: 'accessing' stamp: ''!
cacheDirectory
	^ cacheDirectory ifNil: [ cacheDirectory := FileLocator workingDirectory ]! !

!MockSettings class methodsFor: 'settings' stamp: ''!
cacheDirectorySettingNode
	^ self settingTree nodeNamed: #cacheDirectory! !

!MockSettings class methodsFor: 'setting strings' stamp: ''!
changedClassStoredSettingVariable
	^ 
'[
	ClassStoredSetting {
		#notExistingInstanceVariable : nil
	},
	ClassStoredSetting {
		#settingNodeIdentifier : ''#notExistingClassStoredSettingSTONString'',
		#realValue : #MockNotExistingClass
	}
]'! !

!MockSettings class methodsFor: 'settings' stamp: ''!
rangeSettingNodeOn: aBuilder
	<mocksystemsettings>
	(aBuilder range: #rangeSetting)
		label: 'Mock range setting';
		range: (0 to: 100 by: 5)! !

!MockSettings class methodsFor: 'settings' stamp: ''!
booleanSettingWithDefault

	^ booleanSettingWithDefault ifNil: [ booleanSettingWithDefault := false ]! !

!MockSettings class methodsFor: 'accessing' stamp: ''!
rangeSetting
	^ rangeSetting ifNil: [ rangeSetting := 10 ].! !

!MockSettings class methodsFor: 'setting strings' stamp: ''!
oneStoredSettingSTONString
	^ 
'[
	StoredSetting {
		#settingNodeIdentifier : ''#booleanSetting'',
		#realValue : true
	}
]'! !

!MockSettings class methodsFor: 'settings' stamp: ''!
monticelloSettingsOn: aBuilder  
	<mocksystemsettings>  
	(aBuilder group: #monticello)
		label: 'Mock Monticello';
		description: 'All Mock Monticello settings';
		with: [ 
			(aBuilder setting: #defaultDirectoryName)
				type: #Directory;
				target: self;
				description: 'The path of a directory where you want to start out when choosing local repository locations' ;
				label: 'Default local repository directory'.
			(aBuilder setting: #cacheDirectory)
				type: #Directory;
				target: self;
				description: 'The path of the local repository cache';
				label: 'Local cache directory'.	
			].! !

!MockSettings class methodsFor: 'accessing' stamp: ''!
rangeSetting: anInteger 
	rangeSetting := anInteger! !

!MockSettings class methodsFor: 'settings' stamp: ''!
rangeSettingNode
	^ self settingTree nodeNamed: #rangeSetting! !

!MockSettings class methodsFor: 'settings' stamp: ''!
booleanSettingNode
	^ self settingTree nodeNamed: #booleanSetting! !

!MockSettings class methodsFor: 'cleanup' stamp: ''!
cleanUp
	self booleanSetting: nil.
	self rangeSetting: nil.
	self defaultDirectoryName: nil.
	self cacheDirectory: nil.
	self booleanSettingWithDefault: nil! !

!MockSettings class methodsFor: 'accessing' stamp: ''!
settingTree
	"self settingTree"
	^ SettingTree new acceptableKeywords: (Array with: #mocksystemsettings)! !

!MockSocketStream commentStamp: ''!
A test mock for socket streams!
!MockSocketStream methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self resetInStream.
	self resetOutStream.! !

!MockSocketStream methodsFor: 'stream in' stamp: ''!
resetInStream
	inStream := String new writeStream.! !

!MockSocketStream methodsFor: 'stream in' stamp: ''!
upToAll: delims
	^self inStream upToAll: delims.! !

!MockSocketStream methodsFor: 'accessing' stamp: ''!
outStream
	^outStream! !

!MockSocketStream methodsFor: 'accessing' stamp: ''!
inStream
	^inStream! !

!MockSocketStream methodsFor: 'stream in' stamp: ''!
nextLine
	^self nextLineCrLf! !

!MockSocketStream methodsFor: 'stream out' stamp: ''!
resetOutStream
	outStream := String new writeStream.! !

!MockSocketStream methodsFor: 'stream out' stamp: ''!
sendCommand: aString
	self outStream
		nextPutAll: aString;
		nextPutAll: String crlf.! !

!MockSocketStream methodsFor: 'accessing' stamp: ''!
atEnd: aBoolean
	atEnd := aBoolean.! !

!MockSocketStream methodsFor: 'stream in' stamp: ''!
nextLineCrLf
	^(self upToAll: String crlf).! !

!MockSocketStream methodsFor: 'testing' stamp: ''!
atEnd
	^self inStream atEnd.! !

!MockSocketStream class methodsFor: 'instance creation' stamp: ''!
on: socket
	^self basicNew initialize! !

!MockSourceEditor commentStamp: ''!
A mock object mocking a source editor!
!MockSourceEditor methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	selectionStart := selectionEnd := 0.! !

!MockSourceEditor methodsFor: 'selection' stamp: ''!
selectFrom: start to: end

	selectionStart := start.
	selectionEnd := end.! !

!MockSourceEditor methodsFor: 'accessing' stamp: ''!
editor

	^ self! !

!MockSourceEditor methodsFor: 'utilities' stamp: ''!
insertAndSelect: aString at: anInteger

	text := (text first: anInteger-1), 
		(' ' , aString), 
		(text copyFrom: anInteger to: text size).
		
	selectionStart := anInteger.
	selectionEnd := anInteger + aString size! !

!MockSourceEditor methodsFor: 'selection' stamp: ''!
selectionAsStream

	^ ReadStream
		on: (self text copyFrom: selectionStart to: selectionEnd)! !

!MockSourceEditor methodsFor: 'notifications' stamp: ''!
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: 'selection' stamp: ''!
selection

	^ self text copyFrom: selectionStart to: selectionEnd! !

!MockSourceEditor methodsFor: 'utilities' stamp: ''!
cut

	text := (text first: selectionStart-1), (text copyFrom: selectionEnd+1 to: text size).
		
	selectionStart := selectionStart - 1.	
	selectionEnd := selectionStart! !

!MockSourceEditor methodsFor: 'accessing' stamp: ''!
startIndex

	^ selectionStart! !

!MockSourceEditor methodsFor: 'accessing' stamp: ''!
contents: aText

	text := aText! !

!MockSourceEditor methodsFor: 'selection' stamp: ''!
selectionInterval

	^ Interval from: selectionStart to: selectionEnd.! !

!MockSourceEditor methodsFor: 'accessing' stamp: ''!
text

	^ text! !

!MockSycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
activeRBEnvironment
	^ self! !

!MockSycRefactoringPreviewPresenter methodsFor: 'private' stamp: ''!
buildDiffFor: aChange
	"i override this method because i just want to test if the transmission use this method"
	^ 'useForTest'! !

!MockSycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
selectedRefactorings
	^ selectedRefactorings! !

!MockTreeTableItem methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ title = anObject title! !

!MockTreeTableItem methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ title hash! !

!MockTreeTableItem methodsFor: 'accessing' stamp: ''!
title: anObject
	title := anObject! !

!MockTreeTableItem methodsFor: 'accessing' stamp: ''!
name
	^ self title.! !

!MockTreeTableItem methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!MockTreeTableItem class methodsFor: 'accessing' stamp: ''!
title: aName
	^ self new title: aName! !

!MockTutorial commentStamp: ''!
Mocking a tutorial for test purposes!
!MockTutorial methodsFor: 'tutorial' stamp: ''!
tutorial 
	^ #(
firstLesson
secondLesson
thirdLesson
)! !

!MockTutorial methodsFor: 'lesson' stamp: ''!
firstLesson
	^ Lesson title: 'first' lesson: 'First lesson'.! !

!MockTutorial methodsFor: 'lesson' stamp: ''!
thirdLesson
	^ Lesson title: 'third' lesson: 'Third lesson'.! !

!MockTutorial methodsFor: 'lesson' stamp: ''!
secondLesson
	^ Lesson title: 'second' lesson: 'Second lesson'.! !

!MockTutorial2 commentStamp: ''!
Mocking another tutorial for test purposes!
!MockWithComplexSlot methodsFor: 'initialization' stamp: ''!
initialize
	
	self class initializeSlots: self.
	super initialize.! !

!Model commentStamp: ''!
Provides optimized model support!
!Model methodsFor: 'updating' stamp: 'nil'!
changed
	"Receiver changed in a general way; inform all the dependents by 
	sending each dependent an update: message."

	self changed: self! !

!Model methodsFor: 'updating' stamp: 'nil'!
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! !

!Model methodsFor: 'backstops' stamp: 'nil'!
selectedClass
	"All owners of TextViews are asked this during a doIt"
	^ nil! !

!Model methodsFor: 'stepping' stamp: 'nil'!
step
	"Default for morphic models is no-op"! !

!Model methodsFor: 'window' stamp: 'nil'!
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."! !

!Model methodsFor: 'window' stamp: 'nil'!
modelWakeUpIn: aWindow
	"A window with me as model is being entered or expanded.  Default response is no-op" ! !

!Model methodsFor: 'updating' stamp: 'nil'!
update: anAspect

	^ self! !

!Model methodsFor: 'edits' stamp: 'nil'!
hasUnacceptedEdits
	"Answer true if any of the views on this model has unaccepted edits."

	dependents ifNil: [^ false].
	self dependents
		do: [:each | 
			self flag: #pharoFixMe. "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: '*Spec-Core' stamp: ''!
isAnnouncingObject

	^ true! !

!Model methodsFor: 'stepping' stamp: 'nil'!
stepTimeIn: aSystemWindow
	
	^ self stepTime ! !

!Model methodsFor: 'updating' stamp: 'nil'!
okToChange
	"Allows a controller to ask this of any model"
	^ true! !

!Model methodsFor: 'dependents-private' stamp: 'nil'!
myDependents

	^ dependents! !

!Model methodsFor: 'announcing' stamp: 'nil'!
destroyAnnouncer

	announcer := nil.! !

!Model methodsFor: 'copying' stamp: 'nil'!
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: 'announcing' stamp: 'nil'!
whenChangedDo: aBlock
	"Culled block [ :newValue :oldValue :announcement :announcer | ]"

	| block |
	block := [ :announcement :ann | 
	aBlock
		cull: announcement newValue
		cull: announcement oldValue
		cull: announcement
		cull: ann ].
	self announcer when: ValueChanged do: block! !

!Model methodsFor: 'dependents' stamp: 'nil'!
dependents
	"Answer a collection of objects that are 'dependent' on the receiver;
	 that is, all objects that should be notified if the receiver changes."

	^ self myDependents ifNil: [#()]! !

!Model methodsFor: 'updating' stamp: 'nil'!
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]! !

!Model methodsFor: '*Tool-Base' stamp: ''!
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: 'accessing' stamp: 'nil'!
announcer

	^ announcer ifNil: [ announcer := Announcer new ]! !

!Model methodsFor: 'stepping' stamp: 'nil'!
stepTime
	
	^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! !

!Model methodsFor: 'dependents-private' stamp: 'nil'!
myDependents: aCollectionOrNil

	dependents := aCollectionOrNil! !

!Model methodsFor: 'announcing' stamp: 'nil'!
whenChangedSend: aSelector to: aReceiver

	self announcer when: ValueChanged send: aSelector to: aReceiver! !

!Model methodsFor: 'updating' stamp: 'nil'!
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]! !

!Model methodsFor: '*Morphic-Core' stamp: ''!
initialExtent

	^ RealEstateAgent standardWindowExtent! !

!Model methodsFor: '*Spec2-Core' stamp: ''!
isSpAnnouncingObject

	^ true! !

!Model methodsFor: 'backstops' stamp: 'nil'!
arrowKey: aChar from: view
	"backstop; all the PluggableList* classes actually handle arrow keys, and the models handle other keys."
	^false! !

!Model methodsFor: 'dependents' stamp: 'nil'!
removeDependent: anObject
	"Remove the given object as one of the receiver's dependents."

	| newDependents |
	newDependents := self dependents reject: [:each | each == anObject].
	self myDependents: (newDependents isEmpty ifFalse: [ newDependents ]).
	
	^ anObject! !

!Model methodsFor: 'edits' stamp: 'nil'!
canDiscardEdits
	"Answer true if none of the views on this model has unaccepted edits that matter."

	dependents ifNil: [ ^ true ].
	
	self dependents
		do: [:each | each canDiscardEdits ifFalse: [ ^ false ] ]
		without: self.
		
	^ true! !

!Model methodsFor: 'updating' stamp: 'nil'!
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."
! !

!Model methodsFor: '*Spec-Core' stamp: ''!
wrappedInValueHolderIfNeeded

	^ self! !

!Model methodsFor: '*Polymorph-Widgets' stamp: ''!
theme
	^ self class theme! !

!Model methodsFor: 'dependents' stamp: 'nil'!
addDependent: anObject
	"Make the given object one of the receiver's dependents."

	(self dependents includes: anObject) ifFalse:
		[self myDependents: (self dependents copyWithDependent: anObject)].
	
	^ anObject! !

!Model methodsFor: 'announcing' stamp: 'nil'!
valueChanged
	
	"compatibility with the NewValueHolder"
	self announcer announce: (ValueChanged newValue: self)! !

!Model methodsFor: 'stepping' stamp: 'nil'!
wantsSteps
	"Overridden by morphic classes whose instances want to be stepped,
	or by model classes who want their morphic views to be stepped."

	^ false! !

!Model methodsFor: 'stepping' stamp: 'nil'!
wantsStepsIn: aSystemWindow
	
	^ self wantsSteps! !

!Model methodsFor: 'stepping' stamp: 'nil'!
stepIn: aWindow

	^ self step! !

!Model methodsFor: 'stepping' stamp: 'nil'!
stepAt: millisecondClockValue in: aWindow

	^ self stepIn: aWindow! !

!Model class methodsFor: 'accessing' stamp: 'nil'!
theme
	^ Smalltalk ui theme! !

!ModelDependentDialogWindow commentStamp: ''!
DialogWindow that updates content based upon its model.!
!ModelDependentDialogWindow methodsFor: 'adding' stamp: ''!
model: anObject
	"Set the model and add the panel for it."
	
	super model: anObject.
	self paneMorphs copy do: [:p | p delete].
	self addMainPanel! !

!ModelDependentDialogWindow methodsFor: 'adding' stamp: ''!
addInitialPanel
	"Don't until the model is set."! !

!ModelMorph commentStamp: ''!
MorphicModels are used to represent structures with state and behavior as well as graphical structure.  A morphicModel is usually the root of a morphic tree depicting its appearance.  The tree is constructed concretely by adding its consituent morphs to a world.

When a part is named in a world, it is given a new slot in the model.  When a part is sensitized, it is named, and a set of mouse-driven methods is also generated in the model.  These may be edited to induce particular behavior.  When a variable is added through the morphic world, it is given a slot in the model, along with a set of access methods.

In addition for public variables (and this is the default for now), methods are generated and called in any outer model in which this model gets embedded, thus propagating variable changes outward.!
!ModelMorph methodsFor: 'initialization' stamp: ''!
defaultBounds
"answer the default bounds for the receiver"
	^ 0 @ 0 corner: 200 @ 100! !

!ModelMorph methodsFor: 'menu' stamp: ''!
hasYellowButtonMenu
	"Answer true if I have any items at all for a context (yellow button) menu."
	^ self wantsYellowButtonMenu
			or: [model
					ifNil: [false]
					ifNotNil: [:aModel | aModel hasModelYellowButtonMenuItems]]! !

!ModelMorph methodsFor: 'settings' stamp: ''!
mouseOverForKeyboardFocus
	^ self class mouseOverForKeyboardFocus! !

!ModelMorph methodsFor: 'settings' stamp: ''!
keyboardFocusOnMouseDown
	^ self class keyboardFocusOnMouseDown! !

!ModelMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color yellow! !

!ModelMorph methodsFor: 'initialization' stamp: ''!
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.! !

!ModelMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color transparent! !

!ModelMorph methodsFor: 'caching' stamp: ''!
releaseCachedState
	"Release cached state of the receiver"

	(model ~~ self and: [model respondsTo: #releaseCachedState]) ifTrue:
		[model releaseCachedState].
	super releaseCachedState! !

!ModelMorph methodsFor: 'accessing' stamp: ''!
model 
	^ model! !

!ModelMorph class methodsFor: 'settings' stamp: ''!
mouseOverForKeyboardFocus
	^ MouseOverForKeyboardFocus ifNil: [MouseOverForKeyboardFocus := false]! !

!ModelMorph class methodsFor: 'settings' stamp: ''!
keyboardFocusOnMouseDown
	^ KeyboardFocusOnMouseDown ifNil: [KeyboardFocusOnMouseDown := true]! !

!ModelMorph class methodsFor: 'settings' stamp: ''!
keyboardFocusOnMouseDown: aBoolean
	KeyboardFocusOnMouseDown := aBoolean! !

!ModelMorph class methodsFor: 'settings' stamp: ''!
mouseOverForKeyboardFocus: aBoolean
	MouseOverForKeyboardFocus := aBoolean! !

!ModificationForbidden commentStamp: ''!
This exception is raised when mutating a read-only object.

My instances have 4 fields to be able to reproduce the modification through retryModification method.

object <Object> read-only object that the code attempted to mutate
index <SmallInteger> index of the field in the object mutated, relevant for the corresponding selector
value <Object> value that was attempted to be stored into the read-only object
selector <Symbol> selector that can be used to reproduce the mutation (typically, #at:put:, #instVarAt:put:, etc.)!
!ModificationForbidden methodsFor: 'retrying' stamp: ''!
retryModification
	fieldIndex notNil
		ifTrue: [ object perform: retrySelector with: fieldIndex with: newValue ]
		ifFalse: [object perform: retrySelector with: newValue ].
	self resumeUnchecked: newValue! !

!ModificationForbidden methodsFor: 'printing' stamp: ''!
indexedMessageText
	^ String streamContents: [ :s |
		s << ' '.
		self printObject: object on: s. 
		s << ' is read-only, hence its field '.
		fieldIndex printOn: s.
		s << ' cannot be modified with '.
		self printObject: newValue on: s]! !

!ModificationForbidden methodsFor: 'accessing' stamp: ''!
retrySelector: anObject
	retrySelector := anObject! !

!ModificationForbidden methodsFor: 'printing' stamp: ''!
standardMessageText

	^ fieldIndex ifNil: [ self nonIndexedMessageText ] ifNotNil: [ self indexedMessageText ]! !

!ModificationForbidden methodsFor: 'printing' stamp: ''!
nonIndexedMessageText
	^ String streamContents: [ :s |
		s << ' '.
		self printObject: object on: s. 
		s << ' is read-only, hence its selector '.
		s << retrySelector.
		s << ' cannot be executed with '.
		self printObject: newValue on: s]! !

!ModificationForbidden methodsFor: 'accessing' stamp: ''!
object: anObject
	object := anObject! !

!ModificationForbidden methodsFor: 'printing' stamp: ''!
printObject: obj on: s
	[obj printOn: s] on: Exception do: [ :ex | s << '<cannot print object>' ]! !

!ModificationForbidden methodsFor: 'accessing' stamp: ''!
fieldIndex: anObject
	fieldIndex := anObject! !

!ModificationForbidden methodsFor: 'accessing' stamp: ''!
newValue
	^ newValue! !

!ModificationForbidden methodsFor: 'accessing' stamp: ''!
newValue: anObject
	newValue := anObject! !

!ModificationForbidden methodsFor: 'accessing' stamp: ''!
retrySelector
	^ retrySelector! !

!ModificationForbidden methodsFor: 'accessing' stamp: ''!
object
	^ object! !

!ModificationForbidden methodsFor: 'accessing' stamp: ''!
fieldIndex
	^ fieldIndex! !

!ModificationForbidden methodsFor: 'printing' stamp: ''!
messageText
	"Overwritten to initialiaze the message text to a standard text if it has not yet been set"
	
	^ messageText ifNil: [ messageText := self standardMessageText ]! !

!ModificationForbidden class methodsFor: 'instance creation' stamp: ''!
for: anObject at: fieldIndex with: newValue retrySelector: selector

	^self new 
		object: anObject;
		fieldIndex: fieldIndex;
		newValue: newValue;
		retrySelector: selector! !

!Monitor commentStamp: ''!
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: 'private' stamp: ''!
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: 'waiting-basic' stamp: ''!
wait
	"Unconditional waiting for the default event.
	The current process gets blocked and leaves the monitor, which means that the monitor
	allows another process to execute critical code. When the default event is signaled, the
	original process is resumed."

	^ self waitMaxMilliseconds: nil! !

!Monitor methodsFor: 'private' stamp: ''!
queueFor: aSymbol 
	aSymbol ifNil: [^self defaultQueue].
	^self queueDict at: aSymbol ifAbsentPut: [OrderedCollection new]! !

!Monitor methodsFor: 'private' stamp: ''!
defaultQueue
	defaultQueue ifNil: [defaultQueue := OrderedCollection new].
	^ defaultQueue! !

!Monitor methodsFor: 'waiting-basic' stamp: ''!
waitUntil: aBlock
	"Conditional waiting for the default event.
	See Monitor>>waitWhile: aBlock."

	^ self waitUntil: aBlock for: nil! !

!Monitor methodsFor: 'waiting-specific' stamp: ''!
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: 'private' stamp: ''!
exit
	nestingLevel := nestingLevel - 1.
	nestingLevel < 1 ifTrue: [
		ownerProcess := nil.
		mutex signal
	].! !

!Monitor methodsFor: 'waiting-specific' stamp: ''!
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-basic' stamp: ''!
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: 'accessing' stamp: ''!
cleanup
	self checkOwnerProcess.
	self critical: [self privateCleanup].! !

!Monitor methodsFor: 'waiting-timeout' stamp: ''!
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: ''!
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: 'signaling-default' stamp: ''!
signal
	"One process waiting for the default event is woken up."

	^ self signal: nil! !

!Monitor methodsFor: 'private' stamp: ''!
signalQueue: anOrderedCollection
	queuesMutex critical: [
	 anOrderedCollection isEmpty ifFalse: [
			anOrderedCollection removeFirst signal ] ]! !

!Monitor methodsFor: 'waiting-timeout' stamp: ''!
waitWhile: aBlock for: aSymbolOrNil maxSeconds: aNumber
	"Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! !

!Monitor methodsFor: 'private' stamp: ''!
signalLock: aSemaphore inQueue: anOrderedCollection
	queuesMutex critical: [
		aSemaphore signal.
		anOrderedCollection remove: aSemaphore ifAbsent: [].
	].! !

!Monitor methodsFor: 'waiting-timeout' stamp: ''!
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: 'private' stamp: ''!
queueDict
	^ queueDict ifNil: [queueDict := IdentityDictionary new].! !

!Monitor methodsFor: 'waiting-timeout' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	super initialize.
	mutex := Semaphore forMutualExclusion.
	queuesMutex := Semaphore forMutualExclusion.
	nestingLevel := 0.! !

!Monitor methodsFor: 'signaling-default' stamp: ''!
signalAll
	"All processes waiting for the default event are woken up."

	^ self signalAll: nil! !

!Monitor methodsFor: 'waiting-timeout' stamp: ''!
waitMaxMilliseconds: anIntegerOrNil
	"Same as Monitor>>wait, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitFor: nil maxMilliseconds: anIntegerOrNil! !

!Monitor methodsFor: 'private' stamp: ''!
waitWhile: aBlock inQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
	[aBlock value] whileTrue: [self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil].! !

!Monitor methodsFor: 'waiting-specific' stamp: ''!
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-timeout' stamp: ''!
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: ''!
exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
	| lock delay |
	lock := queuesMutex 
		critical: [anOrderedCollection addLast: Semaphore new].
	self exit.
	anIntegerOrNil ifNil: [
		lock wait
	] ifNotNil: [
		delay := MonitorDelay signalLock: lock afterMSecs: anIntegerOrNil inMonitor: self queue: anOrderedCollection.
		lock wait.
		delay unschedule.
	].
	self enter.! !

!Monitor methodsFor: 'waiting-timeout' stamp: ''!
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: 'private' stamp: ''!
waitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
	self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil.! !

!Monitor methodsFor: 'private' stamp: ''!
isOwnerProcess
	^ Processor activeProcess == ownerProcess! !

!Monitor methodsFor: 'signaling-specific' stamp: ''!
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: 'waiting-timeout' stamp: ''!
waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil
	"Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the 
	specified time has passed."

	self checkOwnerProcess.
	self waitWhile: aBlock inQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! !

!Monitor methodsFor: 'signaling-specific' stamp: ''!
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: 'private' stamp: ''!
checkOwnerProcess
	self isOwnerProcess
		ifFalse: [self error: 'Monitor access violation'].! !

!Monitor methodsFor: 'private' stamp: ''!
enter
	self isOwnerProcess ifTrue: [
		nestingLevel := nestingLevel + 1.
	] ifFalse: [
		mutex wait.
		ownerProcess := Processor activeProcess.
		nestingLevel := 1.
	].! !

!Monitor methodsFor: 'synchronization' stamp: ''!
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: 'signaling-specific' stamp: ''!
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: 'private' stamp: ''!
signalAllInQueue: anOrderedCollection
	 queuesMutex critical: [
		anOrderedCollection removeAllSuchThat: [ :each |
				each signal.
				true ] ]! !

!Monitor methodsFor: 'waiting-timeout' stamp: ''!
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: ''!
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: ''!
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! !

!MonitorDelay commentStamp: ''!
This is a specialization of the class Delay that is used for the implementation of the class Monitor.!
!MonitorDelay methodsFor: 'private' stamp: ''!
timingPrioritySignalExpired
	"The delay time has elapsed; signal the waiting process."

	beingWaitedOn := false.
	monitor signalLock: delaySemaphore inQueue: queue.! !

!MonitorDelay methodsFor: 'private' stamp: ''!
setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection
	monitor := aMonitor.
	queue := anOrderedCollection.
	self setDelay: anInteger forSemaphore: aSemaphore.! !

!MonitorDelay class methodsFor: 'instance creation' stamp: ''!
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; yourself! !

!MonitorTest commentStamp: ''!
SUnit tests for monitors!
!MonitorTest methodsFor: 'tests - examples' stamp: ''!
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 equals: work! !

!MonitorTest methodsFor: 'tests' stamp: ''!
testWaitMaxMilliseconds
	| monitor |
	monitor := Monitor new.
	monitor critical: [ monitor waitMaxMilliseconds: 10 ].! !

!MonitorTest methodsFor: 'tests - examples' stamp: ''!
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 equals: work! !

!Month commentStamp: ''!
I represent a month.!
!Month methodsFor: 'accessing' stamp: ''!
previous 

	^ self class starting: (self start - 1)! !

!Month methodsFor: 'private' stamp: ''!
species

	^Timespan! !

!Month methodsFor: 'accessing' stamp: ''!
daysInMonth

	^ self duration days.! !

!Month methodsFor: 'converting' stamp: ''!
asMonth

	^ self! !

!Month methodsFor: 'printing' stamp: ''!
printOn: aStream 

	aStream nextPutAll: self monthName; space; print: self year .! !

!Month methodsFor: 'testing' stamp: ''!
name 

	^ self monthName! !

!Month methodsFor: 'accessing' stamp: ''!
index

	^ self monthIndex! !

!Month class methodsFor: 'instance creation' stamp: ''!
march
    ^ self month: 3! !

!Month class methodsFor: 'instance creation' stamp: ''!
november
    ^ self month: 11! !

!Month class methodsFor: 'instance creation' stamp: ''!
june
    ^ self month: 6! !

!Month class methodsFor: 'instance creation' stamp: ''!
october
    ^ self month: 10! !

!Month class methodsFor: 'accessing' stamp: ''!
indexOfMonth: aMonthName 

	1 to: 12 do: [ :i |  (aMonthName, '*' match: (MonthNames at: i)) ifTrue: [^i] ].
 	self error: aMonthName , ' is not a recognized month name'.! !

!Month class methodsFor: 'instance creation' stamp: ''!
january
    ^ self month: 1! !

!Month class methodsFor: 'instance creation' stamp: ''!
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
				offset: aDateAndTime offset.
	days := self 
		daysInMonth: adjusted month 
		forYear: adjusted year.
	^ super
		starting: adjusted
		duration: (Duration days: days)! !

!Month class methodsFor: 'instance creation' stamp: ''!
month: month year: year
	^ self year: year month: month! !

!Month class methodsFor: 'instance creation' stamp: ''!
february
    ^ self month: 2! !

!Month class methodsFor: 'instance creation' stamp: ''!
july
    ^ self month: 7! !

!Month class methodsFor: 'instance creation' stamp: ''!
september
    ^ self month: 9! !

!Month class methodsFor: 'instance creation' stamp: ''!
august
    ^ self month: 8! !

!Month class methodsFor: 'instance creation' stamp: ''!
december
    ^ self month: 12! !

!Month class methodsFor: 'accessing' stamp: ''!
nameOfMonth: anIndex

	^ MonthNames at: anIndex.! !

!Month class methodsFor: 'instance creation' stamp: ''!
year: year month: month
	"Create a Month for the given <year> and <month>.
	<month> may be a number or a String with the
	name of the month. <year> should be with 4 digits."

	^ self starting: (DateAndTime year: year month: month day: 1)! !

!Month class methodsFor: 'instance creation' stamp: ''!
month: month
	"Create a Month in the current year for the given <month>.
	<month> may be a number or a String with the name of the month."

	^ self 
		year: DateAndTime now year
		month: month! !

!Month class methodsFor: 'instance creation' stamp: ''!
may
    ^ self month: 5! !

!Month class methodsFor: 'instance creation' stamp: ''!
april
    ^ self month: 4! !

!Month class methodsFor: 'instance creation' stamp: ''!
readFrom: aStream

	| m y c |
	m := (ReadWriteStream with: '') reset.
	[(c := aStream next) isSeparator] whileFalse: [m nextPut: c].
	[(c := aStream next) isSeparator] whileTrue.
	y := (ReadWriteStream with: '') reset.
	y nextPut: c.
	[aStream atEnd] whileFalse: [y nextPut: aStream next].

	^ self 
		year: y contents asNumber
		month: (Month indexOfMonth: m contents)

"Month readFrom: 'July 1998' readStream"! !

!Month class methodsFor: 'accessing' stamp: ''!
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])! !

!MonthTest commentStamp: ''!
This is the unit test for the class Month.
!
!MonthTest methodsFor: 'running' stamp: ''!
tearDown

	month := nil.
	super tearDown.! !

!MonthTest methodsFor: 'tests' stamp: ''!
testInquiries
	self
		assert: month index equals: 7;
		assert: month name equals: #July;
		assert: month duration equals: 31 days! !

!MonthTest methodsFor: 'tests' stamp: ''!
testPreviousNext
	| n p |
	n := month next.
	p := month previous.

	self
		assert: n year equals: 1998;
		assert: n index equals: 8;
		assert: p year equals: 1998;
		assert: p index equals: 6! !

!MonthTest methodsFor: 'tests' stamp: ''!
testReadFrom
	| m |
	m := Month readFrom: 'July 1998' readStream.
	self assert: m equals: month! !

!MonthTest methodsFor: 'tests' stamp: ''!
testIndexOfMonth
	| m |
	m := #(#January #February #March #April #May #June #July #August #September #October #November #December).

	m withIndexDo: [ :item :index | self assert: (Month indexOfMonth: item) equals: 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: ''!
testNameOfMonth
	| m |
	m := #(#January #February #March #April #May #June #July #August #September #October #November #December).

	m withIndexDo: [ :item :index | self assert: (Month nameOfMonth: index) equals: 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: 'coverage' stamp: ''!
selectorsToBeIgnored

	| deprecated private special |
	deprecated := #().
	private := #( #printOn: ).
	special := #( #next ).

	^ super selectorsToBeIgnored, deprecated, private, special.! !

!MonthTest methodsFor: 'tests' stamp: ''!
testInstanceCreation
	| m1 m2 |
	m1 := Month starting: '4 July 1998' asDate.
	m2 := Month year: 1998 month: #July.
	self
		assert: month equals: m1;
		assert: month equals: m2! !

!MonthTest methodsFor: 'tests' stamp: ''!
testConverting
	self assert: month asDate equals: '1 July 1998' asDate! !

!MonthTest methodsFor: 'tests' stamp: ''!
testOffset
	"Check that the offset is maintained when creating a new instance of Month from a DateAndTime"

	| dt newMonth |

	dt := DateAndTime fromString: '2018/01/01T00:00:00+10'.
	newMonth := Month starting: dt duration: 0. "duration is ignored"
	self assert: newMonth asDateAndTime offset equals: dt offset! !

!MonthTest methodsFor: 'tests' stamp: ''!
testPrinting
	self assert: month printString equals: 'July 1998'! !

!MonthTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ Month! !

!MonthTest methodsFor: 'tests' stamp: ''!
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 assertEmpty: weeks! !

!MonthTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	month := Month year: 1998 month: 7.! !

!MonticelloBootstrap commentStamp: ''!
This class contains the required behavior to bootstrap monticello in a new image. A new image has no monticello meta-data, working copies, or whatsoever. Then, Monticello (this package) is initially loaded using an ST file in chunk format (see the CodeImporter package). Once Monticello is installed, this class is required to:

 - recreate the corresponding MC working copies for each package in the system
 - reload all methods, recreate their source code (and thus create the .changes file)

I can be created from a directory using the #inDirectory: class message. e.g.,

  MonticelloBootstrap inDirectory: 'test'.

Then, the method #loadPackageVersion: will load a specific version, and #loadBootstrapPackages will load the packages in the correct order for the corresponding version of the bootstrap.

The convenience method #bootstrapDefault will create an instance with the default parameters for bootstrap and load all bootstrap packages.

  MonticelloBootstrap bootstrapDefault!
!MonticelloBootstrap methodsFor: 'bootstrapping' stamp: 'nil'!
createWorkingCopies
	
	"For each of the packages inside the image, excepted by the Unpackaged package, create a monticello working copy.
	This is achieved by creating an instance of a working copy and snapshotting it. This generates and registers the working copy automatically."
	(RPackageOrganizer default packageNames) asSortedCollection do: [:packageName |
		packageName = RPackage defaultPackageName ifFalse: [
			SystemNotification signal: ('Creating Snapshot of: ', packageName).
			(MCWorkingCopy forPackage: (MCPackage named: packageName)) snapshot ] ]! !

!MonticelloBootstrap methodsFor: 'bootstrapping' stamp: 'nil'!
loadPackageNamed: aName

	self loadPackagesNamed: { aName }! !

!MonticelloBootstrap methodsFor: 'versions' stamp: 'nil'!
bootstrapVersionsExcept: aBlock

	^ self bootstrapVersionsSatisfying: [ :arg | (aBlock value: arg) not ]! !

!MonticelloBootstrap methodsFor: 'accessing' stamp: 'nil'!
localRepository

	^ localRepository ifNil: [
		localRepository := MCDirectoryRepository new
			directory: directory asFileReference;
			yourself.	]! !

!MonticelloBootstrap methodsFor: 'bootstrapping' stamp: 'nil'!
loadBootstrapPackagesNamed: aCollectionOfNames

	(self bootstrapVersionsSatisfying: [ :package | aCollectionOfNames includes: package name ])
		do: [ :version | self loadPackageVersion: version ].! !

!MonticelloBootstrap methodsFor: 'accessing' stamp: 'nil'!
directory: aDirectory

	directory := aDirectory! !

!MonticelloBootstrap methodsFor: 'bootstrapping' stamp: 'nil'!
loadPackageVersion: aFileName
	
	[ 	SystemNotification signal: ('Loading ', aFileName asString).
		"Use snapshot install instead of load to force loading.
		Otherwise monticello finds no changes and does not load anything."
		(self localRepository loadVersionFromFileNamed: aFileName) load.
	] on: MCMergeOrLoadWarning do: [:warning |
		SystemNotification signal: ('Warning: ', warning messageText asString).
		warning resume: true ]! !

!MonticelloBootstrap methodsFor: 'bootstrapping' stamp: 'nil'!
bootstrap

	self createWorkingCopies.
	self loadBootstrapPackages.
	
	SessionManager default registerSystemClassNamed: #SmalltalkImage.
! !

!MonticelloBootstrap methodsFor: 'bootstrapping' stamp: 'nil'!
loadBootstrapPackages

	MCCacheRepository cacheDirectory: directory.

	(self bootstrapVersionsExcept: [ :package | 
		#('Shift-ClassBuilder' 'Monticello')
			includes: package name])
		do: [ :version | self loadPackageVersion: version ].

	"We load ShiftClassBuilder at the end because it has a patch to work in the bootstrap process. The patch is used when there is no source."

	self loadBootstrapPackageNamed: 'Shift-ClassBuilder'.

	"We load lastly monticello because we are using it to reload itself.
	Othewise, we should handle the case that after loading monticello we should return to a safe place from the stack where no old methods or classes are used."
	self loadBootstrapPackageNamed: 'Monticello'! !

!MonticelloBootstrap methodsFor: 'bootstrapping' stamp: 'nil'!
loadBootstrapPackageNamed: aName

	self loadBootstrapPackagesNamed: { aName }! !

!MonticelloBootstrap methodsFor: 'bootstrapping' stamp: 'nil'!
loadPackagesNamed: aCollectionOfNames

	aCollectionOfNames do: [ :name | | filename |
		filename := self fileNameForPackageNamed: name.
		self loadPackageVersion: filename ]! !

!MonticelloBootstrap methodsFor: 'versions' stamp: 'nil'!
fileNameForPackageNamed: name

	| versionInfos |
	versionInfos := self localRepository directory files
		select: [ :fileName | (fileName basename copyUpToLast: $-) = name ].
	
	versionInfos
		ifEmpty: [ self error: 'No versionInfo for package: ', name,' in ', self localRepository directory asString ].
	versionInfos size > 1
		ifTrue: [ self error: 'More than one versionInfo for package "', name , '": ', versionInfos asArray asString ].
	
	^ versionInfos anyOne basename! !

!MonticelloBootstrap methodsFor: 'versions' stamp: 'nil'!
bootstrapVersionsSatisfying: aBlock

	^ RPackageOrganizer default packages
		select: [ :package | package name ~= RPackage defaultPackageName and: [ aBlock value: package ] ]
		thenCollect: [ :rpackage | self fileNameForPackageNamed: rpackage name ]! !

!MonticelloBootstrap class methodsFor: 'defaults' stamp: 'nil'!
defaultDirectory

	^ FileLocator localDirectory / 'package-cache'! !

!MonticelloBootstrap class methodsFor: 'instance creation' stamp: 'nil'!
inDirectory: aDirectory

	^ self new
		directory: aDirectory;
		yourself! !

!MonticelloBootstrap class methodsFor: 'instance creation' stamp: 'nil'!
bootstrapDefault

	(self inDirectory: self defaultDirectory)
		bootstrap! !

!Morph commentStamp: ''!
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: 'tiling' stamp: ''!
tileTopRight

	| max |
	max := RealEstateAgent maximumUsableArea.
	self bounds: (max topCenter corner: max rightCenter)! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
firstSubmorph
	^submorphs first! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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 - add/remove' stamp: ''!
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: 'debug and other' stamp: ''!
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: 'layout - properties' stamp: ''!
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: 'event handling' stamp: ''!
mouseStillDown: evt
	"Handle a mouse move event. The default response is to let my eventHandler, if any, handle it."! !

!Morph methodsFor: '*Morphic-Base-keymapping' stamp: ''!
kmDispatcher
	"When creating the KMDispatcher instance, load default shortcuts."

	^ self
		valueOfProperty: #kmDispatcher
		ifAbsentPut: [ 
			| kmd |
			kmd := KMDispatcher target: self.
			self initializeShortcuts: kmd.
			kmd ]! !

!Morph methodsFor: 'drop shadows' stamp: ''!
addDropShadow

	self hasDropShadow ifTrue:[^self].
	self changed.
	self hasDropShadow: true.
	self shadowOffset: 3@3.
	self layoutChanged.
	self changed.! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
isMenuItemMorph
	^false! !

!Morph methodsFor: 'layout - properties' stamp: ''!
wrapDirectionString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self wrapDirection! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
highlightForDrop: aBoolean
	self setProperty: #highlightedForDrop toValue: aBoolean.
	self changed! !

!Morph methodsFor: '*Athens-Morphic' stamp: ''!
drawKeyboardFocusOnAthensCanvas: anAthensCanvas
	"Draw the keyboard focus indication."

	self focusIndicatorMorph
		drawOnAthensCanvas: anAthensCanvas! !

!Morph methodsFor: 'geometry' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
formerPosition: formerPosition 
	formerPosition 
		ifNil: [self removeProperty: #formerPosition]
		ifNotNil: [self setProperty: #formerPosition toValue: formerPosition]! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
setShadowOffset: evt
	| handle |
	handle := HandleMorph new forEachPointDo:
		[:newPoint | self shadowPoint: newPoint].
	evt hand attachMorph: handle.
	handle startStepping.! !

!Morph methodsFor: 'menus' stamp: ''!
changeDirectionHandles
	^self wantsDirectionHandles: self wantsDirectionHandles not! !

!Morph methodsFor: 'geometry' stamp: ''!
left
	" Return the x-coordinate of my left side "

	^ bounds left! !

!Morph methodsFor: 'geometry' stamp: ''!
extent

	^ bounds extent! !

!Morph methodsFor: 'copying' stamp: ''!
duplicate
	"Make and return a duplicate of the receiver"

	| newMorph topRend |
	((topRend := self topRendererOrSelf) ~~ self) ifTrue: [^ topRend duplicate].
	newMorph := self veryDeepCopy.
	newMorph arrangeToStartStepping.
		newMorph privateOwner: nil. "no longer in world"
	^newMorph! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
highlightedForDrop
	^(self valueOfProperty: #highlightedForDrop) == true! !

!Morph methodsFor: 'drawing' stamp: ''!
show
	"Make sure this morph is on-stage."

	self visible
		ifTrue: [ ^ self ].
	self visible: true.
	self changed! !

!Morph methodsFor: 'event handling' stamp: ''!
windowEvent: anEvent
	"Host window event"! !

!Morph methodsFor: 'stepping and presenter' stamp: ''!
stopStepping
	"Stop getting sent the 'step' message."

	| w |
	w := self world.
	w ifNotNil: [w stopStepping: self].! !

!Morph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
ensureLayoutAndAddMorph: aMorph

	aMorph layoutFrame
		ifNil: [ aMorph layoutFrame: LayoutFrame identity].
	self addMorph: aMorph ! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
exportAsGIF
	
	self exportAs: 'gif' using: GIFReadWriter.! !

!Morph methodsFor: 'geometry' stamp: ''!
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: 'submorphs - add/remove' stamp: ''!
addMorphCentered: aMorph

	aMorph position: bounds center - (aMorph extent // 2).
	self addMorphFront: aMorph.! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateMiddleClick

	self simulateClickWith: MouseEvent blueButton.! !

!Morph methodsFor: 'event handling' stamp: ''!
wouldAcceptKeyboardFocus
	"Answer whether a plain mouse click on the receiver should result in a text selection there"
	^ false! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
goBehind

	owner addMorphBack: self.! !

!Morph methodsFor: 'meta-actions' stamp: ''!
potentialEmbeddingTargets
	"Return the potential targets for embedding the receiver"

	| oneUp topRend |
	(oneUp := (topRend := self topRendererOrSelf) owner) ifNil: [ ^ #() ].
	^ (oneUp morphsAt: topRend referencePosition behind: topRend unlocked: true) reject: [ :m | m isFlexMorph ]! !

!Morph methodsFor: 'layout - properties' stamp: ''!
vResizingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self vResizing! !

!Morph methodsFor: 'geometry' stamp: ''!
pointFromWorld: aPoint
	^self point: aPoint from: self world! !

!Morph methodsFor: 'events - processing' stamp: ''!
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: 'meta-actions' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
formerPosition
	^self valueOfProperty: #formerPosition! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
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: 'events - processing' stamp: ''!
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: 'geometry' stamp: ''!
positionSubmorphs
	self submorphsDo:
		[:aMorph | aMorph snapToEdgeIfAppropriate]! !

!Morph methodsFor: 'layout' stamp: ''!
fullBounds
	"Return the bounding box of the receiver and all its children. Recompute the layout if necessary."

	fullBounds ifNotNil: [ ^ fullBounds ].	"Errors at this point can be critical so make sure we catch 'em all right"
	self computeFullBounds.	"This should do it unless you don't screw up the bounds"
	^ fullBounds! !

!Morph methodsFor: 'drop shadows' stamp: ''!
toggleDropShadow
	self hasDropShadow
		ifTrue:[self removeDropShadow]
		ifFalse:[self addDropShadow].! !

!Morph methodsFor: 'layout - properties' stamp: ''!
hResizingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self hResizing! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
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: ''!
addTableLayoutMenuItems: aMenu hand: aHand
	| menu sub |
	menu := UIManager default newMenuIn: self for: self.
	menu addUpdating: #hasReverseCellsString selector: #changeReverseCells.
	menu addUpdating: #hasClipLayoutCellsString selector: #changeClipLayoutCells.
	menu addUpdating: #hasRubberBandCellsString selector: #changeRubberBandCells.
	menu addLine.
	menu add: 'change cell inset...' selector: #changeCellInset:.
	menu add: 'change min cell size...' selector: #changeMinCellSize:.
	menu add: 'change max cell size...' selector: #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' 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' 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' 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' 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' 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' 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' subMenu: sub.
	aMenu ifNotNil: [ aMenu add: 'table layout' subMenu: menu ].
	^ menu! !

!Morph methodsFor: 'menus' stamp: ''!
inspectInMorphic: evt
	Smalltalk tools inspector inspect: self! !

!Morph methodsFor: 'accessing' stamp: ''!
beUnsticky
	"If the receiver is marked as sticky, make it now be unsticky"
	extension ifNotNil: [extension sticky: false]! !

!Morph methodsFor: 'layout - properties' stamp: ''!
layoutPolicy
	"Layout specific. Return the layout policy describing how children 
	of the receiver should appear."
	^ extension ifNotNil: [ extension layoutPolicy]! !

!Morph methodsFor: 'layout' stamp: ''!
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"
	"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: 'testing' stamp: ''!
isTranslucentButNotTransparent
	"Answer true if this any of this morph is translucent but not transparent."

	^ color isColor and: [ color isTranslucentButNotTransparent ]! !

!Morph methodsFor: 'events - accessing' stamp: ''!
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: 'base - widgets' stamp: ''!
listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph

	self bounds: drawBounds.
	self fullDrawOn: aCanvas.
	(aMorph submorphs includes: self)
		ifFalse: [ aMorph addMorph: self ]! !

!Morph methodsFor: 'event handling' stamp: ''!
mouseDown: evt 
	"Handle a mouse down event. It can be handled here or in the event handler"! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
dropEnabled: aBool
	^self enableDrop: aBool! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
repelsMorph: aMorph event: ev
	^ false! !

!Morph methodsFor: 'text-anchor' stamp: ''!
hasInlineAnchorString
	^ (self textAnchorType == #inline)-> 'Inline' translated! !

!Morph methodsFor: 'base - worlds' stamp: ''!
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: 'settings' stamp: ''!
menuKeyboardControl
	^ self theme settings menuKeyboardControl! !

!Morph methodsFor: 'layout' stamp: ''!
minHeight
	"answer the receiver's minHeight"
	^ self
		valueOfProperty: #minHeight
		ifAbsent: [2]! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: 'structure' stamp: ''!
renderedMorph
	"This now  gets overridden by rendering morphs."

	^self! !

!Morph methodsFor: 'menus' stamp: ''!
changeDragAndDrop
	^self enableDragNDrop: self dragNDropEnabled not! !

!Morph methodsFor: 'recategorized' stamp: ''!
handlesDropShadowInHand
	"Answer whether the receiver will handle drop shadow drawing when picked up in the hand."

	^false! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
hasHalo: aBool
	aBool
		ifTrue:[self setProperty: #hasHalo toValue: true]
		ifFalse:[self removeProperty: #hasHalo]! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
lastSubmorph
	^submorphs last! !

!Morph methodsFor: 'card in a stack' stamp: ''!
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. "really???"
	itemToHighlight editor selectAll.
	itemToHighlight invalidRect: itemToHighlight bounds! !

!Morph methodsFor: 'wiw support' stamp: ''!
addMorphInLayer: aMorph

	submorphs do: [ :each |
		each == aMorph ifTrue: [^self].
		aMorph morphicLayerNumber < each morphicLayerNumber ifTrue: [
			^self addMorph: aMorph inFrontOf: each
		].
	].
	self addMorphBack: aMorph! !

!Morph methodsFor: 'layout' stamp: ''!
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: 'structure' stamp: ''!
isInWorld
	"Return true if this morph is in a world."

	^self world notNil! !

!Morph methodsFor: 'events - processing' stamp: ''!
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: 'accessing' stamp: ''!
highlight
	"The receiver is being asked to appear in a highlighted state.  Mostly used for textual morphs"
	self color: self highlightColor! !

!Morph methodsFor: 'events - alarms' stamp: ''!
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: 'submorphs - accessing' stamp: ''!
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: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbars
	"Answer the receiver's taskbars."
	
	^self submorphs select: [:each |
		each isTaskbar]! !

!Morph methodsFor: 'events - accessing' stamp: ''!
actionMap
	"Answer an action map"

	^self updateableActionMap! !

!Morph methodsFor: 'layout' stamp: ''!
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: 'tiling' stamp: ''!
tileRight

	| max |
	max := RealEstateAgent maximumUsableArea.
	self bounds: (max topCenter corner: max corner)! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
optimalExtent
	"Answer the submorphBounds extent plus twice our border width."
	
	^self submorphBounds extent + (self borderWidth * 2)! !

!Morph methodsFor: 'drawing' stamp: ''!
clippingBounds
	"Return the bounds to which any submorphs should be clipped if the property is set"
	^self innerBounds! !

!Morph methodsFor: 'event testing' stamp: ''!
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: 'submorphs - add/remove' stamp: ''!
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: 'change reporting' stamp: ''!
displayExtentChanged

	"
	This method is sent to all submorphs of the worldMorph when the external display extent changes (resizing the vm window).
	"! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
removeHalo
	"remove the surrounding halo (if any)"
	self primaryHand removeHaloAround: self! !

!Morph methodsFor: 'text-anchor' stamp: ''!
relativeTextAnchorPosition
	^self valueOfProperty: #relativeTextAnchorPosition! !

!Morph methodsFor: 'drop shadows' stamp: ''!
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: '*NewTools-Morphic' stamp: ''!
inspectionLayout
	<inspectorPresentationOrder: 800 title: 'Layout'>
	
	^ SpTablePresenter new 
		addColumn: (SpStringTableColumn title: 'Property' evaluated: [ :assoc | assoc key ]);
		addColumn: (SpStringTableColumn title: 'Value' evaluated: [ :assoc | assoc value ]);
		items: { 
			'layoutPolicy' -> self layoutPolicy ifNil: [ 'None' ].
			'extent' -> self extent.
			'hResizing' -> self hResizing.
			'vResizing' -> self vResizing.
			'cellInset' -> self cellInset.
			'cellPositioning' -> self cellPositioning.
			'cellSpacing' -> self cellSpacing.
			'layoutInset' -> self layoutInset.
			'listCentering' -> self listCentering.
			'listDirection' -> self listDirection.
			'listSpacing' -> self listSpacing.
			'maxCellSize' -> (self maxCellSize = SmallInteger maxVal 
				ifTrue: [ 'Infinite' ] 
				ifFalse: [ self maxCellSize ]). 
			'minCellSize' -> self minCellSize.
			'reverseTableCells' -> self reverseTableCells.
			'rubberBandCells' -> self rubberBandCells.
			'wrapCentering' -> self wrapCentering.
			'wrapDirection' -> self wrapDirection.
			};
		yourself! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: 'drawing' stamp: ''!
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: 'event handling' stamp: ''!
handlesKeyStroke: evt
	^self handlesKeyboard: evt! !

!Morph methodsFor: 'geometry' stamp: ''!
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].
	^box! !

!Morph methodsFor: 'event handling' stamp: ''!
handleKeystroke: anEvent 
	"System level event handling."
	
	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: 'event handling' stamp: ''!
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: 'geometry' stamp: ''!
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: 'accessing' stamp: ''!
borderWidth
	^self borderStyle width! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
submorphWithProperty: aSymbol
	^ submorphs detect: [:aMorph | aMorph hasProperty: aSymbol] ifNone: [nil]! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
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: 'event handling' stamp: ''!
removeLink: actionCode
	self eventHandler ifNotNil:
		[self eventHandler on: actionCode send: nil to: nil]! !

!Morph methodsFor: 'drop shadows' stamp: ''!
shadowOffset: aPoint
	"Set the current shadow offset"
	(aPoint isNil or:[ aPoint isZero ])
		ifTrue:[ self removeProperty: #shadowOffset ]
		ifFalse:[ self setProperty: #shadowOffset toValue: aPoint ].! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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 add: 'grab' selector: #grabMorph:.
	menu add: 'copy to paste buffer' selector: #copyToPasteBuffer:.
	self maybeAddCollapseItemTo: menu.
	menu add: 'delete' selector: #dismissMorph:.
	menu addLine.
	menu add: 'copy text' selector: #clipText.
	menu addLine.
	menu add: 'go behind' selector: #goBehind.
	menu add: 'add halo' selector: #addHalo:.
	menu add: 'duplicate' selector: #maybeDuplicateMorph:.
	self addEmbeddingMenuItemsTo: menu hand: evt hand.
	menu add: 'resize' selector: #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'
		selector: #inspectAt:event:
		argument: evt position.
	menu add: 'explore' selector: #inspect.
	menu lastItem
		icon: (self iconNamed: #smallInspectItIcon).
	menu addLine.
	menu add: 'show actions' selector: #showActions.
	menu addLine.
	self addDebuggingItemsTo: menu hand: evt hand.
	self addCustomMenuItems: menu hand: evt hand.
	^ menu! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
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: 'drop shadows' stamp: ''!
hasDropShadow: aBool
	aBool
		ifTrue:[self setProperty: #hasDropShadow toValue: true]
		ifFalse:[self removeProperty: #hasDropShadow]! !

!Morph methodsFor: 'geometry' stamp: ''!
leftCenter

	^ bounds leftCenter! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: 'halos and balloon help' stamp: ''!
preferredDuplicationHandleSelector
	"Answer the selector, either #addMakeSiblingHandle: or addDupHandle:, to be offered as the default in a halo open on me"

	^ #addDupHandle:! !

!Morph methodsFor: 'accessing' stamp: ''!
unlockContents
	self submorphsDo:
		[:m | m unlock]! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
dismissViaHalo
	"The user has clicked in the delete halo-handle.  This provides a hook in case some concomitant action should be taken, or if the particular morph is not one which should be put in the trash can, for example."

	self setProperty: #lastPosition toValue: self positionInWorld.
	self dismissMorph! !

!Morph methodsFor: 'menus' stamp: ''!
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: 'announcements' stamp: ''!
announcer
	^self valueOfProperty: #announcer ifAbsentPut: [ Announcer new ]! !

!Morph methodsFor: 'structure' stamp: ''!
primaryHand

        | outer |
        outer := self outermostWorldMorph ifNil: [^ nil].
        ^ outer activeHand ifNil: [outer firstHand]! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
defaultLabel
	"Answer the default label to be used"
	^ self printString truncateTo: 40! !

!Morph methodsFor: 'base - worlds' stamp: ''!
pasteUpMorph
	"Answer the closest containing morph that is a PasteUp morph"
	^ self ownerThatIsA: PasteUpMorph! !

!Morph methodsFor: 'geometry' stamp: ''!
referencePosition
	"Return the current reference position of the receiver"
	| box |
	box := self bounds.
	^box origin + (self rotationCenter * box extent).! !

!Morph methodsFor: 'event handling' stamp: ''!
handlesKeyUp: evt
	^self handlesKeyboard: evt! !

!Morph methodsFor: 'tiling' stamp: ''!
tileFull

	| max |
	max := RealEstateAgent maximumUsableArea.
	self bounds: max! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
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: '*Morphic-Base' stamp: ''!
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: '*Morphic-Base-keymapping' stamp: ''!
on: aShortcut do: anAction
	
	^ self bindKeyCombination: aShortcut toAction: anAction! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
addMorph: aMorph fullFrame: aLayoutFrame

	aMorph layoutFrame: aLayoutFrame asLayoutFrame.
	aMorph hResizing: #spaceFill; vResizing: #spaceFill.
	self addMorph: aMorph.! !

!Morph methodsFor: 'event handling' stamp: ''!
dropFiles: anEvent
	"Handle a number of files dropped from the OS"! !

!Morph methodsFor: 'accessing' stamp: ''!
wantsToBeCachedByHand
	"Return true if the receiver wants to be cached by the hand when it is dragged around.
	Note: The default implementation queries all submorphs since subclasses may have shapes that do not fill the receiver's bounds completely."

	self isTranslucentButNotTransparent ifTrue: [ ^ false ].
	self
		submorphsDo: [ :m | 
			m wantsToBeCachedByHand
				ifFalse: [ ^ false ] ].
	^ true! !

!Morph methodsFor: '*Morphic-Base-keymapping' stamp: ''!
allowsKeymapping: aBoolean

	^ self setProperty: #allowsKeymapping toValue: aBoolean! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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: 'rotate scale and flex' stamp: ''!
removeFlexShell
	self isFlexed ifTrue: [self owner removeFlexShell]! !

!Morph methodsFor: 'drawing' stamp: ''!
doesOwnRotation
	"Some morphs don't want to TransformMorph to rotate their images, but we do"
	^ false! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateMiddleMouseUp 
	"Simulate mouse button up with the left button (red button for left, blue for middle, yellow for right)"
	self simulateMouseUpWith: MouseEvent blueButton .! !

!Morph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
centerWidget: aWindow

	aWindow
			fullBounds;
			center: self center! !

!Morph methodsFor: 'accessing' stamp: ''!
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: 'naming' stamp: ''!
setNameTo: aName 
	| nameToUse nameString |
	nameToUse := aName ifNotNil: 
					[(nameString := aName asString) notEmpty ifTrue: [nameString] ifFalse: ['*']].
	self setNamePropertyTo: nameToUse	"no Texts here!!"! !

!Morph methodsFor: 'base - worlds' stamp: ''!
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: 'drawing' stamp: ''!
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: 'layout - menu' stamp: ''!
hasClipLayoutCellsString
	^ (self clipLayoutCells) -> 'clip to cell size' translated! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
openInWindowLabeled: aString inWorld: aWorld
	"Changed to include the inset margin in the bound calculation."

	^ self wrappedInWindow
		setLabel: aString;
		openInWorld: aWorld! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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: '*Morphic-Base-keymapping' stamp: ''!
removeKeyCombination: aShortcut

	self kmDispatcher removeKeyCombination: aShortcut! !

!Morph methodsFor: 'announcements' stamp: ''!
announceDeleted
	self doAnnounce: (MorphDeleted morph: self).
	self submorphs do: #announceDeleted! !

!Morph methodsFor: 'geometry' stamp: ''!
fitInWorld

	self bounds: (self bounds translatedAndSquishedToBeWithin: self world bounds).! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
exportAsBMP
	
	self exportAs: 'bmp' using: BMPReadWriter! !

!Morph methodsFor: 'private' stamp: ''!
privateSubmorphs: aCollection
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."

	submorphs := aCollection.! !

!Morph methodsFor: 'menus' stamp: ''!
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: '*Morphic-Base' stamp: ''!
on: eventName send: selector to: recipient withValue: value
	"NOTE: selector must take 3 arguments, of which value will be the *** FIRST ***"

	self eventHandler ifNil: [self eventHandler: MorphicEventHandler new].
	self eventHandler on: eventName send: selector to: recipient withValue: value! !

!Morph methodsFor: 'accessing' stamp: ''!
enabled
	"Answer whether the receiver is enabled."

	^true! !

!Morph methodsFor: 'opening' stamp: ''!
openInWorld: aWorld
	self preOpenInWorld: aWorld.
	self doOpenInWorld: aWorld.
	self postOpenInWorld: aWorld.
	self announceOpened.! !

!Morph methodsFor: 'converting' stamp: ''!
asFormOfSize: extent
	"Answer a new thumbnail for the receiver."
	| form transform rect |

	rect := self bounds scaledAndCenteredIn: (0@0 extent: extent).
	form := Form extent: rect extent depth: Display depth.
	transform := MatrixTransform2x3 withScale: form extent / self extent.
	form getCanvas
		transformBy: transform
		clippingTo: form boundingBox
		during: [ :canvas | 
			canvas 
				translateBy: self topLeft negated 
				during: [ :translatedCanvas | self fullDrawOn: translatedCanvas ] ]
		smoothing: 2.
	^ form! !

!Morph methodsFor: 'drop shadows' stamp: ''!
shadowOffset
	"Return the current shadow offset"
	
	extension ifNil: [^0@0].
	^self valueOfProperty: #shadowOffset ifAbsent:[0@0]! !

!Morph methodsFor: 'event handling' stamp: ''!
mouseStillDownStepRate
	"At what rate do I want to receive #mouseStillDown: notifications?"
	^1! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
submorphCount

	^ submorphs size! !

!Morph methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForKeysFor: aStep
	<stSpotterOrder: 15>
	(self hasProperty: #kmDispatcher) ifFalse: [^self].
	self kmDispatcher spotterForKeysFor: aStep! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
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: ''!
deleteDockingBars
	"Delete the receiver's docking bars"
	self dockingBars
		do: [:each | each delete]! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
hasSubmorphs
	^submorphs notEmpty! !

!Morph methodsFor: 'accessing' stamp: ''!
eventHandler: anEventHandler 
	"Note that morphs can share eventHandlers and all is OK. "
	self assureExtension eventHandler: anEventHandler! !

!Morph methodsFor: 'events - processing' stamp: ''!
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: 'submorphs - accessing' stamp: ''!
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: 'event handling' stamp: ''!
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: 'recategorized' stamp: ''!
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: 'halos and balloon help' stamp: ''!
addOptionalHandlesTo: aHalo box: box! !

!Morph methodsFor: 'layout - menu' stamp: ''!
hasReverseCellsString
	^ (self reverseTableCells) -> 'reverse table cells' translated! !

!Morph methodsFor: 'menu' stamp: ''!
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: 'accessing' stamp: ''!
lock: aBoolean 
	"change the receiver's lock property"
	(extension isNil and: [aBoolean not]) ifTrue: [^ self].
	self assureExtension locked: aBoolean! !

!Morph methodsFor: 'accessing' stamp: ''!
toggleStickiness
	"togle the receiver's Stickiness"
	extension ifNil: [^ self beSticky].
	extension sticky: extension sticky not! !

!Morph methodsFor: 'accessing' stamp: ''!
halosEnabled

	^ self class halosEnabled! !

!Morph methodsFor: 'layout - menu' stamp: ''!
changeReverseCells
	self reverseTableCells: self reverseTableCells not.! !

!Morph methodsFor: 'events - processing' stamp: ''!
mouseDownPriority
	"Return the default mouse down priority for the receiver"

	^ 0! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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: 'halos and balloon help' stamp: ''!
addHalo
	"Invoke a halo programatically (e.g., not from a meta gesture)"
	^self addHalo: nil! !

!Morph methodsFor: 'utilities' stamp: ''!
transparentSpacerOfSize: aPoint
	^ (Morph new extent: aPoint) color: Color transparent! !

!Morph methodsFor: '*Morphic-Base-keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher
	"Where we may attach keymaps or even on:do: local shortcuts if needed."

	aKMDispatcher attachCategory: #MorphFocusCtrlNavigation! !

!Morph methodsFor: 'event handling' stamp: ''!
tabAmongFields
	^ self theme settings tabAmongFields
		or: [self hasProperty: #tabAmongFields]! !

!Morph methodsFor: 'event handling' stamp: ''!
mouseStillDownThreshold
	"Return the number of milliseconds after which mouseStillDown: should be sent"
	^200! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
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: '*Morphic-Widgets-Windows' stamp: ''!
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: 'submorphs - accessing' stamp: ''!
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: 'change reporting' stamp: ''!
invalidRect: damageRect
	^self invalidRect: damageRect from: self! !

!Morph methodsFor: 'layout - menu' stamp: ''!
hasNoLayoutString
	^ (self layoutPolicy isNil) -> 'no layout' translated! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: 'rounding' stamp: ''!
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: ['<yes>' translated]
		ifFalse: ['<no>' translated])
		, ('round corners' translated)! !

!Morph methodsFor: 'menus' stamp: ''!
lockedString
	"Answer the string to be shown in a menu to represent the 'locked' status"
	^ (self isLocked) -> 'be locked' translated! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
privateDelete
	"Remove the receiver as a submorph of its owner"
	owner ifNotNil:[owner removeMorph: self].! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
minExtent
	"Layout specific. Return the minimum size the receiver can be represented in.
	Implementation note: When this message is sent from an owner trying to lay out its children it will traverse down the morph tree and recompute the minimal arrangement of the morphs based on which the minimal extent is returned. When a morph with some layout strategy is encountered, the morph will ask its strategy to compute the new arrangement. However, since the final size given to the receiver is unknown at the point of the query, the assumption is made that the current bounds of the receiver are the base on which the layout should be computed. This scheme prevents strange layout changes when for instance, a table is contained in another table. Unless the inner table has been resized manually (which means its bounds are already enlarged) the arrangement of the inner table will not change here. Thus the entire layout computation is basically an iterative process which may have different results depending on the incremental changes applied.
	Fixed for shrinkWrap."

	| layout minExtent extra hFit vFit |
	hFit := self hResizing.
	vFit := self vResizing.
	(hFit == #rigid and: [vFit == #rigid]) 
		ifTrue: 
			["The receiver will not adjust to parents layout by growing or shrinking,
		which means that an accurate layout defines the minimum size."

			^self fullBounds extent max: self minWidth @ self minHeight].

	"An exception -- a receiver with #shrinkWrap constraints but no children is being treated #rigid (the equivalent to a #spaceFill receiver in a non-layouting owner)"
	self hasSubmorphs 
		ifFalse: 
			[hFit == #shrinkWrap ifTrue: [hFit := #rigid].
			vFit == #shrinkWrap ifTrue: [vFit := #rigid]].
	layout := self layoutPolicy.
	layout 
		ifNil: [minExtent := 0 @ 0]
		ifNotNil: [minExtent := layout minExtentOf: self in: self layoutBounds].
	hFit == #rigid 
		ifTrue: [minExtent := self fullBounds extent x @ minExtent y]
		ifFalse: 
			[extra := self bounds width - self layoutBounds width.
			minExtent := (minExtent x + extra) @ minExtent y].
	minExtent := vFit == #rigid 
				ifTrue: [minExtent x @ self fullBounds extent y]
				ifFalse: 
					[extra := self bounds height - self layoutBounds height.
					minExtent x @ (minExtent y + extra)].
	minExtent := minExtent max: self minWidth @ self minHeight.
	^minExtent! !

!Morph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph

	self bounds: drawBounds.
	aMorph addMorphBack: self.
       ! !

!Morph methodsFor: 'events - processing' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
dropHighlightColor
	^ Color blue! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'theme' stamp: ''!
themeChanged
	"The current theme has changed.
	Update any dependent visual aspects."

	self submorphsDo: [:m | m themeChanged].
	self changed! !

!Morph methodsFor: 'drawing' stamp: ''!
drawMouseDownHighlightOn: aCanvas
	self highlightedForMouseDown ifTrue: [
		aCanvas frameRectangle: self fullBounds color: self color darker darker].! !

!Morph methodsFor: 'naming' stamp: ''!
setNamePropertyTo: aName 
	"change the receiver's externalName"
	self assureExtension externalName: aName! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
activate
	"Mark the receiver and submorphs as active (foreground)."

	self submorphsDo: [:m | m activate]! !

!Morph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
setModal: aSystemWindow
	|area mySysWin keyboardFocus|

	keyboardFocus := self activeHand keyboardFocus.
	mySysWin := self isSystemWindow ifTrue: [self] ifFalse: [self ownerThatIsA: SystemWindow].
	mySysWin ifNil: [mySysWin := self].

	mySysWin isSystemWindow ifTrue: [ 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).
	[  MorphicRenderLoop new doOneCycleWhile: [ aSystemWindow isInWorld ] ]
		ensure: [
			mySysWin isSystemWindow ifTrue: [ mySysWin modalUnlockFrom: aSystemWindow ].
			self activeHand newKeyboardFocus: keyboardFocus].
	^ aSystemWindow! !

!Morph methodsFor: 'menu' stamp: ''!
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: 'geometry' stamp: ''!
bottom
	" Return the y-coordinate of my bottom side "

	^ bounds bottom! !

!Morph methodsFor: 'drawing' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"

	super initialize.
	submorphs := EmptyArray.
	bounds := self defaultBounds.
	color := self defaultColor! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
startDrag: anItem with: anObject
	self currentHand attachMorph: anObject! !

!Morph methodsFor: 'geometry' stamp: ''!
intersects: aRectangle
	"Answer whether aRectangle, which is in World coordinates, intersects me."

	^self fullBoundsInWorld intersects: aRectangle! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateMouseUp 
	"Simulate mouse button up with the left button (red button for left, blue for middle, yellow for right)"
	self simulateMouseUpWith: MouseEvent redButton.! !

!Morph methodsFor: 'accessing' stamp: ''!
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 ifNotNil: [:ext | ext balloonText ifNotNil: [:text | 
				text asString withNoLineLongerThan: self theme settings maxBalloonHelpLineLength]]! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
setArrowheads
	"Let the user edit the size of arrowheads for this object"

	| aParameter result  |
	aParameter := self renderedMorph valueOfProperty:  #arrowSpec ifAbsent: [PolygonMorph defaultArrowSpec].
	result := Morph obtainArrowheadFor: 'Head size for arrowheads: ' translated defaultValue: aParameter asString.
	result ifNotNil:
			[self renderedMorph  setProperty: #arrowSpec toValue: result]
		ifNil:
			[ self inform: 'Invalid input']! !

!Morph methodsFor: 'macpal' stamp: ''!
flash
	| originalFill flashFill |
	
	flashFill := self flashFillStyle.
	originalFill := self fillStyle.
	
	self fillStyle: flashFill.
	
	self addAlarm: #flashFinished:original: withArguments: { flashFill . originalFill } after: 50! !

!Morph methodsFor: 'user interface' stamp: ''!
doFastReframe: ptName

	| newBounds |
	"For fast display, only higlight the rectangle during loop"
	newBounds := self boundsInWorld
		newRectButtonPressedDo: [:rectangle :cursorPoint | 
			rectangle
				withSideOrCorner: ptName
				setToPoint: cursorPoint
				minExtent: self minimumExtent
		] inWorld: self world.
	Display deferUpdatesIn: Display boundingBox while: [
		self bounds: newBounds].

	^newBounds.! !

!Morph methodsFor: 'geometry' stamp: ''!
height

	^ bounds height! !

!Morph methodsFor: 'stepping and presenter' stamp: ''!
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: 'meta-actions' stamp: ''!
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: 'menus' stamp: ''!
resistsRemovalString
	"Answer the string to be shown in a menu to represent the 
	'resistsRemoval' status"
	^ (self resistsRemoval) -> 'resist being deleted' translated! !

!Morph methodsFor: 'geometry' stamp: ''!
transformedBy: aTransform
	aTransform isIdentity ifTrue:[^self].
	aTransform isPureTranslation ifTrue:[
		^self position: (aTransform localPointToGlobal: self position).
	].
	^self addFlexShell transformedBy: aTransform! !

!Morph methodsFor: 'geometry' stamp: ''!
position

	^ bounds topLeft! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
enableDrag: aBoolean
	self setProperty: #dragEnabled toValue: aBoolean! !

!Morph methodsFor: 'classification' stamp: ''!
isTextMorph
	^false! !

!Morph methodsFor: 'updating' stamp: ''!
update: anAspect

	^ self! !

!Morph methodsFor: 'geometry' stamp: ''!
bottomRight

	^ bounds bottomRight! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateClickWith: buttons position: position
	"Did you know there's #simulateClick (left), #simulateMiddleClick, and #simulateRightClick?
	buttons - look at MouseEvent's class-side for button types"

	| noButtons hand |
	noButtons := 0.
	hand := HandMorph new mouseFocus: self; yourself.
	hand privateOwner: self.
	{ #mouseDown->buttons. #mouseUp->noButtons } do: [ :type |
		hand handleEvent: (MouseButtonEvent new 
			setType: type key
			position: position "Some Morphs report local coords"
			which: (noButtons bitXor: buttons)
			buttons: type value
			hand: hand
			stamp: Time millisecondClockValue) ].! !

!Morph methodsFor: 'macpal' stamp: ''!
flashFillStyle

	^Color black! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
myDependents
	"Improved performance dependents."
	
	^ (self valueOfProperty: #myDependents) ifNil: [ #() ]! !

!Morph methodsFor: 'copying' stamp: ''!
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: '*NewTools-Morphic' stamp: ''!
inspectorIcon

	^ self class systemIcon! !

!Morph methodsFor: 'accessing' stamp: ''!
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: 'layout - properties' stamp: ''!
cellInset
	"Layout specific. This property specifies an extra inset for each cell in the layout."
	^ self layoutProperties ifNil:[0] ifNotNil: [:props | props cellInset]! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
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: 'layout - menu' stamp: ''!
hasTableLayoutString
	| layout |
	^ ((layout := self layoutPolicy) notNil
			and: [layout isTableLayout]) ->   'table layout' translated! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
wantsRecolorHandle
	"Answer whether the receiver would like a recoloring halo handle to be put up.  Since this handle also presently affords access to the property-sheet, it is presently always allowed, even though SketchMorphs don't like regular recoloring"

	^ true! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
adoptPaneColor
	"Adopt our pane color."

	self adoptPaneColor: self paneColor! !

!Morph methodsFor: '*Athens-Morphic' stamp: ''!
fullDrawOnAthensCanvas: anAthensCanvas 
	"Draw the full Morphic structure on the given Canvas"

	self visible ifFalse: [^ self].
	(anAthensCanvas isVisible: self fullBounds) ifFalse: [^self].
	(self hasProperty: #errorOnDraw) ifTrue: [^self "drawErrorOn: aCanvas" ].

	(anAthensCanvas isVisible: self bounds) ifTrue: [ anAthensCanvas draw: self ].
	
	submorphs isEmpty ifTrue: [^self].

	self drawSubmorphsOnAthensCanvas: anAthensCanvas! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
isInSystemWindow
	"answer if the receiver is in a system window"
	^ owner isMorph and:[owner isSystemWindow or:[owner isInSystemWindow]]! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'halos and balloon help' stamp: ''!
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: 'layout - properties' stamp: ''!
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: 'structure' stamp: ''!
outermostWorldMorph

	^self world ifNil: [ self currentWorld ].! !

!Morph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnCanvasWrapperFor: anAthensCanvas 
	self drawOn: anAthensCanvas asCanvasWrapper! !

!Morph methodsFor: 'wiw support' stamp: ''!
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: 'geometry testing' stamp: ''!
containsPoint: aPoint

	^ self bounds containsPoint: aPoint! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: 'wiw support' stamp: ''!
addMorphInFrontOfLayer: aMorph

	| targetLayer |

	targetLayer := aMorph morphicLayerNumber.
	submorphs do: [ :each | | layerHere |
		each == aMorph ifTrue: [^self].
		layerHere := each morphicLayerNumber.
		"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: 'event handling' stamp: ''!
mouseLeaveDragging: evt
	"Handle a mouseLeaveLaden event, meaning the mouse just left my bounds with a button pressed or laden with submorphs."! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
defaultBalloonColor
	^ Display depth <= 2
		ifTrue: [Color white]
		ifFalse: [BalloonMorph balloonColor]! !

!Morph methodsFor: 'change reporting' stamp: ''!
addedMorph: aMorph
	"Notify the receiver that the given morph was just added."! !

!Morph methodsFor: 'menus' stamp: ''!
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: 'layout - properties' stamp: ''!
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 - menu' stamp: ''!
hasDisableTableLayoutString
	^ (self disableTableLayout) -> 'disable layout in tables' translated! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
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: (SimpleBorderStyle 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: '*Morphic-Widgets-Windows' stamp: ''!
shadowMargins
	"Answer the margins of my shadow"
	|left right top bottom deltaX deltaY|
	left := right := top := bottom := 0.
	(deltaX := self shadowOffset x) < 0 ifTrue: [ left := deltaX] ifFalse: [right := deltaX ].
	(deltaY := self shadowOffset x) < 0 ifTrue: [ top := deltaY] ifFalse: [bottom := deltaY ].
	^Margin left: left right: right top: top bottom: bottom! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
grabTransform
	"Return the transform for the receiver which should be applied during grabbing"
	^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]! !

!Morph methodsFor: 'visual properties' stamp: ''!
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: 'halos and balloon help' stamp: ''!
balloonFont: aFont 
	^ self setProperty: #balloonFont toValue: aFont! !

!Morph methodsFor: 'layout - menu' stamp: ''!
changeNoLayout
	self layoutPolicy ifNil:[^self]. "already no layout"
	self layoutPolicy: nil.
	self layoutChanged.! !

!Morph methodsFor: 'settings' stamp: ''!
displayScaleFactor

	^ self currentWorld displayScaleFactor! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
formerOwner
	^self valueOfProperty: #formerOwner! !

!Morph methodsFor: 'accessing - extension' stamp: ''!
assureExtension
	"creates an extension for the receiver if needed"
	^ extension ifNil: [extension := MorphExtension new]! !

!Morph methodsFor: 'geometry' stamp: ''!
goHome
	| box fb |
	owner ifNil: [^ self].
	self visible ifFalse: [^ self].

	box := owner visibleClearArea.
	fb := self fullBounds.

	fb left < box left
		ifTrue: [self left: box left - fb left + self left].
	fb right > box right
		ifTrue: [self right: box right - fb right + self right].

	fb top < box top
		ifTrue: [self top: box top - fb top + self top].
	fb bottom > box bottom
		ifTrue: [self bottom: box bottom - fb bottom + self bottom].! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
submorphsDo: aBlock 
	submorphs do: aBlock! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
focusIndicatorCornerRadius
	"Answer the corner radius preferred for the focus indicator
	for the receiver for themes that support this."

	^self theme focusIndicatorCornerRadiusFor: self! !

!Morph methodsFor: 'drawing' stamp: ''!
hasClipSubmorphsString
	"Answer a string that represents the clip-submophs checkbox"
	^ (self clipSubmorphs) -> 'provide clipping' translated! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
embedInWindow

	| window worldToUse |

	worldToUse := self world.		"I'm assuming we are already in a world"
	window := (SystemWindow labelled: self defaultLabel) model: nil.
	window bounds: ((self position - ((0@window labelHeight) + window borderWidth))
						corner: self bottomRight + window borderWidth).
	window addMorph: self frame: (0@0 extent: 1@1).
	window updatePaneColors.
	worldToUse addMorph: window.
	window activate! !

!Morph methodsFor: 'structure' stamp: ''!
firstOwnerSuchThat: conditionBlock

	self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [^ m]].
	^ nil! !

!Morph methodsFor: 'layout' stamp: ''!
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: '*NewTools-Morphic' stamp: ''!
inspectionMorph
	<inspectorPresentationOrder: 90 title: 'Morph'>

	^ SpMorphPresenter new
		morph: self imageForm asMorph;
		yourself! !

!Morph methodsFor: 'layout' stamp: ''!
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: '*Spec2-Adapters-Morphic' stamp: ''!
presenter

	^ self valueOfProperty: #presenter ifAbsent: [ nil ]! !

!Morph methodsFor: 'layout' stamp: ''!
computeBounds
	[ self doLayoutIn: self layoutBounds ]
		on: Error
		do: [ :ex | 
			"This should do it unless you don't screw up the bounds"
			fullBounds := bounds.
			ex pass ]! !

!Morph methodsFor: 'drop shadows' stamp: ''!
hasDropShadowString
	^ (self hasDropShadow) ->  'show shadow' translated! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
exportAsPNG

	self exportAs: 'png' using: PNGReadWriter! !

!Morph methodsFor: 'accessing - extension' stamp: ''!
privateExtension: aMorphExtension
	"private - change the receiver's extension"
	extension := aMorphExtension! !

!Morph methodsFor: 'event handling' stamp: ''!
hasFocus
	^ false! !

!Morph methodsFor: 'drawing' stamp: ''!
visible
	"answer whether the receiver is visible"
	^ extension ifNil: [ true ] ifNotNil: [ :ext | ext visible ]! !

!Morph methodsFor: 'private' stamp: ''!
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: '*NewTools-Spotter-Extensions' stamp: ''!
spotterPreview: aBuilder

	^ aBuilder newImage 
		image: (self asFormOfSize: 300@300);
		yourself! !

!Morph methodsFor: 'recategorized' stamp: ''!
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: 'layout' stamp: ''!
minHeight: aNumber 
	aNumber 
		ifNil: [self removeProperty: #minHeight]
		ifNotNil: [self setProperty: #minHeight toValue: aNumber].
	self layoutChanged! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'events - alarms' stamp: ''!
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: 'drop shadows' stamp: ''!
shadowPoint: newPoint
	self changed.
	self shadowOffset: newPoint - self center // 5.
	fullBounds ifNotNil:[fullBounds := self privateFullBounds].
	self changed.! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'classification' stamp: ''!
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: '*Morphic-Widgets-Windows' stamp: ''!
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: 'accessing' stamp: ''!
highlightColor
	
	^ (self valueOfProperty: #highlightColor)
		ifNotNil:
			[:val | val ifNil: [self error: 'nil highlightColor']]
		ifNil:
			[owner ifNil: [self color] ifNotNil: [owner highlightColor]]! !

!Morph methodsFor: 'stepping and presenter' stamp: ''!
isStepping
	"Return true if the receiver is currently stepping in its world"
	| aWorld |
	^ (aWorld := self world)
		ifNil:		[false]
		ifNotNil:	[aWorld isStepping: self]! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
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: 'accessing' stamp: ''!
borderWidthForRounding

	^ self borderWidth! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
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: '*Morphic-Widgets-ColorPicker' stamp: ''!
changeColor
	
	| dialog |
	dialog := ColorSelectorDialogWindow new
		title: 'Choose color';
		selectedColor: self color.
	dialog openModal.
	dialog cancelled
		ifFalse: [self fillStyle: dialog selectedColor]! !

!Morph methodsFor: 'structure' stamp: ''!
withAllOwnersDo: aBlock
	"Evaluate aBlock with the receiver and all of its owners"
	aBlock value: self.
	owner ifNotNil:[^owner withAllOwnersDo: aBlock].! !

!Morph methodsFor: 'menus' stamp: ''!
addExportMenuItems: aMenu hand: aHandMorph
	"Add export items to the menu"

	aMenu
		ifNotNil: [ | aSubMenu |
			aSubMenu := UIManager default newMenuIn: self for: self.
			aSubMenu add: 'BMP file' selector: #exportAsBMP.
			aSubMenu add: 'GIF file' selector: #exportAsGIF.
			aSubMenu add: 'JPEG file' selector: #exportAsJPEG.
			aSubMenu add: 'PNG file' selector: #exportAsPNG.
			aMenu
				add: 'export...'
				icon: (self iconNamed: #smallExportIcon)
				subMenu: aSubMenu.
			aMenu lastItem
				icon: (self iconNamed: #smallExportIcon) ]! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateClick

	self simulateClickWith: MouseEvent redButton.! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
changeMaxCellSize: evt
	| handle |
	handle := HandleMorph new forEachPointDo:[:newPoint |
		self maxCellSize: (newPoint - evt cursorPoint) asIntegerPoint].
	evt hand attachMorph: handle.
	handle startStepping.! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
focusIndicatorMorph
	"Answer the focus indicator morph for the receiver."

	^self theme focusIndicatorMorphFor: self! !

!Morph methodsFor: 'base - worlds' stamp: ''!
viewBox
	^ self pasteUpMorph viewBox! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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: 'event handling' stamp: ''!
handlesKeyboard: evt
	"Return true if the receiver wishes to handle the given keyboard event"
	self eventHandler ifNotNil: [^ self eventHandler handlesKeyboard: evt].
	^ false! !

!Morph methodsFor: 'rotate scale and flex' stamp: ''!
scale: newScale
	"Backstop for morphs that don't have to do something special to set their scale"! !

!Morph methodsFor: 'deferred message' stamp: ''!
defer: aValuable
	"aValuable will be executed in the next UI rendering cycle"
	self owner 
		ifNotNil: [ self owner defer: aValuable] 
		ifNil: [ UIManager default defer: aValuable ]! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
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: 'stepping and presenter' stamp: ''!
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: 'layout - properties' stamp: ''!
cellSpacingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self cellSpacing! !

!Morph methodsFor: 'events - alarms' stamp: ''!
alarmScheduler
	"Return the scheduler being responsible for triggering alarms"
	^self world! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
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: '*Morphic-Base' stamp: ''!
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: 'private' stamp: ''!
privateSubmorphs
	"Private!! Use 'submorphs' instead."

	^ submorphs! !

!Morph methodsFor: 'text-anchor' stamp: ''!
hasDocumentAnchorString
	^ (self textAnchorType == #document) ->  'Document' translated! !

!Morph methodsFor: 'text-anchor' stamp: ''!
hasParagraphAnchorString
	^ (self textAnchorType == #paragraph) -> 'Paragraph' translated! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
enableDrop: aBoolean
	self setProperty: #dropEnabled toValue: aBoolean! !

!Morph methodsFor: 'debug and other' stamp: ''!
addDebuggingItemsTo: aMenu hand: aHandMorph
	aMenu add: 'debug...' subMenu: (self buildDebugMenu: aHandMorph).
	aMenu lastItem icon: (self iconNamed: #smallDebugIcon)! !

!Morph methodsFor: 'events - processing' stamp: ''!
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: 'drawing' stamp: ''!
changeClipSubmorphs
	self clipSubmorphs: self clipSubmorphs not.! !

!Morph methodsFor: 'private' stamp: ''!
privateBounds: boundsRect
	"Private!! Use position: and/or extent: instead."

	fullBounds := nil.
	bounds := boundsRect.! !

!Morph methodsFor: 'geometry' stamp: ''!
bottomLeft

	^ bounds bottomLeft! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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 submorphs select: [ :m | (m fullContainsPoint: aPoint) and: [ m isLocked not ] ]! !

!Morph methodsFor: 'drop shadows' stamp: ''!
shadowColor
	^self valueOfProperty: #shadowColor ifAbsent:[Color black]! !

!Morph methodsFor: 'layout - properties' stamp: ''!
cellPositioningString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self cellPositioning! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
setCenteredBalloonText: aString
	self setBalloonText: aString.! !

!Morph methodsFor: 'layout' stamp: ''!
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: 'event handling' stamp: ''!
mouseEnter: evt
	"Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed"! !

!Morph methodsFor: 'tiling' stamp: ''!
tileBottom

	| max |
	max := RealEstateAgent maximumUsableArea.
	self bounds: (max leftCenter corner: max corner)! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
addMorphFrontFromWorldPosition: aMorph
	^self addMorphFront: aMorph fromWorldPosition: aMorph positionInWorld.! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
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: 'submorphs - add/remove' stamp: ''!
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: 'theme' stamp: ''!
theme
	"Answer the current theme for the receiver."

	(self valueOfProperty: #theme) ifNotNil: [:t | ^ t].
	^(self owner ifNil: [self class]) theme! !

!Morph methodsFor: 'viewer' stamp: ''!
externalName
	^ self assureExtension externalName ifNil: [self printString]! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
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: 'geometry' stamp: ''!
pointInWorld: aPoint
	^self point: aPoint in: self world! !

!Morph methodsFor: 'geometry' stamp: ''!
screenLocation
	"For compatibility only"

	^ self fullBounds origin! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'settings' stamp: ''!
balloonHelpEnabled
	^ self theme settings balloonHelpEnabled! !

!Morph methodsFor: 'debug and other' stamp: ''!
debugDrawError
	
	(self valueOfProperty: #drawError) debug.! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
preferredCornerStyle
	"Answer the preferred corner style."

	^#square! !

!Morph methodsFor: 'initialize' stamp: ''!
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 - properties' stamp: ''!
layoutInset: aNumber
	"Return the extra inset for layouts"
	self assureTableProperties layoutInset: aNumber.
	self layoutChanged.! !

!Morph methodsFor: 'events - processing' stamp: ''!
handlesMouseMove: anEvent
	"Rules say that by default a morph gets #mouseMove if
		* the hand is not dragging anything,
			+ and some button is down,
			+ and the receiver is the current mouse focus."
			
	self eventHandler ifNotNil: [ :handler | 
		(handler handlesMouseMove: anEvent) ifTrue: [ 
			^ true ] ].
				
	^anEvent hand submorphs isEmpty and: [ 	 
		(anEvent anyButtonPressed and:[
			anEvent hand mouseFocus == self
		])]! !

!Morph methodsFor: 'geometry' stamp: ''!
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: '*Morphic-Base' stamp: ''!
justDroppedInto: aMorph event: anEvent
	"This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"

	| aWindow |
	(self formerOwner notNil and: [self formerOwner ~~ aMorph])
		ifTrue: [self removeHalo].
	self formerOwner: nil.
	self formerPosition: nil.
	(aWindow := aMorph ownerThatIsA: SystemWindow) 
		ifNotNil: [aWindow isActive 
			ifFalse: [aWindow activate]].

	"An object launched by certain parts-launcher mechanisms should end up fully visible..."
	(self hasProperty: #beFullyVisibleAfterDrop) 
		ifTrue: [aMorph == self world 
			ifTrue: [self goHome].
			self removeProperty: #beFullyVisibleAfterDrop].! !

!Morph methodsFor: 'layout - properties' stamp: ''!
disableTableLayout
	"Layout specific. Disable laying out the receiver in table layout"
	| props |
	props := self layoutProperties.
	^props ifNil:[false] ifNotNil:[props disableTableLayout].! !

!Morph methodsFor: 'change reporting' stamp: ''!
ownerChanged
	"The receiver's owner, some kind of a pasteup, has changed its layout."

	self snapToEdgeIfAppropriate! !

!Morph methodsFor: 'printing' stamp: ''!
printOn: aStream 
	super printOn: aStream.
	aStream nextPutAll: '('.
	aStream
		print: self identityHash;
		nextPutAll: ')'! !

!Morph methodsFor: 'naming' stamp: ''!
name: aName 
	(aName isString) ifTrue: [self setNameTo: aName]! !

!Morph methodsFor: 'drawing' stamp: ''!
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: 'menu' stamp: ''!
addTitleForHaloMenu: aMenu 
	aMenu buildTitle: [ :menuTitle | menuTitle
		bigTitle: self externalName;
		icon: (self iconOrThumbnailOfSize: 18);
		cellInset: 3
	]! !

!Morph methodsFor: '*Morphic-Base-keymapping' stamp: ''!
detachAllKeymapCategories

	self kmDispatcher detachAllKeymapCategories! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
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: 'event handling' stamp: ''!
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: 'base - widgets' stamp: ''!
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-Base-keymapping' stamp: ''!
allowsKeymapping

	^ self valueOfProperty: #allowsKeymapping ifAbsent: [ true]! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
boundsForBalloon

	"some morphs have bounds that are way too big"
	^self boundsInWorld! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
enableDragNDrop: aBoolean
	"Set both properties at once"
	self separateDragAndDrop.
	self enableDrag: aBoolean.
	self enableDrop: aBoolean.! !

!Morph methodsFor: 'stepping and presenter' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
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: 'layout - properties' stamp: ''!
disableTableLayout: aBool
	"Layout specific. Disable laying out the receiver in table layout"
	self assureLayoutProperties disableTableLayout: aBool.
	self layoutChanged.! !

!Morph methodsFor: 'structure' stamp: ''!
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: 'halos and balloon help' stamp: ''!
balloonFont
	^ self
		valueOfProperty: #balloonFont
		ifAbsent: [self defaultBalloonFont]! !

!Morph methodsFor: 'drawing' stamp: ''!
boundingBoxOfSubmorphs
	| aBox visibleSubmorphs |
	visibleSubmorphs := submorphs select: [ :m | m visible ].
	visibleSubmorphs ifEmpty: [ ^ bounds origin extent: self minimumExtent "so won't end up with something empty" ].
	aBox := visibleSubmorphs first fullBounds.
	visibleSubmorphs allButFirst do: [ :m | aBox := aBox quickMerge: m fullBounds ].
	^ aBox! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
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: 'geometry' stamp: ''!
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: 'halos and balloon help' stamp: ''!
hasHalo
	^self hasProperty: #hasHalo.! !

!Morph methodsFor: 'menus' stamp: ''!
lockUnlockMorph
	"If the receiver is locked, unlock it; if unlocked, lock it"

	self isLocked ifTrue: [self unlock] ifFalse: [self lock]! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
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: 'menu' stamp: ''!
buildYellowButtonMenu: aHand 
	"build the morph menu for the yellow button"
	| menu |
	menu := UIManager default newMenuIn: self for: self.
	self addNestedYellowButtonItemsTo: menu event: self activeHand lastEvent.
	^ menu! !

!Morph methodsFor: 'geometry' stamp: ''!
point: aPoint from: aReferenceMorph

	owner ifNil: [^ aPoint].
	^ (owner transformFrom: aReferenceMorph) globalPointToLocal: aPoint.! !

!Morph methodsFor: 'menus' stamp: ''!
stickinessString
	"Answer the string to be shown in a menu to represent the stickiness status"
	
	^ (self isSticky) ->  'resist being picked up' translated! !

!Morph methodsFor: 'initialize' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
wantsKeyboardFocusNavigation
	"Answer whether the receiver would like keyboard focus
	when navigated to by keyboard."

	^self wantsKeyboardFocus! !

!Morph methodsFor: 'thumbnail' stamp: ''!
iconOrThumbnailOfSize: aNumberOrPoint 
	"Answer an appropiate form to represent the receiver"

	^ self iconOrThumbnail scaledIntoFormOfSize: aNumberOrPoint! !

!Morph methodsFor: 'drawing' stamp: ''!
drawDropHighlightOn: aCanvas
	self highlightedForDrop ifTrue: [
		aCanvas frameRectangle: self fullBounds color: self dropHighlightColor].! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
balloonColor
	^ self
		valueOfProperty: #balloonColor
		ifAbsent: [self defaultBalloonColor]! !

!Morph methodsFor: 'drawing' stamp: ''!
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: 'testing' stamp: ''!
shouldDropOnMouseUp
	| former |
	former := self formerPosition ifNil:[^false].
	^(former distanceTo: self position) > 10! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
asText

	| anchor embedMorphSignal |
    anchor := TextAnchor new anchoredMorph: self.
    embedMorphSignal := (Character value: 1) asString. "required by the scanner"
    ^ Text string: embedMorphSignal attribute: anchor.! !

!Morph methodsFor: 'copying' stamp: ''!
deepCopy

	self error: 'Please use veryDeepCopy'.! !

!Morph methodsFor: 'tiling' stamp: ''!
tileBottomLeft

	| max |
	max := RealEstateAgent maximumUsableArea.
	self bounds: (max leftCenter corner: max bottomCenter)! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
navigateFocusBackward
	"Change the keyboard focus to the previous morph."

	self previousMorphWantingFocus ifNotNil: [:m |
		m takeKeyboardFocus]! !

!Morph methodsFor: 'rounding' stamp: ''!
toggleCornerRounding
	self cornerStyle == #rounded
		ifTrue: [self cornerStyle: #square]
		ifFalse: [self cornerStyle: #rounded].
	self changed! !

!Morph methodsFor: 'geometry' stamp: ''!
referencePositionInWorld

	^ self pointInWorld: self referencePosition! !

!Morph methodsFor: 'structure' stamp: ''!
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: 'accessing' stamp: ''!
userString
	"Do I have a text string to be searched on?"

	^ nil! !

!Morph methodsFor: 'geometry' stamp: ''!
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: 'shortcuts' stamp: ''!
shortcutsHandler

	^ ShortcutsHandler! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
addAllMorphs: aCollection after: anotherMorph
	^self privateAddAllMorphs: aCollection 
			atIndex: (submorphs indexOf: anotherMorph ifAbsent: [submorphs size])! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateKeyStrokes: aString

	aString do: [:c | self simulateKeyStroke: c ].! !

!Morph methodsFor: 'geometry' stamp: ''!
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: ''!
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: 'layout - properties' stamp: ''!
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: '*Morphic-Base-keymapping' stamp: ''!
dispatchKeystrokeForEvent: evt 
	self kmDispatcher dispatchKeystroke: evt! !

!Morph methodsFor: 'accessing - properties' stamp: ''!
otherProperties
	"answer the receiver's otherProperties"
	^ extension ifNotNil: [extension otherProperties]! !

!Morph methodsFor: 'menus' stamp: ''!
hasDragAndDropEnabledString
	"Answer a string to characterize the drag & drop status of the  
	receiver"
	^ (self dragNDropEnabled) -> 'accept drops' translated! !

!Morph methodsFor: 'geometry' stamp: ''!
localPointToGlobal: aPoint
	^self point: aPoint in: nil! !

!Morph methodsFor: 'geometry' stamp: ''!
right
	" Return the x-coordinate of my right side "
	^ bounds right! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
wantsBalloon
	"Answer true if receiver wants to show a balloon help text is a few moments."

	^ (self balloonText notNil) and: [self balloonHelpEnabled]! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'structure' stamp: ''!
activeHand
	| world |
   world := self world ifNil: [^ nil ].
   ^ world activeHand! !

!Morph methodsFor: 'structure' stamp: ''!
nearestOwnerThat: conditionBlock
	"Return the first enclosing morph for which aBlock evaluates to true, or nil if none"

	^ self firstOwnerSuchThat: conditionBlock! !

!Morph methodsFor: 'geometry' stamp: ''!
referencePositionInWorld: aPoint
	| localPosition |
	localPosition := owner
		ifNil: [aPoint]
		ifNotNil: [(owner transformFrom: self world) globalPointToLocal: aPoint].

	self referencePosition: localPosition! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateRightMouseUp
	"Simulate mouse button up with the left button (red button for left, blue for middle, yellow for right)"
	self simulateMouseUpWith: MouseEvent yellowButton .! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
passivate
	"Mark the receiver and submorphs as passive (background)."

	self submorphsDo: [:m | m passivate]! !

!Morph methodsFor: 'converting' stamp: ''!
asReadOnlyMorph

	^ self! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
allNonSubmorphMorphs
	"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy"

	^ OrderedCollection new! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
dragEnabled
	"Get this morph's ability to add and remove morphs via drag-n-drop."
	^(self valueOfProperty: #dragEnabled) == true! !

!Morph methodsFor: 'updating' stamp: ''!
changed: anAspect
	
	self doAnnounce: (MorphChanged new
		morph: self;
		selector: anAspect)! !

!Morph methodsFor: '*Morphic-Base-keymapping' stamp: ''!
detachKeymapCategory: aCategoryName

	self kmDispatcher detachKeymapCategory: aCategoryName.! !

!Morph methodsFor: 'geometry' stamp: ''!
minimumExtent: aPoint
	"Remember a minimumExtent, for possible future use"

	self setProperty: #minimumExtent toValue: aPoint! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
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: 'accessing - backstop' stamp: ''!
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: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForSubmorphsFor: aStep
	<stSpotterOrder: 10>
	self submorphs ifNil: [ ^ self ].
	
	aStep listProcessor
			title: 'Submorphs';
			allCandidates: [ self submorphs ];
			candidatesLimit: 5;
			filter: StFilterSubstring! !

!Morph methodsFor: 'updating' stamp: ''!
changed: anAspect with: anObject

	self doAnnounce: (MorphChangedWithArguments new
		morph: self;
		selector: anAspect;
		arguments: anObject)! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
window
	"Answer the receiver's window."

	^self ownerThatIsA: SystemWindow! !

!Morph methodsFor: 'accessing' stamp: ''!
highlightColor: aColor
	self setProperty: #highlightColor toValue: aColor! !

!Morph methodsFor: 'announcements' stamp: ''!
announceOpened
	self doAnnounce: (MorphOpened morph: self).
	self submorphs do: #announceOpened! !

!Morph methodsFor: 'event handling' stamp: ''!
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: self activeHand.
	menu
		addTitle: self externalName
		icon: (self iconOrThumbnailOfSize: 28).
	menu popUpInWorld: self currentWorld.
	^ true! !

!Morph methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
presenter: aPresenter

	self 
		setProperty: #presenter 
		toValue: aPresenter ! !

!Morph methodsFor: 'drawing' stamp: ''!
clipSubmorphs
	"Drawing specific. If this property is set, clip the receiver's  
	submorphs to the receiver's clipping bounds."
	
	extension ifNil: [^false].
	^extension clipSubmorphs ifNil: [false]! !

!Morph methodsFor: 'geometry' stamp: ''!
point: aPoint in: aReferenceMorph

	owner ifNil: [^ aPoint].
	^ (owner transformFrom: aReferenceMorph) localPointToGlobal: aPoint.! !

!Morph methodsFor: 'stepping and presenter' stamp: ''!
startStepping
	"Start getting sent the 'step' message."
	self startStepping: #stepAt: at: Time millisecondClockValue arguments: nil stepTime: nil.! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarThumbnail
	"Answer a new taskbar thumbnail for the receiver."

	^self taskThumbnailOfSize: self taskbarThumbnailExtent! !

!Morph methodsFor: 'meta-actions' stamp: ''!
maybeDuplicateMorph
	"Maybe duplicate the morph"

	^self duplicate openInHand! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
addMorphFront: aMorph
	^self privateAddMorph: aMorph atIndex: 1! !

!Morph methodsFor: 'accessing - properties' stamp: ''!
valueOfProperty: aSymbol

	"answer the value of the receiver's property named aSymbol"

	^ extension ifNotNil: [ :ext | ext valueOfProperty: aSymbol ]! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
isMenuMorph
	^false! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
disableDragNDrop
	self enableDragNDrop: false! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
paneColor: aColor
	"Explicitly set the pane color for the reveiver."

	self setProperty: #paneColor toValue: aColor.
	self adoptPaneColor! !

!Morph methodsFor: 'opening' stamp: ''!
doOpenInWorld: aWorld

	aWorld addMorph: self! !

!Morph methodsFor: 'rounding' stamp: ''!
wantsRoundedCorners
	"Return true if the receiver wants its corners rounded"
	^ self cornerStyle == #rounded! !

!Morph methodsFor: 'stepping and presenter' stamp: ''!
stopSteppingSelfAndSubmorphs
	self allMorphsDo: [:m | m stopStepping]! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: ''!
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: 'announcements' stamp: ''!
onAnnouncement: anAnnouncement do: aValuable
	self announcer when: anAnnouncement do: aValuable.! !

!Morph methodsFor: 'menus' stamp: ''!
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: '*Morphic-Widgets-Windows' stamp: ''!
dialogWindow
	"Answer the receiver's dialog window."

	^self ownerThatIsA: DialogWindowMorph! !

!Morph methodsFor: 'structure' stamp: ''!
world
	^owner ifNotNil: [owner world]! !

!Morph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	"does nothing"! !

!Morph methodsFor: 'layout - properties' stamp: ''!
listCenteringString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self listCentering! !

!Morph methodsFor: 'debug and other' stamp: ''!
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: '*Athens-Examples' stamp: ''!
openInSceneView
	^ AthensSceneView new
		scene: (AthensMorphScene new morph:self);
		openInWindow! !

!Morph methodsFor: 'geometry' stamp: ''!
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: 'printing' stamp: ''!
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: 'geometry' stamp: ''!
width: aNumber
	" Set my width; my position (top-left corner) and height will remain the same "

	self extent: aNumber asInteger@self height.! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
wantsKeyboardFocus
	"Answer whether the receiver would like keyboard focus
	in the general case (mouse action normally)."

	^self takesKeyboardFocus and: [
		self visible and: [self enabled]]! !

!Morph methodsFor: 'accessing' stamp: ''!
borderStyle

	^ extension 
		ifNil: [BorderStyle default trackColorFrom: self]
		ifNotNil: [:ext | (ext borderStyle ifNil: [BorderStyle default]) trackColorFrom: self]! !

!Morph methodsFor: 'geometry' stamp: ''!
center: aPoint
	self position: (aPoint - (self extent // 2))! !

!Morph methodsFor: 'copying' stamp: ''!
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: 'accessing' stamp: ''!
toggleLocked
	
	self lock: self isLocked not! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
justGrabbedFrom: formerOwner
	"The receiver was just grabbed from its former owner and is now attached to the hand. By default, we pass this message on if we're a renderer."
	(self isRenderer and:[self hasSubmorphs]) 
		ifTrue:[self firstSubmorph justGrabbedFrom: formerOwner].! !

!Morph methodsFor: 'layout' stamp: ''!
computeFullBounds
	[ self doLayoutIn: self layoutBounds ]
		on: Error
		do: [ :ex | 
			"This should do it unless you don't screw up the bounds"
			fullBounds := bounds.
			ex pass ]! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
resizeMorph: evt
	| handle |
	handle := HandleMorph new forEachPointDo: [ :newPoint | self extent: newPoint - self bounds topLeft ].
	evt hand attachMorph: handle.
	handle startStepping! !

!Morph methodsFor: 'thumbnail' stamp: ''!
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: 'classification' stamp: ''!
isWorldMorph

	^ false! !

!Morph methodsFor: 'converting' stamp: ''!
asForm
	
	^ self asFormOfSize: self extent! !

!Morph methodsFor: 'event handling' stamp: ''!
wantsDropFiles: anEvent
	"Return true if the receiver wants files dropped from the OS."
	^false! !

!Morph methodsFor: 'geometry' stamp: ''!
topRight

	^ bounds topRight! !

!Morph methodsFor: 'layout - menu' stamp: ''!
changeClipLayoutCells
	self invalidRect: self fullBounds.
	self clipLayoutCells: self clipLayoutCells not.
	self invalidRect: self fullBounds.! !

!Morph methodsFor: 'drawing' stamp: ''!
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: 'meta-actions' stamp: ''!
dismissMorph
	"This is called from an explicit halo destroy/delete action."

	| w |
	w := self world ifNil:[^self].
	w stopStepping: self.
	self delete! !

!Morph methodsFor: 'drawing' stamp: ''!
refreshWorld
	| aWorld |
	(aWorld := self world) ifNotNil: [aWorld displayWorldSafely]! !

!Morph methodsFor: 'geometry' stamp: ''!
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: ''!
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: 'visual properties' stamp: ''!
useDefaultFill
	"Make receiver use a solid fill style (e.g., a simple color)"
	self fillStyle: self defaultColor.! !

!Morph methodsFor: 'drawing' stamp: ''!
hide
	owner ifNil: [ ^ self ].
	self visible
		ifFalse: [ ^ self ].
	self visible: false.
	self changed! !

!Morph methodsFor: 'testing' stamp: ''!
canDrawBorder: aBorderStyle
	"Return true if the receiver can be drawn with the given border style."
	^true! !

!Morph methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
isTaskbar
	"Answer false in the general case."

	^false! !

!Morph methodsFor: 'event handling' stamp: ''!
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: 'menus' stamp: ''!
maybeAddCollapseItemTo: aMenu
	"If appropriate, add a collapse item to the given menu"

	| anOwner |
	(anOwner := self topRendererOrSelf owner) ifNotNil:
			[anOwner isWorldMorph ifTrue:
				[aMenu add: 'collapse' target: self selector: #collapse]]! !

!Morph methodsFor: 'private' stamp: ''!
privateOwner: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."

	owner := aMorph.! !

!Morph methodsFor: 'converting' stamp: ''!
asDraggableMorph
	^self! !

!Morph methodsFor: 'naming' stamp: ''!
renameTo: aName 
	"Set The morph name."

	self topRendererOrSelf setNameTo: aName.
	^aName! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
highlightForDrop
	self highlightForDrop: true! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
submorphsSatisfying: aBlock
	^ submorphs select: [:m | (aBlock value: m) == true]! !

!Morph methodsFor: 'stepping and presenter' stamp: ''!
stopSteppingSelector: aSelector
	"Stop getting sent the given message."
	| w |
	w := self world.
	w ifNotNil: [w stopStepping: self selector: aSelector].! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
delete
	"Remove the receiver as a submorph of its owner and make its 
	new owner be nil."
	
	self removeHalo.
	self activeHand ifNotNil: [ :hand |
		hand
			releaseKeyboardFocus: self;
			releaseMouseFocus: self.
	].
	owner ifNotNil:[ 
		self privateDelete.
		self announceDeleted.
	].! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
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: 'geometry' stamp: ''!
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: 'rounding' stamp: ''!
useRoundedCorners
	self cornerStyle: #rounded! !

!Morph methodsFor: 'events - processing' stamp: ''!
handleEvent: anEvent
	"Handle the given event"
	^anEvent sentTo: self.! !

!Morph methodsFor: 'menu' stamp: ''!
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 submenu |
	self addYellowButtonMenuItemsTo: aMenu event: evt.
	underMouse := self submorphThat: [ :each | each containsPoint: evt position ] ifNone: [ ^ self ].
	(underMouse addMyYellowButtonMenuItemsToSubmorphMenus and: [ underMouse hasYellowButtonMenu ])
		ifFalse: [ ^ self ].
	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: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	self submorphsDo:[:m| m adoptPaneColor: paneColor].! !

!Morph methodsFor: 'geometry' stamp: ''!
globalPointToLocal: aPoint
	^self point: aPoint from: nil! !

!Morph methodsFor: 'structure' stamp: ''!
isInDockingBar
	"answer if the receiver is in a menu bar"
	^ (owner notNil) and: [owner isDockingBar]! !

!Morph methodsFor: 'event handling' stamp: ''!
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: 'accessing - extension' stamp: ''!
resetExtension
	"reset the extension slot if it is not needed"
	(extension notNil and: [extension isDefault]) ifTrue: [extension := nil]! !

!Morph methodsFor: 'tiling' stamp: ''!
tileTop

	| max |
	max := RealEstateAgent maximumUsableArea.
	self bounds: (max topLeft corner: max rightCenter)! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
lastSubmorphRecursive
	"Answer recursive last submorph of the receiver."

	^self hasSubmorphs
		ifTrue: [self lastSubmorph lastSubmorphRecursive]
		ifFalse: [self]! !

!Morph methodsFor: 'drawing' stamp: ''!
highlightForMouseDown: aBoolean
	aBoolean 
		ifTrue:[self setProperty: #highlightedForMouseDown toValue: aBoolean]
		ifFalse:[self removeProperty: #highlightedForMouseDown. self resetExtension].
	self changed! !

!Morph methodsFor: 'layout - properties' stamp: ''!
layoutFrame
	"Layout specific. Return the layout frame describing where the  
	receiver should appear in a proportional layout"
	^ extension ifNotNil: [extension layoutFrame]! !

!Morph methodsFor: 'debug and other' stamp: ''!
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: 'drawing' stamp: ''!
expandFullBoundsForRolloverBorder: aRectangle
	| delta |
	delta := self valueOfProperty: #rolloverWidth ifAbsent: [10@10].
	^aRectangle expandBy: delta.! !

!Morph methodsFor: 'event handling' stamp: ''!
keyDown: anEvent
	"Handle a key down event. The default response is to do nothing."
	^ false! !

!Morph methodsFor: 'accessing' stamp: ''!
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: 'halos and balloon help' stamp: ''!
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: '*Morphic-Base' stamp: ''!
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: ''!
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: 'event handling' stamp: ''!
mouseMove: evt
	"Handle a mouse move event. The default response is to let my eventHandler, if any, handle it."! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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: 'event handling' stamp: ''!
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: 'menu' stamp: ''!
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: 'events - alarms' stamp: ''!
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: 'rotate scale and flex' stamp: ''!
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: 'debug and other' stamp: ''!
inspectOwnerChain
	self ownerChain inspectWithLabel: 'Owner chain for ', self printString! !

!Morph methodsFor: 'settings' stamp: ''!
cmdGesturesEnabled
	^ self class cmdGesturesEnabled! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
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: ''!
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: '*Morphic-Base-keymapping' stamp: ''!
attachKeymapCategory: aCategory
	self kmDispatcher attachCategory: aCategory.! !

!Morph methodsFor: 'geometry' stamp: ''!
top
	" Return the y-coordinate of my top side "

	^ bounds top! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
toggleVisible
	"Toggle the visibility of the receiver."

	self visible
		ifTrue: [self hide]
		ifFalse: [self show]! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
newTransformationMorph
	^TransformationMorph new! !

!Morph methodsFor: 'meta-actions' stamp: ''!
invokeMetaMenu: evt
	| menu |	
	self world ifNil: [ ^self ].
	
	menu := self buildMetaMenu: evt.
	self addTitleForHaloMenu: menu.	
	menu popUpEvent: evt in: self world! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
addHalo: evt
	| halo |
	
	self halosEnabled
		ifFalse: [ ^ self ].
		
	halo := (Smalltalk globals at: self haloClass ifAbsent: [ HaloMorph ]) new.
	halo bounds: (halo worldBoundsForMorph: self).
	halo popUpFor: self event: evt.
	^ halo! !

!Morph methodsFor: 'geometry' stamp: ''!
center

	^ bounds center! !

!Morph methodsFor: 'event handling' stamp: ''!
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: 'accessing' stamp: ''!
beTransparent
	self color: Color transparent! !

!Morph methodsFor: 'geometry' stamp: ''!
positionInWorld

	^ self pointInWorld: self position.! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
submorphsBehind: aMorph do: aBlock
	| behind |
	behind := false.
	submorphs do:
		[:m | m == aMorph ifTrue: [behind := true]
						ifFalse: [behind ifTrue: [aBlock value: m]]].! !

!Morph methodsFor: 'menus' stamp: ''!
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: 'geometry' stamp: ''!
align: aPoint1 with: aPoint2
	"Translate by aPoint2 - aPoint1."

	^ self position: self position + (aPoint2 - aPoint1)! !

!Morph methodsFor: 'drawing' stamp: ''!
imageForm

	^ self imageFormForRectangle: self fullBounds! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
wantsDirectionHandles: aBool
	self setProperty: #wantsDirectionHandles toValue: aBool! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
layoutInBounds: cellBounds
	"Layout specific. Apply the given bounds to the receiver after being layed out in its owner."
	| box aSymbol |
	
	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: '*Athens-Morphic' stamp: ''!
testAthensRender

| surf |
	surf := AthensCairoSurface extent: Display extent.

	surf drawDuring: [:can |
"		can pathTransform scaleBy: 0.5; rotateByDegrees: 30."
		self fullDrawOnAthensCanvas: can ].

	Display getCanvas drawImage: 	surf asForm  at: 0@0! !

!Morph methodsFor: 'private' stamp: ''!
privateFullBounds: boundsRect
	"Private!! Computed automatically."

	fullBounds := boundsRect.! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
hasKeyboardFocus
	"Answer whether the receiver has keyboard focus."

	^((self world ifNil: [^false]) 
		activeHand ifNil: [^false])  keyboardFocus = self! !

!Morph methodsFor: '*Morphic-Base-keymapping' stamp: ''!
handleKeystrokeWithKeymappings: aKeystrokeEvent

	self allowsKeymapping ifTrue: [
		self dispatchKeystrokeForEvent: aKeystrokeEvent.
	].! !

!Morph methodsFor: 'rotate scale and flex' stamp: ''!
rotationCenter: aPointOrNil
	"Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	aPointOrNil 
		ifNil: [self removeProperty: #rotationCenter]
		ifNotNil:[self setProperty: #rotationCenter toValue: aPointOrNil]! !

!Morph methodsFor: 'accessing' stamp: ''!
scaleFactor
	^self valueOfProperty: #scaleFactor ifAbsent: [ 1.0 ]! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
haloClass
	"Answer the name of the desired kind of HaloMorph to launch on behalf of the receiver"

	^ #HaloMorph! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'menus' stamp: ''!
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: 'stepping and presenter' stamp: ''!
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: 'geometry' stamp: ''!
boundsInWorld
	^self bounds: self bounds in: self world! !

!Morph methodsFor: 'layout - properties' stamp: ''!
layoutInset
	"Return the extra inset for layouts"

	^ self layoutProperties ifNil: [ 0 ] ifNotNil: [ :props | props layoutInset ]! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
takeKeyboardFocus
	"Make the receiver the keyboard focus for the active hand."

	self activeHand ifNotNil: [ :hand | hand newKeyboardFocus: self ]! !

!Morph methodsFor: 'event handling' stamp: ''!
keyStroke: anEvent
	"Handle a keystroke event.  The default response is to let my eventHandler, if any, handle it."
	^false! !

!Morph methodsFor: 'layout - properties' stamp: ''!
minCellSize: aPoint
	"Layout specific. This property specifies the minimal size of a table cell."
	self assureTableProperties minCellSize: aPoint.
	self layoutChanged.! !

!Morph methodsFor: 'menus' stamp: ''!
presentHelp
	"Present a help message if there is one available"

	self inform: 'Sorry, no help has been
provided here yet.'! !

!Morph methodsFor: 'private' stamp: ''!
privateAddMorph: aMorph atIndex: index
	| oldIndex myWorld itsWorld oldOwner |
	(index between: 1 and: submorphs size + 1)
		ifFalse: [ ^ self error: 'index out of range' ].
	myWorld := self world.
	oldOwner := aMorph owner.
	(oldOwner == self and: [ (oldIndex := submorphs indexOf: aMorph) > 0 ])
		ifTrue: [ 
			"aMorph's position changes within in the submorph chain"
			oldIndex < index
				ifTrue: [ 
					"moving aMorph to back"
					submorphs
						replaceFrom: oldIndex
						to: index - 2
						with: submorphs
						startingAt: oldIndex + 1.
					submorphs at: index - 1 put: aMorph ]
				ifFalse: [ 
					"moving aMorph to front"
					oldIndex - 1 to: index by: -1 do: [ :i | submorphs at: i + 1 put: (submorphs at: i) ].
					submorphs at: index put: aMorph ] ]
		ifFalse: [ 
			"adding a new morph"
			oldOwner
				ifNotNil: [ 
					itsWorld := aMorph world.
					itsWorld ifNotNil: [ self privateInvalidateMorph: aMorph ].
					itsWorld == myWorld
						ifFalse: [ aMorph outOfWorld: itsWorld ].
					oldOwner privateRemove: aMorph.
					oldOwner removedMorph: aMorph ].
			aMorph privateOwner: self.
			submorphs := submorphs copyReplaceFrom: index to: index - 1 with: (Array with: aMorph).
			itsWorld == myWorld
				ifFalse: [ aMorph intoWorld: myWorld ] ].
	myWorld ifNotNil: [ self privateInvalidateMorph: aMorph ].
	self layoutChanged.
	oldOwner == self
		ifFalse: [ 
			self addedMorph: aMorph.
			aMorph noteNewOwner: self ]! !

!Morph methodsFor: 'testing' stamp: ''!
shouldFlex
	^ self isFlexMorph.! !

!Morph methodsFor: 'layout - menu' stamp: ''!
addLayoutMenuItems: topMenu hand: aHand
	| aMenu |
	aMenu := UIManager default newMenuIn: self for: self.
	aMenu addUpdating: #hasNoLayoutString selector: #changeNoLayout.
	aMenu addUpdating: #hasProportionalLayoutString selector: #changeProportionalLayout.
	aMenu addUpdating: #hasTableLayoutString selector: #changeTableLayout.
	aMenu addLine.
	aMenu add: 'change layout inset...' selector: #changeLayoutInset:.
	aMenu addLine.
	self addCellLayoutMenuItems: aMenu hand: aHand.
	self addTableLayoutMenuItems: aMenu hand: aHand.
	topMenu ifNotNil: [ topMenu add: 'layout' subMenu: aMenu ].
	^aMenu! !

!Morph methodsFor: 'accessing - defaults' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color blue! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
changeMinCellSize: evt
	| handle |
	handle := HandleMorph new forEachPointDo:[:newPoint |
		self minCellSize: (newPoint - evt cursorPoint) asIntegerPoint].
	evt hand attachMorph: handle.
	handle startStepping.! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
defaultBalloonFont
	^ BalloonMorph balloonFont! !

!Morph methodsFor: 'layout - properties' stamp: ''!
layoutProperties
	"Return the current layout properties associated with the  
	receiver"
	^ extension ifNotNil: [ extension layoutProperties]! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: 'menus' stamp: ''!
hasDirectionHandlesString
	^ (self wantsDirectionHandles) ->  'direction handles' translated! !

!Morph methodsFor: 'geometry' stamp: ''!
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: 'opening' stamp: ''!
postOpenInWorld: aWorld

	aWorld startSteppingSubmorphsOf: self! !

!Morph methodsFor: 'events - processing' stamp: ''!
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: ''!
processEvent: anEvent
	"Process the given event using the default event dispatcher."
	^self processEvent: anEvent using: self defaultEventDispatcher! !

!Morph methodsFor: 'menus' stamp: ''!
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: 'visual properties' stamp: ''!
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: 'geometry' stamp: ''!
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: 'thumbnail' stamp: ''!
icon
	"Answer a form with an icon to represent the receiver"
	^ self valueOfProperty: #icon! !

!Morph methodsFor: 'text-anchor' stamp: ''!
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: 'geometry' stamp: ''!
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: 'caching' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas 
	| border |
	border := self borderStyle. 
	anAthensCanvas setPaint: self fillStyle.
	anAthensCanvas drawShape: self bounds.
	
	"Fill the given rectangle."
	anAthensCanvas drawShape: (self bounds insetBy: border width).

	(anAthensCanvas setStrokePaint: border).
	anAthensCanvas drawShape: (self bounds insetBy: (border width /2 asFloat)).
	

	"aBorderStyle frameRectangle: aRectangle on: self "! !

!Morph methodsFor: 'events - alarms' stamp: ''!
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: 'accessing' stamp: ''!
sticky: aBoolean 
	"change the receiver's sticky property"
	extension sticky: aBoolean! !

!Morph methodsFor: 'events - processing' stamp: ''!
handleKeyDown: anEvent
	"System level event handling."
	
	anEvent wasHandled ifTrue:[ ^ self ].
	
	self shortcutsHandler ifNotNil: [:handler | 
		handler handleKeystroke: anEvent inMorph: self.
		anEvent wasHandled ifTrue: [^ self]].
	
	(self handlesKeyDown: anEvent) ifFalse:[ ^ self ].
	anEvent wasHandled: true.
	self keyDown: anEvent.
	^ self eventHandler ifNotNil: [ :handler | handler keyDown: anEvent fromMorph: self ]! !

!Morph methodsFor: 'menu' stamp: ''!
hasYellowButtonMenu
	"Answer true if I have any items at all for a context (yellow button) menu."
	^ self wantsYellowButtonMenu! !

!Morph methodsFor: 'menus' stamp: ''!
addHaloActionsTo: aMenu
	"Add items to aMenu representing actions requestable via halo"

	| subMenu |
	subMenu := UIManager default newMenuIn: self for: self.
	subMenu 
	buildTitle: [ :menuTitle | menuTitle 
		bigTitle: self externalName
	];
	add: 'delete' selector: #dismissViaHalo.
	subMenu balloonTextForLastItem: 'Delete this object -- warning -- can be destructive!!' translated.

	self maybeAddCollapseItemTo: subMenu.
	subMenu add: 'grab' selector: #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'  selector: #resizeFromMenu.
	subMenu balloonTextForLastItem: 'Change the size of this object' translated.

	subMenu add: 'duplicate'  selector: #maybeDuplicateMorph.
	subMenu balloonTextForLastItem: 'Hand me a copy of this object'.

	subMenu addLine.

	subMenu add: 'set color'  target: self renderedMorph selector: #changeColor.
	subMenu balloonTextForLastItem: 'Change the color of this object'.

	subMenu addLine.

	subMenu add: 'inspect' target: self selector: #inspect.
	subMenu balloonTextForLastItem: 'Open an Inspector on this object'.

	aMenu add: 'halo actions...' subMenu: subMenu! !

!Morph methodsFor: 'tiling' stamp: ''!
tileLeft

	| max |
	max := RealEstateAgent maximumUsableArea.
	self bounds: (max topLeft corner: max bottomCenter)! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'event testing' stamp: ''!
simulateRightMouseDown 
	"Simulate mouse button down with the left button (red button for left, blue for middle, yellow for right)"
	self simulateMouseDownWith: MouseEvent yellowButton .! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
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: 'menus' stamp: ''!
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' selector: #useSolidFill.
	menu add: 'gradient fill' selector: #useGradientFill.
	menu add: 'bitmap fill' selector: #useBitmapFill.
	menu add: 'default fill' selector: #useDefaultFill.
	aMenu add: 'fill style' subMenu: menu.! !

!Morph methodsFor: 'geometry' stamp: ''!
worldBounds
	^ self world bounds! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
navigationKey: event
	"Check for tab key activity and change focus as appropriate.
	Check for menu key to do popup."
	
	(event key = KeyboardKey escape and: [
			event anyModifierKeyPressed]) ifTrue: [
		^ self yellowButtonActivity: false ].
	
	self window ifNotNil: [:win |
		(win handlesKeyDown: event) ifTrue: [
			(win keyDown: event) ifTrue: [^true]]].
	
	^false! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: 'drawing' stamp: ''!
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: 'menu' stamp: ''!
wantsYellowButtonMenu: aBoolean 
	"Change the receiver to wants or not a yellow button menu"
	self setProperty: #wantsYellowButtonMenu toValue: aBoolean! !

!Morph methodsFor: 'layout - menu' stamp: ''!
hasRubberBandCellsString
	^ (self rubberBandCells) -> 'rubber band cells' translated! !

!Morph methodsFor: 'structure' stamp: ''!
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: 'accessing' stamp: ''!
eventHandler
	"answer the receiver's eventHandler"
	^ extension ifNotNil: [extension eventHandler]! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
containingWindow
	"Answer a window that contains the receiver"

	^ self ownerThatIsA: SystemWindow! !

!Morph methodsFor: 'theme' stamp: ''!
basicTheme: aUITheme
	"Set the current theme for the receiver without notification of change."

	self theme = aUITheme ifFalse: [
		self setProperty: #theme toValue: aUITheme]! !

!Morph methodsFor: 'menus' stamp: ''!
model
	^ nil! !

!Morph methodsFor: 'meta-actions' stamp: ''!
maybeDuplicateMorph: evt
	^self duplicateMorph: evt! !

!Morph methodsFor: '*Commander-Activators-Mouse' stamp: ''!
enableMouseCommands: aMouseActivationClass withContextFrom: someObjectWithCommandContext

	aMouseActivationClass enableInMorph: self withCommandsFrom: someObjectWithCommandContext! !

!Morph methodsFor: 'accessing' stamp: ''!
wantsToBeTopmost
	"Answer if the receiver want to be one of the topmost objects in its owner"
	^ false! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
navigateFocusForward
	"Change the keyboard focus to the next morph."

	self nextMorphWantingFocus ifNotNil: [:m |
		m takeKeyboardFocus]! !

!Morph methodsFor: 'accessing' stamp: ''!
insetColor
	owner ifNil:[^self color].
	^ self colorForInsets! !

!Morph methodsFor: 'geometry' stamp: ''!
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: ''!
topCenter

	^ bounds topCenter! !

!Morph methodsFor: 'rotate scale and flex' stamp: ''!
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: 'layout - properties' stamp: ''!
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: 'testing' stamp: ''!
isHaloMorph
	
	^ false! !

!Morph methodsFor: 'drawing' stamp: ''!
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: 'stepping and presenter' stamp: ''!
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: ''!
arrangeToStartSteppingIn: aWorld
	"Start getting sent the 'step' message in aWorld.  Like startSteppingIn:, but without the initial one to get started'"

	aWorld ifNil: [ ^ self ].
	aWorld startStepping: self.
	self changed.! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
boundsWithinCorners
 	"Changed to be more realistic..."
	
	^self bounds insetBy: 2! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
focusBounds
	"Answer the bounds for drawing the focus indication."

	^self bounds! !

!Morph methodsFor: 'layout' stamp: ''!
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: 'halos and balloon help' stamp: ''!
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: ''!
setBalloonText: stringOrText
	"Set receiver's balloon help text. Pass nil to remove the help."

	self setBalloonText: stringOrText maxLineLength: self theme settings maxBalloonHelpLineLength! !

!Morph methodsFor: 'menus' stamp: ''!
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 selector: #setToAdhereToEdge: argument: each]].
	menu popUpEvent: self currentEvent in: self world! !

!Morph methodsFor: 'change reporting' stamp: ''!
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: 'event testing' stamp: ''!
simulateRightClick

	self simulateClickWith: MouseEvent yellowButton.! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
wantsDirectionHandles
	^self valueOfProperty: #wantsDirectionHandles ifAbsent:[false]! !

!Morph methodsFor: 'accessing - properties' stamp: ''!
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: 'selected object' stamp: ''!
selectedObject
	"answer the selected object for the hand or nil is none"
	^ self primaryHand selectedObject! !

!Morph methodsFor: 'menus' stamp: ''!
setToAdhereToEdge: anEdge
	anEdge ifNil: [^ self].
	anEdge == #none ifTrue: [^ self removeProperty: #edgeToAdhereTo].
	self setProperty: #edgeToAdhereTo toValue: anEdge.! !

!Morph methodsFor: 'layout' stamp: ''!
minWidth
	"answer the receiver's minWidth"
	^ self
		valueOfProperty: #minWidth
		ifAbsent: [2]! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
wantsHaloFromClick
	^ true! !

!Morph methodsFor: 'showing' stamp: ''!
openInHand
	"Attach the receiver to the current hand in the current morphic world"

	self currentHand attachMorph: self! !

!Morph methodsFor: 'accessing - extension' stamp: ''!
initializeExtension
	"private - initializes the receiver's extension"
	extension := MorphExtension new! !

!Morph methodsFor: 'accessing - properties' stamp: ''!
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: 'stepping and presenter' stamp: ''!
start
	"Start running my script. For ordinary morphs, this means start stepping."

	self startStepping.! !

!Morph methodsFor: 'accessing' stamp: ''!
beSticky
	"make the receiver sticky"
	self assureExtension sticky: true! !

!Morph methodsFor: 'menu' stamp: ''!
addMyYellowButtonMenuItemsToSubmorphMenus
	"Answer true if I have items to add to the context menus of my submorphs"

	^true! !

!Morph methodsFor: 'events - processing' stamp: ''!
handleKeyUp: anEvent
	"System level event handling."

	anEvent wasHandled ifTrue:[ ^ self ].
	(self handlesKeyUp: anEvent) ifFalse:[ ^ self ].
	anEvent wasHandled: true.
	self keyUp: anEvent.
	^ self eventHandler ifNotNil: [ :handler | handler keyUp: anEvent fromMorph: self ].! !

!Morph methodsFor: 'testing' stamp: ''!
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: 'meta-actions' stamp: ''!
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: '*Morphic-Widgets-Windows' stamp: ''!
nextMorphAcrossInWindow
	"Answer the next morph in the window. Traverse
	from the receiver to its next sibling or owner's next sibling etc."

	^self submorphAfter ifNil: [
		(self owner ifNil: [^self]) nextMorphAcrossInWindow]! !

!Morph methodsFor: 'layout' stamp: ''!
doLayoutIn: layoutBounds 
	"Compute a new layout based on the given layout bounds."

	"Note: Testing for #bounds or #layoutBounds would be sufficient to
	figure out if we need an invalidation afterwards but #outerBounds
	is what we need for all leaf nodes so we use that."

	| box priorBounds |
	priorBounds := self outerBounds.
	submorphs isEmpty ifTrue: [^fullBounds := priorBounds].
	"Send #ownerChanged to our children"
	submorphs do: [:m | m ownerChanged].
	self layoutPolicy ifNotNil: [:layout | layout layout: self in: layoutBounds].
	self adjustLayoutBounds.
	fullBounds := self privateFullBounds.
	box := self outerBounds.
	box = priorBounds 
		ifFalse: [self invalidRect: (priorBounds quickMerge: box)]! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
dragNDropEnabled
	"Note: This method is only useful for dragEnabled == dropEnabled at all times"
	self separateDragAndDrop.
	^self dragEnabled and:[self dropEnabled]! !

!Morph methodsFor: 'structure' stamp: ''!
owner
	"Returns the owner of this morph, which may be nil."

	^ owner! !

!Morph methodsFor: 'debug and other' stamp: ''!
resumeAfterDrawError

	self changed.
	self removeProperty:#errorOnDraw.
	self removeProperty:#drawError.
	self changed.! !

!Morph methodsFor: 'structure' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
resetHighlightForDrop
	self highlightForDrop: false! !

!Morph methodsFor: 'creation' stamp: ''!
asMorph
	^ self! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
paneColorOrNil
	"Answer the window's pane color or nil otherwise."

	^self valueOfProperty: #paneColor ifAbsent: [
		(self owner ifNil: [^nil]) paneColorOrNil]! !

!Morph methodsFor: 'user interface' stamp: ''!
initialExtent
	
	 ^(self valueOfProperty: #initialExtent) ifNil: [ 700@500 ] ifNotNil: [ :ext | ext ]! !

!Morph methodsFor: 'utilities' stamp: ''!
addTransparentSpacerOfSize: aPoint
	self addMorphBack: (self transparentSpacerOfSize: aPoint)! !

!Morph methodsFor: 'event handling' stamp: ''!
keyUp: anEvent
	"Handle a key up event. The default response is to do nothing."
	^ false! !

!Morph methodsFor: 'events - processing' stamp: ''!
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: 'geometry' stamp: ''!
screenRectangle
	"For compatibility only"

	^ self fullBounds! !

!Morph methodsFor: 'testing' stamp: ''!
isMorph

	^ true! !

!Morph methodsFor: 'drawing' stamp: ''!
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: 'events - processing' stamp: ''!
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 ].
		
	^ self eventHandler ifNotNil: [:handler | handler mouseDown: anEvent fromMorph: self ]! !

!Morph methodsFor: 'text-anchor' stamp: ''!
relativeTextAnchorPosition: aPoint
	^self setProperty: #relativeTextAnchorPosition toValue: aPoint! !

!Morph methodsFor: 'accessing' stamp: ''!
lock
	self lock: true! !

!Morph methodsFor: 'thumbnail' stamp: ''!
permitsThumbnailing
	^ true! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
findDeepSubmorphThat: block1 ifAbsent: block2 
	self
		allMorphsDo: [:m | (block1 value: m)
				== true ifTrue: [^ m]].
	^ block2 value! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
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: 'submorphs - accessing' stamp: ''!
submorphThat: block1 ifNone: block2
	^ submorphs detect: [:m | (block1 value: m) == true] ifNone: block2! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
dragSelectionColor
	^ Color magenta! !

!Morph methodsFor: 'events - processing' stamp: ''!
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: 'drawing' stamp: ''!
drawOn: aCanvas

	aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
mainDockingBars
	"Answer the receiver's main dockingBars"
	^ self dockingBars
		select: [:each | each hasProperty: #mainDockingBarTimeStamp]! !

!Morph methodsFor: 'geometry' stamp: ''!
bottomCenter

	^ bounds bottomCenter! !

!Morph methodsFor: 'event handling' stamp: ''!
moveOrResizeFromKeystroke: anEvent
	"move or resize the receiver based on a keystroke"

	| dir |
	anEvent keyValue = 28
		ifTrue: [ dir := -1 @ 0 ].
	anEvent keyValue = 29
		ifTrue: [ dir := 1 @ 0 ].
	anEvent keyValue = 30
		ifTrue: [ dir := 0 @ -1 ].
	anEvent keyValue = 31
		ifTrue: [ dir := 0 @ 1 ].
	dir notNil
		ifTrue: [ 
			anEvent controlKeyPressed
				ifTrue: [ dir := dir * 10 ].
			anEvent shiftPressed
				ifTrue: [ self extent: self extent + dir ]
				ifFalse: [ self position: self position + dir ] ]! !

!Morph methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskThumbnailOfSize: thumbExtent
	"Answer a new task thumbnail for the receiver."
	
	^ ImageMorph new
		form: (self asFormOfSize: thumbExtent);
		yourself! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: '*Morphic-Base-keymapping' stamp: ''!
detachKeymapCategory: aCategoryName targetting: anObject

	self kmDispatcher detachKeymapCategory: aCategoryName targetting: anObject! !

!Morph methodsFor: 'accessing' stamp: ''!
resistsRemoval
	"Answer whether the receiver is marked as resisting removal"

	^ self hasProperty: #resistsRemoval! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
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: 'drop shadows' stamp: ''!
removeDropShadow
	self hasDropShadow ifFalse:[^self].
	self changed.
	self hasDropShadow: false.
	self shadowOffset: 0@0.
	self layoutChanged.
	self changed.! !

!Morph methodsFor: 'structure' stamp: ''!
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: 'base - worlds' stamp: ''!
topPasteUp
	"If the receiver is in a world, return that; otherwise return the outermost pasteup morph"
	^ self outermostMorphThat: [:m | m isKindOf: PasteUpMorph]! !

!Morph methodsFor: 'meta-actions' stamp: ''!
dismissMorph: evt
	self dismissMorph! !

!Morph methodsFor: 'event handling' stamp: ''!
handlesKeyDown: evt
	^self handlesKeyboard: evt! !

!Morph methodsFor: 'drawing' stamp: ''!
highlightedForMouseDown
	^(self valueOfProperty: #highlightedForMouseDown) == true! !

!Morph methodsFor: 'classification' stamp: ''!
isHandMorph

	^ false! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
noHelpString
	^ 'Help not yet supplied' translated! !

!Morph methodsFor: 'accessing' stamp: ''!
resistsRemoval: aBoolean
	"Set the receiver's resistsRemoval property as indicated"

	aBoolean
		ifTrue: [ self setProperty: #resistsRemoval toValue: true ]
		ifFalse: [ self removeProperty: #resistsRemoval ]! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
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."
	
	self formerOwner: owner.
	self formerPosition: self position.
	^self "Grab me"! !

!Morph methodsFor: 'event handling' stamp: ''!
handlerForMouseDown: anEvent 
	"Return the (prospective) handler for a mouse down event. The handler is temporarily 
	installed and can be used for morphs further down the hierarchy to negotiate whether 
	the inner or the outer morph should finally handle the event."

	anEvent blueButtonPressed
		ifTrue: [^ self handlerForBlueButtonDown: anEvent].
	anEvent yellowButtonPressed
		ifTrue: [^ self handlerForYellowButtonDown: anEvent].
	anEvent controlKeyPressed
		ifTrue: [^ self handlerForMetaMenu: anEvent].
	(self handlesMouseDown: anEvent)
		ifFalse: [^ nil].	"not interested"

	anEvent handler
		ifNil: [^ self ].	"Same priority but I am innermost"

	"Nobody else was interested"
	^self mouseDownPriority >= anEvent handler mouseDownPriority
		ifTrue: [ self]
		ifFalse: [ nil]! !

!Morph methodsFor: 'geometry' stamp: ''!
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: 'classification' stamp: ''!
isWorldOrHandMorph

	^ self isWorldMorph or: [self isHandMorph]! !

!Morph methodsFor: 'visual properties' stamp: ''!
fillStyle
	"Return the current fillStyle of the receiver."
	
	^extension
		ifNil: [^color]
		ifNotNil: [extension fillStyle ifNil: [color]]! !

!Morph methodsFor: 'accessing - extension' stamp: ''!
hasExtension
	"answer whether the receiver has extention"
	^ extension notNil! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
openInWindowLabeled: aString

	^self openInWindowLabeled: aString inWorld: self currentWorld! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
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: 'layout - properties' stamp: ''!
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: 'accessing' stamp: ''!
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: 'debug and other' stamp: ''!
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.
	(self hasProperty: #errorOnDraw)
		ifTrue: [ aMenu add: 'start drawing again' selector: #resumeAfterDrawError ].
	(self hasProperty: #drawError)
		ifTrue: [ aMenu add: 'debug drawing error' selector: #debugDrawError.
			aMenu addLine ].
	(self hasProperty: #errorOnStep)
		ifTrue: [ aMenu add: 'start stepping again' selector: #resumeAfterStepError.
			aMenu addLine ].
	aMenu add: 'inspect morph' selector: #inspectInMorphic:.
	aMenu lastItem
		icon: (self iconNamed: #smallInspectItIcon).
	aMenu add: 'inspect owner chain' selector: #inspectOwnerChain.
	aMenu lastItem
		icon: (self iconNamed: #smallInspectItIcon).
	aMenu addLine.
	aMenu
		add: 'browse morph class'
		target: self
		selector: #browseHierarchy.
	^ aMenu! !

!Morph methodsFor: 'drop shadows' stamp: ''!
hasDropShadow

	"answer whether the receiver has DropShadow"

	^ extension
		  ifNil: [ false ]
		  ifNotNil: [ :ext | ext valueOfProperty: #hasDropShadow ifAbsent: false ]! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
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: 'event handling' stamp: ''!
cursorPoint
	^ self currentHand lastEvent cursorPoint! !

!Morph methodsFor: 'accessing' stamp: ''!
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: ''!
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: 'events - processing' stamp: ''!
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: 'updating' stamp: ''!
handleUpdate: aMorphChangedAnnouncement
	^ aMorphChangedAnnouncement deliverTo: self! !

!Morph methodsFor: 'visual properties' stamp: ''!
cornerStyle
	"Returns one of the following symbols:
		#square
		#rounded
	according to the current corner style."

	^extension 
		ifNil: [ #square ]
		ifNotNil: [ extension cornerStyle ]! !

!Morph methodsFor: 'recategorized' stamp: ''!
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: 'macpal' stamp: ''!
flashFinished: flashFill original: originalFill

	"if the color/fillstyle has changed while the flash is active, it will continue to use the new color/fill and not restrore the original"
	
	self fillStyle == flashFill ifTrue: [ 
		self fillStyle: originalFill	
	]! !

!Morph methodsFor: 'meta-actions' stamp: ''!
grabMorph: evt

	evt hand grabMorph: self! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'menus' stamp: ''!
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: 'accessing' stamp: ''!
unlock
	self lock: false! !

!Morph methodsFor: 'geometry' stamp: ''!
width

	^ bounds width! !

!Morph methodsFor: 'events - alarms' stamp: ''!
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: '*OSWindow-Core' stamp: ''!
openInExternalWindowModalCallback: aBlock
	| world |
	world := OSWindowWorldMorph new extent: self extent.
	world
		layoutPolicy: ProportionalLayout new;
		clipSubmorphs: true;
		closeCallback: [ aBlock cull: self ].

	self layoutFrame: LayoutFrame identity.
	self hResizing: #spaceFill; vResizing: #spaceFill.
	self openInWorld: world.
	self onAnnouncement: MorphDeleted do: [ :announce |
		world ifNotNil: [
			world delete
		].
		world := nil.
	].
	^ world open! !

!Morph methodsFor: 'private' stamp: ''!
privateColor: aColor

	color := aColor.! !

!Morph methodsFor: 'accessing' stamp: ''!
couldHaveRoundedCorners
	^ true! !

!Morph methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
spEnsureLayoutAndAddMorph: aMorph

	aMorph layoutFrame
		ifNil: [ aMorph layoutFrame: LayoutFrame identity].
	self addMorph: aMorph ! !

!Morph methodsFor: 'menu' stamp: ''!
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' selector: #inspect].
	aMenu addLine.
	self isWorldMorph ifFalse: [aMenu add: 'delete' selector: #delete].
	self world selectedObject == self
		ifTrue: [aMenu add: 'halo off' selector: #removeHalo]
		ifFalse: [aMenu add: 'halo on' selector: #addHalo].
	(self isWorldMorph
			or: [self wantsToBeTopmost])
		ifFalse: [
			aMenu addLine.
			aMenu add: 'send to back' selector: #goBehind.
			aMenu add: 'bring to front' selector: #comeToFront.
			self addEmbeddingMenuItemsTo: aMenu hand: evt hand].
	self isWorldMorph ifFalse: [
			self isFullOnScreen ifFalse: [aMenu add: 'move onscreen' selector: #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' selector: #copyToPasteBuffer:].
	(self allStringsAfter: nil) isEmpty ifFalse: [aMenu add: 'copy text' selector: #clipText].
	self addExportMenuItems: aMenu hand: evt hand.
	aMenu addLine.
	aMenu add: 'adhere to edge...' selector: #adhereToEdge.
	self addCustomMenuItems: aMenu hand: evt hand! !

!Morph methodsFor: 'event handling' stamp: ''!
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: 'accessing' stamp: ''!
color

	^ color 	"has already been set to ((self valueOfProperty: #fillStyle) asColor)"! !

!Morph methodsFor: '*Commander-Activators-Mouse' stamp: ''!
enableAllMouseCommandsFrom: someObjectWithCommandContext
	
	self
		enableMouseCommands: CmdClickActivation withContextFrom: someObjectWithCommandContext;
		enableMouseCommands: CmdDoubleClickActivation withContextFrom: someObjectWithCommandContext! !

!Morph methodsFor: '*Morphic-Base-keymapping' stamp: ''!
hasKeymapCategoryNamed: aString

	^ self kmDispatcher targets anySatisfy: [ :e | e category name = aString ].! !

!Morph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
heightToDisplayInTree: aTree

	^ self minExtent y! !

!Morph methodsFor: 'geometry' stamp: ''!
topLeft: aPoint
	" Move me so that my top left corner is at aPoint. My extent (width & height) are unchanged "

	self position: aPoint! !

!Morph methodsFor: 'drawing' stamp: ''!
highlightForMouseDown
	self highlightForMouseDown: true! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
focusColor
	"Answer the keyboard focus indication color."

	^self borderStyle color contrastingBlackAndWhiteColor! !

!Morph methodsFor: 'drop shadows' stamp: ''!
shadowColor: aColor
	self shadowColor = aColor ifFalse: [self changed].
	self setProperty: #shadowColor toValue: aColor.! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
dockingBars
	"Answer the receiver's dockingBars"
	^ self submorphs
		select: [:each | each isDockingBar]! !

!Morph methodsFor: 'event handling' stamp: ''!
mouseWheel: evt 
	"Handle a mouseWheel event."! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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: [ "let outer guy have it" nil ]
		ifTrue: [ "let me have it" self ]! !

!Morph methodsFor: 'event handling' stamp: ''!
preferredKeyboardPosition

	^ self preferredKeyboardBounds topLeft.! !

!Morph methodsFor: 'event handling' stamp: ''!
mouseLeave: evt
	"Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed."! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
athensSurface
	^ owner ifNotNil: [ owner athensSurface ]! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
formerOwner: aMorphOrNil 
	aMorphOrNil ifNil: [self removeProperty: #formerOwner]
		ifNotNil: [self setProperty: #formerOwner toValue: aMorphOrNil]! !

!Morph methodsFor: 'layout - menu' stamp: ''!
addCellLayoutMenuItems: aMenu hand: aHand
	"Cell (e.g., child) related items"
	| menu sub |
	menu := UIManager default newMenuIn: self for: self.
	menu addUpdating: #hasDisableTableLayoutString selector: #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' 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' subMenu: sub.
	aMenu ifNotNil: [ aMenu add: 'child layout' subMenu: menu ].
	^ menu! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
toggleDragNDrop
	"Toggle this morph's ability to add and remove morphs via drag-n-drop."

		self enableDragNDrop: self dragNDropEnabled not.! !

!Morph methodsFor: 'layout - menu' stamp: ''!
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: '*Morphic-Base' stamp: ''!
exportAsJPEG
	"Export the receiver's image as a JPEG"
	
	self exportAs: 'jpeg' using: PluginBasedJPEGReadWriter! !

!Morph methodsFor: 'accessing' stamp: ''!
borderColor
	^self borderStyle color! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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 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: 'testing' stamp: ''!
isSticky
	"answer whether the receiver is Sticky"

	^ extension ifNil: [ false ] ifNotNil: [ :ext | ext sticky ]! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateMouseUpWith: buttons
	"Simulate mouse button up with a given button"
	
	self handleEvent: (MouseButtonEvent new 
		setType: #mouseUp
		position: (self pointInWorld: self center) "Some Morphs report local coords"
		which:  buttons
		buttons: buttons
		hand: self activeHand
		stamp: Time millisecondClockValue)! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
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: 'opening' stamp: ''!
preOpenInWorld: aWorld
	"Interact with a world to decide how to position myself.
	By default, I choose the visible area of the world.
	Subclasses may choose different strategies or even calculate their bounds.
	"
	(aWorld visibleClearArea origin ~= (0@0) and: [self position = (0@0)]) ifTrue:
		[self position: aWorld visibleClearArea origin].! !

!Morph methodsFor: 'text-anchor' stamp: ''!
addTextAnchorMenuItems: topMenu hand: aHand
	| aMenu |
	aMenu := UIManager default newMenuIn: self for: self.
	aMenu addUpdating: #hasInlineAnchorString selector: #changeInlineAnchor.
	aMenu addUpdating: #hasParagraphAnchorString selector: #changeParagraphAnchor.
	aMenu addUpdating: #hasDocumentAnchorString selector: #changeDocumentAnchor.
	topMenu ifNotNil: [ topMenu add: 'text anchor' subMenu: aMenu ].
	^aMenu! !

!Morph methodsFor: 'events - processing' stamp: ''!
defaultEventDispatcher
	"Return the default event dispatcher to use with events that are directly sent to the receiver"
 	^ self class defaultEventDispatcher! !

!Morph methodsFor: 'printing' stamp: ''!
printStructureOn: aStream indent: tabCount

	tabCount timesRepeat: [aStream tab].
	self printOn: aStream.
	aStream cr.
	self submorphsDo: [:m | m printStructureOn: aStream indent: tabCount + 1].! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
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: 'layout - properties' stamp: ''!
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: 'change reporting' stamp: ''!
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: 'menus' stamp: ''!
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 selector: each second.
			aMenu balloonTextForLastItem: each third translated ].
	self couldHaveRoundedCorners
		ifFalse: [ ^ self ].
	aMenu addUpdating: #roundedCornersString selector: #toggleCornerRounding.
	aMenu balloonTextForLastItem: 'whether my corners should be rounded' translated! !

!Morph methodsFor: 'opening' stamp: ''!
openInWorld
	self openInWorld: self currentWorld! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
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: 'base - widgets' stamp: ''!
widthToDisplayInList: aList

	^ self minExtent x! !

!Morph methodsFor: 'layout - properties' stamp: ''!
wrapCenteringString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self wrapCentering! !

!Morph methodsFor: 'stepping and presenter' stamp: ''!
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: 'geometry' stamp: ''!
height: aNumber
	" Set my height; my position (top-left corner) and width will remain the same "

	self extent: self width@aNumber asInteger.! !

!Morph methodsFor: '*Morphic-Base-keymapping' stamp: ''!
attachKeymapCategory: aCategoryName onProperty: aProperty
	self kmDispatcher attachCategory: aCategoryName onProperty: aProperty! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
defaultBitmapFillForm
	^ImageMorph defaultForm.! !

!Morph methodsFor: 'layout - menu' stamp: ''!
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: 'structure' stamp: ''!
withAllOwners
	"Return the receiver and all its owners"

	^ Array streamContents: [:strm | self withAllOwnersDo: [:m | strm nextPut: m]]! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
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: 'classification' stamp: ''!
isAlignmentMorph

	^ false! !

!Morph methodsFor: '*OSWindow-Core' stamp: ''!
openInExternalWindow
	| world |
	world := OSWindowWorldMorph new extent: self fullBounds extent.
	world
		layoutPolicy: ProportionalLayout new;
		clipSubmorphs: true.

	self hResizing: #spaceFill; vResizing: #spaceFill.
	self openInWorld: world.
	self onAnnouncement: MorphDeleted do: [ :announce |
		world ifNotNil: [
			world delete
		].
		world := nil.
	].
	^ world open! !

!Morph methodsFor: 'announcements' stamp: ''!
announceKeyboardFocusChange: gotFocus
	| announcement |
	announcement := gotFocus 
						ifTrue: [ MorphGotFocus morph: self ]
						ifFalse: [ MorphLostFocus morph: self ].
	self doAnnounce: announcement.
	Morph announcer announce: announcement.! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
comeToFrontAndAddHalo
	self comeToFront.
	self addHalo! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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' subMenu: menu.
	^ menu! !

!Morph methodsFor: 'text-anchor' stamp: ''!
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: 'accessing - defaults' stamp: ''!
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"
	
	^  self theme windowColorFor: self! !

!Morph methodsFor: 'stepping and presenter' stamp: ''!
stop
	"Stop running my script. For ordinary morphs, this means stop stepping."

	self stopStepping.! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
paneColor
	"Answer the window's pane color or our color otherwise."

	^self paneColorOrNil ifNil: [self color]! !

!Morph methodsFor: 'events - alarms' stamp: ''!
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: 'event handling' stamp: ''!
click
	"Pretend the user clicked on me."

	(self handlesMouseDown: nil) ifTrue: [
		self mouseDown: nil.
		self mouseUp: nil].! !

!Morph methodsFor: 'geometry' stamp: ''!
fullBoundsInWorld
	^self bounds: self fullBounds in: self world! !

!Morph methodsFor: 'text-anchor' stamp: ''!
textAnchorType: aSymbol
	^ aSymbol == #document
		ifTrue: [ self removeProperty: #textAnchorType ]
		ifFalse: [ self setProperty: #textAnchorType toValue: aSymbol ]! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
submorphsInFrontOf: aMorph do: aBlock
	| behind |
	behind := false.
	submorphs do:
		[:m | m == aMorph ifTrue: [behind := true]
						ifFalse: [behind ifFalse: [aBlock value: m]]].! !

!Morph methodsFor: 'drawing' stamp: ''!
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: 'base - widgets' stamp: ''!
heightToDisplayInList: aList

	^ self minExtent y! !

!Morph methodsFor: 'accessing - properties' stamp: ''!
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: 'halos and balloon help' stamp: ''!
halo
	^ self primaryHand halo
		ifNotNil: [ :h | h target == self ifTrue: [ h ] ]! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: 'button' stamp: ''!
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: '*Morphic-Widgets-ColorPicker' stamp: ''!
scaledIntoFormOfSize: aSmallInteger 
	^ self imageForm scaledIntoFormOfSize: aSmallInteger! !

!Morph methodsFor: 'testing' stamp: ''!
isDockingBar
	"Return true if the receiver is a docking bar"
	^ false! !

!Morph methodsFor: 'announcements' stamp: ''!
onAnnouncement: anAnnouncement send: aMessageSelector to: anObject
	self announcer when: anAnnouncement send: aMessageSelector to: anObject.! !

!Morph methodsFor: 'drawing' stamp: ''!
imageFormDepth: depth

	^ self imageForm: depth forRectangle: self fullBounds! !

!Morph methodsFor: 'structure' stamp: ''!
allOwners
	"Return the owners of the reciever"

	^ Array streamContents: [:strm | self allOwnersDo: [:m | strm nextPut: m]]! !

!Morph methodsFor: 'theme' stamp: ''!
theme: aUITheme
	"Set the current theme for the receiver and propagate theme changed to submorphs."

	self theme = aUITheme ifFalse: [
		self setProperty: #theme toValue: aUITheme.
		"we do not invoke basicTheme: to avoid checking twice if the theme changed or not"
		self themeChanged]! !

!Morph methodsFor: 'geometry' stamp: ''!
shiftSubmorphsOtherThan: listNotToShift by: delta
	| rejectList |
	rejectList := listNotToShift ifNil: [OrderedCollection new].
	(submorphs copyWithoutAll: rejectList) do:
		[:m | m position: (m position + delta)]! !

!Morph methodsFor: 'event handling' stamp: ''!
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: 'geometry' stamp: ''!
rightCenter

	^ bounds rightCenter! !

!Morph methodsFor: 'event handling' stamp: ''!
mouseUp: evt
	"Handle a mouse up event. The default response is to let my eventHandler, if any, handle it."! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
showBalloon: msgString
	"Pop up a balloon containing the given string,
	first removing any existing BalloonMorphs in the world."
	| w |
	self showBalloon: msgString hand: ((w := self world) ifNotNil:[w activeHand]).! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph
	"I have just been added as a submorph of aMorph"! !

!Morph methodsFor: 'event handling' stamp: ''!
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: 'events - processing' stamp: ''!
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: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarButtonFor: aTaskBar
	"Answer a new task bar button for the receiver.
	Answer nil if not required."

	^nil! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: 'classification' stamp: ''!
isFlexMorph

	^ false! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
openInWindow

	^self openInWindowLabeled: self defaultLabel! !

!Morph methodsFor: 'events - processing' stamp: ''!
handleUnknownEvent: anEvent
	"An event of an unknown type was sent to the receiver. What shall we do?!!"
	self inform: 'Unknown event: ', anEvent printString. 
	anEvent printString displayAt: 0@0.
	anEvent wasHandled: true.! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'events - alarms' stamp: ''!
removeAlarm: aSelector
	"Remove the given alarm"
	| scheduler |
	scheduler := self alarmScheduler.
	scheduler ifNotNil:[scheduler removeAlarm: aSelector for: self].! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
expandFullBoundsForDropShadow: aRectangle
	"Return an expanded rectangle for an eventual drop shadow."
	
	^(aRectangle expandBy: self shadowMargins)
		quickMerge: aRectangle! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
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: 'user interface' stamp: ''!
becomeModal

	self world modalWindow: self! !

!Morph methodsFor: 'events - processing' stamp: ''!
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 - alarms' stamp: ''!
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: 'event testing' stamp: ''!
simulateMouseDownWith: buttons
	"Simulate mouse button down with a given button"
	
	self handleEvent: (MouseButtonEvent new 
		setType: #mouseDown
		position: (self pointInWorld: self center) "Some Morphs report local coords"
		which:  buttons
		buttons: buttons
		hand: self activeHand
		stamp: Time millisecondClockValue)! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
submorphsReverseDo: aBlock

	submorphs reverseDo: aBlock.! !

!Morph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
widthToDisplayInTree: aTree

	^ self minExtent x! !

!Morph methodsFor: 'menus' stamp: ''!
addStandardHaloMenuItemsTo: aMenu hand: aHandMorph
	"Add standard halo items to the menu"

	aMenu add: 'send to back' selector: #goBehind.
	aMenu add: 'bring to front' selector: #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: 'event handling' stamp: ''!
preferredKeyboardBounds

	^ self bounds: self bounds in: self world! !

!Morph methodsFor: '*Polymorph-Widgets' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^ false! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
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: '*Morphic-Widgets-Windows' stamp: ''!
wrappedInWindow
	"Changed to include the inset margin in the bound calculation."

	| window extent |
	window := SystemWindow new.
	window 
		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.
	^ window! !

!Morph methodsFor: 'accessing' stamp: ''!
borderStyle: newStyle
	newStyle = self borderStyle
		ifTrue: [ ^ self ].
	(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: 'settings' stamp: ''!
defaultYellowButtonMenuEnabled
	^ self class defaultYellowButtonMenuEnabled! !

!Morph methodsFor: 'tiling' stamp: ''!
tileCenter

	| max initial |
	max := RealEstateAgent maximumUsableArea.
	initial := self initialExtent.
	self bounds: ((max center - (initial/2)) extent: initial)! !

!Morph methodsFor: 'private' stamp: ''!
privateRemove: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."

	submorphs := submorphs copyWithout: aMorph.
	self layoutChanged.! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateMouseMove: aPointStart to: aPointEnd
"Simulates a mouse moving from a given point to a destinationpoint"
	| event |
	event := MouseMoveEvent  new 
				setType: #mouseMove  
				startPoint: aPointStart 
				endPoint: aPointEnd 
				trail: nil
				buttons: 0
				hand: self activeHand  
				stamp: 0.
	self mouseMove: event! !

!Morph methodsFor: 'copying' stamp: ''!
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: 'private' stamp: ''!
privateFullMoveBy: delta
	"Private!! Relocate me and all of my subMorphs by recursion. Subclasses that implement different coordinate systems may override this method."

	self privateMoveBy: delta.
	submorphs do: [:each | each privateFullMoveBy: delta].! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
addMorphFront: aMorph fromWorldPosition: wp

	self addMorphFront: aMorph.
	aMorph position: (self transformFromWorld globalPointToLocal: wp)! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: '*Spec-MorphicAdapters' stamp: ''!
asSpecAdapter

	^ MorphicGenericAdapter 
		morph: self! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateKeyStroke: aCharacter
	| event |

	event := KeyboardEvent new 
				setType: #keystroke 
				buttons: 0 
				position: 0@0 
				keyValue: aCharacter charCode 
				charCode: aCharacter charCode
				hand: self activeHand 
				stamp: 0.
	self keyStroke: event! !

!Morph methodsFor: 'event handling' stamp: ''!
transformFromWorld
	"Return a transform to map world coordinates into my local coordinates"

	^ self transformFrom: nil! !

!Morph methodsFor: 'layout - properties' stamp: ''!
listDirectionString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self listDirection! !

!Morph methodsFor: 'layout - menu' stamp: ''!
hasProportionalLayoutString
	| layout |
	^ ((layout := self layoutPolicy) notNil
			and: [layout isProportionalLayout]) -> 'proportional layout' translated! !

!Morph methodsFor: 'rotate scale and flex' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
myDependents: aCollectionOrNil
	"Improved performance dependents."
	
	aCollectionOrNil 
		ifNil: [self removeProperty: #myDependents]
		ifNotNil: [self setProperty: #myDependents toValue: aCollectionOrNil]! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
addHalo: evt from: formerHaloOwner
	"Transfer a halo from the former halo owner to the receiver"
	^self addHalo: evt! !

!Morph methodsFor: '*Morphic-Base-keymapping' stamp: ''!
attachKeymapCategory: aCategoryName targetting: anObject
	self kmDispatcher attachCategory: aCategoryName targetting: anObject! !

!Morph methodsFor: 'events - alarms' stamp: ''!
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: 'submorphs - add/remove' stamp: ''!
addMorph: aMorph

	self addMorphFront: aMorph.! !

!Morph methodsFor: 'accessing - properties' stamp: ''!
removeProperty: aSymbol 
	"removes the property named aSymbol if it exists"
	extension ifNil:  [^ self].
	extension removeProperty: aSymbol! !

!Morph methodsFor: 'geometry' stamp: ''!
topLeft

	^ bounds topLeft! !

!Morph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
collapse
	CollapsedMorph new beReplacementFor: self! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
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: 'caching' stamp: ''!
fullReleaseCachedState
	"Release the cached state of the receiver and its full submorph tree."

	self allMorphsDo: [:m | m releaseCachedState].! !

!Morph methodsFor: 'drawing' stamp: ''!
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: 'rounding' stamp: ''!
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: '*Morphic-Base-keymapping' stamp: ''!
bindKeyCombination: aShortcut toAction: anAction
	self kmDispatcher bindKeyCombination: aShortcut asKeyCombination toAction: anAction! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
addAllMorphs: aCollection
	^self privateAddAllMorphs: aCollection atIndex: submorphs size! !

!Morph methodsFor: 'accessing - properties' stamp: ''!
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: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarThumbnailExtent
	"Answer the size of a taskbar thumbnail for the receiver."

	^self extent min: self defaultTaskbarThumbnailExtent! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
wantsHaloFor: aSubMorph
	^ false! !

!Morph methodsFor: 'accessing - properties' stamp: ''!
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: 'layout - properties' stamp: ''!
maxCellSize: aPoint
	"Layout specific. This property specifies the maximum size of a table cell."
	self assureTableProperties maxCellSize: aPoint.
	self layoutChanged.! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
dropEnabled
	"Get this morph's ability to add and remove morphs via drag-n-drop."
	^(self valueOfProperty: #dropEnabled) == true! !

!Morph methodsFor: '*Morphic-Widgets-Menubar' stamp: ''!
isMenubar
	"Answer false in the general case."

	^false! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
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: 'accessing' stamp: ''!
raisedColor
	"Return the color to be used for shading raised borders. The 
	default is my own color, but it might want to be, eg, my 
	owner's color. Whoever's color ends up prevailing, the color 
	itself gets the last chance to determine, so that when, for 
	example, an InfiniteForm serves as the color, callers won't choke 
	on some non-Color object being returned"
	(color isColor
			and: [color isTransparent
					and: [owner notNil]])
		ifTrue: [^ owner raisedColor].
	^ color asColor raisedColor! !

!Morph methodsFor: 'events - removing' stamp: ''!
releaseActionMap
	"Release the action map"
	
 	self removeProperty: #actionMap! !

!Morph methodsFor: 'stepping and presenter' stamp: ''!
startSteppingSelector: aSelector
	"Start getting sent the 'step' message."
	self startStepping: aSelector at: Time millisecondClockValue arguments: nil stepTime: nil.! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
exportAs: anExtension using: aWriter
	
	| reference |
	reference := UIManager default
		chooseForSaveFileReference: 'Save Morph as ', anExtension asUppercase
		extensions: { anExtension }
		path: (self externalName, '.' , anExtension).
	reference ifNotNil: [ aWriter putForm: self imageForm onFileNamed: reference ]! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
editBalloonHelpText
	"Modify the receiver's balloon help text."

	self editBalloonHelpContent: self balloonText! !

!Morph methodsFor: 'accessing - extension' stamp: ''!
extension
	"answer the recevier's extension"
	^ extension! !

!Morph methodsFor: 'copying' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
drawKeyboardFocusOn: aCanvas
	"Draw the keyboard focus indication."

	self focusIndicatorMorph
		drawOn: aCanvas! !

!Morph methodsFor: 'menus' stamp: ''!
setRotationCenterFrom: aPoint
	self rotationCenter: (aPoint - self bounds origin) / self bounds extent asFloatPoint.! !

!Morph methodsFor: 'layout - menu' stamp: ''!
changeRubberBandCells
	self rubberBandCells: self rubberBandCells not.! !

!Morph methodsFor: '*Athens-Morphic' stamp: ''!
drawClippedOnAthensCanvas: anAthensCanvas during: aBlock

	^ self clipSubmorphs 
		ifTrue: [ 
			 anAthensCanvas
				clipBy: (self clippingBounds intersect: anAthensCanvas clipRect ifNone:[^ self])
				during: aBlock ] 
		ifFalse: [ aBlock value ]! !

!Morph methodsFor: 'accessing' stamp: ''!
toggleResistsRemoval
	"Toggle the resistsRemoval property"

	self resistsRemoval
		ifTrue:
			[self removeProperty: #resistsRemoval]
		ifFalse:
			[self setProperty: #resistsRemoval toValue: true]! !

!Morph methodsFor: '*Commander-SpecSupport' stamp: ''!
createCommandContextBy: aPresenter forDropAt: anEvent
	^aPresenter createCommandContextForSelection: #()! !

!Morph methodsFor: 'text-anchor' stamp: ''!
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: 'wiw support' stamp: ''!
shouldGetStepsFrom: aWorld
	^self world == aWorld! !

!Morph methodsFor: 'tiling' stamp: ''!
tileBottomRight

	| max |
	max := RealEstateAgent maximumUsableArea.
	self bounds: (max center corner: max corner)! !

!Morph methodsFor: 'updating' stamp: ''!
breakDependents
	
	self removeProperty: #announcer! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'tiling' stamp: ''!
tileTopLeft

	| max |
	max := RealEstateAgent maximumUsableArea.
	self bounds: (max topLeft corner: max center)! !

!Morph methodsFor: 'layout' stamp: ''!
minWidth: aNumber 
	aNumber 
		ifNil: [self removeProperty: #minWidth]
		ifNotNil: [self setProperty: #minWidth toValue: aNumber].
	self layoutChanged! !

!Morph methodsFor: 'event handling' stamp: ''!
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: 'halos and balloon help' stamp: ''!
balloonColor: aColor
	^ self
		setProperty: #balloonColor
		toValue: aColor! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
balloonHelpAligner
	"Answer the morph to which the receiver's balloon help should point"
	^ (self valueOfProperty: #balloonTarget) ifNil: [self]! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateMiddleMouseDown 
	"Simulate mouse button down with the left button (red button for left, blue for middle, yellow for right)"
	self simulateMouseDownWith: MouseEvent blueButton .! !

!Morph methodsFor: 'accessing' stamp: ''!
isLocked
	"answer whether the receiver is Locked"
	extension ifNil: [^ false].
	^ extension locked! !

!Morph methodsFor: 'drop shadows' stamp: ''!
addDropShadowMenuItems: aMenu hand: aHand
	| menu |
	menu := UIManager default newMenuIn: self for: self.
	menu
		addUpdating: #hasDropShadowString
		selector: #toggleDropShadow.
	menu addLine.
	menu add: 'shadow color...' target: self selector: #changeShadowColor.
	menu add: 'shadow offset...' target: self selector: #setShadowOffset:.
	aMenu add: 'drop shadow' subMenu: menu.! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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 - add/remove' stamp: ''!
addMorphBack: aMorph
	^self privateAddMorph: aMorph atIndex: submorphs size+1! !

!Morph methodsFor: 'layout - menu' stamp: ''!
changeDisableTableLayout
	self disableTableLayout: self disableTableLayout not.
	self layoutChanged.! !

!Morph methodsFor: 'event handling' stamp: ''!
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: '*Morphic-Base' stamp: ''!
changeLayoutInset: evt
	| handle |
	handle := HandleMorph new forEachPointDo:[:newPoint |
		self layoutInset: (newPoint - evt cursorPoint) asIntegerPoint // 5].
	evt hand attachMorph: handle.
	handle startStepping.! !

!Morph methodsFor: 'event testing' stamp: ''!
simulateMouseDown 
	"Simulate mouse button down with the left button (red button for left, blue for middle, yellow for right)"
	self simulateMouseDownWith: MouseEvent redButton.! !

!Morph methodsFor: 'meta-actions' stamp: ''!
resizeFromMenu
	"Commence an interaction that will resize the receiver"

	self resizeMorph: self activeHand lastEvent! !

!Morph methodsFor: 'geometry testing' stamp: ''!
fullContainsPoint: aPoint
	(self fullBounds containsPoint: aPoint)
		ifFalse: [ ^ false ].	"quick elimination"
	(self containsPoint: aPoint)
		ifTrue: [ ^ true ].	"quick acceptance"
	^ submorphs anySatisfy: [ :m | m fullContainsPoint: aPoint ]! !

!Morph methodsFor: 'events - processing' stamp: ''!
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: ''!
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: 'events - processing' stamp: ''!
handlesMouseWheel: evt
	"Do I want to receive mouseWheel events?." 

	^false! !

!Morph methodsFor: 'rotate scale and flex' stamp: ''!
keepsTransform
	"Return true if the receiver will keep it's transform while being grabbed by a hand."
	^false! !

!Morph methodsFor: 'geometry' stamp: ''!
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: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarTask
	"Answer a new taskbar task for the receiver.
	Answer nil if not required."

	^nil! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
borderWidth: aNumber
	| style |
	style := self borderStyle.
	style width = aNumber ifTrue: [ ^self ].

	style style = #none
		ifTrue: [ self borderStyle: (SimpleBorderStyle width: aNumber color: Color transparent) ]
		ifFalse: [ style width: aNumber. self changed ].! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
changeTableLayout
	| layout |
	((layout := self layoutPolicy) notNil and:[layout isTableLayout])
		ifTrue:[^self]. "already table layout"
	self layoutPolicy: TableLayout new.
	self layoutChanged.! !

!Morph methodsFor: 'event handling' stamp: ''!
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: '*Morphic-Base' stamp: ''!
isMenuLineMorph
	^false! !

!Morph methodsFor: 'rotate scale and flex' stamp: ''!
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: 'copying' stamp: ''!
copy

	^ self veryDeepCopy! !

!Morph methodsFor: 'drawing' stamp: ''!
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 ].

		"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: 'testing' stamp: ''!
isLineMorph
	^false! !

!Morph methodsFor: 'updating' stamp: ''!
addDependent: anObject

	self announcer 
		when: MorphChanged , MorphChangedWithArguments
		send: #handleUpdate:
		to: anObject.
			
	^ anObject! !

!Morph methodsFor: 'menu' stamp: ''!
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: 'event handling' stamp: ''!
transformFromOutermostWorld
	"Return a transform to map world coordinates into my local coordinates"

	"self isWorldMorph ifTrue: [^ MorphicTransform identity]."
	^ self transformFrom: self outermostWorldMorph! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
preferredButtonCornerStyle
	"Answer the preferred button corner style
	for submorphs. Answer nil for no preference."

	^nil! !

!Morph methodsFor: 'dropping/grabbing' stamp: ''!
dragEnabled: aBool
	^self enableDrag: aBool! !

!Morph methodsFor: 'text-anchor' stamp: ''!
textAnchorType
	^self valueOfProperty: #textAnchorType ifAbsent:[#document]! !

!Morph methodsFor: 'announcements' stamp: ''!
doAnnounce: anAnnouncement
	"Take care of not creating the announcer when announcing. If the announcer doesn't exist then this means nobody has expressed an interest in the message."

	"Do not override announce: for now, there is a need to refactor the announcements code in at least SystemWindow and ExpanderMorph."

	(self valueOfProperty: #announcer ifAbsent: [ ^ self ]) announce: anAnnouncement! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
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.
	rm computeBounds.
	
	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: 'drawing' stamp: ''!
imageFormForRectangle: rect

	^ self imageForm: Display depth forRectangle: rect! !

!Morph methodsFor: 'recategorized' stamp: ''!
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: 'testing' stamp: ''!
isFlexed
	"Return true if the receiver is currently flexed"
	^ owner notNil and: [owner isFlexMorph]! !

!Morph methodsFor: 'structure' stamp: ''!
allOwnersDo: aBlock
	"Evaluate aBlock with all owners of the receiver"
	owner ifNotNil:[^owner withAllOwnersDo: aBlock].! !

!Morph methodsFor: 'layout - properties' stamp: ''!
listSpacingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self listSpacing! !

!Morph methodsFor: 'halos and balloon help' stamp: ''!
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: 'events - processing' stamp: ''!
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: [ | result |
			result := self mouseUp: anEvent.
			self stopSteppingSelector: #handleMouseStillDown:.
			result ].
	^ self eventHandler ifNotNil: [:handler | handler mouseUp: anEvent fromMorph: self]! !

!Morph methodsFor: 'showing' stamp: ''!
openCenteredInWorld
	"Open me in the center of current world"
	self 
		fullBounds;
		openInWorld;
		center: self world clearArea center! !

!Morph methodsFor: 'accessing' stamp: ''!
embeddedWindowOrNil

	"answer nil for common morphs, yourself from system windows and first submorph for transformation morphs"

	^ nil! !

!Morph methodsFor: 'submorphs - accessing' stamp: ''!
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: '*Morphic-Base' stamp: ''!
on: eventName send: selector to: recipient
	self eventHandler ifNil: [self eventHandler: MorphicEventHandler new].
	self eventHandler on: eventName send: selector to: recipient! !

!Morph methodsFor: '*Athens-Morphic' stamp: ''!
drawSubmorphsOnAthensCanvas: anAthensCanvas
	self
		drawClippedOnAthensCanvas: anAthensCanvas
		during: [ submorphs reverseDo: [ :m | anAthensCanvas fullDrawMorph: m ] ]! !

!Morph methodsFor: 'events - processing' stamp: ''!
handleMouseMove: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self]. 
	
	(self handlesMouseMove: anEvent) 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: 'dropping/grabbing' stamp: ''!
enableDragNDrop
	self enableDragNDrop: true! !

!Morph methodsFor: 'accessing - properties' stamp: ''!
hasProperty: aSymbol

	"Answer whether the receiver has the property named aSymbol"

	^ extension
		  ifNil: [ false ]
		  ifNotNil: [ :ext | ext hasProperty: aSymbol ]! !

!Morph methodsFor: 'meta-actions' stamp: ''!
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 browse: list title:  'Actions of ' , self printString.! !

!Morph methodsFor: 'structure' stamp: ''!
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: 'accessing' stamp: ''!
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 - defaults' stamp: ''!
defaultBounds
"answer the default bounds for the receiver"
	^ 0 @ 0 corner: 50 @ 40! !

!Morph methodsFor: 'menus' stamp: ''!
addMiscExtrasTo: aMenu
	"Add a submenu of miscellaneous extra items to the menu."

	| subMenu |
	self isWorldMorph
		ifTrue: [ ^ self ].
	subMenu := UIManager default newMenuIn: self for: self.
	self renderedMorph isSystemWindow
		ifFalse: [ subMenu add: 'put in a window' selector: #embedInWindow ].
	subMenu add: 'adhere to edge...' selector: #adhereToEdge.
	aMenu add: 'extras...' subMenu: subMenu! !

!Morph methodsFor: 'updating' stamp: ''!
removeDependent: anObject

	self announcer unsubscribe: anObject! !

!Morph methodsFor: 'layout - properties' stamp: ''!
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: 'layout - properties' stamp: ''!
layoutProperties: newProperties
	"Return the current layout properties associated with the receiver"
	self layoutProperties == newProperties ifTrue:[^self].
	self assureExtension layoutProperties: newProperties.! !

!Morph methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
defaultTaskbarThumbnailExtent
	"Answer the default size of a taskbar thumbnail for the receiver."

	^320@320! !

!Morph methodsFor: 'submorphs - add/remove' stamp: ''!
removedMorph: aMorph
	"Notify the receiver that aMorph was just removed from its children"! !

!Morph methodsFor: 'meta-actions' stamp: ''!
copyToPasteBuffer: evt
	^evt hand copyToPasteBuffer: self.! !

!Morph methodsFor: '*Morphic-Base' stamp: ''!
changeProportionalLayout
	| layout |
	((layout := self layoutPolicy) notNil and:[layout isProportionalLayout])
		ifTrue:[^self]. "already proportional layout"
	self layoutPolicy: ProportionalLayout new.
	self layoutChanged.! !

!Morph methodsFor: 'event handling' stamp: ''!
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: ''!
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: 'layout - properties' stamp: ''!
vResizeToFit: aBoolean
	aBoolean ifTrue:[
		self vResizing: #shrinkWrap.
	] ifFalse:[
		self vResizing: #rigid.
	].! !

!Morph methodsFor: 'geometry' stamp: ''!
boundsIn: referenceMorph
	"Return the receiver's bounds as seen by aMorphs coordinate frame"
	^self bounds: self bounds in: referenceMorph! !

!Morph class methodsFor: 'settings' stamp: ''!
cmdGesturesEnabled: aBoolean
	CmdGesturesEnabled := aBoolean! !

!Morph class methodsFor: 'instance creation' stamp: ''!
newSticky

	^ self new beSticky! !

!Morph class methodsFor: 'settings' stamp: ''!
defaultYellowButtonMenuEnabled: aBoolean
	DefaultYellowButtonMenuEnabled := aBoolean! !

!Morph class methodsFor: 'instance creation' stamp: ''!
newBounds: bounds color: color

	^ (self new privateBounds: bounds) privateColor: color! !

!Morph class methodsFor: 'settings' stamp: ''!
cycleHalosBothDirections: aBoolean

	CycleHalosBothDirections := aBoolean.! !

!Morph class methodsFor: 'class initialization' stamp: ''!
initialize
	"Morph initialize"

	"this empty array object is shared by all morphs with no submorphs:"
	EmptyArray := Array new.! !

!Morph class methodsFor: 'accessing' stamp: ''!
defaultEventDispatcher
	^ EventDispatcher ifNil: [ EventDispatcher := MorphicEventDispatcher new ]! !

!Morph class methodsFor: 'misc' stamp: ''!
morphsUnknownToTheirOwners
	"Return a list of all morphs (other than HandMorphs) whose owners do not contain them in their submorph lists"

	"Morph morphsUnknownToTheirOwners"

	| problemMorphs |
	problemMorphs := OrderedCollection new.
	self allSubInstances
		do: [ :m | 
			| itsOwner |
			(m isHandMorph not and: [ (itsOwner := m owner) notNil and: [ (itsOwner submorphs includes: m) not ] ])
				ifTrue: [ problemMorphs add: m ] ].
	^ problemMorphs! !

!Morph class methodsFor: 'instance creation' stamp: ''!
newBounds: bounds

	^ self new privateBounds: bounds! !

!Morph class methodsFor: 'settings' stamp: ''!
defaultYellowButtonMenuEnabled
	^ DefaultYellowButtonMenuEnabled ifNil: [DefaultYellowButtonMenuEnabled := false]! !

!Morph class methodsFor: 'settings' stamp: ''!
cycleHalosBothDirections

	^ CycleHalosBothDirections ifNil: [ CycleHalosBothDirections := false ].! !

!Morph class methodsFor: 'shortcuts' stamp: ''!
shortcutsHandler 

	^ ShortcutsHandler! !

!Morph class methodsFor: 'settings' stamp: ''!
halosEnabled

	^ HalosEnabled ifNil: [ HalosEnabled := true ]! !

!Morph class methodsFor: 'settings' stamp: ''!
cmdGesturesEnabled
	^ CmdGesturesEnabled ifNil: [CmdGesturesEnabled := true]! !

!Morph class methodsFor: '*Polymorph-Widgets' stamp: ''!
theme
	"Answer the ui theme that provides controls."

	^ Smalltalk ui theme! !

!Morph class methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
systemIconName

	^ #morphIcon! !

!Morph class methodsFor: 'settings' stamp: ''!
morphNavigationShortcutsOn: aBuilder
	"Basic, general navigation shortcut among morphs. #MorphNoCtrl will not work for TextMorphs."

	<keymap>
	(aBuilder shortcut: #navigateFocusForwardCtrl)
		category: #MorphFocusCtrlNavigation
		default: Character tab ctrl asKeyCombination
		do: [ :target :morph :event | morph navigateFocusForward ].
	(aBuilder shortcut: #navigateFocusBackwardCtrl)
		category: #MorphFocusCtrlNavigation
		default: Character tab shift ctrl asKeyCombination
		do: [ :target :morph :event | morph navigateFocusBackward ].
	(aBuilder shortcut: #navigateFocusForward)
		category: #MorphFocusNavigation
		default: Character tab asKeyCombination
		do: [ :target :morph :event | morph navigateFocusForward ].
	(aBuilder shortcut: #navigateFocusBackward)
		category: #MorphFocusNavigation
		default: Character tab shift asKeyCombination
		do: [ :target :morph :event | morph navigateFocusBackward ]! !

!Morph class methodsFor: 'misc' stamp: ''!
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: 'shortcuts' stamp: ''!
shortcutsHandler: anObject

	ShortcutsHandler := anObject! !

!Morph class methodsFor: 'accessing' stamp: ''!
announcer

	^ announcer ifNil: [ announcer := Announcer new ].! !

!Morph class methodsFor: 'settings' stamp: ''!
halosEnabled: aBoolean

	HalosEnabled := aBoolean! !

!MorphAnnouncement commentStamp: ''!
I am an abstract announcement for morphic events.  I carry the morph where the event has ocurred.

My subclasses should add information for more precise events.!
!MorphAnnouncement methodsFor: 'accessing' stamp: ''!
morph
	^ morph! !

!MorphAnnouncement methodsFor: 'accessing' stamp: ''!
morph: anObject
	morph := anObject! !

!MorphAnnouncement class methodsFor: 'instance creation' stamp: ''!
morph: aMorph
	^self new
			morph: aMorph;
			yourself! !

!MorphChanged commentStamp: ''!
I am raised when a morph property changed, and should be propagated to dependents!
!MorphChanged methodsFor: 'delivering' stamp: ''!
deliverTo: aHandler

	^ aHandler update: selector! !

!MorphChanged methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!MorphChanged methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!MorphChangedWithArguments commentStamp: ''!
I am an announcement raised when a Morph changed and need to propagate the information to dependents. In addition, I also propagate a value!
!MorphChangedWithArguments methodsFor: 'delivering' stamp: ''!
deliverTo: aHandler

	^ aHandler update: selector with: arguments! !

!MorphChangedWithArguments methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!MorphChangedWithArguments methodsFor: 'accessing' stamp: ''!
arguments: anObject
	arguments := anObject! !

!MorphClosePopups commentStamp: ''!
Some morph can use another related morphs as popups. For example, the text editor can have open a completion menu. I am the announcement for explicit closing of such morphs.!
!MorphDeleted commentStamp: ''!
I'm an announcement raised when a morph is deleted. Subscribe to me when you want to do things after the morph is opened.

Take into account that when a morph is deleted, all it's children also get deleted and they raise a similar announcement.!
!MorphDropListMorph commentStamp: ''!
Drop list supporting morphs in list.!
!MorphDropListMorph methodsFor: 'drawing' stamp: ''!
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: 'private' stamp: ''!
listMorphClass
	"Answer the class for a new list morph"

	^PluggableMorphListMorph! !

!MorphDropListMorph methodsFor: 'accessing' stamp: ''!
font
	"Answer the content font"

	^self listFont! !

!MorphDropListMorph methodsFor: 'accessing' stamp: ''!
font: aFont
	"Set the list font"

	self listFont: aFont! !

!MorphDropListMorph methodsFor: 'testing' stamp: ''!
updateContents
	"Update the contents."

	|item|
	self contentMorph removeAllMorphs.
	self listSelectionIndex > 0
		ifTrue: [item := (self list at: self listSelectionIndex) copy
					hResizing: #spaceFill;
					vResizing: #rigid.
				self contentMorph
					addMorph: item]! !

!MorphDropListMorph methodsFor: 'updating' stamp: ''!
updateContentColor: paneColor
	"Change the content text color."! !

!MorphEventSubscription commentStamp: ''!
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: ''!
valueParameter: anObject

	valueParameter := anObject! !

!MorphEventSubscription methodsFor: 'accessing' stamp: ''!
event

	^ event! !

!MorphEventSubscription methodsFor: 'events-triggering' stamp: ''!
doubleClick: anEvent fromMorph: aMorph 
	^self notify: anEvent from: aMorph! !

!MorphEventSubscription methodsFor: 'events-triggering' stamp: ''!
mouseLeave: anEvent fromMorph: aMorph 
	^self notify: anEvent from: aMorph! !

!MorphEventSubscription methodsFor: 'accessing' stamp: ''!
selector

	^ selector! !

!MorphEventSubscription methodsFor: 'accessing' stamp: ''!
selector: anObject

	selector := anObject! !

!MorphEventSubscription methodsFor: 'events-triggering' stamp: ''!
click: anEvent fromMorph: aMorph 
	^self notify: anEvent from: aMorph! !

!MorphEventSubscription methodsFor: 'events-triggering' stamp: ''!
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 methodsFor: 'accessing' stamp: ''!
recipient: anObject

	recipient := anObject! !

!MorphEventSubscription methodsFor: 'accessing' stamp: ''!
recipient

	^ recipient! !

!MorphEventSubscription methodsFor: 'events-triggering' stamp: ''!
mouseEnter: anEvent fromMorph: aMorph 
	^self notify: anEvent from: aMorph! !

!MorphEventSubscription methodsFor: 'accessing' stamp: ''!
valueParameter

	^ valueParameter! !

!MorphEventSubscription methodsFor: 'events-triggering' stamp: ''!
doubleClickTimeout: anEvent fromMorph: aMorph 
	^self notify: anEvent from: aMorph! !

!MorphEventSubscription methodsFor: 'accessing' stamp: ''!
event: anEvent

	event := anEvent! !

!MorphEventSubscription class methodsFor: 'instance creation' stamp: ''!
on: anEvent send: aMessageSelector to: anObject withValue: aValue
	^self new
		event: anEvent;
		selector: aMessageSelector;
		recipient: anObject;
		valueParameter: aValue;
		yourself! !

!MorphEventSubscription class methodsFor: 'instance creation' stamp: ''!
on: anEvent send: aSelector to: anObject
	^self new
		event: anEvent;
		selector: aSelector;
		recipient: anObject;
		yourself! !

!MorphExtension commentStamp: ''!
MorphExtension provides access to extra instance state that is not required in most simple morphs.  This allows simple morphs to remain relatively lightweight while still admitting more complex structures as necessary.  The otherProperties field takes this policy to the extreme of allowing any number of additional named attributes, albeit at a certain cost in speed and space.!
!MorphExtension methodsFor: 'accessing' stamp: ''!
locked: aBoolean 
	"change the receiver's locked property"
	locked := aBoolean! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
cornerStyle: anObject
	"Set the value of cornerStyle"

	cornerStyle := anObject! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: ''!
assureOtherProperties

	"creates an otherProperties for the receiver if needed"

	^ otherProperties ifNil: [  otherProperties := SmallIdentityDictionary new ]! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
borderStyle: anObject
	"Set the value of borderStyle"

	borderStyle := anObject! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: ''!
valueOfProperty: aSymbol ifAbsentPut: aBlock 
	"If the receiver possesses a property of the given name, answer  
	its value. If not, then create a property of the given name, give 
	it the value obtained by evaluating aBlock, then answer that  
	value"
	^self assureOtherProperties at: aSymbol ifAbsentPut: aBlock! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: ''!
layoutFrame

	^layoutFrame! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
eventHandler: newValue
	eventHandler := newValue! !

!MorphExtension methodsFor: 'printing' stamp: ''!
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 = ' ; 
					nextPutAll:  externalName;
				nextPutAll: ' ] ' ].
	eventHandler
		ifNotNil: [ 
			aStream
				nextPutAll:  ' [eventHandler = ' ; 
				print: eventHandler ;
				nextPutAll: '] ' ].
	(otherProperties isNil or: [ otherProperties isEmpty ])
		ifTrue: [ ^ self ].
	aStream nextPutAll: ' [other: '.
	self otherProperties
		keysDo: [ :aKey | 
			aStream
				nextPutAll: ' (' ; 
					nextPutAll:  aKey; nextPutAll:  ' -> ' ; print: (self otherProperties at: aKey) ;
				nextPutAll: ')' ].
	aStream nextPut: $]! !

!MorphExtension methodsFor: 'connectors - copying' stamp: ''!
copyWeakly
	"list of names of properties whose values should be weak-copied when veryDeepCopying a morph.  See DeepCopier."

	^ #(formerOwner)
	"add yours to this list" 

	"formerOwner should really be nil at the time of the copy, but this will work just fine."! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: ''!
sortedPropertyNames
	"answer the receiver's property names in a sorted way"

	| props |
	props := (Array new: 10) writeStream.
	locked == true ifTrue: [props nextPut: #locked].
	visible == false ifTrue: [props nextPut: #visible].
	sticky == true ifTrue: [props nextPut: #sticky].
	balloonText ifNotNil: [props nextPut: #balloonText].
	externalName ifNotNil: [props nextPut: #externalName].
	eventHandler ifNotNil: [props nextPut: #eventHandler].
	 otherProperties ifNotNil: [otherProperties associationsDo: [:a | props nextPut: a key]].
	^props contents sort: [:s1 :s2 | s1 <= s2]! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: ''!
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
		  ifNotNil: [ :prop | prop at: aSymbol ifAbsent: aBlock ]
		  ifNil: [ aBlock value ]! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
eventHandler
	"answer the receiver's eventHandler"
	^ eventHandler! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
clipSubmorphs: anObject
	"Set the value of clipSubmorphs"

	clipSubmorphs := anObject! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
cornerStyle
	"Answer the value of cornerStyle"

	^cornerStyle ifNil: [#square]! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: ''!
layoutFrame: aLayoutFrame

	layoutFrame := aLayoutFrame! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: ''!
otherProperties
	"answer the receiver's otherProperties"
	^ otherProperties! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: ''!
hasProperty: aSymbol

	"Answer whether the receiver has the property named aSymbol"

	^ otherProperties
		  ifNil: [ false ]
		  ifNotNil: [ :prop | prop includesKey: aSymbol ]! !

!MorphExtension methodsFor: 'connectors - copying' stamp: ''!
veryDeepFixupWith: deepCopier 
	"If target and arguments fields were weakly copied, fix them here.
	If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

	super veryDeepFixupWith: deepCopier.
	otherProperties ifNil: [ ^self ].

	"Properties whose values are only copied weakly replace those values if they were copied via another path"
	self copyWeakly do: [ :propertyName |
		otherProperties at: propertyName ifPresent: [ :property |
			otherProperties at: propertyName
				put: (deepCopier references at: property ifAbsent: [ property ])]].! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
fillStyle: anObject
	"Set the value of fillStyle"

	fillStyle := anObject! !

!MorphExtension methodsFor: 'other' stamp: ''!
isDefault
	"Return true if the receiver is a default and can be omitted"
	locked == true
		ifTrue: [^ false].
	visible == false
		ifTrue: [^ false].
	sticky == true
		ifTrue: [^ false].
	balloonText ifNotNil: [^ false].
	externalName ifNotNil: [^ false].
	eventHandler ifNotNil: [^ false].
	otherProperties ifNotNil: [otherProperties isEmpty ifFalse: [^ false]].
	^ true! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
externalName: aString 
	"change the receiver's externalName"
	externalName := aString! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
locked
	"answer whether the receiver is Locked"
	^ locked! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
borderStyle
	"Answer the value of borderStyle"

	^borderStyle! !

!MorphExtension methodsFor: 'initialization' stamp: ''!
initialize
	
	locked := false.
	visible := true.
	sticky := false.! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
actionMap
	"Answer the value of actionMap"

	^actionMap ifNil: [self valueOfProperty: #actionMap ifAbsent: []]! !

!MorphExtension methodsFor: 'connectors - copying' stamp: ''!
propertyNamesNotCopied
	"list of names of properties whose values should be deleted when veryDeepCopying a morph.
	See DeepCopier."

	^ #(connectedConstraints connectionHighlights highlightedTargets)
	"add yours to this list"! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: ''!
removeOtherProperties
	"Remove the 'other' properties"
	otherProperties := nil! !

!MorphExtension methodsFor: 'other' stamp: ''!
inspectElement
	"Create and schedule an Inspector on the otherProperties and the 
	named properties."
	| key obj |
	key := UIManager default 
				chooseFrom: self sortedPropertyNames 
				values: self sortedPropertyNames
				title: 'Inspect which property?' translated.
	key
		ifNil: [^ self].
	obj := otherProperties
				at: key
				ifAbsent: ['nOT a vALuE'].
	obj = 'nOT a vALuE'
		ifTrue: [(self perform: key) inspect
			"named properties"]
		ifFalse: [obj inspect]! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
sticky: aBoolean 
	"change the receiver's sticky property"
	sticky := aBoolean! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: ''!
layoutPolicy

	^layoutPolicy! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
actionMap: anObject
	"Set the value of actionMap"

	actionMap := anObject! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
balloonText
	^ balloonText! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: ''!
layoutProperties: newProperties 
	"Return the current layout properties associated with the receiver"

	layoutProperties := newProperties! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: ''!
setProperty: aSymbol toValue: abObject 
	"change the receiver's property named aSymbol to anObject"
	self assureOtherProperties at: aSymbol put: abObject! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
balloonText: newValue
	balloonText := newValue! !

!MorphExtension methodsFor: 'viewer' stamp: ''!
externalName
	^ externalName! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: ''!
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' stamp: ''!
clipSubmorphs
	"Answer the value of clipSubmorphs"

	^clipSubmorphs! !

!MorphExtension methodsFor: 'connectors - copying' stamp: ''!
veryDeepInner: deepCopier 
	"Copy all of my instance variables.
	Some otherProperties need to be not copied at all, but shared. Their names are given by copyWeakly.
	Some otherProperties should not be copied or shared. Their names are given by propertyNamesNotCopied.
	This is special code for the dictionary. See DeepCopier, and veryDeepFixupWith:."

	| namesOfWeaklyCopiedProperties weaklyCopiedValues |
	super veryDeepInner: deepCopier.
	locked := locked veryDeepCopyWith: deepCopier.
	visible := visible veryDeepCopyWith: deepCopier.
	sticky := sticky veryDeepCopyWith: deepCopier.
	balloonText := balloonText veryDeepCopyWith: deepCopier.
	externalName := externalName veryDeepCopyWith: deepCopier.
	eventHandler := eventHandler veryDeepCopyWith: deepCopier. 	"has its own restrictions"
	
	fillStyle := fillStyle veryDeepCopyWith: deepCopier.
	layoutPolicy := layoutPolicy veryDeepCopyWith: deepCopier.
	layoutFrame := layoutFrame veryDeepCopyWith: deepCopier.
	layoutProperties := layoutProperties veryDeepCopyWith: deepCopier.
	borderStyle := borderStyle  veryDeepCopyWith: deepCopier.
	cornerStyle := cornerStyle veryDeepCopyWith: deepCopier.
	actionMap := actionMap veryDeepCopyWith: deepCopier.
	clipSubmorphs := clipSubmorphs veryDeepCopyWith: deepCopier.

	otherProperties ifNil: [ ^self ].

	otherProperties := otherProperties copy.
	self propertyNamesNotCopied do: [ :propName | otherProperties removeKey: propName ifAbsent: [] ].

	namesOfWeaklyCopiedProperties := self copyWeakly.
	weaklyCopiedValues := namesOfWeaklyCopiedProperties collect: [  :propName | otherProperties removeKey: propName ifAbsent: [] ].

	"Now copy all the others."
	otherProperties := otherProperties veryDeepCopyWith: deepCopier.

	"And replace the weak ones."
	namesOfWeaklyCopiedProperties with: weaklyCopiedValues do: [ :name :value | value ifNotNil: [ otherProperties at: name put: value ]].! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
visible: newValue
	visible := newValue! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: ''!
layoutPolicy: aLayoutPolicy 
	
	layoutPolicy := aLayoutPolicy! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
fillStyle
	"Answer the value of fillStyle"

	^ fillStyle! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
sticky
	^ sticky! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: ''!
valueOfProperty: aSymbol 
"answer the value of the receiver's property named aSymbol"
	^ self
		valueOfProperty: aSymbol
		ifAbsent: []! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: ''!
layoutProperties

	^layoutProperties! !

!MorphExtension methodsFor: 'accessing' stamp: ''!
visible
	"answer whether the receiver is visible"
	^ visible! !

!MorphGotFocus commentStamp: ''!
I'm an announcement raised when a morph gets keyboard focus. !
!MorphHandlingMiddleButton commentStamp: ''!
I log when the middle mouse button has been clicked on me, which is useful for testing.!
!MorphHandlingMiddleButton methodsFor: 'meta-actions' stamp: ''!
blueButtonUp: anEvent

	receivedBlueButtonUp := true.! !

!MorphHandlingMiddleButton methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	receivedBlueButtonUp := receivedBlueButtonDown := false.! !

!MorphHandlingMiddleButton methodsFor: 'testing' stamp: ''!
wasClickedWithMiddleButton

	^ receivedBlueButtonDown and: [ receivedBlueButtonUp ].! !

!MorphHandlingMiddleButton methodsFor: 'meta-actions' stamp: ''!
handlerForBlueButtonDown: anEvent

	^ self.! !

!MorphHandlingMiddleButton methodsFor: 'meta-actions' stamp: ''!
blueButtonDown: anEvent

	receivedBlueButtonDown := true.! !

!MorphLostFocus commentStamp: ''!
I'm an announcement raised when a morph losts keyboard focus.!
!MorphOpened commentStamp: ''!
I'm an announcement raised when a morph is opened.  Subscribe to me when you want to do things after the morph is opened.

Take into account that when a morph is opened, all it's children also get opened and they raise a similar announcement.!
!MorphTest commentStamp: ''!
This is the unit test for the class Morph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- http://minnow.cc.gatech.edu/squeak/1547
	- the sunit class category!
!MorphTest methodsFor: 'testing - geometry' stamp: ''!
testBoundingBoxOfSubmorphs

	| subMorph |
	subMorph := morph copy
		topLeft: morph topLeft + 5;
		yourself.

	morph addMorph: subMorph.
	
	self assert: morph boundingBoxOfSubmorphs equals: subMorph bounds.! !

!MorphTest methodsFor: 'testing - testing' stamp: ''!
testForTiltedStickyness

	| m |
	m := Morph new openCenteredInWorld.
	self assert: m topRendererOrSelf isSticky not.
	m beSticky.
	self assert: m topRendererOrSelf isSticky.
	m addFlexShell.
	m topRendererOrSelf rotationDegrees: 45.0.
	self assert: m topRendererOrSelf isSticky.
	m beUnsticky.
	self assert: m topRendererOrSelf isSticky not.
	m topRendererOrSelf delete! !

!MorphTest methodsFor: 'running' stamp: ''!
tearDown
	morph delete.
	super tearDown! !

!MorphTest methodsFor: 'testing - into/outof world' stamp: ''!
testIntoWorldCollapseOutOfWorld
	| m1 m2 collapsed |
	"Create the guys"
	m1 := TestInWorldMorph new.
	m2 := TestInWorldMorph new.
	self assert: m1 intoWorldCount equals: 0.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 0.
	self assert: m2 outOfWorldCount equals: 0.

	"add them to basic morph"
	morph addMorphFront: m1.
	m1 addMorphFront: m2.
	self assert: m1 intoWorldCount equals: 0.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 0.
	self assert: m2 outOfWorldCount equals: 0.

	"open the guy"
	morph openInWorld.
	self assert: m1 intoWorldCount equals: 1.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 1.
	self assert: m2 outOfWorldCount equals: 0.

	"collapse it"
	collapsed := CollapsedMorph new beReplacementFor: morph.
	self assert: m1 intoWorldCount equals: 1.
	self assert: m1 outOfWorldCount equals: 1.
	self assert: m2 intoWorldCount equals: 1.
	self assert: m2 outOfWorldCount equals: 1.

	"expand it"
	collapsed collapseOrExpand.
	self assert: m1 intoWorldCount equals: 2.
	self assert: m1 outOfWorldCount equals: 1.
	self assert: m2 intoWorldCount equals: 2.
	self assert: m2 outOfWorldCount equals: 1.

	"delete it"
	morph delete.
	self assert: m1 intoWorldCount equals: 2.
	self assert: m1 outOfWorldCount equals: 2.
	self assert: m2 intoWorldCount equals: 2.
	self assert: m2 outOfWorldCount equals: 2! !

!MorphTest methodsFor: 'testing - into/outof world' stamp: ''!
testIntoWorldTransferToNewGuy
	| m1 m2 |
	"Create the guys"
	m1 := TestInWorldMorph new.
	m2 := TestInWorldMorph new.
	self assert: m1 intoWorldCount equals: 0.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 0.
	self assert: m2 outOfWorldCount equals: 0.

	morph addMorphFront: m1.
	m1 addMorphFront: m2.
	self assert: m1 intoWorldCount equals: 0.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 0.
	self assert: m2 outOfWorldCount equals: 0.

	morph openInWorld.
	self assert: m1 intoWorldCount equals: 1.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 1.
	self assert: m2 outOfWorldCount equals: 0.

	morph addMorphFront: m2.
	self assert: m1 intoWorldCount equals: 1.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 1.
	self assert: m2 outOfWorldCount equals: 0.

	morph addMorphFront: m1.
	self assert: m1 intoWorldCount equals: 1.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 1.
	self assert: m2 outOfWorldCount equals: 0.

	m2 addMorphFront: m1.
	self assert: m1 intoWorldCount equals: 1.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 1.
	self assert: m2 outOfWorldCount equals: 0.

	morph delete.
	self assert: m1 intoWorldCount equals: 1.
	self assert: m1 outOfWorldCount equals: 1.
	self assert: m2 intoWorldCount equals: 1.
	self assert: m2 outOfWorldCount equals: 1! !

!MorphTest methodsFor: 'testing - halo' stamp: ''!
testHaloIsDisable
	| isHaloEnable |
	isHaloEnable := Morph halosEnabled.
	Morph halosEnabled: false.
	self assert: (Morph new addHalo: nil) ~= (Smalltalk globals at: #HaloMorph).
	Morph halosEnabled: isHaloEnable! !

!MorphTest methodsFor: 'testing - geometry' stamp: ''!
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 equals: b1! !

!MorphTest methodsFor: 'testing - into/outof world' stamp: ''!
testIntoWorldDeleteOutOfWorld
	| m1 m2 |
	"Create the guys"
	m1 := TestInWorldMorph new.
	m2 := TestInWorldMorph new.
	self assert: m1 intoWorldCount equals: 0.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 0.
	self assert: m2 outOfWorldCount equals: 0.

	morph addMorphFront: m1.
	m1 addMorphFront: m2.
	self assert: m1 intoWorldCount equals: 0.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 0.
	self assert: m2 outOfWorldCount equals: 0.

	morph openInWorld.
	self assert: m1 intoWorldCount equals: 1.
	self assert: m1 outOfWorldCount equals: 0.
	self assert: m2 intoWorldCount equals: 1.
	self assert: m2 outOfWorldCount equals: 0.

	morph delete.
	self assert: m1 intoWorldCount equals: 1.
	self assert: m1 outOfWorldCount equals: 1.
	self assert: m2 intoWorldCount equals: 1.
	self assert: m2 outOfWorldCount equals: 1! !

!MorphTest methodsFor: 'testing - classification' stamp: ''!
testIsMorph
	self assert: (morph isMorph).! !

!MorphTest methodsFor: 'testing - initialization' stamp: ''!
testOpenInWorld
	morph openInWorld! !

!MorphTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	morph := Morph new! !

!MorphTreeAnnounce commentStamp: ''!
Announcements for morphic based trees!
!MorphTreeChangeRequest commentStamp: ''!
Used to announce a change request on the tree!
!MorphTreeChangeRequest methodsFor: 'accessing' stamp: ''!
action: aSymbol
	action := aSymbol! !

!MorphTreeChangeRequest methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments ifNil: [Array new]! !

!MorphTreeChangeRequest methodsFor: 'accessing' stamp: ''!
arguments: anArray
	arguments := anArray! !

!MorphTreeChangeRequest methodsFor: 'accessing' stamp: ''!
change: aTreeMorph
	action ifNil: [^self].
	aTreeMorph perform: action withEnoughArguments: self arguments! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
expandItemPath: anItemPath
	^ self new action: #expandItemPath:; arguments: (Array with: anItemPath)! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
selectItems: itemsList
	^ self new action: #selectItems:; arguments: (Array with: itemsList)! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
expandAll
	^ self new action: #expandAll! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
expandNodePath: aNodePath
	^ self new action: #expandNodePath:; arguments: (Array with: aNodePath)! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
deselectAll
	^ self new action: #deselectAll! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
pageSize: anInteger
	^ self new action: #pageSize:; arguments: (Array with: anInteger)! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
expandRoots
	^ self new action: #expandRoots! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
updateSelectionFromModel
	^ self new action: #updateSelectionFromModel! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
enabled
	^ self new action: #enabledFromModel! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
selectAll
	^ self new action: #selectAll! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
expandAllFromNode: aNode
	^ self new action: #expandAllFromNode:; arguments: (Array with: aNode)! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
collapseNodePath: aNodePath
	^ self new action: #collapseNodePath:; arguments: (Array with: aNodePath)! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
collapseAll
	^ self new action: #collapseAll! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
updateList
	^ self new action: #updateList! !

!MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: ''!
chunkSize: anInteger
	^ self new action: #chunkSize:; arguments: (Array with: anInteger)! !

!MorphTreeChunkPager commentStamp: ''!
A chunk pager!
!MorphTreeChunkPager class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!MorphTreeColumn commentStamp: ''!
A column in a morphic based tree!
!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
color: aColor
	color := aColor! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
resizable
	^ resizable ifNil: [resizable := true]! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
color 
	^ color ifNil: [self container columnColors at: ((self index \\ 2) + 1)]! !

!MorphTreeColumn methodsFor: 'converting' stamp: ''!
drawColumnOn: aCanvas
	self isPotentialDropTarget 
		ifTrue: [aCanvas 
					frameAndFillRectangle: self dataBounds 
					fillColor: ((Color gray alpha: 0.1) alphaMixed: 0.9 with: (self color ifNotNil: [:c | c asColor] ifNil: [Color transparent]))
					borderWidth: 2 
					borderColor: Color gray]
		ifFalse: [self color 
						ifNotNil: [:c | 
							c isColor 
								ifTrue: [
									aCanvas 
										frameAndFillRectangle: self dataBounds 
										fillColor: self color
										borderWidth: 0 
										borderColor: Color transparent]
								ifFalse: [c origin: self dataBounds topLeft.
									c direction: 0@self dataBounds height.
									aCanvas fillRectangle: self dataBounds  basicFillStyle: c]]]! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
isPotentialDropTarget
	^ isPotentialDropTarget ifNil: [isPotentialDropTarget := false]! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
header
	^ header ifNil: [header :=  (Morph new extent: 0@0) color: Color transparent]! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
defaultRowMorph
	^ Morph new color: Color red; borderWidth: 0; extent: 0@0; yourself! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
resizable: aBoolean
	resizable := aBoolean! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
rowMorphGetSelector: aSelector
	rowMorphGetSelector := aSelector! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
dataBounds 
	^ self visibleBounds withTop: self container topHeader bottom! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
contentWidth
	| w |
	w := 0.
	self container allNodeMorphs do: [:n | w := w max: (n columnMorphAt: self index) width].
	^ w! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
rowMorphFor: aNode 
	| rowMorph |
	
	rowMorph := self rowMorphGetSelector
		ifNil: [aNode rowMorphForColumn: self]
		ifNotNil: [self rowMorphGetterBlock value: aNode value: self container].
	rowMorph := rowMorph asMorph.
	rowMorph
		ifNotNil: [rowMorph borderWidth: 0]
		ifNil: [rowMorph := self defaultRowMorph].
	^ rowMorph rowMorphForNode: aNode inColumn: self! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
headerButtonLabel: aLabel font: aFont icon: anIconForm target: aReceiver actionSelector: aSelector arguments: aCollection
	self headerButton.
	self header label: aLabel font: aFont.
	self header icon: (ImageMorph new form: anIconForm).
	self header actionSelector: aSelector.
	self header target: aReceiver.
	self header arguments: aCollection! !

!MorphTreeColumn methodsFor: 'accessing' stamp: ''!
asDraggableMorph
	^ self thumbnailOfSize: self header fullBounds extent! !

!MorphTreeColumn methodsFor: 'testing' stamp: ''!
isFirstColumn
	^ container columns first = self! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
container: aTreeMorph
	container := aTreeMorph! !

!MorphTreeColumn methodsFor: 'accessing' stamp: ''!
thumbnailOfSize: thumbExtent
	"Answer a new thumbnail for the receiver."

	|f t r|
	r := self header fullBounds scaledAndCenteredIn: (0@0 extent: thumbExtent).
	f := Form extent: r extent depth: Display depth.
	t := MatrixTransform2x3 withScale: 1.0.
	f getCanvas
		transformBy: t
		clippingTo: f boundingBox
		during: [:c | c translateBy: self visibleBounds topLeft negated during: [:ct | self container fullDrawOn: ct]]
		smoothing: 6.
	^ImageMorph new
		form: f! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
headerButton
	self header: ((TreeColumnButtonMorph new) 
		layoutPolicy: RowLayout new; 
		listDirection: #leftToRight; 
		wrapCentering: #center;
		cellInset: 5@0;
		layoutInset: 5@0;
		yourself)! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
visibleBounds
	^ self header bounds withBottom: self container scroller bottom! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
index
	^ self container columns indexOf: self! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
header: aMorph
	header := aMorph clipSubmorphs: true; yourself.
	header model: self! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
itemMorphGetter: aSelectorOrAValuable
	rowMorphGetSelector := aSelectorOrAValuable isSymbol 
		ifTrue: [[:node | node complexContents item perform: aSelectorOrAValuable]]
		ifFalse: [[:node | aSelectorOrAValuable value: node complexContents item]]! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
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: ''!
shrinkWrap
	^ shrinkWrap ifNil: [shrinkWrap := false]! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
fixedWidth: anInteger
	currentWidth := anInteger.
	resizable := false! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
currentWidth
	^ currentWidth ifNil: [currentWidth := self defaultWidth]! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
rowMorphGetSelector
	^ rowMorphGetSelector! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
asPotentialDropTarget
	isPotentialDropTarget := true.
	self container invalidRect: self visibleBounds! !

!MorphTreeColumn methodsFor: 'testing' stamp: ''!
isLastColumn
	^ container columns last = self! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
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: ''!
noMorePotentialDropTarget
	isPotentialDropTarget := false.
	self container invalidRect: self visibleBounds! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
forceWidthTo: anInteger
	currentWidth := anInteger! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
headerButtonLabel: aLabel font: aFont
	self headerButton.
	self header label: aLabel font: aFont.! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
headerButtonLabel: aLabel icon: anIconForm
	self headerButtonLabel: aLabel font: nil.
	self header cellInset: 3@0.
	self header icon: (ImageMorph new form: anIconForm)! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
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: 'geometry' stamp: ''!
height
	^ header ifNil: [0] ifNotNil: [header height]! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
defaultWidth
	^ 100! !

!MorphTreeColumn methodsFor: 'initialization' stamp: ''!
release
	container := nil.
	header := nil.
	self releaseActionMap. "we are not sure if we need it"
	super release.! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
startWidth: anInteger
	currentWidth := anInteger! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
shrinkWrap: aBoolean
	shrinkWrap := aBoolean! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
container
	^ container! !

!MorphTreeColumn methodsFor: 'accessing' stamp: ''!
nodeStringGetter: aSelectorOrAValuable
	rowMorphGetSelector := aSelectorOrAValuable isSymbol 
		ifTrue: [[:node | (node complexContents perform: aSelectorOrAValuable) asMorph]]
		ifFalse: [[:node | (aSelectorOrAValuable value: node complexContents ) asMorph]]! !

!MorphTreeColumn methodsFor: 'column drawing' stamp: ''!
currentWidth: anInteger
	self resizable ifTrue: [currentWidth := anInteger]! !

!MorphTreeColumnButton commentStamp: ''!
A button in a morphic based tree!
!MorphTreeColumnButton class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!MorphTreeListManager commentStamp: ''!
A manager caring about a morphic based tree!
!MorphTreeListManager methodsFor: 'selection accessing' stamp: ''!
selectedMorphList
	^ selectedMorphList ifNil: [selectedMorphList := LinkedList new]! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
setSelectedMorph: aMorph
	| path |
	path := aMorph ifNotNil: [ aMorph path collect: [ :m | m complexContents ] ].
	self lastClickedMorph: aMorph.
	self emptySelection.
	aMorph 
		ifNotNil: [ self addToSelection: lastClickedMorph ].
	self selectionUpdateFromViewWhile: [ 
			self listModel selection: (self newSelectionHolderWithNodePath: path) ]! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
potentialDropMorph

	^ potentialDropMorph! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
searchedElement

	^ searchedElement! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
firstClickedMorph: aNodeMorph

	firstClickedMorph := aNodeMorph! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
lastKeystrokeTime

	^ lastKeystrokeTime! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
addAllToSelection: aCollection
| selHolder |
	self searchedElement: nil.
	aCollection do: [:m | m 
		highlight;
		selected: true ].
	self selectionChanged.
	self selectionUpdateFromViewWhile: [
		selHolder := self newSelectionHolderWithNodePath: (aCollection last path collect: [:m | m complexContents]).
		self listModel selection: selHolder]! !

!MorphTreeListManager methodsFor: 'client list accessing' stamp: ''!
numSelectionsInView
	^ client numSelectionsInView! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
lastKeystrokes

	^ lastKeystrokes! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
updateSelectionFromModel
	(self listModel selection) 
		ifNotNil: [:selHolder | 	
				self isSelectionUpdateFromView
					ifTrue: [
						self listModel selectionChanged.
						self selectionChanged]
					ifFalse: [selHolder updateView: client forModel: self listModel]].! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
addToSelection: aMorph clickedTheCheckBox: checkBox
	aMorph selected ifTrue: [^false].
	self searchedElement: nil.
	checkBox ifFalse: [ aMorph highlight ].
	aMorph selected: true.
	^ true! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
multipleSelection

	^ multipleSelection ifNil: [multipleSelection := false]! !

!MorphTreeListManager methodsFor: 'keyboard managing' stamp: ''!
setSelectionIndexFromKeyboard: index multiSelection: multiSelect event: anEvent
	"Called internally to select the index-th item."
	| targetMorph |
	index ifNil: [^ self].
	index > self allNodeMorphs size ifTrue: [^self].
	targetMorph := index = 0 ifTrue: [nil] ifFalse: [self allNodeMorphs at: index].
	lastClickedMorph ifNotNil: [lastClickedMorph highlightForMouseDown: false].
	self isCheckList
		ifTrue: [
			(multiSelect and: [anEvent shiftPressed])
				ifTrue: [self autoMultiSelect: targetMorph]]
		ifFalse: [
			(multiSelect and: [anEvent shiftPressed])
				ifTrue: [self autoMultiSelect: targetMorph]
				ifFalse: [self setSelectedMorph: targetMorph]].
	self lastClickedMorph: (firstClickedMorph := targetMorph).
	anEvent shiftPressed
		ifTrue: [lastClickedMorph highlightForMouseDown: true].

	self selectionChanged.
	self scrollToShow: targetMorph contentBounds! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
firstClickedMorph

	^ firstClickedMorph! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
isSelectionUpdateFromView
	^ isSelectionUpdateFromView ifNil: [isSelectionUpdateFromView := false]! !

!MorphTreeListManager methodsFor: 'selection accessing' stamp: ''!
selectedMorph
	^ self selectedMorphList
		ifNotEmpty: [ :l | l last]
 		ifEmpty: []! !

!MorphTreeListManager methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	lastKeystrokeTime := 0.
	lastKeystrokes := ''.
	lastSelection := 0.
	removeOnlyLastSelected := false! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
selectOnlyLastHighlighted
	^ removeOnlyLastSelected! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
selectionChanged
	client selectionChanged! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
lastSelection

	^ lastSelection! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
removeFromSelection: aMorph
	aMorph selected ifFalse: [^false].
	aMorph selected: false.
	aMorph unhighlight.
	self selectionUpdateFromViewWhile: [ | selHolder | 
		selHolder := self newSelectionHolderWithNodePath: nil.
		self listModel selection: selHolder].
	^ true! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
listModel
	^ client model! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
deselectAll
	| selHolder |
	self allNodeMorphs isEmpty
		ifTrue: [^ self].
	self emptySelection.
	self selectionUpdateFromViewWhile: [
		selHolder := self newSelectionHolderWithNodePath: nil.
		self listModel selection: selHolder]! !

!MorphTreeListManager methodsFor: 'mouse managing' stamp: ''!
mouseUp: event on: aNodeMorph 
	| path cmdOrCtrl clickedTheCheckbox |
	"No change if model is locked" 
	
	clickedTheCheckbox := self clicked: event inTheCheckboxOf: aNodeMorph.
	self listModel okToChange ifFalse: [^self].
	self listModel okToDiscardEdits ifFalse: [^ self].

	cmdOrCtrl := self commandOrCrontrolKeyPressed: event.
	
	path := (event shiftPressed and: [self isMultiple])
				ifTrue: [self shiftSelectMorph: aNodeMorph]
				ifFalse: [
					self autoMultiSelection
						ifTrue: [self selectedMorphList ifEmpty: [] ifNotEmpty: [:l | l last path collect: [:p | p complexContents]]]
						ifFalse: [self selectMorph: aNodeMorph multiple: ((cmdOrCtrl and: [self isMultiple]) or: [self autoMultiSelection]) clickedTheCheckBox: clickedTheCheckbox ]].
	self selectionUpdateFromViewWhile: [ | selHolder | 
		selHolder := self newSelectionHolderWithNodePath: path.
		self listModel selection: selHolder].
	
	clickedTheCheckbox ifFalse: [ self lastClickedMorph: aNodeMorph ].
	self selectionChanged.! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
shiftSelectMorph: aNodeMorph 
	| m |
	m := aNodeMorph ifNil: [self allNodeMorphs last].
	self emptySelection.
	self searchedElement: nil.
	self 
		from: firstClickedMorph 
		to: m 
		do: [:nd | self addToSelection: nd]. 
	self lastClickedMorph: m.
	^ m path collect: [:p | p complexContents]! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
silentlySetSelectedMorph: aMorph
	| path |
	
	path := aMorph ifNotNil: [ aMorph path collect: [ :m | m complexContents ] ].
	self isMultiple ifFalse: [ self emptySelection ].
	
	aMorph ifNotNil: [ self addToSelection: aMorph ].
	
	self selectionUpdateFromViewWhile: [ 
			self listModel selection: (self newSelectionHolderWithNodePath: path) ]! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
toggleExpandedState: aMorph
	aMorph toggleExpandedState.
	client innerWidgetChanged! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
isCheckList: aBoolean
	isCheckList := aBoolean! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
removeOnlyLastSelected: aBoolean

	removeOnlyLastSelected := aBoolean! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
client: aMorphList
	client := aMorphList! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
autoDeselection: aBoolean

	autoDeselection := aBoolean! !

!MorphTreeListManager methodsFor: 'client list accessing' stamp: ''!
scrollToShow: aRectangle
	client scrollToShow: aRectangle! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
autoDeselection
	^ autoDeselection
		ifNil: [autoDeselection := false]! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
autoMultiSelection
	^ autoMultiSelection ifNil: [autoMultiSelection := false]! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
selectMoreAtBottom
	| last |
	autoTargetMorph ifNil: [^self].
	last := autoTargetMorph index.
	last < self allNodeMorphs size
		ifTrue: [
			self autoMultiSelect: (self allNodeMorphs at: last + 1).
			self selectionChanged]! !

!MorphTreeListManager methodsFor: 'keyboard managing' stamp: ''!
arrowEvent: event key: aChar 
	"Handle a keyboard navigation character. Answer true if handled, false
	if not."
	| newIndex targetMorph targetIndex multi |
	
	self allNodeMorphs ifEmpty: [ ^ false].
	self listModel okToChange ifFalse: [^ false].
	self listModel okToDiscardEdits ifFalse: [^ false].

	newIndex := nil.
	targetMorph := lastClickedMorph.
	"Give the oportunity to model to handle the keystroke event. 
	 This is an ugly HACK due to the lack of proper key handling... but I can live with it for now"
	targetMorph ifNotNil: [  
		(self listModel arrowEvent: event key: aChar target: targetMorph)
			ifTrue:  [ ^  true ]].

	targetIndex := targetMorph
		ifNil: [ 0 ]
		ifNotNil: [ targetMorph index ].
	multi := (event shiftPressed and: [self isMultiple]) or: [self autoMultiSelection].
	aChar = Character arrowDown
		ifTrue: [newIndex := targetIndex + 1].
	aChar = Character arrowUp
		ifTrue: [newIndex := targetIndex - 1 max: 1].
	aChar = Character home
		ifTrue: [newIndex := 1].
	aChar = Character end
		ifTrue: [newIndex := self allNodeMorphs size].
	aChar = Character pageUp
		ifTrue: [newIndex := targetIndex - self numSelectionsInView max: 1].
	aChar = Character pageDown
		ifTrue: [newIndex := targetIndex + self numSelectionsInView].
	aChar = Character arrowRight
		ifTrue: [
			targetMorph ifNil: [^ false].
			(targetMorph canExpand and: [targetMorph isExpanded not])
				ifTrue: [
					self toggleExpandedState: targetMorph.
					^ true]
				ifFalse: [ newIndex := targetIndex + 1 ] ].
	aChar = Character arrowLeft
		ifTrue: [
			targetMorph ifNil: [^ false].
			(targetMorph canExpand and: [targetMorph isExpanded])
				ifTrue: [
					self toggleExpandedState: targetMorph.
					^ true]
				ifFalse: [ | parent |
					parent := targetMorph parent.
					parent
						ifNil: [newIndex := targetIndex - 1 max: 1]
						ifNotNil: [
							self toggleExpandedState: parent.
							newIndex := parent index]]].
	newIndex notNil
		ifTrue: [
			self
				setSelectionIndexFromKeyboard: newIndex
				multiSelection: multi
				event: event.
			self selectionChanged.
			^ true].
	^ false! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
emptySelection 
	self selectedMorphList do: [:n | n unhighlight; setSelectedSilently: false].
	self selectedMorphList removeAll.
	self selectionChanged! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
searchedElement: anObject

	searchedElement := anObject! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
selectMorph: aNodeMorph multiple: withMultipleSelection

	| path mult |

	self lastClickedMorph: aNodeMorph.
	aNodeMorph
		ifNil: [ 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: 'keyboard managing' stamp: ''!
keyDownActionSelector: aSelector

	keyDownActionSelector := aSelector! !

!MorphTreeListManager methodsFor: 'keyboard managing' stamp: ''!
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"
            oldSelection := oldSelection + 1.
            lastKeystrokes := aChar asLowercase asString.]
        ifFalse: ["append quick keystrokes but don't move selection if it still matches"
            lastKeystrokes := lastKeystrokes , aChar asLowercase asString.].

    oldSelection isZero
        ifFalse:
            [ nextSelectionNodeMorph := self allNodeMorphs
                detect:
                    [ :a |
                    a index >= oldSelection and: [
                    "Get rid of blanks and style used in some lists"
                    a complexContents asString trimBoth asLowercase beginsWith: lastKeystrokes ]]
                ifNone: [     "roll over" oldSelection := 0 ] ].
               
    oldSelection isZero
        ifTrue:
            [ nextSelectionNodeMorph := self allNodeMorphs
                detect:
                    [ :a |
                    "Get rid of blanks and style used in some lists"
                    a complexContents asString trimBoth asLowercase beginsWith: lastKeystrokes ]
                ifNone: [ ^ self ] ].
           
    nextSelection := nextSelectionNodeMorph index.
    "No change if model is locked"
    self listModel okToChange ifFalse: [^ self].
    self searchedElement: nextSelectionNodeMorph.

    lastSelection := nextSelection.
    "change scrollbarvalue"
    self scrollToShow: nextSelectionNodeMorph contentBounds.
    self selectionChanged! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
nodeMorphsWithAllNodeItems: aNodeItemList
	| result |

	result := OrderedCollection new.
	
	self allNodeMorphs do: [:m | 
		aNodeItemList do: [ :sel | (m expandPath: sel) ] ].
	
	self allNodeMorphs do: [:m | 
		aNodeItemList do: [ :sel | (m matchPath: sel)
			ifNotNil: [:col | result addAll: col ] ] ].

	^ result flattened! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
isCheckList
	^ isCheckList ifNil: [isCheckList := false]! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
selectionUpdateFromViewWhile: aBlock
	| prev |
	prev := self isSelectionUpdateFromView.
	isSelectionUpdateFromView := true.
	aBlock ensure: [isSelectionUpdateFromView := prev]! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
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 contentBounds]! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
isMultiple	
	^ multipleSelection ifNil: [ multipleSelection := false ]! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
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: ''!
autoAction
	^ firstClickedMorph
		ifNotNil: [
			firstClickedMorph selected
				ifTrue: [#addToSelection:]
				ifFalse: [#removeFromSelection:]].! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
getSelectionIndexOf: aMorph
	^ aMorph ifNil: [0] ifNotNil: [aMorph index]! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
selectMorph: aNodeMorph multiple: withMultipleSelection clickedTheCheckBox: checkBox

	| path mult |
	checkBox
		ifFalse: [ self lastClickedMorph: aNodeMorph ].
	aNodeMorph
		ifNil: [ self emptySelection.
				^ nil ].
	aNodeMorph selected
		ifTrue: [ withMultipleSelection
				ifTrue: [ self removeFromSelection: aNodeMorph ]
				ifFalse: [ mult := self selectedMorphList size > 1.
					path := aNodeMorph path collect: [ :m | m complexContents ].
					( self autoDeselection or: [ mult ] )
						ifTrue: [ self emptySelection.
							mult
								ifTrue: [ self addToSelection: aNodeMorph ]
								ifFalse: [ path := nil ]
							]
					]
			]
		ifFalse: [ withMultipleSelection
				ifFalse: [ self emptySelection ].
			self addToSelection: aNodeMorph clickedTheCheckBox: checkBox.
			path := aNodeMorph path collect: [ :m | m complexContents ]
			].
	self selectionChanged.
	^ path! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
potentialDropMorph: anObject

	potentialDropMorph := anObject! !

!MorphTreeListManager methodsFor: 'client list accessing' stamp: ''!
allNodeMorphs
	^ client allNodeMorphs! !

!MorphTreeListManager methodsFor: 'keyboard managing' stamp: ''!
keyDown: anEvent
	| char args |
	char := anEvent keyValue asCharacter.

	(self arrowEvent: anEvent key: char) ifTrue: [ ^ true ].

	char = Character cr
		ifTrue: [ self selectSearchedElement.
			^ true ].

	anEvent anyModifierKeyPressed
		ifFalse: [ self basicKeyPressed: char.
			^ true ].
		
	keyDownActionSelector ifNil: [ ^ false ].

	args := keyDownActionSelector numArgs.
	^ (args = 0 or: [ args > 2 ])
		ifTrue: [ self error: 'The keyDownActionSelector must be a 1- or 2-keyword symbol' ]
		ifFalse: [ args = 1
				ifTrue: [ self listModel perform: keyDownActionSelector with: anEvent ]
				ifFalse: [ self listModel perform: keyDownActionSelector with: anEvent with: self ] ]! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
selectAll
	self allNodeMorphs isEmpty
		ifTrue: [^ self].
	self isMultiple
		ifFalse: [^ self]. 
	self addAllToSelection: self allNodeMorphs! !

!MorphTreeListManager methodsFor: 'mouse managing' stamp: ''!
doubleClick: anEvent on: aMorph
	self doubleClickSelector  ifNil: [^false].
	client model perform: self doubleClickSelector withEnoughArguments: { anEvent. aMorph }.
	^ true! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
lastClickedMorph: aNodeMorph

	lastClickedMorph ifNotNil: [ lastClickedMorph complexContents lastClicked: false ].
	lastClickedMorph := aNodeMorph.
	aNodeMorph ifNotNil: [ aNodeMorph complexContents lastClicked: true ].! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
doubleClickSelector

	^ doubleClickSelector! !

!MorphTreeListManager methodsFor: 'mouse managing' stamp: ''!
mouseDown: event on: aTargetMorph
	"Changed to take keybaord focus."
	| clickedTheCheckbox |
	
	clickedTheCheckbox := self clicked: event inTheCheckboxOf: aTargetMorph.
	
	(self autoMultiSelection and: [ event shiftPressed not ])
		ifTrue: [ 
			firstClickedMorph := aTargetMorph.
			aTargetMorph selected
				ifTrue: [ 
					self removeFromSelection: aTargetMorph.
					(clickedTheCheckbox not and: [ self selectOnlyLastHighlighted and: [ aTargetMorph hasContentToShow ] ])
						ifTrue: [ 
							aTargetMorph = self lastClickedMorph
								ifFalse: [ self addToSelection: aTargetMorph ] ] ]
				ifFalse: [ 
					(clickedTheCheckbox not and: [ self selectOnlyLastHighlighted and: [ aTargetMorph hasContentToShow ] ])
						ifTrue: [ 
							aTargetMorph = self lastClickedMorph
								ifTrue: [ 
									self addToSelection: aTargetMorph.
									clickedTheCheckbox
										ifFalse: [ self lastClickedMorph: aTargetMorph ] ] ]
						ifFalse: [ 
							self addToSelection: aTargetMorph.
							clickedTheCheckbox
								ifFalse: [ self lastClickedMorph: aTargetMorph ] ] ] ].
	
	(clickedTheCheckbox not and: [ event shiftPressed not or: [ firstClickedMorph isNil ] ])
		ifTrue: [ firstClickedMorph := aTargetMorph ].
	
	aTargetMorph mouseDown: event! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
noteRemovalOfAll: aMorphList
	"When noting the removal of items, do not change their model status: the model will be in charge of it (i.e. either updates from the model or expand/collapse things)."

	aMorphList
		do: [ :each | 
			self selectedMorphList remove: each ifAbsent: [  ].
			lastClickedMorph == each
				ifTrue: [ lastClickedMorph := nil ] ]! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
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: 'accessing' stamp: ''!
columnDropUnabled: aBoolean

	columnDropUnabled := aBoolean! !

!MorphTreeListManager methodsFor: 'client list accessing' stamp: ''!
commandOrCrontrolKeyPressed: anEvent
	^ client commandOrCrontrolKeyPressed: anEvent! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
addToSelection: aMorph
	aMorph selected ifTrue: [^false].
	self searchedElement: nil.
	aMorph highlight.
	aMorph selected: true.
	^ true! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
lastKeystrokeTime: anObject

	lastKeystrokeTime := anObject! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
autoMultiSelection: aBoolean
	autoMultiSelection := aBoolean.
	aBoolean ifTrue: [self multipleSelection: true]! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
multipleSelection: anObject

	multipleSelection := anObject! !

!MorphTreeListManager methodsFor: 'mouse managing' stamp: ''!
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: 'selection change' stamp: ''!
selectedItems: aNodeItemCollection

	self listModel okToDiscardEdits ifFalse: [^ self].
	self emptySelection.
	(self nodeMorphsWithAllNodeItems: aNodeItemCollection) ifNotEmpty:[:selection |
	self addAllToSelection: selection].
	lastClickedMorph
		ifNil: [lastClickedMorph := self selectedMorphList
						ifEmpty: []
						ifNotEmpty: [self selectedMorphList last]]! !

!MorphTreeListManager methodsFor: 'mouse managing' stamp: ''!
clicked: event inTheCheckboxOf: aTargetMorph
	| position |

	aTargetMorph ifNil: [ ^ false ].
	position := aTargetMorph point: event position from: client.
	^ self isCheckList and: [ (aTargetMorph checkClickableZone translateBy: 2 @ 0) containsPoint: position ]! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
doubleClickSelector: aSelector

	doubleClickSelector := aSelector! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
lastClickedMorph

	^ lastClickedMorph! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
lastKeystrokes: anObject

	lastKeystrokes := anObject! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
selectMoreAtTop
	| first |
	autoTargetMorph ifNil: [^self].
	first := autoTargetMorph index.
	first > 1
		ifTrue: [
			self autoMultiSelect: (self allNodeMorphs at: first - 1).
			self selectionChanged]! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
lastSelection: anObject

	lastSelection := anObject! !

!MorphTreeListManager methodsFor: 'selection change' stamp: ''!
updateLastClickedMorph
	"When the contents have been updated, ensure that lastClickedMorph refer to a correct morph."

	lastClickedMorph
		ifNil: [ lastClickedMorph := self selectedMorphList ifEmpty: [  ] ifNotEmpty: [ self selectedMorphList last ] ]
		ifNotNil: [ 
			self allNodeMorphs
				do: [ :each | 
					each complexContents withoutListWrapper = lastClickedMorph complexContents withoutListWrapper
						ifTrue: [ lastClickedMorph := each ] ] ]! !

!MorphTreeListManager methodsFor: 'selection accessing' stamp: ''!
secondSelection: anItem

 	| nodeMorph |
	nodeMorph := self allNodeMorphs detect: [ :e | e complexContents item == anItem ].
	self searchedElement: nodeMorph.
	client changed.! !

!MorphTreeListManager methodsFor: 'accessing' stamp: ''!
columnDropUnabled

	^ columnDropUnabled! !

!MorphTreeListManager methodsFor: 'private' stamp: ''!
selectSearchedElement

	self searchedElement 
		ifNotNil: [ :selectedMorph | 
			self setSelectedMorph: selectedMorph.
			self searchedElement: nil ]! !

!MorphTreeModel commentStamp: ''!
I'm the base class for tree models.  See ClassListExample for basic usage.!
!MorphTreeModel methodsFor: 'expanding-collapsing' stamp: ''!
expandItemPath: anItemPath
	self  requestView: (MorphTreeChangeRequest expandItemPath: anItemPath)! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
selectedNodePath
	^ self selection ifNotNil: [:s | s lastSelectedNodePath]! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
okToDiscardEdits 
	^ self canDiscardEdits  or: [self promptForCancel]! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
treeMorphClass
	^ MorphTreeMorph! !

!MorphTreeModel methodsFor: 'view' stamp: ''!
defaultMorphIn: aThemable
	^ self defaultTreeMorph! !

!MorphTreeModel methodsFor: 'dialog' stamp: ''!
headerLabel

	^ headerLabel! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
rootNodeClassFromItem: anItem
	^ MorphTreeNodeModel! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
beCheckList
	self isCheckList: true! !

!MorphTreeModel methodsFor: 'dialog' stamp: ''!
openDialogWindowIn: aWindow title: aTitle selectedtems: aCollection 
	| dialog |
	dialog := self dialogWindowIn: aWindow title: aTitle selectedtems: aCollection.
	dialog openModal.
	^ dialog cancelled ifFalse: [self selectedItems]! !

!MorphTreeModel methodsFor: 'expanding-collapsing' stamp: ''!
expandAllFromNode: aNode
	self  requestView: (MorphTreeChangeRequest expandAllFromNode: aNode)! !

!MorphTreeModel methodsFor: 'announcing' stamp: ''!
onSelectionChangeSend: aSelector to: anObject
	self on: MorphTreeSelectionChanged send: aSelector to: anObject! !

!MorphTreeModel methodsFor: 'dialog' stamp: ''!
dialogWindowIn: aWindow title: aTitle selectedtems: aCollection 
	| dialog dialogMorph |
	dialog := self theme
				newPluggableDialogWindowIn: aWindow
				title: aTitle
				for: (dialogMorph := self defaultMorphIn: aWindow).
	dialogMorph buildContents; selectedItems: aCollection.
	dialog minimumExtent: 300 @ 500.
	dialog beResizeable.
	^ dialog! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
promptForCancel
	"Ask if it is OK to cancel changes"
	
	^(self confirm:
'Changes have not been saved.
Is it OK to cancel changes?' translated)! !

!MorphTreeModel methodsFor: 'announcing' stamp: ''!
requestView: anAnnouncement
	^ self announcer announce: anAnnouncement! !

!MorphTreeModel methodsFor: 'selecting' stamp: ''!
selection: aSelection
	self setSelection: aSelection.
	self  requestView: MorphTreeChangeRequest updateSelectionFromModel! !

!MorphTreeModel methodsFor: 'selecting' stamp: ''!
setSelection: aSelection
	selection := aSelection.! !

!MorphTreeModel methodsFor: 'selecting' stamp: ''!
selectItems: aListOfItems
	self selection: nil.
	self requestView: ( MorphTreeChangeRequest selectItems: aListOfItems )! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
selectedNode
	^ self selectedNodePath ifNotNil: [:path | path ifEmpty: [nil] ifNotEmpty: [path last]]! !

!MorphTreeModel methodsFor: 'expanding-collapsing' stamp: ''!
expandAll
	self  requestView: MorphTreeChangeRequest expandAll! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
rootItems: aCollection
	rootItems := aCollection.! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
selectedItem
	^ self selectedNode ifNotNil: [:node | node item]! !

!MorphTreeModel methodsFor: 'selecting' stamp: ''!
selectionChanged
	self requestView: (MorphTreeSelectionChanged new selection: self selection)! !

!MorphTreeModel methodsFor: 'expanding-collapsing' stamp: ''!
expandNodePath: aNodePath
	self requestView: (MorphTreeChangeRequest expandNodePath:  aNodePath)! !

!MorphTreeModel methodsFor: 'selecting' stamp: ''!
deselectAll
	self  requestView: MorphTreeChangeRequest deselectAll! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
enable
	self enabled: true! !

!MorphTreeModel methodsFor: 'selecting' stamp: ''!
selection
	^ selection.! !

!MorphTreeModel methodsFor: 'expanding-collapsing' stamp: ''!
expandRoots
	self requestView: (MorphTreeChangeRequest expandRoots)! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
enabled
	^ enabled ifNil: [ enabled := true ]! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
isCheckList: aBoolean
	^ isCheckList := aBoolean! !

!MorphTreeModel methodsFor: 'dialog' stamp: ''!
openDialogWindowIn: aWindow title: aTitle
	^ self openDialogWindowIn: aWindow title: aTitle selectedtems: Array new! !

!MorphTreeModel methodsFor: 'keyboard managing' stamp: ''!
arrowEvent: event key: aChar target: aMorph
	"Give model the capability of handle a key before is handled by MorphTreeListManager"
	^ false! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
defaultPageSize
	^ nil! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
autoMultiSelection
	^ autoMultiSelection ifNil: [autoMultiSelection := false]! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
wrapBlockOrSelector

	^ wrapBlockOrSelector ifNil: [wrapBlockOrSelector := #printString]! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
multiSelection: aBoolean
	multiSelection := aBoolean! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
isCheckList
	^ isCheckList ifNil: [isCheckList := false]! !

!MorphTreeModel methodsFor: 'view' stamp: ''!
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;
			"preferedPaneColor: Color white;"
			multiSelection: self multiSelection;
			autoMultiSelection: self autoMultiSelection;
			itemStringGetter: [:item | self wrapItem: item];
			isCheckList: self isCheckList";
			rowColorForEven: Color veryLightGray muchLighter odd: Color white".! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
multiSelection
	^ multiSelection ifNil: [multiSelection := false]! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
deeplyDetect: aBlock 
	self rootNodes
		do: [:sub | (sub deeplyDetect: aBlock)
				ifNotNil: [:found | ^ found]].
	^ nil! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
headerLabel: aString
	
	headerLabel := aString! !

!MorphTreeModel methodsFor: 'help-text' stamp: ''!
helpText

	^ nil! !

!MorphTreeModel methodsFor: 'selecting' stamp: ''!
selectAll
	self requestView: MorphTreeChangeRequest selectAll! !

!MorphTreeModel methodsFor: 'announcing' stamp: ''!
on: anAnnouncementClass send: aSelector to: anObject
	self announcer when: anAnnouncementClass send: aSelector to: anObject! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	aBoolean ~= enabled
		ifTrue: [ 
			enabled := aBoolean.
			self  requestView: MorphTreeChangeRequest enabled]! !

!MorphTreeModel methodsFor: 'expanding-collapsing' stamp: ''!
collapseAll
	self  requestView:  MorphTreeChangeRequest collapseAll! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
autoMultiSelection: aBoolean
	autoMultiSelection := aBoolean! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
disable
	self enabled: false! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
keyStroke: anEvent from: aTreeView! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
selectAllNodePaths: aCollectionOfNodePath
	self selection: (MorphTreeMorphMultipleSelection new selectedNodePathList: aCollectionOfNodePath)! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
menu: menu shifted: b
	^ menu! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
wrapBlockOrSelector: aBlockOrSelector

	wrapBlockOrSelector := aBlockOrSelector! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
defaultChunkSize
	^ nil! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
rootNodeFromItem: anItem
	^ (self rootNodeClassFromItem: anItem) with: anItem model: self! !

!MorphTreeModel methodsFor: 'dialog' stamp: ''!
dialogWindowIn: aWindow title: aTitle
	^ self dialogWindowIn: aWindow title: aTitle selectedtems: Array new! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
rootNodes
	^ (self rootItems ifNil: [^nil])
		collect: [:ci | self rootNodeFromItem: ci].! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
selectedItems
	^ selection 
		ifNil: [OrderedCollection new]
		ifNotNil: [selection selectedItems]! !

!MorphTreeModel methodsFor: 'expanding-collapsing' stamp: ''!
collapseNodePath: aNodePath
	self  requestView: (MorphTreeChangeRequest collapseNodePath: aNodePath)! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
selectNodePath: aNodePath
	self selection: (MorphTreeMorphSingleSelection new selectedNodePath: aNodePath)! !

!MorphTreeModel methodsFor: 'updating' stamp: ''!
updateList
	| items |
	items := self selectedItems.
	self requestView: MorphTreeChangeRequest updateList.
	self selectItems: items! !

!MorphTreeModel methodsFor: 'accessing' stamp: ''!
rootItems

	^ rootItems ifNil: [ rootItems := {} ]! !

!MorphTreeModel methodsFor: 'wrapping' stamp: ''!
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 methodsFor: 'examples' stamp: ''!
exampleCheckList1
	<sampleInstance>
	"self exampleCheckList1"
	Cursor wait 
		showWhile: [
			^ self new
				beCheckList;
				rootItems: (Object allSubclasses sort: [:a :b | a name <= b name]);
				 headerLabel: 'Sub-classes';
				 openDialogWindowIn: self currentWorld title: 'All Object sub-classes ready to be checked']! !

!MorphTreeModel class methodsFor: 'item handling' stamp: ''!
itemsList: itemsList itemsHeaderName: aName wrapBlockOrSelector: wrapBlockOrSelector

	^ self new
		wrapBlockOrSelector: wrapBlockOrSelector;
		rootItems: itemsList;
		headerLabel: aName;
		yourself! !

!MorphTreeModel class methodsFor: 'examples' stamp: ''!
exampleCheckList2
	<sampleInstance>
	"self exampleCheckList2"
	| model |
	model := self new rootItems: Morph methods.
	model
		 wrapBlockOrSelector: #selector;
		 autoMultiSelection: true;
		 headerLabel: 'Plop';
		 beCheckList.
	^ (model openDialogWindowIn: self currentWorld title: 'All Morph methods')! !

!MorphTreeModel class methodsFor: 'item handling' stamp: ''!
itemsList: itemsList itemsHeaderName: aName

	^ self new
		rootItems: itemsList;
		headerLabel: aName;
		yourself! !

!MorphTreeModel class methodsFor: 'item handling' stamp: ''!
itemsList: itemsList

	^ self new
		rootItems: itemsList;
		yourself! !

!MorphTreeModel class methodsFor: 'examples' stamp: ''!
exampleCheckList3
	<sampleInstance>
	"self exampleCheckList3"
	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]! !

!MorphTreeMorph commentStamp: ''!
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:		<Object>
	autoMultiSelection:		<Object>
	columnColors:		<Object>
	columnDropUnabled:		<Object>
	columnInset:		<Object>
	columnResizers:		<Object>
	columns:		<Object>
	doubleClickSelector:		<Object>
	expandedToggleImage:		<Object>
	gapAfterIcon:		<Object>
	gapAfterToggle:		<Object>
	getListSelector:		<Object>
	getSelectionSelector:		<Object>
	hasToggleAtRoot:		<Object>
	iconReservedExtent:		<Object>
	indentGap:		<Object>
	keystrokeActionSelector:		<Object>
	lastSelectedMorph:		<Object>
	lineColor:		<Object>
	multipleSelection:		<Object>
	nodeList:		<Object>
	nodeSortBlock:		<Object>
	notExpandedToggleImage:		<Object>
	pager:		<Object>
	potentialDropMorph:		<Object>
	preferedPaneColor:		<Object>
	resizerWidth:		<Object>
	rowColors:		<Object>
	rowInset:		<Object>
	scrollDeltaHeight:		<Object>
	selectedMorphList:		<Object>
	setSelectionSelector:		<Object>
	shiftSelectedMorph:		<Object>
	topHeader:		<Object>
	topHeaderBackground:		<Object>
	unboundLastColumn:		<Object>
	withHLines:		<Object>

autoDeselection
	- xxxxx

autoMultiSelection
	- xxxxx

columnColors
	- xxxxx

columnDropUnabled
	- xxxxx

columnInset
	- xxxxx

columnResizers
	- xxxxx

columns
	- xxxxx

doubleClickSelector
	- xxxxx

expandedToggleImage
	- xxxxx

gapAfterIcon
	- xxxxx

gapAfterToggle
	- xxxxx

getListSelector
	- xxxxx

getSelectionSelector
	- xxxxx

hasToggleAtRoot
	- xxxxx

iconReservedExtent
	- xxxxx

indentGap
	- xxxxx

keystrokeActionSelector
	- xxxxx

lastSelectedMorph
	- xxxxx

lineColor
	- xxxxx

multipleSelection
	- xxxxx

nodeList
	- xxxxx

nodeSortBlock
	- xxxxx

notExpandedToggleImage
	- xxxxx

pager
	- xxxxx

potentialDropMorph
	- xxxxx

preferedPaneColor
	- xxxxx

resizerWidth
	- xxxxx

rowColors
	- xxxxx

rowInset
	- xxxxx

scrollDeltaHeight
	- xxxxx

selectedMorphList
	- xxxxx

setSelectionSelector
	- xxxxx

shiftSelectedMorph
	- xxxxx

topHeader
	- xxxxx

topHeaderBackground
	- xxxxx

unboundLastColumn
	- xxxxx

withHLines
	- xxxxx
!
!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
rowColorForEven: evenColor 
	rowColors at: 1 put: evenColor.! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
buildContents
	nodeList := nil.
	scroller removeAllMorphs.
	(self nodeList isNil or: [self nodeList isEmpty]) 
		ifTrue: [
			nodeList := nil.	
			^ self emptySelection].
	self addSubmorphsFromNodeList.! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
notExpandedForm
	"Answer the form to use for unexpanded items."
	
	^self theme treeUnexpandedForm! !

!MorphTreeMorph methodsFor: 'submorphs - add/remove' stamp: ''!
addMorphsAfter: parentMorph fromCollection: aCollection
	"Sent when expanding a node in order to add chilldren nodes after the expanded node"
	| priorMorph morphList  subs |
	priorMorph := nil.
	morphList := OrderedCollection new.
	
	"prepare the list of nodes to be added"
	aCollection do: [:item | 
		priorMorph := self indentingItemClass new 
			initWithContents: item 
			prior: priorMorph 
			forList: self
			indentLevel: parentMorph indentLevel + 1.
		morphList add: priorMorph.
		"Was this row expanded ? if true -> expand it
			again " 
			priorMorph isExpanded
				ifTrue: [priorMorph isExpanded: true.
					priorMorph
						addChildrenForList: self
						addingTo: morphList
						withExpandedItems: #()] ].
	
	"Set new child morphs index"
	1 to: morphList size do: [:i | | m | (m := morphList at: i) index: i + parentMorph index].
	"Add the new morph list in the scroller"
	scroller addAllMorphs: morphList after: parentMorph.
	"update next morphs index"
	subs := self allNodeMorphs.
	morphList last index to: subs size do: [:pos | (subs at: pos) index: pos].
	"set the new morphs widths according to columns width"
	self updateColumnMorphsWidth.
	morphList do: [ :e | e doLayoutIn: e layoutBounds ].
	^morphList! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
updateSelectionFromModel
	^ self listManager updateSelectionFromModel! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
gapAfterToggle: anInteger
	"set the horizontal space after the toggle"
	gapAfterToggle := anInteger.! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
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: 'column handling' stamp: ''!
removeColumnAtIndex: aPosition
	"remove a column at a given position - rough implementation"
	self columns removeAt: aPosition.
	self columnsChanged.
	self updateList.! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandAllFromNode: aNode
		self expandAll: ((self nodeMorphOfNode: aNode) ifNil: [^self]).
		self adjustSubmorphPositions! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
resetRootInfo
	hasToggleAtRoot := nil.! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
toggleImageHeight
	^ self expandedToggleImage height max: self notExpandedToggleImage height.! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandedNodesFrom: aMorpList

	^ (aMorpList select: [ :each | each isExpanded]) collect: [ :each | each complexContents].! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandedToggleImage
	^ expandedToggleImage ifNil: [expandedToggleImage := ImageMorph new form: self expandedForm].! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
updateColumnMorphs
	self privateUpdateColumnMorphs! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandAll
	"Expand all of the roots"
	
	self roots reverseDo: [:m | self expandAllSilently: m].
	self innerWidgetChanged! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
nodeListSelector
	^ #rootNodes! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
beSingle	
	self listManager multipleSelection: false! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
lineColorForNode: aNode
	"Answer a good color to use for drawing the lines that connect members of the hierarchy view.
	Used the cached color, or derive it if necessary by finding the receiver or 
	the first owner (up to my root) that is not transparent, then picking a contrasting color.
	Fall back to black if all my owners are transparent."

	^ lineColorBlock
		ifNotNil: [lineColorBlock value: aNode]
		ifNil: [
			| colored |
			colored := self color isTransparent
				ifTrue: [self firstOwnerSuchThat: [:o | o isWorldOrHandMorph not and: [o color isTransparent not]]]
				ifFalse: [self].
			colored 
				ifNil: [Color black]
				ifNotNil: [colored color luminance > 0.5
					ifTrue: [Color black]
					ifFalse: [Color white]]]! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandRoots
	"Expand all the receiver's roots"
	
	self roots
		do: [:each |
			(each canExpand and: [each isExpanded not])
				ifTrue: [each toggleExpandedState]].
	self innerWidgetChanged! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
removeOnlyLastSelected: aBoolean
	self listManager removeOnlyLastSelected: aBoolean! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
adoptPaneColor: paneColor
	"Pass on to the selection, the border"
	
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	self color: (self preferedPaneColor ifNil: [ self theme backgroundColor ] ).! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
emptySelection
	self listManager emptySelection! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
updateColumnResizersHeight
	self columnResizers do: [:col | | b |
		b :=  col bounds.
		b := b left @ self top corner: b right @ scroller bottom.
		col bounds: b].! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
multiSelection: aBoolean
	self listManager multipleSelection: aBoolean! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
resizerChanged
	self columns size > 1
		ifTrue: [
			self updateColumnResizersXOffset;
				resizeScroller;
				updateColumnMorphs]
		ifFalse: [self updateTopHeader]! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
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: 'selection' stamp: ''!
selectAll
	self listManager selectAll! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
keyDown: event 
	"Process potential command keys."
	(self navigationKey: event) ifTrue: [^true].
	(self scrollByKeyboard: event) ifTrue: [^true].
	^ self listManager keyDown: event! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
secondarySelectionColor

	^ self theme secondarySelectionColor! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
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: 'selection' stamp: ''!
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: 'events-processing' stamp: ''!
mouseMove: evt

	| targetMorph |
	self enabled ifFalse: [ ^self ].
	targetMorph := self scrollerSubMorphFromPoint: evt position.
	evt hand hasSubmorphs 
		ifFalse: [(self innerBounds containsPoint: evt position)
			ifTrue: [self listManager mouseMove: evt on: targetMorph]].
		
	(self dropEnabled and: [evt hand hasSubmorphs]) 
		ifFalse:[^super mouseMove: evt].
		
	potentialDropMorph 
		ifNotNil:[
			(potentialDropMorph containsPoint: (potentialDropMorph point: evt position from: self))
				ifTrue:[^self]].
			
	self mouseLeaveDragging: evt.
	
	(self containsPoint: evt position) 
		ifTrue: [self mouseEnterDragging: evt].! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
addColumn: aTreeColumn
	"add a column"
	self addColumn: aTreeColumn afterIndex: self columns size! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
autoMultiSelection: aBoolean
	self listManager autoMultiSelection: aBoolean! !

!MorphTreeMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOverDragging: evt
	^self dropEnabled! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
mouseDown: event 
	"Changed to take keybaord focus."
	| targetMorph selectors |
	self enabled ifFalse: [ ^self ].
	mouseOverAllowed := true.
	self wantsKeyboardFocus
		ifTrue: [self takeKeyboardFocus].
	(event yellowButtonPressed and: [(self commandOrCrontrolKeyPressed: event) not])
		ifTrue: ["First check for option (menu) click"			
			^ self yellowButtonEvent: event].
	(targetMorph := self scrollerSubMorphFromPoint: event position)
		ifNotNil: [targetMorph hasToggle
				ifTrue: [(targetMorph
							inToggleArea: (targetMorph point: event position from: self))
						ifTrue: [^ self toggleExpandedState: targetMorph event: event]]].
	targetMorph
		ifNil: [^ super mouseDown: event].
	targetMorph highlightForMouseDown.
	selectors := Array
				with: #click:
				with: #doubleClick:
				with: nil
				with: (self dragEnabled
						ifTrue: [#startDrag:]).
	event hand
		waitForClicksOrDrag: self
		event: event
		selectors: selectors
		threshold: 10.

	self listManager mouseDown: event on: targetMorph! !

!MorphTreeMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	^true! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
indentGap: anInteger
	indentGap := anInteger.! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
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: 'expanding-collapsing' stamp: ''!
expandAllTo: aLevel
	self roots do: [:m | self expand: m to: aLevel].
	self innerWidgetChanged! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
selectNodePath: aPath
	aPath 
		ifNil: [self emptySelection] 
		ifNotNil: [self firstChild 
			ifNotNil: [:fc | fc selectNodePath: aPath]]! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
lineColor: aColor
	lineColorBlock := [:node | aColor]! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
updateList
	|value|
	value := scrollBar value.
	self updateContentsWithPreviouslyExpanded: self currentlyExpanded.
	self vScrollValue: value! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
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: 'selection' stamp: ''!
selectedMorphList
	^ self listManager selectedMorphList! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
withTreeLines: aBoolean
	self  treeLineWidth: 1! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
columns
	"Return a column definitions, if empty, return a collection with one column"
	^columns ifNil: [self columns: (OrderedCollection with: MorphTreeColumn new). columns]! !

!MorphTreeMorph methodsFor: 'event handling' stamp: ''!
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: 'announce requests' stamp: ''!
collapseRequest: anAnnounce
	anAnnounce nodes
		ifEmpty: [^ self collapseAll]
		ifNotEmpty: [:nodes | self collapseNodePath: nodes]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
fillStyleToUse
	"Answer the fillStyle that should be used for the receiver."
	
	^self enabled
		ifTrue: [self theme listNormalFillStyleFor: self]
		ifFalse: [self theme listDisabledFillStyleFor: self]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
setSelectedMorph: aNodeMorph 
	self listManager setSelectedMorph: aNodeMorph! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
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: 'selection' stamp: ''!
beCheckList
	self isCheckList: true.! !

!MorphTreeMorph methodsFor: 'announce requests' stamp: ''!
changeRequest: anAnnounce
	^ anAnnounce change: self! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
minResizerX
	^ scroller left + self minResizerOffset! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
indentingItemClass
	
	^ MorphTreeNodeMorph! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
lineColorBlock
	^ lineColorBlock! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
rowColorForEven: evenColor odd: oddColor
	rowColors at: 2 put: oddColor.
	rowColors at: 1 put: evenColor.! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
roots
	"Answer the receiver's roots"
	^ self rootsFrom: self allNodeMorphs! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
innerWidgetChanged
	self setScrollDeltas.
	self updateColumnMorphsWidth.
	self adjustSubmorphPositions.! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
updateFromSelection: aSelection
	aSelection selectedNodePathList do: [:path | self selectNodePath: path].
	self scrollSelectionIntoView! !

!MorphTreeMorph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
initializeColumsFrom: aModel

	self columns: aModel columns! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
selectedMorph
	^ self listManager selectedMorph! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
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: ''!
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: 'expanding-collapsing' stamp: ''!
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: 'accessing' stamp: ''!
iconBlock: aValuableWithOneArg
	"A valuable which value is an icon or nil. takes a node as argument"
	iconBlock := aValuableWithOneArg! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
mouseEnter: event
	"Changed to take keyboardFocusOnMouseDown preference into account."
	
	super mouseEnter: event.
	self wantsKeyboardFocus ifFalse: [^self].
	self keyboardFocusOnMouseDown ifFalse: [self takeKeyboardFocus]! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
columns: aListOfTreeColumn
	"set the columns -  as a consequence, the topHeader is update (if present) and column resizers are added"

	self removeColumnResizers.
	topHeader ifNotNil: [ self removeMorph: topHeader ].
	columns := aListOfTreeColumn asOrderedCollection.
	aListOfTreeColumn do: [:col | col container: self].
	self buildTopHeader .
	self addColumnResizers.! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
selectionChanged
	self changed! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
enable
	self enabled: true! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
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: 'submorphs - add/remove' stamp: ''!
addSubmorphsFromNodeList
	self addSubmorphsFromNodeList: self currentNodelist previouslyExpanded: #()! !

!MorphTreeMorph methodsFor: 'scrolling' stamp: ''!
hScrollBarValue: scrollValue
	| prev |
	prev := scroller offset x.
	super hScrollBarValue: scrollValue.
	scroller offset x ~= prev
		ifTrue: [
			self updateColumnResizersXOffset.
			self updateTopHeader]! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
rowColorForOdd: oddColor 
	rowColors at: 2 put: oddColor.! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
isCheckList: aBoolean
	self listManager isCheckList: aBoolean.! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
startDrag: anEvent 
	| aTransferMorph itemMorph passenger |
	self dragEnabled
		ifTrue: [itemMorph := self allNodeMorphs
						detect: [:any | any highlightedForMouseDown]
						ifNone: []].
	(itemMorph isNil
			or: [anEvent hand hasSubmorphs])
		ifTrue: [^ self].
	itemMorph highlightForMouseDown: false.
	
	(self listManager selectedMorphList includes: itemMorph)
		ifFalse: [self listManager setSelectedMorph: itemMorph].
		
	passenger := self model dragPassengerFor: itemMorph inMorph: self.
	passenger
		ifNotNil: [
			aTransferMorph := self model transferFor: passenger from: self.
				"Ask the draggedMorph otherwise the transferMorph has not yet its bounds"
			aTransferMorph align: aTransferMorph draggedMorph center with: anEvent position.
			aTransferMorph
				dragTransferType: (self model dragTransferTypeForMorph: self).
			anEvent hand grabMorph: aTransferMorph].
	anEvent hand releaseMouseFocus: self! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
autoDeselection: trueOrFalse
	"Enable/disable autoDeselect (see class comment)"
	self listManager autoDeselection: trueOrFalse! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
treeLineWidth: anInteger
	treeLineWidth := anInteger! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
mouseUp: event 
	"Fixed up highlight problems."
	| nodeMorph wasHigh |
	
	self enabled ifFalse: [ ^self ].
	mouseOverAllowed := false.
	nodeMorph := self scrollerSubMorphFromPoint: event position.

	wasHigh := nodeMorph notNil 
		ifTrue: [nodeMorph highlightedForMouseDown] 
		ifFalse: [false].
		
	self allNodeMorphs 
		do: [:m | 
				m highlightedForMouseDown 
					ifTrue: [m highlightForMouseDown: false]].
	wasHigh 
		ifFalse: [
			nodeMorph 
				ifNotNil: [^self]].

	self listManager mouseUp: event on: nodeMorph.! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
columnColorForOdd: oddColor 
	columnColors at: 1 put: nil.
	columnColors at: 2 put: oddColor.! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
doubleClick: anEvent 
	| targetMorph |
	targetMorph := self scrollerSubMorphFromPoint: anEvent position.
	(self listManager doubleClick:  anEvent on: targetMorph)
		ifFalse: [super doubleClick: anEvent]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
treeLineDashes: anArrayOfInteger
	treeLineDashes := anArrayOfInteger! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
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: ''!
expandedForm
	"Answer the form to use for expanded items."
	
	^self theme treeExpandedForm! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
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: 'accessing' stamp: ''!
treeLineDashes
	^ treeLineDashes 
		ifNil: [treeLineDashes := self theme treeLineDashes]! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
lineColorBlock: aValuable
	lineColorBlock := aValuable! !

!MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: ''!
potentialDropMorph: aMorph
	"Set the morph (the MorphTreeNodeMorph) 
	which is the current drop target candidate "
	potentialDropMorph := aMorph.
	aMorph highlightForDrop! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
topHeaderBackground
	^ topHeaderBackground ifNil: [topHeaderBackground := Color transparent]! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
updateTopHeader
	self topHeader ifNotNil: [:th | | w |
		th width: scroller width.
		w := self headerBounds.
		th submorphsDo: [:sm | w ifNotEmpty: [sm bounds: w removeFirst; layoutInset: self columnInset @ 0]]].! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
topHeaderBackground: aFillStyle
	topHeaderBackground := aFillStyle! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
collapseAll
	self updateContentsWithPreviouslyExpanded: Array new.! !

!MorphTreeMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas

	self drawOnCanvasWrapperFor: anAthensCanvas! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
commandOrCrontrolKeyPressed: anEvent
	^ (Smalltalk os isMacOS) 
		ifTrue: [anEvent controlKeyPressed]
		ifFalse: [anEvent commandKeyPressed]! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
notExpandedFormForMorph: aMorph
	^ (aMorph selected and: [self selectionColor luminance < 0.7])
		ifTrue: [self theme whiteTreeUnexpandedForm]
		ifFalse: [self theme treeUnexpandedForm]! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
selectionColor
	"Answer the colour to use for selected items."

	^ self 
		valueOfProperty: #selectionColor 
		ifAbsent: [ self theme selectionColor ]! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
gapAfterToggle
	"horizontal space after the toggle"
	^ gapAfterToggle ifNil: [gapAfterToggle := 5]! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandedFormForMorph: aMorph
	"Answer the form to use for expanded items."
	
	^ (aMorph selected and: [self selectionColor luminance < 0.7])
		ifTrue: [self theme whiteTreeExpandedForm]
		ifFalse: [self theme treeExpandedForm]! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
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: 'announce requests' stamp: ''!
nodeExpandRequest: anAnnounce
	anAnnounce nodes
		ifEmpty: [self expandAll]
		ifNotEmpty: [:nodes | anAnnounce recur 
			ifTrue: [self expandAllFromNode: nodes last]
			ifFalse: [self expandNodePath: nodes]]! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
treeLineWidth
	^ treeLineWidth ifNil: [treeLineWidth := self  theme treeLineWidth]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
model: aTreeModel
	self model ifNotNil: [self model announcer unsubscribe: self].
	super model: aTreeModel.
	self registerRequestHandlers! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
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: 'column handling' stamp: ''!
makeLastColumnBounded
	"Make the last column horizontally resizable with a resizer"
	self lastColumnBounded 
		ifFalse: [
			unboundLastColumn := false.
			self columnsChanged]! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^ self enabled! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
firstChild
	"returns the first scroller submorph if not empty, or nil if empty"
	^ self firstNodeMorph! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandItemPath: aNodePath
	(self allNodeMorphs at: 1 ifAbsent: [^self]) 
		openItemPath: aNodePath! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
preferedPaneColor: aColor
	self color: (preferedPaneColor := aColor).! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
firstNodeMorph
	"returns the first scroller submorph if not empty, or nil if empty"
	^ self allNodeMorphs ifEmpty: [nil] ifNotEmpty: [scroller submorphs at: 1]! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
updateContentsWithPreviouslyExpanded: aNodeList
	"Make sure we notice the removal of the contained nodes."

	nodeList := nil.
	self noteRemovalOfAll: self allNodeMorphs.	"<-- Changed"
	(self nodeList isNil or: [ self nodeList isEmpty ])
		ifTrue: [ 
			nodeList := nil.
			^ self emptySelection ].
	self addSubmorphsFromNodeList: self currentNodelist previouslyExpanded: aNodeList.
	self listManager updateLastClickedMorph! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandAllSilently: aMorph
	aMorph isExpanded ifFalse: [aMorph expand].
	aMorph childrenDo: [:ch | self expandAllSilently: ch].! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
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 | 
			(ptY between: item top and: item bottom)
				ifTrue: [ 0 ]
				ifFalse: [ 
					(item top + item bottom) // 2 > ptY
						ifTrue: [ -1 ]
						ifFalse: [ 1 ] ]	"found" ]! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
removeTopHeader
	topHeader 
		ifNotNil: [self removeMorph: topHeader.
		topHeader := nil]! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
innerBounds
	| inner |
	inner := super innerBounds.
	inner := inner withTop: self top + self topHeaderHeight.
	^ inner! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
lastColumnBounded
	"Return true if the last column can be resized with a resizer"
	^ self lastColumnUnbounded not! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
withHLines: aBoolean
	withHLines := aBoolean! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
yellowButtonEvent: anEvent

	(self scrollerSubMorphFromPoint: anEvent position) 
		ifNotNil: [:sel |
			sel selected
				ifFalse: [self listManager setSelectedMorph: sel].
			^ self yellowButtonActivity: anEvent shiftPressed ].
	^ self yellowButtonActivity: anEvent shiftPressed! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandNodePath: aNodePath
	(self allNodeMorphs at: 1 ifAbsent: [^self]) 
		openNodePath: aNodePath! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
deselectAll
	self listManager deselectAll! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
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: 'column handling' stamp: ''!
removeColumnResizers
	"Remove all column resizers"
	self removeAllMorphsIn: self columnResizers.
	self columnResizers do: [:r | r release].
	self columnResizers removeAll! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
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: 'scrolling' stamp: ''!
newTransformMorph
	^ MorphTreeTransformMorph new! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
enabled
	^ enabled ifNil: [ enabled := super enabled ]! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
mouseStillDownStepRate
	"At what rate do I want to receive #mouseStillDown: notifications?"
	^10! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
columnColorForEven: evenColor odd: oddColor
	columnColors at: 2 put: oddColor.
	columnColors at: 1 put: evenColor.! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
adjustSubmorphPositions
	maxNodeWidth := 0.
	^ self adjustSubmorphPositionsOf: self allNodeMorphs startIdx: 1 startPos: 0@0! !

!MorphTreeMorph methodsFor: 'submorphs - add/remove' stamp: ''!
addMorphsTo: morphList from: aCollection withExpandedItems: expandedItems atLevel: newIndent 
	"Sent when building the list (by #buildContents), takes
	into accound old expanded items: they remain 
	expanded such that a list update don't change the list
	visual state"
	| priorMorph firstAddition |
	priorMorph := nil.
	firstAddition := nil.
	"also for the system progress bar"
	aCollection
		doWithIndex: [:item :idx | 
			priorMorph := self indentingItemClass new
						initWithContents: item
						prior: priorMorph
						forList: self
						indentLevel: newIndent.
			firstAddition
				ifNil: [firstAddition := priorMorph].
			morphList add: priorMorph.
			"Was this row expanded ? if true -> expand it
			again " 
			((item hasEquivalentIn: expandedItems)
					or: [priorMorph isExpanded])
				ifTrue: [priorMorph isExpanded: true.
					priorMorph
						addChildrenForList: self
						addingTo: morphList
						withExpandedItems: expandedItems]].
	^ firstAddition! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
mouseDownHighlightColor
	"Answer a good color to use for drawing the mouse down highlight.
	Used the line color if not transparent, otherwise a contrasting color in the
	same way as the line color is determined.
	Fall back to black if all my owners are transparent."

	|colored |
	colored := self color isTransparent
		ifTrue: [self firstOwnerSuchThat: [:o | o isWorldOrHandMorph not and: [o color isTransparent not]]]
		ifFalse: [self].
	colored ifNil: [^Color black].
	^colored color luminance > 0.5
		ifTrue: [Color black]
		ifFalse: [Color white]! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
lastColumnUnbounded
	"Return true if the last column can not be resized with a resizer"
	^ unboundLastColumn ifNil: [unboundLastColumn := true]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
hasToggleAtRoot
	^ hasToggleAtRoot ifNil: [hasToggleAtRoot := self roots anySatisfy: [:s | s hasToggle]]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
listManager
	^ listManager ifNil: [listManager := MorphTreeListManager new client: self]! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
makeLastColumnUnbounded
	"Make the last column not horizontally  resizable (no resizer for it)"
	unboundLastColumn := true! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
nodeList
	^ nodeList ifNil: [nodeList := self getList]! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
beMultiple	
	self listManager multipleSelection: true! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
hasIconBlock
	^ iconBlock notNil! !

!MorphTreeMorph methodsFor: 'announce requests' stamp: ''!
changeSelectionRequest: anAnnounce
	self updateSelectionFromModel! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
privateUpdateColumnMorphs
	self resetRootInfo.
	self updateTopHeader.
	self innerWidgetChanged.! !

!MorphTreeMorph methodsFor: 'announce requests' stamp: ''!
registerRequestHandlers
	self model announcer when: MorphTreeChangeRequest send: #changeRequest: to: self.! !

!MorphTreeMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt
	^ self mouseOverAllowed! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
getList 
	"Answer the full list to be displayed."
	^ model rootNodes.! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
notExpandedToggleImage
	^ notExpandedToggleImage ifNil: [notExpandedToggleImage := ImageMorph new form: self notExpandedForm].! !

!MorphTreeMorph methodsFor: 'announce requests' stamp: ''!
nodeCollapseRequest: anAnnounce
	anAnnounce nodes
		ifEmpty: [self collapseAll]
		ifNotEmpty: [:nodes | self collapseNodePath: nodes]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
disable
	self enabled: false! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
doubleClickSelector: aSelector
	"set a  double click action"
	self listManager doubleClickSelector: aSelector! !

!MorphTreeMorph methodsFor: 'announce requests' stamp: ''!
changeListRequest: anAnnounce
	self updateList! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
nodeList: aCollection 
	nodeList := aCollection.! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
preferedPaneColor
	^ preferedPaneColor! !

!MorphTreeMorph methodsFor: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher

	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #MorphFocusNavigation! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
currentlyExpanded

	^ self expandedNodesFrom: (self allNodeMorphs).! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
withTreeLines
	^ self  treeLineWidth > 0! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
collapseNodePath: aPath
	self allNodeMorphs first collapseNodePath: aPath! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
columnDropUnabled
	"return true if column drop is enabled - see also #allowColumnDrop"
	^ columnDropUnabled ifNil: [columnDropUnabled := false]! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
resizerWidth
	^ resizerWidth ifNil:[resizerWidth := 3]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
topHeader
	^ topHeader! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
columnColorForEven: evenColor 
	columnColors at: 2 put: nil.
	columnColors at: 1 put: evenColor.! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
toggleImageWidth
	^ self expandedToggleImage width max: self notExpandedToggleImage width.! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
minResizerOffset
	^ 20! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
columnInset: anInteger
	"Change the horizontal space between a resizer and a row morph"
	columnInset := anInteger.! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
insertNewMorphs: morphList
	scroller addAllMorphs: morphList.! !

!MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: ''!
potentialDropMorph
	"return the morph (the MorphTreeNodeMorph) 
	which is the current drop target candidate "
	^potentialDropMorph! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
updateColumnMorphsWidth
	| rowMorphsWidths |
	self columns size > 1 ifFalse: [^ self].
	rowMorphsWidths := self rowMorphsWidths.
	self allNodeMorphs do: [:i | i updateColumnMorphsWidthWith: rowMorphsWidths].! !

!MorphTreeMorph methodsFor: 'drawing' stamp: ''!
drawLinesOn: aCanvas
	"Draw the lines for the submorphs.
	Modified for performance."
	self hasToggleAtRoot ifFalse: [^ self].
	aCanvas 
		transformBy: scroller transform
		clippingTo: scroller innerBounds
		during: [:clippedCanvas |
			scroller submorphsDo: [ :submorph | | last |
				((submorph isExpanded and: [
					(submorph nextSibling notNil and: [
						clippedCanvas isVisible: (submorph fullBounds topLeft
							corner: submorph nextSibling fullBounds bottomRight)]) or: [
					submorph nextSibling isNil and: [(last := submorph lastChild) notNil and: [
						clippedCanvas isVisible: (submorph fullBounds topLeft
							corner: last fullBounds bottomRight)]]]]) or: [
				(clippedCanvas isVisible: submorph fullBounds) or: [
				(submorph nextSibling notNil and: [
						clippedCanvas isVisible: submorph nextSibling fullBounds])]]) ifTrue:[
					submorph drawLinesOn: clippedCanvas]]]
		smoothing: scroller smoothing! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
themeChanged
	
	rowColors at: 1 put: (	
		rowColors asSet size = 1 
			ifTrue: [  self theme backgroundColor ]
			ifFalse: [ rowColors at: 1 put: self theme backgroundColor contrastingColorAdjustment ]
		).
		
	rowColors at: 2 put: self theme backgroundColor .
	
	super themeChanged.! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
columnResizersToFront
	"Column resizers should always be at top"
	self columnResizers do: [:cl | cl comeToFront; fillStyle: cl normalFillStyle].! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
maxNodeWidth
	^ maxNodeWidth ifNil: [maxNodeWidth := 0]! !

!MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: ''!
forbidColumnDrop
	"Do not allow column drag and drop"
	columnDropUnabled := false! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
columnInset
	"Horizontal space between a resizer and a row morph"
	^ columnInset ifNil: [columnInset := 0]! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
columnColors 
	^ columnColors! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
resizerWidth: anInteger
	resizerWidth := anInteger.! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
iconBlock
	^ iconBlock ifNil: [[:node | node icon]]! !

!MorphTreeMorph methodsFor: 'announce requests' stamp: ''!
selectItems: aNodeItemCollection
	self selectedItems: aNodeItemCollection! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
selectionColor: aColor
	"Set the colour for selected items."

	| window |
	aColor
		ifNil: [ self removeProperty: #selectionColor ]
		ifNotNil: [ self setProperty: #selectionColor toValue: aColor ].

	window := self ownerThatIsA: SystemWindow.

	self selectionColorToUse: ((self theme fadedBackgroundWindows not or: [ window isNil or: [ window isActive ] ])
		ifTrue: [ aColor ]
		ifFalse: [ self theme unfocusedSelectionColor ])! !

!MorphTreeMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"
	super initialize.
	columnColors := Array 
		with: Color transparent 
		with: Color transparent.
	rowColors := Array 
		with: self theme backgroundColor 
		with: self theme backgroundColor.
	self borderWidth: 0.! !

!MorphTreeMorph methodsFor: 'event handling' stamp: ''!
mouseOverAllowed
	^ mouseOverAllowed ifNil: [mouseOverAllowed := false]! !

!MorphTreeMorph methodsFor: 'event handling' stamp: ''!
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: 'selection' stamp: ''!
isSingle	
	^ self isMultiple not! !

!MorphTreeMorph methodsFor: 'scrolling' stamp: ''!
scrollDeltaWidth
	"A guess -- assume that the width of a char is approx 1/2 the height of the font"
	^ self scrollDeltaHeight // 2! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
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: 'announce requests' stamp: ''!
selectItemsRequest: anAnnounce
	self selectedItems: anAnnounce itemsToSelect! !

!MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: ''!
resetPotentialDropMorph
	"release the current drop morph candidate"
	potentialDropMorph ifNotNil: [
		potentialDropMorph resetHighlightForDrop.
		potentialDropMorph := nil]! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
rowInset
	^ rowInset  ifNil: [rowInset := 0]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
currentNodelist
	"The nodeList currently viewed "
	^ self nodeList! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
autoMultiSelection
	^ self listManager autoMultiSelection! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
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: 'updating' stamp: ''!
updateColumnResizersXOffset
	self columnResizerFrames with: self columnResizers do: [:frm :resizer | resizer bounds: (frm withBottom: scroller bottom)].! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
indentGap
	^ indentGap ifNil: [indentGap := 20]! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
enabledFromModel
	| val |
	self model ifNil: [ ^ self ].
	val := self model enabled.
	val ~= self enabled
		ifTrue: [ self enabled: val ]! !

!MorphTreeMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	super drawOn: aCanvas.
	self columns do: [:col | col drawColumnOn: aCanvas].! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
keyDownActionSelector: aSelector

	self listManager keyDownActionSelector: aSelector! !

!MorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
rowColors
	^ rowColors! !

!MorphTreeMorph methodsFor: 'scrolling' stamp: ''!
scrollSelectionIntoView
	"make sure that the current selection is visible"
	self listManager selectedMorph
		ifNotNil: [:morph | self scrollToShow: morph contentBounds ]! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
selectionColorToUse
	"Answer the colour to use for selected items."
	self enabled ifFalse: [ ^ self paneColor ].
	^ self valueOfProperty: #selectionColorToUse 
		ifAbsent: [ self theme selectionColor ].! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
update: aSymbol
	aSymbol = self nodeListSelector
		ifTrue: [ ^ self updateList ].
	super update: aSymbol! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
nodeMorphOfNode: aNode
	^ self allNodeMorphs detect: [:m | m complexContents  = aNode] ifNone: []! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
removeColumn: aTreeColumn
	"Remove a column - rough implementation"
	self removeColumnAtIndex: (self columns indexOf: aTreeColumn)! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
allNodeMorphs
	"all list morphs"
	^ scroller submorphs! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
columnResizers
	"return the resizers which make it possible 
	to resize columns horizontally with the mouse"
	^ columnResizers ifNil: [ columnResizers := OrderedCollection new ]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
rootsFrom: aCollectionOfNodes
	"Answer the receiver's roots"
	^ aCollectionOfNodes
		select: [:each | each indentLevel isZero]! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
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: 'events-processing' stamp: ''!
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: 'accessing' stamp: ''!
withHLines
	^ withHLines ifNil: [withHLines := false]! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	enabled := aBoolean.
	self
		submorphsDo: [ :sm | 
			sm
				allMorphsDo: [ :m | 
					(m respondsTo: #enabled:)
						ifTrue: [ m enabled: aBoolean ] ] ].
	self changed: #enabled.
	self changed! !

!MorphTreeMorph methodsFor: 'updating' stamp: ''!
noteRemovalOfAll: aCollection
	"TODO: update the selection as well"

	 self listManager noteRemovalOfAll: aCollection.
	aCollection do: [ :each | each delete ].
	scroller removeAllMorphsIn: aCollection.
	self adjustSubmorphPositions! !

!MorphTreeMorph methodsFor: 'submorphs - add/remove' stamp: ''!
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: 'geometry' stamp: ''!
extent: newExtent
	super extent: newExtent.
	self resizerChanged.! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
selectedItems: aNodeItemCollection
	self listManager selectedItems: aNodeItemCollection! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
swapColumn: aColumn withColumn: anotherColumn
	"column swapping - this is the default behavior for column drag & drop"
	self swapColumnAt:  aColumn index withColumnAt: anotherColumn index! !

!MorphTreeMorph methodsFor: 'selection' stamp: ''!
selectionFrameFor: aNodeMorph
	"Answer the frame of aNodeMorph in the receiver"
	^ aNodeMorph bounds:  aNodeMorph selectionFrame in: self! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandAllSuchThat: aBlock
	self roots do: [:m | self expand: m suchThat: aBlock].
	self innerWidgetChanged! !

!MorphTreeMorph methodsFor: 'geometry' stamp: ''!
rowInset: anInteger
	rowInset := anInteger.! !

!MorphTreeMorph methodsFor: 'accessing' stamp: ''!
topHeaderHeight
	^ self topHeader
		ifNil: [ 0 ]
		ifNotNil: [ :th | 
			| h |
			h := th borderWidth * 2.
			self columns do: [ :col | h := h max: col height ].
			h ]! !

!MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandSilently: aMorph suchThat: aBlock
	(aBlock value: aMorph complexContents)
		ifTrue: [
			aMorph isExpanded ifFalse: [aMorph expand].
			aMorph childrenDo: [:ch | self expandSilently: ch suchThat: aBlock]].! !

!MorphTreeMorph methodsFor: 'enumeration' stamp: ''!
childrenDo: aBlock
	self roots do: aBlock! !

!MorphTreeMorph methodsFor: 'column handling' stamp: ''!
headerBounds
	"return the bounds of each top header button (one per column)"

	| positions controlBounds currPos currLeft |
	controlBounds := OrderedCollection new.
	currPos := scroller left.
	(positions := self columnResizers asOrderedCollection collect: [ :r | r position ])
		ifNotEmpty: [ 
			| currRight |
			currPos := positions removeFirst x.
			currLeft := scroller left - scroller offset x.
			currRight := currPos.
			controlBounds add: (currLeft @ topHeader top corner: currRight @ topHeader bottom).
			[ positions notEmpty ]
				whileTrue: [ 
					currLeft := currPos + self resizerWidth.
					currPos := positions removeFirst x.
					currRight := currPos.
					controlBounds add: (currLeft @ topHeader top corner: currRight @ topHeader bottom) ] ].
	self columnResizers size < self columns size
		ifTrue: [ 
			currLeft := currPos + self resizerWidth.
			controlBounds add: ((currLeft min: scroller right) @ topHeader top corner: scroller right @ topHeader bottom) ].
	^ controlBounds! !

!MorphTreeMorph methodsFor: 'initialize - release' stamp: ''!
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].
	self releaseActionMap. "we are not sure if we need it"
	super release.! !

!MorphTreeMorph methodsFor: 'events-processing' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
on: anObject
	^ self new model: anObject! !

!MorphTreeMorphMultipleSelection commentStamp: ''!
Multiple selections in a morphic based tree!
!MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: ''!
selectedNodePathList
	^ selectedNodePathList ifNil: [selectedNodePathList := OrderedCollection new]! !

!MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: ''!
removeNode: aNode
	self selectedNodePathList remove: aNode path ifAbsent: []! !

!MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: ''!
selectedNodePathList: aCollectionOfPath
	selectedNodePathList := aCollectionOfPath! !

!MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: ''!
addNodePath: aPath
	self selectedNodePathList add: aPath! !

!MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: ''!
empty
	self selectedNodePathList: OrderedCollection new! !

!MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: ''!
selectedItemOrItemsOrNil
	| theItems |
	theItems := self selectedNodeList collect: [ :each | each item ].
	^ theItems isEmpty ifTrue: [nil] ifFalse: [ theItems ]! !

!MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: ''!
lastSelectedNodePath
	^ self selectedNodePathList ifNotEmpty: [:l | l last]! !

!MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: ''!
selectedNodeList
	^ self selectedNodePathList 
		ifNil: [#()]
		ifNotNil: [:l | l collect: [:path | path last]]! !

!MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: ''!
selectedNodes
	^ OrderedCollection withAll: self selectedNodeList! !

!MorphTreeMorphSelection commentStamp: ''!
Superclass for selections in a morphic based tree!
!MorphTreeMorphSelection methodsFor: 'accessing' stamp: ''!
selectedNodePathList
	^ self subclassResponsibility! !

!MorphTreeMorphSelection methodsFor: 'accessing' stamp: ''!
removeNode: aNode
	self subclassResponsibility! !

!MorphTreeMorphSelection methodsFor: 'accessing' stamp: ''!
addNodePath: aPath
	^ self subclassResponsibility! !

!MorphTreeMorphSelection methodsFor: 'accessing' stamp: ''!
empty
	self subclassResponsibility! !

!MorphTreeMorphSelection methodsFor: 'accessing' stamp: ''!
selectedItemOrItemsOrNil
	^ self lastSelectedNode ifNotNil: [ self lastSelectedNode item ]! !

!MorphTreeMorphSelection methodsFor: 'accessing' stamp: ''!
lastSelectedNode
	^ self lastSelectedNodePath ifNotNil: [:path | path ifEmpty: [nil] ifNotEmpty: [:p | path last]]! !

!MorphTreeMorphSelection methodsFor: 'accessing' stamp: ''!
lastSelectedNodePath 
	^ self subclassResponsibility! !

!MorphTreeMorphSelection methodsFor: 'accessing' stamp: ''!
selectedItems
	^ self selectedNodes collect: [:n | n item]! !

!MorphTreeMorphSelection methodsFor: 'accessing' stamp: ''!
addNode: aNode
	self addNodePath: aNode path! !

!MorphTreeMorphSelection methodsFor: 'view updating' stamp: ''!
updateView: aTreeMorph forModel: aTreeModel
	aTreeMorph updateFromSelection: self.
	aTreeModel selectionChanged! !

!MorphTreeMorphSelection methodsFor: 'accessing' stamp: ''!
selectedNodes
	^ self lastSelectedNode
		ifNotNil: [:l | OrderedCollection with: l]
		ifNil: [OrderedCollection new]! !

!MorphTreeMorphSingleSelection commentStamp: ''!
Single selections in a morphic based tree!
!MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: ''!
selectedNodePathList
	^ self selectedNodePath ifNil: [#()] ifNotNil: [Array with: self selectedNodePath]! !

!MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: ''!
selectedNodePath
	^ selectedNodePath! !

!MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: ''!
removeNode: aNode
	self selectedNodePath = aNode path
		ifTrue: [self selectedNodePath: nil]! !

!MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: ''!
addNodePath: aPath
	self selectedNodePath: aPath! !

!MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: ''!
empty
	self selectedNodePath: nil! !

!MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: ''!
selectedNodePath: aSelectionPath
	selectedNodePath := aSelectionPath! !

!MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: ''!
lastSelectedNodePath
	^ self selectedNodePath! !

!MorphTreeMorphTest commentStamp: ''!
A MorphTreeMorphTests tests aspects of a MorphTreeMorph
!
!MorphTreeMorphTest methodsFor: 'tests' stamp: ''!
testLastClickedMorphSetUponUpdateList
	"Test that lastClickedMorph isn't set to nil after an update list."

	| c w t |
	c := ClassTreeExample new.
	[ 
	w := c openOn: Collection.
	t := c dependents last.
	t expandAll.
	c
		selectItems:
			{CharacterSet}.
	self assert: t listManager lastClickedMorph notNil.
	c rootClass: Bag.	"We change completely the list. CharacterSet is not anymore in the list after the update."
	c updateList.
	self assert: t listManager lastClickedMorph isNil.
	c selectItems: { Bag }.
	self assert: t listManager lastClickedMorph notNil ]
		ensure: [ w close ]! !

!MorphTreeMorphTest methodsFor: 'tests' stamp: ''!
testUpdatingSelectionsOnUpdate
	"Test that the selection does not refer to non-existing nodes after updates."

	| c w t |
	c := ClassTreeExample new.
	[ 
	w := c openOn: Collection.
	t := c dependents last.
	t expandAll.
	c
		selectItems:
			{Bag.
			CharacterSet}.
	c selection selectedNodes do: [ :e | self assert: (t selectedMorphList anySatisfy: [ :sm | sm complexContents = e ]) ].
	c rootClass: Bag.
	c updateList.
	c selection selectedNodes do: [ :e | self assert: (t selectedMorphList anySatisfy: [ :sm | sm complexContents = e ]) ] ]
		ensure: [ w close ]! !

!MorphTreeMorphTest methodsFor: 'tests' stamp: ''!
testMaintainingSelectionsOnUpdate
	"Test that the selection is well maintained on list update."

	| c w t |
	c := ClassTreeExample new.
	[ 
	w := c openOn: Collection.
	t := c dependents last.
	t expandAll.
	c
		selectItems:
			{Bag.
			CharacterSet}.
	t selectedMorphList
		do: [ :e | 
			self
				assert:
					({Bag.
					CharacterSet} includes: e complexContents withoutListWrapper) ].
	c updateList.
	t selectedMorphList
		do: [ :e | 
			self
				assert:
					({Bag.
					CharacterSet} includes: e complexContents withoutListWrapper) ] ]
		ensure: [ w close ]! !

!MorphTreeMorphTest methodsFor: 'tests' stamp: ''!
testLeakingSelectionsOnUpdate
	"Test that selected morphs are forgotten on update."

	| c w t |
	c := ClassTreeExample new.
	[ 
	w := c openOn: Collection.
	t := c dependents last.
	t expandAll.
	t selectAll.
	c updateList.
	t listManager selectedMorphList do: [ :each | self assert: (t allNodeMorphs includes: each) ] ]
		ensure: [ w close ]! !

!MorphTreeMorphTest methodsFor: 'tests' stamp: ''!
testUpdatingSelectionsOnUpdateWithRemoval
	"Test that the selection does not refer to non-existing nodes after updates, including if the update removes nodes."

	| c w t |
	c := ClassTreeExample new.
	[ w := c openOn: Collection.
	t := c dependents last.
	t expandAll.
	c selectItems: {Bag . CharacterSet}.
	c selection selectedNodes do: [ :e | self assert: (t selectedMorphList anySatisfy: [ :sm | sm complexContents = e ]) ].
	c rootClass: Bag.	"We change completely the list. CharacterSet is not anymore in the list after the update."
	c updateList.
	self assert: t selectedMorphList size equals: 1.	"We have only Bag selected now."
	self assert: t selectedMorphList first complexContents withoutListWrapper identicalTo: Bag.
	c selection selectedNodes do: [ :e | self assert: (t selectedMorphList anySatisfy: [ :sm | sm complexContents = e ]) ] ]
		ensure: [ w close ]! !

!MorphTreeNavigationBar commentStamp: ''!
I'm a pager control used to navigate in a MorphTreeMorph that has a lot of entries.

You can see one of my subclass in action using:
"May take a while to open"
ClassListExample new open!
!MorphTreeNavigationBar class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!MorphTreeNodeModel commentStamp: ''!
I wrap an item to be displayed in a TreeMorph, so I can answer content and representation in a polymorphic way. 

My hierarchy usually follows TreeMorphModel one.!
!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
childNodeClassFromItem: anItem
	^ self class! !

!MorphTreeNodeModel methodsFor: 'testing' stamp: ''!
hasContentToShow

	^ false! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
level
	^ parentNode ifNil: [1] ifNotNil: [parentNode level + 1]! !

!MorphTreeNodeModel methodsFor: 'protocol' stamp: ''!
isExpanded

	^ false! !

!MorphTreeNodeModel methodsFor: 'protocol' stamp: ''!
selected

	^ false! !

!MorphTreeNodeModel methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: 'Node('.
	self item printOn: aStream.
	aStream nextPut: $)! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
helpText
	^ model helpText! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
parentNode: aNode
	parentNode := aNode! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
contents
	^ self childrenItems collect: [:ci | self childNodeFromItem: ci ]! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
pathIn: aCollection 
	self parentNode
		ifNotNil: [(aCollection includes: self parentNode)
		ifFalse: [self parentNode pathIn: aCollection]].
	aCollection add: self.
	^ aCollection! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
path
	^ self pathIn: OrderedCollection new.! !

!MorphTreeNodeModel methodsFor: 'protocol' stamp: ''!
isExpanded: aBoolean! !

!MorphTreeNodeModel methodsFor: 'protocol' stamp: ''!
selected: aBoolean
	"Do nothing but introduce a hook"! !

!MorphTreeNodeModel methodsFor: 'testing' stamp: ''!
isPartialMatch
	| result |

	result := false.
	
	self contents do: [:each | 
		(each selected or: [ each isPartialMatch ]) ifTrue: [ result := true ] ].

	^ result! !

!MorphTreeNodeModel methodsFor: 'protocol' stamp: ''!
lastClicked: aBoolean
	"Do nothing but introduce a hook"! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
rowMorphForColumn: aTreeColumn
	^ self item ifNotNil: [:i | self asString asMorph]! !

!MorphTreeNodeModel methodsFor: 'dependents' stamp: ''!
addDependent: aDependent
	"Ensure to only have one dependent at every moment"
	
	dependents := #().
	super addDependent: aDependent! !

!MorphTreeNodeModel methodsFor: 'events' stamp: ''!
mouseDown: event
	"Do not do anything"! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
enabled
	^ true! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
childrenItems
	^ Array new! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
includesSubstringAnywhere: aString
	^ (Array with: self asString) includesSubstringAnywhere: aString! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
name
	^ self item name! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
parentNode
	^ parentNode! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
color
	^ nil! !

!MorphTreeNodeModel methodsFor: 'accessing' stamp: ''!
childNodeFromItem: anItem
	^ ((self childNodeClassFromItem: anItem) with: anItem model: model) parentNode: self; yourself! !

!MorphTreeNodeMorph commentStamp: ''!
I draw the node part of a tree.!
!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
columnMorphAt: anIndex
	^ controls at: anIndex! !

!MorphTreeNodeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandItemPath: anArray
	"Open a path."
	
	| found |
	anArray isEmpty
		ifTrue: [^ container listManager setSelectedMorph: nil].
	found := nil.
	self
		withSiblingsDo: [:each | found
				ifNil: [(each complexContents withoutListWrapper = anArray first
							or: [anArray first isNil])
						ifTrue: [found := each]]].
	found
		ifNotNil: [found isExpanded
				ifFalse: [found toggleExpandedState].
			found changed.
			anArray size = 1
				ifTrue: [^ container listManager setSelectedMorph: found].
			^ found firstChild
				ifNil: [container setSelectedMorph: nil]
				ifNotNil: [found firstChild expandItemPath: anArray allButFirst]].
	^container setSelectedMorph: nil! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
inToggleArea: aPoint

	^self sensitiveToggleRectangle containsPoint: aPoint! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
isFirstItem
	^owner submorphs first == self! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
children
	| children |
	children := OrderedCollection new.
	self childrenDo: [:each | children add: each].
	^children! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
complexContents

	^complexContents! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
nextSibling

	^nextSibling! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
toggleImageForm
	^ isExpanded 
			ifTrue: [container expandedFormForMorph: self]
			ifFalse: [container notExpandedFormForMorph: self]! !

!MorphTreeNodeMorph methodsFor: 'announcements' stamp: ''!
announceDeleted

	complexContents ifNotNil: [ complexContents removeDependent: self ].
	
	super announceDeleted.! !

!MorphTreeNodeMorph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
model

	^ self complexContents! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
withoutListWrapper

	^complexContents withoutListWrapper! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
delete

	parent := nil.
	complexContents := nil.
	firstChild := nil.
	container := nil.
	nextSibling := nil.
	controls := nil.
	super delete.! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
selected: aBoolean
	selected = aBoolean
		ifTrue: [^ self].
	container ifNil: [^ self].
	aBoolean
		ifTrue: [container selectedMorphList add: self]
		ifFalse: [selected 
			ifNotNil: [container selectedMorphList remove: self]].
	selected := aBoolean.

	self complexContents selected: aBoolean! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
mustTakeIntoAccountCheckSpace
	^container listManager isCheckList! !

!MorphTreeNodeMorph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
isMorphicModel

	^ true! !

!MorphTreeNodeMorph methodsFor: 'layout' stamp: ''!
layoutBounds
	"Return the bounds for laying out children of the receiver"

	| lb left right |
	
	lb := super layoutBounds.
	container ifNil: [ ^ lb ].
	left := (lb left + self spacerWidth).
	right := (lb right max: left + self spacerWidth).
	"Make sure that left and right have changed simultaneously, avoiding creating degenerate rectangle"
	^ Rectangle left: left right: right top: lb top bottom: lb bottom! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
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: [ self theme textColor ])]].! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
rowMorphAt: anIndex
	^ self submorphs seconds submorphs at: anIndex! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
adoptPaneColor: aColor! !

!MorphTreeNodeMorph methodsFor: 'private' stamp: ''!
computeCheckTopLeft
	| center offset |
	
	center := self checkRectangle center.
	offset := (self checkWidth / 2.0) truncated.
	^ (center x - offset) @ (center y - offset - 1)! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
toggleRectangle
	^(bounds left + self indentGap) @ bounds top extent: (container toggleImageWidth) @ bounds height! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
color
	^ complexContents color ifNil: [self index ifNotNil: [container rowColors at: ((self index \\ 2) + 1)]]! !

!MorphTreeNodeMorph methodsFor: 'initialization' stamp: ''!
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: 'updating' stamp: ''!
toggleExpandedState
	| toDelete |
	self isExpanded: self isExpanded not.
	toDelete := OrderedCollection new.
	firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: toDelete ] ].
	container noteRemovalOfAll: toDelete.
	(isExpanded and: [ complexContents hasContents ])
		ifFalse: [ ^ self changed ].
	self expand! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
openPath: anArray 
	| found |
	anArray isEmpty
		ifTrue: [^ container listManager setSelectedMorph: nil].
	found := nil.
	self
		withSiblingsDo: [:each | found
				ifNil: [(each complexContents asString = anArray first
							or: [anArray first isNil])
						ifTrue: [found := each]]].
	found
		ifNil: ["try again with no case sensitivity"
			self
				withSiblingsDo: [:each | found
						ifNil: [(each complexContents asString sameAs: anArray first)
								ifTrue: [found := each]]]].
	found
		ifNotNil: [found isExpanded
				ifFalse: [found toggleExpandedState.
					container adjustSubmorphPositions].
			found changed.
			anArray size = 1
				ifTrue: [^ container setSelectedMorph: found].
			^ found firstChild
				ifNil: [container setSelectedMorph: nil]
				ifNotNil: [found firstChild openPath: anArray allButFirst]].
	^ container setSelectedMorph: nil! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
controls
	^ controls! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
matchPath: anAssociation

	anAssociation ifNil: [ ^ nil ].
	^ anAssociation treeNodeHead = self complexContents withoutListWrapper
		ifFalse: [ nil ]
		ifTrue: [ | matchingChildren |
			anAssociation treeNodeTail ifNil: [ ^ { self } ].
			matchingChildren := self children collect: [:child | child matchPath: anAssociation treeNodeTail ].
			^ matchingChildren select: [ :e | e notNil ] ]! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
highlightForMouseDown: aBoolean
	aBoolean 
		ifTrue: [self setProperty: #highlightedForMouseDown toValue: aBoolean]
		ifFalse: [self removeProperty: #highlightedForMouseDown].
	self changed! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
nextSibling: anotherMorph

	nextSibling := anotherMorph! !

!MorphTreeNodeMorph methodsFor: 'drawing' stamp: ''!
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: 'expanding-collapsing' stamp: ''!
openNodePath: anArray 
	| found |
	anArray isEmpty
		ifTrue: [^ container listManager setSelectedMorph: nil].
	found := nil.
	self
		withSiblingsDo: [:each | found
				ifNil: [(each complexContents = anArray first
							or: [anArray first isNil])
						ifTrue: [found := each]]].
	found
		ifNotNil: [found isExpanded
				ifFalse: [found toggleExpandedState.
					container adjustSubmorphPositions].
			found changed.
			anArray size = 1
				ifTrue: [^ container setSelectedMorph: found].
			^ found firstChild
				ifNil: [container setSelectedMorph: nil]
				ifNotNil: [found firstChild openNodePath: anArray allButFirst]].
	^ container setSelectedMorph: nil! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
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: 'testing' stamp: ''!
mustTakeIntoAccountToggleSpace
	^ indentLevel > 0 or: [	container hasToggleAtRoot]! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
isSoleItem
	^self isFirstItem and: [ owner submorphs size = 1 ]! !

!MorphTreeNodeMorph methodsFor: 'layout' stamp: ''!
fullBounds
	fullBounds ifNotNil: [^ fullBounds].
	^ submorphs 
		ifEmpty: [bounds]
		ifNotEmpty: [
			self doLayoutIn: self layoutBounds.
			fullBounds]! !

!MorphTreeNodeMorph methodsFor: 'initialization' stamp: ''!
initRow
	self buildRowMorph.
	self layoutChanged! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
spacerWidth
	"Such a morph composed of, left to right, some space according to the level in the tree, an expand toggle (if any), a check box (if any),  and the item morphs (icon + text often). Compute here the width of the space, including the toggle (and the check box) if there is one."

	| baseRect |
	baseRect := self mustTakeIntoAccountCheckSpace
		ifTrue: [ self checkRectangle ]
		ifFalse: [ self toggleRectangle ].
	^ (self mustTakeIntoAccountToggleSpace or: [ self mustTakeIntoAccountCheckSpace ])
		ifTrue: [ baseRect right + container gapAfterToggle - bounds left ]
		ifFalse: [ baseRect left - bounds left ]! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
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: 'accessing' stamp: ''!
isExpanded: aBoolean

	isExpanded := aBoolean.
	self complexContents isExpanded: aBoolean! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
isPartialMatch
	
	^ self complexContents isPartialMatch! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
setSelectedSilently: aBoolean
	
	selected := aBoolean.
	self complexContents selected: aBoolean! !

!MorphTreeNodeMorph methodsFor: 'private' stamp: ''!
selectedWithoutNotifyingComplexContents: aBoolean
	"Only called at creation"
	
	aBoolean ifFalse: [ ^ self ].
	
	container listManager silentlySetSelectedMorph: self.
	selected := aBoolean.! !

!MorphTreeNodeMorph methodsFor: 'mouse events' stamp: ''!
mouseDown: event
	container enabled ifFalse: [ ^self ].
	complexContents mouseDown: event! !

!MorphTreeNodeMorph methodsFor: 'initialization' stamp: ''!
initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel
	"Make sure we properly register the delete event on the model."

	container := hostList.
	self cellInset: container resizerWidth @ 0.
	
	complexContents := anObject.
	complexContents addDependent: self.

	isExpanded := complexContents isExpanded.
	nextSibling := firstChild := nil.
	priorMorph ifNotNil: [ priorMorph nextSibling: self ].
	indentLevel := newLevel.
	self setBalloonText: complexContents helpText.
	self initRow.
	complexContents selected
		ifTrue: [ self selectedWithoutNotifyingComplexContents: true ]! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
canExpand
	^complexContents 
		ifNotNil: [ complexContents hasContents ]
		ifNil: [ false ]! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
updateChildrenRecursively
	self childrenDo: [:child | 
		child parent: self. 
		child updateChildrenRecursively]! !

!MorphTreeNodeMorph methodsFor: 'expanding-collapsing' stamp: ''!
collapseNodePath: anArray
	"Close a path based on node."
	
	| found |
	anArray isEmpty
		ifTrue: [^ container setSelectedMorph: nil].
	found := nil.
	self
		withSiblingsDo: [:each | found
				ifNil: [(each complexContents = anArray first)
						ifTrue: [found := each]]].
	found
		ifNotNil: [(found isExpanded and: [anArray size = 1])
				ifTrue: [found toggleExpandedState.
					container adjustSubmorphPositions].
			found changed.
			anArray size = 1
				ifTrue: [^ container listManager setSelectedMorph: found].
			^ found firstChild
				ifNil: [container setSelectedMorph: nil]
				ifNotNil: [found firstChild collapseNodePath: anArray allButFirst]].
	^container setSelectedMorph: nil! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
selectNodePath: anArray

	"select a node from a path based on wrapper node equivalence"

	| found |

	anArray ifNil: [ ^ self ].
	anArray isEmpty
		ifTrue: [ ^ self ].
	self
		withSiblingsDo: [ :each | 
			found
				ifNil: [ ( each complexContents = anArray first or: [ anArray first isNil ] )
						ifTrue: [ found := each ]
					]
			].
	found
		ifNotNil: [ anArray size = 1
				ifTrue: [ ^ container listManager addToSelection: found ].
			found firstChild ifNotNil: [ :fc | fc selectNodePath: anArray allButFirst ]
			]! !

!MorphTreeNodeMorph methodsFor: 'drawing' stamp: ''!
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: 'change reporting' stamp: ''!
invalidRect: aRectangle! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
hasContentToShow

	^ self complexContents hasContentToShow! !

!MorphTreeNodeMorph methodsFor: 'drawing' stamp: ''!
drawLinesOn: aCanvas 
	| hasToggle |
	hasToggle := self hasToggle.
	"Draw line from toggle to text"
	self drawLineToggleToTextOn: aCanvas hasToggle: hasToggle.

	"Draw the line from my toggle to the nextSibling's toggle"
	self nextSibling ifNotNil: [ self drawLinesToNextSiblingOn: aCanvas hasToggle: hasToggle ].

	"If I have children and am expanded, draw a line to my first child"
	(self firstChild notNil and: [ self isExpanded ])
		ifTrue: [ self drawLinesToFirstChildOn: aCanvas]! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
themeChanged
 
	self allMorphsDo: [ :m | (m isKindOf: StringMorph) ifTrue: [ m color: self theme textColor ] ].
	
	super themeChanged! !

!MorphTreeNodeMorph methodsFor: 'mouse events' stamp: ''!
checkClickableZone
	| topLeft icon |
	
	topLeft := self computeCheckTopLeft.
	icon := self retrieveCheckIcon.
	
	^ topLeft corner: icon extent + topLeft! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
indentLevel

	^indentLevel! !

!MorphTreeNodeMorph methodsFor: 'drawing' stamp: ''!
drawMouseDownHighlightOn: aCanvas
	"Draw with a dotted border."
	
	self highlightedForMouseDown 
		ifTrue: [
			container ifNil: [^super drawMouseDownHighlightOn: aCanvas].
			aCanvas 
				frameRectangle: self bounds
				width: 1
				colors: {container mouseDownHighlightColor. Color transparent}
				dashes: #(1 1)]! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
sensitiveToggleRectangle
	^(bounds left + self indentGap) @ bounds top extent: (container toggleImageWidth + container gapAfterToggle) @ bounds height! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
index: anInteger
	index := anInteger! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
path
	^ parent 
		ifNil: [OrderedCollection with: self]
		ifNotNil: [(parent path) add: self; yourself]! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
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: 'drawing' stamp: ''!
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: 'accessing' stamp: ''!
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: 'updating' stamp: ''!
highlight
	self
		allMorphsDo: [:m | (m isKindOf: StringMorph)
				ifTrue: [m setProperty: #originalColor toValue: m color.
					m color: self theme selectionTextColor]].
	complexContents highlightingColor 
		ifNotNil: [:c |
			self setProperty: #originalColor toValue: color.
			self color: c]! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
hasIcon
	"Answer whether the receiver has an icon."
	^ container hasIconBlock or: [self complexContents icon notNil]! !

!MorphTreeNodeMorph methodsFor: 'initialization' stamp: ''!
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: 'drag and drop' stamp: ''!
acceptDroppingMorph: toDrop event: evt
	complexContents acceptDroppingObject: toDrop complexContents.
	toDrop delete.
	self highlightForDrop: false.! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
balloonText

	^complexContents balloonText ifNil: [super balloonText]! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
checkWidth
	^ 10! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
updateChildren
	self childrenDo: [:child | child parent: self]! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
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: 'drawing' stamp: ''!
drawCheckOn: aCanvas
	| topLeft icon |
	
	topLeft := self computeCheckTopLeft.
	icon := self retrieveCheckIcon.
	
	aCanvas
		drawImage: icon
		at: topLeft! !

!MorphTreeNodeMorph methodsFor: 'private' stamp: ''!
takeHighlight

	container listManager lastClickedMorph: self.
	container selectionChanged! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
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: ''!
withSiblingsDo: aBlock

	| node |
	node := self.
	[node isNil] 
		whileFalse: [
			aBlock value: node.
			node := node nextSibling].! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
checkGap
	^ 2! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
indentGap
	^ container indentGap * indentLevel! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
changed
	"Need to invalidate the selection frame."
	container
		ifNil: [super changed] 
		ifNotNil: [container invalidRect: self selectionFrame]! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
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: 'drawing' stamp: ''!
drawOn: aCanvas
	"Note that selection is rendered from the container transformMorph (see MorphTreeTransformMorph)" 
	
	container withHLines 
		ifTrue: [
			aCanvas 
				frameRectangle: self selectionFrame
				width: 1
				colors: {Color veryLightGray. Color transparent}
				 dashes: #(1 2)].

	self hasToggle 
		ifTrue: [self drawToggleOn: aCanvas in: self toggleRectangle]. 
		
	container listManager isCheckList
		ifTrue: [self drawCheckOn: aCanvas ].! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
update: aSymbol

	aSymbol = #select
		ifTrue: [ ^ self selected: true ].
		
	aSymbol = #deselect
		ifTrue: [ ^ self selected: false ].
		
	aSymbol = #takeHighlight
		ifTrue: [ ^ self takeHighlight ].

	super update: aSymbol! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
treeLineDashes
	^ container treeLineDashes! !

!MorphTreeNodeMorph methodsFor: 'mouse events' stamp: ''!
handleMouseUp: anEvent 
	container enabled ifFalse: [ ^ false ].
	(container commandOrCrontrolKeyPressed: anEvent) 
		ifTrue: [^ container listManager mouseUp: anEvent on: self].
	^ super handleMouseUp: anEvent! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
isExpanded

	^isExpanded! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
recursiveDelete

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete].
	].
	self delete! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
parent: aNodeMorph
	parent := aNodeMorph! !

!MorphTreeNodeMorph methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: 'NodeMorph('.
	complexContents printOn: aStream.
	aStream nextPut: $)! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
selected
	^ selected ifNil: [selected := false]! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
icon
	"answer the receiver's icon"
	
	^ container iconBlock value: self complexContents.! !

!MorphTreeNodeMorph methodsFor: 'private' stamp: ''!
retrieveCheckIcon
	^ self selected
		ifTrue: [ self iconNamed: #checkedBoxIcon ]
		ifFalse: [ self isPartialMatch
				ifTrue: [ self iconNamed: #partialCheckedBoxIcon ]
				ifFalse: [ self iconNamed: #uncheckedBoxIcon ] ]! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
lastChild
	"Answer the last child."

	|c|
	c := self firstChild ifNil: [^nil].
	[c nextSibling isNil] whileFalse: [c := c nextSibling].
	^c! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	self drawOnCanvasWrapperFor: anAthensCanvas! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
selectionFrame
	"Answer the selection frame rectangle."

	^ self bounds: self bounds in: container! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
boundsForBalloon

	"some morphs have bounds that are way too big"
	container ifNil: [^super boundsForBalloon].
	^self boundsInWorld intersect: container boundsInWorld ifNone: [ self boundsInWorld ]! !

!MorphTreeNodeMorph methodsFor: 'drawing' stamp: ''!
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: 'testing' stamp: ''!
isSelected
	"^ container selectedMorphList includes: self"
	^ self selected! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
childrenDo: aBlock

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aBlock value: aNode].
	]! !

!MorphTreeNodeMorph methodsFor: 'updating' stamp: ''!
recursiveAddTo: aCollection

	firstChild ifNotNil: [firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: aCollection]].
	aCollection add: self.! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
hasToggle
	^ self canExpand! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
contentBounds
	"return bounds of drawn content, i.e. fullBounds except the gap"
	^ self fullBounds insetOriginBy: (self indentGap)@0 cornerBy: 0@0.! !

!MorphTreeNodeMorph methodsFor: 'accessing' stamp: ''!
firstChild

	^firstChild! !

!MorphTreeNodeMorph methodsFor: 'testing' stamp: ''!
expandPath: anAssociation

	anAssociation ifNil: [ ^ false ].
	^ anAssociation treeNodeHead = self complexContents withoutListWrapper
		ifFalse: [ false ]
		ifTrue: [
			anAssociation treeNodeTail ifNil: [ ^ true ].
			(self isExpanded not and: [ self canExpand ]) ifTrue: [
				self toggleExpandedState.
				container innerWidgetChanged ].
			self children anySatisfy: [:child | child expandPath: anAssociation treeNodeTail ]]! !

!MorphTreePager commentStamp: ''!
A tree pager!
!MorphTreePager class methodsFor: 'testing' stamp: ''!
isDeprecated 	
	^ true! !

!MorphTreeResizerMorph commentStamp: ''!
A resizer morph for a morphic based tree!
!MorphTreeResizerMorph methodsFor: 'instance creation' stamp: ''!
getOldColor
	^ oldColor ifNil: [Color transparent]! !

!MorphTreeResizerMorph methodsFor: 'instance creation' stamp: ''!
normalFillStyle
	"Return the normal fillstyle for the receiver."
	^ self theme morphTreeSplitterNormalFillStyleFor: self! !

!MorphTreeResizerMorph methodsFor: 'instance creation' stamp: ''!
container: aTreeMorph index: anInteger
	container := aTreeMorph.
	index := anInteger! !

!MorphTreeResizerMorph methodsFor: 'dependents access' stamp: ''!
delete
	super delete.
	self release.! !

!MorphTreeResizerMorph methodsFor: 'event handling' stamp: ''!
doubleClick: event
	"A double click occurred.
	Resize the column to fit all content."
	| maxWidth |
	self canResizeColumn ifFalse: [^ self].
	maxWidth := container getList max: [ :node | (self column rowMorphFor: node) width ].
	self column currentWidth: maxWidth + 6.
	container resizerChanged! !

!MorphTreeResizerMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	(owner notNil and: [owner containsPoint: self position])
		ifTrue: [super drawOn: aCanvas]! !

!MorphTreeResizerMorph methodsFor: 'event handling' stamp: ''!
mouseEnter: anEvent
	self canResizeColumn ifFalse: [^ self].
	(owner notNil and: [owner bounds containsPoint: anEvent position]) 
		ifTrue: [super mouseEnter: anEvent]! !

!MorphTreeResizerMorph methodsFor: 'Polymorph-Widgets' stamp: ''!
shouldDraw
	^ true! !

!MorphTreeResizerMorph methodsFor: 'instance creation' stamp: ''!
setGrabbedColor
	"Set the color of the receiver when it is grabbed."
	
	self fillStyle: self pressedFillStyle! !

!MorphTreeResizerMorph methodsFor: 'private - testing' stamp: ''!
column
	^container columns at: index! !

!MorphTreeResizerMorph methodsFor: 'event handling' stamp: ''!
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].
	anEvent hand waitForClicksOrDrag: self event: anEvent.
	(self bounds containsPoint: anEvent cursorPoint)
		ifTrue: [oldColor := self color.
			self setGrabbedColor].
	cp := anEvent cursorPoint.
	lastMouse := {cp. cp - self position}! !

!MorphTreeResizerMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: anEvent
	self canResizeColumn ifFalse: [^ self].
	super mouseLeave: anEvent! !

!MorphTreeResizerMorph methodsFor: 'instance creation' stamp: ''!
resizeCursor
	^ Cursor resizeForEdge: #left! !

!MorphTreeResizerMorph methodsFor: 'Polymorph-Widgets' stamp: ''!
themeChanged
	"Update the fill style."
	self fillStyle: self normalFillStyle.
	super themeChanged! !

!MorphTreeResizerMorph methodsFor: 'Polymorph-Widgets' stamp: ''!
adoptPaneColor: paneColor 
	"Change our color too."
	super adoptPaneColor: paneColor.
	self fillStyle: self normalFillStyle! !

!MorphTreeResizerMorph methodsFor: 'submorphs - add/remove' stamp: ''!
release
	traceMorph := nil.
	oldColor := nil.
	container := nil.
	self releaseActionMap. "we are not sure if we need it"
	super release.! !

!MorphTreeResizerMorph methodsFor: 'instance creation' stamp: ''!
normalizedX: x

	^ x! !

!MorphTreeResizerMorph methodsFor: 'instance creation' stamp: ''!
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.
	self column currentWidth: newWidth.
	container resizerChanged! !

!MorphTreeResizerMorph methodsFor: 'instance creation' stamp: ''!
normalizedY: y 
	^y! !

!MorphTreeResizerMorph methodsFor: 'private - testing' stamp: ''!
canResizeColumn
	^self column resizable! !

!MorphTreeResizerMorph methodsFor: 'Polymorph-Widgets' stamp: ''!
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: 'instance creation' stamp: ''!
pressedFillStyle
	"Return the pressed fillStyle of the receiver."
	^ self theme morphTreeSplitterPressedFillStyleFor: self! !

!MorphTreeResizerMorph methodsFor: 'event handling' stamp: ''!
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: 'instance creation' stamp: ''!
splitsTopAndBottom
	^ false! !

!MorphTreeResizerMorph class methodsFor: 'instance creation' stamp: ''!
container: aTreeList index: anInteger
	^ self new container: aTreeList index: anInteger! !

!MorphTreeResizerMorph class methodsFor: 'accessing' stamp: ''!
fastSplitterResize
	^ true! !

!MorphTreeSelectionChanged commentStamp: ''!
Used to announce the change of a selection in the tree!
!MorphTreeSelectionChanged methodsFor: 'accessing' stamp: ''!
selection
	^ selection! !

!MorphTreeSelectionChanged methodsFor: 'accessing' stamp: ''!
selection: aSelection
	selection := aSelection! !

!MorphTreeTransformMorph commentStamp: ''!
A custom transform morph for a morphic based tree!
!MorphTreeTransformMorph methodsFor: 'drawing' stamp: ''!
drawRawColorOn: aCanvas forSubmorph: aSubMorph
	| c frame |
	frame := (aSubMorph fullBounds withWidth: owner scroller innerBounds width) translateBy:(owner scroller offset x)@0.
	aSubMorph = owner listManager searchedElement
		ifTrue: [ 
			aCanvas fillRectangle: frame color: owner secondarySelectionColor.
			^ self ].
	owner listManager isCheckList
		ifTrue: [ 
			aSubMorph = owner listManager lastClickedMorph
				ifTrue: [ 
					aCanvas fillRectangle: frame color: owner selectionColorToUse.
					^ self ] ]
		ifFalse: [ 
			aSubMorph selected
				ifTrue: [ 
					aCanvas fillRectangle: frame color: owner selectionColorToUse.
					^ self ] ].
	(c := aSubMorph color) notNil
		ifTrue: [ 
			c isColor
				ifTrue: [ 
					aCanvas
						frameAndFillRectangle: frame
						fillColor: c
						borderWidth: 0
						borderColor: Color transparent ]
				ifFalse: [ 
					c origin: aSubMorph bounds topLeft.
					c direction: aSubMorph bounds width @ 0.
					aCanvas fillRectangle: frame basicFillStyle: c ] ]! !

!MorphTreeTransformMorph methodsFor: 'drawing' stamp: ''!
bottomVisibleRowForCanvas: aCanvas startingAt: aPos
     "return the bottom visible row in aCanvas's clip rectangle"
	
	^ self rowAtLocation: (aCanvas clipRect  bottomRight)  startingAt: aPos! !

!MorphTreeTransformMorph methodsFor: 'private' stamp: ''!
privateAddAllMorphs: aCollection atIndex: index
	"Private. Add aCollection of morphs to the receiver"
	submorphs := Array 
		new: submorphs size + aCollection size
		streamContents: [:str |
			1 to: index do: [:p | str nextPut: (submorphs atWrap: p)].
			str nextPutAll: aCollection.
			index + 1 to: submorphs size do: [:p | str nextPut: (submorphs atWrap: p)]].
	aCollection do: [:m |  
		m fullBounds. 
		m privateOwner: self].
	self layoutChanged.! !

!MorphTreeTransformMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self smoothingOn! !

!MorphTreeTransformMorph methodsFor: 'drawing' stamp: ''!
topVisibleRowForCanvas: aCanvas
     "return the top visible row in aCanvas's clip rectangle"

        ^ self rowAtLocation: (aCanvas clipRect topLeft).! !

!MorphTreeTransformMorph methodsFor: 'submorphs - add/remove' stamp: ''!
addAllMorphs: aCollection after: anotherMorph
	^self privateAddAllMorphs: aCollection 
			atIndex: (anotherMorph index ifNil: [submorphs size])! !

!MorphTreeTransformMorph methodsFor: 'drawing' stamp: ''!
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: ''!
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: ''!
topVisibleRowForCanvas: aCanvas startingAt: aPos
     "return the top visible row in aCanvas's clip rectangle"

        ^ self rowAtLocation: (aCanvas clipRect topLeft) startingAt: aPos.! !

!MorphTreeTransformMorph methodsFor: 'layout' stamp: ''!
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: 'testing' stamp: ''!
wantsSteps
	^ false! !

!MorphTreeTransformMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawSubmorphsOnAthensCanvas: anAthensCanvas
	| clip |
	clip := self clippingBounds intersect: anAthensCanvas clipRect.
	anAthensCanvas
		transformBy: self transform
		withClip: clip
		in: self innerBounds
		during: [ :canvas | 
			| top bottom |
			top := self topVisibleRowForCanvas: canvas.
			bottom := self bottomVisibleRowForCanvas: canvas startingAt: top.
			bottom to: top by: -1 do: [ :row | 
				| m |
				m := submorphs basicAt: row.
				self drawRawColorOn: anAthensCanvas asCanvasWrapper forSubmorph: m.
				canvas fullDrawMorph: m ] ].
	owner withTreeLines
		ifTrue: [ owner drawLinesOn: anAthensCanvas asCanvasWrapper ].
	owner enabled
		ifFalse: [ anAthensCanvas asCanvasWrapper fillRectangle: owner innerBounds fillStyle: (owner paneColor alpha: 0.2) ]! !

!MorphTreeTransformMorph methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas
	submorphs ifEmpty: [^ self].
	aCanvas transformBy: transform
		clippingTo: (aCanvas clipRect intersect: (owner clippingBounds) ifNone: ["we're done here" ^ self ])
		during: [:myCanvas |  | top bottom |
			top := self topVisibleRowForCanvas: myCanvas.
			bottom := self bottomVisibleRowForCanvas: myCanvas startingAt: top.
			bottom 
				to: top
				by: -1			
				do: [:row | | m |
					m := submorphs basicAt: row.
					self drawRawColorOn: myCanvas forSubmorph: m.
					myCanvas fullDrawMorph: m] ]
		smoothing: smoothing.
	owner withTreeLines ifTrue: [owner drawLinesOn: aCanvas].
	owner enabled ifFalse: [ aCanvas fillRectangle: owner innerBounds fillStyle: (owner paneColor alpha: 0.2) ]! !

!MorphTreeTransformMorph methodsFor: 'geometry' stamp: ''!
fullBounds
	"Overridden to clip submorph hit detection to my bounds."
	"It might be better to override doLayoutIn:, and remove this method"

	fullBounds ifNotNil:[^ fullBounds].
	fullBounds := bounds.
	^ fullBounds! !

!MorphTreeTransformMorph methodsFor: 'layout' stamp: ''!
localSubmorphBounds
	"Answer, in my coordinate system, the bounds of all my visible submorphs (or nil if no visible submorphs)"
	localBounds ifNil: [ 
		self hasSubmorphs ifFalse: [^ nil].
		localBounds :=  self firstSubmorph fullBounds topLeft corner: owner maxNodeWidth @ (self lastSubmorph fullBounds bottom + owner extraScrollRange)].
	^ localBounds! !

!MorphTreeTransformMorph methodsFor: 'drawing' stamp: ''!
bottomVisibleRowForCanvas: aCanvas
     "return the bottom visible row in aCanvas's clip rectangle"
	
	^ self rowAtLocation: (aCanvas clipRect  bottomRight).! !

!MorphTreeTransformMorph methodsFor: 'change reporting' stamp: ''!
privateInvalidateMorph: aMorph! !

!MorphWithSubmorphsWrapper commentStamp: ''!
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: ''!
contents
	^item submorphs collect: [ :m |
		self class with: m ]! !

!MorphWrapper commentStamp: ''!
A MorphWrapper is used to wrap a morph with a layout in the goal to be easily added to another morph!
!MorphWrapper methodsFor: 'adding' stamp: ''!
addIn: aContainer
		
	aContainer
		addMorph: morph
		fullFrame: layout! !

!MorphWrapper methodsFor: 'accessing' stamp: ''!
fullFrame: anObject
	
	layout := anObject! !

!MorphWrapper methodsFor: 'accessing' stamp: ''!
frame: rectangle
	
	layout := rectangle asSpecLayoutFrame! !

!MorphWrapper methodsFor: 'accessing' stamp: ''!
morph: anObject
	
	morph := anObject! !

!MorphWrapper class methodsFor: 'instance creation' stamp: ''!
morph: morph layout: aLayout 

	^ self new
		layout: aLayout;
		morph: morph;
		yourself! !

!MorphicAdapterBindings commentStamp: ''!
I am used to link the spec-adapter names to the morphic adapters!
!MorphicAdapterBindings methodsFor: 'fonts' stamp: ''!
defaultFont

	^ StandardFonts defaultFont! !

!MorphicAdapterBindings methodsFor: 'initialize' stamp: ''!
initializeBindings
	
	^ bindings
		at: #ButtonAdapter				put: #MorphicButtonAdapter;
		at: #CheckBoxAdapter			put: #MorphicCheckBoxAdapter;
		at: #ContainerAdapter			put: #MorphicContainerAdapter;
		at: #DiffAdapter				put: #MorphicDiffAdapter;
		at: #DropListAdapter			put: #MorphicDropListAdapter;
		at: #LabelAdapter				put: #MorphicLabelAdapter;
		at: #ListAdapter				put: #MorphicListAdapter;
		at: #IconListAdapter			put: #MorphicIconListAdapter;
		at: #FastTableAdapter			put: #MorphicFastTableAdapter;
		at: #ImageAdapter			put: #MorphicImageAdapter;
		at: #MultiColumnListAdapter	put: #MorphicMultiColumnListAdapter;
		at: #MenuAdapter				put: #MorphicMenuAdapter;
		at: #MenuGroupAdapter		put: #MorphicMenuGroupAdapter;
		at: #MenuItemAdapter			put: #MorphicMenuItemAdapter;
		at: #RadioButtonAdapter		put: #MorphicRadioButtonAdapter;
		at: #SliderAdapter				put: #MorphicSliderAdapter;
		at: #TabManagerAdapter		put: #MorphicTabManagerAdapter;
		at: #TabAdapter				put: #MorphicTabAdapter;
		at: #TextAdapter				put: #MorphicTextAdapter;
		at: #TextInputFieldAdapter		put: #MorphicTextInputFieldAdapter;
		at: #TransferAdapter			put: #MorphicTransferAdapter;
		at: #TreeAdapter				put: #MorphicTreeAdapter;
		at: #TreeColumnAdapter		put: #MorphicTreeColumnAdapter;
		at: #TreeNodeAdapter			put: #MorphicTreeNodeAdapter;
		at: #WindowAdapter			put: #MorphicWindowAdapter;
		at: #TickingWindowAdapter	put: #MorphicTickingWindowAdapter;
		at: #DialogWindowAdapter		put: #MorphicDialogWindowAdapter;
		yourself! !

!MorphicAlarm commentStamp: ''!
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: 'evaluating' stamp: ''!
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 methodsFor: 'accessing' stamp: ''!
scheduledTime: msecs
	"Set the time (in milliseconds) that the receiver is scheduled to be executed"
	scheduledTime := msecs! !

!MorphicAlarm methodsFor: 'accessing' stamp: ''!
scheduledTime
	"Return the time (in milliseconds) that the receiver is scheduled to be executed"
	^scheduledTime! !

!MorphicAlarm class methodsFor: 'instance creation' stamp: ''!
scheduledAt: scheduledTime receiver: aTarget selector: aSelector arguments: argArray
	^(self receiver: aTarget selector: aSelector arguments: argArray)
		scheduledTime: scheduledTime.! !

!MorphicButtonAdapter commentStamp: ''!
SpecInterpreter
	interpretASpec: MorphicButtonAdapter  defaultSpec
	model: (MorphicButtonAdapter model: ButtonPresenter new)
!
!MorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
menu: aMenu
	| menuModel |
	
	menuModel := self model menu.
	menuModel isBlock ifTrue: [ menuModel := menuModel value ].
	^ menuModel buildWithSpec! !

!MorphicButtonAdapter methodsFor: 'private' stamp: ''!
buildLabel: text withIcon: icon

	icon ifNil: [ ^ text
			ifNil: [ '' ]
			ifNotNil: [ text ] ].
	
	^ IconicListItemMorph 
		text: text 
		icon: icon
! !

!MorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
action

	self widget ifNotNil: [:m | m takeKeyboardFocus ].
	self model performAction.! !

!MorphicButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	
	| button | 
	button := PluggableButtonMorph
				on: self 
				getState: #state 
				action:  #action 
				label: #label 
				menu: nil. 	
	button 
		getEnabledSelector: #enabled ;
		getFontSelector: #font ;
		hResizing: #spaceFill ;
		vResizing: #spaceFill ;
		askBeforeChanging: self askBeforeChanging ;
		setBalloonText: self model help ;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled ;	
		eventHandler: (MorphicEventHandler new on: #keyStroke send: #keyStroke:fromMorph: to: self).
	
	self color ifNotNil: [ self setWidgetColor: button ].
	^ button! !

!MorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
font
	^self model font! !

!MorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
state

	^ self model state! !

!MorphicButtonAdapter methodsFor: 'factory' stamp: ''!
setWidgetColor: button

		| normalColorBlock clickedColorBlock |

		normalColorBlock := [ :aButton |
							(aButton valueOfProperty: #noFill ifAbsent: [false]) 
								ifTrue: [ SolidFillStyle color: Color transparent ]
								ifFalse: [ SolidFillStyle color: self color ] ].
	
		clickedColorBlock := [ :aButton | SolidFillStyle color: self color muchDarker ].
		button theme: ((UIThemeDecorator theme: button theme)
							property: #buttonNormalFillStyleFor: returnsValueOf: normalColorBlock;
							property: #buttonMouseOverFillStyleFor: returnsValueOf: normalColorBlock;
							property: #buttonPressedFillStyleFor: returnsValueOf: clickedColorBlock;
							yourself).
! !

!MorphicButtonAdapter methodsFor: 'protocol' stamp: ''!
askBeforeChanging

	^ self model askBeforeChanging! !

!MorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
label
	
	^ self buildLabel: self model label withIcon: self model icon! !

!MorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
keyStroke: anEvent fromMorph: aMorph! !

!MorphicCheckBoxAdapter commentStamp: ''!
I am an adapter to ease the bridge a CheckBoxPresenter and a CheckboxMorph!
!MorphicCheckBoxAdapter methodsFor: 'spec protocol' stamp: ''!
labelOnRight

	^ self widgetDo: [ :w | w listDirection: #rightToLeft ]! !

!MorphicCheckBoxAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	| checkButton |
	checkButton := CheckboxMorph
						on: self 
						selected: #state
						changeSelected: #state:. 			
	checkButton 
			label:	self label; 
			beCheckbox;
			hResizing: #spaceFill; 
			vResizing: #shrinkWrap; 
			setBalloonText: self help;
			getEnabledSelector: #enabled;
			dragEnabled: self dragEnabled;
			dropEnabled: self dropEnabled;	
			labelClickable: self labelClickable.
	^ checkButton! !

!MorphicCheckBoxAdapter methodsFor: 'widget API' stamp: ''!
state: aBoolean
	
	^ self model state: aBoolean! !

!MorphicCheckBoxAdapter methodsFor: 'spec protocol' stamp: ''!
labelOnLeft

	^ self widgetDo: [ :w | w listDirection: #leftToRight ]! !

!MorphicCheckBoxAdapter methodsFor: 'widget API' stamp: ''!
labelClickable
	
	^ self model labelClickable! !

!MorphicCheckBoxAdapter methodsFor: 'widget API' stamp: ''!
state
	
	^ self model state! !

!MorphicCheckBoxAdapter methodsFor: 'widget API' stamp: ''!
label
	
	^ self model label! !

!MorphicContainerAdapter commentStamp: ''!
I am the adapter providing the correct container class: PanelMorph!
!MorphicContainerAdapter methodsFor: 'protocol' stamp: ''!
newVSplitterAt: aPosition
	
	self widgetDo: [ :w | w newVSplitterAt: aPosition ]! !

!MorphicContainerAdapter methodsFor: 'spec protocol' stamp: ''!
centerWidget: aWindow

	self widgetDo: [ :w| w centerWidget: aWindow ]! !

!MorphicContainerAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ PanelMorph new
		changeProportionalLayout;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		yourself! !

!MorphicContainerAdapter methodsFor: 'protocol' stamp: ''!
isRedrawable
	"This must be overriden in the adapter representing your container"
	
	^ true! !

!MorphicContainerAdapter methodsFor: 'protocol' stamp: ''!
checkSplitters
	
	self widgetDo: [ :w | w checkSplitters ]! !

!MorphicContainerAdapter methodsFor: 'protocol' stamp: ''!
newHSplitterAt: aPosition
	
	self widgetDo: [ :w | w newHSplitterAt: aPosition ]! !

!MorphicCoreUIManager commentStamp: ''!
This is a very simplified version of MorphicUIManager for Moprhic subset that contains ony Morphic-Core package and has only support of the most basic morphs.!
!MorphicCoreUIManager methodsFor: 'ui process' stamp: ''!
spawnNewProcess

  UIProcess := [
	MorphicRenderLoop new doOneCycleWhile: [ true ]
  ] newProcess priority: Processor userSchedulingPriority.
  UIProcess name: 'Morphic UI Process'.
  UIProcess resume! !

!MorphicCoreUIManager methodsFor: 'ui requests' stamp: ''!
restoreDisplayAfter: aBlock

  aBlock value.
  self currentWorld activeHand waitButton.
  self currentWorld fullRepaintNeeded.! !

!MorphicCoreUIManager methodsFor: 'ui requests' stamp: ''!
currentWorld

	ActiveWorld ifNotNil: [ ^ ActiveWorld ].
	^ World! !

!MorphicCoreUIManager methodsFor: 'ui process' stamp: ''!
uiProcess
  " Answer the currently active UI process for morphic world.
  Client should check explicitly if #uiProcess answers nil or not (see other implementations)"

  ^ UIProcess! !

!MorphicCoreUIManager methodsFor: 'ui requests' stamp: ''!
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! !

!MorphicCoreUIManager methodsFor: 'ui process' stamp: ''!
terminateUIProcess
  UIProcess suspend; terminate.
  UIProcess := nil "?"! !

!MorphicCoreUIManager methodsFor: 'ui process' stamp: ''!
resumeUIProcess: aProcess
  "Adopt aProcess as the project process -- probably because of proceeding from a debugger"
      
  UIProcess := aProcess.
  UIProcess resume! !

!MorphicCoreUIManager class methodsFor: 'cleanup' stamp: ''!
restartMethods
   UIProcess ifNotNil: [
	| process |
	process := UIProcess.
	self new spawnNewProcess.
	process terminate. ]! !

!MorphicDialogWindowAdapter commentStamp: ''!
I am the adapter used to bridge a DialogWindowPresenter and a DialogWindow!
!MorphicDialogWindowAdapter methodsFor: 'protocol' stamp: ''!
open

	self widget openInWorld! !

!MorphicDialogWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecDialogWindow new
			specWidget: self contentMorph;
			setToolbarFrom: self toolbarBlock;
			model: self model;
			initialize;
			yourself! !

!MorphicDialogWindowAdapter methodsFor: 'widget API' stamp: ''!
contentMorph

	^ self model contents! !

!MorphicDialogWindowAdapter methodsFor: 'widget API' stamp: ''!
toolbarBlock

	^ [ self model toolbar ]! !

!MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: ''!
triggerCancelAction

	self widget ifNotNil: [:w | w toolbar triggerCancelAction ]! !

!MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: ''!
cancelAction: aBlock

	^ self widget
		ifNotNil: [:w | w cancelAction: aBlock ]! !

!MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: ''!
okAction: aBlock

	^ self widget
		ifNotNil: [:w | w okAction: aBlock ]! !

!MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: ''!
toolbar: aToolbar 

	self widgetDo: [ :w | w toolbar: aToolbar ]! !

!MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: ''!
triggerOkAction

	self widget ifNotNil: [:w | w toolbar triggerOkAction ]! !

!MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: ''!
okButtonEnabled: aBoolean

	self widget ifNotNil: [ :w | w toolbar okButton enabled: aBoolean ]! !

!MorphicDiffAdapter commentStamp: ''!
I am an adapter to bridge a DiffPresenter and a DiffMorph!
!MorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
rightLabel: aText

	self widgetDo: [ :w | 
		w leftLabel: self leftLabel rightLabel: aText ]! !

!MorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
rightText: aText
	self
		widgetDo: [ :w | 
			w destTextModel setText: aText.
			w updateText ]! !

!MorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
showBoth

	self widgetDo: [ :w | w showBoth ]! !

!MorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
rightLabel

	^ self model rightLabel! !

!MorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
contextClass

	^ self model contextClass! !

!MorphicDiffAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ DiffMorph new  
		on: self ;
		from: self leftText to: self rightText contextClass: self contextClass;
		 hResizing:	#spaceFill;
		vResizing: #spaceFill;
		setBalloonText: self  help;
		showOptions: self showOptions;
		leftLabel: self leftLabel rightLabel: self rightLabel;
		showOnlyDestination: self showOnlyDestination;
		yourself! !

!MorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
leftLabel

	^ self model leftLabel! !

!MorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
leftLabel: aText

	self widgetDo: [ :w | 
		w leftLabel: aText rightLabel: self rightLabel ]! !

!MorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
showOptions

	^ self model showOptions! !

!MorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
showOptions: aBoolean

	self widgetDo: [ :w | w showOptions: aBoolean ]! !

!MorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
showOnlyDestination: aBoolean

	self widgetDo: [ :w | w showOnlyDestination: aBoolean ]! !

!MorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
showOnlyDestination

	^ self model showOnlyDestination! !

!MorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
showOnlySource

	^ self model showOnlySource! !

!MorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
leftText

	^ self model leftText! !

!MorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
rightText

	^ self model rightText! !

!MorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
showOnlySource: aBoolean

	self widgetDo: [ :w | w showOnlySource: aBoolean ]! !

!MorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
leftText: aText

	self widgetDo: [ :w | 
		w sourceTextModel setText: aText.
		w updateText ]! !

!MorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
contextClass: aClass
	self widgetDo: [ :w | 
		w 
			contextClass: aClass;
			updateText ]! !

!MorphicDropListAdapter commentStamp: ''!
I am the adapter used to bridget a DropListPresenter and a DropListMorph!
!MorphicDropListAdapter methodsFor: 'widget API' stamp: ''!
wrapItem: anItem index: anIndex
	| result |
	result := self model displayForItem: anItem.	
	^ result asString! !

!MorphicDropListAdapter methodsFor: 'widget API' stamp: ''!
setIndex: anIndex
	^ self model setIndex: anIndex! !

!MorphicDropListAdapter methodsFor: 'widget API' stamp: ''!
getIndex

	^ self model getIndex! !

!MorphicDropListAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ SpecDropListMorph new
		wrapSelector: #wrap:withIndex:;
		on: self list: #getList selected: #getIndex 	changeSelected: #setIndex:;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		enabled: self enabled;
		setBalloonText: self help;
		yourself! !

!MorphicDropListAdapter methodsFor: 'widget API' stamp: ''!
getIconFor: anItem

	^ self model iconHolder cull: anItem model cull: anItem! !

!MorphicDropListAdapter methodsFor: 'widget API' stamp: ''!
getList

	^ self model getList! !

!MorphicEvent commentStamp: ''!
This class represents the base for all events.

Instance variables:
	stamp	<Integer>	The millisecond clock time stamp (based on Time millisecondClock)
	source	<Hand | nil>	If non-nil the hand that generated the event.!
!MorphicEvent methodsFor: 'accessing' stamp: ''!
position
	"Since cursorPoint is defined and refers to position it should be defined
	here as well"
	^ self subclassResponsibility! !

!MorphicEvent methodsFor: 'testing' stamp: ''!
isDropEvent
	^false! !

!MorphicEvent methodsFor: 'comparing' stamp: ''!
= anEvent
	anEvent isMorphicEvent ifFalse:[^false].
	^self type = anEvent type! !

!MorphicEvent methodsFor: 'accessing' stamp: ''!
wasHandled
	"Return true if this event was handled. May be ignored for some types of events."
	^false! !

!MorphicEvent methodsFor: 'accessing' stamp: ''!
hand
	"Return the source that generated the event"
	^source! !

!MorphicEvent methodsFor: 'comparing' stamp: ''!
hash
	^self type hash! !

!MorphicEvent methodsFor: 'testing' stamp: ''!
isMouseOver
	^self type == #mouseOver! !

!MorphicEvent methodsFor: 'initialize' stamp: ''!
copyHandlerState: anEvent
	"Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."! !

!MorphicEvent methodsFor: 'testing' stamp: ''!
isMove
	^false! !

!MorphicEvent methodsFor: 'accessing' stamp: ''!
cursorPoint
	"Backward compatibility. Use #position instead"
	^ self position! !

!MorphicEvent methodsFor: 'accessing' stamp: ''!
timeStamp
	"Return the millisecond clock value at which the event was generated"
	^timeStamp ifNil:[timeStamp := Time millisecondClockValue]! !

!MorphicEvent methodsFor: 'testing' stamp: ''!
isDraggingEvent
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: ''!
isKeyboard
	^false! !

!MorphicEvent methodsFor: 'private' stamp: ''!
setHand: aHand
	source := aHand! !

!MorphicEvent methodsFor: 'private' stamp: ''!
setTimeStamp: stamp
	timeStamp := stamp.! !

!MorphicEvent methodsFor: 'accessing' stamp: ''!
wasHandled: aBool
	"Determine if this event was handled. May be ignored for some types of events."! !

!MorphicEvent methodsFor: 'accessing' stamp: ''!
windowIndex
	^windowIndex! !

!MorphicEvent methodsFor: 'initialize' stamp: ''!
resetHandlerFields
	"Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"! !

!MorphicEvent methodsFor: 'testing' stamp: ''!
isWindowEvent
	^false! !

!MorphicEvent methodsFor: 'accessing' stamp: ''!
type
	"Return a symbol indicating the type this event."
	^self subclassResponsibility! !

!MorphicEvent methodsFor: 'dispatching' stamp: ''!
sentTo: anObject
	"Dispatch the receiver into anObject"
	^anObject handleUnknownEvent: self! !

!MorphicEvent methodsFor: 'testing' stamp: ''!
isKeystroke
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: ''!
isMouse
	^false! !

!MorphicEvent methodsFor: 'accessing' stamp: ''!
windowIndex: aValue
	windowIndex := aValue! !

!MorphicEvent methodsFor: 'testing' stamp: ''!
isMorphicEvent
	^true! !

!MorphicEvent methodsFor: 'transforming' stamp: ''!
transformedBy: aMorphicTransform
	"Return the receiver transformed by the given transform into a local coordinate system."! !

!MorphicEventDispatcher commentStamp: ''!
The class represents a strategy for dispatching events to some immediate child of a morph. It is used by morphs to delegate the somewhat complex action of dispatching events accurately. !
!MorphicEventDispatcher methodsFor: 'dispatching' stamp: ''!
dispatchEvent: anEvent with: aMorph
	"Dispatch the given event for a morph that has chosen the receiver to dispatch its events. "
	morph := aMorph.
	[ ^ anEvent sentTo: self ]
	ensure: [ morph := nil ]! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleKeystroke: anEvent 

	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleUnknownEvent: anEvent 
	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching' stamp: ''!
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: ''!
dispatchWindowEvent: anEvent with: aMorph
	"Host window events do not have a position and are only dispatched to the World"
	aMorph isWorldMorph ifFalse: [^#rejected].
	anEvent wasHandled ifTrue:[^self].
	^aMorph handleEvent: anEvent! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleKeyDown: anEvent 

		^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleMouseOver: anEvent 	
	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleMouseUp: anEvent 
	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleDropMorph: anEvent 

	^ self dispatchDropEvent: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleMouseDown: anEvent 

	^ self dispatchMouseDown: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching' stamp: ''!
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-callback' stamp: ''!
handleStep: anEvent 
	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleMouseLeave: anEvent 
	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleMouseMove: anEvent 
	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleDropFiles: anEvent 
	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching' stamp: ''!
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-callback' stamp: ''!
handleMouseWheel: anEvent 
	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleWindowEvent: anEvent 

	^ self dispatchWindowEvent: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleMouseEnter: anEvent 

	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventDispatcher methodsFor: 'dispatching-callback' stamp: ''!
handleKeyUp: anEvent 

	^ self dispatchDefault: anEvent with: morph! !

!MorphicEventHandler commentStamp: ''!
I'm the class in charge of handling the subscriptions to events such as clicks or key presses.
I'm a provisory solution while my clients are fixed and I can be replaced by announcements!
!MorphicEventHandler methodsFor: 'testing' stamp: ''!
existsSubscriptionsFor: anEvent
	^(subscriptions includesKey: anEvent) and: [ (subscriptions at: anEvent) notEmpty ]! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
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: 'testing' stamp: ''!
handlesMouseMove: evt
	^self existsSubscriptionsFor: #mouseMove! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
keyUp: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #keyUp from: sourceMorph! !

!MorphicEventHandler methodsFor: 'testing' stamp: ''!
handlesClickOrDrag: evt
	^(self existsSubscriptionsFor: #click)
		or: [ (self existsSubscriptionsFor: #doubleClick) 
			or: [(self existsSubscriptionsFor: #startDrag)]].! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
keyDown: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #keyDown from: sourceMorph! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
mouseStillDown: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #mouseStillDown from: sourceMorph! !

!MorphicEventHandler methodsFor: 'initialization' stamp: ''!
on: eventName send: selector to: recipient
	self
		addSubscription: (MorphEventSubscription on: eventName send: selector to: recipient)
		toEvent: eventName.! !

!MorphicEventHandler methodsFor: 'copying' stamp: ''!
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: 'testing' stamp: ''!
handlesMouseOver: evt
	(self existsSubscriptionsFor: #mouseEnter) ifTrue: [ ^true ].
	(self existsSubscriptionsFor: #mouseLeave)  ifTrue: [ ^true ].
	(self existsSubscriptionsFor: #mouseOver) ifTrue: [ ^true ].
	^false.! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
mouseMove: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #mouseMove from: sourceMorph! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
doubleClickTimeout: event fromMorph: sourceMorph 
	^self notifyMorphsOfEvent: event ofType: #doubleClickTimeout from: sourceMorph! !

!MorphicEventHandler methodsFor: 'testing' stamp: ''!
handlesGestureStart: evt
	^self existsSubscriptionsFor: #gestureStart! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
mouseOver: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #mouseOver from: sourceMorph! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
keyStroke: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #keyStroke from: sourceMorph! !

!MorphicEventHandler methodsFor: 'testing' stamp: ''!
handlesKeyDown: evt
	^self existsSubscriptionsFor: #keyDown! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
startDrag: event fromMorph: sourceMorph 
	^self notifyMorphsOfEvent: event ofType: #startDrag from: sourceMorph! !

!MorphicEventHandler methodsFor: 'testing' stamp: ''!
handlesKeyUp: evt
	^self existsSubscriptionsFor: #keyUp! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
doubleClick: event fromMorph: sourceMorph 
	^self notifyMorphsOfEvent: event ofType: #doubleClick from: sourceMorph! !

!MorphicEventHandler methodsFor: 'testing' stamp: ''!
handlesMouseOverDragging: evt
	^(self existsSubscriptionsFor: #mouseEnterDragging )
		or: [ self existsSubscriptionsFor: #mouseLeaveDragging ]! !

!MorphicEventHandler methodsFor: 'testing' stamp: ''!
handlesMouseStillDown: evt
	^self existsSubscriptionsFor: #mouseStillDown.! !

!MorphicEventHandler methodsFor: 'initialization' stamp: ''!
initialize
	subscriptions := Dictionary new.! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
mouseEnterDragging: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #mouseEnterDragging from: sourceMorph! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
mouseLeave: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #mouseLeave from: sourceMorph! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
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: 'accessing' stamp: ''!
methodRefList
	"Return a MethodReference for each message I can send."
	| list |
	list := OrderedCollection new.
	subscriptions do: [
		:subscriptionSet |
		
		subscriptionSet do: [ 	 :s | 
			s  ifNotNil: [list
						add: (RGMethodDefinition
								realClass: (s recipient class whichClassIncludesSelector: s selector)
								selector: s selector)]
							]
		].
	^ list! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
click: event fromMorph: sourceMorph 
	^self notifyMorphsOfEvent: event ofType: #click from: sourceMorph! !

!MorphicEventHandler methodsFor: 'accessing' stamp: ''!
allRecipients
	^subscriptions collect: [ :each | each recipients ]! !

!MorphicEventHandler methodsFor: 'initialization' stamp: ''!
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: ''!
handlesKeyboard: evt
	^(self handlesKeyDown: evt)
		or: [ (self handlesKeyUp: evt)
			or: [ self handlesKeyStroke: evt ]].! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
addSubscription: aSubscription toEvent: eventName
	(subscriptions includesKey: eventName)
		ifFalse: [ subscriptions at: eventName put: Set new. ].
	(subscriptions at: eventName)
		add: aSubscription.! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
mouseUp: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #mouseUp from: sourceMorph! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
mouseEnter: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #mouseEnter from: sourceMorph! !

!MorphicEventHandler methodsFor: 'testing' stamp: ''!
mouseSelectorsInclude: selector

	| mouseEventTypes allSubscriptions |
	mouseEventTypes := #(
		mouseDown
		mouseMove
		mouseStillDown
		mouseUp
		mouseEnter
		mouseLeave
		mouseEnterDragging
		mouseLeaveDragging
		doubleClick).
	
	allSubscriptions := subscriptions values flatCollect: [ :e | e ].
	^ allSubscriptions anySatisfy: [ :e | (mouseEventTypes includes: e event) and: [ e selector = selector ] ].! !

!MorphicEventHandler methodsFor: 'testing' stamp: ''!
handlesMouseDown: evt
	^(self existsSubscriptionsFor: #mouseDown)
		or: [ (self existsSubscriptionsFor: #mouseStillDown)
			or: [ (self existsSubscriptionsFor: #mouseUp)
				or: [ (self handlesClickOrDrag: evt)
					or: [ self handlesGestureStart: evt]]]].! !

!MorphicEventHandler methodsFor: 'events' stamp: ''!
mouseLeaveDragging: event fromMorph: sourceMorph
	^self notifyMorphsOfEvent: event ofType: #mouseLeaveDragging from: sourceMorph! !

!MorphicEventHandler methodsFor: 'testing' stamp: ''!
handlesKeyStroke: evt
	^self existsSubscriptionsFor: #keyStroke! !

!MorphicEventHandlerTest methodsFor: 'tests - events' stamp: ''!
testKeyDownFromMorph
	| keyboardEvent |

	keyboardEvent := KeyboardEvent new
		setType: #keyDown
		buttons: 2
		position: nil
		keyValue: nil
		charCode: 65
		hand: nil
		stamp: nil.

	morph eventHandler on: #keyDown send: #value to: true.

	self assert: (keyboardEvent sentTo: morph) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'running' stamp: ''!
tearDown

	morph delete.

	morph := nil.
	super tearDown! !

!MorphicEventHandlerTest methodsFor: 'tests - events' stamp: ''!
testMouseLeaveFromMorph
	| event |
	morph eventHandler on: #mouseLeave send: #value to: true.

	event := (MouseButtonEvent new 
		setType: #mouseMove
		position: 0@0
		which: 0
		buttons: 0
		hand: (HandMorph new
			mouseFocus: morph;
			yourself)
		stamp: Time millisecondClockValue).

	self assert: (morph handleMouseLeave: event) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'tests - events' stamp: ''!
testMouseUpFromMorph
	| event |

	event := (MouseButtonEvent new 
		setType: #mouseUp
		position: 0@0
		which: 0
		buttons: 0
		hand: (HandMorph new
			mouseFocus: morph;
			yourself)
		stamp: Time millisecondClockValue).

	morph eventHandler on: #mouseUp send: #value to: true.
	
	self assert: (event sentTo: morph) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'tests - events' stamp: ''!
testMiddleButtonOpenHalos
	| event |

	morph openInWorld.

	event := (MouseButtonEvent new 
		setType: #mouseDown
		position: 0@0
		which: MouseButtonEvent blueButton
		buttons: 0
		hand: morph world activeHand
		stamp: Time millisecondClockValue).
	
	event sentTo: morph.
			
	self assert: (morph halo) isNotNil! !

!MorphicEventHandlerTest methodsFor: 'tests' stamp: ''!
testClickFromMorph
	morph eventHandler on: #click send: #value to: true.

	self assert: (morph click: nil) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'tests - events' stamp: ''!
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) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'tests' stamp: ''!
testDoubleClickTimeoutFromMorph
	morph eventHandler on: #doubleClickTimeout send: #value to: true.

	self assert: (morph doubleClickTimeout: nil) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'tests' stamp: ''!
testDoubleClickFromMorph
	morph eventHandler on: #doubleClick send: #value to: true.

	self assert: (morph doubleClick: nil) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'tests - events' stamp: ''!
testMouseEnterFromMorph
	| event |
	morph eventHandler on: #mouseEnter send: #value to: true.

	event := (MouseButtonEvent new 
		setType: #mouseMove
		position: 0@0
		which: 0
		buttons: 0
		hand: (HandMorph new
			mouseFocus: morph;
			yourself)
		stamp: Time millisecondClockValue).

	self assert: (morph handleMouseEnter: event) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'tests' stamp: ''!
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) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'tests - events' stamp: ''!
testKeyUpFromMorph
	| keyboardEvent |

	keyboardEvent := KeyboardEvent new
		setType: #keyUp
		buttons: 2
		position: nil
		keyValue: nil
		charCode: 65
		hand: nil
		stamp: nil.

	morph eventHandler on: #keyUp send: #value to: true.

	self assert: (keyboardEvent sentTo: morph) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'tests - events' stamp: ''!
testMouseDownFromMorph
	| event |

	event := (MouseButtonEvent new 
		setType: #mouseDown
		position: 0@0
		which: 0
		buttons: 0
		hand: (HandMorph new
			mouseFocus: morph;
			yourself)
		stamp: Time millisecondClockValue).

	morph eventHandler on: #mouseDown send: #value to: true.
	
	self assert: (event sentTo: morph) identicalTo: true! !

!MorphicEventHandlerTest methodsFor: 'tests' stamp: ''!
testTwoEventHandlersAreAttached

	| keyboardEvent first second |
	keyboardEvent := KeyboardEvent new 
							setType: #keystroke
							buttons: 2
							position: nil
							keyValue: 65
							charCode: 65
							hand: nil
							stamp: nil.

	first := false.
	second := false.
	morph eventHandler on: #keyStroke send: #value to: [ first := true ].
	morph eventHandler on: #keyStroke send: #value to: [ second := true ].
	morph handleKeystroke: keyboardEvent.
	
	self assert: first.
	self assert: second.! !

!MorphicEventHandlerTest methodsFor: 'tests' stamp: ''!
testMouseEnterEventIsNotDuplicated
	| mockObject window evt |
	mockObject := ForEventTestMock new.

	[ window := mockObject stringMorph openInWindow.
	evt := MouseButtonEvent new
		setType: nil
		position: mockObject stringMorph center
		which: MouseButtonEvent redButton
		buttons: MouseButtonEvent redButton
		hand: nil
		stamp: nil.

	self assert: mockObject counter equals: 0.

	mockObject stringMorph handleMouseEnter: evt.
	self assert: mockObject counter equals: 1 ]
		ensure: [ window ifNotNil: #close ]! !

!MorphicEventHandlerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	morph := Morph new.
	morph eventHandler: MorphicEventHandler new! !

!MorphicFastTableAdapter commentStamp: ''!
I am the adapter used to bridge an FastTablePresenter and a FTPluggableIconListMorphAdaptor!
!MorphicFastTableAdapter methodsFor: 'widget API' stamp: ''!
doubleClick: event

	^ self model doubleClick: event! !

!MorphicFastTableAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ FTPluggableIconListMorphAdaptor new
		  model: self model;
			hideColumnHeaders;
			beResizable;
			columns: self model columns;
			getListSizeSelector: #listSize ;
			getListElementSelector: #listElementAt: ;
			getIndexSelector: #getIndex ;
			setIndexSelector: #setIndex: ;
			getSelectionListSelector:	#getSelectionStateFor: ;
			setSelectionListSelector:	#setSelectionStateFor:at: ;
			getIconSelector: #getIconFor: ;
			resetListSelector:	#resetListSelection ; 
			getMenuSelector:	#menu:shifted: ;
			setMultipleSelection: self multiSelection;
			doubleClickSelector: #doubleClick: ;
			basicWrapSelector: #wrapItem: ;
			dragEnabled:	self dragEnabled ;
			dropEnabled:	self dropEnabled ; 	
			setBalloonText: self help; 
			hResizing: 	#spaceFill;
			vResizing: 	#spaceFill;
			selectIndex: 1;
			enableFilter: FTSubstringFilter;			
			explicitFunction;
			yourself! !

!MorphicFastTableAdapter methodsFor: 'widget API' stamp: ''!
getIconFor: anItem

	^ self model getIconFor: anItem! !

!MorphicFastTableAdapter methodsFor: 'widget API' stamp: ''!
wrapItem: anObject

	^ self model wrapItem: anObject! !

!MorphicGenericAdapter commentStamp: ''!
I am a generic adapter used to embed directly a Morph in spec.

Be aware that when you use this, you broke Spec plateform independency and force you application to run only on top of Morphic!
!MorphicGenericAdapter methodsFor: 'accessing' stamp: ''!
morph

	^ self widget! !

!MorphicGenericAdapter methodsFor: 'accessing' stamp: ''!
morph: anObject

	widget := anObject! !

!MorphicGenericAdapter class methodsFor: 'instance creation' stamp: ''!
morph: morph

	^ self new
		morph: morph;
		yourself! !

!MorphicIconListAdapter commentStamp: ''!
I am the adapter used to bridge an IconListPresenter and a PluggableIconListMorph!
!MorphicIconListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ PluggableIconListMorph new
		    	model: self ;
			getListSizeSelector: #listSize ;
			getListElementSelector: #listElementAt: ;
			getIndexSelector: #getIndex ;
			setIndexSelector: #setIndex: ;
			getSelectionListSelector:	#getSelectionStateFor: ;
			setSelectionListSelector:	#setSelectionStateFor:at: ;
			getIconSelector: #getIconFor: ;
			resetListSelector:	#resetListSelection ; 
			getMenuSelector:	#menu:shifted: ;
			setMultipleSelection:	self multiSelection;
			wrapSelector: 	#wrapItem:index: ;
			dragEnabled:	self dragEnabled ;
			dropEnabled:	self dropEnabled ; 	
			setBalloonText: self help; 
			hResizing: 	#spaceFill;
			vResizing: 	#spaceFill;
			backgroundColoringBlockOrSelector: #backgroundColorFor:at: ;
			yourself! !

!MorphicIconListAdapter methodsFor: 'widget API' stamp: ''!
getIconFor: anItem

	^ self model getIconFor: anItem! !

!MorphicImageAdapter commentStamp: ''!
I am the bridge between an ImagePresenter and a AlphaImageMorph!
!MorphicImageAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| alphaImage |
	alphaImage := AlphaImageMorph new.
	alphaImage model: self.
	alphaImage
		getImageSelector: #getImage;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		layout: (self model autoScale 
				ifTrue: [ #scaledAspect ]
				ifFalse: [ #center ]);
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		setBalloonText: self help;
		update: #getImage.
	^ alphaImage! !

!MorphicImageAdapter methodsFor: 'initialization' stamp: ''!
adapt: aComposablePresenter

	super adapt: aComposablePresenter.
	widget
		on: #click
		send: #click
		to: self! !

!MorphicImageAdapter methodsFor: 'private' stamp: ''!
click

	^ self model action value! !

!MorphicImageAdapter methodsFor: 'widget protocol' stamp: ''!
getImage

	^ self model image! !

!MorphicImageAdapter methodsFor: 'widget protocol' stamp: ''!
switchAutoscale
	| layoutValue |
	layoutValue := self model autoScale
		ifTrue: [ #scaledAspect ]
		ifFalse: [ #center ].
	self widgetDo: [ :w | w layout: layoutValue ]! !

!MorphicLabelAdapter commentStamp: ''!
I am the adapter used to bridget a LabelPresenter and a LabelMorph!
!MorphicLabelAdapter methodsFor: 'spec protocol' stamp: ''!
emphasisCodeFor: anEmphasis
	^ anEmphasis
		inject: 0
		into: [ :sum :next | sum + (self emphasisOptions at: next) ]! !

!MorphicLabelAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| label |
	label := LabelMorph new model: self.
	label
		getEnabledSelector: #enabled;
		getTextSelector: #getText;
		vResizing: #shrinkWrap;
		hResizing: #spaceFill;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		setBalloonText: self help;
		color: self model color;
		emphasis: (self emphasisCodeFor: self model emphasis).
	^ label! !

!MorphicLabelAdapter methodsFor: 'spec protocol' stamp: ''!
emphasisOptions
	^ emphasisOptions
		ifNil:
			[ 
			emphasisOptions := {(#bold -> 1).
			(#italic -> 2).
			(#underline -> 4).
			(#narrow -> 8).
			(#struck -> 16)} asDictionary ]! !

!MorphicLabelAdapter methodsFor: 'spec protocol' stamp: ''!
emphasis: anEmphasis

	self widgetDo: [ :w | w emphasis: (self emphasisCodeFor: anEmphasis) ]! !

!MorphicLabelAdapter methodsFor: 'model access' stamp: ''!
getText

	^ self model label! !

!MorphicListAdapter commentStamp: ''!
I am the adapter used to bridge a ListPresenter and a PluggableListMorph!
!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
autoDeselect

	^ self model autoDeselect! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
wrapItem: anObject index: index

	^ self model wrapItem: anObject index: index! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
acceptDroppingMorph: draggedMorph event: event inMorph: source
	| item index |
	
	index := source rowAtLocation: event position.
	item := self model getList at: index ifAbsent: [ nil ].
	
	^ self acceptDropBlock valueWithEnoughArguments: { draggedMorph model model . event. source model model. item. index }! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
setIndex: anIndex

	^ self model setIndex: anIndex! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
getIndex

	^ self model getIndex! !

!MorphicListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ PluggableListMorph new
		model: self;
		getListSizeSelector: #listSize;
		autoDeselect: self autoDeselect;
		getIndexSelector: #getIndex;
		setIndexSelector: #setIndex:;
		getSelectionListSelector: #getSelectionStateFor:;
		setSelectionListSelector: #setSelectionStateFor:at:;
		backgroundColoringBlockOrSelector: #backgroundColorFor:at: ;
		getListElementSelector: #listElementAt: ;
		resetListSelector: #resetListSelection;
		getMenuSelector: #menu:shifted: ;
		setMultipleSelection: self multiSelection;
		wrapSelector: #wrapItem:index: ;
		setBalloonText: self help;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;	
		hResizing: #spaceFill;
		vResizing: #spaceFill! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
listSize

	^ self model listSize! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
multiSelection

	^ self model multiSelection! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
resetListSelection

	^ self model resetListSelection! !

!MorphicListAdapter methodsFor: 'spec protocol' stamp: ''!
autoDeselect: aBoolean

	self widgetDo: [ :w | w autoDeselect: aBoolean ]! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
getSelectionStateFor: anIndex

	^ self model getSelectionStateFor: anIndex! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
listElementAt: anIndex ifAbsent: aBlock

	^ self model listElementAt: anIndex ifAbsent: aBlock! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
listElementAt: anIndex

	^ self model listElementAt: anIndex! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
menu: aMenu shifted: aBoolean

	^ (self model menu: aMenu shifted: aBoolean) 
		! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
setSelectionStateFor: anIndex at: aBoolean

	^ self model setSelectionStateFor: anIndex at: aBoolean! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
backgroundColorFor: anItem at: index

	^ self model backgroundColorFor: anItem at: index! !

!MorphicListAdapter methodsFor: 'widget API' stamp: ''!
backgroundColorFor: anItem

	^ self model backgroundColorFor: anItem! !

!MorphicMenuAdapter commentStamp: ''!
I am the adapter used to build a MenuMorph from a MenuPresenter!
!MorphicMenuAdapter methodsFor: 'private' stamp: ''!
buildWidget

	^ ToolDockingBarMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		adoptMenuModel: self model
		yourself! !

!MorphicMenuAdapter methodsFor: 'private' stamp: ''!
basicMenuPopUp

	^  MenuMorph new
		addIfNeededTitle: self title andIcon: self icon! !

!MorphicMenuAdapter methodsFor: 'protocol' stamp: ''!
menuGroups
	^ self model menuGroups reject: [ :e | e isEmpty ]! !

!MorphicMenuAdapter methodsFor: 'protocol' stamp: ''!
icon

	^ self model icon! !

!MorphicMenuAdapter methodsFor: 'initialization' stamp: ''!
adaptAsPopup: aComposablePresenter

	model := aComposablePresenter.
	aComposablePresenter addDependent: self.
	widget := self buildWidgetPopup.! !

!MorphicMenuAdapter methodsFor: 'private' stamp: ''!
buildWidgetPopup
	widget := self basicMenuPopUp.
	self menuGroups
		do: [ :group | 
			| items |
			items := group buildWithSpec.
			items do: [ :item | widget addMorphBack: item ] ]
		separatedBy: [ widget addLine ].
	^ widget! !

!MorphicMenuAdapter methodsFor: 'spec protocol' stamp: ''!
openAt: aPoint 

	self widgetDo: [ :w | w invokeAt: (aPoint + (2@7)) in: self currentWorld allowKeyboard: true ]! !

!MorphicMenuAdapter methodsFor: 'protocol' stamp: ''!
title

	^ self model title! !

!MorphicMenuAdapter class methodsFor: 'instance creation' stamp: ''!
adaptAsPopup: aComposablePresenter
	^ self new
		adaptAsPopup: aComposablePresenter;
		yourself! !

!MorphicMenuGroupAdapter commentStamp: ''!
I am used to compute a MenuGroupPresenter.
There is not Morphic representation of a MenuGroup, that is why I do not have a coresponding morph.!
!MorphicMenuGroupAdapter methodsFor: 'protocol' stamp: ''!
menuItems
	
	^ self model menuItems! !

!MorphicMenuGroupAdapter methodsFor: 'private' stamp: ''!
buildWidget

	^ self menuItems collect: [ :each | each buildWithSpec ]! !

!MorphicMenuItemAdapter commentStamp: ''!
I am the bridge between a MenuItemPresenter and a ToggleMenuItemMorph!
!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
action

	^ self model action! !

!MorphicMenuItemAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ self autoRefresh
		ifTrue: [ self buildWidgetAutoRefresh ]
		ifFalse: [ self buildWidgetNoRefersh ]! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
balloonText
	| balloonText | 
	
	balloonText := self model description.
	balloonText ifNil: [ ^ nil ].
	
	^ (balloonText isBlock or: [ balloonText isMessageSend ])
		ifTrue: [ balloonText cull: self model ]
		ifFalse: [ balloonText ]! !

!MorphicMenuItemAdapter methodsFor: 'factory' stamp: ''!
buildWidgetAutoRefresh
	^ UpdatingMenuItemMorph new
		target: self;
		balloonTextSelector: #balloonText;
		subMenuSelector: #subMenu;
		nameSelector: #name;
		selector: #performMenuActionWith:;
		argumentsBlock: self actionArguments;
		getStateSelector: #state;
		iconSelector: #icon;
		enablementSelector: #enabled;
		keyText: self shortcutText;
		yourself! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
performMenuActionWith: arguments

	^ self model performMenuActionWith: arguments! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
autoRefresh
	| autoRefresh | 
	
	autoRefresh := self model autoRefresh.
	
	^ (autoRefresh isBlock or: [ autoRefresh isMessageSend ])
		ifTrue: [ autoRefresh cull: self model ]
		ifFalse: [ autoRefresh ]! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
enabled
	| enabled | 
	
	enabled := self model enabled.
	
	^ (enabled isBlock or: [ enabled isMessageSend ])
		ifTrue: [ enabled cull: self model ]
		ifFalse: [ enabled ]! !

!MorphicMenuItemAdapter methodsFor: 'factory' stamp: ''!
buildWidgetNoRefersh
	^ ToggleMenuItemMorph new
		contents: self name;
		target: self;
		selector: #performMenuActionWith:;
		subMenu: self subMenu;
		argumentsBlock: self actionArguments;
		getStateSelector: self stateSelector;
		icon: self icon;
		enablementSelector: #enabled;
		balloonText: self balloonText;
		keyText: self shortcutText;
		yourself! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
icon
	| icon | 
	
	icon := self model icon.
	
	^ (icon isBlock or: [ icon isMessageSend ])
		ifTrue: [ icon cull: self model ]
		ifFalse: [ icon ]! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
name
	| name | 
	
	name := self model name.
	
	^ (name isBlock or: [ name isMessageSend ])
		ifTrue: [ name cull: self model ]
		ifFalse: [ name ]! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
shortcut
	| shortcut | 
	
	shortcut := self model shortcut.
	
	^ (shortcut isBlock or: [ shortcut isMessageSend ])
		ifTrue: [ shortcut cull: self model ]
		ifFalse: [ shortcut ]! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
shortcutText
	| shortcut platform string |
	
	shortcut := self shortcut.
	shortcut isString ifTrue: [ shortcut := self defaultModifierShortcut ].
	shortcut ifNil: [ ^ nil ].
	platform := Smalltalk os platformFamily.
	shortcut combinationsDo: [ :each | (each platform = Smalltalk os platformFamily) ifTrue: [ shortcut := each ] ].
	
	string := '⌘⇧'.
	
	^ (platform =  #MacOSX and: [ 
		(StandardFonts menuFont hasGlyphsForAll: string) and: [
		string allSatisfy: [ :c | (StandardFonts menuFont characterFormAt: c) width~= 0 ]]])
		ifFalse: [ shortcut shortcut printString ]
		ifTrue: [ String streamContents: [:stream | shortcut shortcut prettyPrintOn: stream ] ]! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
state
	| state | 
	
	state := self model state.
	
	^ (state isBlock or: [ state isMessageSend ])
		ifTrue: [ state cull: self model ]
		ifFalse: [ state ]! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
actionArguments

	^ [ Array with: self ]! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
stateSelector
	^ self state ifNotNil: [ #state ]! !

!MorphicMenuItemAdapter methodsFor: 'private' stamp: ''!
defaultModifierShortcut
	
	^ self shortcut first isUppercase
		ifTrue: [ OSPlatform current defaultModifier + KMModifier shift + self shortcut first ]
		ifFalse: [ OSPlatform current defaultModifier + self shortcut first ]! !

!MorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
subMenu
	| subMenu | 
	
	subMenu := self model subMenu.
	subMenu ifNil: [ ^ nil ].
	
	^ (subMenu isBlock or: [ subMenu isMessageSend ])
		ifTrue: [ subMenu cull: self model ]
		ifFalse: [ subMenu buildWithSpecAsPopup ]! !

!MorphicModel commentStamp: ''!
MorphicModels are used to represent structures with state and behavior as well as graphical structure.  A morphicModel is usually the root of a morphic tree depicting its appearance.  The tree is constructed concretely by adding its consituent morphs to a world.

When a part is named in a world, it is given a new slot in the model.  When a part is sensitized, it is named, and a set of mouse-driven methods is also generated in the model.  These may be edited to induce particular behavior.  When a variable is added through the morphic world, it is given a slot in the model, along with a set of access methods.

In addition for public variables (and this is the default for now), methods are generated and called in any outer model in which this model gets embedded, thus propagating variable changes outward.!
!MorphicModel class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!MorphicMultiColumnListAdapter commentStamp: ''!
I am the adapter used to bridge a MultiColumnListPresenter and a PluggableMultiColumnListMorph!
!MorphicMultiColumnListAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ PluggableMultiColumnListMorph new
		wrapSelector: #wrapItem:index:;
		model: self;
		getListSizeSelector: #listSize;
		getIndexSelector: #getIndex;
		setIndexSelector: #setIndex:;
		getSelectionListSelector: #getSelectionStateFor:;
		setSelectionListSelector: #setSelectionStateFor:at:;
		getListElementSelector: #listElementAt:;
		resetListSelector: #resetListSelection;
		getMenuSelector: #menu:shifted:;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		setMultipleSelection: self multiSelection;
		setBalloonText: self help;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		yourself! !

!MorphicRadioButtonAdapter commentStamp: ''!
I am the adapter used to link a RadioButtonPresenter with a CheckboxMorph (which can also act as a radio button)!
!MorphicRadioButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ CheckboxMorph new
		on: self selected: #state changeSelected: #state:;
		getEnabledSelector: #enabled;
		label: self label;
		labelClickable: self labelClickable;
		beRadioButton;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		setBalloonText: self help;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		yourself! !

!MorphicRadioButtonAdapter methodsFor: 'widget API' stamp: ''!
state: aBoolean

	^ self model state: aBoolean! !

!MorphicRadioButtonAdapter methodsFor: 'widget API' stamp: ''!
labelClickable

	^ self model labelClickable! !

!MorphicRadioButtonAdapter methodsFor: 'widget API' stamp: ''!
state

	^ self model state! !

!MorphicRadioButtonAdapter methodsFor: 'widget API' stamp: ''!
label

	^ self model label! !

!MorphicRenderLoop methodsFor: 'initialize-release' stamp: ''!
doOneCycleWhile: aBlock

	[ aBlock value ] whileTrue: [ 
		self doOneCycle.
		"Collaborate with other processes in the same priority"
		Processor yield. ]! !

!MorphicRenderLoop methodsFor: 'initialize-release' stamp: ''!
doOneCycle

	WorldMorph doOneCycle! !

!MorphicRenderLoop methodsFor: 'deferred message' stamp: ''!
defer: aValuable

	WorldState addDeferredUIMessage: aValuable! !

!MorphicShortcutHandler commentStamp: ''!
I am a null shortcut handler for morphic. I register myself as a tool to be replaced by somebody else who really wants to handle shortcuts.!
!MorphicShortcutHandler methodsFor: 'shortcut-handling' stamp: ''!
handleKeystroke: aKeystrokeEvent inMorph: aMorph

	"I do nothing. I'm a null object"! !

!MorphicShortcutHandler class methodsFor: 'tools' stamp: ''!
registerToolsOn: aToolRegistry
	"commente out as Smalltalk resetTools might register this handler and break keybindings"
	"aToolRegistry register: self new as: #shortcuts"! !

!MorphicSliderAdapter commentStamp: ''!
I am the adapter used to bridget a SliderPresenter and a PluggableSliderMorph!
!MorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
value: aValue

	^ self model value: aValue! !

!MorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
absoluteValue: aFloat

	^ self model absoluteValue: aFloat! !

!MorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
absoluteValue

	^ self model absoluteValue! !

!MorphicSliderAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ PluggableSliderMorph new
		model: self;
		getValueSelector: #value;
		setValueSelector: #value:;
		value: self absoluteValue;
		getLabelSelector: #label;
		max: self max;
		min: self min;
		quantum: self quantum;
		setBalloonText: self help;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		yourself! !

!MorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
min

	^ self model min! !

!MorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
value

	^ self model value! !

!MorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
quantum

	^ self model quantum! !

!MorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
label

	^ self model label! !

!MorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
max

	^ self model max! !

!MorphicTabAdapter commentStamp: ''!
I am the adapter used to bridge a TabPresenter and a Tab!
!MorphicTabAdapter methodsFor: 'updating' stamp: ''!
bindModel: aTabModel andWidget: aWidget
	"bind change propagation between Spec TabPresenter and Morphic Tab"

	aWidget when: #tabSelected send: #tabSelected to: aTabModel.
	aTabModel actionsHolder whenChangedDo: [ :new | aWidget actions: new ].
	aTabModel closeableHolder whenChangedDo: [ :new | aWidget closeable: new ].
	aTabModel iconHolder whenChangedDo: [ :new | aWidget icon: new ].
	aTabModel labelHolder whenChangedDo: [ :new | aWidget label: new ].
	aTabModel menuHolder whenChangedDo: [ :new | aWidget menu: new ].
	aTabModel morphHolder whenChangedDo: [ :new | aWidget morph: new ].
	aTabModel retrievingBlockHolder whenChangedDo: [ :new | aWidget retrievingBlock: new ].
	aTabModel selectedHolder whenChangedDo: [ :new | aWidget selected: new ]! !

!MorphicTabAdapter methodsFor: 'factory' stamp: ''!
buildWidgetWith: aTabModel
	^ TabMorph new
		model: aTabModel;
		label: aTabModel label;
		icon: aTabModel icon;
		retrievingBlock: aTabModel retrievingBlock;
		morph: aTabModel contents;
		menu: aTabModel menu;
		closeable: aTabModel closeable;
		setActionsFrom: [ aTabModel actions ];
		yourself! !

!MorphicTabAdapter methodsFor: 'initialization' stamp: ''!
adapt: aComposablePresenter
	widget := self buildWidgetWith: aComposablePresenter.
	aComposablePresenter addDependent: widget.
	self bindModel: aComposablePresenter andWidget: widget! !

!MorphicTabManagerAdapter commentStamp: ''!
I am the adapter used to bridge a TabManagerPresenter and a TabManager!
!MorphicTabManagerAdapter methodsFor: 'widget API' stamp: ''!
tabSelected: aTab

	self model selectedTab: aTab model! !

!MorphicTabManagerAdapter methodsFor: 'spec protocol' stamp: ''!
addTab: aTab
	self widgetDo: [ :w | w addTab: (self buildTab: aTab) ]! !

!MorphicTabManagerAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ TabManagerMorph new
		model: self model;
		setTabs: self getTabs;
		when: #tabSelected send: #tabSelected: to: self;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		yourself! !

!MorphicTabManagerAdapter methodsFor: 'widget API' stamp: ''!
tabDeleted: aTab
	"Tab removal notification triggered from Morphic world."

	self model basicRemoveTab: aTab model! !

!MorphicTabManagerAdapter methodsFor: 'factory' stamp: ''!
buildTab: aTab
	^ aTab buildWithSpec
		when: #tabDeleted send: #tabDeleted: to: self;
		yourself! !

!MorphicTabManagerAdapter methodsFor: 'widget API' stamp: ''!
getTabs
	^ [ (self model tabs collect: [ :each | self buildTab: each ]) collect: #asWidget ]! !

!MorphicTabManagerAdapter methodsFor: 'spec protocol' stamp: ''!
removeTab: aTab
	"In Morphic, Tab removal is triggered on Tab, on TabManager."

	aTab widget delete! !

!MorphicTableContainerAdapter commentStamp: ''!
I am the adapter providing container with table layout
!
!MorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
width: aNumber
	self hRigid.
	self widgetDo: [ :w | w width: aNumber ].! !

!MorphicTableContainerAdapter methodsFor: 'spec protocol' stamp: ''!
centerWidget: aWindow
	self widgetDo: [ :w | w centerWidget: aWindow ]! !

!MorphicTableContainerAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ PanelMorph new
		layoutPolicy: TableLayout new;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		yourself! !

!MorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
layoutProperties: props
	self widgetDo: [ :w | w layoutProperties: props ]! !

!MorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
minHeight: aNumber
	self widgetDo: [ :w | w minHeight: aNumber ]! !

!MorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
height: aNumber
	self vRigid.
	self widgetDo: [ :w | w height: aNumber ].! !

!MorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
isRedrawable
	"This must be overriden in the adapter representing your container"
	
	^ true! !

!MorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
minWidth: aNumber
	self widgetDo: [ :w | w minWidth: aNumber ]! !

!MorphicTextAdapter commentStamp: ''!
I am the adapter used to bridge a TextPresenter and a PluggableTextMorph!
!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
accept: aText notifying: aNotifyier

	self model accept: aText notifying: aNotifyier! !

!MorphicTextAdapter methodsFor: 'protocol - shout' stamp: ''!
isAboutToStyle

	^ self model isAboutToStyle! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
selectedBehavior

	^ self model selectedBehavior! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
selectFrom: nodeStart to: nodeStop
	self widget selectFrom: nodeStart to: nodeStop! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
setScrollValue: aValue
	self
		widgetDo: [ :w | 
			w scrollPane
				hScrollbarValue: aValue x;
				vScrollbarValue: aValue y;
				updateScrollbars ]! !

!MorphicTextAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| newWidget |
	newWidget := RubPluggableTextMorph new
		on: self
			text: #getText
			accept: #accept:notifying:
			readSelection: #readSelection
			menu: #codePaneMenu:shifted:
			setSelection: #setSelection:;
		beWrapped;
		enabled: self enabled;
		askBeforeDiscardingEdits: self askBeforeDiscardingEdits;
		autoAccept: self autoAccept;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		setBalloonText: self help;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		registerScrollChanges: #scrollValueChanged:;
		yourself.
	self setEditingModeFor: newWidget withBehavior: self behavior.
	^ newWidget! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
hasEditingConflicts: aBoolean
 
	self widgetDo: [ :w | w hasEditingConflicts: aBoolean ]! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
codePaneMenu: aMenu shifted: shifted 

	^ self model codePaneMenu: aMenu shifted: shifted ! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
doItReceiver

	^ self model doItReceiver! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
hasUnacceptedEdits: aBoolean

	self model hasUnacceptedEdits: aBoolean! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
selectAll
	self widgetDo: [ :w | w selectAll ]! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
accept
	"We use RubScrolledTextMorph>>#acceptContents but we keep accept as method name for compatibility"
	self widgetDo: [ :w | w acceptContents ]! !

!MorphicTextAdapter methodsFor: 'accessing' stamp: ''!
interactionModel
	^ self! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
autoAccept

	^ self model autoAccept! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
autoAccept: aBoolean

	^ self model autoAccept: aBoolean! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
getText

	^ self model text! !

!MorphicTextAdapter methodsFor: 'private - shout' stamp: ''!
okToStyle

	^ true! !

!MorphicTextAdapter methodsFor: 'NOCompletion' stamp: ''!
receiverClass

	^ self behavior! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
setSelection: interval

	self model setSelectionInterval: interval! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
clearUserEditFlag

	self model text: self getText.
	self changed: #clearUserEdits! !

!MorphicTextAdapter methodsFor: 'accessing' stamp: ''!
announcer
	^ self model announcer

	! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
askBeforeDiscardingEdits

	^ self model askBeforeDiscardingEdits! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
pendingText: aText

	self widgetDo: [ :w | 
		w setText: aText.
		w hasUnacceptedEdits: true ]! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
doItContext

	^ self model doItContext! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
askBeforeDiscardingEdits: aBoolean
	self widget askBeforeDiscardingEdits: aBoolean! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
readSelection

	^ self model readSelection! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
scrollValueChanged: aValue

	self model scrollValue: aValue step! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
shoutAboutToStyle: aMorph
	
	^ self model isAboutToStyle! !

!MorphicTextAdapter methodsFor: 'NOCompletion' stamp: ''!
selectedClassOrMetaClass

	^ self behavior! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
wantsVisualFeedback

	^ self model wantsVisualFeedback! !

!MorphicTextAdapter methodsFor: 'accessing' stamp: ''!
editingMode 

	^ self widget editingMode! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
font: aFont
	self widgetDo: [ :w | w font: aFont ]! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
setSelectionFromModel: aSelection

	self widget ifNotNil: [:w | w setSelection: aSelection ]! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
notify: errorMessage at: position in: sourceCode

	self widgetDo: [ :w | w notify: errorMessage at: position in: sourceCode ]! !

!MorphicTextAdapter methodsFor: 'undo-redo' stamp: ''!
clearUndoManager
	self widget clearUndoManager! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
pendingText

	^ self widgetDo: [ :w | w text ]! !

!MorphicTextAdapter methodsFor: 'private' stamp: ''!
setEditingModeFor: textArea withBehavior: behavior
	behavior
		ifNil:
			[
			self isForSmalltalkCode
				ifTrue: [ textArea beForSmalltalkScripting ]
				ifFalse: [ textArea beForPlainText ] ]
		ifNotNil: [ :class | 
			textArea
				beForSmalltalkCodeInClass: class ]! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
canChangeText
	^ self widget textArea canChangeText! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
classOrMetaClass: aClass
	self setEditingModeFor: self widget withBehavior: aClass! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
isForSmalltalkCode
	^ self model isForSmalltalkCode! !

!MorphicTextAdapter methodsFor: 'accessing' stamp: ''!
acceptAllowed
	^self widget editingMode acceptAllowed! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
setHasUnacceptedEdits: aBoolean

	self widgetDo: [ :w | w basicHasUnacceptedEdits: aBoolean ]! !

!MorphicTextAdapter methodsFor: 'spec protocol' stamp: ''!
selectionInterval
	^ self widget selectionInterval ! !

!MorphicTextAdapter methodsFor: 'widget API' stamp: ''!
behavior

	^ self model behavior! !

!MorphicTextAdapter class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MorphicTextAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MorphicTextAdapter class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MorphicTextAdapter class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MorphicTextAdapter class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MorphicTextAdapter class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MorphicTextAdapter class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MorphicTextAdapter class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MorphicTextAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MorphicTextAdapter class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MorphicTextAdapter class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MorphicTextAdapter class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MorphicTextAdapter class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MorphicTextAdapter class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MorphicTextAdapter class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MorphicTextAdapter class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MorphicTextAdapter class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MorphicTextAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MorphicTextAdapter class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MorphicTextAdapter class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MorphicTextAdapter class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MorphicTextAdapter class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MorphicTextAdapter class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MorphicTextAdapter class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MorphicTextAdapter class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MorphicTextAdapter class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MorphicTextAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MorphicTextAdapter class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MorphicTextAdapter class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MorphicTextInputFieldAdapter commentStamp: ''!
I am the adapter used to bridge a TextInputFieldPresenter and a PluggableTextFieldMorph!
!MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: ''!
entryCompletion

	^ self model entryCompletion! !

!MorphicTextInputFieldAdapter methodsFor: 'spec protocol' stamp: ''!
encrypted: aBoolean

	self widgetDo: [ :w | 
		w encrypted: aBoolean.
		w changed ]! !

!MorphicTextInputFieldAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| plu |
	plu := RubTextFieldMorph new
		on: self
			text: #getText
			accept: #accept:
			readSelection: nil
			menu: nil
			setSelection: #setSelection:.
	plu
		entryCompletion: self entryCompletion;
		autoAccept: self autoAccept;
		ghostText: self ghostText;
		enabled: self enabled;
		encrypted: self encrypted;
		setBalloonText: self help;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		acceptOnCR: self acceptOnCR.
	
	self model whenTextChanged: [ plu setText: self model getText].
		
	^ plu! !

!MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: ''!
encrypted

	^ self model encrypted! !

!MorphicTextInputFieldAdapter methodsFor: 'initialization' stamp: ''!
adapt: aModel
	
	super adapt: aModel.
	aModel whenBuiltDo: [ :w | w widget color: self theme backgroundColor ]! !

!MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: ''!
ghostText: aText

	^ self model ghostText: aText! !

!MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: ''!
accept: aText

	self model accept: aText! !

!MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: ''!
acceptOnCR

	^ self model acceptOnCR! !

!MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: ''!
ghostText

	^ self model ghostText! !

!MorphicTickingWindowAdapter commentStamp: ''!
I am the adapter used to bridge a TickingWindowPresenter and a TickingSpecWindow!
!MorphicTickingWindowAdapter methodsFor: 'stepping' stamp: ''!
step
	self model step! !

!MorphicTickingWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ TickingSpecWindow new
			model: self;
			isResizeable: self isResizeable;
			yourself! !

!MorphicTransferAdapter commentStamp: ''!
I am a morphic specific adapter used to build a transfer object during a drang and drop operation!
!MorphicTransferAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecTransferMorph new
		model: self;
		passenger: self passenger;
		source: self source;
		yourself! !

!MorphicTransferAdapter methodsFor: 'widget API' stamp: ''!
source

	^ [ self model source ]! !

!MorphicTransferAdapter methodsFor: 'widget API' stamp: ''!
passenger

	^ [ self model passenger ]! !

!MorphicTransform commentStamp: ''!
This class implements simple translation, scaling and rotation for points, as well as inverse transformations.  These transformations are used in TransformMorphs (clipping scrollers) and TransformationMorphs (general flex-morph wrappers) to map, eg, global mouse coords into local coords, and to invert, eg, local damage rectangles into global damage rectangles.!
!MorphicTransform methodsFor: 'accessing' stamp: ''!
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' stamp: ''!
withOffset: aPoint
	^ self copy setOffset: aPoint! !

!MorphicTransform methodsFor: 'private' stamp: ''!
setOffset: aPoint 
	offset := aPoint! !

!MorphicTransform methodsFor: 'converting' stamp: ''!
asMatrixTransform2x3
	^((MatrixTransform2x3 withRotation: angle radiansToDegrees negated) composedWithLocal:
		(MatrixTransform2x3 withScale: scale))
			offset: offset negated! !

!MorphicTransform methodsFor: 'testing' stamp: ''!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."

	^ angle = 0.0 and: [scale = 1.0]! !

!MorphicTransform methodsFor: 'initialize' stamp: ''!
setIdentiy
	scale := 1.0.
	offset := 0 @ 0.
	angle := 0.0! !

!MorphicTransform methodsFor: 'testing' stamp: ''!
isMorphicTransform
	^true! !

!MorphicTransform methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(;
		nextPutAll:'angle = '; print: angle;
		nextPutAll:'; scale = '; print: scale;
		nextPutAll:'; offset = '; print: offset;
		nextPut:$).! !

!MorphicTransform methodsFor: 'private' stamp: ''!
setScale: aNumberOrPoint 
	scale := aNumberOrPoint! !

!MorphicTransform methodsFor: 'composing' stamp: ''!
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: 'testing' stamp: ''!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."

	^ self isPureTranslation and: [offset = (0@0)]! !

!MorphicTransform methodsFor: 'accessing' stamp: ''!
offset
	^ offset! !

!MorphicTransform methodsFor: 'accessing' stamp: ''!
scale
	^ scale! !

!MorphicTransform methodsFor: 'private' stamp: ''!
setAngle: radians
	angle := radians! !

!MorphicTransform methodsFor: 'transforming points' stamp: ''!
localPointToGlobal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^self invert: aPoint! !

!MorphicTransform methodsFor: 'accessing' stamp: ''!
angle
	^ angle! !

!MorphicTransform methodsFor: 'transformations' stamp: ''!
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: ''!
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: 'transformations' stamp: ''!
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: 'private' stamp: ''!
setOffset: aPoint angle: radians scale: aNumberOrPoint
	offset := aPoint.
	angle := radians.
	scale := aNumberOrPoint! !

!MorphicTransform methodsFor: 'accessing' stamp: ''!
withScale: aNumberOrPoint
	^ self copy setScale: aNumberOrPoint! !

!MorphicTransform methodsFor: 'transforming points' stamp: ''!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^self transform: aPoint! !

!MorphicTransform methodsFor: 'transformations' stamp: ''!
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: ''!
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: ''!
invertRect: aRectangle

	self error: 'method name changed to emphasize enclosing bounds'.
	^ self invertBoundsRect: aRectangle! !

!MorphicTransform methodsFor: 'accessing' stamp: ''!
withAngle: radians
	^ self copy setAngle: radians! !

!MorphicTransform methodsFor: 'converting' stamp: ''!
asMorphicTransform

	^ self! !

!MorphicTransform class methodsFor: 'instance creation' stamp: ''!
new

	^ self offset: 0@0! !

!MorphicTransform class methodsFor: 'instance creation' stamp: ''!
offset: aPoint angle: radians scale: aNumberOrPoint

	^ self basicNew setOffset: aPoint angle: radians scale: aNumberOrPoint! !

!MorphicTransform class methodsFor: 'instance creation' stamp: ''!
offset: aPoint

	^ self offset: aPoint angle: 0.0 scale: 1.0! !

!MorphicTransform class methodsFor: 'instance creation' stamp: ''!
identity

	^ self offset: 0@0 angle: 0.0 scale: 1.0! !

!MorphicTreeAdapter commentStamp: ''!
I am the adapter used to bridge a TreePresenter and a MorphTreeMorph!
!MorphicTreeAdapter methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage

	(self treeModel respondsTo: aMessage selector) 
		ifFalse: [ ^ super doesNotUnderstand: aMessage ].
		
	^ self treeModel 
		perform: aMessage selector 
		withArguments: aMessage arguments! !

!MorphicTreeAdapter methodsFor: 'spec protocol' stamp: ''!
setRoots: aCollection

	treeModel rootItems: aCollection! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
columns

	^ self model columns collect: [ :each | each buildWithSpec ]! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
isCheckList

	^ self model isCheckList! !

!MorphicTreeAdapter methodsFor: 'spec protocol' stamp: ''!
onMorphTreeSelectionChanged: ann
	| items |
	items := (ann selection
		ifNil: [ #() ]
		ifNotNil: [:selection | selection selectedNodes ]).
	items := items collect: [ :each | each nodeModel ].
	self model selectedItems: items! !

!MorphicTreeAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ MorphTreeMorph new
		model: self treeModel;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		initializeColumsFrom: self;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		autoDeselection: self autoDeselection;
		resizerWidth: self resizerWidth;
		columnInset: self columnInset;
		iconBlock: self iconBlock;
		rowInset: self rowInset;
		multiSelection: self multiSelection;
		autoMultiSelection: self autoMultiSelection;
		removeOnlyLastSelected: self selectOnlyLastHighlighted;
		isCheckList: self isCheckList;
		doubleClickSelector: #doubleClick;
		getMenuSelector: #menu:shifted:;
		rowColorForEven: self evenRowColor;
		rowColorForOdd: self oddRowColor;
		buildContents;
		yourself! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
multiSelection

	^ self model multiSelection! !

!MorphicTreeAdapter methodsFor: 'spec protocol' stamp: ''!
selectAdd

	self widgetDo: [ :w | w selectAll ]! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
evenRowColor: aColor

	^ self widget rowColorForEven: aColor! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
doubleClick

	^ self model doubleClick! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
evenRowColor

	^ self model evenRowColor! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
childrenFor: aNode

	^ self model childrenFor: aNode! !

!MorphicTreeAdapter methodsFor: 'accessing' stamp: ''!
treeModel
	^ treeModel! !

!MorphicTreeAdapter methodsFor: 'updating' stamp: ''!
changed: aSymbol

	treeModel changed: aSymbol! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
columnInset

	^ self model columnInset! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
roots

	^ self model roots! !

!MorphicTreeAdapter methodsFor: 'spec protocol' stamp: ''!
collapseAll

	self treeModel collapseAll! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
iconBlock

	^ [:each | self iconFor: each ]! !

!MorphicTreeAdapter methodsFor: 'protocol' stamp: ''!
updateTree

	self treeModel resetRootNodes.
	self treeModel changed: #rootNodes.! !

!MorphicTreeAdapter methodsFor: 'drag and drop - private' stamp: ''!
acceptDroppingMorph: draggedMorph event: event inMorph: source
	| item |
	item := self widget ifNotNil: [ :w | w scrollerSubMorphFromPoint: event position ].
	item ifNil: [ ^ self ].
	^ self acceptDropBlock
		valueWithEnoughArguments: { draggedMorph model model. event. source model model model. item model nodeModel}! !

!MorphicTreeAdapter methodsFor: 'spec protocol' stamp: ''!
expandAll

	self treeModel expandAll! !

!MorphicTreeAdapter methodsFor: 'spec protocol' stamp: ''!
filterWith: aFilter
	
	self widgetDo: [ :w || nodes |
		nodes := w model rootNodes.
		nodes do: [:r | r nodeModel updateAccordingTo: aFilter].
	
		self removeRootsSuchAs: [:n | (aFilter keepTreeNode: n) not and: [n isEmpty]].

		self changed: #rootNodes ].! !

!MorphicTreeAdapter methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.

	treeModel := SpecTreeModel model: self.	
	treeModel announcer
		when: MorphTreeSelectionChanged
		send: #onMorphTreeSelectionChanged:
		to: self.! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
selectOnlyLastHighlighted

	^ self model selectOnlyLastHighlighted! !

!MorphicTreeAdapter methodsFor: 'accessing' stamp: ''!
rootNodeHolder

	^ self model rootNodeHolder! !

!MorphicTreeAdapter methodsFor: 'spec protocol' stamp: ''!
columns: newColumns

	self widgetDo: [ :w || columns |
		columns := newColumns collect: [ :each | each buildWithSpec ]. 
		w columns: columns.
		w resizerChanged.
		w updateList ]! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
preferedPaneColor

	^ self model preferedPaneColor! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
oddRowColor: aColor

	^ self widget rowColorForOdd: aColor! !

!MorphicTreeAdapter methodsFor: 'spec protocol' stamp: ''!
expandRoots

	self treeModel expandRoots! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
keyStroke: aKeyStroke

	^ self model keyStroke: aKeyStroke! !

!MorphicTreeAdapter methodsFor: 'spec protocol' stamp: ''!
isCheckList: aBoolean

	self widgetDo: [ :w | w isCheckList: aBoolean ]! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
menu: aMenu shifted: aBoolean

	^ (self model menu: aMenu shifted: aBoolean) 
		ifNotNil: [ :menuModel | menuModel buildWithSpecAsPopup ]! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
rootNodeFromItem: item
	| node |
	
	node := item isTreeNodeModel
		ifTrue: [ item ]
		ifFalse: [ self rootNodeHolder cull: item ].
		
	node container: self model.
	^ node buildWithSpec! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
rowInset

	^ self model rowInset! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
autoDeselection

	^ self model autoDeselection! !

!MorphicTreeAdapter methodsFor: 'spec protocol' stamp: ''!
removeRootsSuchAs: aBlock

	self widgetDo: [ :w | w model rootNodes removeAllSuchThat: [ :node | aBlock value: node nodeModel ] ]! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
autoMultiSelection

	^ self model autoMultiSelection! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
wrapItem: anItem

	^ self model wrapItem: anItem! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
resizerWidth

	^ self model resizerWidth! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
oddRowColor

	^ self model oddRowColor! !

!MorphicTreeAdapter methodsFor: 'widget API' stamp: ''!
iconFor: aNode

	^ self model iconFor: aNode! !

!MorphicTreeColumnAdapter commentStamp: ''!
I am the bridge between a TreeColumnPresenter and a MorphTreeColumn.

Ialso add support for on the fly refresh!
!MorphicTreeColumnAdapter methodsFor: 'private' stamp: ''!
headerFontChanged
	
	self widgetDo: [ :w | 
		w header label: self headerLabel font: self headerFont.
		w container resizerChanged ]! !

!MorphicTreeColumnAdapter methodsFor: 'private' stamp: ''!
resizableChanged
	
	self widgetDo: [ :w | w resizable: self resizable ]! !

!MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: ''!
headerAction

	^ self model headerAction! !

!MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: ''!
displayBlock

	^ self model displayBlock! !

!MorphicTreeColumnAdapter methodsFor: 'private' stamp: ''!
headerLabelChanged
	
	self widgetDo: [ :w | 
		w header label: self headerLabel.
		w container resizerChanged ]! !

!MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: ''!
headerFont

	^ self model headerFont! !

!MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: ''!
headerLabel

	^ self model headerLabel! !

!MorphicTreeColumnAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ SpecTreeColumn new
		resizable: self resizable;
		startWidth: self initialWidth;
		setHeaderButtonLabel: self headerLabel
			font: self headerFont
			icon: self headerIcon
			target: self
			actionSelector: self performHeaderActionSelector;
		rowMorphGetSelector: self displayBlock! !

!MorphicTreeColumnAdapter methodsFor: 'updating' stamp: ''!
update: aSymbol

	aSymbol == #displayBlockChanged ifTrue: [ ^ self displayBlockChanged ].
	aSymbol == #resizableChanged ifTrue: [ ^ self resizableChanged ].
	aSymbol == #headerLabelChanged ifTrue: [ ^ self headerLabelChanged ].
	aSymbol == #headerFontChanged ifTrue: [ ^ self headerFontChanged ].
	aSymbol == #headerIconChanged  ifTrue: [ ^ self headerIconChanged ].
	
	^ super update: aSymbol! !

!MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: ''!
performHeaderAction

	self headerAction cull: self model cull: self! !

!MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: ''!
headerIcon

	^ self model headerIcon! !

!MorphicTreeColumnAdapter methodsFor: 'private' stamp: ''!
displayBlockChanged

	self widgetDo: [ :w | 
		w rowMorphGetSelector: self displayBlock.
		w container updateList ]! !

!MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: ''!
argumentBlock

	^ [ Array with: self model ]! !

!MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: ''!
performHeaderActionSelector
	^ self headerAction ifNotNil: [ #performHeaderAction ]! !

!MorphicTreeColumnAdapter methodsFor: 'private' stamp: ''!
headerIconChanged
	
	self widgetDo: [ :w | 
		self headerIcon
			ifNil: [ w header removeIcon ]
			ifNotNil: [ w header icon: (ImageMorph new form: self headerIcon) ] ]! !

!MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: ''!
initialWidth

	^ self model initialWidth! !

!MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: ''!
resizable

	^ self model resizable! !

!MorphicTreeNodeAdapter commentStamp: ''!
I am the bridget between a TreeNodePresenter and a SpecTreeNodeModel!
!MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: ''!
childrenBlock
	^ [ self model buildChildren ]! !

!MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: ''!
hasChildrenBlock
	^ self model hasChildren! !

!MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: ''!
hasContentToShow
	^ self model hasContentToShow! !

!MorphicTreeNodeAdapter methodsFor: 'spec protocol' stamp: ''!
isExpanded: aBoolean

	! !

!MorphicTreeNodeAdapter methodsFor: 'spec protocol' stamp: ''!
selected: aBoolean

	aBoolean 
		ifTrue: [ self select ]
		ifFalse: [ self deselect ]! !

!MorphicTreeNodeAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ SpecTreeNodeModel new
		setItemFromBlock: self itemBlock;
		icon: self icon;
		setChildren: self childrenBlock;
		hasContents: self hasChildrenBlock;
		model: self container;
		nodeModel: self model! !

!MorphicTreeNodeAdapter methodsFor: 'private' stamp: ''!
select

	self widgetDo: [ :w |
		w changed: #select.
		w model selectionChanged.
		w dependents do: [ :e | e changed ] ]! !

!MorphicTreeNodeAdapter methodsFor: 'spec protocol' stamp: ''!
updateAccordingTo: aFilter

	self widgetDo: [ :w |
		w contents do: [ :n | n nodeModel updateAccordingTo: aFilter ].
		w contents removeAllSuchThat: [ :n | (aFilter keepTreeNode: n nodeModel) not  and: [ n nodeModel isEmpty ] ] ]! !

!MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: ''!
selected
	^ self model selected! !

!MorphicTreeNodeAdapter methodsFor: 'private' stamp: ''!
deselect

	self widgetDo: [ :w |
		w changed: #deselect.
		w model selectionChanged.
		w dependents do: [ :e | e changed ] ]! !

!MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: ''!
icon
	^ self model icon! !

!MorphicTreeNodeAdapter methodsFor: 'spec protocol' stamp: ''!
takeHighlight

	self widgetDo: [ :w | w changed: #takeHighlight ]! !

!MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: ''!
container
	^ self model container! !

!MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: ''!
item
	^ self model content! !

!MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: ''!
itemBlock
	^ [ self item ]! !

!MorphicUIManager commentStamp: ''!
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: 'ui requests' stamp: ''!
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: ''!
merge: merger informing: aString

	| mergeMorph  window |
	mergeMorph := PSMCMergeMorph forMerger: merger.
	mergeMorph
		fromDescription: 'Working copy' translated;
		toDescription: aString.
	window := mergeMorph newWindow
		title: aString;
		yourself.
	window openModal.
	^ mergeMorph merged! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
question: aStringOrText
	"Open a question dialog."

	^self question: aStringOrText title: 'Question' translated! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel
	"Answer a text editor for the given model."

	^self
		newTextEditorFor: aModel
		getText: getSel
		setText: setSel
		getEnabled: nil! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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: 'accessing' stamp: ''!
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 == self currentWorld
							and: [sender selector == #handleEvent:
									or: [sender selector == #findWindow:]]])
				ifTrue: [foundWorld := true]
				ifFalse: [sender := sender sender]].
	foundWorld
		ifTrue: [^ receiver world
				ifNil: [self currentWorld]].
	^ SystemWindow topWindow
		ifNil: [self currentWorld]! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newColorPresenterFor: aModel getColor: getSel help: helpText
	"Answer a color presenter with the given selectors."

	^self theme
		newColorPresenterIn: self
		for: aModel
		getColor: getSel
		help: helpText! !

!MorphicUIManager methodsFor: 'error handling' stamp: ''!
handleError: anError log: shouldLog
	shouldLog
		ifTrue: [ self logError: anError ].
	(OupsDebugRequest newForException: anError) submit.! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newSeparator
	"Answer an horizontal separator."

	^self theme
		newSeparatorIn: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newScrollPaneFor: aMorph
	"Answer a new scroll pane morph to scroll the given morph."
	
	^self theme
		newScrollPaneIn: self
		for: aMorph! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newLabelGroup: labelsAndControls
	"Answer a morph laid out with a column of labels and a column of associated controls.
	Controls having a vResizing value of #spaceFill will
	cause their row to use #spaceFill also, otherwise #shrinkWrap."

	^self theme
		newLabelGroupIn: self
		for: labelsAndControls! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newCancelButton
	"Answer a new cancel button."

	^self newCancelButtonFor: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newVerticalSeparator
	"Answer a vertical separator."

	^self theme
		newVerticalSeparatorIn: self! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
newMenuIn: aThemedMorph for: aModel
	"Answer a new menu."
	"UIManager default"
	^self theme 
		newMenuIn: aThemedMorph for: aModel! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newNoButton
	"Answer a new No button."

	^self newNoButtonFor: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newToolbar
	"Answer a toolbar."

	^self theme
		newToolbarIn: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText
	"Answer a bracket slider with the given selectors."

	^self
		newBracketSliderFor: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum 
		getEnabled: nil
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseColor
	"Answer the result of a color selector dialog ."

	^self chooseColor: Color black! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel help: helpText
	"Answer a text entry for the given model."

	^self
		newTextEntryFor: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: nil 
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a bracket slider with the given selectors."

	^self theme
		newBracketSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
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 process' stamp: ''!
terminateUIProcess
	UIProcess suspend; terminate.
	UIProcess := nil "?"! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		label: (AlphaImageMorph new image: aForm)
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseExistingFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseExistingFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText
	"Open a question dialog."

	^self questionWithoutCancel: aStringOrText title: 'Question' translated! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseColor: aColor 
	"Answer the result of a color selector dialog with the given color."

	^self theme
		chooseColorIn: self
		title: 'Colour Selector' translated
		color: aColor! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseDirectory: title 
	"Answer the result of a file dialog with the given title, answer a directory."

	^self
		chooseDirectory: title
		path: nil! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText list: aList
	"Open a drop list chooser dialog."

	^self
		chooseDropList: aStringOrText
		title: 'Choose' translated
		list: aList! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel 
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseForSaveFileReference: 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
		chooseForSaveFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector
	"Answer a new tree morph."
	
	^self theme
		newTreeIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newOKButtonFor: aModel getEnabled: enabledSel
	"Answer a new OK button."

	^self theme
		newOKButtonIn: self
		for: aModel
		getEnabled: enabledSel! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newStack
	"Answer a morph laid out as a stack."

	^self theme
		newStackIn: self
		for: #()! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newTitle: aString for: control
	"Answer a morph laid out with a column with a title."

	^self theme
		newTitleIn: self
		label: aString
		for: control! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion

	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel 
		help: helpText
		entryCompletion: anEntryCompletion! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText
	"Answer an inremental slider with the given selectors."

	^self theme
		newIncrementalSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: min
		max: max
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newOKButtonFor: aModel
	"Answer a new OK button."

	^self
		newOKButtonFor: aModel
		getEnabled: nil! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newCancelButtonFor: aModel
	"Answer a new cancel button."

	^self theme
		newCancelButtonIn: self
		for: aModel! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newSVSelector: aColor help: helpText
	"Answer a saturation-volume selector with the given color."

	^self theme
		newSVSelectorIn: self
		color: aColor
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newString: aStringOrText
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: #plain! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseFont: aFont 
	"Answer the result of a font selector dialog with the given initial font."

	^self theme
		chooseFontIn: self
		title: 'Font Selector' translated
		font: aFont! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
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: 'controls' stamp: ''!
newButtonLabel: aString
	"Answer a new button text label."

	^self
		newButtonLabelFor: nil
		label: aString
		getEnabled: nil! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString entryText: defaultEntryText
	"Open a text entry dialog."

	^self theme
		textEntryIn: self
		text: aStringOrText
		title: aString
		entryText: defaultEntryText! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
request: aStringOrText initialAnswer: defaultAnswer title: aTitle
	"Create an instance of me whose question is queryString with the given 
	initial answer. Answer the string the user accepts.
	The title serves for the window that is opened
	Answer the empty string if the user cancels.
	Allow for interception with a ProvideAnswerNotification handler."
	
	|modalMorph|
	(ProvideAnswerNotification signal: aStringOrText) ifNotNil: [:answer |
		^answer == #default ifTrue: [defaultAnswer] ifFalse: [answer]].
	modalMorph := self modalMorph.
	^(modalMorph theme 
		textEntryIn: modalMorph
		text: aStringOrText
		title: aTitle
		entryText: defaultAnswer)! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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: 'ui process' stamp: ''!
defer: aValuable
	"aValuable will be executed in the next UI rendering cycle"
	WorldState defer: aValuable! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newExpander: aString for: aControl
	"Answer an expander with the given label and control."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: {aControl}! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newExpander: aString
	"Answer an expander with the given label."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: #()! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
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."
	anException debug! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newCloseButtonFor: aModel
	"Answer a new close button."

	^self theme
		newCloseButtonIn: self
		for: aModel! !

!MorphicUIManager methodsFor: 'display' stamp: ''!
showWaitCursorWhile: aBlock
	Cursor wait showWhile: aBlock! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newFuzzyLabel: aString
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: nil
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: nil! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newRow
	"Answer a morph laid out as a row."

	^self theme
		newRowIn: self
		for: #()! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newNoButtonFor: aModel
	"Answer a new No button."

	^self theme
		newNoButtonIn: self
		for: aModel! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a morph list for the given model."

	^self theme
		newMorphListIn: self
		for: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
onFontsChanged

	StringMorph allSubInstancesDo: [ :s | s layoutChanged ].
	TextMorph allSubInstancesDo: [ :s | s layoutChanged ].
	SystemWindow allInstancesDo: [ :w | [ w update: #relabel ] on: Error do: [ :ex | ] ].
	self currentWorld ifNotNil: [ :w | w changed ].! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newYesButton
	"Answer a new Yes button."

	^self newYesButtonFor: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newHSVSelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVSelectorIn: self
		color: aColor
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: nil
		help: helpText! !

!MorphicUIManager methodsFor: 'debug' stamp: ''!
debugProcess: process context: context label: title fullView: bool notification: notificationString

	(OupsDebugRequest newForContext: context)
		process: process;
		label: title;
		submit! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		getLabel: labelSel
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newGroupbox: aString forAll: controls
	"Answer a groupbox with the given label and controls."

	^self theme
		newGroupboxIn: self
		label: aString
		forAll: controls! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
proceed: aStringOrText
	"Open a proceed dialog."

	^self proceed: aStringOrText title: 'Proceed' translated! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newToolbarHandle
	"Answer a toolbar handle."

	^self theme
		newToolbarHandleIn: self! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
longMessage: aStringOrText title: aString
	"Open a (long) message dialog."

	^self theme
		longMessageIn: self
		text: aStringOrText
		title: aString! !

!MorphicUIManager methodsFor: 'accessing' stamp: ''!
theme  
	^ Smalltalk ui theme! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
centeredAlert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		centeredAlertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newToolDockingBar
	"Answer a tool docking bar."

	^self theme
		newToolDockingBarIn: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseColor: aColor title: title
	"Answer the result of a color selector dialog with the given title and initial colour."

	^self theme
		chooseColorIn: self
		title: title
		color: aColor! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
systemNotificationDefaultAction: aNotification

	aNotification messageText traceCr.
	aNotification resume.! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		getLabel: labelSel
		getEnabled: enabledSel! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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: 'accessing' stamp: ''!
preferredCornerStyle
	^ self theme preferredCornerStyle! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newEmbeddedMenu
	"Answer a new menu."

	^self theme
		newEmbeddedMenuIn: self
		for: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 
	"Answer a text editor for the given model."

	^self 
		newTextEditorFor: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: nil! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel 
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newGroupboxFor: control
	"Answer a plain groupbox with the given control."

	^self theme
		newGroupboxIn: self
		for: control! !

!MorphicUIManager methodsFor: 'ui process' stamp: ''!
spawnNewProcess

	UIProcess := [
		MorphicRenderLoop new doOneCycleWhile: [ true ]
	] newProcess priority: Processor userSchedulingPriority.
	UIProcess name: 'Morphic UI Process'.
	UIProcess resume! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newDialogPanel
	"Answer a new main dialog panel."

	^self theme
		newDialogPanelIn: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newImageFor: aModel get: getSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newImageIn: self
		for: aModel
		get: getSel
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newGroupbox: aString for: control
	"Answer a groupbox with the given label and control."

	^self theme
		newGroupboxIn: self
		label: aString
		for: control! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newMenuFor: aModel
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: aModel! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: enabledSel
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
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: ''!
deny: aStringOrText
	"Open a denial dialog."

	^self deny: aStringOrText title: 'Access Denied' translated! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: labelList values: valueList lines: linesArray title: aString
	"Choose an item from the given list. Answer the selected item."
	
	|modalMorph|
	
	(ProvideAnswerNotification signal: aString) ifNotNil: [:answer |
		^answer].
	
	modalMorph := self modalMorph.
	^modalMorph theme  
		chooseIn: modalMorph
		title: aString
		labels: labelList
		values: valueList
		lines: linesArray! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
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: 'handle debug requests' stamp: ''!
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."
	self flag: 'This looks like a code smell'.
	(OupsWarningRequest newForException: anException) submit! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self
		newRadioButtonFor: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newRow: controls
	"Answer a morph laid out with a row of controls."

	^self theme
		newRowIn: self
		for: controls! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		getLabel: labelSel
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newColumn: controls
	"Answer a morph laid out with a column of controls."

	^self theme
		newColumnIn: self
		for: controls! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
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: ''!
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: 'services' stamp: ''!
proceed: aStringOrText title: aString
	"Open a proceed dialog and answer true if not cancelled, false otherwise."

	^self theme
		proceedIn: self
		text: aStringOrText
		title: aString! !

!MorphicUIManager methodsFor: '*Files-Prompt' stamp: ''!
fileExistsDefaultAction: anException
	| file choice |
	
	file := anException file.
	choice := self chooseFrom: {
		'overwrite that file'.
		'choose another name'.
		'cancel'
	} title: file name, ' already exists.'.
 
	choice = 1 ifTrue: [
		file delete.
		file ifExists: [ self error: 'Could not delete the old version of that file' ].
		^ file ].

	choice = 2 ifTrue: [ | newName newFile |
		newName := self request: 'Enter a new file name' initialAnswer: file name.
		newName ifNil: [ Abort signal ].
		newFile := File named: newName.
		^ newFile checkDoesNotExist ].

	Abort signal: 'Please close this to abort file opening'! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseFrom: aList lines: linesArray message: messageString title: aString
	"Choose an item from the given list. Answer the selected item."
	
	^(self
		chooseFrom: aList
		values: nil
		lines: linesArray
		message: messageString
		title: aString) ifNil: [0]! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newCloseButton
	"Answer a new close button."

	^self newCloseButtonFor: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newImage: aForm size: aPoint
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm
		size: aPoint! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
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: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		useIndex: true
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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: 'private' stamp: ''!
deactivate
	activeTranscript := Transcript.
	SystemProgressMorph disable.
	
	self triggerEvent: #aboutToLeaveWorld.
	WorldMorph extraWorldList do: [:world | world triggerEvent: #aboutToLeaveWorld ].	
	
	self currentWorld worldState worldRenderer: (NullWorldRenderer forWorld: self currentWorld).! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		icon: iconSelector
		getEnabled: enabledSel
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newAlphaImage: aForm help: helpText
	"Answer an alpha image morph."

	^self theme
		newAlphaImageIn: self
		image: aForm
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText
	"Answer a morph list for the given model."

	^self
		newMorphListFor: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: nil
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
deny: aStringOrText title: aString
	"Open a denial dialog."

	^self theme
		denyIn: self
		text: aStringOrText
		title: aString! !

!MorphicUIManager methodsFor: 'events' stamp: ''!
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)]]].
	Stdio stderr << message.
	"init hands and redisplay" 
	self currentWorld install! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
message: aStringOrText title: aString
	"Open a message dialog."

	^self theme
		messageIn: self
		text: aStringOrText
		title: aString! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newString: aStringOrText style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: aStyle! !

!MorphicUIManager methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
inform: aStringOrText actionOnClick: aBlock
	"Display a message for the user to read and then dismiss. When clicked, execute an action."

	(ProvideAnswerNotification signal: aStringOrText) ifNotNil: [ :answer | ^ true ].
	(GrowlMorph openWithLabel: 'Information' translated contents: aStringOrText)
		vanishDelay: 2 second;
		actionBlock: aBlock! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: #bottomLeft! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
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: ''!
restoreDisplay

	self currentWorld fullRepaintNeeded! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newImage: aForm
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newStack: controls
	"Answer a morph laid out with a stack of controls."

	^self theme
		newStackIn: self
		for: controls! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newGroupboxForAll: controls
	"Answer a plain groupbox with the given controls."

	^self theme
		newGroupboxIn: self
		forAll: controls! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
message: aStringOrText
	"Open a message dialog."

	^self message: aStringOrText title: 'Information' translated! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText
	"Answer a list for the given model."

	^self
		newListFor: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: nil
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
textEntry: aStringOrText
	"Open a text entry dialog."

	^self textEntry: aStringOrText title: 'Entry' translated! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newYesButtonFor: aModel
	"Answer a new yes button."

	^self theme
		newYesButtonIn: self
		for: aModel! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title for: contentMorph
	"Answer a new pluggable dialog with the given content."

	^self theme
		newPluggableDialogWindowIn: self
		title: title
		for: contentMorph! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title
	"Answer a new pluggable dialog with the given content."

	^self
		newPluggableDialogWindow: title
		for: nil! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: aClass
		default: defaultValue
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText
		entryCompletion: anEntryCompletion! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newGroupbox: aString
	"Answer a groupbox with the given label."

	^self theme
		newGroupboxIn: self
		label: aString! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
edit: aText label: labelString accept: aBlockOrNil
	"Open an editor on the given string/text"
	
	| window pane |
	window := (SystemWindow labelled: labelString) model: self.
	pane := RubScrolledTextMorph new 
				setText: aText asString;
				yourself.
	aBlockOrNil ifNotNil: [  
		pane announcer when: RubTextAcceptRequest do: [:aRequest | aBlockOrNil value: aRequest morph text]].	
	window addMorph: pane frame: (0@0 corner: 1@1); openInWorld.
	^ window! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseFont
	"Answer the result of a font selector dialog."

	^self chooseFont: nil! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newExpander: aString forAll: controls
	"Answer an expander with the given label and controls."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: controls! !

!MorphicUIManager methodsFor: 'debug' stamp: ''!
lowSpaceWarningMessage
	"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!!).

'! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
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: 'services' stamp: ''!
enterOrRequestFrom: aList lines: linesArray title: aString
	"Choose an item from the given list. 
	 Answer the value selected of the selected item or the new string entered."
	
	^self
		enterOrRequestFrom: aList
		values: aList
		lines: linesArray
		title: aString! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel ghostText: ghostText getEnabled: enabledSel help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: String
		default: ''
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: false
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newWindowFor: aModel title: titleString
	"Answer a new window morph."
	
	^self theme
		newWindowIn: self
		for: aModel
		title: titleString! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
confirm: aStringOrText
	"Put up a question dialog (without cancel).
	Answer true if the response is yes, false if no.
	This is a modal question--the user must respond yes or no."
	
	^ self confirm: aStringOrText label: 'Question' translated.! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newToolbar: controls
	"Answer a toolbar with the given controls."

	^self theme
		newToolbarIn: self
		for: controls! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newToolSpacer
	"Answer a tool spacer."

	^self theme
		newToolSpacerIn: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector
	"Answer a text editor for the given model."

	^self theme
		newTextEditorIn: self
		for: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: menuSelector! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newButtonLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new button text label."

	^self theme
		newButtonLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
chooseOrRequestFrom: aList title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	^self chooseOrRequestFrom: aList lines: #() title: aString! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString
	"Open an alert dialog."

	^self
		alert: aStringOrText
		title: aString
		configure: [:d | ]! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
restoreDisplayAfter: aBlock

	aBlock value.
	self currentWorld activeHand waitButton.
	self currentWorld fullRepaintNeeded.! !

!MorphicUIManager methodsFor: 'handle debug requests' stamp: ''!
handleWarningDebugRequest: aWarningDebugRequest fromDebuggerSystem: anOupsDebuggerSystem
	<debuggerCompleteToSender>
	anOupsDebuggerSystem openDebuggerOnRequest: aWarningDebugRequest! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newTabGroup: labelsAndPages
	"Answer a tab group with the given tab labels associated with pages."

	^self theme
		newTabGroupIn: self
		for: labelsAndPages! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: cornerSymbol! !

!MorphicUIManager methodsFor: 'ui process' stamp: ''!
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: 'services' stamp: ''!
chooseForSaveFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseForSaveFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow
	"Answer a new pluggable dialog."

	^self
		newPluggableDialogWindow: 'Dialog'! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
request: aStringOrText initialAnswer: defaultAnswer entryCompletion: anEntryCompletion
	^ self request: aStringOrText initialAnswer: defaultAnswer title: 'Information Required' translated entryCompletion: anEntryCompletion! !

!MorphicUIManager methodsFor: 'ui process' stamp: ''!
resumeUIProcess: aProcess
	"Adopt aProcess as the project process -- probably because of proceeding from a debugger"
			
	UIProcess := aProcess.
	UIProcess resume! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
confirm: queryString label: title 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: title! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseExistingFileReference: 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
		chooseExistingFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self theme
		newRadioButtonIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
question: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionIn: self
		text: aStringOrText
		title: aString! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
enterOrRequestFrom: aList title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	^self enterOrRequestFrom: aList lines: #() title: aString! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
currentWorld

	ActiveWorld ifNotNil: [ ^ ActiveWorld ].
	^ World! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
abort: aStringOrText title: aString
	"Open an error dialog."

	^self theme
		abortIn: self
		text: aStringOrText
		title: aString! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		alertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText
		entryCompletion: anEntryCompletion! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
chooseDropList: aStringOrText title: aString list: aList
	"Open a drop list chooser dialog."

	^self theme
		chooseDropListIn: self
		text: aStringOrText
		title: aString
		list: aList! !

!MorphicUIManager methodsFor: 'private' stamp: ''!
activate

	self currentWorld worldState worldRenderer: (AbstractWorldRenderer detectCorrectOneForWorld: self currentWorld).
	self currentWorld currentCursor: self currentWorld currentCursor.
		
	self currentWorld ifNotNil: [:world | world restoreMorphicDisplay].
	WorldMorph extraWorldList do: [:each | each restoreMorphicDisplay].

	activeTranscript 
		ifNil: [
			Transcript class == ThreadSafeTranscript ifFalse: [ 
				ThreadSafeTranscript install 
			]
		]		
		ifNotNil: [ Transcript := activeTranscript ].
		
	SystemProgressMorph enable.! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
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: 'controls' stamp: ''!
newPanel
	"Answer a new panel."

	^self theme
		newPanelIn: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a drop list for the given model."

	^self theme
		newDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
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: 'controls' stamp: ''!
newLabel: aString
	"Answer a new text label."

	^self
		newLabelFor: nil
		label: aString
		getEnabled: nil! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
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: 'handle debug requests' stamp: ''!
handleDebugRequest: aDebugRequest fromDebuggerSystem: anOupsDebuggerSystem
	<debuggerCompleteToSender>
	anOupsDebuggerSystem openDebuggerOnRequest: aDebugRequest! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newOKButton
	"Answer a new OK button."

	^self newOKButtonFor: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newMultistateButton
	"Answer a new multistate button morph.
	To be usable it needs to have fill styles assigned to various states along
	with mouse-up/down actions."
	
	^self theme
		newMultistateButtonIn: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newHueSelector: aModel getHue: getSel setHue: setSel help: helpText
	"Answer a hue selector with the given selectors."

	^self theme
		newHueSelectorIn: self
		for: aModel
		getHue: getSel
		setHue: setSel
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString
	"Open a text entry dialog."

	^self
		textEntry: aStringOrText
		title: aString
		entryText: ''! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a morph drop list for the given model."

	^self theme
		newMorphDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
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."

	^ self
		confirm: queryString
		label: 'Question' translated
		trueChoice: trueChoice
		falseChoice: falseChoice
		cancelChoice: cancelChoice
		default: defaultOption! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newGroupbox
	"Answer a plain groupbox."

	^self theme
		newGroupboxIn: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newHSVASelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVASelectorIn: self
		color: aColor
		help: helpText! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
chooseFrom: labelList values: valueList lines: linesArray message: messageString title: aString
	"Choose an item from the given list. Answer the selected item."
	
	^ self theme
		chooseIn: self modalMorph
		title: aString
		message: messageString
		labels: labelList
		values: valueList
		lines: linesArray! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newString: aStringOrText font: aFont style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: aFont
		style: aStyle! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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: 'ui requests' stamp: ''!
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: 'events' stamp: ''!
onEventSensorStartup: anEventSensor

	anEventSensor flushAllButDandDEvents! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionWithoutCancelIn: self
		text: aStringOrText
		title: aString! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
fontFromUser: priorFont	
	
	^ StrikeFont fromUser: priorFont allowKeyboard: true! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newMenu
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: self! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText
	"Answer an alpha channel selector with the given selectors."

	^self theme
		newAlphaSelectorIn: self
		for: aModel
		getAlpha: getSel
		setAlpha: setSel
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		font: aFont
		help: helpText
		entryCompletion: anEntryCompletion! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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: 'global state' stamp: ''!
world
	^ self currentWorld! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newText: aStringOrText
	"Answer a new text."

	^self theme
		newTextIn: self
		text: aStringOrText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText
	"Answer a drop list for the given model."

	^self
		newDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		useIndex: true
		help: helpText! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList lines: linesArray title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	
	^(self
		chooseFrom: aList
		values: nil
		lines: linesArray
		title: aString) ifNil: [0]! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
chooseDirectory: title path: path
	"Answer the result of a file dialog with the given title, answer a directory."

	^self theme
		chooseDirectoryIn: self
		title: title
		path: path! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
alert: aStringOrText
	"Open an alert dialog."

	^self alert: aStringOrText title: 'Alert' translated! !

!MorphicUIManager methodsFor: 'services' stamp: ''!
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: 'controls' stamp: ''!
newCloseControlFor: aModel action: aValuable help: helpText
	"Answer a new cancel button."

	^self theme
		newCloseControlIn: self
		for: aModel
		action: aValuable
		help: helpText! !

!MorphicUIManager methodsFor: 'controls' stamp: ''!
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: 'services' stamp: ''!
abort: aStringOrText
	"Open an error dialog."

	^self abort: aStringOrText title: 'Error' translated! !

!MorphicUIManager methodsFor: 'ui requests' stamp: ''!
syntaxErrorNotificationDefaultAction: anException
	"Handle a syntax error.
	Note, if there is no #syntaxErrorDebugger registered, it will be silently ignored"
	^Smalltalk tools using: #syntaxErrorDebugger do: [:tool | 
			tool open: (tool syntaxError: anException)]! !

!MorphicUIManager class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!MorphicUIManager class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!MorphicUIManager class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!MorphicUIManager class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!MorphicUIManager class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!MorphicUIManager class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!MorphicUIManager class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!MorphicUIManager class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!MorphicUIManager class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MorphicUIManager class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!MorphicUIManager class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!MorphicUIManager class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!MorphicUIManager class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!MorphicUIManager class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!MorphicUIManager class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!MorphicUIManager class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!MorphicUIManager class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!MorphicUIManager class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!MorphicUIManager class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!MorphicUIManager class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!MorphicUIManager class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!MorphicUIManager class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!MorphicUIManager class methodsFor: 'accessing' stamp: ''!
isActiveManager
	"Answer whether I should act as the active ui manager"
	^ true! !

!MorphicUIManager class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!MorphicUIManager class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!MorphicUIManager class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!MorphicUIManager class methodsFor: 'testing' stamp: ''!
isValidForCurrentSystemConfiguration

	^ Smalltalk isHeadless not 
		or: [ 
			Smalltalk isHeadless 
			and: [ Smalltalk isInteractiveGraphic ] ]! !

!MorphicUIManager class methodsFor: 'cleanup' stamp: ''!
restartMethods
   UIProcess ifNotNil: [
	| process |
	process := UIProcess.
	self new spawnNewProcess.
	process terminate. ]! !

!MorphicUIManager class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!MorphicUIManager class methodsFor: 'ui process' stamp: ''!
uiProcess 

	^ UIProcess! !

!MorphicUIManager class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!MorphicUIManager class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!MorphicUIManager class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!MorphicWindowAdapter commentStamp: ''!
I am the adapter used to bridge a WindowPresenter and a SystemWindow!
!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
isDisplayed

	^ self widget isDisplayed! !

!MorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
askOkToClose

	^ self model askOkToClose! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
addModelIn: widgetToBuild withSpec: aSpec
	
	widgetToBuild
		addMorph: (self model model buildWithSpec: aSpec)
		frame: (0@0 corner: 1@1)! !

!MorphicWindowAdapter methodsFor: 'spec protocol' stamp: ''!
minimize

	self widgetDo: [ :w | w minimize ]! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
open

	self model window openInWorld! !

!MorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
addModelItemsToWindowMenu: aMenu

	self model addMenuItemsToWindowMenu: aMenu! !

!MorphicWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ SpecWindow new
		model: model;
		isResizeable: self isResizeable;
		yourself! !

!MorphicWindowAdapter methodsFor: 'spec protocol' stamp: ''!
isResizeable: aBoolean

	^ self widgetDo: [ :w | w isResizeable: aBoolean ]! !

!MorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
okToChange
^ self model okToChange! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
close

	self widget ifNotNil: [ :w | w close ].! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
rebuildWithSpec: aSpec
	| sub |
	
	sub := self model window submorphs copy.
	self model window removeAllMorphs.
	sub allButLast do: [:e | self model window addMorphBack: e ].
	self model addModelIn: self widget withSpec: aSpec! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
extent: aPoint

	^ self widget extent: aPoint! !

!MorphicWindowAdapter methodsFor: 'icons' stamp: ''!
taskbarIcon 
	^ self model taskbarIcon! !

!MorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
title
	^ self model title! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
addModelIn: widgetToBuild withSpecLayout: aSpec
	
	widgetToBuild
		addMorph: (self model model buildWithSpecLayout: aSpec)
		frame: (0@0 corner: 1@1)! !

!MorphicWindowAdapter methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.

	isClosedHolder := false asValueHolder.! !

!MorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
initialExtent

	^ self model initialExtent! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
title: aString

	^ self widget
		ifNotNil: [:w | w title: aString ]! !

!MorphicWindowAdapter methodsFor: 'updating' stamp: ''!
windowIsClosing

	self model windowIsClosing! !

!MorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
isResizeable

	^ self model isResizeable! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
centered

	self widgetDo: [ :w | 
		w
			fullBounds;
			position: Display extent - w extent // 2 ]! !

!MorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
cancelled

	^ false! !

!MorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
aboutText

	^ self model model
		ifNotNil: [ :m | m aboutText ]! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
centeredRelativeTo: aModel

	self widgetDo: [ :w | aModel centerWidget: w ]! !

!MorphicWindowAdapter methodsFor: 'spec protocol' stamp: ''!
modalRelativeTo: aWindow

	self widgetDo: [ :w | aWindow setModal: w ]! !

!MorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
aboutTitle
    ^ self model model
         ifNotNil: [ :m | (m respondsTo: #aboutTitle)
		ifTrue: [m aboutTitle]
		ifFalse: [m class name]].! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
openModal: aWindow

	^ self widget 
		ifNotNil: [:w | w openModal: aWindow asWidget ].! !

!MorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
rebuildWithSpecLayout: aSpec
	| sub |
	
	sub := self model window submorphs copy.
	self model window removeAllMorphs.
	sub allButLast do: [:e | self model window addMorphBack: e ].
	self model addModelIn: self widget withSpecLayout: aSpec.
	self widget model: self! !

!MorphicWindowAdapter methodsFor: 'spec protocol' stamp: ''!
maximize

	self widgetDo: [ :w | w maximize ]! !

!MouseButtonEvent commentStamp: ''!
A button event from a mouse!
!MouseButtonEvent methodsFor: 'private' stamp: ''!
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.! !

!MouseButtonEvent methodsFor: 'accessing' stamp: ''!
redButtonChanged
	"Answer true if the red mouse button has changed. This is the first mouse button."

	^ whichButton anyMask: self class redButton! !

!MouseButtonEvent methodsFor: 'dispatching' stamp: ''!
sentTo: anObject
	"Dispatch the receiver into anObject"
	type == #mouseDown ifTrue:[^anObject handleMouseDown: self].
	type == #mouseUp ifTrue:[^anObject handleMouseUp: self].
	^super sentTo: anObject! !

!MouseButtonEvent methodsFor: '*Commander-Activators-Mouse' stamp: ''!
fixStateForClickAndModifierIssue

	self isMouseUp ifFalse: [ ^self ].
	self yellowButtonChanged ifFalse: [ ^self ].
	self anyModifierKeyPressed ifFalse: [ ^self ].
	
	whichButton := MouseEvent redButton! !

!MouseButtonEvent methodsFor: 'accessing' stamp: ''!
whichButton
	^whichButton! !

!MouseButtonEvent methodsFor: 'accessing' stamp: ''!
yellowButtonChanged
	"Answer true if the yellow mouse button has changed. This is the second mouse button or option+click on the Mac."

	^ whichButton anyMask: self class yellowButton! !

!MouseButtonEvent methodsFor: 'accessing' stamp: ''!
blueButtonChanged
	"Answer true if the blue mouse button has changed. This is the third mouse button or cmd+click on the Mac."

	^ whichButton anyMask: self class blueButton! !

!MouseButtonEvent methodsFor: 'printing' stamp: ''!
storeOn: aStream
	super storeOn: aStream.
	aStream space.
	whichButton storeOn: aStream.! !

!MouseClickState commentStamp: ''!
MouseClickState is a simple class managing the distinction between clicks, double clicks, and drag operations. It has been factored out of HandMorph due to the many instVars.

Instance variables:
	clickClient 	<Morph>		The client wishing to receive #click:, #dblClick:, or #drag messages
	clickState 	<Symbol>	The internal state of handling the last event (#firstClickDown, #firstClickUp, #firstClickTimedOut)
	firstClickDown 	<MorphicEvent>	The #mouseDown event after which the client wished to receive #click: or similar messages
	firstClickUp 	<MorphicEvent>	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 	<Integer>	The millisecond clock value of the first event
	clickSelector 	<Symbol>	The selector to use for sending #click: messages
	dblClickSelector 	<Symbol>	The selector to use for sending #doubleClick: messages
	dblClickTime 	<Integer>	Timout in milliseconds for a double click operation
	dragSelector 	<Symbol>	The selector to use for sending #drag: messages
	dragThreshold 	<Integer>	Threshold used for determining if a #drag: message is sent (pixels!!)
!
!MouseClickState methodsFor: 'initialize' stamp: ''!
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.
	localStamp := Time millisecondClockValue.! !

!MouseClickState methodsFor: 'event handling' stamp: ''!
checkTimeoutFrom: aHand
	
	localStamp ifNil: [ localStamp := Time millisecondClockValue. ^ self ].
	
	(Time millisecondClockValue - localStamp ) > dblClickTime ifFalse: [ ^ self ].
	
	clickState == #firstClickDown ifTrue: [ 
		clickState := #firstClickTimedOut.
		dragSelector ifNotNil: [ ^ self ]. 
	].

	aHand resetClickState.
	self doubleClickTimeout.
	
	clickState == #firstClickTimedOut ifTrue:[ self click ]! !

!MouseClickState methodsFor: 'event handling' stamp: ''!
click

	clickSelector ifNotNil: [clickClient perform: clickSelector with: firstClickDown]! !

!MouseClickState methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $[; print: clickState; nextPut: $]! !

!MouseClickState methodsFor: 'event handling' stamp: ''!
doubleClick

	dblClickSelector ifNotNil: [clickClient perform: dblClickSelector with: firstClickDown]! !

!MouseClickState methodsFor: 'event handling' stamp: ''!
doubleClickTimeout

	dblClickTimeoutSelector ifNotNil: [
		clickClient perform: dblClickTimeoutSelector with: firstClickDown]! !

!MouseClickState methodsFor: 'event handling' stamp: ''!
drag: event

	dragSelector ifNotNil: [clickClient perform: dragSelector with: event]! !

!MouseClickState methodsFor: 'event handling' stamp: ''!
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].

			"Change the state to #firstClickUp.
			Then queue the mouseUp event for later processing.
			We will handle a click now."
			clickState := #firstClickUp.
			firstClickUp := evt copy.
			"If timedOut or the client's not interested in dbl clicks get outta here"
			aHand queuePendingEvent: firstClickUp.
			
			self click.
			
			^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! !

!MouseEvent commentStamp: ''!
Superclass for mouse events!
!MouseEvent methodsFor: 'testing' stamp: ''!
isMouseUp
	^self type == #mouseUp! !

!MouseEvent methodsFor: '*Spec2-Morphic' stamp: ''!
isSecondaryButton

	^ self yellowButtonPressed! !

!MouseEvent methodsFor: 'button state' stamp: ''!
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: 'comparing' stamp: ''!
= aMorphicEvent
	super = aMorphicEvent ifFalse:[^false].
	position = aMorphicEvent position ifFalse: [^ false].
	buttons = aMorphicEvent buttons ifFalse: [^ false].
	^ true! !

!MouseEvent methodsFor: 'private' stamp: ''!
setType: evtType position: evtPos buttons: evtButtons hand: evtHand
	type := evtType.
	position := evtPos.
	buttons := evtButtons.
	source := evtHand.
	wasHandled := false.! !

!MouseEvent methodsFor: 'comparing' stamp: ''!
hash
	^ position hash + buttons hash! !

!MouseEvent methodsFor: 'private' stamp: ''!
setType: aSymbol
	"For quick conversion between event types"
	type := aSymbol.! !

!MouseEvent methodsFor: 'button state' stamp: ''!
yellowButtonPressed
	"Answer true if the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac."

	^ buttons anyMask: self class yellowButton! !

!MouseEvent methodsFor: 'testing' stamp: ''!
isMouseMove
	^self type == #mouseMove! !

!MouseEvent methodsFor: 'accessing' stamp: ''!
cursorPoint
	"Answer the location of the cursor's hotspot when this event occured."

	^ position! !

!MouseEvent methodsFor: 'converting' stamp: ''!
asMouseLeave
	^self shallowCopy setType: #mouseLeave! !

!MouseEvent methodsFor: 'converting' stamp: ''!
asMouseOver
	"Convert the receiver into a mouse over event"

	^ MouseEvent basicNew
		setType: #mouseOver
			position: position
			buttons: buttons
			hand: source;
		setTimeStamp: self timeStamp! !

!MouseEvent methodsFor: 'testing' stamp: ''!
isDraggingEvent
	source ifNil:[^false].
	source hasSubmorphs ifTrue:[^true].
	self anyButtonPressed ifTrue:[^true].
	^false! !

!MouseEvent methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPut: $[.
	aStream print: self cursorPoint ; space.
	aStream nextPutAll: type; space.
	aStream nextPutAll: self modifierString.
	aStream nextPutAll: self buttonString.
	aStream print: timeStamp ; space.
	aStream print: self windowIndex .
	aStream nextPut: $].! !

!MouseEvent methodsFor: 'testing' stamp: ''!
isMouseLeave
	^self type == #mouseLeave! !

!MouseEvent methodsFor: 'testing' stamp: ''!
isMouseWheel
	"Answer whether the receiver is a mouse wheel event."
	
	^false! !

!MouseEvent methodsFor: '*Spec2-Morphic' stamp: ''!
isMiddleButton

	^ self blueButtonPressed! !

!MouseEvent methodsFor: 'button state' stamp: ''!
anyButtonPressed
	"Answer true if any mouse button is being pressed."

	^ buttons anyMask: self class anyButton! !

!MouseEvent methodsFor: 'dispatching' stamp: ''!
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: 'testing' stamp: ''!
isMouseEnter
	^self type == #mouseEnter! !

!MouseEvent methodsFor: 'converting' stamp: ''!
asMouseEnter
	^self shallowCopy setType: #mouseEnter! !

!MouseEvent methodsFor: 'testing' stamp: ''!
isMouse
	^true! !

!MouseEvent methodsFor: 'button state' stamp: ''!
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: 'converting' stamp: ''!
asMouseMove
	"Convert the receiver into a mouse move"
	^MouseMoveEvent basicNew setType: #mouseMove startPoint: position endPoint: position trail: {position. position} buttons: buttons hand: source stamp: self timeStamp! !

!MouseEvent methodsFor: '*Spec2-Morphic' stamp: ''!
isPrimaryButton

	^ self redButtonPressed! !

!MouseEvent methodsFor: 'printing' stamp: ''!
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: 'button state' stamp: ''!
redButtonPressed
	"Answer true if the red mouse button is being pressed. This is the first mouse button."

	^ buttons anyMask: self class redButton! !

!MouseEvent methodsFor: 'testing' stamp: ''!
isMouseDown
	^self type == #mouseDown! !

!MouseEvent class methodsFor: 'constants' stamp: ''!
anyButton
	^ 7! !

!MouseEvent class methodsFor: 'constants' stamp: ''!
redButton
	^ 4! !

!MouseEvent class methodsFor: 'constants' stamp: ''!
yellowButton
	^ 2! !

!MouseEvent class methodsFor: 'constants' stamp: ''!
blueButton
	^ 1! !

!MouseMoveEvent commentStamp: ''!
A move event from the mouse!
!MouseMoveEvent methodsFor: 'comparing' stamp: ''!
= 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: ''!
hash
	^ position hash + startPoint hash + buttons hash! !

!MouseMoveEvent methodsFor: 'dispatching' stamp: ''!
sentTo: anObject
	"Dispatch the receiver into anObject"
	type == #mouseMove ifTrue:[^anObject handleMouseMove: self].
	^super sentTo: anObject.! !

!MouseMoveEvent methodsFor: 'transforming' stamp: ''!
transformBy: aMorphicTransform
	"Transform the receiver into a local coordinate system."
	position :=  aMorphicTransform globalPointToLocal: position.
	startPoint :=  aMorphicTransform globalPointToLocal: startPoint.! !

!MouseMoveEvent methodsFor: 'testing' stamp: ''!
isMove
	^true! !

!MouseMoveEvent methodsFor: 'transforming' stamp: ''!
translateBy: delta
	"add delta to cursorPoint, and return the new event"
	position := position + delta.
	startPoint := startPoint + delta.! !

!MouseMoveEvent methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPut: $[.
	aStream print: self startPoint ; space.
	aStream print: self endPoint ; space.
	aStream nextPutAll: self type; space.
	aStream nextPutAll: self modifierString.
	aStream nextPutAll: self buttonString.
	aStream print: timeStamp ; space.
	aStream print: self windowIndex .
	aStream nextPut: $].! !

!MouseMoveEvent methodsFor: 'accessing' stamp: ''!
startPoint
	"Return the point where the movement started."
	^startPoint! !

!MouseMoveEvent methodsFor: 'accessing' stamp: ''!
endPoint
	"Return the point where the movement ended."
	^position! !

!MouseMoveEvent methodsFor: 'private' stamp: ''!
setType: evtType startPoint: evtStart endPoint: evtEnd trail: evtTrail buttons: evtButtons hand: evtHand stamp: stamp
	type := evtType.
	startPoint := evtStart.
	position := evtEnd.
	trail := evtTrail.
	buttons := evtButtons.
	source := evtHand.
	wasHandled := false.
	timeStamp := stamp.! !

!MouseMoveEvent methodsFor: 'accessing' stamp: ''!
trail
	"Return any immediate points that have been assembled along the move"
	^trail ifNil:[#()]! !

!MouseMoveEvent methodsFor: 'printing' stamp: ''!
storeOn: aStream
	super storeOn: aStream.
	aStream space.
	self startPoint x storeOn: aStream.
	aStream space.
	self startPoint y storeOn: aStream.
	aStream space.
	"trail storeOn: aStream."! !

!MouseOverHandler commentStamp: ''!
Mouse over handler in a hand morph!
!MouseOverHandler methodsFor: 'event handling - private' stamp: ''!
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: ''!
initializeProcessMouseOver

	leftMorphs := mouseOverMorphs asIdentitySet.
	overMorphs := WriteStream on: (Array new: leftMorphs size).
	enteredMorphs := WriteStream on: #()! !

!MouseOverHandler methodsFor: 'event handling' stamp: ''!
processMouseOver: anEvent 

	self initializeProcessMouseOver.
	self handleAsMouseOver: anEvent.
	self hasLeftMorphsChanged ifTrue: [ 
		self handleAsMouseLeave: anEvent.
		self handleAsMouseEnter: anEvent.
		self rememberOverList ].
	
	self initializeTrackedMorphs! !

!MouseOverHandler methodsFor: 'initialization' stamp: ''!
initialize
	mouseOverMorphs := #().
	
	self initializeTrackedMorphs! !

!MouseOverHandler methodsFor: 'event handling - private' stamp: ''!
handleAsMouseOver: anEvent 

	anEvent hand handleEvent: anEvent asMouseOver.! !

!MouseOverHandler methodsFor: 'event handling - private' stamp: ''!
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: ''!
rememberOverList

	mouseOverMorphs := overMorphs contents.! !

!MouseOverHandler methodsFor: 'event handling - private' stamp: ''!
keepLeftMorphsOrder

	leftMorphs size > 1 ifTrue: [ leftMorphs := mouseOverMorphs intersection: leftMorphs ]! !

!MouseOverHandler methodsFor: 'event handling' stamp: ''!
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 - private' stamp: ''!
is: anEvent withFocusOver: aMorph 

	| focusedMorph |
	
	focusedMorph := anEvent hand mouseFocus.
	^ aMorph = focusedMorph or: [ aMorph hasOwner: focusedMorph ]! !

!MouseOverHandler methodsFor: 'event handling - private' stamp: ''!
inform: evt to: aLeftMorph originatedFrom: anEvent ifNotFocusedDo: aBlock

	^ (self is: anEvent withFocusOver: aLeftMorph) 
		ifTrue: [ self transform: evt from: anEvent andSendTo: aLeftMorph ]
		ifFalse: aBlock! !

!MouseOverHandler methodsFor: 'initialization' stamp: ''!
initializeTrackedMorphs

	leftMorphs := OrderedCollection new.
	overMorphs := WriteStream on: #().
	enteredMorphs := WriteStream on: #().! !

!MouseOverHandler methodsFor: 'event handling - private' stamp: ''!
transform: anEvent from: originalEvent andSendTo: aMorph

	| transformedEvent |

	transformedEvent := anEvent transformedBy: (aMorph transformedFrom: originalEvent hand).
	^ aMorph handleEvent: transformedEvent! !

!MouseOverHandler methodsFor: 'event handling - private' stamp: ''!
hasLeftMorphsChanged

	^(leftMorphs isEmpty and: [ enteredMorphs position = 0 ]) not! !

!MouseOverHandler methodsFor: 'event handling - private' stamp: ''!
handleAsMouseLeave: anEvent 

	self keepLeftMorphsOrder.
	self informMouseLeaveToLeftMorphsUsing: anEvent! !

!MouseWheelEvent commentStamp: ''!
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: ''!
direction: anObject
	"Set the value of direction"

	direction := anObject! !

!MouseWheelEvent methodsFor: 'accessing' stamp: ''!
setType: evtType position: evtPos direction: dirSymbol buttons: evtButtons hand: evtHand stamp: stamp
	"Set the state for the receiver."
	
	type := evtType.
	position := evtPos.
	buttons := evtButtons.
	source := evtHand.
	wasHandled := false.
	direction := dirSymbol.
	timeStamp := stamp.! !

!MouseWheelEvent methodsFor: 'dispatching' stamp: ''!
sentTo: anObject
	"Dispatch the receiver into anObject"
	
	type == #mouseWheel ifTrue:[^anObject handleMouseWheel: self].
	^super sentTo: anObject.! !

!MouseWheelEvent methodsFor: 'testing' stamp: ''!
isUp

	^ direction = Character arrowUp! !

!MouseWheelEvent methodsFor: 'testing' stamp: ''!
isLeft

	^ direction = Character arrowLeft! !

!MouseWheelEvent methodsFor: 'accessing' stamp: ''!
direction
	"Answer the value of direction"

	^ direction! !

!MouseWheelEvent methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPut: $[.
	aStream print: self cursorPoint; space.
	aStream nextPutAll: type; space.
	aStream print: self direction; space.
	aStream nextPutAll: self modifierString.
	aStream nextPutAll: self buttonString.
	aStream print: timeStamp; space.
	aStream print: self windowIndex.
	aStream nextPut: $].! !

!MouseWheelEvent methodsFor: 'testing' stamp: ''!
isDown

	^ direction = Character arrowDown! !

!MouseWheelEvent methodsFor: 'testing' stamp: ''!
isMouseWheel
	"Answer whether the receiver is a mouse wheel event."
	
	^true! !

!MouseWheelEvent methodsFor: 'testing' stamp: ''!
isRight

	^ direction = Character arrowRight! !

!MouseWheelEvent class methodsFor: 'instance creation' stamp: ''!
fromCharacter: aCharacter position: aPoint buttons: evtButtons hand: evtHand stamp: stamp

	^ self new
		setType: #mouseWheel
		position: aPoint
		direction: aCharacter
		buttons: evtButtons
		hand: evtHand
		stamp: stamp! !

!MultiColumnListPresenter commentStamp: ''!
A MultiColumnListPresenter is a spec presenter for Multi columns list!
!MultiColumnListPresenter methodsFor: 'morphic' stamp: ''!
setIndex: anIndex

	self allowToSelect ifFalse: [ ^ self ].
	self okToChange ifFalse: [ ^ self ].
	selectionHolder index value: anIndex.
	selectionHolder selection value: (self listItems at: anIndex ifAbsent: [ nil ]).! !

!MultiColumnListPresenter methodsFor: 'morphic' stamp: ''!
listElementAt: anIndex

	^ self wrapItem: (self listItems at: anIndex) index: anIndex ! !

!MultiColumnListPresenter methodsFor: 'api' stamp: ''!
setSelectedIndex: anIndex
	"<api: #integer min: 0 max: #listSize getter: #selectedIndex registration: #whenSelectionIndexChanged:>"
	"Set the index of the item you want to be selected"
	| idx selection |
	
	self allowToSelect ifFalse: [ ^ self ].
	self okToChange ifFalse: [ ^ self ].
	self listSize isZero ifTrue:  [ ^self ].
	idx := anIndex min: self listSize.
	selection := self listItems 
					at: idx 
					ifAbsent: [ idx := 0.
								nil ].
	
	selectionHolder index value: idx.
	selectionHolder selection value: selection.! !

!MultiColumnListPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(MultiColumnListAdapter
		adapt: #(model))! !

!MultiColumnListPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #MultiColumnListAdapter! !

!MultiFontTest commentStamp: ''!
Test for internationalized fonts!
!MulticolumnLazyListMorph commentStamp: ''!
A variant of LazyListMorph that can display multi-column lists.!
!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	self getListSize = 0 ifTrue:[ ^self ].

	self setColumnWidthsFor: aCanvas.
	self adjustWidth.
	
	super drawOn: aCanvas! !

!MulticolumnLazyListMorph methodsFor: 'scroll range' stamp: ''!
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: ''!
widthToDisplayItem: item
	"This class will be removed soon, so this method will disappear"
	| widths |
	
	widths := item collect: [ :each | each widthToDisplayInList: self ].
	^widths sum + ((listSource gapSize + 4) * (widths size - 1))   "add in space between the columns"! !

!MulticolumnLazyListMorph methodsFor: 'list access' stamp: ''!
getListItem: index
	^listSource getListRow: index! !

!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: ''!
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: 'list access' stamp: ''!
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: ''!
listChanged
	columnWidths := nil.
	super listChanged! !

!MulticolumnLazyListMorph methodsFor: '*Athens-Morphic' stamp: ''!
athensDisplay: items atRow: row on: anAthensCanvas
	| drawBounds |
	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) ].
			anAthensCanvas
				morphicDrawString: item asString
				at: drawBounds topLeft
				font: self font
				color: color ]! !

!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: ''!
setColumnWidthsFor: aCanvas
        | row topRow bottomRow |
        "set columnWidths for drawing on the specified canvas"
		columnWidths ifNil: [
		columnWidths := (self item: 1) collect: [ :ignored | 0 ]. ].
	topRow := (self topVisibleRowForCanvas: aCanvas) max: 1.
	bottomRow :=  (self bottomVisibleRowForCanvas: aCanvas) max: 1.
	topRow > bottomRow ifTrue: [ ^ self ].
	topRow to: bottomRow do: [ :rowIndex |
                row := self item: rowIndex.
                columnWidths := columnWidths with: row collect: [ :currentWidth :item |
				| widthOfItem |
				widthOfItem := (font widthOfStringOrText: item).
				widthOfItem > currentWidth
					ifTrue: [ self changed.  widthOfItem ]
					ifFalse: [ currentWidth ] ] ]! !

!MulticolumnLazyListMorph methodsFor: 'row management' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	self getListSize = 0 ifTrue:[ ^self ].

	self setColumnWidthsFor: anAthensCanvas.
	self adjustWidth.
	
	super drawOnAthensCanvas: anAthensCanvas! !

!MultipleSettingDeclaration commentStamp: ''!
A declaration for multiple settings!
!MultipleSettingDeclaration methodsFor: 'user interface' stamp: ''!
domainValuesLabels
	^ self domainValues
		collect: [:f | f name]! !

!MultipleSettingDeclaration methodsFor: 'user interface' stamp: ''!
hasEditableList
	^ false! !

!MultipleSettingDeclaration methodsFor: 'accessing' stamp: ''!
domainValues: aCollection 
	domainValues := aCollection asArray collect: [ :v | v settingFixedDomainValueNodeFrom: self]! !

!MultipleSettingDeclaration methodsFor: 'user interface' stamp: ''!
fixedDomainValueNodeForAssociation: anAssociation 
	| s |
	^ (s := (SettingDeclaration new name: anAssociation key translated))
		target: s;
		selector: #default;
		default: anAssociation value! !

!MultipleSettingDeclaration methodsFor: 'user interface' stamp: ''!
fixedDomainValueNodeForObject: anObject 
	| s |
	^ (s := (SettingDeclaration new name: anObject asString))
		target: s;
		selector: #default;
		default: anObject! !

!MultipleSettingDeclaration methodsFor: 'accessing' stamp: ''!
domainValues
	^ domainValues ifNil: [domainValues := OrderedCollection new]! !

!MultistateButtonMorph commentStamp: ''!
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: 'updating' stamp: ''!
changed
	"Update the fillStyle here."
	
	self assureExtension.
	extension fillStyle: self fillStyleToUse.
	color := self fillStyle asColor.
	super changed! !

!MultistateButtonMorph methodsFor: 'visual properties' stamp: ''!
passiveEnabledOverDownFillStyle: aFillStyle
	"Set the passive, enabled, over, down fill style."

	self stateMap atPath: #(passive enabled over down) put: aFillStyle.
	self changed! !

!MultistateButtonMorph methodsFor: 'event handling' stamp: ''!
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: 'visual properties' stamp: ''!
activeEnabledOverUpFillStyle: aFillStyle
	"Set the active, enabled, over, up fill style."

	self stateMap atPath: #(active enabled over up) put: aFillStyle.
	self changed! !

!MultistateButtonMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
passivate
	"Make passive."

	super passivate.
	self active: false! !

!MultistateButtonMorph methodsFor: 'event handling' stamp: ''!
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: 'visual properties' stamp: ''!
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: 'recategorized' stamp: ''!
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: 'visual properties' stamp: ''!
activeDisabledOverUpFillStyle: aFillStyle
	"Set the active, disabled, over, up fill style."

	self stateMap atPath: #(active disabled over up) put: aFillStyle.
	self changed! !

!MultistateButtonMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: evt
	"Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed."

	super mouseLeave: evt.
	self over: false! !

!MultistateButtonMorph methodsFor: 'visual properties' stamp: ''!
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: ''!
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: ''!
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: ''!
passiveDisabledNotOverUpFillStyle: aFillStyle
	"Set the passive, disabled, notOver, up fill style."

	self stateMap atPath: #(passive disabled notOver up) put: aFillStyle.
	self changed! !

!MultistateButtonMorph methodsFor: 'accessing' stamp: ''!
down
	"Answer the value of down"

	^ down! !

!MultistateButtonMorph methodsFor: 'recategorized' stamp: ''!
handlesMouseOver: anEvent
	"Answer true, otherwise what is all that
	#mouseEnter:/#mouseLeave: stuff about?"

	^true! !

!MultistateButtonMorph methodsFor: 'visual properties' stamp: ''!
activeDisabledOverDownFillStyle: aFillStyle
	"Set the active, disabled, over, down fill style."

	self stateMap atPath: #(active disabled over down) put: aFillStyle.
	self changed! !

!MultistateButtonMorph methodsFor: 'adding' stamp: ''!
addUpAction: aValuable
	
	upAction := aValuable! !

!MultistateButtonMorph methodsFor: 'accessing' stamp: ''!
enabled: anObject
	"Set the value of enabled"

	enabled := anObject.
	self changed! !

!MultistateButtonMorph methodsFor: 'accessing' stamp: ''!
over
	"Answer the value of over"

	^ over! !

!MultistateButtonMorph methodsFor: 'accessing' stamp: ''!
stateMap
	"Answer the value of stateMap"

	^ stateMap! !

!MultistateButtonMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
activate
	"Make active."

	super activate.
	self active: true! !

!MultistateButtonMorph methodsFor: 'geometry' stamp: ''!
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: 'visual properties' stamp: ''!
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: ''!
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: 'event handling' stamp: ''!
handlesMouseOverDragging: evt
	"Yes, for other states."
	
	^true! !

!MultistateButtonMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	self stateMap: KeyedTree new.
	enabled := true.
	active := true.
	over := false.
	down := false.
	super initialize! !

!MultistateButtonMorph methodsFor: 'visual properties' stamp: ''!
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: 'event handling' stamp: ''!
mouseEnter: evt
	"Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed."

	super mouseEnter: evt.
	self over: true! !

!MultistateButtonMorph methodsFor: 'visual properties' stamp: ''!
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: ''!
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: ''!
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: ''!
passiveEnabledNotOverUpFillStyle: aFillStyle
	"Set the passive, enabled, notOver, up fill style."

	self stateMap atPath: #(passive enabled notOver up) put: aFillStyle.
	self changed! !

!MultistateButtonMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt 
	"Handle a mouse down event."
	
	super mouseDown: evt.
	self enabled ifFalse: [^self].
	self down: true.! !

!MultistateButtonMorph methodsFor: 'accessing' stamp: ''!
enabled
	"Answer whether the button is rnabled."

	^enabled! !

!MultistateButtonMorph methodsFor: 'visual properties' stamp: ''!
passiveEnabledOverUpFillStyle: aFillStyle
	"Set the passive, enabled, over, up fill style."

	self stateMap atPath: #(passive enabled over up) put: aFillStyle.
	self changed! !

!MultistateButtonMorph methodsFor: 'accessing' stamp: ''!
active: anObject
	"Set the value of active"

	active := anObject.
	self changed! !

!MultistateButtonMorph methodsFor: 'accessing' stamp: ''!
stateMap: anObject
	"Set the value of stateMap"

	stateMap := anObject! !

!MultistateButtonMorph methodsFor: 'visual properties' stamp: ''!
passiveDisabledOverUpFillStyle: aFillStyle
	"Set the passive, disabled, over, up fill style."

	self stateMap atPath: #(passive disabled over up) put: aFillStyle.
	self changed! !

!MultistateButtonMorph methodsFor: 'accessing' stamp: ''!
down: anObject
	"Set the value of down"

	down := anObject.
	self changed! !

!MultistateButtonMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	"Yes."
	
	^true! !

!MultistateButtonMorph methodsFor: 'accessing' stamp: ''!
active
	"Answer the value of active"

	^ active! !

!MultistateButtonMorph methodsFor: 'visual properties' stamp: ''!
activeDisabledNotOverUpFillStyle: aFillStyle
	"Set the active, disabled, notOver, up fill style."

	self stateMap atPath: #(active disabled notOver up) put: aFillStyle.
	self changed! !

!MultistateButtonMorph methodsFor: 'event handling' stamp: ''!
mouseUp: evt 
	"Handle a mouse up event."
	
	super mouseUp: evt.
	self enabled ifFalse: [^self].
	self down: false.
	
	(self containsPoint: evt cursorPoint) ifTrue: [ 
		upAction value.
	]! !

!MultistateButtonMorph methodsFor: 'accessing' stamp: ''!
over: anObject
	"Set the value of over"

	over := anObject.
	self changed! !

!Mutex commentStamp: ''!
A Mutex is a light-weight MUTual EXclusion object being used when two or more processes need to access a shared resource concurrently. A Mutex grants ownership to a single process and will suspend any other process trying to aquire the mutex while in use. Waiting processes are granted access to the mutex in the order the access was requested.

A Mutex is also more robust to nested critical calls.
For example 

mutex critical: [ mutex critical: [ Trasncript show: 'nested passes through' ] ]

will not deadlock, while a semaphore will. This is why a mutex is also called a recursionLock.

Instance variables:
	semaphore	<Semaphore>		The (primitive) semaphore used for synchronization.
	owner		<Process>		The process owning the mutex.!
!Mutex methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	semaphore := Semaphore forMutualExclusion.! !

!Mutex methodsFor: 'mutual exclusion' stamp: ''!
critical: aBlock
	"Execute aBlock only if the receiver is not already used by another process. 
	If it is, wait until the resource is available. 
	If the mutex is already used by the current process, execution proceeds. 
	Answer the block's result."
	
	| activeProcess |
	activeProcess := Processor activeProcess.
	activeProcess == owner ifTrue:[ ^aBlock value ].
	^ semaphore critical: [
			owner := activeProcess.
			aBlock ensure: [ owner := nil ] ].! !

!Mutex methodsFor: '*Calypso-NavigationModel' stamp: ''!
tryEnterCritical: criticalBlock ifLocked: lockedBlock

	| activeProcess |
	activeProcess := Processor activeProcess.
	activeProcess == owner ifTrue:[^criticalBlock value].
	^semaphore critical:[
		owner := activeProcess.
		criticalBlock ensure:[owner := nil]] ifLocked: lockedBlock! !

!MutexSet commentStamp: ''!
A MutexSet helps with aquiring a set of mutexes.!
!MutexSet methodsFor: 'mutual exclusion' stamp: ''!
critical: aBlock
	"Evaluate aBlock aquiring all mutexes"
	^self pvtCritical: aBlock startingAt: 1! !

!MutexSet methodsFor: 'initialize' stamp: ''!
withAll: mutexList
	array := mutexList.! !

!MutexSet methodsFor: 'private' stamp: ''!
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 methodsFor: 'instance creation' stamp: ''!
withAll: mutexList
	^self new withAll: mutexList! !

!MutexTest commentStamp: ''!
SUnit tests for class  Mutex!
!MutexTest methodsFor: 'tests' stamp: ''!
testTwoCriticalsShouldWaitEachOther

	| lastCriticalExecuted firstCriticalExecutedFirst semaphoreToHoldMutex |
	lastCriticalExecuted := false.
	firstCriticalExecutedFirst := false.
	semaphoreToHoldMutex := Semaphore new.
	
	self fork: [
		mutex critical: [ semaphoreToHoldMutex wait. "here we grab mutex and control it with semaphore"
		firstCriticalExecutedFirst := lastCriticalExecuted not ]].
	self waitLastProcessLock.
	
	self fork: [mutex critical: [ lastCriticalExecuted := true ]].
	self waitLastProcessLock.
	
	semaphoreToHoldMutex signal.
	self waitLastProcessTerminate.
	self assert: lastCriticalExecuted.
	self assert: firstCriticalExecutedFirst! !

!MutexTest methodsFor: 'running' stamp: ''!
tearDown
	forkedProcesses do: #terminate.
	
	super tearDown.! !

!MutexTest methodsFor: 'helpers' stamp: ''!
waitLastProcessLock

	self waitProcessLock: forkedProcesses last! !

!MutexTest methodsFor: 'helpers' stamp: ''!
waitProcessLock: aProcess

	self waitFor: [ aProcess suspendingList isEmptyOrNil not ]! !

!MutexTest methodsFor: 'tests' stamp: ''!
testTerminatingBlockedCriticalWhichWasSignalledButNotResumedYet
	| processWaitingForMutex firstCriticalExecuted lastCriticalExecuted semaphoreToHoldMutex |
	firstCriticalExecuted := false.
	lastCriticalExecuted := false.
	semaphoreToHoldMutex := Semaphore new.
	
	self fork: [ 
		mutex critical: [ semaphoreToHoldMutex wait.
		firstCriticalExecuted := true ]] at: Processor activeProcess priority + 1.	
	self waitLastProcessLock.
	"for second critical we choose small priority. So it can't be resumed automatically by scheduler in our scenario."
	processWaitingForMutex := self fork: [mutex critical: [ self error: 'should not happen' ]] at: Processor activeProcess priority - 1. 
	self waitLastProcessLock.
	self deny: firstCriticalExecuted.
	semaphoreToHoldMutex signal.
	self assert: firstCriticalExecuted.
	processWaitingForMutex terminate. "Here the process waits for mutex and being terminated at the point when mutex was already signalled but process was not resumed.
		Correct critical implementation should allow execution of new consequent criticals"
	self fork: [ mutex critical: [ lastCriticalExecuted := true ]].	
	self waitLastProcessTerminate.
	self assert: lastCriticalExecuted description: 'consequent last critical should be executed'! !

!MutexTest methodsFor: 'helpers' stamp: ''!
waitLastProcessSuspend

	self waitProcessSuspend: forkedProcesses last! !

!MutexTest methodsFor: 'helpers' stamp: ''!
fork: aBlock

	| newProcess |
	newProcess := aBlock forkNamed: testSelector.
	forkedProcesses add: newProcess.
	^newProcess! !

!MutexTest methodsFor: 'tests' stamp: ''!
testExecutionCriticalSection

	| actual |
	actual := mutex critical: [ #result ].
	
	self assert: actual equals: #result! !

!MutexTest methodsFor: 'helpers' stamp: ''!
waitFor: aBlock

	[ 10 milliSeconds wait. aBlock value ] whileFalse! !

!MutexTest methodsFor: 'tests' stamp: ''!
testTerminatedCriticalSectionShouldUnblockWaitingOne
	| lastCriticalExecuted semaphoreToHoldMutex processHoldingMutex |
	lastCriticalExecuted := false.
	semaphoreToHoldMutex := Semaphore new.
	
	processHoldingMutex := self fork: [
		mutex critical: [ semaphoreToHoldMutex wait. "here we grab mutex and control it with semaphore"
		self error: 'should not happen' ]].
	self waitLastProcessLock.
	
	self fork: [mutex critical: [ lastCriticalExecuted := true ]].
	self waitLastProcessLock.
	
	processHoldingMutex terminate.
	self waitLastProcessTerminate.
	self assert: lastCriticalExecuted! !

!MutexTest methodsFor: 'helpers' stamp: ''!
waitProcessTermination: aProcess

	self waitFor: [ aProcess isTerminated ]! !

!MutexTest methodsFor: 'tests' stamp: ''!
testTerminatingBlockedCriticalSectionShouldNotUnblockAnotherWaitingSection
	| semaphoreToHoldMutex holdingCriticalExecutedFirst firstWaitingProcess lastCriticalExecuted |
	holdingCriticalExecutedFirst := false.
	semaphoreToHoldMutex := Semaphore new.
	lastCriticalExecuted := false.
	
	self fork: [
		mutex critical: [ semaphoreToHoldMutex wait. "here we grab mutex and control it with semaphore"
		holdingCriticalExecutedFirst := lastCriticalExecuted not ]].
	self waitLastProcessLock.
	
	firstWaitingProcess := self fork: [mutex critical: [ self error: 'should not happen' ]].
	self waitLastProcessLock.
	self fork: [mutex critical: [ lastCriticalExecuted := true]].
	self waitLastProcessLock.

	firstWaitingProcess terminate.
	self waitLastProcessLock. "check that last process is still waiting"
	semaphoreToHoldMutex signal. "here we resume first process execution"
	self waitLastProcessTerminate.
	self assert: holdingCriticalExecutedFirst.
	self assert: lastCriticalExecuted.! !

!MutexTest methodsFor: 'helpers' stamp: ''!
waitProcessSuspend: aProcess

	self waitFor: [ aProcess isSuspended ]! !

!MutexTest methodsFor: 'helpers' stamp: ''!
fork: aBlock at: priority

	| newProcess |
	newProcess := aBlock forkAt: priority named: testSelector.
	forkedProcesses add: newProcess.
	^newProcess! !

!MutexTest methodsFor: 'tests' stamp: ''!
testTwoRecursiveCriticalsShouldNotWaitEachOther

	| executed |
	executed := false.
	
	self fork: [mutex critical: [ mutex critical: [ executed := true ]]].
	self waitLastProcessTerminate.
		
	self assert: executed! !

!MutexTest methodsFor: 'tests' stamp: ''!
testFailedCriticalSectionShouldUnblockWaitingOne
	| lastCriticalExecuted semaphoreToHoldMutex |
	lastCriticalExecuted := false.
	semaphoreToHoldMutex := Semaphore new.
	self fork: [ 
		[ 
		mutex critical: [ 
			semaphoreToHoldMutex wait. "here we grab mutex and control it with semaphore"
			self error: 'critical section failed' ] ] onErrorDo: [  ] ].
	self waitLastProcessLock. "wait until first process grabs the mutex"

	self fork: [ mutex critical: [ lastCriticalExecuted := true ] ].
	self waitLastProcessLock.

	semaphoreToHoldMutex signal.
	self waitLastProcessTerminate.
	self assert: lastCriticalExecuted! !

!MutexTest methodsFor: 'helpers' stamp: ''!
waitLastProcessTerminate

	self waitProcessTermination: forkedProcesses last! !

!MutexTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	forkedProcesses := OrderedCollection new.
	mutex := Mutex new.! !

!MyBooleanObject commentStamp: ''!
I am an example class used in MustBeBooleanTest.

The compiler compiles some solectors specially (among them and:, or:, not, ifTrue: and related).

These methods are compiled directly to a "jump if true/false" byteode. This means that a method like #ifTrue:
is never called.

When the jump bytecode is called on a non-boolean, the VM sends #mustBeBooleanIn:

- In ST80, this just raises the NonBooleanReceiver exception.
- In Pharo, instead the expression is compiled on the fly without optimization and then executed 
  (read the comment in #mustBeBooleanIn: for more information about the details).

This means that in Pharo, we can define our own kind of Boolean and implement e.g. #ifTrue: there and it will just work as 
expected.

This class contains an example for this and MustBeBooleanTest tests that endeed we can call #ifTrue: on a non-Boolean.!
!MyBooleanObject methodsFor: 'controlling' stamp: ''!
and: alternativeBlock 
	"Nonevaluating conjunction -- answer with false since the receiver is false."

	^self! !

!MyBooleanObject methodsFor: 'controlling' stamp: ''!
ifTrue: aBlock 
	^ aBlock value printString , ' sent from my boolean object'! !

!MyBooleanObject methodsFor: 'logical operations' stamp: ''!
not
	^true! !

!MyBooleanObject methodsFor: 'controlling' stamp: ''!
or: alternativeBlock 
	^alternativeBlock value! !

!MyHalt commentStamp: ''!
A custom exception used in halts!
!MyHalt methodsFor: 'accessing' stamp: ''!
defaultAction
	"The default action taken if the exception is signaled."
	"Mimics the normal way an exception being signaled results in its process being suspended and a DebugSession being created."

	| debugSession |
	debugSession := Processor activeProcess newDebugSessionNamed: 'test' startedAt: self signalerContext.
	"Storing the debug session in this class variable so that it can be recovered by the test"
	DebugSessionContexts2Test debugSession: debugSession.
	Processor activeProcess suspend.! !

!MyResumableTestError commentStamp: ''!
A resumable error for tests!
!MyResumableTestError methodsFor: 'private' stamp: ''!
isResumable

	^true! !

!MyTestError commentStamp: ''!
An error for tests!
!MyTestNotification commentStamp: ''!
A notification for tests !
!MyVariableNotDeclaredDummyClassForTest methodsFor: 'accessing' stamp: ''!
description
^ 'a specialized description'! !

!NECCVariableEntry commentStamp: ''!
my subclasses model pssible completions for variables!
!NECCVariableEntry methodsFor: 'ui related' stamp: ''!
browse
	| class |
	class := Smalltalk globals at: contents ifAbsent: [ nil ].
	class
		ifNotNil: [ Smalltalk tools browser openOnClass: class].
	^ true! !

!NECCVariableEntry methodsFor: 'detail information' stamp: ''!
createDescription
	| clazz |
	clazz := Smalltalk globals at: contents ifAbsent: [ nil ].
	^ clazz 
		ifNil: [ NECEntryDescription label: self label ]
		ifNotNil: 
			[ NECEntryDescription 
				label: self label
				title: clazz printString
				description: clazz comment ]! !

!NECClassVarEntry commentStamp: ''!
I represent a class Variable!
!NECClassVarEntry methodsFor: 'accessing' stamp: ''!
hightlightSymbol
	^ #classVar! !

!NECClassVarEntry methodsFor: 'accessing' stamp: ''!
label
	^ 'class variable'! !

!NECDetailMorph commentStamp: ''!
I display some detail information for a selected ECEntry in the ECMenuMorph.
The content I show, is provided by an ECDetailContentProvider subclass. 
!
!NECDetailMorph methodsFor: 'drawing' stamp: ''!
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: 'private' stamp: ''!
positionOnLeft: anInteger 
	^ arrowPosition x - self class width - anInteger! !

!NECDetailMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	super drawOn: aCanvas.
	arrowPosition ifNotNil: [
		self drawArrowOn: aCanvas.
		self drawMessageOn: aCanvas]! !

!NECDetailMorph methodsFor: 'drawing' stamp: ''!
bounds
	^ super bounds topLeft extent: self class width @ self class height! !

!NECDetailMorph methodsFor: 'initialization' stamp: ''!
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' stamp: ''!
titleBounds
	^ self contentBounds top: self contentBounds top + 10! !

!NECDetailMorph methodsFor: 'drawing' stamp: ''!
messageFont
	^ NECMenuMorph messageFont! !

!NECDetailMorph methodsFor: 'drawing' stamp: ''!
scrollColor
	^ NECMenuMorph scrollColor! !

!NECDetailMorph methodsFor: 'drawing' stamp: ''!
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' stamp: ''!
drawArrowOn: aCanvas
	| point factor poligon |
	factor := self itemHeight.
	point := arrowPosition.
	poligon := OrderedCollection new.
	poligon add: point.
	poligon add: (point := point translateBy: (factor / 2) @ 0).
	poligon add: (point := point translateBy: 0 @ (factor * -0.5)).
	poligon add: (point := point translateBy: factor @ factor).
	poligon add: (point := point translateBy: (factor * -1) @ factor).
	poligon add: (point := point translateBy: 0 @ (factor * -0.5)).
	poligon add: (point := point translateBy: (factor * -0.5) @ 0).
	aCanvas drawPolygon: poligon fillStyle: self scrollColor! !

!NECDetailMorph methodsFor: 'accessing' stamp: ''!
entryDescription: anECEntryDescription 
	| categoryContents entryDescription |
	entryDescription := anECEntryDescription.
	title
		contents: (entryDescription title
				ifNil: [
					description bounds: self titleBounds.
					String new]
				ifNotNil: [
					description bounds: self descriptionBounds.
					entryDescription title]).
	description contentsWrapped: entryDescription description.
	categoryContents := entryDescription label.
	label contents: categoryContents! !

!NECDetailMorph methodsFor: 'drawing' stamp: ''!
itemHeight
	^ NECMenuMorph itemHeight! !

!NECDetailMorph methodsFor: 'accessing' stamp: ''!
descriptionBounds
	^ self contentBounds top: self contentBounds top + 30! !

!NECDetailMorph methodsFor: 'drawing' stamp: ''!
defaultColor
	^ NECMenuMorph backgroundColor.! !

!NECDetailMorph methodsFor: 'drawing' stamp: ''!
contentBounds
	| factor rectangle |
	factor := self itemHeight.
	rectangle := self bounds top: self bounds top + 3.
	rectangle := rectangle left: rectangle left + (factor * 2.0).
	rectangle := rectangle bottom: rectangle bottom - factor.
	^ rectangle! !

!NECDetailMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas 
	self drawOnCanvasWrapperFor: anAthensCanvas! !

!NECDetailMorph class methodsFor: 'private' stamp: ''!
width
	^ NECMenuMorph itemWidth * 2.0! !

!NECDetailMorph class methodsFor: 'private' stamp: ''!
height
	^ NECMenuMorph itemHeight * 15.5! !

!NECEntry commentStamp: ''!
I represent a completion entry that is management by a ECModel and shown in the ECMenuMorph as a menu entry.

Each of my subclass will represent a specific kind of entity. For example a globalvariable, self...!
!NECEntry methodsFor: 'accessing' stamp: ''!
hightlightSymbol
	^nil! !

!NECEntry methodsFor: 'operations' stamp: ''!
description
	^description ifNil: [ description := self createDescription ]! !

!NECEntry methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream 
		nextPutAll: self class name;
		nextPut: $(;
		nextPutAll: contents;
		nextPut: $,.

	self hightlightSymbol ifNotNil: [ aStream nextPutAll: self hightlightSymbol ].
	
	aStream nextPut: $)! !

!NECEntry methodsFor: 'private' stamp: ''!
browse
	self subclassResponsibility! !

!NECEntry methodsFor: 'detail information' stamp: ''!
createDescription
	self subclassResponsibility! !

!NECEntry methodsFor: 'accessing' stamp: ''!
contents: aString node: aNode
	contents := aString.
	node := aNode! !

!NECEntry methodsFor: 'accessing' stamp: ''!
contents
	^contents! !

!NECEntry methodsFor: 'accessing' stamp: ''!
label
	^ 'unknown'! !

!NECEntry methodsFor: 'operations' stamp: ''!
<= aECEntry 
	^ contents <= aECEntry contents! !

!NECEntry methodsFor: 'operations' stamp: ''!
activateOn: aCompletionContext

	| entryContents |
	"By default insert the contents of the entry instead of the token in the text editor"
	entryContents := self contents asSymbol separateKeywords.
	entryContents := (self class spaceAfterCompletion
				ifTrue: [ entryContents , ' ' ]
				ifFalse: [ entryContents ]).
	aCompletionContext replaceTokenInEditorWith: entryContents! !

!NECEntry class methodsFor: 'accessing' stamp: ''!
spaceAfterCompletion: aBoolean

	SpaceAfterCompletion := aBoolean! !

!NECEntry class methodsFor: 'instance creation' stamp: ''!
contents: aString node: aNode
	^ self new contents: aString node: aNode! !

!NECEntry class methodsFor: 'accessing' stamp: ''!
spaceAfterCompletion
	
	^ SpaceAfterCompletion! !

!NECEntryDescription commentStamp: ''!
A NECEntryDescription is a holder for some information to be displayed.!
!NECEntryDescription methodsFor: 'accessing' stamp: ''!
description
  (description isNil or: [ description isEmpty ]) ifTrue: [ ^'-' ].
  ^description! !

!NECEntryDescription methodsFor: 'initialization' stamp: ''!
label: firstString title: secondString description: thirdString 
	label := firstString.
	title := secondString.
	description := thirdString! !

!NECEntryDescription methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!NECEntryDescription methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!NECEntryDescription class methodsFor: 'instance creation' stamp: ''!
label: firstString 
	^ self new
		label: firstString
		title: '(unknown)'
		description: nil! !

!NECEntryDescription class methodsFor: 'instance creation' stamp: ''!
label: firstString title: secondString description: thirdString 
	^ self new 
		label: firstString
		title: secondString
		description: thirdString! !

!NECGlobalEntry commentStamp: ''!
I represent a global variable.!
!NECGlobalEntry methodsFor: 'accessing' stamp: ''!
hightlightSymbol
	^ #globalVar! !

!NECGlobalEntry methodsFor: 'accessing' stamp: ''!
label
	^ 'global'! !

!NECInstVarEntry commentStamp: ''!
I represent an instance variable.!
!NECInstVarEntry methodsFor: 'accessing' stamp: ''!
hightlightSymbol
	^ #instVar! !

!NECInstVarEntry methodsFor: 'accessing' stamp: ''!
label
	^ 'instance variable'! !

!NECLocalEntry commentStamp: ''!
I represent a local variable: either a temporary variables, a block temporary or a method arguments.!
!NECLocalEntry methodsFor: 'accessing' stamp: ''!
label
	^ 'local variable'! !

!NECMenuMorph commentStamp: ''!
I show the possible completions in a menu like appearance. The user may choose an entry from my list and complete the word he was typing in the editor. I'm showed with the Tab key and will be deleted when with ESC key or when a successful completion occurs. The following keystrokes are supported:

Ctrl-Space or Tab: Open a new morph. Tab requires at least one character in front of the cursor. When already open complete the selected entry. 
Esc: Close me
Ctrl+u: Change to untyped mode, so I show all selectors of all classes in the system and the variables that are accessible to the current context.
Arrow Up: Move one entry up.
Arrow Down: Move one entry down
Enter: (like Ctrl-Space and Tab): Complete with the selected item and close the morph
any letter or digit: Narrow the completion further
Ctrl+t: Toggle the expand flag. When expand is disabled, you don't see selectors belonging to Object and ProtoObject. 

!
!NECMenuMorph methodsFor: 'drawing' stamp: ''!
drawLine: index on: aCanvas rectangle: rectangle
	| necEntry font type string preString highlightRectangle |
	
	necEntry := context entries at: index.
	string := necEntry contents.
	preString := string asLowercase findString: context completionToken asLowercase.
	preString := preString <= 0
		ifFalse: [ string first: preString - 1 ]
		ifTrue: [ String empty ].
	type := necEntry hightlightSymbol.
	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 
		clipBy: rectangle 
		during: [ :c | c fillRectangle: highlightRectangle color: (Color gray alpha: 0.3) ].
	aCanvas
		drawString: string
		in: (rectangle insetBy: 1)
		font: font
		color: (self selectColor: type)! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
pageUp
	self gotoPage: self currentPage - 1.
	self changed.! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
moveDown
	self selected: self selected + 1.
	(self selected > self lastVisible
			and: [self selected <= self itemsCount])
		ifTrue: [firstVisible := firstVisible + 1].
	self changed! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
showDetail
	detailMorph ifNotNil: [ ^ self browse ].
	self itemsCount isZero ifTrue: [ ^ self ].
	detailMorph := NECDetailMorph new.
	self addMorph: detailMorph.
	self updateDetail! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
pageDown
	self gotoPage: self currentPage + 1.
	self changed.! !

!NECMenuMorph methodsFor: 'private' stamp: ''!
itemsCount
	^context entryCount! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
hideDetail
	detailMorph ifNil: [ ^ false ].
	self removeMorph: detailMorph.
	detailMorph delete.
	detailMorph := nil.
	self changed.
	^ true! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
home
	self gotoPage: 1.
	self changed! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
moveUp
	(self selected = 0
			and: [self firstVisible = 1])
		ifTrue: [^ self].
	self selected: self selected - 1.
	self selected < self firstVisible
		ifTrue: [firstVisible := firstVisible - 1].
	self changed.! !

!NECMenuMorph methodsFor: 'paging' stamp: ''!
currentPage
	^(self selected - 1 // self pageHeight ) + 1.! !

!NECMenuMorph methodsFor: 'drawing' stamp: ''!
drawModelMessageOn: aCanvas in: rectangle 
	| message |
	message := context hasMessage 
		ifTrue: [ context message ]
		ifFalse: [ self detailMessage ].
	aCanvas 
		drawString: message
		in: rectangle
		font: self class messageFont
		color: Color gray! !

!NECMenuMorph methodsFor: 'drawing' stamp: ''!
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' stamp: ''!
prepareRectForNextRow: aRectangle 
	^aRectangle translateBy: 0 @ self class itemHeight! !

!NECMenuMorph methodsFor: 'private' stamp: ''!
delete
	super delete.
	engine menuClosed! !

!NECMenuMorph methodsFor: 'private' stamp: ''!
visibleItemsCount

	^ self lastVisible - self firstVisible + 1! !

!NECMenuMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self color: self class backgroundColor.
	self borderStyle: (BorderStyle color: Color gray width: 1).! !

!NECMenuMorph methodsFor: 'accessing' stamp: ''!
selected: aNumber 
	"Set the value of selected"
	context hasEntries ifTrue: 
		[ ((1 to: self itemsCount) includes: aNumber) ifTrue: [ aNumber ~= selected ifTrue: [ selected := aNumber ] ] ]! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
insertSelected
	self delete.
	context hasEntries ifFalse: [^ false].
	context activateEntryAt: self selected.
	^ true! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
show
	self resize.
	self activeHand ifNotNil: [ :hand | hand newMouseFocus: self ].
	self changed.! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
browse
	(self selectedEntry browse)
		ifTrue: [ engine closeMenu ]! !

!NECMenuMorph methodsFor: 'accessing' stamp: ''!
height
	^ 10! !

!NECMenuMorph methodsFor: 'drawing' stamp: ''!
hasMessage
	^ true! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
end
	self gotoPage: self pageCount.
	self changed.! !

!NECMenuMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: anEvent
	^ true! !

!NECMenuMorph methodsFor: 'private' stamp: ''!
updateDetail
	detailMorph
		ifNil: [^ self].
	detailMorph
		entryDescription: (self selectedEntry description);
		position: detailPosition menuWidth: self width;
		show! !

!NECMenuMorph methodsFor: 'initialization' stamp: ''!
createTitle
	| titleString transformationMorph |
	titleString := context title ifNil: [ ^ self ].
	
	titleStringMorph := StringMorph new.
	titleStringMorph 
		contents: titleString;
		font: self class messageFont.
		
	transformationMorph := TransformationMorph new.
	transformationMorph rotationDegrees: -90.0;
		offset: self position negated - (0 @ (titleStringMorph width + 12));
		addMorph: titleStringMorph.

	self addMorph: transformationMorph.
	self resize.! !

!NECMenuMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	| rectangle |
	"draw background"
	super drawOn: aCanvas.
	
	rectangle := self bounds insetBy: 1.
	rectangle := rectangle bottom: rectangle top + self class itemHeight.
	rectangle := rectangle left: rectangle left + 20.
	
	self extent: self extent.
	self firstVisible > 1 
		ifTrue: [ self drawTopScrollArrowOn: aCanvas ].
	self lastVisible ~= self itemsCount 
		ifTrue: [ self drawBottomScrollArrowOn: aCanvas ].
		
	context hasEntries 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: 'private' stamp: ''!
isClosed
	^ owner isNil! !

!NECMenuMorph methodsFor: 'paging' stamp: ''!
pageHeight
	^pageHeight.! !

!NECMenuMorph methodsFor: 'drawing' stamp: ''!
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: 'private' stamp: ''!
lastVisible

	^ (self firstVisible + self height-1)  min: (self itemsCount).! !

!NECMenuMorph methodsFor: 'accessing' stamp: ''!
selected
	"Answer the value of selected"
	selected ifNil: [ selected := self firstVisible ].
	^ selected! !

!NECMenuMorph methodsFor: 'drawing' stamp: ''!
selectColor: type
	^ self class selectColorFor: type! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
close
	self delete.! !

!NECMenuMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas 
	self drawOnCanvasWrapperFor: anAthensCanvas! !

!NECMenuMorph methodsFor: 'drawing' stamp: ''!
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: 'initialization' stamp: ''!
engine: aCompletionEngine position: aPoint
	engine := aCompletionEngine.
	context := engine context.
	self position: aPoint - (20 @ 0).
	self refreshSelection.
	self createTitle.
	self openInWorld! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
help
	self class helpText asMorph openInWindowLabeled: self class helpTitle! !

!NECMenuMorph methodsFor: 'paging' stamp: ''!
pageCount
	| count |
	self itemsCount == self pageHeight
		ifTrue: [^ 1].
	count := self itemsCount // self pageHeight.
	(self itemsCount \\ self pageHeight) > 0 
		ifTrue:[count := count + 1].
	^count! !

!NECMenuMorph methodsFor: 'paging' stamp: ''!
gotoPage: anInteger
	| item |
	item := (anInteger - 1) * self pageHeight + 1.
	item >= self itemsCount
		ifTrue: [ ^ self ].
	item := item max: 1.
	firstVisible := item.
	self selected: firstVisible! !

!NECMenuMorph methodsFor: 'accessing' stamp: ''!
detailPosition: aPoint 
	detailPosition := aPoint.
	
	self updateDetail.! !

!NECMenuMorph methodsFor: 'drawing' stamp: ''!
detailMessage

	^ String streamContents: [:stream |
		NECPreferences captureNavigationKeys ifTrue: [
			stream << (detailMorph
				ifNil: ['cmd-> open detail']
				ifNotNil: ['cmd<- close detail']	) ] ]! !

!NECMenuMorph methodsFor: 'drawing' stamp: ''!
drawMessageOn: aCanvas in: rectangle 
	self hasMessage ifFalse: [ ^ self ].
	context hasEntries ifTrue: [ 
		aCanvas 
			line: rectangle topLeft
			to: rectangle topRight
			color: Color gray ].
	self 
		drawModelMessageOn: aCanvas
		in: rectangle.! !

!NECMenuMorph methodsFor: 'private' stamp: ''!
firstVisible
	^firstVisible min: context entryCount! !

!NECMenuMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	(self bounds containsPoint: evt cursorPoint)
		ifTrue: [	
			evt wasHandled: true.
			^ self 
				selectIndexAtPoint: evt cursorPoint;
				insertSelected ].
			
	super mouseDown: evt.
	evt wasHandled: false.
	self flag: #pharoFixMe "ugly hack".
	engine editor morph owner owner
		takeKeyboardFocus;
		handleMouseDown: evt.
	self close.! !

!NECMenuMorph methodsFor: 'actions' stamp: ''!
refreshSelection

	self selected: 0.
	firstVisible := 1.
	context hasEntries ifTrue: [ self selected: 1 ].
	self show.
	^ true! !

!NECMenuMorph methodsFor: 'accessing' stamp: ''!
selectedEntry
	^ context entries at: self selected! !

!NECMenuMorph methodsFor: 'event handling' stamp: ''!
selectIndexAtPoint: aPoint
	| yPos  |
	yPos := aPoint y - self bounds top.
	selected := firstVisible + (yPos / self class itemHeight) floor.
	selected := selected min: context entries size max: 1.! !

!NECMenuMorph methodsFor: 'drawing' stamp: ''!
selectFont: aSymbol 
	^ self class selectFontFor: aSymbol! !

!NECMenuMorph methodsFor: 'testing' stamp: ''!
takesKeyboardFocus
	^ true! !

!NECMenuMorph class methodsFor: 'instance creation' stamp: ''!
engine: aCompletionEngine position: aPoint 
	^ self new engine: aCompletionEngine position: aPoint! !

!NECMenuMorph class methodsFor: 'preferences' stamp: ''!
itemWidth
	^ 250! !

!NECMenuMorph class methodsFor: 'preferences-colors' stamp: ''!
backgroundColor
	^NECPreferences backgroundColor! !

!NECMenuMorph class methodsFor: 'help text' stamp: ''!
shortcutAttributes
	^ {TextIndent  tabs: 1. TextEmphasis italic }! !

!NECMenuMorph class methodsFor: 'preferences' stamp: ''!
selectColorFor: aSymbol 
	| attribute |
	attribute := self convertToSHSymbol: aSymbol.
	^ (SHRBTextStyler new attributesFor: attribute) first color! !

!NECMenuMorph class methodsFor: 'preferences-fonts' stamp: ''!
titleFont
	^ StandardFonts windowTitleFont! !

!NECMenuMorph class methodsFor: 'preferences' stamp: ''!
maxLength
	^ 20! !

!NECMenuMorph class methodsFor: 'preferences' stamp: ''!
convertToSHSymbol: aSymbol
	^ (SHRBTextStyler new attributesFor: aSymbol) isNotEmpty
		ifTrue: [ aSymbol ]
		ifFalse: [ #default ]! !

!NECMenuMorph class methodsFor: 'help text' stamp: ''!
sectionAttributes
	^ {TextEmphasis bold}! !

!NECMenuMorph class methodsFor: 'preferences' stamp: ''!
scrollArrowSize
	^ 8! !

!NECMenuMorph class methodsFor: 'help text' stamp: ''!
explanationAttributes
	^{TextIndent tabs: 2}! !

!NECMenuMorph class methodsFor: 'preferences-fonts' stamp: ''!
messageFont
	^ StandardFonts menuFont! !

!NECMenuMorph class methodsFor: 'preferences-colors' stamp: ''!
scrollColor
	^ self theme selectionColor! !

!NECMenuMorph class methodsFor: 'help text' stamp: ''!
section: aString on: aTextStream 
	aTextStream
		withAttributes: self sectionAttributes
		do: [aTextStream nextPutAll: aString].
	aTextStream cr! !

!NECMenuMorph class methodsFor: 'help text' stamp: ''!
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: ''!
helpTitle

	^ 'Completion Keyboard Help'! !

!NECMenuMorph class methodsFor: 'preferences-fonts' stamp: ''!
selectFontFor: aSymbol 
	| emphasized attributes |
	attributes := SHRBTextStyler new 
		attributesFor: (self convertToSHSymbol: aSymbol).
	emphasized := attributes size > 1 
		ifTrue: [ attributes second emphasisCode ]
		ifFalse: [ 0 ].
	^ StandardFonts codeFont
		emphasized: emphasized! !

!NECMenuMorph class methodsFor: 'help text' stamp: ''!
shortcut: aString text: secondString on: aTextStream 
	aTextStream
		withAttributes: self shortcutAttributes
		do: [aTextStream nextPutAll: aString;
				 cr].
	aTextStream
		withAttributes: self explanationAttributes
		do: [aTextStream nextPutAll: secondString;
				 cr].! !

!NECMenuMorph class methodsFor: 'preferences' stamp: ''!
itemHeight
	^ (self selectFontFor: #default) height + 2! !

!NECPreferences commentStamp: ''!
I control the preferences for completion framework. 
It is the same for NECompletion and NOCompletion (and other potential completion algorithms should be configured here too)

!
!NECPreferences class methodsFor: 'defaults' stamp: ''!
defaultBackgroundColor
	^ self theme menuColor! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ backgroundColor! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
smartCharactersMapping
	^ smartCharactersMapping! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
smartCharactersWithDoubleSpace: aString
	smartCharactersWithDoubleSpace := aString! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
smartCharacters
	^ smartCharacters! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
availablePopupShortcuts
	^ {Character space shift . Character tab asKeyCombination}! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
popupShowAutomatic
	^ popupShowAutomatic! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
smartCharacters: aBoolean
	smartCharacters := aBoolean! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
popupAutomaticDelay: anObject
	popupAutomaticDelay := anObject! !

!NECPreferences class methodsFor: 'defaults' stamp: ''!
defaultPopupDelay
	^ 200! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
popupShowWithShortcut: anObject
	popupShowWithShortcut := anObject! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
useEnterToAccept
	^ useEnterToAccept! !

!NECPreferences class methodsFor: 'private' stamp: ''!
availableEngines
	^ AbstractCompletionEngine allSubclasses! !

!NECPreferences class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #'Code Completion')
		target: self;
		parentName: #codeBrowsing;
		selector: #enabled;
		default: true;
		iconName: #smallConfigurationIcon;
		description: 'Enable or disable code completion in browsers, debuggers and workspaces.';
		with: [ 
					| availableControllers availableSorters |
					availableControllers := self availableEngines.
					availableControllers size > 1
						ifTrue: [ 
							(aBuilder pickOne: #completionEngineClass)
								order: -1;
								label: 'CompletionEngine';
								target: RubSmalltalkEditor;
								getSelector: #completionEngineClass;
								setSelector: #completionEngineClass:;
								default: (Smalltalk at: #CoCompletionEngine);
								domainValues: availableControllers ].
					availableSorters := self availableSorters.
					availableSorters size > 1
						ifTrue: [ 
							(aBuilder pickOne: #completionSorter)
								order: -1;
								label: 'Sorter';
								target: CompletionContext;
								getSelector: #sorterClass;
								setSelector: #sorterClass:;
								domainValues: availableSorters ].
					(aBuilder setting: #backgroundColor)
						default: (Color 
							r: 0.823069403714565 
							g: 0.823069403714565 
							b: 0.823069403714565 alpha: 1.0);
						label: 'Background Color'.
					(aBuilder setting: #useEnterToAccept)
						label: 'Use ENTER to accept a suggested completion';
						default: self defaultUseEnterToAccept.
					(aBuilder setting: #captureNavigationKeys)
						default: true;
						label: 'Use navigation keys for extended completion functionality'.
					(aBuilder setting: #caseSensitive)
						label: 'Case Sensitive';
						default: true;
						description: 'Decide if you want eCompletion to be case sensitive or not.'.
					(aBuilder setting: #smartCharacters)
						label: 'Smart Characters';
						default: true;
						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';
						default: '';
				 		description: 'Enumerate the characters which are automatically inserted with a single space in between.'.
					(aBuilder setting: #smartCharactersWithDoubleSpace) 
						label: 'Smart Characters with Double Space';
						default: '[]{}';
				 		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';
						domainValues: self availablePopupShortcuts.
					(aBuilder setting: #spaceAfterCompletion)
						target: NECEntry;
						default: self defaultSpaceAfterCompletion;
						label: 'Put a space after completion'
					 ].! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
smartCharactersWithSingleSpace: aString
	smartCharactersWithSingleSpace := aString! !

!NECPreferences class methodsFor: 'private' stamp: ''!
availableSorters
	^ CompletionSorter subclasses! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
useEnterToAccept: aBoolean
	useEnterToAccept := aBoolean! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
popupShowWithShortcut
	^ popupShowWithShortcut! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
caseSensitive: aBoolean
	caseSensitive := aBoolean! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	enabled := aBoolean.! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
expandPrefixes
	^ expandPrefixes! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
popupAutomaticDelay
	^ popupAutomaticDelay! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
spaceAfterCompletion
	
	^ NECEntry spaceAfterCompletion! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
smartCharactersMapping: aDictionary
	smartCharactersMapping := aDictionary! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
popupShowAutomatic: aBoolean
	popupShowAutomatic := aBoolean! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
backgroundColor: aColor 
	backgroundColor := aColor! !

!NECPreferences class methodsFor: 'defaults' stamp: ''!
defaultPopupShortcut
	^ Character tab asShortcut! !

!NECPreferences class methodsFor: 'defaults' stamp: ''!
defaultPopupShowAutomatic
	^ true! !

!NECPreferences class methodsFor: 'defaults' stamp: ''!
defaultUseEnterToAccept
	^ true! !

!NECPreferences class methodsFor: 'class initialization' stamp: ''!
initialize
	enabled := true.
	caseSensitive := true.
	smartCharacters := true.
	expandPrefixes := true.
	captureNavigationKeys := true.
	useEnterToAccept := self defaultUseEnterToAccept.
	smartCharactersMapping := Dictionary new.
	smartCharactersMapping
		at: $( put: $) -> true;
		at: $[ put: $] -> true;
		at: ${ put: $} -> true;
		at: $" put: $" -> true;
		at: $' put: $' -> true;
		at: $< put: $> -> false;
		at: $| put: $| -> false.

	smartCharactersWithSingleSpace := ''.
	smartCharactersWithDoubleSpace := '[]{}'.
	backgroundColor := self defaultBackgroundColor.
	popupShowWithShortcut := self defaultPopupShortcut.
	popupShowAutomatic := self defaultPopupShowAutomatic.
	popupAutomaticDelay := self defaultPopupDelay.
	NECEntry spaceAfterCompletion: true! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
captureNavigationKeys: aBoolean
	captureNavigationKeys := aBoolean! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
smartCharactersWithDoubleSpace
	^ smartCharactersWithDoubleSpace! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
expandPrefixes: aBoolean
	expandPrefixes := aBoolean! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
smartCharactersWithSingleSpace
	^ smartCharactersWithSingleSpace! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
theme
	self flag: #SmalltalkReference.
	^ Smalltalk ui theme! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
captureNavigationKeys
	^ captureNavigationKeys! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
caseSensitive
	^ caseSensitive! !

!NECPreferences class methodsFor: 'accessing' stamp: ''!
enabled
	^ enabled! !

!NECPreferences class methodsFor: 'defaults' stamp: ''!
defaultSpaceAfterCompletion
	^ true! !

!NECSelectorEntry commentStamp: ''!
I represent a selector of a method!
!NECSelectorEntry methodsFor: 'private' stamp: ''!
findMethodAndDo: foundBlock ifAbsent: notfoundBlock 
	| theClass result implementors |
	theClass := node receiver propertyAt: #type ifAbsent: nil.
	result := theClass
				ifNil: [implementors := self systemNavigation allImplementorsOf: contents.
					implementors size == 1
						ifTrue: [| ref | 
							ref := implementors first.
							ref realClass lookupSelector: ref selector]
						ifFalse: [^ notfoundBlock value: contents]]
				ifNotNil: [theClass lookupSelector: contents ]. 
	^ foundBlock value: result! !

!NECSelectorEntry methodsFor: 'ui related' stamp: ''!
browse
	| class |
	class := node receiver propertyAt: #type ifAbsent: nil.
	class ifNil: [ SystemNavigation new browseAllImplementorsOf: contents. ^true].
	
	^ self
		findMethodAndDo: [ :method | 
			Smalltalk tools browser 
				openOnClass: method methodClass 
				selector: method selector. 
			true ]
		ifAbsent: [ :selector | 
			SystemNavigation new 
				browseAllImplementorsOf: selector.
			true ]! !

!NECSelectorEntry methodsFor: 'accessing' stamp: ''!
label
	"I return whether the variable is a class or a method."
	
	 ^node receiver 
		propertyAt: #type 
		ifPresent:  [ 'method' ] 
		ifAbsent:  [ 'class' ]! !

!NECSpecialVariableEntry commentStamp: ''!
I represent self, super and thisContext and in addion true, false, nil!
!NECSpecialVariableEntry methodsFor: 'accessing' stamp: ''!
label
	^ contents! !

!NECSymbolEntry commentStamp: ''!
I represent a symbol, there might be a method with this selector!
!NECSymbolEntry methodsFor: 'private' stamp: ''!
methodSourceDescription: aClass method: aCompiledMethod 
	"I return if it's a class or a method, its class name, and the implementation."
	| styler styledText |
	
	styler := SHRBTextStyler new.
	styler classOrMetaClass: aClass.
	styledText := styler styledTextFor: (aCompiledMethod sourceCode) asText.
	
	^ NECEntryDescription
		label: self label
		title: aClass printString
		description: styledText! !

!NECSymbolEntry methodsFor: 'private' stamp: ''!
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 className printString;
			cr ].
	^ NECEntryDescription 
		label: self label
		title: '(Implementors)'
		description: output contents! !

!NECSymbolEntry methodsFor: 'detail information' stamp: ''!
findMethodAndDo: foundBlock ifAbsent: notfoundBlock 
	| result  implementors |
	
	implementors := self systemNavigation allImplementorsOf: contents.
	implementors size == 1
						ifTrue: [| ref | 
							ref := implementors first.
							result := ref realClass lookupSelector: ref selector]
						ifFalse: [^ notfoundBlock value: contents].
			
	^ foundBlock value: result! !

!NECSymbolEntry methodsFor: 'private' stamp: ''!
browse
	| class |
	class := node propertyAt: #type ifAbsent: nil.
	class ifNil: [ SystemNavigation new browseAllImplementorsOf: contents. ^true].
	
	^ self
		findMethodAndDo: [ :method | 
			Smalltalk tools browser 
				openOnClass: method methodClass 
				selector: method selector. 
			true ]
		ifAbsent: [ :selector | 
			SystemNavigation new 
				browseAllImplementorsOf: selector.
			true ]! !

!NECSymbolEntry methodsFor: 'detail information' stamp: ''!
createDescription
	"Creates description either from looking up the method in a class,
	or in the system."

	^ self
		findMethodAndDo: [:method | 
			self
				methodSourceDescription: method methodClass
				method: method ]
		ifAbsent: [:selector | self implementorsDescription: selector]! !

!NECTestClass commentStamp: ''!
I'm only for SUnit TestCases.!
!NECTestClass methodsFor: 'utilities' stamp: ''!
lowPriorityOverrides: aRectangle

	messageSend := aRectangle.
	typeSuggestingParameter2 := aRectangle! !

!NECTestClass methodsFor: 'tests' stamp: ''!
testIt: anArgument 
	| loc1 x2 t |
	x2 := [:bar :var | var < bar].
	loc1 := constantArray.
	x2 value: loc1.
	t := 15.
	^ x2! !

!NECTestClass methodsFor: 'initialization' stamp: ''!
initialize: aRectangle 
	constantInteger := 15.
	constantLargeInteger := 1152921504606846976. "(SmallInteger maxVal + 1) on 64-bit"
	constantString := 'Ruben'.
	constantSymbol := #Symbol.
	constantArray := #(15 16 17 28 ).
	constantBoolean := true.
	typeSuggestingParameter := aRectangle.
	messageSend := Dictionary new.
	messageSend2 := aRectangle origin.
	globalVarKeyword := SortedCollection
				sortBlock: [:a :b | a <= b].
	globalVarKeyword2 := SortedCollection new: 15.
	constantNil := nil.
	typeSuggestingParameter2 := nil.
	complexInit := 15 > 16
				ifTrue: [#Symbol]
				ifFalse: ['String'].
	complexInit2 := Dictionary new: aRectangle origin x.! !

!NECTestClass class methodsFor: 'class initialization' stamp: ''!
initialize

	ClassVar := 'Any string'! !

!NECTestSuperClass commentStamp: ''!
I'm only for SUnit TestCases.!
!NECTestSuperClass methodsFor: 'initialization' stamp: ''!
initialize
	superInstVar := Dictionary new! !

!NECTestSuperClass methodsFor: 'utilities' stamp: ''!
toBeOverriden: anArgument 
	15 > 16
		ifTrue: [self sample * anArgument ]! !

!NECTestSuperClass methodsFor: 'tests' stamp: ''!
testIt: aString
	self subclassResponsibility! !

!NECTestSuperClass methodsFor: 'utilities' stamp: ''!
toBeOverridenWithReturn
	^ 'saga'! !

!NECTestSuperClass class methodsFor: 'class initialization' stamp: ''!
initialize
	SuperClassVar := Dictionary new! !

!NSAbstractInterpolator commentStamp: ''!
I have two ranges the start an the stop!
!NSAbstractInterpolator methodsFor: 'accessing' stamp: ''!
stop: anObject
	stop := anObject! !

!NSAbstractInterpolator methodsFor: 'accessing' stamp: ''!
start: anObject
	start := anObject! !

!NSBilinearScale commentStamp: ''!
I represent a bilinear range for 2 limits, start and end!
!NSBilinearScale methodsFor: 'hooks' stamp: ''!
rescale
	u := uninterpolate uninterpolate: domain first and: domain second.
	i := interpolate interpolate: range first and: range second.! !

!NSBilinearScale methodsFor: 'transformation' stamp: ''!
invert: anObject
	self shouldNotImplement! !

!NSBilinearScale methodsFor: 'transformation' stamp: ''!
scale: x
	^ i interpolate: (u uninterpolate: x)! !

!NSClampTest methodsFor: 'tests' stamp: ''!
testBasic01
	| x |
	
	x := NSScale linear
		domain: { -100. 100 };
		range: { 500. 1000 }.
	self deny: x clamp.
	self assert: x uninterpolate equals: NSUninterpolateNumber.
	self assert: (x scale: 0) equals: 750.
	self assert: (x scale: 200) equals: 1250.
	self assert: (x invert: 1250) equals: 200.
	
	x clamp: true.
	self assert: x uninterpolate equals: NSUninterpolateClamp.
	self assert: (x scale: 0) equals: 750.
	self assert: (x scale: 200) equals: 1000.
	self assert: (x invert: 1250) equals: 100.
	
	! !

!NSClampTest methodsFor: 'tests' stamp: ''!
testBasic03
	| x |
	
	x := NSScale log
		domain: { 1. 100 };
		range: { 500. 1000 }.
	self deny: x clamp.
	self assert: x uninterpolate equals: NSUninterpolateNumber.
	self assert: (x scale: 1) closeTo: 500.
	self assert: (x scale: 200) closeTo: 1075.2574989159953.
	self assert: (x invert: 1075.2574989159953) closeTo: 200.
	
	x clamp: true.
	self assert: x uninterpolate equals: NSUninterpolateClamp.
	self assert: (x scale: 0) closeTo: 500.
	self assert: (x scale: 200) closeTo: 1000.
	self assert: (x invert: 1250) closeTo: 100.
	
	! !

!NSClampTest methodsFor: 'tests' stamp: ''!
testBasic02
	| x |
	x := NSScale sqrt
		domain: { -100. 100 };
		range: { 500. 1000 }.
	self deny: x clamp.
	self assert: (x scale: 0) equals: 750.
	self assert: (x scale: 200) closeTo: 1103.5533905932737.
	self assert: (x invert: 1103.5533905932737) closeTo: 200.
	
	x clamp: true.
	self assert: (x scale: 0) closeTo: 750.
	self assert: (x scale: 200) closeTo: 1000.
	self assert: (x invert: 1250) closeTo: 100.
	
	! !

!NSColorHSLAInterpolator commentStamp: ''!
reate a color with the given hue, saturation, lightness, and alpha.!
!NSColorHSLAInterpolator methodsFor: 'interpolation' stamp: ''!
interpolate: t
	^ Color
		h: start hue + ((stop hue - start hue) * t)
		s: start hslSaturation + ((stop hslSaturation - start hslSaturation)  * t)
		l: start luminance + ((stop luminance - start luminance) * t)
		alpha: start alpha + ((stop alpha - start alpha) * t)! !

!NSColorHSVAInterpolator commentStamp: ''!
Same as NSColorRGBAInterpolation but for hsva  !
!NSColorHSVAInterpolator methodsFor: 'interpolation' stamp: ''!
interpolate: t
	^ Color
		h: start hue + ((stop hue - start hue) * t)
		s: start hsvSaturation + ((stop hsvSaturation - start hsvSaturation)  * t)
		l: start luminance + ((stop luminance - start luminance) * t)
		alpha: start alpha + ((stop alpha - start alpha) * t)! !

!NSColorRGBAInterpolator commentStamp: ''!
I am the interpolator  for colors!
!NSColorRGBAInterpolator methodsFor: 'interpolation' stamp: ''!
interpolate: t
	^ start interpolateTo: stop at: t! !

!NSColorRGBAInterpolator methodsFor: 'interpolation' stamp: ''!
stop: anObject
	stop := Color colorFrom: anObject! !

!NSColorRGBAInterpolator methodsFor: 'interpolation' stamp: ''!
start: anObject
	start := Color colorFrom: anObject! !

!NSColorRGBAInterpolator class methodsFor: 'color categories' stamp: ''!
paired12
	^ self colorHex: #(10931939 2062516 11722634 3383340 16489113 14883356 16629615 16744192 13284054 6962586 16777113 11622696)! !

!NSColorRGBAInterpolator class methodsFor: 'color categories' stamp: ''!
google20
	^ self colorHex: #(3368652 14432530 16750848 1087000 10027161 39366 14500983 6728192 12070446 3236757 10044569 2271897 11184657 6697932 15102720 9111303 6623335 3314274 5600422 3882668)! !

!NSColorRGBAInterpolator class methodsFor: 'helpers' stamp: ''!
hex: v
	^ (v < 16 ifTrue: [ '0' ] ifFalse: [ '' ]), v printStringHex! !

!NSColorRGBAInterpolator class methodsFor: 'color categories' stamp: ''!
category10
	^ self colorHex: #(2062260 16744206 2924588 14034728 9725885 9197131 14907330 8355711 12369186 1556175)
	! !

!NSColorRGBAInterpolator class methodsFor: 'color categories' stamp: ''!
category20c
	^ self colorHex: #(3244733 7057110 10406625 13032431 15095053 16616764 16625259 16634018 3253076 7652470 10607003 13101504 7695281 10394312 12369372 14342891 6513507 9868950 12434877 14277081)
	! !

!NSColorRGBAInterpolator class methodsFor: 'interpolation' stamp: ''!
colorInterpolator
	^ self! !

!NSColorRGBAInterpolator class methodsFor: 'helpers' stamp: ''!
colorHex: arr
	^ arr collect: [ :value | Color colorFrom: (
		(self hex: value >> 16),
		(self hex: value >> 8 & 255), 
		(self hex: value & 255))
		 ].
	! !

!NSColorRGBAInterpolator class methodsFor: 'color categories' stamp: ''!
eva10
	^ #('A57DBF' '562A65' 'A1DC5C' '46705C' 'B5A7DD' 'F1C123' 'C9783E' '605EA9' '730D0B' '5B5C65') 
		collect: [ :s | Color colorFrom: s ].! !

!NSColorRGBAInterpolator class methodsFor: 'color categories' stamp: ''!
category20
	^ self colorHex: #(2062260 11454440 16744206 16759672 2924588 10018698 14034728 16750742 9725885 12955861 9197131 12885140 14907330 16234194 8355711 13092807 12369186 14408589 1556175 10410725)
	! !

!NSColorRGBAInterpolator class methodsFor: 'color categories' stamp: ''!
category20b
	^ self colorHex: #(3750777 5395619 7040719 10264286 6519097 9216594 11915115 13556636 9202993 12426809 15186514 15190932 8666169 11356490 14049643 15177372 8077683 10834324 13528509 14589654)
	! !

!NSColorRGBAInterpolator class methodsFor: 'color categories' stamp: ''!
sky8
	^ self colorHex: #(13623528 12048360 8895960 14347240 12372694 9280950 6714002 15852509)! !

!NSInterpolator commentStamp: ''!
I determine the correct interpolator for a kind of data
my subclasses 
NSColorInterpolator
NSNumberInterpolator

The basic interpolation is between 2 values 
0 and 1, usually the value between these values is called 't'!
!NSInterpolator methodsFor: '*Roassal3-Inspector' stamp: ''!
gtCanvasForInspector
	| canvas theme boxes pos rect line cp label loc s |
 	canvas := RSCanvas new.
	theme := Smalltalk ui theme.
	canvas color: theme backgroundColor.
	s := NSScale linear domain: #(1 100); range: #(0 420).
	boxes := (0 to: 99) collect: [ :i |
		RSBox new
			size: 40;
			x: (s scale: (i / 10) asInteger) * 10 + 64;
			y: (s scale: (i % 10) asInteger) * 10 + 64;
			color: (theme caretColor alpha: 0.2);
			resetBBox;
			yourself ] as: RSGroup.
	rect := boxes encompassingRectangle.
	pos := NSScale linear
		domain: { 0@0. 1@1 };
		range: { 0 @ rect height. rect width@ 0 }.
	line := RSPolyline new 
		border: (RSBorder new 
			width: 4;
			paint: ((LinearGradientPaint fromArray: {"sweetPeriod"
					0->'3f51b1'. 
					0.13->'5a55ae'.
					0.25->'7b5fac'.
					0.38->'8f6aae'.
					0.50->'a86aa4'.
					0.62->'cc6b8e'.
					0.75->'f18271'.
					0.87->'f3a469'.
					1->'f7c978'
				})
				start: rect bottomLeft;
				stop: rect topRight;
				yourself)).
	canvas addShape: line.
	cp := OrderedCollection new.
	canvas newAnimation
		duration: 5 seconds;
		onStepDo: [ :t |
			cp add: t.
			line controlPoints: (cp collect: [:value | 
				pos scale: value @ (self interpolate: value) ]).
			canvas signalUpdate].
	canvas addAll: boxes.
	label := [ :text | 
		RSLabel new
			color: theme textColor;
			size: 20;
			text: text;
			yourself ].
	canvas addShape: (label value: '1').
	loc := RSLocation new outer.
	loc top; right;
		move: canvas shapes last on: rect.
	canvas addShape: (label value: '0').
	loc bottom; left;
		move: canvas shapes last on: rect.
	canvas addShape: (label value: 'Y').
	loc top; left;
		move: canvas shapes last on: rect.
	canvas addShape: (label value: 'X').
	loc bottom; right;
		move: canvas shapes last on: rect.
	canvas @ RSCanvasController.
	^ canvas! !

!NSInterpolator methodsFor: '*Roassal3-Inspector' stamp: ''!
inspectorCanvas
	<inspectorPresentationOrder: 90 title: 'Canvas'>
	^ SpRoassal3InspectorPresenter new
		canvas: self gtCanvasForInspector;
		yourself! !

!NSInterpolator methodsFor: '*Roassal3-Inspector' stamp: ''!
gtInspectorCanvasIn: composite
	<gtInspectorPresentationOrder: -10>
	composite roassal3
		title: ['Interpolator'];
		initializeCanvas: [ self gtCanvasForInspector ]! !

!NSInterpolator methodsFor: 'interpolation' stamp: ''!
interpolate: anObject
	self subclassResponsibility! !

!NSInterpolator class methodsFor: 'interpolation' stamp: ''!
colorInterpolator
	^ NSColorRGBAInterpolator! !

!NSInterpolator class methodsFor: 'interpolation' stamp: ''!
interpolatorFor: b
	(b isString or: [ b isColor ]) ifTrue: [ ^ self colorInterpolator ].
	b isNumber ifTrue: [ ^ NSNumberInterpolator ].
	b isPoint ifTrue: [ ^ NSNumberInterpolator ].
	self error: 'Invalid value for interpolator'! !

!NSInterpolator class methodsFor: 'interpolation' stamp: ''!
interpolate: a and: b
	| clazz |
	clazz := self interpolatorFor: b.
	^ clazz new start: a; stop: b.! !

!NSLinearScale commentStamp: ''!
I follow the linear function!
!NSLinearScale methodsFor: 'accessing' stamp: ''!
input
	^ input! !

!NSLinearScale methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	range := domain := #(0 1).
	clamp := false.
	interpolate := NSInterpolator.
	self rescale.! !

!NSLinearScale methodsFor: 'accessing' stamp: ''!
clamp
	^ clamp! !

!NSLinearScale methodsFor: 'accessing' stamp: ''!
domain: x
	super domain: x.
	self rescale.! !

!NSLinearScale methodsFor: 'accessing' stamp: ''!
range: r
	super range: r.
	self rescale.! !

!NSLinearScale methodsFor: 'accessing' stamp: ''!
rangeRound: x
	"x is a range"
	self 
		range: x;
		interpolate: NSRoundInterpolator.! !

!NSLinearScale methodsFor: 'accessing' stamp: ''!
output
	^ output! !

!NSLinearScale methodsFor: 'hooks' stamp: ''!
rescale
	| linear |
	linear := (domain size min: range size ) > 2
		ifTrue: [ NSPolylinearScale ]
		ifFalse: [ NSBilinearScale ].
	uninterpolate := clamp
		ifTrue: [ NSUninterpolateClamp ]
		ifFalse: [ NSUninterpolateNumber ].
	output := linear new domain: domain; range: range; 
		uninterpolate: uninterpolate; interpolate: interpolate.
	output rescale.
	input := linear new domain: range; range: domain;
		uninterpolate: uninterpolate; interpolate: NSInterpolator.
	input rescale.! !

!NSLinearScale methodsFor: 'transformation' stamp: ''!
invert: y
	^ input scale: y.! !

!NSLinearScale methodsFor: 'accessing' stamp: ''!
interpolate: x
	interpolate := x.
	self rescale.! !

!NSLinearScale methodsFor: 'accessing' stamp: ''!
clamp: aBool
	"If clamp is specified, enables or disables clamping accordingly. If clamping is disabled and the scale is passed a value outside the domain, the scale may return a value outside the range through extrapolation. If clamping is enabled, the return value of the scale is always within the scale’s range."
	clamp := aBool.
	self rescale.! !

!NSLinearScale methodsFor: 'transformation' stamp: ''!
scale: x
	^ output scale: x! !

!NSLinearScaleTest commentStamp: ''!
A NSLinearScaleTest is a test class for testing the behavior of NSLinearScale!
!NSLinearScaleTest methodsFor: 'running' stamp: ''!
classToTest
	^ NSLinearScale! !

!NSLinearScaleTest methodsFor: 'test - linear' stamp: ''!
testScaleLinearInvert
	| linear |
	linear := self classToTest new
		domain: #(-5 5);
		range: #(40 50).
	self 
		assert: (linear scale: 0) equals: 45;
		assert: (linear scale: 5) equals: 50;
		assert: (linear invert: 50) equals: 5;
		assert: (linear invert: 40) equals: -5
	! !

!NSLinearScaleTest methodsFor: 'test - linear' stamp: ''!
testScaleLinearColors
	| linear |
	linear := self classToTest new
		domain: #(0 100);
		range: #('white' 'black').
	self assert: (linear scale: 50) equals: Color gray.
	self assert: (linear scale: 0) equals: Color white.
	self assert: (linear scale: 100) equals: Color black.	! !

!NSLinearScaleTest methodsFor: 'test - scales' stamp: ''!
testSameRange
	| sc |
	sc := self classToTest new
		domain: #(0 100);
		range: #(100 100).
	self assert: (sc scale: 0) equals: 100.
	self assert: (sc scale: 50) equals: 100.
	self assert: (sc scale: 100) equals: 100.
	self assert: (sc scale: 123123) equals: 100.

	sc := NSScale linear
		domain: #(0 100);
		range: #(0 0).
	self assert: (sc scale: 0) equals: 0.
	self assert: (sc scale: 50) equals: 0.
	self assert: (sc scale: 100) equals: 0.
	self assert: (sc scale: 123123) equals: 0.! !

!NSLinearScaleTest methodsFor: 'test - linear' stamp: ''!
testScaleLinearRound
	| linear |
	linear := self classToTest new
		domain: #(-5 5);
		rangeRound: #(40 50).
	self 
		assert: (linear scale: 0.2) equals: 45;
		assert: (linear scale: 5.1) equals: 50;
		assert: (linear invert: 50) equals: 5;
		assert: (linear invert: 40) equals: -5
	! !

!NSLinearScaleTest methodsFor: 'test - linear' stamp: ''!
testScaleLinearClamp
	| linear |
	linear := self classToTest new
		domain: #(0 10);
		range: #(0 100).
	self assert: (linear scale: 11) equals: 110.
	self assert: (linear scale: -5) equals: -50.
	linear clamp: true.
	self assert: (linear scale: 11) equals: 100.
	self assert: (linear scale: -5) equals: 0.! !

!NSLinearScaleTest methodsFor: 'test - linear' stamp: ''!
testScaleLinear
	| linear |
	linear := self classToTest new.
	self 
		assert: linear domain equals: #(0 1);
		assert: linear range equals: #(0 1).
	linear range: #(1 10).
	self
		assert: (linear scale: 1) equals: 10;
		assert: (linear scale: 0.5) equals: 5.5.
		
	self assert: linear interpolate equals: NSInterpolator.
	self assert: linear uninterpolate equals: NSUninterpolateNumber.
	
	! !

!NSLnScale commentStamp: ''!
I use natural logarithms to compute scales.!
!NSLnScale methodsFor: 'accessing' stamp: ''!
initialize
	super initialize.
	linear := self class linear.! !

!NSLnScale methodsFor: 'accessing' stamp: ''!
clamp
	^ linear clamp! !

!NSLnScale methodsFor: 'accessing' stamp: ''!
domain: arr
	domain := arr collect: [:i | i max: Float epsilon ].
	linear domain: (domain collect: [:n | n ln ]).! !

!NSLnScale methodsFor: 'accessing' stamp: ''!
range: x
	linear range: x! !

!NSLnScale methodsFor: 'accessing' stamp: ''!
interpolate
	^ linear interpolate! !

!NSLnScale methodsFor: 'accessing' stamp: ''!
invert: x
	^ (linear invert: x) exp.! !

!NSLnScale methodsFor: 'accessing' stamp: ''!
interpolate: x
	linear interpolate: x! !

!NSLnScale methodsFor: 'accessing' stamp: ''!
clamp: x
	 linear clamp: x! !

!NSLnScale methodsFor: 'accessing' stamp: ''!
scale: x
	^ linear scale: (x max: Float epsilon) ln! !

!NSLnScale methodsFor: 'accessing' stamp: ''!
range
	^ linear range! !

!NSLogScale commentStamp: ''!
for scale log, for positive domains or negative domains!
!NSLogScale methodsFor: 'accessing' stamp: ''!
uninterpolate: anUninterolator
	linear uninterpolate: anUninterolator! !

!NSLogScale methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	linear := self class linear.
	base := 10.
	positive := true.
	domain := #(1 0).! !

!NSLogScale methodsFor: 'accessing' stamp: ''!
clamp
	^ linear clamp! !

!NSLogScale methodsFor: 'accessing' stamp: ''!
domain: arr
	positive := arr first >= 0.
	domain := arr.
	linear domain: (arr collect: [:n | self lg: n]).! !

!NSLogScale methodsFor: 'accessing' stamp: ''!
range: x
	linear range: x! !

!NSLogScale methodsFor: 'math functions' stamp: ''!
pow: x
	^ positive  
		ifTrue: [ base raisedTo: x ]
		ifFalse: [ (base raisedTo: x negated) negated ].
		! !

!NSLogScale methodsFor: 'accessing' stamp: ''!
interpolate
	^ linear interpolate! !

!NSLogScale methodsFor: 'transformation' stamp: ''!
invert: x
	^ self pow: (linear invert: x).! !

!NSLogScale methodsFor: 'accessing' stamp: ''!
interpolate: x
	linear interpolate: x! !

!NSLogScale methodsFor: 'accessing' stamp: ''!
base
	^ base! !

!NSLogScale methodsFor: 'accessing' stamp: ''!
clamp: x
	 linear clamp: x! !

!NSLogScale methodsFor: 'transformation' stamp: ''!
scale: x
	^ linear scale: (self lg: x)! !

!NSLogScale methodsFor: 'math functions' stamp: ''!
lg: x
	"logarithm"
	^ (positive 
		ifTrue: [ (x max: 0) ln ]
		ifFalse: [ (x > 0 
			ifTrue: [ 0 ] 
			ifFalse: [ 0 - x ] ) ln negated ])
		/ (base ln).
		! !

!NSLogScale methodsFor: 'accessing' stamp: ''!
range
	^ linear range! !

!NSLogScale methodsFor: 'accessing' stamp: ''!
base: number
	base := number.
	linear domain: (domain collect: [:n | self lg: n ]).! !

!NSLogScale methodsFor: 'accessing' stamp: ''!
uninterpolate
	^ linear uninterpolate! !

!NSLogScaleTest commentStamp: ''!
A NSLogScaleTest is a test class for testing the behavior of NSLogScale!
!NSLogScaleTest methodsFor: 'test - scales' stamp: ''!
testLogScale
	| log |
	log := NSLogScale new.
	self 
		assert: log base equals: 10;
		assert: log range equals: #(0 1);
		assert: (log scale: 10) equals: 1;
		assert: (log scale: 100) equals: 2;
		assert: (log scale: 50) equals: 1.6989700043360185.
	log := NSLogScale new
		base: Float e;
		domain: (#(0 9) collect: #exp);
		range: #(200 0).
	self assert: ((log scale: 50) closeTo: 113.0661554349301).
	self assert: ((log scale: 0.01) closeTo: 302.3371152441798).
	self assert: ((log scale: 100) closeTo: 97.66288475582019).
	self assert: ((log invert: 10) closeTo: 5166.754427175983).
	
	self assert: (log scale: 9000) closeTo: -2.3328856959635047.
	log clamp: true.
	self
		assert: (log scale: 9000) closeTo: 0;
		assert: log interpolate equals: NSInterpolator.
	log interpolate: NSInterpolator
	
! !

!NSLogScaleTest methodsFor: 'test - scales' stamp: ''!
testNA
	| log |
	log := NSLogScale new.
	self assert: (log scale: 10) closeTo: 1.0.
	self assert: (log scale: 1) closeTo: 0.
	self assert: (log scale: 0.5) closeTo: -0.30102999566398114.
	self assert: (log scale: 0.1) closeTo: -0.9999999999999998.
	self assert: (log scale: 0.001) closeTo: -2.9999999999999996.
	self assert: (log scale: 0) isNaN.
	self assert: (log scale: -1) isNaN.
	self assert: (log scale: -10) isNaN.! !

!NSNumberInterpolator commentStamp: ''!
I am the basic interpolator for numbers!
!NSNumberInterpolator methodsFor: 'interpolation' stamp: ''!
interpolate: t
	^ (start * (1 - t)) + (stop * t).! !

!NSOrdinalScale commentStamp: ''!
I am a scale for ordinal ranges!
!NSOrdinalScale methodsFor: 'helpers' stamp: ''!
steps: start and: step
	^ (0 to: domain size - 1) collect: [ :i | (start + (step * i)) asFloat ].! !

!NSOrdinalScale methodsFor: 'accessing' stamp: ''!
rangeExtent
	^ self scaleExtent: argument first! !

!NSOrdinalScale methodsFor: 'helpers' stamp: ''!
scaleExtent: d
	| start stop |
	start := d first.
	stop := d last.
	^ start < stop
		ifTrue: [ Array with: start with: stop ]
		ifFalse: [ Array with: stop with: start ]! !

!NSOrdinalScale methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	ranger := #range:.
	argument := #( #() ).
	self domain: #().
	
	! !

!NSOrdinalScale methodsFor: 'public' stamp: ''!
rangeRoundPoints: x
	self rangeRoundPoints: x padding: 0! !

!NSOrdinalScale methodsFor: 'accessing' stamp: ''!
rangeFrom: array
	self range: (array collect: [ :val | Color colorFrom: val ])! !

!NSOrdinalScale methodsFor: 'accessing' stamp: ''!
domain: arr
	domain := OrderedCollection new.
	dictionary := Dictionary new.
	arr do: [ :xi |
		dictionary at: xi ifAbsentPut: [ 
			domain add: xi.
			domain size ] ].
	self perform: ranger withArguments: argument! !

!NSOrdinalScale methodsFor: 'public' stamp: ''!
rangeBands: x padding: padding
	self rangeBands: x padding: padding outerPadding: padding! !

!NSOrdinalScale methodsFor: 'accessing' stamp: ''!
dictionary 
	^ dictionary ! !

!NSOrdinalScale methodsFor: 'public' stamp: ''!
rangeBands: x
	self rangeBands: x padding: 0! !

!NSOrdinalScale methodsFor: 'accessing' stamp: ''!
range: x
	range := x.
	rangeBand := 0.
	ranger := #range:.
	argument := Array with: x.! !

!NSOrdinalScale methodsFor: 'accessing' stamp: ''!
rangeBand
	^ rangeBand! !

!NSOrdinalScale methodsFor: 'public' stamp: ''!
rangeRoundBands: x padding: padding outerPadding: outerPadding
	| start stop step reverse |
	start := x first.
	stop := x second.
	reverse := false.
	start > stop ifTrue: [| t |
		t := start. start := stop. stop := t.
		reverse := true. ].
	step := ((stop - start) / (domain size - padding + (2*outerPadding))) floor.
	
	range := self 
		steps: start + ( (stop - start - ((domain size - padding) * step) ) / 2 ) rounded
		and: step.
	reverse ifTrue: [ range := range reverse ].
	rangeBand := (step * (1 - padding)) rounded.
	ranger := #rangeRoundBands:padding:outerPadding:.
	argument := Array with: x with: padding with: outerPadding! !

!NSOrdinalScale methodsFor: 'public' stamp: ''!
rangeRoundPoints: x padding: padding
	| start stop step |
	start := x first.
	stop := x second.
	step := domain size < 2
		ifTrue: [ start := stop := ((start + stop)/2) rounded. 0 ]
		ifFalse: [[ (stop - start)/(domain size -1 + padding)]
			on: Error do: [ :ex | 0 ] ].
		
	range := self 
		steps: start + ((step * padding / 2) + (stop - start - 
			((domain size - 1 + padding)* step) )/ 2) rounded
		and: step.
	rangeBand := 0.
	ranger := #rangeRoundPoints:padding:.
	argument := Array with: x with: padding! !

!NSOrdinalScale methodsFor: 'transformation' stamp: ''!
invert: anObject
	self shouldNotImplement! !

!NSOrdinalScale methodsFor: 'public' stamp: ''!
rangeRoundBands: x
	self rangeRoundBands: x padding: 0! !

!NSOrdinalScale methodsFor: 'public' stamp: ''!
rangePoints: x
	self rangePoints: x padding: 0! !

!NSOrdinalScale methodsFor: 'public' stamp: ''!
rangeBands: x padding: padding outerPadding: outerPadding
	| start stop step reverse |
	start := x first.
	stop := x second.
	reverse := false.
	start > stop ifTrue: [| t |
		t := start. start := stop. stop := t.
		reverse := true. ].
	step := (stop - start) / (domain size - padding + (2*outerPadding)).
	
	range := self 
		steps: start + (step * outerPadding)
		and: step.
	reverse ifTrue: [ range := range reverse ].
	rangeBand := step * (1 - padding).
	
	range doWithIndex: [ :val :in | range at: in put: val + (rangeBand / 2.0) ].
	ranger := #rangeBands:padding:outerPadding:.
	argument := Array with: x with: padding with: outerPadding! !

!NSOrdinalScale methodsFor: 'transformation' stamp: ''!
scale: x
	| index |
	index := dictionary at: x ifAbsent: [ nil ].
	(index isNil and: [ ranger = #range:]) ifTrue: [
		domain add: x.
		dictionary at: x put: (index := domain size).
		].
	index ifNil: [ ^ NSScale linear domain: domain; range: range; scale: x ].
	index := index % range size.
	index isZero 
		ifTrue: [ index := range size ].
	^ range at: index! !

!NSOrdinalScale methodsFor: 'public' stamp: ''!
rangeRoundBands: x padding: padding
	self rangeRoundBands: x padding: padding outerPadding: padding! !

!NSOrdinalScale methodsFor: 'public' stamp: ''!
rangePoints: x padding: padding
	| start stop step |
	start := x first.
	stop := x second.
	step := domain size < 2
		ifTrue: [ start := (start  + stop)/2. 0 ]
		ifFalse: [ (stop - start)/(domain size - 1 + padding) ].
	range := self 
		steps: start + (step * padding / 2)
		and: step.
	rangeBand := 0.
	
	ranger := #rangePoints:padding:.
	argument := Array with: x with: padding! !

!NSOrdinalScaleTest commentStamp: ''!
A NSOrdinalScaleTest is a test class for testing the behavior of NSOrdinalScale!
!NSOrdinalScaleTest methodsFor: 'running' stamp: ''!
classToTest
	^ NSOrdinalScale! !

!NSOrdinalScaleTest methodsFor: 'test - scales' stamp: ''!
testOrdinalScaleRangeRoundPoints
	| ordinal |
	ordinal := self classToTest new
		domain: #(1 2 3 4);
		rangeRoundPoints: #(0 100).
	self 
		assert: ordinal rangeBand equals: 0;
		assert: (ordinal scale: 1) equals: 0;
		assert: (ordinal scale: 2) equals: 33.333333333333333;
		assert: (ordinal scale: 4) equals: 100.
	! !

!NSOrdinalScaleTest methodsFor: 'test - scales' stamp: ''!
testOrdinalScale
	| ordinal |
	ordinal := self classToTest new
		domain: #('a' 'b' 'c' 'd' 'e' 'f');
		range: #(10 20 30 40 50 60).
	self 
		assert: (ordinal scale: 'a') equals: 10;
		assert: (ordinal scale: 'd') equals: 40;
		assert: (ordinal scale: 'f') equals: 60.
		! !

!NSOrdinalScaleTest methodsFor: 'test - scales' stamp: ''!
testOrdinalScaleRangeBands
	| ordinal |
	ordinal := self classToTest new
		domain: #('a' 'b' 'c' 'd' 'e' 'f');
		rangeBands: #(0 960).
	self 
		assert: ordinal rangeBand equals: 160;
		assert: (ordinal scale: 'a') equals: 80.0;
		assert: (ordinal scale: 'd') equals: 560.0;
		assert: (ordinal scale: 'f') equals: 880.0;
		
		assert: ordinal rangeExtent equals: #(0 960)! !

!NSOrdinalScaleTest methodsFor: 'test - scales' stamp: ''!
testOrdinalScaleRangeRoundBands
	| ordinal |
	ordinal := self classToTest new
		domain: #('a' 'b' 'c' 'd' 'e' 'f');
		rangeRoundBands: #(0 960) padding: 0.1.
	self 
		assert: ordinal rangeBand equals: 141;
		assert: (ordinal scale: 'a') equals: 17;
		assert: (ordinal scale: 'd') equals: 488;
		assert: (ordinal scale: 'f') equals: 802;
		assert: ordinal rangeExtent equals: #(0 960).
		
	ordinal := NSScale ordinal
		domain: #('a' 'b' 'c' 'd' 'e' 'f');
		rangeRoundBands: #(0 960).
	self 
		assert: ordinal rangeBand equals: 160;
		assert: (ordinal scale: 'a') equals: 0;
		assert: (ordinal scale: 'd') equals: 480;
		assert: (ordinal scale: 'f') equals: 800;
		assert: ordinal rangeExtent equals: #(0 960)! !

!NSOrdinalScaleTest methodsFor: 'test - scales' stamp: ''!
testOrdinalScaleRangePoints
	| ordinal |
	ordinal := self classToTest new
		domain: #('apple' 'orange' 'banana' 'grape');
		rangePoints: #(0 960).
	self 
		assert: (ordinal scale: 'apple') equals: 0;
		assert: (ordinal scale: 'orange') equals: 320;
		assert: (ordinal scale: 'grape') equals: 960;
		
		assert: ordinal rangeExtent equals: #(0 960)
	
		! !

!NSPerlinNoise commentStamp: ''!
Based on http://webstaff.itn.liu.se/~stegu/simplexnoise/simplexnoise.pdf!
!NSPerlinNoise methodsFor: 'initialization' stamp: ''!
initialize
	| p |
	super initialize.
	grad3 := #( 
		#(1 1 0) 
		#(-1 1 0) 
		#(1 -1 0)
		#(-1 -1 0)
		#(1 0 1)
		#(-1 0 1)
		#(1 0 -1)
		#(-1 0 -1)
		#(0 1 1)
		#(0 -1 1)
		#(0 1 -1)
		#(0 -1 -1)).
		
	p := #(151 160 137 91 90 15 131 13 201 95 96 53 194 233 7 225 140 36 103 30 69 142 8 99 37 240 21 10 23 190 6 148 247 120 234 75 0 26 197 62 94 252 219 203 117 35 11 32 57 177 33 88 237 149 56 87 174 20 125 136 171 168 68 175 74 165 71 134 139 48 27 166 77 146 158 231 83 111 229 122 60 211 133 230 220 105 92 41 55 46 245 40 244 102 143 54 65 25 63 161 1 216 80 73 209 76 132 187 208 89 18 169 200 196 135 130 116 188 159 86 164 100 109 198 173 186 3 64 52 217 226 250 124 123 5 202 38 147 118 126 255 82 85 212 207 206 59 227 47 16 58 17 182 189 28 42 223 183 170 213 119 248 152 2 44 154 163 70 221 153 101 155 167 43 172 9 129 22 39 253 19 98 108 110 79 113 224 232 178 185 112 104 218 246 97 228 251 34 242 193 238 210 144 12 191 179 162 241 81 51 145 235 249 14 239 107 49 192 214 31 181 199 106 157 184 84 204 176 115 121 50 45 127 4 150 254 138 236 205 93 222 114 67 29 24 72 243 141 128 195 78 66 215 61 156 180).
	perm := Array new: 512.
	1 to: 256 do: [ :i | | v |
		v := p at: i.
		perm at: i put: v.
		perm at: i + 256 put: v ].
	! !

!NSPerlinNoise methodsFor: 'public' stamp: ''!
noise: xin and: yin
	"all this proces explained in http://webstaff.itn.liu.se/~stegu/simplexnoise/simplexnoise.pdf"
	| f2 s i j g2 t xzero yzero x0 y0 i1 j1 x1 y1 x2 y2 ii jj gi0 gi1 gi2 t0 n0 t1 n1 t2 n2 |
	f2 := 0.5 * (3 sqrt - 1).
	s := (xin + yin) * f2.
	i := (xin + s) floor.
	j := (yin + s) floor.
	g2 := (3 - 3 sqrt) / 6.
	t := (i + j) * g2.
	xzero := i - t.
	yzero := j - t.
	x0 := xin - xzero.
	y0 := yin - yzero.
	x0 > y0 ifTrue: [ 
		i1 := 1.
		j1 := 0 ]
		ifFalse: [ 
		i1 := 0.
		j1 := 1 ].
	x1 := x0 - i1 + g2.
	y1 := y0 - j1 + g2.
	x2 := x0 - 1 + (2* g2).
	y2 := y0 - 1 + (2* g2).
	
	ii := i & 255.
	jj := j & 255.
	
	gi0 := (self permAt: ii + (self permAt: jj)) % 12.
	gi1 := (self permAt: ii + i1 + (self permAt: jj + j1)) % 12.
	gi2 := (self permAt: ii + 1 + (self permAt: jj + 1) ) % 12.
	
	t0 := 0.5 - (x0 * x0) - (y0 * y0).
	t0 < 0 ifTrue: [ n0 := 0 ] ifFalse: [ 
		t0 := t0 * t0.
		n0 := t0 * t0 * (self dot: (self grad3At: gi0) and: x0 and: y0 ) ].
	t1 := 0.5 - (x1*x1) - (y1 * y1).
	t1 < 0 ifTrue: [ n1 := 0 ] ifFalse: [ 
		t1 := t1 * t1.
		n1 := t1 * t1 * (self dot: (self grad3At: gi1) and: x1 and: y1 ) ].
	t2 := 0.5 - (x2 * x2) - (y2 * y2).
	t2 < 0 ifTrue: [ n2 := 0 ] ifFalse: [ 
		t2 := t2 * t2.
		n2 := t2 * t2 * (self dot: (self grad3At: gi2) and: x2 and: y2) ].
	^ 70.0 * (n0 + n1 + n2).
	


! !

!NSPerlinNoise methodsFor: 'accessing' stamp: ''!
permAt: index
	^ perm at: index + 1! !

!NSPerlinNoise methodsFor: 'accessing' stamp: ''!
grad3At: index
	^ grad3 at: index + 1! !

!NSPerlinNoise methodsFor: 'private' stamp: ''!
dot: arr and: x and: y
	^ (arr first * x) + (arr second * y)! !

!NSPerlinNoise2 commentStamp: ''!
Based on Ken Perlin!
!NSPerlinNoise2 methodsFor: 'public' stamp: ''!
noise: xin y: yin z: zin
	"(NSPerlinNoise2 new noise: 3.14 y: 42 z: 7) >>> 0.13691995878400012"
	| x0 y0 z0 x y z u v w a aa ab b ba bb |
	x0 := xin floor & 255.
	y0 := yin floor & 255.
	z0 := zin floor & 255.
	x := xin - xin floor.
	y := yin - yin floor.
	z := zin - zin floor.
	u := self fade: x.
	v := self fade: y.
	w := self fade: z.
	a := (p at: x0)+y0.
	aa := (p at: a)+z0.
	ab := (p at: a+1)+z0.
	b := (p at: x0+1)+y0.
	ba := (p at: b) + z0.
	bb := (p at: b+1) + z0.
	"result will cover the range [-1,1]"
	^ self lerp: w 
		a: (self lerp: v
			a: (self lerp: u 
				a: (self grad: (p at: aa) x: x 	y: y z: z)
				b: (self grad: (p at: ba) x: x-1	y: y z: z) )  
			b: (self lerp: u
				a: (self grad: (p at: ab) x: x 	y: y-1 z: z)
				b: (self grad: (p at: bb) x: x-1	y: y-1 z: z) ) )
		b: (self lerp: v
			a: (self lerp: u 
				a: (self grad: (p at: aa+1) x: x 	y: y z: z-1)
				b: (self grad: (p at: ba+1) x: x-1	y: y z: z-1) )  
			b: (self lerp: u
				a: (self grad: (p at: ab+1) x: x 	y: y-1 z: z-1)
				b: (self grad: (p at: bb+1) x: x-1	y: y-1 z: z-1) ) )! !

!NSPerlinNoise2 methodsFor: 'public' stamp: ''!
fade: t
	^ t * t * t * (t * (t * 6 - 15) + 10 )! !

!NSPerlinNoise2 methodsFor: 'initialization' stamp: ''!
initialize
	| permutation |
	super initialize.
	p := Dictionary new.
	permutation :=#(151 160 137 91 90 15 131 13 201 95 96 53 194 233 7 225 140 36 103 30 69 142 8 99 37 240 21 10 23 190 6 148 247 120 234 75 0 26 197 62 94 252 219 203 117 35 11 32 57 177 33 88 237 149 56 87 174 20 125 136 171 168 68 175 74 165 71 134 139 48 27 166 77 146 158 231 83 111 229 122 60 211 133 230 220 105 92 41 55 46 245 40 244 102 143 54 65 25 63 161 1 216 80 73 209 76 132 187 208 89 18 169 200 196 135 130 116 188 159 86 164 100 109 198 173 186 3 64 52 217 226 250 124 123 5 202 38 147 118 126 255 82 85 212 207 206 59 227 47 16 58 17 182 189 28 42 223 183 170 213 119 248 152 2 44 154 163 70 221 153 101 155 167 43 172 9 129 22 39 253 19 98 108 110 79 113 224 232 178 185 112 104 218 246 97 228 251 34 242 193 238 210 144 12 191 179 162 241 81 51 145 235 249 14 239 107 49 192 214 31 181 199 106 157 184 84 204 176 115 121 50 45 127 4 150 254 138 236 205 93 222 114 67 29 24 72 243 141 128 195 78 66 215 61 156 180).
	0 to: 255 do: [ :i |
		p at: 256 + i put: (p at: i put: (permutation at: i + 1) ) ]! !

!NSPerlinNoise2 methodsFor: 'public' stamp: ''!
snoise: xin and: yin
	"range #(0 1)"
	^((self noise: xin and: yin) + 1)/2! !

!NSPerlinNoise2 methodsFor: 'public' stamp: ''!
noise: xin and: yin
	^ self noise: xin y: yin z: 0! !

!NSPerlinNoise2 methodsFor: 'public' stamp: ''!
noise: xin
	^ self noise: xin y: 0 z: 0! !

!NSPerlinNoise2 methodsFor: 'public' stamp: ''!
lerp: t a: a b: b
	^ t * (b - a) + a! !

!NSPerlinNoise2 methodsFor: 'public' stamp: ''!
grad: hash x: x y: y z: z
	| h u v |
	h := hash & 15.
	u := h < 8
		ifTrue: [ x ]
		ifFalse: [ y ].
	v := h < 4
		ifTrue: [ y ]
		ifFalse: [ ((h = 12) or: [ h = 14 ])
				ifTrue: [ x ]
				ifFalse: [ z ] ].
	^ (h & 1 = 0
		ifTrue: [ u ]
		ifFalse: [ u negated ])
		+
			((h & 2) = 0
				ifTrue: [ v ]
				ifFalse: [ v negated ])! !

!NSPerlinNoise3 commentStamp: ''!
based on https://mrl.nyu.edu/~perlin/noise/!
!NSPerlinNoise3 methodsFor: 'initialization' stamp: ''!
initialize
	| r |
	super initialize.
	fallOff := 0.5.
	self octaves: 1.
	r := Random new.
	p := Dictionary new.
	0 to: 511 do: [ :i | 
		p at: i put: (r next * 256) asInteger ].! !

!NSPerlinNoise3 methodsFor: 'accessing' stamp: ''!
fallOff: aFloat
	"aFloat between 0 and 1"
	fallOff := aFloat! !

!NSPerlinNoise3 methodsFor: 'public' stamp: ''!
noise: xin and: yin
	| e k s |
	e := 1.
	k := 1.
	s := 0.
	1 to: octaves do: [ :i | 
		e := e * fallOff.
		s := s + (e * (1 + (self noise2d: k * xin and: k * yin)/2) ).
		k := k * 2 ].
	^ s! !

!NSPerlinNoise3 methodsFor: 'accessing' stamp: ''!
octaves: anInteger
	octaves := anInteger! !

!NSPerlinNoise3 methodsFor: 'public' stamp: ''!
noise: aPoint
	^ self noise: aPoint x and: aPoint y! !

!NSPerlinNoise3 methodsFor: 'public' stamp: ''!
lerp: t a: a b: b
	^ t * (b - a) + a! !

!NSPerlinNoise3 methodsFor: 'public' stamp: ''!
noise2d: xin and: yin
	| x1 y1 x y fx fy p0 p1 |
	x1 := xin floor & 255.
	y1 := yin floor & 255.
	x := xin - xin floor.
	y := yin - yin floor.
	fx := (3- (2 * x)) * x * x.
	fy := (3 -(2 * y)) * y * y.
	p0 := (p at: x1) + y1.
	p1 := (p at: x1 + 1)+ y1.
	^ self lerp: fy 
		a: (self lerp: fx
			a: (self grad2d: (p at: p0) x: x y: y)
			b: (self grad2d: (p at: p1) x: x -1 y: y))
		b: (self lerp: fx
			a: (self grad2d: (p at: p0+1) x: x y: y-1)
			b: (self grad2d: (p at: p1+1) x: x -1 y: y-1)).! !

!NSPerlinNoise3 methodsFor: 'accessing' stamp: ''!
fallOff

	^ fallOff! !

!NSPerlinNoise3 methodsFor: 'public' stamp: ''!
grad2d: i x: x y: y
	| v |
	v := (i &1) = 0 
		ifTrue: [ x ] 
		ifFalse: [ y ].
	^ (i & 2) = 0 ifTrue: [ v negated ] ifFalse: [ v ]! !

!NSPolylinearScale commentStamp: ''!
I can handle a several kind of values!
!NSPolylinearScale methodsFor: 'hooks' stamp: ''!
rescale
	| obj |
	u := OrderedCollection new.
	i := OrderedCollection new.
	k := domain size min: range size.
	obj := domain at: k.
	
	((obj class canUnderstand: #<) and: [obj < domain first]) ifTrue: [
		domain := domain reverse.
		range := range reverse ].
	
	2 to: k do: [ :j | 
		u add: (uninterpolate uninterpolate: (domain at: j -1 ) and: (domain at: j)).
		i add: (interpolate interpolate: (range at: j -1) and: (range at: j) )
		 ].
	
	! !

!NSPolylinearScale methodsFor: 'transformation' stamp: ''!
invert: anObject
	self shouldNotImplement! !

!NSPolylinearScale methodsFor: 'private' stamp: ''!
findJ: x
	| lo hi mid |
	lo := 2.
	hi := k.
	[ lo < hi ] whileTrue: [ 
		mid := ((lo + hi) / 2) asInteger.
		(domain at: mid) > x 
			ifTrue: [ hi := mid ]
			ifFalse: [ lo := mid + 1 ] ].
	^ lo - 1 ! !

!NSPolylinearScale methodsFor: 'transformation' stamp: ''!
scale: x
	| j |
	j := self findJ: x.
	^ (i at: j) interpolate: ((u at: j) uninterpolate: x)
	! !

!NSPolylinearScaleTest commentStamp: ''!
A NSPolylinearScaleTest is a test class for testing the behavior of NSPolylinearScale!
!NSPolylinearScaleTest methodsFor: 'test - linear' stamp: ''!
testScalePolyLinear
	| linear |
	linear := NSScale linear
		domain: #(0 0.5 1);
		range: #(10 80 10).
	self
		assert: linear input class equals: NSPolylinearScale;
		assert: linear output class equals: NSPolylinearScale;
		assert: (linear scale: 0) equals: 10;
		assert: (linear scale: 0.5) equals: 80;
		assert: (linear scale: 1) equals: 10;
		assert: (linear scale: 1.5) equals: -60.
	linear := NSScale linear
		domain: #(0 0.5 1);
		range: #('white' 'black' 'white').
	self 
		assert: (linear scale: 0) equals: Color white;
		assert: (linear scale: 0.25) equals: Color gray;
		assert: (linear scale: 0.75) equals: Color gray.
	
	
	! !

!NSPowPowScale commentStamp: ''!
I am a utility clas for NSScalePow!
!NSPowPowScale methodsFor: 'accessing' stamp: ''!
exponent: aNumber
	exponent := aNumber! !

!NSPowPowScale methodsFor: 'transformations' stamp: ''!
scale: x
	^ x < 0
		ifTrue: [ (x negated raisedTo: exponent) negated ]
		ifFalse: [ x raisedTo: exponent ]! !

!NSPowPowScale class methodsFor: 'instance creation' stamp: ''!
exponent: exponent
	^ self new 
		exponent: exponent;
		yourself! !

!NSPowScale commentStamp: ''!
I scale using pow function!
!NSPowScale methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	linear := self class linear.
	exponent := 1.
	domain := #(0 1).
	powp := NSPowPowScale exponent: exponent.
	powb := NSPowPowScale exponent: 1 / exponent.! !

!NSPowScale methodsFor: 'accessing' stamp: ''!
clamp
	^ linear clamp! !

!NSPowScale methodsFor: 'accessing' stamp: ''!
domain: x
	linear domain: ((domain := x) collect: [ :i | powp scale: i ]).! !

!NSPowScale methodsFor: 'initialization' stamp: ''!
range: x
	linear range: x! !

!NSPowScale methodsFor: 'accessing' stamp: ''!
exponent: x
	exponent := x.
	powp exponent: exponent.
	powb exponent: 1/exponent.
	linear domain: (domain collect: [ :i | powp scale: i ])! !

!NSPowScale methodsFor: 'initialization' stamp: ''!
interpolate
	^ linear interpolate! !

!NSPowScale methodsFor: 'initialization' stamp: ''!
rescale! !

!NSPowScale methodsFor: 'initialization' stamp: ''!
invert: x
	^ powb scale: (linear invert: x)! !

!NSPowScale methodsFor: 'initialization' stamp: ''!
interpolate: x
	linear interpolate: x! !

!NSPowScale methodsFor: 'accessing' stamp: ''!
clamp: x
	linear clamp: x! !

!NSPowScale methodsFor: 'accessing' stamp: ''!
exponent
	^ exponent! !

!NSPowScale methodsFor: 'initialization' stamp: ''!
scale: x
	^ linear scale: (powp scale: x)! !

!NSPowScale methodsFor: 'initialization' stamp: ''!
range
	^ linear range! !

!NSPowScaleTest commentStamp: ''!
A NSPowScaleTest is a test class for testing the behavior of NSPowScale!
!NSPowScaleTest methodsFor: 'test - scales' stamp: ''!
testSqrt
	| sqrt |
	sqrt := NSScale sqrt.
	
	self
		assert: sqrt class equals: NSPowScale;
		assert: sqrt exponent equals: 0.5;
		assert: ((sqrt scale: 9) closeTo: 3).
	
	sqrt := NSScale sqrt
		domain: #(0 36756666);
		range: #(0 220).
	self assert: (sqrt scale: 4661900) closeTo: 78.34947695663722
	! !

!NSPowScaleTest methodsFor: 'test - scales' stamp: ''!
testPowScale
	| pow |
	pow := NSPowScale new.
	
	self
		assert: pow exponent equals: 1;
		assert: (pow scale: 5) equals: 5.
	pow exponent: 2.
	self
		assert: (pow scale: 5) equals: 25;
		assert: (pow invert: 25) equals: 5;
		assert: pow exponent equals: 2.
	
	pow 
		domain: #(0 100);
		range: #(-10 10);
		clamp: true.
		
	self 
		assert: (pow scale: 200) equals: 10;
		assert: (pow scale: 99.9) closeTo: 9.960020000000004.
	pow interpolate: NSRoundInterpolator.
	self 
		assert: pow interpolate equals: NSRoundInterpolator;
		assert: (pow scale: 99.9) equals: 10;
		assert: pow range equals: #(-10 10)! !

!NSRoundInterpolator commentStamp: ''!
I am a interpolator to round numbers!
!NSRoundInterpolator methodsFor: 'interpolation' stamp: ''!
interpolate: t
	^  (start + (stop * t)) rounded! !

!NSRoundInterpolator methodsFor: 'accessing' stamp: ''!
stop: b
	stop := b - start! !

!NSRoundInterpolator class methodsFor: 'interpolation' stamp: ''!
interpolate: a and: b
	^ self new start: a; stop: b.! !

!NSSLnScaleTest methodsFor: 'tests' stamp: ''!
testBasic
	| s |
	s:= NSLnScale new
		domain: {  -100. 50};
		range: { 100. 50 }.
	self assert: s domain equals: { Float epsilon. 50 }.
	self assert: (s scale: -1000) closeTo: 100.
	self assert: (s scale: 0) closeTo: 100. 
	self assert: (s scale: 50) closeTo: 50. ! !

!NSSLnScaleTest methodsFor: 'tests' stamp: ''!
testMultiple
	| s |
	s:= NSLnScale new
		domain: {  0. 50. 100 };
		range: { 100. 50. 200 }.
	self assert: (s scale: 0) closeTo: 100.
	self assert: (s scale: 50) closeTo: 50.
	self assert: (s scale: 100) closeTo: 200.
	
	self assert: (s scale: -100) closeTo: 100.! !

!NSScale commentStamp: ''!
<keyClass>
`NSScale` is a common scale interpolator. It transformes numerical or ordinal values using a range and a domain. A scale maps _a domain to a range_. `NSScale` offers several scales as class side methods. The code of the scales are inspired from https://github.com/d3/d3-scale

*Responsibility*: act as a scale interpolator for numerical and ordinal values.

*Collaborators*: `NSScale` depends on a number of Pharo packages, including `Colors`, `Random-Core`. The scales are intensively used by Roassal

*Variables*:
- `range`: an array of two or more values to which the domain is mapped to. The range variable defines the range of the scaled value. A range may contains values or colors.
- `domain`: an array of values that maps to a range

*Example*:
```Smalltalk
s := NSScale linear.
s range: { 5 . 10 }.
s scale: 0. "=> 5"
s scale: 0.5. "=> 7.5"
s scale: 1. "=> 10"
```

```Smalltalk
s := NSScale linear.
s domain: { -1 . 1 }.
s range: { 5 . 10 }.
s scale: 0.5
```

```Smalltalk
s := NSScale linear.
s range: { Color white . Color black }.
s scale: 0.5  "=> Color gray"
```

Here is a larger example:
```
sc := NSScale linear 
	range: { #white . #gray . #red };
	domain: { 0 . 1 . 2}.

ss := NSScale linear 
	range: { 80 . 30 . 80 };
	domain: { 0 . 1 . 2}.
	 
c := RSCanvas new.
0 to: 2 by: 0.1 do: [ :i |
	s := RSBox new width: 30; height: (ss scale: i); model: i; color: (sc scale: i).
	c add: s ].

RSHorizontalLineLayout on: c shapes.
c @ RSCanvasController.
c open
```

Another example using ordinal scale:
```Smalltalk
c := RSCanvas new.
colors := NSScale ordinalColored: 3.

r := Random seed: 42.
100 timesRepeat: [ 
	txt := { 'hello' . 'bonjour' . 'Guten Morgen' } atRandom: r.
	g := RSGroup new.
	g add: (RSBox new width: 130; height: 20; model: txt; color: (colors scale: txt)).
	g add: (RSLabel new text: txt).
	c add: g asShape.
	 ].

RSGridLayout new lineItemsCount: 5; on: c shapes.
c @ RSCanvasController.
c open
```!
!NSScale methodsFor: 'accessing' stamp: ''!
to
	^ self range last! !

!NSScale methodsFor: 'accessing' stamp: ''!
uninterpolate: anObject
	uninterpolate := anObject! !

!NSScale methodsFor: 'accessing' stamp: ''!
from: value
	self range: { value. self range last }.! !

!NSScale methodsFor: 'accessing' stamp: ''!
domain: aTwoArrayAsNumbers
	"Define the domain of the input values. Values provided to scale: should be within the domain
	For example
	-=-=-=
	s := NSScale linear.
	s domain: { -1 . 1 }.
	s range: { 5 . 10 }.
	s scale: 0
	-=-=-=
	Return 7.5
	"
	domain := aTwoArrayAsNumbers! !

!NSScale methodsFor: 'transformation' stamp: ''!
rsValue: obj
	^ self scale: obj! !

!NSScale methodsFor: 'accessing' stamp: ''!
to: value
	self range: { self range first. value }.! !

!NSScale methodsFor: 'accessing' stamp: ''!
range: someValues
	"Expect an array of two or more values.
This is to what a domain is mapped to.
	
For example:
```
s := NSScale linear.
s range: { 5 . 10 }.
s scale: 0.5 
```
Return 7.5

Another example:
```
s := NScale linear 
	range: { #white . #gray . #red };
	domain: { 0 . 1 . 2}.
s scale: 1.5. 
``
Return a gray-red color`
"
	
	range := someValues! !

!NSScale methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream << '('.
	self domain printOn: stream.
	stream << ', '.
	self range printOn: stream.
	stream << ')'.! !

!NSScale methodsFor: 'accessing' stamp: ''!
domain
	^ domain! !

!NSScale methodsFor: 'accessing' stamp: ''!
interpolate
	^ interpolate! !

!NSScale methodsFor: 'hooks' stamp: ''!
rescale
	self subclassResponsibility! !

!NSScale methodsFor: 'transformation' stamp: ''!
invert: anObject
	"This is the inverse of scale"
	self subclassResponsibility.! !

!NSScale methodsFor: 'accessing' stamp: ''!
interpolate: anObject
	interpolate := anObject.! !

!NSScale methodsFor: 'transformation' stamp: ''!
scale: anObject
	"do you have your domain, and your range? ok so use this method in one of my subclasses"
	self subclassResponsibility! !

!NSScale methodsFor: 'accessing' stamp: ''!
range
	"Return the array of values to which the domain is mapped to"
	^ range! !

!NSScale methodsFor: 'accessing' stamp: ''!
from
	^ self range first! !

!NSScale methodsFor: 'accessing' stamp: ''!
uninterpolate
	^ uninterpolate! !

!NSScale class methodsFor: 'colors' stamp: ''!
paired12
	^ self fromColorCategory: #paired12! !

!NSScale class methodsFor: 'colors' stamp: ''!
sky8
	^ self fromColorCategory: #sky8! !

!NSScale class methodsFor: 'instance creation' stamp: ''!
log
	^ NSLogScale new! !

!NSScale class methodsFor: 'instance creation' stamp: ''!
sqrt
	^ self pow
		exponent: 0.5; 
		yourself! !

!NSScale class methodsFor: 'colors' stamp: ''!
google20
	^ self fromColorCategory: #google20! !

!NSScale class methodsFor: 'instance creation' stamp: ''!
ordinal
"Define an ordinal scale.

Example:
```Smalltalk
c := RSCanvas new.
colors := NSScale ordinal range: { Color red translucent . Color yellow translucent . Color blue translucent }.

r := Random seed: 42.
100 timesRepeat: [ 
	txt := { 'hello' . 'bonjour' . 'Guten Morgen' } atRandom: r.
	g := RSGroup new.
	g add: (RSBox new width: 130; height: 20; model: txt; color: (colors scale: txt)).
	g add: (RSLabel new text: txt).
	c add: g asShape.
	 ].

RSGridLayout new lineItemsCount: 5; on: c shapes.
c @ RSCanvasController.
c open
```
"
	^ NSOrdinalScale new ! !

!NSScale class methodsFor: 'colors' stamp: ''!
fromColorCategory: symbol
	^ self ordinal 
		range: (NSColorRGBAInterpolator perform: symbol);
		yourself! !

!NSScale class methodsFor: 'colors' stamp: ''!
category10
	^ self fromColorCategory: #category10! !

!NSScale class methodsFor: 'colors' stamp: ''!
category20c
	^ self fromColorCategory: #category20c! !

!NSScale class methodsFor: 'instance creation' stamp: ''!
linear
	^ NSLinearScale new. ! !

!NSScale class methodsFor: 'colors' stamp: ''!
eva10
	^ self fromColorCategory: #eva10! !

!NSScale class methodsFor: 'instance creation' stamp: ''!
pow
	^ NSPowScale new! !

!NSScale class methodsFor: 'colors' stamp: ''!
category20
	^ self fromColorCategory: #category20! !

!NSScale class methodsFor: 'instance creation' stamp: ''!
symlog
	^ NSSymLogScale new! !

!NSScale class methodsFor: 'colors' stamp: ''!
category20b
	^ self fromColorCategory: #category20b! !

!NSScale class methodsFor: 'instance creation' stamp: ''!
ln
	^ NSLnScale new! !

!NSScale class methodsFor: 'instance creation' stamp: ''!
ordinalColored: numberOfBuckets
"Define an ordinal scale for colors. It accepts the number of allocated buckets.

Example:
```Smalltalk
c := RSCanvas new.
colors := NSScale ordinalColored: 3.

r := Random seed: 42.
100 timesRepeat: [ 
	txt := { 'hello' . 'bonjour' . 'Guten Morgen' } atRandom: r.
	g := RSGroup new.
	g add: (RSBox new width: 130; height: 20; model: txt; color: (colors scale: txt)).
	g add: (RSLabel new text: txt).
	c add: g asShape.
	 ].

RSGridLayout new lineItemsCount: 5; on: c shapes.
c @ RSCanvasController.
c open
```
"
	^ self ordinal range: (Color wheel: numberOfBuckets saturation: 0.4 brightness: 1.0)! !

!NSScaleTest commentStamp: ''!
A NSScaleTest is a test class for testing the behavior of NSScale!
!NSScaleTest methodsFor: 'test - colors' stamp: ''!
testSetInterpolator
	| scale |
	scale := NSScale linear
		range: { 'white'. 'black' }.
	self assert: (scale scale: 0.5) equals: Color gray.
	scale interpolate: NSColorHSLAInterpolator.
	self assert: (scale scale: 0.5) equals: Color gray.
	scale interpolate: NSColorHSVAInterpolator.
	self assert: (scale scale: 0.5) equals: Color gray.! !

!NSScaleTest methodsFor: 'test - colors' stamp: ''!
testCategories
	| color |
	color := NSScale category10.
	self assert: color range size equals: 10.
	
	1 to: 10 do: [ :i | 
		self assert: (color scale: i) class equals: Color ].
	
	1 to: 10 do: [ :i | 
		self assert: (color scale: i) equals: (color scale: i + 10) ].
	
	color := NSScale category20.
	
	self assert: color range size equals: 20.
	0 to: 19 do: [ :i | 
		self assert: (color scale: i) class equals: Color ].
	color := NSScale category20b.
	
	self assert: color range size equals: 20.
	color := NSScale category20c.
	self assert: color range size equals: 20.
	
	color := NSScale paired12.
	self assert: color range size equals: 12.! !

!NSScaleTest methodsFor: 'tests' stamp: ''!
testAccessorsColors
	#(category10 category20 category20b category20c eva10 google20 paired12 sky8) 
		do: [ :sel| | scale |
		scale := NSScale perform: sel.
		self assert: scale class equals: NSOrdinalScale.
		self assert: scale range class equals: Array.
		self assert: scale range first class equals: Color ]! !

!NSScaleTest methodsFor: 'tests' stamp: ''!
testAccessors
	self assert: NSScale linear class equals: NSLinearScale.
	self assert: NSScale log class equals: NSLogScale.
	self assert: NSScale sqrt class equals: NSPowScale.
	self assert: NSScale pow class equals: NSPowScale.
	self assert: NSScale ordinal class equals: NSOrdinalScale.
	! !

!NSScaleTest methodsFor: 'test - linear' stamp: ''!
testRandom
	"Random uses TSScale linear"
	| random value |
	random := Random new.
	value := random rsNext: 10.
	self assert: (value between: 0 and: 10).
	value := random rsNext: -10 and: -5.
	self assert: (value between: -10 and: -5 ).! !

!NSSymLogScale commentStamp: ''!
I order to have a generic log scale for positive and negative log scales 

Inspired from https://github.com/d3/d3-scale/blob/master/src/symlog.js!
!NSSymLogScale methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self constant: 1.
	linear := self class linear.! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
clamp
	^ linear clamp! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
transformSymLog: x
	^ x sign * (1.0 + (x / constant) abs) ln! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
domain: arr
	domain := arr.
	linear domain: (arr collect: [ :i | self transformSymLog: i ]).! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
constant
	^ constant! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
range: x
	linear range: x.! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
constant: aNumber
	constant := aNumber.! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
interpolate
	^ linear interpolate! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
invert: x
	^ self transformSymExp: (linear invert: x).! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
transformSymExp: x
	^ x sign *  (1.0 + x abs) exp * constant! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
interpolate: x
	linear interpolate: x! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
clamp: x
	 linear clamp: x! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
scale: x
	^ linear scale: (self transformSymLog: x)! !

!NSSymLogScale methodsFor: 'accessing' stamp: ''!
range
	^ linear range! !

!NSSymLogScaleTest methodsFor: 'tests' stamp: ''!
testBasic
	| log |
	log := NSSymLogScale new
		domain: #(0 100);
		range: #(50 1150).
	self assert: (log scale: 71) closeTo: 1069.330419162588.
	self assert: (log scale: 0) closeTo: 50.
	
	self assert: (log invert: 50) closeTo: 0.! !

!NSUninterpolate commentStamp: ''!
I am the basic uninterpolator, my subclasses are

NSUninterpolateClamp
NSUninterpolateNumber!
!NSUninterpolate methodsFor: 'interpolating' stamp: ''!
uninterpolate: x
	self subclassResponsibility.! !

!NSUninterpolate methodsFor: 'accessing' stamp: ''!
uninterpolate: aNum1 and: aNum2
	a := aNum1.
	b := aNum2.
	(a isPoint or: [ b isPoint ]) ifTrue: [ 
		| b2 |
		a := a asPoint.
		b2 := b := b asPoint.
		b := b - a.
		b := (self stopValue: b x stop: b2 x ) @ b y.
		b := b x @ (self stopValue: b y stop: b2 y).
		^ self  ].
	a isNumber 
		ifFalse: [ ^ a := b := Float nan. ].
	b  := b - a.
	b := self stopValue: b stop: aNum2.
	! !

!NSUninterpolate methodsFor: 'accessing' stamp: ''!
stopValue: aNum1 stop: aNum2
	aNum1 isZero ifFalse: [ ^ aNum1 ].
	aNum2 isZero ifTrue: [ ^ Float infinity ].
	^ 1 / aNum2! !

!NSUninterpolate class methodsFor: 'interpolating' stamp: ''!
uninterpolate: aNum1 and: aNum2
	^ self new uninterpolate: aNum1 and: aNum2.
	! !

!NSUninterpolateClamp commentStamp: ''!
I am a private class useful to uninterpolate a value in the range { 0. 1 }.

Scales with `clamp:` should limit their ranges and domains.

Example
```Smalltalk
x := NSScale linear
	clamp: true;
	domain: { -100. 100 };
	range: { 500. 1000 }.
x scale: 200.
"1000"
x invert: 1250.
"100"
``` 
!
!NSUninterpolateClamp methodsFor: 'interpolating' stamp: ''!
uninterpolate: x
	^ 0 max: (1 min: ((x - a ) / b))! !

!NSUninterpolateNumber commentStamp: ''!
I uninterpolate a value of x acording to 2 limits, a and b without limitation!
!NSUninterpolateNumber methodsFor: 'interpolating' stamp: ''!
uninterpolate: x
	^ (x - a )/b! !

!NameLookupFailure commentStamp: ''!
Signals that a name lookup operation failed.

	hostName	hostName for which the name loopup failed
!
!NameLookupFailure methodsFor: 'accessing' stamp: ''!
standardMessageText
	"Generate a standard textual description"

	^ String
		streamContents: [ :stream | 
			stream << 'cannot resolve '.
			stream print: self hostName ]! !

!NameLookupFailure methodsFor: 'accessing' stamp: ''!
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: ''!
hostName: aString
	hostName := aString! !

!NameLookupFailure methodsFor: 'accessing' stamp: ''!
hostName
	^ hostName! !

!NameLookupFailure methodsFor: 'accessing' stamp: ''!
messageText
	"Overwritten to initialiaze the message text to a standard text if it has not yet been set"

	^ messageText ifNil: [ messageText := self standardMessageText ]! !

!NameLookupFailure class methodsFor: 'instance creation' stamp: ''!
hostName: aString
	^ self new hostName: aString! !

!NameLookupFailure class methodsFor: 'instance creation' stamp: ''!
signalFor: hostName
	"Create and signal a NameLookupFailure for hostName"

	^ (self hostName: hostName) signal! !

!NativeArrayTest commentStamp: ''!
SUnit tests for ByteArray, DoubleByteArray, WordArray and DoubleWordArray.!
!NativeArrayTest methodsFor: 'utilities' stamp: ''!
alignments
	"Arrays aligned differently on 8 bytes boundary (when turned into byteArrays)"
	^ #( 
	(10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80) "aligned"
	(10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10) "+ 1.."
	(10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20)
	(10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30)
	(10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40)
	(10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50)
	(10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50 60)
	(10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50 60 70 80 10 20 30 40 50 60 70) "+ 7 !!"
	)! !

!NativeArrayTest methodsFor: 'utilities' stamp: ''!
guineaPigClasses
	^ { ByteArray . DoubleByteArray . WordArray . DoubleWordArray}! !

!NativeArrayTest methodsFor: 'tests' stamp: ''!
testAtAllPutFail
	"Makes sure the primitive works correctly with different data structures"
	self guineaPigHerd do: [ :guineaPig |
		self should: [guineaPig atAllPut: -1] raise: Error ]! !

!NativeArrayTest methodsFor: 'tests' stamp: ''!
testAtPutBiggerNumberThrowsException
	"Make sure native arrays can contain elements of their slot size"

	self guineaPigClasses do: [ :guineaPig | | nativeArray smallerNumber bytesToShift |
		nativeArray := guineaPig new: 1.
		bytesToShift := guineaPig classLayout bytesPerSlot * 8 "bits per byte".
		smallerNumber := 1 << bytesToShift.

		self
			should: [ nativeArray at: 1 put: smallerNumber ]
			raise: Error ]! !

!NativeArrayTest methodsFor: 'utilities' stamp: ''!
alignmentIndexesDo: aBlock
	| max |
	max := self wordSize.
	1 to: max do: [ :i |
		1 to: max do: [ :j |
			1 to: max do: [ :k |
				aBlock value: i value: j value: k ] ] ]! !

!NativeArrayTest methodsFor: 'utilities' stamp: ''!
guineaPigHerd
	"Different alignment, different classes"
	^ self guineaPigClasses flatCollect: [ :cls |
		self alignments collect: [ :align |
			cls newFrom: align ] ]! !

!NativeArrayTest methodsFor: 'tests' stamp: ''!
testReplaceFromToWithStartingAt
	"Makes sure the primitive works correctly with different data structures"
	self guineaPigHerd do: [ :guineaPig |
		| copy |
		copy := guineaPig copy.
		1 to: copy size do: [ :l | copy at: l put: l ]. 
		self alignmentIndexesDo: [ :i :j :k |
					guineaPig replaceFrom: i to: j + 8 with: copy startingAt: k.
					self assert: (guineaPig at: i) equals: (copy at: k).
					self assert: (guineaPig at: j + 8) equals: (copy at: j + 8 - i + k) ] ]! !

!NativeArrayTest methodsFor: 'utilities' stamp: ''!
wordSize
	^ Smalltalk wordSize! !

!NativeArrayTest methodsFor: 'tests' stamp: ''!
testDoubleArraysHaveCorrectLayout
	self skip.
	"this is broken, work in progress see https://github.com/pharo-project/pharo/issues/5956"
	self assert: DoubleWordArray classLayout class equals: DoubleWordLayout.
	self assert: DoubleByteArray classLayout class equals: DoubleByteLayout! !

!NativeArrayTest methodsFor: 'tests' stamp: ''!
testAtAllPut
	"Makes sure the primitive works correctly with different data structures"
	self guineaPigHerd do: [ :guineaPig |
		guineaPig atAllPut: 42.
		1 to: (self wordSize min: guineaPig size) do: [ :i |
			self assert: (guineaPig at: i) equals: 42 ].
		(guineaPig size - self wordSize max: 1) to: guineaPig size do: [ :i |
			self assert: (guineaPig at: i) equals: 42 ] ]! !

!NativeArrayTest methodsFor: 'tests' stamp: ''!
testAtPutExactSizeNumber
	"Make sure native arrays can contain elements of their slot size"

	self guineaPigClasses do: [ :guineaPig | | nativeArray smallerNumber bytesToShift |
		nativeArray := guineaPig new: 1.
		bytesToShift := guineaPig classLayout bytesPerSlot * 8 "bits per byte" - 1.
		smallerNumber := 1 << bytesToShift.

		nativeArray at: 1 put: smallerNumber.
		self assert: (nativeArray at: 1) equals: smallerNumber
	]! !

!NativeBrowserOpenVisitor commentStamp: ''!
Native-Browser is a package adding to the system the possibility of opening a directory in the native browser of the OS. 

Currently working on:
- OSX (32/64)
- Linux (32/64)
- Windows (32/64)

Examples
------------
	See class side in #examples protocol!
!NativeBrowserOpenVisitor methodsFor: 'visiting' stamp: ''!
visitUnix: aPlatform
	LibC runCommand: ('xdg-open "{1}"' format: {pathString})! !

!NativeBrowserOpenVisitor methodsFor: 'visiting' stamp: ''!
visitWindows: aPlatform
	self
		privShellExecute: 'explore'
		file: pathString
		parameters: ''
		directory: ''
		show: 5	"SW_SHOW"! !

!NativeBrowserOpenVisitor methodsFor: 'private - ffi' stamp: ''!
privShellExecute: lpOperation file: lpFile parameters: lpParameters directory: lpDirectory show: nShowCmd
	^ self ffiCall: #( 
			FFIConstantHandle ShellExecuteA(
     				0,
     				char* lpOperation,
         			char* lpFile,
     				char* lpParameters,
     				char* lpDirectory,
        			int nShowCmd)) module: #shell32! !

!NativeBrowserOpenVisitor methodsFor: 'visiting' stamp: ''!
visitMacOS: aPlatform
	LibC runCommand: ('open "{1}"' format: {pathString})! !

!NativeBrowserOpenVisitor methodsFor: 'accessing' stamp: ''!
pathString: aString
	pathString := aString! !

!NativeBrowserOpenVisitor class methodsFor: 'examples' stamp: ''!
example
	<example>
	FileSystem workingDirectory openInOSFileBrowser! !

!NativeBrowserOpenVisitor class methodsFor: 'instance creation' stamp: ''!
openOn: aFileReference
	"Opens an OS-specific file and directory browser on ==aFileReference==. If aFileReference is a file, opens the browser on its containing directory instead."

	| ref |
	(aFileReference isNil or: [ aFileReference exists not ]) ifTrue: [ ^ nil ].
	ref := aFileReference isFile ifTrue: [ aFileReference parent ] ifFalse: [ aFileReference ].
	(ref isNil or: [ ref exists not ]) ifTrue: [ ^ nil ].

	self new
		pathString: ref pathString;
		visit! !

!NativeBrowserOpenVisitor class methodsFor: 'examples' stamp: ''!
example2
	<example>
	self openOn: FileLocator home! !

!NaturalLanguageTranslator commentStamp: ''!
A NaturalLanguageTranslator is a dummy translator.

The localization framework is found in the gettext package usually 
overriding this class completely. 

As an alternative you can register a translator using
  
   NaturalLanguageTranslator current: myTranslator

If this is done the messages will be dispatched to it!
!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: ''!
current 
	"Return the currently registered translator"
	
	^Current ! !

!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: ''!
current: aTranslator
	"Register a translator that should receiver the translation messages"
	
	Current := aTranslator! !

!NaturalLanguageTranslator class methodsFor: 'translate' stamp: ''!
translate: aString toLocale: localeID
	"Dispatch to a registered translator to translate the given string with the given locale ID or (if there is no translator) return the untranslated string."
	Current ifNotNil: [ ^Current translate: aString toLocale: localeID ].
	^ aString! !

!NaturalLanguageTranslator class methodsFor: 'translate' stamp: ''!
translate: aString
	"Dispatch to a registered translator to translate the given string or (if there is no translator) return the untranslated string."
	Current ifNotNil: [ ^Current translate: aString ].
	^ aString! !

!NaturalLanguageTranslator class methodsFor: 'cleanup' stamp: ''!
cleanUp
	 Current ifNotNil: [ Current cleanUp ]! !

!NaturalLanguageTranslatorTest commentStamp: ''!
Tests for NaturalLanguageTranslator!
!NaturalLanguageTranslatorTest methodsFor: 'tests' stamp: ''!
testRegisterCustomTranslator

	NaturalLanguageTranslator current: RegisterableTranslatorMock new.
	
	"Our custom translator translates the string differently"
	self assert: 'TestCase' translated equals: 'Testfall'
	
	! !

!NaturalLanguageTranslatorTest methodsFor: 'running' stamp: ''!
tearDown

	NaturalLanguageTranslator current: previousRegistered.
	super tearDown! !

!NaturalLanguageTranslatorTest methodsFor: 'tests' stamp: ''!
testTranslatePureString

	self assert: 'Pharo' translated equals: 'Pharo'! !

!NaturalLanguageTranslatorTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	previousRegistered := NaturalLanguageTranslator current! !

!NautilusRefactoring commentStamp: ''!
NautilusRefactoring is a facade for refactorings:
- class
- method
- inst var
- class var
- source code!
!NautilusRefactoring methodsFor: 'option' stamp: ''!
shouldOverride: aSelector in: aClass 
	^ self confirm: ('<1s> is already defined in the <2p> hierarchy. Extracting it to an existing selector may change behavior. Do you wish to use <1s> anyway?' expandMacrosWith: aSelector with: aClass)! !

!NautilusRefactoring methodsFor: 'option' stamp: ''!
shouldSearchInHierarchy: class
	^ class subclasses 
		ifNotEmpty: [ 
			UIManager default 
				confirm: 'Do you want to search occurrences in the whole hierarchy?'
				label: 'Warning'
		] ifEmpty: [ false ]! !

!NautilusRefactoring methodsFor: 'display' stamp: ''!
handleWarning: anException
	self inform: anException messageText.
	anException resume! !

!NautilusRefactoring methodsFor: 'display' stamp: ''!
request: requestString initialAnswer: initialAnswerString
	| answer |
	answer := UIManager default request: requestString initialAnswer: initialAnswerString.
	answer isEmptyOrNil ifTrue:  [ RefactoringAborted signal ].
	^ answer! !

!NautilusRefactoring methodsFor: 'option' stamp: ''!
shouldUseExistingMethod: aMethodName
	"for now we always want to use the existing method."
	^ true! !

!NautilusRefactoring methodsFor: 'option' stamp: ''!
requestImplementorToInline: imps
	^ self chooseFrom: imps title: 'Choose the class that should provide the implementation.' lines:#()! !

!NautilusRefactoring methodsFor: 'option' stamp: ''!
shouldInlineExpression: aString
	^ self confirm: ('Do you want to inline the expression ''<1s>'' in the current method?' expandMacrosWith: aString)! !

!NautilusRefactoring methodsFor: 'display' stamp: ''!
chooseFrom: anArray title: aString lines: aCollection 
	anArray isEmpty
		ifTrue: [ ^ nil ].
	anArray size = 1
		ifTrue: [ ^ anArray first ].
	^ UIManager default chooseOrRequestFrom: anArray lines: aCollection title: aString! !

!NautilusRefactoring methodsFor: 'accessing' stamp: ''!
model: aNautilusUI
	model := aNautilusUI! !

!NautilusRefactoring methodsFor: 'option' stamp: ''!
requestMethodNameFor: aMethodName
	^ self handleMethodNameRequest: aMethodName! !

!NautilusRefactoring methodsFor: 'option' stamp: ''!
requestSelfArgumentName
	^ self request: 'Enter name for argument to refer to "self" in extracted method'! !

!NautilusRefactoring methodsFor: 'option' stamp: ''!
selectVariableTypesFrom: aCollectionOfTypes selected: aSelectedCollection for: aRefactoring
	| stream result |
	stream := WriteStream on: String new.
	aCollectionOfTypes do: [ :each | stream nextPutAll: each name ] separatedBy: [ stream cr ].
	result := Smalltalk ui theme
		textEditorIn: self model window
		text: 'Select classes to move to: (one class per line)'
		title: 'Select classes to move to:'
		entryText: stream contents
		entryHeight: 300.
	result ifNil: [ ^ nil ].
	^ (result asString findTokens: String crlf)
		collect: [ :each | aRefactoring model classFor: (Smalltalk classNamed: each trimBoth) ]! !

!NautilusRefactoring methodsFor: 'option' stamp: ''!
selectVariableToMoveMethodTo: aSelector class: aClass

	| parseTree nameList |

	parseTree := aClass parseTreeFor: aSelector.
	parseTree
		ifNil: [ parseTree := RBMethodNode selector: #value body: ( RBSequenceNode statements: #() ) ].
	nameList := OrderedCollection new.
	nameList
		addAll: parseTree argumentNames sorted;
		addAll: aClass allInstanceVariableNames sorted.
	^ self
		chooseFrom: nameList
		title: 'Select variable to move method into:'
		lines: ( Array with: parseTree argumentNames size )! !

!NautilusRefactoring methodsFor: 'display' stamp: ''!
handleMethodNameRequest: aMethodName
	|dialog|
	dialog := SycMethodNameEditorPresenter 
		openOn: aMethodName 
		canRenameArgs: false 
		canRemoveArgs: false 
		canAddArgs: false.
	dialog cancelled ifTrue: [  CmdCommandAborted signal ].
	^ aMethodName! !

!NautilusRefactoring methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!NautilusRefactoring methodsFor: 'display' stamp: ''!
request: aString
	^ self request: aString initialAnswer: ''! !

!NautilusRefactoring methodsFor: 'option' stamp: ''!
shouldExtractAssignmentTo: aString
	^ self confirm: ('Do you want to extract the assignment of <1s> at the end of selection?' expandMacrosWith: aString)! !

!NautilusRefactoring methodsFor: 'option' stamp: ''!
refactoringOptions: aRefactoring
	aRefactoring
		setOption: #implementorToInline
		toUse: [ :ref :imps | self requestImplementorToInline: imps ];
		setOption: #methodName
		toUse: [ :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: #searchInWholeHierarchy
		toUse: [ :ref :class | self shouldSearchInHierarchy: class ]! !

!NautilusRefactoring class methodsFor: 'instance creation' stamp: ''!
model: model

	^ self new
		model: model;
		yourself! !

!NavigationHistory commentStamp: ''!
I act as a web browser history!
!NavigationHistory methodsFor: 'protocol' stamp: ''!
basicAdd: anEntry
	
	( storage isNotEmpty and: [ storage last = anEntry ] ) ifTrue: [ ^ self ].
	anEntry = self current key ifTrue: [ ^ self ].
	self checkSize.
	index := index +1.
	index > storage size
		ifTrue: [ storage addLast:  (anEntry -> DateAndTime now)]
		ifFalse: [ 
			storage := storage copyFrom: 1 to: index.
			storage at: index put: (anEntry -> DateAndTime now)]! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
addEntry: anEntry
	
	self isPaused ifTrue: [ ^ self ].
	
	self basicAdd: anEntry! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
maxSize: anInteger

	maxSize := anInteger! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
pauseDuring: aBlock
	| previousPausedValue |
	"Don't accept any new entries while executing aBlock"
	previousPausedValue := paused.
	paused := true.
	aBlock ensure: [ paused := previousPausedValue ]! !

!NavigationHistory methodsFor: 'collection compatibility' stamp: ''!
add: anEntry

	self addEntry: anEntry! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
current

	^ storage at: index ifAbsent: [ nil -> nil ]! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
back

	index := ((index - 1) max: 0)! !

!NavigationHistory methodsFor: 'testing' stamp: ''!
hasNext

	^ index < storage size! !

!NavigationHistory methodsFor: 'initialization' stamp: ''!
initialize

	storage := OrderedCollection new.
	index := 0.
	paused := false.! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
next

	index := ((index + 1) min: storage size).
	^ storage at: index! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
previous

	index := index-1 max: 1.
	^ storage at: index! !

!NavigationHistory methodsFor: 'testing' stamp: ''!
hasPrevious

	^ index > 1! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
replaceCurrentWith: anEntry
	"Change the current history item to the given object"
	storage at: index put: (anEntry -> DateAndTime now)! !

!NavigationHistory methodsFor: 'testing' stamp: ''!
isPaused
	^ paused! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
last

	^ storage last! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
maxSize

	^ maxSize ifNil: [ maxSize := self class defaultMaxSize ].! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
removeLastEntry

	self isPaused ifTrue: [ ^ self ].
	storage ifEmpty: [ ^ self ].
	
	storage remove: storage last.	
	index := index -1! !

!NavigationHistory methodsFor: 'private' stamp: ''!
checkSize
	
	[ storage size >= self maxSize ]
		whileTrue: [ 
			storage removeFirst.
			index := index -1].! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
removeEntry: anEntry
	| toRemove |
	
	"we know that toRemove will always contains one element"
	toRemove := (storage select: [:e | e key == anEntry ]).
	toRemove ifEmpty: [ ^ self ].
	toRemove := toRemove first.
	storage remove: toRemove.
	storage addLast: toRemove! !

!NavigationHistory methodsFor: 'protocol' stamp: ''!
entries

	^ storage! !

!NavigationHistory class methodsFor: 'accessing' stamp: ''!
defaultMaxSize

	^ 15! !

!NestedDictionaryTest commentStamp: ''!
SUnit test class for nested dictionaries!
!NestedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtAtputHasLastPutLastStayBehavior
	| d |
	d := Dictionary new.
	d at: #top at: #below1 put: 1.
	d at: #top at: #below1 put: 2.
	self assert: (d at: #top at: #below1) equals: 2! !

!NestedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtAtputEffectivelyPutAValue
	| d |
	d := Dictionary new.
	d at: #top at: #below1 put: 1.
	self assert: (d at: #top at: #below1) equals: 1! !

!NestedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtAtIfAbsentPut
	| d |
	d := Dictionary new.
	d at: #first at: #second put: [ 2 ].
	d at: #first at: #second42 ifAbsentPut: [ 142 ].
	d at: #first42 at: #second ifAbsentPut: [ 42 ].
	d at: #first42 at: #second42 ifAbsentPut: [ 0 ].
	self assert: (d at: #first at: #second42) equals: 142.
	self assert: (d at: #first42 at: #second) equals: 42.
	self assert: (d at: #first42 at: #second42) equals: 0.! !

!NestedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtAtIfAbsent
	| d |
	d := Dictionary new.
	d at: #top at: #below1 put: 1.
	d at: #top at: #below1 put: 2.
	d at: #fop at: #below1 put: 1.
	self assert: (d at: #top at: #below1) equals: 2.
	self assert: (d at: #fop at: #below666 ifAbsent: [ 666 ]) equals: 666.
	self assert: (d at: #fop666 at: #below1 ifAbsent: [ 666 ]) equals: 666.
	"when the first key is not found do not execute the second one."
	self assert: (d at: #fop666 at: [ 1 / 0 ] ifAbsent: [ 666 ]) equals: 666! !

!NestedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtAtPut
	| d |
	d := Dictionary new.
	d at: #top at: #below1 put: 1.
	d at: #top at: #below1 put: 2.
	d at: #fop at: #below1 put: 1.
	self assert: (d at: #top at: #below1) equals: 2.
	self assert: (d at: #fop at: #below1) equals: 1! !

!NestedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtAtOnIdentityDictinary

	| dct key1 key2 subDct |

	dct := IdentityDictionary new.
	key1 := 'a'.
	key2 := key1 copy.
	dct
		at: #a at: key1 put: 1;
		at: #a at: key2 put: 2.
	subDct := dct at: #a.
	TestCase new
		assert: subDct size equals: 2;
		assert: (subDct at: key1) equals: 1;
		assert: (subDct at: key2) equals: 2! !

!NetNameResolver commentStamp: ''!
This class implements TCP/IP style network name lookup and translation facilities.

Attempt to keep track of whether there is a network available.
HaveNetwork	true if last attempt to contact the network was successful.
LastContact		Time of that contact (totalSeconds).
haveNetwork	returns true, false, or #expired.  True means there was contact in the last 30 minutes.  False means contact failed or was false last time we asked.  Get out of false state by making contact with a server in some way (FileList or updates).!
!NetNameResolver class methodsFor: 'lookups' stamp: ''!
promptUserForHostAddress
	"Ask the user for a host name and return its address."
	"NetNameResolver promptUserForHostAddress"

	^ NetNameResolver promptUserForHostAddressDefault: ''! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primGetAddressInfoResult: socketAddress

	<primitive: 'primitiveResolverGetAddressInfoResult' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primGetAddressInfoSize

	<primitive: 'primitiveResolverGetAddressInfoSize' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'testing' stamp: ''!
isConnected
	"Dirty, but avoids fixing the plugin bug"

	[ NetNameResolver addressForName: 'www.esug.org' ]
		on: NameLookupFailure
		do: [ :exception | ^ false ].
	^ true! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primHostNameSize
 
 	<primitive: 'primitiveResolverHostNameSize' module: 'SocketPlugin'>
 	self primitiveFailed! !

!NetNameResolver class methodsFor: 'network initialization' stamp: ''!
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: 'primitives' stamp: ''!
primGetNameInfoHostResult: aString
 
 	<primitive: 'primitiveResolverGetNameInfoHostResult' module: 'SocketPlugin'>
 	self primitiveFailed! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primNameResolverError
	"Return an integer reflecting the error status of the last network name resolver request. Zero means no error."

	<primitive: 'primitiveResolverError' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
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."

	<primitive: 'primitiveResolverStatus' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'class initialization' stamp: ''!
initialize
	"Note: On the Mac, the name resolver is asynchronous, 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 image 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: 'primitives' stamp: ''!
primAbortLookup
	"Abort the current lookup operation, freeing the name resolver for the next query."

	<primitive: 'primitiveResolverAbortLookup' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'address string utils' stamp: ''!
stringFromAddress: addr
	"Return a string representing the given host address as four decimal bytes delimited with decimal points."
	"NetNameResolver stringFromAddress: NetNameResolver localHostAddress"

	| s |	
	(addr isKindOf: SocketAddress) ifTrue: [^addr printString copyUpTo: $( ].
	"If the incoming addr is a size 16 ByteArray, we assume it is
	representing an IPv6 address."
	(addr size = 16) ifTrue: [ ^ self stringFromIPv6Address: addr ].
	
	"Otherwise write out in IPv4 format"
	s := WriteStream on: ''.
	1 to: 3 do: [ :i | (addr at: i) printOn: s. s nextPut: $.].
	(addr at: 4) printOn: s.
	^ s contents! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
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."

	<primitive: 'primitiveResolverStartNameLookup' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primGetAddressInfoProtocol

	<primitive: 'primitiveResolverGetAddressInfoProtocol' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
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: 'private' stamp: ''!
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: 'address string utils' stamp: ''!
stringFromIPv6Address: aByteArray
	"Respond with a correctly formatted IPv6 string
	parsed from the incoming ByteArray.
	Note the 'compressed-zero' rule for IPv6 address strings:
	the longest contiguous range of two or more consecutive
	0 values can be compressed to '::'.
	If there are two ranges of the same size, use the leftmost"
	| readStream integerCollection indices writeStream |
	
	"If the ByteArray as an Integer is zero (ie, it's all zeros),
	then just return the double colon"
	aByteArray asInteger = 0 ifTrue: [ ^ '::' ].
	
	readStream := aByteArray readStream.
	integerCollection := OrderedCollection new.
	[ readStream atEnd ] whileFalse: [
		integerCollection add: (readStream next: 2) asInteger ].
	
	"Find the start and end indices of the longest
	contiguous set of zeroes, if any"
	writeStream := WriteStream on: String new.
	indices := self findLongestIPv6ZerosIn: integerCollection.
	indices ifNil: [
		self putIPv6HexIntegers: integerCollection on: writeStream.
		^ writeStream contents ].
	
	"If the start index of the zeros is 1, then there are contiguous
	zeros at the beginning of the string"
	(indices first = 1) ifTrue: [
		writeStream nextPutAll: '::'.
		self 
			putIPv6HexIntegers:  (integerCollection copyFrom: (indices second + 1) to: integerCollection size)
			on: writeStream.
		^ writeStream contents ].
	
	"If the end index of the zeros is the same as the size
	of the collection of integers, then there are contiguous
	zeros at the end of the string."
	(indices second = integerCollection size)
		ifTrue: [
			self
				putIPv6HexIntegers: (integerCollection copyFrom: 1 to: (indices first - 1))
				on: writeStream.
			writeStream nextPutAll: '::'.
			^ writeStream contents ].
		
	"Otherwise, there is a range of zeros somewhere in the middle
	of the string that should get compressed. Write normal strings for
	each side out of the range of the indices, then join them by the
	compression string (::)"
	self
		putIPv6HexIntegers: (integerCollection copyFrom: 1 to: (indices first - 1))
		on: writeStream.
	writeStream nextPutAll: '::'.
	self
		putIPv6HexIntegers: (integerCollection copyFrom: (indices second + 1) to: integerCollection size)
		on: writeStream.
	^ writeStream contents! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primGetNameInfoHostSize

 	<primitive: 'primitiveResolverGetNameInfoHostSize' module: 'SocketPlugin'>
 	self primitiveFailed! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primGetNameInfoServiceResult: aString
 
 	<primitive: 'primitiveResolverGetNameInfoServiceResult' module: 'SocketPlugin'>
 	self primitiveFailed! !

!NetNameResolver class methodsFor: 'network initialization' stamp: ''!
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."

	<primitive: 'primitiveInitializeNetwork' module: 'SocketPlugin'>
	^ nil  "return nil if primitive fails"! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
addressForName: aString
	^self addressForName: aString timeout: 60! !

!NetNameResolver class methodsFor: 'address string utils' stamp: ''!
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 |
	"If the address string contains a colon, then we
	consider it an IPv6 address"
	(addressString includes: $:) ifTrue: [ ^ self addressFromIPv6String: addressString ].
	
	"Otherwise parse as a normal IPv4 string"
	newAddr := ByteArray new: 4.
	s := ReadStream on: addressString.
	s skipSeparators.
	1 to: 4 do: [:i |
		byte := self readDecimalByteFrom: s.
		byte = nil ifTrue: [^ nil].
		newAddr at: i put: byte.
		i < 4 ifTrue: [
			delimiter := s next.
			((delimiter = $.) or: [(delimiter = $,) or: [delimiter = $ ]])
				ifFalse: [^ nil]]].
	^ newAddr! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
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."

	<primitive: 'primitiveResolverStartAddressLookup' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primAddressLookupResult
	"Return the host name found by the last host address lookup. Returns nil if the last lookup was unsuccessful."

	<primitive: 'primitiveResolverAddressLookupResult' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'private' stamp: ''!
putIPv6HexIntegers: aCollection on: aWriteStream
	"Given a collection of Integers, convert them to
	hex strings and join them with the ':' separator
	on the given write stream"
	aCollection 
		do: [ :integer |
			aWriteStream nextPutAll: (integer printStringBase: 16) asLowercase ]
		separatedBy: [ aWriteStream nextPut: $: ]! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
loopBackAddress
	^self addressForName: self loopBackName! !

!NetNameResolver class methodsFor: 'private' stamp: ''!
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: 'address string utils' stamp: ''!
addressFromIPv6String: aString
	"Return a ByteArray corresponding to an IPv6 address in text format"
	| stream headStream headBytes tailStream tailBytes hextets |
	headStream := WriteStream on: ByteArray new.
	tailStream := WriteStream on: ByteArray new.
	
	"Obtain a collection of the string hextets from the
	original IPv6 string. Any instance of a double colon (::)
	will be present in the list as an empty string."
	hextets := self splitIPv6HextetsOn: aString.
	stream := hextets readStream.
	(stream upTo: '') do: [ :hextet |
		headStream nextPutAll: (ByteArray readHexFrom: hextet) ].
	(stream upToEnd) do: [ :hextet |
		tailStream nextPutAll: (ByteArray readHexFrom: hextet) ].
	headBytes := headStream contents.
	tailBytes := tailStream contents.
	
	"If the total number of bytes is less than 16, that means
	we have a compressed range of 0-value hextets specified
	using the double colon (::). We add these at the end of
	the headBytes collection"
	(16 - (headBytes size + tailBytes size)) timesRepeat: [
		headBytes := headBytes,#[0] ].
	
	^ headBytes,tailBytes! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
resolverStatus
	^self primNameResolverStatus! !

!NetNameResolver class methodsFor: 'private' stamp: ''!
waitForResolverNonBusyUntil: deadline
	"Wait up to the given number of seconds for the resolver to be non busy.
	Return the resolver state."

	| status passed |
	status := self resolverStatus.
	[ status = ResolverBusy and: [ (passed := Time millisecondsSince: deadline key) < deadline value] ]
		whileTrue: [
			"wait for resolver to be available"
			ResolverSemaphore waitTimeoutMSecs: (deadline value - passed).
			status := self resolverStatus ].
	^ status! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primGetAddressInfoFamily

	<primitive: 'primitiveResolverGetAddressInfoFamily' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primGetAddressInfoHost: hostName service: servName flags: flags family: family type: type protocol: protocol

	<primitive: 'primitiveResolverGetAddressInfo' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
addressForName: hostName timeout: secs
	"Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds."
	"NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30"
	"NetNameResolver addressForName: '100000jobs.de' timeout: 30"
	"NetNameResolver addressForName: '1.7.6.4' timeout: 30"
	"NetNameResolver addressForName: '' timeout: 30"

	| deadline result |
	self initializeNetwork.
	"check if this is a valid numeric host address (e.g. 1.2.3.4)"
	result := self addressFromString: hostName.
	result ifNotNil: [ ^ result asSocketAddress ].

	"Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or www.pharo-project.org)"
	deadline := Time millisecondClockValue -> (secs * 1000).
	"Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction."
	self resolverMutex
		critical: [
			(self waitForResolverReadyUntil: deadline)
				ifTrue: [
					self primStartLookupOfName: hostName.
					(self waitForCompletionUntil: deadline)
						ifTrue: [ result := self primNameLookupResult ]
						ifFalse: [ ^ NameLookupFailure signalFor: hostName ] ]
				ifFalse: [ ^ NameLookupFailure signalFor: hostName ] ].
	^ result asSocketAddress! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
resolverError
	^self primNameResolverError! !

!NetNameResolver class methodsFor: 'private' stamp: ''!
waitForCompletionUntil: deadline
	"Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is ready, false if the network is not initialized or the resolver does not become free within the given time period."

	| status |
	status := self waitForResolverNonBusyUntil: deadline.
	^ status = ResolverReady
		ifTrue: [ true ]
		ifFalse: [ status = ResolverBusy ifTrue: [ self primAbortLookup ].
			false ]! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primGetAddressInfoNext

	<primitive: 'primitiveResolverGetAddressInfoNext' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'private' stamp: ''!
splitIPv6HextetsOn: aString
	"Respond with a collection of hextet strings extracted
	from a single string in IPv6 format. These are separated
	by the $: character.
	We avoid using #splitOn: or #splitBy: since they
	are not consistent across Smalltalks"
	| stream result |
	result := OrderedCollection new.
	stream := aString readStream.
	[ stream atEnd ] whileFalse: [ 
		"Pad any valid hextets so that they are each length 4, 
		ie they have the leading zeros. This is so that ByteArray class >> #readFromHex:
		will work properly -- it does not correctly parse hextets without the leading zeros."
		| next |
		next := stream upTo: $:.
		(next = '')
			ifTrue: [ result add: next ]
			ifFalse: [
				(4 - next size) timesRepeat: [
					next := '0',next ].
				result add: next ] ].
	
	^ result! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primHostNameResult: aString
 
 	<primitive: 'primitiveResolverHostNameResult' module: 'SocketPlugin'>
 	self primitiveFailed! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
localHostName
	"Return the local name of this host."

	"NetNameResolver localHostName"

	^ [ | hostName |
	self initializeNetwork.
	hostName := String new: self primHostNameSize.
	self primHostNameResult: hostName.
	hostName ]
		on: PrimitiveFailed
		do: [ self loopBackName ]! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primGetAddressInfoType

	<primitive: 'primitiveResolverGetAddressInfoType' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
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: 'primitives' stamp: ''!
primGetNameInfoServiceSize
 
 	<primitive: 'primitiveResolverGetNameInfoServiceSize' module: 'SocketPlugin'>
 	self primitiveFailed! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
localHostAddress
	"Return the local address of this host."
	"NetNameResolver localHostAddress"
	"On Mac the primitive is buggy and can return an empty IP address. Use a standard value in that case"
		
	| primAddress |

	self initializeNetwork.
	[ primAddress := self primLocalAddress ] on: PrimitiveFailed do: [ :err | primAddress := #[0 0 0 0] ].
	^ (primAddress = #[0 0 0 0] ifTrue: [ #[127 0 0 1] ] ifFalse: [ primAddress ]) asSocketAddress! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primLocalAddress
	"Return the local address of this host."

	<primitive: 'primitiveResolverLocalAddress' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
promptUserForHostAddressDefault: defaultName
	"Ask the user for a host name and return its address. If the default name is the empty string, use the last host name as the default."

	"NetNameResolver promptUserForHostAddressDefault: ''"

	| default hostName serverAddr |
	default := defaultName isEmpty
		ifTrue: [ DefaultHostName ]
		ifFalse: [ defaultName ].
	hostName := UIManager default request: 'Host name or address?' initialAnswer: default.
	hostName isEmptyOrNil
		ifTrue: [ ^ 0 ].
	serverAddr := NetNameResolver addressForName: hostName timeout: 15.
	hostName size > 0
		ifTrue: [ DefaultHostName := hostName ].
	^ serverAddr! !

!NetNameResolver class methodsFor: 'lookups' stamp: ''!
loopBackName
	^'localhost'! !

!NetNameResolver class methodsFor: 'primitives' stamp: ''!
primNameLookupResult
	"Return the host address found by the last host name lookup. Returns nil if the last lookup was unsuccessful."

	<primitive: 'primitiveResolverNameLookupResult' module: 'SocketPlugin'>
	self primitiveFailed! !

!NetNameResolver class methodsFor: 'private' stamp: ''!
findLongestIPv6ZerosIn: aCollection
	"Given a collection of Integers, find the longest (or leftmost)
	range of contiguous consecutive zero values (if any).
	Respond with a size 2 array corresponding to the start
	and end index, or nil if there are no zero ranges at all"
	| active start end cursor ranges largest firstLargest |
	active := false. "Whether or not the beginning of some range has been found"
	start := 0.
	end := 0.
	ranges := OrderedCollection new.
	cursor := 1.
	[ cursor < aCollection size ] whileTrue: [
		| current next isConsecutive |
		current := aCollection at: cursor.
		next := aCollection at: cursor + 1.
		isConsecutive := (current = 0) and: [ next = 0].
		
		isConsecutive
			ifTrue: [ 
				active
					ifFalse: [
						"If the current values are consecutive zeros,
						and we are not active, set active to true and update
						the start and end values." 
						start := cursor.
						end := cursor + 1.
						active := true ]
					ifTrue: [ 
						"If the current values are consecutive zeros,
						and we _are_ active, this means we need to just
						update the end"
						end := cursor + 1 ] ].

			
		"If we are active, but the values are _not_ consecutive,
		it means we've reached the end of a range"
		((active and: [ isConsecutive not ]) or: [ (active and: [ (cursor + 1) = aCollection size ])])
			ifTrue: [
				active := false.
				ranges add: { start. end }.
				start := 0.
				end := 0 ].
		
		"Increment the cursor"
		cursor := cursor + 1.
	].

	"If there are no zero ranges, return nil."
	ranges ifEmpty: [ ^ nil ].
	
	"Otherwise, return the longest range.
	If there are multiple ranges with the same size,
	return the first (leftmost) encountered."
	largest := 0.
	firstLargest := 1. "index of the first instance of the largest value, in case there are multiple with same size"
	(ranges collect: [ :range |
		(range last - range first )]) doWithIndex: [ :rangeSize :index |
			rangeSize > largest ifTrue: [ 
				largest := rangeSize.
				firstLargest := index ] ].
	
	^ ranges at: firstLargest! !

!NetNameResolver class methodsFor: 'private' stamp: ''!
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! !

!NetNameResolverTest commentStamp: ''!
SUnit tests for NetNameResolver !
!NetNameResolverTest methodsFor: 'accessing' stamp: ''!
localHostAddressIsLoopBackAddress
		^NetNameResolver localHostAddress = NetNameResolver loopBackAddress! !

!NetNameResolverTest methodsFor: 'testing' stamp: ''!
testLocalHostAddress
	self skip. "This test is currently broken"
	NetNameResolver isConnected
		ifTrue: [self deny: self localHostAddressIsLoopBackAddress]
		ifFalse: [self assert: self localHostAddressIsLoopBackAddress]! !

!NetNameResolverTest methodsFor: 'testing' stamp: ''!
testLocalHostName
	self deny: NetNameResolver localHostName isNil.
	NetNameResolver isConnected
		ifTrue: [self deny: self localHostNameIsLoopBackName]
		ifFalse: [self assert: self localHostNameIsLoopBackName]! !

!NetNameResolverTest methodsFor: 'accessing' stamp: ''!
localHostNameIsLoopBackName
		^NetNameResolver localHostName = NetNameResolver loopBackName! !

!NetworkError commentStamp: ''!
Abstract super class for all network related exceptions.!
!NetworkIPv6StringTest methodsFor: 'tests' stamp: ''!
testCompressedZerosOnlyToString
	"Ensure that a ByteArray of size 16 consisting of all zeros is
	correctly represented as just the compressed zero IPv6 string (::)"
	| source expected result |
	source := #[ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ].
	expected := '::'.
	result := NetNameResolver stringFromIPv6Address: source.
	
	self assert: expected equals: result.! !

!NetworkIPv6StringTest methodsFor: 'tests' stamp: ''!
testMiddleCompressedZeroToString
	"Ensure that a size-16 ByteArray corresponding to an IPv6 address
	that contains some middle range of consecutive zeros responds with
	a string that includes the consecutive zero substring (::) in the correct place."
	| source expected result |
	source := #[32 1 13 184 0 0 0 0 0 1 0 0 0 0 0 1].
	expected := '2001:db8::1:0:0:1'.
	result := NetNameResolver stringFromIPv6Address: source.
	
	self assert: expected equals: result.! !

!NetworkIPv6StringTest methodsFor: 'tests' stamp: ''!
testTailCompressedZerosToString
	"Ensure that a size 16 ByteArray corresponding to an IPv6 address
	that ends in a contiguous range of zeros has the correct compressed
	zero substring (::) at the end of the string."
	| source expected result |
	source := #[ 13 184 32 1 0 0 0 0 0 0 0 0 0 0 0 0 ].
	expected := 'db8:2001::'.
	result := NetNameResolver stringFromIPv6Address: source.
	
	self assert: expected equals: result.! !

!NetworkIPv6StringTest methodsFor: 'tests' stamp: ''!
testCompressedZerosOnlytoBytes
	"Ensure that an IPv6 string containing only compressed zeroes
	(::) responds with a ByteArray of all zeros."
	| source expected result |
	source := '::'.
	expected := #[ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ].
	result := NetNameResolver addressFromIPv6String: source.
	
	self assert: expected equals: result.! !

!NetworkIPv6StringTest methodsFor: 'tests' stamp: ''!
testHeadCompressedZerosToString
	"Ensure that a valid 16-size ByteArray corresponding
	to an IPv6 address that begins with some number of
	compressed zeros accurately responds with a string
	that begins with the compressed symbol (::)."
	| source expected result |
	source := #[ 0 0 0 0 0 0 0 0 0 0 0 0 32 1 13 184 ].
	expected := '::2001:db8'.
	result := NetNameResolver stringFromIPv6Address: source.
	
	self assert: expected equals: result.! !

!NetworkIPv6StringTest methodsFor: 'tests' stamp: ''!
testTailCompressedZerosToBytes
	"Ensure that compressed zeroes (::) at the tail of a valid
	IPv6 string are accurately represented in the resulting ByteArray."
	| source expected result |
	source := 'db8:2001::'.
	expected := #[ 13 184 32 1 0 0 0 0 0 0 0 0 0 0 0 0 ].
	result := NetNameResolver addressFromIPv6String: source.
	
	self assert: expected equals: result.! !

!NetworkIPv6StringTest methodsFor: 'tests' stamp: ''!
testHeadCompressedZerosToBytes
	"Ensure that compressed zeros (::) at the start of the
	IPv6 string are accurately represented in the resulting ByteArray"
	| source expected result |
	source := '::2001:db8'.
	expected := #[ 0 0 0 0 0 0 0 0 0 0 0 0 32 1 13 184 ].
	result := NetNameResolver addressFromIPv6String: source.
	
	self assert: expected equals: result.! !

!NetworkIPv6StringTest methodsFor: 'tests' stamp: ''!
testMiddleCompressedZeroToBytes
	"Ensure that the compressed zeros, represented by '::' in
	the source IPv6 string, are accurately written out to the
	resulting ByteArray."
	| source expected result |
	source := '2001:db8::1:0:0:1'.
	expected := #[32 1 13 184 0 0 0 0 0 1 0 0 0 0 0 1].
	result := NetNameResolver addressFromIPv6String: source.
	
	self assert: expected equals: result.! !

!NetworkSystemSettings commentStamp: ''!
I am NetworkSystemSettings, a class side API to manage various system network settings, mostly related to HTTP proxying.!
!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
addHttpProxyException: domainName
	"Add a (partial, wildcard) domain name to the list of proxy exceptions"
	"HTTPSocket addProxyException: '*.pharo.org'."

	self httpProxyExceptions add: domainName! !

!NetworkSystemSettings class methodsFor: 'private' stamp: ''!
lastHTTPProxyPort
	^ LastHTTPProxyPort ifNil: [ LastHTTPProxyPort := HTTPProxyPort ]! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
isAnExceptionFor: url
	"Return true when the host of url matches any of our HTTP proxy exceptions, else return false"

	 ^ self isHttpProxyException: url host! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
blabEmail
	^ BlabEmail ifNil: [ BlabEmail := '' ]! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
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: ''!
proxyPassword
	"Return the HTTP proxy password to use, if any. Can be empty."

	^ ProxyPassword 
		ifNil: [ '' ]
		ifNotNil: [ ProxyPassword base64Decoded utf8Decoded ]! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
networkSettingsOn: aBuilder 
	<systemsettings> 
	(aBuilder group: #network) 
		label: 'Network';
		description: 'All network related settings';
		noOrdering;
		with: [ 
			(aBuilder setting: #useHTTPProxy)      
				label: 'Use HTTP proxy' ;   
				noOrdering;
				default: false;
		 		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.';
				with: [
					(aBuilder setting: #httpProxyPort)
						label: 'Port' ;
						default: 80;
						description: 'The HTTP proxy port'.
					(aBuilder setting: #httpProxyServer)
						label: 'Server' ;
						default: '';
						description: 'The HTTP proxy server (i.e. proxy.univ-brest.fr)'.
					(aBuilder setting: #manageHttpProxyExceptions)
						label: 'Exceptions' ;
						target: NetworkSystemSettings;
						default: '';
						description: 'Domains to avoid to proxy (separated by ;)'
				].
			(aBuilder setting: #useNetworkAuthentification) 
				label: 'Proxy authentication' ;
				noOrdering;
				default: false;
		 		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';
				with: [
					(aBuilder setting: #proxyUser)
						label: 'User name' ;
						default: '';
						description: 'The proxy user name'.
					(aBuilder setting: #proxyPassword)
						type: #Password;
						default: '';
						label: 'Password' ;
						description: 'The user password'].
			(aBuilder setting: #blabEmail)
				label: 'Blab email' ;
				ghostHelp: 'somebody@some.where';
				default: '';
				description: 'Enter blab email of the form ''somebody@some.where''. It can be empty']! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
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: ''!
httpProxyPort  
	"Return the HTTP proxy port to use, an Integer"
	
	^ HTTPProxyPort ifNil: [ HTTPProxyPort := 80 ]! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
useNetworkAuthentification: aBoolean
	"Set whether authentication should be used when accessing the HTTP proxy.
	This is a switch over username/password."

	UseNetworkAuthentification := aBoolean! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
manageHttpProxyExceptions: aStringWithExceptions

	self removeAllHttpProxyExceptions.

	aStringWithExceptions isEmptyOrNil ifTrue: [ ^ self ].

	LastHTTPProxyExceptions := aStringWithExceptions.
	( ';' split: aStringWithExceptions) do: [
		:domain  | 
		self addHttpProxyException: domain
	].! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
blabEmail: aBlabEmailString
	BlabEmail := aBlabEmailString! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
proxyPassword: aPassword
	"Set the HTTP proxy password. Can be empty or nil to reset"
	
	ProxyPassword := aPassword ifNotNil: [ aPassword utf8Encoded base64Encoded ]! !

!NetworkSystemSettings class methodsFor: 'private' stamp: ''!
lastHTTPProxyServer
	^ LastHTTPProxyServer ifNil: [ LastHTTPProxyServer := HTTPProxyServer ]! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
manageHttpProxyExceptions
	^ LastHTTPProxyExceptions ifNil:[ LastHTTPProxyExceptions := ''].! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
isHttpProxyException: serverName
	"Return true when serverName matches any of our HTTP proxy exceptions, else return false"

	^ self httpProxyExceptions anySatisfy: [ :domainName | domainName match: serverName ]! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
proxyUser: aUser
	"Set the HTTP proxy user. Can be empty or nil to reset"
	
	ProxyUser := aUser ifNotNil: [ aUser utf8Encoded base64Encoded ]! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
removeAllHttpProxyExceptions
	self httpProxyExceptions removeAll.! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
removeHttpProxyException: domainName
	"Remove a (partial, wildcard) domain name from the list of proxy exceptions"

	self httpProxyExceptions remove: domainName ifAbsent: []! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
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: ''!
useHTTPProxy
	"Should an HTTP proxy be used ? This is a global switch."

	^ UseHTTPProxy ifNil: [ UseHTTPProxy := false ]! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
proxyUser
	"Return the HTTP proxy user to use, if any. Can be empty."

	^ ProxyUser
		ifNil: [ '' ]
		ifNotNil: [ ProxyUser base64Decoded utf8Decoded ]! !

!NetworkSystemSettings class methodsFor: 'settings' stamp: ''!
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: ''!
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: ''!
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 ]! !

!NewHandleMorph commentStamp: ''!
A more recent implementation of a handle morph!
!NewHandleMorph methodsFor: 'submorphs - add/remove' stamp: ''!
delete

	hand ifNotNil: [ hand showTemporaryCursor: nil ].
	super delete! !

!NewHandleMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"

	super initialize.
	waitingForClickInside := true! !

!NewHandleMorph methodsFor: 'stepping and presenter' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
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: 'all' stamp: ''!
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: 'all' stamp: ''!
followHand: aHand forEachPointDo: block1 lastPointDo: block2

	hand := aHand.
	pointBlock := block1.
	lastPointBlock := block2.
	self position: hand lastEvent cursorPoint - (self extent // 2)! !

!NewHandleMorph methodsFor: 'wiw support' stamp: ''!
morphicLayerNumber
	"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"

	^ 1! !

!NewUndeclaredWarning commentStamp: ''!
I am a warning about the definition of a new Undeclared variable. I may be quite common during loading of packages that do not have (or cannot have) clean dependencies structure or are loaded in wrong order.!
!NewUndeclaredWarning methodsFor: 'accessing' stamp: ''!
originName: anObject
	originName := anObject! !

!NewUndeclaredWarning methodsFor: 'accessing' stamp: ''!
messageText
	^String streamContents: [ :str |
		originName putOn: str.		
		str nextPutAll: ' ('.
		undeclaredName putOn: str.
		str nextPutAll: ' is Undeclared)' ].! !

!NewUndeclaredWarning methodsFor: 'accessing' stamp: ''!
undeclaredName
	^ undeclaredName! !

!NewUndeclaredWarning methodsFor: 'accessing' stamp: ''!
undeclaredName: anObject
	undeclaredName := anObject! !

!NewUndeclaredWarning methodsFor: 'accessing' stamp: ''!
originName
	^ originName! !

!NewUndeclaredWarning class methodsFor: 'exceptioninstantiator' stamp: ''!
signal: undeclaredName in: originName

	^ self new 
		undeclaredName: undeclaredName;
		originName: originName;
		signal.! !

!NewValueHolder commentStamp: ''!
I am a class holding any object inside its unique instance variable. 
Each time the instance variable value changes, an announcement is emitted. 

The instance variable is accessed through `value` and `value:` while the registration is done by `whenChangedDo: aBlock`. 

In addition, infinite loops of propagation are prevented. 
Use case: you have two lists A, and B, and you want to keep their selection synchronised. 
So when A selection changes, you set B selection. 
But since B selection changes, you set A selection, and so on… 

This case is prevented by the use of a `lock` variable.!
!NewValueHolder methodsFor: 'accessing' stamp: ''!
value: anObject
	
	self handleCircularReferencesWhile: [ | oldValue |
		oldValue := value.
		value := anObject.
		self valueChanged: oldValue ].! !

!NewValueHolder methodsFor: 'testing' stamp: ''!
isValueHolder

	^ true! !

!NewValueHolder methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	lock := false.! !

!NewValueHolder methodsFor: 'converting' stamp: ''!
asValueHolder

	^ self! !

!NewValueHolder methodsFor: 'accessing' stamp: ''!
rawValue: aValue

	value := aValue! !

!NewValueHolder methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream 
		nextPutAll: '[ '; 
		print: self value;
		nextPutAll: ' ]'! !

!NewValueHolder methodsFor: 'accessing' stamp: ''!
value

	^ value! !

!NewValueHolder methodsFor: 'accessing' stamp: ''!
valueChanged
	
	self announcer announce: (ValueChanged newValue: self value)! !

!NewValueHolder methodsFor: 'accessing' stamp: ''!
valueChanged: oldValue
	
	self valueChanged: oldValue to: self value! !

!NewValueHolder methodsFor: 'backward' stamp: ''!
contents

	^ self value! !

!NewValueHolder methodsFor: 'backward' stamp: ''!
contents: anObject

	self value: anObject! !

!NewValueHolder methodsFor: 'accessing' stamp: ''!
valueChanged: oldValue to: newValue
	
	self announcer announce: (ValueChanged oldValue: oldValue newValue: newValue)! !

!NewValueHolder methodsFor: 'private' stamp: ''!
handleCircularReferencesWhile: aBlock
	"Used to handle circular references as explained in the class comment"

	lock ifTrue: [ ^ self ].
	lock := true.
	
	aBlock ensure: [ lock := false ].! !

!NewValueHolder class methodsFor: 'instance creation' stamp: ''!
value: contents

	^ self new
		rawValue: contents;
		yourself! !

!NewValueHolderTest commentStamp: ''!
Unit tests for new ValueHolder!
!NewValueHolderTest methodsFor: 'tests' stamp: ''!
testValuesInBlock
	| valueHolder old new ann |
	valueHolder := 'old' asValueHolder.
	valueHolder
		whenChangedDo: [ :newValue :oldValue :a | 
			new := newValue.
			old := oldValue.
			ann := a ].
	valueHolder value: 'new'.
	self assert: old equals: 'old'.
	self assert: new equals: 'new'.
	self assert: (ann isMemberOf: ValueChanged)! !

!NewValueHolderTest methodsFor: 'tests' stamp: ''!
testChange
	| valueHolder fired |
	valueHolder := 'word' asValueHolder.
	self assert: valueHolder value equals: 'word'.
	fired := false.
	valueHolder whenChangedDo: [ fired := true ].
	valueHolder value: 'new'.
	self assert: fired.
	self assert: valueHolder value equals: 'new'! !

!NoBroadcastAllowed commentStamp: ''!
A socket primitive failed due to no broadcast being allowed on this socket.

This failure is fairly specific, as IPv6 does not include broadcast, and it is not supported by the TCP protocol.

Usually, the cause is one of two things;
- We tried sending to the wrong address
- We should have #setOption: 'SO_BROADCAST' value: true on the (UDP) socket!
!NoChangesLog commentStamp: ''!
I am NoChangesLog.

I am a ChangesLog that does nothing. I.e. I do not log any changes.

I am used to set up an image to run an image without changes.

To install me, execute

  NoChangesLog install.

To get back to the normal situation, execute

  ChangesLog reset.!
!NoChangesLog methodsFor: 'logging' stamp: ''!
logSnapshot: save andQuit: quit! !

!NoChangesLog methodsFor: 'logging' stamp: ''!
logChange: aStringOrText! !

!NoChangesLog class methodsFor: 'singleton' stamp: ''!
install
	DefaultInstance := self new! !

!NoDebugger commentStamp: ''!
I am a debugger that will do nothing in case I am called.!
!NoDebugger class methodsFor: 'opening api' stamp: ''!
openOn: aDebugSession withFullView: aBool andNotification: aString
	"Do nothing"! !

!NoNetworkError commentStamp: ''!
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.

!
!NoPharoFilesOpener commentStamp: ''!
I am NoPharoFilesOpener.

I am a PharoFilesOpener that does nothing. I.e. neither the sources nor the changes file are opened and nil is returned.

I am used to set up an image to run an image without sources or changes.

To install me, execute

  NoPharoFilesOpener install.

To get back to the normal situation, execute

  PharoFilesOpener reset.!
!NoPharoFilesOpener methodsFor: 'public' stamp: ''!
changesFileOrNil
	^ nil! !

!NoPharoFilesOpener methodsFor: 'public' stamp: ''!
sourcesFileOrNil
	^ nil! !

!NoPharoFilesOpener class methodsFor: 'singleton' stamp: ''!
install
	Default := self new! !

!NoUnusedVariablesLeftTest commentStamp: ''!
Test to check if there are methods who have unused temporary variables in the image!
!NoUnusedVariablesLeftTest methodsFor: 'testing' stamp: ''!
testNoUnusedTemporaryVariablesLeft
	"Fail if there are methods who have unused temporary variables"
	| found validExceptions remaining |
	found := SystemNavigation default allMethodsSelect: [ :m | 
		((m numTemps - m numArgs) > 0) and: [  
		m ast temporaries anySatisfy: [ :x | x binding isUsed not] ] ].
	
	"No other exceptions beside the ones mentioned here should be allowed"	
	validExceptions := { MFClassA>>#method. MFClassB>>#method3. MFClassB>>#method2 . TemporaryVariableTest>>#testIsReferenced }.	
	
	remaining := found asOrderedCollection 
								removeAll: validExceptions;
								yourself.
								
	self assert: remaining isEmpty description: ('the following methods have unused temporary variables and should be cleaned: ', remaining asString)! !

!NoUnusedVariablesLeftTest methodsFor: 'testing' stamp: ''!
testNoUnusedInstanceVariablesLeft
	| variables classes validExceptions remaining |
	
	variables := Smalltalk globals allBehaviors flatCollect: [ :each | each instanceVariables ].
	variables := variables reject: [ :each | each isReferenced ].
	
	classes := variables collect: [ :each | each definingClass ] as: Set.
	
	validExceptions := { RBFooLintRuleTestData . RBLintRuleTestData .RBFooDummyLintRuleTest . RBDummyLintRuleTest. MockWithComplexSlot}.	
	
	remaining := classes asOrderedCollection removeAll: validExceptions; yourself.
	self assert: remaining isEmpty description: ('the following classes have unused instance variables and should be cleaned: ', remaining asString)! !

!NoUnusedVariablesLeftTest methodsFor: 'testing' stamp: ''!
testNoUnusedClassVariablesLeft
	| variables classes validExceptions remaining |
	
	variables := Smalltalk globals allBehaviors flatCollect: [ :each | each classVariables ].
	variables := variables reject: [ :each | each isReferenced ].
	
	classes := variables collect: [ :each | each definingClass ] as: Set.
	
	validExceptions := #(OSKeySymbols FooSharedPool SDL2Constants AthensCairoDefinitions BalloonEngineConstants ShTestSharedPool RBLintRuleTestData RBDummyLintRuleTest MCMockClassF Unicode Character STONAlternativeRepresentationTestObject).	
	
	remaining := classes asOrderedCollection reject: [ :each  | validExceptions includes: each name].
	self assert: remaining isEmpty description: ('the following classes have unused class variables and should be cleaned: ', remaining asString)! !

!NoUnusedVariablesLeftTest class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit

	^ 2 minute! !

!NonBooleanReceiver commentStamp: ''!
Some constructs are optimized in the compiler :
#whileTrue:
#whileFalse:
#ifTrue:
#ifFalse:
#ifTrue:ifFalse:
#ifFalse:ifTrue:
So you cannot by default use them on non boolean objects.
	
If you really need to use optimized constructs, you can enable Opal compiler and do one of the following :
		- recompile your method with the pragma : <compilerOptions: #(+ optIlineNone)>
		- recompile your class with the method : MyClass class>>compiler 
			^ super compiler options: #(+ optIlineNone)
		- call from this method by Object>>#mustBeBooleanInMagic:"!
!NonBooleanReceiver methodsFor: 'signaledexception' stamp: ''!
isResumable

	^true! !

!NonBooleanReceiver methodsFor: 'accessing' stamp: ''!
object
	^object! !

!NonBooleanReceiver methodsFor: 'accessing' stamp: ''!
object: anObject
	object := anObject! !

!NonBooleanReceiver class methodsFor: 'must-be-boolean-mop' stamp: ''!
mustBeBooleanHandler

	^ MustBeBooleanHandler! !

!NonBooleanReceiver class methodsFor: 'must-be-boolean-mop' stamp: ''!
mustBeBooleanHandler: aHandler

	MustBeBooleanHandler := aHandler! !

!NonInteractiveTranscript commentStamp: ''!
I am NonInteractiveTranscript, a replacement for Transcript, writing everything to a file or stdout. I implement TTranscript.

This is useful when running headless.

	NonInteractiveTranscript file install.
	
To connect to the output stream of the virtual machine process choose stdout.

	NonInteractiveTranscript stdout install.

or 

	NonInteractiveTranscript stderr install
!
!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
cr
	"Output a cr on the receiver, buffered and not yet shown"
	
	self newLine! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
newLine
	"Output a cr on the receiver, buffered and not yet shown"
	
	self nextPutAll: OSPlatform current lineEnding! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
endEntry
	"Show the currently buffered output"

	self flush! !

!NonInteractiveTranscript methodsFor: 'installation' stamp: ''!
install
	"Install me as a replacement for Transcript"
	
	Smalltalk globals 
		at: #Transcript 
		put: self! !

!NonInteractiveTranscript methodsFor: 'testing' stamp: ''!
isStdout
	"Answer true when I am setup to be connected to the special
	standard output stream of the virtual machine process."
	
	^ fileName = #stdout! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
crShow: anObject
	"Output anObject asString on the receiver preceded by a cr and show the output"
	
	self critical: [ self cr; show: anObject ]! !

!NonInteractiveTranscript methodsFor: 'accessing' stamp: ''!
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: 'printing' stamp: ''!
printOn: aStream
	self == Transcript ifFalse: [ ^ super printOn: aStream ].
	aStream nextPutAll: 'Transcript'! !

!NonInteractiveTranscript methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating

	^self == Transcript 
		ifTrue: [ true ]
		ifFalse: [ super isSelfEvaluating ]! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
tab
	"Output a tab on the receiver, buffered and not yet shown"

	self nextPut: Character tab! !

!NonInteractiveTranscript methodsFor: 'accessing' stamp: ''!
fileName: anObject
	"Initialize me to write to a file stream described by anObject.
	anObject is either a String naming a file or the special #stdout value
	for using the standard output stream of the virtual machine process."
	
	self close.
	fileName := anObject! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
nextPut: aCharacter
	"Output character on the receiver, buffered, not yet shown"

	self critical: [  self stream nextPut: aCharacter ]! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
show: anObject
	"Output anObject asString on the receiver and show the output"
	
	self critical: [ self print: anObject; endEntry ]! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
close
	"Close the receiver, indicating it is not longer needed"
	
	self critical: [ 
		stream ifNotNil: [ 
			(self isStdout or: [ self isStderr ])
				ifTrue: [ stream flush ]
				ifFalse: [ stream close ].
			stream := nil ] ]! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
flush
	"Show the currently buffered output"

	self critical: [ self stream flush ]! !

!NonInteractiveTranscript methodsFor: 'private' stamp: ''!
initializeStream
	"Open the file stream that I write to or connect to #stdout/#stderr.
	I will use the platform line end convention.
	I will append to regular files."
	
	^ stream := self isStdout 
		ifTrue: [ Stdio stdout ]
		ifFalse: [ 
			self isStderr
				ifTrue: [ Stdio stderr ]
				ifFalse: [ (File named: self fileName) openForAppend ] ]! !

!NonInteractiveTranscript methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	accessSemaphore := Mutex new! !

!NonInteractiveTranscript methodsFor: 'private' stamp: ''!
stepGlobal
	"ignored"! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
space
	"Output a space on the receiver, buffered and not yet shown"

	self nextPut: Character space! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
<< anObject
	"Write anObject to the receiver, dispatching using #putOn:
	This is a shortcut for both nextPut: and nextPutAll: since anObject can be both
	the element type of the receiver as well as a collection of those elements.
	No further conversions of anObject are applied.
	Return self to accomodate chaining."

 	anObject putOn: self! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
clear
	"Clear the receiver, removing all existing output"! !

!NonInteractiveTranscript methodsFor: 'accessing' stamp: ''!
stream
	"The file stream I am writing to.
	Lazy initialized so as not to create the file when it is not used."
	
	^ stream ifNil: [ self initializeStream ]! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
critical: block
	"Execute block making sure only one thread accesses the receiver"

	^ accessSemaphore critical: block ! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
nextPutAll: aCollection
	"Output string on the receiver, buffered, not yet shown"

	self critical: [ self stream nextPutAll: aCollection ]! !

!NonInteractiveTranscript methodsFor: 'streaming' stamp: ''!
print: anObject
	"Output anObject asString on the receiver, buffered, not yet shown"
	
	self nextPutAll: anObject asString! !

!NonInteractiveTranscript methodsFor: 'testing' stamp: ''!
isStderr
	
	^ fileName = #stderr! !

!NonInteractiveTranscript class methodsFor: 'class initialization' stamp: ''!
initialize
	"Make sure to cleanup on shutdown"
	SessionManager default registerSystemClassNamed: self name! !

!NonInteractiveTranscript class methodsFor: 'instance creation' stamp: ''!
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: 'testing' stamp: ''!
isInstalled
	^ Transcript class = self! !

!NonInteractiveTranscript class methodsFor: 'system startup' stamp: ''!
shutDown
	"Send close to all our instances.
	Their streams will be reopened on first use later on."
	
	self allInstances do: #close! !

!NonInteractiveTranscript class methodsFor: 'instance creation' stamp: ''!
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: ''!
onFileNamed: fileName
	"Create a NonInteractiveTranscript that will write to fileName."
	
	^ self new
		fileName: fileName;
		yourself! !

!NonInteractiveTranscript class methodsFor: 'constants' stamp: ''!
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: ''!
stderr
	"Create a new NonInteractiveTranscript that will output 
	to the special standard error output stream of the virtual machine process."
	
	^ self onFileNamed: #stderr! !

!NonInteractiveTranscriptTest commentStamp: ''!
I am NonInteractiveTranscriptTests!
!NonInteractiveTranscriptTest methodsFor: 'tests' stamp: ''!
testStderr
	NonInteractiveTranscript stderr << 'Pharo writing to the standard error'; cr; flush! !

!NonInteractiveTranscriptTest methodsFor: 'tests' stamp: ''!
testAppend
	| log transcript |
	log := 'test.log' asFileReference.
	log ensureDelete.
	transcript := NonInteractiveTranscript onFileNamed: log basename.
	transcript
		show: 'One'; cr; 
		show: 'Two'; cr; 
		close.
	transcript := NonInteractiveTranscript onFileNamed: log basename.
	transcript
		show: 'Three'; cr; 
		close.
	self assert: log contents lines equals: #('One' 'Two' 'Three').
	log ensureDelete! !

!NonInteractiveTranscriptTest methodsFor: 'tests' stamp: ''!
testStdout
	NonInteractiveTranscript stdout << 'Pharo writing to the standard output'; cr; flush! !

!NonInteractiveTranscriptTest methodsFor: 'tests' stamp: ''!
testSimple
	| log transcript |
	log := 'test.log' asFileReference.
	log ensureDelete.
	transcript := NonInteractiveTranscript onFileNamed: log basename.
	transcript
		show: 'One'; cr; 
		show: 'Two'; cr; 
		show: 'Three'; cr; 
		close.
	self assert: log contents lines equals: #('One' 'Two' 'Three').
	log ensureDelete! !

!NonInteractiveUIManager commentStamp: ''!
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: 'errors' stamp: ''!
nonInteractiveRequest: aStringOrText
	^ self nonInteractiveRequest: aStringOrText title: nil! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
multiLineRequest: queryString initialAnswer: defaultAnswer answerHeight: answerHeight
	^  self nonInteractiveRequest: queryString! !

!NonInteractiveUIManager methodsFor: '*Monticello' stamp: 'nil'!
merge: merger informing: aString
	"Check for conflicts, if there are none, just continue. 
	 Merger will accept all conflicts"
	super merge: merger informing: aString.
	merger hasConflicts ifTrue: [ self exitFailure ]! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString
	(ProvideAnswerNotification signal: queryString) ifNotNil: [:answer |
		^ answer].
	
	^  self nonInteractiveWarning: 'Confirming: ', queryString! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
fontFromUser: priorFont	
	^self nonInteractiveWarning: 'Font Choose Request'! !

!NonInteractiveUIManager methodsFor: '*Morphic-Core' stamp: ''!
currentWorld

	" err.. we should probably prohibit this message.. but lets play nice"
	uiManager ifNotNil: [ ^ uiManager currentWorld ].
	
	ActiveWorld ifNotNil: [ ^ ActiveWorld ].
	^ World! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
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: ''!
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: 'non-interactive' stamp: ''!
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: 'errors' stamp: ''!
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: 'debug' stamp: ''!
debugProcess: process context: context label: title fullView: bool notification: notificationString
	^ self nonInteractiveWarning: 'Opening Debugger'! !

!NonInteractiveUIManager methodsFor: 'errors' stamp: ''!
nonInteractiveWarning: aWarnMessage
	^ ProvideAnswerNotification signal: aWarnMessage! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
request: queryString initialAnswer: defaultAnswer
	^ self request: queryString initialAnswer: defaultAnswer title: nil entryCompletion: nil. ! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
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: ''!
confirm: aString orCancel: cancelBlock
	^  self nonInteractiveRequest: aString! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
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: ''!
requestPassword: queryString
	^self nonInteractiveWarning: 'Requesting Password'.! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
request: aStringOrText initialAnswer: defaultAnswer title: aTitle
	^ self request: aStringOrText initialAnswer: defaultAnswer title: aTitle entryCompletion: nil. ! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString trueChoice: trueChoice falseChoice: falseChoice 
	^  self nonInteractiveRequest: queryString! !

!NonInteractiveUIManager methodsFor: 'errors' stamp: ''!
nonInteractive
	^ ErrorNonInteractive signal! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
edit: aText label: labelString accept: aBlockOrNil
	"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: '*Files-Prompt' stamp: ''!
fileExistsDefaultAction: anException

	^ self nonInteractive: anException! !

!NonInteractiveUIManager methodsFor: 'errors' stamp: ''!
nonInteractive: anException
	^ ErrorNonInteractive signalForException: anException! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
request: queryString initialAnswer: defaultAnswer entryCompletion: anEntryCompletion
	^ self request: queryString initialAnswer: defaultAnswer title: nil entryCompletion: anEntryCompletion. ! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
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: ''!
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: ''!
confirm: queryString label: title trueChoice: trueChoice falseChoice: falseChoice cancelChoice: cancelChoice default: aSymbol
	^  self nonInteractiveRequest: queryString! !

!NonInteractiveUIManager methodsFor: '*Files-Prompt' stamp: ''!
fileDoesNotExistsDefaultAction: anException

	^ self nonInteractive: anException! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString label: titleString
	^  self nonInteractiveRequest: queryString title: titleString! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString trueChoice: trueChoice falseChoice: falseChoice cancelChoice: cancelChoice default: aSymbol
	^  self nonInteractiveRequest: queryString! !

!NonInteractiveUIManager methodsFor: 'ui requests' stamp: ''!
syntaxErrorNotificationDefaultAction: aSyntaxErrorNotification
	
	"display and log the syntax error"
	super syntaxErrorNotificationDefaultAction: aSyntaxErrorNotification.
	
	"in noninteractive mode simply quit"
	^ self exitFailure! !

!NonInteractiveUIManager class methodsFor: 'testing' stamp: ''!
isValidForCurrentSystemConfiguration

	^ Smalltalk isHeadless 
		and: [ Smalltalk isInteractive not
		and: [ Smalltalk isInteractiveGraphic not ] ]! !

!NonObservableSlotError commentStamp: ''!
I am an error raised when a user try to interact with a slot as an observable slot, but this slot is not observable.!
!NotFound commentStamp: ''!
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: ''!
collection
	"Return the collection where something is not found in"
	
	^ self signaler! !

!NotFound methodsFor: 'accessing' stamp: ''!
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: ''!
collection: aCollection
	"Set the collection where something is not found in"
	
	self signaler: aCollection! !

!NotFound methodsFor: 'private' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		stream print: self object.
		stream << ' not found in '.
		stream print: self collection class ]! !

!NotFound methodsFor: 'accessing' stamp: ''!
object
	"Return the object that was not found"
	
	^ object! !

!NotFound methodsFor: 'accessing' stamp: ''!
object: anObject
	"Set the object that was not found"
	
	object := anObject! !

!NotFound class methodsFor: 'instance creation' stamp: ''!
signalFor: anObject
	"Create and signal a NotFound exception for anObject in the default receiver."
	
	^ self new
		object: anObject;
		signal! !

!NotFound class methodsFor: 'instance creation' stamp: ''!
signalFor: anObject in: aCollection
	"Create and signal a NotFound exception for anObject in aCollection."

	^ self new
		object: anObject;
		collection: aCollection;
		signal! !

!NotYetImplemented commentStamp: ''!
I am NotYetImplement, an exception signaled when a method is a stub for code that will be implemented in the future.

This is used in incremental development, for example when doing Test First development.
It is similar to ShouldBeImplemented, with a slightly different meaning.!
!NotYetImplemented methodsFor: 'printing' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		stream print: self selector.
		stream << ' is not yet implemented in '.
		stream print: self signaler class]! !

!NothingToRedo commentStamp: ''!
I am an exception raised by a history iterator if the user try to redo an element of the history while there is nothing to redo.!
!NothingToUndo commentStamp: ''!
I am an exception raised by a history iterator if the user try to undo an element of the history while there is nothing to undo.!
!Notification commentStamp: ''!
A Notification is an indication that something interesting has occurred.  If it is not handled, it will pass by without effect.!
!Notification methodsFor: '*SUnit-Core' stamp: ''!
manageTestProcessBy: aProcessMonitorTestService
	"Notification is not considered as interesting exception for test monitoring.
	Normally they are resumable by default. So no break happens for the test"! !

!Notification methodsFor: 'handling' stamp: ''!
defaultAction
	"No action is taken. The value nil is returned as the value of the message that signaled the exception."

	^nil! !

!NullAnnotationContext commentStamp: ''!
I represent undefined annotation context which is initialized by default for annotation instances.

Annotations with undefined contexts (unspecified context) are never returned from contextual query of annotations.

I has singleton #instance on class side which is used by annotations as default context value!
!NullAnnotationContext methodsFor: 'testing' stamp: ''!
describes: anAnnotationUser

	^false! !

!NullAnnotationContext class methodsFor: 'accessing' stamp: ''!
instance
	^instance ifNil: [instance := self new]! !

!NullFFIBackend commentStamp: ''!
I am a null implementation of a FFIBackend!
!NullFFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float32At: offset put: value

	^ self primitiveFailed! !

!NullFFIBackend methodsFor: 'callbacks' stamp: ''!
lookupCallbackByAddress: address 
	
	^ self error: 'Null FFI backend does not know about callback in address ' , address printString! !

!NullFFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float32At: offset

	^ self primitiveFailed! !

!NullFFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float64At: offset put: value

	^ self primitiveFailed! !

!NullFFIBackend methodsFor: 'instance creation' stamp: ''!
allocate: byteSize
	"Primitive. Allocate an object on the external heap."
	^self primitiveFailed! !

!NullFFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float64At: offset

	^ self primitiveFailed! !

!NullFFIBackend methodsFor: 'instance creation' stamp: ''!
free: anExternalAddress

	^ self primitiveFailed! !

!NullFFIBackend methodsFor: 'accessing' stamp: ''!
integerOfObject: anObject at: byteOffset put: value size: nBytes signed: aBoolean

	^ self primitiveFailed! !

!NullFFIBackend methodsFor: 'accessing' stamp: ''!
integerOfObject: anObject at: byteOffset size: nBytes signed: aBoolean

	^ self primitiveFailed! !

!NullFFIBackend methodsFor: 'instance creation' stamp: ''!
loadSymbol: moduleSymbol module: module 

	^ self primitiveFailed! !

!NullFFIBackend class methodsFor: 'accessing' stamp: ''!
priority

	^ 0! !

!NullFFIBackend class methodsFor: 'accessing' stamp: ''!
isAvailable

	^ true! !

!NullPresenter commentStamp: ''!
A null presenter that contains nothing.
Used by DynamicPresentersListBuilder to fill empty space when required for the layout.!
!NullPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	"Does nothing. That's the point of null presenter."! !

!NullPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	"Returns empty layout. That's the point of null presenter."
	^ SpecLayout composed! !

!NullSound commentStamp: ''!
The NullSound means silence !
!NullSound class methodsFor: 'playing' stamp: ''!
play
	"Do nothing for the null sound."! !

!NullSoundTheme commentStamp: ''!
A silent sound theme!
!NullSoundTheme methodsFor: 'initialization' stamp: ''!
defaultDefaultSound
	"Answer the default default sound!!"

	^NullSound! !

!NullSoundTheme class methodsFor: 'accessing' stamp: ''!
themeName
	"Answer the friendly name of the theme."

	^'No Sounds'! !

!NullStream commentStamp: ''!
I am a stream that does nothing i.e. generates and consumes an infinite number of elements (NullObject pattern). I can be used as an equivalent of /dev/null (for example 
a logging in off mode) or for performance benchmarks.!
!NullStream methodsFor: 'testing' stamp: ''!
isEmpty
	"Answer whether the receiver's contents has no elements."

	^false! !

!NullStream methodsFor: 'reading' stamp: ''!
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: ''!
peekLast
	^ lastElement! !

!NullStream methodsFor: 'writing' stamp: ''!
lf
	^ self nextPut: Character lf! !

!NullStream methodsFor: 'positioning' stamp: ''!
position
	"Answer the current position of accessing the sequence of objects."

	^position! !

!NullStream methodsFor: 'writing' stamp: ''!
peek
	"Answer what would be returned if the message next were sent to the 
	receiver. If the receiver is at the end, answer nil."

	^self element! !

!NullStream methodsFor: 'accessing' stamp: ''!
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: 'positioning' stamp: ''!
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: 'accessing' stamp: ''!
element
	"The element returned by the stream"

	^binary ifTrue: [0] ifFalse: [Character value: 0]! !

!NullStream methodsFor: 'reading' stamp: ''!
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: 'testing' stamp: ''!
isBinary
	"Return true if the receiver is a binary byte stream"

	^binary! !

!NullStream methodsFor: 'accessing' stamp: ''!
next: anInteger putAll: aCollection startingAt: startIndex
	"Store the next anInteger elements from the given collection."

	position := position + anInteger.
	lastElement := aCollection at: anInteger + startIndex - 1.
	^aCollection! !

!NullStream methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: 'a '; nextPutAll: self class name.! !

!NullStream methodsFor: 'writing' stamp: ''!
tab
	^ self nextPut: Character tab! !

!NullStream methodsFor: 'accessing' stamp: ''!
nextPut: anObject 
	"Insert the argument, anObject, as the next object accessible by the 
	receiver. Answer anObject."

	position := position + 1.
	lastElement := anObject.
	^anObject! !

!NullStream methodsFor: 'accessing' stamp: ''!
contents
	"Answer all of the contents of the receiver."

	self shouldNotImplement! !

!NullStream methodsFor: 'modes' stamp: ''!
ascii
	"Switches the stream to ascii mode"

	binary := false.! !

!NullStream methodsFor: 'testing' stamp: ''!
atEnd
	"Answer whether the receiver can access any more objects."

	^false! !

!NullStream methodsFor: 'reading' stamp: ''!
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: 'initialization' stamp: ''!
reset
	"Set the receiver's position to the beginning of the sequence of objects."

	position := 0! !

!NullStream methodsFor: 'writing' stamp: ''!
next: anInteger putAll: aCollection
	"Store the next anInteger elements from the given collection."

	^self next: anInteger putAll: aCollection startingAt: 1! !

!NullStream methodsFor: 'reading' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"Initialize the receiver"

	binary := false.
	position := 0.! !

!NullStream methodsFor: 'positioning' stamp: ''!
positionError
	"Since I am not necessarily writable, it is up to my subclasses to override 
	position: if expanding the collection is preferrable to giving this error."

	self error: 'Attempt to set the position of a PositionableStream out of bounds'! !

!NullStream methodsFor: 'modes' stamp: ''!
binary
	"Switches the stream to binary mode"

	binary := true! !

!NullStream methodsFor: 'accessing' stamp: ''!
next
	"Answer the next object accessible by the receiver."

	position := position + 1.
	^self element! !

!NullStream methodsFor: 'accessing' stamp: ''!
collectionSpecies
	"The type of collection returned by the stream"

	^binary ifTrue: [ByteArray] ifFalse: [ByteString]! !

!NullStream methodsFor: 'writing' stamp: ''!
space
	^ self nextPut: Character space! !

!NullStream methodsFor: 'positioning' stamp: ''!
skip: anInteger 
	"Set the receiver's position to be the current position+anInteger. A 
	subclass might choose to be more helpful and select the minimum of the 
	receiver's size and position+anInteger, or the maximum of 1 and 
	position+anInteger for the repositioning."

	self position: position + anInteger! !

!NullStream methodsFor: 'reading' stamp: ''!
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: 'accessing' stamp: ''!
nextPutAll: aCollection
	"Append the elements of aCollection to the sequence of objects accessible 
	by the receiver. Answer aCollection."

	position := position + aCollection size.
	aCollection isEmpty
		ifFalse: [ lastElement := aCollection last ].
	^ aCollection! !

!NullStream methodsFor: 'writing' stamp: ''!
cr
	^ self nextPut: Character cr! !

!NullStream class methodsFor: 'instance creation' stamp: ''!
new
	"Creates a new instance"

	^self basicNew initialize! !

!NullStreamTest commentStamp: ''!
SUnit tests for null streams!
!NullStreamTest methodsFor: 'tests' stamp: ''!
testCounting
	| expectedPosition |
	expectedPosition := 0.
	self assert: stream position equals: expectedPosition.
	
	stream nextPut: $a.
	expectedPosition := expectedPosition + 1.
	self assert: stream position equals: expectedPosition.
	
	stream nextPutAll: 'bcd'.
	expectedPosition := expectedPosition + 3.
	self assert: stream position equals: expectedPosition.
	
	stream cr.
	expectedPosition := expectedPosition + 1.
	self assert: stream position equals: expectedPosition.
	
	stream lf.
	expectedPosition := expectedPosition + 1.
	self assert: stream position equals: expectedPosition.
	
	stream space.
	expectedPosition := expectedPosition + 1.
	self assert: stream position equals: expectedPosition.
	
	stream tab.
	expectedPosition := expectedPosition + 1.
	self assert: stream position equals: expectedPosition.
	
	stream next: 4 putAll: 'abcdefgh' startingAt: 3.
	expectedPosition := expectedPosition + 4.
	self assert: stream position equals: expectedPosition.! !

!NullStreamTest methodsFor: 'tests' stamp: ''!
testPeekLast
	self assert: stream peekLast equals: nil.
	stream nextPut: $a.
	self assert: stream peekLast equals: $a.
	stream nextPutAll: 'bcd'.
	self assert: stream peekLast equals: $d.
	stream cr.
	self assert: stream peekLast equals: Character cr.
	stream lf.
	self assert: stream peekLast equals: Character lf.
	stream space.
	self assert: stream peekLast equals: Character space.
	stream tab.
	self assert: stream peekLast equals: Character tab.
	stream next: 4 putAll: 'abcdefgh' startingAt: 3.
	self assert: stream peekLast equals: $f.! !

!NullStreamTest methodsFor: 'tests' stamp: ''!
testNextPutAllEmpty
	self assert: stream position equals: 0.
	self assert: stream peekLast equals: nil.
	stream nextPutAll: ''.
	self assert: stream position equals: 0.
	self assert: stream peekLast equals: nil.! !

!NullStreamTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	stream := NullStream new.! !

!NullTaskList commentStamp: ''!
I stand in when the task list is not open in the world.!
!NullTaskList methodsFor: 'event handling' stamp: ''!
handleEvent: aKeyboardEvent 

	(TaskListMorph isNavigationEvent: aKeyboardEvent) ifFalse: [ ^ false ].
	world theme openTaskListIn: world from: aKeyboardEvent.
	^ true.! !

!NullTaskList methodsFor: 'private' stamp: ''!
world: aWorldMorph 

	world := aWorldMorph.! !

!NullTaskList class methodsFor: 'instance creation' stamp: ''!
in: world

	^ self new
		world: world;
		yourself.! !

!NullTermInfo commentStamp: ''!
I provide a simple mapping from high-level commands to low-level terminal character sequences.
!
!NullTermInfo methodsFor: 'term style' stamp: ''!
set: aString
	^ aString! !

!NullTermInfo methodsFor: 'instance creation' stamp: ''!
on: aStream
	"Null"
	^self! !

!NullTextStyler commentStamp: ''!
This class is a styler NullObject!
!NullTextStyler methodsFor: 'accessing' stamp: ''!
environment: anObject! !

!NullTextStyler methodsFor: 'styling' stamp: ''!
styleInBackgroundProcess: aText! !

!NullTextStyler methodsFor: 'accessing' stamp: ''!
font: aFont! !

!NullTextStyler methodsFor: 'accessing' stamp: ''!
view: aViewOrMorph! !

!NullTextStyler methodsFor: 'styling' stamp: ''!
style: aText! !

!NullTextStyler methodsFor: 'accessing' stamp: ''!
classOrMetaClass: aBehavior! !

!NullTextStyler methodsFor: 'private' stamp: ''!
stylingEnabled: aBoolean! !

!NullTextStyler methodsFor: 'private' stamp: ''!
stylingEnabled

	^ false! !

!NullTextStyler methodsFor: 'styling' stamp: ''!
unstyledTextFrom: aText
	^aText! !

!NullTextStyler methodsFor: 'formatting' stamp: ''!
format: aText

	^ aText! !

!NullTextStyler methodsFor: 'accessing' stamp: ''!
workspace: aWorkspace! !

!NullWorldRenderer commentStamp: ''!
I am a null renderer.
I am used when we are in command line or during the initialization!
!NullWorldRenderer methodsFor: 'operations' stamp: ''!
forceDamageToScreen: allDamage

	"Do Nothing"! !

!NullWorldRenderer methodsFor: 'private' stamp: ''!
doActivate! !

!NullWorldRenderer methodsFor: 'operations' stamp: ''!
drawDuring: aBlock

	| canvas |
	canvas := (Form extent: self actualScreenSize depth: 32) getCanvas.
	aBlock value: canvas! !

!NullWorldRenderer methodsFor: 'rendering' stamp: ''!
updateDamage: rectangles

	"Do nothing"! !

!NullWorldRenderer methodsFor: 'operations' stamp: ''!
activateCursor: aCursor withMask: maskForm
	"Nothing to activate here"! !

!NullWorldRenderer methodsFor: 'utilities' stamp: ''!
convertWindowMouseEventPosition: aPosition

	^ aPosition! !

!NullWorldRenderer methodsFor: 'display box access' stamp: ''!
checkForNewScreenSize! !

!NullWorldRenderer methodsFor: 'accessing' stamp: ''!
actualScreenSize

	^ 240@120! !

!NullWorldRenderer methodsFor: 'accessing' stamp: ''!
windowTitle: aString

	"I am a dummy implementation"! !

!NullWorldRenderer methodsFor: 'events' stamp: ''!
updateToNewResolution! !

!NullWorldRenderer methodsFor: 'accessing' stamp: ''!
icon: aForm 

	"Do nothing, a null world rendered has no window, so no icon either"! !

!NullWorldRenderer methodsFor: 'private' stamp: ''!
deactivate! !

!NullWorldRenderer class methodsFor: 'accessing' stamp: ''!
isApplicableFor: aWorld
	"This worldRenderer is always applicable"

	^ true! !

!NullWorldRendererTest methodsFor: 'tests' stamp: ''!
testConvertWindowMouseEventPosition
	| renderer |
	

	renderer := NullWorldRenderer new.
	self 
		assert: (renderer convertWindowMouseEventPosition: 0@0)
		equals: 0@0! !

!Number commentStamp: ''!
Class Number holds the most general methods for dealing with numbers. Subclasses Float, Fraction, and Integer, and their subclasses, provide concrete representations of a numeric quantity.

All of Number's subclasses participate in a simple type coercion mechanism that supports mixed-mode arithmetic and comparisons.  It works as follows:  If
	self<typeA> op: arg<typeB>
fails because of incompatible types, then it is retried in the following guise:
	(arg adaptTypeA: self) op: arg adaptToTypeA.
This gives the arg of typeB an opportunity to resolve the incompatibility, knowing exactly what two types are involved.  If self is more general, then arg will be converted, and viceVersa.  This mechanism is extensible to any new number classes that one might wish to add to Pharo.  The only requirement is that every subclass of Number must support a pair of conversion methods specific to each of the other subclasses of Number.

Implementation notes
----------------------------------
The implementation of #degreeCos and #degreeSin is such that results are exact for any multiple of 90.

Care is also taken to evaluate the sine between -90° and 90°, this will avoid #degreesToRadians and i386 FPU sine function to accumulate round off errors due to approximate representation of pi.
We can thus evaluate 240 degreeCos with at most 1 ulp error. It's not perfect, but better than previous implementation.

For cosine, we know that:
	cosd(x)=cosd(abs(x))
	cosd(x)=sind(90-x)
thus the trick is to evaluate:
	cosd(x)=sind(90-abs(x)) after appropriate modulo in [-180,180[
This way, we are sure to evaluate the sine between -90° and 90°
The #degreesToRadians and #sin are used rather than #degreeSin to avoid cycles.

For sine, it would be necessary to evaluate either
sind(x) if abs(x) <=90
or sind(180-x) if abs(x) >= 90
A possible implementation would be:
	| x |
	x := 90 + self \\ 360 - 90.
	x >= 180 ifTrue: [x := 180 - x].
	^x degreesToRadians sin
We prefer evaluating cosd(90-x) thus providing a branch free implementation.!
!Number methodsFor: 'truncation and round off' stamp: ''!
roundUpTo: aNumber 
	"Answer the next multiple of aNumber toward infinity that is nearest the receiver."
	"(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: '*Math-Operations-Extensions' stamp: ''!
% aNumber 
	"modulo. Remainder defined in terms of //. Answer a Number with the 
	same sign as aNumber."
	
	"9 % 4 >>> 1"
	"-9 % 4 >>> 3"
	"9 % -4 >>> -3"
	
	
	^ self \\ aNumber! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
nanoSecond
	"1 nanoSecond printString >>> '0:00:00:00.000000001'"
	"(1 milliSecond + 1 nanoSecond) printString >>> '0:00:00:00.001000001'"
 
 	^ self nanoSeconds! !

!Number methodsFor: 'truncation and round off' stamp: ''!
integerPart
	"Added for ANSI compatibility"
	^self truncated! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
milliSecond
	"1 milliSecond printString >>> '0:00:00:00.001'"
	"(1 second + 1 milliSecond) printString >>> '0:00:00:01.001'"
	
 	^ self milliSeconds! !

!Number methodsFor: 'converting' stamp: ''!
copySignTo: aNumber
	"Return a number with same magnitude as aNumber and same sign as self."

	^ self signBit = 0
		ifTrue: [aNumber abs]
		ifFalse: [aNumber abs negated].! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
days
 
 	^ Duration days: self! !

!Number methodsFor: 'converting' stamp: ''!
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: '*Kernel-Chronology' stamp: ''!
asSeconds
	^ Duration milliSeconds: self * 1000! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
second
	"1 second printString >>> '0:00:00:01'"
	"(1 minute + 1 second) printString >>> '0:00:01:01'"
	
 	^ self seconds! !

!Number methodsFor: 'arithmetic' stamp: ''!
- aNumber 
	"Answer the difference between the receiver and aNumber."

	self subclassResponsibility! !

!Number methodsFor: 'printing' stamp: ''!
stringForReadout
	^ self rounded printString! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
strictlyPositive
	"Answer whether the receiver is mathematically positive."

	^ self > 0! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
squared
	"Answer the receiver multiplied by itself."

	^self * self! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
isDivisibleBy: aNumber
	aNumber = 0 ifTrue: [^ false].
	aNumber isInteger ifFalse: [^ false].
	^ (self \\ aNumber) = 0! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
degreeSin
	"Answer the sine of the receiver taken as an angle in degrees."
	
	^(90 - self) degreeCos! !

!Number methodsFor: 'printing' stamp: ''!
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: 'converting' stamp: ''!
asScaledDecimal
	"Answer a scaled decimal number approximating the receiver."
	#Numeric.

	^ self asScaledDecimal: 8! !

!Number methodsFor: 'arithmetic' stamp: ''!
negated
	"Answer a Number that is the negation of the receiver."

	^0 - self! !

!Number methodsFor: 'mathematical functions' stamp: ''!
raisedToFraction: aFraction
	self isZero
		ifTrue:
			[aFraction negative ifTrue: [^ (ZeroDivide dividend: 1) signal].
			^self].
	self negative ifFalse: [^(self ln * aFraction) exp].
	aFraction denominator even
		ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.'].
	^(self negated ln * aFraction) exp negated! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
seconds

	"2 seconds printString >>> '0:00:00:02'"
	"(1 minute + 2 seconds) printString >>> '0:00:01:02'"
 
 	^ Duration seconds: self! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
nthRoot: aPositiveInteger
	"Answer the nth root of the receiver."

	self subclassResponsibility! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
years
 
 	^ Duration years: self! !

!Number methodsFor: 'mathematical functions' stamp: ''!
signBit
	"Answer 1 if the receiver is negative, zero otherwise."

	self < 0 ifTrue: [^1].
	^0! !

!Number methodsFor: 'truncation and round off' stamp: ''!
truncated
	"Answer an integer nearest the receiver toward zero."

	^self quo: 1! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
week
 
 	^ self weeks! !

!Number methodsFor: 'testing' stamp: ''!
isNaN
	^ false! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
cos
	"The receiver represents an angle measured in radians. Answer its cosine."

	^self asFloat cos! !

!Number methodsFor: 'converting' stamp: ''!
asNumber
	^ self! !

!Number methodsFor: 'truncation and round off' stamp: ''!
reduce
    "If self is close to an integer, return that integer"
    ^ self! !

!Number methodsFor: 'converting' stamp: ''!
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: '*Collections-Sequenceable' stamp: 'nil'!
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: '*Kernel-Chronology' stamp: ''!
asDuration
 
 	^ Duration seconds: self asInteger! !

!Number methodsFor: 'arithmetic' stamp: ''!
* aNumber 
	"Answer the result of multiplying the receiver by aNumber."

	self subclassResponsibility! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
day
 
 	^ self days! !

!Number methodsFor: 'truncation and round off' stamp: ''!
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: '*Collections-Sequenceable' stamp: 'nil'!
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: 'converting' stamp: ''!
adaptToInteger: rcvr andSend: selector
	"If I am involved in arithmetic with a Integer, convert us and evaluate exprBlock."
	^ self subclassResponsibility! !

!Number methodsFor: 'testing' stamp: ''!
isInfinite

	^ false! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
minute
	"1 minute printString >>> '0:00:01:00'"
	"(1 hour + 1 minute) printString >>> '0:01:01:00'"
 
 	^ self minutes! !

!Number methodsFor: '*Geometry' stamp: ''!
divideWithAngle: aGAngle 
	^ (aGAngle radians / self) radians! !

!Number methodsFor: 'converting' stamp: ''!
asInteger
	"Round me towards nearest integer closer to zero."
	"This violates the ANSI standard, but the system depends on this"

	^self truncated! !

!Number methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter writeFloat: self asFloat! !

!Number methodsFor: 'arithmetic' stamp: ''!
\\ aNumber 
	"modulo. Remainder defined in terms of //. Answer a Number with the 
	same sign as aNumber."
	
	"9 \\ 4 >>> 1"
	"-9 \\ 4 >>> 3"
	"9 \\ -4 >>> -3"

	^self - (self // aNumber * aNumber)! !

!Number methodsFor: 'arithmetic' stamp: ''!
@ y 
	"Primitive. Answer a Point whose x value is the receiver and whose y 
	value is the argument. Optional. No Lookup. See Object documentation 
	whatIsAPrimitive."

	<primitive: 18>
	^Point x: self y: y! !

!Number methodsFor: 'testing' stamp: ''!
isNumber
	^ true! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
radiansToDegrees
	"The receiver is assumed to represent radians. Answer the conversion to 
	degrees."
	
	"Float pi radiansToDegrees >>> 180.0"

	^self asFloat radiansToDegrees! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
arcTan
	"The receiver is the tangent of an angle. Answer the angle measured in 
	radians."

	^self asFloat arcTan! !

!Number methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects 
	^ false! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
floorLog: radix
	"Answer the floor of the log base radix of the receiver."

	^(self log: radix) floor! !

!Number methodsFor: '*Roassal3-Chart' stamp: ''!
to: upperBound count: count
	"Answer an Interval from the receiver up to the argument, stop, 
	incrementing by step."

	| answer |
	count = 1 ifTrue: [ ^ Array with: self ].
	
	answer := self to: upperBound by: (upperBound - self) / (count - 1).
	"We need to do a bit of fiddling because of the float precision"
	^ answer size = count 
			ifTrue: [ answer ]
			ifFalse: [ answer asArray, { upperBound } ]! !

!Number methodsFor: 'arithmetic' stamp: ''!
abs
	"Answer a Number that is the absolute value (positive magnitude) of the 
	receiver."

	self < 0
		ifTrue: [^self negated]
		ifFalse: [^self]! !

!Number methodsFor: 'truncation and round off' stamp: ''!
fractionPart
	"Added for ANSI compatibility"
	^self - self integerPart! !

!Number methodsFor: 'arithmetic' stamp: ''!
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: 'converting' stamp: ''!
asScaledDecimal: scale 
	"Answer the receiver converted to a ScaledDecimal."
	
	^ ScaledDecimal newFromNumber: self scale: scale! !

!Number methodsFor: '*Collections-Sequenceable' stamp: 'nil'!
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: '*Math-Operations-Extensions' stamp: ''!
degreeCos
	"Answer the cosine of the receiver taken as an angle in degrees."
	
	^ (90 - (180 + self \\ 360 - 180) abs) degreesToRadians sin! !

!Number methodsFor: 'converting' stamp: ''!
asSmallPositiveDegrees
	"Return the receiver normalized to lie within the range (0, 360)"

	^self \\ 360! !

!Number methodsFor: 'truncation and round off' stamp: ''!
roundTo: quantum 
	"Answer the nearest number that is a multiple of quantum."

	^(self / quantum) rounded * quantum! !

!Number methodsFor: 'printing' stamp: ''!
storeStringBase: base
	"Returns a string representation of the receiver in base 16 in a way that executing it will return the receiver."
	"(10 storeStringBase: 16) >>> '16rA'"
	"(10 storeStringBase: 10) >>> '10'"

	^ String streamContents: [:strm | self storeOn: strm base: base]! !

!Number methodsFor: '*Geometry' stamp: ''!
, aNumber
	^ GPoint x: self y: aNumber! !

!Number methodsFor: '*Geometry' stamp: ''!
π
	^ self * Float pi! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
percent

	^ self / 100! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
degreesToRadians
	"The receiver is assumed to represent degrees. Answer the conversion to 
	radians."

	^self asFloat degreesToRadians! !

!Number methodsFor: '*Geometry' stamp: ''!
multiplyWithAngle: aGAngle 
	^ (aGAngle radians * self) radians! !

!Number methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	self printOn: aStream! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
ln
	"Answer the natural log of the receiver."

	^self asFloat ln! !

!Number methodsFor: 'arithmetic' stamp: ''!
+ aNumber 
	"Answer the sum of the receiver and aNumber."

	self subclassResponsibility! !

!Number methodsFor: 'truncation and round off' stamp: ''!
floor
	"Answer the integer nearest the receiver toward negative infinity."

	| truncation |
	truncation := self truncated.
	self >= 0 ifTrue: [^truncation].
	self = truncation
		ifTrue: [^truncation]
		ifFalse: [^truncation - 1]! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
sqrt
	"Answer the square root of the receiver."

	self subclassResponsibility! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
closeTo: num precision: aPrecision
	"are these two numbers close?"

	num isFloat ifTrue: [ ^ num closeTo: self asFloat precision: aPrecision ].
	^ [ self = num ] onErrorDo: [ false ]! !

!Number methodsFor: 'arithmetic' stamp: ''!
rem: aNumber 
	"Remainder defined in terms of quo:. Answer a Number with the same 
	sign as self. e.g. 9 rem: 4 = 1, -9 rem: 4 = -1. 0.9 rem: 0.4 = 0.1."

	^self - ((self quo: aNumber) * aNumber)! !

!Number methodsFor: 'arithmetic' stamp: ''!
/ aNumber 
	"Answer the result of dividing the receiver by aNumber."

	self subclassResponsibility! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
sin
	"The receiver represents an angle measured in radians. Answer its sine."

	^self asFloat sin! !

!Number methodsFor: '*Geometry' stamp: ''!
multiplyWithVector: aGVector 
	^ (aGVector coordinates * self) asGVector! !

!Number methodsFor: 'converting' stamp: ''!
sign
	"Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0."

	self > 0 ifTrue: [^1].
	self < 0 ifTrue: [^-1].
	^0! !

!Number methodsFor: 'printing' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
arcSin
	"The receiver is the sine of an angle. Answer the angle measured in 
	radians."

	^self asFloat arcSin! !

!Number methodsFor: 'mathematical functions' stamp: ''!
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: 'testing' stamp: ''!
isZero
	^self = 0! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
even
	"Answer whether the receiver is an even number."

	^self \\ 2 = 0! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
** exponent 
	" A shortcut method for raisedTo: "
	
	"2 ** 8 >>> 256"
	"8 ** 2 >>> 64"
	"2 ** (1/12) >>> 1.0594630943592953"
	"2 ** -1 >>> (1/2)"
	
	^ self raisedTo: exponent! !

!Number methodsFor: '*Collections-Sequenceable' stamp: 'nil'!
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: '*Kernel-Chronology' stamp: ''!
milliSeconds

	"2 milliSeconds printString >>> '0:00:00:00.002'"
	"(1 second + 2 milliSeconds) printString >>> '0:00:00:01.002'"
	
 	^ Duration milliSeconds: self! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
tan
	"The receiver represents an angle measured in radians. Answer its 
	tangent."

	^self asFloat tan! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Geometry' stamp: ''!
radians
	^ GAngle radians: self! !

!Number methodsFor: 'truncation and round off' stamp: ''!
rounded
	"Answer the integer nearest the receiver."
	
	"1.4 rounded >>> 1"
	"1.5 rounded >>> 2"
	"2 rounded >>> 2"
	"-1.5 rounded >>> -2"

	^(self + (self sign / 2)) truncated! !

!Number methodsFor: 'truncation and round off' stamp: ''!
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: '*Kernel-Chronology' stamp: ''!
minutes
	"2 minutes printString >>> '0:00:02:00'"
	"(1 hour + 2 minutes) printString >>> '0:01:02:00'"
 
 	^ Duration minutes: self! !

!Number methodsFor: 'mathematical functions' stamp: ''!
raisedTo: aNumber 
	"Answer the receiver raised to aNumber."
	
	"(2 raisedTo: 8) >>> 256"
	"(8 raisedTo: 2) >>> 64"
	"(2 raisedTo: (1/12)) >>> 1.0594630943592953"
	"(2 raisedTo: -1) >>> (1/2)"

	aNumber isInteger ifTrue: [
		"Do the special case of integer power"
		^ self raisedToInteger: aNumber].
	aNumber isFraction ifTrue: [
		"Special case for fraction power"
		^ self raisedToFraction: aNumber].
	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: 1) signal]
			ifFalse: [^ self]].
	^ (aNumber * self ln) exp		"Otherwise use logarithms"! !

!Number methodsFor: 'testing' stamp: ''!
negative
	"Answer whether the receiver is mathematically negative."

	^ self < 0! !

!Number methodsFor: '*Geometry' stamp: ''!
degrees
	^ GAngle degrees: self! !

!Number methodsFor: 'truncation and round off' stamp: ''!
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: 'printing' stamp: ''!
printString
	^self printStringBase: 10! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
odd
	"Answer whether the receiver is an odd number."

	^self even == false! !

!Number methodsFor: 'converting' stamp: ''!
asFloat
	"Answer a floating-point number approximating the receiver."

	self subclassResponsibility! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
interpolateTo: aNumber at: param
    ^  self * (1 - param) + (aNumber * param)! !

!Number methodsFor: 'printing' stamp: ''!
printStringBase: base
	"Return a String representation of this number in base b."
	"(10 printStringBase: 10) >>> '10'"
	"(-10 printStringBase: 10) >>> '-10'"
	"(10 printStringBase: 2) >>> '1010'"
	"(10 printStringBase: 16) >>> 'A'"
	
	^ String streamContents: [:strm | self printOn: strm base: base]! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
log
	"Answer the base-10 log of the receiver."

	^self asFloat log! !

!Number methodsFor: 'printing' stamp: ''!
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. Here are some examples:"
	
	"(23 printShowingDecimalPlaces: 2) >>> '23.00'"
	"(23.5698 printShowingDecimalPlaces: 2) >>> '23.57'"
	"(-234.567 printShowingDecimalPlaces: 5) >>> '-234.56700'"
	"(23.4567 printShowingDecimalPlaces: 0) >>> '23'"
	"(-23.4567 printShowingDecimalPlaces: 0) >>> '-23'"
	"(100000000 printShowingDecimalPlaces: 1) >>> '100000000.0'"
	"(0.98 printShowingDecimalPlaces: 5) >>> '0.98000'"
	"(-0.98 printShowingDecimalPlaces: 2) >>> '-0.98'"
	"(2.567 printShowingDecimalPlaces: 2) >>> '2.57'"
	"(-2.567 printShowingDecimalPlaces: 2) >>> '-2.57'"
	"(0 printShowingDecimalPlaces: 2) >>> '0.00'"

	^String new: placesDesired + 10 streamContents: [:aStream |
		self printOn: aStream showingDecimalPlaces: placesDesired]! !

!Number methodsFor: 'converting' stamp: ''!
sign: aNumber
 	"Return a Number with the same sign as aNumber"
 
 	^ aNumber copySignTo: self.! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
log: aNumber 
	"Answer the log base aNumber of the receiver."

	^self ln / aNumber ln! !

!Number methodsFor: 'printing' stamp: ''!
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: 'testing' stamp: ''!
positive
	"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
	See also strictlyPositive"

	^ self >= 0! !

!Number methodsFor: 'printing' stamp: ''!
printOn: aStream
	self printOn: aStream base: 10! !

!Number methodsFor: 'truncation and round off' stamp: ''!
truncateTo: aNumber 
	"Answer the next multiple of aNumber toward zero that is nearest the receiver."
	"(3.1479 truncateTo: 0.01) >>>  3.14"
   "(3.1479 truncateTo: 0.1) >>>  3.1"
	"(1923 truncateTo: 10) >>>  1920"
	"(1929 truncateTo: 10) >>>  1920"
	"(-1929 truncateTo: 10) >>>  -1920"
	"(3.1479 truncateTo: 0.005) >>>  3.145"
	"(-3.1479 truncateTo: 0.01) >>>  -3.14"
             
	^(self quo: aNumber) * aNumber! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
closeTo: num
	"Tell whether the receiver and arguments are close from each."

	num isFloat ifTrue: [ ^ num closeTo: self asFloat ].
	^ [ self = num ] onErrorDo: [ false ]! !

!Number methodsFor: 'converting' stamp: ''!
asMargin
	^ Margin fromNumber: self.! !

!Number methodsFor: 'converting' stamp: ''!
asPoint
	"Answer a Point with the receiver as both coordinates; often used to 
	supply the same value in two dimensions, as with symmetrical gridding 
	or scaling."

	^self @ self! !

!Number methodsFor: 'converting' stamp: ''!
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: '*Kernel-Chronology' stamp: ''!
nanoSeconds
	"2 nanoSeconds printString >>> '0:00:00:00.000000002'"
	"(1 milliSecond + 2 nanoSeconds) printString >>> '0:00:00:00.001000002'"
 
 	^ Duration nanoSeconds: self.! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
arcCos 
	"The receiver is the cosine of an angle. Answer the angle measured in 
	radians."

	^self asFloat arcCos! !

!Number methodsFor: 'arithmetic' stamp: ''!
reciprocal
	"Returns the reciprocal of self.
	In case self is 0 the / signals ZeroDivide"
	
	"1/2 reciprocal >>> 2"
	"2 reciprocal >>> (1/2)"
	"1.25 reciprocal >>> 0.8"
	"-2 reciprocal >>> (-1/2)"
	
	^1 / self! !

!Number methodsFor: '*Morphic-Base' stamp: ''!
defaultLabel
	"Answer the default label to be used for an Inspector window on the receiver."

	^ super defaultLabel, ': ', self printString! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
hour
 
 	^ self hours! !

!Number methodsFor: 'truncation and round off' stamp: ''!
round: numberOfWishedDecimal
	"Round the decimal part of the receiver to be limited to the number of wished decimal. Only leave a fixed amount of decimal"
   < expr: 10.12345 round: 2 result: 10.12 >
	< expr: 10.199999999 round: 2 result: 10.2 > 
	^ self subclassResponsibility! !

!Number methodsFor: 'arithmetic' stamp: ''!
// aNumber 
	"Integer quotient defined by division with truncation toward negative 
	infinity. 9//4 = 2, -9//4 = -3. -0.9//0.4 = -3. \\ answers the remainder 
	from this division."

	^(self / aNumber) floor! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
arcTan: denominator
	"The receiver is the tangent of an angle. Answer the angle measured in 
	radians."

	^ self asFloat arcTan: denominator! !

!Number methodsFor: '*Geometry' stamp: ''!
=~ aNumber 
	^((self - aNumber) abs) < Number epsilon.! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
weeks
 
 	^ Duration weeks: self! !

!Number methodsFor: '*Kernel-Chronology' stamp: ''!
year
 
 	^self years! !

!Number methodsFor: 'mathematical functions' stamp: ''!
exp
	"Answer the exponential of the receiver as a floating point number."

	^self asFloat exp! !

!Number methodsFor: 'adding' stamp: ''!
addAssignToFloatArray: aFloatArray
	^ aFloatArray primAddScalar: self asFloat! !

!Number methodsFor: 'converting' stamp: ''!
adaptToFraction: rcvr andSend: selector
	"If I am involved in arithmetic with a Fraction, convert us and evaluate exprBlock."
	^ self subclassResponsibility! !

!Number methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: '*Kernel-Chronology' stamp: ''!
hours
 
 	^ Duration hours: self! !

!Number class methodsFor: 'instance creation' stamp: ''!
new

	self == Number ifTrue: [
		^ self error: 'Number is an abstract class.  Make a concrete subclass.'].
	^ super new! !

!Number class methodsFor: '*NumberParser' stamp: ''!
readFrom: stringOrStream base: base
	"Answer a number as described on aStream in the given number base.
	If stringOrStream does not start with a valid number description, answer 0 for backward compatibility. This is not clever and should better be changed."

	^(NumberParser on: stringOrStream) nextNumberBase: base! !

!Number class methodsFor: '*Debugger-Model' stamp: ''!
canonicalArgumentName

	^ 'aNumber'.! !

!Number class methodsFor: '*NumberParser' stamp: ''!
squeezeNumberOutOfString: stringOrStream
	"Try and find a number in this string. First, look if the string 
	starts with a number. Then, see if it ends with a number. Then,
	remove a character from the front and see if the remaining 
	string makes a number. Repeat the process until no characters
	are left or the number has been found. As soon as a number is
	found, it is returned. Otherwise, the method fails."
	^ NumberParser squeezeNumberOutOfString: stringOrStream! !

!Number class methodsFor: '*NumberParser' stamp: ''!
readFrom: stringOrStream ifFail: aBlock
	"Answer a number as described on aStream.  The number may
	be any accepted Smalltalk literal Number format.
	It can include a leading radix specification, as in 16rFADE.
	It can as well be NaN, Infinity or -Infinity for conveniency.
	If input does not represent a valid number, then execute fail block
	and leave the stream positioned before offending character"
	
	^(NumberParser on: stringOrStream) failBlock: aBlock; nextNumber! !

!Number class methodsFor: '*NumberParser' stamp: ''!
squeezeNumberOutOfString: stringOrStream ifFail: aBlock
	"Try and find a number in this string. First, look if the string 
	starts with a number. Then, see if it ends with a number. Then,
	remove a character from the front and see if the remaining 
	string makes a number. Repeat the process until no characters
	are left or the number has been found. As soon as a number is
	found, it is returned. Otherwise, the method fails."
	^ NumberParser squeezeNumberOutOfString: stringOrStream onError: aBlock! !

!Number class methodsFor: 'constants' stamp: ''!
one

	^1! !

!Number class methodsFor: '*System-Settings-Browser' stamp: ''!
settingInputWidgetForNode: aSettingNode
	^ aSettingNode inputWidgetForNumber! !

!Number class methodsFor: '*Geometry' stamp: ''!
epsilon
	^ 0.00001! !

!Number class methodsFor: '*NumberParser' stamp: ''!
readFrom: stringOrStream 
	"Answer a number as described on aStream.  The number may
	be any accepted Smalltalk literal Number format.
	It can include a leading radix specification, as in 16rFADE.
	It can as well be NaN, Infinity or -Infinity for conveniency.
	If stringOrStream does not start with a valid number description, fail."
	
	^(NumberParser on: stringOrStream) nextNumber! !

!NumberParser commentStamp: ''!
NumberParser implements parsing and building numbers from string/stream.
It offers a framework with utility methods and exception handling.

Instance variables:
sourceStream <Stream> the stream of characters from which the number is read
base <Integer> the radix in which to interpret digits
neg <Boolean> true in case of minus sign
integerPart <Integer> the integer part of the number
fractionPart <Integer> the fraction part of the number if any
exponent <Integer> the exponent used in scientific notation if any
scale <Integer> the scale used in case of ScaledDecimal number if any
nDigits <Integer> number of digits read to form an Integer
lasNonZero <Integer> 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 <BlockClosure> Block to execute whenever an error occurs!
!NumberParser methodsFor: 'accessing' stamp: ''!
requestor: anObjectOrNil
	requestor := anObjectOrNil! !

!NumberParser methodsFor: 'private - parsing' stamp: ''!
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' stamp: ''!
nextScaledDecimal
	"Main method for reading a (scaled) decimal number.
	Good Gracious, do not accept a decimal in another base than 10!!
	In other words, do not accept radix notation like 2r1.1, even not 10r5.3
	Do not accept exponent notation neither, like 1.0e-3"
	
	| numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart |
	base := 10.
	neg := sourceStream peekFor: $-.
	integerPart := self nextUnsignedIntegerBase: base.
	(sourceStream peekFor: $.)
		ifTrue: [fractionPart := self nextUnsignedIntegerOrNilBase: base.
			fractionPart ifNil: ["Oops, the decimal point seems not part of this number"
							sourceStream skip: -1.
							^ neg
								ifTrue: [integerPart negated asScaledDecimal: 0]
								ifFalse: [integerPart asScaledDecimal: 0]].
			numberOfNonZeroFractionDigits := lastNonZero.
			numberOfTrailingZeroInFractionPart := nDigits - lastNonZero.
			(self readScaleWithDefaultNumberOfDigits: nDigits)
				ifFalse: ["No scale were provided. use number of digits after decimal point as scale"
					scale := nDigits].
			^self makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart].
	self readScaleWithDefaultNumberOfDigits: 0.
	neg	ifTrue: [integerPart := integerPart negated].
	^integerPart asScaledDecimal: scale! !

!NumberParser methodsFor: 'private - parsing' stamp: ''!
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' stamp: ''!
nextInteger
	"Main method for reading an Integer.
	This won't try to read a Float nor a ScaledDecimal."
	
	base := 10.
	neg := self peekSignIsMinus.
	integerPart := self nextUnsignedIntegerOrNilBase: base.
	integerPart ifNil: [ ^self expected: 'Digit'].
	(sourceStream peekFor: $r)
		ifTrue: ["<base>r<integer>"
			(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]].
			self peekSignIsMinus ifTrue: [neg := neg not].
			integerPart := self nextUnsignedIntegerOrNilBase: base.
			integerPart ifNil: [^self expected: 'Digit']].
	neg
		ifTrue: [integerPart := integerPart negated].
	self readExponent
		ifTrue: [^integerPart * (base raisedToInteger: exponent)].
	^ integerPart! !

!NumberParser methodsFor: 'parsing' stamp: ''!
nextUnsignedIntegerBase: aRadix 
	"Form an unsigned integer with incoming digits from sourceStream.
	Fail if no digit found.
	Since only characters $A - $Z are supported, limit the character range shown on error.
	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 min: 36) - 1))].
	^value! !

!NumberParser methodsFor: 'parsing' stamp: ''!
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: 'private - parsing' stamp: ''!
readNamedFloatOrFail
	"This method is used when there is no digit encountered:
	It try and read a named Float NaN or Infinity.
	Negative sign for -Infinity has been read before sending this method, and is indicated in the neg inst.var.
	Fail if no named Float is found"
		
	neg ifFalse: [(sourceStream nextMatchAll: 'NaN')
			ifTrue: [^ Float nan]].
	(sourceStream nextMatchAll: 'Infinity')
		ifTrue: [^ neg
			ifTrue: [Float infinity negated]
			ifFalse: [Float infinity]].
	^self expected: 'a digit between 0 and ' , (String with: (Character digitValue: base - 1))! !

!NumberParser methodsFor: 'parsing' stamp: ''!
nextUnsignedIntegerOrNilBase: aRadix
	"Form an unsigned integer with incoming digits from sourceStream.
	Answer this integer, or nil if no digit found.
	Count the number of digits and the position of lastNonZero digit and store them in instVar"
	
	| nPackets high nDigitsHigh lastNonZeroHigh low |
	"read no more digits than one elementary LargeInteger"
	high :=  self nextElementaryLargeIntegerBase: aRadix.
	nDigits = 0 ifTrue: [^nil].
	
	"Not enough digits to form a LargeInteger, stop iteration"
	high isLarge ifFalse: [^high].

	"We now have to engage arithmetic with LargeInteger
	Decompose the integer in a high and low packets of growing size:"
	nPackets := 1.
	nDigitsHigh := nDigits.
	lastNonZeroHigh := lastNonZero.
	[
	low := self nextLargeIntegerBase: aRadix nPackets: nPackets .
	high := high * (aRadix raisedToInteger: nDigits) + low.
	lastNonZero = 0 ifFalse: [lastNonZeroHigh := lastNonZero + nDigitsHigh].
	nDigitsHigh := nDigitsHigh + nDigits.
	low isLarge]
		whileTrue: [nPackets := nPackets * 2].

	nDigits := nDigitsHigh.
	lastNonZero := lastNonZeroHigh.
	^high! !

!NumberParser methodsFor: 'private - parsing - large int' stamp: ''!
nextLargeIntegerBase: aRadix nPackets: nPackets 
	"Form a Large integer with incoming digits from sourceStream.
	Return this integer, or zero if no digits found.
	Stop reading when no more digits or when nPackets elementary LargeInteger have been encountered.
	Count the number of digits and the lastNonZero digit and store them in instVar"
	
	| high nDigitsHigh lastNonZeroHigh low nDigitsLow halfPackets |
	halfPackets := nPackets bitShift: -1.
	halfPackets = 0 ifTrue: [^self nextElementaryLargeIntegerBase: aRadix].
	high := self nextLargeIntegerBase: aRadix nPackets: halfPackets.
	high isLarge ifFalse: [^high].
	nDigitsHigh := nDigits.
	lastNonZeroHigh := lastNonZero.
	low := self nextLargeIntegerBase: aRadix nPackets: halfPackets.
	nDigitsLow := nDigits.
	nDigits := nDigitsHigh + nDigitsLow.
	lastNonZero := lastNonZero = 0
		ifTrue: [lastNonZeroHigh]
		ifFalse: [lastNonZero + nDigitsHigh].
	^high * (aRadix raisedToInteger: nDigitsLow) + low! !

!NumberParser methodsFor: 'private - parsing - large int' stamp: ''!
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) isNil
		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' stamp: ''!
nextFraction
	| numerator denominator |
	numerator := self nextInteger.
	(sourceStream peekFor: $/) ifFalse: [^numerator].
	denominator := self nextInteger.
	^numerator / denominator! !

!NumberParser methodsFor: 'parsing' stamp: ''!
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: 'error' stamp: ''!
expected: aString

	| errorString |

	errorString := aString , ' expected'.
	requestor
		ifNotNil: [ 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: 'private - parsing' stamp: ''!
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' stamp: ''!
nextNumber
	"Main method for reading a number.
	 This one can read Float Integer and ScaledDecimal"
	
	| numberOfTrailingZeroInIntegerPart |
	base := 10.
	neg := self peekSignIsMinus.
	integerPart := self nextUnsignedIntegerOrNilBase: base.
	integerPart ifNil: [
		"This is not a regular number beginning with a digit
		It is time to check for exceptional condition NaN and Infinity"
		^self readNamedFloatOrFail].
	numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero.
	(sourceStream peekFor: $r)
		ifTrue: ["<base>r<integer>"
			(base := integerPart) < 2
				ifTrue: [
					sourceStream skip: -1.
					^ self expected: 'an integer greater than 1 as valid radix'].
			self peekSignIsMinus
				ifTrue: [neg := neg not].
			integerPart := self nextUnsignedIntegerBase: base.
			numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero].
	^ (sourceStream peekFor: $.)
		ifTrue: [self readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart]
		ifFalse: [self makeIntegerOrScaledIntegerOrFloat]! !

!NumberParser methodsFor: 'accessing' stamp: ''!
failBlock: aBlockOrNil
	failBlock := aBlockOrNil! !

!NumberParser methodsFor: 'accessing' stamp: ''!
allowPlusSignInExponent
	"Return a boolean indicating if plus sign is allowed or not in exponent"

	^self allowPlusSign! !

!NumberParser methodsFor: 'accessing' stamp: ''!
exponentLetters
	"answer the list of possible exponents for Numbers.
	Note: this parser will not honour precision attached to the exponent.
	different exponent do not lead to different precisions.
	only IEEE 754 floating point numbers will be created"
	
	^'edq'! !

!NumberParser methodsFor: 'initialization' stamp: ''!
on: aStringOrStream 
	sourceStream := aStringOrStream isString 
		ifTrue: [ aStringOrStream readStream ]
		ifFalse: [ aStringOrStream ].
	base := 10.
	neg := false.
	integerPart := fractionPart := exponent := scale := 0.
	requestor := failBlock := nil! !

!NumberParser methodsFor: 'accessing' stamp: ''!
allowPlusSign
	"Return a boolean indicating if plus sign is allowed or not"

	^false! !

!NumberParser methodsFor: 'private - parsing' stamp: ''!
readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart
	"At this stage, sign integerPart and a decimal point have been read.
	try and form a number with a fractionPart"
	
	| numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart mantissa value |
	fractionPart := self nextUnsignedIntegerOrNilBase: base.
	fractionPart ifNil: ["No fractionPart found,ungobble the decimal point and return the integerPart"
					sourceStream skip: -1.
					^ neg
						ifTrue: [integerPart negated]
						ifFalse: [integerPart]].
	numberOfNonZeroFractionDigits := lastNonZero.
	numberOfTrailingZeroInFractionPart := nDigits - lastNonZero.
	self readExponent
		ifFalse: [(self readScaleWithDefaultNumberOfDigits: nDigits)
				ifTrue: [^self makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits
					andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart]].

	fractionPart isZero
		ifTrue: [mantissa := integerPart
						// (base raisedToInteger: numberOfTrailingZeroInIntegerPart).
			exponent := exponent + numberOfTrailingZeroInIntegerPart]
		ifFalse: [mantissa := integerPart
						* (base raisedToInteger: numberOfNonZeroFractionDigits) + (fractionPart // (base raisedToInteger: numberOfTrailingZeroInFractionPart)).
			exponent := exponent - numberOfNonZeroFractionDigits].

	value := self makeFloatFromMantissa: mantissa exponent: exponent base: base.
	^ neg
		ifTrue: [value isZero
				ifTrue: [Float negativeZero]
				ifFalse: [value negated]]
		ifFalse: [value]! !

!NumberParser methodsFor: 'private - parsing' stamp: ''!
readScaleWithDefaultNumberOfDigits: anInteger
	"Read the scale if any and store it into scale instance Variable.
	Answer true if found, answer false if none.
	The scale is specified by letter s, optionnally followed by a positive integer in base 10.
	If no integer is specified, that means using as many digits as provided after the fraction separator, as provided by parameter anInteger.
	A letter s followed by another letter is not considered as a scale specification, because it could be part of a message."

	scale := 0.
	sourceStream atEnd ifTrue: [ ^ false ].
	(sourceStream peekFor: $s) ifFalse: [ ^ false ].
	scale := self nextUnsignedIntegerOrNilBase: 10.
	scale
		ifNil: [ scale := anInteger.
			^ (sourceStream peek
				ifNil: [ false ]
				ifNotNil: [ :nextChar | nextChar isLetter ])
				ifTrue: [ sourceStream skip: -1.	"ungobble the s"
					false ]
				ifFalse: [ true ] ].
	^ true! !

!NumberParser methodsFor: 'private - parsing' stamp: ''!
makeIntegerOrScaledIntegerOrFloat
	"At this point, there is no digit, nor fractionPart.
	maybe it can be a scaled decimal with fraction omitted...
	integer with negative exponent can be floats not fractions"
	
	neg
		ifTrue: [integerPart := integerPart negated].
	self readExponent ifTrue:
		["Check that the result is an integer, otherwise answer a Float.  Fractions are /not/ valid literals."
		 (exponent >= 0 or: [(integerPart * (base raisedToInteger: exponent)) isInteger]) ifFalse:
			[base := base asFloat].
		^integerPart * (base raisedToInteger: exponent)].
	(self readScaleWithDefaultNumberOfDigits: 0)
		ifTrue: [^integerPart asScaledDecimal: scale].
	^ integerPart! !

!NumberParser methodsFor: 'parsing' stamp: ''!
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' stamp: ''!
nextNumberBase: b
	"Method for reading a number without radix prefix.
	This one can read Float Integer and ScaledDecimal"
	
	| numberOfTrailingZeroInIntegerPart |
	base := b.
	neg := sourceStream peekFor: $-.
	integerPart := self nextUnsignedIntegerOrNilBase: base.
	integerPart ifNil: [
		"This is not a regular number beginning with a digit
		It is time to check for exceptional condition NaN and Infinity"
		^self readNamedFloatOrFail].
	numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero.
	^ (sourceStream peekFor: $.)
		ifTrue: [self readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart]
		ifFalse: [self makeIntegerOrScaledIntegerOrFloat]! !

!NumberParser methodsFor: 'private - parsing' stamp: ''!
peekSignIsMinus
	"Peek an optional sign from sourceStream.
	 Answer true if it is minus sign"

	| isMinus |
	isMinus := sourceStream peekFor: $-.
	isMinus ifFalse: [self allowPlusSign ifTrue: [sourceStream peekFor: $+]].
	^isMinus! !

!NumberParser class methodsFor: 'testing' stamp: ''!
isNumber: aStringOrStream

	| stream |
	stream := aStringOrStream readStream.
	self parse: stream onError: [ ^ false ].
	^ stream atEnd! !

!NumberParser class methodsFor: 'instance creation' stamp: ''!
parse: aStringOrStream 
	^self new
		on: aStringOrStream;
		nextNumber! !

!NumberParser class methodsFor: 'instance creation' stamp: ''!
parse: aStringOrStream onError: failBlock 
	^(self new)
		on: aStringOrStream;
		failBlock: failBlock;
		nextNumber! !

!NumberParser class methodsFor: 'instance creation' stamp: ''!
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: ''!
on: aStringOrStream
	^self new on: aStringOrStream! !

!NumberParser class methodsFor: 'instance creation' stamp: ''!
squeezeNumberOutOfString: stringOrStream onError: errorBlock
	"Try and find a number in this string. First, look if the string 
	starts with a number. Then, see if it ends with a number. Then,
	remove a character from the front and see if the remaining 
	string makes a number. Repeat the process until no characters
	are left or the number has been found. As soon as a number is
	found, it is returned. Otherwise, the method fails."
	
	| string |

	string := stringOrStream.
				
	stringOrStream size timesRepeat: [
		(self parse: string onError: [ nil ])
			ifNotNil: [ :result| ^ result ].
		string := string allButFirst ].
	
	^ errorBlock value! !

!NumberParserTest commentStamp: ''!
Provide tests for new clas aimed at parsing numbers.

It duplicates NumberParsingTest, with few more tests.!
!NumberParserTest methodsFor: 'utilities' stamp: ''!
areLowercaseDigitsAllowed
	"Answer true if lowercase letter are allowed digits."
	
	^(NumberParser parse: '16re' onError: [-1]) = 16rE! !

!NumberParserTest methodsFor: 'tests - Float' stamp: ''!
testFloatGradualUnderflow
	"Gradual underflow are tricky.
	This is a non regression test for http://bugs.squeak.org/view.php?id=6976"

	| float trueFraction str |
	
	"as a preamble, use a base 16 representation to avoid round off error and check that number parsing is correct"
	trueFraction := 16r2D2593D58B4FC4 / (16 raisedTo: 256+13).
	"Parse the number in base 16 if possible - it is impossible if lowercase letter are allowed digits due to exponent letter ambiguity."
	float := self areLowercaseDigitsAllowed
		ifFalse: [NumberParser parse: '16r2.D2593D58B4FC4e-256']
		ifTrue: [trueFraction asFloat]..
	self assert: float asTrueFraction equals: trueFraction.
	self assert: float equals: trueFraction asFloat.

	"now print in base 10"
	str := (String new: 32) writeStream.
	float absPrintExactlyOn: str base: 10.
	
	"verify if SqNumberParser can read it back"
	self assert: (NumberParser parse: str contents) equals: float.! !

!NumberParserTest methodsFor: 'tests - Fail' stamp: ''!
testFail
	"Verify that the value of a failblock is returned."
	self assert: (NumberParser parse: 'blablabla' onError: [42]) equals: 42! !

!NumberParserTest methodsFor: 'tests - Float' stamp: ''!
testFloatFromStreamWithExponent
	"This covers parsing in Number>>readFrom:"

	| rs aFloat |
	rs := '1.0e-14' readStream.
	aFloat := NumberParser parse: rs.
	self assert: 1.0e-14 equals: aFloat.
	self assert: rs atEnd.

	rs := '1.0e-14 1' readStream.
	aFloat := NumberParser parse: rs.
	self assert: 1.0e-14 equals: aFloat.
	self assert: rs upToEnd equals: ' 1'.

	rs := '1.0e-14eee' readStream.
	aFloat := NumberParser parse: rs.
	self assert: 1.0e-14 equals: aFloat.
	self assert: rs upToEnd equals: 'eee'.

	rs := '1.0e14e10' readStream.
	aFloat := NumberParser parse: rs.
	self assert: 1.0e14 equals: aFloat.
	self assert: rs upToEnd equals: 'e10'.

	rs := '1.0e+14e' readStream. "Plus sign is not parseable"
	aFloat := NumberParser parse: rs.
	self assert: 1.0 equals: aFloat.
	self assert: rs upToEnd equals: 'e+14e'.

	rs := '1.0e' readStream.
	aFloat := NumberParser parse: rs.
	self assert: 1.0 equals: aFloat.
	self assert: rs upToEnd equals: 'e'.! !

!NumberParserTest methodsFor: 'tests - Fail' stamp: ''!
testFailWithDetails

	| failed |
	failed := false.
	self
		assert: (NumberParser new
				 on: '-';
				 failBlock: [ :error :errorIndex | 
					 self
						 assert: error equals: 'Digit expected';
						 assert: errorIndex equals: 2.
					 failed := true.
					 42 ];
				 nextInteger)
		equals: 42;
		assert: failed! !

!NumberParserTest methodsFor: 'tests - Integer' stamp: ''!
testcheckForCoverage	
	"Tests for old semantics of Number>>readFrom:"
	
	self should: [(NumberParser parse: '.') = 0 ] raise: Error.
	self should: [(NumberParser parse: '.1') asNumber ] raise: Error.
	self assert: (NumberParser parse: '0.0') asNumber equals: 0.
	self assert: (NumberParser parse: '0.1') asNumber equals: 0.1.
	self assert: (NumberParser parse: '1.1') asNumber equals: 1.1.
	self assert: (NumberParser parse: '-1') asNumber equals: -1.! !

!NumberParserTest methodsFor: 'tests - ScaledDecimal' stamp: ''!
testScaledDecimalWithTrailingZeroes
	"This is a non regression tests for http://bugs.squeak.org/view.php?id=7169"
	
	self assert: (NumberParser parse: '0.50s2') equals: 1/2.
	self assert: (NumberParser parse: '0.500s3') equals: 1/2.
	self assert: (NumberParser parse: '0.050s3') equals: 1/20.! !

!NumberParserTest methodsFor: 'tests - Fail' stamp: ''!
testFailParsingGarbage

	| failed |
	failed := false.
	self
		assert: (NumberParser new
				 on: 'garbage';
				 failBlock: [ :error :index | 
					 self
						 assert: error equals: 'Digit expected';
						 assert: index equals: 1.
					 failed := true.
					 42 ];
				 nextInteger)
		equals: 42;
		assert: failed! !

!NumberParserTest methodsFor: 'tests - Float' stamp: ''!
testFloatPrintString
	| f r bases |
	f := Float basicNew: 2.
	r := Random new seed: 1234567.
	"printing a Float in base other than 10 is broken if lowercase digits are allowed"
	bases := self areLowercaseDigitsAllowed ifTrue: [ #(10) ] ifFalse: [ #(2 8 10 16) ].
	100
		timesRepeat: [ f basicAt: 1 put: (r nextInteger: 16r100000000) - 1.
			f basicAt: 2 put: (r nextInteger: 16r100000000) - 1.
			bases
				do: [ :base | 
					| str |
					str := (String new: 64) writeStream.
					f negative ifTrue: [ str nextPut: $- ].
					str
						print: base;
						nextPut: $r.
					f absPrintExactlyOn: str base: base.
					self assert: (NumberParser parse: str contents) equals: f ] ].
	"test big num near infinity"
	10
		timesRepeat: [ f basicAt: 1 put: 16r7FE00000 + ((r nextInteger: 16r100000) - 1).
			f basicAt: 2 put: (r nextInteger: 16r100000000) - 1.
			bases
				do: [ :base | 
					| str |
					str := (String new: 64) writeStream.
					f negative ifTrue: [ str nextPut: $- ].
					str
						print: base;
						nextPut: $r.
					f absPrintExactlyOn: str base: base.
					self assert: (NumberParser parse: str contents) equals: f ] ].
	"test infinitesimal (gradual underflow)"
	10
		timesRepeat: [ f basicAt: 1 put: 0 + ((r nextInteger: 16r100000) - 1).
			f basicAt: 2 put: (r nextInteger: 16r100000000) - 1.
			bases
				do: [ :base | 
					| str |
					str := (String new: 64) writeStream.
					f negative ifTrue: [ str nextPut: $- ].
					str
						print: base;
						nextPut: $r.
					f absPrintExactlyOn: str base: base.
					self assert: (NumberParser parse: str contents) equals: f ] ]! !

!NumberParserTest methodsFor: 'tests - Float' stamp: ''!
testIsNumber

	self assert: (NumberParser isNumber: '-1.2') equals: true.
	self assert: (NumberParser isNumber: '2e-2') equals: true.
	
	self assert: (NumberParser isNumber: '') equals: false.
	self assert: (NumberParser isNumber: '2a') equals: false.
	self assert: (NumberParser isNumber: '--1') equals: false.
	self assert: (NumberParser isNumber: '1-') equals: false.
	self assert: (NumberParser isNumber: '1..2') equals: false.! !

!NumberParserTest methodsFor: 'tests - squeezing' stamp: ''!
testSqueezingOutNumbers
	"test that SqNumberParser squeezeNumberOutOfString finds numbers."
	
	self assert: '123blabla' squeezeOutNumber equals: 123.
	self assert: 'blabla123' squeezeOutNumber equals: 123.
	self assert: 'blabla12blabla' squeezeOutNumber equals: 12.
	self assert: ('12.3bla' squeezeOutNumber -12.3 ) abs < 0.0001.
	self assert: '.1' squeezeOutNumber > 0.
	
	self assert: 'blabla1230' squeezeOutNumber equals: 1230.! !

!NumberParserTest methodsFor: 'tests - Integer' stamp: ''!
testIntegerReadFrom
	"Ensure remaining characters in a stream are not lost when parsing an integer."
	| rs i s |
	rs := '123s could be confused with a ScaledDecimal' readStream.
	i := NumberParser parse: rs.
	self assert: i equals: 123.
	s := rs upToEnd.
	self assert: ' could be confused with a ScaledDecimal' equals: s.
	rs := '123.s could be confused with a ScaledDecimal' readStream.
	i := NumberParser parse: rs.
	self assert: i equals: 123.
	s := rs upToEnd.
	self assert: '.s could be confused with a ScaledDecimal' equals: s! !

!NumberParserTest methodsFor: 'tests - ScaledDecimal' stamp: ''!
testScaledDecimalWithoutScaleSpecification
	self assert: (NumberParser parse: '0.050s') equals: 1/20.
	self assert: (NumberParser parse: '0.050s') scale equals: 3.! !

!NumberParserTest methodsFor: 'tests - Float' stamp: ''!
testFloatMaxAndMin
	"This covers parsing in Number>>readFrom:"

	| rs aFloat |
	rs := '2r0.0000000000000000000000000000000000000000000000000001e-1022'
		readStream.
	aFloat := NumberParser parse: rs.
	self assert: Float fminDenormalized equals: aFloat.
	self assert: rs atEnd.
	rs := '-2r0.0000000000000000000000000000000000000000000000000001e-1022'
		readStream.
	aFloat := NumberParser parse: rs.
	self assert: Float fminDenormalized negated equals: aFloat.
	self assert: rs atEnd.
	rs := '2r1.1111111111111111111111111111111111111111111111111111e1023'
		readStream.
	aFloat := NumberParser parse: rs.
	self assert: Float fmax equals: aFloat.
	self assert: rs atEnd! !

!NumberParserTest methodsFor: 'tests - Float' stamp: ''!
testFloatReadError
	"This covers parsing in Number>>readFrom:"

	| rs num |
	rs := '1e' readStream.
	num := NumberParser parse: rs.
	self assert: 1 equals: num.
	self assert: rs upToEnd equals: 'e'.
	
	rs := '1s' readStream.
	num := NumberParser parse: rs.
	self assert: 1 equals: num.
	self assert: rs upToEnd equals: ''.

	rs := '1.' readStream.
	num := NumberParser parse: rs.
	self assert: 1 equals: num.
	self assert: num isInteger.
	self assert: rs upToEnd equals: '.'.
	
	rs := '' readStream.
	self should: [NumberParser parse: rs] raise: Error.
	
	rs := 'foo' readStream.
	self should: [NumberParser parse: rs] raise: Error.

	rs := 'radix' readStream.
	self should: [NumberParser parse: rs] raise: Error.
	
	rs := '.e0' readStream.
	self should: [NumberParser parse: rs] raise: Error.
	
	rs := '-.e0' readStream.
	self should: [NumberParser parse: rs] raise: Error.
	
	rs := '--1' readStream.
	self should: [NumberParser parse: rs] raise: Error.! !

!NumberParserTest methodsFor: 'tests - Float' stamp: ''!
testFloatReadWithRadix
	"This covers parsing in Number>>readFrom:
	Note: In most Smalltalk dialects, the radix notation is not used for numbers
	with exponents. In Squeak, a string with radix and exponent can be parsed,
	and the exponent is always treated as base 10 (not the base indicated in the
	radix prefix). I am not sure if this is a feature, a bug, or both, but the
	Squeak behavior is documented in this test. -dtl"
	| rs |
	self assert: (NumberParser parse: '2r1.0101e9') equals: (1.3125 * (2 raisedTo: 9)).
	rs := '2r1.0101e9e9' readStream.
	self assert: (NumberParser parse: rs) equals: 672.0.
	self assert: rs upToEnd equals: 'e9'! !

!NumberParserTest methodsFor: 'tests - Float' stamp: ''!
testIntegerWithNegExponentIsAFloat
	"Make sure a float literal like 1e(some possible neg exponent)
	isn't evaluated to the non-literal Fraction"

	| rs aFloat |
	rs := '1e-14' readStream.
	aFloat := NumberParser parse: rs.
	self assert: aFloat isFloat.

	rs := '1e-14' readStream.
	aFloat := (NumberParser on: rs ) nextNumberBase: 10.
	self assert: aFloat isFloat.! !

!NumberParserTest methodsFor: 'utilities' stamp: ''!
classToBeTested

	^ NumberParser! !

!NumberParserTest methodsFor: 'tests - Float' stamp: ''!
testFloatmin
	"Note that these are originally tests cases for former bugs of libc dtoa from netlib.
	ref http://www.exploringbinary.com/gays-strtod-returns-zero-for-inputs-just-above-2-1075/
	ref http://gcc.gnu.org/viewcvs/gcc/trunk/gcc/testsuite/gcc.dg/float-exact-1.c?view=markup&pathrev=205119
	They are also non regression for a bug of NumberParser related to incorrect position of last non zero digit.
	ref https://pharo.manuscript.com/f/cases/12642/"
	| halfMin moreThanHalfmin |
	halfMin := NumberParser parse: (Float fmin asTrueFraction / 2 printShowingDecimalPlaces: 1 - Float fmin exponent).
	self assert: halfMin = 0.0 description: 'nearest even of 0.5*Float fmin is zero'.
	moreThanHalfmin := NumberParser parse: (Float fmin asTrueFraction / 2 + (10 raisedTo: Float fmin exponent - 4) printShowingDecimalPlaces: 4 - Float fmin exponent).
	self assert: moreThanHalfmin = Float fmin description: 'nearest Float of a Fraction > 0.5*Float fmin is Float fmin'.! !

!NumberParserTest methodsFor: 'tests - Integer' stamp: ''!
testIntegerReadWithRadix
	"This covers parsing in Number>>readFrom:
	Note: In most Smalltalk dialects, the radix notation is not used for numbers
	with exponents. In Squeak, a string with radix and exponent can be parsed,
	and the exponent is always treated as base 10 (not the base indicated in the
	radix prefix). I am not sure if this is a feature, a bug, or both, but the
	Squeak behavior is documented in this test. -dtl"

	| rs |
	self assert: (NumberParser parse: '2r1e26') equals: (2 raisedTo: 26).
	rs := '2r1e26eee' readStream.
	self assert: (NumberParser parse: rs) equals: 67108864.
	self assert: rs upToEnd equals: 'eee'! !

!NumberParserTest methodsFor: 'tests - Float' stamp: ''!
testFloatFromStreamAsNumber
	"This covers parsing in Number>>readFrom:"

	| rs aFloat |
	rs := '10r-12.3456' readStream.
	aFloat := NumberParser parse: rs.
	self assert: -12.3456 equals: aFloat.
	self assert: rs atEnd.

	rs := '10r-12.3456e2' readStream.
	aFloat := NumberParser parse: rs.
	self assert: -1234.56 equals: aFloat.
	self assert: rs atEnd.

	rs := '10r-12.3456e2e2' readStream.
	aFloat := NumberParser parse: rs.
	self assert: -1234.56 equals: aFloat.
	self assert: rs upToEnd equals: 'e2'.

	rs := '10r-12.3456d2' readStream.
	aFloat := NumberParser parse: rs.
	self assert: -1234.56 equals: aFloat.
	self assert: rs atEnd.

	rs := '10r-12.3456q2' readStream.
	aFloat := NumberParser parse: rs.
	self assert: -1234.56 equals: aFloat.
	self assert: rs atEnd.

	rs := '-12.3456q2' readStream.
	aFloat := NumberParser parse: rs.
	self assert: -1234.56 equals: aFloat.
	self assert: rs atEnd.

	rs := '12.3456q2' readStream.
	aFloat := NumberParser parse: rs.
	self assert: 1234.56 equals: aFloat.
	self assert: rs atEnd.

	rs := '12.3456z2' readStream.
	aFloat := NumberParser parse: rs.
	self assert: 12.3456 equals: aFloat.
	self assert: rs upToEnd equals: 'z2'.! !

!NumberParsingTest commentStamp: ''!
Tests to verify parsing of numbers from streams and strings.

Note: ScaledDecimalTest contains related tests for parsing ScaledDecimal.!
!NumberParsingTest methodsFor: 'tests - Float' stamp: ''!
testFloatFromStreamWithExponent
	"This covers parsing in Number>>readFrom:"

	| rs aFloat |
	rs := '1.0e-14' readStream.
	aFloat := Number readFrom: rs.
	self assert: 1.0e-14 equals: aFloat.
	self assert: rs atEnd.

	rs := '1.0e-14 1' readStream.
	aFloat := Number readFrom: rs.
	self assert: 1.0e-14 equals: aFloat.
	self assert: rs upToEnd equals: ' 1'.

	rs := '1.0e-14eee' readStream.
	aFloat := Number readFrom: rs.
	self assert: 1.0e-14 equals: aFloat.
	self assert: rs upToEnd equals: 'eee'.

	rs := '1.0e14e10' readStream.
	aFloat := Number readFrom: rs.
	self assert: 1.0e14 equals: aFloat.
	self assert: rs upToEnd equals: 'e10'.

	rs := '1.0e+14e' readStream.
	aFloat := Number readFrom: rs.
	self assert: 1.0 equals: aFloat.
	self assert: rs upToEnd equals: 'e+14e'.

	rs := '1.0e' readStream.
	aFloat := Number readFrom: rs.
	self assert: 1.0 equals: aFloat.
	self assert: rs upToEnd equals: 'e'! !

!NumberParsingTest methodsFor: 'tests - ScaledDecimal' stamp: ''!
testScaledDecimalWithTrailingZeroes
	"This is a non regression tests for http://bugs.squeak.org/view.php?id=7169"
	
	self assert: (Number readFrom: '0.50s2') equals: 1/2.
	self assert: (Number readFrom: '0.500s3') equals: 1/2.
	self assert: (Number readFrom: '0.050s3') equals: 1/20! !

!NumberParsingTest methodsFor: 'tests - Float' stamp: ''!
testFloatFromStringAsNumber
	"This covers parsing in Number>>readFrom:"

	| aFloat |
	aFloat := '10r-12.3456' asNumber.
	self assert: -12.3456 equals: aFloat.
	aFloat := '10r-12.3456e2' asNumber.
	self assert: -1234.56 equals: aFloat.
	aFloat := '10r-12.3456d2' asNumber.
	self assert: -1234.56 equals: aFloat.
	aFloat := '10r-12.3456q2' asNumber.
	self assert: -1234.56 equals: aFloat.
	aFloat := '-12.3456q2' asNumber.
	self assert: -1234.56 equals: aFloat.
	aFloat := '12.3456q2' asNumber.
	self assert: 1234.56 equals: aFloat! !

!NumberParsingTest methodsFor: 'tests - Integer' stamp: ''!
testIntegerFromString
	"This covers parsing in Number>>readFrom:
	Trailing decimal points should be ignored."

	self assert: '123' asNumber equals: 123.
	self assert: '-123' asNumber equals: -123.
	self assert: '123.' asNumber equals: 123.
	self assert: '-123.' asNumber equals: -123.
	self assert: '123This is not to be read' asNumber equals: 123.
	self assert: '123s could be confused with a ScaledDecimal' asNumber equals: 123.
	self assert: '123e could be confused with a Float' asNumber equals: 123! !

!NumberParsingTest methodsFor: 'tests - Integer' stamp: ''!
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 equals: 123.
	s := rs upToEnd.
	self assert: 's could be confused with a ScaledDecimal' equals: s.
	rs := '123.s could be confused with a ScaledDecimal' readStream.
	i := Integer readFrom: rs.
	self assert: i equals: 123.
	s := rs upToEnd.
	self assert: '.s could be confused with a ScaledDecimal' equals: s.
	rs := '123sA has unary message sA' readStream.
	i := Number readFrom: rs.
	self assert: i equals: 123.
	s := rs upToEnd.
	self assert: 'sA has unary message sA' equals: s.
	rs := '123sB has unary message sB' readStream.
	i := Number readFrom: rs.
	self assert: i equals: 123.
	s := rs upToEnd.
	self assert: 'sB has unary message sB' equals: s! !

!NumberParsingTest methodsFor: 'tests - Integer' stamp: ''!
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 - Float' stamp: ''!
testFloatFromStringWithExponent
	"This covers parsing in Number>>readFrom:"

	| aFloat |
	aFloat := '1.0e-14' asNumber.
	self assert: 1.0e-14 equals: aFloat.
	aFloat := '1.0e-14 1' asNumber.
	self assert: 1.0e-14 equals: aFloat.
	aFloat := '1.0e-14e' asNumber.
	self assert: 1.0e-14 equals: aFloat.
	aFloat := '1.0e14e' asNumber.
	self assert: 1.0e14 equals: aFloat! !

!NumberParsingTest methodsFor: 'tests - Float' stamp: ''!
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 equals: aNumber.
	self assert: (Number readFrom: '2r1.0101e9') equals: 1.3125 * (2 raisedTo: 9).
	rs := '2r1.0101e9e9' readStream.
	self assert: (Number readFrom: rs) equals: 672.0.
	self assert: rs upToEnd equals: 'e9'! !

!NumberParsingTest methodsFor: 'tests - Float' stamp: ''!
testNumberReadOnlyDigit
	"This covers parsing in Number>>readFrom:"

	| rs num |
	rs := '1e' readStream.
	num := Number readFrom: rs.
	self assert: 1 equals: num.
	self assert: rs upToEnd equals: 'e'.
	
	rs := '1s' readStream.
	num := Number readFrom: rs.
	self assert: 1 equals: num.
	self assert: rs upToEnd equals: ''.

	rs := '1.' readStream.
	num := Number readFrom: rs.
	self assert: 1 equals: num.
	self assert: num isInteger.
	self assert: rs upToEnd equals: '.'! !

!NumberParsingTest methodsFor: 'tests - ScaledDecimal' stamp: ''!
testScaledDecimalWithoutScaleSpecification
	self assert: (Number readFrom: '0.050s') equals: 1/20.
	self assert: (Number readFrom: '0.050s') scale equals: 3.
	
	self assert: (ScaledDecimal readFrom: '0.050') equals: 1/20.
	self assert: (ScaledDecimal readFrom: '0.050') scale equals: 3! !

!NumberParsingTest methodsFor: 'tests - Float' stamp: ''!
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 - Integer' stamp: ''!
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 equals: aNumber.
	self assert: (Number readFrom: '2r1e26') equals: (2 raisedTo: 26).
	rs := '2r1e26eee' readStream.
	self assert: (Number readFrom: rs) equals: 67108864.
	self assert: rs upToEnd equals: 'eee'! !

!NumberParsingTest methodsFor: 'tests - Float' stamp: ''!
testFloatFromStreamAsNumber
	"This covers parsing in Number>>readFrom:"

	| rs aFloat |
	rs := '10r-12.3456' readStream.
	aFloat := Number readFrom: rs.
	self assert: -12.3456 equals: aFloat.
	self assert: rs atEnd.

	rs := '10r-12.3456e2' readStream.
	aFloat := Number readFrom: rs.
	self assert: -1234.56 equals: aFloat.
	self assert: rs atEnd.

	rs := '10r-12.3456e2e2' readStream.
	aFloat := Number readFrom: rs.
	self assert: -1234.56 equals: aFloat.
	self assert: rs upToEnd equals: 'e2'.

	rs := '10r-12.3456d2' readStream.
	aFloat := Number readFrom: rs.
	self assert: -1234.56 equals: aFloat.
	self assert: rs atEnd.

	rs := '10r-12.3456q2' readStream.
	aFloat := Number readFrom: rs.
	self assert: -1234.56 equals: aFloat.
	self assert: rs atEnd.

	rs := '-12.3456q2' readStream.
	aFloat := Number readFrom: rs.
	self assert: -1234.56 equals: aFloat.
	self assert: rs atEnd.

	rs := '12.3456q2' readStream.
	aFloat := Number readFrom: rs.
	self assert: 1234.56 equals: aFloat.
	self assert: rs atEnd.

	rs := '12.3456z2' readStream.
	aFloat := Number readFrom: rs.
	self assert: 12.3456 equals: aFloat.
	self assert: rs upToEnd equals: 'z2'! !

!NumberTest commentStamp: ''!
SUnit tests for numbers!
!NumberTest methodsFor: 'tests' stamp: ''!
testOne
	self
		assert: Integer one equals: 1;
		assert: Float one equals: 1.0;
		assert: Fraction one equals: 1! !

!NumberTest methodsFor: 'tests' stamp: ''!
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: ''!
testRaisedToIntegerWithFloats
	self
		assert: (2.0 raisedToInteger: 0) equals: 1.0;
		assert: (2.0 raisedToInteger: 1) equals: 2.0;
		assert: (2.0 raisedToInteger: 4) equals: 16.0;
		assert: (0.0 raisedToInteger: 0) equals: 1.0;
		assert: (0.0 raisedToInteger: 2) equals: 0.0;
		assert: (2.0 raisedToInteger: -1) equals: 0.5;
		assert: (2.0 raisedToInteger: -4) equals: 0.0625.

	self
		assert: (-3.0 raisedTo: 0) equals: 1.0;
		assert: (-3.0 raisedTo: 1) equals: -3.0;
		assert: (-3.0 raisedTo: 2) equals: 9.0;
		assert: (-3.0 raisedTo: 3) equals: -27.0;
		assert: (-2.0 raisedTo: -2) equals: 0.25;
		assert: (-2.0 raisedTo: -3) equals: -0.125.

	self should: [ 0.0 raisedTo: -1 ] raise: ZeroDivide! !

!NumberTest methodsFor: 'tests' stamp: ''!
testPrintShowingDecimalPlaces
	self assert: (111.2 printShowingDecimalPlaces: 2) equals: '111.20'.
	self assert: (111.2 printShowingDecimalPlaces: 0) equals: '111'.
	self assert: (111 printShowingDecimalPlaces: 0) equals: '111'.
	self assert: (111111111111111 printShowingDecimalPlaces: 2) equals: '111111111111111.00'.
	self assert: (10 printShowingDecimalPlaces: 20) equals: '10.00000000000000000000'.
	self assert: (0.98 printShowingDecimalPlaces: 2) equals: '0.98'.
	self assert: (-0.98 printShowingDecimalPlaces: 2) equals: '-0.98'.
	self assert: (2.567 printShowingDecimalPlaces: 2) equals: '2.57'.
	self assert: (-2.567 printShowingDecimalPlaces: 2) equals: '-2.57'.
	self assert: (0.01 printShowingDecimalPlaces: 2) equals: '0.01'.
	self assert: (-0.001 printShowingDecimalPlaces: 2) equals: '0.00'! !

!NumberTest methodsFor: 'tests' stamp: ''!
testRounded

	self assert: 0 rounded equals: 0.
	self assert: 1 rounded equals: 1.
	self assert: (1/2) rounded equals: 1.
	self assert: ((1/2) - Float epsilon) rounded equals: 0.! !

!NumberTest methodsFor: 'tests' stamp: ''!
testReadFrom
	self assert: 1.0e-14 equals: (Number readFrom: '1.0e-14').
	"Use a literal number format that compiles in GemStone.
	 Note that the test still checks the same value."
	self assert: 16r4000000 equals: (Number readFrom: '2r1e26').
	self should: [ Number readFrom: 'foo' ] raise: Error! !

!NumberTest methodsFor: 'tests' stamp: ''!
testAsInteger
	"ensure we keep using truncated in asInteger"
	self assert: 0.5 asInteger equals: 0.
	self assert: (1/2) asInteger equals: 0! !

!NumberTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testPercent
	self assert: 20 / 40 equals: 50 percent! !

!NumberTest methodsFor: 'tests' stamp: ''!
testRaisedToInteger
	self
		assert: (2 raisedToInteger: 0) equals: 1;
		assert: (2 raisedToInteger: 1) equals: 2;
		assert: (2 raisedToInteger: 4) equals: 16;
		assert: (0 raisedToInteger: 0) equals: 1;
		assert: (0 raisedToInteger: 2) equals: 0;
		assert: (2 raisedToInteger: -1) equals: 1 / 2;
		assert: (2 raisedToInteger: -4) equals: 1 / 16.

	self
		assert: (-3 raisedTo: 0) equals: 1;
		assert: (-3 raisedTo: 1) equals: -3;
		assert: (-3 raisedTo: 2) equals: 9;
		assert: (-3 raisedTo: 3) equals: -27;
		assert: (-3 raisedTo: -2) equals: 1 / 9;
		assert: (-3 raisedTo: -3) equals: -1 / 27.

	self should: [ 0 raisedTo: -1 ] raise: ZeroDivide! !

!NumberTest methodsFor: 'tests' stamp: ''!
testReciprocal
	self
		assert: 1 reciprocal equals: 1;
		assert: 2 reciprocal equals: 1 / 2;
		assert: -1 reciprocal equals: -1;
		assert: -3 reciprocal equals: -1 / 3.

	self should: [ 0 reciprocal ] raise: ZeroDivide! !

!NumberTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Number! !

!NumberTest methodsFor: 'tests' stamp: ''!
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) equals: '1.009'.
	self assert: (35.900 printShowingDecimalPlaces: 3) equals: '35.900'.
	self assert: (-0.097 printShowingDecimalPlaces: 3) equals: '-0.097'! !

!NumberTest methodsFor: 'tests' stamp: ''!
testIntegerPart
	self
		assert: 2 integerPart equals: 2;
		assert: (1 / 2) integerPart equals: 0;
		assert: (4 / 3) integerPart equals: 1;
		assert: 2.0 integerPart equals: 2.0;
		assert: 0.5 integerPart equals: 0.0;
		assert: 2.5 integerPart equals: 2.0! !

!NumberTest methodsFor: 'tests' stamp: ''!
testNew

	self should: [Number new] raise: self defaultTestError.! !

!NumberTest methodsFor: 'tests' stamp: ''!
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) equals: '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) equals: '50000000000001.25'.	"This number is close to maximum float value"
	1.0e306 printShowingDecimalPlaces: 3! !

!NumberTest methodsFor: 'tests' stamp: ''!
testFractionPart
	self
		assert: 2 fractionPart equals: 0;
		assert: (1 / 2) fractionPart equals: 1 / 2;
		assert: (4 / 3) fractionPart equals: 1 / 3;
		assert: 2.0 fractionPart equals: 0.0;
		assert: 0.5 fractionPart equals: 0.5;
		assert: 2.5 fractionPart equals: 0.5! !

!OCASTAndOrTranslatorTest methodsFor: 'tests - and & or' stamp: ''!
testTrueOrAnythingReturnsTrue

	| result |
	result := self
		testComposedExample: 'example: anything
	{definition}.
	^ true or: {argument}'
		withBlock: '[ anything ]'
		withArguments: #(17).
	self assert: result! !

!OCASTAndOrTranslatorTest methodsFor: 'tests - and & or' stamp: ''!
testOrWithLeftFalseEvaluatesRight

	self
		testComposedExample: 'example
	{definition}.
	false or: {argument}'
		withBlock: '[ result := 17 ]'.
	self assert: instance result equals: 17.! !

!OCASTAndOrTranslatorTest methodsFor: 'tests - and & or' stamp: ''!
testAndWithLeftFalseShortcircuitsRight

	self
		testComposedExample: 'example
	{definition}.
	false and: {argument}'
		withBlock: '[ result := 17 ]'.
	self assert: instance result equals: nil! !

!OCASTAndOrTranslatorTest methodsFor: 'tests - and & or' stamp: ''!
testTrueAndAnythingReturnsAnything

	| result |
	result := self
		testComposedExample: 'example: anything
	{definition}.
	^ true and: {argument}'
		withBlock: '[ anything ]'
		withArguments: #(17).
	self assert: result equals: 17! !

!OCASTAndOrTranslatorTest methodsFor: 'tests - and & or' stamp: ''!
testFalseOrAnythingReturnsAnything

	| result |
	result := self
		testComposedExample: 'example: anything
	{definition}.
	^ false or: {argument}'
		withBlock: '[ anything ]'
		withArguments: #(17).
	self assert: result equals: 17! !

!OCASTAndOrTranslatorTest methodsFor: 'tests - and & or' stamp: ''!
testOrWithLeftTrueShortcircuitsRight

	self
		testComposedExample: 'example
	{definition}.
	true or: {argument}'
		withBlock: '[ result := 17 ]'.
	self assert: instance result equals: nil! !

!OCASTAndOrTranslatorTest methodsFor: 'tests - and & or' stamp: ''!
testFalseAndAnythingReturnsFalse

	| result |
	result := self
		testComposedExample: 'example: anything
	{definition}.
	^ false and: {argument}'
		withBlock: '[ anything ]'
		withArguments: #(17).
	self deny: result! !

!OCASTAndOrTranslatorTest methodsFor: 'tests - and & or' stamp: ''!
testAndWithLeftTrueEvaluatesRight

	self
		testComposedExample: 'example
	{definition}.
	true and: {argument}'
		withBlock: '[ result := 17 ]'.
	self assert: instance result equals: 17.! !

!OCASTAndOrTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters
	^ super testParameters *
		(ParametrizedTestMatrix new
			forSelector: #optimization addOptions: { #optionInlineAndOr . #optionInlineNone })! !

!OCASTBasicTranslatorTest methodsFor: 'tests - errors' stamp: ''!
testSyntaxError
	
	self
		should: [ self compileSource: 'foo (']
		raise: SyntaxErrorNotification! !

!OCASTBasicTranslatorTest methodsFor: 'tests - simple' stamp: ''!
testInitialInstanceIsEmpty

	self assert: instance result equals: nil! !

!OCASTBasicTranslatorTest methodsFor: 'tests - simple' stamp: ''!
testEmptyMethodReturnsReceiver

	self assert: (self testExample: #exampleEmptyMethod) equals: instance! !

!OCASTBlockTranslatorTest methodsFor: 'tests - arguments' stamp: ''!
testBlockWithFiveArgumentReturnsLastExpression
	
	| result |
	result := self testSource: 'example
	^ [ :arg1 :arg2 :arg3 :arg4 :arg5 | arg1 + arg2 + arg3 + arg4 + arg5 ] 
		valueWithArguments: #( 2 3 4 5 6 )'.
	
	self assert: result equals: 20! !

!OCASTBlockTranslatorTest methodsFor: 'tests - readvariables' stamp: ''!
testBlockWithInstanceVariableReturnsLastExpression
	
	| result value |
	value := Object new.
	instance iVar: value.
	
	result := self testSource: 'example
	^ [ iVar ] value'.
	
	self assert: result equals: value! !

!OCASTBlockTranslatorTest methodsFor: 'tests - readvariables' stamp: ''!
testBlockCapturesVariableNotValue
	
	| result |
	"Test that the block captures the variable and not the value at the moment of the closure"
	result := self testSource: 'example
	| t block |
	t := 1.
	block := [ t ].
	t := 2.
	^ block value'.
	
	self assert: result equals: 2! !

!OCASTBlockTranslatorTest methodsFor: 'tests - writevariables' stamp: ''!
testBlockWritesInstanceVariable
	
	self testSource: 'example
	[ iVar := 1 ] value'.
	
	self assert: instance iVar equals: 1! !

!OCASTBlockTranslatorTest methodsFor: 'tests - writevariables' stamp: ''!
testBlockExplicitReturn
	
	| result |
	result := self testSource: 'example
	[ ^ 5 ] value.
	^ 2'.
	
	self assert: result equals: 5! !

!OCASTBlockTranslatorTest methodsFor: 'tests - literals' stamp: ''!
testEmptyBlockReturnsNil
	
	| result |
	result := self testSource: 'example
	^ [] value'.
	
	self assert: result isNil! !

!OCASTBlockTranslatorTest methodsFor: 'tests - arguments' stamp: ''!
testBlockWithArgumentReturnsLastExpression
	
	| result |
	result := self testSource: 'example
	^ [ :arg | arg ] value: 7'.
	
	self assert: result equals: 7! !

!OCASTBlockTranslatorTest methodsFor: 'tests - writevariables' stamp: ''!
testWritesTemporaryVariable
	
	| result |
	result := self testSource: 'example
	| t |
	[ t := 1 ] value.
	^ t'.
	
	self assert: result equals: 1! !

!OCASTBlockTranslatorTest methodsFor: 'tests - literals' stamp: ''!
testBlockWithLiteralReturnsLastExpression
	
	| result |
	result := self testSource: 'example
	^ [ 1 ] value'.
	
	self assert: result equals: 1! !

!OCASTBlockTranslatorTest methodsFor: 'tests - arguments' stamp: ''!
testBlockWithThreeArgumentReturnsLastExpression
	
	| result |
	result := self testSource: 'example
	^ [ :arg1 :arg2 :arg3 | arg1 + arg2 + arg3 ] value: 2 value: 3 value: 4'.
	
	self assert: result equals: 9! !

!OCASTBlockTranslatorTest methodsFor: 'tests - writevariables' stamp: ''!
testBlocksShareOuterVariables
	
	| result |
	result := self testSource: 'example
	| blocks |
	blocks := [| t |
		{
			"setter" [ :value | t := value ].
			"getter" [ t ]
		}
	] value.
	blocks first value: 5.
	^ blocks second value '.
	
	self assert: result equals: 5! !

!OCASTBlockTranslatorTest methodsFor: 'tests - readvariables' stamp: ''!
testNestedBlockWithExternalTempReturnsLastExpression
	
	| result |
	result := self testSource: 'example
	| t1 t2 |
	t1 := 1.
	t2 := 2.
	^ [ [ t1 ] value + t2 ] value'.
	
	self assert: result equals: 3! !

!OCASTBlockTranslatorTest methodsFor: 'tests - readvariables' stamp: ''!
testBlockWithTempReturnsLastExpression
	
	| result |
	result := self testSource: 'example
	^ [ | t | t := 1. t ] value'.
	
	self assert: result equals: 1! !

!OCASTBlockTranslatorTest methodsFor: 'tests - readvariables' stamp: ''!
testBlockWithExternalTempReturnsLastExpression
	
	| result |
	result := self testSource: 'example
	| t |
	t := 1.
	^ [ t ] value'.
	
	self assert: result equals: 1! !

!OCASTBlockTranslatorTest methodsFor: 'tests - writevariables' stamp: ''!
testOuterBlockTemporaryVariable
	
	| result |
	result := self testSource: 'example
	| block |
	block := [| t |
		t := 0.
		[ t := t + 1. t ]
	] value.
	^ block value; value '.
	
	self assert: result equals: 2! !

!OCASTBlockTranslatorTest methodsFor: 'tests - arguments' stamp: ''!
testBlockWithFourArgumentReturnsLastExpression
	
	| result |
	result := self testSource: 'example
	^ [ :arg1 :arg2 :arg3 :arg4 | arg1 + arg2 + arg3 + arg4 ] value: 2 value: 3 value: 4 value: 5'.
	
	self assert: result equals: 14! !

!OCASTBlockTranslatorTest methodsFor: 'tests - arguments' stamp: ''!
testBlockWithTwoArgumentReturnsLastExpression
	
	| result |
	result := self testSource: 'example
	^ [ :arg1 :arg2 | arg1 + arg2 ] value: 2 value: 3'.
	
	self assert: result equals: 5! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testSingleRemoteDifferentBlocksSameArgumentName
	| ast |
	ast := (OCOpalExamples >> #singleRemoteDifferentBlocksSameArgumentName) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 3.

	self deny: (ast scope lookupVar: 'b') isEscaping.
	self deny: (ast scope lookupVar: 'c') isEscaping.
	self assert: (ast scope lookupVar: 'z') isEscaping! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testOptimizedBlocksAndSameNameTemps
	| ast scopes |
	ast := (OCOpalExamples >> #optimizedBlocksAndSameNameTemps) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 2.

	self deny: (ast scope lookupVar: 's') isRemote.
	self deny: (ast scope lookupVar: 'c') isRemote.

	scopes := (OCScopesCollector new visitNode: ast) scopes.

	self deny: (scopes second lookupVar: 'a') isRemote.
	self deny: (scopes fourth lookupVar: 'i') isRemote! !

!OCASTCheckerTest methodsFor: 'tests - primitives' stamp: ''!
testExamplePrimitiveErrorCode
	| ast |
	ast := (OCOpalExamples>>#examplePrimitiveErrorCode) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.

	self assert: (ast scope lookupVar: 'code') isLocalVariable.
	self deny: (ast scope lookupVar: 'code') isUninitialized.! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testNoRemoteBlockReturn
	| ast |
	ast := (OCOpalExamples >> #noRemoteBlockReturn) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testOptimizedBlockWrittenAfterClosedOverCase2
	| ast scopes |
	ast := (OCOpalExamples >> #optimizedBlockWrittenAfterClosedOverCase2) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 1.

	self deny: (ast scope lookupVar: 'index') isEscaping.
	self assert: (ast scope lookupVar: 'index') scope equals: ast scope.

	scopes := (OCScopesCollector new visitNode: ast) scopes.

	self assert: (scopes third lookupVar: 'temp') isEscapingWrite.
	self assert: (scopes third lookupVar: 'temp') isEscaping! !

!OCASTCheckerTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testExampleToDoArgument
	| ast |
	ast := (OCOpalExamples >> #exampleToDoArgument) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0! !

!OCASTCheckerTest methodsFor: 'tests - simple' stamp: ''!
testReturn1
	| ast |
	ast := (OCOpalExamples >> #exampleReturn42) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assertEmpty: ast scope tempVars! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testSingleRemoteMethodArgument
	| ast |
	ast := (OCOpalExamples >> #singleRemoteMethodArgument) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 2.

	self deny: (ast scope lookupVar: 'block') isEscaping.
	self assert: (ast scope lookupVar: 'temp') isEscaping.
	self assert: (ast scope lookupVar: 'temp') isWrite! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testExampleSelf
	| ast assignment |
	ast := (OCOpalExamples>>#exampleSelf) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0.
	self assert: (ast scope lookupVar: 'self') isSelfVariable.
	
	assignment := RBParseTreeSearcher treeMatching: 'self result: ``@anything' in: ast. 
	self assert: assignment arguments first variable isSelfVariable.! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testExampleSelfReceiver
	| ast |
	ast := (OCOpalExamples>>#exampleSelfReceiver) parseTree.
	self assert: ast body statements first receiver isSelfVariable.! !

!OCASTCheckerTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testExampleInlineBlockCollectionLR3
	| ast |
	ast := (OCOpalExamples >> #exampleInlineBlockCollectionLR3) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 1	"index is a temp of the outer method due to optimized block"! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testDoubleRemoteAnidatedBlocks
	| ast scopes |
	ast := (OCOpalExamples >> #doubleRemoteAnidatedBlocks) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 2.

	self assert: (ast scope lookupVar: 'last') isEscaping.
	self assert: (ast scope lookupVar: 'val') isEscaping.

	scopes := (OCScopesCollector new visitNode: ast) scopes.
	self assert: scopes size equals: 4.

	self assert: (scopes second lookupVar: 'i') isEscaping.	"This is due to the inlined block."


	self assert: scopes third tempVars size equals: 1.
	self deny: (scopes third lookupVar: 'continue') isEscaping	"It is not escaping since is being accessed in an optimized block."! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testInstanceVar
	| ast assignment |
	ast := (OCOpalExamples >> #exampleInstanceVariableAssignment) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assertEmpty: ast scope tempVars.
	self assert: (ast scope outerScope lookupVar: 'iVar') isInstanceVariable.

	assignment := RBParseTreeSearcher treeMatching: '`var := ``@anything' in: ast.
	self assert: assignment variable isInstanceVariable! !

!OCASTCheckerTest methodsFor: 'tests - simple' stamp: ''!
testSemanticAnalysisOnNonMethodNode
	| ast |
	{[ 1 + 2 ].
	thisContext.
	(OCOpalExamples >> #exampleReturn42)}
		do: [ :object | 
			ast := object sourceNode].
	#('1' 'true' 'nil' '1 + 2' '^1' '1 + 2. 2 + 3' '#(1 true)' '{ #foo . 1 }' '1+2;+3')
		do: [ :source | 
			ast := RBParser parseExpression: source.
			ast doSemanticAnalysis ].
	ast := RBParser parseMethod: 'foo 1 + 2'.
	ast doSemanticAnalysis! !

!OCASTCheckerTest methodsFor: 'utilities' stamp: ''!
nameAnalysisNoClosureIn: class for: ast
	"Look up vars in classOrScope.  My tree will be annotated with bindings to Scopes and Variables."

	OCASTSemanticAnalyzer new
		compilationContext: class compiler compilationContext;
		visitNode: ast.! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testOptimizedBlockWrittenAfterClosedOverCase1
	| ast scopes |
	ast := (OCOpalExamples >> #optimizedBlockWrittenAfterClosedOverCase1) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 1.

	"index is not escaping as it is (due to the optimized block) defined in the same block"
	self deny: (ast scope lookupVar: 'index') isEscaping.
	self assert: (ast scope lookupVar: 'index') scope equals: ast scope.

	scopes := (OCScopesCollector new visitNode: ast) scopes.

	self assert: (scopes third lookupVar: 'temp') isWrite.
	self assert: (scopes third lookupVar: 'temp') isEscaping! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testExampleSuper
	| ast assignment |
	ast := (OCOpalExamples>>#exampleSuper) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0.
	self assert: (ast scope lookupVar: 'super') isSuperVariable.
	
	assignment := RBParseTreeSearcher treeMatching: 'self result:``@anything' in: ast. 
	self assert: assignment arguments first variable isSuperVariable.! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testExampleThisContext 
	| ast assignment |
	ast := (OCOpalExamples>>#exampleThisContext) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0.
	self assert: (ast scope lookupVar: 'thisContext') isThisContextVariable.
	
	assignment := RBParseTreeSearcher treeMatching: 'self result: ``@anything' in: ast. 
	self assert: assignment arguments first variable isThisContextVariable.! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testExampleSuperReceiver
	| ast |
	ast := (OCOpalExamples>>#exampleSuperReceiver) parseTree.
	self assert: ast body statements first receiver isSuperVariable! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testNoRemoteBlockArgument
	| ast |
	ast := (OCOpalExamples >> #noRemoteBlockArgument) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 3.

	self deny: (ast scope lookupVar: 'block') isEscaping.
	self deny: (ast scope lookupVar: 'block1') isEscaping.
	self deny: (ast scope lookupVar: 'block2') isEscaping! !

!OCASTCheckerTest methodsFor: 'tests - simple' stamp: ''!
testExampleIfNotNilReturnNil
	| ast |
	ast := (OCOpalExamples >> #exampleIfNotNilReturnNil) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testNoRemoteMethodTemp
	| ast |
	ast := (OCOpalExamples >> #noRemoteMethodTemp) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 2.

	self deny: (ast scope lookupVar: 'block1') isEscaping.
	self deny: (ast scope lookupVar: 'block2') isEscaping! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testSingleRemoteTempVar
	| ast |
	ast := (OCOpalExamples >> #singleRemoteTempVar) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 3.

	self assert: (ast scope lookupVar: 'index') isEscaping.
	self assert: (ast scope lookupVar: 'index') scope equals: ast scope.
	self deny: (ast scope lookupVar: 'block') isEscaping.
	self assert: (ast scope lookupVar: 'theCollection') isEscaping.
	self assert: (ast scope lookupVar: 'block') isTempVariable.
	self assert: (ast scope lookupVar: 'theCollection') isTempVariable.
	self deny: (ast scope lookupVar: 'theCollection') isInstanceVariable.
	self deny: (ast scope lookupVar: 'index') isInstanceVariable.
	self deny: (ast scope lookupVar: 'block') isInstanceVariable! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testsingleRemoteTempVarWhileWithTempNotInlined
	| ast |
	ast := (OCOpalExamples >> #exampleWhileWithTempNotInlined) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 2.

	self assert: (ast scope lookupVar: 'index') isEscaping.
	self assert: (ast scope lookupVar: 'index') scope equals: ast scope.
	self deny: (ast scope lookupVar: 'block') isEscaping.
	self assert: (ast scope lookupVar: 'block') isTempVariable! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testNoRemoteBlockTemp
	| ast |
	ast := (OCOpalExamples >> #noRemoteBlockTemp) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 3.

	self deny: (ast scope lookupVar: 'block') isEscaping.
	self deny: (ast scope lookupVar: 'block1') isEscaping.
	self deny: (ast scope lookupVar: 'block2') isEscaping! !

!OCASTCheckerTest methodsFor: 'tests - variables' stamp: ''!
testsingleRemoteTempVarWrittenAfterClosedOver
	| ast |
	ast := (OCOpalExamples >> #singleRemoteTempVarWrittenAfterClosedOver) parseTree.
	self nameAnalysisNoClosureIn: OCOpalExamples for: ast.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 2.

	self assert: (ast scope lookupVar: 'index') isWrite.
	self assert: (ast scope lookupVar: 'index') scope equals: ast scope.
	self deny: (ast scope lookupVar: 'block') isEscaping.
	self assert: (ast scope lookupVar: 'block') isTempVariable! !

!OCASTClosureAnalyzer commentStamp: ''!
I visit the AST of method a second time (after OCASTSemanticAnalyzer) to analyze temps related to closures.!
!OCASTClosureAnalyzer methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode
	"here look at the temps and make copying vars / tempVector out of them"
	self visitArgumentNodes: aBlockNode arguments.
	scope := aBlockNode scope.	
	scope moveEscapingWritesToTempVector.
	scope copyEscapingReads.
	self visitNode: aBlockNode body.
	aBlockNode temporaries do: [ :each | self lookupAndFixBinding: each ].
	scope := scope popScope.! !

!OCASTClosureAnalyzer methodsFor: 'variables' stamp: ''!
lookupAndFixBinding: aVariableNode
	| var |
	var := scope lookupVar: aVariableNode name.
	aVariableNode variable: var.
	^var! !

!OCASTClosureAnalyzer methodsFor: 'visiting' stamp: ''!
visitArgumentNode: aVariableNode
	"nothing to do for arguments"! !

!OCASTClosureAnalyzer methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode
	"here look at the temps and make copying vars / tempVector out of them"
	self visitArgumentNodes: aMethodNode arguments.
	scope := aMethodNode scope.	
	scope moveEscapingWritesToTempVector.
	scope copyEscapingReads.
	self visitNode: aMethodNode body.
	aMethodNode temporaries do: [ :each | self lookupAndFixBinding: each ]! !

!OCASTClosureAnalyzer methodsFor: 'visiting' stamp: ''!
visitLocalVariableNode: aVariableNode
	"re-lookup local variables..."
	| var |
	var := self lookupAndFixBinding: aVariableNode.
	var isTempVectorTemp ifTrue: [ | vectorVar |
		vectorVar := scope lookupVar: var vectorName.
		scope addCopyingTempToAllScopesUpToDefTemp: vectorVar].
	var isCopying ifTrue: [scope addCopyingTempToAllScopesUpToDefTemp: var].! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testSingleRemoteDifferentBlocksSameArgumentName
	| ast |
	ast := (OCOpalExamples >> #singleRemoteDifferentBlocksSameArgumentName) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 2.
	self assert: ast scope tempVector size equals: 1.

	self deny: (ast scope lookupVar: 'b') isRemote.
	self deny: (ast scope lookupVar: 'c') isRemote.
	self assert: (ast scope lookupVar: 'z') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - blocks' stamp: ''!
testExampleWhileModificationBefore
	| ast |
	ast := (OCOpalExamples >> #exampleWhileModificationBefore) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0.
	self assert: ast scope tempVector size equals: 1.
	self assert: ast scope copiedVars size equals: 1.

	self assert: (ast scope lookupVar: 'index') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testNestedBlocksRemoteInBlockCase1
	| ast scopes |
	ast := (OCOpalExamples >> #nestedBlocksRemoteInBlockCase1) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 0.
	self deny: (ast scope lookupVar: 'block') isRemote.

	scopes := (OCScopesCollector new visitNode: ast) scopes.

	self assert: scopes second tempVars size equals: 0.
	self assert: scopes second tempVector size equals: 2.
	self assert: (scopes second tempVector at: 'a') isRemote.
	self assert: (scopes second tempVector at: 'b') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testWrittenAfterClosedOver
	| ast |
	ast := (OCOpalExamples >> #writtenAfterClosedOver) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0.
	self assert: ast scope tempVector size equals: 1.

	self assert: (ast scope lookupVar: 'a') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testSingleRemoteReadNestedBlocks
	| ast |
	ast := (OCOpalExamples >> #singleRemoteReadNestedBlocks) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0.
	self assert: ast scope tempVector size equals: 1.

	self assert: (ast scope lookupVar: 'a') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testNoRemoteReadInBlock
	| ast |
	ast := (OCOpalExamples >> #noRemoteReadInBlock) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 0.

	self deny: (ast scope lookupVar: 'a') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testOptimizedBlockWrittenAfterClosedOverCase2
	| ast scopes |
	ast := (OCOpalExamples >> #optimizedBlockWrittenAfterClosedOverCase2) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 0.
	self deny: (ast scope lookupVar: 'index') isRemote.

	scopes := (OCScopesCollector new visitNode: ast) scopes.
	self assert: (scopes third tempVector at: 'temp') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testSingleRemoteMethodArgument
	| ast |
	ast := (OCOpalExamples >> #singleRemoteMethodArgument) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 1.

	self deny: (ast scope lookupVar: 'block') isRemote.
	self assert: (ast scope lookupVar: 'temp') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testOptimizedBlockWriteInNestedBlockCase2
	| ast |
	ast := (OCOpalExamples >> #optimizedBlockWriteInNestedBlockCase2) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 0.
	self deny: (ast scope lookupVar: 't1') isRemote.
	self assert: ast scope copiedVars size equals: 0! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - variables' stamp: ''!
testArgumentIsRead

	| ast |
	ast := (OCOpalExamples >> #exampleWithArgument:) parseTree.
	self assert: ast arguments first variable usage equals: #read! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testOptimizedBlockWriteInNestedBlock
	| ast |
	ast := (OCOpalExamples >> #optimizedBlockWriteInNestedBlock) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 0.
	self assert: ast scope tempVector size equals: 1.
	self assert: (ast scope lookupVar: 't1') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testDoubleRemoteAnidatedBlocks
	| ast scopes |
	ast := (OCOpalExamples >> #doubleRemoteAnidatedBlocks) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0.
	self assert: ast scope tempVector size equals: 2.

	scopes := (OCScopesCollector new visitNode: ast) scopes.

	self assert: (ast scope lookupVar: 'last') isRemote.
	self assert: (ast scope lookupVar: 'val') isRemote.
	self assert: (ast scope lookupVar: 'val') vectorName equals: '0vector0'.
	self deny: (scopes second lookupVar: 'i') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testNestedBlocksRemoteInBlockCase3
	| ast scopes |
	ast := (OCOpalExamples >> #nestedBlocksRemoteInBlockCase3) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 0.
	self assert: ast scope tempVector size equals: 1.
	self assert: (ast scope lookupVar: 'block') isRemote.

	scopes := (OCScopesCollector new visitNode: ast) scopes.

	self assert: scopes second tempVars size equals: 0.
	self assert: scopes second tempVector size equals: 0.

	self assert: scopes third tempVars size equals: 0.
	self assert: scopes third tempVector size equals: 1.
	self assert: (scopes third tempVector at: 'a') isRemote.

	self assert: scopes fourth tempVars size equals: 0.
	self assert: scopes fourth tempVector size equals: 0.

	self assert: scopes fifth tempVars size equals: 0.
	self assert: scopes fifth tempVector size equals: 1.
	self assert: (scopes fifth tempVector at: 'b') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testOptimizedBlockWriteInNestedBlockCase4
	| ast scopes |
	ast := (OCOpalExamples >> #optimizedBlockWriteInNestedBlockCase4) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 0.
	self assert: ast scope tempVector size equals: 1.
	self assert: (ast scope lookupVar: 't1') isRemote.
	self assert: ast scope copiedVars size equals: 1.	 "this one copying var is the tempVector"

	scopes := (OCScopesCollector new visitNode: ast) scopes.
	self assert: scopes second tempVars size equals: 0.
	self assert: scopes second tempVector size equals: 0.
	self assert: scopes second copiedVars size equals: 1.
	scopes second copiedVars at: '0vector0' ifAbsent: [ self fail ]! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - optimized blocks' stamp: ''!
testExampleSimpleBlockLocalIf
	| ast  assignment var |
	ast := (OCOpalExamples>>#exampleSimpleBlockLocalIf) parseTree.

	assignment := RBParseTreeSearcher treeMatching: '`var := ``@anything' in: ast. 	
	var := assignment variable variable.
	self assert: var isWrite.
	self deny: var isEscaping.! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testOptimizedBlockWriteInBlock
	| ast |
	ast := (OCOpalExamples >> #optimizedBlockWriteInBlock) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 0.
	self deny: (ast scope lookupVar: 't1') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testOptimizedBlockWrittenAfterClosedOverCase1
	| ast scopes |
	ast := (OCOpalExamples >> #optimizedBlockWrittenAfterClosedOverCase1) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 0.

	scopes := (OCScopesCollector new visitNode: ast) scopes.

	self assert: scopes third tempVars size equals: 0.
	self assert: scopes third tempVector size equals: 1.

	self deny: (scopes third lookupVar: 'index') isRemote.
	"as we are in an optimized loop, the var is considered a remote write"
	self assert: (scopes third tempVector at: 'temp') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - variables' stamp: ''!
testVariableDefintionScopeUpdate
	"the scope of local var definitons needs to be updated, too"

	| ast |
	ast := OpalCompiler new parse:
			'm04_two_temps_one_temp_in_remote_vector

| t1 t2 |

t1 := 1.
[ t2 := t1 +  1.0 ] value.

^t2'.
	self assert: ast temporaries second variable class equals: OCVectorTempVariable! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - variables' stamp: ''!
testInlinedBlockArgumentIsArgumentVariable
	| ast blockNode |
	ast := (OCOpalExamples>>#exampleForInlinedBlockArgument) parseTree.
	blockNode := ast body statements first arguments first.
	self assert: blockNode arguments notEmpty.
	self assert: blockNode arguments first isArgumentVariable! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - blocks' stamp: ''!
testExampleBlockArgument
	| ast blockScope blockScope2 |
	ast := (OCOpalExamples >> #exampleBlockArgument) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 3.
	self assert: ast scope tempVector size equals: 0.
	self assert: ast scope copiedVars size equals: 0.

	self deny: (ast scope lookupVar: 'block') isRemote.
	self deny: (ast scope lookupVar: 'block1') isRemote.
	self deny: (ast scope lookupVar: 'block2') isRemote.

	blockScope := (OCScopesCollector new visitNode: ast) scopes second.

	self assert: blockScope tempVars size equals: 2.
	self assert: blockScope tempVector size equals: 0.
	self assert: blockScope copiedVars size equals: 1.
	self deny: (blockScope lookupVar: 'temp') isRemote.
	self assert: (blockScope lookupVar: 'temp') isEscapingRead.
	self assert: (blockScope lookupVar: 'temp') isWrite.
	self deny: (blockScope lookupVar: 'temp') isEscapingWrite.
	self deny: (blockScope lookupVar: 'arg') isRemote.


	blockScope2 := (OCScopesCollector new visitNode: ast) scopes third.
	self assert: blockScope2 tempVars size equals: 0.
	self assert: blockScope2 tempVector size equals: 0.
	self assert: blockScope2 copiedVars size equals: 1! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - variables' stamp: ''!
testMethodArgumentIsArgumentVariable
	| ast |
	ast := (OCOpalExamples>>#exampleWithArgument:) parseTree.
	self assert: ast arguments notEmpty.
	self assert: ast arguments first isArgumentVariable! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - variables' stamp: ''!
testBlockArgumentIsArgumentVariable
	| ast blockNode |
	ast := (OCOpalExamples>>#exampleForBlockArgument) parseTree.
	blockNode := ast body statements first value.
	self assert: blockNode arguments notEmpty.
	self assert: blockNode arguments first isArgumentVariable! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testExampleSimpleBlockLocalWhile
	| ast scopes |
	ast := (OCOpalExamples >> #exampleSimpleBlockLocalWhile) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 0.
	self assert: ast scope tempVector size equals: 1.
	self assert: (ast scope lookupVar: 'a') isRemote.

	scopes := (OCScopesCollector new visitNode: ast) scopes.

	self assert: scopes second tempVars size equals: 1.
	self assert: scopes second tempVector size equals: 0.
	self deny: (scopes second lookupVar: 'b') isRemote.
	self assert: (scopes second lookupVar: 'b') isArgumentVariable.
	self deny: (scopes fourth lookupVar: 'hallo') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testNoRemoteBlockArgument
	| ast |
	ast := (OCOpalExamples >> #noRemoteBlockArgument) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 3.

	self deny: (ast scope lookupVar: 'block') isRemote.
	self deny: (ast scope lookupVar: 'block1') isRemote.
	self deny: (ast scope lookupVar: 'block2') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testOptimizedBlockWriteInNestedBlockCase3
	| ast scopes |
	ast := (OCOpalExamples >> #optimizedBlockWriteInNestedBlockCase3) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 0.
	self assert: ast scope tempVector size equals: 1.
	self assert: (ast scope lookupVar: 't1') isRemote.
	self assert: ast scope copiedVars size equals: 1.	"Is this correct, I think that the copied vars should be empty."

	scopes := (OCScopesCollector new visitNode: ast) scopes.
	self assert: scopes second tempVars size equals: 0.
	self assert: scopes second tempVector size equals: 0.
	self assert: scopes second copiedVars size equals: 1.
	scopes second copiedVars at: '0vector0' ifAbsent: [ self fail ].
	self assert: (scopes second copiedVars at: '0vector0') isStoringTempVector! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testSingleRemoteTempVar
	| ast |
	ast := (OCOpalExamples >> #singleRemoteTempVar) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 2.
	self assert: ast scope tempVector size equals: 1.

	self assert: (ast scope lookupVar: 'index') isRemote.
	self assert: (ast scope lookupVar: 'index') scope equals: ast scope.
	self deny: (ast scope lookupVar: 'block') isRemote.
	self deny: (ast scope lookupVar: 'theCollection') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testExampleSimpleBlockNested
	| ast scopes |
	ast := (OCOpalExamples >> #exampleSimpleBlockNested) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 2.
	self assert: ast scope tempVector size equals: 1.
	self deny: (ast scope lookupVar: 'a') isRemote.
	self deny: (ast scope lookupVar: 'dict') isRemote.
	self assert: (ast scope lookupVar: 'match') isRemote.

	scopes := (OCScopesCollector new visitNode: ast) scopes.

	self assert: scopes second tempVars size equals: 2.
	self assert: scopes second tempVector size equals: 0.
	self deny: (scopes second lookupVar: 'each') isRemote.
	self deny: (scopes second lookupVar: 'index') isRemote.

	self assert: scopes second copiedVars size equals: 3! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testOptimizedBlockReadInBlock
	| ast |
	ast := (OCOpalExamples >> #optimizedBlockReadInBlock) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 0.
	self deny: (ast scope lookupVar: 't1') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testsingleRemoteTempVarWhileWithTempNotInlined
	| ast |
	ast := (OCOpalExamples >> #exampleWhileWithTempNotInlined) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 1.

	self assert: (ast scope lookupVar: 'index') isRemote.
	self assert: (ast scope lookupVar: 'index') scope equals: ast scope.
	self deny: (ast scope lookupVar: 'block') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - blocks' stamp: ''!
testExampleWhileNoModification
	"A block in an optimized loop with no modification on temp vars in the loop
only needs to copy the tempvars. No write -> no indirection vector."

	| ast |
	ast := (OCOpalExamples >> #exampleWhileNoModification) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 3.
	self assert: ast scope tempVector size equals: 0.
	self assert: ast scope copiedVars size equals: 3.
	self deny: (ast scope lookupVar: 'a') isRemote.
	self deny: (ast scope lookupVar: 'b') isRemote.
	self deny: (ast scope lookupVar: 'c') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testNestedBlocksRemoteInBlockCase2
	| ast scopes |
	ast := (OCOpalExamples >> #nestedBlocksRemoteInBlockCase2) parseTree.
	self assert: ast scope isMethodScope.

	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 0.
	self deny: (ast scope lookupVar: 'block') isRemote.

	scopes := (OCScopesCollector new visitNode: ast) scopes.

	self assert: scopes second tempVars size equals: 0.
	self assert: scopes second tempVector size equals: 0.

	self assert: scopes third tempVars size equals: 0.
	self assert: scopes third tempVector size equals: 1.
	self assert: (scopes third tempVector at: 'a') isRemote.

	self assert: scopes fourth tempVars size equals: 0.
	self assert: scopes fourth tempVector size equals: 0.

	self assert: scopes fifth tempVars size equals: 0.
	self assert: scopes fifth tempVector size equals: 1.
	self assert: (scopes fifth tempVector at: 'b') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testsingleRemoteTempVarWrittenAfterClosedOver
	| ast |
	ast := (OCOpalExamples >> #singleRemoteTempVarWrittenAfterClosedOver) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 1.
	self assert: ast scope tempVector size equals: 1.

	self assert: (ast scope lookupVar: 'index') isRemote.
	self assert: (ast scope lookupVar: 'index') scope equals: ast scope.
	self deny: (ast scope lookupVar: 'block') isRemote! !

!OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: ''!
testNoRemoteReadNestedBlocks
	| ast scopes |
	ast := (OCOpalExamples >> #noRemoteReadNestedBlocks) parseTree.
	self assert: ast scope isMethodScope.
	self assert: ast scope tempVars size equals: 0.
	self assert: ast scope tempVector size equals: 0.

	scopes := (OCScopesCollector new visitNode: ast) scopes.
	self assert: scopes second tempVars size equals: 1.
	self assert: scopes second tempVector size equals: 0.
	self deny: (scopes second lookupVar: 'a') isRemote! !

!OCASTDoubleBlockTranslatorTest methodsFor: 'accessing' stamp: ''!
extractBlock2InTemp
	^ extractBlock2InTemp! !

!OCASTDoubleBlockTranslatorTest methodsFor: 'tests' stamp: ''!
testComposedExample: template withFirstBlock: firstBlockCode withSecondBlock: secondBlockCode

	^ self
		testComposedExample: template
		withTemps: #()
		withFirstBlock: firstBlockCode
		withSecondBlock: secondBlockCode! !

!OCASTDoubleBlockTranslatorTest methodsFor: 'tests' stamp: ''!
testComposedExample: template withTemps: predefinedTemps withFirstBlock: firstBlockCode withSecondBlock: secondBlockCode
	| temps declaration argument1 argument2 source |
	temps := OrderedCollection new.
	temps addAll: predefinedTemps.
	self extractBlockInTemp ifTrue: [ 
			temps add: 'block1'.
			declaration := 'block1 := ', firstBlockCode, '.'.
			argument1 := 'block1' ]
		ifFalse: [
			declaration := ''.
			argument1 := firstBlockCode ].
	self extractBlock2InTemp ifTrue: [ 
			temps add: 'block2'.
			declaration := declaration , 'block2 := ', secondBlockCode, '.'.
			argument2 := 'block2' ]
		ifFalse: [
			argument2 := secondBlockCode ].

	declaration := String streamContents: [ :stream |
		stream nextPut: $|.
		temps do: [ :each | stream nextPutAll: each; space ].
		stream nextPut: $|.
		stream nextPutAll: declaration.
	].

	source := template format: { 
		'definition' -> declaration.
		'argument1' -> argument1.
		'argument2' -> argument2 } asDictionary.
	^ self testSource: source.! !

!OCASTDoubleBlockTranslatorTest methodsFor: 'accessing' stamp: ''!
extractBlock2InTemp: anObject
	extractBlock2InTemp := anObject! !

!OCASTDoubleBlockTranslatorTest class methodsFor: 'private' stamp: ''!
isAbstract

	^ self == OCASTDoubleBlockTranslatorTest! !

!OCASTDoubleBlockTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters

	^ super testParameters *
		(ParametrizedTestMatrix new
			forSelector: #extractBlock2InTemp addOptions: { true . false };
			yourself)! !

!OCASTDoubleBranchConditionalTranslatorTest methodsFor: 'tests - conditionals' stamp: ''!
testTrueIfTrueIfFalseEvaluatesTrueBlock

	self
		testComposedExample: 'example
	{definition}.
	^true ifTrue: {argument1} ifFalse: {argument2}'
		withFirstBlock: '[iVar := ''true'']'
		withSecondBlock: '[ self error ]'.

	self assert: instance iVar equals: 'true'! !

!OCASTDoubleBranchConditionalTranslatorTest methodsFor: 'tests - conditionals' stamp: ''!
testTrueIfTrueIfFalseReturnsTrueBlockValue
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^true ifTrue: {argument1} ifFalse: {argument2}'
		withFirstBlock: '[iVar := ''true'']'
		withSecondBlock: '[ self error ]'.

	self assert: result equals: 'true'! !

!OCASTDoubleBranchConditionalTranslatorTest methodsFor: 'tests - conditionals' stamp: ''!
testFalseIfTrueIfFalseEvaluatesFalseBlock

	self
		testComposedExample: 'example
	{definition}.
	^false ifTrue: {argument1} ifFalse: {argument2}'
		withFirstBlock: '[ self error ]'
		withSecondBlock: '[iVar := ''false'']'.

	self assert: instance iVar equals: 'false'! !

!OCASTDoubleBranchConditionalTranslatorTest methodsFor: 'tests - conditionals' stamp: ''!
testTrueIfFalseIfTrueEvaluatesTrueBlock

	self
		testComposedExample: 'example
	{definition}.
	^true ifFalse: {argument1} ifTrue: {argument2}'
		withFirstBlock: '[ self error ]'
		withSecondBlock: '[iVar := ''true'']'.

	self assert: instance iVar equals: 'true'! !

!OCASTDoubleBranchConditionalTranslatorTest methodsFor: 'tests - conditionals' stamp: ''!
testFalseIfTrueIfFalseReturnsFalseBlockValue
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^false ifTrue: {argument1} ifFalse: {argument2}'
		withFirstBlock: '[ self error ]'
		withSecondBlock: '[iVar := ''false'']'.

	self assert: result equals: 'false'! !

!OCASTDoubleBranchConditionalTranslatorTest methodsFor: 'tests - conditionals' stamp: ''!
testTrueIfFalseIfTrueReturnsTrueBlockValue
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^true ifFalse: {argument1} ifTrue: {argument2}'
		withFirstBlock: '[ self error ]'
		withSecondBlock: '[iVar := ''true'']'.
	self assert: result equals: 'true'! !

!OCASTDoubleBranchConditionalTranslatorTest methodsFor: 'tests - conditionals' stamp: ''!
testFalseIfFalseIfTrueEvaluatesFalseBlock

	self
		testComposedExample: 'example
	{definition}.
	^false ifFalse: {argument1} ifTrue: {argument2}'
		withFirstBlock: '[iVar := ''false'']'
		withSecondBlock: '[ self error ]'.

	self assert: instance iVar equals: 'false'! !

!OCASTDoubleBranchConditionalTranslatorTest methodsFor: 'tests - conditionals' stamp: ''!
testFalseIfFalseIfTrueReturnsFalseBlockValue
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^false ifFalse: {argument1} ifTrue: {argument2}'
		withFirstBlock: '[iVar := ''false'']'
		withSecondBlock: '[ self error ]'..
	self assert: result equals: 'false'! !

!OCASTDoubleBranchConditionalTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters
	^ super testParameters *
		(ParametrizedTestMatrix new
			forSelector: #optimization addOptions: { #optionInlineIf . #optionInlineIfNil . #optionInlineNone })! !

!OCASTLiteralTranslatorTest methodsFor: 'accessing' stamp: ''!
expectedLiteralValue: anObject
	expectedLiteralValue := anObject! !

!OCASTLiteralTranslatorTest methodsFor: 'tests - literals' stamp: ''!
testLiteralIsInLiteralFrame
	
	| array |
	array := self testExample: literalExample.
	
	self assert: (method literals identityIncludes: array).! !

!OCASTLiteralTranslatorTest methodsFor: 'tests - literals' stamp: ''!
testLiteralReturnsAlwaysSameLiteral
	self compileExample: literalExample.

	self assert: (self executeMethodOnInstance: method) identicalTo: (self executeMethodOnInstance: method)! !

!OCASTLiteralTranslatorTest methodsFor: 'accessing' stamp: ''!
literalExample: anObject
	literalExample := anObject! !

!OCASTLiteralTranslatorTest methodsFor: 'tests - literals' stamp: ''!
testLiteralReturnsLiteral
	
	self assert: (self testExample: literalExample) equals: expectedLiteralValue! !

!OCASTLiteralTranslatorTest methodsFor: 'accessing' stamp: ''!
expectedLiteralValue
	^ expectedLiteralValue! !

!OCASTLiteralTranslatorTest methodsFor: 'accessing' stamp: ''!
literalExample
	^ literalExample! !

!OCASTLiteralTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters

	^ super testParameters * {
			{ #literalExample -> #exampleNonSpecialLiteralInteger. #expectedLiteralValue -> 10 }.
			{ #literalExample -> #exampleLiteralLargeInteger. #expectedLiteralValue -> 16rFFFFFFFFFFFFFFFF }.
			{ #literalExample -> #exampleLiteralCharacter. #expectedLiteralValue -> $H }.
			{ #literalExample -> #exampleLiteralArray. #expectedLiteralValue -> #(1 2 3) }.
			{ #literalExample -> #exampleLiteralByteArray. #expectedLiteralValue -> #[1 2 3] }.
			{ #literalExample -> #exampleLiteralFloat. #expectedLiteralValue -> 1.2 }.
			{ #literalExample -> #exampleLiteralBoxedFloat. #expectedLiteralValue -> 9.999999999999996e157 }.
			{ #literalExample -> #exampleLiteralByteSymbol. #expectedLiteralValue -> #bytesymbol }.
			{ #literalExample -> #exampleLiteralWideSymbol. #expectedLiteralValue -> #'áèîöÑü' }.
			{ #literalExample -> #exampleLiteralByteString. #expectedLiteralValue -> 'bytestring' }.
			{ #literalExample -> #exampleLiteralWideString. #expectedLiteralValue -> 'áèîöÑü' }
	}! !

!OCASTMethodMetadataAnalyser commentStamp: ''!
This visitor analyses the AST and then adds annotations that will end up being set on the
compild method.

One example are methods that contains message send that is a #halt (and any of it's variations)!
!OCASTMethodMetadataAnalyser methodsFor: 'visiting' stamp: ''!
visitMessageNode: aNode

	super visitMessageNode: aNode.
	aNode isHaltNode ifTrue: [ 
		aNode methodNode methodPropertyAt: #containsHalt put: true ]! !

!OCASTRepeatTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testRepeatWithTempInBlock

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 1.
	{argument} repeat.
	 ^ total'
		withTemps: #('total')
		withBlock: '[ | tempInBlock | 
			tempInBlock := total.
			total := tempInBlock + 1.
			total > 5 ifTrue: [ ^ total ] ]'.
	
	self assert: result equals: 6.! !

!OCASTRepeatTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testRepeatExecutesBlock


	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 1.
	{argument} repeat.
	 ^ total'
		withTemps: #('total')
		withBlock: '[ total := total  + 1. total > 5 ifTrue: [ ^ total ] ]'.
	
	self assert: result equals: 6.! !

!OCASTRepeatTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testTimesRepeatWithTempInBlock

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 1.
	5 timesRepeat: {argument}.
	 ^ total'
		withTemps: #('total')
		withBlock: '[ | tempInBlock | 
			tempInBlock := total.
			total := total + tempInBlock ]'.
	
	self assert: result equals: 2 ** 5.! !

!OCASTRepeatTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters
	^ super testParameters *
		(ParametrizedTestMatrix new
			forSelector: #optimization addOptions: { #optionInlineRepeat . #optionInlineNone })! !

!OCASTSemanticAnalyzer commentStamp: ''!
I visit each node in the abstract syntax tree while growing and shrinking a scope chain. Each method and block node is linked with its corresponding scope object, and each variable def and ref is linked with its corresponding OCVariable. Exceptions are raised for undefined variable references and so on (see subclasses of OCSemanticWarning).
!
!OCASTSemanticAnalyzer methodsFor: 'initialization' stamp: ''!
scope: aSemScope
	scope := aSemScope! !

!OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: ''!
undeclaredVariable: variableNode
	compilationContext optionSkipSemanticWarnings
		ifTrue: [ ^UndeclaredVariable named: variableNode name asSymbol ].
	^ OCUndeclaredVariableWarning new
		node: variableNode;
		compilationContext: compilationContext;
		signal! !

!OCASTSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode
	blockCounter := self blockCounter + 1.

	aBlockNode isInlined ifTrue: [^ self visitInlinedBlockNode: aBlockNode ].	
	scope := scope newBlockScope: blockCounter. 
	aBlockNode scope: scope. scope node: aBlockNode.
	
	aBlockNode arguments do: [:node | self declareArgumentNode: node ].
	self visitNode: aBlockNode body.
	scope := scope popScope.! !

!OCASTSemanticAnalyzer methodsFor: 'accessing' stamp: ''!
compilationContext: aCompilationContext
	compilationContext := aCompilationContext! !

!OCASTSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
analyzeLocalVariableRead: aLocalVariable
	aLocalVariable markRead.
	(aLocalVariable scope outerNotOptimizedScope ~= scope outerNotOptimizedScope ) ifFalse: [ ^self ].
	"only escaping when they will end up in different closures"
	aLocalVariable markEscapingRead.
	"if we read a variable in a loop that is a repeated write, it need to be marked as escaping write"	
	(scope isInsideOptimizedLoop and: [aLocalVariable isRepeatedWrite])
				ifTrue: [aLocalVariable markEscapingWrite]! !

!OCASTSemanticAnalyzer methodsFor: 'variables' stamp: ''!
declareArgumentNode: aVariableNode
	^self declareVariableNode: aVariableNode as: (ArgumentVariable named: aVariableNode name)! !

!OCASTSemanticAnalyzer methodsFor: 'accessing' stamp: ''!
compilationContext
	^ compilationContext! !

!OCASTSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode
	
	aSequenceNode temporaries do: [ :node | self declareTemporaryNode: node ].
	aSequenceNode statements do: [ :each | self visitNode: each ].
	aSequenceNode temporaries reverseDo: [ :node | 
			node variable isUsed
				ifFalse: [ self unusedVariable: node ] ]! !

!OCASTSemanticAnalyzer methodsFor: 'variables' stamp: ''!
declareTemporaryNode: aVariableNode
	^self declareVariableNode: aVariableNode as: (TemporaryVariable named: aVariableNode name)! !

!OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: ''!
unusedVariable: variableNode

	variableNode propertyAt: #semanticWarning put: 'unused variable'! !

!OCASTSemanticAnalyzer methodsFor: 'variables' stamp: ''!
resolveVariableNode: aVariableNode
	| var |	
	var := (scope lookupVar: aVariableNode name) 
		ifNil: [ self undeclaredVariable: aVariableNode ].
	aVariableNode variable: var.
	^var! !

!OCASTSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: anAssignmentNode
	| var |
	self visitNode: anAssignmentNode value.	
		
	var := self resolveVariableNode: anAssignmentNode variable.	
	var analyzeWrite: anAssignmentNode variable by: self! !

!OCASTSemanticAnalyzer methodsFor: 'variables' stamp: ''!
declareVariableNode: aVariableNode as: anOCTempVariable
	| name var shadowing |
	name := aVariableNode name. 
	var := scope lookupVarForDeclaration: name.
	"check if another variable with same name is visible"
	var ifNotNil: [ shadowing := var].
	var := scope addTemp: anOCTempVariable.
	aVariableNode binding: var.
	(shadowing notNil and: [ shadowing allowsShadowing not]) ifTrue: [self shadowingVariable: aVariableNode].
	^ var! !

!OCASTSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
analyzeLocalVariableWrite: aLocalVariable
	(aLocalVariable scope outerNotOptimizedScope ~= scope outerNotOptimizedScope) 
	"only escaping when they will end up in different closures"
			ifTrue: [ aLocalVariable markEscapingWrite].
	"if we write a variable in a loop, mark it as a repeated Write"	
	scope isInsideOptimizedLoop
					ifTrue: [ aLocalVariable markRepeatedWrite ]
					ifFalse: [ aLocalVariable markWrite ]! !

!OCASTSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode

	scope := OCMethodScope new outerScope: compilationContext scope.
	aMethodNode scope: scope.  scope node: aMethodNode.
	aMethodNode arguments do: [:node | self declareArgumentNode: node ].
	aMethodNode pragmas do: [:each | self visitNode: each].
	self visitNode: aMethodNode body.! !

!OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: ''!
uninitializedVariable: variableNode
	variableNode propertyAt: #semanticWarning put: #unitialized.! !

!OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: ''!
storeIntoReadOnlyVariable: variableNode
	compilationContext optionSkipSemanticWarnings ifTrue: [ ^ self ].
		
	^ OCStoreIntoReadOnlyVariableError new
		node: variableNode;
		compilationContext: compilationContext;
		messageText: 'Cannot store into';
		signal! !

!OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: ''!
shadowingVariable: aNode
	compilationContext optionSkipSemanticWarnings ifTrue: [ ^aNode ].
	^ OCShadowVariableWarning new
		node: aNode;
		compilationContext: compilationContext;
		signal! !

!OCASTSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitPragmaNode: aPragmaNode

	| varNode |
	super visitPragmaNode: aPragmaNode.
	aPragmaNode selector = #compilerOptions: ifTrue: [ 
		aPragmaNode asPragma sendTo:
			aPragmaNode methodNode compilationContext ].
	
	"if the pragma is a primitive that defines an error variable, we need to declare a temp
	for it"	
	aPragmaNode isPrimitiveError ifFalse: [ ^ self ].
	varNode := RBVariableNode named: aPragmaNode primitiveErrorVariableName.
	self declareVariableNode: varNode as: (PrimitiveErrorVariable node: varNode).! !

!OCASTSemanticAnalyzer methodsFor: 'api' stamp: ''!
analyze: aNode
	self visitNode: aNode.
	OCASTClosureAnalyzer new visitNode: aNode.
	OCASTMethodMetadataAnalyser new visitNode: aNode! !

!OCASTSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitInlinedBlockNode: aBlockNode

	scope := scope newOptimizedBlockScope: blockCounter.
	aBlockNode isInlinedLoop ifTrue: [scope markInlinedLoop]. 
	aBlockNode scope: scope. scope node: aBlockNode.
	aBlockNode arguments do: [:node | self declareArgumentNode: node ].
	self visitNode: aBlockNode body.
	scope := scope popScope.! !

!OCASTSemanticAnalyzer methodsFor: 'accessing' stamp: ''!
blockCounter
	^blockCounter ifNil: [0]! !

!OCASTSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode
	| var |	
	var := self resolveVariableNode: aVariableNode.
	var analyzeRead: aVariableNode by: self! !

!OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: ''!
storeIntoReservedVariable: variableNode
	compilationContext optionSkipSemanticWarnings ifTrue: [ ^ self ].
	^ OCStoreIntoReservedVariableError new
		node: variableNode;
		compilationContext: compilationContext;
		messageText: 'Cannot store into';
		signal! !

!OCASTSemanticAnalyzerTest methodsFor: 'tests' stamp: ''!
testWhileWithArg
	"If we analyse #whileTrue with a block that has an argument, answer false for #isInlineWhile.
	executing this code would lead to a runtime error, which is what we expect"
	| ast |
	ast := RBParser parseExpression: '[:test | ] whileTrue'.
	self deny: ast sendNodes first isInlineWhile.! !

!OCASTSemanticCleaner commentStamp: ''!
I am cleaning the semantic analysis of the AST.

-> scopes of Blocks and Methpd
-> binding from Variables!
!OCASTSemanticCleaner methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode
	aBlockNode removeProperty: #scope ifAbsent: [ ].
	super visitBlockNode: aBlockNode.! !

!OCASTSemanticCleaner methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode
	aMethodNode removeProperty: #scope ifAbsent: [ ].
	super visitMethodNode: aMethodNode! !

!OCASTSemanticCleaner methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode
	aVariableNode variable: UnresolvedVariable instance! !

!OCASTSemanticCleaner class methodsFor: 'api' stamp: ''!
clean: aMethodNode
	self new visitNode: aMethodNode.
	^aMethodNode! !

!OCASTSingleBlockTranslatorTest methodsFor: 'tests' stamp: ''!
testComposedExample: template withBlock: blockCode withArguments: arguments
	
	^ self
		testComposedExample: template
		withTemps: #() 
		withBlock: blockCode
		withArguments: arguments! !

!OCASTSingleBlockTranslatorTest methodsFor: 'accessing' stamp: ''!
extractBlockInTemp

	^ extractBlockInTemp	ifNil: [ extractBlockInTemp := false ]! !

!OCASTSingleBlockTranslatorTest methodsFor: 'tests' stamp: ''!
testComposedExample: template withTemps: temps withBlock: blockCode

	^ self testComposedExample: template  withTemps: temps withBlock: blockCode withArguments: #()! !

!OCASTSingleBlockTranslatorTest methodsFor: 'tests' stamp: ''!
testComposedExample: template  withTemps: temps withBlock: blockCode withArguments: arguments
	| declaration argument source methodTemps |
	methodTemps := OrderedCollection withAll: temps.
	self extractBlockInTemp ifTrue: [ 
			methodTemps add: 'block'.
			declaration := 'block := ', blockCode.
			argument := 'block' ]
		ifFalse: [
			declaration := ''.
			argument := blockCode ].
	
	declaration := String streamContents: [ :stream |
		stream nextPut: $|.
		methodTemps do: [ :each | stream nextPutAll: each; space ].
		stream nextPut: $|.
		stream nextPutAll: declaration. ].
	source := template format: { 
		'definition' -> declaration.
		'argument' -> argument } asDictionary.
	^ self testSource: source withArguments: arguments! !

!OCASTSingleBlockTranslatorTest methodsFor: 'accessing' stamp: ''!
extractBlockInTemp: aBoolean 
	extractBlockInTemp := aBoolean! !

!OCASTSingleBlockTranslatorTest methodsFor: 'tests' stamp: ''!
testComposedExample: template withBlock: blockCode

	^ self testComposedExample: template withBlock: blockCode withArguments: #()! !

!OCASTSingleBlockTranslatorTest class methodsFor: 'building suites' stamp: ''!
isAbtract

	^ self == OCASTSingleBlockTranslatorTest! !

!OCASTSingleBlockTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters

	^ super testParameters * 
		(ParametrizedTestMatrix new
			forSelector: #extractBlockInTemp addOptions: { true . false };
			yourself)! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNotNil' stamp: ''!
testNotNilIfNotNilEvaluatesBlock

	self
		testComposedExample: 'example
		{definition}.
		^1 ifNotNil: {argument}'
		withBlock: '[ iVar := 17 ]'.

	self assert: instance iVar equals: 17! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifTrue' stamp: ''!
testTrueIfTrueReturnsBlockValue

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^true ifTrue: {argument}'
		withBlock: '[ 1 ]'.
	self assert: result equals: 1! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNotNil' stamp: ''!
testNilIfNotNilDoesNotEvaluateBlock

	self
		shouldnt: [
			self
				testComposedExample: 'example
			{definition}.
			^ nil ifNotNil: {argument}'
				withBlock: '[ self error ]' ]
		raise: Error! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifFalse' stamp: ''!
testFalseIfFalseEvaluatesBlockWithTempInsideBlock

	self
		testComposedExample: 'example
	{definition}.
	^false ifFalse: {argument}'
		withBlock: '[ | temp |
			temp := 17.
			iVar := temp ]'.
	self assert: instance iVar equals: 17! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNotNil' stamp: ''!
testNilIfNotNilWithArgumentDoesNotEvaluateBlock
	self shouldnt: [ 
		self
			testComposedExample: 'example
		{definition}.
		^nil ifNotNil: {argument}'
			withBlock: '[ :arg | self error ]' ] raise: Error! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifFalse' stamp: ''!
testFalseIfFalseReturnsBlockValue

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^false ifFalse: {argument}'
		withBlock: '[1]'.
	self assert: result equals: 1! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifFalse' stamp: ''!
testTrueIfFalseReturnsNil

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^true ifFalse: {argument}'
		withBlock: '[ 1 ]'.
	self assert: result equals: nil! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNotNil' stamp: ''!
testNilIfNotNilWithArgumentReturnsNil
	| result |
	result := self
			testComposedExample: 'example
		{definition}.
		^nil ifNotNil: {argument}'
			withBlock: '[ :arg | self error ]'.
	self assert: result equals: nil! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifTrue' stamp: ''!
testFalseIfTrueDoesNotEvaluateBlock

	self
		testComposedExample: 'example
	{definition}.
	^false ifTrue: {argument}'
		withBlock: '[iVar := 17]'.
	self assert: instance iVar equals: nil! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifTrue' stamp: ''!
testTrueIfTrueEvaluateBlockWithTempInsideBlock

	self
		testComposedExample: 'example
	{definition}.
	^true ifTrue: {argument}'
		withBlock: '[ | temp |
			temp := 17.
			iVar := temp ]'.
	self assert: instance iVar equals: 17! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifTrue' stamp: ''!
testTrueIfTrueEvaluateBlock

	self
		testComposedExample: 'example
	{definition}.
	^true ifTrue: {argument}'
		withBlock: '[ iVar := 17 ]'.
	self assert: instance iVar equals: 17! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNil' stamp: ''!
testNilIfNilEvaluatesBlock

	self
		testComposedExample: 'example
	{definition}.
	^nil ifNil: {argument}'
		withBlock: '[ iVar := 17 ]'.
	self assert: instance iVar equals: 17! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNotNil' stamp: ''!
testNotNilIfNotNilReturnsBlockValue
	| result |
	result := self
		testComposedExample: 'example
		{definition}.
		^1 ifNotNil: {argument}'
		withBlock: '[ iVar := 17 ]'.
	self assert: result equals: 17! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifFalse' stamp: ''!
testFalseIfFalseReturnsBlockValueWithTempInsideBlock

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^false ifFalse: {argument}'
		withBlock: '[ | temp | 
			temp := 1.
			temp ]'.
	self assert: result equals: 1! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNil' stamp: ''!
testNotNilIfNilDoesNotEvaluateBlock

	self
		shouldnt: [ 
			self
				testComposedExample: 'example
			{definition}.
			^1 ifNil: {argument}'
				withBlock: '[ self error ]' ]
		raise: Error! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifFalse' stamp: ''!
testFalseIfFalseEvaluatesBlock

	self
		testComposedExample: 'example
	{definition}.
	^false ifFalse: {argument}'
		withBlock: '[iVar := 17]'.
	self assert: instance iVar equals: 17! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifTrue' stamp: ''!
testFalseIfTrueReturnsNil

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^false ifTrue: {argument}'
		withBlock: '[1]'.
	self assert: result equals: nil! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNil' stamp: ''!
testNotNilIfNilReturnsReceiver
	| result |
	result := self
			testComposedExample: 'example
		{definition}.
		^1 ifNil: {argument}'
			withBlock: '[ self error ]'.
	self assert: result equals: 1! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifTrue' stamp: ''!
testTrueIfTrueReturnsBlockValueWithTempOutsideBlock

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^true ifTrue: {argument}'
		withTemps: #( 'temp' )
		withBlock: '[
			temp := 1.
			temp ]'.
	self assert: result equals: 1! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNotNil' stamp: ''!
testNilIfNotNilReturnsNil
	| result |
	
	result := self
		testComposedExample: 'example
	{definition}.
	^nil ifNotNil: {argument}'
		withBlock: '[ self error ]'.
	self assert: result equals: nil! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifTrue' stamp: ''!
testTrueIfTrueReturnsBlockValueWithTempInsideBlock

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^true ifTrue: {argument}'
		withBlock: '[ | temp |
			temp := 1.
			temp ]'.
	self assert: result equals: 1! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNil' stamp: ''!
testNilIfNilReturnsBlockValue
	| result |
	
	result := self
		testComposedExample: 'example
	{definition}.
	^nil ifNil: {argument}'
		withBlock: '[ iVar := 17 ]'.
	self assert: result equals: 17! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifFalse' stamp: ''!
testFalseIfFalseEvaluatesBlockWithTempOutsideBlock

	self
		testComposedExample: 'example
	{definition}.
	^false ifFalse: {argument}'
		withTemps: #( 'temp' )
		withBlock: '[
			temp := 17.
			iVar := temp ]'.
	self assert: instance iVar equals: 17! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifTrue' stamp: ''!
testTrueIfTrueEvaluateBlockWithTempOutsideBlock

	self
		testComposedExample: 'example
	{definition}.
	^true ifTrue: {argument}'
		withTemps: #( 'temp' )
		withBlock: '[
			temp := 17.
			iVar := temp ]'.
	self assert: instance iVar equals: 17! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNotNil' stamp: ''!
testNotNilIfNotNilWithArgumentEvaluatesBlock

	self
		testComposedExample: 'example
		{definition}.
		^1 ifNotNil: {argument}'
		withBlock: '[ :arg | iVar := arg ]'.

	self assert: instance iVar equals: 1! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifNotNil' stamp: ''!
testNotNilIfNotNilWithArgumentReturnsBlockValue
	| result |
	result := 	self
		testComposedExample: 'example
		{definition}.
		^1 ifNotNil: {argument}'
		withBlock: '[ :arg | iVar := arg ]'.
	self assert: result equals: 1! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifFalse' stamp: ''!
testTrueIfFalseDoesNotEvaluateBlock

	self
		testComposedExample: 'example
	{definition}.
	^true ifFalse: {argument}'
		withBlock: '[iVar := 17]'.

	self assert: instance iVar equals: nil! !

!OCASTSingleBranchConditionalTranslatorTest methodsFor: 'tests - ifFalse' stamp: ''!
testFalseIfFalseReturnsBlockValueWithTempOutsideBlock

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^false ifFalse: {argument}'
		withTemps: #( 'temp' )
		withBlock: '[ 
			temp := 1.
			temp ]'.
	self assert: result equals: 1! !

!OCASTSingleBranchConditionalTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters
	^ super testParameters *
		(ParametrizedTestMatrix new
			forSelector: #optimization addOptions: { #optionInlineIf . #optionInlineIfNil . #optionInlineNone })! !

!OCASTSpecialLiteralTranslatorTest methodsFor: 'tests - literals' stamp: ''!
testDynamicLiteralArrayReturnsEqualsArray
	
	| aCompiledMethod |
	aCompiledMethod := self compileExample: #examplePushDynamicLiteralArray.
	
	self assert: (self executeMethodOnInstance: aCompiledMethod) equals: (self executeMethodOnInstance: aCompiledMethod)! !

!OCASTSpecialLiteralTranslatorTest methodsFor: 'tests - literals' stamp: ''!
testSpecialLiteralsNotInLiteralFrame

	self testExample: #examplePushNonSpecialSmallInteger.
	self assert: instance result equals: 10.
	self assert: (method hasLiteral: 10)! !

!OCASTSpecialLiteralTranslatorTest methodsFor: 'tests - literals' stamp: ''!
testDynamicLiteralArrayReturnsAlwaysNewArray
	
	| aCompiledMethod |
	aCompiledMethod := self compileExample: #examplePushDynamicLiteralArray.
	
	self assert: (self executeMethodOnInstance: aCompiledMethod) ~~ (self executeMethodOnInstance: aCompiledMethod)! !

!OCASTSpecialLiteralTranslatorTest methodsFor: 'tests - literals' stamp: ''!
testDynamicLiteralArrayIsNotInLiteralFrame
	
	| aCompiledMethod array |
	aCompiledMethod := self compileExample: #examplePushDynamicLiteralArray.
	array := self executeMethodOnInstance: aCompiledMethod.
	
	self deny: (aCompiledMethod literals identityIncludes: array).! !

!OCASTSpecialLiteralTranslatorTest methodsFor: 'tests - literals' stamp: ''!
testDynamicLiteralArrayReturnsArray

	self assert: (self testExample: #examplePushDynamicLiteralArray) equals: #(1 3)! !

!OCASTTimesRepeatTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testTimesRepeatExecutesBlock


	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 1.
	5 timesRepeat: {argument}.
	 ^ total'
		withTemps: #('total')
		withBlock: '[ total := total  + total ]'.
	
	self assert: result equals: 2 ** 5.! !

!OCASTTimesRepeatTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testTimesRepeatWithCalculatedArguments


	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 1.
	times := 6.
	times - 1 timesRepeat: {argument}.
	 ^ total'
		withTemps: #('times' 'total')
		withBlock: '[ total := total + total ]'.
	
	self assert: result equals: 2 ** 5.! !

!OCASTTimesRepeatTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testTimesRepeatWithTempInBlock

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 1.
	5 timesRepeat: {argument}.
	 ^ total'
		withTemps: #('total')
		withBlock: '[ | tempInBlock | 
			tempInBlock := total.
			total := total + tempInBlock ]'.
	
	self assert: result equals: 2 ** 5.! !

!OCASTTimesRepeatTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testTimesRepeatReturnsReceiver


	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^ 5 timesRepeat: {argument}'
		withBlock: '[ 1+2 ]'.
	
	self assert: result equals: 5! !

!OCASTTimesRepeatTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testTimesRepeatWithTempOutsideBlock

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 1.
	5 timesRepeat: {argument}.
	 ^ total'
		withTemps: #('total' 'tempOutsideBlock')
		withBlock: '[
			tempOutsideBlock := total.
			total := total + tempOutsideBlock ]'.
	
	self assert: result equals: 2 ** 5.! !

!OCASTTimesRepeatTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters
	^ super testParameters *
		(ParametrizedTestMatrix new
			forSelector: #optimization addOptions: { #optionInlineTimesRepeat . #optionInlineNone })! !

!OCASTToDoTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testToDoWithTempInBlock

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 0.
	begin := 1.
	end := 6.
	begin to: end - 1 do: {argument}.
	 ^ total'
		withTemps: #('begin' 'end' 'total')
		withBlock: '[ :index | | tempInBlock | 
			tempInBlock := index.
			total := total + tempInBlock ]'.
	
	self assert: result equals: 15.! !

!OCASTToDoTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testToDoReturnsReceiver


	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	^ 1 to: 5 do: {argument}'
		withBlock: '[ :index | 1+2 ]'.
	
	self assert: result equals: 1.! !

!OCASTToDoTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testToDoWithTempOutsideBlock

	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 0.
	begin := 1.
	end := 6.
	begin to: end - 1 do: {argument}.
	 ^ total'
		withTemps: #('begin' 'end' 'total' 'tempOutsideBlock')
		withBlock: '[ :index |
			tempOutsideBlock := index.
			total := total + tempOutsideBlock ]'.
	
	self assert: result equals: 15.! !

!OCASTToDoTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testToDoExecutesBlock


	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 0.
	1 to: 5 do: {argument}.
	 ^ total'
		withTemps: #('total')
		withBlock: '[ :index | total := total + index ]'.
	
	self assert: result equals: 15.! !

!OCASTToDoTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testToDoWithCalculatedArguments


	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	total := 0.
	begin := 1.
	end := 6.
	begin to: end - 1 do: {argument}.
	 ^ total'
		withTemps: #('begin' 'end' 'total')
		withBlock: '[ :index | total := total + index ]'.
	
	self assert: result equals: 15.! !

!OCASTToDoTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters
	^ super testParameters *
		(ParametrizedTestMatrix new
			forSelector: #optimization addOptions: { #optionInlineToDo . #optionInlineNone })! !

!OCASTTranslator commentStamp: ''!
I visit an abstract syntax tree and generate IR (intermediate representation) instructions for each node by sending the appropriate message to my methodBuilder (an IRBuilder).  I hold onto my two subclasses 
OCASTTranslatorForValue for generating instructions for effect and value, and
OCASTTranslatorForEffect for generating instructions for effect only.

Which one to use depends on the AST nodes and whether the code will only be executed (for effect only) or if the value is used afterwards (for value).

For example, when translating a return, the value to return needs to be pushed on stack, so the valueTranslator is used:
visitReturnNode: aReturnNode 
	valueTranslator visitNode: aReturnNode value.
	methodBuilder returnTop.
	
Whereas, in #visitMethodNode:,  the effectTranslator is used, because no value is pushed on stack at the end of the method body:
...effectTranslator visitNode: aMethodNode body..
!
!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitIfTrue: aMessageNode

	self shouldBeSentToValueOrEffectTranslator! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitToDo: aMessageNode 
	
	self emitToDo: aMessageNode step: 1! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitBlockNode: aBlockNode
	| compiledBlock |
	aBlockNode arguments size >15 ifTrue: [self backendError: 'Too many arguments' forNode: aBlockNode ].
	aBlockNode isInlined ifTrue: [^ self visitInlinedBlockNode: aBlockNode ].
	
	compiledBlock := self compilationContext astTranslatorClass new translateFullBlock: aBlockNode.
	(self compilationContext optionCleanBlockClosure and: [ aBlockNode isClean ])
		ifTrue: [ methodBuilder pushLiteral: ((CleanBlockClosure new: 0) numArgs: compiledBlock numArgs; compiledBlock: compiledBlock)]
		ifFalse: [methodBuilder pushFullClosureCompiledBlock: compiledBlock copiedValues: aBlockNode scope inComingCopiedVarNames  ]! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitWhileFalse: aMessageNode

	self emitWhile: aMessageNode boolean: true! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitSequenceNode: aSequenceNode 

	self shouldBeSentToValueOrEffectTranslator! !

!OCASTTranslator methodsFor: 'inline messages factored' stamp: ''!
emitToDo: aMessageNode step: step
	| limit block iterator limitEmit |
	
	limit := aMessageNode arguments first.
	block := aMessageNode arguments last.
	iterator := block arguments first variable.
	
	limitEmit := [valueTranslator visitNode: limit].
	"if the limit is not just a literal or a non-writable variable, make a temp store it there"
	(limit isLiteralNode or: [limit isVariable and: [limit variable isWritable not]]) ifFalse: [
		valueTranslator visitNode: limit.
		methodBuilder addTemp: ('0limit_', iterator name).
		methodBuilder storeTemp: ('0limit_', iterator name).
		methodBuilder popTop.
		limitEmit := [methodBuilder pushTemp: ('0limit_', iterator name)]].

	"push start. allocate and initialize iterator"
	valueTranslator visitNode: aMessageNode receiver.
	iterator emitStore: methodBuilder.	
	self isEffectTranslator ifTrue: [methodBuilder popTop]. 
	methodBuilder jumpBackTarget: #start.
	iterator emitValue: methodBuilder.	
	limitEmit value.
	methodBuilder send: (step > 0 ifTrue: [#<=] ifFalse: [#>=]).
	methodBuilder jumpAheadTo: #done if: false.

	effectTranslator visitInlinedBlockNode: block.
	iterator emitValue: methodBuilder.
	methodBuilder pushLiteral: step.
	methodBuilder send: #+.
	iterator emitStore: methodBuilder.
	methodBuilder popTop.
	methodBuilder jumpBackTo: #start.
	methodBuilder jumpAheadTarget: #done.! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitReturnNode: aReturnNode 

	valueTranslator visitNode: aReturnNode value.
	methodBuilder returnTop.! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitAssignmentNode: anAssignmentNode 

	valueTranslator visitNode: anAssignmentNode value.
	anAssignmentNode variable variable emitStore: methodBuilder! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitLiteralNode: aLiteralNode

	methodBuilder pushLiteral: aLiteralNode value.! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitNode: aNode
	methodBuilder mapToNode: aNode.
	super visitNode: aNode.
	methodBuilder popMap.! !

!OCASTTranslator methodsFor: 'inline messages factored' stamp: ''!
emitIf: aMessageNode boolean: aBoolean

	valueTranslator visitNode: aMessageNode receiver.
	
	self emitCondition: aMessageNode arguments boolean: aBoolean! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitInlinedBlockNode: anOptimizedBlockNode

	"We are visiting a scope that is not a block, but inlined in the outer context.
	This means: 
			- we do not create a Block
			- we call IRBuilder to add temps
	"
	
	methodBuilder mapToNode: anOptimizedBlockNode.
	anOptimizedBlockNode scope tempVector ifNotEmpty: [
		methodBuilder 
			createTempVectorNamed: anOptimizedBlockNode scope tempVectorName 
			withVars: anOptimizedBlockNode scope tempVectorVarNames.
	].
	methodBuilder addTemps: anOptimizedBlockNode scope tempVarNamesWithoutArguments.
	methodBuilder addTemps: anOptimizedBlockNode scope inComingCopiedVarNames.
	methodBuilder addTemps: anOptimizedBlockNode argumentNames.
	anOptimizedBlockNode isInlinedLoop ifTrue: [
		anOptimizedBlockNode scope tempVarNamesWithoutArguments do: [ :tempName |
			methodBuilder pushLiteral: nil.
			methodBuilder storeTemp: tempName.
			methodBuilder popTop.
		]].
	
	self visitNode: anOptimizedBlockNode body.
	methodBuilder popMap! !

!OCASTTranslator methodsFor: 'inline messages factored' stamp: ''!
emitCaseOf: aMessageNode otherwiseBlock: aBlock

	| cases assocMessageNode  |
	
	cases := aMessageNode arguments first statements.
	valueTranslator visitNode: aMessageNode receiver.
	valueTranslator emitAllButLastCases: cases.
	
	"last case with otherwise"
	assocMessageNode := cases last.
	valueTranslator visitInlinedBlockNode: assocMessageNode receiver.
	methodBuilder send: #=.
	methodBuilder jumpAheadTo: #next if: false.
	valueTranslator visitInlinedBlockNode: assocMessageNode arguments first.
	methodBuilder jumpAheadTo: #end.
	methodBuilder jumpAheadTarget: #next.
	aBlock value.

	cases size timesRepeat: [methodBuilder jumpAheadTarget: #end].
	
	aMessageNode lastIsReturn 
		ifTrue: [
			(aMessageNode owningScope) isBlockScope 
				ifTrue: [methodBuilder blockReturnTop] 
				ifFalse: [methodBuilder returnTop]] 
		ifFalse: [self isEffectTranslator ifTrue: [methodBuilder popTop]].! !

!OCASTTranslator methodsFor: 'inline messages factored' stamp: ''!
emitIfNil: aMessageNode boolean: aBoolean
	| args notNilBlock |
	
	valueTranslator visitNode: aMessageNode receiver.
	
	"emits the == nil code and push correct value on stack if the ifNotNil block has an argument"
	args := aMessageNode arguments.
	notNilBlock := aBoolean ifTrue: [args first] ifFalse: [args last].
	notNilBlock arguments ifNotEmpty: [ notNilBlock arguments first variable emitStore: methodBuilder ].
	methodBuilder pushLiteral: nil.
	methodBuilder send: #==.
	
	self emitCondition: args boolean: aBoolean! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitParseErrorNode: anErrorNode  
	methodBuilder 
		pushLiteralVariable: RuntimeSyntaxError binding;
		pushLiteral: anErrorNode;
		send: #signalSyntaxError:! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitToByDo: aMessageNode 

	| step |
	
	step := aMessageNode arguments second.
	step isLiteralNode ifFalse: [self error: 'should not have been inlined'].
	step := step value.

	self emitToDo: aMessageNode step: step! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitIfNotNilIfNil: aMessageNode
	self emitIfNil: aMessageNode boolean: true! !

!OCASTTranslator methodsFor: 'initialization' stamp: ''!
initialize

	methodBuilder := IRBuilder new.
	effectTranslator := self classForEffect basicNew.
	valueTranslator := self classForValue basicNew.
	effectTranslator setFromSimilar: self.
	valueTranslator setFromSimilar: self.! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitWhileTrue: aMessageNode

	self emitWhile: aMessageNode boolean: false! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitLiteralArrayNode: aRBLiteralArrayNode 
	 
	methodBuilder pushLiteral: aRBLiteralArrayNode value.! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitIfFalseIfTrue: aMessageNode

	self emitIf: aMessageNode boolean: true! !

!OCASTTranslator methodsFor: 'initialization' stamp: ''!
setFromSimilar: aSimilarTranslator
	methodBuilder := aSimilarTranslator privateMethodBuilder.
	effectTranslator := aSimilarTranslator privateEffectTranslator.
	valueTranslator := aSimilarTranslator privateValueTranslator.! !

!OCASTTranslator methodsFor: 'accessing' stamp: ''!
ir

	^ methodBuilder ir! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitLargeArrayNode: aRBArrayNode 
	"Long form: generates (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray"
	methodBuilder pushLiteralVariable: Array binding.
	methodBuilder pushLiteral: aRBArrayNode statements size.
	methodBuilder send: #braceStream:.
	aRBArrayNode statements do: [ :each |
		methodBuilder pushDup.
		valueTranslator visitNode: each.
		methodBuilder send: #nextPut:.
		methodBuilder popTop.
		].
	methodBuilder send: #braceArray.! !

!OCASTTranslator methodsFor: 'private' stamp: ''!
privateMethodBuilder
	^ methodBuilder! !

!OCASTTranslator methodsFor: 'inline messages factored' stamp: ''!
emitAllButLastCases: cases

	|  assocMessageNode  |
	
	1 to: cases size - 1 do: [:i |
		methodBuilder pushDup.
		assocMessageNode := cases at: i.
		valueTranslator visitInlinedBlockNode: assocMessageNode receiver.
		methodBuilder send: #=.
		methodBuilder jumpAheadTo: #next if: false.
		methodBuilder popTop.
		self visitInlinedBlockNode: assocMessageNode arguments first.
		methodBuilder jumpAheadTo: #end.
		methodBuilder jumpAheadTarget: #next.
	]! !

!OCASTTranslator methodsFor: 'initialization' stamp: ''!
classForEffect
	^OCASTTranslatorForEffect! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
translateFullBlock: aBlockNode

	methodBuilder mapToNode: aBlockNode.
	methodBuilder compilationContext: aBlockNode methodNode compilationContext.
	
	"args, then copied, then temps"
	methodBuilder addTemps: aBlockNode argumentNames.
	methodBuilder addTemps: aBlockNode scope inComingCopiedVarNames.
	methodBuilder addTemps: aBlockNode scope tempVarNamesWithoutArguments.
	methodBuilder numArgs: aBlockNode arguments size.
	
	aBlockNode scope tempVector ifNotEmpty: [
		methodBuilder 
			createTempVectorNamed: aBlockNode scope tempVectorName 
			withVars: aBlockNode scope tempVectorVarNames.
	].
	valueTranslator visitNode: aBlockNode body.
	methodBuilder mapToNode: aBlockNode body.
	methodBuilder addBlockReturnTopIfRequired.
	aBlockNode ir: self ir.
	^ aBlockNode ir compiledBlock: aBlockNode scope! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitArrayNode: anArrayNode 

	| elementNodes |
	
	anArrayNode statements size > 32 ifTrue: [^ self visitLargeArrayNode: anArrayNode ].
	
	elementNodes := anArrayNode children.
	elementNodes do: [:node | valueTranslator visitNode: node].
	methodBuilder pushConsArray: elementNodes size.! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitMessageNode: aMessageNode
	aMessageNode isInlined ifTrue: [
		methodBuilder addLiteral: aMessageNode selector. "so searching for senders will work"
		^self 
			perform: (OptimizedMessages at: aMessageNode selector)
			with: aMessageNode].
	^ self emitMessageNode: aMessageNode! !

!OCASTTranslator methodsFor: 'testing' stamp: ''!
isEffectTranslator
	^self == effectTranslator! !

!OCASTTranslator methodsFor: 'initialization' stamp: ''!
classForValue
	^OCASTTranslatorForValue! !

!OCASTTranslator methodsFor: 'private' stamp: ''!
privateValueTranslator
	^ valueTranslator! !

!OCASTTranslator methodsFor: 'accessing' stamp: ''!
compilationContext
	^methodBuilder compilationContext! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitIfTrueIfFalse: aMessageNode
	
	self emitIf: aMessageNode boolean: false! !

!OCASTTranslator methodsFor: 'inline messages factored' stamp: ''!
emitWhile: aMessageNode boolean: aBoolean

	methodBuilder jumpBackTarget: #begin.
	valueTranslator visitInlinedBlockNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #end if: aBoolean.
	aMessageNode arguments ifNotEmpty: [ 
			effectTranslator visitInlinedBlockNode: aMessageNode arguments first].
	methodBuilder jumpBackTo: #begin.
	methodBuilder jumpAheadTarget: #end.! !

!OCASTTranslator methodsFor: 'testing' stamp: ''!
isValueTranslator
	^self == valueTranslator! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitRepeat: aMessageNode
	| block |
	block := aMessageNode receiver.
	methodBuilder jumpBackTarget: #start.
	effectTranslator visitInlinedBlockNode: block.
	methodBuilder jumpBackTo: #start.
	self isValueTranslator ifTrue: [ methodBuilder pushLiteral: nil ]! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitCascadeNode: aCascadeNode 

	valueTranslator visitNode: aCascadeNode receiver.
	aCascadeNode messages allButLastDo: [:node |
		methodBuilder pushDup.
		effectTranslator visitNode: node.
	].
	self visitNode: aCascadeNode messages last.! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitMethodNode: aMethodNode
	
	aMethodNode arguments size > 15 ifTrue: [self backendError: 'Too many arguments' forNode: aMethodNode ].

	methodBuilder compilationContext: aMethodNode compilationContext.
	methodBuilder addTemps: aMethodNode scope tempVarNames.
		
	methodBuilder properties: aMethodNode methodProperties.
	methodBuilder irPrimitive: aMethodNode primitiveFromPragma.
	aMethodNode pragmas do: [:each | self visitPragmaNode: each].
	methodBuilder numArgs: aMethodNode arguments size.
	
	aMethodNode scope tempVector ifNotEmpty: [
		methodBuilder 
			createTempVectorNamed: aMethodNode scope tempVectorName 
			withVars: aMethodNode scope tempVectorVarNames
	].
	effectTranslator visitNode: aMethodNode body.
	aMethodNode body lastIsReturn ifFalse:  [methodBuilder pushReceiver; returnTop]! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitAnd: aMessageNode

	valueTranslator visitNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #else if: false.
	valueTranslator visitInlinedBlockNode: aMessageNode arguments first.
	methodBuilder jumpAheadTo: #end.
	methodBuilder jumpAheadTarget: #else.
	methodBuilder pushLiteral: false. 
	methodBuilder jumpAheadTarget: #end.! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitTimesRepeat: aMessageNode 
	| limit block limitEmit |
	
	limit := aMessageNode receiver.
	block := aMessageNode arguments last.
	
	limitEmit := [valueTranslator visitNode: limit].
	"if the limit is not just a literal or a non-writable variable, make a temp store it there"
	(limit isLiteralNode or: [limit isVariable and: [limit variable isWritable not]]) ifFalse: [
		valueTranslator visitNode: limit.
		methodBuilder addTemp: #'0limit'.
		methodBuilder storeTemp: #'0limit'.
		methodBuilder popTop.
		limitEmit := [methodBuilder pushTemp: #'0limit']].

	"push start. allocate and initialize iterator"
	self isValueTranslator ifTrue: [ limitEmit value ].
	methodBuilder pushLiteral: 1.
	methodBuilder addTemp: #'0iterator'.
	methodBuilder storeTemp: #'0iterator'.
	methodBuilder popTop. 
	methodBuilder jumpBackTarget: #start.
	methodBuilder pushTemp: #'0iterator'.
	limitEmit value.
	methodBuilder send: #<=.
	methodBuilder jumpAheadTo: #done if: false.

	effectTranslator visitInlinedBlockNode: block.
	methodBuilder pushTemp: #'0iterator'.
	methodBuilder pushLiteral: 1.
	methodBuilder send: #+.
	methodBuilder storeTemp: #'0iterator'.
	methodBuilder popTop.
	methodBuilder jumpBackTo: #start.
	methodBuilder jumpAheadTarget: #done.! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
emitMessageNode: aMessageNode

	aMessageNode isCascaded ifFalse: [
		valueTranslator visitNode: aMessageNode receiver].
	aMessageNode arguments do: [:each | 
		valueTranslator visitNode: each].
	aMessageNode isSuperSend
		ifTrue: [methodBuilder send: aMessageNode selector toSuperOf: self compilationContext getClass]
		ifFalse: [methodBuilder send: aMessageNode selector].! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitPragmaNode: aPragmaNode

	| var |
	methodBuilder addPragma: aPragmaNode asPragma.
	
	"if the pragma is a primitive that defines an error variable, we need to store error value 
	which is on the stack"
	aPragmaNode isPrimitiveError ifFalse: [ ^ self ].
	var := aPragmaNode methodNode scope lookupVar: aPragmaNode primitiveErrorVariableName.
	var emitStore: methodBuilder.! !

!OCASTTranslator methodsFor: 'errors' stamp: ''!
backendError: aMessage forNode: aNode
		
	SyntaxErrorNotification 	
		inClass: Object
		withCode: aNode methodNode source
		doitFlag: false
		errorMessage: aMessage
		location: aNode startWithoutParentheses! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitCaseOfOtherwise: aMessageNode

	self 
		emitCaseOf: aMessageNode 
		otherwiseBlock: [ valueTranslator visitInlinedBlockNode: aMessageNode arguments last ]! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitIfNilIfNotNil: aMessageNode
	self emitIfNil: aMessageNode boolean: false! !

!OCASTTranslator methodsFor: 'errors' stamp: ''!
shouldBeSentToValueOrEffectTranslator
	self error: 'should be sent only to valueTranslator or effectTranslator'! !

!OCASTTranslator methodsFor: 'private' stamp: ''!
privateEffectTranslator
	^ effectTranslator! !

!OCASTTranslator methodsFor: 'inline messages factored' stamp: ''!
emitCondition: args boolean: aBoolean
	"emits the jumps so that one of the 2 blocks in args is evaluated depending on boolean"
	
	methodBuilder jumpAheadTo: #else if: aBoolean.
	self visitInlinedBlockNode: args first.
	methodBuilder jumpAheadTo: #end.
	methodBuilder jumpAheadTarget: #else.
	self visitInlinedBlockNode: args last.
	methodBuilder jumpAheadTarget: #end.! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitOr: aMessageNode

	valueTranslator visitNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #else if: false.
	methodBuilder pushLiteral: true. 
	methodBuilder jumpAheadTo: #end.
	methodBuilder jumpAheadTarget: #else.
	valueTranslator visitInlinedBlockNode: aMessageNode arguments first.
	methodBuilder jumpAheadTarget: #end.! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitIfNil: aMessageNode

	valueTranslator visitNode: aMessageNode receiver.
	self isValueTranslator ifTrue: [ methodBuilder pushDup ].
	methodBuilder pushLiteral: nil.
	methodBuilder send: #==.
	methodBuilder jumpAheadTo: #else if: false.
	self isValueTranslator ifTrue: [ methodBuilder popTop ].
	self visitInlinedBlockNode: aMessageNode arguments first.
	methodBuilder jumpAheadTarget: #else.! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitIfFalse: aMessageNode

	self shouldBeSentToValueOrEffectTranslator! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitCaseOf: aMessageNode

	self 
		emitCaseOf: aMessageNode 
		otherwiseBlock: [ 
			methodBuilder pushReceiver.
			methodBuilder send: #caseError ]! !

!OCASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitVariableNode: aVariableNode
	aVariableNode variable emitValue: methodBuilder! !

!OCASTTranslator methodsFor: 'inline messages' stamp: ''!
emitIfNotNil: aMessageNode

	self shouldBeSentToValueOrEffectTranslator! !

!OCASTTranslator class methodsFor: 'class initialization' stamp: ''!
initialize

	OptimizedMessages := { 
		                     (#caseOf: -> #emitCaseOf:).
		                     (#caseOf:otherwise: -> #emitCaseOfOtherwise:).
		                     (#ifFalse: -> #emitIfFalse:).
		                     (#ifFalse:ifTrue: -> #emitIfFalseIfTrue:).
		                     (#ifNil: -> #emitIfNil:).
		                     (#ifNil:ifNotNil: -> #emitIfNilIfNotNil:).
		                     (#ifNotNil: -> #emitIfNotNil:).
		                     (#ifNotNil:ifNil: -> #emitIfNotNilIfNil:).
		                     (#ifTrue: -> #emitIfTrue:).
		                     (#ifTrue:ifFalse: -> #emitIfTrueIfFalse:).
		                     (#or: -> #emitOr:).
		                     (#and: -> #emitAnd:).
		                     (#timesRepeat: -> #emitTimesRepeat:).
		                     (#repeat -> #emitRepeat:).
		                     (#to:by:do: -> #emitToByDo:).
		                     (#to:do: -> #emitToDo:).
		                     (#whileFalse: -> #emitWhileFalse:).
		                     (#whileTrue: -> #emitWhileTrue:).
		                     (#whileFalse -> #emitWhileFalse:).
		                     (#whileTrue -> #emitWhileTrue:) } asDictionary! !

!OCASTTranslatorForEffect commentStamp: ''!
I override some methods in my super to generate instructions for effect only.!
!OCASTTranslatorForEffect methodsFor: 'inline messages' stamp: ''!
emitIfTrue: aMessageNode

	valueTranslator visitNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #else if: false.	
		self visitInlinedBlockNode: aMessageNode arguments first.
	methodBuilder jumpAheadTarget: #else.! !

!OCASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitBlockNode: aBlockNode 
	"even though the code is never executed, we generate it to make sure that we 
	can map bytecode and access temps"
	super visitBlockNode: aBlockNode.
	methodBuilder popTop! !

!OCASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitSequenceNode: aSequenceNode 
	aSequenceNode statements do: [:each | self visitNode: each].! !

!OCASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitLiteralArrayNode: aLiteralNode

	super visitLiteralArrayNode: aLiteralNode.
	methodBuilder popTop! !

!OCASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitAssignmentNode: anAssignmentNode 

	super visitAssignmentNode: anAssignmentNode .
	methodBuilder popTop.! !

!OCASTTranslatorForEffect methodsFor: 'inline messages' stamp: ''!
emitOr: aMessageNode

	super emitOr: aMessageNode.
	methodBuilder popTop.! !

!OCASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitLiteralNode: aLiteralNode

	super visitLiteralNode: aLiteralNode.
	methodBuilder popTop! !

!OCASTTranslatorForEffect methodsFor: 'inline messages' stamp: ''!
emitAnd: aMessageNode
	
	super emitAnd: aMessageNode.
	methodBuilder popTop.! !

!OCASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitArrayNode: anArrayNode 
	"An arrayNode may have side effect, for example: '{self foo}'. So we cannot just generate nothing for this node."

	super visitArrayNode: anArrayNode.
	methodBuilder popTop.! !

!OCASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
emitMessageNode: aMessageNode 

	super emitMessageNode: aMessageNode.
	methodBuilder popTop.! !

!OCASTTranslatorForEffect methodsFor: 'inline messages' stamp: ''!
emitIfFalse: aMessageNode

	valueTranslator visitNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #else if: true.
		self visitInlinedBlockNode: aMessageNode arguments first.
	methodBuilder jumpAheadTarget: #else.! !

!OCASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitParseErrorNode: anErrorNode  

	super visitParseErrorNode: anErrorNode.
	methodBuilder popTop.! !

!OCASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitVariableNode: aVariableNode
	"when visiting a variable for effect, we could push it and then pop it, but we do nothing"
	| variable |
	variable := aVariableNode variable.
	(variable isLiteralVariable or: [ variable isUndeclaredVariable ])
		ifTrue: [ methodBuilder addLiteral: variable ]! !

!OCASTTranslatorForEffect methodsFor: 'inline messages' stamp: ''!
emitIfNotNil: aMessageNode
	| args |
	valueTranslator visitNode: aMessageNode receiver.
	args := aMessageNode arguments.
	args first arguments ifNotEmpty: [ args first arguments first variable emitStore: methodBuilder ].
	methodBuilder pushLiteral: nil.
	methodBuilder send: #==.
	methodBuilder jumpAheadTo: #end if: true.
	self visitInlinedBlockNode: args first.
	methodBuilder jumpAheadTarget: #end.! !

!OCASTTranslatorForValue commentStamp: ''!
I override some methods in my super to generate instructions for effect and value only.!
!OCASTTranslatorForValue methodsFor: 'inline messages' stamp: ''!
emitIfTrue: aMessageNode
	
	self visitNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #else if: false.
	self visitInlinedBlockNode:  aMessageNode arguments first.
	methodBuilder jumpAheadTo: #end.
	methodBuilder jumpAheadTarget: #else.
	methodBuilder pushLiteral: nil.
	methodBuilder jumpAheadTarget: #end.! !

!OCASTTranslatorForValue methodsFor: 'inline messages' stamp: ''!
emitWhileFalse: aMessageNode

	super emitWhileFalse: aMessageNode.
	methodBuilder pushLiteral: nil.! !

!OCASTTranslatorForValue methodsFor: 'inline messages' stamp: ''!
emitWhileTrue: aMessageNode

	super emitWhileTrue: aMessageNode.
	methodBuilder pushLiteral: nil.! !

!OCASTTranslatorForValue methodsFor: 'visitor - double dispatching' stamp: ''!
visitSequenceNode: aSequenceNode 
	| statements |
	statements := aSequenceNode statements.
	statements ifEmpty: [
		methodBuilder pushLiteral: nil.
		^self].
	statements allButLastDo: [:each | effectTranslator visitNode: each].
	self visitNode: statements last.! !

!OCASTTranslatorForValue methodsFor: 'inline messages' stamp: ''!
emitIfFalse: aMessageNode
	
	self visitNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #false if: false.
		methodBuilder pushLiteral: nil.
		methodBuilder jumpAheadTo: #end.
		methodBuilder jumpAheadTarget: #false.
	self visitInlinedBlockNode: aMessageNode arguments first.
	methodBuilder jumpAheadTarget: #end.! !

!OCASTTranslatorForValue methodsFor: 'inline messages' stamp: ''!
emitIfNotNil: aMessageNode
	| args |
	self visitNode: aMessageNode receiver.
	args := aMessageNode arguments.
	args first arguments ifNotEmpty: [ args first arguments first variable emitStore: methodBuilder ].
	methodBuilder pushDup.
	methodBuilder pushLiteral: nil.
	methodBuilder send: #==.
	methodBuilder jumpAheadTo: #end if: true.
	methodBuilder popTop.
	self visitInlinedBlockNode: args first.
	methodBuilder jumpAheadTarget: #end.! !

!OCASTTranslatorMappingForFullBlockClosuresTest methodsFor: 'tests' stamp: ''!
testSimpleBlockASTMapping
	|method blockNode|
	method := compiler compile: 'm ^[40 + 2] value'.
	blockNode := method ast statements first value receiver.
	self assertBlockNodeHasCorrectIR: blockNode.
	self assertMethodReturnValue: method! !

!OCASTTranslatorMappingForFullBlockClosuresTest methodsFor: 'tests' stamp: ''!
assertBlockNodeHasCorrectIR: blockNode
	| sequence |
	blockNode methodNode ir.
	sequence := blockNode ir startSequence sequence.
	self assert: (sequence allSatisfy: [ :ir | ir sourceNode notNil ]).
	self assert: sequence last sourceNode equals: blockNode body! !

!OCASTTranslatorMappingForFullBlockClosuresTest methodsFor: 'tests' stamp: ''!
assertMethodReturnValue: method
	self
		assert: (method valueWithReceiver: nil arguments: #())
		equals: 42! !

!OCASTTranslatorMappingForFullBlockClosuresTest methodsFor: 'tests' stamp: ''!
testBlockWithParametersASTMapping
	|method blockNode|
	method := compiler compile: 'm ^[:i :j|i+j] value: 41 value: 1'.
	blockNode := method ast statements first value receiver.
	self assertBlockNodeHasCorrectIR: blockNode.
	self assertMethodReturnValue: method! !

!OCASTTranslatorMappingForFullBlockClosuresTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	compiler := OpalCompiler new
		options: #(+optionEmbeddSources);
		yourself! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
executeMethod: aMethod onReceiver: receiver

	^ aMethod valueWithReceiver: receiver arguments: #()! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
globals: anObject
	globals := anObject! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
compilationContext

	| context |
	context := CompilationContext new
		encoderClass: self encoder;
		bindings: globals;
		interactive: true;
		yourself.
	^ context! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
executeMethod: aMethod onReceiver: receiver withArguments: arguments

	^ aMethod valueWithReceiver: receiver arguments: arguments! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
compileExample: aSelector
	
	^ self compileSource: (OCOpalExamples>> aSelector) sourceCode! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
instance
	^ instance! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
encoder

	^ encoder! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
executeMethod: aMethod onReceiver: receiver withArgument: anArgument

	^ self executeMethod: aMethod onReceiver: receiver withArguments: {anArgument}! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
testExample: aSelector withArgument: anArgument

	^ self testExample: aSelector withArguments: { anArgument }! !

!OCASTTranslatorTest methodsFor: 'tests - primitives' stamp: ''!
testExamplePrimitiveErrorCode
	| ast ir newMethod |
	method := OCOpalExamples >> #examplePrimitiveErrorCode.
	ast := method parseTree.
	ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir.

	newMethod := ir compiledMethod.
	self assert: method primitive equals: newMethod primitive! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
globals
	^ globals! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
instance: anObject
	instance := anObject! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
executeMethodOnInstance: aMethod

	^ self executeMethod: aMethod onReceiver: instance! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
encoder: anEncoder

	encoder := anEncoder! !

!OCASTTranslatorTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	instance := OCOpalExamples new.
	globals := SystemDictionary new.! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
testSource: sourceCode withArguments: arguments

	self compileSource: sourceCode.
	^ self executeMethod: method onReceiver: instance withArguments: arguments! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!OCASTTranslatorTest methodsFor: 'running' stamp: ''!
tearDown

	OCOpalExamples reset.
	super tearDown! !

!OCASTTranslatorTest methodsFor: 'tests - primitives' stamp: ''!
testExamplePrimitiveModuleError
"teset for primitive declaration
  <primitive: 'primFunction'  module: 'primModule' error: errorCode >
"
	| ast ir |
	method := OCOpalExamples >> #examplePrimitiveModuleError.
	ast := method parseTree.
	ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir.
	self assert: ir tempKeys equals: #(#errorCode)! !

!OCASTTranslatorTest methodsFor: 'tests - simple' stamp: ''!
testSendSpecialBinaryMessage

	self assert: (Smalltalk specialSelectors includes: #+).
	self assert: (self testExample: #exampleReturn1plus2) equals: 3! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
testSource: sourceCode

	^ self testSource: sourceCode withArguments: #()! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
compileSource: source
	| ir ast |
	ast := RBParser parseMethod: source.
	ast compilationContext: self compilationContext.
	ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir.
	^ 	method := ir compiledMethod! !

!OCASTTranslatorTest methodsFor: 'tests - primitives' stamp: ''!
testExamplePrimitiveErrorModule
"test for primitive declaration
  <primitive: 'primFunction'  error: errorCode module: 'primModule'  >
"
	| ast ir |
	method := OCOpalExamples >> #examplePrimitiveErrorModule.
	ast := method parseTree.
	ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir.
	self assert: ir tempKeys equals: #(#errorCode)! !

!OCASTTranslatorTest methodsFor: 'tests - primitives' stamp: ''!
testExamplePrimitiveErrorCodeModule
	| ast ir newMethod |
	method := OCOpalExamples >> #examplePrimitiveErrorCodeModule.
	ast := method parseTree.
	ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir.

	newMethod := ir compiledMethod.

	self assert: method primitive equals: newMethod primitive.
	self assert: method pragmas printString equals: newMethod pragmas printString! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
instanceVariablesToKeep

	^ super instanceVariablesToKeep , #('fullblocks')! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
method: anObject
	^ method := anObject! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
optimization: anObject
	optimization := anObject! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
testExample: aSelector

	^ self testExample: aSelector withArguments: #()! !

!OCASTTranslatorTest methodsFor: 'support' stamp: ''!
testExample: aSelector withArguments: arguments

	^ self testSource: ((OCOpalExamples>> aSelector) sourceCode) withArguments: arguments! !

!OCASTTranslatorTest methodsFor: 'accessing' stamp: ''!
optimization
	^ optimization! !

!OCASTTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters

	^ super testParameters
		addCase: { #encoder -> EncoderForSistaV1 };
		yourself! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testPushArgumentVariable
	self testExample: #examplePushArgumentVariable: withArgument: 17.
	
	self assert: instance result equals: 17! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testPushThisContext
	method := self compileExample: #exampleThisContext.
	self executeMethodOnInstance: method.

	self assert: instance result isContext.
	self assert: instance result method equals: method.! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testAssignClassVariable
	self assert: instance iVar equals: nil.
	self testExample: #exampleClassVariableAssignment.
	self assert: instance classVariable equals: 1! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testAssignSelfVariable
	self
		should: [self compileSource: 'foo
	self := 17'] raise: OCStoreIntoReservedVariableError! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testPushInstanceVariable
	instance iVar: 17.
	self testExample: #examplePushInstanceVariable.
	
	self assert: instance result equals: 17! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testPushTemporaryVariable
	instance iVar: 17.
	self testExample: #examplePushTemporaryVariable.
	
	self assert: instance result equals: 17! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testAssignTemporaryVariable
	self testExample: #exampleTemporaryVariableAssignment.
	
	self assert: instance result equals: 17! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testPushSuper
	
	self assert: instance result equals: nil.
	self testExample: #exampleSuper.
	self assert: instance result equals: instance! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testAssignThisContextVariable
	self
		should: [self compileSource: 'foo
	thisContext := 17'] raise: OCStoreIntoReservedVariableError! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testAssignGlobalVariable
	globals add: (GlobalVariable key: #GlobalVariable value: nil).
	self testSource: 'exampleGlobalVariableAssignment
	GlobalVariable := 17'.
	self assert: (globals at: #GlobalVariable) equals: 17! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testPushClassVariable
	instance classVariable: 17.
	self testExample: #examplePushClassVariable.
	
	self assert: instance result equals: 17! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testPushGlobalVariable

	globals add: (GlobalVariable key: #GlobalVariable value: 17).
	self testSource: 'exampleGlobalVariableAssignment
	self message: GlobalVariable'.
	
	self assert: instance result equals: 17! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testPushSelf
	
	self assert: instance result equals: nil.
	self testExample: #exampleSelf.
	self assert: instance result equals: instance! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testAssignInstanceVariable
	self assert: instance iVar equals: nil.
	self testExample: #exampleInstanceVariableAssignment.
	self assert: instance iVar equals: 1! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testAssignSuperVariable
	self
		should: [self compileSource: 'foo
	super := 17'] raise: OCStoreIntoReservedVariableError! !

!OCASTVariableTranslatorTest methodsFor: 'tests - variables' stamp: ''!
testAssignArgumentVariable
	self
		should: [self compileSource: 'argument: anArgument
	anArgument := 17'] raise: OCStoreIntoReadOnlyVariableError! !

!OCASTWhileFalseTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testWhileFalseExecutesLeftBlockWithTemp
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	temp := 0.
	{argument1} whileFalse: {argument2}.
	^ temp'
		withTemps: #( 'temp' )
		withFirstBlock: '[ | intemp |
			intemp := temp + 1.
			temp := intemp.
			intemp > 4 ]'
		withSecondBlock: '[ ]'.

	self assert: result equals: 5.! !

!OCASTWhileFalseTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testWhileFalseExecutesRightBlockWithTemp
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	temp := 0.
	{argument1} whileFalse: {argument2}.
	^ temp'
		withTemps: #( 'temp' )
		withFirstBlock: '[ temp > 4 ]'
		withSecondBlock: '[ | intemp |
			intemp := temp + 1.
			temp := intemp ]'.

	self assert: result equals: 5.! !

!OCASTWhileFalseTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testWhileFalseReturnsNil
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	temp := 0.
	^ {argument1} whileFalse: {argument2}'
		withTemps: #( 'temp' )
		withFirstBlock: '[ temp := temp + 1. temp > 4 ]'
		withSecondBlock: '[ ]'.

	self assert: result equals: nil.! !

!OCASTWhileFalseTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testWhileFalseExecutesLeftBlock
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	temp := 0.
	{argument1} whileFalse: {argument2}.
	^ temp'
		withTemps: #( 'temp' )
		withFirstBlock: '[ temp := temp + 1. temp > 4 ]'
		withSecondBlock: '[ ]'.

	self assert: result equals: 5.! !

!OCASTWhileFalseTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testWhileFalseExecutesRightBlock
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	temp := 0.
	{argument1} whileFalse: {argument2}.
	^ temp'
		withTemps: #( 'temp' )
		withFirstBlock: '[ temp > 4 ]'
		withSecondBlock: '[ temp := temp + 1 ]'.

	self assert: result equals: 5.! !

!OCASTWhileFalseTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters
	^ super testParameters *
		(ParametrizedTestMatrix new
			forSelector: #optimization addOptions: { #optionInlineWhile . #optionInlineNone })! !

!OCASTWhileTrueTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testWhileTrueExecutesLeftBlock
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	temp := 0.
	{argument1} whileTrue: {argument2}.
	^ temp'
		withTemps: #( 'temp' )
		withFirstBlock: '[ temp := temp + 1. temp < 5 ]'
		withSecondBlock: '[ ]'.

	self assert: result equals: 5.! !

!OCASTWhileTrueTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testWhileTrueExecutesLeftBlockWithTemp
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	temp := 0.
	{argument1} whileTrue: {argument2}.
	^ temp'
		withTemps: #( 'temp' )
		withFirstBlock: '[ | intemp |
			intemp := temp + 1.
			temp := intemp.
			intemp < 5 ]'
		withSecondBlock: '[ ]'.

	self assert: result equals: 5.! !

!OCASTWhileTrueTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testWhileTrueExecutesRightBlockWithTemp
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	temp := 0.
	{argument1} whileTrue: {argument2}.
	^ temp'
		withTemps: #( 'temp' )
		withFirstBlock: '[ temp < 5 ]'
		withSecondBlock: '[ | intemp |
			intemp := temp + 1.
			temp := intemp.
			temp ]'.

	self assert: result equals: 5.! !

!OCASTWhileTrueTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testWhileTrueExecutesRightBlock
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	temp := 0.
	{argument1} whileTrue: {argument2}.
	^ temp'
		withTemps: #( 'temp' )
		withFirstBlock: '[ temp < 5 ]'
		withSecondBlock: '[ temp := temp + 1 ]'.

	self assert: result equals: 5.! !

!OCASTWhileTrueTranslatorTest methodsFor: 'tests - blocks - optimized' stamp: ''!
testWhileTrueReturnsNil
	| result |
	result := self
		testComposedExample: 'example
	{definition}.
	temp := 0.
	^ {argument1} whileTrue: {argument2}'
		withTemps: #( 'temp' )
		withFirstBlock: '[ temp := temp + 1. temp < 5 ]'
		withSecondBlock: '[ ]'.

	self assert: result equals: nil.! !

!OCASTWhileTrueTranslatorTest class methodsFor: 'building suites' stamp: ''!
testParameters
	^ super testParameters *
		(ParametrizedTestMatrix new
			forSelector: #optimization addOptions: { #optionInlineWhile . #optionInlineNone })! !

!OCAbstractMethodScope commentStamp: ''!
I am an abstract superclass for Block and Method scopes!
!OCAbstractMethodScope methodsFor: 'accessing' stamp: ''!
node: aNode
	node := aNode! !

!OCAbstractMethodScope methodsFor: 'temp vars - vector' stamp: ''!
tempVectorVar
	^ tempVectorVar ifNil: [ tempVectorVar := TemporaryVariable new
			name: self tempVectorName;
			scope: self;
			yourself]! !

!OCAbstractMethodScope methodsFor: 'accessing' stamp: ''!
id: int
	id := int! !

!OCAbstractMethodScope methodsFor: 'temp vars - copying' stamp: ''!
copiedVarNames
	^ copiedVars keys! !

!OCAbstractMethodScope methodsFor: 'accessing' stamp: ''!
node
	^node! !

!OCAbstractMethodScope methodsFor: 'lookup' stamp: ''!
hasBindingThatBeginsWith: aString
	"check weather there are any temporaries defined that start with aString"
	(copiedVars hasBindingThatBeginsWith: aString) ifTrue: [ ^true ].
	(tempVector hasBindingThatBeginsWith: aString) ifTrue: [ ^true ].
	(tempVars hasBindingThatBeginsWith: aString) ifTrue: [ ^true ].
	
	^ self outerScope hasBindingThatBeginsWith: aString! !

!OCAbstractMethodScope methodsFor: 'temp vars - copying' stamp: ''!
copyEscapingReads

	self tempVars values 
		select: [ :each | each isEscapingRead ]
		thenDo: [ :each | self addCopyingTemp: each ]! !

!OCAbstractMethodScope methodsFor: 'printing' stamp: ''!
printOn: stream

	super printOn: stream.
	stream space.
	self scopeLevel printOn: stream.! !

!OCAbstractMethodScope methodsFor: 'lookup' stamp: ''!
lookupDefiningContextForVariable: var startingFrom: aContext
	"Is this the definition context for var? If it not, we look in the outer context using the corresponding outer scope. If found, we return the context"
	
	^self = var scope
		ifFalse: [ self outerScope lookupDefiningContextForVariable: var startingFrom: (self nextOuterScopeContextOf: aContext) ]
		ifTrue: [ aContext ]! !

!OCAbstractMethodScope methodsFor: 'scope' stamp: ''!
newBlockScope: int
	^ OCBlockScope new outerScope: self; id: int; yourself.! !

!OCAbstractMethodScope methodsFor: 'temp vars' stamp: ''!
tempVars

	^ tempVars! !

!OCAbstractMethodScope methodsFor: 'temp vars - vector' stamp: ''!
addVectorTemp: aTemp
	^ tempVector 
		at:  aTemp name
		put: (OCVectorTempVariable new
			name: aTemp name;
			vectorName: self tempVectorName;
			scope: self;
			usage: aTemp usage;
			escaping: aTemp escaping;
			yourself)! !

!OCAbstractMethodScope methodsFor: 'temp vars - vector' stamp: ''!
moveEscapingWritesToTempVector

	self tempVars values
		select: [ :each | each isEscapingWrite ]
		thenDo: [ :each | self moveToVectorTemp: each ]! !

!OCAbstractMethodScope methodsFor: 'printing' stamp: ''!
scopeLevel
	"For debugging we print a counter for all Method and Block scopes"
	^ outerScope scopeLevel + 1! !

!OCAbstractMethodScope methodsFor: 'temp vars' stamp: ''!
removeTemp: tempVar

	tempVars removeKey: tempVar name! !

!OCAbstractMethodScope methodsFor: 'scope' stamp: ''!
popScope
	"Propogate free var usages to their outer vars, then return outer scope"

	^ self outerScope! !

!OCAbstractMethodScope methodsFor: 'temp vars - vector' stamp: ''!
tempVectorName
	"the name of the tempVector is not a valid name of a temp variable
	 This way we avoid name clashes "
	^'0vector', id asString! !

!OCAbstractMethodScope methodsFor: 'scope' stamp: ''!
newOptimizedBlockScope: int
	^ OCOptimizedBlockScope new 
			outerScope: self; 
			id: int;
			yourself.! !

!OCAbstractMethodScope methodsFor: 'lookup' stamp: ''!
nextOuterScopeContextOf: aContext
	^aContext! !

!OCAbstractMethodScope methodsFor: 'temp vars' stamp: ''!
allTempNames
	^self allTemps collect: [: each | each name]! !

!OCAbstractMethodScope methodsFor: 'initialization' stamp: ''!
initialize

	tempVars :=  OrderedDictionary new.
	tempVector  := OrderedDictionary new.
	copiedVars := OrderedDictionary new.
	id := 0! !

!OCAbstractMethodScope methodsFor: 'temp vars - copying' stamp: ''!
addCopyingTempToAllScopesUpToDefTemp: aVar

	(self copiedVarNames includes: aVar name) ifFalse: [self addCopyingTemp: aVar].
	self = aVar scope ifTrue: [^ self].
	^ self outerScope addCopyingTempToAllScopesUpToDefTemp: aVar.! !

!OCAbstractMethodScope methodsFor: 'temp vars - copying' stamp: ''!
setCopyingTempToAllScopesUpToDefTemp: aVar to: aValue from: aContext
	"we need to update all the copies if we change the value of a copied temp"

	self = aVar scope
		ifTrue: [ ^ aVar writeFromLocalContext: aContext put: aValue ].
	(self lookupVar: aVar name) writeFromLocalContext: aContext put: aValue.
	^self outerScope
		setCopyingTempToAllScopesUpToDefTemp: aVar
		to: aValue
		from: (self nextOuterScopeContextOf: aContext)! !

!OCAbstractMethodScope methodsFor: 'temp vars' stamp: ''!
localTempNames
	^self localTemps collect: [:each | each name]! !

!OCAbstractMethodScope methodsFor: 'temp vars - vector' stamp: ''!
tempVectorVarNames
	"As other users are taking the values directly from the tempVector Dictionary, 
	it is important that the collect is performed like this. As in this way it has always the order dependending on the hash of the String (that is constant). 
	If done with collect:as: it has the order of the Dictionary that is almost random (changes from image run to image run)"
	^ (self tempVector collect: [:each| each name]) asArray! !

!OCAbstractMethodScope methodsFor: 'scope' stamp: ''!
outerNotOptimizedScope
	^self! !

!OCAbstractMethodScope methodsFor: 'temp vars' stamp: ''!
tempVarNamesWithoutArguments

	^ tempVars values reject: [ :each | each isArgumentVariable ] thenCollect: [ :each | each name ]! !

!OCAbstractMethodScope methodsFor: 'temp vars - copying' stamp: ''!
copiedVars
	^ copiedVars! !

!OCAbstractMethodScope methodsFor: 'temp vars' stamp: ''!
tempVarNames

	^ tempVars keys! !

!OCAbstractMethodScope methodsFor: 'temp vars - vector' stamp: ''!
moveToVectorTemp: aTempVar

	self addVectorTemp: aTempVar.
	self removeTemp: aTempVar.! !

!OCAbstractMethodScope methodsFor: 'temp vars - vector' stamp: ''!
tempVector
	^ tempVector! !

!OCAbstractMethodScope methodsFor: 'temp vars - vector' stamp: ''!
hasTempVector
	^ tempVector isNotEmpty! !

!OCAbstractMethodScope methodsFor: 'scope' stamp: ''!
methodScope

	^ self outerScope methodScope! !

!OCAbstractMethodScope methodsFor: 'temp vars' stamp: ''!
allTemps
	"return all temps defined, even the ones in the outer scope that are not used in the current.
	 This includes the arguments. We do not need to care about shadowed temps as temp shadowing is not allowed."

	^ Array streamContents: [ :str | 
			self outerScope allTemps
				do: [ :var | 
					(self localTempNames includes: var name)
						ifFalse: [ str nextPut: var ] ].
			str nextPutAll: self localTemps ]! !

!OCAbstractMethodScope methodsFor: 'temp vars' stamp: ''!
addTemp: aTempVar	
	aTempVar scope: self.
	^ tempVars
		at: aTempVar name
		put: aTempVar! !

!OCAbstractMethodScope methodsFor: 'temp vars - copying' stamp: ''!
addCopyingTemp: aTempVar
	^copiedVars at: aTempVar name put: (aTempVar createCopiedVariableFor: self)! !

!OCAbstractMethodScope methodsFor: 'lookup' stamp: ''!
lookupVar: name declare: aBoolean

	copiedVars at: name ifPresent: [:v | ^ v].
	tempVector at: name ifPresent: [:v | ^ v].
	tempVars at: name ifPresent: [:v | ^ v].
	name = self tempVectorName ifTrue: [ ^ self tempVectorVar ].
	^self outerScope lookupVar: name declare: aBoolean! !

!OCAbstractMethodScope methodsFor: 'temp vars' stamp: ''!
localTemps
	"all temps accessed in the context... for tempVectors, it takes all the vars even those not used here"

	^ Array streamContents: [ :str | 
			copiedVars valuesDo: [ :var | 
					var isStoringTempVector
						ifTrue: [ var originalVar scope tempVector
								do: [ :tempVectorVars | str nextPut: tempVectorVars ] ] ].
			str nextPutAll: tempVars values]! !

!OCAbstractScope commentStamp: ''!
I am a symbol table where variable names are associated with SemVars.  Each context (method/closure) get a fresh scope that inherits from its outer scope.!
!OCAbstractScope methodsFor: 'lookup' stamp: ''!
lookupVarForDeclaration: name
	"This is a version of #lookupVar: that skips the OCRequestorScope.
	When looking temp var declarations, we do not want the Requestor scope to automatically
	create that variable. Subclasses override if they do not skip but do a lookup"

	^ self lookupVar: name declare: false! !

!OCAbstractScope methodsFor: 'lookup' stamp: ''!
hasBindingThatBeginsWith: aString
	"check weather there are any variables defined that start with aString"
	^ outerScope
		ifNil: [ false ]
		ifNotNil: [ outerScope hasBindingThatBeginsWith: aString ]! !

!OCAbstractScope methodsFor: 'testing' stamp: ''!
isMethodScope

	^false! !

!OCAbstractScope methodsFor: 'testing' stamp: ''!
isBlockScope

	^false! !

!OCAbstractScope methodsFor: 'lookup' stamp: ''!
outerScope

	^ outerScope! !

!OCAbstractScope methodsFor: 'testing' stamp: ''!
isInsideOptimizedLoop
	^ false! !

!OCAbstractScope methodsFor: 'testing' stamp: ''!
hasTempVector
	^ false! !

!OCAbstractScope methodsFor: 'lookup' stamp: ''!
lookupVar: name
	"search the scope (and the outer scopes) for a variable 'name' and return it"
	^ self lookupVar: name declare: true! !

!OCAbstractScope methodsFor: 'initializing' stamp: ''!
outerScope: aSemScope

	outerScope := aSemScope! !

!OCAbstractScope methodsFor: 'lookup' stamp: ''!
lookupVar: name declare: aBoolean
	"search the scope (and the outer scopes) for a variable 'name' and return it"
	^self subclassResponsibility! !

!OCArrayLiteralTest methodsFor: 'running' stamp: ''!
tearDown

	self class removeSelector: #array.
	super tearDown! !

!OCArrayLiteralTest methodsFor: 'tests' stamp: ''!
testByteArrayLiteral
	self class compile: 'array ^ #[ 1 2 3 4 ]'.
	self assert: self array equals: self array.
	self assert: self array identicalTo: self array! !

!OCArrayLiteralTest methodsFor: 'tests' stamp: ''!
testByteArrayRange
	self class compile: 'array ^ #[ 0 255 ]'.
	self assert: (self array isKindOf: ByteArray).
	self assert: self array size equals: 2.
	self assert: self array first equals: 0.
	self assert: self array last equals: 255! !

!OCArrayLiteralTest methodsFor: 'tests' stamp: ''!
testByteArrayWithinArray
	self class compile: 'array ^ #( #[1] #[2] )'.
	self assert: (self array isKindOf: Array).
	self assert: self array size equals: 2.
	self assert: (self array first isKindOf: ByteArray).
	self assert: self array first first equals: 1.
	self assert: (self array last isKindOf: ByteArray).
	self assert: self array last first equals: 2! !

!OCArrayLiteralTest methodsFor: 'tests' stamp: ''!
testSymbols
	self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'.
	self assert: self array equals: {#nil . #true . #false . #nil . #true . #false}! !

!OCArrayLiteralTest methodsFor: 'tests' stamp: ''!
testByteArrayEmpty
	self class compile: 'array ^ #[]'.
	self assert: (self array isKindOf: ByteArray).
	self assertEmpty: self array! !

!OCArrayLiteralTest methodsFor: 'tests' stamp: ''!
testByteArrayBase
	self class compile: 'array ^ #[2r1010 8r333 16rFF]'.
	self assert: (self array isKindOf: ByteArray).
	self assert: self array size equals: 3.
	self assert: self array first equals: 10.
	self assert: self array second equals: 219.
	self assert: self array last equals: 255! !

!OCArrayLiteralTest methodsFor: 'running' stamp: ''!
runCase

	SystemAnnouncer uniqueInstance suspendAllWhile: [ super runCase ]! !

!OCArrayLiteralTest methodsFor: 'tests' stamp: ''!
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 equals: 256.
	0 to: 255 do: [ :index | self assert: (self array at: index + 1) equals: index ]! !

!OCArrayLiteralTest methodsFor: 'tests' stamp: ''!
testReservedIdentifiers
	self class compile: 'array ^ #(nil true false)'.
	self assert: self array equals: {nil . true . false}! !

!OCBlockScope commentStamp: ''!
I modelt the scope of a block!
!OCBlockScope methodsFor: 'lookup' stamp: ''!
nextOuterScopeContextOf: aContext

	"Returns the next context to lookup a variable name from within outer scope.
	If it is block context then we return outer context for lookup.
	But if it is method context lookup will continue in same context but within outer scope"
	^ aContext outerContext ifNil: [ aContext ]! !

!OCBlockScope methodsFor: 'testing' stamp: ''!
hasEscapingVars
	^ (copiedVars isEmpty and: [tempVector isEmpty]) not! !

!OCBlockScope methodsFor: 'testing' stamp: ''!
isBlockScope
	^ true! !

!OCBlockScope methodsFor: 'testing' stamp: ''!
isInsideOptimizedLoop
	^ self outerScope isInsideOptimizedLoop! !

!OCBlockScope methodsFor: 'accessing' stamp: ''!
inComingCopiedVarNames
	^ self copiedVarNames intersection: outerScope copiedVarNames! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlock
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlock) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) value equals: instance exampleSimpleBlock value! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleWhileModificationBefore
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleWhileModificationBefore) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleWhileModificationBefore! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleIfTrue
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleIfTrue) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleIfTrue! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleIfTrueIfFalse
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleIfTrueIfFalse) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleIfTrueIfFalse! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleWhileWithTemp
	| ir method newMethod |
	method := (OCOpalExamples >> #exampleWhileWithTemp) parseTree generate.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: OCOpalExamples new arguments: #()) equals: OCOpalExamples new exampleWhileWithTemp! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleMethodWithOptimizedBlocksA
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleMethodWithOptimizedBlocksA) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleMethodWithOptimizedBlocksA! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockLocalNested
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockNested) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockNested! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleIfFalse
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleIfFalse) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleIfFalse! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockEmpty
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockEmpty) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockEmpty! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleIfNotNilArg
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleIfNotNilArg) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleIfNotNilArg! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleBlockInternal
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleBlockInternal) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleBlockInternal! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleToDoOutsideTempNotInlined
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleToDoOutsideTempNotInlined) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleToDoOutsideTempNotInlined! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockArgument1
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockArgument1) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockArgument1! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - variables' stamp: ''!
testExampleSelf
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSelf) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSelf! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleWhileModificationBeforeNotInlined
	| ir method newMethod |
	method := (OCOpalExamples >> #exampleWhileModificationBeforeNotInlined) parseTree generate.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: OCOpalExamples new arguments: #()) equals:  OCOpalExamples new exampleWhileModificationBeforeNotInlined! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - simple' stamp: ''!
testExampleNewArray
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleNewArray) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleNewArray! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleWhileModificationAfterNotInlined
	| ir method newMethod |
	method := (OCOpalExamples >> #exampleWhileModificationAfterNotInlined) parseTree generate.
	
	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: OCOpalExamples new arguments: #()) equals: OCOpalExamples new exampleWhileModificationAfterNotInlined! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleSimpleBlockLocalIf
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockLocalIf) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockLocalIf! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockReturn
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockReturn) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockReturn! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleMethodTempInNestedBlock
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleMethodTempInNestedBlock) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleMethodTempInNestedBlock! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - variables' stamp: ''!
testExampleSuper
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSuper) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSuper! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleIfFalseIfTrue
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleIfFalseIfTrue) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleIfFalseIfTrue! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - variables' stamp: ''!
testExampleThisContext
	| ir method newMethod instance |
	
	method := (OCOpalExamples>>#exampleThisContext) parseTree generate.
	
	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.
	
	instance := OCOpalExamples new.
	newMethod valueWithReceiver: instance arguments: #().
	
	self assert: instance result isContext! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleSimpleBlockLocalWhile
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockLocalWhile) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockLocalWhile! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockiVar
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockiVar) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockiVar! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - simple' stamp: ''!
testExampleReturn1plus2
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleReturn1plus2) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleReturn1plus2! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleBlockExternal
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleBlockExternal) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleBlockExternal! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockArgument3
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockArgument3) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockArgument3! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleToDoArgumentNotInlined
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleToDoArgumentNotInlined) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleToDoArgumentNotInlined! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleNestedBlockScoping
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleNestedBlockScoping) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleNestedBlockScoping! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleBlockNested
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleBlockNested) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleBlockNested! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - misc' stamp: ''!
testExamplePushArray
	| ir method newMethod instance |
	method := (OCOpalExamples >> #examplePushArray) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance examplePushArray! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - simple' stamp: ''!
testExampleReturn1
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleReturn42) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleReturn42! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - variables' stamp: ''!
testExampleiVar
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleiVar) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleiVar! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockArgument5
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockArgument5) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockArgument5! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockLocal
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockLocal) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockLocal! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleIfIfNotNilReturnNil
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleIfNotNilReturnNil) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleIfNotNilReturnNil! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleToDoArgument
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleToDoArgument) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleToDoArgument! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - simple' stamp: ''!
testExampleEmptyMethod
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleEmptyMethod) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleEmptyMethod! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleBlockExternalNested
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleBlockExternalNested) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleBlockExternalNested! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleBlockExternalArg
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleBlockExternalArg) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleBlockExternalArg! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleToDoOutsideTemp
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleToDoOutsideTemp) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleToDoOutsideTemp! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - misc' stamp: ''!
testExampleToDoValue
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleToDoValue) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleToDoValue! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleBlockExternal2
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleBlockExternal2) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleBlockExternal2! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleToDoInsideTemp
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleToDoInsideTemp) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleToDoInsideTemp! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleBlockArgument
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleBlockArgument) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleBlockArgument! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleToDoInsideTempNotInlined
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleToDoInsideTempNotInlined) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleToDoInsideTempNotInlined! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks-optimized' stamp: ''!
testExampleWhileWithTempNotInlined
	| ir method newMethod |
	method := (OCOpalExamples >> #exampleWhileWithTempNotInlined) parseTree generate.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: OCOpalExamples new arguments: #()) equals: OCOpalExamples new exampleWhileWithTempNotInlined! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockArgument2
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockArgument2) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockArgument2! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockNested
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockNested) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockNested! !

!OCBytecodeDecompilerExamplesTest methodsFor: 'tests - blocks' stamp: ''!
testExampleSimpleBlockArgument4
	| ir method newMethod instance |
	method := (OCOpalExamples >> #exampleSimpleBlockArgument4) parseTree generate.
	instance := OCOpalExamples new.

	ir := IRBytecodeDecompiler new decompile: method.
	newMethod := ir compiledMethod.

	self assert: (newMethod valueWithReceiver: instance arguments: #()) equals: instance exampleSimpleBlockArgument4! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testSendSuper
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testSendSuper.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testJumpBackTo
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testJumpBackTo.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testPushThisContext
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testPushThisContext.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests - examples' stamp: ''!
testDecompileBytecodeDecompilerTestClass
	| decompiledIR aCompiledMethod |
	self class methods
		do: [ :each | 
			decompiledIR := IRBytecodeDecompiler new decompile: each.
			aCompiledMethod := decompiledIR compiledMethod ]! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testPopTop
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testPopTop.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralVariableGlobale
	| ir1 ir2 method |
	ir1 := IRBuilderTest new setUp; testLiteralVariableGlobale.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests - examples' stamp: ''!
testDecompileBytecodeGeneratorTest
	| decompiledIR aCompiledMethod |
	OCBytecodeGeneratorTest methods
		do: [ :each | 
			decompiledIR := IRBytecodeDecompiler new decompile: each.
			aCompiledMethod := decompiledIR compiledMethod ]! !

!OCBytecodeDecompilerTest methodsFor: 'tests - examples' stamp: ''!
testDecompilerOrderedCollectionDo
	| cm decompiledIR |
	cm := OrderedCollection >> #do:.
	decompiledIR := IRBytecodeDecompiler new decompile: cm.
	decompiledIR compiledMethod! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testPushConsArray
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testPushConsArray.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests - examples' stamp: ''!
testWhileTrue
	| cm decompiledIR aCompiledMethod |
	cm := self class >> #testWhileTrue.
	decompiledIR := IRBytecodeDecompiler new decompile: cm.
	aCompiledMethod := decompiledIR compiledMethod! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralVariableClass
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testLiteralVariableClass.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralCharacter
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testLiteralCharacter.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testPushConsArray2
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testPushConsArray2.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralFloat
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testLiteralFloat.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralInteger
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testLiteralInteger.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testStoreTemp
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testStoreTemp.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	currentCompiler := SmalltalkImage compilerClass.
	SmalltalkImage compilerClass: OpalCompiler.! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testBugOffset
	| iRMethod aCompiledMethod ir method |
	iRMethod := IRBuilder new
		addTemps: #(#a #b);
		pushTemp: #b;
		pushTemp: #a;
		returnTop;
		ir.
	aCompiledMethod := iRMethod compiledMethod.
	ir := aCompiledMethod decompileIR.
	method := ir compiledMethod.
	self assert: aCompiledMethod symbolic equals: method symbolic! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralArray
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testLiteralArray.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralVariableClassVariable
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testLiteralVariableClassVariable.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'running' stamp: ''!
tearDown
	SmalltalkImage compilerClass: currentCompiler.
	super tearDown! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testPushTempTemp
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testPushTempTemp.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testReturnTop
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testReturnTop.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testStoreIntoVariable
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testStoreIntoVariable.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testDup
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testDup.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralNil
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testLiteralNil.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testInstVar
	| ir1 ir2 method method2 |
	ir1 := IRBuilderTest new testInstVar.
	method := ir1 compiledMethod.
	ir2 := method decompileIR.
	method2 := ir2 compiledMethod.
	self deny: method2 identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: method2 equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralSymbol
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testLiteralSymbol.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralString
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testLiteralString.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testLiteralBoolean
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testLiteralBoolean.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testPushSelf
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testPushSelf.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests - examples' stamp: ''!
testDecompileIRBuilderTestClass
	| decompiledIR aCompiledMethod |
	IRBuilderTest methods
		do: [ :each | 
			decompiledIR := IRBytecodeDecompiler new decompile: each.
			aCompiledMethod := decompiledIR compiledMethod ]! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testJumpAheadToIf
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testJumpAheadToIf.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testPushTempArgument
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testPushTempArgument.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod symbolic equals: method symbolic.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeDecompilerTest methodsFor: 'tests' stamp: ''!
testJumpAheadTo
	| ir1 ir2 method |
	ir1 := IRBuilderTest new testJumpAheadTo.
	method := ir1 compiledMethod.
	ir2 := IRBytecodeDecompiler new decompile: method.
	self deny: ir2 compiledMethod identicalTo: method.
	self assert: ir2 compiledMethod equals: method! !

!OCBytecodeGeneratorTest methodsFor: 'tests - execution' stamp: ''!
testExample2
	| cm |
	cm := self bytecodeGenerator
		numArgs: 1;
		numTemps: 1;
		pushInstVar: 2;
		pushTemp: 1;
		send: #<;
		if: false goto: #else;
		pushLiteral: 'yes';
		returnTop;
		label: #else;
		pushLiteral: 'no';
		returnTop;
		compiledMethod.

	self assert: (cm isKindOf: CompiledMethod).
	self assert: (cm valueWithReceiver: 2 @ 2 arguments: #(1)) equals: 'no'.
	self assert: (cm valueWithReceiver: 2 @ 2 arguments: #(3)) equals: 'yes'.
	^ cm! !

!OCBytecodeGeneratorTest methodsFor: 'tests - execution' stamp: ''!
testExample
	| cm |
	cm := self bytecodeGenerator
		numArgs: 1;
		numTemps: 1;
		pushTemp: 1;
		pushInstVar: 2;
		send: #>;
		if: false goto: #else;
		pushLiteral: 'yes';
		returnTop;
		label: #else;
		pushLiteral: 'no';
		returnTop;
		compiledMethod.
	cm methodClass: self class.
	cm selector: #test.

	self assert: (cm isKindOf: CompiledMethod).
	self assert: (cm valueWithReceiver: 2 @ 2 arguments: #(1)) equals: 'no'.
	self assert: (cm valueWithReceiver: 2 @ 2 arguments: #(3)) equals: 'yes'.
	^ cm! !

!OCBytecodeGeneratorTest methodsFor: 'helper' stamp: ''!
testMethod: cm against: string
	| symbolic |
	self assert: cm isCompiledMethod.
	symbolic := String streamContents: [ :str | cm longPrintOn: str ].
	self assert: symbolic equals: string! !

!OCBytecodeGeneratorTest methodsFor: 'helper' stamp: ''!
bytecodeGenerator
	^ IRBytecodeGenerator newWithEncoderClass: EncoderForSistaV1! !

!OCBytecodeGeneratorTest class methodsFor: 'accessing' stamp: ''!
packageNamesUnderTest
	^ #('OpalCompiler')! !

!OCBytecodeToASTCache commentStamp: ''!
I cache a mapping between possible bytecode offsets and the AST nodes they correspond to for a given compiled method.

Instanciate me using my class method generateForCompiledMethod: and give me as parameter a compiled method.

Use me through the node access API method nodeForPC: and give me a program counter as parameter.

I store: 
- firstBcOffset: The first bytecode pc. If you try to access a pc below that first pc, I return the method node.
- lastBcOffset: The last bytecode pc. If you try to access a pc after this last pc, I return the node associated with the last pc.
- bcToASTMap: A map associating each possible pc between firstBcOffset and lastBcOffset and the corresponding ast node.
- the methode node.!
!OCBytecodeToASTCache methodsFor: 'accessing' stamp: ''!
methodOrBlockNode
	^ methodOrBlockNode! !

!OCBytecodeToASTCache methodsFor: 'accessing' stamp: ''!
bcToASTMap
	^ bcToASTMap! !

!OCBytecodeToASTCache methodsFor: 'accessing' stamp: ''!
methodNode
	^ methodOrBlockNode! !

!OCBytecodeToASTCache methodsFor: 'accessing' stamp: ''!
firstBcOffset
	^ firstBcOffset! !

!OCBytecodeToASTCache methodsFor: 'initialization' stamp: ''!
generateForNode: aNode
	| methodOrBlockIr currentBcOffset |
	methodOrBlockNode := aNode.
	methodOrBlockIr := aNode ir.
	bcToASTMap := Dictionary new.
	firstBcOffset := methodOrBlockIr compiledMethod initialPC.

	"if there is a primitive, we need to record the offset"
	(methodOrBlockIr irPrimitive num ~= 0
		or: [ methodOrBlockIr compiledMethod isQuick ])
		ifTrue: [ bcToASTMap at: firstBcOffset put: methodOrBlockNode ]. 

	currentBcOffset := firstBcOffset.
	methodOrBlockIr startSequence withAllSuccessors
		do: [ :seq | 
			seq
				do: [ :ir | 
					ir
						ifNotNil: [ bcToASTMap at: ir bytecodeOffset ifAbsentPut: [ ir sourceNode ].
							currentBcOffset := ir bytecodeOffset + 1 ] ] ].
	lastBcOffset := currentBcOffset - 1.
	self fillMissingBCOffsetsWithLastBCOffsetNodes! !

!OCBytecodeToASTCache methodsFor: 'node access' stamp: ''!
nodeForPC: pc
	pc < firstBcOffset ifTrue: [ ^ methodOrBlockNode ].
	pc > lastBcOffset ifTrue: [ ^ bcToASTMap at: lastBcOffset ].
	^ bcToASTMap at: pc! !

!OCBytecodeToASTCache methodsFor: 'accessing' stamp: ''!
lastBcOffset
	^ lastBcOffset! !

!OCBytecodeToASTCache methodsFor: 'private' stamp: ''!
fillMissingBCOffsetsWithLastBCOffsetNodes
	 "It happens that different bytecode offsets map to the same AST node.
	These cases are detected when there is no node mapped between, for example, bcOffset 46 and bcOffset 50.
	In that case, we take every possible bytecode index between 46 and 50 (i.e., 47, 48, 49),
	and we map them to the same node as the last mapped bytecode offset, here 46.
	
	When a fullblocks is the first node in a method body, it is possible (when?) the offsets do not start at the first offset of the method (why?). 
	In that case, we also fix the missing offsets by mapping to them the first mapped node."

	 | sortedBCOffsets |
	 sortedBCOffsets := bcToASTMap keys asSortedCollection.
	 sortedBCOffsets first = firstBcOffset ifFalse: [ 
		 firstBcOffset to: sortedBCOffsets first - 1 do: [ :offset | 
			 bcToASTMap at: offset put: (bcToASTMap at: sortedBCOffsets first) ] ].
	 1 to: sortedBCOffsets size - 1 do: [ :index | 
		 | bcAtIndex bcAtNextIndex |
		 bcAtIndex := sortedBCOffsets at: index.
		 bcAtNextIndex := sortedBCOffsets at: index + 1.
		 bcAtIndex < bcAtNextIndex ifTrue: [ 
			 bcAtIndex to: bcAtNextIndex - 1 do: [ :i | 
			 bcToASTMap at: i put: (bcToASTMap at: bcAtIndex) ] ] ]! !

!OCBytecodeToASTCache class methodsFor: 'initialization' stamp: ''!
generateForNode: aNode
	^self new generateForNode: aNode! !

!OCBytecodeToASTCacheTest methodsFor: 'tests' stamp: ''!
testFirstBCOffsetWithBlock
	compiledMethod := (MethodMapExamples >> #helperMethod14:).
	cache := OCBytecodeToASTCache generateForNode: compiledMethod ast.	
	self assert: (cache nodeForPC: cache firstBcOffset) identicalTo: compiledMethod ast statements first receiver! !

!OCBytecodeToASTCacheTest methodsFor: 'tests' stamp: ''!
testHigherThanLastBCOffsetAccessTest
	| pc |
	pc := cache lastBcOffset + 5.
	"if we are beyond the last bc, we map to the whole method"
	self
		assert: (cache nodeForPC: pc)
		identicalTo: compiledMethod ast! !

!OCBytecodeToASTCacheTest methodsFor: 'tests' stamp: ''!
testLastBCOffsetTest
	self
		assert: cache lastBcOffset
		equals:
			compiledMethod ast ir startSequence withAllSuccessors last last
				bytecodeOffset! !

!OCBytecodeToASTCacheTest methodsFor: 'tests' stamp: ''!
testLowerThanFirstBCOffsetAccessTest
	self
		testCacheInInterval: (0 to: cache firstBcOffset - 1)
		equalsNode: compiledMethod ast! !

!OCBytecodeToASTCacheTest methodsFor: 'tests' stamp: ''!
testNodeForBCOffsetTest
	| pc mappedNode expectedNode |
	self flag: #TODO. "we skip for now on 32 bit"
	Smalltalk vm is32bit ifTrue: [ self skip ]. 
	pc := 50.
	mappedNode := (cache nodeForPC: pc).
	expectedNode := compiledMethod ast statements second arguments first statements first.
	self assert: mappedNode sourceCode equals: expectedNode sourceCode.	
	self assert: mappedNode start equals: expectedNode start.
	self assert: mappedNode stop equals: expectedNode stop! !

!OCBytecodeToASTCacheTest methodsFor: 'tests' stamp: ''!
testFirstBCOffsetTest
	self assert: cache firstBcOffset equals: compiledMethod initialPC! !

!OCBytecodeToASTCacheTest methodsFor: 'tests' stamp: ''!
testFirstBCOffsetWithQuickReturn
	compiledMethod := ( MethodMapExamples >> #ivar).
	cache := OCBytecodeToASTCache generateForNode: compiledMethod ast.	
	self assert: cache firstBcOffset equals: compiledMethod initialPC.
	self assert: (cache nodeForPC: cache firstBcOffset) identicalTo: compiledMethod ast.
	self assert: (cache nodeForPC: cache lastBcOffset) identicalTo: compiledMethod ast statements last.

	cache firstBcOffset to: cache lastBcOffset - 1 do:[:pc|
		self assert: (cache nodeForPC: pc) identicalTo: compiledMethod ast].! !

!OCBytecodeToASTCacheTest methodsFor: 'helpers' stamp: ''!
testCacheInInterval: interval equalsNode: aNode
	interval do: [ :i | 
		self assert: (cache nodeForPC: i) identicalTo: aNode ]! !

!OCBytecodeToASTCacheTest methodsFor: 'tests' stamp: ''!
testCachedMethodNode
	self assert: cache methodOrBlockNode identicalTo: compiledMethod ast! !

!OCBytecodeToASTCacheTest methodsFor: 'tests' stamp: ''!
testNodeForBCOffsetTestFull
	| pc mappedNode expectedNode blockNode |
	self flag: #TODO. "we skip for now on 32 bit"
	Smalltalk vm is32bit ifTrue: [ self skip ]. 
	compiledMethod := MethodMapExamples >> #helperMethod13.
	
	"this is a test for full blocks only"
	blockNode := compiledMethod ast statements last value.
	pc := 27.
	mappedNode := (blockNode sourceNodeForPC: pc).
	expectedNode := blockNode body.
	self assert: mappedNode sourceCode equals: expectedNode sourceCode.	
	self assert: mappedNode start equals: expectedNode start.
	self assert: mappedNode stop equals: expectedNode stop! !

!OCBytecodeToASTCacheTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
	super setUp.	
	compiledMethod := MethodMapExamples >> #helperMethod12.
	cache := OCBytecodeToASTCache generateForNode: compiledMethod ast! !

!OCCleanBlockTest methodsFor: 'tests' stamp: ''!
testBlockIsClean
	self assert: [  ] sourceNode isClean.
	self assert: [ thisContext ] sourceNode isClean.
	self assert: [ 1 + 2 ] sourceNode isClean.
	self assert: [ :a | a + 2 ] sourceNode isClean.
	self assert: [ :a :b | a + b + 3 ] sourceNode isClean.
	self assert: [ | a | a := 1. a + 3 ] sourceNode isClean.! !

!OCCleanBlockTest methodsFor: 'tests' stamp: ''!
testBlockIsNotClean
	| escpWrite escpRead |
	escpRead := escpWrite := 1.
	self deny: [ self foo ] sourceNode isClean.
	self deny: [ ^ 1 ] sourceNode isClean.
	self deny: [ instVar foo ] sourceNode isClean.
	self deny: [ escpRead foo ] sourceNode isClean.
	self deny: [ escpWrite := 2 ] sourceNode isClean.
	 
	self deny: [[ self foo ]] sourceNode isClean.
	self deny: [[ ^ 1 ]] sourceNode isClean.
	self deny: [[ instVar foo ]] sourceNode isClean.
	self deny: [[ escpRead foo ]] sourceNode isClean.
	self deny: [[ escpWrite := 2 ]] sourceNode isClean.! !

!OCClosureCompilerTest methodsFor: 'running' stamp: ''!
tearDown
	SmalltalkImage compilerClass: currentCompiler.
	super tearDown! !

!OCClosureCompilerTest methodsFor: 'tests' stamp: ''!
testDebuggerTempAccess
	self doTestDebuggerTempAccessWith: 1 with: 2! !

!OCClosureCompilerTest methodsFor: 'tests' stamp: ''!
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 equals: (1 to: 11) asArray! !

!OCClosureCompilerTest methodsFor: 'source' stamp: ''!
closureCases
	^#(
'| n |
n := 1.
^n + n'

'[:c :s| | mn |
mn := Compiler new
		compile: (c sourceCodeAt: s)
		in: c
		notifying: nil
		ifFail: [self halt].
mn generate: #(0 0 0 0).
{mn blockExtentsToTempsMap.
  mn encoder schematicTempNames}]
			value: AbstractInstructionTests
			value: #runBinaryConditionalJumps:'

'inject: thisValue into: binaryBlock
	| nextValue |
	nextValue := thisValue.
	self do: [:each | nextValue := binaryBlock value: nextValue value: each].
	^nextValue'

'mapFromBlockStartsIn: aMethod toTempVarsFrom: schematicTempNamesString constructor: aDecompilerConstructor
	| map |
	map := aMethod
				mapFromBlockKeys: aMethod startpcsToBlockExtents keys asSortedCollection
				toSchematicTemps: schematicTempNamesString.
	map keysAndValuesDo:
		[:startpc :tempNameTupleVector| | subMap tempVector numTemps |
		subMap := Dictionary new.
		tempNameTupleVector do:
			[:tuple|
			tuple last isArray
				ifTrue:
					[subMap at: tuple last first put: tuple last last.
					 numTemps := tuple last first]
				ifFalse:
					[numTemps := tuple last]].
		tempVector := Array new: numTemps.
		subMap keysAndValuesDo:
			[:index :size|
			tempVector at: index put: (Array new: size)].
		tempNameTupleVector do:
			[:tuple| | itv |
			tuple last isArray
				ifTrue:
					[itv := tempVector at: tuple last first.
					 itv at: tuple last last
						put: (aDecompilerConstructor
								codeTemp: tuple last last - 1
								named: tuple first)]
				ifFalse:
					[tempVector
						at: tuple last
						put: (aDecompilerConstructor
								codeTemp: tuple last - 1
								named: tuple first)]].
		subMap keysAndValuesDo:
			[:index :size|
			tempVector
				at: index
				put: (aDecompilerConstructor
						codeRemoteTemp: index
						remoteTemps: (tempVector at: index))].
		map at: startpc put: tempVector].
	^map'

 'gnuifyFrom: inFileStream to: outFileStream

	| inData beforeInterpret inInterpret inInterpretVars beforePrimitiveResponse inPrimitiveResponse |

	inData := inFileStream upToEnd withSqueakLineEndings.
	inFileStream close.

	outFileStream
		nextPutAll: ''/* This file has been post-processed for GNU C */'';
		cr; cr; cr.

	beforeInterpret := true.    "whether we are before the beginning of interpret()"
	inInterpret := false.     "whether we are in the middle of interpret"
	inInterpretVars := false.    "whether we are in the variables of interpret"
	beforePrimitiveResponse := true.  "whether we are before the beginning of primitiveResponse()"
	inPrimitiveResponse := false.   "whether we are inside of primitiveResponse"
	''Gnuifying''
		displayProgressAt: Sensor cursorPoint
		from: 1 to: (inData occurrencesOf: Character cr)
		during:
			[:bar | | lineNumber |
			lineNumber := 0.
			inData linesDo:
				[ :inLine | | outLine extraOutLine caseLabel |
				bar value: (lineNumber := lineNumber + 1).
				outLine := inLine. 	"print out one line for each input line; by default, print out the line that was input, but some rules modify it"
				extraOutLine := nil.   "occasionally print a second output line..."
				beforeInterpret ifTrue: [
					inLine = ''#include "sq.h"'' ifTrue: [
						outLine := ''#include "sqGnu.h"'' ].
					inLine = ''interpret(void) {'' ifTrue: [
						"reached the beginning of interpret"
						beforeInterpret := false.
						inInterpret := true.
						inInterpretVars := true ] ]
				ifFalse: [
				inInterpretVars ifTrue: [
					(inLine findString: ''register struct foo * foo = &fum;'') > 0 ifTrue: [
						outLine := ''register struct foo * foo FOO_REG = &fum;'' ].
					(inLine findString: '' localIP;'') > 0 ifTrue: [
						outLine := ''    char* localIP IP_REG;'' ].
					(inLine findString: '' localFP;'') > 0 ifTrue: [
						outLine := ''    char* localFP FP_REG;'' ].
					(inLine findString: '' localSP;'') > 0 ifTrue: [
						outLine := ''    char* localSP SP_REG;'' ].
					(inLine findString: '' currentBytecode;'') > 0 ifTrue: [
						outLine := ''    sqInt currentBytecode CB_REG;'' ].
					inLine isEmpty ifTrue: [
						"reached end of variables"
						inInterpretVars := false.
						outLine := ''    JUMP_TABLE;''.
						extraOutLine := inLine ] ]
				ifFalse: [
				inInterpret ifTrue: [
					"working inside interpret(); translate the switch statement"
					(inLine beginsWith: ''		case '') ifTrue: [
						caseLabel := (inLine findTokens: ''	 :'') second.
						outLine := ''		CASE('', caseLabel, '')'' ].
					inLine = ''			break;'' ifTrue: [
						outLine := ''			BREAK;'' ].
					inLine = ''}'' ifTrue: [
						"all finished with interpret()"
						inInterpret := false ] ]
				ifFalse: [
				beforePrimitiveResponse ifTrue: [
					(inLine beginsWith: ''primitiveResponse('') ifTrue: [
						"into primitiveResponse we go"
						beforePrimitiveResponse := false.
						inPrimitiveResponse := true.
						extraOutLine := ''    PRIM_TABLE;'' ] ]
				ifFalse: [
				inPrimitiveResponse ifTrue: [
					inLine = ''	switch (primitiveIndex) {'' ifTrue: [
						extraOutLine := outLine.
						outLine := ''	PRIM_DISPATCH;'' ].
					inLine = ''	switch (GIV(primitiveIndex)) {'' ifTrue: [
						extraOutLine := outLine.
						outLine := ''	PRIM_DISPATCH;'' ].
					(inLine beginsWith: ''	case '') ifTrue: [
						caseLabel := (inLine findTokens: ''	 :'') second.
						outLine := ''	CASE('', caseLabel, '')'' ].
					inLine = ''}'' ifTrue: [
						inPrimitiveResponse := false ] ]
				] ] ] ].

				outFileStream nextPutAll: outLine; cr.
				extraOutLine ifNotNil: [
					outFileStream nextPutAll: extraOutLine; cr ]]].

	outFileStream close' )! !

!OCClosureCompilerTest methodsFor: 'running' stamp: ''!
evaluate: aString in: aContext to: anObject
	^self class compiler source: aString;
		context: aContext;
		receiver: anObject;
		evaluate! !

!OCClosureCompilerTest methodsFor: 'tests' stamp: ''!
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 equals: (1 to: 11) asArray! !

!OCClosureCompilerTest methodsFor: 'tests' stamp: ''!
testOptimizedBlockLocalNilling1
	"Whether a block is optimized or not a block-local temp
	 should be nil at the start of each evaluation of the block."

	1 to: 3 do: [:i| | j |
		self assert: j isNil.
		j := i + 1.
		self assert: j isNil not]! !

!OCClosureCompilerTest methodsFor: 'tests' stamp: ''!
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 equals: (2 to: 12) asArray! !

!OCClosureCompilerTest methodsFor: 'tests' stamp: ''!
doTestDebuggerTempAccessWith: one with: two
	"Test debugger access for temps"

	| outerContext local1 remote1 |
	outerContext := thisContext.
	local1 := 3.
	remote1 := 1 / 2.
	self assert: (self evaluate: 'one' in: thisContext to: self) identicalTo: one.
	self assert: (self evaluate: 'two' in: thisContext to: self) identicalTo: two.
	self assert: (self evaluate: 'local1' in: thisContext to: self) identicalTo: local1.
	self assert: (self evaluate: 'remote1' in: thisContext to: self) identicalTo: remote1.
	self evaluate: 'local1 := -3.0' in: thisContext to: self.
	self assert: local1 equals: -3.0.
	(1 to: 2)
		do: [ :i | 
			| local2 r1 r2 r3 r4 |
			local2 := i * 3.
			remote1 := local2 / 7.
			self assert: thisContext ~~ outerContext.
			self assert: (r1 := self evaluate: 'one' in: thisContext to: self) identicalTo: one.
			self assert: (r2 := self evaluate: 'two' in: thisContext to: self) identicalTo: two.
			self assert: (r3 := self evaluate: 'i' in: thisContext to: self) identicalTo: i.
			self assert: (r4 := self evaluate: 'local2' in: thisContext to: self) identicalTo: local2.
			self assert: (r4 := self evaluate: 'remote1' in: thisContext to: self) identicalTo: remote1.
			self assert: (r4 := self evaluate: 'remote1' in: outerContext to: self) identicalTo: remote1.
			self evaluate: 'local2 := 15' in: thisContext to: self.
			self assert: local2 equals: 15.
			self evaluate: 'local1 := 25' in: thisContext to: self.
			self assert: local1 equals: 25.
			{r1 . r2 . r3 . r4}	"placate the compiler" ].
	self assert: local1 equals: 25.
	"this is 25 even though the var is a local, non escaping variable that was copied into the block.
	But the DoIt compiles temp acces using #tempAt:put:, which updates the copies and the original"
	self assert: remote1 equals: 6 / 7! !

!OCClosureCompilerTest methodsFor: 'tests' stamp: ''!
testOptimizedBlockLocalNilling2
	"Whether a block is optimized or not a block-local temp
	 should be nil at the start of each evaluation of the block."

	1 to: 6 do: [:i| | j k |
		self assert: j isNil.
		self assert: k isNil.
		i even
			ifTrue: [j := i + 2]
			ifFalse: [k := i + 1].
		self assert: (j isNil or: [k isNil]).
		self assert: (j isNil not or: [k isNil not])]! !

!OCClosureCompilerTest methodsFor: 'tests' stamp: ''!
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 equals: b2! !

!OCClosureCompilerTest methodsFor: 'tests' stamp: ''!
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 equals: b2! !

!OCClosureCompilerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	currentCompiler := SmalltalkImage compilerClass.
	SmalltalkImage compilerClass: OpalCompiler.! !

!OCClosureCompilerTest class methodsFor: 'code examples' stamp: ''!
methodWithCopiedTemps
	| a b c r |
	a := 1.
	b := 2.
	c := 4.
	r := [a + b + c] value.
	b := nil.
	r

	"Parser new
		parse: (self class sourceCodeAt: #methodWithCopiedTemps)
		class: self class"

	"(Parser new
		encoderClass: EncoderForV3;
		parse: (self class sourceCodeAt: #methodWithCopiedTemps)
		class: self class) generateUsingClosures: #(0 0 0 0)"! !

!OCClosureCompilerTest class methodsFor: 'code examples' stamp: ''!
methodWithOptimizedBlocks
	| s c |
	s := self isNil
			ifTrue: [| a | a := 'isNil'. a]
			ifFalse: [| b | b := 'notNil'. b].
	c := String new: s size.
	1 to: s size do:
		[:i| c at: i put: (s at: i)].
	^c

	"Parser new
		parse: (self class sourceCodeAt: #methodWithOptimizedBlocks)
		class: self class"! !

!OCClosureCompilerTest class methodsFor: 'code examples' stamp: ''!
methodWithOptimizedBlocksA
	| s c |
	s := self isNil
			ifTrue: [| a | a := 'isNil'. a]
			ifFalse: [| a | a := 'notNil'. a].
	c := String new: s size.
	1 to: s size do:
		[:i| c at: i put: (s at: i)].
	^c

	"Parser new
		parse: (self class sourceCodeAt: #methodWithOptimizedBlocksA)
		class: self class"! !

!OCClosureCompilerTest class methodsFor: 'code examples' stamp: ''!
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)"! !

!OCClosureCompilerTest class methodsFor: 'code examples' stamp: ''!
methodWithCopiedAndAssignedTemps
	| blk "0w" a "0w" b "0w" c "0w" t "0w" r1 "0w" r2 "0w" |
	a := 1. "1w"
	b := 2. "1w"
	c := 4. "1w"
	t := 0. "1w"
	blk "5w" := ["2" t  "3w" := t "3r" + a "3r" + b "3r" + c "3r" ] "4".
	r1 "5w" := blk "5r" value.
	b "5w" := -100.
	r2 "5w" := blk "5r" value.
	^r1 "5r" -> r2 "5r" -> t "5r"

	"a: main(read(),write(0,1)), block(read(3),write()) => copy; no writes follow read
	 b: main(read(),write(0,1,5)), block(read(3),write()) => remote; write follows contained read
	 blk: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5
	 c: main(read(),write(0,1)), block(read(3),write()) => copy; no writes follow read
	 r1: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5
	 r2: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5
	 t: main(read(5),write(0,1)), block(read(3),write(3)) => remote; read follows contained write"


	"(Parser new
		encoderClass: EncoderForV3;
		parse: (self class sourceCodeAt: #methodWithCopiedAndAssignedTemps)
		class: self class) generateUsingClosures: #(0 0 0 0)"! !

!OCClosureCompilerTest class methodsFor: 'accessing' stamp: ''!
compilerClass
	^OpalCompiler! !

!OCClosureCompilerTest class methodsFor: 'code examples' stamp: ''!
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"! !

!OCClosureTest methodsFor: 'tests - while' stamp: ''!
testWhileModificationAfter
	| index |
	index := 0.
	[ index < 5 ] whileTrue: [
		collection add: [ index ].
		index := index + 1 ].
	self assertValues: #(5 5 5 5 5)! !

!OCClosureTest methodsFor: 'tests - while' stamp: ''!
testWhileModificationBefore
	| index |
	index := 0.
	[ index < 5 ] whileTrue: [ 
		index := index + 1.
		collection add: [ index ] ].
	self assertValues: #(5 5 5 5 5)! !

!OCClosureTest methodsFor: 'tests - while' stamp: ''!
testWhileModificationBeforeNotInlined
	| index block |
	index := 0.
	block := [ 
		index := index + 1.
		collection add: [ index ] ].
	[ index < 5 ] whileTrue: block.
	self assertValues: #(5 5 5 5 5)! !

!OCClosureTest methodsFor: 'tests' stamp: ''!
methodArgument: anObject
	^ [ anObject ]! !

!OCClosureTest methodsFor: 'tests - empty' stamp: ''!
testEmptyBlockTwoArguments
	self
		assert: (self class compiler evaluate: '[ :a :b ] value: 1 value: 2') isNil
		description: 'Empty blocks in ST-80 should return nil'.
	self
		assert: (self class compiler evaluate: '[ :a :b | ] value: 1 value: 2') isNil
		description: 'Empty blocks in ST-80 should return nil'.
	self
		assert: (self class compiler evaluate: '[ :a :b | | t | ] value: 1 value: 2') isNil
		description: 'Empty blocks in ST-80 should return nil'! !

!OCClosureTest methodsFor: 'tests - empty' stamp: ''!
testEmptyBlockZeroArguments
	self
		assert: (self class compiler evaluate: '[ ] value') isNil
		description: 'Empty blocks in ST-80 should return nil'.
	self
		assert: (self class compiler evaluate: '[ | t | ] value') isNil
		description: 'Empty blocks in ST-80 should return nil'! !

!OCClosureTest methodsFor: 'tests' stamp: ''!
testMethodTemp
	| block1 block2 |
	block1 := self methodArgument: 1.
	block2 := self methodArgument: 2.
	self assert: block1 value equals: 1.
	self assert: block2 value equals: 2! !

!OCClosureTest methodsFor: 'tests - while' stamp: ''!
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)! !

!OCClosureTest methodsFor: 'tests - while' stamp: ''!
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)! !

!OCClosureTest methodsFor: 'tests' stamp: ''!
testMethodArgument
	| temp block |
	temp := 0.
	block := [ [ temp ] ].
	temp := 1.
	block := block value.
	temp := 2.
	self assert: block value equals: 2! !

!OCClosureTest methodsFor: 'tests - todo' stamp: ''!
testToDoOutsideTemp
	| temp |
	1 to: 5 do: [ :index | 
		temp := index. 
		collection add: [ temp ] ].
	self assertValues: #(5 5 5 5 5)! !

!OCClosureTest methodsFor: 'tests - todo' stamp: ''!
testToDoInsideTempNotInlined
	| block |
	block := [ :index | 
		| temp | 
		temp := index. 
		collection add: [ temp ] ].
	1 to: 5 do: block.
	self assertValues: #(1 2 3 4 5)! !

!OCClosureTest methodsFor: 'utilities' stamp: ''!
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]! !

!OCClosureTest methodsFor: 'tests - empty' stamp: ''!
testEmptyBlockOneArgument
	self
		assert: (self class compiler evaluate: '[ :a ] value: 1') isNil
		description: 'Empty blocks in ST-80 should return nil'.
	self
		assert: (self class compiler evaluate: '[ :a | ] value: 1') isNil
		description: 'Empty blocks in ST-80 should return nil'.
	self
		assert: (self class compiler evaluate: '[ :a | | t | ] value: 1') isNil
		description: 'Empty blocks in ST-80 should return nil'! !

!OCClosureTest methodsFor: 'tests - todo' stamp: ''!
testToDoArgumentNotInlined
	| block |
	block := [ :index |
		collection add: [ index ] ].
	1 to: 5 do: block.
	self assertValues: #(1 2 3 4 5)! !

!OCClosureTest methodsFor: 'tests - todo' stamp: ''!
testToDoOutsideTempNotInlined
	| block temp |
	block := [ :index | 
		temp := index. 
		collection add: [ temp ] ].
	1 to: 5 do: block.
	self assertValues: #(5 5 5 5 5)! !

!OCClosureTest methodsFor: 'tests - while' stamp: ''!
testWhileWithTemp
	| index |
	index := 0.
	[ index < 5 ] whileTrue: [
		| temp |
		temp := index := index + 1.
		collection add: [ temp ] ].
	self assertValues: #(1 2 3 4 5)! !

!OCClosureTest methodsFor: 'tests' stamp: ''!
testBlockArgument
	| block block1 block2 |
	block := [ :arg | 
	| temp |
	temp := arg.
	[ temp ] ].
	block1 := block value: 1.
	block2 := block value: 2.
	self assert: block1 value equals: 1.
	self assert: block2 value equals: 2! !

!OCClosureTest methodsFor: 'tests - todo' stamp: ''!
testToDoInsideTemp
	1 to: 5 do: [ :index | 
		| temp | 
		temp := index. 
		collection add: [ temp ] ].
	self assertValues: #(1 2 3 4 5)! !

!OCClosureTest methodsFor: 'tests' stamp: ''!
testBlockTemps
	| block block1 block2 |
	"Regression test: Bytecode offset of IR was to last byte of IR node, which for blocks include temp initialization bytes. This caused scan for block creation bytecode to fail when there were many block temps, and no source node to be found."
	block := [ :arg | 
	| a b c d e f g |
	a := b := c := d := e := f := g := arg.
	[ a ] ].
	self assert: block sourceNode isBlock.
	self assert: block argumentNames equals: #(#arg).
	block1 := block value: 1.
	block2 := block value: 2.
	self assert: block1 value equals: 1.
	self assert: block2 value equals: 2! !

!OCClosureTest methodsFor: 'tests - while' stamp: ''!
testWhileModificationAfterNotInlined
	| index block |
	index := 0.
	block := [ 
		collection add: [ index ].
		index := index + 1 ].
	[ index < 5 ] whileTrue: block.
	self assertValues: #(5 5 5 5 5)! !

!OCClosureTest methodsFor: 'tests' stamp: ''!
testBlockTemp
	| block block1 block2 |
	block := [ :arg | [ arg ] ].
	block1 := block value: 1.
	block2 := block value: 2.
	self assert: block1 value equals: 1.
	self assert: block2 value equals: 2! !

!OCClosureTest methodsFor: 'tests - todo' stamp: ''!
testToDoArgument
	1 to: 5 do: [ :index |
		collection add: [ index ] ].
	self assertValues: #(1 2 3 4 5)! !

!OCClosureTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	collection := OrderedCollection new! !

!OCCompileWithFailureTest commentStamp: ''!
I have tests for the curious capability of Opal to compile code with syntax errors.

Instead of raising syntax errors at runtime, they are raised at compile time.

!
!OCCompileWithFailureTest methodsFor: 'interactive error protocol' stamp: ''!
notify: aMessage at: positon in: object
	"ingnore, for testEmptyBlockArg"! !

!OCCompileWithFailureTest methodsFor: 'tests' stamp: ''!
testEvalSimpleMethodWithError
	| ast cm |
	ast := OpalCompiler new
				source: 'method 3+';
				options: #(+ optionParseErrors);
				parse.
	
	self assert: ast isMethod.
	self assert: ast isFaulty.
	
	cm := ast compiledMethod.
	self should: [cm valueWithReceiver: nil arguments: #()] raise: RuntimeSyntaxError! !

!OCCompileWithFailureTest methodsFor: 'tests' stamp: ''!
testEmptyBlockArg
	| result | 
	"parse [:] in parse error mode, this results in arg vars with an empty string as a name"
	result := UndefinedObject compiler
    source: '^[ :]';
    noPattern: true;
    options:  #(+ optionParseErrors + optionSkipSemanticWarnings);
    requestor: self;
    parse. 
	self assert: result isReturn! !

!OCCompiledMethodIntegrityTest methodsFor: 'tests' stamp: ''!
testNotUsedArgument
	| newCompiledMethod |
	newCompiledMethod := OpalCompiler new
		source:
			'ascentOf: aCharacter
											^ self ascent.';
		class: OCMockCompilationClass;
		compile.

	self assert: newCompiledMethod numArgs equals: 1.
	self assert: newCompiledMethod numLiterals equals: 3.
	self assert: newCompiledMethod numTemps equals: 1.
	self assert: newCompiledMethod primitive equals: 0! !

!OCCompiledMethodIntegrityTest methodsFor: 'tests' stamp: ''!
testUndeclaredVariable
	| newCompiledMethod undeclaredBinding |
	newCompiledMethod := OpalCompiler new
		source:
			'methodWithUndeclaredVar
											^ undeclaredTestVar';
		class: OCMockCompilationClass;
		compile.

	undeclaredBinding := newCompiledMethod literals detect: [ :each | each name = #undeclaredTestVar ].
	self assert: undeclaredBinding class equals: UndeclaredVariable.
	self assert: undeclaredBinding identicalTo: (Undeclared associationAt: #undeclaredTestVar).
	undeclaredBinding unregister! !

!OCCompiledMethodIntegrityTest methodsFor: 'tests' stamp: ''!
testUndeclaredVariableWhenItIsAlreadyRegisteredAsAssociation
	"Test describes current state of bootstrap where undeclared vars are encoded using associations.
	It breaks introduced logic which explicitly return existing variable from Undeclared registry. 
	Compiler parts expect kind of variable and not a simple association.
	The bootstrap will be updated at some point. But now this case needs to be supported: 
		- declaring undefined var should update registered variable when its type is not undeclared var"
	| newCompiledMethod undeclaredBinding |
	Undeclared add: #undeclaredTestVar -> nil.
	newCompiledMethod := OpalCompiler new
		source:
			'methodWithUndeclaredVar
											^ undeclaredTestVar';
		class: OCMockCompilationClass;
		compile.

	undeclaredBinding := newCompiledMethod literals detect: [ :each | each name = #undeclaredTestVar ].
	self assert: undeclaredBinding class equals: UndeclaredVariable.
	self assert: undeclaredBinding identicalTo: (Undeclared associationAt: #undeclaredTestVar).
	undeclaredBinding unregister! !

!OCCompiledMethodIntegrityTest methodsFor: 'tests' stamp: ''!
testRemoteTempInVector
	| newCompiledMethod |
	newCompiledMethod := OpalCompiler new
		source:
			'value
													    | answer |
 													   self do:
       														 [:each |
        															answer := each value].
   													 ^answer';
		class: Object;
		compile.

	self assert: newCompiledMethod numArgs equals: 0.
	self assert: newCompiledMethod numLiterals equals: 3.
	self assert: newCompiledMethod numTemps equals: 1.
	self assert: newCompiledMethod primitive equals: 0! !

!OCCompiledMethodIntegrityTest methodsFor: 'tests' stamp: ''!
testUndeclaredVariableWhenItIsAlreadyRegistered
	| newCompiledMethod undeclaredBinding var |
	var := UndeclaredVariable registeredWithName: #undeclaredTestVar.
	newCompiledMethod := OpalCompiler new
		source:
			'methodWithUndeclaredVar
											^ undeclaredTestVar';
		class: OCMockCompilationClass;
		compile.

	undeclaredBinding := newCompiledMethod literals detect: [ :each | each name = #undeclaredTestVar ].
	self assert: undeclaredBinding identicalTo: var.
	undeclaredBinding unregister! !

!OCCompiledMethodIntegrityTest methodsFor: 'tests' stamp: ''!
testPragmas
	| newCompiledMethod |
	newCompiledMethod := OpalCompiler new
		source:
			'methodDoublePragma
											<hello: 5>
											<hello: 2>';
		class: OCMockCompilationClass;
		compile.

	self assert: newCompiledMethod numArgs equals: 0.
	self assert: newCompiledMethod numLiterals equals: 2.

	"AdditionalState assertions"
	self assert: newCompiledMethod allLiterals first selector equals: #methodDoublePragma.
	self assert: (newCompiledMethod allLiterals first instVarNamed: 'method') equals: newCompiledMethod.

	self assert: newCompiledMethod primitive equals: 256! !

!OCCompiledMethodIntegrityTest methodsFor: 'tests' stamp: ''!
testPrimitive
	| newCompiledMethod |
	newCompiledMethod := OpalCompiler new
		source:
			'size
											<primitive: 62>
											^ self basicSize.';
		class: OCMockCompilationClass;
		compile.

	self assert: newCompiledMethod numArgs equals: 0.
	self assert: newCompiledMethod numLiterals equals: 3.
	self assert: newCompiledMethod numTemps equals: 0.
	self assert: newCompiledMethod primitive equals: 62! !

!OCCompiledMethodIntegrityTest methodsFor: 'tests' stamp: ''!
testBlockTemps
	| newCompiledMethod |
	newCompiledMethod := OpalCompiler new
		source:
			'ascentOf: aCharacter
											^ [ | temp1 temp2 temp3 | 1= temp1. 2 = temp2. 3 = temp3].';
		class: OCMockCompilationClass;
		compile.

	self assert: newCompiledMethod numArgs equals: 1.
	self assert: (newCompiledMethod numLiterals = 3 or: [ newCompiledMethod numLiterals = 4	"Sista Bytecode" ]).
	self assert: newCompiledMethod numTemps equals: 1.
	self assert: newCompiledMethod primitive equals: 0! !

!OCCompilerASTPlugin commentStamp: ''!
I am an abtract superclass for compiler plugins.

The compiler consists of multiple passes:

source 
	- [ Scanner/Parser ]  -> 
AST 
	- [ SemCheck ] -> 
AST   <<HERE>>
	- [ ASTTranslator ] -> 
IR 
	- [ IRBuilder ] ->
 CompiledMethod


These plugins are called <<HERE>>, that is, after semantic analysis before generating the IR.
They are sorted by #priority and handed the AST without making a copy (as plugins might just analyse the AST). If you modify the AST, you have to make a copy before!!

!
!OCCompilerASTPlugin methodsFor: 'accessing' stamp: ''!
ast: anAst
	ast := anAst! !

!OCCompilerASTPlugin methodsFor: 'api' stamp: ''!
transform
	"Plugins override this method. If you modify the AST, make sure to copy it before!!"
	self subclassResponsibility.! !

!OCCompilerASTPlugin methodsFor: 'api' stamp: ''!
priority
	^100 "default. Priority 0 is used by Reflectivity to be the last"! !

!OCCompilerASTPlugin methodsFor: 'api' stamp: ''!
transform: anRBMethodNode
	ast := anRBMethodNode.
	self transform.
	^ast.! !

!OCCompilerASTPlugin class methodsFor: 'private' stamp: ''!
priority
	self subclassResponsibility! !

!OCCompilerASTPlugin class methodsFor: 'instance creation' stamp: ''!
transform: ast
	^self new transform: ast! !

!OCCompilerDynamicASTPlugin commentStamp: ''!
Look at the OCCompilerASTPlugin class comment for information about compiler plugins.

I allow the dynamic creation of compiler plugins.

Instanciate me using ""newFromTransformBlock: aBlock andPriority: aPriority"" to get a compiler plugin you can add to an OpalCompiler instance with OpalCompiler>>addPlugin:.
- aBlock must be a block of the form [ :ast | do something to ast ] that returns the modified ast.
- aPriority is the priority the created plugin should have

Check out my test class (OCCompilerDynamicASTPluginTest) for a usage example.!
!OCCompilerDynamicASTPlugin methodsFor: 'accessing' stamp: ''!
priority
	^ priority! !

!OCCompilerDynamicASTPlugin methodsFor: 'accessing' stamp: ''!
priority: anObject
	priority := anObject! !

!OCCompilerDynamicASTPlugin methodsFor: 'accessing' stamp: ''!
transformBlock
	^ transformBlock! !

!OCCompilerDynamicASTPlugin methodsFor: 'accessing' stamp: ''!
transform: ast
	^ transformBlock value: ast copy.! !

!OCCompilerDynamicASTPlugin methodsFor: 'accessing' stamp: ''!
transformBlock: anObject
	transformBlock := anObject! !

!OCCompilerDynamicASTPlugin class methodsFor: 'instance creation' stamp: ''!
newFromTransformBlock: aBlock andPriority: aPriority
	^ self new
		transformBlock: aBlock;
		priority: aPriority.! !

!OCCompilerDynamicASTPluginTest methodsFor: 'tests' stamp: ''!
testCreatingAndUsingDynamicCompilerPlugin
	| result |
	result :=
	Object compiler
		addPlugin: 
			(OCCompilerDynamicASTPlugin 
				newFromTransformBlock: [ :ast | (RBParseTreeRewriter replaceLiteral: 42 with: 'meaning of life') executeTree: ast. ast. ]
				andPriority: 0
			);
		evaluate: '42'.
	self assert: result equals: 'meaning of life'.! !

!OCCompilerExceptionsTest methodsFor: 'emulating' stamp: ''!
text
	^ text! !

!OCCompilerExceptionsTest methodsFor: 'running' stamp: ''!
tearDown
	self removeGeneratedMethods.
	SmalltalkImage compilerClass: currentCompiler.
	super tearDown! !

!OCCompilerExceptionsTest methodsFor: 'emulating' stamp: ''!
selectFrom: start to: end! !

!OCCompilerExceptionsTest methodsFor: 'tests' stamp: ''!
testUndeclaredVariable

	self
		compiling: 'griffle ^ goo' shouldRaise: OCUndeclaredVariableWarning  ;
		compiling: 'griffle ^ [ goo ] value' shouldRaise: OCUndeclaredVariableWarning! !

!OCCompilerExceptionsTest methodsFor: 'emulating' stamp: ''!
select! !

!OCCompilerExceptionsTest methodsFor: 'compiling' stamp: ''!
removeGeneratedMethods

	self class removeProtocol: 'generated'! !

!OCCompilerExceptionsTest methodsFor: 'compiling' stamp: ''!
interactive 
	^ true! !

!OCCompilerExceptionsTest methodsFor: 'compiling' stamp: ''!
compile: sourceString

       text := sourceString.
       self class
               compileSilently: text
               classified: 'generated'
               notifying: self! !

!OCCompilerExceptionsTest methodsFor: 'compiling' stamp: ''!
compiling: sourceCode shouldRaise: exceptionClass

	self should: [ self compile: sourceCode ] raise: exceptionClass! !

!OCCompilerExceptionsTest methodsFor: 'emulating' stamp: ''!
selectionInterval
	^ 1 to: 0! !

!OCCompilerExceptionsTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	currentCompiler := SmalltalkImage compilerClass.
	SmalltalkImage compilerClass: OpalCompiler.! !

!OCCompilerNotifyingTest commentStamp: ''!
A CompilerNotifyingTest is a TestCase for checking that Compiler/Parser notifications are inserted at the right place in a TextEditor.

Instance Variables
	expectedErrorPositions:		<Array of: Integer>
	expectedErrors:		<Array of: String>
	failure:		<Object>
	morph:		<TextMorph>
	text:		<String>

errorPositions
	- the position where error text should be inserted for each chunk of text evaluated

errors
	- the error text that should be inserted on evaluation of each chunk of text evaluated

failure
	- an object returned in case of evaluation error and whose identity can be uniquely recognized as a failure
	
morph
	- the Morph holding the text
	
text
	- the string containing all the chunks to be evaluated (separated by %)
	  and the expected error messages (`enclosed in back quotes`)
	  this text will be stripped of the error messages before being evaluated.

!
!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testMissingArgumentAfterAMessageKey
	self setUpForErrorsIn: '1 to: ` Variable or expression expected ->`:='.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'private' stamp: ''!
evaluateSelection
	^ OpalCompiler new
		source: morph editor selectionAsStream;
		requestor: morph editor;
		failBlock: [^failure];
		evaluate! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testTooLargeAnIntegerInALiteralByteArray

	self setUpForErrorsIn: '#[ 1 2 ` Expecting 8-bit integer ->`256 4 5]'.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testInvalidPrimitive
	"Not implemented yet.
	##primitive:error: #primitive:module:error: skipped, cannot be evaluated"! !

!OCCompilerNotifyingTest methodsFor: 'tests - bytecode limits' stamp: ''!
testTooManyTemporaries
	self setUpForErrorsIn: '| a1 a2 a3 a4 a5 a6 a7 a8 a9 b1 b2 b3 b4 b5 b6 b7 b8 b9 c1 c2 c3 c4 c5 c6 c7 c8 c9 d1 d2 d3 d4 d5 d6 d7 d8 d9 e1 e2 e3 e4 e5 e6 e7 e8 e9 f1 f2 f3 f4 f5 f6 f7 f8 f9 g1 g2 g3 g4 g5 g6 g7 g8 g9 |
	a1 := a2 := a3 := a4 := a5 := a6 := a7 := a8 := a9 := b1 := b2 := b3 := b4 := b5 := b6 := b7 := b8 := b9 := c1 := c2 := c3 := c4 := c5 := c6 := c7 := c8 := c9 := d1 := d2 := d3 := d4 := d5 := d6 := d7 := d8 := d9 := e1 := e2 := e3 := e4 := e5 := e6 := e7 := e8 := e9 := f1 := f2 := f3 := f4 := f5 := f6 := f7 := f8 := f9 := g1 := g2 := g3 := g4 := g5 := g6 := g7 := g8 := g9 := 1'.
	self flag: 'fail on jenkins but works on my computer with both compiler I dont know why'.
	"self should: [ self enumerateAllSelections ] raise: Error.
	[ self enumerateAllSelections ] on: Error do: [ :ex | self assert: ex messageText equals: 'Cannot compile -- stack including temps is too deep' ]"! !

!OCCompilerNotifyingTest methodsFor: 'private' stamp: ''!
enumerateAllSelections
	1 to: self numberOfSelections do: [ :n | 
		self assert: (self evaluateSelectionNumber: n) identicalTo: failure.
		self assert: morph editor selection asString equals: (expectedErrors at: n).
		self assert: (expectedErrorPositions at: n) equals: morph editor startIndex.
		morph editor cut ]! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testExtraneousStatementAfterAReturnInABlock
	self setUpForErrorsIn: '[ ^1 ` End of statement expected ->`2]'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testUnmatchedByteArrayBracket

	self setUpForErrorsIn: '#[ 1 2 ` '']'' expected ->`'.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testUnmatchedStringQuote

	self setUpForErrorsIn: '^nil printString ,  ''unfinished string` Unmatched '' in string literal. ->`'.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testMissingExpressionAfterAReturn

	self setUpForErrorsIn: '^ ` Variable or expression expected ->`. 1 + 2'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testUnmatchedExpressionParenthesis

	self setUpForErrorsIn: '1+(2 ` '')'' expected ->`. '.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'initialization' stamp: ''!
initializeTextWithoutError
	"Remove the errors from the text to be compiled and answer the text without errors.
	Meanwhile, collect the expected error messages and their expected position."

	| input output errorStream positionStream |
	input := text readStream.
	output := (String new: text size) writeStream.
	errorStream := (Array new: self numberOfSelections) writeStream.
	positionStream := (Array new: self numberOfSelections) writeStream.
	
	[output nextPutAll: (input upTo: $`).
	input atEnd]
		whileFalse:
			[positionStream nextPut: output position + 1.
			errorStream nextPut: (input upTo: $`)].
	expectedErrors := errorStream contents.
	expectedErrorPositions := positionStream contents.
	^output contents! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testUnmatchedBlockBracket
	self setUpForErrorsIn: 'nil yourself. [` '']'' expected ->`'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testMissingMessageAfterACascade
	
	self setUpForErrorsIn: 'nil yourself; ` Cascade message expected ->`^ 2'.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testMissingArgumentAfterABinaryMessage
	self setUpForErrorsIn: '1 +` Variable or expression expected ->`'.
	self enumerateAllSelections.
	self setUpForErrorsIn: '1 + ` Variable or expression expected ->`* 2 + 3'.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testDigitTooLargeForARadix

	self setUpForErrorsIn: '2r` Reading a number failed: a digit between 0 and 1 expected ->`3'.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testMissingBlockArgumentName

	self setUpForErrorsIn: '[ :x : ` Variable name expected ->`1]'.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	failure := Object new.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testMissingSeparatorBetweenBlockArgumentAndStatements
	
	self setUpForErrorsIn: '[ :x ` ''|'' expected ->`x + 1 ]'.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testUnmatchedCommentQuote

	self setUpForErrorsIn: '1+2   "unfinished comment` Unmatched " in comment. ->`'.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'private' stamp: ''!
evaluateSelectionNumber: n
	| i start stop |
	i := start := 1.
	[stop := morph text indexOf: $% startingAt: start + 1 ifAbsent: morph text size + 1.
	i = n]
		whileFalse:
			[i := i + 1.
			start := stop + 1].
	morph editor selectFrom: start to: stop - 1.
	^self evaluateSelection! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testInvalidPattern
	"Not implemented yet.
	#pattern:inContext: skipped, cannot be evaluated"! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testInvalidPragma
	"Not implemented yet.
	#pragmaLiteral: #pragmaSequence #pragmaStatement #pragmaPrimitives skipped, cannot be evaluated"! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testMissingExpression

	
	self setUpForErrorsIn: '| x | x := ` Variable or expression expected ->'.
	self enumerateAllSelections! !

!OCCompilerNotifyingTest methodsFor: 'private' stamp: ''!
numberOfSelections
	^(text occurrencesOf: $%) + 1! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testUnmatchedLocalTempDeclaration

	self setUpForErrorsIn: '| x y ` ''|'' expected ->`'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testInvalidRadix

	self setUpForErrorsIn: '1` Reading a number failed: an integer greater than 1 as valid radix expected ->`r0'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testExpectedExpressionInBraceArray
	
	self setUpForErrorsIn: '{ 1. 2 ` End of statement expected ->`3 }'.
	self enumerateAllSelections.
	self setUpForErrorsIn: '{ 1. 2. ` Variable or expression expected ->`| x | x}'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testInvalidLiteralCharacter
	self setUpForErrorsIn: '^ #yourself , #` Expecting a literal type ->`) , #end'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testAssignmentOfSelf

	self setUpForErrorsIn: '` Cannot store into ->`self := 1. ^self'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testInvalidExternalFunctionDeclaration
	"Not implemented yet.
	#externalFunctionDeclaration skipped, cannot be evaluated"! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testMissingPeriodSeparatorBetweenStatements

	self setUpForErrorsIn: '1 + 2 ` End of statement expected ->`^nil'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests - bytecode limits' stamp: ''!
testTooManyArguments
	self setUpForErrorsIn: '^ ` Too many arguments ->`[:x1 :x2 :x3 :x4 :x5 :x6 :x7 :x8 :x9 :x10 :x11 :x12 :x13 :x14 :x15 :x16 :x17 | ]'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testUnmatchedLiteralParenthesis

	self setUpForErrorsIn: '#( 1 2` '')'' expected ->`'.
	self enumerateAllSelections.
	self setUpForErrorsIn: '#( 1 2 ` '')'' expected ->`'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testEmptyCaseStatement
	self flag: 'Opal has the correct behavior but the error is not caught'

	"self setUpForErrorsIn: '^ nil caseOf: { ` At least one case required ->`} '.
	self enumerateAllSelections."! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testUnmatchedLocalTempDeclarationInABlock

	self setUpForErrorsIn: '[:z | | x y ` ''|'' expected ->`]'.
	self enumerateAllSelections.! !

!OCCompilerNotifyingTest methodsFor: 'initialization' stamp: ''!
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 asString.! !

!OCCompilerNotifyingTest methodsFor: 'tests' stamp: ''!
testUnmatchedBraceArray
	self setUpForErrorsIn: '{ 1. 2` expected } ->`'.
	self enumerateAllSelections.
	self setUpForErrorsIn: '{ 1. 2 ` expected } ->`'.
	self enumerateAllSelections! !

!OCCompilerSyntaxErrorNotifyingTest commentStamp: ''!
A CompilerSyntaxErrorNotifyingTest is a specialization for testing correct handling of non interactive compiler notification.
Non interactive is a very relative notion in Smalltalk...
Here it means that user interaction will not happen directly in the TextEditor holding source code, but rather thru a SyntaxError window that will pop-up.
This test intercept the Notification before the pop-up is raised.
!
!OCCompilerSyntaxErrorNotifyingTest methodsFor: 'private' stamp: ''!
evaluateSelection
	^ OpalCompiler new
		source: morph editor selection readStream;
		"Note subtle difference versus  (morph editor selectionAsStream). 
		The later does not answer the same contents and would raise a SyntaxErrorNotification with wrong sub-selection"
		failBlock: [^failure];
		evaluate! !

!OCCompilerSyntaxErrorNotifyingTest methodsFor: 'private' stamp: ''!
enumerateAllSelections
	"This method intercepts the SyntaxErrorNotification and prevent the SyntaxError morph to open.
	The notification errorCode hold the source of evaluated sub-selection with inserted error message.
	This can be compared to expected error notification."
	1 to: self numberOfSelections do: [:n |
		| result |
		result := [self evaluateSelectionNumber: n] on: SyntaxErrorNotification do: [:exc |
			| expectedNotification expectedNotificationLocation |
			expectedNotification := (expectedErrors at: n) allButFirst allButLast: 3.
			expectedNotificationLocation := (expectedErrorPositions at: n) - (morph editor startIndex - 1).
			self assert: exc location equals: expectedNotificationLocation.
			self assert: exc errorMessage asString equals: expectedNotification.
			exc return: nil]].! !

!OCCompilerSyntaxErrorNotifyingTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	"This class can recycle all of super tests, it just has to refine internal Compiler evaluation machinery"
	^true! !

!OCCompilerTest commentStamp: ''!
CompilerTest is a holder for SUnit test of Compiler!
!OCCompilerTest methodsFor: 'tests - shadowing2' stamp: ''!
testNotInteractiveInBlockTempShadowing
	
	interactive := false.
	self initializeErrorMessage.
	self 
		should: [ 
			OpalCompiler new
				source: 'temp |var2| [:temp| |var2|]';
				class: MockForCompilation;
				requestor: self;
				failBlock: [self fail];
				compile.
		] 
		raise: OCShadowVariableWarning 
		withExceptionDo: [ :ex |
			self 
				assert: ex warningMessage 
				equals: 'MockForCompilation>>temp(var2 is shadowed)'
		].! !

!OCCompilerTest methodsFor: 'tests - shadowing2' stamp: ''!
testNotInteractiveInBlockTempArgumentShadowing
	
	interactive := false.
	self initializeErrorMessage.
	self 
		should: [ 
			OpalCompiler new
				source: 'temp [:temp | |temp|]';
				class: MockForCompilation;
				requestor: self;
				compile.
		] 
		raise: OCShadowVariableWarning 
		withExceptionDo: [ :ex |
			self 
				assert: ex warningMessage 
				equals: 'MockForCompilation>>temp(temp is shadowed)'
		].! !

!OCCompilerTest methodsFor: 'mocking' stamp: ''!
initializeErrorMessage
	errorMessage := nil.
	errorLocation := nil.
	errorSource := nil! !

!OCCompilerTest methodsFor: 'tests - shadowing2' stamp: ''!
testNotInteractiveInBlockArgumentInstanceVariableShadowing

	interactive := false.
	self initializeErrorMessage.

	self 
		should: [ 
			OpalCompiler new 
				source: 'temp [:var1 | ]';
				class: MockForCompilation;
				compile.
		] 
		raise: OCShadowVariableWarning 
		withExceptionDo: [ :ex |
			self 
				assert: ex warningMessage 
				equals: 'MockForCompilation>>temp(var1 is shadowed)'
		].! !

!OCCompilerTest methodsFor: 'tests - shadowing' stamp: ''!
testSiblingBlocksInstanceVariableShadowing
	interactive := true.
	self initializeErrorMessage.

	OpalCompiler new
		source: 'temp [:temp | ].[:temp | |var1|]';
		class: MockForCompilation;
		requestor: self;
		failBlock: [ self assert: errorMessage equals: 'Name already defined ->'.
			self assert: errorLocation equals: 27.
			^ nil ];
		compile.
	self fail! !

!OCCompilerTest methodsFor: 'tests - shadowing' stamp: ''!
testInBlockTempShadowing
	interactive := true.
	self initializeErrorMessage.
	text := 'temp |var2| [:temp| |var2|]'.

	self
		compileWithFailBlock: [ self assert: errorMessage equals: 'Name already defined ->'.
			self assert: errorLocation equals: 22.
			self assert: errorSource contents equals: 'temp |var2| [:temp| |var2|]'.
			^ nil ].
	self fail! !

!OCCompilerTest methodsFor: 'tests - readonly vars' stamp: ''!
testAssignmentOfClassNameBinding
	interactive := true.
	self initializeErrorMessage.
	text := 'temp | | MockForCompilation := nil'.

	self
		compileWithFailBlock: [ self assert: errorMessage equals: 'Cannot store into ->'.
			self assert: errorLocation equals: 10.
			self assert: errorSource contents equals: 'temp | | MockForCompilation := nil'.
			^ nil ].
	self fail! !

!OCCompilerTest methodsFor: 'mocking' stamp: ''!
interactive
	^interactive! !

!OCCompilerTest methodsFor: 'tests - shadowing' stamp: ''!
testInstanceVariableShadowing
	interactive := true.
	self initializeErrorMessage.
	text := 'var1 |var1|'.

	self
		compileWithFailBlock: [ self assert: errorMessage equals: 'Name already defined ->'.
			self assert: errorLocation equals: 7.
			self assert: errorSource contents equals: 'var1 |var1|'.
			^ nil ].
	self fail! !

!OCCompilerTest methodsFor: 'tests - shadowing2' stamp: ''!
testNotInteractiveInBlockTempInstanceVariableShadowing
	
	interactive := false.
	self initializeErrorMessage.
	self 
		should: [ 
			OpalCompiler new
				source: 'temp [:temp | |var1|]';
				class: MockForCompilation;
				requestor: self;
				failBlock: [self fail. ^ nil];
				compile.
		] 
		raise: OCShadowVariableWarning 
		withExceptionDo: [ :ex |
			self 
				assert: ex warningMessage 
				equals: 'MockForCompilation>>temp(var1 is shadowed)'
		].! !

!OCCompilerTest methodsFor: 'tests - shadowing' stamp: ''!
testReservedNameAsBlockArgumentShadowing
	interactive := true.
	#('self' 'super' 'thisContext' 'true' 'false' 'nil')
		do: [ :each | 
			self initializeErrorMessage.
			[ :exit | 
			OpalCompiler new
				source: 'temp ^ [ :' , each , ' | ^ ' , each , ' ]';
				class: MockForCompilation;
				requestor: self;
				failBlock: [ exit value ];
				compile.
			self fail ] valueWithExit.
			self assert: (errorMessage = 'Variable name expected ->' or: [ errorMessage = 'Name already defined ->' ]).
			self assert: errorLocation equals: 11 ]! !

!OCCompilerTest methodsFor: 'tests - shadowing2' stamp: ''!
testNotInteractiveSiblingBlocksTempShadowing

	interactive := false.
	self initializeErrorMessage.

	self shouldnt: [ 
		OpalCompiler new
			source: 'temp [:temp | ]. [:temp | ]';
			class: MockForCompilation;
			requestor: self;
			failBlock: [self fail. ^nil];
			compile
	] raise: OCShadowVariableWarning.! !

!OCCompilerTest methodsFor: 'tests - shadowing2' stamp: ''!
testTraitTempShadowing
	
	| warningCount |
	
	warningCount := 0.
	
	self initializeErrorMessage.
	
	[ 
			OpalCompiler new 
				source: self tempTraitShadowingString;
				class: ArrayTest;
				failBlock: [self fail.];
				compile.
	] 
	on: OCShadowVariableWarning 
	do: [ :ex | 
		warningCount := warningCount + 1.
		self 
			assert: ex warningMessage 
			equals: (self traitTempShadowingWarnings at: warningCount).
		
		ex resume
	].

	self assert: warningCount equals: 3! !

!OCCompilerTest methodsFor: 'tests - shadowing' stamp: ''!
testInBlockTempInstanceVariableShadowing
	interactive := true.
	self initializeErrorMessage.
	text := 'temp [:temp | |var1|]'.

	self
		compileWithFailBlock: [ self assert: errorMessage equals: 'Name already defined ->'.
			self assert: errorLocation equals: 16.
			self assert: errorSource contents equals: 'temp [:temp | |var1|]'.
			^ nil ].
	self fail! !

!OCCompilerTest methodsFor: 'literals' stamp: ''!
testScaledDecimalLiterals
	"Equal ScaledDecimal with different scales should use different slots
	This is related to http://bugs.squeak.org/view.php?id=6797"

	"This correctly works when evaluated separately"

	self deny: (Smalltalk compiler evaluate: '0.5s1') scale equals: (Smalltalk compiler evaluate: '0.5s2') scale.

	"But not when evaluated together if literal reduction is too agressive"
	self deny: (Smalltalk compiler evaluate: '0.5s1 scale =  0.5s2 scale')! !

!OCCompilerTest methodsFor: 'utilities' stamp: ''!
tempTraitShadowingString

	^ 'testReplaceFromToWithStartingAt
	| result  repStart collection replacementCollection firstIndex secondIndex |
		replacementCollection := 1.'! !

!OCCompilerTest methodsFor: 'tests - shadowing' stamp: ''!
testInBlockArgumentInstanceVariableShadowing
	interactive := true.
	self initializeErrorMessage.
	text := 'temp [:var1 | ]'.

	self compile.

	self flag: 'display menu instead of going into failblock'.

	self assert: errorMessage equals: 'Name already defined ->'.
	self assert: errorLocation equals: 8.
	self assert: errorSource contents equals: 'temp [:var1 | ]'! !

!OCCompilerTest methodsFor: 'running' stamp: ''!
compile
	^ self compileWithFailBlock: [^ nil]! !

!OCCompilerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	testingEnvironment at: #OCCompilerTestTestVar put: MockForCompilation.! !

!OCCompilerTest methodsFor: 'tests - shadowing2' stamp: ''!
testNotInteractiveShadowingOfTemp

	interactive := false.
	self initializeErrorMessage.
	self 
		should: [ 
			OpalCompiler new
				source: 'temp |temp1 temp1| ';
				class: MockForCompilation;
				requestor: self;
				compile.
		] 
		raise: OCShadowVariableWarning 
		withExceptionDo: [ :ex |
			self 
				assert: ex warningMessage 
				equals: 'MockForCompilation>>temp(temp1 is shadowed)'
		].! !

!OCCompilerTest methodsFor: 'running' stamp: ''!
tearDown
	testingEnvironment removeKey: #OCCompilerTestTestVar.
	super tearDown! !

!OCCompilerTest methodsFor: 'tests - shadowing2' stamp: ''!
testNotInteractiveSiblingBlocksInstanceVariableShadowing

	interactive := false.
	self initializeErrorMessage.
	self 
		should: [ 
			OpalCompiler new
				source: 'temp [:temp | ].[:temp | |var1|]';
				class:  MockForCompilation;
				requestor: self; 
				failBlock: [self fail. ^ nil ];
				compile.
		] 
		raise: OCShadowVariableWarning 
		withExceptionDo: [ :ex |
			self 
				assert: ex warningMessage 
				equals: 'MockForCompilation>>temp(var1 is shadowed)'
		].! !

!OCCompilerTest methodsFor: 'tests - shadowing2' stamp: ''!
testNotInteractiveNoShadowing

	interactive := false.
	self initializeErrorMessage.

	self shouldnt: [ 
		OpalCompiler new
			source: 'temp |var2|';
			class: MockForCompilation;
			requestor: self;
			failBlock: [self fail. ^ nil ];
			compile.
	] raise: OCShadowVariableWarning.! !

!OCCompilerTest methodsFor: 'tests - shadowing' stamp: ''!
testReservedNameAsMethodArgumentShadowing
	interactive := true.
	#('self' 'super' 'thisContext' 'true' 'false' 'nil')
		do: [ :each | 
			self initializeErrorMessage.
			[ :exit | 
			OpalCompiler new
				source: 'temp: ' , each , ' ^ ' , each;
				class: MockForCompilation;
				requestor: self;
				failBlock: [ exit value ];
				compile.
			self fail ] valueWithExit.
			self assert: (errorMessage = 'Variable name expected ->' or: [ errorMessage = 'Name already defined ->' ]).
			self assert: errorLocation equals: 7 ]! !

!OCCompilerTest methodsFor: 'mocking' stamp: ''!
notify: aString at: aSmallInteger in: aReadStream 
	errorMessage := aString.
	errorLocation := aSmallInteger.
	errorSource := aReadStream.! !

!OCCompilerTest methodsFor: 'tests - shadowing' stamp: ''!
testSiblingBlocksTempShadowing

	interactive := true.
	self initializeErrorMessage.

	OpalCompiler new
		source: 'temp [:temp | ]. [:temp | ]';
		class: MockForCompilation;
		failBlock: [self fail. ^ nil ];
		compile.! !

!OCCompilerTest methodsFor: 'utilities' stamp: ''!
traitTempShadowingWarnings

	^ #(	
		'ArrayTest>>testReplaceFromToWithStartingAt(replacementCollection is shadowed)'
		'ArrayTest>>testReplaceFromToWithStartingAt(firstIndex is shadowed)'
		'ArrayTest>>testReplaceFromToWithStartingAt(secondIndex is shadowed)'
	)! !

!OCCompilerTest methodsFor: 'literals' stamp: ''!
testNegativeZero
	self
		assert:
			(OpalCompiler new
				source: '-0.0';
				evaluate) hex
		equals: Float negativeZero hex! !

!OCCompilerTest methodsFor: 'tests - readonly vars' stamp: ''!
testAssignmentOfGlobalVarBinding
	interactive := true.
	self initializeErrorMessage.
	text := 'temp | | OCCompilerTestTestVar := 2'.
	self initializeErrorMessage.
	OpalCompiler new
		source: text;
		class: MockForCompilation;
		requestor: self;
		failBlock: [ self fail.
			^ nil ];
		compile! !

!OCCompilerTest methodsFor: 'running' stamp: ''!
compileWithFailBlock: aBlock
	^ OpalCompiler new 
		source: text;
		class: MockForCompilation;
		requestor: self;
		failBlock: aBlock;
		compile.! !

!OCCompilerTest methodsFor: 'tests - shadowing' stamp: ''!
testInBlockTempArgumentShadowing
	interactive := true.
	self initializeErrorMessage.
	text := 'temp [:temp | |temp|]'.

	self
		compileWithFailBlock: [ self assert: errorMessage equals: 'Name already defined ->'.
			self assert: errorLocation equals: 16.
			self assert: errorSource contents equals: 'temp [:temp | |temp|]'.
			^ nil ].
	self fail! !

!OCCompilerTest methodsFor: 'tests - shadowing' stamp: ''!
testNoShadowing
	interactive := true.
	self initializeErrorMessage.
	text := 'temp |var2|  var2:=1'.

	self compileWithFailBlock: [
		self fail.
		^nil ].! !

!OCCompilerTest methodsFor: 'running' stamp: ''!
runCase
	SystemAnnouncer uniqueInstance suspendAllWhile: [ super runCase ]! !

!OCCompilerTest methodsFor: 'mocking' stamp: ''!
text
	^ text! !

!OCContextTempMappingTest commentStamp: ''!
This testcase tests that we can correctly get the value of the temp vars from a context. That is,

 - it finds the correct context where the variable is defined to get the value
 - it handles well copying and temp vectors

Probably tests are missing covering all possible combinations of 
  - temps
  - copying temps
  - temp vectors
  - nested blocks
  - blocks from dead contexts
  - optimized blocks

However this class is a starting point for this.!
!OCContextTempMappingTest methodsFor: 'tests' stamp: ''!
testAccessingTempsVectorInBlock2
	| a b r |
	"Check the source code availability to do not fail on images without sources"
	thisContext method hasSourceCode ifFalse: [ ^ self skip ].

	a := [ r := 'failure' ].
	[ b := 'success'.
	r := thisContext ]
		on: Error
		do: a.

	self assert: r identicalTo: (r tempNamed: 'r').
	self assert: (r tempNamed: 'a') identicalTo: a.
	self assert: (r tempNamed: 'b') identicalTo: b! !

!OCContextTempMappingTest methodsFor: 'tests' stamp: ''!
testAccessingVariablesInOptimizedBlock2
	| a b |
	"Check the source code availability to do not fail on images without sources"
	thisContext method hasSourceCode ifFalse: [ ^ self skip ].

	a := 1.
	b := 2.

	a < b
		ifTrue: [ | c |
			c := 50.
			self assert: (thisContext tempNamed: 'a') identicalTo: 1.
			self assert: (thisContext tempNamed: 'b') identicalTo: 2.
			self assert: (thisContext tempNamed: 'c') identicalTo: 50 ]! !

!OCContextTempMappingTest methodsFor: 'tests' stamp: ''!
testAccessingMultipleVariablesInVector
	| t1 t2 t3 t4 t5 t6 |
	"Check the source code availability to do not fail on images without sources"
	thisContext method hasSourceCode ifFalse: [ ^ self skip ].

	t1 := 1.
	t2 := 2.
	t3 := 3.
	t4 := 4.
	t5 := 5.
	t6 := 6.
	[ t5 := 50.
	t6 := 60.
	t3 + t4 ] value.

	self assert: t1 identicalTo: (thisContext tempNamed: 't1').
	self assert: t2 identicalTo: (thisContext tempNamed: 't2').
	self assert: t3 identicalTo: (thisContext tempNamed: 't3').
	self assert: t4 identicalTo: (thisContext tempNamed: 't4').
	self assert: t5 identicalTo: (thisContext tempNamed: 't5').
	self assert: t6 identicalTo: (thisContext tempNamed: 't6')! !

!OCContextTempMappingTest methodsFor: 'tests' stamp: ''!
testAccessingArgOfOuterBlockFromAnotherDeepBlock
	
	| actual |
	
	"Check the source code availability to do not fail on images without sources"
	thisContext method hasSourceCode ifFalse: [ ^ self skip ].
	
	actual := [:outerArg | 
		outerArg asString.
		[ :innerArg | innerArg asString. thisContext tempNamed: #outerArg ] value: #innerValue.
		] value: #outerValue.
	
	self assert: actual equals: #outerValue! !

!OCContextTempMappingTest methodsFor: 'tests' stamp: ''!
testAccessingTempsVectorInBlock3

	|a b r |

	"Check the source code availability to do not fail on images without sources"
	thisContext method hasSourceCode ifFalse: [ ^ self skip ].

	a := [ r := 'failure'].
	[ b :='success'.
	self assert: (thisContext tempNamed: 'a') equals: a. 
	] on: Error do: a.
	self assert: (thisContext tempNamed: 'r') equals: nil.
	self assert: (thisContext tempNamed: 'b') equals: 'success'.! !

!OCContextTempMappingTest methodsFor: 'tests' stamp: ''!
testAccessingVariablesInBlock
	| theContext |
	"Check the source code availability to do not fail on images without sources"
	thisContext method hasSourceCode ifFalse: [ ^ self skip ].

	[ | t1 |
	t1 := true.
	theContext := thisContext.
	self assert: (thisContext tempNamed: 'theContext') identicalTo: thisContext.
	self assert: (theContext tempNamed: 't1') ] value! !

!OCContextTempMappingTest methodsFor: 'test - block arguments' stamp: ''!
testAccessingBlockArgumentNoneOptimizedBlock
	" the #in: call is not optimized, the block argument 'x' is a real block local temporary (argument).
(OCContextTempMappingTest>>#testAccessingBlockArgumentNoneOptimizedBlock) numTemps -> 2"

	| a b |

	"Check the source code availability to do not fail on images without sources"
	thisContext method hasSourceCode ifFalse: [ ^ self skip ].

	a := 1.
	b := a in: [ :x | thisContext tempNames ].
	self assert: b equals:#(a b x)! !

!OCContextTempMappingTest methodsFor: 'test - block arguments' stamp: ''!
testAccessingBlockArgumentOptimizedBlock
	" the #ifNotNil: call is an optimized block, the block argument 'x' actually a method temporary.
(OCContextTempMappingTest>>#testAccessingBlockArgumentOptimizedBlock) numTemps -> 3"

	| a b |
	
	"Check the source code availability to do not fail on images without sources"
	thisContext method hasSourceCode ifFalse: [ ^ self skip ].

	a := 1.
	b := a ifNotNil: [ :x | thisContext tempNames ].
	self assert: b equals: #(#a #b #x)! !

!OCContextTempMappingTest methodsFor: 'tests' stamp: ''!
testAccessingVariablesInOptimizedBlock
	"Check the source code availability to do not fail on images without sources"

	thisContext method hasSourceCode ifFalse: [ ^ self skip ].

	1 to: 2 do: [ :index | 
		| optimizedTemp |
		optimizedTemp := index.
		self assert: (thisContext tempNamed: 'optimizedTemp') identicalTo: index ]! !

!OCContextTempMappingTest methodsFor: 'tests' stamp: ''!
testAccessingTempsVectorInBlock
	"Check the source code availability to do not fail on images without sources"

	thisContext method hasSourceCode ifFalse: [ ^ self skip ].

	[ | temp |
	[ temp := 1.
	self assert: (thisContext tempNamed: 'temp') identicalTo: 1 ] value ] value! !

!OCContextTempMappingTest methodsFor: 'tests' stamp: ''!
fetchArgFromOptimizedBlockInsideFullBlock: anArg extraArg: anotherArg
	
	| result |
	self class withAllSubclassesDo: [ :each | 
		result := anArg = anArg ifTrue: [ anotherArg value. thisContext tempNamed: #anArg ]].
	^result! !

!OCContextTempMappingTest methodsFor: 'tests' stamp: ''!
testAccessingMethodArgFromOptimizedBlockContext
	
	| actual |
	actual := self fetchArgFromOptimizedBlockInsideFullBlock: #argValue extraArg: #anotherArg.
	self assert: actual equals: #argValue! !

!OCDoitTest methodsFor: 'tests' stamp: ''!
testDoItContextReadTemp
	| tempForTesting value |
	"we can read this temp from a doit when executing against thisContext"
	tempForTesting := #someValue.
	
	value := OpalCompiler new
		source: 'tempForTesting';
		context: thisContext;
		evaluate.
		
	self assert: value equals: #someValue! !

!OCDoitTest methodsFor: 'binding' stamp: ''!
hasBindingOf: aSelector
	^aSelector == #requestorVarForTesting! !

!OCDoitTest methodsFor: 'tests' stamp: ''!
testDoItRequestorShadow

	| value  |
	"we can shadow a var defined in the requestor without error"
	value := OpalCompiler new
		          source: '|requestorVarForTesting| requestorVarForTesting';
		          noPattern: true;
		          requestor: self;
		          evaluate.
		
	self assert: value equals: nil! !

!OCDoitTest methodsFor: 'binding' stamp: ''!
bindingOf: aSelector
	^(aSelector == #requestorVarForTesting) 
		ifTrue: [WorkspaceVariable key: aSelector value: 5 ]
		ifFalse:  [nil]! !

!OCDoitTest methodsFor: 'interactive error protocol' stamp: ''!
notify: aString at: anInteger in: aString3 
	"we ignore"! !

!OCDoitTest methodsFor: 'tests' stamp: ''!
testDoItContextReadIvar

	| value method |
	"we can read this ivar from a doit when executing against thisContext"
	ivarForTesting := #someValue.

	method := OpalCompiler new
		          source: 'ivarForTesting';
		          noPattern: true;
		          context: thisContext;
		          compileDoit.

	value := method valueWithReceiver: self arguments: { thisContext }.
	self assert: value equals: #someValue! !

!OCDoitTest methodsFor: 'tests' stamp: ''!
testDoItContextReadGlobal
	"we can read a global from a doit when executing against a context"

	|  value |	
	value := OpalCompiler new
		source: 'Object';
		context: thisContext;
		evaluate.
		
	self assert: value equals: Object! !

!OCDoitTest methodsFor: 'tests' stamp: ''!
testDoItRequestorEvalError
	| value |
	value  := OpalCompiler new 
	requestor: self;
	evaluate: '1('.

	self assert: value isNil.! !

!OCDoitTest methodsFor: 'tests' stamp: ''!
testDoItRequestorReadRequestorVar

	| value  |
	"we can read a variable from a requestor"
	value := OpalCompiler new
		          source: 'requestorVarForTesting';
		          noPattern: true;
		          requestor: self;
		          evaluate.
		
	self assert: value equals: 5! !

!OCDoitTest methodsFor: 'tests' stamp: ''!
testDoitContextCheckClass
	"if we create a parse tree for a doit in a context, the class should be correctly set"
	
	| ast |
	ast := OpalCompiler new
		source: 'tempForTesting';
		noPattern: true;
		context: thisContext;
		parseDoIt.
	"we expect that the class is set to the class of the context, which is self class"		
	self assert: ast methodClass equals: self class! !

!OCEnvironmentScopeTest commentStamp: ''!
tests related to environment!
!OCEnvironmentScopeTest methodsFor: 'tests - environment' stamp: ''!
testCompileWithEnvironment
	"testing compiling with environments other then Smalltalk globals. Note: the class in the environment has to point to the environment. And we have to compile for a class in the environment"


	| environment method return | 
	environment := SystemDictionary new.
	environment at: #MyClass put: Point copy.
	(environment at: #MyClass) environment: environment.
	method := OpalCompiler new
					environment: environment;
					class: (environment at: #MyClass);
					compile: 'tt ^MyClass'.
	return := method valueWithReceiver: nil arguments: #().
	self assert: return name equals: 'Point'.
	"I d not know about anything else"
	method := OpalCompiler new
					environment: environment;
					class: (environment at: #MyClass);
					compile: 'tt ^Object'.
	return := method valueWithReceiver: nil arguments: #().
	self assert: return equals: nil.! !

!OCEnvironmentScopeTest methodsFor: 'test - production - environment' stamp: ''!
testCompileWithProductionEnvironment
	| environment method return | 
	environment := {#CompiledMethod -> MyCompiledMethodForTesting} asDictionary.
	method := Smalltalk compiler 
					productionEnvironment: environment;
					compile: 'tt ^1+2'.
	
	self assert: method class equals: MyCompiledMethodForTesting.			
	return := method valueWithReceiver: nil arguments: #().
	self assert: return equals: 3.! !

!OCExtraBindingScope commentStamp: ''!
Bindings normally only come from the scope hierarchy that the variable is in: method, instance, class, requestor (if any). 

The ExtraBinding Scope allows to define bindings via a compiler API.

	result := Smalltalk compiler
		bindings: {(#a -> 3)} asDictionary;
		evaluate: '1+a'.
		
these binding shadow all other bindings, even globals:

result := Smalltalk compiler
		bindings: {(#Object -> 3)} asDictionary;
		evaluate: 'Object + 1'.
		
Shadowed global variables can be assigned to even if they referene a class.!
!OCExtraBindingScope methodsFor: 'accessing' stamp: ''!
bindings: anObject
	bindings := anObject! !

!OCExtraBindingScope methodsFor: 'accessing' stamp: ''!
bindings
	^ bindings! !

!OCExtraBindingScope methodsFor: 'lookup' stamp: ''!
lookupVar: name declare: aBoolean
	^(bindings bindingOf: name asSymbol)
		ifNotNil: [ :var | var ]
		ifNil: [ outerScope lookupVar: name declare: aBoolean]! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNotNil1Arg
	self assert: (5 ifNotNil: [ :a | a printString ]) equals: '5'.
	self assert: (nil ifNotNil: [ :a | a printString ]) isNil! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNotNil1ArgWithStatement
	self
		assert:
			(5
				ifNotNil: [ :a | 
					3.
					a ])
		equals: 5.
	self
		assert:
			(5
				ifNotNil: [ :a | 
					a.
					3 ])
		equals: 3! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNilIfNotNil0Arg
	self assert: (5 ifNil: [ #foo ] ifNotNil: [ #bar ]) equals: #bar.
	self assert: (nil ifNil: [ #foo ] ifNotNil: [ #bar ]) equals: #foo! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNotNilIfNil1ArgAsVar
	| block1 block2 |
	block1 := [ #foo ].
	block2 := [ :a | a printString ].
	self assert: (5 ifNotNil: block2 ifNil: block1) equals: '5'.
	self assert: (nil ifNotNil: block2 ifNil: block1) equals: #foo! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNotNil0ArgAsVar
	| block |
	block := [ #foo ].
	self assert: (5 ifNotNil: block) equals: #foo.
	self assert: (nil ifNotNil: block) isNil! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNotNilIfNil0ArgAsVar
	| block1 block2 |
	block1 := [ #foo ].
	block2 := [ #bar ].
	self assert: (5 ifNotNil: block2 ifNil: block1) equals: #bar.
	self assert: (nil ifNotNil: block2 ifNil: block1) equals: #foo! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNotNil0Arg
	self assert: (5 ifNotNil: [ #foo ]) equals: #foo.
	self assert: (nil ifNotNil: [ #foo ]) isNil! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNilIfNotNil1Arg
	self assert: (5 ifNil: [ #foo ] ifNotNil: [ :a | a printString ]) equals: '5'.
	self assert: (nil ifNil: [ #foo ] ifNotNil: [ :a | a printString ]) equals: #foo! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNotNil1ArgAsVar
	| block |
	block := [ :a | a printString ].
	self assert: (5 ifNotNil: block) equals: '5'.
	self assert: (nil ifNotNil: block) isNil! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNilIfNotNil1ArgAsVar
	| block1 block2 |
	block1 := [ #foo ].
	block2 := [ :a | a printString ].
	self assert: (5 ifNil: block1 ifNotNil: block2) equals: '5'.
	self assert: (nil ifNil: block1 ifNotNil: block2) equals: #foo! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNotNilIfNil1Arg
	self assert: (5 ifNotNil: [ :a | a printString ] ifNil: [ #foo ]) equals: '5'.
	self assert: (nil ifNotNil: [ :a | a printString ] ifNil: [ #foo ]) equals: #foo! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNilIfNotNil0ArgAsVar
	| block1 block2 |
	block1 := [ #foo ].
	block2 := [ #bar ].
	self assert: (5 ifNil: block1 ifNotNil: block2) equals: #bar.
	self assert: (nil ifNil: block1 ifNotNil: block2) equals: #foo! !

!OCIfNotNilTest methodsFor: 'tests' stamp: ''!
testIfNotNilIfNil0Arg
	self assert: (5 ifNotNil: [ #foo ] ifNil: [ #bar ]) equals: #foo.
	self assert: (nil ifNotNil: [ #foo ] ifNil: [ #bar ]) equals: #bar! !

!OCLiteralList commentStamp: ''!
Holds a unique ordered collection of literals!
!OCLiteralList methodsFor: 'accessing' stamp: ''!
literalIndexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of anElement within the receiver. If the receiver does 
	not contain anElement, answer the result of evaluating the argument, 
	exceptionBlock."
	1 to: self size do:
		[:i | ((self at: i) literalEqual: anElement) ifTrue: [^ i]].
	^ exceptionBlock value! !

!OCLiteralList methodsFor: 'accessing' stamp: ''!
indexOf: anElement startingAt: start ifAbsent: exceptionBlock

	start to: self size do:
		[:index | ((self at: index) literalEqual: anElement) ifTrue: [^ index]].
	^ exceptionBlock value! !

!OCLiteralList methodsFor: 'private' stamp: ''!
setCollection: anArray

	super setCollection: anArray.
	equalitySet := OCLiteralSet new: anArray size.! !

!OCLiteralList methodsFor: 'adding' stamp: ''!
addLast: object
	"Only add if not already in list"

	(equalitySet includes: object) ifTrue: [^ object].
	equalitySet add: object.
	super addLast: object.
	^ object! !

!OCLiteralSet commentStamp: ''!
Holds a unique set of literals.  Literal objects are equal if they are #= plus they are the same class.  This set uses this rule for finding elements.

Example:
	Set new add: 'anthony'; add: #anthony; size  "= 1"
	LiteralSet new add: 'anthony'; add: #anthony; size  "= 2"
!
!OCLiteralSet methodsFor: 'adding' stamp: ''!
add: newObject
	"Include newObject as one of the receiver's elements.  If equivalent is already present don't add and return equivalent object"

	| index |
	newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
	index := self findElementOrNil: newObject.
	^ (array at: index) 
		ifNil: [self atNewIndex: index put: newObject. newObject]
		ifNotNil: [array at: index]! !

!OCLiteralSet methodsFor: 'private' stamp: ''!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	start := (anObject hash \\ array size) + 1.
	finish := array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element := array at: index) == nil
					or: [element literalEqual: anObject])
					ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element := array at: index) == nil
					or: [element literalEqual: anObject])
					ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!OCMethodScope commentStamp: ''!
I am the scope for a Method!
!OCMethodScope methodsFor: 'testing' stamp: ''!
isMethodScope 
	^true! !

!OCMethodScope methodsFor: 'scope' stamp: ''!
methodScope

	^ self! !

!OCMockCompilationClass methodsFor: 'accessing' stamp: ''!
collection

	^ collection! !

!OCNewCompilerWithChangesFunctionalTest methodsFor: 'tests' stamp: ''!
testPragma
	| aCompiledMethod bytecode |
	aCompiledMethod := OpalCompiler new
		source:
			'methodDoublePragma
											<hello: 5>
											<hello: 2>';
		class: OCMockCompilationClass;
		compile.

	bytecode := aCompiledMethod symbolic asString substrings: String cr.
	self assert: bytecode first equals: 'Quick return self'! !

!OCOpalExamples commentStamp: ''!
I am the central place for example code used in tests!
!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleFalseIfFalseWithEffect
	^false ifFalse: [iVar := 17]! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleNilIfNotNilWithArgument
	^nil ifNotNil: [ :arg | self error ]! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
singleRemoteTempVar
	| index block theCollection |
	index := 0.
	block := [ 
		theCollection add: [ index ].
		index := index + 1 ].
	[ index < 5 ] whileTrue: block.
	self assertValues: #(5 5 5 5 5)! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleTrueIfTrueIfFalse
	^true ifTrue: [iVar := 'true'] ifFalse: [ self error ]! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
noRemoteBlockArgument
	| block block1 block2 |
	block := [ :arg | | temp | temp := arg. [ temp ] ].
	block1 := block value: 1.
	block2 := block value: 2.! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileWithTemp
	| index |
	index := 0.
	[ index < 5 ] whileTrue: [
		| temp |
		temp := index := index + 1.
		collection add: [ temp ] ].
	^collection collect: [:each | each value].
	"#(1 2 3 4 5)"! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockLocal
	^[ :each | | t |  t:= each. t   ] value: 5! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
examplePushArgumentVariable: argument
	self message: argument! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleFalseIfFalseIfTrue
	^false ifFalse: [iVar := 'false'] ifTrue: [ self error ]! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
noRemoteReadNestedBlocks   
	 [ |a| a := 1.
       [ a ]]! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoOutsideTemp
	| temp |
	1 to: 5 do: [ :index | 
		temp := index. 
		collection add: [ temp ] ].
	^collection "#(5 5 5 5 5)"! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfFalseIfTrue
	^ true
		ifFalse: [ 1 ]
		ifTrue: [ 2 ]! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleLiteralCharacter
	^ $H! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleNewArray
	| temp |
	
	temp := Array new: 3.
	^temp! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfFalse
	true
		ifTrue: [  ]
		ifFalse: [ ^ 1 ].
	^ 2! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleTimesRepeatValue
	^ 5 timesRepeat: [ 1 + 2 ]! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockMethodArgument: arg
	|  block |
	block := [ :blockarg | blockarg + arg].
	self assert: ((block value: 2) = (arg + 2)).
	^block value: 2! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleLiteralBoxedFloat
	^ 9.999999999999996e157! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSuperReceiver
	super foo! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
examplePushTemporaryVariable
	| temporary |
	temporary := iVar.
	self result: temporary! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
exampleForBlockArgument
	|b|
	b:= [ :blockArg | 1 ].
	^ b! !

!OCOpalExamples methodsFor: 'examples - simple' stamp: ''!
exampleEmptyMethod! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlock
	^[1]! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleNotNilIfNil
	^1 ifNil: [ self error ]! !

!OCOpalExamples methodsFor: 'examples - andor' stamp: ''!
exampleAndValueWithEffect
	
	true and: [ result := 17 ]! !

!OCOpalExamples methodsFor: 'accessing' stamp: ''!
message: anObject

	result := anObject! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
noRemoteReadInBlock
	| a |
	a := 1.
	[ a ]! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileNoModification
	"tempvars aren't modified in the loop, therefore they don't need to be in a indirection vector.
	  number of temps = declared temps "

	| a b c |
	a := 1.
	b := 2.
	c := 3.
	[ false ]
		whileTrue: [ 
			[ a class.
			  b class.
			  c class ]	"<- block in optimized loop" ]! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleFalseIfTrueIfFalse
	^false ifTrue: [ self error ] ifFalse: [iVar := 'false']! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
singleRemoteDifferentBlocksSameArgumentName
	| b c z |
	b := [:a | 
		z := 2.
		z + a].
	c := [:a |
		z + a].
	^ (b value: 2) + (c value: 1)! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
examplePushInstanceVariable
	self result: iVar! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
exampleTemporaryVariableAssignment
	| temporary |
	temporary := 17.
	self message: temporary! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
writtenAfterClosedOver
	| a |      
	[ a ].
	a := 1! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleTrueIfTrue
	^true ifTrue: [1]! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
exampleClassVariableAssignment

	ExampleClassVariable := 1! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfNotNilReturnNil
	^nil ifNotNil: [ :arg | arg not ]! !

!OCOpalExamples methodsFor: 'accessing' stamp: ''!
iVar
	^ iVar! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockiVar
	^[iVar] value! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockArgument2
	^[:a :b | a + b ] value: 1 value: 1! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoArgumentNotInlined
	| block |
	block := [ :index |
		collection add: [ index ] ].
	1 to: 5 do: block.
	^collection "#(1 2 3 4 5)"! !

!OCOpalExamples methodsFor: 'accessing' stamp: ''!
result: anObject
	result := anObject! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
examplePushArray
	| t |

	{1 .t:=1}.
	^t! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockInternal
	^[ | t | t := 1. t] value! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfNotNilArg
	^1 even ifNotNil: [ :arg | arg not ]! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSelfReceiver
	self foo! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockExternalNested
	| t s |
	t := s := 1.
	^[[s] value +   t   ] value.! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleTrueIfFalse
	^true ifFalse: [1]! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
exampleWithArgument: anArg
	^ anArg! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockArgument1
	^[:a | a ] value: 1! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockLocalIfNested
	^true ifTrue: [| hallo |  [  hallo := 1 . hallo] value]! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockExternal2
	| t1 t2 |
	t1 :=  t2 := 1.
	^[t1 + t2] value.! !

!OCOpalExamples methodsFor: 'examples - misc' stamp: ''!
exampleToDoValueLimitExpression
	^ 2 to: 3+4 do: [:each | each]! !

!OCOpalExamples methodsFor: 'examples - simple' stamp: ''!
exampleReturn42
	^42! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockExternal
	| t |
	t := 1.
	^[t] value.! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteInNestedBlock
	| t1 |
	^[ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ]! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleNonSpecialLiteralInteger
	^ 10! !

!OCOpalExamples methodsFor: 'examples - andor' stamp: ''!
exampleOrValueWithShortcircuitEffect
	
	true or: [ result := 17 ]! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockArgument4
	^[:a :b :c :d | a + b + c  + d] value: 1 value: 1 value: 1 value: 1! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleFalseIfTrue
	^false ifTrue: [1]! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoArgument
	collection := OrderedCollection new.
	1 to: 5 do: [ :index |
		collection add:  [index]  ].
	 ^collection collect: [:each | each value]. 
	"#(1 2 3 4 5)"! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleRepeatValue
	<compilerOptions: #(+ #optionInlineRepeat)>
	| i |
	i := 1.
	^ [ 
	i := i + 1.
	i = 10
		ifTrue: [ ^ true ] ] repeat! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
optimizedBlockReadInBlock
	| t1 |
	[ t1 < 5 ] whileTrue: [ [ t1 ] ].! !

!OCOpalExamples methodsFor: 'examples - pragmas' stamp: ''!
examplePrimitiveErrorModule
	<primitive: 'primFunction' error: errorCode module: 'primModule'>
	^ errorCode! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockArgument5
	^[:a :b :c :d :e| a + b + c  + d + e] valueWithArguments: #(1 1 1 1 1)! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockEmpty
	^[] value! !

!OCOpalExamples methodsFor: 'examples - simple' stamp: ''!
exampleReturn1plus2
	^1+2! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteInBlock
	| t1 |
	[ t1 < 5 ] whileTrue: [ t1 := 1 ].! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleNilIfNil
	^nil ifNil: [ iVar := 17 ]! !

!OCOpalExamples methodsFor: 'examples - andor' stamp: ''!
exampleOrValueWithEffect
	
	false or: [ result := 17 ]! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
singleRemoteMethodArgument
	| temp block |
	temp := 0.
	block := [ [ temp ] ].
	temp := 1.
	block := block value.
	temp := 2.! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleLiteralArray
	^ #( 1 2 3)! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
noRemoteBlockTemp
	| block block1 block2 |
	block := [ :arg | [ arg ] ].
	block1 := block value: 1.
	block2 := block value: 2.! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleNotNilIfNotNil
	^1 ifNotNil: [ iVar := 17 ]! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleLiteralFloat
	^ 1.2! !

!OCOpalExamples methodsFor: 'examples - andor' stamp: ''!
exampleFalseAndAnything: anything
	^ false and: [ anything ]! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
noRemoteMethodTemp
	| block1 block2 |
	block1 := self methodArgument: 1.
	block2 := self methodArgument: 2.! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleFalseIfTrueWithEffect
	^false ifTrue: [iVar := 17]! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleLiteralWideString
	^ 'áèîöÑü'! !

!OCOpalExamples methodsFor: 'examples - pragmas' stamp: ''!
examplePrimitiveErrorCode
	<primitive: 60 error: code >
	
	^ code! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfTrueIfFalse
	 1 <2 ifTrue: [^'result'] ifFalse: [2].! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleiVar
	iVar := 1.
	^iVar.! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
nestedBlocksRemoteInBlockCase1
	| block |
	block := [ | a b |
		[ a := b ].
		[ b := a ] ]! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
exampleSelf
	
	self result: self! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleLiteralByteSymbol
	^ #bytesymbol! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockReturn
	[^1] value! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
nestedBlocksRemoteInBlockCase3
	| block |
	block := [ 
		[ |a| block := [ a := 1] ].
		[ |b| block := [ b := 2] ] ].! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteReadInBlock
	| t1 |
	[ t1 < 5 ] whileTrue: [ t1 := 1. [ t1 ] ].! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleMethodTempInNestedBlock
	| temp block |
	temp := 0.
	block := [ [ temp ] ].
	temp := 1.
	block := block value.
	temp := 2.
	"self assert: block value = 2."
	^block value.! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleSimpleBlockLocalIf
	^true ifTrue: [ | hallo |  hallo := 1 . hallo]! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteInNestedBlockCase2
	| t1 |
	(true) ifTrue: [ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ]! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleFalseIfFalse
	^false ifFalse: [1]! !

!OCOpalExamples methodsFor: 'examples - misc' stamp: ''!
examplePushDynamicLiteralArray
	^  { 1 . 1+2 }! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockNested
	| a match dict | 

	a  := #(a b c d).
	dict := Dictionary new.


	a doWithIndex: [:each :index |
		(match := a indexOf: each) > 0 ifTrue:
			[dict at: index put: (a at: match)]].

	^ dict! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleTrueIfFalseWithEffect
	^true ifFalse: [iVar := 17]! !

!OCOpalExamples methodsFor: 'accessing' stamp: ''!
classVariable: anInteger 

	ExampleClassVariable := anInteger! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleRepeatEffect
	<compilerOptions: #(+ #optionInlineRepeat)>
	| i |
	i := 1.
	[  
	i := i + 1. 
	i = 10
		ifTrue: [ ^ true ] ] repeat! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleSimpleBlockArgument3
	^[:a :b :c | a + b + c ] value: 1 value: 1 value: 1! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockNested
	
	^[ [1] value] value! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
singleRemoteReadNestedBlocks   
	|a| 
	[  a := 1.
       [ a ]]! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleMethodWithOptimizedBlocksA
	| s c |
	s := self isNil
			ifTrue: [| a | a := 'isNil'. a]
			ifFalse: [| a | a := 'notNil'. a].
	c := String new: s size.
	1 to: s size do:
		[:i| c at: i put: (s at: i)].
	^c. "notNil"! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleTimesRepeatEffect
	| foo |
	foo := 1.
	5 timesRepeat: [ foo := foo + 3 ] . 
	^ foo! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleLiteralByteArray
	^ #[ 1 2 3 ]! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileWithTempNotInlined
	| index block |
	index := 0.
	block := [
		| temp |
		temp := index := index + 1.
		collection add: [ temp ] ].
	[ index < 5 ] whileTrue: block.
	^collection collect: [:each | each value].
	"#(1 2 3 4 5)"! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteInNestedBlockCase4
	| t1 |
	[(true) whileTrue: [ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ] ]! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoOutsideTempNotInlined
	| block temp |
	block := [ :index | 
		temp := index. 
		collection add: [ temp ] ].
	1 to: 5 do: block.
	^collection "#(5 5 5 5 5)"! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
exampleInstanceVariableAssignment
	iVar := 1! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWrittenAfterClosedOverCase2
	| index |
	index := 0.
	[ index < 5 ] whileTrue: [
		| temp |
		temp := index := index + 1.
		 [ temp ] ].! !

!OCOpalExamples methodsFor: 'initialization' stamp: ''!
initialize
	collection := OrderedCollection new! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleNilIfNotNil
	^nil ifNotNil: [ self error ]! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
nestedBlocksRemoteInBlockCase2
	| block |
	block := [ 
		[ |a| [ a := 1] ].
		[ |b| [ b := 2] ] ]! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
noRemoteBlockReturn
	(self announcements at: self index ifAbsent: [ ^ self ]) 
		open.! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleIfTrue
	[ 1 < 2
		ifTrue: [ ^ 'result' ]] value! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoInsideTemp
	1 to: 5 do: [ :index | 
		| temp | 
		temp := index. 
		collection add: [ temp ] ].
	^collection "#(1 2 3 4 5)"! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockExternalArg
	| t  |
	t := 1.
	^[:a | t + a] value: 1.! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
examplePushNonSpecialSmallInteger
	self result: 10! !

!OCOpalExamples methodsFor: 'accessing' stamp: ''!
iVar: anInteger 
	iVar := anInteger! !

!OCOpalExamples methodsFor: 'examples - pragmas' stamp: ''!
examplePrimitiveModuleError
	<primitive: 'primFunction'  module: 'primModule' error: errorCode >
	^ errorCode! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleLiteralLargeInteger
	^ 16rFFFFFFFFFFFFFFFF! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleSimpleBlockLocalWhile
	|a|
	a := true.
	^[: b | [a] whileTrue: [ | hallo |  a := false. hallo := 1 . hallo]] value: 1! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoArgumentLimitIsExpression
	| count sum |
	count := 10.
	sum := 0.
	1 to: count - 1 do: [ :each | sum := sum + each].
	^sum! !

!OCOpalExamples methodsFor: 'examples - andor' stamp: ''!
exampleTrueOrAnything: anything
	^ true or: [ anything ]! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleBlockArgument
	| block block1 block2 |
	block := [ :arg | | temp | temp := arg. [ temp ] ].
	block1 := block value: 1.
	block2 := block value: 2.
	self assert: block1 value = 1.
	self assert: block2 value = 2.
	^block1 value + block2 value.! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleNestedBlockScoping
	| b c z |
	b := [:a | 
			z := 2.
			z + a].
	c := [:a |
			z + a].
	^ (b value: 2) + (c value: 1)! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileModificationBefore
	| index |
	collection := OrderedCollection new.
	index := 0.
	[ index < 5 ] whileTrue: [ 
		index := index + 1.
		collection add: [ index ] ].
	^collection collect:  [:each | each value].
	"#(5 5 5 5 5)"! !

!OCOpalExamples methodsFor: 'accessing' stamp: ''!
result

	^ result! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
examplePushClassVariable
	self result: ExampleClassVariable! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
doubleRemoteAnidatedBlocks
	| val last |	
	val := 0. 
	1 to: 10 do: [ :i |
		[ :continue |
			i = 4 ifTrue: [continue value].
			val := val + 1.
			last := i
		] valueWithExit.
	].
	self assert: val = 9.
	self assert: last = 10.! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleLiteralWideSymbol
	^ #'áèîöÑü'! !

!OCOpalExamples methodsFor: 'examples - pragmas' stamp: ''!
examplePrimitiveErrorCodeModule
	"Primitive. Attempt to load a module of the given name.
	Fail if module cannot be found, or cannot be loaded,
	or failed to initialize"

	<primitive: 'primLoadModule'  module: '' error: #errorCode >
	^ self primitiveFailed! !

!OCOpalExamples methodsFor: 'examples - andor' stamp: ''!
exampleTrueAndAnything: argument
	^ true and: [ argument ]! !

!OCOpalExamples methodsFor: 'examples - pragmas' stamp: ''!
exampleDoublePrimitive
	<primitive: 1>! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
singleRemoteTempVarWrittenAfterClosedOver
	| index block |
	index := 0.
	block := [ index ].
	index := index + 1.! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleInlineBlockCollectionLR3
	| col |
	col := OrderedCollection new.
	1 to: 11 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ].
	^ (col collect: [ :each | each value ]) asArray "= (2 to: 12) asArray"! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
exampleSuper
	self result: super! !

!OCOpalExamples methodsFor: 'examples - blocks' stamp: ''!
exampleEffectValues
	#getMe.
	#( got that ? ).
	Class.! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWrittenAfterClosedOverCase1
	| index |
	index := 0.
	[ index < 5 ] whileTrue: [
		| temp |
		[ temp ].
		temp := index := index + 1].
	^index! !

!OCOpalExamples methodsFor: 'examples - misc' stamp: ''!
examplePushBigDynamicLiteralArray
	"This array should have a size more than 127 elements"
	self message: { 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 .  255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 }! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleToDoInsideTempNotInlined
	| block |
	block := [ :index | 
		| temp | 
		temp := index. 
		collection add: [ temp ] ].
	1 to: 5 do: block.
	^collection "#(1 2 3 4 5)"! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleTrueIfTrueWithEffect
	^true ifTrue: [iVar := 17]! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileModificationAfterNotInlined
	| index block |
	index := 0.
	block := [ 
		collection add: [ index ].
		index := index + 1 ].
	[ index < 5 ] whileTrue: block.
	^collection collect:  [:each | each value].
	"#(5 5 5 5 5)"! !

!OCOpalExamples methodsFor: 'examples - literals' stamp: ''!
exampleLiteralByteString
	^ 'bytestring'! !

!OCOpalExamples methodsFor: 'examples - andor' stamp: ''!
exampleFalseOrAnything: anything
	^ false or: [ anything ]! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleTrueIfFalseIfTrue
	^true ifFalse: [ self error ] ifTrue: [iVar := 'true']! !

!OCOpalExamples methodsFor: 'examples - conditionals' stamp: ''!
exampleNotNilIfNotNilWithArgument
	^1 ifNotNil: [ :arg | iVar := arg ]! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
exampleThisContext
	self result: thisContext! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
optimizedBlocksAndSameNameTemps
	| s c |
	s := self isNil
			ifTrue: [| a | a := 1. a]
			ifFalse: [| a | a := 2. a].
	c := String new: s size.
	1 to: s size do:
		[:i| c at: i put: (s at: i)].
	^c! !

!OCOpalExamples methodsFor: 'examples - variables' stamp: ''!
exampleForInlinedBlockArgument
	1 ifNotNil:[ :value | ^ value ].! !

!OCOpalExamples methodsFor: 'examples - misc' stamp: ''!
exampleToDoValue
	^ 1 to: 2 do: [:each | each]! !

!OCOpalExamples methodsFor: 'accessing' stamp: ''!
classVariable

	^ ExampleClassVariable! !

!OCOpalExamples methodsFor: 'examples - blocks-optimized' stamp: ''!
exampleWhileModificationBeforeNotInlined
	| index block |
	index := 0.
	block := [ 
		index := index + 1.
		collection add: [ index ] ].
	[ index < 5 ] whileTrue: block.
	^collection collect: [:each | each value].
	"#(5 5 5 5 5)"! !

!OCOpalExamples methodsFor: 'examples - andor' stamp: ''!
exampleAndValueWithShortcircuitEffect
	
	false and: [ result := 17 ]! !

!OCOpalExamples methodsFor: 'examples' stamp: ''!
optimizedBlockWriteInNestedBlockCase3
	| t1 |
	[(true) ifTrue: [ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ] ]! !

!OCOpalExamples class methodsFor: 'compiler' stamp: ''!
compilerClass
	^OpalCompiler! !

!OCOpalExamples class methodsFor: 'class initialization' stamp: ''!
reset

	ExampleClassVariable := nil! !

!OCOptimizedBlockScope commentStamp: ''!
In Smalltalk, methods like ifTrue: are inlined an there is no Block for the arguments of these message sends.
To be consistent, these blocks need nevertheless a scope.

!
!OCOptimizedBlockScope methodsFor: 'lookup' stamp: ''!
nextOuterScopeContextOf: aContext

	"Returns the next context to lookup a variable name from within outer scope.
	
	For inlined BlockClosure which I represent it will be same context because inlined blocks do not produce extra contexts on stack"
	^ aContext! !

!OCOptimizedBlockScope methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	isInlinedLoop := false! !

!OCOptimizedBlockScope methodsFor: 'accessing' stamp: ''!
outerNotOptimizedScope
	^self outerScope outerNotOptimizedScope! !

!OCOptimizedBlockScope methodsFor: 'testing' stamp: ''!
isInsideOptimizedLoop
	^ isInlinedLoop
		ifTrue: [true]
		ifFalse: [self outerScope isInsideOptimizedLoop]! !

!OCOptimizedBlockScope methodsFor: 'mark' stamp: ''!
markInlinedLoop
	isInlinedLoop := true! !

!OCPerformTest commentStamp: ''!
I test a primitive failure with perform:withArguments: which was raised when selectors with many arguments was called from methods with small stack sizes.!
!OCPerformTest methodsFor: 'utilities' stamp: ''!
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! !

!OCPerformTest methodsFor: 'utilities' stamp: ''!
doPerformOldSmallFrame
	"The perform primitive reuses the current stack frame.
	When this was small, it would cause the perform primitive to fail, when the amount of arguments were too high"
	
	^self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15:
		withArguments: (Array new: 15).! !

!OCPerformTest methodsFor: 'testing' stamp: ''!
testPerformWithArgsLargeFrame
	self doPerformOldLargeFrame! !

!OCPerformTest methodsFor: 'testing' stamp: ''!
testPerformWithArgsSmallFrame
	self doPerformOldSmallFrame! !

!OCPerformTest methodsFor: 'utilities' stamp: ''!
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! !

!OCPragmaTest methodsFor: 'method - tested' stamp: ''!
methodPragmaAfterBeforTemps
	^'methodPragmaAfterBeforTemps
		<hello: 5>
		| aTemp |
		<world: #ok>
		<blue: true>'! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testDoublePragma
	| aRBMethode |
	aRBMethode := OpalCompiler new parse: self methodDoublePragma.

	self assert: aRBMethode compiledMethod pragmas first selector equals: #hello:.
	self assert: aRBMethode compiledMethod pragmas second selector equals: #hello:! !

!OCPragmaTest methodsFor: 'method - tested' stamp: ''!
methodSinglePragma
	^'methodSinglePragma
		<hello: 5>'! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testPragmaTwoParam
	| aRBMethode |
	aRBMethode := OpalCompiler new parse: self methodPragmaTwoParam.


	self assert: aRBMethode compiledMethod pragmas first selector equals: #hello:by:! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testPragmaUnarayMessage
	| aRBMethode |
	aRBMethode := OpalCompiler new parse: self methodPragmaUnarayMessage.

	self assert: aRBMethode compiledMethod pragmas first selector equals: #hello! !

!OCPragmaTest methodsFor: 'method - tested' stamp: ''!
methodPrimitive
	^'methodPrimitive
		<primitive: 4>'! !

!OCPragmaTest methodsFor: 'method - tested' stamp: ''!
methodPrimitiveStringModule
	^'methodPrimitiveStringModule
		<primitive: ''aFunctionName'' module: ''aModuleName''>'! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testSinglePragma
	| aRBMethode |
	aRBMethode := OpalCompiler new parse: self methodSinglePragma.
	self assert: aRBMethode compiledMethod pragmas first selector equals: #hello:! !

!OCPragmaTest methodsFor: 'method - tested' stamp: ''!
methodPrimitiveString
	^'methodPrimitiveString
		<primitive: ''aFunctionName''>'! !

!OCPragmaTest methodsFor: 'method - tested' stamp: ''!
methodNoPragma
	^'methodNoPragma: aNum
		^aNum'! !

!OCPragmaTest methodsFor: 'method - tested' stamp: ''!
methodPragmaTwoParam
	^'methodDoublePragma
		<hello: 5 by: 2>'! !

!OCPragmaTest methodsFor: 'method - tested' stamp: ''!
methodPragmaUnarayMessage
	^'methodPragmaUnarayMessage
		<hello>'! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testPrimitiveNumber
	| aRBMethode |
	aRBMethode := OpalCompiler new parse: self methodPrimitive.
	self assert: aRBMethode compiledMethod primitive equals: 4! !

!OCPragmaTest methodsFor: 'method - tested' stamp: ''!
methodPrimitivePragma
	^'methodPrimitivePragma
		<hello: 1>
		<primitive: 4>
		<hello: 1>'! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testPrimitivePragmaNumber
	| aRBMethode |
	aRBMethode := OpalCompiler new parse: self methodPrimitivePragma.
	self assert: aRBMethode compiledMethod primitive equals: 4! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testPrimitiveString
	| aRBMethode |
	aRBMethode := OpalCompiler new parse: self methodPrimitiveString.

	self assert: aRBMethode compiledMethod primitive equals: 117! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testNoPragma

	OpalCompiler new parse: self methodNoPragma! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testPrimitiveStringModule
	| aRBMethode |
	aRBMethode := OpalCompiler new parse: self methodPrimitiveStringModule.

	self assert: aRBMethode compiledMethod primitive equals: 117! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testPragmaAfterBeforTemp
	| aRBMethode |
	aRBMethode := OpalCompiler new parse: self methodPragmaAfterBeforTemps.

	self assert: aRBMethode compiledMethod pragmas first selector equals: #hello:.
	self assert: aRBMethode compiledMethod pragmas second selector equals: #world:! !

!OCPragmaTest methodsFor: 'method - tested' stamp: ''!
methodDoublePragma
	^'methodDoublePragma
		<hello: 5>
		<hello: 2>'! !

!OCPragmaTest methodsFor: 'tests' stamp: ''!
testIsPrimitive
	| aRBMethode |

	aRBMethode := OpalCompiler new parse: self methodPrimitive.
	self assert: aRBMethode isPrimitive! !

!OCRequestorScope commentStamp: ''!
This class models a scope for the workspace (and the debugger and all other tools).

The default scope of the compiler is initialized with a Requestor scope, if the requestor is not nil (see CompilationContext>>scope)

The OCRequestorScope will ask the tool (the requestor) for bindings. This will be an association, and as such it will create a OCLiteralVariable.  It will compile the same bytecode as for a global, but it will use the associations hold on by the tool to do so.!
!OCRequestorScope methodsFor: 'accessing' stamp: ''!
requestor: anObject
	requestor := anObject! !

!OCRequestorScope methodsFor: 'accessing' stamp: ''!
compilationContext: anObject
	compilationContext := anObject! !

!OCRequestorScope methodsFor: 'accessing' stamp: ''!
requestor
	^ requestor! !

!OCRequestorScope methodsFor: 'accessing' stamp: ''!
compilationContext
	^ compilationContext! !

!OCRequestorScope methodsFor: 'temp vars' stamp: ''!
allTemps
	^#()! !

!OCRequestorScope methodsFor: 'accessing' stamp: ''!
scopeLevel
	^ 0! !

!OCRequestorScope methodsFor: 'lookup' stamp: ''!
lookupVar: name declare: aBoolean

	"the system normally allows any object as the name, but the requestor uses some 
	heuristics based on names of variables"
	
	name isString ifFalse: [ ^ outerScope lookupVar: name declare: aBoolean ].
	name isEmpty ifTrue: [ ^ outerScope lookupVar: name declare: aBoolean ].

	"reserved Variables are defined by the global scope, thus we look up in the outer scope"
	(ReservedVariable nameIsReserved: name) ifTrue: [ 
		^ outerScope lookupVar: name declare: aBoolean ].
	
	"generated temps (e.g. for limits in to:do: should not create bindings"
	name first = $0 ifTrue: [ ^ outerScope lookupVar: name declare: aBoolean ].
	"We do not want to auto define bindings for unknown Globals"
	name first isUppercase ifTrue: [ ^ outerScope lookupVar: name declare: aBoolean].
	"do not 'create bindings' in requestor scope if we just want to style a possible unknown variable"
	((compilationContext optionSkipSemanticWarnings or: [aBoolean not])
		and: [ (requestor hasBindingOf: name) not ])
		ifTrue: [ ^ outerScope lookupVar: name declare: aBoolean ].

	"the requestors #bindingOf may create a binding for not yet existing variables"
	^(requestor bindingOf: name)
		ifNotNil: [ :var | var ]
		ifNil: [ outerScope lookupVar: name declare: aBoolean ]! !

!OCScannerTest methodsFor: 'testing' stamp: ''!
testLiteralSymbols
		
	((((32 to: 126) collect: [:ascii | Character value: ascii])) copyWithout: $`) , "backtick is not suppored by OBParser"
	#(':x:yourself' '::' 'x:yourself' '123' 'x0:1:2:' 'x.y.z' '1abc' 'a1b0c2' ' x' 'x ' '+x-y' '||' '--' '++' '+-' '+/-' '-/+' '<|>' '#x' '()' '[]' '{}' '')
		do: [:str |
			self assert: (self class compiler evaluate: str asSymbol printString) = str asSymbol
				description: 'in all case, a Symbol must be printed in an interpretable fashion']! !

!OCScannerTest methodsFor: 'testing' stamp: ''!
testAmbiguousSelector
	"Non regression test.
	See http://code.google.com/p/pharo/issues/detail?id=2271
	and http://bugs.squeak.org/view.php?id=7491"

	'1@-1' parseLiterals.
	self assert: ('1@-1' parseLiterals at: 2) asString equals: '@-'! !

!OCScopeTest methodsFor: 'tests' stamp: ''!
testHasBindingThatBeginsWithGlobal
	self assert: (thisContext astScope hasBindingThatBeginsWith: 'Obj').
	self deny: (thisContext astScope hasBindingThatBeginsWith: 'OBj').! !

!OCScopeTest methodsFor: 'accessing' stamp: ''!
ivarForTesting

	^ ivarForTesting! !

!OCScopeTest methodsFor: 'tests' stamp: ''!
testHasBindingThatBeginsWithTemp
	| tempForTesting |
	tempForTesting := 'only',  'forTest'.
	self assert: (thisContext astScope hasBindingThatBeginsWith: 'tempFor').
	self deny: (thisContext astScope hasBindingThatBeginsWith: 'TempForTest').
	
	"thisContext is known, too"
	self assert: (thisContext astScope hasBindingThatBeginsWith: 'thisC').
	^tempForTesting! !

!OCScopeTest methodsFor: 'tests' stamp: ''!
testHasBindingThatBeginsWithClassVar
	self assert: (thisContext astScope hasBindingThatBeginsWith: 'MyClass').
	self deny: (thisContext astScope hasBindingThatBeginsWith: 'NonExMYCL')! !

!OCScopeTest methodsFor: 'tests' stamp: ''!
testHasBindingThatBeginsWithSlot
	self assert: (thisContext astScope hasBindingThatBeginsWith: 'ivarFo').
	self deny: (thisContext astScope hasBindingThatBeginsWith: 'ivarForDoesNotExist').
	
	"super and self, too"
	self assert: (thisContext astScope hasBindingThatBeginsWith: 'sel').
	self assert: (thisContext astScope hasBindingThatBeginsWith: 'sup')! !

!OCScopeTest class methodsFor: 'accessing' stamp: ''!
myClassVarForTesting

	^MyClassVarForTesting! !

!OCScopesCollector commentStamp: ''!
I am a helper class to simplify tests related to scopes. I collect all scopes of the AST.
This way one can easily check for scopes and variables even when the scopes are deeply nested.
Simple example (with just a method scope):

|ast scopes ivar|
ast := (OCOpalExamples>>#exampleiVar) 
		parseTree doSemanticAnalysisIn: OCOpalExamples.
scopes := (OCScopesCollector new visitNode: ast) scopes.
ivar := scopes first lookupVar: #iVar!
!OCScopesCollector methodsFor: 'initialization' stamp: ''!
initialize 
	scopes := OrderedCollection new.
	super initialize! !

!OCScopesCollector methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode
	scopes add: aBlockNode owningScope.
	super visitBlockNode: aBlockNode! !

!OCScopesCollector methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode
	scopes add: aMethodNode owningScope.
	super visitMethodNode: aMethodNode! !

!OCScopesCollector methodsFor: 'accessing' stamp: ''!
scopes 
	^scopes! !

!OCSemanticError commentStamp: ''!
Raises a semantic error during semantic analysis!
!OCSemanticError methodsFor: 'error handling' stamp: ''!
notify: aString at: location
	^self requestor 
		ifNil: [SyntaxErrorNotification
					inClass: self methodClass 
					withCode: self methodNode source
					doitFlag: false
					errorMessage: aString
					location: location]
		ifNotNil: [self requestor
					notify: aString , ' ->'
					at: location
					in: self requestor text]! !

!OCSemanticError methodsFor: 'accessing' stamp: ''!
node: aNode
	node := aNode! !

!OCSemanticError methodsFor: 'accessing' stamp: ''!
methodClass
	^self methodNode methodClass! !

!OCSemanticError methodsFor: 'accessing' stamp: ''!
compilationContext: anObject
	compilationContext := anObject! !

!OCSemanticError methodsFor: 'accessing' stamp: ''!
methodNode
	^node methodNode! !

!OCSemanticError methodsFor: 'accessing' stamp: ''!
requestor
	^ compilationContext requestor! !

!OCSemanticError methodsFor: 'exceptiondescription' stamp: ''!
defaultAction
	^self notify: messageText at: node start! !

!OCSemanticError methodsFor: 'accessing' stamp: ''!
compilationContext
	^ compilationContext! !

!OCSemanticError methodsFor: 'accessing' stamp: ''!
node
	^ node! !

!OCSemanticWarning commentStamp: ''!
If a variable is not found or some other problem occurs during checking (ASTChecker) than a particular subclass instance of me is signal, usually causing a notification to the user. If not handled, the default handling is done, and compiling continues.!
!OCSemanticWarning methodsFor: 'correcting' stamp: ''!
openMenuIn: aBlock
	self subclassResponsibility! !

!OCSemanticWarning methodsFor: 'correcting' stamp: ''!
methodClass
	^node methodNode methodClass! !

!OCSemanticWarning methodsFor: 'accessing' stamp: ''!
node: anObject
	node := anObject! !

!OCSemanticWarning methodsFor: 'correcting' stamp: ''!
methodNode
	^node methodNode! !

!OCSemanticWarning methodsFor: 'accessing' stamp: ''!
requestor
	^ compilationContext requestor! !

!OCSemanticWarning methodsFor: 'correcting' stamp: ''!
defaultAction
	
	compilationContext interactive ifFalse: [ ^nil ].
	^self openMenuIn: 
		[:labels :lines :caption | 
		UIManager default chooseFrom: labels lines: lines title: caption]! !

!OCSemanticWarning methodsFor: 'accessing' stamp: ''!
compilationContext: anObject
	compilationContext := anObject! !

!OCSemanticWarning methodsFor: 'accessing' stamp: ''!
compilationContext
	^ compilationContext! !

!OCSemanticWarning methodsFor: 'accessing - compatibility' stamp: ''!
location
	^ self node sourceInterval first! !

!OCSemanticWarning methodsFor: 'accessing' stamp: ''!
node
	^node! !

!OCSemanticWarning methodsFor: 'accessing - compatibility' stamp: ''!
errorCode
	self requestor ifNil: [
		^ self node methodNode asString ].
	^ self requestor contents! !

!OCSemanticWarning methodsFor: 'accessing - compatibility' stamp: ''!
errorMessage
	^ self messageText! !

!OCShadowVariableWarning commentStamp: ''!
I get signalled when a variable in a block or method scope shadows a variable of the same name in an outer scope.  The default action is to allow it.!
!OCShadowVariableWarning methodsFor: 'correcting' stamp: ''!
openMenuIn: aBlock
	self error: 'should not be called'! !

!OCShadowVariableWarning methodsFor: 'correcting' stamp: ''!
showWarningOnTranscript
	SystemNotification signal: self warningMessage! !

!OCShadowVariableWarning methodsFor: 'accessing' stamp: ''!
node: aVariableNode

	super node: aVariableNode.
	messageText := 'Temp shadows: ', aVariableNode name! !

!OCShadowVariableWarning methodsFor: 'correcting' stamp: ''!
defaultAction

	^ self resume: (compilationContext interactive
			   ifTrue: [ self raiseSemanticError ]
			   ifFalse: [ self showWarningOnTranscript ])! !

!OCShadowVariableWarning methodsFor: 'accessing' stamp: ''!
warningMessage

	^ String streamContents: [ :stream |
		stream	 
			nextPutAll: self methodClass name;
			nextPutAll: '>>';
			nextPutAll: self node methodNode selector;
			nextPutAll: '(';
			nextPutAll: self node name;
			nextPutAll: ' is shadowed)'	
	]! !

!OCShadowVariableWarning methodsFor: 'correcting' stamp: ''!
raiseSemanticError

	^OCSemanticError new
		node: node;
		compilationContext: compilationContext;
		messageText: self stringMessage;
		signal! !

!OCShadowVariableWarning methodsFor: 'accessing' stamp: ''!
stringMessage
	^ 'Name already defined'! !

!OCSourceCode2BytecodeTest commentStamp: ''!
I provide at least one test which corresponds to a message sent by InstructionStream>>#interpretNextInstructionFor: to its client.!
!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimAdd
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimAdd 3 + 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#+. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimDivide
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimDivide 3 / 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#/. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimNew
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimNew super new') selector.
	scanner := InstructionStream on:  method.
	1
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#new. true. 0}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testStoreIntoTemporaryVariableBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'storeIntoTemporaryVariableBytecode | t0 t1 | ^ (t1 := t0)') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner decodeNextInstruction; peekInstruction) selector == #storeIntoTemporaryVariable:
				and: [did arguments first == 1])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimPointY
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimPointY self y') selector.
	scanner := InstructionStream on: method.
	1
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#y. false. 0}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimNewWith
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodeNewWith self new: 3') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#new:. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimBitOr
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimBitOr 3 bitOr: 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#bitOr:. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testStoreIntoLiteralVariableBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'storeIntoLiteralVariableBytecode ^ (ClassVar := nil)') selector.
	scanner := InstructionStream on: method.
	self
		assert: (did := scanner decodeNextInstruction; peekInstruction) selector == #storeIntoLiteralVariable:
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testReturnTopFromMethod
	| selector method scanner |
	selector := (method := self compile2method: 'returnTopFromMethod ^ 3 + 4') selector.
	scanner := InstructionStream on: method.
	3
		timesRepeat: [scanner decodeNextInstruction].
	self assert: scanner peekInstruction selector == #methodReturnTop
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushConstantFalseBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushConstantFalseBytecode false yourself') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner peekInstruction) selector == #pushConstant:
				and: [did arguments first not])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimMultiply
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimMultiply 3 * 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#'*'. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testStoreAndPopReceiverVariableBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'storeAndPopReceiverVariableBytecode instVar := self') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner decodeNextInstruction; peekInstruction) selector == #popIntoReceiverVariable:
				and: [did arguments first == 3])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimValueWith
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodeValueWith self value: 3') selector.
	scanner := InstructionStream on: method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#value:. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimLessThan
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimLessThan 3 < 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#<. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testSuperSend
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodeSuperSend super yourself') selector.
	scanner := InstructionStream on: method.
	1
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#yourself. true. 0}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimNext
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimSize self next') selector.
	scanner := InstructionStream on:  method.
	1
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#next. false. 0}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushReceiverVariableBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushReceiverVariableBytecode instVar yourself') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner peekInstruction) selector == #pushReceiverVariable:
				and: [did arguments first == 3])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testSuperSendWith
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodeSuperSendWith super new: 0') selector.
	scanner := InstructionStream on: method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#new:. true. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushLiteralConstantBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushLiteralConstantBytecode #() yourself') selector.
	scanner := InstructionStream on: method.
	self assert: ((did := scanner peekInstruction) selector == #pushConstant:
					and: [did arguments first = #()])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimGreaterOrEqual
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimGreaterOrEqual 3 >= 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#'>='. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'compiling' stamp: ''!
compile2method: sourceStream 
			"Compile code without logging the source in the changes file"
			^OpalCompiler new
						source: sourceStream;
						class: self class;			
						compile.! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimMod
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimMod 3 \\ 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#\\. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimGreaterThan
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimGreaterThan 3 > 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#>. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimPointX
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimPointX self x') selector.
	scanner := InstructionStream on: method.
	1
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#x. false. 0}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimEqual
	| selector method scanner did |
	selector := (method  := self compile2method: 'bytecodePrimEqual 3 = 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#'='. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimNextPut
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimNextPut self nextPut: 3') selector.
	scanner := InstructionStream on: method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#nextPut:. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushTemporaryVariableBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushTemporaryVariableBytecode: t0 t0 yourself') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner peekInstruction) selector == #pushTemporaryVariable:
				and: [did arguments first == 0])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimBitShift
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimBitShift 3 bitShift: 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#bitShift:. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimIdentity
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimIdentity 3 == 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#==. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushConstantMinusOneBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushConstantMinusOneBytecode -1 yourself') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner peekInstruction) selector == #pushConstant:
				and: [did arguments first == -1])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'accessing' stamp: ''!
instVar

	^ instVar! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushActiveContextBytecode
	| selector method scanner |
	selector := (method := self compile2method: 'pushActiveContextBytecode thisContext yourself') selector.
	scanner := InstructionStream on: method.
	self assert: scanner peekInstruction selector == #pushActiveContext
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testStoreIntoReceiverVariableBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'storeIntoReceiverVariableBytecode ^ (instVar := self)') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner decodeNextInstruction; peekInstruction) selector == #storeIntoReceiverVariable:
				and: [did arguments first == 3])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushConstantZeroBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushConstantZeroBytecode 0 yourself') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner peekInstruction) selector == #pushConstant:
				and: [did arguments first == 0])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushLiteralVariableBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushLiteralVariableBytecode ClassVar yourself') selector.
	scanner := InstructionStream on: method.
	self
		assert: (did := scanner peekInstruction) selector == #pushLiteralVariable:
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimAtEnd
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimSize self atEnd') selector.
	scanner := InstructionStream on:  method.
	1
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#atEnd. false. 0}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testStoreAndPopTemporaryVariableBytecode
	| selector method scanner did |
	selector := (method:= self compile2method: 'storeAndPopTemporaryVariableBytecode | t0 t1 | t1 := t0') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner decodeNextInstruction; peekInstruction) selector == #popIntoTemporaryVariable:
				and: [did arguments first == 1])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimDoWith
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodeDoWith self do: #something') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#do:. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimAtPut
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimAtPut self at: 3 put: 4') selector.
	scanner := InstructionStream on:  method.
	3
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#at:put:. false. 2}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimMakePoint
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimMakePoint 3 @ 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#'@'. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimSize
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimSize self size') selector.
	scanner := InstructionStream on: method.
	1
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#size. false. 0}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testStoreAndPopLiteralVariableBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'storeAndPopLiteralVariableBytecode ClassVar := nil') selector.
	scanner := InstructionStream on: method.
	self
		assert: (did := scanner decodeNextInstruction; peekInstruction) selector == #popIntoLiteralVariable:
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimSubtract
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimSubtract 3 - 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#-. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimAt
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimAt self at: 3') selector.
	scanner := InstructionStream on: method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#at:. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testReturnFalseBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'returnFalseBytecode 3 + 4. ^ false') selector.
	scanner := InstructionStream on: method.
	4
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #methodReturnConstant:
				and: [did arguments first not])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testReturnTrueBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'returnTrueBytecode 3 + 4. ^ true') selector.
	scanner := InstructionStream on: method.
	4
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #methodReturnConstant:
				and: [did arguments first])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimLessOrEqual
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimLessOrEqual 3 <= 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#<=. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushConstantNilBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushConstantNilBytecode nil yourself') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner peekInstruction) selector == #pushConstant:
				and: [did arguments first isNil])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testReturnReceiver
	| selector method scanner |
	selector := (method := self compile2method: 'returnReceiver 3 + 4. ^ self') selector.
	scanner := InstructionStream on: method.
	4
		timesRepeat: [scanner decodeNextInstruction].
	self assert: scanner peekInstruction selector == #methodReturnReceiver
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushReceiverBytecode
	| selector method scanner |
	selector := (method := self compile2method: 'pushReceiverBytecode ^ self yourself') selector.
	scanner := InstructionStream on: method.
	self assert: scanner peekInstruction selector == #pushReceiver
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimQuo
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimQuo 3 // 4') selector.
	scanner := InstructionStream on:  method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#//. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimBitAnd
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimBitAnd 3 bitAnd: 4') selector.
	scanner := InstructionStream on: method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#bitAnd:. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testDoDup
	| selector method scanner |
	method := self compile2method: 'duplicateTopBytecode 3 + 4; yourself'.
	selector := method selector.
	scanner := InstructionStream on:  method.
	1
		timesRepeat: [scanner decodeNextInstruction].
	self assert: scanner peekInstruction selector == #doDup description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimNotEqual
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimNotEqual 3 ~= 4') selector.
	scanner := InstructionStream on: method.
	2
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#~=. false. 1}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushConstantTwoBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushConstantTwoBytecode 2 yourself') selector.
	scanner := InstructionStream on: method.
	self
		assert: ((did := scanner peekInstruction) selector == #pushConstant:
				and: [did arguments first == 2])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPrimValue
	| selector method scanner did |
	selector := (method := self compile2method: 'bytecodePrimValue self value') selector.
	scanner := InstructionStream on:  method.
	1
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #send:super:numArgs:
				and: [did arguments = {#value. false. 0}])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testDoPop
	| selector method scanner |
	selector := (method := self compile2method: 'popStackBytecode 3 + 4') selector.
	scanner := InstructionStream on:  method.
	3
		timesRepeat: [scanner decodeNextInstruction].
	self assert: scanner peekInstruction selector == #doPop description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testReturnNilBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'returnNilBytecode 3 + 4. ^ nil') selector.
	scanner := InstructionStream on: method.
	4
		timesRepeat: [scanner decodeNextInstruction].
	self
		assert: ((did := scanner peekInstruction) selector == #methodReturnConstant:
				and: [did arguments first isNil])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushConstantOneBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushConstantOneBytecode 1 yourself') selector.
	scanner := InstructionStream on:  method.
	self
		assert: ((did := scanner peekInstruction) selector == #pushConstant:
				and: [did arguments first == 1])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: ''!
testPushConstantTrueBytecode
	| selector method scanner did |
	selector := (method := self compile2method: 'pushConstantTrueBytecode true yourself') selector.
	scanner := InstructionStream on: method.
	self assert: ((did := scanner peekInstruction) selector == #pushConstant:
					and: [did arguments first])
		description: 'Failed ' , selector! !

!OCSourceCode2BytecodeTest class methodsFor: 'accessing' stamp: ''!
classVar

	 ^ClassVar! !

!OCStoreIntoReadOnlyVariableError commentStamp: ''!
Error when trying to assign to a non writeble Variable.
(method arguments). For backward compatibility this error does not signal if the compilation context is not  interactive.!
!OCStoreIntoReadOnlyVariableError methodsFor: 'accessing' stamp: ''!
description
	"Return a textual description of the exception."

	^ String
		streamContents: [ :stream | 
			stream << super description asString.
			stream cr.
			stream << self methodClass asString.
			stream cr.
			stream << self methodNode asString ]! !

!OCStoreIntoReadOnlyVariableError methodsFor: 'signaling' stamp: ''!
signal
	compilationContext interactive
		ifFalse: [ ^ SystemNotification signal: self asString ].
	^ super signal! !

!OCTargetCompiler commentStamp: ''!
I am a ridiculous alternate compiler, that replaces any literal symbol #dontReturnThis with the symbol #expectedReturn.

It's the simplest change to the compiler that I could imagine that doesn't interfere with the fact that the class-side `compilerClass` method can't be interfered with.
!
!OCTargetCompiler methodsFor: 'accessing' stamp: ''!
compilationContext
	^ compilationContext ifNil: [ compilationContext := self compilationContextClass default parserClass: OCTargetCompilerParser ]! !

!OCTargetCompilerParser commentStamp: ''!
I am a ridiculous alternate parser, that replaces any literal symbol #dontReturnThis with the symbol #expectedReturn.

It's the simplest change to the compiler that I could imagine that doesn't interfere with the fact that the class-side `compilerClass` method can't be interfered with.

Note that  I only override a single method, and that method is somewhat deprecated, so changes in the superclass must be reflected here.!
!OCTargetCompilerParser methodsFor: 'parsing' stamp: ''!
parsePrimitiveValueLiteral
	"Creates a literal value node from a literal token."
	| token value |
	token := currentToken.
	self step.
	value := token value.
	value == #dontReturnThis ifTrue: [ value := #expectedReturn ].

	^self literalValueNodeClass 
		value: value 
		start: token start
		stop: token stop
		source: token source! !

!OCTargetCompilerSample methodsFor: 'examples' stamp: ''!
returnExpected
	" the target compiler will ignore the code and force this to return #expectedReturn "
	^ #dontReturnThis! !

!OCTargetCompilerSample class methodsFor: 'examples' stamp: ''!
returnExpected
	" the target compiler will ignore the code and force this to return #expectedReturn
		self returnExpected
		self new returnExpected
	"
	^ #dontReturnThis! !

!OCTargetCompilerSample class methodsFor: 'accessing' stamp: ''!
compilerClass
	^ OCTargetCompiler! !

!OCTargetCompilerTest methodsFor: 'tests' stamp: ''!
testRecompiledReturnFromClass
	" I test that the compilerClass method works for class-side when we trigger method recompilation by adding/removing a slot for the metaclass "
	" it ***doesn't*** at the moment!!!!!!!! "
	self
		assert: ([
				OCTargetCompilerSample class addSlot: #xyzzy. " forces recompile of methods "
				OCTargetCompilerSample returnExpected
			] ensure: [
				OCTargetCompilerSample class removeSlot: (OCTargetCompilerSample class slotNamed: #xyzzy)
			])
 		equals: #expectedReturn.! !

!OCTargetCompilerTest methodsFor: 'testing' stamp: ''!
expectedFailures
	^ #(testModifiedReturnFromClass testRecompiledReturnFromClass)! !

!OCTargetCompilerTest methodsFor: 'tests' stamp: ''!
testModifiedReturnFromClass
	" I test that the compilerClass method works for class-side "
	" it ***doesn't*** at the moment!!!!!!!! "
	" if something has failed to recompile using compilerClass, then you may need to go to OCTargetCompilerSample class and force recompile of the method returnExpected (by e.g. adding/deleting a space and saving) "
	self assert: OCTargetCompilerSample returnExpected equals: #expectedReturn.! !

!OCTargetCompilerTest methodsFor: 'tests' stamp: ''!
testModifiedReturn
	" I test that the compilerClass method works for instance-side "
	" if something has failed to recompile using compilerClass, then you may need to go to OCTargetCompilerSample and force recompile of the method returnExpected (by e.g. adding/deleting a space and saving) "
	self skipOnPharoCITestingEnvironment.
	self assert: OCTargetCompilerSample new returnExpected equals: #expectedReturn.! !

!OCTargetCompilerTest methodsFor: 'tests' stamp: ''!
testRecompiledReturn
	" I test that the compilerClass method works for instance-side when we trigger method recompilation by adding/removing a slot for the class "
	" it ***doesn't*** at the moment!!!!!!!! "
	self
		assert: ([
				OCTargetCompilerSample addSlot: #xyzzy. " forces recompile of methods "
				OCTargetCompilerSample new returnExpected
			] ensure: [
				OCTargetCompilerSample removeSlot: (OCTargetCompilerSample slotNamed: #xyzzy)
			])
 		equals: #expectedReturn.! !

!OCUndeclaredVariableWarning commentStamp: ''!
I get signalled when a temporary variable is used that is not defined.  My default action is to create an Undeclared binding and add it to the Undeclared dictionary.!
!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
openMenuIn: aBlock
	| alternatives labels actions lines caption choice name interval requestor |
	
	"Turn off suggestions when in RubSmalltalkCommentMode
 	This is a workaround, the plan is to not do this as part of the exception"
 	requestor := compilationContext requestor.
 	((requestor class name = #RubEditingArea) and: [
 		requestor editingMode class name = #RubSmalltalkCommentMode])
 					ifTrue: [ ^UndeclaredVariable named: node name ].
	
	interval := node sourceInterval.
	name := node name.
	alternatives := self possibleVariablesFor: name.
	labels := OrderedCollection new.
	actions := OrderedCollection new.
	lines := OrderedCollection new.
	name first isLowercase
		ifTrue: [ 
			labels add: 'Declare new temporary variable'.
			actions add: [ self declareTempAndPaste: name ].
			labels add: 'Declare new instance variable'.
			actions add: [ self declareInstVar: name ] ]
		ifFalse: [ 
			labels add: 'Leave variable undeclared'.
			actions add: [ self declareUndefined ].
			lines add: labels size.
			labels add: 'Define new class'.
			actions
				add: [ 
					[ self defineClass: name ]
						on: Abort
						do: [ self openMenuIn: aBlock ] ].
			labels add: 'Declare new global'.
			actions add: [ self declareGlobal ].
			compilationContext requestor isForScripting ifFalse: 
				[labels add: 'Declare new class variable'.
				actions add: [ self declareClassVar ]].
			labels add: 'Define new trait'.
			actions
				add: [ 
					[ self defineTrait: name ]
						on: Abort
						do: [ self openMenuIn: aBlock ] ] ].	
	lines add: labels size.
	alternatives
		do: [ :each | 
			labels add: each.
			actions
				add: [ 
					self substituteVariable: each atInterval: interval.
					(ReparseAfterSourceEditing new newSource: self requestor text) signal ] ].
	lines add: labels size.
	labels add: 'Cancel'.
	caption := 'Unknown variable: ' , name , ' please correct, or cancel:'.
	choice := aBlock value: labels value: lines value: caption.
	^choice ifNotNil: [ self resume: (actions at: choice ifAbsent: [ compilationContext failBlock value ]) value ]! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
declareClassVar

	self methodClass instanceSide
		addClassVarNamed: node name asSymbol.
	(ReparseAfterSourceEditing new newSource: self requestor text) signal! !

!OCUndeclaredVariableWarning methodsFor: 'accessing' stamp: ''!
node: aVariableNode

	super node: aVariableNode.
	messageText := 'Undeclared temp: ', aVariableNode name.! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
declareTempAndPaste: name
	| insertion delta theTextString characterBeforeMark tempsMark newMethodNode |

	"Below we are getting the text that is actually seen in the morph. This is rather ugly. Maybe there is a better way to do this."
	theTextString := self requestor textMorph editor paragraph text.

	"We parse again the method displayed in the morph. The variable methodNode has the first version of the method, without temporary declarations. "
	newMethodNode := RBParser parseMethod: theTextString.
	
	"We check if there is a declaration of temporary variables"
	tempsMark :=  newMethodNode body  rightBar ifNil: [ self methodNode body start ].	
	
	characterBeforeMark := theTextString at: tempsMark-1 ifAbsent: [$ ].

	(theTextString at: tempsMark) = $| ifTrue:  [
  		"Paste it before the second vertical bar"
		insertion := name, ' '.
		
		characterBeforeMark isSeparator ifFalse: [insertion := ' ', insertion].
		delta := 0.
	] ifFalse: [
		"No bars - insert some with CR, tab"
		insertion := '| ' , name , ' |',String cr.
		delta := 2.	"the bar and CR"
		characterBeforeMark = Character tab ifTrue: [
			insertion := insertion , String tab.
			delta := delta + 1.	"the tab" ]
		].
	tempsMark := tempsMark +
		(self substituteWord: insertion
			wordInterval: (tempsMark to: tempsMark-1)
			offset: 0) - delta.
	" we can not guess at this point where the tempvar should be stored,
	tempvars vs. tempvector therefore -> reparse"
	(ReparseAfterSourceEditing new newSource: self requestor text) signal! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
defaultAction
	| className selector |
 	className := self methodClass name.
	selector := self methodNode selector. 

	NewUndeclaredWarning signal: node name in: (selector 
		ifNotNil: [className, '>>', selector]
			ifNil: ['<unknown>']).

	^super defaultAction ifNil: [ self declareUndefined ]! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
declareInstVar: name
	"Declare an instance variable."
	self methodClass addInstVarNamed: name.
	(ReparseAfterSourceEditing new newSource: self requestor text) signal! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
defineClass: className 
	"Prompts the user to define a new class."
	
	| classSymbol systemCategory classDefinition classBinding |
	classSymbol := className asSymbol.
	systemCategory := self methodClass category
		ifNil: [ 'Unknown' ].
	classDefinition := 'Object subclass: #' , classSymbol , '
		instanceVariableNames: '''' 
		classVariableNames: ''''
		category: ''' , systemCategory , ''''.
	classDefinition := UIManager default 
		multiLineRequest: 'Edit class definition:'
		initialAnswer: classDefinition
		answerHeight: 150.
	(classDefinition isNil or: [ classDefinition isEmpty ])
		ifTrue: [ ^ Abort signal ].
	self class compiler
		source: classDefinition;
		logged: true;
		evaluate.
	classBinding := node owningScope lookupVar: className.
	"make sure to recompile all methods referencing this class"
	classBinding usingMethods do: [:method | method recompile].
	^classBinding! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
declareUndefined

	^UndeclaredVariable registeredWithName: node name! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
defineTrait: traitName 
	"Prompts the user to define a new trait."
	
	| traitSymbol systemCategory traitDefinition |
	traitSymbol := traitName asSymbol.
	systemCategory := self methodClass category
		ifNil: [ 'Unknown' ].
	traitDefinition := 'Trait named: #' , traitSymbol , '
		uses:{} 
		package: ''' , systemCategory , ''''.
	traitDefinition := UIManager default 
		multiLineRequest: 'Edit trait definition:'
		initialAnswer: traitDefinition
		answerHeight: 150.
	(traitDefinition isNil or: [ traitDefinition isEmpty ])
		ifTrue: [ ^ Abort signal ].
	self class compiler
		source: traitDefinition;
		logged: true;
		evaluate.
	^ (node owningScope lookupVar: traitSymbol)
		ifNil: [self error: 'should be not happen']! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
substituteVariable: varName atInterval: anInterval 
	self 
		substituteWord: varName
		wordInterval: anInterval
		offset: 0.
	self methodNode source: self requestor text.
	node replaceWith:((RBVariableNode named: varName) binding: (node owningScope lookupVar: varName)).
	^ (node owningScope lookupVar: varName)
		ifNil: [self error: 'should be found'].! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
possibleVariablesFor: proposedVariable 
	| results class |
	class := node methodNode methodClass .
	
	results := proposedVariable correctAgainst: node methodOrBlockNode scope allTempNames 
								continuedFrom: nil.
	proposedVariable first canBeGlobalVarInitial ifTrue:
		[ results := class possibleVariablesFor: proposedVariable
						continuedFrom: results ].
	^ proposedVariable correctAgainst: nil continuedFrom: results! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
substituteWord: correctWord wordInterval: spot offset: o
	"Substitute the correctSelector into the (presuamed interactive) receiver."

	self requestor correctFrom: (spot first + o)
					to: (spot last + o)
					with: correctWord.

	^ o + correctWord size - spot size! !

!OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: ''!
declareGlobal
	Smalltalk globals at: node name asSymbol put: nil.
	(ReparseAfterSourceEditing new newSource: self requestor text) signal.
	^Smalltalk globals bindingOf: node name asSymbol! !

!OCVectorTempVariable commentStamp: ''!
I model a temp variable that is stored in a temp vector.

My "index" variable has the index where I am stored in the temp vector (filled in lazily if requested, the index is determined by the bytecode backend and thus the result of the compilation)

The temp vector itself is stored in a copied var (you can get it's name by sending #vectorName) 

reading and writing thus is a multi step process:

1) get the semamtic variable that stores the temp vector by name
2) get the offset in the temp vector from it (cached in "index")
3) the temp vector semantic var knows how to read / write the vector (which is an array)
4) use the index to access this array!
!OCVectorTempVariable methodsFor: 'accessing' stamp: ''!
vectorName: anObject
	vectorName := anObject! !

!OCVectorTempVariable methodsFor: 'accessing' stamp: ''!
vectorName
	^ vectorName! !

!OCVectorTempVariable methodsFor: 'testing' stamp: ''!
isRemote
	^true! !

!OCVectorTempVariable methodsFor: 'debugging' stamp: ''!
writeFromContext: aContext scope: contextScope value: aValue

	| theVector |
	theVector := self readVectorFromContext: aContext scope: contextScope.
	^theVector at: self index put: aValue.! !

!OCVectorTempVariable methodsFor: 'debugging' stamp: ''!
readVectorFromContext: aContext scope: contextScope
	| tempVectorVar theVector |
	"We need to first read the temp vector. We use the closest copied var up the stack possible as
	 as the definition context could be already garbage collected"
	tempVectorVar := contextScope lookupVar: vectorName.
	"We might be called from the debugger for a context that actually does not access the temp vector, 
	so we need to read possibly from a context above aContext"
	theVector := tempVectorVar readFromContext: aContext scope: contextScope.
	"We can call this method on a context in any state, e.g. even when the copied var is not yet initialized.
	In this case, we lookup in the outer context with the corresponding outer scope"
	^ theVector ifNil: [ aContext outerContext 
		"but there might be no outer context, so in that case, just return an empty array of the correct size"
			ifNil: [ Array new: tempVectorVar originalVar scope tempVector size ]
			ifNotNil: [: ctxt | self readVectorFromContext: ctxt scope: contextScope outerScope ]]! !

!OCVectorTempVariable methodsFor: 'debugging' stamp: ''!
readFromContext: aContext scope: contextScope

	| theVector |
	theVector := self readVectorFromContext: aContext scope: contextScope.
	^theVector at: self index! !

!OCVectorTempVariable methodsFor: 'testing' stamp: ''!
isTempVectorTemp
	^true! !

!OCVectorTempVariable methodsFor: 'emitting' stamp: ''!
emitValue: methodBuilder

	methodBuilder pushRemoteTemp: name inVector: vectorName.! !

!OCVectorTempVariable methodsFor: 'emitting' stamp: ''!
emitStore: methodBuilder

	methodBuilder storeRemoteTemp: name inVector: vectorName.! !

!OSBackendWindow commentStamp: ''!
I am abstract class, representing an OSWindow handle.
Each instance of OSWindow holds a handle, through which it communicates with underlaying operating system.

The implementation of OSWindowHandle (and subclasses) is highly driver-specific and therefore considered private.!
!OSBackendWindow methodsFor: 'accessing' stamp: ''!
position
	^ self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
setMouseCursor: cursor mask: mask andScale: scale! !

!OSBackendWindow methodsFor: 'factory' stamp: ''!
newGenericRenderer
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
bounds
	^ self position extent: self extent! !

!OSBackendWindow methodsFor: 'text input' stamp: ''!
isTextInputActive
	^ self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
resizable: aBoolean! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
osWindow
	
	^ osWindow! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
position: newPosition
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
bounds: newBounds
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
horizontalDPI
	^ self screenScaleFactorBaseDPI! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
borderless: aBoolean! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
hide
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
screenScaleFactorBaseDPI
	^ OSPlatform current osWindowScreenScaleFactorBaseDPI! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
verticalDPI
	^ self screenScaleFactorBaseDPI! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
diagonalDPI
	^ self screenScaleFactorBaseDPI! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
screenScaleFactor
	^ 1! !

!OSBackendWindow methodsFor: 'text input' stamp: ''!
stopTextInput
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'mouse capture' stamp: ''!
releaseMouse! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
extent: newExtent
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
icon: aForm! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
title
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
renderer
	
	^ renderer! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
windowId
	^ nil! !

!OSBackendWindow methodsFor: 'cursor' stamp: ''!
setMouseCursor: cursorWithMask
	self setMouseCursor: cursorWithMask mask: cursorWithMask maskForm! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
platformSpecificHandle
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
clipboardText: aString
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
title: aTitle
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'text input' stamp: ''!
startTextInput
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
extent
	^ self bounds extent! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
fullscreen: aBoolean! !

!OSBackendWindow methodsFor: 'factory' stamp: ''!
newFormRenderer: aForm
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
renderer: anObject
	
	renderer := anObject! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
prepareExternalResourceForAutoRelease
	"This hook will allow just create handlers to prepate their external resources for being 
	 releases by the GC (if needed). By default, do nothing."! !

!OSBackendWindow methodsFor: 'mouse capture' stamp: ''!
captureMouse! !

!OSBackendWindow methodsFor: 'cursor' stamp: ''!
setMouseCursor: cursor mask: mask

	self setMouseCursor: cursor mask: mask andScale: 1! !

!OSBackendWindow methodsFor: 'testing' stamp: ''!
isValid
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
clipboardText
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
show
	self subclassResponsibility! !

!OSBackendWindow methodsFor: 'events' stamp: ''!
updateToNewResolution! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
borderless
	^ false! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
resizable
	^ true! !

!OSBackendWindow methodsFor: 'accessing' stamp: ''!
osWindow: anObject
	
	osWindow := anObject! !

!OSButtonState commentStamp: ''!
I am holding a set of mouse buttons state (pressed or not).
Used by various mouse events.!
!OSButtonState methodsFor: 'initialization' stamp: ''!
initialize
	buttons := 0! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
button1
	^ (buttons & 1) ~=0! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
button4: aBoolean
	self setBit: 8 value: aBoolean! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
button4
	^ (buttons & 8) ~=0! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
button5: aBoolean
	self setBit: 16 value: aBoolean! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
button2: aBoolean
	self setBit: 2 value: aBoolean! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
button5
	^ (buttons & 16) ~=0! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
button2
	^ (buttons & 2) ~=0! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
anyPressed
	^ buttons isZero not! !

!OSButtonState methodsFor: 'private' stamp: ''!
setBit: bit value: aBoolean
	
	buttons := buttons - (buttons bitAnd: bit) + (aBoolean ifTrue: [ bit  ] ifFalse: [ 0 ])! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
button3: aBoolean
	self setBit: 4 value: aBoolean! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
button1: aBoolean
	self setBit: 1 value: aBoolean! !

!OSButtonState methodsFor: 'accessing' stamp: ''!
button3
	^ (buttons & 4) ~=0! !

!OSEnvironment commentStamp: ''!
I represent the user environment variables. See  `man environ` for more details.
Get access using: 

	Smalltalk os environment

I have a Dictionary-like API to access the system environment variables.
The common denominator for all platforms implements a simple API that uses strings.
In other words, methods

- #at:
- #at:put:

and its variants receive normal strings and decide whether they have to encode those strings to platform bytes or not depending on the platform.

My subclasses may or may not provide additional APIs to have more control on the particular encoding used.!
!OSEnvironment methodsFor: 'enumeration' stamp: ''!
keysAndValuesDo: aBlock withAssociationString: associationString
	| equalsIndex |
	equalsIndex := associationString indexOf: $=.
	aBlock 
		value: (associationString first: equalsIndex-1) 
		value: (associationString allButFirst: equalsIndex).
		! !

!OSEnvironment methodsFor: 'enumeration' stamp: ''!
associationsDo: aBlock
	^ self keysAndValuesDo: [ :key :value |
		aBlock value: key -> value ]! !

!OSEnvironment methodsFor: 'testing' stamp: ''!
includes: anObject

	self do: [:each | anObject = each ifTrue: [^true]].
	^false! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
associations
	"Answer a Collection containing the receiver's associations."
	
	^Array streamContents: [ :stream |
		self associationsDo: [ :each | stream nextPut: each ]]! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
keys
	"Answer an Array containing the receiver's keys."
	
	^Array streamContents: [ :s | self keysDo: [ :key | s nextPut: key]]! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey put: aValue
	"Sets the value of an environment variable called `aKey` to `aValue`.
	It is the system responsibility to manage the encodings of both arguments.
	
	This is the common denominator API for all platforms.
	Rationale: Windows does not (compared to *nix systems) provide a encoded byte representation of the value. Windows has instead its own wide string representation."

	^ self subclassResponsibility! !

!OSEnvironment methodsFor: 'enumeration' stamp: ''!
keysDo: aBlock
	^ self keysAndValuesDo: [ :key :value |
		aBlock value: key ]! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey ifPresent: aBlock
	"Gets the value of an environment variable called `aKey` and invoke aBlock with it.
	Return nil if absent.
	It is the system responsibility to manage the encodings of the argument and return values.
	
	This is the common denominator API for all platforms.
	Rationale: Windows does not (compared to *nix systems) provide a encoded byte representation of the value. Windows has instead its own wide string representation."

	^ aBlock value: (self at: aKey ifAbsent: [ ^ nil ])! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
setEnv: nameString value: valueString
	"This method calls the the platform specific set environment routine"

	^ self subclassResponsibility! !

!OSEnvironment methodsFor: 'enumeration' stamp: ''!
valuesDo: aBlock
	^ self keysAndValuesDo: [ :key :value |
		aBlock value: value ]! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
removeKey: aKey
	"Removes the entry `aKey` from the environment variables.
	It is the system responsibility to manage the encoding of the argument.
	
	This is the common denominator API for all platforms.
	Rationale: Windows does not (compared to *nix systems) provide a encoded byte representation of the value. Windows has instead its own wide string representation."

	^ self subclassResponsibility! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey
	"Gets the value of an environment variable called `aKey`.
	Throws a KeyNotFound exception if not found.
	It is the system responsibility to manage the encodings of the argument and return values.
	
	This is the common denominator API for all platforms.
	Rationale: Windows does not (compared to *nix systems) provide a encoded byte representation of the value. Windows has instead its own wide string representation."

	^ self at: aKey ifAbsent: [ KeyNotFound signalFor: aKey ]! !

!OSEnvironment methodsFor: 'initialization' stamp: ''!
initializeWith: anOSPlatform
	super initialize.
	platform := anOSPlatform! !

!OSEnvironment methodsFor: 'enumeration' stamp: ''!
do: aBlock

	^self valuesDo: aBlock! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey ifAbsent: aBlock
	"Gets the value of an environment variable called `aKey`.
	Execute aBlock if absent.
	It is the system responsibility to manage the encodings of the argument and return values.
	
	This is the common denominator API for all platforms.
	Rationale: Windows does not (compared to *nix systems) provide a encoded byte representation of the value. Windows has instead its own wide string representation."
	
	self subclassResponsibility! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey ifAbsentPut: aBlock 
	"Gets the value of an environment variable called `aKey`.
	If absent, insert the value given by aBlock.
	It is the system responsibility to manage the encodings of the argument and return values.
	
	This is the common denominator API for all platforms.
	Rationale: Windows does not (compared to *nix systems) provide a encoded byte representation of the value. Windows has instead its own wide string representation."

	^ self at: aKey ifAbsent: [ self at: aKey put: aBlock value ]! !

!OSEnvironment methodsFor: 'converting' stamp: ''!
asDictionary
	| dictionary |
	dictionary := Dictionary new.
	self keysAndValuesDo: [ :key :value |
		dictionary at: key put: value ].
	^ dictionary! !

!OSEnvironment methodsFor: 'enumeration' stamp: ''!
keysAndValuesDo: aBlock
	self subclassResponsibility! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
platform
	^ platform! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
unsetEnv: string
	"This method calls the the platform specific unset environment routine"

	^ self ffiCall: #(int unsetenv #(String string)) module: LibC! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey ifPresent: presentBlock ifAbsent: absentBlock
	"Gets the value of an environment variable called `aKey`.
	Call presentBlock with it if present.
	Execute absentBlock if absent.
	It is the system responsibility to manage the encodings of the argument and return values.
	
	This is the common denominator API for all platforms.
	Rationale: Windows does not (compared to *nix systems) provide a encoded byte representation of the value. Windows has instead its own wide string representation."
	
	self at: aKey ifPresent: [ :v | ^ presentBlock cull: v ].
	^absentBlock value! !

!OSEnvironment methodsFor: 'accessing' stamp: ''!
values
	"Answer a Collection containing the receiver's values."
	^ Array streamContents: [ :stream|
		self valuesDo: [ :value | stream nextPut: value ]]! !

!OSEnvironment methodsFor: 'testing' stamp: ''!
includesKey: aKey
	^ self at: aKey ifPresent: [ :value | true ] ifAbsent: [ false ].! !

!OSEnvironment class methodsFor: 'examples' stamp: ''!
example

	Smalltalk os environment asDictionary inspect! !

!OSEnvironment class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default
		registerSystemClassNamed: self name! !

!OSEnvironment class methodsFor: 'instance creation' stamp: ''!
current
	^ Current ifNil: [ Current := self environmentFor: OSPlatform current ]! !

!OSEnvironment class methodsFor: 'instance creation' stamp: ''!
platform: anOSPlatform
	^ self basicNew initializeWith: anOSPlatform ! !

!OSEnvironment class methodsFor: 'testing' stamp: ''!
isAvailable
	self flag: #pharoTodo. "Replace this for a check of FFI available"
	self environment at: #FFICalloutAPI ifAbsent: [ ^ false ].
	^ true! !

!OSEnvironment class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting

	isImageStarting ifTrue: [ Current := nil ]! !

!OSEnvironment class methodsFor: 'testing' stamp: ''!
isDefaultFor: aPlatform
	^ false! !

!OSEnvironment class methodsFor: 'private - accessing' stamp: ''!
environmentFor: aPlatform
	| environmentClass |
	
	environmentClass := self allSubclasses
		detect: [ :each | each isDefaultFor: aPlatform ]
		ifNone: [ nil ].
		
	^ (environmentClass notNil and: [ environmentClass isAvailable  ])  
		ifTrue: [ environmentClass platform: aPlatform ]
		ifFalse: [ PlatformIndependentEnvironment platform: aPlatform ]! !

!OSEnvironmentTest commentStamp: ''!
This tests the OSEnvironment. The tests assume that there is at least 1 environment variable given.!
!OSEnvironmentTest methodsFor: 'tests' stamp: ''!
testAsDictionary
	self assert: self instance asDictionary isDictionary! !

!OSEnvironmentTest methodsFor: 'helper' stamp: ''!
instance
	^ Smalltalk os environment! !

!OSEnvironmentTest methodsFor: 'tests' stamp: ''!
testAtPut
	| key value env |
	
	env := self instance.
	value := 1000 atRandom asString.
	key := 'OSEnvironmentTest >> #testAtPut >> ', value.
	
	env at: key put: value.
	self assert: (env at: key) equals: value.
	
	env removeKey: key.
	self deny: (env includesKey: key)! !

!OSEnvironmentTest methodsFor: 'tests' stamp: ''!
testValues
	| env values |
	env := self instance.
	values := env values.

	self denyEmpty: values.
	self assert: values anyOne isString.
	self assert: (env includes: values anyOne)! !

!OSEnvironmentTest methodsFor: 'tests' stamp: ''!
testKeys
	| env keys |
	env := self instance.
	keys := env keys.

	self denyEmpty: keys.
	self assert: keys anyOne isString.
	self assert: (env includesKey: keys anyOne)! !

!OSEnvironmentTest methodsFor: 'tests' stamp: ''!
testEnvironmentFor
	
	| compareDictionary |
	
	compareDictionary := ((Smalltalk hasClassNamed: #UnixEnvironment) and: [Smalltalk hasClassNamed: #Win32Environment])
		ifTrue: [ "NativeBoost is present in the image"
			{ 	MacOSPlatform -> #UnixEnvironment. 
	 		  	MacOSXPlatform -> #UnixEnvironment. 
				UnixPlatform -> #UnixEnvironment. 
				Win32Platform -> #Win32Environment  } asDictionary ]
		ifFalse: [ "NativeBoost is NOT present in the image"
			{ 	MacOSPlatform -> #PlatformIndependentEnvironment. 
	 		  	MacOSXPlatform -> #PlatformIndependentEnvironment. 
				UnixPlatform -> #PlatformIndependentEnvironment. 
				Win32Platform -> #PlatformIndependentEnvironment  } asDictionary ].

	compareDictionary keysAndValuesDo: [ :platformClass :envClassName |
		self 
			assert:  (OSEnvironment environmentFor: platformClass new) class name
			equals: envClassName ] ! !

!OSEnvironmentTest methodsFor: 'tests' stamp: ''!
testAssociations
	| associations |
	associations := self instance associations.
	self denyEmpty: associations.
	self assert: associations anyOne key isString.
	self assert: associations anyOne value isString! !

!OSEvent commentStamp: ''!
I am a basic class of OSEvent hierarchy.
The specific events are coming from operating system and converted to corresponding OSEvent subinstance(s) in order to handle them.

Events can implement a default action, which will be performed after dispatch on event handling,
unless they are suppressed using #suppressDefaultAction message.!
!OSEvent methodsFor: 'default actions' stamp: ''!
performDefaultAction
	suppressDefaultAction ifFalse: [  self defaultAction ]! !

!OSEvent methodsFor: 'initialization' stamp: ''!
initialize
	suppressDefaultAction := false! !

!OSEvent methodsFor: 'dispatching' stamp: ''!
deliver
	"deliver an event to its handler(s)"
	
	^ window deliverEvent: self! !

!OSEvent methodsFor: 'accessing' stamp: ''!
window
	^ window! !

!OSEvent methodsFor: 'default actions' stamp: ''!
defaultAction
	"do nothing by default"! !

!OSEvent methodsFor: 'default actions' stamp: ''!
suppressDefaultAction 
	suppressDefaultAction  := true! !

!OSEvent methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream. 
	window ifNotNil: [ 
		aStream 
			nextPutAll:  ' (WindowId='; 
			print: window windowId;  
			nextPut:  $) ]! !

!OSEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	self subclassResponsibility! !

!OSEvent methodsFor: 'accessing' stamp: ''!
window: anOSWindow 
	window := anOSWindow! !

!OSEvent class methodsFor: 'instance creation' stamp: ''!
for: aWindow
	^ self new window: aWindow; yourself! !

!OSJoyAxisEvent commentStamp: ''!
I am the  joystick axis event.

This event is generated when a joystick stick is moved.

The which parameter gives the joystick index.
The axis parameter is the index of the axis that moved.
The value parameter is how much the axis was moved.
The mapped parameter tells if the axis index has been mapped into the index of a standard layout.
The hasMapping parameters tells if this joystick is generating a mapped version of the event.!
!OSJoyAxisEvent methodsFor: 'accessing' stamp: ''!
value: anObject
	
	value := anObject! !

!OSJoyAxisEvent methodsFor: 'accessing' stamp: ''!
hasMapping
	^ hasMapping! !

!OSJoyAxisEvent methodsFor: 'accessing' stamp: ''!
which
	
	^ which! !

!OSJoyAxisEvent methodsFor: 'testing' stamp: ''!
isLeftX
	^ axis == 0! !

!OSJoyAxisEvent methodsFor: 'testing' stamp: ''!
isRightX
	^ axis == 2! !

!OSJoyAxisEvent methodsFor: 'testing' stamp: ''!
isTriggerLeft
	^ axis == 4! !

!OSJoyAxisEvent methodsFor: 'accessing' stamp: ''!
hasMapping: anObject
	hasMapping := anObject! !

!OSJoyAxisEvent methodsFor: 'testing' stamp: ''!
isTriggerRight
	^ axis == 5! !

!OSJoyAxisEvent methodsFor: 'accessing' stamp: ''!
axis
	
	^ axis! !

!OSJoyAxisEvent methodsFor: 'testing' stamp: ''!
isLeftY
	^ axis == 1! !

!OSJoyAxisEvent methodsFor: 'accessing' stamp: ''!
mapped: anObject
	mapped := anObject! !

!OSJoyAxisEvent methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!OSJoyAxisEvent methodsFor: 'accessing' stamp: ''!
axis: anObject
	
	axis := anObject! !

!OSJoyAxisEvent methodsFor: 'accessing' stamp: ''!
which: anObject
	
	which := anObject! !

!OSJoyAxisEvent methodsFor: 'testing' stamp: ''!
isPreferredEvent
	^ mapped or: hasMapping not! !

!OSJoyAxisEvent methodsFor: 'testing' stamp: ''!
isRightY
	^ axis == 3! !

!OSJoyAxisEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyAxisEvent: self! !

!OSJoyAxisEvent methodsFor: 'accessing' stamp: ''!
mapped
	^ mapped! !

!OSJoyButtonDownEvent commentStamp: ''!
This event is delivered when user pressing down a joystick button.!
!OSJoyButtonDownEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyButtonDownEvent: self! !

!OSJoyButtonEvent commentStamp: ''!
I am the root of the joystick button events hierarchy.

The which parameter identifies the joystick that produced this event.
The button parameter is the joystick dependent index of the button that was pressed or released.
The pressed parameter tells if the button was pressed or released.
The  mapped  parameters tells if the button index have been mapped into a standard controller layout.
The hasMapping parameters tells if this joystick is generating a mapped version of the event.!
!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isButtonA
	^ button == 0! !

!OSJoyButtonEvent methodsFor: 'accessing' stamp: ''!
which
	
	^ which! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isButtonX
	^ button == 2! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isRightStick
	^ button == 8! !

!OSJoyButtonEvent methodsFor: 'accessing' stamp: ''!
hasMapping: anObject
	hasMapping := anObject! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isDigitalPadUp
	^ button == 11! !

!OSJoyButtonEvent methodsFor: 'accessing' stamp: ''!
pressed
	
	^ pressed! !

!OSJoyButtonEvent methodsFor: 'accessing' stamp: ''!
which: anObject
	
	which := anObject! !

!OSJoyButtonEvent methodsFor: 'accessing' stamp: ''!
button
	
	^ button! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isPreferredEvent
	^ mapped or: hasMapping not! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isDigitalPadRight
	^ button == 14! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isRightShoulder
	^ button == 10! !

!OSJoyButtonEvent methodsFor: 'accessing' stamp: ''!
hasMapping
	^ hasMapping! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isLeftShoulder
	^ button == 9! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isButtonBack
	^ button == 4! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isLeftStick
	^ button == 7! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isDigitalPadDown
	^ button == 12! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isButtonB
	^ button == 1! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isDigitalPadLeft
	^ button == 13! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isButtonGuide
	^ button == 5! !

!OSJoyButtonEvent methodsFor: 'accessing' stamp: ''!
mapped: anObject
	mapped := anObject! !

!OSJoyButtonEvent methodsFor: 'accessing' stamp: ''!
button: anObject
	
	button := anObject! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isButtonStart
	^ button == 6! !

!OSJoyButtonEvent methodsFor: 'testing' stamp: ''!
isButtonY
	^ button == 3! !

!OSJoyButtonEvent methodsFor: 'accessing' stamp: ''!
pressed: anObject
	
	pressed := anObject! !

!OSJoyButtonEvent methodsFor: 'accessing' stamp: ''!
mapped
	^ mapped! !

!OSJoyButtonUpEvent commentStamp: ''!
This event is delivered when user releases a previously pressed joystick button.!
!OSJoyButtonUpEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyButtonUpEvent: self! !

!OSJoyDeviceAddedEvent commentStamp: ''!
I am a joystick device added event.

This event is generated when a joystick is connected to the computer.!
!OSJoyDeviceAddedEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyDeviceAddedEvent: self! !

!OSJoyDeviceEvent commentStamp: ''!
I am a joystick device event.

The which parameter gives the joystick index.
The  mapped  parameters tells if this device is axis and buttons are going to be mapped into a standard layout.
The hasMapping parameters tells if this joystick is generating a mapped version of the event.!
!OSJoyDeviceEvent methodsFor: 'accessing' stamp: ''!
hasMapping
	^ hasMapping! !

!OSJoyDeviceEvent methodsFor: 'accessing' stamp: ''!
which
	^ which! !

!OSJoyDeviceEvent methodsFor: 'accessing' stamp: ''!
hasMapping: anObject
	hasMapping := anObject! !

!OSJoyDeviceEvent methodsFor: 'accessing' stamp: ''!
mapped: anObject
	mapped := anObject! !

!OSJoyDeviceEvent methodsFor: 'accessing' stamp: ''!
which: anObject
	which := anObject! !

!OSJoyDeviceEvent methodsFor: 'testing' stamp: ''!
isPreferredEvent
	^ mapped or: hasMapping not! !

!OSJoyDeviceEvent methodsFor: 'accessing' stamp: ''!
mapped
	^ mapped! !

!OSJoyDeviceRemappedEvent commentStamp: ''!
I am a joystick device remapped event.

This event is generated when a joystick layout is remapped.!
!OSJoyDeviceRemappedEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyDeviceRemappedEvent: self! !

!OSJoyDeviceRemovedEvent commentStamp: ''!
I am a joystick device added event.

This event is generated when a joystick is disconnected from the computer.!
!OSJoyDeviceRemovedEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyDeviceRemovedEvent: self! !

!OSKeyDownEvent commentStamp: ''!
This event is delivered when user pressing down a key!
!OSKeyDownEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitKeyDownEvent: self! !

!OSKeySymbols commentStamp: ''!
This pool contains all the platform independent key symbols. They are the same used by SDL2 to avoid having to perform any kind of translation.

The symbolic constants and their mapping to named KeyboardKey	for Morphic consumption are defined in the data method. Some SDL2 constants are omitted because they are rare and they do not have a corresponding mapping in KeyboardKey. One requirement in the initialize method is that all of the named constan have a corresponding mapping in KeyboardKey.!
!OSKeySymbols class methodsFor: 'class initialization' stamp: ''!
initialize
	
	OSKeySymbolValueToKeyboardKeyMap := Dictionary new.
	OSKeySymbolNameToValueMap := Dictionary new.
	self data do: [ :each |
		| symbolValue classVarName symbolName keyboardKey |
		symbolValue := each first.
		classVarName := each second.
		symbolName := each third asString asUppercase asSymbol.
		keyboardKey := KeyboardKey named: symbolName.
		(self hasClassVarNamed: classVarName) ifFalse: [
			self addClassVarNamed: classVarName
		].
		self classVarNamed: classVarName put: symbolValue.
		OSKeySymbolValueToKeyboardKeyMap at: symbolValue put: keyboardKey.
		OSKeySymbolNameToValueMap at: symbolName put: symbolValue.
	].! !

!OSKeySymbols class methodsFor: 'accessing' stamp: ''!
mapKeySymbolNameToValue: keySymbolName
	^ OSKeySymbolNameToValueMap at: keySymbolName ifAbsent: [ OSK_UNKNOWN ]! !

!OSKeySymbols class methodsFor: 'accessing' stamp: ''!
mapKeySymbolValueToKeyboardKey: keySymbolValue
	^ OSKeySymbolValueToKeyboardKeyMap at: keySymbolValue ifAbsent: [ nil ]! !

!OSKeySymbols class methodsFor: 'private' stamp: ''!
data
	^ #(
		(16r0000 OSK_UNKNOWN null)
		(16r000D OSK_RETURN return)
		(16r001B OSK_ESCAPE escape)
		(16r0008 OSK_BACKSPACE backspace)
		(16r0009 OSK_TAB tab)
		(16r0020 OSK_SPACE space)
		(16r0021 OSK_EXCLAIM exclam)
		(16r0022 OSK_QUOTEDBL quotedbl)
		(16r0023 OSK_HASH numbersign)
		(16r0025 OSK_PERCENT percent)
		(16r0024 OSK_DOLLAR underscore)
		(16r0026 OSK_AMPERSAND ampersand)
		(16r0027 OSK_QUOTE apostrophe)
		(16r0028 OSK_LEFTPAREN parenleft)
		(16r0029 OSK_RIGHTPAREN parenright)
		(16r002A OSK_ASTERISK asterisk)
		(16r002B OSK_PLUS plus)
		(16r002C OSK_COMMA comma)	
		(16r002D OSK_MINUS minus)
		(16r002E OSK_PERIOD period)
		(16r002F OSK_SLASH slash)
		(16r0030 OSK_0 0)	
		(16r0031 OSK_1 1)
		(16r0032 OSK_2 2)
		(16r0033 OSK_3 3)
		(16r0034 OSK_4 4)
		(16r0035 OSK_5 5)
		(16r0036 OSK_6 6)
		(16r0037 OSK_7 7)
		(16r0038 OSK_8 8)
		(16r0039 OSK_9 9)
		(16r003A OSK_COLON colon)
		(16r003B OSK_SEMICOLON semicolon)
		(16r003C OSK_LESS less)
		(16r003D OSK_EQUALS equal)
		(16r003E OSK_GREATER greater)
		(16r003F OSK_QUESTION question)
		(16r0040 OSK_AT at)		
		(16r005B OSK_LEFTBRACKET bracketleft)
		(16r005C OSK_BACKSLASH backslash)
		(16r005D OSK_RIGHTBRACKET bracketright)
		(16r005E OSK_CARET asciicircum)
		(16r005F OSK_UNDERSCORE underscore)
		(16r0060 OSK_BACKQUOTE grave)
		(16r0061 OSK_a a)
		(16r0062 OSK_b b)
		(16r0063 OSK_c c)
		(16r0064 OSK_d d)
		(16r0065 OSK_e e)
		(16r0066 OSK_f f)
		(16r0067 OSK_g g)
		(16r0068 OSK_h h)
		(16r0069 OSK_i i)
		(16r006A OSK_j j)
		(16r006B OSK_k k)
		(16r006C OSK_l l)
		(16r006D OSK_m m)
		(16r006E OSK_n n)
		(16r006F OSK_o o)
		(16r0070 OSK_p p)
		(16r0071 OSK_q q)
		(16r0072 OSK_r r)
		(16r0073 OSK_s s)
		(16r0074 OSK_t t)
		(16r0075 OSK_u u)
		(16r0076 OSK_v v)
		(16r0077 OSK_w w)
		(16r0078 OSK_x x)
		(16r0079 OSK_y y)
		(16r007A OSK_z z)
		(16r40000039 OSK_CAPSLOCK Caps_Lock)
		(16r4000003A OSK_F1 f1)
		(16r4000003B OSK_F2 f2)
		(16r4000003C OSK_F3 f3)
		(16r4000003D OSK_F4 f4)
		(16r4000003E OSK_F5 f5)
		(16r4000003F OSK_F6 f6)
		(16r40000040 OSK_F7 f7)
		(16r40000041 OSK_F8 f8)
		(16r40000042 OSK_F9 f9)
		(16r40000043 OSK_F10 f10)
		(16r40000044 OSK_F11 f11)
		(16r40000045 OSK_F12 f12)
		(16r40000046 OSK_PRINTSCREEN printScreen)
		(16r40000047 OSK_SCROLLLOCK scroll_Lock)
		(16r40000048 OSK_PAUSE pause)
		(16r40000049 OSK_INSERT insert)
		(16r4000004A OSK_HOME HOME)
		(16r4000004B OSK_PAGEUP Page_Up)
		(16r007F OSK_DELETE delete)
		(16r4000004D OSK_END end)
		(16r4000004E OSK_PAGEDOWN Page_Down)
		(16r4000004F OSK_RIGHT right)
		(16r40000050 OSK_LEFT left)
		(16r40000051 OSK_DOWN down)
		(16r40000052 OSK_UP up)
		(16r40000053 OSK_NUMLOCKCLEAR num_lock)
		(16r40000054 OSK_KP_DIVIDE kp_divide)
		(16r40000055 OSK_KP_MULTIPLY kp_multiply)
		(16r40000056 OSK_KP_MINUS KP_Subtract)
		(16r40000057 OSK_KP_PLUS KP_Add)
		(16r40000058 OSK_KP_ENTER kp_enter)
		(16r40000059 OSK_KP_1 kp_1)
		(16r4000005A OSK_KP_2 kp_2)
		(16r4000005B OSK_KP_3 kp_3)
		(16r4000005C OSK_KP_4 kp_4)
		(16r4000005D OSK_KP_5 kp_5)
		(16r4000005E OSK_KP_6 kp_6)
		(16r4000005F OSK_KP_7 kp_7)
		(16r40000060 OSK_KP_8 kp_8)
		(16r40000061 OSK_KP_9 kp_9)
		(16r40000062 OSK_KP_0 kp_0)
		(16r40000063 OSK_KP_PERIOD KP_Decimal)
		"(16r40000065 OSK_APPLICATION application)
		(16r40000066 OSK_POWER power)"
		(16r40000067 OSK_KP_EQUALS kp_equal)
		(16r40000068 OSK_F13 f13)
		(16r40000069 OSK_F14 f14)
		(16r4000006A OSK_F15 f15)
		(16r4000006B OSK_F16 f16)
		(16r4000006C OSK_F17 f17)
		(16r4000006D OSK_F18 f18)
		(16r4000006E OSK_F19 f19)
		(16r4000006F OSK_F20 f20)
		(16r40000070 OSK_F21 f21)
		(16r40000071 OSK_F22 f22)
		(16r40000072 OSK_F23 f23)
		(16r40000073 OSK_F24 f24)
		(16r40000074 OSK_EXECUTE execute)
		(16r40000075 OSK_HELP help)
		(16r40000076 OSK_MENU menu)
		(16r40000077 OSK_SELECT select)
		(16r40000078 OSK_STOP break	)
		(16r40000079 OSK_AGAIN redo)
		(16r4000007A OSK_UNDO undo)
		(16r4000007B OSK_CUT cut)
		(16r4000007C OSK_COPY copy)
		(16r4000007D OSK_PASTE paste)
		(16r4000007E OSK_FIND find)
		"(16r4000007F OSK_MUTE mute)
		(16r40000080 OSK_VOLUMEUP volumeup)
		(16r40000081 OSK_VOLUMEDOWN volumedown)
		(16r40000085 OSK_KP_COMMA kp_comma)
		(16r40000086 OSK_KP_EQUALSAS400 kp_equalsas400)
		(16r40000099 OSK_ALTERASE altErase)"
		(16r4000009A OSK_SYSREQ Sys_Req)
		(16r4000009B OSK_CANCEL cancel)
		(16r4000009C OSK_CLEAR clear)
		(16r4000009D OSK_PRIOR prior)
		"(16r4000009E OSK_RETURN2 return2)
		(16r4000009F OSK_SEPARATOR separator)
		(16r400000A0 OSK_OUT out)
		(16r400000A1 OSK_OPER oper)
		(16r400000A2 OSK_CLEARAGAIN clearagain)
		(16r400000A3 OSK_CRSEL CursorSelect)
		(16r400000A4 OSK_EXSEL ExSelect)
		(16r400000B0 OSK_KP_00 kp_00)
		(16r400000B1 OSK_KP_000 kp_000)
		(16r400000B2 OSK_THOUSANDSSEPARATOR thousandsseparator)
		(16r400000B3 OSK_DECIMALSEPARATOR decimalseparator)
		(16r400000B4 OSK_CURRENCYUNIT currencyunit)
		(16r400000B5 OSK_CURRENCYSUBUNIT currencysubunit)
		(16r400000B6 OSK_KP_LEFTPAREN kp_leftparen)
		(16r400000B7 OSK_KP_RIGHTPAREN kp_rightparen)
		(16r400000B8 OSK_KP_LEFTBRACE kp_leftbrace)
		(16r400000B9 OSK_KP_RIGHTBRACE kp_rightbrace)
		(16r400000BA OSK_KP_TAB kp_tab)
		(16r400000BB OSK_KP_BACKSPACE kp_backspace)
		(16r400000BC OSK_KP_A kp_a)
		(16r400000BD OSK_KP_B kp_b)
		(16r400000BE OSK_KP_C kp_c)
		(16r400000BF OSK_KP_D kp_d)
		(16r400000C0 OSK_KP_E kp_e)
		(16r400000C1 OSK_KP_F kp_f)
		(16r400000C2 OSK_KP_XOR kp_xor)
		(16r400000C3 OSK_KP_POWER kp_power)
		(16r400000C4 OSK_KP_PERCENT kp_percent)
		(16r400000C5 OSK_KP_LESS kp_less)
		(16r400000C6 OSK_KP_GREATER kp_greater)
		(16r400000C7 OSK_KP_AMPERSAND kp_ampersand)
		(16r400000C8 OSK_KP_DBLAMPERSAND kp_dblampersand)
		(16r400000C9 OSK_KP_VERTICALBAR kp_verticalbar)
		(16r400000CA OSK_KP_DBLVERTICALBAR kp_dblverticalbar)
		(16r400000CB OSK_KP_COLON kp_colon)
		(16r400000CC OSK_KP_HASH kp_hash)
		(16r400000CD OSK_KP_SPACE kp_space)
		(16r400000CE OSK_KP_AT kp_at)
		(16r400000CF OSK_KP_EXCLAM kp_exclam)
		(16r400000D0 OSK_KP_MEMSTORE kp_memstore)
		(16r400000D1 OSK_KP_MEMRECALL kp_memrecall)
		(16r400000D2 OSK_KP_MEMCLEAR kp_memclear)
		(16r400000D3 OSK_KP_MEMADD kp_memadd)
		(16r400000D4 OSK_KP_MEMSUBTRACT kp_memsubtract)
		(16r400000D5 OSK_KP_MEMMULTIPLY kp_memmultiply)
		(16r400000D6 OSK_KP_MEMDIVIDE kp_memdivide)
		(16r400000D7 OSK_KP_PLUSMINUS kp_plusminus)
		(16r400000D8 OSK_KP_CLEAR kp_clear)
		(16r400000D9 OSK_KP_CLEARENTRY kp_clearentry)
		(16r400000DA OSK_KP_BINARY kp_binary)
		(16r400000DB OSK_KP_OCTAL kp_octal)
		(16r400000DC OSK_KP_DECIMAL kp_decimal)
		(16r400000DD OSK_KP_HEXADECIMAL kp_hexadecimal)"
		(16r400000E0 OSK_LCTRL Control_L)
		(16r400000E1 OSK_LSHIFT Shift_L)
		(16r400000E2 OSK_LALT Alt_L)
		(16r400000E3 OSK_LGUI Super_L)
		(16r400000E4 OSK_RCTRL Control_R)
		(16r400000E5 OSK_RSHIFT Shift_R)
		(16r400000E6 OSK_RALT Alt_R)
		(16r400000E7 OSK_RGUI Super_R)
		"(16r40000101 OSK_MODE mode)
		(16r40000102 OSK_AUDIONEXT audioNext)
		(16r40000103 OSK_AUDIOPREV audioPrev)
		(16r40000104 OSK_AUDIOSTOP audioStop)
		(16r40000105 OSK_AUDIOPLAY audioPlay)
		(16r40000106 OSK_AUDIOMUTE audioMute)
		(16r40000107 OSK_MEDIASELECT mediaSelect)
		(16r40000108 OSK_WWW www)
		(16r40000109 OSK_MAIL mail)
		(16r4000010A OSK_CALCULATOR calculator)
		(16r4000010B OSK_COMPUTER computer)
		(16r4000010C OSK_AC_SEARCH ac_search)
		(16r4000010D OSK_AC_HOME ac_home)
		(16r4000010E OSK_AC_BACK ac_back)
		(16r4000010F OSK_AC_FORWARD ac_forward)
		(16r40000110 OSK_AC_STOP ac_stop)
		(16r40000111 OSK_AC_REFRESH ac_refresh)
		(16r40000112 OSK_AC_BOOKMARKS ac_bookmarks)
		(16r40000113 OSK_BRIGHTNESSDOWN brightnessDown)
		(16r40000114 OSK_BRIGHTNESSUP brightnessUp)
		(16r40000115 OSK_DISPLAYSWITCH displaySwitch)
		(16r40000116 OSK_KBDILLUMTOGGLE kbdIllumToggle)
		(16r40000117 OSK_KBDILLUMDOWN kbdIllumDown)
		(16r40000118 OSK_KBDILLUMUP kbdIllumUp)
		(16r40000119 OSK_EJECT eject)
		(16r4000011A OSK_SLEEP sleep)"
	)! !

!OSKeyUpEvent commentStamp: ''!
This event is delivered when user releases previously pressed key!
!OSKeyUpEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitKeyUpEvent: self! !

!OSKeyboardEvent commentStamp: ''!
i am the root of keyboard events hierarchy.

The scan code represents an unique number identifying a key and comes directly from OS.
Some keys can be directly translated to corresponding character(s) by OS and thus such events will carry character ~= nil.  Character translation is not reliable with this event because many characters are introduced by using multiples key strokes. For a reliable way for getting text input, it is better to listen for the OSTextInputEvent.

character - An character representation of the key.
modifiers - Extra flags telling if special keys such as ctrl, alt, cmd, etc are being held.
position - The position of the mouse cursor when the key was pressed.
scanCode - Raw keyboard scan scode.
repeat - This value is non-zero if this event was originated by a repeated key stroke.
symbol - A virtual platform independent identifier for a keyboard key. Valid values are defined in the OSKeySymbols pool dictionary.!
!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
position
	
	^ position! !

!OSKeyboardEvent methodsFor: 'keymapping' stamp: ''!
asKeyCombination
	| modifier control command shift alt char |

	control := self modifiers ctrl.
	command := self modifiers cmd.
	shift := self modifiers shift.
	alt := self modifiers alt.
	char := self modifiedCharacter.
	
	(shift | command | control | alt)
		ifFalse: [^ KMSingleKeyCombination from: char ].
	
	modifier := KMNoShortcut new.
	control ifTrue: [ modifier := modifier + KMModifier ctrl ].
	command ifTrue: [ modifier := modifier + KMModifier command ].
	shift ifTrue: [ modifier := modifier + KMModifier shift ].
	alt ifTrue: [ modifier := modifier + KMModifier alt ].

	^ modifier + char! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
character
	
	^ character! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
characterCode
	"answer the unicode value"
	
	^ character ifNil: [0] ifNotNil: [ character charCode ]! !

!OSKeyboardEvent methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	modifiers := OSStateModifiers new.
	handled := false! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
character: anObject
	
	character := anObject! !

!OSKeyboardEvent methodsFor: 'keymapping' stamp: ''!
modifiedCharacter
	
	self character ifNotNil: [ :c | ^ c ].
	self symbol <= 16rFF ifTrue: [ ^ Character value: self symbol ]. 
	^ Character value: 0! !

!OSKeyboardEvent methodsFor: 'keymapping' stamp: ''!
wasHandled
	^ handled! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
position: anObject
	
	position := anObject! !

!OSKeyboardEvent methodsFor: 'keymapping' stamp: ''!
wasHandled: aBoolean
	handled := aBoolean! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
repeat: anObject
	repeat := anObject! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
symbol
	
	^ symbol! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
repeat
	^ repeat! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
symbol: anObject
	
	symbol := anObject! !

!OSKeyboardEvent methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream space; nextPutAll: 'scanCode: '; print: scanCode.
	stream space; nextPutAll: 'symbol '; print: symbol.
	stream space; nextPutAll: 'character '; print: character.
	stream space; nextPutAll: 'modifiers: '; print: modifiers.! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
scanCode: anObject
	
	scanCode := anObject! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
modifiers
	
	^ modifiers! !

!OSKeyboardEvent methodsFor: 'accessing' stamp: ''!
scanCode
	
	^ scanCode! !

!OSMouseButtonEvent commentStamp: ''!
i am the root of various mouse button events.!
!OSMouseButtonEvent methodsFor: 'accessing' stamp: ''!
wheelDirection
	"If button is wheel button (>3), answer direction (#up/#down)"
	^ self button = 4 
		ifTrue: [ #up ] 
		ifFalse: [ #down ]! !

!OSMouseButtonEvent methodsFor: 'testing' stamp: ''!
isWheel
	^ self button > 3! !

!OSMouseButtonEvent methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream 
		space; 
		print: button! !

!OSMouseButtonEvent methodsFor: 'accessing' stamp: ''!
button
	
	^ button! !

!OSMouseButtonEvent methodsFor: 'accessing' stamp: ''!
button: anObject
	
	button := anObject! !

!OSMouseButtonPressEvent commentStamp: ''!
i am delivered when user presses a mouse button!
!OSMouseButtonPressEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitMouseButtonPressEvent: self! !

!OSMouseButtonReleaseEvent commentStamp: ''!
i am delivered when user releases a mouse button!
!OSMouseButtonReleaseEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitMouseButtonReleaseEvent: self! !

!OSMouseEvent commentStamp: ''!
i am the root of various mouse events.

Note, that my subclasses care to represent only the most basic events, not the synthethic ones, like click or double-click, which are result of interpreting the sequence of raw events.!
!OSMouseEvent methodsFor: 'accessing' stamp: ''!
position
	
	^ position! !

!OSMouseEvent methodsFor: 'accessing' stamp: ''!
delta
	
	^ delta! !

!OSMouseEvent methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	modifiers := OSStateModifiers new! !

!OSMouseEvent methodsFor: 'accessing' stamp: ''!
position: anObject
	
	position := anObject! !

!OSMouseEvent methodsFor: 'accessing' stamp: ''!
buttons
	^ modifiers buttons! !

!OSMouseEvent methodsFor: 'accessing' stamp: ''!
modifiers
	^ modifiers! !

!OSMouseEvent methodsFor: 'accessing' stamp: ''!
delta: anObject
	
	delta := anObject! !

!OSMouseMoveEvent commentStamp: ''!
i am delivered when user moves a mouse!
!OSMouseMoveEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitMouseMoveEvent: self! !

!OSMouseWheelEvent commentStamp: ''!
i am delivered when user scrolling the mouse wheel!
!OSMouseWheelEvent methodsFor: 'accessing' stamp: ''!
scrollVertical: anObject
	
	scrollVertical := anObject! !

!OSMouseWheelEvent methodsFor: 'accessing' stamp: ''!
scrollVertical
	
	^ scrollVertical! !

!OSMouseWheelEvent methodsFor: 'accessing' stamp: ''!
scrollHorizontal
	
	^ scrollHorizontal! !

!OSMouseWheelEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitMouseWheelEvent: self! !

!OSMouseWheelEvent methodsFor: 'accessing' stamp: ''!
scrollHorizontal: anObject
	
	scrollHorizontal := anObject! !

!OSNullBackendWindow commentStamp: ''!
i am a handle for null window , created using OSNullWindowDriver.!
!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
position
	^ attributes position! !

!OSNullBackendWindow methodsFor: 'factory' stamp: ''!
newGenericRenderer
	^ renderer := OSWindowNullGenericRenderer new! !

!OSNullBackendWindow methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	isTextInputActive := false! !

!OSNullBackendWindow methodsFor: 'text input' stamp: ''!
isTextInputActive
	^ isTextInputActive! !

!OSNullBackendWindow methodsFor: 'factory' stamp: ''!
newOpenGLRenderer
	self subclassResponsibility! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
platformSpecificHandle
	^ nil! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
clipboardText: anObject! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
position: position
	attributes position: position! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
title: anObject! !

!OSNullBackendWindow methodsFor: 'text input' stamp: ''!
startTextInput
	isTextInputActive := true! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
bounds: aRectangle! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
extent
	^ attributes extent! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
hide! !

!OSNullBackendWindow methodsFor: 'factory' stamp: ''!
newFormRenderer: form
	^ renderer := OSNullFormRenderer new form: form! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
show! !

!OSNullBackendWindow methodsFor: 'factory' stamp: ''!
newAthensRenderer
	self subclassResponsibility! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
isValid
	^ true! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
clipboardText
	^ ''! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
attributes: newAttributes
	attributes := newAttributes! !

!OSNullBackendWindow methodsFor: 'initialize' stamp: ''!
destroy! !

!OSNullBackendWindow methodsFor: 'text input' stamp: ''!
stopTextInput
	isTextInputActive := false! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
extent: newExtent
	attributes extent: newExtent! !

!OSNullBackendWindow methodsFor: 'accessing' stamp: ''!
title
	^attributes title! !

!OSNullBackendWindow class methodsFor: 'instance creation' stamp: ''!
fromAttributes: attributes for: anOSWindow 
	^ self new attributes: attributes! !

!OSNullFormRenderer commentStamp: ''!
i just a stub for rendering nothing , so that all update requests (like from Morhpic), are simply ignored!
!OSNullFormRenderer methodsFor: 'size' stamp: ''!
newExtent: anExtent! !

!OSNullFormRenderer methodsFor: 'morphic integration' stamp: ''!
updateAreas: allDamage immediate: forceToScreen
	"Do Nothing"! !

!OSNullFormRenderer methodsFor: 'updating screen' stamp: ''!
updateAll
	"Do nothing"! !

!OSNullFormRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangle: aRectangle
	"Do nothing"! !

!OSNullWindowDriver commentStamp: ''!
I provide a mock (or null) driver, which can create a valid OSWindow instances, despite the fact that underlaying OS may not support any notion of windows or even graphical user interface.

I can be used for testing (by picking as a preferrable driver in window attributes),
or as a default driver while running image in headless mode.

Using null driver allows most of the code which relies on existance of at least single main window to work flawlessly, by simply ignoring all requests/commands passed to it.!
!OSNullWindowDriver methodsFor: 'window creation' stamp: ''!
createWindowWithAttributes: anOSWindowAttributes osWindow: osWindow
	^ OSNullBackendWindow fromAttributes: anOSWindowAttributes for: osWindow! !

!OSNullWindowDriver methodsFor: 'testing' stamp: ''!
isNullDriver
	^ true! !

!OSNullWindowDriver class methodsFor: 'testing' stamp: ''!
isSupported
	"Yep, i am always supported"
	^ true! !

!OSPlatform commentStamp: ''!
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: 'accessing' stamp: 'nil'!
current
	^ self! !

!OSPlatform methodsFor: '*Keymapping-Core' stamp: ''!
shortcutPrinter
	"Return a generic shortcut printer"
	^ KMShortcutPrinter new! !

!OSPlatform methodsFor: 'testing' stamp: 'nil'!
isMacOS
	^ false! !

!OSPlatform methodsFor: 'testing' stamp: 'nil'!
isWin64
	^ false! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
virtualKey: virtualKeyCode
	"Subclass responsibility to override if necessary"
	^nil! !

!OSPlatform methodsFor: '*UnifiedFFI' stamp: ''!
runCommand: aCommand
	"Run the given operating system command."
	
	^LibC runCommand: aCommand! !

!OSPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiInt64Alignment
	"By default is 4, windows and maybe others can use other"
	^ Smalltalk wordSize! !

!OSPlatform methodsFor: '*System-OSEnvironments' stamp: ''!
environment
	^ OSEnvironment current! !

!OSPlatform methodsFor: '*Spec2-Core' stamp: ''!
configureApplication: anApplication configuration: aConfiguration
! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
defaultEncoding

	^ ZnCharacterEncoder utf8! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
family
	"Returns a symbol specific to the platform family (MacOSX, Windows, Unix, RiscOS).
	This may need to be extended if there are new platforms added or significant differences within a platform family arise (as was the case between MacOS 9 and X)."

	self subclassResponsibility! !

!OSPlatform methodsFor: 'testing' stamp: 'nil'!
isUnix
	^ false! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
subtype
	"Return the subType of the platform we're running on"

	^ (Smalltalk vm getSystemAttribute: 1003)! !

!OSPlatform methodsFor: 'testing' stamp: 'nil'!
isWin32
	^ false! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
version
	"Return the version number string of the platform we're running on"

	^ self class currentVersion! !

!OSPlatform methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
defaultModifier

	^ self subclassResponsibility! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
currentWorkingDirectoryPathWithBufferSize: aBufferSize
	| buffer |
	buffer := ByteArray new: aBufferSize.
	^ self currentWorkingDirectoryPathWithBuffer: buffer! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
lineEnding

	^ self subclassResponsibility! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
currentWorkingDirectoryPathWithBuffer: aByteArray
	<primitive: 'primitiveGetCurrentWorkingDirectory' module: '' error: ec>
	
	^ self primitiveFailed ! !

!OSPlatform methodsFor: '*System-Sources' stamp: ''!
potentialLocationsOfSourcesFile
	"Return a collection of directories where the PharoVXX.sources should be searched."
	^ self subclassResponsibility! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
defaultMaximumPathLength
	"This method returns the default maximum path length for the getCurrentWorkingDirectory implementation"
	 ^self subclassResponsibility 
! !

!OSPlatform methodsFor: 'compatbility' stamp: 'nil'!
platformName
	^ self name! !

!OSPlatform methodsFor: 'testing' stamp: 'nil'!
isUnix64
	^ false! !

!OSPlatform methodsFor: 'system startup' stamp: 'nil'!
shutDown: quitting
	"Pharo is shutting down. If this platform requires specific shutdown code, this is a great place to put it."
! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
menuShortcutString
	^ self subclassResponsibility! !

!OSPlatform methodsFor: '*Network-Kernel' stamp: ''!
configureHttpProxy
	"We only know how on Mac"! !

!OSPlatform methodsFor: 'testing' stamp: 'nil'!
isWindows
	^ false! !

!OSPlatform methodsFor: 'testing' stamp: 'nil'!
isMacOSX
	^ false! !

!OSPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiLongAlignment
	"By default is 4, windows and maybe others can use other"
	^ Smalltalk wordSize! !

!OSPlatform methodsFor: '*System-CommandLine' stamp: ''!
newTerminfo
	"By default we create a TermInfoCharacter, that uses escaping characters to style the text in a terminal.
	This imp is a hack: the platform should offer way to set it"
	^ TermInfoCharacter new! !

!OSPlatform methodsFor: 'testing' stamp: 'nil'!
isUnix32
	^ false! !

!OSPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiCallingConvention
	^ #cdecl! !

!OSPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiPointerAlignment
	"By default is 4, windows and maybe others can use other"
	^ Smalltalk wordSize! !

!OSPlatform methodsFor: '*UnifiedFFI' stamp: ''!
resultOfCommand: aCommand
	"Run the given operating system command and return the piped command line result."
	
	^LibC resultOfCommand: aCommand! !

!OSPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiLibraryName: aLibrary 
	^ self subclassResponsibility! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
name
	"Return the name of the platform we're running on"

	^ Smalltalk vm operatingSystemName! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
currentWorkingDirectoryRawPath
	"This method calls the method getPwdViaFFI with argument of a buffer size. 
	By default it uses the defaultMaximumPathLength of each subclass as the buffer size.
	We return a raw byte array that should be decoded with the proper encoding."
	^ (self currentWorkingDirectoryPathWithBufferSize: self defaultMaximumPathLength) asByteArray
! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
windowSystemName			
	"Return the name of the window system currently being used for display."

	^ Smalltalk vm getSystemAttribute: 1005! !

!OSPlatform methodsFor: '*OSWindow-Core' stamp: ''!
osWindowScreenScaleFactorBaseDPI
	^ 96! !

!OSPlatform methodsFor: '*OSWindow-SDL2' stamp: ''!
sdlPlatform

	^ SDLNullPlatform new! !

!OSPlatform methodsFor: 'accessing' stamp: 'nil'!
currentWorkingDirectoryPath
	"We MUST decode raw bytes to support non-Ascii characters"
	^ self currentWorkingDirectoryRawPath decodeWith: self defaultEncoding! !

!OSPlatform methodsFor: 'testing' stamp: 'nil'!
isLinux
	^ false! !

!OSPlatform methodsFor: 'testing' stamp: 'nil'!
isX11
	^ self windowSystemName = 'X11'! !

!OSPlatform methodsFor: 'system startup' stamp: 'nil'!
startUp: resuming
	"Pharo is starting up. If this platform requires specific initialization, this is a great place to put it."
! !

!OSPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiFloat64Alignment
	"By default is 4, windows and maybe others can use other"
	^ Smalltalk wordSize! !

!OSPlatform methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor

	self subclassResponsibility	! !

!OSPlatform methodsFor: 'compatbility' stamp: 'nil'!
platformFamily
	^ self family! !

!OSPlatform class methodsFor: 'examples' stamp: 'nil'!
example
	<example>
	Smalltalk os current inspect! !

!OSPlatform class methodsFor: 'class initialization' stamp: 'nil'!
initialize
	"OSPlatform initialize"

	SessionManager default
		registerSystemClassNamed: self name
		atPriority: 50.	
	self startUp: true.! !

!OSPlatform class methodsFor: 'accessing' stamp: 'nil'!
current
	"Answer the current platform"
	^Current! !

!OSPlatform class methodsFor: 'private' stamp: 'nil'!
determineActivePlatform
	"Look for the matching platform class"
	^ self allSubclasses 
		detect: [ :any | any isActivePlatform ].
! !

!OSPlatform class methodsFor: 'system startup' stamp: 'nil'!
shutDown: isImageQuitting
	"The system is going down"
	Current ifNotNil: [ Current shutDown: isImageQuitting ].
! !

!OSPlatform class methodsFor: 'testing' stamp: 'nil'!
isActivePlatform
	"Answer whether the receiver is the active platform"
	^false! !

!OSPlatform class methodsFor: '*Deprecated10' stamp: ''!
currentPlatformName
	"Return the name of the platform we're running on"

	self deprecated: 'Use ''Smalltalk vm operatingSystemName'' instead'.

	^ Smalltalk vm operatingSystemName! !

!OSPlatform class methodsFor: 'system startup' stamp: 'nil'!
startUp: isImageStarting
	"Determine the current platform."
	
	isImageStarting ifFalse: [  ^ self ].
	
	Current := self determineActivePlatform new.
	Current startUp: isImageStarting! !

!OSPlatform class methodsFor: 'system attributes' stamp: 'nil'!
currentVersion
	"Return the version number string of the platform we're running on"

	^ (Smalltalk vm getSystemAttribute: 1002) asString! !

!OSPlatformTest methodsFor: 'tests' stamp: ''!
testAPI
	"A test to make sure the full API will work"
	Smalltalk os
		isMacOS;
		isMacOSX;
		isWin32;
		isWin64;
		isWindows;
		isUnix;
		isLinux;
		isX11;
		name;
		subtype;
		family! !

!OSPlatformTest methodsFor: 'tests' stamp: ''!
testCurrentWorkingDirectoryWithBufferSize
	"This is a test to make sure getCurrentWorkingDirectoryWithBufferSize is working"
	
 self assert: FileSystem workingDirectory fullName equals:  (OSPlatform current currentWorkingDirectoryPathWithBufferSize: 1024) .
 self assert: 'relativePath' asFileReference asAbsolute parent fullName equals: (OSPlatform current currentWorkingDirectoryPathWithBufferSize: 1024)! !

!OSPlatformTest methodsFor: 'tests' stamp: ''!
testCurrentWorkingDirectory
	"This is a test to make sure getCurrentWorkingDirectory is working"

 self assert: FileSystem workingDirectory fullName equals:  OSPlatform current currentWorkingDirectoryPath.
 self assert: 'relativePath' asFileReference asAbsolute parent fullName equals: OSPlatform current currentWorkingDirectoryPath! !

!OSPlatformTest methodsFor: 'tests' stamp: ''!
testStartUpList
	"This test documents issue http://code.google.com/p/pharo/issues/detail?id=838"
	
	| startupList |
	startupList := (SessionManager default startupList collect: [:each | each handledId]).
	self should: [ (startupList indexOf: #Delay) < (startupList indexOf: #GlobalIdentifier) ]! !

!OSPlatformTest methodsFor: 'tests' stamp: ''!
testNewFileInWorkingDirectory
	"This is a test to make sure new files are created in the current working directory"

	| file |
	file := File named: 'asd.txt'.
	file writeStream close.
	self
		assert: file name asPath parent
		equals: OSPlatform current currentWorkingDirectoryPath asPath.
	file delete! !

!OSPlatformVisitor commentStamp: ''!
A visitor to be subclassed to write platform specific code without needing to add extension methods on OSPlatform subclasses.!
!OSPlatformVisitor methodsFor: 'visiting' stamp: 'nil'!
visitUnix: aPlatform

	^ self visitGeneric: aPlatform! !

!OSPlatformVisitor methodsFor: 'visiting' stamp: 'nil'!
visit 

	^ OSPlatform current accept: self! !

!OSPlatformVisitor methodsFor: 'visiting' stamp: 'nil'!
visitWindows32: aPlatform 

	^ self visitWindows: aPlatform! !

!OSPlatformVisitor methodsFor: 'visiting' stamp: 'nil'!
visitWindows64: aPlatform 

	^ self visitWindows: aPlatform! !

!OSPlatformVisitor methodsFor: 'visiting' stamp: 'nil'!
visitMacOS: aPlatform

	^ self visitGeneric: aPlatform! !

!OSPlatformVisitor methodsFor: 'visiting' stamp: 'nil'!
visitWindows: aPlatform 

	^ self visitGeneric: aPlatform! !

!OSPlatformVisitor methodsFor: 'visiting' stamp: 'nil'!
visitGeneric: aPlatform
	! !

!OSPlatformVisitor methodsFor: 'visiting' stamp: 'nil'!
visitUnix32: aPlatform

	^ self visitUnix: aPlatform! !

!OSPlatformVisitor methodsFor: 'visiting' stamp: 'nil'!
visitMacOSX: aPlatform

	^ self visitMacOS: aPlatform! !

!OSPlatformVisitor methodsFor: 'visiting' stamp: 'nil'!
visitUnix64: aPlatform

	^ self visitUnix: aPlatform! !

!OSSDL2AthensRenderer commentStamp: ''!
I am an Athens renderer which uses SDL2.!
!OSSDL2AthensRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangle: aRectangle
	mutex critical: [
		| intersection |
		self validate ifFalse: [ ^ self ].
		intersection := aRectangle
			intersect: (0 @ 0 corner: textureExtent)
			ifNone: [ ^ self ].

		self drawTexturePixelsWith: [ :textureForm |
			self primitiveUpdateRectangle: intersection externalForm: textureForm
		].
	]! !

!OSSDL2AthensRenderer methodsFor: 'private' stamp: ''!
drawTexturePixelsWith: aBlock
	| pixels pitch externalForm |
	pixels := ExternalAddress new.
	pitch := ExternalAddress allocate: 4 bytesDuring: [:pitchHolder |
		texture lockPixels: pixels pitch: pitchHolder.
		pitchHolder signedLongAt: 1 ].

	externalForm := OSSDL2ExternalForm extent: textureExtent depth: 32 bits: pixels.
	[
		aBlock value: externalForm
	] ensure: [
		texture unlock.
		externalForm destroySurface
	].! !

!OSSDL2AthensRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangles: allDamage
	mutex critical: [
		| fullBounds |
		self validate ifFalse: [ ^ self ].

		fullBounds := 0 @ 0 corner: textureExtent.
		self drawTexturePixelsWith: [ :textureForm |
			| intersection |
			allDamage do: [ :rectangle |
				intersection := rectangle intersect: fullBounds ifNone: [ nil ].
				intersection ifNotNil: [
					self primitiveUpdateRectangle: rectangle externalForm: textureForm.
				]
			].
		].
	]! !

!OSSDL2AthensRenderer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	mutex := Mutex new.! !

!OSSDL2AthensRenderer methodsFor: 'private' stamp: ''!
primitiveUpdateRectangle: rectangle externalForm: externalForm
	externalForm getCanvas
		drawImage: athensSurface asForm at: rectangle origin sourceRect: rectangle! !

!OSSDL2AthensRenderer methodsFor: 'drawing' stamp: ''!
prepareForDrawing
	mutex critical: [
		textureExtent ~= renderer outputExtent ifTrue: [ self resized ].
	].! !

!OSSDL2AthensRenderer methodsFor: 'updating screen' stamp: ''!
present
	mutex critical: [
		self validate ifFalse: [ ^ self ].
		renderer
			clear;
			copy: texture;
			present
	]! !

!OSSDL2AthensRenderer methodsFor: 'initialization' stamp: ''!
initializeWindowHandle: aBackendWindow
	self initialize.
	self backendWindow: aBackendWindow.
	renderer := backendWindow sdl2Window createDefaultRenderer.
	mutex critical: [
		self resetResources.
	].! !

!OSSDL2AthensRenderer methodsFor: 'accessing' stamp: ''!
surface
	^ mutex critical: [super surface]! !

!OSSDL2AthensRenderer methodsFor: 'updating screen' stamp: ''!
validate
	self checkSession.
	athensSurface ifNil: [ ^ false ].
	(texture isNil or: [ texture isNull ]) ifTrue: [ ^ false ].
	(renderer isNil or: [ renderer isNull ]) ifTrue: [ ^ false ].
	renderer outputExtent ~= textureExtent ifTrue: [ ^ false ].
	^ true! !

!OSSDL2AthensRenderer methodsFor: 'accessing' stamp: ''!
athensSurface
	^ mutex critical: [super athensSurface]! !

!OSSDL2AthensRenderer methodsFor: 'updating screen' stamp: ''!
resized
	mutex critical: [
		self resetResources.
		super resized
	]! !

!OSSDL2AthensRenderer methodsFor: 'updating screen' stamp: ''!
updateAll
	mutex critical: [
		self validate ifFalse: [ ^ self ].

		self drawTexturePixelsWith: [ :textureForm |
			self primitiveUpdateRectangle: (0 @ 0 corner: textureExtent) externalForm: textureForm.
		].
	]! !

!OSSDL2AthensRenderer methodsFor: 'updating resources' stamp: ''!
resetResources
	| extent |
	self checkSession.
	extent := renderer outputExtent.
	athensSurface := AthensCairoSurface extent: extent.
	texture ifNotNil: [
		texture destroy.
		texture := nil.
	].
	texture := renderer
		createTextureFormat: SDL_PIXELFORMAT_XRGB8888
		access: SDL_TEXTUREACCESS_STREAMING
		width: extent x
		height: extent y.
	textureExtent := extent.! !

!OSSDL2AthensRenderer methodsFor: 'deleting' stamp: ''!
destroy

	mutex critical: [
		texture ifNotNil: [ texture destroy ].
		texture := nil.
		renderer ifNotNil: [ renderer destroy ].
		renderer := nil.
	].

	super destroy.! !

!OSSDL2AthensRenderer methodsFor: 'updating screen' stamp: ''!
pixelExtent
	mutex critical: [
		(renderer isNil or: [ renderer isNull ]) ifFalse: [ ^ renderer outputExtent ].
	].
	^ super pixelExtent! !

!OSSDL2AthensRenderer class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #for:'! !

!OSSDL2AthensRenderer class methodsFor: 'instance creation' stamp: ''!
for: aWindowHandle
	^ self basicNew
		initializeWindowHandle: aWindowHandle;
		yourself! !

!OSSDL2BackendWindow commentStamp: ''!
I am the OSWindowHandle interface implemented using SDL2 library

my handle is an SDL_Window!
!OSSDL2BackendWindow methodsFor: 'window management' stamp: ''!
restore

	sdl2Window restore! !

!OSSDL2BackendWindow methodsFor: 'cursor' stamp: ''!
setMouseCursor: cursor mask: mask andScale: scale

	| sdlCursor |
	sdlCursor := self convertCursor: cursor withMask: mask andScale: scale.

	sdlCursor ifNotNil: [ sdlCursor setCursor ].
	currentCursor ifNotNil: [ currentCursor freeCursor ].
	currentCursor := sdlCursor! !

!OSSDL2BackendWindow methodsFor: 'instance creation' stamp: ''!
newGenericRenderer
	^ renderer := OSSDL2GenericRenderer new 
		backendWindow: self;
		createSDL2Renderer;
		yourself! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
visitWindowEvent: windowEvent
	osWindow ifNil: [ ^self ].
	
	windowEvent event = SDL_WINDOWEVENT_EXPOSED ifTrue: [
		^ ((OSWindowExposeEvent for: osWindow) timestamp: windowEvent timestamp) deliver ].
	windowEvent event = SDL_WINDOWEVENT_HIDDEN ifTrue: [ 
		^ (OSWindowHiddenEvent for: osWindow) deliver ].
	windowEvent event = SDL_WINDOWEVENT_SHOWN ifTrue: [ 
		^ ((OSWindowShownEvent for: osWindow) timestamp: windowEvent timestamp) deliver ].
	windowEvent event = SDL_WINDOWEVENT_CLOSE ifTrue: [ 
		^ (OSWindowCloseEvent for: osWindow) deliver ].
	windowEvent event = SDL_WINDOWEVENT_MOVED ifTrue: [
		self fetchDPIAndRaiseEvent.
		^ (OSWindowMoveEvent for: osWindow) deliver
	].
	windowEvent event = SDL_WINDOWEVENT_RESIZED ifTrue: [ 
		^ (OSWindowResizeEvent for: osWindow)
				width: windowEvent data1;
				height: windowEvent data2;
				deliver ].
	windowEvent event = SDL_WINDOWEVENT_ENTER ifTrue: [ 
		^ (OSWindowMouseEnterEvent for: osWindow) deliver ].
	windowEvent event = SDL_WINDOWEVENT_LEAVE ifTrue: [ 
		^ (OSWindowMouseLeaveEvent for: osWindow) deliver ].
	windowEvent event = SDL_WINDOWEVENT_FOCUS_GAINED ifTrue: [ 
		^ (OSWindowFocusInEvent for: osWindow) deliver ].
	windowEvent event = SDL_WINDOWEVENT_FOCUS_LOST ifTrue: [ 
		^ (OSWindowFocusOutEvent for: osWindow) deliver ].
	windowEvent event = SDL_WINDOWEVENT_MAXIMIZED ifTrue: [ 
		^ (OSWindowMaximizedEvent for: osWindow) deliver ].
	windowEvent event = SDL_WINDOWEVENT_MINIMIZED ifTrue: [ 
		^ (OSWindowMinimizedEvent for: osWindow) deliver ]! !

!OSSDL2BackendWindow methodsFor: 'window management' stamp: ''!
minimize

	sdl2Window minimize! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
raise

	sdl2Window raise! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
position: aPoint
	sdl2Window setPositionX: aPoint x asInteger y: aPoint y asInteger! !

!OSSDL2BackendWindow methodsFor: 'cursor' stamp: ''!
showCursor: aBoolean
	SDL2 showCursor: (aBoolean ifTrue: [SDL_ENABLE] ifFalse: [SDL_DISABLE])! !

!OSSDL2BackendWindow methodsFor: 'window management' stamp: ''!
setDraggableArea: aRectangle

	| myCallback sdlRect |
	
	sdlRect := aRectangle asSDLRect.
	
	myCallback := DraggableCallback on: [ :aWindow :pt :data |
			(pt x > sdlRect x) & (pt x < sdlRect w) & (pt y > sdlRect y) & (pt y < sdlRect h) ifTrue: [ 1 ] ifFalse: [ 0 ].
		].
	
	^sdl2Window setHitTest: myCallback! !

!OSSDL2BackendWindow methodsFor: 'window management' stamp: ''!
toggleBorderOn

	sdl2Window toggleBorder: true! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
borderless: aBoolean
	sdl2Window toggleBorder: aBoolean not! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
hide
	sdl2Window hide! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
verticalDPI
	self fetchDPIAndRaiseEvent.
	^ verticalDPI! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
visitMouseMotionEvent: sdlEvent
	| osEvent |
	osEvent := OSMouseMoveEvent for: osWindow.
	osEvent position: sdlEvent x @ sdlEvent y;
		delta: sdlEvent xrel @ sdlEvent yrel.

	self convertButtonState: sdlEvent state modState: SDL2 modState modifiers: osEvent modifiers.
	^ osEvent deliver! !

!OSSDL2BackendWindow methodsFor: 'cursor' stamp: ''!
convertCursor: cursor withMask: mask andScale: scale

	| maskBits extent cursorBits offset sdlCursor scaledCursor scaledMask scaleToUse |

	scaleToUse := scale ceiling.

	^ self 
		lookupSystemCursor: cursor 
		ifNotFound: [ 
			scaledCursor := cursor scaledToSize: (cursor extent * scaleToUse).
			scaledMask := mask scaledToSize: (mask extent * scaleToUse).

			cursorBits := self convertCursor: scaledCursor.
			maskBits := self convertCursor: scaledMask.
			extent := scaledCursor extent.
			offset := scaledCursor offset.
			sdlCursor := SDL2
				             createCursor: cursorBits
				             mask: maskBits
				             w: extent x
				             h: extent y
				             hotX: offset x negated
				             hotY: offset y negated ].! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
icon: aForm
	| convertedIcon surface |
	aForm ifNil: [ ^self ].
	
	convertedIcon := aForm unhibernate; asFormOfDepth: 32.
	surface := SDL2 createRGBSurfaceFromPixels: convertedIcon bits
			width: convertedIcon width height: convertedIcon height
			depth: 32 pitch: convertedIcon width *4
			rmask: 16r00ff0000 
			gmask: 16r000ff00
			bmask: 16r00000ff
			amask: 16rff000000.
	sdl2Window icon: surface.
	iconSurface ifNotNil: [ SDL2 freeSurface: surface ].
	iconSurface := surface! !

!OSSDL2BackendWindow methodsFor: 'testing' stamp: ''!
isVisible
	^ (self getFlags bitAnd: SDL_WINDOW_SHOWN) = SDL_WINDOW_SHOWN! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
visitMouseButtonUpEvent: event
	| osEvent |
	osEvent := OSMouseButtonReleaseEvent for: osWindow.
	osEvent button: event button;
			position: event x @ event y.
	
	self convertButtonState: SDL2 mouseState modState: SDL2 modState modifiers: osEvent modifiers.
	^ osEvent deliver! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
mapSpecialCharacter: symbol
	^ SDL2SpecialCharacterMapping mapKeySymbol: symbol ifAbsent: [ ^ nil ]! !

!OSSDL2BackendWindow methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self class initializeSlots: self! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
clipboardText: aText
	SDL2 clipboardText: aText! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
convertButtonState: mouseState modState: modState modifiers: modifiers
	| shift ctrl alt ralt gui |
	modifiers buttons button1: (mouseState bitAnd: SDL_BUTTON_LMASK) ~= 0.
	modifiers buttons button2: (mouseState bitAnd: SDL_BUTTON_MMASK) ~= 0.
	modifiers buttons button3: (mouseState bitAnd: SDL_BUTTON_RMASK) ~= 0.
	modifiers buttons button4: (mouseState bitAnd: SDL_BUTTON_X1MASK) ~= 0.
	modifiers buttons button5: (mouseState bitAnd: SDL_BUTTON_X2MASK) ~= 0.

	shift := (modState bitAnd: KMOD_SHIFT) ~= 0.
	ctrl := (modState bitAnd: KMOD_CTRL) ~= 0.
	alt := (modState bitAnd: KMOD_LALT) ~= 0.
	ralt := (modState bitAnd: KMOD_RALT) ~= 0.
	gui := (modState bitAnd: KMOD_GUI) ~= 0.

	modifiers leftShift: shift; rightShift: shift;
		leftCtrl: ctrl; rightCtrl: ctrl;
		leftAlt: alt; rightAlt: ralt;
		leftCmd: gui; rightCmd: gui! !

!OSSDL2BackendWindow methodsFor: 'private' stamp: ''!
fetchDPIAndRaiseEvent
	self fetchDPI ifTrue: [
		(OSWindowResolutionChangeEvent for: osWindow)
			horizontalDPI: horizontalDPI;
			verticalDPI: verticalDPI;
			diagonalDPI: diagonalDPI;
			screenScaleFactor: screenScaleFactor;
			deliver
	]! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
extent
	| w h |
	w := ByteArray new: 4.
	h := ByteArray new: 4.
	sdl2Window getSizeW: w h: h.
	^ (w signedLongAt: 1) @ (h signedLongAt: 1)! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
fullscreen: aBoolean

	aBoolean 
		ifTrue: [ sdl2Window fullscreen: SDL_WINDOW_FULLSCREEN_DESKTOP ] 
		ifFalse: [ sdl2Window fullscreen: 0 ]! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
show
	sdl2Window show! !

!OSSDL2BackendWindow methodsFor: 'cursor' stamp: ''!
systemCursorConversionTable

	^ OSPlatform current sdlPlatform systemCursorConversionTable! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
visitMouseButtonDownEvent: event
	| osEvent |
	osEvent := OSMouseButtonPressEvent for: osWindow.
	osEvent button: event button;
			position: event x @ event y.
	
	self convertButtonState: SDL2 mouseState modState: SDL2 modState modifiers: osEvent modifiers.
	^ osEvent deliver! !

!OSSDL2BackendWindow methodsFor: 'instance creation' stamp: ''!
newAthensRenderer
	^ renderer := OSSDL2AthensRenderer for: self! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
handleNewSDLEvent: sdlEvent
	^ sdlEvent accept: self! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
mousePosition
	| x y |
	x := ByteArray new: 4.
	y := ByteArray new: 4.
	SDL2 mouseStateX: x y: y.
	^ ( x signedLongAt: 1) @ (y signedLongAt: 1)! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
deliverGlobalEvent: aGlobalEvent
	^ osWindow deliverGlobalEvent: aGlobalEvent! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
visitKeyDownEvent: event
	| osEvent keysym |
	keysym := event keysym.
	osEvent := OSKeyDownEvent for: osWindow.
	osEvent scanCode: keysym scancode;
			symbol: keysym sym;
			repeat: event repeat;
			position: self mousePosition;
			character: (self mapSpecialCharacter: keysym sym).
			
	self convertButtonState: SDL2 mouseState modState: keysym mod modifiers: osEvent modifiers.
	^ osEvent deliver! !

!OSSDL2BackendWindow methodsFor: 'window management' stamp: ''!
toggleBorderOff

	sdl2Window toggleBorder: false! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
borderless
	^ sdl2Window getFlags anyMask: SDL_WINDOW_BORDERLESS! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
resizable
	^ sdl2Window getFlags anyMask: SDL_WINDOW_RESIZABLE! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
position
	| x y |
	x := ByteArray new: ExternalType long byteSize.
	y := ByteArray new: ExternalType long byteSize.
	sdl2Window getPositionX: x y: y.
	^ ( x signedLongAt: 1) @ (y signedLongAt: 1)! !

!OSSDL2BackendWindow methodsFor: 'text input' stamp: ''!
isTextInputActive
	"See https://wiki.libsdl.org/SDL_IsTextInputActive"

	^ sdl2Window isTextInputActive! !

!OSSDL2BackendWindow methodsFor: 'instance creation' stamp: ''!
newOpenGLRenderer
	^ renderer := OSSDL2GLRenderer new 
		backendWindow: self;
		createContext;
		yourself! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
bounds: newBounds
	self 
		position: newBounds origin;
		extent: newBounds extent! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
horizontalDPI
	self fetchDPIAndRaiseEvent.
	^ horizontalDPI! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
visitKeyUpEvent: event
	| osEvent keysym |
	keysym := event keysym.
	osEvent := OSKeyUpEvent for: osWindow.
	osEvent scanCode: keysym scancode;
			symbol: keysym sym;
			repeat: event repeat;
			position: self mousePosition.
			
	self convertButtonState: SDL2 mouseState modState: keysym mod modifiers: osEvent modifiers.
	^ osEvent deliver! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
diagonalDPI
	self fetchDPIAndRaiseEvent.
	^ diagonalDPI! !

!OSSDL2BackendWindow methodsFor: 'deleting' stamp: ''!
destroy

	sdl2Window ifNotNil: [ :validHandle | 
		OSSDL2Driver current unregisterWindowWithId: validHandle windowID.
		renderer ifNotNil: [ renderer destroy ].
		validHandle destroy
	].

	renderer := nil.
	sdl2Window := nil.
	osWindow := nil! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
screenScaleFactor
	self fetchDPIAndRaiseEvent.
	^ screenScaleFactor! !

!OSSDL2BackendWindow methodsFor: 'text input' stamp: ''!
stopTextInput
	"See https://wiki.libsdl.org/SDL_StopTextInput"

	sdl2Window stopTextInput! !

!OSSDL2BackendWindow methodsFor: 'mouse capture' stamp: ''!
releaseMouse
	SDL2 setRelativeMouseMode: false! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
extent: newExtent
	sdl2Window setSizeW: newExtent x h: newExtent y! !

!OSSDL2BackendWindow methodsFor: 'cursor' stamp: ''!
lookupSystemCursor: cursor ifNotFound: aBlock
	
	^ self systemCursorConversionTable
		  detect: [ :aMapping | (Cursor perform: aMapping key) = cursor ]
		  ifFound: [ :aMapping | SDL2 createSystemCursor: (SDL_SystemCursorType perform: aMapping value) ]
		  ifNone: [ aBlock value  ]! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
title
	^ sdl2Window title! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
windowId
	^ self sdl2Window windowID! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
sdl2Window

	^ sdl2Window! !

!OSSDL2BackendWindow methodsFor: 'private' stamp: ''!
getWMInfo
	| wmInfo |
	wmInfo := SDL_SysWMinfo new version: SDL_Version bindingVersion.
	sdl2Window getWMInfo: wmInfo.
	^ wmInfo! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
platformSpecificHandle
	| wmInfo platformID |
	wmInfo := self getWMInfo.
	platformID := wmInfo subsystem.
	platformID = SDL_SYSWM_WINDOWS ifTrue: [ ^ wmInfo info win asPlatformSpecificHandle ].
	platformID = SDL_SYSWM_X11 ifTrue: [ ^ wmInfo info x11 asPlatformSpecificHandle ].
	platformID = SDL_SYSWM_DIRECTFB ifTrue: [ ^ wmInfo info dfb asPlatformSpecificHandle ].
	platformID = SDL_SYSWM_COCOA ifTrue: [ ^ wmInfo info cocoa asPlatformSpecificHandle ].
	platformID = SDL_SYSWM_UIKIT ifTrue: [ ^ wmInfo info uikit asPlatformSpecificHandle ].
	platformID = SDL_SYSWM_WAYLAND ifTrue: [ ^ wmInfo info wl asPlatformSpecificHandle ].
	platformID = SDL_SYSWM_MIR ifTrue: [ ^ wmInfo info mir asPlatformSpecificHandle ].
	platformID = SDL_SYSWM_WINRT ifTrue: [ ^ wmInfo info winrt asPlatformSpecificHandle ].
	platformID = SDL_SYSWM_ANDROID ifTrue: [ ^ wmInfo info android asPlatformSpecificHandle ].
	
	self error: 'Trying to get a platform specific handle for an unsupported SDL2 platform.'! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
title: aTitle
	sdl2Window title: aTitle! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
visitTextInputEvent: event
	| osEvent |
	
	osEvent := OSTextInputEvent for: osWindow.
	osEvent text: (ZnUTF8Encoder new decodeBytes: event text);
			position: self mousePosition.
	^ osEvent deliver! !

!OSSDL2BackendWindow methodsFor: 'text input' stamp: ''!
startTextInput
	"See https://wiki.libsdl.org/SDL_StartTextInput"

	sdl2Window startTextInput! !

!OSSDL2BackendWindow methodsFor: 'private - initialization' stamp: ''!
initWithHandle: aHandle attributes: attributes
	sdl2Window := aHandle.
	attributes applyTo: self.
	diagonalDPI := horizontalDPI := verticalDPI := self screenScaleFactorBaseDPI.
	screenScaleFactor := 1.
	self fetchDPI.! !

!OSSDL2BackendWindow methodsFor: 'instance creation' stamp: ''!
newFormRenderer: form
	^ renderer := OSSDL2FormRenderer new 
		form: form;
		backendWindow: self;
		yourself! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
prepareExternalResourceForAutoRelease
	sdl2Window autoRelease! !

!OSSDL2BackendWindow methodsFor: 'mouse capture' stamp: ''!
captureMouse
	SDL2 setRelativeMouseMode: true! !

!OSSDL2BackendWindow methodsFor: 'private' stamp: ''!
convertCursor: aCursor
	| bits size result bytesPerLineInResult bytesPerLineInBitMap lineBitmapPosition lineResultPosition |

	"This method converts the bits in a Pharo Cursor to the bitmap expected by SDL.
	SDL expects a bitmap of 1bit depth. The cursor passed as parameter should be 1 bit depth.	
		
	This conversion handles cursors of any size. SDL requires that the resulting width is multiple of 8.
	"
	aCursor unhibernate.
	
	bits := aCursor bits.
	size := aCursor extent.

	"The resulting byte array has the size of the cursor (e.g., 32x32), but as each pixel is one byte 
	we need to divide it by 8"
	result := ByteArray new: (size x * size y) // 8.

	"We are going to traverse the whole Pharo bitmap and generate the byteArray.
	As the bitmap is organized line by line, we need to calculate how many bytes there is in a line."
	bytesPerLineInResult := size x // 8.
	"The amount of bytes in a line in the bitmap is not the same as the result.
	Bitmaps contain 32-bit numbers. So each line is padded to 32 bits elements (4 bytes). 
	If the line has 48 pixels, in the byteArray it will take 6 bytes, but in the bitmap this is round up to 8 bytes.
	The padding is always zero and we can discard it in the transformation (as it has not image information)"
	bytesPerLineInBitMap := bytesPerLineInResult roundUpTo: 4.

	"We are going to traverse the cursor line by line.
	As the positions in the bitmap and the byte array are not the same (the bitmap has padding, the bytearray no)
	we need to have different starts for each line.
	Once the offset is adjusted we can copy byte-per-byte"	
	1 to: size y do: [ :line |
		lineBitmapPosition := (line - 1) * bytesPerLineInBitMap.
		lineResultPosition := (line - 1) * bytesPerLineInResult.
		
		1 to: bytesPerLineInResult do: [ :i |
			result at: lineResultPosition + i put: (bits byteAt: lineBitmapPosition + i)]].
	

	^ result! !

!OSSDL2BackendWindow methodsFor: 'testing' stamp: ''!
isValid
	^ true! !

!OSSDL2BackendWindow methodsFor: 'accessing' stamp: ''!
clipboardText
	^ SDL2 clipboardText! !

!OSSDL2BackendWindow methodsFor: 'private' stamp: ''!
getFlags
	^ sdl2Window getFlags! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
visitSystemWindowEvent: systemWindowEvent

	self fetchDPI.
	(OSWindowResolutionChangeEvent for: osWindow)
		horizontalDPI: horizontalDPI;
		verticalDPI: verticalDPI;
		diagonalDPI: diagonalDPI;
		screenScaleFactor: screenScaleFactor;
		deliver! !

!OSSDL2BackendWindow methodsFor: 'event handling' stamp: ''!
visitMouseWheelEvent: sdlEvent
	| osEvent |
	osEvent := OSMouseWheelEvent for: osWindow.
	osEvent position: self mousePosition;
			scrollHorizontal: sdlEvent x;
			scrollVertical: sdlEvent y.
			
	self convertButtonState: SDL2 mouseState modState: SDL2 modState modifiers: osEvent modifiers.
	^ osEvent deliver! !

!OSSDL2BackendWindow methodsFor: 'events' stamp: ''!
updateToNewResolution
	
	"Force the regeneration of the renderer because we have a new resolution"
	renderer destroy.
	renderer validate.
	renderer updateAll.! !

!OSSDL2BackendWindow methodsFor: 'private' stamp: ''!
fetchDPI
	| displayIndex ddpi hdpi vdpi newDiagonalDPI newScreenScaleFactor |
	"In OS X disable the computation of a DPI based scale factor. These values
	are completely wrong and we are getting scale factors that are very large
	even in non-retina display. This workaround does not affect the support for
	retina display because that is handled by fetching the size of the drawing surface."
	Smalltalk os isMacOSX ifTrue: [ 
		diagonalDPI := verticalDPI := horizontalDPI := self screenScaleFactorBaseDPI.
		screenScaleFactor := 1.0.
		^ false
	].

	displayIndex := sdl2Window getDisplayIndex.
	displayIndex < 0 ifTrue: [ ^ false ].
	
	ddpi := ByteArray new: 4.
	hdpi := ByteArray new: 4.
	vdpi := ByteArray new: 4.
	(SDL2 getDisplay: displayIndex ddpi: ddpi hdpi: hdpi vdpi: vdpi) = 0 ifFalse: [ ^ false ].
				
	newDiagonalDPI := ddpi floatAt: 1.
	"Allow automatic scale of factor increments of 5%. We need to
	round due to precision issues which may result in an almost 1 scale factor, but not exactly one.
	This has to be at least a divisor of 25% which are normal scale factor increments that are selectable in Windows.
	"
	newScreenScaleFactor := newDiagonalDPI / self screenScaleFactorBaseDPI roundTo: 0.05.
	(screenScaleFactor closeTo: newScreenScaleFactor) ifTrue: [ ^ false ].

	horizontalDPI := hdpi floatAt: 1.
	verticalDPI := vdpi floatAt: 1.
	diagonalDPI := newDiagonalDPI.
	screenScaleFactor := newScreenScaleFactor.
	^ true! !

!OSSDL2BackendWindow methodsFor: 'window management' stamp: ''!
maximize

	sdl2Window maximize! !

!OSSDL2BackendWindow class methodsFor: 'instance creation' stamp: ''!
newWithHandle: handle attributes: attributes
	^ self basicNew 
		initWithHandle: handle attributes: attributes; 
		yourself! !

!OSSDL2Driver commentStamp: ''!
A window driver used for running things using SDL2 library!
!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitJoyDeviceRemovedEvent: joyEvent
	(SDL2 isGameController: joyEvent which) ifFalse: [ self closeRemovedJoystick: joyEvent which ].
	^ OSJoyDeviceRemovedEvent new
		which: joyEvent which;
		hasMapping: (self isGameController: joyEvent which);
		mapped: false! !

!OSSDL2Driver methodsFor: 'events' stamp: ''!
afterMainPharoWindowCreated: osWindow
	
	OSPlatform current sdlPlatform 
		afterMainPharoWindowCreated: osWindow! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
primitiveSetVMSDL2Input: semaIndex
	<primitive: #primitiveSetVMSDL2Input>
	^ nil! !

!OSSDL2Driver methodsFor: 'private' stamp: ''!
closeRemovedJoystick: index
	"TODO: What should I do here?"

	self traceCr: ('Joystick <1s> removed' expandMacrosWith: index)! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
isGameController: joystickIndex
	^ (JoystickMap at: joystickIndex ifAbsent: [ ^ false ]) isGameController! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
dispatchEvent: mappedEvent

	| window |

	mappedEvent windowID ifNil: [ ^ self sendEventWithoutWindow: mappedEvent ].
	
	WindowMapMutex critical: [ 
		window := WindowMap at: mappedEvent windowID ifAbsent: [ ^ nil ] ].

	^ window handleNewSDLEvent: mappedEvent.! !

!OSSDL2Driver methodsFor: 'accessing' stamp: ''!
eventFilter

	^ eventFilter ifNil: [ eventFilter := OSSDLPasteEventFilter new next: self; yourself ]! !

!OSSDL2Driver methodsFor: 'private' stamp: ''!
openAddedJoystick: index
	| joystick |
	joystick := SDL2 joystickOpen: index.
	JoystickMap at: index put: joystick.! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitControllerButtonUpEvent: joyEvent
	^ OSJoyButtonUpEvent new
		which: joyEvent which;
		button: joyEvent button;
		mapped: true;
		hasMapping: true;
		pressed: false! !

!OSSDL2Driver methodsFor: 'window creation and deletion' stamp: ''!
createWindowWithAttributes: attributes osWindow: osWindow
	| flags handle aBackendWindow glAttributes x y |
	
	flags := attributes visible ifTrue: [ SDL_WINDOW_SHOWN ] ifFalse: [ SDL_WINDOW_HIDDEN ].
	attributes fullscreen ifTrue: [ flags := flags | SDL_WINDOW_FULLSCREEN_DESKTOP ].
	attributes borderless ifTrue: [ flags := flags | SDL_WINDOW_BORDERLESS ].
	flags := flags | SDL_WINDOW_ALLOW_HIGHDPI.
	
	" Set the OpenGL attributes."
	glAttributes := attributes glAttributes.
	glAttributes ifNotNil: [ 
		flags := flags | SDL_WINDOW_OPENGL.
		self setGLAttributes: glAttributes ].
	
	"Get the actual initial position value."
	x := attributes x.
	y := attributes y.
	attributes windowCentered ifTrue: [
		x := SDL_WINDOWPOS_CENTERED.
		y := SDL_WINDOWPOS_CENTERED ].

	"Extra creation flags"
	attributes resizable ifTrue: [ 
		flags := flags | SDL_WINDOW_RESIZABLE ].

	attributes maximized ifTrue: [ 
		flags := flags | SDL_WINDOW_MAXIMIZED ].
	
	attributes minimized ifTrue: [ 
		flags := flags | SDL_WINDOW_MINIMIZED ].

	"Create the window"
	WindowMapMutex critical: [ 
		handle := SDL2 createWindow: attributes title
			x: x
			y: y
			width: attributes width 
			height: attributes height 
			flags: flags.
		
		aBackendWindow := OSSDL2BackendWindow newWithHandle: handle attributes: attributes.
		aBackendWindow osWindow: osWindow.
		self registerWindow: aBackendWindow.
		
		"The OSWindow handle has to be set inside of this critical section to avoid losing some events such as expose."
		osWindow setJustCreatedHandle: aBackendWindow.
	].
	^ aBackendWindow! !

!OSSDL2Driver methodsFor: 'events' stamp: ''!
afterSetWindowTitle: windowTitle onWindow: osWindow
	
	OSPlatform current sdlPlatform 
		afterSetWindowTitle: windowTitle onWindow: osWindow.! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
processEvent: sdlEvent
	| mappedEvent |
			
	[ 
		mappedEvent := sdlEvent mapped.
		self evaluateUserInterrupt: mappedEvent.
		self eventFilter dispatchEvent: mappedEvent
	] on: Error do: [ :err | 
		"It is critical, that event handling keep running despite errors.
		Normally, any errors in event handling requires immediate attention and fixing"
		err freeze.
		[ err debug ] fork.
	 ]! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitJoyDeviceAddedEvent: joyEvent
	(SDL2 isGameController: joyEvent which) ifFalse: [ self openAddedJoystick: joyEvent which ].
	^ OSJoyDeviceAddedEvent new
		which: joyEvent which;
		hasMapping: (self isGameController: joyEvent which);
		mapped: false! !

!OSSDL2Driver methodsFor: 'private' stamp: ''!
closeRemovedController: index
	"TODO: What should I do here?"

	self
		traceCr: ('Game controller <1s> removed' expandMacrosWith: index)! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
unregisterGlobalListener: globalListener
	"This method registers a global event listener.
	Global event listeners are used to handle events that are not generate for a specific window.
	Joysticks use this kind of events.
	"
	globalListeners remove: globalListener! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitJoyAxisEvent: joyEvent
	^ OSJoyAxisEvent new
		which: joyEvent which;
		axis: joyEvent axis;
		hasMapping: (self isGameController: joyEvent which);
		mapped: false;
		value: joyEvent value! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
registerGlobalListener: globalListener
	"This method registers a global event listener.
	Global event listeners are used to handle events that are not generate for a specific window.
	Joysticks use this kind of events.
	"
	globalListeners add: globalListener! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
evaluateUserInterrupt: anSDLEvent

	anSDLEvent isUserInterrupt
		ifTrue: [ UserInterruptHandler new handleUserInterrupt ].
		
	anSDLEvent isUserInterruptKillAll 
	 	ifTrue: [ UserInterruptHandler new handleUserInterruptKillAll ].! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
eventLoopProcessWithPlugin
	| event session semaIndex |
	event := SDL_Event new.
	session := Smalltalk session.
	
	semaIndex := (Smalltalk registerExternalObject: inputSemaphore).
	self primSetupInputSemaphore: semaIndex.
	[
		[ inputSemaphore wait; consumeAllSignals. session  == Smalltalk session] whileTrue: [
			[ (SDL2 pollEvent: event) > 0 ] whileTrue: [
				self processEvent: event
			].
		]
	] ensure:  [ Smalltalk unregisterExternalObject: inputSemaphore ]! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
sendEventWithoutWindow: event
	| converted |
	converted := event accept: self.
	converted ifNil: [ ^ self ].
	globalListeners do: [ :list | list handleEvent: converted ].
	self flag: #pharoFixMe. "Avoid holding the mutex for so long".	
	WindowMapMutex critical: [
		WindowMap valuesDo: [ :window | window deliverGlobalEvent: converted ].
	]! !

!OSSDL2Driver methodsFor: 'window creation and deletion' stamp: ''!
registerWindow: aBackendWindow
	WindowMap at: aBackendWindow sdl2Window windowID put: aBackendWindow! !

!OSSDL2Driver methodsFor: 'initialization' stamp: ''!
initialize
	inputSemaphore := Semaphore new.
	globalListeners := WeakSet new.
	self
		initializeWindowMap;
		initializeJoystickMap.
	SDL2
"		initVideo;
		initJoystick;
		initGameController;
"		initEverything.
	self setupEventLoop.! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitControllerDeviceRemappedEvent: controllerEvent
	^ OSJoyDeviceRemappedEvent new
		which: controllerEvent which;
		mapped: true;
		hasMapping: true! !

!OSSDL2Driver methodsFor: 'private' stamp: ''!
openAddedController: index
	| controller |
	controller := SDL2 gameControllerOpen: index.
	JoystickMap at: index put: controller.! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitJoyButtonUpEvent: joyEvent
	^ OSJoyButtonUpEvent new
		which: joyEvent which;
		button: joyEvent button;
		hasMapping: (self isGameController: joyEvent which);
		mapped: false;
		pressed: false! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
primSetupInputSemaphore: semaIndex
	<primitive: #primitiveSetSDL2Input module: #SDL2DisplayPlugin>
	^ nil! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
visitFingerMotionEvent: event
	^OSTouchActionPointerMoveEvent new
			timestamp: event timestamp;
			deviceId: event touchId;
			fingerId: event fingerId;
			position: event x @ event y;
			delta: event dx @ event dy;
			pressure: event pressure;
			yourself.! !

!OSSDL2Driver methodsFor: 'window creation and deletion' stamp: ''!
initializeWindowMap

	WindowMap ifNil: [ 
		WindowMap := WeakValueDictionary new. 
	].
	WindowMapMutex := Semaphore forMutualExclusion.! !

!OSSDL2Driver methodsFor: 'window creation and deletion' stamp: ''!
unregisterWindowWithId: windowId

	WindowMapMutex critical: [ 
		WindowMap removeKey: windowId ifAbsent: [].
	].
	
	"Does it make sense to keep the SDL event loop process running even if no OSWindow is currently open ?"
	"WindowMap ifEmpty: [ 
		EventLoopProcess terminate.
		EventLoopProcess := nil.
	]."! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitControllerDeviceAddedEvent: controllerEvent
	self openAddedController: controllerEvent which.
	^ OSJoyDeviceAddedEvent new
		which: controllerEvent which;
		mapped: true;
		hasMapping: true! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
visitFingerUpEvent: event
	^OSTouchActionPointerUpEvent new
			timestamp: event timestamp;
			deviceId: event touchId;
			fingerId: event fingerId;
			position: event x @ event y;
			delta: event dx @ event dy;
			pressure: event pressure;
			yourself.! !

!OSSDL2Driver methodsFor: 'system startup' stamp: ''!
shutDown
	"Reset WindowMap and JoystickMap when shuting down (otherwise there will be handlers 
	 remaining on restart)"

	WindowMap := nil.
	JoystickMap := nil.
	EventLoopProcess ifNotNil: [ EventLoopProcess terminate ].! !

!OSSDL2Driver methodsFor: 'window creation and deletion' stamp: ''!
setGLAttributes: glAttributes
	glAttributes majorVersion ifNotNil: [ 
		SDL2 glSetAttribute: SDL_GL_CONTEXT_MAJOR_VERSION value: glAttributes majorVersion.
	].
	glAttributes minorVersion ifNotNil: [ 
		SDL2 glSetAttribute: SDL_GL_CONTEXT_MINOR_VERSION value: glAttributes minorVersion.
	].
	glAttributes hasCompatibilityProfile ifTrue: [ 
		SDL2 glSetAttribute: SDL_GL_CONTEXT_PROFILE_MASK value: SDL_GL_CONTEXT_PROFILE_COMPATIBILITY
	].
	glAttributes hasCoreProfile ifTrue: [ 
		SDL2 glSetAttribute: SDL_GL_CONTEXT_PROFILE_MASK value: SDL_GL_CONTEXT_PROFILE_CORE
	].
	glAttributes hasESProfile ifTrue: [ 
		SDL2 glSetAttribute: SDL_GL_CONTEXT_PROFILE_MASK value: SDL_GL_CONTEXT_PROFILE_ES
	].

	SDL2 glSetAttribute: SDL_GL_RED_SIZE value: glAttributes redSize.
	SDL2 glSetAttribute: SDL_GL_BLUE_SIZE value: glAttributes blueSize.
	SDL2 glSetAttribute: SDL_GL_GREEN_SIZE value: glAttributes greenSize.
	SDL2 glSetAttribute: SDL_GL_ALPHA_SIZE value: glAttributes alphaSize.
	SDL2 glSetAttribute: SDL_GL_DEPTH_SIZE value: glAttributes depthSize.
	SDL2 glSetAttribute: SDL_GL_STENCIL_SIZE value: glAttributes stencilSize.
	SDL2 glSetAttribute: SDL_GL_DOUBLEBUFFER value: glAttributes doubleBuffer.
	SDL2 glSetAttribute: SDL_GL_FRAMEBUFFER_SRGB_CAPABLE value: glAttributes srgbFramebuffer asBit.! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitControllerButtonDownEvent: joyEvent
	^ OSJoyButtonDownEvent new
		which: joyEvent which;
		button: joyEvent button;
		mapped: true;
		hasMapping: true;
		pressed: true! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitControllerDeviceRemovedEvent: controllerEvent
	self closeRemovedController: controllerEvent which.
	^ OSJoyDeviceRemovedEvent new
		which: controllerEvent which;
		mapped: true;
		hasMapping: true! !

!OSSDL2Driver methodsFor: 'window creation and deletion' stamp: ''!
initializeJoystickMap

	JoystickMap ifNil: [ 
		JoystickMap := Dictionary new. 
	].! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitJoyButtonDownEvent: joyEvent
	^ OSJoyButtonDownEvent new
		which: joyEvent which;
		button: joyEvent button;
		hasMapping: (self isGameController: joyEvent which);
		mapped: false;
		pressed: true! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitQuitEvent: quitEvent
	^ nil! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitControllerAxisEvent: joyEvent
	^ OSJoyAxisEvent new
		which: joyEvent which;
		axis: joyEvent axis;
		mapped: true;
		hasMapping: true;
		value: joyEvent value! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitDropEvent: dropEvent

	"The dragged file name comes as a C-string of utf8 encoded bytes.
	Get the string, and decode it to a string using a utf8 decoder"
	| fileName |
	fileName := dropEvent file readString asByteArray utf8Decoded.
	
	"Free the file handle after it has been read, as specified by SDL2
	https://wiki.libsdl.org/SDL_DropEvent"
	dropEvent file free.
	
	^ OSWindowDropEvent new
		timestamp: dropEvent timestamp;
		filePath: fileName! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
setupEventLoop
	EventLoopProcess ifNotNil: [ 
		EventLoopProcess isTerminating ifFalse: [EventLoopProcess terminate. EventLoopProcess := nil] ].
	EventLoopProcess := self class isVMDisplayUsingSDL2 ifTrue: [ 
		[ self eventLoopProcessWithVMWindow ] 
		forkAt: Processor lowIOPriority
	] ifFalse: [ 
		self class hasPlugin ifTrue: [ 
			[ self eventLoopProcessWithPlugin ] 
			forkAt: Processor lowIOPriority ]
		ifFalse: [ 
			[ self eventLoopProcessWithoutPlugin ] 
			forkAt: Processor lowIOPriority ].
	].

	EventLoopProcess
		name: 'SDL2 Event loop';
		resume! !

!OSSDL2Driver methodsFor: 'accessing' stamp: ''!
eventLoopProcess
	
	^ self class eventLoopProcess! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
eventLoopProcessWithoutPlugin
	| event session |
	event := SDL_Event new.
	session := Smalltalk session.
	
	[ session == Smalltalk session] 
	whileTrue: [
		[ (SDL2 pollEvent: event) > 0 ] 
		whileTrue: [ self processEvent: event ].
		
		(Delay forMilliseconds: 5) wait ]! !

!OSSDL2Driver methodsFor: 'global events' stamp: ''!
visitCommonEvent: event
	^ nil! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
visitFingerDownEvent: event
	^OSTouchActionPointerDownEvent new
			timestamp: event timestamp;
			deviceId: event touchId;
			fingerId: event fingerId;
			position: event x @ event y;
			delta: event dx @ event dy;
			pressure: event pressure;
			yourself.! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
primitivePollVMSDL2Event: eventBuffer size: size
	<primitive: #primitivePollVMSDL2Event>
	^ false! !

!OSSDL2Driver methodsFor: 'events-processing' stamp: ''!
eventLoopProcessWithVMWindow
	| event session semaIndex eventBuffer |
	event := SDL_Event new.
	eventBuffer := event getHandle. 
	session := Smalltalk session.
	
	semaIndex := (Smalltalk registerExternalObject: inputSemaphore).
	self primitiveSetVMSDL2Input: semaIndex.
	[
		[ inputSemaphore wait; consumeAllSignals. session  == Smalltalk session] whileTrue: [
			[ self primitivePollVMSDL2Event: eventBuffer size: eventBuffer size ] whileTrue: [
				self processEvent: event
			].
		]
	] ensure:  [ Smalltalk unregisterExternalObject: inputSemaphore ]! !

!OSSDL2Driver class methodsFor: 'testing' stamp: ''!
isSuitable
	^ self isSupported! !

!OSSDL2Driver class methodsFor: 'testing' stamp: ''!
isSupported 
	^ SDL2 isAvailable! !

!OSSDL2Driver class methodsFor: 'testing' stamp: ''!
isVMDisplayUsingSDL2
	<primitive: #primitiveIsVMDisplayUsingSDL2>
	^ false! !

!OSSDL2Driver class methodsFor: 'accessing' stamp: ''!
allWindows

	^ WindowMapMutex critical: [ WindowMap values ]! !

!OSSDL2Driver class methodsFor: 'testing' stamp: ''!
eventLoopProcess 

	^ EventLoopProcess! !

!OSSDL2Driver class methodsFor: 'testing' stamp: ''!
hasPlugin
	<primitive: #primitiveHasDisplayPlugin module: #SDL2DisplayPlugin>
	^ false! !

!OSSDL2ExternalForm commentStamp: ''!
An ExternalForm is a specialized Form whose pixel-data is stored in memory that the user provides a pointer to.  This can simply be memory on the C heap, or (the motivating use-case...) it can be a pointer that is temporarily "mapped" from GPU memory by an API such as OpenCL.

IMPORTANT: Moved form FFI to SDL2 because is not needed there anymore but OSWindow-SDL2 package uses it.

The user is responsible for both releasing the image-memory, as well as destroying the surface handle (perhaps the latter should be handled by automatic finalization).

Example usage:

| extent form ptr |
extent := 400@300.
form := ExternalForm extent: extent depth: 32.
ptr := ExternalAddress gcallocate: (extent x * extent y * 4).
form setManualSurfacePointer: ptr.
Display displayScaledOn: form.
form displayAt: 0@0.
form destroySurface.
!
!OSSDL2ExternalForm methodsFor: 'primitives' stamp: ''!
primDestroyManualSurface: surfaceID
	<primitive: 'primitiveDestroyManualSurface' module: 'SurfacePlugin'>

	^ self oldPrimDestroyManualSurface: surfaceID! !

!OSSDL2ExternalForm methodsFor: 'initialize' stamp: ''!
destroySurface
	"Users must call this explicitly when this object is no longer needed; otherwise, resource-leakage will occur in the SurfacePlugin"
	bits ifNotNil: [:surfaceID |
		bits := nil.
		self primDestroyManualSurface: surfaceID
	].! !

!OSSDL2ExternalForm methodsFor: 'initialize' stamp: ''!
setExtent: extent depth: bitsPerPixel
	bits ifNotNil: [self error: 'bits are already set'].
	bitsPerPixel == 32 ifFalse: [self error: 'only 32 bits for now'.  "see 'rowPitch' below"].
	width := extent x asInteger.
	width < 0 ifTrue: [width := 0].
	height := extent y asInteger.
	height < 0 ifTrue: [height := 0].
	depth := bitsPerPixel.
	bits := self 
		primCreateManualSurfaceWidth: width 
		height: height 
		rowPitch: width * 4
		depth: bitsPerPixel
		isMSB: true.! !

!OSSDL2ExternalForm methodsFor: 'initialize' stamp: ''!
allocateSpace
	"Convenient way to allocate space for the pixels.  This isn't done by default, because it is common to use a pointer obtained from elsewhere."
	| addr |
	pointer ifNotNil: [self error: 'space is already allocated'].
	addr := ExternalAddress gcallocate: width*height * depth/8. "area times bytes/pixel"
	self setManualSurfacePointer: addr.! !

!OSSDL2ExternalForm methodsFor: 'initialize' stamp: ''!
setManualSurfacePointer: newPointer "ExternalStructure, ExternalAddress, or nil"
	"Set the memory-location of the image data.  It is OK to set a NULL pointer;
	 in this case, any attempt to BitBlt to or from the form will result in a primitive-failure."
	pointer := newPointer.
	pointer ifNil: [^self primManualSurface: bits setPointer: 0].
	pointer isExternalAddress
		ifFalse: ["must already be ExternalStructure, so nothing to do"]
		ifTrue: [pointer := ExternalData 
							fromHandle: newPointer 
							type: ExternalType void asPointerType].
	"The primitive expects an unsigned integer arg, not an ExternalAddress."
	"NOTE: it used to be acceptable for 'newPointer' to be an Integer... 
	 if you get a MNU for #getHandle here, you should update your code 
	 to pass in either an ExternalStructure or an ExternalAddress."
	self primManualSurface: bits setPointer: pointer getHandle asInteger! !

!OSSDL2ExternalForm methodsFor: 'old - ffi backend support' stamp: ''!
oldPrimCreateManualSurfaceWidth: aWidth height: aHeight rowPitch: rowPitch depth: aDepth isMSB: isMSB
	<primitive: 'primitiveCreateManualSurface' module: 'SqueakFFIPrims'>
	self primitiveFailed! !

!OSSDL2ExternalForm methodsFor: 'old - ffi backend support' stamp: ''!
oldPrimManualSurface: surfaceID setPointer: aPointer
	"The 'surfaceID' is a handle returned by #primitiveCreateManualSurface from SurfacePlugin. The pointer is a 32-bit unsigned integer that SurfacePlugin casts to a void*."
	<primitive: 'primitiveSetManualSurfacePointer' module: 'SqueakFFIPrims'>
	self primitiveFailed! !

!OSSDL2ExternalForm methodsFor: 'accessing' stamp: ''!
pointer
	^pointer! !

!OSSDL2ExternalForm methodsFor: 'primitives' stamp: ''!
primCreateManualSurfaceWidth: aWidth height: aHeight rowPitch: rowPitch depth: aDepth isMSB: isMSB
	<primitive: 'primitiveCreateManualSurface' module: 'SurfacePlugin'>
	
	^ self oldPrimCreateManualSurfaceWidth: aWidth height: aHeight rowPitch: rowPitch depth: aDepth isMSB: isMSB! !

!OSSDL2ExternalForm methodsFor: 'primitives' stamp: ''!
primManualSurface: surfaceID setPointer: aPointer
	"The 'surfaceID' is a handle returned by #primitiveCreateManualSurface from SurfacePlugin. The pointer is a 32-bit unsigned integer that SurfacePlugin casts to a void*."
	<primitive: 'primitiveSetManualSurfacePointer' module: 'SurfacePlugin'>

	^ self oldPrimManualSurface: surfaceID setPointer: aPointer! !

!OSSDL2ExternalForm methodsFor: 'old - ffi backend support' stamp: ''!
oldPrimDestroyManualSurface: surfaceID
	<primitive: 'primitiveDestroyManualSurface' module: 'SqueakFFIPrims'>
	self primitiveFailed! !

!OSSDL2ExternalForm methodsFor: 'initialize' stamp: ''!
setExtent: extent depth: bitsPerPixel bits: aPointer
	self setExtent: extent depth: bitsPerPixel.
	self setManualSurfacePointer: aPointer.! !

!OSSDL2FormRenderer commentStamp: ''!
My instances implement OSWindowFormRenderer interface using SDL2 library!
!OSSDL2FormRenderer methodsFor: 'updating screen' stamp: ''!
copyAndPresentTextureRectangle: rectangle
	| sdlRectangle |

	deferUpdates
		ifTrue: [ ^ self ].

	sdlRectangle := rectangle asSDLRect.				
	renderer copy: texture srcRect: sdlRectangle dstRect: sdlRectangle.
	renderer present! !

!OSSDL2FormRenderer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	deferUpdates := false.
	mutex := Mutex new.! !

!OSSDL2FormRenderer methodsFor: 'private' stamp: ''!
primitiveUpdateRectangle: rectangle externalForm: externalForm

	"We need to do this ugly hack because the Mutex that is used in the renderer is not correctly liberated when there is an exception. Issue #10156. Once it is fixed, we can signal the exception as normal people."

	[externalForm copy: rectangle from: form to: rectangle origin rule: Form over]
		on:Exception do: [ :e | ('There was an error during copy, we should not throw an exception here:' , e printString) traceCr ]! !

!OSSDL2FormRenderer methodsFor: 'private' stamp: ''!
useDeferredUpdates
	mutex critical: [ 
		renderer
			copy: texture;
			present
	]! !

!OSSDL2FormRenderer methodsFor: 'updating screen' stamp: ''!
deferUpdatesWhile: aBlock
	deferUpdates := true.
	aBlock ensure: [ deferUpdates := false. ].
	self useDeferredUpdates.! !

!OSSDL2FormRenderer methodsFor: 'updating screen' stamp: ''!
updateAreas: allDamage immediate: forceToScreen

	| pixels pitch intersection updateUnion externalForm |
	mutex critical: [ 
		self validate ifFalse: [ ^ self ].

		pixels := ExternalAddress new.
		ExternalAddress allocate: 4 bytesDuring: [ :pitchHolder | 
			texture lockPixels: pixels pitch: pitchHolder.
			pitch := pitchHolder signedLongAt: 1 ].

		updateUnion := nil.
		[ 
		externalForm := OSSDL2ExternalForm
			                extent: extent
			                depth: 32
			                bits: pixels.
		allDamage do: [ :rectangle | 
			intersection := rectangle
				                intersect: (0 @ 0 corner: extent)
				                ifNone: [ nil ].

			intersection ifNotNil: [ 
				self
					primitiveUpdateRectangle: rectangle
					externalForm: externalForm.
				updateUnion
					ifNil: [ updateUnion := intersection ]
					ifNotNil: [ updateUnion := updateUnion merge: intersection ] ] ] ] 
			ensure: [ 
				texture unlock.
				externalForm destroySurface ].

		updateUnion ifNotNil: [ 
			self copyAndPresentTextureRectangle: updateUnion ] ]! !

!OSSDL2FormRenderer methodsFor: 'private' stamp: ''!
validate
	form ifNil: [ ^ false ].
	(renderer isNil or: [renderer isNull]) ifTrue: [ self createRenderer ].
	(texture isNil or: [texture isNull or: [ form extent ~= extent ]])
		ifTrue: [ self createTexture ].
	^ true! !

!OSSDL2FormRenderer methodsFor: 'updating screen' stamp: ''!
updateAll
	mutex critical: [
		self validate
			ifFalse: [ ^ self ].
	
		texture updateTexturePixels: form bits pitch: form width * 4.
	
		deferUpdates
			ifTrue: [ ^ self ].
		renderer copy: texture.
		renderer present
	]! !

!OSSDL2FormRenderer methodsFor: 'private' stamp: ''!
createRenderer
	renderer := backendWindow sdl2Window createDefaultRenderer.! !

!OSSDL2FormRenderer methodsFor: 'private' stamp: ''!
createTexture
	texture := renderer createTextureFormat: SDL_PIXELFORMAT_XRGB8888
						access: SDL_TEXTUREACCESS_STREAMING width: form width height: form height.
	extent := form extent! !

!OSSDL2FormRenderer methodsFor: 'deleting' stamp: ''!
destroy
	mutex critical: [
		(texture isNil or: [ renderer isNil ])
			ifTrue: [ ^ self ].
		texture destroy.
		renderer destroy.
		texture := nil.
		renderer := nil.
	]! !

!OSSDL2FormRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangle: rectangle

	| intersection pixels pitch externalForm |
	mutex critical: [ 
		intersection := rectangle
			                intersect: (0 @ 0 corner: backendWindow extent)
			                ifNone: [ ^ self ].
		self validate ifFalse: [ ^ self ].

		pixels := ExternalAddress new.
		ExternalAddress allocate: 4 bytesDuring: [ :pitchHolder | 
			texture lockPixels: pixels pitch: pitchHolder.
			pitch := pitchHolder signedLongAt: 1 ].

		[ 
		externalForm := OSSDL2ExternalForm
			                extent: extent
			                depth: 32
			                bits: pixels.
		self
			primitiveUpdateRectangle: intersection
			externalForm: externalForm ] ensure: [ 
			texture unlock.
			externalForm destroySurface ].

		self copyAndPresentTextureRectangle: intersection ]! !

!OSSDL2GLRenderer commentStamp: ''!
My instances implement OSWindowGLRenderer interface using SDL2 library!
!OSSDL2GLRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangle: rectangle
	"Do nothing here"! !

!OSSDL2GLRenderer methodsFor: 'misc' stamp: ''!
getProcAddress: procName
	self checkThread.
	^ SDL2 glGetProcAddress: procName! !

!OSSDL2GLRenderer methodsFor: 'misc' stamp: ''!
swapBuffers: aWindow
	self checkThread.
	SDL2 glSwapWindow: aWindow sdl2Window.! !

!OSSDL2GLRenderer methodsFor: 'misc' stamp: ''!
checkThread
OSWindowRenderThread isActiveThread ifFalse: [ ^ 'GL Renderer must be used inside the OSWindowRenderThread or a critical section' ]! !

!OSSDL2GLRenderer methodsFor: 'updating screen' stamp: ''!
updateAll
	"Do nothing here"! !

!OSSDL2GLRenderer methodsFor: 'initialize' stamp: ''!
destroy
	self onRenderThreadBlocking: [
		context ifNotNil: [ context delete ].
		context := nil.
	]! !

!OSSDL2GLRenderer methodsFor: 'misc' stamp: ''!
createContext
	self onRenderThreadBlocking: [
		context := SDL2 glCreateContext: backendWindow sdl2Window .
	].

	(context isNotNil and: [ context isNull not ]) ifTrue: [
		FFIExternalResourceManager addResource: self data: { backendWindow . context }
	]! !

!OSSDL2GLRenderer methodsFor: 'misc' stamp: ''!
makeCurrent: aBackendWindow
	| windowHandle |
	context ifNil: [ ^ false ].

	self checkThread.
	windowHandle := aBackendWindow sdl2Window.
	windowHandle ifNil: [ ^ false ].
	^ (SDL2 glMakeCurrent: windowHandle context: context) == 0! !

!OSSDL2GLRenderer methodsFor: 'clipping' stamp: ''!
pixelExtent
	| w h |
	backendWindow ifNil: [ ^ super pixelExtent ].
	
	w := ByteArray new: 4.
	h := ByteArray new: 4.
	backendWindow sdl2Window glGetDrawableSizeW: w h: h.
	^ (w signedLongAt: 1) @ (h signedLongAt: 1)! !

!OSSDL2GLRenderer class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: windowAndContext
	| window context |
	window := windowAndContext first.
	context := windowAndContext second.

	OSWindowRenderThread enqueueBlockingOperation: [
		SDL2
			glMakeCurrent: (SDL_Window null) context: (SDL_GLContext null).
		context delete
	].! !

!OSSDL2GenericRenderer commentStamp: ''!
My instances implement OSWindowGenericRenderer interface by wrapping a SDL2 renderer.!
!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
color: aColor
	activeRed := self mapColorChannel: aColor red.
	activeGreen := self mapColorChannel: aColor green.
	activeBlue := self mapColorChannel: aColor blue.
	activeAlpha := self mapColorChannel: aColor alpha.
	renderer drawColorR: activeRed g: activeGreen b: activeBlue a: activeAlpha! !

!OSSDL2GenericRenderer methodsFor: 'initialization' stamp: ''!
createSDL2Renderer
	renderer := backendWindow sdl2Window createAcceleratedRenderer.
	
	self useNoBlending;
		color: Color white.! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
useAdditiveColorBlending
	self setBlendMode: SDL_BLENDMODE_ADD.! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
usePremultipliedCompositeAlphaBlending
	self setBlendMode: self premultipliedCompositeAlphaBlending! !

!OSSDL2GenericRenderer methodsFor: 'blending mode' stamp: ''!
useSubpixelFontFirstPassBlending
	self setBlendMode: self subpixelFontFirstPassBlendMode! !

!OSSDL2GenericRenderer methodsFor: 'blending mode' stamp: ''!
subpixelFontFirstPassBlendMode
	^ subpixelFontFirstPassBlendMode ifNil: [subpixelFontFirstPassBlendMode :=
		SDL2 composeCustomBlendMode_srcColorFactor: SDL_BLENDFACTOR_ZERO dstColorFactor: SDL_BLENDFACTOR_ONE_MINUS_SRC_COLOR colorOperation: SDL_BLENDOPERATION_ADD
		srcAlphaFactor: SDL_BLENDFACTOR_ZERO dstAlphaFactor: SDL_BLENDFACTOR_ONE_MINUS_SRC_ALPHA alphaOperation: SDL_BLENDOPERATION_ADD ]! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
present
	renderer present! !

!OSSDL2GenericRenderer methodsFor: 'blending mode' stamp: ''!
useSubpixelFontSecondPassBlending
	self setBlendMode: self subpixelFontSecondPassBlendMode! !

!OSSDL2GenericRenderer methodsFor: 'resources' stamp: ''!
createRenderTargetTextureWithExtent: anExtent
	| texture |
	texture := renderer createTextureFormat: SDL_PIXELFORMAT_ARGB8888 access: SDL_TEXTUREACCESS_TARGET width: anExtent x height: anExtent y.
	^ OSSDL2WindowRendererTexture new
		extent: anExtent copy;
		handle: texture;
		yourself! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
drawTexture: texture rectangle: sourceRectangle in: destRectangle
	self setupTextureBlendingState: texture handle.
	renderer copy: texture handle srcRect: sourceRectangle asSDLRect dstRect: destRectangle asSDLRect! !

!OSSDL2GenericRenderer methodsFor: 'private' stamp: ''!
createStaticTextureFromForm: form
	"form depth = 8 ifTrue: [ self halt ].
	form depth =	 16 ifTrue: [ self halt ].
	form depth =	 24 ifTrue: [ self halt ]."
	form depth =	 32 ifTrue: [ ^ self createStaticTextureFromForm32: form ].
	self flag: 'TODO: Support more depths to optimize the memory usage.'.
	^ self createStaticTextureFromForm: (form asFormOfDepth: 32)! !

!OSSDL2GenericRenderer methodsFor: 'blending mode' stamp: ''!
premultipliedCompositeAlphaBlending
	^ premultipliedCompositeAlphaBlending ifNil: [premultipliedCompositeAlphaBlending :=
		SDL2 composeCustomBlendMode_srcColorFactor: SDL_BLENDFACTOR_ONE dstColorFactor: SDL_BLENDFACTOR_ONE_MINUS_SRC_ALPHA colorOperation: SDL_BLENDOPERATION_ADD
		srcAlphaFactor: SDL_BLENDFACTOR_ONE dstAlphaFactor: SDL_BLENDFACTOR_ONE_MINUS_SRC_ALPHA alphaOperation: SDL_BLENDOPERATION_ADD ]! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
fillRectangle: aRectangle
	renderer fillRect: aRectangle asSDLRect! !

!OSSDL2GenericRenderer methodsFor: 'resources' stamp: ''!
getOrCreateStaticTextureFromForm: form
	^ self staticTextureCache at: form ifAbsentPut: [ self createStaticTextureFromForm: form ]! !

!OSSDL2GenericRenderer methodsFor: 'private' stamp: ''!
staticTextureCache
	^ staticTextureCache ifNil: [ staticTextureCache := WeakKeyDictionary new ]! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
drawTexture: texture in: aRectangle
	self setupTextureBlendingState: texture handle.
	renderer copy: texture handle srcRect: nil dstRect: aRectangle asSDLRect! !

!OSSDL2GenericRenderer methodsFor: 'deleting' stamp: ''!
destroy
	(renderer isNotNil and: [renderer isNull not]) ifTrue: [ 
		renderer destroy
	].
	renderer := nil.! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
drawLine: startPoint end: endPoint
	renderer drawLineX1: startPoint x asInteger y1: startPoint y asInteger x2: endPoint x asInteger y2: endPoint y asInteger! !

!OSSDL2GenericRenderer methodsFor: 'blending mode' stamp: ''!
subpixelFontSecondPassBlendMode
	^ subpixelFontSecondPassBlendMode ifNil: [subpixelFontSecondPassBlendMode :=
		SDL2 composeCustomBlendMode_srcColorFactor: SDL_BLENDFACTOR_ONE dstColorFactor: SDL_BLENDFACTOR_ONE colorOperation: SDL_BLENDOPERATION_ADD
		srcAlphaFactor: SDL_BLENDFACTOR_ONE dstAlphaFactor: SDL_BLENDFACTOR_ONE alphaOperation: SDL_BLENDOPERATION_ADD ]! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
useCompositeAlphaBlending
	self setBlendMode: SDL_BLENDMODE_BLEND! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
clippingBounds: aRectangle
	renderer setClipRect: aRectangle asSDLRect! !

!OSSDL2GenericRenderer methodsFor: 'resources' stamp: ''!
getOrCreateRenderTargetTextureFor: anObject withExtent: anExtent
	| result |
	result := self renderTargetTextureCache at: anObject ifAbsentPut: [ self createRenderTargetTextureWithExtent: anExtent ].
	result extent ~= anExtent ifTrue: [
		result := self createRenderTargetTextureWithExtent: anExtent.
		self renderTargetTextureCache at: anObject put: result
	].
	^ result! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
setupTextureBlendingState: texture
	texture
		blendMode: activeBlendMode;
		colorModR: activeRed g: activeGreen b: activeBlue;
		alphaMod: activeAlpha! !

!OSSDL2GenericRenderer methodsFor: 'resources' stamp: ''!
createTextureForObjectWithExtent:  anExtent
	| texture |
	texture := renderer createTextureFormat: SDL_PIXELFORMAT_ARGB8888 access: SDL_TEXTUREACCESS_STATIC width: anExtent x height: anExtent y.
	^ OSSDL2WindowRendererTexture new
		extent: anExtent copy;
		handle: texture;
		yourself! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
drawRectangle: aRectangle
	renderer drawRect: aRectangle asSDLRect! !

!OSSDL2GenericRenderer methodsFor: 'resources' stamp: ''!
getRenderTargetTextureForObjectOrNil: anObject
	^ self renderTargetTextureCache at: anObject ifAbsent: [ nil ]! !

!OSSDL2GenericRenderer methodsFor: 'private' stamp: ''!
createStaticTextureFromForm32: form
	| texture |
	self assert: form depth = 32.
	texture := renderer createTextureFormat: SDL_PIXELFORMAT_ARGB8888 access: SDL_TEXTUREACCESS_STATIC width: form width height: form height.
	form unhibernate.
	texture updateTexturePixels: form bits pitch: form width * 4.
	^ OSSDL2WindowRendererTexture new
		extent: form extent copy;
		handle: texture;
		yourself! !

!OSSDL2GenericRenderer methodsFor: 'private' stamp: ''!
renderTargetTextureCache
	^ renderTargetTextureCache ifNil: [ renderTargetTextureCache := WeakKeyDictionary new ]! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
withRenderTarget: aRenderTargetTexture do: aBlock
	| oldRenderTarget |
	oldRenderTarget := currentRenderTarget.
	currentRenderTarget := aRenderTargetTexture ifNotNil: [ aRenderTargetTexture handle ].
	renderer setRenderTarget: currentRenderTarget.
	aBlock ensure: [
		currentRenderTarget := oldRenderTarget.
		renderer setRenderTarget: (currentRenderTarget ifNil: [SDL_Texture null]).
	].! !

!OSSDL2GenericRenderer methodsFor: 'resources' stamp: ''!
getOrCreateTextureFor: anObject withExtent: anExtent
	| result |
	result := self textureForObjectCache at: anObject ifAbsentPut: [ self createTextureForObjectWithExtent: anExtent ].
	result extent ~= anExtent ifTrue: [
		result := self createTextureForObjectWithExtent: anExtent.
		self textureForObjectCache at: anObject put: result
	].
	^ result! !

!OSSDL2GenericRenderer methodsFor: 'private' stamp: ''!
textureForObjectCache
	^ textureForObjectCache ifNil: [ textureForObjectCache := WeakKeyDictionary new ]! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
clear
	renderer clear! !

!OSSDL2GenericRenderer methodsFor: 'resources' stamp: ''!
getTextureForObjectOrNil: anObject
	^ self textureForObjectCache at: anObject ifAbsent: [ nil ]! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
drawPoint: aPoint
	renderer drawPointX: aPoint x asInteger y: aPoint y asInteger! !

!OSSDL2GenericRenderer methodsFor: 'private' stamp: ''!
mapColorChannel: colorChannel
	^ colorChannel * 255 asInteger min: 255 max: 0! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
useModulatingColorBlending
	self setBlendMode: SDL_BLENDMODE_MOD! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
setBlendMode: blendMode
	activeBlendMode := blendMode.
	renderer drawBlendMode: blendMode! !

!OSSDL2GenericRenderer methodsFor: 'clipping' stamp: ''!
fullClippingExtent

	^ ExternalAddress allocate: 8 bytesDuring: [ :buffer | 
		  | result |
		  renderer getLogicalSizeW: buffer h: buffer + 4.
		  result := (buffer unsignedLongAt: 1) @ (buffer unsignedLongAt: 5).
		  (result x = 0 and: [ result y = 0 ]) ifTrue: [ 
			  renderer getOutputSizeW: buffer h: buffer + 4.
			  result := (buffer unsignedLongAt: 1) @ (buffer unsignedLongAt: 5) ].
		  result ]! !

!OSSDL2GenericRenderer methodsFor: 'testing' stamp: ''!
supportsRenderTargets
	^ renderer renderTargetSupported! !

!OSSDL2GenericRenderer methodsFor: 'rendering' stamp: ''!
useNoBlending
	self setBlendMode: SDL_BLENDMODE_NONE! !

!OSSDL2GenericRenderer methodsFor: 'clipping' stamp: ''!
pixelExtent
	^ renderer
		ifNotNil: [ renderer outputExtent ]
		ifNil: [ super pixelExtent ]! !

!OSSDL2WindowRendererTexture commentStamp: ''!
I am a handle for a SDL2 texture created by an OSSDL2GenericRenderer.!
!OSSDL2WindowRendererTexture methodsFor: 'texture manipulation' stamp: ''!
uploadForm: aForm
	| convertedForm |
	convertedForm := aForm asFormOfDepth: 32.
	convertedForm unhibernate.
	handle updateTexturePixels: convertedForm bits pitch: convertedForm width * 4.! !

!OSSDL2WindowRendererTexture methodsFor: 'accessing' stamp: ''!
handle
	^ handle! !

!OSSDL2WindowRendererTexture methodsFor: 'texture manipulation' stamp: ''!
uploadAthensSurface: athensSurface
	handle updateTexturePixels: athensSurface getDataPtr pitch: athensSurface stride.! !

!OSSDL2WindowRendererTexture methodsFor: 'accessing' stamp: ''!
extent
	^ extent! !

!OSSDL2WindowRendererTexture methodsFor: 'accessing' stamp: ''!
handle: anObject
	handle := anObject! !

!OSSDL2WindowRendererTexture methodsFor: 'accessing' stamp: ''!
extent: anObject
	extent := anObject! !

!OSSDLPasteEventFilter methodsFor: 'accessing' stamp: ''!
currentState

	^ currentState ifNil: [ currentState := 1 ]! !

!OSSDLPasteEventFilter methodsFor: 'events-processing' stamp: ''!
changeEventsToIncludeModifier

	| modifierToUse defaultModifier |

	"We modify the KeyUp/KeyDown events to include the correct modifier.
	This is because tools to handle copy/paste use virtual events, and SDL is dropping the modifier.
	
	The correct modifier is calculated depending of the current platform modifier"

	modifierToUse := 0.
	defaultModifier := OSPlatform current defaultModifier.
	
	defaultModifier = KMModifier command ifTrue: [ modifierToUse := KMOD_GUI ].
	defaultModifier = KMModifier alt ifTrue: [ 	modifierToUse := KMOD_LALT ].
	defaultModifier = KMModifier ctrl ifTrue: [ modifierToUse := KMOD_LCTRL ].

	self lastEvents do: [ :anEvent | 
		(anEvent isKeyUpEvent or: [ anEvent isKeyDownEvent ]) 
			ifTrue: [ anEvent keysym mod: (anEvent keysym mod bitOr: modifierToUse) ] ]! !

!OSSDLPasteEventFilter methodsFor: 'events-processing' stamp: ''!
isKeyDownV: aSDLEvent

	^ aSDLEvent isKeyDownEvent 
		and: [ aSDLEvent keysym scancode = 25 "SDL_SCANCODE_V" 
			and: [aSDLEvent keysym sym = SDLK_v]]! !

!OSSDLPasteEventFilter methodsFor: 'accessing' stamp: ''!
next

	^ next! !

!OSSDLPasteEventFilter methodsFor: 'accessing' stamp: ''!
next: anObject

	next := anObject! !

!OSSDLPasteEventFilter methodsFor: 'events-processing' stamp: ''!
dispatchEvent: aSDLEvent
	
	"
	This isssue was first detected in OSX, but we have seen the other platforms code in SDL and it is
	possible the issue will happen in all platforms.
	
	This filter will handle the case when an external Clipboard handling tool is used.
	When an external tool modifies the clipboard and send a virtual paste command, it sends three events:
	
	1) SDL_CLIPBOARDUPDATEEVENT
	2) SDL_KEYDOWN with $v as the key
	3) SDL KEYUP with $v as the keysym 
	
	If we find these three events, we need to modify the last two events to include defaul system modifier.
	Check #changeEventsToIncludeModifier.
	
	This is implemented with a 3 state machine.
	
	State 1: This is the default state. All events are passed to the next filter (or the driver if there is not filter).
	         If we found a Clipboard Update event, we store the event for the future, and change the state to 2. We don't dispatch the event.
	
	State 2: It will check if the event is a KeyDown with a $V and if it is, it will store the event and change to state 3.
	         If the event is other one, it will go to error state and flush all pending events, change to state one and dispatch current event.
	
	State 3: It will check if the event is a KeyUp with a $V and if it is, it will update pending events to have the virtual modifier.
		      Then pending events are flushed.
	         If the event is other one, it will go to error state and flush all pending events, change to state one and dispatch current event. "
	
	(self currentState = 1 and: [aSDLEvent isClipboardUpdateEvent not]) 
		ifTrue: [  ^ next dispatchEvent: aSDLEvent ].

	(self currentState = 1 and: [aSDLEvent isClipboardUpdateEvent]) 
		ifTrue: [ 
			self addEvent: aSDLEvent.
			self currentState: 2.
			 ^ self ].

	(self currentState = 2 and: [self isKeyDownV: aSDLEvent]) 
		ifTrue: [ 
			self addEvent: aSDLEvent.
			self currentState: 3.
			 ^ self ].

	(self currentState = 3 and: [self isKeyUpV: aSDLEvent]) 
		ifTrue: [ 
			self addEvent: aSDLEvent.
			self changeEventsToIncludeModifier.
			self flushEvents.
			self currentState: 1.
			^ self].
	
	self flushEvents.
	self currentState: 1.
	^ next dispatchEvent: aSDLEvent! !

!OSSDLPasteEventFilter methodsFor: 'last events' stamp: ''!
lastEvents

	^ lastEvents ifNil: [ lastEvents := OrderedCollection new ]! !

!OSSDLPasteEventFilter methodsFor: 'last events' stamp: ''!
flushEvents 

	self lastEvents do: [ :anEvent | next dispatchEvent: anEvent ].
	self lastEvents removeAll.! !

!OSSDLPasteEventFilter methodsFor: 'last events' stamp: ''!
addEvent: aEvent

	self lastEvents add: aEvent! !

!OSSDLPasteEventFilter methodsFor: 'events-processing' stamp: ''!
isKeyUpV: aSDLEvent

	^ aSDLEvent isKeyUpEvent 
		and: [ aSDLEvent keysym scancode = 25 "SDL_SCANCODE_V" 
			and: [aSDLEvent keysym sym = SDLK_v]]! !

!OSSDLPasteEventFilter methodsFor: 'accessing' stamp: ''!
currentState: aValue

	currentState := aValue! !

!OSStateModifiers commentStamp: ''!
i holding a collection of various key/button modifier flags, usually carried by certain events and accessible through #modifiers message.!
!OSStateModifiers methodsFor: 'accessing' stamp: ''!
leftCmd: anObject
	
	leftCmd := anObject! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
rightAlt: anObject
	
	rightAlt := anObject! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
any 

	^ self cmd | self alt | self ctrl! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
leftAlt
	
	^ leftAlt! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
rightAlt
	
	^ rightAlt! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
rightShift
	
	^ rightShift! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
capsLock: anObject
	
	capsLock := anObject! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
rightShift: anObject
	
	rightShift := anObject! !

!OSStateModifiers methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: self class name; space; nextPut: $[.
	leftAlt ifTrue: [ aStream nextPutAll: 'leftAlt'; space ].
	leftCmd ifTrue: [ aStream nextPutAll: 'leftCmd'; space ].
	leftCtrl ifTrue: [ aStream nextPutAll: 'leftCtrl'; space ].
	leftShift ifTrue: [ aStream nextPutAll: 'leftShift'; space ].
	rightAlt ifTrue: [ aStream nextPutAll: 'rightAlt'; space ].
	rightCmd ifTrue: [ aStream nextPutAll: 'rightCmd'; space ].
	rightCtrl ifTrue: [ aStream nextPutAll: 'rightCtrl'; space ].
	rightShift ifTrue: [ aStream nextPutAll: 'rightShift'; space ].
	capsLock ifTrue: [ aStream nextPutAll: 'capsLock'; space ].
	numLock ifTrue: [ aStream nextPutAll: 'numLock'; space ].
	
	aStream nextPut: $]; space; print: buttons! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
rightCmd
	
	^ rightCmd! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
buttons
	^ buttons! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
leftShift
	
	^ leftShift! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
alt
	^ leftAlt or: [  rightAlt ]! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
rightCmd: anObject
	
	rightCmd := anObject! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
ctrl
	^ leftCtrl or: [  rightCtrl ]! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
leftCmd
	
	^ leftCmd! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
leftShift: anObject
	
	leftShift := anObject! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
rightCtrl: anObject
	
	rightCtrl := anObject! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
cmd
	^ leftCmd or: [  rightCmd ]! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
numLock: anObject
	
	numLock := anObject! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
leftCtrl
	
	^ leftCtrl! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
shift
	^ leftShift or: [  rightShift ]! !

!OSStateModifiers methodsFor: 'initialization' stamp: ''!
initialize
	leftAlt := leftCmd := leftCtrl := leftShift := rightAlt := rightCmd := rightCtrl := rightShift :=
	capsLock := numLock := false.
	buttons := OSButtonState new.! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
leftCtrl: anObject
	
	leftCtrl := anObject! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
rightCtrl
	
	^ rightCtrl! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
leftAlt: anObject
	
	leftAlt := anObject! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
capsLock
	
	^ capsLock! !

!OSStateModifiers methodsFor: 'accessing' stamp: ''!
numLock
	
	^ numLock! !

!OSTextInputEvent commentStamp: ''!
i am delivered when user enters some text!
!OSTextInputEvent methodsFor: 'accessing' stamp: ''!
position
	
	^ position! !

!OSTextInputEvent methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	modifiers := OSStateModifiers new.! !

!OSTextInputEvent methodsFor: 'accessing' stamp: ''!
text: anObject
	
	text := anObject! !

!OSTextInputEvent methodsFor: 'accessing' stamp: ''!
position: anObject
	
	position := anObject! !

!OSTextInputEvent methodsFor: 'accessing' stamp: ''!
modifiers: anObject
	
	modifiers := anObject! !

!OSTextInputEvent methodsFor: 'accessing' stamp: ''!
modifiers
	
	^ modifiers! !

!OSTextInputEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitTextInputEvent: self! !

!OSTextInputEvent methodsFor: 'accessing' stamp: ''!
text
	
	^ text! !

!OSTouchActionEvent commentStamp: ''!
Super class of all action
!
!OSTouchActionPointerDownEvent commentStamp: ''!
A non-primary pointer has gone down.!
!OSTouchActionPointerDownEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^aVisitor visitTouchPointerDownEvent: self.! !

!OSTouchActionPointerEvent commentStamp: ''!
Superclass of all the pointer Event
	Can be a finger or something else.!
!OSTouchActionPointerEvent methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!OSTouchActionPointerEvent methodsFor: 'accessing' stamp: ''!
delta
	^ delta! !

!OSTouchActionPointerEvent methodsFor: 'accessing' stamp: ''!
position: anObject
	position := anObject! !

!OSTouchActionPointerEvent methodsFor: 'accessing' stamp: ''!
pressure: anObject
	pressure := anObject! !

!OSTouchActionPointerEvent methodsFor: 'accessing' stamp: ''!
fingerId
	^ fingerId! !

!OSTouchActionPointerEvent methodsFor: 'accessing' stamp: ''!
fingerId: anObject
	fingerId := anObject! !

!OSTouchActionPointerEvent methodsFor: 'accessing' stamp: ''!
pressure
	^ pressure! !

!OSTouchActionPointerEvent methodsFor: 'accessing' stamp: ''!
delta: anObject
	delta := anObject! !

!OSTouchActionPointerMoveEvent commentStamp: ''!
aFinger just move.!
!OSTouchActionPointerMoveEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^aVisitor visitTouchPointerMoveEvent: self.! !

!OSTouchActionPointerUpEvent commentStamp: ''!
A non-primary pointer has gone up.!
!OSTouchActionPointerUpEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitTouchPointerUpEvent: self! !

!OSTouchComplexEvent commentStamp: ''!
I am a touch event composed by several others basic events. 
!
!OSTouchComplexEvent methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!OSTouchComplexEvent methodsFor: 'accessing' stamp: ''!
position: anObject
	position := anObject! !

!OSTouchComplexEvent class methodsFor: 'accessing' stamp: ''!
id
	^ #default! !

!OSTouchDirectionnalGestureDetector commentStamp: ''!
I detect gestures which needs all fingers to go on a certain direction (creating a delta distance)!
!OSTouchDirectionnalGestureDetector methodsFor: 'event field' stamp: ''!
dDist
	^ self subclassResponsibility! !

!OSTouchDoubleTapEvent commentStamp: ''!
I am the abstract class for all double tap gestures!
!OSTouchDoubleTapEvent class methodsFor: 'accessing' stamp: ''!
id
	^ #doubleTap! !

!OSTouchEvent commentStamp: ''!
i am the different touch events. As a lot of event should be raises at the same time I should be par of 

I have the same logic as the Android Event. For my realy first draw maybe I should be refined late, depending of the need.

I am design to manage:
	- Touch Event from mobile platform
	- Touch Event from Graphical Tools (graphical palette)
	
Developpement version Todo Work in progress
!
!OSTouchEvent methodsFor: 'accessing' stamp: ''!
timestamp: anObject
	timestamp := anObject! !

!OSTouchEvent methodsFor: 'accessing' stamp: ''!
deviceId
	^ deviceId! !

!OSTouchEvent methodsFor: 'accessing' stamp: ''!
timestamp
	^timestamp! !

!OSTouchEvent methodsFor: 'accessing' stamp: ''!
deviceId: anObject
	deviceId := anObject! !

!OSTouchFingerTracker commentStamp: ''!
I am recording all movements and informations from a finger!
!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
move: anObject
	move := anObject! !

!OSTouchFingerTracker methodsFor: 'updating' stamp: ''!
updateWithEvent: anEvent
	self updateDelta: anEvent delta;
		addToMove: anEvent position;
		pressure: anEvent pressure;
		timestamp: anEvent timestamp! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
deviceId
	^ deviceId! !

!OSTouchFingerTracker methodsFor: 'calculating' stamp: ''!
distanceTravelled
	^ firstPosition distanceTo: lastPosition! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
move
	^ move! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
pressure: anObject
	pressure := anObject! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
timestamp
	^ timestamp! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
deviceId: anObject
	deviceId := anObject! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
fingerId
	^ fingerId! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
fingerId: anObject
	fingerId := anObject! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
delta: anObject
	delta := anObject! !

!OSTouchFingerTracker methodsFor: 'updating' stamp: ''!
updateDelta: aPoint
	delta := (delta + (2 * aPoint)) / 3! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
delta
	^ delta! !

!OSTouchFingerTracker methodsFor: 'moves' stamp: ''!
firstPosition
	^ firstPosition! !

!OSTouchFingerTracker methodsFor: 'initialization' stamp: ''!
initialize
	move := OrderedCollection new.! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
timestamp: anObject
	timestamp := anObject! !

!OSTouchFingerTracker methodsFor: 'calculating' stamp: ''!
isGettingCloserToPoint: aPoint
	| rectangle |
	rectangle := lastPosition rectangle: aPoint.
	^ (rectangle containsPoint: lastPosition + delta)! !

!OSTouchFingerTracker methodsFor: 'calculating' stamp: ''!
direction
	"Only returns noth, east, west, south"
	^ delta x abs > delta y abs
		ifTrue: [ delta x sign @ 0 ]
		ifFalse: [ 0 @ delta y sign ]! !

!OSTouchFingerTracker methodsFor: 'calculating' stamp: ''!
distanceFromLineFormedByFinger: aFingerTracker
	| otherLast |
	otherLast := aFingerTracker lastPosition.

	^ lastPosition distanceTo: 
		(lastPosition nearestPointAlongLineFrom: 
			otherLast + aFingerTracker delta 
		to:
			otherLast)! !

!OSTouchFingerTracker methodsFor: 'calculating' stamp: ''!
totalDistanceTravelled
	| previous sum |
	previous := firstPosition.
	sum := 0.
	move
		do: [ :position | 
			sum := sum + position distanceTo: firstPosition.
			previous := position ].
	^ sum! !

!OSTouchFingerTracker methodsFor: 'moves' stamp: ''!
lastPosition
	^ lastPosition! !

!OSTouchFingerTracker methodsFor: 'moves' stamp: ''!
firstPosition: anObject
	move removeAll.
	firstPosition := anObject.
	self addToMove: firstPosition.! !

!OSTouchFingerTracker methodsFor: 'moves' stamp: ''!
lastPosition: anObject
	lastPosition := anObject! !

!OSTouchFingerTracker methodsFor: 'accessing' stamp: ''!
pressure
	^ pressure! !

!OSTouchFingerTracker methodsFor: 'moves' stamp: ''!
addToMove: aPoint
	move add: aPoint.
	lastPosition := aPoint! !

!OSTouchFingerTracker class methodsFor: 'instance creation' stamp: ''!
for: anEvent
	^ self new deviceId: anEvent deviceId;
		fingerId: anEvent fingerId;
		delta: anEvent delta;
		firstPosition: anEvent position;
		pressure: anEvent pressure;
		timestamp: anEvent timestamp! !

!OSTouchGestureDetector commentStamp: ''!
I am an abstract class for the gestures detector, to work I have to register with an OSWindowGestureHandler!
!OSTouchGestureDetector methodsFor: 'factory' stamp: ''!
sendToEventHandler: anEvent
	eventHandler handleGestureEvent: anEvent! !

!OSTouchGestureDetector methodsFor: 'accessing' stamp: ''!
deviceId
	^ deviceId! !

!OSTouchGestureDetector methodsFor: 'factory' stamp: ''!
centerOfAllFingers
	| fingersPosition sum cpt |
	cpt := 0.
	sum := 0@0.
	fingersPosition := self activeFingers
		collect: [ :fingerTracker | fingerTracker lastPosition ].
	fingersPosition ifEmpty: [ ^ nil ].
	fingersPosition do: [ :point | sum := sum + point. cpt := cpt + 1 ].
	^ sum / cpt! !

!OSTouchGestureDetector methodsFor: 'accessing' stamp: ''!
eventHandler: anObject
	eventHandler := anObject! !

!OSTouchGestureDetector methodsFor: 'accessing' stamp: ''!
activeFingers: anObject
	activeFingers := anObject! !

!OSTouchGestureDetector methodsFor: 'accessing' stamp: ''!
activeFingers
	^ activeFingers! !

!OSTouchGestureDetector methodsFor: 'accessing' stamp: ''!
eventHandler
	^ eventHandler! !

!OSTouchGestureDetector methodsFor: 'accessing' stamp: ''!
deviceId: anInteger
	deviceId := anInteger! !

!OSTouchGestureDetector class methodsFor: 'settings' stamp: ''!
touchGestureSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #touchGestures)
		parent: #appearance;
		label: 'Touch Gestures'! !

!OSTouchGestureDetector class methodsFor: 'initialization' stamp: ''!
reinitializeAllSubclasses
	"self reinitializeAllSubclasses"
	self allSubclassesDo: [ :each | each initialize ]! !

!OSTouchGestureDetector class methodsFor: 'instance creation' stamp: ''!
onDeviceId: anInteger
	^ self new deviceId: anInteger! !

!OSTouchGestureNeedingThresholdDetector commentStamp: ''!
I am a gesture detector for gestures who has to travel a certain distance before being detected!
!OSTouchGestureNeedingThresholdDetector methodsFor: 'calculating' stamp: ''!
distanceTravelledForEachFingers
	^ self activeFingers
			collect: [ :finger | finger distanceTravelled ]! !

!OSTouchGestureNeedingThresholdDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	minDistBeforeDetection := self class minDistanceBeforeDetection.! !

!OSTouchGestureNeedingThresholdDetector methodsFor: 'preconditions' stamp: ''!
eachFingersHadTravelledEnough
	^ self distanceTravelledForEachFingers allSatisfy: [ :each | each > minDistBeforeDetection ]! !

!OSTouchGestureNeedingThresholdDetector methodsFor: 'preconditions' stamp: ''!
beginConditions
	^ super beginConditions and: [ self eachFingersHadTravelledEnough ]! !

!OSTouchGestureNeedingThresholdDetector class methodsFor: 'class initialization' stamp: ''!
initialize
	super initialize.
	MinDistanceBeforeDetection := 0.05! !

!OSTouchGestureNeedingThresholdDetector class methodsFor: 'accessing' stamp: ''!
minDistanceBeforeDetection
	"I am the minimum percentage of the touch device that the user have to travel before the beginning of the event"

	^ MinDistanceBeforeDetection! !

!OSTouchGestureNeedingThresholdDetector class methodsFor: 'accessing' stamp: ''!
minDistanceBeforeDetection: anObject
	MinDistanceBeforeDetection := anObject! !

!OSTouchHoldDetector commentStamp: ''!
I am the abstract class for all the Hold gesture detectors!
!OSTouchHoldDetector methodsFor: 'preconditions' stamp: ''!
necessaryFingers
	self subclassResponsibility! !

!OSTouchHoldDetector methodsFor: 'visiting' stamp: ''!
visitTouchPointerDownEvent: anEvent
	super visitTouchPointerDownEvent: anEvent.
	eventHandler fingerCount = self necessaryFingers
		ifTrue: [  process := self createWaitingProcess ]
		ifFalse: [ process terminate ]! !

!OSTouchHoldDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	waitingTime := self class waitingTime.
	maxDistanceTravelled := self class maxDistanceTravelled.
	process := Process new terminate.! !

!OSTouchHoldDetector methodsFor: 'visiting' stamp: ''!
visitTouchPointerUpEvent: anEvent
	super visitTouchPointerUpEvent: anEvent.
	process terminate! !

!OSTouchHoldDetector methodsFor: 'creation' stamp: ''!
createHoldEvent
	self subclassResponsibility! !

!OSTouchHoldDetector methodsFor: 'creation' stamp: ''!
createWaitingProcess
	^ [ 
	(Delay forMilliseconds: waitingTime) wait.
	(self activeFingers allSatisfy: [ :each | each totalDistanceTravelled < maxDistanceTravelled ])
		ifTrue: [ self sendToEventHandler: self createHoldEvent ] ] fork! !

!OSTouchHoldDetector class methodsFor: 'accessing' stamp: ''!
waitingTime: anObject
	WaitingTime := anObject! !

!OSTouchHoldDetector class methodsFor: 'class initialization' stamp: ''!
initialize
	super initialize.
	MaxDistanceTravelled := 0.02.
	WaitingTime := 1000! !

!OSTouchHoldDetector class methodsFor: 'accessing' stamp: ''!
maxDistanceTravelled: anObject
	MaxDistanceTravelled := anObject! !

!OSTouchHoldDetector class methodsFor: 'accessing' stamp: ''!
waitingTime
	^ WaitingTime! !

!OSTouchHoldDetector class methodsFor: 'settings' stamp: ''!
waitingTimeSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #waitingTime)
		target: self;
		label: 'Time to hold (ms)';
		default: 1000;
		description:
				'How long does a finger has to stay on the screen to be considered as holding';
		parent: #holdGesture! !

!OSTouchHoldDetector class methodsFor: 'accessing' stamp: ''!
maxDistanceTravelled
	^ MaxDistanceTravelled! !

!OSTouchHoldDetector class methodsFor: 'settings' stamp: ''!
maxDistanceTravelledSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #maxDistanceTravelled)
		target: self;
		label: 'Detection area (%)';
		default: 0.02;
		description:
				'The area to consider the finger to be still';
		parent: #holdGesture! !

!OSTouchHoldDetector class methodsFor: 'settings' stamp: ''!
touchHoldSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #holdGesture)
		label: 'Hold';
		parent: #touchGestures! !

!OSTouchHoldEvent commentStamp: ''!
Fingers are staying on the screen!
!OSTouchHoldEvent class methodsFor: 'accessing' stamp: ''!
id
	^ #hold! !

!OSTouchOneDirectionGestureDetector commentStamp: ''!
I detect gestures which needs all fingers to go on the same direction!
!OSTouchOneDirectionGestureDetector methodsFor: 'accessing' stamp: ''!
direction: anObject
	direction := anObject! !

!OSTouchOneDirectionGestureDetector methodsFor: 'accessing' stamp: ''!
direction
	^ direction! !

!OSTouchOneDirectionGestureDetector methodsFor: 'event field' stamp: ''!
dDist
	| directionDDist |
	directionDDist := (self activeFingers collect: [ :each | each delta ]) average * direction abs.
	^ directionDDist x + directionDDist y! !

!OSTouchOneDirectionGestureDetector methodsFor: 'preconditions' stamp: ''!
beginConditions
	^ super beginConditions and: [ self allFingersGoesInTheSameDirection ]! !

!OSTouchOneDirectionGestureDetector methodsFor: 'preconditions' stamp: ''!
allFingersGoesInTheSameDirection
	"We suppose that the direction of the gesture is the same as the first finger"
	direction := self activeFingers first direction.
	
	^ activeFingers allSatisfy: [ :finger | finger direction = direction ]! !

!OSTouchOneFingerDoubleTapDetector commentStamp: ''!
I am the detector of a finger which double tapped.
I send these event back to my handler: 
	- OSTouchOneFingerDoubleTapEvent!
!OSTouchOneFingerDoubleTapDetector methodsFor: 'visiting' stamp: ''!
visitTouchPointerDownEvent: anEvent
	super visitTouchPointerDownEvent: anEvent.
	previousPosition := position.
	previousTimestamp := timestamp.
	position := anEvent position.
	timestamp := anEvent timestamp.
	self checkDoubleTouch.! !

!OSTouchOneFingerDoubleTapDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	doubleTouchSpeed := self class doubleTouchSpeed.
	maxDistanceBetweenEachTouch := self class maxDistance.
	self reinitialize.! !

!OSTouchOneFingerDoubleTapDetector methodsFor: 'operations' stamp: ''!
reinitialize
	position := 0@0.
	timestamp := 0! !

!OSTouchOneFingerDoubleTapDetector methodsFor: 'creation' stamp: ''!
createEvent
	^ OSTouchOneFingerDoubleTapEvent new
		position: position;
		yourself! !

!OSTouchOneFingerDoubleTapDetector methodsFor: 'gesture detection' stamp: ''!
checkDoubleTouch
	(timestamp - previousTimestamp < doubleTouchSpeed 
		and: [ (position distanceTo: previousPosition) < maxDistanceBetweenEachTouch ])
		ifFalse: [ ^ self ].
	self sendToEventHandler: self createEvent.
	self reinitialize! !

!OSTouchOneFingerDoubleTapDetector class methodsFor: 'settings' stamp: ''!
maxDistanceSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #maxDistance)
		target: self;
		label: 'Max distance between tap (%)';
		default: 0.05;
		description:
				'The distance tolerance to send double touch event (in percentage of the window)';
		parent: #doubleTapGesture! !

!OSTouchOneFingerDoubleTapDetector class methodsFor: 'class initialization' stamp: ''!
initialize
	super initialize.
	DoubleTouchSpeed := 700.
	MaxDistance := 0.05! !

!OSTouchOneFingerDoubleTapDetector class methodsFor: 'accessing' stamp: ''!
doubleTouchSpeed: anObject
	DoubleTouchSpeed := anObject! !

!OSTouchOneFingerDoubleTapDetector class methodsFor: 'settings' stamp: ''!
touchDoubleTapSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #doubleTapGesture)
		label: 'Double Tap';
		parent: #touchGestures! !

!OSTouchOneFingerDoubleTapDetector class methodsFor: 'accessing' stamp: ''!
maxDistance
	^ MaxDistance! !

!OSTouchOneFingerDoubleTapDetector class methodsFor: 'accessing' stamp: ''!
doubleTouchSpeed
	^ DoubleTouchSpeed! !

!OSTouchOneFingerDoubleTapDetector class methodsFor: 'accessing' stamp: ''!
maxDistance: anObject
	MaxDistance := anObject! !

!OSTouchOneFingerDoubleTapDetector class methodsFor: 'settings' stamp: ''!
doubleTouchSpeedSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #doubleTouchSpeed)
		target: self;
		label: 'Max time between tap (ms)';
		default: 700;
		description:
				'The time between two touch to send double touch (in milliseconds)';
		parent: #doubleTapGesture! !

!OSTouchOneFingerDoubleTapEvent commentStamp: ''!
A finger tapped quickly two time at the same position!
!OSTouchOneFingerDoubleTapEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchOneFingerDoubleTapEvent: self! !

!OSTouchOneFingerHoldDetector commentStamp: ''!
I am the detector of the hold with one finger.
I send these event back to my handler: 
	- OSTouchOneFingerHoldEvent!
!OSTouchOneFingerHoldDetector methodsFor: 'preconditions' stamp: ''!
necessaryFingers
	^ 1! !

!OSTouchOneFingerHoldDetector methodsFor: 'creation' stamp: ''!
createHoldEvent
	^ OSTouchOneFingerHoldEvent new 
		position: self centerOfAllFingers;
		timestamp: eventHandler lastUpdateTimestamp ;
		deviceId: deviceId;
		yourself! !

!OSTouchOneFingerHoldEvent commentStamp: ''!
One finger is down and has not moved on the screen!
!OSTouchOneFingerHoldEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchOneFingerHoldEvent: self! !

!OSTouchPinchDetector commentStamp: ''!
I am the abstract class for all the Pinch gesture detectors!
!OSTouchPinchDetector methodsFor: 'factory' stamp: ''!
createEventDuringMove
	^ self eventClassMoveGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		dDist: self dDist;
		yourself! !

!OSTouchPinchDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	maxDistanceBetweenFingersLine := self class maxDistanceBetweenFingersLine.! !

!OSTouchPinchDetector methodsFor: 'factory' stamp: ''!
createEventBeginning
	fingersDistanceFromCenter := self fingersDistanceFromCenter.
	^ self eventClassBeginGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		dDist: self dDist;
		yourself! !

!OSTouchPinchDetector methodsFor: 'event field' stamp: ''!
dDist
	| oldDistance |
	oldDistance := fingersDistanceFromCenter.
	fingersDistanceFromCenter := self fingersDistanceFromCenter.
	^ fingersDistanceFromCenter - oldDistance! !

!OSTouchPinchDetector methodsFor: 'preconditions' stamp: ''!
areFingersLinesNotTooFarApart
	| firstFinger secondFinger minDistance |
	firstFinger := self activeFingers first.
	secondFinger := self activeFingers last.
	minDistance := (firstFinger distanceFromLineFormedByFinger: secondFinger)
		min: (secondFinger distanceFromLineFormedByFinger: firstFinger).
	^ minDistance < maxDistanceBetweenFingersLine! !

!OSTouchPinchDetector methodsFor: 'preconditions' stamp: ''!
beginConditions
	^ super beginConditions
		and: [ self areFingersLinesNotTooFarApart
		and: [ self doesFingersGoesInOppositeDirection ]]! !

!OSTouchPinchDetector methodsFor: 'factory' stamp: ''!
createEventEnding
	^ self eventClassEndGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		dDist: self dDist;
		yourself! !

!OSTouchPinchDetector methodsFor: 'preconditions' stamp: ''!
fingersDistanceFromCenter
	| centerOfAllFingers |
	centerOfAllFingers := self centerOfAllFingers.
	^ (self activeFingers collect: [ :each | centerOfAllFingers distanceTo: each lastPosition ]) sum! !

!OSTouchPinchDetector methodsFor: 'preconditions' stamp: ''!
doesFingersGoesInOppositeDirection
	| fingersDirection direction |
	fingersDirection := self activeFingers collect: [ :each | each direction ].

	"We suppose that the direction of the gesture is the same as the first finger"
	direction := fingersDirection first.

	"We remove the first so he can't be evaluated a second time"
	fingersDirection at: 1 put: nil.
	^ fingersDirection anySatisfy: [ :finger | finger = direction negated ]! !

!OSTouchPinchDetector methodsFor: 'abstract' stamp: ''!
eventClassEndGesture
	self subclassResponsibility! !

!OSTouchPinchDetector methodsFor: 'abstract' stamp: ''!
eventClassMoveGesture
	self subclassResponsibility! !

!OSTouchPinchDetector methodsFor: 'abstract' stamp: ''!
eventClassBeginGesture
	self subclassResponsibility! !

!OSTouchPinchDetector class methodsFor: 'accessing' stamp: ''!
maxDistanceBetweenFingersLine: aNumber
	MaxDistanceBetweenFingersLine := aNumber! !

!OSTouchPinchDetector class methodsFor: 'class initialization' stamp: ''!
initialize
	super initialize.
	MaxDistanceBetweenFingersLine := 0.2.
	MinDistanceBeforeDetection := 0.03! !

!OSTouchPinchDetector class methodsFor: 'settings' stamp: ''!
maxDistanceBetweenFingersLineSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #maxDistanceBetweenFingersLine)
		target: self;
		label: 'Max distance between fingers lines (%)';
		default: 0.2;
		description:
				'The maximum distance between the two lines formed by the fingers';
		parent: #pinchGesture! !

!OSTouchPinchDetector class methodsFor: 'settings' stamp: ''!
minDistanceBeforeDetectionSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #minDistanceBeforeDetection)
		target: self;
		label: 'Minimal fingers distance crossed (%)';
		default: 0.05;
		description:
				'The distance, in percentage of the screen, that a finger of both fingers needs to travel before event detection';
		parent: #pinchGesture! !

!OSTouchPinchDetector class methodsFor: 'accessing' stamp: ''!
maxDistanceBetweenFingersLine
	^ MaxDistanceBetweenFingersLine! !

!OSTouchPinchDetector class methodsFor: 'settings' stamp: ''!
touchPinchSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #pinchGesture)
		label: 'Pinch';
		parent: #touchGestures! !

!OSTouchPinchEvent commentStamp: ''!
Superclass of all pinches events!
!OSTouchPinchEvent methodsFor: 'accessing' stamp: ''!
dDist: anObject
	dDist := anObject! !

!OSTouchPinchEvent methodsFor: 'accessing' stamp: ''!
dDist
	^ dDist! !

!OSTouchPinchEvent class methodsFor: 'accessing' stamp: ''!
id
	^ #pinch! !

!OSTouchPunctualGestureDetector commentStamp: ''!
I am an abstract class for gestures which sends events that are puntuals!
!OSTouchRotationDetector commentStamp: ''!
I am the abstract class for all the Rotation gesture detectors!
!OSTouchRotationDetector methodsFor: 'visiting' stamp: ''!
visitTouchPointerDownEvent: anEvent
	super visitTouchPointerDownEvent: anEvent.
	eventHandler fingerCount = self necessaryFingers 
		ifTrue:[ vectorAtBeginnig := self vectorBetweenFirstAndLastFingers ]! !

!OSTouchRotationDetector methodsFor: 'factory' stamp: ''!
createEventDuringMove
	^ self eventClassMoveGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		dTheta: currentAngle - lastAngle;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		yourself! !

!OSTouchRotationDetector methodsFor: 'update' stamp: ''!
updateCurrentAngle
	lastAngle := currentAngle.
	currentAngle := vectorAtBeginnig angleWith: self vectorBetweenFirstAndLastFingers.! !

!OSTouchRotationDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	currentAngle := 0.0.
	minAngleBeforeDetection := self class minAngleBeforeDetection degreesToRadians! !

!OSTouchRotationDetector methodsFor: 'visiting' stamp: ''!
visitTouchPointerMoveEvent: anEvent
	super visitTouchPointerMoveEvent: anEvent.
	eventHandler fingerCount = self necessaryFingers 
		ifTrue:[ self updateCurrentAngle ]! !

!OSTouchRotationDetector methodsFor: 'factory' stamp: ''!
createEventBeginning
	vectorAtBeginnig := self vectorBetweenFirstAndLastFingers.
	currentAngle := vectorAtBeginnig angleWith: self vectorBetweenFirstAndLastFingers.
	self updateCurrentAngle .
	
	^ self eventClassBeginGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		dTheta: 0;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		yourself! !

!OSTouchRotationDetector methodsFor: 'calculating' stamp: ''!
vectorBetweenFirstAndLastFingers
	^ self activeFingers first lastPosition - self activeFingers last lastPosition! !

!OSTouchRotationDetector methodsFor: 'preconditions' stamp: ''!
beginConditions
	^ super beginConditions and: [ self isBrinkAngleOverwhelmed ]! !

!OSTouchRotationDetector methodsFor: 'factory' stamp: ''!
createEventEnding
	^ self eventClassEndGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		dTheta: currentAngle - lastAngle;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		yourself! !

!OSTouchRotationDetector methodsFor: 'abstract' stamp: ''!
eventClassEndGesture
	self subclassResponsibility! !

!OSTouchRotationDetector methodsFor: 'abstract' stamp: ''!
eventClassMoveGesture
	self subclassResponsibility! !

!OSTouchRotationDetector methodsFor: 'abstract' stamp: ''!
eventClassBeginGesture
	self subclassResponsibility! !

!OSTouchRotationDetector methodsFor: 'preconditions' stamp: ''!
isBrinkAngleOverwhelmed
	^ (currentAngle > (2 * Float pi - minAngleBeforeDetection) or: [ currentAngle < minAngleBeforeDetection ]) not! !

!OSTouchRotationDetector class methodsFor: 'accessing' stamp: ''!
minAngleBeforeDetection: anInteger
	MinAngleBeforeDetection := anInteger! !

!OSTouchRotationDetector class methodsFor: 'accessing' stamp: ''!
minAngleBeforeDetection
	"I am the minimum angle, in degrees, required before the beginning of the rotation gesture"

	^ MinAngleBeforeDetection ifNil: [ 10 ]! !

!OSTouchRotationDetector class methodsFor: 'settings' stamp: ''!
touchRotationSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #rotationGesture)
		label: 'Rotation';
		parent: #touchGestures! !

!OSTouchRotationDetector class methodsFor: 'settings' stamp: ''!
minAngleBeforeDetectionSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #minAngleBeforeDetection)
		target: self;
		default: 10;
		label: 'Minimal angle (degrees)';
		description:
				'Minimal angle, in degrees, that the fingers have to rotate before detection';
		parent: #rotationGesture! !

!OSTouchRotationEvent commentStamp: ''!
Superclass of all rotation events!
!OSTouchRotationEvent methodsFor: 'accessing' stamp: ''!
dTheta: anObject
	dTheta := anObject! !

!OSTouchRotationEvent methodsFor: 'accessing' stamp: ''!
dTheta
	^ dTheta! !

!OSTouchRotationEvent class methodsFor: 'accessing' stamp: ''!
id
	^ #rotate! !

!OSTouchScrollDetector commentStamp: ''!
I am the abstract class for all the Scroll gesture detectors!
!OSTouchScrollDetector methodsFor: 'factory' stamp: ''!
createEventDuringMove
	^ self eventClassMoveGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		dDist: self dDist;
		direction: direction;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		yourself! !

!OSTouchScrollDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	persistentDirection := self class persistentDirection.
	directionAtBeginning := 0@0.! !

!OSTouchScrollDetector methodsFor: 'preconditions' stamp: ''!
isKeepingDirection
	^ persistentDirection not
		or: [	directionAtBeginning = (0 @ 0)
		or: [ direction abs = directionAtBeginning abs ] ]! !

!OSTouchScrollDetector methodsFor: 'factory' stamp: ''!
createEventBeginning
	directionAtBeginning := direction.
	^ self eventClassBeginGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		dDist: self dDist;
		direction: direction;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		yourself! !

!OSTouchScrollDetector methodsFor: 'preconditions' stamp: ''!
beginConditions
	^ super beginConditions
		and: [ self isKeepingDirection ]! !

!OSTouchScrollDetector methodsFor: 'factory' stamp: ''!
createEventEnding
	directionAtBeginning := 0@0.
	^ self eventClassEndGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		dDist: self dDist;
		direction: direction;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		yourself! !

!OSTouchScrollDetector methodsFor: 'abstract' stamp: ''!
eventClassEndGesture
	self subclassResponsibility! !

!OSTouchScrollDetector methodsFor: 'abstract' stamp: ''!
eventClassMoveGesture
	self subclassResponsibility! !

!OSTouchScrollDetector methodsFor: 'abstract' stamp: ''!
eventClassBeginGesture
	self subclassResponsibility! !

!OSTouchScrollDetector class methodsFor: 'class initialization' stamp: ''!
initialize
	super initialize.
	PersistentDirection := false! !

!OSTouchScrollDetector class methodsFor: 'settings' stamp: ''!
minDistanceBeforeDetectionSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #minDistanceBeforeDetection)
		target: self;
		label: 'Minimal fingers distance crossed (%)';
		default: 0.05;		
		description:
				'The distance, in percentage of the screen, that both fingers needs to travel before event detection';
		parent: #scrollGesture! !

!OSTouchScrollDetector class methodsFor: 'accessing' stamp: ''!
persistentDirection
	^ PersistentDirection! !

!OSTouchScrollDetector class methodsFor: 'accessing' stamp: ''!
persistentDirection: anObject
	PersistentDirection := anObject! !

!OSTouchScrollDetector class methodsFor: 'settings' stamp: ''!
persistentDirectionSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #persistentDirection)
		target: self;
		label: 'Persitent scrolling';
		default: false;
		description:
				'Should the scroll be keeping his direction after started?';
		parent: #scrollGesture! !

!OSTouchScrollDetector class methodsFor: 'settings' stamp: ''!
touchScrollSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #scrollGesture)
		label: 'Scroll';
		parent: #touchGestures! !

!OSTouchScrollEvent commentStamp: ''!
Superclass of all scrolls events!
!OSTouchScrollEvent methodsFor: 'accessing' stamp: ''!
direction: anObject
	direction := anObject! !

!OSTouchScrollEvent methodsFor: 'accessing' stamp: ''!
dDist: anObject
	dDist := anObject! !

!OSTouchScrollEvent methodsFor: 'accessing' stamp: ''!
direction
	^ direction! !

!OSTouchScrollEvent methodsFor: 'accessing' stamp: ''!
dDist
	^ dDist! !

!OSTouchScrollEvent class methodsFor: 'accessing' stamp: ''!
id
	^ #scroll! !

!OSTouchStateGestureDetector commentStamp: ''!
I am a gesture detector who detects gestures with a begin, current and end state!
!OSTouchStateGestureDetector methodsFor: 'preconditions' stamp: ''!
necessaryFingers
	self subclassResponsibility! !

!OSTouchStateGestureDetector methodsFor: 'visiting' stamp: ''!
visitTouchPointerDownEvent: anEvent
	super visitTouchPointerDownEvent: anEvent.
	self tryToGoThroughNextState! !

!OSTouchStateGestureDetector methodsFor: 'factory' stamp: ''!
createEventDuringMove
	self subclassResponsibility! !

!OSTouchStateGestureDetector methodsFor: 'changing state' stamp: ''!
tryToStartGesture
	self beginConditions ifFalse: [ ^self ].
	modeActivated := true.
	self sendToEventHandler: self createEventBeginning! !

!OSTouchStateGestureDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	modeActivated := false.! !

!OSTouchStateGestureDetector methodsFor: 'visiting' stamp: ''!
visitTouchPointerMoveEvent: anEvent
	super visitTouchPointerMoveEvent: anEvent.
	self tryToGoThroughNextState.
	(modeActivated and: [ self beginConditions ])
		ifTrue: [ self sendToEventHandler: self createEventDuringMove ]! !

!OSTouchStateGestureDetector methodsFor: 'changing state' stamp: ''!
tryToGoThroughNextState
	modeActivated
		ifTrue: [ self tryToEndGesture ]
		ifFalse: [ self tryToStartGesture ]! !

!OSTouchStateGestureDetector methodsFor: 'visiting' stamp: ''!
visitTouchPointerUpEvent: anEvent
	super visitTouchPointerUpEvent: anEvent.
	self tryToGoThroughNextState! !

!OSTouchStateGestureDetector methodsFor: 'preconditions' stamp: ''!
hasGoodNumberOfFingers 
	^ eventHandler fingerCount = self necessaryFingers! !

!OSTouchStateGestureDetector methodsFor: 'factory' stamp: ''!
createEventBeginning
	self subclassResponsibility! !

!OSTouchStateGestureDetector methodsFor: 'preconditions' stamp: ''!
stayActiveConditions
	^ self hasGoodNumberOfFingers! !

!OSTouchStateGestureDetector methodsFor: 'preconditions' stamp: ''!
beginConditions
	^ self hasGoodNumberOfFingers! !

!OSTouchStateGestureDetector methodsFor: 'factory' stamp: ''!
createEventEnding
	self subclassResponsibility! !

!OSTouchStateGestureDetector methodsFor: 'changing state' stamp: ''!
tryToEndGesture
	self stayActiveConditions
		ifTrue: [ ^ self ].
	modeActivated := false.
	self sendToEventHandler: self createEventEnding! !

!OSTouchSwipeDetector commentStamp: ''!
I am the abstract class for all the Swipe gesture detectors!
!OSTouchSwipeDetector methodsFor: 'factory' stamp: ''!
createEventDuringMove
	^ self eventClassMoveGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		direction: direction;
		dDist: self dDist;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		yourself! !

!OSTouchSwipeDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	minDistToBorder := self class minDistToBorder! !

!OSTouchSwipeDetector methodsFor: 'factory' stamp: ''!
createEventBeginning
	^ self eventClassBeginGesture new
		timestamp: eventHandler lastUpdateTimestamp;
		direction: direction;
		dDist: self dDist;
		deviceId: deviceId;
		position: self centerOfAllFingers;
		yourself! !

!OSTouchSwipeDetector methodsFor: 'preconditions' stamp: ''!
beginConditions
	^ super beginConditions and: [ self areFingersCloseToABorder ]! !

!OSTouchSwipeDetector methodsFor: 'factory' stamp: ''!
createEventEnding
	| endClass |
	endClass := self areFingersCloseToABorder ifTrue: [ self eventClassEndGesture ] ifFalse: [ self eventClassAbortGesture ].
	^ endClass new
		timestamp: eventHandler lastUpdateTimestamp;
		direction: direction;
		deviceId: deviceId;
		dDist: self dDist;
		position: self centerOfAllFingers;
		yourself! !

!OSTouchSwipeDetector methodsFor: 'abstract' stamp: ''!
eventClassEndGesture
	self subclassResponsibility! !

!OSTouchSwipeDetector methodsFor: 'abstract' stamp: ''!
eventClassMoveGesture
	self subclassResponsibility! !

!OSTouchSwipeDetector methodsFor: 'preconditions' stamp: ''!
areFingersCloseToABorder
	"0.5 represents half the screen in percentage"
	| halfScreen fingersCenterTranslatedToScreenCenter |
	halfScreen := 0.5.
	
	fingersCenterTranslatedToScreenCenter := (self centerOfAllFingers - halfScreen) abs.
	
	^ modeActivated or: [ fingersCenterTranslatedToScreenCenter x > (halfScreen - minDistToBorder)
		or: [ fingersCenterTranslatedToScreenCenter y > (halfScreen - minDistToBorder)  ]]! !

!OSTouchSwipeDetector methodsFor: 'abstract' stamp: ''!
eventClassAbortGesture
	self subclassResponsibility! !

!OSTouchSwipeDetector methodsFor: 'abstract' stamp: ''!
eventClassBeginGesture
	self subclassResponsibility! !

!OSTouchSwipeDetector class methodsFor: 'class initialization' stamp: ''!
initialize
	super initialize.
	MinDistToBorder := 0.1! !

!OSTouchSwipeDetector class methodsFor: 'settings' stamp: ''!
minDistanceBeforeDetectionSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #minDistanceBeforeDetection)
		target: self;
		label: 'Minimal fingers distance crossed (%)';
		default: 0.05;		
		description:
				'The distance, in percentage of the screen, that both fingers needs to travel before event detection';
		parent: #swipeGesture! !

!OSTouchSwipeDetector class methodsFor: 'accessing' stamp: ''!
minDistToBorder
	^ MinDistToBorder! !

!OSTouchSwipeDetector class methodsFor: 'settings' stamp: ''!
minDistToBorderSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #minDistToBorder)
		target: self;
		default: 0.1;
		label: 'Minimal distance of the fingers to a border (%)';
		description:
				'The distance, in percentage of the screen, that fingers needs to be close to a border to trigger a swipe';
		parent: #swipeGesture! !

!OSTouchSwipeDetector class methodsFor: 'settings' stamp: ''!
touchSwipeSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #swipeGesture)
		label: 'Swipe';
		parent: #touchGestures! !

!OSTouchSwipeDetector class methodsFor: 'accessing' stamp: ''!
minDistToBorder: aFloat
	MinDistToBorder := aFloat .! !

!OSTouchSwipeEvent commentStamp: ''!
Superclass of all swipes events!
!OSTouchSwipeEvent methodsFor: 'accessing' stamp: ''!
direction: anObject
	direction := anObject! !

!OSTouchSwipeEvent methodsFor: 'accessing' stamp: ''!
dDist: anObject
	dDist := anObject! !

!OSTouchSwipeEvent methodsFor: 'accessing' stamp: ''!
direction
	^ direction! !

!OSTouchSwipeEvent methodsFor: 'accessing' stamp: ''!
dDist
	^ dDist! !

!OSTouchSwipeEvent class methodsFor: 'accessing' stamp: ''!
id
	^ #swipe! !

!OSTouchThreeFingersScrollBeginEvent commentStamp: ''!
Three fingers started to scroll!
!OSTouchThreeFingersScrollBeginEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchThreeFingersScrollBeginEvent: self! !

!OSTouchThreeFingersScrollDetector commentStamp: ''!
I am detecting the scrolls made with three fingers.
I send these event back to my handler: 
	- OSTouchThreeFingersScrollBeginEvent 
	- OSTouchThreeFingersScrollMoveEvent 
	- OSTouchThreeFingersScrollEndEvent !
!OSTouchThreeFingersScrollDetector methodsFor: 'preconditions' stamp: ''!
necessaryFingers
	^ 3! !

!OSTouchThreeFingersScrollDetector methodsFor: 'abstract' stamp: ''!
eventClassEndGesture
	^ OSTouchThreeFingersScrollEndEvent! !

!OSTouchThreeFingersScrollDetector methodsFor: 'abstract' stamp: ''!
eventClassMoveGesture
	^ OSTouchThreeFingersScrollMoveEvent! !

!OSTouchThreeFingersScrollDetector methodsFor: 'abstract' stamp: ''!
eventClassBeginGesture
	^ OSTouchThreeFingersScrollBeginEvent! !

!OSTouchThreeFingersScrollEndEvent commentStamp: ''!
Three fingers finished to scroll!
!OSTouchThreeFingersScrollEndEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchThreeFingersScrollEndEvent: self! !

!OSTouchThreeFingersScrollEvent commentStamp: ''!
I am the abstract class for all three fingers scroll events!
!OSTouchThreeFingersScrollMoveEvent commentStamp: ''!
Three fingers are scrolling!
!OSTouchThreeFingersScrollMoveEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchThreeFingersScrollMoveEvent: self! !

!OSTouchThreeFingersSwipeAbortEvent commentStamp: ''!
Three fingers aborted to swipe!
!OSTouchThreeFingersSwipeAbortEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchThreeFingersSwipeAbortEvent: self! !

!OSTouchThreeFingersSwipeBeginEvent commentStamp: ''!
Three fingers started to swipe!
!OSTouchThreeFingersSwipeBeginEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchThreeFingersSwipeBeginEvent: self! !

!OSTouchThreeFingersSwipeDetector commentStamp: ''!
I am detecting the scrolls made with two fingers.
I send these event back to my handler: 
	- OSTouchThreeFingersSwipeBeginEvent 
	- OSTouchThreeFingersSwipeMoveEvent 
	- OSTouchThreeFingersSwipeEndEvent 
	- OSTouchThreeFingersSwipeAbortEvent !
!OSTouchThreeFingersSwipeDetector methodsFor: 'preconditions' stamp: ''!
necessaryFingers
	^ 3! !

!OSTouchThreeFingersSwipeDetector methodsFor: 'abstract' stamp: ''!
eventClassEndGesture
	^ OSTouchThreeFingersSwipeEndEvent! !

!OSTouchThreeFingersSwipeDetector methodsFor: 'abstract' stamp: ''!
eventClassMoveGesture
	^ OSTouchThreeFingersSwipeMoveEvent! !

!OSTouchThreeFingersSwipeDetector methodsFor: 'abstract' stamp: ''!
eventClassAbortGesture
	^ OSTouchThreeFingersSwipeAbortEvent! !

!OSTouchThreeFingersSwipeDetector methodsFor: 'abstract' stamp: ''!
eventClassBeginGesture
	^ OSTouchThreeFingersSwipeBeginEvent! !

!OSTouchThreeFingersSwipeEndEvent commentStamp: ''!
Three fingers finished to swipe!
!OSTouchThreeFingersSwipeEndEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchThreeFingersSwipeEndEvent: self! !

!OSTouchThreeFingersSwipeEvent commentStamp: ''!
I am the abstract class for all three fingers swipe events!
!OSTouchThreeFingersSwipeMoveEvent commentStamp: ''!
Three fingers are swiping!
!OSTouchThreeFingersSwipeMoveEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchThreeFingersSwipeMoveEvent: self! !

!OSTouchTwoFingersPinchBeginEvent commentStamp: ''!
Two fingers started pinching!
!OSTouchTwoFingersPinchBeginEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchTwoFingersPinchBeginEvent: self! !

!OSTouchTwoFingersPinchDetector commentStamp: ''!
I am detecting the pinches made with two fingers.
I send these event back to my handler: 
	- OSTouchTwoFingersPinchBeginEvent 
	- OSTouchTwoFingersPinchMoveEvent 
	- OSTouchTwoFingersPinchEndEvent !
!OSTouchTwoFingersPinchDetector methodsFor: 'preconditions' stamp: ''!
necessaryFingers
	^ 2! !

!OSTouchTwoFingersPinchDetector methodsFor: 'abstract' stamp: ''!
eventClassEndGesture
	^ OSTouchTwoFingersPinchEndEvent! !

!OSTouchTwoFingersPinchDetector methodsFor: 'abstract' stamp: ''!
eventClassMoveGesture
	^ OSTouchTwoFingersPinchMoveEvent! !

!OSTouchTwoFingersPinchDetector methodsFor: 'abstract' stamp: ''!
eventClassBeginGesture
	^OSTouchTwoFingersPinchBeginEvent! !

!OSTouchTwoFingersPinchEndEvent commentStamp: ''!
Two fingers finished to pinch!
!OSTouchTwoFingersPinchEndEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchTwoFingersPinchEndEvent: self! !

!OSTouchTwoFingersPinchEvent commentStamp: ''!
I am the abstract class for all two fingers pinch events!
!OSTouchTwoFingersPinchMoveEvent commentStamp: ''!
Two fingers are pinching!
!OSTouchTwoFingersPinchMoveEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchTwoFingersPinchMoveEvent: self! !

!OSTouchTwoFingersRotationBeginEvent commentStamp: ''!
Two fingers had began to rotate!
!OSTouchTwoFingersRotationBeginEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchTwoFingersRotationBeginEvent: self! !

!OSTouchTwoFingersRotationDetector commentStamp: ''!
I am detecting the rotations made with two fingers.
I send these event back to my handler: 
	- OSTouchTwoFingersRotationBeginEvent 
	- OSTouchTwoFingersRotationMoveEvent 
	- OSTouchTwoFingersRotationEndEvent !
!OSTouchTwoFingersRotationDetector methodsFor: 'preconditions' stamp: ''!
necessaryFingers
	^ 2! !

!OSTouchTwoFingersRotationDetector methodsFor: 'abstract' stamp: ''!
eventClassEndGesture
	^ OSTouchTwoFingersRotationEndEvent! !

!OSTouchTwoFingersRotationDetector methodsFor: 'abstract' stamp: ''!
eventClassMoveGesture
	^ OSTouchTwoFingersRotationMoveEvent! !

!OSTouchTwoFingersRotationDetector methodsFor: 'abstract' stamp: ''!
eventClassBeginGesture
	^ OSTouchTwoFingersRotationBeginEvent! !

!OSTouchTwoFingersRotationEndEvent commentStamp: ''!
Two fingers had stopped to rotate!
!OSTouchTwoFingersRotationEndEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchTwoFingersRotationEndEvent: self! !

!OSTouchTwoFingersRotationEvent commentStamp: ''!
I am the abstract class for all two fingers rotation events!
!OSTouchTwoFingersRotationMoveEvent commentStamp: ''!
Two fingers are rotating!
!OSTouchTwoFingersRotationMoveEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchTwoFingersRotationMoveEvent: self! !

!OSTouchTwoFingersScrollBeginEvent commentStamp: ''!
Two fingers started to scroll!
!OSTouchTwoFingersScrollBeginEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchTwoFingersScrollBeginEvent: self! !

!OSTouchTwoFingersScrollDetector commentStamp: ''!
I am detecting the scrolls made with two fingers.
I send these event back to my handler: 
	- OSTouchTwoFingersScrollBeginEvent 
	- OSTouchTwoFingersScrollMoveEvent 
	- OSTouchTwoFingersScrollEndEvent !
!OSTouchTwoFingersScrollDetector methodsFor: 'preconditions' stamp: ''!
necessaryFingers
	^ 2! !

!OSTouchTwoFingersScrollDetector methodsFor: 'abstract' stamp: ''!
eventClassEndGesture
	^ OSTouchTwoFingersScrollEndEvent! !

!OSTouchTwoFingersScrollDetector methodsFor: 'abstract' stamp: ''!
eventClassMoveGesture
	^ OSTouchTwoFingersScrollMoveEvent! !

!OSTouchTwoFingersScrollDetector methodsFor: 'abstract' stamp: ''!
eventClassBeginGesture
	^ OSTouchTwoFingersScrollBeginEvent! !

!OSTouchTwoFingersScrollEndEvent commentStamp: ''!
Two fingers stopped to scroll!
!OSTouchTwoFingersScrollEndEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchTwoFingersScrollEndEvent: self! !

!OSTouchTwoFingersScrollEvent commentStamp: ''!
I am the abstract class for all two fingers scroll events!
!OSTouchTwoFingersScrollMoveEvent commentStamp: ''!
Two fingers are scrolling!
!OSTouchTwoFingersScrollMoveEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	aVisitor visitTouchTwoFingersScrollMoveEvent: self! !

!OSUnknownEvent commentStamp: ''!
I am delivered , when driver don't knows how to interpret the event which comes from OS.
Useful for debugging.!
!OSUnknownEvent methodsFor: 'accessing' stamp: ''!
data: anObject
	
	data := anObject! !

!OSUnknownEvent methodsFor: 'accessing' stamp: ''!
data
	
	^ data! !

!OSUnknownEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitUnknownEvent: self! !

!OSWindow commentStamp: ''!
I am a central class, which provides a top-level API for creating/controlling an operating-system windows.

To create a new OS window with default attributes, just use

OSWindow new.

For better control of window creation, use 

OSWindow createWithAttributes: ...

message. (See OSWindowAttributes for description).

A newly created OSWindow instance can be used and controlled by application.
To handle events (mouse/keyboard) of newly created window, one must 
bind own event handler to it (#eventHandler:) which must understand #handleEvent: message.

To render on window's surface, first application must obtain an OSWindowRenderer instance.
Currently there's two kinds of renderers available:
- form renderer (to use existing form for updating window's contents)
- opengl renderer (to render using OpenGL).

OSWindow instance and its handle: 
 - all operations with window (like hiding/showing/resizing etc) is possible only if its handle is valid. If window gets destroyed, or image opened in a new session while window was created in previous session, the handle becomes invalid, and any operations will lead to error. 
To test if window is still valid, you can just use #isValid message.

Text input

Why does OSWindow need a text input API?
When I press a key on my keyboard, my program receives a character event, right?
Well, it's not always that simple. Sometimes it can take multiple key presses to produce a character. Sometimes a single key press can produce multiple characters.
Text input is not as simple as it seems, particularly when you consider International users (and you should). It's not hard to figure out why that is when you look at languages like Chinese, Japanese, and Korean. These languages, collectively referred to as the CJK, have thousands of symbols.
It would not be feasible to have a keyboard with over ten-thousand keys, would it? The solution to this is a software input method.

Related methods:
 - startTextInput
 - stopTextInput
 - isTextInputActive

(reference https://wiki.libsdl.org/Tutorials/TextInput)!
!OSWindow methodsFor: 'window management' stamp: ''!
restore

	self validHandle restore.! !

!OSWindow methodsFor: 'accessing' stamp: ''!
setMouseCursor: cursor mask: mask andScale: scale
	currentCursor == cursor ifTrue: [ ^ self ].
	currentCursor := cursor.

	self validHandle setMouseCursor: cursor mask: mask andScale: scale! !

!OSWindow methodsFor: 'factory' stamp: ''!
newGenericRenderer
	^ backendWindow ifNotNil: [backendWindow newGenericRenderer]! !

!OSWindow methodsFor: 'window management' stamp: ''!
minimize

	self validHandle minimize.! !

!OSWindow methodsFor: 'accessing' stamp: ''!
position: newPosition
	self validHandle position: newPosition! !

!OSWindow methodsFor: 'window management' stamp: ''!
toggleBorderOn

	self validHandle toggleBorderOn.! !

!OSWindow methodsFor: 'window management' stamp: ''!
setDraggableArea: aRectangle

	^self validHandle setDraggableArea: aRectangle.! !

!OSWindow methodsFor: 'accessing' stamp: ''!
borderless: aBoolean
	self validHandle borderless: aBoolean! !

!OSWindow methodsFor: 'visibility' stamp: ''!
hide
	self checkIsValid .
	backendWindow hide! !

!OSWindow methodsFor: 'accessing' stamp: ''!
verticalDPI
	^ self validHandle verticalDPI! !

!OSWindow methodsFor: 'accessing' stamp: ''!
eventHandler
	
	^ eventHandler! !

!OSWindow methodsFor: 'private' stamp: ''!
validHandle
	self checkIsValid.
	^ backendWindow! !

!OSWindow methodsFor: 'accessing' stamp: ''!
icon: aForm
	self validHandle icon: aForm! !

!OSWindow methodsFor: 'dispatching events' stamp: ''!
deliverEvent: anEvent
	"TODO..."

	TraceEvents
		ifTrue: [ self traceCr: anEvent ].
	eventHandler ifNotNil: [ eventHandler handleEvent: anEvent ].! !

!OSWindow methodsFor: 'window management' stamp: ''!
focus

	self validHandle raise.! !

!OSWindow methodsFor: 'testing' stamp: ''!
isVisible
	^ self isValid and: [backendWindow isVisible]! !

!OSWindow methodsFor: 'accessing' stamp: ''!
renderer
	^ backendWindow renderer! !

!OSWindow methodsFor: 'accessing' stamp: ''!
setMouseCursor: cursorWithMask
	currentCursor == cursorWithMask ifTrue: [ ^ self ].
	currentCursor := cursorWithMask.
	self validHandle setMouseCursor: cursorWithMask! !

!OSWindow methodsFor: 'clipboard handling' stamp: ''!
clipboardText: aString
	^ self validHandle clipboardText: aString! !

!OSWindow methodsFor: 'accessing' stamp: ''!
extent
	^ self validHandle extent! !

!OSWindow methodsFor: 'accessing' stamp: ''!
fullscreen: aBoolean
	self validHandle fullscreen: aBoolean! !

!OSWindow methodsFor: 'visibility' stamp: ''!
show
	self checkIsValid .
	backendWindow show! !

!OSWindow methodsFor: 'private' stamp: ''!
checkIsValid

	(backendWindow isNil or: [ backendWindow isValid not ]) ifTrue: [ self invalidHandle ].! !

!OSWindow methodsFor: 'instance creation' stamp: ''!
newAthensRenderer
	^ backendWindow ifNotNil: [backendWindow newAthensRenderer]! !

!OSWindow methodsFor: 'dispatching events' stamp: ''!
deliverGlobalEvent: aGlobalEvent
	"TODO..."

	TraceEvents
		ifTrue: [ self traceCr: aGlobalEvent ].
	eventHandler ifNotNil: [ eventHandler handleEvent: aGlobalEvent ]! !

!OSWindow methodsFor: 'window management' stamp: ''!
toggleBorderOff

	self validHandle toggleBorderOff.! !

!OSWindow methodsFor: 'private' stamp: ''!
createWindow
	backendWindow ifNotNil: [ self error: 'The window is already created.' ].
	
	backendWindow := initialAttributes createWindowHandleFor: self.
	backendWindow isValid ifTrue: [ 
		"Handle here points to an OSWindowHandle, its #handle message has the real 
		 external resource. This is a bit confusing, but is better like this :)"
		backendWindow prepareExternalResourceForAutoRelease ]! !

!OSWindow methodsFor: 'accessing' stamp: ''!
borderless
	^ self validHandle borderless! !

!OSWindow methodsFor: 'private' stamp: ''!
setJustCreatedHandle: aHandle
	"This method is to be called by a driver that needs to create the window in a critical section to prevent a race condition where some events such as expose could be missed."
	backendWindow := aHandle! !

!OSWindow methodsFor: 'accessing' stamp: ''!
resizable
	^ self validHandle resizable! !

!OSWindow methodsFor: 'accessing' stamp: ''!
position
	^ self validHandle position! !

!OSWindow methodsFor: 'accessing' stamp: ''!
bounds
	^ self validHandle bounds! !

!OSWindow methodsFor: 'text input' stamp: ''!
isTextInputActive
	"Check whether or not Unicode text input events are enabled"

	^ self validHandle isTextInputActive! !

!OSWindow methodsFor: 'factory' stamp: ''!
newOpenGLRenderer
	^ backendWindow ifNotNil: [backendWindow newOpenGLRenderer]! !

!OSWindow methodsFor: 'accessing' stamp: ''!
resizable: aBoolean
	self validHandle resizable: aBoolean! !

!OSWindow methodsFor: 'accessing' stamp: ''!
bounds: newBounds
	self validHandle bounds: newBounds! !

!OSWindow methodsFor: 'accessing' stamp: ''!
horizontalDPI
	^ self validHandle horizontalDPI! !

!OSWindow methodsFor: 'accessing' stamp: ''!
eventHandler: anObject
	
	eventHandler := anObject! !

!OSWindow methodsFor: 'private' stamp: ''!
invalidHandle
	self error: 'Invalid window handle'! !

!OSWindow methodsFor: 'accessing' stamp: ''!
screenScaleFactorBaseDPI
	^ self validHandle screenScaleFactorBaseDPI! !

!OSWindow methodsFor: 'event handling' stamp: ''!
processPendingEvents
	backendWindow processPendingEvents! !

!OSWindow methodsFor: 'initialization' stamp: ''!
initWithAttributes: attributes eventHandler: anEventHandle
	initialAttributes := attributes.
	eventHandler := anEventHandle.
	self createWindow.
	self initialize! !

!OSWindow methodsFor: 'accessing' stamp: ''!
backendWindow
	^ backendWindow! !

!OSWindow methodsFor: 'private' stamp: ''!
destroy
	self validHandle destroy.
	backendWindow := nil.
	eventHandler := nil.! !

!OSWindow methodsFor: 'accessing' stamp: ''!
diagonalDPI
	^ self validHandle diagonalDPI! !

!OSWindow methodsFor: 'accessing' stamp: ''!
screenScaleFactor
	^ self validHandle screenScaleFactor! !

!OSWindow methodsFor: 'mouse capture' stamp: ''!
releaseMouse
	self validHandle releaseMouse! !

!OSWindow methodsFor: 'accessing' stamp: ''!
extent: newExtent
	self validHandle extent: newExtent! !

!OSWindow methodsFor: 'text input' stamp: ''!
stopTextInput
	"Stop receiving any text input events"

	self validHandle stopTextInput! !

!OSWindow methodsFor: 'accessing' stamp: ''!
title
	^ self validHandle title! !

!OSWindow methodsFor: 'accessing' stamp: ''!
windowId
	^ self validHandle windowId! !

!OSWindow methodsFor: 'accessing' stamp: ''!
platformSpecificHandle
	^ self validHandle platformSpecificHandle! !

!OSWindow methodsFor: 'accessing' stamp: ''!
title: aString
	self validHandle title: aString! !

!OSWindow methodsFor: 'text input' stamp: ''!
startTextInput
	"Start accepting Unicode text input events.
	I will start accepting Unicode text input events in the focused window, and start emitting text input and text editing events.
	Please use me in pair with stopTextInput.
	On some platforms I may activate the screen keyboard."

	self validHandle startTextInput! !

!OSWindow methodsFor: 'accessing' stamp: ''!
renderer: aRenderer
	backendWindow renderer: aRenderer! !

!OSWindow methodsFor: 'factory' stamp: ''!
newFormRenderer: form
	^ backendWindow ifNotNil: [backendWindow newFormRenderer: form]! !

!OSWindow methodsFor: 'accessing' stamp: ''!
setMouseCursor: cursor mask: mask

	self setMouseCursor: cursor mask: mask andScale: 1! !

!OSWindow methodsFor: 'mouse capture' stamp: ''!
captureMouse
	self validHandle captureMouse! !

!OSWindow methodsFor: 'testing' stamp: ''!
isValid
	 ^ backendWindow notNil and: [ backendWindow isValid ]! !

!OSWindow methodsFor: 'clipboard handling' stamp: ''!
clipboardText
	^ self validHandle clipboardText! !

!OSWindow methodsFor: 'private' stamp: ''!
getFlags
	^ self validHandle getFlags! !

!OSWindow methodsFor: 'events' stamp: ''!
updateToNewResolution
	
	self backendWindow updateToNewResolution! !

!OSWindow methodsFor: 'window management' stamp: ''!
maximize

	self validHandle maximize.! !

!OSWindow class methodsFor: 'instance creation' stamp: ''!
new
	^ self createWithAttributes: OSWindowAttributes new! !

!OSWindow class methodsFor: 'class initialization' stamp: ''!
initialize 

	self traceEvents: false! !

!OSWindow class methodsFor: 'clipboard handling' stamp: ''!
clipboardText: aString
	self validHandle clipboardText: aString! !

!OSWindow class methodsFor: 'instance creation' stamp: ''!
createWithAttributes: attributes eventHandler: eventHandler
	^ self basicNew initWithAttributes: attributes eventHandler: eventHandler! !

!OSWindow class methodsFor: 'tracing' stamp: ''!
traceEvents: aBoolean
	TraceEvents := aBoolean! !

!OSWindow class methodsFor: 'instance creation' stamp: ''!
newWithNullDriver
	^ self createWithAttributes: OSWindowAttributes newWithNullDriver! !

!OSWindow class methodsFor: 'clipboard handling' stamp: ''!
clipboardText
	^ self validHandle clipboardText! !

!OSWindow class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: windowHandle
	windowHandle destroy.! !

!OSWindow class methodsFor: 'instance creation' stamp: ''!
createWithAttributes: attributes
	^ self createWithAttributes: attributes eventHandler: nil! !

!OSWindowAnimated commentStamp: ''!
I am an animated window who interacts with the OSWindowRenderThread!
!OSWindowAnimated methodsFor: 'private' stamp: ''!
registerWindow
	OSWindowRenderThread createdWindow: self.! !

!OSWindowAnimated methodsFor: 'initialization' stamp: ''!
initWithAttributes: attributes eventHandler: anEventHandle
	super initWithAttributes: attributes eventHandler: anEventHandle.
	self registerWindow.! !

!OSWindowAnimated methodsFor: 'private' stamp: ''!
destroy
	OSWindowRenderThread destroyedWindow: self.
	super destroy! !

!OSWindowAthensDrawingExampleEventHandler commentStamp: ''!
i a m the event handler linked to SDL2AthensDrawingExample!
!OSWindowAthensDrawingExampleEventHandler methodsFor: 'visiting' stamp: ''!
visitMouseButtonReleaseEvent: anEvent
	athensExample endStroke! !

!OSWindowAthensDrawingExampleEventHandler methodsFor: 'visiting' stamp: ''!
visitMouseButtonPressEvent: anEvent
	anEvent button = 1
		ifTrue: [ ^ athensExample startStrokeAt: anEvent position ].
	athensExample clearStrokes! !

!OSWindowAthensDrawingExampleEventHandler methodsFor: 'visiting' stamp: ''!
visitMouseMoveEvent: anEvent
	athensExample moveAt: anEvent position! !

!OSWindowAthensExampleEventHandler commentStamp: ''!
I am the event handler linked to the SDL2AthensExample!
!OSWindowAthensExampleEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowCloseEvent: anEvent
	athensExample destroy! !

!OSWindowAthensExampleEventHandler methodsFor: 'accessing' stamp: ''!
athensExample: anObject
	athensExample := anObject! !

!OSWindowAthensExampleEventHandler methodsFor: 'accessing' stamp: ''!
athensExample
	^ athensExample! !

!OSWindowAthensRenderer commentStamp: ''!
I am an abstract Athens renderer. !
!OSWindowAthensRenderer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	session := Smalltalk session! !

!OSWindowAthensRenderer methodsFor: 'drawing' stamp: ''!
drawDuring: aBlock
	self prepareForDrawing.
	self athensSurface drawDuring: aBlock! !

!OSWindowAthensRenderer methodsFor: 'drawing' stamp: ''!
prepareForDrawing! !

!OSWindowAthensRenderer methodsFor: 'accessing' stamp: ''!
surface
	^ self athensSurface! !

!OSWindowAthensRenderer methodsFor: 'accessing' stamp: ''!
athensSurface
	^ athensSurface! !

!OSWindowAthensRenderer methodsFor: 'session management' stamp: ''!
checkSession
	session == Smalltalk session 
		ifFalse: [ self error: 'Cannot use this renderer (created in a previous session or in a closed window)' ].! !

!OSWindowAthensRenderer methodsFor: 'deleting' stamp: ''!
destroy
	
	super destroy.
	athensSurface := nil.
	session := nil.! !

!OSWindowAthensRenderer methodsFor: 'accessing' stamp: ''!
pixelExtent
	"The extent of the window may not be in pixels, so we have to ask to the actual
	drawing surface for its size in pixel. This is specially true under OS X with HiDPI suppport."
	self checkSession.
	^ self athensSurface extent! !

!OSWindowAttributes commentStamp: ''!
My instances hold a number of various attributes, used during initial window creation and its initialization:

- initial bounds
- title
- icon
- screen id
- fullscreen or not
- etc...

Please note, that depending on driver used, some attributes can be ignored by driver and will have no any effect.  

The preferableDriver attribute is special, that it allows user to bypass the default driver selection mechanism and tell directly, which driver shall be used for creating a window.!
!OSWindowAttributes methodsFor: 'private' stamp: ''!
createWindowHandleFor: osWindow
	^ (preferableDriver
		ifNil: [ preferableDriver := OSWindowDriver current ])
		createWindowWithAttributes: self
		osWindow: osWindow! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
bounds
	^ position extent: extent! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
maximized: aBoolean
	maximized := aBoolean! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
glAttributes
	
	^ glAttributes! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
maximized
	^ maximized! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
preferableDriver: anObject
	
	preferableDriver := anObject! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
position: aPoint
	position := aPoint! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
resizable: aBoolean
	resizable := aBoolean! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
screenId
	^ screenId! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
bounds: aRectangle
	position := aRectangle origin.
	extent := aRectangle extent.! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
x
	^ position x! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
borderless: anObject
	borderless := anObject! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
y
	^ position y! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
icon
	
	^ icon! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
extent: newExtent
	extent := newExtent! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
icon: anObject
	
	icon := anObject! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
screenId: newScreenId
	screenId := newScreenId! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
title
	
	^ title! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
width
	^ extent x! !

!OSWindowAttributes methodsFor: 'initialization' stamp: ''!
initialize
	visible := self class defaultVisible.
	position := self class defaultPosition.
	extent := self class defaultExtent.
	fullscreen := self class defaultFullscreen.
	title := self class defaultTitle.
	windowCentered := self class defaultWindowCentered.

	borderless := self class defaultBorderless.
	resizable := self class defaultResizable.
	minimized := self class defaultMinimized.
	maximized := self class defaultMaximized! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
title: anObject
	
	title := anObject! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
glAttributes: anObject
	
	glAttributes := anObject! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
extent
	^ extent! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
fullscreen: anObject
	
	fullscreen := anObject! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
fullscreen
	
	^ fullscreen! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
minimized
	^ minimized! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
height
	^ extent y! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
visible: aBoolean
	visible := aBoolean! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
windowCentered
	^ windowCentered! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
windowCentered: aBoolean
	windowCentered := aBoolean! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
preferableDriver
	
	^ preferableDriver! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
applyTo: window
	window title: self title;
		icon: self icon.! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
minimized: aBoolean
	minimized := aBoolean! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
visible
	^ visible! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
borderless
	^ borderless! !

!OSWindowAttributes methodsFor: 'accessing' stamp: ''!
resizable
	^ resizable! !

!OSWindowAttributes class methodsFor: 'defaults' stamp: ''!
defaultFullscreen
	^ DefaultFullscreen! !

!OSWindowAttributes class methodsFor: 'class initialization' stamp: ''!
initialize
	"
	self initialize
	"
	DefaultPosition := 0@0.
	DefaultExtent :=150@150.
	DefaultFullscreen  := false.
	DefaultWindowCentered := false.
	DefaultTitle := 'New Window'.
	DefaultVisible := true.

	DefaultBorderless := false.
	DefaultResizable := true.
	DefaultMaximized := false.
	DefaultMinimized := false.! !

!OSWindowAttributes class methodsFor: 'defaults' stamp: ''!
defaultMinimized
	^ DefaultMinimized! !

!OSWindowAttributes class methodsFor: 'defaults' stamp: ''!
defaultTitle
	^ DefaultTitle! !

!OSWindowAttributes class methodsFor: 'defaults' stamp: ''!
defaultPosition
	^ DefaultPosition! !

!OSWindowAttributes class methodsFor: 'defaults' stamp: ''!
defaultExtent
	^ DefaultExtent! !

!OSWindowAttributes class methodsFor: 'instance creation' stamp: ''!
newWithNullDriver
	^ self new preferableDriver: OSNullWindowDriver new; yourself! !

!OSWindowAttributes class methodsFor: 'defaults' stamp: ''!
defaultVisible
	^ DefaultVisible! !

!OSWindowAttributes class methodsFor: 'defaults' stamp: ''!
defaultWindowCentered
	^ DefaultWindowCentered! !

!OSWindowAttributes class methodsFor: 'defaults' stamp: ''!
defaultBorderless
	^ DefaultBorderless! !

!OSWindowAttributes class methodsFor: 'defaults' stamp: ''!
defaultResizable
	^ DefaultResizable! !

!OSWindowAttributes class methodsFor: 'defaults' stamp: ''!
defaultMaximized
	^ DefaultMaximized! !

!OSWindowAttributesTest commentStamp: ''!
An OSWindowAttributesTest is a test class for testing the behavior of OSWindowAttributes!
!OSWindowAttributesTest methodsFor: 'tests' stamp: ''!
testDefaults
	| attributes |
	attributes := OSWindowAttributes new.
	self assert: attributes position equals: attributes class defaultPosition.
	self assert: attributes extent equals: attributes class defaultExtent.
	self assert: attributes fullscreen equals: attributes class defaultFullscreen.
	self assert: attributes title equals: attributes class defaultTitle! !

!OSWindowBench commentStamp: ''!
Benchmark for window processing!
!OSWindowBench methodsFor: 'benchmarking' stamp: ''!
benchEventProcessing
	<script: 'self new benchEventProcessing'>
	
	| window sema |
	
	window := self currentWorld osWindow.
	sema := Semaphore new.
	[ 
		"TimeProfiler spyAllOn:[ sema wait ]"		
		AndreasSystemProfiler spyOn: [ sema wait ].
	] forkAt: Processor userInterruptPriority.
	
	[ 20 timesRepeat: [  
			1 to: 500 do: [ :i | 
				| event |
				event := OSMouseMoveEvent for: window.
				event 
					position: i @ 100;
					delta: 1 @ 0.
				event deliver ].
			(Delay forMilliseconds: 20) wait ].
		sema signal
	] forkAt: 60.! !

!OSWindowClipboard commentStamp: ''!
This is a private class for handling clipboard text. There's no direct use of it.
For setting/retrieving clipboard text, use clipboardText/clipboardText: accessors of OSWindow instances.!
!OSWindowClipboard methodsFor: 'private' stamp: ''!
noteRecentClipping: text! !

!OSWindowClipboard methodsFor: 'accessing' stamp: ''!
chooseRecentClipping
	^ nil! !

!OSWindowClipboard methodsFor: 'accessing' stamp: ''!
clipboardText: aString
	self worldRenderer clipboardText: aString asString! !

!OSWindowClipboard methodsFor: 'accessing' stamp: ''!
beDefault

	Default := self! !

!OSWindowClipboard methodsFor: 'accessing' stamp: ''!
clipboardText
	^ self worldRenderer clipboardText withInternalLineEndings! !

!OSWindowClipboard methodsFor: 'accessing' stamp: ''!
worldRenderer 

	^ self currentWorld worldState worldRenderer! !

!OSWindowCloseEvent commentStamp: ''!
I am delivered when user closing the window.
The default action (unless suppressed) will also destroy the window.!
!OSWindowCloseEvent methodsFor: 'default actions' stamp: ''!
defaultAction
	window destroy! !

!OSWindowCloseEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowCloseEvent: self! !

!OSWindowDriver commentStamp: ''!
I am a basic (abstract) class, which represents an OS window driver.
The driver connects an OSWindow instances with underlaying operating system window(s) through managing OSWindowHandle(s). Driver provides an implemenation of all OSWindow functionality, starting from its creation, setting/retrieving its attributes, and finishing with event handling and/or rendering window's contents on screen.

The driver connects OSWindow(s) with operating system windows by providing the handle (see OSWindowHandle). The way how various OSWindow features and API are implemented is up to the concrete driver and thus considered private.

The driver(s) responsible for initial window creation , proper setup and and managing external resources. 
Again, most of driver's functionality is considered private and application-level code should not rely on any of its features. 

Driver selection mechanism:

 - on session change, i scan all of my subclasses to pick a most suitable driver which will be used on current platform (see #current on my class side)!
!OSWindowDriver methodsFor: 'events' stamp: ''!
afterMainPharoWindowCreated: aWindow! !

!OSWindowDriver methodsFor: 'window creation' stamp: ''!
createWindowWithAttributes: anOSWindowAttributes osWindow: osWindow
	self subclassResponsibility! !

!OSWindowDriver methodsFor: 'events' stamp: ''!
afterSetWindowTitle: windowTitle onWindow: osWindow! !

!OSWindowDriver methodsFor: 'system startup' stamp: ''!
shutDown
	"A hook to perform cleanups when shuting down a driver"! !

!OSWindowDriver methodsFor: 'testing' stamp: ''!
isNullDriver
	^ false! !

!OSWindowDriver class methodsFor: 'driver selection' stamp: ''!
pickDriverClass

	self subclassesDo: [ :s | s isSuitable ifTrue: [ ^ s ] ].
	^ OSNullWindowDriver! !

!OSWindowDriver class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default registerSystemClassNamed: self name! !

!OSWindowDriver class methodsFor: 'accessing' stamp: ''!
current

	Session == Smalltalk session ifTrue: [ 
		^ Current ifNil: [ Current := self driverClass new ] ].
	
	Session := Smalltalk session.
	^ Current := self driverClass new! !

!OSWindowDriver class methodsFor: 'settings' stamp: ''!
driverClass

	^ DriverClass ifNil: [ DriverClass := self pickDriverClass ]! !

!OSWindowDriver class methodsFor: 'system startup' stamp: ''!
shutDown: quitting
	quitting ifFalse: [ ^ self ].
	Current ifNil: [ ^ self ].

	"Clean driver"
	Current shutDown.
	Current := nil.
	
	"clean OSWindow worlds"
	WorldMorph extraWorldList copy 
		select: [ :each | each isKindOf: OSWindowWorldMorph ]
		thenDo: [ :each | WorldMorph removeExtraWorld: each ].
	"Clean also active world"
	(ActiveWorld isKindOf: OSWindowWorldMorph)
		ifTrue: [ ActiveWorld := nil ]! !

!OSWindowDriver class methodsFor: 'testing' stamp: ''!
isSuitable
	"Answer true if receiver is most suitable for using in current session/platform"
	^ false! !

!OSWindowDriver class methodsFor: 'testing' stamp: ''!
isSupported
	"Answer true if receiver is most suitable for using in current session/platform"
	^ false! !

!OSWindowDriver class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	
	(aBuilder group: #oswindow)
		label: 'OSWindow';
		parent: #pharoSystem;
		description: 'OSWindow subsystem';
		with: [  
			(aBuilder pickOne: #driverClass)
				label: 'Driver to use';
				description: 'Select the driver to use for OSWindow. 
WARNING: Changing the driver will change the world rendering itself. 
You will need to restart the image to make this changes take effect.';
				target: self;
				domainValues: (self allSubclasses select: [ :each | each isSuitable ]) ]! !

!OSWindowDriver class methodsFor: 'settings' stamp: ''!
driverClass: aClass

	self driverClass = aClass ifTrue: [ ^ self ].
	
	DriverClass := aClass.
	Current := nil.
	self inform: 'You need to restart your image for this changes to take effect.'! !

!OSWindowDropEvent commentStamp: ''!
I am delivered when user drop something into the window (of course, if there's a drag and drop support by underlaying platform).!
!OSWindowDropEvent methodsFor: 'accessing' stamp: ''!
timestamp: anObject
	timestamp := anObject! !

!OSWindowDropEvent methodsFor: 'accessing' stamp: ''!
filePath
	^ filePath! !

!OSWindowDropEvent methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll: ' filePath: ''';
		nextPutAll: filePath;
		nextPut: $'! !

!OSWindowDropEvent methodsFor: 'accessing' stamp: ''!
timestamp
	^ timestamp! !

!OSWindowDropEvent methodsFor: 'accessing' stamp: ''!
filePath: anObject
	filePath := anObject! !

!OSWindowDropEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowDropEvent: self! !

!OSWindowEvent commentStamp: ''!
i am the root of various window events hierarchy!
!OSWindowEventGestureVisitor commentStamp: ''!
I am a abstract visitor for handling events.. 
serving just to cover the complete gesture protocol.!
!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchActionPointerDownEvent: anEvent
	"This event is only send when using the gesture detector"! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersSwipeMoveEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersScrollBeginEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersScrollMoveEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersSwipeAbortEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting' stamp: ''!
visitTouchOneFingerHoldEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersSwipeEndEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersPinchBeginEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersPinchMoveEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersScrollEndEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersSwipeBeginEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting' stamp: ''!
visitTouchOneFingerDoubleTapEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchActionPointerMoveEvent: anEvent
	"This event is only send when using the gesture detector"! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchActionPointerUpEvent: anEvent
	"This event is only send when using the gesture detector"! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersRotationBeginEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersPinchEndEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersRotationEndEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersScrollBeginEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersScrollEndEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting' stamp: ''!
handleGestureEvent: anEvent
	self handleEvent: anEvent.! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersRotationMoveEvent: anEvent! !

!OSWindowEventGestureVisitor methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersScrollMoveEvent: anEvent! !

!OSWindowEventVisitor commentStamp: ''!
i am a abstract visitor for handling events.. 
serving just to cover complete protocol, which user(s) will need to implement in order to act as an OSWindow event handler.!
!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitJoyDeviceRemovedEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitMouseButtonReleaseEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowMouseLeaveEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowShownEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowCloseEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowFrameEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitJoyDeviceAddedEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitKeyUpEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowResolutionChangeEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitMouseButtonPressEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowDropEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitJoyAxisEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowResizeEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowMinimizedEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowFocusOutEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowMouseEnterEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowMoveEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitJoyButtonUpEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitTouchPointerDownEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitTouchPointerMoveEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowHiddenEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitTouchPointerUpEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitJoyButtonDownEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitTextInputEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitUnknownEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowMaximizedEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'events' stamp: ''!
handleEvent: anEvent
	anEvent accept: self.
	
	"By default we perform the event default action after visiting the event. Other event handlers may decide to never perform this default action, or defer it into a separate Pharo process (to avoid race conditions) by overriding this method."
	anEvent performDefaultAction! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitJoyDeviceRemappedEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowExposeEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitKeyDownEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitMouseWheelEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitWindowFocusInEvent: anEvent! !

!OSWindowEventVisitor methodsFor: 'visiting' stamp: ''!
visitMouseMoveEvent: anEvent! !

!OSWindowExposeEvent commentStamp: ''!
I am delivered when part (or whole) window are exposed on the desktop and needs refreshing.!
!OSWindowExposeEvent methodsFor: 'default actions' stamp: ''!
defaultAction
	window isValid ifTrue: [ window renderer ifNotNil: [ window renderer exposed: timestamp ] ]! !

!OSWindowExposeEvent methodsFor: 'accessing' stamp: ''!
timestamp: anObject
	timestamp := anObject! !

!OSWindowExposeEvent methodsFor: 'accessing' stamp: ''!
timestamp
	^ timestamp! !

!OSWindowExposeEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowExposeEvent: self! !

!OSWindowFocusInEvent commentStamp: ''!
I am delivered when window obtains a user input focus.!
!OSWindowFocusInEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowFocusInEvent: self! !

!OSWindowFocusOutEvent commentStamp: ''!
I am delivered when window loses the user input focus.!
!OSWindowFocusOutEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowFocusOutEvent: self! !

!OSWindowFormRenderer commentStamp: ''!
I provide a way of delivering form's bits to window's contents.
To obtain my instance, first one create a valid OSWindow and then use #newFormRenderer: .

Then you can render on form, and form's contents will serve as medium which will be displayed inside a window.!
!OSWindowFormRenderer methodsFor: 'size' stamp: ''!
newExtent: newExtent
	form setExtent: newExtent depth: form depth! !

!OSWindowFormRenderer methodsFor: 'accessing' stamp: ''!
drawDuring: aBlock

	aBlock value: self getCanvas! !

!OSWindowFormRenderer methodsFor: 'morphic integration' stamp: ''!
deferUpdatesWhile: aBlock

	aBlock value! !

!OSWindowFormRenderer methodsFor: 'morphic integration' stamp: ''!
updateAreas: allDamage immediate: forceToScreen
	"Force all the damage rects to the screen."
	allDamage do: [ :r| self updateRectangle: r ].! !

!OSWindowFormRenderer methodsFor: 'accessing' stamp: ''!
form
	
	^ form! !

!OSWindowFormRenderer methodsFor: 'accessing' stamp: ''!
form: anObject
	
	form := anObject! !

!OSWindowFormRenderer methodsFor: 'accessing' stamp: ''!
getCanvas
	^ form getCanvas! !

!OSWindowFormRenderer methodsFor: 'accessing' stamp: ''!
pixelExtent
	^ form ifNotNil: [ form extent ] ifNil: [ 1@1 ]! !

!OSWindowFrameEvent commentStamp: ''!
Some strange event nobody knows what it does.??!
!OSWindowFrameEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowFrameEvent: self! !

!OSWindowGLAttributes commentStamp: ''!
I holding a set of OpenGL attributes, used to initialize an opengl rendering context for a window.!
!OSWindowGLAttributes methodsFor: 'profile selection' stamp: ''!
setCoreProfile
	self profileType: #core! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
swapControl
	
	^ swapControl! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
doubleBuffer: anObject
	
	doubleBuffer := anObject! !

!OSWindowGLAttributes methodsFor: 'profile selection' stamp: ''!
hasCompatibilityProfile
	^ self profileType = #compatibility! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
greenSize: anObject
	
	greenSize := anObject! !

!OSWindowGLAttributes methodsFor: 'profile selection' stamp: ''!
setForOpenGLES30
	self
		setESProfile;
		majorVersion: 3;
		minorVersion: 0! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
stencilSize
	^ stencilSize! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
majorVersion: anObject
	majorVersion := anObject! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
greenSize
	
	^ greenSize! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
depthSize: anObject
	
	depthSize := anObject! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
alphaSize: anObject
	
	alphaSize := anObject! !

!OSWindowGLAttributes methodsFor: 'profile selection' stamp: ''!
setForOpenGLES20
	self
		setESProfile;
		majorVersion: 2;
		minorVersion: 0! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
srgbFramebuffer
	^ srgbFramebuffer! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
stencilSize: aStencilSize
	stencilSize := aStencilSize! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
redSize: anObject
	
	redSize := anObject! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
swapControl: anObject
	
	swapControl := anObject! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
alphaSize
	
	^ alphaSize! !

!OSWindowGLAttributes methodsFor: 'initialization' stamp: ''!
initialize
	redSize := DefaultRedSize.
	greenSize := DefaultGreenSize.
	blueSize := DefaultBlueSize.
	alphaSize := DefaultAlphaSize.
	depthSize := DefaultDepthSize.
	stencilSize := DefaultStencilSize.
	doubleBuffer := DefaultDoubleBuffer.
	swapControl := DefaultSwapControl.
	minorVersion := DefaultMinorVersion.
	majorVersion := DefaultMajorVersion.
	profileType := DefaultProfileType.
	srgbFramebuffer := DefaultSRGBFramebuffer.! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
majorVersion
	^ majorVersion! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
blueSize: anObject
	
	blueSize := anObject! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
doubleBuffer
	
	^ doubleBuffer! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
profileType: anObject
	profileType := anObject! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
srgbFramebuffer: anObject
	srgbFramebuffer := anObject! !

!OSWindowGLAttributes methodsFor: 'profile selection' stamp: ''!
setCompatibilityProfile
	self profileType: #compatibility! !

!OSWindowGLAttributes methodsFor: 'profile selection' stamp: ''!
hasCoreProfile
	^ self profileType = #core! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
blueSize
	
	^ blueSize! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
minorVersion: anObject
	minorVersion := anObject! !

!OSWindowGLAttributes methodsFor: 'profile selection' stamp: ''!
setESProfile
	self profileType: #es! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
depthSize
	
	^ depthSize! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
redSize
	
	^ redSize! !

!OSWindowGLAttributes methodsFor: 'profile selection' stamp: ''!
hasESProfile
	^ self profileType = #es! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
minorVersion
	^ minorVersion! !

!OSWindowGLAttributes methodsFor: 'accessing' stamp: ''!
profileType
	^ profileType! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultDoubleBuffer
	^ DefaultDoubleBuffer! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultGreenSize
	^ DefaultGreenSize! !

!OSWindowGLAttributes class methodsFor: 'class initialization' stamp: ''!
initialize
	DefaultRedSize := 5.
	DefaultGreenSize := 5.
	DefaultBlueSize := 5.
	DefaultAlphaSize := 5.
	DefaultDepthSize := 16.
	DefaultDoubleBuffer := 1.
	DefaultStencilSize := 0.
	DefaultSwapControl := 0.
	DefaultMajorVersion := nil.
	DefaultMinorVersion := nil.
	DefaultProfileType := nil.
	DefaultSRGBFramebuffer := false.! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultMinorVersion
	^ DefaultMinorVersion! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultAlphaSize
	^ DefaultAlphaSize! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultDepthSize
	^ DefaultDepthSize! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultSRGBFramebuffer
	^ DefaultSRGBFramebuffer! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultSwapControl
	^ DefaultSwapControl! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultMajorVersion
	^ DefaultMajorVersion! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultRedSize
	^ DefaultRedSize! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultStencilSize
	^ DefaultStencilSize! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultProfileType
	^ DefaultProfileType! !

!OSWindowGLAttributes class methodsFor: 'defaults' stamp: ''!
defaultBlueSize
	^ DefaultBlueSize! !

!OSWindowGLRenderer commentStamp: ''!
i am abstract OpenGL renderer facade. !
!OSWindowGLRenderer methodsFor: 'context activation' stamp: ''!
asCurrentDo: aBlock ifFailure: aFailureBlock
	^ self withWindow: backendWindow do: aBlock ifFailure: aFailureBlock! !

!OSWindowGLRenderer methodsFor: 'misc' stamp: ''!
getProcAddress: procName
	"Gets an OpenGL procedure address."
	self subclassResponsibility! !

!OSWindowGLRenderer methodsFor: 'misc' stamp: ''!
swapBuffers: aWindow
	self subclassResponsibility! !

!OSWindowGLRenderer methodsFor: 'misc' stamp: ''!
makeCurrent
	^ self makeCurrent: backendWindow! !

!OSWindowGLRenderer methodsFor: 'misc' stamp: ''!
makeCurrent: aWindow
	self subclassResponsibility! !

!OSWindowGLRenderer methodsFor: 'context activation' stamp: ''!
withWindow: aWindow do: aBlock
	^ self withWindow: aWindow do: aBlock ifFailure: []! !

!OSWindowGLRenderer methodsFor: 'misc' stamp: ''!
swapBuffers
	^ self swapBuffers: backendWindow! !

!OSWindowGLRenderer methodsFor: 'context activation' stamp: ''!
asCurrentDo: aBlock
	^ self asCurrentDo: aBlock ifFailure: [ ]! !

!OSWindowGLRenderer methodsFor: 'context activation' stamp: ''!
withWindow: aWindow do: aBlock ifFailure: aFailureBlock
	| oldContext oldWindow |
	OSWindowRenderThread uniqueInstance critical: [ 
		oldContext := CurrentContext.
		oldWindow := CurrentWindow.
		[ 
			(self makeCurrent: aWindow) ifTrue: [
				CurrentContext := self.
				CurrentWindow := aWindow.
				aBlock value
			] ifFalse: [
				aFailureBlock value
			]
		] ensure: [
			(oldContext ~~ CurrentContext or: [ oldWindow ~~ CurrentWindow ]) ifTrue: [ 
				CurrentContext := oldContext.
				CurrentWindow := oldWindow.
				CurrentContext ifNotNil: [ CurrentContext makeCurrent: CurrentWindow ]
			]
		]
	]! !

!OSWindowGenericRenderer commentStamp: ''!
I am an abstract renderer that provides a generic API for native window rendering.!
!OSWindowGenericRenderer methodsFor: 'rendering' stamp: ''!
color: aColor
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'blending mode' stamp: ''!
useAdditiveColorBlending
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'blending mode' stamp: ''!
useSubpixelFontFirstPassBlending
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'rendering' stamp: ''!
present
	"This should present the content of an internal draw buffer"
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'blending mode' stamp: ''!
useSubpixelFontSecondPassBlending
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'resources' stamp: ''!
createRenderTargetTextureWithExtent: anExtent
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'rendering' stamp: ''!
drawTexture: texture rectangle: sourceRectangle in: destRectangle
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'rendering' stamp: ''!
fillRectangle: aRectangle
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'resources' stamp: ''!
getOrCreateStaticTextureFromForm: from
	"This gets or creates a cached static texture corresponding to a form. This is typically used for drawing GUI icons."
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'blending mode' stamp: ''!
useCompositeAlphaBlending
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'clipping' stamp: ''!
fullClippingBounds
	"This method should return a clipping rectangle that encompasses the full renderer output surface."
	^ 0@0 extent: self fullClippingExtent! !

!OSWindowGenericRenderer methodsFor: 'rendering' stamp: ''!
drawTexture: texture in: rectangle
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'rendering' stamp: ''!
drawLine: startPoint end: endPoint
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'clipping' stamp: ''!
clippingBounds: aRectangle
	"This methods sets a new clipping rectangle for the whole renderer output."
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangle: rectangle
	scene ifNotNil: [ scene renderRectangle: rectangle with: self ]! !

!OSWindowGenericRenderer methodsFor: 'resources' stamp: ''!
getOrCreateRenderTargetTextureFor: anObject withExtent: anExtent
	"This gets or creates a cached render target texture corresponding to an an abstract object used as a key."
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangles: aCollectionOfRectangles
	scene ifNotNil: [ scene renderRectangles: aCollectionOfRectangles with: self ]! !

!OSWindowGenericRenderer methodsFor: 'rendering' stamp: ''!
drawRectangle: aRectangle
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'accessing' stamp: ''!
scene
	^ scene! !

!OSWindowGenericRenderer methodsFor: 'resources' stamp: ''!
getRenderTargetTextureForObjectOrNil: anObject
	"This gets or creates a cached render target texture corresponding to an an abstract object used as a key."
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'accessing' stamp: ''!
scene: anObject
	scene := anObject! !

!OSWindowGenericRenderer methodsFor: 'rendering' stamp: ''!
withRenderTarget: aRenderTargetTexture do: aBlock
	"Activates a specific render target during the block."
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'resources' stamp: ''!
getOrCreateTextureFor: anObject withExtent: anExtent
	"This gets or creates a cached texture corresponding to an an abstract object used as a key."
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'updating screen' stamp: ''!
updateAll
	scene ifNotNil: [ scene renderAllWith: self ]! !

!OSWindowGenericRenderer methodsFor: 'rendering' stamp: ''!
clear
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'resources' stamp: ''!
getTextureForObjectOrNil: anObject
	"This gets or creates a cached render target texture corresponding to an an abstract object used as a key."
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'rendering' stamp: ''!
drawPoint: aPoint
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'blending mode' stamp: ''!
useModulatingColorBlending
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'blending mode' stamp: ''!
useNoBlending
	self subclassResponsibility! !

!OSWindowGenericRenderer methodsFor: 'testing' stamp: ''!
supportsRenderTargets
	"This method tells on whether the renderer support rendering into a texture or not."
	^ false! !

!OSWindowGenericRenderer methodsFor: 'clipping' stamp: ''!
fullClippingExtent
	"This method should return the extent associated to a clipping rectangle that encompasses the full renderer output surface."
	^ backendWindow extent! !

!OSWindowGenericRenderer methodsFor: 'blending mode' stamp: ''!
usePremultipliedCompositeAlphaBlending
	self subclassResponsibility! !

!OSWindowGenericRendererDrawingExample commentStamp: ''!
I am a basic example to show how we can draw something.

To launch the example:
self new open!
!OSWindowGenericRendererDrawingExample methodsFor: 'drawing' stamp: ''!
redraw
	| seconds x y|
	seconds := Time millisecondClockValue * 0.001.
	
	x := 320 + (150 * (0.3 * Float twoPi * seconds) cos).
	y := 240 + (150 * (0.3 * Float twoPi * seconds) sin).
	
	renderer
		color: (Color gray: (seconds sin) *0.5 + 0.5);
		clear;
		color: Color blue;
		drawRectangle: (x @ y extent: 20 @ 20)! !

!OSWindowGenericRendererExample commentStamp: ''!
Example showing how to use the joystick.!
!OSWindowGenericRendererExample methodsFor: 'accessing' stamp: ''!
enqueueRender
	OSWindowRenderThread enqueueOperation: [ 
		renderer ifNotNil: [ self redrawAndPresent ].
	]! !

!OSWindowGenericRendererExample methodsFor: 'factory' stamp: ''!
createEventHandler
	"You should override this method with your own event handler"
	^ OSWindowGenericRendererExampleEventHandler new 
		example: self! !

!OSWindowGenericRendererExample methodsFor: 'instance creation' stamp: ''!
open
	| attrs |
	attrs := OSWindowAttributes new.
	attrs
		extent: self defaultExtent;
		resizable: false;
		windowCentered: true.
		
	window := OSWindowAnimated createWithAttributes: attrs.
	
	renderer := window newGenericRenderer.
	self initializeWithRenderer.
	
	window eventHandler: (self createEventHandler).! !

!OSWindowGenericRendererExample methodsFor: 'instance creation' stamp: ''!
redraw
	^ self subclassResponsibility! !

!OSWindowGenericRendererExample methodsFor: 'instance creation' stamp: ''!
maxFPS
	^ 60! !

!OSWindowGenericRendererExample methodsFor: 'instance creation' stamp: ''!
present
	renderer present! !

!OSWindowGenericRendererExample methodsFor: 'initialize' stamp: ''!
initializeWithRenderer
		"Here we put all the things that needs the renderer to be initialized."! !

!OSWindowGenericRendererExample methodsFor: 'instance creation' stamp: ''!
defaultExtent
	^ 640@480! !

!OSWindowGenericRendererExample methodsFor: 'initialize' stamp: ''!
destroy
	"This function must be called when the window is closed"
	"drawingProcess terminate"! !

!OSWindowGenericRendererExample methodsFor: 'instance creation' stamp: ''!
redrawAndPresent
	self redraw.
	self present.! !

!OSWindowGenericRendererExampleEventHandler commentStamp: ''!
I am the event handler linked to the SDL2JoystickExample!
!OSWindowGenericRendererExampleEventHandler methodsFor: 'accessing' stamp: ''!
example
	<sampleInstance>
	^ example! !

!OSWindowGenericRendererExampleEventHandler methodsFor: 'accessing' stamp: ''!
example: anObject
	example := anObject! !

!OSWindowGenericRendererExampleEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowCloseEvent: anEvent
	example destroy! !

!OSWindowGenericRendererExampleEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowFrameEvent: anEvent
	example ifNotNil: [ example update: Time millisecondClockValue *0.001. ].
	example enqueueRender! !

!OSWindowGenericRendererExampleEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowExposeEvent: anEvent
	example enqueueRender.
	anEvent suppressDefaultAction.! !

!OSWindowGenericRendererScene commentStamp: ''!
I am an abstract interface for a scene that is drawn with a generic renderer. I provide methods that are called by the windowing system when immediate redrawing is required due to a window exposure state change.!
!OSWindowGenericRendererScene methodsFor: 'rendering' stamp: ''!
renderRectangle: rectangle with: aRenderer
	"This is the place where only a single rectangle of scene actually needs to be drawn. By default, redraw the whole scene."
	^ self renderAllWith: aRenderer! !

!OSWindowGenericRendererScene methodsFor: 'rendering' stamp: ''!
renderAllWith: renderer
	"This is the place where the whole scene must be redrawn with the renderer."! !

!OSWindowGenericRendererScene methodsFor: 'rendering' stamp: ''!
renderRectangles: aCollectionOfRectangles with: aRenderer
	"This is the place where a collection of rectangles in the scene actually needs to be drawn.
	By default, redraw the union of the rectangles."
	^ self renderRectangle: (Rectangle merging: aCollectionOfRectangles) with: aRenderer! !

!OSWindowGestureEventHandler commentStamp: ''!
I am the handler for the gestures.
As you can see instead of using #visitTouchPointerUpEvent: anEvent you have to use #visitTouchActionPointerUpEvent: anEvent!
!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchActionPointerDownEvent: anEvent
	touchExample beginMove: anEvent fingerId at: anEvent position! !

!OSWindowGestureEventHandler methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersSwipeMoveEvent: anEvent
	touchExample swipe: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersSwipeAbortEvent: anEvent
	touchExample abortedSwipe.! !

!OSWindowGestureEventHandler methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersSwipeEndEvent: anEvent
	touchExample endSwipe: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'visiting' stamp: ''!
visitTouchOneFingerHoldEvent: anEvent
	touchExample switchDiscoMode! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersPinchBeginEvent: anEvent
	touchExample beginPinch: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersPinchMoveEvent: anEvent
	touchExample pinch: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'visiting - three fingers gestures' stamp: ''!
visitTouchThreeFingersSwipeBeginEvent: anEvent
	touchExample beginSwipe: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowCloseEvent: anEvent
	touchExample destroy! !

!OSWindowGestureEventHandler methodsFor: 'visiting' stamp: ''!
visitTouchOneFingerDoubleTapEvent: anEvent
	touchExample changeColors! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchActionPointerMoveEvent: anEvent
	touchExample move: anEvent fingerId at: anEvent position.! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchActionPointerUpEvent: anEvent
	touchExample endMove: anEvent fingerId at: anEvent position.! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersRotationBeginEvent: anEvent
	touchExample beginRotation: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersPinchEndEvent: anEvent
	touchExample endPinch: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersRotationEndEvent: anEvent
	touchExample endRotation: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersScrollBeginEvent: anEvent
	touchExample beginScroll: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersScrollEndEvent: anEvent
	touchExample endScroll: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'api' stamp: ''!
touchExample: renderer
	touchExample := renderer! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersRotationMoveEvent: anEvent
	touchExample rotation: anEvent! !

!OSWindowGestureEventHandler methodsFor: 'visiting - two fingers gestures' stamp: ''!
visitTouchTwoFingersScrollMoveEvent: anEvent
	touchExample scroll: anEvent! !

!OSWindowGestureHandler commentStamp: ''!
I am a handler who can manage gestures and provide them informations on past and current touch events!
!OSWindowGestureHandler methodsFor: 'handling fingers' stamp: ''!
trackFinger: anEvent
	| newFingerTracker |
	"Creating a new finger tracker"
	newFingerTracker := OSTouchFingerTracker for: anEvent.
	
	"Registering it in the right places"
	fingers at: anEvent fingerId put: newFingerTracker.
	(devicesFingers at: anEvent deviceId ifAbsentPut: [ OrderedCollection new ]) add: newFingerTracker.
	
	^ newFingerTracker! !

!OSWindowGestureHandler methodsFor: 'visiting' stamp: ''!
visitTouchPointerDownEvent: anEvent
	self trackFinger: anEvent.
	
	"Updating informations"
	fingerCount := fingerCount + 1 .
	lastUpdateTimestamp := anEvent timestamp.
	
	self updateGesturesActiveFingers.
	
	self sendEventToGestures: anEvent.
	
	self visitTouchActionPointerDownEvent: anEvent! !

!OSWindowGestureHandler methodsFor: 'handling fingers' stamp: ''!
untrackFinger: anEvent
	| removedTracker |
	fingerCount := fingerCount - 1.
	removedTracker := fingers removeKey: anEvent fingerId ifAbsent: [ ^ self ].
	(devicesFingers at: anEvent deviceId) remove: removedTracker.! !

!OSWindowGestureHandler methodsFor: 'accessing' stamp: ''!
lastUpdateTimestamp
	^ lastUpdateTimestamp! !

!OSWindowGestureHandler methodsFor: 'initialization' stamp: ''!
initialize
	registeredGestures := OrderedCollection new.
	devicesFingers := Dictionary new.
	fingers := Dictionary new.
	fingerCount := 0.! !

!OSWindowGestureHandler methodsFor: 'detector registering' stamp: ''!
registerGesture: aGesture
	registeredGestures add: aGesture.
	aGesture eventHandler: self! !

!OSWindowGestureHandler methodsFor: 'visiting' stamp: ''!
visitTouchPointerMoveEvent: anEvent
	| fingerTracker |
	fingerTracker := fingers at: anEvent fingerId ifAbsent: [ self trackFinger: anEvent].

	fingerTracker updateWithEvent: anEvent.
	lastUpdateTimestamp := anEvent timestamp.
	
	self sendEventToGestures: anEvent.

	self visitTouchActionPointerMoveEvent: anEvent! !

!OSWindowGestureHandler methodsFor: 'visiting' stamp: ''!
visitTouchPointerUpEvent: anEvent
	self untrackFinger: anEvent.
	lastUpdateTimestamp := anEvent timestamp.
	self updateGesturesActiveFingers.
	self sendEventToGestures: anEvent.
	self visitTouchActionPointerUpEvent: anEvent! !

!OSWindowGestureHandler methodsFor: 'accessing' stamp: ''!
fingers
	^ fingers! !

!OSWindowGestureHandler methodsFor: 'accessing' stamp: ''!
fingerCount
	^ fingerCount! !

!OSWindowGestureHandler methodsFor: 'accessing' stamp: ''!
fingersFromDevice: id
	^ devicesFingers at: id ifAbsent: [ ^ fingers values ]! !

!OSWindowGestureHandler methodsFor: 'events' stamp: ''!
sendEventToGestures: anEvent
	registeredGestures
		do: [ :gesture | gesture handleEvent: anEvent ]! !

!OSWindowGestureHandler methodsFor: 'accessing' stamp: ''!
lastUpdateTimestamp: anObject 
	lastUpdateTimestamp := anObject! !

!OSWindowGestureHandler methodsFor: 'accessing' stamp: ''!
fingerCount: anObject
	fingerCount := anObject! !

!OSWindowGestureHandler methodsFor: 'events' stamp: ''!
handleGestureEvent: anEvent
	self handleEvent: anEvent.
	
	"Notifying gestures"
	self sendEventToGestures: anEvent! !

!OSWindowGestureHandler methodsFor: 'detector registering' stamp: ''!
unregisterGesture: anOSTouchGesture
	registeredGestures remove: anOSTouchGesture! !

!OSWindowGestureHandler methodsFor: 'handling fingers' stamp: ''!
updateGesturesActiveFingers
	registeredGestures do: [ :gesture | gesture activeFingers: (self fingersFromDevice: gesture deviceId) ]! !

!OSWindowHandle commentStamp: ''!
OSWindowHandle was deprecated in Pharo 9 in favor of OSBackendWindow.
Replace your usages.

For more information, please check the comment in OSBackendWindow.!
!OSWindowHandle class methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!OSWindowHiddenEvent commentStamp: ''!
I am delivered when a window is hidden.!
!OSWindowHiddenEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowHiddenEvent: self! !

!OSWindowJoystickExample commentStamp: ''!
I am a basic example to show how we can draw something and use the joystick.

To launch the example:
self new open!
!OSWindowJoystickExample methodsFor: 'game controls' stamp: ''!
shoot
	| position velocity |
	position := characterPosition.
	velocity := 400 @ characterVelocity y.
	bullets add: { position . velocity }! !

!OSWindowJoystickExample methodsFor: 'accessing' stamp: ''!
characterPosition
	^ characterPosition! !

!OSWindowJoystickExample methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	bullets := OrderedCollection new.
	self reset.! !

!OSWindowJoystickExample methodsFor: 'factory' stamp: ''!
createEventHandler
	^ OSWindowJoystickExampleEventHandler new 
		example: self! !

!OSWindowJoystickExample methodsFor: 'drawing' stamp: ''!
redraw
	self simulate.
	renderer
		color: Color black;
		clear.
		
	self
		drawCharacter;
		drawBullets! !

!OSWindowJoystickExample methodsFor: 'drawing' stamp: ''!
drawBullets
	renderer
		color: (Color r: (currentTime * 2.0) cos * 0.4 + 0.6 g: (currentTime * 3.0) sin * 0.4 + 0.6 b: 0.0).
	bullets do: [ :bullet |
		renderer fillRectangle: (bullet first extent: 10@10)
	]! !

!OSWindowJoystickExample methodsFor: 'simulation' stamp: ''!
simulate
	| deltaTime |
	lastSimulationTime ifNil: [ lastSimulationTime := Time millisecondClockValue * 0.001].
	currentTime := Time millisecondClockValue * 0.001.
	deltaTime := currentTime - lastSimulationTime.
	lastSimulationTime := currentTime.
	
	self
		simulateCharacter: deltaTime;
		simulateBullets: deltaTime.! !

!OSWindowJoystickExample methodsFor: 'simulation' stamp: ''!
simulateCharacter: deltaTime
	characterPosition := characterPosition + (characterVelocity * deltaTime).! !

!OSWindowJoystickExample methodsFor: 'accessing' stamp: ''!
characterVelocity
	^ characterVelocity! !

!OSWindowJoystickExample methodsFor: 'accessing' stamp: ''!
characterPosition: anObject
	characterPosition := anObject! !

!OSWindowJoystickExample methodsFor: 'drawing' stamp: ''!
drawCharacter
	renderer
		color: (Color r: 0.0 g: (currentTime*2.0) cos * 0.3 + 0.5 b: 1.0);
		fillRectangle: (characterPosition extent: 20@40)! !

!OSWindowJoystickExample methodsFor: 'accessing' stamp: ''!
characterVelocity: anObject
	characterVelocity := anObject! !

!OSWindowJoystickExample methodsFor: 'initialization' stamp: ''!
reset
	characterPosition := 320@240.
	characterVelocity := 0@0.
	bullets removeAll.! !

!OSWindowJoystickExample methodsFor: 'simulation' stamp: ''!
simulateBullets: delta
	| position velocity |
	
	bullets do: [ :bullet |
		position := bullet first.
		velocity	:= bullet second.
		position := position + (velocity * delta).
		bullet at: 1 put: position.
	].! !

!OSWindowJoystickExampleEventHandler commentStamp: ''!
I am the event handler linked to OSWindowJoystickExample.!
!OSWindowJoystickExampleEventHandler methodsFor: 'visiting' stamp: ''!
visitJoyButtonUpEvent: buttonUpEvent
	buttonUpEvent isPreferredEvent ifFalse: [ ^ self ].
	"TODO: Handle button up event."! !

!OSWindowJoystickExampleEventHandler methodsFor: 'visiting' stamp: ''!
visitJoyButtonDownEvent: buttonEvent
	buttonEvent isPreferredEvent ifFalse: [ ^ self ].
	
	buttonEvent isButtonX ifTrue: [ 
		example shoot.
	].

	buttonEvent isButtonStart ifTrue: [ 
		example reset.
	].! !

!OSWindowJoystickExampleEventHandler methodsFor: 'accessing' stamp: ''!
axisDeadZoneThreshold
	^ self class axisDeadZoneThreshold! !

!OSWindowJoystickExampleEventHandler methodsFor: 'visiting' stamp: ''!
visitJoyAxisEvent: axisEvent
	| axisValue velocity |
	axisEvent isPreferredEvent ifFalse: [ ^ self ].
	
	axisValue := self normalizeAxisValue: axisEvent value.
	velocity := example characterVelocity.
	axisEvent isLeftX ifTrue: [ 
		velocity := (axisValue * 300) @ velocity y
	].

	axisEvent isLeftY ifTrue: [ 
		"Left Y"
		velocity := velocity x @ (axisValue * 300)

	].

	example characterVelocity: velocity! !

!OSWindowJoystickExampleEventHandler methodsFor: 'settings' stamp: ''!
axisMaxValue
	^ self class axisMaxValue! !

!OSWindowJoystickExampleEventHandler methodsFor: 'visiting' stamp: ''!
normalizeAxisValue: value
	| result deadZone |
	result := value asFloat / self axisMaxValue.
	deadZone := self axisDeadZoneThreshold.
	(result between: deadZone negated and: deadZone) ifTrue: [ 
		result := 0.0
	] ifFalse: [
		result < 0 ifTrue: [ 
			result := result + deadZone.
		] ifFalse: [ 
			result := result - deadZone.
		].
		result := result / (1.0 - deadZone).
	].

	^ result min: 1.0 max: -1.0! !

!OSWindowJoystickExampleEventHandler class methodsFor: 'settings' stamp: ''!
axisDeadZoneThreshold
	^ 0.20! !

!OSWindowJoystickExampleEventHandler class methodsFor: 'settings' stamp: ''!
axisMaxValue
	^ 32767! !

!OSWindowMaximizedEvent commentStamp: ''!
I am delivered when the window got maximized.!
!OSWindowMaximizedEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowMaximizedEvent: self! !

!OSWindowMinimizedEvent commentStamp: ''!
I am delivered when the window got minimized.!
!OSWindowMinimizedEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowMinimizedEvent: self! !

!OSWindowMorphicEventHandler commentStamp: ''!
I can be used to convert OSWindow-level events to Morphic events.

So, that installing my instance as event handler for specific window would allow running Morphic World in it.

Later, the Morphic can be integrated with OSWindow API to avoid unnecessary conversion and thus eliminating the need in having this class.!
!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitMouseButtonReleaseEvent: anEvent
	anEvent isWheel ifTrue: [ ^ nil ].

	^ MouseButtonEvent new
		setType: #mouseUp
		position: (self convertPosition: anEvent position)
		which: (self convertButtonFromEvent: anEvent)
		buttons: (self convertModifiers: anEvent modifiers)
		hand: self activeHand
		stamp: Time millisecondClockValue! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitTextInputEvent: anEvent
	| keyEvent char mods |
	anEvent text ifNil: [ ^ nil ].
	char := anEvent text first.
	char ifNil: [ ^ nil ].
	mods := anEvent modifiers.
	"If a modifier key is pressed the keystroke event is handled by #visitMouseDownEvent:"
	(mods alt or: [ mods ctrl or: [ mods cmd ] ])
		ifTrue: [ ^ nil ].
		
	keyEvent := KeyboardEvent new
		setType: #keystroke
		buttons: (self convertModifiers: anEvent modifiers)
		position: (self convertPosition: anEvent position)
		keyValue: char charCode
		charCode: char charCode
		hand: self activeHand
		stamp: Time millisecondClockValue.
	
	^ keyEvent! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitUnknownEvent: anEvent
	self
		traceCr: ('Unknown event: <1s>' expandMacrosWith: anEvent data printString)! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowCloseEvent: anEvent
	anEvent suppressDefaultAction.
	
	morphicWorld worldState worldRenderer handleOSWindowCloseEvent: anEvent! !

!OSWindowMorphicEventHandler methodsFor: 'accessing' stamp: ''!
morphicWorld
	^ morphicWorld! !

!OSWindowMorphicEventHandler methodsFor: 'events' stamp: ''!
handleEvent: anEvent
	
	"convert the event to morphic one, and dispatch it whatever..."
	| morphicEvent |
	
	morphicEvent := anEvent accept: self.
	morphicEvent isMorphicEvent ifFalse: [ ^ self ].
		
	self dispatchMorphicEvent: morphicEvent! !

!OSWindowMorphicEventHandler methodsFor: 'converting' stamp: ''!
convertModifiers: modifiers
	| buttons |
	buttons := 0.
	
	"Alt/Option key"
	modifiers alt ifTrue: [
		"On windows and unix, treat alt key as command key"
		buttons := Smalltalk os isWin32 | Smalltalk os isUnix
			ifTrue: [ buttons | 2r01000000 ]
			ifFalse: [ buttons | 2r00100000 ]
	]. 
	
	modifiers ctrl ifTrue: [ buttons := buttons | 2r00010000 ]. "Control key"
	modifiers shift ifTrue: [ buttons := buttons | 8 ]. "Shift key"
	modifiers cmd ifTrue: [ buttons := buttons | 2r01000000 ]. "Cmd key"
	
	modifiers buttons button1 ifTrue:  [ buttons := buttons | MouseButtonEvent redButton ].
	modifiers buttons button2 ifTrue:  [ buttons := buttons | MouseButtonEvent blueButton ].
	modifiers buttons button3 ifTrue:  [ buttons := buttons | MouseButtonEvent yellowButton ].
	^ buttons! !

!OSWindowMorphicEventHandler methodsFor: 'private' stamp: ''!
activeHand
	^ self morphicWorld activeHand! !

!OSWindowMorphicEventHandler methodsFor: 'accessing' stamp: ''!
morphicWorld: aMorphicWorld
	morphicWorld := aMorphicWorld! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitKeyUpEvent: anEvent
	| keyEvent |
	keyEvent := KeyboardEvent new
		setType: #keyUp
		buttons: (self convertModifiers: anEvent modifiers)
		position: (self convertPosition: anEvent position)
		keyValue: (self mapSymbolToKeyValue: anEvent symbol)
		charCode: (self mapSymbolToKeyValue: anEvent symbol)
		hand: self activeHand
		stamp: Time millisecondClockValue.
	keyEvent
		scanCode: anEvent scanCode;
		key: (OSKeySymbols mapKeySymbolValueToKeyboardKey: anEvent symbol).
	^ keyEvent! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowResolutionChangeEvent: anEvent
	
	morphicWorld worldState updateToNewResolution: anEvent! !

!OSWindowMorphicEventHandler methodsFor: 'converting' stamp: ''!
convertPosition: aPosition
	morphicWorld ifNil: [ ^ aPosition ].
	^ morphicWorld worldState worldRenderer convertWindowMouseEventPosition: aPosition! !

!OSWindowMorphicEventHandler methodsFor: 'events' stamp: ''!
dispatchMorphicEvent: anEvent
	morphicWorld defer: [
		(morphicWorld activeHand isNotNil and: [ anEvent hand isNotNil ]) ifTrue: [
			morphicWorld activeHand handleEvent: anEvent
		]
	].! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitMouseButtonPressEvent: anEvent
	anEvent isWheel ifTrue: [ 
		^ MouseWheelEvent new 
			setType: #mouseWheel
			position: (self convertPosition: anEvent position)
			direction: anEvent wheelDirection
			buttons: (self convertModifiers: anEvent modifiers)
			hand: self activeHand
			stamp: Time millisecondClockValue ].
			
	^ MouseButtonEvent new
		setType: #mouseDown 
		position: (self convertPosition: anEvent position)
		which: (self convertButtonFromEvent: anEvent)
		buttons: (self convertModifiers: anEvent modifiers) | (self convertButtonFromEvent: anEvent)
		hand: self activeHand
		stamp: Time millisecondClockValue! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowDropEvent: anEvent

	| dropEvent |
	
	"The OSWindow drop events are generated one-per file (unlike the case the non-headless VM)"
	
	dropEvent := DropFilesEvent new 
				setPosition: self activeHand position
				contents: 1
				hand: self activeHand;
				fileNames: { anEvent filePath }. 
				
	^ dropEvent! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
mapSymbolToKeyValue: symbol
	^ SymbolCharacterMapping at: symbol ifAbsent: [
		 "Don't allow symbol values outside the unicode range"
		 symbol >= 16r400000 ifTrue: [ 0 ] ifFalse: [ symbol ] ]! !

!OSWindowMorphicEventHandler methodsFor: 'converting' stamp: ''!
convertButtonFromEvent: anEvent

	(self class simulateMiddleClick and: [anEvent button = 1 and: [ anEvent modifiers alt ]])
		ifTrue: [ ^ MouseButtonEvent blueButton ].

	anEvent button = 1 ifTrue: [ ^ MouseButtonEvent redButton ].
	anEvent button = 2 ifTrue: [ ^ MouseButtonEvent blueButton ].
	anEvent button = 3 ifTrue: [ ^ MouseButtonEvent yellowButton ].! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitKeyDownEvent: anEvent
	| keyEvent mods |

	mods := anEvent modifiers.
	keyEvent := KeyboardEvent new
		setType: #keyDown
		buttons: (self convertModifiers: mods)
		position: (self convertPosition: anEvent position)
		keyValue: (self mapSymbolToKeyValue: anEvent symbol)
		charCode: (self mapSymbolToKeyValue: anEvent symbol)
		hand: self activeHand
		stamp: Time millisecondClockValue.
	keyEvent
		scanCode: anEvent scanCode;
		key: (OSKeySymbols mapKeySymbolValueToKeyboardKey: anEvent symbol).
	self dispatchMorphicEvent: keyEvent! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitMouseWheelEvent: anEvent
	| vertical |
	vertical := anEvent scrollVertical.
	vertical = 0 ifTrue: [ ^ nil ].
	
	^ MouseWheelEvent new 
		setType: #mouseWheel
		position: (self convertPosition: anEvent position)
		direction: (vertical > 0 ifTrue: [Character arrowUp] ifFalse: [Character arrowDown])
		buttons: (self convertModifiers: anEvent modifiers)
		hand: self activeHand
		stamp: Time millisecondClockValue! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowResizeEvent: anEvent

	"window resized"
	morphicWorld worldState worldRenderer checkForNewScreenSize.! !

!OSWindowMorphicEventHandler methodsFor: 'visiting' stamp: ''!
visitMouseMoveEvent: anEvent
	| oldPos newPos |
	oldPos := morphicWorld activeHand ifNil: [ 0@0 ] ifNotNil: [:hand | hand position ].
	morphicWorld beCursorOwner.
	newPos := self convertPosition: anEvent position.
	^ MouseMoveEvent basicNew
		setType: #mouseMove 
		startPoint: oldPos
		endPoint: newPos 
		trail: { oldPos. newPos }
		buttons: (self convertModifiers: anEvent modifiers)
		hand: self activeHand
		stamp: Time millisecondClockValue! !

!OSWindowMorphicEventHandler class methodsFor: 'class initialization' stamp: ''!
initialize
	"
	self initialize
	"
	super initialize.
	SymbolCharacterMapping := Dictionary new.
	{
	 OSK_RETURN . Character cr.
	 OSK_BACKSPACE . Character backspace.
	 OSK_TAB . Character tab.
	 OSK_HOME . Character home.
	 OSK_LEFT . Character arrowLeft.
	 OSK_UP . Character arrowUp.
	 OSK_RIGHT . Character arrowRight.
	 OSK_DOWN . Character arrowDown.
	 OSK_END . Character end.
	 OSK_INSERT . Character insert.
	 OSK_PAGEUP . Character pageUp.
	 OSK_PAGEDOWN . Character pageDown.
	 OSK_DELETE. Character delete.
	
	 OSK_KP_0 . $0.
	 OSK_KP_1 . $1.
	 OSK_KP_2 . $2.
	 OSK_KP_3 . $3.
	 OSK_KP_4 . $4.
	 OSK_KP_5 . $5.
	 OSK_KP_6 . $6.
	 OSK_KP_7 . $7.
	 OSK_KP_8 . $8.
	 OSK_KP_9 . $9.
	 OSK_KP_DIVIDE . $/.
	 OSK_KP_MULTIPLY . $*.
	 OSK_KP_PLUS . $+.
	 OSK_KP_MINUS . $-.
	 OSK_KP_ENTER . Character cr.
	 OSK_KP_PERIOD . $..
	} pairsDo: [ :key :val | SymbolCharacterMapping at: key put: val charCode ]! !

!OSWindowMorphicEventHandler class methodsFor: 'instance creation' stamp: ''!
for: morphicWorld
	^ self new morphicWorld: morphicWorld; yourself! !

!OSWindowMorphicEventHandler class methodsFor: 'event testing' stamp: ''!
simulateMiddleClick 

	^ SimulateMiddleButton ifNil: [ SimulateMiddleButton := true ]! !

!OSWindowMorphicEventHandler class methodsFor: 'asserting' stamp: ''!
simulateMiddleClickSettingOn: aBuilder
	<systemsettings>
	
	(aBuilder setting: #simulateMiddleClick)
		target: self;
		default: true;
		parent: #morphic;
		label: 'Simulate Middle Mouse Button';
		description: 'Sets if we are simulating the middle button by doing Alt + Left button'! !

!OSWindowMorphicEventHandler class methodsFor: 'event testing' stamp: ''!
simulateMiddleClick: aValue

	SimulateMiddleButton := aValue! !

!OSWindowMouseEnterEvent commentStamp: ''!
I am delivered when mouse enters the area , covered by a window!
!OSWindowMouseEnterEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowMouseEnterEvent: self! !

!OSWindowMouseLeaveEvent commentStamp: ''!
I am delivered when mouse leaves the area , covered by a window!
!OSWindowMouseLeaveEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowMouseLeaveEvent: self! !

!OSWindowMoveEvent commentStamp: ''!
I am delivered when window moved by user or OS/window manager.!
!OSWindowMoveEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowMoveEvent: self! !

!OSWindowNullGenericRenderer commentStamp: ''!
I am an implementation of the generic API for native window rendering that does nothing.!
!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
color: aColor
	"Do nothing"! !

!OSWindowNullGenericRenderer methodsFor: 'blending mode' stamp: ''!
useAdditiveColorBlending! !

!OSWindowNullGenericRenderer methodsFor: 'blending mode' stamp: ''!
useSubpixelFontFirstPassBlending
	"Do nothing here"! !

!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
present
	"Do nothing"! !

!OSWindowNullGenericRenderer methodsFor: 'blending mode' stamp: ''!
useSubpixelFontSecondPassBlending
	"Do nothing here"! !

!OSWindowNullGenericRenderer methodsFor: 'resources' stamp: ''!
createRenderTargetTextureWithExtent: anExtent
	^ nil! !

!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
drawTexture: texture rectangle: sourceRectangle in: destRectangle! !

!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
fillRectangle: aRectangle
	"Do nothing"! !

!OSWindowNullGenericRenderer methodsFor: 'resources' stamp: ''!
getOrCreateStaticTextureFromForm: from
	^ nil! !

!OSWindowNullGenericRenderer methodsFor: 'blending mode' stamp: ''!
useCompositeAlphaBlending! !

!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
drawTexture: texture in: rectangle! !

!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
drawLine: startPoint end: endPoint
	"Do nothing"! !

!OSWindowNullGenericRenderer methodsFor: 'clipping' stamp: ''!
clippingBounds: aRectangle
	"Nothing required here"! !

!OSWindowNullGenericRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangle: rectangle
	"Do nothing"! !

!OSWindowNullGenericRenderer methodsFor: 'resources' stamp: ''!
getOrCreateRenderTargetTextureFor: anObject withExtent: anExtent
	^ nil! !

!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
drawString: aString from: firstIndex to: lastIndex in: bounds font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc kern: kern! !

!OSWindowNullGenericRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangles: aCollectionOfRectangles
	"Do nothing"! !

!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
drawRectangle: aRectangle
	"Do nothing"! !

!OSWindowNullGenericRenderer methodsFor: 'resources' stamp: ''!
getRenderTargetTextureForObjectOrNil: anObject
	^ nil! !

!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
withRenderTarget: aRenderTargetTexture do: aBlock
	^ aBlock value! !

!OSWindowNullGenericRenderer methodsFor: 'resources' stamp: ''!
getOrCreateTextureFor: anObject withExtent: anExtent
	^ nil! !

!OSWindowNullGenericRenderer methodsFor: 'updating screen' stamp: ''!
updateAll
	"Do nothing"! !

!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
clear
	"Do nothing"! !

!OSWindowNullGenericRenderer methodsFor: 'resources' stamp: ''!
getTextureForObjectOrNil: anObject
	^ nil! !

!OSWindowNullGenericRenderer methodsFor: 'blending mode' stamp: ''!
useNoBlending! !

!OSWindowNullGenericRenderer methodsFor: 'rendering' stamp: ''!
drawPoint: aPoint
	"Do nothing"! !

!OSWindowNullGenericRenderer methodsFor: 'blending mode' stamp: ''!
useModulatingColorBlending! !

!OSWindowNullGenericRenderer methodsFor: 'blending mode' stamp: ''!
usePremultipliedCompositeAlphaBlending! !

!OSWindowPlatformSpecificHandle commentStamp: ''!
I represent a collection of platform specific handles that can be passed to external graphics rendering APIs such as OpenGL, Vulkan, Direct 3D and Metal.

Instance Variables
	display:		The display handle.
	platform:		The a symbol with the name of the platform.
	surface:		The window drawing surface handle.
	window:		The window handle.
!
!OSWindowPlatformSpecificHandle methodsFor: 'accessing' stamp: ''!
platform: anObject
	platform := anObject! !

!OSWindowPlatformSpecificHandle methodsFor: 'accessing' stamp: ''!
window
	^ window! !

!OSWindowPlatformSpecificHandle methodsFor: 'accessing' stamp: ''!
display
	^ display! !

!OSWindowPlatformSpecificHandle methodsFor: 'accessing' stamp: ''!
surface
	^ surface! !

!OSWindowPlatformSpecificHandle methodsFor: 'accessing' stamp: ''!
display: anObject
	display := anObject! !

!OSWindowPlatformSpecificHandle methodsFor: 'accessing' stamp: ''!
platform
	^ platform! !

!OSWindowPlatformSpecificHandle methodsFor: 'accessing' stamp: ''!
surface: anObject
	surface := anObject! !

!OSWindowPlatformSpecificHandle methodsFor: 'accessing' stamp: ''!
window: anObject
	window := anObject! !

!OSWindowRenderThread commentStamp: ''!
I am a pharo process that performs all rendering calls. !
!OSWindowRenderThread methodsFor: 'render thread' stamp: ''!
enqueueOperation: operation blocking: blocking
	^ self enqueueOperation: operation blocking: blocking ifError: [ ]! !

!OSWindowRenderThread methodsFor: 'window animation' stamp: ''!
doAnimationFrameFor: window
	[
		(OSWindowFrameEvent for: window) deliver
	] on: Error do: [ :error |
		"It is critical, that the animation render thread keeps running despite errors."
		error freeze.
		[ error debug ] fork
	]! !

!OSWindowRenderThread methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self createRenderThread.
	RenderSession := Smalltalk session.! !

!OSWindowRenderThread methodsFor: 'initialization' stamp: ''!
isActiveThread
	^ Processor activeProcess == ActiveRenderThreadProcess! !

!OSWindowRenderThread methodsFor: 'window animation' stamp: ''!
performAnimationFrames
	| windows |
	
	" Copy the registered windows. "
	registeredWindowsMutex critical: [ 
		windows := registeredWindows copy.
	].

	" Try to animate them. "
	hasAnimatedWindowsInThisPeriod := false.
	windows do: [ :window |
		(window isValid) ifTrue: [ 
			hasAnimatedWindowsInThisPeriod := true.
			self doAnimationFrameFor: window.
		]
	].! !

!OSWindowRenderThread methodsFor: 'render thread' stamp: ''!
enqueueBlockingOperation: operation
	^ self enqueueOperation: operation blocking: true! !

!OSWindowRenderThread methodsFor: 'window animation' stamp: ''!
destroyedWindow: window
	registeredWindowsMutex critical:  [ 
		registeredWindows remove: window ifAbsent: [ nil ]
	]! !

!OSWindowRenderThread methodsFor: 'render thread' stamp: ''!
executeRenderOperations
	| operation  |
	[ operation := renderThreadQueue nextOrNil.
	  operation  ~~ nil ] whileTrue: [
		operation execute.
	].! !

!OSWindowRenderThread methodsFor: 'render thread' stamp: ''!
enqueueOperation: operation
	^ self enqueueOperation: operation blocking: false! !

!OSWindowRenderThread methodsFor: 'window animation' stamp: ''!
createdWindow: window
	registeredWindowsMutex critical: [
		registeredWindows add: window.
		operationAvailableSemaphore signal
	]! !

!OSWindowRenderThread methodsFor: 'window animation' stamp: ''!
waitMoreOperations
	"Wait for another operation event or a time out."
	hasAnimatedWindowsInThisPeriod ifTrue:  [
		"TODO: Compute a better time for the Delay. Thedelay is required to give time to threads with a lower priority."
		(Delay forMilliseconds: self animationStep) wait.
		operationAvailableSemaphore waitTimeoutMSecs: self animationStep.
	] ifFalse: [ 
		operationAvailableSemaphore wait.
	]! !

!OSWindowRenderThread methodsFor: 'initialization' stamp: ''!
isThisThread
	^ Processor activeProcess == RenderThreadProcess! !

!OSWindowRenderThread methodsFor: 'window animation' stamp: ''!
animationStep
	^ 10! !

!OSWindowRenderThread methodsFor: 'render thread' stamp: ''!
renderThreadProcess
	| session |
	session := Smalltalk session.
	
	[session == Smalltalk session] whileTrue: [
		"Execute the enqueued rendering operations"
		operationAvailableSemaphore consumeAllSignals.
		self critical: [
			self executeRenderOperations.
		
			"Animations must be refreshed periodically"
			self performAnimationFrames
		].
	
		self waitMoreOperations
	]! !

!OSWindowRenderThread methodsFor: 'window animation' stamp: ''!
createRenderThread
	RenderThreadProcess ifNotNil: [ RenderThreadProcess terminate ].
	ActiveRenderThreadProcess := nil.
	
	renderThreadQueue := AtomicSharedQueue new.
	operationAvailableSemaphore := Semaphore new.
	
	registeredWindows := WeakSet new.
	registeredWindowsMutex := Semaphore forMutualExclusion.
	
	activeRenderThreadProcessMutex := Mutex new.
	
	RenderThreadProcess := [ self renderThreadProcess ] forkAt: Processor userSchedulingPriority.
	RenderThreadProcess name:  'OS Window Renderer Loop'; resume.! !

!OSWindowRenderThread methodsFor: 'mutual exclusion' stamp: ''!
critical: aBlock
	| oldActiveRenderThreadProcess |
	activeRenderThreadProcessMutex critical: [
		oldActiveRenderThreadProcess := ActiveRenderThreadProcess.
		ActiveRenderThreadProcess := Processor activeProcess.
		[
			aBlock value
		] ensure: [ ActiveRenderThreadProcess := oldActiveRenderThreadProcess ]
	]! !

!OSWindowRenderThread methodsFor: 'render thread' stamp: ''!
enqueueOperation: operation blocking: blocking ifError: aBlock
	" If this is in the RenderThread, execute directly"
	| operationHandle |
	Processor activeProcess == RenderThreadProcess ifTrue: [ ^ operation value ].
	
	"Enqueue the operation"
	operationHandle := OSWindowRenderThreadOperation new: operation blocking: blocking.
	renderThreadQueue nextPut: operationHandle.
	operationAvailableSemaphore signal.

	"Wait for blocking operations."
	blocking ifTrue: [
		operationHandle wait.
		operationHandle failed ifTrue: aBlock
	].! !

!OSWindowRenderThread class methodsFor: 'render thread' stamp: ''!
enqueueOperation: operation blocking: blocking
	^ self uniqueInstance enqueueOperation: operation blocking: blocking! !

!OSWindowRenderThread class methodsFor: 'window animation' stamp: ''!
doAnimationFrameFor: window
	"TODO: Handle errors produced here"
	(OSWindowFrameEvent for: window) deliver! !

!OSWindowRenderThread class methodsFor: 'render thread' stamp: ''!
isActiveThread
	^ self uniqueInstance isActiveThread! !

!OSWindowRenderThread class methodsFor: 'render thread' stamp: ''!
enqueueBlockingOperation: operation
	^ self uniqueInstance enqueueBlockingOperation: operation! !

!OSWindowRenderThread class methodsFor: 'window animation' stamp: ''!
destroyedWindow: window
	^ self uniqueInstance destroyedWindow: window! !

!OSWindowRenderThread class methodsFor: 'render thread' stamp: ''!
enqueueOperation: operation
	^ self uniqueInstance enqueueOperation: operation blocking: false! !

!OSWindowRenderThread class methodsFor: 'window animation' stamp: ''!
createdWindow: window
	^ self uniqueInstance createdWindow: window! !

!OSWindowRenderThread class methodsFor: 'render thread' stamp: ''!
isThisThread
	^ self uniqueInstance isThisThread! !

!OSWindowRenderThread class methodsFor: 'window animation' stamp: ''!
animationStep
	^ 10! !

!OSWindowRenderThread class methodsFor: 'session management' stamp: ''!
uniqueInstance
	self checkSession.
	^ UniqueInstance! !

!OSWindowRenderThread class methodsFor: 'session management' stamp: ''!
checkSession
	RenderSession ~~ Smalltalk session ifTrue: [ 
		UniqueInstance := self new.
	]! !

!OSWindowRenderThread class methodsFor: 'render thread' stamp: ''!
enqueueOperation: operation blocking: blocking ifError: aBlock
	^ self uniqueInstance enqueueOperation: operation blocking: blocking ifError: aBlock! !

!OSWindowRenderThreadOperation commentStamp: ''!
I am a render operation, used to send commands (which can be asynchronous or synchronous) to the render thread. !
!OSWindowRenderThreadOperation methodsFor: 'waiting' stamp: ''!
blocking
	^ blocking! !

!OSWindowRenderThreadOperation methodsFor: 'initialize' stamp: ''!
initWithOperation: anOperation
	semaphore := Semaphore new.
	operation := anOperation.! !

!OSWindowRenderThreadOperation methodsFor: 'waiting' stamp: ''!
wait
	semaphore wait! !

!OSWindowRenderThreadOperation methodsFor: 'accessing' stamp: ''!
failed
	^ failed! !

!OSWindowRenderThreadOperation methodsFor: 'execute' stamp: ''!
execute
	[ 
		[
			failed := false.
			operation value
		] on: Exception do: [ :ex |
			failed := true.
			ex freeze.
			[ ex debug ] fork.
		]
	] ensure: [ semaphore signal ]! !

!OSWindowRenderThreadOperation methodsFor: 'initialize' stamp: ''!
initWithOperation: anOperation blocking: isBlocking
	semaphore := Semaphore new.
	operation := anOperation.
	blocking := isBlocking! !

!OSWindowRenderThreadOperation class methodsFor: 'instance creation' stamp: ''!
new: anOperation
	^ self new: anOperation blocking: false! !

!OSWindowRenderThreadOperation class methodsFor: 'instance creation' stamp: ''!
new: anOperation blocking: isBlocking
	^ self basicNew initWithOperation: anOperation blocking: isBlocking; yourself! !

!OSWindowRenderer commentStamp: ''!
My instances are used for updating the OSWindow contents by rendering on it.
There is no way to obtain a valid instance of window renderer other than asking a valid instance of OSWindow for window renderer instance.
See newFormRenderer: / newOpenGLRenderer factory methods.!
!OSWindowRenderer methodsFor: 'accessing' stamp: ''!
backendWindow: anObject
	
	backendWindow := anObject! !

!OSWindowRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangle: rectangle
		"do something to update given portion of the window"
		
		self subclassResponsibility! !

!OSWindowRenderer methodsFor: 'operating' stamp: ''!
onRenderThreadBlocking: aBlock
	OSWindowRenderThread enqueueBlockingOperation: aBlock! !

!OSWindowRenderer methodsFor: 'updating screen' stamp: ''!
updateRectangles: aCollectionOfRectangles
	aCollectionOfRectangles do: [ :rectangle | self updateRectangle: rectangle ]! !

!OSWindowRenderer methodsFor: 'initialization' stamp: ''!
initialize
	lastExposeTime := 0! !

!OSWindowRenderer methodsFor: 'operating' stamp: ''!
onRenderThread: aBlock
	OSWindowRenderThread enqueueOperation: aBlock! !

!OSWindowRenderer methodsFor: 'updating screen' stamp: ''!
exposed
	self present! !

!OSWindowRenderer methodsFor: 'updating screen' stamp: ''!
present
	"This should present the changes to the next frame."
	self updateAll! !

!OSWindowRenderer methodsFor: 'updating screen' stamp: ''!
resized
	self updateAll! !

!OSWindowRenderer methodsFor: 'updating screen' stamp: ''!
updateAll
		"do something to update whole contents of the window"
		
		self subclassResponsibility! !

!OSWindowRenderer methodsFor: 'deleting' stamp: ''!
destroy
	"Called when the window associated with the renderer is destroyed"
	backendWindow := nil.! !

!OSWindowRenderer methodsFor: 'updating screen' stamp: ''!
exposed: exposeTime
	(lastExposeTime notNil and: [ exposeTime <= lastExposeTime]) ifTrue: [ ^ self ].
	lastExposeTime := exposeTime.
	self exposed! !

!OSWindowRenderer methodsFor: 'clipping' stamp: ''!
pixelExtent
	^ backendWindow extent! !

!OSWindowRendererTexture commentStamp: ''!
I am an abstract texture that is created by an OSWindowGenericRenderer.

The user data member is provided as a quick storage slot for storing additional metadata corresponding to this texture with a constant access guarantee. This slot is typically used for caching the rendering of a sub scene that is rendered through myself.!
!OSWindowRendererTexture methodsFor: 'texture manipulation' stamp: ''!
uploadForm: aForm! !

!OSWindowRendererTexture methodsFor: 'texture manipulation' stamp: ''!
uploadForm: aForm withModificationCount: newModificationCount
	(modificationCount isNil or: [ modificationCount < newModificationCount ]) ifTrue: [ 
		self uploadForm: aForm.
		modificationCount := newModificationCount
	]! !

!OSWindowRendererTexture methodsFor: 'accessing' stamp: ''!
modificationCount
	^ modificationCount! !

!OSWindowRendererTexture methodsFor: 'texture manipulation' stamp: ''!
uploadAthensSurface: athensSurface! !

!OSWindowRendererTexture methodsFor: 'accessing' stamp: ''!
userData
	^ userData! !

!OSWindowRendererTexture methodsFor: 'accessing' stamp: ''!
userData: anObject
	userData := anObject! !

!OSWindowRendererTexture methodsFor: 'accessing' stamp: ''!
extent
	self subclassResponsibility! !

!OSWindowRendererTexture methodsFor: 'texture manipulation' stamp: ''!
uploadAthensSurface: anAthensSurface withModificationCount: newModificationCount
	(modificationCount isNil or: [ modificationCount < newModificationCount ]) ifTrue: [ 
		self uploadAthensSurface: anAthensSurface.
		modificationCount := newModificationCount
	]! !

!OSWindowRendererTexture methodsFor: 'accessing' stamp: ''!
modificationCount: anObject
	modificationCount := anObject! !

!OSWindowResizeEvent commentStamp: ''!
I am delivered when window resized by user or OS/window manager.!
!OSWindowResizeEvent methodsFor: 'accessing' stamp: ''!
width: anInteger 
	width := anInteger.! !

!OSWindowResizeEvent methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!OSWindowResizeEvent methodsFor: 'visitor' stamp: ''!
defaultAction
	window renderer ifNotNil: [ :renderer | renderer resized ]! !

!OSWindowResizeEvent methodsFor: 'accessing' stamp: ''!
height
	^ height! !

!OSWindowResizeEvent methodsFor: 'accessing' stamp: ''!
height: anInteger 
	height := anInteger.! !

!OSWindowResizeEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowResizeEvent: self! !

!OSWindowResolutionChangeEvent commentStamp: ''!
I am delivered when the per-pixel resolution measured in DPI of a window is changed.!
!OSWindowResolutionChangeEvent methodsFor: 'accessing' stamp: ''!
horizontalDPI: anObject
	horizontalDPI := anObject! !

!OSWindowResolutionChangeEvent methodsFor: 'accessing' stamp: ''!
screenScaleFactor: anObject
	screenScaleFactor := anObject! !

!OSWindowResolutionChangeEvent methodsFor: 'accessing' stamp: ''!
horizontalDPI
	^ horizontalDPI! !

!OSWindowResolutionChangeEvent methodsFor: 'accessing' stamp: ''!
verticalDPI
	^ verticalDPI! !

!OSWindowResolutionChangeEvent methodsFor: 'accessing' stamp: ''!
diagonalDPI
	^ diagonalDPI! !

!OSWindowResolutionChangeEvent methodsFor: 'accessing' stamp: ''!
diagonalDPI: anObject
	diagonalDPI := anObject! !

!OSWindowResolutionChangeEvent methodsFor: 'accessing' stamp: ''!
screenScaleFactor
	^ screenScaleFactor! !

!OSWindowResolutionChangeEvent methodsFor: 'visitor' stamp: ''!
accept: visitor
	^ visitor visitWindowResolutionChangeEvent: self! !

!OSWindowResolutionChangeEvent methodsFor: 'accessing' stamp: ''!
verticalDPI: anObject
	verticalDPI := anObject! !

!OSWindowShownEvent commentStamp: ''!
I am delivered when a window is shown.!
!OSWindowShownEvent methodsFor: 'visitor' stamp: ''!
defaultAction
	window isValid ifTrue: [ window renderer ifNotNil: [ window renderer exposed: timestamp  ] ]! !

!OSWindowShownEvent methodsFor: 'accessing' stamp: ''!
timestamp: anObject
	timestamp := anObject! !

!OSWindowShownEvent methodsFor: 'accessing' stamp: ''!
timestamp
	^ timestamp! !

!OSWindowShownEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowShownEvent: self! !

!OSWindowTest commentStamp: ''!
An OSWindowTest is a test class for testing the behavior of OSWindow!
!OSWindowTest methodsFor: 'tests' stamp: ''!
testSettingUpWindow

	| window |
	
	window := OSWindow newWithNullDriver.
	
	[ window extent: 150@150.
		self assert: window extent equals: (150@150).
		self assert: (window isValid).
		self assert: (window isTextInputActive not)
	] ensure: [ window destroy ].

	self deny: window isValid! !

!OSWindowTest methodsFor: 'tests' stamp: ''!
testCreatingWindow

	| window attributes |
	attributes := OSWindowAttributes new.
	attributes preferableDriver: OSNullWindowDriver new.
	window := OSWindow createWithAttributes: attributes.

	self assert: (window isValid)! !

!OSWindowTest methodsFor: 'tests' stamp: ''!
testTraceEvents
	"We do not trace events by default"

	self deny: (OSWindow classVarNamed: #TraceEvents)! !

!OSWindowTest methodsFor: 'tests' stamp: ''!
testNewWindowDefaults
	| window |
	window := OSWindow newWithNullDriver.

	[ self assert: window isValid.
	self assert: window extent equals: OSWindowAttributes defaultExtent ]
		ensure: [ window destroy ]! !

!OSWindowTouchEventHandler commentStamp: ''!
I am the basic event handler for the example!
!OSWindowTouchEventHandler methodsFor: 'visiting' stamp: ''!
visitTouchPointerDownEvent: anEvent
	touchExample beginMove: anEvent fingerId at: anEvent position.! !

!OSWindowTouchEventHandler methodsFor: 'visiting' stamp: ''!
visitTouchPointerMoveEvent: anEvent
	touchExample move: anEvent fingerId at: anEvent position! !

!OSWindowTouchEventHandler methodsFor: 'visiting' stamp: ''!
visitTouchPointerUpEvent: anEvent
	touchExample endMove: anEvent fingerId at: anEvent position! !

!OSWindowTouchEventHandler methodsFor: 'visiting' stamp: ''!
visitWindowCloseEvent: anEvent
	touchExample destroy! !

!OSWindowTouchEventHandler methodsFor: 'api' stamp: ''!
touchExample:	renderer
		touchExample := renderer! !

!OSWindowWorldMorph commentStamp: ''!
I am a morphic world that uses OSWindow.

For opening a World in a external window, the following script can be used:

world := OSWindowWorldMorph new.
world open.
!
!OSWindowWorldMorph methodsFor: 'events' stamp: ''!
osWindowCloseButtonPressed
	self delete! !

!OSWindowWorldMorph methodsFor: 'submorphs - add/remove' stamp: ''!
delete
	closeCallback value.
	self class removeExtraWorld: self.
	worldState worldRenderer deactivate.
	super delete! !

!OSWindowWorldMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self color: Color veryLightGray.
	isResizeable := true.
	self extent: 640@480.
	self addHand: HandMorph new.! !

!OSWindowWorldMorph methodsFor: 'instance creation' stamp: ''!
open
	self worldState worldRenderer: ((OSWorldRenderer forWorld: self)
		windowCloseAction: [self osWindowCloseButtonPressed]).
	self changed.
	self class addExtraWorld: self.! !

!OSWindowWorldMorph methodsFor: 'accessing' stamp: ''!
title: aTitle
	"self flag: 'ToDo'"! !

!OSWindowWorldMorph methodsFor: 'accessing' stamp: ''!
isResizeable
	^ isResizeable! !

!OSWindowWorldMorph methodsFor: 'accessing' stamp: ''!
isResizeable: anObject
	isResizeable := anObject! !

!OSWindowWorldMorph methodsFor: 'display' stamp: ''!
openInWorld
	^ self open! !

!OSWindowWorldMorph methodsFor: 'adding' stamp: ''!
addMorph: aMorph frame: rectangle
	"For compatibility with SystemWindow."
	^ self addMorph: aMorph fullFrame: rectangle! !

!OSWindowWorldMorph methodsFor: 'accessing' stamp: ''!
closeCallback: anObject
	self flag: 'Do something better than just storing a closure.'.
	closeCallback := anObject! !

!OSWindowWorldMorph methodsFor: 'accessing' stamp: ''!
closeCallback
	^ closeCallback! !

!OSWindowWorldMorphWithModel commentStamp: ''!
I am an OSWindow world morph that includes a model, to be used with Spec and Glamour.!
!OSWindowWorldMorphWithModel methodsFor: 'accessing' stamp: ''!
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.! !

!OSWindowWorldMorphWithModel methodsFor: 'accessing' stamp: ''!
model 
    ^ model! !

!OSWorldRenderer commentStamp: ''!
I know how to render the world in an OSWindow!
!OSWorldRenderer methodsFor: 'operations' stamp: ''!
updateDamage: allDamage

	"quickly copy altered rects of canvas to Display:"
	self osWindowRenderer updateAreas: allDamage immediate: false.! !

!OSWorldRenderer methodsFor: 'private' stamp: ''!
pickMostSuitableWindowDriver

	driver := OSWindowDriver current.
	^ driver! !

!OSWorldRenderer methodsFor: 'events' stamp: ''!
checkForNewScreenSize

	(display isNil or: [ display extent = self actualScreenSize ]) 
		ifTrue: [ ^ self ].

	display := Form extent: self actualScreenSize depth: 32.
	self osWindowRenderer form: display.

	world worldState realWindowExtent: self actualScreenSize.

	world restoreMorphicDisplay! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
osWindowRenderer

	osWindow ifNil: [ ^ nil ].
	^ osWindow renderer ifNil: [ 
		  osWindow newFormRenderer: display.
		  osWindow renderer ]! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
screenScaleFactor

	^ world scaleFactor * self windowScaleFactor! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
icon: aForm 

	osWindow icon: aForm! !

!OSWorldRenderer methodsFor: 'activation' stamp: ''!
updateWindowTitle

	osWindow title: Smalltalk imageFile fullName.
	driver
		afterSetWindowTitle: Smalltalk imageFile fullName
		onWindow: osWindow! !

!OSWorldRenderer methodsFor: 'operations' stamp: ''!
deferUpdatesDuring: aBlock

	self osWindowRenderer ifNotNil: [:renderer | renderer deferUpdatesWhile: aBlock ]! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
windowCloseAction
	^ windowCloseAction! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
driver

	^ driver! !

!OSWorldRenderer methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	windowCloseAction := [ self currentWorld defer: [ WorldState quitSession ] ]! !

!OSWorldRenderer methodsFor: 'private' stamp: ''!
doActivate

	| attributes initialExtent |
	
	initialExtent := world worldState realWindowExtent ifNil: [976@665].

	attributes := OSWindowAttributes new.
	attributes
		extent: initialExtent;
		title: Smalltalk image imageFile fullName;
		windowCentered:true;
		icon: (self iconNamed: #pharoBig).

	display := Form extent: initialExtent depth: 32.
	world extent: initialExtent.

	driver := self pickMostSuitableWindowDriver.
	attributes preferableDriver: driver.
	osWindow := OSWindow createWithAttributes: attributes eventHandler: (OSWindowMorphicEventHandler for: world).
	
	driver afterMainPharoWindowCreated: osWindow.
	driver afterSetWindowTitle: Smalltalk image imageFile fullName onWindow: osWindow.
		
	osWindow focus. 
	
	world worldState doFullRepaint.
	world displayWorld.
	
	OSWindowClipboard new beDefault.! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
window
	
	^ osWindow! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
clipboardText: aString
	osWindow clipboardText: aString asString! !

!OSWorldRenderer methodsFor: 'operations' stamp: ''!
drawDuring: aBlock
	osWindow ifNil: [ ^ self ].
	self isProfilingRenderingTime ifTrue: [ ^ self drawWhileProfilingRenderingTimeDuring: aBlock ].
	self osWindowRenderer deferUpdatesWhile: [
		self osWindowRenderer drawDuring: aBlock
	].! !

!OSWorldRenderer methodsFor: 'profiling' stamp: ''!
drawWhileProfilingRenderingTimeDuring: aBlock
	| measurements |
	previousFrameRenderingTime := [
		self osWindowRenderer deferUpdatesWhile: [
			self osWindowRenderer drawDuring: [ :canvas |
				| frameCanvasRenderingTime displayRectangle |
				frameCanvasRenderingTime := [ aBlock value: canvas ] timeToRunWithoutGC.
					
				measurements := {
					'Content' -> frameCanvasRenderingTime
				}.
				previousFrameRenderingTime ifNotNil: [
					measurements := measurements , {
						'Previous frame' -> previousFrameRenderingTime.
					}
				].
				
				displayRectangle := (0@0 extent: 250@40).
				canvas
					fillRectangle: displayRectangle color: Color white.
				measurements doWithIndex: [ :each :index |
					| line |
					line := self formatRenderingTimeMeasurement: each.
					canvas drawString: line at: 10@(10*index) font: nil color: Color black.
				].
				
				self osWindowRenderer updateRectangle: displayRectangle.
			]
		]
	] timeToRunWithoutGC.
	
	self logRenderingTimeMeasurements: measurements! !

!OSWorldRenderer methodsFor: 'events' stamp: ''!
handleOSWindowCloseEvent: event
	windowCloseAction value! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
activateCursor: aCursor withMask: maskForm

	osWindow ifNotNil: [ 
		osWindow
			setMouseCursor: aCursor
			mask: maskForm
			andScale: world worldState worldRenderer screenScaleFactor ]! !

!OSWorldRenderer methodsFor: 'utilities' stamp: ''!
convertWindowMouseEventPosition: aPosition

	^ (aPosition / self screenScaleFactor) rounded! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
world: aWorld

	world := aWorld! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
actualScreenSize
	^ (self windowExtent / self screenScaleFactor) ceiling max: 1@1! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
windowCloseAction: anObject
	windowCloseAction := anObject! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
clipboardText
	^ osWindow clipboardText! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
windowExtent

	^ osWindow ifNil: [ 240@120 ] ifNotNil: [ osWindow extent ]! !

!OSWorldRenderer methodsFor: 'accessing' stamp: ''!
windowTitle: aString

	osWindow title: aString! !

!OSWorldRenderer methodsFor: 'operations' stamp: ''!
fullscreenMode: aValue

	osWindow fullscreen: aValue.
	self checkForNewScreenSize! !

!OSWorldRenderer methodsFor: 'scale factor' stamp: ''!
windowScaleFactor
	^ osWindow ifNil: [ 1 ] ifNotNil: [ osWindow screenScaleFactor max: 1 ]! !

!OSWorldRenderer methodsFor: 'events' stamp: ''!
updateToNewResolution

	self window updateToNewResolution! !

!OSWorldRenderer methodsFor: 'private' stamp: ''!
deactivate

	osWindow ifNotNil: [ osWindow destroy. osWindow := nil ].
	display := nil.! !

!OSWorldRenderer class methodsFor: 'accessing' stamp: ''!
isApplicableFor: aWorld

	^ Smalltalk isHeadless and: [ CommandLineArguments new hasOption: 'interactive' ]! !

!OSWorldRenderer class methodsFor: 'accessing' stamp: ''!
priority 

	^ 2! !

!Object commentStamp: ''!
`Object` is the root class for almost all of the other classes in the class hierarchy. The exceptions are ProtoObject (the superclass of Object) and its subclasses.

Class `Object` provides default behavior common to all normal objects, such as access, copying, comparison, error handling, message sending, and reflection. Also utility messages that all objects should respond to are defined here.

`Object` has no instance variables, nor should any be added. This is due to several classes of objects that inherit from Object that have special implementations (SmallInteger and UndefinedObject for example) or the VM knows about and depends on the structure and layout of certain standard classes.

Class Variables:
	DependentsFields		an IdentityDictionary
		Provides a virtual 'dependents' field so that any object may have one
		or more dependent views, synchronized by the changed:/update: protocol.
		Note that class Model has a real slot for its dependents, and overrides
		the associated protocol with more efficient implementations.

Because `Object` is the root of the inheritance tree, methods are often defined in Object to give all objects special behaviors needed by certain subsystems or applications, or to respond to certain general test messages such as isMorph.


###Miscellanous Discussions

About `at:` index accepting float and not only integers
 
This behavior is also free in the sense that the failure code is only invoked when the primitive fails and so adds nothing to the cost of successful accesses, which are the high dynamic frequency operation.  It will also show up under
profiling if one is concerned about efficiency, and so isn't a hidden cost.

It is also in keeping with Pharo'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: 'halting' stamp: ''!
halt: aString 
	<debuggerCompleteToSender>
	Halt now: aString! !

!Object methodsFor: 'introspection' stamp: ''!
instVarAt: index
	"Primitive. Answer a fixed variable in an object. The numbering of the variables
	 corresponds to the named instance variables, followed by the indexed instance
	 variables. Fail if the index is not an Integer or is not the index of a fixed 
	 variable or indexed variable. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 173 error: ec>
	self primitiveFailed! !

!Object methodsFor: '*System-Model' stamp: 'nil'!
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: '*Ring-Core' stamp: ''!
isRingResolved

	^ true! !

!Object methodsFor: '*Morphic-Core' stamp: ''!
complexContents

	^self! !

!Object methodsFor: '*Graphics-Canvas' stamp: ''!
printDirectlyToDisplay
	"For debugging: write the receiver's printString directly to the display at (0, 100); senders of this are detected by the check-for-slips mechanism."

	self asString displayAt: 0@100

"StringMorph someInstance printDirectlyToDisplay"! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
asDraggableMorph
	^ self asStringMorph! !

!Object methodsFor: 'error handling' stamp: ''!
shouldNotImplement
	"Announce that, although the receiver inherits this message, 
	it should not implement it."
	<debuggerCompleteToSender>
	ShouldNotImplement signalFor: thisContext sender selector! !

!Object methodsFor: 'printing' stamp: ''!
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: 'testing' stamp: ''!
isInterval

	^ false! !

!Object methodsFor: 'write barrier' stamp: ''!
beRecursivelyWritableObject
	^self recursivelySetIsReadOnlyObject: false! !

!Object methodsFor: '*Spec2-Core' stamp: ''!
isSpAnnouncingObject

	^ false! !

!Object methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
haltOnAccess: access to: anInstVarName
	access = #read ifTrue:[^self haltOnReadTo: anInstVarName].
	access = #write ifTrue:[^self haltOnWriteTo: anInstVarName].
	^self haltOnAccessTo: anInstVarName! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toTemporary: aTempVar
	"Object specific links cannot be put on temporaries"

	self shouldNotImplement! !

!Object methodsFor: 'deprecation' stamp: ''!
deprecated: anExplanationString on: date in: version transformWith: aRule when: conditionBlock
	"Automatically tranform the deprecated call if it matches the condition"
	
	Deprecation new
		context: thisContext sender;
		explanation: anExplanationString;
		date: date;
		version: version;
		rule: aRule;
		condition: conditionBlock;
		transform.! !

!Object methodsFor: '*Transcript-Core' stamp: ''!
traceCr: anObject
	"Log the argument. Use self traceCr: 'something' instead of Transcript show: 'something'  ; cr "
	
	self trace: anObject.
	Transcript cr! !

!Object methodsFor: '*NewTools-Fuel' stamp: ''!
fuelOut
	| target |
	target := FileLocator imageDirectory / self printString asFileName, 'fuel'.
	self serializeToFileNamed: target nextVersion fullName! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiCallingConvention
	^ OSPlatform current ffiCallingConvention! !

!Object methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 62>
	self class isVariable ifFalse: [self errorNotIndexable].
	^ 0! !

!Object methodsFor: 'printing' stamp: ''!
fullPrintString
	"Answer a String whose characters are a description of the receiver."

	^ String streamContents: [:s | self printOn: s]! !

!Object methodsFor: 'casing-To be deprecated' stamp: ''!
caseOf: aBlockAssociationCollection otherwise: aBlock
	"DO NOT USE THIS METHOD!! It will be removed from Pharo."
	
	"The elements of aBlockAssociationCollection are associations between blocks.
	 Answer the evaluated value of the first association in aBlockAssociationCollection
	 whose evaluated key equals the receiver.  If no match is found, answer the result
	 of evaluating aBlock."

	aBlockAssociationCollection associationsDo:
		[:assoc | (assoc key value = self) ifTrue: [^assoc value value]].
	^ aBlock value

"| z | z := {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]"
"| z | z := {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]"
"The following are compiled in-line:"
"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]"
"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]"! !

!Object methodsFor: '*Metacello-Core' stamp: ''!
metacelloStringLessThanSelf: anInteger

	^self error: 'Invalid Metacello verson component - should be String or Integer.'! !

!Object methodsFor: '*System-Object Events' stamp: ''!
when: anEventSelector evaluate: anAction 

	| actions |
	actions := self actionSequenceForEvent: anEventSelector.
	(actions includes: anAction)
		ifTrue: [^ self].
	self 
		setActionSequence: (actions copyWith: anAction)
		forEvent: anEventSelector! !

!Object methodsFor: 'testing' stamp: ''!
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: '*UnifiedFFI' stamp: ''!
calloutAPIClass
	^ self ffiLibrary calloutAPIClass! !

!Object methodsFor: 'message performing' stamp: ''!
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."
	
	<primitive: 83>
	^ self perform: aSymbol withArguments: #()! !

!Object methodsFor: 'pinning' stamp: ''!
pin
	"self
		deprecated: 'Please use #pinInMemory instead'
		transformWith: '`@receiver pin' -> '`@receiver pinInMemory'."
		
	self pinInMemory! !

!Object methodsFor: 'converting' stamp: ''!
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: 'updating' stamp: ''!
update: anAspect with: anObject
	"Receive a change notice from an object of whom the receiver is a 
	dependent. The default behavior is to call update:,
	which by default does nothing; a subclass might want 
	to change itself in some way."

	^ self update: anAspect! !

!Object methodsFor: 'testing' stamp: ''!
isTrait
	^false! !

!Object methodsFor: '*Collections-Abstract-splitjoin' stamp: ''!
split: aSequenceableCollection indicesDo: aBlock
	"Perform an action specified as aBlock (with a start and end argument) to each of the indices of the receiver element that have been identified by splitting the receiver using the splitter argument. optimized version for single delimiters."
	
	"(String streamContents: [:s | Character space split: 'Pharo is cool'  indicesDo: [ :start :end | s << 's:' << start asString << ' ' << 'e:' << end asString << ' ' ]]) >>> 's:1 e:5 s:7 e:8 s:10 e:13 '"
		
		
		
	|  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: '*Monticello-Storing' stamp: 'nil'!
comeFullyUpOnReload: smartRefStream
	"Normally this read-in object is exactly what we want to store."

	^ self! !

!Object methodsFor: 'converting' stamp: ''!
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: '*Transcript-Core' stamp: ''!
traceCrTab: anObject
	"Log the argument. Use self traceCr: 'something' instead of Transcript show: 'something'  ; cr "
	
	self trace: anObject.
	Transcript cr ; tab! !

!Object methodsFor: 'finalization' stamp: ''!
hasMultipleExecutors
	"All objects, except ObjectFinalizerCollection instances should answer false to this message"
	^ false! !

!Object methodsFor: 'write barrier' stamp: ''!
beRecursivelyReadOnlyObject
	^self recursivelySetIsReadOnlyObject: true! !

!Object methodsFor: '*Collections-Abstract-splitjoin' stamp: ''!
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: 'flagging' stamp: ''!
isThisEverCalled: msg
	"Send this message, with some useful printable argument, from methods or branches of methods which you believe are never reached."

	self error: 'This is indeed called: ', msg printString! !

!Object methodsFor: '*NewTools-Spotter' stamp: ''!
asStSpotterProcessorLink

	^ StSpotterProcessorLink value: self! !

!Object methodsFor: 'displaying' stamp: ''!
fullDisplayString
	"Answer a String whose characters are a description of the receiver suitable for UI"

	^ String streamContents: [:s | self displayStringOn: s]! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toMethodNamed: aMethodName
	self link: aMetaLink toAST: (self nonAnonymousClass lookupSelector: aMethodName asSymbol) ast! !

!Object methodsFor: '*Calypso-Browser' stamp: ''!
asScriptResultStringInCalypso
	^self printString! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiCall: fnSpec
	<ffiCalloutTranslator>
	
	"All the ffiCall: messages are used to perform Foreign-Function calls (FFI calls).
	FFI calls allows Pharo code to interact with external dynamic linked libraries.
	Please refer to the booklet about more configuration details
	or some of the examples on the image LibC / FreeTypeFont / Athens / SDL."
	
	self ffiCall: fnSpec library: self ffiLibrary options: #()	! !

!Object methodsFor: '*System-Object Events' stamp: ''!
when: anEventSelector
send: aMessageSelector
to: anObject
with: anArg
 
    self
        when: anEventSelector
        evaluate: (WeakMessageSend
            receiver: anObject
            selector: aMessageSelector
		arguments: {anArg})! !

!Object methodsFor: 'testing' stamp: ''!
isLiteral
	"Answer whether the receiver has a literal text form recognized by the 
	compiler."

	^false! !

!Object methodsFor: 'message performing' stamp: ''!
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: 'dependencies' stamp: ''!
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: '*System-Object Events' stamp: ''!
updateableActionMap

	^EventManager updateableActionMapFor: self! !

!Object methodsFor: 'evaluating' stamp: ''!
value

	^self! !

!Object methodsFor: '*System-Object Events' stamp: ''!
removeAction: anAction
forEvent: anEventSelector

    self
        removeActionsSatisfying: [:action | action = anAction]
        forEvent: anEventSelector! !

!Object methodsFor: 'converting' stamp: ''!
asOrderedCollection
	"Answer an OrderedCollection with the receiver as its only element."

	^ OrderedCollection with: self! !

!Object methodsFor: 'casing-To be deprecated' stamp: ''!
caseError
	"DO NOT USE THIS METHOD!! It will be removed from Pharo."
	"Report an error from an in-line or explicit case statement."

	self error: 'Case not found (', self printString, '), and no otherwise clause'! !

!Object methodsFor: 'message performing' stamp: ''!
perform: aSymbol with: firstObject with: secondObject with: thirdObject with: fourthObject
	"Send the selector, aSymbol, to the receiver with the given arguments.
	Fail if the number of arguments expected by the selector is not four.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 83>
	^ self perform: aSymbol
		withArguments: {firstObject . secondObject . thirdObject . fourthObject}! !

!Object methodsFor: 'copying' stamp: ''!
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 |
	<primitive: 168>
	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: 'printing' stamp: ''!
printStringLimitedTo: limit
	"Answer a String whose characters are a description of the receiver.
	If you want to print without a character limit, use fullPrintString."
	^self printStringLimitedTo: limit using: [:s | self printOn: s]! !

!Object methodsFor: '*Spec-Core' stamp: ''!
isSpecAdapter

	^ false! !

!Object methodsFor: '*NewTools-Spotter' stamp: ''!
stFilter

	^ StFilterBlock stFilter
		! !

!Object methodsFor: 'testing' stamp: ''!
refersToLiteral: aLitteral
	^ self literalEqual: aLitteral! !

!Object methodsFor: 'message performing' stamp: ''!
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."
	
	<primitive: 84>
	^ self perform: selector withArguments: argArray inSuperclass: self class! !

!Object methodsFor: '*System-Object Events' stamp: ''!
actionMap

	^EventManager actionMapFor: self! !

!Object methodsFor: 'finalization' stamp: ''!
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: 'testing' stamp: ''!
isContext
	^false! !

!Object methodsFor: 'write barrier' stamp: ''!
isReadOnlyObject
	"Answer if the receiver is read-only.
	 If the VM supports read-only objects it will not write to read-only objects.
	 An attempt to write to an instance variable of a read-only object will
	 cause the VM to send attemptToAssign:withIndex: to the read-only object.
	 An attempt to modify a read-only object in a primitive will cause the
	 primitive to fail with a #'no modification' error code."
	<primitive: 163 error: ec>
	^self isImmediateObject! !

!Object methodsFor: 'copying' stamp: ''!
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: '*Spec-Core' stamp: ''!
wrappedInValueHolderIfNeeded

	^ self asValueHolder! !

!Object methodsFor: '*Morphic-Widgets-Basic' stamp: ''!
wantsDroppedMorph: aMorph event: anEvent inMorph: destinationLM 
	^false! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiCall: fnSpec module: aModuleName
	<ffiCalloutTranslator>
	
	self ffiCall: fnSpec library: aModuleName options: #()	
! !

!Object methodsFor: '*NewTools-Spotter' stamp: ''!
stListFilter

	^ StFilterSubstring new! !

!Object methodsFor: 'testing' stamp: ''!
isVariableBinding
	"Return true if I represent a literal variable binding"
	^false! !

!Object methodsFor: 'copying' stamp: ''!
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: '*System-Object Events' stamp: ''!
actionForEvent: anEventSelector
    "Answer the action to be evaluated when <anEventSelector> has been triggered."

	| actions |
	actions := self actionMap
		at: anEventSelector asSymbol
		ifAbsent: [^nil].
 
	^ actions asMinimalRepresentation! !

!Object methodsFor: 'converting' stamp: ''!
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: 'comparing' stamp: ''!
literalEqual: other

	^ self class == other class and: [self = other]! !

!Object methodsFor: '*Spec2-Core' stamp: ''!
isSpLayout

	^ false! !

!Object methodsFor: '*Tool-Finder' stamp: ''!
closeTo: anObject
	"Do not use this Method!! It is a workaround for MethodFinder"

	^[self = anObject] onErrorDo: [false]! !

!Object methodsFor: '*Tool-CriticBrowser' stamp: ''!
populateCBMenu: aMenu

	aMenu add: 'Browse' target: self selector: #browse! !

!Object methodsFor: '*System-Finalization' stamp: ''!
mourn
	"Sent by the new Finalization mechanism.
	All weak objects (instances of weak classes) and Ephemerons may be mourned if they point to an object that needs to be collected.
	
	This default implementation does nothing. To override in specific subclasses."! !

!Object methodsFor: '*Reflectivity' stamp: ''!
haltOnReadTo: aVariableName
	^VariableBreakpoint watchVariableReads: aVariableName inObject: self! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
defaultLabel
	"Answer the default label to be used in morphs."

	^ self class name! !

!Object methodsFor: '*System-Object Events' stamp: ''!
when: anEventSelector
send: aMessageSelector
to: anObject
 
    self
        when: anEventSelector
        evaluate: (WeakMessageSend
            receiver: anObject
            selector: aMessageSelector)! !

!Object methodsFor: '*System-Object Events' stamp: ''!
asActionSequence

	^WeakActionSequence with: self! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
wantsVisualFeedback

	^ true! !

!Object methodsFor: '*Transcript-Core' stamp: ''!
logEntry
	self traceCr: 'Entered ' , thisContext sender printString! !

!Object methodsFor: '*Spec2-Core' stamp: ''!
asPresenter

	^ self asString asPresenter! !

!Object methodsFor: 'pinning' stamp: ''!
pinInMemory
	"The VM's garbage collector routinely moves objects as it reclaims and compacts
	 memory. But it can also pin an object so that it will not be moved, which can make
	 it easier to pass objects out through the FFI.  Objects are unpinnned when created.
	 This method ensures an object is pinned, and answers whether it was already pinned."
	^self setPinnedInMemory: true! !

!Object methodsFor: 'converting' stamp: ''!
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: '*Tool-Base' stamp: ''!
inspect
	"Create and schedule an Inspector in which the user can examine the receiver's variables."
	^ Smalltalk tools inspector inspect: self! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
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."

	^ self currentWorld primaryHand! !

!Object methodsFor: 'halting' stamp: ''!
haltOnce
	<debuggerCompleteToSender>
	Halt once.! !

!Object methodsFor: 'testing' stamp: ''!
notNil
	"Coerces nil to false and everything else to true."

	^true! !

!Object methodsFor: 'message performing' stamp: ''!
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."

	<primitive: 100>
	selector isSymbol
		ifFalse: [ ^ self error: 'selector argument must be a Symbol' ].
	selector numArgs = argArray size
		ifFalse: [ ^ self error: 'incorrect number of arguments' ].
	(self class includesBehavior: lookupClass)
		ifFalse: [ ^ self error: 'lookupClass is not in my inheritance chain' ].
	self primitiveFailed! !

!Object methodsFor: 'converting' stamp: ''!
asCollectionElement
	"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: 'write barrier' stamp: ''!
recursivelySetIsReadOnlyObject: aBoolean exceptObjectsIn: alreadyDone

	"Handle self if not already done, and note it as done."

	(alreadyDone includes: self) ifFalse:
		[	self setIsReadOnlyObject: aBoolean.
			alreadyDone add: self ].

	"Handle all instance vars of self."
	self class allSlots do: [ :ivar | 
		(ivar read: self)
			recursivelySetIsReadOnlyObject: aBoolean
			exceptObjectsIn: alreadyDone ].
	
	"Handle all indexed elements of self."
	1 to: self basicSize do: [ :i | 
		(self basicAt: i)
			recursivelySetIsReadOnlyObject: aBoolean
			exceptObjectsIn: alreadyDone ]! !

!Object methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
stDisplayString

	^ StObjectPrinter asTruncatedTextFrom: self! !

!Object methodsFor: '*System-Support' stamp: ''!
systemNavigation

	^ SystemNavigation new! !

!Object methodsFor: 'printing' stamp: ''!
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: 'model - updating' stamp: ''!
okToChange
	"Allows a controller to ask this of any model"
	^ true! !

!Object methodsFor: 'error handling' stamp: ''!
explicitRequirement
	"If one of the superclasses can perform the selector, we execute the method of that class, otherwise, the explicit requirement error is thrown"
	<debuggerCompleteToSender>
	| originalMethod originalArguments errorBlock originalReceiver callingContext originalSelector |
	errorBlock := [ ^ self error: 'Explicitly required method' ].
	callingContext := thisContext sender.
	originalMethod := callingContext compiledCode method.
	originalMethod isFromTrait
		ifFalse: errorBlock.
	originalReceiver := callingContext receiver.
	originalSelector := originalMethod selector.
	originalArguments := callingContext arguments.
	originalReceiver class superclass
		withAllSuperclassesDo: [ :superClass | 
			superClass
				compiledMethodAt: originalSelector
				ifPresent: [ :method | 
					(method isProvided or: [ method isFromTrait not ])
						ifTrue: [ callingContext
								return:
									(method
										valueWithReceiver: originalReceiver
										arguments: originalArguments) ] ] ].
	errorBlock value! !

!Object methodsFor: '*System-Object Events' stamp: ''!
triggerEvent: anEventSelector
withArguments: anArgumentList

    ^(self actionForEvent: anEventSelector)
        valueWithArguments: anArgumentList! !

!Object methodsFor: '*Collections-Abstract-splitjoin' stamp: ''!
joinTo: stream
	"double dispatch for join:"
	^ stream nextPut: self! !

!Object methodsFor: '*LibGit-Core' stamp: ' 1/5/2022 21:01:26'!
handleLGitReturnCode
	^ self! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiLibrary
	
	"This method returns the ffiLibrary to use in the Foreign-Function calls performed in this object.
	FFI calls allows Pharo to call functions in other external dynamic linked libraries.
	
	See #ffiCall: to see how to perform a FFI call.
	Subclasses can redefine this method to use a different FFILibrary class (see class FFILibrary). 
	A FFILibrary object not only returns the path to the dynamic linked library to use (DLL/SO/DYLIB)
	but it can also configure different behaviours for the FFI Calls. For example, the backend to use 
	or how the types are mapped. 
	
	This default implementation is kept as backward compatibility. 
	Its implementation only returns a default configured FFILibrary using the path to the 
	dynamic library file returned by #ffiLibraryName 
	
	New users of FFI should return here a subclass of FFILibrary configured as required by the target 
	external library to call by FFI"
		
	^ self ffiLibraryName asFFILibrary! !

!Object methodsFor: '*Epicea' stamp: ''!
isEpEvent
	
	^ false! !

!Object methodsFor: '*ClassAnnotation' stamp: ''!
representsSimpleAnnotationUser: someUserClass

	^self isKindOf: someUserClass! !

!Object methodsFor: 'finalization' stamp: ''!
finalizationRegistry
	"Answer the finalization registry associated with the receiver."
	^WeakRegistry default! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
hasModelYellowButtonMenuItems
	^Morph cmdGesturesEnabled! !

!Object methodsFor: '*Monticello-Storing' stamp: 'nil'!
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: '*Reflectivity' stamp: ''!
link: aMetaLink toAST: aNode
	aNode link: aMetaLink forObject: self! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiCall: fnSpec options: callOptions
	<ffiCalloutTranslator>
	
	self ffiCall: fnSpec library: self ffiLibrary options: callOptions! !

!Object methodsFor: 'testing' stamp: ''!
isClosure
	^false! !

!Object methodsFor: 'displaying' stamp: ''!
displayStringLimitedTo: limit
	"Answer a String whose characters are a description of the receiver.
	If you want to print without a character limit, use fullDisplayString."
	^self printStringLimitedTo: limit using: [:s | self displayStringOn: s]! !

!Object methodsFor: '*Spec-Core' stamp: ''!
isSpecContainer
	^ false! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toSlot: aSlot
	"Object specific links cannot be put on slots"

	self shouldNotImplement! !

!Object methodsFor: 'testing' stamp: ''!
isPoint
	"Overridden to return true in Point."

	^ false! !

!Object methodsFor: '*UIManager' stamp: ''!
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: '*Morphic-Widgets-Basic' stamp: ''!
dragTransferTypeForMorph: dragSource 
	^nil! !

!Object methodsFor: 'error handling' stamp: ''!
notYetImplemented
	"Announce that this message is not yet implemented"
	<debuggerCompleteToSender>
	NotYetImplemented signalFor: thisContext sender selector! !

!Object methodsFor: 'testing' stamp: ''!
isInteger
	"Overridden to return true in Integer."

	^ false! !

!Object methodsFor: 'deprecation' stamp: ''!
deprecated: anExplanationString transformWith: aRule when: conditionBlock
	"Automatically tranform the deprecated call if it matches the condition"
	
	Deprecation new
		context: thisContext sender;
		explanation: anExplanationString;
		rule: aRule;
		condition: conditionBlock;
		transform.! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiLibraryName
	self flag: 'HACK: avoid direct subclassResponsibility to not break RB test cases..'.
	^ SubclassResponsibility signalFor: thisContext selector! !

!Object methodsFor: '*System-Object Events' stamp: ''!
hasActionsWithReceiver: anObject

	^self actionMap keys anySatisfy:
		[:eachEventSelector |
			(self actionSequenceForEvent: eachEventSelector)
				anySatisfy: [:anAction | anAction receiver == anObject]]! !

!Object methodsFor: '*Transcript-Core' stamp: ''!
traceCr
	self traceCr: self! !

!Object methodsFor: 'reflective operations' stamp: ''!
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."

	<primitive: 115>
	self isReadOnlyObject 
		ifTrue: [ ^ self modificationForbiddenFor: #primitiveChangeClassTo: value: anObject ]. 
	self primitiveFailed! !

!Object methodsFor: '*Metacello-Core' stamp: ''!
metacelloSemanticVersionComponentLessThan: aMetacelloVersonComponent
    ^ self error: 'Invalid Metacello verson component - should be String or Integer.'! !

!Object methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects
	"Return true if I contain subObjects that should be processed, false otherwise.
	Overwrite when necessary. See also #stonProcessSubObjects:"
	
	^ true! !

!Object methodsFor: '*System-Object Events' stamp: ''!
triggerEvent: anEventSelector
with: anObject

    ^self 
		triggerEvent: anEventSelector
		withArguments: { anObject }! !

!Object methodsFor: 'error handling' stamp: ''!
error: aString
	"Throw a generic Error exception."
	<debuggerCompleteToSender>
	^ Error new signal: aString! !

!Object methodsFor: '*System-Object Events' stamp: ''!
triggerEvent: anEventSelector
	"Evaluate all actions registered for <anEventSelector>. Return the value of the last registered action."

    ^(self actionForEvent: anEventSelector) value! !

!Object methodsFor: '*Ring-Core' stamp: ''!
isRingFullyResolved

	^ true! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiCall: fnSpec library: aLibrary options: callOptions fixedArgumentCount: fixedArgumentsCount
	<ffiCalloutTranslator>
	
	| ffiLibrary |
	ffiLibrary := aLibrary asFFILibrary.
	^ (ffiLibrary calloutAPIClass inUFFIContext: thisContext)
		convention: self ffiCallingConvention;
		options: (ffiLibrary options), callOptions;
		fixedArgumentCount: fixedArgumentsCount;
		function: fnSpec library: ffiLibrary! !

!Object methodsFor: '*System-Object Events' stamp: ''!
removeActionsSatisfying: aOneArgBlock 
forEvent: anEventSelector

    self
        setActionSequence:
            ((self actionSequenceForEvent: anEventSelector)
                reject: [:anAction | aOneArgBlock value: anAction])
        forEvent: anEventSelector! !

!Object methodsFor: '*Morphic-Widgets-Basic' stamp: ''!
dragTransferType
	^nil! !

!Object methodsFor: 'deprecation' stamp: ''!
deprecated: anExplanationString
	"Warn that the sending method has been deprecated"
	
	Deprecation new
		context: thisContext sender;
		explanation: anExplanationString;
		signal! !

!Object methodsFor: '*Reflectivity' stamp: ''!
asLiteralNode
	^RBLiteralNode value: self! !

!Object methodsFor: '*Epicea-Triggering' stamp: ''!
isEpiceaInterestingJobOwner

	^ false! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
asAlphaImageMorph

	^ self asMorph! !

!Object methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Decode non-variable classes from a map of their instance variables and values.
	Override to customize and add a matching #toSton: (see implementors)."
	
	self class isVariable 
		ifTrue: [
			stonReader error: 'custom #fromSton: implementation needed for variable/indexable class' ]
		ifFalse: [
			stonReader parseNamedInstVarsFor: self ]! !

!Object methodsFor: 'class membership' stamp: ''!
respondsTo: aSymbol 
	"Answer whether the method dictionary of the receiver's class contains 
	aSymbol as a message selector."

	^self class canUnderstand: aSymbol! !

!Object methodsFor: 'stepping' stamp: ''!
stepIn: aWindow

	^ self step! !

!Object methodsFor: '*System-Object Events' stamp: ''!
removeActionsForEvent: anEventSelector

    | map |
    map := self actionMap.
    map removeKey: anEventSelector asSymbol ifAbsent: [].
    map isEmpty
        ifTrue: [self releaseActionMap]! !

!Object methodsFor: 'write barrier' stamp: ''!
beReadOnlyObject
	"If the VM supports read-only objects it will not write to read-only objects.
	 An attempt to write to an instance variable of a read-only object will
	 cause the VM to send attemptToAssign:withIndex: to the read-only object.
	 An attempt to modify a read-only object in a primitive will cause the
	 primitive to fail with a #'no modification' error code.
	 Set the read-only flag of the receiver to true and answer the previous vaue of the flag."
	^self setIsReadOnlyObject: true! !

!Object methodsFor: 'write barrier' stamp: ''!
attemptToAssign: value withIndex: index 
	"Called by the VM when assigning an instance variable of an immutable object.
	Upon return, executing will resume *after* the inst var assignment. If the inst var mutation has to be 
	performed, do it manually here in the call back with instVarAt:put:.
	This method has to return *no* value by jumping to the context's sender"
	
	self modificationForbiddenFor: #instVarAt:put: index: index value: value.

	thisContext sender jump
	"CAN'T REACH"! !

!Object methodsFor: 'pinning' stamp: ''!
unpin
	"self
		deprecated: 'Please use #unpinInMemory instead'
		transformWith: '`@receiver unpin' -> '`@receiver unpinInMemory'."
		
	self unpinInMemory! !

!Object methodsFor: '*Metacello-Core' stamp: ''!
metacelloSemanticStringLessThanSelf: anInteger
    ^ self error: 'Invalid Metacello verson component - should be String or Integer.'! !

!Object methodsFor: 'introspection' stamp: ''!
instVarNamed: aString put: aValue
	"Store into the value of the instance variable in me of that name. Slow, but very useful.
	We support here all slots (even non indexed) but raise a backward compatible exception"

	^ self class
		slotNamed: aString
		ifFound: [ :slot | slot write: aValue to: self ]
		ifNone: [ InstanceVariableNotFound signalFor: aString asString ]! !

!Object methodsFor: '*Spec2-Core' stamp: ''!
isPresenter

	^ false! !

!Object methodsFor: '*Calypso-SystemQueries' stamp: ''!
matchesQueryBrowserFilter: aQueryBrowserFilter

	^self calypsoEnvironmentType match: self forQueryBrowserFilter: aQueryBrowserFilter! !

!Object methodsFor: 'reading' stamp: ''!
readFromString: aString 
	"Create an object based on the contents of aString."
	^ self readFrom: aString readStream! !

!Object methodsFor: 'private' stamp: ''!
errorNotIndexable
	"Create an error notification that the receiver is not indexable."

	self error: ('Instances of {1} are not indexable' format: {self class name})! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
taskbarIcon
	"Answer the icon for the receiver in a task bar
	or nil for the default."

	^self class taskbarIcon! !

!Object methodsFor: 'accessing' stamp: ''!
basicSize
	"Primitive. Answer the number of indexable variables in the receiver. 
	This value is the same as the largest legal subscript. Essential. Do not 
	override in any subclass. See Object documentation whatIsAPrimitive."

	<primitive: 62>
	"The number of indexable fields of fixed-length objects is 0"
	^0! !

!Object methodsFor: '*Transcript-Core' stamp: ''!
trace
	self trace: self! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
asMorph
	"Open a morph, as best one can, on the receiver"

	^ self asStringMorph! !

!Object methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionMetaContext: aContext

	aContext withoutEvaluator! !

!Object methodsFor: '*Reflectivity' stamp: ''!
haltOnWrite
	^VariableBreakpoint watchVariablesWritesInObject: self! !

!Object methodsFor: 'testing' stamp: ''!
isColor
	"Answer true if receiver is a Color. False by default."

	^ false! !

!Object methodsFor: 'message performing' stamp: ''!
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."

	<primitive: 83>
	^ self perform: aSymbol withArguments: {firstObject . secondObject}! !

!Object methodsFor: '*System-Settings-Core' stamp: ''!
acceptSettings: aVisitor 
	^ aVisitor visitObject: self! !

!Object methodsFor: 'write barrier' stamp: ''!
beReadOnlyLiteral
	"This is used by the compiler, it recurses into Arrays (see the override there)"
	self isLiteral ifFalse: [ ^ self ].
	self beReadOnlyObject! !

!Object methodsFor: 'testing' stamp: ''!
isMorph

	^ false! !

!Object methodsFor: 'error handling' stamp: ''!
shouldBeImplemented
	"Announce that this message should be implemented"
	<debuggerCompleteToSender>
	ShouldBeImplemented signalFor: thisContext sender selector! !

!Object methodsFor: 'pinning' stamp: ''!
isPinned
	"self
		deprecated: 'Please use #isPinnedInMemory instead'
		transformWith: '`@receiver isPinned' -> '`@receiver isPinnedInMemory'."
		
	^self isPinnedInMemory! !

!Object methodsFor: 'error handling' stamp: ''!
notify: aString 
	"Create and schedule a Notifier with the argument as the message in 
	order to request confirmation before a process can proceed."
	<debuggerCompleteToSender>
	Warning signal: aString! !

!Object methodsFor: 'printing' stamp: ''!
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: 'stepping' stamp: ''!
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: '*Ring-Core' stamp: ''!
isRingFullyUnresolved

	^ false! !

!Object methodsFor: 'comparing' stamp: ''!
~= anObject 
	"Answer whether the receiver and the argument do not represent the 
	same object."

	^self = anObject == false! !

!Object methodsFor: '*NewTools-Spotter' stamp: ''!
asStSpotterCandidateLink

	^ StSpotterCandidateLink value: self! !

!Object methodsFor: 'streaming' stamp: ''!
putOn: aStream
	"Write the receiver onto aStream.
	In general we assume aStream accepts the receiver as element type.
	Return self."
	
	aStream nextPut: self! !

!Object methodsFor: 'updating' stamp: ''!
update: aParameter 
	"Receive a change notice from an object of whom the receiver is a 
	dependent. The default behavior is to do nothing; a subclass might want 
	to change itself in some way."

	^ self! !

!Object methodsFor: 'associating' stamp: ''!
-> anObject
	"Answer an Association between self and anObject"
	"The following example creates an association whose key is number 1 and value string 'one'."

	"(1 -> 'one') key >>> 1"
	"(1 -> 'one') value >>> 'one'"
	
	"Note that key and value can be ANY object."
	
	^Association key: self value: anObject! !

!Object methodsFor: '*Calypso-NavigationModel' stamp: ''!
calypsoEnvironmentType

	^self class! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toSlotNamed: aSlotName option: option
	aMetaLink
		installOnVariableNamed: aSlotName
		for: self
		option: option
		instanceSpecific: self intanceSpecificMetaLinksAvailable! !

!Object methodsFor: 'dependencies' stamp: ''!
myDependents
	"Private. Answer a list of all the receiver's dependents."

	^ DependentsFields at: self ifAbsent: []! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiCall: fnSpec fixedArgumentCount: fixedArgumentsCount
	<ffiCalloutTranslator>
	
	"All the ffiCall: messages are used to perform Foreign-Function calls (FFI calls).
	FFI calls allows Pharo code to interact with external dynamic linked libraries.
	Please refer to the booklet about more configuration details
	or some of the examples on the image LibC / FreeTypeFont / Athens / SDL.
	
	This message allows to call variadic functions.
	It is required to set the number of fixed arguments in the call as different calling conventions handle them differently"
	
	self 
		ffiCall: fnSpec 
		library: self ffiLibrary 
		options: #()	
		fixedArgumentCount: fixedArgumentsCount! !

!Object methodsFor: '*System-Object Events' stamp: ''!
when: anEventSelector
send: aMessageSelector
to: anObject
withArguments: anArgArray
 
    self
        when: anEventSelector
        evaluate: (WeakMessageSend
            receiver: anObject
            selector: aMessageSelector
		arguments: anArgArray)! !

!Object methodsFor: 'class membership' stamp: ''!
isKindOf: aClass
	"Answer whether the class, aClass, is a superclass or class of the receiver.
	The current implemementation allows for a Trait to be used as argument"

	^ self class == aClass or: [ self class inheritsFrom: aClass ]! !

!Object methodsFor: 'introspection' stamp: ''!
instVarAt: index put: anObject
	"Primitive. Store a value into a fixed variable in an object. The numbering of the
	 variables corresponds to the named instance variables, followed by the indexed
	 instance variables. Fail if the index is not an Integer or is not the index of a fixed
	 variable or indexed variable. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 174 error: ec>
	 (index isInteger 
		and: [ index between: 1 and: self class instSize + self basicSize]) 
			ifFalse: [ ^ self errorSubscriptBounds: index ].
	self isReadOnlyObject 
		ifTrue: [ ^ self modificationForbiddenFor: #instVarAt:put: index: index value: anObject ]! !

!Object methodsFor: '*Transcript-Core' stamp: ''!
crTrace
	self crTrace: self! !

!Object methodsFor: 'deprecation' stamp: ''!
deprecated: anExplanationString on: date in: version transformWith: aRule
	"Automatically tranform the deprecated call"
	
	Deprecation new
		context: thisContext sender;
		explanation: anExplanationString;
		date: date;
		version: version;
		rule: aRule;
		transform.! !

!Object methodsFor: '*Metacello-Core' stamp: ''!
metacelloSemanticIntegerLessThanSelf: anInteger
    ^ self error: 'Invalid Metacello verson component - should be String or Integer.'! !

!Object methodsFor: 'finalization' stamp: ''!
actAsExecutor
	"Prepare the receiver to act as executor for any resources associated with it"
	self breakDependents! !

!Object methodsFor: 'private' stamp: ''!
retrySetPinnedInMemory: aBoolean
	"Never use me directly use #setPinnedInMemory: instead"
	
	<primitive: 184 error: ec>
	
	^ self primitiveFailed! !

!Object methodsFor: 'copying' stamp: ''!
clone
	"Answer a shallow copy of the receiver."
	<primitive: 148 error: ec>
	| class newObject |
	ec == #'insufficient object memory' ifFalse:
		[^self primitiveFailed].
	"If the primitive fails due to insufficient memory, instantiate via basicNew: to invoke
	 the garbage collector before retrying, and use copyFrom: to copy state."
	newObject := (class := self class) isVariable
					ifTrue: 
						[class isCompiledMethodClass
							ifTrue:
								[class newMethod: self basicSize - self initialPC + 1 header: self header]
							ifFalse:
								[class basicNew: self basicSize]]
					ifFalse:
						[class basicNew].
	^newObject copyFrom: self! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
pointer
	"Answers a pointer to me (see overrides for implementations)"
	self error: 'You cannot get a pointer to me.'! !

!Object methodsFor: 'dependencies' stamp: ''!
release
	"Remove references to objects that may refer to the receiver. This message 
	should be overridden by subclasses with any cycles, in which case the 
	subclass should also include the expression super release."! !

!Object methodsFor: '*System-Settings-Browser' stamp: ''!
settingStoreOn: aStream
	^ self storeOn: aStream! !

!Object methodsFor: 'testing' stamp: ''!
isBehavior
	"Return true if the receiver is a behavior.
	Note: Do not override in any class except behavior."
	^false! !

!Object methodsFor: 'class membership' stamp: ''!
isMemberOf: aClass 
	"Answer whether the receiver is an instance of the class, aClass."

	^self class == aClass! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
transferFor: passenger from: aMorph

	^ TransferMorph withPassenger: passenger from: aMorph! !

!Object methodsFor: '*Spec-Core' stamp: ''!
isSpecLayout

	^ false! !

!Object methodsFor: '*System-Model' stamp: 'nil'!
modelWakeUpIn: aWindow
	"A window with me as model is being entered or expanded.  Default response is no-op" ! !

!Object methodsFor: '*MenuRegistration-Core' stamp: ''!
fallbackMenuOn: aMenuMorph
	"When pragma menu building goes wrong, a fallback menu is created. To add custom items to that menu, override me in subclasses. See WorldState>>#fallbackMenuOn: for an example"! !

!Object methodsFor: 'deprecation' stamp: ''!
deprecated: anExplanationString transformWith: aRule
	"Automatically tranform the deprecated call"
	
	Deprecation new
		context: thisContext sender;
		explanation: anExplanationString;
		rule: aRule;
		transform.! !

!Object methodsFor: 'accessing' stamp: ''!
enclosedElement
	"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: '*UIManager' stamp: ''!
uiManager
	^ UIManager default! !

!Object methodsFor: '*Spec-Core' stamp: ''!
isAnnouncingObject

	^ false! !

!Object methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
asInspectorModel

	^ StInspectorModel on: self! !

!Object methodsFor: 'testing' stamp: ''!
isEmbeddedBlock
	"returns true for CleanBlockBlockClosure and CompiledBlock"
	^ false! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
dragPassengersFor: item inMorph: dragSource 

	^ { item }! !

!Object methodsFor: 'literal testing' stamp: ''!
shouldBePrintedAsLiteral

	^self isLiteral! !

!Object methodsFor: 'halting' stamp: ''!
haltIfNotTest
	"Halt if execution was not started by a test. This is useful as this means one can just run tests undisturbed, while a execution for example from the Playground would be halted"
	<debuggerCompleteToSender>
	Halt ifNotTest! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiCalloutIn: aContext
	"For backwards compatibility.
	It receives the context that is performing the ffi callout.
	This context will be used to know what method to compile and where to restart the execution"
	^ self calloutAPIClass inContext: aContext! !

!Object methodsFor: '*System-Object Events' stamp: ''!
createActionMap

	^IdentityDictionary new! !

!Object methodsFor: '*TaskIt' stamp: ''!
asWeakReference
	^ (WeakArray new: 1)
		at: 1 put: self;
		yourself! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiCall: fnSpec module: aModuleName options: callOptions
	<ffiCalloutTranslator>
	
	self ffiCall: fnSpec library: aModuleName options: callOptions! !

!Object methodsFor: '*System-Object Events' stamp: ''!
hasActionForEvent: anEventSelector
    "Answer true if there is an action associated with anEventSelector"

    ^(self actionForEvent: anEventSelector) notNil! !

!Object methodsFor: '*Morphic-Widgets-Basic' stamp: ''!
withoutListWrapper

	^self! !

!Object methodsFor: '*Morphic-Widgets-Basic' stamp: ''!
acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph 
	
	^false.! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toClassVariableNamed: aClassVariableName option: option
	aMetaLink
		installOnVariableNamed: aClassVariableName
		for: self
		option: option
		instanceSpecific: self intanceSpecificMetaLinksAvailable! !

!Object methodsFor: '*NewTools-Inspector' stamp: ''!
evaluatorInitialText: aStObjectContextPresenter 
	^ '{1}' format: { aStObjectContextPresenter model codeSnippet } ! !

!Object methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 61>
	index isInteger 
		ifTrue: [self class isVariable
			ifTrue: [(index between: 1 and: self size)
				ifFalse: [ ^ self errorSubscriptBounds: index]]
			ifFalse: [ ^ self errorNotIndexable ]]
		ifFalse: [ ^ self errorNonIntegerIndex ].
	self isReadOnlyObject 
		ifTrue: [ ^ self modificationForbiddenFor: #at:put: index: index value: value ].
	self errorImproperStore! !

!Object methodsFor: 'testing' stamp: ''!
isString
	"Overridden to return true in String, natch"
	^ false! !

!Object methodsFor: 'testing' stamp: ''!
isAssociation
	^ false! !

!Object methodsFor: '*Monticello-Storing' stamp: 'nil'!
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: '*Morphic-Base' stamp: ''!
treeNodeHead

	^ self! !

!Object methodsFor: '*Roassal3' stamp: ''!
rsValue: anArgument 
	^ self! !

!Object methodsFor: '*Tools' stamp: ''!
inspector
	^ Smalltalk tools inspector inspector: self! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
treeNodeTail

	^ nil! !

!Object methodsFor: 'pinning' stamp: ''!
unpinInMemory
	"The VM's garbage collector routinely moves objects as it reclaims and compacts
	 memory. But it can also pin an object so that it will not be moved, which can make
	 it easier to pass objects out through the FFI.  Objects are unpinnned when created.
	 This method ensures an object is unpinned, and answers whether it was pinned."
	^self setPinnedInMemory: false! !

!Object methodsFor: 'comparing' stamp: ''!
= 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: 'converting' stamp: ''!
as: aSimilarClass
	"Create an object of class aSimilarClass that has similar contents to the receiver if the object is not already an instance of this class."

	aSimilarClass == self class ifTrue: [ ^ self ].

	^ aSimilarClass newFrom: self! !

!Object methodsFor: '*NewTools-Spotter' stamp: ''!
spotterPreview: aBuilder

	^ self asString spotterPreview: aBuilder! !

!Object methodsFor: '*STON-Core' stamp: ''!
isStonReference
	^ false! !

!Object methodsFor: 'testing' stamp: ''!
haltIfNil! !

!Object methodsFor: '*Tool-Base' stamp: ''!
basicInspect
	^ Smalltalk tools basicInspector inspect: self! !

!Object methodsFor: 'halting' stamp: ''!
haltIfTest
	"Halt if execution was started by a test. These #halts are just active in the tests, useful when you want to add a halt in methods that are executed a lot (e.g. collections)"
	<debuggerCompleteToSender>
	Halt ifTest! !

!Object methodsFor: 'halting' stamp: ''!
halt
	"This is the typical message to use for inserting breakpoints during debugging."
	<debuggerCompleteToSender>
	Halt now! !

!Object methodsFor: '*System-Settings-Browser' stamp: ''!
settingFixedDomainValueNodeFrom: aSettingNode 
	^ aSettingNode fixedDomainValueNodeForObject: self! !

!Object methodsFor: 'converting' stamp: ''!
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: 'private' stamp: ''!
storeAt: offset inTempFrame: aContext
	"This message had to get sent to an expression already on the stack
	as a Block argument being accessed by the debugger.
	Just re-route it to the temp frame."
	^ aContext tempAt: offset put: self! !

!Object methodsFor: '*Polymorph-Widgets' stamp: ''!
systemIconName

	^ #classIcon! !

!Object methodsFor: 'dependencies' stamp: ''!
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: '*Reflectivity' stamp: ''!
haltOnCallTo: aSelector
	^Breakpoint breakOn: aSelector inObject: self! !

!Object methodsFor: 'halting' stamp: ''!
haltOnCount: anInteger
	"Halts once when a count is reached"

	<debuggerCompleteToSender>
	Halt onCount: anInteger! !

!Object methodsFor: 'introspection' stamp: ''!
className
	"Answer a string characterizing the receiver's class, for use in list views for example"

	^ self class name asString! !

!Object methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
haltOnAccess: access
	access = #read ifTrue:[^self haltOnRead].
	access = #write ifTrue:[^self haltOnWrite].
	^self haltOnAccess! !

!Object methodsFor: '*Morphic-Widgets-Basic' stamp: ''!
dragPassengerFor: item inMorph: dragSource 
	^item! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toTemporaryNamed: aTempVarName inMethod: aMethodName
	self
		link: aMetaLink
		toTemporaryNamed: aTempVarName
		inMethod: aMethodName
		option: #all! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
asStringMorph
	"Open a StringMorph, as best one can, on the receiver"

	^ self asString asStringMorph! !

!Object methodsFor: '*System-Caching' stamp: ''!
asDoubleLink
	^ DoubleLink value: self! !

!Object methodsFor: 'introspection' stamp: ''!
writeSlotNamed: aName value: anObject
	^(self class slotNamed: aName) write: anObject to: self! !

!Object methodsFor: '*Fuel-Core' stamp: ''!
fuelReplacement
	^ self! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toTemporaryNamed: aTempVarName inMethod: aMethodName option: option
	| variable |
	
	variable := (self nonAnonymousClass lookupSelector: aMethodName) lookupVar: aTempVarName.

	aMetaLink
		installOnVariable: variable
		for: self
		option: option
		instanceSpecific: true! !

!Object methodsFor: 'accessing' stamp: ''!
basicAt: index put: value 
	"Primitive. Assumes receiver is indexable. Store the second argument 
	value in the indexable element of the receiver indicated by index. Fail 
	if the index is not an Integer or is out of bounds. Or fail if the value is 
	not of the right type for this kind of collection. Answer the value that 
	was stored. Essential. Do not override in a subclass. See Object 
	documentation whatIsAPrimitive."

	<primitive: 61>
	index isInteger 
		ifTrue: [self class isVariable
			ifTrue: [(index between: 1 and: self size)
				ifFalse: [ ^ self errorSubscriptBounds: index ]]
			ifFalse: [ ^ self errorNotIndexable ]]
		ifFalse: [ ^ self errorNonIntegerIndex ].
	self isReadOnlyObject 
		ifTrue: [ ^ self modificationForbiddenFor: #basicAt:put: index: index value: value ].
	self errorImproperStore! !

!Object methodsFor: 'evaluating' stamp: ''!
in: aBlock
	"Evaluate the given block with the receiver as its argument."

	^ aBlock value: self! !

!Object methodsFor: '*System-Object Events' stamp: ''!
removeActionsWithReceiver: anObject
forEvent: anEventSelector

    self
        removeActionsSatisfying:
            [:anAction |
            anAction receiver == anObject]
        forEvent: anEventSelector! !

!Object methodsFor: '*FreeType' stamp: ''!
ftSize

	^ 4! !

!Object methodsFor: 'associating' stamp: ''!
~~> aValueLinkOrNil

	"Answer a link of the same class of `aValueLinkOrNil`; if that argument is nil,
	 then the Link hierarchy is used as fallback. Moreover, `aValueLinkOrNil` can be
	 any object, in that case by dispatching of #asLinkPrepend:, that object is enclosed
	 in a Link and then used to chain `self`. "

	^ aValueLinkOrNil asLinkPrepend: self! !

!Object methodsFor: 'testing' stamp: ''!
isCharacter

	^ false.! !

!Object methodsFor: 'asserting' stamp: ''!
assert: aBlock description: aStringOrBlock
	"Throw an assertion error if aBlock does not evaluates to true."
	<debuggerCompleteToSender>
	aBlock value 
		ifFalse: [ AssertionFailure signal: aStringOrBlock value ]! !

!Object methodsFor: '*Fuel-Core' stamp: ''!
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: 'testing' stamp: ''!
isDictionary
	^false! !

!Object methodsFor: '*Transcript-Core' stamp: ''!
crTrace: aString
	"Log the argument. Use self crTrace: instead of Transcript cr; show: "
	
	Transcript cr.
	self trace: aString! !

!Object methodsFor: 'private' stamp: ''!
errorNonIntegerIndex
	"Create an error notification that an improper object was used as an index."

	self error: 'only integers should be used as indices'! !

!Object methodsFor: '*Reflectivity' stamp: ''!
intanceSpecificMetaLinksAvailable
	^true! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toClassVariable: aClassVariable
	"Object specific links cannot be put on class variables"

	self shouldNotImplement! !

!Object methodsFor: '*NewTools-Spotter' stamp: ''!
stSpotterProcessorsFor: aSpotterStep
	"This is a utility method that collects all extensions (processors) for the current object.
	By default, it simply looks for the #spotterOrder: pragma.
	The step can decice whether or not an extension should be enabled.
	The step can also configure each extension (e.g. override any property)"
	
	(Pragma allNamed: #stSpotterOrder: from: self class to: Object) 
		do: [ :aPragma |  
			self perform: aPragma methodSelector with: aSpotterStep.
			aSpotterStep processors 
				ifNotEmpty: [ :list | list last order: (aPragma argumentAt: 1) ] ]! !

!Object methodsFor: '*STON-Core' stamp: ''!
stonPostReferenceResolution
	"Hook that is called when references were resolved processing this object or one of its sub objects. This will most probably influence hash values. Override to take appropriate action."! !

!Object methodsFor: 'write barrier' stamp: ''!
setIsReadOnlyObject: aBoolean
	"If the VM supports read-only objects it will not write to read-only objects.
	 An attempt to write to an instance variable of a read-only object will
	 cause the VM to send attemptToAssign:withIndex: to the read-only object.
	 An attempt to modify a read-only object in a primitive will cause the
	 primitive to fail with a #'no modification' error code.
	 This primitive sets the read-only flag of the receiver to the given
	 value and answers the previous vaue of the flag.
	 Note: Some objects can't be read-only, currently contexts and objects related
	 to process scheduling (Processor, Process instances, Semaphore instances, ...)"
	<primitive: 164 error: ec>
	self isImmediateObject ifTrue: [ ^true ].
	^self primitiveFailed! !

!Object methodsFor: '*NewValueHolder-Core' stamp: ''!
isValueHolder

	^ false! !

!Object methodsFor: '*Collections-Abstract-splitjoin' stamp: ''!
join: aSequenceableCollection
	"Append the elements of the argument, aSequenceableCollection, separating them by the receiver."
	"(Character space join: #('Pharo' 'is' 'cool')) >>> 'Pharo is cool'"
	
	^ (Array with: self) join: aSequenceableCollection! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toNodes: nodes
	nodes do: [ :node | self link: aMetaLink toAST: node ]! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
packToArity: arity
	"This will answer a pointer to this object. 
	 It is like doing ==var ptr=&aVariable== in C (up to arity). 
	
	 In general, arity>1 will not work because then object has to be copied to 
	 heap, but my overrides will handle this case"
	| rolledPointer |
		
	rolledPointer := self.
	1 to: arity do: [ :index | rolledPointer := rolledPointer pointer ].
	^ rolledPointer! !

!Object methodsFor: 'message performing' stamp: ''!
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."
	
	<primitive: 83>
	^ self perform: aSymbol
		withArguments: {firstObject . secondObject . thirdObject}! !

!Object methodsFor: '*NewTools-Debugger-Breakpoints-Tools' stamp: ''!
inspectionBreakpointsContext: aContext

	aContext withoutEvaluator! !

!Object methodsFor: 'testing' stamp: ''!
isMessageSend
	^false! !

!Object methodsFor: 'converting' stamp: ''!
asLinkPrepend: anObject

	^ self asLink asLinkPrepend: anObject! !

!Object methodsFor: '*Tool-Base' stamp: ''!
browse
	^ Smalltalk tools browser openOnClass: self class! !

!Object methodsFor: '*UIManager' stamp: ''!
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: '*Rubric' stamp: ''!
unplug
! !

!Object methodsFor: 'testing' stamp: ''!
isColorForm
	^false! !

!Object methodsFor: 'stepping' stamp: ''!
wantsStepsIn: aSystemWindow
	
	^ self wantsSteps! !

!Object methodsFor: 'evaluating' stamp: ''!
valueWithArguments: aSequenceOfArguments

	^self! !

!Object methodsFor: 'accessing' stamp: ''!
basicAt: index 
	"Primitive. Assumes receiver is indexable. Answer the value of an 
	indexable element in the receiver. Fail if the argument index is not an 
	Integer or is out of bounds. Essential. Do not override in a subclass. See 
	Object documentation whatIsAPrimitive."

	<primitive: 60>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	self errorNonIntegerIndex! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
newCallbackWithSignature: signature block: aBlock
	"This method is used to create a callback in the same library and callout api of the receiver"
	
	^ (self ffiCalloutIn: thisContext sender)
		convention: self ffiCallingConvention;
		newCallbackWithSignature: signature
			block: aBlock
			library: self ffiLibrary! !

!Object methodsFor: '*Sindarin' stamp: ''!
isExceptionSignalledForDebuggedExecution
	^ false! !

!Object methodsFor: '*NewValueHolder-Core' stamp: ''!
asValueHolder
	"See NewValueHolder class comment"

	^ NewValueHolder value: self! !

!Object methodsFor: 'testing' stamp: ''!
isFraction
	"Answer true if the receiver is a Fraction."

	^ false! !

!Object methodsFor: 'printing' stamp: ''!
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: 'pinning' stamp: ''!
setPinned: aBoolean
	"self
		deprecated: 'Please use #setPinnedInMemory: instead'
		transformWith: '`@receiver setPinned: `@statements' -> '`@receiver setPinnedInMemory: `@statements'."
		
	self setPinnedInMemory: aBoolean! !

!Object methodsFor: '*Reflectivity' stamp: ''!
haltOnWriteTo: aVariableName
	^VariableBreakpoint watchVariableWrites: aVariableName inObject: self! !

!Object methodsFor: 'enumerating' stamp: ''!
flattenOn: aStream
		aStream nextPut: self! !

!Object methodsFor: '*Ring-Core' stamp: ''!
isRGObject

	^ false! !

!Object methodsFor: 'printing' stamp: ''!
storeString
	"Answer a String representation of the receiver from which the receiver 
	can be reconstructed."

	^ String streamContents: [:s | self storeOn: s]! !

!Object methodsFor: '*System-Object Events' stamp: ''!
setActionSequence: actionSequence
forEvent: anEventSelector

    | action |
    action := actionSequence asMinimalRepresentation.
    action 
	  ifNil:
            [self removeActionsForEvent: anEventSelector]
        ifNotNil:
            [self updateableActionMap
                at: anEventSelector asSymbol
                put: action]! !

!Object methodsFor: 'converting' stamp: ''!
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: 'deprecation' stamp: ''!
deprecated: anExplanationString on: date in: version
	"Warn that the sending method has been deprecated"
	
	Deprecation new
		context: thisContext sender;
		explanation: anExplanationString;
		date: date;
		version: version;
		signal! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toSlotNamed: aSlotName
	self link: aMetaLink toSlotNamed: aSlotName option: #all! !

!Object methodsFor: '*Transcript-Core' stamp: ''!
logExecution
	self traceCr: 'Executing ' , thisContext sender printString! !

!Object methodsFor: 'testing' stamp: ''!
isStream
	"Return true if the receiver responds to the stream protocol"
	^false! !

!Object methodsFor: 'displaying' stamp: ''!
displayString
	"While printString is about to give a detailled information about an object, displayString is a message that should return a short string-based representation to be used by list and related UI frameworks. By default, simply return printString. Subclasses should not override this method but instead stream based method #displayStringOn:"
	
	^ self displayStringLimitedTo: 1000! !

!Object methodsFor: 'testing' stamp: ''!
isSymbol
	^ false! !

!Object methodsFor: 'reflective operations' stamp: ''!
someObject
	"Primitive. Answer the first object in the enumeration of all
	 objects."

	<primitive: 138>
	self primitiveFailed.! !

!Object methodsFor: '*System-Object Events' stamp: ''!
removeActionsSatisfying: aBlock

	self actionMap keysDo:
		[:eachEventSelector |
			self
   				removeActionsSatisfying: aBlock
				forEvent: eachEventSelector
		]! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
currentEvent
	"Answer the current Morphic event.  This method never returns nil."
	^ self currentHand lastEvent! !

!Object methodsFor: '*UIManager' stamp: ''!
inform: aString
	"Display a message for the user to read and then dismiss."

	aString isEmptyOrNil
		ifFalse: [ UIManager default inform: aString ]! !

!Object methodsFor: '*Collections-Abstract-splitjoin' stamp: ''!
split: aSequenceableCollection
	"Split the argument using the receiver as a separator."
	"optimized version for single delimiters"
	"($/ split: '/foo/bar')>>>#('' 'foo' 'bar') asOrderedCollection"
	"([:c| c isSeparator] split: 'aa bb cc dd')>>> #('aa' 'bb' 'cc' 'dd') asOrderedCollection"
		
	| result |
	result := OrderedCollection new: (aSequenceableCollection size / 2) asInteger.
	self split: aSequenceableCollection do: [ :item |
		result add: item ].
	^ result! !

!Object methodsFor: 'testing' stamp: ''!
isCompiledBlock

	^ false! !

!Object methodsFor: 'error handling' stamp: ''!
traitConflict
	self error: 'A class or trait does not properly resolve a conflict between multiple traits it uses.'! !

!Object methodsFor: 'testing' stamp: ''!
isMorphicEvent
	^false! !

!Object methodsFor: 'write barrier' stamp: ''!
beWritableObject
	"If the VM supports read-only objects it will not write to read-only objects.
	 An attempt to write to an instance variable of a read-only object will
	 cause the VM to send attemptToAssign:withIndex: to the read-only object.
	 An attempt to modify a read-only object in a primitive will cause the
	 primitive to fail with a #'no modification' error code.
	 Set the read-only flag of the receiver to false and answer the previous vaue of the flag."
	^self setIsReadOnlyObject: false! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
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: [ 
		aCustomMenu add: 'inspect model'  target: self selector: #inspect.
	].
	^aCustomMenu! !

!Object methodsFor: '*Polymorph-Widgets' stamp: ''!
systemIcon
	"dont use this method. It will be deprecated.
	Tools should resolve real icon object based on icon name"
	^ self iconNamed: self systemIconName! !

!Object methodsFor: '*NewTools-Debugger-Breakpoints-Tools' stamp: ''!
inspectionBreakpoints
	<inspectorPresentationOrder: 998 title: 'Breakpoints'>

	^ StObjectBreakpointInspection on: self! !

!Object methodsFor: '*Transcript-Core' stamp: ''!
logExit
	self traceCr: 'Exited ' , thisContext sender printString! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiCall: fnSpec library: aLibrary
	<ffiCalloutTranslator>
	
	self ffiCall: fnSpec library: aLibrary options: #()! !

!Object methodsFor: 'private' stamp: ''!
errorImproperStore
	"Create an error notification that an improper store was attempted."

	self error: 'Improper store into indexable object'! !

!Object methodsFor: 'pinning' stamp: ''!
setPinnedInMemory: aBoolean
	"The VM's garbage collector routinely moves objects as it reclaims and compacts
	 memory. But it can also pin an object so that it will not be moved around in memory,
    while still being reclamable by the garbage collector. This can make
	 it easier to pass objects out through the FFI. Objects are unpinnned when created.
	 This primitive either pins or unpins an object, and answers if it was already pinned.
	
	If there is not enough memory, I will try to find more memory and retry once."
	<primitive: 184 error: ec>
	
	| requiredSize |
	
	ec = #'insufficient object memory'
		ifFalse: [ ^ self primitiveFailed ].
	
	"Require at least the double of my size in Memory"
	requiredSize := self sizeInMemory * 2.
	
	Smalltalk garbageCollect < requiredSize ifTrue:
		[Smalltalk growMemoryByAtLeast: requiredSize].

	^ self retrySetPinnedInMemory: aBoolean! !

!Object methodsFor: '*Reflectivity' stamp: ''!
haltOnAccessTo: aVariableName
	^VariableBreakpoint watchVariable: aVariableName inObject: self! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
isExternalType
	^ false! !

!Object methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating
	^ self isLiteral! !

!Object methodsFor: 'copying' stamp: ''!
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: 'error handling' stamp: ''!
subclassResponsibility
	"This message sets up a framework for the behavior of the class' subclasses.
	Announce that the subclass should have implemented this message."
	<debuggerCompleteToSender>
	SubclassResponsibility signalFor: thisContext sender selector! !

!Object methodsFor: '*Tool-Base' stamp: ''!
inspectWithLabel: aLabel
	"Create and schedule an Inspector in which the user can examine the receiver's variables."
	^Smalltalk tools inspector inspect: self label: aLabel! !

!Object methodsFor: '*Calypso-NavigationModel' stamp: ''!
printSystemPath

	^self calypsoEnvironmentType printSystemPathTo: self! !

!Object methodsFor: 'testing' stamp: ''!
isBlock

	^ false! !

!Object methodsFor: 'testing' stamp: ''!
isSystemWindow
"answer whatever the receiver is a SystemWindow"
	^ false! !

!Object methodsFor: 'pointing to' stamp: ''!
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: 'dependencies' stamp: ''!
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: '*System-Object Events' stamp: ''!
removeActionsWithReceiver: anObject

	self actionMap copy keysDo:
		[:eachEventSelector |
			self
   				removeActionsSatisfying: [:anAction | anAction receiver == anObject]
				forEvent: eachEventSelector
		]! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
iconOrThumbnailOfSize: aNumberOrPoint 
	"Answer an appropiate form to represent the receiver"
	^ nil! !

!Object methodsFor: '*Tool-Base' stamp: ''!
inspectOnce
	"Inspect unless we have already done it once."
	
	| node |
	node := thisContext sender sourceNodeExecuted.
	(node hasProperty: #Once) ifTrue: [^self]. 
	node propertyAt: #Once put: true.
	^self inspect! !

!Object methodsFor: '*Polymorph-Widgets' stamp: ''!
taskbarLabel
	"Answer the label string for the receiver in a task bar
	or nil for the default."

	^self class taskbarLabel! !

!Object methodsFor: '*System-Object Events' stamp: ''!
actionSequenceForEvent: anEventSelector

    ^(self actionMap
        at: anEventSelector asSymbol
        ifAbsent: [^WeakActionSequence new])
            asActionSequence! !

!Object methodsFor: '*Spec-Core' stamp: ''!
asWidget

	^ self! !

!Object methodsFor: '*PharoDocComment' stamp: ''!
>>> anObject
	"Return a pair. It is handy to support the tweaking of pharo doc expression. A pharo doc expression is a comment as the following one:"

	"4 + 3 >>> 7"
	
	"Pay attention when you write an executable comment for keyword-based method : surround with parentheses your expression because, otherwise the executable comment won't work as the message is binary."
	
	"(1 max: 1000) >>> 1000"

	^ self -> anObject! !

!Object methodsFor: '*System-Object Events' stamp: ''!
actionForEvent: anEventSelector
ifAbsent: anExceptionBlock
    "Answer the action to be evaluated when <anEventSelector> has been triggered."

	| actions |
	actions := self actionMap
		at: anEventSelector asSymbol
		ifAbsent: [nil].
	actions ifNil: [^anExceptionBlock value].
	^ actions asMinimalRepresentation! !

!Object methodsFor: 'testing' stamp: ''!
isClass
	^ false! !

!Object methodsFor: 'model - updating' stamp: ''!
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: 'copying' stamp: ''!
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: '*Ring-Core' stamp: ''!
markAsRingResolved

	"do nothing"! !

!Object methodsFor: '*Reflectivity' stamp: ''!
asMethodConstant
	| const constNode link |
	"this method will replace full sender message send of sender with me (or my value which usefull for block). So following sender method execution will not evaluate my receiver expresion but instead push precomputed literal with me"
	const := self value.
	constNode := thisContext sender sourceNodeExecuted.
	link := MetaLink new
		metaObject: const;
		control: #instead.
	constNode link: link.
	^const! !

!Object methodsFor: 'testing' stamp: ''!
isNotNil
	"Coerces nil to false and everything else to true."

	^true! !

!Object methodsFor: '*Metacello-Core' stamp: ''!
metacelloVersionComponentLessThan: aMetacelloVersonComponent

	^self error: 'Invalid Metacello verson component - should be String or Integer.'! !

!Object methodsFor: 'flagging' stamp: ''!
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: '*Transcript-Core' stamp: ''!
trace: anObject
	"Log the argument. Use self trace: instead of Transcript show: "
	
	Transcript show: anObject asString! !

!Object methodsFor: 'stepping' stamp: ''!
stepAt: millisecondClockValue in: aWindow

	^ self stepIn: aWindow! !

!Object methodsFor: 'finalization' stamp: ''!
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: 'testing' stamp: ''!
isMethodProperties
	^false! !

!Object methodsFor: '*System-Object Events' stamp: ''!
actionsDo: aBlock

	self actionMap do: aBlock! !

!Object methodsFor: 'introspection' stamp: ''!
instVarNamed: aString
	"Return the value of the instance variable in me with that name.  Slow, but very useful.
	We support here all slots (even non indexed) but raise a backward compatible exception"

	^ self class
		slotNamed: aString
		ifFound: [ :slot | slot read: self ]
		ifNone: [ InstanceVariableNotFound signalFor: aString asString ]! !

!Object methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
isRingObject

	^false! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
asTextMorph
	"Open a TextMorph, as best one can, on the receiver"

	^ TextMorph new contentsAsIs: self asStringOrText! !

!Object methodsFor: '*Calypso-NavigationModel' stamp: ''!
asCalypsoBrowserItem

	^self calypsoEnvironmentType convertToCalypsoBrowserItem: self! !

!Object methodsFor: '*Fuel-Core' stamp: ''!
serializeToFileNamed: aFilename
	^ FLSerializer serialize: self toFileNamed: aFilename! !

!Object methodsFor: '*Collections-Abstract-splitjoin' stamp: ''!
appendTo: aCollection
	"double dispatch for join:"
	^ aCollection addLast: self! !

!Object methodsFor: '*Calypso-NavigationModel' stamp: ''!
adoptForNewCalypsoQuery

	^self! !

!Object methodsFor: '*System-Support' stamp: ''!
isPrimitiveError
	"Answer a boolean indicating if the receiver is an error object returned by a primitive"
	^false! !

!Object methodsFor: 'stepping' stamp: ''!
stepTimeIn: aSystemWindow
	
	^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! !

!Object methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"Encode non-variable classes with a map of their instance variable and values.
	Override to customize and add a matching #fromSton: (see implementors)."

	self class isVariable 
		ifTrue: [
			stonWriter error: 'custom #stonOn: implementation needed for variable/indexable class' ]
		ifFalse: [
			stonWriter writeObject: self ]
! !

!Object methodsFor: '*Polymorph-Widgets' stamp: ''!
iconNamed: aSymbol
	
	^ Smalltalk ui icons iconNamed: aSymbol! !

!Object methodsFor: 'testing' stamp: ''!
isNumber
	"Overridden to return true in Number, natch"
	^ false! !

!Object methodsFor: '*System-Object Events' stamp: ''!
releaseActionMap

	EventManager releaseActionMapFor: self! !

!Object methodsFor: 'printing' stamp: ''!
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: 'stepping' stamp: ''!
stepTime
	
	^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! !

!Object methodsFor: 'copying' stamp: ''!
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: 'introspection' stamp: ''!
readSlotNamed: aName
	^(self class slotNamed: aName) read: self! !

!Object methodsFor: 'memory usage' stamp: ''!
sizeInMemory
	self class isImmediateClass
		ifTrue: [ ^ 0 ].
	^ self class isVariable
		ifTrue: [ self class byteSizeOfInstanceOfSize: self basicSize ]
		ifFalse: [ self class byteSizeOfInstance ]! !

!Object methodsFor: 'binding' stamp: ''!
hasBindingOf: aString
	^false! !

!Object methodsFor: '*NewTools-Spotter' stamp: ''!
stActDefault

	^ self inspect! !

!Object methodsFor: 'pinning' stamp: ''!
isPinnedInMemory
	"Answer if the receiver is pinned.  The VM's garbage collector routinely moves
	 objects as it reclaims and compacts memory.  But it can also pin an object so
	 that it will not be moved, which can make it easier to pass objects out through
	 the FFI."
	<primitive: 183 error: ec>
	^self primitiveFailed! !

!Object methodsFor: '*Calypso-NavigationModel' stamp: ''!
printAsConstantQueryItem
	^self printString! !

!Object methodsFor: 'process termination handling' stamp: ''!
handleProcessTerminationOfWaitingContext: suspendedContext
	^suspendedContext! !

!Object methodsFor: 'converting' stamp: ''!
asString
	"Answer a string that represents the receiver."

	^ self printString! !

!Object methodsFor: 'accessing' stamp: ''!
yourself
	"Answer self. The message yourself deserves a bit of explanation.
	Sending yourself is handy to get the receiver of a message. It is especially useful when using a cascade since all the cascaded messages are send to the receiver. Let us look at an example.
	
	Imagine that you have the following expression
		#('hello' 'world') at: 2 put: 'pharo'
	and that you would like to get the modified array #('hello' 'pharo') - the receiver of the message at:put:. 
	
	Right now the expression #('hello' 'world') at: 2 put: 'pharo' returns 'pharo' and not the receiver because the message at:put: always returns the second argument.
	 
	To get the receiver we can simply use a cascade as follows:
		#('hello' 'world') at: 2 put: 'pharo'; yourself
	and since yourself returns the receiver of the message we will get the modified array.
	
	Stepping back using a cascade and yourself is equivalent to declare a variable, assign the expression and return the variable as follows:
	| a |
	a := #('hello' 'world'). 
	a at: 2 put: 'pharo'.
	a 
	"
	
	^self! !

!Object methodsFor: '*Beacon-Core' stamp: ''!
asBeaconSignal
	^ WrapperSignal on: self! !

!Object methodsFor: '*Morphic-Base' stamp: ''!
isTransferable

	^ false! !

!Object methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink toClassVariableNamed: aClassVariableName
	self link: aMetaLink toClassVariableNamed: aClassVariableName option: #all! !

!Object methodsFor: '*Reflectivity' stamp: ''!
haltOnAccess
	^ VariableBreakpoint watchVariablesInObject: self! !

!Object methodsFor: 'dependencies' stamp: ''!
breakDependents
	"Remove all of the receiver's dependents."

	self myDependents: nil! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
newCallbackWithSignature: signature block: aBlock library: aFFILibrary
	"This method is used to create a callback in the callout api of the receiver"
	
	^ (self ffiCalloutIn: thisContext sender)
		convention: self ffiCallingConvention;
		newCallbackWithSignature: signature
			block: aBlock
			library: aFFILibrary! !

!Object methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	"Append to the argument aStream a sequence of characters that is an 
	expression whose evaluation creates an object similar to the receiver."

	aStream nextPut: $(.
	self class isVariable
		ifTrue: [aStream nextPutAll: '(', self class name, ' basicNew: ';
					store: self basicSize;
					nextPutAll: ') ']
		ifFalse: [aStream nextPutAll: self class name, ' basicNew'].
	1 to: self class instSize do:
		[:i |
		aStream nextPutAll: ' instVarAt: ';
			store: i;
			nextPutAll: ' put: ';
			store: (self instVarAt: i);
			nextPut: $;].
	1 to: self basicSize do:
		[:i |
		aStream nextPutAll: ' basicAt: ';
			store: i;
			nextPutAll: ' put: ';
			store: (self basicAt: i);
			nextPut: $;].
	aStream nextPutAll: ' yourself)'! !

!Object methodsFor: 'asserting' stamp: ''!
assert: aBlock
	"Throw an assertion error if aBlock does not evaluates to true.
	We check for true explicitly to make the assertion fail for non booleans"
	<debuggerCompleteToSender>
	self assert: aBlock description: 'Assertion failed'.! !

!Object methodsFor: 'private' stamp: ''!
errorSubscriptBounds: index 
	"Create an error notification that an improper integer was used as an index."

	SubscriptOutOfBounds signalFor: index! !

!Object methodsFor: '*STON-Core' stamp: ''!
stonShouldWriteNilInstVars
	"Return true if my instance variables that are nil should be written out, 
	false otherwise. Overwrite when necessary. By default, return false."
	
	^ false! !

!Object methodsFor: '*Reflectivity' stamp: ''!
haltOnRead
	^VariableBreakpoint watchVariablesReadsInObject: self! !

!Object methodsFor: 'comparing' stamp: ''!
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: 'message performing' stamp: ''!
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: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionMeta
	<inspectorPresentationOrder: 999 title: 'Meta'>

	^ StMetaBrowser on: self! !

!Object methodsFor: 'testing' stamp: ''!
isClassOrTrait
	^ self isClass or: [ self isTrait ]! !

!Object methodsFor: 'testing' stamp: ''!
isHeap

	^ false! !

!Object methodsFor: 'message performing' stamp: ''!
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."
	
	<primitive: 83>
	^ self perform: aSymbol withArguments: {anObject}! !

!Object methodsFor: '*Morphic-Core' stamp: ''!
currentWorld
	"Answer a morphic world that is the current UI focus."
	^ UIManager default currentWorld! !

!Object methodsFor: '*Fuel-Core' stamp: ''!
fuelAfterMaterialization
	"Materialization process will send this message after materializing instances of my class"! !

!Object methodsFor: 'write barrier' stamp: ''!
recursivelySetIsReadOnlyObject: aBoolean
	^self recursivelySetIsReadOnlyObject: aBoolean exceptObjectsIn: IdentitySet new! !

!Object methodsFor: 'testing' stamp: ''!
isCompiledMethod

	^ false! !

!Object methodsFor: 'updating' stamp: ''!
changed: aParameter 
	"Receiver changed. The change is denoted by the argument aParameter. 
	Usually the argument is a Symbol that is part of the dependent's change 
	protocol. Inform all of the dependents."

	self dependents do: [:aDependent | aDependent update: aParameter]! !

!Object methodsFor: '*Polymorph-Widgets' stamp: ''!
okToClose
	"Sent to models when a window closing.
	Allows this check to be independent of okToChange."
	
	^true! !

!Object methodsFor: 'updating' stamp: ''!
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: 'halting' stamp: ''!
haltIf: condition
	<debuggerCompleteToSender>
	Halt if: condition.! !

!Object methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
defaultObjectInspectorClass

	^ StObjectInspectorPresenter! !

!Object methodsFor: 'error handling' stamp: ''!
error
	"Throw a generic Error exception."
	<debuggerCompleteToSender>
	^ self error: 'Error!!'! !

!Object methodsFor: 'copying' stamp: ''!
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: 'casing-To be deprecated' stamp: ''!
caseOf: aBlockAssociationCollection
	"DO NOT USE THIS METHOD!! It will be removed from Pharo."

	"The elements of aBlockAssociationCollection are associations between blocks.
	 Answer the evaluated value of the first association in aBlockAssociationCollection
	 whose evaluated key equals the receiver.  If no match is found, report an error."

	^ self caseOf: aBlockAssociationCollection otherwise: [self caseError]

"| z | z := {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z"
"| z | z := {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z"
"The following are compiled in-line:"
"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}"
"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}"! !

!Object methodsFor: 'copying' stamp: ''!
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: 'dependencies' stamp: ''!
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: 'literal testing' stamp: ''!
hasLiteralSuchThat: testBlock
	"This is the end of the imbedded structure path so return false."

	^ false! !

!Object methodsFor: '*STON-Core' stamp: ''!
stonProcessSubObjects: block
	"Execute block to (potentially) change each of my subObjects.
	In general, all instance and indexable variables are processed.
	Overwrite when necessary. Not used when #stonContainSubObjects returns false."
	
	1 to: self class instSize do: [ :each |
		self instVarAt: each put: (block value: (self instVarAt: each)) ].
	(self class isVariable and: [ self class isBytes not ])
		ifTrue: [
			1 to: self basicSize do: [ :each |
				self basicAt: each put: (block value: (self basicAt: each)) ] ]! !

!Object methodsFor: '*Text-Core' stamp: ''!
asStringOrText
	"Answer a string that represents the receiver."

	^ self asString ! !

!Object methodsFor: '*Ring-Core' stamp: ''!
isRGUnresolvedValue

	^ false! !

!Object methodsFor: 'testing' stamp: ''!
isText
	^ false! !

!Object methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectorNodes
	"Answer a list of attributes as nodes"
	
	^ (StNodeCollector for: self) collectNodes! !

!Object methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
asStyleVariable

	^ SpStyleVariable newValue: self! !

!Object methodsFor: 'finalization' stamp: ''!
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: 'introspection' stamp: ''!
writeSlot: aSlot value: anObject
	^aSlot write: anObject to: self! !

!Object methodsFor: 'updating' stamp: ''!
changed
	"Receiver changed in a general way; inform all the dependents by 
	sending each dependent an update: message."

	self changed: self! !

!Object methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage 
	<debuggerCompleteToSender>
	 "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: '*Ring-Core' stamp: ''!
orDefaultForUnresolved

	^ self! !

!Object methodsFor: 'flagging' stamp: ''!
isThisEverCalled
	^ self isThisEverCalled: thisContext sender printString! !

!Object methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
stInspect
	"Temporary to experiment, should be replaced by inspect later"

	^ StInspector inspect: self! !

!Object methodsFor: 'private' stamp: ''!
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."
	<primitive: 111>
	^self class! !

!Object methodsFor: 'printing' stamp: ''!
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: 'binding' stamp: ''!
bindingOf: aString
	^nil! !

!Object methodsFor: 'copying' stamp: ''!
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 |
	<primitive: 148>
	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: '*UnifiedFFI' stamp: ''!
ffiCall: fnSpec library: aLibrary options: callOptions
	<ffiCalloutTranslator>
	
	"Zero argument count tells it is a not variadic function"
	^ self ffiCall: fnSpec library: aLibrary options: callOptions fixedArgumentCount: 0! !

!Object methodsFor: 'displaying' stamp: ''!
displayStringOn: aStream
	"While #printOn: is about to give a detailled information about an object, #displayStringOn: is a message that should return a string-based representation to be used by list and related UI frameworks. By default, simply use printOn: method.
	Subclasses should override this method instead of #displayString"

	self printOn: aStream! !

!Object methodsFor: '*UnifiedFFI' stamp: ''!
ffiCall: fnSpec library: aLibrary fixedArgumentCount: fixedArgumentsCount
	<ffiCalloutTranslator>
	
	"This message allows to call variadic functions.
	It is required to set the number of fixed arguments in the call as different calling conventions handle them differently"
	
	self 
		ffiCall: fnSpec 
		library: aLibrary
		options: #()	
		fixedArgumentCount: fixedArgumentsCount! !

!Object methodsFor: 'accessing' stamp: ''!
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."

	<primitive: 60>
	index isInteger ifTrue:
		[self class isVariable
			ifTrue: [self errorSubscriptBounds: index]
			ifFalse: [self errorNotIndexable]].
	self errorNonIntegerIndex! !

!Object methodsFor: 'testing' stamp: ''!
isForm
	^false! !

!Object methodsFor: '*Metacello-Core' stamp: ''!
metacelloIntegerLessThanSelf: anInteger

	^self error: 'Invalid Metacello verson component - should be String or Integer.'! !

!Object methodsFor: 'testing' stamp: ''!
isRectangle
	^false! !

!Object methodsFor: '*Spec-Core' stamp: ''!
isTreeNodeModel

	^ false! !

!Object methodsFor: 'dependencies' stamp: ''!
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: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  Some classes refuse to be copied.  Some classes are picky about which fields get deep copied."
	
	| class selfNumberOfInstanceVariables fieldOfSelf copyOfSelf currentClass hasVeryDeepInnerMethod currentNumberOfInstanceVariables |
	
	deepCopier references at: self ifPresent: [ :newer | 	"already copied" ^ newer].
	class := self class.
	class isMeta ifTrue: [ "a metaclass" ^ self ].
	copyOfSelf := self shallowCopy.
	deepCopier references at: self put: copyOfSelf.	"remember"
		
	(class isVariable and: [class isPointers]) ifTrue: [
		self basicSize to: 1 by: -1 do: [ :i |
			fieldOfSelf := self basicAt: i. 
			copyOfSelf 
				basicAt: i
				put: (deepCopier references 
					at: fieldOfSelf
					ifAbsent: [ fieldOfSelf veryDeepCopyWith: deepCopier ])]].
	
	"Ask each superclass if it wants to share (weak copy) any inst vars"
	copyOfSelf veryDeepInner: deepCopier.

	"other superclasses want all instance variables deep copied"
	currentClass := class.  
	selfNumberOfInstanceVariables := class instSize.
	
	[ selfNumberOfInstanceVariables == 0 ] whileFalse: [
		hasVeryDeepInnerMethod := currentClass includesSelector: #veryDeepInner:.
		currentNumberOfInstanceVariables := currentClass instSize - currentClass superclass instSize.
		hasVeryDeepInnerMethod 
			ifTrue: ["skip inst vars"
				selfNumberOfInstanceVariables := selfNumberOfInstanceVariables - currentNumberOfInstanceVariables]	
			ifFalse: [ 
				currentNumberOfInstanceVariables timesRepeat: [ 
					fieldOfSelf := self instVarAt: selfNumberOfInstanceVariables.
					copyOfSelf 
						instVarAt: selfNumberOfInstanceVariables 
						put: (deepCopier references 
							at: fieldOfSelf 
							ifAbsent: [ fieldOfSelf veryDeepCopyWith: deepCopier ]).
					selfNumberOfInstanceVariables := selfNumberOfInstanceVariables - 1 ]].
		currentClass := currentClass superclass ].
		
	^ copyOfSelf! !

!Object methodsFor: 'error handling' stamp: ''!
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: 'introspection' stamp: ''!
readSlot: aSlot
	^aSlot read: self! !

!Object methodsFor: 'converting' stamp: ''!
asLink
	"Answer a string that represents the receiver."

	^ ValueLink value: self! !

!Object methodsFor: '*Tool-Base' stamp: ''!
browseHierarchy

	self systemNavigation browseHierarchy: self class! !

!Object methodsFor: 'halting' stamp: ''!
haltFromCount: anInteger
	"Always halt after a count has been reached"

	<debuggerCompleteToSender>
	Halt fromCount: anInteger! !

!Object methodsFor: 'testing' stamp: ''!
isFloat
	"Overridden to return true in Float, natch"
	^ false! !

!Object methodsFor: 'printing' stamp: ''!
printStringLimitedTo: limit using: printBlock
	"Answer a String whose characters are a description of the receiver
	produced by given printBlock. It ensures the result will be not bigger than given limit"
	| limitedString |
	limitedString := String streamContents: printBlock limitedTo: limit.
	limitedString size < limit ifTrue: [^ limitedString].
	^ limitedString , '...etc...'! !

!Object methodsFor: 'finalization' stamp: ''!
executor
	"Return an object which can act as executor for finalization of the receiver"
	^self shallowCopy actAsExecutor! !

!Object methodsFor: 'testing' stamp: ''!
isArray
	^false! !

!Object class methodsFor: '*Calypso-NavigationModel' stamp: ''!
isCalypsoItemType: aClass
	^self includesBehavior: aClass! !

!Object class methodsFor: '*System-FileRegistry' stamp: ''!
fileReaderServicesForFile: fullName suffix: suffix
	<fileService>
	"Backstop"
	^#()! !

!Object class methodsFor: '*STON-Core' stamp: ''!
stonName
	"Override to encode my instances using a different class name.
	Use symbols as class name/tag."
	
	"Class names are expected to conform
	to first STONReader>>#isClassStartChar: then STONReader>>#isClassChar:"
	
	^ self name! !

!Object class methodsFor: '*Tools-FileList' stamp: ''!
services
	"Backstop"
	^#()! !

!Object class methodsFor: 'class initialization' stamp: ''!
reInitializeDependentsFields
	<script>

	| oldFields |
	oldFields := DependentsFields.
	DependentsFields := WeakIdentityKeyDictionary new.
	oldFields
		keysAndValuesDo: [ :obj :deps | deps do: [ :d | obj addDependent: d ] ]! !

!Object class methodsFor: 'class initialization' stamp: ''!
flushDependents
	DependentsFields keysAndValuesDo:[:key :dep|
		key ifNotNil:[key removeDependent: nil].
	].
	DependentsFields finalizeValues.! !

!Object class methodsFor: 'documentation' stamp: ''!
whatIsAPrimitive
	"Some messages in the system are responded to primitively. A primitive   
	response is performed directly by the interpreter rather than by evaluating   
	expressions in a method. The methods for these messages indicate the   
	presence of a primitive response by including <primitive: xx> or 
	<primitive: 79 error: ec>before the first expression in the method.   
	
	In the second case, ec is a special temporary variable that holds an error code. 
	In the VM primitive, failure is indicated by a variable called primFailCode being 
	non-zero. On activating a method with a failing primitive, if the index is in 
	bounds of the 	primitiveFailCodes array in the VMspecialObjectsArray then the 
	failure code substitutes the symbol in the 	primitiveFailCodes array, otherwise 
	it supplies the integer value.
	  
	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: '*Metacello-MC' stamp: ''!
lastMetacelloVersionLoad
	"Answer the last version loaded and the list of packages loaded for that version.
	 See MetacelloConfigTemplate."

	^nil -> 'default'! !

!Object class methodsFor: 'instance creation' stamp: ''!
readFrom: textStringOrStream
	"Create an object based on the contents of textStringOrStream."

	| object |
	object := self class compiler evaluate: textStringOrStream.
	(object isKindOf: self) ifFalse: [self error: self name, ' expected'].
	^object! !

!Object class methodsFor: '*Morphic-Base' stamp: ''!
taskbarIcon
	"Answer the icon for an instance of the receiver in a task bar"

	^self iconNamed: self taskbarIconName! !

!Object class methodsFor: '*Calypso-NavigationModel' stamp: ''!
checkCalypsoItem: anObject isSameAs: anObject2
	^anObject == anObject2! !

!Object class methodsFor: '*Calypso-NavigationModel' stamp: ''!
printSystemPathTo: myInstance
	^''! !

!Object class methodsFor: 'documentation' stamp: ''!
howToModifyPrimitives
	"You are allowed to write methods which specify primitives, but please use 
	caution.  If you make a subclass of a class which contains a primitive method, 
	the subclass inherits the primitive.  The message which is implemented 
	primitively may be overridden in the subclass (E.g., see at:put: in String's 
	subclass Symbol).  The primitive behavior can be invoked using super (see 
	Symbol string:). 
	 
	A class which attempts to mimic the behavior of another class without being 
	its subclass may or may not be able to use the primitives of the original class.  
	In general, if the instance variables read or written by a primitive have the 
	same meanings and are in the same fields in both classes, the primitive will 
	work.  

	For certain frequently used 'special selectors', the compiler emits a 
	send-special-selector bytecode instead of a send-message bytecode.  
	Special selectors were created because they offer two advantages.  Code 
	which sends special selectors compiles into fewer bytes than normal.  For 
	some pairs of receiver classes and special selectors, the interpreter jumps 
	directly to a primitive routine without looking up the method in the class.  
	This is much faster than a normal message lookup. 
	 
	A selector which is a special selector solely in order to save space has a 
	normal behavior.  Methods whose selectors are special in order to 
	gain speed contain the comment, 'No Lookup'.  When the interpreter 
	encounters a send-special-selector bytecode, it checks the class of the 
	receiver and the selector.  If the class-selector pair is a no-lookup pair, 
	then the interpreter swiftly jumps to the routine which implements the 
	corresponding primitive.  (A special selector whose receiver is not of the 
	right class to make a no-lookup pair, is looked up normally).  The pairs are 
	listed below.  No-lookup methods contain a primitive number specification, 
	<primitive: xx>, 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 
	Context with					blockCopy: 
	BlockContext with either of 		value value:
	"

	self error: 'comment only'! !

!Object class methodsFor: 'class initialization' stamp: ''!
initialize
	"Object initialize"
	DependentsFields ifNil:[ self initializeDependentsFields ]! !

!Object class methodsFor: '*Polymorph-Widgets' stamp: ''!
taskbarLabel
	"Answer the label string for the receiver in a task bar
	or nil for the default."

	^nil! !

!Object class methodsFor: '*Morphic-Base' stamp: ''!
taskbarIconName
	"Answer the icon for an instance of the receiver in a task bar"

	^#smallWindowIcon! !

!Object class methodsFor: '*Debugger-Model' stamp: ''!
canonicalArgumentName
	"Imagine you write a method using this object (self) as argument, I return how you would likely 
	name that argument. 
	Used by DynamicMessageImplementor in the debugger to create a template method when an execution 
	calls a method that does not exist."
	| prefix |
	prefix := self name first isVowel
		ifTrue: [ 'an' ]
		ifFalse: [ 'a' ].
	^ prefix, self name! !

!Object class methodsFor: '*Tool-Finder' stamp: ''!
approvedSelectorsForMethodFinder

	^ #(at: basicAt: basicSize yourself size
	    ->
	    = == ~= hash literalEqual
	   )! !

!Object class methodsFor: 'class initialization' stamp: ''!
initializeDependentsFields
	<script: 'Object initialize'>
	
	DependentsFields := WeakIdentityKeyDictionary new! !

!Object class methodsFor: '*Calypso-NavigationModel' stamp: ''!
checkCalypsoItem: anObject isEqualTo: anObject2
	^anObject = anObject2! !

!Object class methodsFor: '*Metacello-MC' stamp: ''!
metacelloVersion: versionString loads: anArrayOrString
	"Stash the last version loaded and the list of packages loaded for that version. The list
	 of packages will be used by the tools when doing 'Load Package Version'.
	See MetacelloConfigTemplate for example"
	
	"noop by default"! !

!Object class methodsFor: '*System-Support' stamp: ''!
registerToolsOn: aToolRegistry

	" Override to register any tools for Smalltalk tools registry. " ! !

!Object class methodsFor: '*Calypso-NavigationModel' stamp: ''!
decorateBrowserItem: aBrowserItem by: anEnvironmentPlugin
	^ anEnvironmentPlugin
		decorateBrowserItem: aBrowserItem
		ofObject: aBrowserItem actualObject! !

!Object class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Create a new instance and delegate decoding to instance side.
	Override only when new instance should be created directly (see implementors). "
	
	^ self new
		fromSton: stonReader;
		yourself! !

!Object class methodsFor: '*STON-Core' stamp: ''!
stonAllInstVarNames
	"Override to encode my instances using a custom set of instance variables or to define their order."
	
	^ self allInstVarNames ! !

!Object class methodsFor: '*System-FileRegistry' stamp: ''!
fileReaderServicesForDirectory: aFileDirectory
	<directoryService>
	"Backstop"
	^#()! !

!Object class methodsFor: 'instance creation' stamp: ''!
newFrom: aSimilarObject
	"Create an object that has similar contents to aSimilarObject. If the classes have any instance variables with the same names, copy them across. If this is bad for a class, override this method."

	^ (self isVariable
		ifTrue: [self basicNew: aSimilarObject basicSize]
		ifFalse: [self basicNew]) copySameFrom: aSimilarObject! !

!Object class methodsFor: '*Calypso-NavigationModel' stamp: ''!
itemsSortOrderForCalypso
	"This method allows specify order of group of concrete type of items 
	Larger value will put items to the end of list comparing to the items of another type.
	By default it is big value multiplied by hash of type. 
	It gives behavior where items of different type will be always splitted in the list
	and sorted separatelly"
	^1000 * self hash! !

!Object class methodsFor: '*Calypso-NavigationModel' stamp: ''!
prepareCalypsoItemCopy: aBrowserItem! !

!Object class methodsFor: '*Calypso-Browser' stamp: ''!
asCalypsoItemContext
	^ClyBrowserItemContext itemType: self! !

!ObjectFinalizer commentStamp: ''!
Represents an action that is to be taken when a target object (not referenced by the ObjectFinalizer) is garbage-collected.!
!ObjectFinalizer methodsFor: 'finalization' stamp: ''!
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: ''!
receiver: anObject selector: aSymbol argument: aParameter
	"Not really necessary now that we're a subclass of MessageSend, but we keep it around because existing code might expect it."
	self 
		receiver: anObject;
		selector: aSymbol;
		arguments: (Array with: aParameter).! !

!ObjectFinalizerCollection commentStamp: ''!
An ObjectFinalizerCollection is simple collection which is intended to hold ObjectFinalizers and be used by WeakRegistry.!
!ObjectFinalizerCollection methodsFor: 'finalization' stamp: ''!
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: ''!
hasMultipleExecutors
	^ true! !

!ObjectFinalizerTest methodsFor: 'tests' stamp: ''!
testFinalizationOfMultipleResources
	"Test that finalizers for multiple resources registered will be ran when
	object is finalized"
	| objToFinalize resource1 resource2 resourceCleanBlock |
	objToFinalize := Object new.
	resource1 := Array with: false.
	resource2 := Array with: false.
	resourceCleanBlock := [:array | array at: 1 put: true].
	objToFinalize
		toFinalizeSend: #value:
		to: resourceCleanBlock
		with: resource1.
	objToFinalize
		toFinalizeSend: #value:
		to: resourceCleanBlock
		with: resource2.
	self deny: resource1 first.
	self deny: resource2 first.
	"Trigger finalization"
	objToFinalize := nil.
	Smalltalk garbageCollect.
	self assert: resource1 first.
	self assert: resource2 first! !

!ObjectLayout commentStamp: ''!
I am the superclass of standard layouts for Objects.!
!ObjectLayout methodsFor: 'extending' stamp: ''!
extend: aScope
	IncompatibleLayoutConflict new
		layout: self;
		subType: #slot;
		signal! !

!ObjectLayout methodsFor: 'testing - class hierarchy' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else as CompiledMethodLayout answers the same as ByteLayout and user defined Layouts are not 
	supported"
	^self class subclassDefiningSymbol! !

!ObjectLayout methodsFor: 'extending' stamp: ''!
extendDoubleByte
	self hasFields ifTrue: [
		IncompatibleLayoutConflict new
			layout: self;
			subType: #doubleByte;
			signal ].
	^ DoubleByteLayout new! !

!ObjectLayout methodsFor: 'testing - class hierarchy' stamp: ''!
kindOfSubclass
	"Answer a String that is the keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, see #subclassDefiningSymbol"
	^' ',self class subclassDefiningSymbol, ' '.! !

!ObjectLayout methodsFor: 'format' stamp: ''!
format
	"Answer an Integer that encodes this layout in the way that VM expects it."
	
	| fieldSize  format |
	fieldSize := self fieldSize.
	format := self instanceSpecification.
	format := (format bitShift: 16) + fieldSize.
	^ format! !

!ObjectLayout methodsFor: 'extending' stamp: ''!
extendCompiledMethod
	self hasFields ifTrue: [
		IncompatibleLayoutConflict new
			layout: self;
			subType: #compiledMethod;
			signal ].
	^ CompiledMethodLayout new! !

!ObjectLayout methodsFor: 'extending' stamp: ''!
extend
	"Answer a default extension of me."

	^ self subclassResponsibility! !

!ObjectLayout methodsFor: 'initialization' stamp: ''!
initializeInstance: anInstance
	"do nothing by default, overriden by PointerLayout"! !

!ObjectLayout methodsFor: 'extending' stamp: ''!
extendDoubleWord
	self hasFields ifTrue: [
		IncompatibleLayoutConflict new
			layout: self;
			subType: #doubleWord;
			signal ].
	^ DoubleWordLayout new! !

!ObjectLayout methodsFor: 'extending' stamp: ''!
extendSmallInteger
	self hasFields ifTrue: [
		IncompatibleLayoutConflict new
			layout: self;
			subType: #compiledMethod;
			signal ].
	^ ImmediateLayout new! !

!ObjectLayout methodsFor: 'extending' stamp: ''!
extendVariable: aScope
	IncompatibleLayoutConflict new
		layout: self;
		subType: #variable;
		signal! !

!ObjectLayout methodsFor: 'extending' stamp: ''!
extendByte
	self hasFields ifTrue: [
		IncompatibleLayoutConflict new
			layout: self;
			subType: #byte;
			signal ].
	^ ByteLayout new! !

!ObjectLayout methodsFor: 'extending' stamp: ''!
extendWord
	self hasFields ifTrue: [
		IncompatibleLayoutConflict new
			layout: self;
			subType: #word;
			signal ].
	^ WordLayout new! !

!ObjectLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	self subclassResponsibility! !

!ObjectLayout class methodsFor: 'monticello' stamp: ''!
layoutForSubclassDefiningSymbol: aSymbol
	"used to get the layout for a subclass definition symbol"
	^self allSubclasses 
		detect: [ :class | class isAbstract not and: [class subclassDefiningSymbol == aSymbol ]] 
		ifNone: [ FixedLayout ]! !

!ObjectLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else!!"
	"As a fallback we just return a standard class creation symbol. This will be called for user 	
	defined Layouts, for old style class definitions that can not support user defined Layouts"
	^#subclass:! !

!ObjectLayout class methodsFor: '*Deprecated10' stamp: ''!
kind

	self
		deprecated: 'Should use mcTypeSymbol instead'
		on: '08 September 2021'
		in: #Pharo10
		transformWith: '`@rec kind' -> '`@rec mcTypeSymbol'.
	^ self mcType! !

!ObjectLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass
	self subclassResponsibility! !

!ObjectLayout class methodsFor: '*Monticello' stamp: 'nil'!
mcTypeSymbol
	"return the symbol that Monticello uses to encode the layout"
	^self name asSymbol! !

!ObjectLayout class methodsFor: '*Monticello' stamp: 'nil'!
layoutForType: typeSymbol
	"used to get the layout for a Monticello internal layout symbol"
	^self allSubclasses 
		detect: [ :class | class mcTypeSymbol = typeSymbol ] 
		ifNone: [ Error signal: 'Invalid layout type: ', typeSymbol asString ]! !

!ObjectLayout class methodsFor: 'description' stamp: ''!
allSubclassDefiningSymbols
	^self allSubclasses collect: [ :class | class subclassDefiningSymbol ] as: Set! !

!ObjectLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == ObjectLayout! !

!ObjectLayoutTest methodsFor: 'tests' stamp: ''!
testLayoutForSubclassDefiningSymbol

	self assert: (ObjectLayout layoutForSubclassDefiningSymbol: #variableWordSubclass:) equals: WordLayout.
	self assert: (ObjectLayout layoutForSubclassDefiningSymbol: #ephemeronSubclass:) equals: EphemeronLayout.
	self assert: (ObjectLayout layoutForSubclassDefiningSymbol: #weakSubclass:) equals: WeakLayout.
	self assert: (ObjectLayout layoutForSubclassDefiningSymbol: #variableSubclass: ) equals: VariableLayout.
	self assert: (ObjectLayout layoutForSubclassDefiningSymbol: #immediateSubclass: ) equals: ImmediateLayout.
	self assert: (ObjectLayout layoutForSubclassDefiningSymbol: #subclass: ) equals: FixedLayout.
	"here we can get back ByteLayout or CompiledMethodLayout, clients have to take that into account and check the class name"
	self assert: ({ByteLayout. CompiledMethodLayout} includes: (ObjectLayout layoutForSubclassDefiningSymbol: #variableByteSubclass:))! !

!ObjectMockForTest commentStamp: ''!
I am a simple mock for tests!
!ObjectMockForTest methodsFor: 'accessing' stamp: ''!
variable
	^ variable! !

!ObjectMockForTest methodsFor: 'accessing' stamp: ''!
variable: anObject
	variable := anObject! !

!ObjectStringConverter commentStamp: ''!
Generic object<->string converter for use with PluggableTextFieldMorph.
Optional regex matching for validation.
Optional transform blocks for each conversion direction.!
!ObjectStringConverter methodsFor: 'converting' stamp: ''!
stringAsObject: aString
	"Answer the given string in object form."

	|transformed|
	transformed := self stringTransformBlock value: aString asString.
	^(transformed notNil and: [self needsConversion])
		ifTrue: [self objectClass readFromString: transformed]
		ifFalse: [transformed]! !

!ObjectStringConverter methodsFor: 'converting' stamp: ''!
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: 'accessing' stamp: ''!
regex

	^ regex! !

!ObjectStringConverter methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		objectTransformBlock: [:obj | obj];
		stringTransformBlock: [:string | string]! !

!ObjectStringConverter methodsFor: 'accessing' stamp: ''!
regex: anObject

	regex := anObject! !

!ObjectStringConverter methodsFor: 'converting' stamp: ''!
needsConversion
	"Answer whether conversion is required for the receiver's object class."

	^self objectClass notNil and: [(self objectClass includesBehavior: String) not]! !

!ObjectStringConverter methodsFor: 'accessing' stamp: ''!
regexString: aString
	"Setup the regex based on the given string."

	self regex: aString asRegex! !

!ObjectStringConverter methodsFor: 'converting' stamp: ''!
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: 'accessing' stamp: ''!
stringTransformBlock

	^ stringTransformBlock! !

!ObjectStringConverter methodsFor: 'converting' stamp: ''!
configureForIntegers
	"Configure the receiver to match/convert positive or negative integers only."

	self
		objectClass: Integer;
		regexString: '[-]?[0-9]+';
		stringTransformBlock: [:s |
			(s beginsWith: '-')
				ifTrue: ['-', (s select: [:c | c isDigit])]
				ifFalse: [s select: [:c | c isDigit]]]! !

!ObjectStringConverter methodsFor: 'accessing' stamp: ''!
objectTransformBlock: anObject

	objectTransformBlock := anObject! !

!ObjectStringConverter methodsFor: 'accessing' stamp: ''!
objectTransformBlock

	^ objectTransformBlock! !

!ObjectStringConverter methodsFor: 'accessing' stamp: ''!
stringTransformBlock: anObject

	stringTransformBlock := anObject! !

!ObjectStringConverter methodsFor: 'converting' stamp: ''!
objectAsString: anObject
	"Answer the given object in string form."

	^(self objectTransformBlock value: anObject)
		ifNotNil: [:o | o asString]! !

!ObjectStringConverter methodsFor: 'accessing' stamp: ''!
objectClass
	"Answer the class of object we are dealing with."

	^objectClass! !

!ObjectStringConverter methodsFor: 'accessing' stamp: ''!
objectClass: aClass
	"Set the class of object we are dealing with."

	objectClass := aClass! !

!ObjectStringConverter class methodsFor: 'instance creation' stamp: ''!
forClass: aClass
	"Answer a new instance of the receiver that converts to and from
	the given class of object and a string."

	^self new objectClass: aClass! !

!ObjectTest commentStamp: ''!
SUnit tests for objects!
!ObjectTest methodsFor: 'tests - printing' stamp: ''!
testDisplayString

	self assert: Object new displayString equals: 'an Object'! !

!ObjectTest methodsFor: 'tests - printing' stamp: ''!
testPrintLimitedString

	| actual |
	actual := Object new printStringLimitedTo: 4.
	self assert: actual equals: 'an O...etc...'! !

!ObjectTest methodsFor: 'tests' stamp: ''!
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 equals: 100 @ 100.
	self assert: pt3 identicalTo: pt2.
	self assert: pt1 equals: 100 @ 100! !

!ObjectTest methodsFor: 'tests - printing' stamp: ''!
testDisplayStringLimitedString

	| actual |
	actual := Object new displayStringLimitedTo: 4.
	self assert: actual equals: 'an O...etc...'! !

!ObjectTest methodsFor: 'tests - introspection' stamp: ''!
testReadSlotNamed
	self assert: (5 @ 3 readSlotNamed: #x) equals: 5! !

!ObjectTest methodsFor: 'tests' stamp: ''!
testAs
	| coll1 coll2 |
	coll1 := {1 . 2 . 3}.
	coll2 := coll1 as: OrderedCollection.

	self assert: coll2 equals: (OrderedCollection with: 1 with: 2 with: 3).
	self deny: coll1 identicalTo: coll2.

	"If the object has the right type, do nothing."
	coll2 := coll1 as: Array.
	self assert: coll1 identicalTo: coll2! !

!ObjectTest methodsFor: 'tests - introspection' stamp: ''!
testWriteSlotNamedValue
	| object |
	object := 5 @ 6.

	self assert: (object writeSlotNamed: #x value: 7) equals: 7.
	self assert: object equals: 7 @ 6! !

!ObjectTest methodsFor: 'tests' stamp: ''!
testCaseOfOtherwise
	| temp |
	"Test for Value"
	temp := #case1 
		caseOf: {
			[#case1]->[ 1 ].
 			[#case2]->[ 2 ] }
		otherwise: [ 3 ].
	self assert: temp equals: 1.
	
	temp := #case2
		caseOf: {
			[#case1]->[ 1 ].
 			[#case2]->[ 2 ] }
		otherwise: [ 3 ].
	self assert: temp equals: 2.
	
	temp := #case3 
		caseOf: {
			[#case1]->[ 1 ].
 			[#case2]->[ 2 ] }
		otherwise: [ 3 ].
	self assert: temp equals: 3.
	
	"Disabled due to bootrap not using Pharo9
	temp := #case4
		caseOf: { }
		otherwise: [ 3 ].
	self assert: temp equals: 3."
	
	"Test Effect"
	#case1 
		caseOf: {
			[#case1]->[ temp := 1 ].
 			[#case2]->[ temp := 2 ] }
		otherwise: [ temp := 3 ].
	self assert: temp equals: 1.
	
	#case2
		caseOf: {
			[#case1]->[ temp := 1 ].
 			[#case2]->[ temp := 2 ] }
		otherwise: [ temp := 3 ].
	self assert: temp equals: 2.
	
	#case3 
		caseOf: {
			[#case1]->[ temp := 1 ].
 			[#case2]->[ temp := 2 ] }
		otherwise: [ temp := 3 ].
	self assert: temp equals: 3! !

!ObjectTest methodsFor: 'tests' stamp: ''!
testInstVarNamed
	| obj |
	obj := ObjectMockForTest new.
	self assert: (obj instVarNamed: 'variable') isNil.
	obj variable: 1.
	self assert: (obj instVarNamed: 'variable') equals: 1.
	self shouldnt: [ obj instVarNamed: 'variable' ] raise: InstanceVariableNotFound.
	self should: [ obj instVarNamed: 'timoleon' ] raise: InstanceVariableNotFound.
	self
		assert:
			([ obj instVarNamed: 'timoleon' ]
				on: InstanceVariableNotFound
				do: [ :ex | ex instVarName ])
		equals: 'timoleon'! !

!ObjectTest methodsFor: 'tests - introspection' stamp: ''!
testWriteSlotValue
	| object |
	object := 5 @ 6.

	self assert: (object writeSlot: (Point slotNamed: #x) value: 7) equals: 7.
	self assert: object equals: 7 @ 6! !

!ObjectTest methodsFor: 'tests - write barrier' stamp: ''!
testBeRecursivelyWritableObject

	| assoc array |
	assoc := 1 -> (1 -> 2).
	assoc beRecursivelyReadOnlyObject.
	self should: [ assoc key: 2 ] raise: ModificationForbidden.
	self should: [ assoc value key: 2 ] raise: ModificationForbidden.
	assoc beRecursivelyWritableObject.
	assoc key: 2.
	assoc value key: 2.
	self assert: assoc key equals: 2.
	self assert: assoc value key equals: 2.
	
	array := Array with: 1 with: (Array with:1 with: 2).
	array beRecursivelyReadOnlyObject.
	self should: [ array at: 1 put: 2 ] raise: ModificationForbidden.
	self should: [ array second  at: 1 put: 2 ] raise: ModificationForbidden.
	array beRecursivelyWritableObject.
	array at: 1 put: 2.
	array second at: 1 put: 2.
	self assert: array first equals: 2.
	self assert: array second first equals: 2.! !

!ObjectTest methodsFor: 'tests - write barrier' stamp: ''!
testBeReadOnlyLiteral
	self assert: String new beReadOnlyLiteral isReadOnlyObject.
	self deny: Object new beReadOnlyLiteral isReadOnlyObject! !

!ObjectTest methodsFor: 'tests - introspection' stamp: ''!
testReadSlot
	self assert: (5 @ 3 readSlot: (Point slotNamed: #x)) equals: 5! !

!ObjectTest methodsFor: 'tests' stamp: ''!
testInstVarNamedPut
	| obj |
	obj := ObjectMockForTest new.
	self assert: (obj instVarNamed: 'variable') isNil.
	obj instVarNamed: 'variable' put: 1.
	self assert: (obj instVarNamed: 'variable') equals: 1.
	self shouldnt: [ obj instVarNamed: 'variable' put: 1 ] raise: InstanceVariableNotFound.
	self should: [ obj instVarNamed: 'timoleon' put: 1 ] raise: InstanceVariableNotFound! !

!ObjectTest methodsFor: 'tests' stamp: ''!
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 equals: 100 @ 100.
	self assert: pt3 equals: 0 @ 0.
	self assert: pt1 equals: 100 @ 100! !

!ObjectTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Object! !

!ObjectTest methodsFor: 'tests - write barrier' stamp: ''!
testBeRecursivelyReadOnlyObject

	| assoc array |
	assoc := 1 -> (1 -> 2).
	assoc beRecursivelyReadOnlyObject.
	self should: [ assoc key: 2 ] raise: ModificationForbidden.
	self should: [ assoc value key: 2 ] raise: ModificationForbidden.
	
	array := Array with: 1 with: (Array with:1 with: 2).
	array beRecursivelyReadOnlyObject.
	self should: [ array at: 1 put: 2 ] raise: ModificationForbidden.
	self should: [ array second  at: 1 put: 2 ] raise: ModificationForbidden.! !

!ObjectTest methodsFor: 'tests' stamp: ''!
testCaseOf
	| temp |
	
	"Test for Value"
	temp := #case1 caseOf: {		
 		[#case1]->[ 1 ].		
  		[#case2]->[ 2 ] }.		
 	self assert: temp equals: 1.		

  	temp := #case2 caseOf: {		
 		[#case1]->[ 1 ].		
  		[#case2]->[ 2 ] }.		
 	self assert: temp equals: 2.		

  	self should: [ 		
 		temp := #case3 caseOf: {		
 			[#case1]->[ 1 ].		
  			[#case2]->[ 2 ] }		
 		] raise: Error.
	
	"Test for effect"
	#case1 caseOf: {
		[#case1]->[ temp := 1 ].
 		[#case2]->[ temp := 2 ] }.
	self assert: temp equals: 1.
	
	#case2 caseOf: {
		[#case1]->[ temp := 1 ].
 		[#case2]->[ temp := 2 ] }.
	self assert: temp equals: 2.
	
	self should: [ 
		#case3 caseOf: {
			[#case1]->[ 1 ].
 			[#case2]->[ 2 ] }
		] raise: Error! !

!ObjectTest methodsFor: 'tests - printing' stamp: ''!
testPrintString

	self assert: Object new printString equals: 'an Object'! !

!ObjectWithPrintingRaisingHalt methodsFor: 'printing' stamp: ''!
printOn: aStream

	<haltOrBreakpointForTesting>
	^ self halt! !

!ObjectWithPrintingRaisingHaltTest methodsFor: 'tests' stamp: ''!
testInspectingObjectWithPrintOnWithHaltOpenInspector
	"Make sure that inspecting an object with a broken printOn: does not produce an endless loop.
	"
	
	| openInspectors inspectedObject |
	StInspector allInstances select: [ :e | e window isOpen ] 
					thenDo: [ :each | each window close ].

	inspectedObject := ObjectWithPrintingRaisingHalt new.
	"We are using halt in printOn: because halt is an exception (not an error).
	The problem was that protecting with onErrorDo: does not catch all exception in particular 
	Halt. And catching Exception in general is not possible else we could break on any printOn: method 
	in the system."
	
	inspectedObject inspect.

	openInspectors := StInspector allInstances select: [ :e | 
		                  e window isOpen ].

	self assert: openInspectors size equals: 1.

	self
		assert: openInspectors first model inspectedObject
		equals: inspectedObject.

	StInspector allInstances do: [ :each | each delete ].! !

!ObjectWithSettableHash commentStamp: ''!
Used to create intentional hash collisions in tests, to test that collision handling is done correctly.!
!ObjectWithSettableHash methodsFor: 'initialization' stamp: ''!
initialize

	"Make sure hash answers a SmallInteger, even if we haven't set it yet."

	super initialize.
	hash := 0! !

!ObjectWithSettableHash methodsFor: 'comparing' stamp: ''!
hash

	^ hash! !

!ObjectWithSettableHash methodsFor: 'accessing' stamp: ''!
hash: anObject

	hash := anObject! !

!ObjectsAsMethodsExample commentStamp: ''!
Example for an object that is installed as a compiled method. The VM calls run:with:in:!
!ObjectsAsMethodsExample methodsFor: 'examples' stamp: ''!
add: a with: b
	^a + b! !

!ObjectsAsMethodsExample methodsFor: 'evaluation' stamp: ''!
run: oldSelector with: arguments in: aReceiver
	^self perform: oldSelector withArguments: arguments! !

!ObjectsAsMethodsExample methodsFor: 'examples' stamp: ''!
answer42
	^42! !

!ObjectsAsMethodsTest methodsFor: 'running' stamp: ''!
tearDown
	SystemAnnouncer uniqueInstance suspendAllWhile: [
		self class removeSelector: #add:with:.
		self class removeSelector: #answer42.
		self class removeSelector: #foo ].
	super tearDown! !

!ObjectsAsMethodsTest methodsFor: 'testing' stamp: ''!
testAddNumbers
	self assert: (self add: 3 with: 4) equals: 7.
	self assert: (self perform: #add:with: withArguments: #(3 4)) equals: 7! !

!ObjectsAsMethodsTest methodsFor: 'testing' stamp: ''!
testDNU 

	self should: [self foo] raise: MessageNotUnderstood! !

!ObjectsAsMethodsTest methodsFor: 'testing' stamp: ''!
testAnswer42
	self assert: self answer42 equals: 42! !

!ObjectsAsMethodsTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	SystemAnnouncer uniqueInstance suspendAllWhile: [
		self class addSelector: #add:with: withMethod: ObjectsAsMethodsExample new.
		self class addSelector: #answer42 withMethod: ObjectsAsMethodsExample new.
		self class addSelector: #foo withMethod: AbstractObjectsAsMethod new ]! !

!ObservablePoint commentStamp: ''!
I am a mock point used to test observable properties. I have an observable property x and a non-observable property y.

I use TObservable that has methods to ease the usage of my observable properties.!
!ObservablePoint methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!ObservablePoint methodsFor: 'accessing' stamp: ''!
xReturn: anInteger 
	^x := anInteger! !

!ObservablePoint methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!ObservablePoint methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self class initializeSlots: self.! !

!ObservablePoint methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!ObservablePoint methodsFor: 'accessing' stamp: ''!
y: anInteger 
	y := anInteger! !

!ObservablePoint methodsFor: 'accessing' stamp: ''!
x
	^ x! !

!ObservablePoint methodsFor: 'accessing' stamp: ''!
x: anInteger 
	x := anInteger! !

!ObservablePoint methodsFor: 'accessing' stamp: ''!
y
	^ y! !

!ObservablePoint methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!ObservablePoint class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ObservablePoint class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ObservablePoint class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ObservablePoint class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ObservablePoint class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ObservablePoint class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ObservablePoint class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ObservablePoint class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ObservablePoint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ObservablePoint class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ObservablePoint class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ObservablePoint class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ObservablePoint class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ObservablePoint class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ObservablePoint class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ObservablePoint class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ObservablePoint class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ObservablePoint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ObservablePoint class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ObservablePoint class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ObservablePoint class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ObservablePoint class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ObservablePoint class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ObservablePoint class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ObservablePoint class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ObservablePoint class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ObservablePoint class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ObservablePoint class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ObservablePoint class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ObservableSlot commentStamp: ''!
I am a slot allowing users to register behavior to execute when my value change. 

The classes using me should use TObservable alongside with me. This trait will give them methods to interact with me.

I am able to prevent infinit loop by locking the executions of the actions I store while they are executed. This is useful if two observable slots update each other during their registered actions.

Public API and Key Messages
--------------------

My users will not interact directly with me but via TObservable.
Check the class comment of this trait for more information.

Examples
--------------------

	Object subclass: #ObservablePoint
		uses: TObservable
		slots: { #x => ObservableSlot. #y }
		classVariables: {  }
		package: 'VariablesLibrary-Tests-Observable'
 
Internal Representation and Key Implementation Points.
--------------------

	I am wrapping a ObservableValueHolder in order to store the content of the variable and to register the actions to execute when it changes.!
!ObservableSlot methodsFor: 'testing' stamp: ''!
isObservableSlot
	
	^ true! !

!ObservableSlot methodsFor: 'meta-object-protocol' stamp: ''!
rawRead: anObject
	^ super read: anObject! !

!ObservableSlot methodsFor: 'meta-object-protocol' stamp: ''!
wantsInitialization
	^ true! !

!ObservableSlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	^ (self rawRead: anObject) value! !

!ObservableSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
	(self rawRead: anObject) ifNotNil: [ :v | v value: aValue ].
	^ aValue! !

!ObservableSlot methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	"Push the value holder into the stack"
	aMethodBuilder pushInstVar: index.
	aMethodBuilder send: #value! !

!ObservableSlot methodsFor: 'code generation' stamp: ''!
emitStore: aMethodBuilder
	"generate bytecode for 'varName value: <stackTop>', make sure to preserve the stackTop"

	| temp |
	temp := '0slotTempForStackManipulation'.	
	"We pop the value from the stack into a temp to push it back in the right order"
	aMethodBuilder addTemp: temp.
	aMethodBuilder storeTemp: temp.

	"Push the value holder into the stack, then the value again, then send"
	aMethodBuilder pushInstVar: index.
	aMethodBuilder pushTemp: temp.
	aMethodBuilder send: #value:.
	"we have to return the value, not the valueHolder"
	aMethodBuilder popTop! !

!ObservableSlot methodsFor: 'initialization' stamp: ''!
initialize: anObject
	super write: ObservableValueHolder new to: anObject! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testObservableSlotAssignReturnsValue
	"When assigning to a Observable Slot, the return value should be the value"
	self assert: (point xReturn: 299) equals: 299
! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testSubscribeToExistentNonObservablePropertyRaisesError

	self
		should: [
			point
				property: #y
				whenChangedDo: [ self fail: 'This event shouldnt have been subscribed at all' ] ]
		raise: NonObservableSlotError! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testExplicitNotificationRaisesEventOnlyOnce
	| count |
	count := 0.
	point property: #x whenChangedDo: [ count := count + 1 ].

	point notifyPropertyChanged: #x.

	self assert: count equals: 1! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testExplicitNotifyUnexistentPropertyChangedRaisesError
	self should: [ point notifyPropertyChanged: #z ] raise: SlotNotFound! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testObservableSlotWorksAsNormalSlot
	point x: 17.
	point y: 299.

	self assert: point x equals: 17.
	self assert: point y equals: 299! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testSubscribeBlockWithoutParametersIsCalled
	| called |
	called := false.
	point property: #x whenChangedDo: [ called := true ].

	point x: 17.

	self assert: called! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testIsObservableSlot

	self assert: (point class slotNamed: 'x') isObservableSlot! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testSubscribeToUnexistentPropertyRaisesError

	self
		should: [
			point
				property: #z
				whenChangedDo: [ self fail: 'This event shouldnt have been subscribed at all' ] ]
		raise: SlotNotFound! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testSubscribeToChangeRaisesEventWithNewValue
	| newValue |
	point property: #x whenChangedDo: [ :new | newValue := new ].

	point x: 17.

	self assert: newValue equals: 17! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testChangeInInstanceVariableRaisesEventOnlyOnce
	| count |
	count := 0.
	point property: #x whenChangedDo: [ count := count + 1 ].

	point x: 17.

	self assert: count equals: 1! !

!ObservableSlotTest methodsFor: 'tests' stamp: ''!
testExplicitNotificationRaisesEventWithNewValue
	| newValue |
	point x: 17.
	point property: #x whenChangedDo: [ :new | newValue := new ].

	point notifyPropertyChanged: #x.

	self assert: newValue equals: 17! !

!ObservableSlotTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	point := ObservablePoint new! !

!ObservableValueHolder commentStamp: ''!
I am a class holding any object. Each time the object changes, I execute a list of commands the user might have register in me.

I am used as an internal mecanism of the ObservableSlot. The slot contains one of my instance and is giving me the blocks to execute when the value change. 

I SHOULD NOT BE USED DIRECTLY BUT VIA AN OBSERVABLE SLOT.
 
In addition, infinite loops of propagation are prevented.

Use case: you have two lists A, and B, and you want to keep their selection synchronised. So when A selection changes, you set B selection. But since B selection changes, you set A selection, and so on… 

This case is prevented by the use of a `lock` variable.!
!ObservableValueHolder methodsFor: 'accessing' stamp: ''!
value: anObject
	"Handle circular references as explained in the class comment"
	lock ifTrue: [ ^ self ].
	
	lock := true.
	
	[ | oldValue |
	oldValue := value.
	value := anObject.
	self valueChanged: oldValue ]
		ensure: [ lock := false ]! !

!ObservableValueHolder methodsFor: 'transfert' stamp: ''!
transferSubscriptionsTo: aSpValueHolder
	aSpValueHolder subscriptions: subscriptions! !

!ObservableValueHolder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	lock := false.
	subscriptions := OrderedCollection new! !

!ObservableValueHolder methodsFor: 'accessing' stamp: ''!
rawValue: aValue
	value := aValue! !

!ObservableValueHolder methodsFor: '*Spec2-Core' stamp: ''!
unsubscribe: anObject 

	subscriptions := subscriptions reject: [ :each | each receiver = anObject ].! !

!ObservableValueHolder methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream 
		nextPutAll: '[ '; 
		print: self value;
		nextPutAll: ' ]'! !

!ObservableValueHolder methodsFor: 'accessing' stamp: ''!
subscriptions: anObject
	subscriptions := anObject! !

!ObservableValueHolder methodsFor: 'enumerating' stamp: ''!
whenChangedDo: aBlock
	subscriptions add: aBlock! !

!ObservableValueHolder methodsFor: 'evaluating' stamp: ''!
value
	^ value! !

!ObservableValueHolder methodsFor: 'accessing' stamp: ''!
valueChanged
	self valueChanged: nil! !

!ObservableValueHolder methodsFor: 'accessing' stamp: ''!
valueChanged: oldValue
	subscriptions do: [ :block | block cull: self value cull: oldValue ]! !

!ObservableValueHolder methodsFor: 'accessing' stamp: ''!
subscriptions
	^ subscriptions! !

!ObservableValueHolder class methodsFor: 'instance creation' stamp: ''!
value: contents

	^ self new
		rawValue: contents;
		yourself! !

!ObsoleteTest commentStamp: ''!
Example class for ClassTest!
!ObsoleteTest methodsFor: 'running' stamp: ''!
tearDown

	classFactory cleanUp.
	Smalltalk fixObsoleteReferences.
	super tearDown	! !

!ObsoleteTest methodsFor: 'tests' stamp: ''!
testClassObsolete
	| aClass |
	aClass := classFactory newClass.
	
	self deny: aClass isObsolete.
	self deny: aClass class isObsolete.
	aClass removeFromSystem.
	self assert: aClass isObsolete.
	self assert: aClass class isObsolete.
	self assert: (aClass originalName beginsWith: #ClassForTestToBeDeleted).! !

!ObsoleteTest methodsFor: 'tests' stamp: ''!
testTraitObsolete
	| aClass aTrait |
	aTrait := classFactory newTrait.
	aClass := classFactory newClassUsing: aTrait.
 
	self deny: aTrait isObsolete.
	aTrait removeFromSystem.
	self assert: aTrait isObsolete.
	self deny: aClass isObsolete
! !

!ObsoleteTest methodsFor: 'tests' stamp: ''!
testFixObsoleteSharedPools
	| poolClass obsoletePoolName testClass preFixObsoleteClassNames postFixObsoleteClassNames |
	poolClass := classFactory newClass.	"provides unique name over time via class variable counter"
	testClass := classFactory
		newSubclassOf: classFactory defaultSuperclass
		uses: {}
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: poolClass name asString
		category: classFactory defaultCategory.
	classFactory deleteClass: poolClass.
	obsoletePoolName := poolClass name.
	poolClass := nil.
	3 timesRepeat: [ Smalltalk garbageCollect ].

	preFixObsoleteClassNames := SystemNavigation default obsoleteClasses collect: [:each | each name].
	self assert: (preFixObsoleteClassNames includes: obsoletePoolName).
	self assert: testClass sharedPoolNames size equals: 1.
	self assert: (testClass sharedPoolNames includes: obsoletePoolName).
	self assert: (testClass sharedPoolsString beginsWith: 'AnObsolete').

	Smalltalk fixObsoleteSharedPools.

	postFixObsoleteClassNames := SystemNavigation default obsoleteClasses collect: #name.
	self deny: (postFixObsoleteClassNames includes: obsoletePoolName).
	self assertEmpty: testClass sharedPoolNames.
	self assertEmpty: testClass sharedPoolsString! !

!ObsoleteTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	classFactory := ClassFactoryForTestCase new! !

!ObsoleteTest class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit 

	^ 30 seconds! !

!OkCancelToolbar commentStamp: ''!
An OkCancelToolbar is a model for a basic Ok-Cancel toolbar!
!OkCancelToolbar methodsFor: 'api' stamp: ''!
cancel

	self cancelled: true! !

!OkCancelToolbar methodsFor: 'api' stamp: ''!
performCancelAction

	^ cancelAction value value == false
		ifFalse: [ 
			cancelled value: true.
			owner ifNil: [ self delete ] ifNotNil: [ owner delete ] ]! !

!OkCancelToolbar methodsFor: 'initialization' stamp: ''!
initialize

	cancelled := false asValueHolder.
	cancelAction := [ true ] asValueHolder.
	super initialize.! !

!OkCancelToolbar methodsFor: 'initialization' stamp: ''!
initializeWidgets

	super initializeWidgets.
	cancelButton := self newButton.

	self registerCancelButtonEvents.
	self focusOrder
		add: cancelButton! !

!OkCancelToolbar methodsFor: 'accessing' stamp: ''!
cancelButton

	^ cancelButton! !

!OkCancelToolbar methodsFor: 'api' stamp: ''!
triggerCancelAction

	self performCancelAction! !

!OkCancelToolbar methodsFor: 'api' stamp: ''!
cancelAction

	^ cancelAction value! !

!OkCancelToolbar methodsFor: 'api' stamp: ''!
cancelAction: aBlock

	^ cancelAction value: aBlock! !

!OkCancelToolbar methodsFor: 'api' stamp: ''!
cancelled: aBoolean

	cancelled value: aBoolean! !

!OkCancelToolbar methodsFor: 'api' stamp: ''!
cancelled

	^ cancelled value! !

!OkCancelToolbar methodsFor: 'initialization' stamp: ''!
registerCancelButtonEvents

	cancelButton 
		label: 'Cancel';
		enabled: true;
		state: false! !

!OkCancelToolbar methodsFor: 'initialization' stamp: ''!
initializePresenter

	super initializePresenter.
	cancelButton action: [ self performCancelAction ]! !

!OkCancelToolbar class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ SpecLayout composed
		add: #okButton origin: 1@0 corner: 1@1 offsetOrigin: (2*(self buttonWidth negated))@0 offsetCorner: (self buttonWidth negated)@0;
		add: #cancelButton origin: 1@0 corner: 1@1 offsetOrigin: (self buttonWidth negated)@0 offsetCorner: 0@0;
		send: #vShrinkWrap;
		yourself! !

!OkCancelToolbar class methodsFor: 'specs' stamp: ''!
title

	^ 'Ok Cancel'! !

!OkToolbar commentStamp: ''!
An OkCancelToolbar is a model for a basic Ok toolbar!
!OkToolbar methodsFor: 'api' stamp: ''!
cancel
	
	owner 
		ifNil: [ self delete ] 
		ifNotNil: [ owner delete ]! !

!OkToolbar methodsFor: 'private' stamp: ''!
addAll: aWindow  withSpec: aSpec

	aWindow
		addMorph: (self buildWithSpec: aSpec)
		fullFrame: ((0@0 corner: 1@0) asSpecLayoutFrame bottomOffset: 30).! !

!OkToolbar methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	okAction := [ true ] asValueHolder.! !

!OkToolbar methodsFor: 'initialization' stamp: ''!
registerOkButtonEvents

	okButton 
		label: 'Ok';
		enabled: true;
		state: false! !

!OkToolbar methodsFor: 'initialization' stamp: ''!
initializeWidgets
	
	
	okButton := self newButton.
	self registerOkButtonEvents.
	
	self focusOrder
		add: okButton! !

!OkToolbar methodsFor: 'api' stamp: ''!
triggerCancelAction
	
	self cancel! !

!OkToolbar methodsFor: 'api' stamp: ''!
okAction

	^ okAction value! !

!OkToolbar methodsFor: 'accessing' stamp: ''!
okButton

	^ okButton! !

!OkToolbar methodsFor: 'private' stamp: ''!
okActionBlock

	^ [ okAction value value == false
		ifFalse: [ owner 
			ifNil: [ self delete ] 
			ifNotNil: [ owner delete ] ] ]! !

!OkToolbar methodsFor: 'api' stamp: ''!
okAction: aBlock

	^ okAction value: aBlock! !

!OkToolbar methodsFor: 'api' stamp: ''!
triggerOkAction

	self okActionBlock value! !

!OkToolbar methodsFor: 'initialization' stamp: ''!
initializePresenter

	okButton action: self okActionBlock! !

!OkToolbar class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ SpecLayout composed
		add: #okButton origin: 1@0 corner: 1@1 offsetOrigin: (self buttonWidth negated)@0 offsetCorner: 0@0;
		send: #vShrinkWrap;
		yourself! !

!OkToolbar class methodsFor: 'specs' stamp: ''!
title

	^ 'Ok Toolbar'! !

!OldClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testSystemAnnouncerClass
	
	self 
		assert: (self forClass: SystemAnnouncer class) 
		equals: 'SystemAnnouncer class
	instanceVariableNames: ''announcer'''! !

!OldClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testArrayedCollectionWithPoolDictionary

	self assert: (self forClass: ExampleForTestWithSharedPool) equals: 'ArrayedCollection subclass: #ExampleForTestWithSharedPool
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''ChronologyConstants''
	package: ''Kernel-Tests-Classes'''! !

!OldClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testByteString

	self 
		assert: (self forClass: ByteString) 
		equals: 'String variableByteSubclass: #ByteString
	instanceVariableNames: ''''
	classVariableNames: ''NonAsciiMap''
	package: ''Collections-Strings-Base'''! !

!OldClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testMetaclassClass
	
	self 
		assert: (self forClass: Metaclass class) 
		equals: 'Metaclass class
	instanceVariableNames: '''''! !

!OldClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testPoint

	self 
		assert: (self forClass: Point) 
		equals: 'Object subclass: #Point
	instanceVariableNames: ''x y''
	classVariableNames: ''''
	package: ''Kernel-BasicObjects'''! !

!OldClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testProtoObject
	
	self assert: (self forClass: ProtoObject) equals: 'ProtoObject subclass: #ProtoObject
	instanceVariableNames: ''''
	classVariableNames: ''''
	package: ''Kernel-Objects''.
ProtoObject superclass: nil'! !

!OldClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testArray

	self 
		assert: (self forClass: Array) 
		equals: 'ArrayedCollection variableSubclass: #Array
	instanceVariableNames: ''''
	classVariableNames: ''''
	package: ''Collections-Sequenceable-Base'''! !

!OldClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testMetaclass
	
	self assert: (self forClass: Metaclass) equals:  'ClassDescription subclass: #Metaclass
	instanceVariableNames: ''thisClass''
	classVariableNames: ''''
	package: ''Kernel-Classes'''! !

!OldClassDefinitionPrinterTest methodsFor: 'helpers' stamp: ''!
forClass: aClass
	^ (OldPharoClassDefinitionPrinter for: aClass) definitionString! !

!OldClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testClassSideDoesNotShowPackage

	self assert: (self forClass: ContextTest class) equals: 'ContextTest class
	instanceVariableNames: '''''! !

!OldClassDefinitionPrinterTest methodsFor: 'tests - classes' stamp: ''!
testChronologyConstants

	self
		assert: (self forClass: ChronologyConstants)
		equals: 'SharedPool subclass: #ChronologyConstants
	instanceVariableNames: ''''
	classVariableNames: ''DayNames DaysInMonth HoursInDay MicrosecondsInDay MinutesInHour MonthNames NanosInMillisecond NanosInSecond SecondsInDay SecondsInHour SecondsInMinute SqueakEpoch''
	package: ''Kernel-Chronology'''! !

!OldClassDefinitionPrinterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	ClassDefinitionPrinter showFluidClassDefinition: false! !

!OldPharoClassDefinitionPrinter methodsFor: 'template' stamp: ''!
compactClassDefinitionTemplateInPackage: aString
	"there is not compact version..."

	^ self classDefinitionTemplateInPackage: aString! !

!OldPharoClassDefinitionPrinter methodsFor: 'internal' stamp: ''!
basicClassDefinitionString

	"Pay attention this definition is fragile in presence of complex slots. Use the public API i.e., classDefinitionString"

	| stream |
	stream := (String new: 800) writeStream.
	forClass superclass
		ifNotNil: [ stream nextPutAll: forClass superclass name ]
		ifNil: [ stream nextPutAll: 'ProtoObject' ].
	stream
		nextPutAll: forClass kindOfSubclass;
		store: forClass name.
	self traitCompositionOn: stream.
	self instanceVariablesOn: stream.
	self classVariablesOn: stream.
	self poolOn: stream.
	self packageOn: stream.
	forClass superclass ifNil: [ 
		stream
			nextPutAll: '.';
			cr.
		stream nextPutAll: forClass name.
		stream
			space;
			nextPutAll: 'superclass: nil' ].
	^ stream contents! !

!OldPharoClassDefinitionPrinter methodsFor: 'public API' stamp: ''!
expandedDefinitionString
	"We do not support expanded on old Pharo syntax so we shortcut the double dispatch call."
	^ self definitionString! !

!OldPharoClassDefinitionPrinter methodsFor: 'low-level elements' stamp: ''!
packageOn: stream

	stream
		crtab;
		nextPutAll: 'package: ';
		store: forClass category asString! !

!OldPharoClassDefinitionPrinter methodsFor: 'internal' stamp: ''!
basicMetaclassDefinitionString

	"Pay attention this definition is fragile in presence of complex slots. Use the public API i.e., classDefinitionString"

	^ String streamContents: [ :stream | 
		  stream print: forClass.
		  self instanceVariablesOn: stream ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'internal' stamp: ''!
basicTraitDefinitionString

	"Pay attention this definition is fragile in presence of complex slots. Use the public API i.e., classDefinitionString"

	forClass instanceSide name == #Trait ifTrue: [ 
		^ self classDefinitionString ].

	^ String streamContents: [ :s | 
		  s
			  nextPutAll: 'Trait named: ';
			  nextPutAll: forClass name printString.
		  self traitCompositionOn: s.
		  self instanceVariablesOn: s.
		  self packageOn: s ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'low-level elements' stamp: ''!
instanceVariablesOn: stream

	stream
		crtab;
		nextPutAll: 'instanceVariableNames: '''.
	forClass instanceVariablesOn: stream.
	stream nextPut: $'! !

!OldPharoClassDefinitionPrinter methodsFor: '*ClassParser' stamp: ''!
classDefinitionParserClass

	^ CDClassDefinitionParser! !

!OldPharoClassDefinitionPrinter methodsFor: 'template' stamp: ''!
classDefinitionTemplateInPackage: aString

	^ String streamContents: [ :s |
			s nextPutAll: 'Object subclass: #MyClass' ; crtab.
			s nextPutAll: 'instanceVariableNames: '''' '; crtab. 
			s nextPutAll: 'classVariableNames: '''''; crtab.
			s nextPutAll: 'package: ''', aString, '''' ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'public API' stamp: ''!
traitDefinitionString 

	^ forClass needsSlotClassDefinition 
		ifTrue: [ (ClassDefinitionPrinter fluid for: forClass) traitDefinitionString ]
		ifFalse: [ self basicTraitDefinitionString ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'public API' stamp: ''!
metaclassDefinitionString 

	^ forClass needsSlotClassDefinition 
		ifTrue: [ (ClassDefinitionPrinter fluid for: forClass) metaclassDefinitionString ]
		ifFalse: [ self basicMetaclassDefinitionString ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'public API' stamp: ''!
traitedMetaclassDefinitionString 

	^ forClass needsSlotClassDefinition 
		ifTrue: [ (ClassDefinitionPrinter fluid for: forClass) traitedMetaclassDefinitionString ]
		ifFalse: [ self basicTraitedMetaclassDefinitionString ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'template' stamp: ''!
testClassDefinitionTemplateInPackage: aString

	^ String streamContents: [ :s |
			s nextPutAll: 'TestCase subclass: #MyTest' ; crtab.
			s nextPutAll: 'instanceVariableNames: '''' '; crtab. 
			s nextPutAll: 'classVariableNames: '''''; crtab.
			s nextPutAll: 'package: ''', aString, '''' ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'template' stamp: ''!
compactTraitDefinitionTemplateInPackage: aString

	^ self traitDefinitionTemplateInPackage: aString! !

!OldPharoClassDefinitionPrinter methodsFor: 'low-level elements' stamp: ''!
poolOn: stream

	| poolString |
	poolString := forClass sharedPoolsString.
	poolString = '' ifFalse: [ 
		stream
			crtab;
			nextPutAll: 'poolDictionaries: ';
			store: poolString ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'template' stamp: ''!
traitDefinitionTemplateInPackage: aString

	^ String streamContents: [ :s |
			s nextPutAll: 'Trait named: #TMyTraits
	 uses: {}
	 package: '''.
			s nextPutAll: aString; nextPut: $' ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'internal' stamp: ''!
basicTraitedMetaclassDefinitionString 

	^ String streamContents: [:strm |
			strm print: forClass.
			self traitCompositionOn: strm.
			self instanceVariablesOn: strm ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'low-level elements' stamp: ''!
classVariablesOn: stream

	stream
		crtab;
		nextPutAll: 'classVariableNames: '''.
	forClass classVariablesOn: stream.
	stream nextPut: $'! !

!OldPharoClassDefinitionPrinter methodsFor: 'public API' stamp: ''!
classDefinitionString

	^ forClass needsSlotClassDefinition 
		ifTrue: [ (ClassDefinitionPrinter fluid for: forClass) classDefinitionString ]
		ifFalse: [ self basicClassDefinitionString ]! !

!OldPharoClassDefinitionPrinter methodsFor: 'low-level elements' stamp: ''!
traitCompositionOn: stream

	forClass hasTraitComposition ifTrue: [ 
		stream
			crtab;
			nextPutAll: 'uses: ';
			nextPutAll: forClass traitCompositionString ]! !

!OldUnicodeInitializer class methodsFor: 'parsing' stamp: ''!
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 = '<control>' or: [ tokens last = '#UNDEFINED' ]) ifFalse: [
					mapping
						at: (hexReader value: tokens first)
						put: (hexReader value: tokens second) ] ] ].
	^ mapping ! !

!OldUnicodeInitializer class methodsFor: 'parsing' stamp: ''!
generateByteToUnicodeSpec: url
	"Return the formatted source code for an array mapping 
	the top 128 byte to unicode values from a Unicode.org url"
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-2.TXT'."

	| mapping |
	mapping := self parseUnicodeOrgSpec: url.  
	^ String streamContents: [ :stream |
		stream tab; << '"'; << self name; << ' generateByteToUnicodeSpec: '; print: url; << '"'; cr; cr; tab; << '^ #('.
		128 to: 255 do: [ :each | | unicode |
			each \\ 8 = 0 ifTrue: [ stream cr; tab ].
			(unicode := mapping at: each ifAbsent: [ nil ]) 
				ifNil: [ stream print: nil; space ]  
				ifNotNil: [ stream << '16r' << (unicode printPaddedWith: $0 to: 4 base: 16); space ] ].
		stream nextPut: $); cr ]! !

!OmAbstractReference commentStamp: ''!
I am the abstract superclass for references to entries.!
!OmAbstractReference methodsFor: 'testing' stamp: ''!
isNull
	^ false! !

!OmBlock commentStamp: ''!
I represent a portion of a .ombu file. I'm a collaborator of OmBlockFileStore.!
!OmBlock methodsFor: 'accessing' stamp: ''!
firstLocalNameAsInteger
	^ self firstEntryReference localName asInteger! !

!OmBlock methodsFor: 'accessing' stamp: ''!
endPosition
	^ endPosition! !

!OmBlock methodsFor: 'initialization' stamp: ''!
initializeWithStore: anOmBlockFileStore startPosition: aStartPosition endPosition: anEndPosition firstEntryReference: anOmReference

	self initialize.
	store := anOmBlockFileStore.
	startPosition := aStartPosition.
	endPosition := anEndPosition.
	firstEntryReference := anOmReference.! !

!OmBlock methodsFor: 'refreshing' stamp: ''!
checkIfMustRefreshBlock
	
	positions ifNil: [ self refresh ]! !

!OmBlock methodsFor: 'refreshing' stamp: ''!
refresh
	"Read all OmEntry instances that belong to my range of file positions"
	
	positions := store entryPositionsStartingAt: startPosition upTo: endPosition! !

!OmBlock methodsFor: 'accessing' stamp: ''!
startPosition
	^ startPosition! !

!OmBlock methodsFor: 'accessing' stamp: ''!
atLocalName: aString ifPresent: presentBlockClosure ifAbsent: absentBlockClosure

	| index |
	self checkIfMustRefreshBlock.

	index := aString asInteger - self firstLocalNameAsInteger + 1.
	
	^ index > positions size
		ifTrue: absentBlockClosure
		ifFalse: [
			presentBlockClosure value: (positions at: index) ]! !

!OmBlock methodsFor: 'accessing' stamp: ''!
store
	^ store! !

!OmBlock methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	
	aStream 
		nextPutAll: '(first entry: ';
		print: self firstLocalNameAsInteger;
		nextPutAll: ' positions: ';
		print: startPosition;
		nextPutAll: '..';
		print: endPosition;
		nextPut: $).! !

!OmBlock methodsFor: 'accessing' stamp: ''!
firstEntryReference
	^ firstEntryReference! !

!OmBlock methodsFor: 'accessing' stamp: ''!
lastLocalNameAsInteger

	self checkIfMustRefreshBlock.
	
	^ positions size + self firstLocalNameAsInteger - 1.! !

!OmBlock methodsFor: 'accessing' stamp: ''!
refreshIfNeededStartingAt: firstStreamPosition since: initialLocalName 

	positions isEmptyOrNil ifTrue: [ ^self ]. "Initial #refresh not yet done, so let things untouched."
	
	"Then, it's only partially loaded i.e. outdated."
	positions addAll: (store entryPositionsStartingAt: firstStreamPosition upTo: endPosition).! !

!OmBlock methodsFor: 'accessing' stamp: ''!
positions
	^ positions! !

!OmBlock class methodsFor: 'instance creation' stamp: ''!
store: anOmBlockFileStore startPosition: aStartPosition endPosition: anEndPosition firstEntryReference: anOmReference

	^ self basicNew
		initializeWithStore: anOmBlockFileStore
		startPosition: aStartPosition
		endPosition: anEndPosition
		firstEntryReference: anOmReference;
		yourself! !

!OmBlockFileStore commentStamp: ''!
I am a single-file store of entries. Each new entry is appended at the end. Entries are lazily read in blocks (represented by OmBlock) from file on demand.!
!OmBlockFileStore methodsFor: 'private' stamp: ''!
refreshEntryPositionsByLocalNameStartingAt: firstStreamPosition since: initialLocalName
	"AKA: Refresh blocks after new entries were written."

	| lastBlock |
	lastBlock := blocks last.

	"Update last block if necessary"
	firstStreamPosition < lastBlock endPosition ifTrue: [ 
		lastBlock refreshIfNeededStartingAt: firstStreamPosition since: initialLocalName ].

	"Add new blocks if necessary"
	lastStreamPosition > lastBlock endPosition ifTrue: [
		self readEntriesWith: [:readStream | self refreshNewBlocksFrom: readStream ] ].! !

!OmBlockFileStore methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	blocks := OrderedCollection with:
		(OmBlock
			store: self
			startPosition: 0
			endPosition: self blockSize - 1
			firstEntryReference: (self referenceToLocalName: '1')).! !

!OmBlockFileStore methodsFor: 'refreshing' stamp: ''!
refreshNewBlocksFrom: readStream

	| reader blockPosition blockFirstEntry |
	reader := self newEntryReader.
	reader stream: readStream.
	
	[	blockPosition := blocks size * self blockSize.
		blockPosition < readStream size ] whileTrue: [
			readStream position: blockPosition.
			reader nextEntryPositionIfFound: [:position | 
				readStream position: position.
				blockFirstEntry := reader nextEntry.
				blocks add: (OmBlock
					store: self
					startPosition: position
					endPosition: blockPosition + self blockSize - 1
					firstEntryReference: (self referenceTo: blockFirstEntry)).
				] ifNone: [ ^self "No more entries to add in a new block" ].
		]! !

!OmBlockFileStore methodsFor: 'accessing' stamp: ''!
entryPositionsStartingAt: startPosition upTo: endPosition

	self readEntriesWith: [:readStream |
		readStream position: startPosition.
		^self newEntryReader
			stream: readStream;
			entryPositionsUpTo: endPosition ]! !

!OmBlockFileStore methodsFor: 'accessing' stamp: ''!
readEntryForLocalName: aString ifPresent: presentBlockClosure ifAbsent: absentBlockClosure

	^ (self blockForLocalNameAsInteger: aString asInteger)
			atLocalName: aString
			ifPresent: [ :position |
				presentBlockClosure value: (self nextEntryFromPosition: position) ]
			ifAbsent: absentBlockClosure! !

!OmBlockFileStore methodsFor: 'refreshing' stamp: ''!
refresh
	self flush.

	self
		critical: [ mustRefresh := false.
			self initialize.
			self fileReference ifAbsent: [ ^ self ].
			self
				readEntriesWith: [ :readStream | 
					self refreshNewBlocksFrom: readStream.
					self refreshHeadReferenceAndEntryCountFrom: readStream ] ]! !

!OmBlockFileStore methodsFor: 'accessing' stamp: ''!
blockSize

	^  131072 "2 ** 17"! !

!OmBlockFileStore methodsFor: 'refreshing' stamp: ''!
refreshHeadReferenceAndEntryCountFrom: readStream

	entryCount := blocks last lastLocalNameAsInteger.
	headReference := self referenceToLocalName: entryCount asString.! !

!OmBlockFileStore methodsFor: 'private' stamp: ''!
blockForLocalNameAsInteger: anIndex
	
	blocks reverseDo: [:each | each firstLocalNameAsInteger <= anIndex ifTrue: [ ^each ] ].
	^ self error: 'block not found'! !

!OmBlockFileStoreTest methodsFor: 'initialization' stamp: ''!
setUpStore	

	^ OmBlockFileStore
		named: 'testingStore', UUID new asString36
		inDirectory: self directoryForTests ensureCreateDirectory! !

!OmBlockFileStoreTest methodsFor: 'tests' stamp: ''!
testMultibyteUnicodeCharacterCrossingTwoBlocks
	"Test fogbugz case 20112"
	
	| aWideString |
	aWideString := (String streamContents: [:stream |
		store blockSize timesRepeat: [ stream nextPut: (Character value: 266) ].
	 ]).
	store newEntry: (OmEntry content: aWideString).	
	store newEntry: (OmEntry content: aWideString).	

	"self shouldnt: [ "store flush" ] raise: OmFileStoreReadingError"! !

!OmBlockFileStoreTest methodsFor: 'initialization' stamp: ''!
setUpOtherStore

	^ OmBlockFileStore
		named: 'testingOtherStore', UUID new asString36
		inDirectory: self directoryForTests ensureCreateDirectory! !

!OmCurrentGlobalName commentStamp: ''!
I am a DynamicVariable that holds the globalName of a OmFileStore. I'm used during read and write operations. See references to my class name.!
!OmDeferrer commentStamp: ''!
I schedule and postpone a message send until the specified duration passed.!
!OmDeferrer methodsFor: 'accessing' stamp: ''!
duration: aDuration

	duration := aDuration! !

!OmDeferrer methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!OmDeferrer methodsFor: 'accessing' stamp: ''!
duration
	^ duration! !

!OmDeferrer methodsFor: 'initialization' stamp: ''!
initializeWithSelector: aSelector object: anObject duration: aDuration 
	
	self initialize.
	selector := aSelector.
	object := anObject.
	duration := aDuration.! !

!OmDeferrer methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!OmDeferrer methodsFor: 'accessing' stamp: ''!
object: anObject
	object := anObject! !

!OmDeferrer methodsFor: 'scheduling' stamp: ''!
schedule
	lastSchedule := DateAndTime now.

	process ifNil: [ 
		"Deferrer can be activated during tests which intercept any forked processes.
		To prevent it we should ensure here that message process is running out of tests environment"
		DefaultExecutionEnvironment beActiveDuring: [ self runMessageProcess ]]! !

!OmDeferrer methodsFor: 'scheduling' stamp: ''!
flush

	process ifNotNil: [
		"Execute deferred action and clean up"
		[ self sendMessage ] ensure: [ process := nil ] 
	].! !

!OmDeferrer methodsFor: 'private' stamp: ''!
sendMessage
	
	object perform: selector! !

!OmDeferrer methodsFor: 'accessing' stamp: ''!
object
	^ object! !

!OmDeferrer methodsFor: 'scheduling' stamp: ''!
runMessageProcess
	process := [ 
		"Loop until enough time passed since last #schedule"
		[ DateAndTime now < (lastSchedule + duration) ]
			whileTrue: [ duration wait ].
			
		"Execute deferred action (if not flushed before) and clean up"
		self flush.
	] fork! !

!OmDeferrer class methodsFor: 'instance creation' stamp: ''!
new

	^ self shouldNotImplement! !

!OmDeferrer class methodsFor: 'class initialization' stamp: ''!
initialize
	"
	self initialize
	"
	SessionManager default registerUserClassNamed: self name! !

!OmDeferrer class methodsFor: 'instance creation' stamp: ''!
send: selector to: object after: aDuration

	^ self basicNew
		initializeWithSelector: selector
		object: object
		duration: aDuration! !

!OmDeferrer class methodsFor: 'system startup' stamp: ''!
shutDown: quitting
	"Force my instances to flush before image quits"

	self allInstancesDo: [:each | each flush ].! !

!OmDeferrerTest commentStamp: ''!
An EpDeferrerTest is a test class for testing the behavior of OmDeferrer!
!OmDeferrerTest methodsFor: 'accessing' stamp: ''!
increase

	count := count + 1! !

!OmDeferrerTest methodsFor: 'tests' stamp: ''!
testExecuteWithoutDelay

	self skipOnPharoCITestingEnvironment.

	self count: 0.
	deferrer := OmDeferrer 
		send: #increase
		to: self
		after: 0 milliSeconds.

	deferrer schedule.

	"Just to document it needs an interruption"
	self assert: self count equals: 0.
	Processor yield.	
	self assert: self count equals: 1.! !

!OmDeferrerTest methodsFor: 'tests' stamp: ''!
testExecuteOnceAfterScheduling

	self skipOnPharoCITestingEnvironment.

	self count: 0.
	deferrer := OmDeferrer 
		send: #increase
		to: self
		after: 250 milliSeconds.

	deferrer schedule.
	(Delay forMilliseconds: 350) wait.
	
	self assert: self count equals: 1.! !

!OmDeferrerTest methodsFor: 'accessing' stamp: ''!
count: anInteger 

	count := anInteger! !

!OmDeferrerTest methodsFor: 'accessing' stamp: ''!
count

	^ count! !

!OmEntry commentStamp: ''!
I am a container for recording objects into a store. I also have tags for custom meta-information.!
!OmEntry methodsFor: 'accessing' stamp: ''!
tagAt: aKey

	^ self tags at: aKey! !

!OmEntry methodsFor: 'initialization' stamp: ''!
initializeWithContent: anObject
	self initialize.
	content := anObject.
	tags := Dictionary new.! !

!OmEntry methodsFor: 'testing' stamp: ''!
isEmpty
	^ false! !

!OmEntry methodsFor: 'comparing' stamp: ''!
= other
	^ other species = self species and: [ 
		other content = self content ]! !

!OmEntry methodsFor: 'comparing' stamp: ''!
hash
	^ self species hash bitXor: self content hash! !

!OmEntry methodsFor: 'accessing' stamp: ''!
content: anObject 
	content := anObject! !

!OmEntry methodsFor: 'accessing' stamp: ''!
tags
	^ tags! !

!OmEntry methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	content printOn: aStream.
	aStream nextPut: $).! !

!OmEntry methodsFor: 'accessing' stamp: ''!
content
	^ content! !

!OmEntry class methodsFor: 'instance creation' stamp: ''!
content: anObject
	^ self basicNew 
		initializeWithContent: anObject;
		yourself! !

!OmEntryReader commentStamp: ''!
I implement how to read entries from a stream.!
!OmEntryReader methodsFor: 'reading' stamp: ''!
entryPositionsDo: aBlock
	
	^ self subclassResponsibility! !

!OmEntryReader methodsFor: 'accessing' stamp: ''!
store
	^ store! !

!OmEntryReader methodsFor: 'accessing' stamp: ''!
stream: aReadStream

	stream := aReadStream! !

!OmEntryReader methodsFor: 'accessing' stamp: ''!
stream

	^ stream! !

!OmEntryReader methodsFor: 'initialization' stamp: ''!
initializeWithStore: aFileStore

	self initialize.
	store := aFileStore.! !

!OmEntryReader methodsFor: 'reading' stamp: ''!
nextEntry
	"Read next entry from the stream."
	
	^ self subclassResponsibility! !

!OmEntryReader class methodsFor: 'instance creation' stamp: ''!
newForStore: aFileStore
	
	^ self basicNew
		initializeWithStore: aFileStore;
		yourself! !

!OmEntryWriter commentStamp: ''!
I implement how to write entries to a stream.!
!OmEntryWriter methodsFor: 'writing' stamp: ''!
on: aStream nextEntryPut: anEntry 
	"Write the entry on the stream."
	
	^ self subclassResponsibility! !

!OmEntryWriter methodsFor: 'accessing' stamp: ''!
store
	^ store! !

!OmEntryWriter methodsFor: 'initialization' stamp: ''!
initializeWithStore: aFileStore

	self initialize.
	store := aFileStore.! !

!OmEntryWriter class methodsFor: 'instance creation' stamp: ''!
newForStore: aFileStore
	
	^ self basicNew
		initializeWithStore: aFileStore;
		yourself! !

!OmFileStore commentStamp: ''!
I am a single-file store of entries. Each new entry is appended at the end. Entries are lazily read from file on demand.!
!OmFileStore methodsFor: 'accessing' stamp: ''!
writingFileReference
	
	^ fileReference! !

!OmFileStore methodsFor: 'testing' stamp: ''!
isOutdated
	"Answer if #refresh is needed. A store is outdated if the file exists and has greater size than last time I wrote."

	^ self fileReference exists and: [ self fileReference size ~= lastStreamPosition ]! !

!OmFileStore methodsFor: 'private' stamp: ''!
entryPositionsByLocalName
	
	self checkIfMustRefresh.
	
	^ entryPositionsByLocalName! !

!OmFileStore methodsFor: 'private' stamp: ''!
refreshEntryPositionsByLocalNameStartingAt: firstStreamPosition since: initialLocalName
	"Workaround needed because can't get real file stream position from ZnBufferedWriteStream. 
	(+ would need special care of WideStrings)"

	| localNameAsInteger |
	localNameAsInteger := initialLocalName asInteger.

	self readEntriesWith: [:readStream |
		readStream position: firstStreamPosition.
		self newEntryReader
			stream: readStream;
			entryPositionsDo: [ :entryPosition |
				entryPositionsByLocalName at: localNameAsInteger asString put: entryPosition.
				localNameAsInteger := localNameAsInteger + 1 ].
		].! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
entryBufferDo: aBlock
	"Iterate the entryBuffer taking care of performance (avoid triggering the lazy initialization)."

	entryBuffer ifNotNil: [
		"Create a new Array instance on purpose, to avoid any possible concurrency issue, since the original collection may mutate buring the iteration."
		entryBuffer asArray do: aBlock ]! !

!OmFileStore methodsFor: 'refreshing' stamp: ''!
refresh
	self flush.

	self
		critical: [ mustRefresh := false.
			self initialize.
			self fileReference ifAbsent: [ ^ self ].
			self
				readEntriesWith: [ :readStream | 
					[ self newEntryReader
						stream: readStream;
						entryPositionsDo: [ :entryPosition | 
							entryCount := entryCount + 1.
							entryPositionsByLocalName at: entryCount asString put: entryPosition ] ]
						ensure: [ headReference := self referenceToLocalName: entryCount asString ] ] ]! !

!OmFileStore methodsFor: 'private' stamp: ''!
entryBuffer

	^ entryBuffer ifNil: [ entryBuffer := OrderedCollection new ]! !

!OmFileStore methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	
	aStream 
		nextPut: $(;
		nextPutAll: self globalName;
		nextPut: $)! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
globalName

	^ globalName! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
entryReferences
	"Optimized implementation for potentially large files"
	
	^ (1 to: self entriesCount) collect: [:index |
			self referenceToLocalName: index asString ]! !

!OmFileStore methodsFor: 'private' stamp: ''!
entryByLocalName

	^ entryByLocalName ifNil: [ entryByLocalName := WeakValueDictionary new ]! !

!OmFileStore methodsFor: 'refreshing' stamp: ''!
flush

	self writingDeferrer flush! !

!OmFileStore methodsFor: 'private' stamp: ''!
newEntryReader
	
	^ OmSTONEntryReader newForStore: self! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
writingDeferDuration

	^ self writingDeferrer duration! !

!OmFileStore methodsFor: 'writing' stamp: ''!
newEntry: anEntry

	self critical: [
		| newReference localName |
		entryCount := entryCount + 1.

		"Build new entry"
		localName := entryCount asString.
		newReference := self referenceToLocalName: localName.
		anEntry tags at: self selfReferenceKey put: newReference.

		"Update head"
		headReference := newReference.

		"Cache (weak)"
		self entryByLocalName at: localName put: anEntry.

		"Defer write"
		self entryBuffer addLast: anEntry -> localName.
		self writingDeferrer schedule.
		]! !

!OmFileStore methodsFor: 'private' stamp: ''!
newEntryWriter

	^ OmSTONEntryWriter newForStore: self! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
entriesCount
	"Answer the number of entries that this store contains"

	self checkIfMustRefresh.
	
	^ entryCount! !

!OmFileStore methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlockClosure 
	"Evaluate the closure on each entry"

	self fileReference ifExists: [
		self readEntriesWith: [:readStream | 
			| reader |
			reader := self newEntryReader.
			reader stream: readStream.
			[ readStream atEnd ] whileFalse: [
				aBlockClosure value: reader nextEntry ] ] ].

	"Finally, the entries still not written"
	self entryBufferDo: [:entryAndLocalName | 
		aBlockClosure value: entryAndLocalName key ].! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
lowLevelFileStoreIfNone: aBlock
	"Needed by EpLostChangesDetector"
	
	^ self! !

!OmFileStore methodsFor: 'private' stamp: ''!
flushEntryBuffer

	self critical: [
		| initialPosition initialLocalName fileStream |
		self entryBuffer isEmpty ifTrue: [ ^self ].
				
		[ fileStream := ZnCharacterWriteStream on: fileReference binaryWriteStream encoding: #utf8. ] on: ReadOnlyFileException do: [ :anException |
			fileStream ifNotNil: #close.
			^ self
		 ].	
	
		[ | anEntryWriter |
			fileStream setToEnd.
			
			initialPosition := fileStream position.
			initialLocalName := self entryBuffer first value.
			anEntryWriter := self newEntryWriter.

			[ self entryBuffer isEmpty ] whileFalse: [
				| next entry |
				next := self entryBuffer removeFirst.
				entry := next key.

				"Write entry to file"
				anEntryWriter
					on: fileStream
					nextEntryPut: entry.
				].

			"In Linux it was necessary to explicitly flush the file stream"
			fileStream flush.
			
			lastStreamPosition := fileStream position.
			] ensure: [ fileStream close ].
	
		self refreshEntryPositionsByLocalNameStartingAt: initialPosition since: initialLocalName ].! !

!OmFileStore methodsFor: 'initialization' stamp: ''!
initializeWithGlobalName: aName fileReference: aFileReference

	self initialize.
	
	globalName := aName.
	fileReference := aFileReference.
	mustRefresh := fileReference exists. "Late file read"! !

!OmFileStore methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	entryCount := 0.
	entryPositionsByLocalName := Dictionary new.
	headReference := OmNullReference uniqueInstance.! !

!OmFileStore methodsFor: 'private' stamp: ''!
nextEntryFromPosition: aFilePosition

	^ self readEntriesWith: [ :readStream |
		readStream position: aFilePosition.
		self newEntryReader stream: readStream; nextEntry ]! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
firstEntryIfAbsent: absentBlock

	^ [ super firstEntryIfAbsent: absentBlock ] 
			on: Error 
			do: absentBlock! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
readEntryForLocalName: aString ifPresent: presentBlockClosure ifAbsent: absentBlockClosure

	^ self entryPositionsByLocalName 
		at: aString
		ifPresent: [ :position |
			presentBlockClosure value: (self nextEntryFromPosition: position) ]
		ifAbsent: absentBlockClosure! !

!OmFileStore methodsFor: 'private' stamp: ''!
readEntriesWith: aBlockClosure

	self fileReference readStreamDo: [ :readStream | [
		^ aBlockClosure value: readStream ]
			on: Error
			do: [ :error |
				(OmFileStoreReadingError 
					readingError: error
					on: self fileReference
					position: readStream position) signal ] ]! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
headReference

	self checkIfMustRefresh.

	^ headReference! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
entryFor: aReference ifPresent: presentBlockClosure ifAbsent: absentBlockClosure

	(aReference isNull or: [ aReference globalName ~= self globalName])
		ifTrue: [ ^ absentBlockClosure value ].

	^ self entryByLocalName
		at: aReference localName
		ifPresent: presentBlockClosure
		ifAbsentOrNil: [
			self
				readEntryForLocalName: aReference localName
				ifPresent: [ :entry |
					self entryByLocalName at: aReference localName put: entry.
					presentBlockClosure value: entry ] 
				ifAbsent: absentBlockClosure ]! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
fileReference

	^ fileReference! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
writingDeferrer

	^ writingDeferrer ifNil: [
		writingDeferrer := OmDeferrer 
			send: #flushEntryBuffer 
			to: self
			after: self class defaultWritingDeferDuration ]! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
ensureDeleteFile
	"After execution of this method, the .ombu file this instance represents will not exist."
	
	^ self fileReference ensureDelete! !

!OmFileStore methodsFor: 'accessing' stamp: ''!
writingDeferDuration: aDuration

	self writingDeferrer duration: aDuration! !

!OmFileStore methodsFor: 'private' stamp: ''!
critical: aBlock

	lock ifNil: [
		lock := Semaphore forMutualExclusion ].

	^ lock critical: aBlock! !

!OmFileStore methodsFor: 'copying' stamp: ''!
copyReopened

	^ self species named: globalName inFile: fileReference! !

!OmFileStore methodsFor: 'private' stamp: ''!
checkIfMustRefresh

	mustRefresh ifTrue: [ self refresh ]! !

!OmFileStore class methodsFor: 'instance creation' stamp: ''!
new

	^ self named: UUID new asString36! !

!OmFileStore class methodsFor: 'instance creation' stamp: ''!
named: aName inFile: aFileReference

	^ self basicNew 
		initializeWithGlobalName: aName
		fileReference: aFileReference;
		yourself! !

!OmFileStore class methodsFor: 'instance creation' stamp: ''!
named: aGlobalName inDirectory: baseDirectoryFileReference

	^ self
		named: aGlobalName
		inFile: (self fileReferenceForStoreNamed: aGlobalName inDirectory: baseDirectoryFileReference)! !

!OmFileStore class methodsFor: 'accessing' stamp: ''!
globalNameFrom: directoryEntryOrFileReference

	^ directoryEntryOrFileReference asFileReference basenameWithoutExtension! !

!OmFileStore class methodsFor: 'accessing' stamp: ''!
defaultWritingDeferDuration

	^ 250 milliSeconds! !

!OmFileStore class methodsFor: 'instance creation' stamp: ''!
fromFile: aFileReference

	^ self 
		named: aFileReference basenameWithoutExtension
		inFile: aFileReference! !

!OmFileStore class methodsFor: 'accessing' stamp: ''!
defaultFileSuffix

	^ '.ombu'! !

!OmFileStore class methodsFor: 'instance creation' stamp: ''!
named: aGlobalName
	^ self named: aGlobalName inDirectory: FileSystem memory! !

!OmFileStore class methodsFor: 'testing' stamp: ''!
existsStoreNamed: aGlobalName inDirectory: aFileReference

	^ aFileReference exists and: [
		(self 
			fileReferenceForStoreNamed: aGlobalName 
			inDirectory: aFileReference) exists ]! !

!OmFileStore class methodsFor: 'accessing' stamp: ''!
fileReferenceForStoreNamed: aGlobalName inDirectory: baseDirectoryFileReference

	^ baseDirectoryFileReference / (aGlobalName, self defaultFileSuffix)! !

!OmFileStoreReadingError commentStamp: ''!
I am a notification raised when a OmFileStore has a problem reading an entry from its file.!
!OmFileStoreReadingError class methodsFor: 'instance creation' stamp: ''!
readingError: sourceError on: aFileReference position: aFilePosition

	^ self new messageText: 'Reading entry from ', aFileReference asString, '@', aFilePosition asString, ': ', sourceError messageText! !

!OmFileStoreTest methodsFor: 'resources' stamp: ''!
setUpStore	

	^ OmFileStore 
		named: 'testingStore', UUID new asString36
		inDirectory: self directoryForTests ensureCreateDirectory! !

!OmFileStoreTest methodsFor: 'running' stamp: ''!
tearDown
	
	store fileReference ensureDelete.
	otherStore fileReference ensureDelete.
	super tearDown! !

!OmFileStoreTest methodsFor: 'tests' stamp: ''!
testLoadFromCorruptFile2
	"Bad class name"

	| loadedStore |
	store newEntry: (OmEntry content: 41).
	store newEntry: (OmEntry content: 42).

	"Override first characters"
	store fileReference writeStreamDo: [ :stream | stream nextPutAll: 'OMENTRY' ].
	
	loadedStore := 
		(OmFileStore 
			named: store globalName 
			inDirectory: self directoryForTests)
			yourself.
	
	self 
		should: [ loadedStore refresh; entries ]
		raise: OmFileStoreReadingError! !

!OmFileStoreTest methodsFor: 'tests' stamp: ''!
testLoadFromCorruptFile3
	"Bad class name. Last entry."

	| loadedStore |
	store newEntry: (OmEntry content: 41).

	"Override first characters"
	store fileReference writeStreamDo: [ :stream | stream nextPutAll: 'OMENTRY' ].
	
	loadedStore := 
		(OmFileStore 
			named: store globalName 
			inDirectory: self directoryForTests)
			yourself.
	
	self 
		should: [ loadedStore refresh; entries ]
		raise: OmFileStoreReadingError! !

!OmFileStoreTest methodsFor: 'tests' stamp: ''!
testLoadFromCorruptFile1
	"Bad character"

	| loadedStore |
	store newEntry: (OmEntry content: 41).
	store newEntry: (OmEntry content: 42).

	"Override first characters"
	store fileReference writeStreamDo: [ :stream | stream nextPutAll: '***' ].
	
	loadedStore := 
		(OmFileStore 
			named: store globalName 
			inDirectory: self directoryForTests)
			yourself.
	
	self 
		should: [ loadedStore refresh; entries ]
		raise: OmFileStoreReadingError! !

!OmFileStoreTest methodsFor: 'tests' stamp: ''!
testLoadFromCorruptFile4
	"Content is corrupted"

	| loadedStore stream |
	store newEntry: (OmEntry content: 41).
	store newEntry: (OmEntry content: 42).
	store flush.
	
	"Override first characters"
	stream := store fileReference binaryWriteStream.
	[
		(ZnCharacterWriteStream on: stream encoding: 'utf8')
			position: 50;
			nextPutAll: '**'.
			
		"Apparently, in Linux it can randomly fail if not explicitly flush"
		stream flush.
	] ensure: [ stream close ].
	
	loadedStore := 
		(OmFileStore 
			named: store globalName 
			inDirectory: self directoryForTests)
			yourself.
	
	self 
		should: [ loadedStore refresh; entries ]
		raise: OmFileStoreReadingError.! !

!OmFileStoreTest methodsFor: 'tests' stamp: ''!
testIsOutdated

	| copy |
	self deny: store isOutdated.
	store newEntry: (OmEntry content: 42).
	self deny: store isOutdated.
	store flush.
	self deny: store isOutdated.
	copy := store copyReopened refresh.
	store newEntry: (OmEntry content: 43).
	store flush.
	"A store is outdated if the file exists and has greater size than in memory."
	self assert: copy isOutdated.
	store ensureDeleteFile.
	self deny: copy isOutdated.! !

!OmFileStoreTest methodsFor: 'tests' stamp: ''!
testLoadFromFile
	| loadedStore |
	store newEntry: (OmEntry content: 42).
	store flush.
	
	loadedStore := 
		(OmFileStore 
			named: store globalName 
			inDirectory: self directoryForTests)
			refresh;
			yourself.
	
	self 
		assert: (loadedStore entries collect: #content as: Array)
		equals: #(42)! !

!OmFileStoreTest methodsFor: 'resources' stamp: ''!
setUpOtherStore

	^ OmFileStore 
		named: 'testingOtherStore', UUID new asString36
		inDirectory: self directoryForTests ensureCreateDirectory! !

!OmFileStoreTest methodsFor: 'tests' stamp: ''!
testEnsureDeleteFile
	| loadedStore |
	store newEntry: (OmEntry content: 42).
	store flush.

	store ensureDeleteFile.
	
	loadedStore := 
		(OmFileStore 
			named: store globalName 
			inDirectory: self directoryForTests)
			refresh;
			yourself.
	
	self assert: loadedStore entriesCount equals: 0.! !

!OmFileStoreWritingError commentStamp: ''!
I am a notification raised when a OmFileStore has a problem writing an entry into its file.!
!OmFuelEntryReader commentStamp: ''!
I implement how to read entries from a stream using Fuel serializer.!
!OmFuelEntryReader methodsFor: 'enumerating' stamp: ''!
entryPositionsDo: aBlock

	self shouldBeImplemented! !

!OmFuelEntryReader methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	materializer := FLMaterializer new.! !

!OmFuelEntryReader methodsFor: 'reading' stamp: ''!
nextEntry

	^ (materializer materializeFrom: stream) root! !

!OmFuelEntryWriter commentStamp: ''!
I implement how to write entries to a stream using Fuel serializer.!
!OmFuelEntryWriter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	serializer := FLSerializer new! !

!OmFuelEntryWriter methodsFor: 'writing' stamp: ''!
on: aStream nextEntryPut: anEntry 

	serializer
		serialize: anEntry 
		on: aStream! !

!OmMemoryStore commentStamp: ''!
I am an in-memory store of entries.!
!OmMemoryStore methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlockClosure 
	entries do: aBlockClosure! !

!OmMemoryStore methodsFor: 'accessing' stamp: ''!
writingFileReference
	"Stub"

	^ (FileSystem memory / 'store.ombu') ensureCreateFile! !

!OmMemoryStore methodsFor: 'accessing' stamp: ''!
initializeWithGlobalName: aName

	self initialize.
	globalName := aName.
	
	entries := OrderedCollection new.! !

!OmMemoryStore methodsFor: 'refreshing' stamp: ''!
refresh
	"Nothing to refresh"
	
	^ self! !

!OmMemoryStore methodsFor: 'accessing' stamp: ''!
headReference
	"Answer a reference to the last entry added to this store, or OmNullReference uniqueInstance when empty."

	^ entries
		ifEmpty: [ OmNullReference uniqueInstance ]
		ifNotEmpty: [ self referenceTo: entries last ]! !

!OmMemoryStore methodsFor: 'accessing' stamp: ''!
entryFor: aReference ifPresent: presentBlockClosure ifAbsent: absentBlockClosure

	| entry |
	(aReference isNull or: [ aReference globalName ~= self globalName])
		ifTrue: [ ^ absentBlockClosure value ].

	entry := entries
		at: aReference localName asInteger
		ifAbsent: [ ^ absentBlockClosure value ].
		
	^ presentBlockClosure cull: entry! !

!OmMemoryStore methodsFor: 'accessing' stamp: ''!
globalName
	^ globalName! !

!OmMemoryStore methodsFor: 'writing' stamp: ''!
newEntry: anEntry

	| localName newReference |
	localName := (entries size + 1) asString.
	newReference := self referenceToLocalName: localName.
	anEntry tags at: self selfReferenceKey put: newReference.
	entries add: anEntry.! !

!OmMemoryStore methodsFor: 'accessing' stamp: ''!
entries
	^ entries! !

!OmMemoryStore class methodsFor: 'instance creation' stamp: ''!
new

	^ self named: UUID new asString36! !

!OmMemoryStore class methodsFor: 'instance creation' stamp: ''!
withAllEntries: aCollection
	^ self new
		in: [ :store | aCollection do: [ :entry | store newEntry: entry ] ];
		yourself! !

!OmMemoryStore class methodsFor: 'instance creation' stamp: ''!
named: aGlobalName

	^ self basicNew
		initializeWithGlobalName: aGlobalName;
		yourself! !

!OmMemoryStore class methodsFor: 'instance creation' stamp: ''!
withAllContents: aCollection
	| entries |
	entries := aCollection collect: [ :each | OmEntry content: each ].
	^ self withAllEntries: entries! !

!OmMemoryStoreTest methodsFor: 'resources' stamp: ''!
setUpStore	
	^ OmMemoryStore new! !

!OmMemoryStoreTest methodsFor: 'tests' stamp: ''!
testWithAllEntries

	| entries newStore |
	entries := (OmMemoryStore withAllContents: #(a b c)) entries.
	newStore := OmMemoryStore withAllEntries: entries.
	self assertCollection: newStore entries hasSameElements: entries.! !

!OmMemoryStoreTest methodsFor: 'tests' stamp: ''!
testWithAllContents

	| entries |
	entries := (OmMemoryStore withAllContents: #(a b c)) entries.
	self assertCollection: (entries collect: [:each | each content]) hasSameElements: #(a b c).! !

!OmNullReference commentStamp: ''!
I represent the no-reference. I implement the null object design pattern.!
!OmNullReference methodsFor: 'testing' stamp: ''!
isNull
	^ true! !

!OmNullReference methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		nextPutAll: 'null:reference'! !

!OmNullReference methodsFor: 'ston persistence' stamp: ''!
stonOn: stonWriter

	stonWriter 
		writeObject: self 
		streamShortList: [ :writer |  ]! !

!OmNullReference methodsFor: 'ston persistence' stamp: ''!
stonContainSubObjects 
	^ false! !

!OmNullReference class methodsFor: 'instance creation' stamp: ''!
uniqueInstance
	^ uniqueInstance ifNil: [ uniqueInstance := self new ]! !

!OmNullReference class methodsFor: 'ston persistence' stamp: ''!
fromSton: stonReader

	stonReader parseListDo: [ :each :index | "nothing to read" ].

	^ self uniqueInstance! !

!OmNullStore commentStamp: ''!
I represent the null OmStore (Null Object design pattern).!
!OmNullStore methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlockClosure
	"Evaluate aBlockClosure with every entries this store contains"! !

!OmNullStore methodsFor: 'accessing' stamp: ''!
writingFileReference

	^ self shouldNotImplement! !

!OmNullStore methodsFor: 'refreshing' stamp: ''!
refresh! !

!OmNullStore methodsFor: 'accessing' stamp: ''!
headReference
	"Answer a reference to the last entry added to this store."

	^ OmNullReference uniqueInstance! !

!OmNullStore methodsFor: 'accessing' stamp: ''!
entryFor: aReference ifPresent: presentBlockClosure ifAbsent: absentBlockClosure
	"Look for an entry, evaluating either the first block closure if present or the second if absent."

	^ absentBlockClosure value! !

!OmNullStore methodsFor: 'writing' stamp: ''!
newEntry: anEntry

	self shouldNotImplement! !

!OmRandomSuffixStrategy commentStamp: ''!
I attach random characters as a suffix to the name (after last _).!
!OmRandomSuffixStrategy methodsFor: 'accessing' stamp: ''!
nextSuffix

	^ UUID new asString36! !

!OmRandomSuffixStrategyTest commentStamp: ''!
An OmRandomSuffixStrategyTest is a test class for testing the behavior of OmRandomSuffixStrategy!
!OmRandomSuffixStrategyTest methodsFor: 'tests' stamp: ''!
testIsNotConstant

	| names |
	names := (1 to: 7) collect: [:each | strategy nextTo: 'existing' in: self directory ].
	"This should be different"
	self assert: names asSet size equals: names size.! !

!OmReference commentStamp: ''!
I represent a reference to an entry into a store.!
!OmReference methodsFor: 'comparing' stamp: ''!
= other
	^ other species = self species and: [ 
		other localName = self localName and: [
		other globalName = self globalName ] ]! !

!OmReference methodsFor: 'comparing' stamp: ''!
hash
	^ (self species hash bitXor: self localName hash) bitXor: self globalName hash! !

!OmReference methodsFor: 'initialization' stamp: ''!
initializeWithLocalName: aLocalName globalName: aGlobalName

	self initialize.
	localName := aLocalName.
	globalName := aGlobalName.! !

!OmReference methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	
	aStream 
		nextPut: $(;
		nextPutAll: self shortName; 
		nextPut: $).! !

!OmReference methodsFor: 'accessing' stamp: ''!
globalName
	
	^ globalName! !

!OmReference methodsFor: 'printing' stamp: ''!
shortName

	^ String streamContents: [ :stream |
		stream
			nextPutAll: self globalName; 
			nextPut: $:;
			nextPutAll: self localName ]! !

!OmReference methodsFor: 'accessing' stamp: ''!
localName
	
	^ localName! !

!OmReference methodsFor: 'ston persistence' stamp: ''!
stonOn: stonWriter
	
	stonWriter 
		writeObject: self 
		streamShortList: [ :array |
			"Optimization: only write globalName if it belongs to a 'remote' store"
			OmCurrentGlobalName value = self globalName
				ifFalse: [ array add: self globalName ].

			array add: self localName ]! !

!OmReference methodsFor: 'ston persistence' stamp: ''!
stonContainSubObjects 
	^ false! !

!OmReference class methodsFor: 'instance creation' stamp: ''!
globalName: aName localName: anIdentifier

	^ self new
		initializeWithLocalName: anIdentifier
		globalName: aName;
		yourself! !

!OmReference class methodsFor: 'ston persistence' stamp: ''!
fromSton: stonReader
	| array |
	array := Array new: 2 streamContents: [ :stream |
		stonReader parseListDo: [ :each :index | stream nextPut: each ] ].

	"Optimization: only write globalName if it belongs to a 'remote' store"
	^ array size = 1
		ifTrue: [ 
			self 
				globalName: OmCurrentGlobalName value
				localName: array first ]
		ifFalse: [
			self 
				globalName: array first
				localName: array second ]! !

!OmSTONEntryReader commentStamp: ''!
I implement how to read entries from a stream using Ston serializer.!
!OmSTONEntryReader methodsFor: 'reading' stamp: ''!
entryPositionsDo: aBlock

	[ self
		nextEntryPositionIfFound: [:position |
			aBlock value: position. true ] 
		ifNone: [ false ]
	] whileTrue! !

!OmSTONEntryReader methodsFor: 'reading' stamp: ''!
nextEntryPositionIfFound: foundBlock ifNone: noneBlock

	| token |
	token := 'OmEntry {'.

	[ [ stream upToAll: token ]
		on: ZnInvalidUTF8
		do: [ :exception | 
			"Workaround: positioned block in middle of multibyte utf8 char 
			   => skip a byte then try again"
			stream next.
			exception retry ].
	stream peek = $\ ] whileTrue.	"here we handle case when log contains this method itself"
	^ stream atEnd
		ifTrue: noneBlock
		ifFalse: [ foundBlock value: stream position - token size ]! !

!OmSTONEntryReader methodsFor: 'accessing' stamp: ''!
stream: aReadStream

	super stream: aReadStream.
	self stonReader on: stream.! !

!OmSTONEntryReader methodsFor: 'accessing' stamp: ''!
stonReader

	^ reader ifNil: [ 
		reader := STON reader
			allowComplexMapKeys: true;
			yourself ]! !

!OmSTONEntryReader methodsFor: 'reading' stamp: ''!
entryPositionsUpTo: endPosition

	| positions |
	positions := OrderedCollection new.
	
	self entryPositionsDo: [ :position |
		position > endPosition ifTrue: [ ^positions ].
		positions add: position ].
	
	^ positions! !

!OmSTONEntryReader methodsFor: 'reading' stamp: ''!
entryPositionsReverseDo: aBlock

	| found token |
	token := 'OmEntry {'.
	stream setToEnd.

	[	[ 	found := stream backUpTo: token. 
			stream skip: token size negated. ] 
				doWhileTrue: [ found and: [ stream peek = $\ ] ].

		found ifFalse: [ ^self ].

		stream skip: token size negated.
		aBlock value: stream position.
			
	] doWhileTrue: true! !

!OmSTONEntryReader methodsFor: 'reading' stamp: ''!
nextEntry

	^ OmCurrentGlobalName
		value: store globalName
		during: [
			self stonReader
				reset;
				next ]! !

!OmSTONEntryWriter commentStamp: ''!
I implement how to write entries to a stream using Ston serializer.!
!OmSTONEntryWriter methodsFor: 'initialization' stamp: ''!
newSTONWriter
	^ STON writer
		prettyPrint: true;
		yourself! !

!OmSTONEntryWriter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	writer := self newSTONWriter! !

!OmSTONEntryWriter methodsFor: 'writing' stamp: ''!
on: aStream nextEntryPut: anEntry 

	OmCurrentGlobalName
		value: store globalName
		during: [
			writer 
				reset;
				on: aStream;
				nextPut: anEntry.

			aStream cr;cr ]! !

!OmSequentialSuffixStrategy commentStamp: ''!
Use FileReference>>nextVersion to find the new name.!
!OmSequentialSuffixStrategy methodsFor: 'accessing' stamp: ''!
nextTo: aName in: aDirectory
	
	| fileReference |
	fileReference := OmFileStore
		fileReferenceForStoreNamed: aName
		inDirectory: aDirectory.
	
	^ fileReference nextVersion basenameWithoutExtension! !

!OmSequentialSuffixStrategyTest commentStamp: ''!
An OmSecuentialSuffixStrategyTest is a test class for testing the behavior of OmSecuentialSuffixStrategy!
!OmSessionStore commentStamp: ''!
I wrap a file store that is renewed each time either the Smalltalk session changes, among others (check #needsReset).!
!OmSessionStore methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlockClosure
	"Evaluate aBlockClosure with every entries this store contains"

	^ self store entriesDo: aBlockClosure! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
lowLevelFileStoreIfNone: aBlock
	"Needed by EpLostChangesDetector"
	
	^ currentStore ifNil: aBlock! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
writingDeferDuration: aDuration

	writingDeferDuration := aDuration.
	self store writingDeferDuration: aDuration.! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
writingFileReference

	^ currentStore writingFileReference! !

!OmSessionStore methodsFor: 'refreshing' stamp: ''!
refresh

	^ self store refresh! !

!OmSessionStore methodsFor: 'testing' stamp: ''!
existsStoreNamed: aName

	^ OmFileStore existsStoreNamed: aName inDirectory: self directory! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
headReference
	"Answer a reference to the last entry added to this store."

	^ headReference ifNil: [
		headReference := self store headReference ]! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
directory

	^ baseLocator asFileReference! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
entryFor: aReference ifPresent: presentBlockClosure ifAbsent: absentBlockClosure
	"Look for an entry, evaluating either the first block closure if present or the second if absent."

	^ self store 
		entryFor: aReference 
		ifPresent: presentBlockClosure 
		ifAbsent: absentBlockClosure! !

!OmSessionStore methodsFor: 'private' stamp: ''!
imagePathString
	"Answer the full path name for the current image."

	^ SmalltalkImage current imagePath! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
store
	"Answer the store I wrap"

	(currentStore isNil or: [ self needsReset ]) 
		ifTrue: [ self resetWithNextStoreName ].
	
	^ currentStore! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
baseLocator

	^ baseLocator! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
globalName

	^ self store globalName! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
storeNameStrategy: anOmStoreNameStrategy

	storeNameStrategy := anOmStoreNameStrategy! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
nextStoreName

	| name |
	name := currentStore 
		ifNil: [ "First store name"
			Smalltalk imageFile basenameWithoutExtension, '.1' ]
		ifNotNil: [ "There is already a name"
			currentStore globalName ].
		
	^ self storeNameStrategy nextTo: name in: self directory! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
storeNameStrategy

	^ storeNameStrategy ifNil: [ self class storeNameStrategy ]! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
resetWithStoreNamed: newName
	"First, ensure file is not already used."

	(OmFileStore fileReferenceForStoreNamed: newName inDirectory: self directory)
		ifExists: [ :fileReference | FileExists signalWith: fileReference ].

	self directory fileSystem isWritable ifFalse: [ ^ self ].

	"Then, we can proceed."
	currentSession := Smalltalk session.
	currentImagePathString := self imagePathString.
	currentStore := OmStoreFactory current named: newName inDirectory: self directory ensureCreateDirectory.
	currentStore writingDeferDuration: self writingDeferDuration.

	"Announce"
	self announcer announce: OmSessionStoreUpdated new! !

!OmSessionStore methodsFor: 'refreshing' stamp: ''!
flush
	"Flush any buffered state"
	
	self store flush! !

!OmSessionStore methodsFor: 'private' stamp: ''!
needsReset

	^ currentSession ~~ Smalltalk session
		or: [ currentImagePathString ~= self imagePathString ]! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
resetWithNextStoreName

	self resetWithStoreNamed: self nextStoreName! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
writingDeferDuration

	^ writingDeferDuration ifNil: [ OmFileStore defaultWritingDeferDuration ]! !

!OmSessionStore methodsFor: 'writing' stamp: ''!
newEntry: anEntry
	"Persist a new entry"

	self store newEntry: anEntry.
	headReference := self store headReference.! !

!OmSessionStore methodsFor: 'accessing' stamp: ''!
announcer

	^ announcer ifNil: [ 
		announcer := Announcer new ]! !

!OmSessionStore methodsFor: 'initialization' stamp: ''!
initializeWithBaseLocator: aDirectoryFileLocator

	self initialize.
	
	baseLocator := aDirectoryFileLocator.
	self store. "Force initialization"
	headReference := self store headReference.
	
	self class register: self.! !

!OmSessionStore class methodsFor: 'instance creation' stamp: ''!
newWithBaseLocator: aBaseDirectory

	^ self basicNew
		initializeWithBaseLocator: aBaseDirectory
		yourself! !

!OmSessionStore class methodsFor: 'accessing' stamp: ''!
defaultBaseLocator: aFileLocator 

	defaultBaseLocator := aFileLocator! !

!OmSessionStore class methodsFor: 'instance creation' stamp: ''!
new

	^ self newWithBaseLocator: self defaultBaseLocator! !

!OmSessionStore class methodsFor: 'class initialization' stamp: ''!
initialize
 
	registry := WeakSet new: 5.
	SessionManager default registerUserClassNamed: self name! !

!OmSessionStore class methodsFor: 'initialization' stamp: ''!
startUp 

	registry do: [ :each | each store ]! !

!OmSessionStore class methodsFor: 'accessing' stamp: ''!
defaultBaseLocator

	^ defaultBaseLocator ifNil: [ 
		defaultBaseLocator := FileLocator localDirectory / 'ombu-sessions' ]! !

!OmSessionStore class methodsFor: 'accessing' stamp: ''!
storeNameStrategy: aStoreNameStrategy

	storeNameStrategy := aStoreNameStrategy! !

!OmSessionStore class methodsFor: 'accessing' stamp: ''!
storeNameStrategy

	^ storeNameStrategy ifNil: [ 
		storeNameStrategy := OmRandomSuffixStrategy new ]! !

!OmSessionStore class methodsFor: 'initialization' stamp: ''!
register: aSessionStore

	registry add: aSessionStore! !

!OmSessionStoreNameStrategyTest commentStamp: ''!
An OmSessionStoreNameStrategyTest is a test class for testing the behavior of OmSessionStoreNameStrategy!
!OmSessionStoreNameStrategyTest methodsFor: 'initialization' stamp: ''!
strategyClass

	^ self class environment classNamed: 
		(self class name allButLast: 4) "corresponding to the word Test"! !

!OmSessionStoreNameStrategyTest methodsFor: 'running' stamp: ''!
tearDown

	self directory ensureDeleteAll.
	super tearDown! !

!OmSessionStoreNameStrategyTest methodsFor: 'private' stamp: ''!
directory

	^ FileLocator temp asFileReference / 'ombu-strategy-tests'! !

!OmSessionStoreNameStrategyTest methodsFor: 'private' stamp: ''!
createFileWith: aName

	self directory ensureCreateDirectory.
	(OmFileStore fileReferenceForStoreNamed: aName inDirectory: self directory) 
		writeStreamDo: [ :stream | stream print: 'stub contents' ]! !

!OmSessionStoreNameStrategyTest methodsFor: 'tests' stamp: ''!
testWithNotExistingFile

	name := strategy nextTo: 'inexistent' in: self directory.
	
	self assert: name isString.
	self deny: (self fileReferenceWith: name) exists! !

!OmSessionStoreNameStrategyTest methodsFor: 'private' stamp: ''!
fileReferenceWith: aName

	^ OmFileStore 
		fileReferenceForStoreNamed: aName
		inDirectory: self directory! !

!OmSessionStoreNameStrategyTest methodsFor: 'tests' stamp: ''!
testWithExistingFile
	self createFileWith: 'existing'.

	name := strategy nextTo: 'existing' in: self directory.

	self assert: name isString.
	self deny: name equals: 'existing'.
	self deny: (self fileReferenceWith: name) exists! !

!OmSessionStoreNameStrategyTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	strategy := self strategyClass new! !

!OmSessionStoreNameStrategyTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self name = #OmSessionStoreNameStrategyTest! !

!OmSessionStoreNamingStrategy commentStamp: ''!
My subclasses define a way to find a name for a new Ombu log.  Names should not collide with an existing file in the same directory.!
!OmSessionStoreNamingStrategy methodsFor: 'accessing' stamp: ''!
nextTo: aName in: aDirectory
	"Answer a name for a new Ombu log, that should not collide with an existing file in the same directory."
	
	^ self subclassResponsibility! !

!OmSessionStoreNamingStrategy class methodsFor: 'accessing' stamp: ''!
availableStrategies

	^ self allSubclasses reject: #hasAbstractMethods! !

!OmSessionStoreTest methodsFor: 'resources' stamp: ''!
setUpStore	

	^ OmSessionStore newWithBaseLocator: (self directoryForTests / 'test-sessions-main') ensureCreateDirectory! !

!OmSessionStoreTest methodsFor: 'running' stamp: ''!
tearDown
	
	store flush. "Store needs to be flushed already to be able to delete"	

	(self directoryForTests / 'test-sessions-main') ensureDeleteAll.
	(self directoryForTests / 'test-sessions-other') ensureDeleteAll.
	super tearDown.! !

!OmSessionStoreTest methodsFor: 'tests' stamp: ''!
testResetWithStoreNamedSignalsErrorIfFileAlreadyExists
	
	store resetWithStoreNamed: 'pepe'.
	store newEntry: (OmEntry content: 42).
	store flush.
	
	self 
		should: [ store resetWithStoreNamed: 'pepe' ]
		raise: FileExists! !

!OmSessionStoreTest methodsFor: 'tests' stamp: ''!
testResetWithNextStoreNameWithSequentialSuffix
	"The sequencial suffix doesn't change unless the file is created"

	| aFileReference anotherFileReference |
	store storeNameStrategy: OmSequentialSuffixStrategy new.

	store resetWithNextStoreName.
	aFileReference := store writingFileReference.
	store resetWithNextStoreName.
	anotherFileReference := store writingFileReference.

	self assert: aFileReference equals: anotherFileReference.

	store newEntry: (OmEntry content: 42).
	store flush.
	store resetWithNextStoreName.
	anotherFileReference := store writingFileReference.
	self deny: aFileReference equals: anotherFileReference! !

!OmSessionStoreTest methodsFor: 'tests' stamp: ''!
testResetWithNextStoreNameWithRandomSuffix
	| aFileReference anotherFileReference |
	store storeNameStrategy: OmRandomSuffixStrategy new.

	store resetWithNextStoreName.
	aFileReference := store writingFileReference.
	store resetWithNextStoreName.
	anotherFileReference := store writingFileReference.

	self deny: aFileReference equals: anotherFileReference! !

!OmSessionStoreTest methodsFor: 'tests' stamp: ''!
testResetWithNextStoreNameWithTimeStampSuffix
	| aFileReference anotherFileReference |
	store storeNameStrategy: OmTimeStampSuffixStrategy new.

	store resetWithNextStoreName.
	aFileReference := store writingFileReference.
	50 milliSeconds wait.
	store resetWithNextStoreName.
	anotherFileReference := store writingFileReference.

	self deny: aFileReference equals: anotherFileReference! !

!OmSessionStoreTest methodsFor: 'resources' stamp: ''!
setUpOtherStore

	^ OmSessionStore newWithBaseLocator: (self directoryForTests / 'test-sessions-other') ensureCreateDirectory! !

!OmSessionStoreTest methodsFor: 'tests' stamp: ''!
testResetWithStoreNamedDoesAnnounce

	| wasAnnounced |
	wasAnnounced := false.

	store announcer
		when: OmSessionStoreUpdated
		do: [ :announcement | wasAnnounced := true ].
	
	[ store resetWithStoreNamed: 'new' ] 
		ensure: [ store announcer unsubscribe: self ].

	self assert: wasAnnounced! !

!OmSessionStoreUpdated commentStamp: ''!
I am announced when a OmSessionStore updated its current #store.!
!OmStore commentStamp: ''!
I am a repository of entries.!
!OmStore methodsFor: 'accessing' stamp: ''!
entriesCount
	"Answer the number of entries that this store contains"

	^ self entries size! !

!OmStore methodsFor: 'enumerating' stamp: ''!
entriesDo: aBlockClosure 
	"Evaluate aBlockClosure with every entries this store contains"

	^ self subclassResponsibility! !

!OmStore methodsFor: 'accessing' stamp: ''!
lowLevelFileStoreIfNone: aBlock
	"Needed by EpLostChangesDetector"
	
	^ self subclassResponsibility! !

!OmStore methodsFor: 'accessing' stamp: ''!
writingFileReference
	"Answer the file reference where the method #newEntry: would persist a new entry."
	
	self subclassResponsibility! !

!OmStore methodsFor: 'accessing' stamp: ''!
firstEntryIfAbsent: absentBlock
	"Answer the first entry of this store, or execute absentBlock"

	self entriesDo: [ :entry | ^ entry ].

	^ absentBlock value! !

!OmStore methodsFor: 'refreshing' stamp: ''!
refresh
	
	^ self subclassResponsibility! !

!OmStore methodsFor: 'accessing' stamp: ''!
referenceTo: anEntry
	"Answer a reference to an entry."
	
	^ anEntry tags 
		at: self selfReferenceKey 
		ifAbsent: [ self error: 'Invalid entry: ', anEntry asString ]! !

!OmStore methodsFor: 'accessing' stamp: ''!
headReference
	"Answer a reference to the last entry added to this store."

	^ self subclassResponsibility! !

!OmStore methodsFor: 'accessing' stamp: ''!
referenceToLocalName: aString

	^ OmReference globalName: self globalName localName: aString! !

!OmStore methodsFor: 'accessing' stamp: ''!
directory
	"Answer the directory where this store is located."

	^ self writingFileReference parent! !

!OmStore methodsFor: 'accessing' stamp: ''!
entryFor: aReference ifPresent: presentBlockClosure ifAbsent: absentBlockClosure
	"Look for an entry, evaluating either the first block closure if present or the second if absent."
	
	^ self subclassResponsibility! !

!OmStore methodsFor: 'accessing' stamp: ''!
selfReferenceKey

	^ self class selfReferenceKey! !

!OmStore methodsFor: 'accessing' stamp: ''!
entryReferences
	"Answer OmReference instances for all the entries in this store"

	^ self entries collect: [:each | self referenceTo: each ]! !

!OmStore methodsFor: 'accessing' stamp: ''!
entryFor: aReference
	"Look for an entry"

	^ self
		entryFor: aReference
		ifPresent: [ :anEntry | ^ anEntry ] 
		ifAbsent: [ NotFound signalFor: aReference ]! !

!OmStore methodsFor: 'refreshing' stamp: ''!
flush
	"Flush any buffered state"! !

!OmStore methodsFor: 'writing' stamp: ''!
newEntry: anEntry
	"Persist a new entry"
	
	self subclassResponsibility! !

!OmStore methodsFor: 'accessing' stamp: ''!
entries
	"Answer all the entries the this store contains"

	| entries |
	entries := OrderedCollection new.

	self entriesDo: [ :entry | entries add: entry ].

	^ entries! !

!OmStore class methodsFor: 'accessing' stamp: ''!
selfReferenceKey

	^ #self! !

!OmStoreFactory commentStamp: ''!
I provide a facade to create and reuse OmStore hierarchy instances.!
!OmStoreFactory methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	storeByPath := WeakValueDictionary new.! !

!OmStoreFactory methodsFor: 'accessing' stamp: ''!
null

	^ nullStore ifNil: [ nullStore := OmNullStore new ]! !

!OmStoreFactory methodsFor: 'accessing' stamp: ''!
named: aGlobalName inDirectory: aDirectory

	| fileReference |
	fileReference := OmFileStore fileReferenceForStoreNamed: aGlobalName inDirectory: aDirectory.

	^ storeByPath
		at: fileReference fullName
		ifPresent: [:store | store ]
		ifAbsentOrNil: [ | newStore |
			newStore := self newStoreNamed: aGlobalName in: aDirectory.
			storeByPath at: fileReference fullName put: newStore.
			newStore ]! !

!OmStoreFactory methodsFor: 'accessing' stamp: ''!
defaultDirectory

	^ OmSessionStore defaultBaseLocator asFileReference! !

!OmStoreFactory methodsFor: 'accessing' stamp: ''!
fromFile: aFileReference

	^ self 
		named: (OmFileStore globalNameFrom: aFileReference)
		inDirectory: aFileReference parent! !

!OmStoreFactory methodsFor: 'accessing' stamp: ''!
named: aGlobalName 

	^ self named: aGlobalName inDirectory: self defaultDirectory! !

!OmStoreFactory methodsFor: 'private' stamp: ''!
newStoreNamed: aGlobalName in: aDirectory

	^ OmBlockFileStore
		named: aGlobalName
		inDirectory: aDirectory! !

!OmStoreFactory class methodsFor: 'class initialization' stamp: ''!
initialize
	
	SessionManager default registerSystemClassNamed: self name! !

!OmStoreFactory class methodsFor: 'accessing' stamp: ''!
current

	^ current ifNil: [ current := self new ]! !

!OmStoreFactory class methodsFor: 'system startup' stamp: ''!
shutDown: aboutToQuit

	aboutToQuit ifTrue: [ self reset ]! !

!OmStoreFactory class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting

	isImageStarting ifTrue: [ self reset ]! !

!OmStoreFactory class methodsFor: 'class initialization' stamp: ''!
reset
	"
	self reset
	"

	current := nil! !

!OmStoreFactoryTest commentStamp: ''!
An OmNullStoreTest is a test class for testing the behavior of OmNullStore!
!OmStoreFactoryTest methodsFor: 'tests' stamp: ''!
testNullStore
	| factory store |
	factory := OmStoreFactory new.
	store := factory null.
	self assertEmpty: store entries.
	self assert: factory null == store description: 'Singleton'! !

!OmStoreFactoryTest methodsFor: 'resources' stamp: ''!
aStoreName

	^ 'aTestGlobalName'! !

!OmStoreFactoryTest methodsFor: 'tests' stamp: ''!
testStoreNamed

	| factory store storeAgain anEntry |
	factory := OmStoreFactory new.
	store := factory named: self aStoreName.
	storeAgain := factory named: self aStoreName.
	self assert: storeAgain == store description: 'Singleton'.

	anEntry := OmEntry content: 42.
	store newEntry: anEntry.
	self assert: (store entries includes: anEntry).

	"tearDown in test"
	store flush.
	store ensureDeleteFile.! !

!OmStoreTest commentStamp: ''!
I am an abstract test case for Ombu stores. My subclasses implement a hook to answer new concrete stores.!
!OmStoreTest methodsFor: 'resources' stamp: ''!
setUpStore
	^ self subclassResponsibility! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testEntryForAbsentEntry
	| isPresent isAbsent |
	anEntry := OmEntry content: 42.
	
	store newEntry: anEntry.

	self beforeAndAfterFlushStore: [
		isPresent := false.
		isAbsent := false.	

		otherStore 
			entryFor: (store referenceTo: anEntry)
			ifPresent: [ :e | isPresent := true ] 
			ifAbsent: [ isAbsent := true ].

		self deny: isPresent.
		self assert: isAbsent ]! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testHeadReferenceForEmptyStore

	self assert: store headReference equals: OmNullReference uniqueInstance.! !

!OmStoreTest methodsFor: 'running' stamp: ''!
tearDown
	
	store flush.
	otherStore flush.
	super tearDown! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testNewEntry
	anEntry := OmEntry content: 42.
	
	store newEntry: anEntry.
	
	self beforeAndAfterFlushStore: [
		self 
			assert: (store entries collect: #content as: Array)
			equals: #(42) ]! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testEntriesDo
	1 to: 7 do: [ :each | store newEntry: (OmEntry content: each) ].

	self beforeAndAfterFlushStore: [
		| contents |
		contents := Array streamContents: [ :stream | 
			store entriesDo: [ :entry | stream nextPut: entry content ] ].

		self assert: contents equals: (1 to: 7) asArray ]! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testHeadReference
	1 to: 7 do: [ :each | store newEntry: (OmEntry content: each) ].

	self beforeAndAfterFlushStore: [
		| lastEntry |
		lastEntry := store entries detect: [ :entry | entry content = 7 ].
		self
			assert: store headReference
			equals: (store referenceTo: lastEntry) ]! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testRefreshEmpty
	store refresh.

	self assertEmpty: store entries! !

!OmStoreTest methodsFor: 'resources' stamp: ''!
directoryForTests

	^ FileLocator temp asFileReference / 'ombu-tests'! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testWritingFileReference

	anEntry := OmEntry content: 42.
	store newEntry: anEntry.
	store flush.
	
	self assert: store writingFileReference isFile.! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testEntryForPresentEntry
	| isPresent isAbsent |
	anEntry := OmEntry content: 42.
	
	store newEntry: anEntry.

	self beforeAndAfterFlushStore: [
		isPresent := false.
		isAbsent := false.	

		store 
			entryFor: (store referenceTo: anEntry)
			ifPresent: [ :e | isPresent := true ] 
			ifAbsent: [ isAbsent := true ].

		self assert: isPresent.
		self deny: isAbsent ]! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testMultipleEntries
	1 to: 7 do: [ :each | store newEntry: (OmEntry content: each) ].
	
	self beforeAndAfterFlushStore: [
		self
			assert: (store entries collect: #content as: Set)
			equals: (1 to: 7) asSet ]! !

!OmStoreTest methodsFor: 'running' stamp: ''!
beforeAndAfterFlushStore: aBlock 

	aBlock value.
	store flush. "Reason: It's worth testing again, after flush."
	aBlock value.! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testReferenceTo
	anEntry := OmEntry content: 42.
	
	store newEntry: anEntry.
	
	self beforeAndAfterFlushStore: [
		aReference := store referenceTo: anEntry.

		self assert: (aReference isKindOf: OmReference).
		self deny: aReference isNull ]! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testEntryForNullReference
	| isPresent isAbsent |

	self beforeAndAfterFlushStore: [
		isPresent := false.
		isAbsent := false.	

		otherStore 
			entryFor: OmNullReference uniqueInstance
			ifPresent: [ :e | isPresent := true ] 
			ifAbsent: [ isAbsent := true ].

		self deny: isPresent.
		self assert: isAbsent ]! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testEntriesCount
	self assert: store entriesCount equals: 0.
	
	store newEntry: (OmEntry content: 42).
	store newEntry: (OmEntry content: 43).
	
	self beforeAndAfterFlushStore: [
		self assert: store entriesCount equals: 2 ].! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testEntryReferences
	| entryReferences entries |

	1 to: 7 do: [ :each | store newEntry: (OmEntry content: each) ].

	entryReferences := store entryReferences.
	entries := store entries.
	
	entryReferences withIndexDo: [:each :index |	
		store
			entryFor: each
			ifPresent: [:entry | 
				self assert: entry equals: (entries at: index) 
				"They must have the same order" ]
			ifAbsent: [ self fail ] ].

	self assert: entryReferences size equals: 7. "To be sure it tests something"! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testRefreshNotEmpty
	anEntry := OmEntry content: 42.
	
	store newEntry: anEntry.
	
	store refresh.
	
	self 
		assert: (store entries collect: #content as: Array)
		equals: #(42)! !

!OmStoreTest methodsFor: 'resources' stamp: ''!
setUpOtherStore
	^ self setUpStore! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testEntries
	self assertEmpty: store entries! !

!OmStoreTest methodsFor: 'tests' stamp: ''!
testFirstEntryIfAbsent

	| absent |
	absent := false.
	store firstEntryIfAbsent: [ absent := true ].
	self assert: absent.
	
	store newEntry: (OmEntry content: 42).
	store newEntry: (OmEntry content: 43).
	
	self beforeAndAfterFlushStore: [
		self 
			assert: (store firstEntryIfAbsent: [ self fail ])
			equals: store entries first ]! !

!OmStoreTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	store := self setUpStore.
	otherStore := self setUpOtherStore.! !

!OmStoreTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #OmStoreTest! !

!OmSuffixAfterDotStrategy commentStamp: ''!
I generate a name by attaching a suffix after last dot in the name received as argument. 

My subclasses implement the concrete ways to do it.!
!OmSuffixAfterDotStrategy methodsFor: 'accessing' stamp: ''!
nextTo: aName in: aDirectory
	
	^ String streamContents: [ :stream |
		stream
			nextPutAll: (aName copyUpToLast: $.);
			nextPut: $.;
			nextPutAll: self nextSuffix ]! !

!OmSuffixAfterDotStrategy methodsFor: 'accessing' stamp: ''!
nextSuffix

	^ self subclassResponsibility! !

!OmTimeStampSuffixStrategy commentStamp: ''!
I attach a timestamp as a suffix to the name (after last _).!
!OmTimeStampSuffixStrategy methodsFor: 'accessing' stamp: ''!
nextSuffix

	^ DateAndTime now asNanoSeconds printStringHex! !

!OmTimeStampSuffixStrategyTest commentStamp: ''!
An OmTimeStampSuffixStrategyTest is a test class for testing the behavior of OmTimeStampSuffixStrategy!
!OpalCompiler commentStamp: ''!
I provide the API of the whole Compiler Package for the case that the input is sourcecode.
(if there is already and AST, call #generate (to compile) or #evaluate directly on the node)

a pre-configures compiler instance can be requested with: 
 - Smalltalk compiler
 - a Class compiler 

The compiler instance (actually: the compilation context) needs to be setup. See #class: #source: #noPattern: #requestor: for the most important accessors (more are in the accessing protocol). 

See the class comment of CompilationContext for more information.

The final step is one of three actions:

-> parsing: parse source and return an AST.
-> compile: parse and compile, return a CompiledMethod 
-> evaluate: parse, compile, evaluate and return result

Example:

Smalltalk compiler
	source: 'test 1+2';
	class: Object;
	compile.

This returns a CompiledMethod.!
!OpalCompiler methodsFor: 'accessing' stamp: ''!
requestor: aRequestor
	self compilationContext requestor: aRequestor.
	self compilationContext interactive: (self isInteractiveFor: aRequestor).! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
logged: aBoolean
	self compilationContext logged:  aBoolean.! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
parse
	[ast := self compilationContext noPattern 
		ifTrue: [ self parseExpression ]
		ifFalse: [ self parseMethod ].
	ast methodNode compilationContext: self compilationContext.
	self doSemanticAnalysis]
	on: ReparseAfterSourceEditing 
			do: 
			[  	:notification | 
				self source: notification newSource. 
				notification retry.  
			]. 
	^ast! !

!OpalCompiler methodsFor: 'private' stamp: ''!
parseMethod
	^ (self compilationContext optionParseErrors or: [ self allowParseErrorsNonInteractive ])
		ifTrue: [self parserClass parseFaultyMethod: source contents]
		ifFalse: [self parserClass parseMethod: source contents]! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
transformDoit
	"if we compile an expression, we wrap it in a method here"
	self compilationContext noPattern ifFalse: [ ^ast ].
		
	ast := context 
		ifNil: [ast asDoit] 
		ifNotNil: [ast asDoitForContext: context].
	"we need to set the compilation context in the new method node"
	ast compilationContext: self compilationContext.
	context ifNotNil: [ast methodClass: context receiver class].
	self doSemanticAnalysis.
	^ast! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
parse: textOrString 
	
	^self
		source: textOrString;
		parse! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
compilationContext: anObject
	compilationContext := anObject! !

!OpalCompiler methodsFor: 'plugins' stamp: ''!
compilationContextClass: aClass
	compilationContextClass := aClass.! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
environment: anEnvironment
	"Set the environment (dictionary of class, traits and globals) used during the compilation"
	self compilationContext environment: anEnvironment! !

!OpalCompiler methodsFor: 'plugins' stamp: ''!
addPlugin: aClass 
	compilationContext addASTTransformationPlugin: aClass! !

!OpalCompiler methodsFor: 'private' stamp: ''!
getSourceFromRequestorSelection
    | selectionString |
    "if the requestor can provide a selection, we use that as the source"
     (self compilationContext requestor respondsTo: #selection) ifFalse: [ ^self ].
    
    selectionString := self compilationContext requestor selection asString.
    selectionString isEmptyOrNil ifTrue: [ ^self ].
    self source: selectionString.! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
context: aContext
	context  := aContext! !

!OpalCompiler methodsFor: 'plugins' stamp: ''!
compilationContextClass
	^compilationContextClass ifNil: [ CompilationContext  ]! !

!OpalCompiler methodsFor: 'private' stamp: ''!
isInteractiveFor: aRequestor
	"the requester can override if the compiler is interactive or not"
	aRequestor ifNil: [^ false ].
	
	^ (aRequestor respondsTo: #interactive)
		ifTrue: [ aRequestor interactive ]
		ifFalse: [ true ]! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
compilationContext
	^ compilationContext ifNil: [ compilationContext := self compilationContextClass default ]! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
compileMethod
	| cm |
	self parse.
	self callPlugins.  
		cm := compilationContext optionEmbeddSources
			ifTrue: [ ast generateWithSource ]
			ifFalse: [ast generate: self compilationContext compiledMethodTrailer   ].
	^cm! !

!OpalCompiler methodsFor: 'plugins' stamp: ''!
requestorScopeClass: aClass 
	"clients can set their own subclass of OCRequestorScope if needed"
	self compilationContext requestorScopeClass: aClass! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
class: aClass
	self compilationContext class: aClass.! !

!OpalCompiler methodsFor: 'private' stamp: ''!
doSemanticAnalysis
	^[ast doSemanticAnalysis] 
		on: OCSemanticError 
		do: [ :ex | ex defaultAction. ^ self compilationContext failBlock value ]! !

!OpalCompiler methodsFor: 'private' stamp: ''!
allowParseErrorsNonInteractive
	^self compilationContext optionParseErrorsNonInteractiveOnly and: [ self isInteractive not ]! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
bindings: aDictionary
	"allows to define additional binding, note: Globals are not shadowed"
	self compilationContext bindings: aDictionary! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
source: aString
	source := aString readStream.! !

!OpalCompiler methodsFor: 'plugins' stamp: ''!
parserClass
	^self compilationContext parserClass! !

!OpalCompiler methodsFor: 'private' stamp: ''!
compileDoit
	| cm |
	"We need to first compile with the AST having the text 
	offset of the original selected code. This way the #location 
	will be correct regarding the requestor"
	self parseDoIt.
	self callPlugins.
	cm := ast generateWithSource.
	"We need to re-parse so that the AST is in sync with the 
	bytecode to be able to debug the doit. Recompile not needed"
	ast := RBParser parseMethod: ast formattedCode.
	ast compilationContext: self compilationContext.
	self doSemanticAnalysis.
	"we store the ast in the doit method so that the debugger can read variables from the requestor"
	cm propertyAt: #ast put: ast.
	^cm! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
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 parserClass parseMethodPattern: aString] on: Error do: [nil].! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
format: textOrString 
	
	^self
		source: textOrString;
		format! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
evaluate
	"Compiles the sourceStream into a parse tree, then generates code into
	 a method. If aContext is not nil, the text can refer to temporaries in that
	 context (the Debugger uses this). If aRequestor is not nil, then it will receive
	 a notify:at: message before the attempt to evaluate is aborted. Finally, the 
	 compiled method is invoked from here via withArgs:executeMethod:, hence
	 the system no longer creates Doit method litter on errors."

	| value |
	self noPattern: true.
	self getSourceFromRequestorSelection.
	self class: (context ifNil: [ receiver class ] ifNotNil: [ context compiledCode methodClass ]).
	value := [ receiver withArgs: (context ifNil: [ #() ] ifNotNil: [ {context} ]) executeMethod: self compileDoit]
		on: SyntaxErrorNotification 
		do: [ :exception | 
			self compilationContext requestor
                ifNotNil: [
						self compilationContext requestor 
							notify: exception errorMessage , ' ->'
							at: exception location
							in: exception errorCode.
                    self compilationContext failBlock value ]
                ifNil: [ exception pass ]].
	self logDoIt.
	^ value! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
options: anOptionsArray
	self compilationContext parseOptions: anOptionsArray! !

!OpalCompiler methodsFor: 'plugins' stamp: ''!
encoderClass: aClass 
	self compilationContext encoderClass: aClass! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
compile
	^[compilationContext noPattern 
		ifTrue: [ self compileDoit ]
		ifFalse: [ self compileMethod ]]
		on: SyntaxErrorNotification 
		do: [ :exception | 
			self compilationContext requestor
                ifNotNil: [
						self compilationContext requestor 
							notify: exception errorMessage , ' ->'
							at: exception location
							in: exception errorCode.
                    ^ self compilationContext failBlock value ]
                ifNil: [ exception pass ]].! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
failBlock: aBlock
	self compilationContext failBlock: aBlock.! !

!OpalCompiler methodsFor: 'private' stamp: ''!
parseExpression
	^ (self compilationContext optionParseErrors or: [ self allowParseErrorsNonInteractive ])
		ifTrue: [self parserClass parseFaultyExpression: source contents]
		ifFalse: [self parserClass parseExpression: source contents]! !

!OpalCompiler methodsFor: 'private' stamp: ''!
logDoIt
	self compilationContext logged ifFalse: [ ^self ].
	Smalltalk globals 
			at: #SystemAnnouncer 
			ifPresent: [ :sysAnn | 
				sysAnn uniqueInstance evaluated: source contents context: context ]! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
format
	^self parse formattedCode.! !

!OpalCompiler methodsFor: 'testing' stamp: ''!
isInteractive
	^self isInteractiveFor: compilationContext requestor! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
evaluate: textOrString 
	
	^self
		source: textOrString;
		evaluate! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
compiledMethodClass: aClass 
	
	self compilationContext compiledMethodClass: aClass! !

!OpalCompiler methodsFor: 'private' stamp: ''!
parseDoIt
	"we parse doits without doing name analysis here, it is done in #transformDoit"
	ast := self parseExpression.
	^self transformDoit! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
receiver: anObject
	receiver := anObject.! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
compile: textOrString 
	
	^self
		source: textOrString;
		compile.! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
parseLiterals: aString
	^self parserClass parseLiterals: aString! !

!OpalCompiler methodsFor: 'private' stamp: ''!
callPlugins
	| plugins  |
	plugins := compilationContext astTransformPlugins ifEmpty: [ ^self ].
	plugins sort: [:a :b | a priority > b priority]. "priority 0 is sorted last"
	plugins do: [ :each | ast := each transform: ast].! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
productionEnvironment: anObject
	compilationContext productionEnvironment: anObject! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
noPattern: aBoolean
	self compilationContext noPattern: aBoolean.
	"when we compile an expression, embedd sources, as the resulting method will never be installed"
	compilationContext parseOptions: #(+ #optionEmbeddSources).! !

!OpalCompiler methodsFor: 'public access' stamp: ''!
decompileMethod: aCompiledMethod
	^ Smalltalk globals 
		at: #FBDDecompiler  
		ifPresent: [ :decompilerClass | [ decompilerClass new decompile: aCompiledMethod ]
			on: Error 
			do: [ RBMethodNode errorMethodNode: aCompiledMethod selector errorMessage: 'Decompilation failed'.  ] ]
		ifAbsent: [ RBMethodNode errorMethodNode: aCompiledMethod selector errorMessage: 'No decompiler available'. ]! !

!OpalCompiler methodsFor: 'accessing' stamp: ''!
compiledMethodTrailer: bytes
	self compilationContext compiledMethodTrailer: bytes! !

!OpalCompiler class methodsFor: 'public' stamp: ''!
isActive
	^Smalltalk compilerClass == self! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
overlayStep2Recompile
	"now we recompile the classes in the environment with itself as an overlay"
	self overlayEnvironment valuesDo: [ :class | 
			class methodsDo: [ :method | 
					| newMethod |
					newMethod := class compiler
						bindings: self overlayEnvironment;
						compile: method sourceCode.
					class addSelectorSilently: method selector withMethod: newMethod ] ]! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
createAndEnableOverlay
	^self overlayIsActive! !

!OpalCompiler class methodsFor: 'options' stamp: ''!
compilerSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #compiler)
		label: 'Compiler';
		description: 'All Compiler Settings';
		with: [ 
				(aBuilder setting: #createAndEnableOverlay)
						label: 'Compiler Overlay Environment';
						target: self;
						default: false;
						description: 'Create a overlay environment for the OpalCompiler package and sets this copy as the global compiler. After this all classes in the package OpalCompiler are not used anymore outside of tests.  Simplifies changing the compiler'.
				CompilationContext compilerSettingsOn: aBuilder]! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
createAndEnableOverlay: aBoolean
	
	aBoolean = self overlayIsActive ifTrue: [ ^self ].
	aBoolean 
		ifTrue: [ self startUsingOverlayForDevelopment   ]
		ifFalse: [ self stopUsingOverlayForDevelopment   ]! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
overlayStep5UpdateInstances
	"transform existing instances to be instances of the overlay"
	self compilerClasses do: [ :class |
		class allInstances do: [ :object | 
			(self overlayEnvironment at: class name) adoptInstance: object ]]! !

!OpalCompiler class methodsFor: 'old - deprecated' stamp: ''!
evaluate: textOrString
	self
		deprecated: 'Please use new compiler API instead'
		transformWith: '`@receiver evaluate: `@statements1 ' -> '`@receiver new source: `@statements1; evaluate'.
	^ self new
		source: textOrString;
		evaluate! !

!OpalCompiler class methodsFor: 'public' stamp: ''!
register 

	SmalltalkImage current compilerClass: self! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
stopUsingOverlayForDevelopment
	"set compiler back to normal and throw away overlay environment"

	<script>
	SmalltalkImage compilerClass: nil.
	overlayEnvironment := nil.
	ASTCache reset! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
overlayEnvironment
	^overlayEnvironment ifNil: [ overlayEnvironment := Dictionary new ]! !

!OpalCompiler class methodsFor: 'public' stamp: ''!
recompileAll
	"Recompile all classes and traits in the system."

	Smalltalk image recompile! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
compilerClasses
	"here the classes for the overlay can changed. the default is just the compiler"
	^self package definedClasses
	
	"Compiler and AST:
	self package definedClasses, RBProgramNode package definedClasses, {TRBProgramNodeVisitor}
	"! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
overlayStep4SetImageCompiler
	"make the copy the default compiler for the image"
	SmalltalkImage compilerClass: (self overlayEnvironment at: #OpalCompiler).
	ASTCache reset.! !

!OpalCompiler class methodsFor: '*Deprecated10' stamp: ''!
debuggerMethodMapForMethod: aMethod
	self deprecated: 'please use the reflective API directly to read variables!!'.
	^ DebuggerMethodMapOpal forMethod: aMethod! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
startUsingOverlayForDevelopment
	"this method sets up an overlay so we can change the compiler package without breaking the compiler"

	<script>
	"We copy all compiler classes into the overlayEnvironment, recompile to update referenced classes,
	fix the superclasses and finaly set the compiler overlay as the image default compiler."
	self 
		overlayStep1CopyClasses;
		overlayStep2Recompile;
		overlayStep3FixSuperclassPointers;
		overlayStep4SetImageCompiler;
		overlayStep5UpdateInstances! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
overlayStep3FixSuperclassPointers
	"make sure superclass pointers are correct"
    self overlayEnvironment valuesDo: [ :class | 
        (class isTrait not and: [self overlayEnvironment includesKey: class superclass name]) 
				ifTrue: [ class superclass: (self overlayEnvironment at: class superclass name)]]! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
overlayStep1CopyClasses
	"now we put a copy of all the classes into the environment"
	self compilerClasses do: [ :class | self overlayEnvironment at: class name put: class copy ]! !

!OpalCompiler class methodsFor: 'overlay' stamp: ''!
overlayIsActive
	^overlayEnvironment notNil! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testEvaluateWithBindings
	| result |
	result := Smalltalk compiler
		bindings: {(#a -> 3)} asDictionary;
		evaluate: '1+a'.
	self assert: result equals: 4! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testArrayEvaluateWithBindingsWithUppercaseName
	| result |
	result := Smalltalk compiler
		bindings: {(#MyVar -> 3)};
		evaluate: '1+MyVar'.
	self assert: result equals: 4! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testCompilerUsingCleanBlockClosureHasBlockAsLiteral

	| compiler method |
	compiler := Smalltalk compiler.
	compiler compilationContext compilerOptions:
		#(+ optionCleanBlockClosure ).

	method := compiler compile: 'test #(1 2 3) do: [:e | e + 1]'.

	self assert: method literals second isEmbeddedBlock.
	self assert: method literals second class equals: CleanBlockClosure! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testBindingsWriteGlobals
	| result |
	result := Smalltalk compiler
		 bindings: {(#Object -> Point)} asDictionary;
       evaluate: 'Object := 42'.
	self assert: result equals: 42.! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testArrayBindingsWithUppercaseNameDoOverwriteGlobals
	| result |
	result := Smalltalk compiler
		bindings: {(#UndefinedObject -> Object)};
		evaluate: 'UndefinedObject class'.
	self assert: result equals: Object class! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testArrayEvaluateWithBindingsReadGlobal
| result |
	result := Smalltalk compiler
	bindings: {(#a -> 3)};
	evaluate: 'OrderedCollection'.
	self assert: result equals: OrderedCollection! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testBindingsWithUppercaseNameDoOverwriteGlobals
	| result |
	result := Smalltalk compiler
		bindings: {(#UndefinedObject -> Object)} asDictionary;
		evaluate: 'UndefinedObject class'.
	self assert: result equals: Object class! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testArrayEvaluateWithBindings
	| result |
	result := Smalltalk compiler
		bindings: {(#a -> 3)};
		evaluate: '1+a'.
	self assert: result equals: 4! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testEvaluateWithBindingsSelfSuperThisContext
	| result |

	"via #bindings: we can overwrite even self, super and thisContext"
	result := Smalltalk compiler
		bindings: {(#self -> 3)} asDictionary;
		evaluate: '1+self'.
	self assert: result equals: 4.
	
	result := Smalltalk compiler
		bindings: {(#super -> 3)} asDictionary;
		evaluate: '1+super'.
	self assert: result equals: 4.
	
	result := Smalltalk compiler
		bindings: {(#thisContext -> 3)} asDictionary;
		evaluate: '1+thisContext'.
	self assert: result equals: 4! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testArrayBindingsWriteGlobals
	| result |
	result := Smalltalk compiler
		 bindings: {(#Object -> Point)};
       evaluate: 'Object := 42'.
	self assert: result equals: 42.! !

!OpalCompilerTest methodsFor: 'tests - bindings' stamp: ''!
testEvaluateWithBindingsWithUppercaseName
	| result |
	result := Smalltalk compiler
		bindings: {(#MyVar -> 3)} asDictionary;
		evaluate: '1+MyVar'.
	self assert: result equals: 4! !

!OpalCompilerTest methodsFor: 'tests' stamp: ''!
testCompileWithNilClass
	"we shoud use UndefinedObject if the class is nil"
	| method |
	method := Smalltalk compiler compile: 'tst 1+2'.
	self assert: method methodClass equals: UndefinedObject.! !

!OpalCompilerTest methodsFor: 'tests' stamp: ''!
testCompileEmbeddsSource
	| result |
	result := Smalltalk compiler
		class: UndefinedObject;
		options: #( + #optionEmbeddSources );
		compile: 'tt ^3+4'.
	self assert: (result valueWithReceiver: nil arguments: #()) equals: 7.
	self deny: result trailer hasSourcePointer. "no sourcePointer"
	self assert: result trailer hasSource.		 "but source embedded"
	
	result := Smalltalk compiler
		class: UndefinedObject;
		options: #( - #optionEmbeddSources );
		compile: 'tt ^3+4'.
	self assert: (result valueWithReceiver: nil arguments: #()) equals: 7.
	self deny: result trailer hasSourcePointer. "no sourcePointer"
	self deny: result trailer hasSource.			 "and source embedded"! !

!OpenToolTest commentStamp: ''!
SUnit tests for opening of tools!
!OpenToolTest methodsFor: 'tests - inspect' stamp: ''!
testInspectInteger
	| inspector |
	inspector := self openInspectorOn: 1.
	inspector changed.
	inspector close! !

!OpenToolTest methodsFor: 'tests - inspect' stamp: ''!
testInspectTraitClass
	| inspector |
	inspector := self openInspectorOn: TSortable.
	inspector changed.
	inspector close! !

!OpenToolTest methodsFor: 'tests - browse' stamp: ''!
testOpenBrowseOnInstalledTraitMethod
	| browser |
	browser := (Class>>#hasClassSide) browse.
	browser changed.
	browser close.! !

!OpenToolTest methodsFor: 'utilities' stamp: ''!
openInspectorOn: anObject

	^ Smalltalk tools inspector inspect: anObject! !

!OpenToolTest methodsFor: 'tests - inspect' stamp: ''!
testInspectArray
	| inspector |
	inspector := self openInspectorOn: (1 to: 1000) asArray.
	inspector changed.
	inspector close.! !

!OpenToolTest methodsFor: 'tests - inspect' stamp: ''!
testInspectDictionary
	| inspector |
	inspector := self openInspectorOn: Dictionary new.
	inspector changed.
	inspector close! !

!OpenToolTest methodsFor: 'tests - senders' stamp: ''!
testSendersOfAt
	| senders |
	senders := SystemNavigation default browseAllSendersOf: #name.
	senders changed.
	senders close.! !

!OpenToolTest methodsFor: 'tests - browse' stamp: ''!
testOpenBrowseOnClass
	| browser |
	browser := Object browse.
	browser changed.
	browser close.! !

!OpenToolTest methodsFor: 'tests - browse' stamp: ''!
testOpenBrowseOnTraitMethod
	| browser |
	browser := (TSortable>>#isSorted) browse.
	browser changed.
	browser close.! !

!OpenToolTest methodsFor: 'tests - browse' stamp: ''!
testOpenBrowseOnMethod
	| browser |
	browser := (Object>>#yourself) browse.
	browser changed.
	browser close.! !

!OpenToolTest methodsFor: 'tests - inspect' stamp: ''!
testInspectClass
	| inspector |
	inspector := self openInspectorOn: Object.
	inspector changed.
	inspector close! !

!OrderedCollection commentStamp: ''!
I am one of the most common collection. I can grow, and elements can be added sequentially by the user.  
I am more general than Array; my size grows on demand. I store data inside an Array and remember the first and last index. If I need, I can replace this Array by a larger one.

I am usually used to store an unknown amount of objects. When my contents size will not move, one can send me the #asArray message to get better performances, but I cannot grow anymore (add: and remove: are not supported on Array).

### Public API and Key Messages

- #new / #withAll: aCollection / #with: anObject 	are common constructors
- #add: anObject / #at: anIndex put: anObject / #at: anIndex ifAbsentPut: anObject 	allow to add new elements to myself.
- #remove: anObject / #removeIndex: anIndex 	allow to remove an element.
- #do: aBlock / #collect: aBlock / #select: aBlock / #reject: aBlock 	are common iterators.

### Examples	

```	
	"There is many ways to create an OrderedCollection, here are some:"
	ordCol := OrderedCollection new.
	ordCol
		add: 'one';
		add: 'two';
		addFirst: 'zero';
		addLast: 'three'.
	ordCol.		"returns: an OrderedCollection('zero' 'one' 'two' 'three')"

	"or"
	ordCol := OrderedCollection with: 'one' with: 'two' with: 'three'.
	ordCol.		"returns: an OrderedCollection('one' 'two' 'three')"

	"or from an other collection"
	ordCol := OrderedCollection withAll: #('one' 'two' 'three').
	ordCol.		"returns: an OrderedCollection('one' 'two' 'three')"

	"or"
	#('one' 'two' 'three') asOrderedCollection.

	"Some manipulations"
	ordCol := OrderedCollection ofSize: 2.
	ordCol
		at: 1 put: 'one';
		at: 2 put: 'two';
		at: 2 ifAbsentPut: 'three'.
	ordCol.		"returns: an OrderedCollection('one' 'two')"
	ordCol
		remove: 'two';
		removeIndex: 1.
	ordCol.		"returns:  an OrderedCollection()"

	"A last one"
	ordCol := OrderedCollection with: $b with: $c with: $a.
	ordCol sort: [ :first :second | first < second ].		"returns: an OrderedCollection($a $b $c)"
	ordCol collect: [ :element | element asUppercase ].		"returns:  an OrderedCollection($A $B $C)"
	ordCol select: [ :element | element >= $b ].		"returns:  an OrderedCollection($b $c)"
	ordCol do: [ :element | element inspect ].
	ordCol asArray		"returns: #($a $b $c)"
``` 

###Internal Representation and Key Implementation Points.
Instance Variables
- array:			<Array> 		An Array where I store my elements. If I need a bigger one I can remove this one and create a new one.
- firstIndex:		<Integer> 	The index of my first element.
- lastIndex:		<Integer> 	The index of my last element.

I store my elements inside an array. This array is AT LEAST of the size of my elements. If someone adds an element and my array is not large enough, I remove it and I create a new one larger with the same elements (usually, the size double).!
!OrderedCollection methodsFor: 'removing' stamp: 'nil'!
removeDuplicates
	"Remove the copies of elements, but keep the same order"
	
	"#(7 42 7 42 9) asOrderedCollection removeDuplicates asArray >>> #(7 42 9)"
	"#(1 2 3) asOrderedCollection removeDuplicates asArray >>> #(1 2 3)"

	| iterator seen |
	self ifEmpty: [ ^ self ].
	iterator := 1.
	seen := Set new.
	[ iterator <= self size ]
		whileTrue: [ | each |
			each := self at: iterator.
			(seen includes: each)
				ifTrue: [ self removeAt: iterator ]
				ifFalse: [ seen add: each. iterator := iterator + 1. ].
	 ]! !

!OrderedCollection methodsFor: 'removing' stamp: 'nil'!
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: 'private' stamp: 'nil'!
ensureBoundsFrom: fromIndex to: toIndex
	(fromIndex < 1)
		ifTrue: [^self errorSubscriptBounds: fromIndex].
	(toIndex + firstIndex - 1 > lastIndex)
		ifTrue: [^self errorSubscriptBounds: toIndex].! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'nil'!
reverseDo: aBlock
	"Override the superclass for performance reasons."

	lastIndex to: firstIndex by: -1 do: [ :index | 
		aBlock value: (array at: index) ]! !

!OrderedCollection methodsFor: '*Fuel-Core' stamp: ''!
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: 'private' stamp: 'nil'!
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: 'enumerating' stamp: 'nil'!
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: 'adding' stamp: 'nil'!
add: newObject before: oldObject 
	"Add the argument, newObject, as an element of the receiver. Put it in 
	the sequence just preceding oldObject. Answer newObject."
	
	"(OrderedCollection new add: 42; add: 41 before: 42; yourself) asArray >>> #(41 42)"
	
	| index |
	index := self find: oldObject.
	self insert: newObject before: index.
	^newObject! !

!OrderedCollection methodsFor: 'private' stamp: 'nil'!
makeRoomAtLast
	"Make some empty slots at the end of the array. If we have more than 50% free space, then just move the elements, so that the last 50% of the slots are free, otherwise add new free slots to the end by growing. Precondition: lastIndex = array size"
	
	| tally newFirstIndex newLastIndex |
	tally := self size.
	tally * 2 >= lastIndex ifTrue: [ ^self growAtLast ].
	tally = 0 ifTrue: [ ^self resetTo: 1 ].
	newLastIndex := lastIndex // 2.
	newFirstIndex := newLastIndex - lastIndex + firstIndex.
	array 
		replaceFrom: newFirstIndex
		to: newLastIndex
		with: array
		startingAt: firstIndex.
	array from: newLastIndex + 1 to: lastIndex put: nil.
	firstIndex := newFirstIndex.
	lastIndex := newLastIndex! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'nil'!
do: aBlock
	"Override the superclass for performance reasons."

	firstIndex to: lastIndex do: [ :index | 
		aBlock value: (array at: index) ]! !

!OrderedCollection methodsFor: 'adding' stamp: 'nil'!
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: 'private' stamp: 'nil'!
setContents: anArray
	array := anArray.
	firstIndex := 1.
	lastIndex := array size.! !

!OrderedCollection methodsFor: 'adding' stamp: 'nil'!
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: 'enumerating' stamp: 'nil'!
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:."

	"(#(1 2 3) asOrderedCollection collect: [ :v | v * 10 ]) asArray >>> #(10 20 30)"
	"(#(1 2 3) asOrderedCollection collect: [ :v | 10 ]) asArray >>> #(10 10 10)"
	
	| newCollection |
	newCollection := self species new: self size.
	firstIndex to: lastIndex do:
		[:index |
		newCollection addLast: (aBlock value: (array at: index))].
	^ newCollection! !

!OrderedCollection methodsFor: 'private' stamp: 'nil'!
resetTo: index
	firstIndex := index.
	lastIndex := firstIndex - 1! !

!OrderedCollection methodsFor: 'removing' stamp: 'nil'!
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: 'private' stamp: 'nil'!
compact
	"remove all empty slots to the end of array, while keeping the empty slots at the front."

    | newArray |
    newArray := self class arrayType new: lastIndex.
    newArray 
        replaceFrom: firstIndex
        to: lastIndex
        with: array
        startingAt: firstIndex.
    array := newArray! !

!OrderedCollection methodsFor: 'adding' stamp: 'nil'!
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: 'private' stamp: 'nil'!
growAtFirst
	"Add new empty slots to the front of array, while keeping the empty slots at the end."
	
	"OrderedCollection new capacity >>> 10"
	"(OrderedCollection new growAtFirst; capacity) >>> 20"
	

	| 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: 'enumerating' stamp: 'nil'!
select: selectBlock thenCollect: collectBlock
    " Optimized version Collection>>#select:thenCollect: "

	| newCollection element |

    newCollection := self copyEmpty.

    firstIndex to: lastIndex do: [ :index |
		element := array at: index.
		(selectBlock value: element) 
			ifTrue: [ newCollection addLast: (collectBlock value: element) ]].

    ^ newCollection! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'nil'!
with: otherCollection collect: twoArgBlock 
	"Collect and return the result of evaluating twoArgBlock with 
	corresponding elements from this collection and otherCollection."
	| result |
	otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size'].
	result := self species new: self size.
	1 to: self size do:
		[:index | result addLast: (twoArgBlock value: (self at: index)
									value: (otherCollection at: index))].
	^ result! !

!OrderedCollection methodsFor: 'adding' stamp: 'nil'!
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: 'private' stamp: 'nil'!
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"
	
	"#(1 2 3) asOrderedCollection capacity >>> 3"
	"#(1 2 3) asOrderedCollection makeRoomAtFirst capacity >>> 6"
	
	| 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: 'accessing' stamp: 'nil'!
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."

	| index |
	anInteger < 1
		ifTrue: [ self errorSubscriptBounds: anInteger ].
	(index := anInteger + firstIndex - 1) > lastIndex
		ifTrue: [ self errorSubscriptBounds: anInteger ].
	^ array at: index put: anObject! !

!OrderedCollection methodsFor: 'splitjoin' stamp: 'nil'!
join: aCollection 
	"Append the elements of the argument, aSequenceableCollection, separating them by the receiver."
	
	| result |
	result := self class new.
	aCollection
		do: [:each | each appendTo: result]
		separatedBy: [self appendTo: result].
	^ result! !

!OrderedCollection methodsFor: 'adding' stamp: 'nil'!
add: newObject after: oldObject 
	"Add the argument, newObject, as an element of the receiver. Put it in 
	the sequence just succeeding oldObject. Answer newObject.
	Raises an error if oldObject is not found"
	
	"(OrderedCollection new add: 41; add: 42 after: 41; yourself) asArray >>>  #(41 42)"
	"(OrderedCollection new add: 41; add: 42 after: 41; add: 43 after: 41; yourself) asArray >>>  #(41 43 42)"
		
	| index |
	index := self find: oldObject.
	self insert: newObject before: index + 1.
	^newObject! !

!OrderedCollection methodsFor: 'copying' stamp: 'nil'!
postCopy
	array := array copy! !

!OrderedCollection methodsFor: 'private' stamp: 'nil'!
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: 'removing' stamp: 'nil'!
removeAll
	"remove all the elements from this collection.
	Keep same amount of storage"
	
	self setCollection: (self class arrayType new: array size)! !

!OrderedCollection methodsFor: 'accessing' stamp: 'nil'!
size
	"Answer how many elements the receiver contains."

	^ lastIndex - firstIndex + 1! !

!OrderedCollection methodsFor: 'copying' stamp: 'nil'!
copyFrom: startIndex to: endIndex 
	"Answer a copy of the receiver that contains elements from position
	startIndex to endIndex."

	^self shallowCopy postCopyFrom: startIndex to: endIndex! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'nil'!
reject: rejectBlock thenCollect: collectBlock
    " Optimized version of Collection>>#reject:thenCollect: "

	| newCollection |

    newCollection := self copyEmpty.

    firstIndex to: lastIndex do: [ :index |
		| element |
		element := array at: index.
		(rejectBlock value: element) 
			ifFalse: [ newCollection addLast: (collectBlock value: element) ]].

    ^ newCollection! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'nil'!
withIndexSelect: elementAndIndexBlock select: selectBlock
	"Optimized version of SequenceableCollection>>#withIndexSelect: "

	"(#('We' 'love' 'pharo!!') asOrderedCollection withIndexSelect: [:value :index | value size - 1 <= index]) >>> (OrderedCollection with: 'We')"

	| newCollection element |
	newCollection := self copyEmpty.
	firstIndex to: lastIndex do: [ :index | 
		(selectBlock value: (element := array at: index) value: index)
			ifTrue: [ newCollection addLast: element ] ].
	^ newCollection! !

!OrderedCollection methodsFor: 'adding' stamp: 'nil'!
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: 'copying' stamp: 'nil'!
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: [^SubscriptOutOfBounds signalFor: startIndex lowerBound: (1 min: self size) upperBound: self size in: self].
		(endIndex between: 1 and: self size) ifFalse: [^SubscriptOutOfBounds signalFor: endIndex lowerBound: (1 min: self size) upperBound: self size in: self]].
	
	"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: 'converting' stamp: 'nil'!
reversed
	"Answer a copy of the receiver with element order reversed.  "
	"#(2 3 4 'fred') asOrderedCollection reversed >>> #('fred' 4 3 2) asOrderedCollection"
	| newCol |
	newCol := self species new.
	self reverseDo:
		[:elem | newCol addLast: elem].
	^ newCol! !

!OrderedCollection methodsFor: 'private' stamp: 'nil'!
growAtLast
	"Add new empty slots to the end of array, while keeping the empty slots at the front."

	"OrderedCollection new capacity >>> 10"
	"(OrderedCollection new growAtLast; capacity) >>> 20"

	| newArray |
	newArray := self class arrayType new: (array size * 2 max: 1).
	newArray 
		replaceFrom: firstIndex
		to: lastIndex
		with: array
		startingAt: firstIndex.
	array := newArray! !

!OrderedCollection methodsFor: 'adding' stamp: 'nil'!
add: newObject
	"Add a new object at the end of the collection, and returns the object itself"
	"((OrderedCollection new add: 42; yourself) add: 43; yourself) asArray >>> #(42 43)"
	
	"Add returns the object itself"
	"(OrderedCollection new add: 42) >>> 42"
	
	"You may want to use yourself to return the collection itself"
	"(OrderedCollection new add: 42; yourself) class >>> OrderedCollection"
	"(OrderedCollection new add: 42; yourself) size >>> 1"
	^self addLast: newObject! !

!OrderedCollection methodsFor: 'private' stamp: 'nil'!
collector  "Private"
	^ array! !

!OrderedCollection methodsFor: 'removing' stamp: 'nil'!
removeAt: index
	| removed |
	removed := self at: index.
	self removeIndex: index + firstIndex - 1.
	^removed! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'nil'!
select: selectBlock 
	"Optimized version of Collection>>#select: "

	| newCollection element |
	
	newCollection := self copyEmpty.
	
	firstIndex to: lastIndex do: [ :index |
		(selectBlock value: (element := array at: index))
			ifTrue: [ newCollection addLast: element ]].
		
	^ newCollection! !

!OrderedCollection methodsFor: 'removing' stamp: 'nil'!
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' stamp: 'nil'!
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: 'sorting' stamp: 'nil'!
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: 'converting' stamp: 'nil'!
asArray
	"Convert an OrderedCollection into an Array."
	"#(a b c) asOrderedCollection asArray >>> #(a b c)"
	"OrderedCollection new class >>> OrderedCollection"
	"OrderedCollection new asArray class >>> Array"
	"(OrderedCollection new add: 42; add: 43; yourself) asArray >>> #(42 43)"
	
	^ (Array new: self size) replaceFrom: 1 to: self size with: array startingAt: firstIndex.! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'nil'!
collect: collectBlock thenSelect: selectBlock
    "Optimized version Collection>>#collect:thenSelect:"

    | newCollection newElement |

    newCollection := self copyEmpty.
    firstIndex to: lastIndex do: [ :index | 
		newElement := collectBlock value: (array at: index).
		(selectBlock value: newElement) 
			ifTrue: [ newCollection addLast: newElement ]].
    ^ newCollection! !

!OrderedCollection methodsFor: 'accessing' stamp: 'nil'!
at: anInteger
	"Answer my element at index anInteger. at: is used by a knowledgeable
	client to access an existing element."
	"((OrderedCollection new add: 34; yourself) at: 1) >>> 34"
	"(#(40 41 42) asOrderedCollection at: 1) >>> 40"
	"(#(40 41 42) asOrderedCollection at: 2) >>> 41"
	"(#(40 41 42) asOrderedCollection at: 3) >>> 42"

	| index |
	anInteger < 1
		ifTrue: [ self errorSubscriptBounds: anInteger ].
	(index := anInteger + firstIndex - 1) > lastIndex
		ifTrue: [ self errorSubscriptBounds: anInteger ].
	^ array at: index! !

!OrderedCollection methodsFor: 'adding' stamp: 'nil'!
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: 'private' stamp: 'nil'!
setCollection: anArray
	array := anArray.
	self reset! !

!OrderedCollection methodsFor: 'private' stamp: 'nil'!
errorConditionNotSatisfied

	self error: 'no element satisfies condition'! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'nil'!
reject: rejectBlock 
	"Optimized version of Collection>>#reject:"

	| newCollection element |
	
	newCollection := self copyEmpty.
	
	firstIndex to: lastIndex do: [ :index |
		(rejectBlock value: (element := array at: index))
			ifFalse: [ newCollection addLast: element ]].
		
	^ newCollection! !

!OrderedCollection methodsFor: 'initialization' stamp: 'nil'!
reset
	"Quickly remove all elements. The objects will be still referenced, but will not be 	accessible."
	
	self resetTo: 1! !

!OrderedCollection methodsFor: 'removing' stamp: 'nil'!
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: 'copying' stamp: 'nil'!
copyEmpty
	"Answer a copy of the receiver that contains no elements."

	^self species new! !

!OrderedCollection methodsFor: 'copying' stamp: 'nil'!
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: 'adding' stamp: 'nil'!
addAllFirst: anOrderedCollection 
	"Add each element of anOrderedCollection at the beginning of the 
	receiver. Answer anOrderedCollection."
	
	"((OrderedCollection new add: 40; addAllFirst: #(41 42); yourself) asArray) >>  #(41 42 40)"

	anOrderedCollection reverseDo: [:each | self addFirst: each].
	^anOrderedCollection! !

!OrderedCollection methodsFor: 'copying' stamp: 'nil'!
copyWith: newElement 
	"Answer a copy of the receiver that is 1 bigger than the receiver and 
	includes the argument, newElement, at the end."

	| newCollection |
	newCollection := self copy.
	newCollection add: newElement.
	^newCollection! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'nil'!
withIndexCollect: elementAndIndexBlock 
	"Just like with:collect: except that the iteration index supplies the second argument to the block. Override superclass in order to use addLast:, not at:put:."

	| newCollection |
	newCollection := self species new: self size.
	firstIndex to: lastIndex do:
		[:index |
		newCollection addLast: (elementAndIndexBlock
			value: (array at: index)
			value: index - firstIndex + 1)].
	^ newCollection! !

!OrderedCollection methodsFor: 'adding' stamp: 'nil'!
addAllLast: aCollection 
	"Add each element of aCollection at the end of the receiver. 
	Answer aCollection."

	aCollection do: [:each | self addLast: each].
	^aCollection! !

!OrderedCollection methodsFor: 'accessing' stamp: 'nil'!
capacity
	"Answer the current capacity of the receiver."

	"OrderedCollection new capacity >>> 10"
	"(OrderedCollection new addAll: (1 to: 15); yourself) capacity >>> 20"
	
	^ array size! !

!OrderedCollection methodsFor: 'private' stamp: 'nil'!
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: 'adding' stamp: 'nil'!
addAll: aCollection 
	"Add each element of aCollection at my end. Answer aCollection."

	"(OrderedCollection new addAll: #(41 42); yourself) asArray >>> #(41 42)"


	^ self addAllLast: aCollection! !

!OrderedCollection methodsFor: 'converting' stamp: 'nil'!
asOrderedCollection 

	self species == OrderedCollection ifTrue: [ ^self ].
	^super asOrderedCollection! !

!OrderedCollection methodsFor: 'removing' stamp: 'nil'!
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 class methodsFor: 'instance creation' stamp: 'nil'!
new
	^ self new: 10! !

!OrderedCollection class methodsFor: 'stream creation' stamp: 'nil'!
new: size streamContents: aBlock
	^ self withAll: (super new: size streamContents: aBlock)! !

!OrderedCollection class methodsFor: 'instance creation' stamp: 'nil'!
new: anInteger withAll: anObject
	^ self basicNew setContents: (self arrayType new: anInteger withAll: anObject)! !

!OrderedCollection class methodsFor: 'instance creation' stamp: 'nil'!
new: anInteger 
	^ self basicNew setCollection: (self arrayType new: anInteger)! !

!OrderedCollection class methodsFor: 'cleanup' stamp: 'nil'!
compactAll
	"OrderedCollection compactAll"	
		
	self allSubclassesDo: #compactAllInstances! !

!OrderedCollection class methodsFor: 'cleanup' stamp: 'nil'!
cleanUp: aggressive
	"Rehash all instances when cleaning aggressively"

	aggressive ifTrue: [self compactAll].! !

!OrderedCollection class methodsFor: 'private' stamp: 'nil'!
arrayType
	^ Array! !

!OrderedCollection class methodsFor: 'cleanup' stamp: 'nil'!
compactAllInstances
	self allInstances do: #compact! !

!OrderedCollection class methodsFor: 'instance creation' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
streamSpecies
	^ Array! !

!OrderedCollection class methodsFor: 'instance creation' stamp: 'nil'!
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
"! !

!OrderedCollectionTest commentStamp: ''!
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: 'setup' stamp: ''!
collection

	^ collectionWith4Elements! !

!OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne)! !

!OrderedCollectionTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutFirst

	| result |
	result := self nonEmpty copyWithoutFirst.
	
	self assert: result size equals: (self nonEmpty size - 1).
	
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (self nonEmpty at: (i + 1))]! !

!OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |
	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 - puting with indexes' stamp: ''!
testAtLastPut

	| index |
	index := self indexArray anyOne.	
	self nonEmpty atLast: index put: self aValue.	

	self assert: (self nonEmpty at: (self nonEmpty size + 1 - index)) equals: self aValue! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
oldSubCollection
" return a subCollection included in collectionWith1TimeSubcollection .
ex :   subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)"
	^ nonEmpty! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedConcatenationTest
	self empty.
	self assertEmpty: self empty.
	self firstCollection.
	self secondCollection! !

!OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''!
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: 'requirements' stamp: ''!
elementInForElementAccessing
" return an element inculded in 'accessCollection '"
	^ self accessCollection anyOne! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSubcollectionAccessTest

	self moreThan3Elements.
	self assert: self moreThan3Elements size > 2! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAt

	| subcollection index collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 1.
	self assert: index equals: 1.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 2.
	self assert: index equals: 0! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirstNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithElementAlreadyIn

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	oldSize := collection size.
	anElement := self element.
	self assert: (collection includes: anElement).
	
	added := collection addIfNotPresent: anElement.
	
	self assert: added == anElement .	"test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: oldSize! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index between bounds of 'nonEmpty'"

	^ 2! !

!OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
elementInForReplacement
	"Return an element included in 'nonEmpty'"

	^ self nonEmpty anyOne! !

!OrderedCollectionTest methodsFor: 'tests - removing' stamp: ''!
testRemoveAllSuchThat
	| collection |
	collection := (1 to: 10) asOrderedCollection.
	collection removeAllSuchThat: [ :e | e even ].
	self assert: collection equals: (1 to: 10 by: 2) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessFotMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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: 'requirements' stamp: ''!
moreThan3Elements
	" return a collection including atLeast 3 elements"
	^ indexCollection! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!OrderedCollectionTest methodsFor: 'tests' stamp: ''!
testSort	
	| ord |
	ord := OrderedCollection new addAll: #(2 1 3 6 7 10 6); yourself.
	self assert: ord sort asArray equals: #(1 2 3 6 6 7 10). 
	self assert: ord sort equals: (OrderedCollection new addAll:#(1 2 3 6 6 7 10); yourself). 
	self assert: (ord sort: [:a :b | a > b]) asArray equals: #(10 7 6 6 3 2 1).
	ord := OrderedCollection new.
	self assert: ord sort asArray equals: #().! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDoEmpty
	| result |
	result := OrderedCollection new.
	self empty reverseDo: [ :each | result add: each ].

	self assertEmpty: result! !

!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''!
testWithCollect
	"Allows one to collect some element of two collections into another collection with element corresponding to the condition in the blocks"
	
	| 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 min: each2 ].
	self assert: res equals: #(-9 2 -11 4 -13 6 -15 8) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
testOFixtureReplacementSequencedTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.

	self elementInForReplacement.
	self assert: (self nonEmpty includes: self elementInForReplacement).

	self newElement.

	self firstIndex.
	self assert: (self firstIndex >= 1 & self firstIndex) <= self nonEmpty size.

	self secondIndex.
	self assert: (self secondIndex >= 1 & self secondIndex) <= self nonEmpty size.

	self assert: self firstIndex <= self secondIndex.

	self replacementCollection.

	self replacementCollectionSameSize.
	self assert: self secondIndex - self firstIndex + 1 equals: self replacementCollectionSameSize size! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
elementsCopyNonIdenticalWithoutEqualElements
	" return a collection that does niot incllude equal elements ( classic equality )"
	^ collectionOfString! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
moreThan4Elements

" return a collection including at leat 4 elements"
	^ indexCollection! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLastNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAddWithOccurrences
	| 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 equals: (oldSize + 5)! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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 - as identity set' stamp: ''!
testAsIdentitySetWithoutIdentityEqualsElements

	| result collection |
	collection := self collectionWithCopy.
	result := collection asIdentitySet.
	" no elements should have been removed as no elements are equels with Identity equality"
	self assert: result size = collection size.
	collection do: 
		[ :each | 
		(collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ].
	self assert: result class = IdentitySet! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
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)"
	^ collectionWithSameBeginingEnd! !

!OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', '.
	
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString withIndexDo: 
		[:el :i |  self assert: el equals: ((self nonEmpty at:i)asString)]! !

!OrderedCollectionTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsCollect
	| index result |
	index := 0.

	result := self nonEmptyMoreThan1Element
		pairsCollect: [ :each1 :each2 | 
			self assert: (self nonEmptyMoreThan1Element indexOf: each2) equals: (index := index + 2).
			(self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1) ].

	result do: [ :each | self assert: each ]! !

!OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAddAll

	| added collection toBeAdded |
	collection := self collectionWithElement.
	toBeAdded := self otherCollection.
	added := collection addAll: toBeAdded.
	self assert: added == toBeAdded .	"test for identiy because #addAll: has not reason to copy its parameter."
	self assert: (collection includesAll: toBeAdded )! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOf

	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element) equals: (collection indexOf: element)! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtRandom

	| result |
	result := self nonEmpty atRandom.
	self assert: (self nonEmpty includes: result)! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
nonEmptyMoreThan1Element
" return a collection with more than one element"
	^ withoutEqualElements  .! !

!OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printElementsOn: aStream.
	allElementsAsString:=(result findBetweenSubstrings: ' ').
	allElementsAsString withIndexDo: 
		[:el :i | self assert: el equals: ((self nonEmpty at: i)asString) ]! !

!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''!
testFlattened

	self assert: self simpleCollection flattened equals: #(1 8 3).
	self assert: self collectionOfCollectionsOfInts flattened equals: #( 1 2 3 4 5 6 ).
	self assert: self collectionWithCharacters flattened equals: #($a $x $d $c $m).
	self assert: self collectionOfCollectionsOfStrings flattened equals: #('foo' 'bar' 'zorg').! !

!OrderedCollectionTest methodsFor: 'setup' stamp: ''!
sizeCollection

	^ collectionWith4Elements! !

!OrderedCollectionTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!OrderedCollectionTest methodsFor: 'accessing' stamp: ''!
speciesClass
	
	^ OrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testAddAllFirstUnlessAlreadyPresent
	"Allows one to add each element of an orderedCollection at the beginning of
	another orderedCollection preserving the order but no duplicate element"

	| 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 equals: #(1 2 3 4 5 6 7 8 9) asOrderedCollection.
	c1 addAllFirstUnlessAlreadyPresent: c3.
	self deny: c1 equals: #(0 1 1 2 3 4) asOrderedCollection.
	self assert: c1 equals: #(0 1 2 3 4) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
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 - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllIndexesPut
	
	self nonEmpty atAllPut: self aValue.
	self nonEmpty do:[ :each| self assert: each = self aValue].! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testAddFirst
	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l addFirst: 88.
	self assert: l equals: #(88 1 2 3 4) asOrderedCollection.
	l addFirst: 99.
	self assert: l equals: #(99 88 1 2 3 4) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollectionReturnsOrderedCollection
	self assert: #(5 4 3) asSortedCollection asOrderedCollection species identicalTo: OrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringOne
	
	"self assert: self oneItemCol asCommaString = '1'.
	self assert: self oneItemCol asCommaStringAnd = '1'."

	self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString).
	self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString)! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testAtIfAbsentPut
	"Allows one to add an element at an index if no element exist at this index"

	| c |
	c := #(1 2 3 4) asOrderedCollection.
	c at: 2 ifAbsentPut: [ 5 ].
	self assert: c equals: #(1 2 3 4) asOrderedCollection.
	c at: 5 ifAbsentPut: [ 5 ].
	self assert: c equals: #(1 2 3 4 5) asOrderedCollection.
	c at: 7 ifAbsentPut: [ 7 ].
	self assert: c equals: #(1 2 3 4 5 nil 7) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''!
testCollect
	"Allows one to collect some element of a collection into another collection"
	| c1 c2 res |
	c1 := #(-1 2 -3 4) asOrderedCollection.
	c2 := #(1 2 3 4) asOrderedCollection.
	res := c1 collect: [:each | each abs].
	self assert: c2 equals: res! !

!OrderedCollectionTest methodsFor: 'tests - sequence isempty' stamp: ''!
testSequenceIfNotEmpty

	self assert: (self nonEmpty 
					ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! !

!OrderedCollectionTest methodsFor: 'tests - copying' stamp: ''!
testCopyEmptyOld
	"Allows one to create a copy of the receiver that contains no elements"

	| c1 c2 |
	c1 := #(1 2 3 4 ) asOrderedCollection.
	c2 := c1 copyEmpty.
	self assert: c2 size equals: 0! !

!OrderedCollectionTest methodsFor: 'tests - removing' stamp: ''!
testRemoveDuplicates
	self assert: #(7 42 7 42 9) asOrderedCollection removeDuplicates equals: #(7 42 9) asOrderedCollection.
	self assert: #(1 2 3) asOrderedCollection removeDuplicates equals: #(1 2 3) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithCharacters
	^withCharacters.! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	^ elementNotIn! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyNonEmptyWithoutAllNotIncluded! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRequirementsOfTAddTest

	self collectionWithElement.
	self otherCollection.
	self element.
	self assert: (self collectionWithElement includes: self element).
	self deny: (self otherCollection includes: self element)! !

!OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''!
anotherElementNotIn
	^ 42! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testAddAll
	"Allows one to add each element of an OrderedCollection at the end of another
	 OrderedCollection"

	| c1 c2 |
	c1 := #(1 2 3 4) asOrderedCollection.
	c2 := #(5 6 7 8 9) asOrderedCollection.
	c1 addAll: c2.
	self assert: c1 equals: #(1 2 3 4 5 6 7 8 9) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - accessing' stamp: ''!
testCapacityFromAsOrderedCollection
	"Allows one to check the current capacity of an Ordered collection"
	
	| c1 c2 c3 |
	c1 := #(1 2 ) asOrderedCollection.
	self assert: c1 capacity equals: 2.
	c2 := OrderedCollection new: 10.
	c2 add: 3.
	self assert: c2 capacity equals: 10.	
	c3 := OrderedCollection new.
	self deny: c3 capacity equals: 0! !

!OrderedCollectionTest methodsFor: 'tests - removing' stamp: ''!
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"
	
	| c1 c2 |
	c1 := #(1 2 3 4) asOrderedCollection.
	c2 := OrderedCollection new.
	
	c2 add: (c1 remove: 2 ifAbsent: [6]).
	self assert: c1 equals: #(1 3 4) asOrderedCollection.
	self assert: c2 equals: #(2) asOrderedCollection.
	
	c2 add: (c1 remove: 18 ifAbsent: [6]).
	self assert: c1 equals: #(1 3 4) asOrderedCollection.
	self assert: c2 equals: #(2 6) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfIfAbsentDuplicate

	| 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 ]) equals: 1! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testFirstSecondThird

	self assert: self moreThan4Elements first equals: (self moreThan4Elements at: 1).
	self assert: self moreThan4Elements second equals: (self moreThan4Elements at: 2).
	self assert: self moreThan4Elements third equals: (self moreThan4Elements at: 3).
	self assert: self moreThan4Elements fourth equals: (self moreThan4Elements at: 4)! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testAddAfter
	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l add: 88 after: 1.
	self assert: l equals: #(1 88 2 3 4) asOrderedCollection.
	l add: 99 after: 2.
	self assert: l equals: #(1 88 2 99 3 4) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWith5Elements
" return a collection of size 5 including 5 elements"
^ indexCollection! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterEmpty
	| result |
	result := self empty copyAfter: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfIfAbsentDuplicate

	| 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 ]) equals: collection size! !

!OrderedCollectionTest methodsFor: 'tests - creation' stamp: ''!
collectionClass 
	"Return the class to be used to create instances of the class tested"
	
	^ OrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureBeginsEndsWithTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self assert: self nonEmpty size > 1.
	self empty.
	self assertEmpty: self empty! !

!OrderedCollectionTest methodsFor: 'tests - removing' stamp: ''!
testRemoveLast
	"Allows one to remove n element of a collection at the end"
	
	| c1 |
	c1 := #(2 3 4 6) asOrderedCollection.
	c1 removeLast: 1.
	self assert: c1 equals: #(2 3 4) asOrderedCollection.
	c1 removeLast: 2.
	self assert: c1 equals: #(2) asOrderedCollection.
	self should: [ c1 removeLast: 10 ] raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAdd
	| added collection |
	collection := self otherCollection.
	added := collection add: self element.
	
	self assert: added == self element.	"test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection includes: self element)	.
	self assert: (self collectionWithElement includes: self element).! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
accessCollection

	^ indexCollection! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtIfAbsent

	| 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 - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterLastWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the last occurrence of element :"
	result := collection copyAfterLast: element.

	"Verify content"
	self assertEmpty: result! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
elementInCollectionOfFloat
	^ collectionOfFloat anyOne.! !

!OrderedCollectionTest methodsFor: 'setup' stamp: ''!
emptyButAllocatedWith20 

	^ emptyButAllocatedWith20! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testMiddle

	self assert: self moreThan4Elements middle equals: (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! !

!OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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: 'requirements' stamp: ''!
integerCollection
" return a collection only including SmallInteger elements"
	^ indexCollection! !

!OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsByteArray

	| res |
	self integerCollectionWithoutEqualElements.
	self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ].
	res := true.
	self integerCollectionWithoutEqualElements
		detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! !

!OrderedCollectionTest methodsFor: 'tests - copying' stamp: ''!
testCopyWith
	"Allows one to create a copy of the receiver that contains the new element at the end"
	
	| c1 | 
	c1 := #(1 2 3 4) asOrderedCollection.
	c1 := c1 copyWith: 6.
	self assert: c1 equals: #(1 2 3 4 6) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
elementNotIn
	^ elementNotIn! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTRemoveTest
	| duplicate |
	self empty.
	self nonEmptyWithoutEqualElements.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	duplicate := true.
	self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ].
	self assert: duplicate = false.
	self elementNotIn.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!OrderedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''!
testReverse

	| result |
	result := self nonEmpty reversed.	
	"verify content of 'result: '"
	1 to: result size do:
		[:i | self assert: ((result at: i) 
			= (self nonEmpty at: (self nonEmpty size - i + 1)))].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testBeforeIfAbsent

	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 - sorting' stamp: ''!
testIsSorted
	self assert: self sortedInAscendingOrderCollection isSorted.
	self deny: self unsortedCollection isSorted! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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: 'requirements' stamp: ''!
firstIndex
" return an index between 'nonEmpty' bounds that is < to 'second index' "
	^1! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testAddLast
	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l addLast: 88.
	self assert: l equals: #(1 2 3 4 88) asOrderedCollection.
	l addLast: 99.
	self assert: l equals: #(1 2 3 4 88 99) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
testLastNElements

	| result |
	result := self moreThan3Elements last: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i + 1) ].
	self assert: result size equals: (self moreThan3Elements size - 1).
	self 
		should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ]
		raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - begin' stamp: ''!
testBeginsWithAnyOf
	"We can't test SequenceableCollection directly. However, we can test a sampling of its descendants."
	
	| 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 - creation' stamp: ''!
testWithAll

	| aCol collection |
	collection := self collectionMoreThan5Elements asOrderedCollection.
	aCol := self collectionClass withAll: collection.
	
	collection do: [ :each | self assert: (aCol occurrencesOf: each ) equals: ( collection occurrencesOf: each ) ].
	
	self assert: aCol size equals: collection size! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
valueArray
" return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty'  at indexes in 'indexArray' "
	| result |
	result := Array new: self indexArray size.
	1 to: result size do:
		[:i |
		result at:i put: (self aValue ).
		].
	^ result.! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithCopyNonIdentical
	" return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)"
	^ collectionOfString! !

!OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printNameOn: aStream.

	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents equals: ('an ',self nonEmpty class name ) ]
		ifFalse:[ self assert: aStream contents equals: ('a ',self nonEmpty class name)].! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutTest
	self aValue.
	self anotherValue.

	self anIndex.
	self nonEmpty isDictionary ifFalse: [ self assert: (self anIndex >= 1 & self anIndex) <= self nonEmpty size ].

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!OrderedCollectionTest methodsFor: 'tests - removing' stamp: ''!
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 equals: 0.
	self assert: c2 size = s2 description: 'the copy has not been modified'! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButFirstDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButFirstDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i +1))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element size-1)! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLastEmpty
	| result |
	result := self empty copyUpToLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAtIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
" return a collection elements that can be sorte ( understanding message ' < '  or ' > ')"
	^ collectionOfFloat! !

!OrderedCollectionTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWithManyOccurrence
	| result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff |
	" testing fixture here as this method may be not used for collection that can't contain equals element :"
	self collectionWith2TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection) = 2.	" test :"
	diff := self replacementCollection size - self oldSubCollection size.
	result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection.	"detecting indexes of olSubCollection"
	firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection.	" verifying that replacementCollection has been put in places of oldSubCollections "
	firstIndexesOfOccurrence
		do: [ :each | 
			(firstIndexesOfOccurrence indexOf: each) = 1
				ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ]
				ifFalse: [ each + diff to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ].	" verifying that the 'between' parts correspond to the initial collection : "
	1 to: firstIndexesOfOccurrence size do: [ :i | 
		i = 1
			ifTrue: [ 1 to: (firstIndexesOfOccurrence at: i) - 1 do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ]
			ifFalse: [ 
				resultBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self replacementCollection size.
				collectionBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self oldSubCollection size.
				1 to: (firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | 
					self
						assert:
							(result at: resultBetweenPartIndex + i - 1)
								= (self collectionWith2TimeSubcollection at: collectionBetweenPartIndex + i - 1) ] ]	" specific comportement for the begining of the collection :"	" between parts till the end : " ].	"final part :"
	1 to: self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size) do: [ :i | 
		self
			assert:
				(result at: firstIndexesOfOccurrence last + self replacementCollection size - 1 + i)
					= (self collectionWith2TimeSubcollection at: firstIndexesOfOccurrence last + self oldSubCollection size - 1 + i) ]! !

!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIdentityIndexOfDuplicate

	| collection element |
	"testing fixture here as this method may not be used by some collections testClass"
	self collectionWithNonIdentitySameAtEndAndBegining.
	collection := self collectionWithNonIdentitySameAtEndAndBegining.
	self assert: collection first equals: collection last.
	self deny: collection first == collection last.
	collection withIndexDo: [:el :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) equals: collection size! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
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 - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutOneOrMoreElementsTest
	self aValue.


	self indexArray.
	self indexArray
		do: [ :each | 
			self assert: each class = SmallInteger.
			self assert: (each >= 1 & each) <= self nonEmpty size ].

	self assert: self indexArray size = self valueArray size.

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDoError
	
	self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testHasEqualElementsOfIdenticalCollectionObjects
	
	self assert: (self empty hasEqualElements: self empty). 
	self assert: (self nonEmpty hasEqualElements: self nonEmpty)! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testAddAllLast
	"Allows one to add each element of an OrderedCollection at the beginning of another OrderedCollection"

	| c1 c2 |
	c1 := #(1 2 3 4) asOrderedCollection.
	c2 := #(5 6 7 8 9) asOrderedCollection.
	c1 addAllLast: c2.
	self assert: c1 equals: #(1 2 3 4 5 6 7 8 9) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''!
testDifferencePreservesOrder
	| n even odd odd2 |
	n := OrderedCollection with: 5 with: 3 with: 4.
	even := OrderedCollection with: 4.
	odd := n difference: even.
	odd2 := n reject: [ :i | i even ].
	self assert: odd equals: odd2! !

!OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignForSequenceableCollections

	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' stamp: ''!
testEqualSignIsTrueForEmptyButNonIdenticalCollections
	
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithNewElement

	| added oldSize collection elem |
	collection := self otherCollection.
	oldSize := collection size.
	elem := self element.
	self deny: (collection includes: elem ).
	
	added := collection  addIfNotPresent: elem .
	self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: (oldSize + 1).! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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 - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDoEmpty
	| result |
	result := OrderedCollection new.

	self empty keysAndValuesDo: [ :i :value | result add: value + i ].

	self assertEmpty: result! !

!OrderedCollectionTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithSequenceable

	| result index element |
	index := self indexInNonEmpty.
	element := self nonEmpty at: index.
	result := self nonEmpty copyWith: (element ).
	
	self assert: result size equals: (self nonEmpty size + 1).
	self assert: result last equals: element.
	
	1 to: (result size - 1) do:
		[ :i | self assert: (result at: i) equals: ( self nonEmpty at: i)]! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexCollect
	
	| result index collection |
	index := 0.
	collection := self nonEmptyMoreThan1Element .
	result := collection  withIndexCollect: [:each :i | 
		self assert: i equals: (index := index + 1).	
		self assert: i equals: (collection  indexOf: each).
		each ]. 
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (collection at: i)].
	self assert: result size equals: collection size! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
elementInForIndexAccessing

^ self accessCollection  anyOne.! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDetectSequenced
	"Testing that detect keep the first element returning true for sequenceable collections"

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element  detect: [:each | each notNil ].
	self assert: result equals: element! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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 - adding' stamp: ''!
testAddBefore
	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l add: 88 before: 1.
	self assert: l equals: #(88 1 2 3 4) asOrderedCollection.
	l add: 99 before: 2.
	self assert: l equals: #(88 1 99 2 3 4) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection last.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: 99! !

!OrderedCollectionTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWithInsertion
	| result  indexOfSubcollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: ( indexOfSubcollection - 1 ) with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'' : '"
	
	1 to: (indexOfSubcollection -1) do: 
		[
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i)=(result at: i)
		].
	
	" middle part containing replacementCollection : "
	indexOfSubcollection  to: (indexOfSubcollection  + self replacementCollection size-1) do: 
		[
		:i |
		self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 ))
		].
	
	" end part :"
	(indexOfSubcollection  + self replacementCollection size) to: (result size) do:
		[:i|
		self assert: (result at: i)=(self collectionWith1TimeSubcollection  at: (i-self replacementCollection size))].
	
	" verify size: "	
	self assert: result size=(self collectionWith1TimeSubcollection  size + self replacementCollection size).! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan5Elements
" return a collection including at least 5 elements"
	
	^collection5Elements! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
secondIndex
" return an index between 'nonEmpty' bounds that is > to 'second index' "
	^2! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopySameContentsTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWith2TimeSubcollection
" return a collection including 'oldSubCollection'  two or many time "
	^ (((OrderedCollection new add: elementNotIn; yourself),self oldSubCollection ) add: elementNotIn;yourself),self  oldSubCollection! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLast

	| index |
	self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last.

	index := self moreThan4Elements indexOf: self elementInForElementAccessing.
	self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! !

!OrderedCollectionTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self collection  anyOne! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
secondCollection
" return a collection that will be the second part of the concatenation"
	^ collectionWith4Elements! !

!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''!
testBind
	
	| aCollection |
	
	aCollection := #(1 2 3).
	
	self assertCollection: (aCollection bind: [ :first :second :third | { first. second. third } ]) equals: aCollection.
	
	self assert: (#() bind: [ #blockResult ]) equals: #blockResult .
	
	self should: [#() bind: [ :arg | #blockResult ]] raise: ArgumentsCountMismatch.
	self should: [#(1 2) bind: [ :arg | #blockResult ]] raise: ArgumentsCountMismatch! !

!OrderedCollectionTest methodsFor: 'setup' stamp: ''!
nonEmpty
	
	^ nonEmpty! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
elementNotInForIndexAccessing

	^ elementNotIn! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithoutEqualElements
" return a collection without equal elements "
	^ withoutEqualElements! !

!OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllFoundIn
	| el aSubCollection |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn.
	self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection.
	self assert: self nonEmptyWithoutEqualElements size = 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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 - enumerating' stamp: ''!
testCollectFromTo
	"Allows one to collect some element of a collection into another collection between a first index and an end index for the collect"
	
	| 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 equals: #(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: ''!
testFlatCollectAsWithEmptyCollection

	self 
		assert: (self empty flatCollect: [ :x | { x }, { x } ] as: IdentitySet) 
		equals: self empty asIdentitySet! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
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 equals: collection size! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
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: 'helpers' stamp: ''!
anotherValue

	^ 66! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfIfAbsent

	| collection |
	collection := self collectionMoreThan1NoDuplicates.
	self assert: (collection 
			indexOf: collection first
			ifAbsent: [ 33 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 33 ]) equals: 33! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAddTwice

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	anElement := self element.
	oldSize := collection size.
	added := collection 
		add: anElement;
		add: anElement.
	self assert: added == anElement.	"test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection includes: anElement).
	self assert: collection size equals: (oldSize + 2)! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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: 'coverage' stamp: ''!
classToBeTested
	
	^ OrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfForMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFromToDo
	
	| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each].
	
	1 to: (self nonEmptyMoreThan1Element  size -1) do:
		[:i | self assert: (self nonEmptyMoreThan1Element at:i) = (result at:i) ].

	self assert: result size = (self nonEmptyMoreThan1Element size - 1).! !

!OrderedCollectionTest methodsFor: 'tests - copying' stamp: ''!
testReversed
	| collection1 collection2 |
	collection1 := #('Jim' 'Mary' 'John' 'Andrew') asOrderedCollection.
	collection2 := collection1 reversed.
	self assert: collection2 first equals: 'Andrew'.
	self assert: collection2 last equals: 'Jim'! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!OrderedCollectionTest methodsFor: 'accessing' stamp: ''!
expectedSizeAfterReject
	^1! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
result

^ collectResult! !

!OrderedCollectionTest methodsFor: 'setup' stamp: ''!
empty
	
	^ empty! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
element
	"Returns an object that can be added to the collection returned by #collection."
	^ 5! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDo
	| result |
	result := OrderedCollection new.
	self nonEmpty reverseDo: [: each | result add: each].
	
	1 to: result size do:
		[:i|
		self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))]! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWith1TimeSubcollection
" return a collection including 'oldSubCollection'  only one time "
	^ ((OrderedCollection new add: elementNotIn; yourself),self oldSubCollection) add: elementNotIn;yourself! !

!OrderedCollectionTest methodsFor: 'tests - sorting' stamp: ''!
testSortedUsingBlock
	| result tmp |
	result := self unsortedCollection sorted:  [:a :b | a>b]..
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	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 - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCreationWithTest

	self collectionMoreThan5Elements.
	self assert: self collectionMoreThan5Elements size >= 5! !

!OrderedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWith
	
	self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst).
	self assert: (self nonEmpty endsWith: self nonEmpty).
	self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0TSequencedStructuralEqualityTest

	self nonEmpty at: 1	"Ensures #nonEmpty is sequenceable"! !

!OrderedCollectionTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty

	| result |
	result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne).
	self assert: result equals: 0! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLastEmpty
	| result |
	result := self empty copyAfterLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan1NoDuplicates
	" return a collection of size 5 without equal elements"
	^ withoutEqualElements! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
withEqualElements
	" return a collection of float including equal elements (classic equality)"
	^ collectionOfFloat , collectionOfFloat! !

!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfStartingAtDuplicate

	| 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 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 55 ]) equals: 1! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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 - subcollections access' stamp: ''!
testAllButFirstNElements

	| allButFirst collection |
	collection := self moreThan3Elements.
	allButFirst := collection allButFirst: 2.
	allButFirst withIndexDo: 
		 [:el :i | self assert: el equals: (collection at: i + 2) ].
	self assert: allButFirst size + 2 equals: collection size! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
elementInForIncludesTest
" return an element included in nonEmpty "
	^ self nonEmpty anyOne! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithSameAtEndAndBegining
" return a collection with elements at end and begining equals .
(others elements of the collection are not equal to those elements)"
	^ collectionWithSameBeginingEnd! !

!OrderedCollectionTest methodsFor: 'tests - public methods' stamp: ''!
testAddAfterIndex
	| coll |
	coll := #(1 2 3 4) asOrderedCollection.
	coll add: 77 afterIndex: 0.
	self assert: coll equals: #(77 1 2 3 4) asOrderedCollection.
	coll add: 88 afterIndex: 2.
	self assert: coll equals: #(77 1 88 2 3 4) asOrderedCollection. 
	coll add: 99 afterIndex: coll size.
	self assert: coll equals: #(77 1 88 2 3 4 99) asOrderedCollection. 
	self should: [ coll add: 666 afterIndex: -1 ] raise: Error.
	self should: [ coll add: 666 afterIndex: coll size+1 ] raise: Error.
	
	"Now make room by removing first two and last two elements,
	and see if the illegal bounds test still fails"
	(coll first: 2), (coll last: 2) reversed do: [:e | coll remove: e].
	self should: [ coll add: 666 afterIndex: -1 ] raise: Error.
	self should: [ coll add: 666 afterIndex: coll size+1 ] raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
" return a collection of size 1 including one element"
	^ OrderedCollection new add:( self nonEmpty anyOne); yourself.! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithIdentical
	"Return a collection of type: 'self collectionWIithoutEqualsElements class containing two elements equals (with identity equality)."

	| result collection anElement |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := collection first.
	collection add: anElement.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
indexArray
	^ indexArray .! !

!OrderedCollectionTest methodsFor: 'tests' stamp: ''!
testCompact
	| collection |
	collection := OrderedCollection new.
	self assertEmpty: collection.
	self assert: collection capacity equals: 10.
	collection compact.
	self assert: collection capacity equals: 0.

	collection := OrderedCollection new.
	collection add: 1.
	collection compact.
	self assert: collection capacity equals: 1.

	collection growAtLast.
	collection compact.
	self assert: collection capacity equals: 1.

	"we do not shrink the start for now"
	collection growAtFirst.
	collection compact.
	self assert: collection capacity equals: 2! !

!OrderedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWith
	
	self assert: (self nonEmpty beginsWith: (self nonEmpty copyUpTo: self nonEmpty last)).
	self assert: (self nonEmpty beginsWith: self nonEmpty).
	self deny: (self nonEmpty beginsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesForMultiplinessTest
	| cpt |
	self collectionWithEqualElements.
	self collectionWithEqualElements.
	self elementTwiceInForOccurrences.
	self elementTwiceInForOccurrences.
	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: 'requirements' stamp: ''!
sortedInAscendingOrderCollection
	"Return a collection sorted in ascending order"

	^ OrderedCollection new
		add: 1;
		add: 2;
		add: 3;
		add: 4;
		add: 5;
		yourself! !

!OrderedCollectionTest methodsFor: 'tests - sequence isempty' stamp: ''!
testSequenceIfNotEmptyifEmpty

	self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIdentityIndexOfIAbsentDuplicate

	| collection element elementCopy |
	collection := self collectionWithNonIdentitySameAtEndAndBegining.
	element := collection last.
	elementCopy := element copy.
	self deny: element == elementCopy.
	self assert: (collection 
			identityIndexOf: element
			ifAbsent: [ 0 ]) equals: collection size.
	self assert: (collection 
			identityIndexOf: elementCopy
			ifAbsent: [ 55 ]) equals: 55! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest

	self nonEmpty! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsDo

	| index |
	index:=1.
	
	self nonEmptyMoreThan1Element  pairsDo: 
		[:each1 :each2 | 
		self assert: (self nonEmptyMoreThan1Element at:index) equals: each1.
		self assert: (self nonEmptyMoreThan1Element at:(index+1)) equals: each2.
		index := index + 2 ].
	
	self nonEmptyMoreThan1Element size odd
		ifTrue:[ self assert: index equals: self nonEmptyMoreThan1Element size ]
		ifFalse:[ self assert: index equals: (self nonEmptyMoreThan1Element size+1) ]! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtWrap
	"
	self assert: (self accessCollection at: 1) = 1.
	self assert: (self accessCollection at: 2) = 2.
	"
	
	| index |
	index := self moreThan4Elements indexOf: self elementInForElementAccessing.
	self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing.
	self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing.
	self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing.
	self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
indexInForCollectionWithoutDuplicates
" return an index between 'collectionWithoutEqualsElements'  bounds"
	^ 2! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!OrderedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopy

	| result |
	result := self nonEmpty shallowCopy.
	
	"Verfy content"
	self nonEmpty withIndexDo:
		[:el :i | self assert: (result at:i) equals: (self nonEmpty at:i)].
	
	"Verify size"
	self assert: result size equals: self nonEmpty size.! !

!OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLast

	| abf col |
	col := self moreThan3Elements.
	abf := col allButLast.
	self deny: abf last = col last.
	self assert: abf size + 1 equals: col size! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexDo

	|  indexes elements |
	indexes:= OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:value :i  |
			indexes  add: (i).
			elements add: value ].
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:el :i |
			self assert: (indexes at: i) equals: i.
			self assert: (elements at: i) equals: el ].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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 - as identity set' stamp: ''!
testAsIdentitySetWithIdentityEqualsElements

	| result |
	result := self collectionWithIdentical asIdentitySet.
	" Only one element should have been removed as two elements are equals with Identity equality"
	self assert: result size = (self collectionWithIdentical size - 1).
	self collectionWithIdentical do: 
		[ :each | 
		(self collectionWithIdentical occurrencesOf: each) > 1 
			ifTrue: 
				[ "the two elements equals only with classic equality shouldn't 'have been removed"
				self assert: (result asOrderedCollection occurrencesOf: each) = 1
				" the other elements are still here" ]
			ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ].
	self assert: result class = IdentitySet! !

!OrderedCollectionTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLastNElements

	| allButLast collection |
	collection := self moreThan3Elements.
	allButLast := collection allButLast: 2.
	allButLast withIndexDo: [:el :i | self assert: el equals: (collection at: i) ].
	self assert: allButLast size + 2 equals: collection size! !

!OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	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 - begins ends with' stamp: ''!
testsBeginsWithEmpty
	
	self deny: (self nonEmpty beginsWith:(self empty)).
	self deny: (self empty beginsWith:(self nonEmpty))! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithOrWithoutSpecificElementsTest

	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self indexInNonEmpty.
	self assert: self indexInNonEmpty > 0.
	self assert: self indexInNonEmpty <= self nonEmpty size! !

!OrderedCollectionTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithFirst

	| index element result |
	index:= self indexInNonEmpty .
	element:= self nonEmpty at: index.
	
	result := self nonEmpty copyWithFirst: element.	
	
	self assert: result size = (self nonEmpty size + 1).
	self assert: result first = element .
	
	2 to: result size do:
	[ :i |
	self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! !

!OrderedCollectionTest methodsFor: 'tests - begin' stamp: ''!
testEndsWithAnyOf
	"We can't test SequenceableCollection directly. However, we can test a sampling of its descendants."
	
	| la oc |
	la := #(6 5 4 3 2 1).
	oc := OrderedCollection new.
	oc add: 3; add: 2; add: 1.
	
	self assert: (la endsWithAnyOf: #((17) (1) (42))).
	self assert: (la endsWithAnyOf: #((17) (2 1) (42))).
	self assert: (la endsWithAnyOf: #((17) (3 2 1) (42))).
	self deny: (la endsWithAnyOf: #()).
	self deny: (la endsWithAnyOf: #(())).
	self deny: (la endsWithAnyOf: #((42))).! !

!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfDuplicate

	| 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) equals: collection size! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpTo

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection   copyUpTo: (collection  at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at:i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllPut
 
	self nonEmpty atAll: self indexArray put: self aValue.
	
	self indexArray do:
		[:i | self assert: (self nonEmpty at: i) equals: self aValue ]! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionOfCollectionsOfStrings
	^collectionOfCollectionsOfStrings.! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLast

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection copyUpToLast: (collection at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at: i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
otherCollection
	^ otherCollection! !

!OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementReallyRemovesElement
 
	| size |
	size := self nonEmptyWithoutEqualElements size.
	self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne.
	self assert: size - 1 = self nonEmptyWithoutEqualElements size! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			lastIndexOf: element
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 99 ]) equals: 99! !

!OrderedCollectionTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
	^ OrderedCollection new add: elementNotIn ; add: elementNotIn ; yourself.! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToLastWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyUpToLast:' should copy until the last occurrence :"
	result := collection copyUpToLast: (element ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (collection at: i) ].
	
	self assert: result size equals: (collection size - 1)! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0SortingArrayedTest
	| tmp sorted |
	" an unsorted collection of number "
	self unsortedCollection.
	self unsortedCollection do: [ :each | each isNumber ].
	sorted := true.
	self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ].
	self deny: sorted.	" a collection of number sorted in an ascending order"
	self sortedInAscendingOrderCollection.
	self sortedInAscendingOrderCollection do: [ :each | each isNumber ].
	tmp := self sortedInAscendingOrderCollection at: 1.
	self sortedInAscendingOrderCollection
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testAdd
	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l add: 88.
	self assert: l equals: #(1 2 3 4 88) asOrderedCollection.
	l add: 99.
	self assert: l equals: #(1 2 3 4 88 99) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	firstCollection  with: secondCollection do:
		[:a :b |
		index := index + 1.
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals: b ]! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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 - iterate on sequenced reable collections' stamp: ''!
testGroupsOfAtATimeCollect
	| groupsOf2 |
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: [ :x | x ]).
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: #yourself).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 2 atATimeCollect: [ :x | x ].
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 2.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 2 ]).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 3 atATimeCollect: #yourself.
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 3.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 3 ]).! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithReplacementTest
	self replacementCollection.
	self oldSubCollection.
	self collectionWith1TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
elementToAdd
	^ 55! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAtIfAbsent
	| absent subcollection collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ].
	self deny: absent.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ].
	self assert: absent! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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 - converting' stamp: ''!
testAsSet
 	"Test with a collection without equal elements"
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set! !

!OrderedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWithEmpty
	
	self deny: (self nonEmpty endsWith: self empty).
	self deny: (self empty endsWith: self nonEmpty)! !

!OrderedCollectionTest methodsFor: 'parameters' stamp: ''!
valuePutIn
	"the value that we will put in the non empty collection"
	
	^ #x! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
simpleCollection
	^simpleCollection.! !

!OrderedCollectionTest methodsFor: 'tests - at put' stamp: ''!
testAtPutTwoValues
	
	self nonEmpty at: self anIndex put: self aValue.
	self nonEmpty at: self anIndex put: self anotherValue.
	self assert: (self nonEmpty at: self anIndex) = self anotherValue.! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLast

	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection copyAfterLast: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!OrderedCollectionTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExistsTwice

	| 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: 'tests - accessing' stamp: ''!
testAtPut
	"Allows one to replace an element but not at an off range index"

	| c |
	c := #(1 2 3 4) asOrderedCollection.
	c at: 2 put: 5.
	self assert: c equals: #(1 5 3 4) asOrderedCollection.
	self should: [ c at: 5 put: 8 ] raise: Error.
	self deny: c equals: #(1 5 3 4 8) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
integerCollectionWithoutEqualElements
" return a collection of integer without equal elements"
	^ withoutEqualElements! !

!OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtWrapPut
	 
	| index |
	index := self indexArray anyOne.
	
	self nonEmpty atWrap: 0 put: self aValue.
	self assert: self nonEmpty last equals: self aValue.
	
	self nonEmpty atWrap: (self nonEmpty size + 1) put: self aValue.
	self assert: self nonEmpty first equals: self aValue.
	
	self nonEmpty atWrap: index put: self aValue.
	self assert: (self nonEmpty at: index) equals: self aValue.
	
	self nonEmpty atWrap: (self nonEmpty size + index) put: self aValue .
	self assert: (self nonEmpty at: index) equals: self aValue.! !

!OrderedCollectionTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''!
testOccurrencesOfForMultipliness

	| collection elem |
	collection := self collectionWithEqualElements.
	elem := self elementTwiceInForOccurrences.

	self assert: (collection occurrencesOf: elem ) equals: 2.! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithElement
	"Returns a collection that already includes what is returned by #element."
	^ collectionWithElement! !

!OrderedCollectionTest methodsFor: 'tests - creation' stamp: ''!
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 ) equals: (collection occurrencesOf: element1).
	self assert: (aCol occurrencesOf: element2 ) equals: (collection occurrencesOf: element2)! !

!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollect

	self assert: (self simpleCollection flatCollect: [ :x | { x } ]) equals: self simpleCollection.
	self assert: (self simpleCollection flatCollect: [ :x | { x } ]) species = self simpleCollection species.
	
	self 
		assert: (self collectionOfCollectionsOfInts flatCollect: [ :x | { x } ]) 
		equals: self collectionOfCollectionsOfInts.
	self 
		assert: (self collectionWithCharacters flatCollect: [ :x | { x } ]) 
		equals: self collectionWithCharacters.
	self 
		assert: (self collectionOfCollectionsOfStrings flatCollect: [ :x | { x } ]) 
		equals: self collectionOfCollectionsOfStrings! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testAddAllFirst
	"Allows one to add each element of an OrderedCollection at the beginning of another OrderedCollection "
	
	| c1 c2 |
	c1 := #(1 2 3 4) asOrderedCollection.
	c2 := #(5 6 7 8 9) asOrderedCollection.
	c2 addAllFirst: c1.
	self assert: c2 equals: #(1 2 3 4 5 6 7 8 9) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''!
elementNotInForOccurrences
	^ 666! !

!OrderedCollectionTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceAllWith
	| result collection oldElement newElement oldOccurrences |
	collection := self nonEmpty.
	result := collection copy.
	oldElement := self elementInForReplacement.
	newElement := self newElement.
	oldOccurrences := (result occurrencesOf: oldElement) + (result occurrencesOf: newElement).
	result replaceAll: oldElement with: newElement.
	
	self assert: oldOccurrences equals: (result occurrencesOf: newElement)! !

!OrderedCollectionTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutIndex

	| result index |	
	index := self indexInNonEmpty.
	result := self nonEmpty copyWithoutIndex: index.
	
	"Verify content of result"
	result withIndexDo: 
		[:element :i | 
		 i <  index ifTrue: [ self assert: element equals: (self nonEmpty at: i) ].
		 i >= index ifTrue: [ self assert: element equals: (self nonEmpty at: (i + 1)) ]].
	
	"Verify size of result"
	self assert: result size equals: (self nonEmpty size - 1)! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
newElement
"return an element that will be put in the collection in place of another"
	^999! !

!OrderedCollectionTest methodsFor: 'helpers' stamp: ''!
anIndex

	^ 2! !

!OrderedCollectionTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceFromToWithStartingAt
	| result repStart collection replacementCollec firstInd secondInd |
	collection := self nonEmpty.
	result := collection copy.
	replacementCollec := self replacementCollectionSameSize.
	firstInd := self firstIndex.
	secondInd := self secondIndex.
	repStart := replacementCollec size - (secondInd - firstInd + 1) + 1.
	result replaceFrom: firstInd to: secondInd with: replacementCollec startingAt: repStart.
	
	"Verify content of 'result'"
	
	"First part of 'result'" 	
	1 to: (firstInd - 1) do: [:i | self assert: (collection at:i) equals: (result at: i) ].
	
	"Middle part containing replacementCollection"	
	firstInd to: (replacementCollec size - repStart +1) do: 
		[:i| self assert: (result at: i) equals: (replacementCollec at: (repStart + (i - firstInd))) ].
	
	"End part"
	(firstInd + replacementCollec size) to: (result size) do:
		[ :i | self assert: (result at: i) equals: (collection at: (secondInd + 1 - (firstInd + replacementCollec size) + i)) ]! !

!OrderedCollectionTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	nonEmpty := OrderedCollection new  add: self valuePutIn; add: self elementTwiceIn; add: self elementTwiceIn; yourself.
	empty := OrderedCollection new. 
	elementNotIn := 99.
	collectionWith4Elements := OrderedCollection new add: 1; add: -2; add: 3; add: 1; yourself.
	indexArray := { 3. 1.}.
	indexCollection := OrderedCollection new add: 1; add: 2;add: 3; add: 4; add:5;  yourself.
	otherCollection := OrderedCollection new add: 1;add: 20; add: 30; yourself.
	withoutEqualElements := OrderedCollection new add: 1;add: 20; add: 30; yourself.
	collectResult := OrderedCollection new add: SmallInteger; add: SmallInteger; add: SmallInteger; yourself.
	collectionOfCollectionsOfStrings:= OrderedCollection new add: (OrderedCollection new add: (OrderedCollection new add: 'foo'; yourself); add: (OrderedCollection new add: 'bar'; yourself); yourself); add: 'zorg'; yourself.
	simpleCollection := OrderedCollection new add: 1; add: 8; add: 3; yourself.
	collectionOfCollectionsOfInts := OrderedCollection new add: 1; add: (OrderedCollection new add: 2; add: 3; yourself); add: (OrderedCollection new add: 4; add: (OrderedCollection new add: 5; add: 6; yourself); yourself); yourself.
	withCharacters := OrderedCollection new add: $a; add: $x; add: $d; add: $c; add: $m; yourself.
	emptyButAllocatedWith20 := OrderedCollection new: 20. 
	collectionWithElement := OrderedCollection new add: self element; yourself.
	collectionOfFloat := OrderedCollection new add: 4.1; add: 7.2; add: 2.5; yourself.
	collectionOfString := OrderedCollection new add: 'a'; add: 'b'; add: 'c'; yourself.
	collectionWithSameBeginingEnd := OrderedCollection new add: 'a'; add: 'b'; add: 'a' 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: 'tests' stamp: ''!
testSorted
	| result tmp unsorted |
	unsorted := self unsortedCollection.
	result := unsorted sorted.
	self deny: unsorted == result.
	tmp := result at: 1.
	result
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!OrderedCollectionTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!OrderedCollectionTest methodsFor: 'tests - sorting' stamp: ''!
testIsSortedBy
	self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]).
	self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]).! !

!OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringMore

	"self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'.
	self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3'"

	| result resultAnd index allElementsAsString |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
 
	index := 1.
	(result findBetweenSubstrings: ',' )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 findBetweenSubstrings: ',' ).
	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 - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result:= self empty,self secondCollection .
	
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:i).
		].
	"size : "
	self assert: result size = ( self secondCollection size).! !

!OrderedCollectionTest methodsFor: 'tests - at put' stamp: ''!
testAtPutOutOfBounds
	
	self should: [self empty at: self anIndex put: self aValue] raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - accessing' stamp: ''!
testAt
	| collection |
	collection := #('Jim' 'Mary' 'John' 'Andrew') asOrderedCollection.
	self assert: (collection at: 1) equals: 'Jim'.
	self assert: (collection at: 2) equals: 'Mary'! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''!
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 - element accessing' stamp: ''!
testLast

	self assert: self moreThan4Elements last equals: (self moreThan4Elements at: self moreThan4Elements size)! !

!OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollectionKeepsIdentity
	| x y |
	x := (1 to: 5) asOrderedCollection.
	y := x asOrderedCollection.
	self assert: y identityHash equals: x identityHash! !

!OrderedCollectionTest methodsFor: 'tests - creation' stamp: ''!
testWith
	
	| aCol anElement |
	anElement := self collectionMoreThan5Elements anyOne.
	aCol := self collectionClass with: anElement.
	self assert: (aCol includes: anElement).! !

!OrderedCollectionTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation
	| result index |
	result:= self firstCollection,self secondCollection .
	"first part : "
	index := 1.
	self firstCollection do: 
		[:each | 
		self assert: (self firstCollection at: index)=each.
		index := index+1.].
	"second part : "
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:index).
		index:=index+1].
	"size : "
	self assert: result size = (self firstCollection size + self secondCollection size).! !

!OrderedCollectionTest methodsFor: 'tests - creation' stamp: ''!
testOfSize
	
	| aCol |
	aCol := self collectionClass ofSize: 3.
	self assert: aCol size equals: 3.! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
replacementCollection
" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection'  " 
	^ collectionWith4Elements! !

!OrderedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopyEmpty
	| result |
	result := self empty shallowCopy.
	self assertEmpty: result! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertAsSetForMultiplinessTest
	"a collection ofFloat with equal elements:"

	| res |
	self withEqualElements.
	self withEqualElements do: [ :each | self assert: each isFloat ].
	res := true.
	self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res equals: true.	"a collection of Float without equal elements:"
	res := true.
	self elementsCopyNonIdenticalWithoutEqualElements
		detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res equals: false! !

!OrderedCollectionTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContentsSized
	| result |
	result:= self collectionClass new: 1 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.
	
	result:= self collectionClass new: 1000 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionInForIncluding
	^ self nonEmpty copyWithoutFirst.! !

!OrderedCollectionTest methodsFor: 'tests - public methods' stamp: ''!
testAddBeforeIndex

	| coll |
	coll := #(1 2 3 4) asOrderedCollection.
	coll add: 77 beforeIndex: 1.
	self assert: coll equals: #(77 1 2 3 4) asOrderedCollection.
	coll add: 88 beforeIndex: 3.
	self assert: coll equals: #(77 1 88 2 3 4) asOrderedCollection. 
	coll add: 99 beforeIndex: coll size+1.
	self assert: coll equals: #(77 1 88 2 3 4 99) asOrderedCollection. 
	self should:[ coll add: 666 beforeIndex: 0 ] raise: Error.
	self should:[ coll add: 666 beforeIndex: coll size+2 ] raise: Error.
	
	"Now make room by removing first two and last two elements,
	and see if the illegal bounds test still fails"
	(coll first: 2), (coll last: 2) reversed do: [:e | coll remove: e].
	self should:[ coll add: 666 beforeIndex: 0 ] raise: Error.
	self should:[ coll add: 666 beforeIndex: coll size+2 ] raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
howMany: aSubCollection in: collection
" return an integer representing how many time 'subCollection'  appears in 'collection'  "
	| tmp nTime |
	tmp := collection.
	nTime:= 0.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				nTime := nTime + 1.
				1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.]
				]
			ifFalse: [tmp := tmp copyWithoutFirst.]
		 ].
	
	^ nTime.! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateSequencedReadableTest
	| res |
	self nonEmptyMoreThan1Element.
	self assert: self nonEmptyMoreThan1Element size > 1.

	self empty.
	self assertEmpty: self empty.

	res := true.
	self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
firstCollection
" return a collection that will be the first part of the concatenation"
	^ nonEmpty! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
unsortedCollection
	^ OrderedCollection new
		add: 3;
		add: 1;
		add: 20;
		add: 4;
		add: 2;
		yourself! !

!OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExists
 
	| el res |
	el := self nonEmptyWithoutEqualElements anyOne.
	res := self nonEmptyWithoutEqualElements remove: el.
	self assert: res == el! !

!OrderedCollectionTest methodsFor: 'parameters' stamp: ''!
accessValuePutIn
	"return access the element put in the non-empty collection"
	
	^ self perform: self selectorToAccessValuePutIn! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDo! !

!OrderedCollectionTest methodsFor: 'helpers' stamp: ''!
aValue

	^ 33! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessTest
	| res |
	self collectionMoreThan1NoDuplicates.
	self assert: self collectionMoreThan1NoDuplicates size > 1.
	res := true.
	self collectionMoreThan1NoDuplicates
		detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self elementInForIndexAccessing.
	self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing).
	self elementNotInForIndexAccessing.
	self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! !

!OrderedCollectionTest methodsFor: 'tests - as set tests' stamp: ''!
testAsIdentitySetWithEqualsElements

	| result collection |
	collection := self withEqualElements .
	result := collection asIdentitySet.
	collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = IdentitySet! !

!OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
	^ nonEmpty copyWithoutFirst.! !

!OrderedCollectionTest methodsFor: 'tests - copying with replacement' stamp: ''!
firstIndexesOf: aSubCollection in: collection
" return an OrderedCollection with the first indexes of the occurrences of subCollection in  collection "
	| tmp result currentIndex |
	tmp:= collection.
	result:= OrderedCollection new.
	currentIndex := 1.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				result add: currentIndex.
				1 to: aSubCollection size do: 
					[:i | 
					tmp := tmp copyWithoutFirst.
					currentIndex := currentIndex + 1]
				]
			ifFalse: [
				tmp := tmp copyWithoutFirst.
				currentIndex := currentIndex +1.
				]
		 ].
	
	^ result.! !

!OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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 - adding' stamp: ''!
testAddBeforeAndRemove
	| l initialCollection |
	l := #(1 2 3 4) asOrderedCollection.
	initialCollection := l shallowCopy.
	l add: 88 before: 1.
	self assert: l equals: #(88 1 2 3 4) asOrderedCollection.
	l add: 99 before: 2.
	self assert: l equals: #(88 1 99 2 3 4) asOrderedCollection.
	l remove: 99.
	l remove: 88.
	self assert: l equals: initialCollection! !

!OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testAddItem2
	| collection |
	collection := #('Jim' 'Mary' 'John' 'Andrew') asOrderedCollection.
	collection add: 'James' before: 'Jim'.
	collection add: 'Margaret' before: 'Andrew'.
	self assert: (collection indexOf: 'James') + 1 equals: (collection indexOf: 'Jim').
	self assert: (collection indexOf: 'Margaret') + 1 equals: (collection indexOf: 'Andrew')! !

!OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllError
	| el aSubCollection |
	el := self elementNotIn.
	aSubCollection := self nonEmptyWithoutEqualElements copyWith: el.
	self should: [ self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - removing' stamp: ''!
testRemoveAt
	"Allows one to remove an element from a collection at an index"
	
	| c1 |
	c1 := #(2 3 4 6) asOrderedCollection.
	c1 removeAt: 2.
	self assert: c1 equals: #(2 4 6) asOrderedCollection.
	self should: [ c1 removeAt: 10 ] raise: Error.
	self should: [ c1 removeAt: -1 ] raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - copying' stamp: ''!
testCopyFromTo
	"Allows one to create a copy of the receiver that contains elements from position start to end"

	| c1 c2 c3 |
	c1 := #(1 2 3 4) asOrderedCollection.
	c2 := c1 copyFrom: 1 to: 2.
	self assert: c2 equals: #(1 2) asOrderedCollection.
	self should: [ c1 copyFrom: 10 to: 20 ] raise: Error.

	c3 := c1 copyFrom: 4 to: 2.
	self assertEmpty: c3.

	self should: [ c1 copyFrom: 4 to: 5 ] raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	allElementsAsString withIndexDo: 
		[:el :i | 
		i=1
			ifTrue:[
				self accessCollection class name first isVowel 
					ifTrue:[self assert: el equals: 'an' ]
					ifFalse:[self assert: el equals: 'a'].].
		i=2
			ifTrue:[self assert: el equals: self accessCollection class name].
		i>2
			ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]]! !

!OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
testFirstNElements

	| result |
	result := self moreThan3Elements first: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i) ].
	
	self assert: result size equals: (self moreThan3Elements size - 1).
	self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: SubscriptOutOfBounds! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeWithIdentityTest

	| anElement |
	self collectionWithCopyNonIdentical.
	anElement := self collectionWithCopyNonIdentical anyOne.
	self deny: anElement == anElement copy! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
elementTwiceIn
	^ super elementTwiceIn! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the first occurrence:"
	result := collection   copyAfter: (element ).
	
	"Verifying content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + 1 )) equals: (result at: (i)) ].

	"Verify size"
	self assert: result size equals: (collection size - 1).! !

!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''!
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 equals: 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: 'requirements' stamp: ''!
elementNotInForElementAccessing
" return an element not included in 'accessCollection' "
	^ elementNotIn! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	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 - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDo
	"| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		result add: (value+i)].
	
	1 to: result size do:
		[:i|
		self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]"
	|  indexes elements |
	indexes := OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		indexes  add: (i).
		elements add: value].
	
	(1 to: self nonEmptyMoreThan1Element size )do:
		[ :i |
		self assert: (indexes at: i) equals: i.
		self assert: (elements at: i) equals: (self nonEmptyMoreThan1Element at: i).	
		].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	^ withoutEqualElements! !

!OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''!
testFromToPut
	
	| collection index |
	index := self indexArray anyOne.
	collection := self nonEmpty copy.
	collection from: 1 to: index  put: self aValue..
	1 to: index do:
		[:i | self assert: (collection at: i)= self aValue].
	(index +1) to: collection size do:
		[:i | self assert: (collection at:i)= (self nonEmpty at:i)].! !

!OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString |
	result:=''.
	aStream:= ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ').
	allElementsAsString withIndexDo: 
		[:el :i | 
		i<(allElementsAsString size-1 )
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:i)asString)].
		i=(allElementsAsString size-1)
			ifTrue:[ self deny: (allElementsAsString at:i) equals: ('and')asString].
		i=(allElementsAsString size)
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:(i-1))asString)]]! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!OrderedCollectionTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfSequenceableTest
	self collectionWithoutEqualElements.
	self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ].
	self indexInForCollectionWithoutDuplicates.
	self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size.
	self empty.
	self assertEmpty: self empty! !

!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfStartingAtDuplicate

	| 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 ]) equals: 1.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 55 ]) equals: collection size! !

!OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!OrderedCollectionTest methodsFor: 'tests - sorting' stamp: ''!
testSortUsingSortBlock
	| result tmp |
	result := self unsortedCollection sort: [:a :b | a>b].
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result index |
	delim := ', '.
	result := ''.
	multiItemStream := ReadWriteStream on: result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	index:=1.
	(result findBetweenSubstrings: delim)do:
		[:each |
			self assert: each= ((self nonEmpty at:index) asString).
			index:=index+1 ]! !

!OrderedCollectionTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsSetForIdentityMultiplinessTest
	"A collection (of elements for which copy is not identical ) without equal elements:"

	| anElement res |
	self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := self elementsCopyNonIdenticalWithoutEqualElements anyOne.
	self deny: anElement copy == anElement.
	res := true.
	self elementsCopyNonIdenticalWithoutEqualElements
		detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
subCollectionNotIn

	^ self collectionNotIncluded .! !

!OrderedCollectionTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContents
	| result |
	result:= self collectionClass streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedElementAccessTest

	self moreThan4Elements.
	self assert: self moreThan4Elements size >= 4.
	self subCollectionNotIn.
	self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ].
	self elementNotInForElementAccessing.
	self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing).
	self elementInForElementAccessing.
	self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! !

!OrderedCollectionTest methodsFor: 'tests - copying' stamp: ''!
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:"

	| 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 equals: #(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 equals: #(5 6 7 8 9 1 2 3 4) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfDuplicate

	| 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) equals: 1! !

!OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''!
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: 'requirements' stamp: ''!
collectionOfCollectionsOfInts
	^collectionOfCollectionsOfInts.! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOfIAbsent
	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) 
	     equals: 1.

	self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) 
		  equals: 55! !

!OrderedCollectionTest methodsFor: 'tests - removing' stamp: ''!
testRemoveFirst
	"Allows one to remove n element of a collection at the first"
	
	| c1 |
	c1 := #(2 3 4 6) asOrderedCollection.
	c1 removeFirst: 1.
	self assert: c1 equals: #(3 4 6) asOrderedCollection.
	c1 removeFirst: 2.
	self assert: c1 equals: #(6) asOrderedCollection.
	self should: [c1 removeFirst: 10] raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastError

	self 
		should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ]
		raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLast

	| element result |
	element := self nonEmptyMoreThan1Element at: self nonEmptyMoreThan1Element size.
	result := self nonEmptyMoreThan1Element findLast: [:each | each =element].
	
	self assert: result equals: self nonEmptyMoreThan1Element size! !

!OrderedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''!
testShuffled
	| result |
	result := self nonEmpty shuffled .
	
	"verify content of 'result: '"
	result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size.! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToEmpty
	| result |
	result := self empty copyUpTo: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!OrderedCollectionTest methodsFor: 'tests - streaming' stamp: ''!
testNewStreamContentsReturnsCollectionOfCorrectSize
	| result item originalSize |
	originalSize := 10.
	item := self firstCollection first.
	result := self collectionClass
		new: originalSize
		streamContents: [ :stream | 
			1 to: originalSize + 1 do: [ :each | stream nextPut: item ].
			stream position: originalSize ].
	self assert: result size equals: originalSize! !

!OrderedCollectionTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceFromToWith
	| result collection replacementCollec firstInd secondInd |
	collection := self nonEmpty .
	replacementCollec := self replacementCollectionSameSize.
	firstInd := self firstIndex.
	secondInd := self secondIndex.
	result := collection copy.
	result replaceFrom: firstInd to: secondInd with: replacementCollec.
	
	"Verify content of 'result'"

	"First part of 'result'"	
	1 to: (firstInd - 1) do: [:i | self assert: (collection at:i) equals: (result at: i) ].
	
	"Middle part containing replacementCollection"	
	firstInd to: (firstInd + replacementCollec size - 1) do: 
		[:i | self assert: (result at: i) equals: (replacementCollec at: (i - firstInd + 1)) ].
	
	"End part"
	(firstInd + replacementCollec size) to: (result size) do:
		[:i|
		self assert: (result at: i) equals: (collection at: (secondInd + 1 - (firstInd + replacementCollec size) + i)) ]! !

!OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementFromEmpty
	 
	self 
		should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ]
		raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButLastDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButLastDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i ))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element  size-1)! !

!OrderedCollectionTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllPutAll

	| aValueArray |
	aValueArray := self valueArray .
	self nonEmpty atAll: self indexArray putAll: aValueArray  .
	
	self indexArray withIndexDo: [:element :index |
		self assert: (self nonEmpty at: element) equals: (aValueArray  at: index) ]! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithEqualElements
" return a collecition including atLeast two elements equal"

^collectionWithDuplicateElement! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
elementTwiceInForOccurrences
" return an element included exactly two time in # collectionWithEqualElements"
^ duplicateElement! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollectError

	self should: [ self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := firstCollection size.
	
	firstCollection  reverseWith: secondCollection do:
		[:a :b |
	
		self assert: (firstCollection at: index) equals: a. 
		self assert: (secondCollection at: index) equals: b.
			(index := index - 1)]! !

!OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtOutOfBounds

	self 
		should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ]
		raise: Error.
	self 
		should: [ self moreThan4Elements at: -1 ]
		raise: Error! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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 - copying with replacement' stamp: ''!
testCopyReplaceAllWith1Occurrence
	| 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 - occurrencesOf' stamp: ''!
testOccurrencesOf
	| collection |
	collection := self collectionWithoutEqualElements .
	
	collection do: [ :each | self assert: (collection occurrencesOf: each) equals: 1 ]! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyEmptyMethod
	| result |
	result := self collectionWithoutEqualElements copyEmpty.
	self assertEmpty: result.
	self assert: result class equals: self nonEmpty class! !

!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollectAs

	self 
		assert: (self simpleCollection flatCollect: [ :x | { x }, { x } ] as: IdentitySet) 
		equals: self simpleCollection asIdentitySet.
	self
		assert: (#(foo bar baz) flatCollect: #yourself as: String)
		equals: 'foobarbaz'.
	self 
		assert: (#(#(1 2) #(4 3)) flatCollect: #yourself as: Array)
		equals: #(1 2 4 3)! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfter
	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection   copyAfter: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!OrderedCollectionTest methodsFor: 'parameters' stamp: ''!
accessValuePutInOn: s

	"return access the element put in the non-empty collection"
	
	^ s perform: self selectorToAccessValuePutIn! !

!OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollectAsSet

	self 
		assert: (self simpleCollection flatCollectAsSet: [ :x | { x }, { x } ]) 
		equals: self simpleCollection asSet! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithCopy
	"Return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals (with identity equality)
	but 2 elements only equals with classic equality"
	
	| result collection |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	collection add: collection first copy.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''!
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' stamp: ''!
testIdentityIncludes
	" test the comportement in presence of elements 'includes' but not 'identityIncludes' "

	" can not be used by collections that can't include elements for wich copy doesn't return another instance "

	| collection element |
	self collectionWithCopyNonIdentical.
	collection := self collectionWithCopyNonIdentical.
	element := collection anyOne copy.	"self assert: (collection includes: element)."
	self deny: (collection identityIncludes: element)! !

!OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
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 - iterate on sequenced reable collections' stamp: ''!
testFindFirst

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element findFirst: [:each | each = element].
	
	self assert: result equals: 1! !

!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
 	 'copyUpTo:' should copy until the first occurrence"
	result := collection copyUpTo: element.

	"Verify content"
	self assertEmpty: result! !

!OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''!
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) equals: index! !

!OrderedCollectionTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	 
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!OrderedCollectionTest methodsFor: 'tests - as set tests' stamp: ''!
testAsSetWithEqualsElements

	| result |
	result := self withEqualElements asSet.
	self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = Set! !

!OrderedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements

" return a collection not including equal elements "
	^ withoutEqualElements! !

!OrderedCollectionTest methodsFor: 'parameters' stamp: ''!
selectorToAccessValuePutIn
	"return the selector of the method that should be invoked to access an element"
	
	^ #first! !

!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureEmptySequenceableTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!OrderedDictionary commentStamp: ''!
I am a collection that act as a Dictionary except that I use key insertion order when enumerating, printing, or returing collections of keys/values/associations, but not when testing for equality (but it does not matters in this case).
I will assume that you know the Dictionary class in this comment.

I work mainly as a Dictionary except that I also store the keys in an Array that keeps the order of elements. 
I should be used ONLY if you need to keep the keys ordered. Else you should use a Dictionary that is faster and keep less values into memory. (I duplicate the keys).
Insertion, update, and inclusion testing have O(1) complexity while removing has O(n) worst-case.

### Public API and Key Messages

- #at: aKey put: aValue / #at: aKey ifAbsentPut: aValue / #at: aKey ifPresent: aBlock ifAbsent: aBlock		allow to add an element.  
- #at: aKey / #at: aKey ifAbsent: aBlock / #at: aKey ifPresent: aBlock ifAbsent: aBlock 		allow to access my values.
- #keysDo: aBlock / #valuesDo: aBlock / #associationsDo: 		allow to iterate on me effectively.
- #keyAtIndex: anIndex / KeyAtIndex: anIndex ifAbsent: aBlock 		allow to acess my keys from an index.

### Examples
	"For basic examples see Dictionary comment."
```	
	ordDic := (Dictionary with: 1 -> $a with: 2 -> $b) asOrderedDictionary.
	ordDic.   		"returns:  an OrderedDictionary(1->$a 2->$b)"
	ordDic keyAtIndex: 2.		"returns:  2"
```
	
### Internal Representation and Key Implementation Points.
Instance Variables
-	dictionary:			<Dictionary>		A dictionary where I store my keys and values.
-	orderedKeys:		<Array>			An ordered collection where I store my keys to maintain the order.

I base my implementation on a Dictionary and when I need to execute an action where the order of the values is important I use the keys in my ordered collection.!
!OrderedDictionary methodsFor: 'removing' stamp: 'nil'!
keysAndValuesRemove: aTwoArgumentBlock
	| removedAssociations |

	removedAssociations := OrderedCollection new.
	self associationsDo: [:each |
		(aTwoArgumentBlock value: each key value: each value)
			ifTrue: [removedAssociations add: each]].
	removedAssociations do: [:each | self removeKey: each key].! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
associationAt: aKey ifPresent: aBlock
	^ dictionary associationAt: aKey ifPresent: aBlock! !

!OrderedDictionary methodsFor: 'private' stamp: 'nil'!
orderedKeys
	^ orderedKeys! !

!OrderedDictionary methodsFor: 'testing' stamp: 'nil'!
includes: anObject
	^ dictionary includes: anObject! !

!OrderedDictionary methodsFor: 'comparing' stamp: 'nil'!
hash
	^ dictionary hash! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
dictionaryClass
	^ Dictionary! !

!OrderedDictionary methodsFor: 'testing' stamp: 'nil'!
includesAssociation: anAssociation
	^ dictionary includesAssociation: anAssociation! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
at: aKey ifPresent: aBlock
	^ dictionary at: aKey ifPresent: aBlock! !

!OrderedDictionary methodsFor: 'removing' stamp: 'nil'!
removeKeys: aKeyCollection
	"Fast removal of multiple keys; returns self to avoid
	having to create a removed value collection and does not
	raise errors."

	aKeyCollection	size > 1
		ifTrue: [| oldSize newOrderedKeys newOrderedKeysIndex |
			oldSize := self size.
			aKeyCollection do: [:each |
				dictionary
					removeKey: each
					ifAbsent: [nil]].

			newOrderedKeys := Array new: oldSize.
			newOrderedKeysIndex := 0.
			1 to: oldSize do: [:i | | key |
				(dictionary includesKey: (key := orderedKeys at: i))
					ifTrue: [
						newOrderedKeys
							at: (newOrderedKeysIndex := newOrderedKeysIndex + 1)
							put: key]].

			orderedKeys := newOrderedKeys]
		ifFalse: [
			aKeyCollection size = 1
				ifTrue: [
					"use #anyOne, because it can be a Set"
					self
						removeKey: aKeyCollection anyOne
						ifAbsent: [nil]]]! !

!OrderedDictionary methodsFor: 'testing' stamp: 'nil'!
hasBindingThatBeginsWith: aString
	^ dictionary hasBindingThatBeginsWith: aString! !

!OrderedDictionary methodsFor: 'testing' stamp: 'nil'!
isDictionary
	^ true! !

!OrderedDictionary methodsFor: 'adding' stamp: 'nil'!
declare: aKey from: aDictionary
	(self includesKey: aKey)
		ifTrue: [^ self].

	(aDictionary includesKey: aKey)
		ifTrue: [
			self add: (aDictionary associationAt: aKey).
			aDictionary removeKey: aKey]
		ifFalse: [self add: aKey -> nil]! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
associationAt: aKey
	^ dictionary associationAt: aKey! !

!OrderedDictionary methodsFor: 'private' stamp: 'nil'!
errorInvalidIndex: anIndex
	SubscriptOutOfBounds signalFor: anIndex! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
keyAtValue: aValue ifAbsent: aBlock
	^ dictionary keyAtValue: aValue ifAbsent: aBlock! !

!OrderedDictionary methodsFor: 'enumerating' stamp: 'nil'!
do: aBlock
	self valuesDo: aBlock! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
at: aKey ifAbsentPut: aBlock
	^ self at: aKey ifAbsent: [self at: aKey put: aBlock value]! !

!OrderedDictionary methodsFor: 'enumerating' stamp: 'nil'!
keysAndValuesDo: aBlock
	self keysDo: [:each | aBlock value: each value: (self at: each)]! !

!OrderedDictionary methodsFor: 'private' stamp: 'nil'!
orderedKeysIndexOf: aKey
	^ orderedKeys indexOf: aKey! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
at: key update: updateBlock initial: initBlocktOrValue
	"I am used to update the value at a given key. The updateBlock is passed 
	the existing value, and the result of the block is stored back.
	If the key does not exist, store the value of the initBlocktOrValue.
	initBlocktOrValue can be a block in case the initial value is expencive to compute."
	| val |
	val := self at: key ifAbsent: [ nil ].
	val 
		ifNil: [ self at: key put: (initBlocktOrValue value) ] 
		ifNotNil: [ self at: key put: (updateBlock value: val) ]! !

!OrderedDictionary methodsFor: 'enumerating' stamp: 'nil'!
collect: aBlock
	^ self species newFrom:
		(self associations collect: [:each |
			each key -> (aBlock value: each value)])! !

!OrderedDictionary methodsFor: 'removing' stamp: 'nil'!
removeKey: aKey ifAbsent: aBlock
	| oldSize value |

	oldSize := dictionary size.
	value := dictionary removeKey: aKey ifAbsent: aBlock.
	dictionary size < oldSize
		ifTrue: [self orderedKeysRemove: aKey].
	^ value.! !

!OrderedDictionary methodsFor: 'testing' stamp: 'nil'!
isHealthy
	^ dictionary isHealthy! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
identityIndexOfKey: aKey ifAbsent: aBlock
	1 to: self size do: [:i |
		(orderedKeys at: i) == aKey
			ifTrue: [^ i]].
	^ aBlock value.! !

!OrderedDictionary methodsFor: 'initialization' stamp: 'nil'!
initialize: aCapacity
	dictionary := self dictionaryClass new: aCapacity.
	orderedKeys := Array new: aCapacity.! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
associationAt: aKey ifAbsent: aBlock
	^ dictionary associationAt: aKey ifAbsent: aBlock! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
indexOfKey: aKey ifAbsent: aBlock
	1 to: self size do: [:i |
		(orderedKeys at: i) = aKey
			ifTrue: [^ i]].
	^ aBlock value.! !

!OrderedDictionary methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionItems: aBuilder
	<inspectorPresentationOrder: 0 title: 'Items'> 
	
	^ aBuilder newTable 
		addColumn: (SpStringTableColumn 
			title: 'Key'
			evaluated: [ :each | StObjectPrinter asTruncatedTextFrom: each key ])
			beSortable;
		addColumn: (SpStringTableColumn 
			title: 'Value' 
			evaluated: [ :each | StObjectPrinter asTruncatedTextFrom: each value ])
			beSortable;
		items: (self associations collect: [:e | StInspectorAssociationNode hostObject: e ]);
		yourself! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
identityIndexOfKey: aKey
	^ self identityIndexOfKey: aKey ifAbsent: [0]! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
associationAt: key ifPresent: aPresentBlock ifAbsent: anAbsentBlock
	^ dictionary associationAt: key ifPresent: aPresentBlock ifAbsent: anAbsentBlock! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
keyAtValue: aValue
	^ dictionary keyAtValue: aValue! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
at: aKey put: aValue
	| oldSize |

	oldSize := dictionary size.
	dictionary at: aKey put: aValue.
	dictionary size > oldSize
		ifTrue: [
			orderedKeys size > oldSize
				ifFalse: [self growOrderedKeys].
			orderedKeys at: oldSize + 1 put: aKey].
	^ aValue.! !

!OrderedDictionary methodsFor: 'private' stamp: 'nil'!
dictionary
	^ dictionary! !

!OrderedDictionary methodsFor: 'copying' stamp: 'nil'!
postCopy
	orderedKeys := orderedKeys copy.
	dictionary := dictionary copy.! !

!OrderedDictionary methodsFor: 'nested dictionaries' stamp: 'nil'!
at: firstKey at: secondKey put: aValue
	"Set a value at secondKey in the dictionary returned by firstKey."
	
	| subDictionary |
	subDictionary := self at: firstKey ifAbsentPut: [ self species new ].
	^ subDictionary at: secondKey put: aValue! !

!OrderedDictionary methodsFor: '*Random-Core' stamp: ''!
atRandom: aGenerator
	self emptyCheck.
	^ self at: (self orderedKeys at: (aGenerator nextInteger: self size)) ! !

!OrderedDictionary methodsFor: 'enumerating' stamp: 'nil'!
valuesDo: aBlock
	self keysDo: [:each | aBlock value: (self at: each)]! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
keyAtIdentityValue: aValue ifAbsent: aBlock
	^ dictionary keyAtIdentityValue: aValue ifAbsent: aBlock! !

!OrderedDictionary methodsFor: 'removing' stamp: 'nil'!
removeAll
	1 to: self size do: [:i | orderedKeys at: i put: nil].
	dictionary removeAll.! !

!OrderedDictionary methodsFor: 'removing' stamp: 'nil'!
removeKey: aKey
	| value |

	value := dictionary removeKey: aKey.
	self orderedKeysRemove: aKey.
	^ value.! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
size
	^ dictionary size! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
at: aKey ifPresent: aPresentBlock ifAbsent: anAbsentBlock
	^ dictionary
		at: aKey
		ifPresent: aPresentBlock
		ifAbsent: anAbsentBlock! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
keyForIdentity: anObject
	^ dictionary keyForIdentity: anObject! !

!OrderedDictionary methodsFor: 'testing' stamp: 'nil'!
includesKey: aKey
	^ dictionary includesKey: aKey! !

!OrderedDictionary methodsFor: 'nested dictionaries' stamp: 'nil'!
at: firstKey at: secondKey ifAbsentPut: aZeroArgBlock
	"Return the object stored in the second dictionary at secondKey. The second dictionary is accessed via the key firstKey. If firstKey is not defined, set a new dictionary for the second key and set the value of aZeroArgBlock execution. If firstKey is defined and not second key set the value of aZeroArgBlock execution. See NestedDictionaryTest for examples."

	| subDictionary |
	subDictionary := self at: firstKey ifAbsentPut: [ self species new ].
	^ subDictionary at: secondKey ifAbsentPut: aZeroArgBlock! !

!OrderedDictionary methodsFor: 'nested dictionaries' stamp: 'nil'!
at: firstKey at: secondKey
	"Return the object stored in the second dictionary at secondKey. The second dictionary is accessed via the key firstKey."

	"
	(Dictionary new
		at: #top at: #below1 put: 1;
		at: #top at: #below1 put: 2;
		at: #top at: #below1)
	>>>
	2"

	^ self at: firstKey at: secondKey ifAbsent: [ self errorKeyNotFound: secondKey ]! !

!OrderedDictionary methodsFor: '*Spec2-Core' stamp: ''!
replaceKey: aKey with: otherKey
	| value index |
	
	value := self at: aKey.
	index := orderedKeys indexOf: aKey.
	dictionary removeKey: aKey.
	dictionary at: otherKey put: value.
	orderedKeys at: index put: otherKey
	! !

!OrderedDictionary methodsFor: 'enumerating' stamp: 'nil'!
associationsDo: aBlock
	self keysDo: [:each | aBlock value: (self associationAt: each)]! !

!OrderedDictionary methodsFor: 'comparing' stamp: 'nil'!
= anObject
	self == anObject
		ifTrue: [^ true].

	(self species == anObject species
		and: [self size = anObject size])
		ifFalse: [^ false].

	dictionary associationsDo: [:each |
		(anObject at: each key ifAbsent: [^ false]) = each value
			ifFalse: [^ false]].
	^ true.! !

!OrderedDictionary methodsFor: 'adding' stamp: 'nil'!
add: anAssociation
	| oldSize |

	oldSize := dictionary size.
	dictionary add: anAssociation.
	dictionary size > oldSize
		ifTrue: [
			orderedKeys size > oldSize
				ifFalse: [self growOrderedKeys].
			orderedKeys at: oldSize + 1 put: anAssociation key].
	^ anAssociation.! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
associations
	| associations i |

	associations := Array new: self size.
	i := 1.
	self associationsDo: [:each |
		associations at: i put: each.
		i := i + 1].
	^ associations.! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
keyAtIdentityValue: aValue
	^ dictionary keyAtIdentityValue: aValue! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
keys
	^ orderedKeys copyFrom: 1 to: self size! !

!OrderedDictionary methodsFor: 'enumerating' stamp: 'nil'!
select: aBlock
	^ self species newFrom:
		(self associations select: [:each | aBlock value: each value])! !

!OrderedDictionary methodsFor: 'enumerating' stamp: 'nil'!
keysDo: aBlock
	1 to: self size do: [:i | aBlock value: (orderedKeys at: i)]! !

!OrderedDictionary methodsFor: '*NewValueHolder-Core' stamp: ''!
asValueHolder

	^ DictionaryValueHolder value: self! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
bindingOf: varName
	^ self associationAt: varName ifAbsent: [nil]! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
at: aKey
	^ dictionary at: aKey! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
at: aKey ifPresent: aPresentBlock ifAbsentPut: anAbsentBlock
	^ dictionary
		at: aKey
		ifPresent: aPresentBlock
		ifAbsent: [ self at: aKey put: anAbsentBlock value ]! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
at: aKey ifAbsent: aBlock
	^ dictionary at: aKey ifAbsent: aBlock! !

!OrderedDictionary methodsFor: 'nested dictionaries' stamp: 'nil'!
at: firstKey at: secondKey ifAbsent: aZeroArgBlock
		"Return the object stored in the second dictionary at secondKey. The second dictionary is accessed via the key firstKey. Execute aZeroArgBlock in case one of the key is wrong."
		
	| subDictionary |
	subDictionary := self at: firstKey ifAbsent: [ ^ aZeroArgBlock value ].
	^ subDictionary at: secondKey ifAbsent: aZeroArgBlock! !

!OrderedDictionary methodsFor: 'private' stamp: 'nil'!
orderedKeysRemove: aRemovedKey
	| index |

	index := self orderedKeysIndexOf: aRemovedKey.

	"shift every remaining key after to the left by one"
	orderedKeys
		replaceFrom: index
		to: self size
		with: orderedKeys
		startingAt: index + 1.

	"one key was removed and the rest shifted, so nil what was the last
	key slot before removing and shifting"
	orderedKeys
		at: self size + 1
		put: nil.! !

!OrderedDictionary methodsFor: 'enumerating' stamp: 'nil'!
associationsSelect: aBlock
	^ self species newFrom: (self associations select: aBlock)! !

!OrderedDictionary methodsFor: 'testing' stamp: 'nil'!
includesIdentity: anObject
	^ dictionary includesIdentity: anObject! !

!OrderedDictionary methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"I store my instances as maps. When in JSON mode, 
	encode me directly, without a class tag, keeping the order."
	
	stonWriter jsonMode 
		ifTrue: [ 
			stonWriter encodeMap: self ] 
		ifFalse: [ 
			stonWriter 
				writeObject: self 
				do: [ stonWriter encodeMap: self ] ]
! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
keyAtIndex: anIndex
	^ self keyAtIndex: anIndex ifAbsent: [self errorInvalidIndex: anIndex]! !

!OrderedDictionary methodsFor: 'printing' stamp: 'nil'!
printElementsOn: aStream
	aStream nextPut: $(.
	self size > 100
		ifTrue: [
			aStream nextPutAll: 'size '.
			self size printOn: aStream]
		ifFalse: [
			self associations withIndexDo: [:each :i |
				aStream
					print: each key;
					nextPutAll: '->';
					print: each value.
				(i < self size)
					ifTrue: [aStream space]]].
	aStream nextPut: $).! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
indexOfKey: aKey
	^ self indexOfKey: aKey ifAbsent: [0]! !

!OrderedDictionary methodsFor: 'private' stamp: 'nil'!
growOrderedKeys
	orderedKeys :=
		(Array new: ((orderedKeys size * 1.5) asInteger max: 10))
			replaceFrom: 1
			to: orderedKeys size
			with: orderedKeys
			startingAt: 1.! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
at: key update: updateBlock 
	"I am used to update the value at a given key, or if the key does not exist, to throw an error"
	self at: key update: updateBlock initial: [ KeyNotFound signalFor: key ].! !

!OrderedDictionary methodsFor: 'enumerating' stamp: 'nil'!
bindingsDo: aBlock
	self associationsDo: aBlock! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
capacity
	^ dictionary capacity! !

!OrderedDictionary methodsFor: '*Microdown' stamp: ''!
at: key add: value
	"Store value under key. If key already exists, store multiple values as Array"
	
	| existingValue newValue |
	existingValue := self at: key ifAbsent: [ nil ].
	newValue := existingValue isNil
		ifTrue: [ value ] 
		ifFalse: [
			existingValue isArray 
				ifTrue: [ existingValue copyWith: value ]
				ifFalse: [ Array with: existingValue with: value ] ].
	^ self at: key put: newValue 

! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
keyAtIndex: anIndex ifAbsent: aBlock
	^ (anIndex > 0 and: [ anIndex <= self size ])
		ifTrue: [ orderedKeys at: anIndex ]
		ifFalse: [ aBlock value ]! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
values
	^ self associations collect: [:each | each value]! !

!OrderedDictionary methodsFor: 'accessing' stamp: 'nil'!
keysSortedSafely
	^ dictionary keysSortedSafely! !

!OrderedDictionary methodsFor: 'adding' stamp: 'nil'!
addAll: anAssociationCollection
	"Since Collection implements #associationsDo:, this method can accept
	any collection of associations including Arrays and OrderedCollections"

	anAssociationCollection associationsDo: [:each | self add: each].
	^ anAssociationCollection.! !

!OrderedDictionary methodsFor: 'printing' stamp: 'nil'!
storeOn: aStream
	aStream << '((' << self class name << ' new)'.
	self associations
		ifNotEmpty: [ :assos | 
			assos
				do: [ :each | 
					aStream
						<< ' add: ';
						store: each ]
				separatedBy: [ aStream << ';' ].
			aStream << '; yourself' ].
	aStream << ')'! !

!OrderedDictionary methodsFor: 'removing' stamp: 'nil'!
remove: anObject ifAbsent: aBlock
	self shouldNotImplement! !

!OrderedDictionary class methodsFor: 'instance creation' stamp: 'nil'!
new
	^ self new: 10! !

!OrderedDictionary class methodsFor: 'instance creation' stamp: 'nil'!
new: aCapacity
	^ self basicNew initialize: aCapacity! !

!OrderedDictionary class methodsFor: 'instance creation' stamp: 'nil'!
newFromKeys: keys andValues: values
	"Create a dictionary from the keys and values arguments which should have the same length."
	
	"(OrderedDictionary newFromKeys: #(#x #y) andValues: #(3 6)) >>> (OrderedDictionary new at: #x put: 3; at: #y put: 6 ;yourself)"
	
	| dict |
	dict := self new.
	keys with: values do: [ :k :v | dict at: k put: v ].
	^ dict! !

!OrderedDictionary class methodsFor: 'instance creation' stamp: 'nil'!
newFromPairs: aSequenceableCollection
	| newDictionary |

	newDictionary := self new: (aSequenceableCollection size / 2) floor.
	1 to: aSequenceableCollection size - 1 by: 2 do: [:i |
		newDictionary
			at: (aSequenceableCollection at: i)
			put: (aSequenceableCollection at: i + 1)].
	^ newDictionary.! !

!OrderedDictionary class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"My instances are stored as maps."
	
	| dictionary |
	dictionary := self new.
	stonReader parseMapDo: [ :key :value |
		dictionary at: key put: value ].
	^ dictionary! !

!OrderedDictionary class methodsFor: 'instance creation' stamp: 'nil'!
newFrom: anAssociationCollection
	| newDictionary |

	newDictionary := self new: anAssociationCollection size.
	anAssociationCollection associationsDo: [:each |
		newDictionary
			at: each key
			put: each value].
	^ newDictionary.! !

!OrderedDictionaryTest commentStamp: ''!
This class tests the OrderedDictionary class. It is separate from DictionaryTest to test that accessing, enumerating, and printing methods preserve the order that keys were inserted in.!
!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
orderedKeys

	^ self orderedAssociations collect: [:each | each key]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
collectClass

	^ Array! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeyAtIdentityValue
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self
			should: [dictionary keyAtIdentityValue: each value]
			raise: Error.

		dictionary add: each.
		self assert: (dictionary keyAtIdentityValue: each value) equals: each key.
		self
			should: [dictionary keyAtIdentityValue: each value copy]
			raise: Error]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
dictionaryClass

	^ OrderedDictionary! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtUpdate
	| dict |
	dict := OrderedDictionary newFrom: {2->10. 100->5} .
	
	dict at: 2 update: [ :v | v+10 ].
	self assert: (dict at: 2) equals: 20.
	self should: [ dict at: 5 update: [ :v | v+1 ] ] raise: KeyNotFound .! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testSelect
	| dictionary |

	dictionary := self dictionaryWithOrderedAssociations.
	self orderedValues do: [:value | | selectedValues |
		selectedValues := self orderedValues copyWithout: value.
		self
			assertIsDictionary:
				(dictionary select: [:each |
					selectedValues includes: each])
			copiedFrom: dictionary
			withOrderedAssociations:
				(self orderedAssociations select: [:each |
					selectedValues includes: each value])].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeysAndValuesRemove
	| dictionary |
	dictionary := self dictionaryWithOrderedAssociations.
	self orderedAssociations
		withIndexDo: [ :removedAssociation :i | 
			| unremovedAssociations |
			unremovedAssociations := (self orderedAssociationsAllButFirst: i) asOrderedCollection.
			dictionary
				keysAndValuesRemove: [ :key :value | 
					(self isTestingIdentityDictionary ifTrue: [ key == removedAssociation key ] ifFalse: [ key = removedAssociation key ])
						ifTrue: [ self assert: value equals: removedAssociation value.
							true ]
						ifFalse: [ | unremovedAssociation |
							unremovedAssociation := unremovedAssociations removeFirst.
							self isTestingIdentityDictionary
								ifTrue: [ self assert: key identicalTo: unremovedAssociation key ]
								ifFalse: [ self assert: key equals: unremovedAssociation key ].
							self assert: value equals: unremovedAssociation value.
							false ] ].
			self assertEmpty: unremovedAssociations.
			self assertKey: removedAssociation key wasRemovedfrom: dictionary ].
	self assertEmpty: dictionary! !

!OrderedDictionaryTest methodsFor: 'assertions' stamp: ''!
assertIsArray: anArray withElements: aCollection

	self
		assert: anArray isArray;
		assert: anArray equals: aCollection asArray! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testHash
	| dictionary otherDictionary internalDictionary otherInternalDictionary |
	dictionary := self emptyDictionary.
	otherDictionary := self emptyDictionary.
	internalDictionary := self emptyInternalDictionary.
	otherInternalDictionary := self emptyInternalDictionary.
	self assert: dictionary hash equals: otherDictionary hash.
	self orderedAssociations
		do: [ :each | 
			dictionary add: each.
			internalDictionary add: each copy.
			"if the internal hashes differ after adding to one, the external should too"
			internalDictionary hash = otherInternalDictionary hash ifFalse: [ self deny: dictionary hash equals: otherDictionary hash ].

			otherDictionary add: each copy.
			otherInternalDictionary add: each copy.
			"should be equal regardless now"
			self assert: dictionary hash equals: otherDictionary hash ]! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAssociations
	| dictionary |

	dictionary := self emptyDictionary.
	self
		assertIsArray: dictionary associations
		withElements: #().
	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		self
			assertIsArray: dictionary associations
			withElements: (self orderedAssociationsFirst: i)].! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
orderedAssociations
	^self isTestingIdentityDictionary
		ifTrue: [ self identityOrderedAssociations ]
		ifFalse: [ self nonIdentityOrderedAssociations ]! !

!OrderedDictionaryTest methodsFor: 'tests - creation' stamp: ''!
testNewFromKeysAndValues2
 
	| dict newDict |
	dict := self dictionaryClass new
	       at: #a put: 1;
			 at: #b put: 2;
			 at: #c put: 3; yourself.
	newDict := self dictionaryClass newFromKeys: dict keys andValues: dict values.
	dict keysAndValuesDo: [:k :v|
		self assert: (newDict at: k) equals: v ].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testEquals
	| dictionaryOne dictionaryTwo |

	dictionaryOne := self emptyDictionary.
	dictionaryTwo := self emptyDictionary.
	self
		assertDictionary: dictionaryOne
		equals: dictionaryTwo.

	"For equality, order will not matter"
	self orderedAssociations
		with: self orderedAssociations reversed
		do: [:firstAssociation :secondAssociation |
			dictionaryOne add: firstAssociation.
			dictionaryTwo add: secondAssociation.
			self
				assertDictionary: dictionaryOne
				doesNotEqual: self emptyDictionary.
			self
				assertDictionary: dictionaryTwo
				doesNotEqual: self emptyDictionary.
			dictionaryOne size < self orderedAssociations size
				ifTrue: [
					self
						assertDictionary: dictionaryOne
						doesNotEqual: dictionaryTwo]].

	self
		assertDictionary: dictionaryOne
		equals: dictionaryTwo.! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeyAtValue
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self
			should: [dictionary keyAtValue: each value]
			raise: Error.

		dictionary add: each.
		self assert: (dictionary keyAtValue: each value) equals: each key].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testNewFrom
	| dictionary |
	
	dictionary := self dictionaryClass newFrom: self orderedAssociations.
	self
		assertIsDictionary: dictionary
		withOrderedAssociations: self orderedAssociations.
	self
		assertIsDictionary: (self dictionaryClass newFrom: dictionary)
		copiedFrom: dictionary
		withOrderedAssociations: self orderedAssociations.
	self
		assertIsDictionary:
			(self dictionaryClass newFrom: self internalDictionaryWithAssociations)
		withUnorderedAssociations: self orderedAssociations.! !

!OrderedDictionaryTest methodsFor: '*Random-Tests' stamp: ''!
testAtRandom
	| dict random |
	dict := { #one -> 1 . #two -> 2 . #three -> 3  } asOrderedDictionary.
	random := dict atRandom.
	self assert: (#(1 2 3) includes: random).
	self assert: (dict includes: random).
	! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAdd
	| dictionary |
	dictionary := self emptyDictionary.
	self orderedAssociations
		withIndexDo: [ :each :i | 
			self
				deny: (dictionary includesAssociation: each);
				assert: (dictionary add: each) identicalTo: each;
				assert: (dictionary includesAssociation: each).
			self assertIsDictionary: dictionary withOrderedAssociations: (self orderedAssociationsFirst: i) ].

	"ensure adding the same associations doesn't change the order"
	self orderedAssociations
		reverseDo: [ :each | 
			self assert: (dictionary add: each) identicalTo: each.
			self assertIsDictionary: dictionary withOrderedAssociations: self orderedAssociations ].

	self changedOrderedAssociations
		withIndexDo: [ :each :i | 
			| old |
			old := self orderedAssociations at: i.
			self
				assert: (dictionary add: each) identicalTo: each;
				assert: (dictionary includesAssociation: each);
				deny: (dictionary includesAssociation: old).
			self assertIsDictionary: dictionary withOrderedAssociations: (self changedOrderedAssociationsFirst: i) , (self orderedAssociationsAllButFirst: i) ]! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeyAtValueIfAbsent
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self assert:
			(dictionary
				keyAtValue: each value
				ifAbsent: [self absentKey]) equals: self absentKey.

		dictionary add: each.
		self assert:
			(dictionary
				keyAtValue: each value
				ifAbsent: [self fail]) equals: each key].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtIfAbsentPut
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations withIndexDo: [:each :i |
		self assert:
			(dictionary
				at: each key
				ifAbsentPut: [each value]) equals: each value.
		self assert:
			(dictionary
				at: each key
				ifAbsentPut: [self fail]) equals: each value.
		self
			assertIsArray: dictionary keys
			withElements: (self orderedKeysFirst: i) ]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
orderedAssociationsFirst: anInteger

	^ self orderedAssociations first: anInteger! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testValuesDo
	| dictionary |

	dictionary := self emptyDictionary.
	self
		should: [:block | dictionary valuesDo: block]
		enumerate: #().
	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		self
			should: [:block | dictionary valuesDo: block]
			enumerate: (self orderedValuesFirst: i)].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testCollect
	| dictionary |

	dictionary := self dictionaryWithOrderedAssociations.
	self
		assertIsDictionary:
			(dictionary collect: [:each | each hash])
		copiedFrom: dictionary
		withOrderedAssociations:
			(self orderedAssociations collect: [:each | each key -> each value hash]).! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtIfPresentIfAbsent
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self assert:
			(dictionary
				at: each key
				ifPresent: [self fail]
				ifAbsent: [self absentValue]) equals: self absentValue.

		dictionary add: each.
		self assert:
			(dictionary
				at: each key
				ifPresent: [:value | self newValue -> value]
				ifAbsent: [self fail]) equals: (self newValue -> each value).
		"ensure cull: is used"
		self assert:
			(dictionary
				at: each key
				ifPresent: [self newValue]
				ifAbsent: [self fail]) equals: self newValue].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testIdentityIndexOfKeyIfAbsent
	| dictionary |
	dictionary := self emptyDictionary.
	self orderedAssociations
		withIndexDo: [ :each :i | 
			self assert: (dictionary identityIndexOfKey: each key ifAbsent: [ self absentValue ]) equals: self absentValue.

			dictionary add: each.
			self assert: (dictionary identityIndexOfKey: each key ifAbsent: [ self fail ]) equals: i.
			self assert: (dictionary identityIndexOfKey: each key copy ifAbsent: [ self absentValue ]) equals: self absentValue ]! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAddAll
	| dictionary addedAssociations |
	dictionary := self emptyDictionary.
	self orderedAssociations do: [ :each | self deny: (dictionary includesAssociation: each) ].

	addedAssociations := self orderedAssociations.
	self assert: (dictionary addAll: addedAssociations) identicalTo: addedAssociations.
	self assertIsDictionary: dictionary withOrderedAssociations: self orderedAssociations.

	"ensure adding the same associations doesn't change the order"
	addedAssociations := self orderedAssociations reversed.
	self assert: (dictionary addAll: addedAssociations) identicalTo: addedAssociations.
	self assertIsDictionary: dictionary withOrderedAssociations: self orderedAssociations.

	addedAssociations := self changedOrderedAssociations.
	self assert: (dictionary addAll: addedAssociations) identicalTo: addedAssociations.
	self assertIsDictionary: dictionary withOrderedAssociations: self changedOrderedAssociations! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtPut
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations withIndexDo: [:each :i |
		self assert:
			(dictionary
				at: each key
				put: each value) equals: each value.
		self
			assertIsDictionary: dictionary
			withOrderedAssociations: (self orderedAssociationsFirst: i)].

	self changedOrderedAssociations withIndexDo: [:each :i |
		self assert:
			(dictionary
				at: each key
				put: each value) equals: each value.
		self
			assertIsDictionary: dictionary
			withOrderedAssociations:
				(self changedOrderedAssociationsFirst: i),
				(self orderedAssociationsAllButFirst: i)].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAssociationAtIfAbsent
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self assert:
			(dictionary
				associationAt: each key
				ifAbsent: [self absentValue]) equals: self absentValue.

		dictionary add: each.
		self assert:
			(dictionary
				associationAt: each key
				ifAbsent: [self fail]) equals: each].! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
identityAbsentKey

	^ self orderedKeys first copy! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testSize
	| dictionary |

	dictionary := self emptyDictionary.
	self assert: dictionary size equals: 0.

	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		self assert: dictionary size equals: i].

	self orderedAssociations size to: 1 by: -1 do: [:i |
		dictionary removeKey: (self orderedKeys at: i).
		self assert: dictionary size equals: (i - 1)].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeysDo
	| dictionary |

	dictionary := self emptyDictionary.
	self
		should: [:block | dictionary keysDo: block]
		enumerate: #().
	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		self
			should: [:block | dictionary keysDo: block]
			enumerate: (self orderedKeysFirst: i)].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAssociationsSelect
	| dictionary |

	dictionary := self dictionaryWithOrderedAssociations.
	self orderedAssociations do: [:assoc | | selectedAssociations |
		selectedAssociations := self orderedAssociations copyWithout: assoc.
		self
			assertIsDictionary:
				(dictionary associationsSelect: [:each |
					selectedAssociations includes: each])
			copiedFrom: dictionary
			withOrderedAssociations:
				(self orderedAssociations select: [:each |
					selectedAssociations includes: each])].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtIfAbsent
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self assert:
			(dictionary
				at: each key
				ifAbsent: [self absentValue]) equals: self absentValue.

		dictionary add: each.
		self assert:
			(dictionary
				at: each key
				ifAbsent: [self fail]) equals: each value].! !

!OrderedDictionaryTest methodsFor: 'assertions' stamp: ''!
assertDictionary: aFirstDictionary equals: aSecondDictionary
	"Test reflixive and symmetric equality."
	
	self
		assert: aFirstDictionary equals: aFirstDictionary;
		assert: aFirstDictionary equals: aSecondDictionary;
		assert: aSecondDictionary equals: aSecondDictionary;
		assert: aSecondDictionary equals: aFirstDictionary! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
emptyDictionary

	^ self dictionaryClass new! !

!OrderedDictionaryTest methodsFor: 'assertions' stamp: ''!
assertDictionary: aFirstDictionary doesNotEqual: aSecondDictionary
	"Test symmetric inequality"

	self
		deny: aFirstDictionary equals: aSecondDictionary;
		deny: aSecondDictionary equals: aFirstDictionary! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
nonIdentityOrderedAssociations
	"Returns ordered associations to use for non-identity dictionaries.
	The keys are all #= and #== different and are returned out of their
	natural sort order."
	nonIdentityOrderedAssociations
		ifNil: [
			nonIdentityOrderedAssociations :=
				Array
					with: 'testKey' -> 'testValue'
					with: 'testKey3' -> 'testValue3'
					with: 'testKey2' -> 'testValue2'
					with: 'testKey4' -> 'testValue4'].
	"return copies of the associations so they can be safely modified
	in one test without affecting another, but do not copy the keys
	and values"
	^ nonIdentityOrderedAssociations collect: [:each | each copy].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testIncludesAssociation
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self
			deny: (dictionary includesAssociation: each);
			deny: (dictionary includesAssociation: each key -> each value).

		dictionary add: each.
		self
			assert: (dictionary includesAssociation: each);
			assert: (dictionary includesAssociation: each key -> each value)].! !

!OrderedDictionaryTest methodsFor: 'assertions' stamp: ''!
should: aBlock enumerate: aFirstCollection and: aSecondCollection
	| firstEnumerated secondEnumerated |

	firstEnumerated := OrderedCollection new.
	secondEnumerated := OrderedCollection new.
	aBlock value: [:first :second |
		firstEnumerated addLast: first.
		secondEnumerated addLast: second].
	self
		assert: firstEnumerated equals: aFirstCollection asOrderedCollection;
		assert: secondEnumerated equals: aSecondCollection asOrderedCollection.! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testDictionary
	| dictionary |
	dictionary := self emptyDictionary.
	self
		assert: dictionary dictionary class identicalTo: self internalDictionaryClass;
		assert: dictionary dictionary equals: self emptyInternalDictionary.

	dictionary := self dictionaryWithOrderedAssociations.
	self
		assert: dictionary dictionary class identicalTo: self internalDictionaryClass;
		assert: dictionary dictionary equals: self internalDictionaryWithAssociations! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testIndexOfKey
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations withIndexDo: [:each :i |
		self assert: (dictionary indexOfKey: each key) equals: 0.

		dictionary add: each.
		self assert: (dictionary indexOfKey: each key) equals: i].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAt
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self
			should: [dictionary at: each key]
			raise: Error.

		dictionary add: each.
		self assert: (dictionary at: each key) equals: each value].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeyAtIndex
	| dictionary |

	dictionary := self emptyDictionary.
	self
		should: [dictionary keyAtIndex: 0]
		raise: Error.
	self orderedAssociations withIndexDo: [:each :i |
		self
			should: [dictionary keyAtIndex: i]
			raise: Error.

		dictionary add: each.
		self assert: (dictionary keyAtIndex: i) equals: each key].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testStoreOn
	| print |
	print := String streamContents: [ :s | self orderedAssociations storeOn: s ].
	self assertDictionary: (self class compiler evaluate: print) equals: self orderedAssociations.
	print := String streamContents: [ :s | self emptyDictionary storeOn: s ].
	self assertDictionary: (self class compiler evaluate: print) equals: self emptyDictionary! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeyAtIdentityValueIfAbsent
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self assert:
			(dictionary
				keyAtIdentityValue: each value
				ifAbsent: [self absentKey]) equals: self absentKey.

		dictionary add: each.
		self assert:
			(dictionary
				keyAtIdentityValue: each value
				ifAbsent: [self fail]) equals: each key.
		self assert:
			(dictionary
				keyAtIdentityValue: each value copy
				ifAbsent: [self absentKey]) equals: self absentKey].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testBindingsDo
	| dictionary |

	dictionary := self emptyDictionary.
	self
		should: [:block | dictionary bindingsDo: block]
		enumerate: #().
	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		self
			should: [:block | dictionary bindingsDo: block]
			enumerate: (self orderedAssociationsFirst: i)].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtIfPresent
	| dictionary |
	dictionary := self emptyDictionary.
	self orderedAssociations
		do: [ :each | 
			self assert: (dictionary at: each key ifPresent: [ self fail ]) isNil.

			dictionary add: each.
			self assert: (dictionary at: each key ifPresent: [ :value | self newValue -> value ]) equals: self newValue -> each value.
			"ensure cull: is used"
			self assert: (dictionary at: each key ifPresent: [ self newValue ]) equals: self newValue ]! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testEqualsOtherOrderedDictionaries
	self otherOrderedDictionaryClasses do: [:each |
		self
			assertDictionary: self emptyDictionary
			doesNotEqual: each new.
		self
			assertDictionary: self dictionaryWithOrderedAssociations
			doesNotEqual: (each newFrom: self orderedAssociations)]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
orderedKeysFirst: anInteger

	^ self orderedKeys first: anInteger! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testRemoveAll
	| dictionary removedKeys |
	dictionary := self dictionaryWithOrderedAssociations.
	removedKeys := dictionary keys.
	self
		denyEmpty: dictionary;
		assert: dictionary removeAll identicalTo: dictionary;
		assertEmpty: dictionary.
	removedKeys do: [ :each | self assertKey: each wasRemovedfrom: dictionary ]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
emptyInternalDictionary

	^ self internalDictionaryClass new! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
internalDictionaryWithAssociations

	^ self internalDictionaryClass newFrom: self orderedAssociations! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testRemoveKey
	| dictionary |

	dictionary := self dictionaryWithOrderedAssociations.
	self orderedAssociations withIndexDo: [:each :i |
		self assert: (dictionary removeKey: each key) equals: each value.
		self
			assertKey: each key
			wasRemovedfrom: dictionary.
		self
			assertIsDictionary: dictionary
			withOrderedAssociations: (self orderedAssociationsAllButFirst: i).

		self
			should: [dictionary removeKey: each key]
			raise: Error]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
orderedValues

	^ self orderedAssociations collect: [:each | each value]! !

!OrderedDictionaryTest methodsFor: 'assertions' stamp: ''!
assertKey: aKey wasRemovedfrom: aDictionary

	self deny: (aDictionary includesKey: aKey).
	aDictionary keys asArray, aDictionary orderedKeys asArray do: [:each |
		self deny:
			(self isTestingIdentityDictionary
				ifTrue: [each == aKey]
				ifFalse: [each = aKey])].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testDo
	| dictionary |

	dictionary := self emptyDictionary.
	self
		should: [:block | dictionary do: block]
		enumerate: #().
	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		self
			should: [:block | dictionary do: block]
			enumerate: (self orderedValuesFirst: i)].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testRemoveKeys
	0 to: self orderedAssociations size do: [ :i | 
		| dictionary keysToRemove |
		dictionary := self dictionaryWithOrderedAssociations.

		"make it a set to ensure it supports non-Sequenceable collections"
		keysToRemove := (self isTestingIdentityDictionary ifTrue: [ IdentitySet ] ifFalse: [ Set ]) withAll: (self orderedKeysFirst: i).
		self assert: (dictionary removeKeys: keysToRemove) identicalTo: dictionary.
		keysToRemove do: [ :each | self assertKey: each wasRemovedfrom: dictionary ].

		self assertIsDictionary: dictionary withOrderedAssociations: (self orderedAssociationsAllButFirst: i) ]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
internalDictionaryClass

	^self isTestingIdentityDictionary
		ifTrue: [ IdentityDictionary]
		ifFalse: [ Dictionary]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
identityOrderedAssociations
	"Returns ordered associations to use for identity dictionaries.
	The keys are all #= equal but #== different, so only an
	identity dictionary will be able to distinguish them."
	identityOrderedAssociations
		ifNil: [| key |
			key := 'testKey'.
			identityOrderedAssociations :=
				Array
					with: (key := key copy) -> 'testValue'
					with: (key := key copy) -> 'testValue3'
					with: (key := key copy) -> 'testValue2'
					with: (key := key copy) -> 'testValue4'].
	"Return copies of the associations so they can be safely modified
	in one test without affecting another, but do not copy the keys
	and values"
	^ identityOrderedAssociations collect: [:each | each copy].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testIncludesKey
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self deny: (dictionary includesKey: each key).

		dictionary add: each.
		self assert: (dictionary includesKey: each key)].! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
orderedValuesFirst: anInteger

	^ self orderedValues first: anInteger! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
changedOrderedAssociationsFirst: anInteger

	^ self changedOrderedAssociations first: anInteger! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testCopy
	| dictionary copy |

	dictionary := self dictionaryWithOrderedAssociations.
	copy := dictionary copy.
	self
		assertIsDictionary: dictionary
		withOrderedAssociations: self orderedAssociations.
	self
		assertIsDictionary: copy
		copiedFrom: dictionary
		withOrderedAssociations: self orderedAssociations.! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtIfPresentIfAbsentPut
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations withIndexDo: [:each :i |
		self assert:
			(dictionary
				at: each key
				ifPresent: [ self fail ]
				ifAbsentPut: [ each value ]) equals: each value.
		self assert:
			(dictionary
				at: each key
				ifPresent: [ :it | self newValue -> it ]
				ifAbsentPut: [self fail]) equals: (self newValue -> each value).
		self
			assertIsArray: dictionary keys
			withElements: (self orderedKeysFirst: i) ]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
absentKey

	^self isTestingIdentityDictionary
		ifTrue: [ self identityAbsentKey ]
		ifFalse: [ self nonIdentityAbsentKey ]! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAssociationAtIfPresent
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self assert:
			(dictionary
				associationAt: each key
				ifPresent: [self fail]) isNil.

		dictionary add: each.
		self assert:
			(dictionary
				associationAt: each key
				ifPresent: [:assoc | self newValue -> assoc]) equals: (self newValue -> each).
		"ensure cull: is used"
		self assert:
			(dictionary
				associationAt: each key
				ifPresent: [self newValue]) equals: self newValue].! !

!OrderedDictionaryTest methodsFor: 'assertions' stamp: ''!
assertIsDictionary: anObject withUnorderedAssociations: anAssociationCollection
	"Tests that anObject is an instance of the correct dictionary class
	with the specified associations, but ignoring the order"

	self
		assert: anObject class identicalTo: self dictionaryClass;
		assert: anObject size equals: anAssociationCollection size.
	anAssociationCollection do: [ :each | self assert: (anObject includesAssociation: each) ]! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testIsDictionary
	self assert: self dictionaryClass new isDictionary! !

!OrderedDictionaryTest methodsFor: 'assertions' stamp: ''!
assertIsDictionary: aFirstDictionary copiedFrom: aSecondDictionary withOrderedAssociations: anAssociationCollection
	self
		deny: aFirstDictionary identicalTo: aSecondDictionary;
		deny: aFirstDictionary dictionary identicalTo: aSecondDictionary dictionary;
		deny: aFirstDictionary orderedKeys identicalTo: aSecondDictionary orderedKeys.

	"esnure the associations were copied (the keys and values can be shared)"
	aFirstDictionary associations do: [ :each | self deny: (aSecondDictionary associations identityIncludes: each) ].

	self assertIsDictionary: aFirstDictionary withOrderedAssociations: anAssociationCollection! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeysAndValuesDo
	| dictionary |

	dictionary := self emptyDictionary.
	self
		should: [:block | dictionary keysAndValuesDo: block]
		enumerate: #()
		and: #().
	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		self
			should: [:block | dictionary keysAndValuesDo: block]
			enumerate: (self orderedKeysFirst: i)
			and: (self orderedValuesFirst: i)].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testDeclareFrom
	| dictionary otherDictionary |
	dictionary := self emptyDictionary.
	otherDictionary := self dictionaryWithOrderedAssociations.
	self orderedKeys do: [ :each | self assert: (dictionary declare: each from: otherDictionary) identicalTo: dictionary ].
	self assertIsDictionary: dictionary withOrderedAssociations: self orderedAssociations.
	self assertEmpty: otherDictionary.

	self orderedKeys
		do: [ :each | 
			otherDictionary add: each -> self newValue.
			self assert: (dictionary declare: each from: otherDictionary) identicalTo: dictionary ].
	self assertIsDictionary: dictionary withOrderedAssociations: self orderedAssociations! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeyForIdentity
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self assert: (dictionary keyForIdentity: each value) isNil.

		dictionary add: each.
		self
			assert: (dictionary keyForIdentity: each value) equals: each key;
			assert: (dictionary keyForIdentity: each value copy) isNil].! !

!OrderedDictionaryTest methodsFor: 'assertions' stamp: ''!
should: aBlock enumerate: aCollection
	| enumerated |

	enumerated := OrderedCollection new.
	aBlock value: [:each | enumerated add: each].
	self assert: enumerated equals: aCollection asOrderedCollection.! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testIncludesIdentity
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self deny: (dictionary includesIdentity: each value).

		dictionary add: each.
		self
			assert: (dictionary includesIdentity: each value);
			deny: (dictionary includesIdentity: each value copy)].! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
defaultCapacity

	^ self emptyInternalDictionary capacity! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAssociationAt
	| dictionary |
	dictionary := self emptyDictionary.
	self orderedAssociations
		do: [ :each | 
			self should: [ dictionary associationAt: each key ] raise: Error.

			dictionary add: each.
			self assert: (dictionary associationAt: each key) equals: each ]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
nonIdentityAbsentKey

	^ 'absentKey'! !

!OrderedDictionaryTest methodsFor: 'assertions' stamp: ''!
assertIsDictionary: anObject withOrderedAssociations: anAssociationCollection
	"Tests that anObject is an instance of the correct dictionary class
	with the specified ordered associations"

	self
		assert: anObject class identicalTo: self dictionaryClass;
		assert: anObject orderedKeys size >= anAssociationCollection size;
		assert: anObject associations size equals: anAssociationCollection size.

	anAssociationCollection
		withIndexDo: [ :each :i | 
			self isTestingIdentityDictionary
				ifTrue: [ self
						assert: (anObject orderedKeys at: i) identicalTo: each key;
						assert: (anObject associations at: i) key identicalTo: each key ]
				ifFalse: [ self
						assert: (anObject orderedKeys at: i) equals: each key;
						assert: (anObject associations at: i) key equals: each key ].
			self assert: (anObject associations at: i) value equals: each value ]! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testDictionaryPublicProtocolCompatibility
	| dictionary |

	dictionary := self emptyDictionary.
	{dictionary -> Dictionary.
	dictionary class -> Dictionary class}
		do: [:assoc | 
			assoc value protocols
				reject: [:protocol | 
					#('private' 'print' 'undeclared' 'copy' 'compar' '*')
						anySatisfy: [:each | protocol asString beginsWith: each]]
				thenDo: [:protocol | 
					(assoc value selectorsInProtocol: protocol)
						do: [:each | self assert: (assoc key respondsTo: each)]]].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeyAtIndexIfAbsent
	| dictionary |

	dictionary := self emptyDictionary.
	self assert:
		(dictionary
			keyAtIndex: 0
			ifAbsent: [self absentKey]) equals: self absentKey.
	self orderedAssociations withIndexDo: [:each :i |
		self assert:
			(dictionary
				keyAtIndex: i
				ifAbsent: [self absentKey]) equals: self absentKey.

		dictionary add: each.
		self assert:
			(dictionary
				keyAtIndex: i
				ifAbsent: [self fail]) equals: each key].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testCapacity
	"The current Dictionary implementation allocates more than specified.
	The amount allocated may change in the future but it likely won't ever
	be less than specified, so a >= test is used throughout."

	| defaultCapacity dictionary |

	defaultCapacity := self defaultCapacity.
	dictionary := self dictionaryClass new.
	self assert: dictionary capacity >= defaultCapacity.

	dictionary := self dictionaryClass new: (defaultCapacity / 2) asInteger.
	self assert: dictionary capacity >= (defaultCapacity / 2) asInteger.

	dictionary := self dictionaryClass newFrom: self orderedAssociations.
	self assert: dictionary capacity >= self orderedAssociations size.

	self orderedAssociations size to: 0 by: -1 do: [:i |
		self
			shouldnt: [
				dictionary := self dictionaryClass new: i.
				dictionary addAll: self orderedAssociations]
			raise: Error].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAtUpdateInitial
	| dict |
	dict := OrderedDictionary  newFrom: {2->10. 100->5} .
	dict at: 5 update: [ :v | v+1 ] initial: 17.
	dict at: 2 update: [ :v | v+10 ] initial: [0].
	self assert: (dict at: 5) equals: 17.
	self assert: (dict at: 2) equals: 20! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testIdentityIndexOfKey
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations withIndexDo: [:each :i |
		self assert: (dictionary identityIndexOfKey: each key) equals: 0.

		dictionary add: each.
		self
			assert: (dictionary identityIndexOfKey: each key) equals: i;
			assert: (dictionary identityIndexOfKey: each key copy) equals: 0].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testValues
	| dictionary |

	dictionary := self emptyDictionary.
	self
		assertIsArray: dictionary values
		withElements: #().
	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		self
			assertIsArray: dictionary values
			withElements: (self orderedValuesFirst: i)].! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
otherOrderedDictionaryClasses

	^ OrderedDictionary withAllSubclasses copyWithout: self dictionaryClass! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testEqualsDictionary
	self
		assertDictionary: self emptyDictionary
		doesNotEqual: self emptyInternalDictionary.

	self
		assertDictionary: self dictionaryWithOrderedAssociations
		doesNotEqual: self internalDictionaryWithAssociations.! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
newValue
	
	^ 'newValue'! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
orderedAssociationsAllButFirst: anInteger

	^ self orderedAssociations allButFirst: anInteger! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testIndexOfKeyIfAbsent
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations withIndexDo: [:each :i |
		self assert:
			(dictionary
				indexOfKey: each key
				ifAbsent: [self absentValue]) equals: self absentValue.

		dictionary add: each.
		self assert:
			(dictionary
				indexOfKey: each key
				ifAbsent: [self fail]) equals: i].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testAssociationsDo

	| dictionary |
	dictionary := self emptyDictionary.
	self
		should: [:block | dictionary associationsDo: block]
		enumerate: #().
	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		self
			should: [:block | dictionary associationsDo: block]
			enumerate: (self orderedAssociationsFirst: i)].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testCopyEmpty
	| dictionary copy |

	dictionary := self dictionaryWithOrderedAssociations.
	copy := dictionary copyEmpty.
	self
		assertIsDictionary: dictionary
		withOrderedAssociations: self orderedAssociations.
	self
		assertIsDictionary: copy
		copiedFrom: dictionary
		withOrderedAssociations: #().! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testIncludes
	| dictionary |

	dictionary := self emptyDictionary.
	self orderedAssociations do: [:each |
		self deny: (dictionary includes: each value).

		dictionary add: each.
		self assert: (dictionary includes: each value)].! !

!OrderedDictionaryTest methodsFor: 'testing' stamp: ''!
isTestingIdentityDictionary

	^ false! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testOccurrencesOf
	| dictionary |

	dictionary := self emptyDictionary.
	self assert: (dictionary occurrencesOf: self newValue) equals: 0.
	self orderedKeys withIndexDo: [:each :i |
		dictionary
			at: each
			put: self newValue.
		self assert: (dictionary occurrencesOf: self newValue) equals: i]! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeys
	| dictionary |

	dictionary := self emptyDictionary.
	self
		assertIsArray: dictionary keys
		withElements: #().
	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		self
			assertIsArray: dictionary keys
			withElements: (self orderedKeysFirst: i)].! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testRemoveKeyIfAbsent
	| dictionary |
	dictionary := self dictionaryWithOrderedAssociations.
	self orderedAssociations
		withIndexDo: [ :each :i | 
			self assert: (dictionary removeKey: each key ifAbsent: [ self fail ]) equals: each value.
			self assertKey: each key wasRemovedfrom: dictionary.
			self assertIsDictionary: dictionary withOrderedAssociations: (self orderedAssociationsAllButFirst: i).

			self assert: (dictionary removeKey: each key ifAbsent: [ self absentValue ]) equals: self absentValue ]! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
dictionaryWithOrderedAssociations

	^ self dictionaryClass newFrom: self orderedAssociations! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testKeysSortedSafely
	| dictionary |

	dictionary := self emptyDictionary.
	self
		assertIsArray: dictionary keysSortedSafely
		withElements: #().
	self orderedAssociations withIndexDo: [:each :i |
		dictionary add: each.
		"The keys are all strings, so the default #sorted implementation is OK."
		self
			assertIsArray: dictionary keysSortedSafely
			withElements: (self orderedKeysFirst: i) sorted].! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
absentValue
	^ 'absentValue'! !

!OrderedDictionaryTest methodsFor: 'accessing' stamp: ''!
changedOrderedAssociations

	^ self orderedAssociations collect: [:each | each key -> self newValue]! !

!OrderedDictionaryTest methodsFor: 'tests' stamp: ''!
testNewFromPairs
	| pairs |

	pairs := OrderedCollection new.
	self orderedAssociations do: [:each |
		pairs
			addLast: each key;
			addLast: each value].

	0 to: pairs size do: [:i |
		self
			assertIsDictionary:
				(self dictionaryClass newFromPairs: (pairs copyFrom: 1 to: i))
			withOrderedAssociations:
				(self orderedAssociationsFirst: (i / 2) floor)].! !

!OrderedDictionaryTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors

	^ true! !

!OrderedIdentityDictionary commentStamp: ''!
An `IdentityDictionary` version that uses `==` instead of `=` for key comparing.
For more information about my usage, check `OrderedDictionary` and `Dictionary` comments.

###Examples

```
	object := Object new.
	otherObject := Object new.
	dict := OrderedIdentityDictionary new.
	dict
		at: object put: 1;
		at: otherObject put: 2.
	dict.		"returns: an OrderedIdentityDictionary(an Object->1 an Object->2)"
	dict at: object put: 3.
	dict 		"returns: an OrderedIdentityDictionary(an Object->3 an Object->2)"
```!
!OrderedIdentityDictionary methodsFor: 'accessing' stamp: 'nil'!
dictionaryClass
	^ IdentityDictionary! !

!OrderedIdentityDictionary methodsFor: 'accessing' stamp: 'nil'!
indexOfKey: aKey ifAbsent: aBlock
	^ self identityIndexOfKey: aKey ifAbsent: aBlock! !

!OrderedIdentityDictionary methodsFor: 'private' stamp: 'nil'!
orderedKeysIndexOf: aKey
	^ orderedKeys identityIndexOf: aKey! !

!OrderedIdentityDictionaryTest commentStamp: ''!
SUnit tests for OrderedIdentityDictionary!
!OrderedIdentityDictionaryTest methodsFor: 'testing' stamp: ''!
isTestingIdentityDictionary
	^ true! !

!OrderedIdentityDictionaryTest methodsFor: 'accessing' stamp: ''!
dictionaryClass
	^ OrderedIdentityDictionary! !

!OrientedFillStyle commentStamp: ''!
OrientedFill is an abstract superclass for fills which can be aligned appropriately.

Instance variables:
	origin	<Point>	The point at which to align the fill.
	direction <Point>	The direction in which the fill is defined
	normal	<Point>	Typically, just the direction rotated by 90 degrees.!
!OrientedFillStyle methodsFor: 'testing' stamp: ''!
isOrientedFill
	"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
	^true! !

!OrientedFillStyle methodsFor: 'accessing' stamp: ''!
direction: aPoint
	direction := aPoint! !

!OrientedFillStyle methodsFor: 'comparing' stamp: ''!
= 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: ''!
hash
	"Hash is implemented because #= is implemented."
	
	^self species hash
		bitXor: (self origin hash
		bitXor: (self direction hash
		bitXor: (self normal hash)))! !

!OrientedFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
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: ''!
origin
	^origin! !

!OrientedFillStyle methodsFor: 'accessing' stamp: ''!
direction
	^direction ifNil:[direction := normal y @ normal x negated]! !

!OrientedFillStyle methodsFor: 'accessing' stamp: ''!
origin: aPoint
	origin := aPoint.! !

!OrientedFillStyle methodsFor: 'accessing' stamp: ''!
normal
	^normal ifNil:[normal := direction y negated @ direction x]! !

!OrientedFillStyle methodsFor: 'accessing' stamp: ''!
normal: aPoint
	normal := aPoint! !

!OrientedFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	aMenu add: 'change origin' target: self selector: #changeOriginIn:event: argument: aMorph.
	aMenu add: 'change orientation' target: self selector: #changeOrientationIn:event: argument: aMorph.! !

!OrientedFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: ''!
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.! !

!OupsDebugRequest commentStamp: ''!
The information required to open a debugger can take multiple forms.
This object is a builder, to be filled with the relevant information by any object that wants to open a debugger.
Once this object is filled, call its #debug or #warning method to open a debugger/send a warning.

# Information That Can Be Provided (and their type)
- exception: Exception
- context: Context
- label: String
- process: Process
- compiledMethod: CompiledMethod

# Notes
- You NEED to provide an exception OR a context. The other information are optional.
- If an exception and a label are provided, the label will be ignored (in favour of the #description of the exception)
- Providing a compiledMethod will make it so the execution will be stepped until it is in that method , prior to the debugger opening

# Instance Variables
- exception: Exception.
- context: Context.
- label: String. If not provided, the result of "self defaultLabel_" will be used.
- process: Process. If not provided, the result of "self defaultProcess" will be used.
- compiledMethod: CompiledMethod
- preDebugActions: OrderedCollection<BlockClosure<DebugSession, nil>>. A list of blocks, taking as arguments a DebugSession on the execution to be debugged. These will be executed before the debugger opens.

# Technical Details
- the setters are meant to be used by the caller, to fill this object with information
- the getters are meant to be used by whatever objects is opening a debugger based on the information contained in this object!
!OupsDebugRequest methodsFor: 'accessing' stamp: ''!
compiledMethod: anObject
	compiledMethod := anObject! !

!OupsDebugRequest methodsFor: 'default values' stamp: ''!
defaultUIManager
	^ UIManager default! !

!OupsDebugRequest methodsFor: 'building' stamp: ''!
computePreDebugActions

	"If compiledMethod is not nil, this DebugRequest has been created to debug the execution of a specific method. Add a pre-debug action to step the execution until that method is reached"

	compiledMethod ifNil: [ ^ self ].
	self preDebugActions add:
		(self preDebugActionForDebugItMethod: compiledMethod)! !

!OupsDebugRequest methodsFor: 'accessing' stamp: ''!
label: anObject
	label := anObject! !

!OupsDebugRequest methodsFor: 'accessing' stamp: ''!
preDebugActions
	preDebugActions ifNil: [ preDebugActions := OrderedCollection new ].
	^ preDebugActions! !

!OupsDebugRequest methodsFor: 'default values' stamp: ''!
defaultException

	^ self nullExceptionFor: context named: self label! !

!OupsDebugRequest methodsFor: 'requests' stamp: ''!
submit
	<debuggerCompleteToSender>
	"Submit this debug request to the system. The system will typically open a debugger for it"
	OupsDebuggerSystem new handleDebugRequest: self! !

!OupsDebugRequest methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!OupsDebugRequest methodsFor: 'accessing' stamp: ''!
debugSession

	^ debugSession ifNil: [ debugSession := self newDebugSession ]! !

!OupsDebugRequest methodsFor: 'helpers' stamp: ''!
nullExceptionFor: aContext named: aString
	^ (OupsNullException fromSignallerContext: aContext)
		messageText: aString;
		yourself! !

!OupsDebugRequest methodsFor: 'accessing' stamp: ''!
exception

	^ exception ifNil: [ exception := self defaultException ]! !

!OupsDebugRequest methodsFor: 'accessing' stamp: ''!
process: anObject
	process := anObject! !

!OupsDebugRequest methodsFor: 'building' stamp: ''!
preDebugActionForDebugItMethod: aCompiledMethod

	"Return a PreDebug action that will step the debugged execution until it is in a call to aCompiledMethod"

	^ [ :session | 
	  session stepIntoUntil: [ :currentContext | 
		  currentContext method == aCompiledMethod ] ]! !

!OupsDebugRequest methodsFor: 'accessing' stamp: ''!
exception: anObject
	exception := anObject! !

!OupsDebugRequest methodsFor: 'building' stamp: ''!
newDebugSession

	^ (self process
		   newDebugSessionNamed: self exception description
		   startedAt: self exception signalerContext)
		  exception: self exception;
		  yourself! !

!OupsDebugRequest methodsFor: 'default values' stamp: ''!
defaultProcess
	^ Processor activeProcess! !

!OupsDebugRequest methodsFor: 'accessing' stamp: ''!
label

	^ label ifNil: [ label := self defaultLabel ]! !

!OupsDebugRequest methodsFor: 'accessing' stamp: ''!
process
	"If a process was provided, return it, otherwise use the result of 'self defaultProcess'"
	^ process ifNil: [ self defaultProcess ]! !

!OupsDebugRequest methodsFor: 'default values' stamp: ''!
defaultLabel
	^ 'No label was provided'! !

!OupsDebugRequest class methodsFor: 'instance creation' stamp: ''!
new
	self shouldNotImplement! !

!OupsDebugRequest class methodsFor: 'instance creation' stamp: ''!
newForException: anException
	"By default we assume that the debugger is requested from the process itself as the result of anException. In that case we must use #realActiveProcess instead of #activeProcess.
	When debugger opens it must stop the current process. Otherwise the error signal will return to the sender and it will continue execution. Obviously it may cause an unexpected behavior and in worst case it may break the system completely (with some infinite recursion triggering debuggers at every step).
	Therefore in this scenario we use #realActiveProcess to reliably get a really running process. 
	For more details see #realActiveProcess and #terminateRealActive comments"
	<debuggerCompleteToSender>
	^ self basicNew 
			exception: anException;
			process: Processor realActiveProcess;
			yourself! !

!OupsDebugRequest class methodsFor: 'instance creation' stamp: ''!
newForContext: aContext
	<debuggerCompleteToSender>
	^ self basicNew context: aContext; yourself! !

!OupsDebugRequestTest commentStamp: ''!
A DebugRequestTest is a test class for testing the behavior of DebugRequest!
!OupsDebugRequestTest methodsFor: 'tests' stamp: ''!
testDebugSession
	| error dr ds |
	[ self error ] on: Error do: [ :e | error := e].
	dr := OupsDebugRequest newForException: error.
	ds := dr debugSession.
	self assert: ds interruptedContext identicalTo: error signalerContext.
	self assert: ds interruptedProcess identicalTo: dr process.
	self assert: ds exception identicalTo: error.! !

!OupsDebugRequestTest methodsFor: 'tests' stamp: ''!
testNoPreDebugActionsBeforeComputation
	| dr |
	dr := OupsDebugRequest basicNew.
	self assert: dr preDebugActions isEmpty! !

!OupsDebugRequestTest methodsFor: 'tests' stamp: ''!
testDefaultProcess
	| dr |
	dr := OupsDebugRequest basicNew.
	self assert: dr process identicalTo: Processor activeProcess! !

!OupsDebugRequestTest methodsFor: 'tests' stamp: ''!
testNewNotAllowed
	self should: [ OupsDebugRequest new ] raise: ShouldNotImplement! !

!OupsDebugRequestTest methodsFor: 'tests' stamp: ''!
testNullExceptionForNamed
	| context name nullException |
	context := thisContext.
	name := 'testName'.
	nullException := OupsDebugRequest basicNew nullExceptionFor: context named: name.
	self assert: nullException signalerContext identicalTo: context.
	self assert: nullException messageText equals: name.! !

!OupsDebugRequestTest methodsFor: 'tests' stamp: ''!
testCreationFromException
	| error dr |
	[ self error ] on: Error do: [ :e | error := e].
	dr := OupsDebugRequest newForException: error.
	self assert: dr exception identicalTo: error.
	self assert: dr process identicalTo: dr defaultProcess! !

!OupsDebugRequestTest methodsFor: 'tests' stamp: ''!
testPreDebugActionForDebugItMethod
	| dr |
	dr := OupsDebugRequest basicNew.
	dr compiledMethod: OupsDebugRequestTest>>#testPreDebugActionForDebugItMethod.
	dr computePreDebugActions.
	self assert: dr preDebugActions isNotEmpty! !

!OupsDebuggerFailure commentStamp: ''!
Debugger failures are exceptions created when the Oups infrastructure is configured to debug error-handling errors.

When a debugger encounters an error while opening, a `DebuggerFailure` exception is instantiated and signaled.
A debugger failure references:

- the debugger that failed to open the original error: it is used by debugger selection strategies to avoid opening recursively the same faulty debugger,
-  the original error with its interrupted context: if the debugger error is fixed, the debugger failure is resumed and the fixed debugger opens the original error.
!
!OupsDebuggerFailure methodsFor: 'testing' stamp: ''!
isDebuggerFailure
	^true! !

!OupsDebuggerFailure methodsFor: 'accessing' stamp: ''!
innerException
	^ innerException! !

!OupsDebuggerFailure methodsFor: 'testing' stamp: ''!
isHandleableBy: aDebugger
	^ aDebugger ~= failedDebugger! !

!OupsDebuggerFailure methodsFor: 'initialization' stamp: ''!
debugger: aDebugger exception: anException
	failedDebugger := aDebugger.
	innerException := anException! !

!OupsDebuggerFailure methodsFor: 'accessing' stamp: ''!
failedDebugger
	^ failedDebugger! !

!OupsDebuggerFailure methodsFor: 'accessing' stamp: ''!
originException
	^ innerException originException! !

!OupsDebuggerFailure class methodsFor: 'instance creation' stamp: ''!
of: aDebugger on: anException

	<debuggerCompleteToSender>
	^ self new
		  debugger: aDebugger exception: anException;
		  yourself! !

!OupsDebuggerSelectionStrategy commentStamp: ''!
I am the abstract super class of **Oups**' debugger selection strategies. My subclasses are responsible for selecting a debugger from a given list of debuggers, and for opening a given error with it.

**Oups** has a setting to define which strategy it should use to find a debugger for the error whose debugging was requested.
The debugger infrastructure implements a default strategy `OupsDebuggerSelector` which is interchangeable with user-defined strategies.!
!OupsDebuggerSelectionStrategy methodsFor: 'iterating' stamp: ''!
nextDebugger
	^ self subclassResponsibility! !

!OupsDebuggerSelectionStrategy methodsFor: 'accessing' stamp: ''!
hasErrors 
	^error notNil! !

!OupsDebuggerSelectionStrategy methodsFor: 'accessing' stamp: ''!
debuggers: aCollection 
	debuggers := aCollection! !

!OupsDebuggerSelectionStrategy methodsFor: 'error handling' stamp: ''!
error
	^error! !

!OupsDebuggerSelectionStrategy methodsFor: 'error handling' stamp: ''!
signalErrorHandlingErrorForSession: aDebugSession

	DebuggerEmmergencyLogger new
		logError: error
		forSession: aDebugSession crTrace! !

!OupsDebuggerSelectionStrategy methodsFor: 'debuggers' stamp: ''!
openDebuggerForSession: aDebugSession
	self subclassResponsibility! !

!OupsDebuggerSelectionStrategy methodsFor: 'accessing' stamp: ''!
debuggers
	^ debuggers! !

!OupsDebuggerSelectionStrategy methodsFor: 'accessing' stamp: ''!
handled
	^handled ifNil:[handled := false]! !

!OupsDebuggerSelectionStrategy class methodsFor: 'settings' stamp: ''!
debuggerSelectionStrategy: aClass
	debuggerSelectionStrategy := aClass! !

!OupsDebuggerSelectionStrategy class methodsFor: 'settings' stamp: ''!
debuggerSelectionStrategy

	^ debuggerSelectionStrategy ifNil: [ 
		  debuggerSelectionStrategy := self defaultDebuggerSelectionStrategy ]! !

!OupsDebuggerSelectionStrategy class methodsFor: 'settings' stamp: ''!
debuggerSelectionStrategySettingsOn: aBuilder
	<systemsettings>
	(aBuilder pickOne: #debuggerSelectionStrategy)
		label: 'Debugger selection strategy';
		target: self;
		default: self defaultDebuggerSelectionStrategy;
		parent: #debugging;
		domainValues: (self allSubclasses);
		description: 'Sets the strategy to open a debugger.'! !

!OupsDebuggerSelectionStrategy class methodsFor: 'instance' stamp: ''!
with: aCollection
	^ self new
		debuggers: aCollection;
		yourself! !

!OupsDebuggerSelectionStrategy class methodsFor: 'settings' stamp: ''!
defaultDebuggerSelectionStrategy
	^OupsDebuggerSelector! !

!OupsDebuggerSelectionStrategyTest methodsFor: 'tests - debugging' stamp: ''!
testHandled
	self deny: OupsDebuggerSelectionStrategy new handled! !

!OupsDebuggerSelector commentStamp: ''!
I take as input a sorted list of debuggers and a debug session.
I will try to open the debug session with the first applicable debugger in this list.

If this first applicable debugger encounters an error, I will either try the next applicable debugger or if I am configured to handle debugger errors (see handlesDebuggerErrors:) I will raise a DebuggerFailure exception.

When I try to open a debug session created from a DebuggerFailure, I exclude the debugger that produced the debugger failure from my debugger list.

When I succeeded to open a debugger, my instance variable "handled" becomes true. 
If I failed to find any debugger, or to open the debug session with any debugger, "handled" stays false. This is the responsibility of my clients to deal with this situation (i.e., the system was unable to open a debugger).!
!OupsDebuggerSelector methodsFor: 'iterating' stamp: ''!
nextDebugger
	^ debuggers pop! !

!OupsDebuggerSelector methodsFor: 'debuggers' stamp: ''!
tryOpen: aDebugSession with: aDebugger

	<debuggerCompleteToSender>
	[ 
	aDebugger debugSession: aDebugSession.
	handled := true ]
		on: Error , UnhandledException
		do: [ :err | 
			error := err.
			(self handlesDebuggerErrors and: [ 
				 aDebugSession exception isDebuggerFailure not ]) ifTrue: [ 
				(OupsDebuggerFailure of: aDebugger on: err) signal ] ]! !

!OupsDebuggerSelector methodsFor: 'accessing' stamp: ''!
debuggers: aCollection
	debuggers := Stack newFrom: aCollection! !

!OupsDebuggerSelector methodsFor: 'debuggers' stamp: ''!
openDebuggerForSession: aDebugSession

	<debuggerCompleteToSender>
	handled := false.
	[ handled or: [ self debuggers isEmpty ] ] whileFalse: [ 
		self
			tryOpen: aDebugSession
			with: (self nextDebuggerForSession: aDebugSession) ].			
	handled ifFalse: [ self signalErrorHandlingErrorForSession: aDebugSession ]! !

!OupsDebuggerSelector methodsFor: 'debuggers' stamp: ''!
nextDebuggerForSession: aDebugSession
	| debugger |
	debugger := self nextDebugger.
	[ (debugger handlesContext: aDebugSession context)
		and: [ aDebugSession exception isHandleableBy: debugger ] ]
		whileFalse: [ debugger := self nextDebugger ].
	^ debugger! !

!OupsDebuggerSelector methodsFor: 'accessing' stamp: ''!
handlesDebuggerErrors: aBoolean 
	handlesDebuggerErrors := aBoolean! !

!OupsDebuggerSelector methodsFor: 'accessing' stamp: ''!
handlesDebuggerErrors
	^ handlesDebuggerErrors
		ifNil: [ handlesDebuggerErrors := self class handleDebuggerErrors ]! !

!OupsDebuggerSelector class methodsFor: 'settings' stamp: ''!
handleDebuggerErrors
	^ handleDebuggerErrors ifNil: [ handleDebuggerErrors := false ]! !

!OupsDebuggerSelector class methodsFor: 'settings' stamp: ''!
handleDebuggerErrorsSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #handleDebuggerErrors)
		label: 'Handle debugger errors';
		target: self;
		default: false;
		parent: #debugging;
		description: 'Try to debug debugger errors when they occur.'! !

!OupsDebuggerSelector class methodsFor: 'settings' stamp: ''!
handleDebuggerErrors: aBoolean
	handleDebuggerErrors := aBoolean! !

!OupsDebuggerSelectorTest methodsFor: 'tests -  algorithm' stamp: ''!
testOpenDebuggerForSession
	| session |
	session := self session.
	debuggerSelector openDebuggerForSession: session.
	self assert: debuggers first tag identicalTo: session.
	self assert: debuggerSelector handled! !

!OupsDebuggerSelectorTest methodsFor: 'tests -  algorithm' stamp: ''!
testFirstUsableDebuggerForSession
	
	debuggerSelector debuggers first beUnusable.
	debuggerSelector debuggers second beUnusable.

	self
		assert: (debuggerSelector nextDebuggerForSession: self session)
		identicalTo: debuggers third! !

!OupsDebuggerSelectorTest methodsFor: 'running' stamp: ''!
tearDown
	debuggers
		do: [ :dbg | 
			(dbg tag isKindOf: DebugSession)
				ifTrue: [ dbg tag terminate ] ].
	super tearDown! !

!OupsDebuggerSelectorTest methodsFor: 'helper' stamp: ''!
session
	^OupsDummyDebugger dummySession! !

!OupsDebuggerSelectorTest methodsFor: 'tests - debuggers' stamp: ''!
testDebuggers
	self
		assertCollection: debuggerSelector debuggers asOrderedCollection
		equals: debuggers! !

!OupsDebuggerSelectorTest methodsFor: 'tests - debuggers' stamp: ''!
testNextDebugger
	debuggers
		do: [ :dbg | self assert: debuggerSelector nextDebugger identicalTo: dbg ]! !

!OupsDebuggerSelectorTest methodsFor: 'tests -  algorithm' stamp: ''!
testTryOpenWithSignalsError
	| session |
	session := self session.
	debuggers first beError.
	debuggers second beError.
	
	self
		shouldnt: [ debuggerSelector tryOpen: session with: debuggers first ]
		raise: OupsDebuggerFailure.
	self deny: debuggerSelector handled.	

	debuggerSelector handlesDebuggerErrors: true.
	self
		should: [ debuggerSelector tryOpen: session with: debuggers second ]
		raise: OupsDebuggerFailure.
	self deny: debuggerSelector handled! !

!OupsDebuggerSelectorTest methodsFor: 'tests -  algorithm' stamp: ''!
testOpenDebuggerWithErrorForSession
	| session |
	session := self session.
	debuggers first beError.
	debuggers second beError.			
	debuggerSelector handlesDebuggerErrors: false.
	debuggerSelector openDebuggerForSession: session.
	self assert: debuggers first tag class identicalTo: Error.
	self assert: debuggers second tag class identicalTo: Error.	
	self assert: debuggers third tag identicalTo: session.
	self assert: debuggerSelector handled.
	self assert: debuggerSelector hasErrors.
	self assert: debuggerSelector error class identicalTo: Error! !

!OupsDebuggerSelectorTest methodsFor: 'tests - debugging' stamp: ''!
testHandlesDebuggerErrors
	self deny: debuggerSelector handlesDebuggerErrors.
	debuggerSelector handlesDebuggerErrors: true.
	self assert: debuggerSelector handlesDebuggerErrors.
	self
		assert: OupsDebuggerSelector new handlesDebuggerErrors
		equals: OupsDebuggerSelector handleDebuggerErrors! !

!OupsDebuggerSelectorTest methodsFor: 'tests -  algorithm' stamp: ''!
testNextDebuggerForDebuggerFailure
	"Upon a debugger failure, we call the nextDebuggerForSession: interface to get the next debugger"
	|session|
	session := self session.
	session exception: (OupsDebuggerFailure of: debuggers first on: session exception).
	self
		assert: (debuggerSelector nextDebuggerForSession: session)
		identicalTo: debuggers second! !

!OupsDebuggerSelectorTest methodsFor: 'tests -  algorithm' stamp: ''!
testOpenDebuggerError
	| session |
	session := self session.
	session exception: (OupsDebuggerFailure of: debuggers first on: session exception).
	debuggers first beError.
	debuggers second beError.
	
	"Because we are debugging a debugger error, we cannot raise another DebuggerFailure:
	we want to find a debugger to debug the failing debugger."
	debuggerSelector handlesDebuggerErrors: true.	
	self shouldnt: [debuggerSelector openDebuggerForSession: session] raise: OupsDebuggerFailure.	
		
	"Because the first debugger originated the debugger failure,
	it is not considered in the algorithm anymore."
	self assert: debuggers first tag equals: nil.
	self assert: debuggers second tag class identicalTo: Error.
	self assert: debuggers third tag identicalTo: session.
	self assert: debuggerSelector handled! !

!OupsDebuggerSelectorTest methodsFor: 'tests -  algorithm' stamp: ''!
testTryOpenWith
	| session |
	session := self session.
	self
		shouldnt: [ debuggerSelector tryOpen: session with: debuggers first ]
		raise: OupsDebuggerFailure.
	self assert: debuggers first tag identicalTo: session.
	self assert: debuggerSelector handled! !

!OupsDebuggerSelectorTest methodsFor: 'tests -  algorithm' stamp: ''!
testNextDebuggerForSession
	"Upon a debugger failure, we call the nextDebuggerForSession: interface to get the next debugger"
	
	self
		assert: (debuggerSelector nextDebuggerForSession: self session)
		identicalTo: debuggers first.
	
	self
		assert: (debuggerSelector nextDebuggerForSession: self session)
		identicalTo: debuggers second.
		
	self
		assert: (debuggerSelector nextDebuggerForSession: self session)
		identicalTo: debuggers last.
		
	self
		should: [ debuggerSelector nextDebuggerForSession: self session]
		raise: CollectionIsEmpty! !

!OupsDebuggerSelectorTest methodsFor: 'tests -  algorithm' stamp: ''!
testNoDebuggerForSession
	debuggerSelector debuggers: #().
	self
		shouldnt: [ debuggerSelector openDebuggerForSession: self session ]
		raise: CollectionIsEmpty.
	self deny: debuggerSelector handled! !

!OupsDebuggerSelectorTest methodsFor: 'tests - debuggers' stamp: ''!
testNoNextDebugger
	debuggerSelector debuggers: #().
	self
		should: [ debuggerSelector nextDebugger ]
		raise: CollectionIsEmpty! !

!OupsDebuggerSelectorTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."

	super setUp.
	debuggers := OupsDummyDebugger dummyDebuggerList.
	debuggerSelector := OupsDebuggerSelector with: debuggers copy.
	debuggerSelector handlesDebuggerErrors: false! !

!OupsDebuggerSystem commentStamp: ''!
I am the entry point into the **Oups** debugging tool layer.
My instances handle debug requests according to the system state and configuration:

- First, before opening a debugger, I query the current `UIManager`. If interactive debugging is not enabled, the debug request concludes there and the error is logged (_e.g._, if the system is running headless).

- Second, I collect the list of users of `TDebugger` (_i.e._, each debugger class) and I sort them based on their per-debugger user-defined priority. Then, a debugger selection strategy selects a debugger from that list to open the error.

- Finally, I ensure that the debug request is handled reliably.
If an exception is raised within the debugger system itself, or if the debugger selection strategy fails to select a debugger, then the original error is handled by the emergency evaluator.!
!OupsDebuggerSystem methodsFor: 'open debugger' stamp: ''!
openDebuggerOnRequest: aDebugRequest

	"Prepare the opening of a debugger, and delegate the debugger selection and opening to a strategy"

	<debuggerCompleteToSender>
	| debuggerOpeningStrategy |
	aDebugRequest debugSession logStackToFileIfNeeded.
	self performPreDebugActionsIn: aDebugRequest.
	self spawnNewUIProcessIfNecessary: aDebugRequest.
	self ensureExceptionIn: aDebugRequest debugSession.

	"Schedule the debugger opening in a deferred UI message to address redraw problems after opening a debugger e.g. from the testrunner."
	debuggerOpeningStrategy := self debuggerSelectionStrategy.
	self defaultUIManager defer: [ 
		debuggerOpeningStrategy openDebuggerForSession:
			aDebugRequest debugSession ].
	self suspendDebuggedProcess: aDebugRequest! !

!OupsDebuggerSystem methodsFor: 'error management' stamp: ''!
signalDebuggerErrorMessage
	^ 'DebuggerSystem failure'! !

!OupsDebuggerSystem methodsFor: 'default values' stamp: ''!
defaultUIManager
	^ UIManager default! !

!OupsDebuggerSystem methodsFor: 'open debugger' stamp: ''!
logDebugRequest: aDebugRequest withUIManager: aCommandLineUIManager

	aCommandLineUIManager
		debugProcess: aDebugRequest process
		context: aDebugRequest exception signalerContext
		label: aDebugRequest exception description
		fullView: false
		notification: aDebugRequest exception description! !

!OupsDebuggerSystem methodsFor: 'handle debug requests' stamp: ''!
handleWarningDebugRequest: aWarningDebugRequest

	"A WarningDebugRequest has been submitted. Ask what to do to the default UIManager. Typically, the UIManager will call back my #openDebuggerOnRequest: method to open a debugger"

	[ 
	self defaultUIManager handleWarningDebugRequest: aWarningDebugRequest fromDebuggerSystem: self]
		on: Error
		do: [ self signalDebuggerError: aWarningDebugRequest ]! !

!OupsDebuggerSystem methodsFor: 'helpers' stamp: ''!
spawnNewUIProcess

	"See comment of spawnNewUIProcessIfNecessary:"

	DefaultExecutionEnvironment beActiveDuring: [ 
		self defaultUIManager spawnNewProcess ]! !

!OupsDebuggerSystem methodsFor: 'helpers' stamp: ''!
suspendDebuggedProcess: aDebugRequest
	aDebugRequest process suspend! !

!OupsDebuggerSystem methodsFor: 'handle debug requests' stamp: ''!
handleDebugRequest: aDebugRequest

	"A DebugRequest has been submitted. Ask what to do to the default UIManager. Typically, the UIManager will call back my #openDebuggerOnRequest: method to open a debugger"

	[ self defaultUIManager handleDebugRequest: aDebugRequest fromDebuggerSystem: self]
		on: Error
		do: [ self signalDebuggerError: aDebugRequest ]! !

!OupsDebuggerSystem methodsFor: 'helpers' stamp: ''!
debuggerSelectionStrategy

	"Returns the debugger selection strategy to be used by this DebuggerSystem. This is the value of the corresponding setting"

	^ OupsDebuggerSelectionStrategy debuggerSelectionStrategy with:
		  self availableDebuggers! !

!OupsDebuggerSystem methodsFor: 'open debugger' stamp: ''!
warningRequest: aDebugRequest withUIManager: aCommandLineUIManager

	aCommandLineUIManager warningDefaultAction: aDebugRequest exception! !

!OupsDebuggerSystem methodsFor: 'exceptions' stamp: ''!
ensureExceptionIn: aDebugSession

	aDebugSession exception ifNotNil: [ ^ self ].
	aDebugSession exception: (OupsNullException fromSignallerContext:
			 aDebugSession interruptedContext)! !

!OupsDebuggerSystem methodsFor: 'error management' stamp: ''!
signalDebuggerError: aDebugRequest
	| failingSession |
	failingSession := aDebugRequest debugSession
		name: self signalDebuggerErrorMessage;
		yourself.
	self inform: 'failingSession signalDebuggerError: aDebugRequest exception'! !

!OupsDebuggerSystem methodsFor: 'instance creation' stamp: ''!
availableDebuggers
	^DebuggerSettings availableDebuggers sort:[:a :b| a rank > b rank]! !

!OupsDebuggerSystem methodsFor: 'helpers' stamp: ''!
spawnNewUIProcessIfNecessary: aDebugRequest

	"If aDebugRequest is about debugging the UI process, we must create a new UI process to take its place. Because the debugged process will be suspended at some point, and suspending the UI process means freezing the UI of the image"

	aDebugRequest debugSession isAboutUIProcess ifTrue: [ 
		self spawnNewUIProcess ]! !

!OupsDebuggerSystem methodsFor: 'helpers' stamp: ''!
performPreDebugActionsIn: aDebugRequest

	"Get the preDebug actions stored in aDebugRequest. Applies them to the debugSession held by aDebugRequest"

	aDebugRequest computePreDebugActions.
	aDebugRequest preDebugActions do: [ :preDebugAction | 
		preDebugAction value: aDebugRequest debugSession ]! !

!OupsDebuggerSystem class methodsFor: 'utilities api' stamp: ''!
closeAllDebuggers
	TDebugger users do:[:debuggerClass| debuggerClass closeAllDebuggers]! !

!OupsDebuggerSystemTest methodsFor: 'tests' stamp: ''!
testPreDebugActionExecuted
	"Test that a DebuggerSystem opening a DebugRequest with a pre-debug action will execute it exactly once"
	| debugRequest |
	debugRequest := self createDummyDebugRequest.
	self assert: debugRequest dummyPreDebugActionExecutedCount equals: 0.
	debuggerSystem openDebuggerOnRequest: debugRequest.
	self assert: debugRequest dummyPreDebugActionExecutedCount equals: 1! !

!OupsDebuggerSystemTest methodsFor: 'tests' stamp: ''!
createDummyDebugRequest
	| exception |
	[ Exception signal ] on: Exception do: [ :e | exception := e ].
	^ OupsDummyDebugRequest newForException: exception! !

!OupsDebuggerSystemTest methodsFor: 'tests' stamp: ''!
testEnsureExceptionIn
	|session|
	session := DebugSession new process: nil context: OupsDummyDebugger new.
	OupsDebuggerSystem basicNew ensureExceptionIn: session.
	self assert: session exception notNil.
	self assert: session exception class equals: OupsNullException.
	
	session := DebugSession new exception: #tag.
	OupsDebuggerSystem basicNew ensureExceptionIn: session.
	self assert: session exception equals: #tag! !

!OupsDebuggerSystemTest methodsFor: 'tests' stamp: ''!
testHandleWarningDebugRequest
	"Tests that a DebuggerSystem tasked to handle a WarningDebugRequest calls the #handleWarningDebugRequest: of its uiManager with that DebugRequest"
	| debugRequest |
	debugRequest := self createDummyDebugRequest.
	self assert: debuggerSystem callsToHandleDebugRequest equals: 0.
	debuggerSystem handleWarningDebugRequest: debugRequest.
	self assert: debuggerSystem callsToHandleDebugRequest equals: 1.
	self assert: debuggerSystem debugRequestSentToHandleDebugRequest identicalTo: debugRequest! !

!OupsDebuggerSystemTest methodsFor: 'tests' stamp: ''!
createDummyDebugRequestForNotUIProcess
	| exception nonUIProcess |
	nonUIProcess := [  1+1 ] newProcess.
	[ Exception signal ] on: Exception do: [ :e | exception := e ].
	^ (OupsDummyDebugRequest newForException: exception) process: nonUIProcess; yourself.! !

!OupsDebuggerSystemTest methodsFor: 'tests' stamp: ''!
createDummyDebugRequestForUIProcess

	| exception |
	[ Exception signal ]
		on: Exception
		do: [ :e | exception := e ].
	^ (OupsDummyDebugRequest newForException: exception)
		  process: UIManager default uiProcess;
		  yourself! !

!OupsDebuggerSystemTest methodsFor: 'tests' stamp: ''!
testHandleDebugRequest
	"Tests that a DebuggerSystem tasked to handle a DebugRequest calls the #handleDebugRequest: of its uiManager with that DebugRequest"
	| debugRequest |
	debugRequest := self createDummyDebugRequest.
	self assert: debuggerSystem callsToHandleDebugRequest equals: 0.
	debuggerSystem handleDebugRequest: debugRequest.
	self assert: debuggerSystem callsToHandleDebugRequest equals: 1.
	self assert: debuggerSystem debugRequestSentToHandleDebugRequest identicalTo: debugRequest! !

!OupsDebuggerSystemTest methodsFor: 'tests' stamp: ''!
testAvailableDebuggers
	"Tests that DebuggerSystem>>#availableDebuggers returns a list"
	self assert: debuggerSystem availableDebuggers isSequenceable! !

!OupsDebuggerSystemTest methodsFor: 'tests' stamp: ''!
testNonUIProcessIsRecognised
	"Tests that a DebuggerSystem opening a DebugRequest that is NOT on the ui process does NOT spawn a new UI process"
	debuggerSystem openDebuggerOnRequest: self createDummyDebugRequestForNotUIProcess.
	self assert: debuggerSystem newUIProcessSpawned not! !

!OupsDebuggerSystemTest methodsFor: 'tests' stamp: ''!
testUIProcessIsRecognised

	"Test that a DebuggerSystem opening a DebugRequest on the ui process will spawn a new UI process"
	|request|
	request := self createDummyDebugRequestForUIProcess.
	request debugSession errorWasInUIProcess: true.
	debuggerSystem spawnNewUIProcessIfNecessary: request.
		
	self assert: debuggerSystem newUIProcessSpawned! !

!OupsDebuggerSystemTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	"Put here a common initialization logic for tests"
	debuggerSystem := OupsDummyDebuggerSystem new.! !

!OupsDummyDebugRequest commentStamp: ''!
I am a dummy DebugRequest, used for testing!
!OupsDummyDebugRequest methodsFor: 'preDebugActions' stamp: ''!
computePreDebugActions

	"For test purposes. Instead of computing preDebugActions as usual, insert a dummy pre debug action"

	self preDebugActions add: [ :dbSession | 
		dummyPreDebugActionExecutedCount := self dummyPreDebugActionExecutedCount	+ 1 ]! !

!OupsDummyDebugRequest methodsFor: 'preDebugActions' stamp: ''!
dummyPreDebugActionExecutedCount
	^dummyPreDebugActionExecutedCount ifNil: [ dummyPreDebugActionExecutedCount := 0 ]! !

!OupsDummyDebugger commentStamp: ''!
I am a dummy debugger.
My instances simulate debugger classes that are named, and can handle any context.!
!OupsDummyDebugger methodsFor: 'instance creation' stamp: ''!
debugSession: aDebugSession
	self isError
		ifFalse: [ tag := aDebugSession.
			^ self ].
	tag := Error new.
	tag signalIn: thisContext.
	tag signal! !

!OupsDummyDebugger methodsFor: 'helpers' stamp: ''!
findContextSuchThat: aBlock
	^self! !

!OupsDummyDebugger methodsFor: 'accessing' stamp: ''!
beUnusable
	usable := false! !

!OupsDummyDebugger methodsFor: 'accessing' stamp: ''!
receiver
	^self! !

!OupsDummyDebugger methodsFor: 'helpers' stamp: ''!
methodToDebug
	| i |
	i := 0.
	10 timesRepeat: [ i := i + 1 ].
	^ i! !

!OupsDummyDebugger methodsFor: 'accessing' stamp: ''!
tag: anObject
	tag := anObject! !

!OupsDummyDebugger methodsFor: 'testing' stamp: ''!
handlesContext: aContext
	^self isUsable! !

!OupsDummyDebugger methodsFor: 'accessing' stamp: ''!
isUsable
	^ usable ifNil: [ usable := true ]! !

!OupsDummyDebugger methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!OupsDummyDebugger methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!OupsDummyDebugger methodsFor: 'debugging' stamp: ''!
signalDebuggerError: exception
	(OupsDebuggerFailure of: self on: exception) signal! !

!OupsDummyDebugger methodsFor: 'accessing' stamp: ''!
tag
	^ tag! !

!OupsDummyDebugger methodsFor: 'accessing' stamp: ''!
isError
	^ error ifNil: [ error := false ]! !

!OupsDummyDebugger methodsFor: 'ui requests' stamp: ''!
warningDefaultAction: aWarningException
	tag := aWarningException! !

!OupsDummyDebugger methodsFor: 'helpers' stamp: ''!
zeroDivide
	1/0! !

!OupsDummyDebugger methodsFor: 'deferred message' stamp: ''!
defer: aBlock
	aBlock value.
	deferred := true! !

!OupsDummyDebugger methodsFor: 'accessing' stamp: ''!
beError
	error := true! !

!OupsDummyDebugger methodsFor: 'accessing' stamp: ''!
deferred
	^ deferred ifNil:[deferred := false]! !

!OupsDummyDebugger class methodsFor: 'helpers' stamp: ''!
dummyDebuggerList
	^ OrderedCollection
		withAll:
			{(self named: #A).
			(self named: #B).
			(self named: #C)}! !

!OupsDummyDebugger class methodsFor: 'instance creation' stamp: ''!
named: aString
	^self new name: aString! !

!OupsDummyDebugger class methodsFor: 'helpers' stamp: ''!
dummySession
	| context process session |
	context := [ Set new ] asContext.
	process := Process
		forContext: context
		priority: Processor userInterruptPriority.
	session := process
		newDebugSessionNamed: 'test session'
		startedAt: context.
	session exception: (OupsNullException fromSignallerContext: context).
	^ session! !

!OupsDummyDebuggerSystem commentStamp: ''!
I am a dummy counterpart to the DebuggerSystem class, used to test it.!
!OupsDummyDebuggerSystem methodsFor: 'open debugger' stamp: ''!
openDebuggerOnRequest: aDebugRequest
	self callsToHandleDebugRequest: self callsToHandleDebugRequest + 1.
	debugRequestSentToHandleDebugRequest := aDebugRequest.
	self performPreDebugActionsIn: aDebugRequest! !

!OupsDummyDebuggerSystem methodsFor: 'accessing' stamp: ''!
callsToHandleDebugRequest: aValue
	callsToHandleDebugRequest := aValue! !

!OupsDummyDebuggerSystem methodsFor: 'default values' stamp: ''!
defaultUIManager
	customUIManager ifNil: [ ^ super defaultUIManager ].
	^ customUIManager! !

!OupsDummyDebuggerSystem methodsFor: 'open debugger' stamp: ''!
logDebugRequest: aDebugRequest withUIManager: aCommandLineUIManager

	self openDebuggerOnRequest: aDebugRequest! !

!OupsDummyDebuggerSystem methodsFor: 'helpers' stamp: ''!
spawnNewUIProcess 
	"For testing purposes. Does not actually spawn a new UI process. Just record that this method was called"
	newUIProcessSpawned := true! !

!OupsDummyDebuggerSystem methodsFor: 'accessing' stamp: ''!
newUIProcessSpawned
	newUIProcessSpawned ifNil: [ newUIProcessSpawned := false ].
	^ newUIProcessSpawned! !

!OupsDummyDebuggerSystem methodsFor: 'helpers' stamp: ''!
suspendDebuggedProcess: aDebugRequest
	"Do not actually suspend the debugged process, in order to prevent the UI process from being suspended (image freeze) if a test goes wrong"
	^ 1! !

!OupsDummyDebuggerSystem methodsFor: 'accessing' stamp: ''!
callsToHandleDebugRequest
	^callsToHandleDebugRequest ifNil: [ callsToHandleDebugRequest := 0 ].! !

!OupsDummyDebuggerSystem methodsFor: 'default values' stamp: ''!
debuggerSelectionStrategy
	^ OupsDummySelectionStrategy new! !

!OupsDummyDebuggerSystem methodsFor: 'open debugger' stamp: ''!
warningRequest: aDebugRequest withUIManager: aCommandLineUIManager

	self openDebuggerOnRequest: aDebugRequest! !

!OupsDummyDebuggerSystem methodsFor: 'default values' stamp: ''!
customUIManager: aUIManager
	customUIManager := aUIManager! !

!OupsDummyDebuggerSystem methodsFor: 'accessing' stamp: ''!
debugRequestSentToHandleDebugRequest
	^ debugRequestSentToHandleDebugRequest! !

!OupsDummySelectionStrategy commentStamp: ''!
I am a dummy debugger selection strategy, used for testing!
!OupsDummySelectionStrategy methodsFor: 'iterating' stamp: ''!
nextDebugger
	"This method is not used in the tests, but is defined as a subclass responsibility by DSDebuggerSelectionStrategy"
	self error: 'Should not be called'! !

!OupsDummySelectionStrategy methodsFor: 'instance creation' stamp: ''!
openDebuggerForSession: aDebugSession
	"Do nothing, to avoid opening a debugger during tests"
	^ 1! !

!OupsNullException commentStamp: ''!
All debuggers are opened from an exception.
I am an exception built in case the opening of a debugger is requested without an exception (user interrupt, debugIt..).!
!OupsNullException methodsFor: 'accessing' stamp: ''!
description
	^'I am an Oups NULL debugging exception'! !

!OupsNullException methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
stDebuggerInspectorNodesFor: aStDebuggerContext

	^ aStDebuggerContext nullExceptionNodesFor: self! !

!OupsNullException methodsFor: 'signaling' stamp: ''!
signalIn: context
	"This exception is not signalled but started from a given context, that is its direct signaller context. Therefore the exception is not signalled after setting its signal context"
	signalContext := context.
	signaler ifNil: [ signaler := self receiver ]! !

!OupsNullException class methodsFor: 'instance creation' stamp: ''!
fromSignallerContext: aContext
	^self new signalIn: aContext! !

!OupsSingleDebuggerSelector commentStamp: ''!
I select the first available debugger in the system and try to open a debug session with that debugger.
I do not care about the possible existence of any other debugger.

I am equivalent to the debugger selection strategy encoded in MorphicUIManager prior to the integration of DebuggerSelector.!
!OupsSingleDebuggerSelector methodsFor: 'iterating' stamp: ''!
nextDebugger
	^ debuggers first! !

!OupsSingleDebuggerSelector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	handled := true! !

!OupsSingleDebuggerSelector methodsFor: 'debuggers' stamp: ''!
openDebuggerForSession: aDebugSession

	[ self nextDebugger debugSession: aDebugSession ]
		on: Exception
		do: [ :err | 
			error := err.
			handled := false.
			self signalErrorHandlingErrorForSession: aDebugSession ]! !

!OupsSingleDebuggerSelectorTest methodsFor: 'tests' stamp: ''!
testError
	self deny: OupsDebuggerSelector new hasErrors! !

!OupsSingleDebuggerSelectorTest methodsFor: 'tests' stamp: ''!
testOpenDebuggerForSession
	| session |
	session := OupsDummyDebugger dummySession.
	
	debuggerSelector openDebuggerForSession: session.
	self assert: debuggers first tag identicalTo: session.	
	
	debuggers first tag: nil.
	debuggerSelector openDebuggerForSession: session.
	self assert: debuggers first tag identicalTo: session.	
	self assert: debuggers second tag equals: nil.
	
	debuggers first tag: nil.
	debuggerSelector openDebuggerForSession: session.
	self assert: debuggers first tag identicalTo: session.	
	self assert: debuggers third tag equals: nil.! !

!OupsSingleDebuggerSelectorTest methodsFor: 'running' stamp: ''!
tearDown
	debuggers
		do: [ :dbg | 
			(dbg tag isKindOf: DebugSession)
				ifTrue: [ dbg tag terminate ] ].
	super tearDown! !

!OupsSingleDebuggerSelectorTest methodsFor: 'tests' stamp: ''!
testNextDebugger
	self
		assert: debuggerSelector nextDebugger
		identicalTo: debuggers first.
	self
		assert: debuggerSelector nextDebugger
		identicalTo: debuggers first.
	self
		assert: debuggerSelector nextDebugger
		identicalTo: debuggers first! !

!OupsSingleDebuggerSelectorTest methodsFor: 'tests' stamp: ''!
testErrorWhenOpeningDebugger
	| session |
	session := OupsDummyDebugger dummySession.
	debuggers first beError.	
	debuggerSelector openDebuggerForSession: session.
	
	self assert: debuggerSelector hasErrors.
	self assert: debuggerSelector error class identicalTo: Error.
	self deny: debuggerSelector handled! !

!OupsSingleDebuggerSelectorTest methodsFor: 'tests' stamp: ''!
testHandled
	| session |
	session := OupsDummyDebugger dummySession.
	debuggers first beError.
	
	self assert: debuggerSelector handled.
	
	debuggerSelector openDebuggerForSession: session.
	self deny: debuggerSelector handled! !

!OupsSingleDebuggerSelectorTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."

	super setUp.
	debuggers := OupsDummyDebugger dummyDebuggerList.
	debuggerSelector := OupsSingleDebuggerSelector with: debuggers copy! !

!OupsWarningRequest commentStamp: ''!
Warnings are requested as debug requests, but should not open debugger directly.
Warning requests are submitted through a different _debugging channel_.!
!OupsWarningRequest methodsFor: 'submit' stamp: ''!
submit
	OupsDebuggerSystem new handleWarningDebugRequest: self! !

!OutOfMemory commentStamp: ''!
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: 'testing' stamp: ''!
isResumable

	^true! !

!OutOfMemoryTest methodsFor: 'tests' stamp: ''!
testSignalOfTheLowSpaceFromTheVM

	| s |
	s := Semaphore new.

	"I emulate the execution when the signal is send by the VM"

	self should: [
		Smalltalk specialObjectsArray at: 23 put: Processor activeProcess.
		Smalltalk signalLowSpace.
		s wait] raise: OutOfMemory! !

!OutOfMemoryTest methodsFor: 'running' stamp: ''!
tearDown 

	Smalltalk vm maxOldSpaceSize: oldValue.
	super tearDown.! !

!OutOfMemoryTest methodsFor: 'tests' stamp: ''!
testErrorProducedByAllocatingInTheImage

	"I generate an error when executing the allocation."
	self should: [ ByteArray new: 100 * 1000 * 1000000 ] raise: OutOfMemory! !

!OutOfMemoryTest methodsFor: 'running' stamp: ''!
setUp 

	super setUp.
	oldValue := Smalltalk vm maxOldSpaceSize: 2 * 1024 *1024 * 1024.! !

!OverflowRowMorph commentStamp: ''!
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: 'showing' stamp: ''!
hideMore
	"Hide the morphs that don't fit."

	self moreVisible ifTrue: [
		self moreMorph delete.
		self defer: [self world ifNotNil: [:w |
				w invalidRect: self moreMorph bounds]]]! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
baseMorphs: anObject
	"Set the value of baseMorphs"

	baseMorphs := anObject! !

!OverflowRowMorph methodsFor: 'initialize' stamp: ''!
outOfWorld: aWorld
	"Get rid of the more column if visible."

	self hideMore.
	^super outOfWorld: aWorld! !

!OverflowRowMorph methodsFor: 'geometry' stamp: ''!
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: 'showing' stamp: ''!
showMore
	"Show the morphs that don't fit."

	self hideMore.
	self recreateMoreMorph.
	self world addMorphInLayer: self moreMorph! !

!OverflowRowMorph methodsFor: 'instance creation' stamp: ''!
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: 'accessing' stamp: ''!
moreButtonLabel
	"Answer the label for the more button."

	^AlphaImageMorph new image: (
		ScrollBarMorph
			arrowOfDirection: #right
			size: self buttonWidth
			color: self paneColor darker)! !

!OverflowRowMorph methodsFor: 'stepping' stamp: ''!
step
	"Move the more column if it is showing."

	self moreVisible ifTrue: [
		self window ifNotNil: [:w |
			w isActive ifFalse: [self hideMore]].
		self moreMorph position = self desiredMoreMorphPosition
			ifFalse: [self hideMore]]! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
baseMorphs
	"Answer the value of baseMorphs"

	^ baseMorphs! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
moreMorph
	"Answer the value of moreMorph"

	^ moreMorph! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
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: 'instance creation' stamp: ''!
newPotentialMorph
	"Answer a morph for trialing potential layout."

	|potential|
	potential := self theme builder newRow: self baseMorphs.
	potential extent: potential minExtent.
	^potential! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
popMore
	"Hide / show the unshown base morphs."

	(self moreMorph isNil or: [self moreMorph owner isNil])
		ifTrue: [self showMore]
		ifFalse: [self hideMore]! !

!OverflowRowMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	"Refit the base morphs and potential 'more' button'"

	super extent: aPoint.
	self fitBaseMorphs.
	self defer: [self layoutChanged]
		"since possibly changing actual submorphs during layout processing"! !

!OverflowRowMorph methodsFor: 'stepping' stamp: ''!
stepTime
	"Answer the desired time between steps in milliseconds."

	^100! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
desiredMoreMorphPosition
	"Answer the position the more morph should be placed."

	^self moreButton boundsInWorld bottom + self moreMorph height > self world height
		ifTrue: [self moreButton boundsInWorld topRight - (self moreMorph width@self moreMorph height)]
		ifFalse: [self moreButton boundsInWorld bottomRight - (self moreMorph width@0)]! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
moreButton
	"Answer the value of moreButton"

	^ moreButton! !

!OverflowRowMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		baseMorphs: #();
		moreButton: self newMoreButton;
		changeTableLayout;
		listDirection: #leftToRight;
		vResizing: #shrinkWrap! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
moreButton: anObject
	"Set the value of moreButton"

	moreButton := anObject! !

!OverflowRowMorph methodsFor: 'private' stamp: ''!
buttonWidth
	"Answer the width for the more button."

	^self theme scrollbarThickness + 3! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
moreMorph: anObject
	"Set the value of moreMorph"

	moreMorph := anObject! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
moreVisible
	"Answer whether the more column is visible."

	^(self moreMorph ifNil: [^false]) owner notNil! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Pass on to the list morph and border too."
	
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	self moreButton cornerStyle: self cornerStyle.
	self changed: #moreButtonLabel.
	self moreMorphs do: [:m |
		m adoptPaneColor: paneColor]! !

!OverflowRowMorph methodsFor: 'accessing' stamp: ''!
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! !

!OverridesDeprecatedMethodRule commentStamp: ''!
The method overrided a deprecated method. This is a sign that an API has changed in an upstream project and most likely the method should override another one.

This rule will not activate if the method itself deprecated because it is make sens to deprecate the overriden methods of a deprecated method too.!
!OverridesDeprecatedMethodRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	aMethod isDeprecated ifTrue: [ ^ false ].

	^ aMethod overriddenMethods anySatisfy: #isDeprecated! !

!OverridesDeprecatedMethodRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!OverridesDeprecatedMethodRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Overrides a deprecated method'! !

!OverridesDeprecatedMethodRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!OverridesDeprecatedMethodRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"

	^ 'RBOverridesDeprecatedMethodRule'! !

!OverridesDeprecatedMethodRuleTest methodsFor: 'tests' stamp: ''!
testDoesNotActivateForDeprecatedMethods
	| testMethod |
	testMethod := testSubclass >> (testSubclass compile: self methodName , ' self deprecated: ''Add another explanation message''').

	self assertEmpty: (OverridesDeprecatedMethodRule new check: testMethod)! !

!OverridesDeprecatedMethodRuleTest methodsFor: 'running' stamp: ''!
tearDown

	testClass := nil.
	testSubclass := nil.
	super tearDown! !

!OverridesDeprecatedMethodRuleTest methodsFor: 'tests' stamp: ''!
testBasicCheck1
	| testMethod |
	testMethod := testSubclass >> (testSubclass compile: self methodName , '1').
	self assertEmpty: (OverridesDeprecatedMethodRule new check: testMethod)! !

!OverridesDeprecatedMethodRuleTest methodsFor: 'properties' stamp: ''!
methodName

	^ 'testMethod'! !

!OverridesDeprecatedMethodRuleTest methodsFor: 'tests' stamp: ''!
testBasicCheck

	| testMethod |
	testMethod := testSubclass >> (
		testSubclass compile: self methodName).
		
	self assert: (OverridesDeprecatedMethodRule new check: testMethod) isNotEmpty! !

!OverridesDeprecatedMethodRuleTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	testClass := Object newAnonymousSubclass.
	testSubclass := testClass newAnonymousSubclass.
	
	testClass compile: self methodName, ' self deprecated: ''method is deprecated'''.! !

!PNGReadWriter commentStamp: ''!
I am PNGReadWriter.
I am a concrete subclass of ImageReadWriter.

I read and write the  Portable Network Graphics (PNG) image format.

  https://en.wikipedia.org/wiki/Portable_Network_Graphics

Submitted by Duane Maxwell!
!PNGReadWriter methodsFor: 'chunks' stamp: ''!
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: 'pixel copies' stamp: ''!
copyPixels: y 
	"Handle non-interlaced pixels of supported colorTypes"
	| s |
	s := #(
		#copyPixelsGray:
		nil
		#copyPixelsRGB:
		#copyPixelsIndexed:
		#copyPixelsGrayAlpha:
		nil
		#copyPixelsRGBA:
	) at: colorType + 1.
	self 
		perform: s asSymbol
		with: y! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: ''!
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: [
			"Warning: This is extremely slow. Besides we are downsampling to 8 bits!!"
			blitter := BitBlt bitPokerToForm: form.
			startX to: width-1 by: incX do: [ :x |
				| high low value |
				high := thisScanline at: x//incX<<1 + 1.
				low := thisScanline at: x//incX<<1 + 2.
				value := (high * 256 + low = transparentPixelValue)
					ifTrue: [0 "transparent"]
					ifFalse: [high max: 1].
				blitter pixelAt: x @ y put: value ].
				^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 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: ''!
copyPixelsIndexed: y at: startX by: incX 
	"Handle interlaced indexed color mode (colorType = 3)"
	| offset bits pixPerByte shifts blitter pixel mask pixelNumber |
	offset := y * rowSize + 1.
	bits := form bits.
	bitsPerChannel = 8 ifTrue: 
		[ startX 
			to: width - 1
			by: incX
			do: 
				[ :x | | w b | 
				w := offset + (x >> 2).
				b := (3 - (x \\ 4)) * 8.
				pixel := (thisScanline at: x // incX + 1) << b.
				mask := (255 << b) bitInvert32.
				bits 
					at: w
					put: (((bits at: w) bitAnd: mask) bitOr: pixel) ].
		^ self ].
	bitsPerChannel = 1 ifTrue: 
		[ pixPerByte := 8.
		mask := 1.
		shifts := #(7 6 5 4 3 2 1 0 ) ].
	bitsPerChannel = 2 ifTrue: 
		[ pixPerByte := 4.
		mask := 3.
		shifts := #(6 4 2 0 ) ].
	bitsPerChannel = 4 ifTrue: 
		[ pixPerByte := 2.
		mask := 15.
		shifts := #(4 0 ) ].
	blitter := BitBlt bitPokerToForm: form.
	pixelNumber := 0.
	startX 
		to: width - 1
		by: incX
		do: 
			[ :x | | rawByte | 
			rawByte := thisScanline at: pixelNumber // pixPerByte + 1.
			pixel := rawByte >> (shifts at: pixelNumber \\ pixPerByte + 1) bitAnd: mask.
			blitter 
				pixelAt: x @ y
				put: pixel.
			pixelNumber := pixelNumber + 1 ]! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: ''!
copyPixelsRGB: y
	"Handle non-interlaced RGB color mode (colorType = 2)"

	| i pixel tempForm tempBits |
	(transparentPixelValue isNil and: [ bitsPerChannel = 8 ]) ifTrue: [ "Do the same trick as in #copyPixelsRGBA:"
		| targetIndex |
		tempBits := ByteArray new: thisScanline size * 4 // 3 withAll: 16rFF.
		tempForm := Form extent: width@1 depth: 32 bits: tempBits.
		targetIndex := 1.
		1 to: thisScanline size by: 3 do: [ :index |
			tempBits
				at: targetIndex put: (thisScanline at: index);
				at: targetIndex + 1 put: (thisScanline at: index + 1);
				at: targetIndex + 2 put: (thisScanline at: index + 2).
			targetIndex := targetIndex + 4 ].
		cachedDecoderMap 
			ifNil:[cachedDecoderMap := self rgbaDecoderMapForDepth: depth].
		(BitBlt toForm: form)
			sourceForm: tempForm;
			destOrigin: 0@y;
			combinationRule: Form over;
			colorMap: cachedDecoderMap;
			copyBits.
		^self ].
	tempForm := Form extent: width@1 depth: 32.
	tempBits := tempForm bits.
	pixel := LargePositiveInteger new: 4.
	pixel at: 4 put: 16rFF.
	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 normalize.
				i := i + 3].
			transparentPixelValue
				ifNotNil:
					[1 to: width do: [ :x |
						(tempBits at: x) = transparentPixelValue
							ifTrue: [tempBits at: x put: 0]]]]
		ifFalse:
			[i := 1.
			1 to: width do:
				[ :x |
				(transparentPixelValue == nil or: [(1 to: 6) anySatisfy: [:k | (transparentPixelValue byteAt: k) ~= (thisScanline at: i + 6 - k)]])
					ifTrue:
						[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 normalize]
					ifFalse:
						[tempBits at: x put: 0].
				i := i + 6]].
	
	tempForm displayOn: form at: 0@y rule: Form over.! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: ''!
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 normalize.
			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 normalize.
			i := i + 8.
		].
	].
	tempForm displayOn: form at: 0@y rule: Form paintAlpha.! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: ''!
copyPixels: y at: startX by: incX 
	"Handle interlaced pixels of supported colorTypes"
	| s |
	s := #(
		#copyPixelsGray:at:by:
		nil
		#copyPixelsRGB:at:by:
		#copyPixelsIndexed:at:by:
		#copyPixelsGrayAlpha:at:by:
		nil
		#copyPixelsRGBA:at:by:
	) at: colorType + 1.
	self 
		perform: s asSymbol
		with: y
		with: startX
		with: incX! !

!PNGReadWriter methodsFor: 'filtering' stamp: ''!
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: 'pixel copies' stamp: ''!
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: 'chunks' stamp: ''!
processNextChunk
	| length chunkType crc chunkCrc |
	length := self nextLong.
	chunkType := (self next: 4) asString.
 	(chunk isNil or: [ chunk size ~= length ])
 		ifTrue: [ chunk := self next: length ]
 		ifFalse: [ stream next: length into: chunk startingAt: 1 ].
	chunkCrc := self nextLong bitXor: 4294967295.
	crc := self 
		updateCrc: 4294967295
		from: 1
		to: 4
		in: chunkType.
	crc := self 
		updateCrc: crc
		from: 1
		to: length
		in: chunk.
	crc = chunkCrc ifFalse: [ self error: 'PNGReadWriter crc error in chunk ' , chunkType ].
	chunkType = 'IEND' ifTrue: [ ^ self	"*should* be the last chunk" ].
	chunkType = 'sBIT' ifTrue: 
		[ ^ self processSBITChunk	"could indicate unusual sample depth in original" ].
	chunkType = 'gAMA' ifTrue: [ ^ self	"indicates gamma correction value" ].
	chunkType = 'bKGD' ifTrue: [ ^ self processBackgroundChunk ].
	chunkType = 'pHYs' ifTrue: [ ^ self processPhysicalPixelChunk ].
	chunkType = 'tRNS' ifTrue: [ ^ self processTransparencyChunk ].
	chunkType = 'IHDR' ifTrue: [ ^ self processIHDRChunk ].
	chunkType = 'PLTE' ifTrue: [ ^ self processPLTEChunk ].
	chunkType = 'IDAT' ifTrue: 
		[ "---since the compressed data can span multiple
		chunks, stitch them all together first. later,
		if memory is an issue, we need to figure out how
		to do this on the fly---"
 		idatChunkStream
 			ifNil: [ idatChunkStream := WriteStream with: chunk copy ]
 			ifNotNil: [ idatChunkStream nextPutAll: chunk ].
		^ self ].
	unknownChunks add: chunkType! !

!PNGReadWriter methodsFor: 'writing' stamp: ''!
writeFileSignature
	stream nextPutAll: #[16r89 16r50 16r4E  16r47 16r0D 16r0A 16r1A 16r0A]! !

!PNGReadWriter methodsFor: 'writing' stamp: ''!
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: 'filtering' stamp: ''!
paethPredictLeft: a above: b aboveLeft: c 
	"Predicts the value of a pixel based on nearby pixels, based on
Paeth (GG II, 1991)"
	| pa pb pc |
	pa := b > c 
		ifTrue: [ b - c ]
		ifFalse: [ c - b ].
	pb := a > c 
		ifTrue: [ a - c ]
		ifFalse: [ c - a ].
	pc := a + b - c - c.
	pc < 0 ifTrue: [ pc := pc * -1 ].
	(pa <= pb and: [ pa <= pc ]) ifTrue: [ ^ a ].
	pb <= pc ifTrue: [ ^ b ].
	^ c! !

!PNGReadWriter methodsFor: 'writing' stamp: ''!
writeIENDChunkOn: aStream
	"Write the IEND chunk"
	aStream nextPutAll: 'IEND' asByteArray.! !

!PNGReadWriter methodsFor: 'filtering' stamp: ''!
filterScanline: filterType count: count

	self
		perform: (
			#(filterNone: filterHorizontal: filterVertical: filterAverage: filterPaeth:)
				at: filterType+1)
		with: count.! !

!PNGReadWriter methodsFor: 'chunks' stamp: ''!
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: 'writing' stamp: ''!
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: [ self
				crTrace:
					(String
						streamContents: [ :str | 
							str
								cr;
								print: stream position;
								space;
								nextPutAll: (bytes copyFrom: 1 to: 4) asString;
								nextPutAll: ' len=';
								print: length;
								nextPutAll: ' crc=0x';
								nextPutAll: crc printStringHex ]) ].
	self nextLongPut: length - 4.	"exclude chunk name"
	stream next: length putAll: bytes startingAt: 1.
	self nextLongPut: crc.
	debug
		ifTrue: [ self crTrace: ' afterPos=' , stream position asString ].
	crcStream resetToStart! !

!PNGReadWriter methodsFor: 'filtering' stamp: ''!
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: 'writing' stamp: ''!
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: [ self
				crTrace:
					('compressed size=<1s> uncompressed size=<2s>'
						expandMacrosWith: aStream position
						with: z position) ]! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: ''!
copyPixelsGrayAlpha: y 
	"Handle non-interlaced grayscale with alpha color mode (colorType = 4)"
	| i pixel gray b |
	b := BitBlt bitPokerToForm: form.
	bitsPerChannel = 8 
		ifTrue: 
			[ 0 
				to: width - 1
				do: 
					[ :x | 
					i := (x << 1) + 1.
					gray := thisScanline at: i.
					pixel := ((thisScanline at: i + 1) << 24) + (gray << 16) + (gray << 8) + gray.
					b 
						pixelAt: x @ y
						put: pixel ] ]
		ifFalse: 
			[ 0 
				to: width - 1
				do: 
					[ :x | 
					i := (x << 2) + 1.
					gray := thisScanline at: i.
					pixel := ((thisScanline at: i + 2) << 24) + (gray << 16) + (gray << 8) + gray.
					b 
						pixelAt: x @ y
						put: pixel ] ]! !

!PNGReadWriter methodsFor: 'writing' stamp: ''!
nextPutImage: aForm interlace: aMethod filter: aFilterType 
	"Note: For now we keep it simple - interlace and filtering are simply ignored"

	| crcStream |
	bigEndian := EndianDetector 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: 'filtering' stamp: ''!
filterNone: count! !

!PNGReadWriter methodsFor: 'accessing' stamp: ''!
understandsImageFormat
	#(137 80 78 71 13 10 26 10) do: [ :byte |
		stream next = byte ifFalse: [^ false]].
	^ true! !

!PNGReadWriter methodsFor: 'miscellaneous' stamp: ''!
grayColorsFor: d
	"return a color table for a gray image"

	palette := Array new: 1<<d.
	d = 1 ifTrue: [
		palette at: 1 put: Color black.
		palette at: 2 put: Color white.
		^  palette
		].
	d = 2 ifTrue: [
		palette at: 1 put: Color black.
		palette at: 2 put: (Color gray: 85.0 / 255.0).
		palette at: 3 put: (Color gray: 170.0 / 255.0).
		palette at: 4 put: Color white.
		^ palette
		].
	d = 4 ifTrue: [
		0 to: 15 do: [ :g |
			palette at: g+1 put: (Color gray: (g/15) asFloat) ].
		^ palette
		].
	d = 8 ifTrue: [
		0 to: 255 do: [ :g |
			palette at: g+1 put: (Color gray: (g/255) asFloat) ].
		^ palette
		].! !

!PNGReadWriter methodsFor: 'chunks' stamp: ''!
processPhysicalPixelChunk

	"Transcript show: '  PHYSICAL: ',chunk printString."! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: ''!
copyPixelsGrayAlpha: y at: startX by: incX 
	"Handle interlaced grayscale with alpha color mode (colorType = 4)"
	| i pixel gray b |
	b := BitBlt bitPokerToForm: form.
	bitsPerChannel = 8 
		ifTrue: 
			[ startX 
				to: width - 1
				by: incX
				do: 
					[ :x | 
					i := (x // incX << 1) + 1.
					gray := thisScanline at: i.
					pixel := ((thisScanline at: i + 1) << 24) + (gray << 16) + (gray << 8) + gray.
					b 
						pixelAt: x @ y
						put: pixel ] ]
		ifFalse: 
			[ startX 
				to: width - 1
				by: incX
				do: 
					[ :x | 
					i := (x // incX << 2) + 1.
					gray := thisScanline at: i.
					pixel := ((thisScanline at: i + 2) << 24) + (gray << 16) + (gray << 8) + gray.
					b 
						pixelAt: x @ y
						put: pixel ] ]! !

!PNGReadWriter methodsFor: 'accessing' stamp: ''!
debugging

	^Debugging == true! !

!PNGReadWriter methodsFor: 'chunks' stamp: ''!
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: 'writing' stamp: ''!
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: ''!
writeSBITChunkOn: aStream
	"Write the IDAT chunk"
	aStream nextPutAll: 'sBIT' asByteArray.
	form depth = 16 ifFalse:[self error: 'Unimplemented feature'].
	aStream nextPut: 5.
	aStream nextPut: 5.
	aStream nextPut: 5.
	aStream nextPut: 1.! !

!PNGReadWriter methodsFor: 'chunks' stamp: ''!
processIDATChunk

	interlaceMethod = 0
		ifTrue: [ self processNonInterlaced ]
		ifFalse: [ self processInterlaced ]! !

!PNGReadWriter methodsFor: 'chunks' stamp: ''!
processPLTEChunk
	| colorCount i |
	colorCount := chunk size // 3.	"TODO - validate colorCount against depth"
	palette := Array new: colorCount.
	0 
		to: colorCount - 1
		do: 
			[ :index | 
			i := index * 3 + 1.
			palette 
				at: index + 1
				put: (Color 
						r: (chunk at: i) / 255.0
						g: (chunk at: i + 1) / 255.0
						b: (chunk at: i + 2) / 255.0) ]! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: ''!
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: 'writing' stamp: ''!
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: 'accessing' stamp: ''!
nextImage
	bigEndian := EndianDetector isBigEndian.
	filtersSeen := Bag new.
	idatChunkStream := nil.
	transparentPixelValue := nil.
	unknownChunks := Set new.
	stream skip: 8.
	[ stream atEnd ] whileFalse: [ self processNextChunk ].
	"Set up our form"
	palette
		ifNotNil: [ "Dump the palette if it's the same as our standard palette"
			palette = (StandardColors copyFrom: 1 to: palette size)
				ifTrue: [ palette := nil ] ].
	(depth <= 8 and: [ palette notNil ])
		ifTrue: [ form := ColorForm extent: width @ height depth: depth.
			form colors: palette ]
		ifFalse: [ form := Form extent: width @ height depth: depth ].
	backColor ifNotNil: [ form fillColor: backColor ].
	idatChunkStream
		ifNil: [ self error: 'image data is missing' ]
		ifNotNil: [ self processIDATChunk ].
	unknownChunks isEmpty
		ifFalse:
			[ "Transcript show: ' ',unknownChunks asSortedCollection asArray printString." ].
	self debugging
		ifTrue: [ self crTrace: 'form = ' , form printString.
			self crTrace: 'colorType = ' , colorType printString.
			self crTrace: 'interlaceMethod = ' , interlaceMethod printString.
			self
				crTrace: 'filters = ' , filtersSeen sortedCounts asArray printString ].
	^ form! !

!PNGReadWriter methodsFor: 'writing' stamp: ''!
writeTRNSChunkOn: aStream
	"Write out tRNS chunk"
	aStream nextPutAll: 'tRNS' asByteArray.
	form colors do:[:aColor|
		aStream nextPut: (aColor alpha * 255) truncated.
	].! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: ''!
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 normalize.
	].
	tempForm displayOn: form at: 0@y rule: Form over.! !

!PNGReadWriter methodsFor: 'writing' stamp: ''!
updateCrc: oldCrc from: start to: stop in: aCollection
	^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: ''!
copyPixelsGray: y 
	"Handle non-interlaced grayscale color mode (colorType = 0)"

	| base bits bytesLeft word |
	bitsPerChannel = 16 ifTrue: [
		"Warning: This is extremely slow. Besides we are downsampling to 8 bits!!"
		| blitter |
		blitter := BitBlt bitPokerToForm: form.
		0 to: width - 1 do: [ :x |
			| high low value |
			high := thisScanline at: x * 2 + 1.
			low := thisScanline at: x * 2 + 2.
			value := (high * 256 + low = transparentPixelValue)
				ifTrue: [0 "transparent"]
				ifFalse: [high max: 1].
			blitter pixelAt: x @ y put: value ].
			^self ].

	"Just copy the bits"

	"This Smalltalk version might be easier to understand than the others below."
	base := y * (form width * bitsPerChannel + 31 // 32) + 1.
	bits := form bits.
	0 to: thisScanline size // 4 - 1 do: [ :i |
		| ii |
		ii := i * 4.
		"This somewhat weird mixture of (#* and #+) with (#bitShift: and #bitOr:) 
		is to make use of faster arithmetic bytecodes, but not of slow largeintegers."
		word :=
			(((thisScanline at: ii + 1) * 256 + 
			(thisScanline at: ii + 2) * 256 + 
			(thisScanline at: ii + 3)) bitShift: 8) bitOr: 
			(thisScanline at: ii + 4).
		bits at: base + i put: word ].	
	(bytesLeft := thisScanline size bitAnd: 3) = 0 ifFalse: [
		word := 0.
		thisScanline size - bytesLeft + 1 to: thisScanline size do: [ :ii |
			word := word * 256 + (thisScanline at: ii) ].
		word := word bitShift: 8 * (4 - bytesLeft).
		bits at: base + (thisScanline size // 4) put: word ].

	"This interesting technique (By Andreas Raab) is faster for very large images, but might be slower for small ones"
	"^self copyPixelsGrayWeirdBitBltHack: y ".
	"It uses the following method:
	PNGReadWriter >> copyPixelsGrayWeirdBitBltHack: y 
	""Handle non-interlaced black and white color mode (colorType = 0)
	By Andreas Raab""
	
	| source dest cmap |
	source := Form extent: 1 @ (thisScanline size // 4) depth: 32 bits: thisScanline.
	dest := Form extent: 1 @ (form bits size) depth: 32 bits: form bits.
	cmap := Smalltalk isLittleEndian
		ifTrue:[ColorMap 
					shifts: #(-24 -8 8 24) 
					masks: #(16rFF000000 16r00FF0000 16r0000FF00 16r000000FF)].
	(BitBlt toForm: dest)
		sourceForm: source;
		destX: 0 destY: (y * form width*bitsPerChannel//32) width: 1 height: (form width+31*bitsPerChannel//32);
		colorMap: cmap;
		combinationRule: 3;
		copyBits."
		
	"This interesting technique  (By Yoshiki Ohshima) is faster for very large images, but might be slower for small ones"
	"form bits copyFromByteArray2: thisScanline to: y * (form width* bitsPerChannel // 32)".
	"It uses the following method:
	BitMap >> copyFromByteArray2: byteArray to: i
	""This method should work with either byte orderings""

	| myHack byteHack |
	myHack := Form new hackBits: self.
	byteHack := Form new hackBits: byteArray.
	Smalltalk  isLittleEndian ifTrue: [byteHack swapEndianness].
	byteHack displayOn: myHack at:  0@i"! !

!PNGReadWriter methodsFor: 'filtering' stamp: ''!
filterHorizontal: count 
	"Use the pixel to the left as a predictor"
	| delta |
	delta := bitsPerPixel // 8 max: 1.
	delta + 1 
		to: count
		do: 
			[ :i | 
			thisScanline 
				at: i
				put: ((thisScanline at: i) + (thisScanline at: i - delta) bitAnd: 255) ]! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: ''!
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: 16rFF.
	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 normalize.
				i := i + 3.
				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]]]]
		ifFalse:
			[i := (startX // incX * 6) + 1.
			xx := startX+1.
			1 to: loopsToDo do:
				[ :j |
				(transparentPixelValue == nil or: [(1 to: 6) anySatisfy: [:k | (transparentPixelValue byteAt: k) ~= (thisScanline at: i + 6 - k)]])
					ifTrue:
						[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 normalize.]
					ifFalse:
						[tempBits at: xx put: 0].
				i := i + 6.
				xx := xx + incX]].
	tempForm displayOn: form at: 0@y rule: Form over.! !

!PNGReadWriter methodsFor: 'writing' stamp: ''!
writeType6DataOn: zStream
	"Write RGBA data."
	| scanline hack hackBlt cm miscBlt |
	scanline := ByteArray new: bytesPerScanline.
	hack := Form extent: width@1 depth: 32 bits: scanline.
	form depth = 16 ifTrue:[
		"Expand 16 -> 32"
		miscBlt := BitBlt toForm: hack.
		miscBlt sourceForm: form.
		miscBlt combinationRule: Form over.
		miscBlt destOrigin: 0@0.
		miscBlt width: width; height: 1.
	].
	hackBlt := BitBlt toForm: hack.
	hackBlt sourceForm: (miscBlt ifNil:[form] ifNotNil:[hack]).
	hackBlt combinationRule: Form over.
	hackBlt destOrigin: 0@0.
	hackBlt width: width; height: 1.
	bigEndian ifTrue:[
		cm := ColorMap 
			shifts: #(8 8 8 -24) 
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000).
	] ifFalse:[
		cm := ColorMap 
			shifts: #(-16 0 16 0) 
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000).
	].
	hackBlt colorMap: cm.
	0 to: height-1 do:[:i|
		miscBlt ifNil:[
			hackBlt sourceOrigin: 0@i; copyBits.
		] ifNotNil:[
			miscBlt sourceOrigin: 0@i; copyBits.
			hack fixAlpha.
			hackBlt copyBits.
		].
		zStream nextPut: 0. "filterType"
		zStream nextPutAll: scanline.
	].
	zStream close.! !

!PNGReadWriter methodsFor: 'writing' stamp: ''!
writeType3DataOn: zStream
	"Write color indexed data."
	| scanline hack hackBlt swizzleBlt swizzleHack hackDepth |
	scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4.
	hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated].
	hack := Form extent: width@1 depth: hackDepth bits: scanline.
	hackBlt := BitBlt toForm: hack.
	hackBlt sourceForm: form.
	hackBlt combinationRule: Form over.
	hackBlt destOrigin: 0@0.
	hackBlt width: width; height: 1.
	(form depth < 8 and:[bigEndian not]) ifTrue:[
		swizzleHack := Form new hackBits: scanline.
		swizzleBlt := BitBlt toForm: swizzleHack.
		swizzleBlt sourceForm: swizzleHack.
		swizzleBlt combinationRule: Form over.
		swizzleBlt colorMap: (StandardSwizzleMaps at: form depth).
	].
	0 to: height-1 do:[:i|
		hackBlt sourceOrigin: 0@i; copyBits.
		swizzleBlt ifNotNil:[swizzleBlt copyBits].
		zStream nextPut: 0. "filterType"
		zStream next: bytesPerScanline putAll: scanline startingAt: 1.
	].
	zStream close.! !

!PNGReadWriter methodsFor: 'chunks' stamp: ''!
processNonInterlaced
	| z filter temp copyMethod debug |
	debug := self debugging.
	copyMethod := #(#copyPixelsGray: nil #copyPixelsRGB: #copyPixelsIndexed: #copyPixelsGrayAlpha: nil #copyPixelsRGBA:)
		at: colorType + 1.
	debug
		ifTrue: [ self
				crTrace:
					('NI chunk size=<1s>' expandMacrosWith: idatChunkStream position) ].
	z := ZLibReadStream
		on: idatChunkStream originalContents
		from: 1
		to: idatChunkStream position.
	prevScanline := ByteArray new: bytesPerScanline.
	thisScanline := ByteArray new: bytesPerScanline.
	0 to: height - 1 do: [ :y | 
		filter := z next.
		debug
			ifTrue: [ filtersSeen add: filter ].
		thisScanline := z
			next: bytesPerScanline
			into: thisScanline
			startingAt: 1.
		(debug and: [ thisScanline size < bytesPerScanline ])
			ifTrue: [ self
					traceCr:
						('wanted {1} but only got {2}'
							format:
								{bytesPerScanline.
								thisScanline size}) ].
		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: [ self trace: ' compressed size=' , z position asString ]! !

!PNGReadWriter methodsFor: 'miscellaneous' stamp: ''!
doPass: pass
	"Certain interlace passes are skipped with certain small image
dimensions"

	pass = 1 ifTrue: [ ^ true ].
	((width = 1) and: [height = 1]) ifTrue: [ ^ false ].
	pass = 2 ifTrue: [ ^ width >= 5 ].
	pass = 3 ifTrue: [ ^ height >= 5 ].
	pass = 4 ifTrue: [ ^ (width >=3 ) or: [height >= 5] ].
	pass = 5 ifTrue: [ ^ height >=3 ].
	pass = 6 ifTrue: [ ^ width >=2 ].
	pass = 7 ifTrue: [ ^ height >=2 ].! !

!PNGReadWriter methodsFor: 'chunks' stamp: ''!
processInterlaced
	| z filter bytesPerPass startingCol colIncrement rowIncrement startingRow cx sc temp |
	startingCol := #(0 4 0 2 0 1 0 ).
	colIncrement := #(8 8 4 4 2 2 1 ).
	rowIncrement := #(8 8 8 4 4 2 2 ).
	startingRow := #(0 0 4 0 2 0 1 ).
 	z := ZLibReadStream 
 		on: idatChunkStream originalContents
 		from: 1
 		to: idatChunkStream position.
	1 
		to: 7
		do: 
			[ :pass | 
			(self doPass: pass) ifTrue: 
				[ cx := colIncrement at: pass.
				sc := startingCol at: pass.
				bytesPerPass := ((width - sc + cx - 1) // cx * bitsPerPixel + 7) // 8.
				prevScanline := ByteArray new: bytesPerPass.
				thisScanline := ByteArray new: bytesPerScanline.
				(startingRow at: pass) 
					to: height - 1
					by: (rowIncrement at: pass)
					do: 
						[ :y | 
						filter := z next.
						filtersSeen add: filter.
						(filter isNil or: [ (filter 
							between: 0
							and: 4) not ]) ifTrue: [ ^ self ].
						thisScanline := z 
							next: bytesPerPass
							into: thisScanline
							startingAt: 1.
						self 
							filterScanline: filter
							count: bytesPerPass.
						self 
							copyPixels: y
							at: sc
							by: cx.
						temp := prevScanline.
						prevScanline := thisScanline.
						thisScanline := temp ] ] ].
	z atEnd ifFalse: [ self error: 'Unexpected data' ]! !

!PNGReadWriter methodsFor: 'filtering' stamp: ''!
filterAverage: count 
	"Use the average of the pixel to the left and the pixel above as a predictor"
	| delta |
	delta := bitsPerPixel // 8 max: 1.
	1 
		to: delta
		do: 
			[ :i | 
			thisScanline 
				at: i
				put: ((thisScanline at: i) + ((prevScanline at: i) // 2) bitAnd: 255) ].
	delta + 1 
		to: count
		do: 
			[ :i | 
			thisScanline 
				at: i
				put: ((thisScanline at: i) + (((prevScanline at: i) + (thisScanline at: i - delta)) // 2) bitAnd: 255) ]! !

!PNGReadWriter methodsFor: 'chunks' stamp: ''!
processTransparencyChunk

	"Transcript show: '  TRANSPARENCY ',chunk printString."
	colorType = 0
		ifTrue:
			[transparentPixelValue := chunk unsignedShortAt: 1 bigEndian: true.
			bitsPerChannel <= 8
				ifTrue: [palette at: transparentPixelValue + 1 put: Color transparent]
				ifFalse: [palette at: 1 put: Color transparent].
			^self].
	colorType = 2
		ifTrue:
			[| red green blue |
			red :=  chunk unsignedShortAt: 1 bigEndian: true.
			green :=  chunk unsignedShortAt: 3 bigEndian: true.
			blue :=  chunk unsignedShortAt: 5 bigEndian: true.
			transparentPixelValue := bitsPerChannel <= 8
				ifTrue: [16rFF00 + red << 8 + green << 8 + blue]
				ifFalse: [red << 16 + green << 16 + blue].
			^self].
	colorType = 3
		ifTrue:
			[chunk withIndexDo: [ :alpha :index |
				palette at: index put: ((palette at: index) alpha: alpha/255)].
			^self].! !

!PNGReadWriter class methodsFor: 'class initialization' stamp: ''!
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: 'initialize' stamp: ''!
debugging: aBoolean 
	Debugging := aBoolean! !

!PNGReadWriter class methodsFor: 'utilities' stamp: ''!
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'! !

!PNGReadWriter class methodsFor: 'image reading/writing' stamp: ''!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('png')! !

!PNGReadWriterTest commentStamp: ''!
SUnit tests for class PNGReadWriter!
!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
drawTransparentStuffOn: aForm
	"Draw stuff on aForm. Avoid any symmetry."

	| canvas |
	canvas := FormCanvas on: aForm.
	canvas
		frameAndFillRectangle: (1 @ 1 corner: aForm extent - 15)
		fillColor: (Color red alpha: 0.25)
		borderWidth: 3
		borderColor: (Color green alpha: 0.5).
	canvas
		fillOval: (aForm boundingBox topRight - (15 @ -5) extent: 20 @ 20)
		color: (Color white alpha: 0.75)
		borderWidth: 1
		borderColor: Color blue.
	^ aForm	"(PNGReadWriterTest new drawStuffOn: (Form extent: 32@32 depth: 16)) display"! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
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 - bits' stamp: ''!
test16BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 16))! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
testPngDecodingColors16
	self decodeColors: self coloredFiles16 depth: 16.! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
testPngDecodingColors32
	self decodeColors: self coloredFiles32 depth: 32.! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
testPngEncodingColors16
	self encodeColors: self coloredFiles16 depth: 16.! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
encodeColors: colorsAndFiles depth: requiredDepth
	colorsAndFiles
		do: [ :assoc | 
			| original encoded color ff |
			color := assoc key.
			original := assoc value base64Decoded.
			ff := Form extent: 32 @ 32 depth: requiredDepth.
			ff fillColor: color.
			encoded := ByteArray new writeStream.
			PNGReadWriter putForm: ff onStream: encoded.
			self assert: encoded contents equals: original contents ]! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
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: 'tests - decoding' stamp: ''!
testNewFromSampleBytes
	"Based on a problem report by Hilaire Fernandes, this fails on 64 bit Spur if a
	synthesized LargeInteger parameter to Bitmap #at:put: is not normalized prior
	to calling the primitive. See problem report at
	http://lists.pharo.org/pipermail/pharo-users_lists.pharo.org/2017-June/032660.html"

	| sampleBytes png form |
	sampleBytes := #[137 80 78 71 13 10 26 10 0 0 0 13 73 72
		68 82 0 0 0 48 0 0 0 48 16 6 0 0 0 7 146 37 196 0 0 0 6 98 75 71 68 255
		255 255 255 255 255 9 88 247 220 0 0 0 9 112 72 89 115 0 0 0 72 0 0 0 72
		0 70 201 107 62 0 0 1 153 73 68 65 84 120 218 237 155 73 110 195 48 12
		69 227 162 183 211 9 180 11 130 220 77 39 208 249 210 77 181 8 81 69 19
		39 169 255 109 12 35 137 197 255 105 81 244 144 219 13 0 0 0 0 0 116 16
		66 8 33 188 94 214 113 120 99 214 151 111 238 1 115 206 57 231 235 178
		54 68 10 238 19 112 58 1 189 1 238 158 16 233 25 255 37 117 224 221 141
		215 210 193 158 128 83 140 215 210 181 156 0 26 216 169 139 180 155 210
		218 50 184 124 126 74 34 122 245 204 234 101 207 224 41 221 145 150 14
		49 67 118 77 132 118 220 98 93 208 168 64 107 172 226 18 63 19 91 194
		172 103 132 117 124 106 194 117 132 210 227 215 143 103 109 124 65 173 4
		181 4 173 149 128 254 223 121 49 190 160 190 6 212 4 126 22 94 12 163 91
		173 241 229 112 219 141 188 51 106 184 223 46 139 162 62 3 164 137 49
		198 24 253 117 89 219 241 183 145 181 82 180 94 154 192 47 212 248 247
		253 209 45 152 102 205 120 36 130 137 182 193 159 19 5 22 233 53 158 126
		31 48 209 54 190 181 15 8 189 247 215 71 141 174 25 127 218 243 137 105
		168 17 53 99 164 140 247 154 8 183 119 67 139 177 41 165 148 210 117 209
		125 233 241 181 16 187 18 158 21 254 124 62 30 247 251 186 241 173 113
		122 227 148 70 237 145 100 175 33 210 120 139 207 205 237 232 255 22 71
		129 45 16 60 3 158 163 123 6 140 214 74 239 198 207 198 201 189 102 12
		151 32 26 128 155 23 150 22 105 189 96 38 181 88 31 211 206 113 163 165
		151 109 17 182 110 231 118 213 193 222 5 237 154 8 171 184 217 254 31
		176 123 9 114 255 146 177 187 128 224 3 0 0 0 0 192 198 252 0 102 116 72
		96 211 171 62 8 0 0 0 0 73 69 78 68 174 66 96 130].

	png := PNGReadWriter on: sampleBytes readStream.
	form := png nextImage.
	self assert: Form equals: form class.! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
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 - colors' stamp: ''!
testBlack32
	self encodeAndDecodeColor: Color blue depth: 32! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
encodeAndDecodeWithError: aStream
	self should:[self encodeAndDecodeStream: aStream] raise: Error! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: ''!
testBlack8
	self encodeAndDecodeColor: Color blue depth: 8! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
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 identicalTo: 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 equals: reversed width.
	self assert: original height equals: reversed height.
	self assert: original depth equals: reversed depth.
	self deny: original nativeDepth equals: reversed nativeDepth.
	original depth = 32 ifTrue: [ self assert: original bits equals: reversed bits ] ifFalse: [ self deny: original bits equals: 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 equals: decoded width.
	self assert: original height equals: decoded height.
	self assert: original depth equals: decoded depth.
	self assert: original bits equals: decoded bits.
	self assert: original class identicalTo: 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: 'tests - colors' stamp: ''!
testBlue16
	self encodeAndDecodeColor: Color blue depth: 16! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test2Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 2))! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
testPngEncodingColors8
	self encodeColors: self coloredFiles8 depth: 8.! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
testAlphaCoding
	self encodeAndDecodeAlpha: (self drawTransparentStuffOn: (Form extent: 33@33 depth: 32))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test4BitDisplay
	self encodeAndDecodeDisplay: 4! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
encodeAndDecodeForm: original
	fileName := 'testForm', original depth printString,'.png'.
	self encodeAndDecode: original.
	self deleteFile.! !

!PNGReadWriterTest methodsFor: 'running' stamp: ''!
tearDown
	self currentWorld changed.
	super tearDown! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: ''!
testGreen8
	self encodeAndDecodeColor: Color green depth: 8! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test1Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 1))! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
testPngDecodingColors8
	self decodeColors: self coloredFiles8 depth: 8.! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: ''!
testBlue32
	self encodeAndDecodeColor: Color blue depth: 32! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test4BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 4))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test2BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 2))! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: ''!
testGreen16
	self encodeAndDecodeColor: Color green depth: 16! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: ''!
testBlue8
	self encodeAndDecodeColor: Color blue depth: 8! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: ''!
testRed8
	self encodeAndDecodeColor: Color red depth: 8! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
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: 'tests - bits' stamp: ''!
test2BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 2))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test1BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 1))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test16Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 16))! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
testPngEncodingColors32
	self encodeColors: self coloredFiles32 depth: 32.! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test8BitDisplay
	self encodeAndDecodeDisplay: 8! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: ''!
testRed16
	self encodeAndDecodeColor: Color red depth: 16! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test2BitDisplay
	self encodeAndDecodeDisplay: 2! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test8BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 8))! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: ''!
testRed32
	self encodeAndDecodeColor: Color red depth: 32! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test32BitDisplay
	self encodeAndDecodeDisplay: 32! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test4BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 4))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test32Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 32))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test16BitDisplay
	self encodeAndDecodeDisplay: 16! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test1BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 1))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test32BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 32))! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: ''!
testGreen32
	self encodeAndDecodeColor: Color green depth: 32! !

!PNGReadWriterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	fileName := nil.! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
encodeAndDecodeDisplay: depth
	| form |
	fileName := 'testDisplay', depth printString,'.png'.
	form := Form extent: (Display extent min: 560@560) depth: depth.
	self currentWorld fullDrawOn: form getCanvas.
	self encodeAndDecode: form.
	self deleteFile.! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test8Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 8))! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
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 equals: decoded width.
	self assert: original height equals: decoded height.
	self assert: original depth equals: decoded depth.
	self assert: original bits equals: decoded bits.
	self assert: original class identicalTo: 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 ] ] ]
		ensure: [ stream close ]! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
readEncoded: bytes
	"Answer a ReadStream on the file named by fileName, if possible; else a ReadStream on bytes"

	fileName ifNil:[^ bytes readStream ].
	^(File named: fileName) readStream! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test1BitDisplay
	self encodeAndDecodeDisplay: 1! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
encodeAndDecodeAlpha: original
	fileName := 'testAlpha', original depth printString,'.png'.
	self encodeAndDecode: original.
	self deleteFile.! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
drawStuffOn: aForm
	"Draw stuff on aForm. Avoid any symmetry."

	| canvas |
	canvas := FormCanvas on: aForm.
	canvas
		frameAndFillRectangle: (1 @ 1 corner: aForm extent - 15)
		fillColor: Color red
		borderWidth: 3
		borderColor: Color green.
	canvas
		fillOval: (aForm boundingBox topRight - (15 @ -5) extent: 20 @ 20)
		color: Color blue
		borderWidth: 1
		borderColor: Color white.
	^ aForm	"(PNGReadWriterTest new drawStuffOn: (Form extent: 32@32 depth: 16)) display"! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test4Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 4))! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
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: ''!
writeEncoded: bytes
	
	fileName ifNil: [ ^self ].
	fileName asFileReference
		ensureDelete;
		binaryWriteStreamDo: [ :file | file nextPutAll: bytes ]! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: ''!
deleteFile

	fileName asFileReference ensureDelete! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
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 - colors' stamp: ''!
testBlack16
	self encodeAndDecodeColor: Color blue depth: 16! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: ''!
decodeColors: colorsAndFiles depth: requiredDepth
	colorsAndFiles
		do: [ :assoc | 
			| bytes color form |
			color := assoc key.
			bytes := assoc value base64Decoded.
			form := PNGReadWriter formFromStream: bytes readStream.
			self assert: form depth equals: requiredDepth.
			self assert: (form pixelValueAt: 1 @ 1) equals: (color pixelValueForDepth: requiredDepth) ]! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: ''!
test8BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 8))! !

!POP3Client commentStamp: ''!
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: 'protocol' stamp: ''!
apopLoginUser: userName password: password

	self loginUser: userName password: password loginMethod: #APOP! !

!POP3Client methodsFor: 'private - protocol' stamp: ''!
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 - protocol' stamp: ''!
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: ''!
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 - testing' stamp: ''!
responseIsError
	^self lastResponse beginsWith: '-'! !

!POP3Client methodsFor: 'private' stamp: ''!
loginMethod
	^self connectionInfo at: #loginMethod ifAbsent: [nil]! !

!POP3Client methodsFor: 'private' stamp: ''!
loginMethod: aSymbol
	^self connectionInfo at: #loginMethod put: aSymbol! !

!POP3Client methodsFor: 'protocol' stamp: ''!
loginUser: userName password: password

	self loginUser: userName password: password loginMethod: #clearText! !

!POP3Client methodsFor: 'protocol' stamp: ''!
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: 'protocol' stamp: ''!
loginUser: userName password: password loginMethod: aLoginMethod

	self user: userName.
	self password: password.
	self loginMethod: aLoginMethod.
	self login! !

!POP3Client methodsFor: 'protocol' stamp: ''!
quit
	"QUIT <CRLF>"

	self sendCommand: 'QUIT'.
	self checkResponse.! !

!POP3Client methodsFor: 'private - testing' stamp: ''!
responseIsWarning
	^self lastResponse beginsWith: '-'! !

!POP3Client methodsFor: 'private - protocol' stamp: ''!
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: 'protocol' stamp: ''!
retrieveMessage: number
	"retrieve the numbered message"

	self ensureConnection.
	self sendCommand: 'RETR ', number printString.
	self checkResponse.
	self logProgress: self lastResponse.

	^self getMultilineResponse! !

!POP3Client methodsFor: 'protocol' stamp: ''!
deleteMessage: num
	"delete the numbered message"

	self ensureConnection.
	self sendCommand: 'DELE ', num printString.
	self checkResponse.
	self logProgress: self lastResponse! !

!POP3Client class methodsFor: 'examples' stamp: ''!
example

	"POP3Client example"
	"download a user's messages into an OrderedCollection and inspect the OrderedCollection"

	| ps messages userName password |
	userName := (UIManager default request: 'POP username').
	password := (UIManager default request: 'POP password').
	ps := POP3Client openOnHostNamed: (UIManager default request: 'POP server').
	[
	ps loginUser: userName password: password.
	ps logProgressToTranscript.

	messages := OrderedCollection new.
	1 to: ps messageCount do: [ :messageNr |
		messages add: (ps retrieveMessage: messageNr) ]]
		ensure: [ps close].

	messages inspect.! !

!POP3Client class methodsFor: 'accessing' stamp: ''!
defaultPortNumber
	^110! !

!POP3Client class methodsFor: 'accessing' stamp: ''!
logFlag
	^#pop! !

!POP3LoginError commentStamp: ''!
Exception for signaling POP3 login failures.!
!PSMCChangeWrapper commentStamp: ''!
Abstract superclass for changes wrapper (for patch tree)!
!PSMCChangeWrapper methodsFor: 'accessing' stamp: ''!
operation
	"Answer the underlying operation."

	self subclassResponsibility ! !

!PSMCChangeWrapper methodsFor: 'accessing' stamp: ''!
icon

	"Answer a form with an icon to represent the receiver"

	| o |

	o := self operation.
	o ifNil: [ ^ self iconNamed: #changeEmptyIcon ].
	o isAddition
		ifTrue: [ ^ self iconNamed: #changeAddIcon ].
	o isRemoval
		ifTrue: [ ^ self iconNamed: #changeRemoveIcon ].
	^ self iconNamed: #changeUpdateIcon! !

!PSMCChangeWrapper methodsFor: 'accessing' stamp: ''!
model: anObject
	"Set the model."

	model := anObject! !

!PSMCChangeWrapper methodsFor: 'accessing' stamp: ''!
actualClass
	"Answer the class represented in the receiver."

	^(self operation ifNil: [^nil]) targetClass! !

!PSMCChangeWrapper methodsFor: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
isConflict
	"Answer whether the receiver is a conflict item."

	^false! !

!PSMCChangesGrouper commentStamp: ''!
I am a visitor on MCDefinition objects. I will group a collection of definitions into a tree that will be shown in the PSMCPatchMorph.!
!PSMCChangesGrouper methodsFor: 'visitor' stamp: ''!
visitMetaclassDefinition: aMCClassDefinition 
	
	"Do nothing for metaclasses"! !

!PSMCChangesGrouper methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	classChanges := OrderedCollection new.
	nonClassChanges := OrderedCollection new.
	classes := Set new.! !

!PSMCChangesGrouper methodsFor: 'visitor' stamp: ''!
visitClassDefinition: aMCClassDefinition 
	
	self ensureClassChangeWrapperNamed: aMCClassDefinition fullClassName! !

!PSMCChangesGrouper methodsFor: 'visitor' stamp: ''!
visitScriptDefinition: aMCScriptDefinition

	"do nothing for script definitions"! !

!PSMCChangesGrouper methodsFor: 'grouping' stamp: ''!
group

	model do: [:operation | self visit: operation ].
	^ (nonClassChanges sorted: [:a :b | a item <= b item]),
		(classChanges sorted: [:a :b | a item <= b item])! !

!PSMCChangesGrouper methodsFor: 'visitor' stamp: ''!
visitDefaultDefinition: aDefinition

	nonClassChanges add: aDefinition! !

!PSMCChangesGrouper methodsFor: 'visitor' stamp: ''!
visitTraitDefinition: aMCTraitDefinition 
	
	self ensureClassChangeWrapperNamed: aMCTraitDefinition fullClassName! !

!PSMCChangesGrouper methodsFor: 'visitor' stamp: ''!
visitOrganizationDefinition: aMCOrganizationDefinition 
	
	nonClassChanges add: (currentOperation patchWrapper model: model)! !

!PSMCChangesGrouper methodsFor: 'grouping' stamp: ''!
model: aCollection 

	model := aCollection.! !

!PSMCChangesGrouper methodsFor: 'visitor' stamp: ''!
visitMethodDefinition: aMCMethodDefinition 
	
	self ensureClassChangeWrapperNamed: aMCMethodDefinition fullClassName! !

!PSMCChangesGrouper methodsFor: 'grouping' stamp: ''!
ensureClassChangeWrapperNamed: aClassName
	
	(classes includes: aClassName)
		ifFalse: [ classes add: aClassName.
				classChanges add: (PSMCClassChangeWrapper with: aClassName model: model ) ]! !

!PSMCChangesGrouper methodsFor: 'visitor' stamp: ''!
visitClassTraitDefinition: aMCClassTraitDefinition 
	
	"Do nothing for class traits (similar to #visitMetaclassDefinition:)"! !

!PSMCChangesGrouper methodsFor: 'grouping' stamp: ''!
visit: aMCOperation

	| previous |
	previous := currentOperation.
	currentOperation := aMCOperation.
	currentOperation definition accept: self.
	currentOperation := previous.! !

!PSMCChangesGrouper class methodsFor: 'helper methods' stamp: ''!
group: aCollectionOfPatches

	^ self new
		model: aCollectionOfPatches;
		group! !

!PSMCClassChangeWrapper commentStamp: ''!
Wrapper for class changes!
!PSMCClassChangeWrapper methodsFor: 'accessing' stamp: ''!
operation
	"Answer the patch operation for the class itself or nil if none."

	^ self model detect: [ :i | i targetClassName = self item and: [ i definition isClassDefinition ] ] ifNone: [ nil ]! !

!PSMCClassChangeWrapper methodsFor: 'testing' stamp: ''!
localChosen
	"Answer whether the local version is chosen."

	^self operation localChosen! !

!PSMCClassChangeWrapper methodsFor: 'choosing' stamp: ''!
chooseLocal
	"Choose the local version."

	self operation chooseLocal! !

!PSMCClassChangeWrapper methodsFor: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
remoteChosen
	"Answer whether the remote version is chosen."

	^self conflict remoteChosen! !

!PSMCClassChangeWrapper methodsFor: 'choosing' stamp: ''!
chooseRemote
	"Choose the remote version."

	self operation chooseRemote! !

!PSMCClassChangeWrapper methodsFor: 'accessing' stamp: ''!
icon
	"Answer a form with an icon to represent the receiver"

	self isConflict
		ifTrue: [ self localChosen
				ifTrue: [ ^ self iconNamed: #changeBlockIcon ] ].
	^ super icon! !

!PSMCClassChangeWrapper methodsFor: 'accessing' stamp: ''!
actualClass
	"Answer the class represented in the receiver."

	^ super actualClass ifNil: [ Smalltalk globals classNamed: self item ]! !

!PSMCClassChangeWrapper methodsFor: 'accessing' stamp: ''!
contents
	"Answer the contents of the change."

	^contents ifNil: [contents := self gatherContents]! !

!PSMCClassChangeWrapper methodsFor: 'testing' stamp: ''!
isConflict
	"Answer whether the receiver is a conflict item."

	| op |
	op := self operation.
	^ op notNil and: [op isConflict ]! !

!PSMCClassChangeWrapper methodsFor: 'choosing' stamp: ''!
clearChoice
	"Choose neither version (be in conflict)."

	self operation clearChoice! !

!PSMCMergeMorph commentStamp: ''!
A PSMCMergeMorph is a graphical tool to navigate changes and select changes in case of conflicts.!
!PSMCMergeMorph methodsFor: 'accessing' stamp: ''!
codeMorph
	"Answer the value of codeMorph"

	^ codeMorph! !

!PSMCMergeMorph methodsFor: 'instance creation' stamp: ''!
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: 'updating' stamp: ''!
update: aspect
	"A join has probably changed its selection state."

	super update: aspect.
	aspect == #compositeText
		ifTrue: [self updateCode].
	aspect == #changes
		ifTrue: [self
				changed: #conflictCountString;
				changed: #allConflictsResolved;
				changed: #notAllConflictsResolved]! !

!PSMCMergeMorph methodsFor: 'actions' stamp: ''!
toDescription: aString
	"Set the description for the right-hand side of the merge,
	typically 'incoming'."

	self patchMorph toDescription: aString! !

!PSMCMergeMorph methodsFor: 'actions' stamp: ''!
compositeText
	"Answer the composite text from the patch morph."

	^self patchMorph compositeText! !

!PSMCMergeMorph methodsFor: 'accessing' stamp: ''!
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: 'actions' stamp: ''!
selectNextConflict
	"Select the next conflict in the tree."
	
	self patchMorph selectNextConflict! !

!PSMCMergeMorph methodsFor: 'testing' stamp: ''!
notAllConflictsResolved
	"Answer whether any conflicts are unresolved."
	
	^self allConflictsResolved not! !

!PSMCMergeMorph methodsFor: 'instance creation' stamp: ''!
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: 'accessing' stamp: ''!
patchMorph
	"Answer the value of patchMorph"

	^ patchMorph! !

!PSMCMergeMorph methodsFor: 'accessing' stamp: ''!
codeMorph: anObject
	"Set the value of codeMorph"

	codeMorph := anObject! !

!PSMCMergeMorph methodsFor: 'actions' stamp: ''!
cancel
	"Delete the window to cancel."

	self window delete! !

!PSMCMergeMorph methodsFor: 'accessing' stamp: ''!
conflictCount
	"Answer the number of conflicts that are unresolved."

	^(self model ifNil: [^0]) conflicts count: [:c | c isResolved not]! !

!PSMCMergeMorph methodsFor: 'initialization' stamp: ''!
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: 'accessing' stamp: ''!
merged: anObject
	"Set the value of merged"

	merged := anObject! !

!PSMCMergeMorph methodsFor: 'accessing' stamp: ''!
defaultTitle
	"Answer the default title label for the receiver."

	^'Merge' translated! !

!PSMCMergeMorph methodsFor: 'accessing' stamp: ''!
merged
	"Answer the value of merged. Indicates whether
	the merge button was pressed with no conflicts remaining."

	^ merged! !

!PSMCMergeMorph methodsFor: 'instance creation' stamp: ''!
newPatchMorph
	"Answer a new patch morph."

	^PSMCMergePatchMorph new
		borderWidth: 0;
		addDependent: self;
		yourself! !

!PSMCMergeMorph methodsFor: 'actions' stamp: ''!
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: 'accessing' stamp: ''!
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: 'initialization' stamp: ''!
model: aMerger
	"Set the model and update the window."

	|grouped sorted|
	super model: aMerger.
	grouped := aMerger operations
		groupedBy: [: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: 'actions' stamp: ''!
fromDescription: aString
	"Set the description for the left-hand side of the merge,
	typically 'currently in image'."

	self patchMorph fromDescription: aString! !

!PSMCMergeMorph methodsFor: 'updating' stamp: ''!
updateCode
	"Update the code morph to match selected differences."

	self changed: #compositeText! !

!PSMCMergeMorph methodsFor: 'testing' stamp: ''!
allConflictsResolved
	"Answer whether all conflicts were resolved."
	
	^(self model ifNil: [^false]) isMerged! !

!PSMCMergeMorph methodsFor: 'accessing' stamp: ''!
patchMorph: anObject
	"Set the value of patchMorph"

	patchMorph := anObject! !

!PSMCMergeMorph methodsFor: 'instance creation' stamp: ''!
newCodeMorph
	"Answer a new code morph."

	^(self newTextEditorFor: self
		getText: #compositeText
		setText: #compositeText:
		getEnabled: nil)
		wrapFlag: false;
		setText: ''! !

!PSMCMergeMorph methodsFor: 'instance creation' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
forMerger: aMerger
	"Answer a new instance of the receiver
	with the given merger as the model."
	
	^ self new model: aMerger! !

!PSMCMergePatchMorph commentStamp: ''!
Display Monticello merge patchs!
!PSMCMergePatchMorph methodsFor: 'actions' stamp: ''!
keepCurrentVersion
	"Mark the conflict as local."
	
	self selectedChangeWrapper chooseLocal.
	self changed: #changes.
	self updateSource! !

!PSMCMergePatchMorph methodsFor: 'actions' stamp: ''!
markAsConflict
	"Mark the operation as unresolved conflict."
	
	self selectedChangeWrapper operation beConflict.
	self changed: #changes.
	self updateSource.! !

!PSMCMergePatchMorph methodsFor: 'updating' stamp: ''!
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: 'actions' stamp: ''!
useAllIncomingVersion
	"Mark all conflicts as remote."
	
	self allConflicts do: [:c | c chooseRemote].
	self changed: #changes.
	self updateSource! !

!PSMCMergePatchMorph methodsFor: 'actions' stamp: ''!
markAllAsConflict
	"Mark all conflicts as unresolved."
	
	self allConflicts do: [:c | c clearChoice].
	self changed: #changes.
	self updateSource! !

!PSMCMergePatchMorph methodsFor: 'hooks' stamp: ''!
diffMorphClass
	"Answer a the class to use for a new diff morph."

	^MergeDiffMorph! !

!PSMCMergePatchMorph methodsFor: 'testing' stamp: ''!
hasAnyNonConflictConflicts
	"Answer whether there are any conflicts not marked as a conflict."

	^self allConflicts anySatisfy: [:conflict |
		conflict isResolved]! !

!PSMCMergePatchMorph methodsFor: 'testing' stamp: ''!
hasAnyNonKeptConflicts
	"Answer whether there are any conflicts not marked as keep."

	^self allConflicts anySatisfy: [:conflict |
		conflict isResolved not or: [conflict remoteChosen]]! !

!PSMCMergePatchMorph methodsFor: 'testing' stamp: ''!
selectionIsRemoteChosen
	self selectedChange ifNil: [ ^ false].
	^ self selectedChange remoteChosen! !

!PSMCMergePatchMorph methodsFor: 'actions' stamp: ''!
useIncomingVersion
	"Mark the conflict as remote."
	
	self selectedChangeWrapper chooseRemote.
	self changed: #changes.
	self updateSource! !

!PSMCMergePatchMorph methodsFor: 'accessing' stamp: ''!
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 iconNamed: #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 iconNamed: #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 iconNamed: #smallCancelIcon);
		keyText: 'Shift+Cmd+x'.
	^ menu! !

!PSMCMergePatchMorph methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
allConflicts
	"Answer all conflicts in the model."

	^self model select: [:op | op isConflict]! !

!PSMCMergePatchMorph methodsFor: 'testing' stamp: ''!
hasAnyNonIncomingConflicts
	"Answer whether there are any conflicts not marked as incoming."

	^self allConflicts anySatisfy: [:conflict |
		conflict isResolved not or: [conflict localChosen]]! !

!PSMCMergePatchMorph methodsFor: 'private' stamp: ''!
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 iconNamed: #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 iconNamed: #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 iconNamed: #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 iconNamed: #smallRightFlushIcon);
		keyText: 'Cmd+f'.
	^ menu! !

!PSMCMergePatchMorph methodsFor: 'actions' stamp: ''!
keepAllCurrentVersion
	"Mark all conflicts as local."
	
	self allConflicts do: [:c | c chooseLocal].
	self changed: #changes.
	self updateSource! !

!PSMCMergePatchMorph methodsFor: 'testing' stamp: ''!
hasConflicts
	"Answer whether there are any conflicts."

	^self allConflicts notEmpty! !

!PSMCMergePatchMorph methodsFor: 'testing' stamp: ''!
notAllConflictsResolved
	"Answer whether any conflicts are unresolved."
	
	^self model anySatisfy: [:item | item isConflict and: [item isResolved not]]! !

!PSMCMergePatchMorph methodsFor: 'actions' stamp: ''!
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: 'actions' stamp: ''!
selectionIsNotNil

	^ self selectedChange notNil! !

!PSMCMergePatchMorph methodsFor: 'actions' stamp: ''!
toggleApplySelectedChange

	self selectedChange remoteChosen 
		ifTrue: [ self selectedChange chooseLocal ]
		ifFalse: [ self selectedChange chooseRemote ].
	self changed: #changes.
	self updateSource! !

!PSMCMergePatchMorph methodsFor: 'actions' stamp: ''!
nextConflict

	"Answer the next (unresolved) conflict or, nil if none."

	| coll current index |

	current := self selectedChangeWrapper.
	index := current ifNil: [ 0 ] ifNotNil: [ 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 ]! !

!PSMCOrganizationChangeWrapper commentStamp: ''!
Wrapper for changes on organization!
!PSMCPatchMorph commentStamp: ''!
I'm a Monticello tool based on polymorph used to browse diffs.
Activate me with the setting named 'Use Polymorph difference tools'.!
!PSMCPatchMorph methodsFor: 'private' stamp: ''!
removeSelection
	"unselect current selection"
	self selectedChangeWrapper: nil.
	self changed: #changes.
	self updateSource! !

!PSMCPatchMorph methodsFor: 'accessing' stamp: ''!
selectedMessageName
	"Answer the method selector or nil if no method change
	is selected.."

	^self selectionIsMethodChange
		ifTrue: [self selectedChange definition selector]
		! !

!PSMCPatchMorph methodsFor: 'updating' stamp: ''!
update: aspect
	"A join has probably changed its selection state."

	super update: aspect.
	aspect == #selectedDifferences
		ifTrue: [self changed: #compositeText]! !

!PSMCPatchMorph methodsFor: 'private' stamp: ''!
changeTreeKey: aCharacter
	"Handle change tree key strokes."

	(aCharacter == $b and: [self selectionHasActualClass]) 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: 'actions' stamp: ''!
compositeText
	"Answer the composite text based on the selection state
	of the joins."

	^self diffMorph compositeText! !

!PSMCPatchMorph methodsFor: 'private' stamp: ''!
selectionHasActualClass
	"Answer whether the currently selected change has an actual
	class in the image."

	^self selectedChangeWrapper
		ifNil: [false]
		ifNotNil: [:w | w actualClass notNil]! !

!PSMCPatchMorph methodsFor: 'accessing' stamp: ''!
changes
	"Answer the changes tree roots."
	
	^ PSMCChangesGrouper group: self model! !

!PSMCPatchMorph methodsFor: 'actions' stamp: ''!
browseImplementors
	"Browse the method implementors."

	self systemNavigation
		browseAllImplementorsOf: (self selectedMessageName ifNil: [^self])! !

!PSMCPatchMorph methodsFor: 'menus' stamp: ''!
loadMethodSelection
	"Install the selected change"
	
	self selectedChange ifNil: [ ^self ].
	self selectedChange definition load.! !

!PSMCPatchMorph methodsFor: 'accessing' stamp: ''!
changeTree
	"Answer the value of changeTree"

	^ changeTree! !

!PSMCPatchMorph methodsFor: 'initialization' stamp: ''!
model

	^ super model ifNil: [ #() ]! !

!PSMCPatchMorph methodsFor: 'accessing' stamp: ''!
selectedChangeWrapper
	"Answer the selected change."

	^selectedChangeWrapper! !

!PSMCPatchMorph methodsFor: 'private' stamp: ''!
revertSelectedChange
	"Revert the selected change"
	| change |
	change := self selectedChange.
	change ifNil: [ ^ self ].
	self revertChange: change.
	self model remove: change.
	self removeSelection.
! !

!PSMCPatchMorph methodsFor: 'private' stamp: ''!
revertChange: aChange
	"Revert the change"

	| loader |
	loader := MCPackageLoader new.
	aChange inverse applyTo: loader.
	loader loadWithName: ChangeSet current name! !

!PSMCPatchMorph methodsFor: 'instance creation' stamp: ''!
newChangeTreeMorph
	"Answer a new morph for the tree of changes."

	^(self
		newTreeFor: self
		list: #changes
		selected: #selectedChangeWrapper
		changeSelected: #selectedChangeWrapper:)
		getMenuSelector: #changesMenu:! !

!PSMCPatchMorph methodsFor: 'private' stamp: ''!
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: 'actions' stamp: ''!
browseClass
	"Browse the class of the selected item."

	^ Smalltalk tools browser
		openOnClass: self selectedChangeWrapper actualClass
		selector: self selectedMessageName! !

!PSMCPatchMorph methodsFor: 'private' stamp: ''!
updateSource

	"Update the source difference morph."

	| sel |

	sel := self selectedChange.
	sel
		ifNil: [ self diffMorph from: '' to: '' ]
		ifNotNil: [ self diffMorph
				from: sel diffFromSource
				to: sel diffToSource
				contextClass:
					( sel isClassPatch
						ifTrue: [ nil ]
						ifFalse: [ sel targetClass ] )
			]! !

!PSMCPatchMorph methodsFor: 'updating' stamp: ''!
expandChangeTree
	self flag: #TODO. "We should only expand the nodes wich have partial changes, if a class was added or removed there is no need to show the complete tree expanded"
	self changeTree expandAll.! !

!PSMCPatchMorph methodsFor: 'accessing' stamp: ''!
selectedChangeWrapper: aWrapper
	"Set the selected change."

	selectedChangeWrapper := aWrapper.
	self
		changed: #selectedChangeWrapper;
		updateSource;
		changed: #compositeText! !

!PSMCPatchMorph methodsFor: 'actions' stamp: ''!
browseSenders
	"Browse the method senders."

	self systemNavigation
		browseAllSendersOf: (self selectedMessageName ifNil: [^self])! !

!PSMCPatchMorph methodsFor: 'accessing' stamp: ''!
defaultTitle
	"Answer the default title label for the receiver."

	^'Changes' translated! !

!PSMCPatchMorph methodsFor: 'actions' stamp: ''!
browseVersions
	"Browse the method versions."

	Smalltalk tools versionBrowser 
			browseVersionsForClass: self selectedChangeWrapper actualClass 
			selector: self selectedMessageName
			! !

!PSMCPatchMorph methodsFor: 'protocol' stamp: ''!
changesMenu: m
	"Answer the changes menu."

	| menu |
	menu := self newMenu
		addTitle: 'Changes'
		icon: (self iconNamed: #smallCopyIcon).
	menu
		addToggle: 'Browse class...' translated
		target: self
		selector: #browseClass
		getStateSelector: nil
		enablementSelector: #selectionHasActualClass.
	menu lastItem
		font: self theme menuFont;
		icon: (self iconNamed: #smallWindowIcon);
		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 iconNamed: #smallJustifiedIcon);
		keyText: 'Cmd+v'.
	menu
		addToggle: 'Senders...' translated
		target: self
		selector: #browseSenders
		getStateSelector: nil
		enablementSelector: #selectionIsMethodChange.
	menu lastItem
		font: self theme menuFont;
		icon: (self iconNamed: #smallForwardIcon);
		keyText: 'Cmd+n'.
	menu
		addToggle: 'Implementors...' translated
		target: self
		selector: #browseImplementors
		getStateSelector: nil
		enablementSelector: #selectionIsMethodChange.
	menu lastItem
		font: self theme menuFont;
		icon: (self iconNamed: #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 iconNamed: #smallUpdateIcon).
	menu
		addToggle: 'Revert change' translated
		target: self
		selector: #revertSelectedChange
		getStateSelector: nil.
	menu lastItem
		font: self theme menuFont;
		icon: (self iconNamed: #smallCancelIcon).
	menu
		add: 'Expand All' translated
		target: self model
		selector: #expandAll.
	menu
		add: 'Collapse All' translated
		target: self model
		selector: #collapseAll.
	^ menu! !

!PSMCPatchMorph methodsFor: 'initialization' stamp: ''!
buildUI
	|descriptionHeight|
	self
		diffMorph: self newDiffMorph;
		changeTree: self newChangeTreeMorph;
		descriptionMorph: self newDescriptionMorph.
	descriptionHeight := self descriptionMorph minExtent y.
	self
		changeProportionalLayout;
		addMorph: self descriptionMorph
		fullFrame: ((0@0 corner: 1@0) asLayoutFrame leftOffset: ProportionalSplitterMorph splitterWidth; bottomOffset: descriptionHeight);
		addMorph: self changeTree
		fullFrame: ((0@0 corner: 0.3@1) asLayoutFrame topLeftOffset: ProportionalSplitterMorph splitterWidth @ descriptionHeight);
		addMorph: self diffMorph
		fullFrame: ((0.3@0 corner: 1@1) asLayoutFrame topLeftOffset: ProportionalSplitterMorph splitterWidth @ descriptionHeight);
		addPaneSplitters.
	self updateDescriptionFillStyle: self paneColor.
	self onAnnouncement: MorphOpened do: [ self expandChangeTree ]
! !

!PSMCPatchMorph methodsFor: 'initialization' stamp: ''!
model: aCollection
	"Set the model and update the window."

	super model: aCollection.
	self changed: #changes! !

!PSMCPatchMorph methodsFor: 'accessing' stamp: ''!
selectedChange
	"Answer the selected change."

	^(self selectedChangeWrapper ifNil: [^nil]) operation! !

!PSMCPatchMorph methodsFor: 'accessing' stamp: ''!
changeTree: anObject
	"Set the value of changeTree"

	changeTree := anObject! !

!PSMCPatchMorph class methodsFor: 'instance creation' stamp: ''!
forPatch: aPatch
	"Answer a new instance of the receiver
	with the given patch as the model."
	
	^ self new model: aPatch operations! !

!PSMCPatchMorph class methodsFor: 'settings' stamp: ''!
defaultDiffToolsSettingOn: aBuilder
	<systemsettings>  
	(aBuilder setting: #polymorphDiffToolsUsedByDefault)
		label: 'Use Polymorph difference tools';
		default: true;
		description: 'When enabled the Polymorph diff tools will be used with Monticello. When disabled, the original tools are used.';
		parent: #differator;
		target: PSMCPatchMorph;
		selector: #usedByDefault! !

!PSMCPatchMorph class methodsFor: 'settings' stamp: ''!
usedByDefault
	"Answer whether the Polymorph diff tools should be used with Monticello."

	^UsedByDefault ifNil: [UsedByDefault := true]! !

!PSMCPatchMorph class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallForwardIcon! !

!PSMCPatchMorph class methodsFor: 'settings' stamp: ''!
usedByDefault: aBoolean
	"Specify whether the Polymorph diff tools should be used with Monticello."
	
	UsedByDefault := aBoolean! !

!PSMCPatchOperationWrapper commentStamp: ''!
Wrapper for patch operations!
!PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: ''!
operation
	"Answer the pacth operation for the receiver or nil if none."

	^self item! !

!PSMCPatchOperationWrapper methodsFor: 'testing' stamp: ''!
localChosen
	"Answer whether the local version is chosen."

	^self operation localChosen! !

!PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: ''!
chooseLocal
	"Choose the local version."

	self operation chooseLocal! !

!PSMCPatchOperationWrapper methodsFor: 'testing' stamp: ''!
remoteChosen
	"Answer whether the remote version is chosen."

	^self operation remoteChosen! !

!PSMCPatchOperationWrapper methodsFor: 'converting' stamp: ''!
asString
	"Answer the method name."
	
	^self item definition summary! !

!PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: ''!
chooseRemote
	"Choose the remote version."

	self operation chooseRemote! !

!PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: ''!
icon
	"Answer a form with an icon to represent the receiver"

	self item localChosen
		ifTrue: [ ^ self iconNamed: #changeBlockIcon ].
	^ super icon! !

!PSMCPatchOperationWrapper methodsFor: 'testing' stamp: ''!
isConflict
	"Answer whether the receiver is a conflict item."

	^ self operation isConflict! !

!PSMCPatchOperationWrapper methodsFor: 'testing' stamp: ''!
clearChoice
	"Choose neither version (be in conflict)."

	self operation clearChoice! !

!PaAbstractExampleTest commentStamp: ''!
Testing class!
!PaAbstractExampleTest methodsFor: 'accessing' stamp: ''!
option1
	^ option1! !

!PaAbstractExampleTest methodsFor: 'accessing' stamp: ''!
option2: anInteger 
	option2 := anInteger! !

!PaAbstractExampleTest methodsFor: 'accessing' stamp: ''!
option2
	^ option2! !

!PaAbstractExampleTest methodsFor: 'accessing' stamp: ''!
option1: aString 
	option1 := aString! !

!PaAbstractExampleTest methodsFor: 'tests' stamp: ''!
testParametersHaveValue
	self assert: option1 isNotNil.
	self assert: option2 isNotNil.! !

!PaAbstractExampleTest class methodsFor: 'private' stamp: ''!
isAbstract
	^ self name = #PaAbstractExampleTest! !

!PaCasesMatrixTest commentStamp: ''!
Testing class!
!PaCasesMatrixTest class methodsFor: 'private' stamp: ''!
testParameters

	^ ParametrizedTestMatrix new
		addCase: { #option1 -> 'a'. #option2 -> 1};
		addCase: { #option1 -> 'b'. #option2 -> 2};		
		addCase: { #option1 -> 'c'. #option2 -> 3};		
		yourself.! !

!PaCombinedMatrixExampleTest commentStamp: ''!
Testing class!
!PaCombinedMatrixExampleTest methodsFor: 'accessing' stamp: ''!
option3
	^ option3! !

!PaCombinedMatrixExampleTest methodsFor: 'accessing' stamp: ''!
option3: aString 
	option3 := aString! !

!PaCombinedMatrixExampleTest class methodsFor: 'building suites' stamp: ''!
testParameters

	^ ParametrizedTestMatrix new
		addCase: { #option1 -> 'a'. #option2 -> 1};
		addCase: { #option1 -> 'b'. #option2 -> 2};		
		addCase: { #option1 -> 'c'. #option2 -> 3};		
		forSelector: #option3 addOptions: #(a b);
		yourself.! !

!PaMatrix3ExampleTest commentStamp: ''!
Testing class!
!PaMatrix3ExampleTest methodsFor: 'accessing' stamp: ''!
option3
	^ option3! !

!PaMatrix3ExampleTest methodsFor: 'accessing' stamp: ''!
option3: anObject
	option3 := anObject! !

!PaMatrix3ExampleTest class methodsFor: 'private' stamp: ''!
testParameters

	^ ParametrizedTestMatrix new
		forSelector: #option1 addOptions: #(a b c);
		forSelector: #option2 addOptions: {[1].[2].[3]};
		forSelector: #option3 addOptions: #(x y z);
		yourself.! !

!PaMatrixExampleTest commentStamp: ''!
Testing class!
!PaMatrixExampleTest class methodsFor: 'private' stamp: ''!
testParameters

	^ ParametrizedTestMatrix new
		forSelector: #option1 addOptions: #(a b c);
		forSelector: #option2 addOptions: {[1].[2].[3]};
		yourself.! !

!PaSelectedCasesExampleTest commentStamp: ''!
This simple example generates 2 cases. Exactly the 2 cases listed in `PaSelectedCasesExampleTest class >>#testParameters` class method.



```
PaSelectedCasesExampleTest class >> testParameters
	^ ParametrizedTestMatrix new
		addCase: { #number1 -> 2. #number2 -> 1.0. #result -> 3 };
		addCase: { #number1 -> (2/3). #number2 -> (1/3). #result -> 1 };
		yourself
```!
!PaSelectedCasesExampleTest methodsFor: 'accessing' stamp: ''!
number1
	^ number1! !

!PaSelectedCasesExampleTest methodsFor: 'accessing' stamp: ''!
number1: anObject
	number1 := anObject! !

!PaSelectedCasesExampleTest methodsFor: 'accessing' stamp: ''!
number2: anObject
	number2 := anObject! !

!PaSelectedCasesExampleTest methodsFor: 'accessing' stamp: ''!
result
	^ result! !

!PaSelectedCasesExampleTest methodsFor: 'accessing' stamp: ''!
result: anObject
	result := anObject! !

!PaSelectedCasesExampleTest methodsFor: 'accessing' stamp: ''!
number2
	^ number2! !

!PaSelectedCasesExampleTest methodsFor: 'tests' stamp: ''!
testSum
	
	self assert: number1 + number2 equals: result! !

!PaSelectedCasesExampleTest class methodsFor: 'building suites' stamp: ''!
testParameters

	^ ParametrizedTestMatrix new
		addCase: { #number1 -> 2. #number2 -> 1.0. #result -> 3 };
		addCase: { #number1 -> (2/3). #number2 -> (1/3). #result -> 1 };
		yourself! !

!PaSimpleMatrixExampleTest commentStamp: ''!
This test executes 81 different cases. 
All the combinations in the matrix for the `item1`, `item2` and `collectionClass` parameters.

```
PaSimpleMatrixExampleTest class >> testParameters

	^ ParametrizedTestMatrix new
		forSelector: #item1 addOptions: { 1. 'a'. $c };
		forSelector: #item2 addOptions: { 2. 'b'. $d };
		forSelector: #collectionClass addOptions: 	{ Set. Bag. OrderedCollection }
```			
!
!PaSimpleMatrixExampleTest methodsFor: 'accessing' stamp: ''!
item1
	^ item1! !

!PaSimpleMatrixExampleTest methodsFor: 'accessing' stamp: ''!
testIncludes
	
	| aCollection |
	aCollection := collectionClass new.
	aCollection add: item1.
	aCollection add: item2.
	
	self assert: (aCollection includes: item1).
	self assert: (aCollection includes: item2).! !

!PaSimpleMatrixExampleTest methodsFor: 'accessing' stamp: ''!
item2
	^ item2! !

!PaSimpleMatrixExampleTest methodsFor: 'accessing' stamp: ''!
testAddAndRemove
	
	| aCollection |
	aCollection := collectionClass new.
	aCollection add: item1.
	aCollection add: item2.
	
	self assert: (aCollection includes: item1).
	self assert: aCollection size equals: 2.

	aCollection remove: item1.
	
	self deny: (aCollection includes: item1).
	self assert: aCollection size equals: 1.! !

!PaSimpleMatrixExampleTest methodsFor: 'accessing' stamp: ''!
item1: anObject
	item1 := anObject! !

!PaSimpleMatrixExampleTest methodsFor: 'accessing' stamp: ''!
testAdd
	
	| aCollection |
	aCollection := collectionClass new.
	aCollection add: item1.
	
	self assert: (aCollection includes: item1).
	self assert: aCollection size equals: 1.! !

!PaSimpleMatrixExampleTest methodsFor: 'accessing' stamp: ''!
collectionClass
	^ collectionClass! !

!PaSimpleMatrixExampleTest methodsFor: 'accessing' stamp: ''!
item2: anObject
	item2 := anObject! !

!PaSimpleMatrixExampleTest methodsFor: 'accessing' stamp: ''!
collectionClass: anObject
	collectionClass := anObject! !

!PaSimpleMatrixExampleTest class methodsFor: 'building suites' stamp: ''!
testParameters

	^ ParametrizedTestMatrix new
		forSelector: #item1 addOptions: { 1. 'a'. $c };
		forSelector: #item2 addOptions: { 2. 'b'. $d };
		forSelector: #collectionClass addOptions: 	{ Set. Bag. OrderedCollection }! !

!PaSuiteTest commentStamp: ''!
Test case to check that the cases are correctly generated!
!PaSuiteTest methodsFor: 'tests' stamp: ''!
testCombinedHasTheCorrectNumberOfTests

	| suite |
	suite := PaCombinedMatrixExampleTest buildSuite.
	self assert: suite tests size equals: 6! !

!PaSuiteTest methodsFor: 'tests' stamp: ''!
testMultiplyMatrixWithOptionsAndCasesMultiplyCases

	| m1 m2 m3 |
	m1 := ParametrizedTestMatrix new.
	m1 forSelector: #option1 addOptions: #(a b).
	
	m2 := ParametrizedTestMatrix new.
	m2 addCase: { #option3 -> #a . #option4 -> #a }.
	m2 addCase: { #option3 -> #b . #option4 -> #c }.
	
	m3 := m1 * m2.
	
	self assert: m3 equals: {
		{ #option1 -> #a. #option3 -> #a. #option4 -> #a  }.
		{ #option1 -> #a. #option3 -> #b. #option4 -> #c  }.
		{ #option1 -> #b. #option3 -> #a. #option4 -> #a  }.
		{ #option1 -> #b. #option3 -> #b. #option4 -> #c  }.
	} asTestMatrix.! !

!PaSuiteTest methodsFor: 'tests' stamp: ''!
testMatrixExampleHasTheCorrectTests

	| suite |
	suite := PaMatrixExampleTest buildSuite.
	suite tests do: [:each | each setUp].
	self 
		assertCollection: (suite tests collect: [:each | { each option1. each option2. } ] ) 
		hasSameElements: { 
			{ 'a'. 1}. { 'a'. 2}. { 'a'. 3}.
			{ 'b'. 1}. { 'b'. 2}. { 'b'. 3}.
			{ 'c'. 1}. { 'c'. 2}. { 'c'. 3}.}! !

!PaSuiteTest methodsFor: 'tests' stamp: ''!
testCombinedHasTheCorrectTests

	| suite |
	suite := PaCombinedMatrixExampleTest buildSuite.
	suite tests do: [:each | each setUp].
	self 
		assertCollection: (suite tests collect: [:each | {each option1. each option2. each option3}]) 
		hasSameElements: {	 { 'a'. 1. 'a'}. { 'a'. 1. 'b'}. 
								 { 'b'. 2. 'a'}. { 'b'. 2. 'b'}. 
	 							 { 'c'. 3. 'a'}. { 'c'. 3. 'b'}. }.! !

!PaSuiteTest methodsFor: 'tests' stamp: ''!
testMultiplyMatrixWithCasesMultiplyCases

	| m1 m2 m3 |
	m1 := ParametrizedTestMatrix new.
	m1 addCase: { #option1 -> #a . #option2 -> #a }.
	m1 addCase: { #option1 -> #b . #option2 -> #c }.
	
	m2 := ParametrizedTestMatrix new.
	m2 addCase: { #option3 -> #a . #option4 -> #a }.
	m2 addCase: { #option3 -> #b . #option4 -> #c }.
	
	m3 := m1 * m2.
	
	self assert: m3 equals: {
		{ #option1 -> #a. #option2 -> #a. #option3 -> #a. #option4 -> #a  }.
		{ #option1 -> #a. #option2 -> #a. #option3 -> #b. #option4 -> #c  }.
		{ #option1 -> #b. #option2 -> #c. #option3 -> #a. #option4 -> #a  }.
		{ #option1 -> #b. #option2 -> #c. #option3 -> #b. #option4 -> #c  }.
	} asTestMatrix.! !

!PaSuiteTest methodsFor: 'tests' stamp: ''!
testMatrix3ExampleHasTheCorrectNumberOfTests

	| suite |
	suite := PaMatrix3ExampleTest buildSuite.
	self assert: suite tests size equals: 27! !

!PaSuiteTest methodsFor: 'tests' stamp: ''!
testMatrixExampleHasTheCorrectNumberOfTests

	| suite |
	suite := PaMatrixExampleTest buildSuite.
	self assert: suite tests size equals: 9! !

!PaSuiteTest methodsFor: 'tests' stamp: ''!
testMatrix3ExampleHasTheCorrectTests

	| suite |
	suite := PaMatrix3ExampleTest buildSuite.
	suite tests do: [:each | each setUp].
	self 
		assertCollection: (suite tests collect: [:each | { each option1. each option2. each option3.} ] ) 
		hasSameElements: { 
			{ 'a'. 1. 'x'}. { 'a'. 2. 'x'}. { 'a'. 3. 'x'}.
			{ 'a'. 1. 'y'}. { 'a'. 2. 'y'}. { 'a'. 3. 'y'}.
			{ 'a'. 1. 'z'}. { 'a'. 2. 'z'}. { 'a'. 3. 'z'}.

			{ 'b'. 1. 'x'}. { 'b'. 2. 'x'}. { 'b'. 3. 'x'}.
			{ 'b'. 1. 'y'}. { 'b'. 2. 'y'}. { 'b'. 3. 'y'}.
			{ 'b'. 1. 'z'}. { 'b'. 2. 'z'}. { 'b'. 3. 'z'}.

			{ 'c'. 1. 'x'}. { 'c'. 2. 'x'}. { 'c'. 3. 'x'}.
			{ 'c'. 1. 'y'}. { 'c'. 2. 'y'}. { 'c'. 3. 'y'}.
			{ 'c'. 1. 'z'}. { 'c'. 2. 'z'}. { 'c'. 3. 'z'}.
		}! !

!PaSuiteTest methodsFor: 'tests' stamp: ''!
testCasesHasTheCorrectTests

	| suite |
	suite := PaCasesMatrixTest buildSuite.
	"I run the setup to set the parametrized values in the test case"
	suite tests do: [:each | each setUp].
	self 
		assertCollection: (suite tests collect: [ :each | {each option1. each option2} ])
		hasSameElements: { { 'a'. 1 }. { 'b'. 2 }. { 'c'. 3 } }! !

!PaSuiteTest methodsFor: 'tests' stamp: ''!
testCasesHasTheCorrectNumberOfTests

	| suite |
	suite := PaCasesMatrixTest buildSuite.
	self assert: suite tests size equals: 3! !

!PaSuiteTest methodsFor: 'tests' stamp: ''!
testMultiplyMatrixWithOptionsMultiplyCases

	| m1 m2 m3 |
	m1 := ParametrizedTestMatrix new.
	m1 forSelector: #option1 addOptions: #(a b).
	
	m2 := ParametrizedTestMatrix new.
	m2 forSelector: #option2 addOptions: #(a b).
	
	m3 := m1 * m2.
	
	self assert: m3 equals: {
		{ #option1 -> #a. #option2 -> #a }.
		{ #option1 -> #a. #option2 -> #b }.
		{ #option1 -> #b. #option2 -> #a }.
		{ #option1 -> #b. #option2 -> #b }.
	} asTestMatrix.! !

!PackageAPIHelpBuilder commentStamp: ''!
A builder for the API of the various packages!
!PackageAPIHelpBuilder methodsFor: 'building' stamp: ''!
build 
	| packageTopic |
	topicToBuild := (HelpTopic named: rootToBuildFrom bookName).
	rootToBuildFrom helpPackages do: [:package|
		packageTopic := HelpTopic named: package.
		topicToBuild addSubtopic: packageTopic.
		self class buildPackageTopic: packageTopic ]! !

!PackageAPIHelpBuilder class methodsFor: 'private - utilities' stamp: ''!
buildPackageTopic: packageTopic
 
	| classTopic classes |
	classes := (RPackageSet named: packageTopic title) classes 
		asSortedCollection: [:class1 :class2 | class1 name < class2 name].
	classes do: [ :aClass | 
		classTopic := ClassAPIHelpBuilder 
			buildHierarchicalHelpTopicFrom: aClass 
			withSubclasses: false 
			withMethods: true.
		packageTopic addSubtopic: classTopic ]! !

!PackageAbstractNodeExample commentStamp: ''!
Example for abstract package nodes!
!PackageAbstractNodeExample methodsFor: 'accessing' stamp: ''!
exploreItem
	self inspect! !

!PackageAbstractNodeExample methodsFor: 'accessing' stamp: ''!
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: ''!
menu: menu shifted: b 
	menu
		add: 'Expand all' 
		target: self
		selector: #expandAll.
	menu
		add: 'Browse (b)' 
		target: self
		selector: #browseItem.
	menu
		add: 'Inspect (i)' 
		target: self
		selector: #inspectItem.
	menu
		add: 'Explore (I)' 
		target: self
		selector: #exploreItem.! !

!PackageAbstractNodeExample methodsFor: 'accessing' stamp: ''!
doubleClick
	self browseItem! !

!PackageAbstractNodeExample methodsFor: 'menu' stamp: ''!
contents
	^ contents ifNil: [contents := super contents]! !

!PackageAbstractNodeExample methodsFor: 'accessing' stamp: ''!
browseItem! !

!PackageAbstractNodeExample methodsFor: 'accessing' stamp: ''!
inspectItem
	self inspect! !

!PackageClassNodeExample commentStamp: ''!
Example for a package class node!
!PackageClassNodeExample methodsFor: 'menu' stamp: ''!
childNodeClassFromItem: anItem
	^PackageMethodCategoryNodeExample! !

!PackageClassNodeExample methodsFor: 'menu' stamp: ''!
methodsInCategory: aCat
	^ self item  selectorsInProtocol: aCat! !

!PackageClassNodeExample methodsFor: 'menu' stamp: ''!
childrenItems
	^ self item organization categories! !

!PackageClassNodeExample methodsFor: 'accessing' stamp: ''!
browseItem
	Smalltalk tools browser openOnClass: self item! !

!PackageManifest commentStamp: ''!
I store meta-data for a package. I'm the common superclass of all package Manifest.!
!PackageManifest class methodsFor: 'code-critics' stamp: ''!
rejectRules
	^ #()! !

!PackageManifest class methodsFor: 'accessing - comment' stamp: ''!
classCommentBlank

	^'No description for this package available. Please add a description for this package here'! !

!PackageManifest class methodsFor: 'meta-data' stamp: ''!
description
	^ 'No description for this package manifest available. Please add a description for this package here.'! !

!PackageManifest class methodsFor: 'unloading' stamp: ''!
preUnload

	"override this method to specify clean-up actions that should be done before package unloading."! !

!PackageManifest class methodsFor: 'meta-data - dependency analyser' stamp: ''!
ignoredDependencies
	^ #(#'System-Settings-Core')! !

!PackageManifest class methodsFor: 'testing' stamp: ''!
isManifest
	^ (self = PackageManifest) not! !

!PackageManifest class methodsFor: 'System-Support' stamp: ''!
isUsed
	^ true! !

!PackageManifest class methodsFor: 'code-critics' stamp: ''!
rejectClasses
	^ #()! !

!PackageManifest class methodsFor: 'meta-data - dependency analyser' stamp: ''!
manuallyResolvedDependencies
	^ #()! !

!PackageManifest class methodsFor: '*Renraku' stamp: ''!
forcedRules

	"override this method and return all the rule names that have to be applied to your package despite global bans"

	^ #()! !

!PackageManifest class methodsFor: 'unloading' stamp: ''!
postUnloadAction

	"override to return block that will be executed after the package unloading. Keep in mind that all package classes are already removed from the system including the manifest class"
	
	^ [ "do nothing" ]! !

!PackageManifest class methodsFor: 'deprecation' stamp: ''!
isDeprecated
	^ false! !

!PackageMethodCategoryNodeExample commentStamp: ''!
Example for a package method node!
!PackageMethodCategoryNodeExample methodsFor: 'accessing' stamp: ''!
childNodeClassFromItem: anItem
	^ PackageMethodNodeExample! !

!PackageMethodCategoryNodeExample methodsFor: 'accessing' stamp: ''!
childrenItems
	^ self parentNode item selectorsInProtocol: self item! !

!PackageMethodNodeExample commentStamp: ''!
Example for a package method node!
!PackageMethodNodeExample methodsFor: 'accessing' stamp: ''!
selector
	^ self item! !

!PackageMethodNodeExample methodsFor: 'private' stamp: ''!
itemClass
	^ self parentNode parentNode item.! !

!PackageMethodNodeExample methodsFor: 'results' stamp: ''!
compiledMethod
	^ self itemClass
		compiledMethodAt: self selector
		ifAbsent: [self itemClass class
				compiledMethodAt: self selector
				ifAbsent: []]! !

!PackageMethodNodeExample methodsFor: 'accessing' stamp: ''!
browseItem
	Smalltalk tools browser openOnClass: self itemClass  selector: self selector! !

!PackageNodeExample commentStamp: ''!
Example for a pakage node!
!PackageNodeExample methodsFor: 'accessing' stamp: ''!
childNodeClassFromItem: anItem
	^  PackageClassNodeExample! !

!PackageNodeExample methodsFor: 'accessing' stamp: ''!
asString
	^ self item packageName! !

!PackageNodeExample methodsFor: 'accessing' stamp: ''!
childrenItems
	^ self item classes! !

!PackageTreeExample commentStamp: ''!
PackageTreeExample new open!
!PackageTreeExample methodsFor: 'showing' stamp: ''!
open
	^ self openDialogWindowIn: self currentWorld title: 'Packages'.! !

!PackageTreeExample methodsFor: 'view' stamp: ''!
defaultTreeMorph
	^ super defaultTreeMorph
			doubleClickSelector: #doubleClick;
			nodeStringGetter: #asString;
			getMenuSelector: #menu:shifted:.! !

!PackageTreeExample methodsFor: 'accessing' stamp: ''!
keyStroke: anEvent from: aTreeMorph 
	self selectedNode
		ifNotNil: [:current | current keyStroke: anEvent from: aTreeMorph]! !

!PackageTreeExample methodsFor: 'accessing' stamp: ''!
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: 'event handling' stamp: ''!
doubleClick
	self selectedNode ifNotNil: [:n | n doubleClick]! !

!PackageTreeExample methodsFor: 'accessing' stamp: ''!
rootNodeClassFromItem: anItem
	^ PackageNodeExample! !

!PackageTreeExample methodsFor: 'accessing' stamp: ''!
rootItems
	^ RPackageOrganizer default packages! !

!PackageTreeExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>

	^PackageTreeExample new open! !

!PaginatedMorphTreeModel commentStamp: ''!
A morphic based tree model with pagination!
!PaginatedMorphTreeModel methodsFor: 'accessing' stamp: ''!
treeMorphClass
	^ PaginatedMorphTreeMorph! !

!PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: ''!
chunkSize
	^ pageSize! !

!PaginatedMorphTreeModel methodsFor: 'accessing' stamp: ''!
pageSize: anIntegerOrNil
	self setPageSize: anIntegerOrNil.
	self announce: (MorphTreeChangeRequest pageSize: anIntegerOrNil)! !

!PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: ''!
pageSize
	^ pageSize! !

!PaginatedMorphTreeModel methodsFor: 'accessing' stamp: ''!
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: 'pager managing' stamp: ''!
setPageSize: anIntegerOrNil
	pageSize := anIntegerOrNil.! !

!PaginatedMorphTreeModel methodsFor: 'accessing' stamp: ''!
chunkSize: anIntegerOrNil
	self setPageSize: anIntegerOrNil.
	self announce: (MorphTreeChangeRequest chunkSize: anIntegerOrNil)! !

!PaginatedMorphTreeModel class methodsFor: 'examples' stamp: ''!
example
	"This test demonstrate a paginating morphTreeMorph in action."

	"self example."

	| treeMorph aWindow aModel |
	aModel := self itemsList: (1 to: 100) asArray.
	aWindow := aModel theme newWindowIn: self for: aModel title: 'Example'.
	treeMorph := aModel defaultTreeMorph.
	treeMorph pageSize: 30.
	treeMorph buildContents.
	aWindow addMorph: treeMorph fullFrame: LayoutFrame identity.
	aWindow open.
	aModel expandItemPath: {40}.
	self assert: treeMorph pager currentPage == 2! !

!PaginatedMorphTreeMorph commentStamp: ''!
A paginated tree morph!
!PaginatedMorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''!
expandItemPath: anItemPath
	| rest |
	rest := anItemPath asOrderedCollection.
	[ rest notEmpty ]
		whileTrue: [ 
			| res |
			res := (1 to: self nodeList size) select: [ :li | (self nodeList at: li) item = rest first ].
			res isEmpty
				ifTrue: [ ^ self ].
			self pager nextPage: res first.
			(self allNodeMorphs at: 1 ifAbsent: [ ^ self ]) openItemPath: {(rest first)}.
			rest := rest copyWithoutFirst ].
	^ self! !

!PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: ''!
pagerHeight
	^ self pager
		ifNil: [0]
		ifNotNil: [pager computedHeight]! !

!PaginatedMorphTreeMorph methodsFor: 'geometry' stamp: ''!
hResizeScrollBar
	super hResizeScrollBar.
	hScrollBar bounds: ((hScrollBar bounds withTop: (hScrollBar top - self pagerHeight)) withBottom: (hScrollBar bottom - self pagerHeight))! !

!PaginatedMorphTreeMorph methodsFor: 'geometry' stamp: ''!
innerBounds
	| inner |
	inner := super innerBounds.
	inner := inner withBottom: inner bottom - self pagerHeight.
	^ inner! !

!PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: ''!
updatePager
	self pager
		ifNotNil: [self pager buildPanel]! !

!PaginatedMorphTreeMorph methodsFor: 'scrolling' stamp: ''!
vScrollBarValue: scrollValue
	super vScrollBarValue: scrollValue.
	self pager ifNotNil: [:p | p vScrollBarValue: scrollValue]! !

!PaginatedMorphTreeMorph methodsFor: 'updating' stamp: ''!
buildContents
	super buildContents.
	self updatePager! !

!PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: ''!
pageSize: aPageSize 
	self pager
		ifNil: [aPageSize ifNotNil: [self addNavigationPane: (TreePagerMorph on: self pageSize: aPageSize)]]
		ifNotNil: [aPageSize 
			ifNil: [self removePager]
			ifNotNil: [self pager changePageSize: aPageSize]]! !

!PaginatedMorphTreeMorph methodsFor: 'updating' stamp: ''!
updateContentsWithPreviouslyExpanded: aNodeList
	super updateContentsWithPreviouslyExpanded: aNodeList.
	self updatePager! !

!PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: ''!
pager
	^ pager! !

!PaginatedMorphTreeMorph methodsFor: 'geometry' stamp: ''!
vScrollBarHeight
	^ super vScrollBarHeight - self pagerHeight! !

!PaginatedMorphTreeMorph methodsFor: 'accessing - colors' stamp: ''!
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: 'accessing' stamp: ''!
currentNodelist
	"The nodeList currently viewed (not the full node list if a pager is used)"
	^ self pager
		ifNil: [super nodeList]
		ifNotNil: [self pager currentNodelist]! !

!PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: ''!
pagerColor
	^ self color darker alpha: 0.6! !

!PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: ''!
removePager
	self pager ifNotNil: [
		self removeMorph: self pager.
		pager := nil.
		self updateList.
		self resizerChanged].! !

!PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: ''!
chunkSize: aPageSize 
	self pager
		ifNil: [aPageSize ifNotNil: [self addNavigationPane: (TreeChunkPagerMorph on: self pageSize: aPageSize)]]
		ifNotNil: [aPageSize 
			ifNil: [self removePager]
			ifNotNil: [self pager changePageSize: aPageSize]]! !

!PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: ''!
addNavigationPane: aNavigPane
	pager := aNavigPane.
	self addMorph: pager.
	pager buildPanel.
	self updatePager.
	self changed! !

!PaginatedMorphTreeMorph methodsFor: 'geometry' stamp: ''!
extent: newExtent
	self extent = newExtent ifTrue: [^ self].
	super extent: newExtent.
	self updatePager.! !

!PaginatedMorphTreeMorphTest methodsFor: 'tests' stamp: ''!
testPager
	"This test demonstrate a paginating morphTreeMorph in action."

	| treeMorph aWindow aModel |
	aModel := PaginatedMorphTreeModel itemsList: (1 to: 100) asArray.
	aWindow := aModel theme newWindowIn: self for: aModel title: 'test'.
	treeMorph := aModel defaultTreeMorph.
	treeMorph pageSize: 30.
	treeMorph buildContents.
	aWindow addMorph: treeMorph fullFrame: LayoutFrame identity.
	aWindow open.
	aModel expandItemPath: {40}.
	self assert: treeMorph pager currentPage identicalTo: 2.
	aWindow close! !

!PaneScrolling commentStamp: ''!
I am an announcement raised when a scroll pane is scrolled.

My two attributes are
	- step: a point representing the scrollbar movement
	- scrollPane: a pointer to the widget raising the announcement!
!PaneScrolling methodsFor: 'accessing' stamp: ''!
step
	^ step! !

!PaneScrolling methodsFor: 'accessing' stamp: ''!
scrollPane
	^ scrollPane! !

!PaneScrolling methodsFor: 'accessing' stamp: ''!
scrollPane: anObject
	scrollPane := anObject! !

!PaneScrolling methodsFor: 'accessing' stamp: ''!
step: anObject
	step := anObject! !

!PanelMorph commentStamp: ''!
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: 'protocol' stamp: ''!
checkMorphsRightOrBottomFrom: splitter
	| index |
	
	index := submorphs identityIndexOf: splitter.
	index := index - 1.
	
	[ index > 0 ] whileTrue: [ | submorph done |
		submorph := submorphs at: index.
		splitter addRightOrBottom: submorph.
		done := self isResizeableMorph: submorph forSplitter: splitter.
		done ifTrue: [ index := 0 ].
		index := index - 1 ]! !

!PanelMorph methodsFor: 'protocol' stamp: ''!
newVSplitter

	^ ProportionalSplitterMorph new
			setProperty: #model toValue: self.! !

!PanelMorph methodsFor: 'protocol' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		clipSubmorphs: true;
		beSticky "stop being grabbed"! !

!PanelMorph methodsFor: 'protocol' stamp: ''!
checkMorphsLeftOrTopFrom: splitter size: size
	| index |
	
	index := submorphs identityIndexOf: splitter.
	
	index := index + 1.
	
	[ index <= size ] whileTrue: [ 
		| submorph done |
		submorph := submorphs at: index.
		splitter addLeftOrTop: submorph.
		done := self isResizeableMorph: submorph forSplitter: splitter.
		done
			ifTrue: [ index := size + 1 ].
		index := index + 1 ]! !

!PanelMorph methodsFor: 'protocol' stamp: ''!
newHSplitter

	^ ProportionalSplitterMorph new
			beSplitsTopAndBottom;
			setProperty: #model toValue: self.! !

!PanelMorph methodsFor: 'protocol' stamp: ''!
interactionState: aSymbol
	"Pass on to submorphs."

	self submorphsDo: [:m |
		(m respondsTo: #interactionState:) ifTrue: [
			m interactionState: aSymbol]]! !

!PanelMorph methodsFor: 'protocol' stamp: ''!
checkMorphsLeftOrTopFrom: splitter
	| index size |
	
	size := submorphs size.
	index := submorphs identityIndexOf: splitter.
	
	index := index + 1.
	
	[ index <= size ] whileTrue: [ 
		| submorph done |
		submorph := submorphs at: index.
		splitter addLeftOrTop: submorph.
		done := self isResizeableMorph: submorph forSplitter: splitter.
		done
			ifTrue: [ index := size + 1 ].
		index := index + 1 ]! !

!PanelMorph methodsFor: 'events-processing' stamp: ''!
handleMouseOver: anEvent
	"System level event handling."
	
	super handleMouseOver: anEvent.
	(self handlesMouseOver: anEvent) ifTrue:[
		anEvent wasHandled: true.
		self mouseOver: anEvent]! !

!PanelMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	"Answer the default border width for the receiver."
	
	^0! !

!PanelMorph methodsFor: 'protocol' stamp: ''!
isResizeableMorph: submorph forSplitter: e
	| done |
	done := e splitsTopAndBottom
		ifTrue: [ submorph layoutFrame isVerticallyResizeable ]
		ifFalse: [ submorph layoutFrame isHorizontallyResizeable ].
	^ done! !

!PanelMorph methodsFor: 'accessing' stamp: ''!
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: 'protocol' stamp: ''!
mouseOver: anEvent
	"Handle a mouseOver event, meaning the mouse just moved within the receiver
	with no button pressed. The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler mouseOver: anEvent fromMorph: self]! !

!PanelMorph methodsFor: 'protocol' stamp: ''!
checkSplitters
		
	(self submorphsSatisfying: [ :e | e isKindOf: ProportionalSplitterMorph ])
		do: [ :splitter |
			self checkMorphsLeftOrTopFrom: splitter.
			self checkMorphsRightOrBottomFrom: splitter ]! !

!PanelMorph methodsFor: 'initialize' stamp: ''!
defaultColor
	"Answer the default color for the receiver."

	^Color transparent! !

!PanelMorph methodsFor: 'protocol' stamp: ''!
enabled: aBoolean
	"Pass on to submorphs."

	self submorphsDo: [:m | m enabled: aBoolean]! !

!PanelMorph methodsFor: 'protocol' stamp: ''!
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)! !

!PanelMorphWithSplitters commentStamp: ''!
A PanelMorphWithSplitters is which add splitters the way SystemWindow do it!
!PanelMorphWithSplitters methodsFor: 'private' stamp: ''!
addPaneVSplitters
	"Add the vertical pane splitters."

	|remaining targetRight sameRight sameLeft |
	remaining := paneMorphs reject: [:each |
			each layoutFrame rightFraction = 1 or: [
				each layoutFrame rightFraction = 0]].
	[remaining notEmpty] whileTrue: [
		targetRight := remaining first layoutFrame rightFraction.
		sameRight := remaining select: [:each |
			each layoutFrame rightFraction = targetRight].
		sameLeft := paneMorphs select: [:each |
			each layoutFrame leftFraction = targetRight and: [
				each layoutFrame rightFraction ~= targetRight]].
		remaining := remaining
			copyWithoutAll: (self addPaneVSplitterBetween: sameRight and: sameLeft)]! !

!PanelMorphWithSplitters methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	paneMorphs := OrderedCollection new.! !

!PanelMorphWithSplitters methodsFor: 'submorphs - add/remove' stamp: ''!
addMorph: aMorph fullFrame: aLayout

	paneMorphs add: aMorph.
	super addMorph: aMorph fullFrame: aLayout! !

!PanelMorphWithSplitters methodsFor: 'submorphs - add/remove' stamp: ''!
addMorph: aMorph

	paneMorphs add: aMorph.
	^ super addMorph: aMorph! !

!PanelMorphWithSplitters methodsFor: 'private' stamp: ''!
addPaneHSplitters
	"Add the horizontal pane splitters."

	|remaining targetBottom sameBottom sameTop|
	remaining := paneMorphs reject: [:each |
			each layoutFrame bottomFraction = 1 or: [
				each layoutFrame bottomFraction = 0]].
	[remaining notEmpty] whileTrue: [
		targetBottom := remaining first layoutFrame bottomFraction.
		sameBottom := remaining select: [:each |
			each layoutFrame bottomFraction = targetBottom].
		sameTop := paneMorphs select: [:each |
			each layoutFrame topFraction = targetBottom].
		remaining := remaining
			copyWithoutAll: (self addPaneHSplitterBetween: sameBottom and: sameTop)]! !

!PanelMorphWithSplitters methodsFor: 'private' stamp: ''!
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' stamp: ''!
linkSplittersToSplitters
	"The pane morphs are already linked. Cross link the splitters as appropriate."
	
	self splitters do: [:each |
		each splitsTopAndBottom
			ifTrue: [self splitters do: [:eachMorph |
					eachMorph splitsTopAndBottom ~= each splitsTopAndBottom ifTrue: [
						eachMorph layoutFrame bottomFraction = each layoutFrame topFraction
							ifTrue: [each addLeftOrTop: eachMorph].
						eachMorph layoutFrame topFraction = each layoutFrame bottomFraction
							ifTrue: [each addRightOrBottom: eachMorph]]]]
			ifFalse: [self splitters do: [:eachMorph |
					eachMorph splitsTopAndBottom ~= each splitsTopAndBottom ifTrue: [
						eachMorph layoutFrame rightFraction = each layoutFrame leftFraction
							ifTrue: [each addLeftOrTop: eachMorph].
						eachMorph layoutFrame leftFraction = each layoutFrame rightFraction
							ifTrue: [each addRightOrBottom: eachMorph]]]].
				
		each comeToFront.]! !

!PanelMorphWithSplitters methodsFor: 'private' stamp: ''!
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: 'layout-properties' stamp: ''!
layoutFrame: aFrame

	self activate.
	super layoutFrame: aFrame! !

!PanelMorphWithSplitters methodsFor: 'private' stamp: ''!
addPaneSplitters
	"Add the vertical and horizontal pane splitters."

	self removePaneSplitters.
	self addPaneVSplitters.
	self addPaneHSplitters.
	self linkSplittersToSplitters! !

!Paragraph commentStamp: ''!
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: <Collection of SelectionBlock>
   findReplaceSelectionRegex: <RxMatcher>
   presentationLines: <Object>
   presentationText: <Object>
   refreshExtraSelection: <Boolean>
   secondarySelection: <String>

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 <lines> 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: 'alignment' stamp: ''!
justified 
	textStyle justified! !

!Paragraph methodsFor: '*Athens-Morphic' stamp: ''!
forLinesIn: aVisibleRect do: aBlock
	(self lineIndexForPoint: aVisibleRect topLeft) to: 
	(self lineIndexForPoint: aVisibleRect bottomRight) do: 
		[:i | aBlock value: (lines at: i) ]! !

!Paragraph methodsFor: 'editing' stamp: ''!
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: 'settings' stamp: ''!
insertionPointColor
	self focused ifFalse: [^ Color transparent].
	^ Display depth <= 2
		ifTrue: [Color black]
		ifFalse: [self class insertionPointColor]! !

!Paragraph methodsFor: '*Athens-Morphic' stamp: ''!
displayTextOnAthensCanvas: anAthensCanvas in: aRectangle
	| athensDisplayScanner offset leftInRun |
	anAthensCanvas clipBy: aRectangle during:[
	anAthensCanvas pathTransform
		restoreAfter: [ 
			offset := aRectangle topLeft - positionWhenComposed.
			athensDisplayScanner := AthensDisplayScanner for: self on: anAthensCanvas.
			leftInRun := 0.
			self
				forLinesIn: anAthensCanvas clipRect
				do: [ :line | 
					line first <= line last
						ifTrue: [ leftInRun := athensDisplayScanner displayLine: line offset: offset leftInRun: leftInRun ] ] ] ]! !

!Paragraph methodsFor: 'private' stamp: ''!
moveBy: delta
	lines do: [:line | line moveBy: delta].
	positionWhenComposed ifNotNil:[
	positionWhenComposed := positionWhenComposed + delta].
	container := container translateBy: delta! !

!Paragraph methodsFor: 'private' stamp: ''!
textStyle: ts lines: l text: t
	"Private -- just a service for deepCopy"
	textStyle := ts.
	lines := l.
	text := t.! !

!Paragraph methodsFor: 'accessing' stamp: ''!
textStyle: aTextStyle 
	"Set the style by which the receiver should display its text."
	textStyle := aTextStyle! !

!Paragraph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: aCanvas bounds: aRectangle 
	"do nothing"! !

!Paragraph methodsFor: 'display' stamp: ''!
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: 'accessing' stamp: ''!
showCaret
	^showCaret ifNil:[true]! !

!Paragraph methodsFor: 'composition' stamp: ''!
composeAllStartingAt: characterIndex
	firstCharacterIndex := characterIndex.
	offsetToEnd := text size - firstCharacterIndex.
	self composeAll! !

!Paragraph methodsFor: 'private' stamp: ''!
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: 'alignment' stamp: ''!
rightFlush 
	textStyle rightFlush! !

!Paragraph methodsFor: 'selection' stamp: ''!
selectionContainsPoint: aPoint
	"return whether the current selection contains the given point"
	^ self selectionRects anySatisfy: [ :rect| rect containsPoint: aPoint ]! !

!Paragraph methodsFor: 'composition' stamp: ''!
composeAll
	^ self
		multiComposeLinesFrom: firstCharacterIndex
		to: text size
		delta: 0
		into: OrderedCollection new
		priorLines: Array new
		atY: container top! !

!Paragraph methodsFor: '*Athens-Morphic' stamp: ''!
displaySelectionBarOnAthensCanvas: anAthensCanvas
	| visibleRectangle line |
	selectionStart ifNil: [ ^ self ].
	selectionStop ifNil: [ ^ self ].
	visibleRectangle := anAthensCanvas clipRect.
	selectionStart textLine = selectionStop textLine
		ifFalse: [ ^ self ].
	line := selectionStart textLine.
	anAthensCanvas setPaint: self selectionBarColor.
	anAthensCanvas drawShape: (visibleRectangle left @ line top corner: visibleRectangle right @ line bottom)! !

!Paragraph methodsFor: 'accessing' stamp: ''!
wantsColumnBreaks: aBoolean

	wantsColumnBreaks := aBoolean! !

!Paragraph methodsFor: 'accessing' stamp: ''!
wantsColumnBreaks

	^wantsColumnBreaks! !

!Paragraph methodsFor: 'composition' stamp: ''!
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: 'accessing' stamp: ''!
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: 'private' stamp: ''!
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: ''!
adjustRightX

	| shrink |
	shrink := container right - maxRightX.
	lines do: [ :line | line paddingWidth: line paddingWidth - shrink ].
	container := container withRight: maxRightX! !

!Paragraph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self positionWhenComposed: 0 @ 0! !

!Paragraph methodsFor: 'accessing' stamp: ''!
maxRightX
	^ maxRightX! !

!Paragraph methodsFor: 'selection' stamp: ''!
selectionColor: aColor 
	"ignored"! !

!Paragraph methodsFor: 'accessing' stamp: ''!
showCaret: aBool
	showCaret := aBool! !

!Paragraph methodsFor: '*Athens-Morphic' stamp: ''!
displaySelectionBlock: aSelBlock inLine: line onAthensCanvas: anAthensCanvas
	(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 onAthensCanvas: anAthensCanvas! !

!Paragraph methodsFor: 'accessing' stamp: ''!
focused
	^ focused ifNil: [focused := false]! !

!Paragraph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas bounds: aRectangle color: aColor
	self displayCaretAndSelectionOnAthensCanvas: anAthensCanvas.
	self displayExtraSelectionOnAthensCanvas: anAthensCanvas.
	anAthensCanvas setPaint: aColor.
	self displayTextOnAthensCanvas: anAthensCanvas in: aRectangle.! !

!Paragraph methodsFor: 'copying' stamp: ''!
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: 'accessing' stamp: ''!
extent
	^ container width @ (lines last bottom - lines first top)! !

!Paragraph methodsFor: 'editing' stamp: ''!
actionAttributesUnder: aClickPoint event: anEvent do: aBlock
	| startBlock |
	startBlock := self characterBlockAtPoint: aClickPoint.
	(text attributesAt: startBlock stringIndex forStyle: textStyle)
		select: [ :attribute | attribute mayActOnEvent: anEvent ]
		thenDo: [ :attribute | 
			| range boxes |
			"find the boxes for the current attribute range"
			range := text rangeOf: attribute startingAt: startBlock stringIndex.
			boxes := self
				selectionRectsFrom: (self characterBlockForIndex: range first)
				to: (self characterBlockForIndex: range last + 1).
			boxes detect: [ :each | each containsPoint: aClickPoint ] ifFound: [ aBlock cull: attribute cull: boxes ] ]! !

!Paragraph methodsFor: 'selection' stamp: ''!
defaultCharacterBlock
	^ (CharacterBlock new stringIndex: firstCharacterIndex text: text
			topLeft: lines first topLeft extent: 0 @ 0)
		textLine: lines first! !

!Paragraph methodsFor: 'accessing' stamp: ''!
theme
	^ Smalltalk ui theme! !

!Paragraph methodsFor: 'private' stamp: ''!
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: 'selection' stamp: ''!
extraSelectionChanged
	refreshExtraSelection := true! !

!Paragraph methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
positionWhenComposed: pos
	positionWhenComposed := pos! !

!Paragraph methodsFor: 'accessing' stamp: ''!
lastCharacterIndex
	^ lines last last! !

!Paragraph methodsFor: 'private' stamp: ''!
lines
	^ lines ifNil: [ ^ Array new ]! !

!Paragraph methodsFor: 'accessing' stamp: ''!
numberOfLines

	^lines size! !

!Paragraph methodsFor: '*Athens-Morphic' stamp: ''!
displayExtraSelectionOnAthensCanvas: anAthensCanvas
	| visibleRectangle |
	visibleRectangle := anAthensCanvas clipRect.
	refreshExtraSelection = true
		ifTrue: [ self buildSelectionBlocksFrom: visibleRectangle topLeft to: visibleRectangle bottomRight.
			refreshExtraSelection := false ].
		
	extraSelectionBlocks
		ifNotNil: [ 
			self forLinesIn: visibleRectangle	do: [ :line | 
					extraSelectionBlocks
						do: [ :selblock | self displaySelectionBlock: selblock inLine: line onAthensCanvas: anAthensCanvas ] ] ]! !

!Paragraph methodsFor: 'accessing' stamp: ''!
textStyle
	^ textStyle! !

!Paragraph methodsFor: 'display' stamp: ''!
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: 'selection' stamp: ''!
findReplaceSelectionRegex: aRegex
	findReplaceSelectionRegex := aRegex.! !

!Paragraph methodsFor: 'display' stamp: ''!
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: 'accessing' stamp: ''!
firstCharacterIndex
	^ firstCharacterIndex! !

!Paragraph methodsFor: '*Athens-Morphic' stamp: ''!
displayCaretAndSelectionOnAthensCanvas: anAthensCanvas
	selectionStart ifNil: [ ^ self ].
	selectionStart = selectionStop
		ifTrue: [ self drawCaretOnAthensCanvas: anAthensCanvas ]
		ifFalse: [ 
			| selection |
			caretRect := nil.
			selection := ParagraphSelectionBlock first: selectionStart last: selectionStop color: self selectionColor.
			self forLinesIn: anAthensCanvas clipRect do: [ :line | selection displayInLine: line onAthensCanvas: anAthensCanvas ] ]! !

!Paragraph methodsFor: 'editing' stamp: ''!
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: 'display' stamp: ''!
displaySelectionInLine: line on: aCanvas 
	| leftX rightX w caretColor |
	selectionStart ifNil: [^self].	"No selection"
	aCanvas isShadowDrawing ifTrue: [ ^self ].	"don't draw selection with shadow"
	selectionStart = selectionStop 
		ifTrue: 
			["Only show caret on line where clicked"

			selectionStart textLine ~= line ifTrue: [^self]]
		ifFalse: 
			["Test entire selection before or after here"

			(selectionStop stringIndex < line first 
				or: [selectionStart stringIndex > (line last + 1)]) ifTrue: [^self].	"No selection on this line"
			(selectionStop stringIndex = line first 
				and: [selectionStop textLine ~= line]) ifTrue: [^self].	"Selection ends on line above"
			(selectionStart stringIndex = (line last + 1) 
				and: [selectionStop textLine ~= line]) ifTrue: [^self]].	"Selection begins on line below"
	leftX := (selectionStart stringIndex < line first 
				ifTrue: [line ]
				ifFalse: [selectionStart ])left.
	rightX := (selectionStop stringIndex > (line last + 1) or: 
					[selectionStop stringIndex = (line last + 1) 
						and: [selectionStop textLine ~= line]]) 
				ifTrue: [line right]
				ifFalse: [selectionStop left].
	selectionStart = selectionStop 
		ifTrue: 
			[rightX := rightX + 1.
			w := self caretWidth.
			caretRect := (leftX-w) @ line top corner: (rightX+w)@ line bottom.
			self showCaret ifFalse:[^self].
			caretColor := self insertionPointColor.
			1 to: w
				do: 
					[:i | 
					"Draw caret triangles at top and bottom"

					aCanvas fillRectangle: ((leftX - w + i - 1) @ (line top + i - 1) 
								extent: ((w - i) * 2 + 3) @ 1)
						color: caretColor.
					aCanvas fillRectangle: ((leftX - w + i - 1) @ (line bottom - i) 
								extent: ((w - i) * 2 + 3) @ 1)
						color: caretColor].
			aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom)
				color: caretColor]
		ifFalse: 
			[caretRect := nil.
			aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom)
				color: self selectionColor]! !

!Paragraph methodsFor: 'display' stamp: ''!
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: 'private' stamp: ''!
lineIndexOfCharacterIndex: characterIndex 
	"Answer the line index for a given characterIndex."
	"apparently the selector changed with NewParagraph"

	^self lineIndexForCharacter: characterIndex! !

!Paragraph methodsFor: 'accessing' stamp: ''!
string
	^ text string! !

!Paragraph methodsFor: 'accessing' stamp: ''!
secondarySelection
	^ secondarySelection! !

!Paragraph methodsFor: 'composition' stamp: ''!
compose: t style: ts from: startingIndex in: textContainer
	text := t.
	textStyle := ts.
	firstCharacterIndex := startingIndex.
	offsetToEnd := text size - firstCharacterIndex.
	container := textContainer.
	self composeAll! !

!Paragraph methodsFor: 'accessing' stamp: ''!
textOwner: ignored  "See TextOnCurve"! !

!Paragraph methodsFor: '*Athens-Morphic' stamp: ''!
drawCaretOnAthensCanvas: anAthensCanvas
	(self showCaret not or: [ selectionStart isNil ])
		ifTrue: [ ^ self ].
	caretRect := selectionStart topLeft asIntegerPoint extent: 1 @ selectionStart height.
	anAthensCanvas setPaint: self insertionPointColor.
	anAthensCanvas drawShape: self caretRect! !

!Paragraph methodsFor: 'selection' stamp: ''!
secondarySelectionColor
	^  self theme secondarySelectionColor! !

!Paragraph methodsFor: 'composition' stamp: ''!
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: 'selection' stamp: ''!
characterBlockAtPoint: aPoint 
	"Answer a CharacterBlock for the character in the text at aPoint."
	| line |
	line := lines at: (self lineIndexForPoint: aPoint).
	^ (CharacterBlockScanner new text: text textStyle: textStyle)
		characterBlockAtPoint: aPoint index: nil
		in: line! !

!Paragraph methodsFor: 'selection' stamp: ''!
selectionRectsFrom: characterBlock1 to: characterBlock2 
	"Return an array of rectangles representing the area between the two character blocks given as arguments."
	| line1 line2 rects cb1 cb2 w |
	characterBlock1 <= characterBlock2
		ifTrue: [cb1 := characterBlock1.  cb2 := characterBlock2]
		ifFalse: [cb2 := characterBlock1.  cb1 := characterBlock2].
	cb1 = cb2 ifTrue:
		[w := self caretWidth.
		^ Array with: (cb1 topLeft - (w@0) corner: cb1 bottomLeft + ((w+1)@0))].
	line1 := self lineIndexForCharacter: cb1 stringIndex.
	line2 := self lineIndexForCharacter: cb2 stringIndex.
	line1 = line2 ifTrue:
		[^ Array with: (cb1 topLeft corner: cb2 bottomRight)].
	rects := OrderedCollection new.
	rects addLast: (cb1 topLeft corner: (lines at: line1) bottomRight).
	line1+1 to: line2-1 do: [ :i |
		| line |
		line := lines at: i.
		(line left = rects last left and: [ line right = rects last right ])
			ifTrue: [ "new line has same margins as old one -- merge them, so that the caller gets as few rectangles as possible"
					| lastRect |
					lastRect := rects removeLast.
					rects add: (lastRect bottom: line bottom) ]
			ifFalse: [ "differing margins; cannot merge"
					rects add: line rectangle ] ].

	rects addLast: ((lines at: line2) topLeft rectangle: cb2 bottomLeft).
	^ rects! !

!Paragraph methodsFor: 'private' stamp: ''!
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: ''!
adjustLineIndicesBy: delta

	firstCharacterIndex := firstCharacterIndex + delta.
	lines do: [ :line | line slide: delta ]! !

!Paragraph methodsFor: 'composition' stamp: ''!
composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines
	atY: startingY
	"While the section from start to stop has changed, composition may ripple all the way to the end of the text.  However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values"

	| newResult |

	newResult := self composer
		composeLinesFrom: start 
		to: stop 
		delta: delta 
		into: lineColl 
		priorLines: priorLines
		atY: startingY
		textStyle: textStyle 
		text: text 
		container: container
		wantsColumnBreaks: wantsColumnBreaks == true.
	lines := newResult first asArray.
	^ maxRightX := newResult second.! !

!Paragraph methodsFor: 'selection' stamp: ''!
characterBlockForIndex: index 
	"Answer a CharacterBlock for the character in text at index."
	| line |
	line := lines at: (self lineIndexForCharacter: index).
	^ (CharacterBlockScanner new text: text textStyle: textStyle)
		characterBlockAtPoint: nil index: ((index max: line first) min: text size+1)
		in: line! !

!Paragraph methodsFor: 'selection' stamp: ''!
hasExtraSelection
	"Return true if I've some findReplace or secondary selection"
	^ extraSelectionBlocks isEmptyOrNil not! !

!Paragraph methodsFor: 'private' stamp: ''!
adjustBottomY

	| heights bottomY verticalSize |
	heights := lines collect: [ :each | each lineHeight ].
	verticalSize := heights sum.
	bottomY := container top + verticalSize.
	container := container withBottom: bottomY! !

!Paragraph methodsFor: 'composition' stamp: ''!
compositionRectangle
	^ container! !

!Paragraph methodsFor: 'selection' stamp: ''!
selectionColor
	^ self focused 
		ifTrue: [ self theme selectionColor]
		ifFalse: [ self theme unfocusedSelectionColor ].! !

!Paragraph methodsFor: 'selection' stamp: ''!
selectionRects
	"Return an array of rectangles representing the selection region."
	selectionStart ifNil: [^ Array new].
	^ self selectionRectsFrom: selectionStart to: selectionStop! !

!Paragraph methodsFor: 'selection' stamp: ''!
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: 'editing' stamp: ''!
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: [ self currentWorld currentCursor == Cursor webLink]) 
		ifTrue:[ Cursor normal show ].
	
	^ action! !

!Paragraph methodsFor: 'editing' stamp: ''!
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: [ self currentWorld currentCursor == Cursor webLink]) 
		ifTrue:[ Cursor normal show ].
	
	^ action! !

!Paragraph methodsFor: 'selection' stamp: ''!
selectionStart: startBlock selectionStop: stopBlock
	selectionStart := startBlock.
	selectionStop := stopBlock.! !

!Paragraph methodsFor: 'alignment' stamp: ''!
centered 
	textStyle centered! !

!Paragraph methodsFor: 'accessing' stamp: ''!
caretWidth

	^ TextEditor dumbbellCursor
		  ifTrue: [ 2 ]
		  ifFalse: [ 0 ]! !

!Paragraph methodsFor: 'selection' stamp: ''!
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: ''!
selectionBarColor
	^ self theme  selectionBarColor! !

!Paragraph methodsFor: 'selection' stamp: ''!
findReplaceSelectionColor
	^  self theme currentSettings findReplaceSelectionColor! !

!Paragraph methodsFor: 'accessing' stamp: ''!
composer
	^ composer ifNil: [composer := TextComposer new]! !

!Paragraph methodsFor: 'alignment' stamp: ''!
leftFlush 
	textStyle leftFlush! !

!Paragraph methodsFor: 'accessing' stamp: ''!
focused: aBoolean
	focused := aBoolean! !

!Paragraph methodsFor: 'selection' stamp: ''!
containsPoint: aPoint
	^ (lines at: (self lineIndexForPoint: aPoint)) rectangle
		containsPoint: aPoint! !

!Paragraph methodsFor: 'selection' stamp: ''!
secondarySelection: aSubstring
	secondarySelection := aSubstring.! !

!Paragraph methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!Paragraph class methodsFor: 'settings' stamp: ''!
insertionPointColor
	^ InsertionPointColor ifNil: [InsertionPointColor := (Color r: 0.0 g: 0.0 b: 0.8 alpha: 0.8)]! !

!Paragraph class methodsFor: 'settings' stamp: ''!
insertionPointColor: aColor
	InsertionPointColor := aColor! !

!Paragraph class methodsFor: 'refreshing' stamp: ''!
refreshAllCompositions
	"This method will re-compose all paragraphs in system. 
	 This is potentially an expensive operation (and is used just in one case: when you change the 
	 hinitng of a font through settings. See FreeTypeSettings>>hintingSymbol:"

	self allSubInstances do: [ :each | each composeAll ].
	self currentWorld restoreMorphicDisplay! !

!ParagraphSelectionBlock commentStamp: ''!
A selection block in a text paragraph !
!ParagraphSelectionBlock methodsFor: '*Athens-Morphic' stamp: ''!
displayInLine: line onAthensCanvas: anAthensCanvas
	"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 ].
	anAthensCanvas setPaint: color.
	anAthensCanvas drawShape: (leftX @ line top corner: rightX @ line bottom)! !

!ParagraphSelectionBlock methodsFor: 'accessing' stamp: ''!
first

	^ first! !

!ParagraphSelectionBlock methodsFor: 'accessing' stamp: ''!
last

	^ last! !

!ParagraphSelectionBlock methodsFor: 'initialization' stamp: ''!
first: firstCharBlock last: lastCharBlock color: aColor

	first := firstCharBlock.
	last := lastCharBlock.
	color := aColor! !

!ParagraphSelectionBlock methodsFor: 'displaying' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
first: firstCharBlock last: lastCharBlock color: aColor
	^ self new first: firstCharBlock last: lastCharBlock color: aColor! !

!ParametrizedTestCase commentStamp: ''!
I am a subclass of `TestCase` that implements support for parametrized tests.
A parametrized tests is a test that is run with different configurations.
These configurations are generated from a Matrix.

### How to 
To define parametrized tests just extend this class as a normal test, 
add accessors for the properties to configure and implement the class side method `testParameters`.

When the test class is executed a `TestSuite` is generated with an instance for each of the configured cases. These instances are populated using the accessors to the described properties. 

The class side method `testParameters` returns a test matrix. 
A Matrix offers two protocols: 
- `addCase:` to define an explicit configuration of parameters 
- `forSelector: addOptions:` to define all possible value of a parameter

#### Matrix with some configurations

```
PaSelectedCasesExampleTest class >> testParameters

	^ ParametrizedTestMatrix new
		addCase: { #number1 -> 2. #number2 -> 1.0. #result -> 3 };
		addCase: { #number1 -> (2/3). #number2 -> (1/3). #result -> 1 };
		yourself
```

#### Matrix with all combinations
This test matrix can be generated with cartesian product configurations or a set of well known cases.

An example of #testParameters is: 

```
PaSimpleMatrixExampleTest class >> testParameters

	^ ParametrizedTestMatrix new
		forSelector: #option1 addOptions: #(a b c);
		forSelector: #option2 addOptions: {[1].[2].[3]};
		yourself.
``` 

Each option is constituted from a set of possible values and a selector that is the name of the property to set in the test case instance.

Also each option can be a literal or a block to generate that value. The block has an optional parameter, the parameter is the test case to configure.

In this example the generated cases will be 9. One per each combination of #option1 and #option2. 
The test Case should have a setter for 

Check the `PaSimpleMatrixExampleTest` and  `PaSelectedCasesExampleTest` to see how to use the different possible configurations.!
!ParametrizedTestCase methodsFor: 'accessing' stamp: ''!
parametersToUse
	^ parametersToUse ifNil: [#()]! !

!ParametrizedTestCase methodsFor: 'accessing' stamp: ''!
nameForReport

	parametersToUse ifNil: [ ^ super nameForReport ].

	^ String streamContents: [ :s |
		s nextPutAll: self selector asString.
		parametersToUse printElementsOn: s ]! !

!ParametrizedTestCase methodsFor: 'accessing' stamp: ''!
parametersToUse: anObject
	parametersToUse := anObject! !

!ParametrizedTestCase methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	parametersToUse ifNotNil: [ parametersToUse printElementsOn: aStream.]! !

!ParametrizedTestCase methodsFor: 'private' stamp: ''!
instanceVariablesToKeep

	^ super instanceVariablesToKeep, #('testSelector' 'parametersToUse')! !

!ParametrizedTestCase methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self parametersToUse do: [ :aParameter | aParameter applyTo: self ].
	
	"If I am executed without calling buildSuite in the class. I will use the first set of options.
	This is a workaround to work when running from Calypso"
	(self parametersToUse isEmpty and: [self class testParameters isNotEmpty]) 
		ifTrue: [ 
				self class 
						testParameters expandMatrix first 
						do: [ :aParameter | aParameter applyTo: self ] ]! !

!ParametrizedTestCase class methodsFor: 'private' stamp: ''!
isAbstract
	^ self name = #ParametrizedTestCase! !

!ParametrizedTestCase class methodsFor: 'building suites' stamp: ''!
testParameters
	"I'm the main hook to define configuration.
	See addCase and forSelector:addOptions: on ParametrizedTestMatrix."
	
	^ ParametrizedTestMatrix new! !

!ParametrizedTestCase class methodsFor: 'building suites' stamp: ''!
buildSuite

	| expandedMatrix suite |
	
	expandedMatrix := self testParameters expandMatrix.

	expandedMatrix ifEmpty: [ ^ self buildSuiteFromSelectors].

	suite := self suiteClass named: self name.
	expandedMatrix do: [ :expandedParameters | |internalSuite|
		internalSuite := self buildSuiteFromSelectors.
		internalSuite tests do: [ :aTest | aTest parametersToUse: expandedParameters ].
		suite addTests: internalSuite tests.
	].

	^ suite! !

!ParametrizedTestExpandedParameter commentStamp: ''!
I represent a parameter in an expanded matrix.
I know how to update the test case with my value.
Also, I know how to print me when printing the test case. !
!ParametrizedTestExpandedParameter methodsFor: 'comparing' stamp: ''!
= anOption

	^ self selector = anOption selector
		and: [ self valuable = anOption valuable ]! !

!ParametrizedTestExpandedParameter methodsFor: 'comparing' stamp: ''!
hash

	^ self selector hash + self valuable hash! !

!ParametrizedTestExpandedParameter methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!ParametrizedTestExpandedParameter methodsFor: 'accessing' stamp: ''!
key
	self shouldBeImplemented.! !

!ParametrizedTestExpandedParameter methodsFor: 'converting' stamp: ''!
asTestParameter

	^ self! !

!ParametrizedTestExpandedParameter methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!ParametrizedTestExpandedParameter methodsFor: 'accessing' stamp: ''!
suiteName
	^ selector , ' -> ' , valuable printString! !

!ParametrizedTestExpandedParameter methodsFor: 'accessing' stamp: ''!
valuable: aValuable 
	valuable := aValuable! !

!ParametrizedTestExpandedParameter methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream print: (selector -> valuable)! !

!ParametrizedTestExpandedParameter methodsFor: 'accessing' stamp: ''!
valuable
	^ valuable! !

!ParametrizedTestExpandedParameter methodsFor: 'applying' stamp: ''!
applyTo: aTest

	| anObject |
	anObject := self valuable isBlock
		ifTrue: [ self valuable cull: aTest ]
		ifFalse: [ self valuable ].

	aTest perform: selector asMutator with: anObject! !

!ParametrizedTestMatrix commentStamp: ''!
I represent the test configuration matrix of all the cases.
Check the examples to see how to use me.
!
!ParametrizedTestMatrix methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ options isEmpty and: [ cases isEmpty ]! !

!ParametrizedTestMatrix methodsFor: 'cases' stamp: ''!
addCase: aCollection
	"Declare a specific configuration of parameters. See forSelector:addOptions: for matrix combinations."
	
	cases add: (aCollection
		collect: [ :assoc | assoc asTestParameter ]
		as: Array).
		
	^ self! !

!ParametrizedTestMatrix methodsFor: 'comparing' stamp: ''!
= aMatrix

	^ self expandMatrix = aMatrix expandMatrix! !

!ParametrizedTestMatrix methodsFor: 'combination' stamp: ''!
* aParametrizedTestMatrix 

	| newMatrix |
	newMatrix := ParametrizedTestMatrix new.
	self expandMatrix do: [ :subcase1 |
		aParametrizedTestMatrix asTestMatrix expandMatrix do: [ :subcase2 |
			newMatrix addCase: subcase1, subcase2  ] ].
	^ newMatrix! !

!ParametrizedTestMatrix methodsFor: 'comparing' stamp: ''!
hash

	^ self expandMatrix hash! !

!ParametrizedTestMatrix methodsFor: 'expanding' stamp: ''!
expandMatrix
	| combinations |
	combinations := self combinationsOf: self options.
	combinations ifEmpty: [ ^ cases ].
	cases ifEmpty: [ ^ combinations ].
	^ combinations flatCollect: [ :aCase | cases collect: [ :each | aCase , each ] ]! !

!ParametrizedTestMatrix methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	options := OrderedCollection new.
	cases := OrderedCollection new! !

!ParametrizedTestMatrix methodsFor: 'testing' stamp: ''!
isNotEmpty
	
	^ self isEmpty not! !

!ParametrizedTestMatrix methodsFor: 'addingOptions' stamp: ''!
forSelector: aSelector addOptions: someOptions
	"Declare all possible values for a given parameter expressed via a message send aSelector."
	
	options
		add:
			(ParametrizedTestOption new
				selector: aSelector;
				values: someOptions;
				yourself)! !

!ParametrizedTestMatrix methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!ParametrizedTestMatrix methodsFor: 'accessing' stamp: ''!
selector: aString 
	selector := aString! !

!ParametrizedTestMatrix methodsFor: 'generating' stamp: ''!
combinationsOf: aCollection 
	
	| first expandedParameters inner |
	aCollection ifEmpty: [ ^ #() ].
	
	first := aCollection first.
	expandedParameters := first expand.
	
	inner := self combinationsOf: aCollection allButFirst.
	inner ifEmpty: [ ^ expandedParameters collect: [ :each | { each } ] ].
	
	^ expandedParameters flatCollect: [ :aParameter | inner collect:[:aCase | {aParameter} , aCase ] ]! !

!ParametrizedTestMatrix methodsFor: 'converting' stamp: ''!
asTestMatrix

	^ self! !

!ParametrizedTestMatrix methodsFor: 'accessing' stamp: ''!
values: aCollection 
	options := aCollection collect:[ :aValue | 
		ParametrizedTestExpandedParameter new 
			parameter: self; 
			valuable: aValue;
			yourself]! !

!ParametrizedTestMatrix methodsFor: 'accessing' stamp: ''!
options
	^ options! !

!ParametrizedTestOption commentStamp: ''!
An option reifies the relationship in between a selector / property with it potential values. !
!ParametrizedTestOption methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!ParametrizedTestOption methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!ParametrizedTestOption methodsFor: 'accessing' stamp: ''!
expand
	^ values
		collect: [ :each | 
			ParametrizedTestExpandedParameter new
				selector: selector;
				valuable: each ]! !

!ParametrizedTestOption methodsFor: 'accessing' stamp: ''!
values
	^ values! !

!ParametrizedTestOption methodsFor: 'accessing' stamp: ''!
values: anObject
	values := anObject! !

!PasswordDialogWindow commentStamp: ''!
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: ''!
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: 'protocol' stamp: ''!
beDecrypted

	textEditor font: self theme textFont! !

!PasswordDialogWindow methodsFor: 'private' stamp: ''!
showPassword
	
	^ showPassword ifNil: [ showPassword := false ]! !

!PasswordDialogWindow methodsFor: 'creation' stamp: ''!
newTextEditorMorph
	"Answer a new morph for the text entry using a password font."

	textEditor := super newTextEditorMorph.
	self beEncrypted.
	^ textEditor! !

!PasswordDialogWindow methodsFor: 'protocol' stamp: ''!
beEncrypted

	textEditor font: (StrikeFont passwordFontSize: self theme textFont pointSize)! !

!PasswordDialogWindow methodsFor: 'private' stamp: ''!
showPasswordButton

	^ (CheckboxMorph 
			on: self 
			selected: #showPassword
			changeSelected: #showPassword:)
			label: 'Show password';
			labelClickable: true;
			height: 25.! !

!PasswordDialogWindow methodsFor: 'private' stamp: ''!
showPassword: aBoolean

	(showPassword := aBoolean)
		ifTrue: [ self beDecrypted ]
		ifFalse: [ self beEncrypted ].
	self changed: #showPassword! !

!PasteUpMorph commentStamp: ''!
A morph whose submorphs comprise a paste-up of rectangular subparts which "show through".  Anything called a 'Playfield' is a PasteUpMorph.

Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided.




!
!PasteUpMorph methodsFor: 'cursor' stamp: ''!
isCursorOwner
	^ false! !

!PasteUpMorph methodsFor: 'event handling' stamp: ''!
wantsEasySelection
	"Answer if the receiver want easy selection mode"
	^ self isEasySelecting! !

!PasteUpMorph methodsFor: 'event handling' stamp: ''!
windowEventHandler: anObject
	"This is a class variable so it is global to all projects and does not get saved"
	WindowEventHandler := anObject! !

!PasteUpMorph methodsFor: 'gridding' stamp: ''!
griddingString
	"Answer a string to use in a menu offering the user the 
	opportunity to start or stop using gridding"
	^ (self griddingOn
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'use gridding' translated! !

!PasteUpMorph methodsFor: 'recategorized' stamp: ''!
resizeBackgroundMorph

	"Resize the background morph to fit the world."

	self backgroundMorph ifNotNil: [ self backgroundMorph extent: self extent ]! !

!PasteUpMorph methodsFor: 'accessing' stamp: ''!
osWindow
	
	^ nil! !

!PasteUpMorph methodsFor: 'accessing' stamp: ''!
backgroundMorph: aMorph

	"Set the background morph.
	Probably best if locked prior to adding."

	self backgroundMorph ifNotNil: [ self backgroundMorph delete ].
	backgroundMorph := aMorph.
	aMorph
		ifNotNil: [ aMorph bounds: self bounds.
			self addMorphBack: aMorph
			]! !

!PasteUpMorph methodsFor: 'submorphs - accessing' stamp: ''!
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: '*Morphic-Widgets-Windows' stamp: ''!
modelWakeUpIn: aWindow
	"I am the model of a SystemWindow, that has just been activated"

	self viewBox = aWindow panelRect ifFalse: [self viewBox: aWindow panelRect]! !

!PasteUpMorph methodsFor: 'cursor' stamp: ''!
currentCursor
	^ worldState currentCursor! !

!PasteUpMorph methodsFor: 'options' stamp: ''!
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: ['<yes>']
		ifFalse: ['<no>'])
		, 'resize to fit' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: ''!
contentsMenu: aMenu
	"Build the menu used from PopUpContentsMenu:"
	(self submorphs asSortedCollection: [:w1 :w2 | w1 class name caseInsensitiveLessOrEqual: w2 class name]) do:
		[:w | aMenu add: w class name target: w selector: #comeToFront ].
	^ aMenu! !

!PasteUpMorph methodsFor: 'world state' stamp: ''!
restoreDisplay

	self world restoreMorphicDisplay.	"I don't actually expect this to be called"! !

!PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: ''!
bringWindowsFullOnscreen

	"Make ever SystemWindow on the desktop be totally on-screen, whenever possible."

	| r |

	bounds
		allAreasOutsideList: ( self taskbars collect: [ :t | t bounds ] )
		do: [ :e | 
			r
				ifNil: [ r := e ]
				ifNotNil: [ 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-Widgets-Windows' stamp: ''!
nextWindow
	"Answer the next window to navigate to."

	|sys|
	sys := self systemWindows.
	sys ifEmpty: [^nil].
	^sys after: self currentWindow ifAbsent: [sys first]! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
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: 'world menu' stamp: ''!
lastKeystroke	
	"Answer the last keystroke fielded by the receiver"	
	^ self valueOfProperty: #lastKeystroke ifAbsent: ['']! !

!PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: ''!
expandAll
	"Expand all windows"
	(self  windowsSatisfying: [:w | w isCollapsed])
		reverseDo: [:w | w collapseOrExpand.  self displayWorld]! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
nonWindows
	^ (self submorphs select: [:m | (m isSystemWindow) not and: [m wantsToBeTopmost not]])! !

!PasteUpMorph methodsFor: 'private' stamp: ''!
privateRemoveMorph: aMorph
	backgroundMorph == aMorph ifTrue: [ backgroundMorph := nil ].
	^super privateRemoveMorph: aMorph.! !

!PasteUpMorph methodsFor: 'testing' stamp: ''!
isEasySelecting
	"This is to isolate easySelection predicate. 
	Selectors in holders make no sense so we are limiting easy
	selection to the worldMorph.
	It would also make sense in playfield so feel free to adjust this
	predicate. Selection can always be forced by using the shift
	before mouse down."
	^ false! !

!PasteUpMorph methodsFor: 'gridding' stamp: ''!
gridVisible

	^ self hasProperty: #gridVisible! !

!PasteUpMorph methodsFor: 'world state' stamp: ''!
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: 'accessing' stamp: ''!
useRoundedCorners
	"Somewhat special cased because we do have to fill Display for this"
	super useRoundedCorners.
	self == self world ifTrue:[Display bits primFill: 0]. "done so that we *don't* get a flash"! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskList

	^ self submorphs
		detect: [ :e | e isKindOf: TaskListMorph ]
		ifNone: [ NullTaskList in: self ].! !

!PasteUpMorph methodsFor: 'event handling' stamp: ''!
windowEvent: anEvent
	self windowEventHandler ifNotNil: [ ^ self windowEventHandler windowEvent: anEvent ].
	"The window close dialog is modal, since the windowClose event originates from the system window button, we need to protect against opening multiple, otherwise we end up with the world in a locked state when one of them is cancelled"
	(anEvent type == #windowClose and: [ self valueOfProperty: #canOpenCloseDialog ifAbsent: true ])
		ifTrue: [ 
			self setProperty: #canOpenCloseDialog toValue: false.
			WorldState quitSession.
			self removeProperty: #canOpenCloseDialog ]! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
showWorldTaskbar: aBoolean
	"Change the receiver to show the taskbar."
	
	aBoolean
		ifTrue: [self createTaskbarIfNecessary]
		ifFalse: [self removeTaskbar]! !

!PasteUpMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color
		r: 0.861
		g: 1.0
		b: 0.722! !

!PasteUpMorph methodsFor: 'gridding' stamp: ''!
gridVisibleOnOff

	self setProperty: #gridVisible toValue: self gridVisible not.
	self changed! !

!PasteUpMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^true! !

!PasteUpMorph methodsFor: 'drawing' stamp: ''!
drawBackgroundSketchOn: aCanvas
	backgroundMorph ifNil: [ ^ self ].
	self clipSubmorphs
		ifTrue: [ aCanvas clipBy: self clippingBounds during: [ :canvas | canvas fullDrawMorph: backgroundMorph ] ]
		ifFalse: [ aCanvas fullDrawMorph: backgroundMorph ]! !

!PasteUpMorph methodsFor: 'gridding' stamp: ''!
griddingOn

	^ griddingOn ifNil: [false]! !

!PasteUpMorph methodsFor: 'cursor' stamp: ''!
currentCursor: aCursor
	^ worldState currentCursor: aCursor! !

!PasteUpMorph methodsFor: 'gridding' stamp: ''!
gridOrigin: newOrigin

	^ self gridSpecPut: (newOrigin extent: self gridModulus)! !

!PasteUpMorph methodsFor: 'gridding' stamp: ''!
gridSpecPut: newSpec
	"Gridding rectangle provides origin and modulus"

	^ self setProperty: #gridSpec toValue: newSpec! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
discoveredWorldMenu
	^ owner discoveredWorldMenu! !

!PasteUpMorph methodsFor: 'Morphic-Base-Basic' stamp: ''!
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: 'dropping/grabbing' stamp: ''!
dropEnabled
	"Get this morph's ability to add and remove morphs via drag-n-drop."

	^ (self valueOfProperty: #dropEnabled) ~~ false! !

!PasteUpMorph methodsFor: 'halos and balloon help' stamp: ''!
defersHaloOnClickTo: aSubMorph
	"If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"
	^ true! !

!PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: ''!
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  closeAllUnchangedWindows.! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
visibleSystemWindows
	"Answer the visible system windows in the world."
	
	^self submorphsSatisfying: [:m | m isSystemWindow and: [m visible]]! !

!PasteUpMorph methodsFor: 'accessing' stamp: ''!
currentWindow

	"Answer the top window or nil"
	
	^ self class environment at: #SystemWindow ifPresent: [:systemWindow | systemWindow topWindow]! !

!PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: ''!
findWindow: evt
	"Present a menu names of windows and naked morphs, and activate the one that gets chosen.  Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo."
	| menu expanded collapsed nakedMorphs |
	menu := UIManager default newMenuIn: self for: self.
	expanded := self  windowsSatisfying: [:w | w isCollapsed not].
	collapsed := self  windowsSatisfying: [:w | w isCollapsed].
	nakedMorphs := self submorphsSatisfying:[:m | m isSystemWindow not].
	(expanded isEmpty and: [collapsed isEmpty and: [nakedMorphs isEmpty]]) ifTrue: [^ self inform: 'No morph in world'].
	(expanded asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do:
		[:w | menu add: w label target: w selector: #activateAndForceLabelToShow.
			w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
	(expanded isEmpty or: [ collapsed isEmpty and: [ nakedMorphs isEmpty ]]) ifFalse: [menu addLine].
	(collapsed asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: 
		[:w | menu add: w label target: w selector: #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 selector: #comeToFrontAndAddHalo].
	menu addTitle: 'find window'.
	menu popUpEvent: evt in: self.! !

!PasteUpMorph methodsFor: 'halos and balloon help' stamp: ''!
wantsHaloFromClick
	 ^owner isSystemWindow not! !

!PasteUpMorph methodsFor: 'options' stamp: ''!
resizeToFit
	^self vResizing == #shrinkWrap! !

!PasteUpMorph methodsFor: 'viewing' stamp: ''!
bringTopmostsToFront
	submorphs
		select:[:m| m wantsToBeTopmost]
		thenDo:[:m| self addMorphInLayer: m].! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
collapseNonWindows
	self nonWindows reject: [:m | m isSticky] thenDo: [:m | m collapse]! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
commandKeySelectors
	"Answer my command-key table"

	| aDict |
	aDict := self valueOfProperty: #commandKeySelectors ifAbsentPut: [self initializeDesktopCommandKeySelectors].
	^ aDict! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: ''!
mouseDown: evt
	"Handle a mouse down event."

	| grabbedMorph handHadHalos |
	(self class isMenuOpenByLeftClick
		ifTrue: [ evt yellowButtonPressed "left click" ]
		ifFalse: [ evt redButtonPressed	"right click" ])
		ifTrue: [ ^ self popUpContentsMenu: evt ].
	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"
	evt hand releaseKeyboardFocus.	"shake of keyboard foci"
	(evt shiftPressed not and: [ self isWorldMorph not and: [ self wantsEasySelection not ] ])
		ifTrue: [ 
			evt wasHandled: false.
			^ self ].	"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 shiftPressed or: [ self wantsEasySelection ])
		ifTrue: [ 
			| clickSelector |
			evt shiftPressed
				ifTrue: [ clickSelector := #popUpContentsMenu: ]
				ifFalse: [ clickSelector := #invokeWorldMenu: ].
			evt hand
				waitForClicksOrDrag: self
				event: evt
				selectors:
					{clickSelector.
					nil.
					nil.
					#dragThroughOnDesktop:}
				threshold: 5 ]
		ifFalse: [ self invokeWorldMenu: evt ]	"We'll select on drag, let's decide what to do on click"	"We wont select, just bring world menu if I'm the world"! !

!PasteUpMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	^ true "handle all not handled events"! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: ''!
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: '*Morphic-Base' stamp: ''!
makeAScreenshot
	| filePrefix |
	filePrefix := 'PharoScreenshot'.
	(UIManager default
		chooseFrom: {'The entire world' translated . 'A selected area' translated}
		values: #(#world #area)
		message: 'What do you want to shoot? (File will be saved in image directory)' translated
		title: 'Make a screenshot')
		ifNotNil: [ :choice | 
			| form name |
			form := choice = #world ifTrue: [ self world imageForm ] ifFalse: [ Form fromUser ].
			name := (FileSystem workingDirectory / filePrefix , 'png') nextVersion.
			PNGReadWriter putForm: form onFileNamed: (FileSystem workingDirectory / filePrefix , 'png') nextVersion.
			UIManager default
				inform:
					(String
						streamContents: [ :s | 
							s
								nextPutAll: 'Screenshot saved under ';
								nextPutAll: name fullName;
								cr;
								nextPutAll: 'Click to open location' ])
				actionOnClick: [ name openInOSFileBrowser ] ]! !

!PasteUpMorph methodsFor: 'accessing' stamp: ''!
removeModalWindow
	self modalWindow: nil! !

!PasteUpMorph methodsFor: 'wiw support' stamp: ''!
shouldGetStepsFrom: aWorld
	(self isWorldMorph and: [owner notNil]) 
		ifTrue: [ ^self outermostWorldMorph == aWorld ].
	^super shouldGetStepsFrom: aWorld! !

!PasteUpMorph methodsFor: 'session management' stamp: ''!
checkSession

	"do nothing"! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
previousWindow
	"Answer the previous window to navigate to."

	|sys|
	sys := self systemWindows.
	sys ifEmpty: [^nil].
	^sys before: self currentWindow ifAbsent: [sys last]! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
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: '*Morphic-Widgets-Taskbar' stamp: ''!
moveCollapsedWindowsToTaskbar
	"Move collapsed windows to the taskbar."
	
	(self systemWindows select: [:w | w isCollapsed]) do: [:w |
		w restore; minimize]! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: ''!
wantsDroppedMorph: aMorph event: evt
	
	self visible ifFalse: [^ false].  "will be a call to #hidden again very soon"
	self dropEnabled ifFalse: [^ false].
	^ true! !

!PasteUpMorph methodsFor: '*Tool-Base' stamp: ''!
defaultDesktopCommandKeyTriplets
	"Answer a list of triplets of the form
		<key> <receiver> <selector>   [+ optional fourth element, a <description> 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"
	self flag: #problem. 
	"there is clearly a problem because not all the tools can be loaded."
 
	^ {
		{ $r.	self world.						#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'}.
		{ $W.	Smalltalk tools finder. 				#open.						         		  	'Open a new Finder'}.
		{ $Z.	Smalltalk tools changeList. 			#browseRecentLog.						'Browse recently-logged changes'}.
		{ $\.	SystemWindow. 					#sendTopWindowToBack.					'Send the top window to the back'}.
	}.
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: ''!
popUpContentsMenu: 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 |
	menu := UIManager default newMenuIn: self for: self.
	self contentsMenu: menu.
	menu buildTitle: [ :titleMorph |
		titleMorph bigTitle: self contentsMenuTitle
	];
	popUpEvent: evt in: (self world ifNil: [self]).! !

!PasteUpMorph methodsFor: 'drawing' stamp: ''!
drawGridOn: aCanvas

	(self griddingOn and: [ self gridVisible ])
		ifTrue: [ 
			aCanvas
				fillRectangle: self bounds
				fillStyle:
					(self
						gridFormOrigin: self gridOrigin
						grid: self gridModulus
						background: nil
						line: Color lightGray) ]! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: ''!
dispatchKeystroke: anEvent
	anEvent keyCharacter == Character tab
		ifTrue: [ 
			self tabAmongFields
				ifTrue: [ ^ self tabHitWithEvent: anEvent ] ]! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
navigateWindowBackward
	"Change the active window to the previous window."

	self previousWindow ifNotNil: [:m |
		m isCollapsed ifTrue: [m collapseOrExpand].
		m activate]! !

!PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: ''!
closeAllWindowsDiscardingChanges
	self world systemWindows do: [:w | [w delete] valueSupplyingAnswer: false]! !

!PasteUpMorph methodsFor: 'world state' stamp: ''!
restoreMainDockingBarDisplay
	"Restore the display of docking bars"
	self dockingBars
		do: [:each | each updateBounds]! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
worldMenu
	^ owner worldMenu! !

!PasteUpMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!PasteUpMorph methodsFor: 'accessing' stamp: ''!
backgroundMorph
	"Answer the background morph if any."
	
	^backgroundMorph! !

!PasteUpMorph methodsFor: 'gridding' stamp: ''!
setGridSpec
	"Gridding rectangle provides origin and modulus"
	| response result |
	response := UIManager default
			request: 'New grid origin (usually 0@0):' translated
			initialAnswer: self gridOrigin printString.
	response isEmpty ifTrue: [^ self].
	result := [self class compiler evaluate: response] onErrorDo: [^ self].
	(result isPoint and: [(result >= (0@0))])
		ifTrue: [self gridOrigin: result]
		ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )].

	response := UIManager default
			request: 'New grid spacing:' translated
			initialAnswer: self gridModulus printString.
	response isEmptyOrNil ifTrue: [^ self].
	result := [self class compiler evaluate: response] onErrorDo: [^ 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: '*Polymorph-Widgets' stamp: ''!
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: 'wiw support' stamp: ''!
addMorphInLayer: aMorph
	super addMorphInLayer: aMorph.
	aMorph wantsToBeTopmost ifFalse:[self bringTopmostsToFront].! !

!PasteUpMorph methodsFor: 'event handling' stamp: ''!
windowEventHandler
	"This is a class variable so it is global to all projects and does not get saved"
	^WindowEventHandler! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
systemWindows
	"Answer the system windows in the world."
	
	^self submorphsSatisfying: [:m | m isSystemWindow]! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
fitAllVisibleWindows
	"Fit all windows as visible"
	|allowedArea|
	allowedArea := RealEstateAgent maximumUsableAreaInWorld: self 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: 'menu & halo' stamp: ''!
contentsMenuTitle
	^ 'Contents' translated! !

!PasteUpMorph methodsFor: 'drawing' stamp: ''!
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: 'gridding' stamp: ''!
gridModulus

	^ self gridSpec extent! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
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 state' stamp: ''!
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 menu' stamp: ''!
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: 'gridding' stamp: ''!
gridOrigin

	^ self gridSpec origin! !

!PasteUpMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"
	
	super initialize.
	self enableDragNDrop.
	self clipSubmorphs: true! !

!PasteUpMorph methodsFor: 'event handling' stamp: ''!
acceptDroppingMorph: dropped event: evt
	"The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied"

	| aMorph |
	aMorph := self morphToDropFrom: dropped.
	super acceptDroppingMorph: aMorph event: evt.
	aMorph
		submorphsDo: [ :m | 
			m isHaloMorph
				ifTrue: [ m delete ] ].
	self bringTopmostsToFront! !

!PasteUpMorph methodsFor: 'gridding' stamp: ''!
gridVisibleString
	"Answer a string to be used in a menu offering the opportunity 
	to show or hide the grid"
	^ (self gridVisible
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'show grid when gridding' translated! !

!PasteUpMorph methodsFor: 'options' stamp: ''!
toggleResizeToFit
	"Toggle whether the receiver is set to resize-to-fit"

	self vResizeToFit: self resizeToFit not! !

!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
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: 'event handling' stamp: ''!
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: ''!
keyStroke: anEvent
	"A keystroke has been made.  Service event handlers and, if it's a keystroke presented to the world, dispatch it to #unfocusedKeystroke:"

	super keyStroke: anEvent.	"Give event handlers a chance"
	self selectedObject ifNotNil: [ :selected | selected moveOrResizeFromKeystroke: anEvent ].
	self dispatchKeystroke: anEvent! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: ''!
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: '*Morphic-Widgets-Windows' stamp: ''!
isWindowActive: aSystemWindow
	"Answer whether the given window is active.
	True if the current top window."
	
	^self currentWindow == aSystemWindow! !

!PasteUpMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.8
		g: 1.0
		b: 0.6! !

!PasteUpMorph methodsFor: 'submorphs - add/remove' stamp: ''!
addMorphFront: aMorph

	^self addMorphInFrontOfLayer: aMorph! !

!PasteUpMorph methodsFor: 'event handling' stamp: ''!
wantsWindowEvent: anEvent
	^ self windowEventHandler notNil! !

!PasteUpMorph methodsFor: '*Morphic-Base' stamp: ''!
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: 'drawing' stamp: ''!
drawOn: aCanvas 
	"Draw in order:
	- background color
	- grid, if any
	- background sketch, if any
	Later (in drawSubmorphsOn:) I will skip drawing the background sketch."

	super drawOn: aCanvas.	
	self drawGridOn: aCanvas.
	self drawBackgroundSketchOn: aCanvas! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
navigateVisibleWindowForward
	"Change the active window to the next visible and not collapsed window."
 
	self nextVisibleWindow
		ifNil: [SystemWindow passivateTopWindow]
		ifNotNil: [:m | m activate]! !

!PasteUpMorph methodsFor: 'accessing' stamp: ''!
modalWindow: aMorph
	(self valueOfProperty: #modalWindow) ifNotNil: [ :morph | morph delete ].
	self setProperty: #modalWindow toValue: aMorph.
	aMorph ifNotNil: [ self when: #aboutToLeaveWorld send: #removeModalWindow to: self ]! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
nextVisibleWindow
	"Answer the next (visible) window to navigate to."

	^self visibleSystemWindows 
		ifEmpty: [ nil ] 
		ifNotEmpty: [ :windows | 
			windows after: self currentWindow ifAbsent: [windows first]
		]! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
removeTaskbar
	"Remove the receiver's taskbars."
	
	self taskbars do: [:each | each removeFromWorld]! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
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: 'thumbnail' stamp: ''!
icon
	^ self iconNamed: #homeIcon! !

!PasteUpMorph methodsFor: 'world state' stamp: ''!
flashRects: rectangleList color: aColor
	"For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work."
	"Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode."

	| blt |
	blt := (BitBlt toForm: Display)
		sourceForm: nil;
		sourceOrigin: 0@0;
		clipRect: self viewBox;
		combinationRule: Form reverse.
	rectangleList do: [:r | | screenRect |
		screenRect := r translateBy: self viewBox origin.
		blt destRect: screenRect; copyBits.
		(Delay forMilliseconds: 15) wait.
		blt destRect: screenRect; copyBits ].! !

!PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: ''!
collapseAll
	"Collapse all windows"
	(self windowsSatisfying: [:w | w isCollapsed not])
		reverseDo: [:w | w collapseOrExpand.  self displayWorld].
	self collapseNonWindows! !

!PasteUpMorph methodsFor: 'caching' stamp: ''!
releaseCachedState
	super releaseCachedState.
	self removeModalWindow.! !

!PasteUpMorph methodsFor: 'stepping' stamp: ''!
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 world stepListSize.
	self world steppingMorphsNotInWorld
		do: [:m | m delete].
	self world cleanseStepList.
	(delta := old - self world stepListSize) > 0
		ifTrue: [ self crTrace: delta asString , ' morphs removed from steplist' ]! !

!PasteUpMorph methodsFor: 'event handling' stamp: ''!
wantsKeyboardFocusFor: aSubmorph

	aSubmorph wouldAcceptKeyboardFocus ifTrue: [ ^ true].
	^ super wantsKeyboardFocusFor: aSubmorph! !

!PasteUpMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: aCanvas 
	"Draw in order:
	- background color
	- background sketch, if any
	- Update and draw the turtleTrails form. See the comment in updateTrailsForm.

	Later (in drawSubmorphsOn:) I will skip drawing the background sketch."

	"draw background fill"
	super drawOnAthensCanvas: aCanvas.

	backgroundMorph ifNotNil: [
		aCanvas clipBy: self clippingBounds
			during: [ aCanvas fullDrawMorph: backgroundMorph ]
	]! !

!PasteUpMorph methodsFor: 'gridding' stamp: ''!
griddingOnOff

	griddingOn := self griddingOn not.
	self changed! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
lastKeystroke: aString	
	"Remember the last keystroke fielded by the receiver"	
	^ self setProperty: #lastKeystroke toValue: aString! !

!PasteUpMorph methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
createTaskbarIfNecessary
	"Private - create a new taskbar if not present."

	self taskbars ifEmpty: [
		TaskbarMorph new openInWorld: self.
		self moveCollapsedWindowsToTaskbar]! !

!PasteUpMorph methodsFor: 'accessing' stamp: ''!
windowsSatisfying: windowBlock

	| windows |
	windows := OrderedCollection new.
	self submorphs do: [:m | 
		m embeddedWindowOrNil ifNotNil: [ 
			(windowBlock value: m) 
				ifTrue: [ windows addLast: m ] ] ].
		
	^ windows.! !

!PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: ''!
closeAllUnchangedWindows
	(self  windowsSatisfying: [:w | w model canDiscardEdits])
		do: [:w | w delete]! !

!PasteUpMorph methodsFor: 'project state' stamp: ''!
viewBox: newViewBox 
	"I am now displayed within newViewBox; react."

	super position: newViewBox topLeft.
	fullBounds := bounds := newViewBox.! !

!PasteUpMorph methodsFor: 'event handling' stamp: ''!
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 |
	numFiles := anEvent contents.
	1 to: numFiles do: [ :i | 
		| aFileReference handler |
		aFileReference := anEvent requestDropReference: i.
		handler := ExternalDropHandler
			lookupExternalDropHandler: aFileReference.
		handler
			ifNotNil: [ handler handle: aFileReference in: self dropEvent: anEvent ] ]! !

!PasteUpMorph methodsFor: 'gridding' stamp: ''!
gridSpec
	"Gridding rectangle provides origin and modulus"

	^ self valueOfProperty: #gridSpec ifAbsent: [0@0 extent: 8@8]! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: ''!
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 selector: trip second.
			aMenu balloonTextForLastItem: trip third]! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
invokeWorldMenuFromEscapeKey
	self invokeWorldMenu: self activeHand lastEvent! !

!PasteUpMorph methodsFor: 'world menu' stamp: ''!
invokeWorldMenu: evt
	"Put up the world menu, triggered by the passed-in event."
	| menu |
	
	"If the user does not want a world menu, do not invoke it."
	self class shouldShowWorldMenu ifFalse: [ ^ self ].
	
	self bringTopmostsToFront.
	"put up screen menu"
	(menu := self worldMenu) popUpEvent: evt in: self.
	^ menu! !

!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
navigationKey: aKeyboardEvent
	
	^ self taskList handleEvent: aKeyboardEvent.! !

!PasteUpMorph methodsFor: 'drawing' stamp: ''!
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: 'gridding' stamp: ''!
gridModulus: newModulus

	self gridSpecPut: (self gridOrigin extent: newModulus).
	self changed! !

!PasteUpMorph class methodsFor: 'class initialization' stamp: ''!
initialize
	ShouldSwapMenuOpenerButtons := false.
	self shouldShowWorldMenu: true! !

!PasteUpMorph class methodsFor: 'settings' stamp: ''!
shouldSwapMenuOpenerButtonsSetting: aBuilder
	<systemsettings>
	(aBuilder setting: #shouldSwapMenuOpenerButtons)
		label: 'Invert right and left click on world menu in Linux and Windows';
		parent: #desktopSettings;
		target: self;
		getSelector: #shouldSwapMenuOpenerButtons;
		setSelector: #shouldSwapMenuOpenerButtons:;
		description:
				'If checked the behaviour of the world menu is changed only under Linux and Windows. The main menu will appear on right click instead of left click.';
		default: false! !

!PasteUpMorph class methodsFor: 'accessing' stamp: ''!
shouldSwapMenuOpenerButtons
	^ ShouldSwapMenuOpenerButtons! !

!PasteUpMorph class methodsFor: 'accessing' stamp: ''!
shouldSwapMenuOpenerButtons: aBoolean
	^ ShouldSwapMenuOpenerButtons := aBoolean! !

!PasteUpMorph class methodsFor: 'testing' stamp: ''!
isMenuOpenByLeftClick
	"Truth table:
	swap 	isMac	methodReturn
	0	 	0	 	1
	0	 	1	 	1
	1	 	0	 	0
	1	 	1 		1
"

	^ self shouldSwapMenuOpenerButtons ==> [ Smalltalk os isMacOS ]! !

!PasteUpMorph class methodsFor: 'settings' stamp: ''!
shouldShowWorldMenuSettingOn: aBuilder
	<systemsettings>
	(aBuilder setting: #shouldShowWorldMenu)
		target: self;
		default: true;
		parent: #morphic;
		label: 'Show world menu';
		description: 'Whether the World''s world menu should be shown or not on a click in the World.'! !

!PasteUpMorph class methodsFor: 'accessing' stamp: ''!
shouldShowWorldMenu
	^ ShouldShowWorldMenu! !

!PasteUpMorph class methodsFor: 'accessing' stamp: ''!
shouldShowWorldMenu: anObject
	ShouldShowWorldMenu := anObject! !

!Path commentStamp: ''!
I'm a private and abstract filesystem path, independent of the string representation used to describe paths on a specific filesystem. I provide methods for navigating the filesystem hierarchy and working with absolute and relative paths. I only refer to a concrete file or directory with regard to a specific filesystem. Normally users should not use me directly. 

API instance creation:

- #from: parses the supplied string using the default delimeter
- #from:delimiter: parses the supplied string using the supplied delimiter.
- #/ creates an absolute path from the supplied string
- #* creates a relative path from the supplied string

API path manipulation:

- #/ adds the supplied string to the receiver
!
!Path methodsFor: 'comparing' stamp: ''!
hash
	| hash |
	hash := self class identityHash.
	1 to: self size do:
		[:i | hash := String stringHash: (self at: i) initialHash: hash].
	^ hash! !

!Path methodsFor: 'accessing' stamp: ''!
delimiter
	^ $/! !

!Path methodsFor: 'private' stamp: ''!
copyFrom: aPath
	| size |
	size := aPath size min: self size.
	1 to: size do: [:i | self at: i put: (aPath at: i)].! !

!Path methodsFor: 'navigating' stamp: ''!
/ aString
	"aString is either a file or path.  If aString is relative, it is appended to the receiver, if it is absolute, an instance of the receiver with the path is answered"

	aString isEmptyOrNil 
		ifTrue: [ Error signal: 'Path element cannot be empty or nil'].

	^self resolvePath: (self class from: aString)! !

!Path methodsFor: 'testing' stamp: ''!
isRoot
	self subclassResponsibility! !

!Path methodsFor: 'navigating' stamp: ''!
asResolvedBy: anObject
	^ anObject resolvePath: self! !

!Path methodsFor: 'accessing' stamp: ''!
basename
	"Returns the base of the basename, 
		i.e. 
		/foo/gloops.taz basename is 'gloops.taz'
		If empty, it is the emptyPathString"

	self isEmpty ifTrue: 
		[ ^ self emptyPathString ].
	^ self at: self size! !

!Path methodsFor: 'navigating' stamp: ''!
resolveString: aString
	"Treat strings as relative paths with a single element."
	
	^ self / aString! !

!Path methodsFor: 'enumerating' stamp: ''!
do: aBlock 
	1 
		to: self size
		do: 
			[ :index || segment |
			segment := self at: index.
			segment isEmpty ifFalse: [ aBlock value: segment ] ]! !

!Path methodsFor: 'testing' stamp: ''!
isRelative
	^ self isAbsolute not! !

!Path methodsFor: 'printing' stamp: ''!
pathString
	"Return a string containing the path elements of the receiver, without the 'Path *' part"

	"((FileSystem workingDirectory / 'book-result' / 'W01-Welcome') relativeToReference: FileSystem workingDirectory) pathString >>> 'book-result/W01-Welcome'"

	^String streamContents: [ :stream | 
		self printPathOn: stream delimiter: self delimiter ]! !

!Path methodsFor: 'accessing' stamp: ''!
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: 'navigating' stamp: ''!
relativeTo: anObject
	^ anObject makeRelative: self! !

!Path methodsFor: 'printing' stamp: ''!
printOn: aStream delimiter: aCharacter
	(1 to: self size)
		do: [:index | aStream nextPutAll: (self at: index)]
		separatedBy: [aStream nextPut: aCharacter]! !

!Path methodsFor: 'testing' stamp: ''!
isAbsolute
	self subclassResponsibility! !

!Path methodsFor: 'navigating' stamp: ''!
resolve
	^ self! !

!Path methodsFor: 'navigating' stamp: ''!
parentUpTo: aParentDirName
	"Answers the path of the parent dir with name aParentDirName or root if not found."

	self withParents
		reverseDo: [ :dir | 
			dir basename = aParentDirName
				ifTrue: [ ^ dir ] ].
	^ Path root! !

!Path methodsFor: 'comparing' stamp: ''!
isContainedBy: anObject
	"DoubleDispatch helper for #contains:"
	^ anObject containsPath: self! !

!Path methodsFor: 'navigating' stamp: ''!
makeRelative: anObject
	^ anObject relativeToPath: self! !

!Path methodsFor: 'navigating' stamp: ''!
relativeToPath: aPath
	"Return the receiver as relative to the argument aPath"

	"(Path / 'griffle' / 'plonk' / 'nurp') 
		relativeToPath: (Path / 'griffle') 
			returns  plonk/nurp"

	| prefix relative |
	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: 'accessing' stamp: ''!
emptyPathString
	"Answer the string representing an empty (size = 0) instance of the receiver"

	^self delimiter asString! !

!Path methodsFor: 'testing' stamp: ''!
isEmpty
	^ self size = 0! !

!Path methodsFor: 'comparing' stamp: ''!
contains: anObject
	"Return true if anObject is in a subfolder of me"
	^ anObject isContainedBy: self! !

!Path methodsFor: 'comparing' stamp: ''!
= 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: 'converting' stamp: ''!
asPathWith: anObject
	^ self! !

!Path methodsFor: 'accessing' stamp: ''!
extensionDelimiter
	^ self class extensionDelimiter! !

!Path methodsFor: 'accessing' stamp: ''!
basenameWithoutExtension: anExtension
	"Returns the basename without specified extension (if any)
	('/foo/gloops.taz' asPath basenameWithoutExtension: 'taz') = 'gloops'
	"
	| extensionWithDelimiter |

	extensionWithDelimiter := anExtension copyWithFirst: self extensionDelimiter.
	(self basename endsWith: extensionWithDelimiter)
		ifTrue: [^ self basename allButLast: extensionWithDelimiter size]
		ifFalse: [ ^ self basename ]! !

!Path methodsFor: 'printing' stamp: ''!
printWithDelimiter: aCharacter
	^ String streamContents: [:out | self printOn: out delimiter: aCharacter]! !

!Path methodsFor: 'navigating' stamp: ''!
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: 'accessing' stamp: ''!
segments
	"return an array with all the path segements separated"
	| segments |
	
	segments := OrderedCollection new.
	
	self do: [ :part|
		segments add: part
	].
	
	^ segments asArray! !

!Path methodsFor: 'enumerating' stamp: ''!
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: ''!
canonicalize
	"Answer the receiver with references to the current folder (.) and parent folder (..) removed"
	
	^self class withAll: (self class canonicalizeElements: self segments).! !

!Path methodsFor: 'private' stamp: ''!
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: 'accessing' stamp: ''!
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: 'navigating' stamp: ''!
parent
	| size parent |
	self isRoot ifTrue: [^ self].
	(self isEmpty or: [ (self at: self size) = '..' ]) ifTrue: [^ self / '..'].
	
	size := self size - 1.
	parent := self class new: size.
	1 to: size do: [:i | parent at: i put: (self at: i)].
	^ parent! !

!Path methodsFor: 'printing' stamp: ''!
printPathOn: aStream
	"Print the receiver's path on aStream (without 'Path' prepended) using the default delimiter"
	"(String streamContents: [ :str| ((FileSystem workingDirectory / 'book-result' / 'W01-Welcome') relativeToReference: FileSystem workingDirectory) printPathOn: str]) >>> 'book-result/W01-Welcome'"

	self printPathOn: aStream delimiter: self delimiter.! !

!Path methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter 
		writeObject: self 
		streamShortList: [ :listWriter | 
			self do: [ :each | listWriter add: each ] ]! !

!Path methodsFor: 'accessing' stamp: ''!
fullName
	"Return the fullName of the receiver."
	
	^ self pathString! !

!Path methodsFor: 'private' stamp: ''!
withName: name extension: extension
	| basename |
	basename :=String streamContents:
		[:out |
		out nextPutAll: name.
		out nextPut: self extensionDelimiter.
		out nextPutAll: extension].
	^ self copy 
		at: self size put: basename;
		yourself! !

!Path methodsFor: '*FileSystem-Core' stamp: ''!
asFileLocatorOrReference

	^ FileLocator fromPath: self ifNone: [ self asFileReference ]! !

!Path methodsFor: 'testing' stamp: ''!
isNetworkPath

	^ false! !

!Path methodsFor: 'printing' stamp: ''!
printPathOn: aStream delimiter: aCharacter
	"Print the receiver's path on aStream (without 'Path' prepended)"
	"(String streamContents: [ :str| ((FileSystem workingDirectory / 'book-result' / 'W01-Welcome') relativeToReference: FileSystem workingDirectory) printPathOn: str delimiter: $|]) >>> 'book-result|W01-Welcome'"

	(1 to: self size)
		do: [:index | aStream nextPutAll: (self at: index)]
		separatedBy: [aStream nextPut: aCharacter]! !

!Path methodsFor: '*FileSystem-Core' stamp: ''!
relativeToReference: aReference 
	^ self relativeToPath: aReference path! !

!Path methodsFor: 'accessing' stamp: ''!
extension
	"Return the extension of path basename i.e., /foo/gloops.taz extension is 'taz'"
	
	^ self basename copyAfterLast: self extensionDelimiter! !

!Path methodsFor: 'navigating' stamp: ''!
resolveReference: aReference
	^ aReference! !

!Path methodsFor: '*FileSystem-Core' stamp: ''!
asFileReference
	^ FileSystem disk referenceTo: self! !

!Path methodsFor: 'comparing' stamp: ''!
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: ''!
containsReference: aReference
	^ false! !

!Path methodsFor: 'navigating' stamp: ''!
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: 'testing' stamp: ''!
isWorkingDirectory
	^ self size = 0! !

!Path methodsFor: 'navigating' stamp: ''!
, extension 
	^ self withName: self basename extension: extension! !

!Path methodsFor: 'converting' stamp: ''!
asPath
	^ self! !

!Path methodsFor: 'accessing' stamp: ''!
base
	^self basenameWithoutExtension! !

!Path methodsFor: 'accessing' stamp: ''!
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: 'comparing' stamp: ''!
isChildOf: anObject
	^ self parent = anObject! !

!Path methodsFor: 'navigating' stamp: ''!
resolvePath: aPath
	"Answers a path created by resolving the argument against the receiver.
	If the argument is abolute answer the argument itself. Otherwise, concatenate the
	two paths."

	| 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: elements! !

!Path methodsFor: 'comparing' stamp: ''!
<= other
	^ self fullName <= other fullName! !

!Path class methodsFor: 'private' stamp: ''!
addParentElementTo: result
	(result isEmpty or: [ result last = '..' ])
		ifTrue: [ result add: '..' ]
		ifFalse: [ result removeLast ]! !

!Path class methodsFor: 'instance creation' stamp: ''!
* 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: 'private' stamp: ''!
addEmptyElementTo: result
	result isEmpty ifTrue: [result add: '']! !

!Path class methodsFor: 'private' stamp: ''!
addElement: element to: result
	element = '..'
		ifTrue: [ ^ self addParentElementTo: result ].
	element = ''
		ifTrue: [ ^ self addEmptyElementTo: result ].
	element = '.'
		ifFalse: [ result add: element ]! !

!Path class methodsFor: 'encodings' stamp: ''!
delimiter
	"Internal path delimiter"

	^$/! !

!Path class methodsFor: 'encodings' stamp: ''!
extensionDelimiter
	"Return the extension delimiter character."
	^ $.! !

!Path class methodsFor: 'instance creation' stamp: ''!
/ aString
	"Answer an absolute path with aString as it's sole segment. The selector
	was chosen to allow path construction with Smalltalk syntax, which 
	neverthelesss resembles paths as they appear in a unix shell. Eg.
	Path / 'griffle' / 'plonk'."
	
	aString isEmptyOrNil 
		ifTrue: [ Error signal: 'Path element cannot be empty or nil'].
	^ AbsolutePath with: aString! !

!Path class methodsFor: 'private' stamp: ''!
canonicalizeElements: aCollection
	| result |
	result := OrderedCollection new.
	aCollection do: [ :element |
		self addElement: element to: result].
	^ result! !

!Path class methodsFor: 'instance creation' stamp: ''!
from: aString
	"Answer an instance of the receiver with the supplied path using the default delimiter"

	^ self from: aString delimiter: self delimiter! !

!Path class methodsFor: 'instance creation' stamp: ''!
from: aString delimiter: aDelimiterCharacter 
	"Answer a path composed of several elements delimited by aCharacter"
	| pathClass |
	aString isEmpty
		ifTrue: [ ^ self root ].
	
	pathClass :=  ((self isAbsolutePath: aString delimiter: aDelimiterCharacter) or: 
							[self isAbsoluteWindowsPath: aString]) 
		ifTrue: [ 
			((aString size >= 2) and: [ aString second = aDelimiterCharacter ])
				ifTrue: [ UNCNetworkPath ]
				ifFalse: [AbsolutePath] ]
		ifFalse:[ RelativePath ].
	
	^ pathClass withAll: (aDelimiterCharacter split: aString)! !

!Path class methodsFor: 'private' stamp: ''!
withAll: aCollection
	"Answer an instance of the receiver representing the supplied collection of strings.
	This should only be sent to one of the concrete subclasses, e.g. AbsolutePath and RelativePath"
	| inst parsedCollection |

	parsedCollection := OrderedCollection new: (aCollection size max: 10).
	aCollection do: [ :each |
		parsedCollection addAll: (self delimiter split: each) ].
	parsedCollection := self removeRedundantSegments: parsedCollection.
	inst := self new: parsedCollection size.
	parsedCollection withIndexDo: [:segment :index |
		inst at: index put: segment].
	^ inst! !

!Path class methodsFor: 'private' stamp: ''!
removeRedundantSegments: segments
	"Remove redundant elements ('.' and '') from the supplied segments"

	^segments select:
		[ :segment | segment notEmpty and: [ segment ~= '.' ] ]! !

!Path class methodsFor: 'instance creation' stamp: ''!
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: ''!
root
	"Answer the root path - ie, / on unix"
	
	^ AbsolutePath new! !

!Path class methodsFor: 'instance creation' stamp: ''!
workingDirectory
	"Answer a path that will always resolve to the current working directory."
	
	^ RelativePath new! !

!Path class methodsFor: 'private' stamp: ''!
isAbsolutePath: aString delimiter: aCharacter
	"Answer a boolean indicating whether the supplied path is considered absolute"

	^ aString first = aCharacter! !

!Path class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	| elements |
	elements := Array streamContents: [ :out |
		stonReader parseListDo: [ :each | out nextPut: each ] ].
	^ self withAll: elements! !

!Path class methodsFor: 'private' stamp: ''!
with: aString
	"Answer an instance of the receiver representing the supplied string.
	This should only be sent to one of the concrete subclasses, e.g. AbsolutePath and RelativePath"
	| inst parsedCollection |

	parsedCollection := self delimiter split: aString.
	parsedCollection := self removeRedundantSegments: parsedCollection.
	inst := self new: parsedCollection size.
	parsedCollection withIndexDo: [:segment :index |
		inst at: index put: segment].
	^ inst! !

!Path class methodsFor: 'private' stamp: ''!
isAbsoluteWindowsPath: aString

	aString ifEmpty: [ ^ false ].
	(aString first = $\ and: [ 
		 aString size = 1 or: [ aString second ~= $\ ] ]) ifTrue: [ ^ true ]. "e.g. \file"

	^ (aString size > 2 and: [ aString first isLetter ])
		  ifTrue: [ "e.g. C:\..." 
		  aString second = $: and: [ aString third = $\ ] ]
		  ifFalse: [ false ]! !

!Path class methodsFor: 'private' stamp: ''!
isAbsoluteUnixPath: aString
	^aString first = $/! !

!Path class methodsFor: 'instance creation' stamp: ''!
parents: anInteger
	| path |
	path := self new: anInteger.
	1 to: anInteger do: [:i | path at: i put: '..'].
	^ path! !

!PathShape commentStamp: ''!
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: 'adding' stamp: ''!
addVertex: aPoint
	"Add a vertex to the path."

	self vertices add: aPoint.
	self basicBounds ifNotNil: [
		self bounds: (self bounds quickMergePoint: aPoint)]! !

!PathShape methodsFor: 'accessing' stamp: ''!
bounds
	"Answer the bounds of the receiver."

	^bounds ifNil: [bounds := self calculatedBounds]! !

!PathShape methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		vertices: OrderedCollection new! !

!PathShape methodsFor: 'accessing' stamp: ''!
bounds: anObject
	"Set the value of bounds"

	bounds := anObject! !

!PathShape methodsFor: 'accessing' stamp: ''!
vertices
	"Answer the value of vertices"

	^ vertices! !

!PathShape methodsFor: 'compute' stamp: ''!
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: 'enumerating' stamp: ''!
segmentsDo: aBlock
	"Evaluate the two-argument block with each vertex and its successor."

	self vertices size < 2 ifTrue: [^self].
	1 to: self vertices size - 1 do: [:i |
		aBlock
			value: (self vertices at: i)
			value: (self vertices at: i + 1)]! !

!PathShape methodsFor: 'accessing' stamp: ''!
basicBounds
	"Answer the bounds of the receiver without lazy calculation."

	^bounds! !

!PathShape methodsFor: 'testing' stamp: ''!
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: 'accessing' stamp: ''!
vertices: aCollection
	"Set the value of vertices."

	vertices := aCollection asOrderedCollection.
	self bounds: nil! !

!PathShape class methodsFor: 'instance creation' stamp: ''!
vertices: aCollection
	"Answer a new instance of the receiver with the
	given vertices."

	^self new
		vertices: aCollection! !

!PathTest commentStamp: ''!
SUnit tests for file system paths!
!PathTest methodsFor: 'tests' stamp: ''!
testSimpleResolution
	| base relative absolute |
	base := Path / 'plonk'.
	relative := (Path * 'griffle') / 'zonk'.
	absolute := base resolve: relative.
	self assert: absolute isAbsolute.
	self assert: (absolute at: 1) equals: 'plonk'.
	self assert: (absolute at: 2) equals: 'griffle'.
	self assert: (absolute at: 3) equals: 'zonk'.! !

!PathTest methodsFor: 'tests' stamp: ''!
testRelativeFromString

	| path |
	
	path := Path from: 'plonk/griffle'.
	
	self assert: path isRelative.
	self assert: path size equals: 2.
	self assert: (path at: 1) equals: 'plonk'.
	self assert: (path at: 2) equals: 'griffle'! !

!PathTest methodsFor: 'tests' stamp: ''!
testParentParent
	| path  |
	path := (Path * '..') parent.
	self assert: path size equals: 2.
	self assert: (path at: 1) equals: '..'.
	self assert: (path at: 2) equals: '..'! !

!PathTest methodsFor: 'tests' stamp: ''!
testParentResolution
	| base relative absolute |
	base := Path / 'plonk' / 'pinto'.
	relative := Path parent / 'griffle' / 'zonk'.
	absolute := base resolve: relative.
	self assert: absolute isAbsolute.
	self assert: absolute segments equals: #('plonk' 'pinto' '..' 'griffle' 'zonk')! !

!PathTest methodsFor: 'tests' stamp: ''!
testPrintPathOnDelimiter

	| pathString pathSrc path |

	"Test a Relative path"
	"Use an unusal delimiter to check that the default isn't hardcoded anywhere"
	pathSrc := 'one|two|three'.
	path := Path from: pathSrc delimiter: $|.
	self assert: path isRelative.
	pathString := String streamContents: [ :stream | path printPathOn: stream delimiter: $| ].
	self assert: pathSrc equals: pathString.

	"Test an Absolute path"
	"Use an unusal delimiter to check that the default isn't hardcoded anywhere"
	pathSrc := '|one|two|three'.
	path := Path from: pathSrc delimiter: $|.
	self assert: path isAbsolute.
	pathString := String streamContents: [ :stream | path printPathOn: stream delimiter: $| ].
	self assert: pathSrc equals: pathString! !

!PathTest methodsFor: 'tests' stamp: ''!
testWindowsAbsolutePathName
  
	self assert: (Path from: 'A:\') isAbsolute.
	self assert: (Path from: 'c:\') isAbsolute.
	self assert: (Path from: 'c:\test') isAbsolute.! !

!PathTest methodsFor: 'tests' stamp: ''!
testIsAbsoluteWindowsPathReturnsTrueWhenWindowsAbsolutePathProvided
  
	self assert: (Path isAbsoluteWindowsPath: 'A:\').
	self assert: (Path isAbsoluteWindowsPath: 'c:\').
	self assert: (Path isAbsoluteWindowsPath: 'c:\test').! !

!PathTest methodsFor: 'tests' stamp: ''!
testParseNetworkPath

	| path |
	path := Path from: '//parent/child/grandChild' delimiter: $/.
	self assert: path size equals: 3.
	self assert: (path at: 1) equals: 'parent'.
	self assert: (path at: 2) equals: 'child'.
	self assert: (path at: 3) equals: 'grandChild'! !

!PathTest methodsFor: 'tests' stamp: ''!
testPrintPathOn

	| pathString pathSrc path |

	"Test a Relative path"
	pathSrc := 'one/two/three'.
	path := Path from: pathSrc.
	self assert: path isRelative.
	pathString := String streamContents: [ :stream | path printPathOn: stream ].
	self assert: pathSrc equals: pathString.

	"Test an Absolute path"
	pathSrc := '/one/two/three'.
	path := Path from: pathSrc.
	self assert: path isAbsolute.
	pathString := String streamContents: [ :stream | path printPathOn: stream ].
	self assert: pathSrc equals: pathString! !

!PathTest methodsFor: 'tests' stamp: ''!
testResolveString	

	| path result |
	path := Path * 'plonk'.
	result := path resolve: 'griffle'.
	self assert: result class equals: path class.
	self assert: result size equals: 2.
	self assert: (result at: 1) equals: 'plonk'.
	self assert: (result at: 2) equals: 'griffle'! !

!PathTest methodsFor: 'tests' stamp: ''!
testExtendingPath

	| ref |

	self should: [ '/a/b' asPath / '' ] raise: Error.
	self should: [ '/a/b' asPath / nil ] raise: Error.

	ref := '/a/b/c' asPath / 'd/e'.
	self assert: ref segments equals: #('a' 'b' 'c' 'd' 'e').

	ref := '/a/b/c' asPath / 'd/e'.
	self assert: ref parent segments equals: #('a' 'b' 'c' 'd').

	ref := '/a/b/c' asPath / '../d'.
	self assert: ref segments equals:  #('a' 'b' 'c' '..' 'd').

	ref := '/a/b/c' asPath / 'd/..'.
	self assert: ref segments equals: #('a' 'b' 'c' 'd' '..').

	ref := '/a/b/c' asPath / 'd/../e'.
	self assert: ref segments equals: #('a' 'b' 'c' 'd' '..' 'e').

	ref := '/a/b/c' asPath / './d'.
	self assert: ref segments equals: #('a' 'b' 'c' 'd').

	ref := '/a/b/c' asPath / 'd/.'.
	self assert: ref segments equals: #('a' 'b' 'c' 'd').

	ref := '/a/b/c' asPath / 'd/./e'.
	self assert: ref segments equals: #('a' 'b' 'c' 'd' 'e').! !

!PathTest methodsFor: 'tests' stamp: ''!
testExtensions
	self 
		assertCollection: (Path from: 'foo') extensions asArray
		equals: #().
	self
		assertCollection: (Path from: 'foo.tar') extensions asArray
		equals: #( 'tar' ).
	self
		assertCollection: (Path from: 'foo.tar.gz') extensions asArray
		equals: #( 'tar' 'gz').
	self
		assertCollection: (Path from: 'foo.1.tar.gz') extensions asArray
		equals: #( '1' 'tar' 'gz').! !

!PathTest methodsFor: 'tests' stamp: ''!
testWorkingDirectoryParent
	| path |
	path := Path workingDirectory parent.
	self assert: path size equals: 1.
	self assert: (path at: 1) equals: '..'! !

!PathTest methodsFor: 'tests' stamp: ''!
testNetworkPathWithParents
	| path allPaths |
	path := UNCNetworkPath withAll: #('machine' 'plonk' 'griffle' 'nurb').
	allPaths := path withParents.
	
	self assert: allPaths size equals: 4.
	self assert: allPaths first isRoot.
	self assert: allPaths second basename equals: 'plonk'.
	self assert: allPaths second size equals: 2.
	self assert: (allPaths second isChildOf: allPaths first).
	self assert: allPaths third basename equals: 'griffle'.
	self assert: allPaths third size equals: 3.
	self assert: (allPaths third isChildOf: allPaths second).
	self assert: allPaths fourth basename equals: 'nurb'.
	self assert: allPaths fourth size equals: 4.
	self assert: (allPaths fourth isChildOf: allPaths third).
	
	self assert: allPaths fourth equals: path.
	self assert: allPaths fourth identicalTo: path! !

!PathTest methodsFor: 'tests' stamp: ''!
testParent
	| path parent |
	path := (Path * 'plonk') / 'griffle'.
	parent := path parent.
	self assert: parent isRelative.
	self assert: (parent at: 1) equals: 'plonk'! !

!PathTest methodsFor: 'tests' stamp: ''!
testCommaAddsExtensionAgain
	| path result |
	path := Path * 'plonk.griffle'.
	result := path, 'nurp'.
	self assert: result basename equals: 'plonk.griffle.nurp'! !

!PathTest methodsFor: 'tests' stamp: ''!
testWithExtentionReplacesExtension
	| path result |
	path := Path * 'plonk.griffle'.
	result := path withExtension: 'griffle'.
	self assert: result basename equals: 'plonk.griffle'! !

!PathTest methodsFor: 'tests' stamp: ''!
testDotParent
	| path parent |
	path := (Path * 'plonk') / 'griffle' / '.'.
	parent := path parent.
	self assert: parent isRelative.
	self assert: parent segments equals: #(plonk).! !

!PathTest methodsFor: 'tests' stamp: ''!
testWorkingDirPrintString
	| path actual |
	path := Path workingDirectory. 
	actual := path printString.
	self assert: actual equals: 'Path workingDirectory'! !

!PathTest methodsFor: 'tests' stamp: ''!
testIsAbsolute
	self assert: (Path / 'plonk') isAbsolute! !

!PathTest methodsFor: 'tests' stamp: ''!
testIsNotRelative
	self deny: (Path / 'plonk') isRelative! !

!PathTest methodsFor: 'tests' stamp: ''!
testPrintRelativeWithParent
	| path |
	path := Path parent / 'foo'.
	self assert: (path printWithDelimiter: $/) equals: '../foo'! !

!PathTest methodsFor: 'tests' stamp: ''!
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: ''!
testParseTrailingSlash
	| path |
	path := Path from: 'griffle/' delimiter: $/.
	self assert: path size equals: 1.
	self assert: (path at: 1) equals: 'griffle'! !

!PathTest methodsFor: 'tests' stamp: ''!
testFullName

	| path |

	path := (FileSystem workingDirectory / 'book-result' / 'W01-Welcome')
				relativeToReference: FileSystem workingDirectory.
	self assert: path fullName equals: 'book-result/W01-Welcome'! !

!PathTest methodsFor: 'tests' stamp: ''!
testAbsoluteWithParents
	| path allPaths |
	path := Path / 'plonk' / 'griffle' / 'nurb'.
	allPaths := path withParents.
	
	self assert: allPaths size equals: 4.
	self assert: allPaths first isRoot.
	self assert: allPaths second basename equals: 'plonk'.
	self assert: allPaths second size equals: 1.
	self assert: (allPaths second isChildOf: allPaths first).
	self assert: allPaths third basename equals: 'griffle'.
	self assert: allPaths third size equals: 2.
	self assert: (allPaths third isChildOf: allPaths second).
	self assert: allPaths fourth basename equals: 'nurb'.
	self assert: allPaths fourth size equals: 3.
	self assert: (allPaths fourth isChildOf: allPaths third).
	
	self assert: allPaths fourth equals: path.
	self assert: allPaths fourth identicalTo: path! !

!PathTest methodsFor: 'tests' stamp: ''!
testBasename
	| path |
	path := Path * 'plonk' / 'griffle'.
	self assert: path basename equals: 'griffle'! !

!PathTest methodsFor: 'tests' stamp: ''!
testAbsolutePrintString
	
	| path actual |
	path := Path / 'plonk' / 'griffle'.
	actual := path printString.
	self assert: actual equals: 'Path / ''plonk'' / ''griffle'''! !

!PathTest methodsFor: 'tests' stamp: ''!
testRelativeFromStringNormalizationParent

	| path |
	
	path := Path from: 'plonk/../../griffle'.
	
	self assert: path isRelative.
	self assert: path size equals: 4.
	self assert: path segments equals: #('plonk' '..' '..' 'griffle')! !

!PathTest methodsFor: 'tests' stamp: ''!
testSiblingOfPath
	| griffle  nurb |
	griffle := Path / 'griffle'.
	nurb := Path / 'nurb'.
	self deny: (griffle isChildOf: nurb).
	self deny: (nurb isChildOf: griffle).! !

!PathTest methodsFor: 'tests' stamp: ''!
testBasenameNoParent
	| path |

	path := Path / 'griffle'.
	self assert: path parent basename equals: '/'.

	path := Path * 'griffle'.
	self assert: path parent basename equals: '.'.! !

!PathTest methodsFor: 'tests' stamp: ''!
testParentUpTo
	| a b c |
	a := Path / 'testParentUpTo' / 'A'.
	b := Path / 'testParentUpTo' / 'A' / 'B'.
	c := Path / 'testParentUpTo' / 'A' / 'B' / 'C'.
	self assert: b equals: (c parentUpTo: 'B').
	self assert: a equals: (c parentUpTo: 'A').
	self assert: Path / 'testParentUpTo' equals: (c parentUpTo: 'testParentUpTo').
	self assert: Path root equals: (c parentUpTo: 'notAParent')! !

!PathTest methodsFor: 'tests' stamp: ''!
testAsReference
	| path reference |
	path := Path * 'plonk'.
	reference := path asFileReference.
	self assert: reference class equals: FileReference.
	self assert: reference path equals: path! !

!PathTest methodsFor: 'tests' stamp: ''!
testPrintWithDelimiter
	| path |
	path := (Path * 'plonk') / 'griffle'.
	self assert: (path printWithDelimiter: $%) equals: 'plonk%griffle'! !

!PathTest methodsFor: 'tests' stamp: ''!
testParse

	| path |
	path := Path from: 'parent/child/grandChild' delimiter: $/.
	self assert: path size equals: 3.
	self assert: (path at: 1) equals: 'parent'.
	self assert: (path at: 2) equals: 'child'.
	self assert: (path at: 3) equals: 'grandChild'! !

!PathTest methodsFor: 'tests' stamp: ''!
testCommaAddsExtension
	| path result |
	path := Path * 'plonk' .
	result := path, 'griffle'.
	self assert: result basename equals: 'plonk.griffle'! !

!PathTest methodsFor: 'tests' stamp: ''!
testIsRelative
	self assert: (Path * 'plonk') isRelative! !

!PathTest methodsFor: 'tests' stamp: ''!
testUnixAbsolutePathName

	self assert: (Path from: '/test') isAbsolute.
	self assert: (Path from: '/etc/bin') isAbsolute.! !

!PathTest methodsFor: 'tests' stamp: ''!
testRelativeTo
	"aPath relativeTo: aParent returns a new path relative to the parent"
	
	| parent child relative |
	parent := Path / 'griffle'.
	child := Path / 'griffle' / 'plonk' / 'nurp'.
	relative := child relativeTo: parent.
	self assert: relative equals: (Path * 'plonk' / 'nurp')! !

!PathTest methodsFor: 'tests' stamp: ''!
testWithExtentionAddsExtension
	| path result |
	path := Path * 'plonk'.
	result := path withExtension: 'griffle'.
	self assert: result basename equals: 'plonk.griffle'! !

!PathTest methodsFor: 'tests' stamp: ''!
testMakeRelativeFrom2RelativePaths
	"Related to issue: 14846 MakeRelative-method-applied-on-two-relative-paths-is-not-working"

	| parent child relative |
	parent := RelativePath new / 'griffle' / 'bibb'.
	child := RelativePath new / 'griffle' / 'plonk' / 'nurp'.
	relative := parent makeRelative: child.
	self assert: relative equals: Path parent / 'plonk' / 'nurp'! !

!PathTest methodsFor: 'tests' stamp: ''!
testResolveAbsolute
	| path |
	path := Path / 'griffle'.
	self assert: path resolve identicalTo: path.
	self assert: path isAbsolute! !

!PathTest methodsFor: 'tests' stamp: ''!
testSlash
	| path actual |
	path := Path * 'plonk'.
	actual := path / 'griffle'.
	self assert: actual class equals: path class.
	self assert: (actual printWithDelimiter: $/) equals: 'plonk/griffle'! !

!PathTest methodsFor: 'tests' stamp: ''!
testDotDotParent
	| path parent |
	path := (Path * 'plonk') / 'griffle' / '..'.
	parent := path parent.
	self assert: parent isRelative.
	self assert: parent segments equals: #(plonk griffle '..' '..').! !

!PathTest methodsFor: 'tests' stamp: ''!
testEqual
	| a b |
	a := Path * 'plonk'.
	b := Path * 'plonk'.
	self deny: a identicalTo: b.
	self assert: a equals: b! !

!PathTest methodsFor: 'tests' stamp: ''!
testResolvePath
		
	| path |
	path := Path / 'grandfather' / 'father' / 'child'.
	self 
		assert: (path resolvePath: Path / 'grandfather') 
		equals: (Path / 'grandfather').
	self 
		assert: (path resolvePath: Path / 'child')
		equals: (Path / 'child').
	self
		assert: (path resolvePath: Path * 'grandfather')
		equals: (Path / 'grandfather' / 'father' / 'child' / 'grandfather').
	self
		assert: (path resolvePath: Path * 'child')
		equals: (Path / 'grandfather' / 'father' / 'child' / 'child').
	self
		assert: (path resolvePath: Path * 'grandfather')
		equals: (Path / 'grandfather' / 'father' / 'child' / 'grandfather').
	self
		assert: (path resolvePath: Path * 'child')
		equals: (Path / 'grandfather' / 'father' / 'child' / 'child').
	self
		assert:  (path resolvePath: (Path parent) / '..') canonicalize
		equals: (Path / 'grandfather')! !

!PathTest methodsFor: 'tests' stamp: ''!
testUnequalContent
	| a b |
	a := Path * 'plonk'.
	b := Path * 'griffle'.
	self deny: a identicalTo: b.! !

!PathTest methodsFor: 'tests' stamp: ''!
testRelativeFromStringParent

	| path |
	
	path := Path from: '../..'.
	
	self assert: path isRelative.
	self assert: path size equals: 2.
	self assert: (path at: 1) equals: '..'.
	self assert: (path at: 2) equals: '..'! !

!PathTest methodsFor: 'tests' stamp: ''!
testGrandchildOfPath
	| griffle  nurb |
	griffle := Path / 'griffle'.
	nurb := griffle / 'plonk' / 'nurb'.
	self deny: (griffle isChildOf: nurb).
	self deny: (nurb isChildOf: griffle).! !

!PathTest methodsFor: 'tests' stamp: ''!
testRelativeToBranch
	| parent child relative |
	parent := Path / 'griffle' / 'bibb'.
	child := Path / 'griffle' / 'plonk' / 'nurp'.
	relative := child relativeTo: parent.
	self assert: relative  equals: (Path parent / 'plonk' / 'nurp')! !

!PathTest methodsFor: 'tests' stamp: ''!
testUnequalSize
	| a b |
	a := Path * 'plonk'.
	b := (Path * 'plonk') / 'griffle'.
	self deny: a identicalTo: b.! !

!PathTest methodsFor: 'tests' stamp: ''!
testWithParentsOnRootReturnRoot
	"Non regression test. Before sending #withParents to the root returned two time root.This is wrong behavior and this test ensure we do not have a regression."

	self assert: FileLocator root fullPath withParents size equals: 1.
	self assert: FileLocator root fullPath withParents anyOne equals: Path root! !

!PathTest methodsFor: 'tests' stamp: ''!
testCanonicalization

	| ref |

	ref := (Path * 'a/b/c') canonicalize.
	self assert: ref segments equals: #('a' 'b' 'c').

	ref := (Path / 'a/b/c') canonicalize.
	self assert: ref segments equals: #('a' 'b' 'c').

	ref := (Path * '../a/b/c') canonicalize.
	self assert: ref segments equals: #('..' 'a' 'b' 'c').

	ref := (Path * 'a/b/c/..') canonicalize.
	self assert: ref segments equals: #('a' 'b').

	ref := (Path / 'a/b/c/..') canonicalize.
	self assert: ref segments equals: #('a' 'b').

	ref := (Path * 'a/b/../c') canonicalize.
	self assert: ref segments equals: #('a' 'c').

	ref := (Path / 'a/b/../c') canonicalize.
	self assert: ref segments equals: #('a' 'c').! !

!PathTest methodsFor: 'tests' stamp: ''!
testPathString

	| path |

	path := (FileSystem workingDirectory / 'book-result' / 'W01-Welcome')
				relativeToReference: FileSystem workingDirectory.
	self assert: path isRelative.
	self assert: path pathString equals: 'book-result/W01-Welcome'! !

!PathTest methodsFor: 'tests' stamp: ''!
testMakeRelative
	
	| parent child relative |
	parent := Path / 'griffle' / 'bibb'.
	child := Path / 'griffle' / 'plonk' / 'nurp'.
	relative := parent makeRelative: child.
	self assert: relative equals: (Path parent / 'plonk' / 'nurp')! !

!PathTest methodsFor: 'tests' stamp: ''!
testIsAbsoluteWindowsPathReturnsFalseWhenNoWindowsAbsolutePathProvided
  
	self deny: (Path isAbsoluteWindowsPath: 'tmp').
	self deny: (Path isAbsoluteWindowsPath: '/tmp').
	self deny: (Path isAbsoluteWindowsPath: '/tmp/test')! !

!PathTest methodsFor: 'tests' stamp: ''!
testRelativeFromStringNormalization

	| path |
	
	path := Path from: 'plonk/../griffle'.
	
	self assert: path isRelative.
	self assert: path size equals: 3.
	self assert: path segments equals: #('plonk' '..' 'griffle')! !

!PathTest methodsFor: 'tests' stamp: ''!
testResolveRelative
	| path |
	path := Path * 'griffle'.
	self assert: path resolve identicalTo: path.
	self assert: path isRelative! !

!PathTest methodsFor: 'tests' stamp: ''!
testBasenameWithoutExtension
	
	| path |
	path := Path * 'plonk' / 'griffle'.
	self assert: path basenameWithoutExtension equals: 'griffle'.
	self assert: (path basenameWithoutExtension: 'griffle') equals: 'griffle'.
	self assert: (path basenameWithoutExtension: 'taz') equals: 'griffle'.
	
	path := Path * 'plonk' / 'griffle.taz'.
	self assert: path basenameWithoutExtension equals: 'griffle'.
	self assert: (path basenameWithoutExtension: 'taz') equals: 'griffle'.
	self assert: (path basenameWithoutExtension: 'griffle.taz') equals: 'griffle.taz'.
	self assert: (path basenameWithoutExtension: 'zork') equals: 'griffle.taz'.
	
	path := Path * 'plonk' / 'griffle.taz.zork'.
	self assert: path basenameWithoutExtension equals: 'griffle.taz'.
	self assert: (path basenameWithoutExtension: 'zork') equals: 'griffle.taz'.
	self assert: (path basenameWithoutExtension: 'taz.zork') equals: 'griffle'.
	self assert: (path basenameWithoutExtension: 'girffle.taz.zork') equals: 'griffle.taz.zork'.
	self assert: (path basenameWithoutExtension: 'taz') equals: 'griffle.taz.zork'.! !

!PathTest methodsFor: 'tests' stamp: ''!
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: ''!
testIsNotRoot
	self deny: (Path / 'plonk') isRoot! !

!PathTest methodsFor: 'tests' stamp: ''!
testIsRoot
	self assert: Path root isRoot! !

!PathTest methodsFor: 'tests' stamp: ''!
testParseBogus
	
	| path |
	path := Path from: 'parent?<>~ \child/grandChild' delimiter: $/.
	self assert: path size equals: 2.
	self assert: (path at: 1) equals: 'parent?<>~ \child'.
	self assert: (path at: 2) equals: 'grandChild'! !

!PathTest methodsFor: 'tests' stamp: ''!
testRootParent
	| root |
	root := Path root.
	self assert: root parent identicalTo: root! !

!PathTest methodsFor: 'tests' stamp: ''!
testPrintPathOnDelimiterOnNetworkDrive


	"Use an unusal delimiter to check that the default isn't hardcoded anywhere"
	| pathSrc path pathString |
	pathSrc := '||one|two|three'.
	path := Path from: pathSrc delimiter: $|.
	self assert: path isAbsolute.
	pathString := String streamContents: [ :stream | path printPathOn: stream delimiter: $| ].
	self assert: pathSrc equals: pathString! !

!PathTest methodsFor: 'tests' stamp: ''!
testRootPrintString
	| path actual |
	path := Path root.
	actual := path printString.
	self assert: actual equals: 'Path root'! !

!PathTest methodsFor: 'tests' stamp: ''!
testIsChildOfPath
	| parent child |
	parent := Path / 'griffle'.
	child := parent / 'nurb'.
	self assert: (child isChildOf: parent).
	self deny: (parent isChildOf: child)! !

!PathTest methodsFor: 'tests' stamp: ''!
testRelativePrintString
	| path actual |
	path := Path * 'plonk' / 'griffle'.
	actual := path printString.
	self assert: actual equals: 'Path * ''plonk'' / ''griffle'''! !

!PathTest methodsFor: 'tests' stamp: ''!
testAbsolutePath

	| path |

	self assert: (AbsolutePath new isAbsolute).
	self assert: (Path root isAbsolute).
	
	path := AbsolutePath from: 'parent/child/grandChild' delimiter: $/.
	self assert: path size equals: 3.
	self assert: (path at: 1) equals: 'parent'.
	self assert: (path at: 2) equals: 'child'.
	self assert: (path at: 3) equals: 'grandChild'.
	
	path := AbsolutePath from: '/' delimiter: $/.
	self assert: path equals: Path root! !

!PathTest methodsFor: 'tests' stamp: ''!
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: ''!
testIsNotAbsolute
	self deny: (Path * 'plonk') isAbsolute! !

!PathTest methodsFor: 'tests' stamp: ''!
testParseWindowsPathWithUnixDelimiters
	
	| path |
	path := WindowsStore new pathFromString: 'C:\a/b/c'.
	self assert: path segments size equals: 4.
	self
		assertCollection: path segments
		equals: #('C:' 'a' 'b' 'c')! !

!PathTest methodsFor: 'tests' stamp: ''!
testIsEmpty
	self assertEmpty: Path workingDirectory! !

!PathTest methodsFor: 'tests' stamp: ''!
testRedundantSeparators

	| ref |

	ref := '/a/b/c' asPath / 'foo/'.
	self assert: ref segments equals: #('a' 'b' 'c' 'foo').

	ref := '/a/b/c' asPath / 'foo//'.
	self assert: ref segments equals: #('a' 'b' 'c' 'foo').

	ref := '/a/b/c' asPath / 'foo//..'.
	self assert: ref segments equals: #('a' 'b' 'c' 'foo' '..').

	ref := '/a/b/c' asPath / '..//foo'.
	self assert: ref segments equals: #('a' 'b' 'c' '..' 'foo').

	ref := '/a/b/c' asPath / 'foo//..//bar'.
	self assert: ref segments equals: #('a' 'b' 'c' 'foo' '..' 'bar')! !

!PathTest methodsFor: 'tests' stamp: ''!
testRelativeWithParents
	| path allPaths |
	path := Path * 'plonk' / 'griffle' / 'nurb'.
	allPaths := path withParents.

	self assert: allPaths size equals: 3.
	self assert: allPaths first basename equals: 'plonk'.
	self assert: allPaths first size equals: 1.
	self assert: allPaths second basename equals: 'griffle'.
	self assert: allPaths second size equals: 2.
	self assert: (allPaths second isChildOf: allPaths first).
	self assert: allPaths third basename equals: 'nurb'.
	self assert: allPaths third size equals: 3.
	self assert: (allPaths third isChildOf: allPaths second).
	self assert: allPaths third identicalTo: path! !

!PeelToFirstDebugAction commentStamp: ''!
A PeelToFirstDebugAction peels the stack back to the second occurance of the currently selected message.
!
!PeelToFirstDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 45! !

!PeelToFirstDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Peels the stack back to the second occurance of the currently selected message.'! !

!PeelToFirstDebugAction methodsFor: 'actions' stamp: ''!
executeAction

	self session peelToFirstLike: self currentContext! !

!PeelToFirstDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #peelToFirst! !

!PeelToFirstDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Peel to first like this'! !

!PeelToFirstDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<contextMenuDebuggingAction>! !

!PerformMessageCommandLineHandler commentStamp: ''!
Usage: perform <global> <messageSelector>  [ <arguments> ] [ --save ]
	global	A class name or a global name. Receiver of the message (e.g. Smalltalk)
	messageSelector   The message selector to be perfomed
	
Documentation:
Performs a message on a given class or global object. This command-line handler can be used to execute some code if a compiler is not loaded in the image. All message arguments are strings.

Examples:
	pharo Pharo.image perform Smalltalk garbageCollect --save
	pharo Pharo.image perform PerformMessageCommandLineHandler printReversed:times:  olleH 10
!
!PerformMessageCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	| aClass aMessage arguments messageArguments |
	self activateHelp
		ifTrue: [ ^ self ].
		
	arguments := self commandLine arguments reject: [ :argument | argument beginsWith: '-']. "ignore options"
	
	(arguments size < 2)
		ifTrue: [ ^ self exitFailure: 'Not enough arguments' ].
		
	aClass := Smalltalk globals at: arguments first asSymbol ifAbsent: [ 
		  ^ self exitFailure: 'Unknown class' ].
	aMessage := arguments second asSymbol.
	messageArguments := (arguments allButFirst: 2) asArray.
	
	aClass perform: aMessage withArguments: messageArguments.
	
	(self hasOption: 'save')
		ifTrue: [ Smalltalk snapshot: true andQuit: false ].
	self exitSuccess! !

!PerformMessageCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'perform'! !

!PerformMessageCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Perform given message on a specified class or global'! !

!PerformMessageCommandLineHandler class methodsFor: 'testing' stamp: ''!
printReversed: aString times: aStringWithNumber

	aStringWithNumber asInteger timesRepeat: [ 
		Stdio stdout nextPutAll: aString reversed; lf. ]! !

!PerformMessageCommandLineHandler class methodsFor: 'testing' stamp: ''!
answerUltimateQuestion

	Smalltalk exit: 42.! !

!PermaLink commentStamp: ''!
I specify a kind of persistence for links to be put on a slot, a temporary variable or a class variable.  

I can be of kind: 
- #read only read nodes
- #write only assignment nodes 
- #all both

I know the class of the slot/var the link will be put on. I also know my link, although several versions of me can exist for the same link, but with different targets (slots/var).

The isInstanceSpecific inst var seems to be needed to keep track that the metalink is installed on an object, because this information is lost after the link is installed through the API. It could be done better perhaps. !
!PermaLink methodsFor: 'accessing' stamp: ''!
targetObjectOrClass
	^ slotOrVarClass! !

!PermaLink methodsFor: 'accessing' stamp: ''!
persistenceType
	^ persistenceType! !

!PermaLink methodsFor: 'initalize' stamp: ''!
initialize
	isInstanceSpecific := false! !

!PermaLink methodsFor: 'accessing' stamp: ''!
link
	^ link! !

!PermaLink methodsFor: 'accessing' stamp: ''!
persistenceType: anObject
	persistenceType := anObject! !

!PermaLink methodsFor: 'accessing' stamp: ''!
isInstanceSpecific: anObject
	isInstanceSpecific := anObject! !

!PermaLink methodsFor: 'accessing' stamp: ''!
slotOrVarClass 
	^ slotOrVarClass nonAnonymousClass! !

!PermaLink methodsFor: 'accessing' stamp: ''!
slotOrVariable
	^ slotOrVariable! !

!PermaLink methodsFor: 'accessing' stamp: ''!
slotOrVarClass: anObject
	slotOrVarClass := anObject! !

!PermaLink methodsFor: 'accessing' stamp: ''!
slotOrVariable: anObject
	slotOrVariable := anObject! !

!PermaLink methodsFor: 'accessing' stamp: ''!
isInstanceSpecific
	^ isInstanceSpecific! !

!PermaLink methodsFor: 'accessing' stamp: ''!
link: anObject
	link := anObject! !

!PersonDataExample commentStamp: ''!
Data object for a grid example!
!PersonDataExample methodsFor: 'accessing' stamp: ''!
married: anObject
	"Set the value of married"

	married := anObject! !

!PersonDataExample methodsFor: 'accessing' stamp: ''!
age: anObject
	"Set the value of age"

	age := anObject! !

!PersonDataExample methodsFor: 'accessing' stamp: ''!
secondName: anObject
	"Set the value of secondName"

	secondName := anObject! !

!PersonDataExample methodsFor: 'accessing' stamp: ''!
firstName
	"Answer the value of firstName"

	^ firstName! !

!PersonDataExample methodsFor: 'accessing' stamp: ''!
married
	"Answer the value of married"

	^ married! !

!PersonDataExample methodsFor: 'accessing' stamp: ''!
age
	"Answer the value of age"

	^ age! !

!PersonDataExample methodsFor: 'accessing' stamp: ''!
secondName
	"Answer the value of secondName"

	^ secondName! !

!PersonDataExample methodsFor: 'accessing' stamp: ''!
firstName: anObject
	"Set the value of firstName"

	firstName := anObject! !

!PersonDataExample class methodsFor: 'instance creation' stamp: ''!
firstName: fname secondName: sname age: age married: married
	^ (self new) firstName: fname; secondName: sname; age: age; married: married; yourself! !

!Pharo3TabPanelBorder commentStamp: ''!
Specialized border for TabGroup. Does not draw border beneath the selectd tab and only draws on top.
!
!Pharo3TabPanelBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!Pharo3TabPanelBorderStyle commentStamp: ''!
Specialized border for TabGroup. Does not draw border beneath the selectd tab and only draws on top.!
!Pharo3TabPanelBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle: aRectangle on: aCanvas
	"Draw the border taking the currently selected tab into account.
	Only works for top-positioned tabs for the moment."
	
	|w h r tab|
	w := self width.
	w isPoint ifTrue: [h := w y. w := w x] ifFalse:[h := w].
	tab := self selectedTab.
	tab ifNil: [	
		r := aRectangle topLeft + (w@0) corner: aRectangle topRight - (w@h negated).
		aCanvas fillRectangle: r color: self color.
		^self]. "top"
	r := aRectangle topLeft + (w@0) corner: tab bounds left + w@(aRectangle top + h).
	aCanvas fillRectangle: r color: self color. "top 1"
	r := tab bounds left + w@ aRectangle top corner: tab bounds right - w@(aRectangle top + h).
	aCanvas fillRectangle: r color: tab paneColor. "top 2"
	r :=  tab bounds right - w@ aRectangle top corner: aRectangle topRight - (w@h negated).
	aCanvas fillRectangle: r color: self color. "top 3"! !

!PharoBootstrapAnalyzerStubWithNewDependency commentStamp: ''!
Stub class to do not compute dependencies of the given package butrather give pre-established responses back.!
!PharoBootstrapAnalyzerStubWithNewDependency methodsFor: 'accessing' stamp: ''!
dependenciesOf: aPackageName
	^ #(Foo Bar)! !

!PharoBootstrapAnalyzerStubWithNoNewDependency commentStamp: ''!
Stub class to do not compute dependencies of the given package butrather give pre-established responses back.

#dependenciesOf will return  packages already in the bootsrap layer.!
!PharoBootstrapAnalyzerStubWithNoNewDependency methodsFor: 'accessing' stamp: ''!
dependenciesOf: aPackageName
	^ #('Collections-Strings' Kernel 'AST-Core')! !

!PharoBootstrapInitialization commentStamp: ''!
I hold the code needed to initialize correctly a fresh generated bootstrap image.

I am invoked from the only process in the bootstraped image. 

This process sends the message

initializeImageOfType: typeName majorVersion: major minor: minor suffix: suffix buid: build commitHash: hash

- The typeName is 'Pharo'
- Major and Minor are the versions of Pharo
- Suffix is the suffix of the version.
- Build is the build number from the CI server.
- hash is the commitish that produced this image.

I initialize the version object of the Image and perform the initial initialization.
Check #initializeCommandLineHandlerAndErrorHandling to see the steps performed.!
!PharoBootstrapInitialization class methodsFor: 'public api' stamp: ''!
initializeImageOfType: typeName major: major minor: minor patch: patch suffix: suffix build: buildNumber commitHash: hash

	"The image main entry point called by an image builder. The arguments specify the image
	version description.
	This method is run before the new bootstrapped image is saved!!"

	SystemVersion 
		writeClassVariableNamed: #Current
		value: (SystemVersion new
					type: typeName;
					major: major;
					minor: minor;
					patch: patch;
					suffix: suffix;
					build: buildNumber;
					commitHash: hash;
					yourself).
	
	self initializeCommandLineHandlerAndErrorHandling.! !

!PharoBootstrapInitialization class methodsFor: 'public api' stamp: ''!
initializeFileSystem
	| env |
	env := self environment.
	(env at: #FileLocator) initialize.
	(env at: #DiskStore) initialize.
	(env at: #FileHandle) initialize.
	(env at: #File) initialize! !

!PharoBootstrapInitialization class methodsFor: 'initialization' stamp: ''!
initializeCommandLineHandlerAndErrorHandling
	"This method is run before the new bootstrapped image is saved!!"
	ProcessorScheduler initialize.
	
	Object initialize.
	
	ChronologyConstants initialize.
	DateAndTime initialize.
	SessionManager default installNewSession.
	
	Delay initialize.
	SmallInteger initialize.
	
	ProcessorScheduler startUp.
	
	OSPlatform startUp: true.
	
	String initialize.
	ByteString initialize. "needed by TextConverter to install LineEnd convention (called by Smalltalk openLog)"
	ZnUTF8Encoder initialize.	
	
	"Weak array class initialization 2 lines"
	Smalltalk specialObjectsArray at: 42 put: Semaphore new."to put in EPObjectSpace>>#createSpecialObjectsArray?"
	WeakArray restartFinalizationProcess.
	
	Smalltalk globals 
		at: #Transcript
		put: (NonInteractiveTranscript stdout install).
	Float initialize.

	CollectionElement initialize.
	ExternalSemaphoreTable initialize.
	Collection initialize.
	CompiledMethod initialize.
	Categorizer initialize.
	Slot initialize.
	RPackage initialize.
	Behavior initialize.

	UIManager default: NonInteractiveUIManager new.	 

	Smalltalk sourceFileVersionString: 'PharoV60'.
	(Smalltalk class classVariableNamed: 'LastImagePath') value: Smalltalk imagePath. "set the default value"
	SourceFiles := SourceFileArray new.
		
	Color initialize.
	InstructionStream initialize.
	SmallInteger initialize.

	"FFI"
	ExternalObject initialize.
	ExternalType initialize.
	FFIBackend initialize.

	"Initialize basic command line behaviour"
	Stdio initialize.
	NonInteractiveTranscript initialize.
	BasicCommandLineHandler initialize.
	Smalltalk snapshot: true andQuit: true.
	Processor terminateActive.! !

!PharoBootstrapRule commentStamp: ''!
A package from the bootstrap layer (minimal image) is depending on an external package.!
!PharoBootstrapRule methodsFor: '*Deprecated10' stamp: ''!
collectionsPackages
	self deprecated: 'Deprecated together with assembly mechanism. See issue #9670'.
	
	^ (CollectionsAssembly parts collect: [:part| part key])
		reject: [ :each | each = #'Collections-Atomic' ]! !

!PharoBootstrapRule methodsFor: 'instance creation' stamp: ''!
newExternalDependencyExistFor: aPackage
	"Check if there are new dependencies to a package outside this layer"
	| dependencies newDependencies |
	dependencies := self dependencyChecker dependenciesOf: aPackage packageName.
	newDependencies := dependencies difference: self bootstrapPackages.
	^ newDependencies notEmpty! !

!PharoBootstrapRule methodsFor: 'running' stamp: ''!
basicCheck: aPackage
	(self bootstrapPackages includes: aPackage packageName)
		ifFalse: [ ^ false "Do not check" ].
	^ self newExternalDependencyExistFor: aPackage! !

!PharoBootstrapRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Architectural'! !

!PharoBootstrapRule methodsFor: 'accessing' stamp: ''!
bootstrapPackages
	^ #(
	#'AST-Core'
	#'Announcements-Core'
	#CodeExport
	#CodeImport
	#CodeImportCommandLineHandlers
	#Collections
	#Compression
	#'FileSystem-Core'
	#'FileSystem-Disk'
	#Files
	#Jobs
	#Kernel
	#Monticello
	#'Multilingual-Encodings'
	#'Network-UUID'
	#'OpalCompiler-Core'
	#'Random-Core'
	#'RPackage-Core'
	#'Ring-Definitions-Containers'
	#'Ring-Definitions-Core'
	#'Ring-Definitions-Monticello'
	#'Ring-OldChunkImporter'
	#'Slot-Core'
	#'System-Announcements'
	#'System-BasicCommandLineHandler'
	#'System-Changes'
	#'System-CommandLine'
	#'System-CommandLineHandler'
	#'System-Finalization'
	#'System-Hashing'
	#'System-Localization'
	#'System-Model'
	#'System-Platforms'
	#'System-SessionManager'
	#'System-Sources'
	#'System-Support'
	#Traits
	#'Transcript-Core'
	#UIManager
	#'Collections-Abstract'
	#'Collections-Arithmetic'
	#'Collections-Native'
	#'Collections-Sequenceable'
	#'Collections-Stack'
	#'Collections-Streams'
	#'Collections-Strings'
	#'Collections-Support'
	#'Collections-Unordered'
	#'Collections-Weak'
	#'Zinc-Character-Encoding-Core'
	#'Zinc-Resource-Meta-Core'
	#'PharoBootstrap-Initialization'
	#'Transcript-NonInteractive'
	)! !

!PharoBootstrapRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Illegal dependency of Bootstrap Layer'! !

!PharoBootstrapRule methodsFor: 'helpers' stamp: ''!
critiqueFor: aPackage

	^ ArchitecturalCritique
		withAnchor: (self anchorFor: aPackage)
		by: self! !

!PharoBootstrapRule methodsFor: 'private' stamp: ''!
dependencyChecker
	^ (DependencyChecker ifNil: [ DADependencyChecker ]) new! !

!PharoBootstrapRule class methodsFor: 'testing' stamp: ''!
checksPackage

	^ true! !

!PharoBootstrapRuleTest methodsFor: 'running' stamp: ''!
tearDown
	PharoBootstrapRule
		classVarNamed: 'DependencyChecker' 
		put: checkerBackup.
	super tearDown! !

!PharoBootstrapRuleTest methodsFor: 'tests' stamp: ''!
testRuleFailsIfAnyNewExternalDependencyFound
	| rule packageUnderTest critiques |
	rule := PharoBootstrapRule new.
	rule class 
		classVarNamed: 'DependencyChecker' 
		put: PharoBootstrapAnalyzerStubWithNewDependency.
	packageUnderTest := RPackage named: #Kernel.

	critiques := rule check: packageUnderTest.

	self assert: critiques size equals: 1.

	self
		assert: critiques anyOne sourceAnchor entity
		equals: packageUnderTest! !

!PharoBootstrapRuleTest methodsFor: 'tests' stamp: ''!
testRuleDoesNotFailIfAppliedOnNonBootstrapPackage
	| rule critiques |
	rule := PharoBootstrapRule new.
	rule class classVarNamed: 'DependencyChecker' put: PharoBootstrapAnalyzerStubWithNoNewDependency.

	critiques := rule check: (RPackage named: #P1).

	self assertEmpty: critiques! !

!PharoBootstrapRuleTest methodsFor: 'tests' stamp: ''!
testRuleDoesNotFailIfNoNewExternalDependency
	| rule critiques |
	rule := PharoBootstrapRule new.
	rule class classVarNamed: 'DependencyChecker' put: PharoBootstrapAnalyzerStubWithNoNewDependency.

	critiques := rule check: (RPackage named: #Kernel).

	self assertEmpty: critiques! !

!PharoBootstrapRuleTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	checkerBackup := PharoBootstrapRule
		classVarNamed: 'DependencyChecker'.! !

!PharoChangesCondenser commentStamp: ''!
I create a new more compact changes files with a single version of each method in the image.!
!PharoChangesCondenser methodsFor: 'public' stamp: ''!
condense
	job := [ 
		newChangesFile writeStreamDo: [ :aStream |
			  stream := aStream.
			  self basicCondense ].
  		self
        installNewChangesFile;
  		  reset
    ] asJob.
	
	job 
		title: 'Condensing Changes';
		max: Smalltalk classNames size + Smalltalk traitNames size;
		run.! !

!PharoChangesCondenser methodsFor: 'private - 2 swapping' stamp: ''!
swapSourcePointers
	job 
		title: 'Swapping source pointers';
		currentValue: 0.
	
	Smalltalk allClassesAndTraitsDo: [ :classOrTrait |
		job increment.
		self swapSourcePointerOfClassOrTrait: classOrTrait ]
	! !

!PharoChangesCondenser methodsFor: 'private - 3 installing' stamp: ''!
updateQuitPosition
	
	Smalltalk lastQuitLogPosition: stream position.! !

!PharoChangesCondenser methodsFor: 'initialization' stamp: ''!
initialize
	self reset.! !

!PharoChangesCondenser methodsFor: 'private' stamp: ''!
condenseClassesAndTraits 
	Smalltalk allClassesAndTraitsDo: [ :classOrTrait | 
		self condenseClassOrTrait: classOrTrait	]
	! !

!PharoChangesCondenser methodsFor: 'private - 2 swapping' stamp: ''!
swapSourcePointerOfMethod: method

	remoteStringMap at: method ifPresent: [ :remoteString |
		method setSourcePointer: remoteString sourcePointer ]! !

!PharoChangesCondenser methodsFor: 'accessing' stamp: ''!
fileIndex
	"Return the index into the SourceFiles:
	1: the .sources file
	2. the .changes file"
	^ 2! !

!PharoChangesCondenser methodsFor: 'private - 1 writing' stamp: ''!
writeMethodSource: aMethod
	
	self nextCommentChunkDo: [ :strm |
		strm 
			nextPutAll: aMethod methodClass name;
			nextPutAll: ' methodsFor: ';
			store: aMethod category asString;
			nextPutAll: ' stamp: ';
			store: aMethod timeStamp ].
	
	self
		writeRemoteString: aMethod sourceCode
		for: aMethod.
		
	stream nextPutAll: ' !!'; cr.! !

!PharoChangesCondenser methodsFor: 'private - 1 writing' stamp: ''!
writeRemoteString: aString for: reference

	| remoteString |
	remoteString := 
		RemoteString 
			newString: aString 
			onFileNumber: self fileIndex 
			toFile: stream.

	remoteStringMap at: reference put: remoteString.

	^ remoteString! !

!PharoChangesCondenser methodsFor: 'helper' stamp: ''!
nextChunkDo: aBlock
	(ChunkWriteStream on: stream) nextPut: (String streamContents: aBlock)! !

!PharoChangesCondenser methodsFor: 'private' stamp: ''!
basicCondense
	self
		condenseClassesAndTraits;
		swapSourcePointers;
    updateQuitPosition.
  stream flush.! !

!PharoChangesCondenser methodsFor: 'private - 2 swapping' stamp: ''!
swapSourcePointerOfClassOrTrait: classOrTrait

	self swapClassComment: classOrTrait.
	
	classOrTrait methodsDo: [ :method | 
		self swapSourcePointerOfMethod: method ].
	
	classOrTrait classSide methodsDo: [ :method | 
		self swapSourcePointerOfMethod: method ]! !

!PharoChangesCondenser methodsFor: 'private - 1 writing' stamp: ''!
writeClassComment: aClass
	| organizer commentRemoteString stamp |
	
	organizer := aClass organization.
	commentRemoteString := self commentRemoteStringFor: organizer.
	
	(commentRemoteString isNil or: [ commentRemoteString sourceFileNumber = 1 ])
		ifTrue: [ ^ self ].
		
	self nextCommentChunkDo: [ :strm |
		strm 
			nextPutAll: aClass name;
			nextPutAll: ' commentStamp: '.
		stamp := organizer commentStamp 
			ifNil: ['<historical>'].
		stamp storeOn: strm ].
	
	self 
		writeRemoteString: organizer classComment
		for: aClass! !

!PharoChangesCondenser methodsFor: 'private - 2 swapping' stamp: ''!
swapClassComment: classOrTrait
	remoteStringMap 
		at: classOrTrait
		ifPresent: [ :remoteString | 
			classOrTrait organization commentSourcePointer:  remoteString sourcePointer]! !

!PharoChangesCondenser methodsFor: 'accessing' stamp: ''!
temporaryFile
	^ (Smalltalk changesFile, 'new') nextVersion.! !

!PharoChangesCondenser methodsFor: 'private - testing' stamp: ''!
shouldCondenseMethod: aMethod
	"Only write methods with changes in the current file (not .sources)"

	^ (SourceFiles fileIndexFromSourcePointer: aMethod sourcePointer) == 2! !

!PharoChangesCondenser methodsFor: 'private - 3 installing' stamp: ''!
backupOldChanges
	| changesFile |
	
	changesFile := self originalFile.
	changesFile moveTo: (changesFile , 'bak') asFileReference nextVersion.
	! !

!PharoChangesCondenser methodsFor: 'private - 3 installing' stamp: ''!
installNewChangesFile
	
	SourceFiles changesFileStream close.
	self backupOldChanges.
	self originalFile ensureDelete.
	newChangesFile moveTo: self originalFile.
	Smalltalk openSourceFiles.! !

!PharoChangesCondenser methodsFor: 'accessing' stamp: ''!
originalFile
	^ Smalltalk changesFile asFileReference! !

!PharoChangesCondenser methodsFor: 'initialization' stamp: ''!
reset
	remoteStringMap := IdentityDictionary new.
	newChangesFile := self temporaryFile.
	
	"Keep a copy of the source streams for performance"
	sourceStreams := Array
			with: PharoFilesOpener default sourcesFileOrNil
			with: PharoFilesOpener default changesFileOrNil! !

!PharoChangesCondenser methodsFor: 'private' stamp: ''!
commentRemoteStringFor: org
	^ org commentSourcePointer ifNotNil: [:ptr | SourceFiles remoteStringAt: ptr]! !

!PharoChangesCondenser methodsFor: 'private' stamp: ''!
condenseClassOrTrait: classOrTrait
	self writeClassComment: classOrTrait.
	
	classOrTrait instanceSide methodsDo: [ :method |
		(self shouldCondenseMethod: method)
			ifTrue: [ self writeMethodSource: method ]].
	
	classOrTrait classSide methodsDo: [ :method |
		(self shouldCondenseMethod: method)
			ifTrue: [ self writeMethodSource: method ]]! !

!PharoChangesCondenser methodsFor: 'helper' stamp: ''!
nextCommentChunkDo: aBlock
	stream cr; nextPut: $!!.
	self nextChunkDo: aBlock.
	stream cr! !

!PharoChangesCondenser class methodsFor: 'helper' stamp: ''!
condense
	^ self new
		condense! !

!PharoCommandLineHandler commentStamp: ''!
Usage: [<subcommand>] [--help] [--copyright] [--version] [--list] [ --no-quit ]
	--help       print this help message
	--copyright  print the copyrights
	--version    print the version for the image and the vm
	--list       list a description of all active command line handlers
	--no-quit    keep the image running without activating any other command line handler
	--deploymentPassword   if a password needs to be used by the user to launch the command
	--readWriteAccessMode, --readOnlyAccessMode, --writeOnlyAccessMode, --disabledAccessMode
	             specify disk access mode, read-write mode as default
	<subcommand> a valid subcommand in --list
	
	Preference File Modification:
	--preferences-file   load the preferences from the given <FILE>
	--no-default-preferences    do not load any preferences from the default locations
	
Documentation:
A PharoCommandLineHandler handles default command line arguments and options.
The PharoCommandLineHandler is activated before all other handlers. 
It first checks if another handler is available. If so it will activate the found handler.!
!PharoCommandLineHandler methodsFor: 'private - preferences' stamp: ''!
runPreferences

	Smalltalk at: #SystemSettingsPersistence ifPresent: [:persistence | 
		persistence resumeSystemSettings].
	Smalltalk at: #StartupPreferencesLoader ifPresent: [:loader |
		loader default loadFromDefaultLocations ].
! !

!PharoCommandLineHandler methodsFor: 'private - preferences' stamp: ''!
isChangingPreferences

	^ self isOverridingPreferences or: [ self isOmittingPreferences ]! !

!PharoCommandLineHandler methodsFor: 'commands' stamp: ''!
default
	Smalltalk isHeadless 
		ifFalse: [ ^ self noQuit ].
	
	^ super default! !

!PharoCommandLineHandler methodsFor: 'private - preferences' stamp: ''!
isOverridingPreferences

	^ self hasOption: 'preferences-file'! !

!PharoCommandLineHandler methodsFor: 'accessing' stamp: ''!
forcePreferencesOmission
	^ self class forcePreferencesOmission! !

!PharoCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	"If the command line is configured to force the omission of preferences, we should skip them in any case. To ensure the command line works perfectly, we should still ensure that there is no unneeded parameters as 'preferences-file' of 'no-default-preferences'."

	self forcePreferencesOmission
		ifTrue: [ self isChangingPreferences ifTrue: [ self copySubcommand ] ]
		ifFalse: [ 
			self isChangingPreferences
				ifTrue: [ self changePreferences ]
				ifFalse: [ self runPreferences ] 
		].
	
	^ super activate! !

!PharoCommandLineHandler methodsFor: 'private - preferences' stamp: ''!
isOmittingPreferences

	^ self hasOption: 'no-default-preferences'! !

!PharoCommandLineHandler methodsFor: 'private - preferences' stamp: ''!
changePreferences
	| preferenceFile |
	self isOmittingPreferences
		ifTrue: [ self copySubcommand.
			^ self ].
		
	preferenceFile := (self optionAt: 'preferences-file') asFileReference.
	self copySubcommand.
	
	StartupPreferencesLoader default load: {preferenceFile}! !

!PharoCommandLineHandler class methodsFor: 'accessing' stamp: ''!
forcePreferencesOmission
	"If this variable is at true, command lines will not load preferences, even if the command line specify directly a preferences file. This is useful to deploy applications with proprietary code."

	^ ForcePreferencesOmission ifNil: [ ForcePreferencesOmission := false ]! !

!PharoCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'responsible for the default options and activating other commands'! !

!PharoCommandLineHandler class methodsFor: 'accessing' stamp: ''!
priority 
	"Highest priority"
	^ Float infinity! !

!PharoCommandLineHandler class methodsFor: 'testing' stamp: ''!
requireDeploymentPassword
	^ false! !

!PharoCommandLineHandler class methodsFor: 'handler selection' stamp: ''!
isResponsibleFor: aCommandLine
	"I do not match ever, because my activation is manual"

	^ true! !

!PharoCommandLineHandler class methodsFor: 'instance creation' stamp: ''!
activateWith: aCommandLine	
	"Make sure that the PharoCommandLineHandler starts at the top of the stack in the main UI thread."
	UIManager default defer:  [ 
		super activateWith: aCommandLine ]! !

!PharoCommandLineHandler class methodsFor: 'accessing' stamp: ''!
forcePreferencesOmission: anObject
	ForcePreferencesOmission := anObject! !

!PharoCommonTools commentStamp: ''!
A PharoCommonTools is a ToolRegistry that knows about common tools that may be replaced by other packages. It manages a list of the recently registered tools and provides settings for reregistering to a former registered tool.
!
!PharoCommonTools methodsFor: 'registry access' stamp: ''!
fileList

	^ self toolNamed: #fileList! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
browserTool: aTool
	^ self register: aTool as: #browser! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
changeList

	^ self toolNamed: #changeList! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
workspace

	^ self toolNamed: #workspace! !

!PharoCommonTools methodsFor: 'registration' stamp: ''!
recentFileListTools
	^ self recentToolsFor: #fileList! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
workspaceTool
	^ self workspace! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
changeSorterTool
	^ self changeSorter! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
messageListTool
	^ self messageList! !

!PharoCommonTools methodsFor: 'private' stamp: ''!
toolNamed: aSymbol

	tools at: aSymbol ifPresent: [ :tool | ^ tool ].
	self error:
		'No tool named: "' , aSymbol , '" present in the registry'! !

!PharoCommonTools methodsFor: 'registration' stamp: ''!
register: anTool as: aNameSelector
	| usedToolSet |
	anTool ifNil:[ ^ self].
	super register: anTool as: aNameSelector.
	usedToolSet := recentTools at: aNameSelector ifAbsentPut: [ Set new ].
	usedToolSet add: anTool! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
versionBrowserTool: aTool
	^ self register: aTool as: #versionBrowser! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
browser

	^ self toolNamed: #browser! !

!PharoCommonTools methodsFor: 'registration' stamp: ''!
recentInspectorTools
	^ self recentToolsFor: #inspector! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
fileListTool
	^ self fileList! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
testRunner

	^ self toolNamed: #testRunner! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
versionBrowserTool
	^ self versionBrowser! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
syntaxErrorDebugger

	^ self toolNamed: #syntaxErrorDebugger! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
inspectorTool
	^ self inspector! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
basicInspector

	^ self toolNamed: #basicInspector! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
versionBrowser

	^ self toolNamed: #versionBrowser! !

!PharoCommonTools methodsFor: 'initialization' stamp: ''!
initialize
	recentTools := Dictionary new.
	super initialize.
	! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
pointerExplorer

	^ self toolNamed: #pointerExplorer! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
processBrowser

	^ self toolNamed: #processBrowser! !

!PharoCommonTools methodsFor: 'registration' stamp: ''!
recentChangeSorterTools
	^ self recentToolsFor: #changeSorter! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
changeSorter

	^ self toolNamed: #changeSorter! !

!PharoCommonTools methodsFor: 'registration' stamp: ''!
recentVersionBrowserTools
	^ self recentToolsFor: #versionBrowser! !

!PharoCommonTools methodsFor: 'registration' stamp: ''!
recentBrowserTools
	^ self recentToolsFor: #browser! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
workspaceTool: aTool
	^ self register: aTool as: #workspace! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
messageList

	^ self toolNamed: #messageList! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
monticelloBrowser

	^ self toolNamed: #monticelloBrowser! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
inspector

	^ self toolNamed: #inspector! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
browserTool
	^ self browser! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
messageListTool: aTool
	^ self register: aTool as: #messageList! !

!PharoCommonTools methodsFor: 'registration' stamp: ''!
recentWorkspaceTools
	^ self recentToolsFor: #workspace! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
fileListTool: aTool
	^ self register: aTool as: #fileList! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
inspectorTool: aTool
	^ self register: aTool as: #inspector! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
finder

	^ self toolNamed: #finder! !

!PharoCommonTools methodsFor: 'registration' stamp: ''!
recentToolsFor: aName
	^ (recentTools at: aName ifAbsent: [ {} ]) reject: [ :tool | tool isObsolete ]! !

!PharoCommonTools methodsFor: 'tools' stamp: ''!
changeSorterTool: aTool
	^ self register: aTool as: #changeSorter! !

!PharoCommonTools methodsFor: 'registry access' stamp: ''!
timeProfiler

	^ self toolNamed: #timeProfiler! !

!PharoCommonTools methodsFor: 'cleanup' stamp: ''!
cleanUp
	recentTools keysAndValuesDo:[:name :toolSet|
		toolSet copy do:[:tool | tool isObsolete ifTrue:[ toolSet remove: tool]]]! !

!PharoCommonTools class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default
		registerToolClassNamed: self name! !

!PharoCommonTools class methodsFor: 'system startup' stamp: ''!
shutDown: aboutToQuit
	Smalltalk image tools cleanUp! !

!PharoCommonTools class methodsFor: 'world menu' stamp: ''!
worldMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #'System Browser')
		parent: #Browsing;
		action: [ Smalltalk tools openClassBrowser ];
		order: 0;
		keyText: 'o, b';
		help: 'System browser to browse and edit code.';
		iconName: #smallSystemBrowser.
	(aBuilder item: #'Iceberg')
		order: 1; 
		icon: (self iconNamed: #komitterSmalltalkhubRemote);  
		parent: #'Browsing';
		keyText: 'o, i';
		help: 'Iceberg is a set of tools that allow one to handle git repositories directly from a Pharo image.';
		action: [ (Smalltalk at: #IceTipRepositoriesBrowser) new openWithSpec ]! !

!PharoCommonTools class methodsFor: 'settings' stamp: ''!
browsingSettingsOn: aBuilder
	<systemsettings>
	
	"create empty #codeBrowsing and #qualityAssistant settings groups so the tools can use it"
	
	(aBuilder group: #codeBrowsing)
		label: 'Code Browsing';
		description: 'All settings concerned with code browsing look''n feel'.
	
	(aBuilder group: #qualityAssistant)
		label: 'QualityAssistant';
		parent: #codeBrowsing.! !

!PharoCommonTools class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	
	Smalltalk tools class == self
		ifFalse: [ ^ self ].
	(aBuilder group: #pharoTools)
		parent: #pharoSystem;
		label: 'Recent Tools';
		description: 'Recently registered Tools';
		with: [ 
					(aBuilder pickOne: #browserTool)
						target: Smalltalk;
						targetSelector: #tools;
						getSelector: #browserTool;
						setSelector: #browserTool:;
						label: 'System browser';
						default: (self environment at: #ClyFullBrowserMorph);
						domainValues: Smalltalk tools recentBrowserTools ];
		with: [ 
					(aBuilder pickOne: #inspectorTool)
						target: Smalltalk;
						targetSelector: #tools;
						getSelector: #inspectorTool;
						setSelector: #inspectorTool:;
						default: (self environment at: #StInspector);
						label: 'Inspector';
						domainValues: Smalltalk tools recentInspectorTools ];
		with: [ 
					(aBuilder pickOne: #workspaceTool)
						target: Smalltalk;
						targetSelector: #tools;
						getSelector: #workspaceTool;
						setSelector: #workspaceTool:;
						label: 'Workspace';
						default: (self environment at: #StPlayground);
						domainValues: Smalltalk tools recentWorkspaceTools ];
		with: [ 
					(aBuilder pickOne: #versionBrowserTool)
						target: Smalltalk;
						targetSelector: #tools;
						label: 'Versionbrowser';
						domainValues: Smalltalk tools recentVersionBrowserTools ];
		with: [ 
					(aBuilder pickOne: #fileListTool)
						target: Smalltalk;
						targetSelector: #tools;
						label: 'Filelist';
						default: (self environment at: #FileList);
						domainValues: Smalltalk tools recentFileListTools];
		with: [ 
					(aBuilder pickOne: #changeSorterTool)
						target: Smalltalk;
						targetSelector: #tools;
						label: 'Changesorter';
						domainValues: Smalltalk tools recentChangeSorterTools]! !

!PharoDarkTheme commentStamp: ''!
A dark theme for pharo, inspired on 

http://blog.jetbrains.com/blog/2013/06/11/inside-darcula-look-and-feel-an-interview-with-konstantin-bulenkov/

This theme works well with the "Dark" text styling. 
You can have "the full experience", executing: 

self installFullTheme.!
!PharoDarkTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemMouseOverBorderStyleFor: aButton
	^ BottomBorderStyle new
		color: Color white;
		width: 2;
		yourself! !

!PharoDarkTheme methodsFor: 'fill-styles' stamp: ''!
sliderNormalFillStyleFor: aSlider
	
	^ self backgroundColor! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
successTextColor
	^ Color green darker darker darker! !

!PharoDarkTheme methodsFor: 'fill-styles' stamp: ''!
textEditorNormalFillStyleFor: aTextEditor
	^ self backgroundColor! !

!PharoDarkTheme methodsFor: 'fill-styles' stamp: ''!
desktopColor

	^ Color darkGray darker! !

!PharoDarkTheme methodsFor: '*DrTests' stamp: ''!
testColorError
	"Should be in SUnit-Core extention methods, but Sunit is used in the bootstrap."
	^ Color red darker darker darker! !

!PharoDarkTheme methodsFor: '*DrTests' stamp: ''!
testColorPassing
	"Should be in SUnit-Core extention methods, but Sunit is used in the bootstrap."
	^ Color green muchDarker lighter! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
menuBorderColor
	^ self borderColor! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
spotlightWindowColor 
	^ self windowColor! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
selectionTextColor
	^ Color r: 16rE0 g: 16rE2 b: 16rE4 range: 255! !

!PharoDarkTheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffEdgeColor
	"Answer the color used to show the border of the changes."
	
	^ Color white alpha: 0.5! !

!PharoDarkTheme methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
paginatorSelectionColor

	^ self lightBaseColor alpha: 0.8! !

!PharoDarkTheme methodsFor: 'configure' stamp: ''!
configurePluggableTextMorph: textMorph 
	textMorph 	
		color: self backgroundColor;
		textColor: self textColor;
		borderWidth: 1.! !

!PharoDarkTheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffRemovedLinesBackgroundColor
	"Answer the color used to highlight removed text lines in a diff view."
	
	^ Color r: 0.84 g: 0.0 b: 0.0 alpha: 0.2! !

!PharoDarkTheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarPressedThumbFillStyleFor: aScrollbar
	"Return the normal scrollbar button fillStyle for the given scrollbar."
	
	^ self buttonSelectedFillStyleFor: aScrollbar! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
balloonBackgroundColor

	^ self darkBaseColor lighter! !

!PharoDarkTheme methodsFor: 'fill-styles' stamp: ''!
dropListNormalFillStyleFor: aDropList
	"Return the normal fillStyle for the given drop list."
	
	^ self backgroundColor! !

!PharoDarkTheme methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self windowActiveDropShadowStyle: #diffuse.
	self settings preferGradientFill: false.! !

!PharoDarkTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemPressedBorderStyleFor: aButton
	^ self taskbarItemNormalBorderStyleFor: aButton! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
dangerTextColor
	^ Color 
		r: 239	
		g: 83	
		b: 80	
		range: 255! !

!PharoDarkTheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonSelectedFillStyleFor: aButton
	"Return the normal button fillStyle for the given button."
	
	^ SolidFillStyle color: self selectionColor! !

!PharoDarkTheme methodsFor: 'fill-styles' stamp: ''!
listNormalFillStyleFor: aList
	"Return the normal fillStyle for the given list."
	
	^ self backgroundColor! !

!PharoDarkTheme methodsFor: 'initialization' stamp: ''!
newRadioMarkerForm
	"Answer a new checkbox marker form."

	^Form extent: 12@12 depth: 32! !

!PharoDarkTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemNormalFillStyleFor: aButton
	^ SolidFillStyle color: Color transparent! !

!PharoDarkTheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffAdditionalLineBackgroundColor
	"Answer the color used to highlight additional text lines in a diff view."
	
	^ Color r: 0.0 g: 0.76 b: 0.0 alpha: 0.2! !

!PharoDarkTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedMouseOverFillStyleFor: aButton
	^ SolidFillStyle color: (Color white alpha: 0.25)! !

!PharoDarkTheme methodsFor: 'label-styles' stamp: ''!
labelDisabledColorFor: aLabel
	"Answer the color to use for a label when disabled."

	^aLabel owner
		ifNil: [aLabel paneColor muchDarker]
		ifNotNil: [aLabel owner color isTransparent
			ifTrue: [ aLabel owner paneColor muchLighter ]
			ifFalse: [ aLabel owner color muchLighter ] ]! !

!PharoDarkTheme methodsFor: 'configure' stamp: ''!
configureScrollPane: aMorph! !

!PharoDarkTheme methodsFor: 'border-styles' stamp: ''!
configureWindowBorderFor: aWindow

	| aStyle |
	aStyle := SimpleBorderStyle new 
					color: self borderColor;
					width: 1.
	aWindow borderStyle: aStyle! !

!PharoDarkTheme methodsFor: 'defaults' stamp: ''!
menuItemDisabledTextColorFor: aMenuItem

	^ Color lightGray! !

!PharoDarkTheme methodsFor: 'configure' stamp: ''!
configureTextMorph: textMorph 
	textMorph 
		color: self textColor! !

!PharoDarkTheme methodsFor: 'defaults' stamp: ''!
shStyleTableName

	^ #darkStyleTable! !

!PharoDarkTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarFillStyleFor: aTaskbar
	^ SolidFillStyle color: (Color black lighter alpha: 0.8)! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
textColorForNonStandardBackground
	^ Color black! !

!PharoDarkTheme methodsFor: '*Iceberg-TipUI' stamp: ''!
badgeTextColor
	^ self textColor! !

!PharoDarkTheme methodsFor: 'fill-styles' stamp: ''!
dropListNormalListFillStyleFor: aDropList
	"Return the normal fillStyle for the list of the given drop list."
	
	^ self backgroundColor! !

!PharoDarkTheme methodsFor: 'configure' stamp: ''!
configureMorphTreeMorph: aMorph
	aMorph preferedPaneColor: self backgroundColor.
	aMorph 
		rowColorForEven: self backgroundColor
		odd: self backgroundColor.! !

!PharoDarkTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemNormalBorderStyleFor: aButton
	^ BottomBorderStyle new
		color: Color white;
		width: 1;
		trimSize: 2;
		yourself! !

!PharoDarkTheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarNormalFillStyleFor: aScrollbar
	"Return the normal scrollbar fillStyle for the given scrollbar."
	
	^ SolidFillStyle color: self backgroundColor lighter.! !

!PharoDarkTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedFillStyleFor: aButton
	^ SolidFillStyle color: (Color white alpha: 0.15)! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
scrollbarColor 
	^ self buttonColor! !

!PharoDarkTheme methodsFor: 'configure' stamp: ''!
configureSystemWindow: aWindow! !

!PharoDarkTheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffModificatedLineBackgroundColor
	"Answer the color used to highlight changed text lines in a diff view."
	
	^ Color gray alpha: 0.2! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
backgroundColor
	^ Color r: 0.130 g: 0.130 b: 0.130! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
lineNumberColor 
	^ Color gray lighter lighter! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
lessConspicuousColorFrom: aColor

	^	aColor slightlyLighter! !

!PharoDarkTheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonDisabledBorderStyleFor: aButton
	"Return the disabled button fillStyle for the given color."

	^ BorderStyle
		width: 0
		color: Color transparent! !

!PharoDarkTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedBorderStyleFor: aButton
	^ self taskbarItemMouseOverBorderStyleFor: aButton! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
buttonColor
	^ self backgroundColor lighter lighter! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
menuBorderWidth
	^ self borderWidth * self displayScaleFactor! !

!PharoDarkTheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonDisabledFillStyleFor: aButton
	"Return the disabled button fillStyle for the given color."

	^ SolidFillStyle color: Color transparent! !

!PharoDarkTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedPressedBorderStyleFor: aButton
	^ self taskbarItemMouseOverBorderStyleFor: aButton! !

!PharoDarkTheme methodsFor: '*DrTests' stamp: ''!
testColorFailure
	"Should be in SUnit-Core extention methods, but Sunit is used in the bootstrap."
	^ Color yellow muchDarker lighter lighter! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
caretColor
	^ Color lightBlue! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
secondarySelectionColor
	^ Color r: 0.31 g: 0.31 b: 0.36 alpha: 1.0! !

!PharoDarkTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedPressedFillStyleFor: aButton
	^ SolidFillStyle color: (Color white alpha: 0.35)! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
warningTextColor
	^ Color yellow darker darker! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
borderColor 
	^ Color darkGray darker darker darker! !

!PharoDarkTheme methodsFor: 'basic-colors' stamp: ''!
errorPopperBackgroundColor
	^ Color red muchDarker! !

!PharoDarkTheme methodsFor: 'basic-colors' stamp: ''!
taskbarItemLabelColorForCollapsed: aButton
	"Answer the colour for the label of the given taskbar button, given that the corresponding window is collapsed."

	^ Color lightGray! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
selectionColor
	^ Color r: 16r07 g: 16r63 b: 16rAD range: 255! !

!PharoDarkTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedMouseOverBorderStyleFor: aButton
	^ self taskbarItemMouseOverBorderStyleFor: aButton! !

!PharoDarkTheme methodsFor: 'label-styles' stamp: ''!
windowLabelForText: aTextOrString
	^ (super windowLabelForText: aTextOrString)
		color: self textColor;
		yourself! !

!PharoDarkTheme methodsFor: 'border-styles' stamp: ''!
dropListNormalListBorderStyleFor: aDropList
	"Return the normal borderStyle for the list of the given given drop list"

	^ BorderStyle inset
		width: 1;
		baseColor: self buttonColor lighter! !

!PharoDarkTheme methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
popoverButtonColor

	^ self lightBaseColor! !

!PharoDarkTheme methodsFor: 'fill-styles-buttons' stamp: ''!
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! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
disabledColor 
	^ Color gray lighter! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
enabledColor 
	^ self textColor! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
listTextColor
	"Answer the list text color to use."

	^ self textColor! !

!PharoDarkTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemPressedFillStyleFor: aButton
	^ SolidFillStyle color: (Color white alpha: 0.4)! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
classExtensionColor
	^ Color gray lighter lighter! !

!PharoDarkTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedDisabledBorderStyleFor: aButton
	^ self taskbarItemMouseOverBorderStyleFor: aButton! !

!PharoDarkTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedDisaledFillStyleFor: aButton
	^ self taskbarItemSelectedFillStyleFor: aButton! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
textColor
	^ Color white! !

!PharoDarkTheme methodsFor: 'basic-colors' stamp: ''!
taskbarItemLabelColorForExpanded: aButton
	"Answer the colour for the label of the given taskbar button, given that the corresponding window is expanded."

	^ Color white! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
unfocusedSelectionColor
	^ self secondarySelectionColor! !

!PharoDarkTheme methodsFor: 'fill-styles' stamp: ''!
windowActiveLabelFillStyleFor: aWindow
	^ self textColor! !

!PharoDarkTheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonNormalBorderStyleFor: aButton
	"Return the normal button borderStyle for the given button."
	
	(aButton valueOfProperty: #noBorder ifAbsent: [ false ]) 
		ifTrue: [ 
			^ SimpleBorderStyle new 
				width: 0; 
				baseColor: Color transparent ].
	
	^ SimpleBorderStyle new
		width: 1;
		baseColor: self buttonColor lighter! !

!PharoDarkTheme methodsFor: '*Roassal3-UML' stamp: ''!
classBoxBackgroundColor
	^ RSUMLCalypsoSettings darkThemeUMLClassColor! !

!PharoDarkTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemMouseOverFillStyleFor: aButton
	^ SolidFillStyle color: (Color white alpha: 0.15)! !

!PharoDarkTheme methodsFor: '*Iceberg-TipUI' stamp: ''!
badgeColor
	^ Color red alpha: 0.5! !

!PharoDarkTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemDisabledFillStyleFor: aButton
	"Return the disabled taskbar item fillStyle for the given color."

	^ self taskbarItemNormalFillStyleFor: aButton! !

!PharoDarkTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemDisabledBorderStyleFor: aButton
	^ self taskbarItemNormalBorderStyleFor: aButton! !

!PharoDarkTheme methodsFor: 'accessing - colors' stamp: ''!
lightBackgroundColor

	^ Color r: 0.218 g: 0.217 b: 0.217! !

!PharoDarkTheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonNormalFillStyleFor: aButton
	"Return the normal button fillStyle for the given button."
	
	(aButton valueOfProperty: #noFill ifAbsent: [false]) 
		ifTrue: [ ^ SolidFillStyle color: Color transparent ].
	^ SolidFillStyle color: self buttonColor! !

!PharoDarkTheme class methodsFor: 'accessing' stamp: ''!
lightSelectionColor
	^ Color r: 175 g: 213 b: 250 range: 255! !

!PharoDarkTheme class methodsFor: 'accessing' stamp: ''!
themeName
	^ 'Pharo Dark'! !

!PharoDarkTheme class methodsFor: 'accessing' stamp: ''!
basePassiveBackgroundColor
	^ Color darkGray! !

!PharoDarkTheme class methodsFor: 'settings' stamp: ''!
setPreferredPreferences
	"NECPreferences 
		expandPrefixes: true;
		popupShowWithShortcut: Character tab asShortcut."! !

!PharoDarkTheme class methodsFor: 'accessing' stamp: ''!
baseColor
	^ Color veryDarkGray! !

!PharoDarkTheme class methodsFor: 'accessing' stamp: ''!
veryLightSelectionColor
	^ self lightSelectionColor muchLighter! !

!PharoDarkTheme class methodsFor: 'accessing' stamp: ''!
isAbstract
	"Answer whether the receiver is considered to be abstract."

	^false! !

!PharoDarkTheme class methodsFor: 'accessing' stamp: ''!
lightBaseColor
	^ Color darkGray! !

!PharoDarkTheme class methodsFor: 'accessing' stamp: ''!
baseSelectionColor
	^ Color r: 97 g: 163 b: 225 range: 255! !

!PharoDarkTheme class methodsFor: 'accessing' stamp: ''!
darkBaseColor
	^ Color veryDarkGray! !

!PharoDocCommentExpression commentStamp: ''!
I am represent an expression within a String (typically the contents of a RBCommentNode resp. the comment text of a method. I am used as expression or the expected expression value by a PharoDocCommentNode.!
!PharoDocCommentExpression methodsFor: 'operation' stamp: ''!
methodClass
	^ node sourceNode methodNode methodClass! !

!PharoDocCommentExpression methodsFor: 'accessing' stamp: ''!
node: anObject
	node := anObject! !

!PharoDocCommentExpression methodsFor: 'accessing' stamp: ''!
node
	^ node! !

!PharoDocCommentExpression methodsFor: 'accessing' stamp: ''!
expression
	^ self source copyFrom: expressionInterval first to: expressionInterval last! !

!PharoDocCommentExpression methodsFor: 'accessing' stamp: ''!
expressionInterval: anObject
	expressionInterval := anObject! !

!PharoDocCommentExpression methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: '('.
	aStream nextPutAll: self expression. 
	aStream nextPutAll: ')'! !

!PharoDocCommentExpression methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!PharoDocCommentExpression methodsFor: 'accessing' stamp: ''!
expressionInterval
	^ expressionInterval! !

!PharoDocCommentExpression methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!PharoDocCommentExpression methodsFor: 'accessing' stamp: ''!
expressionCode

	^ self methodClass compiler
		  source: self expression;
		  noPattern: true;
		  options: #( + optionParseErrors );
		  parse! !

!PharoDocCommentExpression methodsFor: 'operation' stamp: ''!
evaluate

	^ self methodClass compiler
		  source: self expression;
		  noPattern: true;
		  receiver: self methodClass;
		  options: #( + optionParseErrors );
		  evaluate! !

!PharoDocCommentNode commentStamp: ''!
I represent a example expression (expression and value) within a method
comment (RBCommentNode). Every pair of Pharo expression and a separator (default ">>>") can be styled as Pharo code and the editor iconstyler  can highlight the code and evaluate the expression.

Example, within a method comment:

" 3 + 4 >>> 7"

The example code should show an  expression 3 + 4 and the expected value 7.

See setting on "Code Browsing" to enable / disable this doc comment style.!
!PharoDocCommentNode methodsFor: 'accessing' stamp: ''!
expression: anObject
	expression := anObject.
	expression node: self! !

!PharoDocCommentNode methodsFor: 'accessing' stamp: ''!
result
	^ result! !

!PharoDocCommentNode methodsFor: 'accessing' stamp: ''!
sourceNode
	^ sourceNode! !

!PharoDocCommentNode methodsFor: 'accessing' stamp: ''!
expression
	^ expression! !

!PharoDocCommentNode methodsFor: 'accessing' stamp: ''!
result: anObject
	result := anObject.
	anObject node: self! !

!PharoDocCommentNode methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream 
		nextPutAll: '(';
		nextPutAll: self expression source;
		nextPutAll: ')'! !

!PharoDocCommentNode methodsFor: 'private' stamp: ''!
browse
	| methodNode |
	methodNode := self sourceNode methodNode.
	(methodNode methodClass>>methodNode selector) browse! !

!PharoDocCommentNode methodsFor: 'converting' stamp: ''!
asTriplet
	"Return the expression, its returned value and its expected result."
	
	^ { self expression expressionCode formattedCode. 
		 self expression evaluate. 
		 self result expressionCode formattedCode }! !

!PharoDocCommentNode methodsFor: 'accessing' stamp: ''!
sourceNode: anObject
	sourceNode := anObject! !

!PharoDocCommentNode class methodsFor: 'settings' stamp: ''!
docCommentEnabled
	^ DocCommentEnabled  ifNil: [ DocCommentEnabled  := true ]! !

!PharoDocCommentNode class methodsFor: 'instance creation' stamp: ''!
expression: aDocExpression result: anotherDocExpression inComment: aRBComment
	^ self new
		expression: aDocExpression;
		result: anotherDocExpression;
		sourceNode: aRBComment
		yourself! !

!PharoDocCommentNode class methodsFor: 'parsing' stamp: ''!
docCommentRangesIn: aText
	^ '(([^[:cntrl:]]*)>>>\3?([^[:cntrl:]]*))' asRegex matchingRangesIn: aText! !

!PharoDocCommentNode class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #docCommentEnabled)
		target: self;
		default: true;
		description:
			'Allow styled and executable example expressions within method comments. 
		Example: 
		"3+4 >>> 7."';
		label: 'Pharo doc comments';
		parent: #codeBrowsing! !

!PharoDocCommentNode class methodsFor: 'parsing' stamp: ''!
parseDocComments: aRBCommentNode
	| ranges |
	ranges := self docCommentRangesIn: aRBCommentNode contents.
	^ ranges
		collect: [ :range | 
			| expression result exps |
			exps := '>>>' split: (aRBCommentNode contents copyFrom: range first to: range last).
			expression := PharoDocCommentExpression new
				expressionInterval: (range first to: range first + exps first size - 1);
				source: aRBCommentNode contents.
			result := PharoDocCommentExpression new
				expressionInterval: (1 + range last - exps last size to: range last);
				source: aRBCommentNode contents.
			self expression: expression result: result inComment: aRBCommentNode ]! !

!PharoDocCommentNode class methodsFor: 'settings' stamp: ''!
docCommentEnabled: aBoolean
	DocCommentEnabled := aBoolean! !

!PharoDocCommentTest commentStamp: ''!
SUnit test for PharoDocComment!
!PharoDocCommentTest methodsFor: 'tests' stamp: ''!
testExpressionResult
	"3 + 4 >>> 7"
	| expression |
	expression := thisContext method ast pharoDocCommentNodes first expression.
	self assert: expression evaluate equals: 7! !

!PharoDocCommentTest methodsFor: 'tests' stamp: ''!
testNodeResultSource
	"we use a doc comment here to test"
	"3 + 4 >>> 7"
	
	| node |
	node := thisContext method ast pharoDocCommentNodes first.
	self assert: node result source equals: '3 + 4 >>> 7'! !

!PharoDocCommentTest methodsFor: 'tests' stamp: ''!
testExpressionReferencingSelf
	"self >>> PharoDocCommentTest"
	| espression |
	espression := thisContext method ast pharoDocCommentNodes first expression.
	self assert: espression evaluate equals: self class.! !

!PharoDocCommentTest methodsFor: 'tests' stamp: ''!
testExpression
	"3 + 4 >>> 7"
	| expression |
	expression := thisContext method ast pharoDocCommentNodes first expression.
	self assert: expression source equals: '3 + 4 >>> 7'! !

!PharoDocCommentTest methodsFor: 'tests' stamp: ''!
testMultipleDocComments
	"3 + 4 >>> 7"
	"1 + 2 >>> 3."
	| espression |
	espression := thisContext method ast pharoDocCommentNodes first expression.
	self assert: espression evaluate equals: 7.
	espression := thisContext method ast pharoDocCommentNodes second expression.
	self assert: espression evaluate equals: 3.! !

!PharoDocCommentTest methodsFor: 'tests' stamp: ''!
testAssociation

	|association|
	association := 3 + 4 >>> 7.
	self 
		assert: association key equals: 7;
		assert: association value equals: 7! !

!PharoDocCommentTest methodsFor: 'tests' stamp: ''!
testMultipleDocCommentsInOneComment
	"3 + 4 >>> 7.
	1 + 2 >>> 3."
	| espression |
	espression := thisContext method ast pharoDocCommentNodes first expression.
	self assert: espression evaluate equals: 7.
	espression := thisContext method ast pharoDocCommentNodes second expression.
	self assert: espression evaluate equals: 3.! !

!PharoEnvironmentHelp commentStamp: ''!
This is introductory help for the Pharo environment and tools. 

!! Keyboard Shortcuts

Pharo has a variety of useful keyboard shortcuts that help you navigate its environment without always using a mouse.

!!!! Browser Shortcuts

There are many keyboard shortcuts available in Pharo:

- You can see them at the end of the System Browser's context menu lines by right-clicking on any area (packages, classes, protocols, methods or code editor).

- Shortcuts are typically multi-key combinations, where you hold a modifier key and press the listed secondary key. For example if something is listed as CMD-F, CMD-C you would press and hold the CMD key while typing  F and then C. 
There are also two-letter shortcuts, such as (CMD-GA) or (CMD-AA). You must press and hold the CMD key while typing G and release, type A and release.

- The modifier key varies between platforms:
 - Windows = CTRL
 - Mac/OSX = CMD
 - Linux = CTRL

!!!! Spotter/Global search

Similar to the Spotlight search on OSX, or the Windows Search charm - Pharo has a global code search tool that is activated using:  Shift+Enter

This search tool shows a popup window on the center of the screen where you can incrementally search for classes, packages, symbols,  pragmas, files, folders and many other types of data.  As you type a search query  all available searches are performed at the same time and results are displayed as they are discovered and grouped based on the type of the search.

You can cursor/keyboard navigate through the results, or press enter to spawn a new tool to examine the selected result.
The following shortcuts are available:

	Ctrl+Arrow_right dives in and restricts the available types of searches only to the selected element.
	Ctrl+Shift+Arrow_right dives in and shows all the rearch results from a category.
	Ctrl+Arrow_left dives out to the previous search
	Ctrl+p toggles the preview pane
	Enter  spawns a new tool to examine the selected result
	Ctrl+Shift+Arrow_down/Ctrl+Shift+Arrow_down navigatew through different types of searches
	Shift highlights all butons from the UI (only works with newer VMs)

!!!! Visual Exploration

A useful way of discovering how things work in Pharo, is to point your mouse cursor at something on the screen (e.g. a browser button) and invoke a visual Halo selection by pressing: 

  Alt+Shift + left mouse click

If you continue clicking the left mouse button (while holding Alt+Shift), the halo will expand it's selection to the current item's parent. This is useful for traversing the lineage of graphical Morph's to see what contains what.

The halo has a series of icons, which if you hover over them will give you some balloon help about their operation. For exploring, the spanner icon is useful for letting you inspect or browse the current item to locate where the actual code is implemented.

To remove the halo,  simply click anywhere outside of the current halo.

It is possible to directly explore a visual object and bypass using the halo mechanism by pressing:

  Ctrl+Shift + left mouse click

This will give you a menu for the current item with options to inspect, debug etc.

!! Browsing and Navigating Code

Finding and navigating through code in Pharo is an important part of developing programs in Smalltalk.

!!!! System Browser (Calypso)

The System Browser (available in the desktop World menu), is the primary way of viewing your source code. This browser framework has been rewritten in Pharo and is often referred to as Calypso (see the other top level help item for more technical details).

The previous browser was called Nautilus, maybe you can see some outdated reference to Nautilus in some places.

!!!!!! Showing Hierarchies

Calypso defaults to a simple 'Flat' display of the list of classes that are in the currently selected package (far left). If you want to see the hierarchy of a particular class, first select it and then press (toggle) the 'Flat' button, to show show its 'Hierarchy'. Pressing this button again will toggle back to the 'Flat' model.

!!!!!! Browser History

The browser records the history of methods and classes you have visited similar to a Web Browser. The dropdown list in the middle right of the panes (above the lower text pane) shows this history, and clicking on one of its items will navigate to that item. This is convenient if you have clicked on a different package, or navigated to superclass and want to return back to where you were. 

In the same area, there is the versions button. You can easily revert any code changes to any time in the past.

!!!!!! Customising

The system browser can also be configured with a different title as well as optional plugins. These are all available in the window dropdown menu in the top right of the title bar (normally a small triangle).

!!!! Spotter

Use the Shift+Enter global keystroke to activate a popup window that lets you incrementally search for methods, classes, packages, pragmas, files, folders and many other types of data.

!!!! Finder 

The code Finder browswer is available from the World | Tools menu. The Finder lets you enter some general text in top edit field and then categorize it as either text, or language construct in the dropdown list to refine your search. There are more detailed instructions in the bottom pane of the browser detailing the different options.

!!!! Workspace

In any workspace you can type or select any text and then perform an 'code search' (context menu item) that will look for matching senders, implementors, references or method source.

!! Icons

There are many icons that are visible in the envionment, each with different meanings.

!!!! General

An orange smudge in the top right of any editable text field indicatest that the field has been modified and should be saved with CMD+S.

!!!! Class Pane

In the System Browser class pane, you will see the following icons appear next to specific types of class objects:

- Red exclamation mark: a missing class comment. The pharo team reccommend that all classes should describe their intent with a comment. 
- Gray dot: a TestCase 
- Yellow Lightening bolt: an Exception 
- 3 Coloured Balls: a Collection 
- Blue Speech bubble: an Announcement 
- Blue Paragraph symbol: a String 
- Gray Epsilon symbol: a Magniture 
- Blue Matrix box: a graphcial Morph 
- Purple Ball with T: a Trait

!!!! Protocol Pane

In the System Browser protocol pane, you will see the following icons appear next to specific types of protocol objects:

- Yellow diamond: initialisation methods
- Red Square: private methods

!!!! Method Pane

In the System Browser methods pane, you will see the following icons appear next to specific types of method objects:

- Blue Up Arrow: indicates this method overrides a method in a super class
- Blue Down Arrow: indicates this method is overriden in a subclass

!!!! Source Pane

In the System Browser lower code source pane, you will see the following icons appear which have the following meaning:

- Orange Smudge top right: the source has changed and should be saved
- Yellow Stripe right margin: a long or complicated method that needs refactoring
- Yellow Padlock top right: when locked, indicates the current method source will be displayed stacked with other locked methods in the source pane

!! Getting More Help

If you need more detailed help, here are some additional places to look.
!!!! Pharo Tutorial

Try using the Pharo Smalltalk tutorial by evaluating (CMD+D) the code below: 
	ProfStef go.

!!!! Online Resources

You can find more information about Pharo by visiting: 
	https://pharo.org

In particular, you may also be interested in:

- Joining discussions and getting help at: https://pharo.org/community
- Pharo Books: http://books.pharo.org/
- The Pharo By Example book (available as a free PDF): http://books.pharo.org/updated-pharo-by-example/
- Browsing the online documentation: https://pharo.org/documentation
- Reporting problems: https://pharo.org/contribute


!
!PharoEnvironmentHelp class methodsFor: 'help-text' stamp: ''!
wikiStyleHelp
	<wikiStyleHelp: #' Pharo Environment Help'>
	
	^ self comment! !

!PharoFilesOpener commentStamp: ''!
My role is to open the .sources and .changes files. My only public methods are in the 'public' protocol. The most important method is #checkAndOpenSourcesAndChanges.!
!PharoFilesOpener methodsFor: 'user interaction' stamp: ''!
inform: msg withRef: fileRef
	self inform: (msg copyReplaceAll: '&fileRef' with: fileRef)! !

!PharoFilesOpener methodsFor: 'public' stamp: ''!
unsetInformAboutReadOnlyChanges
	"Make sure the user is *not* informed when the .changes file can not be written to."
	shouldInformAboutReadOnlyChanges := false! !

!PharoFilesOpener methodsFor: 'messages' stamp: ''!
cannotLocateMsg
	^ 'Pharo cannot locate &fileRef.

Please check that the file is named properly and is in the
same directory as this image.'! !

!PharoFilesOpener methodsFor: 'open sources' stamp: ''!
informCannotLocateSources
	| msg |
	msg := self cannotLocateMsg.
	Smalltalk os isMacOS
		ifTrue: [ 
			msg := msg
				,
					'
Make sure the sources file is not an Alias.' ].
	self inform: msg withSourceRef: self sourcesName! !

!PharoFilesOpener methodsFor: 'open sources' stamp: ''!
openSources: fullSourcesName forImage: imagePath
	"Look in various places for a sources file, return an open stream to it."

	| locations |
	locations := OSPlatform current potentialLocationsOfSourcesFile, {
		FileLocator imageDirectory.
		FileLocator workingDirectory
	}.

	^ (SourceFile on: fullSourcesName potentialLocations: locations)
		tryOpenReadOnly: true;
		yourself! !

!PharoFilesOpener methodsFor: 'public' stamp: ''!
changesFileOrNilReadOnly: readOnly silent: silent
	| changesFile |
	changesFile := self openChanges: self changesName readOnly: readOnly.
	(changesFile isNil and: [ silent not ])
		ifTrue: [ self informProblemInChanges: self cannotLocateMsg ].

	silent
		ifTrue: [ ^ changesFile ].
		
	changesFile isOpen ifFalse: [ 
		changesFile := nil.
		^ nil ].

	(changesFile isReadOnly and: [ self shouldInformAboutReadOnlyChanges ])
		ifTrue: [ self informProblemInChanges: self cannotWriteMsg ].
	((changesFile next: 200) includesSubstring: String crlf)
		ifTrue: [ self informProblemInChanges: self badContentMsg ].
	^ changesFile! !

!PharoFilesOpener methodsFor: 'public' stamp: ''!
shouldInformAboutReadOnlyChanges
	"Answer true if and only if the user must be informed when the .changes file can not be written to."
	^ shouldInformAboutReadOnlyChanges ifNil: [ shouldInformAboutReadOnlyChanges := true ]! !

!PharoFilesOpener methodsFor: 'user interaction' stamp: ''!
informProblemInChanges: msg
	self inform: msg withChangesRef: self changesName! !

!PharoFilesOpener methodsFor: 'helper' stamp: ''!
ignoreIfFail: aBlock
	^ [ aBlock value ] onErrorDo: [  ]! !

!PharoFilesOpener methodsFor: 'public' stamp: ''!
setInformAboutReadOnlyChanges
	"Make sure the user is informed when the .changes file can not be written to."
	shouldInformAboutReadOnlyChanges := true! !

!PharoFilesOpener methodsFor: 'public' stamp: ''!
sourcesFileOrNil
	| sources |
	sources := self openSources.
	^ (sources isNil or: [ sources closed ])
		ifTrue: [ 
			self informCannotLocateSources.
			nil ]
		ifFalse: [ sources ]! !

!PharoFilesOpener methodsFor: 'delegated' stamp: ''!
sourcesName
	^ Smalltalk sourcesName! !

!PharoFilesOpener methodsFor: 'open changes' stamp: ''!
openChanges: changesPath readOnly: readOnly

	^ (SourceFile on: changesPath potentialLocations: {
			FileLocator imageDirectory.
			FileLocator workingDirectory.
		}) tryOpenReadOnly: readOnly;
			yourself! !

!PharoFilesOpener methodsFor: 'user interaction' stamp: ''!
inform: msg withChangesRef: fileRef
	self inform: msg withRef: 'the changes file named ' , fileRef! !

!PharoFilesOpener methodsFor: 'messages' stamp: ''!
badContentMsg
	^ '&fileRef
has been injured by an unpacking utility.  Crs were changed to CrLfs.
Please set the preferences in your decompressing program to 
"do not convert text files" and unpack the system again.'! !

!PharoFilesOpener methodsFor: 'public' stamp: ''!
changesFileOrNil

	^ self changesFileOrNilReadOnly: false! !

!PharoFilesOpener methodsFor: 'delegated' stamp: ''!
lastImagePath
	^ Smalltalk lastImagePath! !

!PharoFilesOpener methodsFor: 'messages' stamp: ''!
cannotWriteMsg
	^ 'Pharo cannot write to &fileRef.

Please check that you have write permission for this file.

You won''t be able to save this image correctly until you fix this.'! !

!PharoFilesOpener methodsFor: 'public' stamp: ''!
changesFileOrNilReadOnly: readOnly

	^ self changesFileOrNilReadOnly: readOnly silent: false! !

!PharoFilesOpener methodsFor: 'user interaction' stamp: ''!
inform: msg withSourceRef: fileRef
	self inform: msg withRef: 'the sources file named ' , fileRef! !

!PharoFilesOpener methodsFor: 'open sources' stamp: ''!
openSources
	^ self openSources: self sourcesName forImage: self lastImagePath! !

!PharoFilesOpener methodsFor: 'delegated' stamp: ''!
changesName
	^ Smalltalk changesName! !

!PharoFilesOpener class methodsFor: 'singleton' stamp: ''!
default
	^ Default ifNil: [ Default := self new ]! !

!PharoFilesOpener class methodsFor: 'class initialization' stamp: ''!
reset
	Default := nil! !

!PharoKernelAssembly commentStamp: ''!
I store metadata for this package assembly.!
!PharoKernelAssembly class methodsFor: 'meta-data' stamp: ''!
parts
	^ {
		(#Kernel -> #()) .
		(#Monticello -> #()) .
		(#'PharoBootstrap-Initialization' -> #()) .
		(#'Transcript-NonInteractive' -> #())
	}! !

!PharoKernelAssembly class methodsFor: 'meta-data' stamp: ''!
description
	^ 'I represent the minimal kernel, i.e. the minimum set of packages needed, to get a usable Pharo image.'! !

!PharoKernelAssembly class methodsFor: 'meta-data' stamp: ''!
version
	^ '1.0-dev'! !

!PharoKernelAssembly class methodsFor: 'meta-data' stamp: ''!
packageName
	^ #'Pharo-Kernel'! !

!PharoLightTheme commentStamp: ''!
The theme is developed in the context of the Glamour project, and its goal is to create a look that:
- does not look like a specific operating system. In particular, the icons should be operating system agnostic, because, for example, people in Windows are confused by the red, yellow, green buttons of apple.
- uses a limited amount of colors and effects.
- is fast.

self defaultSettings: nil.
self beCurrent. 

Is adopted as the theme for Pharo3, but it was renamed to avoid collisions with the glamour team,!
!PharoLightTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemMouseOverBorderStyleFor: aButton
	^ BottomBorderStyle new
		color: (Color fromHexString: '616161');
		width: 2;
		yourself! !

!PharoLightTheme methodsFor: 'accessing - colors' stamp: ''!
ghostTextColor

	^ Color darkGray! !

!PharoLightTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedBorderStyleFor: aButton
	^ self taskbarItemMouseOverBorderStyleFor: aButton! !

!PharoLightTheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonDisabledBorderStyleFor: aButton
	"Return the disabled button fillStyle for the given color."

	^ BorderStyle
		width: 0
		color: Color transparent! !

!PharoLightTheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonDisabledFillStyleFor: aButton
	"Return the disabled button fillStyle for the given color."

	^ SolidFillStyle color: Color transparent! !

!PharoLightTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedPressedBorderStyleFor: aButton
	^ self taskbarItemMouseOverBorderStyleFor: aButton! !

!PharoLightTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedPressedFillStyleFor: aButton
	^ SolidFillStyle color: (Color black alpha: 0.2)! !

!PharoLightTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedMouseOverBorderStyleFor: aButton
	^ self taskbarItemMouseOverBorderStyleFor: aButton! !

!PharoLightTheme methodsFor: 'forms' stamp: ''!
scrollbarPressedThumbFillStyleFor: aScrollbar
	"Return the pressed scrollbar thumb fillStyle for the given scrollbar."
		"Return the normal scrollbar fillStyle for the given scrollbar."
	
	"^ (self glamorousNormalFillStyleWithBaseColor: aScrollbar paneColor for:  aScrollbar height: aScrollbar height)
		direction: (aScrollbar bounds isWide
			ifTrue: [0 @ aScrollbar height]
			ifFalse: [aScrollbar width @ 0])"
"	^ SolidFillStyle color: Color lightGray lighter."
	^ self selectedFillStyleFor: aScrollbar height: aScrollbar height! !

!PharoLightTheme methodsFor: 'accessing - colors' stamp: ''!
balloonBackgroundColor

	^ (Color r: 1.0 g: 1.0 b: 0.71 alpha: 1.0)! !

!PharoLightTheme methodsFor: 'initialization' stamp: ''!
initialize
	"self beCurrent"

	super initialize.
	self windowActiveDropShadowStyle: #diffuse.
	self settings preferGradientFill: false.! !

!PharoLightTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemPressedBorderStyleFor: aButton
	^ self taskbarItemNormalBorderStyleFor: aButton! !

!PharoLightTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemPressedFillStyleFor: aButton
	^ SolidFillStyle color: (Color black alpha: 0.15)! !

!PharoLightTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedMouseOverFillStyleFor: aButton
	^ SolidFillStyle color: (Color black alpha: 0.15)! !

!PharoLightTheme methodsFor: 'forms' stamp: ''!
newRadioMarkerForm
	"Answer a new checkbox marker form."

	^Form extent: 12@12 depth: 32! !

!PharoLightTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemNormalFillStyleFor: aButton
	^ SolidFillStyle color: Color transparent! !

!PharoLightTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedDisabledBorderStyleFor: aButton
	^ self taskbarItemMouseOverBorderStyleFor: aButton! !

!PharoLightTheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonNormalBorderStyleFor: aButton
	"Return the normal button borderStyle for the given button."

	| outerColor |
	(aButton valueOfProperty: #noBorder ifAbsent: [false]) 
		ifTrue: [ ^ SimpleBorderStyle new 
							width: 0; 
							baseColor: Color transparent ].
	outerColor := self darkBaseColorFor: aButton.
	^ SimpleBorderStyle new
			width: 1;
			baseColor: outerColor! !

!PharoLightTheme methodsFor: 'border-styles' stamp: ''!
configureWindowBorderFor: aWindow

	| aStyle |
	aStyle := SimpleBorderStyle new 
					color: (Color lightGray);
					width: 1.
	aWindow borderStyle: aStyle! !

!PharoLightTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemMouseOverFillStyleFor: aButton
	^ SolidFillStyle color: (Color black alpha: 0.07)! !

!PharoLightTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarFillStyleFor: aTaskbar
	^ SolidFillStyle color: (Color gray muchLighter alpha: 0.8)! !

!PharoLightTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemNormalBorderStyleFor: aButton
	^ BottomBorderStyle new
		color: (Color fromHexString: '757575');
		width: 2;
		trimSize: 2;
		yourself! !

!PharoLightTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemDisabledFillStyleFor: aButton
	"Return the disabled taskbar item fillStyle for the given color."

	^ self taskbarItemNormalFillStyleFor: aButton! !

!PharoLightTheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedFillStyleFor: aButton
	^ SolidFillStyle color: (Color black alpha: 0.1)! !

!PharoLightTheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemDisabledBorderStyleFor: aButton
	^ self taskbarItemNormalBorderStyleFor: aButton! !

!PharoLightTheme class methodsFor: 'accessing' stamp: ''!
lightSelectionColor
	^ Color r: 175 g: 213 b: 250 range: 255! !

!PharoLightTheme class methodsFor: 'accessing' stamp: ''!
themeName
	^ 'Pharo Light'! !

!PharoLightTheme class methodsFor: 'settings' stamp: ''!
setPreferredShoutColors
	"self setPreferredShoutColors"

	SHRBTextStyler 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)))! !

!PharoLightTheme class methodsFor: 'accessing' stamp: ''!
basePassiveBackgroundColor
	^ Color r: 245 g: 245 b: 245 range: 255! !

!PharoLightTheme class methodsFor: 'settings' stamp: ''!
setPreferredPreferences
	"NECPreferences 
		expandPrefixes: true;
		popupShowWithShortcut: Character tab asShortcut."! !

!PharoLightTheme class methodsFor: 'accessing' stamp: ''!
baseColor
	^ Color r: 210 g: 210 b: 210 range: 255! !

!PharoLightTheme class methodsFor: 'accessing' stamp: ''!
veryLightSelectionColor
	^ self lightSelectionColor muchLighter! !

!PharoLightTheme class methodsFor: 'accessing' stamp: ''!
isAbstract
	"Answer whether the receiver is considered to be abstract."

	^false! !

!PharoLightTheme class methodsFor: 'accessing' stamp: ''!
lightBaseColor
	^ Color r: 230 g: 230 b: 230 range: 255! !

!PharoLightTheme class methodsFor: 'accessing' stamp: ''!
baseSelectionColor
	^ Color r: 97 g: 163 b: 225 range: 255! !

!PharoLightTheme class methodsFor: 'accessing' stamp: ''!
darkBaseColor
	^ Color r: 200 g: 200 b: 200 range: 255! !

!PharoShortcuts commentStamp: ''!
I am a class defining the current shortcuts of the system. My main purpose is to avoid the duplication of shortcut definition amongst basic tools and to allow to change the shortcuts from a single place.

Users may query me to know the key combinations used to accept or cancel an action, browse or inspect an object.

EXAMPLES

PharoShortcuts current browseShortcut => Cmd-B

ATTENTION - I'm not still finished. My #current method returns always a new instance of myself instead of a configured one.

NEXT Steps: Allow one to configure the shortcuts and to define several shortcut configurations via settings.!
!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
findShortcut
	^ $f meta! !

!PharoShortcuts methodsFor: 'keymaps - window resizing' stamp: ''!
windowRightEdgeLeftShortcut

	^ self windowManagementShortcut, $d shift meta, $s shift meta! !

!PharoShortcuts methodsFor: 'keymaps - code search' stamp: ''!
methodStringContainingItShortcut

	^  $e meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
textEndShortcut

	^ Character end meta
	 ! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectBackwardWordShortcut
	^ Character arrowLeft meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
cursorHomeShortcut

	^ Character home meta! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
indentShortcut

	^ $r meta shift! !

!PharoShortcuts methodsFor: 'keymaps - code search' stamp: ''!
browseSendersShortcut

	^ $n meta! !

!PharoShortcuts methodsFor: 'keymaps - code' stamp: ''!
removeShortcut

	^ $x meta! !

!PharoShortcuts methodsFor: 'keymaps - window resizing' stamp: ''!
windowLeftEdgeLeftShortcut

	^ self windowManagementShortcut, $a shift meta, $a shift meta! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowMinimizeShortcut

	^ self windowManagementShortcut, $s shift! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowTopShortcut

	^ self windowManagementShortcut, $w! !

!PharoShortcuts methodsFor: 'keymaps - code' stamp: ''!
printItShortcut

	^ $p meta! !

!PharoShortcuts methodsFor: 'keymaps - Tools' stamp: ''!
saveImageShortcut
	^ $s meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
pageUpShortcut

	^ Character pageUp asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
selectAllShortcut

	^ $a meta! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
toggleBoldEmphasisShortcut

	^ $7 meta! !

!PharoShortcuts methodsFor: 'keymaps - code' stamp: ''!
fileItInShortcut

	^ $g alt win | $g alt unix | $g option mac! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
selectUndoShortcut

	^ $m meta shift! !

!PharoShortcuts methodsFor: 'keymaps - code search' stamp: ''!
browseMethodHierarchyShortcut

	^ $i meta! !

!PharoShortcuts methodsFor: 'keymaps - window resizing' stamp: ''!
windowTopEdgeDownShortcut

	^ self windowManagementShortcut, $w shift meta, $s shift meta! !

!PharoShortcuts methodsFor: 'keymaps - window' stamp: ''!
windowManagementShortcut

	^ $w shift meta! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
makeLowercaseShortcut

	^ $x meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
backwardLineShortcut

	^ Character arrowUp asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
delShortcut

	^ Character delete asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
backwardWordShortcut
	^ Character arrowLeft meta! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectForwardLineShortcut

	^ Character arrowDown shift! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
backspaceShortcut

	^ Character backspace asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectTextStartShortcut
	^ Character home shift meta! !

!PharoShortcuts methodsFor: 'keymaps - debugger' stamp: ''!
stepOverShortcut

	^ $o meta shift! !

!PharoShortcuts methodsFor: 'keymaps - window' stamp: ''!
closeWindowShortcut

	^ $w meta! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
lineEndShortcut

	^ Character end asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
forwardLineShortcut

	^ Character arrowDown asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - Tools' stamp: ''!
openPlaygroundShortcut
	^ $o meta, $w meta! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
normalEmphasisShortcut

	^ $0 meta! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectTextEndShortcut

	^ Character end shift meta
	 ! !

!PharoShortcuts methodsFor: 'keymaps - Tools' stamp: ''!
openTestRunnerShortcut
	^ $o meta , $u meta! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
cursorEndShortcut

	^ Character end meta! !

!PharoShortcuts methodsFor: 'keymaps - window resizing' stamp: ''!
windowLeftEdgeRightShortcut

	^ self windowManagementShortcut, $a shift meta, $s shift meta! !

!PharoShortcuts methodsFor: 'keymaps - code search' stamp: ''!
browseImplementorsShortcut

	^ $m meta! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectForwardWordShortcut
	^ Character arrowRight shift meta! !

!PharoShortcuts methodsFor: 'keymaps - debugger' stamp: ''!
resumeExecutionShortcut

	^ $r meta! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
changeStyleShortcut

	^ $k meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
escapeShortcut

	^ Character escape asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - Tools' stamp: ''!
openSystemBrowserShortcut
	^ $o meta , $b meta! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectBackwardLineShortcut

	^ Character arrowUp shift! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
increaseKerningShortcut

	^ $= meta! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
acceptShortcut

	^ $s meta! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
duplicateFromSelectionShortcut

	^ $d meta shift! !

!PharoShortcuts methodsFor: 'keymaps - window moving' stamp: ''!
windowMoveUpShortcut

	^ self windowManagementShortcut, Character arrowUp! !

!PharoShortcuts methodsFor: 'keymaps - code search' stamp: ''!
querySymbolShortcut

	^  $q meta shift! !

!PharoShortcuts methodsFor: 'keymaps - code' stamp: ''!
pasteInitialsShortcut

	^ $v alt win | $v alt unix | $v option mac! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowCenterShortcut

	^ self windowManagementShortcut, $r! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectBackwardCharShortcut

	^ Character arrowLeft shift! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowBottomShortcut

	^ self windowManagementShortcut, $x! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
cutShortcut

	^ $x meta! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
findAgainShortcut
	^ $g meta! !

!PharoShortcuts methodsFor: 'keymaps - code search' stamp: ''!
browseReferencesShortcut

	^ $b meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
strokethroughShortcut

	^ $= meta! !

!PharoShortcuts methodsFor: 'keymaps - code' stamp: ''!
displayIfTrueShortcut

	^ $t alt win | $t alt unix | $t option mac! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
makeCapitalizedShortcut

	^ $z meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
openFontAlignmentMenuShortcut

	^ $u meta! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
setSearchStringShortcut
	^ $h meta! !

!PharoShortcuts methodsFor: 'keymaps - window moving' stamp: ''!
windowMoveDownShortcut

	^ self windowManagementShortcut, Character arrowDown! !

!PharoShortcuts methodsFor: 'keymaps - code search' stamp: ''!
browseVersionsShortcut

	^ $v meta! !

!PharoShortcuts methodsFor: 'keymaps - window moving' stamp: ''!
windowMoveRightShortcut

	^ self windowManagementShortcut, Character arrowRight! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectPageUpShortcut

	^ Character pageUp shift! !

!PharoShortcuts methodsFor: 'keymaps - Tools' stamp: ''!
openMonticielloShortcut
	^ $o meta, $p meta! !

!PharoShortcuts methodsFor: 'keymaps - code' stamp: ''!
doItShortcut

	^ $d meta! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowTopRightShortcut

	^ self windowManagementShortcut, $e! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
backwardWordDeleteShortcut

	^ Character backspace shift! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
compareToClipboardShortcut

	^ $c meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
searchShortcut
	^ $s meta! !

!PharoShortcuts methodsFor: '*Iceberg-TipUI' stamp: ''!
openIcebergShortcut
	^ $o meta, $i meta! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
undoShortcut

	^ $z meta! !

!PharoShortcuts methodsFor: 'keymaps - code' stamp: ''!
debugItShortcut

	^  $d meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
formatCodeShortcut

	^ $f meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
copySelectionShortcut

	^ $c meta! !

!PharoShortcuts methodsFor: 'keymaps - code search' stamp: ''!
browseShortcut

	^ $b meta! !

!PharoShortcuts methodsFor: 'keymaps - code search' stamp: ''!
browseClassReferencesShortcut

	^ $n meta shift! !

!PharoShortcuts methodsFor: 'keymaps - window resizing' stamp: ''!
windowTopEdgeUpShortcut

	^ self windowManagementShortcut, $w shift meta, $w shift meta! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
pageDownShortcut

	^ Character pageDown asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
toggleItalicEmphasisShortcut

	^ $8 meta! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
exchangeSelectionShortcut

	^ $e meta! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
outdentShortcut

	^ $l meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
swapCharsShortcut

	^ $y meta! !

!PharoShortcuts methodsFor: 'keymaps - window moving' stamp: ''!
windowMoveLeftShortcut

	^ self windowManagementShortcut, Character arrowLeft! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
textStartShortcut

	^ Character home meta
! !

!PharoShortcuts methodsFor: 'keymaps - Tools' stamp: ''!
openTranscriptShortcut
	^ $o meta , $t meta! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
makeUppercaseShortcut

	^ $y meta shift! !

!PharoShortcuts methodsFor: 'keymaps - debugger' stamp: ''!
stepThroughShortcut

	^ $t meta shift! !

!PharoShortcuts methodsFor: 'keymaps - code' stamp: ''!
argAdvanceShortcut
	^ $a meta shift! !

!PharoShortcuts methodsFor: 'keymaps - window resizing' stamp: ''!
windowBottomEdgeUpShortcut

	^ self windowManagementShortcut, $x shift meta, $s shift meta! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectForwardCharShortcut

	^ Character arrowRight shift! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
toggleCommentOnSelectionOrLine

	^ $/ meta! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
lineStartShortcut

	^ Character home asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectLineEndShortcut
	^ Character end shift! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectPageDownShortcut

	^ Character pageDown shift! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowRightShortcut

	^ self windowManagementShortcut, $d! !

!PharoShortcuts methodsFor: 'keymaps - debugger' stamp: ''!
stepIntoShortcut

	^ $e meta ! !

!PharoShortcuts methodsFor: 'keymaps - code' stamp: ''!
displayIfFalseShortcut

	^ $f alt! !

!PharoShortcuts methodsFor: 'keymaps - code' stamp: ''!
inspectItShortcut

	^ $i meta! !

!PharoShortcuts methodsFor: 'keymaps - window resizing' stamp: ''!
windowRightEdgeRightShortcut

	^ self windowManagementShortcut, $d shift meta, $d shift meta! !

!PharoShortcuts methodsFor: 'keymaps - debugger' stamp: ''!
restartExecutionShortcut

	^ $a meta shift! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowLeftShortcut

	^ self windowManagementShortcut, $a! !

!PharoShortcuts methodsFor: 'keymaps - editor selection' stamp: ''!
selectLineStartShortcut
	^ Character home shift! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
openFontMenuShortcut

	^ $k meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
cancelShortcut

	^ $l meta! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowMaximizeShortcut

	^ self windowManagementShortcut, $s! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowTopLeftShortcut

	^ self windowManagementShortcut, $q! !

!PharoShortcuts methodsFor: 'keymaps - window resizing' stamp: ''!
windowBottomEdgeDownShortcut

	^ self windowManagementShortcut, $x shift meta, $x shift meta! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
backwardCharShortcut

	^ Character arrowLeft asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - Tools' stamp: ''!
openSettingsShortcut
	^ $o meta, $s meta! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
underlineShortcut

	^ $_ meta! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowBottomLeftShortcut

	^ self windowManagementShortcut, $z! !

!PharoShortcuts methodsFor: 'keymaps - window tiling' stamp: ''!
windowRightBottomShortcut

	^ self windowManagementShortcut, $c! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
redoShortcut

	^ $z meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
openFontColorMenuShortcut

	^ $6 meta! !

!PharoShortcuts methodsFor: 'keymaps - editor style' stamp: ''!
decreaseKerningShortcut

	^ $9 meta! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
delWordShortcut

	^ Character delete shift asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
forwardCharShortcut

	^ Character arrowRight asShortcut! !

!PharoShortcuts methodsFor: 'keymaps - code search' stamp: ''!
methodNamesContainingItShortcut

	^  $w meta shift! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
selectWordShortcut

	^ Character space meta! !

!PharoShortcuts methodsFor: 'keymaps - editor navigation' stamp: ''!
forwardWordShortcut
	^ Character arrowRight meta! !

!PharoShortcuts methodsFor: 'keymaps - editor edit' stamp: ''!
pasteShortcut

	^ $v meta! !

!PharoShortcuts class methodsFor: 'accessing' stamp: ''!
current

	^ self new! !

!PharoSourcesCondenser commentStamp: ''!
I create a more compact version of the .sources file.
I move the source code from all methods to a new .sources file where I keep only one version.
Additionally I will empty the current .changes file.!
!PharoSourcesCondenser methodsFor: 'private - 3 installing' stamp: ''!
updateQuitPosition
	
	"We use an empty .changes file, hence the last quit position is 0"
	
	Smalltalk lastQuitLogPosition: 0.! !

!PharoSourcesCondenser methodsFor: 'accessing' stamp: ''!
fileIndex
	"We are working on the .sources file which has index = 1"
	^ 1! !

!PharoSourcesCondenser methodsFor: 'writing' stamp: ''!
writeClassComment: aClass

	| organizer commentRemoteString stamp |

	organizer := aClass organization.
	commentRemoteString := self commentRemoteStringFor: organizer.

	commentRemoteString ifNil: [ ^ self ].

	self
		nextCommentChunkDo: [ :strm | 
			strm
				nextPutAll: aClass name;
				nextPutAll: ' commentStamp: '.
			stamp := organizer commentStamp ifNil: [ '<historical>' ].
			stamp storeOn: strm
			].

	self writeRemoteString: organizer classComment for: aClass! !

!PharoSourcesCondenser methodsFor: 'public' stamp: ''!
newSourceNamed: aString
	"Create a new version of the .sources file by copying the existing file to a new location"
	| originalSourcesFile newSourcesFile |
	
	"Create a copy with the new name"
	originalSourcesFile := self originalFile resolve asFileReference.
	Smalltalk sourceFileVersionString: aString.
	newSourcesFile := Smalltalk sourcesFile asFileReference.

	originalSourcesFile copyTo: newSourcesFile.
	"Use the new sources file"
	Smalltalk openSourceFiles.! !

!PharoSourcesCondenser methodsFor: 'private - 3 installing' stamp: ''!
installFreshChangesFile
	| changesFile |
	
	"install a new .changes file"
	changesFile := Smalltalk changesFile.
	changesFile moveTo: (changesFile , 'bak') nextVersion.
	
	"Force the creation of a fresh changes file "
	changesFile writeStreamDo: [ :strm |
		 "Nothing, just create the file" ].! !

!PharoSourcesCondenser methodsFor: 'accessing' stamp: ''!
temporaryFile
	^ 'new.sources' asFileReference nextVersion! !

!PharoSourcesCondenser methodsFor: 'private - testing' stamp: ''!
shouldCondenseMethod: aCompiledMethod
	"The sources condenser moves ALL method sources to a new file"
	^ aCompiledMethod hasSourcePointer! !

!PharoSourcesCondenser methodsFor: 'private - 3 installing' stamp: ''!
backupOldChanges
	super backupOldChanges.
	self installFreshChangesFile.! !

!PharoSourcesCondenser methodsFor: 'accessing' stamp: ''!
originalFile
	^ Smalltalk sourcesFile asFileReference! !

!PharoSourcesCondenser class methodsFor: 'helper' stamp: ''!
condenseNewSources
	| fileName condenser arch |

	arch := (Smalltalk vm wordSize = 4) ifTrue: [32] ifFalse: [64].
	
	fileName := 'Pharo{1}.{2}-{3}bit-{4}' format: {SystemVersion current major asString. SystemVersion current minor asString. arch. SystemVersion current commitHashShort asString}.
	
	condenser := self new.
	condenser newSourceNamed: fileName.
	condenser condense.! !

!PharoSyntaxTutorial commentStamp: ''!
The default Pharo tutorial to learn the Pharo syntax!
!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
pharoEnvironment
	^ Lesson
title: 'Pharo environment' 
lesson: 
'"Pharo is full of objects. There are windows, text, numbers, dates, colors, points and much more. You can interact with objects in a much more direct way than is possible with other programming languages.

Every object understands the message ''inspect''. As a result, you get an Inspector window that shows details about the object."

Date today inspect.

"This shows that the date object consists of a point in time (start) and a duration (one day long)."

ProfStef inspect.

"You see, ProfStef class has a lot of objects. Let''s take a look at my code:"

ProfStef browse.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
blocksAssignation
	^ Lesson
title: 'Block assignation' 
lesson: 
'"Blocks can be assigned to a variable then executed later.

Note that |b| is the declaration of a variable named ''b'' and that '':='' assigns a value to a variable.

Select the three lines then Print it:"

|b|
b := [:x | x+2].
b value: 12.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
basicTypesCharacters
	^ Lesson
title: 'Basic types: Characters' 
lesson: 
'"A Character can be instantiated using $ operator:"

$A.

$A class.

$B charCode.

Character cr.

Character space.

"You can print all 256 characters of the ASCII extended set:"

Character allByteCharacters.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
debugger
	^ Lesson
title: 'Debugger' 
lesson: '"The Debugger may be the most famous tool of Smalltalk environments. It will open as soon as an unmanaged Exception occurs. 

The following code will open the debugger on the message stack, select PharoSyntaxTutorial>>divideTwoByZero".

PharoSyntaxTutorial new divideTwoByZero.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
basicTypesNumbers
	^ Lesson
title: 'Basic types: Numbers' 
lesson: 
'"You now know how to execute Pharo code. 

Now let''s talk about basic objects.

1, 2, 100, 2/3 ... are Numbers, and respond to many messages evaluating mathematical expressions.
Evaluate these ones:"

2.

20 factorial.

1000 factorial / 999 factorial.

(1/3).

(1/3) + (4/5).

(1/3) asFloat.

1 class.

1 class maxVal class.

(1 class maxVal + 1) class.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
messageSyntaxExecutionOrderParentheses
	^ Lesson
title: 'Message syntax: Parentheses'
lesson: 
'"Use parentheses to change order of evaluation"

(2 + 3) squared.

(2 raisedTo: 3) + 2.

(0@0 extent: 100@200) bottomRight.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
basicTypesDynamicArray
	^ Lesson
title: 'Basic types: Dynamic Array' 
lesson: 
'"Dynamic Arrays are created at execution time:"

{ (2+3) . (6*6) }.

{ (2+3) . (6*6) . ''hello'', '' Stef''} size.

{ ProfStef } first next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
mathematicalPrecedence
	^ Lesson
title: 'Mathematical precedence'
lesson: 
'"Traditional precedence rules from mathematics do not apply in Pharo."

2 * 10 + 2.

"Here the message * is sent to 2, which answers 20, then 20 receive the message +

Remember that all messages always follow a simple left-to-right precedence rule, * without exceptions *."

2 + 2 * 10.

2 + (2 * 10).

8 - 5 / 2.

(8 - 5) / 2.

8 - (5 / 2).

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
reflectionContinued
	^ Lesson
title: 'Reflection continued' 
lesson: 
'"So cool, isn''t it? Before going further, let''s remove this method:"

ProfStef respondsTo: #goToNextLesson.

ProfStef class removeSelector: #goToNextLesson.

ProfStef respondsTo: #goToNextLesson.

"Then move forward:"

ProfStef default executeMethod: (ProfStef lookupSelector:#next).'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
conditionals
	^ Lesson
title: 'Conditionals' 
lesson: 
'"Conditionals are just messages sent to Boolean objects"

1 < 2
  ifTrue: [100]
  ifFalse: [42].

"Here the message is ifTrue:ifFalse:

Try this:"

Transcript open.

3 > 10 
	ifTrue: [Transcript show: ''Maybe there''''s a bug ....'']
	ifFalse: [Transcript show: ''No: 3 is less than 10''].

3 = 3 ifTrue: [ProfStef next].'.! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
theEnd
	^ Lesson
title: 'Tutorial done!!' 
lesson: 
'"This tutorial is done. Enjoy programming with Pharo. 

Don''t forget to read ''Pharo By Example'' found here:  

	https://books.pharo.org/updated-pharo-by-example

You can run this tutorial again by evaluating:"

ProfStef go.

"Do you want to create your own interactive tutorial with ProfStef? That''s very easy!!!! How? There''s a ProfStef interactive tutorial for that :D
Just evaluate the following code:"

ProfStef goOn: HowToMakeYourOwnTutorial

"See you soon!!"'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
messageSyntaxUnary
	^ Lesson
title: 'Message syntax: Unary messages' 
lesson: 
'"Messages are sent to objects. There are three types of message: unary, binary and keyword.

Unary messages have the following form:
    anObject aMessage 

You''ve already sent unary messages. For example:"

1 class.

false not.

Time now.

Date today.

Float pi.

"And of course:"

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
basicTypesSymbol
	^ Lesson
title: 'Basic types: Symbols' 
lesson: 
'"A Symbol is a String which is guaranteed to be globally unique. 

There is one and only one Symbol #ProfStef. There may be several ''ProfStef'' String objects.

(Message == returns true if the two objects are the SAME)"

''ProfStef'' asSymbol.

#ProfStef asString.

(2 asString) == (2 asString).

(2 asString) asSymbol == (2 asString) asSymbol.

(Smalltalk globals at: #ProfStef) next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
instantiation
	^ Lesson
title: 'Instantiation' 
lesson: 
'"Objects are instances of their class. Usually, we send the message #new to a class for creating an instance of this class.

The message #allInstances sent to a class answers an Array with all instances of this class.

For example, let''s look at how many instances of SimpleButtonMorph exist. Please use only Do it or Print it on this page, not Inspect it."

SimpleButtonMorph allInstances size.

"Now create a new instance of it:"

SimpleButtonMorph new
	label: ''A nice button'';
	openCenteredInWorld.

"See the button centered on the world? The list of all instances should contains one more instance:"

SimpleButtonMorph allInstances size.

"Let''s play with it:"

SimpleButtonMorph allInstances last 
	label: ''ProfStef is cooooool !!'';
	color: Color cyan.
	
"Let''s delete it and ask the system to clean the memory:"

SimpleButtonMorph allInstances last delete.
Smalltalk garbageCollect.
SimpleButtonMorph allInstances size.

"Click on the button to go to next lesson:"

SimpleButtonMorph new
	label: ''Go to next lesson'';
	target: [ProfStef next. 
			   SimpleButtonMorph allInstances last delete];
	actionSelector: #value;
	openCenteredInWorld.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
printing 
	^ Lesson
title: 'Printing' 
lesson: 
'"Now you''re a Do it master!! Let''s talk about printing. It''s a Do it which prints the result next to the expression you''ve selected.
For example, select the text below, open the menu and click on ''Print it'':"

1 + 2.

"You''ve seen the keyboard keys next to the ''Print it''? It indicates the Ctrl- (or Cmd-) shortcut to execute this command.

Try ''Ctrl + P'' (or ''Cmd + P'') on the following expressions:"

Date today.

Time now.

"The result is selected, so you can erase it using the backspace key. Try it!!"

SmalltalkImage current datedVersion.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
basicTypesString
	^ Lesson
title: 'Basic types: Strings' 
lesson: 
'"A String is a collection of characters. Use single quotes to create a String object. Print these expressions:"

''ProfStef''.

''ProfStef'' size.

''abc'' asUppercase.

''Hello World'' reverse. 

"You can access each character using at: message"

''ProfStef'' at: 1.

"String concatenation uses the comma operator:"

''ProfStef'', '' is cool''.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
blocks
	^ Lesson
title: 'Blocks' 
lesson: 
'"Cascade is cool!! Let''s talk about blocks.

Blocks are anonymous methods that can be stored into variables and executed on demand.

Blocks are delimited by square brackets: []"

[StPlayground open].

"does not open a Browser because the block is not executed.

Here is a block that adds 2 to its argument (its argument is named x):"

[:x | x+2].

"We can execute a block by sending it value messages."

[:x | x+2] value: 5.

[StPlayground open] value.

[:x | x+2] value: 10.

[:x :y| x + y] value:3 value:5.

[ProfStef next] value.'! !

!PharoSyntaxTutorial methodsFor: 'tutorial' stamp: ''!
tutorial
^ #(
welcome
doingVSPrinting
printing
inspecting

basicTypesNumbers
basicTypesCharacters
basicTypesString
basicTypesSymbol
basicTypesArray
basicTypesDynamicArray

messageSyntaxUnary
messageSyntaxBinary
messageSyntaxKeyword
messageSyntaxExecutionOrder
messageSyntaxExecutionOrderParentheses
mathematicalPrecedence
messageSyntaxCascade
messageSyntaxCascadeShouldNotBeHere

blocks
blocksAssignation
conditionals
loops
iterators

instantiation

reflection
reflectionContinued

pharoEnvironment
debugger

theEnd
)! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
messageSyntaxCascadeShouldNotBeHere
	^ Lesson
title: 'Lost?' 
lesson: 
'"Hey, you should not be here!!!! 

Go back and use a cascade!!"

ProfStef previous.'.! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
messageSyntaxExecutionOrder
	^ Lesson
title: 'Message syntax: Execution order' 
lesson: 
'"Unary messages are executed first, then binary messages and finally keyword messages:
    Unary > Binary > Keywords"

2 + 3 squared.

2 raisedTo: 3 + 2.
  
(0@0) class.

0@0 corner: 100@200.

(0@0 corner: 100@200) class.

"Between messages of similar precedence, expressions are executed from left to right"

-3 abs negated reciprocal.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
reflection
	^ Lesson
title: 'Reflection' 
lesson: 
'"You can inspect and change the system at runtime.

Take a look at method #ifFalse:ifTrue: source code of class True:"

(True>>#ifFalse:ifTrue:) sourceCode.

"Or just its comment:"

(True>>#ifFalse:ifTrue:) comment.

"Here''s all the methods I implement:"

ProfStef selectors.

"Now let''s create a new method to go to the next lesson:"

ProfStef class compile:''goToNextLesson
  self next''.

"Wow!! I can''t wait to use my new method!!"

ProfStef goToNextLesson.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
basicTypesArray
	^ Lesson
title: 'Basic types: Array' 
lesson: 
'"Literal arrays are created at parse time and are read-only:"

#(1 2 3).

#(1 2 3 #(4 5 6)) size.

#(1 2 4) isEmpty.

#(1 2 3) first.

#(''hello'' ''World'') at: 2.

"You can modify a copy"
#(''hello'' ''World'') copy at: 2 put: ''Pharo''; yourself.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
messageSyntaxKeyword
	^ Lesson
title: 'Message syntax: Keyword messages' 
lesson: 
'"Keyword messages are messages with arguments. They have the following form:
    anObject akey: anotherObject akey2: anotherObject2"

4 between: 0 and: 10.

"The message is between:and: sent to the Number 4"

1 max: 3.

Color r:1 g:0 b:0.

"The message is r:g:b: implemented on class Color. Note you can also write"

Color
	r:1
	g:1
	b:0.
	
ProfStef perform: #next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
loops
	^ Lesson
title: 'Loops' 
lesson: 
'"Loops are high-level collection iterators, implemented as regular methods."

"Basic loops:
  to:do:
  to:by:do:
"

1 to: 100 do: [:i | Transcript show: i asString; cr].

1 to: 100 by: 3 do: [:i | Transcript show: i asString; cr].

100 to: 0 by: -2 do: [:i | Transcript show: i asString; cr].

1 to: 1 do: [:i | ProfStef next].'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
messageSyntaxCascade
	^ Lesson
title: 'Message syntax: Cascade' 
lesson: 
'"; is the cascade operator. It''s useful to send message to the SAME receiver.

Open a Transcript (console):"

Transcript open.

"Then:"

Transcript show: ''hello''.
Transcript show: ''Pharo''.
Transcript cr.

"is equivalent to:"

Transcript 
	   show: ''hello'';
	   show: ''Pharo'' ;
	   cr.

"Try to go to the next lesson with a cascade of two ''next'' messages:"

ProfStef'.! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
inspecting
	^ Lesson
title: 'Inspecting' 
lesson: 
'"Now you''re a Do it and Print it master!! Let''s talk about inspecting. It''s a Do it which opens an Inspector on the result of evaluating the expression you''ve selected. 
The Inspector is a tool that allows you to have a look inside an object.

For example, select the text below, open the menu and click on ''Inspect it'':"

1 / 2.

"You''ve seen the keyboard keys next to the ''Inspect it''? It indicates the Ctrl- (or Cmd-) shortcut to execute this command.

Try ''Ctrl + I'' (or ''Cmd + I'') on the following expressions:"

DateAndTime today.

Float pi.

SystemVersion current.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
messageSyntaxBinary
	^ Lesson
title: 'Message syntax: Binary messages' 
lesson: 
'"Binary messages have the following form:
    anObject + anotherObject"

3 * 2.

Date today + 3 weeks.

false | false.

true & true.

true & false.

10 @ 100.

10 <= 12.

''ab'', ''cd''.

Date today < Date yesterday.

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
welcome
	^ Lesson
title: 'Welcome' 
lesson: 
'"Hello!! I''m Professor Stef.

You must want me to help you learn Pharo.

So let''s go to the first lesson. Select the text below, right-click and choose ''Do it''"

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
iterators
	^ Lesson
title: 'Iterators' 
lesson: 
'"The message do: is sent to a collection of objects (Array, Set, OrderedCollection), evaluating the block for each element.

Here we want to print all the numbers on the Transcript (a console)"

#(11 38 3 -2 10) do: [:each |
     Transcript show: each printString; cr].

"Some other really nice iterators"

#(11 38 3 -2 10) collect: [:each | each abs].

#(11 38 3 -2 10) collect: [:each | each odd].

#(11 38 3 -2 10) select: [:each | each odd].

#(11 38 3 -2 10) select: [:each | each > 10].

#(11 38 3 -2 10) reject: [:each | each > 10].

#(11 38 3 -2 10) 
     do: [:each | Transcript show: each printString]
     separatedBy: [Transcript show: ''.''].

ProfStef allInstances do: [:aPharoTutorial | aPharoTutorial next].'! !

!PharoSyntaxTutorial methodsFor: 'lessons' stamp: ''!
doingVSPrinting 
	^ Lesson
title: 'Doing' 
lesson: 
'"Cool!! (I like to say Cooool :) ). You''ve just executed a Pharo expression. More precisely, you sent the message ''next'' to ProfStef class (it''s me!!).

Note you can run this tutorial again by evaluating: ''ProfStef go''. 
''ProfStef previous'' returns to the previous lesson.

You can also Do it using the keyboard shortcut ''Ctrl + D'' (or ''Cmd + D'' on MacOS). 

Try to evaluate these expressions:"

StPlayground open.

SmalltalkImage current aboutThisSystem.

"Then go to the next lesson:"

ProfStef next.'! !

!PharoSyntaxTutorial methodsFor: 'interactive' stamp: ''!
divideTwoByZero
	2/0.

	"Oops!! 2/0 raises a ZeroDivide exception. So the debugger opens to let you fix the code.

	- Remove the line of code above.
	- Right-click and select 'Accept' to compile the new version of the method
	- click the button 'Proceed' to continue execution."

	ProfStef next.! !

!PharoSyntaxTutorialTest commentStamp: ''!
SUnit tests for PharoSyntaxTutorial!
!PharoSyntaxTutorialTest methodsFor: 'tests' stamp: ''!
testEachSelectorReturnsALesson
	| answer |
	self testedTutorial tutorial do: [:aSelector|
		answer := (self testedTutorial perform: aSelector).
		self assert: (answer isKindOf: Lesson).
	]! !

!PharoSyntaxTutorialTest methodsFor: 'tests' stamp: ''!
testNotEmpty
	self assert: self testedTutorial tutorial notEmpty.! !

!PharoSyntaxTutorialTest methodsFor: 'tests' stamp: ''!
testDivideTwoByZeroSignalsZeroDivide
	[self testedTutorial divideTwoByZero.
	self fail] 
	on: ZeroDivide 
	do: []! !

!PharoSyntaxTutorialTest methodsFor: 'tests' stamp: ''!
testSizeReturnsNumberOfSelectors
	self assert: (self testedTutorial tutorial size) equals: self testedTutorial size.! !

!PharoSyntaxTutorialTest methodsFor: 'requirements' stamp: ''!
testedTutorial
	"Returns an instance of an AbstractTutorial subclass"
	^ PharoSyntaxTutorial new! !

!PharoSyntaxTutorialTest methodsFor: 'tests' stamp: ''!
testEachSelectorExists
	self testedTutorial tutorial do: [:aSelector|
		self assert: (self testedTutorial respondsTo: aSelector) 
	]! !

!PharoSyntaxTutorialTest methodsFor: 'tests' stamp: ''!
testLessonAtReturnsCorrespondingLesson
	| answer |
	1 to: (self testedTutorial tutorial size) do: [:index|
		answer := self testedTutorial lessonAt: index.
		self assert: (answer isKindOf: Lesson)
	]! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!PharoSyntaxTutorialTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!PharoSyntaxTutorialTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!PharoSyntaxTutorialTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!PharoSyntaxTutorialTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!PharoSyntaxTutorialTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!PharoSyntaxTutorialTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!PharoSyntaxTutorialTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!PharoSyntaxTutorialTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!PharoSyntaxTutorialTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!PharoSyntaxTutorialTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!PharoSyntaxTutorialTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!PharoSyntaxTutorialTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!PharoSyntaxTutorialTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!PharoSyntaxTutorialTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!PharoSyntaxTutorialTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!PharoSyntaxTutorialTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!PharoSyntaxTutorialTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!PharoSyntaxTutorialTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!PharoTutorialAPIHelp commentStamp: ''!
I'm a PharoTutorial which builds a HelpSystem book by collecting comment from classes and method.!
!PharoTutorialAPIHelp class methodsFor: 'accessing' stamp: ''!
bookName 
	^ 'Reference'! !

!PharoTutorialAPIHelp class methodsFor: 'accessing' stamp: ''!
helpPackages
	^ #('ProfStef-Core')! !

!PharoTutorialAPIHelp class methodsFor: 'defaults' stamp: ''!
builder 
	^ PackageAPIHelpBuilder! !

!PharoTutorialGoOnMockTutorialTest commentStamp: ''!
SUnit tests for tutorial navigation!
!PharoTutorialGoOnMockTutorialTest methodsFor: 'tests' stamp: ''!
testFirstLessonShouldBeDisplayed
 	self assert:  'First lesson' equals: ProfStef default lessonView text! !

!PharoTutorialGoOnMockTutorialTest methodsFor: 'tests' stamp: ''!
testLastThenPreviousShouldGoToSecondLesson
	ProfStef last; previous.
 	self assert:  'Second lesson' equals: ProfStef default lessonView text! !

!PharoTutorialGoOnMockTutorialTest methodsFor: 'tests' stamp: ''!
testLastThenFirstShouldGoToFirstLesson
	ProfStef last; first.
 	self assert:  'First lesson' equals: ProfStef default lessonView text! !

!PharoTutorialGoOnMockTutorialTest methodsFor: 'running' stamp: ''!
tearDown
	ProfStef default close.
	super tearDown! !

!PharoTutorialGoOnMockTutorialTest methodsFor: 'tests' stamp: ''!
testNextShouldGoToSecondLesson
	ProfStef next.
 	self assert:  'Second lesson' equals: ProfStef default lessonView text! !

!PharoTutorialGoOnMockTutorialTest methodsFor: 'tests' stamp: ''!
testLastShouldGoToThirdLesson
	ProfStef last.
 	self assert:  'Third lesson' equals: ProfStef default lessonView text! !

!PharoTutorialGoOnMockTutorialTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	ProfStef tutorial: MockTutorial lesson: #firstLesson! !

!PharoTutorialGoTest commentStamp: ''!
SUnit tests for tutorial navigation!
!PharoTutorialGoTest methodsFor: 'running' stamp: ''!
tearDown
	ProfStef default close.
	super tearDown! !

!PharoTutorialGoTest methodsFor: 'tests' stamp: ''!
testGoOnMockTutorial
	| displayedText expected |
	ProfStef goOn: MockTutorial.
	
	displayedText := ProfStef default lessonView text.
	expected := MockTutorial new firstLesson lesson.
 	self assert: displayedText equals: expected.! !

!PharoTutorialGoTest methodsFor: 'tests' stamp: ''!
testGoTwiceUseSameLessonView
	| firstLessonView |
	ProfStef go.
	firstLessonView := ProfStef default lessonView.
	ProfStef goOn: PharoSyntaxTutorial.
	self assert: firstLessonView identicalTo: ProfStef default lessonView! !

!PharoTutorialGoTest methodsFor: 'tests' stamp: ''!
testGoTwiceShowLessonViewIfNotVisible
	| firstLessonView |
	ProfStef go.
	firstLessonView := ProfStef default lessonView.
	firstLessonView close.
	ProfStef goOn: PharoSyntaxTutorial.
	self assert:  (self currentWorld systemWindows includes:  firstLessonView window).! !

!PharoTutorialGoTest methodsFor: 'tests' stamp: ''!
testGoOpenSmalltalkSyntaxTutorial
	| displayedText expected |
	ProfStef go.
	
	displayedText := ProfStef default lessonView text.
	expected := PharoSyntaxTutorial new welcome lesson.
 	self assert: displayedText equals: expected.! !

!PharoTutorialHelp commentStamp: ''!
HelpSystem book documenting PharoTutorial!
!PharoTutorialHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(introduction listOfTutorials createATutorial)! !

!PharoTutorialHelp class methodsFor: 'accessing' stamp: ''!
bookName 
	^ 'Pharo Tutorial'! !

!PharoTutorialHelp class methodsFor: 'pages' stamp: ''!
introduction
	^ HelpTopic 
		title: 'Introduction'
		contents: 'PharoTutorial is a framework to create interactive tutorials'.! !

!PharoTutorialHelp class methodsFor: 'pages' stamp: ''!
createATutorial
	^ HelpTopic 
		title: 'Create a tutorial'
		contents: 'See AbstractTutorial comment: ', AbstractTutorial comment.! !

!PharoTutorialHelp class methodsFor: 'pages' stamp: ''!
listOfTutorials
	^ HelpTopic title: 'List of tutorials' contents: AbstractTutorial contentsOfTutorials! !

!PharoTutorialHelp class methodsFor: 'testing' stamp: ''!
canHaveSyntaxHighlighting
	^ true! !

!PharoTutorialHelpTest commentStamp: ''!
SUnit tests for PharoTutorialHelp!
!PharoTutorialHelpTest methodsFor: 'tests' stamp: ''!
testCreateATutorial
	| helpTopic |
	helpTopic := PharoTutorialHelp createATutorial.
	self assert: helpTopic notNil.
	self assert: helpTopic class identicalTo: HelpTopic.
	self assert: helpTopic title equals: 'Create a tutorial'! !

!PharoTutorialHelpTest methodsFor: 'tests' stamp: ''!
testPages
	self assert: PharoTutorialHelp pages isCollection.
	self assert: (PharoTutorialHelp pages allSatisfy: #isSymbol).! !

!PharoTutorialHelpTest methodsFor: 'tests' stamp: ''!
testBookName
	self assert: PharoTutorialHelp bookName isString! !

!PharoTutorialHelpTest methodsFor: 'tests' stamp: ''!
testIntroduction
	| helpTopic |
	helpTopic := PharoTutorialHelp introduction.
	self assert: helpTopic notNil.
	self assert: helpTopic class identicalTo: HelpTopic.
	self assert: helpTopic title equals: 'Introduction'! !

!PharoTutorialHelpTest methodsFor: 'tests' stamp: ''!
testListOfTutorials
	| helpTopic |
	helpTopic := PharoTutorialHelp listOfTutorials.
	self assert: helpTopic notNil.
	self assert: helpTopic title equals: 'List of tutorials'! !

!PharoTutorialHelpTutorialBuilder commentStamp: ''!
I build HelpSystem topics to browse PharoTutorial tutorials!
!PharoTutorialHelpTutorialBuilder methodsFor: 'building' stamp: ''!
buildTutorialTopicFor: aTutorial
	|tutorialTopic|
	tutorialTopic := HelpTopic named: aTutorial title.	
	
	aTutorial new lessons do:[:aLesson|
		tutorialTopic addSubtopic: (HelpTopic 
									title: aLesson title 
									contents:  aLesson lesson)
	].

	^ tutorialTopic! !

!PharoTutorialHelpTutorialBuilder methodsFor: 'building' stamp: ''!
build
	topicToBuild := HelpTopic named: rootToBuildFrom bookName.
	
	AbstractTutorial tutorials do: [:aTutorial| 
		topicToBuild addSubtopic: (self buildTutorialTopicFor: aTutorial)
	].

	^ topicToBuild.! !

!PharoTutorialHelpTutorialBuilder class methodsFor: 'instance creation' stamp: ''!
new
	"We prohibid new"
	^ (self class lookupSelector: #buildHelpTopicFrom:)  == thisContext sender compiledCode  
		ifFalse:[self error: 'Please use buildHelpTopicFrom: instead']
		ifTrue: [super new]! !

!PharoTutorialHelpTutorialBuilderTest commentStamp: ''!
SUnit tests for PharoTutorialHelpTutorialBuilder!
!PharoTutorialHelpTutorialBuilderTest methodsFor: 'tests' stamp: ''!
testInstantiation 
	self should: [ PharoTutorialHelpTutorialBuilder new ] raise: Error! !

!PharoTutorialHelpTutorialBuilderTest methodsFor: 'tests' stamp: ''!
testBuild
	| helpTopic tutorial |
	tutorial := PharoTutorialsHelp.
	helpTopic := PharoTutorialHelpTutorialBuilder buildHelpTopicFrom: tutorial.
	self assert: helpTopic notNil! !

!PharoTutorialNavigationTest commentStamp: ''!
SUnit tests for tutorial navigation!
!PharoTutorialNavigationTest methodsFor: 'tests' stamp: ''!
testSequenceNextNextOpenThirdLesson
	prof next; next.
	self assert: mockView title equals: 'third (3/3)'.
	self assert: mockView lesson lesson equals: 'Third lesson'.! !

!PharoTutorialNavigationTest methodsFor: 'tests' stamp: ''!
testSequenceNextNextPreviousOpenSecondLesson
	prof next; next; previous.
	self assert: mockView title equals: 'second (2/3)'.
	self assert: mockView lesson lesson equals: 'Second lesson'.! !

!PharoTutorialNavigationTest methodsFor: 'tests' stamp: ''!
testShowingLessonByIndex
	prof tutorial: MockTutorial lessonAt: 2.
	self assert: mockView title equals: 'second (2/3)'.
	self assert: mockView lesson lesson equals: 'Second lesson'.! !

!PharoTutorialNavigationTest methodsFor: 'tests' stamp: ''!
testNextOpenSecondLesson
	prof next.
	self assert: mockView title equals: 'second (2/3)'.
	self assert: mockView lesson lesson equals: 'Second lesson'.! !

!PharoTutorialNavigationTest methodsFor: 'tests' stamp: ''!
testShowFirstLessonOnGo
	| lesson |
	lesson := mockView lesson.
	self assert: lesson title equals: 'first'.
	self assert: lesson lesson equals: 'First lesson'.! !

!PharoTutorialNavigationTest methodsFor: 'tests' stamp: ''!
testShowingLessonBySelector
	prof tutorial: MockTutorial lesson: #firstLesson.
	self assert: mockView title equals: 'first (1/3)'.
	self assert: mockView lesson lesson equals: 'First lesson'.! !

!PharoTutorialNavigationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	prof := ProfStef new.
	prof player: (
		TutorialPlayer new 
			tutorial: MockTutorial new; 
			yourself).
	mockView := MockLessonView new.
	prof lessonView: mockView.
	prof open.! !

!PharoTutorialsHelp commentStamp: ''!
I'm a HelpSystem book which list all Pharo tutorials!
!PharoTutorialsHelp class methodsFor: 'accessing' stamp: ''!
bookName 
	^ 'Browse tutorials'! !

!PharoTutorialsHelp class methodsFor: 'defaults' stamp: ''!
builder
	^ PharoTutorialHelpTutorialBuilder! !

!PharoTutorialsHelp class methodsFor: 'menu' stamp: ''!
menuCommandOn: aBuilder 
	<worldMenu> 
	(aBuilder item: #'Pharo Tutorials')
			parent: #PharoHelp;
			order: 2;
			action:[ HelpBrowser openOn: self ]; 
			icon: ((self iconNamed: #pharoIcon) scaledToSize: 16@16);
			help: 'Browse and create Pharo tutorials.'.! !

!PickListPresenter commentStamp: ''!
A PickList is a tick list done using spec.

self example!
!PickListPresenter methodsFor: 'api' stamp: ''!
checkboxFor: anItem

	^ associationsItemToWrapper at: anItem ifAbsent: [ nil ]! !

!PickListPresenter methodsFor: 'api' stamp: ''!
pickedItems
	"Returns the selected items according to the order they have been picked"
	
	^ pickedItemsHolder value! !

!PickListPresenter methodsFor: 'api' stamp: ''!
itemFor: aCheckbox

	^ associationsWrapperToItem at: aCheckbox ifAbsent: [ nil ]! !

!PickListPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	
	listPresenter := self newList.
	listPresenter displayBlock: [ :item | item ].
	self focusOrder add: listPresenter! !

!PickListPresenter methodsFor: 'api' stamp: ''!
defaultValue

	^ defaultValueHolder value! !

!PickListPresenter methodsFor: 'private' stamp: ''!
addPicked: item

	pickedItemsHolder add: item.
	pickedItemsHolder valueChanged: true to: item.! !

!PickListPresenter methodsFor: 'private' stamp: ''!
wrap: item at: index
	| checkBox |

	associationsIndexToWrapper 
		at: index
		ifPresent: [:cb | ^ cb ].

	checkBox := self instantiate: CheckBoxPresenter.
	blockToPerformOnWrappers value value: checkBox.
	checkBox label: (wrapHolder value cull: item cull: self).
	
	checkBox whenActivatedDo: [ 
		self addPicked: item.
		listPresenter setSelectedItem: checkBox.
		listPresenter takeKeyboardFocus ].
	
	checkBox whenDeactivatedDo: [ 
		self removePicked: item.
		listPresenter setSelectedItem: checkBox.
		listPresenter takeKeyboardFocus ].
	
	checkBox 
		state: self defaultValue;
		labelClickable: self labelClickable.
		
	associationsWrapperToItem at: checkBox put: item.
	associationsItemToWrapper at: item put: checkBox.
	associationsIndexToWrapper at: index put: checkBox.
	^ checkBox! !

!PickListPresenter methodsFor: 'api' stamp: ''!
labelClickable: aBoolean

	labelClickableHolder value: aBoolean! !

!PickListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionIndexChanged: aBlock

	listPresenter whenSelectionIndexChanged: aBlock! !

!PickListPresenter methodsFor: 'accessing' stamp: ''!
blockToPerformOnWrappers: aBlock

	blockToPerformOnWrappers value: aBlock! !

!PickListPresenter methodsFor: 'accessing' stamp: ''!
wrapHolder

	^ wrapHolder! !

!PickListPresenter methodsFor: 'api' stamp: ''!
wrappers

	^ associationsWrapperToItem keys! !

!PickListPresenter methodsFor: 'accessing' stamp: ''!
listPresenter

	^ listPresenter! !

!PickListPresenter methodsFor: 'api - events' stamp: ''!
whenListChanged: aBlock

	listPresenter whenListChanged: aBlock! !

!PickListPresenter methodsFor: 'initialization' stamp: ''!
initialize

	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.! !

!PickListPresenter methodsFor: 'api' stamp: ''!
selectedIndex

	^ listPresenter selectedIndex! !

!PickListPresenter methodsFor: 'api' stamp: ''!
selectedItem

	^ associationsWrapperToItem 
		at: listPresenter selectedItem
		ifAbsent: [ nil ]! !

!PickListPresenter methodsFor: 'api - events' stamp: ''!
whenPickedItemsChanged: aBlock

	pickedItemsHolder whenChangedDo: aBlock! !

!PickListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectedItemChanged: aBlock
	| newBlock |
	
	newBlock := [ :item | aBlock cull: (associationsWrapperToItem at: item ifAbsent: [ nil ])].
	listPresenter whenSelectedItemChanged: newBlock! !

!PickListPresenter methodsFor: 'accessing' stamp: ''!
blockToPerformOnWrappers

	^ blockToPerformOnWrappers value! !

!PickListPresenter methodsFor: 'api' stamp: ''!
resetSelection

	listPresenter resetSelection! !

!PickListPresenter methodsFor: 'api' stamp: ''!
labelClickable
	
	^ labelClickableHolder value! !

!PickListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionChanged: aBlock

	"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:"

	listPresenter whenSelectionChanged: aBlock.! !

!PickListPresenter methodsFor: 'api' stamp: ''!
items: aCollection

	associationsWrapperToItem removeAll.
	pickedItemsHolder removeAll.
	listPresenter items: (aCollection collectWithIndex: [:e :i | self wrap: e at: i ]).! !

!PickListPresenter methodsFor: 'api' stamp: ''!
indexFor: aCheckbox

	^ listPresenter listItems indexOf: aCheckbox.! !

!PickListPresenter methodsFor: 'api' stamp: ''!
setSelectedIndex: anIndex

	listPresenter setSelectedIndex: anIndex! !

!PickListPresenter methodsFor: 'private' stamp: ''!
removePicked: item

	pickedItemsHolder remove: item ifAbsent: [ ^ self ].! !

!PickListPresenter methodsFor: 'api' stamp: ''!
selectedItems
	"Returns the selected items according to the list order"
	| wrappers items |
	
	wrappers := listPresenter 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! !

!PickListPresenter methodsFor: 'api' stamp: ''!
defaultValue: aBoolean

	defaultValueHolder value: aBoolean! !

!PickListPresenter methodsFor: 'api' stamp: ''!
displayBlock: aBlock

	wrapHolder value: aBlock! !

!PickListPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	labelClickableHolder
		whenChangedDo:
			[ :aBoolean | associationsWrapperToItem keysDo: [ :e | e labelClickable: aBoolean ] ].
	defaultValueHolder
		whenChangedDo: [ :value | associationsWrapperToItem keysDo: [ :cb | cb state: value ] ]! !

!PickListPresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self new.
	example
		items:
			{{1 . 2 . 4}.
			'Foo'.
			123}.
	example openWithSpec.
			^example! !

!PickListPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ SpecLayout composed 
		add: #listPresenter;
		yourself! !

!PickListPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Pick List Example'! !

!PickOneSettingDeclaration commentStamp: ''!
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: ''!
defaultValue
	^ self default value ifNil: [self domainValues first realValue]
! !

!PickOneSettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidget
	| widget row |
	row := self theme newRowIn: self for: {
				widget := (self theme 
						newDropListIn: self currentWorld
						for: self
						list: #domainValuesLabels
						getSelected: #index
						setSelected: #index:
						getEnabled: #enabled
						useIndex: true
						help: self description)
						extent: 1 @ 30}.
	widget hResizing: #rigid.
	widget width: (self maxNameWidthForFont: widget font) + 50.
	^ row! !

!PickOneSettingDeclaration methodsFor: 'user interface' stamp: ''!
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: ''!
content
	^ self domainValues
		detect: [ :setting | setting realValue = self realValue ]
		ifFound: [ :setting | setting name ]
		ifNone: [ 'nil' ]! !

!PickOneSettingDeclaration methodsFor: 'user interface' stamp: ''!
index: anInteger
	self realValue: (self domainValues at: anInteger) realValue.
! !

!PickOneSettingDeclaration methodsFor: 'user interface' stamp: ''!
index
	self realValue ifNil: [self realValue: self default].
	^ self domainValues indexOf: (self domainValues detect: [:dv | dv realValue = self realValue] ifNone: [^ 0])! !

!PlainGroupboxMorph commentStamp: ''!
Groupbox without title with a vertical layout. Appears in a lighter colour than the owner's pane colour.!
!PlainGroupboxMorph methodsFor: 'accessing' stamp: ''!
paneColorOrNil
	"Answer the window's pane color or nil otherwise."

	^super paneColorOrNil ifNotNil: [:c | self theme subgroupColorFrom: c]! !

!PlainGroupboxMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		borderStyle: (self theme plainGroupPanelBorderStyleFor: self);
		changeTableLayout; 
		layoutInset: 4;
		cellInset: 8;
		vResizing: #spaceFill;
		hResizing: #spaceFill! !

!PlainGroupboxMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Change our color too."
	
	super adoptPaneColor: (self theme subgroupColorFrom: paneColor).
	self borderStyle: (self theme plainGroupPanelBorderStyleFor: self)! !

!PlatformIndependentEnvironment commentStamp: ''!
I'm a platform independent environment who is intent to work when none other works. 
Specially, I'm intended to work as a replacement for environments when there is no NativeBoost present, therefore I provide stubs for method calls that answers just default values. 
!
!PlatformIndependentEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey put: aValue
	"Do nothing"! !

!PlatformIndependentEnvironment methodsFor: 'accessing' stamp: ''!
removeKey: key
	"Do nothing"! !

!PlatformIndependentEnvironment methodsFor: 'enumeration' stamp: ''!
keysAndValuesDo: aBlock
	"Do nothing"! !

!PlatformIndependentEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey ifAbsent: aBlock

	^ nil! !

!PlatformIndependentEnvironment class methodsFor: 'testing' stamp: ''!
isAvailable 
	^ true! !

!PlatformResolver commentStamp: ''!
I am an abstract superclass for platform-specific resolvers.!
!PlatformResolver methodsFor: 'private' stamp: ''!
directoryFromEnvVariableNamed: aString or: aBlock
	| envValue |
	envValue := [ Smalltalk os environment at: aString ifAbsent: [ nil ] ]
		on: Error
		do: [ ^ aBlock value ].
	^ envValue isEmptyOrNil
		ifTrue: [ aBlock value ]
		ifFalse: [ self resolveString: envValue ]! !

!PlatformResolver methodsFor: 'private' stamp: ''!
cantFindOriginError
	^ Error signal: 'Can''t find the requested origin'! !

!PlatformResolver methodsFor: 'origins' stamp: ''!
desktop
	^ self home / 'Desktop'! !

!PlatformResolver methodsFor: 'origins' stamp: ''!
documents
	<origin>
	^ self home / 'Documents'! !

!PlatformResolver methodsFor: 'origins' stamp: ''!
temp
	"Where to put files that are not supposed to last long"

	<origin>
	^ self subclassResponsibility! !

!PlatformResolver methodsFor: 'origins' stamp: ''!
cache
	"Operating Systems often define standard locations for a personal cache directory. The cache directory is a user-specific non-essential (cached) place where data should be written."

	<origin>
	^ self subclassResponsibility! !

!PlatformResolver methodsFor: 'origins' stamp: ''!
downloads
	<origin>
	^ self home / 'Downloads'! !

!PlatformResolver methodsFor: 'origins' stamp: ''!
home
	<origin>
	^ self subclassResponsibility! !

!PlatformResolver methodsFor: 'origins' stamp: ''!
preferences
	<origin>
	^ self subclassResponsibility! !

!PlatformResolver methodsFor: 'private' stamp: ''!
directoryFromEnvVariableNamed: aString
	^ self directoryFromEnvVariableNamed: aString or: [ self cantFindOriginError ]! !

!PlatformResolver class methodsFor: 'accessing' stamp: ''!
platformName
	^ nil! !

!PlatformResolver class methodsFor: 'private' stamp: ''!
primitiveGetUntrustedUserDirectory
	<primitive: 'primitiveGetUntrustedUserDirectory' module: 'SecurityPlugin'>
	self primitiveFailed.
	self flag: #pharoFixMe. "use a more decent way to get a path in the users home directory"! !

!PlatformResolver class methodsFor: 'instance creation' stamp: ''!
forCurrentPlatform
	| platformName |
	platformName :=  Smalltalk os platformName.
	^ (self allSubclasses detect: [:ea | ea platformName = platformName]) new! !

!PlatformResolverTest commentStamp: ''!
SUnit tests for PlatformResolver!
!PlatformResolverTest methodsFor: 'tests' stamp: ''!
testCache
	self assertOriginResolves: #cache! !

!PlatformResolverTest methodsFor: 'tests' stamp: ''!
testHome
	| home |
	home := self assertOriginResolves: #home.
	self assert: home isDirectory! !

!PlatformResolverTest methodsFor: 'running' stamp: ''!
createResolver
	^ PlatformResolver forCurrentPlatform! !

!PlatformResolverTest methodsFor: 'tests' stamp: ''!
testCanAddOrigin
	[ resolver class
		compile:
			'newOriginForTest
	<origin>
	^ self home / ''toto'''.
	self assert: (resolver supportedOrigins includes: #newOriginForTest) ]
		ensure: [ resolver class compiledMethodAt: #newOriginForTest ifPresent: [ :m | m removeFromSystem ] ]! !

!PluggableButtonMorph commentStamp: ''!
A PluggableButtonMorph is a combination of an indicator for a boolean value stored in its model and an action button. The action of a button is often, but not always, to toggle the boolean value that it shows. Its pluggable selectors are:

		getStateSelector		fetch a boolean value from the model
		actionSelector		invoke this button's action on the model
		getLabelSelector		fetch this button's lable from the model
		getMenuSelector		fetch a pop-up menu for this button from the model

Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if getStateSelector is nil, then this button shows the state of a read-only boolean that is always false.

The model informs its view(s) of changes by sending #changed: to itself with getStateSelector as a parameter. The view tells the model when the button is pressed by sending actionSelector.

If the actionSelector takes one or more arguments, then the following are relevant:
		arguments			A list of arguments to provide when the actionSelector is called.
		argumentsProvider	The object that is sent the argumentSelector to obtain arguments, if dynamic
		argumentsSelector	The message sent to the argumentProvider to obtain the arguments.

Options:
	askBeforeChanging		have model ask user before allowing a change that could lose edits
	triggerOnMouseDown	do this button's action on mouse down (vs. up) transition
	shortcutCharacter		a place to record an optional shortcut key
!
!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
color: aColor
	"Check to avoid repeats of the same color."

	aColor ifNil: [ ^ self ].
	(aColor = self color and: [ self getModelState = self lastState ]) ifTrue: [ ^ self ].
	
	super color: aColor! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
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: 'event handling' stamp: ''!
mouseLeaveDragging: evt

	self mouseLeave: evt! !

!PluggableButtonMorph methodsFor: 'private' stamp: ''!
invokeMenu: evt
	"Invoke my menu in response to the given event."
	| menu |
	menu := self getMenu: evt shiftPressed.
	menu ifNotNil: [menu popUpEvent: evt in: self world]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
beIconLeft
	"show icon left to label"
	iconPosition := #left.
	self update: getIconSelector! !

!PluggableButtonMorph methodsFor: 'copying' stamp: ''!
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: 'keyboard' stamp: ''!
wantsKeyboardFocusNavigation
	"Answer whether the receiver would like keyboard focus
	when navigated to by keyboard."

	^super wantsKeyboardFocusNavigation and: [
		self valueOfProperty: #wantsKeyboardFocusNavigation ifAbsent: [true]]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
isDefault
	"Answer whether the button is considered to be a default one."

	^self valueOfProperty: #isDefault ifAbsent: [false]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
model
	"Answer the receiver's model."
	
	^model! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
action: aSymbol 
	"Set actionSelector to be the action defined by aSymbol."

	actionSelector := aSymbol.! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
normalBorderStyle
	"Return the normal borderStyle of the receiver."
	
	^self theme buttonNormalBorderStyleFor: self! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
label: aStringOrTextOrMorph
	"Label this button with the given string or morph."
	font ifNil: [
		self label: aStringOrTextOrMorph font: self theme buttonFont]
	ifNotNil: [ self label: aStringOrTextOrMorph font: font ]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
focusIndicatorCornerRadius
	"Answer the corner radius preferred for the focus indicator
	for the receiver for themes that support this."

	^self theme buttonFocusIndicatorCornerRadiusFor: self! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
selectedMouseOverBorderStyle
	"Return the selected mouse over borderStyle of the receiver."
	
	^self theme buttonSelectedMouseOverBorderStyleFor: self! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
font: anObject
	font := anObject.
	self update: getLabelSelector.! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
getModelState
	"Answer the result of sending the receiver's model the getStateSelector message.
	If the selector expects arguments then supply as for the actionSelector."

	model ifNil: [^ false].
	^getStateSelector ifNil: [false]
		ifNotNil: [getStateSelector numArgs = 0
					ifTrue: [model perform: getStateSelector]
					ifFalse: [argumentsProvider ifNotNil: [
								arguments := argumentsProvider perform: argumentsSelector].
							model perform: getStateSelector withEnoughArguments: arguments]]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
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: ''!
enabled
	^ enabled ifNil: [enabled := true]! !

!PluggableButtonMorph methodsFor: 'updating' stamp: ''!
adoptPaneColor: aColor

	super adoptPaneColor: aColor.
	aColor ifNil: [^self].
	self adoptColor: self colorToUse! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
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: ''!
lastState: anObject
	lastState := anObject! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
disabledFillStyle
	"Return the disabled fillStyle of the receiver."
	
	^self theme buttonDisabledFillStyleFor: self! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
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: 'event handling' stamp: ''!
handlesMouseDown: evt

	^ true! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
feedbackColor: aColor
	"Set the color of this button's selection feedback border."

	feedbackColor := aColor.
	self changed.! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
target
	^model! !

!PluggableButtonMorph methodsFor: 'updating' stamp: ''!
updateFeedbackForEvt: evt

	| newState |
	newState := self containsPoint: evt cursorPoint.
	newState = showSelectionFeedback ifFalse: [
		self showSelectionFeedback: newState.
		self changed; layoutChanged].! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
getMenuSelector: aSymbol
	"Set the menu selector."

	getMenuSelector := aSymbol! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
cornerStyle: aSymbol
	"Adjust the layout inset."

	super cornerStyle: aSymbol.
	self layoutInset: (self theme buttonLabelInsetFor: self)! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
newLabel
	"Answer a new label for the receiver."
	|lbl|
	lbl := self theme buttonLabelFor: self.
	font ifNotNil: [lbl font: font.
		lbl extent: lbl optimalExtent ].
	^lbl! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
focusColor
	"Answer the keyboard focus indication color."

	^self color contrastingBlackAndWhiteColor! !

!PluggableButtonMorph methodsFor: 'arguments' stamp: ''!
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: 'accessing' stamp: ''!
font
	^ font! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
borderStyleToUse
	"Return the borderStyle to use for the receiver."

	^ self perform: (self availableBorderStyles at: (self interactionStates indexOf: self interactionState))! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
triggerOnMouseDown

	^ triggerOnMouseDown! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
focusBounds
	"Answer the bounds for drawing the focus indication."

	^self theme buttonFocusBoundsFor: self! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: evt
	"Update the appearance."

	self setProperty: #mouseEntered toValue: false.
	self changed.
	"0.09375 is exact in floating point so no cumulative rounding error will occur"
	self color: (self color adjustBrightness: 0.09375).
	super mouseLeave: evt! !

!PluggableButtonMorph methodsFor: 'keyboard' stamp: ''!
keyDown: event 
	"Process spacebar for action and tab keys for navigation."
	
	(self navigationKey: event) ifTrue: [^self].
	event keyCharacter = Character cr
		ifTrue: [self performAction]! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt

	^ true! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
showSelectionFeedback
	"Answer whether the feedback should be shown for being pressed."

	^showSelectionFeedback! !

!PluggableButtonMorph methodsFor: 'updating' stamp: ''!
updateLabelEnablement
	"Set the enabled state of the label if possible."
	
	self labelMorph enabled: self enabled! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
contentHolder
	"Answer the alignment morph for extra control."

	^self submorphs first! !

!PluggableButtonMorph methodsFor: 'private' stamp: ''!
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 ifNil: [ ^ nil ].
	menu := self theme newMenuIn: self for: model.
	getMenuSelector numArgs = 1
		ifTrue: [ ^ model perform: getMenuSelector with: menu ].
	getMenuSelector numArgs = 2
		ifTrue: [ ^ model perform: getMenuSelector with: menu with: shiftPressed ].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
beIconBottom
	"show icon top to label"
	iconPosition := #bottom.
	self update: getIconSelector! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
iconPosition
	"Position of the icon. 
	  #left - Icon will be left to the label
	  #right - Icon will be right to the label 
	  #top - Icon will be top to the label"
	^ iconPosition ifNil: [ iconPosition := #left ]! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: ''!
mouseMove: evt

	allButtons ifNil: [^ self].
	allButtons do: [:m | m updateFeedbackForEvt: evt].! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
selectedDisabledFillStyle
	"Return the selected disabled fillStyle of the receiver."
	
	^self theme buttonSelectedDisabledFillStyleFor: self! !

!PluggableButtonMorph methodsFor: 'copying' stamp: ''!
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.
icon :=  icon 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: 'private' stamp: ''!
browseAction

	| classDefiningAction |
	classDefiningAction := self model class whichClassIncludesSelector: self actionSelector.
	Smalltalk tools browser openOnClass: classDefiningAction selector: self actionSelector.! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOverDragging: evt

	^ true! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
minWidth
	"Consult the theme also."

	^super minWidth max: self theme buttonMinWidth! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
actionSelector
	"Answer the receiver's actionSelector"

	^ actionSelector! !

!PluggableButtonMorph methodsFor: '*Spec2-Morphic' stamp: ''!
getStateSelector

	^ getStateSelector! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
disable
	"Disable the button."

	self enabled: false! !

!PluggableButtonMorph methodsFor: 'balloon' stamp: ''!
helpText: aString

	self setBalloonText: aString! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
mouseOverFillStyle
	"Return the mouse over fillStyle of the receiver."
	
	^self theme buttonMouseOverFillStyleFor: self! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
normalColor
	"Return the normal colour for the receiver."
	
	^self theme buttonColorFor: self! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
selectedBorderStyle
	"Return the selected borderStyle of the receiver."
	
	^self theme buttonSelectedBorderStyleFor: self! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
selectedFillStyle
	"Return the selected fillStyle of the receiver."
	
	^self theme buttonSelectedFillStyleFor: self! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: ''!
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: ''!
handlesKeyboard: evt
	"Answer true, we'll handle spacebar for pressing plus the usual
	tab navigation."
	
	^true! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
on: anObject getState: getStateSel action: actionSel label: labelSel icon: iconSel menu: menuSel
	"Set up the pluggable parameters.
	Update label and state."
	
	self model: anObject.
	getStateSelector := getStateSel.
	actionSelector := actionSel.
	getLabelSelector := labelSel.
	getIconSelector := iconSel.
	getMenuSelector := menuSel.
	self
		update: (labelSel ifNil: [ iconSel ]);
		update: getStateSel! !

!PluggableButtonMorph methodsFor: '*Spec2-Morphic' stamp: ''!
getStateSelector: aSelector

	getStateSelector := aSelector! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
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: 'drawing' stamp: ''!
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.
		self privateColor: 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: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher
	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #MorphFocusNavigation.
	aKMDispatcher attachCategory: #PluggableButtonMorph! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
minHeight
	"Consult the theme also."

	^super minHeight max: self theme buttonMinHeight! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector
	^getEnabledSelector! !

!PluggableButtonMorph methodsFor: 'initialization' stamp: ''!
initializeLabelMorph
	labelMorph := LabelMorph new
		extent: 0 @ 0;
		yourself	"this is a safe guard for enabled: among others."! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
askBeforeChanging

	^ askBeforeChanging! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
beIconTop
	"show icon top to label"
	iconPosition := #top.
	self update: getIconSelector! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
selectedPressedFillStyle
	"Return the selected pressed fillStyle of the receiver."
	
	^self theme buttonSelectedPressedFillStyleFor: self! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
offColor
	^ offColor! !

!PluggableButtonMorph methodsFor: 'keyboard' stamp: ''!
keyboardFocusChange: aBoolean
	"The message is sent to a morph when its keyboard focus changes.
	Update for focus feedback."
	super keyboardFocusChange: aBoolean.
	self focusChanged! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
fillStyleToUse
	"Return the fillStyle to use for the receiver."
	
	^self perform: (self availableFillStyles at: (
			self interactionStates indexOf: self interactionState))! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
selectedDisabledBorderStyle
	"Return the selected disabled borderStyle of the receiver."
	
	^self theme buttonSelectedDisabledBorderStyleFor: self! !

!PluggableButtonMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ self theme borderWidth! !

!PluggableButtonMorph methodsFor: 'updating' stamp: ''!
themeChanged

	self
		layoutInset: (self theme buttonLabelInsetFor: self);
		cornerStyle: (self theme buttonCornerStyleIn: self window);
		borderStyle: (self theme buttonNormalBorderStyleFor: self).
		
	(self labelMorph isNil or: [self label isMorph ]) ifFalse: [
		self label: self label font: self labelMorph font.
		self labelMorph color: self theme textColor
	].

	super themeChanged! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
getFontSelector: anObject
	getFontSelector := anObject.
	self update: getFontSelector.! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
offColor: colorWhenOff
	"Set the fill colors to be used when this button is off."

	self onColor: onColor offColor: colorWhenOff! !

!PluggableButtonMorph methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas 
	"Display submorphs back to front.
	Draw the focus here since we are using inset bounds
	for the focus rectangle."

	super drawSubmorphsOn: aCanvas.
	self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
icon: anIcon
	icon := anIcon! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
label
	"Answer the DisplayObject used as this button's label."

	^ label! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
normalFillStyle
	"Return the normal fillStyle of the receiver."
	
	^self theme buttonNormalFillStyleFor: self! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
performAction
	"backward compatibility"
	
	self performAction: nil! !

!PluggableButtonMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the state of the receiver."

	super initialize.
	self
		rubberBandCells: false;
		listDirection: #topToBottom;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		wrapCentering: #center;
		cellPositioning: #center.
	enabled := true.
	self initializeLabelMorph.	"this is a safe guard for enabled: among others."
	askBeforeChanging := false.
	triggerOnMouseDown := false.
	showSelectionFeedback := false.
	arguments := #().
	self
		layoutInset: (self theme buttonLabelInsetFor: self);
		extent: 20 @ 15;
		lastState: false;
		cornerStyle: (self theme buttonCornerStyleIn: nil);
		borderStyle: (self theme buttonNormalBorderStyleFor: self).
		
	self clipSubmorphs: true! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: ''!
mouseEnter: evt
	"Update the appearance."

	self setProperty: #mouseEntered toValue: true.
	self changed.
	"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: 'accessing' stamp: ''!
arguments
	"Answer the static arguments.
	SimpleButtonMorph cross-compatibility."

	^arguments! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
shortcutCharacter: aCharacter 
	"Set the character to be used as a keyboard shortcut for turning on this switch."

	shortcutCharacter := aCharacter.! !

!PluggableButtonMorph methodsFor: 'keyboard' stamp: ''!
wantsKeyboardFocusOnMouseDown
	"Answer whether the receiver would like keyboard focus
	on a mouse down event. use a property here for apps that want to take keyboard
	focus when the button is pressed (so that other morphs can, e.g. accept on focus change)."

	^self wantsKeyboardFocus and: [self valueOfProperty: #wantsKeyboardFocusOnMouseDown ifAbsent: [false]]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
newLabel: aFont
	"Answer a new label for the receiver with the given font."

	^self newLabel
		font: aFont! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
lastState
	^ lastState! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
enable
	"Enable the button."

	self enabled: true! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
showSelectionFeedback: aBoolean
	"Set the feedback."

	showSelectionFeedback := aBoolean! !

!PluggableButtonMorph methodsFor: 'keyboard' stamp: ''!
keyStroke: event 
	"Process spacebar for action and tab keys for navigation."
	
	event keyCharacter = Character space
		ifTrue: [self performAction]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
getColorSelector: aSymbol
	getColorSelector := aSymbol.
	self update: getColorSelector.! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: ''!
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: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ self containingWindow ifNil: [Color lightGreen] ifNotNil: [:w | w defaultBackgroundColor]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector: aSymbol
	getEnabledSelector := aSymbol.
	self update: aSymbol.! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
pressedFillStyle
	"Return the pressed fillStyle of the receiver."
	
	^self theme buttonPressedFillStyleFor: self! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
selectedMouseOverFillStyle
	"Return the selected mouse over fillStyle of the receiver."
	
	^self theme buttonSelectedMouseOverFillStyleFor: self! !

!PluggableButtonMorph methodsFor: 'updating' stamp: ''!
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).
	self privateColor: 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 contrastingBlackAndWhiteColor]
					ifFalse: [pc contrastingBlackAndWhiteColor muchDarker].
				self labelMorph color: lc]].
	super changed! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
mouseOverBorderStyle
	"Return the mouse over borderStyle of the receiver."
	
	^self theme buttonMouseOverBorderStyleFor: self! !

!PluggableButtonMorph methodsFor: 'arguments' stamp: ''!
argumentsProvider: anObject argumentsSelector: aSelector
	"Set the argument provider and selector"

	argumentsProvider := anObject.
	argumentsSelector := aSelector! !

!PluggableButtonMorph methodsFor: 'updating' stamp: ''!
update: aParameter 
	|state|
	
	aParameter ifNil: [^self].
	"I associate label and icon because both are part of a 'complex' label... and update one 
	 means update the other"
	((aParameter == getLabelSelector) or: [ (aParameter == getIconSelector) ]) ifTrue: [
		getIconSelector ifNotNil: [ self icon: (model perform: getIconSelector) ].
		self label: (getLabelSelector ifNotNil: [ model perform: getLabelSelector])].
	aParameter == getFontSelector ifTrue: [ self font: (model perform: getFontSelector) ].
	state := self getModelState.
	(state ~= (self lastState) 
		or: [ getStateSelector isNil and: [aParameter == #onOffColor]])
		ifTrue: [
			self color: self colorToUse.
			self lastState: state].
	aParameter == getEnabledSelector ifTrue: [^self enabled: (model perform: getEnabledSelector)].
	getColorSelector ifNotNil: [ | cc |
		color = (cc := model perform: getColorSelector) 
			ifFalse: [
				self privateColor: cc.
				self onColor: color offColor: color.
				self changed ]].
		
	aParameter isArray ifFalse: [ ^ self ].
	aParameter size == 2 ifFalse: [ ^ self ].
	
	aParameter first = #askBeforeChanging: ifTrue: [ self askBeforeChanging: aParameter second ]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
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: ''!
interactionStates
	"Return all the states that the receiver may be in at any given moment."
	
	^#(normal mouseOver pressed disabled
		selected selectedPressed selectedMouseOver selectedDisabled)! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
actionSelector: aSymbol 
	"Set actionSelector to be the action defined by aSymbol.
	SimpleButtonMorph cross-compatibility"

	actionSelector := aSymbol.! !

!PluggableButtonMorph methodsFor: 'balloon' stamp: ''!
helpText 
	^ self balloonText! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
getColorSelector
	^getColorSelector! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!PluggableButtonMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawSubmorphsOnAthensCanvas: anAthensCanvas
	super 	drawSubmorphsOnAthensCanvas: anAthensCanvas.
	self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOnAthensCanvas: anAthensCanvas].! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	"Set the enabled state of the receiver."
	
	enabled = aBoolean ifTrue: [^self].
	enabled := aBoolean.
	self updateLabelEnablement.
	self changed! !

!PluggableButtonMorph methodsFor: 'updating' stamp: ''!
adoptColor: aColor
	"Go through paneColorChanged instead."
	
	self paneColorChanged! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
disabledBorderStyle
	"Return the disabled borderStyle of the receiver."
	
	^self theme buttonDisabledBorderStyleFor: self! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
onColor
	"Answer the on color."
	
	^onColor! !

!PluggableButtonMorph methodsFor: 'updating' stamp: ''!
paneColorChanged
	"Use changed to update the appearance."

	self changed! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
labelMorph
	"Answer the actual label morph."

	^ labelMorph! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
actionBlock

	^ actionBlock! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
pressedBorderStyle
	"Return the pressed borderStyle of the receiver."
	
	^self theme buttonPressedBorderStyleFor: self! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
getFontSelector
	^ getFontSelector! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
roundedCorners: anArray
	"Adjust the layout inset if necessary."

	super roundedCorners: anArray.
	self layoutInset: (self theme buttonLabelInsetFor: self)! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
action
	"Answer the action selector."

	^self actionSelector! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
availableBorderStyles
	"Return the selectors of the the available border styles for each state.
	Must match the order of interactionStates."
	
	^#(normalBorderStyle mouseOverBorderStyle pressedBorderStyle disabledBorderStyle
		selectedBorderStyle selectedPressedBorderStyle selectedMouseOverBorderStyle selectedDisabledBorderStyle)! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
triggerOnMouseDown: aBoolean
	"If this preference is turned on, then trigger my action immediately when the mouse goes down."

	triggerOnMouseDown := aBoolean.! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
beIconRight
	"show icon right to label"
	iconPosition := #right.
	self update: getIconSelector! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
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: 'accessing' stamp: ''!
label: aStringOrTextOrMorph font: aFont
	"Label this button with the given string or morph."
	| containerMorph |

	self removeAllMorphs.
	"nest label in a row for centering"
	containerMorph := AlignmentMorph new
		borderWidth: 0;
		layoutInset: 0;
		cellInset: 2;
		color: Color transparent;
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		wrapCentering: #center;
		listCentering: #center;
		cellPositioning: #center;
		yourself.
		
	(self iconPosition == #top or: [ self iconPosition == #bottom ]) 
		ifTrue: [ containerMorph setAsColumn ]
		ifFalse: [ containerMorph setAsRow ].

	label := aStringOrTextOrMorph.	
	self label ifNotNil: [ 
		labelMorph := self label isMorph
			ifTrue: [ self label ]
			ifFalse: [ self newLabel: aFont ].
		containerMorph addMorph: labelMorph ].

	self icon ifNotNil: [
		iconMorph := self icon asMorph.
		((self iconPosition == #right) or: [ self iconPosition == #bottom ])
			ifTrue: [ containerMorph addMorphBack: iconMorph ]
			ifFalse: [ containerMorph addMorphFront: iconMorph ] ].
	
	self addMorph: containerMorph.
	self updateLabelEnablement! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
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: ''!
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: ''!
on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel
	"This method is for backward compatibility."
	self 
		on: anObject 
		getState: getStateSel 
		action: actionSel 
		label: labelSel 
		icon: nil 
		menu: menuSel! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: ''!
addStandardHaloMenuItemsTo: aMenu hand: aHandMorph

	aMenu add: 'browse action' selector: #browseAction.
	aMenu addLine.
	super addStandardHaloMenuItemsTo: aMenu hand: aHandMorph.! !

!PluggableButtonMorph methodsFor: 'style' stamp: ''!
selectedPressedBorderStyle
	"Return the selected pressed borderStyle of the receiver."
	
	^self theme buttonSelectedPressedBorderStyleFor: self! !

!PluggableButtonMorph methodsFor: 'keyboard' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: label help: helpText
	"Answer a new button."

	| b |
	b := self on: aModel getState: stateSel action: actionSel.
	b
		arguments: (args ifNil: [{b}]);
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		label: label ;
		getEnabledSelector: enabledSel;
		setBalloonText: helpText;
		extent: b minExtent;
		hResizing: #rigid;
		vResizing: #rigid.
	^b! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: ''!
on: anObject getState: getStateSel action: actionSel label: labelSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		icon: nil
		menu: nil! !

!PluggableButtonMorph class methodsFor: 'shortcuts' stamp: ''!
buildPluggableButtonShortcutsOn: aBuilder
	<keymap>
	(aBuilder shortcut: #action1)
		category: #PluggableButtonMorph
		default: Character space asKeyCombination | Character cr asKeyCombination
		do: [ :target :morph :event | morph performAction ].! !

!PluggableButtonMorph class methodsFor: 'examples' stamp: ''!
exampleButtonNoAction
	<sampleInstance>

	^ PluggableButtonMorph
		newButtonFor: nil
		action: nil
		label: 'A Button'
		help: 'This is a button'! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: ''!
on: anObject getState: getStateSel action: actionSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: nil
		icon: nil
		menu: nil! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: ''!
on: anObject

	^ self on: anObject getState: #isOn action: #switch! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: ''!
newButtonFor: aModel action: actionSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: nil 
		label: stringOrText
		help: helpText! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: ''!
on: anObject getState: getStateSel action: actionSel label: labelSel icon: iconSel menu: menuSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		icon: iconSel
		menu: menuSel! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: ''!
on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		icon: nil
		menu: menuSel! !

!PluggableButtonMorphExample commentStamp: ''!
I keep some examples on how to use a PluggableButtonMorph!
!PluggableButtonMorphExample methodsFor: 'building' stamp: ''!
buildButton
	^ PluggableButtonMorph
		on: self 
		getState: nil
		action:  #action 
		label: #label 
		menu: nil.! !

!PluggableButtonMorphExample methodsFor: 'building' stamp: ''!
buildButtonWithIconBottom
	^ (PluggableButtonMorph
		on: self 
		getState: nil 
		action:  #action 
		label: #label 
		icon: #icon
		menu: nil)
		beIconBottom.! !

!PluggableButtonMorphExample methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	label := 'Test label'.
	state := #on.
	icon := self iconNamed: #smallOkIcon! !

!PluggableButtonMorphExample methodsFor: 'accessing' stamp: ''!
label: anObject
	label := anObject! !

!PluggableButtonMorphExample methodsFor: 'building' stamp: ''!
buildButtonWithIconTop
	^ (PluggableButtonMorph
		on: self 
		getState: nil 
		action:  #action 
		label: #label 
		icon: #icon
		menu: nil)
		beIconTop.! !

!PluggableButtonMorphExample methodsFor: 'actions' stamp: ''!
action
	self inform: 'Button pressed'! !

!PluggableButtonMorphExample methodsFor: 'accessing' stamp: ''!
state: anObject
	state := anObject! !

!PluggableButtonMorphExample methodsFor: 'building' stamp: ''!
buildButtonWithIcon
	^ PluggableButtonMorph
		on: self 
		getState: nil 
		action:  #action 
		label: #label 
		icon: #icon
		menu: nil.! !

!PluggableButtonMorphExample methodsFor: 'accessing' stamp: ''!
state
	^ state! !

!PluggableButtonMorphExample methodsFor: 'building' stamp: ''!
buildButtonWithIconRight
	^ (PluggableButtonMorph
		on: self 
		getState: nil 
		action:  #action 
		label: #label 
		icon: #icon
		menu: nil)
		beIconRight.! !

!PluggableButtonMorphExample methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!PluggableButtonMorphExample methodsFor: 'accessing' stamp: ''!
icon: anObject
	icon := anObject! !

!PluggableButtonMorphExample methodsFor: 'building' stamp: ''!
buildButtonNoLabel
	^ PluggableButtonMorph
		on: self 
		getState: nil 
		action:  #action 
		label: nil 
		icon: #icon
		menu: nil.! !

!PluggableButtonMorphExample methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!PluggableButtonMorphExample class methodsFor: 'examples' stamp: ''!
exampleButtonWithIconBottom
	<example>
	self new buildButtonWithIconBottom openInWindow! !

!PluggableButtonMorphExample class methodsFor: 'examples' stamp: ''!
exampleButtonWithIcon
	<example>
	self new buildButtonWithIcon openInWindow! !

!PluggableButtonMorphExample class methodsFor: 'examples' stamp: ''!
exampleButtonNoLabel
	<example>
	self new buildButtonNoLabel openInWindow! !

!PluggableButtonMorphExample class methodsFor: 'examples' stamp: ''!
exampleButtonFont
	<example>
	self new buildButton
		font: (LogicalFont familyName: 'Source Sans Pro' pointSize: 24);
	  openInWindow! !

!PluggableButtonMorphExample class methodsFor: 'examples' stamp: ''!
exampleButton
	<example>
	self new buildButton openInWindow! !

!PluggableButtonMorphExample class methodsFor: 'examples' stamp: ''!
exampleButtonWithIconTop
	<example>
	self new buildButtonWithIconTop openInWindow! !

!PluggableButtonMorphExample class methodsFor: 'examples' stamp: ''!
exampleButtonWithIconRight
	<example>
	self new buildButtonWithIconRight openInWindow! !

!PluggableCanvas commentStamp: ''!
An abstract canvas which modifies the behavior of an underlying canvas in some way.  Subclasses should implement apply:, which takes a one argument block and an actual canvas to draw on.  See apply: for the specific definition.!
!PluggableCanvas methodsFor: 'drawing - support' stamp: ''!
clipBy: newClipRect during: aBlock
	self apply: [ :c |
		c clipBy: newClipRect during: aBlock ]! !

!PluggableCanvas methodsFor: 'drawing - polygons' stamp: ''!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	self apply: [ :c |
		c drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc ]! !

!PluggableCanvas methodsFor: 'accessing' stamp: ''!
shadowColor: color
	self apply: [ :c |
		c shadowColor: color ]! !

!PluggableCanvas methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubParagraph: paragraph bounds: bounds color: color
	self apply: [ :c |
		c paragraph: paragraph bounds: bounds color: color ]! !

!PluggableCanvas methodsFor: 'accessing' stamp: ''!
origin

	self apply: [ :c | ^c origin ].! !

!PluggableCanvas methodsFor: 'drawing - text' stamp: ''!
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: 'canvas methods' stamp: ''!
showAt: pt invalidRects: updateRects
	self apply: [ :c |
		c showAt: pt invalidRects: updateRects ]! !

!PluggableCanvas methodsFor: 'other' stamp: ''!
translateBy: aPoint clippingTo: aRect during: aBlock
	self apply: [ :clippedCanvas |
		clippedCanvas translateBy: aPoint clippingTo: aRect during: aBlock ]! !

!PluggableCanvas methodsFor: 'drawing - rectangles' stamp: ''!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	self apply: [ :c |
		c frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor ]! !

!PluggableCanvas methodsFor: 'initialization' stamp: ''!
flush
	self apply: [ :c |
		c flush ]! !

!PluggableCanvas methodsFor: 'drawing - ovals' stamp: ''!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given oval."
	(aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
		self flag: #pharoFixMe. "See FormCanvas>>fillOval:fillStyle:borderWidth:borderColor:"
		^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 apply: [ :c | 
		c drawOval: (aRectangle insetBy: bw // 2)
			color: aFillStyle 
			borderWidth: bw
			borderColor: bc ]! !

!PluggableCanvas methodsFor: 'private' stamp: ''!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	self apply:  [ :c |
		c image: aForm at: aPoint sourceRect: sourceRect rule: rule ]! !

!PluggableCanvas methodsFor: 'drawing - rectangles' stamp: ''!
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)].
	].

	self apply: [ :c | 
		c drawRectangle: aRectangle
			color: aFillStyle
			borderWidth: 0
			borderColor: nil ]! !

!PluggableCanvas methodsFor: 'drawing - general' stamp: ''!
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: 'accessing' stamp: ''!
contentsOfArea: aRectangle into: aForm
	self apply: [ :c |
		c contentsOfArea: aRectangle into: aForm ].
	^aForm! !

!PluggableCanvas methodsFor: 'drawing - ovals' stamp: ''!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	self apply: [ :clippedCanvas |
		clippedCanvas fillOval: r color: c borderWidth: borderWidth borderColor: borderColor ]! !

!PluggableCanvas methodsFor: 'accessing' stamp: ''!
clipRect
	| innerClipRect |
	self apply: [ :c |
		innerClipRect := c clipRect ].
	^innerClipRect! !

!PluggableCanvas methodsFor: 'other' stamp: ''!
flushDisplay
	self apply: [ :c |
		c flushDisplay ]! !

!PluggableCanvas methodsFor: 'drawing' stamp: ''!
line: pt1 to: pt2 width: w color: c
	self apply: [ :clippedCanvas |
		clippedCanvas line: pt1 to: pt2 width: w color: c ]! !

!PluggableCanvas methodsFor: 'drawing' stamp: ''!
render: anObject
	self apply: [ :c |
		c render: anObject ]! !

!PluggableCanvas methodsFor: 'accessing' stamp: ''!
extent

	self apply: [ :c | ^c extent ].! !

!PluggableCanvas methodsFor: 'private' stamp: ''!
apply: aBlock
	"evaluate aBlock with a canvas to do a drawing command on.  See implementors for examples"! !

!PluggableCanvas methodsFor: 'drawing - images' stamp: ''!
paintImage: aForm at: aPoint sourceRect: sourceRect
	self apply: [ :c |
		c paintImage: aForm at: aPoint sourceRect: sourceRect ]! !

!PluggableCanvas methodsFor: 'drawing - support' stamp: ''!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize

	self apply: [ :clippedCanvas |
		clippedCanvas transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize ]! !

!PluggableCanvas methodsFor: 'drawing - text' stamp: ''!
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: 'drawing - images' stamp: ''!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	self apply: [ :c |
		c stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor ]! !

!PluggableCanvas methodsFor: 'drawing - support' stamp: ''!
translateBy: delta during: aBlock
	self apply: [ :clippedCanvas |
		 clippedCanvas translateBy: delta during: aBlock ]! !

!PluggableCanvas methodsFor: 'drawing' stamp: ''!
paragraph: paragraph bounds: bounds color: color
	self apply: [ :c |
		c paragraph: paragraph bounds: bounds color: color ]! !

!PluggableCanvas methodsFor: 'drawing - images' stamp: ''!
paintImage: aForm at: aPoint
	self apply: [ :c |
		c paintImage: aForm at: aPoint ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: ''!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	self apply: [ :c | c infiniteFillRectangle: aRectangle fillStyle: aFillStyle ]! !

!PluggableDialogWindow commentStamp: ''!
Pluggable form of dialog window supporting custom selector on model for applying changes along with configurable content and buttons.!
!PluggableDialogWindow methodsFor: 'accessing' stamp: ''!
applyChangesSelector: anObject
	"Set the value of applyChangesSelector"

	applyChangesSelector := anObject! !

!PluggableDialogWindow methodsFor: 'actions' stamp: ''!
newContentMorph
	"Answer the plugged content."
	
	^self contentMorph! !

!PluggableDialogWindow methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		buttons: super newButtons! !

!PluggableDialogWindow methodsFor: 'focus handling' stamp: ''!
defaultFocusMorph
	^ defaultFocusMorph ifNil: [super defaultFocusMorph]! !

!PluggableDialogWindow methodsFor: 'accessing' stamp: ''!
statusValue
	^statusValue! !

!PluggableDialogWindow methodsFor: 'accessing' stamp: ''!
contentMorph
	"Answer the value of contentMorph"

	^ contentMorph! !

!PluggableDialogWindow methodsFor: 'accessing' stamp: ''!
contentMorph: anObject
	"Set the value of contentMorph"

	contentMorph := anObject! !

!PluggableDialogWindow methodsFor: 'accessing' stamp: ''!
buttons: anObject
	"Set the value of buttons"

	buttons := anObject! !

!PluggableDialogWindow methodsFor: 'accessing' stamp: ''!
buttons
	"Answer the value of buttons"

	^ buttons! !

!PluggableDialogWindow methodsFor: 'actions' stamp: ''!
newButtons
	"Answer  the plugged buttons."

	^self buttons! !

!PluggableDialogWindow methodsFor: 'accessing' stamp: ''!
applyChangesSelector
	"Answer the value of applyChangesSelector"

	^ applyChangesSelector! !

!PluggableDialogWindow methodsFor: 'actions' stamp: ''!
applyChanges
	"Apply the changes."

	super applyChanges.
	self applyChangesSelector ifNotNil: [:s |
		self model perform: s withEnoughArguments: {self}]! !

!PluggableDialogWindow methodsFor: 'focus handling' stamp: ''!
defaultFocusMorph: aMorph
	defaultFocusMorph := aMorph! !

!PluggableDialogWindow methodsFor: 'accessing' stamp: ''!
statusValue: val
	statusValue := val! !

!PluggableDialogWindow methodsFor: 'actions' stamp: ''!
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: 'actions' stamp: ''!
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: 'actions' stamp: ''!
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}! !

!PluggableDictionary commentStamp: ''!
Class PluggableDictionary allows the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the dictionary. See the class comment of PluggableSet for an example.

Instance variables:
	hashBlock	<BlockClosure>	A one-argument block used for hashing the keys.
	equalBlock	<BlockClosure>	A two-argument block used for comparing the keys.
!
!PluggableDictionary methodsFor: 'private' stamp: ''!
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 methodsFor: 'accessing' stamp: ''!
equalBlock
	"Return the block used for comparing the elements in the receiver."
	^equalBlock! !

!PluggableDictionary methodsFor: 'comparing' stamp: ''!
= 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.
	See issue 16760 before changing"

	self == aDictionary ifTrue: [^true].
	self species == aDictionary species ifFalse: [^false].
	self size = aDictionary size ifFalse: [^false].
	self equalBlock = aDictionary equalBlock ifFalse: [^false].
	self hashBlock = aDictionary hashBlock ifFalse: [^false].
	self associationsDo: [:assoc|
		(aDictionary at: assoc key ifAbsent: [^false]) = assoc value
			ifFalse: [^false]].
	^true! !

!PluggableDictionary methodsFor: 'copying' stamp: ''!
copyEmpty
	^super copyEmpty
		hashBlock: hashBlock;
		equalBlock: equalBlock! !

!PluggableDictionary methodsFor: 'accessing' stamp: ''!
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: 'comparing' stamp: ''!
hash
	"hashBlock is used to hash keys for lookup, not the dictionary itself, but its hash is still
	considered."
	^ (super hash bitXor: self equalBlock hash) bitXor: self hashBlock hash! !

!PluggableDictionary methodsFor: 'accessing' stamp: ''!
hashBlock
	"Return the block used for hashing the keys in the receiver."
	^hashBlock! !

!PluggableDictionary methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
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 class methodsFor: 'accessing' stamp: ''!
integerDictionary
	^ self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! !

!PluggableDictionaryTest commentStamp: ''!
SUnit tests for pluggable dictionaries!
!PluggableDictionaryTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	| pluggableDict copiedPluggableDict |
	super testCopyEmpty.

	(pluggableDict := self emptyDict)
		equalBlock: [ :a :b | a = b ];
		hashBlock: [ :a | a hash ].

	copiedPluggableDict := pluggableDict copyEmpty.
	self assert: copiedPluggableDict equalBlock identicalTo: pluggableDict equalBlock.
	self assert: copiedPluggableDict hashBlock identicalTo: pluggableDict hashBlock! !

!PluggableDictionaryTest methodsFor: 'tests - comparing' stamp: ''!
testHashBlock
	| pluggableDict keys |
	pluggableDict := self nonEmptyDict.
	keys := pluggableDict keys.
	self assert: pluggableDict hashBlock isNil.
	self assert: (pluggableDict hashBlock: [ :a | a hash ]) identicalTo: pluggableDict.

	keys do: [ :each | self assert: (pluggableDict includesKey: each) ].
	self deny: (pluggableDict includesKey: self keyNotIn)! !

!PluggableDictionaryTest methodsFor: 'tests - comparing' stamp: ''!
testHashBlockEquality
	| pluggableDict pluggableDict2 hashBlock |
	pluggableDict := self nonEmptyDict.
	pluggableDict2 := self nonEmptyDict copy.

	hashBlock := [ :a | a hash ].
	pluggableDict2 hashBlock: hashBlock.
	self deny: pluggableDict equals: pluggableDict2.
	self deny: pluggableDict2 equals: pluggableDict.

	pluggableDict hashBlock: hashBlock.
	self assert: pluggableDict equals: pluggableDict2.
	self assert: pluggableDict2 equals: pluggableDict! !

!PluggableDictionaryTest methodsFor: 'tests - comparing' stamp: ''!
testEqualBlock
	| pluggableDict assoc |
	pluggableDict := self emptyDict.
	self assert: pluggableDict equalBlock isNil.
	self assert: (pluggableDict equalBlock: [ :a :b | a = b ]) identicalTo: pluggableDict.

	assoc := 'newKey' -> 'newValue'.
	pluggableDict add: assoc.
	self assert: (pluggableDict includesAssociation: assoc).

	pluggableDict equalBlock: [ :a :b | a == b ].
	self assert: (pluggableDict includesAssociation: assoc).
	pluggableDict
		removeKey: assoc key;
		add: assoc key copy -> assoc value.
	self deny: (pluggableDict includesAssociation: assoc).

	pluggableDict equalBlock: [ :a :b | a = b ].
	self assert: (pluggableDict includesAssociation: assoc)! !

!PluggableDictionaryTest methodsFor: 'tests - comparing' stamp: ''!
testEqualBlockEquality
	| pluggableDict pluggableDict2 equalBlock |
	pluggableDict := self nonEmptyDict.
	pluggableDict2 := self nonEmptyDict copy.

	equalBlock := [ :a :b | a = b ].
	pluggableDict2 equalBlock: equalBlock.
	self deny: pluggableDict equals: pluggableDict2.
	self deny: pluggableDict2 equals: pluggableDict.

	pluggableDict equalBlock: equalBlock.
	self assert: pluggableDict equals: pluggableDict2.
	self assert: pluggableDict2 equals: pluggableDict! !

!PluggableDictionaryTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ PluggableDictionary! !

!PluggableDictionaryTest class methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ IdentitySet! !

!PluggableDictionaryTest class methodsFor: 'building suites' stamp: ''!
shouldInheritSelectors

^true! !

!PluggableIconListMorph commentStamp: ''!
A type of PluggableListMorph that supports a single icon (Form) for items. Useful for lists with icons.!
!PluggableIconListMorph methodsFor: 'event' stamp: ''!
basicKeyPressed: aChar 
	
	^ aChar == Character space
		ifTrue: [ self interactWithSelectedItem ]
		ifFalse: [ super basicKeyPressed: aChar ]! !

!PluggableIconListMorph methodsFor: 'accessing' stamp: ''!
getIconSelector
	"Answer the value of getIconSelector"

	^ getIconSelector! !

!PluggableIconListMorph methodsFor: 'display' stamp: ''!
itemMorphFor: anObject index: anIndex
	"Answer a morph for the object with the appropriate icon."

	|item icon|
	item := IconicListItemMorph new
		originalObject: anObject;
		yourself.
		
	icon := self getIconSelector ifNotNil: [self model perform: self getIconSelector withEnoughArguments: {anObject. anIndex}].
	icon ifNotNil: [
		item icon: icon asMorph].
	item morph: (self wrapItem: anObject index: anIndex) asMorph.
	^item! !

!PluggableIconListMorph methodsFor: 'model access' stamp: ''!
getListItem: index
	"get the index-th item in the displayed list"

	getListElementSelector ifNotNil: [
		^self itemMorphFor: (model perform: getListElementSelector with: index) index: index].
	(list notNil and: [list size >= index]) ifTrue: [ ^list at: index ].
	^ self wrapItem: (self getList at: index) index: index! !

!PluggableIconListMorph methodsFor: 'accessing' stamp: ''!
getIconSelector: anObject
	"Set the value of getIconSelector"

	getIconSelector := anObject! !

!PluggableIconListMorph methodsFor: 'model access' stamp: ''!
getList

	"Answer the list to be displayed.  Caches the returned list in the 'list' ivar"

	getListSelector ifNil: [ ^ #() ].
	list := model perform: getListSelector.
	list ifNil: [ ^ #() ].
	list := list collectWithIndex: [ :item :index | self itemMorphFor: item index: index ].
	^ list! !

!PluggableIconListMorph methodsFor: 'action' stamp: ''!
interactWithSelectedItem

	self selection
		ifNotNil: [: sel | sel submorphs do: [:each | each update: #interact ]]! !

!PluggableListItemWrapper commentStamp: ''!
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: ''!
string: aString
	string := aString! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: ''!
hasContents
	hasContentsSelector ifNil:[^super hasContents].
	^self sendToModel: hasContentsSelector! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: ''!
getContentsSelector: aSymbol
	self validateSelector: aSymbol.
	getContentsSelector := aSymbol.! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: ''!
getStringSelector
	^getStringSelector! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: ''!
getStringSelector: aSymbol
	self validateSelector: aSymbol.
	getStringSelector := aSymbol.! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: ''!
hasContentsSelector
	^hasContentsSelector! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: ''!
getContentsSelector
	^getContentsSelector! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: ''!
hasContentsSelector: aSymbol
	self validateSelector: aSymbol.
	hasContentsSelector := aSymbol.! !

!PluggableListItemWrapper methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream 
		nextPut: $(; 
		print: self; 
		nextPut: $)! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: ''!
string
	^string! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: ''!
asString
	string ifNotNil:[^string].
	getStringSelector ifNil:[^super asString].
	^self sendToModel: getStringSelector! !

!PluggableListItemWrapper methodsFor: 'private' stamp: ''!
validateSelector: aSymbol
	(aSymbol numArgs between: 0 and: 2) ifFalse:[^self error: 'Invalid pluggable selector'].! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: ''!
contents
	getContentsSelector ifNil:[^#()].
	^self sendToModel: getContentsSelector.! !

!PluggableListItemWrapper methodsFor: 'private' stamp: ''!
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].! !

!PluggableListMorph commentStamp: ''!
...

When a PluggableListMorph is in focus, type in a letter (or several
letters quickly) to go to the next item that begins with that letter.
Special keys (up, down, home, etc.) are also supported.!
!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
mouseUpOnMultiple: event
	"Reset the mouseDownRow."
	
	dragOnOrOff := nil.  "So improperly started drags will have not effect".
	event hand hasSubmorphs ifFalse: [
		self mouseDownRow: nil]! !

!PluggableListMorph methodsFor: 'geometry' stamp: ''!
scrollDeltaHeight
	"Return the increment in pixels which this pane should be scrolled."
	^ self font height! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
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: 'menus' stamp: ''!
copySelectionToClipboard
	"Copy my selected item to the clipboard as a string"

	self selection ifNotNil: [ Clipboard clipboardText: self selection asString ] ifNil: [ self flash ]! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
resetListSelection

	self resetListSelectionSilently.
	self changed! !

!PluggableListMorph methodsFor: 'scrolling' stamp: ''!
resizeScrollBars
	"Fixed to not use deferred message that incorrectly
	sets scroll deltas/interval."

	(self extent = self defaultExtent)
		ifFalse: [super resizeScrollBars]! !

!PluggableListMorph methodsFor: 'events' stamp: ''!
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: 'searching' stamp: ''!
listForSearching

	^ getListSelector
		ifNotNil: [ self getList ]
		ifNil: [ getListElementSelector
				ifNil: [ #() ]
				ifNotNil: [ 
					(1 to: self getListSize) collect: [:index | self getListItem: index ]]]! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
wantsDropSelector
	^wantsDropSelector! !

!PluggableListMorph methodsFor: 'scrolling' stamp: ''!
vUnadjustedScrollRange
	"Return the height extent of the receiver's submorphs."
	(scroller submorphs size > 0) ifFalse:[ ^0 ].
	^(scroller submorphs last fullBounds bottom)! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
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: 'model access' stamp: ''!
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: 'scrolling' stamp: ''!
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: 'updating' stamp: ''!
updateEnabled
	"Update the enablement state."

	self model ifNotNil: [
		self getEnabledSelector ifNotNil: [
			self enabled: (self model perform: self getEnabledSelector)]]! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
multipleSelection

	^ multipleSelection ifNil: [ multipleSelection := self defaultMultipleSelectionValue ]! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
defaultMultipleSelectionValue

	^ false! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
setSelectionListSelector: getListSel

	setSelectionListSelector := getListSel! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
keystrokeActionSelector: keyActionSel
	"Set the keystroke action selector as specified"

	keystrokeActionSelector := keyActionSel! !

!PluggableListMorph methodsFor: 'model access' stamp: ''!
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: 'selection' stamp: ''!
selection: item
	"Called from outside to request setting a new selection."

	self selectionIndex: (self getList indexOf: item)! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
listSelectionAt: index

	index isZero ifFalse:[ lastNonZeroIndex := index ].
	getSelectionListSelector ifNil:[^false].
	^model perform: getSelectionListSelector with: index! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
basicGetListElementSelector: aSymbol
	"specify a selector that can be used to obtain a single element in the underlying list"
	getListElementSelector := aSymbol.! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
wantsDropSelector: aSymbol
	wantsDropSelector := aSymbol! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
font: aFontOrNil
	self listMorph font: aFontOrNil.! !

!PluggableListMorph methodsFor: 'menus' stamp: ''!
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...' target: self selector: #setListFont.
	aMenu add: 'copy list to clipboard' target: self selector: #copyListToClipboard.
	aMenu add: 'copy selection to clipboard' target: self selector: #copySelectionToClipboard! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
deselectAll

	self isMultipleSelection ifFalse: [ ^ self ].
	self resetListSelection! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
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: 'configuration' stamp: ''!
enabled
	"Answer the enablement state of the receiver."

	^enabled ifNil: [true]! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
getIndexSelector: aSelector

	getIndexSelector := aSelector! !

!PluggableListMorph methodsFor: 'drawing' stamp: ''!
adoptPaneColor: paneColor
	"Pass on to the border too."
	
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	self selectionColor: self selectionColor.
	self fillStyle: self fillStyleToUse.
	self borderWidth > 0 ifTrue: [
		self borderStyle: self borderStyleToUse]! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
getListSelector
	^ getListSelector! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
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: ''!
beSingleSelection

	multipleSelection := false! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
dragItemSelector
	^dragItemSelector! !

!PluggableListMorph methodsFor: 'separator' stamp: ''!
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: ''!
separatorBlockOrSelector

	^ separatorBlockOrSelector! !

!PluggableListMorph methodsFor: 'debug and other' stamp: ''!
userString
	^list ifNotNil: [ 
		String streamContents: [:strm |
			list do: [:i |
				strm nextPutAll: (i string); cr
			]
		]
	]! !

!PluggableListMorph methodsFor: 'background coloring' stamp: ''!
backgroundColoringBlockOrSelector

	^ backgroundColoringBlockOrSelector! !

!PluggableListMorph methodsFor: 'wrapping' stamp: ''!
wrapItem: anItem index: anIndex
	"Use the wrapSelector to get the text or string representation of a list item."
	
	^ self wrapSelector 
		ifNil: [ anItem asStringOrText]
		ifNotNil: [:selector | 
			selector numArgs == 0
				ifTrue: [ anItem perform: selector ]
				ifFalse: [ self model perform: selector withEnoughArguments: { anItem. anIndex } ]].! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
listMorphClass
	^LazyListMorph! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
font

	^ self listMorph font! !

!PluggableListMorph methodsFor: 'geometry' stamp: ''!
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: 'events' stamp: ''!
mouseDownRow: anIntegerOrNil
	"Set the mouse down row or nil if none."

	self listMorph mouseDownRow: anIntegerOrNil! !

!PluggableListMorph methodsFor: 'model access' stamp: ''!
getCurrentSelectionIndex
	"Answer the index of the current selection."

	getIndexSelector ifNil: [^0].
	^model perform: getIndexSelector! !

!PluggableListMorph methodsFor: 'geometry' stamp: ''!
focusBounds
	"Answer the bounds for drawing the focus indication."

	^self theme listFocusBoundsFor: self! !

!PluggableListMorph methodsFor: 'model access' stamp: ''!
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: 'scroll cache' stamp: ''!
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: 'model access' stamp: ''!
getListSize
	"return the current number of items in the displayed list"
	getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ].
	^self getList size! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
keyDown: 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.
	aChar asciiValue < 32 ifTrue: [^ self specialKeyPressed: event ].
	(event anyModifierKeyPressed or: [self handlesBasicKeys not])
		ifTrue: [ ^ self modifierKeyPressed: event].
	^ false! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
selectAll

	self isMultipleSelection ifFalse: [ ^ self ].
	1 to: self maximumSelection do: [: i | self listSelectionAt: i put: true ]! !

!PluggableListMorph methodsFor: 'searching' stamp: ''!
secondarySelectionColor
	^ self theme secondarySelectionColor! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
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: 'accessing' stamp: ''!
basicWrapSelector: aSymbol
	wrapSelector := aSymbol.! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
dropItemSelector: aSymbol
	dropItemSelector := aSymbol.
	aSymbol ifNotNil:[self dropEnabled: true].! !

!PluggableListMorph methodsFor: 'model access' stamp: ''!
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: 'menu' stamp: ''!
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: 'selection' stamp: ''!
resetListSelectionSilently

	self resetListSelector ifNotNil: [:sel | self model perform: sel ]! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
mouseMove: evt

	self isMultipleSelection
		ifTrue: [ self mouseMoveOnMultiple: evt ]
		ifFalse: [ self mouseMoveOnSingle:evt ]! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
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: 'multi-selection' stamp: ''!
resetListSelector: aSelector

	resetListSelector := aSelector! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
initForKeystrokes
	canMove := true.
	lastKeystrokeTime := 0.
	lastKeystrokes := ''! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
selectionColorToUse: aColor
	"Set the colour for selected items."

	aColor = self selectionColorToUse ifTrue: [^self].
	selectionColorToUse := aColor.
	self listMorph selectionFrameChanged! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
autoDeselect

	^ autoDeselect
		ifNil: [ self resetListSelector notNil ]
		ifNotNil: [ autoDeselect ]! !

!PluggableListMorph methodsFor: 'model access' stamp: ''!
commandKeyTypedIntoMenu: evt
	"The user typed a command-key into a menu which has me as its command-key handler"

	^ self modifierKeyPressed: evt! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOverDragging: evt
	"Yes, for mouse down highlight."
	
	^true! !

!PluggableListMorph methodsFor: 'events' stamp: ''!
specialKeyPressed: anEvent
	"A special key with the given ascii-value was pressed; dispatch it"
	| keyString max nextSelection oldSelection howManyItemsShowing |
	
	keyString := anEvent keyString.
	keyString = '<escape>'
		ifTrue: [" escape key"
			^ self activeHand lastEvent shiftPressed
				ifTrue:
					[self world invokeWorldMenuFromEscapeKey]
				ifFalse:[ 
					(self yellowButtonActivity: false) 
						ifTrue: [ ^ self ]]].

	keyString = '<cr>'
		ifTrue: [ 
			"enter pressed" 
			self selectSearchedElement ].

	max := self maximumSelection.
	max > 0 ifFalse: [^ self].
	nextSelection := oldSelection := self getCurrentSelectionIndex.
	
	keyString = '<down>'
		ifTrue: [" down arrow"
			self resetListSelectionSilently.
			nextSelection := oldSelection + 1.
			nextSelection > max ifTrue: [nextSelection := max]].
	
	keyString = '<up>'
		ifTrue: [ " up arrow"
			self resetListSelectionSilently.
			nextSelection := oldSelection - 1.
			nextSelection < 1 ifTrue: [nextSelection := 1]].
	keyString = '<home>'
		ifTrue: [" home"
			self resetListSelectionSilently.
			nextSelection := 1].
		
	keyString = '<end>' 
		ifTrue: [" end"
			self resetListSelectionSilently.
			nextSelection := max].
	
	howManyItemsShowing := self numSelectionsInView.
	
	keyString = '<pageUp>'
		ifTrue: 	[" page up"
			self resetListSelectionSilently.
			nextSelection := 1 max: oldSelection - howManyItemsShowing].
	keyString = '<pageDown>'
		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: 'initialization' stamp: ''!
textColor: aColor
	"Set my default text color."
	self setProperty: #textColor toValue: aColor.
	self listMorph color: aColor.! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
textHighlightColor
	"Answer my default text highlight color."
	^self valueOfProperty: #textHighlightColor ifAbsent: [ Color red ].! !

!PluggableListMorph methodsFor: 'drawing' stamp: ''!
unhighlightSelection

	self searchedElement: nil.! !

!PluggableListMorph methodsFor: 'configuration' stamp: ''!
disable
	"Disable the receiver."
	
	self enabled: false! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
doubleClickSelector: aSymbol
	doubleClickSelector := aSymbol! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	"Changed to only take focus if wanted."

	| selectors row |
	row := self rowAtLocation: evt position.
	evt yellowButtonPressed
		ifTrue: [ 
			self isMultipleSelection
				ifTrue: [ 
					evt commandKeyPressed
						ifFalse: [ 
							"right click"
							(self yellowButtonActivity: evt shiftPressed)
								ifTrue: [ ^ super mouseDown: evt ] ] ]
				ifFalse: [ 
					(self yellowButtonActivity: evt shiftPressed)
						ifTrue: [ ^ super mouseDown: evt ] ] ].	"First check for option (menu) click"
	self enabled
		ifFalse: [ ^ super mouseDown: evt ].
	self wantsKeyboardFocus
		ifTrue: [ self takeKeyboardFocus ].
	row := self rowAtLocation: evt position.
	row = 0
		ifTrue: [ ^ super mouseDown: evt ].
	self mouseDownRow: row.
	self isMultipleSelection
		ifTrue: [ self mouseDownOnMultiple: evt forRow: row ].
	selectors := Array
		with: #click:
		with: (doubleClickSelector ifNotNil: [ #doubleClick: ])
		with: nil
		with:
			(self dragEnabled
				ifTrue: [ #startDrag: ]
				ifFalse: [ nil ]).
	evt hand
		waitForClicksOrDrag: self
		event: evt
		selectors: selectors
		threshold: 10.	"pixels"
	super mouseDown: evt! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	^true! !

!PluggableListMorph methodsFor: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher
	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #MorphFocusNavigation! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector
	"Answer the value of getEnabledSelector"

	^ getEnabledSelector! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
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: 'drawing' stamp: ''!
highlightSelection! !

!PluggableListMorph methodsFor: 'separator' stamp: ''!
separatorBlockOrSelector: aBlockOrSelector

	separatorBlockOrSelector := aBlockOrSelector! !

!PluggableListMorph methodsFor: 'updating' stamp: ''!
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 ifNotNil: [ 
		index := index min: self getListSize.
		index > 0 ifTrue: [	self selectionIndex: index].
	].
	
	self searchedElement: nil.! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
mouseUpOnSingle: event
	"The mouse came up within the list; take appropriate action"
	
	| row mdr |
	row := self rowAtLocation: event position.
	event hand hasSubmorphs ifFalse: [
		mdr := self mouseDownRow.
		 self mouseDownRow: nil.
		mdr ifNil: [^self]].

	(self enabled and: [model okToChange])
		ifFalse: [^ self].

	"No change if model is locked or receiver disabled"
	row == self selectionIndex
		ifTrue: [
			self autoDeselect 
				ifTrue: [ row = 0 ifFalse: [ self changeModelSelection: 0 ] ]
				ifFalse: [ self changeModelSelection: row ] ]
		ifFalse: [ self changeModelSelection: row ].
	Cursor normal show! !

!PluggableListMorph methodsFor: 'searching' stamp: ''!
selectSearchedElement

	self searchedElement ifNotNil: [: index |	
		self activeHand lastEvent commandKeyPressed	ifFalse: [ self resetListSelectionSilently ].
		self changeModelSelection: index.
		self isMultipleSelection
			ifTrue: [ self listSelectionAt: index put: true ].
		self vScrollValue: ((index-1)/self getListSize) ]! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
setMultipleSelection: aBoolean

	multipleSelection := aBoolean! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: ''!
wantsDroppedMorph: aMorph event: anEvent
	^ aMorph dragTransferType == #dragTransfer 
		ifTrue: [ dropItemSelector ifNil: [^false].
			wantsDropSelector ifNil: [^true].
			(model perform: wantsDropSelector with: aMorph passenger)]
		ifFalse: [ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self]! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
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: 'drag and drop' stamp: ''!
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: 'geometry' stamp: ''!
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: 'selection' stamp: ''!
setSelectedMorph: aMorph
	self changeModelSelection: (scroller submorphs indexOf: aMorph)! !

!PluggableListMorph methodsFor: 'searching' stamp: ''!
searchedElement

	^ searchedElement! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
getListSelector: sel
	"Set the receiver's getListSelector as indicated, and trigger a recomputation of the list"

	getListSelector := sel.
	self changed.
	self updateList.! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: ''!
startDragExtended: evt
	"This method was defined in PluggableListMorphPlus (a subclass that got merged)" 
	
	dragItemSelector ifNil: [^self].
	evt hand hasSubmorphs ifTrue: [^ self].
	[ | dragIndex draggedItem ddm ddRect |
	(self dragEnabled and: [model okToChange]) ifFalse: [^ self].
	dragIndex := self rowAtLocation: evt position.
	dragIndex = 0 ifTrue: [^self].
	draggedItem := model perform: dragItemSelector with: dragIndex.
	draggedItem ifNil: [^self].
	self mouseDownRow: nil.
	ddm := self model transferFor: draggedItem from: self.
	ddRect := ddm draggedMorph bounds.
	ddm position: evt position - (ddRect center - ddRect origin).
	ddm dragTransferType: #dragTransfer.
	evt hand grabMorph: ddm]
		ensure: [Cursor normal show.
			evt hand newMouseFocus: self]! !

!PluggableListMorph methodsFor: 'updating' stamp: ''!
themeChanged

	self setProperty: #textColor toValue: self theme textColor; updateList.
	
	self selectionColor ifNotNil: [
		self selectionColor: self theme selectionColor
	].

	super themeChanged! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
textHighlightColor: aColor
	"Set my default text highlight color."
	self setProperty: #textHighlightColor toValue: aColor.! !

!PluggableListMorph methodsFor: 'separator' stamp: ''!
separatorColor: aColor

	separatorColor := aColor! !

!PluggableListMorph methodsFor: 'events' stamp: ''!
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: 'background coloring' stamp: ''!
backgroundColorFor: aRow

	| return |
	aRow ifNil: [ ^ nil ].
	self enabled
		ifFalse: [ return := Color white darker darker ].
	self backgroundColoringBlockOrSelector
		ifNotNil: [:blockOrSelector || anItem |
			anItem := getListElementSelector
						ifNil: [ list at: aRow ifAbsent: [ ^ nil ]]
						ifNotNil: [ model perform: getListElementSelector with: aRow ].

			return := blockOrSelector isBlock
				ifTrue: [ blockOrSelector cull: anItem cull: aRow ]
				ifFalse: [
					blockOrSelector isSymbol
						ifTrue: [ blockOrSelector numArgs == 0
									ifTrue: [ anItem perform: blockOrSelector ]
									ifFalse: [ self model perform: blockOrSelector withEnoughArguments: { anItem. aRow} ]]
						ifFalse: [ nil ]]].
		
		^ return isColor
			ifTrue: [ return ]
			ifFalse: [ nil ]! !

!PluggableListMorph methodsFor: 'model access' stamp: ''!
keystrokeAction: event 
	| returnValue |
	
	keystrokeSelector ifNil: [ ^ nil ].

	returnValue := model 
						perform: keystrokeSelector
						withEnoughArguments: { event. self }.
	
	^ returnValue = true! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
selectionColor: aColor
	"Set the colour for selected items."

	| window |
	selectionColor := aColor.
	window := self ownerThatIsA: SystemWindow.

	self selectionColorToUse: ((self theme fadedBackgroundWindows not or: [ window isNil or: [ window isActive ] ])
		ifTrue: [ aColor ]
		ifFalse: [ self theme unfocusedSelectionColor ])! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
selectedMorph
	"this doesn't work with the LargeLists patch!!  Use #selectionIndex and #selection instead."
	^self scroller submorphs at: self selectionIndex! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self initForKeystrokes.! !

!PluggableListMorph methodsFor: 'geometry' stamp: ''!
optimalExtent
	"Answer the extent of the list morph."

	^self listMorph extent + (self borderWidth * 2) + self scrollBarThickness! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: ''!
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: 'scrolling' stamp: ''!
hUnadjustedScrollRange
	"Return the entire scrolling range."

	^self listMorph hUnadjustedScrollRange! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
mouseEnter: event
	"Changed to take keyboardFocusOnMouseDown  into account."
	
	super mouseEnter: event.
	self wantsKeyboardFocus ifFalse: [^self].
	self keyboardFocusOnMouseDown
		ifFalse: [self takeKeyboardFocus]! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
getListSizeSelector: aSymbol
	"specify a selector that can be used to specify the list's size"
	getListSizeSelector := aSymbol! !

!PluggableListMorph methodsFor: 'geometry' stamp: ''!
scrollDeltaWidth
"A guess -- assume that the width of a char is approx 1/2 the height of the font"
	^ self scrollDeltaHeight // 2! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
listSelectionAt: index put: value

	self searchedElement: nil.
	setSelectionListSelector ifNil:[^false].
	^model perform: setSelectionListSelector with: index with: value! !

!PluggableListMorph methodsFor: 'configuration' stamp: ''!
enable
	"Enable the receiver."
	
	self enabled: true! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
listItemHeight
	"This should be cleaned up.  The list should get spaced by this parameter."
	^ 12! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
selection 
	self selectionIndex = 0 ifTrue: [ ^nil ].
	list ifNotNil: [ ^list at: self selectionIndex ].
	^ self getListItem: self selectionIndex! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
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 |
	
	aChar := event keyCharacter.

	keystrokeSelector ifNotNil: [ 
		(self keystrokeAction: event) ifTrue: [ ^ self ] ].
	
	^ self basicKeyPressed: aChar! !

!PluggableListMorph methodsFor: 'separator' stamp: ''!
separatorSize: anInteger

	separatorSize := anInteger! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
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: 'scroll cache' stamp: ''!
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: '*FreeType-Morphic' stamp: ''!
setListFont
	"set the font for the list"

	StandardFonts chooseFontWithTitle: 'Choose the font for this list' translated  for: self setSelector: #font:  getSelector: #font! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: ''!
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 "
	self activeHand anyButtonPressed ifFalse: [ ^self ].
			
	draggedItem := self getListItem: (self mouseDownRow ifNil: [ self lastNonZeroIndex ]).
	draggedItem ifNil: [ ^ self ].
	passenger := self model dragPassengersFor: draggedItem inMorph: self.
	passenger ifNil: [ ^ self ].
		
	transferMorph := self model transferFor: passenger from: self.
	transferMorph align: transferMorph draggedMorph bottomLeft  with: evt position.
	
	self mouseDownRow: nil.
	transferMorph dragTransferType: (self model dragTransferTypeForMorph: self).
	
	[evt hand grabMorph: transferMorph ] 
		ensure: [
			Cursor normal show.
			evt hand releaseMouseFocus: self]! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
mouseDownRow
	"Answer the mouse down row or nil if none."

	^self listMorph mouseDownRow! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
mouseUp: evt

	self isMultipleSelection
		ifTrue: [ self mouseUpOnMultiple: evt ]
		ifFalse: [ self mouseUpOnSingle: evt ]! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
setIndexSelector: aSelector

	setIndexSelector := aSelector! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector: aSymbol
	"Set the value of getEnabledSelector"

	getEnabledSelector := aSymbol.
	self updateEnabled! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
isMultipleSelection

	^ self multipleSelection! !

!PluggableListMorph methodsFor: 'scrolling' stamp: ''!
hExtraScrollRange
	"Return the amount of extra blank space to include to the right of the scroll content."
	^5! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
getSelectionListSelector: getListSel

	getSelectionListSelector := getListSel! !

!PluggableListMorph methodsFor: 'searching' stamp: ''!
searchedElement: anInteger

	searchedElement := anInteger.
	anInteger
		ifNil: [
			" just for redrawn "
			self vScrollValue: (self scrollValue y) ]
		ifNotNil: [ self vScrollValue: ((anInteger-1)/self getListSize) ]! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
lastNonZeroIndex

	^ lastNonZeroIndex ifNil: [ lastNonZeroIndex := 0 ]! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
selectionIndex
	"return the index we have currently selected, or 0 if none"
	^self listMorph selectedRow ifNil: [ 0 ]! !

!PluggableListMorph methodsFor: 'events' stamp: ''!
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: 'multi-selection' stamp: ''!
isSingleSelection

	^ self multipleSelection not! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
basicKeyPressed: aChar
	"Return the index of the element matching the keystrokes.
	Returns 0 if nothing found"

	| nextSelection milliSeconds slowKeyStroke oldSelection |
	nextSelection := oldSelection := self getCurrentSelectionIndex.
	milliSeconds := Time millisecondClockValue.
	slowKeyStroke := milliSeconds - lastKeystrokeTime > 500.
	lastKeystrokeTime := milliSeconds.
	self searchedElement: nil.
	lastKeystrokes := slowKeyStroke
		ifTrue: [ aChar asLowercase asString ]
		ifFalse: [ lastKeystrokes , aChar asLowercase asString ].	"forget previous keystrokes and search in following elements"	"append quick keystrokes but don't move selection if it still matches"	"Get rid of blanks and style used in some lists"
	nextSelection := self listForSearching findFirst: [ :a | a beginsWith: lastKeystrokes fromList: self ].
	nextSelection isZero
		ifTrue: [ ^ 0 ].	"No change if model is locked"
	model okToChange
		ifFalse: [ ^ 0 ].	"No change if model is locked"	"The following line is a workaround around the behaviour of OBColumn>>selection:,
	 which deselects when called twice with the same argument."
	oldSelection = nextSelection
		ifTrue: [ ^ 0 ].	"change scrollbarvalue"
	self searchedElement: nextSelection.
	^ nextSelection! !

!PluggableListMorph methodsFor: 'menus' stamp: ''!
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: 'accessing' stamp: ''!
dragItemSelector: aSymbol
	dragItemSelector := aSymbol.
	aSymbol ifNotNil:[self dragEnabled: true].! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
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: 'drag and drop' stamp: ''!
resetPotentialDropRow
	potentialDropRow ifNotNil: [
	potentialDropRow ~= 0 ifTrue: [
		potentialDropRow := 0.
		self changed. ] ]! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
scrollSelectionIntoView
	"make sure that the current selection is visible"
	| row |
	row := self getCurrentSelectionIndex.
	self scrollSelectionToRow: row! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: ''!
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: 'accessing' stamp: ''!
selectionColorToUse
	"Answer the colour to use for selected items."

	^ selectionColorToUse ifNil: [ self theme selectionColor ]! !

!PluggableListMorph methodsFor: 'separator' stamp: ''!
separatorSize

	^ separatorSize ifNil: [ separatorSize := 1 ]! !

!PluggableListMorph methodsFor: 'updating' stamp: ''!
update: aParameter 
	"Refer to the comment in View|update:."

	(aParameter == getListSelector or: [ aParameter == getListElementSelector ]) ifTrue: 
		[self updateList.
		^ self].
	aParameter == getIndexSelector ifTrue:
		[self selectionIndex: self getCurrentSelectionIndex.
		^ self].
	aParameter == #allSelections ifTrue:
		[self selectionIndex: self getCurrentSelectionIndex.
		^ self changed].
	
	aParameter isArray ifFalse: [ ^ self ].
	aParameter size == 2 ifFalse: [ ^ self ].
	
	aParameter first = #setMultipleSelection: ifTrue: [ self setMultipleSelection: aParameter second ]! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
wrapSelector

	^ wrapSelector! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
getListElementSelector

	^ getListElementSelector! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
wrapSelector: aSymbol

	self basicWrapSelector: aSymbol.
	self updateList.! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
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: 'configuration' stamp: ''!
enabled: aBoolean
	"Set the enablement state of the receiver."

	aBoolean = self enabled
		ifFalse: [ enabled :=  aBoolean.
				self adoptPaneColor: self paneColor;
					changed]! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
minimumSelection
	^ 1! !

!PluggableListMorph methodsFor: 'geometry' stamp: ''!
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: 'selection' stamp: ''!
maximumSelection
	^ self getListSize! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
selectionColor
	"Answer the colour to use for selected items."

	^ selectionColor ifNil: [self theme selectionColor]! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
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: ''!
beMultipleSelection

	multipleSelection := true! !

!PluggableListMorph methodsFor: 'scroll cache' stamp: ''!
resetHScrollRange

	hScrollRangeCache := nil.
	self deriveHScrollRange.! !

!PluggableListMorph methodsFor: 'model access' stamp: ''!
keystrokeSelector: aSymbol
	keystrokeSelector := aSymbol! !

!PluggableListMorph methodsFor: 'submorphs - accessing' stamp: ''!
allSubmorphNamesDo: nameBlock
	"Assume list morphs do not have named parts -- saves MUCH time"

	^ self! !

!PluggableListMorph methodsFor: 'model access' stamp: ''!
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: 'background coloring' stamp: ''!
backgroundColoringBlockOrSelector: aSelector

	backgroundColoringBlockOrSelector := aSelector! !

!PluggableListMorph methodsFor: 'selection' stamp: ''!
scrollSelectionToRow: row
	"make sure that the current selection is visible"

	row = 0 ifTrue: [ ^ self ].
	self scrollToShow: (self listMorph drawBoundsForRow: row)! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
textColor
	"Answer my default text color."
	^ self 
		valueOfProperty: #textColor 
		ifAbsent: [ self theme textColor ]! !

!PluggableListMorph methodsFor: 'initialization' stamp: ''!
autoDeselect: trueOrFalse
	"Enable/disable autoDeselect (see class comment)"
	autoDeselect := trueOrFalse.! !

!PluggableListMorph methodsFor: 'scrolling' stamp: ''!
vExtraScrollRange
	"Return the amount of extra blank space to include below the bottom of the scroll content."

	^8! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
dropItemSelector
	^dropItemSelector! !

!PluggableListMorph methodsFor: 'separator' stamp: ''!
separatorColor

	^ separatorColor ifNil: [ separatorColor := Color gray ]! !

!PluggableListMorph methodsFor: 'multi-selection' stamp: ''!
resetListSelector

	^ resetListSelector! !

!PluggableListMorph methodsFor: 'accessing' stamp: ''!
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: 'events' stamp: ''!
navigationKey: anEvent

	self isMultipleSelection
		ifTrue: [ | keyString |
			keyString := anEvent keyString.
			keyString = '<Cmd-a>'
				ifTrue: [ 
					self selectAll.
					^ true ].
			keyString = '<Cmd-A>'
				ifTrue: [ 
					self deselectAll.
					^ true ]	].
				
	^ super navigationKey: anEvent! !

!PluggableListMorph methodsFor: 'updating' stamp: ''!
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: [	self selectionIndex: existingSelection]
		ifFalse:	[self changeModelSelection: 0]! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!PluggableListMorph methodsFor: 'event handling' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
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: ''!
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: ''!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: keyActionSel! !

!PluggableListMorph class methodsFor: 'instance creation' stamp: ''!
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: ''!
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"! !

!PluggableMenuItemSpec commentStamp: ''!
I'm a spec for an item menu. The World menu pragma based registration uses it for now. I'm moved in this package so that later we can decide what to do with it. 
We could probably avoid MenuSpec and just use MenuMorph instead. !
!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
enabledBlock

	^ enabledBlock! !

!PluggableMenuItemSpec methodsFor: '*Morphic-Base' stamp: ''!
morphClass
	^ ToggleMenuItemMorph! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
keyText: aString
	keyText := aString.! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
checked: aBool
	"Indicate whether the receiver is checked"
	checked := aBool.! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
enabled: aBool
	"Indicate whether the receiver is enabled"
	enabled := aBool! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
subMenu: aMenuSpec
	"Answer the receiver's subMenu"
	subMenu := aMenuSpec! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
icon: aForm
	 icon := aForm! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
label
	"Answer the receiver's label"
	^label! !

!PluggableMenuItemSpec methodsFor: '*Spec-Core' stamp: ''!
addToMenuItemModel: aMenuItemModel
	| en newSubMenu |
	en := self enabledBlock ifNil: [ self enabled ].
	newSubMenu := self subMenu
		ifNotNil: [ :sub | MenuPresenter new fromSpec: sub ].
	aMenuItemModel
		name: self label;
		state: self checked;
		enabled: en;
		icon: self icon;
		shortcut: self keyText;
		subMenu: newSubMenu;
		action: self action! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
hasCheckBox	
	^ checked notNil! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
action: aMessageSend
	"Answer the action associated with the receiver"
	action := aMessageSend! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
help
	"Answer the message to get the help texts of this element."
	^ help! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
label: aString
	"Set the receiver's label"
	label := aString! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
checked
	"Answer whether the receiver is checked"
	^checked! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
action
	"Answer the action associated with the receiver"
	^action! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
help: aSymbol 
	"Indicate the message to retrieve the help texts of this element."
	help := aSymbol! !

!PluggableMenuItemSpec methodsFor: '*Morphic-Base' stamp: ''!
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.
	it balloonText: self help.
	(act := self action) ifNotNil: [
				it 
					target: act receiver;
					selector: act selector;
					arguments: act arguments ].
	(menu := self subMenu) ifNotNil: [ self enabled ifTrue: [ it subMenu: (menu asMenuMorphOfKind: parentMenu class) ]].
		
	parentMenu ifNotNil: [ parentMenu addMorphBack: it ].
	aBoolean ifFalse: [ self separator ifTrue: [ parentMenu addLine ] ].
	^it! !

!PluggableMenuItemSpec methodsFor: '*Spec-Core' stamp: ''!
addToMenuGroupModel: aMenuGroupModel

	aMenuGroupModel addItem: [ :item | item fromSpec: self ]! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
separator: aBool
	"Indicate whether the receiver should be followed by a separator"
	separator := aBool.! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
enabled
	"Answer whether the receiver is enabled"
	^ enabledBlock
		ifNil:[enabled ifNil: [ true ]]
		ifNotNil: [ enabledBlock value ]! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
separator
	"Answer whether the receiver should be followed by a separator"
	^separator ifNil:[false]! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
enabledBlock: aBlock

	enabledBlock := aBlock! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
keyText
	^keyText! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: ''!
subMenu
	"Answer the receiver's subMenu"
	^subMenu! !

!PluggableMenuSpec commentStamp: ''!
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 we can decide what to do with it. 
We could probably avoid MenuSpec and just use MenuMorph instead. !
!PluggableMenuSpec methodsFor: 'construction' stamp: ''!
add: aString action: aMessageSend
	| item |
	item := self addMenuItem.
	item label: aString translated.
	item action: aMessageSend.
	^item! !

!PluggableMenuSpec methodsFor: '*Morphic-Base' stamp: ''!
asMenuMorph
	^ self asMenuMorphOfKind: self morphClass! !

!PluggableMenuSpec methodsFor: '*Morphic-Base' stamp: ''!
asMenuMorphOfKind: aMorphClass
	| prior menu myitems |
	prior := parentMenu.
	parentMenu := menu := aMorphClass new.
	self label ifNotNil: [ 
		parentMenu buildTitle: [ :titleMorph | 
			titleMorph bigTitle: self label 
		]
	].
	myitems := self items.
	myitems do: [ :each | each asMenuItemMorphFrom: parentMenu isLast: each = myitems last ].
	parentMenu := prior.
	^ menu! !

!PluggableMenuSpec methodsFor: 'construction' stamp: ''!
add: aString
	^ self add: aString action: nil! !

!PluggableMenuSpec methodsFor: 'accessing' stamp: ''!
label: aString
	label := aString.! !

!PluggableMenuSpec methodsFor: 'construction' stamp: ''!
newMenuItem
	^ PluggableMenuItemSpec new! !

!PluggableMenuSpec methodsFor: '*Spec-Core' stamp: ''!
addToMenuModel: aMenuModel
	| groups tmp |
	
	groups := OrderedCollection new.
	self label ifNotNil: [ aMenuModel title: self label ]. "only change the title when a new one is specified"
	
	tmp := OrderedCollection new.
	self items do: [ :each | 
		tmp add: each.
		each separator
			ifTrue: [ 
				groups add: tmp copy.
				tmp removeAll ] ].
	tmp ifNotEmpty: [ groups add: tmp copy ].
	
	groups do: [ :each | aMenuModel 
		addGroup: [ :group | each do: [ :spec | 
			group addItem: [ :item | item fromSpec: spec ] ] ] ]! !

!PluggableMenuSpec methodsFor: 'construction' stamp: ''!
add: aString target: anObject selector: aSelector argumentList: anArray
	^ self add: aString translated action: (MessageSend receiver: anObject selector: aSelector arguments: anArray)! !

!PluggableMenuSpec methodsFor: '*Morphic-Base' stamp: ''!
buildWith: aBuilder
	^ self asMenuMorph! !

!PluggableMenuSpec methodsFor: '*Morphic-Base' stamp: ''!
morphClass
	^ MenuMorph! !

!PluggableMenuSpec methodsFor: '*Morphic-Widgets-Menubar' stamp: ''!
asMenubarMenuMorph
	^ (self asMenuMorphOfKind: MenubarMenuMorph)
		layoutItems;
		yourself! !

!PluggableMenuSpec methodsFor: 'construction' stamp: ''!
addSeparator
	self items isEmpty
		ifTrue: [ ^ nil ].
	self items last separator: true! !

!PluggableMenuSpec methodsFor: 'construction' stamp: ''!
add: aString selector: aMessageSend
	| item |
	item := self addMenuItem.
	item label: aString translated.
	item action: aMessageSend.
	^item! !

!PluggableMenuSpec methodsFor: 'construction' stamp: ''!
addList: aList
	"Add the given items to this menu, where each item is a pair (<string> <actionSelector>).  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: ''!
addMenuItem
	| item |
	item := self newMenuItem.
	self items add: item.
	^item! !

!PluggableMenuSpec methodsFor: 'accessing' stamp: ''!
model: anObject 
	model := anObject! !

!PluggableMenuSpec methodsFor: 'accessing' stamp: ''!
items
	^ items ifNil: [ items := OrderedCollection new ]! !

!PluggableMenuSpec methodsFor: 'construction' stamp: ''!
add: aString selector: aSelector argumentList: anArray
	^ self add: aString action: (MessageSend receiver: model selector: aSelector arguments: anArray)! !

!PluggableMenuSpec methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!PluggableMenuSpec methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!PluggableMenuSpec class methodsFor: '*Morphic-Base-Examples' stamp: ''!
exampleWithTwoSimpleItems
	"self exampleWithTwoSimpleItems"

	| s |
	s := (self withModel: Object) label: 'Hello'.
	s
		add: 'Print Hello'
		action: (MessageSend receiver: [ self traceCr: 'Hello' ] selector: #value).
	s
		add: 'Print Hello again'
		selector: #trace:
		argumentList: {('Hello again' , String cr)}.
	s asMenuMorph popUpInWorld! !

!PluggableMenuSpec class methodsFor: '*Morphic-Base-Examples' stamp: ''!
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: '*Morphic-Base-Examples' stamp: ''!
exampleWithOneSingleItem
	"self exampleWithOneSingleItem"

	| s |
	s := (self withModel: nil) label: 'Hello'.
	s
		add: 'Print Hello'
		action: (MessageSend receiver: [ self traceCr: 'Hello' ] selector: #value).
	s asMenuMorph popUpInWorld! !

!PluggableMenuSpec class methodsFor: 'instance creation' stamp: ''!
withModel: aModel
	^ self new model: aModel! !

!PluggableMorphListMorph commentStamp: ''!
A type of PluggableListMorph that supports morphs for items. Useful for lists with icons etc.!
!PluggableMorphListMorph methodsFor: 'initialization' stamp: ''!
listMorphClass
	"Answer the class to use for the list morph."

	^LazyMorphListMorph! !

!PluggableMorphListMorph methodsFor: 'model access' stamp: ''!
getList

	"Answer the list to be displayed.  Caches the returned list in the 'list' ivar"

	getListSelector ifNil: [ ^ #() ].
	list := model perform: getListSelector.
	list ifNil: [ ^ #() ].
	^ list! !

!PluggableMorphListMorph methodsFor: 'geometry' stamp: ''!
extent: newExtent
	"Change listMorph's bounds to the new width. It is either the size
	of the widest list item, or the size of self, whatever is bigger"

	super extent: newExtent.
	self listMorph width: (self innerBounds width max: listMorph hUnadjustedScrollRange).! !

!PluggableMorphListMorph methodsFor: 'scrolling' stamp: ''!
hExtraScrollRange
	"Return the amount of extra blank space to include to the right of the scroll content."

	^12! !

!PluggableMultiColumnListMorph commentStamp: ''!
This morph can be used to show a list having multiple columns,  The columns are self width sized to make the largest entry in each list fit.  In some cases the pane may then be too narrow.

Use it like a regular PluggableListMorph except pass in an array of lists instead of a single list.

There are base assumptions made here that each list in the array of lists is the same size.

Also, the highlight color for the selection is easy to modify in the #highlightSelection method.  I used blue
when testing just to see it work.!
!PluggableMultiColumnListMorph methodsFor: 'model access' stamp: ''!
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: 'accessing' stamp: ''!
gapSize: anInteger

	gapSize := anInteger.! !

!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: ''!
listMorphClass
	^MulticolumnLazyListMorph! !

!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: ''!
findSubmorphFor: ptY
	^ scroller submorphThat: [ :item | ptY between: item top and: item bottom ] ifNone: [  ]! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: ''!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel  wrapSelector: wrapSel
	self model: anObject.
	getListSelector := getListSel.
	getIndexSelector := getSelectionSel.
	setIndexSelector := setSelectionSel.
	getMenuSelector := getMenuSel.
	keystrokeActionSelector := keyActionSel.
	wrapSelector := wrapSel.
	self autoDeselect: true.
	self borderWidth: 1.
	self updateList.
	self selectionIndex: self getCurrentSelectionIndex.
	self initForKeystrokes! !

!PluggableMultiColumnListMorph methodsFor: 'searching' stamp: ''!
listForSearching

	^ super listForSearching collect: [:each | each first ]! !

!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: ''!
getListSize
	| l |
	getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ].

	l := self getList.
	l isEmpty ifTrue: [ ^ 0 ].
	^l size! !

!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: ''!
gapSize

	^ gapSize ifNil: [ gapSize := 10 ]! !

!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: ''!
getListRow: row
	"return the strings that should appear in the requested row"
	getListElementSelector ifNotNil: [ ^model perform: getListElementSelector with: row ].
	^self getList at: row! !

!PluggableMultiColumnListMorph class methodsFor: 'instance creation' stamp: ''!
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: ''!
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! !

!PluggableSet commentStamp: ''!
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	<BlockContext>	A one argument block used for hashing the elements.
	equalBlock	<BlockContext>	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: 'private' stamp: ''!
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 methodsFor: 'accessing' stamp: ''!
equalBlock
	"Return the block used for comparing the elements in the receiver."
	^equalBlock! !

!PluggableSet methodsFor: 'copying' stamp: ''!
copyEmpty
	^super copyEmpty
		hashBlock: hashBlock;
		equalBlock: equalBlock! !

!PluggableSet methodsFor: 'accessing' stamp: ''!
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: ''!
hashBlock
	"Return the block used for hashing the elements in the receiver."
	^hashBlock! !

!PluggableSet methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
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 enclosedElement = anObject] ifNotNil: [ 
				equalBlock value: element enclosedElement value: anObject ]])
			ifTrue: [ ^index ].
		(index := index \\ array size + 1) = start ] whileFalse.
	self errorNoFreeSpace! !

!PluggableSet class methodsFor: 'accessing' stamp: ''!
integerSet
	^self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! !

!PluggableSetTest commentStamp: ''!
SUnit tests for pluggable sets!
!PluggableSetTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ PluggableSet! !

!PluggableSetTest class methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ IdentitySet! !

!PluggableSliderMorph commentStamp: ''!
A pluggable slider (rather than one that auto-generates access selectors). Needs to be themed...!
!PluggableSliderMorph methodsFor: 'drawing' stamp: ''!
labelGap
	
	^ 2! !

!PluggableSliderMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas

	super drawOn: aCanvas.
	aCanvas 
		drawString: self label
		in: self labelBounds
		font: self font
		color: self fontColor.! !

!PluggableSliderMorph methodsFor: 'drawing' stamp: ''!
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.
	deltaX := (slider left < treshold or: [ sliderShadow visible and: [ sliderShadow left < treshold ] ])
		ifTrue: [ bnd width - self labelGap - labelWidth ]
		ifFalse: [ self labelGap ].
	^ bnd translateBy: deltaX @ deltaY! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
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: 'drawing' stamp: ''!
font

	^ StandardFonts defaultFont! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
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: 'protocol' stamp: ''!
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: ''!
update: aParameter

	aParameter = getEnabledSelector 		ifTrue: [ ^ self updateEnabled ].
	aParameter = getValueSelector 		ifTrue: [ ^ self updateValue ].
	aParameter = getLabelSelector 		ifTrue: [ ^ self updateLabel ].
			
	aParameter isArray ifFalse: [ ^ self ].
	aParameter size == 2 ifFalse: [ ^ self ].
	
	aParameter first = #max: ifTrue: [ self max: aParameter second ].
	aParameter first = #min: ifTrue: [ self min: aParameter second ].
	aParameter first = #quantum: ifTrue: [ self quantum: aParameter second ].
	aParameter first = #scaledValue: ifTrue: [ self scaledValue: aParameter second ].
	aParameter first = #value: ifTrue: [ self value: aParameter second ].! !

!PluggableSliderMorph methodsFor: 'protocol' stamp: ''!
updateLabel
	"Update the label."
	
	self model ifNotNil: [:m |
		self getLabelSelector ifNotNil: [:selector | 
			self label: (m perform: selector) ]]! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
min: anObject
	"Set the value of min"

	min := anObject.
	self setValue: self value! !

!PluggableSliderMorph methodsFor: 'instance creation' stamp: ''!
on: anObject getValue: getSel setValue: setSel
	"Use the given selectors as the interface."

	self
		model: anObject;
		getValueSelector: getSel;
		setValueSelector: setSel;
		updateValue! !

!PluggableSliderMorph methodsFor: 'protocol' stamp: ''!
updateEnabled
	"Update the enablement state."

	self model ifNotNil: [:m | 
		self getEnabledSelector ifNotNil: [:s |
			self enabled: (m perform: s)]]! !

!PluggableSliderMorph methodsFor: 'scrolling' stamp: ''!
scrollAbsolute: event
	"Ignore if disabled."
	
	self enabled ifFalse: [^self].
	super scrollAbsolute: event.
	"label or label position may change"
	self updateLabel.! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
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: 'drawing' stamp: ''!
fontColor

	^ self theme textColor! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
getLabelSelector

	^ getLabelSelector! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
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: ''!
getValueSelector
	"Answer the value of getValueSelector"

	^ getValueSelector! !

!PluggableSliderMorph methodsFor: 'model access' stamp: ''!
setValue: newValue
	"Called internally for propagation to model."

	|scaled|
	"First, set the value"
	value := newValue.
	"Second, scaledValue gets the scaled-value based on the value"
	scaled := self scaledValue.
	"Third, setting the scaled value, sets the value based on quantum steps (if needed)"
	self scaledValue: scaled.
	"Propagate throught the model"
	self model ifNotNil: [
		self setValueSelector ifNotNil: [:sel |
			self model perform: sel with: scaled ]]! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
label

	^ label! !

!PluggableSliderMorph methodsFor: 'event handling' stamp: ''!
scrollPoint: event
	"Scroll to the event position."
	
	| r p |
	r := self roomToMove.
	bounds isWide
		ifTrue: [r width = 0 ifTrue: [^ self]]
		ifFalse: [r height = 0 ifTrue: [^ self]].
	p := event position - (self sliderThickness // 2) adhereTo: r.
	self descending
		ifFalse:
			[self setValue: (bounds isWide 
				ifTrue: [(p x - r left) asFloat / r width]
				ifFalse: [(p y - r top) asFloat / r height])]
		ifTrue:
			[self setValue: (bounds isWide
				ifTrue: [(r right - p x) asFloat / r width]
				ifFalse:	[(r bottom - p y) asFloat / r height])]! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
max: anObject
	"Set the value of max"

	max := anObject.
	self setValue: self value! !

!PluggableSliderMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: aCanvas 

	super drawOnAthensCanvas: aCanvas.
	aCanvas 
		morphicDrawString: self label
		in: self labelBounds
		font: self font
		color: self fontColor.! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
setValueSelector
	"Answer the set selector."
	
	^setValueSelector! !

!PluggableSliderMorph methodsFor: 'other events' stamp: ''!
mouseDownInSlider: event
	"Ignore if disabled."
	
	self enabled ifFalse: [^self].
	^super mouseDownInSlider: event! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
getValueSelector: anObject
	"Set the value of getValueSelector"

	getValueSelector := anObject! !

!PluggableSliderMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	min := 0.
	max := 1.
	label := ''.
	super initialize.
	self enabled: true! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
label: aLabel

	label := aLabel.
	self changed.! !

!PluggableSliderMorph methodsFor: 'protocol' stamp: ''!
updateValue
	"Update the value."
	
	self model ifNotNil: [:m |
		self getValueSelector ifNotNil: [:s |
			self scaledValue: (m perform: s)]]! !

!PluggableSliderMorph methodsFor: 'protocol' stamp: ''!
disable
	"Disable the receiver."
	
	self enabled: false! !

!PluggableSliderMorph methodsFor: 'protocol' stamp: ''!
enable
	"Enable the receiver."
	
	self enabled: true! !

!PluggableSliderMorph methodsFor: 'layout' stamp: ''!
layoutBounds: aRectangle
	"Set the bounds for laying out children of the receiver.
	Note: written so that #layoutBounds can be changed without touching this method"
	
	super layoutBounds: aRectangle.
	self computeSlider! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
sliderColor: newColor
	"Set the slider colour."
	
	super sliderColor: newColor.
	slider ifNotNil: [slider borderStyle baseColor: newColor]! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
min
	"Answer the value of min"

	^ min! !

!PluggableSliderMorph methodsFor: 'initialization' stamp: ''!
initializeSlider
	"Make the slider raised."
	
	super initializeSlider.
	slider borderStyle: (BorderStyle raised baseColor: slider color; width: 1)! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
enabled
	"Answer the value of enabled"

	^ enabled! !

!PluggableSliderMorph methodsFor: 'event handling' stamp: ''!
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: 'accessing' stamp: ''!
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: 'other events' stamp: ''!
mouseUpInSlider: event 

	super mouseUpInSlider: event.
	"label or label position may change"
	self updateLabel.! !

!PluggableSliderMorph methodsFor: 'layout' stamp: ''!
minHeight
	"Answer the receiver's minimum height.
	Give it a bit of a chance..."
	
	^8 max: super minHeight! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector
	"Answer the value of getEnabledSelector"

	^ getEnabledSelector! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
quantum
	"Answer the value of quantum"

	^ quantum! !

!PluggableSliderMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"Answer the default color/fill style for the receiver."
	
	^Color white! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector: aSymbol
	"Set the value of getEnabledSelector"

	getEnabledSelector := aSymbol.
	self updateEnabled! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
getLabelSelector: aSymbol

	getLabelSelector := aSymbol.
	self updateLabel! !

!PluggableSliderMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	"Answer true." 

	^true! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
quantum: anObject
	"Set the value of quantum"

	quantum := anObject.
	self setValue: self value! !

!PluggableSliderMorph methodsFor: 'accessing' stamp: ''!
max
	"Answer the value of max"

	^ max! !

!PluggableSliderMorph class methodsFor: 'instance creation' stamp: ''!
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: 'instance creation' stamp: ''!
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! !

!PluggableTabButtonMorph commentStamp: ''!
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: 'accessing' stamp: ''!
textSelector
	^ textSelector! !

!PluggableTabButtonMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	self drawTabOn: aCanvas.
	self drawSubMorphOn: aCanvas! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: ''!
subMorph
	subMorph ifNil: [ self update: self textSelector ].
	^ subMorph! !

!PluggableTabButtonMorph methodsFor: 'actions' stamp: ''!
toggle
	self active: self active not! !

!PluggableTabButtonMorph methodsFor: 'stepping' stamp: ''!
step
	self subMorph step.
	self changed.! !

!PluggableTabButtonMorph methodsFor: 'updating' stamp: ''!
update: aSelector
	self textSelector
		ifNotNil: [ 
			aSelector = self textSelector
				ifTrue: [ 
					| morph |
					morph := (aSelector isSymbol and: [ model notNil ])
						ifTrue: [ (self model perform: aSelector) asMorph ]
						ifFalse: [ aSelector value asMorph ].
					self subMorph: morph ] ].
	self changed! !

!PluggableTabButtonMorph methodsFor: 'drawing' stamp: ''!
drawTabOn: aCanvas
	| top myColor cornerRadius myArcLengths myBounds |
	cornerRadius := self cornerRadius.
	myBounds := self bounds.
	self active
		ifTrue: [ top := myBounds top.
			myColor := self color ]
		ifFalse: [ top := myBounds top + self topInactiveGap.
			myColor := self color whiter whiter ].
	aCanvas fillRectangle:
		((myBounds left + cornerRadius)
				@ (top + cornerRadius)
			corner: (myBounds right - cornerRadius)
						@ self bottom)
		color: myColor.
	aCanvas fillRectangle:
		((myBounds left + (cornerRadius * 2)) @ top
			corner: (myBounds right - (cornerRadius * 2))
				@ (top + cornerRadius))
		color: myColor.
	aCanvas fillOval:
		((myBounds left + self cornerRadius) @ top
			corner: (myBounds left + (self cornerRadius * 3))
				@ (top + (self cornerRadius * 2)))
		color: myColor.
	aCanvas fillOval:
		((myBounds right - (self cornerRadius * 3)) @ top
			corner: (myBounds right - self cornerRadius)
				@ (top + (self cornerRadius * 2)))
		color: myColor.

	myArcLengths := self arcLengths.
	1 to: myArcLengths size do: [ :i | | length |
		length := myArcLengths at: i.
		aCanvas line: (myBounds left + cornerRadius - i) @ (myBounds bottom - 1 )
			to: (myBounds left + cornerRadius - i) @ (myBounds bottom - length - 1)
			color: myColor.
		aCanvas line: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - 1)
			to: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - length - 1)
			color: myColor]! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: ''!
arcLengths: anArrayOfIntegers
	arcLengths := anArrayOfIntegers! !

!PluggableTabButtonMorph methodsFor: 'event' stamp: ''!
keyDown: event

	(self navigationKey: event) ifTrue: [^self].
	super keyDown: event! !

!PluggableTabButtonMorph methodsFor: 'precalculations' stamp: ''!
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: 'accessing' stamp: ''!
textSelector: aSymbol
	textSelector := aSymbol! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: ''!
topInactiveGap
	^ 5! !

!PluggableTabButtonMorph methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!PluggableTabButtonMorph methodsFor: 'stepping' stamp: ''!
stepTime
	^ self subMorph stepTime! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: ''!
arcLengths
	arcLengths ifNil: [ self calculateArcLengths ].
	^ arcLengths! !

!PluggableTabButtonMorph methodsFor: 'drawing' stamp: ''!
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: 'event' stamp: ''!
handlesKeyboard: evt
	"Yes, we do it here."
	
	^true! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: ''!
subMorph: aMorph
	subMorph := aMorph! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: ''!
cornerRadius
	^ 5! !

!PluggableTabButtonMorph methodsFor: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher

	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #MorphFocusNavigation! !

!PluggableTabButtonMorph methodsFor: 'accessing' stamp: ''!
active: aBoolean
	active := aBoolean.
	self changed.! !

!PluggableTabButtonMorph methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!PluggableTabButtonMorph methodsFor: 'accessing' stamp: ''!
outerGap
	"The horizontal distance of the outer left and right edges of the tab excluding the inner visible part"
	^ self cornerRadius * 2! !

!PluggableTabButtonMorph methodsFor: 'accessing' stamp: ''!
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: 'stepping' stamp: ''!
wantsSteps
	^ self subMorph wantsSteps! !

!PluggableTabButtonMorph methodsFor: 'accessing' stamp: ''!
active
	active ifNil: [ active := false ].
	^ active! !

!PluggableTabButtonMorph methodsFor: 'event' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!PluggableTabButtonMorph class methodsFor: 'instance creation' stamp: ''!
on: anObject label: getTextSelector
	^self new
	      model: anObject;
		textSelector: getTextSelector;
		yourself.! !

!PluggableTextAttribute commentStamp: ''!
An attribute which evaluates an arbitrary block when it is selected.!
!PluggableTextAttribute methodsFor: 'evaluating' stamp: ''!
actOnClick: anEvent for: anObject in: paragraph editor: editor

	evalBlock ifNil: [ ^self ].
	evalBlock numArgs = 0 ifTrue: [ evalBlock value.  ^true ].
	evalBlock numArgs = 1 ifTrue: [ evalBlock value: anObject.  ^true ].
	self error: 'evalBlock should have 0 or 1 arguments'! !

!PluggableTextAttribute methodsFor: 'accessing' stamp: ''!
evalBlock: aBlock
	evalBlock := aBlock! !

!PluggableTextAttribute class methodsFor: 'instance creation' stamp: ''!
evalBlock: aBlock
	^super new evalBlock: aBlock! !

!PluggableThreePhaseButtonMorph commentStamp: ''!
A PluggableThreePhaseButtonMorph is an extesion of ThreePhaseButtonMorph to make it pluggable

Then a model can be defined, and queried for state, on image, off image and pressed image.!
!PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
pressedImageSelector

	^ pressedImageSelector! !

!PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: ''!
updateOnImage

	self onImage: ( target perform: onImageSelector )! !

!PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
stateSelector: anObject 

	stateSelector := anObject! !

!PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: ''!
update: aSymbol

	aSymbol == stateSelector
		ifTrue: [ ^ self updateState ].
	aSymbol == onImageSelector
		ifTrue: [ ^ self updateOnImage ].
	aSymbol == offImageSelector
		ifTrue: [ ^ self updateOffImage ].
	aSymbol == pressedImageSelector
		ifTrue: [ ^ self updatePressedImage ].
				
	^ super update: aSymbol! !

!PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
offImageSelector

	^ offImageSelector! !

!PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: ''!
updateOffImage

	self offImage: ( target perform: offImageSelector )! !

!PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: ''!
updatePressedImage

	self pressedImage: ( target perform: pressedImageSelector )! !

!PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: ''!
updateState

	( target perform: stateSelector )
		ifTrue: [ self state: #on ]
		ifFalse:[ self state: #off ]! !

!PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
onImageSelector: anObject 

	onImageSelector := anObject! !

!PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
pressedImageSelector: anObject 

	pressedImageSelector := anObject! !

!PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
stateSelector

	^ stateSelector! !

!PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
offImageSelector: anObject 

	offImageSelector := anObject! !

!PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
onImageSelector

	^ onImageSelector! !

!PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
target: anObject

	target ifNotNil: [ target removeDependent: self ].
	anObject ifNotNil: [ anObject addDependent: self ].
	target := anObject.! !

!PluggableThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: ''!
on: aModel

	^ self new 
			target: aModel;
			yourself! !

!PluggableToggleButtonMorph commentStamp: ''!
I'm a pluggable togglable button. 
I extend a pluggable button in a very simple way:  I keep two states, PRESSED, and UNPRESSED (in fact, is just a boolean).

I override a couple of methods, like #getModelState because in my context it does not have sense. 

See PluggableToggleButtonMorphExample to have some usage hints. 

Example:
========
(This is very simple and probably you want to use as is shown in the examples)

PluggableToggleButtonMorph new 
	icon: Smalltalk ui icons smallOkIcon;
	label: 'Test';
	actionBlock: [ :pressed | self inform: 'Status: ', (pressed asString) ];
	openInWindow
	
!
!PluggableToggleButtonMorph methodsFor: 'initialization' stamp: ''!
initialize 
	pressed := false.
	super initialize! !

!PluggableToggleButtonMorph methodsFor: 'testing' stamp: ''!
isPressed
	^ pressed! !

!PluggableToggleButtonMorph methodsFor: 'accessing' stamp: ''!
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]].
	
	"Toggle pressed"
	self pressed: self isPressed not.
	
	self actionBlock ifNotNil: [ ^ self actionBlock cull: self isPressed cull: event ].
	actionSelector ifNil: [ ^ self ].
	
	arguments := argumentsProvider 
		ifNotNil: [ argumentsProvider perform: argumentsSelector ]
		ifNil: [ #() ].
	model 
		perform: actionSelector 
		withArguments: (arguments copyWithFirst: self isPressed)! !

!PluggableToggleButtonMorph methodsFor: 'accessing' stamp: ''!
on: anObject getState: getStateSel action: actionSel label: labelSel icon: iconSel menu: menuSel
	"Set up the pluggable parameters.
	Update label and state."

	super
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		icon: iconSel
		menu: menuSel.
	self pressed: super getModelState! !

!PluggableToggleButtonMorph methodsFor: 'accessing' stamp: ''!
icon
	| originalIcon |
	originalIcon := super icon.
	originalIcon ifNil: [ ^ originalIcon ].
	^ self isPressed 
		ifTrue: [ (originalIcon asFormOfDepth: 32) dimmed ]
		ifFalse: [ originalIcon ]! !

!PluggableToggleButtonMorph methodsFor: 'accessing' stamp: ''!
bePressed
	self pressed: true! !

!PluggableToggleButtonMorph methodsFor: 'private' stamp: ''!
pressed: aBoolean
	pressed := aBoolean.
	self update: (getLabelSelector ifNil: [ getIconSelector ])! !

!PluggableToggleButtonMorphExample commentStamp: ''!
I keep some examples on how to use a PluggableToggleButtonMorph!
!PluggableToggleButtonMorphExample methodsFor: 'building' stamp: ''!
buildToggleButtonNoLabel
	^ PluggableToggleButtonMorph
		on: self 
		getState: nil
		action:  #toggleAction:
		label: nil 
		icon: #icon
		menu: nil.! !

!PluggableToggleButtonMorphExample methodsFor: 'building' stamp: ''!
buildToggleButton
	^ PluggableToggleButtonMorph
		on: self 
		getState: nil
		action:  #toggleAction:
		label: #label 
		menu: nil.! !

!PluggableToggleButtonMorphExample methodsFor: 'actions' stamp: ''!
toggleAction: aBoolean
	self inform: (aBoolean
		ifTrue: [ 'Button pressed' ]
		ifFalse: [ 'Button unpressed' ])! !

!PluggableToggleButtonMorphExample methodsFor: 'building' stamp: ''!
buildToggleButtonWithIcon
	^ PluggableToggleButtonMorph
		on: self 
		getState: nil
		action:  #toggleAction:
		label: #label 
		icon: #icon
		menu: nil.! !

!PluggableToggleButtonMorphExample class methodsFor: 'examples' stamp: ''!
exampleToggleButton
	<sampleInstance>
	<example>
	^ self new buildToggleButton openInWindow! !

!PluggableToggleButtonMorphExample class methodsFor: 'examples' stamp: ''!
exampleToggleButtonWithIcon
	<sampleInstance>
	<example>
	^ self new buildToggleButtonWithIcon openInWindow! !

!PluggableToggleButtonMorphExample class methodsFor: 'examples' stamp: ''!
exampleToggleButtonNoLabel
	<sampleInstance>
	<example>
	^ self new buildToggleButtonNoLabel openInWindow! !

!PluggableTreeItemNode commentStamp: ''!
Tree item for PluggableTreeMorph.!
!PluggableTreeItemNode methodsFor: 'accessing' stamp: ''!
hasContents
	^model hasNodeContents: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: ''!
balloonText
	^model balloonTextForNode: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: ''!
wantsDroppedObject: anotherItem
	^model wantsDroppedNode: anotherItem on: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: ''!
canBeDragged
	^model isDraggableNode: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: ''!
asString
	^model printNode: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: ''!
icon
	^model iconOfNode: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: ''!
contents
	^model contentsOfNode: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: ''!
acceptDroppingObject: anotherItem
	^model dropNode: anotherItem on: self! !

!PluggableTreeMorph commentStamp: ''!
A pluggable tree morph.!
!PluggableTreeMorph methodsFor: 'node access' stamp: ''!
contentsOfNode: node
	| children |
	getChildrenSelector ifNil:[^#()].
	children := model perform: getChildrenSelector with: node item.
	^children collect:[:item| PluggableTreeItemNode with: item model: self]! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getChildrenSelector: aSymbol
	getChildrenSelector := aSymbol.! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getHelpSelector
	^getHelpSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
dragItemSelector: aSymbol
	dragItemSelector := aSymbol.
	aSymbol ifNotNil:[self dragEnabled: true].! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getRootsSelector
	^getRootsSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getRootsSelector: aSelector
	getRootsSelector := aSelector.
	self update: getRootsSelector.! !

!PluggableTreeMorph methodsFor: 'selection' stamp: ''!
setSelectedMorph: aMorph
	selectedWrapper := aMorph complexContents.
	self selection: selectedWrapper.
	setSelectionSelector ifNotNil:[
		model 
			perform: setSelectionSelector 
			with: (selectedWrapper ifNotNil:[selectedWrapper item]).
	].! !

!PluggableTreeMorph methodsFor: 'updating' stamp: ''!
update: what
	what ifNil:[^self].
	what == getRootsSelector ifTrue:[
		self roots: (model perform: getRootsSelector)
	].
	what == getSelectedPathSelector ifTrue:[
		^self selectPath: (model perform: getSelectedPathSelector)
			in: (scroller submorphs at: 1 ifAbsent: [^self]) 
	].
	^super update: what! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
wantsDropSelector
	^wantsDropSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getIconSelector
	^getIconSelector! !

!PluggableTreeMorph methodsFor: 'node access' stamp: ''!
wantsDroppedNode: srcNode on: dstNode
	dropItemSelector ifNil:[^false].
	wantsDropSelector ifNil:[^true].
	^(model perform: wantsDropSelector with: srcNode with: dstNode) == true! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getChildrenSelector
	^getChildrenSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
setSelectedSelector: aSymbol
	setSelectionSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'node access' stamp: ''!
iconOfNode: node
	getIconSelector ifNil:[^nil].
	^model perform: getIconSelector with: node item! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
hasChildrenSelector
	^hasChildrenSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getIconSelector: aSymbol
	getIconSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getLabelSelector
	^getLabelSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
dropItemSelector: aSymbol
	dropItemSelector := aSymbol.
	aSymbol ifNotNil:[self dropEnabled: true].! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
roots
	^roots! !

!PluggableTreeMorph methodsFor: 'node access' stamp: ''!
balloonTextForNode: node
	getHelpSelector ifNil:[^nil].
	^model perform: getHelpSelector with: node item! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
setSelectedSelector
	^setSelectionSelector! !

!PluggableTreeMorph methodsFor: 'morphic' stamp: ''!
acceptDroppingMorph: aMorph event: evt
	| item dropTarget |

	dropItemSelector 
		ifNil:[
			model 
				acceptDroppingMorph: aMorph 
				event: evt 
				inMorph: self ]
		ifNotNil: [
			item := aMorph passenger.
			dropTarget := (self itemFromPoint: evt position) withoutListWrapper.
			model perform: dropItemSelector with: item with: dropTarget ].
		
	evt hand releaseMouseFocus: self.
	Cursor normal show.! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getHelpSelector: aSymbol
	getHelpSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
wantsDropSelector: aSymbol
	wantsDropSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'node access' stamp: ''!
dropNode: srcNode on: dstNode
	dropItemSelector ifNil:[^nil].
	model perform: dropItemSelector with: srcNode item with: dstNode item! !

!PluggableTreeMorph methodsFor: 'updating' stamp: ''!
selectPath: path in: listItem
	path isEmpty ifTrue: [^self setSelectedMorph: nil].
	listItem withSiblingsDo: [:each | 
		(each complexContents item = path first) ifTrue: [
			each isExpanded ifFalse: [
				each toggleExpandedState.
				self adjustSubmorphPositions.
			].
			each changed.
			path size = 1 ifTrue: [
				^self setSelectedMorph: each
			].
			each firstChild ifNil: [^self setSelectedMorph: nil].
			^self selectPath: path allButFirst in: each firstChild
		].
	].
	^self setSelectedMorph: nil! !

!PluggableTreeMorph methodsFor: 'node access' stamp: ''!
isDraggableNode: node
	^true! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
dropItemSelector
	^dropItemSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getSelectedPathSelector
	^getSelectedPathSelector! !

!PluggableTreeMorph methodsFor: 'node access' stamp: ''!
hasNodeContents: node
	hasChildrenSelector ifNil: [ ^ node contents isNotEmpty ].
	^ model perform: hasChildrenSelector with: node item! !

!PluggableTreeMorph methodsFor: 'morphic' stamp: ''!
startDrag: anEvent 
	| aTransferMorph itemMorph passenger |
	
	self dragEnabled
		ifTrue: [itemMorph := scroller submorphs
						detect: [:any | any highlightedForMouseDown]
						ifNone: []].
	(itemMorph isNil
			or: [anEvent hand hasSubmorphs])
		ifTrue: [^ self].
	itemMorph highlightForMouseDown: false.
	itemMorph ~= self selectedMorph
		ifTrue: [self setSelectedMorph: itemMorph].
		
	passenger := dragItemSelector
		ifNil: [ self model
			dragPassengerFor: itemMorph withoutListWrapper 
			inMorph: self ]
		ifNotNil: [
			self model 
				perform: dragItemSelector 
				withEnoughArguments: { itemMorph withoutListWrapper. self } ].
			
	passenger
		ifNotNil: [aTransferMorph := self model transferFor: passenger from: self.
			aTransferMorph dragTransferType: #dragTransfer.
			aTransferMorph align: aTransferMorph draggedMorph center with: anEvent position.
			anEvent hand grabMorph: aTransferMorph].
	anEvent hand releaseMouseFocus: self! !

!PluggableTreeMorph methodsFor: 'node access' stamp: ''!
printNode: node
	getLabelSelector ifNil:[^node item printString].
	^model perform: getLabelSelector with: node item! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getLabelSelector: aSymbol
	getLabelSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
dragItemSelector
	^dragItemSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
getSelectedPathSelector: aSymbol
	getSelectedPathSelector := aSymbol.! !

!PluggableTreeMorph methodsFor: 'morphic' stamp: ''!
wantsDroppedMorph: aMorph event: anEvent
	
	aMorph dragTransferType == #dragTransfer ifFalse: [ ^ false ].
	
	^ wantsDropSelector 
		ifNil: [ model
			wantsDroppedMorph: aMorph 
			event: anEvent 
			inMorph: self ]
		ifNotNil: [
			model 
				perform: wantsDropSelector 
				with: aMorph passenger ]! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
roots: anArray
	roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self].
	self list: roots.! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: ''!
hasChildrenSelector: aSymbol
	hasChildrenSelector := aSymbol! !

!PluginBasedJPEGReadWriter commentStamp: ''!
I am PluginBasedJPEGReadWriter.
I am a concrete subclass of ImageReadWriter.

I implement the JPEG image format.

  https://en.wikipedia.org/wiki/JPEG

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: 'public access' stamp: ''!
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: 'primitives' stamp: ''!
primJPEGDecompressStructSize

	<primitive: 'primJPEGDecompressStructSize' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed! !

!PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: ''!
primJPEGReadImage: aJPEGDecompressStruct fromByteArray: source onForm: form doDithering: ditherFlag errorMgr: aJPEGErrorMgr2Struct

	<primitive: 'primJPEGReadImagefromByteArrayonFormdoDitheringerrorMgr' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed! !

!PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: ''!
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: ''!
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: ''!
nextImage
	"Decode and answer a Form from my stream."

	^ self nextImageSuggestedDepth: Display depth! !

!PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: ''!
nextPutImage: aForm
	"Encode the given Form on my stream with default quality."

	^ self nextPutImage: aForm quality: -1 progressiveJPEG: false! !

!PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: ''!
primImageWidth: aJPEGCompressStruct

	<primitive: 'primImageWidth' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed! !

!PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: ''!
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: 'testing' stamp: ''!
isPluginPresent
	^self primJPEGPluginIsPresent! !

!PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: ''!
nextPutImage: aForm quality: quality progressiveJPEG: progressiveFlag 
	"Encode the given Form on my stream with the given settings. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG."
	| sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount |
	aForm unhibernate.
	"odd width images of depth 16 give problems; avoid them."
	sourceForm := aForm depth = 32 | (aForm width even & (aForm depth = 16)) 
		ifTrue: [ aForm ]
		ifFalse: [ aForm asFormOfDepth: 32 ].
	jpegCompressStruct := ByteArray new: self primJPEGCompressStructSize.
	jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize.
	buffer := ByteArray new: sourceForm width * sourceForm height + 1024.
	byteCount := self 
		primJPEGWriteImage: jpegCompressStruct
		onByteArray: buffer
		form: sourceForm
		quality: quality
		progressiveJPEG: progressiveFlag
		errorMgr: jpegErrorMgr2Struct.
	byteCount = 0 ifTrue: [ self error: 'buffer too small for compressed data' ].
	stream 
		next: byteCount
		putAll: buffer
		startingAt: 1.
	self close! !

!PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: ''!
primJPEGCompressStructSize

	<primitive: 'primJPEGCompressStructSize' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed! !

!PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: ''!
primJPEGReadHeader: aJPEGDecompressStruct fromByteArray: source errorMgr: aJPEGErrorMgr2Struct

	<primitive: 'primJPEGReadHeaderfromByteArrayerrorMgr' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed! !

!PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: ''!
primJPEGWriteImage: aJPEGCompressStruct onByteArray: destination form: form quality: quality progressiveJPEG: progressiveFlag errorMgr: aJPEGErrorMgr2Struct

	<primitive: 'primJPEGWriteImageonByteArrayformqualityprogressiveJPEGerrorMgr' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed! !

!PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: ''!
primJPEGErrorMgr2StructSize

	<primitive: 'primJPEGErrorMgr2StructSize' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed! !

!PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: ''!
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: 'primitives' stamp: ''!
primImageHeight: aJPEGCompressStruct

	<primitive: 'primImageHeight' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed! !

!PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: ''!
primJPEGPluginIsPresent
	<primitive: 'primJPEGPluginIsPresent' module: 'JPEGReadWriter2Plugin'>
	^false! !

!PluginBasedJPEGReadWriter methodsFor: 'testing' stamp: ''!
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 methodsFor: 'image reading/writing' stamp: ''!
putForm: aForm quality: quality progressiveJPEG: progressiveFlag onFileNamed: fileName 
	"Store the given Form as a JPEG file of the given name, overwriting any existing file of that name. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG."
	| writer |
	fileName asFileReference ensureDelete.
	writer := self on: fileName asFileReference binaryWriteStream.
	writer 
		nextPutImage: aForm
		quality: quality
		progressiveJPEG: progressiveFlag.
	writer close! !

!PluginBasedJPEGReadWriter class methodsFor: 'image reading/writing' stamp: ''!
putForm: aForm onFileNamed: fileName
	"Store (encode) the image of the Form aForm as PNG on a file of with fileName."

	self
		putForm: aForm
		quality: -1
		progressiveJPEG: false
		onFileNamed: fileName! !

!PluginBasedJPEGReadWriter class methodsFor: 'image reading/writing' stamp: ''!
primJPEGPluginIsPresent
	<primitive: 'primJPEGPluginIsPresent' module: 'JPEGReadWriter2Plugin'>
	^false! !

!PluginBasedJPEGReadWriter class methodsFor: 'image reading/writing' stamp: ''!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('jpg' 'jpeg')! !

!Point commentStamp: ''!
I represent an x,y pair of numbers usually designating a location on the screen.

My instances are created either using the message `@` or `x:y:` or `r:degrees:` as follows:

```
| pt |
pt := 10@20.
pt x 
>>> 10
pt y
>>> 20 			 
```

```
| pt |
pt := Point x: 10 y: 20.
pt x 
> 10
pt y
> 20 			 
```

I define many nice messages that deal with point such as: 
- arithmetic such as \+, \*, reciprocal, min, abs,
- comparison \<, \<=, \=, \>, \>=, closeTo: 
- geometry such as sideOf:, to:intersects:to:, 
- polar coordinates,
- extent such as scaleTo:
- transformation such as negated, translatedBy:, scaleBy:
- rounding with roundTo:, roundUpTo:, truncateTo:, truncated

!
!Point methodsFor: 'truncation and round off' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
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: 'testing' stamp: ''!
isFloatPoint
	"Return true if both of my x and y coordinates
	are represented by float values, otherwise false"
	"(1@2) isFloatPoint >>> false"
	"(1@2.2) isFloatPoint >>> false"
	"(1.3@2.2) isFloatPoint >>> true"
	"((1/3)@(2/2)) isFloatPoint >>> false"
	
	^ x isFloat and: [ y isFloat ]! !

!Point methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating
	^ self class == Point! !

!Point methodsFor: 'comparing' stamp: ''!
min: aMin max: aMax 

	^ (self min: aMin) max: aMax! !

!Point methodsFor: '*Geometry' stamp: ''!
asGPoint
	^ x , y! !

!Point methodsFor: 'arithmetic' stamp: ''!
- arg 
	"Answer a Point that is the difference of the receiver and arg."
	"((2@2) - (100@200)) >>> (-98@ -198)"
	"((2@2) - 200) >>> (-198@ -198)"
	
	arg isPoint ifTrue: [^ (x - arg x) @ (y - arg y)].
	^ arg adaptToPoint: self andSend: #-! !

!Point methodsFor: 'comparing' stamp: ''!
max: aPoint 
	"Answer the lower right corner of the rectangle uniquely defined by the receiver and the argument, aPoint."
	"((100@200) max: (330@400)) >>> (330@400)"
	"((100@200) max: (30@400)) >>> (100@400)"
	^ (x max: aPoint x) @ (y max: aPoint y)! !

!Point methodsFor: '*Math-Operations-Extensions' stamp: ''!
rotateBy: angle about: center 
	"This method returns the point obtained after rotating myself (counter clockwise) 
	around the #center point of an #angle given as parameter. The #angle provided as 
	parameter is interpreted as being in radian."
	| p r theta |
	p := self - center.
	r := p r.
	theta := angle asFloat - p theta.
	^ (center x asFloat + (r * theta cos)) @ (center y asFloat - (r * theta sin))! !

!Point methodsFor: 'comparing' stamp: ''!
>= aPoint
	"Answer whether the receiver is neither above nor to the left of aPoint."

	^ x >= aPoint x and: [ y >= aPoint y ]! !

!Point methodsFor: 'transforming' stamp: ''!
negated
	"Answer a point whose x and y coordinates are the negatives of those of the receiver."
	^ (0 - x) @ (0 - y)! !

!Point methodsFor: 'point functions' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
r
	"Answer the receiver's radius in polar coordinate system."

	^ (self dotProduct: self) sqrt! !

!Point methodsFor: 'point functions' stamp: ''!
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: 'copying' stamp: ''!
deepCopy
	"Implemented here for better performance."

	^ x deepCopy @ y deepCopy! !

!Point methodsFor: '*Geometry' stamp: ''!
asGVector
	^ GVector coordinates: (G2DCoordinates x: x y: y)! !

!Point methodsFor: 'arithmetic' stamp: ''!
min
	"Answer a number that is the minimum of the x and y of the receiver."
	"(100@200) min >>> 100"
	
	^ self x min: self y! !

!Point methodsFor: 'truncation and round off' stamp: ''!
truncated
	"Answer a Point whose x and y coordinates are integers. Answer the receiver if its coordinates are already integral."

	self isIntegerPoint ifTrue: [ ^ self ].
	^ x truncated @ y truncated! !

!Point methodsFor: 'point functions' stamp: ''!
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: ''!
octantOf: otherPoint 
	"Return 1..8 indicating relative direction to otherPoint.  
	1=ESE, 2=SSE, ... etc. clockwise to 8=ENE"

	| 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: 'geometry' stamp: ''!
isInsideCircle: a with: b with: c 
	"Returns true if self is inside the circle defined by the points a, b, c. See Guibas and Stolfi (1985) p.107"
	^ (a dotProduct: a)
		* (b triangleArea: c with: self) - ((b dotProduct: b)
			* (a triangleArea: c with: self)) + ((c dotProduct: c)
			* (a triangleArea: b with: self)) - ((self dotProduct: self)
			* (a triangleArea: b with: c)) > 0.0! !

!Point methodsFor: 'comparing' stamp: ''!
= aPoint

	^ self species = aPoint species
		ifTrue: [ x = aPoint x and: [ y = aPoint y ]]
		ifFalse: [ false ]! !

!Point methodsFor: 'arithmetic' stamp: ''!
* arg 
	"Answer a Point that is the product of the receiver and arg."
	"((2@2) * (100@200)) >>> (200@400)"
	"((2@2) * 200) >>> (400@400)"
	
	arg isPoint ifTrue: [^ (x * arg x) @ (y * arg y)].
	^ arg adaptToPoint: self andSend: #*! !

!Point methodsFor: 'point functions' stamp: ''!
squaredDistanceTo: aPoint 
	"Answer the distance between aPoint and the receiver."
	| delta |
	delta := aPoint - self.
	^ delta dotProduct: delta! !

!Point methodsFor: 'truncation and round off' stamp: ''!
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: 'testing' stamp: ''!
isPoint
	^ true! !

!Point methodsFor: 'transforming' stamp: ''!
translateBy: delta 
	"Answer a Point translated by delta (an instance of Point)."
	"((100@200) translateBy: 5@10) >>> (105@210)"
	
	^ (delta x + x) @ (delta y + y)! !

!Point methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'accessing' stamp: ''!
y
	"Answer the y coordinate."
	"(100@200) y >>> 200"
	
	^ y! !

!Point methodsFor: '*Math-Operations-Extensions' stamp: ''!
normalized
	"Optimized for speed"
	| r |
	r := (x * x + (y * y)) sqrt.
	^ (x / r) @ (y / r)! !

!Point methodsFor: 'comparing' stamp: ''!
> aPoint
	"Answer whether the receiver is below and to the right of aPoint."

	^ x > aPoint x and: [ y > aPoint y ]! !

!Point methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter writeObject: self streamShortList: [ :array |
		array add: x; add: y ]! !

!Point methodsFor: 'arithmetic' stamp: ''!
\\ 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: 'point functions' stamp: ''!
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: 'testing' stamp: ''!
isIntegerPoint
	"Return true if both of my x and y coordinates
	are represented by integer values, otherwise false"
	^ x isInteger and: [ y isInteger ]! !

!Point methodsFor: 'transforming' stamp: ''!
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: 'private' stamp: ''!
setX: xValue setY: yValue 
	x := xValue.
	y := yValue! !

!Point methodsFor: 'transforming' stamp: ''!
scaleBy: factorPoint 
	"Answer a Point scaled by factor (an instance of Point)."
	 "(200@200 scaleBy: 2@3) >>> (400@600)"
	^(factorPoint x * x) @ (factorPoint y * y)! !

!Point methodsFor: 'arithmetic' stamp: ''!
abs
	"Answer a Point whose x and y are the absolute values of the receiver's x and y."
	"(100 @ -200) abs >>> (100@200)"
	^ x abs @ y abs! !

!Point methodsFor: 'point functions' stamp: ''!
nearestPointAlongLineFrom: p1 to: p2 
	"Note this will give points beyond the endpoints."
	
	| 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))! !

!Point methodsFor: 'rectangle creation' stamp: ''!
corner: aPoint 
	"Answer a Rectangle whose origin is the receiver and whose corner is aPoint. This is one of the infix ways of expressing the creation of a rectangle."
	"(10@10 corner: 100@100) >>> (10@10 corner: 100@100)"
	
	^ Rectangle origin: self corner: aPoint! !

!Point methodsFor: 'truncation and round off' stamp: ''!
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: '*STON-Core' stamp: ''!
fromSton: stonReader
	stonReader parseListDo: [ :each :index |
		index = 1 ifTrue: [ x := each ].
		index = 2 ifTrue: [ y := each ] ]! !

!Point methodsFor: '*Math-Operations-Extensions' stamp: ''!
theta
	"Answer the angle the receiver makes with origin in radians. right is 0; 
	down is 90."

	| 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: 'transforming' stamp: ''!
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: 'printing' stamp: ''!
storeOn: aStream 
	"x@y printed form is good for storing too"
	aStream nextPut: $(.
	self printOn: aStream.
	aStream nextPut: $).! !

!Point methodsFor: 'arithmetic' stamp: ''!
+ arg 
	"Answer a Point that is the sum of the receiver and arg."
	"((2@2) + (100@200)) >>> (102@202)"
	"((2@2) + 200) >>> (202@202)"
	
	arg isPoint ifTrue: [^ (x + arg x) @ (y + arg y)].
	^ arg adaptToPoint: self andSend: #+! !

!Point methodsFor: 'truncation and round off' stamp: ''!
floor
	"Answer a Point that is the receiver's x and y floor. Answer the receiver if its coordinates are already integral."
	"(100@200) floor >>> (100@200)"
	"(100.1@200.9) floor >>> (100@200)"
	
	self isIntegerPoint ifTrue: [ ^ self ].
	^ x floor @ y floor! !

!Point methodsFor: 'arithmetic' stamp: ''!
max
	"Answer a number that is the maximum of the x and y of the receiver."
	"(100@200) max >>> 200"

	^ self x max: self y! !

!Point methodsFor: 'comparing' stamp: ''!
< aPoint 
	"Answer whether the receiver is above and to the left of aPoint."
	"((100@200) < (330@400)) >>> true"
	"((100@200) < (330@100)) >>> false"
	
	^ x < aPoint x and: [y < aPoint y]! !

!Point methodsFor: 'point functions' stamp: ''!
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: '*Math-Operations-Extensions' stamp: ''!
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: 'comparing' stamp: ''!
closeTo: aPoint precision: aPrecision
 	^ (x closeTo: aPoint x precision: aPrecision) and: [ y closeTo: aPoint y precision: aPrecision ]! !

!Point methodsFor: 'comparing' stamp: ''!
hash
	"Hash is reimplemented because = is reimplemented."

	^ ( x hash hashMultiply + y hash) hashMultiply! !

!Point methodsFor: 'point functions' stamp: ''!
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: 'comparing' stamp: ''!
<= aPoint 
	"Answer whether the receiver is neither below nor to the right of aPoint."

	^ x <= aPoint x and: [y <= aPoint y]! !

!Point methodsFor: 'arithmetic' stamp: ''!
/ 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: '*Math-Operations-Extensions' stamp: ''!
onLineFrom: p1 to: p2
	^ self onLineFrom: p1 to: p2 within: 2! !

!Point methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^ aGeneralMapper visitPoint: self
! !

!Point methodsFor: 'point functions' stamp: ''!
sign
	^ (x sign @ y sign)! !

!Point methodsFor: 'accessing' stamp: ''!
x
	"Answer the x coordinate."
	"(100@200) x >>> 100"

	^ x! !

!Point methodsFor: 'comparing' stamp: ''!
min: aPoint 
	"Answer the upper left corner of the rectangle uniquely defined by the receiver and the argument, aPoint."
	"(100@200) min: (330@400) >>> (100@200)"
	"(100@200) min: (30@400) >>> (30@200)"
	
	^ (x min: aPoint x) @ (y min: aPoint y)! !

!Point methodsFor: '*Math-Operations-Extensions' stamp: ''!
distanceTo: 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: 'converting' stamp: ''!
asFloatPoint
	"Convert me to a float point transforming both of my coordinates
	to floats using #asFloat. If x and y are already represented
	by floats return myself, otherwise create a new Point instance."
	"((30/3)@(2/2)) asFloatPoint >>> (10.0@1.0)"
	
	self isFloatPoint
		ifTrue: [ ^ self ].
	^ x asFloat @ y asFloat! !

!Point methodsFor: 'testing' stamp: ''!
isZero
	^ x isZero and: [ y isZero ]! !

!Point methodsFor: 'geometry' stamp: ''!
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: '*Morphic-Core' stamp: ''!
scaledByDisplayScaleFactor

	^ self * self currentWorld displayScaleFactor.! !

!Point methodsFor: 'point functions' stamp: ''!
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: 'geometry' stamp: ''!
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: 'geometry' stamp: ''!
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"
	"((0@0) sideOf: (100@100)) >>> #center"
	
	| side |
	side := (self crossProduct: otherPoint) sign.
	^ { #right . #center . #left } at: side + 2! !

!Point methodsFor: 'transforming' stamp: ''!
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."
    "(200@200 scaleTo: 400@400) >>> (2.0@2.0)"
	 "(40@40 scaleTo: 400@400) >>> (10.0@10.0)"
	
    | 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: '*Math-Operations-Extensions' stamp: ''!
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: 'truncation and round off' stamp: ''!
rounded
	"Answer a Point that is the receiver's x and y rounded. Answer the receiver if its coordinates are already integral."

	self isIntegerPoint ifTrue: [ ^ self] .
	^ x rounded @ y rounded! !

!Point methodsFor: 'truncation and round off' stamp: ''!
ceiling
	"Answer a Point that is the receiver's x and y ceiling. Answer the receiver if its coordinates are already integral."
	"(100@200) ceiling >>> (100@200)"
	"(100.1@200.9) ceiling >>> (101@201)"
	
	self isIntegerPoint ifTrue: [ ^ self ].
	^ x ceiling @ y ceiling! !

!Point methodsFor: 'converting' stamp: ''!
asIntegerPoint
	"Convert me to an integer point transforming both of my coordinates
	to integers using #asInteger. If x and y are already represented
	by integers return myself, otherwise create a new Point instance."
	
	self isIntegerPoint
		ifTrue: [ ^ self ].
	^ x asInteger @ y asInteger! !

!Point methodsFor: 'private' stamp: ''!
bitShiftPoint: bits 
	x := x bitShift: bits.
	y := y bitShift: bits! !

!Point methodsFor: '*Math-Operations-Extensions' stamp: ''!
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: 'point functions' stamp: ''!
nearestPointOnLineFrom: p1 to: p2
	"This will not give points beyond the endpoints"
	^ (self nearestPointAlongLineFrom: p1 to: p2)
		adhereTo: (p1 rectangle: p2)! !

!Point methodsFor: 'interpolating' stamp: ''!
interpolateTo: end at: amountDone
	"Interpolate between the instance and end after the specified amount has been done (0 - 1)."

	^ self * (1 - amountDone) + (end * amountDone)! !

!Point methodsFor: '*Math-Operations-Extensions' stamp: ''!
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 distanceTo: (self nearestPointAlongLineFrom: p1 to: p2)) <= epsilon! !

!Point methodsFor: 'point functions' stamp: ''!
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: 'rectangle creation' stamp: ''!
rectangle: aPoint 
	"Answer a Rectangle that encompasses the receiver and aPoint. This is the most general infix way to create a rectangle."

	^ Rectangle 
		point: self
		point: aPoint! !

!Point methodsFor: 'point functions' stamp: ''!
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: 'comparing' stamp: ''!
closeTo: aPoint
	"Return whether the receiver is close to the argument aPoint. The precision for point holding floats is defined by Float >> #closeTo:precision:. For points holding integer, closeTo: corresponds to equalsTo:"
	
	"((100@200) closeTo: (100@200)) >>> true"
	"((100@201) closeTo: (100@200)) >>> false"
	
 	^ (x closeTo: aPoint x) and: [ y closeTo: aPoint y ]! !

!Point methodsFor: 'printing' stamp: ''!
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: 'point functions' stamp: ''!
reflectedAbout: aPoint
	"Answer a new point that is the reflection of the receiver about the given point."

	^ (self - aPoint) negated + aPoint! !

!Point methodsFor: 'truncation and round off' stamp: ''!
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: 'point functions' stamp: ''!
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: 'converting' stamp: ''!
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: ''!
asMargin
	"Return a margin instance based on the receiver. aMargin is an object representing either 1, 2 or 4 numbers. It represents the space between a rectangular area and this rectangular area augmented by the margin"
	
	^ Margin fromPoint: self! !

!Point methodsFor: 'converting' stamp: ''!
asPoint
	"Answer the receiver itself."
	^self! !

!Point methodsFor: 'geometry' stamp: ''!
to: end1 intersects: start2 to: end2 
	"Returns true if the linesegment from start1 (=self) to end1 intersects with the segment from start2 to end2, otherwise false."
	
	| start1 sideStart sideEnd |
	start1 := self.
	(((start1 = start2 or: [ end1 = end2 ]) or: [ start1 = end2 ]) or: [ start2 = end1 ]) ifTrue: [ ^ true ].
	sideStart := start1 
		to: end1
		sideOf: start2.
	sideEnd := start1 
		to: end1
		sideOf: end2.
	sideStart = sideEnd ifTrue: [ ^ false ].
	sideStart := start2 
		to: end2
		sideOf: start1.
	sideEnd := start2 
		to: end2
		sideOf: end1.
	sideStart = sideEnd ifTrue: [ ^ false ].
	^ true! !

!Point methodsFor: 'converting' stamp: ''!
asNonFractionalPoint
	"Convert a point to a float point if necessary i.e., if one of its constituents are fractions."
	
	(x isFraction or: [ y isFraction ])
		ifTrue: [ ^ x asFloat @ y asFloat ]! !

!Point methodsFor: '*Math-Operations-Extensions' stamp: ''!
bearingToPoint: anotherPoint
    "Return the bearing, in degrees, from the receiver to anotherPoint."

    | 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: 'rectangle creation' stamp: ''!
extent: aPoint 
	"Answer a Rectangle whose origin is the receiver and whose extent is aPoint. This is one of the infix ways of expressing the creation of a rectangle."

	^ Rectangle origin: self extent: aPoint! !

!Point methodsFor: 'arithmetic' stamp: ''!
reciprocal
	"Answer a Point with coordinates that are the reciprocals of mine."
	"(100@200) reciprocal >>> ((1/100)@(1/200))"
	
	^ x reciprocal @ y reciprocal! !

!Point methodsFor: 'point functions' stamp: ''!
transposed
	^ y @ x! !

!Point methodsFor: 'point functions' stamp: ''!
fourNeighbors
	^ Array with: self + (1 @ 0)
		with: self + (0 @ 1)
		with: self + (-1 @ 0)
		with: self + (0 @ -1)! !

!Point methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."
	^ self! !

!Point methodsFor: 'point functions' stamp: ''!
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] ]! !

!Point methodsFor: 'point functions' stamp: ''!
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: 'arithmetic' stamp: ''!
// 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: '*Math-Operations-Extensions' stamp: ''!
setR: rho degrees: degrees 
	| radians |
	radians := degrees asFloat degreesToRadians.
	x := rho asFloat * radians cos.
	y := rho asFloat * radians sin! !

!Point methodsFor: '*Deprecated10' stamp: ''!
dist: aPoint 
	"Answer the distance between aPoint and the receiver."
	
	self
		deprecated: 'Use #distanceTo: instead.'
		on: '9 February 2021'
		in: #Pharo9
		transformWith: '`@receiver dist: `@arg' -> '`@receiver distanceTo: `@arg'.
	^ self distanceTo: aPoint! !

!Point methodsFor: 'extent functions' stamp: ''!
guarded
	"Return a positive nonzero extent."
	"(100@200) guarded >>> (100@200)"
	"(0@5) guarded >>> (1@5)"
	
	^self max: 1@1! !

!Point methodsFor: 'converting' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
x: xInteger y: yInteger 
	"Answer an instance of me with coordinates xInteger and yInteger."

	^ self basicNew setX: xInteger setY: yInteger! !

!Point class methodsFor: '*Tool-Finder' stamp: ''!
approvedSelectorsForMethodFinder

	^ self selectors! !

!Point class methodsFor: '*Math-Operations-Extensions' stamp: ''!
r: rho degrees: degrees
	"Answer an instance of me with polar coordinates rho and theta."

	^ self basicNew setR: rho degrees: degrees! !

!Point class methodsFor: '*System-Settings-Browser' stamp: ''!
settingInputWidgetForNode: aSettingNode
	^ aSettingNode inputWidgetForPoint! !

!Point class methodsFor: '*Roassal3-Layouts' stamp: ''!
r: radius theta: angle
	^ (radius * angle cos) @ (radius * angle sin)! !

!PointArray commentStamp: ''!
This class stores 32bit Integer points in place. It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.!
!PointArray methodsFor: 'accessing' stamp: ''!
bounds
	| min max |
	min := max := self at: 1.
	self do:[:pt|
		min := min min: pt.
		max := max max: pt].
	^min corner: max! !

!PointArray methodsFor: 'accessing' stamp: ''!
at: index put: aPoint

	super at: index * 2 - 1 put: aPoint x asInteger.
	super at: index * 2 put: aPoint y asInteger.
	^aPoint! !

!PointArray methodsFor: 'accessing' stamp: ''!
defaultElement 

	"Return the default element of the receiver"
	^0@0! !

!PointArray methodsFor: 'accessing' stamp: ''!
size
	"Return the number of elements in the receiver"
	^super size // 2! !

!PointArray methodsFor: 'converting' stamp: ''!
asPointArray
	^ self! !

!PointArray methodsFor: 'accessing' stamp: ''!
at: index

	^(super at: index * 2 - 1) @ (super at: index * 2)! !

!PointArray class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!PointArray class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!PointArray class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!PointArray class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!PointArray class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!PointArray class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!PointArray class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!PointArray class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!PointArray class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!PointArray class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!PointArray class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!PointArray class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!PointArray class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!PointArray class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!PointArray class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!PointArray class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!PointArray class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!PointArray class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!PointArray class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!PointArray class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!PointArray class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!PointArray class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!PointArray class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!PointArray class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!PointArray class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!PointArray class methodsFor: 'instance creation' stamp: ''!
new: n
	^super new: n*2! !

!PointArray class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!PointArray class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!PointArray class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!PointArray class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!PointArrayTest commentStamp: ''!
SUnit Test for PointArray!
!PointArrayTest methodsFor: 'tests' stamp: ''!
testDefaultElement

	self assert: 0@0 equals: pointArray defaultElement! !

!PointArrayTest methodsFor: 'tests' stamp: ''!
testAt

	self assert: 0@0 equals: (pointArray at: 1).
	self assert: 10@3 equals: (pointArray at: 2)! !

!PointArrayTest methodsFor: 'tests' stamp: ''!
testAtPutFloat

	pointArray at: 2 put: 1.2 @ 5.5.
	self assert: 1 @ 5 equals: (pointArray at: 2)! !

!PointArrayTest methodsFor: 'tests' stamp: ''!
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: 'tests' stamp: ''!
testAtPutInt4

	pointArray at: 2 put: 405933 @ -405933.
	self assert: 405933@ -405933 equals: (pointArray at: 2)! !

!PointArrayTest methodsFor: 'tests' stamp: ''!
testSize

	self assert: 2 equals: pointArray size! !

!PointArrayTest methodsFor: 'tests' stamp: ''!
testAtPutFraction

	pointArray at: 2 put: 1/2 @ 51/5.
	self assert: 0 @ 10 equals: (pointArray at: 2)! !

!PointArrayTest methodsFor: 'tests' stamp: ''!
testBounds

	self assert: (0@0 corner: 10@3) equals: pointArray bounds! !

!PointArrayTest methodsFor: 'tests' stamp: ''!
testAtPutLargeInteger

	self should: [ pointArray at: 2 put: 123456789012345678901234567890@987654323456787654378989 ] raise: Error.! !

!PointArrayTest methodsFor: 'running' stamp: ''!
setUp 

	super setUp.
	pointArray := PointArray with: 0@0 with: 10@3! !

!PointTest commentStamp: ''!
SUnit tests for class Point!
!PointTest methodsFor: 'tests - testing' stamp: ''!
testNormalized
	| pt |
	pt := Point x: 2 y: 2.

	self assert: pt normalized equals: (2 / 8 sqrt) @ (2 / 8 sqrt)! !

!PointTest methodsFor: 'tests - point functions' stamp: ''!
testFlipByCenterAt
	| center a direction |
	center := 4 @ 5.

	a := 0 @ 0.
	direction := #vertical.
	self assert: (a flipBy: direction centerAt: center) equals: 0 @ 10.
	direction := #horizontal.
	self assert: (a flipBy: direction centerAt: center) equals: 8 @ 0.
	direction := #diagonal.
	self should: [ a flipBy: direction centerAt: center ] raise: Error description: 'unrecognizable direction'.

	a := 1 @ 2.
	direction := #vertical.
	self deny: (a flipBy: direction centerAt: center) equals: 0 @ 10.
	direction := #horizontal.
	self deny: (a flipBy: direction centerAt: center) equals: 8 @ 0.
	direction := #diagonal.
	self should: [ a flipBy: direction centerAt: center ] raise: Error description: 'unrecognizable direction'! !

!PointTest methodsFor: 'tests - point functions' stamp: ''!
testInsideTriangleWithWith
	self assert:   ( (2 @ 3) insideTriangle:  (1 @ 1 ) with: (1 @ 7) with: (3 @ 3)).
	self deny:    ( (3 @ 1) insideTriangle:  (1 @ 1 ) with: (1 @ 7) with: (3 @ 3)).
	self deny:    ( (3 @ 15) insideTriangle:  (1 @ 1 ) with: (1 @ 7) with: (3 @ 3)).
	self deny:    ( (0 @ 6) insideTriangle:  (1 @ 1 ) with: (1 @ 7) with: (3 @ 3)).
	self assert:   ( (-2 @ -3) insideTriangle:  (-1 @ -1 ) with: (-1 @ -7) with: (-3 @ -3)).
	self deny:    ( (-3 @ -1) insideTriangle:  (-1 @ -1 ) with: (-1 @ -7) with: (-3 @ -3)).
	self deny:    ( (-3 @ -15) insideTriangle:  (-1 @ -1 ) with: (-1 @ -7) with: (-3 @ -3)).
	self deny:    ( (0 @ -6) insideTriangle:  (-1 @ -1 ) with: (-1 @ -7) with: (-3 @ -3)).! !

!PointTest methodsFor: 'tests - testing' stamp: ''!
testIsZero

	self assert: (0@0) isZero.	
	self deny:  (0@1) isZero.
	self deny:  (1@0) isZero.
	self deny:  (1@1) isZero.! !

!PointTest methodsFor: 'tests - point functions' stamp: ''!
testDistanceTo
	self assert: (0 @ 0 distanceTo: 0 @ 0) equals: 0.
	self assert: (0 @ 0 distanceTo: 0 @ 5) equals: 5.
	self assert: (5 @ 0 distanceTo: 0 @ 0) equals: 5.
	self assert: (3 @ 0 distanceTo: 0 @ 4) equals: 5.
	self assert: (5 @ 0 distanceTo: 2 @ 4) equals: 5.
	self deny: (0 @ 0 distanceTo: 0 @ 0) equals: 1! !

!PointTest methodsFor: 'tests - transforming' stamp: ''!
testNegated
	self assert: (0 @ 0) negated equals: 0 @ 0.
	self deny: (0 @ 1) negated equals: 0 @ 0.
	self deny: (1 @ 0) negated equals: 0 @ 0.
	self deny: (1 @ 1) negated equals: 0 @ 0.
	self assert: (1 @ 1) negated equals: -1 @ -1.
	self deny: (-1 @ -1) negated equals: -1 @ -1.
	self deny: (1 @ -1) negated equals: -1 @ -1.
	self deny: (-1 @ 1) negated equals: -1 @ -1.
	self assert: (-1 @ -1) negated equals: 1 @ 1.
	self assert: (1 @ -1) negated equals: -1 @ 1.
	self assert: (-1 @ 1) negated equals: 1 @ -1! !

!PointTest methodsFor: 'tests - testing' stamp: ''!
testSideOf
	| p1 p2 p3 p4 p5 p6 o |
	p1 := 1 @ 1.
	p2 := -1 @ -1.
	p3 := -1 @ 0.
	p4 := 0 @ 1.
	p5 := 1 @ 0.
	p6 := 0 @ -1.
	o := 0 @ 0.

	self assert: (p1 sideOf: o) equals: #center.
	self assert: (p1 sideOf: p2) equals: #center.

	self assert: (p1 sideOf: p3) equals: #left.
	self assert: (p1 sideOf: p4) equals: #left.

	self assert: (p1 sideOf: p5) equals: #right.
	self assert: (p1 sideOf: p6) equals: #right! !

!PointTest methodsFor: 'tests - geometry' stamp: ''!
testToIntersectsTo

	self assert: ( (1 @ 1) to: ( 1 @ 6) intersects: (1 @ 1) to: (2 @ 9) ).
	self assert: ( (1 @ 1) to: ( 1 @ 6) intersects: (1 @ 2) to: (1 @6) ).
	self assert: ( (1 @ 1) to: ( 2 @ 6) intersects: (8 @ 6) to: (1 @ 1) ).
	self assert: ( (5 @ 1) to: ( 1 @ 6) intersects: (1 @ 6) to: (9 @ 1) ).
	self deny:  ( (1 @ 1) to: ( 1 @ 6) intersects: (2 @ 1) to: (2 @ 6) ). 
	self deny:  ( (1 @ 1) to: ( 1 @ 6) intersects: (0 @7) to: (5 @ 7) ). 
	self assert: ( (1 @ 1) to: ( 1 @ 6) intersects: (0 @ 2) to: (2 @ 2) ). 
	
	self assert: ( (-1 @ -1) to: ( -1 @ -6) intersects: (-1 @ -1) to: (-2 @ -9) ).
	self assert: ( (-1 @ -1) to: ( -1 @ -6) intersects: (-1 @ -2) to: (-1 @ -6) ).
	self assert: ( (-1 @ -1) to: ( -2 @ -6) intersects: (-8 @ -6) to: (-1 @ -1) ).
	self assert: ( (-5 @ -1) to: ( -1 @ -6) intersects: (-1 @ -6) to: (-9 @ -1) ).
	self deny:  ( (-1 @ -1) to: (-1 @ -6) intersects: (-2 @ -1) to: (-2 @ -6) ). 
	self deny:  ( (-1 @ -1) to: ( -1 @ -6) intersects: (-0 @ -7) to: (-5 @ -7) ). 
	self assert: ( (-1 @ -1) to: ( -1 @ -6) intersects: (-0 @ -2) to: (-2 @ -2) ). 
	
	"point line( 1@1 to: 1@1 ) not allowed "
	self deny: ( (1 @ 1) to: ( 1 @ 1) intersects: (1@ 0) to: (1 @ 2) )."should be true if point line alowed" 
	self assert: ( (1 @ 1) to: ( 1 @ 1) intersects: (1 @ 1) to: (1 @ 9) ).! !

!PointTest methodsFor: 'tests - testing' stamp: ''!
testRightRotated
	self assert: (10 @ 20) rightRotated equals: -20 @ 10! !

!PointTest methodsFor: 'tests - testing' stamp: ''!
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.! !

!PointTest methodsFor: 'tests - converting' stamp: ''!
testAsIntegerPoint
	| testPoint |
	self assert: (1 @ 1) asIntegerPoint equals: 1 @ 1.
	self assert: (1.2 @ 1) asIntegerPoint equals: 1 @ 1.
	self assert: (1 @ 1.2) asIntegerPoint equals: 1 @ 1.
	self assert: (1.2 @ 1.2) asIntegerPoint equals: 1 @ 1.
	self assert: (1.000000000000000001 @ 1.9999999999) asIntegerPoint equals: 1 @ 1.

	self assert: (-1 @ -1) asIntegerPoint equals: -1 @ -1.
	self assert: (-1.2 @ -1) asIntegerPoint equals: -1 @ -1.
	self assert: (-1 @ -1.2) asIntegerPoint equals: -1 @ -1.
	self assert: (-1.2 @ -1.2) asIntegerPoint equals: -1 @ -1.
	self assert: (-1.000000000000000001 @ -1.9999999999) asIntegerPoint equals: -1 @ -1.

	self deny: (1.2 @ 1) asIntegerPoint equals: 1.2 @ 1.
	self deny: (1 @ 1.2) asIntegerPoint equals: 1 @ 1.2.
	self deny: (1.2 @ 1.2) asIntegerPoint equals: 1.2 @ 1.2.

	self deny: (-1.2 @ -1) asIntegerPoint equals: -1.2 @ -1.
	self deny: (-1 @ -1.2) asIntegerPoint equals: -1 @ -1.2.
	self deny: (-1.2 @ -1.2) asIntegerPoint equals: -1.2 @ -1.2.

	"test that we don't create a new instance if point is already a n integer point"
	testPoint := 1 @ 1.
	self assert: testPoint identicalTo: testPoint asIntegerPoint.
	"test that we actually create a new instance if point is not an integer one"
	testPoint := 1.0 @ 1.0.
	self deny: testPoint identicalTo: testPoint asIntegerPoint! !

!PointTest methodsFor: 'tests - arithmetic' stamp: ''!
testReciprocal
	self assert: (1 @ 1) reciprocal equals: 1 @ 1.
	self deny: (2 @ 2) reciprocal equals: 2 @ 2.
	self assert: (1 @ 5) reciprocal equals: 1 @ (1 / 5).
	self should: [ (0 @ 0) reciprocal ] raise: ZeroDivide.
	self should: [ (1 @ 0) reciprocal ] raise: ZeroDivide.
	self should: [ (0 @ 1) reciprocal ] raise: ZeroDivide! !

!PointTest methodsFor: 'tests - testing' stamp: ''!
testSign
	self assert: (-3 @ -2) sign equals: -1 @ -1.
	self assert: (-3 @ 2) sign equals: -1 @ 1.
	self assert: (3 @ -2) sign equals: 1 @ -1.
	self assert: (3 @ 2) sign equals: 1 @ 1! !

!PointTest methodsFor: 'tests - testing' stamp: ''!
testCloseToWithPrecision

	| x y |
	x := 0.105.
	y := 0.11.

	self assert: (x closeTo: 0.1 precision: 0.1).
	self assert: (y closeTo: 0.1 precision: 0.1).
	
	self assert: (x@y closeTo: (0.1@0.1) precision: 0.1)! !

!PointTest methodsFor: 'tests - testing' stamp: ''!
testLeftRotated
	self assert: (10 @ 20) leftRotated equals: 20 @ -10! !

!PointTest methodsFor: 'tests - truncation and roundoff' stamp: ''!
testIsIntegerPoint

	self assert: (1 @ 1) isIntegerPoint.
	self assert: (-1 @ 1) isIntegerPoint.
	self assert: (1 @ -1) isIntegerPoint.
	self assert: (-1 @ -1) isIntegerPoint.
	
	self deny: (1 @ 1.2) isIntegerPoint.
	self deny: (1.2 @ 1) isIntegerPoint.
	self deny: (1.2 @ 1.2) isIntegerPoint.
	
	self deny: (-1 @ -1.2) isIntegerPoint.
	self deny: (-1.2 @ -1) isIntegerPoint.
	self deny: (-1.2 @ -1.2) isIntegerPoint.! !

!PointTest methodsFor: 'tests - testing' stamp: ''!
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 equals: {(0 @ 0) . (0 @ 0) . (0 @ 0) . (0 @ 0)}.
	self assert: (0 @ 0) eightNeighbors equals: {(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 assertEmpty: rejects! !

!PointTest methodsFor: 'tests - arithmetic' stamp: ''!
testAbs
	self assert: (0 @ 0) abs equals: 0 @ 0.
	self assert: (1 @ 1) abs equals: 1 @ 1.
	self assert: (-1 @ -1) abs equals: 1 @ 1.
	self assert: (-1 @ 1) abs equals: 1 @ 1.
	self deny: (1 @ -1) abs equals: 1 @ -1.
	self deny: (-1 @ -1) abs equals: -1 @ -1.
	self deny: (-1 @ 1) abs equals: -1 @ 1.
	self deny: (1 @ -1) abs equals: 1 @ -1! !

!PointTest methodsFor: 'tests - converting' stamp: ''!
testIsPoint

	self deny: nil isPoint.
	self deny: 'a' isPoint.
	self deny: 1 isPoint. 
	self deny: -1 isPoint. 
	'Test on a random class'.
	self deny: Object new isPoint.
	self assert: Point new isPoint.
	self assert: (0 @ 0) isPoint.
	self assert: (-1 @ -1) isPoint.
	self assert: (1.2 @ 1.2) isPoint.
	self assert: (-1.2 @ -1.2) isPoint.! !

!PointTest methodsFor: 'tests - point functions' stamp: ''!
testCrossProduct
	self assert: (0 @ 0 crossProduct: 0 @ 0) equals: 0.
	self assert: (1 @ 0 crossProduct: 1 @ 1) equals: 1.
	self assert: (3 @ 2 crossProduct: 6 @ 4) equals: 0.
	self assert: (1 @ 2 crossProduct: 3 @ 4) equals: -2! !

!PointTest methodsFor: 'tests - point functions' stamp: ''!
testEightNeighbors
	| x y |
	x := Point new.
	x := 1 @ 1.
	y := x eightNeighbors.
	self assert: y equals: {(2 @ 1) . (2 @ 2) . (1 @ 2) . (0 @ 2) . (0 @ 1) . (0 @ 0) . (1 @ 0) . (2 @ 0)}.
	x := Point new.
	x := -2 @ -6.
	y := x eightNeighbors.
	self assert: y equals: {(-1 @ -6) . (-1 @ -5) . (-2 @ -5) . (-3 @ -5) . (-3 @ -6) . (-3 @ -7) . (-2 @ -7) . (-1 @ -7)}! !

!PointTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Point! !

!PointTest methodsFor: 'tests - converting' stamp: ''!
testAsFloatPoint
	| testPoint |
	self assert: (1 @ 1) asFloatPoint equals: 1.0 @ 1.0.
	self assert: (1.2 @ 1) asFloatPoint equals: 1.2 @ 1.0.
	self assert: (1 @ 1.2) asFloatPoint equals: 1.0 @ 1.2.
	self assert: (1.2 @ 1.2) asFloatPoint equals: 1.2 @ 1.2.
	self assert: (1.000000000000000001 @ 1.9999999999) asFloatPoint equals: 1.000000000000000001 @ 1.9999999999.

	self assert: (-1 @ -1) asFloatPoint equals: -1.0 @ -1.0.
	self assert: (-1.2 @ -1) asFloatPoint equals: -1.2 @ -1.0.
	self assert: (-1 @ -1.2) asFloatPoint equals: -1.0 @ -1.2.
	self assert: (-1.2 @ -1.2) asFloatPoint equals: -1.2 @ -1.2.
	self assert: (-1.000000000000000001 @ -1.9999999999) asFloatPoint equals: -1.000000000000000001 @ -1.9999999999.

	self deny: (1.2 @ 1) asFloatPoint equals: 1 @ 1.
	self deny: (1 @ 1.2) asFloatPoint equals: 1 @ 1.
	self deny: (1.2 @ 1.2) asFloatPoint equals: 1 @ 1.

	self deny: (-1.2 @ -1) asFloatPoint equals: -1 @ -1.
	self deny: (-1 @ -1.2) asFloatPoint equals: -1 @ -1.
	self deny: (-1.2 @ -1.2) asFloatPoint equals: -1 @ -1.

	"test that we don't create a new instance if point is already a float point"
	testPoint := 1.0 @ 1.0.
	self assert: testPoint identicalTo: testPoint asFloatPoint.
	"test that we actually create a new instance if point is not a float one"
	testPoint := 1 @ 1.
	self deny: testPoint identicalTo: testPoint asFloatPoint! !

!PointTest methodsFor: 'tests - testing' stamp: ''!
testBearingToPoint
	self assert: (0 @ 0 bearingToPoint: 0 @ 0) equals: 0.
	self assert: (0 @ 0 bearingToPoint: 0 @ -1) equals: 0.
	self assert: (0 @ 0 bearingToPoint: 1 @ 0) equals: 90.
	self assert: (0 @ 0 bearingToPoint: 0 @ 1) equals: 180.
	self assert: (0 @ 0 bearingToPoint: -1 @ 0) equals: 270.
	self assert: (0 @ 0 bearingToPoint: 1 @ 1) equals: 135.
	self assert: (0 @ 0 bearingToPoint: 0.01 @ 0) equals: 90.
	self assert: (0 @ 0 bearingToPoint: -2 @ -3) equals: 326.
	self assert: (0 @ 0 bearingToPoint: -0 @ 0) equals: 0.
	self assert: (-2 @ -3 bearingToPoint: 0 @ 0) equals: 146! !

!PointTest methodsFor: 'tests - truncation and roundoff' stamp: ''!
testIsFloatPoint

	self deny: (1 @ 1) isFloatPoint.
	self deny: (-1 @ 1) isFloatPoint.
	self deny: (1 @ -1) isFloatPoint.
	self deny: (-1 @ -1) isFloatPoint.
	
	self deny: (1 @ 1.2) isFloatPoint.
	self deny: (1.2 @ 1) isFloatPoint.
	self assert: (1.2 @ 1.2) isFloatPoint.
	
	self deny: (-1 @ -1.2) isFloatPoint.
	self deny: (-1.2 @ -1) isFloatPoint.
	self assert: (-1.2 @ -1.2) isFloatPoint.
	
	self deny: (0 @ 0) isFloatPoint.
	self deny: (0.0 @ 0) isFloatPoint.
	self deny: (0 @ 0.0) isFloatPoint.
	self assert: (0.0 @ 0.0) isFloatPoint.! !

!PointTest methodsFor: 'tests - testing' stamp: ''!
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: ''!
testScaleTo
	self assert: (200@200 scaleTo: 400@400) equals:(2.0@2.0).
	self assert: (40@40 scaleTo: 400@400) equals: (10.0@10.0)! !

!PointTest methodsFor: 'tests - converting' stamp: ''!
testAsPoint
	self deny: 1 isPoint.
	self deny: 1.2 isPoint.
	self assert: 1 asPoint isPoint.
	self assert: -1 asPoint isPoint.
	self assert: 1.2 asPoint isPoint.
	self assert: -1.2 asPoint isPoint.
	self assert: 1 asPoint equals: 1 @ 1.
	self assert: -1 asPoint equals: -1 @ -1.
	self assert: 1.2 asPoint equals: 1.2 @ 1.2.
	self assert: -1.2 asPoint equals: -1.2 @ -1.2.
	self assert: (1 @ 1) asPoint equals: 1 @ 1.
	self assert: (-1 @ -1) asPoint equals: -1 @ -1.
	self assert: (1.2 @ 1.2) asPoint equals: 1.2 @ 1.2.
	self assert: (-1.2 @ -1.2) asPoint equals: -1.2 @ -1.2! !

!PointerLayout commentStamp: ''!
I am the superclass for all layouts with Slots.!
!PointerLayout methodsFor: 'api' stamp: ''!
slotNamed: aName 
	^self resolveSlot: aName asSymbol! !

!PointerLayout methodsFor: 'comparing' stamp: ''!
= other
	^ super = other
		ifFalse: [  false ]
		ifTrue: [ self slotScope = other slotScope ]! !

!PointerLayout methodsFor: 'validation' stamp: ''!
checkParentScopes
	| parentScope superclassScope |
	parentScope := self slotScope parentScope.
	self host superclass ifNil: [ ^ self ].
	superclassScope := self host superclass classLayout slotScope.
	self 
		assert: parentScope = superclassScope
		description: 'Parent slot scope is out of sync'! !

!PointerLayout methodsFor: 'comparing' stamp: ''!
hash
	^ self class hash bitXor: self slotScope hash! !

!PointerLayout methodsFor: 'accessing' stamp: ''!
fieldSize
	^ slotScope fieldSize! !

!PointerLayout methodsFor: 'extending' stamp: ''!
extend
	"Answer a default layout extending me."

	^ self extend: self slotScope extend! !

!PointerLayout methodsFor: 'accessing' stamp: ''!
allVisibleSlots
	^ slotScope allVisibleSlots! !

!PointerLayout methodsFor: 'instance initialization' stamp: ''!
initializeInstance: anInstance
	self allSlotsDo: [ :slot | slot initialize: anInstance ]! !

!PointerLayout methodsFor: 'validation' stamp: ''!
checkSlotIndices
	| slots current |
	slots := slotScope flatten select: [:each | each size > 0]. "skip slots that have no index"
	[ slots size > 1 ] whileTrue: [
		current := slots removeFirst.
			self assert: slots first index = (current index + current size) ]! !

!PointerLayout methodsFor: 'validation' stamp: ''!
checkSanity
	super checkSanity.
	self 
		checkSlotNames;
		checkSlotIndices! !

!PointerLayout methodsFor: 'testing' stamp: ''!
hasBindingThatBeginsWith: aString
	"Answer true if there is a Slot that begins with aString, false otherwise"
	
	^ self slotScope hasBindingThatBeginsWith: aString! !

!PointerLayout methodsFor: 'extending' stamp: ''!
extendEphemeron: newScope

	^ EphemeronLayout new slotScope: newScope! !

!PointerLayout methodsFor: 'extending' stamp: ''!
extendVariable: newScope
	^ VariableLayout new slotScope: newScope! !

!PointerLayout methodsFor: 'accessing' stamp: ''!
resolveSlot: aName ifFound: foundBlock ifNone: noneBlock
	^ slotScope resolveSlot: aName ifFound: foundBlock ifNone: noneBlock! !

!PointerLayout methodsFor: 'accessing' stamp: ''!
allSlots
	^ slotScope flatten! !

!PointerLayout methodsFor: 'validation' stamp: ''!
checkIntegrity
	self
		checkSanity;
		checkParentScopes;
		checkInheritedSlots! !

!PointerLayout methodsFor: 'api' stamp: ''!
definesSlotNamed: aString 
	^self resolveSlot: aString ifFound: [ true ] ifNone: [ false ].! !

!PointerLayout methodsFor: 'extending' stamp: ''!
extend: aScope
	^ self species new slotScope: aScope! !

!PointerLayout methodsFor: 'testing' stamp: ''!
hasSlots
	^ slotScope hasSlots! !

!PointerLayout methodsFor: 'accessing' stamp: ''!
slots
	^ slotScope slots! !

!PointerLayout methodsFor: 'copying' stamp: ''!
postCopy
	slotScope := slotScope copy! !

!PointerLayout methodsFor: 'testing' stamp: ''!
hasFields
	^ slotScope hasFields! !

!PointerLayout methodsFor: 'extending' stamp: ''!
extendWeak: newScope
	^ WeakLayout new slotScope: newScope! !

!PointerLayout methodsFor: 'accessing' stamp: ''!
slotScope
	^ slotScope! !

!PointerLayout methodsFor: 'testing' stamp: ''!
size 
	^ slotScope fieldSize! !

!PointerLayout methodsFor: 'validation' stamp: ''!
checkSlotNames
	| slots current |
	slots := slotScope allVisibleSlots.
	[ slots isEmpty ] whileFalse: [
		current := slots removeLast.
		slots do: [ :other |
			other name = current name
				ifTrue: [ 
					DuplicatedSlotName new
						oldSlot: current;
						newSlot: other;
						host: host;
						signal ]]]! !

!PointerLayout methodsFor: 'validation' stamp: ''!
checkInheritedSlots
	
	self host superclass 
		ifNil: [ ^ self ].
	self host classLayout
		ifNil: [ ^ self ].
		
	self 
		assert: (self host superclass classLayout size <= self host classLayout size)
		description: [ (self host name, ' does not inherit all slots from ', self host superclass name) ].
	
	"check that the we have the same slots at the same indices as in the superclass"
	self host superclass classLayout allSlots withIndexDo: [ :slot :index|
		| localSlot |
		localSlot := (self host classLayout allSlots at: index).
		self 
			assert: slot = localSlot
			description: [ 'Slot "', localSlot name, '" index at position ', index asString, ' conflicts with slot "', slot name, '" in ', self host superclass asString ]].! !

!PointerLayout methodsFor: 'accessing' stamp: ''!
instVarNames
	^ slotScope visibleSlotNames! !

!PointerLayout methodsFor: 'accessing' stamp: ''!
resolveSlot: aName
	^ slotScope resolveSlot: aName! !

!PointerLayout methodsFor: 'accessing' stamp: ''!
host: aClass

	super host: aClass.
	self slots do: [ :aSlot | aSlot owningClass: aClass ]! !

!PointerLayout methodsFor: 'accessing' stamp: ''!
slotScope: anObject
	slotScope := anObject! !

!PointerLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == PointerLayout! !

!PointerUtils commentStamp: ''!
I have some primitives used when using objects in FFI calls.
I have them here, because they are really unsafe and never should be called directly.!
!PointerUtils class methodsFor: 'private' stamp: ''!
oopForObject: anObject

	^ ExternalAddress new
		fromInteger: (self primOopForObject: anObject);
		yourself
		 ! !

!PointerUtils class methodsFor: 'private' stamp: ''!
primOopForObject: anObject

	"This primitive fails if the object is not pinned"

	<primitive: 'primitiveGetAddressOfOOP'>

	anObject isPinned ifFalse: [ self error: 'Objects passed by reference should be pinned' ].

	^ self primitiveFailed	! !

!PointerUtils class methodsFor: 'private' stamp: ''!
primObjectForOop: anObject

	"This primitive fails if the object is not pinned"

	<primitive: 'primitiveGetObjectFromAddress'>

	^ self primitiveFailed	! !

!PointerUtils class methodsFor: 'private' stamp: ''!
objectForOop: anAddressAsInteger

	^ self primObjectForOop: anAddressAsInteger asInteger! !

!PointerUtils class methodsFor: 'private' stamp: ''!
oopForObjectForcePinInMemory: anObject

	anObject pinInMemory.
	^ self oopForObject: anObject! !

!Polygon commentStamp: ''!
I'm a Polygon PathShape (see PathShape).!
!Polygon methodsFor: 'enumerating' stamp: ''!
segmentsDo: aBlock
	"Evaluate the two-argument block with each vertex and its successor."

	self vertices size < 2 ifTrue: [^self].
	super segmentsDo: aBlock.
	aBlock
		value: self vertices last
		value: self vertices first! !

!Polygon methodsFor: 'testing' stamp: ''!
containsPoint: aPoint
	"Answer whether the receiver contains the given point."

	|wind|
	(self basicContainsPoint: aPoint) ifFalse: [^false].
	wind := 0.
	self segmentsDo: [:p1 :p2 |
		p1 y <= aPoint y
			ifTrue: [p2 y = aPoint y
						ifTrue: [(aPoint directionToLineFrom: p1 to: p2) = 0
							ifTrue: [^true]]
						ifFalse: [(p2 y > aPoint y and: [(aPoint directionToLineFrom: p1 to: p2) > 0])
							ifTrue: [wind := wind + 1]]]
			ifFalse: [p2 y = aPoint y
						ifTrue: [(aPoint directionToLineFrom: p1 to: p2) = 0
								ifTrue: [^true]].
					(p2 y < aPoint y and: [(aPoint directionToLineFrom: p1 to: p2) < 0])
							ifTrue: [wind := wind - 1]]].
	^wind ~= 0! !

!PolygonMorph commentStamp: ''!
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: 'shaping' stamp: ''!
diamondOval
	"Set my vertices to an array of edge midpoint vertices. Order of vertices is in the tradion of warpblt quads."
	
	| b |
	b := self bounds.
	self setVertices: { b leftCenter. b bottomCenter. b rightCenter. b topCenter }! !

!PolygonMorph methodsFor: 'cubic support' stamp: ''!
transform: coefficients toCubicPointPolynomialAt: vIndex 
	"From curve information assemble a 4-array of points representing the coefficents for curve segment between to points. Beginning point is first point in array endpoint is the pointSum of the array. Meant to be sent to newcurves idea of curve coefficents." 
	| transformed |
	transformed := (1 to: 4) collect: [:i | 
			((coefficients at: i) at: vIndex) @ ((coefficients at: 4 + i) at: vIndex)].
	^ Cubic withAll: transformed! !

!PolygonMorph methodsFor: '*Athens-Morphic' stamp: ''!
asAthensLinePathOn: anAthensCanvas
	| verts |
	verts := self adjustSegmentPointsForArrows.
	^ anAthensCanvas
		createPath: [ :builder | 
			verts notEmpty
				ifTrue: [ 
					builder absolute.
					builder moveTo: verts first.
					verts allButFirstDo: [ :p | builder lineTo: p ] ].
			self isClosed
				ifTrue: [ builder close ].
			builder ]! !

!PolygonMorph methodsFor: 'drawing' stamp: ''!
drawDashedBorderOn: aCanvas 
	self
		drawDashedBorderOn: aCanvas
		usingEnds: (Array with: vertices first with: vertices last)! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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: 'accessing' stamp: ''!
borderColor: aColor 

	super borderColor: aColor.
	(borderColor isColor and: [borderColor isTranslucentButNotTransparent]) 
		== (aColor isColor and: [aColor isTranslucentButNotTransparent]) 
			ifFalse: 
				["Need to recompute fillForm and borderForm
					if translucency of border changes."

				self releaseCachedState ]! !

!PolygonMorph methodsFor: 'smoothing' stamp: ''!
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: 'attachments' stamp: ''!
firstVertex
	^vertices first! !

!PolygonMorph methodsFor: 'dashes' stamp: ''!
borderDashOffset
	borderDashSpec size < 4 ifTrue: [^0.0].
	^ (borderDashSpec fourth) asFloat! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
lineWidth: anInteger

	self borderWidth: (anInteger rounded max: 1)! !

!PolygonMorph methodsFor: 'accessing' stamp: ''!
vertices
	^ vertices! !

!PolygonMorph methodsFor: 'editing' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
setDashOnStroke: anAthensStrokePaint
	| d commonOffset |
	d := self dashedBorder.
	commonOffset := d size > 3
		ifTrue: [ d fourth ]
		ifFalse: [ 0 ].
	anAthensStrokePaint
		dashes:
			{(d first).
			(d second)}
		offset: commonOffset! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
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: 'attachments' stamp: ''!
defaultAttachmentPointSpecs
	^{ 
		{ #firstVertex } .
		{ #midpoint } .
		{ #lastVertex }
		}! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
lineBorderWidth: anInteger

	self borderWidth: anInteger! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
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 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: ''!
removeHandles
	handles ifNotNil: [
		handles do: [:h | h delete].
		handles := nil].! !

!PolygonMorph methodsFor: 'accessing' stamp: ''!
fillStyle: newColor

	^ self isOpen
		ifTrue: [ self borderColor: newColor asColor "easy access to line color from halo"]
		ifFalse: [ super fillStyle: newColor ]! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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: 'rotate scale and flex' stamp: ''!
prepareForScaling
	"When scaling from a halo, I can do this without a flex shell"

	^ self! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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: 'testing' stamp: ''!
isCurvy
	"Test for significant curves.  
	Small smoothcurves in practice are straight."
	^ smoothCurve
		and: [vertices size > 2]! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
handlesShowingPhrase
	^ (self showingHandles
		ifTrue: ['hide handles']
		ifFalse: ['show handles']) translated! !

!PolygonMorph methodsFor: 'drawing' stamp: ''!
drawClippedBorderOn: aCanvas usingEnds: anArray 
	aCanvas clipBy: self bounds during:[:cc| self drawBorderOn: cc usingEnds: anArray].! !

!PolygonMorph methodsFor: 'smoothing' stamp: ''!
slopes: knots 
	"Choose slopes according to state of polygon"
	self isCurvy ifFalse: [^ self segmentedSlopesOf: knots ].
	^ closed
		ifTrue: [ self closedCubicSlopesOf: knots ]
		ifFalse: [ self naturalCubicSlopesOf: knots ]! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
addPolyLIneCurveMenuItems: aMenu hand: aHandMorph 

	aMenu addLine;
				addUpdating: #openOrClosePhrase
				target: self
				selector: #toggleOpenOrClosed.
			
			aMenu
				addUpdating: #smoothOrSegmentedPhrase
				target: self
				selector: #toggleSmoothing.! !

!PolygonMorph methodsFor: 'attachments' stamp: ''!
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 distanceTo: b).
		middle < dist
			ifTrue: [ ^(a + ((b - a) * (middle / dist))) asIntegerPoint ].
		middle := middle - dist.
	].
	self error: 'can''t happen'! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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: 'menu' stamp: ''!
addCustomMenuItems: aMenu hand: aHandMorph 
	| |
	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu
		addUpdating: #handlesShowingPhrase
		target: self
		selector: #showOrHideHandles.
	vertices size > 2
		ifTrue: [ self addPolyLIneCurveMenuItems: aMenu hand: aHandMorph ].
	aMenu add: 'specify dashed line' selector: #specifyDashedLine.
	self isOpen
		ifTrue: [self addPolyArrowMenuItems: aMenu hand: aHandMorph]
			ifFalse: [self addPolyShapingMenuItems: aMenu hand: aHandMorph]! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
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: 'accessing' stamp: ''!
couldHaveRoundedCorners
	^ false! !

!PolygonMorph methodsFor: 'attachments' stamp: ''!
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: 'private' stamp: ''!
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: 'geometry' stamp: ''!
lineBorderColor: aColor
	self borderColor: aColor! !

!PolygonMorph methodsFor: 'drawing' stamp: ''!
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: 'menu' stamp: ''!
showingHandles
	^ handles notNil! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
specifyDashedLine

	| executableSpec newSpec |
	executableSpec := UIManager default
		request:
'Enter a dash specification as
{ major dash length. minor dash length. minor dash color }
The major dash will have the normal border color.
A blank response will remove the dash specification.
[Note: You may give 5 items as, eg, {10. 5. Color white. 0. 3}
where the 4th ityem is zero, and the 5th is the number of pixels
by which the dashes will move in each step of animation]' translated
		initialAnswer: '{ 10. 5. Color red }'.
	executableSpec isEmptyOrNil ifTrue:
		[^ self stopStepping; dashedBorder: nil].
	newSpec := [self class compiler evaluate: executableSpec] onErrorDo:
		[^ self stopStepping; dashedBorder: nil].
	(newSpec first isNumber and: [newSpec second isNumber and: [newSpec third isColor]]) ifFalse:
		[^ self stopStepping; dashedBorder: nil].
	newSpec size = 3 ifTrue:
		[^ self stopStepping; dashedBorder: newSpec].
	(newSpec size = 5 and: [newSpec fourth isNumber and: [newSpec fifth isNumber]]) ifTrue:
		[^ self dashedBorder: newSpec; startStepping].! !

!PolygonMorph methodsFor: 'dashes' stamp: ''!
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: 'initialization' stamp: ''!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color
		r: 0.0
		g: 0.419
		b: 0.935! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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 distanceTo: aPoint.
		(closestPoint isNil or: [dist < minDist])
			ifTrue: [closestPoint := curvePoint.
					minDist := dist.
					closestVertexIndex := vertexIndex. ]].
	^ closestVertexIndex! !

!PolygonMorph methodsFor: 'drawing' stamp: ''!
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: 'event handling' stamp: ''!
handlesMouseDown: evt

	^ (super handlesMouseDown: evt) or: [evt shiftPressed]! !

!PolygonMorph methodsFor: 'cubic support' stamp: ''!
closedCubicSlopesOf: knots 
	"Sent to knots returns the slopes of a closed cubic spline.
	From the same set of java sources as naturalCubic. This is a smalltalk  
	transliteration of the java code."
	"from java code NatCubicClosed extends NatCubic  
	solves for the set of equations for all knots: 
	b1+4*b2+b3=3*(a3-a1)
	where a1 is (knots atWrap: index + 1) etc.
	and the b's are the slopes .
	by decomposing the matrix into upper triangular and lower matrices  
	and then back sustitution. See Spath 'Spline Algorithms for Curves  
	and Surfaces' pp 19--21. The D[i] are the derivatives at the knots.  
	"
	
	| v w x y z n1  D F G H |
	n1 := knots size.
	n1 < 3
		ifTrue: [self error: 'Less than 3 points makes a poor curve'].
	v := Array new: n1.
	w := Array new: n1.
	y := Array new: n1.
	
	D := Array new: n1.
	x := knots.
	z := 1.0 / 4.0.
	v at: 2 put: z.
	w at: 2 put: z.
	y at: 1 put: z * 3.0 * ((x at: 2) - (x at: n1)).
	H := 4.0.
	F := 3 * ((x at: 1) - (x at: n1 - 1)).
	G := 1.
	2 to: n1 - 1 do: [:k | 
			z := 1.0 / (4.0 - (v at: k)).
			v at: k + 1 put: z.
			w at: k + 1 put: z negated
					* (w at: k).
			y at: k put: z * (3.0 * ((x at: k + 1) - (x at: k - 1)) - (y at: k - 1)).
			H := H - (G * (w at: k)).
			F := F - (G * (y at: k - 1)).
			G := (v at: k) negated * G].
	H := H - (G + 1 * ((v at: n1) + (w at: n1))).
	y at: n1 put: F - (G + 1 * (y at: n1 - 1)).
	D at: n1 put: (y at: n1) / H.
	D at: n1 - 1 put: (y at: n1 - 1) - ((v at: n1) + (w at: n1) * (D at: n1)).
	(1 to: n1 - 2)
		reverseDo: [:k | D at: k put: (y at: k)
					- ((v at: k + 1) * (D at: k + 1)) - ((w at: k + 1) * (D at: n1))].
	^ D! !

!PolygonMorph methodsFor: 'attachments' stamp: ''!
lastVertex
	^vertices last! !

!PolygonMorph methodsFor: 'private' stamp: ''!
includesHandle: aMorph

	handles ifNil: [^ false].
	^ handles includes: aMorph! !

!PolygonMorph methodsFor: '*Athens-Morphic' stamp: ''!
adjustSegmentPointsForArrows
	" In the list of vertices, adjust first and last entry if this polygon uses arrows."

	| verts |
	(self isClosed or: [ self hasArrows not ])
		ifTrue: [ ^ self vertices ].
	verts := self vertices copy.
	(arrows == #back or: [ arrows == #both ])
		ifTrue: [ 
			| arrow |
			arrow := self arrowBoundsAt: verts first from: verts second.
			arrow size = 4
				ifTrue: [ verts at: 1 put: arrow third ]
				ifFalse: [ verts at: 1 put: (arrow copyFrom: 2 to: 3) average ] ].
	(arrows == #forward or: [ arrows == #both ])
		ifTrue: [ 
			| arrow |
			arrow := self arrowBoundsAt: verts last from: verts nextToLast.
			arrow size = 4
				ifTrue: [ verts at: verts size put: arrow third ]
				ifFalse: [ verts at: verts size put: (arrow copyFrom: 2 to: 3) average ] ].
	^ verts! !

!PolygonMorph methodsFor: 'accessing' stamp: ''!
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: 'menu' stamp: ''!
makeOpen
	closed := false.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !

!PolygonMorph methodsFor: 'testing' stamp: ''!
isClosed
	^ closed! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
lineBorderColor
	^self borderColor! !

!PolygonMorph methodsFor: 'dashes' stamp: ''!
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: 'drawing' stamp: ''!
drawBorderOn: aCanvas 
	self
		drawClippedBorderOn: aCanvas
		usingEnds: (Array with: vertices first with: vertices last)! !

!PolygonMorph methodsFor: 'private' stamp: ''!
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: 'geometry' stamp: ''!
closestPointTo: aPoint 
	| closestPoint minDist |
	closestPoint := minDist := nil.
	self lineSegmentsDo: 
			[:p1 :p2 | | dist curvePoint | 
			curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2.
			dist := curvePoint distanceTo: aPoint.
			(closestPoint isNil or: [dist < minDist]) 
				ifTrue: 
					[closestPoint := curvePoint.
					minDist := dist]].
	^closestPoint! !

!PolygonMorph methodsFor: 'private' stamp: ''!
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: 'geometry' stamp: ''!
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: 'private' stamp: ''!
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: 'accessing' stamp: ''!
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: 'stepping' stamp: ''!
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: 'rotate scale and flex' stamp: ''!
rotationDegrees

	^ self forwardDirection! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
toggleSmoothing

	smoothCurve := smoothCurve not.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !

!PolygonMorph methodsFor: 'dashes' stamp: ''!
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: 'editing' stamp: ''!
deleteVertexAt: anIndex
	"This acts as a backstop for MixedCurveMorph."
	self setVertices: (vertices
						copyReplaceFrom: anIndex
						to: anIndex
						with: #()).! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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: 'smoothing' stamp: ''!
coefficientsForMoreThanThreePoints 
	"Less than three points handled as segments by our lineSegmentsDo:"
	| verts coefficients vertXs slopeXs vertYs slopeYs bestSegments |
	verts := self vertices. 
	coefficients := {
		vertXs := verts collect: [:p | p x asFloat].
		slopeXs := self slopes: vertXs. 
		self changeInSlopes: slopeXs of: vertXs .
		self changeOfChangesInSlopes: slopeXs of: vertXs. 
		vertYs := verts collect: [:p | p y asFloat].
		slopeYs := self slopes: vertYs.
		self changeInSlopes: slopeYs of: vertYs.
		self changeOfChangesInSlopes: slopeYs of: vertYs. 
		Array new: verts size withAll: 12}.
		
		
	bestSegments := (1 to: verts size) collect: [:i | (self transform: coefficients toCubicPointPolynomialAt: i) bestSegments].
	coefficients at: 9 put:bestSegments.
	
	curveState := {coefficients. nil. nil}.
	self computeNextToEndPoints.
	^ coefficients! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
makeNoArrows
	arrows := #none.
	self computeBounds! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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: 'attachments' stamp: ''!
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: 'testing' stamp: ''!
hasArrows
	"Are all the conditions meet for having arrows?"
	^ (closed or: [arrows == #none or: [vertices size < 2]]) not! !

!PolygonMorph methodsFor: 'stepping' stamp: ''!
stepTime

	^ 100! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
makeBackArrow
	arrows := #back.
	self computeBounds! !

!PolygonMorph methodsFor: 'editing' stamp: ''!
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: 'testing' stamp: ''!
isCurve
	^ smoothCurve! !

!PolygonMorph methodsFor: 'private' stamp: ''!
lineSegments
	| lineSegments |
	lineSegments := OrderedCollection new.
	self lineSegmentsDo: [:p1 :p2 | lineSegments addLast: (Array with: p1 with: p2)].
	^ lineSegments! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
rotationCenter
	"Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	| refPos |
	refPos := self valueOfProperty: #referencePosition ifAbsent: [^ 0.5@0.5].
	^ (refPos - self bounds origin) / self bounds extent asFloatPoint! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
setRotationCenterFrom: aPoint
	"Polygons store their referencePosition."
	self setProperty: #referencePosition toValue: aPoint! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
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: 'editing' stamp: ''!
dropVertex: ix event: evt fromHandle: handle
	"Leave vertex in new position. If dropped ontop another vertex delete this one. Check for too few vertices before deleting. The alternative is not pretty"
	
	| p |
	p := vertices at: ix.
	(vertices size >= 2
			and: ["check for too few vertices before deleting. The alternative 
				is not pretty -wiz"
				((vertices atWrap: ix - 1)
						distanceTo: p)
						< 3
					or: [((vertices atWrap: ix + 1)
							distanceTo: 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: 'initialization' stamp: ''!
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: 'drawing' stamp: ''!
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: 'event handling' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
computeCurvedSegmentCtrlPoints
	"compute control points for the curved polygon.
For every vertice C take the two edges L and R. Compute the line T between the midpoints of L and R.
Use T is the tangent on the C. T is divided by the C with the same ration as L/R.
The start and end point of T defines the controlpoint c1 and c2
for the current vertice C.
"

	| ctrls vert |
	vert := self adjustSegmentPointsForArrows.
	ctrls := (1 to: vert size)
		collect: [ :i | 
			| prior current next lenpc lencn ctrl1 ctrl2 tangent |
			prior := vert atWrap: i - 1.
			current := vert atWrap: i.
			next := vert atWrap: i + 1.
			tangent := (next - prior) / 2.
			lenpc := current distanceTo: prior.
			lencn := next distanceTo: current.
			lenpc = 0 ifTrue:[
				ctrl1 := prior]
			ifFalse:[	ctrl1 := current - (tangent / (1 + (lencn / lenpc)))].
				lencn = 0 ifTrue:[
					ctrl2 := next]
				ifFalse:[
			ctrl2 := current + (tangent / (1 + (lenpc / lencn)))].
		"collect ctrl1 current and ctrl2"
			{(ctrl1 asFloatPoint).
			current.
			(ctrl2 asFloatPoint)} ].
	^ ctrls! !

!PolygonMorph methodsFor: 'initialization' stamp: ''!
beSmoothCurve

	smoothCurve == true ifFalse:
		[smoothCurve := true.
		self computeBounds]! !

!PolygonMorph methodsFor: 'shaping' stamp: ''!
rectangleOval
	"Set my vertices to an array of corner vertices.
	Order of vertices is in the tradion of warpblt quads."

	self setVertices: self bounds corners.! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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: ''!
lineBorderWidth

	^self borderWidth! !

!PolygonMorph methodsFor: 'accessing' stamp: ''!
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: 'geometry' stamp: ''!
lineColor: aColor
	self borderColor: aColor! !

!PolygonMorph methodsFor: 'attachments' stamp: ''!
endShapeColor: aColor
	self borderColor: aColor.
	self isClosed ifTrue: [ self color: aColor ].! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
makeForwardArrow
	arrows := #forward.
	self computeBounds! !

!PolygonMorph methodsFor: 'private' stamp: ''!
transformVerticesFrom: oldOwner to: newOwner
	| oldTransform newTransform world newVertices |
	world := self world.
	oldTransform := oldOwner
		ifNil: [ IdentityTransform new ]
		ifNotNil: [ oldOwner transformFrom: world ].
	newTransform := newOwner
		ifNil: [ IdentityTransform new ]
		ifNotNil: [ newOwner transformFrom: world ].
	newVertices := vertices collect: [ :ea | newTransform globalPointToLocal:
		(oldTransform localPointToGlobal: ea) ].
	self setVertices: newVertices.! !

!PolygonMorph methodsFor: 'editing' stamp: ''!
verticesAt: ix put: newPoint
	vertices at: ix put: newPoint.
	self computeBounds! !

!PolygonMorph methodsFor: '*Athens-Morphic' stamp: ''!
asAthensCurvedOpenPathOn: anAthensCanvas
"like asAthensCurvedPathOn: but use quadratic curve for start and end points"
	| points |
	points := self computeCurvedSegmentCtrlPoints.
	^ anAthensCanvas
		createPath: [ :builder | 
			self vertices notEmpty
				ifTrue: [ 
					| prior |
					"points contains {ctrl1 vertice ctrl2}"
					prior := points first.
					builder absolute.
					builder moveTo: prior second.
					builder curveVia: (points at: 2) first to: (points at: 2) second.
					prior := points at: 2.
					3 to: points size - 1 do: [ :index | 
							| p |
							p := points at: index.
							builder curveVia: prior third and: p first to: p second.
							prior := p ].
					builder curveVia: prior third to: points last second].
			builder ]! !

!PolygonMorph methodsFor: 'private' stamp: ''!
filledForm
	"Note: The filled form is actually 2 pixels bigger than bounds, and the point corresponding to this morphs' position is at 1@1 in the form.  This is due to the details of the fillig routines, at least one of which requires an extra 1-pixel margin around the outside.  Computation of the filled form is done only on demand."
	| bb origin |
	closed ifFalse: [^ filledForm := nil].
	filledForm ifNotNil: [^ filledForm].
	filledForm := Form extent: bounds extent+2.

	"Draw the border..."
	bb := (BitBlt toForm: filledForm) sourceForm: nil; fillColor: Color black;
			combinationRule: Form over; width: 1; height: 1.
	origin := bounds topLeft asIntegerPoint-1.
	self lineSegmentsDo: [:p1 :p2 | bb drawFrom: p1 asIntegerPoint-origin
										to: p2 asIntegerPoint-origin].

	"Fill it in..."
	filledForm convexShapeFill: Color black.

	(borderColor isColor and: [borderColor isTranslucentButNotTransparent]) ifTrue:
		["If border is stored as a form, then erase any overlap now."
		filledForm copy: self borderForm boundingBox from: self borderForm
			to: 1@1 rule: Form erase].

	^ filledForm! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
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: ''!
standardArrows

	self removeProperty: #arrowSpec.
	self computeBounds! !

!PolygonMorph methodsFor: 'editing' stamp: ''!
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: 'private' stamp: ''!
computeArrowFormAt: endPoint from: priorPoint 
	"Compute a triangle oriented along the line from priorPoint to  
	endPoint. Then draw those lines in a form and return that  
	form, with appropriate offset"

	| p1 pts box arrowForm bb origin |
	pts := self arrowBoundsAt: endPoint from: priorPoint.
	box := ((pts first rectangle: pts last) encompass: (pts second)) expandBy: 1.
	arrowForm := Form extent: box extent asIntegerPoint.
	bb := (BitBlt toForm: arrowForm)
				sourceForm: nil;
				fillColor: Color black;
				combinationRule: Form over;
				width: 1;
				height: 1.
	origin := box topLeft.
	p1 := pts last - origin.
	pts do: 
			[:p | 
			bb drawFrom: p1 to: p - origin.
			p1 := p - origin].
	arrowForm convexShapeFill: Color black.
	^arrowForm offset: box topLeft! !

!PolygonMorph methodsFor: 'cubic support' stamp: ''!
segmentedSlopesOf: knots 
	"For a collection of floats. Returns the slopes for straight 
	segments between vertices."
	"last slope closes the polygon. Always return same size as 
	self. "
	^ knots collectWithIndex: [:x :i | (knots atWrap: i + 1) - x]! !

!PolygonMorph methodsFor: 'smoothing' stamp: ''!
coefficients
	curveState ifNotNil: [^ curveState at: 1].
	^ self vertices size < 1 
		ifTrue: [ self  ]
		ifFalse: [ self coefficientsForMoreThanThreePoints ].! !

!PolygonMorph methodsFor: 'cubic support' stamp: ''!
naturalCubicSlopesOf: knots 
	"Sent to knots returns the slopes of a natural cubic curve fit."
	"We solve the equation for knots with end conditions:  
	2*b1+b2 = 3(a1 - a0) 
	bN1+2*bN = 3*(aN-aN1)
	and inbetween:
	b2+4*b3+b4=3*(a4-a2)
	where a2 is (knots atWrap: index + 1) etc.
	and the b's are the slopes .
	N is the last index (knots size)
	N1 is N-1.
	 
	by using row operations to convert the matrix to upper  
	triangular and then back sustitution. The D[i] are the derivatives at the  
	knots."
	
	| x gamma delta D n1 |
	n1 := knots size.
	n1 < 3
		ifTrue: [self error: 'Less than 3 points makes a poor curve'].
	x := knots.
	gamma := Array new: n1.
	delta := Array new: n1.
	
	D := Array new: n1.
	gamma at: 1 put: 1.0 / 2.0.
	2 to: n1 - 1 do: [:i | gamma at: i put: 1.0 / (4.0
						- (gamma at: i - 1))].
	gamma at: n1 put: 1.0 / (2.0
				- (gamma at: n1 - 1)).
	delta at: 1 put: 3.0 * ((x at: 2)
				- (x at: 1))
			* (gamma at: 1).
	2 to: n1 - 1 do: [:i | delta at: i put: 3.0 * ((x at: i + 1)
						- (x at: i - 1))
					- (delta at: i - 1)
					* (gamma at: i)].
	delta at: n1 put: 3.0 * ((x at: n1)
				- (x at: n1 - 1))
			- (delta at: n1 - 1)
			* (gamma at: n1).
	D
		at: n1
		put: (delta at: n1).
	(1 to: n1 - 1)
		reverseDo: [:i | D at: i put: (delta at: i)
					- ((gamma at: i)
							* (D at: i + 1))].
	^ D! !

!PolygonMorph methodsFor: 'private' stamp: ''!
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: 'editing' stamp: ''!
clickVertex: ix event: evt fromHandle: handle
	"Backstop for MixedCurveMorph"! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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
		ifNil: [ self removeProperty: #referencePosition ]
		ifNotNil: [ box := self bounds.
			self setProperty: #referencePosition toValue: box origin + ( aPointOrNil * box extent )
			]! !

!PolygonMorph methodsFor: 'rotate scale and flex' stamp: ''!
prepareForRotating
	"When rotating from a halo, I can do this without a flex shell"

	^ self! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
makeClosed
	closed := true.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !

!PolygonMorph methodsFor: 'attachments' stamp: ''!
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 distanceTo: b) ].
	^ length.! !

!PolygonMorph methodsFor: 'editing' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
setSecondColorDashOnStroke: anAthensStrokePaint
	| d c commonOffset |
	d := self dashedBorder.
	c := d third.
	commonOffset := d size > 3
		ifTrue: [ d fourth ]
		ifFalse: [ 0 ].
	anAthensStrokePaint fillPaint: c.
	anAthensStrokePaint
		dashes:
			{(d second).
			(d first)}
		offset: commonOffset + d second! !

!PolygonMorph methodsFor: 'cubic support' stamp: ''!
changeInSlopes: slopes of: verts 
	"A message to knots of a spline. Returns an array with the 3rd cubic coeff."
	"The last nth item is correct iff this is a closed cubic.
	Presumably that is the only time we care.
	We always return the same sized array as self."
	| n slopeChanges |
	n := verts size.
	n = slopes size ifFalse: [^ self error: 'vertices and slopes differ in number'].
	slopeChanges := Array new: n.
	1 to: n do: [:i | slopeChanges at: i put: (verts atWrap: i + 1)
					- (verts at: i) * 3 - ((slopes at: i) * 2)
					- (slopes atWrap: i + 1)].
	^ slopeChanges! !

!PolygonMorph methodsFor: 'drawing' stamp: ''!
drawDropShadowOn: aCanvas 
	"Display the receiver, a spline curve, approximated by straight 
	line segments."
	self assert: [vertices notEmpty] description: 'a polygon must have at least one point'.
	closed 
		ifTrue: [aCanvas drawPolygon: self getVertices fillStyle: self shadowColor].! !

!PolygonMorph methodsFor: 'accessing' stamp: ''!
borderWidth: anInteger

	borderColor ifNil: [ borderColor := Color black ].
	borderWidth := anInteger max: 0.
	self computeBounds! !

!PolygonMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
arrows
	^arrows! !

!PolygonMorph methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	vertices := Array
				with: 5 @ 0
				with: 20 @ 10
				with: 0 @ 20.
	closed := true.
	smoothCurve := false.
	arrows := #none.
	self computeBounds.
	self beSmoothCurve.
	self diamondOval.! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
intersects: aRectangle 
	"Answer whether any of my segments intersects aRectangle, which is in World coordinates."
	| rect |
	(super intersects: aRectangle) ifFalse: [ ^false ].
	rect := self bounds: aRectangle in: self world.
	self
		lineSegmentsDo: [:p1 :p2 | (rect intersectsLineFrom: p1 to: p2)
				ifTrue: [^ true]].
	^ false! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
makeBothArrows
	arrows := #both.
	self computeBounds! !

!PolygonMorph methodsFor: '*Athens-Morphic' stamp: ''!
asAthensCurvedPathOn: anAthensCanvas
	| points |
	points := self computeCurvedSegmentCtrlPoints.
	^ anAthensCanvas
		createPath: [ :builder | 
			self vertices notEmpty
				ifTrue: [ 
					| prior | "points contains {ctrl1 vertice ctrl2}"
					prior := points first.
					builder absolute.
					builder moveTo: prior second.
					points allButFirst
						do: [ :p | 
							builder curveVia: prior third and: p first to: p second.
							prior := p ].
					self isClosed
						ifTrue: [ 
							builder curveVia: prior third and: points first first to: points first second.
							builder close ] ].
			builder ]! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
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' selector: #customizeArrows:.
	(self hasProperty: #arrowSpec)
		ifTrue: [ aMenu add: 'standard arrows' selector: #standardArrows ]! !

!PolygonMorph methodsFor: 'testing' stamp: ''!
isLineMorph
	^closed not! !

!PolygonMorph methodsFor: 'initialization' stamp: ''!
beStraightSegments

	smoothCurve == false ifFalse:
		[smoothCurve := false.
		self computeBounds]! !

!PolygonMorph methodsFor: 'testing' stamp: ''!
isAnimated

	borderDashSpec ifNil: [^false].
	^ borderDashSpec size = 5 and: [(borderDashSpec fifth) > 0]! !

!PolygonMorph methodsFor: 'drawing' stamp: ''!
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: 'smoothing' stamp: ''!
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: '*Athens-Morphic' stamp: ''!
drawArrowsOnAthensCanvas: aAthensCanvas 
	"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
				drawArrowOnAthensCanvas: aAthensCanvas
				at: vertices last
				from: self nextToLastPoint) ].

	(arrows == #back or: [arrows == #both])
		ifTrue: [ array at: 1 put: (self
				drawArrowOnAthensCanvas: aAthensCanvas
				at: vertices first
				from: self nextToFirstPoint) ].

	^array! !

!PolygonMorph methodsFor: 'smoothing' stamp: ''!
nextToFirstPoint
	"For arrow direction"

	^ self isCurvy
		ifTrue: [ curveState ifNil: [ self coefficients ].
			curveState second ]
		ifFalse: [ vertices second ]! !

!PolygonMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!PolygonMorph methodsFor: 'drawing' stamp: ''!
areasRemainingToFill: aRectangle
	"Could be improved by quick check of inner rectangle"

	^ Array with: aRectangle! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
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: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color orange! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
flipHAroundX: centerX
	"Flip me horizontally around the center.  If centerX is nil, compute my center of gravity."

	| cent |
	cent := centerX 
		ifNil: [ bounds center x ] "average is the center"
		ifNotNil: [ centerX ].
	self setVertices: (vertices collect: [ :vv | ((vv x - cent) * -1 + cent) @ vv y ]) reversed.! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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: 'private' stamp: ''!
setVertices: newVertices
	vertices := newVertices.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
transformedBy: aTransform
	self setVertices: (self vertices collect:[:v| aTransform localPointToGlobal: v])! !

!PolygonMorph methodsFor: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
addPolyShapingMenuItems: aMenu hand: aHandMorph
	aMenu addLine.
	aMenu addWithLabel: 'make inscribed diamondOval' enablement: [ self isClosed ] action: #diamondOval.
	aMenu addWithLabel: 'make enclosing rectangleOval' enablement: [ self isClosed ] action: #rectangleOval! !

!PolygonMorph methodsFor: 'drawing' stamp: ''!
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: 'stepping' stamp: ''!
wantsSteps
	super wantsSteps ifTrue: [^true].

	"For crawling ants effect of dashed line."
	^ self isAnimated! !

!PolygonMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawArrowOnAthensCanvas: anAthensCanvas at: endPoint from: priorPoint
	"Draw a triangle oriented along the line from priorPoint to  
	endPoint. Answer the wingBase."

	| pts spec wingBase path |
	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 ].
	path := anAthensCanvas
		createPath: [ :builder | 
			builder absolute.
			builder moveTo: pts first.
			pts allButFirst do: [ :p | builder lineTo: p ]. builder close. ].
	spec x sign = spec y sign
		ifTrue: [ 
			anAthensCanvas setPaint: self borderColor]
		ifFalse: [ 
			(anAthensCanvas
				setStrokePaint: self borderColor)
				width: (borderWidth + 1) // 2].
	anAthensCanvas drawShape: path.
	^ wingBase! !

!PolygonMorph methodsFor: '*Athens-Morphic' stamp: ''!
hasTwoColorDash
	" return true if the dash spec has another color"

	^ self dashedBorder notNil and: [ self dashedBorder size > 2 ]! !

!PolygonMorph methodsFor: 'smoothing' stamp: ''!
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: 'menu' stamp: ''!
toggleHandles

	handles ifNil: [self addHandles] ifNotNil: [self removeHandles].! !

!PolygonMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!PolygonMorph methodsFor: 'private' stamp: ''!
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
				ifNil: [ 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: 'geometry' stamp: ''!
straighten
	self setVertices: { vertices first . vertices last }! !

!PolygonMorph methodsFor: 'smoothing' stamp: ''!
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: 'accessing' stamp: ''!
toggleOpenOrClosed
	"toggle the open/closed status of the receiver"
	closed ifTrue: [ self makeOpen ] ifFalse: [ self makeClosed ]! !

!PolygonMorph methodsFor: 'testing' stamp: ''!
isOpen
	^ closed not! !

!PolygonMorph methodsFor: '*Athens-Morphic' stamp: ''!
asAthensPathOn: anAthensCanvas
	^ self isCurvy
		ifTrue: [ 
			self isOpen
				ifTrue: [ self asAthensCurvedOpenPathOn: anAthensCanvas ]
				ifFalse: [ self asAthensCurvedPathOn: anAthensCanvas ] ]
		ifFalse: [ self asAthensLinePathOn: anAthensCanvas ]! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
lineColor
	^self borderColor! !

!PolygonMorph methodsFor: 'editing' stamp: ''!
dragVertex: ix event: evt fromHandle: handle
	| p |
	p := evt cursorPoint.
	handle position: p - (handle extent // 2).
	self verticesAt: ix put: p! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
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: 'smoothing' stamp: ''!
nextToLastPoint
	"For arrow direction"

	^ self isCurvy
		ifTrue: [ curveState ifNil: [ self coefficients ].
			curveState third ]
		ifFalse: [ vertices at: vertices size - 1 ]! !

!PolygonMorph methodsFor: 'cubic support' stamp: ''!
changeOfChangesInSlopes: slopes of: verts
	"A message to knots of a spline. Returns an array with the 4rd 
	cubic coeff."
	"The last nth item is correct iff this is a closed cubic. 
	Presumably that is the only time we care. 
	We always return the same sized array as self."
	| n changes |
	n := verts size.
	n = slopes size ifFalse: [^ self error: 'vertices and slopes differ in number'].
	changes := Array new: n.
	1 to: n do: [:i | changes at: i put: (verts at: i)
					- (verts atWrap: i + 1) * 2
					+ (slopes at: i)
					+ (slopes atWrap: i + 1)].
	^ changes! !

!PolygonMorph methodsFor: 'caching' stamp: ''!
releaseCachedState

	super releaseCachedState.
	filledForm := nil.
	arrowForms := nil.
	borderForm := nil.
	curveState := nil.
	(self hasProperty: #flex) ifTrue:
		[self removeProperty: #flex].! !

!PolygonMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	| border shape stroke |
	border := self borderStyle.
	shape := self asAthensPathOn: anAthensCanvas.
	self isClosed
		ifTrue: [ 
			anAthensCanvas setPaint: self fillStyle.
			anAthensCanvas drawShape: shape ].
	stroke := anAthensCanvas setStrokePaint: border color.
	stroke width: border width.
	self dashedBorder notNil
		ifTrue: [ self setDashOnStroke: stroke ].
	anAthensCanvas drawShape: shape.
	self hasTwoColorDash
		ifTrue: [ 
			self setSecondColorDashOnStroke: stroke.
			anAthensCanvas drawShape: shape ].
	self drawArrowsOnAthensCanvas: anAthensCanvas! !

!PolygonMorph methodsFor: 'accessing' stamp: ''!
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: 'editing' stamp: ''!
handleColorAt: vertIndex
      "This is a backstop for MixedCurveMorph"

	^ Color yellow! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
referencePosition 
	"Return the current reference position of the receiver"
	^ self valueOfProperty: #referencePosition ifAbsent: [super referencePosition]! !

!PolygonMorph methodsFor: 'drawing' stamp: ''!
drawOnFormCanvas: aCanvas 
	"Display the receiver, a spline curve, approximated by straight line segments."

	vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point'].
	closed & color isTransparent not
		ifTrue: [aCanvas stencil: self filledForm at: bounds topLeft - 1 color: color].
	(borderColor isColor and: [borderColor isTranslucentButNotTransparent])
		ifTrue: [aCanvas stencil: self borderForm at: bounds topLeft color: borderColor]
		ifFalse: [self drawBorderOn: aCanvas].
	self arrowForms do:
		[:f | aCanvas 
				stencil: f 
				at: f offset
				color: (borderColor isColor ifTrue: [borderColor] ifFalse: [color])]! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
arrowSpec: specPt
	"Specify a custom arrow for this line.
	specPt x abs gives the length of the arrow (point to base) in terms of borderWidth.
	If specPt x is negative, then the base of the arrow will be concave.
	specPt y abs gives the width of the arrow.
	The standard arrow is equivalent to arrowSpec: PolygonMorph defaultArrowSpec.
	See arrowBoundsAt:From: for details."

	self setProperty: #arrowSpec toValue: specPt.
	self computeBounds! !

!PolygonMorph methodsFor: 'dashes' stamp: ''!
vertexAt: n
	^vertices at: (n min: vertices size).! !

!PolygonMorph methodsFor: 'menu' stamp: ''!
showOrHideHandles
	self showingHandles
		ifTrue:	[self removeHandles]
		ifFalse:	[self addHandles]! !

!PolygonMorph methodsFor: 'accessing' stamp: ''!
fillStyle

	^ self isOpen
		ifTrue: [ self borderColor  "easy access to line color from halo"]
		ifFalse: [ super fillStyle ]! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
isBordered
	^false! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
flipVAroundY: centerY
	"Flip me vertically around the center.  If centerY is nil, compute my center of gravity."

	| cent |
	cent := centerY 
		ifNil: [ bounds center y ]		"average is the center"
		ifNotNil: [ centerY ].
	self setVertices: (vertices collect: [:vv |
			vv x @ ((vv y - cent) * -1 + cent)]) reversed.! !

!PolygonMorph methodsFor: 'private' stamp: ''!
arrowBoundsAt: endPoint from: priorPoint
	"Answer a triangle oriented along the line from priorPoint to endPoint."

	| d v angle wingBase arrowSpec length width |
	v := endPoint - priorPoint.
	angle := v degrees.
	d := borderWidth max: 1.
	arrowSpec := self valueOfProperty: #arrowSpec ifAbsent: [ PolygonMorph defaultArrowSpec ].
	length := arrowSpec x abs.
	width := arrowSpec y abs.
	wingBase := endPoint + (Point r: d * length degrees: angle + 180.0).
	^ arrowSpec x >= 0
		ifTrue: [ {endPoint . (wingBase + (Point r: d * width degrees: angle + 125.0)) . (wingBase + (Point r: d * width degrees: angle - 125.0))} ]
		ifFalse:
			[ "Negative length means concave base." {endPoint . (wingBase + (Point r: d * width degrees: angle + 125.0)) . wingBase . (wingBase + (Point r: d * width degrees: angle - 125.0))} ]! !

!PolygonMorph methodsFor: 'testing' stamp: ''!
containsPoint: aPoint
	(super containsPoint: aPoint) ifFalse: [^ false].

	(closed and: [color isTransparent not]) ifTrue:
		[ ^ (self filledForm pixelValueAt: aPoint - bounds topLeft + 1) > 0].

	self lineSegmentsDo:
		[ :p1 :p2 |
		(aPoint onLineFrom: p1 to: p2 within: (3 max: borderWidth+1//2) asFloat)
				ifTrue: [^ true]].

	self arrowForms do:
		[ :f | (f pixelValueAt: aPoint - f offset) > 0 ifTrue: [^ true]].

	^ false! !

!PolygonMorph methodsFor: 'geometry' stamp: ''!
lineWidth

	^self borderWidth! !

!PolygonMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!PolygonMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!PolygonMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!PolygonMorph class methodsFor: 'examples' stamp: ''!
example1
	<sampleInstance>
	"self example1"
	^ (PolygonMorph
		vertices: {261@400. 388@519. 302@595. 	222@500.	141@583. 34@444}
		color: Color blue
		borderWidth: 3
		borderColor: Color black) openInWorld! !

!PolygonMorph class methodsFor: 'instance creation' stamp: ''!
fromHandFreehand: hand
	"Let the user draw a polygon, holding the mouse down, and ending by clicking within 5 of the first point..."
	"self fromHandFreehand: ActiveHand"
	
	| p1 poly pN opposite |
	"wait till guy will press the mouse button"
	hand captureEventsUntil: [:evt |
		evt isMouse ifTrue: [ p1 := evt cursorPoint].
		(evt isMouse and: [ evt anyButtonPressed ])  ].
	
	opposite := (Display colorAt: p1) negated.
	opposite = Color transparent ifTrue: [opposite := Color red].
	(poly := LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld.
	
	hand captureEventsWhile: [:evt |
		
		evt isMouse ifTrue:[ 
			pN := evt cursorPoint.
			(pN distanceTo: 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: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!PolygonMorph class methodsFor: 'examples' stamp: ''!
example4
	"self example4"
	| poly | 
	poly :=  (PolygonMorph
		vertices: {261@400. 388@519. 302@595. 	222@500.	141@583. 34@444}
		color: Color blue
		borderWidth: 3
		borderColor: Color black).
	poly dashedBorder: { 5 .
		5.
		Color red.
		50 .
		0 }.
	poly openInWorld! !

!PolygonMorph class methodsFor: 'examples' stamp: ''!
example3
	"self example3"
	| poly | 
	poly := PolygonMorph
				vertices: {261@400. 388@519. 302@595. 	222@500.	141@583. 34@444}
				color: Color blue
				borderWidth: 3
				borderColor: Color black.
	poly makeOpen.
	poly openInWorld! !

!PolygonMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!PolygonMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!PolygonMorph class methodsFor: 'examples' stamp: ''!
example2
	"self example2"
	| poly | 
	poly := PolygonMorph
		vertices: {261@400. 388@519. 302@595. 	222@500.	141@583. 34@444}
		color: Color blue
		borderWidth: 3
		borderColor: Color black.
	poly beSmoothCurve.
	poly openInWorld! !

!PolygonMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!PolygonMorph class methodsFor: 'instance creation' stamp: ''!
arrowPrototype
	"Answer an instance of the receiver that will serve as a prototypical arrow"
	"PolygonMorph arrowPrototype openInWorld"
	
	| aa |
	aa := self new. 
	aa vertices: (Array with: 0@0 with: 40@40) 
		color: Color black 
		borderWidth: 2 
		borderColor: Color black.
	aa makeForwardArrow.	
	aa computeBounds.
	^ aa! !

!PolygonMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!PolygonMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!PolygonMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!PolygonMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!PolygonMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!PolygonMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!PolygonMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!PolygonMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!PolygonMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!PolygonMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!PolygonMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!PolygonMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!PolygonMorph class methodsFor: 'instance creation' stamp: ''!
fromHand: hand
	"Let the user draw a polygon, clicking at each vertex, and ending by clicking within 5 of the first point..."
	"self fromHand: ActiveHand"
	
	| p1 poly oldVerts pN opposite |
	"wait till guy will press the mouse button"
	hand captureEventsUntil: [:evt |
		evt isMouse ifTrue: [ p1 := evt cursorPoint].
		(evt isMouse and: [ evt anyButtonPressed ]) not ].
	
	opposite := (Display colorAt: p1) negated.
	opposite = Color transparent ifTrue: [opposite := Color red].
	(poly := LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld.
	oldVerts := {p1}.
	
	[true] whileTrue: [
		"wait till button release"
		hand captureEventsWhile: [:evt |
			evt isMouse 
				ifTrue: [ 
					pN := evt cursorPoint.
					poly setVertices: (oldVerts copyWith: pN).
					evt anyButtonPressed ] 
				ifFalse: [ true ] ].

		(oldVerts size > 1 and: [(pN distanceTo: 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: 'settings' stamp: ''!
defaultArrowSpec
	^ 5@4! !

!PolygonMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!PolygonMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!PolygonMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!PolygonMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!PolygonMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!PolygonMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!PolygonMorph class methodsFor: 'instance creation' stamp: ''!
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: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!PolygonMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!PolygonMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!PolygonMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!PolygonMorphTest commentStamp: ''!
This class holds tests for PolygonMorph!
!PolygonMorphTest methodsFor: 'tests' stamp: ''!
testBoundsBug1035
	"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 equals: (0 @ 0 extent: 100 @ 100).
	self assert: submorph bounds equals: (10 @ 10 corner: 90 @ 90)! !

!PolymorphSystemSettings commentStamp: ''!
I provide settings for Morphic appearance (theme, fonts, colors, ...) that can be found and changed in the Settings browser.!
!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopGradientDirection
	"#Radial #Vertical or #Horizontal"
	^ DesktopGradientDirection ifNil: [DesktopGradientDirection := #Vertical]! !

!PolymorphSystemSettings class methodsFor: 'settings' stamp: ''!
morphicHaloSettingsOn: aBuilder 
	(aBuilder group: #halo)
		label: 'Halo';
		parent: #morphic;
		description: 'All halo settings';
		noOrdering;
		with: [
			(aBuilder setting: #cycleHalosBothDirections)
				label: 'Cycle both directions';
				target: Morph;
				default: false;
				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)'.
			(aBuilder setting: #haloEnclosesFullBounds)
				label: 'Encloses fullbounds';
				default: false;
				target: HaloMorph;
				description: 'If true, halos will enclose the full bounds of the target Morph, rather than just the bounds'.
			(aBuilder setting: #showBoundsInHalo)
				label: 'Exhibits bounds' ;
				target: HaloMorph;
				default: false;
				description: 'If true, halos will include a fine rectangle around the bounds of the target morph.'
		]! !

!PolymorphSystemSettings class methodsFor: 'morphic' stamp: ''!
uiThemeClass
	^ UITheme current class
! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopLogoFileName
	^ DesktopLogoFileName ifNil: [DesktopLogoFileName := '']! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
showDesktopLogo: aBoolean
	ShowDesktopLogo = aBoolean ifTrue: [^ self].
	ShowDesktopLogo := aBoolean.
	self desktopLogoChanged! !

!PolymorphSystemSettings class methodsFor: 'sound' stamp: ''!
soundThemeClass
	^ SoundTheme current class
! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
pharoLogoForm
	^ Form fromBinaryStream: self pharoLogoContents base64Decoded readStream! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopColor
	^ DesktopColor ifNil: [DesktopColor := self currentWorld defaultWorldColor] ! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
showDesktopLogo
	^ ShowDesktopLogo ifNil: [ShowDesktopLogo := true]! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopImageFileName
	^ DesktopImageFileName ifNil: [DesktopImageFileName := '']! !

!PolymorphSystemSettings class methodsFor: 'morphic' stamp: ''!
morphicMenuSettingsOn: aBuilder 
	(aBuilder group: #menu)
		label: 'Menus';
		parent: #morphic;
		description: 'All menu settings' ;
		target: UITheme;
		targetSelector: #currentSettings;
		noOrdering;
		with: [
			(aBuilder setting: #preferGradientFill)
				label: 'Gradient filling' ;
				default: false;
				description: 'If true, then menus will have a gradient look' .
			(aBuilder setting: #flatMenu)
				label: 'Flat appearance' ;
				default: true;
				description: 'If true, then menu will without 3D like borders.' .
			(aBuilder setting: #autoMenuColor)
				label: 'Computed color' ;
				default: false;
				description: 'If true, then the menu color will be computed from world dressing.' .
			(aBuilder setting: #menuColor)
				label: 'Menu color';
				default: (Color r: 0.823069403714565 g: 0.823069403714565 b: 0.823069403714565 alpha: 1.0);
				description: 'The menu color to use if it is not computed automatically (see the ''Computed color'' setting)' .
			(aBuilder setting: #menuSelectionColor)
				label: 'Menu selection color' ;
				default: (Color r: 0.38025415444770283 g: 0.6383186705767351 b: 0.8817204301075269 alpha: 1.0);
				description: 'The background color of a selected menu item' .
			(aBuilder setting: #menuSelectionTextColor)
				description: 'The text color of a selected menu item' ;
				default: Color black;
				label: 'Menu selection text color' .
		]! !

!PolymorphSystemSettings class methodsFor: 'morphic' stamp: ''!
morphicSettingsOn: aBuilder 
	(aBuilder group: #morphic)
		label: 'Morphic';
		description: 'All morphic settings';
		noOrdering;
		with: [
			self morphicWindowsSettingsOn: aBuilder.
			self morphicMenuSettingsOn: aBuilder.
			self morphicHaloSettingsOn: aBuilder.
			(aBuilder setting: #keyboardFocusOnMouseDown)
				label: 'Keyboard focus on mouse down';
				default: true;
				target: ModelMorph;
				description: 'When enabled the mouse button must be clicked within a morph for it to take the keyboard focus.' .
			(aBuilder setting: #mouseOverForKeyboardFocus)
				label: 'Lose keyboard focus when mouse leave';
				target: ModelMorph;
				default: false;
				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.' .
			(aBuilder setting: #balloonHelpEnabled)
				label: 'Balloon Tooltips'; 
				description: 'If true, tooltips are shown when leaving the cursor on top of a graphic element';
				default: true;
				target: UITheme;
				targetSelector: #currentSettings.
			(aBuilder setting: #editableStringMorph)
				label: 'String morphs are editable';
				target: StringMorph;
				default: false;
				description: 'If true, editing on StringMorph is possible if the shift key is pressed while selecting the morphs.' .
			(aBuilder setting: #defaultYellowButtonMenuEnabled)
				label: 'Show default action click menu';
				target: Morph;
				default: false;
				description: 'If true, populate an action click menu (default context menu).'.
			(aBuilder setting: #easySelectingWorld)
				label: 'Easy selection';
				default: false;
				target: WorldState;
				description: 'If true, select multiple Morphs in the world by dragging a selection box around them.']! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopGradientDirection: aSymbol
	"#Radial #Vertical or #Horizontal"
	DesktopGradientDirection := aSymbol.
	self desktopBackgroundChanged
! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
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';
		 default: PharoDarkTheme current desktopColor;
		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;
				default: false;
				with: [(aBuilder setting: #desktopGradientFillColor) label: 'Other color';
						default: PharoDarkTheme current desktopColor;
						description: 'This is the second color of your gradient (the first one is given by the "Color" setting'.
					(aBuilder pickOne: #desktopGradientDirection) label: 'Direction';
						default: #Vertical;
						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: ''!
pharoLogoContents
	^ 'iVBORw0KGgoAAAANSUhEUgAAAWkAAAB5CAYAAAD72tBhAAAKQWlDQ1BJQ0MgUHJvZmlsZQAA
SA2dlndUU9kWh8+9N73QEiIgJfQaegkg0jtIFQRRiUmAUAKGhCZ2RAVGFBEpVmRUwAFHhyJj
RRQLg4Ji1wnyEFDGwVFEReXdjGsJ7601896a/cdZ39nnt9fZZ+9917oAUPyCBMJ0WAGANKFY
FO7rwVwSE8vE9wIYEAEOWAHA4WZmBEf4RALU/L09mZmoSMaz9u4ugGS72yy/UCZz1v9/kSI3
QyQGAApF1TY8fiYX5QKUU7PFGTL/BMr0lSkyhjEyFqEJoqwi48SvbPan5iu7yZiXJuShGlnO
Gbw0noy7UN6aJeGjjAShXJgl4GejfAdlvVRJmgDl9yjT0/icTAAwFJlfzOcmoWyJMkUUGe6J
8gIACJTEObxyDov5OWieAHimZ+SKBIlJYqYR15hp5ejIZvrxs1P5YjErlMNN4Yh4TM/0tAyO
MBeAr2+WRQElWW2ZaJHtrRzt7VnW5mj5v9nfHn5T/T3IevtV8Sbsz55BjJ5Z32zsrC+9FgD2
JFqbHbO+lVUAtG0GQOXhrE/vIADyBQC03pzzHoZsXpLE4gwnC4vs7GxzAZ9rLivoN/ufgm/K
v4Y595nL7vtWO6YXP4EjSRUzZUXlpqemS0TMzAwOl89k/fcQ/+PAOWnNycMsnJ/AF/GF6FVR
6JQJhIlou4U8gViQLmQKhH/V4X8YNicHGX6daxRodV8AfYU5ULhJB8hvPQBDIwMkbj96An3r
WxAxCsi+vGitka9zjzJ6/uf6Hwtcim7hTEEiU+b2DI9kciWiLBmj34RswQISkAd0oAo0gS4w
AixgDRyAM3AD3iAAhIBIEAOWAy5IAmlABLJBPtgACkEx2AF2g2pwANSBetAEToI2cAZcBFfA
DXALDIBHQAqGwUswAd6BaQiC8BAVokGqkBakD5lC1hAbWgh5Q0FQOBQDxUOJkBCSQPnQJqgY
KoOqoUNQPfQjdBq6CF2D+qAH0CA0Bv0BfYQRmALTYQ3YALaA2bA7HAhHwsvgRHgVnAcXwNvh
SrgWPg63whfhG/AALIVfwpMIQMgIA9FGWAgb8URCkFgkAREha5EipAKpRZqQDqQbuY1IkXHk
AwaHoWGYGBbGGeOHWYzhYlZh1mJKMNWYY5hWTBfmNmYQM4H5gqVi1bGmWCesP3YJNhGbjS3E
VmCPYFuwl7ED2GHsOxwOx8AZ4hxwfrgYXDJuNa4Etw/XjLuA68MN4SbxeLwq3hTvgg/Bc/Bi
fCG+Cn8cfx7fjx/GvyeQCVoEa4IPIZYgJGwkVBAaCOcI/YQRwjRRgahPdCKGEHnEXGIpsY7Y
QbxJHCZOkxRJhiQXUiQpmbSBVElqIl0mPSa9IZPJOmRHchhZQF5PriSfIF8lD5I/UJQoJhRP
ShxFQtlOOUq5QHlAeUOlUg2obtRYqpi6nVpPvUR9Sn0vR5Mzl/OX48mtk6uRa5Xrl3slT5TX
l3eXXy6fJ18hf0r+pvy4AlHBQMFTgaOwVqFG4bTCPYVJRZqilWKIYppiiWKD4jXFUSW8koGS
txJPqUDpsNIlpSEaQtOledK4tE20Otpl2jAdRzek+9OT6cX0H+i99AllJWVb5SjlHOUa5bPK
UgbCMGD4M1IZpYyTjLuMj/M05rnP48/bNq9pXv+8KZX5Km4qfJUilWaVAZWPqkxVb9UU1Z2q
bapP1DBqJmphatlq+9Uuq43Pp893ns+dXzT/5PyH6rC6iXq4+mr1w+o96pMamhq+GhkaVRqX
NMY1GZpumsma5ZrnNMe0aFoLtQRa5VrntV4wlZnuzFRmJbOLOaGtru2nLdE+pN2rPa1jqLNY
Z6NOs84TXZIuWzdBt1y3U3dCT0svWC9fr1HvoT5Rn62fpL9Hv1t/ysDQINpgi0GbwaihiqG/
YZ5ho+FjI6qRq9Eqo1qjO8Y4Y7ZxivE+41smsImdSZJJjclNU9jU3lRgus+0zwxr5mgmNKs1
u8eisNxZWaxG1qA5wzzIfKN5m/krCz2LWIudFt0WXyztLFMt6ywfWSlZBVhttOqw+sPaxJpr
XWN9x4Zq42Ozzqbd5rWtqS3fdr/tfTuaXbDdFrtOu8/2DvYi+yb7MQc9h3iHvQ732HR2KLuE
fdUR6+jhuM7xjOMHJ3snsdNJp9+dWc4pzg3OowsMF/AX1C0YctFx4bgccpEuZC6MX3hwodRV
25XjWuv6zE3Xjed2xG3E3dg92f24+ysPSw+RR4vHlKeT5xrPC16Il69XkVevt5L3Yu9q76c+
Oj6JPo0+E752vqt9L/hh/QL9dvrd89fw5/rX+08EOASsCegKpARGBFYHPgsyCRIFdQTDwQHB
u4IfL9JfJFzUFgJC/EN2hTwJNQxdFfpzGC4sNKwm7Hm4VXh+eHcELWJFREPEu0iPyNLIR4uN
FksWd0bJR8VF1UdNRXtFl0VLl1gsWbPkRoxajCCmPRYfGxV7JHZyqffS3UuH4+ziCuPuLjNc
lrPs2nK15anLz66QX8FZcSoeGx8d3xD/iRPCqeVMrvRfuXflBNeTu4f7kufGK+eN8V34ZfyR
BJeEsoTRRJfEXYljSa5JFUnjAk9BteB1sl/ygeSplJCUoykzqdGpzWmEtPi000IlYYqwK10z
PSe9L8M0ozBDuspp1e5VE6JA0ZFMKHNZZruYjv5M9UiMJJslg1kLs2qy3mdHZZ/KUcwR5vTk
muRuyx3J88n7fjVmNXd1Z752/ob8wTXuaw6thdauXNu5Tnddwbrh9b7rj20gbUjZ8MtGy41l
G99uit7UUaBRsL5gaLPv5sZCuUJR4b0tzlsObMVsFWzt3WazrWrblyJe0fViy+KK4k8l3JLr
31l9V/ndzPaE7b2l9qX7d+B2CHfc3em681iZYlle2dCu4F2t5czyovK3u1fsvlZhW3FgD2mP
ZI+0MqiyvUqvakfVp+qk6oEaj5rmvep7t+2d2sfb17/fbX/TAY0DxQc+HhQcvH/I91BrrUFt
xWHc4azDz+ui6rq/Z39ff0TtSPGRz0eFR6XHwo911TvU1zeoN5Q2wo2SxrHjccdv/eD1Q3sT
q+lQM6O5+AQ4ITnx4sf4H++eDDzZeYp9qukn/Z/2ttBailqh1tzWibakNml7THvf6YDTnR3O
HS0/m/989Iz2mZqzymdLz5HOFZybOZ93fvJCxoXxi4kXhzpXdD66tOTSna6wrt7LgZevXvG5
cqnbvfv8VZerZ645XTt9nX297Yb9jdYeu56WX+x+aem172296XCz/ZbjrY6+BX3n+l37L972
un3ljv+dGwOLBvruLr57/17cPel93v3RB6kPXj/Mejj9aP1j7OOiJwpPKp6qP6391fjXZqm9
9Oyg12DPs4hnj4a4Qy//lfmvT8MFz6nPK0a0RupHrUfPjPmM3Xqx9MXwy4yX0+OFvyn+tveV
0auffnf7vWdiycTwa9HrmT9K3qi+OfrW9m3nZOjk03dp76anit6rvj/2gf2h+2P0x5Hp7E/4
T5WfjT93fAn88ngmbWbm3/eE8/syOll+AAAACXBIWXMAAAsTAAALEwEAmpwYAABAAElEQVR4
AexdB4AU1fl/U3f3KnAcB4gKSL1eUCOKorGiJjEKJiZqjAU4ioLJX03++XuaajQi7SjGaKIx
ComJGk2MMTY0Frh+R5EOSq9Xtkz7/77Z22P3bu92d2aOkuyDvZl58973yrz3ve997TGWDMke
SPZAsgeSPZDsgWQPJHsg2QPJHkj2QLIHkj2Q7IFkD/wX9oBhGPx/arP/Yxv2n/rBku1K9kCy
ByJ7AAiaQ0x6ZOx/zlMSSf/nfMtkS5I98F/ZAxzHGWg4cLWJrP8r+yDZ6OPVAzTIkgPtePV2
spz/oB4gdgd+ff6DmtTRFNomJIOjPWBw5835t7tlZJqbU41UprNUXuKzNMHoI2pGCscbWZoh
pXJMdzFD78cxPl3n9BSeEzMZ01MEQRb8qv+O+vLCzY5WKwks2QP/4T0AJN0XTTzcTln/x7RW
/I9pyUnSkPzFDUO8XOZ2mecY5zq2BoocOEv4jwHEsOTT5gw1Dv54JgBf63hGesPQRZ7l4CGJ
pE+Sb5qsRu/2wOQVK4Tq3SWiSwhIPKdJsuAS/N6A4PL4TXasT/UYblFUfa2qriqC4h+wSxm6
janvVFysdqqZD8+UR+sUf0o/JpG0w5/PYAGXKKQwXdeCeLgDfnzjRjd0TtOE0zqyJW+SPfAf
1gOFC2uHYUdZIjDpPNAnYzfvM07LkALZgihLmDQiSBfenSIDN8kmleORqAM4NSVN0kHHKHog
Rz08UD1UurTpc0NRN6iC8G+OqWtAAK03jLfdSBzfZDtF+vUYqXeKVPhkr2bBwroClyzX6Xrn
RT7OmoPi1gx1Wu30wmVx5kgmS/bASdsD+YvrTxeYNpbnxQsEURyva9rZQMQZPA98TDtJg3aQ
tKeke9pZxhkwT0zkhZ0ph3uabwbjvOmi0NisqO/qmv6BprO6htkFm+KEeNImS1LSTn8ajqVx
PLrVKpKmoabxHqerlYSX7IHj1QOn/ezjrKyMtLt43rhDFMThjJPMnaWuHiNcdF2xVx0gdxOl
E25vJ5whdfe0KPo4oO1xkiTeKwN5Fy+u3wNe9e9VTZjfeHfednuFnpjcSSTtcL+LzEihYWMr
iFwSSdvqwGTm490D+b+qP110s1sEUfo6xCrFJHqhaWB5R2mrAYa5KBDXgxf4HFDac0XBmFu2
fG2Tqqh/M1T9mbq7ixpsFWEhMxaLdLBkmhPNmkTSifZYjPSgg9NsIWkMbI7DcE+GZA+c5D2Q
V9EocwP0MS5eeJhx/FeBmJmuBanlRDgXvdpMVMQw2lnUGsuVBDHXkLh7i5c2rmJK4EeCrH2y
Zuq4tt6sA5AzCTP747fPSjmm9NRKxmSe6D3AGUZ/A0JDywED3dCVQ5bzJzMme+A49EBBZc1t
7kFCvYsXqzFiv2qAvRdC0Meh+C5FdPCnwakO/euSCBE6ELaBhURg7AJBcr3NcenrSxbX3B8t
rRNxQNAy4GTht8+qamCvU9KlS9ZeweuBXjDZFJmma60Gx6n4Kq0qx1pETj3KfOxwzZySw050
sBUYhsBybDI7sFWzUnIyT7IHerkHKir4ouzrvyYI/E95ThhzYlgZx9pI6qzYueIf38I4faOh
qvsMnkthBqenynymz5CxI9WywL4mHdc+pnASqUlYCeQJQIjR9CGC6P45NEXu1nX9R3sF3/Nf
OERZowzaEaeinpYo6FBLex1JM874KxNJncb5IEDjOAiVYxIvwFaPMzTOp5ctbjiE+081jv3d
61X+vGFu8efOlx4dIgbMEPDkor+MKxaDTtAPxJU0mSjZA8epB3KX1JS4efcfwWgeBvVSTjeO
CQGPSxWIyQ1BoBnar6qqNKqc/rCvSXp5Y9ZohT3YLgwCHvDuWjt088HA/orGRu++pmzui7T0
Pikp8sVgJv5UFOWR5gLTzpNpX2wGioLw5CCW9ot+S2q+0zC9+K922gUEDbYnqsxxtueyuUuw
U5me8hYuqP0SVB//HVKz6Smto+/wQUktx/xkhDAFcauuqB8D+a2oemvty2zlFBv8iJ5rWrp0
/avMUK7pOVX3b3ksNgEt8LW68qJXuk+VfJPsgePTA6MXVg32SO55oLKmmLSnLQIkjjqbc5cI
X41oZJqnrRrPreV0vVHT9FpOYLvhqaPVrysNa2eWbusOIpAkaVdnA0l+0TlN/sL6cbLAXweh
4uVINy6SqAJKRB2APN5WFO3u+lmF9Z3zx3oGzAFIE0DZjuzoexVJl1TW/FgQ3P97ordFZqfS
SgzdTEUL+NCJP+b9amVvsEXKlq+rAc+rKNaH7O499En1gOIfXzez6OPu0iTjkz3Q+z1gcPlL
G65z8fIL4DeTkUnvFgmiCmO/VVEC+3he/41X0F9sWdu2Y+e88V4rBWOOE24rA6Jc3VP+oiX1
U2DhuFTTlb6RbaQdLakO+u6t7rduPpsSH2GHcgejPDJNd0wY2atIuqyyvho6MMWRK1VPXXY8
3qHzUQwnCNB511Yc8eydufW2i8mc1JEA3tZRkAGWefC8IKlKwFtcO7O40ZEKJYEkeyDBHhj+
izcz+/Q5/SWI2S4J7YLNnSngkCUtEFCCELtPzguQLWnqUd0wZmgB9mb/w/sPRDH37h5AD2+A
MIlY2o769iiIL1u2OlPT3b8WBekGXeukv02UPS/Waa1tXwVRt7WH4ojPPaK9vEBP6RJ951xv
dyp59CPr0lMz9S/wkYk3c1IGrNzwf6Qf1VTtttoZBRiU9sLw+avPyJQ920icYTXwosvnC/hG
Ncwo2GEVRjJfsges9kDR4poLeFH+K29wmaRnTII5zJMjGtNfNhTfKo6X7gHSy42kOi2URuxI
ULm6ojxYM7PwdQsQYmYB0iTB3dmo7/s9JiaqG3zs4sXV33LLnv8NaNqY8PbRAmUKHQ39xqrp
BSs6w0I5xFoZhd9GlOXv/N7uc6+p4Hnc3oH4uKR+ctIGkw2j6xmSKP6xZGnja3YrmiZK5wsC
lHvsBF3VxYCasMK7nSKTeZM9QD1QVFn3f5Kc+h74v5kcHITBjYwCwvnbvrZDo5mqK6LoXg6q
zhaCNhGeAf8bTP1a1dSxZ/cWgqb2AGGaO2Qg0Z4nZdAfNau++aw3/j2+rggi0at4UeqQjJqc
ALB7BMH1Ykll4wsEOxQAmwzPiGJf2xsImsrpNSSNFo00eVlUykkeSFoNMeyksmXr1pGgxHJ1
ee4KfDTL2WkAw8/XwZojh1ssA0lmTPZAoj1Q8bZYurRhhSRID+lqgEjnLxS/7xtV5XkyBHX9
3Cl9N0LIdjuxOuwEjhegp8w9f4DpOTXTCl+2AyuBvDuRNiOu9OnpmVzelEDdtLy/K17vOdDc
e4VDB4SCBn4Mz3M3Fi9t+jDj8Q/7Gc3NJCAcDuS8Gj87Kl2hIqJeew1Jg9c0HitQr7FTorbG
RiS5CoVEeXSq5Nk+dn71SCugBIMfH75NsgIDxjBbWFcXjFZAJfMkeyB2DxCCHpjzb9Brk4nA
AFLaFfBqpRCaCcWVDZug9rYAfNo0WwZaqAUvyG1QmZtVPX3st7aXF/bII45d6YRS7Efq8bFy
tFPEHcRR7ezi6prpY7+q6MoTkBN1ZCeqGsyP8/LS+65bc4TlATn3uuyo15A0NhuXd7TslLkB
FWzogsflem/Ego/iW33b25b3eGM/uFocbEdIyvHw5mWwd06Z7kpW9JTugbyKt9PGDR4MJGOM
g+onCb6mwfDsAsnNvyHy3O8FnhtuGzkDLkjzrYFD3tG1MwoXHe8OAxIl1mEftC01Rtk037ss
HnXlhXN0LXBjOEVNhJhf1bPvfP2LF0csbcyNAdf2695B0pMnw7JEL7ZduxMCgEQlbGCmmF4z
8WnTN21cteBcOhz1myagcaWPloioeew93ov2LhmX7AEne+CsxZ+c7hk4cCuQ8CioL/gDft8N
wD27NF7aBCegRfBrTkjbVpFgbygQOC5as2fFWXX3FRHb4USFj1BwXozCh+J9Bx86PC0JCwOq
cpHOCRAKhpgDwBOakt2HE2qL51X3Kq7rFSQ99uL7z4YA7dgeIbzFp8A9UcMwLx122DfgF/FW
V+SMfPDsbLWZJMj63gM0oJIh2QO91gODK1an9BHTPwVJkAXL3M8DfjVPEeAgV+Behp00kLNd
9ioQGeQr/oA6vnpq3ixWUWEXoK2+ADW9CQCGdAcEi5Eb7zJ64ivXzyx8b3Zxxs/82OqGBygf
iGJqyvv5C+rPCo938r5XkLTEYH7poC6lkw2OGxbxngT+7sJFVV+OJw/4VheCVRJP0m7TYEu1
qbHi4g6+WLcJky+SPWCxB8p+sTpz0KD0Wuic5WDbtsqv7h4jauoBDy88S7w2u8HUp+b5A/6A
r7hhVkGPhiR2ywrlB5KFe+CYQWtHxtESno3IbdFeUBzy9cXvxtvOlR43NO1CEoCi/zqSw7FU
mssl1hY8tnpMR6SDN84jaegc4gy/CeRt6lQPOMeKiZJ7IZTdY1PIunGlnfaaH93QGuzASOZN
9kCsHjD6pPwT+7URqqH8pao8d0LjjItbIIRZAUyUZuoCxwLQw3vwngGG+7Rq14sDGmeX1vaQ
1OlXhID7xwC6Ee8v6ZwG+QgHjsbvs87v6JkQNC5ww8q9yHEDWppmF71vGIGrsNMOS46e07VU
OT3tH2xFDHW/sFzx3jqOpPNWNsFlqzTCCVdu6BhQsxLUXqL8zHiox/QixU50BbQtxqoBscvH
De9g8KT6wPEWWRtZD/TRVT1pCm69B5M5Y/RA8dK1r2K+jMPcfLdmWsF1lDx/fvV4CKwvi5E1
5msSPOqcUcXxrecfb/YG8AQZkBwGQj0dP1c3lV2P+AK870xwEavDBxhdthFIW4h31DfP4dcR
qqYV/R3s+lupzRHB0E4vObCuLhFZVkT+bh7EbuItR6tbBBfryw104ixIcIY3wA/G83Da3aWe
HLm849hAaCeOFCRpCFDcIFDvHix9luseLaOJqEWxEu+65TlxonyhAH1KO57BYMnFFCNQFa0O
ybhkD9jtgdLFdXNAz1yD8fxh1fS8iQSvDHxUQxb+Qf6VbQUA1gz2r+ppeXGxBm2V1U1mIFlq
xA4gVkLEh/C8MzwpvUc8IepB+G0Pe0esjs1hz+Yt0l6ImzOR79nO7+i5elru74oqG86C57z/
C2nAIA9Y8UbuEd+Ax5GkPFo+K3FdkJ8VIOF5PLL3LKbJln1XdMAis1Fd/XNNeeFDHXHRbrC/
GrFwoyzyB9M8YtpN0Mh8FGPGZZc/3FEUOl4S5eFkLls7o3hVR3zYjS5pl8NtalhM4rcafAZo
mq8m8ZzJHMke6LkHiiurrxYkz+Mwxjhc9VYjIR9WUFnXVxfEVbyhp9oha4hNhymyb9+GQ9f0
XIvj8xZItR7IEu6CDdop/AXP4c17D3ETWP71fXKG5pzJGZK72estTfd4fhVeO+T9Np53dIeg
Q2lr+zc9XHJw7FCBl27pcCIHDS1BkKcXL6rfUjOz4NFQWjtXe5glWskucZLpfyrauwTiBPKr
oXOxKUt8hI2zR/rXzTz3AFbyhW1HD2aDub+MmPtOBaI0eE6MOggnr1ghwIjlHDvWWBgMYH7p
Wxvu+dIep+qchJPsAeoBHHGVxgnupyDc8uPfhJCbXpkXn8bkH0jUn60gCPDaqJ9n1VudrbK7
yYz5RFT0B/h9G+0bRskmVlSI2VdOn/HwM6+8mDN0UC3U6V4ZNiRrxa9fee/+M6d878+Zl02F
y1JDwu8OJCenTO9Svh4DPONVTyu4Fbbzb5E2Syjomh+yLOnHTml8HIMcKsH+9atAObYDqQFp
XCBhX67r77uguXpGwTQ4TbqPHCg5EUhnlBOlS6LB2rlzCA4lloZEexd/HEf60a/Fnz6ZMtkD
8fWANED7p8hxOS1+7z2hw1fJRwdQM468sifcN/nQiv+uhtkFpOJ2UgUg2b34EaviWiDey+o+
3vcyL8sPb9+931Uy6kzmC6is+Kwz2P4jLay1zXdBZp/0j+o371iI9B8h33uJNCbFS762uSPH
ND5od6G5JIGjhcJ2cBZJ08GU8Dpld3GmxoIy9TbMKFtrtYU1M/J/qWkaPpITSwZqoWmlEIh0
6a8DLKUfaks2/JYDpO2M+dmfLANIZkz2QJQeIF/Joug6V9G0FevvLl1KSUoWN3xTFOSH7LID
yQIP8+v+6hlFT0Up+mSKWvTzZ15+cObkKyedPnAA27m+mk0p7sumn7WDXZfnYelH1rP8nBR2
4xUXC9/48VNT5Ytu7SxYjNmWD+fktpyexl0drsSAhYHxopBTvKTxJzEBxEjgDKnZXkhJll6I
wx05OGmJUWyM19j+G7oRe7sRA8y+zzKm5oxtvRbsij4xksbx2hDys6//UgOr+DA8cZrELsCC
You3AlZK215Ns6ayBN8LI/p5Uvrxmebg0qRWTvSrgY8Hbm+N11F5eHtO+D1kDEMfeseVmj1A
9GvNvJqeExCbVWPjrBEBTAKbe/MT3rqEKzAUVq+uvYMkF+/HiZ6i0liRF9fkGv3IqnSwDJ/F
RAroqno/FXw2rAwNQXi+g3+acG2CGUBpgvbR1wX6c/Msgjhu2TKuKh+JYXPu/GtOY2/fOZCl
767DqYOwhP8y6K3B+9llbe+z+y84l9Wv+hnbrg1iu1Kzfw7bcFOdFoiW8CP9aG6F7smzZwiR
k5c92o40v/ytMR8WL2laLPH8DNp5U6CdisALP4R157JNM87ZYUZa+OMokjZ4Ix8ksIVqdM5C
c1F/uXNsos87553uza6sfwMddWOo4xKFEUrPwwWpZGhfwnMEkjYEcQqdvWbLSovj9rhFuTVU
VqzrkMc/9GSJ6d8URP06gxPyBZ7PMATJ/JY868NUWdHKDuQd0hbXr4aJ73NVM/JfjQXzRL7H
MWsTeIm/UtC587QlDadzA/qnkd6lW8zgdW+LH8eIamVLGtv0yrrdQNRN8K64ptkn/n3TvSel
z22OVUAqU2HdK1rxwrrJOLTzOvRHse4z+sDzBAThki6kGd6SyvrPdY57Ex5tn8fRTuuifjcs
dJ6ljc8Clcp+Tf9W/awiOO0yeJVvega7vqhZEokEFb3vsF8o3jhlZFwLRiKwnU57pqznvV70
T23AvjbRqD2bKWMvZ0xBtfudxthRhRlp5zCtehUb1a8/+8OVLvaulJ8y4VXjTkx3IuxoG34U
v634bcZvL370TJok+AyRREPhEuVhqBnMwLtjAQg7Q0j7J1uxItcq0eQoksZxJ7YEaKGWkfcM
XvW/GXq2c9U57WmBk260u70DZY/hzUWz0b+UtjZWA1loKZqyeeMsUEizu4dChyikZPqv4Zh8
K9boyzFAiJ6B2h8UFcnnhx5+yhBROlxfURSHQ81+Clyw7oL2yCJB8D+xxqGTkLuvaew3hUtq
B/CGcBXP8zegEROxwqXh9Asc8qyROYQJAEcKo5loBpxOUaBYnomgivgJBtQVM1M0VrqsaTfy
vg/K8DVFEN9unJq33Uxs80/p4sYRqMtpGm94OJXP4Hg9A58/FYt9Bnq6L8eEvqhVOhaSTFQw
E/6X01G/FOjUpwE991ONpgrQaw8lUo3ixY3FILtmY0s2GfnSCD0YPEYc/QNFRnPC/M8Jpwsc
/yVoFP2o7Ml12w2f/7aqWUX/Ci9r7IKaEYLHcw0ouer68rzn6V1u/6aLsZhfYkfATXBovAZU
9faNs8eQbvJJHTAvOQhK/+Fd7VY1MdPFtmJ46NVMOLOQOtesO8dlMXHsFGJnMsN7lE0cNHiN
KpiGLduQYA9mWVu8jaybXrS3tLJuKpQWloVwAl0xbkYW7sudhDFhiVhyFEnDeX4+qZLZDRBI
HATtsMsuHMqv7pE+4HNUGt82gzlNhoUDGf1E7Wj4KMmwM/BNM1pV/6DbrTyKLVzW9F0Qk4sE
3u0OHe9D6wIhLgrBa6cWIsExq099kCCIP+V04b78yvoJDeUFGC/HP5z2s4+zBvRJmQdK7Gb4
5SW5A3BssB5Gp3ETaltHAiQji7iIHYtuDET0ZPBdJ4sABP7fPwHnHrtHj3Ei/wQcvF8tYvED
AdteMi545kHWUz3MYAreCIEGA13J6k404jdsGlrxtrtPTs5voG/7Tfq2IVjHbkLfF2/M/8f6
gNOMM1TW1UeOSxJfAmoXVE25n2pGHhrdAv+GbnOXS2QBvtnsuhkFlpBNsJes/zWRbtfsaYgK
/cjqMKv9R2rAaYGrf5PC60skFvAxwwd862sFMsZcIRN48jp5eB8o6beZfmgXk3U/83nbPurz
0nXvIK+l0Np89A9pfbJ/hsOoqR5mABHBCTxbjgfS0U44OIqk8QGLEq5BlAygDndn7Gp2ZCsF
Hl5L6bLGL/BRBkcpKqEofNoI/e8UiRXQh2bmZE0IVEdiE/Ew7vWOiLAbCH5uFpeLD6OAobQi
hxB0WJK4b01JPsdlyLy0unhB9Yya2SVPxp3ZZsKxjzWd6UkzHgUC+wowjYsQLc0RpwLUy0xQ
oDAvNUS5oXRpYzX666fV0/MtCWOxawpous9y9YDWB8STuXRxw7WYvfQdcqx8W3iYY762SA2o
gvnVX4XLXDj7UldCr/8fVA/Zwy+E6Sz5Io2nWt2kAbXASft4obnXBIX4ZmT9RxaDRHEQbqJn
+hHZS3Kf0C+4cgbXL+IJ0zNdd+K3BT+iFGlQ+Nt+eLObX18311AVHGAgMtfXbweixn7tyBHG
pWMjpLiZMOJixg58wbQ17zPtUDOyWQ+kXVa8qO4FQZZnhBsJQdNsYGFl7QN15UU/TxS6Y0g6
d1FNHhBORqIV6Jye1HpUVW1w6jBKE77GduCz20bSgBUxyjnSj8Y2yVbQdK1O8laFwyh7bHV/
I83zDNiyV8OXbfgrW/eE6LHCS5InbTmU7bdC2f5NWwBjZB769BZ3pretHFTzr2jWQS0pRg57
r8Oo7BL03R9Llqx9V/MHptbdU0SWZvEHDnzgiC8df9bgEOFiIunSJXVT4Qh/qZ3vC4zlX39f
6RfhtZNcrnvBdtEUVf0FxY+ZVz0UOOwm89uHJ0zwnuNEpqj+p2pnjAM5ai+gLkT50pAg5Es/
6m0ZP+LZEXKld8ROOQjqnRCw5WCUDeaPCB6MPJmJU77DWvxu1vL2G0xMAaryyMyTV8Rafv8s
85SewzKvvIOletJOM1ZNd6Ncy6u0wvl+IhgiWRxSO8xg6AqTRXf5iAWfPU52HaH4eK6OIWmR
eIw2TaODFeYZeIHvx1P5eNOA/RSIZPHHmzMyHbaQHZ1uvpHkEobOtxN0nvuUTR3XAQTU83Uc
Lz+Nj5ppZwJ3XyeY8Kp+Ug/6R+HC2uF1JFTqhUAeweRA4DVYAQ0n5GwZ51msG00KTLSL5BRX
fdHi+t/goOFp8YLCWuaJ/NDx5gymgzyJEE+3oWRJw5OgrO6w+30hNN4WXkjugsYSHAM3ARTc
hrqZhdWkMup2iy8jDgukvS+Avc8eOO1/ILw8G/emkBzfx16lYlRgWUrKoOe2HJojs72e02+4
nckH/azp2Xksc9AI2D0cZoc+q2EF94xgR0aeyzb//jnmSk9lWWPP+0HhWbll6K8lqN+qGEVE
fd0445zdhYubZsqisPgYK5Q01tQhqZI+CZn+HDVjN5E9DqZu8kSNxikOXwmjZKKmiSfSwK5F
bg38M5608aZB9wT3w/Fm6CYdGA4HIl9p0QSJkUl6ejJxvvG3UBJoMDwm8sJLOhB0KK63roSE
BJf0AmavHXwUtXrYxs+R01PXYlACQdsihKLCjzsSiAlsBIhKxKmlS5vqyhbWFcSTF+zyCLZW
PHniTVOytOFXIGbusKsGZ5bHcRFI2iXpy4kw9TNlLog4oyDrmlGS4Mq1u4MhuQkEuQ/G28ZY
6Qg59zaC/nWGa4THw76A1PX72Vd+QzAEjjUumcfU5qPMk3Ma8+3ZjbHhY5ue+x3rX1zA0nOG
M82vsd1Vb2e9dd3VN713262PAFHfih/sPhI/zEPbZ/waYx87+GPTi1Yk3mCVsfqn83tHkDRc
eaaAW1RA/FW7AR3SvOZ749bZhROZn7OvJ02dbXBbQ3DHLKoZBQQXyz1iKHnUK1T3DN1vvE/9
h9PKq6HJcC9pahyPQMgTG8lzChbXT3CqvLwVjTIO6XyDF8XHg9Zs9seD/boRBQM2i6EXcC5X
dcHCuptiwUSt+8VKY+V9yaLGh+DnYa5dpGmWjfGoqQHiwZohf1n9WYLoLsSytKWhvOQ1ipR5
z+0aDvkO23UHEyf4F9oKPkNVT4iwMMGqdiSXJUPSQJtlFU1gms/P1v/hNyZHmzYU7qy+TPEe
hjhJYm37drC9H3/MhlxxFbAXBMOII2ej2/664nMsJL8FQGJ7lAMv5XYAj+OG9NmNgDqD1HOh
AaSRlg7wBbk+Hli8tI6o6biDI0ha04UBkIY75YHuw7hrH2dC9M3pcSbtNhl1Ms6hrwklcHHs
amLv2AlQOwtofKCZGSnVoFWKj22N7EBNJC8GDS88k0iO7tKOWFCV7TrEfSRw3OWOUIndFWQj
HlS1IEvS74uXNi7rEYxmU7YShY8KYdJdvCT8nxUBYbS6tlO3W0LvJI27AQ7JZOxeXqE48oGu
88ZMQgx2AqlAqor/r9WzInnfdmAej7x+6B3kFOFcaJCuO995mcF9slksB4m1nJnJVI04LkTl
cmz7my+D4OWZp+9gdJdmxvKMJx45sczqcVmEH44ENL6O3ziKjydUzS56Fd71m5DnIL7CGsCC
ph9OHGfiN+PJH0rjCJLmNOEMDJCQFU4ItqUrqPG3LWXsJhPp5GJ3ZYviJdCmMYzO1oSKwQqJ
M+HsUb3gDRuiKP8LbR5lF1aoXgldMYHh5nVYwdK6CxPK1ylx/hP1OemyqxbzoSRIQXdKcBI9
0iQUOeEuUPzvj35qVRe2xmmLPs4CRznWoaU9tMikmfaGJ4DHuTLJ5V5GfHKnApWi8sbmDng8
P4ucikEO/UeKUxXXzfDGRpoRtgI0XZprZhTeaAvICch87ae1PrXNt25v1bsmdRyqgsDDLgis
cLJ7CAVelNmWv77Ahl77NZroQNTGRkUXTcErpQFyVQlZ4/cSHr14j7lvetqLSaVpiu95qOlm
q4b6qanEG1w0vxoqO56rI0gavXAeqEDbsDDIdN6vfhBPxeNNI+jsSp5zYP3AV2lYlW865TfZ
O7yYZ5dKQRvc6LR0B+DE2x1d0hFlJ6p8QoMmHAhpD8ge8TOMe/jztrdohcPtzXui9KGEdUGa
krW686nwfXRpiH3HXNyRUP3zFjemuQTxn2BNIIooN2cCqZPBAbnJ7iipbPwKhIXvQPtic8id
Lliwl9B5hXaC6UDJ0H8MGKfGh21vLKbq4NThw1uqPv6oyOBcAcKLhJKBfpmYkcWMAJQrjuFo
803gyGG275PVLCu/lLWqbefcdvDoR+3gIi5A1I2I+At+1CeXo6zhEQk6PeB0p+U0L3B4iQ/i
83vJWx6o9vSCJXXf6pS020fbiNWEzHGXdVtCAi8wOZQ2Acx2pwIJxTjhm4YDckNOEOrYSpjE
IQQ0eaAIB7300U/5gBHMS+JEK+0YA6oz1eN6DxYOoEhPsb6gmctxo1L8MDkLC7wgloTJesLe
xH9raHqHIZYscq9hGNqXiXQq3kT6orgDCzwGpX4B0MA/kMTkG5P7XGCFXLvsM+oivy6s6FT0
Sf0IpEm7I196evq+CkxV3ZBaVaheq7COo5+cncPajh7FvWz+NDCg6aeDu7G7/kMmpmVB84Ol
9NTIdsr6C1xJ6E9sEBIuDsavyypcPbt0H3aXH2CX+TXR6/0DrGxVkPFwMcHu7amM8HeOIGnU
7NxwoJbuMTNU1d/aHPBFbBUtwWrPVPhYXQoOLT8HnWcHDE1mECVKx8oKcd8I8P4cIM/tVcup
3GABlLC7liXUnvOfWpeeyqc1oQ7g99vsX6cakiActPvzuu+fuyU8G44YLQ5/Tvwe+kk820T5
ipbWzMLkvJBYLE4HYivVv71uW9nyNaKh+Z+FRdu9YNO8TuVU7y4BR0foa6dM4tFCy+hfa2fm
brMD53jmxTxPmQoEDeR5sDIzs+/irIyzNU52a/CHpMM2hn5yTg478vle3Mv4AUHjav5IgUPM
YHsb6tjoydN/WJnqvvTJ1NScWPVHWZ/h9ynSkYCRkHXXBVll94C3P9TncQ8wFA1EKLEZPWOI
TRgLPr23jaQLFq4ew/EcKafbCiYnT2eNO+eO99oCFJaZT+XLYRptW1IPiTw07PU3Q6B5Xr4A
W5guq2bo/al35biionMvSKTeXr/6R+hAD3CSl06IAawzMAW4FuyA6iF0+QTb+k3g5WHiIR48
VycDlt63IuDBCRFOiC+0w1cnggAqfGsL59WWipx7gZP9E6orkAL10UZy4A9fLAr8mZ8myu4C
kflXURpD8Q2AlhAWT+uB2oHDVk0hpHUoxzfngkHDbiweeOZLywadvo1zZ+zlxcxPNNHl0WA5
rwlAxpjHEijp5r37QTkjDtSz+QM7VMdPw6+tpZXt+uCT6Z5+A99k7pTdT2XlbHkyK/u3i/sN
7rE/aWHA7xO0WEbfnYVfdqj1suHeAHZHm6AZk1WmwfoTxp+65uJ5fVQoTU9XMLbsBU5yXQGH
M1gb7LGtghM0KPSwV6Ng7rHzmgaBL/dLJyaJCoGP/6iLtpPBoLOrSOHxxARaG5wtm9SEQFWM
B+C342lT8eK65WALOKrFAVYXHLZp76mq9pP6mYXvhzdy8uQVwmcXjvwS2DLf4wUXylVSbPPx
qc2aHoGk83KbRO6QMAS7pHi6IXoawPWrvg2pKSl/RD2RpjfWcsDUNdrFmAE4GxaFbOcRf6ZG
EWke/lJ42RDsjBJsy9E9iimEDJZy8v6twNLe57QRb8HJ/kQNgj8cZkis32Cg+/b5QgsP1DBZ
2xEoVJkuT0JzqT0NdRjiD0OHOuPMYaxt8ybgU3GoyBlDeVUjqvfKdqjdXoCoiROwF2Vl4kdI
eOfU5Wu8a9T0raA/Juzf0HLlgFGZv0I8z8nyxbjSWO8xhJrSY6KeXkIAc75dAQXBJ2GOYOhv
9FRWIu88Kdx8aOAnkiVqWnPx0PVfr79vTLOZoGKFDARdGjVxb0USdQkqEkOJ3MStxU0zuU51
KgQXMiOubX7xsuqroQd9pzNqdtj20WQxuFd9LUdHVk/PuxwI+j20K+LDrQTFWDOr5IMqnHCt
+VtGYtL9zi7yA8kMib1RE9GHTYwOrYhrCxqRL+wBVHSzxOSfoU+hqkVIoDcCsVSENSZkUP+S
nHqZEmh9J2RuDAT9I3ulovt5fp/Iq4fswTk+uSsIfXD820Qtq1C106GtodFVCt6rost81iBs
1SUX80JvWpUoLZ7phzGoUl7EBfO5WPPBA0weOAgUuIh3YsDrEW5KpDVA1iQ8/gw/Y9ldZTlp
orpKktPyRmT6FewQ/0HyLDCz4xLY20LSE+FwHg7r852Q6gMZHl5dnqCPhW56rWxR/Wz4L5hM
K6fdgG2lonNyRQhOUfaoc+B60Fa/hWDFuppbfEE8iDMbnzW0wHlAYmLV1LzcqvL8DPg3ucbg
BZyJ6AwigM73yFj1gRn5MJ65/oopEStpzPcYxFh4xLaAzzutqjzvKw33xucUnfR117zV9F3b
QluOC7Tp4ufhFXUN0IdrhganDtYDhHXpoOhA2drvo+5qQeNaNIIykuLs+sdAVQ/EQkcIgeU8
WpuKnh1mZ+yTdosS8P/lZHBr210fdI6fu3PDw17Gv6kTWwNImpCuAnaGAiSs4UfPGiHo5lac
kw2kDcRMzwoQOP00IHRC0EHkLTM/jtfSwJYAt2Szn2NT5+7cebBzmbGeMcbJstKL385Jg+Qf
KwFvljBs4HBN8VYKKBPWZMVsMoi+GMEWsmkelC4DSYPysI8MsbrUxqhrXK/pyCBsIx53ZJIA
kWAB+qh2z6gOaT3Wv5hbnrgqGiMRqVhpuvr0dkU7s7q84Jaq8qIOwSVlrSkveA2uKMeTUNOJ
oHN6jxJtKkOU5KecQtC6wXsNVS+qnV3cs2FJlMYVTRz1ZXi8i/Imviha/HQl8Pm6mWMPhOeA
hsTV1qGGINHm2v58CEGLdkX9gabbNpvvOO6OYBrd5EcP8uiX4nSkaNkSiEMLNOMnCWQ4KZJ+
f0v9FW1+bpQicR8b7UiXEHb4r/VoC6hpdxBJYzEiZE0Udwd/mvjUQOgMfQj+9PQ9Z+eNnfP5
1mfsNvC+SSN3wofKobYA99VHC6VqKEmA3yHwBReMKYgF29aY9LVyg6H1AMGcTUQBRAM+YH2s
ysZ6XwSfESIvvkiWZbHSxvOeznFTNfX7HadsQMVGFPjxvSGtD9WHEAjUp7arinpJTXnhd/fN
yGsJvet8rS8v3IxV5FG7iNpEKgZLISu1zmWEngsW183BZ7o49Gz1araPcVsV/5FhVTPyNlqB
wxv8FVjUrWQN5qHxxoy/dwVgTLI9lrsCTTiGdhlEzbb3FfJjfiGOnmlMQgjll7TsvcULqydK
kiudjGS8fs8GsyBDxDbb3iIBQ499dbOLdiZc8ROcAb1k/GhnzWf3r6v5UoCJfzGRMxCuycoA
Nc2npbNWUNKG2x1kbbSzN1Rid5jsD0LoxCIB5S1KH87d2rS0YuXKgGPN4oXXvao66YqLCnbg
a/4bHxKOztiFseCLsRL09F50SVeamoH2xgStKPBDoJBk1FKg89w86X0rBYH/th3JfGThtHDo
L9TNLDINWOjdiIUbZd4tDnfKtDeyPJqH4PAz1uBqPXTOv+PUcgkE9OfcHmmubuA8CRuBmA++
XdGdv+UtazzDxYm/tN9uEznuPXzYW7z5/i8Rz85SgNbB5aRrajWAFQZtHeVPEfmxQMGJ/gWO
7MAiAMf/QMiZEySvpvh34riBV1WN/cOt+9Z+zvHeQTxLCWjcaYIolIIiKwkM1HzSXqmYxrth
8Ps2zB1tsm6ww77W7nfCuVDb4q/1yZlS8evTpQzXtboOJWhgb2xLGZ/Rh7X5FPCgaafRGWmR
8JBCMB6blXfNRwf/BAL+P0kCW0kgoSz9K1nXIZjl8mIVYQtJQwI8CcMKzerc4FjFdnpPvaMr
dZ1i43g0uLKlTfej+78HxkQ/5xA0yU0EvaXN+0B4JVxqINUwhAHhcU7dk2MXVVdXCLz320DQ
pBYQV5B4ZRfHuwMwy/fElaH7REbjIG/UDynqxiMGp9oaK4SAoJzm9ftbz958/zjLCLp4XnUf
mNIPtYOIgADV+rc3rgrvinzNNZb8O4QOEAh/19v3Qcs+1goK9iEcGruien/+jo7dW3vhu4PX
bbh8GKpPUWX98HZ5UMeOxM/037iYMDeIcEIpE7sCXdne1SZWYi+kHpq6Xz8i/Bluj4sNTndj
bzJE7teHHfliH1NdEjkXAz4+NtyD/YURSqha1xcGDOFnTteK9+ofCP3SuLHzq0e2KS1vyu6+
rSDLRpJBEii0Y5XpVLD1iYcvyS0xvowO6AQy8UeyjFJ5cShcSfp9irC3cUjuETYlaN0XDu28
x3d4vJ79OfAjMxwsW5yP13QbnJG7OQd9IlB5tNXEqnffujklW8PLx84J/qNtI8NwkOY9UdCg
nl6pmZm4j4R9qq8lW5P9QIKWHVzRQqtzamu4X+tQJQsW1V0IJ0zfsLsAgj2h+duaxzfOOWd7
CLaVq87zQzCN3FbyhvJAr7iWdIxDz3TlOT0XEzk8qtfvaeEC6ezDwvCUfy83N96TwEMVEzmu
P81s/LaE4gSoehPSDz8VJPQuvqupULs+vrQnb6qKd94hPcrJD5ReMUE22F8CArTH0jKgnrfX
5D+bn9pE0kEK2vwWir46oCp3/bjp/ereaFnd94v2liyuP5Ai8P3S93u3NA/qswWaUlkTH3pH
eCd42EHUYi0j6ZKFVWN5tyQ7Qnmgs+Cd7M9AjqpbUrWSA01+rrLhACTUB9GZELNiDvHcID9/
NEviU0R4tsLxc6rJG9CNuInOqB3QOdJEWIb2BpzhP9b5HS9qU8xTfWxstTvDJIVO7EQ+4qXA
DV3exRGRkypj58S1YKJ2tXSKI38oCSa3P3QfupL2zhFJnG8XQYOHSt6/ZgFBR6q8hQpK4GpI
xtnQp7Y8bkFakGVrl3rASVixxjk7lnpqFnmXA4beEtACl5qyhZ4Sd/NOBe9YgDEA2BMdBmDQ
SEghvjUxdKwEYHhDUfzkn+LEhRkvjGKLvxHksduoxf+Mm3SzJEu/U6CNhGMGmZTiwekf4AqK
wcWYaFc6EAGq1YehPXXj+tH93lq5cmXE4m2j+K5ZYa7P7eNEqHyMwMlTHxdW1n8ky+4rd/Yb
QqzKbj+Y5cGuSXIhWPFdK2IxBoiAw+QjwZVElBKQciYom+EmOLOWQGVA5k4cdNt9FVEyLxxS
9QO3REuDAzcmkQctpwJKwwQzNvK7vF9eU3HsdJZE4MOAgc8QfW6Q/4lk65IWSsNQ54sMh7Oz
S2ARUWynxbToQd7wKjRUlkRCt/YEnylX29EwMeUfhkJmvBFBkIR88Doi4nrrgRC0ZhjLa3av
mM4qKixvRYFQYelLspNj3vBkPgCPjzG1unpqGljcxxxE9ZSw1955AiZ/3Q787589aSDn8iz1
0z6DhK0QDH5heEBFA5kAMZN2EFhF+3U18MvmLGPBwr+96T/m49JOyT3knYLd25L6vThxbxil
gnuJnVBDTc1Wd/Ed/Koo2S0jaWDMUqiIRQHpTFRQz9MOeki8HjAY8So8K6ubej5ZDUWEsnmr
B8EQfEg4HysigYUHTpD9hrd1EhB0m4XsZhbBu0dmmf3A6rA8181By+tcV8qFY8+FBClW6wfx
9V6eNV9vOX+njLzGru7qxqZToh4eCUGKhtSVkmYs93iMNuwWwdnS7qmdnbeoh2rG98rQP4Us
47uCYJwRyqDr4lkgG0OPiV85Xhd4LUI1MXEgNnM8dgs5e7YV9PSMn2OHmUJkMo1hXpaYq+Uw
O4pdnSiJAdgZ/NZzcP3MisbG7rQ3iIZyfEgAh6yFX5Wx1Di4rACeMdyBVLKh6j5YJr8kUS62
hRi6r9MJeQOqBHxh5at1d47ZEq0ChiwViaQ/6VRAeX7FN6vm7hLTCMEqWMmVCSdSsuXvSOUS
Pw7UWMQWFyeYXCWKEvxcWx+nZCUJ1sL/kX8Jq+0Lz5e3pPYSJgq2+NEqXIYe0eUIJN3/kXXp
oM5N6ia8PGfvwfuk/lAC1zuCoFE5aKLQbp12mOTcJxh4PdUWboEQSw/A6fIpHuDmYGLQYCVo
pMJ7UlhzW4B0oF9Q/PyoR97/4109IGg2/eJvXtgbXQBayiMKYt8gbGEYPh6neIh50H2wQUnr
Rd2DPbXeYMuhaKp2U0+nZ4PZcrYzptBAirRF5bm/188ofNJuT/Gy3gd629a/Iyqgg2cHd5cR
En1REqZCB95W9eAi9iMcXpqwsUp3hUoa/207PlOCi5H+Ych8OlTO6emBCwzyOd4L3upCZYAv
j6PSfLfUzCp+ORRn9wreZn+omMFzDmsOwRKZWKTbWFixYpOKQ3fUZaiYk/p61VVXuRTdPZQW
MArkZkdISd3efLRt6rx3n4+iHx9MF/p795fvyNFE/Zd4PjcU59zV+NjgxVsInsAbcCSGf10Y
jZGlWZrcefMbz4AOca+ookVWr7efQN0IkH16AxNr7i7oUG2KViovyKVOnT8IPwOg2gP3RCsn
0ThB53JABtvSkSYVSkHROlQgz13wUYZqsK9ap6ExMURZC/jVGYm2p7v0pqENJ51vXWshCJnT
hb90LgNygSuhKeEkJyuiCNK2UBTlhtpZxXSyh2MBfkKAjk3XZukmULibRTOut7X7gRZOgMnd
GlA5VvleBDSADRhigAdtLmDYsaqa9vD3lj+0MCMjY3+sYm+/4vZ+MG6hnVawT2NlSPA9p5OH
R9OtKYlAdiB7zF1wzATR6iCI+mXEHjilAxAlx8uf6/7Wc2MhaLOdHF/iSHtRLva8D9Y55KcE
KjwloIRtfQz0xIGaOSWHQ+3zS6kP2xFEkkqhrio1dTNzq0Iw7V5bAmnZQEnD7cLRWKALJQuB
8KW9RkUTgla1X9TOKHAUQVM/gIgm3xDkR8wkmLIHX+ACv94S4RXqV+wWdRfMQUPPp+LVJfYZ
ZMD025BcR32aMWnx35Y9iEMAYtIcd1498wrZndqoS+JAXRRSb758muOEKD6ZC5PVpPHx8eIi
rix9UPgXuo5W8FM1kB60ZuifVO364nxWcXFMKcuox1b3x9b9TCfaC6pq12FdesQJWAQDWgIX
mbqINgACqXYIDcsqcPI7x99qV+0OiOnbNqrUJSu8iN0OlGRpvIaAwZrvoMh5d4ae6Uq7hoAg
YmfYG5odmIu6vqJ2Rn6EUVR4+XbuDQ1+ts1prptjMydbPx2qGUEMYAGwqa+vaevDF2wLYE54
Fr8k9INqm3GkueX8Z/+2pKG9Qt1+4JsLv5fqOktbKvDit0PKEESEwgBjBPJ2USKw00CB51tg
iDWaYOBg6wYw/2OO6ZgJOlcor6JR5nV2Dp3Ce6oFGoS0uMCy766arKbfsGmRBg3dtSclRbgc
RjMg5GLi8+5AmPFAEth6+ZZtnF3URSe5x4w9vOQ5Y4Kt9RKUGKin9aEi9CxXLrz8pdthK2A2
vFM/q3BdCKYTV1gJ3gufYvZA6fqe9F04RjosqCw1G5MTFrrdzuGw1PHfEoWrM25P25GDd8Sf
K7GUUMQ4nfjPvMH1pZxHjx7endUHrnTsBI5ts5P9ZMhrYNEFJlz+7GsLQgiaqtVF/ek7X7un
D9zcPSjx/HdhPZ6hEC8fc9QM+H5wcToS9z2yQYOJ4/8L4tAropgRs1538UbzF4aeqkoouScI
CW+TxRwlW5DkE3p4ak8NivbO3BJC9Qnf4J9+rXVQzfT8JxnpLMYZsCu50QlNFjiRaq2ZXvRQ
nMXGTFa2oP4s1K1/zIQ9JCC9YbhC7bCwMmT+a3iOaxsWDSwOAyBWxzPR3lmNK66svloUXZl2
tBZMvrDqq4IRQcRK6xe0s3rjKDRsZfWjbd4L1t93QYdQz2r7u81HAxsrNHjqJmbe/sCEQ7D6
2t5t+rheGClxJTs5EnEMBledq2II7iPPrHhkWigePHrCcx1I+lvf+p8hN9/4fz9hnvRD8Jh5
j8LzGaavaXILQN4n6Uc8bd49PATDqSu4EJfCBmT3xoWT/IxL6YtP2HZAzuqoW7RyujQwWqKI
OEU6zeA1B3XRIqA7+kCCU6JeNc1fB6ujmxum59eb0usESqGdAybCubbZO8QDZ0ZFAkXHTArr
u+t5yB1g4hMzbXcJyCWq7jvmgRDG+N+2Y7BDFqg4qdJR/iu07qYGT9vurhXxxPPQguDf7ZxS
5qRxZEjVOd7OMy1Umqr+YNPcso124MTMazDoE1PV9awRC153bZw9yQ89cPI/fkbMvN0l0J0/
NLe7ohyIN1jjvi5UqE9b+2In2NRJKml99O1/7jMSJ12ncaoruFojO+QGJgGAW0qIeYo/iMOA
6QTH/qNuDFMM7R0TkMCD2NVbswKHtK09QE64EoJIqmg4avNkDYQMwU+CTmobpt6fA5r3y9XT
C4oaygvqEkXQ1EShnzoAVFwfu6J/UHKKz+9d4Vi3kT4r4y6zy4JRAz7409VJms1KH18zAqv8
mVbrGGQnseedpB7zF9aPAyV0rdU6hfKRe1m/Gngj9By6gsaaGLp35EpsDlVfjwMaSIWrVwMQ
ymY6+gxjS5SMQSZiBvtjq/VCSfvOPG07DhDgPd217BjVjSPO4sjkfJJOPlioAJh2R7C0nlv+
0oBb7nz0wb4DLzzECa5vBDjmMilnLKZgjUAdln5Sxz1ZJeLkG9amBWyryHZuMDQc+/K68jeK
xyGHxRD+Hlyzq6xHKitxZMuLl9rZdkZUmnZrDgUMVBxUIuGIM20TGPLlR/xiv5ppeV+vm170
LztFYKuBM+9Mc3XLYIICmUBN493jtlsG0inj0Ge2ugTeNdaeuhX6n9cb4TviEIE3XNINxBaw
GqguOlPnW83fOR9Rh5LE/9mJ8Qae9t6o/W9w53Qu184zXBkonNJ2uRWCIOFyDQYvpuSJk2c4
fWM45dcCvldIMG4l0PczBH5I3uJGmJvHCtApWb6rw4hGGqjnx8pxIt5fd9svr3mrfuc2lRPv
h18TjwoCjo7LIraGbiLjIHuj4xnxnJyi+nX+upUrH3FsvobaDtoqDQdeHKRncGGG4ZSWHZ09
HobShq6Jf01DGx/KbOeKNduv64EfCJx4NrYbY+G4YwR4a6m03xBoq0HIghj54cFkwQERtBtZ
gO93gBO4RhyT/oGqKKvA6m+smVm6LTyL3Xs4Dh/PGfZ2DiTvUlT2Q7t1Cc8vH24ebHjE08Lj
rNyDGRak7jF64FfgIjuHsMIo6IDIvOHCGitV6siTIZ15J+jEIVh4O+Is3xjcW53z5s1ffQZ0
jXFgaOc31p4JYWrQ5qhxcDHuqSY6JE/mBh3jCzsgEE/sDdh076Z6WDUNx5mTkuRtJTlHS09l
B99VYPhg3Ex8SFAWfqM2dvrjm2Ly1PmvoMRrSWda8WE9AXI2WRmIpE8e1H2gOyxOuAiEuDVt
q6p4b1z53P9+gheOhjGLPs4SZE+W0ubFOaXwC/nk+lI1oH4cq5CEkDQNalAIA7ogz1ildHof
lHdoW2vLix8PfwWDhZRWThwi+QKDBFFEOSwV/Js+YA1hZ0/om+2FS8mjakDcsU/RN+35fpFt
G//w8qPd49Dky+1QqwQTFf+iYWbBm9HgW41LcXPfpQFnB79QXkFTVlId8lY2STAvH2nLqtLQ
tg/vt9m/xmqjwvIVw+cuem6hIwgai7vGtC5IWnBJE00WjR2/J2F1BqshgF1ch8Aq7FWv3EIF
77AhwgkiLEZBTefSxOcWrwGV5rFeHlmvyuJgANgaHxBQ1O9078EtPhjOprr85kdT09JSq8Du
hFsDnbXio9BpKzQRUduOACtb3BNaAcLmuMMBTV3+0lP33mdG9MKfFD7lNN3vDzTMLtg0gn3m
4lPlXEP1z4tVVEJIWpTFS2k7jLPeY8Ht8T3pcEPA1IU/2H7w5QZkpt9JEXCKx3m2KkI8Sjoq
x/kwNWy8WYIOyncfRu02yixsUyWWKVrWFGn3Lle9MgGtmW4rjROwBff6V+xQ9eGwyakRp6lV
4XF0DyQ3Ht6WOkdbejZ9v2ja9xpnFMRBgVoqoksmXRE+1+AnmTaYvCiNoYWWJyZrO+LpkiGO
CMxtbG6F2UjqqOpZHEU7liQlq89vVM0YFSQmgWuAmQ0BbKEgPsaHx4zEZ4cVMewMNCbgsAUU
/thLy+f06rfzwykdGC0mDZOt7uP9at8UprR8FKvhCfGkOUNw5Hgh4lziNJXXYlXuRL8vnF+b
j61jhp16EL8QOsdOEJcd1SheXH22JMj97exoTLVETd0IoYXJV9Rd/EAIhKHmZjFAgIWz6ru4
ALUCrWhA0zMQ9I2xkjdaHtCXAR5HUkW8w0Lg4oRi8lviRDA44ajhV591Ala8MBrn5h0EPt4U
JBH5LHXLIZcuwjlSCBnFCygiHVwlGOxoRNRJ9QCLptkru2W5XlH+6xHgP08xecygnoO8ZggF
2+9NISEd1Ct79gU47pdKizHopcoZFSsrZ/QqgqYudLs8BVgA/0H3gdShnKGqO+u+39XjJr0P
D3FT0pPhsHrTQR7+K+zzB+nIn1bN/W54RU7Ge7jnviKosWC9zeTwPqArpvaEU22E7w9oddhD
LmSco+jKmyGhBSjNAmIvWg9YenV/tfX8wZxwhP6AJIo3h+QOduGZrLWAsrt6Vsl+RvRhe5h4
5la5JSAMtsq7DcGhKwnq/Ip/fn2YaX34+968h3+Kv+Bsz3vRjkwhNe0MnIVx1BCsj1ezrgYb
1rXOocERzjDomqr3Y4DbDv2uW/637pKnwaQbxHJ7H4QJHEL8aAzUX77eZ9sD8fnyJh1rB46f
QsfoAe9kWVWvpD7ytW4d7PKkx0W8ESkUsAAAIIpJREFUxU1J72s9W8KxQ4Oc+Ag8J67r7InM
CbjOwqBBKUCQZm/A6wpOnTME28grvG2i4LrGroUc8XqNgPZ8CK4oC6UmQgtFJHgleFybvi3B
bBHJCxfX3i4L0s+cQtAEnBZZlen/wk0EX2PfoV0p2ARbZu9EVBwne9Tve6kiIu44PUCt8A+h
HZVLEL/dcGB/DfovYIflgeX2y0H7gLBGVLwjsIqHIJGMI8xZ4ZHueaE0jpTWkjzbg79pUZyg
gyVLFDNpbxggkhgEh4YI1gYvPQJuzuDXn/juffEg6Infedo9afbTt1qrZGSunO+9kQr2Yp8D
LN3c0Unu9NvgcsdUxYtM2fUpbkp6/8F92a7UNNuD2pT/6VpD16qcXDFly9agb1LH2ELSJj9a
39lYXrDbqdYVPlo7AKyA8+zQvFQXTje21N1TtD5ULzgiB3uBoEbgstDr2FfouDW28Za3yUUL
6i+XZfnXQaMVu607Vl1TrUzV/3AsJngnuFNHQTBiQ8LWDpHYPJr2u3gmfec6OPHcVxvQFODb
DoB/n4Uvdyt80TxgLG38KSwFHrIq8IaWA8eyW85H/d7uqGMnS82O+IgbEDaTH5LYvClehbEu
MoCIpL3wUAYvgFCvOx3sLdBXwbMLsc/BdFE/ONLCTf608psJzUMhy3UlbG+vR1WftlvdnKGD
78au+rONB0eYbBXgwTGQVj0XD9y4KWk+Je18fPS403dXOFSFMKj14/4Bu6tPd/Huw2luUGE5
3b2PJ54WJHSZo1odfBp3Lx39YysEJSgR/FNsm8+wAxO+XGDA5YkwuY4XXnFl7a2SS/47jtlC
FucQtFk+MFfdIfH9znWBmuck6K11jk742TQm0f0RfZkwEBsZhgz5N50Uv4kYyTgweBBpxSit
OpCKvS26qMuXJ14tVGJlBaj4ExM8/dLSOLcnQ4eQUCehoOg+gl3UZf/0rL3o08opCSHoi763
4jzBLf9Z48RhTrQGeG8CfPe+RuzF0Y+sSscwv9C/j98UD+y4R6mga5PtbIc7KgPLHsEwHOXR
dsB28OaQp3kE1NFsCQ2JkvHr2h+dqtaIBVDbYcLtZD1nJ5C2Q4D5SIc0LJD/B2A0qwFqn0Oh
IZlo9uLKhjtE0f0MdOYdxs7tNeHh4a8irwvigLbaJFvtBXiaDzD/Xlc9q3R1ou12Kj1p0/h1
dSWO0cLXQ30k4fL+zft3gVG+1moZZNoPTa4rSA5lFcaJyMeL6X2AnEUdrA1VEN48eHT/0Ld/
NvmtRHc5l9z/p+tEj+t9GL/QmYjkZMlWmFixxS2J0kWt/qPLCJAnNeMS8ED/FO/p8PFPKo67
xO6gpgoSvzGgCxFHNVH8yRZkwX29XawBKivQVzAcm8Au5h8DC2Dbxhc4KqvNqyqfRfS5Ydha
kICxhLTs/tkRMGM8lFTWL8ERXU8GedB2ezt6YUBbHSydjhTLVkvQty+zyg4IwSGZFAxKfhB6
PlHXHUd3PEWIlVQWoex+NTmRUv3+X5GKmeVgcHnbj4y1zd60XL6FjIos9tElWcaJ4L96r+Ka
y2ueuK3DR3q84C568K9PGympL2kYz2QarkuCNOGB1xMa153LOjyg+RYdpxRtmDv+c3oHdswE
pisPd07X3XNcSLpw4bph8N6EY5psUFpmDWj7r+1vvDtve3cVOlniYT16re268PzevUrKEdtw
2gHIMv9NTMa45QjRyiU9d81Q39g4+0sR/GMMHFsfF+5NmcgZV0Urs3Nc4cKPh5UtX/9v1GWa
k0LCzuUQO0NR1Q2d44tVIc8WAmsHKAjCEd/RI//sDP94Px954JpDmJqPm6wig11VUFnXt3ZW
4dPo281W6wLhoQzx4x1W85+IfKB6x/hU/dEPH7zye4mWf97Dr9100U/+uRk87e+o6EzzfEQS
OsopcFlqDEwUXnh6yAd+ic3vo6E4TDUBu68vQs+xrnEhaYH5C0iVzG6g7SHOzvyXXTi9nd/0
XWBwhXYWJeJH40TizyEoIEarQ8HAcVS2cCl2WQap3v20c4WAom2RsrqukCrazIlRXEeGyiKL
UlDP00Q5czPOT/ySXTXCENzurnRKKyZEFyQNhmVukC3fXc744gOqvna99/zW+FL3cirV/wtB
dnlJmwV+t39Cpfl9geuJtWWlZBoMWLj/B1SVrXFhpWyreQQmqx+pFz8Qb/7JcApV+uM3x47/
6b+qeTnt9+CJDQvqV8NNKbktJe0QsE7A7Ld8QgsWzEsFV4pbZdpHVK/RlfWF6FiToo63nnEh
abjtKwsKdeIFGz2dOSk55hiPNnop9mN5TSsTSOHdRjD9J3D6RyE9ZBugzKzFlXU3gfJMswsH
lnEbGmeUdJEJQLBhbzHB2oHZXHBkQP8oEusKvmRJ/b0cS92INixxQjc5nn4gN7W6wXXZtcHV
c6EG9oCdQLrRmMJ/c+r72qkL5a2eXbpP9be9Sfshl+y6ddSy1f3VDM8m7Fy9VmATgYKdQgZk
Bg9ayX8i8vj4tnfi/R7jHnnnsu3nDPlEcqfWaaJQjDM9TdNxFQabKu026ScG73UBXjAtBomX
ygO+tmUhJ2YezvgOzEMTwoFxbZ2hnlUM/1oWq3ksG3i0ulfzOe645FgJztyJol5IPD57gVTn
NWe2wrCO47imu8DQt1UlorIg6PprVCC6sQeerYZEfRdnJC3C2HHdWLq06UqON940dG4P6LGx
GP8XQCPF8dNPYlWL/JCIHN9lW8lJciEHS0PUy3IgrykKU1+0DKAXMrb6/XNS3eJXOFVNTeVS
b6m+fczjxUvq3hR56TorevWUBz50HixaUPN67ezik37eVv9g0r6eupW8KvZR+l7BOPE+qL+N
h8tMJIdRGHEJICINMvyCW8qQVxzSt9ZEzRJvvt+CzzIMPdCvVvTfSPUiwb+utzXWzRi7lZ7j
DfFR0rwBEj1ekN2ng/38gRRJ77Eju899/N4YnAQn//h4NoKG7b/qbfvQBoiOrOf2+ziNF4RS
O+wXAkYsK2xeX+oAHHaDLfJWkxYOi7Nya/rbMPRMQzNuAG9rBrbLl8D/yXFH0FR3XVVZi+Dv
gqThzCHX9nDWjH1OHSZspZ+j5dkw5+zNAsdWEeKBM4KbKY1fE39CFr6WAyhqXhZM9ollGBYz
ytNeyCemi8XsEdmKHl8zJVUfuEuX3S+rPDeeNDeCqnrktjTI2jBZHaCkzZNZoC0D4xe8Ax1L
SNxCOEP03wxkv55NHWfuUt2878K9mtZJqyo24JhIOu/xD/vBjHJobFBxpNC1XZ3PmIsj13FP
gjPvioFcbJULzuDGxrnjD9oC0p7ZJ6bfCqOadFuwwIRVAr49ODrsg2hwVN6Aiaq9NkeDe0Lj
sJnZMHXcgfA6jMDBs0BiZ4bHWbnX+ZNTthJQlcUCnZTN8cWFi9dcuRYntmMH1WCljZSHdkci
L19asLTuPKswuuYD4g0/MKBrAjOGk0U/rBytI2nwnPMX1swqWtK0ATygF5ko9NUI5xMCNpEx
XcPvCUHjHFJC2vQefGmwP9RmXX+1myoGoyuedkd7j71ait6qzQ29g77I8N0HSyLGY+hdT9eY
7A5BSr2Y+Ku2LO9QA9IqUFSlrvMZcz1V7kS8y5vcKOO0k1x7ZZue7960B+NYboEzHqJDWO2g
UBrp4Ed3SxFJAf1f5mHzx4o9pe9ISA0DHTJgiOi2NDFjAtmwQA3RevuoMw3NkV2S9UpEz9mm
p/yZU3xvSbzwZZ7z3Acs+4ZaWbtMEt0Lrbqh1TSFwzFjs1CiQ94cwVhYztqit+BYrH/B9RvZ
HQES2oFtlkCAfvfofYUXAmv9AW5Xc1QVIkGoa8FWHC5JQ3Do++MhbJdBM8wcFfhDVotg8x7V
A8r5OGmo624sBIaue91Q0TN2hhgmEJBLR/yZfF35yA6NDhhs3QPo78bLMw8HH5OSFgV+cuQw
D8+eyL1Z1KpEcpyQtBcqF4Py6PiUVupA2XUWeMdK3s55ChbVTQKbom+IR9b5fdzPvNB8mPd2
axkn8t61YKn03qGpcVc0mJD451DNSDBX5+R8FNaacbVdtg58z+iKHljdubST4Zl84viZcgec
vTKB5y4qXlYzQt0nLQd/GUjRRn9y7Jtj5lUPPb5tBDL/9U0JIeixj1WdOfZIyUeyJPyLE/gc
nPeIZhPDGT/0SZDFQVfykIcraXFAQEg/opyJ9WG43VC7k1YdPOobW3d3UcxdSArUuMIp/oAh
X5YueeeE+so0CtL1xtrpxZZ8+PSMpCGwgvAH2xwbPK32mpKVXEDQ/hWq+Ml6haBpit26QQ8e
bC8p5seNpxwZTnNIvc1OIHVATNKazbvKukXCnoPeNvC8t9opx6m8hKDhQvRP4GXvtw6T1O/U
vZ3zoycmhlNPnd/H9YzzKg1VA+V0coZ100u2tvn3DQUVvZ3TxeVk2aYy9oAdHE3sv1S31EEZ
nlwtD/KtcyvXX8WlpW2Ff+hxQUFpvLslLF4mUQBELkjb4FN7etO0MRN23BefLnPb8pt3hVs1
giIXgDffC/XRB03DXdiLWN6F9Iik8/s0ZIsed7ZdgRVVFqdHNK+dVvJZqOIn5RU6oSLPXUwD
0l7gAl61JSEKIFp5ZcuWSTi5+3q7OxnzRHBVWdTTVovYULqqvUaqZScyEFsMutzvVpfn34At
p99WXTQuAsmfC2k7joc6w+54xunz3kNuFgHbVj17IfPamedv8+n6baInbWLBwrqrMgztWRzM
0O0iHasKQfVZ/obSJY0zY6U97u/vWi4O/sUHX+Uk4XXaw5p1TaASQVVNeE/WtO/k9qk6Cwh6
aQLZO5IWLqgdUlJZdVHdtKJXa2YUBNlhIHT7p0pc44y8lo6ECd70iKRhOzsQFIOcIMzoyXne
8koSHaDzsSULq/tzomtgoh85vCbEC4VN7ufrZp6bsIAgHA7dq9r5/wu1Rdv9r+nq/tqZxSs6
w+/83KwFHrfrF6QzzESeaYEAq3glTtqeGMzH7Uokf5e0PAdm5LHg41sHgjdpqz9NKl8z1n0x
dVxMnuqxkk/MXeOM/LcVX/MKSXb9ahUOG9Z07SMan1YDzQuMx4V5OHTCKoxgPlC+odPFKyq6
4qCrXne5Zv9xUlgZPVd68F1av8zsOYmoqJrsNBAE0DH8FIvurc1tB7LXlY/9rZ2ThXhReItj
0qGwejMijOpsHvPXtYPCSoAaWgn0o9ES+wGI4qRndRiC6zTQ/LYmMW2bdI7ZFhqSdR5cRs4O
btvs9b+uc4/FA2EjDCKgFTDPFu8ynoKipcGEASn/26ppY4+xm9qP9oqWPHYcRq/BvohIpwtD
MZFtbRVocvOc9rcIuCfxQ830whthdTkWso274BfvcZM3a6O+5DfcLbp+e97jH3qsgwGveeWU
oNL/F6PIsVckEv7bJL/BBYLsJELmd684vaeyRvTbKOHklTPi2gGbAkFJ0Tm9SlECExrvHHHO
2mm5v9s5d7wlox+zXlhoSpY0fAKLT7WqvKCup7paedcjkuYl6SInjhcChUQyVNMs0kolj1ce
XYDTHU21tSjRVloQjD/brbMWcJ0D+SPUxewFXnQpmhq/Jz5vW+uj0OYBC/P4BdIeUpXAnVAP
/E5EqTq3LuI5wQf0X8Tk5yXuXCx6EXEJgiTePugW/fVE853I9HCR+R23J22R37/jE2hpRRGm
Jly7sW2e9E8SzhUtw/KbwDYKmpGEvw7MvymI7AiZz5+ynd38u1TwfaPiK5/qpvg0IPtwEBH3
xPIjMxWca/lYQNHGNN01pmzDjLxVEYkmr8jsoPAjXvT8UDxgym9EQTrb33L0mz2ntPY2aqND
oECLXBK6t3WFoIXTjO22YByHzDITJtrVooCwS2/27XzfdnVF4V5YPfb4fWKVwUHtSAl4G+h0
4lhpQ+/Xzhm3S1XavntceNOgauDoaLviN86rm1n061AdQlddUTc64fM5BA972wuP3Vu7A7sg
cCJdk1qpdc3Mot+qgVZR9pz5d07nKuywPKh8Op0cKn754E//1Ep9eswDyjmHEHLn0N/dx7O/
4Lxo+tVu8XMJaD7F3AF2xtO0s2X8HhhZPREIHMpsKh/1/Q3lozZ3Bk/P0un6UNbX44r2Lmoc
UdCVjUskSbq1zdda3HBP2TEq2kGfJ90igVGPre6PBe6MqJVLJBJ0iwFMwXxsbyLZTkRaTdMv
s12uIDZunD3JlsCrcP6n+aIgXGO3LkTVq7xG+q0JhdqZpc/CfPwXTniK665gUPhQGtKfM4yj
I+pm50bfZQlaI7kS6A5GrHjYykWOb0MbFytPzPecsDZmmpMwAcbCfIFnZ2tM+y6QtOU+DTWN
dtgQ7P6g6PGavFCcU9c9h6Fx2jnMm/J5lqRVsQ2jIuQMlEziM/ri5EPToITGPP1IfdPA5+c0
9j9Hdh8d3jh1zJzOnh87F6E8/o1atvzauGQNhU/Uji7JmbwOZvPTfGrLtxtnl3acu0jvRv/m
A1D2zoTIQRwGU3a7JuBs97AYa7d0WjbOBl9vl3lurfT4c5FklvQq488RPaWhBY6tptGTxI7l
5VZFVx82BPETGmxBZ03dfqpu4WEy1jdOL4lqYdhtpvYX1TPyH1A15ac4lw0xtjgEHUUR94F4
ulBRbMDJrVeDf3fzmnaT2Y5EYTfwWPIF2g79w65zNixZ97e63sGTHr2wdhh2FpYd5YQKAUXm
iGplCN7xutaUF87VGbddFMUyINjEB1OUigINMiHV9XyUV9aiyp8eaPKqXw1DlJNXeBjOGiSA
O3EsF3vnYpWVryDWRseg5HUjB6bvgjlXsBLB5zrc8bLlPOcf2FA+6tEvKpwV8hYvrrtT9siN
As+PBDGztH56ye9DDYYHzYEtnOhdf/sFljVpQrBC124/ligaX6ZG2/3BaoeUYl4NFXiyXtHh
l5tbfBttJvUxTWfVdttYN6toS+20vAer7xpz7v5DWj9NUX8IrYtNvCgH4t3+U12gY/+0nbrU
TM/7X43p1wG5eeMtt7vygGyxAeSOwlfvtDXTxhasnpkbk6/bd8+hParqPRBcpBIci8R/hIQv
VB8PDDuc+L6qrteEYJ5iV3iH9V0G9UbbVHRHu0Gxgr1XCA+HT3bE2bmpvG13KHv6jJey2Kzn
MoC0veyZ23zy3StuCr2DMyQILY/xsVWJjSRCQvUHiO98wOv1jls3bfTUhjsLbKvBdpRJNxjB
RQtrrpBcnmWQTdCicDjgYz8Mpcl/oj7HpakjNzvsLz86qYzK6Esb3w4EyGG6vW8KvUWR+fQX
Qw05Wa+6pm2BOfgcHbPQah2x9RF5Q/iT1fzR8m1/oPDQdsZ+hhHy87JlTacrinauJIs3YcP6
NVD+Jn8w2rwjpzp+w/u7aDATiauZmvuX4nnVgw236zaRE+4HJTyAxkQsrROYoGPe0KKlYvrw
b2iGsUBvVt5NZEdFutsFC6vuAHIdgzZ2INx46o9FildV471QWtjfbQSPe66aIJxQfrqKEodT
5Ngr4XGn0j3UMDdAZzpPkvhPsadJM9kCNhtAYw8WsXfAU96TiXjKI1/OK9O1HPabb3bsdsKr
0uxp8bGj3iBrY8afzgzMv54odi5t2u+yW1y+CB/eHBNzTVsA3fvCtnW1lb55k9ccg0UU9zGE
fiw+8buSpU2/FWTPTVrAx3GidNB3uOWcxv8ZZ/rnKZu3epAqaIVVs4rfSBxyzzk6tgw9J0u+
Pdl6YMSs113pY864EYch3ySIchHMX83TI2jSEEsBFPATNdPyO0xTnap//tL6y2SN/wZsqkoF
Xu4HDmAKKAwXWCsiJj1R+m0QoTdDJ3cd1N3eaObZHzdNLzrp5RFO9c+pAId4ppJHXoUVvr8T
iBqrMAL/j6ppuVfE3/4KPm1WblbLwildtU3uer4/6+P1s1/eHmIZUAlBntddKzJlmZ2hMW6I
5lOqyGx8VOXaV7Ho7FlfPuaOjvJJdQ+aIZ7yleO9rh3VbN5cyyp2Q6BumO3J/AzykdPIjoAT
5BZfW+sljfeUfErlEYtD5PTJteUFCzvKd/AmiaQd7MwTAgq7nrLlazxevzhalqVpsOO/VZA8
QttRf07j3Dxzle+NetEJLFvPHCqmtrWJaZrMqy54tPDvM1SXSOp7ypq7ykBCO0PB9Eb9/9th
0onVKWn9ngAX6rtOIGoiDEBTv39o967Lt1Zc7IurfysqRNaYK5ksjfAM3wKbY4CcziAsDI8O
v3ff/dLPfVLLT9hjt7SOXbLuybXVLeVsedAlaHi6IO86+jjMr1xTyLG2HfXlEw5F5jn2VLyw
4XycbbsUsoh8ioV1oq8toI2Bd8Ft9IydCU6tYlNq+6+rYDgUmOKcDkkk7XSPnmh4oCCKLskr
q52W+2kSSZ7oj3GSlw9vcWUHC1YBkTlylFkQURsfBJj/rsZppU1RW4/x6e4vnOlbcv3mqO8p
cvJkgeXlGayRiWzlgwq7+dkU9uwt7SyOIPtCnvPilMC8G1e45r4watSI3H3eV99p2zZ8cLFs
6NtawWVjnmYf25LeZgoiuymopLLuvexW46p/RLEILFrUdDMnGNMFjjuP1HJJ6A0+6Aa9LfD1
2rnFjQSyaEnDFeDnnV07s/An3RThSHQSSTvSjUkgyR44NXtgYsUWd/PAtr2gptOdaQHQGZQF
VM24tu+e3X8nuYJtuMS6yGsyWMWDpFtnBA1OmjwsOzeNce4stvgrQJpA3hUrJXZgN8cWzoYf
6hWy6xB/l3/+DYu6K3/Moqrz1s0s/TeDf43iATVXcZxUigIKeYNBiYDPgMIDwAJBQ76CS8PB
3XvODu0SShbVTkdL86pmFs7sDr5T8ZDuJEOyB5I98N/aA+9UDPMFmHYFqZTbNXIJ9iHoThw9
Bx/orx4dOPCz0sX1FZb6lhBzKKycosv7c/Oku/80w4wauBsKD7leSeAHyWIArisQZrw40nWU
v9RE0HiUDglFvF+Pavk78ekt7pLKhj/JTCouWtTwi7JB63fCpctfwXN+GMe83QBXwxnmaTbA
zEGHX+ypqrcaiglBT15hCMVLG/8K19TK8UDQ1LQkJU29kAzJHvgv74G8BQ1FLln8Gzb1g6Jp
C1ntHvgoB0fAeF/xaZMb7klAJW7WApeJcO9+PocFIJBe8q1DmTNfGeZ1tbgCzc2bXCzzjAyR
33PUJfzc0P1PdpiRhyr6naf75BePcwku/jZe10bi4IInRUE+YojCLKimfiaJ8k85Q/eYLBpo
IHUJZJ/A8X5F1ebWzcivpPcFy1aPEQ3PMghbflQ/LbdDc6hLXocjkkja4Q5Ngkv2wKnaA3Dq
lanrnp8LvDA96MPcOfQAo6hWaEZ8Aq2fN+B+97W66WHO9MknR0VFdNVXUNSpfVhB62nZDQys
E3H2H8arRuYatnCSX5z1x1+JIrfYN68rfzsX7lk9LteLoOrTiRQ1LVc5XoMAUCKWCQLKM45R
62EfzaSeGVvj97V+vfHucdvxiitdUncPDqX9VqD18OVOHYsXVmSPt859hR6LSb5M9kCyB06V
HihZXH87L4rkTqDI1PwgfOZAIKqVfkCOTDH0B92B5ic+nv2lo2wiLArfuc3HRsxysSFf10yr
wijlSbNeKmKCl4MN6iGcqpIe8B3ZzJZPbeuctHh+9UgxNXWNrgQS4rNT3WBw1QbfJAvgLvcH
VNGixfVfl0TxpxozPqyemnt757KOx3MSSR+PXk6WkeyBU7AHCpfUThcNfg4sXUfoOOfQySbA
NYDJbNVU/V2dqb+AcM7DFKWvLzVl5fodo1vZg6RS0a46N7lCNrU8QAG7Z794sU9orpWNvk8H
Wg7exX59ZxerwsLK2jtk0fUkHJTFXWWyRoWBVn1Lq/eSojM2H/p069DsrPSUpYwXr2aKdsH/
t3cuIVFFYRw/555774zjNCqmi4TUaBFoglFGUdHSTcvATYu2ThlC0LbHplWgFemylVi0q02r
JHsIafmAkF6SUMIsVEZz5s499/Q/dxwQUUm8M83oNzDcyzy+c85v4D+H73yP0StNI/9sLOAP
Bgo+4LmROSJABIqAQOuDiXPMNJ8ZnO/fQcLmhivRh5U6S0XLsX/lhoPTuhnsgr8iumIWUj7l
cctZSfKB6W9DUeyc/UYQZ5/8rpldTiVnLjemELMfTtQwJFNV1UsVno8Kbxg5040bDrjmxezY
OriOvU5J1ZVOJL+X10Q67XCkG6UYalGO4N7SvLw5feNILqlmzbcLd0siXTjWNBIRKFkCush/
KlIxiOiHdkQ+oFurltR8PlBMYLW0gC6n47oZbKzZPMohJBBZ4eDarCOmoe7JbPigFltfcP0d
uu+m2WR6fhQLFw7iUKakm76eVqGJiJC3sXXvNK2Qrm0+aWdUx0hX08ax3pvYzdfLJNL5Ikt2
icAuJNDSM94sbKtfCHEaLpD/sEJIllatbf5JaGHmBrqBey7KCKu+pYzsK0OmoC2sOMS5EjZt
lFaYQ+eZS4ZwhraqzljoRZNIF5o4jUcEdgGB448mzyvDuoMgiTOoAVLUK4K/2/E8NQwBfouj
S2FYdh0OBy/ivsx33xj8s3LdnrF4S38xLoREuhh/FZoTESgRAi0Pxy8I03oKwQsF7a8ODIFi
KPzF0sIM7UO8tA7AY9y0mYTfG1Em8an40ZeBjZUHQyTSeYBKJonAXiJw6O6HioqqcqRJs6tw
KhzQO+sgE2KCYKlrkmuPNYrsJpjkj13PGUDLtrEgbOfbBol0vgmTfSKwhwj4pWw9dk1Y4RPY
WVdni+MDwDZ9yDtGpk8bMSYSUyQSaRYyMjWqXHkfNbWf79h2gQ2QSBcYOA1HBPYCgZO9X2J/
+Eq9Jcx2ZBh2QDOP6Uw+/fAbRgQt2hjA8GOvsVtGmjfMT+JuMO25L8Km/IGDwMVS5U4iXaq/
HM2bCJQQgcO972NlZqyNM9mGeOtWCGqD4EL3JkTXWRnN7rThkNA7YF+V1kvTaiA11NcPvcPa
IcvLaAuzgIpOc1K5P+Fr/ojU8zGWZm8+dbculBCeLae6nsSWH6Y3iQARIAKBEECzCnaL8Yb6
V3Z5orbSiMo6U6oGzxAHlaliQhnVHvQ4Nxb3PBTmx5PzXxklZ9hyZjZmuovvuk9lGwzkshNz
X6ArESACRIAIEAEiQASIABEgAkSACBABIkAEiAARIAJEgAgQASKwbQJ/AQb4me4AfccBAAAA
AElFTkSuQmCC'! !

!PolymorphSystemSettings class methodsFor: 'settings' stamp: ''!
appearanceSettingsOn: aBuilder 
	<systemsettings>
	(aBuilder group: #appearance)
		label: 'Appearance' ;  
		description: 'All settings concerned with the look''n feel of your system';
		with: [
			(aBuilder pickOne: #uiThemeClass)
				label: 'User interface theme';
				target: self;
				default: (Smalltalk at: #PharoLightTheme);
				order: 1;
				domainValues: self uiThemeClassChoices.
			self morphicSettingsOn: aBuilder.
			self desktopSettingsOn: aBuilder.
			self soundSettingsOn: aBuilder]! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopImageLayout: aSymbol
	DesktopImageLayout := aSymbol.
	self desktopBackgroundChanged! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
pharoLogo
	^ ImageMorph withForm: self pharoLogoForm! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopGradientFillColor: aColor 
	DesktopGradientFillColor := aColor.
	self desktopBackgroundChanged! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopLogo: anImageMorph
	DesktopLogo := anImageMorph! !

!PolymorphSystemSettings class methodsFor: 'sound' stamp: ''!
soundThemeClass: aSoundThemeClass
	aSoundThemeClass ifNil: [^ self].
	self soundThemeClass ~= aSoundThemeClass
		ifTrue: [aSoundThemeClass beCurrent]! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopImageFileName: aFileName
	DesktopImageFileName := aFileName.
	self desktopBackgroundChanged! !

!PolymorphSystemSettings class methodsFor: 'morphic' stamp: ''!
uiThemeClass: aUIThemeClass
	| themeClass |
	themeClass := aUIThemeClass 
		ifNil: [ UITheme standardThemeClass ]. 
	 themeClass beCurrent.! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopGradientOrigin: aSymbol
	"#Radial #Vertical or #Horizontal"
	DesktopGradientOrigin := aSymbol.
	self desktopBackgroundChanged
! !

!PolymorphSystemSettings class methodsFor: 'sound' stamp: ''!
soundThemeClassChoices
	^ SoundTheme allThemeClasses collect: [:c | c themeName -> c]! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopColor: aColor
	DesktopColor := aColor.
	self desktopBackgroundChanged! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopGradientFillColor
	^ DesktopGradientFillColor ifNil: [DesktopGradientFillColor := self desktopColor]! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopLogo
	^ DesktopLogo ifNil: [self showDesktopLogo ifTrue: [DesktopLogo := self pharoLogo]]	! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
useDesktopGradientFill
	^ UseDesktopGradientFill ifNil: [UseDesktopGradientFill := false]! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopLogoFileName: aFileName
	DesktopLogoFileName = aFileName ifTrue: [^ self].
	DesktopLogoFileName := aFileName.
	self desktopLogoChanged ! !

!PolymorphSystemSettings class methodsFor: 'morphic' stamp: ''!
windowPositionStrategySettingsOn: aBuilder
	<systemsettings>
	(aBuilder pickOne: #usedStrategy) 
		label: 'Window position strategy';
		parent: #windows;
		target: RealEstateAgent;
		default: #cascadeFor:initialExtent:world:;
		domainValues: {'Reverse Stagger' -> #staggerFor:initialExtent:world:. 'Cascade' -> #cascadeFor:initialExtent:world:. 'Standard' -> #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.' .! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopGradientOrigin
	"#topLeft #topCenter #topRight #rightCenter #bottomRight #bottomCenter #bottomLeft #leftCenter #center"
	^ DesktopGradientOrigin ifNil: [DesktopGradientOrigin := #topLeft]! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
useDesktopGradientFill: aBoolean 
	UseDesktopGradientFill := aBoolean.
	self desktopBackgroundChanged! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
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: 'morphic' stamp: ''!
uiThemeClassChoices
	^ UITheme allThemeClasses collect: [:c | c themeName -> c]! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopSettingsOn: aBuilder 
	(aBuilder group: #desktopSettings)
		label: 'Desktop';
		target: self;
		noOrdering;
		with: [
			(aBuilder setting: #showDesktopLogo)
				label: 'Show logo' ;
				description: 'If true, then a logo if shown on the top left of the desktop' ;
				default: true;
				with: [
					(aBuilder setting: #desktopLogoFileName)
						type: #FilePathEncoder;
						default: '';
						description: 'The path of an image file for your own logo, the default pharo logo is used if empty.' ;
						label: 'Logo image file name'].
			self desktopColorSettingsOn: aBuilder.
			(aBuilder setting: #desktopImageFileName)
				type: #FilePathEncoder;
				default: '';
				description: 'The path of an image file which will be imported as a form and displayed as your desktop background';
				label: 'Desktop background image file name';
			with: [
				(aBuilder pickOne: #desktopImageLayout) label: 'Layout';
				 description: 'Size and placement of the background image';
				 target: self;
				 order: 0;
				 default: #scaled;
				 domainValues: #(#center #tiled #scaled #scaledAspect
		#topLeft #topCenter #topRight #rightCenter
		#bottomRight #bottomCenter #bottomLeft #leftCenter).
				]]
		
						! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
setDesktopLogoWith: aMorph
	self desktopLogo ifNotNil: [ self desktopLogo delete ].
	self desktopLogo: aMorph.
	self desktopLogo
		ifNotNil: [ :logo | 
			logo
				beSticky;
				lock.
			"The logo image should appear just below the menu bar"
			logo position: 10 @ (self currentWorld menubar height + 10).
			self currentWorld backgroundMorph
				ifNil: [ self currentWorld addMorphBack: logo ]
				ifNotNil: [ self currentWorld addMorph: logo inFrontOf: self currentWorld backgroundMorph ] ]! !

!PolymorphSystemSettings class methodsFor: 'sound' stamp: ''!
soundSettingsOn: aBuilder
	(aBuilder setting: #soundEnabled)
		label: 'Sound'; 
		target: SoundSystem;
		default: false;
		noOrdering;
		with: [
			(aBuilder setting: #useThemeSounds)
				label: 'Use theme sounds';
				target: SoundTheme; 
				default: true;
				with: [
					(aBuilder pickOne: #soundThemeClass)
						label: 'Sound theme' ;
						target: self;
						domainValues: self soundThemeClassChoices]]! !

!PolymorphSystemSettings class methodsFor: 'morphic' stamp: ''!
morphicWindowsSettingsOn: aBuilder 
	(aBuilder group: #windows)
		label: 'Windows';
		description: 'All windows settings';
		noOrdering;
		with: [
			(aBuilder setting: #preferRoundCorner)
				target: UITheme;
				targetSelector: #currentSettings;
				default: false;
				label: 'Rounded corners';
				description: 'If true, then windows, menu and other popups will have their corners rounded.'.
			(aBuilder range: #fullscreenMargin) 
						target: SystemWindow;
						default: 0;
						label: 'Fullscreen margin';
						description: 'Specify the amount of space that is let around a windows when it''s opened fullscreen';
						range: (-5 to: 100).
			(aBuilder setting: #fadedBackgroundWindows)
				target: UITheme;
				targetSelector: #currentSettings;
				default: false;
				label: 'Fade background windows';
				description: 'If true then, background windows appear more "washed out" to distinguish from the active window'.
			(aBuilder setting: #fastDragging)
				target: UITheme;
				targetSelector: #currentSettings;
				label: 'Fast dragging';
				default: false;
				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' .
			(aBuilder range: #textEntryFieldMinimumWidth)
				label: 'Text entry dialog width';
				default: 450;
				target: TextEntryDialogWindow;
				selector: #minimumWidth;
				range: (100 to: 800);
				description: 'Set the default text field width of the text entry dialog window' ]
			
			
			
! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopBackgroundChanged
	| fill |
	
	self desktopImageFileName
		ifEmpty: [UIManager default currentWorld world backgroundMorph: nil]
		ifNotEmpty: [ [
				self currentWorld backgroundImage: (Form fromFileNamed: self desktopImageFileName) layout: self desktopImageLayout 
			] on: Error	do: []
		].
	
	self useDesktopGradientFill
		ifTrue: [self currentWorld fillStyle isGradientFill
				ifTrue: [fill := self currentWorld fillStyle]
				ifFalse: [fill := GradientFillStyle new].
			fill colorRamp: {0.0 -> self desktopColor darker. 1.0 -> self desktopGradientFillColor lighter}.
			fill origin: (self currentWorld perform: self desktopGradientOrigin).
			self desktopGradientDirection = #Vertical
				ifTrue: [fill radial: false.
					fill normal: self currentWorld width @ 0.
					fill direction: 0 @ self currentWorld height].
			self desktopGradientDirection = #Horizontal
				ifTrue: [fill radial: false.
					fill normal: 0 @ self currentWorld height.
					fill direction: self currentWorld width @ 0]. 
			self desktopGradientDirection = #Radial
				ifTrue: [
					fill radial: true.
					self desktopGradientOrigin = #center
						ifTrue: [fill direction: self currentWorld width // 2 @ 0.
							fill normal: 0 @ (self currentWorld height // 2)]
						ifFalse: [fill direction: self currentWorld width @ 0.
							fill normal: 0 @ self currentWorld height]].
			self currentWorld fillStyle: fill]
		ifFalse: [self currentWorld color: self desktopColor].
		
		self currentWorld changed! !

!PolymorphSystemSettings class methodsFor: 'desktop' stamp: ''!
desktopImageLayout
	^ DesktopImageLayout ifNil: [DesktopImageLayout := #scaled]! !

!PoolDefiner commentStamp: ''!
A pool used for testing purposes!
!PoolDefiner class methodsFor: 'initialization' stamp: ''!
initialize
	"self initialize"
	
	Gloups := 42.
	AnAuthor := 'Ducasse'.! !

!PoolDefiner2 commentStamp: ''!
A pool used for testing purposes!
!PoolDefiner2 class methodsFor: 'initialization' stamp: ''!
initialize
	"self initialize"
	
	VariableInPoolDefiner2 := 33.
	AnAuthor := 'NotDucasse'.! !

!PopupChoiceDialogWindow commentStamp: ''!
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: 'compatibility' stamp: ''!
deleteIfPopUp: evt
	"For compatibility with MenuMorph."! !

!PopupChoiceDialogWindow methodsFor: 'actions' stamp: ''!
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: 'actions' stamp: ''!
switchToNextColumn
	"Give the next embedded menu keyboard focus."

	(self choiceMenus isNil or: [ self choiceMenus isEmpty ])
		ifTrue: [ ^ self ].
	self choiceMenus detect: [ :m | m hasKeyboardFocus ] ifFound: [ :menuWithFocus | menuWithFocus navigateFocusForward ].
	self choiceMenus detect: [ :m | m hasKeyboardFocus ] ifNone: [ self choiceMenus first takeKeyboardFocus ]! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
choiceMenus
	"Answer the value of choiceMenus"

	^ choiceMenus ifNil: [#()]! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
filterMorph: anObject
	"Set the value of filterMorph"

	filterMorph := anObject! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
lines: anObject
	"Set the value of lines"

	lines := anObject! !

!PopupChoiceDialogWindow methodsFor: 'actions' stamp: ''!
switchToPreviousColumn
	"Give the previous embedded menu keyboard focus."

	(self choiceMenus isNil or: [ self choiceMenus isEmpty ])
		ifTrue: [ ^ self ].
	self choiceMenus detect: [ :m | m hasKeyboardFocus ] ifFound: [ :menuWithFocus | menuWithFocus navigateFocusBackward ].
	self choiceMenus detect: [ :m | m hasKeyboardFocus ] ifNone: [ self choiceMenus last takeKeyboardFocus ]! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
choice: anObject
	"Set the value of choice"

	choice := anObject! !

!PopupChoiceDialogWindow methodsFor: 'event handling' stamp: ''!
processEnter: anEvent
	self choiceMenus do: [:embeddedMenu | 
		embeddedMenu selectedItem ifNotNil: [:item |
			item invokeWithEvent: anEvent.
			^true ] ].
	^false! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
filter: aString
	"Set the value of filter, used to match the valid choices."
	

	filter := aString.

	"As this method is called during the update of the list,
	and the list is updated after filtering it. 
	We have to ensure that the list is not updating and generating a recursive call"
	updatingFilter ifFalse: [
		updatingFilter := true.
		[ self changed: #filter ]
	  	ensure: [ updatingFilter := false ] ].
	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]! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
choiceMenus: anObject
	"Set the value of choiceMenus"

	choiceMenus := anObject! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
filter
	"Answer the value of filter"

	^ filter! !

!PopupChoiceDialogWindow methodsFor: 'actions' stamp: ''!
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: 'actions' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	self filterMorph: self newFilterEntry.
	^{self filterMorph. self newCancelButton}! !

!PopupChoiceDialogWindow methodsFor: 'event handling' stamp: ''!
keyDown: anEvent
	"Look for a matching item?"
	
	(super keyDown: anEvent)
		ifTrue: [ ^ true ].
	
	(anEvent key = KeyboardKey enter or: [anEvent key = KeyboardKey keypadEnter]) 
		ifTrue: [ ^self processEnter: anEvent ].
	anEvent key = KeyboardKey backspace
		ifTrue: [
			self filter ifNotEmpty: [self filter: self filter allButLast].
			^ true].

	anEvent key isArrowUp ifTrue: [self selectLastEnabledItem. ^true].
	anEvent key isArrowDown ifTrue: [self selectFirstEnabledItem. ^true].
	anEvent key isArrowLeft ifTrue: [self switchToPreviousColumn. ^true].
	anEvent key isArrowRight ifTrue: [self switchToNextColumn. ^true].
	^false! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
filterMorph
	"Answer the value of filterMorph"

	^ filterMorph! !

!PopupChoiceDialogWindow methodsFor: 'actions' stamp: ''!
activate: evt
	"Backstop."! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
choice
	"Answer the value of choice"

	^ choice! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
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: 'actions' stamp: ''!
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: 'accessing' stamp: ''!
labels: anObject
	"Set the value of labels"

	labels := anObject! !

!PopupChoiceDialogWindow methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	updatingFilter := false.
	self
		labels: #();
		lines: #();
		filter: ''! !

!PopupChoiceDialogWindow methodsFor: 'actions' stamp: ''!
selectFirstEnabledItem
	"Select the first enabled item in any of the embedded menus"

	|found|
	found := false.
	(self choiceMenus ifNil: [^self]) do: [:embeddedMenu |
		embeddedMenu selectItem: nil event: nil]. "clear selection in other menus"
	self choiceMenus do: [:embeddedMenu | 
		(embeddedMenu selectMatch: self filter)
			ifNotNil: [:menuItem |
				found ifFalse: [
					embeddedMenu selectItem: menuItem event: nil.
					self activeHand newKeyboardFocus: embeddedMenu.
					found := true]]]! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
choicesMorph
	"Answer the value of choicesMorph"

	^ choicesMorph! !

!PopupChoiceDialogWindow methodsFor: 'actions' stamp: ''!
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: 'actions' stamp: ''!
choose: index
	"Set the given choice and ok."

	self choice: (self model
		ifNil: [index]
		ifNotNil: [self model at: index]).
	self ok! !

!PopupChoiceDialogWindow methodsFor: 'actions' stamp: ''!
newMenuWith: morphs
	"Answer menu with the given morphs."

	^(self newEmbeddedMenu addAllMorphs: morphs)
		borderWidth: 0;
		removeDropShadow;
		color: Color transparent;
		hResizing: #spaceFill;
		cornerStyle: #square;
		stayUp: true;
		beSticky;
		popUpOwner: (MenuItemMorph new privateOwner: self)! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
scrollPane
	"Answer the scroll pane."

	^self findDeeplyA: GeneralScrollPaneMorph! !

!PopupChoiceDialogWindow methodsFor: 'event handling' stamp: ''!
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."
	
	^ true! !

!PopupChoiceDialogWindow methodsFor: 'event handling' stamp: ''!
keyStroke: anEvent
	"Look for a matching item?"
	(super keyStroke: anEvent) ifTrue: [^true].
	anEvent keyCharacter = Character space 
		ifTrue: [ ^self processEnter: anEvent ].
	self filter: self filter, anEvent keyCharacter asString.
	^true! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
rootMenu
	"Answer the root menu. Answer self."

	^self! !

!PopupChoiceDialogWindow methodsFor: 'actions' stamp: ''!
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 crAction: (MessageSend receiver: self selector: #ok).
	^entry! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
lines
	"Answer the value of lines"

	^ lines! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
labels
	"Answer the value of labels"

	^ labels! !

!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: ''!
choicesMorph: anObject
	"Set the value of choicesMorph"

	choicesMorph := anObject! !

!PopupChoiceDialogWindow class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallQuestionIcon! !

!PopupChoiceDialogWindow class methodsFor: 'instance creation' stamp: ''!
chooseFrom: aList lines: lines title: title
	"self chooseFrom: #('yes' 'no') lines: #(1 2)  title: 'Foo is the question'"
	"self chooseFrom: #('yes' 'no') lines: #()  title: 'Foo is the question'"
	| pd |
	pd := (self newWithTheme: self currentWorld theme)
		title: (title isEmpty ifTrue: ['Choose' translated] ifFalse: [title asString]);
		labels: aList;
		lines: (lines ifNil: [#()]);
		model: aList.
	"World may be not the best choice because a window may want to be in controlaList 
	this point should be investigated based on UIManager default modalMorph"
	^pd openModal choice! !

!PopupChoiceDialogWindowWithMessage commentStamp: ''!
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: 'actions' stamp: ''!
newContentMorph
	| top bottom |
	self textMorph: self newTextMorph.
	self text: self message.
	self iconMorph: self newIconMorph.
	top := self newRow: {self iconMorph. self textMorph}.
	bottom := super newContentMorph.
	^ self newGroupboxFor: (self newColumn: {top. bottom}).! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: ''!
message: aStringOrText
	
	message := aStringOrText! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'api' stamp: ''!
initialExtent
	"Answer the initial extent for the receiver.
	Adjust the text if the text	would be wider than 1/2 the display width."
	
	|ext|
	ext := super initialExtent.
	self textMorph width > (Display width // 2) ifTrue: [
		self textMorph
			wrapFlag: true;
			hResizing: #rigid;
			extent: Display width // 2 @ 0.
		ext := super initialExtent].
	^ext! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: ''!
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: 'actions' stamp: ''!
newTextMorph
	"Answer a text morph."
	
	^self newText: ''! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: ''!
textFont
	"Answer the text font."
	
	^textFont! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: ''!
iconMorph
	"Answer the value of iconMorph"

	^ iconMorph! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: ''!
icon
	"Answer an icon for the receiver."

	^ self iconNamed: #questionIcon! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: ''!
textFont: aFont
	"Set the text font."
	
	textFont :=  aFont! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: ''!
textMorph: anObject
	"Set the value of textMorph"

	textMorph := anObject! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: ''!
iconMorph: anObject
	"Set the value of iconMorph"

	iconMorph := anObject! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: ''!
message
	
	^ message! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'actions' stamp: ''!
newIconMorph
	"Answer an icon for the receiver."
	
	^ImageMorph new form: self icon! !

!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: ''!
textMorph
	"Answer the value of textMorph"

	^ textMorph! !

!PopupChoiceOrRequestDialogWindow methodsFor: 'accessing' stamp: ''!
filterValue

	^filter isEmpty
		ifTrue: [ nil ]
		ifFalse: [ filter ]! !

!PopupChoiceOrRequestDialogWindow methodsFor: 'event handling' stamp: ''!
processEnter: anEvent
	(super processEnter: anEvent)
		ifFalse: [ self okButton performAction ].
		
	^true! !

!PopupChoiceOrRequestDialogWindow methodsFor: 'accessing' stamp: ''!
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: ''!
okButton
	^okButton! !

!PopupChoiceOrRequestDialogWindow methodsFor: 'initialization' stamp: ''!
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: ''!
okButton: aMorph
	okButton := aMorph! !

!PopupChoiceOrRequestDialogWindow methodsFor: 'accessing' stamp: ''!
extent: aPoint
	"Make the choices area at least fill the scroll area."
	^super extent: (aPoint x max: self class minWidth)@(aPoint y).! !

!PopupChoiceOrRequestDialogWindow class methodsFor: 'accessing' stamp: ''!
minWidth
	^250! !

!PositionableStream commentStamp: ''!
I represent an accessor for a sequence of objects (a collection) that are externally named by indices so that the point of access can be repositioned. I am abstract in that I do not implement the messages next and nextPut: which are inherited from my superclass Stream.!
!PositionableStream methodsFor: 'accessing' stamp: ''!
contentsOfEntireFile
	"For non-file streams"
	^ self contents! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
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: 'positioning' stamp: ''!
skipSeparators
	[self atEnd]
		whileFalse:
		[self next isSeparator ifFalse: [^ self position: self position-1]]! !

!PositionableStream methodsFor: 'accessing - data' stamp: ''!
int16: anInteger
	"Store the given signed, 16-bit integer on this (binary) stream."

	| n |
	(anInteger < -16r8000 or: [ anInteger >= 16r8000 ])
		ifTrue: [ self error: 'outside 16-bit integer range' ].
	n := anInteger < 0
		ifTrue: [ 16r10000 + anInteger ]
		ifFalse: [ anInteger ].
	self nextPut: (n byteAt: 2).
	self nextPut: (n byteAt: 1)! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
back
	"Go back one element and return it."

	self position = 0 ifTrue: [self positionError].
	self skip: -1.
	^ self peek! !

!PositionableStream methodsFor: 'accessing - nonhomogeneous' stamp: ''!
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: 'accessing' stamp: ''!
peek
	"Answer what would be returned if the message next were sent to the 
	receiver. If the receiver is at the end, answer nil."

	| nextObject |
	self atEnd ifTrue: [^nil].
	nextObject := self next.
	position := position - 1.
	^nextObject! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
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: 'positioning' stamp: ''!
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 between: 0 and: readLimit)
		ifTrue: [ position := anInteger ]
		ifFalse: [ self positionError ]! !

!PositionableStream methodsFor: 'accessing - data' stamp: ''!
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: 'positioning' stamp: ''!
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: ''!
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: 'accessing' stamp: ''!
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: ''!
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 upToPosition: endMatch - aCollection size.
			self position: endMatch.
			result ]
		ifFalse: [ self position: startPos.
			self upToEnd ]! !

!PositionableStream methodsFor: 'accessing - nonhomogeneous' stamp: ''!
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 byteAt: n+1-i)].
	^ v! !

!PositionableStream methodsFor: 'accessing - nonhomogeneous' stamp: ''!
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 byteAt: 4)+192.
			self nextPut: (length byteAt: 3).
			self nextPut: (length byteAt: 2).
			self nextPut: (length byteAt: 1)].
	self nextPutAll: s asByteArray.
	^s! !

!PositionableStream methodsFor: 'accessing - data' stamp: ''!
uint24: anInteger
	"Store the given unsigned, 24-bit integer on this (binary) stream."

	(anInteger < 0 or: [ anInteger >= 16r1000000 ])
		ifTrue: [self error: 'outside unsigned 24-bit integer range'].

	self nextPut: (anInteger byteAt: 3).
	self nextPut: (anInteger byteAt: 2).
	self nextPut: (anInteger byteAt: 1).! !

!PositionableStream methodsFor: '*System-Changes' stamp: 'nil'!
decodeString: string andRuns: runsRaw
	| strm runLength runValues newString index |
	strm := ReadStream on: runsRaw from: 1 to: runsRaw size.
	(strm peekFor: $()
		ifFalse: [ ^ nil ].
	runLength := OrderedCollection new.
	[ 
	strm skipSeparators.
	strm peekFor: $) ] whileFalse: [ runLength add: (Number readFrom: strm) ].
	runValues := OrderedCollection new.
	[ strm atEnd ]
		whileFalse: [ 
			runValues add: (Number readFrom: strm).
			strm next ].
	newString := WideString new: string size.
	index := 1.
	runLength
		with: runValues
		do: [ :length :leadingChar | 
			index to: index + length - 1 do: [ :pos | newString at: pos put: (Character leadingChar: leadingChar code: (string at: pos) charCode) ].
			index := index + length ].
	^ newString! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
contents
	"Answer with a copy of my collection from 1 to readLimit."

	^collection copyFrom: 1 to: readLimit! !

!PositionableStream methodsFor: 'testing' stamp: ''!
atEnd
	"Primitive. Answer whether the receiver can access any more objects.
	Optional. See Object documentation whatIsAPrimitive."

	^position >= readLimit! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
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: 'initialization' stamp: ''!
on: aCollection from: firstIndex to: lastIndex
	self on: (aCollection copyFrom: firstIndex to: lastIndex)! !

!PositionableStream methodsFor: 'positioning' stamp: ''!
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: 'accessing' stamp: ''!
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: ''!
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 - data' stamp: ''!
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: 'positioning' stamp: ''!
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: 'private' stamp: ''!
positionError
	"Since I am not necessarily writable, it is up to my subclasses to override 
	position: if expanding the collection is preferrable to giving this error."

	self error: 'Attempt to set the position of a PositionableStream out of bounds'! !

!PositionableStream methodsFor: 'accessing - data' stamp: ''!
uint32: anInteger
	"Store the given unsigned, 32-bit integer on this (binary) stream."

	(anInteger < 0 or: [ anInteger >= 16r100000000 ])
		ifTrue: [self error: 'outside unsigned 32-bit integer range'].

	self nextPut: (anInteger byteAt: 4).
	self nextPut: (anInteger byteAt: 3).
	self nextPut: (anInteger byteAt: 2).
	self nextPut: (anInteger byteAt: 1).! !

!PositionableStream methodsFor: '*Graphics-Primitives' stamp: ''!
nextWordsInto: aBitmap 
	"Fill the word based buffer from my collection. 
	Stored on stream as Big Endian. Optimized for speed. 
	Read in BigEndian, then restoreEndianness."
	| blt pos source byteSize |
	collection class isBytes
		ifFalse: [^ self next: aBitmap size into: aBitmap startingAt: 1].

	byteSize := aBitmap byteSize.
	"is the test on collection basicSize \\ 4 necessary?"
	((self position bitAnd: 3) = 0 and: [ (collection basicSize bitAnd: 3) = 0])
		ifTrue: [source := collection.
			pos := self position.
			self skip: byteSize]
		ifFalse: ["forced to copy it into a buffer"
			source := self next: byteSize.
			pos := 0].

	"Now use BitBlt to copy the bytes to the bitmap."
	blt := (BitBlt
				toForm: (Form new hackBits: aBitmap))
				sourceForm: (Form new hackBits: source).
	blt combinationRule: Form over. "store"
	blt sourceX: 0;
		 sourceY: pos // 4;
		 height: byteSize // 4;
		 width: 4.
	blt destX: 0;
		 destY: 0.
	blt copyBits.

	"And do whatever the bitmap needs to do to convert from big-endian order."
	aBitmap restoreEndianness.

	^ aBitmap 	"May be WordArray, ColorArray, etc"! !

!PositionableStream methodsFor: 'accessing - data' stamp: ''!
boolean
	"Answer the next boolean value from this (binary) stream."

	^ self next ~= 0! !

!PositionableStream methodsFor: 'accessing - data' stamp: ''!
boolean: aBoolean
	"Store the given boolean value on this (binary) stream."

	self nextPut: (aBoolean ifTrue: [1] ifFalse: [0]).! !

!PositionableStream methodsFor: '*System-Changes' stamp: 'nil'!
verbatim: aString
	"Do not attempt to translate the characters.  Use to override nextPutAll:"
	^ self nextPutAll: aString! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
peekFor: anObject 
	"Answer false and do not move over the next element if it is not equal to 
	the argument, anObject, or if the receiver is at the end. Answer true 
	and increment the position for accessing elements, if the next element is 
	equal to anObject."

	| nextObject |
	self atEnd ifTrue: [^false].
	nextObject := self next.
	"peek for matching element"
	anObject = nextObject ifTrue: [^true].
	"gobble it if found"
	position := position - 1.
	^false! !

!PositionableStream methodsFor: 'accessing - nonhomogeneous' stamp: ''!
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 byteAt: 5-i)].
	^ int32! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
upTo: anObject 
	"Answer a subcollection from the current access position to the 
	occurrence (if any, but not inclusive) of anObject in the receiver. If 
	anObject is not in the collection, answer the entire rest of the receiver."
	| newStream element |
	newStream := (collection species new: 100) writeStream.
	[self atEnd or: [(element := self next) = anObject]]
		whileFalse: [newStream nextPut: element].
	^newStream contents! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
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: '*Fuel-Core' stamp: ''!
fuelNextWordsInto: aWordObject 
	"This method is the same as nextWordsInto: but the restoreEndianness is only done if needed"
	| blt pos source byteSize |

	byteSize := aWordObject byteSize.
	"is the test on collection basicSize \\ 4 necessary?"
	
	((self position bitAnd: 3) = 0 and: [ (collection basicSize bitAnd: 3) = 0])
		ifTrue: [source := collection.
			pos := self position.
			self skip: byteSize]
		ifFalse: ["forced to copy it into a buffer"
			source := self next: byteSize.
			pos := 0].

	"Now use BitBlt to copy the bytes to the bitmap."
	blt := (BitBlt
				toForm: (Form new hackBits: aWordObject))
				sourceForm: (Form new hackBits: source).
	blt combinationRule: Form over. "store"
	blt sourceX: 0;
		 sourceY: pos // 4;
		 height: byteSize // 4;
		 width: 4.
	blt destX: 0;
		 destY: 0.
	blt copyBits.

	^ aWordObject 	
! !

!PositionableStream methodsFor: 'accessing - data' stamp: ''!
int32: anInteger
	"Store the given signed, 32-bit integer on this (binary) stream."

	| n |
	(anInteger < -16r80000000 or: [ anInteger >= 16r80000000 ])
		ifTrue: [ self error: 'outside 32-bit integer range' ].
	n := anInteger < 0
		ifTrue: [ 16r100000000 + anInteger ]
		ifFalse: [ anInteger ].
	self nextPut: (n byteAt: 4).
	self nextPut: (n byteAt: 3).
	self nextPut: (n byteAt: 2).
	self nextPut: (n byteAt: 1)! !

!PositionableStream methodsFor: 'positioning' stamp: ''!
setToStart
	"Set the position of the receiver to the start of the sequence of objects."

	self reset! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
originalContents
	"Answer the receiver's actual contents collection, NOT a copy."

	^ collection! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
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: 'positioning' stamp: ''!
position
	"Answer the current position of accessing the sequence of objects."

	^position! !

!PositionableStream methodsFor: 'accessing - data' stamp: ''!
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: 'accessing' stamp: ''!
upToPosition: anInteger
	"Answer a subcollection containing items starting from the current position and ending including the given position. Usefully different to #next: in that in the case of MultiByteFileStream, and perhaps others, positions measure in terms of encoded items, while #next: convention is to name a number of items, independent of their encoding in the underlying buffer."
	^ self next: anInteger - position! !

!PositionableStream methodsFor: '*Compression' stamp: 'nil'!
asZLibReadStream
	^ZLibReadStream on: collection from: position+1 to: readLimit! !

!PositionableStream methodsFor: '*System-Changes' stamp: 'nil'!
header
	"If the stream requires a standard header, override this message.  See HtmlFileStream"! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
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: ''!
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 occurrence 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: ''!
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: '*System-Changes' stamp: 'nil'!
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) isNil ]
		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: 'nil'!
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: 'accessing' stamp: ''!
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: 'testing' stamp: ''!
isBinary
	"Return true if the receiver is a binary byte stream"
	^collection class == ByteArray! !

!PositionableStream methodsFor: 'accessing - data' stamp: ''!
string
	"Answer the next string from this (binary) stream."

	| size |
	size := self uint16.
	^ (self next: size) asString! !

!PositionableStream methodsFor: 'positioning' stamp: ''!
padToNextLongPut: char 
	"Make position be on long word boundary, writing the padding 
	character, char, if necessary."
	[self position \\ 4 = 0]
		whileFalse: [self nextPut: char]! !

!PositionableStream methodsFor: 'accessing - data' stamp: ''!
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: 'accessing - data' stamp: ''!
uint16: anInteger
	"Store the given unsigned, 16-bit integer on this (binary) stream."

	(anInteger < 0 or: [ anInteger >= 16r10000 ])
		ifTrue: [self error: 'outside unsigned 16-bit integer range'].

	self nextPut: (anInteger byteAt: 2).
	self nextPut: (anInteger byteAt: 1).! !

!PositionableStream methodsFor: '*System-Changes' stamp: 'nil'!
nextPreamble
	"Assuming that preamble part does not contain ]lang[ tag"
	| terminator out ch |
	terminator := $!!.
	out := (String new: 1000) writeStream.
	self skipSeparators.
	[ (ch := self next) isNil ]
		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 - data' stamp: ''!
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: 'private' stamp: ''!
setFrom: newStart to: newStop

	position := newStart - 1.
	readLimit := newStop! !

!PositionableStream methodsFor: '*System-Changes' stamp: 'nil'!
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) isNil ]
		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 - nonhomogeneous' stamp: ''!
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: 'initialization' stamp: ''!
reset
	"Set the receiver's position to the beginning of the sequence of objects."

	position := 0! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
next: anInteger putAll: aCollection
	"Store the next anInteger elements from the given collection."
	^self next: anInteger putAll: aCollection startingAt: 1! !

!PositionableStream methodsFor: 'positioning' stamp: ''!
skipTo: anObject 
	"Set the access position of the receiver to be past the next occurrence of 
	anObject. Answer whether anObject is found."

	[self atEnd]
		whileFalse: [self next = anObject ifTrue: [^true]].
	^false! !

!PositionableStream methodsFor: 'positioning' stamp: ''!
pushBack: aString
	"Compatibility with SocketStreams"
	self skip: aString size negated! !

!PositionableStream methodsFor: 'accessing - nonhomogeneous' stamp: ''!
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: 'accessing - data' stamp: ''!
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: 'positioning' stamp: ''!
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: 'accessing - nonhomogeneous' stamp: ''!
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 byteAt: i)].
	self nextPutAll: bytes! !

!PositionableStream methodsFor: 'accessing - nonhomogeneous' stamp: ''!
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: ''!
resetContents
	"Set the position and limits to 0."

	position := 0.
	readLimit := 0! !

!PositionableStream methodsFor: 'initialization' stamp: ''!
on: aCollection

	collection := aCollection.
	readLimit := aCollection size.
	position := 0.
	self reset! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
upToAnyOf: aCollection 
	"Answer a subcollection from the current access position to the 
	occurrence (if any, but not inclusive) of any object in the collection. If 
	no matching object is found, answer the entire rest of the receiver."
	^self upToAnyOf: aCollection do: [:matchingObject | ]! !

!PositionableStream methodsFor: 'private' stamp: ''!
collectionSpecies
	"Answer the species of collection into which the receiver can stream"
	
	^collection species! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
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 - nonhomogeneous' stamp: ''!
nextString
	"Read a string from the receiver. The first byte is the length of the string, unless it is greater than 192, in which case the first four bytes encode the length.  I expect to be in ascii mode when called (caller puts back to binary)."

	| length aByteArray |

	"read the length in binary mode"
	self binary.
	length := self next.		"first byte."
	length >= 192 ifTrue: [length := length - 192.
		1 to: 3 do: [:ii | length := length * 256 + self next]].
	aByteArray := ByteArray new: length.

	self nextInto: aByteArray.
	^aByteArray asString.! !

!PositionableStream methodsFor: 'positioning' stamp: ''!
untilEnd: aBlock displayingProgress: aString
	aString
		displayProgressFrom: 0 to: self size
		during:
			[:bar |
			[self atEnd] whileFalse:
				[bar current: self position.
				aBlock value]].! !

!PositionableStream methodsFor: 'accessing - nonhomogeneous' stamp: ''!
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: '*System-Changes' stamp: 'nil'!
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: 'positioning' stamp: ''!
skip: anInteger 
	"Set the receiver's position to be the current position+anInteger. A 
	subclass might choose to be more helpful and select the minimum of the 
	receiver's size and position+anInteger, or the maximum of 1 and 
	position+anInteger for the repositioning."

	self position: position + anInteger! !

!PositionableStream methodsFor: '*Text-Core' stamp: ''!
nextChunkText
	"Deliver the next chunk as a Text.  Decode the following ]style[ chunk if present.  Position at start of next real chunk."
	| string runsRaw strm runs peek pos |
	"Read the plain text"
	string := self nextChunk.
	
	"Test for ]style[ tag"
	pos := self position.
	peek := self skipSeparatorsAndPeekNext.
	peek = $] ifFalse: [self position: pos. ^ string asText].  "no tag"
	(self upTo: $[) = ']style' ifFalse: [self position: pos. ^ string asText].  "different tag"

	"Read and decode the style chunk"
	runsRaw := self basicNextChunk.	"style encoding"
	strm := ReadStream on: runsRaw from: 1 to: runsRaw size.
	runs := RunArray scanFrom: strm.

	^ Text basicNew setString: string setRunsChecking: runs.
! !

!PositionableStream methodsFor: 'positioning' stamp: ''!
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 |
	pattern := subCollection readStream.
	[ self atEnd or: [pattern atEnd] ] whileFalse: 
		[self skip: pattern position negated.
		pattern setToStart. 
		(self skipTo: pattern next) ifFalse: [ ^false ].
		[pattern atEnd not and: [self next = pattern peek]] whileTrue: [pattern next]
	].
	^ pattern atEnd! !

!PositionableStream methodsFor: 'accessing - nonhomogeneous' stamp: ''!
nextNumber: n 
	"Answer the next n bytes as a positive Integer or LargePositiveInteger."
	| s |
	s := 0.
	1 to: n do: 
		[:i | s := (s bitShift: 8) bitOr: self next asInteger].
	^ s normalize! !

!PositionableStream methodsFor: 'accessing' stamp: ''!
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: ''!
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: 'positioning' stamp: ''!
setToEnd
	"Set the position of the receiver to the end of the sequence of objects."

	position := readLimit! !

!PositionableStream class methodsFor: 'instance creation' stamp: ''!
on: aCollection 
	"Answer an instance of me, streaming over the elements of aCollection."

	^self basicNew on: aCollection! !

!PositionableStream class methodsFor: 'enumerating' stamp: ''!
with: aCollectionOrStream do: aBlock
	"Evaluates a block with a new stream based on the collection or stream. Answers the result of the block evaluation. Follows the style of FileStream>>fileNamed:do:."
	| aStream |
	aStream := self on: aCollectionOrStream.
	[ ^ aBlock value: aStream ] ensure: [ aStream close ]! !

!PositionableStream class methodsFor: 'instance creation' stamp: ''!
on: aCollection from: firstIndex to: lastIndex 
	"Answer an instance of me on a copy of the argument, aCollection, 
	determined by the indices firstIndex and lastIndex. Position the instance 
	at the beginning of the collection."

	^self basicNew
		on: aCollection
		from: firstIndex
		to: lastIndex! !

!PostorderGuide commentStamp: ''!
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: ''!
pushVisit: aReference 
	self push: (Message 
				selector: #visit:
				argument: aReference)! !

!PostorderGuide methodsFor: 'showing' stamp: ''!
pushTraverse: aReference 
	self push: (Message 
				selector: #traverse:
				argument: aReference)! !

!PostorderGuide methodsFor: 'showing' stamp: ''!
show: aReference 
	self pushTraverse: aReference entry.
	self whileNotDoneDo: [ self pop sendTo: self ]! !

!PostorderGuide methodsFor: 'showing' stamp: ''!
traverse: anEntry 
		
	self pushVisit: anEntry.
	
	anEntry isDirectory ifTrue: [ 
		(self shouldVisitChildrenOf: anEntry)
			ifFalse: [ ^ self ].
		anEntry reference entries reverseDo: [ :each | 
			self pushTraverse: each ]]! !

!PostorderGuide methodsFor: 'showing' stamp: ''!
visit: anEntry
	anEntry isDirectory
		ifTrue: [ visitor visitDirectory: anEntry ]
		ifFalse: [ visitor visitFile: anEntry ]! !

!PostorderGuideTest commentStamp: ''!
SUnit tests for class PostorderGuide!
!PostorderGuideTest methodsFor: 'tests' stamp: ''!
testAll
	guide := PostorderGuide for: self.
	guide show: (filesystem / 'alpha').
	self assertVisitedIs: #(
			'delta'
			'gamma'
			'beta'
			'zeta'
			'epsilon'
			'alpha'
		)! !

!PotentialOutDatedDependencyWarning commentStamp: ''!
Warning signaled when a dependency manually declared has no match in potential dependencies.!
!PotentialOutDatedDependencyWarning methodsFor: 'accessing' stamp: ''!
messageText
	^ messageText 
		ifNil: [ package , ': ' , dependency , ' dependency declared in the package Manifest as manuallyResolvedDependencies not detected as a dependency!!' ]! !

!PotentialOutDatedDependencyWarning methodsFor: 'comparing' stamp: ''!
= anObject
	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].
	^ (package == anObject package) and: [ dependency == anObject dependency ]! !

!PotentialOutDatedDependencyWarning methodsFor: 'comparing' stamp: ''!
hash
	^ package hash bitXor: dependency hash! !

!PotentialOutDatedDependencyWarning methodsFor: 'accessing' stamp: ''!
dependency
	^ dependency! !

!PotentialOutDatedDependencyWarning methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!PotentialOutDatedDependencyWarning methodsFor: 'initialization' stamp: ''!
initializeWithDependency: aDependencyName on: aPackageName 
	dependency := aDependencyName.
	package := aPackageName! !

!PotentialOutDatedDependencyWarning class methodsFor: 'signaling' stamp: ''!
signalDependency: dependencyName on: aPackageName
	^ self basicNew 
		initializeWithDependency: dependencyName on: aPackageName;
		signal;
		yourself! !

!Pragma commentStamp: ''!
I represent an occurrence of a pragma in a compiled method.  A pragma is a literal message pattern that occurs between angle brackets at the start of a method after any temporaries.  A common example is the primitive pragma:
	<primitive: 123 errorCode: 'errorCode'>
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: ''!
methodClass
	"Answer the class of the method containing the pragma."
	
	^ method methodClass! !

!Pragma methodsFor: 'comparing' stamp: ''!
= aPragma

	self == aPragma ifTrue: [^true].
	self species == aPragma species ifFalse: [^false].

	self method = aPragma method ifFalse: [^false].
	self method selector = aPragma method selector ifFalse: [ ^false ].
	self selector = aPragma selector ifFalse: [^false].
	self arguments = aPragma arguments ifFalse: [^false].

	^true.! !

!Pragma methodsFor: 'comparing' stamp: ''!
hash

	| hash |

	hash := self method hash bitXor: self selector hash.
	1 to: self basicSize do: [:index | hash := hash bitXor: (self basicAt: index) hash].

	^hash.! !

!Pragma methodsFor: 'accessing - pragma' stamp: ''!
numArgs
	"Answer the number of arguments in the pragma."

	^ self arguments size.! !

!Pragma methodsFor: 'initialization' stamp: ''!
arguments: anArray
	arguments := anArray! !

!Pragma methodsFor: 'view' stamp: ''!
methodSelector
	"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: 'printing' stamp: ''!
displayStringOn: stream
	self method displayStringOn: stream.
	stream space.
	self printOn: stream! !

!Pragma methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPut: $<.
	self selector precedence = 1
		ifTrue: [ aStream nextPutAll: self selector ]
		ifFalse: [
			self selector keywords with: self arguments do: [ :key :arg |
				aStream nextPutAll: key; space; print: arg; space ].
			aStream skip: -1 ].
	aStream nextPut: $>.! !

!Pragma methodsFor: 'comparing' stamp: ''!
analogousCodeTo: anObject 
	^self class == anObject class
	  and: [self selector == anObject selector
	  and: [arguments = anObject arguments]]! !

!Pragma methodsFor: 'accessing - pragma' stamp: ''!
argumentNamed: aSymbol ifNone: aBlockClosure
	"Answer the argument of the pragma after the keyword given as parameter.
	If none, return the result of the block given as parameter.
	
	I am more readable than #argumentAt: but also slower."

	^ self argumentAt:
		(self selector keywords
			indexOf: aSymbol asMutator
			ifAbsent: [ ^ aBlockClosure value])! !

!Pragma methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForBytecodesFor: aStep
	<stSpotterOrder: 15>
	self method spotterForBytecodesFor: aStep! !

!Pragma methodsFor: 'sending' stamp: ''!
sendTo: anObject
	"Send the pragma keyword together with its arguments to anObject and answer the result."
	
	^ anObject perform: self selector withArguments: self arguments! !

!Pragma methodsFor: 'testing' stamp: ''!
refersToLiteral: aLiteral
	^self selector == aLiteral 
	   or: [arguments hasLiteral: aLiteral]! !

!Pragma methodsFor: 'accessing - method' stamp: ''!
method
	"Answer the compiled-method containing the pragma."
	
	^ method! !

!Pragma methodsFor: 'processing' stamp: ''!
withArgumentsDo: aBlock
	"Pass the arguments of the receiving pragma into aBlock and answer the result."
	
	^ aBlock valueWithArguments: self arguments! !

!Pragma methodsFor: 'accessing' stamp: ''!
selector
	"Answer the selector of the pragma.
	 For a pragma defined as <key1: val1 key2: val2> this will answer #key1:key2:."
	
	^ selector! !

!Pragma methodsFor: 'accessing - pragma' stamp: ''!
arguments
	"Answer the arguments of the receiving pragma. For a pragma defined as <key1: val1 key2: val2> this will answer #(val1 val2)."
	
	^ arguments! !

!Pragma methodsFor: 'querying' stamp: ''!
key
	"Answer the keyword of the pragma (the selector of its message pattern).
	 This accessor provides polymorphism with Associations used for properties."
	^self selector! !

!Pragma methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
stActDefault
    ^ self method browse! !

!Pragma methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionSourceCodeMethod
	<inspectorPresentationOrder: 30 title: 'Method'>

	^ SpCodePresenter new 
		beForMethod: self method;
		text: self method sourceCode;
		yourself! !

!Pragma methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForImplementorsFor: aStep
	<stSpotterOrder: 10>
	self method spotterForImplementorsFor: aStep! !

!Pragma methodsFor: 'initialization' stamp: ''!
selector: aSymbol
	selector := aSymbol! !

!Pragma methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForSendersFor: aStep
	<stSpotterOrder: 10>
	self method spotterForSendersFor: aStep! !

!Pragma methodsFor: 'accessing - pragma' stamp: ''!
argumentAt: anInteger
	"Answer one of the arguments of the pragma."
	
	^ self arguments at: anInteger.! !

!Pragma methodsFor: 'initialization' stamp: ''!
method: aCompiledMethod
	method := aCompiledMethod! !

!Pragma methodsFor: 'testing' stamp: ''!
hasLiteral: aLiteral
	^self selector == aLiteral 
	   or: [arguments hasLiteral: aLiteral]! !

!Pragma methodsFor: 'accessing' stamp: ''!
message
	"Answer the message of the receiving pragma."
	
	^ Message selector: self selector arguments: self arguments.! !

!Pragma methodsFor: 'accessing - pragma' stamp: ''!
argumentNamed: aSymbol
	"Answer the argument of the pragma after the keyword given as parameter.
	If none, raise an error."

	^ self argumentNamed: aSymbol ifNone: [ self error: 'No argument of this name.' ]! !

!Pragma class methodsFor: 'finding' stamp: ''!
allNamed: aSymbol in: aClass
	"Answer a collection of all pragmas found in methods of aClass whose selector is aSymbol."
	
	^ Array streamContents: [ :stream |
		 aClass pragmasDo: [ :pragma |
			pragma selector = aSymbol
				ifTrue: [ stream nextPut: pragma ] ] ]! !

!Pragma class methodsFor: 'finding' stamp: ''!
allNamed: aSymbol in: aClass sortedUsing: aSortBlock
	"Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to aSortBlock."
	
	^ (self allNamed: aSymbol in: aClass) sort: aSortBlock.! !

!Pragma class methodsFor: 'finding' stamp: ''!
allNamed: aSymbol

	"Answer a collection of all pragmas whose selector is aSymbol."

	| pragmas |
	pragmas := self pragmaCache at: aSymbol ifAbsent: [ ^ #(  ) ].
	"if there are none, we can remove the entry in the cache"
	pragmas ifEmpty: [ self pragmaCache removeKey: aSymbol ifAbsent: [  ] ].
	"we check if the pragma is really from an installed method 
	(others will be cleaned up by the gc when the method is garbadge collected)"
	^ (pragmas select: [ :each | each method isInstalled ]) asArray! !

!Pragma class methodsFor: 'instance creation' stamp: ''!
for: aMethod selector: aSelector arguments: anArray
	^self new
		method: aMethod;
		selector: aSelector;
		arguments: anArray;
		yourself! !

!Pragma class methodsFor: 'finding' stamp: ''!
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: ''!
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: 'cache' stamp: ''!
pragmaCache

	^ pragmaCache ifNil: [ pragmaCache := Dictionary new ]! !

!Pragma class methodsFor: 'cache' stamp: ''!
addToCache: aPragma
	"when a method is added to a class, the Pragma is added to the cache"
	self pragmaCache
		at: aPragma selector
		ifAbsentPut: [ WeakIdentitySet new ].
	(self pragmaCache at: aPragma selector) add: aPragma! !

!Pragma class methodsFor: 'cache' stamp: ''!
all
	"all pragmas whose methods are currently installed in the system"
	^ self pragmaCache values flattened select: [ :each | 
		  each method isInstalled ]! !

!Pragma class methodsFor: 'finding' stamp: ''!
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: ''!
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 | 
					class pragmasDo: [ :pragma | 
							pragma selector = aSymbol
								ifTrue: [ stream nextPut: pragma ] ].
					aSuperClass = class
						ifTrue: [ ^ stream contents ] ] ]! !

!Pragma class methodsFor: 'private' stamp: ''!
selector: aSymbol arguments: anArray
	^ self new
		selector: aSymbol;
		arguments: anArray;
		yourself! !

!PragmaAdded commentStamp: ''!
A PragmaAdded is announced by a PragamColllector when a method defined with an acceptable pragma according to the PragmaCollector filter is added.

Instance Variables
!
!PragmaAnnouncement commentStamp: ''!
A PragmaAnnouncement is announced by a PragmaCollector when it adds, removes or updates a PragmaHandler.

Instance Variables
	pragma:		<Pragma>

pragma
	- the pragma which has been added, removed or updated
!
!PragmaAnnouncement methodsFor: 'accessing' stamp: ''!
pragma: aPragma
	pragma := aPragma! !

!PragmaAnnouncement methodsFor: 'accessing' stamp: ''!
pragma
	^ pragma! !

!PragmaAnnouncement class methodsFor: 'instance creation' stamp: ''!
pragma: aPragma
	^ self new pragma: aPragma! !

!PragmaCollector commentStamp: ''!
Note: In most cases it is better to use the class side methods of Pragma instead.

PragmaCollector is useful if a client needs to be notified if pragmas are added or removed.
If you do not store the PragmaCollector instance, you most likely can just use the API of Pragma directly.

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. 

The filter is applied to all Pragmas or (faster) pragmas with the selectors defined by #selectors:.

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:' selector (<primitive:>)
---------------------------
(PragmaCollector filter: [:prg | prg selector = 'primitive:']) reset.
---------------------------

In this case it is faster to specify selectors via #selector, as this avoids to iterate over all Pragmas of the system:

---------------------------
(PragmaCollector selectors: #(primitive:)) reset
---------------------------

We can specify both the selectors and an additional filter, e.g. filter for all Pragmas named primitive: in methods that have one Argument:
 
---------------------------
(PragmaCollector 
	selectors: #(primitive:) 
	filter: [:prg | prg methodSelector numArgs = 1] ) reset
---------------------------

Instance Variables	
	announcer:		<Announcer>	
	collected:		<Collection>
	filter:			<Block or MessageSend>
	selector:      <Array of symbols>
				
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: 'testing' stamp: ''!
isEmpty
	^ self collected isEmpty! !

!PragmaCollector methodsFor: 'updating' stamp: ''!
keepPragma: aPragma
	(selectors notNil and: [(selectors includes: aPragma selector) not ]) ifTrue: [ ^ false ].
	^ self filter value: aPragma! !

!PragmaCollector methodsFor: 'updating' stamp: ''!
updatePragma: aPragma
	"only announce that the pragma has been updated"
	self announcer announce: (PragmaUpdated pragma: aPragma)! !

!PragmaCollector methodsFor: 'testing' stamp: ''!
isNotEmpty
	^ self collected isNotEmpty! !

!PragmaCollector methodsFor: 'enumerating' stamp: ''!
select: aBlock
	^ self collected select: aBlock! !

!PragmaCollector methodsFor: 'system changes' stamp: ''!
removedEventOccurs: anEvent
	"a method has been removed, remove any corresponding handler if found"

	(self
		detect: [ :prag | 
			prag methodSelector = anEvent selector
				and: [ prag methodClass = anEvent methodClass ] ])
		ifNotNil: [ :found | self removePragma: found ]! !

!PragmaCollector methodsFor: 'accessing' stamp: ''!
filter: aOneArgValuable
	filter := aOneArgValuable! !

!PragmaCollector methodsFor: 'subscription' stamp: ''!
unsubscribe: anObject
	"see Announcements packages"
	self announcer unsubscribe: anObject! !

!PragmaCollector methodsFor: 'accessing' stamp: ''!
filter
	^ filter ifNil: [filter := [:prg | true]]! !

!PragmaCollector methodsFor: 'subscription' stamp: ''!
announce: anAnnouncement
	"see Announcements packages"

	self announcing ifTrue:	[ self announcer announce: anAnnouncement ]! !

!PragmaCollector methodsFor: 'accessing' stamp: ''!
collected
	^ collected ifNil: [collected := OrderedCollection new]! !

!PragmaCollector methodsFor: 'enumerating' stamp: ''!
do: aBlock
	self collected do: aBlock! !

!PragmaCollector methodsFor: 'accessing' stamp: ''!
announcing
	^ announcing ifNil: [ announcing := true ]! !

!PragmaCollector methodsFor: 'updating' stamp: ''!
addPragma: aPragma
	"if aPragma is to be kept, then add it and announce"
	(self keepPragma: aPragma) ifFalse: [ ^ self ].
	self collected add: aPragma.
	self announce: (PragmaAdded pragma: aPragma)! !

!PragmaCollector methodsFor: 'system changes' stamp: ''!
installSystemNotifications
	"Allows myself to be kept up-to-date regarding system changes"
	
	SystemAnnouncer uniqueInstance unsubscribe: self.
	
	SystemAnnouncer uniqueInstance weak
			when: ClassRemoved send: #classRemovedEventOccurs: to: self;
			when: MethodRemoved send: #removedEventOccurs: to: self;
			when: MethodAdded send: #addedEventOccurs: to: self;
			when: MethodModified send: #modifiedEventOccurs: to: self! !

!PragmaCollector methodsFor: 'enumerating' stamp: ''!
collect: aBlock
	^ self collected collect: aBlock! !

!PragmaCollector methodsFor: 'enumerating' stamp: ''!
reject: aBlock
	^ self collected reject: aBlock! !

!PragmaCollector methodsFor: 'initialization' stamp: ''!
reset
	"reinitialize current system settings"
	self
		noMoreAnnounceWhile: [self collected copy
				do: [:pragma | self removePragma: pragma].
			self pragmas
				do: [:pragma | self addPragma: pragma]].
	self announce: (PragmaCollectorReset collector: self)! !

!PragmaCollector methodsFor: 'updating' stamp: ''!
removePragma: aPragma 
	"remove an handler an announce it"
	self collected remove: aPragma ifAbsent: [].
	self announce: (PragmaRemoved pragma: aPragma)! !

!PragmaCollector methodsFor: 'accessing' stamp: ''!
selectors
	^selectors! !

!PragmaCollector methodsFor: 'subscription' stamp: ''!
whenChangedSend: aSelector to: anObject
	"record a change listener"
	
	self when: PragmaAnnouncement send: aSelector to: anObject! !

!PragmaCollector methodsFor: 'accessing' stamp: ''!
selectors: anArray
	selectors := anArray! !

!PragmaCollector methodsFor: 'subscription' stamp: ''!
when: anAnnouncement send: aSelector to: anObject
	"see Announcements packages"

	self announcer when: anAnnouncement send: aSelector to: anObject! !

!PragmaCollector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self installSystemNotifications! !

!PragmaCollector methodsFor: 'querying' stamp: ''!
pragmasOfClass: aClass 
	"return all handlers of class aClass"
	^ self	select: [:prag | prag methodClass = aClass ]! !

!PragmaCollector methodsFor: 'system changes' stamp: ''!
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.
	"

	anEvent methodClass pragmasDo: [ :pragma | 
			pragma methodSelector = anEvent selector
				ifTrue: [ (self
						detect: [ :oldprag | 
							oldprag methodSelector = pragma methodSelector
								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: 'enumerating' stamp: ''!
noneSatisfy: aBlock
	^ self collected noneSatisfy: aBlock! !

!PragmaCollector methodsFor: 'system changes' stamp: ''!
addedEventOccurs: anEvent
	"method adding event occured: if the 
	concerned method contains a pragma then 
	try to update myself with it"
	
	anEvent method pragmas
		do: [ :pragma | self addPragma: pragma ]! !

!PragmaCollector methodsFor: 'querying' stamp: ''!
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 methodSelector = aSelector ] ]! !

!PragmaCollector methodsFor: 'system changes' stamp: ''!
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: 'subscription' stamp: ''!
whenResetSend: aSelector to: anObject
	"record a change listener"

	self when: PragmaCollectorReset send: aSelector to: anObject! !

!PragmaCollector methodsFor: 'dependents access' stamp: ''!
release
	self noMoreNotifications.
	self destroyAnnouncer.
	collected := nil.
	super release! !

!PragmaCollector methodsFor: 'system changes' stamp: ''!
noMoreNotifications
	"Do not receiver any system change notification anymore"
	SystemAnnouncer uniqueInstance unsubscribe: self.! !

!PragmaCollector methodsFor: 'system changes' stamp: ''!
noMoreAnnounceWhile: aBlock
	"unplug the announcer during aBlock"
	| oldAnnouncing |
	[oldAnnouncing := announcing. 
	announcing := false.
	aBlock value]
		ensure: [announcing := oldAnnouncing]! !

!PragmaCollector methodsFor: 'system changes' stamp: ''!
noMoreNotificationsWhile: aBlock
	"don not receive any system change notification during aBloc"
	self noMoreNotifications.
	[ aBlock value ] ensure: [ self installSystemNotifications ]! !

!PragmaCollector methodsFor: 'testing' stamp: ''!
ifNotEmpty: aBlock
	self collected ifNotEmpty: aBlock! !

!PragmaCollector methodsFor: 'accessing' stamp: ''!
pragmas
	^ selectors 
		ifNil: [ Pragma all ]
		ifNotNil: [ selectors flatCollect: [:each | Pragma allNamed: each ] ]! !

!PragmaCollector methodsFor: 'enumerating' stamp: ''!
detect: aBlock
	^ self collected detect: aBlock ifNone:[]! !

!PragmaCollector class methodsFor: 'instance creation' stamp: ''!
selectors: anArray
	"Create a PragmaCollector that looks for Pragmas with the specified selectors"
	^ self new selectors: anArray! !

!PragmaCollector class methodsFor: 'instance creation' stamp: ''!
filter: aOneArgValuable
	"Create a PragmaCollector that filters all system pragmas"
	"Note: If you know whoch pragma selectors are interesting, better use selectors:filter: to create the instance, this avoids the need to iterate over all Pragmas"
	^ self new filter: aOneArgValuable! !

!PragmaCollector class methodsFor: 'instance creation' stamp: ''!
selectors: anArray filter: aBlock
	"Create a PragmaCollector that looks for Pragmas with the specified selectors, filter using aBlock"
	^ (self new selectors: anArray) filter: aBlock! !

!PragmaCollectorReset commentStamp: ''!
A PragmaCollectorReset is an announce which is announced by a PragamColllector when it is reset.
see PragmaCollector>>reset.

Instance Variables
	collector:		<PragmaCollector>

collector
	- the collector which is reset
!
!PragmaCollectorReset methodsFor: 'accessing' stamp: ''!
collector
	^collector! !

!PragmaCollectorReset methodsFor: 'accessing' stamp: ''!
collector: aCollector
	collector := aCollector! !

!PragmaCollectorReset class methodsFor: 'instance creation' stamp: ''!
collector: aCollector
	^ self new collector: aCollector! !

!PragmaMenuAndShortcutRegistration commentStamp: ''!
A PragmaMenuAndShortcutRegistration is the list items holder!
!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
platform: anArray
 
	anArray isEmpty
		ifTrue: [ platform := #all ]
		ifFalse: [ platform := anArray first ]! !

!PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: ''!
currentRoot: aMenuRegistration 

	currentRoot := aMenuRegistration! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
iconName: aSymbol
	"instead of forcing clients to refer to an icon builder such Smalltalk ui icons 
	this message encapsulates it inside the builder itself. When removing uses of Smalltalk ui icons it avoid to force to subclass class with menu to inherit from Model."
	
	self icon: (Smalltalk ui icons iconNamed: aSymbol)! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
arguments: anArray

	self currentItem arguments: anArray! !

!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
category: aByteSymbol
	
	self currentItem
		category: aByteSymbol! !

!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
category: aByteSymbol shortcut: aKMModifiedShortcut do: aBlockClosure 
	
	self currentItem
		category: aByteSymbol;
		default: aKMModifiedShortcut;
		action: aBlockClosure! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
parent: aSymbol 
	
	self currentItem parent: aSymbol! !

!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
category: aByteSymbol default: aKMModifiedShortcut do: aBlockClosure 
	
	self currentItem
		category: aByteSymbol;
		default: aKMModifiedShortcut;
		action: aBlockClosure! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
createNewItem
	
	items add: self itemClass new.
	
	self currentItem
		platform: platform;
		parent: currentRoot! !

!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
do: aBlockClosure
	
	self currentItem
		action: aBlockClosure! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
keyText: aString
	self currentItem keyText: aString! !

!PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
 
	self currentItem enabled: aBoolean! !

!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
default: aKMModifiedShortcut
	
	self currentItem
		default: aKMModifiedShortcut! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
icon: anIcon
	
	self currentItem icon: anIcon! !

!PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
target: aSymbol 

	self currentItem target: aSymbol! !

!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
category: aByteSymbol shortcut: aKMModifiedShortcut do: aBlockClosure description: aByteString 
	
	self currentItem
		category: aByteSymbol;
		default: aKMModifiedShortcut;
		action: aBlockClosure;
		help: aByteString! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
action: aBlock

	self currentItem action: aBlock! !

!PragmaMenuAndShortcutRegistration methodsFor: '*Keymapping-Pragmas' stamp: ''!
attachShortcutCategory: aSymbol to: aClass 

	KMRepository default attachCategoryName: aSymbol to: aClass.! !

!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
shortcut: aSymbol
	
	self createNewItem.
	self currentItem shortcut: aSymbol! !

!PragmaMenuAndShortcutRegistration methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	items := OrderedCollection new.! !

!PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: ''!
handOutItems
	"we don't want to hold a reference to the items after they are hand out to the registration"

	| itemsCopy |
	itemsCopy := items copy.
	items removeAll.
	^ itemsCopy! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
label: aString
	
	self currentItem label: aString! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
order: anInteger 
	
	self currentItem order: anInteger! !

!PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: ''!
currentRoot

	^ currentRoot! !

!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
description: aByteString 
	
	self currentItem
		help: aByteString! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
help: aString 
	
	self currentItem help: aString! !

!PragmaMenuAndShortcutRegistration methodsFor: 'private' stamp: ''!
itemClass

	^ PragmaMenuAndShortcutRegistrationItem! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
selector: aSelector 
	
	self currentItem selector: aSelector! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
withSeparatorAfter

	self currentItem withSeparatorAfter! !

!PragmaMenuAndShortcutRegistration methodsFor: '*Keymapping-Pragmas' stamp: ''!
setAsGlobalCategory: aGlobalCategory

	KMRepository default setAsGlobalCategory: aGlobalCategory! !

!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
keyText: aString if: aBoolean
	aBoolean ifFalse: [ ^ self ].
	self keyText: aString! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
currentItem

	^ items last! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
item: aSymbol 
	
	self createNewItem.
	self currentItem item: aSymbol! !

!PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: ''!
model: aModel

	model := aModel.! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
with: aBlock
	| old itemOrGroup |
	old := self currentRoot.
	itemOrGroup := self currentItem item ifNil: [ self currentItem group ].
	self currentRoot: itemOrGroup.
	[ aBlock value ]
		ensure: [ self currentRoot: old ]! !

!PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: ''!
items

	^ items! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
enabledBlock: aBlock

	self currentItem enabledBlock: aBlock! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
precondition: aBlock 
	
	self currentItem precondition: aBlock! !

!PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: ''!
category: aByteSymbol default: aKMModifiedShortcut do: aBlockClosure description: aByteString 
	
	self currentItem
		category: aByteSymbol;
		default: aKMModifiedShortcut;
		action: aBlockClosure;
		help: aByteString! !

!PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: ''!
group: aSymbol 
	
	self createNewItem.
	self currentItem group: aSymbol! !

!PragmaMenuAndShortcutRegistration class methodsFor: 'instance creation' stamp: ''!
model: aModel

	^ self new
		model: aModel;
		yourself! !

!PragmaMenuAndShortcutRegistrationItem commentStamp: ''!
A PragmaMenuAndShortcutRegistrationItem is an item of a menu or keymap!
!PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: ''!
shortcutName: aSymbol 
	
	shortcutName := aSymbol! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: ''!
platform: aSymbol 

	platform := aSymbol! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
enabledBlock
	
	^ enabledBlock! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
arguments: anArray

	arguments := anArray! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: ''!
category: aByteSymbol 
	
	category := aByteSymbol! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
parent: aSymbol 
	
	parent := aSymbol! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
with

	^ with! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
isWithSeparatorAfter
	
	^ withSeparatorAfter! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
parent

	^ parent! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
icon

	^ icon! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
shortcut
	
	^ shortcut! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
keyText: aString
	keyText := aString! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
enabled: aBoolean

	enabled := aBoolean! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: ''!
default: aKMModifiedShortcut 

	default := aKMModifiedShortcut! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
label

	^ label! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
icon: anIcon
	
	icon := anIcon! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
target: aSymbol 
	
	target := aSymbol! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
action: aBlock

	action := aBlock! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
help

	^ help! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: ''!
shortcut: aSymbol 
	
	shortcut := aSymbol! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	withSeparatorAfter := false.! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
label: aString
	
	label := aString! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
order: anInteger 

	order := anInteger! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
arguments
	
	^ arguments! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
order

	^ order! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
action
	
	^ action! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
help: aString 
	
	help := aString! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
group
	
	^ group! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: ''!
category

	^ category! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
selector

	^ selector! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
selector: aSymbol 
	
	selector := aSymbol! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
withSeparatorAfter

	withSeparatorAfter := true! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
enabled

	^ enabled! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
platform

	^ platform! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
default

	^ default! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
item: aSymbol 
	
	item := aSymbol! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
with: aBlock
 
	with := aBlock! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
item

	^ item! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
enabledBlock: aBlock

	enabledBlock := aBlock! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
target

	^ target! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
precondition: aBlock
	
	precondition := aBlock! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: ''!
keyText
	^keyText! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: ''!
group: aSymbol

	group := aSymbol! !

!PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: ''!
shortcutName
	
	^shortcutName! !

!PragmaMenuBuilder commentStamp: ''!
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:		<Object>
	pragmaCollector:		<PragmaCollection>
	pragmaKeywords:		<Collection of Symbol>
	currentRoot: 			<MenuRegistration>

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: 'menu building' stamp: ''!
buildTree
	"Retrieve all menu registrations with the help of a PragmaCollector then, 
	reorganise the tree and sort it  - see class comment for more informations"
	itemList := OrderedCollection new.
	self collectRegistrations.
	self arrangeRegistrations.
	self sortRegistrations! !

!PragmaMenuBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	isGroup := true.
	currentRoot := self.
	pragmaKeywords := OrderedCollection new.! !

!PragmaMenuBuilder methodsFor: 'accessing' stamp: ''!
itemReceiver
	^ model! !

!PragmaMenuBuilder methodsFor: 'accessing' stamp: ''!
pragmaKeywords: aCollection
	"Returns the pragma keyword used to select pragmas (see #pragmaCollector)"
	pragmaKeywords addAll: (aCollection collect: [:k | k asSymbol])! !

!PragmaMenuBuilder methodsFor: '*Morphic-Base' stamp: ''!
menuFrom: specBlock

	^ [ specBlock value asMenuMorph ]
			on: Error
			do: [
				self reset.
				self fallbackMenu ].! !

!PragmaMenuBuilder methodsFor: 'accessing' stamp: ''!
pragmaKeyword: aString
	"Set the pragma keyword used to select pragmas"
	pragmaKeywords add: aString asSymbol! !

!PragmaMenuBuilder methodsFor: '*Morphic-Base' stamp: ''!
menuEntitled: aTitle 
	"returns a MenuMorph build from my menuSpec"
	^ self menuFrom: [ self menuSpec label: aTitle ].! !

!PragmaMenuBuilder methodsFor: '*Morphic-Base' stamp: ''!
fallbackMenu

	^ FallbackMenu when: self fails: model.! !

!PragmaMenuBuilder methodsFor: 'registrations handling' stamp: ''!
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: ''!
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 pragmas
		do: [ :prg | 
			self
				currentRoot: self
				while: [ prg methodClass instanceSide
						perform: prg methodSelector
						with: menu ] ].
	self interpretRegistration: menu! !

!PragmaMenuBuilder methodsFor: 'public menu building' stamp: ''!
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: 'menu building' stamp: ''!
currentRoot: anItem while: aBlock
	| old |
	old := currentRoot.
	currentRoot := anItem.
	[aBlock value] ensure: [currentRoot := old]! !

!PragmaMenuBuilder methodsFor: 'accessing' stamp: ''!
pragmaKeywords
	"Returns the pragma keyword used to select pragmas (see #pragmaCollector)"
	^  pragmaKeywords! !

!PragmaMenuBuilder methodsFor: 'private' stamp: ''!
interpretRegistration: aRegistration 
	| root |
	root := MenuRegistration owner: self.
	aRegistration handOutItems do: [:item || node |
			node := item group
					ifNil: [ root item: item item ]
					ifNotNil: [:grp | root group: grp ].
			item with
				ifNil: [
					item action
						ifNil: [ 
							node 
								target: item target;
								arguments: item arguments;
								selector: item selector ]
						ifNotNil:[ 
							node 
								action: item action ]].
			node
				keyText: item keyText;
				help: item help;
				icon: item icon;
				order: item order;
				parent: item parent.
			item enabled
				ifNil: [ node enabledBlock: item enabledBlock ]
				ifNotNil: [:boolean | node enabled: boolean ].	
			item label
				ifNotNil: [ node label: item label ].
			item default ifNotNil: [ :d |
				node label: node label, ' (', d asString, ')'].
			item isWithSeparatorAfter
				ifTrue: [ node withSeparatorAfter ]]! !

!PragmaMenuBuilder methodsFor: '*Morphic-Base' stamp: ''!
menu
	"returns a MenuMorph build from my menuSpec"
	
	^ self menuFrom: [ self menuSpec ].! !

!PragmaMenuBuilder methodsFor: 'accessing' stamp: ''!
builder
	^ self! !

!PragmaMenuBuilder methodsFor: 'public menu building' stamp: ''!
menuSpec
	"returns a PluggableMenuSpec build from my contents"
	^ self menuSpecAt: nil! !

!PragmaMenuBuilder methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!PragmaMenuBuilder methodsFor: 'menu building' stamp: ''!
newSubItem
	| reg |
	reg := MenuRegistration owner: currentRoot.
	currentRoot addItem: reg.
	^ reg! !

!PragmaMenuBuilder methodsFor: 'registrations handling' stamp: ''!
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: '*Morphic-Base' stamp: ''!
menuAt: aName
	"returns a MenuMorph from my menuSpec"
	^ self menuFrom: [ self menuSpecAt: aName ].! !

!PragmaMenuBuilder methodsFor: 'registrations handling' stamp: ''!
allMisplacedItems
	| misplaced |
	self collectMisplacedItemsIn: (misplaced := OrderedCollection new).
	^ misplaced! !

!PragmaMenuBuilder methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!PragmaMenuBuilder methodsFor: 'registrations handling' stamp: ''!
pragmas

	"Return all pragmas which keyword is self pragmaKeyword"

	^ (self pragmaKeywords flatCollect: [ :each | Pragma allNamed: each ]) 
		  select: [ :prg | prg methodSelector numArgs = 1 ]! !

!PragmaMenuBuilder class methodsFor: 'private' stamp: ''!
itemSortBlock
	"The block which is used to sort a menu tree"
	^ [:a :b | 
		((a order notNil and: [b order notNil]) and: [a order ~= b order])
			ifTrue: [a order < b order]
			ifFalse: [((a order isNil and: [b order isNil]) or: [a order = b order])
				ifTrue: [true]
				ifFalse: [a order ifNil: [false] ifNotNil: [true]]]]! !

!PragmaMenuBuilder class methodsFor: 'instance creation' stamp: ''!
withAllPragmaKeywords: aCollection model: aModel
	"Build a builder using aPragmaKeyword as the pragma keyword and aModel a the model of the resulting builder"
	^ self new 
		pragmaKeywords: aCollection;
		model: aModel;
		yourself.! !

!PragmaMenuBuilder class methodsFor: 'private' stamp: ''!
orderAssignBlock
	"The block which is used to set MenuRegistration tree node order inst var (which is used to sort the tree)"

	^ [ :list | 
	list
		detect: [ :n | n order notNil ]
		ifFound: [ :firstWithOrder | 
			| idx order |
			"A menu registration with an order indication hase been found - then compute order of previous and next nodes"
			idx := list indexOf: firstWithOrder.
			order := firstWithOrder order.
			idx > 1
				ifTrue: [ 
					idx - 1 to: 1 do: [ :pos | 
						(list at: pos) order: order - 1.
						order := order - 1 ] ].
			order := firstWithOrder order.
			idx + 1 to: list size do: [ :pos | 
				(list at: pos) order ifNil: [ (list at: pos) order: order + 1 ] ifNotNil: [ order := (list at: pos) order ].
				order := order + 1 ].
			list ]
		ifNone: [ list ]	"No order has been set - do not touch anything, the list order is ok" ]! !

!PragmaMenuBuilder class methodsFor: 'instance creation' stamp: ''!
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! !

!PragmaRemoved commentStamp: ''!
A PragmaRemoved is announced by a PragamColllector when a method defined with an acceptable pragma according to the PragmaCollector filter is removed.

Instance Variables
!
!PragmaSetting commentStamp: ''!
A PragmaSetting is a holder for a setting. A setting is declared in a class method which contains a pragma (as examples, <menu> or <setting>). 
Settings can be collected on the fly by a PragmaCollector and browsed by a SettingBrowser. Settings are organized in trees.

Instance Variables
	allowedInStyle:		<Object>
	description:		<Object>
	dialog:		<Object>
	icon:		<Object>
	label:		<Object>
	name:		<Object>
	order:		<Object>
	ordering:		<Object>
	precondition:		<Object>
	target:		<Object>
	targetSelector:		<Object>

allowedInStyle
	- xxxxx

description
	- xxxxx

dialog
	- xxxxx

icon
	- xxxxx

label
	- xxxxx

name
	- xxxxx

order
	- xxxxx

ordering
	- xxxxx

precondition
	- xxxxx

target
	- xxxxx

targetSelector
	- xxxxx
!
!PragmaSetting methodsFor: 'user interface' stamp: ''!
labelMorphFor: aContainer
	^ StringMorph contents: (aContainer model viewedLabelOfSetting: self)! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
dialog: aValuable
	dialog := aValuable! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
targetSelector: aSelector
	targetSelector := aSelector! !

!PragmaSetting methodsFor: 'comparing' stamp: ''!
= other 
	^ self species = other species
		and: [self name = other name]! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
fontButtonLabel
	| emphases |
	emphases := IdentityDictionary new at: nil put: 'Regular' translated;
				 at: 0 put: 'Regular' translated;
				 at: 1 put: 'Bold' translated;
				 at: 2 put: 'Italic' translated;
				 at: 4 put: 'Underlined' translated;
				 at: 8 put: 'Narrow' translated; 
				 at: 16 put: 'StruckOut' translated;
				 yourself.
	^ StringMorph contents: self realValue familyName , ' '
			, (emphases
					at: self realValue emphasis
					ifAbsent: ['']) , ' ' , self realValue pointSize asString font: self realValue! !

!PragmaSetting methodsFor: 'comparing' stamp: ''!
hash
	^ self species hash bitXor: self name hash ! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
precondition
	^ precondition ifNil: [precondition := [true]].! !

!PragmaSetting methodsFor: 'export' stamp: ''!
isExportable

	^ false! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
hasEditableList
	^ false! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
description
	"Answer the value of description"

	^ description 
		ifNil: [description := ''] 
		ifNotNil: [ description translated ]
! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
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: ''!
dialog
	^ dialog! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
hasDefault
	^ false! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
icon
	^ icon ifNil: [icon := self defaultIcon]! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
allowedInStyle
	^ allowedInStyle ifNil: [allowedInStyle := self hasValue]! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
getFont
	^ FontChooser
		openWithWindowTitle: 'Font for ' , self name
		for: self
		setSelector: #realValue:
		getSelector: #realValue ! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
name: aName
	name := aName! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
realTarget
	^ target isSymbol
		ifTrue: [ Smalltalk globals at: target ifAbsent: [  ] ]
		ifFalse: [ target ]! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
targetSelector
	^ targetSelector! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
icon: aForm 
	icon := aForm! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
label
	^ label ifNil: [self name translated] ifNotNil: [label translated]! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
noOrdering
	ordering := false! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
settingReceiver
	^ self targetSelector ifNil: [self realTarget] ifNotNil: [self realTarget perform: self targetSelector]! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
target: anObject
	target := anObject! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
hasValue
	^ false! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
ordering
	^ ordering ifNil: [ordering := true]! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
label: aString
	label := aString! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
notInStyle
	allowedInStyle := false! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
order
	^ order! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
order: aNumber
	order := aNumber! !

!PragmaSetting methodsFor: 'visitor' stamp: ''!
acceptSettings: aVisitor
	^ aVisitor visitPragmaSetting: self! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
description: aString
	"Set the value of description"

	description := aString ! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
asString
	^ self name! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
enabled
	^ true! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
chooseFileDirectory
	| result |
	result := self theme chooseDirectoryIn: self currentWorld title: 'Choose a directory' path: nil.
	result ifNotNil: [ self realValue: result  ].! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
name
	^ name ifNil: [super name] ifNotNil: [name]! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
chooseFilePath
    | result |
    result := self theme chooseFileIn: self currentWorld title: 'Choose a file' extensions: nil path: nil preview: true.
    result ifNotNil: [ self realValue: result fullName.]! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
defaultIcon
	^ self iconNamed: #smallConfigurationIcon! !

!PragmaSetting methodsFor: 'export' stamp: ''!
exportSettingAction
	
	^ nil! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
precondition: aValuable
	precondition := aValuable! !

!PragmaSetting methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!PragmaSetting methodsFor: 'user interface' stamp: ''!
inputMorphFor: aContainer 
	^ self inputWidget
		ifNotNil: [:iw | 
			( self theme newRowIn: self for: {iw})
				 clipSubmorphs: true;
				 hResizing: #shrinkWrap;
				 cellInset: 0;
				 yourself]! !

!PragmaTest commentStamp: ''!
SUnit tests for Pragma class!
!PragmaTest methodsFor: 'tests' stamp: ''!
testArgumentNamed
	| pragma |
	pragma := (self class >> #methodWithPragma) pragmas anyOne.
	self assert: (pragma argumentNamed: #testPragmaArg1) equals: #toto.
	self assert: (pragma argumentNamed: #arg2) equals: 2.
	self assert: (pragma argumentNamed: #arg3).
	self should: [ pragma argumentNamed: #nonExisting ] raise: Error! !

!PragmaTest methodsFor: 'tests' stamp: ''!
testArgumentAt
	| pragma |
	pragma := (self class >> #methodWithPragma) pragmas anyOne.
	self assert: (pragma argumentAt: 1) equals: #toto.
	self assert: (pragma argumentAt: 2) equals: 2.
	self assert: (pragma argumentAt: 3)! !

!PragmaTest methodsFor: 'tests' stamp: ''!
testArgumentNamedIfNone
	| pragma |
	pragma := (self class >> #methodWithPragma) pragmas anyOne.
	self assert: (pragma argumentNamed: #arg3 ifNone: [ false ]).
	self deny: (pragma argumentNamed: #nonExisting ifNone: [ false ])! !

!PragmaTest methodsFor: 'tests' stamp: ''!
testEqual
	self assert: atPragma equals: atPragma.
	self assert: atPragma equals: anotherAtPragma.
	self assert: anotherAtPragma equals: atPragma.
	self assert: atPragma equals: anotherAtPragma.
	self assert: anotherAtPragma equals: yetAnotherAtPragma.
	self assert: yetAnotherAtPragma equals: atPragma.

	self deny: atPragma equals: atPutPragma! !

!PragmaTest methodsFor: 'tests - cache' stamp: ''!
testall
	self assert: Pragma all first class equals: Pragma! !

!PragmaTest methodsFor: 'tests' stamp: ''!
testHash
	self assert: atPragma hash equals: atPragma hash.
	self assert: atPragma hash equals: anotherAtPragma hash.
	self assert: anotherAtPragma hash equals: atPragma hash.
	self assert: atPragma hash equals: anotherAtPragma hash.
	self assert: anotherAtPragma hash equals: yetAnotherAtPragma hash.
	self assert: yetAnotherAtPragma hash equals: atPragma hash! !

!PragmaTest methodsFor: 'tests - cache' stamp: ''!
testAllNamed
	self assert: ((Pragma allNamed: #primitive:) first selector) equals: #primitive:.
	"does it work when asking for a non existing Pragma?"
	self assert: (Pragma allNamed: #nonExistingPragma) isEmpty! !

!PragmaTest methodsFor: 'tests' stamp: ''!
testCopy
	| copy |
	copy := atPragma copy.

	self deny: atPragma identicalTo: copy.
	self assert: atPragma method identicalTo: copy method.
	self assert: atPragma selector identicalTo: copy selector.
	self assert: atPragma arguments identicalTo: copy arguments! !

!PragmaTest methodsFor: 'helper' stamp: ''!
methodWithPragma
	<testPragmaArg1: #toto arg2: 2 arg3: true>! !

!PragmaTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	atPragma := Pragma for: (Object methodDict at: #at:) selector: #primitive: arguments: (Array with: 60).
	anotherAtPragma := Pragma for: (Object methodDict at: #at:) selector: #primitive: arguments: (Array with: 60).
	yetAnotherAtPragma := Pragma for: (Object methodDict at: #at:) selector: #primitive: arguments: (Array with: 60).
	atPutPragma := Pragma for: (Object methodDict at: #at:) selector: #primitive: arguments: (Array with: 61).! !

!PragmaUpdated commentStamp: ''!
A PragmaUpdated is announced by a PragamColllector when a method defined with an acceptable pragma according to the PragmaCollector filter is updated (recompiled).


Instance Variables
!
!PreDebugAction commentStamp: ''!
A PreDebugAction is a debugging actions sending a unary message to the pre debug window.
!
!PreDebugAction methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self needsUpdate: false.
	self needsValidation: false.! !

!PreDebugAction methodsFor: 'accessing' stamp: ''!
preDebugWindow: anObject
	
	preDebugWindow := anObject! !

!PreDebugAction methodsFor: 'accessing' stamp: ''!
receiver

	^ self preDebugWindow! !

!PreDebugAction methodsFor: 'accessing' stamp: ''!
preDebugWindow
	
	^ preDebugWindow! !

!PreDebugAction class methodsFor: 'actions creation' stamp: ''!
debugActionsFor: aDebugger
	<preDebuggingAction>
	
	^ { 
		self new
			id: #abandonAction;
			selector: #close;
			order: 10;
			help: 'Close the debugger and ignore the exception';
			label: 'Abandon'.
		self new
			id: #openFullDebuggerAction;
			selector: #openFullDebugger;
			order: 15;
			help: 'Open a full debugger to navigate in the full bugged stack.';
			label: 'Debug'
	}! !

!PreDebugDoesNotUnderstandAction commentStamp: ''!
A PreDebugDoesNotUnderstandAction adds the DoesNotUnderstandDebugAction debugging actions to the pre debug window. When executed, it will further close the pre debug window and open the full debugger. 

Instance Variables
	preDebugWindow:		<Object>

preDebugWindow
	- xxxxx
!
!PreDebugDoesNotUnderstandAction methodsFor: 'private' stamp: ''!
closeWindow
	"Safely close the pre-debugger window without destroying the debugger context and stack"

	self preDebugWindow
		debugger: nil;
		close! !

!PreDebugDoesNotUnderstandAction methodsFor: 'actions' stamp: ''!
executeAction

	"The create method from the session will trigger #contextChanged, which will
	make the debgger update the stack. Sof it safe to just open the debugger."
	super executeAction.
	self preDebugWindow openFullDebugger! !

!PreDebugDoesNotUnderstandAction methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	self needsUpdate: false.
	self needsValidation: false! !

!PreDebugDoesNotUnderstandAction methodsFor: 'accessing' stamp: ''!
preDebugWindow: anObject
	
	preDebugWindow := anObject! !

!PreDebugDoesNotUnderstandAction methodsFor: 'accessing' stamp: ''!
preDebugWindow
	
	^ preDebugWindow! !

!PreDebugDoesNotUnderstandAction methodsFor: 'accessing' stamp: ''!
id

	^ #preDebugDoesNotUnderstand! !

!PreDebugResumeDebugAction commentStamp: ''!
A PreDebugResumeDebugAction adds the ResumeDebugAction to the pre debug window.

Instance Variables
	preDebugWindow:		<Object>

preDebugWindow
	- xxxxx
!
!PreDebugResumeDebugAction methodsFor: 'actions' stamp: ''!
executeAction

	self session 
		resume;
		clear.
	self preDebugWindow close.! !

!PreDebugResumeDebugAction methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self needsUpdate: false.
	self needsValidation: false! !

!PreDebugResumeDebugAction methodsFor: 'accessing' stamp: ''!
preDebugWindow: anObject
	
	preDebugWindow := anObject! !

!PreDebugResumeDebugAction methodsFor: 'accessing' stamp: ''!
preDebugWindow
	
	^ preDebugWindow! !

!PreDebugResumeDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #preDebugResume! !

!PreDebugResumeDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<preDebuggingAction>! !

!PreorderGuide commentStamp: ''!
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: ''!
pushAll: aCollection 
	aCollection reverseDo: [ :each | work add: each ]! !

!PreorderGuide methodsFor: 'showing' stamp: ''!
show: aReference
	self push: aReference entry.
	self whileNotDoneDo: [ self visitNextEntry: self pop ]! !

!PreorderGuide methodsFor: 'showing' stamp: ''!
visitNextEntry: entry
	
	entry isFile
		ifTrue: [ visitor visitFile: entry ]
		ifFalse: [ 
			visitor visitDirectory: entry.
			(self shouldVisitChildrenOf: entry)
				ifTrue: [ self pushAll: entry reference entries ]]! !

!PreorderGuideTest commentStamp: ''!
SUnit tests for class PreorderGuide!
!PreorderGuideTest methodsFor: 'tests' stamp: ''!
testAll
	guide := PreorderGuide for: self.
	guide show: (filesystem / 'alpha').
	self assertVisitedIs: #(
			'alpha'
			'beta'
			'delta'
			'gamma'
			'epsilon'
			'zeta'
		)! !

!PresenterResized methodsFor: 'accessing' stamp: ''!
extent
	^ extent! !

!PresenterResized methodsFor: 'accessing' stamp: ''!
extent: anObject
	extent := anObject! !

!PrettyTextDiffBuilder commentStamp: ''!
I'm like TextDiffBuilder, but I use the pretty-printed version of the source code if available.

Instance Variables
	sourceClass:		<Class>

sourceClass
	- this class provides the pretty-printer
!
!PrettyTextDiffBuilder methodsFor: 'initialize' stamp: ''!
split: aString 
	| formatted trimmed |
	trimmed := aString asString trimBoth.
	trimmed isEmpty ifTrue: [ ^super split: '' ].
	formatted := [ sourceClass
				source: trimmed;
				class: sourceClass;
				format] on: Error do: [ :ex | trimmed ].
	^ super split: formatted! !

!PrettyTextDiffBuilder methodsFor: 'initialize' stamp: ''!
sourceClass: aClass
	sourceClass := aClass.! !

!PrettyTextDiffBuilder class methodsFor: 'instance creation' stamp: ''!
from: srcString to: dstString inClass: srcClass 
	^ (self new sourceClass: srcClass) from: srcString to: dstString
		! !

!PrimitiveError commentStamp: ''!
A PrimitiveError is used to answer a primitive failure code that has an associated operating system/library error.

Instance Variables
	errorName:		<Symbol>
	errorCode:		<Integer>

errorName
	- typically #'operating system error'

errorCode
	- the value of the error, a signed 64-bit value, a representation imposed by the VM; specific clients must map this error value into an unsigned value as appropriate if required

Typical usage is shown in the fictitious method below:

primitiveOperation
	<primitive: 'primitiveOperation' module: 'APlugin' error: error>
	^(error isPrimitiveError)
		ifTrue: [ self processErrorCode: error errorCode ]
		ifFalse: [ self primitiveFailed ].!
!PrimitiveError methodsFor: 'accessing' stamp: ''!
errorCode
	
	^errorCode! !

!PrimitiveError methodsFor: 'accessing' stamp: ''!
errorCode: anInteger
	
	errorCode := anInteger! !

!PrimitiveError methodsFor: 'accessing' stamp: ''!
errorName: aSymbol
	
	errorName := aSymbol! !

!PrimitiveError methodsFor: 'accessing' stamp: ''!
errorName
	
	^errorName! !

!PrimitiveError methodsFor: 'testing' stamp: ''!
isPrimitiveError
	"Answer a boolean indicating if the receiver is an error object returned by a primitive"
	^true! !

!PrimitiveErrorVariable commentStamp: ''!
Primitives can declare a local variable that will hold the error code.!
!PrimitiveErrorVariable methodsFor: 'accessing' stamp: ''!
node: anObject
	node := anObject! !

!PrimitiveErrorVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitTemporaryVariableNode: aNode! !

!PrimitiveErrorVariable methodsFor: 'queries' stamp: ''!
definingNode
	^node! !

!PrimitiveErrorVariable class methodsFor: 'instance creation' stamp: ''!
node: aVariableNode
	^self new 
		name: aVariableNode name;
		node: aVariableNode;
		markWrite;
		yourself! !

!PrimitiveFailed commentStamp: ''!
I am PrimitiveFailed, an exception signaled when a primitive fails.!
!PrimitiveFailed methodsFor: 'printing' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		stream << 'primitive '.
		stream print: self selector.
		stream << ' in '.
		stream print: self signaler class.
		stream << ' failed' ]! !

!PrintVersionCommandLineHandler commentStamp: ''!
Usage: printVersion [ --numeric | --release ]
	--numeric   Print the full version number only (e.g. 12345)
	--release   Print the major release number only (e.g. 1.2)
	
Documentation:
Prints the version number in an easy to parse format. This can be used in Jenkins with the "Description Setter" Plugin. Configure it like this:

Regular expression:  \[version\] (.*)
Description: \1


Examples:
	pharo Pharo.image printVersion
	#result will be something like:
	[version] 3.0 #30100

	pharo Pharo.image printVersion --numeric
	# will print a simpler version
	30100
	
	pharo Pharo.image printVersion --release
	# prints the Pharo release version
	3.0!
!PrintVersionCommandLineHandler methodsFor: 'actions' stamp: ''!
printVersion
	self stdout 
		nextPutAll: '[version] ';
		print: SystemVersion current majorMinorVersion;
		nextPutAll: ' ';
		print: SystemVersion current asString;
		nextPutAll: OSPlatform current lineEnding.! !

!PrintVersionCommandLineHandler methodsFor: 'actions' stamp: ''!
printNumericVersion
	self stdout 
		print: SystemVersion current highestUpdate;
		lf! !

!PrintVersionCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self activateHelp
		ifTrue: [  ^ self ].
		
	(self hasOption: 'numeric')
		ifTrue: [ 
			self printNumericVersion.
			^ self exitSuccess].
	(self hasOption: 'release')
		ifTrue: [ 
			self printRelease.
			^ self exitSuccess ].
	self hasArguments
		ifFalse: [ 
			self printVersion.
			^ self exitSuccess ].
	
	self printHelp.
	^ self exitFailure! !

!PrintVersionCommandLineHandler methodsFor: 'actions' stamp: ''!
printRelease
	self stdout 
		print: SystemVersion current major;
		nextPutAll: '.';
		print: SystemVersion current minor;
		lf.! !

!PrintVersionCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'printVersion'! !

!PrintVersionCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Print image version'! !

!ProceedDialogWindow commentStamp: ''!
Yes/no dialog. Test result as to whether the dialog is cancelled (no) or not (yes).!
!ProceedDialogWindow methodsFor: 'event handling' stamp: ''!
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: 'event handling' stamp: ''!
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: 'actions' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self newOKButton. self newCancelButton isDefault: true}! !

!ProceedDialogWindow methodsFor: 'accessing' stamp: ''!
icon
	"Answer an icon for the receiver."

	^ self iconNamed: #questionIcon! !

!ProceedDialogWindow methodsFor: 'accessing' stamp: ''!
no
	"Answer no."

	self cancel! !

!ProceedDialogWindow methodsFor: 'accessing' stamp: ''!
yes
	"Answer yes."

	self ok! !

!ProceedDialogWindow class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallQuestionIcon! !

!Process commentStamp: ''!
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: 'signaling' stamp: ''!
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)."
	<debuggerCompleteToSender>
	| 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: 'printing' stamp: ''!
browserPrintString
	^self browserPrintStringWith: suspendedContext! !

!Process methodsFor: 'changing process state' stamp: ''!
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 |
	<primitive: 88>
	"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: 'testing' stamp: ''!
isActiveProcess

	^ self == Processor activeProcess! !

!Process methodsFor: '*Reflectivity' stamp: ''!
level
	<metaLinkOptions: #( + optionDisabledLink)>
	^level ifNil: [ level := 0 ]! !

!Process methodsFor: 'testing' stamp: ''!
isTerminated

	"Answer if the receiver is terminated, i.e. if the receiver is not active and 
	one of the following conditions is met:
	(1) the receiver is a defunct process (suspendedContext = nil or pc = nil)
	(2) the receiver is suspended in the endProcess method (We cannot use pragmas... pragmas require the compiler, it generates an evil dependency.
	It also is not available in minimal images)"

	self isActiveProcess ifTrue: [ ^ false ].
	
	^suspendedContext isNil or: [
		suspendedContext isDead or: [
			(suspendedContext method == (self class >> #endProcess))]]! !

!Process methodsFor: 'changing process state' stamp: ''!
endProcess
	"When I reach this method, I'm terminated. Suspending or terminating me is harmless."

	thisContext terminateTo: nil.   "set thisContext sender to nil"
	self suspend.
  
	"Restart this method.
	This will terminate and suspend again in case of sending resume to a terminated process"
	"the following line commented out because current debugger step over tests fail with this feature"
	"^thisContext restart"! !

!Process methodsFor: 'changing process state' stamp: ''!
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: 'accessing' stamp: ''!
priority: anInteger
	"Set the receiver's priority to anInteger.
	When changing the process priority we need to yield to make it reschedule the processor"

	(anInteger between: Processor lowestPriority and: Processor highestPriority)
		ifTrue: [ priority := anInteger. Processor interpriorityYield: self ]
		ifFalse: [ self error: 'Invalid priority: ' , anInteger printString ]! !

!Process methodsFor: 'changing process state' stamp: ''!
run
	"Suspend current process and execute self instead"

	| proc |
	proc := Processor activeProcess.
	[	proc suspend.
		self resume.
	] forkAt: Processor highestPriority! !

!Process methodsFor: 'accessing' stamp: ''!
effectiveProcess
	"effectiveProcess is a mechanism to allow process-faithful debugging.  The debugger executes code
	 on behalf of processes, so unless some effort is made the identity of Processor activeProcess is not
	 correctly maintained when debugging code.  The debugger uses evaluate:onBehalfOf: to assign the
	 debugged process as the effectiveProcess of the process executing the code, preserving process
	 identity."
	^effectiveProcess ifNil: [self]! !

!Process methodsFor: 'changing suspended state' stamp: ''!
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:
		[^Processor activeProcess
			evaluate: [suspendedContext := aContext return: value from: aContext]
			onBehalfOf: self].
	self activateReturn: aContext value: value.
	^self complete: aContext! !

!Process methodsFor: 'changing suspended state' stamp: ''!
restartTopWith: method
	"Rollback top context and replace with new method.  Assumes self is suspended"

	suspendedContext privRefreshWith: method! !

!Process methodsFor: 'testing' stamp: ''!
isTerminating
	"lazy initialization is a fallback only for processes that existed before this addition"
	^ terminating ifNil: [ false ]! !

!Process methodsFor: 'changing suspended state' stamp: ''!
activateReturn: aContext value: value
	"Activate 'aContext return: value', so execution will return to aContext's sender"

	^Processor activeProcess
		evaluate: [suspendedContext := suspendedContext activateReturn: aContext value: value]
		onBehalfOf: self! !

!Process methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	terminating := false! !

!Process methodsFor: 'printing' stamp: ''!
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: 'changing process state' stamp: ''!
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."

	<primitive: 87>
	self primitiveFailed! !

!Process methodsFor: 'accessing' stamp: ''!
suspendingList
	"Answer the list on which the receiver has been suspended."

	^myList! !

!Process methodsFor: 'changing suspended state' stamp: ''!
popTo: aContext value: aValue
	"Replace the suspendedContext with aContext, releasing all contexts 
	 between the currently suspendedContext and it."

	self == Processor activeProcess ifTrue:
		[^self error: 'The active process cannot pop contexts'].
	^(self calleeOf: aContext)
		ifNil: [aContext]  "aContext is on top"
		ifNotNil:
			[:callee|
			 Processor activeProcess
				evaluate: [self return: callee value: aValue]
				onBehalfOf: self]! !

!Process methodsFor: 'changing suspended state' stamp: ''!
stepToHome: aContext 
	| ctxt pair error |
	ctxt := suspendedContext.
	suspendedContext := nil.
	pair := Processor activeProcess
				evaluate: [ctxt stepToHome: aContext]
				onBehalfOf: self.
	suspendedContext := pair first.
	error := pair second.

	error ifNotNil: [
		suspendedContext := error signalerContext.
		"As we are activating a context that has been interrupted in the signal of the exception,
		we need to push a receiver of the signal message.
		A suspended context should always be a top context.
		A top context has the return value of the message in the stack.
		As this context has been suspended while sending a message the return value should be pushed. 
		This is maybe not the expected return value (the #signal message returns the value with the 
		one the exception is resumed).
		But this allows the debugger to continue executing and does not crash the interpreter nor 
		the VM
		"
		suspendedContext push: nil].
	^ suspendedContext! !

!Process methodsFor: 'debugging' stamp: ''!
debug
	^ self debugWithTitle: 'Debug'.! !

!Process methodsFor: 'changing suspended state' stamp: ''!
install: aContext 
	"Replace the suspendedContext with aContext."

	self == Processor activeProcess
		ifTrue: [^self error: 'The active process cannot install contexts'].
	suspendedContext := aContext! !

!Process methodsFor: '*Reflectivity' stamp: ''!
shiftLevelDown
	<metaLinkOptions: #( + optionDisabledLink)>
	level ifNil: [ level := 0 ].
	(level rfIsEqual: 0) ifTrue: [ ^level ].
	(level rfIsEqual: 1) ifTrue: [ ^level := 0 ].
	level := level rfMinus: 1.! !

!Process methodsFor: '*Reflectivity' stamp: ''!
shiftLevelUp
	<metaLinkOptions: #( + optionDisabledLink)>
	level ifNil: [ level := 0 ].
	level := level rfPlus: 1! !

!Process methodsFor: 'debugging' stamp: ''!
debugWithTitle: title

	| context |
	context := self isActiveProcess
		           ifTrue: [ thisContext ]
		           ifFalse: [ self suspendedContext ].
	UIManager default
		requestDebuggerOpeningForProcess: self
		named: title
		inContext: context! !

!Process methodsFor: 'process specific' stamp: ''!
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: 'accessing' stamp: ''!
copyStack

	^ self copy install: suspendedContext copyStack! !

!Process methodsFor: '*Debugger-Model' stamp: ''!
newDebugSessionNamed: aString startedAt: aContext

	^DebugSession named: aString on: self startedAt: aContext! !

!Process methodsFor: 'changing suspended state' stamp: ''!
completeTo: aContext 
	"Resume self until aContext is on top"

	self suspendedContext == aContext ifTrue: [^ aContext].
	^ self complete: (self calleeOf: aContext)! !

!Process methodsFor: 'signaling' stamp: ''!
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 := Context
		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: 'changing suspended state' stamp: ''!
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."

	self == Processor activeProcess ifTrue:
		[^self error: 'The active process cannot pop contexts'].
	^(self calleeOf: aContext)
		ifNil: [aContext]  "aContext is on top"
		ifNotNil:
			[:callee|
			 Processor activeProcess
				evaluate: [self return: callee value: callee receiver]
				onBehalfOf: self]! !

!Process methodsFor: 'private' stamp: ''!
evaluate: aBlock onBehalfOf: aProcess
	"Evaluate aBlock setting effectiveProcess to aProcess.  Used
	 in the execution simulation machinery to ensure that
	 Processor activeProcess evaluates correctly when debugging."
	| oldEffectiveProcess |
	oldEffectiveProcess := effectiveProcess.
	effectiveProcess := aProcess.
	^aBlock ensure: [effectiveProcess := oldEffectiveProcess]! !

!Process methodsFor: 'accessing' stamp: ''!
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: 'process specific' stamp: ''!
psValueAt: index put: value
	"Set a value for given index in process-specific storage"

	"NOTE: this method are PRIVATE. Do not use it directly, instead use ProcessSpecificVariable (or its subclasses) "

	env ifNil: [ env := WeakArray new: PSKeys size ].
	env size < PSKeys size ifTrue: [ env := env grownBy: PSKeys size - env size ].
	^ env at: index put: value.! !

!Process methodsFor: 'changing suspended state' stamp: ''!
step

	^Processor activeProcess
		evaluate: [suspendedContext := suspendedContext step]
		onBehalfOf: self! !

!Process methodsFor: 'process specific' stamp: ''!
resetPSValueAt: index

	"NOTE: this method are PRIVATE. "

	env ifNil: [ ^ self ]. 
	index > env size ifTrue: [ ^ self ].
	
	env at: index put: nil! !

!Process methodsFor: 'changing suspended state' stamp: ''!
stepToCallee
	"Step until top context changes"

	Processor activeProcess
		evaluate:
			[| ctxt |
			ctxt := suspendedContext.
			[ctxt == suspendedContext] whileTrue: [
				suspendedContext := suspendedContext step]]
		onBehalfOf: self.
	^suspendedContext! !

!Process methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' in '.
	suspendedContext printOn: aStream! !

!Process methodsFor: 'accessing' stamp: ''!
priority
	"Answer the priority of the receiver."

	^priority! !

!Process methodsFor: 'private' stamp: ''!
doTerminationFromAnotherProcess 
	
  "Stop this process forever from another process.  
	Unwind to execute pending ensure:/ifCurtailed: blocks before terminating.
	It assumes that self is not the active process
	and the termination is requested from another process"

	| ctxt oldList outerMost unwindBlock |

	self isTerminating ifTrue: [ ProcessAlreadyTerminating signal. ^self ].
	terminating := true.

	"Always suspend the process first so it doesn't accidentally get woken up"
	oldList := self suspend.
	suspendedContext ifNil: [^self].

	"Figure out if we are terminating the process while waiting inside special object like
	in Semaphore>>critical:. So if waiting object is interesting on this situation we will ask it to handle it. In case of Semaphore>>critical, Semaphore will pop the suspendedContext so that we leave the ensure: block inside	Semaphore>>critical: without signaling the semaphore.
	This methods allow to not be restricted only on Semaphore case."
	suspendedContext := oldList handleProcessTerminationOfWaitingContext: suspendedContext.

	"If terminating a process halfways through an unwind, try to complete that unwind block first;
	if there are multiple such nested unwind blocks, try to complete the outer-most one; the inner
	blocks will be completed in the process."
	ctxt := suspendedContext.
	[(ctxt := ctxt findNextUnwindContextUpTo: nil) isNil] whileFalse: 
		"Contexts under evaluation have already set their complete (tempAt: 2) to true."
		[ctxt unwindComplete ifNotNil: [outerMost := ctxt]].
	outerMost ifNotNil: [
		"This is the outer-most unwind context currently under evaluation;
		let's find an inner context executing outerMost's argument block (tempAt: 1)"
		(suspendedContext findContextSuchThat: [:ctx | 
			ctx closure == outerMost unwindBlock]) ifNotNil: [:inner | 
				"Let's finish the unfinished unwind context only (i.e. up to inner) and return here"
				outerMost := (suspendedContext runUntilErrorOrReturnFrom: inner) first.
				"Update the receiver's suspendedContext (the previous step reset its sender to nil);
				return, if the execution stack reached its bottom (e.g. in case of non-local returns)."
				(suspendedContext := outerMost sender) ifNil: [^self]]]. 

	"Now all unwind blocks caught halfway through have been completed; 
	let's execute the ones still pending. Note: #findNextUnwindContextUpTo: starts
	searching from the receiver's sender but the receiver itself may be an unwind context."
	ctxt := suspendedContext.
	ctxt isUnwindContext ifFalse: [ctxt := ctxt findNextUnwindContextUpTo: nil].
	[ctxt isNil] whileFalse: [
		ctxt unwindComplete ifNil: [
			ctxt unwindComplete: true.
			unwindBlock := ctxt unwindBlock.
			"Create a context for the unwind block and execute it on the unwind block's stack. 
			Note: using #value instead of #runUntilErrorOrReturnFrom: would lead to executing 
			the unwind on the wrong stack preventing the correct execution of non-local returns."
			suspendedContext := unwindBlock asContextWithSender: ctxt.
			suspendedContext runUntilErrorOrReturnFrom: suspendedContext].
		ctxt := ctxt findNextUnwindContextUpTo: nil].

	"Mark the context as terminated"
	suspendedContext terminateTo: nil.
	suspendedContext setSender: nil receiver: self method: (Process>>#endProcess) arguments: {}! !

!Process methodsFor: 'accessing' stamp: ''!
name: aString

	name := aString! !

!Process methodsFor: 'changing suspended state' stamp: ''!
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: '*Reflectivity' stamp: ''!
rfeffectiveProcess
	"same as #effectiveProcess but for internal use for metalink activation"
	<metaLinkOptions: #( + optionDisabledLink)>
	^effectiveProcess ifNil: [self] ! !

!Process methodsFor: 'changing suspended state' stamp: ''!
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 signal context (rather than open a debugger)."

	| ctxt pair |
	ctxt := suspendedContext.
	suspendedContext := nil.	"disable this process while running its stack in active process below"
	pair := Processor activeProcess
				evaluate: [ ctxt runUntilErrorOrReturnFrom: aContext ]
				onBehalfOf: self.
	suspendedContext := pair first.
	^ pair second
		ifNil: [ suspendedContext ]
		ifNotNil: [ :error | error completeProcess: self with: aContext ]! !

!Process methodsFor: 'testing' stamp: ''!
isSuspended
	"Answer true if I was never scheduled yet (new process, never been sent #resume) or paused (was sent #suspend)"
	self isActiveProcess ifTrue: [ ^false ].
	self isTerminated ifTrue: [ ^false ].
	^myList isNil or: [ myList isEmpty ]! !

!Process methodsFor: 'printing' stamp: ''!
longPrintOn: stream
	| ctxt |
	super printOn: stream.
	stream cr.
	ctxt := self suspendedContext.
	[ ctxt isNil ]
		whileFalse: [ 
			stream space.
			ctxt printOn: stream.
			stream cr.
			ctxt := ctxt sender ]! !

!Process methodsFor: 'changing process state' stamp: ''!
terminate 
	"Stop the process that the receiver represents forever.  Unwind to execute pending ensure:/ifCurtailed: blocks before terminating."

	self isActiveProcess 
		ifTrue: [ self doTerminationFromYourself ]
		ifFalse: [ self doTerminationFromAnotherProcess]! !

!Process methodsFor: 'process specific' stamp: ''!
installEnvIntoForked: newProcess
	env ifNil: [ ^ self ].
	InheritablePSKeys ifNil: [ ^self ].

	"InheritablePSKeys includes indices of all inheritable variables"
	1 to: InheritablePSKeys size do: [ :i | | varIndex varValue |
		varIndex := InheritablePSKeys at: i.
		(varIndex <= env size) "if new variable was installed into system existed processes env can not have room for it"
			ifTrue: [ 
				varValue := env at: varIndex.
				varValue ifNotNil: [ (PSKeys at: varIndex) installValue: varValue intoForked: newProcess from: self ] ]]! !

!Process methodsFor: 'signaling' stamp: ''!
on: exception do: handlerAction
	"This method inject new bottom context into process with exception handler. 
	It uses context jump tricks to achieve it"
	| currentContext root newRoot |
	currentContext := self isActiveProcess ifTrue: [ thisContext ] ifFalse: [self suspendedContext].
	root := currentContext bottomContext.
	newRoot := [
			[root insertSender: thisContext.
			currentContext jump] on: exception do: handlerAction.
		Processor terminateRealActive] asContext.

	self isActiveProcess 
		ifTrue: [ newRoot jump ]
		ifFalse: [ self install: newRoot ]! !

!Process methodsFor: 'private' stamp: ''!
doTerminationFromYourself 
	"Stop this process forever from the process itself. 
	Unwind to execute pending ensure:/ifCurtailed: blocks before terminating.
	It assumes that self is the active process. "
	terminating := true.
	thisContext unwindForTermination.
	^self endProcess
! !

!Process methodsFor: 'changing suspended state' stamp: ''!
step: aContext 
	"Resume self until aContext is on top, or if already on top, do next step"

	^Processor activeProcess
		evaluate:
			[self suspendedContext == aContext
				ifTrue: [suspendedContext := suspendedContext step]
				ifFalse: [self complete: (self calleeOf: aContext)]]
		onBehalfOf: self! !

!Process methodsFor: 'accessing' stamp: ''!
effectiveProcess: aProcess 
	effectiveProcess := aProcess! !

!Process methodsFor: '*Reflectivity' stamp: ''!
isMeta
	<metaLinkOptions: #( + optionDisabledLink)>
	level ifNil: [ level := 0 ].
	^level ~= 0! !

!Process methodsFor: 'accessing' stamp: ''!
name
 
 	^name ifNil: [ self hash asString forceTo: 10 paddingStartWith: $ ]! !

!Process methodsFor: 'accessing' stamp: ''!
suspendedContext
	"Answer the context the receiver has suspended."

	^suspendedContext! !

!Process methodsFor: 'changing suspended state' stamp: ''!
restartTop
	"Rollback top context and replace with new method.  Assumes self is suspended"

	suspendedContext privRefresh! !

!Process methodsFor: 'private' stamp: ''!
suspendedContext: aContext

	suspendedContext := aContext! !

!Process methodsFor: '*Debugging-Core' stamp: ''!
stepToSendOrReturn

	^Processor activeProcess
		evaluate: [suspendedContext := suspendedContext stepToSendOrReturn]
		onBehalfOf: self! !

!Process methodsFor: '*Reflectivity' stamp: ''!
isActive: n
	<metaLinkOptions: #( + optionDisabledLink)>
	^level = n or: [ level == nil ]. ! !

!Process class methodsFor: 'process specific' stamp: ''!
updateInheritableKeys
"
	self updateInheritableKeys
"
	| keys |
	keys := Set new.
	ProcessSpecificVariable allSubclasses select: [ :each | each isInheritable ] thenDo: [ :each | keys add: each soleInstance index].
	  
	InheritablePSKeys := keys asArray ifEmpty: [ nil ]! !

!Process class methodsFor: 'process specific' stamp: ''!
allocatePSKey: aPSVariable

	"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 |
	self psKeysSema critical: [
		PSKeys 
			ifNil: [ PSKeys := WeakArray with: aPSVariable. index := 1 ]
			ifNotNil: [ 
				index := PSKeys indexOf: aPSVariable.
				index = 0 ifTrue: [
					index := PSKeys indexOf: nil.
					index = 0 
						ifTrue: [
							index := (PSKeys := PSKeys copyWith: aPSVariable) 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: aPSVariable.
							]
				]
			].

		aPSVariable isInheritable ifTrue: [ 
			InheritablePSKeys 
				ifNil: [ InheritablePSKeys := Array with: index ]
				ifNotNil: [ 
					(InheritablePSKeys includes: index) ifFalse: [ InheritablePSKeys := InheritablePSKeys copyWith: index ]]
		]
	].

	^ index! !

!Process class methodsFor: '*TaskIt' stamp: ''!
enableDebugger
	! !

!Process class methodsFor: 'process specific' stamp: ''!
psKeysSema
	"Isolate handling of class variable"

	^PSKeysSema ifNil: [ PSKeysSema := Semaphore forMutualExclusion ]! !

!Process class methodsFor: 'instance creation' stamp: ''!
forContext: aContext priority: anInteger 
	"Answer an instance of me that has suspended aContext at priority 
	anInteger."

	| newProcess |
	newProcess := self new.
	newProcess suspendedContext: aContext asContext.
	newProcess priority: anInteger.
	Processor activeProcess installEnvIntoForked: newProcess.
	^newProcess! !

!Process class methodsFor: '*TaskIt' stamp: ''!
disableDebugger
	! !

!Process class methodsFor: '*TaskIt' stamp: ''!
isDebuggingCompatible
	^ false! !

!ProcessAlreadyTerminating commentStamp: ''!
I notify the sender of #terminate that the receiving process has already received a #terminate before.

Use Process>>isTerminating to check for this.!
!ProcessBrowser commentStamp: ''!
Change Set:		ProcessBrowser
Date:			14 March 2000
Author:			Ned Konz

email: ned@bike-nomad.com

This is distributed under the Squeak License.

Added 14 March:
	CPUWatcher integration
	automatically start and stop CPUWatcher
	added CPUWatcher to process list menu

Added 29 October:
	MVC version
	2.8, 2.7 compatibility
	rearranged menus
	added pointer inspection and chasing
	added suspend/resume
	recognized more well-known processes
	misc. bug fixes

Added 26 October: highlight pc in source code
Added 27 October: added 'signal semaphore'
added 'inspect receiver', 'explore receiver', 'message tally' to stack list menu
added 'find context', 'next context' to process list menu
added 'change priority' and 'debug' choices to process list menu

27 October mods by Bob Arning:

alters process display in Ned's ProcessBrowser to 
- show process priority
- drop 'a Process in' that appears on each line
- show in priority order
- prettier names for known processes
- fix to Utilities to forget update downloading process when it ends (1 less dead
process)
- correct stack dump for the active process
!
!ProcessBrowser methodsFor: 'stack list' stamp: ''!
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: 'accessing' stamp: ''!
text
	^methodText! !

!ProcessBrowser methodsFor: 'process actions' stamp: ''!
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: 'accessing' stamp: ''!
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: 'process list' stamp: ''!
inspectProcess
	selectedProcess inspect! !

!ProcessBrowser methodsFor: 'accessing' stamp: ''!
stackList
	^ stackList! !

!ProcessBrowser methodsFor: 'initialization' stamp: ''!
stopCPUWatcher

	CPUWatcher stopMonitoring.
	self updateProcessList.
	cpuWatcherMonitoring := false	"so a manual restart won't be killed later" ! !

!ProcessBrowser methodsFor: 'stack list' stamp: ''!
inspectContext
	selectedContext inspect! !

!ProcessBrowser methodsFor: 'accessing' stamp: ''!
processListIndex
	^ processListIndex! !

!ProcessBrowser methodsFor: 'updating' stamp: ''!
startAutoUpdate
	self isAutoUpdatingPaused ifTrue: [ ^autoUpdateProcess resume ].
	self isAutoUpdating
		ifFalse: [| delay | 
			delay := Delay forSeconds: 2.
			autoUpdateProcess := [[self hasView]
						whileTrue: [delay wait.
							deferredMessageRecipient ifNotNil: [
								deferredMessageRecipient defer: [self updateProcessList]]
							ifNil: [ self updateProcessList ]].
					autoUpdateProcess := nil] fork].
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process list' stamp: ''!
exploreProcess
	selectedProcess inspect! !

!ProcessBrowser methodsFor: 'stack list' stamp: ''!
exploreContext
	selectedContext inspect! !

!ProcessBrowser methodsFor: 'initialization' stamp: ''!
mayBeStartCPUWatcher
	cpuWatcherMonitoring ifTrue: [ self setUpdateCallbackAfter: 7 ]
! !

!ProcessBrowser methodsFor: 'updating' stamp: ''!
pauseAutoUpdate
	self isAutoUpdating
		ifTrue: [ autoUpdateProcess suspend ].
	self updateProcessList! !

!ProcessBrowser methodsFor: 'accessing' stamp: ''!
deferredMessageRecipient: anObject
	deferredMessageRecipient := anObject! !

!ProcessBrowser methodsFor: 'initialization' stamp: ''!
ensureCPUWatcherMonitoring

	self startCPUWatcher.
	^ true! !

!ProcessBrowser methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self class registerWellKnownProcesses.
	methodText := ''.
	stackListIndex := 0.
	searchString := ''.
	lastUpdate := 0.
	textModel :=  RubScrolledTextModel new interactionModel: self; yourself.
	cpuWatcherMonitoring := CPUWatcher cpuWatcherEnabled and: [ self ensureCPUWatcherMonitoring ].
	self updateProcessList; processListIndex: 1! !

!ProcessBrowser methodsFor: 'accessing' stamp: ''!
processList
	^ processList! !

!ProcessBrowser methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass
	^self doItReceiver class! !

!ProcessBrowser methodsFor: 'updating' stamp: ''!
shoutAboutToStyle: aPluggableShoutMorphOrView

	selectedContext ifNil: [^false].
	aPluggableShoutMorphOrView classOrMetaClass: self selectedClass.
	^ true
! !

!ProcessBrowser methodsFor: 'process actions' stamp: ''!
suspendProcess
	| nameAndRules |
	selectedProcess isSuspended
		ifTrue: [^ self].
	nameAndRules := self nameAndRulesForSelectedProcess.
	nameAndRules second
		ifFalse: [self inform: 'Nope, won''t suspend ' , nameAndRules first.
			^ self].
	self class suspendProcess: selectedProcess.
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process list' stamp: ''!
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: 'initialization' stamp: ''!
windowIsClosing

	cpuWatcherMonitoring ifTrue: [ CPUWatcher stopMonitoring ]! !

!ProcessBrowser methodsFor: 'process list' stamp: ''!
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 actions' stamp: ''!
wasProcessSuspendedByProcessBrowser: aProcess
	^self class suspendedProcesses includesKey: aProcess! !

!ProcessBrowser methodsFor: 'process list' stamp: ''!
processListKey: aKey from: aView 
	self perform: (self keyEventsDict at: aKey ifAbsent: [ ^ self ])! !

!ProcessBrowser methodsFor: 'views' stamp: ''!
hasView
	^self dependents isEmptyOrNil not! !

!ProcessBrowser methodsFor: 'process actions' stamp: ''!
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: 'accessing' stamp: ''!
stackListIndex: index 
	stackListIndex := index.
	selectedContext := (stackList notNil
						and: [index > 0]) ifTrue:
							[stackList at: index ifAbsent: []].
	selectedClass := nil.
	selectedSelector := nil.
	methodText := nil.
	textModel setText: self methodText! !

!ProcessBrowser methodsFor: 'process list' stamp: ''!
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: 'menu' stamp: ''!
menuStackList: aMenuMorph
	
	aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Inspect context')
		keyText: 'c';
		selector: #inspectContext;
		target: self;
		yourself).
		
	aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Explore context')
		keyText: 'C';
		selector: #exploreContext;
		target: self;
		yourself).
		
	aMenuMorph addMenuItem: MenuLineMorph new.
		
	aMenuMorph addMenuItem:((ToggleMenuItemMorph new contents: #'Explore context')
		keyText: 'C';
		selector: #exploreContext;
		target: self;
		yourself).
		
		
	aMenuMorph addMenuItem:((ToggleMenuItemMorph new contents: #'Inspect receiver')
		keyText: 'i';
		selector: #inspectReceiver;
		target: self;
		yourself).

	aMenuMorph addMenuItem:((ToggleMenuItemMorph new contents: #'Explore receiver')
		keyText: 'I';
		selector: #exploreReceiver;
		target: self;
		yourself).

	aMenuMorph addMenuItem: MenuLineMorph new.
		
	aMenuMorph addMenuItem:((ToggleMenuItemMorph new contents: #'Browse')
		keyText: 'b';
		selector: #browseContext;
		target: self;
		yourself).! !

!ProcessBrowser methodsFor: 'process list' stamp: ''!
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' stamp: ''!
prettyNameForProcess: aProcess 
	| nameAndRules |
	aProcess ifNil: [ ^'<nil>' ].
	nameAndRules := self nameAndRulesFor: aProcess.
	^ aProcess browserPrintStringWith: nameAndRules first! !

!ProcessBrowser methodsFor: 'stack list' stamp: ''!
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: 'accessing' stamp: ''!
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: 'process actions' stamp: ''!
inspectPointers
	| tc pointers |
	selectedProcess ifNil: [ ^ self ].
	tc := thisContext.
	pointers := selectedProcess pointersToExcept: { self processList. tc. self}.
	pointers ifEmpty: [ ^ self ].
	pointers inspectWithLabel: 'Objects pointing to ' , selectedProcess browserPrintString! !

!ProcessBrowser methodsFor: 'process actions' stamp: ''!
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: 'stack list' stamp: ''!
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 pcRangeContextIsActive: (stackListIndex = 1)! !

!ProcessBrowser methodsFor: 'accessing' stamp: ''!
methodText
	^ methodText ifNil: [methodText := selectedContext
						ifNil: ['']
						ifNotNil: [| pcRange | 
							methodText := [ selectedContext sourceCode ]
								onErrorDo: [ 'error getting method text' ].
							pcRange := self pcRange.
							methodText asText
								addAttribute: TextColor red
								from: pcRange first
								to: pcRange last;
								addAttribute: TextEmphasis bold
								from: pcRange first
								to: pcRange last]]! !

!ProcessBrowser methodsFor: 'updating' stamp: ''!
stopAutoUpdate
	autoUpdateProcess ifNotNil: [
		autoUpdateProcess terminate.
		autoUpdateProcess := nil].
	self updateProcessList! !

!ProcessBrowser methodsFor: 'stack list' stamp: ''!
updateStackList
	self updateStackList: 20! !

!ProcessBrowser methodsFor: 'process actions' stamp: ''!
resumeProcess
	selectedProcess
		ifNil: [^ self].
	self class resumeProcess: selectedProcess.
	self updateProcessList! !

!ProcessBrowser methodsFor: 'accessing' stamp: ''!
doItReceiver
	^selectedContext ifNil: [ selectedProcess ] ifNotNil: [ selectedContext receiver ]! !

!ProcessBrowser methodsFor: 'views' stamp: ''!
browsedEnvironment

	^ Smalltalk globals! !

!ProcessBrowser methodsFor: 'stack list' stamp: ''!
stackNameList
	^ stackList
		ifNil: [#()]
		ifNotNil: [stackList collect: [:each | each asString]]! !

!ProcessBrowser methodsFor: 'stack list' stamp: ''!
stackListMenu: aMenu 
	selectedContext ifNil: [^ aMenu].
	self menuStackList: aMenu.
	^ aMenu! !

!ProcessBrowser methodsFor: 'process actions' stamp: ''!
debugProcess
	| nameAndRules |
	nameAndRules := self nameAndRulesForSelectedProcess.
	nameAndRules third
		ifFalse: [self inform: 'Nope, won''t debug ' , nameAndRules first.
			^ self].
	self class debugProcess: selectedProcess.! !

!ProcessBrowser methodsFor: 'stack list' stamp: ''!
changeStackListTo: aCollection 

        stackList := aCollection.
        self changed: #stackNameList.
        self stackListIndex: 0.
	textModel setText: self methodText. ! !

!ProcessBrowser methodsFor: 'views' stamp: ''!
build
	| window  scrolledText |
	window := (SystemWindow labelled: 'later') model: self.
	self deferredMessageRecipient: WorldState.
	window
		addMorph: ((PluggableListMorph
				on: self
				list: #processNameList
				selected: #processListIndex
				changeSelected: #processListIndex:
				menu: #menuProcessList:
				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).
		
	textModel setText: self methodText.
	textModel clearUserEdits.
	scrolledText := textModel newScrolledText beForSmalltalkCode; yourself.
	window
		addMorph:  scrolledText
		frame: (0 @ 0.5 corner: 1 @ 1).
	window setUpdatablePanesFrom: #(#processNameList #stackNameList ).
	(window setLabel: 'Process Browser') openInWorld.
	self mayBeStartCPUWatcher.
	^ window! !

!ProcessBrowser methodsFor: 'initialization' stamp: ''!
startCPUWatcher

	CPUWatcher isMonitoring ifTrue: [ ^ self ].

	CPUWatcher startMonitoringPeriod: 5 rate: 100 threshold: 0.85.
	self setUpdateCallbackAfter: 7! !

!ProcessBrowser methodsFor: 'process actions' stamp: ''!
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: 'updating' stamp: ''!
isAutoUpdating
	^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended  not ]! !

!ProcessBrowser methodsFor: 'process actions' stamp: ''!
nameAndRulesForSelectedProcess
	"Answer a nickname and two flags: allow-stop, and allow-debug"
	^self nameAndRulesFor: selectedProcess! !

!ProcessBrowser methodsFor: 'accessing' stamp: ''!
selectedMethod
	^selectedContext ifNotNil: [ selectedContext method ]! !

!ProcessBrowser methodsFor: 'views' stamp: ''!
stackListKey: aKey from: aView 
	aKey = $c ifTrue: [ self inspectContext].
	aKey = $C ifTrue: [ self exploreContext].
	aKey = $i ifTrue: [ self inspectReceiver].
	aKey = $I ifTrue: [ self exploreReceiver].
	aKey = $b ifTrue: [ self browseContext].

! !

!ProcessBrowser methodsFor: 'accessing' stamp: ''!
doItContext
	^selectedContext! !

!ProcessBrowser methodsFor: 'updating' stamp: ''!
isAutoUpdatingPaused
	^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended ]! !

!ProcessBrowser methodsFor: 'updating' stamp: ''!
toggleAutoUpdate
	self isAutoUpdating
		ifTrue: [ self stopAutoUpdate ]
		ifFalse: [ self startAutoUpdate ]
! !

!ProcessBrowser methodsFor: 'stack list' stamp: ''!
browseContext
	selectedContext ifNil: [ ^ self ]. 
	Smalltalk tools browser openOnClass: self selectedClass selector: self selectedSelector! !

!ProcessBrowser methodsFor: 'process list' stamp: ''!
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: ''!
exploreReceiver
	selectedContext ifNotNil: [ selectedContext receiver inspect ]! !

!ProcessBrowser methodsFor: 'menu' stamp: ''!
menuProcessList: aMenuMorph
	
	selectedProcess
		ifNotNil: [ 
			| nameAndRules |
			nameAndRules := self nameAndRulesForSelectedProcess.
			aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Inspect')
				keyText: 'i';
				selector: #inspectProcess;
				target: self;
				yourself).
			aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Explore')
				keyText: 'I';
				selector: #exploreProcess;
				target: self;
				yourself).
			aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Inspect Pointers')
				keyText: 'P';
				selector: #inspectPointers;
				target: self;
				yourself).
			(Smalltalk globals includesKey: #PointerExplorer)
				ifTrue: [ 
					aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Explore pointers')
						keyText: 'e';
						selector: #explorePointers;
						target: self;
						yourself). ].
					
			nameAndRules second
				ifTrue: [ 
					aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Terminate')
						keyText: 't';
						selector: #terminateProcess;
						target: self;
						yourself).

					selectedProcess isSuspended
						ifTrue: [ 
							aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Resume')
								keyText: 'r';
								selector: #resumeProcess;
								target: self;
								yourself). ]
						ifFalse: [ 
							aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Suspend')
								keyText: 's';
								selector: #suspendProcess;
								target: self;
								yourself). ] ].
			
			nameAndRules third
				ifTrue: [ 
					aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Change priority')
						keyText: 'p';
						selector: #changePriority;
						target: self;
						yourself).
					aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Debug')
						keyText: 'd';
						selector: #debugProcess;
						target: self;
						yourself) ].
			
			aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Profile messages')
				keyText: 'm';
				selector: #messageTally;
				target: self;
				yourself).

			(selectedProcess suspendingList isKindOf: Semaphore)
				ifTrue: [ 
					aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Signal Semaphore')
						keyText: 'S';
						selector: #signalSemaphore;
						target: self;
						yourself). ].
					
			aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Full stack')
				keyText: 'k';
				selector: #moreStack;
				target: self;
				yourself). 
			
			aMenuMorph addMenuItem: (MenuLineMorph new)].

	aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Find context...')
		keyText: 'f';
		selector: #findContext;
		target: self;
		yourself).
	aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Find again')
		keyText: 'g';
		selector: #nextContext;
		target: self;
		yourself).

	aMenuMorph addMenuItem: (MenuLineMorph new).
		
	aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: (self isAutoUpdating
			ifTrue: [ #'Turn off auto-update' ]
			ifFalse: [ #'Turn on auto-update' ]))
		keyText: 'a';
		selector: #toggleAutoUpdate;
		target: self;
		yourself).

	aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Update list')
		keyText: 'u';
		selector: #updateProcessList;
		target: self;
		yourself).

	Smalltalk globals 
		at: #CPUWatcher 
		ifPresent: [ :pw | 
			aMenuMorph addMenuItem: (MenuLineMorph new).
			pw isMonitoring
				ifTrue: [ 
					aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Stop CPUWatcher')
						selector: #stopCPUWatcher;
						target: self;
						yourself) ]
				ifFalse: [ 
					aMenuMorph addMenuItem: ((ToggleMenuItemMorph new contents: #'Start CPUWatcher')
						selector: #startCPUWatcher;
						target: self;
						yourself) ] ].
				
	^ aMenuMorph! !

!ProcessBrowser methodsFor: 'stack list' stamp: ''!
inspectReceiver
	selectedContext
		ifNotNil: [selectedContext receiver inspect]! !

!ProcessBrowser methodsFor: 'updating' stamp: ''!
setUpdateCallbackAfter: seconds
	deferredMessageRecipient
		ifNotNil: [ 
			| d |
			d := Delay forSeconds: seconds.
			[ d wait.
			d := nil. 
			deferredMessageRecipient defer: [ self updateProcessList ] ] fork ]! !

!ProcessBrowser methodsFor: 'stack list' stamp: ''!
moreStack
	self updateStackList: 2000! !

!ProcessBrowser methodsFor: 'process actions' stamp: ''!
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: 'accessing' stamp: ''!
processListIndex: index 
	processListIndex := index.
	selectedProcess := processList
				at: index
				ifAbsent: [].
	self updateStackList.
	self changed: #processListIndex.! !

!ProcessBrowser methodsFor: 'accessing' stamp: ''!
stackListIndex
	^ stackListIndex! !

!ProcessBrowser methodsFor: 'process list' stamp: ''!
processNameList
	"since processList is a WeakArray, we have to strengthen the result"
	| tally |
	tally := CPUWatcher ifNotNil: [ CPUWatcher current ifNotNil: [ CPUWatcher 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: 'accessing' stamp: ''!
selectedProcess
	^selectedProcess! !

!ProcessBrowser class methodsFor: 'process control' stamp: ''!
debugProcess: aProcess
	self resumeProcess: aProcess.
	aProcess debugWithTitle: 'Interrupted from the Process Browser'.
! !

!ProcessBrowser class methodsFor: 'settings' stamp: ''!
processBrowserSettingsOn: aBuilder

	<systemsettings>
	(aBuilder group: #processBrowser)
		label: 'Process browser';
		parent: #tools;
		description: 'Process browser settings';
		with: [ 
			(aBuilder setting: #cpuWatcherEnabled)
				label: 'Process browser monitors CPU usage';
				target: CPUWatcher;
				default: false;
				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' .
				
			(aBuilder setting: #pigFinding)
				label: 'Find the most CPU demanding processes';
				target: CPUWatcher;
				default: false;
				description: 'Try to identify CPU demanding processes during CPU monitoring and offer their termination'  ]! !

!ProcessBrowser class methodsFor: 'class initialization' stamp: ''!
initialize
	SuspendedProcesses ifNil: [ SuspendedProcesses := IdentityDictionary new ].
	self registerWellKnownProcesses! !

!ProcessBrowser class methodsFor: 'CPU utilization' stamp: ''!
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: 'instance creation' stamp: ''!
open
	"Create and schedule a ProcessBrowser."
	<script>
	
	Smalltalk garbageCollect.
	^ self new build! !

!ProcessBrowser class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#processBrowserIcon! !

!ProcessBrowser class methodsFor: 'process control' stamp: ''!
unregisterWellKnownProcess: aProcess
	"Remove the first registry entry that matches aProcess. Use
	with caution if more than one registry entry may match aProcess."

	"self unregisterWellKnownProcess: Smalltalk lowSpaceWatcherProcess"

	WellKnownProcesses detect: [ :e | e key value == aProcess ] ifFound: [ :entry | WellKnownProcesses remove: entry ]! !

!ProcessBrowser class methodsFor: 'process control' stamp: ''!
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: 'private - initialization' stamp: ''!
registerWellKnownProcesses
	"Associate each well-known process with a nickname and two flags: allow-stop, and allow-debug.
	Additional processes may be added to this list as required"

	WellKnownProcesses := OrderedCollection new.
	self
		registerWellKnownProcess: [  ]
		label: 'no process'
		allowStop: false
		allowDebug: false.
	self
		registerWellKnownProcess: [ Smalltalk lowSpaceWatcherProcess ]
		label: nil
		allowStop: false
		allowDebug: false.
	self
		registerWellKnownProcess: [ WeakArray runningFinalizationProcess ]
		label: nil
		allowStop: false
		allowDebug: false.
	self
		registerWellKnownProcess: [ Processor backgroundProcess ]
		label: nil
		allowStop: false
		allowDebug: false.
	self
		registerWellKnownProcess: [ UIManager default uiProcess ]
		label: nil
		allowStop: false
		allowDebug: false.
	self
		registerWellKnownProcess: [ Smalltalk globals at: #CPUWatcher ifPresent: [ :cw | cw currentWatcherProcess ] ]
		label: 'the CPUWatcher'
		allowStop: false
		allowDebug: false.
		
	self
		registerWellKnownProcess: [ Delay schedulingProcess ]
		label: nil
		allowStop: false
		allowDebug: false! !

!ProcessBrowser class methodsFor: 'process control' stamp: ''!
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: 'CPU utilization' stamp: ''!
tallyCPUUsageFor: seconds every: msec
	"Compute CPU usage using a msec millisecond sample for the given number of seconds,
	then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile"
	"ProcessBrowser tallyCPUUsageFor: 10 every: 100"

	| promise |
	promise := Processor tallyCPUUsageFor: seconds every: msec.

	[ | tally |
		tally := promise value.
		UIManager default defer: [ self dumpTallyOnTranscript: tally ].
	] fork.! !

!ProcessBrowser class methodsFor: 'process control' stamp: ''!
wasProcessSuspendedByProcessBrowser: aProcess
	^self suspendedProcesses includesKey: aProcess! !

!ProcessBrowser class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]" 
	registry register: self as: #processBrowser
! !

!ProcessBrowser class methodsFor: 'process control' stamp: ''!
terminateProcess: aProcess
	aProcess ifNotNil: [
		self suspendedProcesses
			removeKey: aProcess
			ifAbsent: [].
		aProcess terminate
	]
! !

!ProcessBrowser class methodsFor: 'CPU utilization' stamp: ''!
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: 'world menu' stamp: ''!
menuCommandOn: aBuilder 
	<worldMenu> 
	(aBuilder item: #'Process Browser')
		parent: #SystemTools;
		order: 3;
		action:[ self open ];
		help: 'Provides a view of all of the processes (threads) executing in Smalltalk.';
		icon: self taskbarIcon! !

!ProcessBrowser class methodsFor: 'process control' stamp: ''!
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: 'CPU utilization' stamp: ''!
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: 'process control' stamp: ''!
nameAndRulesFor: aProcess 
	"Answer a nickname and two flags: allow-stop, and allow-debug"
	| rules |
	rules := {nil. true. true}.
	WellKnownProcesses do: [:blockAndRules |
		blockAndRules key value == aProcess 
			ifTrue: [ rules := blockAndRules value value ]].
	rules first ifNil: [ 
		rules at: 1 put: aProcess suspendedContext asString ].
	^ rules! !

!ProcessBrowser class methodsFor: 'process control' stamp: ''!
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: ''!
isUIProcess: aProcess
	^ aProcess == UIManager default uiProcess! !

!ProcessBrowser class methodsFor: 'process control' stamp: ''!
resumeProcess: aProcess
	| priority |
	priority := self suspendedProcesses
				removeKey: aProcess
				ifAbsent: [aProcess priority].
	aProcess priority: priority.
	aProcess suspendedContext ifNotNil: [ aProcess resume ]
! !

!ProcessBrowser class methodsFor: 'class initialization' stamp: ''!
cleanUp
 	"Remove terminated processes from my suspended list"
	<script>
	
	self suspendedProcesses keysDo: [:ea |
		ea isTerminated ifTrue: [self suspendedProcesses removeKey: ea]]! !

!ProcessBrowser class methodsFor: 'CPU utilization' stamp: ''!
dumpPigStackOn: aStream
	"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]].! !

!ProcessList commentStamp: ''!
I am a VM Special class!! Do not break me!!

I am a linked list that contains processes as Nodes. My implementation is tied to the VM: 
- every node I contain should have as first instance variable the next node in the list.

My main user is ProcessScheduler, which contains an array with instances of myself. Each entry in that array a priority for processes. Processes are queues in each process list by the VM automatically.!
!ProcessList methodsFor: 'testing' stamp: ''!
isEmpty

	^firstLink isNil! !

!ProcessList methodsFor: 'private' stamp: ''!
linkAt: index ifAbsent: errorBlock

	| i |
	i := 0.
	self linksDo: [:link |
		(i := i + 1) = index ifTrue: [^ link]].
	^ errorBlock value! !

!ProcessList methodsFor: 'adding' stamp: ''!
add: aLinkOrObject
	"Add aLink to the end of the receiver's list. Answer aLink."

	^self addLast: aLinkOrObject! !

!ProcessList methodsFor: 'removing' stamp: ''!
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! !

!ProcessList methodsFor: 'adding' stamp: ''!
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.! !

!ProcessList methodsFor: 'enumerating' stamp: ''!
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! !

!ProcessList methodsFor: 'enumerating' stamp: ''!
linksDo: aBlock

	| aLink |
	aLink := firstLink.
	[aLink == nil ] whileFalse:
		[
		aBlock value: aLink.
		aLink := aLink nextLink]! !

!ProcessList methodsFor: 'copying' stamp: ''!
copyWithout: oldElement
	|newInst| 
	newInst := self class new.
	self do: [:each | each = oldElement ifFalse: [newInst add: each]].
	^newInst! !

!ProcessList methodsFor: 'removing' stamp: ''!
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]]! !

!ProcessList methodsFor: 'removing' stamp: ''!
removeLink: aLink
	^self removeLink: aLink ifAbsent: [self error: 'no such method!!']! !

!ProcessList methodsFor: 'enumerating' stamp: ''!
species

	^ Array! !

!ProcessList methodsFor: 'adding' stamp: ''!
add: link before: otherLinkOrObject
	"Add otherLink  after link in the list. Answer aLink."

	| otherLink |
	otherLink := self linkAt: (self indexOf: otherLinkOrObject).
	^ self add: link beforeLink: otherLink! !

!ProcessList methodsFor: 'enumerating' stamp: ''!
collect: collectBlock thenSelect: selectBlock
	"Optimized version of SequenceableCollection>>#collect:#thenSelect:"

	| newCollection newElement |
	newCollection := self class new.
	self
		do: [ :each | 
			newElement := collectBlock value: each.
			(selectBlock value: newElement)
				ifTrue: [ newCollection add: newElement ] ].
	^ newCollection! !

!ProcessList methodsFor: 'accessing' stamp: ''!
at: index

	^(self linkAt: index) value! !

!ProcessList methodsFor: 'private' stamp: ''!
indexOf: anElement startingAt: start ifAbsent: exceptionBlock
	"Answer the index of the first occurrence 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! !

!ProcessList methodsFor: 'enumerating' stamp: ''!
do: aBlock

	| aLink |
	aLink := firstLink.
	[aLink == nil] whileFalse:
		[aBlock value: aLink value.
		 aLink := aLink nextLink]! !

!ProcessList methodsFor: 'accessing' stamp: ''!
first
	"Answer the first link. Create an error notification if the receiver is 
	empty."
^self firstLink value! !

!ProcessList methodsFor: 'accessing' stamp: ''!
last
	"Answer the last link. Create an error notification if the receiver is 
	empty."


	^self lastLink value! !

!ProcessList methodsFor: 'private' stamp: ''!
linkOf: anObject 
	^ self
		linkOf: anObject
		ifAbsent: [self error: 'No such element']! !

!ProcessList methodsFor: 'private' stamp: ''!
linkOf: anObject ifAbsent: errorBlock 
	
	self
		linksDo: [:el | el value = anObject
				ifTrue: [^ el]].
	^ errorBlock value! !

!ProcessList methodsFor: 'removing' stamp: ''!
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! !

!ProcessList methodsFor: 'enumerating' stamp: ''!
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! !

!ProcessList methodsFor: 'removing' stamp: ''!
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! !

!ProcessList methodsFor: 'adding' stamp: ''!
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! !

!ProcessList methodsFor: 'accessing' stamp: ''!
lastLink
	"Answer the last link. Create an error notification if the receiver is 
	empty."

	self emptyCheck.
	^lastLink! !

!ProcessList methodsFor: 'enumerating' stamp: ''!
select: selectBlock thenCollect: collectBlock
	"Optimized version of SequenceableCollection>>#select:thenCollect:"

	| newCollection |
	newCollection := self class new.
	self
		do: [ :each | 
			(selectBlock value: each)
				ifTrue: [ newCollection add: (collectBlock value: each) ] ].
	^ newCollection! !

!ProcessList methodsFor: 'accessing' stamp: ''!
firstLink
	"Answer the first link. Create an error notification if the receiver is 
	empty."

	self emptyCheck.
	^firstLink! !

!ProcessList methodsFor: 'accessing' stamp: ''!
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.! !

!ProcessList methodsFor: 'adding' stamp: ''!
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! !

!ProcessList methodsFor: 'accessing' stamp: ''!
at: index put: anObject

	^self at: index putLink: (self linkOf: anObject ifAbsent: [anObject asLink])! !

!ProcessList methodsFor: 'accessing' stamp: ''!
at: index putLink: aLink 
	| previousLink nextLink |
	"Please don't put a link which is already in the list, or you will create an infinite loop"
	(self validIndex: index)
		ifFalse: [^ self errorOutOfBounds].
	index = 1
		ifTrue: [aLink nextLink: self firstLink nextLink.
			firstLink := aLink.
			aLink nextLink ifNil: [lastLink := aLink].
			^ aLink].
	previousLink := self linkAt: index - 1.
	nextLink := previousLink nextLink nextLink.
	
	nextLink ifNil: [
		aLink nextLink: self lastLink
	] ifNotNil: [
		aLink nextLink: nextLink.
	].

	previousLink nextLink: aLink.

	nextLink ifNil: [
		lastLink := aLink.
		aLink nextLink: nil.
	].

	^ aLink! !

!ProcessList methodsFor: 'adding' stamp: ''!
add: link after: otherLinkOrObject
	"Add otherLink  after link in the list. Answer aLink."

	| otherLink |
	otherLink := self linkAt: (self indexOf: otherLinkOrObject).
	^ self add: link afterLink: otherLink! !

!ProcessList methodsFor: 'adding' stamp: ''!
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! !

!ProcessList methodsFor: 'copying' stamp: ''!
postCopy
	| aLink |
	super postCopy.
	firstLink ifNotNil: [
		aLink := firstLink := firstLink copy.
		[aLink nextLink isNil] whileFalse: [aLink nextLink: (aLink := aLink nextLink copy)].
		lastLink := aLink].! !

!ProcessList methodsFor: 'copying' stamp: ''!
copyWith: newElement
	^self copy add: newElement; yourself! !

!ProcessList methodsFor: 'removing' stamp: ''!
removeAll
	"Implementation note: this has to be fast"

	firstLink := lastLink := nil! !

!ProcessList methodsFor: 'accessing' stamp: ''!
size
	"Answer how many elements the receiver contains."

	| tally |
	tally := 0.
	self do: [:each | tally := tally + 1].
	^ tally! !

!ProcessList methodsFor: 'private' stamp: ''!
linkAt: index

	^self linkAt: index ifAbsent: [ self errorSubscriptBounds: index]! !

!ProcessList methodsFor: 'private' stamp: ''!
validIndex: index
	 ^index > 0
			and: [index <= self size]! !

!ProcessList methodsFor: 'removing' stamp: ''!
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! !

!ProcessList class methodsFor: 'stream creation' stamp: ''!
new: size streamContents: aBlock
	^ self withAll: (super new: size streamContents: aBlock)! !

!ProcessList class methodsFor: 'instance creation' stamp: ''!
new: anInt
	"LinkedList don't need capacity"
	^self new! !

!ProcessList class methodsFor: 'accessing' stamp: ''!
streamSpecies
	^ Array! !

!ProcessList class methodsFor: 'instance creation' stamp: ''!
newFrom: aCollection
	"Answer an instance with same elements as aCollection."
	^self new
		addAll: aCollection;
		yourself! !

!ProcessLocalSlot commentStamp: ''!
A ProcessLocal is a slot that references different objects in different processes.

Internally it is implemented with a ProcessLocalVariable. Writing into the slot writes a field in the current process. 

myProcessLocalVariable value: anObject

Reading into the Slot reads the only field in the array.

myProcessLocalVariable value.

This slot inherits from IndexedSlot to guarantee that this slot has a real field inside an object.

This slot should be used wisely:

1) The value is stored weakly, an example of this would be:
obj := MyClass new.
obj local: Object new.
obj local. “anObject” <—— Now we see the object
Smalltalk garbageCollect.
obj local. “nil” <—— Now we don’t

2) This variable are stored in a WeakArray in the Process, so massive use of them will make the array in the processes start growing a lot and often.
!
!ProcessLocalSlot methodsFor: 'meta-object-protocol' stamp: ''!
wantsInitialization

	^ true! !

!ProcessLocalSlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject

	^ (super read: anObject) value.! !

!ProcessLocalSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject

	(super read: anObject) value: aValue.
	^ aValue! !

!ProcessLocalSlot methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	"Push the process local variable into the stack"
	aMethodBuilder pushInstVar: index.
	aMethodBuilder send: #value! !

!ProcessLocalSlot methodsFor: 'code generation' stamp: ''!
emitStore: aMethodBuilder
	"generate bytecode for 'varname value: <stackTop>'"
	| temp |
	temp := '0slotTempForStackManipulation'.
	"We pop the value from the stack into a temp to push it back in the right order"
	aMethodBuilder addTemp: temp.
	aMethodBuilder storeTemp: temp.
	aMethodBuilder popTop.
	
	"Push the process local variable into the stack, then the value again, then send"
	aMethodBuilder pushInstVar: index.
	aMethodBuilder pushTemp: temp.
	aMethodBuilder send: #value:! !

!ProcessLocalSlot methodsFor: 'initialization' stamp: ''!
initialize: anObject
	super write: ProcessLocalVariable new to: anObject! !

!ProcessLocalSlotTest methodsFor: 'tests' stamp: ''!
testWriteAndReadCompiled
	| slot object |
	slot := #slot1 => ProcessLocalSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].
	object := aClass new.
	
	"now compile an accessor and read/write"
	self compileAccessorsFor: slot.
	self assert: object slot1 equals: nil.
	object slot1: 3.
	self assert: object slot1 equals: 3.
	"inside another process it it nil"
	[ self assert: object slot1 equals: nil. ] fork.
	self assert: object slot1 equals: 3! !

!ProcessLocalSlotTest methodsFor: 'tests' stamp: ''!
testWriteAndReadReflective
	| slot object |
	slot := #slot1 => ProcessLocalSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].
	object := aClass new.
	"now do reflective read and write"
	self assert: (slot read: object) equals: nil.
	slot write: 3 to: object.
	self assert: (slot read: object) equals: 3.
	"inside another process it it nil"
	[ self assert: (slot read: object) equals: nil. ] fork.
	self assert: (slot read: object) equals: 3! !

!ProcessLocalSlotTest methodsFor: 'tests' stamp: ''!
testIsPossibleToSetSlotInBlock
	| slot writerString instance |
	slot := #slot1 => ProcessLocalSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	writerString := String streamContents: [ :str |
		str 
			nextPutAll: slot name;
			nextPutAll: ': anObject';
			cr;tab;
			nextPutAll: 'true ifTrue: [ ';
			nextPutAll: slot name;
			nextPutAll: ':= anObject ]'.
		].
	
	aClass compile: writerString.
	
	instance := aClass new.
	instance slot1: #test.
	self assert: (instance instVarNamed: #slot1) value equals: #test! !

!ProcessLocalSlotTest methodsFor: 'tests' stamp: ''!
testRead
	| slot |
	slot := #slot1 => ProcessLocalSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	"now compile an accessor and read"
	self compileAccessorsFor: slot.
	self assert: aClass new slot1 equals: nil.
	
	"test refelective read"
	self assert: (slot read: aClass new) equals: nil! !

!ProcessLocalVariable commentStamp: ''!
My subclasses have values specific to the active process. They can be read with #value and set with #value:!
!ProcessLocalVariable methodsFor: 'evaluating' stamp: ''!
value: anObject
	Processor activeProcess psValueAt: index put: anObject! !

!ProcessLocalVariable class methodsFor: 'accessing' stamp: ''!
value: anObject
	^ self soleInstance value: anObject! !

!ProcessMonitorTestService commentStamp: ''!
I monitor all processes forked during tests and track all exceptions signaled from them.

1) The main goal is to ensure that if there was an error from the background process the test will never be green. 
For example I make following test fail:

	testExample
		[ 1/0 ] fork.
		self assert: true.

TestFailedByForkedProcess will be signaled at the end of such test. And if user will debug this test then two debuggers will be opened for each error (for main and background processes).
		
2) The second my purpose is to ensure that no running processes will be left after the test.
The background process can be more tricky than example and it can be forked by domain code.
Out of the test such processes could affect the overall system behavior. 
They could affect other tests results. If they fail during other tests it will hide the fact that the issue is related to the original test which will make debugging hard.

So at the end of every test I perform a cleanup (#cleanUpAfterTest) where I terminate all running processes. This behavior can be disabled globaly in settings (System/SUnit) or in test method and setUp:

	self executionProcessMonitor disableProcessTermination 
	
To enable it use: 

	self executionProcessMonitor terminateProcessesAfterTest

In addition I implement special logic to fail the test which left running processes after run.
So the process termination is not hidden. 
For example following test will fail:

	testExample
		[ 10 seconds wait ] fork.
		self assert: true.

TestLeftRunningProcess will be signaled at the end of test.
For compatibility this feature is disabled by default. And this test would not fail. But it can be enabled globaly in settings (System/SUnit) or in test and setUp:	 

	self executionProcessMonitor failTestLeavingProcesses.

And to disable it use: 

	self executionProcessMonitor allowTestToLeaveProcesses.

3) I can be completely disabled globaly in settings (System/SUnit) or in test and setUp:

	self executionProcessMonitor disable 
	 
Finally at the end of every test I perform a cleanup (#cleanUpAfterTest) where I restore all my default settings. So the next test will be started with default behaviour.

Implementation details:

1. Background failures

I am a kind of TestExecutionService and therefore I intercept all processes forked during the test (#handleNewProcess:).
I set up default exception handler for them to catch all unhandled exceptions. UnhandledException's are supposed to open a debugger at the end of processing. I postpone this logic by suspending the failing process. So when error is signaled from the background process no debugger will be opened immediately.
At the end of test (#handleCompletedTest) I check all suspended failures and if they exist I fail the test with TestFailedByForkedProcess signal.
In interactive mode when user debugs the test I pass all suspended failures together with this signal. So multiple debuggers will be opened to show each error.

The interactive scenario is detected using UnhandledException logic: unhandled error from the main test process or halt from anywhere mean the "debugger fallback" and therefore it is a good time to show the rest of failures from other processes. So in that case I pass all suspended failures to debug all of them together.

2. Failing strategy for left processes

I collect all forked processes (#forkedProcesses) and at the end of tests I have an option (#shouldFailTestLeavingProcesses) to fail the test if these processes are still running. TestLeftRunningProcess would be a final error for the test in that case.
I implement a little logic to make this failing strategy more usable and not break the test in trivial cases. For eaxmple following pattern is quite common in tests: 

	testExample 
		[ "some work here". Processor yield ] fork.
		Processor yield.
		self assert: true.

The #yield's here are to describe what could happen in real world: processes can be preemted at any time due to various activities from other image processes (with different priorities). And a simple #fork in tests like this one will not be able to terminate at the end of test while it is "almost done".
The method #allowRunningProcessesToFinish is to solve this issue. It performs own "Processor yield" logic to allow such background processes to take a control and finish the execution. 

3. One more detail: 
In uninteractive mode I signal TestFailedByForkedProcess even if there was a domain error from the test. So two exceptions can be signaled for single test run.
It allows to log all errors signaled during the test: one from the main process and others from all background processes using this signal (notice that I suspend all background failures and they do not log themselves as a default feedback).

Internal Representation and Key Implementation Points.

    Instance Variables
	forkedProcesses:		<OrderedCollection<Process>>
	testFailures:		<OrderedIdentityDictionary<Process, Exception>>
	shouldFailTestLeavingProcesses:		<Boolean>
	shouldSuspendBackgroundFailures:		<Boolean>!
!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
forkedProcesses
	^ forkedProcesses! !

!ProcessMonitorTestService methodsFor: 'testing' stamp: ''!
shouldPassBackgroundFailures
	^shouldSuspendBackgroundFailures not! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
terminateProcessesAfterTest

	shouldTerminateProcesses := true! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
testFailures
	^ testFailures! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
ensureNoBackgroundFailures
	self isMainTestProcessFailed & self shouldPassBackgroundFailures ifTrue: [ 
		"We don't need extra error about failed process when all errors are shown to the user: 
			- if they were not suspended and were passed
			- if main test process is also fail (and therefore test fails anyway)"
		^self ].
	self suspendedBackgroundFailures ifEmpty: [ ^self ].

	"COMMENT FOR DEBUGGER STOPPED HERE:
	TestFailedByForkedProcess notifies about background failures.
	Test failed because forked process failed (even if main test process was completed without errors).
	See ProcessMonitorTestService comment for more details"
	[TestFailedByForkedProcess signalFrom: executionEnvironment] 
		on: UnhandledError do: [ :e | 
			self passBackgroundFailures.
			e pass]! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
recordTestFailure: anException

	| activeProcess |
	activeProcess := Processor activeProcess.
	activeProcess isTerminating ifTrue: [ 
		"Do nothing for exceptions during process termination"
		^self ]. 
	
	testFailures at: activeProcess put: anException! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
shouldFailTestLeavingProcesses
	^ shouldFailTestLeavingProcesses! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
disableProcessesTermination

	shouldTerminateProcesses := false! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
suspendBackgroundFailure: anException

	| activeProcess |
	activeProcess := Processor activeProcess.
	activeProcess isTerminating ifTrue: [ 
		"Do nothing if process is under termination"
		^self ]. 
	
	self recordTestFailure: anException.
	activeProcess suspend! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
enableBackgroudFailuresSuspension

	shouldSuspendBackgroundFailures := true! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
handleBackgroundException: anUnhandledException
	
	self handleException: anUnhandledException.
	
	anUnhandledException pass! !

!ProcessMonitorTestService methodsFor: 'testing' stamp: ''!
isTestProcessFailed: aProcess

	^testFailures at: aProcess ifPresent: [ true ] ifAbsent: [ false ]! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
allowRunningProcessesToFinish
	"The idea here is to allow most trivial processes to finish themselves.
	So they would not be a garbage left by test.
	For example following test would left one process at the end:
		>>testExample
			[ Processor yield ] fork 
	But if we would give it a chance to finish it would do this. 
	So in this method we give running processes a chance to finish:
		- yield execution until number of rest processes are reduced"
	| runningProcesses restProcesses |
	runningProcesses := self runningProcesses.
	runningProcesses ifEmpty: [ ^self ].
	(runningProcesses allSatisfy: [ :each | each priority = Processor activePriority ]) ifFalse: [ 
			"If there is any process with different priority than active one 
			we can't do anything to allow finish all of them"
			^self ].
	
	[Processor yield.
	restProcesses := runningProcesses reject: [ :each | each isTerminated ].
	restProcesses size = runningProcesses size or: [ restProcesses isEmpty ]] 
		whileFalse: [ runningProcesses := restProcesses ]! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
shouldSuspendBackgroundFailures
	^ shouldSuspendBackgroundFailures! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
shouldTerminateProcesses
	^ shouldTerminateProcesses! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
handleNewProcess: aProcess
	super handleNewProcess: aProcess.
	
	forkedProcesses add: aProcess.
	
	aProcess on: UnhandledException do: [ :err |
		self handleBackgroundException: err]! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
handleUnhandledException: anUnhandledException
	self recordTestFailure: anUnhandledException.
	
	executionEnvironment isMainTestProcessActive ifTrue: [ ^self passBackgroundFailures ].
	
	shouldSuspendBackgroundFailures ifTrue: [
		self suspendBackgroundFailure: anUnhandledException]! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
failTestLeavingProcesses

	shouldFailTestLeavingProcesses := true! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
forkedProcesses: anObject
	forkedProcesses := anObject! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
handleException: anException
	super handleException: anException.
	
	anException manageTestProcessBy: self! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
handleCompletedTest
	super handleCompletedTest.
	
	self allowRunningProcessesToFinish.
	self ensureNoBackgroundFailures.
	self ensureNoRunningProcesses! !

!ProcessMonitorTestService methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	self enableBackgroudFailuresSuspension.
	self useDefaultFailingStrategyForRunningProcesses.
	self useDefaultTerminationStrategyForRunningProcesses.
	forkedProcesses := WeakSet new.
	testFailures := OrderedIdentityDictionary new.
	 ! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
shouldTerminateProcesses: anObject
	shouldTerminateProcesses := anObject! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
shouldFailTestLeavingProcesses: anObject
	shouldFailTestLeavingProcesses := anObject! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
passBackgroundFailures	
	self disableBackgroudFailuresSuspension.
	self disableProcessesTermination.
		
	testFailures keys 
		select: [:each | each isSuspended ] 
		thenDo: [:each | each resume ]! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
runningProcesses
	"Suspended processes are not scheduled and therefore they are not considered as running"
	^ forkedProcesses reject: [ :each | each isTerminated or: [ each isSuspended ]]! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
ensureNoRunningProcesses
	"If test was already failed due to an error in the main test process 
	we do not need an extra failure about left processes"
	self isMainTestProcessFailed ifTrue: [ ^self ].	
	self runningProcesses ifEmpty: [ ^self ].
	shouldFailTestLeavingProcesses ifFalse: [ ^self ].
	
	"COMMENT FOR DEBUGGER STOPPED HERE:
	TestLeftRunningProcess notifies that forked processes are still running when test completes.
	Test failed because test left the system in dirty state.
	Left running processes can affect the result of other tests 
	and even the general system behavior after test run.
	This protection can be disabled globaly in settings or in test method and setUp:
		self executionProcessMonitor allowTestToLeaveProcesses
	See ProcessMonitorTestService comment for more details"
	TestLeftRunningProcess signalFrom: executionEnvironment! !

!ProcessMonitorTestService methodsFor: 'initialization' stamp: ''!
useDefaultTerminationStrategyForRunningProcesses
	shouldTerminateProcesses := self class shouldTerminateProcesses! !

!ProcessMonitorTestService methodsFor: 'testing' stamp: ''!
isMainTestProcessFailed
	^self isTestProcessFailed: executionEnvironment mainTestProcess! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
suspendedBackgroundFailures
	^ testFailures associationsSelect: [ :each | each key isSuspended ]! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
terminateRunningProcesses
	forkedProcesses do: [:each | each terminate]! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
shouldSuspendBackgroundFailures: anObject
	shouldSuspendBackgroundFailures := anObject! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
testBackgroundFailures
	^ testFailures copy 
		removeKey: executionEnvironment mainTestProcess ifAbsent: [ ];
		yourself! !

!ProcessMonitorTestService methodsFor: 'controlling' stamp: ''!
cleanUpAfterTest
	super cleanUpAfterTest.
	
	shouldTerminateProcesses ifTrue: [ 
		self terminateRunningProcesses].
	forkedProcesses removeAll.
	testFailures removeAll.
	self enableBackgroudFailuresSuspension.
	self useDefaultFailingStrategyForRunningProcesses.
	self useDefaultTerminationStrategyForRunningProcesses ! !

!ProcessMonitorTestService methodsFor: 'initialization' stamp: ''!
useDefaultFailingStrategyForRunningProcesses

	shouldFailTestLeavingProcesses := self class shouldFailTestLeavingProcesses.
! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
disableBackgroudFailuresSuspension

	shouldSuspendBackgroundFailures := false! !

!ProcessMonitorTestService methodsFor: 'accessing' stamp: ''!
allowTestToLeaveProcesses

	shouldFailTestLeavingProcesses := false
! !

!ProcessMonitorTestService class methodsFor: 'accessing' stamp: ''!
shouldTerminateProcesses: anObject
	shouldTerminateProcesses := anObject! !

!ProcessMonitorTestService class methodsFor: 'accessing' stamp: ''!
shouldFailTestLeavingProcesses: aBoolean
	shouldFailTestLeavingProcesses := aBoolean! !

!ProcessMonitorTestService class methodsFor: 'accessing' stamp: ''!
shouldFailTestLeavingProcesses
	^shouldFailTestLeavingProcesses ifNil: [ shouldFailTestLeavingProcesses := false ]! !

!ProcessMonitorTestService class methodsFor: 'settings' stamp: ''!
settingsForTerminationStrategyOn: aBuilder
	
	(aBuilder setting: #shouldTerminateProcesses)
		target: self;
		parent: self name ;
		default: true;
		label: 'Terminate all processes after the test' ;
		description: 'At the end of each test all forked processes will be terminated except when we are running in interractive mode under debugger. 
When debugger opens all control is up to the user.
But when we are running the test suite to get results it is a good practice to remove all garbage after the test. 
This setting is about doing it in automatic way.
See ProcessMonitorTestService comment for more details'! !

!ProcessMonitorTestService class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	super settingsOn: aBuilder.
	
	self
		settingsForFailingStrategyOn: aBuilder;
		settingsForTerminationStrategyOn: aBuilder! !

!ProcessMonitorTestService class methodsFor: 'settings' stamp: ''!
settingsForFailingStrategyOn: aBuilder
	
	(aBuilder setting: #shouldFailTestLeavingProcesses)
		target: self;
		parent: self name ;
		default: false;
		label: 'Fail tests which left running processes' ;
		description: 'The test will be failed if it left running processes after the run.
For example following test will fail:
	testExample
		[ 10 seconds wait ] fork.
		self assert: true.
Tests should not leave the system dirty.
And this setting is to facilitate such rule relatively to background processes forked during the test.
See ProcessMonitorTestService comment for more details'! !

!ProcessMonitorTestService class methodsFor: 'accessing' stamp: ''!
shouldTerminateProcesses
	^ shouldTerminateProcesses ifNil: [ shouldTerminateProcesses := true ]! !

!ProcessMonitorTestService class methodsFor: 'fuel support' stamp: ''!
fuelIgnoredInstanceVariableNames
    ^#('forkedProcesses' 'suspendedBackgroundFailures')! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testGettingServiceFromTestCase

	| actual |
	executionEnvironment beActiveDuring: [ 
		actual := self executionProcessMonitor
	].

	self assert: actual identicalTo: testService ! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testIsTestProcessFailed

	| process |
	self deny: (testService isTestProcessFailed: #process).
	
	process := self fork: [testService recordTestFailure: Error new].
	self assert: (testService isTestProcessFailed: process).
	self deny: (testService isTestProcessFailed: #anotherProcess)! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testFailTestWhenItIsCompletedWithRunningProcesses

	self fork: [ 10 seconds wait ].
	
	self should: [testService handleCompletedTest] raise: TestLeftRunningProcess! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testResumeFailedProcessesWhenTestFailureIsUnhandled
	| executed |
	executed := false.
	self fork: [ testService suspendBackgroundFailure: Error new. executed := true ].
	self deny: executed.	

	testService handleException: Error new. "UnhandledError always started with original error signal"
	testService handleException: UnhandledError new.
	self assert: executed.
	"Unhandled exception opens debugger and therefore any new errors should not be suspended"
	self deny: testService shouldSuspendBackgroundFailures ! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testHasEmptyForkedProcessesByDefault

	self assert: testService forkedProcesses isEmpty! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testIsMainTestProcessFailed

	executionEnvironment activated.
	
	self deny: testService isMainTestProcessFailed.
	
	testService recordTestFailure: Error new.
	self assert: executionEnvironment isMainTestProcessFailed! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testCleanUpShouldNotTerminateAllRunningProcessesWhenSuchTerminationIsDisabled
	| process  |
	process := self fork: [ 10 seconds wait ].
	testService disableProcessesTermination.
	
	testService cleanUpAfterTest.
	
	self deny: process isTerminated.		
	self assert: testService forkedProcesses isEmpty! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testDoesNotRaiseLeftRunningProcessWhenItAllowsThemToBe

	| process |
	process := self fork: [ 10 seconds wait ].
	self deny: process isTerminated.

	testService allowTestToLeaveProcesses.	
	self shouldnt: [testService handleCompletedTest] raise: TestLeftRunningProcess.
	self deny: process isTerminated.! !

!ProcessMonitorTestServiceTest methodsFor: 'running' stamp: ''!
fork: aBlock
	"Here we simulate fork under TestExecutionEnvironment 
	which passes new process to all test services"
	| newProcess |
	newProcess := self newProcess: 'Test process' toImmediatelyExecute: aBlock.
	testService handleNewProcess: newProcess.
	newProcess resume.
	^newProcess! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testDoesNotRaiseLeftRunningProcessWhenProcessWasOnlyCreated

	testService handleNewProcess: [  ] newProcess.
	
	self shouldnt: [testService handleCompletedTest] raise: TestLeftRunningProcess ! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testCleanUpShouldRestoreSuspensionLogic

	testService passBackgroundFailures.
	self deny: testService shouldSuspendBackgroundFailures.
	
	testService cleanUpAfterTest.
	self assert: testService shouldSuspendBackgroundFailures! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testCleanUpShouldTerminateAllRunningProcesses
	| process  |
	process := self fork: [ 10 seconds wait ].
	
	testService cleanUpAfterTest.
	
	self assert: process isTerminated.		
	self assert: testService forkedProcesses isEmpty! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testFailTestWhenItIsCompletedWithBackgroundFailures

	self fork: [ testService suspendBackgroundFailure: Error new ].
	
	self should: [testService handleCompletedTest] raise: TestFailedByForkedProcess! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testGettingForkedProcessesFromEnvironment

	| process |
	process := self fork: [ ].
	
	self assert: executionEnvironment forkedProcesses equals: testService forkedProcesses.
	self assert: executionEnvironment forkedProcesses asArray equals: {process}! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testCleanUpShouldTerminateAllFailedProcesses
	| process  |
	process := self fork: [ testService suspendBackgroundFailure: Error new ].
	
	testService cleanUpAfterTest.
	
	self assert: process isTerminated.		
	self assert: testService suspendedBackgroundFailures isEmpty.
	self assert: testService forkedProcesses isEmpty! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testGettingServiceFromEnvironment

	self assert: executionEnvironment processMonitor identicalTo: testService ! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testGettingBackgroundFailuresFromEnvironment
	| mainError backgroundError |
	mainError := Error new messageText: 'mainProcessError'.
	backgroundError := Error new messageText: 'backgroundError'.
	self fork: [ testService recordTestFailure: backgroundError ].
	testService recordTestFailure: mainError.
	
	self assert: executionEnvironment backgroundFailures equals: testService testBackgroundFailures.
	self assertCollection: executionEnvironment backgroundFailures asSet hasSameElements: {backgroundError}! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testHasDefaultTerminationStrategyForRunningProcesses

	testService := ProcessMonitorTestService new.
	
	self assert: testService shouldTerminateProcesses notNil.
	self assert: testService shouldTerminateProcesses equals: ProcessMonitorTestService shouldTerminateProcesses! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testCleanUpShouldNotTerminateAllFailedProcessesWhenSuchTerminationIsDisabled
	| process  |
	process := self fork: [ testService suspendBackgroundFailure: Error new ].
	testService disableProcessesTermination.
	
	testService cleanUpAfterTest.
	
	self deny: process isTerminated.		
	self assert: testService suspendedBackgroundFailures isEmpty.
	self assert: testService forkedProcesses isEmpty! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testDisableRunningProcessesCleanupWhenPassBackgroundFailures

	testService passBackgroundFailures.
	
	self deny: testService shouldTerminateProcesses! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testDoesNotRaiseLeftRunningProcessWhenThereWasMainProcessFailure

	self fork: [ 10 seconds wait].
	
	testService handleException: Error new.
	
	self shouldnt: [testService handleCompletedTest] raise: TestLeftRunningProcess! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testCleanUpShouldRestoreDefaultFailingLogicForRunningProcessesCase

	testService shouldFailTestLeavingProcesses: ProcessMonitorTestService shouldFailTestLeavingProcesses not.
	
	testService cleanUpAfterTest.
	
	self assert: testService shouldFailTestLeavingProcesses equals: ProcessMonitorTestService shouldFailTestLeavingProcesses.! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testFailTestWhenBackgroundProcessWasFailedDuringFinalTryToFinishItAtTestCompletionTime
	"ProcessMonitor tries to allow the left running processes to terminate during the test completion.
	Such running processes can fail at this stage and this test is to cover this scenario. 
	The complex assertion logic here is to reliably simulate this scenario.
	The error processing envolves many message sends and it increases the chances for the process to be preempted.
	Therefore a single iteration is not always enough to get the expected corner case. 
	Thus the function under the test is repeated in the loop"
	| semaphore processIsDone process |
	semaphore := Semaphore new.
	processIsDone := false.
	process := self fork: [ semaphore wait. processIsDone := true. 1/0 ].
	process priority: Processor activePriority.
	semaphore signal.
	self deny: processIsDone.
	
	self should: [
		[	
			[testService handleCompletedTest] on: TestLeftRunningProcess do: [ :err | err retry ].
			self assert: false description: 'should fail with error'.
		] on: TestFailedByForkedProcess do: [:err | ]
	] notTakeMoreThan: 2 seconds.	
	self assert: processIsDone.! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testFailTestWhenItIsCompletedWithBackgroundFailuresAndRunningProcesses

	self fork: [ testService suspendBackgroundFailure: Error new ].
	self fork: [ 10 seconds wait ].
	
	self 
		should: [
			[testService handleCompletedTest] 
				on: TestFailedByForkedProcess do: [ :err | err resumeUnchecked: true ]]
		raise: TestLeftRunningProcess! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testHasEmptySuspendedBackgroundFailuresByDefault

	self assert: testService suspendedBackgroundFailures isEmpty! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testPassBackgroundFailuresWhenSuspensionLogicIsDisabled
	| process error errorWasPassed |
	self flag: 'it fails runKernelTests on bootstrap image due to Process bug #6745'.
	self skip.
	errorWasPassed := false.
	error := Error new messageText: 'test error'.
	process := self fork: [ Processor activeProcess suspend. error signal ].	
	
	testService disableBackgroudFailuresSuspension.
	self deny: testService shouldSuspendBackgroundFailures.
	
	process on: UnhandledError do: [ :err | errorWasPassed := true ].
	process resume.
	
	self assert: errorWasPassed.
	self assert: process isTerminated description: 'process should be terminated now'! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testResumeFailedProcessesWhenHaltIsSignaled
	| executed |
	executed := false.
	self fork: [ testService suspendBackgroundFailure: Error new. executed := true ].

	testService handleException: Halt new. 
	
	self assert: executed.
	self deny: testService shouldSuspendBackgroundFailures! !

!ProcessMonitorTestServiceTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	
	"Following settings ensure that we are testing full behavior independently from default settings"
	testService failTestLeavingProcesses. 
	testService terminateProcessesAfterTest.
	executionEnvironment activated ! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testDoesNotRaiseForkedProcessFailureWhenFailuresWerePassedAndMainProcessAlsoFails

	self fork: [ testService suspendBackgroundFailure: Error new. 
		Processor activeProcess suspend "To emulate process under debugger" ].

	testService passBackgroundFailures.
	testService recordTestFailure: Error new.	
		
	self shouldnt: [testService handleCompletedTest] raise: TestFailedByForkedProcess! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testRecordMainTestProcessUnhandledError

	| error |
	error := UnhandledError new.
	
	testService handleException: error.

	self 
		assert: (testService testFailures at: Processor activeProcess) 
		equals: error! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testDoesNotRaiseForkedProcessFailureWhenFailuresWerePassedAndProcessCompletes

	| process |
	self flag: 'it fails runKernelTests on bootstrap image due to Process bug #6745'.
	self skip.
	process := self fork: [ testService suspendBackgroundFailure: Error new ].
	
	testService passBackgroundFailures.
	
	self assert: process isTerminated description: 'process should be terminated now'.
	self shouldnt: [testService handleCompletedTest] raise: TestFailedByForkedProcess! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testAlwaysPassBackgroundHalt
	| process haltWasPassed halt |
	self flag: 'it fails runKernelTests on bootstrap image due to Process bug #6745'.
	self skip.
	
	haltWasPassed := false.
	halt := Halt new.
	process := self fork: [ Processor activeProcess suspend. halt signal ].
	testService handleNewProcess: process.
	
	process on: Halt do: [ :actual | 
		actual == halt ifFalse: [ actual pass ]. "it allows to debug if it works wrongly"
		self assert: actual equals: halt. haltWasPassed := true ].
	process resume.
	
	self assert: haltWasPassed.
	self assert: process isTerminated description: 'process should be terminated now'. 
	self deny: (testService suspendedBackgroundFailures includesKey: process)! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testResumeFailedProcessWhenItFailsTestWithUnhandledError
	"Test with background failures is failing with TestFailedByForkedProcess.
	In case when it is unhandled (when we debug the test) it should resume all background failures"
	| executed failedProcess |
	executed := false.
	failedProcess := self fork: [testService suspendBackgroundFailure: Error new. executed := true ].
	self assert: failedProcess isSuspended.
	
	self runWithNoHandlers: [
		[testService handleCompletedTest] on: UnhandledError do: [ :err |
			self deny: failedProcess isSuspended]
	].

	self assert: executed ! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testResumeFailedProcessesWhenHaltIsSignaledInBackground
	| processWithHalt executed |
	executed := false.
	self fork: [ testService suspendBackgroundFailure: Error new. executed := true ].
	processWithHalt := self fork: [ Processor activeProcess suspend. Halt new signal ].
	
	processWithHalt on: Halt do: [ :actual | ].
	processWithHalt resume.
	
	self assert: executed.
	self deny: testService shouldSuspendBackgroundFailures! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testStoreAllForkedProcesses

	| process |
	process := self fork: [ ].
	
	self assert: (testService forkedProcesses includes: process)! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testSuspendBackgroundError

	| process error suspendedError |
	error := Error new messageText: 'test error'.
	
	process := self fork: [ error signal ].
	
	self assert: process isSuspended.
	suspendedError := testService suspendedBackgroundFailures at: process.
	self assert: suspendedError class equals: UnhandledError. 
	self assert: suspendedError exception identicalTo: error.! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testSuspendBackgroundWarning
	
	| process warning suspendedError |
	warning := Warning new.
	process := self fork: [ warning signal ].
	
	self assert: process isSuspended.
	suspendedError := testService suspendedBackgroundFailures at: process.
	self assert: suspendedError class equals: UnhandledError. 
	self assert: suspendedError exception identicalTo: warning.! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testAllowRunningBackgroundProcessesToFinishButFailTestIfItCant

	| semaphore process wasResumed |
	semaphore := Semaphore new.
	wasResumed := false.
	process := self fork: [ semaphore wait. wasResumed := true. 10 seconds wait].
	process priority: Processor activePriority.
	semaphore signal.
	self deny: wasResumed.
	
	self should: [testService handleCompletedTest] raise: TestLeftRunningProcess.
	self assert: wasResumed! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testFailTestWhenBackgroundFailureWasPassedButMainProcessCompletesSuccessfully

	self fork: [ testService suspendBackgroundFailure: Error new. 
		Processor activeProcess suspend "To emulate process under debugger" ].
	
	testService passBackgroundFailures.
	
	self should: [testService handleCompletedTest] raise: TestFailedByForkedProcess! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testIgnoreDirtyTestErrors
	
	testService handleException: TestLeftRunningProcess new.
	self assert: testService testFailures isEmpty.
	
	testService handleException: TestFailedByForkedProcess new.
	self assert: testService testFailures isEmpty! !

!ProcessMonitorTestServiceTest methodsFor: 'running' stamp: ''!
createTestService

	^ProcessMonitorTestService new! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testAllowRunningBackgroundProcessesToFinish

	| semaphore processIsDone process |
	semaphore := Semaphore new.
	processIsDone := false.
	process := self fork: [ semaphore wait. processIsDone := true].
	process priority: Processor activePriority.
	semaphore signal.
	self deny: processIsDone.
	
	testService handleCompletedTest.
	
	self assert: processIsDone.! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testShouldSuspendBackgroundFailuresByDefault

	self assert: testService shouldSuspendBackgroundFailures ! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testHasDefaultFailingStrategyForRunningProcesses

	testService := ProcessMonitorTestService new.
	
	self assert: testService shouldFailTestLeavingProcesses notNil.
	self assert: testService shouldFailTestLeavingProcesses equals: ProcessMonitorTestService shouldFailTestLeavingProcesses.! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testRecordMainTestProcessError

	| error |
	error := Error new.
	
	testService handleException: error.

	self 
		assert: (testService testFailures at: Processor activeProcess) 
		equals: error! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testCleanUpShouldRestoreProcessTerminationLogic

	testService shouldTerminateProcesses: ProcessMonitorTestService shouldTerminateProcesses not.
	
	testService cleanUpAfterTest.
	
	self assert: testService shouldTerminateProcesses equals: ProcessMonitorTestService shouldTerminateProcesses.! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testGettingFailuresFromEnvironment
	| mainError backgroundError |
	mainError := Error new messageText: 'mainProcessError'.
	backgroundError := Error new messageText: 'backgroundError'.
	self fork: [ testService recordTestFailure: backgroundError ].
	testService recordTestFailure: mainError.
	
	self assert: executionEnvironment failures equals: testService testFailures.
	self assertCollection: executionEnvironment failures asSet hasSameElements: {mainError. backgroundError}! !

!ProcessMonitorTestServiceTest methodsFor: 'tests' stamp: ''!
testDoesNotRaiseForkedProcessFailureWhenThereWasOnlyMainProcessFailure

	testService handleException: Error new.
	
	self shouldnt: [testService handleCompletedTest] raise: TestFailedByForkedProcess! !

!ProcessSpecificTest commentStamp: ''!
A ProcessSpecificTest is a test case for process local and dynamic variables.
!
!ProcessSpecificTest methodsFor: 'testing' stamp: ''!
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: 10.
	s2 waitTimeoutSeconds: 10.
	self assert: p1stopped.
	self assert: p2stopped.! !

!ProcessSpecificTest methodsFor: 'testing' stamp: ''!
testExecutionEnvironment

	| newEnv |
	newEnv := ExecutionEnvironmentStub new.
	newEnv beActiveDuring: [  
		self assert: CurrentExecutionEnvironment value equals: newEnv.	
	
		DefaultExecutionEnvironment beActiveDuring: [ 
			self assert: CurrentExecutionEnvironment value equals: DefaultExecutionEnvironment instance].
	
		self assert: CurrentExecutionEnvironment value equals: newEnv.		
	]! !

!ProcessSpecificTest methodsFor: 'testing' stamp: ''!
checkLocal: value
	self assert: TestLocalVariable value equals: value! !

!ProcessSpecificTest methodsFor: 'testing' stamp: ''!
testDynamicVariableRemovedAfterUse
	TestDynamicVariable
		value: 3
		during: [  ].
		
	self assert: (Processor activeProcess psValueAt: TestDynamicVariable soleInstance index) equals: nil! !

!ProcessSpecificTest methodsFor: 'testing' stamp: ''!
testInheritableVariable

	| s1 s2 parentVar childVar |
	s1 := Semaphore new.
	s2 := Semaphore new.
	TestInheritableVariable enable.
	
	[ TestInheritableVariable value: #inheritedVar.
		parentVar := TestInheritableVariable value.
		[ childVar := TestInheritableVariable value. s2 signal ] fork.
		s1 signal.
	 ] fork.

	s1 waitTimeoutSeconds: 2.
	s2 waitTimeoutSeconds: 2.
	TestInheritableVariable disable.
	
	self assert: parentVar equals: #inheritedVar.
	self assert: childVar equals: #inheritedVar! !

!ProcessSpecificTest methodsFor: 'testing' stamp: ''!
checkDynamic: value
	self assert: TestDynamicVariable value equals: value! !

!ProcessSpecificTest methodsFor: 'testing' stamp: ''!
testLocalVariable

	| s1 s2 p1stopped p2stopped |
	s1 := Semaphore new.
	s2 := Semaphore new.
	p1stopped := p2stopped := false.
	[
		self checkLocal: 0.
		TestLocalVariable value: 1.
		self checkLocal: 1.
		(Delay forMilliseconds: 30) wait.
		self checkLocal: 1.
		TestLocalVariable value: 2.
		self checkLocal: 2.
		p1stopped := true.
		s1 signal.
	] fork.

	[
		(Delay forMilliseconds: 30) wait.
		self checkLocal: 0.
		TestLocalVariable value: 3.
		self checkLocal: 3.
		(Delay forMilliseconds: 30) wait.
		self checkLocal: 3.
		TestLocalVariable value: 4.
		self checkLocal: 4.
		p2stopped := true.
		s2 signal.
	] fork.

	"Set a maximum wait timeout so that the test case will complete 
	 even if the processes fail to signal us."
	s1 waitTimeoutMSecs: 5000.
	s2 waitTimeoutMSecs: 5000.
	self assert: p1stopped.
	self assert: p2stopped.! !

!ProcessSpecificTest methodsFor: 'testing' stamp: ''!
testInheritingExecutionEnvironment

	| newEnv p |
	newEnv := ExecutionEnvironmentStub new.
	newEnv beActiveDuring: [  
		p := [self assert: CurrentExecutionEnvironment value equals: newEnv] fork.
	].

	self assert: newEnv forkedProcesses anyOne equals: p! !

!ProcessSpecificTest methodsFor: 'testing' stamp: ''!
testDynamicVariableAccessFromDifferentProcess
	| process sem result |
	sem := Semaphore new.
	process := [ TestDynamicVariable value: 123 during: [ sem wait ] ] fork.
	Processor yield.
	Processor activeProcess evaluate: [ result := TestDynamicVariable value ] onBehalfOf: process.
	sem signal.
	self assert: result equals: 123! !

!ProcessSpecificTest methodsFor: 'testing' stamp: ''!
testDynamicVariableBlockReturnValue
	| returnValue |
	returnValue := TestDynamicVariable value: 10 during: [ TestDynamicVariable value + 1 ].
	self assert: returnValue equals: 11! !

!ProcessSpecificVariable commentStamp: ''!
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).

My subclasses could supply inheritable values which will be installed on forked (child) processes. To enable this classes should return true from  #isInheritable method (on class side).
Also subclasses could provide specific logic for installing variables into new processes which allows interesting hooks to control forked processes
!
!ProcessSpecificVariable methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!ProcessSpecificVariable methodsFor: 'inheriting' stamp: ''!
isInheritable
	^self class isInheritable! !

!ProcessSpecificVariable methodsFor: 'accessing' stamp: ''!
value

	^ (Processor activeProcess psValueAt: index) ifNil: [ self default ]! !

!ProcessSpecificVariable methodsFor: 'accessing' stamp: ''!
default
	"Answer the default value for the variable. The default for the default value is nil."
	^nil! !

!ProcessSpecificVariable methodsFor: 'accessing' stamp: ''!
index: anInteger
	index := anInteger! !

!ProcessSpecificVariable methodsFor: 'accessing' stamp: ''!
valueOrNil
	"a faster version, which doesn't using ifAbsent: to avoid using block closure"
	^ Processor activeProcess psValueAt: index! !

!ProcessSpecificVariable methodsFor: 'inheriting' stamp: ''!
installValue: anObject intoForked: newProcess from: ownerProcess
"
	In subclasses you can override this method to implement specific variable inheritance logic
"
	newProcess psValueAt: index put: anObject! !

!ProcessSpecificVariable class methodsFor: 'testing' stamp: ''!
isInheritable
	^false! !

!ProcessSpecificVariable class methodsFor: 'instance creation' stamp: ''!
new
	| instance |
	instance := super new.
	instance index: (Process allocatePSKey: instance).
	^ instance! !

!ProcessSpecificVariable class methodsFor: 'accessing' stamp: ''!
soleInstance
	^ soleInstance ifNil: [ soleInstance := self new ]! !

!ProcessSpecificVariable class methodsFor: 'class initialization' stamp: ''!
initialize
	self resetSoleInstance.! !

!ProcessSpecificVariable class methodsFor: 'class initialization' stamp: ''!
resetSoleInstance
	soleInstance := nil.! !

!ProcessSpecificVariable class methodsFor: 'accessing' stamp: ''!
value
	"Answer the current value for this variable in the current context."
	^ self soleInstance value! !

!ProcessTerminateBugTest commentStamp: ''!
SUnit tests for Process termination!
!ProcessTerminateBugTest methodsFor: 'tests' stamp: ''!
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."		
	| 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.! !

!ProcessTerminateBugTest methodsFor: 'tests' stamp: ''!
testUnwindFromActiveProcess
	| sema |
	sema := Semaphore forMutualExclusion.
	self assert: sema isSignaled.
	[ 
	sema critical: [ 
		self deny: sema isSignaled.
		Processor activeProcess terminate ] ] forkAt: Processor userInterruptPriority.
	self assert: sema isSignaled! !

!ProcessTerminateBugTest methodsFor: 'tests' stamp: ''!
testTerminationDuringNestedUnwindS1
	"Test all nested unwind blocks are correctly unwound; 
	all unwind blocks halfway through their execution should be completed."

	| p x1 x2 x3 |
	x1 := x2 := x3 := false.
	p := 
		[
			[
				[ ] ensure: [
					[Processor activeProcess suspend] ensure: [
						x1 := true]. 
					x2 := true]
			] ensure: [
				x3 := true]
		] newProcess resume.
	Processor yield.
	"make sure p is suspended and none of the unwind blocks has finished yet"
	self assert: p isSuspended.
	self deny: x1 | x2 | x3.
	"now terminate the process and make sure all unwind blocks have finished"
	p terminate.
	self assert: p isTerminated.
	self assert: x1 & x2 & x3
! !

!ProcessTerminateBugTest methodsFor: 'tests' stamp: ''!
testTerminationDuringNestedUnwindR1
	"Test all nested unwind blocks are correctly unwound; 
	all unwind blocks halfway through their execution should be completed."

	| p x1 x2 x3 |
	x1 := x2 := x3 := false.
	p := 
		[
			[
				[ ] ensure: [
					[Processor yield] ensure: [
						x1 := true]. 
					x2 := true]
			] ensure: [
				x3 := true]
		] newProcess resume.
	Processor yield.
	"make sure p is not suspended and none of the unwind blocks has finished yet;
	ideally we'd like to make sure p is runnable but isRunnable is not implemented"
	self deny: p isSuspended.
	self deny: x1 | x2 | x3.
	"now terminate the process and make sure all unwind blocks have finished"
	p terminate.
	self assert: p isTerminated.
	self assert: x1 & x2 & x3
! !

!ProcessTerminateBugTest methodsFor: 'tests' stamp: ''!
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.! !

!ProcessTerminateBugTest methodsFor: 'tests' stamp: ''!
testTerminationDuringNestedUnwindR2
	"Test all nested unwind blocks are correctly unwound; 
	all unwind blocks halfway 	through their execution should be completed."

	| p x1 x2 x3 |
	x1 := x2 := x3 := false.
	p := 
		[
			[
				[ ] ensure: [
					[ ] ensure: [
						Processor yield. 
						x1 := true]. 
					x2 := true]
			] ensure: [
				x3 := true]
		] newProcess resume.
	Processor yield.
	"make sure p is not suspended and none of the unwind blocks has finished yet;
	ideally we'd like to make sure p is runnable but isRunnable is not implemented"
	self deny: p isSuspended.
	self deny: x1 | x2 | x3.
	"now terminate the process and make sure all unwind blocks have finished"
	p terminate.
	self assert: p isTerminated.
	self assert: x1 & x2 & x3
! !

!ProcessTerminateBugTest methodsFor: 'tests' stamp: ''!
testTerminationDuringNestedUnwindB2
	"Test all nested unwind blocks are correctly unwound; 
	all unwind blocks halfway 	through their execution should be completed."

	| p x1 x2 x3 semaphore |
	x1 := x2 := x3 := false.
	semaphore := Semaphore new.
	p := 
		[
			[
				[ ] ensure: [
					[ ] ensure: [
						semaphore wait.
						x1 := true]. 
					x2 := true]
			] ensure: [
				x3 := true]
		] newProcess resume.
	Processor yield.
	"make sure p is not suspended and none of the unwind blocks has finished yet;
	ideally we'd like to make sure p is blocked but isBlocked is not implemented"
	self deny: p isSuspended.
	self deny: x1 | x2 | x3.
	"now terminate the process and make sure all unwind blocks have finished"
	p terminate.
	self assert: p isTerminated.
	self assert: x1 & x2 & x3
! !

!ProcessTerminateBugTest methodsFor: 'tests' stamp: ''!
testTerminationDuringNestedUnwindS2
	"Test all nested unwind blocks are correctly unwound; 
	all unwind blocks halfway through their execution should be completed."

	| p x1 x2 x3 |
	x1 := x2 := x3 := false.
	p := 
		[
			[
				[ ] ensure: [
					[ ] ensure: [
						Processor activeProcess suspend. 
						x1 := true]. 
					x2 := true]
			] ensure: [
				x3 := true]
		] newProcess resume.
	Processor yield.
	"make sure p is suspended and none of the unwind blocks has finished yet"
	self assert: p isSuspended.
	self deny: x1 | x2 | x3.
	"now terminate the process and make sure all unwind blocks have finished"
	p terminate.
	self assert: p isTerminated.
	self assert: x1 & x2 & x3
! !

!ProcessTerminateBugTest methodsFor: 'tests' stamp: ''!
testTerminationDuringNestedUnwindB1
	"Test all nested unwind blocks are correctly unwound; 
	all unwind blocks halfway 	through their execution should be completed."

	| p x1 x2 x3 semaphore |
	x1 := x2 := x3 := false.
	semaphore := Semaphore new.
	p := 
		[
			[
				[ ] ensure: [
					[semaphore wait] ensure: [
						x1 := true]. 
					x2 := true]
			] ensure: [
				x3 := true]
		] newProcess resume.
	Processor yield.
	"make sure p is not suspended and none of the unwind blocks has finished yet;
	ideally we'd like to make sure p is blocked but isBlocked is not implemented"
	self deny: p isSuspended.
	self deny: x1 | x2 | x3.
	"now terminate the process and make sure all unwind blocks have finished"
	p terminate.
	self assert: p isTerminated.
	self assert: x1 & x2 & x3
! !

!ProcessTerminateBugTest methodsFor: 'tests' stamp: ''!
testUnwindFromForeignProcess

	| sema process |
	sema := Semaphore forMutualExclusion.
	self assert: sema isSignaled.
	process := [ 
	sema
		critical: [ 
			self deny: sema isSignaled.
			sema wait	"deadlock" ] ] forkAt: Processor userInterruptPriority.
	self deny: sema isSignaled.	"This is for illustration only - the BlockCannotReturn cannot 
	be handled here (it's truncated already)"
	process terminate.
	self assert: sema isSignaled! !

!ProcessTest commentStamp: ''!
A ProcessTest holds test cases for generic Process-related behaviour.!
!ProcessTest methodsFor: 'tests' stamp: ''!
testRealActiveProcessFromProcesor
	
	| processFromProcessor activeProcess |
	activeProcess := [ processFromProcessor := Processor realActiveProcess ] forkAt: Processor activePriority + 1.
	
	self assert: processFromProcessor identicalTo: activeProcess! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testIsNotSuspendedWhenItIsRunningButNotActiveProcess

	| semaphore process |
	semaphore := Semaphore new.
	process := [ semaphore signal. Processor yield ] fork.
	semaphore wait.
	self deny: process isTerminated.
	self deny: process isSuspended! !

!ProcessTest methodsFor: 'tests - termination' stamp: ''!
testIsTerminatingNormalTermination
	| sem process unwound started terminator |
	sem := Semaphore new.
	unwound := false.
	started := false.
	process := [ started := true.
	[ sem wait ]
		ensure: [ terminator := Processor activeProcess.
			unwound := true ] ] fork.
	self deny: process isSuspended.
	self deny: process isTerminating.
	self deny: process isTerminated.
	self deny: started.
	self deny: unwound.

	sem signal.
	self waitForProcessTermination: process.
	"#terminate will be sent by the process itself after its context has finished (see BlockClosure>>newProcess)"
	self deny: process isSuspended.
	self assert: process isTerminating.
	self assert: process isTerminated.
	self assert: started.
	"When inside of an unwind context, that unwind context needs run through."
	self assert: unwound.
	"A process should terminte itself."
	self assert: terminator identicalTo: process! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testRealActiveProcessFromProcesorShouldIgnoreInstalledEffectiveProcess
	
	| processFromProcessor activeProcess effectiveProcess |
	effectiveProcess := [ 10 seconds wait ] forkAt: Processor activePriority + 1.
	activeProcess := [ processFromProcessor := Processor realActiveProcess ] newProcess.
	activeProcess 
		priority: Processor activePriority + 1;
		effectiveProcess: effectiveProcess;
		resume.
	
	self assert: processFromProcessor identicalTo: activeProcess! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testNormalProcessWithArgsCompletionWithLeftEffectiveProcess
	
	| effectiveProcess activeProcess |
	effectiveProcess := [ 10 seconds wait ] forkAt: Processor activePriority + 1.
	activeProcess := [:arg | Processor activeProcess suspend. ] newProcessWith: #(1).
	activeProcess 
		priority: Processor activePriority + 1; 
		resume.
	activeProcess effectiveProcess: effectiveProcess.
	
	activeProcess resume.
	
	self assert: activeProcess isTerminated.
	self deny: effectiveProcess isTerminated.
	effectiveProcess terminate! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testFork

	| hasBlockRun block return checkAssert |
	checkAssert := Semaphore new.
	hasBlockRun := false.
	block := [ hasBlockRun := true. checkAssert signal.].
	return := block fork.
	
	"Returns immediately, forked block not yet run"
	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"
	checkAssert wait.
	self assert: hasBlockRun! !

!ProcessTest methodsFor: 'tests - creation' stamp: ''!
testTerminateAnswersSelf

	| process |

	"verify #terminate returns a process that is terminated"
	process := [] newProcess terminate.
	self assert: (process isKindOf: Process).
	self assert: process isTerminated.

	"verify repeating #terminate still returns a terminated process"
	process := process terminate.
	self assert: (process isKindOf: Process).
	self assert: process isTerminated.! !

!ProcessTest methodsFor: 'tests - exception handlers' stamp: ''!
testInjectingMultipleExceptionHandlersIntoRunningProcess

	| error process lastHandler firstHandler sema started |
	DefaultExecutionEnvironment beActive.
	started := firstHandler := lastHandler := false.	
	sema := Semaphore new.
	process := [started := true. sema wait. error signal ] fork.
	[started] whileFalse: [ Processor yield ].
	process on: ZeroDivide do: [ :err | firstHandler := true ].
	process on: Error do: [ :err | lastHandler := true ].
	
	error := ZeroDivide new.
	sema signal.
	[process isTerminated] whileFalse: [ Processor yield ].
	self assert: firstHandler.
	self deny: lastHandler.
	
	started := firstHandler := lastHandler := false.
	sema := Semaphore new.
	process := [started := true. sema wait. error signal ] fork.
	[started] whileFalse: [ Processor yield ].
	process on: ZeroDivide do: [ :err | firstHandler := true ].
	process on: Error do: [ :err | lastHandler := true ].
	
	error := Error new.
	sema signal.
	[process isTerminated] whileFalse: [ Processor yield ].
	self deny: firstHandler.
	self assert: lastHandler! !

!ProcessTest methodsFor: 'helpers' stamp: ''!
waitForProcessTermination: aProcess
	aProcess priority: Processor activePriority + 1.
	[ aProcess isTerminated ] whileFalse: [ Processor yield ]! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testSchedulingSamePriorityFirstComeFirstServed
    "The first process to run will pass straight through the gate
    while the other waits for the assert to whichRan."

	"At the same priority process, the longer waiting process should run first."

	| gate checkAssert whichRan |
	gate := Semaphore new signal. 
	checkAssert := Semaphore new.
		
	[ gate wait. whichRan := 1. checkAssert signal ] fork.
	[ gate wait. whichRan := 2. checkAssert signal ] fork.
	
	checkAssert wait.
	self assert: whichRan=1 description: 'First scheduled process should run first'.
	gate signal. 

	checkAssert wait.
	self assert: whichRan=2 description: 'Second scheduled process should run after'.! !

!ProcessTest methodsFor: 'tests - termination' stamp: ''!
testIsTerminatingForcedTermination
	| process unwound started terminator unwindChecks terminationSemaphore |
	unwound := false.
	started := false.
	terminationSemaphore := Semaphore new.
	terminationSemaphore signal.
	process := [ started := true.
	[ terminationSemaphore
		wait;
		wait ]
		ensure: [ terminator := Processor activeProcess.
			unwindChecks value.
			unwound := true ] ] newProcess.
	process priority: Processor activePriority - 1.

	self assert: process isSuspended.
	self deny: process isTerminating.
	self deny: process isTerminated.
	self deny: started.
	self deny: unwound.

	process resume.
	[ terminationSemaphore isSignaled ] whileTrue: [ 50 milliSeconds asDelay wait ].
	self deny: process isSuspended.
	self deny: process isTerminating.
	self deny: process isTerminated.
	self assert: started.
	self deny: unwound.
	self deny: terminator identicalTo: process.

	terminationSemaphore signal.
	"This will run the #ensure: block and block on the Semaphore."
	process terminate.
	"We want these checks to run during unwinding, so we need to cheat a bit."
	unwindChecks := [ self assert: process isSuspended.
	"We're inside of #terminate."
	self assert: process isTerminating.
	"Still unwinding, so not finished."
	self deny: process isTerminated.
	self assert: started.
	"Not unwound yet."
	self deny: unwound.
	self assert: terminator identicalTo: process ].

	[ process isTerminated ] whileFalse: [ 50 milliSeconds asDelay wait ].
	self deny: process isSuspended.
	self assert: process isTerminating.
	self assert: process isTerminated.
	self assert: started.
	self assert: unwound.
	self assert: terminator identicalTo: process! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testNormalProcessCompletionWithLeftEffectiveProcess
	
	| effectiveProcess activeProcess |
	effectiveProcess := [ 10 seconds wait ] forkAt: Processor activePriority + 1.
	activeProcess := [ Processor activeProcess suspend. ] forkAt: Processor activePriority + 1.
	activeProcess effectiveProcess: effectiveProcess.
	
	activeProcess resume.
	
	self assert: activeProcess isTerminated.
	self deny: effectiveProcess isTerminated.
	effectiveProcess terminate! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testIsNotTerminatedWhenItIsJustStartedByEnteringMainBlock
	
	| process processBody |
	processBody := [ #test ].
	process := processBody newProcess.
	
	[process step.
	self deny: process isTerminated] 
		doWhileTrue: [ process suspendedContext isBottomContext ].
		
	self assert: process suspendedContext closure identicalTo: processBody.
	self deny: process isTerminated! !

!ProcessTest methodsFor: 'tests - termination' stamp: ''!
testTerminateActive

	| lastStatementEvaluated block1HasRun block2HasRun p1 p2 |
	block1HasRun := block2HasRun := lastStatementEvaluated := false.
	p1 := [
		block1HasRun := true.
		Processor activeProcess terminate.
		lastStatementEvaluated := true ] fork.
	
	p2 := [
		block2HasRun := true.
		Processor terminateActive.
		lastStatementEvaluated := true ] fork.
	
	[p1 isTerminated & p2 isTerminated] whileFalse: [ Processor yield ].
	
	"Expressions following terminate are never executed"
	self assert: block1HasRun.
	self assert: block2HasRun.
	self deny: lastStatementEvaluated.! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testSchedulingHigherPriorityServedFirst
    "The first process to run will pass straight through the gate
    while the other waits for the assert to whichRan."

	"Even though the low priority process is waiting longer, 
	the higher priority process should run first."

	| gate checkAssert whichRan |
	gate := Semaphore new signal. 
	checkAssert := Semaphore new.
	
	[ gate wait. whichRan := 11. checkAssert signal ] forkAt: 11.
	[ gate wait. whichRan := 12. checkAssert signal ] forkAt: 12.
	
	checkAssert wait.
	self assert: whichRan=12 description: 'Second scheduled but higher priority should run first'.	
	gate signal. 
	
	checkAssert wait.
	self assert: whichRan=11 description: 'First scheduled but lower priority should run after'.! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testActiveProcessFromProcesorShouldUseInstalledEffectiveProcess
	
	| processFromProcessor activeProcess effectiveProcess |
	effectiveProcess := [ 10 seconds wait ] forkAt: Processor activePriority + 1.
	activeProcess := [ processFromProcessor := Processor activeProcess ] newProcess.
	activeProcess 
		priority: Processor activePriority + 1;
		effectiveProcess: effectiveProcess;
		resume.
	
	self assert: processFromProcessor identicalTo: effectiveProcess! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testIsSuspendedWhenItIsNotStartedYet

	| process |
	process := [  ] newProcess.
	self assert: process isSuspended! !

!ProcessTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	
	self executionProcessMonitor disable! !

!ProcessTest methodsFor: 'tests' stamp: ''!
expectedFailures
	^#("these two tests fail after fixing the root cause of an unwind error in Process>>terminate"
		#testIsTerminatingForcedTermination
		#testTerminationShouldProceedAllEnsureBlocksIfSomeWasFailed
	)! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testForkAtHigherPriority
	| hasBlockRun |
	hasBlockRun := false.
	[ hasBlockRun := true ] forkAt: Processor activeProcess priority + 1.

	"Preempts current process"
	self assert: hasBlockRun! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testIsTerminatedAfterManualTermination
	
	| process |
	process := [ 10 seconds wait ] forkAt: Processor activePriority + 1.
	self deny: process isTerminated.
	
	process terminate.
	self assert: process isTerminated! !

!ProcessTest methodsFor: 'tests - exception handlers' stamp: ''!
testInjectingExceptionHandlerIntoNotRunningProcess
	| error interceptedError process interrupted |
	DefaultExecutionEnvironment beActive.
	error := Error new messageText: 'test error'.
	interrupted := true.
	process := [ error signal.
	interrupted := false ] newProcess.
	process
		on: Error
		do: [ :err | interceptedError := err ].
	process resume.
	[ process isTerminated ] whileFalse: [ Processor yield ].

	self assert: interceptedError identicalTo: error.
	self assert: interrupted! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testIsNotSuspendedWhenItIsTerminated

	| semaphore process |
	semaphore := Semaphore new.
	process := [ semaphore signal] fork.
	semaphore wait.
	self assert: process isTerminated.
	self deny: process isSuspended! !

!ProcessTest methodsFor: 'tests - creation' stamp: ''!
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: 'tests' stamp: ''!
testChangingPriorityRespectsTheProcessPreemptionSettings
	"test whether #priority: preempts active process to allow higher priority processes run;
	#priority behavior reflects the processPreemptionYields setting - for false the active 
	process gets to the front of the queue while for true (default) it goes to the end"

	| val highPriority |
	val := nil.
	highPriority := 70.
	
	[
		[ val := false ] forkAt: highPriority + 1.
		[ val := true ] forkAt: highPriority.
		Processor activeProcess priority: highPriority.
	]	forkAt: highPriority + 2.
	
	self assert: val equals: Smalltalk vm processPreemptionYields! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testChangingPriorityYieldsCurrentProcess

	| val highPriority |
	val := 0.
	highPriority := 70.

	[ 
		[ val := 1 ] forkAt: highPriority + 1.
		
		Processor activeProcess priority: highPriority.
		val := 2 
	] forkAt: highPriority + 2.
	
	self assert: val equals: 2! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testActiveProcessFromProcesor
	
	| processFromProcessor activeProcess |
	activeProcess := [ processFromProcessor := Processor activeProcess ] forkAt: Processor activePriority + 1.
	
	self assert: processFromProcessor identicalTo: activeProcess! !

!ProcessTest methodsFor: 'tests - exception handlers' stamp: ''!
testInjectingExceptionHandlerIntoProcessWithArg
	| error interceptedError process interrupted processArg |
	DefaultExecutionEnvironment beActive.
	error := Error new messageText: 'test error'.
	interrupted := true.
	process := [ :arg | 
	processArg := arg.
	error signal.
	interrupted := false ] newProcessWith: #(#arg).
	process
		on: Error
		do: [ :err | interceptedError := err ].
	process resume.
	[ process isTerminated ] whileFalse: [ Processor yield ].

	self assert: interceptedError identicalTo: error.
	self assert: interrupted.
	self assert: processArg equals: #arg! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testIsNotTerminatedWhenItIsInsideLastTerminationMethod
	
	| process processBody |
	processBody := [ #test ].
	process := processBody newProcess.
	
	[process step.
	self deny: process isTerminated.
	process suspendedContext isBottomContext] whileTrue. 
	
	[process step.
	process suspendedContext isBottomContext] whileFalse: [ 
		self deny: process isTerminated ].
	
	[process step.
	self deny: process isTerminated.
	process suspendedContext isBottomContext ] whileTrue.
	"Notice that stepping delegates terminateRealActive to terminateActive"
	self assert: process suspendedContext selector equals: #terminateActive. 
	self deny: process isTerminated! !

!ProcessTest methodsFor: 'tests - exception handlers' stamp: ''!
testInjectingExceptionHandlerFromProcessItself
	| error interceptedError process interrupted |
	DefaultExecutionEnvironment beActive.
	error := Error new messageText: 'test error'.
	interrupted := true.
	process := [ Processor activeProcess
		on: Error
		do: [ :err | interceptedError := err ].
	error signal.
	interrupted := false ] fork.

	[ process isTerminated ] whileFalse: [ Processor yield ].

	self assert: interceptedError identicalTo: error.
	self assert: interrupted! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testIsNotSuspendedWhenItIsActiveProcess

	| semaphore suspended |
	semaphore := Semaphore new.
	[ suspended := Processor activeProcess isSuspended. semaphore signal ] fork.
	semaphore wait.
	self deny: suspended! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testIsNotTerminatedWhenItIsNotStarted
	
	| process |
	process := [  ] newProcess.
	
	self deny: process isTerminated! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testIsSelfEvaluating
	self assert: Processor printString equals: 'Processor'! !

!ProcessTest methodsFor: 'tests - exception handlers' stamp: ''!
testInjectingMultipleExceptionHandlersIntoNotRunningProcess

	| error process lastHandler firstHandler |
	DefaultExecutionEnvironment beActive.
	firstHandler := lastHandler := false.
	process := [ error signal ] newProcess.
	process on: ZeroDivide do: [ :err | firstHandler := true ].
	process on: Error do: [ :err | lastHandler := true ].
	
	error := ZeroDivide new.
	process resume.
	[process isTerminated] whileFalse: [ Processor yield ].
	self assert: firstHandler.
	self deny: lastHandler.
	
	firstHandler := lastHandler := false.
	process := [ error signal ] newProcess.
	process on: ZeroDivide do: [ :err | firstHandler := true ].
	process on: Error do: [ :err | lastHandler := true ].
	
	error := Error new.
	process resume.
	[process isTerminated] whileFalse: [ Processor yield ].
	self deny: firstHandler.
	self assert: lastHandler! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testIsTerminatedAfterSelfTermination
	
	| process |
	process := [  ] forkAt: Processor activePriority + 1.
	
	self assert: process isTerminated! !

!ProcessTest methodsFor: 'tests - exception handlers' stamp: ''!
testInjectingExceptionHandlerIntoRunningProcess
	| error interceptedError process sema started interrupted |
	DefaultExecutionEnvironment beActive.
	error := Error new messageText: 'test error'.
	sema := Semaphore new.
	started := false.
	interrupted := true.
	process := [ started := true.
	sema wait.
	error signal.
	interrupted := false ] newProcess.
	process resume.
	[ started ] whileFalse: [ Processor yield ].

	process
		on: Error
		do: [ :err | interceptedError := err ].

	sema signal.
	[ process isTerminated ] whileFalse: [ Processor yield ].

	self assert: interceptedError identicalTo: error.
	self assert: interrupted! !

!ProcessTest methodsFor: 'tests - creation' stamp: ''!
testNewProcessWith

	| hasBlockRun block process passedArguments receivedArgument1 receivedArgument2 |
	hasBlockRun := false.
	block := [ :a :b |
		receivedArgument1 := a.
		receivedArgument2 := b.
		hasBlockRun := true ].
	passedArguments := #(1 2).
	process := block newProcessWith: passedArguments.
	
	"Returns immediately"
	self deny: hasBlockRun.
	
	self assert: (process isKindOf: Process).
	
	"Process has not been scheduled"
	self assert: process isSuspended.
	
	process resume.
	[process isTerminated] whileFalse: [ Processor yield ].
	
	"Each element in the collection argument was passed separately to the block"
	self assert: { receivedArgument1. receivedArgument2 } equals: passedArguments.! !

!ProcessTest methodsFor: 'tests - termination' stamp: ''!
testTerminationShouldProceedAllEnsureBlocksIfSomeWasFailed

	| ensureCalled process ensureFailure started unwindError |
	ensureFailure := Error new messageText: 'signalled inside ensure'.
	ensureCalled := false.
	started := false.
	process := [ 
		[ 
		[[started := true. 10 seconds wait] 
			ensure: [ ensureFailure signal ]]
				ensure: [ ensureCalled := true ].
		] on: UnwindError do: [ :err | unwindError := err ]
	] forkAt: Processor activePriority + 1.

	"We terminate the process in backround using higher priority
	to ensure that all forked processes during the termination logic will finish before the test continue.
	The UnwindError during termination is always signalled by fork"
	[ process terminate ] forkAt: Processor activePriority + 1.
	self assert: ensureCalled.
	self assert: unwindError signalerContext sender exception equals: ensureFailure! !

!ProcessTest methodsFor: 'tests - termination' stamp: ''!
testTerminationShouldProceedEnsureBlocks

	| ensureCalled process semaphore |
	ensureCalled := false.
	semaphore := Semaphore new.
	process := [ 
		[semaphore signal. [10 milliSeconds wait] repeat] ensure: [ ensureCalled := true ]
	] fork.
	semaphore wait.
	
	process terminate.
	self assert: ensureCalled! !

!ProcessTest methodsFor: 'tests - termination' stamp: ''!
testIsTerminatingForcedTerminationWithoutRunning
	| process unwound started terminator |
	unwound := false.
	started := false.
	process := [ started := true.
	[ Semaphore new wait ]
		ensure: [ terminator := Processor activeProcess.
			unwound := true ] ] newProcess.
	"This will prevent the process from getting a chance to run.
	Effectively the pc of suspendedContext will be equal to startpc."
	process priority: Processor systemBackgroundPriority.

	self assert: process isSuspended.
	self deny: process isTerminating.
	self deny: process isTerminated.
	self deny: started.
	self deny: unwound.

	process resume.
	self deny: process isSuspended.
	self deny: process isTerminating.
	self deny: process isTerminated.
	self deny: unwound.

	process terminate.
	self deny: process isSuspended.
	self assert: process isTerminating.
	self assert: process isTerminated.
	"The process never ran"
	self deny: started.
	"No unwind blocks were ever activated, so the next two lines can't be true."
	self deny: unwound.
	self deny: terminator identicalTo: process! !

!ProcessTest methodsFor: 'tests' stamp: ''!
testYield

	| lowerHasRun lowerPriority same1HasRun same2HasRun |
	lowerHasRun := same1HasRun := same2HasRun := false.
	lowerPriority := Processor activeProcess priority - 10 min: 10.
	[ lowerHasRun := true ] forkAt: lowerPriority.
	[ same1HasRun := true ] fork.
	[ same2HasRun := true ] fork.

	Processor yield.
	
	"All processes of same priority have been given a chance to execute"
	self assert: same1HasRun.
	self assert: same2HasRun.
	self deny: lowerHasRun.! !

!ProcessorScheduler commentStamp: ''!
My single instance,  named Processor,  coordinates the use of the physical processor by all Processes requiring service.

My instances variables are managed by the VM. The VM has for role to choose which process should be executed and when.

NB: DelayBasicScheduler is THE HIGHEST priority code which is run in Pharo. See DelayBasicScheduler for additional comments.
!
!ProcessorScheduler methodsFor: 'priority names' stamp: ''!
timingPriority
	"Answer the priority at which the system processes keeping track of real 
	time should run."
	"BEFORE USING IT: please read the 'Original word of advice' in the DelayScheduler class comment. 
	TL;DR: for top priority processes use 'Processor timingPriority - 1' except if you really know what you are doing!!"

	^TimingPriority! !

!ProcessorScheduler methodsFor: 'accessing' stamp: ''!
backgroundProcess
	"Answer the background process"
	^ BackgroundProcess! !

!ProcessorScheduler methodsFor: 'accessing' stamp: ''!
realActiveProcess
	"Answers the real currently running Process (ignoring any effective process installed).
	Method should be used carefully only in specific low level parts of the system.
	End users should use #activeProcess instead. 

	This method is not debuggable because stepping over it would wrongly return an actual UI process of the debugger instead of a process under the debugger. 
	But this is the required property for the use cases like debugger requests which must work with real running process (not a simulated one)"

	^activeProcess! !

!ProcessorScheduler methodsFor: 'priority names' stamp: ''!
userInterruptPriority
	"Answer the priority at which user processes desiring immediate service 
	should run. Processes run at this level will preempt the window 
	scheduler and should, therefore, not consume the processor forever."

	^UserInterruptPriority! !

!ProcessorScheduler methodsFor: 'CPU usage tally' stamp: ''!
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: 'accessing' stamp: ''!
highestPriority: newHighestPriority
	"Change the number of priority levels currently available for use."

	| 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: ProcessList new].
	quiescentProcessLists := newProcessLists! !

!ProcessorScheduler methodsFor: 'accessing' stamp: ''!
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: 'priority names' stamp: ''!
lowIOPriority
	"Answer the priority at which most input/output processes should run. 
	Examples are the process handling input from the user (keyboard, 
	pointing device, etc.) and the process distributing input from a network."

	^LowIOPriority! !

!ProcessorScheduler methodsFor: 'CPU usage tally' stamp: ''!
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: 'printing' stamp: ''!
printOn: aStream
	self isSelfEvaluating ifFalse: [^super printOn: aStream].
	aStream nextPutAll: #Processor! !

!ProcessorScheduler methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating
	^self == Processor! !

!ProcessorScheduler methodsFor: 'process state change' stamp: ''!
suspendFirstAt: aPriority ifNone: noneBlock 
	"Suspend the first Process that is waiting to run with priority aPriority. If 
	no Process is waiting, evaluate the argument, noneBlock."

	| aList |
	aList := quiescentProcessLists at: aPriority.
	aList isEmpty
		ifTrue: [^noneBlock value]
		ifFalse: [^aList first suspend]! !

!ProcessorScheduler methodsFor: 'priority names' stamp: ''!
lowestPriority
	"Return the lowest priority that is allowed with the scheduler"
	^SystemRockBottomPriority! !

!ProcessorScheduler methodsFor: 'priority names' stamp: ''!
highIOPriority
	"Answer the priority at which the most time critical input/output 
	processes should run. An example is the process handling input from a 
	network."

	^HighIOPriority! !

!ProcessorScheduler methodsFor: 'accessing' stamp: ''!
highestPriority
	"Answer the number of priority levels currently available for use."
	"NB: If you are looking to set a priority when forking a process, please use the methods in 'priority names' protocol"

	^quiescentProcessLists size! !

!ProcessorScheduler methodsFor: 'private' stamp: ''!
interpriorityYield: modifiedProcess

	"The original yield only works within processes of the same priority.
	The primitive does not try to resume a process in a higher priority.
	By forcing the creation of a new process and suspending this one, 
	we force the rescheduling of processes. 
	
	This message should not be used directly. 
	The only application so far is when changing the priority of a process.
	"

	modifiedProcess isActiveProcess ifFalse: [ ^ self ].
	[ modifiedProcess resume ] fork.
	modifiedProcess suspend! !

!ProcessorScheduler methodsFor: 'accessing' stamp: ''!
activeProcess
	"Answers the currently running Process.
	It can be just pretending to be the active process
	(like during the code simulation in the debugger)"

	^activeProcess effectiveProcess! !

!ProcessorScheduler methodsFor: 'CPU usage tally' stamp: ''!
nextReadyProcess
	quiescentProcessLists reverseDo: [ :list |
		list isEmpty ifFalse: [ | proc |
			proc := list first.
			proc suspendedContext ifNotNil: [ ^proc ]]].
	^nil! !

!ProcessorScheduler methodsFor: 'accessing' stamp: ''!
activePriority
	"Answer the priority level of the currently running Process."

	^self activeProcess priority! !

!ProcessorScheduler methodsFor: 'priority names' stamp: ''!
userBackgroundPriority
	"Answer the priority at which user background processes should run."

	^UserBackgroundPriority! !

!ProcessorScheduler methodsFor: 'priority names' stamp: ''!
userSchedulingPriority
	"Answer the priority at which the window scheduler should run."

	^UserSchedulingPriority! !

!ProcessorScheduler methodsFor: 'process state change' stamp: ''!
terminateActive
	"Terminate the process that is currently running."

	self activeProcess doTerminationFromYourself! !

!ProcessorScheduler methodsFor: 'process state change' stamp: ''!
terminateRealActive
	"IMPORTANT: Do not step over this method in the debugger (normally you will never do it) because it will terminate the UIProcess of the debugger instead of the process under the debugger.
	Method should not be used by users. It is only for specific low level places of the system like a normal process termination.
	
	It terminates the active process that is really currently running despite on any effective process installed. 	
	It is very critical to ignore the simulation trick of the debugger (the effective process) during the normal completion of the process. This method ensures that every process is able to complete. 
	Previously #terminateActive was used for the process completion. But #terminateActive targets the effective process which the debugger sets for the stepping over the Processor calls. Debugger resets this value at the end of stepping but there are huge amount of cases where it is impossible to do or due to the bugs in the debugger implementation.
	The consequences of unreset effective process is inability of the process to finish the execution.
	The following scenario happens in this case: 
	- Process completes by ```Processor terminateActive``` call (it is the end of any process). 
	- #terminateActive can't terminate the real active process because the effective one is used.
	- Without the stop the #terminateActive continutes the execution to the nil sender (it is nil after the full unwind during Process>>terminate).
	- The return to nil sender causes the VM fallback logic. It sends #cannotReturn: message to the context.
	- #cannotReturn: method raises an error which requests the debugger
	- Debugger is opened in UI process and the current process is suspended to stop the execution.
	- To suspend the current process the debugger uses ```Processor activeProcess suspend`` 
	- The active process there is not a real process due to effectiveProcess state.
	- Suspend is executed over wrong process 
	- Really running process continues the execution after #suspend.
	- Execution tries to return from cannotReturn: method to the nil sender.
	- VM sends again #cannotReturn: message. 
	- Image hangs due to this infinite recursion triggering new debugger at every step.
	
	In other words the effective process trick is very dangerous mechanizm and critical system operations must avoid it. 
	Therefore this method. It is used only as the last instruction for the process termination. See #newProcess for example: 
			[ self value, Processor terminateRealActive ]
	"

	activeProcess doTerminationFromYourself! !

!ProcessorScheduler methodsFor: 'private' stamp: ''!
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 methodsFor: 'process state change' stamp: ''!
suspendFirstAt: aPriority 
	"Suspend the first Process that is waiting to run with priority aPriority."

	^self suspendFirstAt: aPriority
		  ifNone: [self error: 'No Process to suspend']! !

!ProcessorScheduler methodsFor: 'accessing' stamp: ''!
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: 'process state change' stamp: ''!
yield
	"Give other Processes at the current priority a chance to run."

	| semaphore |

	<primitive: 167>
	semaphore := Semaphore new.
	[semaphore signal] fork.
	semaphore wait! !

!ProcessorScheduler methodsFor: 'priority names' stamp: ''!
systemBackgroundPriority
	"Answer the priority at which system background processes should run. 
	Examples are an incremental garbage collector or status checker."

	^SystemBackgroundPriority! !

!ProcessorScheduler methodsFor: 'accessing' stamp: ''!
waitingProcessesAt: aPriority
	"Return the list of processes at the given priority level."
	^quiescentProcessLists at: aPriority! !

!ProcessorScheduler methodsFor: '*Reflectivity' stamp: ''!
rfactiveProcess
	"Answer the currently running Process."
	<metaLinkOptions: #( + optionDisabledLink)>
	^activeProcess rfeffectiveProcess! !

!ProcessorScheduler methodsFor: 'removing' stamp: ''!
remove: aProcess ifAbsent: aBlock 
	"Remove aProcess from the list on which it is waiting for the processor 
	and answer aProcess. If it is not waiting, evaluate aBlock."

	(quiescentProcessLists at: aProcess priority)
		remove: aProcess ifAbsent: aBlock.
	^aProcess! !

!ProcessorScheduler class methodsFor: 'instance creation' stamp: ''!
new
	"New instances of ProcessorScheduler should not be created."

	self error:
'New ProcessSchedulers should not be created since
the integrity of the system depends on a unique scheduler'! !

!ProcessorScheduler class methodsFor: 'background process' stamp: ''!
startUp
	"Install a background process of the lowest possible priority that is always runnable."
	"Details: The virtual machine requires that there is always some runnable process that can be scheduled; this background process ensures that this is the case."

	Smalltalk installLowSpaceWatcher.
	BackgroundProcess ifNotNil: [BackgroundProcess terminate].
	BackgroundProcess := [self idleProcess] newProcess.
	BackgroundProcess priority: SystemRockBottomPriority.
	BackgroundProcess name: 'Idle Process'.
	BackgroundProcess resume.! !

!ProcessorScheduler class methodsFor: 'class initialization' stamp: ''!
initialize
	"ProcessorScheduler initialize."
	     
	SystemRockBottomPriority := 10.
	SystemBackgroundPriority := 20.
	UserBackgroundPriority := 30.
	UserSchedulingPriority := 40.
	UserInterruptPriority := 50.
	LowIOPriority := 60.
	HighIOPriority := 70.
	TimingPriority := 80.
	IdleTime := 50000.

	SessionManager default
		registerSystemClassNamed: self name
		atPriority: 30.! !

!ProcessorScheduler class methodsFor: 'settings' stamp: ''!
idleTimeSettingOn: aBuilder
	<systemsettings>
	
	(aBuilder setting: #idleTime)
		target: self;
		parent: #pharoSystem ;
		default: 50000;
		label: 'Default idle time for the system (microseconds)' ;
		description: 'Detault idle time for the Pharo process in case of inactivity. In idle mode, the system can be awakened by a signal. This value can limit the minimal delay time.'! !

!ProcessorScheduler class methodsFor: 'settings' stamp: ''!
idleTime: microsecondsCount

	IdleTime := microsecondsCount! !

!ProcessorScheduler class methodsFor: 'background process' stamp: ''!
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."

	<primitive: 230>
	"don't fail if primitive is not implemented, just do nothing"! !

!ProcessorScheduler class methodsFor: 'settings' stamp: ''!
idleTime

	"The default idle time for the Pharo process in case of inactivity. In idle mode, the system can be awakened by a signal. This value can limit the minimal delay time."
	
	^ IdleTime! !

!ProcessorScheduler class methodsFor: 'background process' stamp: ''!
idleProcess
	"A default background process which is invisible. During the idle time, the delays may not wake up."

	[true] whileTrue:
		[self relinquishProcessorForMicroseconds: IdleTime]! !

!ProfStef commentStamp: ''!
ProfStef is the Pharo teacher. To start the tutorial, evaluate:

[[[ 
ProfStef go.
]]]
To go to the next lesson evaluate:

[[[
ProfStef next.
]]]

To execute your own tutorial:
[[[
ProfStef goOn: MyOwnTutorial
]]]

MyOwnTutorial should be a subclass of AbstractTutorial.

To see a table of contents with all defined tutorials:

[[[
ProfStef contents 

Metacello Configuration Tutorial Part1
	ProfStef goOn: MetacelloConfigurationTutorialPart1

Metacello Configuration Tutorial Part2
	ProfStef goOn: MetacelloConfigurationTutorialPart2

Metacello Development Cycle
	ProfStef goOn: MetacelloDevelopmentProcess

Inside Metacello Toolbox API
	ProfStef goOn: MetacelloToolBoxTutorial

Pharo Syntax Tutorial
	ProfStef goOn: PharoSyntaxTutorial

'
]]]

Metacello Configuration Tutorial Part1
	ProfStef goOn: MetacelloConfigurationTutorialPart1

Metacello Configuration Tutorial Part2
	ProfStef goOn: MetacelloConfigurationTutorialPart2

Metacello Development Cycle
	ProfStef goOn: MetacelloDevelopmentProcess

Inside Metacello Toolbox API
	PharoTutorial goOn: MetacelloToolBoxTutorial

Pharo Syntax Tutorial
	ProfStef goOn: PharoSyntaxTutorial
'
]]]

ProfStef is interacting with a tutorial player (which encapsulate the logic of navigating within lessons) and lessonView (a dead simple little UI).

!
!ProfStef methodsFor: 'accessing' stamp: ''!
player: aTutorialPlayer

	player := aTutorialPlayer! !

!ProfStef methodsFor: 'navigating' stamp: ''!
previous

	self helpBrowserWindow 
		ifNotNil: [:window | window model previous ].
	self lessonView isOpenInWindow 
		ifTrue: [ 
			self player previous.
			self showCurrentLesson ]! !

!ProfStef methodsFor: 'navigating' stamp: ''!
goOn: aTutorialClass

	self player tutorial: aTutorialClass new.
	^ self open! !

!ProfStef methodsFor: 'accessing' stamp: ''!
tutorialPositionString

	^ player tutorialPosition asString! !

!ProfStef methodsFor: 'navigating' stamp: ''!
go

	^ self goOn: PharoSyntaxTutorial! !

!ProfStef methodsFor: 'navigating' stamp: ''!
next

	self helpBrowserWindow 
		ifNotNil: [:window | window model next ].
	self lessonView isOpenInWindow 
		ifTrue: [ 
			self player next.
			self showCurrentLesson ]! !

!ProfStef methodsFor: 'instance creation' stamp: ''!
open

	self player first.
	^ self showCurrentLesson! !

!ProfStef methodsFor: 'gui' stamp: ''!
showCurrentLesson

	| progressInfo lesson |
	lesson := self player currentLesson.
	progressInfo := '(', self tutorialPositionString, '/', self tutorialSizeString, ')'. 
	^ self lessonView 
		showLesson: lesson 
		withTitle: lesson title, ' ', progressInfo! !

!ProfStef methodsFor: 'accessing' stamp: ''!
lessonView

	^ lessonView 
			ifNil: [ lessonView := LessonView new ]! !

!ProfStef methodsFor: 'accessing' stamp: ''!
tutorial: aTutorialClass lessonAt: lessonIndex

	self player tutorial: aTutorialClass new.
	self player tutorialPosition: lessonIndex.
	self showCurrentLesson! !

!ProfStef methodsFor: 'accessing' stamp: ''!
tutorialSizeString

	^ self player size asString! !

!ProfStef methodsFor: 'private - accessing' stamp: ''!
helpBrowserWindow
	"Yes this is a hack"
	
	^ self currentWorld systemWindows 
		detect: [ :each | each model class = HelpBrowser ] 
		ifNone: [ nil ]! !

!ProfStef methodsFor: 'navigating' stamp: ''!
first

	self player first.
	^ self showCurrentLesson! !

!ProfStef methodsFor: 'navigating' stamp: ''!
last

	self player last.
	^ self showCurrentLesson! !

!ProfStef methodsFor: 'gui' stamp: ''!
close

	self lessonView close! !

!ProfStef methodsFor: 'navigating' stamp: ''!
tutorial: aTutorialClass lesson: aSelector

	| tutorial |
	tutorial := aTutorialClass new.
	self player tutorial: tutorial.
	self tutorial: aTutorialClass lessonAt: (tutorial indexOfLesson: aSelector)! !

!ProfStef methodsFor: 'accessing' stamp: ''!
lessonView: aLessonView

	lessonView := aLessonView! !

!ProfStef methodsFor: 'accessing' stamp: ''!
player

	^ player ifNil: [ player := TutorialPlayer new ]! !

!ProfStef class methodsFor: 'navigating' stamp: ''!
previous

	^ self default previous! !

!ProfStef class methodsFor: 'navigating' stamp: ''!
goOn: aTutorialClass

	^ self default goOn: aTutorialClass.! !

!ProfStef class methodsFor: 'navigating' stamp: ''!
go

	^ self default go.! !

!ProfStef class methodsFor: 'zen' stamp: ''!
aboutPharoZen
	^ 'These are the Pharo Zen values.\\See:\\  ProfStef class>>#pharoZenValues\\Inspect:\\  PharoTutorial pharoZenValues' withCRs! !

!ProfStef class methodsFor: 'navigating' stamp: ''!
next

	^ self default next! !

!ProfStef class methodsFor: 'zen' stamp: ''!
pharoZenValuesContents
	"Return a string with CRs listing the Pharo Zen values in random order"
 	
	^ String streamContents: [ :stream | 
			stream << (self class >> #pharoZenValues) comment withoutQuoting; cr; cr.
			self pharoZenValues shuffled 
				do: [ :each | stream << each ] 
				separatedBy: [ stream cr ]]! !

!ProfStef class methodsFor: 'starting' stamp: ''!
tutorial: aTutorialClass lessonAt: lessonIndex

	self default tutorial: aTutorialClass lessonAt: lessonIndex! !

!ProfStef class methodsFor: 'class initialization' stamp: ''!
default

	^ Instance ifNil: [ Instance := self new ]! !

!ProfStef class methodsFor: 'navigating' stamp: ''!
first

	^ self default first.! !

!ProfStef class methodsFor: 'navigating' stamp: ''!
last

	^ self default last! !

!ProfStef class methodsFor: 'accessing' stamp: ''!
contents
	"Build table of contents with all defined tutorials."

	^ AbstractTutorial contentsOfTutorials! !

!ProfStef class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	
	(aBuilder item: #'Pharo Zen')
		parent: #PharoHelp;
		order: 3;
		action: [ self openPharoZenWorkspace ];
		icon: ((self iconNamed: #pharoIcon) scaledToSize: 16@16);
		help: 'Pharo values.'! !

!ProfStef class methodsFor: 'zen' stamp: ''!
openPharoZenWorkspace
    "Open a Workspace showing the Pharo Zen values in random order"

    <script>
    | presenter |
    presenter := SpTextPresenter new
        text: self pharoZenValuesContents;
        openWithSpec.

    presenter
        withWindowDo: [ :w | 
            w
                title: 'Pharo Zen' translated;
                aboutText: self aboutPharoZen ]! !

!ProfStef class methodsFor: 'zen' stamp: ''!
pharoZenValues
	"Our values and convictions are condensed in this simple list."
	
	^ #(
		'Easy to understand, easy to learn from, easy to change.' 
		'Objects all the way down.' 
		'Examples to learn from.' 
		'Fully dynamic and malleable.' 
		'Beauty in the code, beauty in the comments.' 
		'Simplicity is the ultimate elegance.' 
		'Better a set of small polymorphic classes than a large ugly one.' 
		'Classes structure our vocabulary.' 
		'Messages are our vocabulary.' 
		'Polymorphism is our esperanto.' 
		'Abstraction and composition are our friends.' 
		'Tests are important but can be changed.' 
		'Explicit is better than implicit.' 
		'Magic only at the right place.' 
		'One step at a time.' 
		'There is no unimportant fix.' 
		'Learning from mistakes.' 
		'Perfection can kill movement.' 
		'Quality is an emerging property.' 
		'Simple processes to support progress.' 
		'Communication is key.' 
		'A system with robust abstractions that a single person can understand.' )! !

!ProfStef class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
		
	Instance := nil! !

!ProfStef class methodsFor: 'cleanup' stamp: ''!
cleanUp

	self reset! !

!ProfStef class methodsFor: 'starting' stamp: ''!
tutorial: aTutorialClass lesson: aSelector

	self default tutorial: aTutorialClass lesson: aSelector! !

!ProgressBarMorph commentStamp: ''!
Instances of this morph get used by SystemProgressMorph or a JobProgressBar to display a bar (i.e., the rectangular part of a progress bar).

Here is an example of how to use it. 

| p |
p := ProgressBarMorph from: 0 to: 200.
p extent: 200@20.
p openInWorld.

[
	(1 to: 200) do: [ :i | p value: i.  (Delay forMilliseconds: 10) wait ].
	p delete ] fork


| p |
p := ProgressBarMorph from: 0 to: 200.
p extent: 600@7.
p openInWorld.

[
	(1 to: 200) do: [ :i | p value: i.  (Delay forMilliseconds: 5) wait ].
	p delete ] fork!
!ProgressBarMorph methodsFor: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!ProgressBarMorph methodsFor: 'accessing' stamp: ''!
value: aNumber
	|testWidth|
	value := aNumber.
	testWidth := self completedWidth.
	testWidth ~= cachedWidth ifTrue: [  
		cachedWidth := testWidth.
		self changed]! !

!ProgressBarMorph methodsFor: 'drawing' stamp: ''!
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: [ 
			cachedWidth := self completedWidth.
			area := area origin extent: cachedWidth @ area height.
			aCanvas fillRectangle: area fillStyle: self barFillStyle ].
	self borderStyle frameRectangle: self bounds on: aCanvas! !

!ProgressBarMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!ProgressBarMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver from the current theme."
	
	super initialize.
	value := 0.
	start := 0.
	end := 100.
	height := DefaultHeight.
	width := DefaultWidth.
	cachedWidth := 0.
	self 
		fillStyle: (self theme progressBarFillStyleFor: self);
		borderStyle: (self theme progressBarBorderStyleFor: self);
		barFillStyle: (self theme progressBarProgressFillStyleFor: self);
		extent: width@height  + (2 * self borderWidth).! !

!ProgressBarMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!ProgressBarMorph methodsFor: 'private' stamp: ''!
startAt: aNumber 

	value := start := aNumber.! !

!ProgressBarMorph methodsFor: 'private' stamp: ''!
privateMoveBy: delta 
	"Update the bar fillStyle if appropriate."
	
	| fill |
	super privateMoveBy: delta.
	fill := self barFillStyle.
	fill isOrientedFill ifTrue: [fill origin: fill origin + delta]! !

!ProgressBarMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!ProgressBarMorph methodsFor: 'private' stamp: ''!
barFillStyle: aFillStyle
	"Set the fillStyle for the bar."

	^self setProperty: #barFillStyle toValue: aFillStyle! !

!ProgressBarMorph methodsFor: 'accessing' stamp: ''!
increment

	self value: self value + 1.! !

!ProgressBarMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!ProgressBarMorph methodsFor: 'private' stamp: ''!
totalBarWidth

	^ self width - (2 * self borderWidth).! !

!ProgressBarMorph methodsFor: 'accessing' stamp: ''!
value
	
	^ value.! !

!ProgressBarMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!ProgressBarMorph methodsFor: 'private' stamp: ''!
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: ''!
endAt: aNumber 

	end := aNumber.! !

!ProgressBarMorph methodsFor: 'private' stamp: ''!
completedWidth

	| range fraction progress |
	range := end - start.
	progress := value - start.
	fraction := progress / range.
	^ (fraction * self totalBarWidth) truncated.! !

!ProgressBarMorph methodsFor: 'geometry' stamp: ''!
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: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!ProgressBarMorph methodsFor: 'accessing' stamp: ''!
decrement

	self value: self value - 1.! !

!ProgressBarMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ProgressBarMorph class methodsFor: 'defaults' stamp: ''!
defaultWidth: aNumber
	
	DefaultWidth := aNumber.! !

!ProgressBarMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ProgressBarMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ProgressBarMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ProgressBarMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ProgressBarMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ProgressBarMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ProgressBarMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ProgressBarMorph class methodsFor: 'class initialization' stamp: ''!
initialize
	
	self defaultWidth: 120.
	self defaultHeight: 10! !

!ProgressBarMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ProgressBarMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ProgressBarMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ProgressBarMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ProgressBarMorph class methodsFor: 'defaults' stamp: ''!
defaultHeight: aNumber

	DefaultHeight := aNumber! !

!ProgressBarMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ProgressBarMorph class methodsFor: 'instance creation' stamp: ''!
from: startNumber to: endNumber

	^ self new
		startAt: startNumber;
		endAt: endNumber.! !

!ProgressBarMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ProgressBarMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ProgressBarMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ProgressBarMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ProgressBarMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ProgressBarMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ProgressBarMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ProgressBarMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ProgressBarMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ProgressBarMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ProgressBarMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ProgressBarMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ProgressBarMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ProgressBarMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ProgressBarMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ProgressBarMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ProgressNotification commentStamp: ''!
Used to signal progress without requiring a specific receiver to notify. Caller/callee convention could be to simply count the number of signals caught or to pass more substantive information with #signal:.!
!ProgressNotification methodsFor: 'accessing' stamp: ''!
extraParam: anObject
	extra := anObject! !

!ProgressNotification methodsFor: 'accessing' stamp: ''!
amount
	^amount! !

!ProgressNotification methodsFor: 'accessing' stamp: ''!
done: aNumber
	done := aNumber! !

!ProgressNotification methodsFor: 'accessing' stamp: ''!
done
	^done! !

!ProgressNotification methodsFor: 'accessing' stamp: ''!
amount: aNumber
	amount := aNumber! !

!ProgressNotification methodsFor: 'accessing' stamp: ''!
extraParam
	^extra! !

!ProgressNotification class methodsFor: 'exceptioninstantiator' stamp: ''!
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! !

!ProperMethodCategorizationTest commentStamp: ''!
Tests to enforce proper categorization of methods!
!ProperMethodCategorizationTest methodsFor: 'tests - object' stamp: ''!
testDeepCopyMethodNeedsToBeInCopyingProtocol
	"The #deepCopy methods should be in method protocol 'copying'"
	
	self assureAll: #deepCopy areCategorizedIn: #copying whenSubclassOf: Object
! !

!ProperMethodCategorizationTest methodsFor: 'utilities' stamp: ''!
assureAll: selector areCategorizedIn: protocol whenSubclassOf: aClass

	| violating |
	violating := OrderedCollection new.
	aClass allSubclassesDo: [:cls | cls methods do: [:m |
			(m selector = selector and: [ m protocol ~= protocol ])
				ifTrue: [ violating add: m -> m protocol ] ] ].
	self 
		assert: violating isEmpty 
		description: ('Violations: {1}.
		Reason: {1} subclasses should have #{2} in protocol {3}' 
			format: { self explanationFrom: violating . aClass asString. selector. protocol })
! !

!ProperMethodCategorizationTest methodsFor: 'utilities' stamp: ''!
assureAll: selector areCategorizedInProtocols: protocols whenSubclassOf: aClass
	"Test whether the selector is categorized in at least the collection of protocols"
	
	| violating |
	violating := OrderedCollection new.
	aClass allSubclassesDo: [:cls | cls methods do: [:m |
			(m selector = selector 
				and: [ (protocols includes: m protocol) not ])
					ifTrue: [ violating add: m -> m protocol ] ] ].
	self 
		assert: violating isEmpty 
		description: ('Violations are: {1}. 
		Reason: {2} subclasses should have #{3} in protocols: {4}' 
			format: { self explanationFrom: violating . aClass asString. selector. protocols })
! !

!ProperMethodCategorizationTest methodsFor: 'tests - object' stamp: ''!
testFinalizeMethodNeedsToBeInComparingProtocol
	"The #finalize method should be in method protocol 'finalization'"
	
	self assureAll: #finalize areCategorizedIn: #finalization whenSubclassOf: Object
! !

!ProperMethodCategorizationTest methodsFor: 'tests - sunit' stamp: ''!
testSetUpMethodInSUnitTestsNeedsToBeInRunningProtocol
	"The #setUp method in SUnit test classes should be in method protocol 'running'"

	self assureAll: #setUp areCategorizedInProtocols: #(#running) whenSubclassOf: TestCase
! !

!ProperMethodCategorizationTest methodsFor: 'tests - object' stamp: ''!
testShallowCopyMethodNeedsToBeInCopyingProtocol
	"The #shallowCopy methods should be in method protocol 'copying'"
	
	self assureAll: #shallowCopy areCategorizedIn: #copying whenSubclassOf: Object
! !

!ProperMethodCategorizationTest methodsFor: 'tests - sunit' stamp: ''!
testTearDownMethodInSUnitTestsNeedsToBeInRunningProtocol
	"The #tearDown method in SUnit test classes should be in method protocol 'running'"
	
	self assureAll: #tearDown areCategorizedInProtocols: #(#running) whenSubclassOf: TestCase
! !

!ProperMethodCategorizationTest methodsFor: 'tests - object' stamp: ''!
testEqualMethodNeedsToBeInComparingProtocol
	"The #= method should be in method protocol 'comparing'"
	
	self assureAll: #= areCategorizedIn: #comparing whenSubclassOf: Object
! !

!ProperMethodCategorizationTest methodsFor: 'tests - object' stamp: ''!
testVeryDeepCopyMethodNeedsToBeInCopyingProtocol
	"The #veryDeepCopy methods should be in method protocol 'copying'"
	
	self assureAll: #veryDeepCopy areCategorizedIn: #copying whenSubclassOf: Object
! !

!ProperMethodCategorizationTest methodsFor: 'tests' stamp: ''!
testNoUtilsMethods
	"Check that we have no #'utils' protocols left, the protocol should be 'utilities' "

	| violating |
	violating := Smalltalk globals allBehaviors select: [ :class | 
		             class protocols includes: #'utils' ].

	"we lock in the number of problematic classes, this way it can only improve"
	self assert: violating size <= 4! !

!ProperMethodCategorizationTest methodsFor: 'tests - object' stamp: ''!
testCloneMethodNeedsToBeInCopyingProtocol
	"The #clone methods should be in method protocol 'copying'"
	
	self assureAll: #clone areCategorizedIn: #copying whenSubclassOf: Object
! !

!ProperMethodCategorizationTest methodsFor: 'tests - object' stamp: ''!
testFinalizeValuesMethodNeedsToBeInComparingProtocol
	"The #finalizeValues methods should be in method protocol 'finalization'"
	
	self assureAll: #finalizeValues areCategorizedIn: #finalization whenSubclassOf: Object
! !

!ProperMethodCategorizationTest methodsFor: 'tests - instance creation' stamp: ''!
testBasicNewMethodNeedsToBeInInstanceCreationProtocol
	"The #basicNew methods should be in method protocol 'instance creation'"
	
	self assureAll: #basicNew areCategorizedIn: #'instance creation' whenSubclassOf: Object class
! !

!ProperMethodCategorizationTest methodsFor: 'tests' stamp: ''!
testNoEmptyProtocols
	"Check that we have no protocols left without methods"

	| violating protocolsWithoutMethods |
	violating := Dictionary new.
	ProtoObject withAllSubclasses
		do: [ :cls | 
			protocolsWithoutMethods := cls organization protocolOrganizer protocols select: [ :e | e isEmpty and: [ e canBeRemoved ] ].
			protocolsWithoutMethods notEmpty ifTrue: [ violating at: cls put: protocolsWithoutMethods ] ].

	self assertEmpty: violating! !

!ProperMethodCategorizationTest methodsFor: 'utilities' stamp: ''!
explanationFrom: aCol

	^ (String streamContents: [:str | 
				aCol do: [:p | p key printOn: str]
					separatedBy: [ str nextPutAll: ' ,'] ]).! !

!ProperMethodCategorizationTest methodsFor: 'tests - object' stamp: ''!
testPostCopyMethodNeedsToBeInCopyingProtocol
	"The #postCopy methods should be in method protocol 'copying'"
	
	self assureAll: #postCopy areCategorizedIn: #copying whenSubclassOf: Object
! !

!ProperMethodCategorizationTest methodsFor: 'tests - sunit' stamp: ''!
testRunCaseMethodInSUnitTestsNeedsToBeInRunningProtocol
	"The #tearDown method in SUnit test classes should be in method protocol 'running'"
	
	self assureAll: #runCase areCategorizedIn: #running whenSubclassOf: TestCase
! !

!ProperMethodCategorizationTest methodsFor: 'tests - object' stamp: ''!
testCopyMethodNeedsToBeInCopyingProtocol
	"The #copy methods should be in method protocol 'copying'"
	
	self assureAll: #copy areCategorizedIn: #copying whenSubclassOf: Object
! !

!ProperMethodCategorizationTest methodsFor: 'tests - object' stamp: ''!
testHashMethodNeedsToBeInComparingProtocol
	"The #hash method should be in method protocol 'comparing'"
	
	self assureAll: #hash areCategorizedIn: #comparing whenSubclassOf: Object
! !

!ProperMethodCategorizationTest methodsFor: 'tests' stamp: ''!
testNoLeadingOrTrailingSpacesInCategoryNames
	"Make sure we have no protocol names with leading or trailing spaces"
	
	| violations |
	violations := OrderedCollection new.

	Object allSubclasses do: [ :each | 
		each organization allCategories do: [ :cat | 
			((cat endsWith: ' ') or: [ cat endsWith: ' ' ]) ifTrue: [ 
				violations add: each -> cat ] ] ].
	
	self assert: violations isEmpty! !

!ProperMethodCategorizationTest methodsFor: 'tests' stamp: ''!
testNoUncategorizedMethods
	"Check that we have no #'as yet unclassified' protocols left"

	| violating |
	violating := Smalltalk globals allBehaviors select: [ :class | 
		             class protocols includes: Protocol unclassified ].

	"we lock in the number of problematic classes, this way it can only improve"
	self assert: violating size <= 33! !

!ProperPackagesTest commentStamp: ''!
Check for proper Manifest categorization!
!ProperPackagesTest methodsFor: 'tests - sunit' stamp: ''!
testNoPackageNameEndsWithTest

	self assert: (Smalltalk packages select: [:each | each name endsWith: 'Test' ]) isEmpty ! !

!ProperPackagesTest methodsFor: 'tests - manifest' stamp: ''!
testProperManifestCategorization
	"If a package provides a PackageManifest subclass then this manifest class should be packaged 
	 with 'Manifest' tag similar to all other manifests."
	
	|violations|
	violations := OrderedCollection new.
	PackageManifest allSubclassesDo: [:each |
 	   ((each package classesForClassTag: 'Manifest') includes: each)
  	      ifFalse: [ violations add: each ]
	].

	self assert: violations isEmpty.! !

!ProperPackagesTest methodsFor: 'tests' stamp: ''!
testProperClassTagCasing
	|violations|
	violations := OrderedCollection new.
	RPackageOrganizer default packages
        do: [:package | package classTags do: [:classTag | classTag name first isLowercase ifTrue: [ violations add: (package -> classTag) ] ] ].
	self assert:  violations isEmpty description: 'Class Tags should be uppercase'! !

!ProperlyImplementedSUnitClassesTest commentStamp: ''!
This class checks if test classes have been properly implemented!
!ProperlyImplementedSUnitClassesTest methodsFor: 'tests' stamp: ''!
testTestClassesShouldBeSingular

	| violations |
	"Ensure test class names are consistent"
	violations := Object allSubclasses select: [ :each | 
		              (each inheritsFrom: TestCase) and: [ each name endsWith: 'Tests' ] ].
	self assert: violations isEmpty! !

!ProperlyImplementedSUnitClassesTest methodsFor: 'tests' stamp: ''!
testAndMakeSureSuperSetupIsCalledAsFirstMessageInSetupMethodsOfTestCases
	"Verify that each setUp method in a unit test starts with a call to super setUp as first message sent"

	| violating |
	violating := OrderedCollection new.
	TestCase
		allSubclassesDo: [ :each | 
			each
				compiledMethodAt: #setUp
				ifPresent: [ :method | 
					(ReShouldSendSuperSetUpAsFirstMessage superSetUpNotCalledFirstIn: method)
						ifTrue: [ violating add: method ] ] ].
	self assertEmpty: violating! !

!ProperlyImplementedSUnitClassesTest methodsFor: 'tests' stamp: ''!
testAndMakeSureSuperTearDownIsCalledAsLastMessageInTearDownMethodsOfTestCases
	"Verify that each tearDown method in a unit test ends with a call to super tearDown as last message sent"

	| violating |
	violating := OrderedCollection new.
	TestCase
		allSubclassesDo: [ :each | 
			each
				compiledMethodAt: #tearDown
				ifPresent: [ :method | 
					(ReShouldSendSuperTearDownAsLastMessage
						superTearDownNotCalledLastIn: method)
						ifTrue: [ violating add: method ] ] ].
	self assertEmpty: violating! !

!PropertySlot commentStamp: ''!
I am a Slot that does not allocate one field for each slot. Instead, all PropertySlots of the whole hierarchy are allocated in a dictionary that is stored in an invisible slot (see PropertyBaseSlot)

Keep in mind:
- I am slower than instance variables
- there is the overhead of the Dictionary. Only if there are multiple ones of me in the class hierarchy you will save memory!
!PropertySlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	^ (baseSlot read: anObject) at: self name ifAbsent: nil! !

!PropertySlot methodsFor: 'class building' stamp: ''!
installingIn: aClass
	super installingIn: aClass.
	
	"we reuse a baselot if it is already there, if not, we add it"
	"TODO: this does not take into account adding PropertySlot higher up in the Hierarchy"
	aClass classLayout 
		resolveSlot: #'_propertyBaseSlot'   
		ifFound:  [: slot |  baseSlot := slot ]
		ifNone: [aClass addSlot: (baseSlot := #'_propertyBaseSlot' => BaseSlot default: Dictionary new)]
	! !

!PropertySlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
	^ (baseSlot read: anObject) at: self name put: aValue! !

!PropertySlot methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder
	"generate bytecode for '<baseSlot> at: name ifAbsent: nil'"
	methodBuilder
		pushInstVar: baseSlot index;
		pushLiteral: self name;
		pushLiteral: nil;
		send: #at:ifAbsent:
	
	! !

!PropertySlot methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder
	"generate bytecode for 'baseSlot at: 1 put: <stackTop>'"
	| tempName |
	tempName := '0slotTempForStackManipulation'.
	methodBuilder
		addTemp: tempName;
		storeTemp: tempName;
		popTop;
		pushInstVar: baseSlot index;
		pushLiteral: self name;
		pushTemp: tempName;
		send: #at:put:
	! !

!PropertySlotTest commentStamp: ''!
Test for PropertySlot!
!PropertySlotTest methodsFor: 'tests' stamp: ''!
testRemovePropertySlotWithInstance
	"add two property slots, remove one"
	
	| propertySlot1 propertySlot2 instance |
	
	propertySlot1 := #prop1 => PropertySlot.
	propertySlot2 := #prop2 => PropertySlot.
	
	aClass := self make: [ :builder |
		builder 
			slots: {propertySlot1 . propertySlot2 }
		].

	instance := aClass new.

	propertySlot1 write: 41 to: instance.
	propertySlot2 write: 42 to: instance.

	self assert: (propertySlot1 read: instance) equals: 41.
	self assert: (propertySlot2 read: instance) equals: 42.

	aClass removeSlot: propertySlot1.
	
	self assert:	(aClass hasSlot: propertySlot2).
	self deny: 	(aClass hasSlot: propertySlot1)
	
	! !

!PropertySlotTest methodsFor: 'tests' stamp: ''!
testRemovePropertySlotWithTwoInstances
	"add two property slots, remove one"
	
	| propertySlot1 propertySlot2 instance instance2 |
	
	propertySlot1 := #prop1 => PropertySlot.
	propertySlot2 := #prop2 => PropertySlot.
	
	aClass := self make: [ :builder |
		builder 
			slots: {propertySlot1 . propertySlot2 }
		].

	instance := aClass new.
	instance2 := aClass new.

	propertySlot1 write: 41 to: instance.
	propertySlot2 write: 42 to: instance.

	self assert: (propertySlot1 read: instance) equals: 41.
	self assert: (propertySlot2 read: instance) equals: 42.
	self assert: (propertySlot1 read: instance2) equals: nil.
	
	propertySlot1 write: 5 to: instance2.
	self assert: (propertySlot1 read: instance2) equals: 5
	
	! !

!PropertySlotTest methodsFor: 'tests' stamp: ''!
testRemovePropertySlot
	
	| propertySlot |
	
	propertySlot := #prop => PropertySlot.
	
	aClass := self make: [ :builder | builder slots: {propertySlot} ].

	self assert: (aClass hasSlot: propertySlot).
	self assert: (aClass classLayout hasSlot: (propertySlot instVarNamed: 'baseSlot')).
	
	aClass := self make: [ :builder | builder  slots: {} ].
	self deny: (aClass hasSlot: propertySlot).	
	self deny: (aClass classLayout hasSlot: (propertySlot instVarNamed: 'baseSlot')).
	self deny: (aClass classLayout hasSlotNamed: #'_propertyBaseSlot')! !

!PropertySlotTest methodsFor: 'tests' stamp: ''!
testRemovePropertySlot2
	"add two property slots, remove one"
	
	| propertySlot1 propertySlot2 |
	
	propertySlot1 := #prop1 => PropertySlot.
	propertySlot2 := #prop2 => PropertySlot.
	
	aClass := self make: [ :builder |
		builder 
			slots: {propertySlot1 . propertySlot2 }
		].

	self assert: (aClass hasSlot: propertySlot1).
	self assert: (aClass classLayout hasSlot: (propertySlot1 instVarNamed: 'baseSlot')).
	
	self assert: (aClass hasSlot: propertySlot2).
	self assert: (aClass classLayout  hasSlot: (propertySlot2 instVarNamed: 'baseSlot')).
	
	aClass := self make: [ :builder |
		builder 
			slots: {propertySlot1}
		].
	
	self assert:	(aClass hasSlot: propertySlot1).
	self deny: 	(aClass hasSlot: propertySlot2).
	self assert:	(aClass classLayout hasSlotNamed:  #'_propertyBaseSlot'). 
		
	aClass := self make: [ :builder |
		builder 
			slots: {}
		].
	
	self deny:	(aClass hasSlot: propertySlot1).
	self deny: 	(aClass hasSlot: propertySlot2).
	self deny:	(aClass classLayout hasSlotNamed:  #'_propertyBaseSlot')! !

!PropertySlotTest methodsFor: 'tests' stamp: ''!
testCreateClassWithTwoPropertySlots
	"Add instance variables using the builder interface"
	
	| propertySlot1 propertySlot2 |
	
	propertySlot1 := #prop1 => PropertySlot.
	propertySlot2 := #prop2 => PropertySlot.
	
	aClass := self make: [ :builder |
		builder 
			slots: {propertySlot1 . propertySlot2 }
		].

	self assert: (aClass hasSlot: propertySlot1).
	self assert: (aClass classLayout hasSlot: (propertySlot1 instVarNamed: 'baseSlot')).
	
	self assert: (aClass hasSlot: propertySlot2).
	self assert: (aClass classLayout  hasSlot: (propertySlot2 instVarNamed: 'baseSlot'))
	
	
	! !

!PropertySlotTest methodsFor: 'tests' stamp: ''!
testCreateClassWithPropertySlotAddSecond
	"Add instance variables using the builder interface"

	| propertySlot1 propertySlot2 |
	propertySlot1 := #prop1 => PropertySlot.
	propertySlot2 := #prop2 => PropertySlot.

	aClass := self make: [ :builder | builder slots: {propertySlot1} ].

	self assert: (aClass hasSlot: propertySlot1).
	self assert: (aClass classLayout hasSlot: (propertySlot1 instVarNamed: 'baseSlot')).

	aClass := self make: [ :builder | builder slots: {propertySlot1 . propertySlot2} ].

	self assert: (aClass hasSlot: propertySlot1).
	self assert: (aClass classLayout hasSlot: (propertySlot2 instVarNamed: 'baseSlot')).

	self assert: (propertySlot1 instVarNamed: 'baseSlot') identicalTo: (propertySlot2 instVarNamed: 'baseSlot').

	self assert: (aClass hasSlot: propertySlot2).
	self assert: (aClass classLayout hasSlot: (propertySlot2 instVarNamed: 'baseSlot'))! !

!PropertySlotTest methodsFor: 'tests' stamp: ''!
testCreateClassWithPropertySlot
	"Add instance variables using the builder interface"
	
	| propertySlot |
	
	propertySlot := #prop => PropertySlot.
	
	aClass := self make: [ :builder |
		builder 
			slots: {propertySlot}
		].

	self assert: (aClass hasSlot: propertySlot).
	self assert: (aClass classLayout hasSlot: (propertySlot instVarNamed: 'baseSlot'))
	
! !

!PropertySlotTest methodsFor: 'tests' stamp: ''!
testWhichSelectorsAccessFindSlots
	| cls |
	cls := Object newAnonymousSubclass.
	cls := cls addSlot: #regularIvar.
	cls := cls addSlot: #slotIvar => PropertySlot.
	cls
		compile:
			'initialize 
		super initialize.
	
		regularIvar := 4.
		slotIvar := 2.
	'.
	self
		assert: (cls whichSelectorsAccess: #regularIvar) size equals: 1;
		assert: (cls whichSelectorsAccess: #slotIvar) size equals: 1;
		assert: (cls whichSelectorsAccess: #notAnIvar) equals: #()! !

!PropertySortFunction commentStamp: ''!
I implement collation of objects using their property. Property is defined by selector or one arg block which can be converted directly to my instances:
	#name ascending.
	#name descending.
	[:a | a name] ascending
	[:a | a name] descending

Look at SortFunction comments for more details.

Internal Representation and Key Implementation Points.

    Instance Variables
	property		<Symbol, BlockClosure>
!
!PropertySortFunction methodsFor: 'converting' stamp: ''!
undefinedFirst
	"apply on the property"
	^self class
		property: property
		collatedWith: baseSortFunction undefinedFirst! !

!PropertySortFunction methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ baseSortFunction = anObject baseSortFunction
		and: [ property = anObject property ]! !

!PropertySortFunction methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash bitXor: property hash! !

!PropertySortFunction methodsFor: 'evaluating' stamp: ''!
collate: anObject with: another
	^ baseSortFunction collate: (property value: anObject) with: (property value: another)! !

!PropertySortFunction methodsFor: 'converting' stamp: ''!
undefinedLast
	"apply on the property"
	^self class
		property: property
		collatedWith: baseSortFunction undefinedLast! !

!PropertySortFunction methodsFor: 'accessing' stamp: ''!
property: aValuable
	property := aValuable! !

!PropertySortFunction methodsFor: 'accessing' stamp: ''!
property
	^ property! !

!PropertySortFunction class methodsFor: 'instance creation' stamp: ''!
property: selectorOrOneArgBlock collatedWith: aSortFunction
	^self new 
		property: selectorOrOneArgBlock;
		baseSortFunction: aSortFunction! !

!PropertySortFunction class methodsFor: 'instance creation' stamp: ''!
property: selectorOrOneArgBlock
	^self new 
		property: selectorOrOneArgBlock! !

!ProportionalLayout commentStamp: ''!
I represent a layout that places all children of some morph in their given LayoutFrame.!
!ProportionalLayout methodsFor: 'layout' stamp: ''!
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: ''!
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: ''!
isProportionalLayout
	^true! !

!ProportionalSplitterMorph commentStamp: ''!
I am the morph the user grabs to adjust pane splitters.!
!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
getOldColor
	^ oldColor ifNil: [Color transparent]! !

!ProportionalSplitterMorph methodsFor: 'operations' stamp: ''!
addRightOrBottom: aMorph

	rightOrBottom add: aMorph.! !

!ProportionalSplitterMorph methodsFor: 'drawing' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
noteNewOwner: o
	"Update the fill style."
	
	super noteNewOwner: o.
	self defer: [self adoptPaneColor: self paneColor]! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
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: 'operations' stamp: ''!
beSplitsTopAndBottom

	splitsTopAndBottom := true.! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
shouldDraw
	"Answer whether the receiver should be drawn."
	
	^super shouldDraw or: [self class showSplitterHandles]! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
hideLeftOrTop
	"Hide the receiver and all left or top morphs."

	self hide.
	leftOrTop do: [:m | m hide]! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
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: ''!
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: '*Polymorph-Widgets' stamp: ''!
showRightOrBottom
	"Show the receiver and all right or bottom morphs."

	self show.
	rightOrBottom do: [:m | m show]! !

!ProportionalSplitterMorph methodsFor: 'actions' stamp: ''!
resizeCursor

	^ Cursor resizeForEdge: (splitsTopAndBottom
		ifTrue: [#top]
		ifFalse: [#left])! !

!ProportionalSplitterMorph methodsFor: 'event handling' stamp: ''!
updateFromEvent: anEvent
	"Update the splitter and attached morph positions from the mouse event.
	Take into account the mouse down offset."
	
	| pNew pOld delta selfTop selfBottom selfLeft selfRight|
	pNew := anEvent cursorPoint - lastMouse second.
	pOld := lastMouse first - lastMouse second.
	delta := splitsTopAndBottom
		ifTrue: [0 @ ((self normalizedY: pNew y) - pOld y)]
		ifFalse: [(self normalizedX: pNew x) - pOld x @ 0].
	lastMouse at: 1 put: (splitsTopAndBottom
		ifTrue: [pNew x @ (self normalizedY: pNew y) + lastMouse second]
		ifFalse: [(self normalizedX: pNew x) @ pNew y + lastMouse second]).
	leftOrTop do: [:each | | firstRight firstBottom | 
		firstRight := each layoutFrame rightOffset
					ifNil: [0].
		firstBottom := each layoutFrame bottomOffset
					ifNil: [0].
		each layoutFrame rightOffset: firstRight + delta x.
		each layoutFrame bottomOffset: firstBottom + delta y.
		(each layoutFrame leftFraction = each layoutFrame rightFraction and: [
				each layoutFrame leftFraction ~= 0]) "manual splitter"
			ifTrue: [each layoutFrame leftOffset: (each layoutFrame leftOffset ifNil: [0]) + delta x].
		(each layoutFrame topFraction = each layoutFrame bottomFraction and: [
				each layoutFrame topFraction ~= 0]) "manual splitter"
			ifTrue: [each layoutFrame topOffset: (each layoutFrame topOffset ifNil: [0]) + delta y]].
	rightOrBottom do: [:each | | secondLeft secondTop | 
		secondLeft := each layoutFrame leftOffset
					ifNil: [0].
		secondTop := each layoutFrame topOffset
					ifNil: [0].
		each layoutFrame leftOffset: secondLeft + delta x.
		each layoutFrame topOffset: secondTop + delta y.
		(each layoutFrame leftFraction = each layoutFrame rightFraction and: [
				each layoutFrame rightFraction ~= 1]) "manual splitter"
			ifTrue: [each layoutFrame rightOffset: (each layoutFrame rightOffset ifNil: [0]) + delta x].
		(each layoutFrame topFraction = each layoutFrame bottomFraction and: [
				each layoutFrame bottomFraction ~= 1]) "manual splitter"
			ifTrue: [each layoutFrame bottomOffset: (each layoutFrame bottomOffset ifNil: [0]) + delta y]].
	selfTop := self layoutFrame topOffset ifNil: [0].
	selfBottom := self layoutFrame bottomOffset ifNil: [0].
	selfLeft := self layoutFrame leftOffset ifNil: [0].
	selfRight := self layoutFrame rightOffset ifNil: [0].
	self layoutFrame topOffset: selfTop + delta y.
	self layoutFrame bottomOffset: selfBottom + delta y.
	self layoutFrame leftOffset: selfLeft + delta x.
	self layoutFrame rightOffset: selfRight + delta x.
	self owner layoutChanged! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
showLeftOrTop
	"Show the receiver and all left or top morphs."

	self show.
	leftOrTop do: [:m | m show]! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
hasRightOrBottom: aMorph
	"Answer whether the receiver has the given morph
	as one of of its right or bottom morphs."

	^rightOrBottom includes: aMorph! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
hideRightOrBottom
	"Hide the receiver and all right or bottom morphs."

	self hide.
	rightOrBottom do: [:m | m hide]! !

!ProportionalSplitterMorph methodsFor: 'operations' stamp: ''!
normalizedX: x

	^ (x max: self leftBoundary) min: self rightBoundary! !

!ProportionalSplitterMorph methodsFor: 'operations' stamp: ''!
normalizedY: y

	^ (y max: self topBoundary) min: self bottomBoundary! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
handleRect

	^ Rectangle
		center: self bounds center 
		extent: (self splitsTopAndBottom
			ifTrue: [self handleSize transposed] 
			ifFalse: [self handleSize])! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
shouldInvalidateOnMouseTransition
	"Answer whether the receiver should be invalidated
	when the mouse enters or leaves."
	
	^self class showSplitterHandles! !

!ProportionalSplitterMorph methodsFor: 'event handling' stamp: ''!
mouseMove: anEvent 
	anEvent hand temporaryCursor
		ifNil: [^ self].
	self class fastSplitterResize
		ifFalse:  [self updateFromEvent: anEvent]
		ifTrue: [traceMorph
				ifNil: [traceMorph := Morph newBounds: self bounds.
					traceMorph borderColor: Color lightGray.
					traceMorph borderWidth: 1.
					self owner addMorph: traceMorph].
			splitsTopAndBottom
				ifTrue: [traceMorph position: traceMorph position x @ (self normalizedY: anEvent cursorPoint y)]
				ifFalse: [traceMorph position: (self normalizedX: anEvent cursorPoint x) @ traceMorph position y]]! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
splitterRight
	"Answer the splitter to the right of the receiver that overlaps in its vertical range."
	
	|splitters|
	splitters := ((self siblingSplitters select: [:each |
		each left > self left and: [self overlapsVertical: each]]) asSortedCollection: [:a :b | a left < b left]).
	
	^ splitters
		ifEmpty: [ nil ]
		ifNotEmpty: [:s | s first ]! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
normalFillStyle
	"Return the normal fillStyle of the receiver."
	
	^self theme splitterNormalFillStyleFor: self! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
siblingSplitters

	^ self owner 
		submorphsSatisfying: [:each | (each isKindOf: self class) 
									and: [self splitsTopAndBottom = each splitsTopAndBottom and: [each ~= self]]]! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
splitsTopAndBottom

	^ splitsTopAndBottom! !

!ProportionalSplitterMorph methodsFor: 'operations' stamp: ''!
addLeftOrTop: aMorph

	leftOrTop add: aMorph! !

!ProportionalSplitterMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
	splitsTopAndBottom := false.
	
	leftOrTop := OrderedCollection new.
	rightOrBottom := OrderedCollection new! !

!ProportionalSplitterMorph methodsFor: 'testing' stamp: ''!
isCursorOverHandle
	^ self class showSplitterHandles not or: [self handleRect containsPoint: self activeHand cursorPoint]! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
setGrabbedColor
	"Set the color of the receiver when it is grabbed."
	
	self fillStyle: self pressedFillStyle! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
handleSize

	^ self class splitterWidth @ 30! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
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: 'event handling' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
adoptPaneColor: paneColor
	"Change our color too."
	
	super adoptPaneColor: paneColor.
	self fillStyle: self normalFillStyle! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
hasLeftOrTop: aMorph
	"Answer whether the receiver has the given morph
	as one of of its left or top morphs."

	^leftOrTop includes: aMorph! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
topBoundary
	"Answer the top boundary position by calculating the minimum
	of the minimum heights of the top morphs."
	
	|morphs|
	morphs := leftOrTop reject: [:m |
		m layoutFrame topFraction ~= 0 and: [
			m layoutFrame topFraction = m layoutFrame bottomFraction]].
	morphs ifEmpty: [
		^(self splitterAbove
			ifNil: [self containingWindow panelRect top]
			ifNotNil: [:s | s first top]) + 25].
	^(morphs collect: [:m |
		m top + m minExtent y +
			(self layoutFrame topOffset ifNil: [0]) -
			(m layoutFrame bottomOffset ifNil: [0])]) max! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
overlapsHorizontal: aSplitter
	"Answer whether the receiver overlaps the given splitter
	in the horizontal plane."

	^aSplitter left <= self right and: [aSplitter right >= self left]! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
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: '*Polymorph-Widgets' stamp: ''!
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: ''!
overlapsVertical: aSplitter
	"Answer whether the receiver overlaps the given splitter
	in the vertical plane."

	^aSplitter top <= self bottom and: [aSplitter bottom >= self top]! !

!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
pressedFillStyle
	"Return the pressed fillStyle of the receiver."
	
	^self theme splitterPressedFillStyleFor: self! !

!ProportionalSplitterMorph methodsFor: 'accessing' stamp: ''!
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 class methodsFor: 'preferences' stamp: ''!
showSplitterHandles: aBoolean

	ShowHandles := aBoolean! !

!ProportionalSplitterMorph class methodsFor: 'preferences' stamp: ''!
showSplitterHandles

	^ ShowHandles ifNil: [ShowHandles := false]! !

!ProportionalSplitterMorph class methodsFor: 'preferences' stamp: ''!
fastSplitterResize
	
	^ self theme settings fastDragging! !

!ProportionalSplitterMorph class methodsFor: 'accessing - defaults' stamp: ''!
splitterWidth

	^ 4! !

!ProtoObject commentStamp: ''!
ProtoObject establishes minimal behavior required of any object in Pharo, even objects that should balk at normal object behavior. 

Generally these are proxy objects designed to read themselves in from the disk, or to perform some wrapper behavior, before responding to a message. 

ProtoObject has no instance variables, nor should any be added.!
!ProtoObject methodsFor: 'reflective operations' stamp: ''!
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"

	{self} elementsExchangeIdentityWith: {otherObject}! !

!ProtoObject methodsFor: 'pointing to' stamp: ''!
pointsTo: anObject
	"Answers true if I hold a reference to anObject, or false otherwise
	an object points to a class via the header either directly or indirectly 
	via the compact classes array"

	^ (self instVarsInclude: anObject) or: [ ^self class == anObject]! !

!ProtoObject methodsFor: '*Tool-Finder' stamp: ''!
allSelectorsToTestInMethodFinder

	^ #()! !

!ProtoObject methodsFor: 'pointing to' stamp: ''!
pointersToExcept: objectsToExclude among: aCollectionOfObjects
	"Find all objects in the system that hold a pointer to me, excluding those listed.
	This method is meant to be a faster solution if used several times on several objects rather than calling the GC multiples times.
	See pointersToExcept: for usage.
	"

	| pointers objectsToAlwaysExclude |
	pointers := OrderedCollection new.
	pointers := aCollectionOfObjects select: [ :e | e pointsTo: self ].
	objectsToAlwaysExclude := {thisContext.
	thisContext sender.
	thisContext sender sender.
	objectsToExclude}.
	^ (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: '*NewTools-Inspector-Extensions' stamp: ''!
inspectorPerform: aSymbol with: anObject
	"This method is required by the inspector infrastructure (in order to inspect properly 
	 ProtoObject and its direct decendants). 
	 DO NOT USE IT!!"
	
	<primitive: 83>
	^ self primitiveFailed! !

!ProtoObject methodsFor: 'reflective operations' stamp: ''!
basicIdentityHash
	"Answer a 22 bits unsigned SmallInteger whose value is related to the receiver's identity.
	
	Primitive. Fails if the receiver is an immediate. Essential.
	See Object documentation whatIsAPrimitive.
	
	Do not override, use #identityHash instead"

	<primitive: 75>
	self primitiveFailed! !

!ProtoObject methodsFor: 'reflective operations' stamp: ''!
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."

	{self} elementsForwardIdentityTo: {otherObject} copyHash: copyHash! !

!ProtoObject methodsFor: 'introspection' stamp: ''!
instVarsInclude: anObject
"Answers true if anObject is among my named or indexed instance variables, and false otherwise"

	<primitive: 132>
	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: 'testing' stamp: ''!
isNil
	"Coerces nil to true and everything else to false."

	^false! !

!ProtoObject methodsFor: 'write barrier' stamp: ''!
modificationForbiddenFor: selector index: index value: value
	^ (ModificationForbidden 
		for: self
		at: index
		with: value
		retrySelector: selector) signal! !

!ProtoObject methodsFor: 'testing' stamp: ''!
ifNil: nilBlock
	"Return self, or evaluate the block if I'm == nil (q.v.)"
	"Might be compiled inline for speed, see RBMessageNode>>#isInlineIfNil"
	^ self! !

!ProtoObject methodsFor: 'memory scanning' stamp: ''!
nextObject
	"Primitive. Answer the next object after the receiver in the 
	enumeration of all objects. Return 0 when all objects have been 
	enumerated."

	<primitive: 139>
	self primitiveFailed.! !

!ProtoObject methodsFor: 'testing' stamp: ''!
ifNotNil: ifNotNilBlock ifNil: nilBlock 
	"If the receiver is not nil, pass it as argument to the ifNotNilBlock block. else execute the nilBlock block"
	"Might be compiled inline for speed, see RBMessageNode>>#isInlineIfNil"

	"(nil ifNotNil: [:o | o +3 ] ifNil: [42]) >>> 42"
	"(3 ifNotNil: [:o | o +3 ] ifNil: [42]) >>> 6"

	^ ifNotNilBlock cull: self! !

!ProtoObject methodsFor: 'flagging' stamp: ''!
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: '*Reflectivity' stamp: ''!
nonAnonymousClass
	^ self class isAnonymous
		ifTrue: [ self class superclass ]
		ifFalse: [ self class ]! !

!ProtoObject methodsFor: 'primitive failure' stamp: ''!
primitiveFailed: selector
	"Announce that a primitive has failed and there is no appropriate Smalltalk code to run."
	
	PrimitiveFailed signalFor: selector! !

!ProtoObject methodsFor: 'initialization' stamp: ''!
initialize
	"Subclasses should redefine this method to perform initializations on instance creation"! !

!ProtoObject methodsFor: 'executing' stamp: ''!
executeMethod: compiledMethod
	^ self withArgs: #( ) executeMethod: compiledMethod! !

!ProtoObject methodsFor: 'testing' stamp: ''!
isImmediateObject
	^ self class isImmediateClass! !

!ProtoObject methodsFor: 'block support' stamp: ''!
mustBeBooleanHandler

	^ NonBooleanReceiver mustBeBooleanHandler ifNil: [ self ]! !

!ProtoObject methodsFor: 'comparing' stamp: ''!
identityHash
	"Answer a SmallInteger whose value is related to the receiver's identity.
	 This method must not be overridden, except by SmallInteger.  As of
	 2014, the 32-bit Spur VM has 22 bits of hash and 31-bit SmallIntegers
	 (30 bits + 1 sign bit).  Shifting by 8 will not create large integers.
	
	 Do not override."

	^self basicIdentityHash bitShift: 8! !

!ProtoObject methodsFor: '*Reflectivity' stamp: ''!
metaLinkOptions
	^{
	#isNil -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!ProtoObject methodsFor: 'comparing' stamp: ''!
== 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."

	<primitive: 110>
	self primitiveFailed! !

!ProtoObject methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectorPerform: aSymbol
	"This method is required by the inspector infrastructure (in order to inspect properly 
	 ProtoObject and its direct decendants). 
	 DO NOT USE IT!!"
	
	<primitive: 83>
	^ self primitiveFailed! !

!ProtoObject methodsFor: 'memory scanning' stamp: ''!
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."

	<primitive: 78>
	^nil! !

!ProtoObject methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
allInspectorNodes
	"Answer a list of attributes as nodes"

	^ { StInspectorSelfNode hostObject: self }, 
		self inspectorNodes! !

!ProtoObject methodsFor: '*Fuel-Core-Collections' stamp: ''!
largeIdentityHash

	^ self basicIdentityHash ! !

!ProtoObject methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectorNodes 
	"Answer a list of attributes as nodes"

	^ (StNodeCollector for: self) slotNodes! !

!ProtoObject methodsFor: 'testing' stamp: ''!
ifNotNil: ifNotNilBlock
	"Evaluate the block, unless I'm == nil (q.v.). If the receiver is not nil, pass it as argument to the block."
	"Might be compiled inline for speed, see RBMessageNode>>#isInlineIfNil"

	"(2 ifNotNil: [ :o | o + 3]) >>> 5"
	"(nil ifNotNil: [:o | o +3 ]) >>> nil"

	^ ifNotNilBlock cull: self! !

!ProtoObject methodsFor: '*Fuel-Core-Collections' stamp: ''!
fuelPointsTo: anObject
	"This method returns true if self contains a pointer to anObject,
		and returns false otherwise"
	<primitive: 132>
	"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: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage

	<debuggerCompleteToSender>

	^ MessageNotUnderstood new 
		message: aMessage;
		receiver: self;
		signal! !

!ProtoObject methodsFor: 'pointing to' stamp: ''!
pointersToAmong: aCollectionOfObjects
	"Meant to be used as: 
	Smalltalk garbageCollect.
	objs := SystemNavigation default allObjects.
	anyObject pointersToAmong: objs.
	otherObject pointersToAmong: objs.
	
	Avoid multiple calls to allObjects Primitive and multiple gcs.
	"

	^ self pointersToExcept: #() among: aCollectionOfObjects! !

!ProtoObject methodsFor: 'reflective operations' stamp: ''!
cannotInterpret: aMessage 
	 "Handle the fact that there was an attempt to send the given message to the receiver but a null methodDictionary was encountered while looking up the message selector.  Hopefully this is the result of encountering a stub for a swapped out class which induces this exception on purpose."

"If this is the result of encountering a swap-out stub, then simulating the lookup in Smalltalk should suffice to install the class properly, and the message may be resent."

	(self class lookupSelector: aMessage selector) ifNotNil:
		["Simulated lookup succeeded -- resend the message."
		^ aMessage sentTo: self].

	"Could not recover by simulated lookup -- it's an error"
	Error signal: 'MethodDictionary fault'.

	"Try again in case an error handler fixed things"
	^ aMessage sentTo: self! !

!ProtoObject methodsFor: 'block support' stamp: ''!
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 mustBeBooleanHandler mustBeBooleanIn: thisContext sender! !

!ProtoObject methodsFor: 'pointing to' stamp: ''!
pointersTo
	^self pointersToExcept: #()! !

!ProtoObject methodsFor: 'primitive failure' stamp: ''!
primitiveFailed
	"Announce that a primitive has failed and there is no appropriate Smalltalk code to run."

	self primitiveFailed: thisContext sender selector! !

!ProtoObject methodsFor: 'write barrier' stamp: ''!
modificationForbiddenFor: selector value: value
	^ self modificationForbiddenFor: selector index: nil value: value! !

!ProtoObject methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectorIcon

	^ nil! !

!ProtoObject methodsFor: 'debugging' stamp: ''!
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."

	(self class environment at: #OneShotArmed ifAbsent: [ true ])
		ifTrue: [ 
			self class environment at: #OneShotArmed put: false.
			aBlock value ]! !

!ProtoObject methodsFor: '*Reflectivity' stamp: ''!
rFwithArgs: argArray executeMethod: compiledMethod
	"Execute compiledMethod against the receiver and args in argArray"
	"This method is used by reflectivity internally. All meta-links are ignored"
	<disableReflectivity>
	<primitive: 188>
	self primitiveFailed! !

!ProtoObject methodsFor: 'reflective operations' stamp: ''!
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."

	{self} elementsForwardIdentityTo: {otherObject}! !

!ProtoObject methodsFor: 'block support' stamp: ''!
mustBeBooleanIn: context
	"context is the where the non-boolean error occurred. Rewind context to before jump then raise error."
	
	"Some constructs are optimized in the compiler :
	#whileTrue:
	#whileFalse:
	#ifTrue:
	#ifFalse:
	#ifTrue:ifFalse:
	#ifFalse:ifTrue:
	So you cannot by default use them on non boolean objects."
	
	"If you really need to use optimized constructs, you can enable Opal compiler and do one of the following :
		- recompile your method with the pragma : <compilerOptions: #(+ optIlineNone)>
		- recompile your class with the method : MyClass class>>compiler 
			^ super compiler options: #(+ optIlineNone)
		- enable the option mustBeBooleanDeOptimize to call mustBeBooleanDeOptimizeIn: instead of this method "

	| proceedValue |
	
	"Set the pc back to the point just before the conditional jump that set off the must be boolean"
	context pc: context instructionStream previousPc.
	proceedValue := NonBooleanReceiver new
		object: self;
		signal: 'proceed for truth.'.
	^ proceedValue ~~ false! !

!ProtoObject methodsFor: 'executing' stamp: ''!
withArgs: argArray executeMethod: compiledMethod
	"Execute compiledMethod against the receiver and args in argArray"

	<primitive: 188>
	self primitiveFailed! !

!ProtoObject methodsFor: '*Reflectivity' stamp: ''!
rfIsEqual: 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."
	<metaLinkOptions: #( + optionDisabledLink)>
	<primitive: 110>
	self primitiveFailed! !

!ProtoObject methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionRaw
	"This is the most basic presentation showing the state of the object"
	<inspectorPresentationOrder: 900 title: 'Raw'>

	^ StRawInspection on: self! !

!ProtoObject methodsFor: 'class membership' stamp: ''!
class
	"Primitive. Answer the object which is the receiver's class. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 111>
	self primitiveFailed! !

!ProtoObject methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionContexts
	"This is a utility method that collects all presentations for the current object.
	By default, it simply looks for the #gtInspectorPresentationOrder: pragma.
	The inspector can decice whether or not a presentation should be dispayed.
	Subclasses might want to override it for more special behavior."

	^ (StInspectionCollector on: self) collectInspectionContexts! !

!ProtoObject methodsFor: 'debugging' stamp: ''!
rearmOneShot
	"Call this manually to arm the one-shot mechanism; use the mechanism in code by calling
		self doOnlyOnce: <a block>"

	self class environment at: #OneShotArmed put: true

	"self rearmOneShot"! !

!ProtoObject methodsFor: 'apply primitives' stamp: ''!
tryPrimitive: primIndex withArgs: argumentArray
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."

	<primitive: 118 error: code >
	^ Context primitiveFailTokenFor: code! !

!ProtoObject methodsFor: 'testing' stamp: ''!
ifNil: nilBlock ifNotNil: ifNotNilBlock
	"If the receiver is not nil, pass it as argument to the ifNotNilBlock block. else execute the nilBlock block"
	"Might be compiled inline for speed, see RBMessageNode>>#isInlineIfNil"
	
	"(nil ifNil: [42] ifNotNil: [:o | o +3 ] ) >>> 42"
	"(3  ifNil: [42] ifNotNil: [:o | o +3 ]) >>> 6"
	
	^ ifNotNilBlock cull: self! !

!ProtoObject methodsFor: 'comparing' stamp: ''!
~~ anObject
	"Primitive. Answer whether the receiver and the argument are different objects
	(do not have the same object pointer). Do not redefine the message ~~ in 
	any other class!! Optional (Assuming == is essential). No Lookup. Do not override in any subclass. 
	See Object documentation whatIsAPrimitive."
	
	<primitive: 169>
	self == anObject
		ifTrue: [^ false]
		ifFalse: [^ true]! !

!ProtoObject methodsFor: 'pointing to' stamp: ''!
pointersToExcept: objectsToExclude
	"Find all objects in the system that hold a pointer to me, excluding those listed"
	| c pointers objectsToAlwaysExclude closure|
	Smalltalk garbageCollect.
	pointers := OrderedCollection new.
	closure := [ :e | (e pointsTo: self) ifTrue: [ pointers add: e ]  ].
	SystemNavigation default allObjectsDo: closure.

	objectsToAlwaysExclude := {
		thisContext.
		thisContext sender.
		thisContext sender sender.
		closure.
		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: 'primitive failure' stamp: ''!
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! !

!ProtoObjectTest commentStamp: ''!
This is the unit test for the class ProtoObject. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- there is a chapter in the PharoByExample book (http://pharobyexample.org)
	- the sunit class category!
!ProtoObjectTest methodsFor: 'tests' stamp: ''!
testNextObject
	"In issue 4011 (https://github.com/pharo-project/pharo/issues/4011), "
	"the image crashed if nextObject was called on a Character, SmallInteger or a SmallFloat64"
	
	self assert: (nil nextObject notNil).
	self assert: ('test' nextObject notNil).
	
	self should: [42 nextObject notNil] raise: ShouldNotImplement.
	self should: [$x nextObject notNil] raise: ShouldNotImplement.

	"Small Floats are only available in 64 bits VMs"	
	Smalltalk vm hasSmallFloats 
		ifTrue: [self should: [3.14 nextObject notNil] raise: ShouldNotImplement].! !

!ProtoObjectTest methodsFor: 'tests - testing' stamp: ''!
testIfNil
	| object block reachabilityTest |
	reachabilityTest := false.
	object := ProtoObject new.
	object ifNil: [ reachabilityTest := true ].
	self assert: (object ifNil: [ nil ]) identicalTo: object.
	self assert: reachabilityTest equals: false.
	"Now the same test without inlining."
	reachabilityTest := false.
	block := [ reachabilityTest := true ].
	object ifNil: block.
	block := [ nil ].
	self assert: (object ifNil: block) identicalTo: object.
	self assert: reachabilityTest equals: false! !

!ProtoObjectTest methodsFor: 'tests - testing' stamp: ''!
testFlag
	ProtoObject new flag: #hallo! !

!ProtoObjectTest methodsFor: 'tests - testing' stamp: ''!
testIfNilIfNotNil
	| object returnValue block notReached1 reached1 notReached2 reached2 reached3 notReached3 reached4 notReached4 |
	notReached1 := false.
	reached1 := false.
	notReached2 := false.
	reached2 := false.
	notReached3 := false.
	reached3 := false.
	notReached4 := false.
	reached4 := false.
	object := ProtoObject new.
	returnValue := Object new.

	object ifNil: [ notReached1 := true ] ifNotNil: [ reached1 := true ].
	self assert: notReached1 equals: false.
	self assert: reached1 equals: true.

	object ifNil: [ notReached2 := true ] ifNotNil: [ :o | reached2 := true ].
	self assert: notReached2 equals: false.
	self assert: reached2 equals: true.

	self assert: (object ifNil: [ false ] ifNotNil: [ :o | o == object ]).
	self assert: (object ifNil: [ nil ] ifNotNil: [ returnValue ]) identicalTo: returnValue.
	self assert: (object ifNil: [ nil ] ifNotNil: [ :o | returnValue ]) identicalTo: returnValue.

	"Now the same without inlining."
	block := [ reached3 := true ].
	object ifNil: [ notReached3 := true ] ifNotNil: block.
	self assert: notReached3 equals: false.
	self assert: reached3 equals: true.

	block := [ :o | reached4 := true ].
	object ifNil: [ notReached4 := true ] ifNotNil: block.
	self assert: notReached4 equals: false.
	self assert: reached4 equals: true.

	block := [ :o | o == object ].
	self assert: (object ifNil: [ false ] ifNotNil: block).
	block := [ returnValue ].
	self assert: (object ifNil: [ nil ] ifNotNil: block) equals: returnValue.
	block := [ :o | returnValue ].
	self assert: (object ifNil: [ nil ] ifNotNil: block) equals: returnValue! !

!ProtoObjectTest methodsFor: 'tests - testing' stamp: ''!
testIfNotNil
	| object returnValue block reached |
	object := ProtoObject new.
	returnValue := Object new.
	reached := false.
	object ifNotNil: [ reached := true ].
	self assert: reached equals: true.
	reached := false.
	object ifNotNil: [ :o | reached := true ].
	self assert: reached equals: true.
	self assert: (object ifNotNil: [ :o | o == object ]).
	self assert: (object ifNotNil: [ returnValue ]) identicalTo: returnValue.
	self assert: (object ifNotNil: [ :o | returnValue ]) identicalTo: returnValue.
	"Now the same without inlining."
	block := [ reached := true ].
	object ifNotNil: block.
	self assert: reached equals: true.
	reached := false.
	block := [ :o | reached := true ].
	object ifNotNil: block.
	self assert: reached equals: true.
	block := [ :o | o == object ].
	self assert: (object ifNotNil: block).
	block := [ returnValue ].
	self assert: (object ifNotNil: block) equals: returnValue.
	block := [ :o | returnValue ].
	self assert: (object ifNotNil: block) equals: returnValue! !

!ProtoObjectTest methodsFor: 'tests - testing' stamp: ''!
testIsNil

	self deny: ProtoObject new isNil! !

!ProtoObjectTest methodsFor: 'tests - testing' stamp: ''!
testIsImmediateObject
	self deny: Object new isImmediateObject.
	self deny: Array new isImmediateObject.
	self assert: 1 isImmediateObject.
	self assert: 1 isImmediateObject equals: 1 class isImmediateClass.
	self assert: 1.2 isImmediateObject equals: 1.2 class isImmediateClass.
	self assert: $a isImmediateObject equals: $a class isImmediateClass! !

!ProtoObjectTest methodsFor: 'tests - testing' stamp: ''!
testNotTheSame

	| object1 object2 |
	object1 := ProtoObject new.
	object2 := ProtoObject new.
	self assert: object1 ~~ object2.
	self deny: object1 ~~ object1.! !

!ProtoObjectTest methodsFor: 'tests - testing' stamp: ''!
testIfNotNilIfNil
	| object returnValue block reached notReached |
	object := ProtoObject new.
	returnValue := Object new.

	reached := false.
	notReached := false.
	object ifNotNil: [ reached := true ] ifNil: [ notReached := true ].
	self assert: reached equals: true.
	self assert: notReached equals: false.

	reached := false.
	notReached := false.
	object ifNotNil: [ :o | reached := true ] ifNil: [ notReached := true ].
	self assert: reached equals: true.
	self assert: notReached equals: false.

	reached := false.
	notReached := false.
	self assert: (object ifNotNil: [ :o | o == object ] ifNil: [ false ]).
	self assert: (object ifNotNil: [ returnValue ] ifNil: [ false ]) identicalTo: returnValue.
	self assert: (object ifNotNil: [ :o | returnValue ] ifNil: [ false ]) identicalTo: returnValue.
	"Now the same without inlining."
	reached := false.
	notReached := false.
	block := [ reached := true ].
	object ifNotNil: block ifNil: [ notReached := true ].
	self assert: reached equals: true.
	self assert: notReached equals: false.

	reached := false.
	notReached := false.
	block := [ :o | reached := true ].
	object ifNotNil: block ifNil: [ notReached := true ].
	self assert: reached equals: true.
	self assert: notReached equals: false.

	block := [ :o | o == object ].
	self assert: (object ifNotNil: block ifNil: [ false ]).
	block := [ returnValue ].
	self assert: (object ifNotNil: block ifNil: [ false ]) identicalTo: returnValue.
	block := [ :o | returnValue ].
	self assert: (object ifNotNil: block ifNil: [ false ]) identicalTo: returnValue! !

!ProtoObjectTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ ProtoObject! !

!ProtoObjectTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testPointersToCycle

	| myObject myArray myArray2 pointingObjects |
	myObject := Object new.
	myArray := {myObject . myObject}.
	myArray2 := {myObject . myArray}.

	pointingObjects := (myObject pointersTo) asArray.
	self assert: pointingObjects size equals: 2.
	self assert: (pointingObjects includesAll: {myArray . myArray2}).
	
	"PointerFinder loops in presence of cycles"
"	myArray at: 1 put: myArray.
	pointingObjects := (PointerFinder pointersTo: myObject) asArray.
	self assert: pointingObjects = {myArray}.
"! !

!ProtoObjectTest methodsFor: 'tests - testing' stamp: ''!
testFastPointersTo
	| myObject myArray myObject2 allObjects |
	self timeLimit: 1 minute.
	myObject := Object new.
	myObject2 := Object new.
	myArray := {myObject.
	myObject2}.
	allObjects := SystemNavigation default allObjects.
	self
		assert: (myObject pointersToAmong: allObjects) asArray
		equals: {myArray}.
	self
		assert: (myObject2 pointersToAmong: allObjects) asArray
		equals: {myArray}! !

!ProtoObjectTest methodsFor: 'tests - testing' stamp: ''!
testPointersTo
	| myObject myArray pointers |
	myObject := Object new.
	pointers := myObject pointersTo.
	self assertEmpty: pointers.
	myArray := {myObject . myObject}.
	self assert: myObject pointersTo asArray equals: {myArray}! !

!Protocol commentStamp: ''!
A Protocol is a simple value holder representing a protocol.
It's composed of a name and a set of method selectors!
!Protocol methodsFor: 'testing' stamp: ''!
isExtensionProtocol 
	^ self name first = $*.! !

!Protocol methodsFor: 'testing' stamp: ''!
isEmpty
	^ self methodSelectors isEmpty! !

!Protocol methodsFor: 'accessing' stamp: ''!
removeAllMethodSelectors
	^ methodSelectors removeAll! !

!Protocol methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	methodSelectors := IdentitySet new.
	name := self class defaultName.! !

!Protocol methodsFor: 'accessing' stamp: ''!
rename: newName

	self name: newName! !

!Protocol methodsFor: 'testing' stamp: ''!
includesSelector: selector

	^ methodSelectors includes: selector! !

!Protocol methodsFor: 'accessing' stamp: ''!
removeMethodSelector: aSymbol
	^ methodSelectors remove: aSymbol! !

!Protocol methodsFor: 'accessing' stamp: ''!
addAllMethodsFrom: aProtocol
	aProtocol methodSelectors do: [ :each | self addMethodSelector: each ]! !

!Protocol methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream
		nextPutAll: self class name;
		nextPutAll: ' (';
		nextPutAll: self name;
		nextPutAll: ') - ';
		print: self methodSelectors size;
		nextPutAll: ' selector(s)'! !

!Protocol methodsFor: 'accessing' stamp: ''!
addMethodSelector: aSymbol
	^ methodSelectors add: aSymbol! !

!Protocol methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!Protocol methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject asSymbol! !

!Protocol methodsFor: 'accessing' stamp: ''!
methodSelectors: anObject
	methodSelectors := anObject! !

!Protocol methodsFor: 'testing' stamp: ''!
canBeRenamed
	^ true! !

!Protocol methodsFor: 'private' stamp: ''!
canBeRemoved
	^ self isEmpty! !

!Protocol methodsFor: 'accessing' stamp: ''!
methodSelectors
	^ methodSelectors! !

!Protocol methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	self error: 'For Protocol you need to use #asRingMinimalDefinitionIn:parent: because parent class cannot be resolved automatically'


! !

!Protocol methodsFor: 'testing' stamp: ''!
isVirtualProtocol
	"A virtual protocol is a calculated one (it does not have any methods by it self)"
	^ false! !

!Protocol class methodsFor: 'instance creation' stamp: ''!
empty 
	 ^ self name: #''! !

!Protocol class methodsFor: 'accessing' stamp: ''!
defaultName

	^  self unclassified! !

!Protocol class methodsFor: 'instance creation' stamp: ''!
name: nm methodSelectors: methods
	^ self new
		methodSelectors: methods;
		name: nm asSymbol;
		yourself! !

!Protocol class methodsFor: 'instance creation' stamp: ''!
name: nm

	^ self new
		name: nm asSymbol;
		yourself! !

!Protocol class methodsFor: 'instance creation' stamp: ''!
ambiguous
	^ #ambiguous! !

!Protocol class methodsFor: 'accessing' stamp: ''!
unclassified
	^ #'as yet unclassified'! !

!Protocol class methodsFor: 'accessing' stamp: ''!
nullCategory

	^ #'no messages'! !

!ProtocolAdded commentStamp: ''!
This class is not used, but should be used when we hook into the addition and removal of protocols. Right now, we only get ClassReorganizedAnnouncement!
!ProtocolAnnouncement commentStamp: ''!
I'm an abstract announcement for protocols!
!ProtocolAnnouncement methodsFor: 'accessing' stamp: ''!
protocol
	^ protocol! !

!ProtocolAnnouncement methodsFor: 'accessing' stamp: ''!
protocol: aString
	protocol := aString! !

!ProtocolAnnouncement methodsFor: 'accessing' stamp: ''!
classAffected
	^self classReorganized! !

!ProtocolAnnouncement methodsFor: 'accessing' stamp: ''!
classReorganized
	^ classReorganized! !

!ProtocolAnnouncement methodsFor: 'testing' stamp: ''!
affectsMethodTagIn: aClass

	^self classAffected == aClass! !

!ProtocolAnnouncement methodsFor: 'accessing' stamp: ''!
classReorganized: anObject
	classReorganized := anObject! !

!ProtocolClient commentStamp: ''!
ProtocolClient is the abstract super class for a variety of network protocol clients.
It uses a stream rather than the direct network access so it could also work for streams on serial connections etc.

Structure:
	stream				stream representing the connection to and from the server
	connectInfo			information required for opening a connection
	lastResponse			remembers the last response from the server.
	progressObservers 	any object understanding #show: can be registered as a progress observer (login, transfer, etc)!
!ProtocolClient methodsFor: 'private' stamp: ''!
openOnHost: hostIP port: portNumber
	self host: hostIP.
	self port: portNumber.
	self ensureConnection! !

!ProtocolClient methodsFor: 'private - protocol' stamp: ''!
fetchPendingResponse
	^pendingResponses
		ifNil: [self fetchNextResponse; lastResponse]
		ifNotNil: [self popResponse]! !

!ProtocolClient methodsFor: 'private' stamp: ''!
defaultPortNumber
	^self class defaultPortNumber! !

!ProtocolClient methodsFor: 'accessing' stamp: ''!
response
	^self protocolInstance lastResponse! !

!ProtocolClient methodsFor: 'private' stamp: ''!
password: aString
	^self connectionInfo at: #password put: aString! !

!ProtocolClient methodsFor: 'private' stamp: ''!
logFlag
	^self class logFlag! !

!ProtocolClient methodsFor: 'private - testing' stamp: ''!
responseIsError
	self subclassResponsibility! !

!ProtocolClient methodsFor: 'private - protocol' stamp: ''!
sendStreamContents: aStream
	self stream sendStreamContents: aStream! !

!ProtocolClient methodsFor: 'private' stamp: ''!
resetConnectionInfo
	connectInfo := nil! !

!ProtocolClient methodsFor: 'private - protocol' stamp: ''!
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' stamp: ''!
user
	^self connectionInfo at: #user ifAbsent: [nil]! !

!ProtocolClient methodsFor: 'private' stamp: ''!
progressObservers
	progressObservers ifNil: [progressObservers := OrderedCollection new].
	^progressObservers! !

!ProtocolClient methodsFor: 'private' stamp: ''!
logProgress: aString
	self progressObservers do: [:each | each show: aString].! !

!ProtocolClient methodsFor: 'actions' stamp: ''!
close
	self stream
		ifNotNil: [
			self stream close.
			stream := nil]! !

!ProtocolClient methodsFor: 'testing' stamp: ''!
isConnected
	^stream notNil
		and: [stream isConnected]! !

!ProtocolClient methodsFor: 'private' stamp: ''!
port
	^self connectionInfo at: #port! !

!ProtocolClient methodsFor: 'private' stamp: ''!
connectionInfo
	connectInfo ifNil: [connectInfo := Dictionary new].
	^connectInfo! !

!ProtocolClient methodsFor: 'private' stamp: ''!
pendingResponses
	pendingResponses ifNil: [pendingResponses := OrderedCollection new].
	^pendingResponses! !

!ProtocolClient methodsFor: 'accessing' stamp: ''!
messageText
	^super messageText
		ifNil: [self response]! !

!ProtocolClient methodsFor: 'private - protocol' stamp: ''!
checkResponseOnError: errorBlock onWarning: warningBlock
	"Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes."

	self fetchPendingResponse.
	self checkResponse: self lastResponse onError: errorBlock onWarning: warningBlock! !

!ProtocolClient methodsFor: 'private' stamp: ''!
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: ''!
pushResponse: aResponse
	self pendingResponses add: aResponse! !

!ProtocolClient methodsFor: 'private' stamp: ''!
port: aPortNumber
	^self connectionInfo at: #port put: aPortNumber! !

!ProtocolClient methodsFor: 'private' stamp: ''!
host
	^self connectionInfo at: #host! !

!ProtocolClient methodsFor: 'private - protocol' stamp: ''!
fetchNextResponse
	self lastResponse: self stream nextLine! !

!ProtocolClient methodsFor: 'actions' stamp: ''!
reopen
	self ensureConnection! !

!ProtocolClient methodsFor: 'private' stamp: ''!
user: aString
	^self connectionInfo at: #user put: aString! !

!ProtocolClient methodsFor: 'private' stamp: ''!
popResponse
	| pendingResponse |
	pendingResponse := self pendingResponses removeFirst.
	pendingResponses isEmpty
		ifTrue: [pendingResponses := nil].
	^pendingResponse! !

!ProtocolClient methodsFor: 'private - protocol' stamp: ''!
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: 'accessing' stamp: ''!
stream: aStream
	stream := aStream! !

!ProtocolClient methodsFor: 'private' stamp: ''!
password
	^self connectionInfo at: #password! !

!ProtocolClient methodsFor: 'private - protocol' stamp: ''!
sendCommand: aString
	self stream sendCommand: aString.! !

!ProtocolClient methodsFor: 'private' stamp: ''!
lastResponse
	^lastResponse! !

!ProtocolClient methodsFor: 'accessing' stamp: ''!
stream
	^stream! !

!ProtocolClient methodsFor: 'private' stamp: ''!
host: hostId
	^self connectionInfo at: #host put: hostId! !

!ProtocolClient methodsFor: 'private - protocol' stamp: ''!
checkResponse
	self
		checkResponseOnError: [:response | (TelnetProtocolError protocolInstance: self)
				signal: response]
		onWarning: [:response | (TelnetProtocolError protocolInstance: self)
				signal: response]! !

!ProtocolClient methodsFor: 'private' stamp: ''!
lastResponse: aString
	lastResponse := aString.! !

!ProtocolClient methodsFor: 'accessing' stamp: ''!
logProgressToTranscript
	self progressObservers add: Transcript! !

!ProtocolClient methodsFor: 'private - testing' stamp: ''!
responseIsWarning
	self subclassResponsibility! !

!ProtocolClient class methodsFor: 'instance creation' stamp: ''!
openOnHost: hostIP port: portNumber
	^self new openOnHost: hostIP port: portNumber! !

!ProtocolClient class methodsFor: 'accessing' stamp: ''!
defaultPortNumber
	self subclassResponsibility! !

!ProtocolClient class methodsFor: 'accessing' stamp: ''!
logFlag
	self subclassResponsibility! !

!ProtocolClient class methodsFor: 'instance creation' stamp: ''!
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: ''!
openOnHostNamed: hostName port: portNumber
	| serverIP |
	serverIP := NetNameResolver addressForName: hostName timeout: 20.
	^self openOnHost: serverIP port: portNumber! !

!ProtocolClientError commentStamp: ''!
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: ''!
protocolInstance
	^protocolInstance! !

!ProtocolClientError methodsFor: 'accessing' stamp: ''!
protocolInstance: aProtocolInstance
	protocolInstance := aProtocolInstance! !

!ProtocolClientError methodsFor: 'accessing' stamp: ''!
response
	^self protocolInstance lastResponse! !

!ProtocolClientError methodsFor: 'accessing' stamp: ''!
messageText
	^super messageText
		ifNil: [self response]! !

!ProtocolClientError class methodsFor: 'instance creation' stamp: ''!
protocolInstance: aProtocolInstance
	^self new protocolInstance: aProtocolInstance! !

!ProtocolConventionsTest commentStamp: ''!
I am a test case ensuring that some protocols that were removed from the system are not introduced again. 

The goal is to keep some conventions around protocols. For example we should use #removing and not #remove or #removal. The goal is to keep the number of protocols in the default image resonable to be able to give better propositions to the users.!
!ProtocolConventionsTest methodsFor: 'tests' stamp: ''!
testProperUtilitiesProtocolIsUsed

	self checkIdiomForRuleClass: ReProperMethodProtocolNameForUtilitiesRule notMoreViolationsThan: 5! !

!ProtocolConventionsTest methodsFor: 'asserting' stamp: ''!
assertProtocolName: aProtocolName notAcceptingProtocolNamesLike: aCollectionOfSelectors notMoreViolationsThan: aCount
	| violations |
	violations := self class environment allClassesAndTraits
		select: [ :c | (c protocols includesAny: aCollectionOfSelectors) or: [ c class protocols includesAny: aCollectionOfSelectors ] ].
	self
		assert: violations size <= aCount
		description: [ 'In the default Pharo images, the protocol #{1} should be used instead of {2}.
Some classes are violating this convention:
{3}'
				format:
					{aProtocolName . aCollectionOfSelectors asString . (String
						streamContents: [ :s | 
							violations
								do: [ :c | 
									s
										<< '- ';
										print: c ]
								separatedBy: [ s cr ] ])} ]! !

!ProtocolConventionsTest methodsFor: 'asserting' stamp: ''!
assertProtocolName: aProtocolName notAcceptingProtocolNamesLike: aCollectionOfSelectors
	| violations |
	violations := self class environment allClassesAndTraits
		select: [ :c | (c protocols includesAny: aCollectionOfSelectors) or: [ c class protocols includesAny: aCollectionOfSelectors ] ].
	self
		assert: violations isEmpty
		description: [ 'In the default Pharo images, the protocol #{1} should be used instead of {2}.
Some classes are violating this convention:
{3}'
				format:
					{aProtocolName . aCollectionOfSelectors asString . (String
						streamContents: [ :s | 
							violations
								do: [ :c | 
									s
										<< '- ';
										print: c ]
								separatedBy: [ s cr ] ])} ]! !

!ProtocolConventionsTest methodsFor: 'tests' stamp: ''!
testProperAccessingProtocolIsUsed

	self checkIdiomForRuleClass: ReProperMethodProtocolNameForAccessingRule notMoreViolationsThan: 1! !

!ProtocolConventionsTest methodsFor: 'tests' stamp: ''!
testProperFileInOutProtocolIsUsed

	self checkIdiomForRuleClass: ReProperMethodProtocolNameForFileInOutRule! !

!ProtocolConventionsTest methodsFor: 'tests' stamp: ''!
testProperTestProtocolIsUsed

	self checkIdiomForRuleClass: ReProperMethodProtocolNameForTestsRule notMoreViolationsThan: 3! !

!ProtocolConventionsTest methodsFor: 'utilities' stamp: ''!
checkIdiomForRuleClass: aRuleClass

	self checkIdiomForRuleClass: aRuleClass notMoreViolationsThan: 0! !

!ProtocolConventionsTest methodsFor: 'tests' stamp: ''!
testProperConvertingProtocolIsUsed

	self checkIdiomForRuleClass: ReProperMethodProtocolNameForConvertingRule notMoreViolationsThan: 29! !

!ProtocolConventionsTest methodsFor: 'tests' stamp: ''!
testProperInstanceCreationProtocolIsUsed

	self checkIdiomForRuleClass: ReProperMethodProtocolNameForInstanceCreationRule! !

!ProtocolConventionsTest methodsFor: 'utilities' stamp: ''!
checkIdiomForRuleClass: aRuleClass notMoreViolationsThan: aCount

	| idiom |
	idiom := aRuleClass protocolIdiom.
	
	self
		assertProtocolName: idiom key
		notAcceptingProtocolNamesLike: idiom value
		notMoreViolationsThan: aCount! !

!ProtocolConventionsTest methodsFor: 'tests' stamp: ''!
testProperRemovalProtocolIsUsed

	self checkIdiomForRuleClass: ReProperMethodProtocolNameForRemovalRule! !

!ProtocolOrganizer commentStamp: ''!
A ProtocolOrganizer is part of a ClassOrganizer. 

It manages the protocols of the class that owns it!
!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
allMethodSelectors
	^ self protocols flatCollect: [ :p | p methodSelectors ]! !

!ProtocolOrganizer methodsFor: 'importing' stamp: ''!
fromSpec: aSpec
	aSpec
		do: [ :spec | 
			| name methods |
			name := spec first asSymbol.
			methods := spec allButFirst asSet.
			self addProtocol: (Protocol name: name methodSelectors: methods) ]! !

!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
renameProtocol: oldName into: newName
	(self existsProtocolNamed: newName) 
		ifTrue: [ 
			self moveMethodsFrom: oldName to: newName.
			self removeProtocolNamed: oldName ] 
		ifFalse: [ 
			^ (self protocolNamed: oldName)
				name: newName;
				yourself ].! !

!ProtocolOrganizer methodsFor: 'testing' stamp: ''!
hasProtocolNamed: aString

	^ self allProtocols anySatisfy: [ :each | each name = aString ]! !

!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
protocolNamed: aName

	^ self 
		protocolNamed: aName 
		ifAbsent: [ Protocol empty ]! !

!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
allProtocol

	^ allProtocol! !

!ProtocolOrganizer methodsFor: 'protocol - removing' stamp: ''!
removeProtocolNamed: aName
	| protocolToRemove |
	
	protocolToRemove := self protocolNamed: aName.
	^ self removeProtocol: protocolToRemove! !

!ProtocolOrganizer methodsFor: 'protocol - adding' stamp: ''!
classify: aSymbol inProtocolNamed: aProtocolName
	| name protocol |
	name := aProtocolName.
	name = allProtocol name ifTrue: [ name := Protocol unclassified ].

	"maybe here we should check if this method already belong to another protocol"
	(self protocolsOfSelector: aSymbol) do: [ :p | p removeMethodSelector: aSymbol ].
	protocol := self getProtocolNamed: name ifNone: [ self addProtocolNamed: name ].

	protocol addMethodSelector: aSymbol! !

!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
allProtocolsNames

	^ self allProtocols collect: [:each | each name]! !

!ProtocolOrganizer methodsFor: 'protocol' stamp: ''!
protocolsOfSelector: aSelector

	^ (self protocols select: [:each | each includesSelector: aSelector ]) asArray! !

!ProtocolOrganizer methodsFor: 'protocol - removing' stamp: ''!
removeProtocol: aProtocol
	
	aProtocol canBeRemoved ifFalse:  [ ^ self ].
	^ protocols 
		remove: aProtocol
		ifAbsent: [ ]! !

!ProtocolOrganizer methodsFor: 'private' stamp: ''!
moveMethodsFrom: fromProtocolNamed to: toProtocolNamed
	| fromProtocol toProtocol |
	
	fromProtocol := self protocolNamed: fromProtocolNamed.
	toProtocol := self protocolNamed: toProtocolNamed.
	
	toProtocol addAllMethodsFrom: fromProtocol.
	fromProtocol removeAllMethodSelectors.
	
	^ toProtocol.! !

!ProtocolOrganizer methodsFor: 'protocol - removing' stamp: ''!
removeEmptyProtocols
	| removedProtocols |
	removedProtocols := protocols select: [:e | e isEmpty and: [ e canBeRemoved ] ].
	removedProtocols do: [:each | self removeProtocol: each].
	^removedProtocols! !

!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
extensionProtocols
	^ self protocols select: #isExtensionProtocol! !

!ProtocolOrganizer methodsFor: 'backward compatibility' stamp: ''!
methodsInProtocolNamed: aName
	aName = AllProtocol defaultName ifTrue: [ ^ self allMethodSelectors ].

	^ (self protocolNamed: aName) methodSelectors! !

!ProtocolOrganizer methodsFor: 'initialization' stamp: ''!
reset
	protocols := IdentitySet new.
	allProtocol := AllProtocol protocolOrganizer: self.! !

!ProtocolOrganizer methodsFor: 'private' stamp: ''!
existsProtocolNamed: aProtocolName
	
	^self allProtocols anySatisfy: [ :e | e name = aProtocolName ]! !

!ProtocolOrganizer methodsFor: '*CodeExport' stamp: ''!
stringForFileOut
	^ String
		streamContents: [ :aStream | 
			self protocols
				do: [ :p | 
					aStream
						nextPut: $(;
						nextPutAll: p name printString.
					p methodSelectors
						do: [ :m | 
							aStream
								space;
								nextPutAll: m ].
					aStream
						nextPut: $);
						cr ] ]! !

!ProtocolOrganizer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self reset! !

!ProtocolOrganizer methodsFor: 'protocol' stamp: ''!
getProtocolNamed: aByteString ifNone: aBlockClosure 
	
	^ protocols detect: [:e | e name = aByteString ] ifNone: aBlockClosure! !

!ProtocolOrganizer methodsFor: 'protocol - adding' stamp: ''!
addProtocol: aProtocol

	^ protocols add: aProtocol! !

!ProtocolOrganizer methodsFor: 'testing' stamp: ''!
includesSelector: selector 
	^ protocols anySatisfy: [ :each | each includesSelector: selector ]! !

!ProtocolOrganizer methodsFor: 'protocol - adding' stamp: ''!
addProtocolNamed: aName
	^ protocols add: (Protocol name: aName)! !

!ProtocolOrganizer methodsFor: 'protocol' stamp: ''!
protocolsSorted
	^ (self protocols collect: #name as: Array) sort
		copyWithFirst: allProtocol name! !

!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
removeMethod: aSymbol

	(self protocolsOfSelector: aSymbol) do: [ :p | p removeMethodSelector: aSymbol ]! !

!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
protocols

	^ protocols asArray! !

!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
allProtocols

	^ { allProtocol }, protocols asArray! !

!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
protocolsNames

	^ protocols 
		collect: #name 
		as: Array! !

!ProtocolOrganizer methodsFor: 'accessing' stamp: ''!
protocolNamed: aString ifAbsent: aBlock 
	^  self allProtocols 
		detect: [ :e | e name = aString ] 
		ifNone: aBlock! !

!ProtocolOrganizer class methodsFor: 'import' stamp: ''!
fromSpec: aSpec
	
	^ self new
		fromSpec: aSpec;
		yourself! !

!ProtocolRemovalException commentStamp: ''!
A ProtocolRemovalException is an error raised when someone try to remove a protocol that should not be removed!
!ProtocolRemoved commentStamp: ''!
This class is not used, but should be used when we hook into the addition and removal of protocols. Right now, we only get ClassReorganizedAnnouncement!
!ProtocolRenamed commentStamp: ''!
This is event about protocol rename. It should substitute ClassReorganized announcement !
!ProtocolRenamed methodsFor: 'accessing' stamp: ''!
oldProtocolName
	^ protocol! !

!ProtocolRenamed methodsFor: 'accessing' stamp: ''!
oldProtocolName: aString
	self protocol: aString! !

!ProtocolRenamed methodsFor: 'accessing' stamp: ''!
newProtocolName
	^ newProtocolName! !

!ProtocolRenamed methodsFor: 'accessing' stamp: ''!
newProtocolName: anObject
	newProtocolName := anObject! !

!PrototypeTester commentStamp: ''!
I am a simple holder of a prototype object and hand out copies when requested.
My subclasses should define resultFor: a!
!PrototypeTester methodsFor: 'accessing' stamp: ''!
prototype: aPrototype
	"Set my prototype"

	prototype := aPrototype copy! !

!PrototypeTester methodsFor: 'operation' stamp: ''!
result
	"Perform the test the default number of times"

	^ self resultFor: self class defaultRuns! !

!PrototypeTester methodsFor: 'accessing' stamp: ''!
prototype
	"Get a prototype"

	^ prototype copy! !

!PrototypeTester methodsFor: 'operation' stamp: ''!
resultFor: runs 
	"Test that equality is the same over runs and answer the result"
	
	self subclassResponsibility! !

!PrototypeTester class methodsFor: 'default' stamp: ''!
defaultRuns
	"Returns the default number of times to test"

	^ 50! !

!PrototypeTester class methodsFor: 'instance creation' stamp: ''!
with: aPrototype

	^ self new prototype: aPrototype! !

!ProvideAnswerNotification commentStamp: ''!
Notify to provide an answer!
!QSystemTally commentStamp: ''!
Tally for assembling system profiles. It's a subclass of Link so we can chain tallies together in the receivers list.!
!QSystemTally methodsFor: 'accessing' stamp: ''!
maxClassPlusSelectorSize
	"Return the default maximum width of the class plus selector together (not counting the '>>')"
	^60! !

!QSystemTally methodsFor: 'report' stamp: ''!
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: 'converting' stamp: ''!
asArray
	| link |
	^Array streamContents: [ :s |
		link := self.
		[link == nil] whileFalse: [
			s nextPut: link.
			link := link nextLink.
		].
	].! !

!QSystemTally methodsFor: 'report' stamp: ''!
getNewTabsFor: tabs
	^ tabs size < self maxTabs
		ifTrue: [ tabs ]
		ifFalse: [ (tabs select: [ :x | x = '[' ]) copyWith: '[' ]! !

!QSystemTally methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream print: class; nextPutAll: '>>'; print: (method ifNotNil:[method selector]).
	aStream nextPutAll: ' -- '; print: tally.! !

!QSystemTally methodsFor: 'copying' stamp: ''!
copyWithTally: hitCount
	^ (QSystemTally new class: class method: method) bumpBy: hitCount! !

!QSystemTally methodsFor: 'testing' stamp: ''!
isPrimitives
	"Detect pseudo node used to carry tally of local hits"

	^ method isNil! !

!QSystemTally methodsFor: 'tallying' stamp: ''!
bumpBy: count
	"Bump this tally by the specified amount"
	tally := tally + count! !

!QSystemTally methodsFor: 'initialize' stamp: ''!
class: aClass method: aCompiledMethod
	class := aClass.
	method := aCompiledMethod.
	tally := 0.! !

!QSystemTally methodsFor: 'report' stamp: ''!
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: 'tallying' stamp: ''!
tally: context by: count
	"Explicitly tally the specified context and its stack."

	^ context sender
		ifNil: [ (self bumpBy: count) tallyPath: context by: count ]
		ifNotNil: [ :root | (self tally: root by: count) tallyPath: context by: count ]! !

!QSystemTally methodsFor: 'tallying' stamp: ''!
tallyMethod: aMethod by: count
	"Called explicitly and needs to decrement receiver's tally count"
	| node |
	node := receivers.
	[node isNil] 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: 'accessing' stamp: ''!
maxClassNameSize
	"Return the default maximum width of the class name alone"
	^30! !

!QSystemTally methodsFor: 'accessing' stamp: ''!
method
	"Answer the CompiledMethod associated with this tally"
	^method! !

!QSystemTally methodsFor: 'accessing' stamp: ''!
tally
	"Answer the tally count for this node"
	^tally! !

!QSystemTally methodsFor: 'tallying' stamp: ''!
tallyPath: context by: count
	"Tally the context chain"

	| aMethod aTally |
	aMethod := context method.
	aTally := receivers.
	[ aTally isNil ]
		whileFalse: [ 
			aTally method == aMethod
				ifTrue: [ ^ aTally bumpBy: count ].
			aTally := aTally nextLink ].
	aTally := QSystemTally new class: context receiver class method: aMethod.
	aTally nextLink: receivers.
	receivers := aTally.
	^ aTally bumpBy: count! !

!QSystemTally methodsFor: 'report' stamp: ''!
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 ifNil: [ ^ 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: 'report' stamp: ''!
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: ''!
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: 'converting' stamp: ''!
asSortedCollection: aCollection
	"Create a sorted collection from the given input"
	^aCollection asSortedCollection: [ :tA :tB | tA tally >= tB tally ]! !

!QSystemTally methodsFor: 'report' stamp: ''!
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: ''!
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: 'initialize' stamp: ''!
primitives: anInteger
	"Make the receiver be a node of unassigned primitives"
	tally := anInteger.
	method := nil. "indicates primitives"! !

!QSystemTally methodsFor: 'report' stamp: ''!
into: leafDict fromSender: senderTally
	| leafNode |
	leafNode := leafDict at: method ifAbsentPut: [ QSystemTally new class: class method: method ].
	leafNode bump: tally fromSender: senderTally! !

!QSystemTally methodsFor: 'accessing' stamp: ''!
maxTabs
	"Return the default number of tabs after which leading white space is compressed"
	^36! !

!QSystemTally class methodsFor: 'LICENSE' stamp: ''!
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.'! !

!QueryAnnotationsFromClassTest methodsFor: 'tests' stamp: ''!
testWhenAnnotationFailsCheckForForbiddenProperty

	| annotations ann |
	[ ClassAnnotationExampleWithFailedForbiddenCheck new isForbidden.
	self assert: false description: 'should fail'  ] onErrorDo: [ ].

	annotations := ClassWithForbiddenAnnotationExample classAnnotations.	
	self assert: annotations size equals: 2. "one forbidden and one broken"
	
	ann := (annotations reject: #isForbidden) anyOne.
	
	self assert: ann class equals: BrokenClassAnnotation.
	self assert: ann annotatedClass equals: ClassWithForbiddenAnnotationExample.
	self assert: ann declarationSelector equals: #failedForbiddenAnnotation! !

!QueryAnnotationsFromClassTest methodsFor: 'tests' stamp: ''!
testAllowDebugBrokenAnnotations

	| annotations ann |
	annotations := ClassWithBrokenAnnotatingMethod classAnnotations.	
	self assert: annotations size equals: 1.
	
	ann := annotations anyOne.
	self assert: ann class equals: BrokenClassAnnotation.

	[ann debug.
	self assert: false description: 'should fail'] 
		on: Error do: [ :err | 
	self assert: err messageText equals: ClassWithBrokenAnnotatingMethod brokenAnnotationMessage  ]! !

!QueryAnnotationsFromClassTest methodsFor: 'tests' stamp: ''!
testWhenDeclaringMethodIsBroken

	| annotations ann |
	annotations := ClassWithBrokenAnnotatingMethod classAnnotations.	
	self assert: annotations size equals: 1.
	
	ann := annotations anyOne.
	
	self assert: ann class equals: BrokenClassAnnotation.
	self assert: ann annotatedClass equals: ClassWithBrokenAnnotatingMethod.
	self assert: ann declarationSelector equals: #brokenAnnotation.
	self assert: (ann errorString endsWith: ClassWithBrokenAnnotatingMethod brokenAnnotationMessage).! !

!QueryAnnotationsFromClassTest methodsFor: 'tests' stamp: ''!
testWhenDeclaringMethodNotReturnAnnotation

	| annotations ann |
	annotations := ClassWithBadAnnotatingMethod classAnnotations.	
	self assert: annotations size equals: 1.
	
	ann := annotations anyOne.
	
	self assert: ann class equals: BrokenClassAnnotation.
	self assert: ann annotatedClass equals: ClassWithBadAnnotatingMethod.
	self assert: ann declarationSelector equals: #badAnnotation! !

!QueryAnnotationsFromClassTest methodsFor: 'tests' stamp: ''!
testWhenSuperclassIsAnnotatedToo

	| annotations |
	annotations := SubclassWithOnlyInheritedAnnotation classAnnotations.
	
	self assert: annotations size equals: 1.
	self assert: annotations anyOne annotatedClass equals: SubclassWithOnlyInheritedAnnotation! !

!QueryAnnotationsFromClassTest methodsFor: 'tests' stamp: ''!
testReturnsInstancesFromAllAnnotatingMethods

	| annotations |
	annotations := ClassWithThreeAnnotations classAnnotations.
	
	self assert: annotations size equals: 3.
	annotations do: [ :each | 
		self assert: each annotatedClass equals: ClassWithThreeAnnotations]! !

!QueryAnnotationsFromClassTest methodsFor: 'tests' stamp: ''!
testCanBeEnumerated

	| enumerated |
	enumerated := OrderedCollection new.
	ClassWithThreeAnnotations classAnnotationsDo: [:each | enumerated add: each].
	
	self assert: enumerated asArray equals: ClassWithThreeAnnotations classAnnotations asArray! !

!QueryAnnotationsFromClassTest methodsFor: 'tests' stamp: ''!
testAllowDebugForbiddenBrokenAnnotations

	| annotations ann |
	annotations := ClassWithForbiddenAnnotationExample classAnnotations.	
	self assert: annotations size equals: 2. "onw forbidden and one broken"
	
	ann := (annotations reject: #isForbidden) anyOne.
	self assert: ann class equals: BrokenClassAnnotation.

	[ann debug.
	self assert: false description: 'should fail'] 
		on: Error do: [ :err |  ]! !

!QueryAnnotationsFromClassTest methodsFor: 'tests' stamp: ''!
testWhenClassHasNoAnnotations

	| annotations |
	annotations := ClassWithoutAnnotations classAnnotations.
	
	self assert: annotations isEmpty! !

!QueryAnnotationsFromClassTest methodsFor: 'tests' stamp: ''!
testWhenItOverridesSuperclassAnnotations

	| annotations |
	annotations := SubclassWithOverridenAnnotation classAnnotations.
	
	self assert: annotations size equals: 1.
	self assert: annotations anyOne annotatedClass equals: SubclassWithOverridenAnnotation.
	self assert: annotations anyOne class equals: ClassAnnotationExample2.! !

!QuestionDialogWindow commentStamp: ''!
A yes/no/cancel message dialog. Cancel (escape & return) is the default.!
!QuestionDialogWindow methodsFor: 'accessing' stamp: ''!
answer: anObject
	"Set the value of answer"

	answer := anObject! !

!QuestionDialogWindow methodsFor: 'accessing' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self newYesButton. self newNoButton. self newCancelButton isDefault: true}! !

!QuestionDialogWindow methodsFor: 'accessing' stamp: ''!
yes
	"Answer yes."

	self
		answer: true;
		ok! !

!QuestionDialogWindow methodsFor: 'accessing' stamp: ''!
no
	"Answer no."

	self
		answer: false;
		ok! !

!QuestionDialogWindow methodsFor: 'accessing' stamp: ''!
answer
	"Answer the value of answer"

	^ answer! !

!QuestionWithoutCancelDialogWindow commentStamp: ''!
A yes/no message dialog. Yes (return) is the default. Escape will answer no.!
!QuestionWithoutCancelDialogWindow methodsFor: 'keymapping' stamp: ''!
closeWindowAction
	
	self escapePressed! !

!QuestionWithoutCancelDialogWindow methodsFor: 'actions' stamp: ''!
escapePressed
	"Default is to cancel."

	self no! !

!QuestionWithoutCancelDialogWindow methodsFor: 'accessing' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self newYesButton isDefault: true. self newNoButton}! !

!QuotedPrintableMimeConverter commentStamp: ''!
I am QuotedPrintableMimeConverter.
I am a MimeConverter.

Quoted-Printable, or QP encoding, is an encoding using printable ASCII characters (alphanumeric and the equals sign "=") to transmit 8-bit data over a 7-bit data path or, generally, over a medium which is not 8-bit clean. It is defined as a MIME content transfer encoding for use in e-mail.

QP works by using the equals sign "=" as an escape character. It also limits line length to 76, as some software has limits on line length.

See also 

  http://en.wikipedia.org/wiki/Quoted-printable
  http://tools.ietf.org/html/rfc2045

I do quoted printable MIME decoding as specified in RFC 2045 "MIME Part One: Format of Internet Message Bodies".

Short version of RFC2045, Sect. 6.7:

	(1) Any octet, except a CR or LF that is part of a CRLF line break of the canonical (standard) form of the data being encoded, may be represented by an "=" followed by a two digit hexadecimal representation of the octet's value. [...]

	(2) Octets with decimal values of 33 through 60 inclusive, and 62 through 126, inclusive, MAY be represented as the US-ASCII characters which correspond to those octets [...].

	(3) Octets with values of 9 and 32 MAY be represented as US-ASCII TAB (HT) and SPACE characters,
 respectively, but MUST NOT be so represented at the end of an encoded line.  [...]

	(4) A line break in a text body, represented as a CRLF sequence in the text canonical form, must be represented by a (RFC 822) line break, which is also a CRLF sequence, in the Quoted-Printable encoding.  [...]

	(5) The Quoted-Printable encoding REQUIRES that encoded lines be no more than 76 characters long.  If longer lines are to be encoded with the Quoted-Printable encoding, "soft" line breaks
 must be used.  An equal sign as the last character on a encoded line indicates such a non-significant ("soft") line break in the encoded text.!
!QuotedPrintableMimeConverter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	newline := String cr! !

!QuotedPrintableMimeConverter methodsFor: 'converting' stamp: ''!
mimeEncode
	| char charValue lineLength |
	lineLength := 0.
	[ dataStream atEnd ] whileFalse: [
		lineLength >= 74
			ifTrue: [
				mimeStream nextPut: $=; nextPutAll: newline.
				lineLength := 0].
		char := dataStream next.
		charValue := char asInteger.
		(charValue = 9 | (charValue between: 32 and: 60) | (charValue between: 62 and: 126))
			ifTrue: [
				mimeStream nextPut: char.
				lineLength := lineLength + 1 ]
			ifFalse: [
				(char = Character cr) | (char = Character lf)
					ifTrue: [
						mimeStream nextPutAll: '=0D=0A'.
						char = Character cr ifTrue: [ dataStream peekFor: Character lf ].
						lineLength := lineLength + 6 ]
					ifFalse: [
						charValue > 255 ifTrue: [ self error: 'Character out of range' ].
						mimeStream nextPut: $=.
						char asInteger printOn: mimeStream base: 16 length: 2 padded: true.
						lineLength := lineLength + 3 ] ] ]! !

!QuotedPrintableMimeConverter methodsFor: 'initialization' stamp: ''!
newline: string
	"Set another newline convention, like CRLF or LF that I should use.
	By default I use CR."
	
	newline := string! !

!QuotedPrintableMimeConverter methodsFor: 'converting' stamp: ''!
mimeDecode
	| char outChar previousChar |
	previousChar := nil.
	[ mimeStream atEnd ] whileFalse: [
		char := mimeStream next.
		outChar := (char = $=
			ifTrue: [
				((char := mimeStream next) = Character cr) | (char = Character lf)
					ifTrue: [
						char = Character cr ifTrue: [ mimeStream peekFor: Character lf ].
						nil ]
					ifFalse: [
						Character codePoint: char digitValue * 16 + mimeStream next digitValue ] ]
			ifFalse: [ char ]).
		outChar notNil 
			ifTrue: [ 
				(outChar = Character lf) & (previousChar = Character cr)
					ifTrue: [ dataStream nextPutAll: newline ]
					ifFalse: [ 
						(outChar = Character cr) | (outChar = Character lf) 
							ifFalse: [ dataStream nextPut: outChar ] ].
				previousChar := outChar ] ]! !

!QuotedPrintableMimeConverterTest commentStamp: ''!
SUnit tests for QuotedPrintableMimeConverter!
!QuotedPrintableMimeConverterTest methodsFor: 'accessing' stamp: ''!
decode: string
	^ coder mimeDecode: string as: String! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testEncodeCR

	self 
		assert: (self encode: 'This is the first line', String cr, 'and this is the second')
		equals: 'This is the first line=0D=0Aand this is the second'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testDecodeSimpleStrings

	self 
		assert: (self decode: 'Z=FCrich') 
		equals: 'Zürich'.
	self 
		assert: (self decode: 'H=E4tten H=FCte ein =DF im Namen, w=E4ren sie m=F6glicherweise keine H=FCte mehr') 
		equals: 'Hätten Hüte ein ß im Namen, wären sie möglicherweise keine Hüte mehr'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testDecodeSoftLinebreak

	self 
		assert: (self decode: 'This is text may not be=
 decoded as two lines')
		equals: 'This is text may not be decoded as two lines'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testEncodeEncodedStrings

	"An = becomes =3D and is then not decodable any more (only if you know you have to do it twice ;-) )"
	self
		assert: (self encode: 'Z=FCrich')
		equals: 'Z=3DFCrich'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testDecodeSoftLinebreakCR

	self 
		assert: (self decode: 'This is text may not be=', String cr, ' decoded as two lines')
		equals: 'This is text may not be decoded as two lines'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testEncodeSoftLinebreak

	| original encoded |

	original :=
		'Cowards die many times before their deaths; The valiant never taste of death but once.
Of all the wonders that I yet have heard, it seems to me most strange that men should fear;
Seeing that death, a necessary end, will come when it will come'.

	encoded :=
		'Cowards die many times before their deaths; The valiant never taste of dea=
th but once.=0D=0AOf all the wonders that I yet have heard, it seems to me=
 most strange that men should fear;=0D=0ASeeing that death, a necessary en=
d, will come when it will come'.

	"When encoding soft line breaks the encoded breaks must be taken into
	account when calculating the maximum line length."
	self assert: (original lines anySatisfy: [ :line | line size > 76 ]).
	self deny: (encoded lines anySatisfy: [ :line | line size > 76 ]).
	
	self assert: (self encode: original) equals: encoded.
	self assert: (self decode: encoded) equals: original! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testDecodeSoftLinebreakCRLF

	self 
		assert: (self decode: 'This is text may not be=', String crlf, ' decoded as two lines')
		equals: 'This is text may not be decoded as two lines'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testDecodeCRLF

	self 
		assert: (self decode: 'This is the first line=0D=0A and this is the second')
		equals: 'This is the first line
 and this is the second'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testDecodeDecodedStrings

	self 
		assert: (self decode: 'Hätten Hüte ein ß im Namen, wären sie möglicherweise keine Hüte mehr')
		equals: 'Hätten Hüte ein ß im Namen, wären sie möglicherweise keine Hüte mehr'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testDecodeCustomNewline
	| decoder output |
	decoder := coder new.
	output := String new writeStream.
	decoder 
		newline: String lf;
		mimeStream: 'foo=0D=0Abar' readStream;
		dataStream: output;
		mimeDecode.
	self 
		assert: output contents
		equals: 'foo', String lf, 'bar'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testEncodeLF

	self 
		assert: (self encode: 'This is the first line', String lf, 'and this is the second')
		equals: 'This is the first line=0D=0Aand this is the second'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testEncodeSimpleStrings

	self 
		assert: (self encode: 'Zürich')
		equals: 'Z=FCrich'.
	self 
		assert: (self encode: 'Über die Fährverbindungen nach Föhr wüßte ich nicht viel')
		equals: '=DCber die F=E4hrverbindungen nach F=F6hr w=FC=DFte ich nicht viel'! !

!QuotedPrintableMimeConverterTest methodsFor: 'accessing' stamp: ''!
encode: string
	^ coder mimeEncode: string! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testLongLine
	| input output |
	
	input := (String new: 74 withAll: $A), (String new: 47 withAll: $B).
	
	output := (String new: 74 withAll: $A), '=
', (String new: 47 withAll: $B).
	
	self 
		assert: (self encode: input)
		equals: output! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testEncodeLongLine
	| input output |
	
	input := (String new: 74 withAll: $A), (String new: 47 withAll: $B).
	
	output := (String new: 74 withAll: $A), '=
', (String new: 47 withAll: $B).
	
	self 
		assert: (self encode: input)
		equals: output! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testDecodeSoftLinebreakLF

	self 
		assert: (self decode: 'This is text may not be=', String lf, ' decoded as two lines')
		equals: 'This is text may not be decoded as two lines'! !

!QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: ''!
testEncodeCRLF

	self 
		assert: (self encode: 'This is the first line', String crlf, 'and this is the second')
		equals: 'This is the first line=0D=0Aand this is the second'! !

!QuotedPrintableMimeConverterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	coder := QuotedPrintableMimeConverter! !

!RBASTClassesHelp commentStamp: ''!
Book from RBProgramNode and subclasses.!
!RBASTClassesHelp class methodsFor: 'building' stamp: ''!
rootHelpClass
	^ RBProgramNode! !

!RBAbstractBlockVisitor commentStamp: ''!
Abstract visitor providing generic block visiting capabilities.
Subclasses provide specific node type capabilties
!
!RBAbstractBlockVisitor methodsFor: 'accessing' stamp: ''!
visitBlock: anObject
	visitBlock := anObject! !

!RBAbstractBlockVisitor methodsFor: 'accessing' stamp: ''!
visitBlock
	^ visitBlock! !

!RBAbstractBlockVisitor class methodsFor: 'enumerating' stamp: ''!
visit: aTree do: aBlock
	^self new 
		visitBlock: aBlock;
		visitNode: aTree! !

!RBAbstractBlockVisitor class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBAbstractBlockVisitor! !

!RBAbstractBlockVisitor class methodsFor: 'enumerating' stamp: ''!
visit: aTree detect: aBlock ifNone: anErrorBlock
	self
		visit: aTree
		do: [ :node | (aBlock value: node) ifTrue: [ ^ node ] ].
	^ anErrorBlock value! !

!RBAbstractBlockVisitor class methodsFor: 'enumerating' stamp: ''!
visit: aTree anySatisfy: aBlock
	self
		visit: aTree
		do: [ :node | (aBlock value: node) ifTrue: [ ^ true ] ].
	^ false! !

!RBAbstractBlockVisitor class methodsFor: 'enumerating' stamp: ''!
visit: aTree detect: aBlock
	
	^self visit: aTree detect: aBlock ifNone: [ NotFound signalFor: aBlock ]! !

!RBAbstractBlockVisitor class methodsFor: 'enumerating' stamp: ''!
visit: aTree select: aBlock
	| result |
	result := OrderedCollection new.
	self visit: aTree do: [ :node |
		(aBlock value: node) ifTrue: [ result add: node ] ].
	^result! !

!RBAbstractBlockVisitor class methodsFor: 'enumerating' stamp: ''!
visit: aTree noneSatisfy: aBlock
	self
		visit: aTree
		do: [ :node | (aBlock value: node) ifTrue: [ ^ false ] ].
	^ true! !

!RBAbstractClass commentStamp: ''!
I am the base class of RBClass and RBMetaclass implementing the common behavior for creating and accessing class and metaclass elements in a refactoring namespace. 

My subclass instances are created in a refactoring namespace when querying the environment for existing 
classes (or metaclasses) and when creating or changing classes during refactoring operations.

RBClass and RBMetaclass are used to model existing, changed or newly added classes before actually applying the refactoring change to the system. 
You can query the class name,  defined methods and  variables. 
They provide a similar interface like the real classes, but only the part that is necessary  for the 
refactoring framework.

They shouldn't be directly used and always be a part of a refacotoring namespace - the model.

Likewise this classes, my methods aren't real methods but models (RBMethod) that representing a real methods.

Changes for my methods during refactoring are stored in a list of
newMethods and removedMethods.
Like a real class I referre to my superclass and subclass, which again are actually RBClasses.
!
!RBAbstractClass methodsFor: 'private' stamp: ''!
addSubclass: aRBClass 
	self subclasses add: aRBClass! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
canUnderstand: aSelector 
	^self definesMethod: aSelector! !

!RBAbstractClass methodsFor: 'querying' stamp: ''!
setterMethodFor: aVariableName
	| matcher candidateSetters |
	matcher := self parseTreeSearcherClass setterMethod: aVariableName.
	candidateSetters := (self definesInstanceVariable: aVariableName)
		ifTrue: [ self whichSelectorsReferToInstanceVariable: aVariableName ]
		ifFalse: [ self whichSelectorsReferToClassVariable: aVariableName ].
	candidateSetters := candidateSetters
		select: [ :each | each numArgs == 1 ].
	^ candidateSetters
		detect: [ :each | 
			(self checkSelector: each using: matcher) notNil
				and: [ (self subclassRedefines: each) not ] ]
		ifNone: [ nil ]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
isDefined
	^self realClass notNil! !

!RBAbstractClass methodsFor: 'variable accessing' stamp: ''!
whoDefinesClassVariable: aString
	| sprClass |
	(self directlyDefinesClassVariable: aString) ifTrue: [ ^ self ].
	sprClass := self superclass.
	^ sprClass ifNotNil: [ sprClass whoDefinesClassVariable: aString ]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
directlyDefinesLocalMethod: aSelector 
	self isDefined 
		ifTrue: 
			[(self hasRemoved: aSelector) ifTrue: [^false].
			(self realClass includesLocalSelector: aSelector) ifTrue: [^true]].
	^newMethods notNil and: [newMethods includesKey: aSelector]! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
compile: aString withAttributesFrom: aRBMethod 
	| change method |
	change := model 
		compile: aString
		in: self
		classified: aRBMethod protocols.
	method := modelFactory rbMethod  
		for: self
		source: aString
		selector: change selector.
	self addMethod: method.
	^ change! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
allPoolDictionaryNames
	^self subclassResponsibility! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
checkSelector: aSelector using: aMatcher 

	| parseTree |
	parseTree := self parseTreeFor: aSelector.
	parseTree ifNotNil: [aMatcher executeTree: parseTree].
	^ aMatcher answer! !

!RBAbstractClass methodsFor: 'variable accessing' stamp: ''!
removeInstanceVariable: aString ifAbsent: aBlock
	self privateInstanceVariableNames remove: aString ifAbsent: aBlock.
	model removeInstanceVariable: aString from: self! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
newMethods

	^ newMethods ifNil: [ newMethods := IdentityDictionary new ] ifNotNil: [ newMethods ]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
model
	^model! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
firstSuperclassRedefines: aSelector
	"Return rbClass, if one of your superclasses redefines the method with name, aMethod"
	self allSuperclasses do: [:each |
		(each directlyDefinesMethod: aSelector) ifTrue: [^ each]].! !

!RBAbstractClass methodsFor: 'enumerating' stamp: ''!
allSubclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's subclasses."

	self subclassesDo: 
		[:cl | 
		aBlock value: cl.
		cl allSubclassesDo: aBlock]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
allMethods

	^ self allSelectors
		collect: [ :selector | self methodFor: selector ]
		thenSelect: #isNotNil! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
definesMethod: aSelector 
	(self directlyDefinesMethod: aSelector) ifTrue: [^true].
	^self superclass notNil and: [self superclass definesMethod: aSelector]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
allSubclasses
	| allSubclasses index |
	index := 1.
	allSubclasses := OrderedCollection withAll: self subclasses.
	[index <= allSubclasses size] whileTrue: 
			[allSubclasses addAll: (allSubclasses at: index) subclasses.
			index := index + 1].
	^allSubclasses! !

!RBAbstractClass methodsFor: 'printing' stamp: ''!
canonicalArgumentName
	| prefix |
	prefix := self name first isVowel
		ifTrue: [ 'an' ]
		ifFalse: [ 'a' ].
	^ prefix, self name! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
superclassRedefines: aSelector
	"Return true, if one of your superclasses redefines the method with name, aMethod"
	
	^ self allSuperclasses anySatisfy: [ :each | each directlyDefinesMethod: aSelector ]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
hasRemoved: aSelector 
	^removedMethods notNil and: [removedMethods includes: aSelector]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
classBinding
	^ Smalltalk globals associationAt: self name! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
removeMethod: aSelector 
	self newMethods removeKey: aSelector ifAbsent: [].
	model removeMethod: aSelector from: self.
	self removedMethods add: aSelector! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
superclass
	^superclass == LookupSuperclass 
		ifTrue: [model classFor: self realClass superclass]
		ifFalse: [superclass]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
isAbstract
	(self whichSelectorsReferToSymbol: #subclassResponsibility) ifNotEmpty: [^true].
	model allReferencesToClass: self do: [:each | ^false].
	^true! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
definesPoolDictionary: aSymbol 
	(self directlyDefinesPoolDictionary: aSymbol) ifTrue: [^true].
	^ self superclass notNil 
				and: [self superclass definesPoolDictionary: aSymbol]! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
allSelectors
	| class selectors |
	class := self.
	selectors := Set new.
	[class notNil] whileTrue: 
			[selectors addAll: class selectors.
			class := class superclass].
	^selectors! !

!RBAbstractClass methodsFor: 'comparing' stamp: ''!
= aRBClass 
	^self class = aRBClass class 
		and: [self name = aRBClass name and: [self model = aRBClass model]]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
classSide
	"Return the metaclass of the couple class/metaclass. Useful to avoid explicit test."
	
	^ model metaclassNamed: self name! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
methodFor: aSelector
	^ self newMethods
		at: aSelector
		ifAbsent: [ | compiledMethod class |
			(self hasRemoved: aSelector) ifTrue: [ ^ nil ].
			class := self realClass.
			class ifNil: [ ^ nil ].
			compiledMethod := class compiledMethodAt: aSelector ifAbsent: [ nil ].
			compiledMethod ifNotNil: [ 
				compiledMethod isFromTrait 
					ifTrue: [ (compiledMethod traitSource hasMethod: aSelector) ifTrue: [
						(model classNamed: compiledMethod origin name) methodFor: aSelector ] ]
					ifFalse: [modelFactory rbMethod for: self fromMethod: compiledMethod andSelector: aSelector ]] ]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
removedMethods

	^ removedMethods ifNil: [ removedMethods := Set new ] ifNotNil: [ removedMethods ]! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
compile: aString classified: aSymbolCollection 
	| change method |
	change := model 
				compile: aString
				in: self
				classified: aSymbolCollection.
	method := modelFactory rbMethod 
				for: self
				source: aString
				selector: change selector.
	self addMethod: method.
	^ change! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
hierarchyDefinesInstanceVariable: aString
	(self definesInstanceVariable: aString)
		ifTrue: [ ^ true ].
	^ self allSubclasses
		anySatisfy: [ :each | each directlyDefinesInstanceVariable: aString ]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
allClassVariableNames
	^self subclassResponsibility! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
whoDefinesMethod: aSelector
	| sprClass |
	(self directlyDefinesMethod: aSelector) ifTrue: [ ^ self ].
	sprClass := self superclass.
	^ sprClass ifNotNil: [ sprClass whoDefinesMethod: aSelector ]! !

!RBAbstractClass methodsFor: 'variable accessing' stamp: ''!
typeOfClassVariable: aSymbol 
	^model classNamed: #Object! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
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: ''!
existingMethodsThatReferTo: aSymbol 
	| existingMethods |
	existingMethods := self realClass thoroughWhichSelectorsReferTo: aSymbol.
	(newMethods isNil and: [ removedMethods isNil ])
		ifTrue: [ ^ existingMethods ].
	^ existingMethods 
		reject: [ :each | (self hasRemoved: each) or: [ self newMethods includesKey: each ] ]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
hierarchyDefinesPoolDictionary: aString
	(self definesPoolDictionary: aString)
		ifTrue: [ ^ true ].
	^ self allSubclasses
		anySatisfy: [ :each | each directlyDefinesPoolDictionary: aString ]! !

!RBAbstractClass methodsFor: 'private' stamp: ''!
privateInstanceVariableNames

	instanceVariableNames
		ifNil: [ self isDefined
				ifTrue: [ self instanceVariableNames: self realClass instVarNames ]
				ifFalse: [ instanceVariableNames := OrderedCollection new ]
			].
	^ instanceVariableNames! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
realName: aSymbol 
	^ self subclassResponsibility! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
protocolsFor: aSelector

	| change |

	change := self isMeta
		ifTrue: [ model changes changeForMetaclass: name selector: aSelector ]
		ifFalse: [ model changes changeForClass: name selector: aSelector ].
	^ change
		ifNil: [ self isDefined
				ifTrue: [ Array with: ( RBBrowserEnvironment new whichProtocolIncludes: aSelector in: self realClass ) ]
				ifFalse: [ #(#accessing) ]
			]
		ifNotNil: [ change protocols ]! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
sourceCodeFor: aSelector

	| class |

	class := self whoDefinesMethod: aSelector.
	class ifNil: [ ^ nil ].
	^ ( class methodFor: aSelector ) source! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
parseTreeFor: aSelector

	| class method |

	class := self whoDefinesMethod: aSelector.
	class ifNil: [ ^ nil ].
	method := class methodFor: aSelector.
	method ifNil: [ ^ nil ].
	^ method parseTree! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
directlyDefinesInstanceVariable: aString 
	^self instanceVariableNames includes: aString! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
realClass: aClass

	realClass := aClass.
	superclass ifNil: [ superclass := LookupSuperclass ]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
hierarchyDefinesClassVariable: aString
	(self definesClassVariable: aString)
		ifTrue: [ ^ true ].
	^ self allSubclasses
		anySatisfy: [ :each | each directlyDefinesClassVariable: aString ]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
isMeta
	self subclassResponsibility! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
name
	^name! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
whichSelectorsReferToSymbol: aSymbol

	| selectors |

	selectors := Set new.
	newMethods
		ifNotNil: [ newMethods
				do: [ :each | 
					( each refersToSymbol: aSymbol )
						ifTrue: [ selectors add: each selector ]
					]
			].
	self isDefined
		ifTrue: [ selectors addAll: ( self existingMethodsThatReferTo: aSymbol ) ].
	^ selectors! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
addMethod: aRBMethod 
	self newMethods at: aRBMethod selector put: aRBMethod.
	removedMethods notNil 
		ifTrue: [removedMethods remove: aRBMethod selector ifAbsent: []]! !

!RBAbstractClass methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPutAll: self name! !

!RBAbstractClass methodsFor: 'accessing - deprecated' stamp: ''!
theMetaClass
	^ model metaclassNamed: self name! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
soleInstance
	^ self instanceSide! !

!RBAbstractClass methodsFor: 'comparing' stamp: ''!
hash
	^self name hash bitXor: self class hash! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
existingMethodsThatReferToInstanceVariable: aString
	| existingMethods |
	existingMethods := self realClass 
		whichSelectorsAccess: aString.
	(newMethods isNil and: [ removedMethods isNil ])
		ifTrue: [ ^ existingMethods ].
	^ existingMethods 
		reject: [ :each | (self hasRemoved: each) or: [ self newMethods includesKey: each ] ]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
directlyDefinesMethod: aSelector 
	self isDefined 
		ifTrue: 
			[(self hasRemoved: aSelector) ifTrue: [^false].
			(self realClass includesSelector: aSelector) ifTrue: [^true]].
	^newMethods notNil and: [newMethods includesKey: aSelector]! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
compileTree: aRBMethodNode 
	^ (self methodFor: aRBMethodNode selector) compileTree: aRBMethodNode! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
withAllSubclasses
	^ self allSubclasses
		add: self;
		yourself! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
hierarchyDefinesVariable: aString
	(self definesVariable: aString)
		ifTrue: [ ^ true ].
	^ self allSubclasses
		anySatisfy: [ :each | each directlyDefinesVariable: aString ]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
directlyDefinesVariable: aVariableName 
	^(self directlyDefinesClassVariable: aVariableName) 
		or: [self directlyDefinesInstanceVariable: aVariableName]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
parseTreeSearcherClass
	^ RBParseTreeSearcher! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
whichSelectorsReferToInstanceVariable: aString

	| selectors |
	selectors := Set new.
	newMethods
		ifNotNil: [ newMethods
				do: [ :each | 
					( each refersToVariable: aString )
						ifTrue: [ selectors add: each selector ]
					]
			].
	self isDefined
		ifTrue: [ selectors addAll: ( self existingMethodsThatReferToInstanceVariable: aString ) ].
	^ selectors! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
allSuperclasses
	| supers sprClass |
	supers := OrderedCollection new.
	sprClass := self superclass.
	[sprClass notNil] whileTrue: 
			[supers add: sprClass.
			sprClass := sprClass superclass].
	^supers! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
instanceVariableNames: aCollectionOfStrings 
	instanceVariableNames := aCollectionOfStrings asOrderedCollection! !

!RBAbstractClass methodsFor: 'private' stamp: ''!
superclass: aRBClass 
	self superclass ifNotNil: [self superclass removeSubclass: self].
	superclass := aRBClass.
	superclass ifNotNil: [superclass addSubclass: self].! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
whichSelectorsReferToClassVariable: aString

	| selectors |

	selectors := Set new.
	newMethods
		ifNotNil: [ 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: ''!
selectors
	| selectors |
	selectors := Set new.
	selectors addAll: self newMethods keys.
	self isDefined 
		ifTrue: 
			[selectors addAll: self realClass selectors.
			removedMethods ifNotNil: [removedMethods do: [:each | selectors remove: each ifAbsent: []]]].
	^selectors! !

!RBAbstractClass methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	name := #'Unknown Class'! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
hierarchyDefinesMethod: aSelector 
	(self definesMethod: aSelector) ifTrue: [^true].
	^self subclassRedefines: aSelector! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
directlyDefinesClassVariable: aString 
	self subclassResponsibility! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
subclassRedefines: aSelector
	"Return true, if one of your subclasses redefines the method with name, aMethod"

	^ self allSubclasses anySatisfy: [ :each | each directlyDefinesMethod: aSelector ]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
includesClass: aRBClass 
	| currentClass |
	currentClass := self.
	[currentClass notNil and: [currentClass ~= aRBClass]] 
		whileTrue: [currentClass := currentClass superclass].
	^currentClass = aRBClass! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
compile: aString 
	^ self compile: aString withAttributesFrom: (self methodFor: (self parserClass parseMethodPattern: aString))! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
realClass
	^realClass! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
definesVariable: aVariableName 
	^(self definesClassVariable: aVariableName) 
		or: [self definesInstanceVariable: aVariableName]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
withAllSuperclasses
	^ self allSuperclasses
		add: self;
		yourself! !

!RBAbstractClass methodsFor: 'variable accessing' stamp: ''!
whoDefinesInstanceVariable: aString
	| sprClass |
	(self directlyDefinesInstanceVariable: aString) ifTrue: [ ^ self ].
	sprClass := self superclass.
	^ sprClass ifNotNil: [ sprClass whoDefinesInstanceVariable: aString ]! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
whichSelectorsReferToClass: aRBClass

	| selectors |

	selectors := Set new.
	newMethods
		ifNotNil: [ 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: ''!
bindingOf: aString 
	^self realClass classPool associationAt: aString asSymbol
		ifAbsent: [self realClass classPool associationAt: aString asString ifAbsent: [nil]]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
subclasses

	^ subclasses
		ifNil: [ subclasses := self isDefined
				ifTrue: [ ( ( self realClass subclasses collect: [ :each | model classFor: each ] )
						reject: [ :each | each isNil ] ) asOrderedCollection
					]
				ifFalse: [ OrderedCollection new ]
			]
		ifNotNil: [ subclasses ]! !

!RBAbstractClass methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream nextPutAll: self name! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
withAllSuperclassesUntil: aClass

	^ (self allSuperclassesUntil: aClass)
		add: self;
		yourself! !

!RBAbstractClass methodsFor: 'enumerating' stamp: ''!
subclassesDo: aBlock 
	self subclasses do: aBlock! !

!RBAbstractClass methodsFor: 'variable accessing' stamp: ''!
renameInstanceVariable: oldName to: newName around: aBlock 
	self privateInstanceVariableNames 
		at: (self privateInstanceVariableNames indexOf: oldName asString)
		put: newName asString.
	^ self model 
		performChange: (changeFactory   
							renameInstanceVariable: oldName
							to: newName
							in: self)
		around: aBlock! !

!RBAbstractClass methodsFor: 'variable accessing' stamp: ''!
addInstanceVariable: aString 
	self privateInstanceVariableNames add: aString.
	model addInstanceVariable: aString to: self! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
directlyDefinesPoolDictionary: aString 
	self subclassResponsibility! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
name: aSymbol 
	name := aSymbol! !

!RBAbstractClass methodsFor: 'accessing - deprecated' stamp: ''!
theNonMetaClass
	^ model classNamed: self name! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
allInstanceVariableNames

	| sprClass |

	sprClass := self superclass.
	^ sprClass
		ifNil: [ self instanceVariableNames ]
		ifNotNil: [ sprClass allInstanceVariableNames , self instanceVariableNames ]! !

!RBAbstractClass methodsFor: 'transforming' stamp: ''!
convertMethod: selector using: searchReplacer

	"Convert the parse tree for selector using the searchReplacer. If a
	change is made then compile it into the changeBuilder."

	| parseTree |

	parseTree := self parseTreeFor: selector.
	parseTree ifNil: [ ^ self ].
	( searchReplacer executeTree: parseTree )
		ifTrue: [ self compileTree: searchReplacer tree ]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
allSuperclassesUntil: aClass

	| supers sprClass |
	supers := OrderedCollection new.
	sprClass := self superclass.
	[sprClass notNil and: [sprClass name ~= aClass name]] whileTrue: 
			[supers add: sprClass.
			sprClass := sprClass superclass].
	^supers! !

!RBAbstractClass methodsFor: 'variable accessing' stamp: ''!
removeInstanceVariable: aString 
	self privateInstanceVariableNames remove: aString.
	model removeInstanceVariable: aString from: self! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
definesClassVariable: aSymbol 
	self realClass isTrait ifTrue: [^false].
	(self directlyDefinesClassVariable: aSymbol) ifTrue: [^true].
	^self superclass notNil 
		and: [self superclass definesClassVariable: aSymbol]! !

!RBAbstractClass methodsFor: 'testing' stamp: ''!
definesInstanceVariable: aString 
	(self directlyDefinesInstanceVariable: aString) ifTrue: [^true].
	^self superclass notNil 
		and: [self superclass definesInstanceVariable: aString]! !

!RBAbstractClass methodsFor: 'method accessing' stamp: ''!
localSelectors
	| selectors |
	selectors := Set new.
	selectors addAll: self newMethods keys.
	self isDefined 
		ifTrue: 
			[selectors addAll: self realClass localSelectors.
			removedMethods ifNotNil: [removedMethods do: [:each | selectors remove: each ifAbsent: []]]].
	^selectors! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
instanceSide
	"Return the class of the couple class/metaclass. Useful to avoid explicit test."

	^ model classNamed: self name! !

!RBAbstractClass methodsFor: 'initialization' stamp: ''!
model: aRBSmalltalk
	model := aRBSmalltalk! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
protocols

	^ (self allMethods
		flatCollect: [ :each | self protocolsFor: each selector ])
		asOrderedCollection! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
removeSubclass: aRBClass 
	self subclasses remove: aRBClass ifAbsent: []! !

!RBAbstractClass methodsFor: 'querying' stamp: ''!
getterMethodFor: aVariableName
	| matcher candidateGetters |
	matcher := self parseTreeSearcherClass getterMethod: aVariableName.
	candidateGetters := (self definesInstanceVariable: aVariableName)
		ifTrue: [ self whichSelectorsReferToInstanceVariable: aVariableName ]
		ifFalse: [ self whichSelectorsReferToClassVariable: aVariableName ].
	candidateGetters := candidateGetters
		select: [ :each | each numArgs == 0 ].
	^ candidateGetters
		detect: [ :each | 
			(self checkSelector: each using: matcher) notNil
				and: [ (self subclassRedefines: each) not ] ]
		ifNone: [ nil ]! !

!RBAbstractClass methodsFor: 'accessing' stamp: ''!
instanceVariableNames
	^self privateInstanceVariableNames copy! !

!RBAbstractClass class methodsFor: 'class initialization' stamp: ''!
initialize
	LookupSuperclass := Object new! !

!RBAbstractClass class methodsFor: 'accessing' stamp: ''!
named: aString
	^ self subclassResponsibility! !

!RBAbstractClass class methodsFor: 'accessing' stamp: ''!
existingNamed: aString
	^ self subclassResponsibility! !

!RBAbstractClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testModelAbstractClassVariableOverridenMethodsInSubclass
	| refactoring meta class |
	class := model classNamed: #Foo.
	meta := class classSide.
	refactoring := self createRefactoringWithModel: model andArguments: 
		{'ClassVarName2'. #Foo}.
	
	self flag: 'There are some errors or different behavior bwt ref and transformation'.
"	self executeRefactoring: refactoring.
	self assert: (meta parseTreeFor: #classVarName21) equals: (self parseMethod: 'classVarName21 ^ClassVarName2').
	self assert: (meta parseTreeFor: #classVarName21:) equals: (self parseMethod: 'classVarName21: anObject ClassVarName2 := anObject')"! !

!RBAbstractClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	self shouldFail: (self createRefactoringWithArguments: 
		{#Foo . #RBBasicLintRuleTestData})! !

!RBAbstractClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInheritedName
	self shouldFail: (self createRefactoringWithArguments: 
		{#DependentsFields . #RBBasicLintRuleTestData})! !

!RBAbstractClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInvalidClass
	self shouldFail: (self createRefactoringWithArguments: 
		{#DependentsFields . #Object })! !

!RBAbstractClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testModelAbstractClassVariable
	| refactoring meta class |
	class := model classNamed: #Foo.
	meta := class classSide.
	refactoring := self createRefactoringWithModel: model andArguments: 
		{'ClassVarName1' . #'Foo class'}.
	
	self flag: 'There are some errors or different behavior bwt ref and transformation'.
	"self executeRefactoring: refactoring.
	self assert: (meta parseTreeFor: #classVarName1) equals: (self parseMethod: 'classVarName1 ^ClassVarName1').
	self assert: (meta parseTreeFor: #classVarName1:) equals: (self parseMethod: 'classVarName1: anObject ^ClassVarName1 := anObject').
	self assert: (meta parseTreeFor: #foo) equals: (self parseMethod: 'foo
					^self classVarName1: self classVarName1 * self classVarName1 * self classVarName1').
	self assert: (class parseTreeFor: #classVarName1) equals: (self parseMethod: 'classVarName1
							^self class classVarName1').
	self assert: (class parseTreeFor: #classVarName1:) equals: (self parseMethod: 'classVarName1: anObject
							^self class classVarName1: anObject').
	self assert: (class parseTreeFor: #asdf) equals: (self parseMethod: 'asdf
						^self classVarName1: (self class classVarName1: self class classVarName1 + 1)').
	self assert: ((model classNamed: #Bar) parseTreeFor: #foo) equals: (self parseMethod: 'foo
					instVarName1 := instVarName1 + instVarName2 + self class classVarName1').
	self assert: ((model classNamed: #Bar) parseTreeFor: #foo) equals: (self parseMethod: 'foo
						instVarName1 := instVarName1 + instVarName2 + self class classVarName1')"! !

!RBAbstractClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testAbstractClassVariable
	| refactoring |
	refactoring := self createRefactoringWithArguments:
		{'RecursiveSelfRule' . #RBTransformationRuleTestData}.
	self flag: 'There are some errors or different behavior bwt ref and transformation'.
"	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBTransformationRuleTestData.
	meta := class classSide.
	self assert: (meta parseTreeFor: #recursiveSelfRule) equals: (self parseMethod: 'recursiveSelfRule ^RecursiveSelfRule').
	self assert: (meta parseTreeFor: #recursiveSelfRule:) equals: (self parseMethod: 'recursiveSelfRule: anObject RecursiveSelfRule := anObject').
	self assert: (meta parseTreeFor: #nuke) equals: (self parseMethod: 'nuke
							self recursiveSelfRule: nil').
	self assert: (meta parseTreeFor: #initializeAfterLoad1) equals: (self parseMethod: 'initializeAfterLoad1
							self recursiveSelfRule: self parseTreeSearcher.
							self recursiveSelfRule
								addMethodSearches: #(''`@methodName: `@args | `@temps | self `@methodName: `@args'' ''`@methodName: `@args | `@temps | ^self `@methodName: `@args'')
										-> [:aNode :answer | true]').
	self assert: (class parseTreeFor: #checkMethod:) equals: (self 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]]')"! !

!RBAbstractClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMetaClassFailure
	self shouldFail: (self createRefactoringWithArguments: 
	{ #RecursiveSelfRule . #'RBTransformationRuleTestData class'})! !

!RBAbstractClassVariableParametrizedTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self abstractVariableTestData.! !

!RBAbstractClassVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBAbstractClassVariableRefactoring .
					  #constructor -> #variable:class: };
		addCase: { #rbClass -> RBRemoveDirectAccessToVariableTransformation .
					  #constructor -> #classVariable:class: };
		yourself! !

!RBAbstractClassVariableRefactoring commentStamp: ''!
I am a refactoring for replacing every direct access to  class variables with accessor methods.

My precondition verifies that the variable is directly defined in that class.
I create new accessor methods for the variables and replace every read and write to this variable with the new accessors.
!
!RBAbstractClassVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self createAccessors.
	self abstractInstanceReferences.
	self abstractClassReferences! !

!RBAbstractClassVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition isMetaclass: class) not 
		& (RBCondition directlyDefinesClassVariable: variableName asSymbol in: class) 
			& ((RBCondition withBlock: 
						[(#(#Object #Behavior #ClassDescription #Class) includes: class name) not]) 
					errorMacro: 'This refactoring does not work for Object, Behavior, ClassDescription, or Class')! !

!RBAbstractClassVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
accessorsRefactoring

	^ accessorsRefactoring
		ifNil: [ accessorsRefactoring := RBCreateAccessorsForVariableRefactoring
				model: self model
				variable: variableName asString
				class: class
				classVariable: true
			]
		ifNotNil: [ accessorsRefactoring ]! !

!RBAbstractClassVariableRefactoring methodsFor: 'transforming' stamp: ''!
abstractClassReferences
	| replacer |
	replacer := self parseTreeRewriterClass  
		variable: variableName
		getter: self accessorsRefactoring getterMethod
		setter: self accessorsRefactoring setterMethod.
	self 
		convertClasses: class classSide withAllSubclasses
		select: 
			[ :aClass | 
			(aClass whichSelectorsReferToClassVariable: variableName) reject: 
				[ :each | 
				aClass == class classSide and: 
					[ each == self accessorsRefactoring getterMethod or: [ each == self accessorsRefactoring setterMethod ] ] ] ]
		using: replacer! !

!RBAbstractClassVariableRefactoring methodsFor: 'transforming' stamp: ''!
createAccessors
	self performCompositeRefactoring: self accessorsRefactoring! !

!RBAbstractClassVariableRefactoring methodsFor: 'transforming' stamp: ''!
abstractInstanceReferences
	| replacer |
	replacer := self parseTreeRewriterClass 
		variable: variableName
		getter: 'class ' , self accessorsRefactoring getterMethod
		setter: 'class ' , self accessorsRefactoring setterMethod.
	self 
		convertClasses: class withAllSubclasses
		select: [ :aClass | aClass whichSelectorsReferToClassVariable: variableName ]
		using: replacer! !

!RBAbstractCondition commentStamp: ''!
I am the abstract base class of refactoring conditions.
Conditions are used by refactoring operation for checking preconditions before applying the 
refactoring.

I implement some common behavior for error handling - errorMacro.
And to combine conditions with boolean operatiosn (and/or/not).

Most of the condition checking behavior is implemented on my subclass 
RBCondition. 

Instances of RBConditions are created by factory methods on its class side.!
!RBAbstractCondition methodsFor: 'accessing' stamp: ''!
errorBlock
	^self errorBlockFor: false! !

!RBAbstractCondition methodsFor: 'private' stamp: ''!
errorBlockFor: aBoolean 
	^nil! !

!RBAbstractCondition methodsFor: 'logical operations' stamp: ''!
& aCondition 
	^RBConjunctiveCondition new left: self right: aCondition! !

!RBAbstractCondition methodsFor: 'private' stamp: ''!
errorStringFor: aBoolean
	^self errorMacro expandMacrosWith: aBoolean! !

!RBAbstractCondition methodsFor: 'checking' stamp: ''!
check
	self subclassResponsibility! !

!RBAbstractCondition methodsFor: 'logical operations' stamp: ''!
| aCondition 
	"(A | B) = (A not & B not) not"

	^(self not & aCondition not) not! !

!RBAbstractCondition methodsFor: 'private' stamp: ''!
errorMacro: aString 
	errorMacro := aString! !

!RBAbstractCondition methodsFor: 'logical operations' stamp: ''!
not
	^RBNegationCondition on: self! !

!RBAbstractCondition methodsFor: 'private' stamp: ''!
errorMacro

	^ errorMacro ifNil: [ 'unknown' ] ifNotNil: [ errorMacro ]! !

!RBAbstractCondition methodsFor: 'accessing' stamp: ''!
errorString
	^self errorStringFor: false! !

!RBAbstractEnvTestCase methodsFor: 'accessing' stamp: ''!
environmentOfTest
	^ testingEnvironment! !

!RBAbstractEnvTestCase methodsFor: 'accessing' stamp: ''!
testingEnvironment: anObject
	testingEnvironment := anObject! !

!RBAbstractEnvTestCase methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	testingEnvironment := Smalltalk globals.! !

!RBAbstractInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testAbstractInstanceVariable
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ 'name' . #RBLintRuleTestData}.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBLintRuleTestData.
	self assert: (class parseTreeFor: #name) equals: (self parseMethod: 'name ^name').
	self assert: (class parseTreeFor: #name:) equals: (self parseMethod: 'name: aString
	name := aString').
	self assert: (class parseTreeFor: #initialize) equals: (self parseMethod: 'initialize
	self name: ''''').
	self assert: (class parseTreeFor: #printOn:) equals: (self parseMethod: 'printOn: aStream
	self name ifNil: [ super printOn: aStream ] ifNotNil: [ aStream nextPutAll: self name ]')! !

!RBAbstractInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testAbstractWithAssignmentUsed
	| refactoring class |
	class := model classNamed: #Foo.
	refactoring := self createRefactoringWithModel:  model
				andArguments: { 'instVarName2' . #Foo}.
	self flag: 'Transformation has another result, reusing existing accessors'.
	self executeRefactoring: refactoring.
"	self assert: (class parseTreeFor: #foo) 
		equals: (self parseMethod: 'foo
						^self instVarName21: 3').
	self 
		assert: (class parseTreeFor: #instVarName2:) equals: (self 
						parseMethod: 'instVarName2: anObject
						self instVarName21: anObject').
	self 
		assert: (class parseTreeFor: #instVarName21:) equals: (self 
						parseMethod: 'instVarName21: anObject
						^instVarName2 := anObject').
	self assert: (class parseTreeFor: #instVarName2) 
				equals: (self parseMethod: 'instVarName2
						^instVarName2').
	self 
		assert: ((model classNamed: #Bar) parseTreeFor: #foo) equals: (self 
						parseMethod: 'foo
						instVarName1 := instVarName1 + self instVarName2 + ClassVarName1')"! !

!RBAbstractInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInheritedName
	self shouldFail: (self createRefactoringWithArguments: 
		{'name' . #RBBasicLintRuleTestData})! !

!RBAbstractInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	self shouldFail: (self createRefactoringWithArguments: 
		{'foo' . #RBBasicLintRuleTestData})! !

!RBAbstractInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testMetaclassInstanceVariables
	| refactoring class |
	class := model metaclassNamed: #Foo.
	class addInstanceVariable: 'foo'.
	class compile: 'zzz ^foo := foo + foo * 2' classified: #(#testing).
	refactoring := self createRefactoringWithModel: model andArguments: 
				{ 'foo' . #'Foo class'}.
	self flag: 'There is a transformation error'.
"	self executeRefactoring: refactoring.
	self assert: (class parseTreeFor: #foo1) 
		  equals: (self parseMethod: 'foo1
						^foo').
	self assert: (class parseTreeFor: #foo:) 
		  equals: (self parseMethod: 'foo: anObject
						^foo := anObject').
	self assert: (class parseTreeFor: #zzz) 
		  equals: (self parseMethod: 'zzz ^self foo: self foo1 + self foo1 * 2')"! !

!RBAbstractInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testAbstractWithDefaultNamesUsed
	| refactoring class |
	class := model classNamed: #Foo.
	refactoring := self createRefactoringWithModel: model andArguments: 
				{'instVarName1' . #Foo}.
	self flag: 'There is an error using RBClass2 with pools'.
	"self executeRefactoring: refactoring.
	self 
		assert: (class parseTreeFor: #bar) equals: (self 
						parseMethod: 'bar
						""Add one to instVarName1""

						self instVarName11: self instVarName11 + 1').
	self 
		assert: (class parseTreeFor: #instVarName11:) equals: (self 
						parseMethod: 'instVarName11: anObject
						instVarName1 := anObject').
	self assert: (class parseTreeFor: #instVarName11) 
			equals: (self parseMethod: 'instVarName11
						^instVarName1').
	self 
		assert: ((model classNamed: #Bar) parseTreeFor: #foo) equals: (self 
						parseMethod: 'foo
						self instVarName11: self instVarName11 + instVarName2 + ClassVarName1')"! !

!RBAbstractInstanceVariableParametrizedTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self abstractVariableTestData.! !

!RBAbstractInstanceVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBAbstractInstanceVariableRefactoring .
					  #constructor -> #variable:class: };
		addCase: { #rbClass -> RBRemoveDirectAccessToVariableTransformation .
					  #constructor -> #instanceVariable:class: };
		yourself! !

!RBAbstractInstanceVariableRefactoring commentStamp: ''!
I am a refactoring for replacing every direct access to  instance  variables with accessor methods.

My precondition verifies that the variable is directly defined in that class.
I create new accessor methods for the variables and replace every read and write to this variable with the new accessors.
!
!RBAbstractInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self createAccessors.
	self abstractReferences! !

!RBAbstractInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^RBCondition directlyDefinesInstanceVariable: variableName in: class! !

!RBAbstractInstanceVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
accessorsRefactoring

	^ accessorsRefactoring
		ifNil: [ accessorsRefactoring := RBCreateAccessorsForVariableRefactoring
				model: self model
				variable: variableName
				class: class
				classVariable: false
			]
		ifNotNil: [ accessorsRefactoring ]! !

!RBAbstractInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
abstractReferences
	| replacer |
	replacer := self parseTreeRewriterClass 
				variable: variableName
				getter: self accessorsRefactoring getterMethod
				setter: self accessorsRefactoring setterMethod.
	self 
		convertClasses: class withAllSubclasses
		select: 
			[:aClass | 
			(aClass whichSelectorsReferToInstanceVariable: variableName) reject: 
					[:each | 
					aClass == class and: 
							[each == self accessorsRefactoring getterMethod 
								or: [each == self accessorsRefactoring setterMethod]]]]
		using: replacer! !

!RBAbstractInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
createAccessors
	self performCompositeRefactoring: self accessorsRefactoring! !

!RBAbstractRefactoringTest methodsFor: 'mocking' stamp: ''!
extractMethodTestData
	| newModel classEnvironment classes |
	classes := #(#MyClassA #MyClassB #MyClassC ) 
		inject: OrderedCollection new 
		into: [ :sum :each | 
			self environmentOfTest at: each ifPresent: [ :class | 
				sum add: class; add: class class ].
			sum ].
	classEnvironment := RBClassEnvironment classes: classes.
	newModel := self defaultNamespace onEnvironment: classEnvironment not.
	newModel name: 'Test'.
	
	#('Object subclass: #MyClassA
		instanceVariableNames: ''instVarName1 instVarName2''
		classVariableNames: ''ClassVarName1 ClassVarName2 ''
		poolDictionaries: ''''
		category: ''Testing'' '
	'MyClassA subclass: #MyClassB
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Testing'' '
	'MyClassB subclass: #MyClassC
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Testing'' '
	) do: [ :each | 
		newModel defineClass: each ].
	
	#(#(#MyClassA #(
		#('bar
			^ self' #tests)
		#('name
			^ ''SomeString''' #tests)
		#('methodWithArg: anArg
			^ anArg not' #tests) 
		#('methodWithArg: anArg1 andArg: anArg2
			^ (anArg1 > anArg2) not' #tests) 
		#('problemCount
			^ 435' #tests)
		#('string: aString stream: aStream
			nil')
		#('myMethod
			| token |
			token := (String new: 100) writeStream.
			[ currentChar isLetter ] whileTrue: [ 
				token nextPut: currentChar.
				self methodWithArg: currentChar isLetter.
				self bar ].
			currentChar isLetter.
			$3 isLetter.
	 		currentChar isLetter.
			token :=  currentChar isLetter.
			token := ( currentChar isLetter) example.
			^ token contents' #tests)
		#('displayName
			| nameStream string|
			string := self name.
			nameStream := WriteStream on: (String new: 64).
		nameStream nextPutAll: string;
			nextPutAll: '' (''.
		self problemCount printOn: nameStream.
		nameStream nextPut: $).
		^nameStream contents' #tests)))
	#(#MyClassB #(
		#('someMethod
			^ instVarName2 := 3' #tests)
		#('exampleMethod
			^ (currentChar isLetter) not' #tests) 
		#('dummyMethod
			(3 > self someMethod) not' #tests)
		#('anotherMethod
			|aStream|
			aStream := WriteStream on: (String new: 128).
			aStream nextPutAll: ''dfgdf'';
				nextPutAll: '' (''.
			self problemCount printOn: aStream.
			aStream nextPut: $).' #tests)))
	#(#MyClassC #(
		#('methodWithArg: anArg
			(currentChar isLetter and: [anArg isDecimal])
			ifTrue: [^ self].
			^ nil' #tests)
		#('visitMonospace: aFormat
			aFormat children do: [ :each | each accept: self ].
			self fixBlockWithoutMicText: aFormat' #tests)
		#('visitStrike: aFormat
			aFormat children do: [ :each | each accept: self ].
			self fixBlockWithoutMicText: aFormat.
			#( 4 5 2 ) do: [ :val | val children do: [ :each | each accept: self ] ]' #tests)
		#('visitParagraph: aParagraph
			^ aParagraph children do: [:each | each accept: self ]' #tests)
		)))
		do: [:each | 
			| class |
			class := newModel classNamed: each first.
			each last do: [ :methodPair | 
				class 
					compile: methodPair first
					classified: methodPair last]].
	^ newModel! !

!RBAbstractRefactoringTest methodsFor: 'mocking' stamp: ''!
abstractVariableTestData

	| newModel classEnvironment classes |
	classes := #(#Bar #Foo) 
		inject: OrderedCollection new 
		into: [ :sum :each | 
			self environmentOfTest at: each ifPresent: [ :class | 
				sum add: class; add: class class ].
			sum ].
	classEnvironment := RBClassEnvironment classes: classes.
	newModel := self defaultNamespace onEnvironment: classEnvironment not.
	newModel name: 'Test'.
	
	#('Object subclass: #Foo
		instanceVariableNames: ''instVarName1 instVarName2''
		classVariableNames: ''ClassVarName1 ClassVarName2 ''
		poolDictionaries: ''''
		category: ''Testing'' '
	'Foo subclass: #Bar
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Testing'' '
	) do: [ :each | newModel defineClass: each ].
	
	#(#(#Bar #(
		#('instVarName1
			^1242321' #tests) 
		#('foo
			instVarName1 := instVarName1 + instVarName2 + ClassVarName1' #tests))) 
	#(#Foo #(
		#('foo
			^instVarName2 := 3' #tests)
		#('bar
			"Add one to instVarName1"
			instVarName1 := instVarName1 + 1' #tests) 
		#('classVarName1
			^ClassVarName1' #tests)
		#('instVarName1: anObject
			^anObject' #tests)
		#('asdf
			^self classVarName1: (ClassVarName1 := ClassVarName1 + 1)' #tests) 
		#('instVarName2
			^instVarName2' #tests)
		#('instVarName2: anObject
			instVarName2 := anObject' #tests)
		#('classVarName1: anObject
			^ClassVarName1 := anObject' #tests)))
	
	#('Bar class' #(
		#('classVarName2: anObject
			ClassVarName2 := anObject' #tests) 
		#('classVarName2
			^ClassVarName2' #tests))) 
	#('Foo class' #(
		#('foo
			^ClassVarName1 := ClassVarName1 * ClassVarName1 * ClassVarName1' #tests)))) 
		do: [:each | 
			| class |
			class := newModel classNamed: each first.
			each last do: [ :methodPair | 
				class 
					compile: methodPair first
					classified: methodPair last]].
	^ newModel! !

!RBAbstractRefactoringTest methodsFor: 'set up' stamp: ''!
setupExtractionClassFor: aRefactoring toReturn: aClass 
	| options |
	options := aRefactoring options copy.
	options at: #extractionClass
		put: [:ref | aClass].
	aRefactoring options: options! !

!RBAbstractRefactoringTest methodsFor: 'helpers' stamp: ''!
createRefactoringWithModel: aRBNamespace andArguments: aParameterCollection
	^ (rbClass perform: #model: , self constructor
			withArguments: {aRBNamespace} , aParameterCollection) asRefactoring! !

!RBAbstractRefactoringTest methodsFor: 'tests' stamp: ''!
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 equals: 'false'.
	self assert: condition not check.
	self assert: condition printString equals: 'false'.
	self assert: condition not printString equals: 'NOT false'.
	self deny: (condition not & condition) check.
	self 
		assert: (condition not & condition) printString equals: '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 equals: 'false AND false'.
	self assert: (condition not | condition not) check.
	self deny: (newCondition := condition & condition) check.
	self assert: newCondition errorString equals: 'false'.
	self assert: (condition not & condition not) check.
	self assert: (condition & condition) errorString equals: 'false OR false'! !

!RBAbstractRefactoringTest methodsFor: 'accessing' stamp: ''!
defaultNamespace
	^RBNamespace! !

!RBAbstractRefactoringTest methodsFor: 'set up' stamp: ''!
setupSelfArgumentNameFor: aRefactoring toReturn: aString 
	| options |
	options := aRefactoring options copy.
	options at: #selfArgumentName put: [:ref | aString].
	aRefactoring options: options! !

!RBAbstractRefactoringTest methodsFor: 'set up' stamp: ''!
setupVariableToMoveToFor: aRefactoring toReturn: aString 
	| options |
	options := aRefactoring options copy.
	options at: #selectVariableToMoveTo put: [:ref :class :selector | aString].
	aRefactoring options: options! !

!RBAbstractRefactoringTest methodsFor: 'set up' stamp: ''!
setupInlineExpressionFor: aRefactoring toReturn: aBoolean 
	| options |
	options := aRefactoring options copy.
	options at: #inlineExpression put: [:ref :string | aBoolean].
	aRefactoring options: options! !

!RBAbstractRefactoringTest methodsFor: 'set up' stamp: ''!
setupShouldUseExistingMethodFor: aRefactoring toReturn: aBoolean 
	| options |
	options := aRefactoring options copy.
	options at: #useExistingMethod put: [ :ref :cls | aBoolean ].
	aRefactoring options: options! !

!RBAbstractRefactoringTest methodsFor: 'accessing' stamp: ''!
rbClass: anObject

	rbClass := anObject! !

!RBAbstractRefactoringTest methodsFor: 'accessing' stamp: ''!
constructor
	! !

!RBAbstractRefactoringTest methodsFor: 'actions' stamp: ''!
proceedThroughWarning: aBlock 
	aBlock on: RBRefactoringWarning do: [ :ex | ex resume ]! !

!RBAbstractRefactoringTest methodsFor: 'parsing' stamp: ''!
parserClass
	^ RBParser! !

!RBAbstractRefactoringTest methodsFor: 'mocking' stamp: ''!
childrenToSiblingTestData
	^ Smalltalk compiler evaluate: '
	| 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
'! !

!RBAbstractRefactoringTest methodsFor: 'set up' stamp: ''!
setupVariableTypesFor: aRefactoring toReturn: anObject 
	| options |
	options := aRefactoring options copy.
	options at: #variableTypes put: [:ref :ignore1 :ignore2 | anObject].
	aRefactoring options: options! !

!RBAbstractRefactoringTest methodsFor: 'set up' stamp: ''!
setupMethodNameFor: aRefactoring toReturn: aSelector withArguments: stringCollection 
	| options |
	options := aRefactoring options copy.
	options at: #methodName
		put: 
			[ :aMethodName :ref | 
			aMethodName
				selector: aSelector;
				arguments: stringCollection;
				yourself].
	aRefactoring options: options! !

!RBAbstractRefactoringTest methodsFor: 'parsing' stamp: ''!
parseMethod: aString
	^ self parserClass parseMethod: aString! !

!RBAbstractRefactoringTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self defaultNamespace new! !

!RBAbstractRefactoringTest methodsFor: 'set up' stamp: ''!
setupMethodNameFor: aRefactoring toReturn: aSelector 
	| options |
	options := aRefactoring options copy.
	options at: #methodName
		put: 
			[:aMethodName :ref | 
			aMethodName
				selector: aSelector;
				yourself].
	aRefactoring options: options! !

!RBAbstractRefactoringTest methodsFor: 'actions' stamp: ''!
shouldFail: aRefactoring 

	self proceedThroughWarning: [
		self should: [ aRefactoring primitiveExecute ] 
		raise: RBRefactoringError ]! !

!RBAbstractRefactoringTest methodsFor: 'actions' stamp: ''!
shouldWarn: aRefactoringColl 
	self 
		should: [ self executeRefactoring: aRefactoringColl ]
		raise: RBRefactoringWarning! !

!RBAbstractRefactoringTest methodsFor: 'actions' stamp: ''!
shouldntWarn: aRefactoring 
	self 
		shouldnt: [ self executeRefactoring: aRefactoring ]
		raise: RBRefactoringWarning! !

!RBAbstractRefactoringTest methodsFor: 'mocking' stamp: ''!
inlineMethodTestData
	^ Smalltalk compiler evaluate: '
		| 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
'! !

!RBAbstractRefactoringTest methodsFor: 'set up' stamp: ''!
setupSearchInAllHierarchyFor: aRefactoring toReturn: aBoolean 
	| options |
	options := aRefactoring options copy.
	options at: #searchInWholeHierarchy put: [ :ref :cls | aBoolean ].
	aRefactoring options: options! !

!RBAbstractRefactoringTest methodsFor: 'set up' stamp: ''!
setupImplementorToInlineFor: aRefactoring toReturn: anObject 
	| options |
	options := aRefactoring options copy.
	options at: #implementorToInline put: [:ref :imps | anObject].
	aRefactoring options: options! !

!RBAbstractRefactoringTest methodsFor: 'helpers' stamp: ''!
objectClassVariable
	^Object classPool keys detect: [:each | true]! !

!RBAbstractRefactoringTest methodsFor: 'helpers' stamp: ''!
createRefactoringWithArguments: aParameterCollection
	^ (rbClass perform: self constructor
			withArguments: aParameterCollection) asRefactoring! !

!RBAbstractRefactoringTest methodsFor: 'parsing' stamp: ''!
executeRefactoring: aRefactoring
	aRefactoring primitiveExecute.! !

!RBAbstractRefactoringTest methodsFor: 'parsing' stamp: ''!
parseExpression: aString
	^ self parserClass parseExpression: aString! !

!RBAbstractRefactoringTest methodsFor: 'parsing' stamp: ''!
executeRefactorings: aRefactoringColl
	aRefactoringColl do: [ :ref | ref primitiveExecute]! !

!RBAbstractRefactoringTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RBAbstractRefactoringTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RBAbstractRefactoringTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RBAbstractRefactoringTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RBAbstractRefactoringTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RBAbstractRefactoringTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RBAbstractRefactoringTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RBAbstractRefactoringTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RBAbstractRefactoringTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBAbstractRefactoringTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RBAbstractRefactoringTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RBAbstractRefactoringTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RBAbstractRefactoringTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RBAbstractRefactoringTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RBAbstractRefactoringTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RBAbstractRefactoringTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RBAbstractRefactoringTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RBAbstractRefactoringTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBAbstractRefactoringTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RBAbstractRefactoringTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RBAbstractRefactoringTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RBAbstractRefactoringTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RBAbstractRefactoringTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RBAbstractRefactoringTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RBAbstractRefactoringTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RBAbstractRefactoringTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RBAbstractRefactoringTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RBAbstractRefactoringTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RBAbstractRefactoringTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RBAbstractSelectionPresenter methodsFor: 'initialization' stamp: ''!
initializeDropList
	dropList := self newDropList.
	dropList
		display: [ :scope | scope name ];
		iconBlock: [ :e | e systemIcon ]! !

!RBAbstractSelectionPresenter methodsFor: 'accessing' stamp: ''!
selectedItem
	^ dropList selectedItem! !

!RBAbstractSelectionPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	super initializeWidgets .
	dropLabel := self newLabel.
	self initializeDropList.! !

!RBAbstractSelectionPresenter methodsFor: 'initialization' stamp: ''!
label: aString dropLabel: dropString withItems: items selecting: selItems dropItems: dropItems acceptBlock: aBlock
	self label: aString withItems: items selecting: selItems.
	dropLabel label: dropString.
	dropList items: dropItems.
	acceptBlock := aBlock.
	! !

!RBAbstractSelectionPresenter methodsFor: 'actions' stamp: ''!
accept
	acceptBlock value: self selectedItem value: table selectedItems! !

!RBAbstractSelectionPresenter methodsFor: 'accessing' stamp: ''!
components 
	^ super components , { dropList . dropLabel }! !

!RBAbstractSelectionPresenter class methodsFor: 'specs' stamp: ''!
label: aString dropLabel: aString2 withItems: items selecting: selectedItems dropItems: dropItems acceptBlock: aBlock
	^ self new 
		label: aString
		dropLabel: aString2
		withItems: items
		selecting: selectedItems
		dropItems: dropItems
		acceptBlock: aBlock;
		openBlockedDialogWithSpec! !

!RBAbstractSelectionPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #dropLabel withConstraints: [ :c | c height: self labelHeight ];
		add:
			(SpBoxLayout newLeftToRight
				add: #dropList ;
				yourself) withConstraints: [ :c | c height: self toolbarHeight  ];
		add: #label withConstraints: [ :c | c height: self buttonHeight ];
		add:
			(SpBoxLayout newLeftToRight
				add: #table;
				yourself);
		yourself! !

!RBAbstractVariablesRefactoring commentStamp: ''!
I am a refactoring used by other refactoring operations for extracting direct inst var and pool var 
access to accessor methods.

For example RBMoveMethodRefactoring uses me.!
!RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''!
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: ''!
classVariableNames
	| nonMetaClass |
	nonMetaClass := fromClass instanceSide.
	^ (nonMetaClass allClassVariableNames collect: [ :each | each asString ]) asSet! !

!RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self hasVariablesToAbstract 
		ifTrue: 
			[self 
				refactoringWarning: 'This method has direct variable references which<n>will need to be converted to getter/setters.<n>Proceed anyway?' 
						expandMacros].
	self abstractInstanceVariables.
	self abstractClassVariables! !

!RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''!
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: ''!
abstractInstanceVariable: aString 
	| refactoring rewriter |
	refactoring := RBCreateAccessorsForVariableRefactoring 
				model: self model
				variable: aString
				class: fromClass
				classVariable: false.
	self performCompositeRefactoring: refactoring.
	rewriter := self parseTreeRewriter.
	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: 'preconditions' stamp: ''!
preconditions

	^ self emptyCondition! !

!RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''!
computeVariablesToAbstract
	| searcher |
	instVarReaders := Set new.
	instVarWriters := Set new.
	classVarReaders := Set new.
	classVarWriters := Set new.
	searcher := self parseTreeSearcher.
	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: 'testing' stamp: ''!
hasVariablesToAbstract
	^ instVarReaders notEmpty or: [ instVarWriters notEmpty or: [ classVarReaders notEmpty or: [ classVarWriters notEmpty ] ] ]! !

!RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''!
processReferenceNode: aNode 
	| varName |
	varName := aNode name.
	ignore = varName ifTrue: [^self].
	(aNode whoDefines: varName) ifNotNil: [^self].
	(self instanceVariableNames includes: varName) 
		ifTrue: [instVarReaders add: varName].
	(self classVariableNames includes: varName) 
		ifTrue: [classVarReaders add: varName]! !

!RBAbstractVariablesRefactoring methodsFor: 'initialization' stamp: ''!
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 performCompositeRefactoring: poolRefactoring.
	self computeVariablesToAbstract! !

!RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''!
abstractClassVariable: aString 
	| refactoring rewriter nonMetaClass |
	nonMetaClass := fromClass instanceSide.
	refactoring := RBCreateAccessorsForVariableRefactoring 
		model: self model
		variable: aString
		class: nonMetaClass
		classVariable: true.
	self performCompositeRefactoring: refactoring.
	rewriter := self parseTreeRewriter.
	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: ''!
processAssignmentNode: aNode 
	| varName |
	varName := aNode variable name.
	ignore = varName ifTrue: [^self].
	(aNode whoDefines: varName) ifNotNil: [^self].
	(self instanceVariableNames includes: varName) 
		ifTrue: [instVarWriters add: varName].
	(self classVariableNames includes: varName) 
		ifTrue: [classVarWriters add: varName]! !

!RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''!
removeDefinedClassVariables
	| selectionBlock nonMetaClass |
	nonMetaClass := fromClass instanceSide.
	selectionBlock := 
	[ :varName | 
	(toClasses 
		detect: 
			[ :each | 
			(each instanceSide includesClass: (nonMetaClass whoDefinesClassVariable: varName)) not ]
		ifNone: [ nil ]) notNil ].
	classVarReaders := classVarReaders select: selectionBlock.
	classVarWriters := classVarWriters select: selectionBlock! !

!RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''!
instanceVariableNames
	^fromClass allInstanceVariableNames asSet! !

!RBAbstractVariablesRefactoring methodsFor: 'accessing' stamp: ''!
parseTree
	^tree! !

!RBAbstractVariablesRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ignoring: aVariableName 
	^ self new
		model: aRBSmalltalk;
		abstractVariablesIn: aBRProgramNode
			from: fromBehavior
			toAll: behaviorCollection
			ignoring: aVariableName;
		yourself! !

!RBAbstractVariablesRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBModel abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection 
	^self 
		model: aRBModel
		abstractVariablesIn: aBRProgramNode
		from: fromBehavior
		toAll: behaviorCollection
		ignoring: nil! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
abstractInstanceVariables
	| variables |
	(instVarReaders isEmpty and: [ instVarWriters isEmpty ])
		ifTrue: [ ^ self].
	variables := Set new.
	variables
		addAll: instVarReaders;
		addAll: instVarWriters.
	variables do: [ :each | self abstractInstanceVariable: each ]! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
classVariableNames
	| nonMetaClass |
	nonMetaClass := fromClass instanceSide.
	^ (nonMetaClass allClassVariableNames collect: [ :each | each asString ]) asSet! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
abstractClassVariables
	| variables |
	(classVarReaders isEmpty and: [ classVarWriters isEmpty ])
		ifTrue: [ ^ self ].
	variables := Set new.
	variables
		addAll: classVarReaders;
		addAll: classVarWriters.
	variables do: [ :each | self abstractClassVariable: each ]! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
abstractInstanceVariable: aString 
	| transformation rewriter |
	transformation := (RBAddVariableAccessorTransformation 
		model: self model
		variable: aString
		class: fromClass
		classVariable: false)
		transform.
	rewriter := self parseTreeRewriter.
	rewriter
		replace: aString , ' := ``@object'
			with: ('self <1s> ``@object' expandMacrosWith: transformation setterMethod);
		replace: aString with: 'self ' , transformation getterMethod.
	(rewriter executeTree: tree) ifTrue: [tree := rewriter tree]! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
preconditions

	^ self emptyCondition! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
computeVariablesToAbstract
	| searcher |
	instVarReaders := Set new.
	instVarWriters := Set new.
	classVarReaders := Set new.
	classVarWriters := Set new.
	searcher := self parseTreeSearcher.
	searcher
		matches: '`var := ``@anything'
			do: [ :aNode :answer | self processAssignmentNode: aNode ];
		matches: '`var'
			do: [ :aNode :answer | self processReferenceNode: aNode ].
	searcher executeTree: tree.
	self removeDefinedClassVariables! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
hasVariablesToAbstract
	^ instVarReaders notEmpty or: [ instVarWriters notEmpty or: [ classVarReaders notEmpty or: [ classVarWriters notEmpty ] ] ]! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
processReferenceNode: aNode 
	| varName |
	varName := aNode name.
	ignore = varName ifTrue: [^self].
	(aNode whoDefines: varName) ifNotNil: [^self].
	(self instanceVariableNames includes: varName) 
		ifTrue: [instVarReaders add: varName].
	(self classVariableNames includes: varName) 
		ifTrue: [classVarReaders add: varName]! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ignoring: aVariableName 
	| poolTransformation |
	tree := aBRProgramNode.
	fromClass := self model classObjectFor: fromBehavior.
	toClasses := behaviorCollection 
				collect: [:each | self model classObjectFor: each].
	ignore := aVariableName.
	poolTransformation := (RBExpandReferencedPoolsTransformation
				model: self model
				forMethod: tree
				fromClass: fromClass
				toClasses: toClasses)
				transform.
	self computeVariablesToAbstract! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
abstractClassVariable: aString 
	| transformation rewriter nonMetaClass |
	nonMetaClass := fromClass instanceSide.
	transformation := (RBAddVariableAccessorTransformation 
		model: self model
		variable: aString
		class: nonMetaClass
		classVariable: true)
		transform.
	rewriter := self parseTreeRewriter.
	fromClass isMeta 
		ifTrue: 
			[ rewriter
				replace: aString , ' := ``@object'
					with: ('self <1s> ``@object' expandMacrosWith: transformation setterMethod);
				replace: aString
					with: 'self ' , transformation getterMethod ]
		ifFalse: 
			[ rewriter
				replace: aString , ' := ``@object'
					with: ('self class <1s> ``@object' expandMacrosWith: transformation setterMethod);
				replace: aString
					with: 'self class ' , transformation getterMethod ].
	(rewriter executeTree: tree) ifTrue: [ tree := rewriter tree ]! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
processAssignmentNode: aNode 
	| varName |
	varName := aNode variable name.
	ignore = varName ifTrue: [^self].
	(aNode whoDefines: varName) ifNotNil: [^self].
	(self instanceVariableNames includes: varName) 
		ifTrue: [instVarWriters add: varName].
	(self classVariableNames includes: varName) 
		ifTrue: [classVarWriters add: varName]! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
removeDefinedClassVariables
	| selectionBlock nonMetaClass |
	nonMetaClass := fromClass instanceSide.
	selectionBlock := 
	[ :varName | 
	(toClasses 
		detect: 
			[ :each | 
			(each instanceSide includesClass: (nonMetaClass whoDefinesClassVariable: varName)) not ]
		ifNone: [ nil ]) notNil ].
	classVarReaders := classVarReaders select: selectionBlock.
	classVarWriters := classVarWriters select: selectionBlock! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
instanceVariableNames
	^fromClass allInstanceVariableNames asSet! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
parseTree
	^tree! !

!RBAbstractVariablesTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	self hasVariablesToAbstract 
		ifTrue: 
			[self 
				refactoringWarning: 'This method has direct variable references which<n>will need to be converted to getter/setters.<n>Proceed anyway?' 
						expandMacros].
	self abstractInstanceVariables.
	self abstractClassVariables! !

!RBAbstractVariablesTransformation class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ignoring: aVariableName 
	^ self new
		model: aRBSmalltalk;
		abstractVariablesIn: aBRProgramNode
			from: fromBehavior
			toAll: behaviorCollection
			ignoring: aVariableName;
		yourself! !

!RBAbstractVariablesTransformation class methodsFor: 'instance creation' stamp: ''!
model: aRBModel abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection 
	^self 
		model: aRBModel
		abstractVariablesIn: aBRProgramNode
		from: fromBehavior
		toAll: behaviorCollection
		ignoring: nil! !

!RBAccessorClassRefactoring commentStamp: ''!
I am a refactoring operation for creating accessors for all variables.

Example:
Create accessors for all instance variables:

```
RBAccessorClassRefactoring 
	model: RBNamespace new className: 'Morph' .
```
Create accessors for all class instance variables:

```
RBAccessorClassRefactoring 
	model: RBNamespace new className: 'Morph class' .
```
If the class already contains that accessor, I will create another one with a numbered suffix.
!
!RBAccessorClassRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self refactorings do: [ :each | self performCompositeRefactoring: each ]! !

!RBAccessorClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ self refactorings
		  inject: self emptyCondition
		  into: [ :result :each | result & each preconditions ]! !

!RBAccessorClassRefactoring methodsFor: 'accessing' stamp: ''!
refactorings
	| class |
	class := self classObjectFor: className asSymbol.
	^  class instanceVariableNames collect: [ :each | 
		RBCreateAccessorsForVariableRefactoring
			variable: each class: class classVariable: false ]! !

!RBAddAccessorsForClassTransformation commentStamp: ''!
Adds accessors (getters and setters) for all the variables in a class, if each of them do not exist.

Usage:
transformation := (RBAddAccessorsForClassTransformation
	className: #RBVariableTransformation)
	transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
overridden from RBAddVariableAccessorRefactoring!
!RBAddAccessorsForClassTransformation methodsFor: 'api' stamp: ''!
className: aClassName

	className := aClassName! !

!RBAddAccessorsForClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' className: '.
	className storeOn: aStream.
	aStream nextPut: $)! !

!RBAddAccessorsForClassTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	| class |
	class := self model classObjectFor: className.
	^ (class instanceVariableNames collect: [ :variable |
			RBAddVariableAccessorTransformation
				model: self model
				instanceVariable: variable
				class: class ])! !

!RBAddAccessorsForClassTransformation class methodsFor: 'api' stamp: ''!
className: aClassName

	^ self new
		className: aClassName;
		yourself! !

!RBAddAccessorsForClassTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel className: aClassName

	^ self new
		model: aRBModel;
		className: aClassName;
		yourself! !

!RBAddAccessorsForClassTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBAddAccessorsForClassTransformation className: #RBVariableTransformation) asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 4.
	
	class := refactoring model classNamed: #RBVariableTransformation.
	self assert: (class parseTreeFor: #variableName)
		  equals: (self parseMethod: 'variableName ^variableName').
	self assert: (class parseTreeFor: #variableName:)
		  equals: (self parseMethod: 'variableName: anObject variableName := anObject')! !

!RBAddAccessorsForClassTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBAddAccessorsForClassTransformation className: self changeMock name) transform.
	
	self assert: transformation model changes changes size equals: 2.
	
	class := transformation model classNamed: self changeMock name asSymbol.
	self assert: (class parseTreeFor: #instVar)
		  equals: (self parseMethod: 'instVar ^instVar').
	self assert: (class parseTreeFor: #instVar:)
		  equals: (self parseMethod: 'instVar: anObject instVar := anObject')! !

!RBAddAssignmentTransformation commentStamp: ''!
I am responsible for adding an assignment statement (variable := anExpression) inside a method. Both variable and expression are passed as arguments separately.

Usage: 
| transformation |
transformation := (RBAddAssignmentTransformation
				variable: 'variable'
				value: '1 asString'
				inMethod: #methodBefore
				inClass: #RBAddAssignmentTransformationTest)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- Checks whether there is a variable in this environment with the given name.

Observations about the transformation:
- If the variable is already assigned in this method, the transformation will add the new assignment just after it.
- Otherwise, the assignment will be positioned as the first statement of the method!
!RBAddAssignmentTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ (RBCondition
			withBlock: [ self definingClass isNotNil ]
			errorString: ('Class named <1s> does not exist' expandMacrosWith: className))
	  & (RBCondition
			withBlock: [ self definingClass canUnderstand: selector ]
			errorString: ('Method named <1s> does not exist' expandMacrosWith: selector))
	  & (RBCondition
			withBlock: [ (self definingMethod allChildren
				select: #isVariable thenCollect: #name)
				anySatisfy: [ :e | e asString = variableName ] ]
			errorString: ('Method named <1s> does not have a variable named <2s>'
				expandMacrosWith: selector with: variableName))! !

!RBAddAssignmentTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName value: anExpression inMethod: aSelector inClass: aClassName

	self className: aClassName.
	selector := aSelector asSymbol.
	variableName := aVariableName asSymbol.
	value := anExpression! !

!RBAddAssignmentTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' variable: ''';
		nextPutAll: variableName;
		nextPutAll: ' value: ''';
		nextPutAll: value;
		nextPutAll: ' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: ''';
		nextPutAll: className.
	aStream nextPut: $)! !

!RBAddAssignmentTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	"if the variable was previously assigned, the transformation adds
	 this assignment as the last one"

	| methodTree assignmentNode assignments previousNode |
	methodTree := self definingMethod.
	assignmentNode := RBAssignmentNode
		variable: (RBVariableNode named: variableName)
		value: (self parserClass parseExpression: value).

	"check whether there are some dependencies in the expression"
	assignments := (methodTree allChildren select: #isAssignment)
		select: [ :each | each variable name asString = variableName ].
	previousNode := assignments detectMax: #stop.
	previousNode
		ifNil: [ methodTree body addNodeFirst: assignmentNode ]
		ifNotNil: [ previousNode parent addNode: assignmentNode after: previousNode ].
	class compileTree: methodTree! !

!RBAddAssignmentTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel variable: aVariableName value: anExpression inMethod: aSelector inClass: aClassName

	^ self new
		model: aRBModel;
		variable: aVariableName
		value: anExpression
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBAddAssignmentTransformation class methodsFor: 'api' stamp: ''!
variable: aVariableName value: anExpression inMethod: aSelector inClass: aClassName

	^ self new
		variable: aVariableName
		value: anExpression
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBAddAssignmentTransformationTest methodsFor: 'utilities' stamp: ''!
methodAfter

	| variable |
	variable := 'String'.
	variable := 1 asString.! !

!RBAddAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBAddAssignmentTransformation
						variable: 'variable'
						value: '1 asString'
						inMethod: #methodBefore
						inClass: #RBAddAssignmentTransformationTest)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 1.
	
	class := refactoring model classNamed: #RBAddAssignmentTransformationTest.
	self assert: (class directlyDefinesMethod: #methodBefore).
	self assert: (class parseTreeFor: #methodBefore) body statements size equals: 2.
	self assert: (class parseTreeFor: #methodBefore) body statements last value sourceCode equals: '1 asString'! !

!RBAddAssignmentTransformationTest methodsFor: 'utilities' stamp: ''!
methodBefore

	| variable |
	variable := 'String'.! !

!RBAddAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBAddAssignmentTransformation new
		variable: 'variable'
		value: '1 asString'
		inMethod: #methodBefore
		inClass: self class name)
		transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self class name.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBAddAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBAddAssignmentTransformation
							variable: 'variable'
							value: '1 asString'
							inMethod: #method
							inClass: #RBAddAssignmentTransformationTest)
							asRefactoring! !

!RBAddAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testClassDoesNotExist

	self shouldFail: (RBAddAssignmentTransformation
							variable: 'variable'
							value: '1 asString'
							inMethod: #methodBefore
							inClass: #RBAssignmentTransformationTest)
							asRefactoring! !

!RBAddAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testVariableDoesNotExist

	self shouldFail: (RBAddAssignmentTransformation
							variable: 'variable1'
							value: '1 asString'
							inMethod: #methodBefore
							inClass: #RBAddAssignmentTransformationTest)
							asRefactoring! !

!RBAddClassChange commentStamp: ''!
I am a refactoring change for a class addition. Executing this change is just like an ordinary class definition by 
calling on "my superclass" (or ProtoObject) subclass:....instancevariable... etc.
!
!RBAddClassChange methodsFor: 'accessing' stamp: ''!
classVariableNames

	^ classVariableNames! !

!RBAddClassChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	| class |
	class := onSystemDictionary classNamed: self changeClassName.

	^ class isBehavior
		  ifTrue: [ changeFactory addClassDefinition: class oldDefinition ]
		  ifFalse: [ changeFactory removeClassNamed: self changeClassName ]! !

!RBAddClassChange methodsFor: 'accessing' stamp: ''!
category

	^ category! !

!RBAddClassChange methodsFor: 'accessing' stamp: ''!
superclassName

	^ superclassName! !

!RBAddClassChange methodsFor: 'accessing' stamp: ''!
nameToDisplay

	^ self changeString! !

!RBAddClassChange methodsFor: 'private' stamp: ''!
fillOutDefinition: aDictionary

	superclassName := (aDictionary at: '`@superclass')
		ifNotNil: [ :value | value asSymbol ].
	className := (aDictionary at: '`#className') asSymbol.
	instanceVariableNames := self namesIn: (aDictionary
		at: '`#instanceVariableNames'
		ifAbsent: [ String new ]).
	classVariableNames := self namesIn: (aDictionary
		at: '`#classVariableNames'
		ifAbsent: [ String new ]).
	poolDictionaryNames := self namesIn: (aDictionary
		at: '`#poolDictionaries'
		ifAbsent: [ String new ]).
	category := (aDictionary
		at: '`#category'
		ifAbsent: [ #Unclassified ])
			asSymbol! !

!RBAddClassChange methodsFor: 'accessing' stamp: ''!
sharedPoolNames

	^ poolDictionaryNames! !

!RBAddClassChange methodsFor: 'accessing' stamp: ''!
instanceVariableNames

	^ instanceVariableNames! !

!RBAddClassChange methodsFor: 'accessing' stamp: ''!
textToDisplay

	^ self definition! !

!RBAddClassChange methodsFor: 'private' stamp: ''!
definitionClass

	^ onSystemDictionary classNamed:
		  (self superclassName ifNil: [ #ProtoObject ])! !

!RBAddClassChange class methodsFor: 'private' stamp: ''!
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'
		'`@superclass subclass: `#className instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries package: `#category'
		'`@superclass subclass: `#className uses: `@traitComposition instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries package: `#category'
		'`@superclass variableByteSubclass: `#className instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries package: `#category'
		'`@superclass variableByteSubclass: `#className uses: `@traitComposition instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries package: `#category'
		'`@superclass variableSubclass: `#className instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries package: `#category'
		'`@superclass variableSubclass: `#className uses: `@traitComposition instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries package: `#category'
		'`@superclass variableWordSubclass: `#className instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries package: `#category'
		'`@superclass variableWordSubclass: `#className uses: `@traitComposition instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries package: `#category'
		'`@superclass weakSubclass: `#className instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries package: `#category'
		'`@superclass weakSubclass: `#className uses: `@traitComposition instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries package: `#category')
		flatCollect: [ :each | Array with: each with: (each copyReplaceAll: '`@superclass' with: 'ProtoObject') , '. `className superclass: `@superclass' ]! !

!RBAddClassCommentTransformation commentStamp: ''!
Adds a comment to a class. It replaces the current comment for the new one (i.e., it does not append the given text to the existing class comment)

Usage:
| transformation |
transformation := (RBAddClassCommentTransformation
		comment: 'New comment'
		in: RBTransformationTest)
		transform.
(ChangesBrowser changes: transformation model changes changes) open!
!RBAddClassCommentTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	"no preconditions needed"
	
	^ self emptyCondition! !

!RBAddClassCommentTransformation methodsFor: 'api' stamp: ''!
comment: aString in: aClassName 

	self className: aClassName.
	comment := aString! !

!RBAddClassCommentTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' comment: ''';
		nextPutAll: comment;
		nextPutAll: ''' in: ''';
		nextPutAll: className.
	aStream nextPut: $)! !

!RBAddClassCommentTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self definingClass comment: comment! !

!RBAddClassCommentTransformation class methodsFor: 'api' stamp: ''!
comment: aString in: aClass

	^ self new
		comment: aString
		in: aClass;
		yourself! !

!RBAddClassCommentTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel comment: aString in: aClass

	^ self new
		model: aRBModel;
		comment: aString
		in: aClass;
		yourself! !

!RBAddClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExistingClassName
	self shouldFail: (self createRefactoringWithArguments:
		{ #Object . self class name asSymbol . #() .  #'Refactory-Testing' } )! !

!RBAddClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testSuperclassIsMetaclass
	self shouldFail: (self createRefactoringWithArguments:  
		{ #Foo . self class class name asSymbol . #() . #'Refactory-Testing'})! !

!RBAddClassParametrizedTest methodsFor: 'tests' stamp: ''!
testAddClass
	| refactoring newClass superClass classTest |
	
	refactoring := self createRefactoringWithArguments: 
		{ #FooTest . #RBAbstractRefactoringTest . (Array with: self class) . #'Refactory-Testing' }.
		
	self executeRefactoring: refactoring.
	
	newClass := refactoring model classNamed: #FooTest.
	superClass := refactoring model classNamed: #RBAbstractRefactoringTest.
	classTest := refactoring model classNamed: self class name.
	self assert: newClass superclass equals: superClass.
	self assert: (superClass subclasses includes: newClass).
	self assert: newClass classSide superclass equals: superClass classSide.
	self assert: (superClass classSide subclasses includes: newClass classSide).
	self assert: classTest superclass equals: newClass.
	self assert: (newClass subclasses includes: classTest).
	self assert: classTest classSide superclass equals: newClass classSide.
	self assert: (newClass classSide subclasses includes: classTest classSide)! !

!RBAddClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testSubclassIsMetaslass
	self shouldFail: (self createRefactoringWithArguments: 
		{ #Foo . #RBLintRuleTestData . (Array with: RBCompositeLintRuleTestData class) . #'Refactory-Tesing'})! !

!RBAddClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelInvalidSubclass

	self shouldFail: (self createRefactoringWithModel: model andArguments: 
		{ #Foo2 . #Object . (Array with: (model classNamed: #Bar)) . #'Refactory-Tesing' } )! !

!RBAddClassParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #addClass:superclass:subclasses:category: ! !

!RBAddClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonImmediateSubclassOfSuperclass
	self shouldFail: (self createRefactoringWithArguments: 
		{ #Foo . #RBCompositeLintRuleTestData . (Array with: RBBasicLintRuleTestData) . #'Refactory-Tesing'})! !

!RBAddClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testEmptyCategory
	self shouldFail: (self createRefactoringWithArguments:
		{ #FooTest . #RBAbstractRefactoringTest . (Array with: self class) . #'' })! !

!RBAddClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelExistingClassName

	self shouldFail: (self createRefactoringWithModel: model andArguments: 
		{ #Foo . #Object . #() . #'Refactory-Testing' })! !

!RBAddClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelNonImmediateSubclassOfSuperclass
	| refactoring |
	refactoring := self createRefactoringWithModel: model andArguments:  
		{ #Foo2 . #Object .(Array with: (model classNamed: #Bar)) . #'Refactory-Tesing'}.
		
	self shouldFail: refactoring! !

!RBAddClassParametrizedTest methodsFor: 'tests' stamp: ''!
testModelAddClass
	| refactoring newClass superClass subclass |
	subclass := model classNamed: #Bar.
	superClass := model classNamed: #Foo.
	refactoring := self createRefactoringWithModel: model andArguments:
		{ #FooTest . superClass name . (Array with: subclass) . #'Refactory-Testing' }.
		
	self executeRefactoring: refactoring.
	
	newClass := model classNamed: #FooTest.
	self assert: newClass superclass equals: superClass.
	self assert: (superClass subclasses includes: newClass).
	self assert: newClass classSide superclass equals: superClass classSide.
	self assert: (superClass classSide subclasses includes: newClass classSide).
	self assert: subclass superclass equals: newClass.
	self assert: (newClass subclasses includes: subclass).
	self assert: subclass classSide superclass equals: newClass classSide.
	self assert: (newClass classSide subclasses includes: subclass classSide)! !

!RBAddClassParametrizedTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	model := self abstractVariableTestData.! !

!RBAddClassParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBAddClassRefactoring };
		addCase: { #rbClass -> RBAddClassTransformation };
		yourself! !

!RBAddClassRefactoring commentStamp: ''!
I am a refactoring for creating new classes. 

You can define the name, superclass, category and subclasses.

I am used by other refactorings that may create new classes, for example, RBSplitClassRefactoring.

My preconditions verify that I use a valid class name, that does not yet exists as a global variable, 
and the subclasses (if any) were direct subclasses of the superclass.!
!RBAddClassRefactoring methodsFor: 'transforming' stamp: ''!
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 methodsFor: 'preconditions' stamp: ''!
preconditions
	| cond |
	cond := ((RBCondition isMetaclass: superclass) 
				errorMacro: 'Superclass must not be a metaclass') not.
	cond := subclasses inject: cond
				into: 
					[:sub :each | 
					sub 
						& ((RBCondition isMetaclass: each) 
								errorMacro: 'Subclass must <1?not :>be a metaclass') not 
							& (RBCondition isImmediateSubclass: each of: superclass)].
	^cond & (RBCondition isValidClassName: className) 
		& (RBCondition isGlobal: className in: self model) not 
			& (RBCondition isSymbol: category) 
			& ((RBCondition withBlock: [category isNotEmpty ]) 
					errorMacro: 'Invalid category name')! !

!RBAddClassRefactoring methodsFor: 'initialization' stamp: ''!
addClass: aName superclass: aClass subclasses: aCollection category: aSymbol 
	self className: aName.
	superclass := self classObjectFor: aClass.
	subclasses := aCollection collect: [:each | self classObjectFor: each].
	category := aSymbol! !

!RBAddClassRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' addClass: #';
		nextPutAll: className;
		nextPutAll: ' superclass: '.
	superclass storeOn: aStream.
	aStream nextPutAll: ' subclasses: '.
	subclasses asArray storeOn: aStream.
	aStream nextPutAll: ' category: '.
	category storeOn: aStream.
	aStream nextPut: $)! !

!RBAddClassRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk addClass: aName superclass: aClass subclasses: aCollection category: aSymbol 
	^ self new
		model: aRBSmalltalk;
		addClass: aName
			superclass: aClass
			subclasses: aCollection
			category: aSymbol;
		yourself! !

!RBAddClassRefactoring class methodsFor: 'instance creation' stamp: ''!
addClass: aName superclass: aClass subclasses: aCollection category: aSymbol
	^ self new
		addClass: aName
		superclass: aClass
		subclasses: aCollection
		category: aSymbol! !

!RBAddClassTraitChange commentStamp: ''!
I am a refactoring change for a class trait  addition, the meta side of a trait definition.!
!RBAddClassTraitChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ self class definition: self changeClass classTrait oldDefinition! !

!RBAddClassTraitChange methodsFor: 'initialization' stamp: ''!
fillOutDefinition: aDictionary

	className := (aDictionary at: '`traitName') asSymbol! !

!RBAddClassTraitChange methodsFor: 'private' stamp: ''!
definitionClass

	^ self changeClass! !

!RBAddClassTraitChange class methodsFor: 'private' stamp: ''!
definitionPatterns

	^ #(
		'`traitName classTrait uses: `@traitComposition' '`traitName classTrait'  
		'`traitName classTrait uses: `@traitComposition instanceVariableNames: `@instVars' 
		'`traitName classTrait instanceVariableNames: `@instVars'
	
		'`traitName classTrait uses: `@traitComposition slots: `@instVars' 
		'`traitName classTrait slots: `@instVars'	
	)! !

!RBAddClassTransformation commentStamp: ''!
Adds a class in the image, optionally inside an hierarchy (with superclass or subclasses).

Usage:
| transformation |
transformation := (RBAddClassTransformation
	addClass: #FooTest
	superclass: #RBTransformationTest
	subclasses: (Array with: RBAddClassTransformationTest)
	category: #'Refactoring2-Transformations-Tests')
	transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- superclass must be an existing class
- each subclass also must be an existing class
- name of the class to be added must be non-existent in the system
- name of the category must be a valid one!
!RBAddClassTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	| cond |
	cond := ((RBCondition isMetaclass: (self model classObjectFor: superclass)) 
				errorMacro: 'Superclass must not be a metaclass') not.
	cond := subclasses inject: cond into: [:sub :each | 
		sub & ((RBCondition isMetaclass: (self model classObjectFor: each)) 
					errorMacro: 'Subclass must <1?not :>be a metaclass') not 
			 & (RBCondition 
					isImmediateSubclass: (self model classObjectFor: each)
					of: (self model classObjectFor: superclass))].
	^ cond & (RBCondition isValidClassName: className) 
		& (RBCondition isGlobal: className in: self model) not 
			& (RBCondition isSymbol: category) 
			& ((RBCondition withBlock: [category isEmpty not]) 
					errorMacro: 'Invalid category name')! !

!RBAddClassTransformation methodsFor: 'api' stamp: ''!
addClass: aName superclass: superclassName subclasses: aCollection category: aSymbol

	self className: aName.
	superclass := superclassName asSymbol.
	subclasses := aCollection.
	category := aSymbol asSymbol! !

!RBAddClassTransformation methodsFor: 'api' stamp: ''!
addClass: aName superclass: aClass category: aSymbol

	self
		addClass: aName
		superclass: aClass asSymbol
		subclasses: (OrderedCollection new)
		category: aSymbol! !

!RBAddClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' addClass: #';
		nextPutAll: className;
		nextPutAll: ' superclass: '.
	superclass storeOn: aStream.
	aStream nextPutAll: ' subclasses: '.
	subclasses asArray storeOn: aStream.
	aStream nextPutAll: ' category: '.
	category storeOn: aStream.
	aStream nextPut: $)! !

!RBAddClassTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self model
		defineClass: ('<1p> subclass: #<2s> instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: <3p>' 
			expandMacrosWith: (self model classObjectFor: superclass)
			with: className
			with: category asString);
		reparentClasses: (subclasses collect: [ :e | self model classObjectFor: e ])
		to: (self model classNamed: className asSymbol)! !

!RBAddClassTransformation class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk addClass: aName superclass: aClass subclasses: aCollection category: aSymbol

	^ self new
		model: aRBSmalltalk;
		addClass: aName
			superclass: aClass
			subclasses: aCollection
			category: aSymbol;
		yourself! !

!RBAddClassTransformation class methodsFor: 'instance creation' stamp: ''!
addClass: aName superclass: aClass subclasses: aCollection category: aSymbol

	^ self new
		addClass: aName
		superclass: aClass
		subclasses: aCollection
		category: aSymbol;
		yourself! !

!RBAddClassVariableChange commentStamp: ''!
I am a refactoring for a class variable addition. My changes are executed on the instance side.!
!RBAddClassVariableChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ changeFactory
		  removeClassVariable: self variable
		  from: self changeClass! !

!RBAddClassVariableChange methodsFor: 'accessing' stamp: ''!
changeClass: aBehavior

	super changeClass: aBehavior.
	isMeta := false! !

!RBAddClassVariableChange methodsFor: 'private' stamp: ''!
changeSymbol

	^ #addClassVarNamed:! !

!RBAddClassVariableChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Add class variable <1s> to <2s>'
		  expandMacrosWith: self variable
		  with: self displayClassName! !

!RBAddClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelAlreadyExistingName
	self shouldFail: 
		(self createRefactoringWithModel: model 
		andArguments: {#ClassVarName2 . #Bar })! !

!RBAddClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testModelAddClassVariable
	| refactoring |
	refactoring := self createRefactoringWithModel: model 
		andArguments: { #ClassVarName3 . #Bar }.
		
	self executeRefactoring: refactoring.
	
	self assert: ((model classNamed: #Bar) 
				directlyDefinesClassVariable: #ClassVarName3)! !

!RBAddClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testAlreadyExistingName

	self shouldFail: 
		(self createRefactoringWithArguments:
			{ #RecursiveSelfRule . #RBTransformationRuleTestData }).
	self shouldFail: 
		(self createRefactoringWithArguments: 
			{ self objectClassVariable . #RBTransformationRuleTestData })! !

!RBAddClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelMetaclass
	| refactoring |
	self flag: 'Broken ref2 test'.
	refactoring := self createRefactoringWithModel: model andArguments: { #ClassVarName3 . #'Bar class' }.
"	self shouldFail: refactoring"! !

!RBAddClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMetaclass
	| refactoring |
	self flag: 'Broken ref2 test'.
	refactoring := self createRefactoringWithModel: model andArguments: { #ClassVarName3 . #'Object class' }.
"	self shouldFail: refactoring"! !

!RBAddClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testAddClassVariable
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{'Asdf' . #RBTransformationRuleTestData }.
		
	self executeRefactoring: refactoring.
	
	self assert: ((refactoring model 
		classNamed: #RBTransformationRuleTestData) 
		directlyDefinesClassVariable: #Asdf)! !

!RBAddClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMetaClassFailure
	self flag: 'Broken ref2 test'
"	self shouldFail: (self createRefactoringWithArguments: { #VariableName . #'RBTransformationRuleTestData class'})"! !

!RBAddClassVariableParametrizedTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self abstractVariableTestData.! !

!RBAddClassVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBAddClassVariableRefactoring .
					  #constructor -> #variable:class: };
		addCase: { #rbClass -> RBAddVariableTransformation .
					  #constructor -> #classVariable:class: };
		yourself! !

!RBAddClassVariableRefactoring commentStamp: ''!
I am a refactoring for adding new class variables.

My precondition verifies that the variable name is valid, not yet used in the whole hierarchy and not a global name.!
!RBAddClassVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	class addClassVariable: variableName! !

!RBAddClassVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition isMetaclass: class) not 
		& (RBCondition isValidClassVarName: variableName for: class) 
			& (RBCondition hierarchyOf: class definesVariable: variableName asString) 
					not 
			& (RBCondition isGlobal: variableName in: self model) not! !

!RBAddInstanceVariableChange commentStamp: ''!
I am a refactoring for a instance  variable addition. My changes are executed on the instance or class side.!
!RBAddInstanceVariableChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ changeFactory
		  removeInstanceVariable: self variable
		  from: self changeClass! !

!RBAddInstanceVariableChange methodsFor: 'private' stamp: ''!
changeSymbol

	^ #addInstVarNamed:! !

!RBAddInstanceVariableChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Add instance variable <1s> to <2s>'
		  expandMacrosWith: self variable
		  with: self displayClassName! !

!RBAddInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testAddInstanceVariable
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{'asdf' . #RBTransformationRuleTestData }.
		
	self executeRefactoring: refactoring.
	
	self assert: ((refactoring model 
		classNamed: #RBTransformationRuleTestData) 
		directlyDefinesInstanceVariable: 'asdf')! !

!RBAddInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testAddToModel
	| refactoring |
	model := RBNamespace new.
	model name: 'Add instance variable'.
	model defineClass: 'Object subclass: #FOOBAR 
		instanceVariableNames: ''fdsa'' 	
		classVariableNames: ''''
		poolDictionaries: ''''
		category: #''Refactory-Test data'''.
	refactoring := self createRefactoringWithModel: model 
		andArguments: {'asdf' .  #FOOBAR }.
	
	self executeRefactoring: refactoring.
	
	self assert: ((refactoring model
		classNamed: #FOOBAR) 
		directlyDefinesInstanceVariable: 'asdf')! !

!RBAddInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNewExistingName
	| refactoring |
	model := RBNamespace new.
	model name: 'Add instance variable'.
	model defineClass: 'Object subclass: #FOOBAR 
		instanceVariableNames: ''asdf'' 	
		classVariableNames: ''''
		poolDictionaries: ''''
		category: #''Refactory-Test data'''.
		
	refactoring := self createRefactoringWithModel: model 
		andArguments: {'asdf' . #FOOBAR }.
	
	self shouldFail: refactoring! !

!RBAddInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelAlreadyExistingName
	self shouldFail: ( self createRefactoringWithModel: model
		andArguments: {'instVarName1' . #Bar }).! !

!RBAddInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
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 := self createRefactoringWithModel: model 
		andArguments: { 'asdf' .#BARFOO }.
	
	self shouldFail: refactoring! !

!RBAddInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testAlreadyExistingName
	self shouldFail: 
		(self createRefactoringWithArguments: 
			{ 'class' . #RBTransformationRuleTestData}).
	self shouldFail: 
		(self createRefactoringWithArguments: 
			{'name'. #RBTransformationRuleTestData})! !

!RBAddInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelMetaclassAlreadyExistingName

	(model metaclassNamed: #Foo) 
		addInstanceVariable: 'instVarName1'.
		
	self shouldFail: ( self createRefactoringWithModel: model 
		andArguments: {'instVarName1' . #Bar })! !

!RBAddInstanceVariableParametrizedTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self abstractVariableTestData.! !

!RBAddInstanceVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBAddInstanceVariableRefactoring .
					  #constructor -> #variable:class: };
		addCase: { #rbClass -> RBAddVariableTransformation .
					  #constructor -> #instanceVariable:class: };
		yourself! !

!RBAddInstanceVariableRefactoring commentStamp: ''!
I am a refactoring for adding new instance variables.

My precondition verifies that the variable name is valid, not yet used in the whole hierarchy and not a global name.!
!RBAddInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	class addInstanceVariable: variableName! !

!RBAddInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition isValidInstanceVariableName: variableName for: class) 
		& (RBCondition hierarchyOf: class definesVariable: variableName) not 
			& (RBCondition isGlobal: variableName in: self model) not! !

!RBAddMessageSendTransformation commentStamp: ''!
I am responsible for adding a message send inside a method. In this implementation, all the message send, e.g., 'variable message: (arg)' shall be described as a string. It was implemented this way to avoid having another transformation just to add the receiver as a literal node.

Usage:
| transformation |
transformation := (RBAddMessageSendTransformation
				messageSend: 'variable byteAt: 1'
				inMethod: #methodBefore
				inClass: #RBAddMessageSendTransformationTest)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the method exists.
- all accesses in the message send, e.g., receiver and arguments, are previously defined in the method

Observations about the transformation:
- The transformation does not know the location on which it will place the message send. Therefore, it extracts all the accesses in the message to be added, and adds the message after all the accesses are assigned.
- If there is no access, the message send will be the first statement of the method.!
!RBAddMessageSendTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition
		withBlock: [ self definingClass isNotNil ]
		errorString: ('Class named <1s> does not exist' expandMacrosWith: className))
		&
			(RBCondition
				withBlock: [ self definingClass canUnderstand: selector ]
				errorString: ('Method named <1s> does not exist' expandMacrosWith: selector))
		&
			(RBCondition
				withBlock: [ | messageNode |
					messageNode := self parserClass parseExpression: message.
					messageNode allVariables
						allSatisfy: [ :e | 
							(self definingMethod hasArgumentNamed: e name)
								or: [ self definingMethod hasTemporaryNamed: e name ] ] ]
				errorString:
					('Some variables in this message send are not defined in method named <1s>.'
						expandMacrosWith: selector))! !

!RBAddMessageSendTransformation methodsFor: 'api' stamp: ''!
messageSend: aMessageSend inMethod: aSelector inClass: aClassName

	self className: aClassName.
	selector := aSelector.
	message := aMessageSend
	! !

!RBAddMessageSendTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' messageSend: ''';
		nextPutAll: message;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBAddMessageSendTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	| methodTree messageNode assignments variables previousNode |
	methodTree := self definingMethod.
	messageNode := self parserClass parseExpression: message.

	"if the message requires variables, look for the right variables in this context"
	variables := messageNode allVariables.
	assignments := (methodTree allChildren select: #isAssignment)
		select: [ :each | variables includes: each variable ].
	previousNode := assignments detectMax: #stop.
	previousNode
		ifNil: [ methodTree body addNodeFirst: messageNode ]
		ifNotNil: [ previousNode parent addNode: messageNode after: previousNode ].
	class compileTree: methodTree! !

!RBAddMessageSendTransformation class methodsFor: 'api' stamp: ''!
messageSend: aString inMethod: aSelector inClass: aClassName

	^ self new
		messageSend: aString
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBAddMessageSendTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel messageSend: aString inMethod: aSelector inClass: aClassName

	^ self new
		model: aRBModel;
		messageSend: aString
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBAddMessageSendTransformationTest methodsFor: 'utilities' stamp: ''!
methodAfter

	| variable |
	variable := 'String'.
	variable byteAt: 1.! !

!RBAddMessageSendTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBAddMessageSendTransformation
						messageSend: 'variable byteAt: 1'
						inMethod: #methodBefore
						inClass: #RBAddMessageSendTransformationTest)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 1.
	
	class := refactoring model classNamed: #RBAddMessageSendTransformationTest.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBAddMessageSendTransformationTest methodsFor: 'utilities' stamp: ''!
methodBefore

	| variable |
	variable := 'String'.! !

!RBAddMessageSendTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBAddMessageSendTransformation new
		messageSend: 'variable byteAt: 1'
		inMethod: #methodBefore
		inClass: self class name)
		transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self class name.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBAddMessageSendTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBAddMessageSendTransformation
							messageSend: 'variable byteAt: 1'
							inMethod: #method
							inClass: #RBAddMessageSendTransformationTest)
							asRefactoring! !

!RBAddMessageSendTransformationTest methodsFor: 'tests' stamp: ''!
testReceiverDoesNotExist

	self shouldFail: (RBAddMessageSendTransformation
							messageSend: 'variable2 byteAt: 1'
							inMethod: #methodBefore
							inClass: #RBAddMessageSendTransformationTest)
							asRefactoring! !

!RBAddMessageSendTransformationTest methodsFor: 'tests' stamp: ''!
testClassDoesNotExist

	self shouldFail: (RBAddMessageSendTransformation
							messageSend: 'variable byteAt: 1'
							inMethod: #methodBefore
							inClass: #RBMessageSendTransformationTest)
							asRefactoring! !

!RBAddMetaclassChange commentStamp: ''!
I am a refactoring change for the class side of a class addition.!
!RBAddMetaclassChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ self class definition: self changeClass class oldDefinition! !

!RBAddMetaclassChange methodsFor: 'accessing' stamp: ''!
classInstanceVariableNames

	^ classInstanceVariableNames! !

!RBAddMetaclassChange methodsFor: 'initialization' stamp: ''!
fillOutDefinition: aDictionary

	className := (aDictionary at: '`className') asSymbol.
	classInstanceVariableNames := self namesIn:
		                              (aDictionary
			                               at: '`#instanceVariableNames'
			                               ifAbsent: [ String new ])! !

!RBAddMetaclassChange methodsFor: 'private' stamp: ''!
definitionClass

	^ self changeClass! !

!RBAddMetaclassChange class methodsFor: 'private' stamp: ''!
definitionPatterns

	^ #(
		'`className class instanceVariableNames: `#instanceVariableNames'
		'`className class uses: `@traitComposition instanceVariableNames: `#instanceVariableNames'
		'`className class uses: `@traitComposition slots: `#instanceVariableNames'
		'`className class slots: `#instanceVariableNames'
		'`className class'
		)! !

!RBAddMethodChange commentStamp: ''!
I am a refactory change for a method change. I know a bout the 
source selector and protocol of the new or modified method. 

The controller instance variable is not directly use by me but needed for executing the change by compiling this
method, the controller is what we pass to the compiler, as the object to get notified by the compiler about the compilation result.
!
!RBAddMethodChange methodsFor: 'accessing' stamp: ''!
textToDisplay

	^ self source! !

!RBAddMethodChange methodsFor: 'initialization' stamp: ''!
class: aClass source: aString controller: aController

	self changeClass: aClass.
	source := aString.
	self protocols: (RBBrowserEnvironment new
			 whichProtocolIncludes: self selector
			 in: aClass).
	controller := aController! !

!RBAddMethodChange methodsFor: '*NautilusRefactoring' stamp: ''!
accept: aText notifying: aController
	"Just to make sure that it compiles, try with the standard compiler."
	
	| compiler |
	compiler := self changeClass
		ifNil: [ Object compiler ]
		ifNotNil: [:changeClass | changeClass compiler ].
		
	compiler
		source: aText asString;
		class:  self changeClass;
		requestor: aController;
		failBlock: [ ^ false ];
		compile.	
		
	self 
		class: self changeClass
		protocol: self protocol
		source: aText asString.
		
	^ true! !

!RBAddMethodChange methodsFor: 'comparing' stamp: ''!
= anAddMethodChange

	super = anAddMethodChange ifFalse: [ ^ false ].
	^ self parseTree = anAddMethodChange parseTree! !

!RBAddMethodChange methodsFor: 'accessing' stamp: ''!
changeForMetaclass: aClassName selector: aSelector

	^ (isMeta and: [ 
		   self selector = aSelector and: [ className = aClassName ] ])
		  ifTrue: [ self ]
		  ifFalse: [ nil ]! !

!RBAddMethodChange methodsFor: 'comparing' stamp: ''!
hash

	^ self parseTree hash! !

!RBAddMethodChange methodsFor: 'accessing' stamp: ''!
selector

	selector ifNil: [ 
		selector := self parserClass parseMethodPattern: source.
		selector ifNil: [ selector := #unknown ] ].
	^ selector! !

!RBAddMethodChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ ( self changeClass includesSelector: self selector )
		ifTrue: [ | oldProtocol |

			oldProtocol := RBBrowserEnvironment new whichProtocolIncludes: self selector in: self changeClass.
			oldProtocol ifNil: [ oldProtocol := #accessing ].
			changeFactory
				addMethodSource: ( self methodSourceFor: self selector )
				in: self changeClass
				classified: oldProtocol
			]
		ifFalse: [ changeFactory removeMethod: selector from: self changeClass ]! !

!RBAddMethodChange methodsFor: 'accessing' stamp: ''!
changeForClass: aClassName selector: aSelector

	^ (isMeta not and: [ 
		   self selector = aSelector and: [ className = aClassName ] ])
		  ifTrue: [ self ]
		  ifFalse: [ nil ]! !

!RBAddMethodChange methodsFor: 'accessing' stamp: ''!
definedSelector

	^ definedSelector! !

!RBAddMethodChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPut: $!!;
		nextPutAll: self displayClassName;
		nextPutAll: ' methodsFor: ''';
		nextPutAll: self protocol;
		nextPutAll: ''' stamp: ';
		print: self changeStamp;
		nextPut: $!!;
		cr;
		nextPutAll: (source copyReplaceAll: '!!' with: '!!!!');
		nextPutAll: '!! !!'! !

!RBAddMethodChange methodsFor: 'accessing' stamp: ''!
protocol

	^ self protocols first! !

!RBAddMethodChange methodsFor: 'accessing' stamp: ''!
source

	^ source! !

!RBAddMethodChange methodsFor: 'initialize-release' stamp: ''!
protocols: aCollectionOrString

	protocols := aCollectionOrString isString
		             ifTrue: [ 
			             aCollectionOrString = Protocol unclassified
				             ifTrue: [ protocols := #( accessing ) ]
				             ifFalse: [ Array with: aCollectionOrString ] ]
		             ifFalse: [ aCollectionOrString ]! !

!RBAddMethodChange methodsFor: 'initialization' stamp: ''!
class: aClass protocol: aProtocol source: aString controller: aController

	self changeClass: aClass.
	self protocols: aProtocol.
	source := aString.
	controller := aController! !

!RBAddMethodChange methodsFor: 'accessing' stamp: ''!
protocols

	^ protocols! !

!RBAddMethodChange methodsFor: 'initialization' stamp: ''!
controller: aController

	controller := aController! !

!RBAddMethodChange methodsFor: 'initialization' stamp: ''!
class: aClass protocol: aProtocol source: aString

	self changeClass: aClass.
	self protocols: aProtocol.
	source := aString! !

!RBAddMethodChange methodsFor: 'accessing' stamp: ''!
oldVersionTextToDisplay
	| class |
	
	class := (onSystemDictionary  
					classNamed: className)
					ifNil: [ ^ super oldVersionTextToDisplay ].
				
	isMeta ifTrue: [ class := class classSide ].
				
	^ class methodDict 
			at: self selector
			ifPresent: [:method | method sourceCode ]
			ifAbsent: [ super oldVersionTextToDisplay ]! !

!RBAddMethodChange methodsFor: 'private' stamp: ''!
controller

	^ controller! !

!RBAddMethodChange methodsFor: 'private' stamp: ''!
parseTree

	^ self parserClass
		  parseMethod: self source
		  onError: [ :str :pos | ^ nil ]! !

!RBAddMethodChange methodsFor: 'printing' stamp: ''!
changeString

	^ self displayClassName , '>>' , self selector! !

!RBAddMethodChange methodsFor: 'private' stamp: ''!
primitiveExecute

	definedSelector := self changeClass
		                   compile: self source
		                   classified: self protocol
		                   notifying: self controller! !

!RBAddMethodChange class methodsFor: 'instance creation' stamp: ''!
compile: aString in: aBehavior classified: aProtocol

	^ self
		  compile: aString
		  in: aBehavior
		  classified: aProtocol
		  for: nil! !

!RBAddMethodChange class methodsFor: 'instance creation' stamp: ''!
compile: aString in: aBehavior classified: aProtocol for: aController

	^ self new
		  class: aBehavior
		  protocol: aProtocol
		  source: aString
		  controller: aController! !

!RBAddMethodChange class methodsFor: 'instance creation' stamp: ''!
compile: aString in: aClass

	^ self compile: aString in: aClass for: nil! !

!RBAddMethodChange class methodsFor: 'instance creation' stamp: ''!
compile: aString in: aClass for: aController

	^ self new class: aClass source: aString controller: aController! !

!RBAddMethodCommentTransformation commentStamp: ''!
Adds a comment in the beginning of the method (after its signature).

Usage:
| transformation |
transformation := (RBAddMethodCommentTransformation
		comment: 'New comment'
		inMethod: #testTransform
		inClass: #RBAddClassTransformationTest)
		transform.
(ChangesBrowser changes: transformation model changes changes) open!
!RBAddMethodCommentTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	"no preconditions needed"
	
	^ self emptyCondition! !

!RBAddMethodCommentTransformation methodsFor: 'api' stamp: ''!
comment: aString inMethod: aSelector inClass: aClassName

	self className: aClassName.
	selector := aSelector.
	comment := aString
	! !

!RBAddMethodCommentTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' comment: ''';
		nextPutAll: comment;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBAddMethodCommentTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	| tree signature sourceCode |
	tree := self definingMethod.
	signature := tree source copyFrom: 1 to: tree body start - 1.
	sourceCode := signature , String cr , (comment surroundedBy: '"')
		, String cr , tree body sourceCode.
	self definingClass
		compileTree: (self parserClass parseMethod: sourceCode)! !

!RBAddMethodCommentTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel comment: aString inMethod: aSelector inClass: aClassName

	^ self new
		model: aRBModel;
		comment: aString 
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBAddMethodCommentTransformation class methodsFor: 'api' stamp: ''!
comment: aString inMethod: aSelector inClass: aClassName

	^ self new
		comment: aString 
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBAddMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadMethod
	self shouldFail: (self createRefactoringWithArguments: 
		{ 'asdf ^super ^printString' . 
		RBBasicLintRuleTestData . 
		#(#accessing )})! !

!RBAddMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelExistingSelector
	self shouldFail: ( self createRefactoringWithModel: model 
			andArguments: 
				{'classVarName1 ^super printString' . 
				(model classNamed: #Bar) . 
				#(#accessing) });
		  shouldFail: (self createRefactoringWithModel: model 
			andArguments:
				{'printString ^super printString' .
				(model classNamed: #Bar) .
				{#accessing}}).! !

!RBAddMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testModelAddMethod
	| refactoring class |
	class := model metaclassNamed: #Bar.
	refactoring := self createRefactoringWithModel: model andArguments: 
				{'printString1 ^super printString' . 
				class . 
				#(#accessing)}.
	self executeRefactoring: refactoring.
	self assert: (class parseTreeFor: #printString1) 
		  equals: (self parseMethod: 'printString1 ^super printString')! !

!RBAddMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testAddMethod
	| refactoring |
	refactoring := self createRefactoringWithArguments:
		{'printString1 ^ super printString' . 
		RBBasicLintRuleTestData . 
		#(#accessing )}.
	
	self executeRefactoring: refactoring.
	self assert: ((refactoring model classNamed: #RBBasicLintRuleTestData) 
			parseTreeFor: #printString1) 
		equals: (self parseMethod: 'printString1 ^super printString')! !

!RBAddMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelInheritedSelector
	| refactoring |
	refactoring := self createRefactoringWithModel: model andArguments: 
				{ 'printString ^super printString' . (model classNamed: #Bar) . #(#accessing) }.
	self shouldFail: refactoring! !

!RBAddMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExistingSelector
	self shouldFail: (self createRefactoringWithArguments: 
		{'printString ^super printString' . 
		RBBasicLintRuleTestData . 
		#(#accessing )})! !

!RBAddMethodParametrizedTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self abstractVariableTestData.! !

!RBAddMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBAddMethodRefactoring .
					  #constructor -> #addMethod:toClass:inProtocols: };
		addCase: { #rbClass -> RBAddMethodTransformation .
					  #constructor -> #sourceCode:in:withProtocols: };
		yourself! !

!RBAddMethodRefactoring commentStamp: ''!
I am a refactoring for adding methods to a class.

My operation will compile a new method to a class in the specified protocol.

You can create an instance with: 

```
RBAddMethodRefactoring 
	model: RBNamespace new 
	addMethod:'foo ^ self' 
	toClass:Morph inProtocols:{'test'}.
```

The method to compile is the full method source (selector, arguments and code).

My precondition verifies that the methods source can be parsed and that the class does not already understands this methods selectors. That means, you can not use this refactoring to add methods for overwriting superclass methods.
!
!RBAddMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform
	class compile: source classified: protocols! !

!RBAddMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	| selector method |
	method := self parserClass
		parseMethod: source
		onError: [ :string :position | 
			^ RBCondition
				withBlock: [ self refactoringFailure: 'The sources could not be parsed' ] ].
	selector := method selector.
	selector ifNil: [ self refactoringFailure: 'Invalid source.' ].
	^ (RBCondition canUnderstand: selector in: class) not! !

!RBAddMethodRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' addMethod: ''';
		nextPutAll: source;
		nextPutAll: ''' toClass: '.
	class storeOn: aStream.
	aStream nextPutAll: ' inProtocols: '.
	protocols storeOn: aStream.
	aStream nextPut: $)! !

!RBAddMethodRefactoring methodsFor: 'initialization' stamp: ''!
addMethod: aString toClass: aClass inProtocols: protocolList 
	class := self classObjectFor: aClass.
	source := aString.
	protocols := protocolList! !

!RBAddMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk addMethod: aString toClass: aClass inProtocols: protocolList 
	^ self new
		model: aRBSmalltalk;
		addMethod: aString
			toClass: aClass
			inProtocols: protocolList;
		yourself! !

!RBAddMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
addMethod: aString toClass: aClass inProtocols: protocolList 
	^ self new 
		addMethod: aString
		toClass: aClass
		inProtocols: protocolList! !

!RBAddMethodTransformation commentStamp: ''!
Adds a method in a class. The source code of the method, as well as the protocol in which the method will be categorized, can be specified.

Usage:
| transformation |
transformation := (RBAddMethodTransformation
		sourceCode: 'printString1 ^super printString'
		in: RBTransformationTest
		withProtocol: #accessing)
		transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
The source code of the method must be syntactically valid.!
!RBAddMethodTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	| rbMethod |
	rbMethod := self parserClass
		parseMethod: sourceCode
		onError: [ :string :position | 
			^ RBCondition
				withBlock: [ self
						refactoringError: 'The content of this method cannot be parsed.' ] ].
	rbMethod selector
		ifNil: [ self refactoringError: 'The method has no selector.' ].
	^ (RBCondition
		canUnderstand: rbMethod selector
		in: self definingClass) not! !

!RBAddMethodTransformation methodsFor: 'api' stamp: ''!
sourceCode: aString in: aClassName withProtocols: symbols

	self className: aClassName.
	sourceCode := aString.
	protocols := symbols! !

!RBAddMethodTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' sourceCode: '''.
	sourceCode storeOn: aStream.
	aStream nextPutAll: ''' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' withProtocols: '.
	protocols storeOn: aStream.
	aStream nextPut: $)! !

!RBAddMethodTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self definingClass
		compile: sourceCode
		classified: protocols asArray! !

!RBAddMethodTransformation class methodsFor: 'api' stamp: ''!
sourceCode: aString in: aClass withProtocols: protocols

	^ self new
		sourceCode: aString
		in: aClass
		withProtocols: protocols;
		yourself! !

!RBAddMethodTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel sourceCode: aString in: aClass withProtocols: protocols

	^ self new
		model: aRBModel;
		sourceCode: aString
		in: aClass
		withProtocols: protocols;
		yourself! !

!RBAddPackageChange commentStamp: ''!
I am a refactory change for a package creating. The RBRefactory api is implemented in my super class, I just define the concrete "package" creating.!
!RBAddPackageChange methodsFor: 'adding' stamp: ''!
addPackageNamed: aString
	packageName := aString! !

!RBAddPackageChange methodsFor: 'converting' stamp: ''!
asUndoOperation
	^ changeFactory removePackageNamed: packageName! !

!RBAddPackageChange methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream
		nextPutAll: 'RPackageOrganizer default ';
		nextPutAll: #createPackageNamed:;
		nextPutAll: packageName;
		nextPut: $!!! !

!RBAddPackageChange methodsFor: 'private' stamp: ''!
primitiveExecute
	RPackageOrganizer default createPackageNamed: packageName! !

!RBAddPackageChange class methodsFor: 'adding' stamp: ''!
addPackageNamed: aString

	^ self new addPackageNamed: aString! !

!RBAddParameterParametrizedTest methodsFor: 'tests' stamp: ''!
testAddParameterThatReferencesModelGlobal

	| refactoring class oldSelector newSelector newArg |
	oldSelector := ('test' , 'Foo:') asSymbol.
	newSelector := #testFoo:bar:.
	newArg := RBArgumentName name: 'anObject' value:  'Bar new'.
	refactoring := self createRefactoringWithModel: model andArguments: 
		{ oldSelector . RBRefactoryTestDataApp . newSelector . #(1 -1) . {newArg}}.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self
		assert: (class parseTreeFor: newSelector)
		equals: (self parseMethod: 'testFoo: anObject bar: anObject1
								^self class + anObject').
	self
		assert: (class parseTreeFor: #callFoo)
		equals:
		(self parseMethod: 'callFoo ^self testFoo: 5 bar: (Bar new)').
	self deny: (class directlyDefinesMethod: oldSelector)! !

!RBAddParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelBadInitializationCode
	| refactoring newArg |
	newArg := RBArgumentName name: 'anObject' value: 'AddParameterRefactoring new'.
	model removeClassNamed: #RBRefactoring.
	refactoring := self createRefactoringWithModel: model andArguments:  
		{#name1 . RBLintRuleTestData . #name1: . #(-1) . {newArg}}.
	self shouldFail: refactoring! !

!RBAddParameterParametrizedTest methodsFor: 'tests' stamp: ''!
testAddParameterThatReferencesGlobalAndLiteral

	| refactoring class oldSelector newSelector newArg |
	oldSelector := ('test' , 'Foo:') asSymbol.
	newSelector := #testFoo:bar:.
	newArg := RBArgumentName name: 'anObject' value: 'OrderedCollection new: 5'.
	refactoring := self createRefactoringWithArguments:
		{ oldSelector . RBRefactoryTestDataApp . newSelector . #(1 -1) . {newArg} }.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self
		assert: (class parseTreeFor: newSelector)
		equals: (self parseMethod: 'testFoo: anObject bar: anObject1
								^self class + anObject').
	self
		assert: (class parseTreeFor: #callFoo)
		equals: (self parseMethod:
				 'callFoo ^self testFoo: 5 bar: (OrderedCollection new: 5)').
	self deny: (class directlyDefinesMethod: oldSelector)! !

!RBAddParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	| newArg |
	newArg := RBArgumentName name: 'anObject' value: 'nil'.
	self shouldFail: (self createRefactoringWithArguments:
		{ #name1 . RBLintRuleTestData . #name1: . #(-1) . {newArg}})! !

!RBAddParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelNonExistantName
	| refactoring newArg |
	newArg := RBArgumentName name: 'anObject' value: 'nil'.
	(model classNamed: #RBLintRuleTestData) removeMethod: #name.
	refactoring := self createRefactoringWithModel: model andArguments:  
		{ #name . RBLintRuleTestData . #nameNew: . #(-1) . {newArg}}.
	self shouldFail: refactoring! !

!RBAddParameterParametrizedTest methodsFor: 'accessing' stamp: ''!
defaultNamespace 
	^ RBNamespace! !

!RBAddParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadInitializationCode
	| newArg |
	newArg := RBArgumentName name: 'anObject' value: 'foo:'.
	self shouldFail: (self createRefactoringWithArguments: 
		{ #name . RBLintRuleTestData . #name: . #(-1) . {newArg}}).
	newArg := RBArgumentName name: 'anObject' value: 'foo'.
	self shouldFail: (self createRefactoringWithArguments: 
		{ #name . RBLintRuleTestData . #name: . #(-1) . {newArg}}).! !

!RBAddParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPrimitiveMethods
	| refactoring newArg |
	newArg := RBArgumentName name: 'anObject' value: '1'.
	(model classNamed: #Object) 
		compile: 'foo <primitive: 100> ^#() primitiveFailed'
		classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model andArguments:  
		{ #foo . Object . #foo123124321s: . #(-1) . {newArg}}.
	self shouldFail: refactoring.
	refactoring := self createRefactoringWithArguments:  
		{ #at: . Object . #at:foo: . #(1 -1) . {newArg}}.
	self shouldFail: refactoring.
	! !

!RBAddParameterParametrizedTest methodsFor: 'tests' stamp: ''!
testAddTwoParameters

	| refactoring class oldSelector newSelector newArgs |
	oldSelector := ('test' , 'Foo:') asSymbol.
	newSelector := #testColl:foo:string:.
	newArgs := Array with: (RBArgumentName name: 'aColl' value: 'OrderedCollection new: 5')
		with: (RBArgumentName name: 'aString' value: '''string''').
	refactoring := self createRefactoringWithArguments: 
		{ oldSelector . RBRefactoryTestDataApp . newSelector . #(-1 1 -2) . newArgs }.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self
		assert: (class parseTreeFor: newSelector)
		equals: (self parseMethod: 'testColl: aColl foo: anObject string: aString
								^self class + anObject').
	self
		assert: (class parseTreeFor: #callFoo)
		equals: (self parseMethod:
				 'callFoo ^self testColl: (OrderedCollection new: 5) foo: 5 string: ''string''').
	self deny: (class directlyDefinesMethod: oldSelector)! !

!RBAddParameterParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #addParameterToMethod:in:newSelector:permutation:newArgs:! !

!RBAddParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInvalidNumArgsOfNewSelector
	| newArg |
	newArg := RBArgumentName name: 'anObject' value: 'nil'.
	self shouldFail: (self createRefactoringWithArguments: 
		{#checkSendersAccessTo: . RBLintRuleTestData . #checkSendersAccessTo: . #(1 -1) . {newArg}})! !

!RBAddParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testUseExistingNewSelector
	| newArg |
	newArg := RBArgumentName name: 'anObject' value: 'nil'.
	self shouldFail: (self createRefactoringWithArguments:  
		{ #checkSendersAccessTo: . RBLintRuleTestData . #safeVariableNameFor:temporaries: . #(1 -1) . {newArg}})! !

!RBAddParameterParametrizedTest methodsFor: 'tests' stamp: ''!
testAddParameterThatReferencesSelf

	| refactoring class oldSelector newSelector newArg |
	oldSelector := ('test' , 'Foo:') asSymbol.
	newSelector := #testFoo:bar:.
	newArg := RBArgumentName name: 'aFoo' value: 'self printString'. 
	refactoring := self createRefactoringWithArguments: 
		{oldSelector . RBRefactoryTestDataApp . newSelector . #(1 -1) . {newArg}}.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self
		assert: (class parseTreeFor: newSelector)
		equals: (self parseMethod: 'testFoo: anObject bar: aFoo
								^self class + anObject').
	self
		assert: (class parseTreeFor: #callFoo)
		equals:
		(self parseMethod:
			 'callFoo ^self testFoo: 5 bar: (self printString)').
	self deny: (class directlyDefinesMethod: oldSelector)! !

!RBAddParameterParametrizedTest methodsFor: 'tests' stamp: ''!
testAddParameterAndRenameParameters
	| oldSelector newSelector refactoring class newArg |
	oldSelector := ('called:' , 'on:') asSymbol.
	newSelector := #called:bar:on:.
	newArg := RBArgumentName name: 'anObject' value: '#(1.0)'.
	refactoring := self createRefactoringWithArguments: 
		{ oldSelector . RBRefactoryTestDataApp . newSelector . #(1 -1 2) . { newArg }}.
	refactoring renameMap: (Array with: ((RBArgumentName name: 'aBlock') newName: 'aBlock1')).
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self assert: (class parseTreeFor: newSelector) equals: (self parseMethod: 'called: anObject bar: anObject1 on: aBlock1
							Transcript
								show: anObject printString;
								cr.
								aBlock1 value').
	self assert: (class parseTreeFor: #caller) equals: (self parseMethod: 'caller
							| anObject |
							anObject := 5.
							self 
								called: anObject + 1
								bar: #(1.0) on: [^anObject]').
	self deny: (class directlyDefinesMethod: oldSelector)! !

!RBAddParameterParametrizedTest methodsFor: 'tests' stamp: ''!
testAddParameterForTwoArgumentMessage
	| oldSelector newSelector refactoring class newArg |
	oldSelector := ('called:' , 'on:') asSymbol.
	newSelector := #called:bar:on:.
	newArg := RBArgumentName name: 'anObject' value: '#(1.0)'.
	refactoring := self createRefactoringWithArguments: 
		{oldSelector . RBRefactoryTestDataApp . newSelector . #(1 -1 2) . { newArg }}.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self assert: (class parseTreeFor: newSelector) equals: (self parseMethod: 'called: anObject bar: anObject1 on: aBlock
							Transcript
								show: anObject printString;
								cr.
								aBlock value').
	self assert: (class parseTreeFor: #caller) equals: (self parseMethod: 'caller
							| anObject |
							anObject := 5.
							self 
								called: anObject + 1
								bar: #(1.0) on: [^anObject]').
	self deny: (class directlyDefinesMethod: oldSelector)! !

!RBAddParameterParametrizedTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self abstractVariableTestData.! !

!RBAddParameterParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBAddParameterRefactoring };
		addCase: { #rbClass -> RBAddParameterTransformation };
		yourself! !

!RBAddParameterRefactoring commentStamp: ''!
I am a refactoring operations for adding method arguments.

You can modify the method name and add an additional keyword argument and the default value used by senders of the original method. Only one new argument can be added. But you can change the whole method name, as long as the number of argument matches.

For example, for `r:g:b:`  add another parameter "a" the new method is `r:g:b:a:`
or change the whole method to `setRed:green:blue:alpha:`

This refactoring will 
- add a new method with the new argument, 
- remove the old method (for all implementors) and 
- replace every sender of the prior method with the new one, using the specified default argument.!
!RBAddParameterRefactoring methodsFor: 'private' stamp: ''!
senders

	senders
		ifNil: [ senders := Set new.
			self model allReferencesTo: oldSelector do: [ :each | senders add: each modelClass ]
			].
	^ senders! !

!RBAddParameterRefactoring methodsFor: 'private' stamp: ''!
parseTreeRewriter
	| rewriteRule oldString newString |
	rewriteRule := self parseTreeRewriterClass new.
	oldString := self buildSelectorString: oldSelector.
	newString := self newSelectorString.
	rewriteRule replace: '``@object ' , oldString
		with: '``@object ' , newString.
	^rewriteRule! !

!RBAddParameterRefactoring methodsFor: 'accessing' stamp: ''!
newArgs
	^ newArgs ifNil: [ newArgs := { } ]! !

!RBAddParameterRefactoring methodsFor: 'preconditions' stamp: ''!
myConditions
	^RBCondition withBlock: 
		[oldSelector numArgs < newSelector numArgs 
			ifFalse: 
				[self refactoringFailure: newSelector printString, 
				' doesn''t have the proper number of arguments.'].
		self newArgs do: [	:arg | self verifyInitializationExpressionOf: arg value1 ].
		true]! !

!RBAddParameterRefactoring methodsFor: 'initialization' stamp: ''!
addParameterToMethod: aSelector in: aClass newSelector: newSel permutation: aColl1 newArgs: aColl2
	self 
		renameMethod: aSelector
		in: aClass
		to: newSel
		permutation: aColl1.
	newArgs := aColl2.! !

!RBAddParameterRefactoring methodsFor: 'private' stamp: ''!
safeVariableNameFor: aClass temporaries: allTempVars 
	| baseString index newString |
	newString := baseString := 'anObject'.
	index := 0.
	
	[(allTempVars includes: newString) 
		or: [aClass definesInstanceVariable: newString]] 
			whileTrue: 
				[index := index + 1.
				newString := baseString , index printString].
	^newString! !

!RBAddParameterRefactoring methodsFor: 'action' stamp: ''!
renameArgumentsIn: parseTree
	| newArgNames |
	newArgNames := newArgs collect: [ :arg | arg name ].	
	self renameMap do: [ :arg |
		(newArgNames includes: arg name) ifFalse: [ 
		(self parseTreeRewriterClass rename: arg name to: arg newName) executeTree: parseTree
	] ]! !

!RBAddParameterRefactoring methodsFor: 'preconditions' stamp: ''!
checkVariableReferencesIn: aParseTree

	| searcher |

	searcher := self parseTreeSearcher.
	searcher
		matches: '`var'
		do: [ :aNode :answer | 
			| name |

			name := aNode name.
			( aNode whoDefines: name ) ifNil: [ self checkSendersAccessTo: name ]
			].
	searcher executeTree: aParseTree! !

!RBAddParameterRefactoring methodsFor: 'private' stamp: ''!
newSelectorString
	| stream keywords indexNewArgs |
	stream := WriteStream on: String new.
	keywords := newSelector keywords.
	indexNewArgs := 0.
	permutation
		doWithIndex: 
			[:each :index |
			stream nextPutAll: (keywords at: index).
			each < 0
				ifTrue: 
					[ indexNewArgs := indexNewArgs - 1.
					stream
						nextPut: $(;
						nextPutAll: (newArgs at: indexNewArgs * -1) value1;
						nextPut: $)]
				ifFalse: 
					[stream
						nextPutAll: ' ``@arg';
						nextPutAll: each printString].
			stream nextPut: $ ].
	^stream contents! !

!RBAddParameterRefactoring methodsFor: 'private' stamp: ''!
modifyImplementorParseTree: parseTree in: aClass
	| argNames index |
	argNames := newArgs collect: [ :arg | | newArg |
		newArg := self safeVariableNamed: arg newName for: aClass temporaries: (parseTree temporaryNames, parseTree argumentNames).
	index := 0.
		newArg ].
	parseTree 
		renameSelector: newSelector
		andArguments: ((permutation 
			collect: [ :e | parseTree argumentNames at: e ifAbsent: [ index := index +1.
				argNames at: index	] ]) 
				collect: [:e | RBVariableNode named: e ]).
	self renameArgumentsIn: parseTree.! !

!RBAddParameterRefactoring methodsFor: 'preconditions' stamp: ''!
verifyInitializationExpressionOf: initializer
	| tree |
	tree := self parserClass
		parseExpression: initializer
		onError: [ :msg :index | self refactoringFailure: 'Illegal initialization code because:.', msg ].
	tree isValue
		ifFalse: [ self refactoringFailure: 'The initialization code cannot be a return node or a list of statements' ].
	self checkVariableReferencesIn: tree.! !

!RBAddParameterRefactoring methodsFor: 'preconditions' stamp: ''!
checkSendersAccessTo: name

	(#('self' 'super') includes: name) ifTrue: [ ^ self ].
	self senders
		detect: [ :each | (self canReferenceVariable: name in: each) not ]
		ifFound: [ :violatorClass | 
			self
				refactoringError:
					('<1s> doesn''t appear to be defined in <2p>'
						expandMacrosWith: name
						with: violatorClass) ]! !

!RBAddParameterRefactoring methodsFor: 'private' stamp: ''!
safeVariableNamed: argName for: aClass temporaries: allTempVars 
	| baseString index newString |
	((allTempVars includes: argName) 
		or: [aClass definesInstanceVariable: argName]) ifFalse: [ ^ argName ].
	newString := baseString := 'anObject'.
	index := 0.
	
	[(allTempVars includes: newString) 
		or: [aClass definesInstanceVariable: newString]] 
			whileTrue: 
				[index := index + 1.
				newString := baseString , index printString].
	^newString! !

!RBAddParameterRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' addParameterToMethod: #';
		nextPutAll: oldSelector;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' newSelector: #';
		nextPutAll: newSelector;
		nextPutAll: ' permutation: ';
		nextPutAll: permutation asString;
		nextPutAll: ' newArgs: '''.
	newArgs storeOn: aStream.
	aStream
		nextPutAll: ''')'.! !

!RBAddParameterRefactoring class methodsFor: 'instance creation' stamp: ''!
addParameterToMethod: aSelector in: aClass newSelector: newSelector permutation: aColl1 newArgs: aColl2 
	^ self new 
		addParameterToMethod: aSelector
		in: aClass
		newSelector: newSelector
		permutation: aColl1
		newArgs: aColl2! !

!RBAddParameterRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk addParameterToMethod: aSelector in: aClass newSelector: newSelector permutation: aColl1 newArgs: aColl2 
	^ self new
		model: aRBSmalltalk;
		addParameterToMethod: aSelector
		in: aClass
		newSelector: newSelector
		permutation: aColl1
		newArgs: aColl2;
		yourself! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
senders

	senders
		ifNil: [ senders := Set new.
			self model allReferencesTo: oldSelector do: [ :each | senders add: each modelClass ]
			].
	^ senders! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
parseTreeRewriter
	| rewriteRule oldString newString |
	rewriteRule := self parseTreeRewriterClass new.
	oldString := self buildSelectorString: oldSelector.
	newString := self newSelectorString.
	rewriteRule replace: '``@object ' , oldString
		with: '``@object ' , newString.
	^rewriteRule! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
newArgs
	^ newArgs ifNil: [ newArgs := { } ]! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
myConditions
	^RBCondition withBlock: 
		[oldSelector numArgs < newSelector numArgs 
			ifFalse: 
				[self refactoringFailure: newSelector printString, 
				' doesn''t have the proper number of arguments.'].
		self newArgs do: [	:arg | self verifyInitializationExpressionOf: arg value1 ].
		true]! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
addParameterToMethod: aSelector in: aClass newSelector: newSel permutation: aColl1 newArgs: aColl2
	self 
		renameMethod: aSelector
		in: aClass
		to: newSel
		permutation: aColl1.
	newArgs := aColl2.! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
safeVariableNameFor: aClass temporaries: allTempVars 
	| baseString index newString |
	newString := baseString := 'anObject'.
	index := 0.
	
	[(allTempVars includes: newString) 
		or: [aClass definesInstanceVariable: newString]] 
			whileTrue: 
				[index := index + 1.
				newString := baseString , index printString].
	^newString! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
renameArgumentsIn: parseTree
	| newArgNames |
	newArgNames := newArgs collect: [ :arg | arg name ].	
	self renameMap do: [ :arg |
		(newArgNames includes: arg name) ifFalse: [ 
		(self parseTreeRewriterClass rename: arg name to: arg newName) executeTree: parseTree
	] ]! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
checkVariableReferencesIn: aParseTree

	| searcher |

	searcher := self parseTreeSearcher.
	searcher
		matches: '`var'
		do: [ :aNode :answer | 
			| name |

			name := aNode name.
			( aNode whoDefines: name ) ifNil: [ self checkSendersAccessTo: name ]
			].
	searcher executeTree: aParseTree! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
newSelectorString
	| stream keywords indexNewArgs |
	stream := WriteStream on: String new.
	keywords := newSelector keywords.
	indexNewArgs := 0.
	permutation
		doWithIndex: 
			[:each :index |
			stream nextPutAll: (keywords at: index).
			each < 0
				ifTrue: 
					[ indexNewArgs := indexNewArgs - 1.
					stream
						nextPut: $(;
						nextPutAll: (newArgs at: indexNewArgs * -1) value1;
						nextPut: $)]
				ifFalse: 
					[stream
						nextPutAll: ' ``@arg';
						nextPutAll: each printString].
			stream nextPut: $ ].
	^stream contents! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
modifyImplementorParseTree: parseTree in: aClass
	| argNames index |
	argNames := newArgs collect: [ :arg | | newArg |
		newArg := self safeVariableNamed: arg newName for: aClass temporaries: (parseTree temporaryNames, parseTree argumentNames).
	index := 0.
		newArg ].
	parseTree 
		renameSelector: newSelector
		andArguments: ((permutation 
			collect: [ :e | parseTree argumentNames at: e ifAbsent: [ index := index +1.
				argNames at: index	] ]) 
				collect: [:e | RBVariableNode named: e ]).
	self renameArgumentsIn: parseTree.! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
verifyInitializationExpressionOf: initializer
	| tree |
	tree := self parserClass
		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.! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
checkSendersAccessTo: name

	(#('self' 'super') includes: name) ifTrue: [ ^ self ].
	self senders
		detect: [ :each | (self canReferenceVariable: name in: each) not ]
		ifFound: [ :violatorClass | 
			self
				refactoringError:
					('<1s> doesn''t appear to be defined in <2p>'
						expandMacrosWith: name
						with: violatorClass) ]! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
safeVariableNamed: argName for: aClass temporaries: allTempVars 
	| baseString index newString |
	((allTempVars includes: argName) 
		or: [aClass definesInstanceVariable: argName]) ifFalse: [ ^ argName ].
	newString := baseString := 'anObject'.
	index := 0.
	
	[(allTempVars includes: newString) 
		or: [aClass definesInstanceVariable: newString]] 
			whileTrue: 
				[index := index + 1.
				newString := baseString , index printString].
	^newString! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' addParameterToMethod: #';
		nextPutAll: oldSelector;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' newSelector: #';
		nextPutAll: newSelector;
		nextPutAll: ' permutation: ';
		nextPutAll: permutation asString;
		nextPutAll: ' newArgs: '''.
	newArgs storeOn: aStream.
	aStream
		nextPutAll: ''')'.! !

!RBAddParameterTransformation methodsFor: 'adding' stamp: ''!
canReferenceVariable: aString in: aClass 
	(aClass definesVariable: aString) ifTrue: [^true].
	(self model includesGlobal: aString asSymbol) ifTrue: [^true].
	^(self poolVariableNamesFor: aClass) includes: aString! !

!RBAddParameterTransformation class methodsFor: 'adding' stamp: ''!
addParameterToMethod: aSelector in: aClass newSelector: newSelector permutation: aColl1 newArgs: aColl2 
	^ self new 
		addParameterToMethod: aSelector
		in: aClass
		newSelector: newSelector
		permutation: aColl1
		newArgs: aColl2! !

!RBAddParameterTransformation class methodsFor: 'adding' stamp: ''!
model: aRBSmalltalk addParameterToMethod: aSelector in: aClass newSelector: newSelector permutation: aColl1 newArgs: aColl2 
	^ self new
		model: aRBSmalltalk;
		addParameterToMethod: aSelector
		in: aClass
		newSelector: newSelector
		permutation: aColl1
		newArgs: aColl2;
		yourself! !

!RBAddPoolVariableChange commentStamp: ''!
I am a refactoring for a pool  variable addition. My changes are executed on the instance side.!
!RBAddPoolVariableChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ changeFactory
		  removePoolVariable: self variable
		  from: self changeClass! !

!RBAddPoolVariableChange methodsFor: 'accessing' stamp: ''!
changeClass: aBehavior

	super changeClass: aBehavior.
	isMeta := false! !

!RBAddPoolVariableChange methodsFor: 'private' stamp: ''!
changeSymbol

	^ #addSharedPoolNamed:! !

!RBAddPoolVariableChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Add pool variable <1s> to <2s>'
		  expandMacrosWith: self variable
		  with: self displayClassName! !

!RBAddPragmaTransformation commentStamp: ''!
I am responsible for adding a pragma inside a method. In this implementation, all pragma definition, e.g., '<selector: args>' must be described.

Usage:
| transformation |
transformation := (RBAddPragmaTransformation
				pragma: '<gtInspectorPresentationOrder: 213>'
				inMethod: #methodBefore
				inClass: #RBAddPragmaTransformationTest)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the class exists,
- the method exists, and
- the method does not have a pragma with the same selector. !
!RBAddPragmaTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition
		withBlock: [ self definingClass isNotNil ]
		errorString: ('Class named <1s> does not exist' expandMacrosWith: className))
		&
			(RBCondition
				withBlock: [ self definingClass canUnderstand: selector ]
				errorString: ('Method named <1s> does not exist' expandMacrosWith: selector))
		&
			(RBCondition
				withBlock: [ | pragmaNode |
					pragmaNode := self parserClass parsePragma: pragma.
					self definingMethod pragmas
						noneSatisfy: [ :e | e selector = pragmaNode selector ] ]
				errorString:
					('Method named <1s> already has a pragma named <2s>'
						expandMacrosWith: selector
						with: (self parserClass parsePragma: pragma) selector))! !

!RBAddPragmaTransformation methodsFor: 'api' stamp: ''!
pragma: aString inMethod: aSelector inClass: aClassName

	self className: aClassName.
	selector := aSelector.
	pragma := aString.! !

!RBAddPragmaTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' pragma: ''';
		nextPutAll: pragma;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBAddPragmaTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	"the transformation is straighforward: just add the node at the last position of the method.
	 #todo the case in which the context is a block"

	| methodTree pragmaNode |
	methodTree := self definingMethod.
	pragmaNode := self parserClass parsePragma: pragma.
	methodTree addPragma: pragmaNode.
	self definingClass compileTree: methodTree! !

!RBAddPragmaTransformation class methodsFor: 'api' stamp: ''!
pragma: aString inMethod: aSelector inClass: aClassName

	^ self new
		pragma: aString
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBAddPragmaTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel pragma: aString inMethod: aSelector inClass: aClassName

	^ self new
		model: aRBModel;
		pragma: aString
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBAddPragmaTransformationTest methodsFor: 'tests' stamp: ''!
testPragmaAlreadyExists

	self shouldFail: (RBAddPragmaTransformation
							pragma: '<gtInspectorPresentationOrder: 56>'
							inMethod: #methodAfter
							inClass: #RBAddPragmaTransformationTest)
							asRefactoring! !

!RBAddPragmaTransformationTest methodsFor: 'utilities' stamp: ''!
methodAfter
	<gtInspectorPresentationOrder: 56>

	| variable |
	variable := 'String'.! !

!RBAddPragmaTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBAddPragmaTransformation
						pragma: '<gtInspectorPresentationOrder: 56>'
						inMethod: #methodBefore
						inClass: #RBAddPragmaTransformationTest)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 1.
	
	class := refactoring model classNamed: #RBAddPragmaTransformationTest.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBAddPragmaTransformationTest methodsFor: 'utilities' stamp: ''!
methodBefore

	| variable |
	variable := 'String'.! !

!RBAddPragmaTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBAddPragmaTransformation new
		pragma: '<gtInspectorPresentationOrder: 56>'
		inMethod: #methodBefore
		inClass: self class name)
		transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self class name.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBAddPragmaTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBAddPragmaTransformation
							pragma: '<gtInspectorPresentationOrder: 56>'
							inMethod: #method
							inClass: #RBAddPragmaTransformationTest)
							asRefactoring! !

!RBAddPragmaTransformationTest methodsFor: 'tests' stamp: ''!
testClassDoesNotExist

	self shouldFail: (RBAddPragmaTransformation
							pragma: '<gtInspectorPresentationOrder: 56>'
							inMethod: #methodBefore
							inClass: #RBPragmaTransformationTest)
							asRefactoring ! !

!RBAddProtocolChange commentStamp: ''!
RBRefactoryProtocolChange is responsible for adding a protocol in classes in a RB model!
!RBAddProtocolChange methodsFor: 'converting' stamp: ''!
asUndoOperation
	
	^ RBRemoveProtocolChange removeProtocolNamed: protocol in: self changeClass! !

!RBAddProtocolChange methodsFor: 'printing' stamp: ''!
printOn: aStream 

	aStream
		nextPutAll: self displayClassName;
		nextPutAll: ' addProtocolNamed: ';
		print: ( self displayProtocolName );
		nextPutAll: ' stamp: ';
		print: (self changeStamp);
		nextPutAll: '!!'! !

!RBAddProtocolChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Add Protocol named ', self displayProtocolName, ' in ', self displayClassName! !

!RBAddProtocolChange methodsFor: 'private' stamp: ''!
primitiveExecute

	self changeClass organization addCategory: protocol! !

!RBAddProtocolChange class methodsFor: 'instance creation' stamp: ''!
addProtocolNamed: aString in: aClass

	^ self new
		changeClass: aClass;
		protocol: aString;
		yourself! !

!RBAddProtocolTransformation commentStamp: ''!
I am responsible to add a protocol to a class.

Usage:
| transformation |
transformation := (RBAddProtocolTransformation
				protocol: 'transforming'
				inClass: #RBDummyEmptyClass)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- The class exists;
- The protocol name is a valid name.!
!RBAddProtocolTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ ( RBCondition
			withBlock: [ self definingClass isNotNil ]
			errorString: 'Class named ', className, ' does not exist' )
	  & ( RBCondition withBlock: [ (( model environment 
			protocolsFor: self definingClass realClass )
			includes: protocol ) not ]
			errorString: 'Protocol named ', protocol, ' already exists' )! !

!RBAddProtocolTransformation methodsFor: 'api' stamp: ''!
protocol: aString inClass: aClassName

	self className: aClassName.
	protocol := aString! !

!RBAddProtocolTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' protocol: ''';
		nextPutAll: protocol;
		nextPutAll: ''' inClass: ''';
		nextPutAll: className.
	aStream nextPut: $)! !

!RBAddProtocolTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self definingClass addProtocolNamed: protocol! !

!RBAddProtocolTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel protocol: aString inClass: aClassName

	^ self new
		model: aRBModel;
		protocol: aString
		inClass: aClassName;
		yourself! !

!RBAddProtocolTransformation class methodsFor: 'api' stamp: ''!
protocol: aString inClass: aClassName

	^ self new
		protocol: aString
		inClass: aClassName;
		yourself! !

!RBAddReturnStatementTransformation commentStamp: ''!
I am responsible for adding a return statement inside a method. In this implementation, all the return value (including the '^') shall be described.

Usage: 
| transformation |
transformation := (RBAddReturnStatementTransformation
				return: '^ variable'
				inMethod: #methodBefore
				inClass: #RBAddReturnStatementTransformationTest)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the method does not have a return statement

Observations about the transformation:
- The transformation is straightforward: parse the return value and add the resulting node to the end of the method!
!RBAddReturnStatementTransformation methodsFor: 'api' stamp: ''!
return: anExpression inMethod: aSelector inClass: aClassName

	self className: aClassName.
	selector := aSelector.
	returnValue := anExpression! !

!RBAddReturnStatementTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition
		withBlock: [ self definingClass isNotNil ]
		errorString: ('Class named <1s> does not exist' expandMacrosWith: className))
		&
			(RBCondition
				withBlock: [ self definingClass canUnderstand: selector ]
				errorString: ('Method named <1s> does not exist' expandMacrosWith: selector))
		&
			(RBCondition
				withBlock: [ self definingMethod lastIsReturn not ]
				errorString:
					('Method named <1s> already has a return statement'
						expandMacrosWith: selector))
		&
			(RBCondition
				withBlock: [ | returnNode |
					returnNode := self parserClass parseExpression: returnValue.
					returnNode allVariables
						allSatisfy: [ :e | 
							(self definingMethod hasArgumentNamed: e name)
								or: [ self definingMethod hasTemporaryNamed: e name ] ] ]
				errorString:
					('Some variables in this return statement are not defined in method named <1s>.'
						expandMacrosWith: selector))! !

!RBAddReturnStatementTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' return: ''';
		nextPutAll: returnValue;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBAddReturnStatementTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	"the transformation is straighforward: just add the node at the last position of the method.
	 #todo the case in which the context is a block"

	| methodTree messageNode |
	methodTree := self definingMethod.
	messageNode := self parserClass parseExpression: returnValue.
	methodTree body addNode: messageNode.
	self definingClass compileTree: methodTree! !

!RBAddReturnStatementTransformation class methodsFor: 'api' stamp: ''!
return: aString inMethod: aSelector inClass: aClassName

	^ self new
		return: aString
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBAddReturnStatementTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel return: aString inMethod: aSelector inClass: aClassName

	^ self new
		model: aRBModel;
		return: aString
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBAddReturnStatementTransformationTest methodsFor: 'utilities' stamp: ''!
methodAfter

	| variable |
	variable := 'String'.
	^ variable! !

!RBAddReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testAlreadyDefinesReturn

	self shouldFail: (RBAddReturnStatementTransformation 
							return: '^ variable'
							inMethod: #methodAfter
							inClass: #RBAddReturnStatementTransformationTest)
							asRefactoring ! !

!RBAddReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBAddReturnStatementTransformation
						return: '^ variable'
						inMethod: #methodBefore
						inClass: #RBAddReturnStatementTransformationTest)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 1.
	
	class := refactoring model classNamed: #RBAddReturnStatementTransformationTest.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBAddReturnStatementTransformationTest methodsFor: 'utilities' stamp: ''!
methodBefore

	| variable |
	variable := 'String'.! !

!RBAddReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testAccessIsNotDefined

	self shouldFail: (RBAddReturnStatementTransformation 
							return: '^ variable2'
							inMethod: #methodBefore
							inClass: #RBAddReturnStatementTransformationTest)
							asRefactoring! !

!RBAddReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBAddReturnStatementTransformation new
		return: '^ variable'
		inMethod: #methodBefore
		inClass: self class name)
		transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self class name.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBAddReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBAddReturnStatementTransformation
							return: '^ variable'
							inMethod: #method
							inClass: #RBAddReturnStatementTransformationTest)
							asRefactoring ! !

!RBAddReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testClassDoesNotExist

	self shouldFail: (RBAddReturnStatementTransformation
							return: '^ variable'
							inMethod: #methodBefore
							inClass: #RBReturnStatementTransformationTest)
							asRefactoring ! !

!RBAddSubtreeTransformation commentStamp: ''!
Adds a subtree inside a method. It is required an interval indicating where the subtree shall be added. If the interval is invalid, the new subtree will be added at the end of the mehtod body (or before the return node, if it exists).

Usage:
| transformation |
transformation := (RBAddSubtreeTransformation
		interval: (0 to: 1)
		with: '^ selector'
		from: #selector:from:
		in: #RBRemoveMethodTransformation)
		transform. 
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the class and method exist
- the code from which the subtree will be extracted is parseable!
!RBAddSubtreeTransformation methodsFor: 'utilities' stamp: ''!
addNode: aRBNode toSequence: aSequenceNode
	"Searches for the statement before which the new code should be added.
	 If not found, it just adds the new code at the end of the block"
	
	aSequenceNode statements
		detect: [ :node | node intersectsInterval: interval ]
		ifFound: [ :node |
						node isBlock "special case when a block is empty"
							ifTrue: [ node body addNode: aRBNode ]
							ifFalse: [ aSequenceNode addNode: aRBNode before: node ]].
	^ aSequenceNode methodNode! !

!RBAddSubtreeTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition definesSelector: selector in: self definingClass)
		&
			(RBCondition
				withBlock: [ self parserClass
						parseExpression: sourceCode
						onError:
							[ :string :pos | self refactoringError: 'Invalid source to add - ' , string ].
					true ])! !

!RBAddSubtreeTransformation methodsFor: 'api' stamp: ''!
interval: anInterval with: aString from: aSelector in: aClass

	self className: aClass.
	selector := aSelector.
	interval := anInterval.
	sourceCode := aString.! !

!RBAddSubtreeTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	| parseTree newNode |
	parseTree := self definingClass parseTreeFor: selector.
	parseTree ifNil: [ ^ self ].
	newNode := self parserClass
		parseExpression: sourceCode
		onError: [ :string :pos | ^ self ].

	"The method is empty, then just add the new code"
	parseTree body statements
		ifEmpty: [ parseTree addNode: newNode.
			^ self ].

	"It tries to find the block to insert new code.
	 If not found, e.g., the interval is invalid, it adds the code at the end."
	parseTree := parseTree allSequenceNodes
		detect: [ :sequence | sequence intersectsInterval: interval ]
		ifFound: [ :sequence | self addNode: newNode toSequence: sequence ]
		ifNone: [ parseTree body addNodeLast: newNode.
			parseTree ].
	self definingClass compileTree: parseTree! !

!RBAddSubtreeTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' interval: ''';
		nextPutAll: interval asString;
		nextPutAll: ' with: ''';
		nextPutAll: sourceCode;
		nextPutAll: ''' from: ''';
		nextPutAll: selector;
		nextPutAll: ''' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBAddSubtreeTransformation class methodsFor: 'api' stamp: ''!
interval: anInterval with: aString from: aSelector in: aClass

	^ self new
		interval: anInterval
		with: aString
		from: aSelector
		in: aClass;
		yourself! !

!RBAddSubtreeTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel interval: anInterval with: aString from: aSelector in: aClass

	^ self new
		model: aRBModel;
		interval: anInterval
		with: aString
		from: aSelector
		in: aClass;
		yourself! !

!RBAddSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testParseFailure
	| transformation |
	transformation := (RBAddSubtreeTransformation
		interval: (0 to: 1)
		with: ':= 123'
		from: #one
		in: self changeMock name) transform.

	self assertEmpty: transformation model changes changes! !

!RBAddSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	self 
		shouldFail: (RBAddSubtreeTransformation
							interval: (0 to: 1)
							with: ':= 123'
							from: #selector:from:
							in: #RBRemoveMethodTransformation)
							asRefactoring;
		shouldFail: (RBAddSubtreeTransformation
							interval: (0 to: 1)
							with: '^ selector'
							from: #selector:for:
							in: #RBRemoveMethodTransformation)
							asRefactoring! !

!RBAddSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBAddSubtreeTransformation
		interval: (0 to: 1)
		with: 'self printString'
		from: #one
		in: self changeMock name)
		transform. 
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self changeMock name asSymbol.
	self assert: (class directlyDefinesMethod: #one).
	self assert: (class parseTreeFor: #one) body statements size equals: 2! !

!RBAddSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist
	| transformation |
	transformation := (RBAddSubtreeTransformation
		interval: (0 to: 1)
		with: 'self printString'
		from: #two
		in: self changeMock name) transform.

	self assertEmpty: transformation model changes changes! !

!RBAddTemporaryVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testVariableAlreadyExists

	self shouldFail: (self createRefactoringWithArguments:
		{'variable' . #methodBefore . #RBAddReturnStatementTransformationTest })! !

!RBAddTemporaryVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testAddTemporaryRefactoring

	| refactoring class |
	refactoring := (self createRefactoringWithArguments:
		{ 'variable2' . #methodBefore . #RBAddReturnStatementTransformationTest }).
	self executeRefactoring: refactoring.
	
	self assert: refactoring model changes changes size equals: 1.
	
	class := refactoring model classNamed: #RBAddReturnStatementTransformationTest.
	self assert: (class directlyDefinesMethod: #methodBefore).
	self assert: (class parseTreeFor: #methodBefore) temporaries size equals: 2! !

!RBAddTemporaryVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (self createRefactoringWithArguments: 
		{ 'variable2' . #method . #RBAddReturnStatementTransformationTest })! !

!RBAddTemporaryVariableParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #variable:inMethod:inClass:! !

!RBAddTemporaryVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testClassDoesNotExist

	self shouldFail: (self createRefactoringWithArguments: 
		{ 'variable2' . #methodBefore . #RBReturnStatementTransformationTest })! !

!RBAddTemporaryVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBAddTemporaryVariableTransformation };
		yourself! !

!RBAddTemporaryVariableTransformation commentStamp: ''!
I am responsible for adding a temporary variable inside a method. In Pharo, temporary variables can be declared inside blocks as well. By default, the container is the method itself.

Usage: 
| transformation |
transformation := (RBAddTemporaryVariableTransformation
			variable: #newVariable
			inMethod: #methodBefore
			inClass: #RBAddReturnStatementTransformationTest)
			transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- Check whether there is a variable inside the method with the same name.

Observations about the transformation:
- In this implementation, the temporary variable will be added to the body of the method!
!RBAddTemporaryVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ ( RBCondition
			withBlock: [ self definingClass isNotNil ]
			errorString: 'No such class or trait named ', className )
		& ( RBCondition definesSelector: selector in: self definingClass)
		& ( RBCondition
			withBlock: [ (self definingMethod allTemporaryVariables includes: variableName) not ]
			errorString: 'Method named ', selector, ' already defines a temporary variable named ', variableName )
		& ( RBCondition
			withBlock: [ (self definingMethod allArgumentVariables includes: variableName) not ]
			errorString: 'Method named ', selector, ' already defines an argument named ', variableName )! !

!RBAddTemporaryVariableTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName inInterval: anInterval inMethod: aSelector inClass: aClass

	self className: aClass.
	interval := anInterval.
	selector := aSelector.
	variableName := aVariableName! !

!RBAddTemporaryVariableTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName inMethod: aSelector inClass: aClass

	self
		variable: aVariableName
		inInterval: nil
		inMethod: aSelector
		inClass: aClass! !

!RBAddTemporaryVariableTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' variable: ''';
		nextPutAll: variableName;
		nextPutAll: ''' inInterval: ''';
		nextPutAll: interval;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBAddTemporaryVariableTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	| methodTree parseTree |
	methodTree := self definingMethod.
	parseTree := methodTree body.
	
	interval ifNotNil: [ 
		| nodeInInterval |
		nodeInInterval := methodTree bestNodeFor: interval.
		nodeInInterval isSequence ifTrue: [ parseTree := nodeInInterval ] ].
	
	parseTree addTemporaryNamed: variableName.
	class compileTree: methodTree! !

!RBAddTemporaryVariableTransformation class methodsFor: 'api' stamp: ''!
variable: aString inInterval: anInterval inMethod: aSelector inClass: aClass

	^ self new
		variable: aString
		inInterval: anInterval
		inMethod: aSelector
		inClass: aClass;
		yourself! !

!RBAddTemporaryVariableTransformation class methodsFor: 'api' stamp: ''!
variable: aString inMethod: aSelector inClass: aClass

	^ self new
		variable: aString
		inMethod: aSelector
		inClass: aClass;
		yourself! !

!RBAddTemporaryVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel variable: aString inMethod: aSelector inClass: aClass

	^ self new
		model: aRBModel;
		variable: aString
		inMethod: aSelector
		inClass: aClass;
		yourself! !

!RBAddTraitChange commentStamp: ''!
I am a refactoring change for a trait addition. Executing this change will create a new trait, just like the ordinary
Trait named: ... call.
At the moment there is no support for the traitcomposition attribute.!
!RBAddTraitChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	| trait |
	trait := onSystemDictionary classOrTraitNamed: self changeClassName.
	^ trait isTrait
		  ifTrue: [ changeFactory addTraitDefinition: trait oldDefinition ]
		  ifFalse: [ changeFactory removeClassNamed: self changeClassName ]! !

!RBAddTraitChange methodsFor: 'accessing' stamp: ''!
category

	^ category! !

!RBAddTraitChange methodsFor: 'initialization' stamp: ''!
fillOutDefinition: aDictionary

	className := (aDictionary at: '`#traitName') asSymbol.
	category := (aDictionary at: '`#package' ifAbsent: [ #Unclassified ]) asSymbol! !

!RBAddTraitChange methodsFor: 'private' stamp: ''!
definitionClass

	^ Trait! !

!RBAddTraitChange class methodsFor: 'private' stamp: ''!
definitionPatterns

	^ #('Trait named: `#traitName uses: `@traitComposition package: `#package' 'Trait named: `#traitName uses: `@traitComposition slots: `@slotDefinition package: `#package'
	
 'Trait named: `#traitName uses: `@traitComposition instanceVariableNamed: `@instanceVars package: `#package'
	
'Trait named: `#traitName instanceVariableNames: `@instanceVars package: `#package'
	
	'Trait named: `#traitName package: `#package'
	
	'Trait << `#traitName package: `#package'
	'Trait << `#traitName uses: `@traitComposition package: `#package'
	'Trait << `#traitName slots: `@slotDefinition package: `#package'
	'Trait << `#traitName slots: `@slotDefinition package: `#package'
	 )! !

!RBAddVariableAccessorTransformation commentStamp: ''!
Adds accessors (getter and setter) for a variable in a class, if they do not exist.

Usage:
| transformation |
transformation := (RBAddVariableAccessorTransformation
	variable: 'variableName'
	class: #RBVariableTransformation
	classVariable: false)
	transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the variable with which the accessors will be created shall exist. The parameter isClassVariable indicates whether to look in the instance or class variables.!
!RBAddVariableAccessorTransformation methodsFor: 'private' stamp: ''!
defineSetterMethod

	|  sourceCode |
	sourceCode := '<1s> anObject<r><r><t><2s> := anObject'.
	setterMethod := self safeMethodNameFor: self definingClass basedOn: variableName asString , ':'.
	self definingClass 
		compile: (sourceCode expandMacrosWith: setterMethod with: variableName)
		classified: #accessing.
	^setterMethod! !

!RBAddVariableAccessorTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	class := self model classObjectFor: className.

	^ isClassVariable 
		ifTrue: [RBCondition definesClassVariable: variableName asSymbol in: class]
		ifFalse: [RBCondition definesInstanceVariable: variableName in: class]! !

!RBAddVariableAccessorTransformation methodsFor: 'private' stamp: ''!
defineGetterMethod

	getterMethod := self safeMethodNameFor: self definingClass basedOn: variableName asString.
	self definingClass 
		compile: ('<1s><r><r><t>^ <2s>' expandMacrosWith: getterMethod with: variableName)
		classified: #(#accessing).
	^ getterMethod! !

!RBAddVariableAccessorTransformation methodsFor: 'private' stamp: ''!
createSetterAccessor

	(self definingClass setterMethodFor: variableName) ifNil: [ self defineSetterMethod ]! !

!RBAddVariableAccessorTransformation methodsFor: 'private' stamp: ''!
createGetterAccessor

	(self definingClass getterMethodFor: variableName) ifNil: [ self defineGetterMethod ]! !

!RBAddVariableAccessorTransformation methodsFor: 'private' stamp: ''!
safeMethodNameFor: aClass basedOn: aString 
	"Creates an unused method name containing aString"

	| baseString newString hasParam i |
	baseString := aString copy.
	baseString at: 1 put: baseString first asLowercase.
	newString := baseString.
	hasParam := newString last = $:.
	hasParam 
		ifTrue: [baseString := newString copyFrom: 1 to: newString size - 1].
	i := 0.
	[aClass hierarchyDefinesMethod: newString asSymbol] whileTrue: 
			[i := i + 1.
			newString := baseString , i printString 
						, (hasParam ifTrue: [':'] ifFalse: [''])].
	^newString asSymbol! !

!RBAddVariableAccessorTransformation methodsFor: 'private' stamp: ''!
setterMethod
	^ setterMethod! !

!RBAddVariableAccessorTransformation methodsFor: 'private' stamp: ''!
getterMethod
	^ getterMethod ! !

!RBAddVariableAccessorTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self
		createGetterAccessor;
		createSetterAccessor! !

!RBAddVariableAccessorWithLazyInitializationTransformation commentStamp: ''!
I am a transformation to create accessors with lazy initialization for variables.

My precondition is that the variable name is defined for this class.

Example
--------
Script
```
(RBAddVariableAccessorWithLazyInitialization 
	variable: 'foo1' 
	class: RBLintRuleTestData 
	classVariable: false 
	defaultValue: '123') execute
```

After refactoring we get:
```
RBLintRuleTestData >> foo1 
	^ foo1 ifNil: [foo1 := 123]
	
RBLintRuleTestData >> foo1: anObject
	foo1 := anObject
```!
!RBAddVariableAccessorWithLazyInitializationTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^ super preconditions & 
	(RBCondition withBlock: [ 
		self verifyInitializationExpressionOf: self defaultValue.
		true ])! !

!RBAddVariableAccessorWithLazyInitializationTransformation methodsFor: 'accessing' stamp: ''!
defaultValue
	^ defaultValue ifNil: [ defaultValue := 'nil' ]! !

!RBAddVariableAccessorWithLazyInitializationTransformation methodsFor: 'transforming' stamp: ''!
defineGetterMethod

	^ self defineGetterCalled: self getterMethod! !

!RBAddVariableAccessorWithLazyInitializationTransformation methodsFor: 'transforming' stamp: ''!
defineGetterCalled: aSymbol 

	| selector |
	selector := aSymbol.
	self definingClass 
		compile:  ('<1s><r><r><t>^ <2s> ifNil: [ <2s> := <3s> ]' 
			expandMacrosWith: selector 
			with: variableName
			with: self defaultValue)
		classified: #(#accessing).
	^ selector! !

!RBAddVariableAccessorWithLazyInitializationTransformation methodsFor: 'preconditions' stamp: ''!
checkVariableReferencesIn: aParseTree

	| searcher |

	searcher := self parseTreeSearcher.
	searcher
		matches: '`var'
		do: [ :aNode :answer | 
			| name |

			name := aNode name.
			( aNode whoDefines: name ) ifNil: [ self canReferenceVariable: name in: class  ]
			].
	searcher executeTree: aParseTree! !

!RBAddVariableAccessorWithLazyInitializationTransformation methodsFor: 'private' stamp: ''!
createGetterAccessor

	(self definingClass getterMethodFor: variableName) 
		ifNil: [ self defineGetterMethod ]
		ifNotNil: [ :symbol | self defineGetterCalled: symbol ]! !

!RBAddVariableAccessorWithLazyInitializationTransformation methodsFor: 'preconditions' stamp: ''!
verifyInitializationExpressionOf: initializer
	| tree |
	tree := self parserClass
		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.! !

!RBAddVariableAccessorWithLazyInitializationTransformation methodsFor: 'accessing' stamp: ''!
getterMethod 
	^ self safeMethodNameFor: self definingClass basedOn: variableName asString! !

!RBAddVariableAccessorWithLazyInitializationTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' variable: '.
	variableName storeOn: aStream.
	aStream nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream nextPutAll: ' classVariable: '.
	isClassVariable storeOn: aStream.
	aStream nextPutAll: ' defaultValue: '.
	defaultValue storeOn: aStream.
	aStream nextPut: $)! !

!RBAddVariableAccessorWithLazyInitializationTransformation methodsFor: 'accessing' stamp: ''!
defaultValue: aString
	defaultValue := aString! !

!RBAddVariableAccessorWithLazyInitializationTransformation class methodsFor: 'api' stamp: ''!
variable: aVarName class: aClass classVariable: aBoolean defaultValue: aString

	^(self variable: aVarName class: aClass classVariable: aBoolean)
		defaultValue: aString;
		yourself! !

!RBAddVariableAccessorWithLazyInitializationTransformation class methodsFor: 'api' stamp: ''!
model: aRBSmalltalk variable: aVarName class: aClass classVariable: aBoolean defaultValue: aString

	^(self model: aRBSmalltalk variable: aVarName class: aClass classVariable: aBoolean)
		defaultValue: aString;
		yourself! !

!RBAddVariableAccessorsParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantInstanceVariable

	self shouldFail: (rbClass 
		instanceVariable: 'foo'
		class: #RBBasicLintRuleTestData) asRefactoring! !

!RBAddVariableAccessorsParametrizedTest methodsFor: 'tests' stamp: ''!
testNewClassVariableAccessors
	| refactoring class |
	refactoring := rbClass 
		classVariable: 'Foo1' 
		class: #RBLintRuleTestData.
		
	self executeRefactoring: refactoring asRefactoring.
	
	class := refactoring model metaclassNamed: #RBLintRuleTestData.
	self denyEmpty: refactoring changes changes.
	self assert: (class parseTreeFor: #foo1) equals: (self parseMethod: 'foo1 ^Foo1').
	self assert: (class parseTreeFor: #foo1:) equals: (self parseMethod: 'foo1: anObject Foo1 := anObject')! !

!RBAddVariableAccessorsParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantClassVariable

	self shouldFail: (rbClass 
		classVariable: 'Foo'
		class: #RBBasicLintRuleTestData) asRefactoring! !

!RBAddVariableAccessorsParametrizedTest methodsFor: 'tests' stamp: ''!
testExistingInstanceVariableAccessors
	| refactoring |
	refactoring := rbClass 
		instanceVariable: 'name' 
		class: #RBLintRuleTestData.
	
	self executeRefactoring: refactoring asRefactoring.
	
	self assertEmpty: refactoring changes changes.! !

!RBAddVariableAccessorsParametrizedTest methodsFor: 'tests' stamp: ''!
testNewInstanceVariableAccessors
	| refactoring class |
	refactoring := rbClass 
		instanceVariable: 'foo1' 
		class: #RBLintRuleTestData.
		
	self executeRefactoring: refactoring asRefactoring.
	
	class := refactoring model classNamed: #RBLintRuleTestData.
	self denyEmpty: refactoring changes changes.
	self assert: (class parseTreeFor: #foo1) equals: (self parseMethod: 'foo1 ^foo1').
	self assert: (class parseTreeFor: #foo1:) equals: (self parseMethod: 'foo1: anObject foo1 := anObject')! !

!RBAddVariableAccessorsParametrizedTest methodsFor: 'tests' stamp: ''!
testExistingClassVariableAccessors
	| refactoring |
	refactoring := rbClass 
		classVariable: 'Name1' 
		class: #RBLintRuleTestData.
							
	self executeRefactoring: refactoring asRefactoring.
	
	self assertEmpty: refactoring changes changes.! !

!RBAddVariableAccessorsParametrizedTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self abstractVariableTestData.! !

!RBAddVariableAccessorsParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBCreateAccessorsForVariableRefactoring };
		addCase: { #rbClass -> RBAddVariableAccessorTransformation };
		yourself! !

!RBAddVariableAccessorsWithLazyInitializationParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName

	self
		shouldFail: (self createRefactoringWithArguments: 
			{ #Foo . RBBasicLintRuleTestData . true . nil });
		shouldFail: (self createRefactoringWithArguments: 
			{'foo' . RBBasicLintRuleTestData . true . nil })! !

!RBAddVariableAccessorsWithLazyInitializationParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadInitializationCode
	self shouldFail: (self createRefactoringWithArguments: 
		{'Foo1' . RBLintRuleTestData . true . 'foo:'})! !

!RBAddVariableAccessorsWithLazyInitializationParametrizedTest methodsFor: 'tests' stamp: ''!
testNewClassVariableAccessors
	| ref class |
	ref := self createRefactoringWithArguments:  
		{'Foo1' . RBLintRuleTestData . true . '''someString'''}.
	self executeRefactoring: ref.
	class := ref model metaclassNamed: #RBLintRuleTestData.
	self denyEmpty: ref changes changes.
	self assert: (class parseTreeFor: #foo1) equals: (self parseMethod: 'foo1 ^Foo1 ifNil: [ Foo1 := ''someString'' ]').
	self assert: (((class parseTreeFor: #foo1:) = (self parseMethod: 'foo1: anObject ^ Foo1 := anObject')) 
		or: [ (class parseTreeFor: #foo1:) = (self parseMethod: 'foo1: anObject Foo1 := anObject') ])! !

!RBAddVariableAccessorsWithLazyInitializationParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #variable:class:classVariable:defaultValue:! !

!RBAddVariableAccessorsWithLazyInitializationParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadInitializationCode1
	self shouldFail: (self createRefactoringWithArguments: 
		{'Foo1' . RBLintRuleTestData . true . '''string'})! !

!RBAddVariableAccessorsWithLazyInitializationParametrizedTest methodsFor: 'tests' stamp: ''!
testExistingInstanceVariableAccessors
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ 'name' . RBLintRuleTestData . false . nil }.
	class := refactoring model classNamed: #RBLintRuleTestData.
	self assert: (class parseTreeFor: #name) 
		equals: (self parseMethod: 'name ^name').
	self executeRefactoring: refactoring.
	self assert: (class parseTreeFor: #name) 
		equals: (self parseMethod: 'name ^name ifNil: [name := nil]').! !

!RBAddVariableAccessorsWithLazyInitializationParametrizedTest methodsFor: 'tests' stamp: ''!
testNewInstanceVariableAccessors
	| ref class |
	ref := self createRefactoringWithArguments: 
		{'foo1' . RBLintRuleTestData . false . '123'}.
	self executeRefactoring: ref.
	class := ref model classNamed: #RBLintRuleTestData.
	self denyEmpty: ref changes changes.
	self assert: (class parseTreeFor: #foo1) equals: (self parseMethod: 'foo1 ^foo1 ifNil: [foo1 := 123]').
	self assert: (class parseTreeFor: #foo1:) equals: (self parseMethod: 'foo1: anObject foo1 := anObject')! !

!RBAddVariableAccessorsWithLazyInitializationParametrizedTest methodsFor: 'tests' stamp: ''!
testExistingClassVariableAccessors
	| refactoring class |
	
	refactoring := self createRefactoringWithArguments:
		{ 'Name1' . RBLintRuleTestData . true . nil }.
	class := refactoring model classNamed: #RBLintRuleTestData.
	self assert: (class classSide parseTreeFor: #name1) 
		equals: (self parseMethod: 'name1 ^Name1').
	self executeRefactoring: refactoring.
	self assert: (class classSide parseTreeFor: #name1) 
		equals: (self parseMethod: 'name1 ^Name1 ifNil: [Name1 := nil]').! !

!RBAddVariableAccessorsWithLazyInitializationParametrizedTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self abstractVariableTestData.! !

!RBAddVariableAccessorsWithLazyInitializationParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBCreateAccessorsWithLazyInitializationForVariableRefactoring };
		addCase: { #rbClass -> RBAddVariableAccessorWithLazyInitializationTransformation };
		yourself! !

!RBAddVariableTransformation commentStamp: ''!
Adds a variable in a class. It is necessary to indicate whether the variable is an instance or class variable.

Usage:
| transformation |
transformation := (RBAddVariableTransformation 
	variable: 'asdf'
	class: #RBVariableTransformation
	classVariable: false)
	transform. 
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the variable name should not be a class name
- the class (and any class in the hierarchy) should not have a variable with the same name!
!RBAddVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	class := self definingClass.
	
	^ (isClassVariable 
		ifTrue: [ (RBCondition isMetaclass: class)
					& (RBCondition isValidClassVarName: variableName for: class) ]
		ifFalse: [ (RBCondition isMetaclass: class) not
					& (RBCondition isValidInstanceVariableName: variableName for: class) ])
		& (RBCondition hierarchyOf: class definesVariable: variableName asString) not 
		& (RBCondition isGlobal: variableName in: self model) not! !

!RBAddVariableTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	
	isClassVariable
		ifTrue: [ self definingClass theNonMetaClass addClassVariable: variableName ]
		ifFalse: [ self definingClass addInstanceVariable: variableName ]! !

!RBAndEnvironment commentStamp: ''!
I am the combination of two RBEnvironments, a logical AND. That is: 
entity A is in this environment if it is in BOTH environment I am constructed from.

Do not construct instances of me directly, use method #& for two existing environments:
env1 & env2 -> a RBAndEnvironment.!
!RBAndEnvironment methodsFor: 'accessing' stamp: ''!
problemCount
	^environment isClassEnvironment 
		ifTrue: [self numberClasses]
		ifFalse: [super problemCount]! !

!RBAndEnvironment methodsFor: 'initialization' stamp: ''!
andedEnvironment: aBrowserEnvironment 
	otherEnvironment := aBrowserEnvironment! !

!RBAndEnvironment methodsFor: 'testing' stamp: ''!
includesCategory: aCategory 
	^(self classNamesFor: aCategory) isNotEmpty! !

!RBAndEnvironment methodsFor: 'testing' stamp: ''!
includesSelector: aSelector in: aClass 
	^(environment includesSelector: aSelector in: aClass) 
		and: [ self andedEnvironment includesSelector: aSelector in: aClass ]! !

!RBAndEnvironment methodsFor: 'printing' stamp: ''!
operator
	^ ' & '! !

!RBAndEnvironment methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass 
	^ (environment includesProtocol: aProtocol in: aClass)
		and: [ self andedEnvironment includesProtocol: aProtocol in: aClass ]! !

!RBAndEnvironment methodsFor: 'printing' stamp: ''!
printOn: aStream 
	environment printOn: aStream.
	aStream nextPutAll: self operator.
	self andedEnvironment printOn: aStream.! !

!RBAndEnvironment methodsFor: 'private' stamp: ''!
andedEnvironment
	^ otherEnvironment! !

!RBAndEnvironment methodsFor: 'accessing' stamp: ''!
classesDo: aBlock 
	environment 
		classesDo: [:each | (self includesClass: each) ifTrue: [aBlock value: each]]! !

!RBAndEnvironment methodsFor: 'accessing' stamp: ''!
packages
	^ environment packages & self andedEnvironment packages! !

!RBAndEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass 
	| doesntHaveSelectors |
	(environment includesClass: aClass) ifFalse: [^false].
	(self andedEnvironment includesClass: aClass) ifFalse: [^false].
	doesntHaveSelectors := true.
	environment selectorsForClass: aClass
		do: 
			[:each | 
			doesntHaveSelectors := false.
			(self andedEnvironment includesSelector: each in: aClass) ifTrue: [^true]].
	^doesntHaveSelectors! !

!RBAndEnvironment methodsFor: 'accessing' stamp: ''!
selectionIntervalFor: aString 
	| interval |
	interval := super selectionIntervalFor: aString.
	interval ifNotNil: [^interval].
	^ self andedEnvironment selectionIntervalFor: aString
! !

!RBAndEnvironment methodsFor: 'accessing' stamp: ''!
selectorsForClass: aClass do: aBlock 
	environment selectorsForClass: aClass
		do: 
			[:each | 
			(self andedEnvironment includesSelector: each in: aClass) 
				ifTrue: [aBlock value: each]]! !

!RBAndEnvironment methodsFor: 'testing' stamp: ''!
definesClass: aClass
	^ (environment definesClass: aClass) and: [ 
		self andedEnvironment definesClass: aClass ]! !

!RBAndEnvironment methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	environment storeOn: aStream.
	aStream nextPutAll: ' & '.
	self andedEnvironment storeOn: aStream.
	aStream nextPut: $)! !

!RBAndEnvironment methodsFor: 'testing' stamp: ''!
classes
	^ environment classes & self andedEnvironment classes! !

!RBAndEnvironment class methodsFor: 'instance creation' stamp: ''!
onEnvironment: anEnvironment and: anotherEnvironment 
	^(self onEnvironment: anEnvironment)
		andedEnvironment: anotherEnvironment;
		yourself! !

!RBArgumentName methodsFor: 'accessing' stamp: ''!
value: anObject

	value := anObject! !

!RBArgumentName methodsFor: 'accessing' stamp: ''!
canBeRemoved: anObject

	canBeRemoved := anObject! !

!RBArgumentName methodsFor: 'testing' stamp: ''!
hasNewName 
	^ self name ~= self newName! !

!RBArgumentName methodsFor: 'accessing' stamp: ''!
newName

	^ newName ifNil: [ newName := name ]! !

!RBArgumentName methodsFor: 'printing' stamp: ''!
printOn: aStream 

	aStream nextPutAll: self newName! !

!RBArgumentName methodsFor: 'accessing' stamp: ''!
newName: anObject

	newName := anObject! !

!RBArgumentName methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!RBArgumentName methodsFor: 'accessing' stamp: ''!
name: anObject

	name := anObject! !

!RBArgumentName methodsFor: 'accessing' stamp: ''!
canBeRenamed

	^ canBeRenamed ifNil: [ canBeRenamed := true ]! !

!RBArgumentName methodsFor: 'accessing' stamp: ''!
value1

	^ value! !

!RBArgumentName methodsFor: 'accessing' stamp: ''!
canBeRemoved

	^ canBeRemoved ifNil: [ canBeRemoved := true ]! !

!RBArgumentName methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream! !

!RBArgumentName methodsFor: 'accessing' stamp: ''!
canBeRenamed: anObject

	canBeRenamed := anObject! !

!RBArgumentName class methodsFor: 'instance creation' stamp: ''!
name: aString value: anObject 
	^self new 
		name: aString;
		value: anObject! !

!RBArgumentName class methodsFor: 'instance creation' stamp: ''!
name: aString
	^ self new 
		name: aString! !

!RBArrayErrorNode commentStamp: ''!
This is a particular englobing node that is an array.
Exemple : { array node }
Can be created by forgetting 
either the opening : array node }
or the closure : { array node .
!
!RBArrayErrorNode methodsFor: 'testing' stamp: ''!
repairCollection
	^ (self errorMessage = '''}'' expected') ifTrue: [ self repairCollectionFromStart ]
													    ifFalse: [ self repairCollectionFromStop ]! !

!RBArrayErrorNode methodsFor: 'testing' stamp: ''!
isArrayError
	^true! !

!RBArrayErrorNode methodsFor: 'testing' stamp: ''!
repairCollectionFromStart
	" The repair process goes through goes through the statements that are compatible with an array.
	  Begins with all statements included in the array and gets one of every time.
	  The removed statements are to be added in the sequence node."
	| collection result removedStatements |
	collection := self content statements.
	result := OrderedCollection new.
	removedStatements := OrderedCollection new.
	[ collection isNotNil ] 
		whileTrue: [ | statements node | 
						 statements := OrderedCollection new.
					    node := RBArrayNode statements: collection.
						 node start: self start.
						 statements add: node .
						 result add: statements, removedStatements.
						 removedStatements addFirst: collection last.
						 collection removeLast. ].
	result add: removedStatements.
	^collection.! !

!RBArrayErrorNode methodsFor: 'testing' stamp: ''!
repairCollectionFromStop
	" The repair process goes through goes through the statements that are compatible with an array.
	  Begins with all statements included in the array and gets one of every time.
	  The removed statements are to be added in the sequence node."
	| collection result removedStatements |
	collection := self content statements.
	result := OrderedCollection new.
	removedStatements := OrderedCollection new.
	[ collection isNotNil ] 
		whileTrue: [ | statements node | 
						 statements := OrderedCollection new.
						 node := RBArrayNode statements: collection.
						 node start: self start -1.
						 statements add: ( node ).
						 result add: removedStatements, statements.
						 removedStatements add: collection first.
						 collection removeFirst. ].
	result add: removedStatements.
	^collection.! !

!RBArrayErrorNode class methodsFor: 'construction' stamp: ''!
error: aToken withNodes: aCollection
	"Analyses the token to identify if it's an opening or a closure."
	| message |
	message := ('{' = aToken value asString) ifTrue: [ '''}'' expected' ] 
										  				 ifFalse: [ '''{'' expected' ].
	"If the collection is empty, there is only the token in the error."
	aCollection isEmpty
		ifTrue: [ ^self new content: aCollection; start: aToken start; stop: aToken stop; errorMessage: message ].
	"If the collection is not empty, we have to sort where the node begins and where it ends."
	^message = '''}'' expected'
		ifTrue: [ self new content: aCollection; start: aToken start; stop: aCollection last stop; errorMessage: message ]
		ifFalse: [ self new content: aCollection; start: aCollection first start; stop: aToken stop; errorMessage: message ]! !

!RBArrayNode commentStamp: ''!
An RBArrayNode is an AST node for runtime arrays.

Instance Variables
	left:	 <Integer | nil> position of {
	periods: <SequenceableCollection of: Integer> the positions of all the periods that separate the statements
	right: <Integer | nil> position of }
	statements: <SequenceableCollection of: RBValueNode> the statement nodes!
!RBArrayNode methodsFor: 'testing' stamp: ''!
isEmpty
	^ statements isEmpty! !

!RBArrayNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].
	self statements size = anObject statements size ifFalse: [ ^ false ].
	self statements with: anObject statements do: [ :first :second | first = second ifFalse: [ ^ false ] ].
	^ true! !

!RBArrayNode methodsFor: 'accessing' stamp: ''!
stopWithoutParentheses 
	^ right! !

!RBArrayNode methodsFor: 'adding nodes' stamp: ''!
addNodesFirst: aCollection
	statements := statements asOrderedCollection
		addAllFirst: aCollection;
		yourself.
	aCollection do: [ :each | each parent: self ].
	^ aCollection! !

!RBArrayNode methodsFor: 'comparing' stamp: ''!
hash
	^ self hashForCollection: self statements! !

!RBArrayNode methodsFor: 'accessing - token' stamp: ''!
left: anInteger
	left := anInteger! !

!RBArrayNode methodsFor: 'adding nodes' stamp: ''!
addNodeFirst: aNode
	statements := statements asOrderedCollection
		addFirst: aNode;
		yourself.
	aNode parent: self.
	^ aNode! !

!RBArrayNode methodsFor: 'testing' stamp: ''!
isFaulty
	^self statements anySatisfy: [:each | each isFaulty]! !

!RBArrayNode methodsFor: 'accessing' stamp: ''!
children
	^ statements! !

!RBArrayNode methodsFor: 'adding nodes' stamp: ''!
addNodes: aCollection
	statements := statements asOrderedCollection
		addAll: aCollection;
		yourself.
	aCollection do: [ :each | each parent: self ].
	^ aCollection! !

!RBArrayNode methodsFor: 'adding nodes' stamp: ''!
addNode: aNode
	statements := statements asOrderedCollection
		add: aNode;
		yourself.
	aNode parent: self.
	^ aNode! !

!RBArrayNode methodsFor: 'private' stamp: ''!
indexOfNode: aNode 
	"Try to find the node by first looking for ==, and then for ="

	^ (1 to: statements size) 
		detect: [ :each | (statements at: each) == aNode ]
		ifNone: [ statements indexOf: aNode ]! !

!RBArrayNode methodsFor: 'testing' stamp: ''!
isDynamicArray
	^ true! !

!RBArrayNode methodsFor: 'testing' stamp: ''!
uses: aNode 
	^ (statements anySatisfy: [ :each | each == aNode ]) or: [ self isUsed ]! !

!RBArrayNode methodsFor: 'accessing - token' stamp: ''!
right: anInteger
	right := anInteger! !

!RBArrayNode methodsFor: 'replacing' stamp: ''!
replaceNode: oldNode  withNode: newNode
	self statements: (statements collect: [ :statement |
		statement == oldNode 
			ifTrue: [ newNode ]
			ifFalse: [ statement ] ])! !

!RBArrayNode methodsFor: 'testing' stamp: ''!
needsParenthesis
	^ false! !

!RBArrayNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	statements := OrderedCollection new.
	periods := #().
	left := right := 0.! !

!RBArrayNode methodsFor: 'accessing' stamp: ''!
startWithoutParentheses 
	^ left! !

!RBArrayNode methodsFor: 'testing' stamp: ''!
lastIsReturn
	statements isEmpty ifTrue:[ ^false ].
	^statements last lastIsReturn! !

!RBArrayNode methodsFor: 'accessing' stamp: ''!
statements
	^statements! !

!RBArrayNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitArrayNode: self! !

!RBArrayNode methodsFor: 'accessing - token' stamp: ''!
periods: anArray
	periods := anArray! !

!RBArrayNode methodsFor: 'comparing' stamp: ''!
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: 'accessing - token' stamp: ''!
right
	^ right! !

!RBArrayNode methodsFor: 'accessing - token' stamp: ''!
left
	^ left! !

!RBArrayNode methodsFor: 'adding nodes' stamp: ''!
addNodes: aCollection before: anotherNode 
	aCollection do: [ :each | self addNode: each before: anotherNode ].
	^ aCollection! !

!RBArrayNode methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self statements: (self statements collect: [ :each | each copy ])! !

!RBArrayNode methodsFor: 'testing' stamp: ''!
references: aVariableName 
	^ statements anySatisfy: [ :each | each references: aVariableName ]! !

!RBArrayNode methodsFor: 'adding nodes' stamp: ''!
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: 'accessing - token' stamp: ''!
periods
	^ periods! !

!RBArrayNode methodsFor: 'accessing' stamp: ''!
allStatements
	^ statements asOrderedCollection copy
			addAll: super allStatements;
			yourself! !

!RBArrayNode methodsFor: 'accessing' stamp: ''!
statementComments
	^self comments! !

!RBArrayNode methodsFor: 'accessing' stamp: ''!
statements: statements0 
	statements := statements0.
	statements do: [:statement | statement parent: self]! !

!RBArrayNode methodsFor: 'accessing' stamp: ''!
precedence
	^0! !

!RBArrayNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary 
	aNode class = self class ifFalse: [ ^ false ].
	^ self matchList: statements against: aNode statements inContext: aDictionary! !

!RBArrayNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	^ self class statements: (self copyList: self statements inContext: aDictionary)! !

!RBArrayNode class methodsFor: 'instance creation' stamp: ''!
statements: statements
	^ self new statements: statements! !

!RBAssignmentNode commentStamp: ''!
RBAssignmentNode is an AST node for assignment statements.

Instance Variables:
	assignment	<Integer>	position of the :=
	value	<RBValueNode>	the value that we're assigning
	variable	<RBVariableNode>	the variable being assigned

!
!RBAssignmentNode methodsFor: 'accessing' stamp: ''!
value: aValueNode 
	value := aValueNode.
	value parent: self! !

!RBAssignmentNode methodsFor: 'testing' stamp: ''!
isAssignment
	^true! !

!RBAssignmentNode methodsFor: 'accessing' stamp: ''!
stopWithoutParentheses
	^value stop! !

!RBAssignmentNode methodsFor: 'comparing' stamp: ''!
hash
	^self variable hash bitXor: self value hash! !

!RBAssignmentNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [^true].
	self class = anObject class ifFalse: [^false].
	^self variable = anObject variable and: [self value = anObject value]! !

!RBAssignmentNode methodsFor: '*Reflectivity-Examples' stamp: ''!
tagType: anObject
	"record the type of the assigned value"
	variable propertyAt: #types ifAbsentPut: Set new.
	(variable propertyAt: #types) add: anObject class.! !

!RBAssignmentNode methodsFor: 'accessing' stamp: ''!
assignmentOperator
	^  ':='! !

!RBAssignmentNode methodsFor: 'testing' stamp: ''!
isFaulty
	^self variable isFaulty or: [ self value isFaulty ]! !

!RBAssignmentNode methodsFor: 'accessing' stamp: ''!
children
	^ { value . variable }! !

!RBAssignmentNode methodsFor: 'initialization' stamp: ''!
variable: aVariableNode value: aValueNode position: anInteger 
	self variable: aVariableNode.
	self value: aValueNode.
	assignment := anInteger! !

!RBAssignmentNode methodsFor: 'replacing' stamp: ''!
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: 'accessing' stamp: ''!
variable: varNode 
	variable := varNode.
	variable parent: self! !

!RBAssignmentNode methodsFor: 'accessing - token' stamp: ''!
assignment
	^ assignment! !

!RBAssignmentNode methodsFor: 'accessing - token' stamp: ''!
assignment: anInteger
	assignment := anInteger! !

!RBAssignmentNode methodsFor: 'testing' stamp: ''!
uses: aNode 
	^aNode = value ifTrue: [true] ifFalse: [self isUsed]! !

!RBAssignmentNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	value == aNode ifTrue: [self value: anotherNode].
	variable == aNode ifTrue: [self variable: anotherNode]! !

!RBAssignmentNode methodsFor: 'testing' stamp: ''!
needsParenthesis
	^parent
		ifNil: [false]
		ifNotNil: [self precedence > parent precedence]! !

!RBAssignmentNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitAssignmentNode: self! !

!RBAssignmentNode methodsFor: 'accessing' stamp: ''!
startWithoutParentheses
	^variable start! !

!RBAssignmentNode methodsFor: 'comparing' stamp: ''!
equalTo: anObject withMapping: aDictionary 
	^self class = anObject class and: 
			[(self variable equalTo: anObject variable withMapping: aDictionary) 
				and: [self value equalTo: anObject value withMapping: aDictionary]]! !

!RBAssignmentNode methodsFor: 'adding/removing' stamp: ''!
removeNode: aNode

	self replaceNode: aNode withNode: aNode receiver! !

!RBAssignmentNode methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self variable: self variable copy.
	self value: self value copy! !

!RBAssignmentNode methodsFor: 'accessing' stamp: ''!
variable
	^variable! !

!RBAssignmentNode methodsFor: 'testing' stamp: ''!
directlyUses: aNode 
	^aNode = value ifTrue: [true] ifFalse: [self isDirectlyUsed]! !

!RBAssignmentNode methodsFor: '*Reflectivity' stamp: ''!
variableValueInContext: aContext
	^self variable variableValueInContext: aContext! !

!RBAssignmentNode methodsFor: 'accessing' stamp: ''!
value
	^value! !

!RBAssignmentNode methodsFor: 'accessing' stamp: ''!
assignmentPosition
	^ assignment! !

!RBAssignmentNode methodsFor: 'accessing' stamp: ''!
precedence
	^5! !

!RBAssignmentNode methodsFor: 'testing' stamp: ''!
assigns: aVariableName 
	^variable name = aVariableName or: [value assigns: aVariableName]! !

!RBAssignmentNode methodsFor: 'matching' stamp: ''!
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: 'matching' stamp: ''!
copyInContext: aDictionary 
	^ self class new
		variable: (self variable copyInContext: aDictionary);
		value: (self value copyInContext: aDictionary);
		yourself! !

!RBAssignmentNode class methodsFor: 'instance creation' stamp: ''!
variable: aVariableNode value: aValueNode position: anInteger 
	^(self new)
		variable: aVariableNode
			value: aValueNode
			position: anInteger;
		yourself! !

!RBAssignmentNode class methodsFor: 'instance creation' stamp: ''!
variable: aVariableNode value: aValueNode 
	^self 
		variable: aVariableNode
		value: aValueNode
		position: nil! !

!RBAssignmentToken commentStamp: ''!
RBAssignmentToken is the first-class representation of the assignment token ':='
!
!RBAssignmentToken methodsFor: 'testing' stamp: ''!
isAssignment
	^true! !

!RBAssignmentToken methodsFor: 'evaluating' stamp: ''!
value
	^':='! !

!RBAssignmentToken methodsFor: 'accessing' stamp: ''!
length

	^ 2! !

!RBBasicDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
foobar

	^#( true false )! !

!RBBasicDummyLintRuleTest methodsFor: 'testing' stamp: ''!
isEmpty
	^result isEmpty! !

!RBBasicDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
problemCount
	^result problemCount! !

!RBBasicDummyLintRuleTest methodsFor: 'initialization' stamp: ''!
classBlock
	^ self anInstVar + 5! !

!RBBasicDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
checkClass: aSmalllintContext 
	^classBlock value: aSmalllintContext value: result! !

!RBBasicDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
checkMethod: aSmalllintContext 
	^methodBlock value: aSmalllintContext value: result! !

!RBBasicDummyLintRuleTest methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self anInstVar: 1.
	classBlock := [:context :aResult | ].
	methodBlock := [:context :aResult | ].
	self resultClass: RBSelectorEnvironment! !

!RBBasicDummyLintRuleTest methodsFor: 'initialization' stamp: ''!
anInstVar
	^ anInstVar! !

!RBBasicDummyLintRuleTest methodsFor: 'initialization' stamp: ''!
methodBlock: aBlock
	methodBlock := aBlock! !

!RBBasicDummyLintRuleTest methodsFor: 'initialize-release' stamp: ''!
resetResult
	result := result copyEmpty.
	result label: name! !

!RBBasicDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
result
	^result! !

!RBBasicDummyLintRuleTest methodsFor: 'private' stamp: ''!
viewResults
	result openEditor! !

!RBBasicDummyLintRuleTest methodsFor: 'private' stamp: ''!
method: anObject1 with: anObject2 lots: anObject3 of: anObject4 arguments: anObject5
	^ anObject5 + anObject1 > (anObject4 - anObject2 + anObject3)! !

!RBBasicDummyLintRuleTest methodsFor: 'initialize-release' stamp: ''!
result: aResult 
	result := aResult copyEmpty! !

!RBBasicDummyLintRuleTest methodsFor: 'initialization' stamp: ''!
classBlock: aBlock
	classBlock := aBlock testMethod1! !

!RBBasicDummyLintRuleTest methodsFor: 'initialization' stamp: ''!
newResultClass: aClass 
"New one:)"
	result := aClass new! !

!RBBasicDummyLintRuleTest methodsFor: 'initialization' stamp: ''!
resultClass: aClass 
	result := aClass new! !

!RBBasicDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
someDemoMethod
	^ self junk! !

!RBBasicDummyLintRuleTest methodsFor: 'initialize-release' stamp: ''!
anInstVar: anObject
	anInstVar := anObject! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
returnsBooleanAndOther
	| detector matcher |
	detector := self new.
	detector name: 'Returns a boolean and non boolean'.
	matcher := self parseTreeSearcher.
	matcher addSearch: '^``@xObject' -> 
					[:aNode :answer | 
					answer add: aNode value;
						yourself].
	detector methodBlock: 
			[:context :result | 
			| hasBool hasSelf |
			hasBool := false.
			hasSelf := context parseTree lastIsReturn not.
			(matcher executeTree: context parseTree initialAnswer: Set new) do: 
					[:each | 
					hasBool := hasBool or: 
									[(each isLiteralNode and: [{true. false} includes: each value])
										or: [each isMessage and: [#(#and: #or:) includes: each selector]]].
					hasSelf := hasSelf or: 
									[(each isVariable and: [each name = 'self'])
										or: [each isLiteralNode and: [({true. false} includes: each value) not]]]].
			hasSelf & hasBool
				ifTrue: [result addClass: context selectedClass selector: context selector]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
atIfAbsent
	^self createParseTreeRule: 
				#('`@object 
						at: `@atArg 
						ifAbsent: [| `@temps | `@.Statements. `@object at: `@atArg put: `@putArg]' 
				'`@object 
						at: `@atArg 
						ifAbsent: [| `@temps | 
								`@.Statements. 
								`@object at: `@atArg put: `@putArg. 
								`@.xStatements1. 
								`@putArg]') 
		name: 'Uses at:ifAbsent: instead of at:ifAbsentPut:'! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
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'! !

!RBBasicDummyLintRuleTest class methodsFor: 'unnecessary code' stamp: ''!
implementedNotSent
	| detector |
	detector := self new.
	detector name: 'Methods implemented but not sent'.
	detector methodBlock: 
			[:context :result | 
			context compiledMethod senders
				senders: [result addClass: context selectedClass selector: context selector]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
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.'! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
consistencyCheck
	^self createParseTreeRule: 
				#('`@object size == 0' 
				'`@object size = 0' 
				'`@object size > 0' 
				'`@object size >= 1' 
				'`@object == nil' 
				'`@object = nil') 
		name: 'Uses "size = 0" or "= nil" instead of "isEmpty" or "isNil"'! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
superSends
	| detector |
	detector := self new.
	detector name: 'Missing super sends'.
	detector methodBlock: 
			[:context :result | 
			(context selectedClass isMetaclass not
				and: [self superMessages includes: context selector]) ifTrue: 
						[(context selectedClass superclass notNil
							and: [context selectedClass superclass canUnderstand: context selector])
								ifTrue: 
									[(context superMessages includes: context selector)
										ifFalse: [result addClass: context selectedClass selector: context selector]]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
usesAdd
	| detector addSearcher |
	detector := self new.
	detector name: 'Uses the result of an add: message'.
	addSearcher := self parseTreeSearcherClass usesResultOfAdd.
	detector methodBlock: 
			[:context :result | 
			(addSearcher executeTree: context parseTree initialAnswer: false)
				ifTrue: [result addClass: context selectedClass selector: context selector]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'unnecessary code' stamp: ''!
variableReferencedOnce
	| detector |
	detector := self new.
	detector 
		name: 'Variable referenced in only one method and always assigned first'.
	detector classBlock: 
			[:context :result | 
			| allSubclasses |
			allSubclasses := context selectedClass withAllSubclasses.
			context selectedClass instVarNames do: 
					[:each | 
					| defClass selector |
					(allSubclasses inject: 0
						into: 
							[:sum :class | 
							| sels |
							sels := class whichSelectorsAccess: each.
							sels size == 1 
								ifTrue: 
									[selector := sels asArray first.
									defClass := class].
							sum + sels size]) 
							== 1 
							ifTrue: 
								[| tree |
								tree := defClass parseTreeFor: selector.
								tree notNil 
									ifTrue: 
										[(RBReadBeforeWrittenTester readBeforeWritten: (Array with: each) in: tree) 
											isEmpty 
												ifTrue: 
													[result addClass: defClass selector: selector.
													result addSearchString: each]]]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'bugs' stamp: ''!
sentNotImplemented

	| detector |

	detector := self new.
	detector name: 'Messages sent but not implemented'.
	detector
		methodBlock: [ :context :result | 
			| message |

			message := context messages detect: [ :each | ( context implements: each ) not ] ifNone: [ nil ].
			message
				ifNil: [ message := context superMessages
						detect: [ :each | 
							context selectedClass superclass isNil
								or: [ ( context selectedClass superclass canUnderstand: each ) not ]
							]
						ifNone: [ nil ].
					message
						ifNil: [ 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! !

!RBBasicDummyLintRuleTest class methodsFor: 'private' stamp: ''!
classShouldNotOverride
	^#(#== #class)! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
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! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
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! !

!RBBasicDummyLintRuleTest class methodsFor: 'bugs' stamp: ''!
subclassResponsibilityNotDefined
	| detector subclassResponsibilitySymbol |
	detector := self new.
	subclassResponsibilitySymbol := 'subclassResponsibility' asSymbol.
	detector name: 'Subclass responsibility not defined'.
	detector classBlock: 
			[:context :result | 
			(context selectedClass whichSelectorsReferTo: subclassResponsibilitySymbol)
				do: 
					[:each | 
					(context selectedClass withAllSubclasses detect: 
							[:class | 
							class subclasses isEmpty
								and: [(class whichClassIncludesSelector: each) == context selectedClass]]
						ifNone: [nil]) notNil
						ifTrue: [result addClass: context selectedClass selector: each]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
stringConcatenation
	| detector matcher concatenationMatcher |
	detector := self new.
	detector name: 'String concatenation instead of streams'.
	matcher := self parseTreeSearcher.
	concatenationMatcher := self parseTreeSearcher.
	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! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
tempsReadBeforeWritten
	| detector |
	detector := self new.
	detector name: 'Temporaries read before written'.
	detector methodBlock: 
			[:context :result | 
			| variables |
			variables := self parseTreeSearcherClass nonBlockTempsIn: context parseTree.
			variables isEmpty 
				ifFalse: 
					[(RBReadBeforeWrittenTester variablesReadBeforeWrittenIn: context parseTree) 
						do: 
							[:each | 
							result addClass: context selectedClass selector: context selector.
							result addSearchString: each]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'unnecessary code' stamp: ''!
justSendsSuper
	| detector matcher |
	detector := self new.
	detector name: 'Method just sends super message'.
	matcher := self parseTreeSearcherClass 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! !

!RBBasicDummyLintRuleTest class methodsFor: 'unnecessary code' stamp: ''!
endTrueFalse
	| detector matcher |
	detector := self new.
	detector name: 'Check for same statements at end of ifTrue:ifFalse: blocks'.
	matcher := (self parseTreeSearcher) 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! !

!RBBasicDummyLintRuleTest class methodsFor: 'private' stamp: ''!
subclassOf: aClass overrides: aSelector 
	| subs |
	subs := aClass subclasses.
	1 to: subs size
		do: 
			[:i | 
			| each |
			each := subs at: i.
			(each includesSelector: aSelector) ifTrue: [^true].
			(self subclassOf: each overrides: aSelector) ifTrue: [^true]].
	^false! !

!RBBasicDummyLintRuleTest class methodsFor: 'unnecessary code' stamp: ''!
onlyReadOrWritten
	| detector |
	detector := self new.
	detector name: 'Instance variables not read AND written'.
	detector result: nil references.
	detector classBlock: 
			[:context :result | 
			| allSubclasses |
			allSubclasses := context selectedClass withAllSubclasses.
			context selectedClass instVarNames do: 
					[:each | 
					| reads writes |
					reads := false.
					writes := false.
					allSubclasses detect: 
							[:class | 
							reads ifFalse: [reads := (class whichSelectorsRead: each) isEmpty not].
							writes ifFalse: [writes := (class whichSelectorsWrite: each) isEmpty not].
							reads & writes]
						ifNone: [result addInstVar: each for: context selectedClass]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
instVarInSubclasses
	| detector |
	detector := self new.
	detector name: 'Instance variables defined in all subclasses'.
	detector result: nil pullUpInstVar.
	detector classBlock: 
			[:context :result | 
			| subs |
			subs := context selectedClass subclasses.
			subs size > 1 ifTrue: 
					[| sels |
					sels := Bag new.
					subs do: [:each | sels addAll: each instVarNames].
					sels asSet do: 
							[:val | 
							(sels occurrencesOf: val) == subs size
								ifTrue: [result addInstVar: val for: context selectedClass]]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'bugs' stamp: ''!
usesTrue
	| detector trueBinding falseBinding |
	detector := self new.
	trueBinding := Smalltalk associationAt: #True.
	falseBinding := Smalltalk associationAt: #False.
	detector name: 'Uses True/False instead of true/false'.
	detector methodBlock: 
			[:context :result | 
			| method |
			method := context compiledMethod.
			((method referencesLiteral: trueBinding)
				or: [method referencesLiteral: falseBinding]) ifTrue: 
						[result addClass: context selectedClass selector: context selector.
						result searchStrings: #('True' 'False')]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
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! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
returnsIfTrue
	^self createParseTreeRule: 
				#('^`@condition ifTrue: [| `@temps | `@.statements]' 
				'^`@condition ifFalse: [| `@temps | `@.statements]') 
		name: 'Returns value of ifTrue:/ifFalse: without ifFalse:/ifTrue: block'! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
modifiesCollection
	| detector addSearcher |
	detector := self new.
	detector name: 'Modifies collection while iterating over it'.
	addSearcher := RBBasicLintRuleTestData modifiesCollection.
	detector methodBlock: 
			[:context :result | 
			addSearcher executeTree: context parseTree initialAnswer: false.
			addSearcher answer 
				ifTrue: [result addClass: context selectedClass selector: context selector]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
longMethods
	| detector matcher |
	detector := self new.
	detector name: 'Long methods'.
	matcher := self parseTreeSearcher.
	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! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
collectionProtocol
	^self createParseTreeRule: 
			#('`@collection do: [:`each | | `@temps | `@.Statements1. `@object add: `@arg. `@.Statements2]' 
			'`@collection do: [:`each | | `@temps | 
					`@.Statements1. 
					`@condition ifTrue: [| `@blockTemps | 
							`@.BlockStatements1. 
							`@object add: `each. 
							`@.BlockStatements2]. 
					`@.Statements2]' 
			'`@collection do: [:`each | | `@temps | 
					`@.Statements1. 
					`@condition ifFalse: [| `@blockTemps | 
							`@.BlockStatements1. 
							`@object add: `each. 
							`@.BlockStatements2]. 
					`@.Statements2]') 
		name: 'Uses do: instead of collect: or select:''s'! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
minMax
	| detector matcher |
	detector := self new.
	detector name: 'Uses ifTrue:/ifFalse: instead of min: or max:'.
	matcher := self parseTreeSearcher.
	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! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
threeElementPoint
	| detector matcher |
	detector := self new.
	detector name: 'Possible three element point (e.g., x @ y + q @ r)'.
	matcher := (self parseTreeSearcher) 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! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
guardingClause
	^self
		createParseTreeRule: 
				#('`@MethodName: `@args 
						| `@temps | 
						`@.Statements. 
						`@condition ifTrue: [| `@BlockTemps | `.Statement1. `.Statement2. `@.BStatements]' 
				'`@MethodName: `@args 
						| `@temps | 
						`@.Statements. 
						`@condition ifFalse: [| `@BlockTemps | `.Statement1. `.Statement2. `@.BStatements]')
		method: true
		name: 'Guarding clauses'! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
ifTrueReturns
	| detector matcher |
	detector := self new.
	detector name: 'ifTrue:/ifFalse: returns instead of and:/or:''s'.
	matcher := self parseTreeSearcher.
	matcher addSearches:
		#('| `@temps | ``@.Statements. ``@object ifTrue: [^``@value1]. ^``@value2' 
		'| `@temps | ``@.Statements. ``@object ifFalse: [^``@value1]. ^``@value2') 
			-> [:aNode :answer | answer
				or: 
					[| node |
					node := (aNode statements at: aNode statements size - 1) arguments first body statements last value. "``@value1"
					(node isLiteralNode and: [{true. false} includes: node value])
						or: 
							[node := aNode statements last value.
							node isLiteralNode and: [{true. false} includes: node value]]]].
	detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false)
			ifTrue: [result addClass: context selectedClass selector: context selector]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
precedence
	| detector matcher |
	detector := self new.
	detector
		name: 'Inspect instances of "A + B * C" might be "A + (B * C)"'.
	matcher := self parseTreeSearcher.
	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! !

!RBBasicDummyLintRuleTest class methodsFor: 'private' stamp: ''!
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]! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
toDo
	| detector matcher |
	detector := self new.
	detector name: 'Uses to:do: instead of do:, with:do: or timesRepeat:'.
	matcher := self parseTreeSearcher.
	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 := self parseTreeSearcher.
							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! !

!RBBasicDummyLintRuleTest class methodsFor: 'unnecessary code' stamp: ''!
unreferencedVariables
	| detector |
	detector := self new.
	detector name: 'Variables not referenced'.
	detector result: nil unreferenced.
	detector classBlock: 
			[:context :result | 
			| allSubclasses |
			allSubclasses := context selectedClass withAllSubclasses.
			context selectedClass instVarNames do: 
					[:each | 
					allSubclasses
						detect: [:class | (class whichSelectorsAccess: each) isEmpty not]
						ifNone: [result addInstVar: each for: context selectedClass]].
			context selectedClass isMetaclass ifFalse: 
					[context selectedClass classPool associationsDo: 
							[:each | 
							(SystemNavigation default allCallsOn: each) ifEmpty:  [result addClassVar: each key for: context selectedClass]]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
tempVarOverridesInstVar
	| detector matcher vars varName |
	detector := self new.
	detector name: 'Instance variable overridden by temporary variable'.
	matcher := (self parseTreeSearcher) 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! !

!RBBasicDummyLintRuleTest class methodsFor: 'bugs' stamp: ''!
booleanPrecedence
	^self createParseTreeRule: 
			#('`@object1 | `@object2 = `@object3'
			'`@object1 | `@object2 == `@object3'
			'`@object1 & `@object2 = `@object3'
			'`@object1 & `@object2 == `@object3'
			'`@object1 | `@object2 ~= `@object3'
			'`@object1 | `@object2 ~~ `@object3'
			'`@object1 & `@object2 ~= `@object3'
			'`@object1 & `@object2 ~~ `@object3')
		name: 'Uses A | B = C instead of A | (B = C)'! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
whileTrue
	^self createParseTreeRule: 
			#('| `@temps | 
				`@.Statements1. 
				[`index <= `@stop] 
					whileTrue: 
						[| `@blockTemps | 
						`@.BlockStmts1. 
						`index := `index + 1].
				`@.Statements2' 
			'| `@temps | 
				`@.Statements1. 
				[`index < `@stop] 
					whileTrue: 
						[| `@blockTemps | 
						`@.BlockStmts1. 
						`index := `index + 1].
				`@.Statements2'
			'| `@temps | 
				`@.Statements1. 
				[`index >= `@stop] 
					whileTrue: 
						[| `@blockTemps | 
						`@.BlockStmts1. 
						`index := `index - 1].
				`@.Statements2' 
			'| `@temps | 
				`@.Statements1. 
				[`index > `@stop] 
					whileTrue: 
						[| `@blockTemps | 
						`@.BlockStmts1. 
						`index := `index - 1].
				`@.Statements2') 
		name: 'Uses whileTrue: instead of to:do:'! !

!RBBasicDummyLintRuleTest class methodsFor: 'unnecessary code' stamp: ''!
equalsTrue
	| detector matcher |
	detector := self new.
	detector name: 'Unnecessary "= true"'.
	matcher := (self parseTreeSearcher) 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! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
sendsDifferentSuper
	| detector |
	detector := self new.
	detector name: 'Sends different super message'.
	detector methodBlock: 
			[:context :result | 
			| message |
			(message := context superMessages detect: [:each | each ~= context selector]
						ifNone: [nil]) notNil ifTrue: 
					[result addSearchString: message.
					result addClass: context selectedClass selector: context selector]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
yourselfNotUsed
	| detector addSearcher |
	detector := self new.
	detector name: 'Doesn''t use the result of a yourself message'.
	addSearcher := self parseTreeSearcher.
	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! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
sizeCheck
	^self createParseTreeRule: (#(#do: #collect: #reject: #select:) collect: 
					[:each | 
					'`@object size > 0 ifTrue: [`@object ' , each
						, ' [:`each | | `@temps | `@.Statements1]. `@.Statements2]'])
				, (#(#do: #collect: #reject: #select:) collect: 
							[:each | 
							'`@object isEmpty ifFalse: [`@object ' , each
								, ' [:`each | | `@temps | `@.Statements1]. `@.Statements2]'])
		name: 'Unnecessary size check'! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
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 := self parseTreeSearcher.
								searcher addSearch: (each , ' := ``@object')
											-> [:aNode :answer | answer isNil and: [aNode value isLiteralNode]].
								tree := defClass parseTreeFor: selector.
								tree notNil ifTrue: 
										[(searcher executeTree: tree initialAnswer: nil) == true
											ifTrue: [result addInstVar: each for: context selectedClass]]]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
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! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
detectContains
	^self createParseTreeRule: 
			#('`@collection do: [:`each | | `@temps | 
					`@.Statements1. 
					`@condition ifFalse: [| `@BlockTemps | `@.BlockStatements1. ^`each]. 
					`@.Statements2]' 
			'`@collection do: [:`each | | `@temps | 
					`@.Statements1. 
					`@condition ifTrue: [| `@BlockTemps | `@.BlockStatements1.  ^`each]. 
					`@.Statements2]' 
			'`@collection do: [:`each | | `@temps | 
					`@.Statements1. 
					`@condition ifFalse: [| `@BlockTemps | `@.BlockStatements1. ^true]. 
					`@.Statements2]' 
			'`@Collection do: [:`each | | `@temps | 
					`@.Statements1. 
					`@condition ifTrue: [| `@BlockTemps | `@.BlockStatements1.  ^true]. 
					`@.Statements2]' 
			'`@collection do: [:`each | | `@temps | 
					`@.Statements1. 
					`@condition ifFalse: [| `@BlockTemps | `@.BlockStatements1. ^false]. 
					`@.Statements2]' 
			'`@collection do: [:`each | | `@temps | 
					`@.Statements1. 
					`@condition ifTrue: [| `@BlockTemps | `@.BlockStatements1.  ^false]. 
					`@.Statements2]') 
		name: 'Uses do: instead of contains: or detect:''s'! !

!RBBasicDummyLintRuleTest class methodsFor: 'private' stamp: ''!
superMessages
	^#(#release #postCopy #postBuildWith: #preBuildWith: #postOpenWith: #noticeOfWindowClose: #initialize)! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
fullBlocks

"	| 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"! !

!RBBasicDummyLintRuleTest class methodsFor: 'private' stamp: ''!
longMethodSize
	^10! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
missingYourself
	| detector matcher |
	detector := self new.
	detector name: 'Possible missing "; yourself"'.
	matcher := self parseTreeSearcher.
	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! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
assignmentInIfTrue
	^self createParseTreeRule: 
			#('`@boolean 
					ifTrue: [| `@temps1 | `@.Statements1. `var := `@object1] 
					ifFalse: [| `@temps2 | `@.Statements2. `var := `@object2]' 
			'`@boolean 
					ifFalse: [| `@temps1 | `@.Statements1. `var := `@object1] 
					ifTrue: [| `@temps2 | `@.Statements2. `var := `@object2]') 
		name: 'Assignment to same variable and end of ifTrue:ifFalse: blocks'! !

!RBBasicDummyLintRuleTest class methodsFor: 'bugs' stamp: ''!
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! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
contains
	^self createParseTreeRule: 
			#('(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) isNil' 
			'(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) notNil' 
			'(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) = nil' 
			'(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) == nil' 
			'(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) ~= nil' 
			'(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) ~~ nil' 
			'`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [| `@temps1 | `@.Statements2. ^`@anything]') 
		name: 'Uses detect:ifNone: instead of contains:'! !

!RBBasicDummyLintRuleTest class methodsFor: 'accessing' stamp: ''!
protocolsToCheck
	^#('bugs' 'possible bugs' 'unnecessary code' 'intention revealing' 'miscellaneous')! !

!RBBasicDummyLintRuleTest class methodsFor: 'unnecessary code' stamp: ''!
equivalentSuperclassMethods
	| detector |
	detector := self new.
	detector name: 'Methods equivalently defined in superclass'.
	detector methodBlock: 
			[:context :result | 
			context selectedClass superclass notNil ifTrue: 
					[(context selectedClass superclass canUnderstand: context selector)
						ifTrue: 
							[(((context selectedClass superclass
								whichClassIncludesSelector: context selector)
									compiledMethodAt: context selector)
									equivalentTo: context compiledMethod)
									ifTrue: [result addClass: context selectedClass selector: context selector]]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'unnecessary code' stamp: ''!
extraBlock
	^self
		createParseTreeRule: (#('value' 'value: `@value' 'value: `@value1 value: `@value2' 'value: `@value1 value: `value2 value: `@value3' 'valueWithArguments: `@values')
				collect: [:each | '[:`@params | | `@temps | `@.statements] ' , each])
		name: 'Block immediately evaluated'! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
ifTrueBlocks
	| detector matcher |
	detector := self new.
	detector name: 'Non-blocks in ifTrue:/ifFalse: messages'.
	matcher := self parseTreeSearcher.
	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! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
sentNotImplementedInApplication

	| detector |

	detector := self new.
	detector name: 'Messages sent but not implemented in application'.
	detector
		methodBlock: [ :context :result | 
			| message class block |

			message := context messages
				detect: [ :each | ( context isItem: each in: context application ) not ]
				ifNone: [ nil ].
			class := context selectedClass.
			block := [ :each | 
			| app |

			app := context application.
			( self canCall: each in: class from: app ) not
			].
			message ifNil: [ message := context selfMessages detect: block ifNone: [ nil ] ].
			message
				ifNil: [ class := class superclass.
					class
						ifNil: [ context superMessages isEmpty
								ifFalse: [ message := context superMessages asArray first ]
							]
						ifNotNil: [ message := context superMessages detect: block ifNone: [ nil ] ]
					].
			message notNil
				ifTrue: [ result addSearchString: message.
					result addClass: context selectedClass selector: context selector
					]
			].
	^ detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'unnecessary code' stamp: ''!
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: 
						[ context selectedClass allCallsOn ifEmpty:
								[result addClass: context selectedClass;
									addClass: context selectedClass class]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'private' stamp: ''!
utilityProtocols
	"If a method is defined in one of these protocols, then don't check if its a utility method."

	^#('*utilit*')! !

!RBBasicDummyLintRuleTest class methodsFor: 'instance creation' stamp: ''!
createParseTreeRule: codeStrings name: aName 
	^self createParseTreeRule: codeStrings
		method: false
		name: aName! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
collectionMessagesToExternalObject
	| detector matcher |
	detector := self new.
	detector name: 'Sends add:/remove: to external collection'.
	matcher := self parseTreeSearcher.
	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! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
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) messages do: 
							[:each | 
							each == #addDependent: ifTrue: [count := count + 1].
							each == #removeDependent: ifTrue: [count := count - 1]]].
			count > 0 ifTrue: [result addClass: context selectedClass]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'possible bugs' stamp: ''!
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)
				ifNotEmpty: 
						[(context whichSelectorsReferTo: subclassResponsibilitySymbol) ifNotEmpty:  [result addClass: context selectedClass]]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'instance creation' stamp: ''!
createParseTreeRule: codeStrings method: aBoolean name: aName 
	| detector matcher |
	detector := self new.
	detector name: aName.
	matcher := self createMatcherFor: codeStrings method: aBoolean.
	detector methodBlock: 
			[:context :result | 
			(matcher executeTree: context parseTree initialAnswer: false)
				ifTrue: [result addClass: context selectedClass selector: context selector]].
	^detector! !

!RBBasicDummyLintRuleTest class methodsFor: 'private' stamp: ''!
createMatcherFor: codeStrings method: aBoolean 
	| matcher |
	matcher := self parseTreeSearcher.
	aBoolean
		ifTrue: [matcher addMethodSearches: codeStrings -> [:aNode :answer | true]]
		ifFalse: [matcher addSearches: codeStrings -> [:aNode :answer | true]].
	^matcher! !

!RBBasicDummyLintRuleTest class methodsFor: 'private' stamp: ''!
metaclassShouldNotOverride
	^#(#name #comment)! !

!RBBasicDummyLintRuleTest class methodsFor: 'intention revealing' stamp: ''!
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! !

!RBBasicDummyLintRuleTest class methodsFor: 'miscellaneous' stamp: ''!
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: 
									[(self parseTreeSearcherClass
										references: context selectedClass allInstVarNames
												, context selectedClass allClassVarNames asArray , #('self')
										in: context parseTree) isEmpty
										ifTrue: [result addClass: context selectedClass selector: context selector]]]]].
	^detector! !

!RBBasicLintRule commentStamp: ''!
I am a rule that has a result. 
It is not clear why it is not merged with its superclass but this is ok too.!
!RBBasicLintRule methodsFor: 'testing' stamp: ''!
isEmpty
	^ self result isEmpty! !

!RBBasicLintRule methodsFor: 'accessing' stamp: ''!
problemCount
	^ self result problemCount! !

!RBBasicLintRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self resetResult
	! !

!RBBasicLintRule methodsFor: 'accessing' stamp: ''!
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 ifEmpty: [ ^ 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 classSide;
					removeClass: class instanceSide ] ]
		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: ''!
result
	^ result! !

!RBBasicLintRule methodsFor: 'accessing' stamp: ''!
resultClass
	self subclassResponsibility! !

!RBBasicLintRule methodsFor: 'running' stamp: ''!
resetResult
	result := self resultClass new.
	result label: self name! !

!RBBasicLintRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'BasicLintRule'! !

!RBBasicLintRuleTestData methodsFor: 'accessing' stamp: ''!
foobar

	^#( true false )! !

!RBBasicLintRuleTestData methodsFor: 'testing' stamp: ''!
isEmpty
	^result isEmpty! !

!RBBasicLintRuleTestData methodsFor: 'accessing' stamp: ''!
problemCount
	^result problemCount! !

!RBBasicLintRuleTestData methodsFor: 'initialization' stamp: ''!
classBlock
	^ self anInstVar + 5! !

!RBBasicLintRuleTestData methodsFor: 'accessing' stamp: ''!
checkClass: aSmalllintContext 
	^classBlock value: aSmalllintContext value: result! !

!RBBasicLintRuleTestData methodsFor: 'accessing' stamp: ''!
checkMethod: aSmalllintContext 
	^methodBlock value: aSmalllintContext value: result! !

!RBBasicLintRuleTestData methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self anInstVar: 1.
	classBlock := [:context :aResult | ].
	methodBlock := [:context :aResult | ].
	self resultClass: RBSelectorEnvironment! !

!RBBasicLintRuleTestData methodsFor: 'initialization' stamp: ''!
anInstVar
	^ anInstVar! !

!RBBasicLintRuleTestData methodsFor: 'initialization' stamp: ''!
methodBlock: aBlock
	methodBlock := aBlock! !

!RBBasicLintRuleTestData methodsFor: 'initialize-release' stamp: ''!
resetResult
	result := result copyEmpty.
	result label: name! !

!RBBasicLintRuleTestData methodsFor: 'accessing' stamp: ''!
result
	^result! !

!RBBasicLintRuleTestData methodsFor: 'private' stamp: ''!
viewResults
	result openEditor! !

!RBBasicLintRuleTestData methodsFor: 'private' stamp: ''!
method: anObject1 with: anObject2 lots: anObject3 of: anObject4 arguments: anObject5
	^ anObject5 + anObject1 > (anObject4 - anObject2 + anObject3)! !

!RBBasicLintRuleTestData methodsFor: 'initialize-release' stamp: ''!
result: aResult 
	result := aResult copyEmpty! !

!RBBasicLintRuleTestData methodsFor: 'initialization' stamp: ''!
classBlock: aBlock
	classBlock := aBlock testMethod1! !

!RBBasicLintRuleTestData methodsFor: 'initialization' stamp: ''!
newResultClass: aClass 
"New one:)"
	result := aClass new! !

!RBBasicLintRuleTestData methodsFor: 'initialization' stamp: ''!
resultClass: aClass 
	result := aClass new! !

!RBBasicLintRuleTestData methodsFor: 'accessing' stamp: ''!
someDemoMethod
	^ self junk! !

!RBBasicLintRuleTestData methodsFor: 'initialize-release' stamp: ''!
anInstVar: anObject
	anInstVar := anObject! !

!RBBasicLintRuleTestData class methodsFor: 'intention revealing' stamp: ''!
toDo
	| detector matcher |
	detector := self new.
	detector name: 'Uses to:do: instead of do:, with:do: or timesRepeat:'.
	matcher := self parseTreeSearcher.
	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 := self parseTreeSearcher.
							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! !

!RBBasicLintRuleTestData class methodsFor: 'possible bugs' stamp: ''!
modifiesCollection
	| detector addSearcher |
	detector := self new.
	detector name: 'Modifies collection while iterating over it'.
	addSearcher := RBBasicLintRuleTestData modifiesCollection.
	detector methodBlock: 
			[:context :result | 
			addSearcher executeTree: context parseTree initialAnswer: false.
			addSearcher answer 
				ifTrue: [result addClass: context selectedClass selector: context selector]].
	^detector! !

!RBBasicLintRuleTestData class methodsFor: 'possible bugs' stamp: ''!
sentNotImplementedInApplication
	| detector |
	detector := self new.
	detector name: 'Messages sent but not implemented in application'.
	detector methodBlock: 
			[:context :result | 
			| message class block |
			message := context messages
						detect: [:each | (context isItem: each in: context application) not]
						ifNone: [nil].
			class := context selectedClass.
			block := 
					[:each | 
					| app |
					app := context application.
					(self canCall: each
						in: class
						from: app) not].
			message isNil ifTrue: [message := context selfMessages detect: block ifNone: [nil]].
			message isNil ifTrue: 
					[class := class superclass.
					class isNil
						ifTrue: 
							[context superMessages isEmpty ifFalse: [message := context superMessages asArray first]]
						ifFalse: [message := context superMessages detect: block ifNone: [nil]]].
			message notNil ifTrue: 
					[result addSearchString: message.
					result addClass: context selectedClass selector: context selector]].
	^detector! !

!RBBasicLintRuleTestData class methodsFor: 'possible bugs' stamp: ''!
superSends
	| detector |
	detector := self new.
	detector name: 'Missing super sends'.
	detector methodBlock: 
			[:context :result | 
			(context selectedClass isMetaclass not
				and: [self superMessages includes: context selector]) ifTrue: 
						[(context selectedClass superclass notNil
							and: [context selectedClass superclass canUnderstand: context selector])
								ifTrue: 
									[(context superMessages includes: context selector)
										ifFalse: [result addClass: context selectedClass selector: context selector]]]].
	^detector! !

!RBBasicLintRuleTestData class methodsFor: 'private' stamp: ''!
utilityProtocols
	"If a method is defined in one of these protocols, then don't check if its a utility method."

	^#('*utilit*')! !

!RBBasicLintRuleTestData class methodsFor: 'private' stamp: ''!
classShouldNotOverride
	^#(#== #class)! !

!RBBasicLintRuleTestData class methodsFor: 'instance creation' stamp: ''!
createParseTreeRule: codeStrings name: aName 
	^self createParseTreeRule: codeStrings
		method: false
		name: aName! !

!RBBasicLintRuleTestData class methodsFor: 'bugs' stamp: ''!
subclassResponsibilityNotDefined
	| detector subclassResponsibilitySymbol |
	detector := self new.
	subclassResponsibilitySymbol := 'subclassResponsibility' asSymbol.
	detector name: 'Subclass responsibility not defined'.
	detector classBlock: 
			[:context :result | 
			(context selectedClass whichSelectorsReferTo: subclassResponsibilitySymbol)
				do: 
					[:each | 
					(context selectedClass withAllSubclasses detect: 
							[:class | 
							class subclasses isEmpty
								and: [(class whichClassIncludesSelector: each) == context selectedClass]]
						ifNone: [nil]) notNil
						ifTrue: [result addClass: context selectedClass selector: each]]].
	^detector! !

!RBBasicLintRuleTestData class methodsFor: 'private' stamp: ''!
superMessages
	^#(#release #postCopy #postBuildWith: #preBuildWith: #postOpenWith: #noticeOfWindowClose: #initialize)! !

!RBBasicLintRuleTestData class methodsFor: 'private' stamp: ''!
longMethodSize
	^10! !

!RBBasicLintRuleTestData class methodsFor: 'unnecessary code' stamp: ''!
justSendsSuper
	| detector matcher |
	detector := self new.
	detector name: 'Method just sends super message'.
	matcher := self parseTreeSearcherClass 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! !

!RBBasicLintRuleTestData class methodsFor: 'instance creation' stamp: ''!
createParseTreeRule: codeStrings method: aBoolean name: aName 
	| detector matcher |
	detector := self new.
	detector name: aName.
	matcher := self createMatcherFor: codeStrings method: aBoolean.
	detector methodBlock: 
			[:context :result | 
			(matcher executeTree: context parseTree initialAnswer: false)
				ifTrue: [result addClass: context selectedClass selector: context selector]].
	^detector! !

!RBBasicLintRuleTestData class methodsFor: 'private' stamp: ''!
createMatcherFor: codeStrings method: aBoolean 
	| matcher |
	matcher := self parseTreeSearcher.
	aBoolean
		ifTrue: [matcher addMethodSearches: codeStrings -> [:aNode :answer | true]]
		ifFalse: [matcher addSearches: codeStrings -> [:aNode :answer | true]].
	^matcher! !

!RBBasicLintRuleTestData class methodsFor: 'private' stamp: ''!
metaclassShouldNotOverride
	^#(#name #comment)! !

!RBBasicLintRuleTestData class methodsFor: 'miscellaneous' stamp: ''!
precedence
	| detector matcher |
	detector := self new.
	detector name: 'Inspect instances of "A + B * C" might be "A + (B * C)"'.
	matcher := self parseTreeSearcher.
	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! !

!RBBasicLintRuleTestData class methodsFor: 'private' stamp: ''!
subclassOf: aClass overrides: aSelector 
	| subs |
	subs := aClass subclasses.
	1 to: subs size
		do: 
			[:i | 
			| each |
			each := subs at: i.
			(each includesSelector: aSelector) ifTrue: [^true].
			(self subclassOf: each overrides: aSelector) ifTrue: [^true]].
	^false! !

!RBBasicLintRuleTestData class methodsFor: 'miscellaneous' stamp: ''!
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: 
									[(self parseTreeSearcherClass
										references: context selectedClass allInstVarNames
												, context selectedClass allClassVarNames asArray , #('self')
										in: context parseTree) isEmpty
										ifTrue: [result addClass: context selectedClass selector: context selector]]]]].
	^detector! !

!RBBasicLintRuleTestData class methodsFor: 'private' stamp: ''!
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]! !

!RBBasicLintRuleTestData class methodsFor: 'accessing' stamp: ''!
protocolsToCheck
	^#('bugs' 'possible bugs' 'unnecessary code' 'intention revealing' 'miscellaneous')! !

!RBBinarySelectorToken commentStamp: ''!
RBBinarySelectorToken is the first-class representation of a binary selector (e.g. +)
!
!RBBinarySelectorToken methodsFor: 'testing' stamp: ''!
isBinary
	^true! !

!RBBlockErrorNode commentStamp: ''!
This is a particular englobing node that is a Block.
Exemple : [ block node ]
Can be created by forgetting 
either the opening : block node ]
or the closure : [ block node .
!
!RBBlockErrorNode methodsFor: 'testing' stamp: ''!
isBlockError
	^true! !

!RBBlockErrorNode methodsFor: 'testing' stamp: ''!
repairCollectionFromStart
	" The repair process goes through goes through the statements that are compatible with an array.
	  Begins with all statements included in the array and gets one of every time.
	  The removed statements are to be added in the sequence node."
	| collection result removedStatements |
	collection := self content statements.
	result := OrderedCollection new.
	removedStatements := OrderedCollection new.
	[ collection isNotNil ] 
		whileTrue: [ | statements node | 
						 statements := OrderedCollection new.
						 node :=  RBArrayNode statements: collection.
						 node start: self start.
					 	 statements add: node .
						 result add: statements, removedStatements.
						 removedStatements addFirst: collection last.
						 collection removeLast. ].
	result add: removedStatements.
	^collection.! !

!RBBlockErrorNode class methodsFor: 'construction' stamp: ''!
error: aToken withNodes: aCollection
	"Analyses the token to identify if it's an opening or a closure."
	| message |
	message := ('[' = aToken value asString) ifTrue: [ ''']'' expected' ] 
										  				 ifFalse: [ '''['' expected' ].
	"If the collection is empty, there is only the token in the error."
	aCollection isEmpty
		ifTrue: [ ^self new content: aCollection; start: aToken start; stop: aToken stop; errorMessage: message ].
	"If the collection is not empty, we have to sort where the node begins and where it ends."
	^message = ''']'' expected'
		ifTrue: [ self new content: aCollection; start: aToken start; stop: aCollection last stop; errorMessage: message ]
		ifFalse: [ self new content: aCollection; start: aCollection first start; stop: aToken stop; errorMessage: message ]! !

!RBBlockLintRule commentStamp: ''!
I am a special kind of rule where the verification is specified using a block. The methods checkClass: and checkMethods are the hooks to specify such verifications.!
!RBBlockLintRule methodsFor: 'accessing' stamp: ''!
resultClass
	^ RBSelectorEnvironment! !

!RBBlockLintRule class methodsFor: 'testing' stamp: ''!
isVisible
	^ self name ~= #RBBlockLintRule! !

!RBBlockLintRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'BlockLintRule'! !

!RBBlockNode commentStamp: ''!
RBBlockNode is an AST node that represents a block "[...]".

Like RBMethodNode, the scope attribute is only valid after doing a semantic analyzing step.

Instance Variables:
	arguments	<SequenceableCollection of: RBVariableNode>	the arguments for the block
	bar	<Integer | nil>	position of the | after the arguments
	body	<RBSequenceNode>	the code inside the block
	colons	<SequenceableCollection of: Integer>	positions of each : before each argument
	left	<Integer>	position of [
	right	<Integer>	position of ]
	scope	<OCBlockScope | OCOptimizedBlockScope | nil> the scope associated with this code of this block

!
!RBBlockNode methodsFor: 'accessing - token' stamp: ''!
colons
	^ colons! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
methodOrBlockNode
	^ self! !

!RBBlockNode methodsFor: 'comparing' stamp: ''!
hash
	^ (self hashForCollection: self arguments) bitXor: self body hash! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
children
	^ arguments copyWith: body! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
argumentNames
	^ self arguments collect: [:each | each name] as: Array! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
allDefinedVariables
	^(self argumentNames asOrderedCollection)
		addAll: super allDefinedVariables;
		yourself! !

!RBBlockNode methodsFor: 'accessing - token' stamp: ''!
colons: anArray 
	colons := anArray! !

!RBBlockNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isClean
	"a block is clean if it has no escaping vars, has no non local return and its children are clean"
	self isInlined ifTrue: [ ^ false ].
	self scope hasEscapingVars ifTrue: [ ^ false ].
	self hasBlockReturn ifTrue: [ ^ false ].
	^ super isClean! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
isBlock
	^true! !

!RBBlockNode methodsFor: 'accessing - token' stamp: ''!
right: anInteger
	right := anInteger! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
temporaryNames
	^ self body temporaryNames! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
body
	^body! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
needsParenthesis
	^false! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
lastIsReturn
	^ false! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
startWithoutParentheses
	^ left! !

!RBBlockNode methodsFor: 'comparing' stamp: ''!
equalTo: anObject withMapping: aDictionary 
	self class = anObject class ifFalse: [^false].
	self arguments size = anObject arguments size ifFalse: [^false].
	self arguments
		with: anObject arguments
		do: [:first :second |	(first equalTo: second withMapping: aDictionary) ifFalse: [^false]].
	(self body equalTo: anObject body withMapping: aDictionary)
		ifFalse: [^false].
	self arguments do: [:each | aDictionary removeKey: each name].
	^true! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
arguments
	^arguments! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
headIsNotEmpty
	"Return true whether the receiver has some arguments or comments"
	
	^ arguments isNotEmpty or: [ self comments isNotEmpty ]! !

!RBBlockNode methodsFor: 'accessing - token' stamp: ''!
left
	^ left! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
temporaries
	^ self body temporaries! !

!RBBlockNode methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self arguments: (self arguments collect: [ :each | each copy ]).
	self body: self body copy! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
blockVariables
	| vars |
	vars := super blockVariables asOrderedCollection.
	vars addAll: self argumentNames.
	^vars! !

!RBBlockNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	arguments := #().
	colons := #().
	left := 0.
	right := 0! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
directlyUses: aNode 
	^false! !

!RBBlockNode methodsFor: '*OpalCompiler-Core' stamp: ''!
ir

	^ self propertyAt: #ir ifAbsent: [ self parent methodOrBlockNode ir ]! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
allStatements
	"including temp variable definition."
	^ self temporaries asOrderedCollection copy
			addAll: super allStatements;
			yourself! !

!RBBlockNode methodsFor: '*OpalCompiler-Core' stamp: ''!
irInstruction
	^ self parent methodOrBlockNode ir firstInstructionMatching: [:instr | instr sourceNode == self ]! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
statementComments
	"this is used for formatting comments for this node as a statement, but I don't have a single statement comment, my comments are place within the block code"

	^ ''! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
precedence
	^0! !

!RBBlockNode methodsFor: 'matching' stamp: ''!
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: 'adding/removing' stamp: ''!
removeTemporaryNamed: aName

	self body removeTemporaryNamed: aName! !

!RBBlockNode methodsFor: '*OpalCompiler-Core' stamp: ''!
owningScope

	^ self scope ifNil: ["inlined" ^ parent owningScope]! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
scope: aScopedNode
	scope := aScopedNode! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
stopWithoutParentheses
	^ right! !

!RBBlockNode methodsFor: 'accessing - token' stamp: ''!
left: anInteger
	left := anInteger! !

!RBBlockNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [^true].
	self class = anObject class ifFalse: [^false].
	self body = anObject body ifFalse: [^false].
	self arguments size = anObject arguments size ifFalse: [^false].
	self arguments with: anObject arguments do: [:first :second | first = second ifFalse: [^false]].
	^true! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
isImmediateNode
	^true! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
isLast: aNode 
	^body isLast: aNode! !

!RBBlockNode methodsFor: '*OpalCompiler-Core' stamp: ''!
bcToASTCache
	^ bcToASTCache ifNil: [ bcToASTCache := OCBytecodeToASTCache generateForNode: self ]! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
arguments: argCollection 
	arguments := argCollection.
	arguments do: [:each | each parent: self ]! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
isFaulty
	^(self arguments anySatisfy: [:each | each isFaulty] ) or: [ self body isFaulty]! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
allArgumentVariables
	^(self argumentNames asOrderedCollection)
		addAll: super allArgumentVariables;
		yourself! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
hasArguments

	^ arguments isNotEmpty! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
hasTemporaryNamed: aString	
	^ self temporaries anySatisfy: [ :temp| temp name = aString ]! !

!RBBlockNode methodsFor: 'accessing - token' stamp: ''!
bar
	^ bar! !

!RBBlockNode methodsFor: '*OpalCompiler-Core' stamp: ''!
ir: aIRMethodNode

	^ self propertyAt: #ir put: aIRMethodNode.! !

!RBBlockNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlinedLoop

	parent isMessage ifFalse: [ ^ false ].
	parent isInlineToDo ifTrue: [^ true].
	parent isInlineWhile ifTrue: [^ true].
	parent isInlineTimesRepeat ifTrue: [^ true].
	parent isInlineRepeat ifTrue: [ ^true ].
	(parent parent isDynamicArray and: [parent parent parent isMessage and: [parent parent parent isInlineCase]]) ifTrue: [^ true].
	parent isInlineCase ifTrue: [^ true].  "otherwise branch"
	^ false! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
uses: aNode 
	aNode = body ifFalse: [^false].
	^parent isMessage 
		ifTrue: 
			[(#(#ifTrue:ifFalse: #ifTrue: #ifFalse: #ifFalse:ifTrue:) 
				includes: parent selector) not 
				or: [parent isUsed]]
		ifFalse: [self isUsed]! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
body: stmtsNode 
	body := stmtsNode.
	body parent: self! !

!RBBlockNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	body == aNode ifTrue: [self body: anotherNode].
	self arguments: (arguments 
				collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! !

!RBBlockNode methodsFor: 'accessing - token' stamp: ''!
right
	^ right! !

!RBBlockNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitBlockNode: self! !

!RBBlockNode methodsFor: 'accessing - token' stamp: ''!
bar: anInteger
	bar := anInteger! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
statements
	^ self body statements! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
hasTemporaries

	^ self temporaries isNotEmpty! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
defines: aName 
	^arguments anySatisfy: [:each | each name = aName]! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
hasArgumentNamed: aString	
	^ self arguments anySatisfy: [ :argument| argument name = aString ]! !

!RBBlockNode methodsFor: '*OpalCompiler-Core' stamp: ''!
sourceNodeForPC: anInteger 
	self methodNode ir.
	(self hasProperty: #ir) ifTrue: [ "FullBlockClosure"
		^ self bcToASTCache nodeForPC: anInteger].
	^ self methodNode sourceNodeForPC: anInteger! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
references: aVariableName 
	^body references: aVariableName! !

!RBBlockNode methodsFor: 'testing' stamp: ''!
hasBlockReturn
	^ self body lastIsReturn! !

!RBBlockNode methodsFor: 'accessing' stamp: ''!
scope
	^ scope! !

!RBBlockNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	^ self class new
		arguments: (self copyList: self arguments inContext: aDictionary);
		body: (self body copyInContext: aDictionary);
		yourself! !

!RBBlockNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlined
	parent isMessage ifFalse: [ ^ false ].
	parent isInlineAndOr ifTrue: [^ true].
	parent isInlineIf ifTrue: [^ true].
	parent isInlineIfNil ifTrue: [^ true].
	^ self isInlinedLoop! !

!RBBlockNode class methodsFor: 'instance creation' stamp: ''!
arguments: argNodes body: sequenceNode 
	^(self new)
		arguments: argNodes;
		body: sequenceNode;
		yourself! !

!RBBlockNode class methodsFor: 'instance creation' stamp: ''!
body: sequenceNode 
	^self arguments: #() body: sequenceNode! !

!RBBlockReplaceRule commentStamp: ''!
RBBlockReplaceRule replaces the matching node by the result of evaluating replaceBlock. This allows arbitrary computation to come up with a replacement.

Instance Variables:
	replaceBlock	<BlockClosure>	The block that returns the node to replace the matching node.
!
!RBBlockReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForTree: aBRProgramNode replaceWith: aBlock 
	searchTree := aBRProgramNode.
	replaceBlock := aBlock! !

!RBBlockReplaceRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	replaceBlock := [:aNode | aNode]! !

!RBBlockReplaceRule methodsFor: 'private - searching' stamp: ''!
searchFor: searchString replaceWith: replBlock when: verifyBlock 
	self searchFor: searchString replaceWith: replBlock.
	verificationBlock := verifyBlock! !

!RBBlockReplaceRule methodsFor: 'matching' stamp: ''!
foundMatchFor: aProgramNode 
	| newNode |
	newNode := replaceBlock value: aProgramNode.
	aProgramNode replaceMethodSource: newNode.
	^newNode! !

!RBBlockReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForTree: aBRProgramNode replaceWith: replBlock when: verifyBlock 
	self searchForTree: aBRProgramNode replaceWith: replBlock.
	verificationBlock := verifyBlock! !

!RBBlockReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForMethod: searchString replaceWith: aBlock 
	self methodSearchString: searchString.
	replaceBlock := aBlock! !

!RBBlockReplaceRule methodsFor: 'private - searching' stamp: ''!
searchFor: searchString replaceWith: aBlock 
	self searchString: searchString.
	replaceBlock := aBlock! !

!RBBlockReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForMethod: searchString replaceWith: replBlock when: verifyBlock 
	self searchForMethod: searchString replaceWith: replBlock.
	verificationBlock := verifyBlock! !

!RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchForTree: aRBProgramNode replaceWith: replaceBlock 
	^self new searchForTree: aRBProgramNode replaceWith: replaceBlock! !

!RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchFor: searchString replaceWith: replaceBlock when: aBlock 
	^self new 
		searchFor: searchString
		replaceWith: replaceBlock
		when: aBlock! !

!RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchForTree: aRBProgramNode replaceWith: replaceBlock when: aBlock 
	^self new 
		searchForTree: aRBProgramNode
		replaceWith: replaceBlock
		when: aBlock! !

!RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchForMethod: searchString replaceWith: replaceBlock 
	^self new searchForMethod: searchString replaceWith: replaceBlock! !

!RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchFor: searchString replaceWith: replaceBlock 
	^self new searchFor: searchString replaceWith: replaceBlock! !

!RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchForMethod: searchString replaceWith: replaceBlock when: aBlock 
	^self new 
		searchForMethod: searchString
		replaceWith: replaceBlock
		when: aBlock! !

!RBBrowserClassRefactoringHelp commentStamp: ''!
This is the chapter of the refactoring help book about the class refactoring available in the System Browser.!
!RBBrowserClassRefactoringHelp class methodsFor: 'pages' stamp: ''!
insertSubclassRefactoring
	^HelpTopic
		title: 'Insert Subclass'
		contents: 
'
Just generate a new class between this class and its subclasses.
The name of the new class needs to be a valid class name, not yet used as any global identifier.
'
! !

!RBBrowserClassRefactoringHelp class methodsFor: 'pages' stamp: ''!
removeClassRefactoring
	^HelpTopic
		title: 'Remove'
		contents: RBRemoveClassRefactoring comment! !

!RBBrowserClassRefactoringHelp class methodsFor: 'pages' stamp: ''!
removeClassKeepingSubclassesRefactoring
	^HelpTopic
		title: 'Remove keeping subclasses'
		contents: RBRemoveClassKeepingSubclassesRefactoring comment! !

!RBBrowserClassRefactoringHelp class methodsFor: 'pages' stamp: ''!
generateAccessorRefactoring
	^HelpTopic
		title: 'Generate Accessor'
		contents: 
'
Generates setter and getter methods for every instance variable defined in this class. The user is provided with a changes browser dialog allowing to select and unselected the creation of single methods. The name for the accessors is auto-generated by the instance variable name. If a method with this name already exists, the new name will have a incremented counter.
'
! !

!RBBrowserClassRefactoringHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(renameClassRefactoring removeClassRefactoring removeClassKeepingSubclassesRefactoring generateAccessorRefactoring generateSuperclassRefactoring insertSuperclassRefactoring insertSubclassRefactoring generateSubclassRefactoring realizeClassRefactoring splitClassRefactoring)! !

!RBBrowserClassRefactoringHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Class Refactorings'! !

!RBBrowserClassRefactoringHelp class methodsFor: 'pages' stamp: ''!
generateSubclassRefactoring
	^HelpTopic
		title: 'Generate Subclass'
		contents: 
'
Adds a new class as a subclass of the selected class. It offers a check box list of the subclasses. Every checked element will be moved to be a sub-subclass of the new subclass. The hierarchy of the not checked elements is unchanged and they become siblings of the new class.
The name of the new class needs to be a valid class name, not yet used as any global identifier.
'
! !

!RBBrowserClassRefactoringHelp class methodsFor: 'pages' stamp: ''!
renameClassRefactoring
	^HelpTopic
		title: 'Rename'
		contents: RBRenameClassRefactoring comment
! !

!RBBrowserClassRefactoringHelp class methodsFor: 'pages' stamp: ''!
splitClassRefactoring
	^HelpTopic
		title: 'Split'
		contents: RBSplitClassRefactoring comment
! !

!RBBrowserClassRefactoringHelp class methodsFor: 'pages' stamp: ''!
generateSuperclassRefactoring
	^HelpTopic
		title: 'Generate Superclass'
		contents: 
'
Adds a new superclass between a class and its previous superclass. It offers a check-box list of the subclasses. Every checked element will be moved to be a subclass of the new superclass. That is, subclasses are moved to siblings of its prior superclass. Every instance variable shared by the new siblings will be moved to the new superclass.
The name of the new class needs to be a valid class name, not yet used as any global identifier.
'
! !

!RBBrowserClassRefactoringHelp class methodsFor: 'pages' stamp: ''!
realizeClassRefactoring
	^HelpTopic
		title: 'Realize'
		contents: RBRealizeClassRefactoring comment! !

!RBBrowserClassRefactoringHelp class methodsFor: 'pages' stamp: ''!
insertSuperclassRefactoring
	^HelpTopic
		title: 'Insert Superclass'
		contents: 
'
Similar to "Generate Superclass", but just generates a new class between a class and its previous superclass. With no change on the subclass hierarchy of the class.
The name of the new class needs to be a valid class name, not yet used as any global identifier.
'
! !

!RBBrowserEnvironment commentStamp: ''!
I am the base class for environments of the refactoring framework.

I define the common interface for all environments.
And I act as a factory for various specialized environments. See my 'environment' protocol.

I am used by different tools to create a 'views' of subsets of the whole system environment to browse or act on (searching/validations/refactoring)

create instances:
RBBrowserEnvironment new forClasses:  Number withAllSubclasses.
RBBrowserEnvironment new forPackageNames: { #Kernel }.

query:
|env|
env := RBBrowserEnvironment new forPackageNames: { #Kernel }.
env referencesTo:#asArray.
-> RBSelectorEnvironment.

browse:
|env|
env := RBBrowserEnvironment new forPackageNames: { #Kernel }.
(Smalltalk tools browser browsedEnvironment: env) open.
!
!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
problemCount
	^self numberSelectors! !

!RBBrowserEnvironment methodsFor: 'cleaning' stamp: ''!
cleanGarbageInCache

	self accessGuard critical: [ self queryCache clyCleanGarbage ]! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
allClasses
	"Answer all the unique non-metaclasses of all the classes and metaclasses in this environment."

	| allClasses |
	allClasses := IdentitySet new: 4096.
	self classesDo: [ :each | 
		allClasses add: each instanceSide].
	^ allClasses asArray! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
forClassHierarchy: aClass
	^ RBClassHierarchyEnvironment class: aClass! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
isClassEnvironment
	^ false! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass
	^ true! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
numberSelectors
	| total |
	total := 0.
	self selectorsDo: [:sel | total := total + 1 ].
	^total! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
associationAt: aKey
	^ self associationAt: aKey ifAbsent: [ self error: aKey printString , ' not found' ]! !

!RBBrowserEnvironment methodsFor: 'accessing - packages' stamp: ''!
packageAt: aName
	^ self packageAt: aName ifAbsent: [ NotFound signalFor: aName in: self ]! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
classesAndSelectorsDo: aBlock 
	self classesDo: [ :class | 
		self selectorsForClass: class do: [ :sel | 
			aBlock value: class value: sel ]]! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
asSelectorEnvironment
	^(RBClassEnvironment onEnvironment: self classes: self classes) asSelectorEnvironment! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
allMetaClasses
	"Answer all the unique non-metaclasses of all metaclasses in this environment."

	| allMetaClasses |
	allMetaClasses := OrderedCollection new: 4096.
	self
		classesDo: [ :each | 
			each isMeta
				ifTrue: [ allMetaClasses add: each instanceSide ] ].
	^ allMetaClasses asArray! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
whichCategoryIncludes: aClassName
	^ self systemDictionary organization categoryOfElement: aClassName! !

!RBBrowserEnvironment methodsFor: 'announcements' stamp: ''!
handleSystemChange: aSystemAnnouncement

	| todoList todoSize anyResult |
	todoList := 	(queryCache values select: [ :each | each notNil ]) as: IdentitySet.
	todoSize := 0.
	[[todoSize = todoList size] whileFalse: [
		todoSize := todoList size.  
		todoList asArray do: [ :eachResult |
			(todoList includes: eachResult) ifTrue: [  
				eachResult handleSystemChange: aSystemAnnouncement byProcessingList: todoList]]].
	todoList notEmpty] whileTrue: [ 
		anyResult := todoList anyOne.
		anyResult handleSystemChange: aSystemAnnouncement.
		todoList remove: anyResult]! !

!RBBrowserEnvironment methodsFor: '*Refactoring-Core' stamp: ''!
classesInPackages: aColl do: aBlock 
	self systemDictionaryClassesDo: [ :each |
		(self includesClass: each) & (aColl anySatisfy: [ :cat | cat , '*' match: each category ])
			ifTrue: [aBlock value: each ] ]! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
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: 'environments' stamp: ''!
withoutClasses: aListOfClasses
	"Build the same environment without classes given as parameter"
	^ RBClassEnvironment 
			onEnvironment: self 
			classes: (self classes copyWithoutAll: aListOfClasses)! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
classVariablesFor: aClass 
	^aClass classVarNames! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
accessGuard
	^ accessGuard ifNil: [ accessGuard := Mutex new ]! !

!RBBrowserEnvironment methodsFor: 'queries' stamp: ''!
adoptQuery: aQuery
	aQuery scope: self.
	^aQuery! !

!RBBrowserEnvironment methodsFor: 'private' stamp: ''!
allClassesDo: aBlock
	self systemDictionaryClassesDo: aBlock! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
addSearchString: aString

	searchStrings
		ifNil: [ 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: ''!
categories
	^ self systemDictionary organization categories select: [ :each | self includesCategory: each ]! !

!RBBrowserEnvironment methodsFor: 'initialization' stamp: ''!
label: aString
	label := aString! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
plugins

	^ plugins ifNil: [ self defaultPlugins ]! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
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 ifNotNil: [ 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' stamp: ''!
selectorsForClass: aClass 
	| selectors |
	selectors := IdentitySet new.
	self selectorsForClass: aClass do: [ :each | selectors add: each ].
	^ selectors! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
forClass: aClass selectors: selectorCollection 
	^(RBSelectorEnvironment 
		onMethods: selectorCollection
		forClass: aClass
		in: self)
		label: aClass name , '>>' 
					, (selectorCollection detect: [:each | true] ifNone: ['']);
		yourself! !

!RBBrowserEnvironment methodsFor: 'printing' stamp: ''!
printDescriptionOn: aStream

	aStream nextPutAll: self description! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
supportsQuery: aQuery

	^true! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
forPragmas: aKeywordCollection
	^ RBPragmaEnvironment onEnvironment: self keywords: aKeywordCollection! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
selectorsDo: aBlock
	self allClassesDo: [ :each | 
		self selectorsForClass: each do: aBlock ].! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
instanceVariablesFor: aClass 
	^aClass instVarNames! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
definesClass: aClass
	^ true! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
isBoundToEnvironment

	^ true! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
defaultPlugins

	^ OrderedCollection new! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
forClass: aClass protocols: protocolCollection 
	^RBProtocolEnvironment onEnvironment: self
		class: aClass
		protocols: protocolCollection! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
instVarRefsTo: instVarName in: aClass 
	^RBVariableEnvironment 
		on: self
		referencesToInstanceVariable: instVarName
		in: aClass! !

!RBBrowserEnvironment methodsFor: '*Calypso-NavigationModel' stamp: ''!
updateStrategy
	^ updateStrategy ifNil: [ updateStrategy := ClyInstantEnvironmentUpdateStrategy new ]! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
methodsDo: aBlock
	
	self classesDo: [ :aClass |
		
		self selectorsForClass: aClass do: [ :selector |
			aBlock value: (aClass >> selector) ].
		self selectorsForClass: aClass class do: [ :selector |
			aBlock value: (aClass class >> selector) ] ]! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
| 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: 'environments' stamp: ''!
classVarRefsTo: instVarName in: aClass 
	^ RBVariableEnvironment 
		on: self
		referencesToClassVariable: instVarName
		in: aClass! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
implementorsOf: aSelector 
	^RBSelectorEnvironment implementorsOf: aSelector in: self! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
isCompositeEnvironment

	^ false! !

!RBBrowserEnvironment methodsFor: 'accessing - packages' stamp: ''!
packages

	^ self packageOrganizer packages
		select: [ :package |
			self includesCategory: package name ]! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
at: aKey ifAbsent: aBlock

	| association |

	association := self associationAt: aKey ifAbsent: [ nil ].
	^ association ifNil: [ aBlock value ] ifNotNil: [ association value ]! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
instVarWritersTo: instVarName in: aClass 
	^RBVariableEnvironment 
		on: self
		writersOfInstanceVariable: instVarName
		in: aClass! !

!RBBrowserEnvironment methodsFor: 'accessing - packages' stamp: ''!
packageAt: aName ifAbsent: absentBlock
	| package |
	package := self packageOrganizer 
		packageNamed: aName ifAbsent: absentBlock.
	
	^ (self includesCategory: aName)
		ifTrue: [ package ]
		ifFalse: absentBlock! !

!RBBrowserEnvironment methodsFor: 'actions' stamp: ''!
inspectIn: spec

	^ (spec instantiate: SpFilteringListPresenter)
		  items: self basisObjects asArray;
		  yourself! !

!RBBrowserEnvironment methodsFor: 'private' stamp: ''!
packageOrganizer

	^ RPackageOrganizer default! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
protocolsFor: aClass
	^aClass organization categories 
		select: [ :each | self includesProtocol: each in: aClass ]! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
includesSelector: aSelector in: aClass
	^ true! !

!RBBrowserEnvironment methodsFor: 'private' stamp: ''!
allClassesAndTraitsDo: aBlock
	self systemDictionary allClassesAndTraitsDo: aBlock! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
forClasses: classCollection 
	| classes |
	classes := OrderedCollection new: classCollection size * 2.
	classCollection do: 
			[:each | 
			classes add: each instanceSide; add: each classSide].
	^RBClassEnvironment onEnvironment: self classes: classes! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
forCategories: categoryList 
	^RBCategoryEnvironment onEnvironment: self categories: categoryList! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
traits
	| traits |
	traits := IdentitySet new: 4096.
	self traitsDo: [ :each | traits add: each ].
	^ traits! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
defaultName

	^ self class defaultName! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
includesMethod: aMethod
	^ self 
		includesSelector: aMethod selector
		in: aMethod methodClass! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
referencesTo: aLiteral 
	^RBSelectorEnvironment referencesTo: aLiteral in: self! !

!RBBrowserEnvironment methodsFor: 'description' stamp: ''!
shortDescription

	^ self description contractTo: 50! !

!RBBrowserEnvironment methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream
		nextPutAll: self class name;
		nextPutAll: ' new'! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
traitsDo: aBlock

	self systemDictionary allTraitsDo: [ :each | 
		(self includesClass: each)
			ifTrue: [ aBlock value: each ]  ]! !

!RBBrowserEnvironment methodsFor: 'accessing - packages' stamp: ''!
packagesWithContributors
	"answer a list of all packages contributing to the definition of classes in the environment"
	^ self classes 
		flatCollect: #packages
		as: Set! !

!RBBrowserEnvironment methodsFor: 'private' stamp: ''!
environment
	^ self! !

!RBBrowserEnvironment methodsFor: 'description' stamp: ''!
description

	^ self defaultName! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
queryCache

	^queryCache ifNil: [ queryCache := WeakValueDictionary new ]! !

!RBBrowserEnvironment methodsFor: 'private' stamp: ''!
rootEnvironment
	"The root environment representing everything."

	^ self! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
allClassesAndTraits
	" compatibility method with SystemDictionary "
	
	| allClassesAndTraits |
	allClassesAndTraits := OrderedCollection new: 4096.
	self allClassesAndTraitsDo: [ :each | 
		allClassesAndTraits add: each ].
	^ allClassesAndTraits asArray! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
classesAndTraits
	
	| classesAndTraits |
	classesAndTraits := OrderedCollection new: 4096.
	self classesAndTraitsDo: [ :each | 
		classesAndTraits add: each ].
	^ classesAndTraits asArray! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
whichProtocolIncludes: aSelector in: aClass
	^aClass organization categoryOfElement: aSelector ifAbsent: [ Protocol unclassified ]! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
numberClasses
	^self classNames size! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
not
	self isSystem ifTrue: [^RBSelectorEnvironment new].
	^RBNotEnvironment onEnvironment: self! !

!RBBrowserEnvironment methodsFor: 'actions' stamp: ''!
updateUsing: newUpdateStrategy by: updateBlock
	"here is special logic to break current mutex when any error is signalled.
	Without this logic fixing code inside spawned debugger will lead to deadlock
	because applying method changes will blocked at this accessGuard.
	Breaking mutex is done by creating new one which meand that current process
	is not guarded any more and proceeding execution in debugger can lead to some errors in rare cases. But it is less problem than locked UI"
	[
		self updateGuard critical: [ | oldStrategy |
			oldStrategy := updateStrategy.
			[
				updateStrategy := newUpdateStrategy.
				updateBlock on: Error do: [ :err |
					updateStrategy := oldStrategy.
					updateGuard := Mutex new.
					err pass]
			] ensure: [ 
				self updateStrategy == newUpdateStrategy ifTrue: [ 
					"In case of error another process can set up new strategy. 
					This condition will avoid possible collision"
					updateStrategy := oldStrategy ]]]
	] ensure: [ newUpdateStrategy publishCollectedChanges]! !

!RBBrowserEnvironment methodsFor: 'private' stamp: ''!
label

	^ label ifNil: [ self defaultLabel ] ifNotNil: [ label ]! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
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: 'actions' stamp: ''!
pluginsDo: aBlock
	^ self plugins do: aBlock! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
selectors
	^ Array streamContents: [ :stream |
		self selectorsDo: [ :selector | 
			stream nextPut: selector ]]! !

!RBBrowserEnvironment methodsFor: 'private' stamp: ''!
systemDictionaryClassesDo: aBlock
	self systemDictionary allClassesDo:[:class |
		 aBlock value: class; value: class classSide]! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
forPackageNames: aCollection
	^ RBPackageEnvironment onEnvironment: self packageNames: aCollection! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
& 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: 'testing' stamp: ''!
includesCategory: aCategory
	^ true! !

!RBBrowserEnvironment methodsFor: 'private' stamp: ''!
systemDictionary
	"The root system dictionary as the source of all objects in this environment."

	^ Smalltalk globals! !

!RBBrowserEnvironment methodsFor: '*Manifest-Core' stamp: ''!
isMultiEnvironment
	^ false! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
classesAndTraitsDo: aBlock 
	self allClassesAndTraitsDo: [ :each |
		(self includesClass: each)
			ifTrue: [ aBlock value: each ] ]! !

!RBBrowserEnvironment methodsFor: 'queries' stamp: ''!
cachedResultOf: aQuery

	^self queryCache at: aQuery ifAbsent: [ nil ]! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
includesPackage: packageName
	^ true! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
isVariableEnvironment
	^ false! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass
	^ true! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
matches: aString 
	^RBSelectorEnvironment matches: aString in: self! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
selectorsFor: aProtocol in: aClass
	^(aClass organization listAtCategoryNamed: aProtocol)
		select: [:each | self includesSelector: each in: aClass]! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
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: 'testing' stamp: ''!
isEmpty
	^ false! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
updateGuard

	^ updateGuard ifNil: [ updateGuard := Mutex new ]! !

!RBBrowserEnvironment methodsFor: 'converting' stamp: ''!
asRBEnvironment
 
	^ self! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
keys
	| keys |
	keys := Set new.
	self systemDictionary keysAndValuesDo: [ :key :value | 
		| class |
		value isBehavior ifTrue: [
			(self includesClass: value) 
				ifTrue: [ keys add: key ] ].
			class := value class.
			(self includesClass: class) 
				ifTrue: [ keys add: key ] ].
	^ keys! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
searchStrings

	^ searchStrings ifNil: [ #() ] ifNotNil: [ searchStrings ]! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
implementorsMatching: aString 
	^RBSelectorEnvironment implementorsMatching: aString in: self! !

!RBBrowserEnvironment methodsFor: 'description' stamp: ''!
descriptionUntil: aNumber

	^ self description contractTo: aNumber! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
isSystem
	^ true! !

!RBBrowserEnvironment methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: self label! !

!RBBrowserEnvironment methodsFor: 'announcements' stamp: ''!
announceChangesOf: aQueryResult

	self updateStrategy announceChangesOf: aQueryResult! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
at: aKey
	^ self at: aKey ifAbsent: [ self error: aKey printString , ' not found' ]! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
classesDo: aBlock 
	self systemDictionaryClassesDo: [ :each |
		(self includesClass: each)
			ifTrue: [aBlock value: each ] ]! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
methods
	| methods |
	methods := IdentitySet new: 4096.
	self methodsDo: [ :each | methods add: each ].
	^ methods! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
classes
	| classes |
	classes := IdentitySet new: 4096.
	self classesDo: [ :each | classes add: each ].
	^ classes! !

!RBBrowserEnvironment methodsFor: 'private' stamp: ''!
defaultLabel
	^ 'Smalltalk'! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
forPackages: aCollection
	^ RBPackageEnvironment onEnvironment: self packages: aCollection! !

!RBBrowserEnvironment methodsFor: 'copying' stamp: ''!
copyEmpty
	^ self class new! !

!RBBrowserEnvironment methodsFor: 'queries' stamp: ''!
query: aQuery

	| result |
	self cleanGarbageInCache.
	result := self queryCache at: aQuery ifAbsent: [nil]. "cache is weak dict where ifAbsentPut: not works"
	result ifNil: [  
		result := aQuery prepareNewResult.
		aQuery fixStateBeforeExecution.
		"We should ensure that state of query will not be modified after execution 
		because it is the key in cache.
		So aQuery is supposed to become readonly object together with required internal state"
		self accessGuard critical: [ self queryCache at: aQuery put: result]].	
	result rebuildIfNeeded.
	^result! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
classNames
	| names |
	names := IdentitySet new: 4096.
	self classesDo: [ :each | names add: each instanceSide name ].
	^ names! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
searchStrings: aCollection 
	searchStrings := aCollection! !

!RBBrowserEnvironment methodsFor: '*Calypso-NavigationModel' stamp: ''!
systemChanged: aSystemAnnouncement

	self updateUsing: ClyFullEnvironmentUpdateStrategy new by: [
		self handleSystemChange: aSystemAnnouncement 
	]! !

!RBBrowserEnvironment methodsFor: 'accessing - classes' stamp: ''!
allNonMetaClasses
	"Answer all the unique non-metaclasses of all of all the non-metaclasses in this environment."
	| allNonMetaClasses |
	allNonMetaClasses := OrderedCollection new: 4096.
	self
		classesDo: [ :each | 
			each isMeta
				ifFalse: [ allNonMetaClasses add: each  ] ].
	^ allNonMetaClasses asArray! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
isSelectorEnvironment
	^ false! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
instVarReadersTo: instVarName in: aClass 
	^RBVariableEnvironment 
		on: self
		readersOfInstanceVariable: instVarName
		in: aClass! !

!RBBrowserEnvironment methodsFor: 'environments' stamp: ''!
referencesTo: aLiteral in: aClass 
	| classes |
	classes := aClass withAllSuperclasses asSet.
	classes
		addAll: aClass allSubclasses;
		addAll: aClass class withAllSuperclasses;
		addAll: aClass class allSubclasses.
	^(self forClasses: classes) referencesTo: aLiteral! !

!RBBrowserEnvironment methodsFor: 'accessing' stamp: ''!
selectionIntervalFor: aString 
	| interval |
	self searchStrings ifEmpty: [^nil].
	interval := self selectionParseTreeIntervalFor: aString.
	interval ifNotNil: [^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: ''!
selectorsForClass: aClass do: aBlock 
	aClass selectorsAndMethodsDo: 
			[:each :meth | 
			(self includesSelector: each in: aClass) ifTrue: [aBlock value: each]]! !

!RBBrowserEnvironment methodsFor: 'testing' stamp: ''!
isBasedOnEmptyBasis

	^false! !

!RBBrowserEnvironment class methodsFor: 'accessing' stamp: ''!
defaultName
	^ 'Current image'! !

!RBBrowserEnvironment class methodsFor: 'accessing' stamp: ''!
default
	^ RBBrowserEnvironment new! !

!RBBrowserEnvironmentTest commentStamp: ''!
Unit test for RBBrowserEnvironment!
!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
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 packages size) equals: 1.
	self assert: (aClassEnvironment implementorsOf: #printString) numberSelectors equals: 1.
	
	self assert: (RBClassEnvironment class: Class) selectors size 
    	  equals: Class methods size.
	self assert: (RBClassEnvironment class: TSortable) selectors size
    	  equals: TSortable methods size.! !

!RBBrowserEnvironmentTest methodsFor: 'tests' stamp: ''!
testVariableEnvironmentClassVars
	"test variable environment for class vars, refered on the class side only"

	| classRefs |
	classRefs := RBVariableEnvironment referencesToClassVariable: 'ClassSideOnlyVariable' in: self class.
	self universalTestFor: classRefs.
	self denyEmpty: classRefs methods! !

!RBBrowserEnvironmentTest methodsFor: 'tests' stamp: ''!
testImplementorsMatching
	| print |
	print := RBBrowserEnvironment new implementorsMatching: '*print*'.
	self universalTestFor: print.
	self assert: (print implementorsOf: #printString) numberSelectors 
				equals: (RBBrowserEnvironment new implementorsOf: #printString) numberSelectors.
	print 
		classesAndSelectorsDo: [:class :sel | self assert: ('*print*' match: sel)]! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
storeStringFor: aBrowserEnvironment
	| newEnvironment |
	newEnvironment := Smalltalk compiler evaluate: aBrowserEnvironment storeString.
	self assert: newEnvironment numberSelectors equals: aBrowserEnvironment numberSelectors.
	self assert: (newEnvironment not & aBrowserEnvironment) numberSelectors equals: 0
	! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testPackageEnvironment
	| aPackageEnvironment |
	aPackageEnvironment := universalEnvironment
		forPackageNames: (Array with: 'Refactoring-Tests-Environment' with: 'Refactoring-Tests-Critics').
	self universalTestFor: aPackageEnvironment.
	self assert: (aPackageEnvironment implementorsOf: #testPackageEnvironment) numberSelectors equals: 1! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
copyFor: aBrowserEnvironment
	| newEnvironment |
	newEnvironment := aBrowserEnvironment copy.
	self assert: newEnvironment numberSelectors equals: aBrowserEnvironment numberSelectors.
	self assert: (newEnvironment not & aBrowserEnvironment) numberSelectors equals: 0! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
keysFor: aBrowserEnvironment
	| allKeys |
	allKeys := IdentitySet withAll: aBrowserEnvironment keys.
	allKeys addAll: aBrowserEnvironment not keys.
	allKeys removeAll: testingEnvironment keys.
	self assertEmpty: allKeys! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testCategoryEnvironment
	| aCategoryEnvironment |
	self skip: 'Use RBPackageEnvironment instead.'.
	aCategoryEnvironment := RBCategoryEnvironment 
				onEnvironment: RBBrowserEnvironment new
				categories: #(#'Kernel-Objects').
	self universalTestFor: aCategoryEnvironment.
	self assert: (aCategoryEnvironment implementorsOf: #printString) numberSelectors equals: 1! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testProtocolEnvironment
	| aProtocolEnvironment size |
	aProtocolEnvironment := RBProtocolEnvironment 
				onEnvironment: RBBrowserEnvironment new
				class: Object
				protocols: #(#printing #testing).
	self universalTestFor: aProtocolEnvironment.
	self 
		assert: (aProtocolEnvironment implementorsOf: #printString) numberSelectors 
				equals: 1.
	size := 0.
	aProtocolEnvironment classesDo: [:each | size := size + 1].
	self assert: size equals: 1.
	aProtocolEnvironment selectorsForClass: Object
		do: 
			[:each | 
			self assert: (#(#printing #testing) 
						includes: (RBBrowserEnvironment new whichProtocolIncludes: each in: Object))]! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
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 assertEmpty: (universalEnvironment classNamesFor: each) ]! !

!RBBrowserEnvironmentTest methodsFor: 'tests' stamp: ''!
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 equals: 1.
	self assert: (environment includesClass: OrderedCollection).
	self assert: (environment selectorsForClass: OrderedCollection) size equals: 1.
	self assert: (environment includesClass: Collection).
	self assert: (environment selectorsForClass: Collection) size 
				equals: 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 equals: 2.
	self 
		assert: newEnvironment numberSelectors + 1 equals: environment numberSelectors.
	newEnvironment addClass: Object class.
	self assert: newEnvironment numberClasses equals: 2.
	self assert: (newEnvironment includesClass: Object class).
	newEnvironment removeClass: self class.
	self assert: newEnvironment numberClasses equals: 2! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
classesFor: aBrowserEnvironment
	| allClasses |
	allClasses := aBrowserEnvironment classes asSet.
	allClasses addAll: aBrowserEnvironment not classes.
	RBBrowserEnvironment new allClassesDo: [ :each | allClasses remove: each ].
	self assertEmpty: allClasses! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testPragmaEnvironment
	| aPragmaEnvironment |
	aPragmaEnvironment := universalEnvironment forPragmas: #(primitive:).
	self universalTestFor: aPragmaEnvironment! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testSelectorEnvironment
	| printString |
	printString := RBBrowserEnvironment new referencesTo: #printString.
	self universalTestFor: printString.
	self deny: universalEnvironment isSelectorEnvironment.
	self assert: printString isSelectorEnvironment.
	self assert: printString numberSelectors equals: (printString referencesTo: #printString) numberSelectors.
	self assert: printString numberClasses equals: (printString referencesTo: #printString) numberClasses! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
numberSelectorsFor: aBrowserEnvironment
	| numberSelectors numberSelectorsNot |
	numberSelectors := aBrowserEnvironment numberSelectors.
	numberSelectorsNot := aBrowserEnvironment not numberSelectors.
	self assert: numberSelectors + numberSelectorsNot equals: universalEnvironment numberSelectors.
	self assert: (aBrowserEnvironment & aBrowserEnvironment not) numberSelectors equals: 0.
	self assert: (universalEnvironment & aBrowserEnvironment) numberSelectors equals: numberSelectors.
	self assert: (aBrowserEnvironment & universalEnvironment) numberSelectors equals: numberSelectors! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testBrowserEnvironment
	self universalTestFor: RBBrowserEnvironment new! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testNotEnvironment
	| notPrintStringEnvironment printStringEnvironment kernelEnvironment notKernelEnvironment |
	printStringEnvironment := universalEnvironment referencesTo: #printString.
	notPrintStringEnvironment := printStringEnvironment not.
	kernelEnvironment := RBPackageEnvironment packageName: 'Kernel'.
	notKernelEnvironment := kernelEnvironment not.

	self universalTestFor: notPrintStringEnvironment.
	self assertEmpty: (notPrintStringEnvironment referencesTo: #printString).
	self assert: (notPrintStringEnvironment not includesClass: RBBrowserEnvironmentTest).
	self assert: (notPrintStringEnvironment not includesSelector: #testNotEnvironment in: RBBrowserEnvironmentTest).
	self assert: (notKernelEnvironment includesPackage: 'Kernel' asPackage) not.
	self assertEmpty: (notKernelEnvironment & kernelEnvironment) packages! !

!RBBrowserEnvironmentTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	universalEnvironment := RBBrowserEnvironment new! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
classNamesFor: anEnvironment
	| classNames allClassNames |
	classNames := IdentitySet new
		addAll: anEnvironment classNames asSet;
		addAll: anEnvironment not classNames;
		yourself.
	allClassNames := universalEnvironment classNames asSortedCollection.
	self assert: classNames asSortedCollection equals: allClassNames.
	self assertEmpty: (anEnvironment & anEnvironment not) classNames.
	self assert: (anEnvironment | anEnvironment not) classNames asSortedCollection equals: allClassNames! !

!RBBrowserEnvironmentTest methodsFor: 'tests' stamp: ''!
testRemoveSelectorByAndAndNot
	| aBrowserEnvironment objectPrintString |
	aBrowserEnvironment := RBBrowserEnvironment new.
	objectPrintString := RBSelectorEnvironment 
				onEnvironment: aBrowserEnvironment.
	objectPrintString addClass: Object selector: #printString.
	self assert: aBrowserEnvironment numberSelectors - 1 
				equals: (aBrowserEnvironment & objectPrintString not) numberSelectors.
	self universalTestFor: aBrowserEnvironment & objectPrintString not! !

!RBBrowserEnvironmentTest methodsFor: 'tests' stamp: ''!
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: 'tests' stamp: ''!
testMatches
	| envEnvironment environmentEnvironment |
	envEnvironment := RBBrowserEnvironment new matches: '*env*'.
	environmentEnvironment := RBBrowserEnvironment new 
				referencesTo: #environment.
	self assert: (envEnvironment referencesTo: #environment) numberSelectors 
				equals: environmentEnvironment numberSelectors! !

!RBBrowserEnvironmentTest methodsFor: 'tests' stamp: ''!
testSelectMethods
	| environment |
	environment := RBBrowserEnvironment new selectMethods: [ :each | false ].
	self assert: environment numberSelectors equals: 0.
	self assert: environment numberClasses equals: 0.
	environment := RBBrowserEnvironment new selectMethods: [ :each | true ].
	self assert: environment numberSelectors equals: RBBrowserEnvironment new numberSelectors.
	environment := RBBrowserEnvironment new selectMethods: [ :each | each refersToLiteral: #environment ].
	self assert: environment numberSelectors equals: (RBBrowserEnvironment new referencesTo: #environment) numberSelectors! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testEnvironmentWrapper
	| printString wrapper |
	printString := RBBrowserEnvironment new referencesTo: #printString.
	wrapper := RBBrowserEnvironmentWrapper onEnvironment: printString.
	self assert: wrapper numberSelectors equals: printString numberSelectors.
	self assert: wrapper numberClasses equals: printString numberClasses.
	self assert: wrapper environment identicalTo: printString! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
protocolsFor: aBrowserEnvironment 
	aBrowserEnvironment classesAndSelectorsDo: [ :class :selector |
		| protocol |
		protocol := aBrowserEnvironment whichProtocolIncludes: selector in: class.
		self assert: (aBrowserEnvironment includesProtocol: protocol in: class) ]! !

!RBBrowserEnvironmentTest methodsFor: 'mockup' stamp: ''!
classVariableReader
	^ AClassVariable! !

!RBBrowserEnvironmentTest methodsFor: 'tests' stamp: ''!
testWithoutClassesRemovesClassesFromSender
	| environment newEnvironment |
	environment := (RBBrowserEnvironment new) forClasses: Number withAllSubclasses.
	
	newEnvironment := environment withoutClasses: { Number . Integer }.
	
	self 
		assert: newEnvironment classes size
		equals: environment classes size - 2! !

!RBBrowserEnvironmentTest methodsFor: 'tests' stamp: ''!
testVariableEnvironmentAddRemove
	| refs |
	refs := RBVariableEnvironment new.
	refs addClass: self class instanceVariable: 'universalEnvironment'.
	self assert: refs numberSelectors > 0.
	self assert: refs numberClasses equals: 1.
	refs removeClass: self class instanceVariable: 'universalEnvironment'.
	self assert: refs numberSelectors equals: 0.
	self assert: refs numberClasses equals: 0.
	refs addClass: self class instanceVariableReader: 'universalEnvironment'.
	self assert: refs numberSelectors > 0.
	self assert: refs numberClasses equals: 1.
	refs removeClass: self class instanceVariableReader: 'universalEnvironment'.
	self assert: refs numberSelectors equals: 0.
	self assert: refs numberClasses equals: 0.
	refs addClass: self class instanceVariableWriter: 'universalEnvironment'.
	self assert: refs numberSelectors > 0.
	self assert: refs numberClasses equals: 1.
	refs removeClass: self class instanceVariableWriter: 'universalEnvironment'.
	self assert: refs numberSelectors equals: 0.
	self assert: refs numberClasses equals: 0.
	refs addClass: self class classVariable: 'AClassVariable'.
	self assert: refs numberSelectors > 0.
	self assert: refs numberClasses equals: 1.
	refs removeClass: self class classVariable: 'AClassVariable'.
	self assert: refs numberSelectors equals: 0.
	self assert: refs numberClasses equals: 0
	! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testAndEnvironmentWithStoreOn
	| originalEnvironment objectPrintStringEnvironment andEnvironment |
	originalEnvironment := universalEnvironment referencesTo: #storeOn:.
	objectPrintStringEnvironment := universalEnvironment forClass: Object
				selectors: #(#storeString).
	andEnvironment := objectPrintStringEnvironment & originalEnvironment.
	self universalTestFor: andEnvironment.
	self assert: andEnvironment numberSelectors equals: 1.
	self assert: andEnvironment classNames asArray equals: #(#Object).
	self assert: (andEnvironment protocolsFor: Object) size equals: 1.
	self assert: (objectPrintStringEnvironment & objectPrintStringEnvironment) packages equals: objectPrintStringEnvironment packages.
	andEnvironment := originalEnvironment 
				& (universalEnvironment referencesTo: #printString).
	self assert: andEnvironment numberSelectors 
				equals: (originalEnvironment referencesTo: #printString) numberSelectors.
	self assert: andEnvironment classNames asSortedCollection 
				equals: (originalEnvironment referencesTo: #printString) classNames 
						asSortedCollection! !

!RBBrowserEnvironmentTest methodsFor: 'tests' stamp: ''!
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 equals: 2.
	environment addClass: Object class.
	self assert: environment numberClasses equals: 2.
	self assert: (environment includesClass: Object class).
	environment removeClass: self class.
	self assert: environment numberClasses equals: 2! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
uniqueClassesIn: aBrowserEnvironment 
	| allClasses |
	allClasses := IdentitySet new.
	aBrowserEnvironment classesDo: [ :each | 
		self deny: (allClasses includes: each).
		allClasses add: each ]! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testOrEnvironment
	| env1 env2 orEnvironment |
	env2 := #printOn:.
	env2 := universalEnvironment forClass: Object selectors: #(#fullPrintString).
	env1 := universalEnvironment forClass: Object selectors: #(#printOn:).
	self assert: (env1 | env2) numberSelectors equals: 2.
	self assert: (env2 | env1) numberSelectors equals: 2.
	self universalTestFor: env1 | env2.
	self assert: (env1 | env1) numberSelectors equals: 1.
	orEnvironment := env1 | env1 not.
	self assert: (env2 | env1) packages size equals: 1.
	self universalTestFor: orEnvironment.
	self assert: orEnvironment numberSelectors equals: universalEnvironment numberSelectors.
	self assert: orEnvironment classNames asSortedCollection equals: universalEnvironment classNames asSortedCollection.
	self
		assert: (orEnvironment protocolsFor: Object)
		equals: ((universalEnvironment protocolsFor: Object) reject: [ :each | (Object allSelectorsInProtocol: each) isEmpty ])! !

!RBBrowserEnvironmentTest methodsFor: 'mockup' stamp: ''!
classVariableWriter
	AClassVariable := nil! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
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 equals: aBrowserEnvironment isEmpty! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testAndEnvironment
	| originalEnvironment objectPrintStringEnvironment andEnvironment |
	originalEnvironment := universalEnvironment referencesTo: #printOn:.
	objectPrintStringEnvironment := universalEnvironment forClass: Object
				selectors: #(#fullPrintString).
	andEnvironment := objectPrintStringEnvironment & originalEnvironment.
	self universalTestFor: andEnvironment.
	self assert: andEnvironment numberSelectors equals: 1.
	self assert: andEnvironment classNames asArray equals: #(#Object).
	self assert: (andEnvironment protocolsFor: Object) size equals: 1.
	self assert: (objectPrintStringEnvironment & objectPrintStringEnvironment) packages equals: objectPrintStringEnvironment packages.
	andEnvironment := originalEnvironment 
				& (universalEnvironment referencesTo: #printString).
	self assert: andEnvironment numberSelectors 
				equals: (originalEnvironment referencesTo: #printString) numberSelectors.
	self assert: andEnvironment classNames asSortedCollection 
				equals: (originalEnvironment referencesTo: #printString) classNames 
						asSortedCollection! !

!RBBrowserEnvironmentTest methodsFor: 'tests - environments' stamp: ''!
testNotEnvironmentWithClassEnvironments
	| numberEnvironment notNumberEnvironment |
	numberEnvironment := RBBrowserEnvironment new forClasses: Number withAllSubclasses.
	notNumberEnvironment := numberEnvironment not.

	self universalTestFor: notNumberEnvironment.
	self deny: (notNumberEnvironment includesClass: Number).
	self assertEmpty: (notNumberEnvironment & numberEnvironment) classes.
	self assert: (notNumberEnvironment not includesClass: Number)! !

!RBBrowserEnvironmentTest methodsFor: 'private' stamp: ''!
labelFor: aBrowserEnvironment 
	self deny: aBrowserEnvironment label isNil.
	self deny: aBrowserEnvironment label isEmpty.
	self deny: aBrowserEnvironment defaultLabel isNil.
	self deny: aBrowserEnvironment defaultLabel isEmpty! !

!RBBrowserEnvironmentTest methodsFor: 'tests' stamp: ''!
testVariableEnvironmentInstVars
	| refs writers readers classRefs |
	
	self timeLimit: 300 seconds.

	refs := RBVariableEnvironment
		referencesToInstanceVariable: 'universalEnvironment'
		in: self class.
	writers := RBVariableEnvironment
		writersOfInstanceVariable: 'universalEnvironment'
		in: self class.
	readers := RBVariableEnvironment
		readersOfInstanceVariable: 'universalEnvironment'
		in: self class.
	classRefs := RBVariableEnvironment
		referencesToClassVariable: 'AClassVariable'
		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 equals: (writers | readers) numberSelectors! !

!RBBrowserEnvironmentTest class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit
	^30 seconds! !

!RBBrowserEnvironmentTest class methodsFor: 'accessing' stamp: ''!
packageNamesUnderTest
	^ #('Refactoring-Environment')! !

!RBBrowserEnvironmentTest class methodsFor: 'accessing' stamp: ''!
accessFromClassSideOnlyVariable
	"testing method. This class variable is only accessed from this class side method"

	^ ClassSideOnlyVariable! !

!RBBrowserEnvironmentWrapper commentStamp: ''!
I am a wrapper around special browser environment subclasses and
the base RBBrowserEnvironment class. I define common methods
for my subclasses to act as a full environment.
no public use.!
!RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''!
isEmpty
	self classesDo: [:each | ^false].
	^true! !

!RBBrowserEnvironmentWrapper methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor

	self subclassResponsibility! !

!RBBrowserEnvironmentWrapper methodsFor: 'private' stamp: ''!
systemDictionary
	^ environment systemDictionary! !

!RBBrowserEnvironmentWrapper methodsFor: 'accessing' stamp: ''!
basisObjects

	^ #()! !

!RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''!
includesCategory: aCategory
	^environment includesCategory: aCategory! !

!RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''!
includesSelector: aSelector in: aClass
	^(self includesClass: aClass)
		and: [environment includesSelector: aSelector in: aClass]! !

!RBBrowserEnvironmentWrapper methodsFor: 'initialization' stamp: ''!
onEnvironment: anEnvironment
	environment := anEnvironment! !

!RBBrowserEnvironmentWrapper methodsFor: 'private' stamp: ''!
environment
	^ environment! !

!RBBrowserEnvironmentWrapper methodsFor: 'description' stamp: ''!
description

	^ label ifNil: [super description, self descriptionBasis]! !

!RBBrowserEnvironmentWrapper methodsFor: 'description' stamp: ''!
descriptionBasis

	^ String streamContents: [ :s | | basis |
		basis := self basisObjects.
		basis ifEmpty: [ ^ self ]
			ifNotEmpty: [ s nextPutAll: ': ' ].
		basis do: [ :each |
			self printBasisObject: each on: s.
			s nextPutAll: ', '].
	s skip: -2]! !

!RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass
	^(self includesClass: aClass)
		and: [environment includesProtocol: aProtocol in: aClass]! !

!RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''!
isSystem
	^false! !

!RBBrowserEnvironmentWrapper methodsFor: 'accessing' stamp: ''!
packages

	^ self subclassResponsibility! !

!RBBrowserEnvironmentWrapper methodsFor: 'printing' stamp: ''!
printBasisObject: anObject on: aStream

	^ anObject printOn: aStream! !

!RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''!
includesPackage: aRPackage 
	^ self packages includes: aRPackage! !

!RBBrowserEnvironmentWrapper methodsFor: 'private' stamp: ''!
packageNames
	^ self packages collect: [ :each | each packageName ]! !

!RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''!
includesClass: aClass
	^environment includesClass: aClass! !

!RBBrowserEnvironmentWrapper methodsFor: 'private' stamp: ''!
rootEnvironment
	^ environment rootEnvironment! !

!RBBrowserEnvironmentWrapper methodsFor: 'accessing' stamp: ''!
selectionIntervalFor: aString 
	| interval |
	interval := super selectionIntervalFor: aString.
	^interval ifNotNil: [interval]
		ifNil: [environment selectionIntervalFor: aString]! !

!RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''!
definesClass: aClass
	^ environment definesClass: aClass! !

!RBBrowserEnvironmentWrapper methodsFor: '*Calypso-NavigationModel' stamp: ''!
query: aQuery

	self isBasedOnEmptyBasis ifTrue: [ 
		"It is optimization to prevent real query execution in remote scenario.
		Any query is a priory empty when its scope is based on empty basis"
		^ClyUnknownQueryResult instance ].

	aQuery ensureScope: self.

	^environment query: aQuery! !

!RBBrowserEnvironmentWrapper methodsFor: '*Calypso-NavigationModel' stamp: ''!
supportsQuery: aQuery
	^ aQuery isKindOf: ClyTypedQuery! !

!RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''!
isBoundToEnvironment

	^ environment notNil! !

!RBBrowserEnvironmentWrapper methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream
		nextPutAll: '(';
		nextPutAll: self class name;
		nextPutAll: ' onEnvironment: '.
	environment storeOn: aStream.
	aStream nextPut: $)! !

!RBBrowserEnvironmentWrapper class methodsFor: 'instance creation' stamp: ''!
new
	^ self onEnvironment: RBBrowserEnvironment new! !

!RBBrowserEnvironmentWrapper class methodsFor: 'instance creation' stamp: ''!
onEnvironment: anEnvironment 
	^(self basicNew)
		initialize;
		onEnvironment: anEnvironment;
		yourself! !

!RBBrowserEnvironmentsClassesHelp commentStamp: ''!
Book from RBBrowserEnvironments classes!
!RBBrowserEnvironmentsClassesHelp class methodsFor: 'building' stamp: ''!
rootHelpClass
	^ RBBrowserEnvironment ! !

!RBBrowserMethodRefactoringHelp commentStamp: ''!
This is the chapter of the refactoring help book about the method  refactoring available in the System Browser.!
!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
removeParameterRefactoring
	^HelpTopic
		title: 'Remove parameter'
		contents: RBRemoveParameterRefactoring comment! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
replaceMethodByAnotherRefactoring
	^HelpTopic
		title: 'Replace by another'
		contents: RBReplaceMethodRefactoring comment
! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
deprecateMethodRefactoring
	^HelpTopic
		title: 'Deprecate'
		contents: RBDeprecateMethodRefactoring comment
! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
moveToClassSideRefactoring
	^HelpTopic
		title: 'Move to class side'
		contents: RBMoveMethodToClassSideRefactoring comment! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(addParameterRefactoring deprecateMethodRefactoring inlineParameterRefactoring inlineTargeSendsRefactoring moveMethodRefactoring  moveToClassRefactoring moveToClassSideRefactoring pushUpMethodRefactoring pushDownpMethodRefactoring removeMethodRefactoring removeParameterRefactoring removeAllSendersRefactoring renameMethodRefactoring replaceMethodByAnotherRefactoring)! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
renameMethodRefactoring
	^HelpTopic
		title: 'Rename method (all)'
		contents: RBRenameMethodRefactoring comment
! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Method Refactorings'! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
pushUpMethodRefactoring
	^HelpTopic
		title: 'Push up'
		contents: RBPullUpMethodRefactoring comment
! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
addParameterRefactoring
	^HelpTopic
		title: 'Add parameter'
		contents: RBAddParameterRefactoring comment
! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
removeHierarchyMethodRefactoring
	^HelpTopic
		title: 'Remove'
		contents: RBRemoveHierarchyMethodRefactoring comment
! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'removing' stamp: ''!
removeAllSendersRefactoring
	^HelpTopic
		title: 'Remove all senders'
		contents: RBRemoveAllSendersRefactoring comment ! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
inlineParameterRefactoring
	^HelpTopic
		title: 'Inline parameter'
		contents: RBInlineParameterRefactoring comment
! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
moveMethodRefactoring
	^HelpTopic
		title: 'Move'
		contents: RBMoveMethodRefactoring comment
! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
removeMethodRefactoring
	^HelpTopic
		title: 'Remove'
		contents: RBRemoveMethodRefactoring comment
! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
inlineTargeSendsRefactoring
	^HelpTopic
		title: 'Inline target sends'
		contents: RBInlineAllSendersRefactoring comment! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
pushDownpMethodRefactoring
	^HelpTopic
		title: 'Push down'
		contents: RBPushDownMethodRefactoring comment
! !

!RBBrowserMethodRefactoringHelp class methodsFor: 'pages' stamp: ''!
moveToClassRefactoring
	^HelpTopic
		title: 'Move to class side / instance side'
		contents: RBSwapMethodRefactoring comment! !

!RBBrowserPackageRefactoringHelp commentStamp: ''!
This is the chapter of the refactoring help book about the package refactoring available in the System Browser.!
!RBBrowserPackageRefactoringHelp class methodsFor: 'accessing' stamp: ''!
pages 
	^ #(renamePackage)! !

!RBBrowserPackageRefactoringHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Package Refactorings'! !

!RBBrowserPackageRefactoringHelp class methodsFor: 'transforming' stamp: ''!
renamePackage
	^HelpTopic
		title: 'Rename'
		contents: RBRenamePackageRefactoring comment
! !

!RBBrowserSourceRefactoringHelp commentStamp: ''!
This is the chapter of the refactoring help book about source code refactorings available from System Browsers code pane.!
!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
inlineMethodFromComponentRefactoring
	^HelpTopic
		title: 'Inline method from component'
		contents: RBInlineMethodFromComponentRefactoring comment
! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
extractToTemporaryRefactoring
	^HelpTopic
		title: 'Extract to temporary'
		contents: RBExtractToTemporaryTransformation comment
! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
extractMethodRefactoring
	^HelpTopic
		title: 'Extract method'
		contents: RBExtractMethodRefactoring comment
! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
createCascadeRefactoring
	^HelpTopic
		title: 'Create cascade'
		contents: RBCreateCascadeRefactoring comment
! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(createCascadeRefactoring extractMethodRefactoring extractMethodToComponentRefactoring extractToTemporaryRefactoring inlineMethodRefactoring inlineMethodFromComponentRefactoring inlineTemporaryRefactoring moveVariableDefinitionRefactoring renameTemporaryRefactoring splitCascadeRefactoring moveTemporaryToInstvarRefactoring)! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Source Refactorings'! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
extractMethodToComponentRefactoring
	^HelpTopic
		title: 'Extract method to component'
		contents: RBExtractMethodToComponentRefactoring comment
! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
inlineMethodRefactoring
	^HelpTopic
		title: 'Inline method'
		contents: RBInlineMethodRefactoring comment
! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
inlineTemporaryRefactoring
	^HelpTopic
		title: 'Inline temporary'
		contents: RBInlineTemporaryRefactoring comment
! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
splitCascadeRefactoring
	^HelpTopic
		title: 'Split cascade'
		contents: RBSplitCascadeRefactoring comment
! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
moveTemporaryToInstvarRefactoring
	^HelpTopic
		title: 'Move temporary to instvar'
		contents: RBTemporaryToInstanceVariableRefactoring comment.
! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
moveVariableDefinitionRefactoring
	^HelpTopic
		title: 'Move variable definition'
		contents: RBMoveVariableDefinitionRefactoring comment
! !

!RBBrowserSourceRefactoringHelp class methodsFor: 'pages' stamp: ''!
renameTemporaryRefactoring
	^HelpTopic
		title: 'Rename temporary/parameter'
		contents: RBRenameArgumentOrTemporaryRefactoring comment
! !

!RBBrowserSupportHelp commentStamp: ''!
This is the chapter of  the refactoring framework help about refactoring support in the System Browser.!
!RBBrowserSupportHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#( overview #RBBrowserClassRefactoringHelp #RBBrowserMethodRefactoringHelp #RBBrowserSourceRefactoringHelp #RBBrowserPackageRefactoringHelp )! !

!RBBrowserSupportHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'System Browser Support'! !

!RBBrowserSupportHelp class methodsFor: 'pages' stamp: ''!
overview
	^HelpTopic
		title: 'Overview'
		contents: 
'
Most refactoring operations fall into one of three categories:

Class Refactoring, Method Refactoring and Source Refactoring.

The following pages describe the refactorings available in the System Browser - Calypso.
Depending on the kind of Refactoring (Class/Method/Source) you can find and apply the refactoring from the "Refactoring" Menu on the class-, method- or code-pane.

Executing a refactoring will open a changes browser that lets you see and (depending on the current operation) select which change to apply.

If the refactoring can not be applied, because one of its preconditions aren''t met (for example you try to rename a class with a name that is already used), a warning message appears.

The refactoring changes will be applied to all classes and methods in the current "namespace". For the default system browser, this is the whole system.
If you want to restrict the operation to some set of classes or packages, you can open a system browser on a refactoring environmet - a kind of "scoped view".

Example:

(RBBrowserEnvironment default forPackageNames:{''Kernel''}) browse. 
will open a system browser with only the classes from package ''Kernel''. And all refactoring operations will only find and change classes in this "namespace".

See the chapter in "RB Refactoring Engine - RBBrowserEnvironment" for more examples on how to create scoped views.
'! !

!RBBrowserVariableRefactoringHelp commentStamp: ''!
This is the chapter of the refactoring help book about the class / instance variable refactoring available in the System Browser.!
!RBBrowserVariableRefactoringHelp class methodsFor: 'pages' stamp: ''!
mergeVariableIntoAnotherRefactoring
	^HelpTopic
		title: 'Merge variable'
		contents: RBMergeInstanceVariableIntoAnother comment
! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'pages' stamp: ''!
pullUpVariableRefactoring
	^HelpTopic
		title: 'Pull up'
		contents: 
'
Moves an instance/class variable up to the superclass. The variable is added to the superclass and removed from this and all other sibling classes, defining this variable. A warning message appears if not all direct subclasses defined this variable.
'
! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'pages' stamp: ''!
pushDownVariableRefactoring
	^HelpTopic
		title: 'Push down'
		contents: 
'
Moves an instance/class variable down to the subclasses. The variable is added to every direct subclass.
A warning dialog appears if there are methods referring to this class (accessors methods for example), and offers a choice to open a (scoped) browser for this messages.
No accessors method will be changed or generated.
'
! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(addVariableRefactoring renameVariableRefactoring removeVariableRefactoring abstractVariableRefactoring  accessorVariableRefactoring accessorForLazyInitializationRefactoring moveToVariableRefactoring pullUpVariableRefactoring pushDownVariableRefactoring #mergeVariableIntoAnotherRefactoring)! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'pages' stamp: ''!
removeVariableRefactoring
	^HelpTopic
		title: 'Remove'
		contents: 
'
Shows a list of variables from the class or instance side. The selected variable is removed. If the variable is referred by a method, it asks for opening a browser window, showing only those classes and its methods accessing this variable (a scoped browser view).
'
! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'pages' stamp: ''!
abstractVariableRefactoring
	^HelpTopic
		title: 'Abstract'
		contents: 
'
Shows a list of variables from the class or instance side, creates an accessors for the variable and replaces all direct access to this variable by this accessors method.
(For this class and all of its subclasses.)
There is no special handling for already existing accessors methods, their direct access is replaced too. And if an accessors method with the name of this variable already exists, the newly created method will get the same name with a counter suffix.
'
! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Class and Instance Variable Refactorings'! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'pages' stamp: ''!
moveToVariableRefactoring
	^HelpTopic
		title: 'Move to class'
		contents: 
'
Only for instance variables. A class search dialog lets you choose the target class to move the instance variable to.
Another dialog for choosing the instance variable to move. If there are any methods referring to this variable, a message list opens, showing all broken methods.
'
! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'pages' stamp: ''!
renameVariableRefactoring
	^HelpTopic
		title: 'Rename'
		contents: 
'
Shows a list of variables from the class or instance side. The selected variable is renamed in the class definition and in all methods referring to this var. The name of the accessor methods are unchanged.
'
! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'pages' stamp: ''!
addVariableRefactoring
	^HelpTopic
		title: 'Add Variable'
		contents: RBAddInstanceVariableRefactoring comment
! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'pages' stamp: ''!
accessorForLazyInitializationRefactoring
	^HelpTopic
		title: 'Accessor with lazy initialization'
		contents: RBCreateAccessorsWithLazyInitializationForVariableRefactoring comment! !

!RBBrowserVariableRefactoringHelp class methodsFor: 'pages' stamp: ''!
accessorVariableRefactoring
	^HelpTopic
		title: 'Accessor'
		contents: 
'
Accessor
Choose one instance / class variable to create accessors for. 
A getter and setter methods is generated, with the name of the chosen instance variable. If a method with this name already exists, it will create a new method with the same name and a counter suffix.
'
! !

!RBCascadeNode commentStamp: ''!
RBCascadeNode is an AST node for cascaded messages (e.g., "self print1 ; print2").

Instance Variables:
	messages	<SequenceableCollection of: RBMessageNode>	the messages 
	semicolons	<SequenceableCollection of: Integer>	positions of the ; between messages

!
!RBCascadeNode methodsFor: 'accessing' stamp: ''!
stopWithoutParentheses
	^messages last stop! !

!RBCascadeNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [^true].
	self class = anObject class ifFalse: [^false].
	self messages size = anObject messages size ifFalse: [^false].
	self messages with: anObject messages do: [:first :second | first = second ifFalse: [^false]].
	^true! !

!RBCascadeNode methodsFor: 'fluid parser' stamp: ''!
handleMetaclassName: aCDFluidClassDefinitionParser 
	aCDFluidClassDefinitionParser handleMetaclassNameFromCascade: self! !

!RBCascadeNode methodsFor: 'comparing' stamp: ''!
hash
	^ self hashForCollection: self messages! !

!RBCascadeNode methodsFor: 'accessing' stamp: ''!
receiver
	^self messages first receiver! !

!RBCascadeNode methodsFor: 'accessing' stamp: ''!
children
	^ messages! !

!RBCascadeNode methodsFor: 'testing' stamp: ''!
isFaulty
	^self messages anySatisfy: [:each | each isFaulty]! !

!RBCascadeNode methodsFor: 'accessing - token' stamp: ''!
semicolons
	^ semicolons! !

!RBCascadeNode methodsFor: 'accessing' stamp: ''!
messages
	^messages! !

!RBCascadeNode methodsFor: 'querying' stamp: ''!
bestNodeFor: anInterval 
	| selectedChildren |
	(self intersectsInterval: anInterval) ifFalse: [ ^nil ] .
	(self containedBy: anInterval) ifTrue: [^self].
	messages 
		reverseDo: [:each | (each containedBy: anInterval) ifTrue: [^each]].
	selectedChildren := (messages 
				collect: [:each | each bestNodeFor: anInterval]) 
					reject: [:each | each isNil].
	^selectedChildren detect: [:each | true] ifNone: [nil]! !

!RBCascadeNode methodsFor: 'querying' stamp: ''!
whichNodeIsContainedBy: anInterval 
	| selectedChildren |
	(self intersectsInterval: anInterval) ifFalse: [^nil].
	(self containedBy: anInterval) ifTrue: [^self].
	messages 
		reverseDo: [:each | (each containedBy: anInterval) ifTrue: [^each]].
	selectedChildren := (messages 
				collect: [:each | each whichNodeIsContainedBy: anInterval]) 
					reject: [:each | each isNil].
	^selectedChildren detect: [:each | true] ifNone: [nil]! !

!RBCascadeNode methodsFor: 'testing' stamp: ''!
uses: aNode 
	^messages last = aNode and: [self isUsed]! !

!RBCascadeNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	self messages: (messages 
				collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! !

!RBCascadeNode methodsFor: 'initialization' stamp: ''!
messages: messageNodes semicolons: integerCollection 
	self messages: messageNodes.
	semicolons := integerCollection! !

!RBCascadeNode methodsFor: 'accessing' stamp: ''!
leftmostChainReceiver

	^ self receiver isMessage
		ifTrue: [ self receiver receiver ]
		ifFalse: [ self receiver ]! !

!RBCascadeNode methodsFor: 'testing' stamp: ''!
needsParenthesis
	^parent 
		ifNil: [false]
		ifNotNil: [self precedence > parent precedence]! !

!RBCascadeNode methodsFor: 'accessing' stamp: ''!
startWithoutParentheses
	^messages first start! !

!RBCascadeNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitCascadeNode: self! !

!RBCascadeNode methodsFor: 'adding/removing' stamp: ''!
removeNode: aNode

	self messages remove: aNode ifAbsent: [ ]! !

!RBCascadeNode methodsFor: 'comparing' stamp: ''!
equalTo: anObject withMapping: aDictionary 
	self class = anObject class ifFalse: [^false].
	self messages size = anObject messages size ifFalse: [^false].
	self messages
		with: anObject messages
		do: [:first :second | (first equalTo: second withMapping: aDictionary) ifFalse: [^false]].
	^true! !

!RBCascadeNode methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self messages: (self messages collect: [ :each | each copy ])! !

!RBCascadeNode methodsFor: '*ClassParser' stamp: ''!
extractClassDefinitionFor: aFluidParser

	aFluidParser setAdequateClassDefinitionFrom: self receiver! !

!RBCascadeNode methodsFor: 'testing' stamp: ''!
directlyUses: aNode 
	^messages last = aNode and: [self isDirectlyUsed]! !

!RBCascadeNode methodsFor: 'accessing' stamp: ''!
messages: messageNodeCollection 
	messages := messageNodeCollection.
	messages do: [:each | each parent: self]! !

!RBCascadeNode methodsFor: 'accessing - token' stamp: ''!
semicolons: anArray
	semicolons := anArray! !

!RBCascadeNode methodsFor: 'accessing' stamp: ''!
statementComments
	| statementComments |
	statementComments := OrderedCollection withAll: self comments.
	statementComments addAll: messages first receiver statementComments.
	messages do: 
			[:each | 
			each arguments 
				do: [:arg | statementComments addAll: arg statementComments]].
	^statementComments asSortedCollection: [:a :b | a start < b start]! !

!RBCascadeNode methodsFor: 'accessing' stamp: ''!
precedence
	^4! !

!RBCascadeNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary 
	aNode class = self class ifFalse: [^false].
	^self 
		matchList: messages
		against: aNode messages
		inContext: aDictionary! !

!RBCascadeNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	^ self class new
		messages: (self copyList: self messages inContext: aDictionary);
		yourself! !

!RBCascadeNode methodsFor: 'testing' stamp: ''!
isCascade
	^true! !

!RBCascadeNode class methodsFor: 'instance creation' stamp: ''!
messages: messageNodes semicolons: integerCollection 
	^self new messages: messageNodes semicolons: integerCollection! !

!RBCascadeNode class methodsFor: 'instance creation' stamp: ''!
messages: messageNodes 
	^self new messages: messageNodes! !

!RBCategoryEnvironment commentStamp: ''!
I am a RBBrowserEnvironment on a set of category names.
I containt all entities using this category name.
I am more restricted to the exact category name compared
to a package environment.

Example, all Morph subclasses in category Morphic-Base-Menus

(RBBrowserEnvironment new forClasses: Morph withAllSubclasses) forCategories: {#'Morphic-Base-Menus'}!
!RBCategoryEnvironment methodsFor: 'testing' stamp: ''!
isEmpty
	^categories isEmpty! !

!RBCategoryEnvironment methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	categories := IdentitySet new! !

!RBCategoryEnvironment methodsFor: 'accessing' stamp: ''!
basisObjects

	^ self categories! !

!RBCategoryEnvironment methodsFor: 'testing' stamp: ''!
includesCategory: aCategory
	^(categories includes: aCategory)
		and: [super includesCategory: aCategory]! !

!RBCategoryEnvironment methodsFor: 'accessing - classes' stamp: ''!
classNames
	^ self categories 
		inject: IdentitySet new
		into: [ :answer :each | 
			answer
				addAll: (self classNamesFor: each);
				yourself ]! !

!RBCategoryEnvironment methodsFor: 'adding' stamp: ''!
addCategory: aSymbol
	categories add: aSymbol! !

!RBCategoryEnvironment methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	categories := categories copy! !

!RBCategoryEnvironment methodsFor: 'accessing' stamp: ''!
packages
	^ self classes collect: [:each | each package]! !

!RBCategoryEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass 
	^ (super includesClass: aClass) and: [ categories includes: aClass instanceSide category ]! !

!RBCategoryEnvironment methodsFor: 'testing' stamp: ''!
definesClass: aClass 
	^ (super definesClass: aClass) and: [ categories includes: aClass instanceSide category ]! !

!RBCategoryEnvironment methodsFor: 'initialization' stamp: ''!
categories: aCollection
	categories addAll: aCollection! !

!RBCategoryEnvironment methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream nextPut: $(.
	super storeOn: aStream.
	aStream nextPutAll: ' categories: '.
	categories asArray storeOn: aStream.
	aStream nextPut: $)! !

!RBCategoryEnvironment methodsFor: 'private' stamp: ''!
defaultLabel
	| stream |
	stream := String new writeStream.
	categories do: [:each | stream nextPutAll: each; nextPut: $ ].
	^stream contents! !

!RBCategoryEnvironment class methodsFor: 'api' stamp: ''!
category: aCategory
	^ self categories: { aCategory }! !

!RBCategoryEnvironment class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'Categories'! !

!RBCategoryEnvironment class methodsFor: 'api' stamp: ''!
categories: aCollection
	^ self
		onEnvironment: self default
		categories: aCollection! !

!RBCategoryEnvironment class methodsFor: 'api' stamp: ''!
onEnvironment: anEnvironment categories: aCollection
	^(self onEnvironment: anEnvironment)
		categories: aCollection;
		yourself! !

!RBCategoryRegexRefactoring commentStamp: ''!
I am a regex refactoring renaming class categories (package names).

See comment of superclass for a nice script to be adapated to package names.!
!RBCategoryRegexRefactoring methodsFor: 'transforming' stamp: ''!
transform
	| replacement |
	self model allClassesDo: [ :class |
		(class isNil or: [ class isMeta ]) ifFalse: [
			replacement := self execute: class category.
			replacement = class category asString ifFalse: [
				class category: replacement.
				self model defineClass: class definitionString ] ] ]! !

!RBChangeMethodNameRefactoring commentStamp: ''!
I am an abstract base class for refactorings changing a method name.

Doing a method rename involves:
- rename implementors
- rename message sends and
- remove renamed implementors.

I implement the above precedures and provide helper functions for finding and renaming references.
Every concrete subclass has to add its own precondition (see `myPrecondition`).
!
!RBChangeMethodNameRefactoring methodsFor: 'private' stamp: ''!
implementors

	implementors ifNil: [ implementors := self model allImplementorsOf: oldSelector ].
	^ implementors! !

!RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self renameImplementors.
	self renameMessageSends.
	self removeRenamedImplementors! !

!RBChangeMethodNameRefactoring methodsFor: 'private' stamp: ''!
parseTreeRewriter
	| rewriteRule oldString newString |
	rewriteRule := self parseTreeRewriterClass new.
	oldString := self buildSelectorString: oldSelector.
	newString := self buildSelectorString: newSelector
				withPermuteMap: permutation.
	rewriteRule replace: '``@object ' , oldString
		with: '``@object ' , newString.
	^rewriteRule! !

!RBChangeMethodNameRefactoring methodsFor: 'accessing' stamp: ''!
newSelector
	^newSelector! !

!RBChangeMethodNameRefactoring methodsFor: 'preconditions' stamp: ''!
myConditions
	"^self subclassResponsibility"! !

!RBChangeMethodNameRefactoring methodsFor: 'preconditions' stamp: ''!
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. Proceed anyway?' 
							expandMacrosWith: self implementors size)].
		true])! !

!RBChangeMethodNameRefactoring methodsFor: 'initialization' stamp: ''!
renameMethod: aSelector in: aClass to: newSel permutation: aMap 
	oldSelector := aSelector asSymbol.
	newSelector := newSel asSymbol.
	class := self classObjectFor: aClass.
	permutation := aMap.! !

!RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: ''!
renameMessageSendsIn: classes
	self convertAllReferencesTo: oldSelector of: classes using: self parseTreeRewriter! !

!RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: ''!
renameMessageSends
	self convertAllReferencesTo: oldSelector using: self parseTreeRewriter! !

!RBChangeMethodNameRefactoring methodsFor: 'accessing' stamp: ''!
renameMap: aColl
	renameMap := aColl! !

!RBChangeMethodNameRefactoring methodsFor: 'testing' stamp: ''!
implementorsCanBePrimitives
	^false! !

!RBChangeMethodNameRefactoring methodsFor: 'action' stamp: ''!
renameArgumentsIn: parseTree
	self renameMap do: [ :arg |
		(self parseTreeRewriterClass rename: arg name to: arg newName) executeTree: parseTree
	] ! !

!RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: ''!
removeRenamedImplementors
	oldSelector = newSelector
		ifTrue: [ ^ self ].
	self implementors 
		do: [ :each | each removeMethod: oldSelector ]! !

!RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: ''!
renameImplementors

	self implementors
		do: [ :each | 
			| parseTree |

			parseTree := each parseTreeFor: oldSelector.
			parseTree ifNil: [ 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: 'accessing' stamp: ''!
renameMap
	^renameMap ifNil: [ renameMap := { } ]! !

!RBChangeMethodNameRefactoring methodsFor: 'private' stamp: ''!
modifyImplementorParseTree: parseTree in: aClass 
	| oldArgs |
	oldArgs := parseTree arguments.
	parseTree renameSelector: newSelector andArguments: (permutation collect: [:each | oldArgs at: each]) ! !

!RBChangeMethodNameRefactoring methodsFor: 'testing' stamp: ''!
hasPermutedArguments
	oldSelector numArgs = newSelector numArgs ifFalse: [^true].
	1 to: oldSelector numArgs
		do: [:i | (permutation at: i) = i ifFalse: [^true]].
	^false! !

!RBChangeMethodNameRefactoring class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBChangeMethodNameRefactoring! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
convertAllReferencesTo: aSymbol of: classes using: searchReplacer 
	(self model allReferencesTo: aSymbol in: classes)
		do: 
			[:eachMethod | 
			self 
				convertMethod: eachMethod selector
				for: eachMethod modelClass
				using: searchReplacer]! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
implementors

	implementors ifNil: [ implementors := self model allImplementorsOf: oldSelector ].
	^ implementors! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
parseTreeRewriter
	| rewriteRule oldString newString |
	rewriteRule := self parseTreeRewriterClass new.
	oldString := self buildSelectorString: oldSelector.
	newString := self buildSelectorString: newSelector
				withPermuteMap: permutation.
	rewriteRule replace: '``@object ' , oldString
		with: '``@object ' , newString.
	^rewriteRule! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
newSelector
	^newSelector! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
myConditions
	"^self subclassResponsibility"! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
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. Proceed anyway?' 
							expandMacrosWith: self implementors size)].
		true])! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
renameMethod: aSelector in: aClass to: newSel permutation: aMap 
	oldSelector := aSelector asSymbol.
	newSelector := newSel asSymbol.
	class := self model classObjectFor: aClass.
	permutation := aMap.! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
renameMessageSendsIn: classes
	self convertAllReferencesTo: oldSelector of: classes using: self parseTreeRewriter! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
renameMessageSends
	self convertAllReferencesTo: oldSelector using: self parseTreeRewriter! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
renameMap: aColl
	renameMap := aColl! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
convertAllReferencesTo: aSymbol using: searchReplacer 
	|aBlock|
	aBlock := [:eachMethod | 
			self 
				convertMethod: eachMethod  selector
				for: eachMethod modelClass
				using: searchReplacer].
	self model allReferencesTo: aSymbol do: aBlock! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
implementorsCanBePrimitives
	^false! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
removeRenamedImplementors
	oldSelector = newSelector
		ifTrue: [ ^ self ].
	self implementors 
		do: [ :each | each removeMethod: oldSelector ]! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
renameArgumentsIn: parseTree
	self renameMap do: [ :arg |
		(self parseTreeRewriterClass rename: arg name to: arg newName) executeTree: parseTree
	] ! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
renameImplementors

	self implementors
		do: [ :each | 
			| parseTree |

			parseTree := each parseTreeFor: oldSelector.
			parseTree ifNil: [ 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
			]! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
renameMap
	^renameMap ifNil: [ renameMap := { } ]! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
modifyImplementorParseTree: parseTree in: aClass 
	| oldArgs |
	oldArgs := parseTree arguments.
	parseTree renameSelector: newSelector andArguments: (permutation collect: [:each | oldArgs at: each]) ! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
hasPermutedArguments
	oldSelector numArgs = newSelector numArgs ifFalse: [^true].
	1 to: oldSelector numArgs
		do: [:i | (permutation at: i) = i ifFalse: [^true]].
	^false! !

!RBChangeMethodNameTransformation methodsFor: 'support' stamp: ''!
privateTransform 
	self renameImplementors.
	self renameMessageSends.
	self removeRenamedImplementors! !

!RBChildrenToSiblingsParametrizedTest methodsFor: 'tests' stamp: ''!
testModelChildrenToSibling
	| refactoring class subclass superclass |
	class := model classNamed: #ConcreteSuperclass.
	subclass := model classNamed: #ConcreteSubclass.
	refactoring := self createRefactoringWithModel: model andArguments: 
		{ #AbstractSuperclass . class . (Array with: subclass)}.
	self executeRefactoring: refactoring.
	superclass := refactoring model classNamed: #AbstractSuperclass.
	self assert: class superclass equals: superclass.
	self assert: class classSide superclass equals: superclass classSide.
	self assert: subclass superclass equals: superclass.
	self assert: subclass classSide superclass equals: superclass classSide.
	self assert: (superclass parseTreeFor: #same) equals: (self parseMethod: 'same ^self initialize isKindOf: AbstractSuperclass').
	self assert: (superclass parseTreeFor: #different) equals: (self parseMethod: 'different self subclassResponsibility').
	self
		assert: (superclass parseTreeFor: #initialize)
		equals:
			(self
				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 classSide directlyDefinesInstanceVariable: 'classInstVarName1').
	self
		assert: (superclass classSide parseTreeFor: #foo)
		equals:
			(self
				parseMethod:
					'foo
							^classInstVarName1 + ClassVarName1 + ClassVarName2').
	self
		assert: (superclass classSide parseTreeFor: #new)
		equals:
			(self
				parseMethod:
					'new
							^super new initialize').
	self
		assert: (superclass classSide parseTreeFor: #bar)
		equals:
			(self
				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 classSide directlyDefinesInstanceVariable: 'classInstVarName1').
	self deny: (class directlyDefinesMethod: #same).
	self deny: (class directlyDefinesMethod: #initialize).
	self deny: (class classSide directlyDefinesMethod: #new).
	self
		assert: (class parseTreeFor: #different)
		equals:
			(self
				parseMethod:
					'different
							^instVarName1 + instVarName2').
	self
		assert: (class classSide parseTreeFor: #bar)
		equals:
			(self
				parseMethod:
					'bar
							^self printString')! !

!RBChildrenToSiblingsParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #name:class:subclasses:! !

!RBChildrenToSiblingsParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadName
	
	self shouldFail: (self createRefactoringWithArguments: 
		{#'Obje ct' . RBLintRuleTestData . (Array 
					with: RBBasicLintRuleTestData
					with: RBCompositeLintRuleTestData)})! !

!RBChildrenToSiblingsParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExistingName
	self shouldFail: (self createRefactoringWithArguments: 
		{ #Object . RBLintRuleTestData . (Array 
						with: RBBasicLintRuleTestData
						with: RBCompositeLintRuleTestData) }).
	self shouldFail: (self createRefactoringWithArguments: 
		{ #Processor . RBLintRuleTestData . (Array 
						with: RBBasicLintRuleTestData
						with: RBCompositeLintRuleTestData) })! !

!RBChildrenToSiblingsParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInvalidSubclass
	self shouldFail: (self createRefactoringWithArguments: 
		{ #Foo .  RBAbstractRefactoringTest . (Array 
					with: RBBasicLintRuleTestData
					with: RBCompositeLintRuleTestData)})! !

!RBChildrenToSiblingsParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMetaClassFailure
	self shouldFail: (self createRefactoringWithArguments: 
		{ #Foo . RBLintRuleTestData class . (Array 
					with: RBBasicLintRuleTestData class
					with: RBCompositeLintRuleTestData class)})! !

!RBChildrenToSiblingsParametrizedTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self childrenToSiblingTestData! !

!RBChildrenToSiblingsParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBChildrenToSiblingsRefactoring };
		yourself! !

!RBChildrenToSiblingsRefactoring commentStamp: ''!
I am a refactoring operation for moving a class and its subclasses to a new super class.

You can choose which of the original childclasses should become now siblings.

For example,  we can generate a new Superclass for ClassS in
Object >> ClassP >> ClassS
Object >> ClassP >> ClassS >> ClassC1
Object >> ClassP >> ClassS >> ClassC2
Object >> ClassP >> ClassS >> ClassC3

and choose to move ClassC2 and ClassC3 to the new superclass - ClassNewP.

Object >> ClassP >> ClassNewP >> ClassS
Object >> ClassP >> ClassNewP >> ClassS >> ClassC1
Object >> ClassP >> ClassNewP >> ClassC2
Object >> ClassP >> ClassNewP >> ClassC3

Any method and instance variables,  defined in ClassS and used by the new siblings of ClassS are pushed up to the new superclass.

!
!RBChildrenToSiblingsRefactoring methodsFor: 'private - variables' stamp: ''!
pullUpClassVariables
	| newSuperclass |
	newSuperclass := self abstractSuperclass.
	parent classVariableNames do: 
			[:each | 
			self performCompositeRefactoring: (RBPullUpClassVariableRefactoring 
						model: self model
						variable: each
						class: newSuperclass)]! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - methods' stamp: ''!
selectorsToPushUpFrom: aClass 
	| superSelectors |
	superSelectors := self computeSubclassSupersOf: aClass.
	^aClass selectors select: 
			[:each | 
			(superSelectors includes: each) or: [self shouldPushUp: each from: aClass]]! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - methods' stamp: ''!
createSubclassResponsibilityFor: aSelector in: aClass

	| source |

	( aClass superclass definesMethod: aSelector )
		ifTrue: [ ^ self ].
	source := self subclassResponsibilityFor: aSelector in: aClass.
	source ifNil: [ ^ self ].
	aClass superclass compile: source classified: ( aClass protocolsFor: aSelector )! !

!RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self
		addSuperclass;
		pushUpVariables;
		pullUpMethods;
		changeIsKindOfReferences;
		reparentSubclasses! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - methods' stamp: ''!
pushUpMethodsFrom: aClass 
	| selectorsToPushUp |
	selectorsToPushUp := self selectorsToPushUpFrom: aClass.
	aClass selectors do: 
			[:each | 
			(selectorsToPushUp includes: each) 
				ifTrue: [self pushUp: each in: aClass]
				ifFalse: [self createSubclassResponsibilityFor: each in: aClass]].
	selectorsToPushUp do: [:each | aClass removeMethod: each]! !

!RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: ''!
addSuperclass
	self performCompositeRefactoring: (RBAddClassRefactoring 
				model: self model
				addClass: className
				superclass: parent superclass
				subclasses: (Array with: parent)
				category: parent category)! !

!RBChildrenToSiblingsRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^subclasses 
		inject: ((RBCondition isMetaclass: parent) 
				errorMacro: 'Superclass must not be a metaclass') not 
				& (RBCondition isValidClassName: className) 
					& (RBCondition isGlobal: className in: self model) not
		into: 
			[:sub :each | 
			sub 
				& ((RBCondition isMetaclass: each) 
						errorMacro: 'Subclass must <1?not :>be a metaclass') not 
					& (RBCondition isImmediateSubclass: each of: parent)]! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - methods' stamp: ''!
computeSubclassSupersOf: aClass 
	| selectors |
	selectors := Set new.
	aClass subclasses do: 
			[:each | 
			each selectors 
				do: [:sel | selectors addAll: (each parseTreeFor: sel) superMessages]].
	^selectors! !

!RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: ''!
reparentSubclasses
	self model reparentClasses: subclasses to: self abstractSuperclass! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - variables' stamp: ''!
pullUpPoolVariables
	"Don't remove the pool variables from the subclass since they might be referenced there."

	| newSuperclass |
	newSuperclass := self abstractSuperclass.
	parent sharedPoolNames 
		do: [:each | newSuperclass addPoolDictionary: each]! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - methods' stamp: ''!
pushUp: aSelector in: aClass

	| source |

	source := aClass sourceCodeFor: aSelector.
	source
		ifNotNil: [ aClass superclass compile: source classified: ( aClass protocolsFor: aSelector ) ]! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - methods' stamp: ''!
shouldPushUp: aSelector from: aClass
	^ (aClass isMeta
		ifTrue: [ subclasses collect: [ :each | each classSide ] ]
		ifFalse: [ subclasses ])
		anySatisfy: [ :each | (each directlyDefinesMethod: aSelector) not ]! !

!RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: ''!
changeIsKindOfReferences
	| replacer |
	replacer := self parseTreeRewriter.
	replacer replace: '``@object isKindOf: ' , parent name
		with: '``@object isKindOf: ' , className.
	self convertAllReferencesToClass: parent using: replacer! !

!RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: ''!
pullUpMethods
	self pushUpMethodsFrom: parent.
	self pushUpMethodsFrom: parent classSide! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - variables' stamp: ''!
pullUpClassInstanceVariables
	| newSuperclass |
	newSuperclass := self abstractSuperclass classSide.
	parent classSide instanceVariableNames do: 
		[ :each | 
		self performCompositeRefactoring: (RBPullUpInstanceVariableRefactoring 
				model: self model
				variable: each
				class: newSuperclass) ]! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - accessing' stamp: ''!
abstractSuperclass
	^self model classNamed: className asSymbol! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - variables' stamp: ''!
pullUpInstanceVariables
	| newSuperclass |
	newSuperclass := self abstractSuperclass.
	parent instanceVariableNames do: 
			[:each | 
			self performCompositeRefactoring: (RBPullUpInstanceVariableRefactoring 
						model: self model
						variable: each
						class: newSuperclass)]! !

!RBChildrenToSiblingsRefactoring methodsFor: 'initialization' stamp: ''!
name: aClassName class: aClass subclasses: subclassCollection 
	className := aClassName asSymbol.
	parent := self model classFor: aClass.
	subclasses := subclassCollection 
				collect: [:each | self model classFor: each]! !

!RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: ''!
pushUpVariables
	self pullUpInstanceVariables.
	self pullUpClassInstanceVariables.
	self pullUpClassVariables.
	self pullUpPoolVariables! !

!RBChildrenToSiblingsRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' name: #';
		nextPutAll: className;
		nextPutAll: ' class: '.
	parent storeOn: aStream.
	aStream nextPutAll: ' subclasses: '.
	subclasses asArray storeOn: aStream.
	aStream nextPut: $)! !

!RBChildrenToSiblingsRefactoring methodsFor: 'private - methods' stamp: ''!
subclassResponsibilityFor: aSelector in: aClass
	| methodNode position source |
	source := aClass sourceCodeFor: aSelector.
	methodNode := self parserClass
		parseMethod: source
		onError: [ :err :pos | ^ nil ].
	position := methodNode arguments isEmpty
		ifTrue: [ methodNode keywordsIntervals last last ]
		ifFalse: [ methodNode arguments last stop ].
	^ '<1s><n><t>self subclassResponsibility'
		expandMacrosWith: (source copyFrom: 1 to: position)! !

!RBChildrenToSiblingsRefactoring class methodsFor: 'instance creation' stamp: ''!
name: aClassName class: aClass subclasses: subclassCollection 
	^ self new
		name: aClassName
			class: aClass
			subclasses: subclassCollection;
		yourself! !

!RBChildrenToSiblingsRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk name: aClassName class: aClass subclasses: subclassCollection 
	^ self new
		model: aRBSmalltalk;
		name: aClassName
			class: aClass
			subclasses: subclassCollection;
		yourself! !

!RBClass commentStamp: ''!
I represent the instance side of a class in a refactoring namespace. 

You can query methods and (instance) var names, poolDictionaries, class category and comment.

I shouldn't be created directly, but always be part of a refactoring namespace.
My  namespace usally knows me and my meta class.!
!RBClass methodsFor: 'accessing' stamp: ''!
classPool
	^classPool ifNil: [ classPool := Dictionary new ]! !

!RBClass methodsFor: 'variable accessing' stamp: ''!
addPoolDictionary: aString 
	self privatePoolDictionaryNames add: aString asSymbol.
	model addPool: aString to: self! !

!RBClass methodsFor: 'accessing' stamp: ''!
allClassVariableNames

	| sprClass |

	sprClass := self superclass.
	^ sprClass
		ifNil: [ self classVariableNames ]
		ifNotNil: [ sprClass allClassVariableNames , self classVariableNames ]! !

!RBClass methodsFor: 'accessing' stamp: ''!
category: aSymbol 
	category := aSymbol! !

!RBClass methodsFor: 'removing' stamp: ''!
removeProtocolNamed: aString

	model removeProtocolNamed: aString in: self! !

!RBClass methodsFor: 'accessing' stamp: ''!
poolDictionaryNames: aCollectionOfStrings 
	poolDictionaryNames := (aCollectionOfStrings collect: [:each | each asSymbol]) asOrderedCollection! !

!RBClass methodsFor: 'accessing' stamp: ''!
allPoolDictionaryNames

	| sprClass |

	sprClass := self superclass.
	^ sprClass
		ifNil: [ self sharedPoolNames ]
		ifNotNil: [ sprClass allPoolDictionaryNames , self sharedPoolNames ]! !

!RBClass methodsFor: 'testing' stamp: ''!
directlyDefinesPoolDictionary: aString 
	^self sharedPoolNames includes: aString asSymbol! !

!RBClass methodsFor: 'private' stamp: ''!
privatePoolDictionaryNames
	(self isDefined and: [poolDictionaryNames isNil]) 
		ifTrue: 
			[self poolDictionaryNames: (self realClass sharedPools 
						collect: [:each | self realClass environment keyAtValue: each])].
	^poolDictionaryNames! !

!RBClass methodsFor: 'accessing - deprecated' stamp: ''!
theNonMetaClass
	^ self! !

!RBClass methodsFor: 'variable accessing' stamp: ''!
removeClassVariable: aString 
	self privateClassVariableNames remove: aString asSymbol.
	model removeClassVariable: aString from: self! !

!RBClass methodsFor: 'accessing' stamp: ''!
definitionString
	^ String
		streamContents:
			[ :definitionStream | 
			definitionStream
				nextPutAll: self superclass printString;
				nextPutAll: ' subclass: #';
				nextPutAll: self name;
				nextPutAll:
					'
	instanceVariableNames: '''.
			self instanceVariableNames
				do: [ :each | 
					definitionStream
						nextPutAll: each;
						nextPut: $  ].
			definitionStream
				nextPutAll:
					'''
	classVariableNames: '''.
			self classVariableNames
				do: [ :each | 
					definitionStream
						nextPutAll: each;
						nextPut: $  ].
			definitionStream
				nextPutAll:
					'''
	poolDictionaries: '''.
			self sharedPoolNames
				do: [ :each | 
					definitionStream
						nextPutAll: each;
						nextPut: $  ].
			definitionStream
				nextPutAll:
					'''
	category: #'''.
			definitionStream nextPutAll: self category asString.
			definitionStream nextPut: $' ]! !

!RBClass methodsFor: 'accessing' stamp: ''!
classVariableNames
	^self privateClassVariableNames copy! !

!RBClass methodsFor: 'initialization' stamp: ''!
realName: aSymbol 
	self realClass: (self model environment at: aSymbol)! !

!RBClass methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	comment := LookupComment! !

!RBClass methodsFor: 'private' stamp: ''!
privateClassVariableNames
	(self isDefined and: [classVariableNames isNil]) 
		ifTrue: [self classVariableNames: self realClass classVarNames].
	^classVariableNames! !

!RBClass methodsFor: 'variable accessing' stamp: ''!
removeClassVariable: aString ifAbsent: aBlock
	self privateClassVariableNames remove: aString asSymbol ifAbsent: aBlock.
	model removeClassVariable: aString from: self! !

!RBClass methodsFor: 'variable accessing' stamp: ''!
renameClassVariable: oldName to: newName around: aBlock 
	self privateClassVariableNames 
		at: (self privateClassVariableNames indexOf: oldName asSymbol)
		put: newName asSymbol.
	^ self model
		performChange: (changeFactory  
								renameClassVariable: oldName
								to: newName
								in: self)
		around: aBlock! !

!RBClass methodsFor: 'accessing' stamp: ''!
classVariableNames: aCollectionOfStrings 
	classVariableNames := (aCollectionOfStrings 
				collect: [:each | self classPool at: each asSymbol put: nil.
					each asSymbol]) asOrderedCollection! !

!RBClass methodsFor: 'adding' stamp: ''!
addProtocolNamed: aString

	model addProtocolNamed: aString in: self! !

!RBClass methodsFor: 'accessing' stamp: ''!
category

	^ category
		ifNil: [ self isDefined
				ifTrue: [ category := self realClass category ]
				ifFalse: [ model environment whichCategoryIncludes: self name ]
			]
		ifNotNil: [ category ]! !

!RBClass methodsFor: 'variable accessing' stamp: ''!
removePoolDictionary: aString 
	self privatePoolDictionaryNames remove: aString asSymbol! !

!RBClass methodsFor: 'testing' stamp: ''!
directlyDefinesClassVariable: aString

	^self classVariableNames includes: aString asSymbol! !

!RBClass methodsFor: 'accessing' stamp: ''!
comment
	^ comment = LookupComment
		ifTrue: [
			comment := self isDefined
				ifTrue: [ self realClass comment ]
				ifFalse: [ nil ] ]
		ifFalse: [ comment ]! !

!RBClass methodsFor: 'testing' stamp: ''!
isMeta

	^false! !

!RBClass methodsFor: 'accessing' stamp: ''!
comment: aString
	self model changes comment: (comment := aString) in: self! !

!RBClass methodsFor: 'accessing' stamp: ''!
instanceSide

	^ self ! !

!RBClass methodsFor: 'accessing' stamp: ''!
sharedPoolNames

	^self privatePoolDictionaryNames copy! !

!RBClass methodsFor: 'variable accessing' stamp: ''!
addClassVariable: aString 
	self privateClassVariableNames add: aString asSymbol.
	model addClassVariable: aString to: self.
	self classPool at: aString put: nil! !

!RBClass methodsFor: 'accessing' stamp: ''!
poolDictionaryNames

	^ self privatePoolDictionaryNames copy! !

!RBClass methodsFor: 'testing' stamp: ''!
isSharedPool
	
	^ (self allSuperclasses collect:  [:each | each name]) includes: #SharedPool! !

!RBClass methodsFor: 'accessing' stamp: ''!
sharedPools
	^ self allPoolDictionaryNames collect: [ :each | Smalltalk globals at: each asSymbol ifAbsent: [ Dictionary new ] ]! !

!RBClass methodsFor: 'querying' stamp: ''!
methodsUsingClassVariableNamed: aClassVariableName
 
	^ (self realClass classVariableNamed: aClassVariableName) usingMethods collect: [ :aMethod | 			
			|modelClass|
			modelClass := self model classNamed: aMethod methodClass name.
			modelClass methodFor: aMethod selector
		]! !

!RBClass class methodsFor: 'class initialization' stamp: ''!
initialize
	LookupComment := Object new! !

!RBClass class methodsFor: 'instance creation' stamp: ''!
named: aSymbol
	^(self new)
		name: aSymbol;
		yourself! !

!RBClass class methodsFor: 'instance creation' stamp: ''!
existingNamed: aSymbol model: aRBNamespace 
	^ (self named: aSymbol)
		model: aRBNamespace;
		realName: aSymbol;
		yourself! !

!RBClass class methodsFor: 'instance creation' stamp: ''!
existingNamed: aSymbol 
	^(self named: aSymbol)
		realName: aSymbol;
		yourself! !

!RBClassCategoryChange commentStamp: ''!
I'm a change corresponding to a change in the class protocols. !
!RBClassCategoryChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	self copy 
		category: self changeClass category;
		yourself! !

!RBClassCategoryChange methodsFor: 'accessing' stamp: ''!
category: anObject
	category := anObject! !

!RBClassCategoryChange methodsFor: 'accessing' stamp: ''!
changeClass: aBehavior

	super changeClass: aBehavior.
	isMeta := false.! !

!RBClassCategoryChange methodsFor: 'printing' stamp: ''!
printOn: aStream 

	aStream
		nextPutAll: self displayClassName;
		nextPutAll: ' classCategory: ';
		print: self displayCategoryName;
		nextPutAll: ' stamp: ';
		print: self changeStamp;
		nextPutAll: '!!'! !

!RBClassCategoryChange methodsFor: 'printing' stamp: ''!
displayCategoryName

	^ category! !

!RBClassCategoryChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Category ', self displayCategoryName, ' in ', self displayClassName! !

!RBClassCategoryChange methodsFor: 'private' stamp: ''!
primitiveExecute
	
	self changeClass category: category.
	SystemAnnouncer uniqueInstance 
		classReorganized: self changeClass! !

!RBClassCategoryChange class methodsFor: 'instance creation' stamp: ''!
category: aString for: aClass

	^ self new
		changeClass: aClass;
		category: aString;
		yourself! !

!RBClassEnvironment commentStamp: ''!
I am a RBBrowserEnvironment on a set of classes.
I containt all entities of this set.

Example:
(RBBrowserEnvironment new) forClasses: Number withAllSubclasses.!
!RBClassEnvironment methodsFor: 'printing' stamp: ''!
classSelectorDictionary
	^ classes 
		inject: (IdentityDictionary new: classes size)
		into: [ :answer :class |
			answer
				at: class put: (self systemDictionary at: class) selectors;
				yourself ]! !

!RBClassEnvironment methodsFor: 'testing' stamp: ''!
isEmpty
	^classes isEmpty and: [metaClasses isEmpty]! !

!RBClassEnvironment methodsFor: 'accessing' stamp: ''!
problemCount
	^self numberClasses! !

!RBClassEnvironment methodsFor: 'accessing' stamp: ''!
basisObjects
	^ classes! !

!RBClassEnvironment methodsFor: 'testing' stamp: ''!
isClassEnvironment
	^true! !

!RBClassEnvironment methodsFor: 'printing' stamp: ''!
metaClassSelectorDictionary
	^ metaClasses 
		inject: (IdentityDictionary new: metaClasses size)
		into: [ :answer :class |
			answer
				at: class put: (self systemDictionary at: class) class selectors;
				yourself ]! !

!RBClassEnvironment methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: 'Cls: '.
	classes do: [ :cls | aStream nextPutAll: cls, ', ']! !

!RBClassEnvironment methodsFor: 'initialization' stamp: ''!
classes: aCollection 
	aCollection do: [ :each | self addClass: each ]! !

!RBClassEnvironment methodsFor: 'accessing - classes' stamp: ''!
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 classSide ])
			ifTrue: [ aBlock value: class classSide ] ]! !

!RBClassEnvironment methodsFor: 'accessing' stamp: ''!
packages
	^ self classes collect: [:each | each package]! !

!RBClassEnvironment methodsFor: '*Manifest-Core' stamp: ''!
smallLintCritics
	^ self allClasses! !

!RBClassEnvironment methodsFor: 'accessing' stamp: ''!
asSelectorEnvironment

	^RBSelectorEnvironment new
		searchStrings:#();
		label:self label;
		onEnvironment: self environment;
		classSelectors: self classSelectorDictionary metaClassSelectors: self metaClassSelectorDictionary;
		yourself.! !

!RBClassEnvironment methodsFor: 'accessing' stamp: ''!
selectors

	^ Array streamContents: [ :stream |
		self classesDo: [ :class | 
			self selectorsForClass: class do: [ :selector | stream nextPut: selector ] ] ]! !

!RBClassEnvironment methodsFor: 'private' stamp: ''!
defaultLabel
	| stream |
	stream := String new writeStream.
	classes do: 
			[:each | 
			stream nextPutAll: each;
				nextPut: $ ].
	^stream contents! !

!RBClassEnvironment methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	classes := IdentitySet new.
	metaClasses := IdentitySet new! !

!RBClassEnvironment methodsFor: 'visiting' stamp: ''!
acceptVisitor: aEnvVisitor
	^ aEnvVisitor visitClassEnv: self! !

!RBClassEnvironment methodsFor: 'testing' stamp: ''!
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: 'accessing - classes' stamp: ''!
classNames
	^ IdentitySet new
		addAll: classes;
		addAll: metaClasses;
		yourself! !

!RBClassEnvironment methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	classes := classes copy.
	metaClasses := metaClasses copy! !

!RBClassEnvironment methodsFor: 'adding' stamp: ''!
addClassAndMetaClassFor: aClassOrMetaClass
	self
		addClass: aClassOrMetaClass classSide;
		addClass: aClassOrMetaClass instanceSide! !

!RBClassEnvironment methodsFor: 'printing' stamp: ''!
printBasisObject: aClass on: aStream

	^ aStream nextPutAll: aClass! !

!RBClassEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass 
	^(aClass isMeta
		ifTrue: [metaClasses includes: aClass soleInstance name]
		ifFalse: [classes includes: aClass name])
			and: [super includesClass: aClass]! !

!RBClassEnvironment methodsFor: 'testing' stamp: ''!
definesClass: aClass
	
	^ self includesClass: aClass! !

!RBClassEnvironment methodsFor: 'adding' stamp: ''!
addClass: aClass 
	aClass isMeta
		ifTrue: [ metaClasses add: aClass soleInstance name ]
		ifFalse: [ classes add: aClass name ]! !

!RBClassEnvironment methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream nextPut: $(.
	super storeOn: aStream.
	aStream nextPutAll: ' classes: (('.
	classes asArray storeOn: aStream.
	aStream nextPutAll: ' inject: OrderedCollection new into: [:sum :each | 
				| class |
				class := Smalltalk at: each ifAbsent: [nil].
				class notNil ifTrue: [sum add: class].
				sum]) , ('.
	metaClasses asArray storeOn: aStream.
	aStream nextPutAll: ' inject: OrderedCollection new into: [:sum :each | 
				| class |
				class := Smalltalk at: each ifAbsent: [nil].
				class notNil ifTrue: [sum add: class class].
				sum])))'! !

!RBClassEnvironment methodsFor: 'removing' stamp: ''!
removeClass: aClass 
	aClass isMeta
		ifTrue: [metaClasses remove: aClass soleInstance name ifAbsent: []]
		ifFalse: [classes remove: aClass name ifAbsent: []]! !

!RBClassEnvironment class methodsFor: 'api' stamp: ''!
onEnvironment: anEnvironment classes: aCollection
	^(self onEnvironment: anEnvironment)
		classes: aCollection; yourself! !

!RBClassEnvironment class methodsFor: 'api' stamp: ''!
classes: aCollection
	^ self
		onEnvironment: self default
		classes: aCollection! !

!RBClassEnvironment class methodsFor: 'api' stamp: ''!
class: aClass
	^ self classes: { aClass }! !

!RBClassEnvironment class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Classes'! !

!RBClassHierarchyEnvironment commentStamp: ''!
I am a RBBrowserEnvironment on a set of classes of a class hierarchy.

Example:

(RBBrowserEnvironment new) forClass:Morph protocols:{'printing'}.!
!RBClassHierarchyEnvironment methodsFor: 'accessing' stamp: ''!
basisObjects
	^ { class }! !

!RBClassHierarchyEnvironment methodsFor: 'testing' stamp: ''!
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 ] ] ] ]! !

!RBClassHierarchyEnvironment methodsFor: 'accessing' stamp: ''!
packages
	^ self classes collect: [:each | each package]! !

!RBClassHierarchyEnvironment methodsFor: 'accessing' stamp: ''!
class: aClass
	class := aClass! !

!RBClassHierarchyEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass
	^ (aClass == class or: 
		[ (class inheritsFrom: aClass) or: 
			[ aClass inheritsFrom: class ] ]) and: [super includesClass: aClass]! !

!RBClassHierarchyEnvironment methodsFor: 'testing' stamp: ''!
definesClass: aClass
	^ (aClass == class or: 
		[ (class inheritsFrom: aClass) or: 
			[ aClass inheritsFrom: class ] ]) and: [super definesClass: aClass]! !

!RBClassHierarchyEnvironment class methodsFor: 'instance creation' stamp: ''!
onEnvironment: anEnvironment class: aClass
	^ (self onEnvironment: anEnvironment)
		class: aClass;
		yourself! !

!RBClassHierarchyEnvironment class methodsFor: 'instance creation' stamp: ''!
class: aClass
	^ self 
		onEnvironment: self default
		class: aClass! !

!RBClassHierarchyEnvironment class methodsFor: 'accessing' stamp: ''!
defaultName
	^ 'Hier'! !

!RBClassModelFactory commentStamp: ''!
None of the classes inside this package should be directly accessed. They should be accessed via myself. I'm a class factory. 

I'm an important design point: I will let future evolution of the system to be experimented without the needs to change all the users. Then once the experiments and a good solution is found it may be the time to remove me and to think that I'm an overengineered solution. Right now I'm a change enabler. For example people can try to use Ring models to model RBmodel. !
!RBClassModelFactory methodsFor: 'factory access' stamp: ''!
rbNamespace

	^ self class rbNamespace! !

!RBClassModelFactory methodsFor: 'factory access' stamp: ''!
rbTrait

	^ self class rbTrait! !

!RBClassModelFactory methodsFor: 'factory access' stamp: ''!
rbMetaclass

	^ self class rbMetaclass! !

!RBClassModelFactory methodsFor: 'factory access' stamp: ''!
rbClass 

	^ self class rbClass! !

!RBClassModelFactory methodsFor: 'factory access' stamp: ''!
rbMethod

	^ self class rbMethod! !

!RBClassModelFactory methodsFor: 'factory access' stamp: ''!
rbTraitMetaclass

	^ self class rbTraitMetaclass! !

!RBClassModelFactory methodsFor: 'factory access' stamp: ''!
rbPackage

	^ self class rbPackage! !

!RBClassModelFactory class methodsFor: 'factory access' stamp: ''!
rbNamespace
 
	^ RBnamespace ifNil: [ RBnamespace := RBNamespace ]! !

!RBClassModelFactory class methodsFor: 'factory customisation' stamp: ''!
setRBClass: aClass

	RBclass := aClass! !

!RBClassModelFactory class methodsFor: 'factory access' stamp: ''!
rbTrait
 
	^ RBtrait ifNil: [ RBtrait := RBTrait ]! !

!RBClassModelFactory class methodsFor: 'factory customisation' stamp: ''!
setRBMetaclass: aClass

	RBmetaclass := aClass! !

!RBClassModelFactory class methodsFor: 'factory access' stamp: ''!
rbMetaclass
 
	^ RBmetaclass ifNil: [ RBmetaclass := RBMetaclass ]! !

!RBClassModelFactory class methodsFor: 'factory customisation' stamp: ''!
setRBNamespace: aClass
 
	RBnamespace := aClass! !

!RBClassModelFactory class methodsFor: 'factory customisation' stamp: ''!
setRBTraitMetaclass: aClass

	RBtraitMetaclass := aClass! !

!RBClassModelFactory class methodsFor: 'factory access' stamp: ''!
rbClass
 
	^ RBclass ifNil: [ RBclass := RBClass ]! !

!RBClassModelFactory class methodsFor: 'factory access' stamp: ''!
rbMethod
 
	^ RBmethod ifNil: [ RBmethod := RBMethod ]! !

!RBClassModelFactory class methodsFor: 'factory access' stamp: ''!
rbTraitMetaclass
 
	^ RBtraitMetaclass ifNil: [ RBtraitMetaclass := RBTraitedMetaclass ]! !

!RBClassModelFactory class methodsFor: 'factory customisation' stamp: ''!
setRBMethod: aClass

	RBmethod := aClass! !

!RBClassModelFactory class methodsFor: 'factory customisation' stamp: ''!
setRBPackage: aClass
 
	RBpackage := aClass! !

!RBClassModelFactory class methodsFor: 'factory customisation' stamp: ''!
setRBTrait: aClass

	RBtrait := aClass! !

!RBClassModelFactory class methodsFor: 'factory access' stamp: ''!
rbPackage
 
	^ RBpackage ifNil: [ RBpackage := RBPackage ]! !

!RBClassRefactoring commentStamp: ''!
I am an abstract base class for class refactorings.

All that I provide is the class name, my subclass refactorings are operating on, and a instance creation method
for setting the class name and an initial namespace model.

Check method `RBClassRefactoring class>>#model:className:` 

!
!RBClassRefactoring methodsFor: 'initialization' stamp: ''!
className: aName
	className := aName! !

!RBClassRefactoring class methodsFor: 'instance creation' stamp: ''!
className: aName
	^ self new className: aName! !

!RBClassRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBModel className: aName 
	^ self new
		model: aRBModel;
		className: aName;
		yourself! !

!RBClassRefactoring class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBClassRefactoring! !

!RBClassRegexRefactoring commentStamp: ''!
I am a regex refactoring renaming or copying class names.
I offer several models of operation in addition to regex matching. 

Refactored classes can be renamed, copied and kept aside old ones: try renameClasses, copyClasses, or createClasses. 

See also the comment of superclass for a nice script.!
!RBClassRegexRefactoring methodsFor: 'transforming' stamp: ''!
create: aClass name: aSymbol
	^ self duplicate: aClass name: aSymbol deep: false! !

!RBClassRegexRefactoring methodsFor: 'private' stamp: ''!
duplicate: aClass name: aSymbol deep: aBoolean
	| superclass superclassName name class |
	(self model includesClassNamed: aSymbol)
		ifTrue: [ ^ nil ].
	superclass := aClass superclass 
		ifNil: [ self rootClass ].
	superclassName := (self model includesClassNamed: superclass name)
		ifFalse: [ superclass name ]
		ifTrue: [ 
			(name := self execute: superclass name) = superclass name
				ifFalse: [ self duplicate: superclass name: name deep: aBoolean ].
			name ].
	self model defineClass: ('<1s>
		subclass: #<2s>
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: <3p>' 
			expandMacrosWith: superclassName 
			with: aSymbol with: aClass category asString).
	aBoolean ifTrue: [
		(class := self model classNamed: aSymbol) 
			ifNil: [ ^ self ].
		self copyFrom: aClass to: class.
		self copyFrom: aClass classSide to: class classSide ].
	^ nil! !

!RBClassRegexRefactoring methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self createClasses! !

!RBClassRegexRefactoring methodsFor: 'transforming' stamp: ''!
transform
	| replacement refactoring |
	self model allClassesDo: [ :class |
		(class isNil or: [ class isMeta ]) ifFalse: [
			replacement := self execute: class name.
			replacement = class name asString ifFalse: [
				refactoring := self perform: mode
					with: class with: replacement asSymbol.
				(refactoring notNil and: [ refactoring preconditions check ])
					ifTrue: [ refactoring transform ] ] ] ]! !

!RBClassRegexRefactoring methodsFor: 'actions' stamp: ''!
renameClasses
	mode := #rename:name:! !

!RBClassRegexRefactoring methodsFor: 'transforming' stamp: ''!
copy: aClass name: aSymbol
	^ self duplicate: aClass name: aSymbol deep: true! !

!RBClassRegexRefactoring methodsFor: 'transforming' stamp: ''!
rename: aClass name: aSymbol
	^ RBRenameClassRefactoring 
		model: self model
		rename: aClass
		to: aSymbol! !

!RBClassRegexRefactoring methodsFor: 'private' stamp: ''!
copyFrom: aSourceClass to: aTargetClass
	aSourceClass instanceVariableNames
		do: [ :each | aTargetClass addInstanceVariable: each ].
	aSourceClass isMeta ifFalse: [
		aSourceClass allClassVariableNames
			do: [ :each | aTargetClass addClassVariable: each ].
		aSourceClass sharedPoolNames
			do: [ :each | aTargetClass addPoolDictionary: each ] ].
	aSourceClass selectors do: [ :each |
		aTargetClass
			compile: (aSourceClass sourceCodeFor: each)
			classified: (aSourceClass protocolsFor: each) ]! !

!RBClassRegexRefactoring methodsFor: 'accessing' stamp: ''!
rootClass
	^ rootClass ifNil: [ Object ]! !

!RBClassRegexRefactoring methodsFor: 'actions' stamp: ''!
createClasses
	mode := #create:name:! !

!RBClassRegexRefactoring methodsFor: 'actions' stamp: ''!
copyClasses
	mode := #copy:name:! !

!RBClassRegexRefactoring methodsFor: 'initialization' stamp: ''!
rootClass: aClass
	rootClass := aClass instanceSide! !

!RBClassTest methodsFor: 'method tests' stamp: ''!
testDefinesPoolDictionary
	self deny: (objectClass definesPoolDictionary: #OpcodePool).
	self assert: (newClass definesPoolDictionary: #TextConstants).
	self deny: (messageNodeClass definesPoolDictionary: #OpcodePool).
	self assert: ((RBClassModelFactory rbNamespace new classNamed: #Text) 
				definesPoolDictionary: #TextConstants)! !

!RBClassTest methodsFor: 'method tests' stamp: ''!
testHierarchy
	| meta |
	meta := objectClass classSide.
	self assert: (objectClass withAllSubclasses includes: meta).
	self assert: (meta withAllSuperclasses includes: objectClass)! !

!RBClassTest methodsFor: 'method tests' stamp: ''!
testDefinesTraitMethod
	| user trait |
	user := rbNamespace classNamed: #MOPTestClassD.
	self assert: (user definesMethod: #c3).
	self assert: (user definesMethod: #c).
	self assert: (user definesMethod: #c2).
	self assert: (user methodFor: #c2) modelClass ~= user.
	self assert: (user methodFor: #c) modelClass ~= user.
	self assert: (user methodFor: #c3) isNil. "we use nil to represent alias"
	trait := rbNamespace classNamed: #Trait2.
	self assert: (user methodFor: #c2) modelClass equals: trait.
	self assert: (user methodFor: #c) modelClass equals: trait.
	! !

!RBClassTest methodsFor: 'method tests' stamp: ''!
testDefinesInstanceVariable
	self deny: (objectClass definesInstanceVariable: 'instanceVariable1').
	self assert: (newClass definesInstanceVariable: 'instanceVariable1').
	self deny: (messageNodeClass definesInstanceVariable: 'instanceVariable1').
	self assert: (messageNodeClass definesInstanceVariable: 'parent').
	self assert: (messageNodeClass definesInstanceVariable: 'selector')! !

!RBClassTest methodsFor: 'tests' stamp: ''!
testObjectIsNotAbstract
	self deny: objectClass isAbstract.
	self deny: objectClass classSide isAbstract.! !

!RBClassTest methodsFor: 'method tests' stamp: ''!
testDefinesClassVariable
	self deny: (objectClass definesClassVariable: #ClassVariable1).
	self assert: (objectClass definesClassVariable: self objectClassVariable).
	self assert: (newClass definesClassVariable: #ClassVariable1).
	self deny: (messageNodeClass definesClassVariable: #ClassVariable1).
	self 
		assert: (messageNodeClass definesClassVariable: self objectClassVariable)! !

!RBClassTest methodsFor: 'method tests' stamp: ''!
testDefinesMethod
	self assert: (objectClass definesMethod: #printString).
	self assert: (newClass definesMethod: #printString).
	self assert: (messageNodeClass definesMethod: #printString)! !

!RBClassTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	rbNamespace := RBClassModelFactory rbNamespace new.
	objectClass := rbNamespace classNamed: #Object.
	messageNodeClass := rbNamespace classNamed: #RBMessageNode.
	rbNamespace defineClass: 'Object subclass: #SomeClassName
	instanceVariableNames: ''instanceVariable1 instanceVariable2''
	classVariableNames: ''ClassVariable1''
	poolDictionaries: ''TextConstants''
	category: #''Refactory-Testing'''.
	newClass := rbNamespace classNamed: #SomeClassName! !

!RBClassToRename methodsFor: 'performing' stamp: ''!
method1
	^self method2! !

!RBClassToRename methodsFor: 'performing' stamp: ''!
method2
	^self method1! !

!RBClassToRename class methodsFor: 'testing' stamp: ''!
justForTest
	^ 42! !

!RBClassTransformation commentStamp: ''!
I'm a transformation whose focus is class.  !
!RBClassTransformation methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!RBClassTransformation methodsFor: 'accessing' stamp: ''!
definingClass

	^ class ifNil: [ 
		class := self model 
					classObjectFor: self className ]! !

!RBClassTransformation methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	environment := Smalltalk globals! !

!RBClassTransformation methodsFor: 'accessing' stamp: ''!
className: anObject

	className := anObject! !

!RBClassTransformation methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!RBClassTransformation methodsFor: 'accessing' stamp: ''!
className

	^ className ifNil: [ 
		self uiManager
			chooseOrRequestFrom: (self environment allClasses collect: [:each | each name])
			title: 'Class name was not defined to perform ', self class baseClass name,
					 '. Please select a class to resume this transformation.' ]! !

!RBClassUsingSharedPoolForTestData methodsFor: 'accessing - instances and variables' stamp: ''!
msg2

	var1! !

!RBClassUsingSharedPoolForTestData methodsFor: 'accessing' stamp: ''!
var1
	^ var1! !

!RBClassUsingSharedPoolForTestData methodsFor: 'tests - some' stamp: ''!
methodFromTrait
	RBClassToRename justForTest! !

!RBClassUsingSharedPoolForTestData methodsFor: 'accessing - instances and variables' stamp: ''!
msg3

	^ Var1! !

!RBClassUsingSharedPoolForTestData methodsFor: 'accessing - instances and variables' stamp: ''!
msg1

	var1 asString! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RBClassUsingSharedPoolForTestData class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RBClassUsingSharedPoolForTestData class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RBClassesHelp commentStamp: ''!
I am the base class for a HelpTopic/Builder for a set of classes.
I am used to create a list of pages for a class and all of its subclasses.
Unlike the ClassApiHelpBilder, I only put the class comments as page content and
ignore any method / method comments.!
!RBClassesHelp class methodsFor: 'building' stamp: ''!
asHelpTopic
	^ self buildClassHierarchyHelpFrom: self rootHelpClass! !

!RBClassesHelp class methodsFor: 'building' stamp: ''!
rootHelpClass
	^ self subclassResponsibility ! !

!RBClassesHelp class methodsFor: 'building' stamp: ''!
buildClassHierarchyHelpFrom: aRootClass
	| topic |
	topic := HelpTopic named: aRootClass name.
	topic iconName: #classIcon.
	topic contents: aRootClass comment.
	aRootClass
		subclassesDo: [ :subclass | topic addSubtopic: (self buildClassHierarchyHelpFrom: subclass) ].
	^ topic! !

!RBCombinatorVisitor commentStamp: ''!
I am a visitor to find differents combinations of sequences nodes!
!RBCombinatorVisitor methodsFor: 'visiting' stamp: ''!
initialize
	combinations := OrderedCollection new.! !

!RBCombinatorVisitor methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode
	| starts ends |
	starts := aSequenceNode statements collect: [ :node | node start ].
	ends := aSequenceNode statements collect: [ :node | node stop ].
	starts do: [ :start | ends do: [ :end | start < end ifTrue: [
		combinations add: (Array with: start with: end) ] ] ].
	super visitSequenceNode: aSequenceNode
	
	! !

!RBCombinatorVisitor methodsFor: 'accessing' stamp: ''!
combinations
	^ combinations! !

!RBComment commentStamp: ''!
An RBComment represents a text comment associated with an AST node.

An RBComment is not an AST-Node (not a subclass of program node). But its instances are just wrapping the comment text and (start-) position.

Due to the way the parser handles comments, the RBComment is assigned to its preceding (real) AST node, although we often write the comment prior to a statement.

For example:

foo
"method comment"

self firstStatement.

"comment about the return"
^ self

The "method comment" is assigned to the method node, the "comment about the return" is assigned
to the "self firstStatement" node!!

instance variables
	contents 	<String> the comment text
	start	<Number> (start-) position within the method source
!
!RBComment methodsFor: 'accessing' stamp: ''!
stop
	^ stop ifNil: [ start + self size - 1 ]
			 ifNotNil: [ stop ].! !

!RBComment methodsFor: 'comparing' stamp: ''!
= anObject
	self == anObject ifTrue: [ ^true ].
	^ self class = anObject class ifTrue: [ self contents = anObject contents ] ifFalse: [ false ]! !

!RBComment methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	"At some point we will have to think what we do to visit comment. 
	It may have an impact on visitors so this should be done carefully.
	Since by default previously comment node were not subclass of ProgramNode 
	we do nothing by default."! !

!RBComment methodsFor: 'comparing' stamp: ''!
hash
	^ self contents hash! !

!RBComment methodsFor: '*PharoDocComment' stamp: ''!
pharoDocCommentNodes
	self hasDocComment ifFalse: [ ^#() ].
	^ self propertyAt: #pharoDocCommentNodes ifAbsentPut: [PharoDocCommentNode parseDocComments: self]! !

!RBComment methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' "'.
	aStream nextPutAll: contents.
	aStream nextPutAll: '" '.! !

!RBComment methodsFor: 'enumeration' stamp: ''!
size
	^ contents size + 2 "must take into account quotation marks"! !

!RBComment methodsFor: '*PharoDocComment' stamp: ''!
hasDocComment
	^ (self hasProperty: #pharoDocCommentNodes) or: [contents includesSubstring: '>>>']! !

!RBComment methodsFor: 'accessing' stamp: ''!
start
	^ start! !

!RBComment methodsFor: 'accessing' stamp: ''!
contents
	^ contents! !

!RBComment methodsFor: 'testing' stamp: ''!
isCommentNode 
	^true! !

!RBComment methodsFor: 'instance creation' stamp: ''!
with: aString from: aStartPosition to: aStopPosition
	start := aStartPosition.
	stop := aStopPosition.
	contents := aString.! !

!RBComment class methodsFor: 'instance creation' stamp: ''!
with: aString at: startPosition

	^ self with: (RBCommentToken
			   value: aString
			   start: startPosition
			   stop: startPosition + aString size - 1)! !

!RBComment class methodsFor: 'instance creation' stamp: ''!
with: aCommentToken
	"To respect the previously implemented comment node content, 
	 we strip the surrounding quotes of the comment."
	^ self new
		with: aCommentToken value from: aCommentToken start to: aCommentToken stop;
		yourself.! !

!RBCommentChange commentStamp: ''!
I am a refactory change for a class comment change. Creating a RBClass during a refactoring operation and 
setting its class comment will create a comment change. Executing this change will set the class comment of the
class with my change stamp.!
!RBCommentChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ self copy
		  comment: self changeClass organization classComment;
		  yourself! !

!RBCommentChange methodsFor: 'accessing' stamp: ''!
changeClass: aBehavior

	super changeClass: aBehavior.
	isMeta := false! !

!RBCommentChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self displayClassName;
		nextPutAll: ' classComment: ';
		print: (self comment copyReplaceAll: '!!' with: '!!!!');
		nextPutAll: ' stamp: ';
		print: self changeStamp;
		nextPutAll: '!!'! !

!RBCommentChange methodsFor: 'accessing' stamp: ''!
comment

	^ comment! !

!RBCommentChange methodsFor: 'accessing' stamp: ''!
comment: aString

	comment := aString! !

!RBCommentChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Comment ' , self displayClassName! !

!RBCommentChange methodsFor: 'private' stamp: ''!
primitiveExecute

	self changeClass classComment: comment stamp: self changeStamp.
	SystemAnnouncer uniqueInstance classCommented: self changeClass! !

!RBCommentChange class methodsFor: 'instance creation' stamp: ''!
comment: aString in: aClass

	^ self new
		  changeClass: aClass;
		  comment: aString;
		  yourself! !

!RBCommentNodeVisitor commentStamp: ''!
Visit any RBCommentNode in the syntax tree and evaluate a generic block.

The block  has two optional parameters:  
	aCommentArray (the collection of 1 or more RBComment's)
	aNode (the node which contains the comment)!
!RBCommentNodeVisitor methodsFor: 'visiting' stamp: ''!
visitNode: aNode
	aNode comments ifNotEmpty: [ :commentNodes |
		commentNodes do: [ :commentNode |
			self visitBlock cull: commentNode cull: aNode ] ].
	
	super visitNode: aNode! !

!RBCommentNodeVisitorTest commentStamp: ''!
SUnit tests for RBCommentNodeVisitor!
!RBCommentNodeVisitorTest methodsFor: 'tests' stamp: ''!
testVisitDo
	| node tree count |
	tree := self parseExpression: '
	"comment 1"
	"comment 2"
	"comment 3"
	^true'.
	
	count := 0.
	node := RBCommentNodeVisitor visit: tree do: [ :n | count := count + 1 ].
	
	self 
		assert: count equals: 3! !

!RBCommentNodeVisitorTest methodsFor: 'tests' stamp: ''!
testVisitDetect
	| node tree |
	tree := self parseExpression: '
	"comment 1"
	"comment 2"
	"comment 3"
	^true'.
	
	node := RBCommentNodeVisitor visit: tree detect: [ :n | n intersectsInterval: (20 to: 20) ].
	
	self 
		assert: node contents equals: 'comment 2'! !

!RBCommentNodeVisitorTest methodsFor: 'tests' stamp: ''!
testVisitSelect
	| node tree |
	tree := self parseExpression: '
	"comment 1"
	"comment 2"
	"comment 3"
	^true'.
	
	node := RBCommentNodeVisitor visit: tree select: [ :n | n contents endsWith: '2'].
	
	self 
		assert: node first contents equals: 'comment 2'! !

!RBCommentTest commentStamp: ''!
SUnit tests for RBComment!
!RBCommentTest methodsFor: 'tests' stamp: ''!
testIntersectsInterval
	| node |
	node:= RBComment with: (RBCommentToken value: 'Some sample text' start: 5 stop: 21).
	
	self 
		assert: (node intersectsInterval: (4 to: 6)) description: 'either side of interval';
		assert: (node intersectsInterval: (4 to: 5)) description: 'before and on interval';
		assert: (node intersectsInterval: (5 to: 6)) description: 'and and after interval';
		assert: (node intersectsInterval: (5 to: 5)) description: 'on interval interval';
		assert: (node intersectsInterval: (1 to: 4)) not description: 'not in interval'! !

!RBCommentToken methodsFor: 'accessing' stamp: ''!
stop
	^ stopPosition! !

!RBCommentToken methodsFor: 'accessing' stamp: ''!
last

	^ self stop! !

!RBCommentToken methodsFor: 'accessing' stamp: ''!
stop: aPosition
	stopPosition := aPosition! !

!RBCommentToken methodsFor: 'accessing' stamp: ''!
first

	^ self start! !

!RBCommentToken methodsFor: 'testing' stamp: ''!
isComment
	^true! !

!RBCommentToken class methodsFor: 'instance creation' stamp: ''!
value: aString start: aStartPosition stop: aStopPosition
	^self new value: aString;
		   		 start: aStartPosition;
				 stop: aStopPosition.! !

!RBComposeParametrizedTest methodsFor: 'asserting' stamp: ''!
shouldFail: refactoringColl

	self proceedThroughWarning: [
		self should: [ refactoringColl do: [ :ref |
				ref primitiveExecute ] ] raise: RBRefactoringError ]! !

!RBComposeParametrizedTest methodsFor: 'accessing' stamp: ''!
isComposed: aBoolean 
	isComposed := aBoolean! !

!RBComposeParametrizedTest methodsFor: 'asserting' stamp: ''!
shouldWarn: aRefactoringColl 
	self 
		should: [ self executeRefactorings: aRefactoringColl ]
		raise: RBRefactoringWarning! !

!RBComposeParametrizedTest methodsFor: 'accessing' stamp: ''!
createRefactoringWithModel: rbNamespace andArguments: aParameterCollection
	^ isComposed 
	ifTrue: [ {super createRefactoringWithModel: rbNamespace andArguments: {aParameterCollection}} ] 
	ifFalse: [ aParameterCollection collect: [ :e |
		super createRefactoringWithModel: rbNamespace andArguments: {e	}	
	] ]! !

!RBComposeParametrizedTest methodsFor: 'accessing' stamp: ''!
createRefactoringWithArguments: aParameterCollection
	^ isComposed 
	ifTrue: 
		[ {super createRefactoringWithArguments: aParameterCollection} ]
	ifFalse: [  aParameterCollection collect: [ :e | 
			super createRefactoringWithArguments: {e} ]
	 ]! !

!RBCompositeEnvironment methodsFor: '*Calypso-NavigationModel' stamp: ''!
query: aQuery

	self isBasedOnEmptyBasis ifTrue: [ 
		"It is optimization to prevent real query execution in remote scenario.
		Any query is a priory empty when its scope is based on empty basis"
		^ClyUnknownQueryResult instance ].

	aQuery ensureScope: self.

	^RBBrowserEnvironment default query: aQuery! !

!RBCompositeEnvironment methodsFor: 'accessing' stamp: ''!
operator
	self subclassResponsibility! !

!RBCompositeEnvironment methodsFor: 'accessing' stamp: ''!
description
	^ (environment descriptionUntil: 15),
		self operator,
		(otherEnvironment  descriptionUntil: 15)! !

!RBCompositeEnvironment methodsFor: 'testing' stamp: ''!
isCompositeEnvironment
	^ true! !

!RBCompositeEnvironment methodsFor: 'accessing' stamp: ''!
shortDescription
	^ self description ! !

!RBCompositeEnvironment methodsFor: 'accessing' stamp: ''!
otherEnvironment
	^ otherEnvironment! !

!RBCompositeLintRule commentStamp: ''!
A RBCompositeLintRule is a composite rule holding rules.!
!RBCompositeLintRule methodsFor: 'testing' stamp: ''!
isEmpty
	^ rules allSatisfy: [ :each | each isEmpty ]! !

!RBCompositeLintRule methodsFor: 'accessing' stamp: ''!
problemCount
	^ rules inject: 0 into: [ :count :each | count + each problemCount ]! !

!RBCompositeLintRule methodsFor: 'running' stamp: ''!
checkClass: aClass 
	rules do: [ :each | each checkClass: aClass ]! !

!RBCompositeLintRule methodsFor: 'running' stamp: ''!
checkMethod: aMethod 
	rules do: [ :each | each checkMethod: aMethod ]! !

!RBCompositeLintRule methodsFor: 'adding/removing' stamp: ''!
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: 'initialization' stamp: ''!
resetResult
	rules do: [ :each | each resetResult ]! !

!RBCompositeLintRule methodsFor: 'running' stamp: ''!
basicCheck: anEntity
	"this has to be rewritten in a smarter way, when the complete implementation with critics will be ready".
	
	^ (self leaves select: [ :rule | rule class perform: (
		anEntity isCompiledMethod
			ifTrue: [ #checksMethod ]
			ifFalse: [ #checksClass ]) ]) anySatisfy: [ :rule |
				rule basicCheck: anEntity ]! !

!RBCompositeLintRule methodsFor: 'adding/removing' stamp: ''!
sort: aBlock
	
	rules first isComposite
		ifTrue: [ rules do: [ :rule | rule sort: aBlock ]] 
		ifFalse: [ self rules: (rules sort: aBlock) ]! !

!RBCompositeLintRule methodsFor: 'accessing' stamp: ''!
rules: aCollection
	rules := aCollection! !

!RBCompositeLintRule methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!RBCompositeLintRule methodsFor: 'testing' stamp: ''!
hasConflicts
	^ rules anySatisfy: [ :each | each hasConflicts ]! !

!RBCompositeLintRule methodsFor: 'accessing' stamp: ''!
changes
	^ rules flatCollect: [ :each  | each changes ]! !

!RBCompositeLintRule methodsFor: 'accessing' stamp: ''!
name: aString
	name := aString! !

!RBCompositeLintRule methodsFor: 'testing' stamp: ''!
isComposite
	^ true! !

!RBCompositeLintRule methodsFor: 'accessing' stamp: ''!
leaves

	^ rules flatCollect: [ :rule | rule leaves ]	
! !

!RBCompositeLintRule methodsFor: 'accessing' stamp: ''!
rules
	^ rules! !

!RBCompositeLintRule methodsFor: 'running' stamp: ''!
checkPackage: aPackage 
	rules do: [ :each | each checkPackage: aPackage ]! !

!RBCompositeLintRule class methodsFor: '*Manifest-Core' stamp: ''!
rulesClassifiedFor: aRuleClass
	| groups rules |
	groups := Dictionary new.
	(self rulesFor: aRuleClass) do: [ :each |
		(groups at: each group ifAbsentPut: [ OrderedCollection new ])
			addLast: each ].
	rules := SortedCollection sortBlock: [ :a :b | a name <= b name ].
	groups keysAndValuesDo: [ :group :elements |
		rules addLast: (RBCompositeLintRule 
			rules: elements asArray
			name: group) ].
	^ rules asArray! !

!RBCompositeLintRule class methodsFor: 'accessing' stamp: ''!
allRules
	^ self rules: (Array with: self lintChecks with: self transformations) name: 'All checks'! !

!RBCompositeLintRule class methodsFor: 'instance creation' stamp: ''!
rules: aCollection name: aString
	^ self new
		rules: aCollection;
		name: aString;
		yourself! !

!RBCompositeLintRule class methodsFor: 'accessing' stamp: ''!
transformations
	^ self rules: (self rulesGroupedFor: RBTransformationRule) name: 'Transformations'! !

!RBCompositeLintRule class methodsFor: 'accessing' stamp: ''!
lintChecks
	^ self rules: (self rulesGroupedFor: RBBasicLintRule) name: 'Lint checks'! !

!RBCompositeLintRule class methodsFor: 'instance creation' stamp: ''!
rules: aCollection
	^ self new
		rules: aCollection;
		yourself! !

!RBCompositeLintRule class methodsFor: '*Manifest-Core' stamp: ''!
allGoodRules
	^ self rules: (self rulesClassifiedFor: RBLintRule) name: 'All Rules'! !

!RBCompositeLintRule class methodsFor: 'instance creation' stamp: ''!
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: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'CompositeLintRule'! !

!RBCompositeLintRule class methodsFor: 'instance creation' stamp: ''!
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! !

!RBCompositeLintRuleTestData methodsFor: 'testing' stamp: ''!
isEmpty
	^ rules allSatisfy: [ :each | each isEmpty ]! !

!RBCompositeLintRuleTestData methodsFor: 'accessing' stamp: ''!
problemCount
	^rules inject: 0 into: [:count :each | count + each problemCount]! !

!RBCompositeLintRuleTestData methodsFor: 'accessing' stamp: ''!
checkClass: aSmalllintContext 
	rules do: 
			[:each | 
			each checkClass: aSmalllintContext.
			Processor yield]! !

!RBCompositeLintRuleTestData methodsFor: 'accessing' stamp: ''!
checkMethod: aSmalllintContext 
	rules do: 
			[:each | 
			each checkMethod: aSmalllintContext.
			Processor yield]! !

!RBCompositeLintRuleTestData methodsFor: 'initialization' stamp: ''!
resetResult
	rules do: [:each | each resetResult]! !

!RBCompositeLintRuleTestData methodsFor: 'private' stamp: ''!
viewResults
	rules do: [:each | each viewResults]! !

!RBCompositeLintRuleTestData methodsFor: 'initialization' stamp: ''!
rules: aCollection
	rules := aCollection! !

!RBCompositeLintRuleTestData methodsFor: 'accessing' stamp: ''!
failedRules
	^rules inject: OrderedCollection new into: [:oc :each | oc addAll: each failedRules; yourself]! !

!RBCompositeLintRuleTestData methodsFor: 'testing' stamp: ''!
hasConflicts
	^ rules anySatisfy: [ :each | each hasConflicts ]! !

!RBCompositeLintRuleTestData methodsFor: 'testing' stamp: ''!
isComposite
	^true! !

!RBCompositeLintRuleTestData methodsFor: 'accessing' stamp: ''!
rules
	^rules! !

!RBCompositeLintRuleTestData class methodsFor: 'instance creation' stamp: ''!
allRules
	^self ruleFor: self protocol: 'all checks'! !

!RBCompositeLintRuleTestData class methodsFor: 'instance creation' stamp: ''!
rules: aCollection name: aString 
	^(self new) rules: aCollection;
		name: aString;
		yourself! !

!RBCompositeLintRuleTestData class methodsFor: 'all checks' stamp: ''!
transformations
	^ self 
		ruleFor: RBTransformationRuleTestData
		protocol: 'transformations'! !

!RBCompositeLintRuleTestData class methodsFor: 'all checks' stamp: ''!
lintChecks
	^ self 
		rules: (RBBasicLintRuleTestData protocolsToCheck collect: 
			[ :each | 
			self 
				ruleFor: RBBasicLintRuleTestData
				protocol: each ])
		name: 'Lint checks'! !

!RBCompositeLintRuleTestData class methodsFor: 'instance creation' stamp: ''!
rules: aCollection 
	^self new rules: aCollection! !

!RBCompositeLintRuleTestData class methodsFor: 'instance creation' stamp: ''!
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)! !

!RBCompositeMethodTransformation methodsFor: 'accessing' stamp: ''!
definingClass

	^ self model classObjectFor: class! !

!RBCompositeMethodTransformation methodsFor: 'accessing' stamp: ''!
definingMethod

	^ self definingClass parseTreeFor: selector asSymbol! !

!RBCompositeRefactoryChange commentStamp: ''!
I am a composition of RBRefactoryChanges. I hold a list of changes. 
I implement many "environment change" operation like renameClass/removeClass/ rename instance variable that are
actually called on the name space by a refactoring operation and my responsibilty is to create a appropriate refactoring change
and save it in my list of changes.
!
!RBCompositeRefactoryChange methodsFor: 'private' stamp: ''!
executeNotifying: aBlock

	| undos undo |
	undos := changes collect: [ :each | each executeNotifying: aBlock ].
	undo := self copy.
	undo changes: undos reversed.
	^ undo! !

!RBCompositeRefactoryChange methodsFor: 'accessing' stamp: ''!
problemCount

	^ self changesSize! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
addPackageNamed: aString

	^ self addChange: (changeFactory addPackageNamed: aString)! !

!RBCompositeRefactoryChange methodsFor: 'comparing' stamp: ''!
= 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: 'accessing' stamp: ''!
changeForMetaclass: aClassName selector: aSelector

	changes reverseDo: [ :each | 
		| change |
		change := each changeForMetaclass: aClassName selector: aSelector.
		change notNil ifTrue: [ ^ change ] ].
	^ nil! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
compile: source in: class classified: aProtocol

	^ self addChange:
		  (changeFactory
			   addMethodSource: source
			   in: class
			   classified: aProtocol)! !

!RBCompositeRefactoryChange methodsFor: 'comparing' stamp: ''!
hash

	^ self class hash bitXor: self changes size hash! !

!RBCompositeRefactoryChange methodsFor: '*Refactoring2-Core' stamp: ''!
addProtocolNamed: aString in: aClass

	^ self addChange:
		  (RBAddProtocolChange addProtocolNamed: aString in: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
addClassVariable: variableName to: aClass

	^ self addChange:
		  (changeFactory addClassVariable: variableName to: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'accessing' stamp: ''!
changeForClass: aClassName selector: aSelector

	changes reverseDo: [ :each | 
		| change |
		change := each changeForClass: aClassName selector: aSelector.
		change notNil ifTrue: [ ^ change ] ].
	^ nil! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
defineClass: aString

	^ self addChange: (changeFactory addClassDefinition: aString)! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
removeMethod: aSelector from: aClass

	^ self addChange:
		  (changeFactory removeMethod: aSelector from: aClass)! !

!RBCompositeRefactoryChange methodsFor: '*Refactoring2-Core' stamp: ''!
removeProtocolNamed: aString in: aClass 
	self flag: #todo. 
	"This change is not made via the changefactory!!!!!!"
	^ self addChange: (RBRemoveProtocolChange removeProtocolNamed: aString in: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'accessing' stamp: ''!
changeClass

	^ self subclassResponsibility! !

!RBCompositeRefactoryChange methodsFor: 'accessing' stamp: ''!
newName

	^ self subclassResponsibility! !

!RBCompositeRefactoryChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	name ifNil: [ ^ super printOn: aStream ].
	aStream nextPutAll: name! !

!RBCompositeRefactoryChange methodsFor: 'accessing' stamp: ''!
removeChange: aChange

	^ changes remove: aChange ifAbsent: [ ]! !

!RBCompositeRefactoryChange methodsFor: '*NautilusRefactoring' stamp: ''!
whatToDisplayIn: aBrowser

	^ self changes flatCollect: [:each | each whatToDisplayIn: aBrowser ]! !

!RBCompositeRefactoryChange methodsFor: '*Refactoring2-Core' stamp: ''!
category: aString for: aClass 

	^ self addChange: (RBClassCategoryChange category: aString for: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'private - inspector accessing' stamp: ''!
changes

	^ changes! !

!RBCompositeRefactoryChange methodsFor: 'private - inspector accessing' stamp: ''!
changes: aCollection

	changes := aCollection! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
comment: aString in: aClass

	^ self addChange: (changeFactory comment: aString in: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'accessing' stamp: ''!
renameChangesForClass: oldClassName to: newClassName

	^ self copy
		  changes: (self changes collect: [ :each | 
					   each renameChangesForClass: oldClassName to: newClassName ]);
		  yourself! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
renameClassVariable: oldNameLocal to: newNameLocal in: aClass

	^ self addChange: (changeFactory
			   renameClassVariable: oldNameLocal
			   to: newNameLocal
			   in: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'accessing' stamp: ''!
oldName

	^ self subclassResponsibility! !

!RBCompositeRefactoryChange methodsFor: 'accessing' stamp: ''!
addChange: aRefactoryChange

	changes add: aRefactoryChange.
	^ aRefactoryChange! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
removeInstanceVariable: variableName from: aClass

	^ self addChange:
		  (changeFactory removeInstanceVariable: variableName from: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	changes := OrderedCollection new! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
addPool: aPoolVariable to: aClass

	^ self addChange:
		  (changeFactory addPoolVariable: aPoolVariable to: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'copying' stamp: ''!
postCopy

	super postCopy.
	changes := changes collect: [ :each | each copy ]! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
renameInstanceVariable: oldNameLocal to: newNameLocal in: aClass

	^ self addChange: (changeFactory
			   renameInstanceVariable: oldNameLocal
			   to: newNameLocal
			   in: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
removeClassVariable: variableName from: aClass

	^ self addChange:
		  (changeFactory removeClassVariable: variableName from: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
removePool: aPoolVariable from: aClass

	^ self addChange:
		  (changeFactory removePoolVariable: aPoolVariable from: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
removeClassNamed: aSymbol

	^ self addChange: (changeFactory removeClassNamed: aSymbol)! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
compile: source in: class

	^ self addChange: (changeFactory addMethodSource: source in: class)! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
addInstanceVariable: variableName to: aClass

	^ self addChange:
		  (changeFactory addInstanceVariable: variableName to: aClass)! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
renameClass: class to: newNameLocal

	^ self addChange: (changeFactory renameClass: class to: newNameLocal)! !

!RBCompositeRefactoryChange methodsFor: '*Refactoring2-Core' stamp: ''!
selector: aSelector in: aClass classified: aProtocol
	self flag: #todo. 
	"This change is not made via the changefactory!!!!!!"
	^ self addChange: (RBMethodProtocolChange
							selector: aSelector
							in: aClass
							classified: aProtocol)! !

!RBCompositeRefactoryChange methodsFor: 'refactory - changes' stamp: ''!
removeClass: aClass

	^ self addChange: (changeFactory removeClassNamed: aClass name)! !

!RBCompositeRefactoryChange methodsFor: 'accessing' stamp: ''!
changesSize

	^ changes inject: 0 into: [ :sum :each | sum + each changesSize ]! !

!RBCompositeRefactoryChange class methodsFor: 'instance creation' stamp: ''!
named: aString

	^ self new
		  name: aString;
		  yourself! !

!RBCompositeTransformation methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	delegatesPreconditions := true! !

!RBCompositeTransformation methodsFor: 'accessing' stamp: ''!
previousTransformations
	^ previousTransformations ifNil: [ previousTransformations := OrderedCollection new ]! !

!RBCompositeTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	"it delegates the preconditionn checking to each sub-refactoring separately.
	 additional preconditions are welcomed"

	^ self emptyCondition! !

!RBCompositeTransformation methodsFor: 'accessing' stamp: ''!
transformations

	^ transformations ifNil: [ transformations := self buildTransformations ]! !

!RBCompositeTransformation methodsFor: 'accessing' stamp: ''!
delegatesPreconditions: aBoolean

	delegatesPreconditions := aBoolean! !

!RBCompositeTransformation methodsFor: 'accessing' stamp: ''!
transformations: anObject
	transformations := anObject! !

!RBCompositeTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	"in refactoring mode, the transformation can do its own precondition checking,
	 therefore not needing checking from its containing transformations"

	(self previousTransformations, self transformations) do: [ :transformation |
		transformation
			copyOptionsFrom: self options;
			model: self model;
			preconditionChecking: (delegatesPreconditions & self preconditionChecking);
			transform ]! !

!RBCompositeTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	self subclassResponsibility! !

!RBCompositeTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel with: aCollection

	^ self new
		model: aRBModel;
		transformations: aCollection;
		yourself! !

!RBCompositeTransformation class methodsFor: 'api' stamp: ''!
with: aCollection

	^ self new
		transformations: aCollection;
		yourself! !

!RBCompositeVariableTransformation methodsFor: 'accessing' stamp: ''!
definingClass

	^ self model classObjectFor: className! !

!RBCompositeVariableTransformation class methodsFor: 'api' stamp: ''!
variable: aVariableName class: aClassName isClassVariable: aBoolean

	^ self new
		variable: aVariableName
		class: aClassName
		classVariable: aBoolean;
		yourself! !

!RBCompositeVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel classVariable: aVariableName class: aClassName

	^ self new
		model: aRBModel;
		variable: aVariableName
		class: aClassName
		classVariable: true;
		yourself! !

!RBCompositeVariableTransformation class methodsFor: 'api' stamp: ''!
instanceVariable: aVariableName class: aClassName

	^ self new
		variable: aVariableName
		class: aClassName
		classVariable: false;
		yourself! !

!RBCompositeVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel variable: aVariableName class: aClassName isClassVariable: aBoolean

	^ self new
		model: aRBModel;
		variable: aVariableName
		class: aClassName
		classVariable: aBoolean;
		yourself! !

!RBCompositeVariableTransformation class methodsFor: 'api' stamp: ''!
classVariable: aVariableName class: aClassName

	^ self new
		variable: aVariableName
		class: aClassName
		classVariable: true;
		yourself! !

!RBCompositeVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel instanceVariable: aVariableName class: aClassName

	^ self new
		model: aRBModel;
		variable: aVariableName
		class: aClassName
		classVariable: false;
		yourself! !

!RBCondition commentStamp: ''!
I am a refactoring condition for doing a precondition check for refactoring operations.

A precondition check returns true or false and is used by refactoring operations to check whether the operation is applicable to the target entity (class or method refactoring).

You can set the block code used for testing the condition (#withBlock:).
And I define some factory methods on my class side for creating instances of me, for some typically usage. 

For example: 
This creates a condition checking if the class named #Morph implements a selector named #drawOn:
(RBCondition definesSelector:#drawOn: in: (RBClass existingNamed:#Morph)).

Most users of me are refactoring operations and use my methods on the class side for creating instances.
!
!RBCondition methodsFor: 'accessing' stamp: ''!
errorBlockFor: aBoolean
	^errorBlock! !

!RBCondition methodsFor: 'checking' stamp: ''!
check
	^block value! !

!RBCondition methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream nextPutAll: type asString! !

!RBCondition methodsFor: 'initialization' stamp: ''!
errorBlock: anObject
	errorBlock := anObject! !

!RBCondition methodsFor: 'initialization' stamp: ''!
withBlock: aBlock 
	block := aBlock.
	type := #(#generic)! !

!RBCondition methodsFor: 'initialization' stamp: ''!
type: aSymbol block: aBlock errorString: aString 
 	type := aSymbol.
	block := aBlock.
	self errorMacro: aString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
isSymbol: aString
	^self new
		type: (Array with: #isSymbol with: aString)
		block: [aString isSymbol]
		errorString: aString , ' is <1?:not >a symbol'! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
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: 'utilities' stamp: ''!
methodDefiningTemporary: aString in: aClass ignore: aBlock 
	| searcher method |
	searcher := RBParseTreeSearcher new.
	method := nil.	"Shut-up the warning"
	searcher matches: aString do: [:aNode :answer | ^method].
	aClass withAllSubclasses do: 
			[:class | 
			class selectors do: 
					[:each | 
					(aBlock value: class value: each) 
						ifFalse: 
							[| parseTree |
							method := class methodFor: each.
							parseTree := class parseTreeFor: each.
							parseTree notNil ifTrue: [searcher executeTree: parseTree]]]].
	^nil! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
hasSubclasses: aClass excluding: classList 
	^self new
		type: (Array with: #hasSubclasses with: aClass)
		block: [ ((aClass subclasses collect: [:each | each name]) copyWithoutAll: classList) isNotEmpty ]
		errorString: aClass printString , ' has <1?:no >subclasses'! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
definesInstanceVariable: aString in: aClass 
	^self new 
		type: (Array 
				with: #definesInstVar
				with: aClass
				with: aString)
		block: [aClass definesInstanceVariable: aString]
		errorString: aClass printString 
				, ' <1?:does not >define<1?s:> instance variable ' , aString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
empty
	"Returns an empty condition"

	^self new 
		type: (Array with: #empty)
		block: [true]
		errorString: 'Empty'! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
hierarchyOf: aClass definesVariable: aString 
	^self new 
		type: (Array 
				with: #hierarchyDefinesInstVar
				with: aClass
				with: aString)
		block: [aClass hierarchyDefinesVariable: aString]
		errorString: aClass printString 
				, ' or one of its subclasses <1?:does not >define<1?s:> variable ' 
					, aString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
isSubclass: subclass of: superClass
	^self new
		type: (Array with: #subclass with: superClass with: subclass)
		block: [subclass includesClass: superClass]
		errorString: subclass printString , ' is <1?:not >a subclass of ' , superClass printString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
definesClassVariable: aString in: aClass 
	^self new 
		type: (Array 
				with: #definesClassVar
				with: aClass
				with: aString)
		block: [aClass definesClassVariable: aString]
		errorString: aClass printString 
				, ' <1?:does not >define<1?s:> class variable ' , aString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
hierarchyOf: aClass canUnderstand: aSelector
	^self new
		type: (Array with: #hierarchyUnderstandsSelector with: aClass with: aSelector)
		block: [aClass hierarchyDefinesMethod: aSelector]
		errorString: aClass printString , ' <1? and/or part of it''s Hierarchy already: and/or part of it''s Hierarchy do not> understand<1?s:> ' , aSelector printString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
definesTempVar: aString in: aClass ignoreClass: subclass 
	| condition |
	condition := self new.
	condition 
		type: (Array with: #definesTempVarIgnoring with: aClass with: aString with: subclass)
		block: 
			[| method |
			method := self 
						methodDefiningTemporary: aString
						in: aClass
						ignore: [:class :aSelector | class includesClass: subclass].
			method notNil 
				ifTrue: 
					[condition errorMacro: method printString , ' defines variable ' , aString].
			method notNil]
		errorString: aClass printString 
				, ' <1?:does not >define<1?s:> temporary variable ' , aString.
	^condition! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
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: 'utilities' stamp: ''!
checkMethodName: aString
	"Return whether the argument aName is can represent a selector"
	
	^ aString isString and: [ aString isValidSelector ]! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
definesTemporaryVariable: aString in: aClass 
	| condition |
	condition := self new.
	condition 
		type: (Array with: #definesTempVar with: aClass with: aString)
		block: 
			[| method |
			method := self 
						methodDefiningTemporary: aString
						in: aClass
						ignore: [:class :selector | false].
			method notNil 
				ifTrue: 
					[condition errorMacro: method printString , ' defines variable ' , aString].
			method notNil]
		errorString: aClass printString 
				, ' <1?:does not >define<1?s:> temporary variable ' , aString.
	^condition! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
definesSelector: aSelector in: aClass orIsSimilarTo: rbMethod
	^self new
		type: (Array with: #definesSelector with: aClass with: aSelector)
		block: [(aClass directlyDefinesMethod: aSelector)
			ifTrue: [ (aClass parseTreeFor: aSelector) ~= rbMethod parseTree ]
			ifFalse: [ false ]
			]
		errorString: aClass printString , ' <1?:does not >define<1?s:> ' , aSelector printString! !

!RBCondition class methodsFor: '*Refactoring2-Core' stamp: ''!
accessesClassVariable: variableName in: aClass showIn: aTransformation

	^ RBCondition withBlock: [ | block |
		block := 	[ :each | 
			(each whichSelectorsReferToClassVariable: variableName)
				ifNotEmpty: [ aClass realClass
					ifNil: [ RBRefactoring new
						refactoringError: ('<1s> is referenced.' expandMacrosWith: variableName) ]
					ifNotNil: [ RBRefactoring new
						refactoringError: ('<1s> is referenced.<n>Browse references?' expandMacrosWith: variableName)
						with: [ aTransformation openBrowserOn: (RBVariableEnvironment 
									referencesToClassVariable: variableName
									in: aClass realClass) ] ] ] ].
			aClass withAllSubclasses do: block.
			aClass theMetaClass withAllSubclasses do: block.
			true ]! !

!RBCondition class methodsFor: 'utilities' stamp: ''!
checkClassVarName: aName in: aClass 
	| string |
	aName isString ifFalse: [^false].
	string := aName asString.
	(self reservedNames includes: string) ifTrue: [^false].
	string isEmpty ifTrue: [^false].
	string first isUppercase ifFalse: [^false].
	^RBScanner isVariable: string! !

!RBCondition class methodsFor: 'utilities' stamp: ''!
checkMethodName: aString in: aClass 
	"Return whether the argument aName is can represent a selector"
	"You probably look for checkMethodName: since the second argument is ignored"
	
	^aString isString and: [ aString isValidSelector ]! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
directlyDefinesInstanceVariable: aString in: aClass 
	^self new 
		type: (Array with: #directlyDefinesInstanceVariable with: aClass with: aString)
		block: [aClass directlyDefinesInstanceVariable: aString]
		errorString: aClass printString 
				, ' <1?:does not >directly define<1?s:> instance variable ' , aString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
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: '*Refactoring2-Core' stamp: ''!
accessesInstanceVariable: variableName in: aClass showIn: aTransformation

	| references |
	references := RBCondition referencesInstanceVariable: variableName in: aClass.
	aClass realClass 
		ifNil: [ references errorMacro: ('<1s> is referenced.' expandMacrosWith: variableName) ]
		ifNotNil: [ references
			errorMacro: ('<1s> is referenced.<n>Browse references?' expandMacrosWith: variableName);
			errorBlock: [ aTransformation openBrowserOn: 
				(RBBrowserEnvironment new instVarRefsTo: variableName in: aClass realClass)]].
	^ references not! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
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' stamp: ''!
hasSubclasses: aClass
	^self new
		type: (Array with: #hasSubclasses with: aClass)
		block: [aClass subclasses isNotEmpty ]
		errorString: aClass printString , ' has <1?:no >subclasses'! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
referencesInstanceVariable: aString in: aClass

	^ self new
		  type: (Array with: #referencesInstVar with: aClass with: aString)
		  block: [ 
		  (aClass whichSelectorsReferToInstanceVariable: aString) isNotEmpty ]
		  errorString: aClass printString
			  , ' <1?:does not >reference<1?s:> instance variable ' , aString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
isClass: anObject
	^self new
		type: (Array with: #IsClass with: anObject)
		block: [anObject isBehavior]
		errorString: anObject printString , ' is <1?:not >a behavior'! !

!RBCondition class methodsFor: 'utilities' stamp: ''!
checkInstanceVariableName: aName in: aClass 
	| string |
	aName isString ifFalse: [^false].
	string := aName asString.
	string isEmpty ifTrue: [^false].
	(self reservedNames includes: string) ifTrue: [^false].
	string first isUppercase ifTrue: [^false].
	^RBScanner isVariable: string! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
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: 'utilities' stamp: ''!
validClassName: aString 
	"Class names and class variable names have the same restrictions"

	^self checkClassVarName: aString in: self! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
isMetaclass: anObject 
	^self new type: (Array with: #IsMetaclass with: anObject)
		block: [anObject isMeta]
		errorString: anObject printString , ' is <1?:not >a metaclass'! !

!RBCondition class methodsFor: '*Refactoring2-Core' stamp: ''!
doesNotAccessInstanceVariable: variableName inHierarchyOf: aClass showIn: aTransformation

	| references |
	references := RBCondition hierarchyOf: aClass referencesInstanceVariable: variableName.
	aClass realClass 
		ifNil: [ references errorMacro: ('<1s> is referenced.' expandMacrosWith: variableName) ]
		ifNotNil: [ references
			errorMacro: ('<1s> is referenced.<n>Browse references?' expandMacrosWith: variableName);
			errorBlock: [ aTransformation openBrowserOn: 
				(RBBrowserEnvironment new instVarRefsTo: variableName in: aClass realClass)]].
	^ references not! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
isImmediateSubclass: subclass of: superClass
	^self new
		type: (Array with: #immediateSubclass with: superClass with: subclass)
		block: [subclass superclass = superClass]
		errorString: subclass printString , ' is <1?:not >an immediate subclass of ' , superClass printString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
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: 'utilities' stamp: ''!
reservedNames
	^#('self' 'true' 'false' 'nil' 'thisContext' 'super')! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
directlyDefinesClassVariable: aString in: aClass 
	^self new 
		type: (Array with: #directlyDefinesClassVar with: aClass with: aString)
		block: [aClass directlyDefinesClassVariable: aString]
		errorString: aClass printString 
				, ' <1?:does not >directly define<1?s:> class variable ' , aString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
isGlobal: aString in: aRBSmalltalk
	^self new 
		type: (Array with: #isLiteralVariable with: aString)
		block: [aRBSmalltalk includesGlobal: aString asSymbol]
		errorString: aString , ' is <1?:not >a class or global variable'! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
isEmptyClass: anObject 
	^self new type: (Array with: #IsEmptyClass with: anObject)
		block: 
			[anObject classVariableNames isEmpty
				and: [anObject instanceVariableNames isEmpty and: [anObject selectors isEmpty]]]
		errorString: anObject printString , ' is <1?:not > empty'! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
withBlock: aBlock
	^self new withBlock: aBlock! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
hierarchyOf: aClass referencesInstanceVariable: aString

	^ self new
		  type:
		  (Array
			   with: #hierarchyReferencesInstVar
			   with: aClass
			   with: aString)
		  block: [ 
			  (aClass withAllSubclasses
				   detect: [ :each | 
					   (each whichSelectorsReferToInstanceVariable: aString)
						   isNotEmpty ]
				   ifNone: [ nil ]) notNil ]
		  errorString: aClass printString
			  , ' or subclass <1?:does not >reference<1?s:> instance variable '
			  , aString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
isValidClassName: aString
	^self new
		type: (Array with: #validClassName with: aString)
		block: [self validClassName: aString]
		errorString: aString , ' is <1?:not >a valid class name'! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
subclassesOf: aClass referToSelector: aSelector 
	^self new 
		type: (Array 
				with: #subclassReferences
				with: aClass
				with: aSelector)
		block: 
			[(aClass subclasses detect: 
					[:each | 
					(each selectors detect: 
							[:sel | 
							| tree |
							tree := each parseTreeFor: sel.
							tree notNil and: [tree superMessages includes: aSelector]]
						ifNone: [nil]) notNil]
				ifNone: [nil]) notNil]
		errorString: '<1?:no:a> subclass of ' , aClass printString , ' refers to ' 
				, aSelector printString! !

!RBCondition class methodsFor: 'instance creation' stamp: ''!
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' stamp: ''!
withBlock: aBlock errorString: aString 
	^self new type: #unknown
		block: aBlock
		errorString: aString! !

!RBConditionTest methodsFor: 'tests' stamp: ''!
testCheckInvalidMethodName
	"Usually used to validate input."

	self deny: (RBCondition checkMethodName: 'fofo fo').
	self deny: (RBCondition checkMethodName: '123fofo').
	self deny: (RBCondition checkMethodName: 'foo::').
	self deny: (RBCondition checkMethodName: 'agr:goo:aa').
	self deny: (RBCondition checkMethodName: 'foo:123:').
	self deny: (RBCondition checkMethodName: 'foo[arg]').
	self deny: (RBCondition checkMethodName: 'foo:=arg').
	self deny: (RBCondition checkMethodName: 'foo:arg)').
	self deny: (RBCondition checkMethodName: 'foo:(arg)').
	self deny: (RBCondition checkMethodName: 'foo:+arg)').
	self deny: (RBCondition checkMethodName: '<<foo:<<arg)').
	self deny: (RBCondition checkMethodName: 'foo:agr^:').
	self deny: (RBCondition checkMethodName: 'foo:agr')! !

!RBConditionTest methodsFor: 'tests' stamp: ''!
testCheckValidMethodName
	"Usually used to validate input."
	self assert: (RBCondition checkMethodName: 'foo').
	self assert: (RBCondition checkMethodName: #foo).

	self assert: (RBCondition checkMethodName: #+)! !

!RBConjunctiveCondition commentStamp: ''!
I am a refactoring condition combining two other conditions by a boolean AND.

I am created by sending the binary message #& to another condition (left) with another condition (right) as its argument.

Checking this conditions holds true, if my left and my right condition is true. !
!RBConjunctiveCondition methodsFor: 'private' stamp: ''!
errorBlockFor: aBoolean 
	^aBoolean
		ifTrue: [nil]
		ifFalse: 
			[failed = #leftFailed ifTrue: [left errorBlock] ifFalse: [right errorBlock]]! !

!RBConjunctiveCondition methodsFor: 'private' stamp: ''!
errorStringFor: aBoolean 
	^aBoolean
		ifTrue: [self neitherFailed]
		ifFalse: [self perform: failed]! !

!RBConjunctiveCondition methodsFor: 'checking' stamp: ''!
check
	left check
		ifFalse: 
			[failed := #leftFailed.
			^false].
	right check
		ifFalse: 
			[failed := #rightFailed.
			^false].
	^true! !

!RBConjunctiveCondition methodsFor: 'private' stamp: ''!
longMacro
	^'(' , left errorMacro , ') <1?AND:OR> (' , right errorMacro , ')'! !

!RBConjunctiveCondition methodsFor: 'private' stamp: ''!
unknownFailed
	^(left errorStringFor: false) , ' OR ' , (right errorStringFor: false)! !

!RBConjunctiveCondition methodsFor: 'initialization' stamp: ''!
left: aCondition right: aCondition2 
	left := aCondition.
	right := aCondition2.
	failed := #unknownFailed! !

!RBConjunctiveCondition methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream 
		print: left;
		nextPutAll: ' & ';
		print: right
! !

!RBConjunctiveCondition methodsFor: 'private' stamp: ''!
leftFailed
	^left errorStringFor: false! !

!RBConjunctiveCondition methodsFor: 'private' stamp: ''!
errorMacro

	^ errorMacro ifNil: [ self longMacro ] ifNotNil: [ super errorMacro ]! !

!RBConjunctiveCondition methodsFor: 'private' stamp: ''!
rightFailed
	^right errorStringFor: false! !

!RBConjunctiveCondition methodsFor: 'private' stamp: ''!
neitherFailed
	^(left errorStringFor: true) , ' AND ' , (right errorStringFor: true)! !

!RBCopyClassRefactoring commentStamp: ''!
I am a refactoring for copy a class.

My preconditions verify, that the copied class exists (in  the current namespace) and that the new copy class name is valid and not yet used as a global variable name 

The refactoring transformation create a new class and copy all instance and class methods of copied class.

Example
---------------
```
	(RBCopyClassRefactoring 
		copyClass: #RBFooLintRuleTestData 
		withName: #RBFooLintRuleTestData1 in: #Example1) execute. 
```!
!RBCopyClassRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self copyClass.
	self copyVariables.
	self copyMethods.! !

!RBCopyClassRefactoring methodsFor: 'transforming' stamp: ''!
copyVariables
	aClass instanceVariableNames do: [ :varName |
		self performCompositeRefactoring: (RBAddInstanceVariableRefactoring
		model: self model
		variable: varName
		class: className) ].

	aClass classVariableNames do: [ :varName |
		self performCompositeRefactoring: (RBAddClassVariableRefactoring
		model: self model
		variable: varName
		class: className) ]! !

!RBCopyClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions 
	^ (RBCondition isValidClassName: className) 
		& (RBCondition isGlobal: className in: self model) not! !

!RBCopyClassRefactoring methodsFor: 'accessing' stamp: ''!
category: aSymbol
	category := aSymbol ! !

!RBCopyClassRefactoring methodsFor: 'accessing' stamp: ''!
category

	^ category ifNil: [ category := aClass category ]! !

!RBCopyClassRefactoring methodsFor: 'transforming' stamp: ''!
copyClass
	self performCompositeRefactoring: (RBAddClassRefactoring
		model: self model
		addClass: className
		superclass: aClass superclass
		subclasses: #()
		category: self category).! !

!RBCopyClassRefactoring methodsFor: 'transforming' stamp: ''!
copyMethods
	| newClass |
	newClass := (self model classNamed: className).
	self copyMethodsOf: aClass in: newClass.
	self copyMethodsOf: aClass classSide in: newClass classSide! !

!RBCopyClassRefactoring methodsFor: 'copying' stamp: ''!
copyMethodsOf: rbClass1 in: rbClass2
	rbClass1 selectors do: [ :symbol | | rbMethod |
		rbMethod := rbClass1 methodFor: symbol.
		self performCompositeRefactoringThroughWarning:
			(RBAddMethodRefactoring 
				model: self model
				addMethod: rbMethod source 
				toClass: rbClass2
				inProtocols: rbMethod protocols)
	]! !

!RBCopyClassRefactoring methodsFor: 'copying' stamp: ''!
copyClass: cls withName: aName
	self className: aName.
	aClass := self classObjectFor: cls.! !

!RBCopyClassRefactoring class methodsFor: 'copying' stamp: ''!
model: aRBSmalltalk copyClass: cls withName: copyName in: aSymbol
	^ self new
		model: aRBSmalltalk;
		category: aSymbol;
		copyClass: cls withName: copyName! !

!RBCopyClassRefactoring class methodsFor: 'copying' stamp: ''!
copyClass: cls withName: copyName in: aSymbol
	^ self new
		category: aSymbol;
		copyClass: cls withName: copyName! !

!RBCopyClassRefactoring class methodsFor: 'copying' stamp: ''!
copyClass: cls withName: aSymbol
	^ self new copyClass: cls withName: aSymbol! !

!RBCopyClassRefactoring class methodsFor: 'copying' stamp: ''!
model: aRBSmalltalk copyClass: cls withName: aSymbol
	^ self new
		model: aRBSmalltalk;
		copyClass: cls withName: aSymbol! !

!RBCopyPackageParametrizedTest methodsFor: 'tests' stamp: ''!
testCopyPackageAndChangesCopyReferences
	| refactoring aModel |
	self timeLimit: 2 minutes.
	refactoring := (self createRefactoringWithArguments: 
		{ #'Refactoring-Help' . #'Refactoring-Help1'}).
	aModel := refactoring model.
	
	self executeRefactoring: refactoring.
	
	self assert: (aModel classNamed: #RBRefactoringClassesHelpCopy) category 
		equals: #'Refactoring-Help1'.
	self assert: (aModel classNamed: #RBRefactoringClassesHelpCopy) superclass name 
		equals: #RBClassesHelpCopy.
	self assert: (aModel classNamed: #RBRefactoringClassesHelpCopy) superclass name 
		equals: #RBClassesHelpCopy.
	self assert: ((aModel classNamed: #RBCoreClassesHelpCopy) classSide parseTreeFor: #pages) 
		equals: (self parseMethod: 'pages
	^ #(RBASTClassesHelpCopy RBRefactoringClassesHelpCopy RBBrowserEnvironmentsClassesHelpCopy)')! !

!RBCopyPackageParametrizedTest methodsFor: 'tests' stamp: ''!
testCopyPackage
	| refactoring aModel |
	refactoring := (self createRefactoringWithArguments: 
		{ #'Refactoring-Tests-Changes' . #'Refactoring-Tests-Changes1'}).
	aModel := refactoring model.
	
	self executeRefactoring: refactoring.
	
	self assert: (aModel packageNamed: #'Refactoring-Tests-Changes1') isNotNil.
	self assert: (aModel classNamed: #RBRefactoringChangeTestCopy) category equals: #'Refactoring-Tests-Changes1'.
	self assert: (aModel classNamed: #RBRefactoringChangeTestCopy) instanceVariableNames asArray
		equals: #( 'changes' 'workingEnvironment' 'changeFactory').
	self assert: (aModel classNamed: #RBRefactoringChangeManagerTestCopy) category equals: #'Refactoring-Tests-Changes1'.
	! !

!RBCopyPackageParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExistingPackage
	self shouldFail: (self createRefactoringWithArguments: 
		{ #'Refactoring-Tests-Core' . #'Refactoring-Tests-Changes'})! !

!RBCopyPackageParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #copyPackage:in:! !

!RBCopyPackageParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadName
	self shouldFail: (self createRefactoringWithArguments: 
		{#'Refactoring-Tests-Core' . #'Refactoring-Tests-Core'}).! !

!RBCopyPackageParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBCopyPackageRefactoring };
		yourself! !

!RBCopyPackageRefactoring commentStamp: ''!
I am a refactoring for copy a package.

My preconditions verify, that the copied package exists (in  the current environment) and that the new copy package name is valid and not yet used as a global variable name 

The refactoring transformation create a new package and copy defined classes of origin package (exclude all class' extensions)

Example
---------------
```
	(RBCopyPackageRefactoring 
		copyPackage: #'Refactoring-Help' 
		in: #'Refactoring-Help1') execute. 
```!
!RBCopyPackageRefactoring methodsFor: 'preconditions' stamp: ''!
reparent: classes  with: copyClasses
	| subclasses dict |
	dict := Dictionary newFromKeys: classes andValues: copyClasses.
	subclasses := copyClasses 
		collect: [ :cls | self model classNamed: cls] 
		thenSelect: [ :rb | classes includes: rb superclass name ].
	subclasses do: [ :cls |
		self model reparentClasses: { cls } to: (self model classNamed: (dict at: cls superclass name))
	]
	! !

!RBCopyPackageRefactoring methodsFor: 'preconditions' stamp: ''!
transform 
	| classes copyClasses |
	self model addPackageNamed: newName.
	classes := (package realPackage definedClasses collect: #name) asArray.
	copyClasses := self copyAllClasses: classes.
	self changeReferencesOf: classes with: copyClasses.
	self reparent: classes  with: copyClasses.! !

!RBCopyPackageRefactoring methodsFor: 'copying' stamp: ''!
copyPackage: aString1 in: aString2
	packageName := aString1 asSymbol.
	package := self model packageNamed: packageName.
	newName := aString2 asSymbol.! !

!RBCopyPackageRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions 
	^ super preconditions & (RBCondition withBlock: [ newName = packageName ifTrue: 
		[ self refactoringError: 'Use a different name' ].
		true ]) &
	(RBCondition withBlock: [ [RPackage organizer validatePackageDoesNotExist: newName. true]
			on: Error 
			do: [ :e | self refactoringError: e messageText ]
		])! !

!RBCopyPackageRefactoring methodsFor: 'renaming' stamp: ''!
renameReferencesOf: aClass1 with: aClass2
	| replacer |
	replacer := (self parseTreeRewriterClass replaceLiteral: aClass1 name with: aClass2)
				replace: aClass1 name with: aClass2;
				replaceArgument: aClass2
					withValueFrom: 
						[:aNode | 
						self 
							refactoringFailure: aClass2 , ' already exists within the reference scope'];
				yourself.
	self model allReferencesToClass: aClass1 inPackages: { newName }
		do: 
			[:method | 
			(method modelClass hierarchyDefinesVariable: aClass2) 
				ifTrue: 
					[self refactoringFailure: aClass2 , ' is already defined in hierarchy of ' 
								, method modelClass printString].
			self 
				convertMethod: method selector
				for: method modelClass
				using: replacer]! !

!RBCopyPackageRefactoring methodsFor: 'preconditions' stamp: ''!
copyNameFor: symbol
	| string counter copyName |
	string := 'Copy'.
	counter := 1.
	copyName := symbol, string.
	[ self model includesGlobal: copyName ] 
		whileTrue: [ copyName := symbol, string, counter asString.
			counter := counter + 1 ].
	^ copyName! !

!RBCopyPackageRefactoring methodsFor: 'preconditions' stamp: ''!
copyAllClasses: classes
	^ classes collect: [ :symbol | | copyClassName |
		copyClassName := self copyNameFor: symbol.
		self performCompositeRefactoring: 
			(RBCopyClassRefactoring
				model: self model
				copyClass: symbol 
				withName: copyClassName
				in: newName).
		copyClassName
	]! !

!RBCopyPackageRefactoring methodsFor: 'preconditions' stamp: ''!
changeReferencesOf: classes with: copyClasses
	classes with: copyClasses do: [ :cls :cp | | rbClass |
		rbClass := self model classNamed: cls.
		self renameReferencesOf: rbClass with: cp.
	]! !

!RBCopyPackageRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' copyPackage: '.
	aStream nextPutAll: package name.
	aStream
		nextPutAll: ' in: #';
		nextPutAll: newName;
		nextPut: $)! !

!RBCopyPackageRefactoring class methodsFor: 'copying' stamp: ''!
copyPackage: aString1 in: aString2
	^ self new
		copyPackage: aString1 in: aString2;
		yourself! !

!RBCopyPackageRefactoring class methodsFor: 'copying' stamp: ''!
model: aRBSmalltalk copyPackage: aString1 in: aString2
	^ self new 
		model: aRBSmalltalk;
		copyPackage: aString1 in: aString2;
		yourself! !

!RBCoreClassesHelp commentStamp: ''!
A book chapter describing  important core classes from the class comments.!
!RBCoreClassesHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(RBASTClassesHelp RBRefactoringClassesHelp RBBrowserEnvironmentsClassesHelp)! !

!RBCoreClassesHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Core classes'! !

!RBCreateAccessorsForVariableRefactoring commentStamp: ''!
I am a refactoring for creating accessors for variables.

I am used by a couple of other refactorings  creating new variables and accessors.

My precondition is that the variable name is defined for this class.!
!RBCreateAccessorsForVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
findGetterMethod
	| definingClass matcher |
	definingClass := self definingClass.
	matcher := self createMatcher.
	^ self possibleGetterSelectors
		detect: [ :each |
			(self checkClass: definingClass selector: each using: matcher) notNil
				and: [ (definingClass subclassRedefines: each) not ] ]
		ifNone: [ nil ]! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self
		createGetterAccessor;
		createSetterAccessor! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: ''!
createMatcher 
	^ self parseTreeSearcherClass getterMethod: variableName! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: ''!
defineSetterMethod
	| definingClass string |
	definingClass := self definingClass.
	string := self needsReturnForSetter 
				ifTrue: ['<1s> anObject<r><r><t>^ <2s> := anObject']
				ifFalse: ['<1s> anObject<r><r><t><2s> := anObject'].
	selector := self safeMethodNameFor: definingClass
				basedOn: variableName asString , ':'.
	definingClass 
		compile: (string expandMacrosWith: selector with: variableName)
		classified: #accessing.
	^selector! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
definingClass
	^ classVariable 
		ifTrue: [ class classSide ]
		ifFalse: [ class ]! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^classVariable 
		ifTrue: [RBCondition definesClassVariable: variableName asSymbol in: class]
		ifFalse: [RBCondition definesInstanceVariable: variableName in: class]! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
findSetterMethod
	| definingClass matcher |
	definingClass := self definingClass.
	matcher := self needsReturnForSetter
		ifTrue: [ self parseTreeSearcherClass returnSetterMethod: variableName ]
		ifFalse: [ self parseTreeSearcherClass setterMethod: variableName ].
	^ self possibleSetterSelectors
		detect: [ :each | 
			(self checkClass: definingClass selector: each using: matcher) notNil
				and: [ (definingClass subclassRedefines: each) not ] ]
		ifNone: [ nil ]! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'testing' stamp: ''!
needsReturnForSetter
	needsReturn
		ifNil:
			[ needsReturn := self usesAssignmentOf: variableName in: class classVariable: classVariable ].
	^ needsReturn! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: ''!
selector 
	^ selector ifNil: [ 
		selector := self safeMethodNameFor: self definingClass
				basedOn: variableName asString. ]! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: ''!
defineGetterMethod
	self definingClass 
		compile: ('<1s><r><r><t>^ <2s>' expandMacrosWith: self selector with: variableName)
		classified: #(#accessing).
	^selector! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: ''!
createSetterAccessor

	setterMethod := self findSetterMethod.
	setterMethod ifNil: [ setterMethod := self defineSetterMethod ]! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'initialization' stamp: ''!
classVariable: aBoolean 
	classVariable := aBoolean! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: ''!
createGetterAccessor

	getterMethod := self findGetterMethod.
	getterMethod ifNil: [ getterMethod := self defineGetterMethod ]! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
methodsReferencingVariable
	^classVariable 
		ifTrue: [self definingClass whichSelectorsReferToClassVariable: variableName]
		ifFalse: 
			[self definingClass whichSelectorsReferToInstanceVariable: variableName]! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'testing' stamp: ''!
usesAssignmentOf: aString in: aClass classVariable: isClassVar
	| matcher definingClass |
	matcher := self parseTreeSearcher.
	matcher
		answer: false;
		matches: aString , ' := ``@object'
			do: [ :aNode :answer | 
			answer
				or: [ aNode isUsed and: [ aNode methodNode selector ~= aString ] ] ].
	definingClass := isClassVar
		ifTrue: [ aClass instanceSide ]
		ifFalse: [ aClass ].
	^ (definingClass withAllSubclasses
		,
			(isClassVar
				ifTrue: [ definingClass classSide withAllSubclasses ]
				ifFalse: [ #() ])
		anySatisfy: [ :each | 
			((isClassVar
				ifTrue: [ each whichSelectorsReferToClassVariable: aString ]
				ifFalse: [ each whichSelectorsReferToInstanceVariable: aString ])
				anySatisfy:
					[ :sel | self checkClass: each selector: sel using: matcher ]) ])! !

!RBCreateAccessorsForVariableRefactoring methodsFor: '*NautilusRefactoring' stamp: ''!
whatToDisplayIn: aBrowser 

	^ (self changes changes 
		select: [:change | {getterMethod. setterMethod} includes: change selector ]) 
		flatCollect: [:change | change whatToDisplayIn: aBrowser ]! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
setterMethod
	^setterMethod! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
getterMethod
	^getterMethod! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' variable: '.
	variableName storeOn: aStream.
	aStream nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream nextPutAll: ' classVariable: '.
	classVariable storeOn: aStream.
	aStream nextPut: $)! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
possibleGetterSelectors
	^self methodsReferencingVariable select: [:each | each numArgs == 0]! !

!RBCreateAccessorsForVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
possibleSetterSelectors
	^self methodsReferencingVariable select: [:each | each numArgs == 1]! !

!RBCreateAccessorsForVariableRefactoring class methodsFor: '*SystemCommands-VariableCommands' stamp: ''!
classVariableAnalog
	^ self! !

!RBCreateAccessorsForVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk classVariable: aVarName class: aClass 

	^ self model: aRBSmalltalk variable: aVarName class: aClass classVariable: true! !

!RBCreateAccessorsForVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
instanceVariable: aVarName class: aClass
	^ self variable: aVarName class: aClass classVariable: false! !

!RBCreateAccessorsForVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk variable: aVarName class: aClass classVariable: aBoolean 
	^(self 
		model: aRBSmalltalk
		variable: aVarName
		class: aClass)
		classVariable: aBoolean;
		yourself! !

!RBCreateAccessorsForVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
variable: aVarName class: aClass classVariable: aBoolean 
	^(self variable: aVarName class: aClass)
		classVariable: aBoolean; yourself! !

!RBCreateAccessorsForVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
classVariable: aVarName class: aClass
	^ self variable: aVarName class: aClass classVariable: true! !

!RBCreateAccessorsForVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk instanceVariable: aVarName class: aClass

	^ self model: aRBSmalltalk variable: aVarName class: aClass classVariable: false! !

!RBCreateAccessorsWithLazyInitializationForVariableRefactoring commentStamp: ''!
I am a refactoring for creating accessors with lazy initialization for variables.

I am used by a couple of other refactorings creating new variables and accessors.

My precondition is that the variable name is defined for this class.

Example
--------
Script
```
(RBCreateAccessorsWithLazyInitializationForVariableRefactoring 
	variable: 'foo1' 
	class: RBLintRuleTestData 
	classVariable: false 
	defaultValue: '123') execute
```

After refactoring we get:
```
RBLintRuleTestData >> foo1 
	^ foo1 ifNil: [foo1 := 123]
	
RBLintRuleTestData >> foo1: anObject
	foo1 := anObject
```!
!RBCreateAccessorsWithLazyInitializationForVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^ super preconditions & 
	(RBCondition withBlock: [ 
		self verifyInitializationExpressionOf: self defaultValue.
		true ])! !

!RBCreateAccessorsWithLazyInitializationForVariableRefactoring methodsFor: 'accessing' stamp: ''!
defaultValue
	^ defaultValue ifNil: [ defaultValue := 'nil' ]! !

!RBCreateAccessorsWithLazyInitializationForVariableRefactoring methodsFor: 'transforming' stamp: ''!
defineGetterMethod
	
	self definingClass 
		compile: ('<1s><r><r><t>^ <2s> ifNil: [ <2s> := <3s> ]' 
			expandMacrosWith: self selector 
			with: variableName
			with: self defaultValue)
		classified: #(#accessing).
	^selector! !

!RBCreateAccessorsWithLazyInitializationForVariableRefactoring methodsFor: 'preconditions' stamp: ''!
checkVariableReferencesIn: aParseTree

	| searcher |

	searcher := self parseTreeSearcher.
	searcher
		matches: '`var'
		do: [ :aNode :answer | 
			| name |

			name := aNode name.
			( aNode whoDefines: name ) ifNil: [ self canReferenceVariable: name in: class  ]
			].
	searcher executeTree: aParseTree! !

!RBCreateAccessorsWithLazyInitializationForVariableRefactoring methodsFor: 'private' stamp: ''!
createGetterAccessor

	getterMethod := self findGetterMethod.
	getterMethod ifNil: [ getterMethod := self defineGetterMethod ]
		ifNotNil: [ |matcher|
			matcher := self parseTreeSearcherClass new
			matchesMethod: '`method ^' , variableName 
			do: [:aNode :ans | aNode selector].
			(self checkClass: self definingClass selector: getterMethod using: matcher)
				ifNotNil: [ selector := getterMethod ].
			getterMethod := self defineGetterMethod ]! !

!RBCreateAccessorsWithLazyInitializationForVariableRefactoring methodsFor: 'preconditions' stamp: ''!
verifyInitializationExpressionOf: initializer
	| tree |
	tree := self parserClass
		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.! !

!RBCreateAccessorsWithLazyInitializationForVariableRefactoring methodsFor: 'accessing' stamp: ''!
defaultValue: aString
	defaultValue := aString! !

!RBCreateAccessorsWithLazyInitializationForVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
variable: aVarName class: aClass classVariable: aBoolean defaultValue: aString

	^(self variable: aVarName class: aClass)
		classVariable: aBoolean;
		defaultValue: aString;
		yourself! !

!RBCreateAccessorsWithLazyInitializationForVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk variable: aVarName class: aClass classVariable: aBoolean defaultValue: aString
	^(self 
		model: aRBSmalltalk
		variable: aVarName
		class: aClass)
		classVariable: aBoolean;
		defaultValue: aString;
		yourself! !

!RBCreateCascadeRefactoring commentStamp: ''!
I am  a refactoring used to generate cascades in source code.

Two or more message sends to the same object are replaced by a cascaded message send. It expects a selection of the messages and the receiver variable.
!
!RBCreateCascadeRefactoring methodsFor: 'transforming' stamp: ''!
compileCode
	class compileTree: (self parseTreeRewriterClass
		replaceStatements: sequenceNode formattedCode
		with: transformedNode formattedCode
		in: self parseTree
		onInterval: selectedInterval)! !

!RBCreateCascadeRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self combineMessages.
	self compileCode! !

!RBCreateCascadeRefactoring methodsFor: 'preconditions' stamp: ''!
addStatementNode: aNode
	aNode isMessage
		ifTrue: [ ^ statementNodes add: aNode ].
	aNode isCascade
		ifTrue: [ ^ statementNodes addAll: aNode messages ].
	self refactoringFailure: aNode formattedCode , ' is not a valid message'! !

!RBCreateCascadeRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [ 
		self findSequenceNode; findStatementNodes; findReceiverNode.
		true ])! !

!RBCreateCascadeRefactoring methodsFor: 'preconditions' stamp: ''!
findSequenceNode
	"Find the sequence to be combined."

	sequenceNode := self parserClass
		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: 'initialization' stamp: ''!
combine: anInterval from: aSelector in: aClass
	class := self classObjectFor: aClass.
	selector := aSelector.
	selectedInterval := anInterval! !

!RBCreateCascadeRefactoring methodsFor: 'preconditions' stamp: ''!
findStatementNodes
	"Find the sequence to be combined."

	statementNodes := OrderedCollection new.
	sequenceNode statements do: [ :each |
		(sequenceNode isLast: each)
			ifFalse: [ self addStatementNode: each ]
			ifTrue: [
				| current |
				current := each.
				[ current isReturn or: [ current isAssignment ] ]
					whileTrue: [ current := current value ].
				self addStatementNode: current ] ]! !

!RBCreateCascadeRefactoring methodsFor: 'preconditions' stamp: ''!
findReceiverNode
	"Find the sequence to be combined."

	| receiverNodes |
	receiverNodes := statementNodes 
		collect: [ :each | each receiver ].
	receiverNodes asSet size = 1
		ifFalse: [ self refactoringError: 'All statements must have the same receiver' ].
	(receiverNodes first isLiteralNode or: [ receiverNodes first isVariable ])
		ifFalse: [ self refactoringWarning: 'The receiver is an expression. Proceed with caution' ]! !

!RBCreateCascadeRefactoring methodsFor: 'accessing' stamp: ''!
selectedSource
	^  self parseTree source copyFrom: selectedInterval first to: selectedInterval last! !

!RBCreateCascadeRefactoring methodsFor: 'transforming' stamp: ''!
combineMessages
	"This combines the messages and adds the assignements of the last statement to the cascade. This is not necessary if there is a return, because the refactoring engine automatically compensates for that."

	| expression |
	transformedNode := RBCascadeNode messages: (statementNodes
		collect: [ :each | each copy ]).
	expression := statementNodes last parent.
	[ expression isAssignment ] whileTrue: [
		transformedNode := RBAssignmentNode
			variable: expression variable
			value: transformedNode.
		expression := expression parent ]! !

!RBCreateCascadeRefactoring methodsFor: 'accessing' stamp: ''!
parseTree

	parseTree
		ifNil: [ parseTree := class parseTreeFor: selector.
			parseTree ifNil: [ self refactoringFailure: 'Could not parse sources' ]
			].
	^ parseTree! !

!RBCreateCascadeRefactoring class methodsFor: 'instance creation' stamp: ''!
combine: anInterval from: aSelector in: aClass
	^ self new 
		combine: anInterval from: aSelector in: aClass;
		yourself! !

!RBCreateCascadeRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aNamespace combine: anInterval from: aSelector in: aClass
	^ self new 
		model: aNamespace; 
		combine: anInterval from: aSelector in: aClass;
		yourself! !

!RBCustomTransformation commentStamp: ''!
Performs a custom transformation. With this class, the developer can manipulate the model (a RBNamespace) directly, i.e., adding classes, transforming them etc.

Usage: 
transformation := (RBCustomTransformation with: [ :model |
	model defineClass: ('Object subclass: #Bla
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ',  'Refactoring2-Transformations' surroundedBySingleQuotes ).
	(model classNamed: #Bla)
		comment: 'Deprecated!!!!!! Use super class' ])
	transform.
(ChangesBrowser changes: transformation model changes changes) open!
!RBCustomTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	"no precondition so far"
	
	^ self emptyCondition! !

!RBCustomTransformation methodsFor: 'api' stamp: ''!
transformationBlock: aBlockWithOneArg

	transformationBlock := aBlockWithOneArg! !

!RBCustomTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' with: '.
	transformationBlock storeOn: aStream.
	aStream nextPut: $)! !

!RBCustomTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	transformationBlock value: self model! !

!RBCustomTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel with: aBlockWithOneArg

	^ self new
		model: aRBModel;
		transformationBlock: aBlockWithOneArg;
		yourself! !

!RBCustomTransformation class methodsFor: 'api' stamp: ''!
with: aBlockWithOneArg

	^ self new
		transformationBlock: aBlockWithOneArg;
		yourself! !

!RBDataTest methodsFor: 'tests' stamp: ''!
testExample1
	| aString aNumber |
	aString := 'Some string'.
	self someMethod.
	aNumber := 4.
	self assert: aString isNotEmpty.
	self deny: (aString, aNumber asString) isEmpty.
	self assert: true! !

!RBDataTest methodsFor: 'tests' stamp: ''!
testExample2
	| aString aNumber |
	aString := 'sa'.
	self someMethod.
	aNumber := 4.
	self assert: aString isNotEmpty.! !

!RBDataTest methodsFor: 'tests' stamp: ''!
someMethod
	#'some.initializations'! !

!RBDataTest methodsFor: 'tests' stamp: ''!
testExample
	self someMethod.
	self assert: true! !

!RBDeprecateClassParametrizedTest methodsFor: 'tests' stamp: ''!
testModelRenameClass
	| refactoring replacement deprecated user |

	model defineClass: 'Object subclass: #ClassDeprecatorTestingClassReplacement 
		instanceVariableNames: '''' 
		classVariableNames: '''' 
		poolDictionaries: '''' 
		category: #''Refactory-Test data'''.

	model defineClass: 'ClassDeprecatorTestingClassReplacement subclass: #ClassDeprecatorTestingClassDeprecated 
		instanceVariableNames: '''' 
		classVariableNames: '''' 
		poolDictionaries: '''' 
		category: #''Refactory-Test data'''.
	
	model defineClass: 'ClassDeprecatorTestingClassDeprecated subclass: #ClassDeprecatorTestingClassDeprecatedUser 
		instanceVariableNames: '''' 
		classVariableNames: '''' 
		poolDictionaries: '''' 
		category: #''Refactory-Test data'''.

	replacement := model classNamed: #ClassDeprecatorTestingClassReplacement.
	deprecated := model classNamed: #ClassDeprecatorTestingClassDeprecated.
	user := model classNamed: #ClassDeprecatorTestingClassDeprecatedUser.

	user
		compile: 'foo	^ClassDeprecatorTestingClassDeprecated' classified: #(#accessing);
		compile: 'objectName ^#(ClassDeprecatorTestingClassDeprecated)' classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model
		andArguments: { deprecated . #ClassDeprecatorTestingClassReplacement }.
	
	"because of RB limitations we cannot detect extensions in the test properly so we skip this operation"
	refactoring shouldCopyExtensions: false.	
	refactoring shouldRemoveExtensions: false.	
		
	self executeRefactoring: refactoring.
	self assert: (model includesClassNamed: #ClassDeprecatorTestingClassReplacement).
	self assert: (model includesClassNamed: #ClassDeprecatorTestingClassDeprecated).
	self assert: (model includesClassNamed: #ClassDeprecatorTestingClassDeprecatedUser).

	self assert: (model classNamed: #ClassDeprecatorTestingClassReplacement) equals: replacement.
	self assert: (model classNamed: #ClassDeprecatorTestingClassDeprecated) equals: deprecated.
	self assert: (model classNamed: #ClassDeprecatorTestingClassDeprecatedUser) equals: user.

	self assert: (user parseTreeFor: #foo)
		equals: (self parseMethod: 'foo ^ClassDeprecatorTestingClassReplacement').
		
	self assert: (user parseTreeFor: #objectName) 
		equals: (self parseMethod: 'objectName ^#(ClassDeprecatorTestingClassReplacement)').

	self assert: user superclass name 
		equals: #ClassDeprecatorTestingClassReplacement! !

!RBDeprecateClassParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #deprecate:in:! !

!RBDeprecateClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadName
	self shouldFail: (self createRefactoringWithArguments: 
		{ RBLintRuleTestData . self objectClassVariable }).
	self shouldFail: (self createRefactoringWithArguments: 
		{ RBLintRuleTestData . #'Ob ject' })! !

!RBDeprecateClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMetaClassFailure
	self shouldFail: (self createRefactoringWithArguments: 
		{ self class class . #Foo })! !

!RBDeprecateClassParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBDeprecateClassRefactoring };
		yourself! !

!RBDeprecateClassRefactoring commentStamp: ''!
I am a refactoring operation for removing of usages of a deprecated class, that was renamed to another name.

 I'm doing following operations:
 - all subclasses of the deprecated class will use the new class as superclass (optional)
 - convert new class to superclass of deprecatedclass, remove methods of deprecated class and add class method #isDeprecated (optional)
 - rename all references in the code
 - move extensions of the deprecated class owned by other packages to the new class (optional)
 - remove the extensions (optional)
!
!RBDeprecateClassRefactoring methodsFor: 'transforming' stamp: ''!
convertDeprecatedToSubclass
	| replacement |
	replacement := self model classNamed: newName.
	self model reparentClasses: {deprecatedClass} to: replacement.
	deprecatedClass selectors do: [ :symbol | 
		(deprecatedClass realClass instanceSide compiledMethodAt: symbol) isExtension 
			ifFalse: [ deprecatedClass removeMethod: symbol ] ].
	deprecatedClass classSide selectors do: [ :symbol | 
		(deprecatedClass realClass classSide compiledMethodAt: symbol) isExtension
			ifFalse: [ deprecatedClass classSide removeMethod: symbol ] ].
	deprecatedClass classSide compile: 'isDeprecated
		" Uses ', newName, ' instead of ', className,'"
		^ true' classified: {'testing'}! !

!RBDeprecateClassRefactoring methodsFor: 'accessing' stamp: ''!
shouldFixSubclasses: anObject
	shouldFixSubclasses := anObject! !

!RBDeprecateClassRefactoring methodsFor: 'transforming' stamp: ''!
transform
	
	self shouldFixSubclasses 
		ifTrue: [ self renameSuperclassOfSubclasses.
			self convertDeprecatedToSubclass ].

	self renameReferences.

	self shouldCopyExtensions 
		ifTrue: [ self copyExtensionMethods ].
		
	self shouldRemoveExtensions 
		ifTrue: [ self removeExtensionMethods ].
! !

!RBDeprecateClassRefactoring methodsFor: 'accessing' stamp: ''!
deprecatedClass
	^ deprecatedClass! !

!RBDeprecateClassRefactoring methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	shouldFixSubclasses := true.
	shouldCopyExtensions := true.
	shouldRemoveExtensions := true.! !

!RBDeprecateClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^((RBCondition withBlock: [deprecatedClass notNil and: [deprecatedClass isMeta not]]) 
			& (RBCondition isValidClassName: newName) 
			& (RBCondition isGlobal: newName in: self model)) |
			(RBCondition withBlock: [ self refactoringFailure: newName , ' is not a valid class name'])! !

!RBDeprecateClassRefactoring methodsFor: 'accessing' stamp: ''!
shouldRemoveExtensions: anObject
	shouldRemoveExtensions := anObject! !

!RBDeprecateClassRefactoring methodsFor: 'transforming' stamp: ''!
renameSuperclassOfSubclasses
	
	| replacement |
	replacement := self model classNamed: newName.  	
	self model reparentClasses: deprecatedClass subclasses to: replacement! !

!RBDeprecateClassRefactoring methodsFor: 'accessing' stamp: ''!
shouldFixSubclasses
	^ shouldFixSubclasses! !

!RBDeprecateClassRefactoring methodsFor: 'transforming' stamp: ''!
removeExtensionMethods

	(self instanceSideExtensionMethodsOf: deprecatedClass)
		do: [ :each | deprecatedClass instanceSide removeMethod: each selector ].
		
	(self classSideExtensionMethodsOf: deprecatedClass)
		do: [ :each | deprecatedClass classSide removeMethod: each selector ].
! !

!RBDeprecateClassRefactoring methodsFor: 'transforming' stamp: ''!
newClass

	^ self model classNamed: newName.  	! !

!RBDeprecateClassRefactoring methodsFor: 'accessing' stamp: ''!
shouldCopyExtensions: anObject
	shouldCopyExtensions := anObject! !

!RBDeprecateClassRefactoring methodsFor: 'accessing' stamp: ''!
shouldRemoveExtensions
	^ shouldRemoveExtensions! !

!RBDeprecateClassRefactoring methodsFor: 'transforming' stamp: ''!
instanceSideExtensionMethodsOf: anRBClass

	^ anRBClass realClass instanceSide localMethods 
		select: #isExtension 
		thenCollect: [ :each | anRBClass instanceSide methodFor: each selector ] ! !

!RBDeprecateClassRefactoring methodsFor: 'transforming' stamp: ''!
renameReferences
	| replacer |
	replacer := (self parseTreeRewriterClass 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: deprecatedClass 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 ]! !

!RBDeprecateClassRefactoring methodsFor: 'accessing' stamp: ''!
shouldCopyExtensions
	^ shouldCopyExtensions! !

!RBDeprecateClassRefactoring methodsFor: 'transforming' stamp: ''!
copyExtensionMethods

	(self instanceSideExtensionMethodsOf: deprecatedClass)
		do: [ :each | self newClass instanceSide compile: each source classified: each protocols ].
		
	(self classSideExtensionMethodsOf: deprecatedClass)
		do: [ :each | self newClass classSide compile: each source classified: each protocols ]! !

!RBDeprecateClassRefactoring methodsFor: 'transforming' stamp: ''!
classSideExtensionMethodsOf: anRBClass

	^ anRBClass realClass classSide localMethods 
		select: #isExtension 
		thenCollect: [ :each | anRBClass classSide methodFor: each selector ] ! !

!RBDeprecateClassRefactoring methodsFor: 'accessing' stamp: ''!
deprecatedClass: anObject
	deprecatedClass := anObject! !

!RBDeprecateClassRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' rename: '.
	deprecatedClass storeOn: aStream.
	aStream
		nextPutAll: ' to: #';
		nextPutAll: newName;
		nextPut: $)! !

!RBDeprecateClassRefactoring methodsFor: 'initialization' stamp: ''!
className: aName newName: aNewName 
	className := aName asSymbol.
	deprecatedClass := self model classNamed: className.
	newName := aNewName asSymbol! !

!RBDeprecateClassRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk deprecate: aClass in: aNewName 
	^ self new
		model: aRBSmalltalk;
		className: aClass name newName: aNewName;
		yourself! !

!RBDeprecateClassRefactoring class methodsFor: 'instance creation' stamp: ''!
deprecate: aDeprecatedClass in: aNewName
	^ self new className: aDeprecatedClass name newName: aNewName! !

!RBDeprecateClassTransformation commentStamp: ''!
Marks a class as deprecated and suggests the use of the superclass.

Usage:
transformation := (RBDeprecateClassTransformation 
		class: #RBRemoveClassTransformation)
		transform. 
(ChangesBrowser changes: transformation model changes changes) open!
!RBDeprecateClassTransformation methodsFor: 'api' stamp: ''!
class: aClassName

	className := aClassName! !

!RBDeprecateClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' class: '.
	className storeOn: aStream.
	aStream nextPut: $)! !

!RBDeprecateClassTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	^ transformations ifNil: [ 
		transformations := OrderedCollection
			with: (RBAddMethodTransformation
					sourceCode: (String streamContents: [ :code | code
						nextPutAll: 'new';
						nextPutAll: String cr;
						nextPutAll: String tab;
						nextPutAll: 'self deprecated: ''Use superclass '' on: ''4 May 2016'' in: #Pharo60.';
						nextPutAll: String cr;
						nextPutAll: String tab;
						nextPutAll: '^ super new' ])
					in: (className, ' class') asSymbol
					withProtocols: {#deprecation})
			with: (RBAddMethodTransformation
					sourceCode: (String streamContents: [ :code | code 
						nextPutAll: 'deprecated';
						nextPutAll: String cr;
						nextPutAll: String tab;
						nextPutAll: '^ true' ])
					in: (className, ' class') asSymbol
					withProtocols: {#deprecation})
			with: (RBAddMethodTransformation
					sourceCode: (String streamContents: [ :code | code
						nextPutAll: 'systemIcon';
						nextPutAll: String cr;
						nextPutAll: String tab;
						nextPutAll: '^ Smalltalk ui icons iconNamed: #packageDelete' ])
					in: (className, ' class') asSymbol
					withProtocols: {#deprecation})
			with: (RBAddClassCommentTransformation
					 comment: 'Deprecated!!!!!! Use superclass'
					 in: className) ]! !

!RBDeprecateClassTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel class: aClassName

	^ self new
		model: aRBModel;
		class: aClassName;
		yourself! !

!RBDeprecateClassTransformation class methodsFor: 'api' stamp: ''!
class: aClassName

	^ self new
		class: aClassName;
		yourself! !

!RBDeprecateMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testDeprecateMethodUsingMethodWithSameNumberOfArgs

	| refactoring class oldSelector newSelector |
	
	oldSelector := #callMethod.
	newSelector := #callFoo.
	refactoring := self createRefactoringWithModel: model andArguments:  
		{ oldSelector . RBRefactoryTestDataApp . newSelector }.
	
	self executeRefactoring: refactoring .
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self
		assert: ((class parseTreeFor: oldSelector ) statements anySatisfy: 
			[ :e | e isMessage ifTrue: [ e selector = #deprecated:on:in: ] ]).! !

!RBDeprecateMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInvalidNumArgsOfSelector

	| refactoring oldSelector newSelector |
	oldSelector := ('called:', 'on1:') asSymbol.
	newSelector := 'inlineFoo:' asSymbol.
	refactoring := self createRefactoringWithModel: model andArguments: 
		{ oldSelector . RBRefactoryTestDataApp . newSelector }.
	
	self shouldFail: refactoring! !

!RBDeprecateMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #deprecateMethod:in:using:! !

!RBDeprecateMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInvalidNewSelector

	| refactoring oldSelector newSelector |
	oldSelector := ('called:', 'on1:') asSymbol.
	newSelector := 'inlineFoo1:' asSymbol.
	refactoring := self createRefactoringWithModel: model andArguments:  
		{ oldSelector . RBRefactoryTestDataApp . newSelector }.
	
	self shouldFail: refactoring! !

!RBDeprecateMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testDeprecateMethodUsingMethodWithoutArgs

	| refactoring class oldSelector newSelector |
	
	oldSelector := ('called:', 'on:') asSymbol.
	newSelector := 'callFoo' asSymbol.
	refactoring := self createRefactoringWithModel: model andArguments: 
		{ oldSelector . RBRefactoryTestDataApp . newSelector }.
	
	self executeRefactoring: refactoring .
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self
		assert: ((class parseTreeFor: oldSelector ) statements anySatisfy: 
			[ :e | e isMessage and: [ e selector = #deprecated:on:in: ] ]).
	! !

!RBDeprecateMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBDeprecateMethodRefactoring };
		addCase: { #rbClass -> RBDeprecateMethodTransformation };
		yourself! !

!RBDeprecateMethodRefactoring commentStamp: ''!
I am a refactoring for deprecate a method.

My preconditions verify, that the old selector exists (in  the current namespace) and that the new selector is a valid selector

The refactoring transformation will add the call to the #deprecated:on:in: method 

Example
---------------

Script:
```
	(RBDeprecateMethodRefactoring 
		deprecateMethod: #called:on: 
		in: RBRefactoryTestDataApp 
		using: #callFoo) execute
```

Before refactoring:
```
RBRefactoryTestDataApp >> called: anObject on: aBlock 
	Transcript
		show: anObject printString;
		cr.
	aBlock value
```

After refactoring:
```
RBRefactoryTestDataApp >> called: anObject on: aBlock 
	self
		deprecated: 'Use #callFoo instead'
		on: '16 April 2021'
		in: 'Pharo-9.0.0+build.1327.sha.a1d951343f221372d949a21fc1e86d5fc2d2be81 (64 Bit)'.
	Transcript
		show: anObject printString;
		cr.
	aBlock value
```!
!RBDeprecateMethodRefactoring methodsFor: 'transforming' stamp: ''!
callDeprecationMethod

	^ 'self 
		deprecated: ''Use ' , newSelector storeString , ' instead''
		on: 	''' , Date today asString , ''' 
		in: ''' , SystemVersion current imageVersionString , ''''! !

!RBDeprecateMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform

	| node parseTree method |
	method := class methodFor: oldSelector.
	parseTree := method parseTree.
	node := self parserClass parseExpression: self callDeprecationMethod.
	parseTree body addNodeFirst: node.
	class compile: parseTree newSource classified: method protocols! !

!RBDeprecateMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ (RBCondition definesSelector: oldSelector in: class) 
		& (RBCondition canUnderstand: newSelector in: class)
		& (RBCondition 
							withBlock: [oldSelector numArgs = newSelector numArgs or: [ newSelector numArgs = 0 ]]
							errorString: 'The new selectors should have the same number of arguments as the old one, or not have them at all').! !

!RBDeprecateMethodRefactoring methodsFor: 'preconditions' stamp: ''!
deprecateMethod: aSelector in: aClass using: newSel
	oldSelector := aSelector asSymbol.
	newSelector := newSel asSymbol.
	class := self classObjectFor: aClass.! !

!RBDeprecateMethodRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' deprecateMethod: #';
		nextPutAll: oldSelector;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' using: #';
		nextPutAll: newSelector.
	aStream nextPut: $)! !

!RBDeprecateMethodRefactoring class methodsFor: 'intance creation' stamp: ''!
deprecateMethod: aSelector in: aClass using: newSelector
	^ self new 
		deprecateMethod: aSelector
			in: aClass
			using: newSelector;
		yourself! !

!RBDeprecateMethodRefactoring class methodsFor: 'intance creation' stamp: ''!
model: aRBSmalltalk deprecateMethod: aSelector in: aClass using: newSelector
	^ self new
		model: aRBSmalltalk;
		deprecateMethod: aSelector
			in: aClass
			using: newSelector;
		yourself! !

!RBDeprecateMethodTransformation commentStamp: ''!
I am a transformation for deprecate a method.

My preconditions verify, that the old selector exists (in  the current namespace) and that the new selector is a valid selector

The transformation will add the call to the #deprecated:on:in: method.

Example
---------------

Script:
```
	(RBDeprecateMethodTransformation 
		deprecateMethod: #called:on: 
		in: RBRefactoryTestDataApp 
		using: #callFoo) asRefactoring; execute
```

Before
```
RBRefactoryTestDataApp >> called: anObject on: aBlock 
	Transcript
		show: anObject printString;
		cr.
	aBlock value
```

After
```
RBRefactoryTestDataApp >> called: anObject on: aBlock 
	self
		deprecated: 'Use #callFoo instead'
		on: '16 April 2021'
		in: 'Pharo-9.0.0+build.1327.sha.a1d951343f221372d949a21fc1e86d5fc2d2be81 (64 Bit)'.
	Transcript
		show: anObject printString;
		cr.
	aBlock value
```!
!RBDeprecateMethodTransformation methodsFor: 'accessing' stamp: ''!
callDeprecationMethod

	^ 'self 
		deprecated: ''Use ' , newSelector storeString , ' instead''
		on: 	''' , Date today asString , ''' 
		in: ''' , SystemVersion current imageVersionString , ''''! !

!RBDeprecateMethodTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ (RBCondition definesSelector: selector in: class) 
		& (RBCondition canUnderstand: newSelector in: class)
		& (RBCondition 
							withBlock: [selector numArgs = newSelector numArgs or: [ newSelector numArgs = 0 ]]
							errorString: 'The new selectors should have the same number of arguments as the old one, or not have them at all').! !

!RBDeprecateMethodTransformation methodsFor: 'api' stamp: ''!
deprecateMethod: aSelector in: aClass using: newSel
	selector := aSelector asSymbol.
	newSelector := newSel asSymbol.
	class := self model classObjectFor: aClass.! !

!RBDeprecateMethodTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' deprecateMethod: #';
		nextPutAll: selector asString;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' using: #';
		nextPutAll: newSelector asString.
	aStream nextPut: $)! !

!RBDeprecateMethodTransformation methodsFor: 'executing' stamp: ''!
buildTransformations
	| node parseTree method start |
	
	method := class methodFor: selector.
	parseTree := method parseTree.
	start := parseTree body statements first start.
	node := self parserClass parseExpression: self callDeprecationMethod.
	^ OrderedCollection new add: (RBAddSubtreeTransformation
		interval: (29 to: 29)
		with: self callDeprecationMethod
		from: selector
		in: class);
		yourself! !

!RBDeprecateMethodTransformation class methodsFor: 'api' stamp: ''!
deprecateMethod: aSelector in: aClass using: newSelector
	^ self new 
		deprecateMethod: aSelector
		in: aClass
		using: newSelector;
		yourself! !

!RBDeprecateMethodTransformation class methodsFor: 'api' stamp: ''!
model: aRBSmalltalk deprecateMethod: aSelector in: aClass using: newSelector
	^ self new
		model: aRBSmalltalk;
		deprecateMethod: aSelector
		in: aClass
		using: newSelector;
		yourself! !

!RBDummy methodsFor: 'accessing' stamp: ''!
var1
	^ var1! !

!RBDummy methodsFor: 'tests - some' stamp: ''!
methodFromTrait
	RBClassToRename justForTest! !

!RBDummy classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RBDummy classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RBDummy classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RBDummy classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RBDummy classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RBDummy classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RBDummy classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RBDummy classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RBDummy classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBDummy classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RBDummy classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RBDummy classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RBDummy classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RBDummy classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RBDummy classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RBDummy classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RBDummy classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RBDummy classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBDummy classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RBDummy classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RBDummy classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RBDummy classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RBDummy classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RBDummy classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RBDummy classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RBDummy classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RBDummyClassToRename commentStamp: ''!
This is a dummy class to test RenameClass transformation!
!RBDummyClassToRename methodsFor: 'performing' stamp: ''!
method1

	^ self method2! !

!RBDummyClassToRename methodsFor: 'performing' stamp: ''!
method2
	
	^ self method1! !

!RBDummyCompositeLintRuleTest methodsFor: 'testing' stamp: ''!
isEmpty
	^(rules detect: [:each | each isEmpty not] ifNone: [nil]) isNil! !

!RBDummyCompositeLintRuleTest methodsFor: 'accessing' stamp: ''!
problemCount
	^rules inject: 0 into: [:count :each | count + each problemCount]! !

!RBDummyCompositeLintRuleTest methodsFor: 'accessing' stamp: ''!
checkClass: aSmalllintContext 
	rules do: 
			[:each | 
			each checkClass: aSmalllintContext.
			Processor yield]! !

!RBDummyCompositeLintRuleTest methodsFor: 'accessing' stamp: ''!
checkMethod: aSmalllintContext 
	rules do: 
			[:each | 
			each checkMethod: aSmalllintContext.
			Processor yield]! !

!RBDummyCompositeLintRuleTest methodsFor: 'initialization' stamp: ''!
resetResult
	rules do: [:each | each resetResult]! !

!RBDummyCompositeLintRuleTest methodsFor: 'private' stamp: ''!
viewResults
	rules do: [:each | each viewResults]! !

!RBDummyCompositeLintRuleTest methodsFor: 'initialization' stamp: ''!
rules: aCollection
	rules := aCollection! !

!RBDummyCompositeLintRuleTest methodsFor: 'accessing' stamp: ''!
failedRules
	^rules inject: OrderedCollection new into: [:oc :each | oc addAll: each failedRules; yourself]! !

!RBDummyCompositeLintRuleTest methodsFor: 'testing' stamp: ''!
hasConflicts
	^(rules detect: [:each | each hasConflicts] ifNone: [nil]) notNil! !

!RBDummyCompositeLintRuleTest methodsFor: 'testing' stamp: ''!
isComposite
	^true! !

!RBDummyCompositeLintRuleTest methodsFor: 'accessing' stamp: ''!
rules
	^rules! !

!RBDummyCompositeLintRuleTest class methodsFor: 'instance creation' stamp: ''!
allRules
	^self ruleFor: self protocol: 'all checks'! !

!RBDummyCompositeLintRuleTest class methodsFor: 'instance creation' stamp: ''!
rules: aCollection name: aString 
	^(self new) rules: aCollection;
		name: aString;
		yourself! !

!RBDummyCompositeLintRuleTest class methodsFor: 'all checks' stamp: ''!
transformations
	^ self 
		ruleFor: RBTransformationRuleTestData
		protocol: 'transformations'! !

!RBDummyCompositeLintRuleTest class methodsFor: 'all checks' stamp: ''!
lintChecks
	^ self 
		rules: (RBBasicLintRuleTestData protocolsToCheck collect: 
			[ :each | 
			self 
				ruleFor: RBBasicLintRuleTestData
				protocol: each ])
		name: 'Lint checks'! !

!RBDummyCompositeLintRuleTest class methodsFor: 'instance creation' stamp: ''!
rules: aCollection 
	^self new rules: aCollection! !

!RBDummyCompositeLintRuleTest class methodsFor: 'instance creation' stamp: ''!
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)! !

!RBDummyEmptyClass commentStamp: ''!
MRDummyEmptyClass is a test class to exercise class transformations!
!RBDummyEmptyClass methodsFor: 'empty protocol 1' stamp: ''!
someMethod

	^ 'a String'! !

!RBDummyLintRuleTest methodsFor: 'testing' stamp: ''!
isEmpty
	self subclassResponsibility! !

!RBDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
problemCount
	^self subclassResponsibility! !

!RBDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
checkClass: aSmalllintContext! !

!RBDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
checkMethod: aSmalllintContext! !

!RBDummyLintRuleTest methodsFor: 'initialization' stamp: ''!
initialize
	name := ''! !

!RBDummyLintRuleTest methodsFor: 'testing' stamp: ''!
junk
	^ RBDummyRefactoryTestDataApp printString 
		copyFrom: 1
		to: CR! !

!RBDummyLintRuleTest methodsFor: 'initialization' stamp: ''!
resetResult! !

!RBDummyLintRuleTest methodsFor: 'private' stamp: ''!
viewResults
	self subclassResponsibility! !

!RBDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
openEditor
	| rules |
	rules := self failedRules.
	rules isEmpty ifTrue: [^self].
	rules size == 1 ifTrue: [^rules first viewResults]! !

!RBDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
displayName
	| nameStream |
	nameStream := WriteStream on: (String new: 64).
	nameStream nextPutAll: self name;
		nextPutAll: ' ('.
	self problemCount printOn: nameStream.
	nameStream nextPut: $).
	^nameStream contents! !

!RBDummyLintRuleTest methodsFor: 'printing' stamp: ''!
printOn: aStream

	name ifNil: [ super printOn: aStream ] ifNotNil: [ aStream nextPutAll: name ]! !

!RBDummyLintRuleTest methodsFor: 'private' stamp: ''!
failedRules
	^self isEmpty
		ifTrue: [#()]
		ifFalse: [Array with: self]! !

!RBDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
name
	^name! !

!RBDummyLintRuleTest methodsFor: 'testing' stamp: ''!
hasConflicts
	^false! !

!RBDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
name: aString 
	name := aString! !

!RBDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
run
	^Object printOn: self! !

!RBDummyLintRuleTest methodsFor: 'testing' stamp: ''!
isComposite
	^false! !

!RBDummyLintRuleTest methodsFor: 'accessing' stamp: ''!
someOtherDemoMethod
	| temp |
	temp := self new.
	^ temp junk! !

!RBDummyLintRuleTest class methodsFor: 'parsing' stamp: ''!
parseTreeSearcherClass 
	^ RBParseTreeSearcher ! !

!RBDummyLintRuleTest class methodsFor: 'foo' stamp: ''!
someOtherFooMethod
	^ 'does nothing here even better:)'! !

!RBDummyLintRuleTest class methodsFor: 'foo' stamp: ''!
someFooMethod
	^ 'does nothing here:)'! !

!RBDummyLintRuleTest class methodsFor: 'parsing' stamp: ''!
parseTreeSearcher
	^ self parseTreeSearcherClass new! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
returnsBooleanAndOther
	self isVariable ifTrue: [^false].
	self printString! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
called: anObject on1: aBlock 
	| each |
	each := anObject printString.
	self traceCr: each.
	aBlock value: each! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
atIfAbsent
	^ Smalltalk at: #MyTest
		ifAbsent: 
			[| collection |
			collection := #().
			Smalltalk at: #MyTest put: collection]! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
callMethod
	^self renameThisMethod: 5! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
assignmentInBlock
	[^self printString] ensure: [self close]! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
demoExampleCall
	^ self demoRenameMethod: 1 PermuteArgs: 2! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
inlineFoo: aBlock 
	| bar baz asdf |
	bar := aBlock value: self.
	baz := bar + bar.
	asdf := baz + bar.
	^asdf! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
fileBlocks
	| file |
	^
	[file := 'asdf' asFileReference readStream.
	file contents] ensure: [file close]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
consistencyCheck
	^(1 to: 10) size > 0! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
multipleCalls
	self caller2.
	self caller2! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
usesAdd
	^(1 to: 10) asOrderedCollection addAll: (11 to: 20)! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
tempsReadBeforeWritten
	| temp |
	self isVariable ifTrue: [temp := 4].
	^temp! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
asOrderedCollectionNotNeeded
	self foo addAll: (1 to: 10) asOrderedCollection! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
cruft
	<haltOrBreakpointForTesting>
	self halt! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
refersToClass
	^ RBRefactoryTestDataApp! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
stringConcatenation
	| string |
	string := '' yourself.
	(1 to: 10) do: [:i | string := string , i printString].
	^string! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
called: anObject on: aBlock 
	self traceCr: anObject printString.
	aBlock value! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
justSendsSuper
	super justSendsSuper! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
endTrueFalse
	self isVariable 
		ifTrue: 
			[self printString.
			self isVariable printString]
		ifFalse: 
			[self printString.
			^4]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
literalArrayCharacters
	^#($a $b $c) includes: $a! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
inlineMethod
	| temp |
	temp := self
				foo;
				inlineMethod;
				bar.
	^temp! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
moveDefinition
	| temp |
	^(self collect: 
			[:each | 
			temp := each printString.
			temp , temp]) 
		select: 
			[:each | 
			temp := each size.
			temp odd]! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
inlineMax
	| x y q |
	x := 5.
	y := 10.
	q := x + 1 max: y.
	^q! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
selectorNotReferenced
	^self selectorNotReferenced + 4! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
returnsIfTrue
	^self isNil ifTrue: [4]! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
inlineJunk
	| asdf |
	asdf := self inlineFoo: 
					[:each | 
					| temp |
					temp := each.
					temp , temp].
	^asdf foo: 
			[:bar | 
			| baz |
			baz := bar.
			baz * baz]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
modifiesCollection
	| collection |
	collection := (1 to: 10) asOrderedCollection.
	collection do: [:each | each > 5 ifTrue: [collection remove: each]].
	^collection! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
longMethods
	self printString.
	self printString.
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
collectionProtocol
	| newCollection |
	newCollection := OrderedCollection new.
	(1 to: 10) asOrderedCollection do: 
			[:each | 
			| new |
			new := each * 2.
			newCollection add: new].
	^newCollection! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
inlineFailed
	| x y q |
	x := 5.
	y := 10.
	q := x + 1 fooMax: y.
	^q! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
minMax
	"Bug in 3<5 ifTrue: [3]  ifFalse: [5]"

^3<5 ifTrue: [3]  ifFalse: [5]
"	| var |
	var := 4.
	var < 5 ifTrue: [var := 5].
	^var"! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
threeElementPoint
	^5 @ 5 + 6 @ 6! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
noMoveDefinition
	| temp |
	^(self collect: 
			[:each | 
			temp := each printString.
			temp , temp]) 
		select: [:each | temp := each size + temp]! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
rename: this two: argumentMethod
	^self printString , this , argumentMethod! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
guardingClause
	self isSymbol 
		ifFalse: 
			[self printString.
			self isSymbol printString]! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
foo: aValue
	^(1 to: 10) inject: aValue into: [:sum :each | sum + each]! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
caller
	| anObject |
	anObject := 5.
	self 
		called: anObject + 1
		on: [^anObject]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
ifTrueReturns
	self isSymbol ifFalse: [^true].
	^false! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
precedence
	^self isArray ifFalse: [self block + 5 * 34] ifTrue: [self printString = 10]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
returnInEnsure
	[self error: 'asdf'] ensure: [^4]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
toDoCollect
	| array |
	array := Array new: 10.
	1 to: 10 do: [:i | array at: i put: i * i].
	^array! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
toDoWithIncrement
	| counter |
	counter := 0.
	1 to: 10
		by: 2
		do: [:i | counter := counter + 2].
	^counter! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
testFoo: anObject
	^self class + anObject! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
toDo
	1 to: self size do: [:i | (self at: i) printString]! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
callFoo
	^self testFoo: 5! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
tempVarOverridesInstVar
	| temporaryVariable |
	temporaryVariable := 4.
	^temporaryVariable! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
booleanPrecedence
	^true & 4 = 45! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
whileTrue
	| i |
	i := 1.
	[i < self size] whileTrue: 
			[(self at: i) printString.
			i := i + 1]! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
inlineLast
	5 = 3 ifTrue: [^self caller] ifFalse: [^self caller2]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
equalsTrue
	^true == self! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
caller1
	| anObject |
	anObject := 5.
	self called: anObject + 1
		on1: 
			[:each | 
			each printString.
			^anObject]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
badMessage
	self become: String new! !

!RBDummyRefactoryTestDataApp methodsFor: 'accessing' stamp: ''!
referencesConditionFor: aClass 
	| environment association |
	^(RBCondition withBlock: 
			[association := Smalltalk associationAt: aClass name
						ifAbsent: [self refactoringError: 'Could not find class'].
			environment := (self environment referencesTo: association) 
						| (self environment referencesTo: aClass name).
			environment isEmpty])
		errorMacro: aClass , ' is referenced.<n>Browse references?';
		errorBlock: [environment openEditor];
		yourself! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
sendsDifferentSuper
	super printString! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
sizeCheck
	self isEmpty
		ifFalse: [self do: 
					[:each | 
					self traceCr: each]]! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
inlineComponent
	| a |
	a := 5.
	^a class
		superclass;
		hasImmediateInstances;
		yourself! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
inlineTemporary
	| temp |
	self isNil ifTrue: [temp := 4].
	^temp! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
detectContains
	^(1 to: 10) do: [:each | each > 2 ifTrue: [^each]]! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
symbolReference
	^#(#renameThisMethod: #(4 #renameThisMethod:))! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
fullBlocks
	^[thisContext]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
missingYourself
	^(OrderedCollection new)
		add: 1;
		add: 2;
		removeFirst! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
testMethod
	^self class! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
assignmentInIfTrue
	| variable |
	self isVariable 
		ifTrue: [variable := self]
		ifFalse: [variable := self printString].
	^variable! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
variableAssignedLiteral
	temporaryVariable := #() ! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
yourselfNotUsed
	self
		printString;
		printString;
		yourself! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
searchingLiteral
	^self printString = #a or: [#() = self printString | ( #() == self printString)]! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
testMethod1
	^self testMethod1 
		, ([:each | each testMethod1] value: #(#(#testMethod1) 2 #testMethod1))! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
contains
	^((1 to: 10) detect: [:each | each > 2] ifNone: [nil]) isNil! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
literalArrayWithTrueFalseOrNil2
	| b c |
	b := #(#true #false #nil).
	c := #(#true (#true #false #nil) #false #nil).
^b! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
equalNotUsed
	| string |
	string = '' yourself.
	(1 to: 10) do: [:i | string := i printString].
	^string! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
inlineParameterMethod: aSymbol
	^aSymbol isSymbol! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
exampleCall
	^self rename: 1 two: 2! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
extraBlock
	^[:arg | arg + 43] value: 45! !

!RBDummyRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
caller2
	^(1 to: 10) inject: 1 into: [:sum :each | sum * (self foo: each)]! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
renameThisMethod: anArg
	^self! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
collectionMessagesToExternalObject
	self someObject collection remove: 10! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
collectSelectNotUsed
	(1 to: 10) select: [:each | each = 4]! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
literalArrayWithTrueFalseOrNil
	| a b c |
	a := #(true false nil).
	b := #(#true #false #nil).
	c := {true. false. nil}.
	^{a. b. c}! !

!RBDummyRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
release
	self printString! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
sendInlineParameterMethod
	^self inlineParameterMethod: #(#asdf)! !

!RBDummyRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
demoMethodWithDuplicates
	| a b result1 result2 answer |
	a := 3.
	b := a + 5.
	result1 := a + b.
	result2 := a + 5.
	answer := result1 + result2 + (a + 5).
	^ answer! !

!RBDummyRefactoryTestDataApp methodsFor: 'as yet unclassified' stamp: ''!
demoRenameMethod: arg1 PermuteArgs: arg2
	self do: arg1. 
	self do: arg2.
	^ arg1 > arg2! !

!RBDummySubclassOfClassToRename commentStamp: ''!
This is a dummy class to test RenameClass transformation!
!RBDummySubclassOfClassToRename methodsFor: 'accessing' stamp: ''!
calls1

	^ self rewriteRule10: (self rewriteRule10: self calls)! !

!RBDummySubclassOfClassToRename methodsFor: 'accessing' stamp: ''!
rewriteRule10
	^ rewriteRule10! !

!RBDummySubclassOfClassToRename methodsFor: 'performing' stamp: ''!
symbolReference

	^ #RBDummyClassToRename! !

!RBDummySubclassOfClassToRename methodsFor: 'accessing' stamp: ''!
calls

	^ self rewriteRule10: self name , self rewriteRule10! !

!RBDummySubclassOfClassToRename methodsFor: 'performing' stamp: ''!
reference

	^ RBDummyClassToRename new! !

!RBDummySubclassOfClassToRename methodsFor: 'accessing' stamp: ''!
rewriteRule10: anObject
	rewriteRule10 := anObject! !

!RBDumpVisitor commentStamp: ''!
I'm a visitor that generates code whose execution will recreate the visited node (similarly to storeOn: protocol).
This is handy because we can simply serialize the object in a textual form without requiring a separate parser.

I'm used by reflexivity.

try me!! 
(RBDumpVisitor >> #stream) ast dump

Instance Variables
	stream:		<Object>		The stream holding the output. Filled up throughout the visit.

!
!RBDumpVisitor methodsFor: 'initialization' stamp: ''!
initialize
	stream := String new writeStream! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode
	stream nextPutAll: aBlockNode class name.
	aBlockNode arguments
		ifNotEmpty: [ stream nextPutAll: ' arguments: {'.
			aBlockNode arguments
				do: [ :each | 
					each acceptVisitor: self.
					stream nextPutAll: '. ' ].
			stream nextPutAll: '}' ].
	stream nextPutAll: ' body: ('.
	aBlockNode body acceptVisitor: self.
	stream nextPut: $)! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralValueNode: aLiteralValueNode
	stream
		nextPutAll: aLiteralValueNode class name;
		nextPutAll: ' value: '.
	aLiteralValueNode value printOn: stream! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode
	stream nextPutAll: aSequenceNode class name.
	aSequenceNode temporaries
		ifNotEmpty: [ stream nextPutAll: ' temporaries: {'.
			aSequenceNode temporaries
				do: [ :each | 
					each acceptVisitor: self.
					stream nextPutAll: '. ' ].
			stream nextPut: $} ].
	stream nextPutAll: ' statements: {'.
	aSequenceNode statements
		do: [ :each | 
			each acceptVisitor: self.
			stream nextPutAll: '. ' ].
	stream nextPut: $}! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aLiteralArrayNode
	stream
		nextPutAll: aLiteralArrayNode class name;
		nextPutAll: ' value: #('.
	(aLiteralArrayNode contents collect: [ :each | each value ]) printOn: stream delimiter: ' '.
	stream nextPutAll: ')'! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitEnglobingErrorNode: anEnglobingErrorNode
	stream
		nextPutAll: '(';
		nextPutAll: anEnglobingErrorNode class name;
		nextPutAll: ' content: {'.
	anEnglobingErrorNode content
		do: [ :each | 
			each acceptVisitor: self.
			stream nextPutAll: '. ' ].
	stream nextPut: $}.
	stream nextPutAll: ' start: '.
	anEnglobingErrorNode start printOn: stream.
	stream nextPutAll: ' stop: '.
	anEnglobingErrorNode stop printOn: stream.
	stream nextPutAll: ' errorMessage: '.
	anEnglobingErrorNode errorMessage printOn: stream.
	stream
		nextPutAll: ') value: ';
		nextPutAll: anEnglobingErrorNode value printString.! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitReturnNode: aReturnNode
	stream
		nextPutAll: aReturnNode class name;
		nextPutAll: ' value: ('.
	aReturnNode value acceptVisitor:self.
	stream nextPut: $)! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: anAssignmentNode
	stream
		nextPutAll: anAssignmentNode class name;
		nextPutAll: ' variable: ('.
	anAssignmentNode variable acceptVisitor: self.
	stream nextPutAll: ') value: ('.
	anAssignmentNode value acceptVisitor: self.
	stream nextPut: $)! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitCascadeNode:aCascadeNode
	stream
		nextPutAll: aCascadeNode class name;
		nextPutAll: ' messages: {'.
	aCascadeNode messages
		do: [ :each | 
			each acceptVisitor: self.
			stream nextPutAll: '. ' ].
	stream nextPut: $}! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralNode: aLiteralNode
	self visitLiteralValueNode: aLiteralNode! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode
	| hasPragmas |
	hasPragmas := aMethodNode pragmas isNotEmpty.
	hasPragmas
		ifTrue: [ stream nextPut: $( ].
	stream
		nextPutAll: aMethodNode class name;
		nextPutAll: ' selector: '.
	aMethodNode selector printOn: stream.
	aMethodNode arguments
		ifNotEmpty: [ stream nextPutAll: ' arguments: {'.
			aMethodNode arguments
				do: [ :each | 
					each acceptVisitor:self.
					stream nextPutAll: '. ' ].
			stream nextPut: $} ].
	aMethodNode body
		ifNotNil: [ stream nextPutAll: ' body: ('.
			aMethodNode body acceptVisitor:self.
			stream nextPut: $) ].
	hasPragmas
		ifFalse: [ ^ aMethodNode ].
	stream nextPutAll: ') pragmas: {'.
	aMethodNode pragmas
		do: [ :each | 
			each acceptVisitor: self.
			stream nextPutAll: '. ' ].
	stream nextPut: $}! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitArrayNode: anArrayNode
	stream
		nextPutAll: anArrayNode class name;
		nextPutAll: ' statements: { '.
	anArrayNode statements
		do: [ :each | 
			each acceptVisitor: self.
			stream nextPutAll: '. ' ].
	stream nextPut: $}! !

!RBDumpVisitor methodsFor: 'initialization' stamp: ''!
stream
	^ stream! !

!RBDumpVisitor methodsFor: 'accessing' stamp: ''!
contents
	^ stream contents! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitPragmaNode: aPragmaNode
	stream
		nextPutAll: aPragmaNode class name;
		nextPutAll: ' selector: '.
	aPragmaNode selector printOn: stream.
	stream nextPutAll: ' arguments: {'.
	aPragmaNode arguments
		do: [ :each | 
			each acceptVisitor: self.
			stream nextPutAll: '. ' ].
	stream nextPut: $}! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitMessageNode: aMessageNode
	stream
		nextPutAll: aMessageNode class name;
		nextPutAll: ' receiver: ('.
	aMessageNode receiver acceptVisitor: self.
	stream nextPutAll: ') selector: '.
	aMessageNode selector printOn: stream.
	aMessageNode arguments
		ifNotEmpty: [ stream nextPutAll: ' arguments: {'.
			aMessageNode arguments
				do: [ :each | 
					each acceptVisitor: self.
					stream nextPutAll: '. ' ].
			stream nextPut: $} ]! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitParseErrorNode: aParseErrorNode
	stream
		nextPutAll: aParseErrorNode class name;
		nextPutAll: ' errorMessage: '.
	aParseErrorNode errorMessage printOn: stream.
	stream nextPutAll: ' value: '.
	aParseErrorNode value printOn: stream.
	stream nextPutAll: ' at: '.
	aParseErrorNode start printOn: stream! !

!RBDumpVisitor methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode
	stream
		nextPutAll: aVariableNode class name;
		nextPutAll: ' named: '.
	aVariableNode name printOn: stream! !

!RBDumpVisitorTest commentStamp: ''!
SUnit tests for the RBDumpVisitor visit, called by the #dump method on RBProgramNodes.!
!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testMessageNodeDump

	| node dumpedNode |
	"Simple selector"
	node := self parseExpression: 'self foo'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBMessageNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString.

	"With an argument"
	node := self parseExpression: 'self foo: 1'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBMessageNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString.

	"With many arguments"
	node := self parseExpression: 'self foo: 1 bar: 2'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBMessageNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString.

	"Binary message"
	node := self parseExpression: '1 + 2'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBMessageNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'test - api' stamp: ''!
testAPI

	| node |
	node := self parseExpression: 'self foo'.
	self 
		assert: (RBDumpVisitor new visit: node) contents
		equals:  'RBMessageNode receiver: (RBVariableNode named: #self) selector: #foo'! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testLiteralValueNodeDump

	| node dumpedNode |
	"Numeric are literals"
	node := self parseExpression: '1'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBLiteralValueNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString.

	"Symbol are literals"
	node := self parseExpression: '#foo'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBLiteralValueNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString.

	"Booleans are literals"
	node := self parseExpression: 'true'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBLiteralValueNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString.

	"char are literals"
	node := self parseExpression: '$a'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBLiteralValueNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString.

	"String are literals"
	node := self parseExpression: '''a'''.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBLiteralValueNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
uselessMethod
	"used for test"! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testBlockNodeDump

	| node dumpedNode |
	"Simple block"
	node := self parseExpression: '[self]'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBBlockNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString.

	"Block with argument"
	node := self parseExpression: '[:each | each]'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBBlockNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString.

	"Block with arguments and temps"
	node := self parseExpression: '[:each :i | |a b| a := each. b := i.]'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBBlockNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testCascadeNodeDump

	| node dumpedNode |
	node := self parseExpression: 'self foo; bar'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBCascadeNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testErrorNodeDump

	| node dumpedNode |
	node := self parseFaultyExpression: '( +'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBParenthesesErrorNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testDumpOnObjectMethod

	| node dumpedNode |
	node := (Object >> #readSlot:) ast.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBMethodNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testSequenceNodeDump

	| node dumpedNode |
	node := self parseExpression: 'foo. bar.'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBSequenceNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testDumpOnSelfClassMethods

	| methods node dumpedNode |
	methods := { 
		           (self class >> #testAssignmentNodeDump).
		           (self class >> #uselessMethod).
		           (self class >> #testVariableNodeDump).
		           (self class >> #testThisContextNodeDump).
		           (self class >> #testReturnNodeDump) }.
	methods do: [ :each | 
		node := each ast.
		dumpedNode := self compiler evaluate: node dump.
		self assert: dumpedNode class equals: RBMethodNode.
		self assert: node class equals: dumpedNode class.
		self assert: node equals: dumpedNode ]! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
compiler

	^ Smalltalk compiler! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testThisContextNodeDump

	| node dumpedNode |
	node := self parseExpression: 'thisContext'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBVariableNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testSuperNodeDump

	| node dumpedNode |
	node := self parseExpression: 'super'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBVariableNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testAssignmentNodeDump

	| node dumpedNode |
	node := self parseExpression: 'a := 3.'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBAssignmentNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testArrayNodeDump

	| node dumpedNode |
	"Empty Array"
	node := self parseExpression: '{}'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBArrayNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString.

	"non-empty Array"
	node := self parseExpression: '{1 + 1. true. Object new}'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBArrayNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testMethodNodeDump

	| node dumpedNode |
	node := self parseMethod: 'foo <useless>'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBMethodNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testPragmaNodeDump

	| node dumpedNode |
	node := self parseMethod: 'foo <useless>'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode pragmas first class equals: RBPragmaNode.
	self
		assert: node pragmas first class
		equals: dumpedNode pragmas first class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testVariableNodeDump

	| node dumpedNode |
	node := self parseExpression: 'a'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBVariableNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testReturnNodeDump

	| node dumpedNode |
	node := self parseExpression: '^ 1 + 1'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBReturnNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testSelfNodeDump

	| node dumpedNode |
	node := self parseExpression: 'self'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBVariableNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testLiteralArrayNodeDump

	| node dumpedNode |
	node := self parseExpression: '#(1 $a true ''a'')'.
	dumpedNode := self compiler evaluate: node dump.

	self assert: dumpedNode class equals: RBLiteralArrayNode.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBDumpVisitorTest methodsFor: 'tests' stamp: ''!
testGlobalNodeDump

	| node dumpedNode |
	"Global nodes are only generated when a semantic analysis is triggered on a method"
	node := self parseMethod: 'foo ^ Object'.
	node doSemanticAnalysis.
	dumpedNode := self compiler evaluate: node dump.
	dumpedNode doSemanticAnalysis.

	self assert: dumpedNode statements first value isGlobalVariable.
	self assert: node class equals: dumpedNode class.
	self assert: node printString equals: dumpedNode printString! !

!RBEOFToken methodsFor: 'accessing' stamp: ''!
value

	^ ''! !

!RBEOFToken methodsFor: 'accessing' stamp: ''!
length
	^ 0! !

!RBEOFToken methodsFor: 'testing' stamp: ''!
isEOF
	^true! !

!RBEnglobingErrorNode commentStamp: ''!
I am a node representing a source code segment that parsed but never used in a node because of an unexpected error at the end. I am mainly used for source-code coloring and icon styling where all the code parsed should be colored normaly but underlined as part of the error.
This node also propose a reparation research.

Parsing faulty code without raising a syntax error is done by 
RBParser parseFaultyExpression:
or
RBParser parseFaultyMethod: 

Accessing to the parsed nodes contained inside the node is the method 'content'.

!
!RBEnglobingErrorNode methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	content := OrderedCollection new.
	value := ''.! !

!RBEnglobingErrorNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aVisitor

	^ aVisitor visitEnglobingErrorNode: self! !

!RBEnglobingErrorNode methodsFor: 'testing' stamp: ''!
isEnglobingError
	^true! !

!RBEnglobingErrorNode methodsFor: 'accessing' stamp: ''!
content: aCollection
	content := aCollection.
	aCollection do: [:each | each parent: self ]! !

!RBEnglobingErrorNode methodsFor: 'accessing' stamp: ''!
children
	^ content! !

!RBEnglobingErrorNode methodsFor: 'accessing' stamp: ''!
content
	^content! !

!RBEnglobingErrorNode methodsFor: 'accessing' stamp: ''!
stop: anInterger
	stop := anInterger.! !

!RBEnglobingErrorNode class methodsFor: 'instance creation' stamp: ''!
content: aCollection start: aStart stop: aStop errorMessage: message
	^self new 
		content: aCollection; 
		start: aStart; 
		stop: aStop; 
		errorMessage: message! !

!RBEnglobingErrorNode class methodsFor: 'construction' stamp: ''!
error: aToken withNodes: aCollection
	"Realise a selection between the different englobing error node classes possible according to the 
	 received token. If the value of the token is not recognised, we create an undetermined one."
	('()' includes: aToken value)
		ifTrue: [ ^RBParenthesesErrorNode error: aToken withNodes: aCollection ].
	('[]' includes: aToken value)
		ifTrue: [ ^RBBlockErrorNode error: aToken withNodes: aCollection ].
	('#(' = aToken value asString)
		ifTrue: [ ^RBLiteralArrayErrorNode error: aToken withNodes: aCollection ].
	('#[' = aToken value asString)
		ifTrue: [ ^RBLiteralByteArrayErrorNode error: aToken withNodes: aCollection ].
	('{}' includes: aToken value)
		ifTrue: [ ^RBArrayErrorNode error: aToken withNodes: aCollection ].
	('|' = aToken value asString)
		ifTrue: [ ^RBTemporariesErrorNode error: aToken withNodes: aCollection ].
	('<' = aToken value asString)
		ifTrue: [ ^RBPragmaErrorNode error: aToken withNodes: aCollection ].
	^self new content: aCollection; start: aCollection first start; stop: aToken stop; errorMessage: 'complementary of''',aToken value,''' expected'! !

!RBEntity commentStamp: ''!
I'm the root of the model classes.!
!RBEntity methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	modelFactory := RBClassModelFactory new. 
	changeFactory := RBRefactoryChangeManager changeFactory! !

!RBEntity methodsFor: 'initialization' stamp: ''!
parserClass 
	
	^ RBParser! !

!RBEnvironmentVisitor commentStamp: ''!
I'm a visitor to create the correct presenter to edit a scope!
!RBEnvironmentVisitor methodsFor: 'visiting' stamp: ''!
visitProtocolEnv: rbProtocolEnv
	| list selectedList methodName items dialog |
	list := rbProtocolEnv definedClass protocols sorted.
	selectedList := rbProtocolEnv protocols sorted.
	methodName := #yourself.
	items := OrderedCollection new.
	dialog := self chooserClass openOn: 
		{ list . selectedList . methodName }
		onAccept: [:e| items addAll: e ].
	dialog isCancelled ifTrue: [ ^self ].

	rbProtocolEnv protocols do: [ :cls | rbProtocolEnv removeProtocol: cls ].
	items do: [ :cls | rbProtocolEnv addProtocol: cls ].! !

!RBEnvironmentVisitor methodsFor: 'visiting' stamp: ''!
visitPackageEnv: rbPackageEnv
	| list selectedList methodName items dialog |
	list := RPackageOrganizer default packages sorted: #packageName ascending.
	selectedList := rbPackageEnv packages asArray sorted: #packageName ascending.
	methodName := #packageName.
	items := OrderedCollection new.
	dialog := self chooserClass openOn: 
		{ list . selectedList . methodName }
		onAccept: [:e| items addAll: e ].
	dialog isCancelled ifTrue: [ ^self ].

	rbPackageEnv packages do: [ :cls | rbPackageEnv removePackage: cls ].
	items do: [ :cls | rbPackageEnv addPackage: cls ].! !

!RBEnvironmentVisitor methodsFor: 'accessing' stamp: ''!
chooserClass
	^ SpChooserPresenter! !

!RBEnvironmentVisitor methodsFor: 'visiting' stamp: ''!
visitClassEnv: rbClassEnv
	| list selectedList methodName items dialog |
	list := RBBrowserEnvironment default allClasses sorted: #name ascending.
	selectedList := (rbClassEnv classes collect: 
		[ :e | Smalltalk globals at: e ifAbsent: [ nil ] ]) asArray sorted: #name ascending.
	methodName := #name.
	items := OrderedCollection new.
	dialog := self chooserClass openOn: 
		{ list . selectedList . methodName }
		onAccept: [:e| items addAll: e ].
	dialog isCancelled ifTrue: [ ^self ].
	rbClassEnv classesDo: [ :cls | rbClassEnv removeClass: cls ].
	items do: [ :cls | rbClassEnv addClass: cls ].! !

!RBEnvironmentsPresenter methodsFor: 'accessing' stamp: ''!
andWithScope: anItem
	self performOperation: #& with: anItem! !

!RBEnvironmentsPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	scopeList := self newTreeTable! !

!RBEnvironmentsPresenter methodsFor: 'actions' stamp: ''!
notWithScope: anItem

	[ | newScope |
	newScope := anItem not.
	(self confirm: 'Do you want store this result in the list?') 
		ifTrue: [
			RefactoringSettings addScope: newScope.
			self updateList.
		] ifFalse: [ newScope inspect ] ] 
	on: Error 
	do: [ :e | self inform: 'Something was wrong']! !

!RBEnvironmentsPresenter methodsFor: 'actions' stamp: ''!
selectAnotherScopeWhitout: anItem
	| anotherScope list |
	list := RefactoringSettings scopeList copyWithout: anItem.
	anotherScope := UIManager default
			chooseFrom: (list collect: #shortDescription)
			values: list
			title: 'Select another scope (RBEnvironment)'.
	^ anotherScope ! !

!RBEnvironmentsPresenter methodsFor: 'actions' stamp: ''!
performOperation: aSymbol with: anItem
	| anEnvironment newScope |
	[ anEnvironment := self selectAnotherScopeWhitout: anItem.
	newScope := anItem perform: aSymbol with: anEnvironment.
	(self confirm: 'Do you want store this result in the list?') 
		ifTrue: [
			RefactoringSettings addScope: newScope.
			self updateList.
		] ifFalse: [ newScope inspect ].
	] 
	on: Error 
	do: [ :e | self inform: 'Something was wrong']! !

!RBEnvironmentsPresenter methodsFor: 'actions' stamp: ''!
orWithScope: anItem
	self performOperation: #| with: anItem! !

!RBEnvironmentsPresenter methodsFor: 'actions' stamp: ''!
edit: anItem
	[ anItem acceptVisitor: RBEnvironmentVisitor new ]
	on: Error 
	do: [ :e | self inform:  'Somethig was wrong']! !

!RBEnvironmentsPresenter methodsFor: 'actions' stamp: ''!
remove: anItem
	RefactoringSettings removeScopeNamed: anItem description.
	self updateList ! !

!RBEnvironmentsPresenter methodsFor: 'accessing' stamp: ''!
argumentsListMenu
	^ self newMenu
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'AND';
						action: [ self andWithScope: scopeList selectedItem ] ];
				addItem: [ :anItem | 
					anItem
						name: 'OR';
						action: [ self orWithScope: scopeList selectedItem ] ];
				addItem: [ :anItem | 
					anItem
						name: 'NOT';
						action: [ self notWithScope: scopeList selectedItem ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Inspect';
						visibleIf: [ (scopeList selectedItem isCompositeEnvironment not
							and: [ scopeList selectedItem label ~= 'current image' ])];
						action: [ self inspect: scopeList selectedItem ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Edit';
						visibleIf: [ (scopeList selectedItem isCompositeEnvironment not
							and: [ scopeList selectedItem label ~= 'current image' ])];
						action: [ self edit: scopeList selectedItem ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Remove';
						visibleIf: [ scopeList selectedItem label ~= 'current image' ];
						action: [ self remove: scopeList selectedItem ] ]
				 ]! !

!RBEnvironmentsPresenter methodsFor: 'actions' stamp: ''!
updateList
	scopeList roots: RefactoringSettings scopeList! !

!RBEnvironmentsPresenter methodsFor: 'actions' stamp: ''!
inspect: anItem

	(anItem inspectIn: self) openWithSpec title: anItem shortDescription.! !

!RBEnvironmentsPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter

	scopeList addColumn: (SpStringTableColumn title: 'Environment' evaluated: #shortDescription);
		roots: RefactoringSettings scopeList;
		children: [ :aClass | RefactoringSettings scopeList 
			select: [ :cls | aClass isCompositeEnvironment ifTrue: 
				[ aClass environment == cls or: [ aClass otherEnvironment == cls ] ] 
			ifFalse: [ false ] ] ];
		contextMenu: self argumentsListMenu.! !

!RBEnvironmentsPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #scopeList;
				yourself);
		yourself! !

!RBEnvironmentsPresenter class methodsFor: 'specs' stamp: ''!
open
	<script>
	self new openWithSpec! !

!RBEnvironmentsPresenter class methodsFor: 'accessing' stamp: ''!
title
	^ 'Scope options'! !

!RBEnvironmentsPresenter class methodsFor: 'specs' stamp: ''!
menuCommandOn: aBuilder
    <worldMenu>
    (aBuilder item: #'Scopes Editor')
                action: [self open];
                parent: #Refactoring;
                help: 'Editor for custom refactoring environments (scopes)';
                order: 10! !

!RBErrorNodeParserTest methodsFor: 'tests' stamp: ''!
testFaultyMessageSendShouldHaveTheCorrectMessage

	| node |
	node := self parserClass parseFaultyExpression: 'msg: arg'.
	
	self assert: node isMessage.
	self assert: node receiver isParseError.
	self assert: node selector equals: #msg:.! !

!RBErrorNodeParserTest methodsFor: 'tests' stamp: ''!
testFaultyCascade

	| node |
	node := self parserClass parseFaultyExpression: '; ]'.
	
	self assert: node isUnfinishedStatement.
	self assert: node children first isCascade.
	self assert: node children first messages first isParseError.! !

!RBErrorNodeParserTest methodsFor: 'tests' stamp: ''!
testFaultyMethodWithSignatureKeepsSignature

	| node |
	node := self parserClass parseFaultyMethod: 'ret ^ 1 ^ 2'.
	
	self assert: node isMethod.
	self assert: node selector equals: #ret! !

!RBErrorNodeParserTest methodsFor: 'tests' stamp: ''!
testFaultyMethodConsumesEntireStream

	| parser |
	parser := self parserClass newFaulty.
	parser initializeParserWith: 'ret ^ 1 ^ 2'.
	parser parseMethod.
	
	self assert: parser atEnd! !

!RBErrorNodeParserTest methodsFor: 'tests' stamp: ''!
testFaultyMessageSendWithLiteralArgumentShouldHaveTheCorrectMessage

	| node |
	node := self parserClass parseFaultyExpression: 'msg: 12'.
	
	self assert: node isMessage.
	self assert: node selector equals: #msg:.
	
	self assert: node receiver isParseError.

	self assert: node arguments first isLiteralNode.
	self assert: node arguments first value equals: 12.! !

!RBErrorNodeParserTest methodsFor: 'tests' stamp: ''!
testFaultyMessageSendWithSymbolsArgumentShouldHaveTheCorrectMessage

	| node |
	node := self parserClass parseFaultyExpression: 'msg: #lala: and:12'.
	
	self assert: node isMessage.
	self assert: node selector equals: #msg:and:.
	
	self assert: node receiver isParseError.

	self assert: node arguments first value equals: #lala:.
	self assert: node arguments second isLiteralNode.
	self assert: node arguments second value equals: 12.! !

!RBErrorNodeParserTest methodsFor: 'tests' stamp: ''!
testFaultyMethodWithoutSignatureHasAnErrorNodeAndContinueParsing

	| node |
	node := self parserClass parseFaultyMethod: '1 between: 2 and: 3'.
	
	self assert: node isMethod.
	self assert: node selector equals: #faulty.

	self assert: node body statements first isParseError.

	self assert: node body statements second isMessage.
	self assert: node body statements second selector equals: #between:and:.! !

!RBErrorNodeParserTest methodsFor: 'tests' stamp: ''!
testFaultyBinaryMessageSendWithLiteralArgumentShouldHaveTheCorrectMessage

	| node |
	node := self parserClass parseFaultyExpression: '+ 12'.
	
	self assert: node isMessage.
	
	self assert: node receiver isParseError.
	
	self assert: node arguments first isLiteralNode.
	self assert: node arguments first value equals: 12.! !

!RBErrorNodeParserTest methodsFor: 'tests' stamp: ''!
testFaultyBinaryMessageSendArgumentShouldHaveTheCorrectMessage

	| node |
	node := self parserClass parseFaultyExpression: '+ arg'.
	
	self assert: node isMessage.
	self assert: node receiver isParseError.
	self assert: node selector equals: #+.! !

!RBErrorToken commentStamp: ''!
I'm a scanned error.
I can have multiple causes.!
!RBErrorToken methodsFor: 'accessing' stamp: ''!
cause
	^ cause! !

!RBErrorToken methodsFor: 'accessing' stamp: ''!
location
	^ location! !

!RBErrorToken methodsFor: 'accessing' stamp: ''!
value: theValue start: tokenStart cause: errorCause location: errorPosition
	self value: theValue start: tokenStart.
	location := errorPosition.
	cause := errorCause! !

!RBErrorToken methodsFor: 'testing' stamp: ''!
isError
	^true! !

!RBErrorToken class methodsFor: 'instance creation' stamp: ''!
value: value start: tokenStart cause: errorCause location: thePosition
	^ self new
		value: value
			start: tokenStart
			cause: errorCause
			location: thePosition;
		yourself! !

!RBExpandReferencedPoolsRefactoring commentStamp: ''!
I am a refactoring operations for finding direct pool variables  references.

I am used by other refactorings, for example to push down/ pull up a method.
Moving a method from class A to class B, that referes to some pool variables of class A, 
this refactoring will add the pool definition to class B.

!
!RBExpandReferencedPoolsRefactoring methodsFor: 'initialization' stamp: ''!
forMethod: aParseTree fromClass: aClass toClasses: classCollection 
	fromClass := self model classFor: aClass.
	parseTree := aParseTree.
	toClasses := classCollection collect: [:each | self model classFor: each]! !

!RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self computePoolsToMove.
	self hasPoolsToMove 
		ifTrue: 
			[self 
				refactoringWarning: 'This method contains references to pools<n>which may need to be moved.<n>Proceed anyway?' 
						expandMacros].
	self movePoolVariables! !

!RBExpandReferencedPoolsRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ self emptyCondition! !

!RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: ''!
movePoolVariables
	pools 
		do: [:poolDict | toClasses do: [:each | self movePool: poolDict toClass: each]]! !

!RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: ''!
whichPoolDefines: varName 
	| currentClass |
	currentClass := fromClass.
	[currentClass isNil] whileFalse: 
			[currentClass allPoolDictionaryNames 
				do: [:each | ((self poolVariableNamesIn: each) includes: varName) ifTrue: [^each]].
			currentClass := currentClass superclass].
	^nil! !

!RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: ''!
movePool: aSymbol toClass: aClass 
	| nonMetaClass |
	nonMetaClass := aClass instanceSide.
	(nonMetaClass definesPoolDictionary: aSymbol) ifFalse: [ nonMetaClass addPoolDictionary: aSymbol ]! !

!RBExpandReferencedPoolsRefactoring methodsFor: 'testing' stamp: ''!
hasPoolsToMove
	^pools isNotEmpty! !

!RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: ''!
computePoolsToMove

	| poolVariables searcher |
	poolVariables := self poolVariableNamesFor: fromClass.
	pools := Set new.
	searcher := self parseTreeSearcher.
	searcher
		matches: '`var'
		do: [ :aNode :answer | 
			| varName pool |

			varName := aNode name.
			( aNode whoDefines: varName )
				ifNil: [ ( poolVariables includes: varName )
						ifTrue: [ pool := self whichPoolDefines: varName.
							pool ifNotNil: [ pools add: pool ]
							]
					]
			].
	searcher executeTree: parseTree! !

!RBExpandReferencedPoolsRefactoring class methodsFor: 'instance creation' stamp: ''!
forMethod: aParseTree fromClass: aClass toClasses: classCollection 
	^ self new
		forMethod: aParseTree
			fromClass: aClass
			toClasses: classCollection;
		yourself! !

!RBExpandReferencedPoolsRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBNamespace forMethod: aParseTree fromClass: aClass toClasses: classCollection 
	^ self new
		model: aRBNamespace;
		forMethod: aParseTree
			fromClass: aClass
			toClasses: classCollection;
		yourself! !

!RBExpandReferencedPoolsTransformation methodsFor: 'api' stamp: ''!
forMethod: aParseTree fromClass: aClass toClasses: classCollection
	fromClass := self model classFor: aClass.
	parseTree := aParseTree.
	toClasses := classCollection collect: [:each | self model classFor: each]! !

!RBExpandReferencedPoolsTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ self emptyCondition! !

!RBExpandReferencedPoolsTransformation methodsFor: 'executing' stamp: ''!
movePoolVariables
	pools 
		do: [:poolDict | toClasses do: [:each | self movePool: poolDict toClass: each]]! !

!RBExpandReferencedPoolsTransformation methodsFor: 'testing' stamp: ''!
whichPoolDefines: varName
	| currentClass |
	currentClass := fromClass.
	[currentClass isNil] whileFalse: 
			[currentClass allPoolDictionaryNames 
				detect: [:each | ((self poolVariableNamesIn: each) includes: varName)] ifFound: [ :each | ^ each ].
			currentClass := currentClass superclass].
	^nil! !

!RBExpandReferencedPoolsTransformation methodsFor: 'preconditions' stamp: ''!
movePool: aSymbol toClass: aClass
	| nonMetaClass |
	nonMetaClass := aClass instanceSide.
	(nonMetaClass definesPoolDictionary: aSymbol) ifFalse: [ nonMetaClass addPoolDictionary: aSymbol ]! !

!RBExpandReferencedPoolsTransformation methodsFor: 'testing' stamp: ''!
hasPoolsToMove
	^pools isNotEmpty! !

!RBExpandReferencedPoolsTransformation methodsFor: 'transforming' stamp: ''!
computePoolsToMove

	| poolVariables searcher |
	poolVariables := self poolVariableNamesFor: fromClass.
	pools := Set new.
	searcher := self parseTreeSearcher.
	searcher
		matches: '`var'
		do: [ :aNode :answer | 
			| varName pool |

			varName := aNode name.
			( aNode whoDefines: varName )
				ifNil: [ ( poolVariables includes: varName )
						ifTrue: [ pool := self whichPoolDefines: varName.
							pool ifNotNil: [ pools add: pool ]
							]
					]
			].
	searcher executeTree: parseTree! !

!RBExpandReferencedPoolsTransformation methodsFor: 'transforming' stamp: ''!
privateTransform

	self computePoolsToMove.
	self hasPoolsToMove 
		ifTrue: 
			[self 
				refactoringWarning: 'This method contains references to pools<n>which may need to be moved.<n>Proceed anyway?' 
						expandMacros].
	self movePoolVariables! !

!RBExpandReferencedPoolsTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' forMethod: '''.
	parseTree storeOn: aStream.
	aStream
		nextPutAll: ''' fromClass: ''';
		nextPutAll: fromClass name;
		nextPutAll: ''' toClasses: '.
	toClasses storeOn: aStream.
	aStream nextPut: $)! !

!RBExpandReferencedPoolsTransformation class methodsFor: 'api' stamp: ''!
forMethod: aParseTree fromClass: aClass toClasses: classCollection
	^ self new
		forMethod: aParseTree
		fromClass: aClass
		toClasses: classCollection;
		yourself! !

!RBExpandReferencedPoolsTransformation class methodsFor: 'api' stamp: ''!
model: aRBNamespace forMethod: aParseTree fromClass: aClass toClasses: classCollection
	^ self new
		model: aRBNamespace;
		forMethod: aParseTree
		fromClass: aClass
		toClasses: classCollection;
		yourself! !

!RBExtractMethodAndOccurrences commentStamp: ''!
I am a refactoring for creating a method from a code fragment and then find all occurrences of code fragment in its class and its hierarchy if apply.

You can select an interval of some code in a method and call this refactoring to create a new method implementing that code and replace the code by calling this method instead. Then find occurrences of extracted method in all class methods and replace the duplicated code by calling extracted method istead.!
!RBExtractMethodAndOccurrences methodsFor: 'asserting' stamp: ''!
shouldSearchInHierarchy
	^(self options at: #searchInWholeHierarchy) value: self value: class! !

!RBExtractMethodAndOccurrences methodsFor: 'transforming' stamp: ''!
transform 
	| newExtractedSelector |
	newExtractedSelector := self extractMethod.
	self findOccurrencesOf: newExtractedSelector.! !

!RBExtractMethodAndOccurrences methodsFor: 'transforming' stamp: ''!
findImplementorOf: aSelector
	(class directlyDefinesMethod: aSelector) ifTrue: [ ^ true ].
	class superclass ifNotNil: [
		class := class superclass.
		^ self findImplementorOf: aSelector.
	].
	^ false! !

!RBExtractMethodAndOccurrences methodsFor: 'preconditions' stamp: ''!
preconditions

	^ self emptyCondition! !

!RBExtractMethodAndOccurrences methodsFor: 'transforming' stamp: ''!
findOccurrencesOf: aSelector

	| refactoring |
	(self findImplementorOf: aSelector)
		ifTrue: [ 
			refactoring := self findOccurrencesClass
				               model: self model
				               find: aSelector
				               of: class
				               inWholeHierarchy: self shouldSearchInHierarchy.
			self performCompositeRefactoring: refactoring ]
		ifFalse: [ 
			self refactoringFailure:
				aSelector , ' is not a valid selector name.' ]! !

!RBExtractMethodAndOccurrences methodsFor: 'transforming' stamp: ''!
findOccurrencesClass

	^ RBFindAndReplaceRefactoring! !

!RBExtractMethodAndOccurrences methodsFor: 'transforming' stamp: ''!
extractMethod

	| refactoring |
	refactoring := self extractMethodClass
		               model: self model
		               extract: extractionInterval
		               from: selector
		               in: class.
	self performCompositeRefactoring: refactoring.
	^ refactoring newExtractedSelector! !

!RBExtractMethodAndOccurrences methodsFor: 'transforming' stamp: ''!
extractMethodClass

	^ RBExtractMethodRefactoring! !

!RBExtractMethodAndOccurrences methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' extract: '.
	extractionInterval storeOn: aStream.
	aStream
		nextPutAll: ' from: #';
		nextPutAll: selector;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBExtractMethodAndOccurrences methodsFor: 'instance creation' stamp: ''!
extract: anInterval from: aSelector in: aClass 
	class := self classObjectFor: aClass.
	selector := aSelector.
	extractionInterval := anInterval! !

!RBExtractMethodAndOccurrences class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk extract: anInterval from: aSelector in: aClass 
	^ self new
		model: aRBSmalltalk;
		extract: anInterval
			from: aSelector
			in: aClass;
		yourself! !

!RBExtractMethodAndOccurrences class methodsFor: 'instance creation' stamp: ''!
extract: anInterval from: aSelector in: aClass 
	^self new
		extract: anInterval
		from: aSelector
		in: aClass! !

!RBExtractMethodAndOccurrencesParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractSimpleMethodAndOcurrences
	|class refactoring|
	class := model classNamed: #MyClassA.
	refactoring := self createRefactoringWithModel: model
		andArguments: { (282 to: 302) . #myMethod . class }.
	self setupSearchInAllHierarchyFor: refactoring toReturn: true.
	self setupMethodNameFor: refactoring toReturn: #extractedMethod.
	self executeRefactoring: refactoring.
	self assert: (class parseTreeFor: #extractedMethod) equals: (self parseMethod: 'extractedMethod
	^ currentChar isLetter.').
	self assert: (class parseTreeFor: #myMethod) equals: (self parseMethod: 'myMethod

	| token |
	token := (String new: 100) writeStream.
	[ self extractedMethod ] whileTrue: [ 
		token nextPut: currentChar.
		self methodWithArg: self extractedMethod.
		self bar ].
	self extractedMethod.
	$3 isLetter.
	self extractedMethod.
	token := self extractedMethod.
	token := self extractedMethod example.
	^ token contents').
	class := model classNamed: #MyClassB.
	self assert: (class parseTreeFor: #exampleMethod) equals: (self parseMethod: 'exampleMethod

	^ self extractedMethod not').
	class := model classNamed: #MyClassC.
	self assert: (class parseTreeFor: #methodWithArg:) equals: (self parseMethod: 'methodWithArg: anArg

	(self extractedMethod and: [ anArg isDecimal ]) ifTrue: [ ^ self ].
	^ nil')! !

!RBExtractMethodAndOccurrencesParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractMethodWithTwoArgsAndOcurrences
	|class refactoring|
	class := model classNamed: #MyClassA.
	refactoring := self createRefactoringWithModel: model
		andArguments: { (114 to: 231) . #displayName . class }.
	self setupSearchInAllHierarchyFor: refactoring toReturn: true.
	self setupMethodNameFor: refactoring toReturn: #stringArg:streamArg:.
	self executeRefactoring: refactoring.
	self assert: (class parseTreeFor: #stringArg:streamArg:) equals: (self parseMethod: 'stringArg: string streamArg: nameStream

	nameStream
		nextPutAll: string;
		nextPutAll: '' (''.
	self problemCount printOn: nameStream.
	nameStream nextPut: $)').
	self assert: (class parseTreeFor: #displayName) equals: (self parseMethod: 'displayName

	| nameStream string |
	string := self name.
	nameStream := WriteStream on: (String new: 64).
	self stringArg: string streamArg: nameStream.
	^ nameStream contents').
	class := model classNamed: #MyClassB.
	self assert: (class parseTreeFor: #anotherMethod) equals: (self parseMethod: 'anotherMethod

	| aStream |
	aStream := WriteStream on: (String new: 128).
	self stringArg: ''dfgdf'' streamArg: aStream').! !

!RBExtractMethodAndOccurrencesParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #extract:from:in:! !

!RBExtractMethodAndOccurrencesParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadInterval
	|class|
	class := model classNamed: #MyClassA.
	self shouldFail: (self createRefactoringWithModel: model
		andArguments: { (127 to: 136) . #myMethod . class })! !

!RBExtractMethodAndOccurrencesParametrizedTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	model := self extractMethodTestData.! !

!RBExtractMethodAndOccurrencesParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBExtractMethodAndOccurrences };
		yourself! !

!RBExtractMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractMethodAtEndOfMethodThatNeedsReturn
	| refactoring class |
	refactoring := self createRefactoringWithArguments: {(52 to: 133) . #openEditor . RBLintRuleTestData }.
	self setupMethodNameFor: refactoring toReturn: #foo:.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBLintRuleTestData.

	self assert: (class parseTreeFor: #openEditor) equals: (self parseMethod: 'openEditor
	| rules |
	rules := self failedRules.
	^self foo: rules').
	self assert: (class parseTreeFor: #foo:) equals: (self parseMethod: 'foo: rules
	rules isEmpty ifTrue: [^self].
	rules size == 1 ifTrue: [^rules first viewResults]')! !

!RBExtractMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractMethodThatMovesTemporaryVariable
	| refactoring class |
	refactoring := self createRefactoringWithArguments: { (22 to: 280) . #superSends . RBTransformationRuleTestData }.
	self setupMethodNameFor: refactoring toReturn: #foo1.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBTransformationRuleTestData.

	self assert: (class parseTreeFor: #superSends) equals: (self parseMethod: 'superSends
	| rule |
	rule := self foo1.
	self rewriteUsing: rule').
	self assert: (class parseTreeFor: #foo1) equals: (self parseMethod: 'foo1 | 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')! !

!RBExtractMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testValidateRenameParameters
	| refactoring |
	refactoring := self createRefactoringWithModel: model
		andArguments: { (78 to: 197) . #displayName . RBLintRuleTestData }.
	self setupMethodNameFor: refactoring toReturn: #foo:.
	refactoring parameterMap: (Dictionary new at: #nameStream put: #nameStream; yourself ).
	"Fail when use instance variables as new parameters"
	self should: [ refactoring validateRenameOf: #nameStream to: #name ] raise: RBRefactoringError.	
	self should: [refactoring validateRenameOf: #nameStream to: #foo1] raise: RBRefactoringError.
	"Fail when use class variables as new parameters"
	self should: [refactoring validateRenameOf: #nameStream to: #Foo1] raise: RBRefactoringError.
	"Fail when use temporary variables as new parameters"! !

!RBExtractMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractMethodThatNeedsTemporaryVariable
	| refactoring class |
	refactoring := self createRefactoringWithArguments: { (78 to: 197) . #displayName . RBLintRuleTestData }.
	self setupMethodNameFor: refactoring toReturn: #foo:.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBLintRuleTestData.

	self assert: (class parseTreeFor: #displayName) equals: (self parseMethod: 'displayName
	| nameStream |
	nameStream := WriteStream on: (String new: 64).
	self foo: nameStream.
	^nameStream contents').

	self assert: (class parseTreeFor: #foo:) equals: (self parseMethod: 'foo: nameStream 	nameStream nextPutAll: self name;
		nextPutAll: '' (''.
	self problemCount printOn: nameStream.
	nameStream nextPut: $).')! !

!RBExtractMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExtractFailure
	self shouldFail: (self createRefactoringWithArguments:
		{ (80 to: 269) . #subclassOf:overrides: . RBBasicLintRuleTestData class }).
	self shouldFail: (self createRefactoringWithArguments:
		{ (53 to: 56) . #subclassOf:overrides: . RBBasicLintRuleTestData class }).
	self shouldFail: (self createRefactoringWithArguments:
		{ (77 to: 222) . #subclassResponsibilityNotDefined . RBBasicLintRuleTestData class })! !

!RBExtractMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testModelExtractMethodWithTemporariesSelected
	| class refactoring |
	model := RBClassModelFactory rbNamespace new.
	class := model classNamed: self class name.
	class compile: 'foo [| temp | temp := 5. temp * temp] value'
		classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model
		andArguments: { (6 to: 36) . #foo . class }.
	self setupMethodNameFor: refactoring toReturn: #foobar.
	self executeRefactoring: refactoring.
	self assert: (class parseTreeFor: #foo) 
			equals: (self parseMethod: 'foo [self foobar] value').
	self assert: (class parseTreeFor: #foobar) 
			equals: (self parseMethod: 'foobar |temp | temp := 5. ^temp * temp')! !

!RBExtractMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #extract:from:in:! !

!RBExtractMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadInterval
	self shouldFail: (self createRefactoringWithArguments:
		{ (24 to: 30) . #testMethod . RBRefactoryTestDataApp }).
	self shouldFail: (self createRefactoringWithArguments:
		{ (80 to: 147) . #subclassOf:overrides: . RBBasicLintRuleTestData class })! !

!RBExtractMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantSelector
	self shouldFail: (self createRefactoringWithArguments: 
		{ (10 to: 20) . #checkClass1: . RBBasicLintRuleTestData })! !

!RBExtractMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractMethodThatNeedsArgument
	| refactoring class |
	refactoring := self createRefactoringWithArguments: { (145 to: 343) . #checkMethod: . RBTransformationRuleTestData }.
	self setupMethodNameFor: refactoring toReturn: #foo:.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBTransformationRuleTestData.

	self assert: (class parseTreeFor: #checkMethod:) equals: (self parseMethod: 'checkMethod: aSmalllintContext 
	class := aSmalllintContext selectedClass.
	(rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: 
			[self foo: aSmalllintContext]').
	self assert: (class parseTreeFor: #foo:) equals: (self parseMethod: 'foo: aSmalllintContext (RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false)
				ifFalse: 
					[builder compile: rewriteRule tree printString
						in: class
						classified: aSmalllintContext protocols]')! !

!RBExtractMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractWithRenamingOfParameters
	| refactoring class |
	refactoring := self createRefactoringWithArguments: { (78 to: 197) . #displayName . RBLintRuleTestData }.
	self setupMethodNameFor: refactoring toReturn: #foo:.
	refactoring
		parameterMap:
			(Array with: ((RBArgumentName name: #nameStream) newName: #newParameter)).
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBLintRuleTestData.

	self
		assert: (class parseTreeFor: #displayName)
		equals:
			(self
				parseMethod:
					'displayName
	| nameStream |
	nameStream := WriteStream on: (String new: 64).
	self foo: nameStream.
	^nameStream contents').
	"Extracted method with renamed parameters"
	self
		assert: (class parseTreeFor: #foo:)
		equals:
			(self
				parseMethod:
					'foo: newParameter 	newParameter nextPutAll: self name;
		nextPutAll: '' (''.
	self problemCount printOn: newParameter.
	newParameter nextPut: $).')! !

!RBExtractMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testModelExtractMethodWithTemporaryAssigned
	| class refactoring |
	model := RBClassModelFactory 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 := self createRefactoringWithModel: model
		andArguments: { (26 to: 102) . #foo . class }.
	self setupMethodNameFor: refactoring toReturn: #foobar.
	self executeRefactoring: refactoring.
	self assert: (class parseTreeFor: #foo) 
			equals: (self parseMethod: 'foo | temp | temp := self foobar. ^temp * temp').
	self 
		assert: ((class parseTreeFor: #foobar) = (self 
						parseMethod: 'foobar | bar temp | bar := 5. temp := bar * bar. Transcript show: temp printString; cr. ^temp.')) |
				((class parseTreeFor: #foobar) = (self 
						parseMethod: 'foobar | temp bar | bar := 5. temp := bar * bar. Transcript show: temp printString; cr. ^temp.'))! !

!RBExtractMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractMethodToSuperclass
	| refactoring class |
	refactoring := self createRefactoringWithArguments: { (145 to: 343) . #checkMethod: . RBTransformationRuleTestData }.
	self setupMethodNameFor: refactoring toReturn: #foo:.
	self setupExtractionClassFor: refactoring toReturn: RBFooLintRuleTestData. 
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBTransformationRuleTestData.

	self assert: (class parseTreeFor: #checkMethod:) equals: (self parseMethod: 'checkMethod: aSmalllintContext 
	class := aSmalllintContext selectedClass.
	(rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: 
			[self foo: aSmalllintContext]').
	
	class := refactoring model classNamed: #RBFooLintRuleTestData.
	self assert: (class parseTreeFor: #foo:) equals: (self parseMethod: 'foo: aSmalllintContext (RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false)
				ifFalse: 
					[builder compile: rewriteRule tree printString
						in: class
						classified: aSmalllintContext protocols]')! !

!RBExtractMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBExtractMethodRefactoring };
		yourself! !

!RBExtractMethodRefactoring commentStamp: ''!
I am a refactoring for creating a method from a code fragment.

You can select an interval of some code in a method and call this refactoring to create a new method implementing that code and replace the code by calling this method instead. 
The new method needs to have as many arguments as the number of (temp)variables, the code refers to.

The preconditions are quite complex. The code needs to be parseable valid code. !
!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
remainingTemporaries
	| temps |
	temps := modifiedParseTree allDefinedVariables asSet.
	extractedParseTree allDefinedVariables 
		do: [:each | temps remove: each ifAbsent: []].
	^temps! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
renameAllParameters
	self parameterMap do: [ :each | 
			self renameParameterWith: each name to: each newName ]! !

!RBExtractMethodRefactoring methodsFor: 'accessing' stamp: ''!
extractedParseTree
	^ extractedParseTree! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
checkReturn
	needsReturn := self placeholderNode isUsed.
	extractedParseTree containsReturn ifFalse: [^self].
	extractedParseTree lastIsReturn ifTrue: [^self].
	(modifiedParseTree isLast: self placeholderNode) 
		ifFalse: 
			[self refactoringError: 'Couldn''t extract code since it contains a return.'].
	self checkSelfReturns! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
requestExtractionClass 
	^ (self options at: #extractionClass ifAbsent: [ [:ref | class ]]) value: self! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
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 := self parseTreeRewriterClass 
				replace: self methodDelimiter
				with: varName , ' := ' , self methodDelimiter
				in: modifiedParseTree! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
getNewMethodName
	| newSelector methodName newMethodName |
	methodName := RBMethodName new.
	methodName arguments: parameters.
	
	[newMethodName := self requestMethodNameFor: methodName.
	newMethodName ifNil: [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.
	newMethodName renameMap ifNotEmpty: [parameterMap := newMethodName renameMap].
	^newSelector asSymbol! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
nameNewMethod: aSymbol
	| args newSend |
	newExtractedSelector := aSymbol .
	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 := String
		streamContents: [ :str | 
			str nextPutAll: 'self '.
			aSymbol keywords
				with: parameters
				do: [ :key :arg | 
					str
						nextPutAll: key asString;
						nextPut: $ ;
						nextPutAll: arg asString;
						nextPut: $  ] ].
	modifiedParseTree := RBParseTreeRewriter replace: self methodDelimiter with: newSend in: modifiedParseTree.
	self parameterMap do: [ :e |
	(self parseTreeRewriterClass rename: e newName to: e name) executeTree: modifiedParseTree ]! !

!RBExtractMethodRefactoring methodsFor: 'accessing' stamp: ''!
parameterMap: aDictionary
	parameterMap := aDictionary ! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
updateTemporariesInExtractedMethodFor: assigned 
	"Add temporaries in extract method"
	assigned do: [:each | extractedParseTree body addTemporaryNamed: each]! !

!RBExtractMethodRefactoring methodsFor: 'renaming' stamp: ''!
validateRenameOf: oldName to: newName
	self validateRenameNode: extractedParseTree withOldName: oldName toWithName: newName ! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
methodDelimiter
	^'#''place.holder.for.method'''! !

!RBExtractMethodRefactoring methodsFor: 'renaming' stamp: ''!
validateRenameNode: aParseTree withOldName: oldName toWithName: newName 
	|conditions block|
	conditions := ((RBCondition isValidInstanceVariableName: newName for: class)
		& (RBCondition definesSelector: selector in: class)
		& (RBCondition definesInstanceVariable: newName in: class) not 
		& (RBCondition definesClassVariable: newName in: class) not).
	conditions check
		ifFalse: [ block := conditions errorBlock.
			block
				ifNotNil: [ self refactoringError: conditions errorString with: block ]
				ifNil: [ self refactoringError: conditions errorString ] ].
	(self parameterMap values includes: newName) ifTrue: [
		self refactoringError: newName asString , ' is already defined as parameter' ].
	(aParseTree whoDefines: newName)
		ifNotNil: [ self refactoringError: newName asString , ' is already defined' ].
	(aParseTree allDefinedVariables includes: newName)
		ifTrue: [ self refactoringError: newName asString , ' is already defined' ]! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
existingSelector
	"Try to find an existing method instead of creating a new one"

	^ self requestExistingSelector
		ifNil: [ self selectorsToSearch
				detect: [ :each | self isMethodEquivalentTo: each ]
				ifNone: [ nil ] ]! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
requestExistingSelector 
	^ [(self options at: #existingSelector) value: self]
			on: Exception 
			do: [ :e | nil ]! !

!RBExtractMethodRefactoring methodsFor: 'renaming' stamp: ''!
renameParameterWith: oldName to: newName
	self renameNode: extractedParseTree withOldName: oldName toWithName: newName.
	! !

!RBExtractMethodRefactoring methodsFor: 'initialization' stamp: ''!
extract: anInterval from: aSelector in: aClass 
	class := self classObjectFor: aClass.
	selector := aSelector.
	extractionInterval := anInterval! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
compileExtractedMethod

	| cls |
	self renameAllParameters.
	cls := self classObjectFor: self requestExtractionClass.
	^ cls
		  compile: extractedParseTree newSource
		  withAttributesFrom: (class methodFor: selector)! !

!RBExtractMethodRefactoring methodsFor: 'accessing' stamp: ''!
method 
	^ class realClass >> selector! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
checkAssignments: variableNames 
	| node outsideVars removeAssigned |
	removeAssigned := variableNames copy.
	node := self placeholderNode.
	outsideVars := variableNames 
				select: [:each | (node whoDefines: each) references: each].
	outsideVars size == 1 
		ifTrue: [self checkSingleAssignment: outsideVars asArray first].
	outsideVars size > 1 
		ifTrue: 
			[self refactoringError: 'Cannot extract assignment without all references.'].
	removeAssigned removeAll: outsideVars.
	(RBReadBeforeWrittenTester readBeforeWritten: removeAssigned
		in: extractedParseTree) ifNotEmpty: 
			[self refactoringError: 'Cannot extract assignment if read before written.'].
	removeAssigned do: [:each | (node whoDefines: each) removeTemporaryNamed: each].
	self updateTemporariesInExtractedMethodFor: variableNames! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform

	| existingSelector |
	existingSelector := self existingSelector.
	self nameNewMethod: (existingSelector
			 ifNil: [ newExtractedSelector ifNil: [ self getNewMethodName ] ]
			 ifNotNil: [ existingSelector ]).
	existingSelector ifNil: [ self compileExtractedMethod ].
	class compileTree: modifiedParseTree! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
getExtractedSource
	| source |
	source := class sourceCodeFor: selector.
	((extractionInterval first between: 1 and: (self startLimit: source size)) 
		and: [extractionInterval last between: 1 and: source size]) 
			ifFalse: [self refactoringFailure: 'Invalid interval'].
	^source copyFrom: extractionInterval first to: extractionInterval last! !

!RBExtractMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class) 
		& (RBCondition withBlock: 
					[self extractMethod.
					self checkSpecialExtractions.
					self checkReturn.
					needsReturn ifTrue: [extractedParseTree addReturn].
					self checkTemporaries.
					true])! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
checkSelfReturns
	| searcher |
	searcher := self parseTreeSearcher.
	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: ''!
selectorsToSearch
	^ class allSelectors! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
isMethodEquivalentTo: aSelector 
	
	selector == aSelector ifTrue: [^false].
	
	aSelector numArgs ~~ parameters size ifTrue: [^false].
	
	(self isParseTreeEquivalentTo: aSelector) ifFalse: [^false].
	self reorderParametersToMatch: aSelector.
	^true! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
checkTemporaries
	| temps accesses assigned |
	temps := self remainingTemporaries.
	accesses := temps select: [:each | extractedParseTree references: each].
	assigned := accesses select: [:each | extractedParseTree assigns: each].
	assigned ifNotEmpty: [self checkAssignments: assigned].
	^parameters := (accesses asOrderedCollection)
				removeAll: assigned;
				yourself! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
checkSpecialExtractions
	| node |
	node := self placeholderNode parent.
	node ifNil: [^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' stamp: ''!
isParseTreeEquivalentTo: aSelector 
	| tree definingClass |
	definingClass := class whoDefinesMethod: aSelector.
	tree := definingClass parseTreeFor: aSelector.
	tree ifNil: [^false].
	tree isPrimitive ifTrue: [^false].
	needsReturn ifFalse: [ tree := self removeReturnsOf: tree ].
	(tree body equalTo: extractedParseTree body
		exceptForVariables: (tree arguments collect: [:each | each name])) 
			ifFalse: [^false].
	(definingClass = class or: 
			[(tree superMessages anySatisfy: 
					[:each | 
					(class superclass whichClassIncludesSelector: aSelector) 
						~= (definingClass superclass whichClassIncludesSelector: each)]) not]) 
		ifFalse: [^false].
	^self shouldUseExistingMethod: aSelector! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
parameters: anOrderedCollection
	parameters := anOrderedCollection ! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
extractMethod
	| parseTree isSequence extractCode subtree newCode errorMessage |
	extractCode := self getExtractedSource.
	extractedParseTree := self parserClass
		parseExpression: extractCode
		onError: [ :string :pos :parser | 
			errorMessage := string.
			parser parseErrorNode: string ].
	extractedParseTree
		ifNil: [ self refactoringFailure: 'Invalid source to extract' ].
	extractedParseTree isFaulty
		ifTrue: [ self
				refactoringFailure: 'Invalid source to extract - ' , errorMessage ].
	(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
		ifNotEmpty: [ extractedParseTree body temporaries: #() ].
	extractedParseTree source: extractCode.
	parseTree := class parseTreeFor: selector.
	parseTree
		ifNil: [ self refactoringFailure: 'Could not parse ' , selector printString ].
	subtree := isSequence
		ifTrue: [ self parseTreeSearcherClass
				treeMatchingStatements: extractedParseTree body formattedCode
				in: parseTree ]
		ifFalse:
			[ self parseTreeSearcherClass treeMatching: extractCode in: parseTree ].
	subtree
		ifNil: [ self refactoringFailure: 'Could not extract code from method' ].
	newCode := self methodDelimiter.
	isSequence
		ifTrue: [ | stmts |
			stmts := extractedParseTree body statements.
			stmts
				ifNotEmpty: [ 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: [ self parseTreeRewriterClass
				replaceStatements: subtree formattedCode
				with: newCode
				in: parseTree
				onInterval: extractionInterval ]
		ifFalse: [ self parseTreeRewriterClass
				replace: subtree formattedCode
				with: newCode
				in: parseTree
				onInterval: extractionInterval ]! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
newExtractedSelector
	^ newExtractedSelector! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
placeholderNode
	| node |
	node := self parseTreeSearcherClass
		treeMatching: self methodDelimiter
		in: modifiedParseTree.
	node ifNil: [ self refactoringFailure: 'Cannot extract code' ].
	^ node! !

!RBExtractMethodRefactoring methodsFor: 'accessing' stamp: ''!
parameterMap
	^ parameterMap ifNil: [ parameterMap := { } ]! !

!RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''!
reorderParametersToMatch: aSelector 
	| tree dictionary |
	tree := class parseTreeFor: aSelector.
	needsReturn ifFalse: [ tree := self removeReturnsOf: tree ].
	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: ''!
startLimit: aNumber
	^ aNumber ! !

!RBExtractMethodRefactoring methodsFor: 'accessing' stamp: ''!
targetClass 
	^ class! !

!RBExtractMethodRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' extract: '.
	extractionInterval storeOn: aStream.
	aStream
		nextPutAll: ' from: #';
		nextPutAll: selector;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBExtractMethodRefactoring methodsFor: 'renaming' stamp: ''!
renameNode: aParseTree withOldName: oldName toWithName: newName 
	(self parseTreeRewriterClass rename: oldName to: newName) executeTree: aParseTree! !

!RBExtractMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk extract: anInterval from: aSelector in: aClass 
	^ self new
		model: aRBSmalltalk;
		extract: anInterval
			from: aSelector
			in: aClass;
		yourself! !

!RBExtractMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
extract: anInterval from: aSelector in: aClass 
	^ self new
		extract: anInterval
		from: aSelector
		in: aClass! !

!RBExtractMethodToComponentParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractMethodAtEndOfMethodThatNeedsReturn
	| refactoring class selectorsSize |
	refactoring := self createRefactoringWithArguments: { (52 to: 133) . #openEditor . RBLintRuleTestData }.
	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: #RBLintRuleTestData.
	selectorsSize := class selectors size.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].

	self
		assert: (class parseTreeFor: #openEditor)
		equals:
			(self
				parseMethod:
					'openEditor
								| rules |
								rules := self failedRules.
								^rules foo: self').
	self
		assert: ((refactoring model classNamed: #Collection) parseTreeFor: #foo:)
		equals:
			(self
				parseMethod:
					'foo: asdf
								self isEmpty ifTrue: [^asdf].
								self size == 1 ifTrue: [^self first viewResults].
								^asdf').
	self assert: class selectors size equals: selectorsSize! !

!RBExtractMethodToComponentParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExtractFailure
	self shouldFail: (self createRefactoringWithArguments:
		{(80 to: 269) . #subclassOf:overrides: . RBBasicLintRuleTestData class }).
	self shouldFail: (self createRefactoringWithArguments:
		{ (53 to: 56) . #subclassOf:overrides: . RBBasicLintRuleTestData class }).
	self shouldFail: (self createRefactoringWithArguments:
		{ (77 to: 222) . #subclassResponsibilityNotDefined . RBBasicLintRuleTestData class })! !

!RBExtractMethodToComponentParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #extract:from:in:! !

!RBExtractMethodToComponentParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadInterval
	self shouldFail: (self createRefactoringWithArguments:
		{ (24 to: 30) . #testMethod . RBRefactoryTestDataApp }).
	self shouldFail: (self createRefactoringWithArguments:
		{ (80 to: 147) . #subclassOf:overrides: . RBBasicLintRuleTestData class })! !

!RBExtractMethodToComponentParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantSelector
	self shouldFail: (self createRefactoringWithArguments:  
		{ (10 to: 20) . #checkClass1: . RBBasicLintRuleTestData })! !

!RBExtractMethodToComponentParametrizedTest methodsFor: 'tests' stamp: ''!
testMoveWithoutSelfReference
	| refactoring class selectorsSize |
	refactoring := self createRefactoringWithArguments: { (118 to: 286) . #copyDictionary: . 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:) equals: (self parseMethod: 'copyDictionary: aDictionary ^aDictionary copyWithAssociations').
	self
		assert: ((refactoring model classNamed: #Dictionary) parseTreeFor: #copyWithAssociations)
		equals:
			(self
				parseMethod:
					'copyWithAssociations 
							| newDictionary |
							newDictionary := Dictionary new: self size.
							self
								keysAndValuesDo: [:key :value | newDictionary at: key put: value].
							^newDictionary').
	self assert: class selectors size equals: selectorsSize! !

!RBExtractMethodToComponentParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBExtractMethodToComponentRefactoring };
		yourself! !

!RBExtractMethodToComponentRefactoring commentStamp: ''!
I am a refactoring for extracting code fragments to a new method. 

Similar to `RBExtractMethodRefactoring`, but you can choose to which component (instance or agument variable) the new method is added. 
As such, the new method arguments will include an additional argument for the sender.
Based on the instance variable you chosed for this method I will guess the class where to add this method, but you can change this class or add more classes.
!
!RBExtractMethodToComponentRefactoring methodsFor: 'transforming' stamp: ''!
inlineForwarder
	| refactoring |
	refactoring := RBInlineAllSendersRefactoring 
				model: self model
				sendersOf: extractedMethodSelector
				in: class.
	refactoring setOption: #inlineExpression toUse: [:ref :string | true].
	self performCompositeRefactoring: refactoring! !

!RBExtractMethodToComponentRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self
		extractMethod;
		moveMethod;
		inlineForwarder! !

!RBExtractMethodToComponentRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ self emptyCondition! !

!RBExtractMethodToComponentRefactoring methodsFor: 'transforming' stamp: ''!
extractMethod
	| refactoring |
	refactoring := RBExtractMethodRefactoring 
				model: self model
				extract: extractionInterval
				from: selector
				in: class.
	refactoring setOption: #methodName
		toUse: 
			[:methodName :ref | 
			extractedMethodSelector := self 
						uniqueMethodNameFor: methodName arguments size.
			methodName
				selector: extractedMethodSelector;
				yourself].
	self performCompositeRefactoring: refactoring! !

!RBExtractMethodToComponentRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' extract: '.
	extractionInterval storeOn: aStream.
	aStream
		nextPutAll: ' from: #';
		nextPutAll: selector;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBExtractMethodToComponentRefactoring methodsFor: 'initialization' stamp: ''!
extract: anInterval from: aSelector in: aClass 
	class := self classObjectFor: aClass.
	selector := aSelector.
	extractionInterval := anInterval! !

!RBExtractMethodToComponentRefactoring methodsFor: 'transforming' stamp: ''!
moveMethod

	| variable refactoring |

	variable := self selectVariableToMoveMethodTo: extractedMethodSelector class: class.
	variable ifNil: [ self refactoringFailure: 'Did not extract method' ].
	refactoring := RBMoveMethodRefactoring
		model: self model
		selector: extractedMethodSelector
		class: class
		variable: variable.
	self performCompositeRefactoring: refactoring! !

!RBExtractMethodToComponentRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk extract: anInterval from: aSelector in: aClass 
	^ self new
		model: aRBSmalltalk;
		extract: anInterval
			from: aSelector
			in: aClass;
		yourself! !

!RBExtractMethodToComponentRefactoring class methodsFor: 'instance creation' stamp: ''!
extract: anInterval from: aSelector in: aClass 
	^ self new
		extract: anInterval
		from: aSelector
		in: aClass! !

!RBExtractMethodTransformation commentStamp: ''!
Creates a method from a code fragment. Temporary variables and arguments are automatically calculated by the transformation.

If the name of the new method is not provided (i.e., nil), it prompts a dialog window so the developer provides a valid method name. In this new implementation, it is possible to add or remove arguments in the new extracted message.
Similarly, if the number of arguments in the new method provided by the developer is higher than the number of arguments as calculated by the transformation, it prompts a dialog window so the developer selects which values must be passed as arguments.

Usage:
transformation := (RBExtractMethodTransformation
	extract: '(RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false)
		ifFalse: [builder
					compile: rewriteRule tree printString
					in: class
					classified: aSmalllintContext protocols]'
	from: #checkMethod:
	to: #foo:
	in: #RBTransformationRuleTest)
	transform.
(ChangesBrowser changes: transformation model changes changes) open!
!RBExtractMethodTransformation methodsFor: 'querying' stamp: ''!
calculateTree

	^ parseTree ifNil: [ parseTree := self definingMethod ]! !

!RBExtractMethodTransformation methodsFor: 'querying' stamp: ''!
calculateSubtree

	^ subtree ifNil: [ 
		subtree := self calculateTree ifNotNil: [ parseTree extractSubtreeWith: sourceCode ] ]! !

!RBExtractMethodTransformation methodsFor: 'requesting' stamp: ''!
shouldUseExistingMethod: aSelector 

	^(self options at: #useExistingMethod) value: self value: aSelector! !

!RBExtractMethodTransformation methodsFor: 'querying' stamp: ''!
calculateIfReturnIsNeeded

	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: '^self' do: [:aNode :answer | answer];
		matches: '^`@anything' do: [:aNode :answer | true].
	^ (searcher executeTree: subtree initialAnswer: false)! !

!RBExtractMethodTransformation methodsFor: 'querying' stamp: ''!
calculateNewArgumentsIn: aMethodName

	aMethodName arguments size > arguments size ifTrue: [ 
		| selection |
		selection := RBMethodArgumentsSelector
			openOn: aMethodName arguments copy
			and: (newMethod body allChildren
					select: #isLiteralNode
					thenCollect: [ :e | e value storeString ])
			in: newMethod.
			
		newMethod := selection newTree.
		^ selection argumentsAndValues ].
	^ Dictionary new! !

!RBExtractMethodTransformation methodsFor: 'api' stamp: ''!
extract: aString from: aSelector to: aNewSelector in: aClassName

	class := aClassName.
	selector := aSelector.
	newSelector := aNewSelector.
	sourceCode := aString! !

!RBExtractMethodTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	| aSubtree |
	aSubtree := self calculateSubtree.
	
	^ (RBCondition withBlock: [ 
		aSubtree ifNil: [ self refactoringError: 'Cannot extract code.' ]. true ])
		"subtree containsReturn
		ifTrue: [ self refactoringError: 'Cannot extract code because it contains a return.' ]."
		& (RBCondition withBlock: [
			aSubtree parent isCascade ifTrue: [ 
				self refactoringError: 'Cannot extract code in a cascaded message' ]. true])
		& (RBCondition withBlock: [
			| tempVariables |
			tempVariables := self calculateTemporaries.
			(RBReadBeforeWrittenTester readBeforeWritten: tempVariables in: aSubtree) ifNotEmpty: [
				self refactoringError: 'Cannot extract temporaries if they are read before written.' ]. true ])
		& (RBCondition withBlock: [
			self calculateAssignments size > 1 ifTrue: [ 
				self refactoringError: 'Cannot extract two or more assignments to temporaries without also extracting all the references.' ]. true ])
		& (RBCondition withBlock: [
			| assignmentCollection |
			assignmentCollection := self calculateAssignments.
			assignmentCollection ifNotEmpty: [ 
			((RBReadBeforeWrittenTester isVariable: assignmentCollection first
				readBeforeWrittenIn: aSubtree) 
				or: [aSubtree containsReturn])
				ifTrue: [ self refactoringError: ('Cannot extract assignment to <1s> without also extracting all the references.' expandMacrosWith: assignments asString)] ]. true ])
		& (RBCondition withBlock: [	
			| searchSpace |
			searchSpace := (self class
				allMethodsInHierarchyOf: self definingClass)
				reject: [ :m | m selector = selector ].
			
			(self parseTreeSearcherClass whichMethodIn: searchSpace matches: aSubtree)
				ifNotEmpty: [ :opportunities | 
					existingSelector := opportunities anyOne.
					(self shouldUseExistingMethod: existingSelector selector)
					ifFalse: [ existingSelector := nil ].
					true ]
				ifEmpty: [ true ] ])! !

!RBExtractMethodTransformation methodsFor: 'executing' stamp: ''!
newMethodName

	| methodName newAttempt |
	newAttempt := newSelector isNil.
	
	methodName := RBMethodName new.
	methodName arguments: arguments.
	newSelector ifNotNil: [ methodName selector: newSelector ].
	
	[ newAttempt ] whileTrue: [ 
		methodName := (RBMethodNameEditor openOn: methodName) methodName.
		methodName
			ifNil: [ "self inform: 'Please provide a name for the method.'.
						methodName := RBMethodName new arguments: arguments" newAttempt := false ]
			ifNotNil: [ :newMethodName |
				newSelector := newMethodName selector.
				newAttempt := newSelector isNil.
				
				"it's a valid selector"
				(newSelector isString and: [newSelector isValidSelector])
					ifFalse: [ self inform: newSelector asString, ' is not a valid selector.'.
								  newSelector := nil ].
					
				"already exists in class"
				(self definingClass directlyDefinesLocalMethod: newSelector)
					ifTrue: [ self inform: newSelector, ' is already defined in ', class asString.
								 newSelector := nil ] ] ].

	^ methodName! !

!RBExtractMethodTransformation methodsFor: 'querying' stamp: ''!
calculateArguments
	"returns a collection of variable that should be passed as arguments"

	| allVariables accesses assigned |
	allVariables := parseTree allDefinedVariables difference: subtree allDefinedVariables.
	
	accesses := allVariables select: [ :each | subtree references: each ].
	assigned := allVariables select: [ :each | subtree assigns: each ].
	
	^ accesses asOrderedCollection difference: assigned.
	! !

!RBExtractMethodTransformation methodsFor: 'querying' stamp: ''!
calculateAssignments
	"checks how many variables in the subtree are assigned to values."

	^ assignments ifNil: [ 
		| sequenceNode whoDefinesTemp |
		sequenceNode := (parseTree allChildren select: #isSequence) last.
	
		assignments := temporaries select: [ :temp | 
			whoDefinesTemp := (sequenceNode whoDefines: temp).
			whoDefinesTemp statements anySatisfy: [ :statement |
				(statement references: temp)
				and: [ (subtree allChildren includes: statement) not ] ] ] ]! !

!RBExtractMethodTransformation methodsFor: 'executing' stamp: ''!
generateNewMethodWith: aMethodName

	| args newMethodNode |
	args := aMethodName arguments
		collect: [ :p | RBVariableNode named: p ].
	
	newMethodNode := RBMethodNode
							selector: aMethodName selector
							arguments: args asArray
							body: (subtree isSequence 
								ifTrue: [ subtree ]
								ifFalse: [ RBSequenceNode
									temporaries: #()
									statements: (OrderedCollection with: subtree)]).						
	temporaries do: [:each | newMethodNode body addTemporaryNamed: each].
	
	((parseTree parentOfSubtree: subtree) uses: subtree)
		ifTrue: [ newMethodNode addReturn ].
	
	assignments size = 1 ifTrue: [
		newMethodNode addNode: 
			(RBReturnNode value: 
			(RBVariableNode named: assignments first asString)) ].
	
	^ newMethodNode.! !

!RBExtractMethodTransformation methodsFor: 'querying' stamp: ''!
calculateTemporaries
	"returns a collection of variables that should be defined inside the method"

	^ temporaries ifNil: [
		| allVariables accesses |
		allVariables := parseTree allDefinedVariables difference: subtree allDefinedVariables.
		accesses := allVariables select: [ :each | subtree references: each ].
	
		temporaries := accesses select: [ :each | subtree assigns: each ] ]! !

!RBExtractMethodTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' extract: '''.
	sourceCode storeOn: aStream.
	aStream
		nextPutAll: ''' from: #';
		nextPutAll: selector asString;
		nextPutAll: ' to: #';
		nextPutAll: newSelector asString;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBExtractMethodTransformation methodsFor: 'executing' stamp: ''!
messageSendWith: aMethodName and: newArguments needsReturn: aBoolean

	^ String streamContents: [ :string |
		aBoolean ifTrue: [ string nextPutAll: '^ ' ].
			
		assignments size = 1
			ifTrue: [ string
				nextPutAll: assignments first asString;
				nextPutAll: ' := ' ].
		
		string nextPutAll: 'self '.
		aMethodName arguments
			ifEmpty: [ string nextPutAll: aMethodName selector asString ] 
			ifNotEmpty: [ 
				(aMethodName selector keywords size = aMethodName arguments size)
					ifTrue: [ aMethodName selector keywords
								with: aMethodName arguments 
								do: [ :key :arg | 
									string nextPutAll: key asString; nextPut: $ .
									(newArguments includesKey: arg asString)
										ifTrue: [ string nextPutAll: (newArguments at: arg asString) ]
										ifFalse: [ string nextPutAll: arg asString ].
								string nextPut: $ ] ] ] ]! !

!RBExtractMethodTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	subtree := self calculateSubtree.
	
	existingSelector ifNotNil: [ 
		^ OrderedCollection with: (self parseTreeRewriterClass 
			replaceCode: subtree
			byMessageSendTo: existingSelector
			in: (self definingClass methodFor: self calculateTree selector))	
	]
	ifNil: [
	^ (parseTree isNil or: [ subtree isNil ])
		ifTrue: [ OrderedCollection new ]
		ifFalse: [ 
			| tempsToRemove |
			arguments := self calculateArguments.
			temporaries := self calculateTemporaries.
			assignments := self calculateAssignments.
			tempsToRemove := self calculateTemporariesToRemove.
			
			assignments size > 1
			ifTrue: [ OrderedCollection new ]
			ifFalse: [ 
				| newMethodName newArguments messageSend needsReturn |
				newMethodName := self newMethodName.
				newMethodName ifNil: [ ^ OrderedCollection new ].
				
				needsReturn := self calculateIfReturnIsNeeded.
				newMethod := self generateNewMethodWith: newMethodName.
				newArguments := self calculateNewArgumentsIn: newMethodName.
				messageSend := self messageSendWith: newMethodName 
									and: newArguments needsReturn: needsReturn.
										
				OrderedCollection new
					add: (RBAddMethodTransformation
							model: self model
							sourceCode: newMethod newSource
							in: class
							withProtocols: {Protocol unclassified});
					add: (RBReplaceSubtreeTransformation
							model: self model
							replace: sourceCode
							to: messageSend
							inMethod: selector
							inClass: class);
					addAll: (tempsToRemove collect: [ :temporary |
							RBRemoveTemporaryVariableTransformation
							model: self model
							variable: temporary
							inMethod: selector
							inClass: class ]);
					yourself ] ] ]! !

!RBExtractMethodTransformation methodsFor: 'querying' stamp: ''!
calculateTemporariesToRemove
	"returns a collection of variables that should be removed from the original method"

	| newParseTree |
	newParseTree := parseTree copy removeSubtree: subtree.
	^ newParseTree allDefinedVariables
		reject: [ :var | newParseTree references: var ]! !

!RBExtractMethodTransformation class methodsFor: 'utilities' stamp: ''!
allMethodsInHierarchyOf: aRBClass

	^ ((aRBClass
		withAllSuperclassesUntil: Object)
		flatCollect: [ :class | class allMethods collect: [:each | each method] ])
		reject: #isNil! !

!RBExtractMethodTransformation class methodsFor: 'api' stamp: ''!
extract: aString from: aSelector to: aNewSelector in: aClass

	^ self new
		extract: aString
		from: aSelector
		to: aNewSelector
		in: aClass;
		yourself! !

!RBExtractMethodTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel extract: aString from: aSelector to: aNewSelector in: aClass

	^ self new
		model: aRBModel;
		extract: aString
		from: aSelector
		to: aNewSelector
		in: aClass;
		yourself! !

!RBExtractMethodTransformationTest methodsFor: 'tests' stamp: ''!
testExtractWithoutUseExistingMethodRefactoring

	| transformation class |
	transformation := (RBExtractMethodTransformation
		extract: 'rewriteRule tree printString'
		from: #checkMethod:
		to: #bar
		in: #RBTransformationRuleTestData).
	transformation setOption: #useExistingMethod toUse: [ :re :sel | false ].
	transformation asRefactoring transform.
	self assert: transformation model changes changes size equals: 2.
	
	class := transformation model classNamed: #RBTransformationRuleTestData.
	self assert: (class parseTreeFor: #checkMethod:) 
		  equals: (self parseMethod: 'checkMethod: aSmalllintContext
	class := aSmalllintContext selectedClass.
	(rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: [ 
		(RecursiveSelfRule
			 executeTree: rewriteRule tree
			 initialAnswer: false) ifFalse: [ 
			builder
				compile: self bar
				in: class
				classified: aSmalllintContext protocols ] ]').	
	self assert: (class parseTreeFor: #bar)
		equals: (self parseMethod: 'bar
		rewriteRule tree printString').
	self assert: (class directlyDefinesMethod: #bar)! !

!RBExtractMethodTransformationTest methodsFor: 'tests' stamp: ''!
testWithTemporariesSelected

	| class refactoring |
	model := RBNamespace new.
	class := model classNamed: self class name.
	class compile: 'foo [| temp | temp := 5. temp * temp] value'
		classified: #(#accessing).
	
	refactoring := (RBExtractMethodTransformation
		model: model
		extract: '| temp | temp := 5. temp * temp'
		from: #foo
		to: #foobar
		in: class)
		asRefactoring transform. 
	
	self assert: refactoring model changes changes size equals: 4.
	self assert: (class parseTreeFor: #foo) 
		  equals: (self parseMethod: 'foo [self foobar] value').
	self assert: (class parseTreeFor: #foobar) 
		  equals: (self parseMethod: 'foobar |temp | temp := 5. ^temp * temp')! !

!RBExtractMethodTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| transformation class |
	transformation := (RBExtractMethodTransformation
		extract: '(RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false)
			ifFalse: [builder
						compile: rewriteRule tree printString
						in: class
						classified: aSmalllintContext protocols]'
		from: #checkMethod:
		to: #foo:
		in: #RBTransformationRuleTestData)
		asRefactoring transform.
		
	self assert: transformation model changes changes size equals: 2.
	
	class := transformation model classNamed: #RBTransformationRuleTestData.
	self assert: (class parseTreeFor: #checkMethod:) 
		  equals: (self parseMethod: 'checkMethod: aSmalllintContext 
			class := aSmalllintContext selectedClass.
			(rewriteRule executeTree: aSmalllintContext parseTree)
				ifTrue: [self foo: aSmalllintContext]').	
	self assert: (class parseTreeFor: #foo:)
		  equals: (self parseMethod: 'foo: aSmalllintContext 
			(RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false)
				ifFalse: [ builder
							compile: rewriteRule tree printString
							in: class
							classified: aSmalllintContext protocols ]')! !

!RBExtractMethodTransformationTest methodsFor: 'tests' stamp: ''!
testWithTemporaryVariable

	| refactoring class |
	refactoring := (RBExtractMethodTransformation
		extract: (self
			sourceCodeAt: (22 to: 280)
			forMethod: #superSends in: RBTransformationRuleTestData)
		from: #superSends
		to: #foo1 in: #RBTransformationRuleTestData)
		asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 2.
	
	class := refactoring model classNamed: #RBTransformationRuleTestData.
	self assert: (class parseTreeFor: #superSends)
		  equals: (self parseMethod: 'superSends
				| rule |
				rule := self foo1.
				self rewriteUsing: rule').
	self assert: (class parseTreeFor: #foo1)
		  equals: (self parseMethod: 'foo1 | 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')! !

!RBExtractMethodTransformationTest methodsFor: 'tests' stamp: ''!
testWithTemporaryVariable2

	| refactoring class |
	refactoring := (RBExtractMethodTransformation
		extract: (self sourceCodeAt: (78 to: 197)
					forMethod: #displayName in: RBDummyLintRuleTest)
		from: #displayName
		to: #foo:
		in: #RBDummyLintRuleTest)
		asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 2.

	class := refactoring model classNamed: #RBDummyLintRuleTest.
	self assert: (class parseTreeFor: #displayName)
		  equals: (self parseMethod: 'displayName
					| nameStream |
					nameStream := WriteStream on: (String new: 64).
					self foo: nameStream.
					^nameStream contents').
	self assert: (class parseTreeFor: #foo:)
		  equals: (self parseMethod: 'foo: nameStream
					nameStream nextPutAll: self name;
								nextPutAll: '' (''.
					self problemCount printOn: nameStream.
					nameStream nextPut: $).')! !

!RBExtractMethodTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBAddMethodTransformation
					sourceCode: 'foo
									| temp bar |
									bar := 5.
									temp := bar * bar.
									Transcript show: temp printString; cr.
									^temp * temp'
					in: self changeMock name
					withProtocols: {#accessing})
					transform.
	
	transformation := (RBExtractMethodTransformation 
				model: transformation model
				extract: 'bar := 5.
							temp := bar * bar.
							Transcript show: temp printString; cr'
				from: #foo
				to: #foobar
				in: self changeMock name)
				transform.
	
	self assert: transformation model changes changes size equals: 4.			
	
	class := transformation model classNamed: self changeMock name.		
	self assert: (class parseTreeFor: #foo) 
		  equals: (self parseMethod: 'foo
													| temp |
													temp := self foobar.
													^temp * temp').
	self assert: (class parseTreeFor: #foobar)
		  equals: (self parseMethod: 'foobar
													| temp bar |
													bar := 5.
													temp := bar * bar.
													Transcript show: temp printString; cr.
													^temp.')! !

!RBExtractMethodTransformationTest methodsFor: 'tests - failures' stamp: ''!
testExtractFailure

	self shouldFail: (RBExtractMethodTransformation
			extract: (self sourceCodeAt: (80 to: 269)
						forMethod: #subclassOf:overrides: in: RBBasicLintRuleTestData class)
			from: #subclassOf:overrides:
			to: #foo in: #'RBBasicLintRuleTestData class')
			asRefactoring.
	
	self shouldFail: (RBExtractMethodTransformation
			extract: (self sourceCodeAt: (53 to: 56)
						forMethod: #subclassOf:overrides: in: RBBasicLintRuleTestData class)
			from: #subclassOf:overrides:
			to: #foo in: #'RBBasicLintRuleTestData class')
			asRefactoring.
	
	self shouldFail: (RBExtractMethodTransformation
			extract: (self sourceCodeAt: (77 to: 222)
						forMethod: #subclassResponsibilityNotDefined in: RBBasicLintRuleTestData class)
			from: #subclassResponsibilityNotDefined
			to: #foo in: #'RBBasicLintRuleTestData class')
			asRefactoring! !

!RBExtractMethodTransformationTest methodsFor: 'tests - failures' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBExtractMethodTransformation
			extract: 'bla'
			from: #checkClass1:
			to: #bla
			in: #RBBasicLintRuleTestData)
			asRefactoring! !

!RBExtractMethodTransformationTest methodsFor: 'tests' stamp: ''!
testNeedsReturn

	| refactoring class |
	refactoring := (RBExtractMethodTransformation
						extract: 'rules isEmpty ifTrue: [^self].
						rules size == 1 ifTrue: [^rules first viewResults]' 
						from: #openEditor
						to: #foo: in: #RBDummyLintRuleTest)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 2.
	
	class := refactoring model classNamed: #RBDummyLintRuleTest.
	self assert: (class parseTreeFor: #openEditor)
		  equals: (self parseMethod: 'openEditor
				| rules |
				rules := self failedRules.
				^self foo: rules').
	self assert: (class parseTreeFor: #foo:)
		  equals: (self parseMethod: 'foo: rules
				rules isEmpty ifTrue: [^self].
				rules size == 1 ifTrue: [^rules first viewResults]')! !

!RBExtractMethodTransformationTest methodsFor: 'tests - failures' stamp: ''!
testBadInterval

	self shouldFail: (RBExtractMethodTransformation
							extract: 'whatever'
							from: #testMethod to: #bla
							in: #RBRefactoryTestDataApp)
							asRefactoring.
				
	self shouldFail: (RBExtractMethodTransformation
							extract: (self sourceCodeAt: (80 to: 147)
								forMethod: #subclassOf:overrides: in: RBBasicLintRuleTestData class)
							from: #subclassOf:overrides: to: #bla
							in: #'RBBasicLintRuleTestData class')
							asRefactoring
	! !

!RBExtractMethodTransformationTest methodsFor: 'tests' stamp: ''!
testExtractUsingExistingMethodRefactoring

	| transformation class |
	transformation := (RBExtractMethodTransformation
		extract: 'rewriteRule tree printString'
		from: #checkMethod:
		to: #bar
		in: #RBTransformationRuleTestData).
	transformation setOption: #useExistingMethod toUse: [ :re :sel | true ].
	transformation asRefactoring transform.
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: #RBTransformationRuleTestData.
	self assert: (class parseTreeFor: #checkMethod:) 
		  equals: (self parseMethod: 'checkMethod: aSmalllintContext
	class := aSmalllintContext selectedClass.
	(rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: [ 
		(RecursiveSelfRule
			 executeTree: rewriteRule tree
			 initialAnswer: false) ifFalse: [ 
			builder
				compile: self rewriteRuleAsString
				in: class
				classified: aSmalllintContext protocols ] ]').	
	self deny: (class directlyDefinesMethod: #bar)! !

!RBExtractMethodTransformationTest methodsFor: 'tests' stamp: ''!
testWithArgument

	| refactoring class |
	refactoring := (RBExtractMethodTransformation
		extract: (self sourceCodeAt: (145 to: 343)
					 forMethod: #checkMethod: in: RBTransformationRuleTestData)
		from: #checkMethod:
		to: #foo:
		in: #RBTransformationRuleTestData)
		asRefactoring transform.
		
	self assert: refactoring model changes changes size equals: 2.
		
	class := refactoring model classNamed: #RBTransformationRuleTestData.
	self assert: (class parseTreeFor: #checkMethod:) 
		  equals: (self parseMethod: 'checkMethod: aSmalllintContext 
					class := aSmalllintContext selectedClass.
					(rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: 
						[self foo: aSmalllintContext]').
	self assert: (class parseTreeFor: #foo:) 
		  equals: (self parseMethod: 'foo: aSmalllintContext
					(RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false)
						ifFalse: 
							[builder compile: rewriteRule tree printString
										in: class
										classified: aSmalllintContext protocols]')! !

!RBExtractMethodTransformationTest methodsFor: 'tests' stamp: ''!
testWithTemporaryAssigned

	| class method refactoring |
	model := RBNamespace new.
	class := model classNamed: self class name.
	method := 'foo
			| temp bar |
			bar := 5.
			temp := bar * bar.
			Transcript show: temp printString; cr.
			^temp * temp'.
	class compile: method classified: #(#accessing).
			
	refactoring := (RBExtractMethodTransformation
			model: model
			extract: (method copyFrom: 24 to: 98)
			from: #foo
			to: #foobar
			in: class)
			asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 4.
	self assert: (class parseTreeFor: #foo) 
		  equals: (self parseMethod: 'foo | temp | temp := self foobar. ^temp * temp').
	self assert: (class parseTreeFor: #foobar) 
		  equals: (self parseMethod: 'foobar | temp bar | bar := 5. temp := bar * bar. Transcript show: temp printString; cr. ^temp.')! !

!RBExtractMethodTransformationTest methodsFor: 'private' stamp: ''!
sourceCodeAt: anInterval forMethod: aSelector in: aClass

	^ (aClass sourceCodeAt: aSelector)
		copyFrom: anInterval first to: anInterval last! !

!RBExtractSetUpMethodAndOccurrences commentStamp: ''!
I'm a refactoring to extract a setUp method and then searchs occurrences of it and replaces them.

Example script
--------------
```
(RBExtractSetUpMethodAndOccurrences
	extract: (17 to: 56)
	from: #testExample1
	in: RBTest) execute.
```
Before refactoring:
```
RBDataTest >> testExample1 	
	self someClasses.
	aString := 'Example'.
	self assert: 4 > 5 equals: false.
RBDataTest >> testExample2
	"Example"
	self someClasses.
	aString := 'Example'.
	self assert: true.
	
RBDataTest >> testExample3
	"Example"
	self someClasses.
	"Comment"
	aString := 'Example'.
	self deny: false.
	
RBDataTest >> testExample4
	self assert: true.
	self deny: false.
```
After refactoring:
```
RBDataTest >> setUp "Added setUp"
	super setUp.
	self someClasses.
	aString := 'Example'.

RBDataTest >> testExample1 "removes setUp occurrence"
	self assert: 4 > 5 equals: false
	
RBDataTest >> testExample2
	self assert: true.

RBDataTest >> testExample3
	self deny: false.

RBDataTest >> testExample4 "this method did not change"
	self assert: true.
	self deny: false
```!
!RBExtractSetUpMethodAndOccurrences methodsFor: 'transforming' stamp: ''!
transform 
	self extractMethod.
	self findOccurrencesOf: #setUp! !

!RBExtractSetUpMethodAndOccurrences methodsFor: 'transforming' stamp: ''!
findOccurrencesClass
	^ RBFindAndReplaceSetUpRefactoring! !

!RBExtractSetUpMethodAndOccurrences methodsFor: 'transforming' stamp: ''!
extractMethodClass
	^ RBExtractSetUpMethodRefactoring! !

!RBExtractSetUpMethodAndOccurrencesParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractSimpleMethodAndOcurrences
	|class refactoring|
	refactoring := self createRefactoringWithArguments: { (17 to: 56) . #testExample1 . RBTest }.
	self setupSearchInAllHierarchyFor: refactoring toReturn: true.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBTest.
	self assert: (class parseTreeFor: #setUp) 
		equals: (self parseMethod: 'setUp
		super setUp. self someClasses. aString := ''Example''').
	self assert: (class parseTreeFor: #testExample1) 
		equals: (self parseMethod: 'testExample1 
		self assert: 4 > 5 equals: false').
	self assert: (class parseTreeFor: #testExample2) 
		equals: (self parseMethod: 'testExample2
		self assert: true').
	self assert: (class parseTreeFor: #testExample3) 
		equals: (self parseMethod: 'testExample3
		self deny: false').
	self assert: (class parseTreeFor: #testExample4) 
		equals: (self parseMethod: 'testExample4
		self assert: true.
		self deny: false').! !

!RBExtractSetUpMethodAndOccurrencesParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #extract:from:in:! !

!RBExtractSetUpMethodAndOccurrencesParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadMethodName
	| refactoring |
	refactoring := self createRefactoringWithArguments: { (36 to: 56) . #testExample7 . RBTest }.
	self setupSearchInAllHierarchyFor: refactoring toReturn: true.
	self shouldFail: refactoring.! !

!RBExtractSetUpMethodAndOccurrencesParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadInterval
	| refactoring |
	refactoring := self createRefactoringWithArguments: { (36 to: 56) . #testExample1 . RBTest }.
	self setupSearchInAllHierarchyFor: refactoring toReturn: true.
	self shouldFail: refactoring.! !

!RBExtractSetUpMethodAndOccurrencesParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBExtractSetUpMethodAndOccurrences };
		yourself! !

!RBExtractSetUpMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractSetUpAndConvertTwoTempsToInstVars
	| class refactoring |
	refactoring := self createRefactoringWithArguments: { (36 to: 93) . #testExample1 . RBDataTest }.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBDataTest.
	self assert: (class instanceVariableNames includes: #aString). 
	self assert: (class instanceVariableNames includes: #aNumber). 
	self assert: (class parseTreeFor: #testExample1) equals: (self parseMethod: 'testExample1
	self assert: aString isNotEmpty.
	self deny: (aString , aNumber asString) isEmpty.
	self assert: true').
	self assert: (class parseTreeFor: #testExample2) equals: (self parseMethod: 'testExample2
	aString := ''sa''.
	self someMethod.
	aNumber := 4.
	self assert: aString isNotEmpty.').
	self assert: (class parseTreeFor: #setUp) equals: (self parseMethod: 'setUp
	super setUp.
	aString := ''Some string''.
	self someMethod.
	aNumber := 4')! !

!RBExtractSetUpMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExtractSetUpWhenIsNotFirstsSentences

	self shouldFail: (self createRefactoringWithArguments: 
		{ (63 to: 77) . #testExample1 . RBDataTest })! !

!RBExtractSetUpMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelExistingSetUpMethod
	| class |
	model := RBClassModelFactory rbNamespace new.
	class := model classNamed: #RBDataTest.
	class compile: 'setUp #setUp'
		classified: #(#accessing).
	self shouldFail: ( self createRefactoringWithModel: model
		andArguments: { (14 to: 29) . #testExample . RBDataTest }).! !

!RBExtractSetUpMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractSetUpAndConvertTempsToInstVars
	| class refactoring |
	refactoring := self createRefactoringWithArguments: { (36 to: 77) . #testExample1 . RBDataTest }.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBDataTest.
	self assert: (class instanceVariableNames includes: #aString). 
	self assert: (class parseTreeFor: #testExample1) equals: (self parseMethod: 'testExample1
	| aNumber |
	aNumber := 4.
	self assert: aString isNotEmpty.
	self deny: (aString , aNumber asString) isEmpty.
	self assert: true').
	self assert: (class parseTreeFor: #testExample2) equals: (self parseMethod: 'testExample2
	| aNumber |
	aString := ''sa''.
	self someMethod.
	aNumber := 4.
	self assert: aString isNotEmpty.').
	self assert: (class parseTreeFor: #setUp) equals: (self parseMethod: 'setUp
	super setUp.
	aString := ''Some string''.
	self someMethod.')! !

!RBExtractSetUpMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractSetUp
	| class refactoring |
	refactoring := self createRefactoringWithArguments: { (14 to: 29) . #testExample . RBDataTest }.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBDataTest.

	self assert: (class parseTreeFor: #testExample) equals: (self parseMethod: 'testExample
	self assert: true').
	self assert: (class parseTreeFor: #setUp) equals: (self parseMethod: 'setUp
	super setUp.
	self someMethod')! !

!RBExtractSetUpMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #extract:from:in:! !

!RBExtractSetUpMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadClass
	self shouldFail: (self createRefactoringWithArguments: 
		{ (78 to: 197) . #displayName . RBLintRuleTestData })! !

!RBExtractSetUpMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadInterval
	self shouldFail: (self createRefactoringWithArguments:
		{ (14 to: 35) . #testExample . RBDataTest })! !

!RBExtractSetUpMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBExtractSetUpMethodRefactoring };
		yourself! !

!RBExtractSetUpMethodRefactoring commentStamp: ''!
I am a refactoring for creating a setUp method from a code fragment.

You can select an interval of some code in a test method and call this refactoring to create a setUp method implementing that code and replace the code by nothing. 
The selected class need to be a subclass of TestCase.

The preconditions are quite complex.
	- The code needs to be parseable valid code. 
	- The class must not implement setUp method.
	- Class must inherit from testCase class 
	
Example script
---------------
```
(RBExtractSetUpMethodRefactoring
	extract: (14 to: 29)
	from: #testExample
	in: RBDataTest) execute.
```

Before refactoring:
```
TestCase subclass: #RBDataTest
	instanceVariableNames: ''
	classVariableNames: ''
	package: 'Example'.

RBDataTest >> someMethod
	#someMethod.

RBDataTest >> testExample
	self someMethod.
	self assert: true.
```
After refactoring:
```
RBDataTest >> setUp
	super setUp.
	self someMethod.

RBDataTest >> testExample
	self assert: true.
``` 



!
!RBExtractSetUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform
	| existingSelector |
	existingSelector := self existingSelector.
	self nameNewMethod: #setUp.
	existingSelector ifNil: 
		[ self renameAllParameters.
		extractedParseTree body addNodeFirst: (RBParser parseExpression: 'super setUp').
		class compile: extractedParseTree newSource
			withAttributesFrom: (class methodFor: selector)].
	modifiedParseTree body removeNode: (modifiedParseTree body statements at: 1).
	class compileTree: modifiedParseTree! !

!RBExtractSetUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
checkAssignments: variableNames 
	| node outsideVars removeAssigned |
	removeAssigned := variableNames copy.
	node := self placeholderNode.
	outsideVars := variableNames 
				select: [:each | (node whoDefines: each) references: each].
	outsideVars do: [ :var | self checkSingleAssignment: var ].
	removeAssigned removeAll: outsideVars.
	(RBReadBeforeWrittenTester readBeforeWritten: removeAssigned
		in: extractedParseTree) ifNotEmpty: 
			[self refactoringError: 'Cannot extract assignment if read before written.'].
	removeAssigned do: [:each | (node whoDefines: each) removeTemporaryNamed: each].
	self updateTemporariesInExtractedMethodFor: variableNames! !

!RBExtractSetUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class) &
	(self requestExistingSelector ifNil: [ (RBCondition definesSelector: #setUp in: class) not ]
	ifNotNil: [ self emptyCondition ]) &
	(RBCondition withBlock: [ class allSuperclasses anySatisfy: [ :e | e name = #TestCase ] ])
		& (RBCondition withBlock: 
			[self extractMethod.
			self checkSpecialExtractions.
			self checkReturn.
			needsReturn ifTrue: [extractedParseTree addReturn].
			self checkTemporaries.
			true])! !

!RBExtractSetUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
checkSingleAssignment: varName 

	((RBReadBeforeWrittenTester isVariable: varName
		readBeforeWrittenIn: extractedParseTree) 
			or: [extractedParseTree containsReturn]) 
			ifTrue: 
				[self 
					refactoringError: 'Cannot extract assignments to temporaries without all references'].
	modifiedParseTree body removeTemporaryNamed: varName.
	self performCompositeRefactoring: (RBTemporaryToInstanceVariableRefactoring 
		model: self model
		class: class
		selector: selector
		variable: varName)! !

!RBExtractSetUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
nameNewMethod: aSymbol
	| args |
	args := parameters collect: [ :parm | RBVariableNode named: parm ].
	extractedParseTree renameSelector: aSymbol andArguments: args asArray.
	modifiedParseTree := RBParseTreeRewriter replace: self methodDelimiter with: '#callToSetUp' in: modifiedParseTree.! !

!RBExtractSetUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
startLimit: aNumber
	| node |
	node := class parseTreeFor: selector.
	^ node statements ifEmpty: [ node body start ]
		ifNotEmpty: [ node statements first start ]
	! !

!RBExtractSetUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
updateTemporariesInExtractedMethodFor: variableNames
	! !

!RBExtractSetUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
shouldExtractAssignmentTo: name
	^ true! !

!RBExtractToTemporaryParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractToTemporaryInsideBlock
	| refactoring |
	refactoring := self createRefactoringWithArguments:
		{ (133 to: 141) . 'asdf' . #noMoveDefinition . RBRefactoryTestDataApp }.
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #noMoveDefinition) equals: (self parseMethod: 'noMoveDefinition
	| temp |
	^(self collect: 
			[:each | 
			temp := each printString.
			temp , temp]) 
		select: [:each | | asdf | asdf := each size. temp := asdf + temp]')! !

!RBExtractToTemporaryParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractToTemporaryWithDuplicates
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{ (73 to: 77) . 'temp' . #demoMethodWithDuplicates . RBRefactoryTestDataApp }.
	self executeRefactoring: refactoring.
	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #demoMethodWithDuplicates) equals: (self parseMethod: 'demoMethodWithDuplicates
	| a b result1 result2 answer temp |
	a := 3.
	temp := a + 5.
	b := temp.
	result1 := a + b.
	result2 := temp.
	answer := result1 + result2 + temp.
	^ answer')! !

!RBExtractToTemporaryParametrizedTest methodsFor: 'tests' stamp: ''!
testExtractToTemporaryForLastStatementInBlock
	| refactoring methodName |
	methodName := ('caller', '2') asSymbol.
	refactoring := self createRefactoringWithArguments:
		{ (52 to: 73) . 'temp' . methodName . RBRefactoryTestDataApp }.
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: methodName) equals: (self parseMethod: 'caller2
	^(1 to: 10) inject: 1 into: [:sum :each | | temp | temp := sum * (self foo: each). temp]')! !

!RBExtractToTemporaryParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #extract:to:from:in:! !

!RBExtractToTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadName
	self shouldFail:
		(self createRefactoringWithArguments: 
			{ (14 to: 23) . 'a sdf' . #testMethod . RBRefactoryTestDataApp })! !

!RBExtractToTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadInterval
	self shouldFail:
		(self createRefactoringWithArguments: 
			{ (24 to: 30) . 'asdf' . #testMethod . RBRefactoryTestDataApp }).
	self shouldFail:
		(self createRefactoringWithArguments:
			{ (14 to: 105) . 'asdf' . #testMethod1 . RBRefactoryTestDataApp }).
	self shouldFail:
		(self createRefactoringWithArguments:
			{ (61 to: 101) . 'asdf' . #noMoveDefinition . RBRefactoryTestDataApp })! !

!RBExtractToTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantSelector
	self shouldFail: 
		( self createRefactoringWithArguments:
			{ (14 to: 23) . 'asdf' . #checkClass1: . RBRefactoryTestDataApp })! !

!RBExtractToTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNoValidNameOfTemp
	self shouldFail:
		(self createRefactoringWithArguments: 
			{ (51 to: 60) . 'collection' . #modifiesCollection . RBRefactoryTestDataApp })! !

!RBExtractToTemporaryParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBExtractToTemporaryRefactoring };
		addCase: { #rbClass -> RBExtractToTemporaryTransformation };
		yourself! !

!RBExtractToTemporaryRefactoring commentStamp: ''!
Add a new temporary variable for the value of the selected code. Every place in this method using the same piece of code is replaced by accessing this new temporary variable instead.
As the code is now only evaluated once for initializing the variable value, this refactoring may modify the behavior if the code statements didn't evaluate to the same value on every call.

My preconditions verify that the new temporary name is a valid name and isn't already used (neither a temporary, an instance variable or a class variable).!
!RBExtractToTemporaryRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self
		insertTemporary;
		compileNewMethod! !

!RBExtractToTemporaryRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class) 
		& (RBCondition isValidInstanceVariableName: newVariableName for: class) 
			& (RBCondition withBlock: 
						[self verifySelectedInterval.
						self checkVariableName.
						true])! !

!RBExtractToTemporaryRefactoring methodsFor: 'preconditions' stamp: ''!
verifySelectedInterval
	| selectedParseTree selectedSources |
	selectedSources := self selectedSource.
	selectedParseTree := self parserClass
		parseExpression: selectedSources
		onError: [ :message :position | self refactoringFailure: 'Invalid selection' ].
	selectedParseTree isSequence
		ifTrue: [ self refactoringFailure: 'Cannot assign temp to multiple statements' ]! !

!RBExtractToTemporaryRefactoring methodsFor: 'transforming' stamp: ''!
compileNewMethod
	class compileTree: self parseTree! !

!RBExtractToTemporaryRefactoring methodsFor: 'preconditions' stamp: ''!
checkVariableName
	(class whoDefinesInstanceVariable: newVariableName) ifNotNil: 
			[self refactoringError: ('<1p> defines an instance variable named <2s>' 
						expandMacrosWith: class
						with: newVariableName)].
	(class whoDefinesClassVariable: newVariableName) ifNotNil: 
			[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: 'transforming' stamp: ''!
insertTemporary
	| node statementNode nodeReferences children |
	node := self parseTree whichNodeIsContainedBy: sourceInterval.
	(node notNil and: [ node isValue ])
		ifFalse: [ self refactoringFailure: 'Cannot assign to non-value nodes' ].
	children := self parseTree body allChildren.
	nodeReferences := children select: [ :each | each = node ] thenCollect: [ :each | each ].
	statementNode := node statementNode.
	nodeReferences do: [ :each | each replaceWith: (RBVariableNode named: newVariableName) ].
	statementNode parent
		addNode: (self constructAssignmentFrom: node)
			before:
				(node == statementNode
						ifTrue: [ RBVariableNode named: newVariableName ]
						ifFalse: [ statementNode ]);
		addTemporaryNamed: newVariableName! !

!RBExtractToTemporaryRefactoring methodsFor: 'private - accessing' stamp: ''!
selectedSource

	| source |

	source := class sourceCodeFor: selector.
	source ifNil: [ self refactoringFailure: 'Couldn''t find sources' ].
	( ( sourceInterval first between: 1 and: source size )
		and: [ sourceInterval last between: 1 and: source size ] )
		ifFalse: [ self refactoringFailure: 'Invalid interval' ].
	^ source copyFrom: sourceInterval first to: sourceInterval last! !

!RBExtractToTemporaryRefactoring methodsFor: 'transforming' stamp: ''!
constructAssignmentFrom: aNode 
	| valueNode |
	valueNode := RBVariableNode named: newVariableName.
	^RBAssignmentNode variable: valueNode value: aNode! !

!RBExtractToTemporaryRefactoring methodsFor: 'initialization' stamp: ''!
extract: anInterval to: aString from: aSelector in: aClass 
	class := self classObjectFor: aClass.
	selector := aSelector.
	sourceInterval := anInterval.
	newVariableName := aString! !

!RBExtractToTemporaryRefactoring methodsFor: 'private - accessing' stamp: ''!
parseTree

	parseTree
		ifNil: [ parseTree := class parseTreeFor: selector.
			parseTree ifNil: [ self refactoringFailure: 'Could not parse method' ]
			].
	^ parseTree! !

!RBExtractToTemporaryRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' extract: '.
	sourceInterval storeOn: aStream.
	aStream
		nextPutAll: ' to: ''';
		nextPutAll: newVariableName;
		nextPutAll: ''' from: #';
		nextPutAll: selector;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBExtractToTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk extract: anInterval to: aString from: aSelector in: aClass 
	^ self new
		model: aRBSmalltalk;
		extract: anInterval
			to: aString
			from: aSelector
			in: aClass;
		yourself! !

!RBExtractToTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''!
extract: anInterval to: aString from: aSelector in: aClass 
	^ self new 
		extract: anInterval
		to: aString
		from: aSelector
		in: aClass! !

!RBExtractToTemporaryTransformation commentStamp: ''!
Add a new temporary variable for the value of the selected code. Every place in this method using the same piece of code is replaced by accessing this new temporary variable instead.
As the code is now only evaluated once for initializing the variable value, this refactoring may modify the behavior if the code statements didn't evaluate to the same value on every call.

My preconditions verify that the new temporary name is a valid name and isn't already used (neither a temporary, an instance variable or a class variable).!
!RBExtractToTemporaryTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class) 
		& (RBCondition isValidInstanceVariableName: newVariableName for: class) 
			& (RBCondition withBlock: 
						[self verifySelectedInterval.
						self checkVariableName.
						true])! !

!RBExtractToTemporaryTransformation methodsFor: 'preconditions' stamp: ''!
verifySelectedInterval
	| selectedParseTree selectedSources |
	selectedSources := self selectedSource.
	selectedParseTree := self parserClass
		parseExpression: selectedSources
		onError: [ :message :position | self refactoringFailure: 'Invalid selection' ].
	selectedParseTree isSequence
		ifTrue: [ self refactoringFailure: 'Cannot assign temp to multiple statements' ]! !

!RBExtractToTemporaryTransformation methodsFor: 'preconditions' stamp: ''!
checkVariableName
	(class whoDefinesInstanceVariable: newVariableName) ifNotNil: 
			[self refactoringError: ('<1p> defines an instance variable named <2s>' 
						expandMacrosWith: class
						with: newVariableName)].
	(class whoDefinesClassVariable: newVariableName) ifNotNil: 
			[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)]! !

!RBExtractToTemporaryTransformation methodsFor: 'executing' stamp: ''!
insertTemporary
	^ {RBCustomTransformation 
	model: self model 
	with: [ :rbMode | | node statementNode nodeReferences  |
	node := self nodeContainedBy: sourceInterval.
	nodeReferences := self referencesTo: node.
	statementNode := node statementNode.
	nodeReferences do: [ :each | each replaceWith: (RBVariableNode named: newVariableName) ].
	statementNode parent
		addNode: (self constructAssignmentFrom: node)
			before:
				(node == statementNode
						ifTrue: [ RBVariableNode named: newVariableName ]
						ifFalse: [ statementNode ]);
		addTemporaryNamed: newVariableName.
		class compileTree: self parseTree]}! !

!RBExtractToTemporaryTransformation methodsFor: 'accessing' stamp: ''!
nodeContainedBy: anInterval
	| node |
	node := self parseTree whichNodeIsContainedBy: anInterval.
	(node notNil and: [ node isValue ])
		ifFalse: [ self refactoringFailure: 'Cannot assign to non-value nodes' ].
	^ node! !

!RBExtractToTemporaryTransformation methodsFor: 'accessing' stamp: ''!
referencesTo: aNode
	| children |
	children := self parseTree body allChildren.
	^ children select: [ :each | each = aNode ]! !

!RBExtractToTemporaryTransformation methodsFor: 'transforming' stamp: ''!
constructAssignmentFrom: aNode
	| valueNode |
	valueNode := RBVariableNode named: newVariableName.
	^RBAssignmentNode variable: valueNode value: aNode! !

!RBExtractToTemporaryTransformation methodsFor: 'accessing' stamp: ''!
selectedSource

	| source |

	source := class sourceCodeFor: selector.
	source ifNil: [ 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! !

!RBExtractToTemporaryTransformation methodsFor: 'api' stamp: ''!
extract: anInterval to: aString from: aSelector in: aClass
	class := self model classObjectFor: aClass.
	selector := aSelector.
	sourceInterval := anInterval.
	newVariableName := aString! !

!RBExtractToTemporaryTransformation methodsFor: 'accessing' stamp: ''!
parseTree

	parseTree
		ifNil: [ 
			parseTree := class parseTreeFor: selector.
			parseTree ifNil: [ self refactoringFailure: 'Could not parse method' ]
		].
	^ parseTree! !

!RBExtractToTemporaryTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	^ self insertTemporary! !

!RBExtractToTemporaryTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' extract: ';
		nextPutAll: sourceInterval asString ;
		nextPutAll: ' to: ';
		nextPutAll: newVariableName;
		nextPutAll: ' from: ';
		nextPutAll: selector;
		nextPutAll: ' in: ';
		nextPutAll: class name.
	aStream nextPut: $)! !

!RBExtractToTemporaryTransformation class methodsFor: 'api' stamp: ''!
model: aRBNamespace extract: anInterval to: aString from: aSelector in: aClass
	^ self new
		model: aRBNamespace;
		extract: anInterval
		to: aString
		from: aSelector
		in: aClass;
		yourself! !

!RBExtractToTemporaryTransformation class methodsFor: 'api' stamp: ''!
extract: anInterval to: aString from: aSelector in: aClass
	^ self new 
		extract: anInterval
		to: aString
		from: aSelector
		in: aClass! !

!RBFindAndReplaceParametrizedTest methodsFor: 'tests' stamp: ''!
testFindOcurrencesInHierarchy
	|class refactoring|
	class := model classNamed: #MyClassA.
	class 
		compile: 'simpleMethod
			^ currentChar isLetter'
		classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model
		andArguments: { #simpleMethod . class . true }.
	self executeRefactoring: refactoring.
	self assert: (class parseTreeFor: #myMethod) equals: (self parseMethod: 'myMethod

	| token |
	token := (String new: 100) writeStream.
	[ self simpleMethod ] whileTrue: [ 
		token nextPut: currentChar.
		self methodWithArg: self simpleMethod.
		self bar ].
	self simpleMethod.
	$3 isLetter.
	self simpleMethod.
	token := self simpleMethod.
	token := self simpleMethod example.
	^ token contents').
	class := model classNamed: #MyClassB.
	self assert: (class parseTreeFor: #exampleMethod) equals: (self parseMethod: 'exampleMethod

	^ self simpleMethod not').
	class := model classNamed: #MyClassC.
	self assert: (class parseTreeFor: #methodWithArg:) equals: (self parseMethod: 'methodWithArg: anArg

	(self simpleMethod and: [ anArg isDecimal ]) ifTrue: [ ^ self ].
	^ nil')! !

!RBFindAndReplaceParametrizedTest methodsFor: 'tests' stamp: ''!
testFindOcurrencesWithArgInHierarchy
	|class refactoring|
	class := model classNamed: #MyClassA.
	class 
		compile: 'simpleMethod
			^ currentChar isLetter'
		classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model
		andArguments: { #methodWithArg:andArg: . class . true }.
	self executeRefactoring: refactoring.
	class := model classNamed: #MyClassB.
	self assert: (class parseTreeFor: #dummyMethod) equals: (self parseMethod: 
	'dummyMethod self methodWithArg: 3 andArg: self someMethod')! !

!RBFindAndReplaceParametrizedTest methodsFor: 'failure tests' stamp: ''!
testFindOcurrencesFailureInHierarchy
	|class refactoring|
	class := model classNamed: #MyClassA.
	class 
		compile: 'simpleMethod
			^ currentChar isLetter'
		classified: #(#accessing).
	(model classNamed: #MyClassB) 
		compile: 'simpleMethod
			^ nil'
		classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model
		andArguments: { #simpleMethod . class . true }.
	self shouldFail: refactoring.! !

!RBFindAndReplaceParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadSelector
	|class|
	class := model classNamed: #MyClassA.
	self shouldFail: (self createRefactoringWithModel: model
		andArguments: { #unexitingMethod . class . true })! !

!RBFindAndReplaceParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #find:of:inWholeHierarchy:! !

!RBFindAndReplaceParametrizedTest methodsFor: 'tests' stamp: ''!
testFindOcurrencesInClass
	|class refactoring|
	class := model classNamed: #MyClassA.
	class 
		compile: 'simpleMethod
			^ currentChar isLetter'
		classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model
		andArguments: {#simpleMethod . class . false }.
	self executeRefactoring: refactoring.
	self assert: (class parseTreeFor: #myMethod) equals: (self parseMethod: 'myMethod

	| token |
	token := (String new: 100) writeStream.
	[ self simpleMethod ] whileTrue: [ 
		token nextPut: currentChar.
		self methodWithArg: self simpleMethod.
		self bar ].
	self simpleMethod.
	$3 isLetter.
	self simpleMethod.
	token := self simpleMethod.
	token := self simpleMethod example.
	^ token contents').
	class := model classNamed: #MyClassB.
	self assert: (class parseTreeFor: #exampleMethod) equals: (self parseMethod: 'exampleMethod

	^ currentChar isLetter not').
	class := model classNamed: #MyClassC.
	self assert: (class parseTreeFor: #methodWithArg:) equals: (self parseMethod: 'methodWithArg: anArg

	(currentChar isLetter and: [ anArg isDecimal ]) ifTrue: [ ^ self ].
	^ nil')! !

!RBFindAndReplaceParametrizedTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	model := self extractMethodTestData.! !

!RBFindAndReplaceParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBFindAndReplaceRefactoring };
		yourself! !

!RBFindAndReplacePreviewPresenter commentStamp: ''!
I am a preview of find and replace refactoring (tool). I can select the methods of class (or subclasses) to find occurrences in them. 

EXAMPLES
-------------------------------------------------

RBFindAndReplacePreview method: (RBRefactoring >> #convertMethod:for:using: )

Instance Variables
-------------------------------------------------

changeList:           <TablePresenter> A table to display the possible methods to push down
label:                <LabelPresenter> Title of table
dropList:             <DropListPresenter> A selector to select the search type
selectedRefactorings: <OrderedCollection> A list with elements to search
method:               <CompiledMethod> A method to find occurrences
refactoring:          <RBRefactoring> A subclass of RBRefactoring 

!
!RBFindAndReplacePreviewPresenter methodsFor: 'initialization' stamp: ''!
initializeDropList
	dropList addItemLabeled: 'Current class'
			do: [ method ifNotNil: [|items|
				items := method origin methods select: [:each | each ~= method].
				selectedRefactorings := OrderedCollection newFrom: items.
				changeList columns last evaluated: #selector.
				changeList items: items ]];
			addItemLabeled: 'Current class and subclasses'
			do: [  method ifNotNil: [|items|
				items := method origin allSubclasses.
				selectedRefactorings := items.
				changeList columns last evaluated: #name.
				changeList items: items ]]! !

!RBFindAndReplacePreviewPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	changeList := self newTable.
	label := (self newLabel)label: 'Find in:' .
	dropList := self newDropList.
	selectedRefactorings := OrderedCollection new.
	self initializeDropList.
	self initializeChangeList.
	! !

!RBFindAndReplacePreviewPresenter methodsFor: 'initialization' stamp: ''!
initializeChangeList
	changeList
		addColumn:
			((SpCheckBoxTableColumn title: ' ' evaluated: [ :x | 
				selectedRefactorings includes: x ])
				onActivation: [ :class |  selectedRefactorings add: class ];
				onDeactivation: [ :class | selectedRefactorings remove: class ];
				width: 20;
				yourself);
		addColumn: (SpStringTableColumn title: 'Name' evaluated: #selector);
		beResizable.! !

!RBFindAndReplacePreviewPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aModalPresenter
	aModalPresenter
		addButton: 'Find' do: [ :presenter |
			refactoring listToFindMatches: selectedRefactorings .
			presenter
				beOk;
				close];
		addButton: 'Cancel' do: [ :presenter | 
			presenter
				beCancel;
				close ]! !

!RBFindAndReplacePreviewPresenter methodsFor: 'initialization' stamp: ''!
method: aMethod
	method := aMethod.
	
	selectedRefactorings := OrderedCollection newFrom: 
		(method origin methods select: [:each | each ~= method]).
	changeList items: selectedRefactorings.
	! !

!RBFindAndReplacePreviewPresenter methodsFor: 'initialization' stamp: ''!
refactoring: ref
	refactoring := ref! !

!RBFindAndReplacePreviewPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	super initializePresenter.
	! !

!RBFindAndReplacePreviewPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #label withConstraints: [ :c | c height: self labelHeight ];
		add:
			(SpBoxLayout newLeftToRight
				add: #changeList;
				yourself);
		add: #dropList withConstraints: [ :constraints | constraints height: self toolbarHeight ];
		yourself.! !

!RBFindAndReplacePreviewPresenter class methodsFor: 'specs' stamp: ''!
method: aMethod
	|temp|
	temp := self new method: aMethod.
	^ temp openModalWithSpec! !

!RBFindAndReplacePreviewPresenter class methodsFor: 'specs' stamp: ''!
example
	<script>
	^ (self method: (RBRefactoring >> #convertMethod:for:using: )) ! !

!RBFindAndReplacePreviewPresenter class methodsFor: 'specs' stamp: ''!
title
	^ 'Find and replace'! !

!RBFindAndReplaceRefactoring commentStamp: ''!
I am a refactoring for find occurrences of a method in owner class and in the whole hierarchy if apply.

My precondition verifies that the method exists in specified class, and if occurrences are found in hierarchy this method should not overwritten in hierarchy.

Example script
----------------

```
(RBFindAndReplaceRefactoring 
find: #methodWithArg:andArg: 
of: MyClassA 
inWholeHierarchy: true) execute.
```
Before refactoring:
```
Object subclass: #MyClassA
	instanceVariableNames: ''
	classVariableNames: ''
	category: 'Testing'

MyClassA >> methodWithArg: anArg1 andArg: anArg2
	^ (anArg1 > anArg2) not	

MyClassA subclass: #MyClassB
	instanceVariableNames: ''
	classVariableNames: ''
	category: 'Testing'
	
MyClassB >> someMethod
	^  3
	
MyClassB >> dummyMethod
	(3 > self someMethod) not
```

After refactoring:

```
MyClassB >> dummyMethod 
	self methodWithArg: 3 andArg: self someMethod
```!
!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
argumentsOf: aDictionary
	"Return the arguments values of a method ocurrence"
	
	|args limit|
	limit := self method ast arguments size - 1.
	args := OrderedCollection new.
	0 to: limit do: [ :each |
		args add: 
			(aDictionary at: (aDictionary keys detect: 
				[ :e | (e name asString) =  ('`@argMatch', each asString)])) sourceCode
	 ].
	^ args! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
extractMethodRefactoring
	^ RBExtractMethodRefactoring new
			setOption: #useExistingMethod 
			toUse:  [ :ref :aSelector | 
				true];
			yourself ! !

!RBFindAndReplaceRefactoring methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	occurrences := 0.! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
method
	^ method ifNil: [ method := class methodFor: selector ]! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
methodNode

	^ self method ast copy! !

!RBFindAndReplaceRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	| condition rbMethod |

	rbMethod := class methodFor: selector.
	condition := (RBCondition definesSelector: selector in: class)
	             & (replacesAllHierarchy
			              ifFalse: [ self emptyCondition ]
			              ifTrue: [ 
				              class allSubclasses
					              inject: self emptyCondition
					              into: [ :cond :aClass | 
						              cond
						              &
						              (RBCondition definesSelector: selector in: aClass orIsSimilarTo: rbMethod)
							              not ] ]).
	^ condition! !

!RBFindAndReplaceRefactoring methodsFor: 'preconditions' stamp: ''!
transform
	|classes|
	classes :=replacesAllHierarchy ifFalse: [ { class } ] ifTrue: [ class withAllSubclasses ].
	classes do: [ :cls | (self selectorsFor: cls) do: [ :sel | |rbMethod|
		rbMethod := cls methodFor: sel.
		self findAndReplaceOccurrencesIn: rbMethod] ].
	self inform: occurrences asString, ' occurrences were found and changed.'! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
replaceArgumentsByPattern: sourceCode 
	|newSource|
	newSource := sourceCode copyWithRegex: 'tempMatch*' matchesReplacedWith: '`@tempMatch' .
	newSource := newSource copyWithRegex: 'argMatch*' matchesReplacedWith: '`@argMatch'.
	^ newSource 
	! !

!RBFindAndReplaceRefactoring methodsFor: 'initialization' stamp: ''!
find: aSelector of: aClass inWholeHierarchy: aBoolean
	class := self classObjectFor: aClass.
	selector := aSelector.
	replacesAllHierarchy := aBoolean.! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
findAndReplaceOccurrencesIn: rbMethod 
	self findOccurrencesIn: rbMethod! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
findOccurrencesIn: rbMethod
	|methodNode sourceCode flag |
	flag := false.
	methodNode := rbMethod ast.
	sourceCode := methodNode sourceCode.
	(self nodesOf: methodNode) do: [ :each |
            each first < each last
                ifTrue: [ 
	self matchNodes do: [ :matchNode | matchNode
                      match: (self patternParserClass parseExpression: (sourceCode copyFrom: each first to: each last ))
                      onSuccess: [ :map |
	self extract: ((each first to: each last) -> map) 
	of: rbMethod.
	occurrences := occurrences + 1.
	flag := true. ]
                      onFailure: [  ] .
						flag ifTrue: [ self findOccurrencesIn: (rbMethod modelClass methodFor: rbMethod selector).
							^ self]]]]. 
	methodNode body nodesDo: [ :node |
		self matchNodes do: [ :matchNode | matchNode
                      match: node
                      onSuccess: [ :map |
	self extract: ((node start to: node stop) -> map) 
	of: rbMethod.
	occurrences := occurrences + 1.
	flag := true.]
                      onFailure: [  ] .
						flag ifTrue: [ self findOccurrencesIn: (rbMethod modelClass methodFor: rbMethod selector).
							^ self]]].! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
extract: occurrence of: rbMethod
	[|refactoring |
	refactoring := self extractMethodRefactoring. 
	refactoring model: self model.
	refactoring 	extract: occurrence key from: rbMethod selector in: rbMethod modelClass.
	refactoring setOption: #existingSelector toUse:  [ :ref | 
			ref parameters: (self argumentsOf: occurrence value).
			selector].
	self performCompositeRefactoring: refactoring ] on: Exception do: [ :e | e ]! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
matchNodes

	^ matchNodes ifNil: [ 
		  | visitor node sourceCode |
		  visitor := RBMatchVisitor new.
		  node := self methodNode.
		  node acceptVisitor: visitor.
		  sourceCode := self replaceArgumentsByPattern: node newSource.
		  sourceCode := sourceCode
			                copyFrom: (self startLimitOf: sourceCode) + visitor difference
			                to: sourceCode size.
		  matchNodes := OrderedCollection new.
		  matchNodes add:
			  (self patternParserClass parseExpression: sourceCode).
		  node lastIsReturn ifTrue: [ 
			  node hasMultipleReturns ifFalse: [ 
				  sourceCode := sourceCode copyReplaceAll: '^' with: ''.
				  matchNodes add:
					  (self patternParserClass parseExpression: sourceCode) ] ].
		  matchNodes ]! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
nodesOf: methodNode
	|visitor node|
	visitor := RBCombinatorVisitor new.
	node := methodNode copy.
	node acceptVisitor: visitor.
	^ visitor combinations ! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
patternParserClass
	^ RBPatternParser ! !

!RBFindAndReplaceRefactoring methodsFor: 'accessing' stamp: ''!
startLimitOf: sourceCode
	^ self method ast body statements first start! !

!RBFindAndReplaceRefactoring methodsFor: 'preconditions' stamp: ''!
selectorsFor: cls
	^ cls selectors copyWithout: selector! !

!RBFindAndReplaceRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' find: #';
		nextPutAll: selector;
		nextPutAll: ' of: #';
		nextPutAll: class name;
		nextPutAll: ' inAllHierarchy: '.
	replacesAllHierarchy storeOn: aStream.
	aStream nextPut: $).! !

!RBFindAndReplaceRefactoring class methodsFor: 'instance creation' stamp: ''!
find: aMethod of: aClass inWholeHierarchy: aBoolean
	^ self new 
		find: aMethod 
		of: aClass
		inWholeHierarchy: aBoolean;
		yourself! !

!RBFindAndReplaceRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aModel find: aMethod of: aClass inWholeHierarchy: aBoolean
	^ self new
		model: aModel; 
		find: aMethod 
		of: aClass
		inWholeHierarchy: aBoolean;
		yourself! !

!RBFindAndReplaceSetUpParametrizedTest methodsFor: 'tests' stamp: ''!
testClassDoesNotDefineSetUpMethod
	| refactoring |
	refactoring := self createRefactoringWithArguments: { RBTest . true }.
	self shouldFail: refactoring! !

!RBFindAndReplaceSetUpParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #of:inWholeHierarchy:! !

!RBFindAndReplaceSetUpParametrizedTest methodsFor: 'tests' stamp: ''!
testReplaceSetUp
	| class refactoring |
	refactoring := self createRefactoringWithArguments: { RBTest . true }.
	class := refactoring model classNamed: #RBTest.
	class compile: 'setUp self someClasses. aString := ''Example''.'
		classified: #(#accessing).
	self executeRefactoring: refactoring.
	self assert: (class parseTreeFor: #testExample1) 
		equals: (self parseMethod: 'testExample1 
		self assert: 4 > 5 equals: false').
	self assert: (class parseTreeFor: #testExample2) 
		equals: (self parseMethod: 'testExample2
		self assert: true').
	self assert: (class parseTreeFor: #testExample3) 
		equals: (self parseMethod: 'testExample3
		self deny: false').
	self assert: (class parseTreeFor: #testExample4) 
		equals: (self parseMethod: 'testExample4
		self assert: true.
		self deny: false').! !

!RBFindAndReplaceSetUpParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBFindAndReplaceSetUpRefactoring };
		yourself! !

!RBFindAndReplaceSetUpRefactoring commentStamp: ''!
I am a refactoring for find occurrences of setUp method in owner class and in the whole hierarchy if apply.

My precondition verifies that setUp method exists in specified class, and if occurrences are found in hierarchy this method should not overwritten in hierarchy.

Example script
----------------
```
(RBFindAndReplaceSetUpRefactoring 
	of: RBTest 
	inWholeHierarchy: false) execute.
```
Before refactoring:
```
TestCase subclass: #RBTest
	instanceVariableNames: 'aString'
	classVariableNames: ''
	package: 'Example'
	
RBTest >> setUp
	self someClasses.
	aString := 'Example'.

RBTest >> someClasses.
	"initialize some classes"
	
RBTest >> testExample1 	
	self someClasses.
	aString := 'Example'.
	self assert: 4 > 5 equals: false.
	
RBTest >> testExample2
	"Example"
	self someClasses.
	aString := 'Example'.
	self assert: true.

RBTest >> testExample4
	self assert: true.
	self deny: false
```

After refactoring: 
```
RBTest >> testExample1 
	self assert: 4 > 5 equals: false.

RBTest >> testExample2
	self assert: true

RBTest >> testExample4
	self assert: true.
	self deny: false
```!
!RBFindAndReplaceSetUpRefactoring methodsFor: 'accessing' stamp: ''!
extractMethodRefactoring
	^ RBExtractSetUpMethodRefactoring new
			setOption: #useExistingMethod 
			toUse:  [ :ref :aSelector | 
				true];
			setOption: #extractAssignment 
			toUse:  [ :ref :aSelector | 
				true];
			yourself ! !

!RBFindAndReplaceSetUpRefactoring methodsFor: 'accessing' stamp: ''!
methodNode 
	| node |
	node := super methodNode.
	node body removeNode: (RBParser parseExpression: 'super setUp.').
	^ node! !

!RBFindAndReplaceSetUpRefactoring methodsFor: 'instance creation' stamp: ''!
of: aClass inWholeHierarchy: aBoolean
	class := self classObjectFor: aClass.
	selector := #setUp.
	replacesAllHierarchy := aBoolean.! !

!RBFindAndReplaceSetUpRefactoring methodsFor: 'accessing' stamp: ''!
startLimitOf: sourceCode
	^ ((self parserClass parseMethod: sourceCode) body statements first start)! !

!RBFindAndReplaceSetUpRefactoring methodsFor: 'accessing' stamp: ''!
nodesOf: methodNode
	| combinations limit |
	
	combinations := super nodesOf: methodNode.
	^ combinations ifEmpty: [ combinations ]
		ifNotEmpty: [ limit :=  methodNode body statements first start.
		combinations select: [ :e | e first <= limit ] ]
	! !

!RBFindAndReplaceSetUpRefactoring methodsFor: 'preconditions' stamp: ''!
selectorsFor: cls
	^ (cls selectors select: [:e | e isTestSelector]) copyWithout: selector! !

!RBFindAndReplaceSetUpRefactoring class methodsFor: 'instance creation' stamp: ''!
of: aClass inWholeHierarchy: aBoolean
	^ self new
		of: aClass
		inWholeHierarchy: aBoolean;
		yourself! !

!RBFindAndReplaceSetUpRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aModel of: aClass inWholeHierarchy: aBoolean
	^ self new
		model: aModel;
		of: aClass
		inWholeHierarchy: aBoolean;
		yourself! !

!RBFooDummyLintRuleTest methodsFor: 'as yet unclassified' stamp: ''!
foo
	^ 6! !

!RBFooLintRuleTestData methodsFor: 'as yet unclassified' stamp: ''!
foo
	^ 6! !

!RBFormatterTest commentStamp: ''!
SUnit tests for BISimpleFormatter!
!RBFormatterTest methodsFor: 'tests' stamp: ''!
testParseError
	| inputSource errorNode |
	"parse error nodes should have the faulty code"
	inputSource := ')'.
   errorNode := self parseFaultyExpression: inputSource.
	self assert: errorNode source equals: errorNode formattedCode! !

!RBFormatterTest methodsFor: 'tests' stamp: ''!
testCoreSystem
	#(#Object #Behavior #Boolean #True #False #Integer #SmallInteger #Collection #String)
		do: [ :each | 
			| class |
			class := testingEnvironment classNamed: each.
			self
				formatClass: class;
				formatClass: class class ]! !

!RBFormatterTest methodsFor: 'private' stamp: ''!
formatClass: aClass selector: aSymbol
	| source tree1 tree2 |
	source := aClass sourceCodeAt: aSymbol.
	tree1 := self parserClass parseMethod: source.
	tree2 := self parserClass
		parseMethod: (self formatterClass new format: tree1)
		onError: [ :err :pos | self assert: false ].
	self assert: tree1 equals: tree2! !

!RBFormatterTest methodsFor: 'tests' stamp: ''!
testPreserveLiteralNumberFormat
	| inputSource numbersNode |
	"Literal numbers can be written in different ways, integer, integer with
	radix float, fractional constants. The formatter should not change the
	formatting."
	inputSource := '#( 1 4r33 16r0F 0.02 2e-2 -1 )'.
   numbersNode := self parseExpression: inputSource.
	self assert: numbersNode source equals: numbersNode formattedCode! !

!RBFormatterTest methodsFor: 'private' stamp: ''!
formatClass: aClass
	aClass selectors
		do: [ :each | self formatClass: aClass selector: each ]! !

!RBFormatterTest methodsFor: 'tests' stamp: ''!
testFormatPragmaWithLastIsSymbolArgument
	| inputSource tree outputSource |
	"formatter should not create invalid code by removing whitespace between #= and >"
	inputSource := 'foo  <selector: #= > ^ self'.
	tree := self parseMethod: inputSource.
	outputSource := self formatterClass new format: tree.
	self shouldnt: [self parseMethod: outputSource] raise: SyntaxErrorNotification.
	
	"already worked and still should for non-symbol arguments"
	inputSource := 'foo  <selector: 0 > ^ self'.
	tree := self parseMethod: inputSource.
	outputSource := self formatterClass new format: tree.
	self shouldnt: [self parseMethod: outputSource] raise: SyntaxErrorNotification.
	
	"already worked and should still work for pragmas without arguments"
	inputSource := 'foo  <selector> ^ self'.
	tree := self parseMethod: inputSource.
	outputSource := self formatterClass new format: tree.
	self shouldnt: [self parseMethod: outputSource] raise: SyntaxErrorNotification! !

!RBFormatterTest methodsFor: 'tests' stamp: ''!
testPreserveLiteralArrayFormat
	| inputSource literalArrayNode |
	"symbols within a literal array can omit the # character, if it is used that way,
	the formatter should not add a # character but just use the source form."
	inputSource := '#( #withnumbersign nonumbersign ''string'' )'.
   literalArrayNode := self parseExpression: inputSource.
	self assert: literalArrayNode source equals: literalArrayNode formattedCode! !

!RBFormatterTest methodsFor: 'tests' stamp: ''!
testLiteralDynamicArray
	| source tree1 |
	source := 'foo ^ { ''film'' . ''FILM''} '.
	tree1 := self parseMethod: source.
	self assert: ((self formatterClass new format: tree1) occurrencesOf: $.) equals: 1! !

!RBFormatterTest methodsFor: 'tests' stamp: ''!
testParseError2
	| inputSource errorNode |
	"parse error nodes should have the faulty code"
	inputSource := '( 1 + 2'.
   errorNode := self parseFaultyExpression: inputSource.
	self assert: errorNode source equals: errorNode formattedCode! !

!RBFormatterTest methodsFor: 'private' stamp: ''!
formatterClass
  ^RBSimpleFormatter! !

!RBGenerateEqualHashRefactoring commentStamp: ''!
I am a refactoring for generating `#hash` and `#=` comparing methods.

For example, a Class with three instance methods inst1-inst3

```
RBGenerateEqualHashRefactoring 
	model: RBNamespace new 
	className: ClassS 
	variables: { #inst1 . #inst2 . #inst3 }.
```
will create:
a `#hash` method 

```
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ inst1 hash bitXor: (inst2 hash bitXor: inst3 hash)
```
	
and a `#=` method
```

= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ inst1 = anObject inst1
		and: [ inst2 = anObject inst2 and: [ inst3 = anObject inst3 ] ]
```

and any instvar accessor for the  instance variables used by method `#=`.
!
!RBGenerateEqualHashRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self compileHash.
	self compileEqual! !

!RBGenerateEqualHashRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ variables
		  inject: self emptyCondition
		  into: [ :condition :variable | 
			  condition
			  &
			  (RBCondition definesInstanceVariable: variable in: self theClass) ]! !

!RBGenerateEqualHashRefactoring methodsFor: 'accessing' stamp: ''!
theClass
	^ (self classObjectFor: className) instanceSide! !

!RBGenerateEqualHashRefactoring methodsFor: 'transforming' stamp: ''!
compileEqual
	| method statement comparison |
	method := self parserClass
		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
				ifNil: [ comparison ]
				ifNotNil: [ RBMessageNode
						receiver: comparison
						selector: #and:
						arguments:
							(Array
								with:
									(RBBlockNode
										body: (RBSequenceNode statements: (Array with: statement)))) ] ].
	method
		addNode: statement;
		addReturn.
	self theClass compile: method formattedCode classified: #(comparing)! !

!RBGenerateEqualHashRefactoring methodsFor: 'accessing' stamp: ''!
variables: anArray
	variables := anArray! !

!RBGenerateEqualHashRefactoring methodsFor: 'transforming' stamp: ''!
compileHash
	| method statement hash |
	method := self parserClass
		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
				ifNil: [ hash ]
				ifNotNil: [ RBMessageNode
						receiver: hash
						selector: #bitXor:
						arguments: (Array with: statement) ] ].
	method
		addNode: statement;
		addReturn.
	self theClass compile: method formattedCode classified: #(comparing)! !

!RBGenerateEqualHashRefactoring methodsFor: 'transforming' stamp: ''!
accessorForVariable: aString
	| refactoring |
	refactoring := RBCreateAccessorsForVariableRefactoring
		model: self model
		variable: aString
		class: self theClass
		classVariable: false.
	refactoring createGetterAccessor.
	^ refactoring getterMethod! !

!RBGenerateEqualHashRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aNamespace className: aClass variables: anArray
	^ (self model: aNamespace className: aClass) variables: anArray! !

!RBGenerateEqualHashRefactoring class methodsFor: 'instance creation' stamp: ''!
className: aClass variables: anArray
	^ (self className: aClass) variables: anArray! !

!RBGeneratePrintStringRefactoring commentStamp: ''!
I am a refactoring for generating a printString (printOn: aStream) method. 

You can specify which of my instance variables should be used for generating the printString.

For example: 

```
RBGeneratePrintStringRefactoring 
	model: RBNamespace new 
	className: ClassS 
	variables: { #inst1 . #inst2 . #inst3 }
```
!
!RBGeneratePrintStringRefactoring methodsFor: 'transforming' stamp: ''!
transform
	| method |
	method := self parserClass
		parseMethod:
			'printOn: aStream
		"Append a sequence of characters to aStream that identify the receiver."
		
		super printOn: aStream'.
	variables
		do: [ :each | 
			method body
				addNode:
					(self parserClass
						parseExpression:
							('aStream nextPutAll: '' <1s>: ''; print: <1s>' expandMacrosWith: each)) ].
	self theClass compile: method formattedCode classified: #(printing)! !

!RBGeneratePrintStringRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ variables
		  inject: self emptyCondition
		  into: [ :condition :variable | 
			  condition
			  &
			  (RBCondition definesInstanceVariable: variable in: self theClass) ]! !

!RBGeneratePrintStringRefactoring methodsFor: 'accessing' stamp: ''!
theClass
	^ (self classObjectFor: className) instanceSide! !

!RBGeneratePrintStringRefactoring methodsFor: 'accessing' stamp: ''!
variables: anArray
	variables := anArray! !

!RBGeneratePrintStringRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aNamespace className: aClass variables: anArray
	^ (self model: aNamespace className: aClass) variables: anArray! !

!RBGeneratePrintStringRefactoring class methodsFor: 'instance creation' stamp: ''!
className: aClass variables: anArray
	^ (self className: aClass) variables: anArray! !

!RBGenericNodeVisitor commentStamp: ''!
Visit any RBProgrmNode in the syntax tree and evaluate a generic block!
!RBGenericNodeVisitor methodsFor: 'visiting' stamp: ''!
visitNode: aNode
	super visitNode: aNode.
	self visitBlock value: aNode! !

!RBGenericNodeVisitorTest methodsFor: 'tests' stamp: ''!
testVisitDetectIfNone
	| result tree |
	tree := self parseExpression: 'Object new'.
	result := RBGenericNodeVisitor visit: tree detect: [ :n | n isReturn ] ifNone: [ #none ].
	self assert: result equals: #none! !

!RBGenericNodeVisitorTest methodsFor: 'tests' stamp: ''!
testVisitDetect
	| node tree |
	tree := self parseExpression: 'Object new'.
	node := RBGenericNodeVisitor  visit: tree detect: [ :n | n isMessage ].
	self  assert: node isMessage! !

!RBGenericNodeVisitorTest methodsFor: 'tests' stamp: ''!
testVisitNoneSatisfy
	| result tree |
	tree := self parseExpression: 'Object new'.
	result := RBGenericNodeVisitor visit: tree noneSatisfy: [ :n | n isMessage ].
	self deny: result.
	result := RBGenericNodeVisitor visit: tree noneSatisfy: [ :n | n isReturn ].
	self assert: result! !

!RBGenericNodeVisitorTest methodsFor: 'tests' stamp: ''!
testVisitAnySatisfy
	| result tree |
	tree := self parseExpression: 'Object new'.
	result := RBGenericNodeVisitor visit: tree anySatisfy: [ :n | n isMessage ].
	self assert: result.
	result := RBGenericNodeVisitor visit: tree anySatisfy: [ :n | n isReturn ].
	self deny: result! !

!RBGenericNodeVisitorTest methodsFor: 'tests' stamp: ''!
testVisitSelect
	| result tree |
	tree := self parseExpression: 'Object new'.
	result := RBGenericNodeVisitor visit: tree select: [ :n | n isMessage ].
	self assert: result size equals: 1.
	self assert: result first selector equals: #new! !

!RBIdentifierToken commentStamp: ''!
RBIdentifierToken is the first-class representation of an identifier token (e.g. Class)
!
!RBIdentifierToken methodsFor: 'testing' stamp: ''!
isPatternVariable
	^value first = RBScanner patternVariableCharacter! !

!RBIdentifierToken methodsFor: 'testing' stamp: ''!
isIdentifier
	^true! !

!RBIdentifierToken methodsFor: 'testing' stamp: ''!
isKeywordPattern
	^ self isPatternVariable	and: [ value second = RBScanner keywordPatternCharacter
				and: [ value third ~= RBScanner cascadePatternCharacter ] ]! !

!RBInlineAllMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInlineMethodCanNotUnderstandSelectorInClass
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{ #caller3 .RBRefactoryTestDataApp }.
	self shouldFail: refactoring.! !

!RBInlineAllMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineMethodWithMultipleArgs
	| class |
	model := RBClassModelFactory rbNamespace new.
	class := model classNamed: self class name.
	class
		compile: 'foo: arg1 bar: arg2 ^ arg1 + arg2' classified: #(#accessing);
		compile: 'exampleInline | x | x := 3 + (self foo: a bar: b). ^ (self foo: 5 bar: 7)' 
		classified: #(#accessing).
	self executeRefactoring: (self createRefactoringWithModel: model
		andArguments: { #foo:bar: . class }).
	self assert: (class parseTreeFor: #exampleInline) 
			equals: (self parseMethod: 'exampleInline
	| x |
	x := 3 + (a + b).
	^ 5 + 7').! !

!RBInlineAllMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRecursiveMethod
	| class |
	model := RBClassModelFactory rbNamespace new.
	class := model classNamed: self class name.
	class
		compile: 'foo ^self foo' classified: #(#accessing);
		compile: 'bar ^self foo' classified: #(#accessing).
	self executeRefactoring: (self createRefactoringWithModel: model
		andArguments: { #foo . class }).
	self assert: (class parseTreeFor: #foo) 
			equals: (self parseMethod: 'foo ^self foo').
	self assert: (class parseTreeFor: #bar) 
			equals: (self parseMethod: 'bar ^self foo')! !

!RBInlineAllMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineMethodCalledAsSuper
	| class superclass |
	model := RBClassModelFactory rbNamespace new.
	superclass := model classNamed: self class superclass name.
	superclass compile: 'foo: arg1 bar: arg2 ^ arg1 + arg2' classified: #(#accessing).
	class := model classNamed: self class name.
	class compile: 'foo: arg1 bar: arg2 ^ (super foo: arg1 bar: arg2) - arg1' classified: #(#accessing).
	self executeRefactoring: (self createRefactoringWithModel: model
		andArguments: { #foo:bar: . superclass }).
	self assert: (class parseTreeFor: #foo:bar:) 
			equals: (self parseMethod: 'foo: arg1 bar: arg2 ^ (arg1 + arg2) - arg1')! !

!RBInlineAllMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #sendersOf:in:! !

!RBInlineAllMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineMethodWithMultipleSendersInMethod
	| refactoring methodName |
	methodName := ('caller', '2') asSymbol.
	refactoring := self createRefactoringWithArguments:  
		{ methodName . RBRefactoryTestDataApp }.
	self executeRefactoring: refactoring.
	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineLast) equals: (self 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) equals: (self 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)]')! !

!RBInlineAllMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBInlineAllSendersRefactoring };
		yourself! !

!RBInlineAllSendersRefactoring commentStamp: ''!
I am a refactoring for inlining code of this method.

The call to this method in all other methods of this class is replaced by its implementation. The method itself will be removed.

For example, a method 

```
foo
	^ 'text'.
```	
is called in

```
baz
	| a |
	a := self foo.
	^ self foo.
```	
inlining in all senders replaces the call to method foo, with its code:

```
baz
	| a |
	a := 'text'.
	^ 'text'.
```
!
!RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
inlineSelfSends
	class withAllSubclasses do: 
		[:each | 
			| selectors |
			self initializePatternFor: each.
			pattern ifNotNil: [
			selectors := each localSelectors.
			class = each ifTrue: [ selectors remove: selector ifAbsent: []].
			selectors do: [:sel | self inlineMessagesInClass: each andSelector: sel]]]
	! !

!RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
inlineMessagesInClass: aClass andSelector: aSelector 
	| messagesToInline previousCountOfMessages rbMethod |
	previousCountOfMessages := 4294967295.	"Some really large number > # of initial self sends."
	rbMethod := aClass parseTreeFor: aSelector.
	rbMethod ifNil: [ ^ self ].
	[ messagesToInline := self numberOfSelfSendsIn: (aClass parseTreeFor: aSelector).
	messagesToInline > 0 and: [previousCountOfMessages > messagesToInline]] 
			whileTrue: 
				[| node |
				previousCountOfMessages := messagesToInline.
				node := self selfSendIn: (aClass parseTreeFor: aSelector).
				self onError: 
						[self performCompositeRefactoring: ((RBInlineMethodRefactoring
									model: self model
									inline: node sourceInterval
									inMethod: aSelector
									forClass: aClass) checkOverridden: false).
						numberReplaced := numberReplaced + 1]
					do: [ :e | ]].
	numberNotReplaced := numberNotReplaced + messagesToInline! !

!RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self
		inlineSelfSends;
		removeMethod;
		checkInlinedMethods! !

!RBInlineAllSendersRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^RBCondition canUnderstand: selector in: class! !

!RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
selfSendIn: aTree
	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: pattern
		do: [ :aNode :answer | ^ aNode ].
	^ searcher executeTree: aTree initialAnswer: nil! !

!RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
checkInlinedMethods
	numberReplaced = 0 
		ifTrue: [self inform:  'Could not find any senders to inline into']! !

!RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
removeMethod
	self onError: 
			[self performCompositeRefactoring: (RBRemoveMethodRefactoring 
						model: self model
						removeMethods: (Array with: selector)
						from: class)]
		do: []! !

!RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
numberOfSelfSendsIn: aParseTree
	| search |
	search := self parseTreeSearcher.
	search
		matches: pattern
		do: [ :aNode :answer | answer + 1 ].
	^ search executeTree: aParseTree initialAnswer: 0! !

!RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
messagePattern
	^'self ' , (self buildSelectorString: selector)! !

!RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
initializePatternFor: aClass
	pattern := nil.
	(aClass = class or: [(aClass directlyDefinesMethod: selector) not]) ifTrue: [
		pattern := 'self ' , self selectorString.
		^ self].
	((aClass directlyDefinesMethod: selector) and: 
		[ (aClass firstSuperclassRedefines: selector) = class]) ifTrue: [ 
		pattern := 'super ' , self selectorString ].! !

!RBInlineAllSendersRefactoring methodsFor: 'initialization' stamp: ''!
sendersOf: aSelector in: aClass 
	class := self classObjectFor: aClass.
	selector := aSelector.
	numberReplaced := numberNotReplaced := 0! !

!RBInlineAllSendersRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' sendersOf: #';
		nextPutAll: selector;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
selectorString
	^selectorString ifNil: [ selectorString := self buildSelectorString: selector ]! !

!RBInlineAllSendersRefactoring class methodsFor: 'instance creation' stamp: ''!
sendersOf: aSelector in: aClass 
	^ self new
		sendersOf: aSelector
		in: aClass! !

!RBInlineAllSendersRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk sendersOf: aSelector in: aClass 
	^ self new
		model: aRBSmalltalk;
		sendersOf: aSelector in: aClass;
		yourself! !

!RBInlineMethodFromComponentParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineEmptyComponentMethod
	| refactoring |

	self proceedThroughWarning: 
		[ refactoring := self createRefactoringWithArguments: 
			 { (35 to: 91) . #inlineComponent . 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) 
		equals: (self parseMethod: 'inlineComponent
	| a anObject |
	a := 5.
	anObject := a class.
	anObject superclass.
	anObject hasImmediateInstances.
	^anObject')! !

!RBInlineMethodFromComponentParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInlineMethodFromComponentFailure
	self shouldFail: (self createRefactoringWithArguments:
		{ (50 to: 64) . #inlineFailed . RBRefactoryTestDataApp })! !

!RBInlineMethodFromComponentParametrizedTest methodsFor: 'tests' stamp: ''!
testModelInlineMethodWithSameVariableNames1
	| class refactoring |
	model := RBClassModelFactory 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 := self createRefactoringWithModel: model andArguments:  
				 { (77 to: 112) . #foo . (model classNamed: #Object)}.
			self setupInlineExpressionFor: refactoring toReturn: false.
			self setupImplementorToInlineFor: refactoring toReturn: class.
			self executeRefactoring: refactoring].
	self assert: ((refactoring model classNamed: #Object) parseTreeFor: #foo) 
			equals: (self 
						parseMethod: 'foo | aRectangle temp | aRectangle := 0@0 corner: 1@1. temp := aRectangle. ^aRectangle origin extent: temp extent')! !

!RBInlineMethodFromComponentParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineComponentIntoCascadedMessage
	| refactoring |
	self proceedThroughWarning: 
		[ refactoring := self createRefactoringWithArguments:  
				{(35 to: 79) . #inlineComponent . 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) 
		equals: (self parseMethod: 'inlineComponent
	| a aBehavior |
	a := 5.
	aBehavior := a class.
	aBehavior superclass.
	aBehavior format = 0.
	^aBehavior yourself')! !

!RBInlineMethodFromComponentParametrizedTest methodsFor: 'tests' stamp: ''!
testModelInlineMethodWithSameVariableNames2
	| class refactoring |
	model := RBClassModelFactory 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 := self createRefactoringWithModel: model andArguments:  
				{ (72 to: 84) . #foo . (model classNamed: #Object) }.
			self setupInlineExpressionFor: refactoring toReturn: false.
			self executeRefactoring: refactoring].
	self assert: ((refactoring model classNamed: #Object) parseTreeFor: #foo) 
				equals: (self 
						parseMethod: 'foo | a b c | a := InlineMethodFromComponentTest new. b := 1. c := 2. ^c + b + a')! !

!RBInlineMethodFromComponentParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineComponentMethodMax
	| refactoring |
	self proceedThroughWarning: [ | class |
			refactoring := self createRefactoringWithArguments:
				{ (47 to: 58) . #inlineMax . 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) equals: (self parseMethod: 'inlineMax
								| x y q |
								x := 5.
								y := 10.
								q := x + 1 > y
									ifTrue: [x + 1]
									ifFalse: [y].
								^q')! !

!RBInlineMethodFromComponentParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #inline:inMethod:forClass:! !

!RBInlineMethodFromComponentParametrizedTest methodsFor: 'tests' stamp: ''!
testModelInlineMethodWithSameVariableNames
	| class refactoring |
	model := RBClassModelFactory 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 := self createRefactoringWithModel: model andArguments:  
				{ (72 to: 84) . #foo . (model classNamed: #Object)}.
			self setupInlineExpressionFor: refactoring toReturn: false.
			self executeRefactoring: refactoring].
	self assert: ((refactoring model classNamed: #Object) parseTreeFor: #foo) 
			equals: (self 
						parseMethod: 'foo | a b c | a := InlineMethodFromComponentTest new. b := 1. c := 2. ^a + b + c')! !

!RBInlineMethodFromComponentParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBInlineMethodFromComponentRefactoring };
		yourself! !

!RBInlineMethodFromComponentRefactoring commentStamp: ''!
I am a refactoring for replacing method calls by the method implementation.

Just like `RBInlineMethodRefactoring`,  I replace a message send by the implementation of that  message , but you can provide the component
where this implementation is taken from or choose one if there are move than one implementors.
If the method implementation has some direct variable references, accessor for this variable are created (just as by the generate accessor refactoring).!
!RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''!
addArgumentToSelector: aSymbol 
	^aSymbol isInfix 
		ifTrue: [#value:value:]
		ifFalse: [(aSymbol , 'value:') asSymbol]! !

!RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self abstractVariableReferences.
	self renameSelfReferences.
	super transform! !

!RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''!
abstractVariableReferences
	| refactoring |
	refactoring := RBAbstractVariablesRefactoring 
				model: self model
				abstractVariablesIn: inlineParseTree
				from: self inlineClass
				toAll: (Array with: class).
	self performCompositeRefactoring: refactoring.
	inlineParseTree := refactoring parseTree! !

!RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''!
addSelfReferenceToInlineParseTree
	| variableName rewriter newArguments |
	
	variableName := self newNameForSelf.
	rewriter := self parseTreeRewriterClass 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: ''!
checkSuperMessages
	inlineParseTree superMessages isEmpty 
		ifFalse: 
			[self 
				refactoringError: 'Cannot inline method since it sends a super message']! !

!RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''!
findSelectedMessage

	sourceParseTree := class parseTreeFor: sourceSelector.
	sourceParseTree ifNil: [ self refactoringFailure: 'Could not parse sources' ].
	sourceMessage := sourceParseTree whichNodeIsContainedBy: sourceInterval.
	sourceMessage
		ifNil: [ 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: ''!
inlineClassName

	^ self inlineClass instanceSide name! !

!RBInlineMethodFromComponentRefactoring methodsFor: 'testing' stamp: ''!
isOverridden
	| selector| 
	selector := self inlineSelector.
	self inlineClass allSubclassesDo: [:each | 
		(each directlyDefinesMethod: selector)
			ifTrue: [ ^ true ]].
	^ false! !

!RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''!
addSelfReferenceToSourceMessage
	| newArguments |

	newArguments := sourceMessage arguments asOrderedCollection.
	newArguments addFirst: sourceMessage receiver copy.
	sourceMessage renameSelector: (self addArgumentToSelector: sourceMessage selector) andArguments: newArguments! !

!RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''!
newNameForSelf

	| variableName index originalName nonMetaClass |
	nonMetaClass := self inlineClassName.
	variableName := originalName := (nonMetaClass first isVowel
		                                 ifTrue: [ 'an' ]
		                                 ifFalse: [ 'a' ])
	                                , nonMetaClass.
	index := 1.

	[ 
	variableName := self safeVariableNameBasedOn: variableName.
	inlineParseTree allDefinedVariables includes: variableName ] 
		whileTrue: [ 
			variableName := originalName , index printString.
			index := index + 1 ].
	^ variableName! !

!RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''!
renameSelfReferences
	self addSelfReferenceToSourceMessage.
	self addSelfReferenceToInlineParseTree.! !

!RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''!
inlineClass

	| imps |

	inlineClass ifNotNil: [ ^ inlineClass ].
	imps := ( self model allImplementorsOf: self inlineSelector ) asOrderedCollection.
	imps size = 1
		ifTrue: [ ^ inlineClass := imps first ].
	imps ifEmpty: [ self refactoringFailure: 'Nobody defines a method named ' , self inlineSelector ].
	inlineClass := self requestImplementorToInline: imps.
	inlineClass ifNil: [ self refactoringFailure: 'No implementor selected' ].
	^ inlineClass! !

!RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''!
safeVariableNameBasedOn: aString 
	"Creates an unused variable name containing aString"

	| baseString newString i allTempsInline allTempsSource |
	allTempsInline := inlineParseTree allTemporaryVariables.
	allTempsSource := sourceParseTree allDefinedVariables.
	baseString := aString copy.
	baseString at: 1 put: baseString first asLowercase.
	newString := baseString.
	i := 0.
	
	[(allTempsInline includes: newString) 
		or: [ (allTempsSource includes: newString) 
			or: [class definesInstanceVariable: newString]]] 
			whileTrue: 
				[i := i + 1.
				newString := baseString , i printString].
	^newString! !

!RBInlineMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineMethodForSuperSend
	| refactoring |
	model := self inlineMethodTestData.
	(model classNamed: #RBRenameVariableChange)
		removeMethod: #executeNotifying:.
	refactoring := self createRefactoringWithModel: model andArguments: 
		{ (102 to: 131) . #executeNotifying: . (model classNamed: #RBRenameInstanceVariableChange) }.
	self executeRefactoring: refactoring.

	self 
		assert: ((model classNamed: #RBRenameInstanceVariableChange) 
				parseTreeFor: #executeNotifying:) equals: (self 
							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')! !

!RBInlineMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineRecursiveCascadedMethod
	| refactoring |
	refactoring := self createRefactoringWithArguments:
		{ (33 to: 62) . #inlineMethod . RBRefactoryTestDataApp }.
	
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineMethod) equals: (self parseMethod: 'inlineMethod
									| temp temp1 |
									self foo.
									temp1 := self foo; inlineMethod; bar.
									temp := self bar.
									^temp')! !

!RBInlineMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInlineMethodForSuperSendThatAlsoSendsSuper
	| refactoring |
	model := self inlineMethodTestData.
	refactoring := self createRefactoringWithArguments: 
		{ (102 to: 131) . #executeNotifying: . #RBRenameInstanceVariableChange }.
	self shouldFail: refactoring! !

!RBInlineMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineMethod2
	| refactoring methodName |
	methodName := ('caller', '1') asSymbol.
	refactoring := self createRefactoringWithArguments:
		{ (40 to: 120) .  methodName . RBRefactoryTestDataApp }.
	self setupInlineExpressionFor: refactoring toReturn: false.
	
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: methodName) equals: (self parseMethod: 'caller1 
								| anObject each1 anObject1 | 
								anObject := 5.
								anObject1 := anObject + 1.
								each1 := anObject1 printString.
								Transcript
									show: each1;
									cr.
								[:each | each printString. ^anObject] value: each1')! !

!RBInlineMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testReturn
	self shouldFail: (self createRefactoringWithArguments:
		{ (418 to: 485) . #utilityMethods . RBBasicLintRuleTestData class })! !

!RBInlineMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testModelInlineRecursiveMethod
	| refactoring class |
	class := model classNamed: #Object.
	class compile: 'foo self bar. self foo. self bar' classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model andArguments: 
		{ (15 to: 23) . #foo . class }.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	self assert: (class parseTreeFor: #foo) 
		equals: (self parseMethod: 'foo self bar. self bar. self foo. self bar. self bar')! !

!RBInlineMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineMethod4
	| refactoring |
	refactoring := self createRefactoringWithArguments:
		{ (31 to: 112) . #inlineJunk . RBRefactoryTestDataApp }.
	self setupInlineExpressionFor: refactoring toReturn: false.
	
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineJunk) equals: (self 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]')! !

!RBInlineMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineMethod3
	| refactoring methodName |
	methodName := ('caller', '2') asSymbol.
	refactoring := self createRefactoringWithArguments: 
		{ (58 to: 73) . methodName . RBRefactoryTestDataApp }.
	self setupInlineExpressionFor: refactoring toReturn: false.
	
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: methodName) equals: (self parseMethod: 'caller2
								^(1 to: 10) inject: 1 into: [:sum :each | sum * ((1 to: 10) inject: each into: [:sum1 :each1 | sum1 + each1])]	')! !

!RBInlineMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPrimitive
	self shouldFail: (self createRefactoringWithArguments:
		{ (14 to: 23) . #testMethod . RBRefactoryTestDataApp })! !

!RBInlineMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #inline:inMethod:forClass:! !

!RBInlineMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineMethod5
	| refactoring |
	
	refactoring := self createRefactoringWithArguments:
		{ (53 to: 64) . #inlineLast . RBRefactoryTestDataApp }.
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineLast) equals: (self parseMethod: 'inlineLast
									5 = 3 ifTrue: [^self caller] ifFalse: [^	(1 to: 10) inject: 1 into: [:sum :each | sum * (self foo: each)]]')! !

!RBInlineMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadInterval
	self shouldFail:
		(self createRefactoringWithArguments: { (13 to: 23) . #testMethod . RBRefactoryTestDataApp }).
	self shouldFail:
		(self createRefactoringWithArguments: { (14 to: 17) . #testMethod . RBRefactoryTestDataApp }).
	self shouldFail:
		(self createRefactoringWithArguments: { (24 to: 30) . #testMethod . RBRefactoryTestDataApp }).
	self shouldFail:
		(self createRefactoringWithArguments: { (1 to: 30) . #testMethod . RBRefactoryTestDataApp })! !

!RBInlineMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantSelector
	self shouldFail: (self createRefactoringWithArguments: 
		{ (14 to: 17) . #checkClass1: . RBRefactoryTestDataApp })! !

!RBInlineMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineMethod
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{ (455 to: 504) .#sentNotImplementedInApplication . RBBasicLintRuleTestData class }.
	
	self executeRefactoring: refactoring.

	self assert: ((refactoring model metaclassNamed: #RBBasicLintRuleTestData) parseTreeFor: #sentNotImplementedInApplication) equals: (self 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')! !

!RBInlineMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testOverriden
	self shouldWarn: (self createRefactoringWithArguments:
		{ (15 to: 26) . #failedRules . RBLintRuleTestData })! !

!RBInlineMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineMethod1
	| refactoring |
	refactoring := self createRefactoringWithArguments:
		{ (39 to: 84) . #caller . RBRefactoryTestDataApp }.
	self setupInlineExpressionFor: refactoring toReturn: false.
	
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #caller) equals: (self parseMethod: 'caller 
									| anObject anObject1 | 
									anObject := 5.
									anObject1 := anObject + 1.
									Transcript
										show: anObject1 printString;
										cr.
									^anObject')! !

!RBInlineMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBInlineMethodRefactoring };
		addCase: { #rbClass -> RBInlineMethodTransformation };
		yourself! !

!RBInlineMethodRefactoring commentStamp: ''!
I am a refactoring for replacing method calls by the method implementation.

You can select a message send in a method and refactoring this message send to inline its code.
Any temporary variable used in the original message send is added  into this method and renamed if there are already variables with this name.

My preconditions verify that the inlined method is not a primitive call, the method does not have multiple returns. I'll show a warning if the method is overriden in subclasses.

!
!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
rewriteInlinedTree 
	sourceMessage parent isReturn 
		ifTrue: 
			[(sourceParseTree isLast: sourceMessage parent) 
				ifFalse: [self addSelfReturn]]
		ifFalse: 
			[self
				writeGuardClauses;
				normalizeIfTrues;
				normalizeReturns;
				addSelfReturn]! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
moveComments
	inlineParseTree nodesDo: 
			[:each | 
			each 
				comments: (each comments collect:
							[:aComment | 
							| start source |
							source := sourceParseTree source.
							start := source size + 1.
							source := source 
										, (inlineParseTree source copyFrom: aComment start to: aComment stop).
							sourceParseTree source: source.
							RBComment with: aComment contents at: start])]! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
replaceArguments
	sourceMessage arguments reversed
		with: inlineParseTree arguments reversed
		do: [ :replacement :source | 
			(replacement isImmediateNode or: [ self shouldInlineExpression: replacement newSource ]) 
				ifTrue: [ self replaceArgument: source with: replacement ]
				ifFalse: [ self addTemporary: source assignedTo: replacement ] ]! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
insertInlinedMethod
	| node |

	node := sourceMessage.
	self moveComments.
	node parent isCascade 
		ifTrue: 
			[self rewriteCascadedMessage.
			node := node parent].
	node parent isReturn 
		ifTrue: [node := node parent]
		ifFalse: [inlineParseTree := self removeReturnsOf: inlineParseTree].
	self replaceArguments.
	self inlineSourceReplacing: node.
	sourceParseTree removeDeadCode.
	self removeEmptyIfTrues.
	self removeImmediateBlocks! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
checkSuperMessages

	self inlineClass = class
		ifTrue: [ ^ self ].
	self inlineClass superclass ifNil: [ ^ self ].
	inlineParseTree superMessages
		do: [ :each | 
			( self inlineClass superclass whoDefinesMethod: each ) = ( class superclass whoDefinesMethod: each )
				ifFalse: [ self
						refactoringError:
							( 'Cannot inline method since it sends a super message <1s> that is overriden'
								expandMacrosWith: each )
					]
			]! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
compileMethod

	class compileTree: sourceParseTree! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
findSelectedMessage

	sourceParseTree := class parseTreeFor: sourceSelector.
	sourceParseTree ifNil: [ self refactoringFailure: 'Could not parse sources' ].
	sourceMessage := sourceParseTree whichNodeIsContainedBy: sourceInterval.
	sourceMessage
		ifNil: [ 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 isSelfVariable or: [ sourceMessage receiver isSuperVariable ])
		ifFalse: [ self refactoringError: 'Cannot inline non-self messages' ]! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
normalizeReturns
	| rewriter |
	rewriter := self parseTreeRewriter.
	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: ''!
removeEmptyIfTrues
	| rewriter |
	rewriter := self parseTreeRewriter.
	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: ''!
writeGuardClauses
	| rewriter |
	rewriter := self parseTreeRewriter.
	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: self inlineParseTree] 
		whileTrue: [inlineParseTree := rewriter tree]! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
inlineSourceReplacing: aParseTree
	| statements nodeUnderSequence |
	statements := inlineParseTree body statements.
	(statements size > 1 and: [ aParseTree isEvaluatedFirst not ]) ifTrue: [ 
		self refactoringWarning:
			'To inline this method, we need to move some of its statements before the original message send.<n>This could change the order of execution, which can change the behavior.<n>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 selfNode ]
			 ifFalse: [ statements last ])! !

!RBInlineMethodRefactoring methodsFor: 'accessing' stamp: ''!
inlineParseTree
	^ inlineParseTree! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
addTemporary: sourceNode assignedTo: replacementNode 
	| newName |
	newName := self renameConflictingTemporary: sourceNode name.
	(inlineParseTree body)
		addTemporaryNamed: newName;
		addNodeFirst: (RBAssignmentNode variable: (RBVariableNode named: newName)
					value: replacementNode)! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
renameTemporary: oldName to: newName 
	| rewriter |
	rewriter := self parseTreeRewriter.
	rewriter
		replace: oldName with: newName;
		replaceArgument: oldName with: newName.
	(rewriter executeTree: inlineParseTree) 
		ifTrue: [inlineParseTree := rewriter tree]! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self
		renameConflictingTemporaries;
		insertInlinedMethod;
		compileMethod! !

!RBInlineMethodRefactoring methodsFor: 'testing' stamp: ''!
hasMultipleReturns
	"Do we have multiple returns? If the last statement isn't a return, then we have an implicit return of self."

	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: '^``@object'
		do: [ :aNode :hasAReturn | 
			hasAReturn
				ifTrue: [ ^ true ].
			true ].
	searcher
		executeTree: inlineParseTree
		initialAnswer: inlineParseTree lastIsReturn not.
	^ false! !

!RBInlineMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: sourceSelector in: class) 
		& (RBCondition withBlock: 
					[self findSelectedMessage.
					self checkOverridden ifTrue: [
						self isOverridden 
						ifTrue: 
							[self 
								refactoringWarning: ('<1p>>><2s> is overriden. Do you want to inline it anyway?' 
										expandMacrosWith: self inlineClass
										with: self inlineSelector)] ].
					self parseInlineMethod.
					self isPrimitive 
						ifTrue: [self refactoringError: 'Cannot inline primitives'].
					self checkSuperMessages.
					self rewriteInlinedTree.
					(sourceMessage parent isReturn or: [self hasMultipleReturns not]) 
						ifFalse: 
							[self 
								refactoringError: 'Cannot inline method since it contains multiple returns that cannot be rewritten'].
					true])! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
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).
	inlineParseTree := self removeReturnsOf: inlineParseTree.
	inlineParseTree body 
		addNodes: (messages copyFrom: index + 1 to: messages size).
	inlineParseTree addReturn! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
addSelfReturn
	inlineParseTree addSelfReturn! !

!RBInlineMethodRefactoring methodsFor: 'accessing' stamp: ''!
checkOverridden: aBoolean
	checkOverridden := aBoolean! !

!RBInlineMethodRefactoring methodsFor: 'testing' stamp: ''!
isOverridden
	| selector| 
	selector := self inlineSelector.
	class allSubclassesDo: [:each | 
		(each directlyDefinesMethod: selector)
			ifTrue: [ ^ true ]].
	^ false
	
		! !

!RBInlineMethodRefactoring methodsFor: 'testing' stamp: ''!
isPrimitive
	^inlineParseTree isPrimitive! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
inlineSelector

	sourceMessage ifNil: [ self findSelectedMessage ].
	^ sourceMessage selector! !

!RBInlineMethodRefactoring methodsFor: 'accessing' stamp: ''!
checkOverridden
	^ checkOverridden ifNil: [ checkOverridden := true ]! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
parseInlineMethod

	self inlineClass
		ifNil: [ self
				refactoringFailure:
					( '<1p> or its superclasses don''t contain method <2s>'
						expandMacrosWith: class
						with: self inlineSelector )
			].
	inlineParseTree := self inlineClass parseTreeFor: self inlineSelector.
	inlineParseTree ifNil: [ self refactoringFailure: 'Could not parse sources' ].
	inlineParseTree lastIsReturn
		ifFalse: [ inlineParseTree addSelfReturn ]! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
removeImmediateBlocks
	| rewriter |
	rewriter := self parseTreeRewriter.
	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: ''!
normalizeIfTrues
	| rewriter |
	rewriter := self parseTreeRewriter.
	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: ''!
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: ''!
replaceArgument: sourceNode with: replacementNode 
	| rewriter |
	rewriter := self parseTreeRewriter.
	rewriter replaceTree: sourceNode withTree: replacementNode.
	(rewriter executeTree: inlineParseTree body) 
		ifTrue: [inlineParseTree body: rewriter tree]! !

!RBInlineMethodRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' inline: '.
	sourceInterval storeOn: aStream.
	aStream
		nextPutAll: ' inMethod: #';
		nextPutAll: sourceSelector;
		nextPutAll: ' forClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBInlineMethodRefactoring methodsFor: 'initialization' stamp: ''!
inline: anInterval inMethod: aSelector forClass: aClass 
	sourceSelector := aSelector.
	class := self classObjectFor: aClass.
	sourceInterval := anInterval! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
inlineClass

	^ inlineClass
		ifNil: [ inlineClass := ( sourceMessage receiver name = 'super'
				ifTrue: [ class superclass ]
				ifFalse: [ class ] ) whoDefinesMethod: self inlineSelector
			]
		ifNotNil: [ inlineClass ]! !

!RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''!
renameConflictingTemporaries
	inlineParseTree allDefinedVariables 
		do: [:each | self renameConflictingTemporary: each]! !

!RBInlineMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk inline: anInterval inMethod: aSelector forClass: aClass 
	^ self new
		model: aRBSmalltalk;
		inline: anInterval
			inMethod: aSelector
			forClass: aClass;
		yourself! !

!RBInlineMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
inline: anInterval inMethod: aSelector forClass: aClass 
	^ self new 
		inline: anInterval
		inMethod: aSelector
		forClass: aClass! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
rewriteInlinedTree 
	sourceMessage parent isReturn 
		ifTrue: 
			[(sourceParseTree isLast: sourceMessage parent) 
				ifFalse: [self addSelfReturn]]
		ifFalse: 
			[self
				writeGuardClauses;
				normalizeIfTrues;
				normalizeReturns;
				addSelfReturn]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
moveComments
	inlineParseTree nodesDo: 
			[:each | 
			each 
				comments: (each comments collect:
							[:aComment | 
							| start source |
							source := sourceParseTree source.
							start := source size + 1.
							source := source 
										, (inlineParseTree source copyFrom: aComment start to: aComment stop).
							sourceParseTree source: source.
							RBComment with: aComment contents at: start])]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
replaceArguments
	sourceMessage arguments reversed
		with: inlineParseTree arguments reversed
		do: [ :replacement :source | 
			(replacement isImmediateNode or: [ self shouldInlineExpression: replacement newSource ]) 
				ifTrue: [ self replaceArgument: source with: replacement ]
				ifFalse: [ self addTemporary: source assignedTo: replacement ] ]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
insertInlinedMethod
	| node |

	node := sourceMessage.
	self moveComments.
	node parent isCascade 
		ifTrue: 
			[self rewriteCascadedMessage.
			node := node parent].
	node parent isReturn 
		ifTrue: [node := node parent]
		ifFalse: [inlineParseTree := self removeReturnsOf: inlineParseTree].
	self replaceArguments.
	self inlineSourceReplacing: node.
	sourceParseTree removeDeadCode.
	self removeEmptyIfTrues.
	self removeImmediateBlocks! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
checkSuperMessages

	self inlineClass = class
		ifTrue: [ ^ self ].
	self inlineClass superclass ifNil: [ ^ 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 )
					]
			]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
compileMethod

	class compileTree: sourceParseTree! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
findSelectedMessage

	sourceParseTree := class parseTreeFor: sourceSelector.
	sourceParseTree ifNil: [ self refactoringFailure: 'Could not parse sources' ].
	sourceMessage := sourceParseTree whichNodeIsContainedBy: sourceInterval.
	sourceMessage
		ifNil: [ 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 isSelfVariable or: [ sourceMessage receiver isSuperVariable ])
		ifFalse: [ self refactoringError: 'Cannot inline non-self messages' ]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
normalizeReturns
	| rewriter |
	rewriter := self parseTreeRewriter.
	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]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
removeEmptyIfTrues
	| rewriter |
	rewriter := self parseTreeRewriter.
	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]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
writeGuardClauses
	| rewriter |
	rewriter := self parseTreeRewriter.
	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: self inlineParseTree] 
		whileTrue: [inlineParseTree := rewriter tree]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
inlineSourceReplacing: aParseTree
	| statements nodeUnderSequence |
	statements := inlineParseTree body statements.
	(statements size > 1 and: [ aParseTree isEvaluatedFirst not ]) ifTrue: [ 
		self refactoringWarning:
			'To inline this method, we need to move some of its statements before the original message send.<n>This could change the order of execution, which can change the behavior.<n>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 selfNode ]
			 ifFalse: [ statements last ])! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
shouldInlineExpression: aString 
	^(self options at: #inlineExpression) value: self value: aString! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
inlineParseTree
	^ inlineParseTree! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
privateTransform
	self
		renameConflictingTemporaries;
		insertInlinedMethod;
		compileMethod! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
addTemporary: sourceNode assignedTo: replacementNode 
	| newName |
	newName := self renameConflictingTemporary: sourceNode name.
	(inlineParseTree body)
		addTemporaryNamed: newName;
		addNodeFirst: (RBAssignmentNode variable: (RBVariableNode named: newName)
					value: replacementNode)! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
renameTemporary: oldName to: newName 
	| rewriter |
	rewriter := self parseTreeRewriter.
	rewriter
		replace: oldName with: newName;
		replaceArgument: oldName with: newName.
	(rewriter executeTree: inlineParseTree) 
		ifTrue: [inlineParseTree := rewriter tree]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
hasMultipleReturns
	"Do we have multiple returns? If the last statement isn't a return, then we have an implicit return of self."

	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: '^``@object'
		do: [ :aNode :hasAReturn | 
			hasAReturn
				ifTrue: [ ^ true ].
			true ].
	searcher
		executeTree: inlineParseTree
		initialAnswer: inlineParseTree lastIsReturn not.
	^ false! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
preconditions
	^(RBCondition definesSelector: sourceSelector in: class) 
		& (RBCondition withBlock: 
					[self findSelectedMessage.
					self checkOverridden ifTrue: [
						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])! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
rewriteCascadedMessage
	| index messages |
	
	messages := sourceMessage parent messages.
	index := (1 to: messages size) 
				detect: [:i | sourceMessage == (messages at: i)]
				ifNone: [0].
	inlineParseTree body addNodesFirst: (messages copyFrom: 1 to: index - 1).
	inlineParseTree := self removeReturnsOf: inlineParseTree.
	inlineParseTree body 
		addNodes: (messages copyFrom: index + 1 to: messages size).
	inlineParseTree addReturn! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
addSelfReturn
	inlineParseTree addSelfReturn! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
isOverridden
	| aSelector | 
	aSelector := self inlineSelector.
	class allSubclassesDo: [:each | 
		(each directlyDefinesMethod: aSelector)
			ifTrue: [ ^ true ]].
	^ false
	! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
isPrimitive
	^inlineParseTree isPrimitive! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
removeReturnsOf: parseTree
	| rewriter |
	rewriter := self parseTreeRewriter.
	rewriter replace: '^``@object' with: '``@object'.
	(rewriter executeTree: parseTree) 
		ifTrue: [ ^ rewriter tree].
	^ parseTree! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
inlineSelector

	sourceMessage ifNil: [ self findSelectedMessage ].
	^ sourceMessage selector! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
checkOverridden
	^ checkOverridden ifNil: [ checkOverridden := true ]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
parseInlineMethod

	self inlineClass
		ifNil: [ self
				refactoringFailure:
					( '<1p> or its superclasses don''t contain method <2s>'
						expandMacrosWith: class
						with: self inlineSelector )
			].
	inlineParseTree := self inlineClass parseTreeFor: self inlineSelector.
	inlineParseTree ifNil: [ self refactoringFailure: 'Could not parse sources' ].
	inlineParseTree lastIsReturn
		ifFalse: [ inlineParseTree addSelfReturn ]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
removeImmediateBlocks
	| rewriter |
	rewriter := self parseTreeRewriter.
	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]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
normalizeIfTrues
	| rewriter |
	rewriter := self parseTreeRewriter.
	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]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
renameConflictingTemporary: aName 
	| allNames newName index seqNode |
	allNames := (Set new)
				addAll: inlineParseTree allDefinedVariables;
				yourself.
	allNames remove: aName ifAbsent: [].
	seqNode := sourceMessage.
	[seqNode isSequence] whileFalse: [seqNode := seqNode parent].
	allNames addAll: seqNode allDefinedVariables.	"Add those variables defined in blocks. This might cause a few 
													variables to be renamed that don't need to be, but this should be safe."
	newName := aName.
	index := 0.
	
	[(sourceMessage whoDefines: newName) notNil or: 
			[(class hierarchyDefinesVariable: newName) or: [allNames includes: newName]]] 
			whileTrue: 
				[index := index + 1.
				newName := aName , index printString].
	newName = aName ifFalse: [self renameTemporary: aName to: newName].
	^newName! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
replaceArgument: sourceNode with: replacementNode 
	| rewriter |
	rewriter := self parseTreeRewriter.
	rewriter replaceTree: sourceNode withTree: replacementNode.
	(rewriter executeTree: inlineParseTree body) 
		ifTrue: [inlineParseTree body: rewriter tree]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' inline: '.
	sourceInterval storeOn: aStream.
	aStream
		nextPutAll: ' inMethod: #';
		nextPutAll: sourceSelector;
		nextPutAll: ' forClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
inline: anInterval inMethod: aSelector forClass: aClass 
	sourceSelector := aSelector.
	class := self model classObjectFor: aClass.
	sourceInterval := anInterval! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
inlineClass

	^ inlineClass
		ifNil: [ inlineClass := ( sourceMessage receiver name = 'super'
				ifTrue: [ class superclass ]
				ifFalse: [ class ] ) whoDefinesMethod: self inlineSelector
			]
		ifNotNil: [ inlineClass ]! !

!RBInlineMethodTransformation methodsFor: 'adding' stamp: ''!
renameConflictingTemporaries
	inlineParseTree allDefinedVariables 
		do: [:each | self renameConflictingTemporary: each]! !

!RBInlineMethodTransformation class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk inline: anInterval inMethod: aSelector forClass: aClass 
	^ self new
		model: aRBSmalltalk;
		inline: anInterval
			inMethod: aSelector
			forClass: aClass;
		yourself! !

!RBInlineMethodTransformation class methodsFor: 'instance creation' stamp: ''!
inline: anInterval inMethod: aSelector forClass: aClass 
	^ self new 
		inline: anInterval
		inMethod: aSelector
		forClass: aClass! !

!RBInlineParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInlineBlockFailure
	self shouldFail: (self createRefactoringWithArguments: 
		{ 'aBlock' . RBRefactoryTestDataApp . ('inline' , 'Foo:') asSymbol })! !

!RBInlineParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInlineArgsWhitoutSameLiteral
	self shouldFail: (self createRefactoringWithArguments:  
		{ 'aSymbol' . RBRefactoryTestDataApp . ('inline' , 'Bar:') asSymbol })! !

!RBInlineParameterParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineLiteralArray
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ 'aSymbol' . RBRefactoryTestDataApp . ('inline' , 'ParameterMethod:') asSymbol }.
	
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self assert: (class parseTreeFor: #inlineParameterMethod) equals: (self parseMethod: 'inlineParameterMethod | aSymbol | aSymbol := #(asdf). ^aSymbol isSymbol').
	self assert: (class parseTreeFor: #sendInlineParameterMethod) equals: (self parseMethod: 'sendInlineParameterMethod ^self inlineParameterMethod').
	self deny: (class directlyDefinesMethod: ('inline' , 'ParameterMethod:') asSymbol)! !

!RBInlineParameterParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #inlineParameter:in:selector:! !

!RBInlineParameterParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBInlineParameterRefactoring };
		yourself! !

!RBInlineParameterRefactoring commentStamp: ''!
I am a refactoring for removing and inlining method arguments.

If all callers of a method with arguments, call that method with the same literal argument expression, you can remove that argument and inline the literal into that method.

My precondition verifies that the method name without that argument isn't already used and that all callers supplied the same literal expression.

For example, a method foo: anArg

```
foo: anArg
	anArg doSomething.
```

and all senders supply the same argument: 	     

```
method1
	anObject foo: 'text'.

method2
	anObject foo: 'text'.
```	
the method argument can be inlined:

```
foo
 | anArg |
 anArg := 'text'.
	anArg doSomething.
```

and the callers just call the method without any arguments:

```
method1
	anObject foo.
```!
!RBInlineParameterRefactoring methodsFor: 'private' stamp: ''!
expressionsToInlineFrom: aTree
	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: '``@obj ' , (self buildSelectorString: oldSelector)
		do: [ :aNode :answer | 
			answer
				add: (aNode arguments at: parameterIndex);
				yourself ].
	^ searcher executeTree: aTree initialAnswer: OrderedCollection new! !

!RBInlineParameterRefactoring methodsFor: 'preconditions' stamp: ''!
myConditions
	self getNewSelector.
	expressions := self allExpressionsToInline.
	^(RBCondition definesSelector: oldSelector in: class) 
		& ((RBCondition withBlock: [expressions isNotEmpty ]) 
				errorMacro: 'No callers. Use Remove Method instead.') 
			& ((RBCondition withBlock: [expressions size = 1]) 
					errorMacro: 'All values passed as this argument must be identical.') 
			& ((RBCondition withBlock: [expressions first isLiteralNode]) 
					errorMacro: 'All values passed must be literal.')! !

!RBInlineParameterRefactoring methodsFor: 'initialization' stamp: ''!
inlineParameter: aString in: aClass selector: aSelector
	oldSelector := aSelector.
	class := self classObjectFor: aClass.
	argument := aString! !

!RBInlineParameterRefactoring methodsFor: 'private' stamp: ''!
allExpressionsToInline
	| coll |
	coll := Set new.
	self model allReferencesTo: oldSelector
		do: 
			[:each | 
			| tree |
			tree := each parseTree.
			tree ifNotNil: [coll addAll: (self expressionsToInlineFrom: tree)]].
	^coll asOrderedCollection! !

!RBInlineParameterRefactoring methodsFor: 'transforming' stamp: ''!
modifyImplementorParseTree: parseTree in: aClass 
	| node assignment |
	node := (parseTree arguments at: parameterIndex) copy.
	parseTree body addTemporaryNamed: node name.
	assignment := RBAssignmentNode variable: node copy value: expressions first.
	parseTree body addNodeFirst: assignment.
	super modifyImplementorParseTree: parseTree in: aClass! !

!RBInlineParameterRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' inlineParameter: ''';
		nextPutAll: argument;
		nextPutAll: ''' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll: oldSelector;
		nextPut: $)! !

!RBInlineParameterRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk inlineParameter: aString in: aClass selector: aSelector 
	^ self new
		model: aRBSmalltalk;
		inlineParameter: aString
			in: aClass
			selector: aSelector;
		yourself! !

!RBInlineParameterRefactoring class methodsFor: 'instance creation' stamp: ''!
inlineParameter: aString in: aClass selector: aSelector 
	^ self new 
		inlineParameter: aString
		in: aClass
		selector: aSelector! !

!RBInlineTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInlineTemporaryMutlipleAssignment
	self shouldFail: (self createRefactoringWithArguments:
		{ (60 to: 83) . #moveDefinition . RBRefactoryTestDataApp })! !

!RBInlineTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInlineTemporaryBadInterval
	self shouldFail: (self createRefactoringWithArguments:
		{ (29 to: 100) . #moveDefinition . RBRefactoryTestDataApp })! !

!RBInlineTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInlineTemporaryReadBeforeWritten
	self shouldFail: (self createRefactoringWithArguments:
		{ (48 to: 56) . #inlineTemporary . RBRefactoryTestDataApp })! !

!RBInlineTemporaryParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #inline:from:in:! !

!RBInlineTemporaryParametrizedTest methodsFor: 'tests' stamp: ''!
testInlineTemporary
	| refactoring |
	refactoring := self createRefactoringWithArguments:
		{ (24 to: 72) . #inlineMethod . RBRefactoryTestDataApp }.
	
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineMethod) equals: (self parseMethod: 'inlineMethod
										^self
													foo;
													inlineMethod;
													bar')! !

!RBInlineTemporaryParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBInlineTemporaryRefactoring };
		addCase: { #rbClass -> RBInlineTemporaryTransformation };
		yourself! !

!RBInlineTemporaryRefactoring commentStamp: ''!
I am a refactoring to replace a temporary variable by code.

All references to the temporary variable in this method are replaced by the value used to initialize the temporary variable. 
The initialization and declaration of this variable will be removed. You need to select the variable and its initial assignment code to apply this refactoring.!
!RBInlineTemporaryRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self
		replaceAssignment;
		replaceReferences;
		compileMethod! !

!RBInlineTemporaryRefactoring methodsFor: 'transforming' stamp: ''!
replaceAssignment
	assignmentNode parent isSequence 
		ifTrue: [assignmentNode parent removeNode: assignmentNode]
		ifFalse: [assignmentNode replaceWith: assignmentNode value]! !

!RBInlineTemporaryRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class) 
		& (RBCondition withBlock: 
					[self verifySelectedInterval.
					true])! !

!RBInlineTemporaryRefactoring methodsFor: 'preconditions' stamp: ''!
verifySelectedInterval

	sourceTree := class parseTreeFor: selector.
	sourceTree ifNil: [ 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: 'transforming' stamp: ''!
compileMethod
	class compileTree: sourceTree! !

!RBInlineTemporaryRefactoring methodsFor: 'testing' stamp: ''!
hasOnlyOneAssignment
	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: assignmentNode variable name , ' := ``@object'
		do: [ :aNode :answer | answer + 1 ].
	^ (searcher executeTree: definingNode initialAnswer: 0) == 1! !

!RBInlineTemporaryRefactoring methodsFor: 'transforming' stamp: ''!
replaceReferences
	| rewriter |
	rewriter := self parseTreeRewriter.
	rewriter replaceTree: assignmentNode variable
		withTree: assignmentNode value.
	definingNode removeTemporaryNamed: assignmentNode variable name.
	rewriter executeTree: definingNode! !

!RBInlineTemporaryRefactoring methodsFor: 'initialization' stamp: ''!
inline: anInterval from: aSelector in: aClass 
	class := self classObjectFor: aClass.
	selector := aSelector.
	sourceInterval := anInterval! !

!RBInlineTemporaryRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' inline: '.
	sourceInterval storeOn: aStream.
	aStream
		nextPutAll: ' from: #';
		nextPutAll: selector;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBInlineTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''!
inline: anInterval from: aSelector in: aClass 
	^ self new 
		inline: anInterval
		from: aSelector
		in: aClass! !

!RBInlineTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk inline: anInterval from: aSelector in: aClass 
	^ self new
		model: aRBSmalltalk;
		inline: anInterval
			from: aSelector
			in: aClass;
		yourself! !

!RBInlineTemporaryTransformation methodsFor: 'executing' stamp: ''!
replaceAssignment
	^ RBCustomTransformation model: self model with: [ :rbModel |
		assignmentNode parent isSequence 
		ifTrue: [assignmentNode parent removeNode: assignmentNode]
		ifFalse: [assignmentNode replaceWith: assignmentNode value]]! !

!RBInlineTemporaryTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class) 
		& (RBCondition withBlock: 
					[self verifySelectedInterval.
					true])! !

!RBInlineTemporaryTransformation methodsFor: 'preconditions' stamp: ''!
verifySelectedInterval

	sourceTree := class parseTreeFor: selector.
	sourceTree ifNil: [ 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' ]! !

!RBInlineTemporaryTransformation methodsFor: 'testing' stamp: ''!
hasOnlyOneAssignment
	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: assignmentNode variable name , ' := ``@object'
		do: [ :aNode :answer | answer + 1 ].
	^ (searcher executeTree: definingNode initialAnswer: 0) == 1! !

!RBInlineTemporaryTransformation methodsFor: 'executing' stamp: ''!
replaceReferences
	^ RBCustomTransformation model: self model with: [ :rbModel |
	| rewriter |
	rewriter := self parseTreeRewriter.
	rewriter replaceTree: assignmentNode variable
		withTree: assignmentNode value.
	definingNode removeTemporaryNamed: assignmentNode variable name.
	rewriter executeTree: definingNode.
	class compileTree: sourceTree ]! !

!RBInlineTemporaryTransformation methodsFor: 'api' stamp: ''!
inline: anInterval from: aSelector in: aClass
	class := self model classObjectFor: aClass.
	selector := aSelector.
	sourceInterval := anInterval! !

!RBInlineTemporaryTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' inline: '.
	sourceInterval storeOn: aStream.
	aStream
		nextPutAll: ' from: #';
		nextPutAll: selector;
		nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBInlineTemporaryTransformation methodsFor: 'executing' stamp: ''!
buildTransformations
	^ OrderedCollection 
		with: self replaceAssignment
		with: self replaceReferences! !

!RBInlineTemporaryTransformation class methodsFor: 'api' stamp: ''!
inline: anInterval from: aSelector in: aClass
	^ self new 
		inline: anInterval
		from: aSelector
		in: aClass! !

!RBInlineTemporaryTransformation class methodsFor: 'api' stamp: ''!
model: aRBNamespace inline: anInterval from: aSelector in: aClass
	^ self new
		model: aRBNamespace;
		inline: anInterval
		from: aSelector
		in: aClass;
		yourself! !

!RBInvalidCascadeErrorNode methodsFor: 'accessing' stamp: ''!
cascade
	
	^ content first! !

!RBItemsSelectionPresenter commentStamp: ''!
I am an abstract class to select items from a list. 
My subclasses should implement 3 methods:

	- Class side
		- title
	- Instance side
		- columnName
		- columnSelector

Instance Variables
-------------------------------------------------

table:                   <TablePresenter> A table to display the possible methods to push down
label:                   <LabelPresenter> Title of table
items:                   <OrderedCollection> A list to select 
selectedItems:           <OrderedCollection> A list with selected items!
!RBItemsSelectionPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	table := self instantiate: SpFilteringSelectableListPresenter.
	table display: self columnSelector.
	label := self newLabel.! !

!RBItemsSelectionPresenter methodsFor: 'initialization' stamp: ''!
label: aString withItems: coll1 selecting: coll2
	label label: aString.
	
	table items: coll1;
		selectItems: coll2	! !

!RBItemsSelectionPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aModalPresenter
	aModalPresenter
		addButton: 'Refactor' do: [ :presenter | self accept: presenter ];
		addButton: 'Cancel' do: [ :presenter | 
			presenter
				beCancel;
				close ]        ! !

!RBItemsSelectionPresenter methodsFor: 'attributes' stamp: ''!
columnName
	self shouldBeImplemented! !

!RBItemsSelectionPresenter methodsFor: 'actions' stamp: ''!
accept

	selectedItems := table selectedItems! !

!RBItemsSelectionPresenter methodsFor: 'accessing' stamp: ''!
selectedItems
	^ selectedItems ! !

!RBItemsSelectionPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters
	
	table bindKeyCombination: Character backspace asShortcut 
		toAction: [ table toggleSelection ].
	self components do: [ :each |
	each bindKeyCombination: Character cr asKeyCombination 
		toAction: [ :presenter | self accept: presenter] ]! !

!RBItemsSelectionPresenter methodsFor: 'actions' stamp: ''!
accept: presenter
	self accept.
	presenter
				beOk;
				close! !

!RBItemsSelectionPresenter methodsFor: 'accessing' stamp: ''!
components 
	^ { table . label }! !

!RBItemsSelectionPresenter methodsFor: 'attributes' stamp: ''!
columnSelector 
	self shouldBeImplemented ! !

!RBItemsSelectionPresenter class methodsFor: 'specs' stamp: ''!
label: aString withItems: items selecting: selectedItems
	^ self new 
		label: aString withItems: items selecting: selectedItems;
		openBlockedDialogWithSpec ! !

!RBItemsSelectionPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #label withConstraints: [ :c | c height: self buttonHeight ];
		add:
			(SpBoxLayout newLeftToRight
				add: #table;
				yourself);
		yourself! !

!RBKeywordToken commentStamp: ''!
RBKeywordToken is the first-class representation of a keyword token (e.g. add:)!
!RBKeywordToken methodsFor: 'testing' stamp: ''!
isPatternVariable
	^value first = RBScanner patternVariableCharacter! !

!RBKeywordToken methodsFor: 'testing' stamp: ''!
isKeyword
	^true! !

!RBKeywordToken methodsFor: 'testing' stamp: ''!
isPrimitiveKeyword
	^ self value = #primitive:! !

!RBLintRule commentStamp: ''!
I represent an executable check applied on an environment (groups of classes, methods... )!
!RBLintRule methodsFor: 'testing' stamp: ''!
isEmpty
	self subclassResponsibility! !

!RBLintRule methodsFor: 'accessing' stamp: ''!
problemCount
	self subclassResponsibility! !

!RBLintRule methodsFor: 'accessing' stamp: ''!
result
	^ self subclassResponsibility! !

!RBLintRule methodsFor: '*Renraku' stamp: ''!
check: anEntity

	^ self check: anEntity ifNoCritiques: [ "do nothing" ]! !

!RBLintRule methodsFor: 'accessing' stamp: ''!
rationale
	"Answer an explanation of the rule, usually in one line. Long description can be obtained using longDescription."

	^ self class comment! !

!RBLintRule methodsFor: '*Manifest-Core' stamp: ''!
critics
	^ self result smallLintCritics! !

!RBLintRule methodsFor: '*Renraku' stamp: ''!
anchorFor: anEntity

	^ ReSourceAnchor
			entity: anEntity! !

!RBLintRule methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	self name
		ifNotNil: [ aStream
				nextPutAll: ' name: ';
				print: self name
			]! !

!RBLintRule methodsFor: 'testing' stamp: ''!
hasConflicts
	^ false! !

!RBLintRule methodsFor: 'accessing' stamp: ''!
changes
	^ #()! !

!RBLintRule methodsFor: 'running' stamp: ''!
run
	^ RBSmalllintChecker runRule: self! !

!RBLintRule methodsFor: 'testing' stamp: ''!
isComposite
	^ false! !

!RBLintRule methodsFor: 'running' stamp: ''!
checkClass: aClass
	"Is a hook to specify a check that is performed at the class level"
	
! !

!RBLintRule methodsFor: 'running' stamp: ''!
checkMethod: aMethod
	"Is a hook to specify a check that is performed at the method level"! !

!RBLintRule methodsFor: 'running' stamp: ''!
resetResult! !

!RBLintRule methodsFor: 'accessing' stamp: ''!
severity
	"Answer the severity of issues reported by this rule. This method should return one of #error, #warning, or #information."

	^ #warning! !

!RBLintRule methodsFor: 'running' stamp: ''!
basicCheck: anEntity

	^ self subclassResponsibility ! !

!RBLintRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Unclassified rules'! !

!RBLintRule methodsFor: 'testing' stamp: ''!
isArchitecturalRule
	^ false ! !

!RBLintRule methodsFor: '*Renraku' stamp: ''!
check: anEntity forCritiquesDo: aCriticBlock

	(self basicCheck: anEntity)
		ifTrue: [ aCriticBlock cull: (self critiqueFor: anEntity) ]! !

!RBLintRule methodsFor: 'accessing' stamp: ''!
name
	"Answer a human readable name of the rule."

	self subclassResponsibility! !

!RBLintRule methodsFor: '*Renraku' stamp: ''!
critiqueFor: anEntity

	^ ReTrivialCritique
		withAnchor: (self anchorFor: anEntity)
		by: self! !

!RBLintRule methodsFor: 'private' stamp: ''!
genericPatternForSelector: aSymbol
	^ String streamContents: [ :stream |
		aSymbol keywords keysAndValuesDo: [ :index :value |
			stream space; nextPutAll: value.
			aSymbol last = $:
				ifTrue: [ stream space; nextPutAll: '`@object'; print: index ] ] ]! !

!RBLintRule methodsFor: 'testing' stamp: ''!
isTransformationRule

	^ false ! !

!RBLintRule methodsFor: '*Renraku' stamp: ''!
check: anEntity forCritiquesDo: aCriticBlock ifNone: alternativeBlock
	| encounteredCritique |
	
	encounteredCritique := false.

	self check: anEntity forCritiquesDo: [ :crit |
		encounteredCritique := true.
		aCriticBlock cull: crit ].
	
	encounteredCritique ifFalse: alternativeBlock! !

!RBLintRule methodsFor: 'accessing' stamp: ''!
leaves 
	^ {self}! !

!RBLintRule methodsFor: 'running' stamp: ''!
runOnEnvironment: anEnvironment 
	^ RBSmalllintChecker runRule: self onEnvironment: anEnvironment! !

!RBLintRule methodsFor: '*Renraku' stamp: ''!
check: anEntity ifNoCritiques: alternativeBlock
	| critics |
	
	critics := OrderedCollection new.
	self check: anEntity forCritiquesDo: [ :critic | critics add: critic ] ifNone: alternativeBlock.
	^ critics! !

!RBLintRule methodsFor: 'running' stamp: ''!
checkPackage: aPackage
	"Is a hook to specify a check that is performed at the pacakge level"
	
! !

!RBLintRule class methodsFor: 'testing' stamp: ''!
checksPackage

	^ false! !

!RBLintRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierNumber
	"This number should be unique and should change only when the rule completely change semantics"
	^ 0! !

!RBLintRule class methodsFor: 'accessing' stamp: ''!
enabledSettingID
	^ (self name, '_enabled') asSymbol! !

!RBLintRule class methodsFor: 'testing' stamp: ''!
checksMethod

	^ false! !

!RBLintRule class methodsFor: 'accessing' stamp: ''!
identifierMinorVersionNumber
	"This number identifies the version of the rule definition. Each time the rule is updated and its changes invalidates previous false positives identification (and as such should be reassessed by developers) the number should be increased."
	^ 1! !

!RBLintRule class methodsFor: 'testing' stamp: ''!
isUsed
	"all my sublasses are used"
	^self name = 'RBLintRule'
		ifTrue: [ super isUsed ]
		ifFalse: [ true ]! !

!RBLintRule class methodsFor: 'testing' stamp: ''!
enabled
	"compatibility to ReAbstractRule"
	^true! !

!RBLintRule class methodsFor: 'testing' stamp: ''!
checksClass

	^ false! !

!RBLintRule class methodsFor: 'testing' stamp: ''!
enabled: aBoolean
	"compatibility to ReAbstractRule"! !

!RBLintRule class methodsFor: '*Renraku' stamp: ''!
checksNode

	^ false! !

!RBLintRule class methodsFor: 'testing' stamp: ''!
isVisible
	"Answer true if the class should be visible in the GUI."

	^ false! !

!RBLintRuleTestData commentStamp: ''!
This hierarchy is code that is used as test data to test the refactoring engine. As such the code might make
no sense or have lots of easy possible improvements... but as it is used for testing, they should not be fixed.!
!RBLintRuleTestData methodsFor: 'testing' stamp: ''!
isEmpty
	self subclassResponsibility! !

!RBLintRuleTestData methodsFor: 'accessing' stamp: ''!
problemCount
	^self subclassResponsibility! !

!RBLintRuleTestData methodsFor: 'accessing' stamp: ''!
checkClass: aSmalllintContext! !

!RBLintRuleTestData methodsFor: 'accessing' stamp: ''!
checkMethod: aSmalllintContext! !

!RBLintRuleTestData methodsFor: 'initialization' stamp: ''!
initialize
	name := ''! !

!RBLintRuleTestData methodsFor: 'testing' stamp: ''!
junk
	^ RBRefactoryTestDataApp printString 
		copyFrom: 1
		to: CR! !

!RBLintRuleTestData methodsFor: 'initialization' stamp: ''!
resetResult! !

!RBLintRuleTestData methodsFor: 'private' stamp: ''!
viewResults
	self subclassResponsibility! !

!RBLintRuleTestData methodsFor: 'accessing' stamp: ''!
openEditor
	| rules |
	rules := self failedRules.
	rules isEmpty ifTrue: [^self].
	rules size == 1 ifTrue: [^rules first viewResults]! !

!RBLintRuleTestData methodsFor: 'accessing' stamp: ''!
displayName
	| nameStream |
	nameStream := WriteStream on: (String new: 64).
	nameStream nextPutAll: self name;
		nextPutAll: ' ('.
	self problemCount printOn: nameStream.
	nameStream nextPut: $).
	^nameStream contents! !

!RBLintRuleTestData methodsFor: 'printing' stamp: ''!
printOn: aStream

	name ifNil: [ super printOn: aStream ] ifNotNil: [ aStream nextPutAll: name ]! !

!RBLintRuleTestData methodsFor: 'private' stamp: ''!
failedRules
	^self isEmpty
		ifTrue: [#()]
		ifFalse: [Array with: self]! !

!RBLintRuleTestData methodsFor: 'accessing' stamp: ''!
name
	^name! !

!RBLintRuleTestData methodsFor: 'testing' stamp: ''!
hasConflicts
	^false! !

!RBLintRuleTestData methodsFor: 'accessing' stamp: ''!
name: aString 
	name := aString! !

!RBLintRuleTestData methodsFor: 'accessing' stamp: ''!
run
	^Object printOn: self! !

!RBLintRuleTestData methodsFor: 'testing' stamp: ''!
isComposite
	^false! !

!RBLintRuleTestData methodsFor: 'accessing' stamp: ''!
someOtherDemoMethod
	| temp |
	temp := self new.
	^ temp junk! !

!RBLintRuleTestData methodsFor: 'accessing' stamp: ''!
runOnEnvironment: anEnvironment 
	^Object printOn: self onEnvironment: anEnvironment! !

!RBLintRuleTestData class methodsFor: 'parsing' stamp: ''!
parseTreeSearcherClass
	^ RBParseTreeSearcher ! !

!RBLintRuleTestData class methodsFor: 'foo' stamp: ''!
someOtherFooMethod
	^ 'does nothing here even better:)'! !

!RBLintRuleTestData class methodsFor: 'accessing' stamp: ''!
name1

	^ Name1! !

!RBLintRuleTestData class methodsFor: 'foo' stamp: ''!
someFooMethod
	^ 'does nothing here:)'! !

!RBLintRuleTestData class methodsFor: 'parsing' stamp: ''!
parseTreeSearcher 
	^ self parseTreeSearcherClass new! !

!RBLintRuleTestData class methodsFor: 'accessing' stamp: ''!
name1: anObject

	Name1 := anObject! !

!RBLiteralArrayErrorNode commentStamp: ''!
This is a particular englobing node that is a literal array.
Exemple : #( literal array node )
Can be created by forgetting 
the closure : #( array node .
Forgetting the opening will be assumed to be a parentheses node.!
!RBLiteralArrayErrorNode methodsFor: 'testing' stamp: ''!
isLiteralArrayError
	^true! !

!RBLiteralArrayErrorNode class methodsFor: 'construction' stamp: ''!
error: aToken withNodes: aCollection
	"A RBLiteralArrayErrorNode can only be created from the opening token by choice.
	 Since the closure is a parentheses, the default assumption is to create a RBParenthesesErrorNode.
	 This could be change by an analysis of prior nodes."
	"If the collection is empty, there is only the token in the error."
	^aCollection isEmpty
		ifTrue: [ self new content: aCollection; start: aToken start; stop: aToken stop; errorMessage: ''')'' expected' ]
		ifFalse: [ self new content: aCollection; start: aToken start; stop: aCollection last stop; errorMessage: ''')'' expected' ]! !

!RBLiteralArrayNode commentStamp: ''!
An RBLiteralArrayNode is an AST node that represents literal arrays #(1 2 3) and literal byte arrays #[ 1 2 3 ].

Instance Variables
	contents: <Array of: RBLiteralNode> literal nodes of the array
	isByteArray: <Boolean> if the receiver is a literal byte array
!
!RBLiteralArrayNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	self contents: (contents 
				collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! !

!RBLiteralArrayNode methodsFor: 'comparing' stamp: ''!
= anObject 
	super = anObject ifFalse: [^false].
	self isForByteArray = anObject isForByteArray ifFalse: [^false].
	self contents size = anObject contents size ifFalse: [^false].
	self contents
		with: anObject contents
		do: [:first :second | first = second ifFalse: [^false]].
	^true! !

!RBLiteralArrayNode methodsFor: 'testing' stamp: ''!
isLiteralArray
	^true! !

!RBLiteralArrayNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitLiteralArrayNode: self! !

!RBLiteralArrayNode methodsFor: 'comparing' stamp: ''!
equalTo: anObject withMapping: aDictionary 
	self class = anObject class ifFalse: [^false].
	self isForByteArray = anObject isForByteArray ifFalse: [^false].
	self contents size = anObject contents size ifFalse: [^false].
	self contents
		with: anObject contents
		do: [:first :second | (first equalTo: second withMapping: aDictionary) ifFalse: [^false]].
	^true! !

!RBLiteralArrayNode methodsFor: 'testing' stamp: ''!
isFaulty
	^self contents anySatisfy: [:each | each isFaulty]! !

!RBLiteralArrayNode methodsFor: 'accessing' stamp: ''!
children
	^ contents! !

!RBLiteralArrayNode methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self contents: (self contents collect: [ :each | each copy ])! !

!RBLiteralArrayNode methodsFor: 'private - replacing' stamp: ''!
replaceSourceWith: aNode 
	(self class = aNode class and: 
			[self isForByteArray = aNode isForByteArray 
				and: [self contents size = aNode contents size]]) 
		ifFalse: [^super replaceSourceWith: aNode].
	self contents
		with: aNode contents 
		do: [:first :second | first = second ifFalse: [ first replaceSourceWith: second]]! !

!RBLiteralArrayNode methodsFor: 'accessing' stamp: ''!
value
	| array |
	array := (isByteArray ifTrue: [ByteArray] ifFalse: [Array]) 
				new: contents size.
	1 to: contents size
		do: [:each | array at: each put: (contents at: each) value].
	^array! !

!RBLiteralArrayNode methodsFor: 'testing' stamp: ''!
isForByteArray
	^isByteArray! !

!RBLiteralArrayNode methodsFor: 'accessing' stamp: ''!
contents
	^contents! !

!RBLiteralArrayNode methodsFor: 'matching' stamp: ''!
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: 'initialization' stamp: ''!
contents: aRBLiteralNodeCollection 
	contents := aRBLiteralNodeCollection.
	contents do: [:each | each parent: self]! !

!RBLiteralArrayNode methodsFor: 'initialization' stamp: ''!
startPosition: startInteger contents: anArray stopPosition: stopInteger isByteArray: aBoolean 
	start := startInteger.
	self contents: anArray.
	stop := stopInteger.
	isByteArray := aBoolean! !

!RBLiteralArrayNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	^ self class 
		startPosition: 0
		contents: (self copyList: self contents inContext: aDictionary)
		stopPosition: -1
		isByteArray: isByteArray! !

!RBLiteralArrayNode class methodsFor: 'instance creation' stamp: ''!
value: aValue 
	^(self new)
		startPosition: 0
			contents: (aValue asArray collect: [:each | RBLiteralNode value: each])
			stopPosition: -1
			isByteArray: aValue class ~~ Array;
		yourself! !

!RBLiteralArrayNode class methodsFor: 'instance creation' stamp: ''!
startPosition: startInteger contents: anArray stopPosition: stopInteger isByteArray: aBoolean 
	^(self new)
		startPosition: startInteger
			contents: anArray
			stopPosition: stopInteger
			isByteArray: aBoolean;
		yourself! !

!RBLiteralArrayToken commentStamp: ''!
I am the start of a literal array, normal literal arrays `#()` or byte arrays `#[]`.
!
!RBLiteralArrayToken methodsFor: 'testing' stamp: ''!
isForByteArray
	^value last = $[! !

!RBLiteralArrayToken methodsFor: 'testing' stamp: ''!
isLiteralArrayToken
	^true! !

!RBLiteralByteArrayErrorNode commentStamp: ''!
This is a particular englobing node that is a literal byte array.
Exemple : #[ literal byte array node ]
Can be created by forgetting 
the closure : #[ array node .
Forgetting the opening will be assumed to be a block node.!
!RBLiteralByteArrayErrorNode methodsFor: 'testing' stamp: ''!
isLiteralByteArrayError
	^true! !

!RBLiteralByteArrayErrorNode class methodsFor: 'construction' stamp: ''!
error: aToken withNodes: aCollection
	"A RBLiteralByteArrayErrorNode can only be created from the opening token by choice.
	 Since the closure is a bracket, the default assumption is to create a RBBlockErrorNode.
	 This could be change by an analysis of prior nodes."
	"If the collection is empty, there is only the token in the error."
	^aCollection isEmpty
		ifTrue: [ self new content: aCollection; start: aToken start; stop: aToken stop; errorMessage: ''']'' expected' ]
		ifFalse: [ self new content: aCollection; start: aToken start; stop: aCollection last stop; errorMessage: ''']'' expected' ]! !

!RBLiteralNode commentStamp: ''!
RBLiteralNode is an AST node that represents literals.

Instance Variables
	start: <Integer | nil> source position for the literal's beginning
	stop: <Integer | nil> source position for the literal's end!
!RBLiteralNode methodsFor: 'testing' stamp: ''!
isLiteralNode
	^true! !

!RBLiteralNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [^true].
	^self class = anObject class! !

!RBLiteralNode methodsFor: 'testing' stamp: ''!
isImmediateNode
	^true! !

!RBLiteralNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitLiteralNode: self! !

!RBLiteralNode methodsFor: 'comparing' stamp: ''!
hash
	^self value hash! !

!RBLiteralNode methodsFor: 'testing' stamp: ''!
needsParenthesis
	^false! !

!RBLiteralNode methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	start := 0.
	stop := 0.! !

!RBLiteralNode methodsFor: 'accessing' stamp: ''!
stopWithoutParentheses
	^stop! !

!RBLiteralNode methodsFor: 'private - replacing' stamp: ''!
replaceSourceFrom: aNode 
	self addReplacement: (RBStringReplacement 
				replaceFrom: aNode start
				to: aNode stop
				with: self formattedCode)! !

!RBLiteralNode methodsFor: 'accessing' stamp: ''!
startWithoutParentheses
	^start! !

!RBLiteralNode methodsFor: 'private - replacing' stamp: ''!
replaceSourceWith: aNode 
	self addReplacement: (RBStringReplacement 
				replaceFrom: self start
				to: self stop
				with: aNode formattedCode)! !

!RBLiteralNode methodsFor: 'accessing' stamp: ''!
value
	^self subclassResponsibility! !

!RBLiteralNode methodsFor: 'accessing' stamp: ''!
stop: anInteger
	stop := anInteger! !

!RBLiteralNode methodsFor: 'accessing' stamp: ''!
start: anInteger
	start := anInteger! !

!RBLiteralNode methodsFor: 'accessing' stamp: ''!
precedence
	^0! !

!RBLiteralNode class methodsFor: 'instance creation' stamp: ''!
value: aValue 
	^((aValue class == Array or: [aValue class == ByteArray]) 
		ifTrue: [RBLiteralArrayNode]
		ifFalse: [RBLiteralValueNode]) value: aValue! !

!RBLiteralToken commentStamp: ''!
RBLiteralToken is the first-class representation of a literal token (entire literals, even literal arrays, are a single token in the Pharo grammar).

Instance Variables:
- stopPosition <Integer> The position within the source code where the token terminates.

!
!RBLiteralToken methodsFor: 'testing' stamp: ''!
isLiteralToken
	^true! !

!RBLiteralToken methodsFor: 'accessing' stamp: ''!
source
	^source! !

!RBLiteralToken methodsFor: 'private' stamp: ''!
length
	^stopPosition - self start + 1! !

!RBLiteralToken methodsFor: 'accessing' stamp: ''!
stop: anObject 
	stopPosition := anObject! !

!RBLiteralToken methodsFor: 'initialization' stamp: ''!
source: aString 
	source := aString! !

!RBLiteralToken methodsFor: 'initialization' stamp: ''!
value: aString start: anInteger stop: stopInteger 
	value := aString.
	sourcePointer := anInteger.
	stopPosition := stopInteger! !

!RBLiteralToken methodsFor: 'accessing' stamp: ''!
realValue
	^value! !

!RBLiteralToken methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	value isSymbol 
		ifTrue: 
			[aStream nextPut: $#.
			(value isValidSelector 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' stamp: ''!
isMultiKeyword
	^false! !

!RBLiteralToken class methodsFor: 'instance creation' stamp: ''!
value: anObject 
	| literal |
	literal := anObject class == Array 
				ifTrue: [anObject collect: [:each | self value: each]]
				ifFalse: [anObject].
	^self 
		value: literal
		start: nil
		stop: nil! !

!RBLiteralToken class methodsFor: 'instance creation' stamp: ''!
value: aString start: anInteger stop: stopInteger source: sourceText
	^(self new)
		value: aString
			start: anInteger
			stop: stopInteger;
			source: sourceText;
		yourself! !

!RBLiteralToken class methodsFor: 'instance creation' stamp: ''!
value: aString start: anInteger stop: stopInteger 
	^ self value: aString start: anInteger stop: stopInteger source: nil! !

!RBLiteralValueNode commentStamp: ''!
RBLiteralNode is an AST node that represents literal values (e.g., #foo, true, 1, etc.), but not literal arrays.

The sourceText field is needed for the formatter for the correct printing of strings vs symbols. If we just call
value asString, both a string and a symbol print itself as a string.

Instance Variables
	value	<Numeric | Symbol | String  | Character>	the literal value I represent
	sourceText <String> the original source text of this literal!
!RBLiteralValueNode methodsFor: 'accessing' stamp: ''!
sourceText
	^ sourceText ifNil: [
		String streamContents: [:aStream|			
			value isSymbol
				ifTrue: [
					aStream nextPut: $#.
					((value isValidSelector) and: [value ~~ #'||']) 
						ifTrue: [aStream nextPutAll: value]
						ifFalse: [value asString printOn: aStream]]
				ifFalse: [ 
					value class == Character 
						ifTrue: 
							[aStream nextPut: $$;	nextPut: value]
						ifFalse: [ value storeOn: aStream ]]] ]! !

!RBLiteralValueNode methodsFor: 'comparing' stamp: ''!
= anObject 
	^ super = anObject 
		and: [ self value = anObject value
		and: [ self value class = anObject value class 
		and: [ self value species = anObject value species ] ] ]! !

!RBLiteralValueNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitLiteralValueNode: self! !

!RBLiteralValueNode methodsFor: 'evaluating' stamp: ''!
evaluateForReceiver: aReceicer

	^ value! !

!RBLiteralValueNode methodsFor: 'initialization' stamp: ''!
value: aValue start: aPosition stop: anotherPosition source: aString 

	self value: aValue start: aPosition stop: anotherPosition.
	sourceText := aString.! !

!RBLiteralValueNode methodsFor: '*NECompletion' stamp: ''!
completionEntries: offset
	value isSymbol ifFalse: [ ^ #() ].
	"return all symbols that start with value"
	^Symbol allSymbols 
		select: [ :each | (each beginsWith: value) and: [each isLiteralSymbol]] 
		thenCollect: [ :each | NECSymbolEntry contents: each node: self ]! !

!RBLiteralValueNode methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!RBLiteralValueNode methodsFor: 'initialization' stamp: ''!
value: aValue start: aPosition stop: anotherPosition

	value := aValue.
	start := aPosition. 
	stop := anotherPosition.! !

!RBLiteralValueNode methodsFor: 'evaluating' stamp: ''!
evaluateForContext: aContext

	^ value! !

!RBLiteralValueNode methodsFor: '*NECompletion' stamp: ''!
completionToken: offset
	^ self value asString! !

!RBLiteralValueNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary
	^ self class value: self value! !

!RBLiteralValueNode class methodsFor: 'instance creation' stamp: ''!
value: aValue
	^ self value: aValue start: 0 stop: -1! !

!RBLiteralValueNode class methodsFor: 'instance creation' stamp: ''!
value: aValue start: aPosition stop: anotherPosition  source: aString 
 	^ self new
		value: aValue start: aPosition stop: anotherPosition source: aString;
		yourself.! !

!RBLiteralValueNode class methodsFor: 'instance creation' stamp: ''!
value: aValue start: aPosition stop: anotherPosition 
 	^ self new
		value: aValue start: aPosition stop: anotherPosition;
		yourself.! !

!RBMatchVisitor commentStamp: ''!
I am a visitor to change temporaries and arguments to generic names (`tempMatch , `argMatch)!
!RBMatchVisitor methodsFor: 'accessing' stamp: ''!
initialize 	
	super initialize .
	arguments := 0 .
	temporaries := 0.
	difference := 0! !

!RBMatchVisitor methodsFor: 'accessing' stamp: ''!
visitBlockNode: aBlockNode
	aBlockNode arguments do: [ :arg | 
		self replace: arg with: ('tempMatch', temporaries  asString).
		temporaries := temporaries + 1 ].
	super visitBlockNode: aBlockNode! !

!RBMatchVisitor methodsFor: 'accessing' stamp: ''!
visitSequenceNode: aSequenceNode
	|isMethod|
	isMethod := aSequenceNode parent isMethod.
	aSequenceNode temporaries do: [ :temp |
		isMethod ifTrue: [
			difference := difference + (('tempMatch', temporaries  asString ) size- (temp name asString ) size + 2 )].
		self replace: temp with: ('tempMatch' , temporaries  asString).
		temporaries := temporaries + 1].
	super visitSequenceNode: aSequenceNode.
	
	! !

!RBMatchVisitor methodsFor: 'accessing' stamp: ''!
replace: temp with: aString
	|definingNode|
	definingNode := temp whoDefines: temp name.
	(RBParseTreeRewriter rename: temp name to: aString) executeTree: definingNode.! !

!RBMatchVisitor methodsFor: 'accessing' stamp: ''!
visitMethodNode: aMethodNode
	aMethodNode arguments do: [ :arg | 
		difference := difference + (('argMatch', arguments  asString )size- (arg name asString )size + 2 ).
		self replace: arg with: ('argMatch', arguments  asString).
		arguments := arguments + 1 ].
	super visitMethodNode: aMethodNode.
	
	! !

!RBMatchVisitor methodsFor: 'accessing' stamp: ''!
difference
	^ difference! !

!RBMergeInstanceVariableIntoAnother commentStamp: ''!
I am a refactoring for merge an instance variable into another.

I replace an instance variable by other, in all methods refering to this variable and rename the old accessors, then if the instance variable renamed is directly defined in class it is removed.

My precondition verifies that the new variable is a defined instance variable in class.

Example
----------------------------
Script
```
(RBMergeInstanceVariableIntoAnother rename: 'x' to: 'y' in: Foo) execute.
```

Before refactoring:
```
Class Foo -> inst vars: x, y 

Foo >> foobar
	^ x 

Foo >> foo
	^ x + y 
```
After refactoring merging X into Y
```
Class Foo -> inst vars: y 

Foo >> foobar
	^ y

Foo >> foo 
	^ y + y
```!
!RBMergeInstanceVariableIntoAnother methodsFor: 'transforming' stamp: ''!
transform
	renameAccessors ifTrue: [ 
		self removeOldAccessors 
	].
	
	self renameVariable.
	
	renameAccessors ifFalse: [ ^ self ].
	self addNewAccessors.
	self renameAccessorsReferences.! !

!RBMergeInstanceVariableIntoAnother methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition 
		withBlock: [ (variableName = newName) 
			ifTrue: [ self refactoringFailure: 'The variable merged must be different' ].
		true ])
		& (RBCondition definesInstanceVariable: variableName in: class) 
			& (RBCondition definesInstanceVariable: newName in: class)! !

!RBMergeInstanceVariableIntoAnother methodsFor: 'transforming' stamp: ''!
renameVariable 
	model 
		renameInstanceVariable: variableName
		to: newName
		in: class
		around: [ self renameReferences ].! !

!RBMergeInstanceVariableIntoAnotherParametrizedTest methodsFor: 'tests' stamp: ''!
testReplaceVariableIntoAnother
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ 'classBlock' . 'anInstVar' . RBBasicLintRuleTestData }.
	class := refactoring model classNamed: #RBBasicLintRuleTestData.
	self assert: (class whichSelectorsReferToInstanceVariable: 'classBlock') isNotEmpty.
	self executeRefactoring: refactoring.
	
	self assert: (class whichSelectorsReferToInstanceVariable: 'classBlock') isEmpty.! !

!RBMergeInstanceVariableIntoAnotherParametrizedTest methodsFor: 'tests' stamp: ''!
testReplaceVariableIntoSupeclassVariable
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ 'name' . 'classBlock' . RBBasicLintRuleTestData }.
	class := refactoring model classNamed: #RBBasicLintRuleTestData.
	self assert: (class whichSelectorsReferToInstanceVariable: 'name') isNotEmpty.
	self executeRefactoring: refactoring.
	self assert: (class definesInstanceVariable: 'name').
	self assert: (class directlyDefinesInstanceVariable: 'classBlock').
	
	self assert: (class whichSelectorsReferToInstanceVariable: 'name') isEmpty.! !

!RBMergeInstanceVariableIntoAnotherParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistingVariable
	self shouldFail: (self createRefactoringWithArguments: 
		{ 'classBlock' . 'anInstVar1' . RBBasicLintRuleTestData })! !

!RBMergeInstanceVariableIntoAnotherParametrizedTest methodsFor: 'failure tests' stamp: ''!
testEqualsVariables
	self shouldFail: (self createRefactoringWithArguments: 
		{ 'classBlock' . 'classBlock' . RBBasicLintRuleTestData })! !

!RBMergeInstanceVariableIntoAnotherParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBMergeInstanceVariableIntoAnother .
					  #constructor -> #rename:to:in: };
		addCase: { #rbClass -> RBMergeInstanceVariableIntoAnotherTransformation .
					  #constructor -> #renameInstanceVarible:to:in: };
		yourself! !

!RBMergeInstanceVariableIntoAnotherTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	class := self model classObjectFor: className.

	^ (RBCondition 
		withBlock: [ (variableName = newVariableName) 
			ifTrue: [ self refactoringFailure: 'The variable merged must be different' ].
		true ])
	& (isClassVariable
		ifTrue: [ (RBCondition isMetaclass: class) not 
					& (RBCondition definesClassVariable: newVariableName asString in: class) 
					& (RBCondition definesClassVariable: variableName asString in: class) ]
		ifFalse: [ (RBCondition definesInstanceVariable: newVariableName in: class) 
					& (RBCondition definesInstanceVariable: variableName in: class) ])
		& (RBCondition isGlobal: newVariableName in: self model) not! !

!RBMergeInstanceVariableIntoAnotherTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self renameReferences.
	isClassVariable
	ifTrue: [ self definingClass removeClassVariable: variableName ifAbsent: [ ^ self ] ]
	ifFalse: [ self definingClass removeInstanceVariable: variableName ifAbsent: [ ^ self ] ]
	! !

!RBMessageNode commentStamp: ''!
RBMessageNode is an AST node that represents a message send.

Instance Variables:
	arguments	<SequenceableCollection of: RBValueNode>	 our argument nodes
	receiver	<RBValueNode>	the receiver's node
	selector	<Symbol>	the selector we're sending
	keywordsPositions	<IntegerArray | nil>	the positions of the selector keywords

!
!RBMessageNode methodsFor: 'accessing' stamp: ''!
selectorAndArgumentNames
	"Returns the selector and argument names portion of a method as a string"

	^ self arguments
		ifEmpty: [ self keywords first ]
		ifNotEmpty: [
			(String streamContents: [ :st | 
				self selectorParts
			 		with: self arguments 
					do: [:sel :arg | 
							st 
								<< sel asString;
								<< ' ';
								<< arg formattedCode;
								<< ' ']]) allButLast ]! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
isFirstCascaded
	^self isCascaded and: [parent messages first == self]! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
keywordsIntervals
	^ self selector keywords
		with: self keywordsPositions 
		collect: [ :keyword :start | start to: (start == 0 ifTrue: [ -1 ] ifFalse: [ start + keyword size - 1]) ].! !

!RBMessageNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlineAndOr

	self methodCompilationContextOrNil ifNotNil:[:c | c optionInlineAndOr ifFalse: [ ^false ]]. 
	self receiver isBlock ifTrue: [^ false].
	self isCascaded ifTrue: [^ false].
	(#(and: or:) includes: self selector) ifFalse: [^ false].
	^self arguments allSatisfy: [ :each |  each isBlock and: [each arguments isEmpty ]]! !

!RBMessageNode methodsFor: 'comparing' stamp: ''!
hash
	^ (self receiver hash bitXor: self selector hash) bitXor: (self hashForCollection: self arguments)! !

!RBMessageNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlineCase
	self methodCompilationContextOrNil ifNotNil:[:c | c optionInlineCase ifFalse: [ ^false ]]. 
	self isCascaded ifTrue: [^ false].
	(#(caseOf: caseOf:otherwise:) includes: self selector) ifFalse: [^ false].
	self arguments size = 2 ifTrue: [  "otherwise block"
		self arguments last isBlock ifFalse: [^ false]].
	self arguments first isDynamicArray ifFalse: [^ false].
	self arguments first statements ifEmpty: [^ false].
	self arguments first statements do: [:assoc |
		(assoc isMessage and: [assoc selector == #->]) ifFalse: [^ false].
		assoc receiver isBlock ifFalse: [^ false].
		assoc receiver arguments isEmpty ifFalse: [^ false].
		assoc arguments first isBlock ifFalse: [^ false].
	].
	^ true! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
isSuperSend
	^ self receiver isSuperVariable! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
numArgs
	^self selector numArgs! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
receiver
	^receiver! !

!RBMessageNode methodsFor: 'initialization' stamp: ''!
receiver: aValueNode selector: aSelector keywordsPositions: positionList arguments: valueNodes
	aSelector numArgs == valueNodes size
		ifFalse: 
			[self error: 'Attempting to assign selector with wrong number of arguments.'].

	self 
		receiver: aValueNode;
		arguments: valueNodes;
		selector: aSelector;
		keywordsPositions: positionList.! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
children
	^(OrderedCollection with: receiver)
		addAll: arguments;
		yourself! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
renameSelector: newSelector andArguments: varNodeCollection 
	self
		arguments: varNodeCollection;
		selector: newSelector! !

!RBMessageNode methodsFor: 'private - replacing' stamp: ''!
replaceSourceWith: aNode 
	(self isContainmentReplacement: aNode) 
		ifTrue: [^self replaceContainmentSourceWith: aNode].
	aNode isMessage ifFalse: [^super replaceSourceWith: aNode].
	^self replaceSourceWithMessageNode: aNode! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
isCascaded
	^parent notNil and: [parent isCascade]! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
isUnary
	^arguments isEmpty! !

!RBMessageNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlineIfNil

	| assertNone assertOneOrNone |
	
	self methodCompilationContextOrNil ifNotNil:[:c | c optionInlineIfNil ifFalse: [ ^false ]]. 
	self receiver isBlock ifTrue: [^ false].
	self isCascaded ifTrue: [^ false].
	(#(ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) includes: self selector) ifFalse: [^ false].
	self arguments do: [:node | node isBlock ifFalse: [^ false]].
	assertNone := [:block | 
		block arguments isEmpty ifFalse: [^ false]
	].
	assertOneOrNone := [:block | 
		block arguments size > 1 ifTrue: [^ false]
	].
	self selector == #ifNil: 	
		ifTrue: [assertNone value: self arguments first].
	self selector == #ifNil:ifNotNil: 
		ifTrue: [assertNone value: self arguments first.  assertOneOrNone value: self arguments last].
	self selector == #ifNotNil: 
		ifTrue: [assertOneOrNone value: self arguments first].
	self selector == #ifNotNil:ifNil: 
		ifTrue: [assertOneOrNone value: self arguments first. assertNone value: self arguments last].
	^ true! !

!RBMessageNode methodsFor: 'private - replacing' stamp: ''!
replaceSourceWithMessageNode: aNode 
	| isBinaryToKeyword newSelectorParts  oldkeywordsIntervals|
	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: ')')]].
							
	newSelectorParts := aNode selectorParts.
	oldkeywordsIntervals := self keywordsIntervals.
	
	self selectorParts keysAndValuesDo: [:index :oldPart| 
			(newSelectorParts at: index) ~= oldPart
				ifTrue: 
					[self addReplacement: (RBStringReplacement 
								replaceFrom: (oldkeywordsIntervals at: index) first
								to: (oldkeywordsIntervals at: index) last
								with: ((isBinaryToKeyword 
										and: [(self source at: (oldkeywordsIntervals at: index) first - 1) isSeparator not]) 
											ifTrue: [' ' , newSelectorParts at: index]
											ifFalse: [newSelectorParts at: index]))]].! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
debugHighlightStop

	^ self stopWithoutParentheses! !

!RBMessageNode methodsFor: 'adding/removing' stamp: ''!
removeFromTree

	self parent removeNode: self! !

!RBMessageNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlineRepeat
	self methodCompilationContextOrNil ifNotNil:[:c | c optionInlineRepeat
		ifFalse: [ ^ false ]].
	self receiver isBlock
		ifFalse: [ ^ false ].
	self receiver arguments ifNotEmpty: [ ^ false ].
	self isCascaded
		ifTrue: [ ^ false ].
	#repeat = self selector
		ifFalse: [ ^ false ].
	^ true! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
needsParenthesis
	^parent 
		ifNil: [false]
		ifNotNil: 
			[self precedence > parent precedence 
				or: [self precedence = parent precedence and: [self isUnary not]]]! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
lastIsReturn
	(self isInlineIf or: [ self isInlineIfNil]) ifFalse: [ ^false ].
	arguments size = 1 ifTrue: [ ^false ].
	^ arguments first isBlock and: [ arguments first body lastIsReturn 
		and: [ arguments last isBlock and: [ arguments last body lastIsReturn ]]]! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
startWithoutParentheses
	^receiver start! !

!RBMessageNode methodsFor: 'comparing' stamp: ''!
equalTo: anObject withMapping: aDictionary 
	self class = anObject class ifFalse: [^false].
	((self receiver equalTo: anObject receiver withMapping: aDictionary)
		and: [self selector = anObject selector]) ifFalse: [^false].
	self arguments
		with: anObject arguments
		do: [:first :second | (first equalTo: second withMapping: aDictionary) ifFalse: [^false]].
	^true! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
selector
	^ selector value! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
arguments
	^arguments ifNil: [#()] ifNotNil: [arguments]! !

!RBMessageNode methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self receiver: self receiver copy.
	self arguments: (self arguments collect: [ :each | each copy ])! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
isHaltNode

	^ (#( #halt #halt: #haltIf: #haltOnce #haltIfNil #haltOnCount: ) 
		   includes: self selector) or: [ 
		  self receiver isGlobalVariable and: [ 
			  self receiver variable value = Halt and: [ 
				  (Halt class selectorsInCategory: #halting) includes:
					  self selector ] ] ]! !

!RBMessageNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlineToDo

	| block step |
	self methodCompilationContextOrNil ifNotNil:[:c | c optionInlineToDo ifFalse: [ ^false ]]. 

	self receiver isBlock ifTrue: [^ false].
	self isCascaded ifTrue: [^ false].
	(#(to:do: to:by:do:) includes: self selector) ifFalse: [^ false].
	block := self arguments last.
	block isBlock ifFalse: [^ false].
	block arguments size = 1 ifFalse: [^ false].
	self arguments first isVariable ifTrue: [ 
		(RBParseTreeSearcher new
			matches: self arguments first name , ' := `@object' do: [:n :a | true];
			executeTree: block initialAnswer: false) ifTrue: [^ false].
	].
	self arguments size = 3 "to:by:do:" ifTrue: [
		step := self arguments second.
		step isLiteralNode ifFalse: [^ false].
		step value = 0 ifTrue: [^ false].
	].
	^ true! !

!RBMessageNode methodsFor: '*ClassParser' stamp: ''!
extractClassDefinitionFor: aFluidParser

	aFluidParser setAdequateClassDefinitionFrom: self! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
selectorInterval
	| positions |
	positions := self keywordsIntervals. 
	^positions first first to: positions last last.! !

!RBMessageNode methodsFor: '*OpalCompiler-Core' stamp: ''!
methodCompilationContextOrNil
	^ self methodNode ifNotNil: [ :node | node compilationContext ]! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
argumentPartStrings
	"Return a collection of string representing the code of the argument."
	^ arguments collect: [ :each | each formattedCode asString 
			"strangely enough literal formatted code is not a string" ]! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
precedence
	^self isUnary 
		ifTrue: [1]
		ifFalse: [self isKeyword ifTrue: [3] ifFalse: [2]]! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
selectorNode
	^selector.! !

!RBMessageNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary 
	aNode class = self class ifFalse: [^false].
	self selector = aNode selector ifFalse: [^false].
	(receiver match: aNode receiver inContext: aDictionary) ifFalse: [^false].
	self arguments
		with: aNode arguments
		do: [:first :second | (first match: second inContext: aDictionary) ifFalse: [^false]].
	^true! !

!RBMessageNode methodsFor: 'private - replacing' stamp: ''!
isContainmentReplacement: aNode 
	^(self mappingFor: self receiver) = aNode 
		or: [self arguments anySatisfy: [:each | (self mappingFor: each) = aNode]]! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
stopWithoutParentheses
	^arguments isEmpty 
		ifTrue: [self keywordsIntervals first last]
		ifFalse: [arguments last stop]! !

!RBMessageNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [^true].
	self class = anObject class ifFalse: [^false].
	(self receiver = anObject receiver 
		and: [self selector = anObject selector]) ifFalse: [^false].
	self arguments
		with: anObject arguments
		do: [:first :second | first = second ifFalse: [^false]].
	^true! !

!RBMessageNode methodsFor: 'fluid parser' stamp: ''!
handleMetaclassName: aCDFluidClassDefinitionParser 
	aCDFluidClassDefinitionParser handleMetaclassNameFromMessage: self! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
keywordsPositions
	^keywordsPositions ifNil: [ IntegerArray new: self selector keywords size withAll: 0 ]! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
arguments: argCollection 
	arguments := argCollection.
	arguments do: [:each | each parent: self]! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
isFaulty
	^self receiver isFaulty or: [self arguments anySatisfy: [:each | each isFaulty]]! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
isKeyword
	^(self selector indexOf: $:) ~= 0.! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
isBinary
	^(self isUnary or: [self isKeyword]) not! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
sentMessages
	^ super sentMessages
		add: self selector;
		yourself! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
selectorParts
	"Returns a collection containing all the selector composing a message"
	
	^ self keywords collect: [ :each | each asSymbol]! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
isSelfSend
	^ self receiver isSelfVariable! !

!RBMessageNode methodsFor: 'querying' stamp: ''!
bestNodeFor: anInterval 
	| comments |
	(self intersectsInterval: anInterval) ifFalse: [ ^nil ] .
	(self containedBy: anInterval) ifTrue: [^self].
	self keywordsIntervals do:
			[:each | 
			((each rangeIncludes: anInterval first) 
				or: [anInterval rangeIncludes:  each first]) 
					ifTrue: [^self]].
	self children do: 
			[:each | 
			| node |
			(each intersectsInterval: anInterval) ifTrue: [node := each bestNodeFor: anInterval.
			node notNil ifTrue: [^node]]].
	comments := self methodNode getCommentsFor: anInterval.
	^comments size ~= 1 ifTrue: [ self ] ifFalse: [ comments first ]! !

!RBMessageNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlineWhile
	
	self methodCompilationContextOrNil ifNotNil:[:c | c optionInlineWhile ifFalse: [ ^false ]]. 
	self isCascaded ifTrue: [^ false].
	(#(whileFalse: whileTrue: whileFalse whileTrue) includes: self selector) ifFalse: [^ false].
	self receiver isBlock ifFalse: [^ false].
	self receiver arguments isEmpty ifFalse: [^ false].
	self arguments isEmpty ifFalse: [
		self arguments first isBlock ifFalse: [^ false].
		self arguments first arguments isEmpty ifFalse: [^ false].
	].
	^ true! !

!RBMessageNode methodsFor: '*NECompletion' stamp: ''!
completionToken: offset

	^ self selector! !

!RBMessageNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	"If we're inside a cascade node and are changing the receiver, change all the receivers"

	receiver == aNode 
		ifTrue: 
			[self receiver: anotherNode.
			(parent notNil and: [parent isCascade]) 
				ifTrue: [parent messages do: [:each | each receiver: anotherNode]]].
	self arguments: (arguments 
				collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
debugHighlightStart

	^ self  keywordsPositions first! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
leftmostChainReceiver

	^ self receiver isMessage
		ifTrue: [ self receiver receiver ]
		ifFalse: [ self receiver ]! !

!RBMessageNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitMessageNode: self! !

!RBMessageNode methodsFor: 'adding/removing' stamp: ''!
removeNode: aNode

	self replaceNode: aNode withNode: aNode receiver! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
keywordsPositions: aPositionsList
	keywordsPositions := aPositionsList ifNotNil: [:list| list asIntegerArray ].! !

!RBMessageNode methodsFor: '*NECompletion' stamp: ''!
completionEntries: offset
	| selectors |
	selectors := (receiver hasProperty: #type)
		ifTrue: [ (receiver propertyAt: #type) allSelectors ] 	
		ifFalse: [ Symbol selectorTable ].
		
	^selectors 
		select: [ :each | each beginsWith: self selector ] 
		thenCollect: [ :each | NECSelectorEntry contents: each node: self ]! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
selector: aSelector
	keywordsPositions := nil.
	selector := aSelector isString
		ifTrue: [ RBSelectorNode value: aSelector ]
		ifFalse: [ aSelector ].
	selector parent: self.! !

!RBMessageNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlineTimesRepeat

	| block |
	self methodCompilationContextOrNil ifNotNil:[:c | c optionInlineTimesRepeat ifFalse: [ ^false ]]. 

	self receiver isBlock ifTrue: [^ false].
	self isCascaded ifTrue: [^ false].
	#timesRepeat: = self selector ifFalse: [^ false].
	block := self arguments last.
	block isBlock ifFalse: [^ false].
	block arguments ifNotEmpty: [^ false].
	^ true! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
keywords
	^ self selector keywords.! !

!RBMessageNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlineIf

	self methodCompilationContextOrNil ifNotNil: [ :c | 
		c optionInlineIf ifFalse: [ ^ false ] ].
	self receiver isBlock ifTrue: [ ^ false ].
	self isCascaded ifTrue: [ ^ false ].
	(#( #ifTrue: #ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue: ) includes: self selector) ifFalse: [ ^ false ].
	^ self arguments allSatisfy: [ :node | node isBlock and: [ node arguments isEmpty ]]! !

!RBMessageNode methodsFor: 'accessing' stamp: ''!
receiver: aValueNode 
	receiver := aValueNode.
	receiver parent: self! !

!RBMessageNode methodsFor: 'testing' stamp: ''!
isMessage
	^true! !

!RBMessageNode methodsFor: 'private - replacing' stamp: ''!
replaceContainmentSourceWith: aNode 
	| originalNode needsParenthesis |
	needsParenthesis := aNode hasParentheses not and: [aNode needsParenthesis].
	originalNode := (self mappingFor: self receiver) = aNode 
				ifTrue: [self receiver]
				ifFalse: [self arguments detect: [:each | (self mappingFor: each) = aNode]].
	self
		addReplacement: (RBStringReplacement 
					replaceFrom: self start
					to: originalNode start - 1
					with: (needsParenthesis ifTrue: ['('] ifFalse: ['']));
		addReplacement: (RBStringReplacement 
					replaceFrom: originalNode stop + 1
					to: self stop
					with: (needsParenthesis ifTrue: [')'] ifFalse: ['']))! !

!RBMessageNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	^self class
		receiver: (self receiver copyInContext: aDictionary)
		selector: self selectorNode
		arguments: (self arguments collect: [ :each | each copyInContext: aDictionary ])! !

!RBMessageNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isInlined 
	self methodCompilationContextOrNil ifNotNil:[:c | c optionInlineNone ifTrue: [ ^false ]]. 
	self isInlineIf ifTrue: [^true].
	self isInlineIfNil  ifTrue: [^true]. 
	self isInlineAndOr  ifTrue: [^true].
	self isInlineWhile ifTrue: [^true].
	self isInlineToDo  ifTrue: [^true].
	self isInlineCase  ifTrue: [^true].
	self isInlineTimesRepeat ifTrue: [^true].
	self isInlineRepeat ifTrue: [^true].
	^false.! !

!RBMessageNode class methodsFor: 'instance creation' stamp: ''!
receiver: aValueNode selector: aSelector 
	^self 
		receiver: aValueNode
		selector: aSelector
		arguments: #()! !

!RBMessageNode class methodsFor: 'instance creation' stamp: ''!
receiver: aValueNode selector: aSelector arguments: valueNodes 
	^self
		receiver: aValueNode
		selector: aSelector
		keywordsPositions: nil
		arguments: valueNodes.! !

!RBMessageNode class methodsFor: 'instance creation' stamp: ''!
receiver: aValueNode selector: aSelector keywordsPositions: positionList arguments: valueNodes
	^(self new)
		receiver: aValueNode
			selector: aSelector
			keywordsPositions: positionList 
			arguments: valueNodes;
		yourself.! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testArgumentPartsForKeywordMessages2

		| tree message |
		tree := self parseMethod: 'test self between: x and: y'.
		message := tree sendNodes first.
		self assert: message argumentPartStrings asArray equals: #('x' 'y').
		
		tree := self parseMethod: 'test self between: x and: y and: zzz'.
		message := tree sendNodes first.
		self assert: message argumentPartStrings asArray equals: #('x' 'y' 'zzz')! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testSelectorPartsForBinaryMessages
	| tree message |
	tree := self parseMethod: 'test 1 + 2 '.
	message := tree sendNodes first.
	self assert: message selectorParts equals: #(#+).! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testSelectorPartsForUnaryMessages
		| tree message |
		tree := self parseMethod: 'test self doit'.
		message := tree sendNodes first.
		self assert: message selectorParts equals: #(#doit).! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testSelectorAndArgumentNamesForComposedKeywordsAndComplexArgs
		| tree message |
		tree := self parseMethod: 'test self between: x + 2 and: (y foo: 3)'.
		message := tree sendNodes first.
		self assert: message selectorAndArgumentNames equals: 'between: x + 2 and: (y foo: 3)'.! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testSelectorInterval
		| tree message |
		tree := self parseMethod: 'test self doit'.
		message := tree sendNodes first.
		self assert: message selectorInterval equals: (11 to: 14).
		tree := self parseMethod: 'test self doit: #nice with: 5'.
		message := tree sendNodes first.
		self assert: message selectorInterval equals: (11 to: 27).! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testSelectorPartsForKeywordMessages
		| tree message |
		tree := self parseMethod: 'test self doit: 5'.
		message := tree sendNodes first.
		self assert: message selectorParts equals: #(#doit:).
		
		tree := self parseMethod: 'test self between: 0 and: 5 '.
		message := tree sendNodes first.
		self assert: message selectorParts equals: #(#between: #and:).! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testSelectorAndArgumentNamesForUnary
		| tree message |
		tree := self parseMethod: 'test self doit'.
		message := tree sendNodes first.
		self assert: message selectorAndArgumentNames equals: 'doit'! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testArgumentPartsForKeywordMessages1
	| tree message |
	tree := self parseMethod: 'test self between: 2 and: 3'.
	message := tree sendNodes first.
	self assert: message argumentPartStrings asArray equals: #('2' '3').! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testArgumentPartsForUnaryMessages
	| tree message |
	tree := self parseMethod: 'test 1 foo '.
	message := tree sendNodes first.
	self assert: message argumentPartStrings equals: #().! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testSelectorAndArgumentNamesForComposedKeywords
		| tree message |
		tree := self parseMethod: 'test self between: x and: y'.
		message := tree sendNodes first.
		self assert: message selectorAndArgumentNames equals: 'between: x and: y'.
		
		tree := self parseMethod: 'test self between: x and: y and: zzz'.
		message := tree sendNodes first.
		self assert: message selectorAndArgumentNames equals: 'between: x and: y and: zzz'! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testSelectorAndArgumentNamesForSimpleKeywords
		| tree message |
		tree := self parseMethod: 'test self doit: 5'.
		message := tree sendNodes first.
		self assert: message selectorAndArgumentNames equals: 'doit: 5'! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testArgumentPartsForBinaryMessages
	| tree message |
	tree := self parseMethod: 'test 1 + 2 '.
	message := tree sendNodes first.
	self assert: message argumentPartStrings equals: #('2').! !

!RBMessageNodeTest methodsFor: 'tests' stamp: ''!
testArgumentPartsForKeywordMessages
	| tree message |
	tree := self parseMethod: 'test self between: x + 2 and: (y foo: 3)'.
	message := tree sendNodes first.
	self assert: message argumentPartStrings asArray equals: #('x + 2' '(y foo: 3)')! !

!RBMetaclass commentStamp: ''!
I represent the class side of a class in a refactoring namespace. 

I shouldn't be created directly, but always be part of a refactoring namespace.
My  namespace usally knows me and my non meta class.!
!RBMetaclass methodsFor: 'accessing - deprecated' stamp: ''!
theMetaClass
	^ self! !

!RBMetaclass methodsFor: 'initialization' stamp: ''!
realName: aSymbol 
	self realClass: (self model environment at: aSymbol) classSide! !

!RBMetaclass methodsFor: 'accessing' stamp: ''!
classSide
	"Return the metaclass of the couple class/metaclass. Useful to avoid explicit test." 
	
	^ self! !

!RBMetaclass methodsFor: 'accessing' stamp: ''!
allClassVariableNames
	^ self instanceSide allClassVariableNames! !

!RBMetaclass methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' class'! !

!RBMetaclass methodsFor: 'testing' stamp: ''!
directlyDefinesClassVariable: aString

	^ self instanceSide directlyDefinesClassVariable: aString! !

!RBMetaclass methodsFor: 'testing' stamp: ''!
isMeta
	^true! !

!RBMetaclass methodsFor: 'accessing' stamp: ''!
allPoolDictionaryNames
	^ self instanceSide allPoolDictionaryNames! !

!RBMetaclass methodsFor: 'testing' stamp: ''!
directlyDefinesPoolDictionary: aString 
	^ self instanceSide directlyDefinesPoolDictionary: aString! !

!RBMetaclass methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	super storeOn: aStream.
	aStream nextPutAll: ' class'! !

!RBMetaclass class methodsFor: 'instance creation' stamp: ''!
named: aSymbol 
	^(self new)
		name: aSymbol;
		yourself! !

!RBMetaclass class methodsFor: 'instance creation' stamp: ''!
existingNamed: aSymbol model: aRBNamespace
	^ (self named: aSymbol)
		model: aRBNamespace;
		realName: aSymbol;
		yourself 
	! !

!RBMetaclass class methodsFor: 'instance creation' stamp: ''!
existingNamed: aSymbol 
	^(self named: aSymbol)
		realName: aSymbol;
		yourself! !

!RBMethod commentStamp: ''!
I represent a method for the refactoring framework.

I am used by RBClass / RBMetaclass resp. RBAbstractClass for methods created or changed during a refactoring operation.
I represent the method with a selector, source and if I am created from an existing method, its 
CompiledMethod. 
I know my method class (a RBClass or RBMetaclass). 
You should not directly create instances of me but query or create a method from a RBClass.

I only implement a small part of  CompiledMethod interface, that is used for refactoring operations, like querying symbols, literals or the whole method source.
!
!RBMethod methodsFor: 'accessing' stamp: ''!
isFromTrait: anObject
	isFromTrait := anObject! !

!RBMethod methodsFor: 'accessing' stamp: ''!
ast
	^ self parseTree! !

!RBMethod methodsFor: 'accessing' stamp: ''!
methodClass

	^ class! !

!RBMethod methodsFor: 'accessing' stamp: ''!
method
	^compiledMethod! !

!RBMethod methodsFor: 'testing' stamp: ''!
parserTreeSearcher
	^ self parseTreeSearcherClass new! !

!RBMethod methodsFor: 'testing' stamp: ''!
refersToClassNamed: aSymbol
	| searcher |
	searcher := self parserTreeSearcher.
	searcher matches: aSymbol asString do: [ :node :answer | true ].
	^ (searcher executeTree: self parseTree initialAnswer: false)
		or: [ self refersToSymbol: aSymbol ]! !

!RBMethod methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!RBMethod methodsFor: 'accessing' stamp: ''!
isFromTrait
	^ isFromTrait ifNil: [ isFromTrait := false ]! !

!RBMethod methodsFor: 'testing' stamp: ''!
refersToSymbol: aSymbol
	| searcher |
	searcher := self parserTreeSearcher.
	searcher
		matches: aSymbol printString do: [ :node :answer | true ];
		matches: '`#literal'
			do:
				[ :node :answer | answer or: [ self literal: node value containsReferenceTo: aSymbol ] ].
	aSymbol isValidSelector
		ifTrue: [ searcher
				matches:
					'`@object '
						, (self parseTreeSearcherClass buildSelectorString: aSymbol)
				do: [ :node :answer | true ] ].
	^ searcher executeTree: self parseTree initialAnswer: false! !

!RBMethod methodsFor: 'private' stamp: ''!
literal: anObject containsReferenceTo: aSymbol
	anObject = aSymbol
		ifTrue: [ ^ true ].
	anObject class = Array
		ifFalse: [ ^ false ].
	^ anObject anySatisfy: [ :each | self literal: each containsReferenceTo: aSymbol ]! !

!RBMethod methodsFor: 'compiling' stamp: ''!
compileTree: aBRMethodNode
	| method sourceCode change |
	sourceCode := aBRMethodNode newSource.
	change := self modelClass model
		compile: sourceCode
		in: self modelClass
		classified: self protocols.
	method := self class
		for: self modelClass
		source: sourceCode
		selector: aBRMethodNode selector.
	self modelClass addMethod: method.
	^ change! !

!RBMethod methodsFor: 'accessing' stamp: ''!
selector: aSymbol 
	selector := aSymbol! !

!RBMethod methodsFor: 'printing' stamp: ''!
printOn: aStream 
	class printOn: aStream.
	aStream
		nextPutAll: '>>';
		nextPutAll: self selector! !

!RBMethod methodsFor: 'accessing' stamp: ''!
source
	^ source ifNil: [ source := (class realClass sourceCodeAt: selector) asString ]! !

!RBMethod methodsFor: 'testing' stamp: ''!
parseTreeSearcherClass
	^ RBParseTreeSearcher! !

!RBMethod methodsFor: 'testing' stamp: ''!
refersToVariable: aString
	| searcher tree |
	tree := self parseTree.
	((tree defines: aString) or: [ tree body defines: aString ])
		ifTrue: [ ^ false ].
	searcher := self parserTreeSearcher.
	searcher
		matches: aString do: [ :node :answer | true ];
		matches: '[:`@vars | | `@temps | `@.Stmts]'
			do: [ :node :answer | 
			answer
				or: [ ((node defines: aString) or: [ node body defines: aString ]) not
						and: [ searcher executeTree: node body initialAnswer: false ] ] ].
	^ searcher executeTree: self parseTree initialAnswer: false! !

!RBMethod methodsFor: 'accessing' stamp: ''!
modelClass
	^class! !

!RBMethod methodsFor: 'accessing' stamp: ''!
protocols
	^ self modelClass protocolsFor: self selector! !

!RBMethod methodsFor: 'accessing' stamp: ''!
method: aCompiledMethod 
	compiledMethod := aCompiledMethod.
	self isFromTrait: compiledMethod isFromTrait.! !

!RBMethod methodsFor: 'accessing' stamp: ''!
source: aString 
	source := aString! !

!RBMethod methodsFor: 'accessing' stamp: ''!
package
	compiledMethod ifNotNil: [ ^ compiledMethod package name ].
	^ class category! !

!RBMethod methodsFor: 'accessing' stamp: ''!
modelClass: aRBClass
	class := aRBClass! !

!RBMethod methodsFor: 'accessing' stamp: ''!
parseTree
	^ self parserClass parseMethod: self source onError: [:str :pos | ^nil]! !

!RBMethod class methodsFor: 'instance creation' stamp: ''!
for: aRBClass source: aString selector: aSelector 
	^(self new)
		modelClass: aRBClass;
		selector: aSelector;
		source: aString;
		yourself! !

!RBMethod class methodsFor: 'instance creation' stamp: ''!
for: aRBClass fromMethod: aCompiledMethod andSelector: aSymbol 
	^ self new 
		modelClass: aRBClass;
		method: aCompiledMethod;
		selector: aSymbol;
		yourself! !

!RBMethodArgumentsSelector commentStamp: ''!
I am an editor to select values in a method that should be passed as arguments.

Usage:
RBMethodArgumentsSelector
	openOn: { 'argumentList' }
	and: { '#argumentList' }
	in: (RBParser parseMethod: 'update: argumentList
		self changed: #argumentList;
			changed: #argumentIndex.
		self changed: #isUpEnabled;
			changed: #isDownEnabled;
			changed: #isOkEnabled.
		labelMorph contents: self methodName printString')!
!RBMethodArgumentsSelector methodsFor: 'initialization' stamp: ''!
initializeWith: aCollection and: anotherCollection in: aTree

	arguments := aCollection.
	values := anotherCollection.
	tree := aTree.
	
	argsAndValues := Dictionary new.
	
	self initialize.
	self title: 'There are extra arguments in this method. Please map a value to each extra argument.' translated! !

!RBMethodArgumentsSelector methodsFor: 'actions' stamp: ''!
removeAssociation

	[  | association argument value |
		association := argsAndValues associations at: self associationIndex.
		argument := association key.
		value := association value.
		
		"replace occurrences in code"
		tree := RBParseTreeRewriter 
			replace: argument
			with: value in: tree.

		"remove entry"
		argsAndValues removeKey: argument.
		argumentsList add: argument.
		valuesList add: value.
		
		sourceCodeMorph contents: self sourceCode.
		self changed: #associations; changed: #arguments;
				changed: #values; changed: #isOkEnabled ]
	on: Error do: [ self inform: 'Please select one association to remove.' ]
	! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
sourceCode

	^ tree formattedCode! !

!RBMethodArgumentsSelector methodsFor: 'actions' stamp: ''!
newContentMorph

	^ (self newColumn: { 
		(self newRow: {
			"the arguments"
			self newGroupbox: 'Arguments' for: (self newColumn: {
				(self newListFor: self
					list: #arguments
					selected: #argumentIndex
					changeSelected: #argumentIndex:
					help: nil)
					hResizing: #spaceFill;
					yourself }).
					
			"the values"
			self newGroupbox: 'Values' for: (self newColumn: {
				(self newListFor: self
					list: #values
					selected: #valueIndex
					changeSelected: #valueIndex:
					help: nil)
					hResizing: #spaceFill;
					yourself }).
					
			"add an association"
			(self newRow: {
				self newButtonFor: self action: #addAssociation 
					label: 'v' help: 'Map'.})
				hResizing: #shrinkWrap}).
				
		"source code preview"
		(self newRow: {
			self newGroupbox: 'Preview' for: (self newColumn: {
				sourceCodeMorph := (self newText: tree formattedCode)
					extent: 400@400;
					hResizing: #rigid }) }).
				
		"associations"
		(self newRow: {
			self newGroupbox: 'Associations' for: (self newColumn: {
				(self newListFor: self
					list: #associations
					selected: #associationIndex
					changeSelected: #associationIndex:
					help: nil)
					hResizing: #spaceFill;
					yourself. }).
					
		"remove association"
		(self newRow: {
			self newButtonFor: self action: #removeAssociation
				label: '^' help: 'Unmap'.})
			hResizing: #shrinkWrap }).		
		
	 }) vResizing: #shrinkWrap
! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
valueIndex: anInteger

	selectedValueIndex := anInteger.
	self changed: #valueIndex! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
argumentIndex

	^ selectedArgumentIndex ifNil: [ selectedArgumentIndex := 0 ]! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
associations

	^ argsAndValues associations collect: [:each | each asString ]! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
arguments

	^ argumentsList ifNil: [ argumentsList := arguments asOrderedCollection ]! !

!RBMethodArgumentsSelector methodsFor: 'testing' stamp: ''!
isOkEnabled

	^ argumentsList isEmpty! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
associationIndex: anInteger

	selectedAssociationIndex := anInteger.
	self changed: #associationIndex! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
associationIndex

	^ selectedAssociationIndex ifNil: [ selectedAssociationIndex := 0 ]! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
valueIndex

	^ selectedValueIndex ifNil: [ selectedValueIndex := 0 ]! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
newTree

	^ tree! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
values

	^ valuesList ifNil: [ valuesList := values asOrderedCollection ]! !

!RBMethodArgumentsSelector methodsFor: 'controls' stamp: ''!
newOKButton

	^ self newOKButtonFor: self getEnabled: #isOkEnabled! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
argumentsAndValues

	^ argsAndValues! !

!RBMethodArgumentsSelector methodsFor: 'accessing' stamp: ''!
argumentIndex: anInteger

	selectedArgumentIndex := anInteger.
	self changed: #argumentIndex! !

!RBMethodArgumentsSelector methodsFor: 'actions' stamp: ''!
addAssociation

	[  | argument value |
		argument := argumentsList at: self argumentIndex.
		value := valuesList at: self valueIndex.
			
		"replace occurrences in code"
		tree := RBParseTreeRewriter 
			replace: value
			with: argument in: tree.
		
		"add new entry"
		argsAndValues at: argument put: value.
		"remove from lists"
		argumentsList removeAt: self argumentIndex.
		valuesList removeAt: self valueIndex.
		
		sourceCodeMorph contents: self sourceCode.
		self changed: #associations; changed: #arguments; 
				changed: #values; changed: #isOkEnabled ]
	on: Error do: [ self inform: 'Please select one argument and one value.' ]
	! !

!RBMethodArgumentsSelector class methodsFor: 'instance creation' stamp: ''!
openOn: arguments and: values in: sourceCode

	^ (self 
		on: arguments
		and: values
		in: sourceCode) openModal! !

!RBMethodArgumentsSelector class methodsFor: 'instance creation' stamp: ''!
on: arguments and: values in: sourceCode

	^ self basicNew
		initializeWith: arguments
		and: values
		in: sourceCode! !

!RBMethodName commentStamp: ''!
I represent a method name (selector and arguments) in the refactoring framework.

I am used by refactoring operations - for example RBMoveMethodRefactoring.

I have a selector name and a list of arguments and I use RBScanner to validate the syntax of my selector name.

In the refactory framework I am used for representing a new method name, generated by the refactoring operation or requested by the caller.

You can create instances of me by 
RBMethodName selector: 'color:' arguments:{'aColor'}.
(RBMethodName selector:'color' arguments:{}) isValid.!
!RBMethodName methodsFor: 'accessing' stamp: ''!
newArgs

	^ newArgs ifNil: [ newArgs := { } ]! !

!RBMethodName methodsFor: 'accessing' stamp: ''!
arguments
	^arguments! !

!RBMethodName methodsFor: 'accessing' stamp: ''!
selector
	^selector! !

!RBMethodName methodsFor: 'accessing' stamp: ''!
arguments: nameCollection 
	arguments := nameCollection.
	self changed: #arguments! !

!RBMethodName methodsFor: 'accessing' stamp: ''!
permutation

	^ permutation ifNil: [ permutation := 1 to: arguments size ]! !

!RBMethodName methodsFor: 'accessing' stamp: ''!
selector: aSymbol 
	selector := aSymbol asSymbol.
	self changed: #selector! !

!RBMethodName methodsFor: 'accessing' stamp: ''!
renameMap: anObject

	renameMap := anObject! !

!RBMethodName methodsFor: 'printing' stamp: ''!
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: 'accessing' stamp: ''!
permutation: anObject

	permutation := anObject! !

!RBMethodName methodsFor: 'accessing' stamp: ''!
newArgs: anObject

	newArgs := anObject! !

!RBMethodName methodsFor: 'testing' stamp: ''!
isValid
	"Return whether the receiver looks like a method with a selector in sync with the arguments in a possible class"
	
	^ 	selector isString and: [ selector isValidSelector
			and: [ selector numArgs = arguments size ]]! !

!RBMethodName methodsFor: 'accessing' stamp: ''!
renameMap

	^ renameMap ifNil: [ renameMap := {  } ]! !

!RBMethodName methodsFor: '*SystemCommands-RefactoringSupport' stamp: ''!
methodName
	^ String streamContents: [ :s | self printOn: s ]! !

!RBMethodName class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol arguments: stringCollection 
	^ self new 
			selector: aSymbol;
			arguments: stringCollection;
			yourself! !

!RBMethodNameEditor commentStamp: ''!
A MethodNameEditor is an editor to set the name of a method.


	MethodNameEditor openOn: (RBMethodName selector: #foo: arguments: #('x')) !
!RBMethodNameEditor methodsFor: 'actions' stamp: ''!
cancel
	methodName := nil.
	^ super cancel! !

!RBMethodNameEditor methodsFor: 'morphic' stamp: ''!
newContentMorph

	^ labelGroup := (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];
				hResizing: #spaceFill;
				yourself).
				
			'Arguments:' -> (self newRow: {
				(self newColumn: {
					self newButtonFor: self action: #add label: '+'  help: nil.
					self newButtonFor: self action: #remove label: '-'  help: nil })
					hResizing: #shrinkWrap.
				(self newListFor: self list: #argumentList
					selected: #argumentIndex
					changeSelected: #argumentIndex: help: nil)
					hResizing: #spaceFill;
					yourself. }).
					
			'Preview:' -> (labelMorph := self newLabel: self methodName printString) } } )
 		minWidth: 400;
		hResizing: #spaceFill;
		yourself! !

!RBMethodNameEditor methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	self beResizeable! !

!RBMethodNameEditor methodsFor: 'accessing' stamp: ''!
argumentIndex
	^ argumentIndex! !

!RBMethodNameEditor methodsFor: 'testing' stamp: ''!
isDownEnabled
	^ self argumentIndex ~= 0 and: [ self argumentIndex + 1 between: 1 and: self argumentList size ]! !

!RBMethodNameEditor methodsFor: 'grips' stamp: ''!
addGrips

	self addEdgeGrips! !

!RBMethodNameEditor methodsFor: 'focus handling' stamp: ''!
defaultFocusMorph
	"Answer the morph that should have the keyboard
	focus by default when the dialog is opened."
	
	^ selectorField
		ifNil: [ super defaultFocusMorph ]! !

!RBMethodNameEditor methodsFor: 'grips' stamp: ''!
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
! !

!RBMethodNameEditor methodsFor: 'testing' stamp: ''!
isOkEnabled

	^ self methodName isNotNil
		and: [ self methodName isValid ]! !

!RBMethodNameEditor methodsFor: 'accessing' stamp: ''!
argumentList

	^ self methodName
		ifNil: [ OrderedCollection new ]
		ifNotNil: [ :method | method arguments copy ]! !

!RBMethodNameEditor methodsFor: 'accessing' stamp: ''!
selector

	^ self methodName ifNotNil: [ :method | method selector ]! !

!RBMethodNameEditor methodsFor: 'accessing' stamp: ''!
selector: aString

	super selector: aString.
	(labelGroup extent x > self extent x) ifTrue: [
		self extent: ((labelGroup extent x+20) @ labelGroup extent y) ]
	
	! !

!RBMethodNameEditor methodsFor: 'morphic' stamp: ''!
update
	self changed: #argumentList; changed: #argumentIndex.
	self changed: #isUpEnabled; changed: #isDownEnabled; changed: #isOkEnabled.
	labelMorph contents: self methodName printString! !

!RBMethodNameEditor methodsFor: 'actions' stamp: ''!
add

	| newArguments |
	newArguments := self argumentList.
	newArguments add: ('arg', (newArguments size + 1) asString).
	
	self methodName arguments: newArguments.
	self update! !

!RBMethodNameEditor methodsFor: 'accessing' stamp: ''!
methodName
	^ methodName! !

!RBMethodNameEditor methodsFor: 'actions' stamp: ''!
down
	self isDownEnabled ifFalse: [ ^ self ].
	self argumentList swap: self argumentIndex with: self argumentIndex + 1.
	self argumentIndex: self argumentIndex + 1! !

!RBMethodNameEditor methodsFor: 'actions' stamp: ''!
remove

	| newArguments |
	newArguments := self argumentList.
	newArguments removeAt: self argumentIndex.
	
	self methodName arguments: newArguments.
	self update! !

!RBMethodNameEditor methodsFor: 'morphic' stamp: ''!
newOKButton
	^ self newOKButtonFor: self getEnabled: #isOkEnabled! !

!RBMethodNameEditor methodsFor: 'actions' stamp: ''!
up
	self isUpEnabled ifFalse: [ ^ self ].
	self argumentList swap: self argumentIndex with: self argumentIndex - 1.
	self argumentIndex: self argumentIndex - 1! !

!RBMethodNameEditor methodsFor: 'testing' stamp: ''!
isUpEnabled
	^ self argumentIndex ~= 0 and: [ self argumentIndex - 1 between: 1 and: self argumentList size ]! !

!RBMethodNameEditor methodsFor: 'accessing' stamp: ''!
argumentIndex: anInteger
	argumentIndex := anInteger.
	self update! !

!RBMethodNameEditor methodsFor: 'initialization' stamp: ''!
initializeOn: aMethodName
	methodName := aMethodName.
	argumentIndex := 0.
	self initialize.
	self title: 'Method Name'! !

!RBMethodNameEditor class methodsFor: 'instance creation' stamp: ''!
openOn: aMethodName
	^ (self on: aMethodName) openModal! !

!RBMethodNameEditor class methodsFor: 'instance creation' stamp: ''!
on: aMethodName
	^ self basicNew initializeOn: aMethodName! !

!RBMethodNameTest methodsFor: 'tests' stamp: ''!
testCreation 
	"Yes this is stupid test but it would have save time to understand what should be passed as argument!!"
	
	| rbmethod |
	rbmethod := RBMethodName selector: #foo: arguments: #('x').
	self assert: rbmethod selector equals: #foo:.
	self assert: rbmethod arguments equals: #('x').
	! !

!RBMethodNameTest methodsFor: 'tests' stamp: ''!
testIsValid
	"A valid RBMethodName is a method name with a valid selector and corresponding arguments"
	
	| rbmethod |
	rbmethod := RBMethodName selector: #foo: arguments: #('x').
	self assert: rbmethod isValid.
	
	rbmethod := RBMethodName selector: #foo:arg: arguments: #('x' 'y').
	self assert: rbmethod isValid.
	
	rbmethod := RBMethodName selector: #foo:arg: arguments: #('x').
	self deny: rbmethod isValid.
	
	rbmethod := RBMethodName selector: #foo: arguments: #('x' 'y').
	self deny: rbmethod isValid.
	
	
	rbmethod := RBMethodName selector: 'fggfg gg g ' arguments: #('x').
	self deny: rbmethod isValid.! !

!RBMethodNode commentStamp: ''!
RBMethodNode is the node that represents AST of a Smalltalk method.

Some properties aren't known to the parser creating this Object. For example, the scope value isn't known by parsing the code but only after doing a
semantic analysis. Likewise, the compilation context isn't needed until we try to do the semantic analysis. 

Instance Variables:
	arguments	<SequenceableCollection of: RBVariableNode>	the arguments to the method
	body	<BRSequenceNode>	the body/statements of the method
	nodeReplacements	<Dictionary>	a dictionary of oldNode -> newNode replacements
	replacements	<Collection of: RBStringReplacement>	the collection of string replacements for each node replacement in the parse tree
	selector	<Symbol>	the method name
	keywordsPositions	<IntegerArray | nil>	the positions of the selector keywords
	source	<String>	the source we compiled
	scope	<OCMethodScope | nil> the scope associated with this code of this method
	pragmas	< SequenceableCollection of: RBPragmaNodes > Nodes representing the pragma statements in this method
	compilationContext	<CCompilationContext | CompilationContext>
!
!RBMethodNode methodsFor: 'accessing' stamp: ''!
methodOrBlockNode
	^ self! !

!RBMethodNode methodsFor: 'accessing - compiled method' stamp: ''!
methodClass

	^ self compilationContext ifNotNil: [ :ctxt | ctxt getClass ]! !

!RBMethodNode methodsFor: 'replacing' stamp: ''!
clearReplacements
	replacements := nil! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
children
	^ OrderedCollection new
		addAll: arguments;
		addAll: pragmas;
		add: body;
		yourself! !

!RBMethodNode methodsFor: 'tree accessing' stamp: ''!
parentOfSubtree: subtree

	| sourceCode |
	sourceCode := subtree formattedCode.
	^ self allChildren reversed
		detect: [ :e | e formattedCode includesSubstring: sourceCode ]
		ifFound: [ :e | e parent ] 
		ifNone: [ nil ]! !

!RBMethodNode methodsFor: 'converting' stamp: ''!
asSequenceNode
	^body! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
generate: trailer
	"if the bytecode is regenerated, we need to reset the cache"
	bcToASTCache := nil.
	^ self generateIR compiledMethodWith: trailer.! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
allDefinedVariables
	^(self argumentNames asOrderedCollection)
		addAll: super allDefinedVariables;
		yourself! !

!RBMethodNode methodsFor: 'tree accessing' stamp: ''!
extractSubtreeWith: aSourceCode
	| extractedTree |
	extractedTree := self parserClass
		parseExpression: aSourceCode
		onError: [ :string :pos | ^ nil ].
	extractedTree ifNil: [ ^ nil ].
	(extractedTree isSequence and: [ extractedTree statements isEmpty ])
		ifTrue: [ ^ nil ].
	extractedTree := extractedTree isSequence
		ifTrue:
			[ RBParseTreeSearcher treeMatchingStatements: aSourceCode in: self ]
		ifFalse:
			[ RBParseTreeSearcher treeMatching: aSourceCode in: self ].	"or: [aTree isReturn]"
	^ extractedTree
		ifNotNil: [ extractedTree parent: (self parentOfSubtree: extractedTree) ]! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
generateWithSource
	"Answer a CompiledMethod with source encoded in trailer."
	^self generate: (CompiledMethodTrailer new sourceCode: source).! !

!RBMethodNode methodsFor: 'replacing' stamp: ''!
map: oldNode to: newNode 
	nodeReplacements at: oldNode put: newNode! !

!RBMethodNode methodsFor: 'completion' stamp: ''!
completionToken
	^ self selector! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
methodPropertyAt: aKey put: anObject
	| existingProperties newProperties |
	existingProperties := self propertyAt: #methodProperties ifAbsentPut: [ 
		AdditionalMethodState forSelector: self selector].
	
	existingProperties at: aKey ifPresent: [:existingValue |
		existingProperties at: aKey put: anObject.
		^self].
	
	newProperties := existingProperties copyWith: aKey -> anObject.
	self propertyAt: #methodProperties put: newProperties! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
temporaryNames
	^ self body temporaryNames! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
pragmas: aCollection
	pragmas := aCollection.
	pragmas do: [ :each | each parent: self ]! !

!RBMethodNode methodsFor: 'comparing' stamp: ''!
equalTo: anObject withMapping: aDictionary 
	self class = anObject class ifFalse: [ ^ false ].
	(self selector = anObject selector
		and: [ self pragmas size = anObject pragmas size
		and: [ self body equalTo: anObject body withMapping: aDictionary ] ]) 
			ifFalse: [ ^ false ].
	self arguments with: anObject arguments do: [ :first :second |
		(first equalTo: second	withMapping: aDictionary)
			ifFalse: [ ^ false ].
		aDictionary removeKey: first name ].
	self pragmas with: anObject pragmas do: [ :first :second |
		(first equalTo: second	withMapping: aDictionary) 
			ifFalse: [ ^ false ] ].
	^ true! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
temporaries
	^ self body temporaries! !

!RBMethodNode methodsFor: '*Reflectivity' stamp: ''!
metaLinkOptions
	^{
	#metaLinkOptionsFromClassAndMethod -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!RBMethodNode methodsFor: '*Reflectivity' stamp: ''!
hasOption: aSymbol for: aLink
	"take the class and method overrides to options into account"
	^(self optionsFor: aLink) includes: aSymbol.! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
allStatements
	"return the statements including variable definition."
	^ self temporaries asOrderedCollection copy
			addAll: super allStatements;
			yourself! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
irInstruction
	^ self ir! !

!RBMethodNode methodsFor: 'replacing' stamp: ''!
mappingFor: oldNode 
	^nodeReplacements at: oldNode ifAbsent: [oldNode]! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
primitiveFromPragma
	^ pragmas
		detect: [ :each | each isPrimitive ]
		ifFound: [ :aPragmaPrimitive | aPragmaPrimitive asIRPrimitive ]
		ifNone: [ IRPrimitive null ]! !

!RBMethodNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary 
	self class = aNode class ifFalse: [ ^ false ].
	aDictionary at: '-source-' put: aNode source.
	self selector = aNode selector ifFalse: [ ^ false ].
	^ (self matchList: arguments against: aNode arguments inContext: aDictionary)
		and: [ (self matchPragmas: self pragmas against: aNode pragmas inContext: aDictionary)
		and: [ body match: aNode body inContext: aDictionary ] ]! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
pragmas
	^ pragmas! !

!RBMethodNode methodsFor: 'iterating' stamp: ''!
allSequenceNodes

	^ self allChildren select: #isSequence! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
scope: aScopedNode
	scope := aScopedNode! !

!RBMethodNode methodsFor: 'comparing' stamp: ''!
= 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: '*OpalCompiler-Core' stamp: ''!
owningScope
	^ self scope! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
keywordsPositions
	^keywordsPositions ifNil: [ (selector keywords collect: [:char| 0 ]) asIntegerArray ]! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
bcToASTCache
	^ bcToASTCache ifNil: [ bcToASTCache := OCBytecodeToASTCache generateForNode: self ]! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
arguments: variableNodes 
	arguments := variableNodes.
	arguments do: [:each | each parent: self]! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
isFaulty
	(self arguments anySatisfy: [:each | each isFaulty]) ifTrue:[ ^true].
	(self pragmas anySatisfy: [:each | each isFaulty]) ifTrue:[ ^true].
	^self body isFaulty! !

!RBMethodNode methodsFor: 'adding/removing' stamp: ''!
addReturn
	^ body addReturn! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
hasArguments

	^ arguments isNotEmpty! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
doSemanticAnalysisIn: behavior
	behavior ifNotNil: [self methodClass: behavior].
	self doSemanticAnalysis! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
selectorParts
	^ self keywords collect: [:each | each asSymbol]! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
methodPropertyAt: aKey
	
	^self methodPropertyAt: aKey ifAbsent: [ self error: 'Property not found' ]! !

!RBMethodNode methodsFor: 'private - replacing' stamp: ''!
changeSourceSelector: oldSelector keywordsIntervals: oldIntervals 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 c
ase try to rewrite the signature as a whole, what unfortunately drops the comments within the signature."

	[ (oldIntervals size = self keywordsPositions size and: [ oldArguments size = arguments size ])
		ifTrue: [
			self selectorParts keysAndValuesDo: [ :index :part |
				self addReplacement: (RBStringReplacement 
					replaceFrom: (oldIntervals at: index) first
					to: (oldIntervals at: index) last
					with: part) ].
			oldArguments with: arguments do: [ :old :new | 
				self addReplacement: (RBStringReplacement 
					replaceFrom: old start
					to: old stop
					with: new name) ] ]
		ifFalse: [
			self addReplacement: (RBStringReplacement
				replaceFrom: oldIntervals first first
				to: (oldArguments notEmpty
					ifTrue: [ oldArguments last stop ]
					ifFalse: [ oldIntervals last last ])
				with: (String streamContents: [ :stream |
					self selectorParts keysAndValuesDo: [ :index :part |
						index = 1 ifFalse: [ stream space ].
						stream nextPutAll: part.
						index <= arguments size
							ifTrue: [ stream space; nextPutAll: (arguments at: index) name ] ] ])) ] ]
		on: Error
		do: [ :ex | ex return ]! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
ir: aIRMethodNode

	^ self propertyAt: #ir put: aIRMethodNode.! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
uses: aNode 
	^body == aNode and: [aNode lastIsReturn]! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
generateIR
	| ir |
	scope ifNil: [self doSemanticAnalysis].
 	ir := (self compilationContext astTranslatorClass new
			visitNode: self)
			ir.
	^ self ir: ir! !

!RBMethodNode methodsFor: 'replacing' stamp: ''!
addReplacement: aStringReplacement 
	replacements ifNil: [^self].
	replacements add: aStringReplacement! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
isMethod
	^true! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
methodProperties
	^self propertyAt: #methodProperties ifAbsent: nil! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
pragmaNamed: aSymbol ifAbsent: absentBlock
	^ self pragmas 
		detect: [ :pragma| pragma selector = aSymbol ]
		ifNone: absentBlock! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
keywordsPositions: aPositionsList
	keywordsPositions := aPositionsList ifNotNil: [:list| list asIntegerArray ]! !

!RBMethodNode methodsFor: 'adding/removing' stamp: ''!
addSelfReturn
	^ body addSelfReturn! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
selector: aSelector
	keywordsPositions := nil.
	selector := aSelector asSymbol.! !

!RBMethodNode methodsFor: '*NECompletion' stamp: ''!
completionEntries: offset
	^Symbol selectorTable 
		select: [ :each | each beginsWith: self selector] 
		thenCollect: [ :each | NECSymbolEntry contents: each node: self ]! !

!RBMethodNode methodsFor: '*PharoDocComment' stamp: ''!
pharoDocCommentNodes
	"Return a collection of pharo comment nodes: expressions following the pattern"
	"true >>> true"
	
	^ self comments flatCollect: [:each | each pharoDocCommentNodes]! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
sourceNodeForPC: anInteger
	^ self bcToASTCache nodeForPC: anInteger! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
references: aVariableName 
	^body references: aVariableName! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
start
	^ 1! !

!RBMethodNode methodsFor: 'accessing - conceptual' stamp: ''!
conceptualSignatureSize
	"Return the full length of the method signature (called with a strange name in Pharo: the patterned selector. Note that this length is based on the tree structure and not the source code. It does not reflect the selection interval but the space the signature would take if displayed on a single line."

	"When we count foo: a b: b, we add three extras spaces so args size * 2 - 1"

	^ self conceptualSelectorSize + self conceptualArgumentSize
		+ (self arguments
		ifNotEmpty: [ self arguments size * 2 - 1 ]
		ifEmpty: [ 0 ])! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
scope
	^ scope! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
keywordsIntervals
	^selector keywords
		with: self keywordsPositions 
		collect: [:keyword :start| start to: (start = 0 ifTrue: [ -1 ] ifFalse: [ start + keyword size - 1]) ]! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
stop
	^(self sourceCode ifNotNil: [:src | src] ifNil: [ self formattedCode ]) size! !

!RBMethodNode methodsFor: 'comparing' stamp: ''!
hash
	^ ((self selector hash bitXor: (self hashForCollection: self arguments)) bitXor: (self hashForCollection: self pragmas)) bitXor: self body hash! !

!RBMethodNode methodsFor: 'accessing - compiled method' stamp: ''!
compilationContext: aCompilationContext
	compilationContext := aCompilationContext.! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
numArgs
	^self selector numArgs! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
decompileString 

	^ self formattedCode! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
rewriteTempsForContext: aContext
	| rewriter contextOnlyTemps |
	rewriter := RBParseTreeRewriter new.
	contextOnlyTemps := self notShadowedTemporaryNamesFrom: aContext.
	aContext tempNames do:
			[ :tempName | 
			(contextOnlyTemps includes: tempName)
				ifTrue:
					[ rewriter
						replace: tempName , ' := ``@object' with: 'ThisContext writeVariableNamed: ', tempName asString printString  , ' value: ``@object';
						replace: tempName with: 'ThisContext readVariableNamed: ' , tempName asString printString ] ].
	^ rewriter
		executeTree: self;
		tree! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
renameSelector: newSelector andArguments: varNodeCollection 
	| oldIntervals oldArguments oldSelector |
	oldSelector := selector.
	oldIntervals := self keywordsIntervals.
	oldArguments := arguments.
	self
		arguments: varNodeCollection;
		selector: newSelector.
	self changeSourceSelector: oldSelector keywordsIntervals: oldIntervals arguments: oldArguments! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
argumentNames
	^ self arguments collect: [:each | each name] as: Array! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
source
	^source! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
methodPropertyAt: aKey ifAbsent: absentBlock
	| existingProperties |
	existingProperties := self propertyAt: #methodProperties ifAbsent: absentBlock.
	
	^existingProperties propertyAt: aKey ifAbsent: absentBlock! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
firstPrecodeComment
	self comments ifEmpty: [ ^nil ].
	^ self comments first contents! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
ensureCachedArgumentNames
	^self methodPropertyAt: #argumentNames put: self argumentNames! !

!RBMethodNode methodsFor: 'tree accessing' stamp: ''!
variableWith: aSymbol

	| matcher block |
	matcher := RBParseTreeSearcher new.
	block := [ :aNode :answer | aNode ].
	
	matcher
		matches: aSymbol do: block;
		matchesArgument: aSymbol do: block.
	^ matcher executeTree: self initialAnswer: nil! !

!RBMethodNode methodsFor: 'adding/removing' stamp: ''!
addNode: aNode
	^ body addNode: aNode! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
hasPragmaNamed: aSymbol	
	self pragmaNamed: aSymbol ifAbsent: [ ^ false ].
	^ true! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
generate
	"The receiver is the root of a parse tree. Answer a CompiledMethod. The
	argument, trailer, is the references to the source code that is stored with 
	every CompiledMethod."

	^ self generate: CompiledMethodTrailer empty! !

!RBMethodNode methodsFor: 'adding/removing' stamp: ''!
removePragma: aPragmaNode

	pragmas := pragmas copyWithout: aPragmaNode! !

!RBMethodNode methodsFor: 'matching' stamp: ''!
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: 'accessing' stamp: ''!
body
	^body! !

!RBMethodNode methodsFor: 'initialization' stamp: ''!
initialize
	pragmas := #().
	replacements := SortedCollection sortBlock: 
					[:a :b | 
					a startPosition < b startPosition 
						or: [a startPosition = b startPosition and: [a stopPosition < b stopPosition]]].
	nodeReplacements := IdentityDictionary new! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
methodNode
	^self! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
arguments
	^arguments! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
lastIsReturn
	^body lastIsReturn! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
startWithoutParentheses
	^ 1! !

!RBMethodNode methodsFor: 'copying' stamp: ''!
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: '*Reflectivity' stamp: ''!
metaLinkOptionsFromClassAndMethod
	| options |
	options := Set new.
	self methodClass
		compiledMethodAt: #metaLinkOptions
		ifPresent: [ :method | 
			options
				parseOptions:
					((method valueWithReceiver: nil arguments: #()) asDictionary
						at: self selector
						ifAbsent: [ #() ]) ].
	"set meta link options defined per method"
	(self pragmas
		select: [ :pragma | pragma selector == #metaLinkOptions: ])
		do:
			[ :pragma | (pragma asPragma selector: #parseOptions:) sendTo: options ].
	^ options! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
ir

	^ self propertyAt: #ir ifAbsent: [self generateIR].! !

!RBMethodNode methodsFor: '*Reflectivity' stamp: ''!
optionsFor: aLink
	| options |
	options := aLink options copy.
	options addAll: self metaLinkOptionsFromClassAndMethod.
	^options
	! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
notShadowedTemporaryNamesFrom: aContext
	| ownVariableNames |
	ownVariableNames := self allDefinedVariables collect: [ :var | var asString ].
	^ aContext tempNames difference: ownVariableNames! !

!RBMethodNode methodsFor: 'accessing - conceptual' stamp: ''!
conceptualSelectorSize
	"Return the length of the selector. It does not take into length of parameters nor the spaces.
	Note that this length is based on the tree structure and not the source code. It does not reflect the selection interval but the space the selector would take if displayed on a single line without any space."

	^ selector size! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
newSource
	replacements ifNil: [^self formattedCode].
	^[self reformatSource] on: Error do: [:ex | ex return: self formattedCode]! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
statements: aCollection
	self body statements: aCollection! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
compiledMethod
	compilationContext compiledMethod 
		ifNil: [ compilationContext compiledMethod: self ir compiledMethod ].
	^compilationContext compiledMethod! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
sourceCode
	"compatibility to MethodNode"
	^source! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
pragmaNamed: aSymbol ifPresent: presentBlock ifAbsent: absentBlock
	^ self pragmas 
		detect: [ :pragma| pragma selector = aSymbol ]
		ifFound: presentBlock
		ifNone: absentBlock! !

!RBMethodNode methodsFor: 'accessing - conceptual' stamp: ''!
conceptualArgumentSize
	"Return the cumulted length of the parameters (yes parameters are called arguments in Pharo - not good!!). It does not count spaces and the selectors.
	Note that this length is based on the tree structure and not the source code. It does not reflect the selection interval but the space the selector would take if displayed on a single line without any space."

	^ self arguments
		inject: 0
		into: [ :sum :each | sum + each name size ]! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
isLast: aNode 
	^body isLast: aNode! !

!RBMethodNode methodsFor: 'accessing - compiled method' stamp: ''!
compilationContext
	^ compilationContext! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
allArgumentVariables
	^(self argumentNames asOrderedCollection)
		addAll: super allArgumentVariables;
		yourself! !

!RBMethodNode methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream nextPutAll: self formattedCode! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
offsetIsComment: anOffset
	"check is the offset in the source part of a comment"

	^ self allComments
		anySatisfy: [ :comment | anOffset between: comment start and: comment stop ]! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
pragmaNamed: aSymbol	
	^ self pragmaNamed: aSymbol ifAbsent: [ KeyNotFound signalFor: aSymbol  ]! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
doSemanticAnalysis

	self compilationContext ifNil: [ self methodClass: nil class ].

	self
		compilationContext semanticAnalyzerClass new
			compilationContext: self compilationContext;
			analyze: self! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
hasTemporaryNamed: aString	
	^ self temporaries anySatisfy: [ :temp| temp name = aString ]! !

!RBMethodNode methodsFor: 'adding/removing' stamp: ''!
addPragma: aPragmaNode

	pragmas := pragmas copyWith: aPragmaNode.
	aPragmaNode parent: self! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
body: stmtsNode 
	body := stmtsNode.
	body parent: self! !

!RBMethodNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	aNode == body ifTrue: [self body: anotherNode].
	self arguments: (arguments 
				collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! !

!RBMethodNode methodsFor: 'accessing - compiled method' stamp: ''!
method
	"return the method that I have been compiled for"
	^self compilationContext ifNotNil: [ :ccntx |
		 ccntx compiledMethod ifNil: [ccntx getClass >> self selector]]! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
hasTemporaries
	^ self temporaries isNotEmpty! !

!RBMethodNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitMethodNode: self! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
statements
	^ self body statements! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
hasArgumentNamed: aString	
	^ self arguments anySatisfy: [ :argument| argument name = aString ]! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
defines: aName
	^ (arguments anySatisfy: [ :each | each name = aName ])
		or: [ self pragmas anySatisfy: [ :pragma | pragma defines: aName ] ]! !

!RBMethodNode methodsFor: 'accessing - compiled method' stamp: ''!
methodClass: aClass	
	compilationContext ifNil: [compilationContext := aClass compiler compilationContext].
	self compilationContext class: aClass! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
isPrimitive
	^ self pragmas anySatisfy: [ :each | each isPrimitive ]! !

!RBMethodNode methodsFor: 'initialization' stamp: ''!
selector: aSymbol keywordsPositions: positionList arguments: valueNodes
	self 
		arguments: valueNodes;
		selector: aSymbol;
		keywordsPositions: positionList.! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
keywords
	^ selector keywords.! !

!RBMethodNode methodsFor: 'adding/removing' stamp: ''!
removeSubtree: aTree

	^ aTree isReturn 
		ifTrue: [ RBParseTreeRewriter 
					 replace: aTree formattedCode
					 with: '' in: self
					 onInterval: aTree sourceInterval ]
		ifFalse: [ RBParseTreeRewriter 
					  replaceStatements: aTree formattedCode
		 			  with: '' in: self
					  onInterval: aTree sourceInterval ]! !

!RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: ''!
sourceText: aString
	self source: aString! !

!RBMethodNode methodsFor: 'testing' stamp: ''!
pragmaNamed: aSymbol ifPresent: foundBlock
	^ self pragmas 
		detect: [ :pragma| pragma selector = aSymbol ]
		ifFound: foundBlock! !

!RBMethodNode methodsFor: 'private' stamp: ''!
reformatSource
	| stream newSource newTree |
	stream := (String new: source size + 100) writeStream.
	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 := self parserClass parseFaultyMethod: newSource.
	self = newTree
		ifFalse: [ ^ self formattedCode ].
	^ newSource! !

!RBMethodNode methodsFor: 'accessing' stamp: ''!
selectorAndArgumentNames
	"Returns the selector and argument names portion of a method as a string"

	^ self arguments
		ifEmpty: [self keywords first]
		ifNotEmpty: [| lastArgument |
			lastArgument := self arguments last.
			self source first: lastArgument start + (lastArgument name size - 1)]! !

!RBMethodNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary
	^ self class new
		selector: self selector;
		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 class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol body: aSequenceNode 
	^self 
		selector: aSymbol
		arguments: #()
		body: aSequenceNode! !

!RBMethodNode class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol arguments: variableNodes body: aSequenceNode 
	^(self new)
		arguments: variableNodes;
		selector: aSymbol;
		body: aSequenceNode;
		yourself! !

!RBMethodNode class methodsFor: '*OpalCompiler-Core' stamp: ''!
errorMethodNode: selector errorMessage: messageText	
	| message |
	message := RBMessageNode 
		receiver: RBVariableNode selfNode
		selector: #error: 
		arguments: {RBLiteralNode value: messageText}.
	^ self 
		selector: selector 
		arguments: ((1 to: selector numArgs) collect: [ :i | RBVariableNode named: 't' , i asString ]) 
		body: (RBSequenceNode statements: {message})! !

!RBMethodNode class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol keywordsPositions: positionList arguments: valueNodes
	^(self new)
		selector: aSymbol
			keywordsPositions: positionList 
			arguments: valueNodes;
		yourself.! !

!RBMethodNode class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol arguments: valueNodes
	^(self new)
		selector: aSymbol;
		arguments: valueNodes;
		yourself! !

!RBMethodNodeTest commentStamp: ''!
SUnit tests for RBMethodNode!
!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testNodeForOffsetVar
	"test the case of a variable"

	| source ast foundNode |
	source := 'method Object'.
	ast := self parserClass parseMethod: source.
	foundNode := ast nodeForOffset: 9.
	self assert: foundNode class identicalTo: RBVariableNode! !

!RBMethodNodeTest methodsFor: 'helpers' stamp: ''!
methodWithArg: someArgName and: someAnotherArgName! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testOffsetIsComment
	self deny: ((OrderedCollection>>#do:) ast offsetIsComment: 3).

	self assert: ((OrderedCollection>>#do:) ast offsetIsComment: 13).
	self assert: ((OrderedCollection>>#do:) ast offsetIsComment: 62).

	self deny: ((OrderedCollection>>#do:) ast offsetIsComment: 63).
	self deny: ((OrderedCollection>>#do:) ast offsetIsComment: 70).! !

!RBMethodNodeTest methodsFor: 'tests - comments' stamp: ''!
testHasComments

	| tree |
	tree := self parseMethod: 'foo: abd bar: cde  
		"this is comment"
		"this is another comment"
^ abd + cde'.

	self assert: tree hasComments.
	
	tree := self parseMethod: 'foo: abd bar: cde  
^ abd + cde'.

	self deny: tree hasComments.! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testNodeForOffsetAssignment
	"test the case of a Assignment"

	| source ast foundNode |
	source := 'method Object := Class'.
	ast := self parserClass parseMethod: source.
	foundNode := ast nodeForOffset: 9.
	self assert: foundNode class identicalTo: RBVariableNode.
	foundNode := ast nodeForOffset: 14.
	self assert: foundNode class identicalTo: RBAssignmentNode.
	foundNode := ast nodeForOffset: 19.
	self assert: foundNode class identicalTo: RBVariableNode! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testMethodsHasTemporaries

	| tree |
	tree := self parseMethod: 'foo: abd bar: cde  
		| tmp |
^ abd + cde'.

	self assert: tree hasTemporaries! !

!RBMethodNodeTest methodsFor: 'tests - primitives' stamp: ''!
testPrimitiveModuleErrorIsPrimitive
	"
	primClosedir: directoryPointerBytes
		<primitive: 'primitiveClosedir' module: 'FileAttributesPlugin' error: error>
		...
	"
	| ast |
	ast := (File class >> #primClosedir:) ast.
	self assert: ast isPrimitive.! !

!RBMethodNodeTest methodsFor: 'tests - comments' stamp: ''!
testCommentsParent
	"Test if comment has a parent"
	self
		assert: (self class >> #testCommentsParent) ast comments first parent selector
		equals: #testCommentsParent.! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testBlockHasTemporaries

	| tree |
	tree := self parseMethod: 'foo 
		[ 
		| tmp |
		abd + cde 
		]'.

	self deny: tree hasTemporaries.
	self assert: tree body statements first hasTemporaries! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testSizeOfSignatureOfBinaryMethod
	| tree |
	tree := self
		parseMethod:
			' + x   
^ 2 + 3'.
	self assert: tree conceptualSelectorSize equals: '+' size.
	self assert: tree conceptualArgumentSize equals: 'x'  size.
	self assert: tree conceptualSignatureSize equals: '+' size + tree conceptualArgumentSize + 1! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testBlockHeadIsNotEmpty

	| tree |
	tree := self parseMethod: 'foo 
		[ :arg | 
		abd + cde 
		]'.

	self assert: tree body statements first headIsNotEmpty! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testBlockHeadIsNotEmpty2

	| tree |
	tree := self parseMethod: 'foo 
		[ "blbl" 
		abd + cde 
		]'.

	self assert: tree body statements first headIsNotEmpty! !

!RBMethodNodeTest methodsFor: 'tests - comments' stamp: ''!
testUncommentMethodDoesNotHaveComments

	| tree |
	tree := self parseMethod: 'foo: abd bar: cde  
^ abd + cde'.

	self deny: tree hasComments.! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testNodeForOffsetTempDefinition
	"test the case of Messages"

	| source ast foundNode |
	source := 'method | temp |'.
	ast := self parserClass parseFaultyMethod: source.
	foundNode := ast nodeForOffset: 12.
	self assert: foundNode class identicalTo: RBVariableNode! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testAddingMethodProperties

	| ast |
	ast := self parseMethod: 'one ^ self'.
	self assert: ast methodProperties isNil. 
	
	ast methodPropertyAt: #testKey put: #testValue.
	ast methodPropertyAt: #testKey2 put: #testValue2.
	self assert: (ast methodPropertyAt: #testKey) equals: #testValue.
	self assert: (ast methodPropertyAt: #testKey2) equals: #testValue2.
	self assert: ast methodProperties class equals: AdditionalMethodState! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testHasArguments

	| ast |
	ast := self parseMethod: 'foo: arg'.
	self assert: ast hasArguments! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testSelectorAndArgumentNames

	self assert: (self parseMethod: 'one ^ self') selectorAndArgumentNames equals: 'one'.
	self assert: (self parseMethod: 'one:   aOne ^ self') selectorAndArgumentNames equals: 'one:   aOne'.
	self assert: (self parseMethod: 'one:   aOne two:   aTwo ^ self') selectorAndArgumentNames equals: 'one:   aOne two:   aTwo'.
	self assert: (self parseMethod: '*   aOne') selectorAndArgumentNames equals: '*   aOne'.
	self assert: (self parseMethod: '**   aOne') selectorAndArgumentNames equals: '**   aOne'! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testSizeOfSignatureOfKeywordsMethod
	| tree |
	tree := self
		parseMethod:
			'foo: abd bar: cde  
^ abd + cde'.
	self assert: tree conceptualSelectorSize equals: 'foo:bar:' size.
	self assert: tree conceptualArgumentSize equals: 'abdcde' size.
	self
		assert: tree conceptualSignatureSize
		equals: 'abdcde' size + 'foo:bar:' size + 3.! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testBlockHeadIsNotEmpty3

	| tree |
	tree := self parseMethod: 'foo 
		[ 
		abd + cde 
		]'.

	self deny: tree body statements first headIsNotEmpty! !

!RBMethodNodeTest methodsFor: 'tests - comments' stamp: ''!
testCommentedMethodHasComments

	| tree |
	tree := self parseMethod: 'foo: abd bar: cde  
		"this is comment"
		"this is another comment"
^ abd + cde'.

	self assert: tree hasComments.! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testCachingMethodArguments

	| ast |
	ast := (self class >> #methodWithArg:and:) ast.
	ast propertyAt: #argumentNames put: #(wrongArg wrongArg2).
	
	ast ensureCachedArgumentNames.
	self assert: (ast methodPropertyAt: #argumentNames) equals: #(someArgName someAnotherArgName)! !

!RBMethodNodeTest methodsFor: 'tests - primitives' stamp: ''!
testPrimitiveErrorIsPrimitive

	"isPinnedInMemory
		<primitive: 183 error: ec>
		^self primitiveFailed
	"
	
	| ast |
	ast := (Object >> #isPinnedInMemory) ast.
	self assert: ast isPrimitive.

	ast := (MirrorPrimitives class >> #makeObject:readOnly:) ast.
	self assert: ast isPrimitive.! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testBlockHasArguments

	| tree |
	tree := self parseMethod: 'foo 
		[ :arg | 
		abd + cde 
		]'.

	self assert: tree body statements first hasArguments! !

!RBMethodNodeTest methodsFor: 'tests - comments' stamp: ''!
testMethodWithCommentsAndEmptyStatements

	| tree |
	tree := self parseMethod: 'foo: abd bar: cde  
		"this is comment".
		"this is another comment"'.

	self assert: tree comments first contents equals: 'this is comment'.
	self assert: tree body comments first contents equals: 'this is another comment'! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testMethodClass
	| ast |
	ast :=  (OrderedCollection>>#do:) ast.
	self assert: ast methodClass equals: OrderedCollection.
	"if we create an AST, the class should be nil"
	ast := RBMethodNode selector: #tt body: RBSelectorNode new. 
	self assert: ast methodClass equals: nil! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testSizeOfSignatureOfUnaryMethod
	| tree |
	tree := self
		parseMethod:
			'foo  
^ 2 + 3'.
	self assert: tree conceptualSelectorSize equals: 'foo' size.
	self assert: tree conceptualArgumentSize isZero.
	self assert: tree conceptualSignatureSize equals: 'foo' size! !

!RBMethodNodeTest methodsFor: 'tests - primitives' stamp: ''!
testPrimitiveIsPrimitive
	"primFill: aPositiveInteger
		<primitive: 145>
		self errorImproperStore."
	
	| ast |
	ast := (SmallInteger >> #+) ast.
	self assert: ast isPrimitive.
	ast := (Bitmap >> #primFill:) ast.
	self assert: ast isPrimitive.! !

!RBMethodNodeTest methodsFor: 'tests' stamp: ''!
testNodeForOffsetMessage
	"test the case of Messages"

	| source ast foundNode |
	source := 'method Object doit: Class'.
	ast := self parserClass parseMethod: source.
	foundNode := ast nodeForOffset: 9.
	self assert: foundNode class identicalTo: RBVariableNode.
	foundNode := ast nodeForOffset: 14.
	self assert: foundNode class identicalTo: RBMessageNode.
	foundNode := ast nodeForOffset: 22.
	self assert: foundNode class identicalTo: RBVariableNode! !

!RBMethodNodeTest methodsFor: 'tests - primitives' stamp: ''!
testIsPrimitive
	"see other testPrimitive... tests"
	"This test brings the test button in the browser and test negatively
	The others are for each specific kind of primitive:..."
	| ast |
	ast := (SmallInteger >> #+) ast.
	self assert: ast isPrimitive.
	ast := (Bitmap >> #primFill:) ast.
	self assert: ast isPrimitive.
	
	ast := (Integer >> #+) ast.
	self deny: ast isPrimitive.! !

!RBMethodNodeTest methodsFor: 'tests - primitives' stamp: ''!
testPrimitiveModuleIsPrimitive
	"
	stringHash: aString initialHash: speciesHash

		| stringSize hash low |
		<primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'>

		<var: #aHash declareC: 'int speciesHash'>
		<var: #aString declareC: 'unsigned char *aString'>

	"
	| ast |
	ast := (ByteString class >> #stringHash:initialHash:) ast.
	self assert: ast isPrimitive.

	ast := (Integer >> #digitSubtract:) ast.
	self assert: ast isPrimitive.! !

!RBMethodProtocolChange methodsFor: 'converting' stamp: ''!
asUndoOperation
	
	^ self class
		selector: self selector
		in: self changeClass
		classified: self oldProtocol! !

!RBMethodProtocolChange methodsFor: 'accessing' stamp: ''!
source

	^ source ifNil: [ super oldVersionTextToDisplay ]! !

!RBMethodProtocolChange methodsFor: 'utilities' stamp: ''!
oldProtocol

	| oldProtocol |
	oldProtocol := RBBrowserEnvironment new
						whichProtocolIncludes: self selector in: self changeClass.
	^ oldProtocol ifNil: [ oldProtocol := #accessing ].! !

!RBMethodProtocolChange methodsFor: 'printing' stamp: ''!
oldVersionTextToDisplay

	^ String streamContents: [ :stream | stream
		nextPutAll: '"protocol: ';
		nextPutAll: self oldProtocol;
		nextPutAll: '"';
		nextPutAll: String cr;
		nextPutAll: super oldVersionTextToDisplay ]! !

!RBMethodProtocolChange methodsFor: 'initialization' stamp: ''!
selector: aSelector in: aClass classified: aProtocol

	selector := aSelector.
	self changeClass: aClass.
	self protocols: aProtocol! !

!RBMethodProtocolChange methodsFor: 'printing' stamp: ''!
textToDisplay

	^ String streamContents: [ :stream | stream
		nextPutAll: '"protocol: ';
		nextPutAll: self protocol;
		nextPutAll: '"';
		nextPutAll: String cr;
		nextPutAll: super textToDisplay ]! !

!RBMethodProtocolChange methodsFor: 'printing' stamp: ''!
changeString

	^ String streamContents: [ :stream | stream
		nextPutAll: '[';
		nextPutAll: self protocol;
		nextPutAll: '] ';
		nextPutAll: super changeString ]! !

!RBMethodProtocolChange class methodsFor: 'instance creation' stamp: ''!
selector: aSelector in: aBehavior classified: aProtocol

	^ self new
		selector: aSelector
		in: aBehavior
		classified: aProtocol! !

!RBMethodProtocolTransformation commentStamp: ''!
I am responsible for changing the protocol (or category) of a method. If the protocol does not exist in the class protocols list, the transformation will create it automatically.

Usage: 
| transformation |
transformation := (RBMethodProtocolTransformation
				protocol: 'transforming'
				inMethod: #someMethod
				inClass: #RBDummyEmptyClass)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the method exists.!
!RBMethodProtocolTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ (RBCondition
			withBlock: [ self definingClass isNotNil ]
			errorString: ('Class named <1s> does not exist' expandMacrosWith: className))
		& (RBCondition definesSelector: selector in: self definingClass)! !

!RBMethodProtocolTransformation methodsFor: 'api' stamp: ''!
protocol: aString inMethod: aSelector inClass: aClassName

	self className: aClassName.
	selector := aSelector.
	protocol := aString! !

!RBMethodProtocolTransformation methodsFor: 'executing' stamp: ''!
protocol

	^ protocol ifNil: [ 
		self uiManager
			chooseOrRequestFrom: self definingClass protocols
			title: 'Class name was not defined to perform ', self class baseClass name,
					 '. Please select a class to resume this transformation.'  ]! !

!RBMethodProtocolTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' protocol ''';
		nextPutAll: protocol;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBMethodProtocolTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self model
		selector: self definingMethod selector
		in: self definingClass
		classified: self protocol.! !

!RBMethodProtocolTransformation class methodsFor: 'api' stamp: ''!
protocol: aString inMethod: aSelector inClass: aClassName

	^ self new
		protocol: aString
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBMethodProtocolTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel protocol: aString inMethod: aSelector inClass: aClassName

	^ self new
		model: aRBModel;
		protocol: aString
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBMethodProtocolTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring
	| refactoring |
	self assert: (RBDummyEmptyClass organization protocolOrganizer protocolNamed: 'empty protocol 2') isEmpty.

	refactoring := (RBMethodProtocolTransformation protocol: 'empty protocol 2' inMethod: #someMethod inClass: #RBDummyEmptyClass) asRefactoring transform.
	RBRefactoryChangeManager instance performChange: refactoring changes.

	self deny: (RBDummyEmptyClass organization protocolOrganizer protocolNamed: 'empty protocol 2') isEmpty.

	refactoring := (RBMethodProtocolTransformation protocol: 'empty protocol 1' inMethod: #someMethod inClass: #RBDummyEmptyClass) asRefactoring transform.
	RBRefactoryChangeManager instance performChange: refactoring changes.

	self assert: (RBDummyEmptyClass organization protocolOrganizer protocolNamed: 'empty protocol 2') isEmpty! !

!RBMethodProtocolTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation |
	self assert: ( RBDummyEmptyClass
		organization protocolOrganizer
		protocolNamed: 'empty protocol 2' ) isEmpty.
	
	transformation := (RBMethodProtocolTransformation new
		protocol: 'empty protocol 2'
		inMethod: #someMethod
		inClass: #RBDummyEmptyClass)
		transform.
	RBRefactoryChangeManager instance performChange: transformation changes.

	self assert: ( RBDummyEmptyClass
		organization protocolOrganizer
		protocolNamed: 'empty protocol 2' ) isEmpty not.
	
	transformation := (RBMethodProtocolTransformation new
		protocol: 'empty protocol 1'
		inMethod: #someMethod
		inClass: #RBDummyEmptyClass)
		transform.
	RBRefactoryChangeManager instance performChange: transformation changes.	
	self assert: ( RBDummyEmptyClass
		organization protocolOrganizer
		protocolNamed: 'empty protocol 2' ) isEmpty.! !

!RBMethodProtocolTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBMethodProtocolTransformation
							protocol: 'empty protocol 2'
							inMethod: #method
							inClass: #RBDummyEmptyClass)
							asRefactoring! !

!RBMethodProtocolTransformationTest methodsFor: 'tests' stamp: ''!
testClassDoesNotExist

	self shouldFail: (RBMethodProtocolTransformation
							protocol: 'empty protocol 2'
							inMethod: #someMethod
							inClass: #RBDummyEmptyClass123)
							asRefactoring! !

!RBMethodRefactoring commentStamp: ''!
I am an abstract base class for method refactorings.

I only provide a helper method for generating  selector names.!
!RBMethodRefactoring methodsFor: 'accessing' stamp: ''!
methodClass 
	^ class! !

!RBMethodRefactoring methodsFor: 'private' stamp: ''!
buildSelectorString: aSelector 
	aSelector numArgs = 0 ifTrue: [^aSelector].
	^self buildSelectorString: aSelector
		withPermuteMap: (1 to: aSelector numArgs)! !

!RBMethodRefactoring methodsFor: 'private' stamp: ''!
buildSelectorString: aSelector withPermuteMap: anIntegerCollection 
	| stream keywords |
	aSelector numArgs == 0 ifTrue: [^aSelector asString].
	stream := WriteStream on: String new.
	keywords := aSelector keywords.
	keywords with: anIntegerCollection
		do: 
			[:each :i | 
			stream
				nextPutAll: each;
				nextPutAll: ' ``@arg';
				nextPutAll: i printString;
				nextPut: $ ].
	^stream contents! !

!RBMethodRefactoring class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBMethodRefactoring! !

!RBMethodTransformation commentStamp: ''!
I'm a transformation whose focus is a method. !
!RBMethodTransformation methodsFor: 'accessing' stamp: ''!
definingMethod

	^ method ifNil: [ 
		method := (self definingClass methodFor: selector asSymbol) ast ]! !

!RBMethodsSelectionPresenter methodsFor: 'attributes' stamp: ''!
columnName 
	^ 'Methods'! !

!RBMethodsSelectionPresenter methodsFor: 'attributes' stamp: ''!
columnSelector
	^ #selector! !

!RBMethodsSelectionPresenter class methodsFor: 'examples' stamp: ''!
example
	<script>
	^ (self label: 'example ...' 
		withItems: SycExtractMethodCommand methods
		selecting: {} )! !

!RBMethodsSelectionPresenter class methodsFor: 'specs' stamp: ''!
title 
	^ 'Methods'! !

!RBMoveClassTransformation commentStamp: ''!
Moves a class to a new category or package

Usage:
| transformation |
transformation := (RBMoveClassTransformation
				move: #RBMoveClassTransformation
				to: #'Refactoring2-Refactorings-Tests')
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the class must exist
- the category or package must exist!
!RBMoveClassTransformation methodsFor: 'api' stamp: ''!
move: aClassName to: aCategoryName

	self className: aClassName.
	category := aCategoryName! !

!RBMoveClassTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ ( RBCondition
		withBlock: [ self definingClass isNotNil ]
		errorString: 'Class named ', className, ' does not exist' ) &
	   ( RBCondition
		withBlock: [ self model environment categories includes: category ]
		errorString: 'Category named ', category, ' does not exist' )! !

!RBMoveClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' move: ''';
		nextPutAll: category;
		nextPutAll: ''' to: ';
		nextPutAll: className.
	aStream nextPut: $)! !

!RBMoveClassTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	oldCategory := self definingClass category.
	self definingClass category: category.
	self model category: category for: self definingClass! !

!RBMoveClassTransformation class methodsFor: 'api' stamp: ''!
move: aClassName to: aCategoryName

	^ self new
		move: aClassName
		to: aCategoryName;
		yourself ! !

!RBMoveClassTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel move: aClassName to: aCategoryName

	^ self new
		model: aRBModel;
		move: aClassName
		to: aCategoryName;
		yourself ! !

!RBMoveClassTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| transformation class |
	self assert: self class category equals: #'Refactoring2-Transformations-Tests'.
	
	transformation := (RBMoveClassTransformation 
							move: self class name
							to: #'Refactoring2-Transformations-Utilities')
							asRefactoring transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self class name. 
	self assert: class category equals: #'Refactoring2-Transformations-Utilities'! !

!RBMoveClassTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	self assert: self changeMock category equals: #'Refactoring-Tests-Changes'.
	
	transformation := (RBMoveClassTransformation
							move: self changeMock name
							to: #'Refactoring2-Transformations-Test')
							transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self changeMock name asSymbol. 
	self assert: class category equals: #'Refactoring2-Transformations-Test'! !

!RBMoveClassTransformationTest methodsFor: 'tests' stamp: ''!
testBadCategoryName

	self shouldFail: (RBMoveClassTransformation 
							move: self class name
							to: #'Refactoring2-Transformations-Test')
							asRefactoring! !

!RBMoveInstVarToClassRefactoring commentStamp: ''!
RBMoveInstVarToClassRefactoring knows how to move instance variable from one class to another.

Instance Variables
	newClass:		<RBClass>

newClass
	- class, in which user moves an instance variable!
!RBMoveInstVarToClassRefactoring methodsFor: 'transforming' stamp: ''!
collectSendersOfInstVar
	| brokenSenders subclasses hasInstVar |
	hasInstVar := false.
	brokenSenders := OrderedCollection new.
	oldClass superclass instanceVariableNames do: [ :each | each = variableName ifTrue: [ hasInstVar := true ] ].
	^ hasInstVar
		ifTrue: [ brokenSenders ]
		ifFalse: [ brokenSenders := (oldClass selectors
				select: [ :each | (oldClass methodFor: each) source includesSubstring: variableName asString ]
				thenCollect: [ :each | oldClass methodFor: each ]) asOrderedCollection.
			subclasses := oldClass subclasses.
			subclasses
				do: [ :subclass | 
					subclass selectors
						do:
							[ :each | ((subclass methodFor: each) source includesSubstring: ' ' , variableName asString , ' ') ifTrue: [ brokenSenders add: (subclass methodFor: each) ] ] ].
			brokenSenders ]! !

!RBMoveInstVarToClassRefactoring methodsFor: 'transforming' stamp: ''!
transform
	| brokenSenders |
	class addInstanceVariable: variableName asString.
	oldClass removeInstanceVariable: variableName asString.
	brokenSenders := self collectSendersOfInstVar.
	brokenSenders ifNotEmpty: [ 
		Smalltalk tools messageList
			browse: (brokenSenders collect: [:each | each method])
			title: 'Broken methods' 
			autoSelect: brokenSenders first selector] ! !

!RBMoveInstVarToClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition definesInstanceVariable: variableName asString in: oldClass) & 
		(RBCondition
		withBlock: [ 
			(class hierarchyDefinesInstanceVariable: variableName)
				ifTrue: [ self refactoringError: 'Already defined in hierarchy' ].true ])! !

!RBMoveInstVarToClassRefactoring methodsFor: 'accessing' stamp: ''!
oldClass: aClass
	oldClass := self classObjectFor: aClass! !

!RBMoveInstVarToClassRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk variable: aVarName fromClass: anOldClass toClass: aClass
	^ self new
		model: aRBSmalltalk;
		variable: aVarName class: aClass;
		oldClass: anOldClass;
		yourself.! !

!RBMoveInstanceVariableToClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testVariableAlreadyExists

	self shouldFail: 
		(self createRefactoringWithModel: model 
			andArguments: { 'result' . #RBFooLintRuleTestData . #RBBasicLintRuleTestData })! !

!RBMoveInstanceVariableToClassParametrizedTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring oldClass newClass |
	refactoring := (self createRefactoringWithModel: model 
		andArguments: { 'methodBlock' . #RBBasicLintRuleTestData . #RBFooLintRuleTestData }).
				
	oldClass := refactoring model classNamed: #RBBasicLintRuleTestData.
	newClass := refactoring model classNamed: #RBFooLintRuleTestData.
	self assert: (oldClass directlyDefinesInstanceVariable: 'methodBlock').
	self deny: (newClass directlyDefinesInstanceVariable: 'methodBlock').
	
	[ refactoring transform ] on: RBRefactoringError do: [ :e | e resume ].
	self assert: refactoring model changes changes size equals: 2.

	oldClass := refactoring model classNamed: #RBBasicLintRuleTestData.
	newClass := refactoring model classNamed: #RBFooLintRuleTestData.
	self deny: (oldClass directlyDefinesInstanceVariable: 'methodBlock').
	self assert: (newClass directlyDefinesInstanceVariable: 'methodBlock').
	! !

!RBMoveInstanceVariableToClassParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #variable:fromClass:toClass:! !

!RBMoveInstanceVariableToClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testVariableDoesNotExistInOldClass

	self shouldFail: 
		(self createRefactoringWithModel: model 
			andArguments: { 'abc' . #RBFooLintRuleTestData . #RBBasicLintRuleTestData })! !

!RBMoveInstanceVariableToClassParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBMoveInstVarToClassRefactoring };
		addCase: { #rbClass -> RBMoveInstanceVariableToClassTransformation };
		yourself! !

!RBMoveInstanceVariableToClassTransformation commentStamp: ''!
Moves an instance variable from a class to another. It does not check whether this variable is being referenced in the former class.

Usage:
| transformation |
transformation := (RBMoveInstanceVariableToClassTransformation
				variable: 'methodBlock'
				fromClass: #RBBasicLintRuleTest
				toClass: #RBFooLintRuleTest)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
overrides the preconditions from both RBAddVariableRefactoring and RBRemoveVariableRefactoring!
!RBMoveInstanceVariableToClassTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName fromClass: fromClassName toClass: toClassName

	variableName := aVariableName.
	className := toClassName.
	oldClass := fromClassName.! !

!RBMoveInstanceVariableToClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' variable: '.
	variableName storeOn: aStream.
	aStream nextPutAll: ' fromClass: '.
	oldClass storeOn: aStream.
	aStream nextPutAll: ' toClass: '.
	className storeOn: aStream.
	aStream nextPut: $)! !

!RBMoveInstanceVariableToClassTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	^ OrderedCollection
		with: (RBAddVariableTransformation
				model: self model
				instanceVariable: variableName asString
				class: className)
		with: (RBRemoveVariableTransformation
				model: self model
				instanceVariable: variableName asString
				class: oldClass)! !

!RBMoveInstanceVariableToClassTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel variable: aVariableName fromClass: fromClassName toClass: toClassName

	^ self new
		model: aRBModel;
		variable: aVariableName
		fromClass: fromClassName
		toClass: toClassName;
		yourself! !

!RBMoveInstanceVariableToClassTransformation class methodsFor: 'api' stamp: ''!
variable: aVariableName fromClass: fromClassName toClass: toClassName

	^ self new
		variable: aVariableName
		fromClass: fromClassName
		toClass: toClassName;
		yourself! !

!RBMoveMethodParametrizedTest methodsFor: 'test' stamp: ''!
testMoveMethodIntoArgument
	| refactoring class |
	self proceedThroughWarning: 
		[ refactoring := self createRefactoringWithArguments:  
				{ #checkMethod: . RBTransformationRuleTestData . '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: #RBTransformationRuleTestData.
	self assert: (class parseTreeFor: #checkMethod:) equals: (self parseMethod: 'checkMethod: aSmalllintContext aSmalllintContext foo: self').
	self assert: ((refactoring model classNamed: #RBSmalllintContext) parseTreeFor: #foo:) equals: (self 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) equals: (self parseMethod: 'class1 ^class').
	self assert: (class parseTreeFor: #class:) equals: (self parseMethod: 'class: anObject class := anObject').
	self assert: (class classSide parseTreeFor: #recursiveSelfRule:) equals: (self parseMethod: 'recursiveSelfRule: anObject RecursiveSelfRule := anObject').
	self assert: (class classSide parseTreeFor: #recursiveSelfRule) equals: (self parseMethod: 'recursiveSelfRule ^RecursiveSelfRule').
	self assert: (class parseTreeFor: #builder) equals: (self parseMethod: 'builder ^builder').
	self assert: (class parseTreeFor: #builder:) equals: (self parseMethod: 'builder: anObject builder := anObject').
	self assert: (class parseTreeFor: #rewriteRule) equals: (self parseMethod: 'rewriteRule ^rewriteRule').
	self assert: (class parseTreeFor: #rewriteRule:) equals: (self parseMethod: 'rewriteRule: anObject rewriteRule := anObject')! !

!RBMoveMethodParametrizedTest methodsFor: 'test' stamp: ''!
testMoveMethodIntoClass
	| refactoring class |
	(model classFor: Object) compile: 'aTestMethodName ^ OrderedCollection new addAll: (1 to: 100); yourself' classified: #test.
	
	refactoring := self createRefactoringWithArguments:  
				{ #aTestMethodName . model classFor: Object . 'OrderedCollection'}.
	
	self
		setupMethodNameFor: refactoring
		toReturn: #oneToOneHundred
		withArguments: #().
	refactoring setOption: #variableTypes toUse: [ :ref :initialTypes :selectedTypes | selectedTypes ].
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #Object.
	self
		assert: ((model classFor: Object) parseTreeFor: #aTestMethodName)
		equals: (self parseMethod: 'aTestMethodName ^ OrderedCollection oneToOneHundred ').
	self
		assert: ((refactoring model classNamed: #OrderedCollection) classSide parseTreeFor: #oneToOneHundred)
		equals: (self parseMethod: 'oneToOneHundred ^ self new addAll: (1 to: 100); yourself')
! !

!RBMoveMethodParametrizedTest methodsFor: 'test' stamp: ''!
testMoveMethodIntoClassVariable
	| refactoring class |
	self proceedThroughWarning: 
		[ refactoring := self createRefactoringWithArguments:  
				{ #checkMethod: . RBTransformationRuleTestData . '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: #RBTransformationRuleTestData.
	self assert: (class parseTreeFor: #checkMethod:) equals: (self parseMethod: 'checkMethod: aSmalllintContext RecursiveSelfRule foo: self foo: aSmalllintContext').
	self assert: ((refactoring model classNamed: #RBParseTreeSearcher) parseTreeFor: #foo:foo:) equals: (self 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) equals: (self parseMethod: 'class1 ^class').
	self assert: (class parseTreeFor: #class:) equals: (self parseMethod: 'class: anObject class := anObject').
	self assert: (class parseTreeFor: #builder) equals: (self parseMethod: 'builder ^builder').
	self assert: (class parseTreeFor: #builder:) equals: (self parseMethod: 'builder: anObject builder := anObject').
	self assert: (class parseTreeFor: #rewriteRule) equals: (self parseMethod: 'rewriteRule ^rewriteRule').
	self assert: (class parseTreeFor: #rewriteRule:) equals: (self parseMethod: 'rewriteRule: anObject rewriteRule := anObject')! !

!RBMoveMethodParametrizedTest methodsFor: 'test' stamp: ''!
testMoveMethodThatReferencesPoolDictionary
	| refactoring class |
	self proceedThroughWarning: 
		[ refactoring := self createRefactoringWithArguments: 
			  { #junk . RBLintRuleTestData . '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: #RBLintRuleTestData.
	self assert: (class parseTreeFor: #junk) equals: (self parseMethod: 'junk ^RefactoryTestDataApp junk1').
	self assert: ((refactoring model metaclassNamed: #RBRefactoryTestDataApp) parseTreeFor: #junk1) equals: (self parseMethod: 'junk1
	^RBRefactoryTestDataApp printString copyFrom: 1 to: CR').
	self assert: (class directlyDefinesPoolDictionary: 'TextConstants' asSymbol)! !

!RBMoveMethodParametrizedTest methodsFor: 'test' stamp: ''!
testMoveMethodIntoInstanceVariable
	| refactoring class |
	self proceedThroughWarning: 
		[ refactoring := self createRefactoringWithArguments: 
			  { #checkMethod: . RBTransformationRuleTestData . '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: #RBTransformationRuleTestData.
	self assert: (class parseTreeFor: #checkMethod:) equals: (self parseMethod: 'checkMethod: aSmalllintContext rewriteRule foo: self foo: aSmalllintContext').
	self assert: ((refactoring model classNamed: #RBParseTreeRewriter) parseTreeFor: #foo:foo:) equals: (self 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) equals: (self parseMethod: 'class1 ^class').
	self assert: (class parseTreeFor: #class:) equals: (self parseMethod: 'class: anObject class := anObject').
	self assert: (class classSide parseTreeFor: #recursiveSelfRule:) equals: (self parseMethod: 'recursiveSelfRule: anObject RecursiveSelfRule := anObject').
	self assert: (class classSide parseTreeFor: #recursiveSelfRule) equals: (self parseMethod: 'recursiveSelfRule ^RecursiveSelfRule').
	self assert: (class parseTreeFor: #builder) equals: (self parseMethod: 'builder ^builder').
	self assert: (class parseTreeFor: #builder:) equals: (self parseMethod: 'builder: anObject builder := anObject')! !

!RBMoveMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #selector:class:variable:! !

!RBMoveMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMovePrimitiveMethod
	| refactoring |
	(model classNamed: #Object) 
		compile: 'foo <primitive: 100> ^#() primitiveFailed'
		classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model 
		andArguments: { #foo . Object . 'OrderedCollection' }.
	self shouldFail: refactoring! !

!RBMoveMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBMoveMethodRefactoring };
		addCase: { #rbClass -> RBMoveMethodTransformation };
		yourself! !

!RBMoveMethodRefactoring commentStamp: ''!
I am a refactoring for moving a method from the class to one of its instance variable objects.

Moving a method moves it implementation to one or more classes and replaces the implementation in the original method by a delegation to one of the classes instance variable. 

I expect an option for selecting the type (classes) to which this method should be added.
A role typer RBRefactoryTyper is used to guess the possible classes used for this instance variables.
And an option for requesting the new method selector.

For all selected classes a method implementing the original method is created, and if the original code uses some references to self, a parameter needs to be added to provided the former implementor.

For example, moving the method #isBlack from class Color to its instvar #rgb for the type "Integer" creates a method 


```
Integer>>#isBlack
 ^ self = 0
```
and changes Colors implementation from: 
```
Color>>#isBlack
   ^ rgb = 0
```

to:

``` 
Color>>#isBlack
   ^ rgb isBlack
```!
!RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkForSuperReferences
	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: 'super `@message: `@args'
		do: [ :aNode :answer | true ].
	(searcher executeTree: parseTree initialAnswer: false)
		ifTrue: [ self
				refactoringError: 'Cannot move the method since it has a super message send.' ]! !

!RBMoveMethodRefactoring methodsFor: 'private' stamp: ''!
buildParseTree

	parseTree := ( class parseTreeFor: selector ) copy.
	parseTree ifNil: [ self refactoringFailure: 'Could not parse method' ]! !

!RBMoveMethodRefactoring methodsFor: 'private - accessing' stamp: ''!
getClassesToMoveTo
	self isMovingToArgument 
		ifTrue: [self getClassesForTemporaryVariable]
		ifFalse: 
			[self isMovingToInstVar 
				ifTrue: [self getClassesForInstanceVariable]
				ifFalse: [self getClassForGlobalOrClassVariable]].
	moveToClasses ifEmpty: [self refactoringFailure: 'No classes selected, method not moved.']! !

!RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
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 ifNil: [ 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 ifNotNil: [ self
				refactoringWarning:
					( '<1s> is already defined by <2p> or a super/subclass<n>Try another?'
						expandMacrosWith: newSelector
						with: alreadyDefined ).
			newSelector := nil
			].
	newSelector isNil
	] whileTrue: [  ].
	parseTree
		renameSelector: newSelector
		andArguments: ( parameters collect: [ :each | RBVariableNode named: each ] ) asArray! !

!RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
abstractVariables
	self performCompositeRefactoring: self abstractVariablesRefactoring.
	parseTree := self abstractVariablesRefactoring parseTree! !

!RBMoveMethodRefactoring methodsFor: 'testing' stamp: ''!
isMovingToInstVar
	^self isMovingToArgument not 
		and: [(class whoDefinesInstanceVariable: variable) notNil]! !

!RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
compileNewMethods
	moveToClasses 
		do: [:each | each compile: parseTree newSource withAttributesFrom: (class methodFor: selector)]! !

!RBMoveMethodRefactoring methodsFor: 'initialization' stamp: ''!
selector: aSymbol class: aClass variable: aVariableName 
	selector := aSymbol.
	class := self classObjectFor: aClass.
	variable := aVariableName! !

!RBMoveMethodRefactoring methodsFor: 'private - accessing' stamp: ''!
getClassesForInstanceVariable

	| definingClass typer types |

	definingClass := class whoDefinesInstanceVariable: variable.
	typer := RBRefactoryTyper newFor: self model.
	typer runOn: definingClass.
	types := typer typesFor: variable.
	types ifEmpty: [ types := OrderedCollection with: ( self model classNamed: #Object ) ].
	moveToClasses := self selectVariableTypesFrom: types selected: ( typer guessTypesFor: variable ).
	moveToClasses ifNil: [ self refactoringFailure: 'Method not moved' ]! !

!RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkTemporaryVariableNames
	| varNames |
	varNames := parseTree allDefinedVariables.
	selfVariableName ifNotNil: [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: 'transforming' stamp: ''!
replaceVariableReferences
	| replacer |
	replacer := self parseTreeRewriter.
	replacer replace: variable with: 'self'.
	replacer executeTree: parseTree.
	parseTree := replacer tree! !

!RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkForPrimitiveMethod
	parseTree isPrimitive 
		ifTrue: [self refactoringError: 'Cannot move primitive methods']! !

!RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
abstractVariablesRefactoring
	^RBAbstractVariablesRefactoring 
		model: self model
		abstractVariablesIn: parseTree
		from: class
		toAll: moveToClasses
		ignoring: variable! !

!RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkAssignmentsToVariable
	| searcher |
	variable
		ifNotNil: [ searcher := self parseTreeSearcher.
			searcher
				matches: variable , ' := `@object'
				do: [ :aNode :answer | true ].
			(searcher executeTree: parseTree initialAnswer: false)
				ifTrue: [ self
						refactoringError:
							('Cannot move the method into <1s> since it is assigned'
								expandMacrosWith: variable) ] ]! !

!RBMoveMethodRefactoring methodsFor: 'testing' stamp: ''!
isMovingToArgument
	^(parseTree arguments collect: [:each | each name]) includes: variable! !

!RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self
		abstractVariables;
		addSelfReturn;
		replaceSelfReferences;
		replaceVariableReferences;
		compileNewMethods;
		compileDelegatorMethod! !

!RBMoveMethodRefactoring methodsFor: 'testing' stamp: ''!
hasSelfReferences
	| searcher |
	searcher := self parseTreeSearcher.
	searcher matches: 'self' do: [ :aNode :answer | true ].
	self hasOnlySelfReturns
		ifTrue: [ searcher matches: '^self' do: [ :aNode :answer | answer ] ].
	^ searcher executeTree: parseTree initialAnswer: false! !

!RBMoveMethodRefactoring methodsFor: 'testing' stamp: ''!
needsToReplaceSelfReferences
	^self hasSelfReferences 
		or: [self abstractVariablesRefactoring hasVariablesToAbstract]! !

!RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
getArgumentNameForSelf
	self needsToReplaceSelfReferences ifFalse: [^self].
	
	[selfVariableName := self requestSelfArgumentName.
	(self checkInstanceVariableName: selfVariableName in: class) 
		ifTrue: 
			[self verifyTemporaryVariableDoesNotOverride 
				ifFalse: 
					[self 
						refactoringWarning: 'The variable is already defined in one of the classes you''re moving the method to.<n>Try another?' 
								expandMacros.
					selfVariableName := nil]]
		ifFalse: 
			[self 
				refactoringWarning: 'The variable name is not a valid Smalltalk temporary variable name<n>Try again?' 
						expandMacros.
			selfVariableName := nil].
	selfVariableName isNil] 
			whileTrue: []! !

!RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class) 
		& (RBCondition withBlock: 
					[self buildParseTree.
					self checkForPrimitiveMethod.
					self checkForSuperReferences.
					self checkAssignmentsToVariable.
					self getClassesToMoveTo.
					self getArgumentNameForSelf.
					self checkTemporaryVariableNames.
					self getNewMethodName.
					true])! !

!RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
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 
			selector: ('' join: ((parseTree selector keywords asOrderedCollection) 
									removeAt: removeIndex; yourself)) asSymbol
			keywordsPositions: ((parseTree keywordsPositions asOrderedCollection) 
									removeAt: removeIndex; yourself) asIntegerArray
			arguments: ((parseTree arguments asOrderedCollection)  
									removeAt: removeIndex; yourself) asArray].! !

!RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
compileDelegatorMethod
	| statementNode delegatorNode tree |
	delegatorNode := RBMessageNode
		                 receiver: (RBVariableNode named: variable)
		                 selector: parseTree selector
		                 keywordsPositions: parseTree keywordsPositions
		                 arguments: (parseTree argumentNames collect: [ :each | 
				                  each = selfVariableName
					                  ifTrue: [ RBVariableNode selfNode ]
					                  ifFalse: [ RBVariableNode named: 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: ''!
addSelfReturn
	self hasOnlySelfReturns ifTrue: [^self].
	parseTree addSelfReturn! !

!RBMoveMethodRefactoring methodsFor: 'private - accessing' stamp: ''!
getClassesForTemporaryVariable

	| types |

	types := RBRefactoryTyper typesFor: variable in: parseTree model: self model.
	types ifEmpty: [ types := OrderedCollection with: ( self model classNamed: #Object ) ].
	moveToClasses := self selectVariableTypesFrom: types selected: types.
	moveToClasses ifNil: [ self refactoringFailure: 'Method not moved' ]! !

!RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
replaceSelfReferences
	| replacer |
	self needsToReplaceSelfReferences ifTrue: [
		replacer := self parseTreeRewriter.
		replacer replace: 'self' with: selfVariableName.
		self hasOnlySelfReturns ifTrue: 
			[replacer replace: '^self' with: '^self'].
		replacer executeTree: parseTree.
		parseTree := replacer tree].! !

!RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
verifyTemporaryVariableDoesNotOverride
	(parseTree allDefinedVariables includes: selfVariableName)
		ifTrue: [ ^ false ].
	^ moveToClasses 
		noneSatisfy: [ :each | each definesVariable: selfVariableName ]! !

!RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
hasOnlySelfReturns

	^ hasOnlySelfReturns
		ifNil: [ | searcher |

			searcher := self parseTreeSearcher.
			searcher
				matches: '^self' do: [ :aNode :answer | answer ];
				matches: '^`@object' do: [ :aNode :answer | false ].
			hasOnlySelfReturns := searcher executeTree: parseTree initialAnswer: true
			]
		ifNotNil: [ hasOnlySelfReturns ]! !

!RBMoveMethodRefactoring methodsFor: 'private - accessing' stamp: ''!
getClassForGlobalOrClassVariable
	| definingClass type |
	definingClass := class whoDefinesClassVariable: (variable ifNil: ['']).
	definingClass ifNil: [ 
			type := (self model classNamed: variable) 
				ifNotNil: [ :cls | cls classSide ]
				ifNil: [ self model classNamed: #Object ] ]
		ifNotNil: [ type := definingClass typeOfClassVariable: variable ].
	moveToClasses := self selectVariableTypesFrom: (Array with: type) selected: (Array with: type).
	moveToClasses ifNil: [ self refactoringFailure: 'Method not moved' ]! !

!RBMoveMethodRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll: selector;
		nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' variable: ''';
		nextPutAll: variable;
		nextPutAll: ''')'! !

!RBMoveMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk selector: aSymbol class: aClass variable: aVariableName
	^ self new
		model: aRBSmalltalk;
		selector: aSymbol class: aClass variable: aVariableName;
		yourself! !

!RBMoveMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol class: aClass variable: aVariableName
	^ self new
		selector: aSymbol class: aClass variable: aVariableName;
		yourself! !

!RBMoveMethodToClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMethodAlreadyDefined
	| method someClass |
	someClass := model classNamed: #RBFooLintRuleTestData.
	method := RBClassModelFactory rbMethod 
		for: someClass 
		source: 'foo' , String cr , String tab , '^ 6' 
		selector: #foo.
		
	self shouldFail: (self createRefactoringWithArguments: 
		{ method . someClass })! !

!RBMoveMethodToClassParametrizedTest methodsFor: 'tests' stamp: ''!
constructor 
	^ #method:class:! !

!RBMoveMethodToClassParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBMoveMethodToClassRefactoring };		
		addCase: { #rbClass -> RBMoveMethodToClassTransformation };
		yourself! !

!RBMoveMethodToClassRefactoring commentStamp: ''!
A RBMoveMethodToClassRefactoring is a class that represents functionality of "Move method to class" refactoring.
User chooses method, and than any of existiong classes.
Refactoring moves chosen method to class.

Instance Variables
	method:		<RBMethod>

method
	- chosen method
!
!RBMoveMethodToClassRefactoring methodsFor: 'transforming' stamp: ''!
transform
	| oldClass newClass rbMethod originalProtocol |
	oldClass := self classModelOf: method methodClass.
	newClass := self classModelOf: class.
	rbMethod := RBClassModelFactory rbMethod for: newClass source: method sourceCode selector: method selector.
	originalProtocol := method protocol.
	oldClass removeMethod: method selector.
	newClass addMethod: rbMethod.
	newClass compile: rbMethod source classified: {originalProtocol}! !

!RBMoveMethodToClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: method selector in: class) not! !

!RBMoveMethodToClassRefactoring methodsFor: 'initialization' stamp: ''!
method: aMethod class: aClass
	method := aMethod.
	class := self classObjectFor: aClass.! !

!RBMoveMethodToClassRefactoring methodsFor: 'transforming' stamp: ''!
classModelOf: aClass
	| classModel |
	classModel := aClass isMeta 
		ifTrue: [ RBClassModelFactory rbMetaclass named: aClass name ]
		ifFalse: [ RBClassModelFactory rbClass named: aClass name ].
	classModel model: self model.
	^classModel! !

!RBMoveMethodToClassRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll:  method selector;
		nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ''')'! !

!RBMoveMethodToClassRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk method: aMethod class: aClass
	^ self new
		model: aRBSmalltalk;
		method: aMethod class: aClass;
		yourself! !

!RBMoveMethodToClassRefactoring class methodsFor: 'instance creation' stamp: ''!
method: aMethod class: aClass
	^ self new
		method: aMethod class: aClass;
		yourself! !

!RBMoveMethodToClassSideParametrizedTest methodsFor: 'failure tests' stamp: ''!
testClassIsNotMeta
	| method someClass className refactoring |
	className := RBRefactoryTestDataApp class.
	someClass := model classNamed: className name.
	someClass compile: 'threeElementPoint ^ self new' classified: {#example}.
	method := someClass methodFor: ('threeElement', 'Point') asSymbol.
	refactoring := self createRefactoringWithModel: model andArguments: { method . className }.
	self shouldFail: refactoring.! !

!RBMoveMethodToClassSideParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #method:class:! !

!RBMoveMethodToClassSideParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExistsMethodInClassSide
	| method someClass className refactoring |
	className := RBRefactoryTestDataApp.
	method := className >> ('threeElement', 'Point') asSymbol.
	refactoring := self createRefactoringWithArguments: { method . className }.
	model := refactoring model.
	someClass := model classNamed: className name, ' class'.
	someClass compile: 'threeElementPoint ^ self new' classified: {#example}.
	self shouldFail: refactoring.! !

!RBMoveMethodToClassSideParametrizedTest methodsFor: 'tests' stamp: ''!
testMoveMethodToClassSide
	| method someClass className refactoring |
	className := RBRefactoryTestDataApp.
	method := className >> ('threeElement', 'Point') asSymbol.
	refactoring := self createRefactoringWithArguments: { method . className }.
	self executeRefactoring: refactoring.
	model := refactoring model.
	someClass := model classNamed: className name.
	self assert: (someClass parseTreeFor: ('threeElement', 'Point') asSymbol) equals: (self parseMethod: 'threeElementPoint ^ self class threeElementPoint').
	someClass := model classNamed: className name, ' class'.
	self assert: (someClass parseTreeFor: ('threeElement', 'Point') asSymbol) equals: (self parseMethod: 'threeElementPoint ^5 @ 5 + 6 @ 6').! !

!RBMoveMethodToClassSideParametrizedTest methodsFor: 'tests' stamp: ''!
testMoveMethodToClassSideWithInsAndMetReferences
	| method someClass className refactoring |
	className := RBTransformationRuleTestData.
	method := className >> ('rewrite', 'Using:') asSymbol.
	refactoring := self createRefactoringWithArguments: { method . className }.
	self executeRefactoring: refactoring.
	model := refactoring model.
	someClass := model classNamed: className name.
	self assert: (someClass parseTreeFor: ('rewrite', 'Using:') asSymbol) equals: (self parseMethod: 'rewriteUsing: searchReplacer
	^ self class rewriteUsing: searchReplacer').
	someClass := model classNamed: className name, ' class'.
	self assert: (someClass parseTreeFor: ('rewrite', 'Using:') asSymbol) equals: (self parseMethod: 'rewriteUsing: searchReplacer

	| aRBTransformationRuleTestData |
	aRBTransformationRuleTestData := self new.
	aRBTransformationRuleTestData rewriteRule: searchReplacer.
	aRBTransformationRuleTestData resetResult').! !

!RBMoveMethodToClassSideParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBMoveMethodToClassSideRefactoring };
		addCase: { #rbClass -> RBMoveMethodToClassSideTransformation };
		yourself! !

!RBMoveMethodToClassSideRefactoring commentStamp: ''!
I'm a refactoring to move a method to class side.

My preconditions verify that the method exists and belongs to instance side.

I catch broken references (method senders and direct access to instVar) and fix them.

Example
-----------

Script
```
	(RBMoveMethodToClassSideRefactoring 
		method: (RBTransformationRuleTestData >> #rewriteUsing:) 
		class: RBTransformationRuleTestData) execute.
```
Before refactoring:
```
RBTransformationRuleTestData >> rewriteUsing: searchReplacer 
     rewriteRule := searchReplacer.
     self resetResult.
```
After refactoring:
```
RBTransformationRuleTestData >> rewriteUsing: searchReplacer
     ^ self class rewriteUsing: searchReplace.

RBTransformationRuleTestData class >> rewriteUsing: searchReplacer
    | aRBTransformationRuleTestData |
    aRBTransformationRuleTestData := self new.
    aRBTransformationRuleTestData rewriteRule: searchReplacer.
    aRBTransformationRuleTestData resetResult.
```!
!RBMoveMethodToClassSideRefactoring methodsFor: 'transforming' stamp: ''!
getNewSource

	| rewriter node temp |
	temp := self temporaryName.
	node := RBParser parseMethod: method source.
	rewriter := RBParseTreeRewriter new replace: 'self' with: temp.
	(rewriter executeTree: node)
		ifTrue: [ 
			node := RBParser parseMethod: rewriter tree formattedCode.
			node body addNodeFirst:
				(RBParser parseExpression: temp , ' := self new').
			node body addTemporaryNamed: temp.
			^ node newSource ]
		ifFalse: [ ^ node sourceCode ] ! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'transforming' stamp: ''!
transform
	| oldClass newClass rbMethod rbMethod2 newSource originalProtocol newSource2 |
	newSource := self getNewInstSideSource.
	originalProtocol := method protocol.
	oldClass := class.
	self removeInstVariableReferences.
	method := class methodFor: method selector.
	newClass := self model classNamed: class name, ' class'.
	newSource2 := self getNewSource.
	rbMethod := RBClassModelFactory rbMethod for: newClass source: newSource2 selector: method selector.
	rbMethod2 := RBClassModelFactory rbMethod for: oldClass source: newSource selector: method selector.
	oldClass removeMethod: method selector.
	self addMethod: rbMethod to: newClass toProtocol: originalProtocol.
	self addMethod: rbMethod2 to: oldClass toProtocol: originalProtocol.! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition 
		definesSelector: method selector 
		in: class classSide) not
		& (RBCondition withBlock: [ class isMeta not ])! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'transforming' stamp: ''!
getNewInstSideSource
	| sender |
	sender := ''.
	(method argumentNames size > 0) ifTrue: [ 
		(method selector keywords) with: (method argumentNames )do: [:a :b |
		sender := sender, a, ' ', b, ' ']]
	ifFalse: [ sender := method selector ].
	^ sender, '
	^ self class ', sender! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'transforming' stamp: ''!
getTempName
	| aString counter tempName |
	counter := 0.
	aString := class canonicalArgumentName.
	tempName := aString.
	[self checkVariableNamed: tempName]
	whileTrue: [ counter := counter + 1.
		tempName := aString , counter asString ].
	^ tempName! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'transforming' stamp: ''!
addMethod: rbMethod to: aClass toProtocol: protocol
	aClass addMethod: rbMethod.
	aClass compile: rbMethod source classified: {protocol}.! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'transforming' stamp: ''!
temporaryName
	| aString counter tempName |
	counter := 0.
	aString := class canonicalArgumentName.
	tempName := aString.
	[self checkVariableNamed: tempName]
	whileTrue: [ counter := counter + 1.
		tempName := aString , counter asString ].
	^ tempName! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'refactoring' stamp: ''!
accessorsFor: variableName

	^ RBCreateAccessorsForVariableRefactoring
				model: self model
				variable: variableName
				class: class
				classVariable: false! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' method: '.
	method storeOn: aStream.
	aStream 
		nextPutAll: ' class: ';
		nextPutAll: class name.
	aStream
		nextPutAll: ')'! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'checking' stamp: ''!
checkVariableNamed: aString
	(class whoDefinesInstanceVariable: aString) ifNotNil: 
			[^ true].
	(class whoDefinesClassVariable: aString) ifNotNil: 
			[^ true].
	^ (self parseTree allDefinedVariables includes: aString) ! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'accessing' stamp: ''!
parseTree

	parseTree
		ifNil: [ parseTree := class parseTreeFor: method selector.
			parseTree ifNil: [ self refactoringFailure: 'Could not parse method' ]
			].
	^ parseTree! !

!RBMoveMethodToClassSideRefactoring methodsFor: 'transforming' stamp: ''!
removeInstVariableReferences
	| rbMethod references |
	rbMethod := (class methodFor: method selector).
	references := class instanceVariableNames select: [:e | rbMethod refersToVariable: e].
	references do: [ :e | |replacer accessorsRefactoring|
		accessorsRefactoring := self accessorsFor: e.
		self performCompositeRefactoring: accessorsRefactoring.
		replacer := self parseTreeRewriterClass 
				variable: e
				getter: accessorsRefactoring getterMethod
				setter: accessorsRefactoring setterMethod.
	   self convertMethod: method selector for: class using: replacer ].! !

!RBMoveMethodToClassSideTransformation commentStamp: ''!
I am responsible for moving a method to class side.

Usage:
| transformation |
transformation := (RBMoveMethodToClassSideTransformation
				method: #method
				class: #RBMoveMethodTransformationTest)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the method exists and belongs to instance side.!
!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
getNewSource

	| rewriter node temp |
	temp := self temporaryName.
	node := RBParser parseMethod: method source.
	rewriter := RBParseTreeRewriter new replace: 'self' with: temp.
	(rewriter executeTree: node)
		ifTrue: [ 
			node := RBParser parseMethod: rewriter tree formattedCode.
			node body addNodeFirst:
				(RBParser parseExpression: temp , ' := self new').
			node body addTemporaryNamed: temp.
			^ node newSource ]
		ifFalse: [ ^ node sourceCode ] ! !

!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
removeInstVariableReferences
	| rbMethod references |
	rbMethod := (class methodFor: method selector).
	references := class instanceVariableNames select: [:e | rbMethod refersToVariable: e].
	references do: [ :e | |replacer accessorsRefactoring|
		accessorsRefactoring := self accessorsFor: e.
		accessorsRefactoring transform.
		replacer := self parseTreeRewriterClass 
				variable: e
				getter: accessorsRefactoring getterMethod
				setter: accessorsRefactoring setterMethod.
	   self convertMethod: method selector for: class using: replacer ].! !

!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
preconditions
	^(RBCondition 
		definesSelector: method selector 
		in: class classSide) not
		& (RBCondition withBlock: [ class isMeta not ])! !

!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
getNewInstSideSource
	| sender |
	sender := ''.
	method argumentNames isNotEmpty ifTrue: [ 
		method selector keywords with: (method argumentNames) do: [:a :b |
		sender := sender, a, ' ', b, ' ']]
	ifFalse: [ sender := method selector ].
	^ sender, '
	^ self class ', sender! !

!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
addMethod: rbMethod to: aClass toProtocol: protocol
	aClass addMethod: rbMethod.
	aClass compile: rbMethod source classified: {protocol}.! !

!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
temporaryName
	| aString counter tempName |
	counter := 0.
	aString := class canonicalArgumentName.
	tempName := aString.
	[self checkVariableNamed: tempName]
	whileTrue: [ counter := counter + 1.
		tempName := aString , counter asString ].
	^ tempName! !

!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
accessorsFor: variableName

	^ RBAddVariableAccessorTransformation 
				model: self model
				variable: variableName
				class: class
				classVariable: false! !

!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' method: '.
	method storeOn: aStream.
	aStream 
		nextPutAll: ' class: ';
		nextPutAll: class name.
	aStream
		nextPutAll: ')'! !

!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
checkVariableNamed: aString
	(class whoDefinesInstanceVariable: aString) ifNotNil: 
			[^ true].
	(class whoDefinesClassVariable: aString) ifNotNil: 
			[^ true].
	^ (self parseTree allDefinedVariables includes: aString) ! !

!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
parseTree

	parseTree
		ifNil: [ parseTree := class parseTreeFor: method selector.
			parseTree ifNil: [ self refactoringFailure: 'Could not parse method' ]
			].
	^ parseTree! !

!RBMoveMethodToClassSideTransformation methodsFor: 'refactoring' stamp: ''!
privateTransform
	| oldClass newClass rbMethod rbMethod2 newSource originalProtocol newSource2 |
	newSource := self getNewInstSideSource.
	originalProtocol := method protocol.
	oldClass := class.
	self removeInstVariableReferences.
	method := class methodFor: method selector.
	newClass := self model classNamed: class name, ' class'.
	newSource2 := self getNewSource.
	rbMethod := RBClassModelFactory rbMethod for: newClass source: newSource2 selector: method selector.
	rbMethod2 := RBClassModelFactory rbMethod for: oldClass source: newSource selector: method selector.
	oldClass removeMethod: method selector.
	self addMethod: rbMethod to: newClass toProtocol: originalProtocol.
	self addMethod: rbMethod2 to: oldClass toProtocol: originalProtocol.! !

!RBMoveMethodToClassTransformation commentStamp: ''!
I am responsible for moving a method from one class to another existing class

Usage:
| transformation |
transformation := (RBMoveMethodToClassTransformation
				method: #method
				class: #RBMoveMethodTransformationTest)
				transform.
(ChangesBrowser changes: transformation model changes changes) open
!
!RBMoveMethodToClassTransformation methodsFor: 'transforming' stamp: ''!
preconditions
	^(RBCondition definesSelector: method selector in: class) not! !

!RBMoveMethodToClassTransformation methodsFor: 'transforming' stamp: ''!
method: aMethod class: aClass
	method := aMethod.
	class := self model classObjectFor: aClass.! !

!RBMoveMethodToClassTransformation methodsFor: 'transforming' stamp: ''!
classModelOf: aClass
	| classModel |
	classModel := aClass isMeta 
		ifTrue: [ RBClassModelFactory rbMetaclass named: aClass name ]
		ifFalse: [ RBClassModelFactory rbClass named: aClass name ].
	classModel model: self model.
	^classModel! !

!RBMoveMethodToClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll:  method selector;
		nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ''')'! !

!RBMoveMethodToClassTransformation methodsFor: 'transforming' stamp: ''!
privateTransform
	| oldClass newClass rbMethod originalProtocol |
	oldClass := self classModelOf: method methodClass.
	newClass := self classModelOf: class.
	rbMethod := RBClassModelFactory rbMethod for: newClass source: method sourceCode selector: method selector.
	originalProtocol := method protocol.
	oldClass removeMethod: method selector.
	newClass addMethod: rbMethod.
	newClass compile: rbMethod source classified: {originalProtocol}! !

!RBMoveMethodToClassTransformation class methodsFor: 'initialization' stamp: ''!
model: aRBSmalltalk method: aMethod class: aClass
	^ self new
		model: aRBSmalltalk;
		method: aMethod class: aClass;
		yourself! !

!RBMoveMethodToClassTransformation class methodsFor: 'initialization' stamp: ''!
method: aMethod class: aClass
	^ self new
		method: aMethod class: aClass;
		yourself! !

!RBMoveMethodTransformation commentStamp: ''!
I am a transformation for moving a method from the class to one of its instance variable objects.

Moving a method moves it implementation to one or more classes and replaces the implementation in the original method by a delegation to one of the classes instance variable. 

I expect an option for selecting the type (classes) to which this method should be added.
A role typer RBRefactoryTyper is used to guess the possible classes used for this instance variables.
And an option for requesting the new method selector.

For all selected classes a method implementing the original method is created, and if the original code uses some references to self, a parameter needs to be added to provided the former implementor.

Usage:
| transformation |
transformation := (RBMoveMethodTransformation
				selector: aSelector
				class: aClass
				variable: aVariable)
				transform.
				
For example, moving the method #isBlack from class Color to its instvar #rgb for the type "Integer" creates a method 


```
Integer>>#isBlack
 ^ self = 0
```
and changes Colors implementation from: 
```
Color>>#isBlack
   ^ rgb = 0
```

to:

``` 
Color>>#isBlack
   ^ rgb isBlack
```!
!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
checkForSuperReferences
	| searcher |
	searcher := self parseTreeSearcher.
	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.' ]! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
buildParseTree

	parseTree := ( class parseTreeFor: selector ) copy.
	parseTree ifNil: [ self refactoringFailure: 'Could not parse method' ]! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
getClassesToMoveTo
	self isMovingToArgument 
		ifTrue: [self getClassesForTemporaryVariable]
		ifFalse: 
			[self isMovingToInstVar 
				ifTrue: [self getClassesForInstanceVariable]
				ifFalse: [self getClassForGlobalOrClassVariable]].
	moveToClasses ifEmpty: [self refactoringFailure: 'No classes selected, method not moved.']! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
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 ifNil: [ 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 ifNotNil: [ self
				refactoringWarning:
					( '<1s> is already defined by <2p> or a super/subclass<n>Try another?'
						expandMacrosWith: newSelector
						with: alreadyDefined ).
			newSelector := nil
			].
	newSelector isNil
	] whileTrue: [  ].
	parseTree
		renameSelector: newSelector
		andArguments: ( parameters collect: [ :each | RBVariableNode named: each ] ) asArray! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
abstractVariables
	self abstractVariablesRefactoring transform.
	parseTree := self abstractVariablesRefactoring parseTree! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
isMovingToInstVar
	^self isMovingToArgument not 
		and: [(class whoDefinesInstanceVariable: variable) notNil]! !

!RBMoveMethodTransformation methodsFor: 'option' stamp: ''!
requestMethodNameFor: aMethodName 
	^(self options at: #methodName) cull: aMethodName cull: self! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
compileNewMethods
	moveToClasses 
		do: [:each | each compile: parseTree newSource withAttributesFrom: (class methodFor: selector)]! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
selector: aSymbol class: aClass variable: aVariableName 
	selector := aSymbol.
	class := self model classObjectFor: aClass.
	variable := aVariableName! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
getClassesForInstanceVariable

	| definingClass typer types |

	definingClass := class whoDefinesInstanceVariable: variable.
	typer := RBRefactoryTyper newFor: self model.
	typer runOn: definingClass.
	types := typer typesFor: variable.
	types ifEmpty: [ types := OrderedCollection with: ( self model classNamed: #Object ) ].
	moveToClasses := self selectVariableTypesFrom: types selected: ( typer guessTypesFor: variable ).
	moveToClasses ifNil: [ self refactoringFailure: 'Method not moved' ]! !

!RBMoveMethodTransformation methodsFor: 'private' stamp: ''!
uniqueMethodNameFor: anInteger 
	| before after index name |
	before := 'a'.
	after := ''.
	anInteger timesRepeat: [after := after , 'z:'].
	index := 0.
	
	[name := before , index printString , after.
	(Symbol findInterned: name) notNil] 
			whileTrue: [index := index + 1].
	^name asSymbol! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
checkTemporaryVariableNames
	| varNames |
	varNames := parseTree allDefinedVariables.
	selfVariableName ifNotNil: [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)]]]! !

!RBMoveMethodTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	self
		abstractVariables;
		addSelfReturn;
		replaceSelfReferences;
		replaceVariableReferences;
		compileNewMethods;
		compileDelegatorMethod! !

!RBMoveMethodTransformation methodsFor: 'testing' stamp: ''!
canReferenceVariable: aString in: aClass 
	(aClass definesVariable: aString) ifTrue: [^true].
	(self model includesGlobal: aString asSymbol) ifTrue: [^true].
	^(self poolVariableNamesFor: aClass) includes: aString! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
checkForPrimitiveMethod
	parseTree isPrimitive 
		ifTrue: [self refactoringError: 'Cannot move primitive methods']! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
abstractVariablesRefactoring
	^RBAbstractVariablesTransformation
		model: self model
		abstractVariablesIn: parseTree
		from: class
		toAll: moveToClasses
		ignoring: variable! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
checkAssignmentsToVariable
	| searcher |
	variable
		ifNotNil: [ searcher := self parseTreeSearcher.
			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) ] ]! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
isMovingToArgument
	^(parseTree arguments collect: [:each | each name]) includes: variable! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
replaceVariableReferences
	| replacer |
	replacer := self parseTreeRewriter.
	replacer replace: variable with: 'self'.
	replacer executeTree: parseTree.
	parseTree := replacer tree! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
hasSelfReferences
	| searcher |
	searcher := self parseTreeSearcher.
	searcher matches: 'self' do: [ :aNode :answer | true ].
	self hasOnlySelfReturns
		ifTrue: [ searcher matches: '^self' do: [ :aNode :answer | answer ] ].
	^ searcher executeTree: parseTree initialAnswer: false! !

!RBMoveMethodTransformation methodsFor: 'requests' stamp: ''!
selectVariableTypesFrom: initialTypeCollection selected: selectedTypeCollection 
	^ (self options at: #variableTypes) 
		value: self
		value: initialTypeCollection
		value: selectedTypeCollection
! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
needsToReplaceSelfReferences
	^self hasSelfReferences 
		or: [self abstractVariablesRefactoring hasVariablesToAbstract]! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
getArgumentNameForSelf
	self needsToReplaceSelfReferences ifFalse: [^self].
	
	[selfVariableName := self requestSelfArgumentName.
	(self checkInstanceVariableName: selfVariableName in: class) 
		ifTrue: 
			[self verifyTemporaryVariableDoesNotOverride 
				ifFalse: 
					[self 
						refactoringWarning: 'The variable is already defined in one of the classes you''re moving the method to.<n>Try another?' 
								expandMacros.
					selfVariableName := nil]]
		ifFalse: 
			[self 
				refactoringWarning: 'The variable name is not a valid Smalltalk temporary variable name<n>Try again?' 
						expandMacros.
			selfVariableName := nil].
	selfVariableName isNil] 
			whileTrue: []! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class) 
		& (RBCondition withBlock: 
					[self buildParseTree.
					self checkForPrimitiveMethod.
					self checkForSuperReferences.
					self checkAssignmentsToVariable.
					self getClassesToMoveTo.
					self getArgumentNameForSelf.
					self checkTemporaryVariableNames.
					self getNewMethodName.
					true])! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
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 
			selector: ('' join: ((parseTree selector keywords asOrderedCollection) 
									removeAt: removeIndex; yourself)) asSymbol
			keywordsPositions: ((parseTree keywordsPositions asOrderedCollection) 
									removeAt: removeIndex; yourself) asIntegerArray
			arguments: ((parseTree arguments asOrderedCollection)  
									removeAt: removeIndex; yourself) asArray].! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
compileDelegatorMethod
	| statementNode delegatorNode tree |
	delegatorNode := RBMessageNode
		                 receiver: (RBVariableNode named: variable)
		                 selector: parseTree selector
		                 keywordsPositions: parseTree keywordsPositions
		                 arguments: (parseTree argumentNames collect: [ :each | 
				                  each = selfVariableName
					                  ifTrue: [ RBVariableNode selfNode ]
					                  ifFalse: [ RBVariableNode named: each ] ]).
	self hasOnlySelfReturns ifFalse: [ delegatorNode := RBReturnNode value: delegatorNode ].
	statementNode := RBSequenceNode temporaries: #(  ) statements: (Array with: delegatorNode).
	(tree := class parseTreeFor: selector) body: statementNode.
	class compileTree: tree! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
addSelfReturn
	self hasOnlySelfReturns ifTrue: [^self].
	parseTree addSelfReturn! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
getClassesForTemporaryVariable

	| types |

	types := RBRefactoryTyper typesFor: variable in: parseTree model: self model.
	types ifEmpty: [ types := OrderedCollection with: ( self model classNamed: #Object ) ].
	moveToClasses := self selectVariableTypesFrom: types selected: types.
	moveToClasses ifNil: [ self refactoringFailure: 'Method not moved' ]! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
replaceSelfReferences
	| replacer |
	self needsToReplaceSelfReferences ifTrue: [
		replacer := self parseTreeRewriter.
		replacer replace: 'self' with: selfVariableName.
		self hasOnlySelfReturns ifTrue: 
			[replacer replace: '^self' with: '^self'].
		replacer executeTree: parseTree.
		parseTree := replacer tree].! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
verifyTemporaryVariableDoesNotOverride
	(parseTree allDefinedVariables includes: selfVariableName)
		ifTrue: [ ^ false ].
	^ moveToClasses 
		noneSatisfy: [ :each | each definesVariable: selfVariableName ]! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
hasOnlySelfReturns

	^ hasOnlySelfReturns
		ifNil: [ | searcher |

			searcher := self parseTreeSearcher.
			searcher
				matches: '^self' do: [ :aNode :answer | answer ];
				matches: '^`@object' do: [ :aNode :answer | false ].
			hasOnlySelfReturns := searcher executeTree: parseTree initialAnswer: true
			]
		ifNotNil: [ hasOnlySelfReturns ]! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
getClassForGlobalOrClassVariable
	| definingClass type |
	definingClass := class whoDefinesClassVariable: (variable ifNil: ['']).
	definingClass ifNil: [ 
			type := (self model classNamed: variable) 
				ifNotNil: [ :cls | cls classSide ]
				ifNil: [ self model classNamed: #Object ] ]
		ifNotNil: [ type := definingClass typeOfClassVariable: variable ].
	moveToClasses := self selectVariableTypesFrom: (Array with: type) selected: (Array with: type).
	moveToClasses ifNil: [ self refactoringFailure: 'Method not moved' ]! !

!RBMoveMethodTransformation methodsFor: 'option' stamp: ''!
requestSelfArgumentName
	^(self options at: #selfArgumentName) value: self! !

!RBMoveMethodTransformation methodsFor: 'transforming' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll: selector;
		nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' variable: ''';
		nextPutAll: variable;
		nextPutAll: ''')'! !

!RBMoveMethodTransformation class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk selector: aSymbol class: aClass variable: aVariableName
	^ self new
		model: aRBSmalltalk;
		selector: aSymbol class: aClass variable: aVariableName;
		yourself! !

!RBMoveMethodTransformation class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol class: aClass variable: aVariableName
	^ self new
		selector: aSymbol class: aClass variable: aVariableName;
		yourself! !

!RBMoveTemporaryVariableDefinitionTransformation commentStamp: ''!
Moves the definition of a temporary variable to the block/scope where it is used.

For a temporary variable defined in a method but only initialized and used within a block, the transformation moves the definition to the block which uses this variable.

The transformation automatically searches for the block(s) where the definition could be moved to.

Usage:
| transformation |
transformation := (RBMoveTemporaryVariableDefinitionTransformation
				variable: #temp
				inMethod: #moveDefinition
				inClass: #RBDummyRefactoryTestDataApp)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- there is a block where the variable definition can be moved to.!
!RBMoveTemporaryVariableDefinitionTransformation methodsFor: 'private' stamp: ''!
checkLocationsIn: candidateBlocks

	(candidateBlocks 
		detect: [:each | RBReadBeforeWrittenTester
							isVariable: variableName readBeforeWrittenIn: each]
		ifNone: [nil]) notNil 
		ifTrue: [^false].
		
	blockNodes ifNil: [ blockNodes := OrderedCollection new ].
	candidateBlocks do: [ :each | 
		(self checkBlocksIn: each body) 
			ifTrue: [ blockNodes add: each ]
			ifFalse: 	[ (self checkLocationsIn: (self checkAllBlocksIn: each body)) 
							ifFalse: [ blockNodes add: each ]]].
	^ true! !

!RBMoveTemporaryVariableDefinitionTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ ( RBCondition
			withBlock: [ self definingClass isNotNil ]
			errorString: 'No such class or trait named ', class asString)
		& ( RBCondition definesSelector: selector in: self definingClass)
		& ( RBCondition
			withBlock: [ self definingMethod allTemporaryVariables includes: variableName ]
			errorString: 'Method named ', selector, ' does not define a temporary variable named ', variableName )
		& ( RBCondition
			withBlock: [ (self definingMethod allArgumentVariables includes: variableName) not ]
			errorString: 'Variable named ', variableName, ' cannot be removed because it is an argument in this method' )
		& ( RBCondition
			withBlock: [ (self checkBlocksIn: self definingBlock) not ]
			errorString: 'Variable named ', variableName, ' is already bound tightly as possible.')
		& ( RBCondition
			withBlock: [ self checkLocationsIn: (self checkAllBlocksIn: self definingBlock) ]
			errorString: 'Variable named ', variableName, ' is used in an outside block.')! !

!RBMoveTemporaryVariableDefinitionTransformation methodsFor: 'private' stamp: ''!
checkBlocksIn: aParseTree
	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: '[:`@args | | `@temps | `@.Statements]'
			do: [ :aNode :answer | answer ];
		matches: variableName do: [ :aNode :answer | true ].
	^ searcher executeTree: aParseTree initialAnswer: false! !

!RBMoveTemporaryVariableDefinitionTransformation methodsFor: 'private' stamp: ''!
checkAllBlocksIn: aParseTree
	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: '[:`@blockTemps | | `@temps | `@.Statements]'
		do: [ :aNode :answer | 
			(aNode references: variableName)
				ifTrue: [ answer add: aNode ].
			answer ].
	^ searcher
		executeTree: aParseTree
		initialAnswer: OrderedCollection new! !

!RBMoveTemporaryVariableDefinitionTransformation methodsFor: 'private' stamp: ''!
checkMethodForBlocks

	| definingNode |
	definingNode := self definingBlock.
	self checkBlocksIn: definingNode.
	self checkLocationsIn: (self checkAllBlocksIn: definingNode)! !

!RBMoveTemporaryVariableDefinitionTransformation methodsFor: 'private' stamp: ''!
definingBlock

	| node definingNode |
	node := self definingMethod
		ifNil: [ self refactoringError: 'Method does not exist' ]
		ifNotNil: [ :methodNode | methodNode variableWith: variableName ].
	node ifNil: [self refactoringError: 'Unable to locate temporary variable in parse tree'].
	
	definingNode := node whoDefines: variableName.
	definingNode 
		ifNil: [self refactoringError: 'Cannot locate variable definition'].
	definingNode isSequence
		ifFalse: [self refactoringError: 'Variable is an argument'].
		
	^ definingNode! !

!RBMoveTemporaryVariableDefinitionTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName inMethod: aSelector inClass: aClass

	class := aClass.
	selector := aSelector.
	variableName := aVariableName! !

!RBMoveTemporaryVariableDefinitionTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' variable: ''';
		nextPutAll: variableName;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBMoveTemporaryVariableDefinitionTransformation methodsFor: 'converting' stamp: ''!
asRefactoring

	^ super asRefactoring
		delegatesPreconditions: false;
		yourself! !

!RBMoveTemporaryVariableDefinitionTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	"ifnil... tight blocks should not be returned as errors"
	blockNodes ifNil: [ self checkMethodForBlocks ].
	
	^ (OrderedCollection
		withAll: ((blockNodes
			sorted: [ :a :b | a start > b start ])
			collect: [ :blockNode | 
				RBAddTemporaryVariableTransformation
					variable: variableName
					inInterval: blockNode body sourceInterval
					inMethod: selector
					inClass: class ]))
		add: (RBRemoveTemporaryVariableTransformation
					variable: variableName
					inMethod: selector
					inClass: class);
		yourself! !

!RBMoveTemporaryVariableDefinitionTransformation class methodsFor: 'api' stamp: ''!
variable: aString inMethod: aSelector inClass: aClass

	^ self new
		variable: aString
		inMethod: aSelector
		inClass: aClass;
		yourself! !

!RBMoveTemporaryVariableDefinitionTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel variable: aString inMethod: aSelector inClass: aClass

	^ self new
		model: aRBModel;
		variable: aString
		inMethod: aSelector
		inClass: aClass;
		yourself! !

!RBMoveTemporaryVariableDefinitionTransformationTest methodsFor: 'tests' stamp: ''!
testMoveDefinitionIntoBlockThatIsAReceiverOfACascadedMessage

	| transformation class |				
	transformation := (RBMoveTemporaryVariableDefinitionTransformation 
							variable: #association
							inMethod: #referencesConditionFor: 
							inClass: #RBDummyRefactoryTestDataApp)
							asRefactoring transform.
							
	class := transformation model classNamed: #RBDummyRefactoryTestDataApp.
	self assert: (class parseTreeFor: #referencesConditionFor:)
		  equals: (self 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.<n>Browse references?'';
							errorBlock: [environment openEditor];
							yourself')! !

!RBMoveTemporaryVariableDefinitionTransformationTest methodsFor: 'tests' stamp: ''!
testNowhereToMove

	| transformation |
	transformation := (RBMoveTemporaryVariableDefinitionTransformation 
							variable: #temp
							inMethod: #noMoveDefinition 
							inClass: #RBDummyRefactoryTestDataApp).
	self assert: transformation model changes changes size equals: 0.	
	
	self shouldFail: (RBMoveTemporaryVariableDefinitionTransformation 
							variable: #temp
							inMethod: #noMoveDefinition 
							inClass: #RBDummyRefactoryTestDataApp)
							asRefactoring! !

!RBMoveTemporaryVariableDefinitionTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBMoveTemporaryVariableDefinitionTransformation 
							variable: #temp
							inMethod: #name1
							inClass: #RBDummyLintRuleTest)! !

!RBMoveTemporaryVariableDefinitionTransformationTest methodsFor: 'tests' stamp: ''!
testMoveDefinition

	| transformation class |
	transformation := (RBMoveTemporaryVariableDefinitionTransformation
							variable: #temp
							inMethod: #moveDefinition
							inClass: #RBDummyRefactoryTestDataApp)
							transform.
		
	class := transformation model classNamed: #RBDummyRefactoryTestDataApp.
	self assert: (class parseTreeFor: #moveDefinition)
		  equals: (self parseMethod: 'moveDefinition
								^(self collect: 
										[:each | 
										| temp |
										temp := each printString.
										temp , temp]) 
									select: 
										[:each | 
										| temp |
										temp := each size.
										temp odd]')! !

!RBMoveTemporaryVariableDefinitionTransformationTest methodsFor: 'tests' stamp: ''!
testVariableDoesNotExist

	self shouldFail: (RBMoveTemporaryVariableDefinitionTransformation 
							variable: #temp
							inMethod: #displayName
							inClass: #RBDummyLintRuleTest).
	self shouldFail: (RBMoveTemporaryVariableDefinitionTransformation 
							variable: #temp
							inMethod: #displayName
							inClass: #RBDummyLintRuleTest)
							asRefactoring! !

!RBMoveVariableDefinitionParametrizedTest methodsFor: 'tests' stamp: ''!
testMoveDefinitionIntoBlockThatIsAReceiverOfACascadedMessage
	| refactoring |
	refactoring := self createRefactoringWithArguments:
		{ (48 to: 58) . RBRefactoryTestDataApp . #referencesConditionFor: }.
	self executeRefactoring: refactoring.
	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #referencesConditionFor:) equals: (self parseMethod: 'referencesConditionFor: aClass 
								| environment  |
								^(RBCondition withBlock: 
										[| association |association := Smalltalk globals 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.<n>Browse references?'';
									errorBlock: [environment openEditor];
									yourself')! !

!RBMoveVariableDefinitionParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	self shouldFail:
		(self createRefactoringWithArguments: { (1 to: 10) . RBLintRuleTestData . #name1 }).
	self shouldFail:
		(self createRefactoringWithArguments: { (44 to: 54) . RBLintRuleTestData . #displayName }).
	self shouldFail:
		(self createRefactoringWithArguments: { (16 to: 25) . RBLintRuleTestData . #displayName })! !

!RBMoveVariableDefinitionParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNoMoveDefinition
	self shouldFail: (self createRefactoringWithArguments:
		{ (21 to: 24) . RBRefactoryTestDataApp . #noMoveDefinition })! !

!RBMoveVariableDefinitionParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInvalidSelector
	self shouldFail: (self createRefactoringWithArguments:
		{ (21 to: 24) . RBRefactoryTestDataApp . #caller3 })! !

!RBMoveVariableDefinitionParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #bindTight:in:selector:! !

!RBMoveVariableDefinitionParametrizedTest methodsFor: 'tests' stamp: ''!
testMoveDefinition
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{ (19 to: 22) . RBRefactoryTestDataApp . #moveDefinition }.
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #moveDefinition) equals: (self parseMethod: 'moveDefinition
								^(self collect: 
										[:each | 
										| temp |
										temp := each printString.
										temp , temp]) 
									select: 
										[:each | 
										| temp |
										temp := each size.
										temp odd]')! !

!RBMoveVariableDefinitionParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBMoveVariableDefinitionRefactoring };
		yourself! !

!RBMoveVariableDefinitionRefactoring commentStamp: ''!
I am a refactoring for moving the definition of a variable to the block/scope where it is used.

For a method temporary variable declared but not initialized in the method scope and only used within a block, the definition can be moved to the block using this variable.!
!RBMoveVariableDefinitionRefactoring methodsFor: 'transforming' stamp: ''!
transform
	definingNode removeTemporaryNamed: name.
	blockNodes do: [:each | each body addTemporaryNamed: name].
	class compileTree: parseTree! !

!RBMoveVariableDefinitionRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class) 
		& (RBCondition withBlock: 
					[| methodSource |
					interval first <= interval last 
						ifFalse: [self refactoringFailure: 'You must select a 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: 'transforming' stamp: ''!
checkParseTree

	| node |

	blockNodes := OrderedCollection new.
	node := self whichVariableNode: parseTree inInterval: interval name: name.
	node ifNil: [ self refactoringFailure: 'Unable to locate node in parse tree' ].
	definingNode := node whoDefines: name.
	definingNode ifNil: [ self refactoringFailure: 'Cannot locate variable definition' ].
	definingNode isSequence
		ifFalse: [ self refactoringFailure: 'Variable is an argument' ].
	( self usesDirectly: definingNode )
		ifTrue: [ self refactoringFailure: 'Variable already bound tightly as possible' ].
	( self checkNodes: ( self subblocksIn: definingNode ) )
		ifFalse: [ self refactoringError: 'Variable is possibly read before written' ]! !

!RBMoveVariableDefinitionRefactoring methodsFor: 'transforming' stamp: ''!
usesDirectly: aParseTree
	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: '[:`@args | | `@temps | `@.Statements]'
			do: [ :aNode :answer | answer ];
		matches: name do: [ :aNode :answer | true ].
	^ searcher executeTree: aParseTree initialAnswer: false! !

!RBMoveVariableDefinitionRefactoring methodsFor: 'initialization' stamp: ''!
class: aClass selector: aSelector interval: anInterval 
	interval := anInterval.
	class := self classObjectFor: aClass.
	selector := aSelector! !

!RBMoveVariableDefinitionRefactoring methodsFor: 'transforming' stamp: ''!
subblocksIn: aParseTree
	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: '[:`@blockTemps | | `@temps | `@.Statements]'
		do: [ :aNode :answer | 
			(aNode references: name)
				ifTrue: [ answer add: aNode ].
			answer ].
	^ searcher
		executeTree: aParseTree
		initialAnswer: OrderedCollection new! !

!RBMoveVariableDefinitionRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' bindTight: '.
	interval storeOn: aStream.
	aStream nextPutAll: ' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll: selector.
	aStream nextPut: $)! !

!RBMoveVariableDefinitionRefactoring methodsFor: 'transforming' stamp: ''!
checkNodes: sequenceNodes 
	(sequenceNodes 
		anySatisfy: [:each | RBReadBeforeWrittenTester isVariable: name readBeforeWrittenIn: each]) 
		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 class methodsFor: 'instance creation' stamp: ''!
bindTight: anInterval in: aClass selector: aSelector 
	^ self new
		class: aClass
		selector: aSelector
		interval: anInterval! !

!RBMoveVariableDefinitionRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk bindTight: anInterval in: aClass selector: aSelector 
	^ self new
		model: aRBSmalltalk;
		class: aClass
			selector: aSelector
			interval: anInterval;
		yourself! !

!RBMultiEnvironment methodsFor: 'accessing' stamp: ''!
environments
	^environmentDictionaries keys! !

!RBMultiEnvironment methodsFor: 'adding' stamp: ''!
addClass: aClass selector: aSymbol into: aValue 
	(environmentDictionaries at: aValue ifAbsentPut: [RBSelectorEnvironment new]) 
		addClass: aClass
		selector: aSymbol! !

!RBMultiEnvironment methodsFor: 'testing' stamp: ''!
isEmpty
	^environmentDictionaries isEmpty! !

!RBMultiEnvironment methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	environmentDictionaries := Dictionary new.
	environment := RBSelectorEnvironment new! !

!RBMultiEnvironment methodsFor: 'accessing' stamp: ''!
problemCount
	^environmentDictionaries size! !

!RBMultiEnvironment methodsFor: 'testing' stamp: ''!
includesCategory: aCategory
	^ (super includesCategory: aCategory) and: [ environmentDictionaries anySatisfy: [ :env | env includesCategory: aCategory ] ]! !

!RBMultiEnvironment methodsFor: 'testing' stamp: ''!
includesSelector: aSelector in: aClass
	^ (super includesSelector: aSelector in: aClass) and: [ environmentDictionaries anySatisfy: [ :env | env includesSelector: aSelector in: aClass ] ]! !

!RBMultiEnvironment methodsFor: '*Manifest-Core' stamp: ''!
isMultiEnvironment
	^ true! !

!RBMultiEnvironment methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass
	^ (super includesProtocol: aProtocol in: aClass) and: [ environmentDictionaries anySatisfy: [ :env | env includesProtocol: aProtocol in: aClass ] ]! !

!RBMultiEnvironment methodsFor: 'accessing' stamp: ''!
packages
	self shouldBeImplemented! !

!RBMultiEnvironment methodsFor: '*Manifest-Core' stamp: ''!
smallLintCritics
	^ self asSelectorEnvironment smallLintCritics! !

!RBMultiEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass
	^ (super includesClass: aClass) and: [ environmentDictionaries anySatisfy: [ :env | env includesClass: aClass ] ]! !

!RBMultiEnvironment methodsFor: 'removing' stamp: ''!
removeClass: aClass selector: aSelector into: aValue 
	(environmentDictionaries at: aValue ifAbsentPut: [RBSelectorEnvironment new]) 
		removeClass: aClass
		selector: aSelector! !

!RBMultiEnvironment methodsFor: 'adding' stamp: ''!
addClass: aClass into: aValue 
	(environmentDictionaries at: aValue ifAbsentPut: [RBSelectorEnvironment new]) 
		addClass: aClass! !

!RBMultiEnvironment methodsFor: 'accessing' stamp: ''!
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: 'removing' stamp: ''!
removeClass: aClass into: aValue 
	(environmentDictionaries at: aValue ifAbsent: [RBSelectorEnvironment new]) 
		removeClass: aClass! !

!RBMultiEnvironment methodsFor: 'accessing' stamp: ''!
selectEnvironment: aValue 
	environment := environmentDictionaries at: aValue
				ifAbsent: [RBSelectorEnvironment new]! !

!RBMultiEnvironment methodsFor: 'removing' stamp: ''!
removeClass: aClass
	environmentDictionaries keysDo: [ :key |
		(environmentDictionaries at: key) removeClass: aClass ]! !

!RBMultiKeywordLiteralToken commentStamp: ''!
I am used for a multi-keyword literal, found in a literal array.
Scanning a message send with a multi-keyword selector produces not this token.
Instead, that token stream would contain multiple `RBKeywordToken`s. 
But if a multikeyword selector is within a literal array `#(printOn:indent: )`
this single selector `printOn:indent:` is scanned as one `RBMultiKeywordLiteralToken`(`#printOn:indent:`).
!
!RBMultiKeywordLiteralToken methodsFor: 'testing' stamp: ''!
isMultiKeyword
	^true! !

!RBNamespace commentStamp: ''!
I am a namespace for refactoring operations.
I collect changes during refactoring and provide an environment for resolving named entities like
classes, method senders or implementors. 

The default environment for a namespace contains all classes in the system, but you can create 
an instance of me with a scoped environment to apply the refactoring operations only on entities in 
that environment.

Resolving named entities includes classes and methods changed or added during refactoring, before
actually applying this changes to the system. For this, I create model classes - RBClass and RBMetaclass - modeling real classes.

The changes that will be applied to the system are collected as refactoring changes (RBRefactoryChange).

Example: 
This creates a new namespace on the default environment (all system classes):
 model := RBNamespace onEnvironment: RBBrowserEnvironment new.

This creates a Refactoring operation for adding a class, with me as the namespace model:
    refactoring := RBAddClassRefactoring
        model: model
        addClass: #SomeClass
        superclass: #Object
        subclasses: {}
        category: #Category.

This will do a "dry run", only collect the changes of this refactoring:
    refactoring primitiveExecute.

Now can ask me for this list of changes:
   model changes.
this acutally gives a composite refactory change that holds a list of all single refacoring changes.

Note, some of my methods for querying method senders and implementors don't work well for Trait methods, because we don't have yet modeling classes for Traits and some refactoring operations don't support refactorings on trait methods.
!
!RBNamespace methodsFor: 'private - changes' stamp: ''!
removeProtocolNamed: aString in: aClass

	^ changes removeProtocolNamed: aString in: aClass! !

!RBNamespace methodsFor: 'private' stamp: ''!
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: ''!
addPackageNamed: aSymbol
	| change pkg |
	change := changes addPackageNamed: aSymbol.
	self flushCaches.
	pkg := self packageNamed: aSymbol.
	self unmarkPackageAsRemoved: aSymbol.
	newPackages at: aSymbol put: pkg.
	^change! !

!RBNamespace methodsFor: 'private' stamp: ''!
markAsRemoved: aClassName

	removedClasses
		add: aClassName;
		add: aClassName, ' class'! !

!RBNamespace methodsFor: 'accessing - classes' stamp: ''!
packageNamed: aSymbol
	aSymbol ifNil: [ ^ nil ].
	(self hasPackageRemoved: aSymbol) ifTrue: [ ^ nil ].
	(newPackages includesKey: aSymbol) ifTrue: [ ^ newPackages at: aSymbol ].
	(changedPackages includesKey: aSymbol) ifTrue: [ ^ (changedPackages at: aSymbol) first ].
	^ (self createNewPackageFor: aSymbol) first! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
environment
	^ environment ifNil: [ environment := RBBrowserEnvironment new].! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
description
	^ self changes name! !

!RBNamespace methodsFor: 'accessing - classes' stamp: ''!
classNamed: aSymbol
	| class classes index |
	aSymbol ifNil: [ ^ 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 ifNotNil: [ class classSide ]! !

!RBNamespace methodsFor: 'testing' stamp: ''!
includesClassNamed: aSymbol 
	^(self classNamed: aSymbol) notNil! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
allImplementorsOf: aSelector 
	^ implementorsCache at: aSelector ifAbsentPut: [ self privateImplementorsOf: aSelector ]! !

!RBNamespace methodsFor: 'converting' stamp: ''!
classObjectFor: anObject

	(anObject isBehavior or: [anObject isTrait])
		ifTrue: [ ^ self classFor: anObject ].
	anObject isString
		ifTrue: [ ^ self classNamed: anObject asSymbol ].
	^ anObject! !

!RBNamespace methodsFor: 'private' stamp: ''!
privateReferencesTo: aSelector 
	| methods |
	methods := OrderedCollection new.
	self allClassesDo: [ :class |
		(class whichSelectorsReferToSymbol: aSelector)
			do: [ :selector |
				methods add: (class methodFor: selector) ] ].
	^ methods! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
renameInstanceVariable: oldName to: newName in: aRBClass around: aBlock 
	^self performChange: (changeFactory 
				renameInstanceVariable: oldName
				to: newName
				in: aRBClass)
		around: aBlock! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
flushCaches
	implementorsCache := IdentityDictionary new.
	sendersCache := IdentityDictionary new! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
replaceClassNameIn: definitionString to: aSymbol 
	| parseTree |
	parseTree := self parserClass parseExpression: definitionString.
	parseTree receiver: (RBVariableNode named: aSymbol).
	^parseTree formattedCode! !

!RBNamespace methodsFor: '*Refactoring2-Core' stamp: ''!
category: aString for: aClass

	^ changes addChange: (RBClassCategoryChange category: aString for: aClass)! !

!RBNamespace methodsFor: 'changes' stamp: ''!
renameClass: aRBClass to: aSymbol around: aBlock
	| change value dict |
	change := changeFactory renameClass: aRBClass to: aSymbol.
	self performChange: change around: aBlock.
	self flushCaches.
	dict := (newClasses includesKey: aRBClass name)
		ifTrue: [ newClasses ]
		ifFalse: [ changedClasses ].
	self markAsRemoved: aRBClass name.
	self unmarkAsRemoved: aSymbol.
	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: 'accessing - classes' stamp: ''!
whichCategoryIncludes: aSymbol
	^self environment whichCategoryIncludes: aSymbol! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
rootClasses
	^ rootClasses ifNil: [ rootClasses := self privateRootClasses]! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
removeInstanceVariable: aString from: aRBClass 
	^changes removeInstanceVariable: aString from: aRBClass! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
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 instanceSide.
					( ( seen includes: class name ) or: [ self hasRemoved: ( self classNameFor: class ) ] )
						ifFalse: [ ( class := self classFor: each )
								ifNotNil: [ seen add: class name.
									aBlock
										value: class;
										value: class classSide
									]
							]
					]
			]! !

!RBNamespace methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	changes := changeFactory compositeRefactoryChange onSystemDictionary: self environment.
	newClasses := IdentityDictionary new.
	newPackages := IdentityDictionary new.
	changedClasses := IdentityDictionary new.
	changedPackages := IdentityDictionary new.
	removedClasses := Set new.
	removedPackages := Set new.
	implementorsCache := IdentityDictionary new.
	sendersCache := IdentityDictionary new! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
addPool: aString to: aRBClass 
	^changes addPool: aString to: aRBClass! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
description: aString
	self changes name: aString! !

!RBNamespace methodsFor: 'testing' stamp: ''!
hasRemoved: aSymbol 
	^removedClasses includes: aSymbol! !

!RBNamespace methodsFor: 'testing' stamp: ''!
includesGlobal: aSymbol 
	(self hasRemoved: aSymbol) ifTrue: [^false].
	(self includesClassNamed: aSymbol) ifTrue: [^true].
	environment at: aSymbol ifAbsent: [^false].
	^true! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
removeClassVariable: aString from: aRBClass 
	^changes removeClassVariable: aString from: aRBClass! !

!RBNamespace methodsFor: 'private' stamp: ''!
privateReferencesTo: aSelector inPackages: aColl
	| methods |
	methods := OrderedCollection new.
	self allClassesInPackages: aColl do: [ :class |
		(class whichSelectorsReferToSymbol: aSelector)
			do: [ :selector |
				methods add: (class methodFor: selector) ] ].
	^ methods! !

!RBNamespace methodsFor: 'private' stamp: ''!
classNameFor: aBehavior 
	^ aBehavior instanceSide name! !

!RBNamespace methodsFor: 'testing' stamp: ''!
hasPackageRemoved: aSymbol 
	^removedPackages includes: aSymbol! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
addChangeToClass: aRBClass
	^ changedClasses 
		at: aRBClass name
		put: (Array 
				with: aRBClass instanceSide
				with: aRBClass classSide)! !

!RBNamespace methodsFor: 'changes' stamp: ''!
removeClassNamed: aSymbol 
	(self classNamed: aSymbol) subclasses 
		do: [:each | self removeClassNamed: each name].
	removedClasses
		add: aSymbol;
		add: aSymbol , ' class'.
	newClasses removeKey: aSymbol ifAbsent: [].
	changedClasses removeKey: aSymbol ifAbsent: [].
	self flushCaches.
	^changes removeClassNamed: aSymbol! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
allReferencesTo: aSymbol in: classes
	| classNames |
	classNames := classes collect: [ :cls | cls name ].
	^ (self allReferencesTo: aSymbol) select: [ :ref | classNames includes: ref modelClass name ]! !

!RBNamespace methodsFor: 'transforming' stamp: ''!
selector: aSelector in: aClass classified: aProtocol

	^ changes
		selector: aSelector
		in: aClass
		classified: aProtocol! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
renameClassVariable: oldName to: newName in: aRBClass around: aBlock 
	^self performChange: (changeFactory  
				renameClassVariable: oldName
				to: newName
				in: aRBClass)
		around: aBlock! !

!RBNamespace methodsFor: 'changes' stamp: ''!
removeClass: aRBClass 
	self removeClassNamed: aRBClass name! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
allReferencesTo: aSymbol do: aBlock
	(self allReferencesTo: aSymbol) do: aBlock! !

!RBNamespace methodsFor: 'accessing - classes' stamp: ''!
createNewClassFor: aBehavior 
	| nonMeta meta className rbType rbMetaType |
	className := aBehavior instanceSide name.
	aBehavior isTrait 
		ifTrue: [ 
			rbType := modelFactory rbTrait.
			rbMetaType := modelFactory rbTraitMetaclass.
		] ifFalse: [ 
			rbType := modelFactory rbClass.
			rbMetaType := modelFactory rbMetaclass.
		].
	nonMeta := rbType existingNamed: className model: self.
	meta := rbMetaType existingNamed: className model: self.
	nonMeta category: aBehavior category.
	^changedClasses at: className put: (Array with: nonMeta with: meta)! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
allReferencesTo: aSymbol inPackages: aColl
	^ sendersCache at: aSymbol ifAbsentPut: [ self privateReferencesTo: aSymbol inPackages: aColl ]! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
environment: aBrowserEnvironment 
	environment := aBrowserEnvironment! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
removePackageNamed: aString

	self flushCaches.
	^ changes removePackageNamed: aString.! !

!RBNamespace methodsFor: 'adding' stamp: ''!
addProtocolNamed: aString in: aClass

	^ changes addProtocolNamed: aString in: aClass! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
allImplementorsOf: aSelector inPackages: aColl
	^ implementorsCache at: aSelector ifAbsentPut: [ self privateImplementorsOf: aSelector in: aColl ]! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
compile: aString in: aRBClass classified: aSymbol 
	| change |
	change := changes 
				compile: aString
				in: aRBClass
				classified: aSymbol.
	self flushCaches.
	^change! !

!RBNamespace methodsFor: 'accessing - classes' stamp: ''!
createNewPackageFor: aPackage
	| package |
	package := modelFactory rbPackage existingNamed: aPackage model: self.
	^changedPackages at: aPackage put: (Array with: package)! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
addClassVariable: aString to: aRBClass 
	^changes addClassVariable: aString to: aRBClass! !

!RBNamespace methodsFor: 'changes' stamp: ''!
defineClass: aString

	| change newClass newClassName |
	change := changes defineClass: aString.
	newClassName := change changeClassName.
	newClass := self classNamed: newClassName.
	newClass
		ifNil: [ | newMetaclass |

			self unmarkAsRemoved: newClassName.
			newClass := modelFactory rbClass named: newClassName.
			newMetaclass := modelFactory 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
		ifNil: [ self rootClasses add: newClass.
			newClass classSide superclass: ( self classFor: Object class superclass )
			]
		ifNotNil: [ newClass classSide superclass: newClass superclass classSide ].
	newClass instanceVariableNames: change instanceVariableNames.
	newClass classVariableNames: change classVariableNames.
	newClass poolDictionaryNames: change sharedPoolNames.
	newClass category: change category.
	^ change! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
removeMethod: aSelector from: aRBClass 
	self flushCaches.
	^changes removeMethod: aSelector from: aRBClass! !

!RBNamespace methodsFor: 'private' stamp: ''!
unmarkPackageAsRemoved: newPackageName
	removedPackages
		remove: newPackageName ifAbsent: [  ]! !

!RBNamespace methodsFor: 'transforming' stamp: ''!
convertClasses: classSet select: aBlock using: searchReplacer
 
	classSet do: [ :aClass | 
		(aBlock value: aClass) do: [ :selector |
			aClass convertMethod: selector using: searchReplacer ]]! !

!RBNamespace methodsFor: 'private' stamp: ''!
privateImplementorsOf: aSelector in: packages
	| classes |
	classes := Set new.
	self allClassesInPackages: packages do: [ :class |
		(class directlyDefinesLocalMethod: aSelector)
			ifTrue: [ classes add: class ].
		(class classSide directlyDefinesLocalMethod: aSelector)
			ifTrue: [ classes add: class classSide ] ].
	^ classes! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
name: aString
	^changes name: aString! !

!RBNamespace methodsFor: 'changes' stamp: ''!
comment: aString in: aClass
	^ changes comment: aString in: aClass! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
allReferencesTo: aSymbol inPackages: aColl do: aBlock
	(self allReferencesTo: aSymbol inPackages: aColl) do: aBlock! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
changes
	^changes! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
allReferencesTo: aSymbol
	^ sendersCache at: aSymbol ifAbsentPut: [ self privateReferencesTo: aSymbol ]! !

!RBNamespace methodsFor: 'changes' stamp: ''!
renamePackage: aRBPackage to: aSymbol
	| change value dict |
	change := changeFactory renamePackage: aRBPackage to: aSymbol.
	self performChange: change around: [].
	self flushCaches.
	dict := changedPackages.
	self markPackageAsRemoved: aRBPackage name.
	self unmarkPackageAsRemoved: aSymbol.
	value := dict at: aRBPackage name.
	dict removeKey: aRBPackage name.
	dict at: aSymbol put: value.
	value first name: aSymbol.
	^ change! !

!RBNamespace methodsFor: 'changes' stamp: ''!
reparentClasses: aRBClassCollection to: newClass 
	aRBClassCollection do: 
			[:aClass | 
			self defineClass: (self replaceClassNameIn: aClass definitionString
						to: newClass name)]! !

!RBNamespace methodsFor: 'private' stamp: ''!
markPackageAsRemoved: aPackageName

	removedPackages
		add: aPackageName! !

!RBNamespace methodsFor: 'private' stamp: ''!
hasCreatedClassFor: aBehavior 
	| className |
	className := self classNameFor: aBehavior.
	^(newClasses includesKey: className) 
		or: [changedClasses includesKey: className]! !

!RBNamespace methodsFor: 'accessing - classes' stamp: ''!
metaclassNamed: aSymbol

	| class |

	aSymbol ifNil: [ ^ 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' stamp: ''!
allImplementorsOf: aSelector do: aBlock
	(self allImplementorsOf: aSelector) do: aBlock! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
performChange: aCompositeRefactoryChange around: aBlock 
	| oldChanges |
	changes addChange: aCompositeRefactoryChange.
	oldChanges := changes.
	changes := aCompositeRefactoryChange.
	aBlock ensure: [changes := oldChanges].
	^aCompositeRefactoryChange! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
allReferencesToClass: aRBClass inPackages: aColl do: aBlock 
	self allClassesInPackages: aColl do:
			[:each |
			(each whichSelectorsReferToClass: aRBClass) 
				do: [:sel | aBlock value: (each methodFor: sel)].
			(each classSide whichSelectorsReferToClass: aRBClass) 
				do: [:sel | aBlock value: (each classSide methodFor: sel)]]! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
removeClassKeepingSubclassesNamed: aSymbol 
	removedClasses
		add: aSymbol;
		add: aSymbol , ' class'.
	newClasses removeKey: aSymbol ifAbsent: [].
	changedClasses removeKey: aSymbol ifAbsent: [].
	self flushCaches.
	^changes removeClassNamed: aSymbol! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
changeClass: aRBClass 
	changedClasses 
		at: aRBClass name
		put: (Array 
				with: aRBClass instanceSide
				with: aRBClass classSide).
	self flushCaches! !

!RBNamespace methodsFor: 'private' stamp: ''!
privateImplementorsOf: aSelector 
	| classes |
	classes := Set new.
	self allClassesDo: [ :class |
		(class directlyDefinesLocalMethod: aSelector)
			ifTrue: [ classes add: class ].
		(class classSide directlyDefinesLocalMethod: aSelector)
			ifTrue: [ classes add: class classSide ] ].
	^ classes! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
name
	^changes name! !

!RBNamespace methodsFor: 'testing' stamp: ''!
includesPackageNamed: aSymbol 
	^(self packageNamed: aSymbol) notNil! !

!RBNamespace methodsFor: 'accessing - classes' stamp: ''!
classFor: aBehavior

	aBehavior ifNil: [ ^ nil ].
	^ aBehavior isMeta
		ifTrue: [ self metaclassNamed: aBehavior instanceSide name ]
		ifFalse: [ self classNamed: aBehavior instanceSide name ]! !

!RBNamespace methodsFor: 'private - changes' stamp: ''!
addInstanceVariable: aString to: aRBClass 
	^changes addInstanceVariable: aString to: aRBClass! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
allClassesInPackages: aColl do: aBlock

	| seen evalBlock |

	seen := Set new.
	evalBlock := [ :each | 
	seen add: each first name.
	aBlock
		value: each first;
		value: each last
	].
	(newClasses select: [ :e | aColl anySatisfy: [ :cat | cat, '*' match: e first category ]]) do: evalBlock.
	(changedClasses select: [ :e | aColl anySatisfy: [ :cat | cat, '*' match: e first category ]]) do: evalBlock.
	self environment
		classesInPackages: aColl do: [ :each | 
			each isObsolete
				ifFalse: [ | class |

					class := each instanceSide.
					( ( seen includes: class name ) or: [ self hasRemoved: ( self classNameFor: class ) ] )
						ifFalse: [ ( class := self classFor: each )
								ifNotNil: [ seen add: class name.
									aBlock
										value: class;
										value: class classSide
									]
							]
					]
			]! !

!RBNamespace methodsFor: 'accessing' stamp: ''!
allReferencesToClass: aRBClass do: aBlock 
	self allClassesDo: 
			[:each |
			(each whichSelectorsReferToClass: aRBClass) 
				do: [:sel | aBlock value: (each methodFor: sel)].
			(each classSide whichSelectorsReferToClass: aRBClass) 
				do: [:sel | aBlock value: (each classSide methodFor: sel)]]! !

!RBNamespace methodsFor: 'private' stamp: ''!
unmarkAsRemoved: newClassName
	removedClasses
		remove: newClassName ifAbsent: [  ];
		remove: newClassName , ' class' ifAbsent: [  ]! !

!RBNamespace methodsFor: 'private' stamp: ''!
privateReferencesTo: aSelector in: classes
	| methods |
	methods := OrderedCollection new.
	classes do: [ :class |
		(class whichSelectorsReferToSymbol: aSelector)
			do: [ :selector |
				methods add: (class methodFor: selector) ] ].
	^ methods! !

!RBNamespace class methodsFor: 'instance creation' stamp: ''!
onEnvironment: aBrowserEnvironment 
	^self basicNew
		environment: aBrowserEnvironment;
		initialize;
		yourself! !

!RBNamespaceTest methodsFor: 'class tests' stamp: ''!
testAllClassesDo
	| model classes |
	classes := 0.
	model := modelFactory rbNamespace new.
	model allClassesDo: 
			[:each | 
			each name = #Object ifTrue: [each allSubclasses].
			classes := classes + 1].
	RBBrowserEnvironment new classesDo: [:each | classes := classes - 1].
	self assert: classes equals: 0! !

!RBNamespaceTest methodsFor: 'class tests' stamp: ''!
testReparentSuperclassChange
	| st superclass subclasses |
	st := modelFactory 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 equals: superclass]! !

!RBNamespaceTest methodsFor: 'class tests' stamp: ''!
testCommentChange
	| st cl |
	st := modelFactory rbNamespace new.
	cl := st classNamed: self class name.
	self assert: cl comment isString.
	cl comment: 'a comment'.
	self assert: cl comment equals: 'a comment'.
	self assert: st changes changes size equals: 1.
	self assert: st changes changes first comment equals: 'a comment'.
	cl comment: nil.
	self assert: cl comment isNil.
	self assert: st changes changes size equals: 2.
	self assert: st changes changes last comment isNil! !

!RBNamespaceTest methodsFor: 'class tests' stamp: ''!
testDefineClassAfterDeletedChange
	| st |
	st := modelFactory rbNamespace new.
	st removeClassNamed: self class name.
	self deny: (st includesClassNamed: self class name).
	st defineClass: self class oldDefinition.
	self assert: (st includesClassNamed: self class name).
	self assert: (st classNamed: self class name) notNil! !

!RBNamespaceTest methodsFor: 'class tests' stamp: ''!
testReferencesPrintOnAfterAddition
	| hasFoundObject hasFoundSelf smalltalk |
	hasFoundObject := false.
	hasFoundSelf := false.
	smalltalk := modelFactory 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: ''!
testImplementors
	| st |
	st := modelFactory 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: ''!
testReferencesPrintOn
	| hasFoundObject hasFoundSelf smalltalk |
	hasFoundObject := false.
	hasFoundSelf := false.
	smalltalk := modelFactory 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: ''!
testReferencesPrintOnAfterRemove
	| hasFoundObject hasFoundSelf smalltalk |
	hasFoundObject := false.
	hasFoundSelf := false.
	smalltalk := modelFactory rbNamespace new.
	(smalltalk classNamed: #Object) 
		removeMethod: #printString.
	(smalltalk classNamed: self class name) 
		removeMethod: #testReferencesPrintOnAfterRemove.
	smalltalk allReferencesTo: #printOn: do: [ :each | 
		hasFoundObject := hasFoundObject
			or: [ each selector = #printString 
			and: [ each modelClass = (smalltalk classNamed: #Object) ] ].
		hasFoundSelf := hasFoundSelf
			or: [ each selector = #testReferencesPrintOnAfterRemove 
			and: [ each modelClass = (smalltalk classNamed: self class name) ] ] ].
	self deny: hasFoundObject.
	self deny: hasFoundSelf! !

!RBNamespaceTest methodsFor: 'class tests' stamp: ''!
testRedefineClassChange
	| st |
	st := modelFactory 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: ''!
testModelImplementorsSenders
	| model class modelImps refs found |
	model := modelFactory 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 
				equals: (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: ''!
testDefineClassChange
	| st |
	st := modelFactory rbNamespace new.
	st 
		defineClass: 'RefactoringBrowserTest subclass: #SmalltalkTestXXX
				instanceVariableNames: ''''
				classVariableNames: ''''
				poolDictionaries: ''''
				category: #''Refactory-Testing'''.
	self assert: (st includesClassNamed: #SmalltalkTestXXX).
	self assert: (st classNamed: #SmalltalkTestXXX) notNil! !

!RBNamespaceTest methodsFor: 'class tests' stamp: ''!
testRemoveClassChange
	| st |
	st := modelFactory rbNamespace new.
	st removeClassNamed: self class name.
	self deny: (st includesClassNamed: self class name).
	self assert: (st classNamed: self class name) isNil! !

!RBNamespaceTest methodsFor: 'class tests' stamp: ''!
testRoots
	| model |
	model := modelFactory rbNamespace new.
	self 
		assert: (model rootClasses asSortedCollection: [:a :b | a name < b name]) 
				asArray 
		equals: ((Class rootsOfTheWorld collect: [:each | model classFor: each]) 
							asSortedCollection: [:a :b | a name < b name]) asArray! !

!RBNamespaceTest methodsFor: 'class tests' stamp: ''!
testIncludesClass
	self assert: (modelFactory rbNamespace new includesClassNamed: #Object).
	self deny: (modelFactory rbNamespace new includesClassNamed: #Object1).
	self 
		deny: ((modelFactory rbNamespace 
				onEnvironment: (RBClassEnvironment onEnvironment: RBBrowserEnvironment new
						classes: (Array with: Object))) 
					includesClassNamed: #OrderedCollection)! !

!RBNamespaceTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	modelFactory := RBClassModelFactory new. ! !

!RBNegationCondition commentStamp: ''!
I am a refactoring condition representing a boolean NOT of another condition.

I am created by sending the message #not to another condition.

Checking this conditions holds true, if my condition is false. 
!
!RBNegationCondition methodsFor: 'private' stamp: ''!
errorBlockFor: aBoolean 
	^condition errorBlockFor: aBoolean not! !

!RBNegationCondition methodsFor: 'private' stamp: ''!
errorStringFor: aBoolean 
	^condition errorStringFor: aBoolean not! !

!RBNegationCondition methodsFor: 'checking' stamp: ''!
check
	^condition check not! !

!RBNegationCondition methodsFor: 'initialization' stamp: ''!
condition: aCondition 
	condition := aCondition.
	self errorMacro: condition errorMacro! !

!RBNegationCondition methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream nextPutAll: 'NOT ';
		print: condition! !

!RBNegationCondition class methodsFor: 'instance creation' stamp: ''!
on: aCondition
	^self new condition: aCondition! !

!RBNode commentStamp: ''!
I'm the superclass of the all the nodes for 
	- expressions and methods (subclasses of RBProgramNode) - historically it was the only tree and 
	it was the only part concerned with refactorings (hence the RB suffix for RegactoringBrowser).
	- class definition (just nodes to represent the class creation messages),
	- full program (class definitions or method definitions)

In the future my prefix may change to convey the fact that my hierarchy is much more than supporting compiler and refactorings.

I'm a new player in the field, do not hesitate to improve me.
!
!RBNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	self subclassResponsibility! !

!RBNode class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBNode! !

!RBNotEnvironment commentStamp: ''!
I am the complement of RBEnvironments, a logical NOT. That is: 
entity A is in this environment if it is in NOT in the environment I am constructed from.

Do not construct instances of me directly, use method #not for an existing environment:
env1 not -> a RBNotEnvironment.!
!RBNotEnvironment methodsFor: 'testing' stamp: ''!
includesCategory: aCategory 
	^(self classNamesFor: aCategory) isNotEmpty! !

!RBNotEnvironment methodsFor: 'testing' stamp: ''!
includesSelector: aSelector in: aClass
	^(environment includesSelector: aSelector in: aClass) not! !

!RBNotEnvironment methodsFor: 'description' stamp: ''!
description
	^ '(', environment shortDescription, ') not' ! !

!RBNotEnvironment methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass
	^ (aClass organization protocolOrganizer
		getProtocolNamed: aProtocol
		ifNone: [ ^ false ]) methodSelectors
		anySatisfy: [ :selector | self includesSelector: selector in: aClass ]! !

!RBNotEnvironment methodsFor: 'accessing' stamp: ''!
packages
	^ self rootEnvironment packages 
		select: [ :package | self includesPackage: package ]! !

!RBNotEnvironment methodsFor: 'testing' stamp: ''!
includesPackage: aRPackage 
	^ (environment includesPackage: aRPackage) not! !

!RBNotEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass 
	(environment includesClass: aClass) ifFalse: [^true].
	^false! !

!RBNotEnvironment methodsFor: 'environments' stamp: ''!
not
	^environment! !

!RBNotEnvironment methodsFor: 'testing' stamp: ''!
definesClass: aClass 
	^ (environment definesClass: aClass) not! !

!RBNotEnvironment methodsFor: 'printing' stamp: ''!
storeOn: aStream
	environment storeOn: aStream.
	aStream nextPutAll: ' not'! !

!RBNumberLiteralToken commentStamp: ''!
I am a number literal token. 
Special handling is needed for converting a negative literal token if it is part of a binary message send. In an expression like
a - 1
the scanner produces the tokens 'a' and '-1'. This will be converted to the token
'a', the binary selector token '-' and the number literal token '1'.!
!RBNumberLiteralToken methodsFor: 'testing' stamp: ''!
isNumberLiteralToken
	^true.! !

!RBNumberLiteralToken methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPutAll: source! !

!RBOrEnvironment commentStamp: ''!
I am the combination of two RBEnvironments, a logical OR. That is: 
entity A is in this environment if it is in at least ONE environment I am constructed from.

Do not construct instances of me directly, use method #| for two existing environments:
env1 | env2 -> a RBOrEnvironment.!
!RBOrEnvironment methodsFor: 'testing' stamp: ''!
includesCategory: aCategory 
	^ (environment includesCategory: aCategory)
		or: [ self orEnvironment includesCategory: aCategory ]! !

!RBOrEnvironment methodsFor: 'testing' stamp: ''!
includesSelector: aSelector in: aClass
	^ (environment includesSelector: aSelector in: aClass)
		or: [ self orEnvironment includesSelector: aSelector in: aClass ]! !

!RBOrEnvironment methodsFor: 'accessing' stamp: ''!
operator
	^ ' | '! !

!RBOrEnvironment methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass
	^ (environment includesProtocol: aProtocol in: aClass)
		or: [ self orEnvironment includesProtocol: aProtocol in: aClass ]! !

!RBOrEnvironment methodsFor: 'accessing' stamp: ''!
orEnvironment
	^ otherEnvironment! !

!RBOrEnvironment methodsFor: 'accessing' stamp: ''!
orEnvironment: aBrowserEnvironment
	 otherEnvironment := aBrowserEnvironment! !

!RBOrEnvironment methodsFor: 'accessing' stamp: ''!
classesDo: aBlock
	| enumerated |
	enumerated := IdentitySet new.
	environment classesDo: [ :each | 
		aBlock value: each.
		enumerated add: each].
	self orEnvironment classesDo: [ :each | 
		(enumerated includes: each) 
			ifFalse: [ aBlock value: each ] ]! !

!RBOrEnvironment methodsFor: 'accessing' stamp: ''!
packages
	^ environment packages | self orEnvironment packages! !

!RBOrEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass
	(environment includesClass: aClass) ifTrue: [ ^ true ].
	(self orEnvironment includesClass: aClass) ifTrue: [ ^ true ].
	(environment selectorsForClass: aClass) ifNotEmpty: [ ^ true ].
	(self orEnvironment selectorsForClass: aClass) ifNotEmpty: [ ^ true ].
	^ false! !

!RBOrEnvironment methodsFor: 'accessing' stamp: ''!
selectionIntervalFor: aString
	^ (environment selectionIntervalFor: aString)
		ifNil: [ self orEnvironment selectionIntervalFor: aString ]! !

!RBOrEnvironment methodsFor: 'accessing' stamp: ''!
selectorsForClass: aClass do: aBlock
	| enumerated |
	enumerated := IdentitySet new.
	environment
		selectorsForClass: aClass
		do: [ :each | 
			enumerated add: each.
			aBlock value: each ].
	self orEnvironment
		selectorsForClass: aClass
		do: [:each | 
			(enumerated includes: each) 
				ifFalse: [ aBlock value: each ] ]! !

!RBOrEnvironment methodsFor: 'testing' stamp: ''!
definesClass: aClass
	^ (environment definesClass: aClass) or: [ 
		self orEnvironment definesClass: aClass ]! !

!RBOrEnvironment methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	environment storeOn: aStream.
	aStream nextPutAll: self operator.
	self orEnvironment storeOn: aStream.
	aStream nextPut: $)! !

!RBOrEnvironment class methodsFor: 'instance creation' stamp: ''!
onEnvironment: anEnvironment or: anotherEnvironment
	^ (self onEnvironment: anEnvironment)
		orEnvironment: anotherEnvironment;
		yourself! !

!RBPackage commentStamp: ''!
I represent a package for the refactoring framework.
!
!RBPackage methodsFor: 'accessing' stamp: ''!
realPackage

	^ realPackage! !

!RBPackage methodsFor: 'accessing' stamp: ''!
realPackage: anObject

	realPackage := anObject! !

!RBPackage methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!RBPackage methodsFor: 'accessing' stamp: ''!
name: anObject

	name := anObject! !

!RBPackage methodsFor: 'accessing' stamp: ''!
model: anObject

	model := anObject! !

!RBPackage methodsFor: 'accessing' stamp: ''!
realPackageFor: aSymbol 
	self realPackage: ( self model environment packageAt: aSymbol ifAbsent: [nil] )! !

!RBPackage methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!RBPackage class methodsFor: 'instance creation' stamp: ''!
named: aSymbol 
	^(self new)
		name: aSymbol;
		yourself! !

!RBPackage class methodsFor: 'instance creation' stamp: ''!
existingNamed: aSymbol model: aRBNamespace 
	^ (self named: aSymbol)
		model: aRBNamespace;
		realPackageFor: aSymbol;
		yourself! !

!RBPackage class methodsFor: 'instance creation' stamp: ''!
existingNamed: aSymbol 
	^(self named: aSymbol)
		realPackageFor: aSymbol;
		yourself! !

!RBPackageEnvironment commentStamp: ''!
I am a RBBrowserEnvironment on a set of packages or package names.
I containt all entities are defined in this packages.
(classes and class that have extensions from this packages)

Example:
(RBBrowserEnvironment new) forPackageNames:{ 'Morphic-Base'}.!
!RBPackageEnvironment methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	packages := Set new! !

!RBPackageEnvironment methodsFor: 'visiting' stamp: ''!
acceptVisitor: aEnvVisitor
	^ aEnvVisitor visitPackageEnv: self! !

!RBPackageEnvironment methodsFor: 'accessing' stamp: ''!
basisObjects
	^ self packages! !

!RBPackageEnvironment methodsFor: 'adding' stamp: ''!
addPackage: aSymbol
	packages add: aSymbol! !

!RBPackageEnvironment methodsFor: 'testing' stamp: ''!
includesCategory: aCategory
	^ (super includesCategory: aCategory) and: [ 
		self packages anySatisfy: [ :package | 
			package includesSystemCategory: aCategory ] ]! !

!RBPackageEnvironment methodsFor: 'testing' stamp: ''!
includesSelector: aSelector in: aClass
	^ (environment includesSelector: aSelector in: aClass) 
		and: [ self packages anySatisfy: [ :package | 
				package includesSelector: aSelector ofClass: aClass ] ]! !

!RBPackageEnvironment methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	packages := packages copy! !

!RBPackageEnvironment methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass
	^ (environment includesProtocol: aProtocol in: aClass) and: [ self packages anySatisfy: [ :package | package includesMethodCategory: aProtocol ofClass: aClass ] ]! !

!RBPackageEnvironment methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: 'Pck: '.
	packages do: [ :pkg | aStream nextPutAll: pkg packageName, ', ']! !

!RBPackageEnvironment methodsFor: 'accessing' stamp: ''!
packages
	^ packages! !

!RBPackageEnvironment methodsFor: 'accessing' stamp: ''!
classesDo: aBlock
	| enumerated enumerator |
	enumerated := IdentitySet new.
	enumerator := [ :each |
		(enumerated includes: each) ifFalse: [
			(environment includesClass: each)
				ifTrue: [ aBlock value: each ].
			(environment includesClass: each classSide)
				ifTrue: [ aBlock value: each classSide].
			enumerated add: each ] ].
	packages do: [ :package |
		package classes do: enumerator.
		package extendedClasses do: enumerator ]! !

!RBPackageEnvironment methodsFor: 'accessing' stamp: ''!
classesAndSelectorsDo: aBlock
	packages do: [ :package |
		package methods do: [ :method |
			(environment includesSelector: method selector in: method methodClass)
				ifTrue: [ aBlock value: method methodClass value: method selector ] ] ]! !

!RBPackageEnvironment methodsFor: 'accessing' stamp: ''!
packageNames
	^ packages collect: [ :each | each packageName ]! !

!RBPackageEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass
	^ (super includesClass: aClass) and: [ 
		self packages anySatisfy: [ :package | 
			(package includesClass: aClass) or: [ 
			(package extensionCategoriesForClass: aClass) notEmpty ]]]! !

!RBPackageEnvironment methodsFor: 'printing' stamp: ''!
printBasisObject: aClass on: aStream

	^ aStream nextPutAll: aClass name! !

!RBPackageEnvironment methodsFor: 'removing' stamp: ''!
removePackage: aSymbol
	packages remove: aSymbol ifAbsent: []! !

!RBPackageEnvironment methodsFor: 'accessing' stamp: ''!
asSelectorEnvironment
	| result |
	result := RBSelectorEnvironment onEnvironment: environment.
	self classesAndSelectorsDo: [ :class :selector | result addClass: class selector: selector ].
	^ result! !

!RBPackageEnvironment methodsFor: 'testing' stamp: ''!
definesClass: aClass
	^ (super definesClass: aClass) and: [ self packages anySatisfy: [ :package | package includesClass: aClass ] ]! !

!RBPackageEnvironment methodsFor: '*Manifest-Core' stamp: ''!
smallLintCritics
	^ self packages! !

!RBPackageEnvironment methodsFor: 'printing' stamp: ''!
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: 'initialization' stamp: ''!
packages: aCollection
	packages addAll: aCollection! !

!RBPackageEnvironment class methodsFor: 'instance creation' stamp: ''!
packageName: aName
	^ self packageNames: { aName }! !

!RBPackageEnvironment class methodsFor: 'instance creation' stamp: ''!
onEnvironment: anEnvironment packages: aCollection
	^ (self onEnvironment: anEnvironment)
		packages: aCollection;
		yourself! !

!RBPackageEnvironment class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'Packages'! !

!RBPackageEnvironment class methodsFor: 'instance creation' stamp: ''!
packageNames: aCollection
	^ self 
		onEnvironment: self default
		packageNames: aCollection! !

!RBPackageEnvironment class methodsFor: 'instance creation' stamp: ''!
package: aPackage
	^ self packages: { aPackage }! !

!RBPackageEnvironment class methodsFor: 'instance creation' stamp: ''!
onEnvironment: anEnvironment packageNames: aCollection
	^ self 
		onEnvironment: anEnvironment
		packages: (aCollection collect: [ :each | 
			RPackageOrganizer default packageNamed: each ])! !

!RBPackageEnvironment class methodsFor: 'instance creation' stamp: ''!
packages: aCollection
	^ self 
		onEnvironment: self default
		packages: aCollection! !

!RBPackageRefactoring commentStamp: ''!
I am an abstract base class for package refactorings.

All that I provide is the package name, my subclass refactorings are operating on, and a instance creation method for setting the package name and an initial namespace model.!
!RBPackageRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions 
	^ (RBCondition withBlock: [ [ RPackage organizer includesPackageNamed: packageName ]
			on: Error 
			do: [ :e | self refactoringError: e messageText ]
		])! !

!RBPackageRefactoring methodsFor: 'accessing' stamp: ''!
packageName: anObject

	packageName := anObject! !

!RBPackageRefactoring methodsFor: 'accessing' stamp: ''!
packageName

	^ packageName! !

!RBPackageRefactoring class methodsFor: 'instance creation' stamp: ''!
packageName: aName
	^ self new
		packageName: aName! !

!RBPackageRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBModel packageName: aName 
	^ self new
		model: aRBModel;
		packageName: aName;
		yourself! !

!RBPackageRefactoring class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBPackageRefactoring! !

!RBPackageTransformation commentStamp: ''!
I am an abstract base class for package transformations.

All that I provide is the package name, my subclass transformations are operating on, and a instance creation method for setting the package name and an initial namespace model.!
!RBPackageTransformation methodsFor: 'preconditions' stamp: ''!
preconditions 
	^ (RBCondition withBlock: [ [ RPackage organizer includesPackageNamed: packageName ]
			on: Error 
			do: [ :e | self refactoringError: e messageText ]
		])! !

!RBPackageTransformation methodsFor: 'executing' stamp: ''!
packageName: anObject

	packageName := anObject! !

!RBPackageTransformation methodsFor: 'executing' stamp: ''!
packageName

	^ packageName! !

!RBPackageTransformation class methodsFor: 'accessing' stamp: ''!
packageName: aName
	^ self new
		packageName: aName! !

!RBPackageTransformation class methodsFor: 'accessing' stamp: ''!
model: aRBModel packageName: aName 
	^ self new
		model: aRBModel;
		packageName: aName;
		yourself! !

!RBParenthesesErrorNode commentStamp: ''!
This is a particular englobing node that is a parentheses.
Exemple : ( parentheses node )
Can be created by forgetting 
either the opening : parentheses node )
or the closure : ( parentheses node .
!
!RBParenthesesErrorNode methodsFor: 'testing' stamp: ''!
isParenthesesError
	^true! !

!RBParenthesesErrorNode class methodsFor: 'construction' stamp: ''!
error: aToken withNodes: aCollection
	"Analyses the token to identify if it's an opening or a closure."
	| message |
	message := ('(' = aToken value asString) ifTrue: [ ''')'' expected' ] 
										  				 ifFalse: [ '''('' expected' ].
	"If the collection is empty, there is only the token in the error."
	aCollection isEmpty
		ifTrue: [ ^self new content: aCollection; start: aToken start; stop: aToken stop; errorMessage: message ].
	"If the collection is not empty, we have to sort where the node begins and where it ends."
	^message = ''')'' expected'
		ifTrue: [ self new content: aCollection; start: aToken start; stop: aCollection last stop; errorMessage: message ]
		ifFalse: [ self new content: aCollection; start: aCollection first start; stop: aToken stop; errorMessage: message ]! !

!RBParseErrorNode commentStamp: ''!
I am a node representing a source code segment that could not be parsed. I am mainly used for source-code coloring where we should parse as far as possible and mark the rest as a failure.

Parsing faulty code without raising a syntax error is done by 
RBParser parseFaultyExpression:
or
RBParser parseFaultyMethod: 

The return value is either valid nodes representing the AST, or nodes representing the valid portion and an RBParseErrorNode for the remaining invalid code.

!
!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
value: aString
	value := aString.! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
stop
	^ stop 
		ifNil: [start + value size - 1]
		ifNotNil: [ stop ]! !

!RBParseErrorNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [^true].
	self class = anObject class ifFalse: [^false].
	^anObject value = value and: [ anObject errorMessage = errorMessage ]! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
stopWithoutParentheses
	^ self stop! !

!RBParseErrorNode methodsFor: 'comparing' stamp: ''!
hash
	^ (self value hash bitXor: self errorMessage hash)! !

!RBParseErrorNode methodsFor: 'testing' stamp: ''!
isFaulty
	^true! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
selectorParts
	
	^ #()! !

!RBParseErrorNode methodsFor: 'testing' stamp: ''!
isUnary
	
	^ false! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
binding: anOCTempVariable 
	"only for compatibility"! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
source: aString
	"I am not a valid MethodNode, but go one with parsing"! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
body: aSequenceNode
	"I am not a valid MethodNode, but go one with parsing"! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
errorMessage
	^ errorMessage! !

!RBParseErrorNode methodsFor: 'testing' stamp: ''!
needsParenthesis
	^ false! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
startWithoutParentheses
	^ start! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
selector
	"A parse error node has an empty selector"
	^ #''! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
arguments
	
	"A parse error node has no arguments"
	^ #()! !

!RBParseErrorNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitParseErrorNode: self! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
errorMessage: anObject
	errorMessage := anObject! !

!RBParseErrorNode methodsFor: 'converting' stamp: ''!
asSyntaxErrorNotification
	^SyntaxErrorNotification new
		setClass: self methodNode methodClass
		code: self methodNode source
		doitFlag: false
		errorMessage: errorMessage
		location: self start! !

!RBParseErrorNode methodsFor: 'testing' stamp: ''!
isParseError
	^true! !

!RBParseErrorNode methodsFor: 'evaluating' stamp: ''!
value
	^value.! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
name
	"be polymorphic with variable nodes"

	^ ''! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
stop: aStopPosition
	stop := aStopPosition! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
start
	^ start! !

!RBParseErrorNode methodsFor: 'accessing' stamp: ''!
start: aPosition
	start := aPosition! !

!RBParseErrorNode class methodsFor: 'instance creation' stamp: ''!
errorMessage: aString value: aValue at: aPosition

	^ self new
		errorMessage: aString;
		value: aValue;
		start: aPosition;
		yourself! !

!RBParseErrorNodeTest methodsFor: 'tests' stamp: ''!
testErrorNodeStart
	"check that the start of the error node is correct"

	| ast |
	ast := self parserClass parseFaultyMethod: 'method ( 1 + 3'.
	"the start should be much earlier then the end of the method"
	self assert: ast body statements first start < 14! !

!RBParseErrorNodeVisitor commentStamp: ''!
Visit any RBParseErrorNode in the syntax tree and evaluate a generic block!
!RBParseErrorNodeVisitor methodsFor: 'visiting' stamp: ''!
visitEnglobingErrorNode: aNode
	self visitParseErrorNode: aNode! !

!RBParseErrorNodeVisitor methodsFor: 'visiting' stamp: ''!
visitParseErrorNode: aNode
	self visitBlock value: aNode! !

!RBParseTreeEnvironment methodsFor: 'accessing' stamp: ''!
selectionIntervalFor: aString

	| parseTree node |

	matcher ifNil: [ ^ 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: 'initialization' stamp: ''!
matcher: aParseTreeSearcher
	matcher := aParseTreeSearcher! !

!RBParseTreeLintRule commentStamp: ''!
A RBParseTreeLintRule is a rule that is expressed using a parse tree matcher on a method AST.!
!RBParseTreeLintRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	matcher := RBParseTreeSearcher new! !

!RBParseTreeLintRule methodsFor: 'running' stamp: ''!
checkMethod: aMethod 
	(self basicCheck: aMethod) ifTrue: [ result addMethod: aMethod ]! !

!RBParseTreeLintRule methodsFor: 'accessing' stamp: ''!
resultClass
	^ RBParseTreeEnvironment! !

!RBParseTreeLintRule methodsFor: 'running' stamp: ''!
resetResult
	super resetResult.
	self result matcher: self matcher! !

!RBParseTreeLintRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod 
	(self matcher canMatchMethod: aMethod) 
		ifFalse: [ ^ false ].
	^ (self matcher executeTree: aMethod ast initialAnswer: nil) isNotNil! !

!RBParseTreeLintRule methodsFor: '*Renraku' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock

	(self matcher canMatchMethod: aMethod) ifTrue: [
		| node |
		node := self matcher
			executeTree: aMethod ast
			initialAnswer: nil.
		node ifNotNil: [ 
			^ aCriticBlock cull: ( 
				self critiqueFor: node about: aMethod) ] ].! !

!RBParseTreeLintRule methodsFor: '*Renraku' stamp: ''!
critiqueFor: aNode about: aMethod
	| anchor | 

	anchor := (aNode isKindOf: RBProgramNode)
		ifFalse: [ ReSourceAnchor entity: aMethod ]
		ifTrue: [
			ReIntervalSourceAnchor
				entity: aMethod
				interval: aNode sourceInterval ].
			
	^ ReTrivialCritique
		withAnchor: anchor 
		by: self! !

!RBParseTreeLintRule methodsFor: 'accessing' stamp: ''!
matcher
	^ matcher! !

!RBParseTreeLintRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!RBParseTreeLintRule class methodsFor: 'testing' stamp: ''!
isVisible
	^ self name ~= #RBParseTreeLintRule! !

!RBParseTreeLintRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ParseTreeLintRule'! !

!RBParseTreeRewriter commentStamp: ''!
ParseTreeRewriter walks over and transforms its RBProgramNode (tree). If the tree is modified, then the answer is set to true, and the modified tree can be retrieved by the #tree method.


Here is a little script to rewrite a self halt into self dormantHalt. 

	| rewriter node |
	rewriter := RBParseTreeRewriter new.
	rewriter replace: 'self halt' with: 'self dormatHalt'.
	node := (ProtoObjectTest>>#testIfNil) parseTree.
	rewriter executeTree: node.
	^ node formattedCode

Note how do we get the transformed code. You can access the rewritten tree as follows:
rewriter tree.

Now here is a full script showing how to compile the method back. 

   | rewriter ok method |
	rewriter := RBParseTreeRewriter new.
	rewriter replaceMethod: self searchPattern with: self targetPattern.
	method := (BIArrayExpressionTest>>#testNoExtraSpaceAroundPeriod).
	ok := rewriter executeTree: method parseTree.
	ok ifFalse: [ ^ 'did not work' ].
	Author 
		useAuthor: 'Refactoring'
		during: [  
			method origin 
				compile: rewriter tree formattedCode 
				classified: method protocol ]


Have a look at the users of deprecated:

		deprecated: 'Please use #isPinnedInMemory instead'
		transformWith: '`@receiver isPinned' -> '`@receiver isPinnedInMemory'.

You can also have a look at the ParseTreeRewriterTest class.


Instance Variables:
	tree	<RBProgramNode>	the parse tree we're transforming
			
	!
!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replaceMethod: searchString withValueFrom: replaceBlock when: conditionBlock 
	self addRule: (RBBlockReplaceRule 
				searchForMethod: searchString
				replaceWith: replaceBlock
				when: conditionBlock)! !

!RBParseTreeRewriter methodsFor: 'visiting' stamp: ''!
visitArgumentNodes: aNodeCollection 
	^aNodeCollection collect: [:each | self visitArgumentNode: each]! !

!RBParseTreeRewriter methodsFor: 'visiting' stamp: ''!
visitTemporaryNodes: aNodeCollection 
	^aNodeCollection collect: [:each | self visitTemporaryDeclarationNode: each]! !

!RBParseTreeRewriter methodsFor: 'visitor - double dispatching' stamp: ''!
visitBlockNode: aBlockNode 
	aBlockNode arguments: (self visitArgumentNodes: aBlockNode arguments).
	aBlockNode body: (self visitNode: aBlockNode body)! !

!RBParseTreeRewriter methodsFor: 'visitor - double dispatching' stamp: ''!
visitSequenceNode: aSequenceNode
	aSequenceNode temporaries: (self visitTemporaryNodes: aSequenceNode temporaries).
	aSequenceNode statements: (aSequenceNode statements collect: [ :each | self visitNode: each ])! !

!RBParseTreeRewriter methodsFor: 'visitor - double dispatching' stamp: ''!
visitReturnNode: aReturnNode 
	aReturnNode value: (self visitNode: aReturnNode value)! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replaceArgument: searchString withValueFrom: replaceBlock 
	self addArgumentRule: (RBBlockReplaceRule searchFor: searchString
				replaceWith: replaceBlock)! !

!RBParseTreeRewriter methodsFor: 'visitor - double dispatching' stamp: ''!
visitAssignmentNode: anAssignmentNode 
	anAssignmentNode variable: (self visitNode: anAssignmentNode variable).
	anAssignmentNode value: (self visitNode: anAssignmentNode value)! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replace: searchString with: replaceString 
   "Add a new replace pattern. To get the replacement executed invoke executeTree: method."

	self addRule: (RBStringReplaceRule searchFor: searchString
				replaceWith: replaceString)! !

!RBParseTreeRewriter methodsFor: 'visitor - double dispatching' stamp: ''!
visitCascadeNode: aCascadeNode

	| newMessages notFound |

	newMessages := OrderedCollection new: aCascadeNode messages size.
	notFound := OrderedCollection new: aCascadeNode messages size.
	aCascadeNode messages
		do: [ :each | 
			| newNode |

			newNode := self performSearches: searches on: each.
			newNode
				ifNil: [ newNode := each.
					notFound add: newNode
					].
			newNode isMessage
				ifTrue: [ newMessages add: newNode ]
				ifFalse: [ newNode isCascade
						ifTrue: [ newMessages addAll: newNode messages ]
						ifFalse: [ "Cannot replace message node inside of cascaded node with non-message node."
							self flag: #pharoFixMe.	"Maybe we should raise a warning here and catch it in the UI layer."
							newMessages add: each
							]
					]
			].
	notFound size = aCascadeNode messages size
		ifTrue: [ | receiver |

			receiver := self visitNode: aCascadeNode messages first receiver.
			newMessages do: [ :each | each receiver: receiver ]
			].
	notFound do: [ :each | each arguments: ( each arguments collect: [ :arg | self visitNode: arg ] ) ].
	aCascadeNode messages: newMessages! !

!RBParseTreeRewriter methodsFor: 'visitor - double dispatching' stamp: ''!
visitMethodNode: aMethodNode
	aMethodNode arguments: (self visitArgumentNodes: aMethodNode arguments).
	aMethodNode pragmas: (aMethodNode pragmas collect: [ :each | self visitNode: each ]).
	aMethodNode body: (self visitNode: aMethodNode body)! !

!RBParseTreeRewriter methodsFor: 'accessing' stamp: ''!
executeTree: aParseTree 
	"Replace the argument node based on the replace rules. Return false when no transformation has been applied, and true when a transformation occured.
	
	Pay attention the method is not recompiled. Just the tree is modified. Look at class comment to see how the method can be compiled"
	
	"here is a little script showing a possible way to use executeTree: 
	| rewriter node |
	rewriter := RBParseTreeRewriter new.
	rewriter replace: 'self halt' with: 'self dormatHalt'.
	node := (ProtoObjectTest>>#testIfNil) parseTree.
	rewriter executeTree: node.
	^ node formattedCode
"


	| oldContext |
	oldContext := context.
	context := SmallDictionary new.
	answer := false.
	tree := self visitNode: aParseTree.
	context := oldContext.
	^answer! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replaceTree: searchTree withTree: replaceTree when: aBlock 
	"Add a replacement between a given tree and a replacement tree when a condition. To get the replacement executed invoke executeTree: method."
	
	self addRule: (RBStringReplaceRule 
				searchForTree: searchTree
				replaceWith: replaceTree
				when: aBlock)! !

!RBParseTreeRewriter methodsFor: 'visitor - double dispatching' stamp: ''!
visitPragmaNode: aPragmaNode
	aPragmaNode arguments: (aPragmaNode arguments collect: [ :each | self visitNode: each ])! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replace: searchString withValueFrom: replaceBlock when: conditionBlock 
	self addRule: (RBBlockReplaceRule 
				searchFor: searchString
				replaceWith: replaceBlock
				when: conditionBlock)! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replace: searchString withValueFrom: replaceBlock 
	self addRule: (RBBlockReplaceRule searchFor: searchString
				replaceWith: replaceBlock)! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replaceArgument: searchString with: replaceString when: aBlock 
	self addArgumentRule: (RBStringReplaceRule 
				searchFor: searchString
				replaceWith: replaceString
				when: aBlock)! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replaceArgument: searchString withValueFrom: replaceBlock when: conditionBlock 
	self addArgumentRule: (RBBlockReplaceRule 
				searchFor: searchString
				replaceWith: replaceBlock
				when: conditionBlock)! !

!RBParseTreeRewriter methodsFor: 'visitor - double dispatching' stamp: ''!
visitLiteralArrayNode: aRBArrayLiteralNode
	aRBArrayLiteralNode contents: (aRBArrayLiteralNode contents collect: [ :each | self visitNode: each ])! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replaceMethod: searchString with: replaceString when: aBlock 
	self addRule: (RBStringReplaceRule 
				searchForMethod: searchString
				replaceWith: replaceString
				when: aBlock)! !

!RBParseTreeRewriter methodsFor: 'accessing' stamp: ''!
tree
	"Return the rewritten tree"
	
	^tree! !

!RBParseTreeRewriter methodsFor: 'private' stamp: ''!
lookForMoreMatchesInContext: oldContext 
	oldContext keysAndValuesDo: [:key :value | 
		(key isString not and: [key recurseInto]) 
			ifTrue: 
				[oldContext at: key put: (value collect: [:each | self visitNode: each])]]! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replaceTree: searchTree withTree: replaceTree 
	"Add a replacement between a given tree and a replacement tree. To get the replacement executed invoke executeTree: method."
	
	self addRule: (RBStringReplaceRule searchForTree: searchTree
				replaceWith: replaceTree)! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replaceMethod: searchString withValueFrom: replaceBlock 
	self addRule: (RBBlockReplaceRule searchForMethod: searchString
				replaceWith: replaceBlock)! !

!RBParseTreeRewriter methodsFor: 'visitor - double dispatching' stamp: ''!
visitArrayNode: anArrayNode
	anArrayNode statements: (anArrayNode statements collect: [:each | self visitNode: each])! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replaceMethod: searchString with: replaceString 
	self addRule: (RBStringReplaceRule searchForMethod: searchString
				replaceWith: replaceString)! !

!RBParseTreeRewriter methodsFor: 'private' stamp: ''!
foundMatch
	"Set that the pattern matched is a successful"
	
	answer := true! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replace: searchString with: replaceString when: aBlock 
	"Add a new replace pattern when condition is true. To get the replacement executed invoke executeTree: method."
	
	self addRule: (RBStringReplaceRule 
				searchFor: searchString
				replaceWith: replaceString
				when: aBlock)! !

!RBParseTreeRewriter methodsFor: 'replacing' stamp: ''!
replaceArgument: searchString with: replaceString 
	self addArgumentRule: (RBStringReplaceRule searchFor: searchString
				replaceWith: replaceString)! !

!RBParseTreeRewriter methodsFor: 'visitor - double dispatching' stamp: ''!
visitMessageNode: aMessageNode
	aMessageNode receiver: (self visitNode: aMessageNode receiver).
	aMessageNode arguments: (aMessageNode arguments collect: [ :each | self visitNode: each ])! !

!RBParseTreeRewriter class methodsFor: 'accessing' stamp: ''!
replaceStatements: code with: newCode in: aParseTree onInterval: anInterval
	| tree replaceStmt |
	tree := self buildTree: code method: false.
	tree isSequence ifFalse: [ tree := RBSequenceNode statements: (Array with: tree) ].
	tree temporaries: (Array with: (RBPatternVariableNode named: '`@temps')).
	tree addNodeFirst: (RBPatternVariableNode named: '`@.S1').
	replaceStmt := tree lastIsReturn
		ifTrue: [ '| `@temps | `@.S1. ^' , newCode ]
		ifFalse: [ tree addNode: (RBPatternVariableNode named: '`@.S2').
			'| `@temps | `@.S1. ' , newCode , '. `@.S2' ].
	^ self
		replace: tree formattedCode
		with: replaceStmt
		in: aParseTree
		onInterval: anInterval! !

!RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''!
replaceLiteral: literal with: newLiteral 
	| rewriteRule |
	rewriteRule := self new.
	rewriteRule replaceTree: (RBLiteralNode value: literal)
		withTree: (RBLiteralNode value: newLiteral).
	^rewriteRule! !

!RBParseTreeRewriter class methodsFor: '*Refactoring2-Transformations' stamp: ''!
replaceCode: subtree byMessageSendTo: aMethod in: aCompiledMethod

	| argsAndValues newSourceCode |
	argsAndValues := self mapArguments: aMethod ast arguments
								toValues: (subtree allChildren select: #isLiteralNode)
								in: subtree.
	newSourceCode := self buildMessageSendWith: aMethod selector 
			and: argsAndValues asDictionary
			needsReturn: subtree isReturn.
		
	^ RBReplaceSubtreeTransformation
		replace: subtree sourceCode
		to: newSourceCode
		inMethod: aCompiledMethod selector
		inClass: aCompiledMethod methodClass! !

!RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''!
variable: aVarName getter: getMethod setter: setMethod 
	^self 
		variable: aVarName
		getter: getMethod
		setter: setMethod
		receiver: 'self'! !

!RBParseTreeRewriter class methodsFor: '*Refactoring2-Transformations' stamp: ''!
mapArguments: arguments toValues: values in: aTree

	^ (arguments size = values size)
		"map directly"
		ifTrue: [
			| argsAndValues |
			argsAndValues := OrderedCollection new.
			arguments with: values do: [ :arg :val | 
				argsAndValues add: (arg name asString -> val value storeString) ].
			argsAndValues ]
		"open browser"
		ifFalse: [
			(RBMethodArgumentsSelector
				openOn: (arguments collect: [:e | e name asString])
				and: (values collect: [ :e | e value storeString ])
				in: aTree)
				argumentsAndValues ]! !

!RBParseTreeRewriter class methodsFor: 'accessing' stamp: ''!
replace: code with: newCode in: aParseTree onInterval: anInterval 
	| rewriteRule |
	rewriteRule := self new.
	^rewriteRule
		replace: code
			with: newCode
			when: [:aNode | aNode intersectsInterval: anInterval];
		executeTree: aParseTree;
		tree! !

!RBParseTreeRewriter class methodsFor: '*Refactoring2-Transformations' stamp: ''!
replaceStatements: code with: newCode in: aParseTree

	| 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].
		
	replaceStmt := '| `@temps | `@.S1. ' , newCode.
	(tree statements last = aParseTree body statements last)
		ifFalse: 
			[tree addNode: (RBPatternVariableNode named: '`@.S2').
			replaceStmt := replaceStmt, '. `@.S2'].
	
	^self 
		replace: tree formattedCode
		with: replaceStmt
		in: aParseTree
		onInterval: aParseTree sourceInterval! !

!RBParseTreeRewriter class methodsFor: 'accessing' stamp: ''!
replace: code with: newCode in: aParseTree 
	^(self 
		replace: code
		with: newCode
		method: false)
		executeTree: aParseTree;
		tree! !

!RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''!
rename: varName to: newVarName 
	| rewriteRule |
	rewriteRule := self new.
	rewriteRule
		replace: varName with: newVarName;
		replaceArgument: varName with: newVarName.
	^rewriteRule! !

!RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''!
replace: code with: newCode method: aBoolean 
	| rewriteRule |
	rewriteRule := self new.
	aBoolean 
		ifTrue: [rewriteRule replaceMethod: code with: newCode]
		ifFalse: [rewriteRule replace: code with: newCode].
	^rewriteRule! !

!RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''!
variable: aVarName getter: getMethod setter: setMethod receiver: aString 
	| rewriteRule |
	rewriteRule := self new.
	rewriteRule
		replace: aVarName , ' := ``@object'
			with: aString , ' ' , setMethod , ' ``@object';
		replace: aVarName with: aString , ' ' , getMethod.
	^rewriteRule! !

!RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''!
removeTemporaryNamed: aName 
	| rewriteRule |
	rewriteRule := self new.
	rewriteRule replace: '| `@temps1 ' , aName , ' `@temps2 | ``@.Statements'
		with: '| `@temps1  `@temps2 | ``@.Statements'.
	^rewriteRule! !

!RBParseTreeRewriter class methodsFor: '*Refactoring2-Transformations' stamp: ''!
buildMessageSendWith: aSelector and: argsAndValues needsReturn: aBoolean

	^ String streamContents: [ :string |
		aBoolean ifTrue: [ string nextPutAll: '^ ' ].
		
		string nextPutAll: 'self '.
		argsAndValues
			ifEmpty: [ string nextPutAll: aSelector asString ] 
			ifNotEmpty: [ 
				aSelector keywords with: argsAndValues associations
					do: [ :key :arg | 
						string nextPutAll: key asString; nextPut: $ .
						string nextPutAll: (argsAndValues at: arg key).
						string nextPut: $ ] ] ]! !

!RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''!
rename: varName to: newVarName handler: aBlock 
	"Rename varName to newVarName, evaluating aBlock if there is a 
	temporary variable with the same name as newVarName. This 
	does not change temporary variables with varName."

	| rewriteRule |
	rewriteRule := self new.
	rewriteRule
		replace: varName with: newVarName;
		replaceArgument: newVarName
			withValueFrom: 
				[:aNode | 
				aBlock value.
				aNode].
	^rewriteRule! !

!RBParseTreeRewriterTest commentStamp: ''!
SUnit tests for RBParseTreeRewriter!
!RBParseTreeRewriterTest methodsFor: 'helpers' stamp: ''!
parseRewriteMethod: aString
	^ self parserClass parseRewriteMethod: aString! !

!RBParseTreeRewriterTest methodsFor: 'tests - ok' stamp: ''!
testBlockRewritesAreNotChained
	"This test shows that rewrite rules are not chained sequentially. One is applied and this is it."

	| tree |
	tree := self treeToBeRewritten.	
	"asdf ->  fdsa but not fdsa -> grgrgrgrgr"
	rewriter replace: 'asdf' with: 'fdsa' when: [ :aNode | true ].
	rewriter replace: 'fdsa' with: 'grgrgrgrgr' when: [ :aNode | true ].
	rewriter executeTree: tree.
	self
		compare: tree
		to:
			(self
				parseMethod:
					'method: asdf
	<primitive: 1>
	<primitive: 2>
	^fdsa +  self foo + fdsa')! !

!RBParseTreeRewriterTest methodsFor: 'setup' stamp: ''!
treeToBeRewritten
	^ self parserClass
		parseMethod:
			'method: asdf
	<primitive: 1>
	<primitive: 2>
	^asdf + self foo + asdf'! !

!RBParseTreeRewriterTest methodsFor: 'tests - to be refined' stamp: ''!
testPatternCascade

	rewriter replace: 'self `;messages; foo: 4; `;messages1'
		with: 'self `;messages1; bar: 4; `;messages'.
	self compare: (rewriter
				executeTree: (self 
							parseExpression: 'self foo; printString; foo: 4; bar. self foo: 4');
				tree)
		to: (self 
				parseExpression: 'self bar; bar: 4; foo; printString. self foo:4')! !

!RBParseTreeRewriterTest methodsFor: 'tests - ok' stamp: ''!
testBlockRewrites
	"This test shows that several rules can be used to specify different rewrite actions: the location in the tree structure, simple expression (self foo) using the node of the expression itself, and depending on the node kinds."

	| tree |
	tree := self treeToBeRewritten.
	"Here the rule says that we only replace in the rightmost children of the return node."
	rewriter replace: 'asdf' with: 'fdsa' when: [ :aNode | aNode parent parent isReturn ].	
	"here we want the replace self foo by the value the selector of the self foo expression, i.e. foo"
	rewriter replace: 'self foo' withValueFrom: [ :aNode | RBVariableNode named: aNode selector asString ].	
	"here the condition is false so the rule is not executed."
	rewriter replaceArgument: 'asdf' withValueFrom: [ :aNode | RBVariableNode named: 'xxx' ] when: [ :aNode | true ].
	rewriter executeTree: tree.
	self
		compare: tree
		to:
			(self
				parseMethod:
					'method: xxx
	<primitive: 1>
	<primitive: 2>
	^asdf +  foo + fdsa')! !

!RBParseTreeRewriterTest methodsFor: 'tests - ok' stamp: ''!
testBlockRewritesFirstRuleTakePrecedence
	| tree |
	tree := self treeToBeRewritten.	
	"Here the rule says that we only replace in the rightmost children of the return node."
	rewriter replace: 'asdf' with: 'fdsa' when: [ :aNode | true ].
	rewriter replace: 'asdf' with: 'grgrgrgrgr' when: [ :aNode | true ].
	rewriter executeTree: tree.
	self
		compare: tree
		to:
			(self
				parseMethod:
					'method: asdf
	<primitive: 1>
	<primitive: 2>
	^fdsa +  self foo + fdsa')! !

!RBParseTreeRewriterTest methodsFor: 'tests - to be refined' stamp: ''!
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: (self parseExpression: (rewrite executeTree: (self parseExpression: each first);
				 tree) formattedCode)
			to: (self parseExpression: (each at: 2))]! !

!RBParseTreeRewriterTest methodsFor: 'helpers' stamp: ''!
parseRewriteExpression: aString
	^ self parserClass parseRewriteExpression: aString! !

!RBParseTreeRewriterTest methodsFor: 'tests - to be refined' stamp: ''!
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 <foo: 1 bar: 2>' 'a <bar: 2 foo: 1>' 'a <`sel1: `#arg1 `sel2: `#arg2>' 'a <`sel2: `#arg2 `sel1: `#arg1>') #('a <foo> self foo' 'b <foo> self foo' 'a `@.stmts' 'b `@.stmts'))
		do: 
			[:each | 
			| rewrite |
			rewrite := RBParseTreeRewriter new.
			rewrite replaceMethod: (each at: 3) with: each last.
			self compare: (self 
						parseMethod: (rewrite
								executeTree: (self parseMethod: each first);
								tree) formattedCode)
				to: (self parseMethod: (each at: 2)).
			rewrite := RBParseTreeRewriter new.
			rewrite replaceTree: (self parseRewriteMethod: (each at: 3))
				withTree: (self parseRewriteMethod: each last).
			self compare: (self 
						parseMethod: (rewrite
								executeTree: (self parseMethod: each first);
								tree) formattedCode)
				to: (self parseMethod: (each at: 2))]! !

!RBParseTreeRewriterTest methodsFor: 'utilities' stamp: ''!
compare: anObject to: anotherObject
	self assert: anObject hash equals: anotherObject hash.
	self assert: anObject equals: anotherObject! !

!RBParseTreeRewriterTest methodsFor: 'tests - ok' stamp: ''!
testBlockRewritesArguments
	"this test just shows that all the arguments are replaced. Check in contrast with testBlockRewritesArgumentsTakeIntoAccountConditions"
	| tree |
	tree := self 
				parseMethod: 'method: asdf bar: bar
	<primitive: 1>
	<primitive: 2>
	^asdf + self foo + asdf'.
	
	rewriter 
		replaceArgument: 'asdf'
		withValueFrom: [ :aNode | RBVariableNode named: 'xxx' ]
		when: [ :aNode | true ].
		
	rewriter 
		replaceArgument: 'bar'
		withValueFrom: [ :aNode | RBVariableNode named: 'yyy' ]
		when: [ :aNode | true ].	
		
	rewriter executeTree: tree.
	self compare: tree
		to: (self 
				parseMethod: 'method: xxx bar: yyy
	<primitive: 1>
	<primitive: 2>
	^asdf +  self foo + asdf')! !

!RBParseTreeRewriterTest methodsFor: 'tests - ok' stamp: ''!
testBlockRewritesWithTrueConditionIsNotExecutedWhenNotMatchingCorrectNode
	"This test shows that even if the condition of the rule is true, it will not be applied on inadequate nodes.
	Here, replaceArgument: is not for plain variable but only method arguments."

	| tree |
	tree := self treeToBeRewritten.
	rewriter replaceArgument: 'asdf' withValueFrom: [ :aNode | RBVariableNode named: 'xxx' ] when: [ :aNode | true ].
	rewriter executeTree: tree.
	self
		compare: tree
		to:
			(self
				parseMethod:
					'method: xxx
	<primitive: 1>
	<primitive: 2>
	^asdf +  self foo + asdf')! !

!RBParseTreeRewriterTest methodsFor: 'tests - to be refined' stamp: ''!
testRewriteDynamicArray
	| newSource |
	rewriter := RBParseTreeRewriter new replace: '
		{`@first. `@second. `@third}' with: 'Array with: `@first  with: `@second  with: `@third'.

	newSource := (rewriter executeTree: (self parseRewriteExpression: ' {(1 @ 255).	(Color lightMagenta). 3}'))
		ifTrue: [ rewriter tree formattedCode].
	self assert: newSource equals: 'Array with: 1 @ 255 with: Color lightMagenta with: 3'.! !

!RBParseTreeRewriterTest methodsFor: 'tests - ok' stamp: ''!
testBlockRewritesArgumentsTakeIntoAccountConditions
	"this test shows that the condition controls the rewriting on the terms: here the bar argument is not rewritten because the condition is set to false."
	| tree |
	tree := self 
				parseMethod: 'method: asdf bar: bar
	<primitive: 1>
	<primitive: 2>
	^asdf + self foo + asdf'.
	rewriter 
		replaceArgument: 'asdf'
		withValueFrom: [ :aNode | RBVariableNode named: 'xxx' ]
		when: [ :aNode | true ].
	rewriter 
		replaceArgument: 'bar'
		withValueFrom: [ :aNode | RBVariableNode named: 'yyy' ]
		when: [ :aNode | false ].	
		
	rewriter executeTree: tree.
	self compare: tree
		to: (self 
				parseMethod: 'method: xxx bar: bar
	<primitive: 1>
	<primitive: 2>
	^asdf +  self foo + asdf')! !

!RBParseTreeRewriterTest methodsFor: 'helpers' stamp: ''!
parserClass
	^ RBParser! !

!RBParseTreeRewriterTest methodsFor: 'tests - to be refined' stamp: ''!
testMultimatch
	| count |
	count := 0.
	rewriter 
		replace: '``@object at: ``@foo'
		with: '``@object foo: ``@foo'
		when: [:aNode | (count := count + 1) == 2].
	self compare: (rewriter
				executeTree: (self parseExpression: 'self at: (bar at: 3)');
				tree)
		to: (self parseExpression: 'self at: (bar foo: 3)')! !

!RBParseTreeRewriterTest methodsFor: 'helpers' stamp: ''!
parseExpression: aString
	^ self parserClass parseExpression: aString! !

!RBParseTreeRewriterTest methodsFor: 'helpers' stamp: ''!
parseMethod: aString
	^ self parserClass parseMethod: aString! !

!RBParseTreeRewriterTest methodsFor: 'tests - ok' stamp: ''!
testRewriteDoesNotReuseOriginalNodes
	"Due to a bug in RBPatternVariableNode copyInContext method, creating a new astTree from the rewriter reused some nodes
	 of the original tree, this results in two trees sharing the identical nodes. The original AST now contained statement nodes
	that don't refer to the same parent (the method node) and that is wrong."

	| ast search replace |
	ast := self
		parseMethod:
			'foo
self statement1.
self match.'.
	"all statement nodes have the same parent"
	self assert: ast statements first parent equals: ast statements last parent.
	search := '`msg
`@.statements.
`object match.'.
	replace := '`msg
`@.statements.
`object class.'.
	rewriter := RBParseTreeRewriter new.
	rewriter replaceMethod: search with: replace.
	rewriter executeTree: ast.
	"all statement nodes of the original AST still have the same parent"
	self assert: ast statements first parent equals: ast statements last parent! !

!RBParseTreeRewriterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	rewriter := RBParseTreeRewriter new.! !

!RBParseTreeRule commentStamp: ''!
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	<ParseTreeSearcher>	The searcher that is actually performing the search.
	searchTree	<RBProgramNode>	The parse tree to be searched.

!
!RBParseTreeRule methodsFor: 'private' stamp: ''!
context
	^owner context! !

!RBParseTreeRule methodsFor: 'matching' stamp: ''!
foundMatchFor: aProgramNode
	^aProgramNode! !

!RBParseTreeRule methodsFor: 'accessing' stamp: ''!
sentMessages
	^searchTree sentMessages! !

!RBParseTreeRule methodsFor: 'initialization' stamp: ''!
methodSearchString: aString
	searchTree := self parserClass parseRewriteMethod: aString! !

!RBParseTreeRule methodsFor: 'initialize-release' stamp: ''!
owner: aParseTreeSearcher
	owner := aParseTreeSearcher! !

!RBParseTreeRule methodsFor: 'matching' stamp: ''!
performOn: aProgramNode 
	self context empty.
	^((searchTree match: aProgramNode inContext: self context) 
		and: [self canMatch: aProgramNode]) 
			ifTrue:
				[owner recusivelySearchInContext.
				self foundMatchFor: aProgramNode]
			ifFalse: [nil]! !

!RBParseTreeRule methodsFor: 'initialization' stamp: ''!
searchString: aString
	searchTree := self parserClass parseRewriteExpression: aString! !

!RBParseTreeRule methodsFor: 'testing' stamp: ''!
canMatch: aProgramNode 
	^true! !

!RBParseTreeRule methodsFor: 'initialization' stamp: ''!
parserClass
	^ RBParser! !

!RBParseTreeRule class methodsFor: 'instance creation' stamp: ''!
search: aString 
	^(self new)
		searchString: aString;
		yourself! !

!RBParseTreeRule class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBParseTreeRule! !

!RBParseTreeRule class methodsFor: 'instance creation' stamp: ''!
methodSearch: aString 
	^(self new)
		methodSearchString: aString;
		yourself! !

!RBParseTreeSearcher commentStamp: ''!
ParseTreeSearcher walks over a normal source code parse tree using the visitor pattern and then matches these nodes against the meta-nodes using the match:inContext: methods defined for the meta-nodes.

Instance Variables:
	answer	<Object>	the "answer" that is propagated between matches
	argumentSearches	<Collection of: (Association key: RBProgramNode value: BlockClosure)>	argument searches (search for the RBProgramNode and perform the BlockClosure when its found)
	context	<RBSmallDictionary>	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	<Collection>	the sent messages in our searches
	searches	<Collection of: (Association key: RBProgramNode value: BlockClosure)>	non-argument searches (search for the RBProgramNode and perform the BlockClosure when its found)!
!RBParseTreeSearcher methodsFor: 'searching' stamp: ''!
matchesAnyOf: aStringCollection do: aBlock 
	aStringCollection do: [:each | self matches: each do: aBlock]! !

!RBParseTreeSearcher methodsFor: 'accessing' stamp: ''!
context
	^context! !

!RBParseTreeSearcher methodsFor: 'searching' stamp: ''!
matchesMethod: aString do: aBlock 
	self addRule: (RBSearchRule searchForMethod: aString thenDo: aBlock)! !

!RBParseTreeSearcher methodsFor: 'searching' stamp: ''!
matchesAnyTreeOf: treeCollection do: aBlock 
	treeCollection do: [:each | self matchesTree: each do: aBlock]! !

!RBParseTreeSearcher methodsFor: 'testing' stamp: ''!
canMatchMethod: aCompiledMethod
	| actualMessages |
	self messages isEmpty
		ifTrue: [ ^ true ].
	actualMessages := aCompiledMethod messages.
	^ self messages 
		anySatisfy: [ :each | actualMessages includes: each ]! !

!RBParseTreeSearcher methodsFor: 'accessing' stamp: ''!
addRules: ruleCollection 
	ruleCollection do: [:each | self addRule: each]! !

!RBParseTreeSearcher methodsFor: 'accessing' stamp: ''!
addArgumentRules: ruleCollection 
	ruleCollection do: [:each | self addArgumentRule: each]! !

!RBParseTreeSearcher methodsFor: 'accessing' stamp: ''!
executeTree: aParseTree 
	"Save our current context, in case someone is performing another search inside a match."

	| oldContext |
	oldContext := context.
	context := SmallDictionary new.
	self visitNode: aParseTree.
	context := oldContext.
	^answer! !

!RBParseTreeSearcher methodsFor: 'accessing' stamp: ''!
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: 'visiting' stamp: ''!
visitNode: aNode 
	| value |
	value := self performSearches: searches on: aNode.
	^ value
		ifNil: [ 
			super visitNode: aNode.
			aNode ]
		ifNotNil: [ value ]! !

!RBParseTreeSearcher methodsFor: 'search' stamp: ''!
addSearches: aCollectionOfAssociations
	"Defines matching rules based on the list of Association (pattern * action)."
	
	aCollectionOfAssociations do: [ :each | self addSearch: each ]! !

!RBParseTreeSearcher methodsFor: 'search' stamp: ''!
addSearch: anAssociation 
	"Create a search rule whose pattern is the association key and action is the association value."
	
	self matches: anAssociation key do: anAssociation value! !

!RBParseTreeSearcher methodsFor: 'accessing' stamp: ''!
addArgumentRule: aParseTreeRule 
	argumentSearches add: aParseTreeRule.
	aParseTreeRule owner: self! !

!RBParseTreeSearcher methodsFor: 'accessing' stamp: ''!
addRule: aParseTreeRule 
	searches add: aParseTreeRule.
	aParseTreeRule owner: self! !

!RBParseTreeSearcher methodsFor: 'private' stamp: ''!
performSearches: aSearchCollection on: aNode 
	| value |
	aSearchCollection do: [ :aSearchRule|
		value := aSearchRule performOn: aNode.
		value notNil 
			ifTrue: 
				[self foundMatch.
				^value]].
	^nil! !

!RBParseTreeSearcher methodsFor: 'accessing' stamp: ''!
executeMethod: aParseTree initialAnswer: anObject 
	answer := anObject.
	searches detect: [:each | (each performOn: aParseTree) notNil] ifNone: [].
	^answer! !

!RBParseTreeSearcher methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	context := SmallDictionary new.
	searches := OrderedCollection new.
	argumentSearches := OrderedCollection new: 0! !

!RBParseTreeSearcher methodsFor: 'accessing' stamp: ''!
executeTree: aParseTree initialAnswer: aValue 
	answer := aValue.
	^self executeTree: aParseTree! !

!RBParseTreeSearcher methodsFor: 'searching' stamp: ''!
matchesTree: aBRProgramNode do: aBlock 
	self addRule: (RBSearchRule searchForTree: aBRProgramNode thenDo: aBlock)! !

!RBParseTreeSearcher methodsFor: 'searching' stamp: ''!
matches: aString do: aBlock 
	self addRule: (RBSearchRule searchFor: aString thenDo: aBlock)! !

!RBParseTreeSearcher methodsFor: 'searching' stamp: ''!
matchesAnyMethodOf: aStringCollection do: aBlock 
	aStringCollection do: [:each | self matchesMethod: each do: aBlock]! !

!RBParseTreeSearcher methodsFor: 'private' stamp: ''!
lookForMoreMatchesInContext: oldContext 
	oldContext keysAndValuesDo: 
			[:key :value | 
			(key isString not and: [key recurseInto]) 
				ifTrue: [value do: [:each | self visitNode: each]]]! !

!RBParseTreeSearcher methodsFor: 'visiting' stamp: ''!
visitArgumentNode: aNode
	| value |
	value := self performSearches: argumentSearches on: aNode.
	^ value
		ifNil: [ 
			super visitArgumentNode: aNode.
			aNode ]
		ifNotNil: [ value ]! !

!RBParseTreeSearcher methodsFor: 'searching' stamp: ''!
matchesArgumentTree: aBRProgramNode do: aBlock 
	self 
		addArgumentRule: (RBSearchRule searchForTree: aBRProgramNode thenDo: aBlock)! !

!RBParseTreeSearcher methodsFor: 'initialization' stamp: ''!
answer: anObject
	answer := anObject! !

!RBParseTreeSearcher methodsFor: 'private' stamp: ''!
recusivelySearchInContext
	"We need to save the matched context since the other searches might overwrite it."

	| oldContext |
	oldContext := context.
	context := SmallDictionary new.
	self lookForMoreMatchesInContext: oldContext.
	context := oldContext! !

!RBParseTreeSearcher methodsFor: 'searching' stamp: ''!
matchesAnyArgumentOf: stringCollection do: aBlock 
	stringCollection do: [:each | self matchesArgument: each do: aBlock]! !

!RBParseTreeSearcher methodsFor: 'testing' stamp: ''!
hasRules
	^searches notEmpty! !

!RBParseTreeSearcher methodsFor: 'private' stamp: ''!
foundMatch! !

!RBParseTreeSearcher methodsFor: 'searching' stamp: ''!
matchesArgument: aString do: aBlock 
	self addArgumentRule: (RBSearchRule searchFor: aString thenDo: aBlock)! !

!RBParseTreeSearcher methodsFor: 'accessing - context' stamp: ''!
variableNamed: aString 
	
	^ (context associations detect: [ :assoc | assoc key name = aString  ]) value! !

!RBParseTreeSearcher methodsFor: 'accessing' stamp: ''!
answer
	^answer! !

!RBParseTreeSearcher class methodsFor: 'private' stamp: ''!
buildSelectorString: aSelector 
	| stream keywords |
	aSelector numArgs = 0 ifTrue: [^aSelector].
	stream := String new writeStream.
	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: 'instance creation' stamp: ''!
getterMethod: aVarName 
	^ self new
		matchesMethod: '`method ^' , aVarName do: [:aNode :ans | aNode selector];
		matchesMethod: '`method ^' , aVarName, ' ifNil:[ `@expr]' do: [:aNode :ans | aNode selector];
		yourself! !

!RBParseTreeSearcher class methodsFor: '*Refactoring2-Transformations' stamp: ''!
treeMatchings: aString in: aParseTree 

	| allMatches |
	allMatches := OrderedCollection new.
	self new
		matches: aString do: [ :aNode :answer | allMatches add: aNode ];
		executeTree: aParseTree.
	^ allMatches! !

!RBParseTreeSearcher class methodsFor: 'instance creation' stamp: ''!
setterMethod: aVarName 
	^(self new)
		matchesAnyMethodOf: (Array with: '`method: `Arg ' , aVarName , ' := `Arg'
					with: '`method: `Arg ^' , aVarName , ' := `Arg')
			do: [:aNode :ans | aNode selector];
		yourself! !

!RBParseTreeSearcher class methodsFor: '*Refactoring2-Transformations' stamp: ''!
whichMethodIn: aCollection matches: subtree

	| isGetterBlock searchTree |
	isGetterBlock := self new
		matchesAnyMethodOf: #(
			'`method ^ `@aValue`{ :aNode |
				(aNode isKindOf: RBInstanceVariableNode)
				or: [ aNode isKindOf: RBLiteralValueNode ] }' )
		do: [ :node :answer | true ].
	searchTree := self matchingTreeForSubtree: subtree.

	^ aCollection
		reject: [ :method | (isGetterBlock executeTree: method ast initialAnswer: false)
			or: [ (self treeMatching: searchTree in: method ast) isNil ] ]! !

!RBParseTreeSearcher class methodsFor: 'private' stamp: ''!
buildTree: aString method: aBoolean 
	^aBoolean 
		ifTrue: [RBParser parseRewriteMethod: aString]
		ifFalse: [RBParser parseRewriteExpression: aString]! !

!RBParseTreeSearcher class methodsFor: 'private' stamp: ''!
buildSelectorTree: aSelector 
	aSelector isEmpty ifTrue: [^nil].
	^RBParser parseRewriteExpression: '``@receiver ' 
				, (self buildSelectorString: aSelector)
		onError: [:err :pos | ^nil]! !

!RBParseTreeSearcher class methodsFor: 'accessing' stamp: ''!
treeMatchingStatements: aString in: aParseTree 
	| notifier tree |
	notifier := self new.
	tree := RBParser parseExpression: aString.
	tree isSequence 
		ifFalse: [tree := RBSequenceNode statements: (Array with: tree)].
	tree temporaries: (Array with: (RBPatternVariableNode named: '`@temps')).
	tree addNodeFirst: (RBPatternVariableNode named: '`@.S1').
	tree lastIsReturn 
		ifFalse: [tree addNode: (RBPatternVariableNode named: '`@.S2')].
	notifier matchesTree: tree
		do: [:aNode :answer | ^RBParser parseExpression: aString].
	notifier executeTree: aParseTree.
	^nil! !

!RBParseTreeSearcher class methodsFor: '*Refactoring2-Transformations' stamp: ''!
matchingTreeForSubtree: subtree

	| searchCode argumentNodes |
	searchCode := subtree formattedCode.

	"if there's just a return, remove it"
	subtree lastIsReturn ifTrue: [ 
		searchCode := searchCode copyReplaceAll: '^' with: '' ].
	
	"replace literal values by wildcards"
	argumentNodes := subtree allChildren
		select: #isLiteralNode
		thenCollect: [ :e | ' ', e value printString ].
	argumentNodes doWithIndex: [ :e :i |
		searchCode := searchCode
							copyReplaceAll: e 
							with: '``@a',i asString,'`{ :aNode | aNode isArgument }' ].
	
	^ searchCode! !

!RBParseTreeSearcher class methodsFor: 'accessing' stamp: ''!
treeMatching: aString in: aParseTree 
	(self new)
		matches: aString do: [:aNode :answer | ^aNode];
		executeTree: aParseTree.
	^nil! !

!RBParseTreeSearcher class methodsFor: 'instance creation' stamp: ''!
justSendsSuper
	^ self new
		matchesAnyMethodOf: #(
			'`@method: `@args ^ super `@method: `@args' 
			'`@method: `@args super `@method: `@args')
		do: [ :node :answer | true ];
		yourself! !

!RBParseTreeSearcher class methodsFor: '*Refactoring2-Transformations' stamp: ''!
matchingTreeForMethod: aCompiledMethod

	| searchCode tree variables |
	tree := aCompiledMethod ast.
	searchCode := tree body sourceCode.
	
	"if there's just a return, remove it"
	tree body lastIsReturn ifTrue: [ 
		searchCode := searchCode copyReplaceAll: '^' with: '' ].
	
	"replace arguments by wildcards"
	variables := tree arguments
		collect: [ :e | ' ', e name asString ].
	variables doWithIndex: [ :e :i |
		searchCode := searchCode copyReplaceAll: e with: '``@a',i asString ].
	
	^ searchCode! !

!RBParseTreeSearcher class methodsFor: 'instance creation' stamp: ''!
returnSetterMethod: aVarName 
	^(self new)
		matchesMethod: '`method: `Arg ^' , aVarName , ' := `Arg'
			do: [:aNode :ans | aNode selector];
		yourself! !

!RBParseTreeSearcherTest commentStamp: ''!
SUnit tests for RBParseTreeSearcher!
!RBParseTreeSearcherTest methodsFor: 'tests - to de refined' stamp: ''!
testDynamicArrayStatements
	"match in context for arraynodes wrongly matched all array statements against the last variable, if all variables are pattern-list-variables"

	| dict |
	searcher matches: '{`@first. `@second. `@third.}' do: [ :aNode :answer |  dict:= searcher context ].
	dict := searcher executeTree: (self parseExpression:'{ (1@2) . Color red . 3}').
	self assert: (dict at: (RBPatternVariableNode named:'`@first')) formattedCode equals: '(1 @ 2)'.
	self assert: (dict at: (RBPatternVariableNode named:'`@second')) formattedCode equals: 'Color red'.
	self assert: (dict at: (RBPatternVariableNode named:'`@third')) formattedCode equals: '3'! !

!RBParseTreeSearcherTest methodsFor: 'tests - add search' stamp: ''!
testSimpleAddSearches

	| res |
	searcher addSearches: { '`@Super << `#ASymbol' -> [ :aNode :anAnswer | res := #class ]}.
	searcher executeTree: (RBParser parseExpression: ' Object << #Point').
	self assert: res equals: #class! !

!RBParseTreeSearcherTest methodsFor: 'tests' stamp: ''!
testSearchingComposedSelector
	
	searcher 
		matches: '``@rcv at: ``@arg `sel: ``@arg1'
		do: [ :aNode :answer | answer + 1].
		
	"the result is 2 because the parse tree searcher only finds at:x: messages like at:put: and at:ifAbsent:"	
	self 
		assert: (searcher 
					executeTree: (self 	
							parseExpression: 'self at: 1 put: 2; at: 2 ifAbsent: []; ifAbsent: 2 at: 1; at: 4; foo')
					initialAnswer: 0) equals: 2! !

!RBParseTreeSearcherTest methodsFor: 'tests' stamp: ''!
testSearchingComposedSelector2

	searcher
		matches: '``@rcv at: ``@arg'
		do: [ :aNode :answer | answer + 1 ].
	"the result is 1 because the parse tree searcher only finds at: messages like at: and not ifAbsent: at:"	
	self 
		assert: (searcher 
					executeTree: (self parseExpression: 'self ifAbsent: 2 at: 1; at: 4; foo')
					initialAnswer: 0)
		equals: 1! !

!RBParseTreeSearcherTest methodsFor: 'tests - to de refined' stamp: ''!
testDynamicArrayWithStatementListPattern
	"pattern with statementlist in a dynamic array, to match all dynamic array expressions"

	| dict |
	searcher matches: '{`.@stmts.}' do: [ :aNode :answer |  dict:= searcher context ].
	dict := searcher executeTree: (self parseExpression:'{ (1@2) . Color red . 3}').
	self assert: (dict at: (RBPatternVariableNode named: '`.@stmts')) size equals: 3! !

!RBParseTreeSearcherTest methodsFor: 'tests - add search' stamp: ''!
testSimpleAddSearch

	| res |
	searcher addSearch: '`@Super << `#ASymbol' -> [ :aNode :anAnswer | res := #class ].
	searcher executeTree: (RBParser parseExpression: ' Object << #Point').
	self assert: res equals: #class! !

!RBParseTreeSearcherTest methodsFor: 'tests - to de refined' stamp: ''!
parseTreeSearcher
	^ RBParseTreeSearcher new! !

!RBParseTreeSearcherTest methodsFor: 'helpers' stamp: ''!
parseExpression: aString 

	^ RBParser parseExpression: aString! !

!RBParseTreeSearcherTest methodsFor: 'tests - to de refined' stamp: ''!
testSearching
	searcher
		matches: '``@rcv at: ``@arg `sel: ``@arg1'
		do: [ :aNode :answer | answer + 1 ].
	self
		assert:
			(searcher
				executeTree:
					(self
						parseExpression: 'self at: 1 put: 2; at: 2 ifAbsent: []; ifAbsent: 2 at: 1; at: 4; foo')
				initialAnswer: 0)
		equals: 2.
	searcher := self parseTreeSearcher.
	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)
		equals: 1.
	searcher := self parseTreeSearcher.
	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)! !

!RBParseTreeSearcherTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	searcher := self parseTreeSearcher! !

!RBParseTreeTest methodsFor: 'helpers' stamp: ''!
parseRewriteMethod: aString
	^ self parserClass parseRewriteMethod: aString! !

!RBParseTreeTest methodsFor: 'private' stamp: ''!
parseFaultyMethod: text
	^ self parserClass parseFaultyMethod: text! !

!RBParseTreeTest methodsFor: 'helpers' stamp: ''!
parserClass
	^ RBParser! !

!RBParseTreeTest methodsFor: 'helpers' stamp: ''!
parseExpression: aString
	^ self parserClass parseExpression: aString! !

!RBParseTreeTest methodsFor: 'helpers' stamp: ''!
parseMethod: aString
	^ self parserClass parseMethod: aString! !

!RBParseTreeTest methodsFor: 'helpers' stamp: ''!
parseFaultyExpression: aString
	^ self parserClass parseFaultyExpression: aString! !

!RBParseTreeTest class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self name = #RBParseTreeTest! !

!RBParser commentStamp: ''!
RBParser takes a source code string and generates an AST for it. This is a hand-written, recursive descent parser and has been optimized for speed. The simplest way to call this is either 'RBParser parseExpression: aString' if you want the AST for an expression, or 'RBParser parseMethod: aString' if you want to parse an entire method.

Instance Variables:
	currentToken	<RBToken>	The current token being processed.
	emptyStatements	<Boolean>	True if empty statements are allowed. In IBM, they are, in VW they aren't.
	errorBlock	<BlockClosure>	The block to evaluate on a syntax error.
	nextToken	<RBToken>	The next token that will be processed. This allows one-token lookahead.
	scanner	<RBScanner>	The scanner that generates a stream of tokens to parse.
	source	<String>	The source code to parse
	tags	<Collection of: Interval>	The source intervals of the tags appearing at the top of a method (e.g. Primitive calls)

Shared Variables:
	ParserType	<Symbol>	the type code we are parsing!
!RBParser methodsFor: 'accessing' stamp: ''!
initializeParserWith: aString 
	source := aString.
	self scanner: (self scannerClass on: (ReadStream on: aString) errorBlock: self errorBlock)! !

!RBParser methodsFor: 'error handling' stamp: ''!
errorBlock
	^errorBlock ifNil: [[:message :position | ]] ifNotNil: [errorBlock]! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseTemps
	| temps |
	temps := OrderedCollection new.
	[currentToken isIdentifier] whileTrue: [temps add: self parsePrimitiveIdentifier].
	^temps! !

!RBParser methodsFor: 'private' stamp: ''!
nextToken
	^nextToken ifNil: [nextToken := self scannerNext] ifNotNil: [nextToken]! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseStatements: pragmaBoolean into: aSequenceNode until: aBlock
	
	self parseTemporariesInto: aSequenceNode.
	
	^self
		parseStatementList: pragmaBoolean
		into: aSequenceNode
		until: aBlock! !

!RBParser methodsFor: 'private - classes' stamp: ''!
englobingErrorNodeClass 
	^RBEnglobingErrorNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parsePragmas
	[ currentToken isBinary and: [ currentToken value = #< ] ] whileTrue: [
		self parsePragma.
		self step ]! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseStatementInto: statementList periodList: periods

	| returnPosition node startOfStatementToken |
	
	"Record the token found at the beginning of the statement.
	If at the end we did not consume it, consume it and mark it as a bad statement for now"
	startOfStatementToken := currentToken.
	
	"If the current statement starts with ^, parse it as a return + an expression.
	Otherwise just parse it as an expression.
	Expressions start with assignments, which have lower precedence"
	(currentToken isSpecial and: [ currentToken value = $^ ])
		ifTrue: [ 
			returnPosition := currentToken start.
			self step.
			node := self returnNodeClass
				        return: returnPosition
				        value: self parseAssignment ]
		ifFalse: [ node := self parseAssignment ].

	"At this point we have parsed a full statement.
	Next we should have the end of the statement
	  - a dot or
	  - a scope closer e.g., )]} or
	  -  or the end of the stream.
	If it is neither, we should mark our statement as unfinished statement."
	(currentToken value ~= $. 
		and: [ ('])}' includes: currentToken value) not
			and: [ currentToken isEOF not ] ] ) ifTrue: [
		self parserError: 'End of statement expected'.
		node := RBUnfinishedStatementErrorNode
			content: { node }
			start: node start
			stop: node stop
			errorMessage: 'End of statement expected'
	].

	"Then consume all dots and comments coming after this well formed statement, if there was any"
	(currentToken isSpecial and: [ currentToken value = $. ]) ifTrue: [ 
		periods add: currentToken start.
		self step.
		self addCommentsTo: node ].

	[ currentToken isSpecial and: [ currentToken value = $. ] ] 
		whileTrue: [ 
			periods add: currentToken start.
			self step ].

	"If the previous node in the statement list is a return node, mark this node as unreachable"
	
	(statementList notEmpty and: [ statementList last isReturn ]) ifTrue: [
		self parserError: 'Unreachable code'.
		node := RBUnreachableStatementErrorNode
			content: { node }
			start: node start
			stop: node stop
			errorMessage: 'Unreachable code' ].

	"Commit the statement to the statements list"
	statementList add: node.
	
	"Consume it. This is a hack to get to work"
	startOfStatementToken = currentToken ifTrue: [ self step ]! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseKeywordMessageWith: node 
	| args isKeyword keywordsStartPositions selector|
	args := OrderedCollection new: 3.
	keywordsStartPositions := OrderedCollection new: 3.
	selector := self selectorNodeClass value: ''.
	
	isKeyword := false.
	[currentToken isKeyword] whileTrue: 
			[keywordsStartPositions add: currentToken start.
			selector value: selector value, currentToken value.
			self step.
			args add: self parseBinaryMessage.
			isKeyword := true].
	selector keywordPositions: keywordsStartPositions.
	^isKeyword
		ifTrue: 
			[self messageNodeClass 
				receiver: node
				selector: selector
				keywordsPositions: keywordsStartPositions
				arguments: args]
		ifFalse: [node]! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseUnaryPragma
	"Current Token must be an Identifier."
	"Return an RBPragmaNode."
	| selector |
	selector := currentToken.
	self step.
	^ self pragmaNodeClass selector: selector value asSymbol keywordsPositions: (Array with: selector start) arguments: #()! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parsePrimitiveLiteral
	^ currentToken isNumberLiteralToken
		ifTrue: [ self parseNumberLiteral ]
		ifFalse: [ self parsePrimitiveValueLiteral ]! !

!RBParser methodsFor: 'private' stamp: ''!
scannerNext

	^ scanner next! !

!RBParser methodsFor: 'private' stamp: ''!
addCommentsTo: aNode
	aNode comments: aNode comments , comments.
	comments do: [ :each | each parent: aNode ].
	comments := OrderedCollection new! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseBlock
	| startToken node |
	startToken := currentToken.
	self step.
	node := self blockNodeClass new. 
	self parseBlockArgsInto: node.
	self addCommentsTo: node.		
	node left: startToken start.
	node body: self sequenceNodeClass new.
	
	self
		parseStatements: false
		into: node body
		untilAnyCloserOf: ']'.
	
	(currentToken isSpecial and: [currentToken value = $]])
		ifFalse: [ ^ self parseEnglobingError: node body statements with: startToken errorMessage: ''']'' expected'].
	node right: currentToken start.
	self step.
	^node! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseMessagePattern
	currentToken isLiteralToken ifTrue: [self patchLiteralMessage].
	^currentToken isIdentifier 
		ifTrue: [self parseUnaryPattern]
		ifFalse: 
			[currentToken isKeyword 
				ifTrue: [self parseKeywordPattern]
				ifFalse: [self parseBinaryPattern]]! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
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 - classes' stamp: ''!
pragmaNodeClass
	^ RBPragmaNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseNumberLiteral
	"Creates a literal value node from a number literal token."
	| token |
	"self deprecated: 'Unnecessary method because it is the same as parsePrimitiveValueLiteral, both called only by parsePrimitiveLiteral' transformWith: self parsePrimitiveLiteral."
	token := currentToken.
	self step.
	
	^self literalValueNodeClass 
		value: token value 
		start: token start
		stop: token stop
		source: token source! !

!RBParser methodsFor: 'testing' stamp: ''!
atEnd
	^currentToken isEOF! !

!RBParser methodsFor: 'private' stamp: ''!
patchLiteralMessage

	currentToken value == true
		ifTrue: [ ^ currentToken := RBIdentifierToken value: 'true' start: currentToken start ].
	currentToken value == false
		ifTrue: [ ^ currentToken := RBIdentifierToken value: 'false' start: currentToken start ].
	currentToken value
		ifNil: [ ^ currentToken := RBIdentifierToken value: 'nil' start: currentToken start ]! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseUnaryMessage
	| node |
	node := self parsePrimitiveObject.
	self addCommentsTo: node.
	[currentToken isLiteralToken ifTrue: [self patchLiteralMessage].
	currentToken isIdentifier] 
			whileTrue: [node := self parseUnaryMessageWith: node].
	self addCommentsTo: node.
	^node! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseKeywordPattern
	| selector positions args node |
	selector := ''.
	positions := OrderedCollection new: 2.
	args := OrderedCollection new: 2.
	[currentToken isKeyword]
		whileTrue:
			[selector := selector, currentToken value.
			 positions add: currentToken start.
			self step.
			args add: self parseVariableNode].
	node := self methodNodeClass
		selector: selector asSymbol
		keywordsPositions: positions asIntegerArray
		arguments: args.
	node comments: (node comments, args last comments).
	args last comments ifNotEmpty: [ args last comments: #() ].
	^node! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseCascadeMessage
	| node receiver messages semicolons |
	"Parse of the first message. It can be either unary, binary or keyword."
	node := self parseKeywordMessage.

	"Quick check if this matches a cascade. If not, return the already parsed node"
	(currentToken isSpecial and: [ currentToken value = $; ])
		ifFalse: [ ^ node ].

	"At this point we know we should create a cascade node."
	messages := OrderedCollection new: 3.
	semicolons := OrderedCollection new: 3.
	
	"Handle invalid cascade sequences such as:
	
	(self foo); bar
	7; message
	
	In this case, the cascade receiver should be an invalid cascade node.
	"
	(node isMessage not or: [ node hasParentheses ]) ifTrue: [ 
		"Cut parsing with an error.
		If in faulty mode, continue the execution and generate a faulty cascade node."
		self parserError: 'cascaded message not allowed'.
		receiver := node := RBInvalidCascadeErrorNode
			content: { node }
			start: node start
			stop: currentToken stop
			errorMessage: 'End of statement expected'.
	] ifFalse: [ 
		receiver := node receiver.
	 	messages add: node.
	].

	"Extract the messages following the cascade marker $;"
	[currentToken isSpecial and: [currentToken value = $;]] whileTrue: [
		|newMessage|
		semicolons add: currentToken start.
		newMessage := nil.
		self step.
		self saveCommentsDuring: [
			newMessage := self parseCascadeMessageWithReceiver: receiver ].
		self addCommentsTo: newMessage.
		messages add: newMessage ].

	^self cascadeNodeClass messages: messages semicolons: semicolons! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseTemporariesInto: aSequenceNode
	| temps leftBar rightBar errorNode startToken |
	temps := OrderedCollection new.
	leftBar := rightBar := nil.
	currentToken isBinary 
		ifTrue: 
			[currentToken value = #| 
				ifTrue: 
					[ startToken := currentToken.
					leftBar := currentToken start.
					self step.
					temps := self parseTemps.
					(currentToken isBinary and: [currentToken value = #|]) 
						ifFalse: [ errorNode :=  self parseEnglobingError: temps with: startToken errorMessage: '''|'' expected'.
									 aSequenceNode addFaultyNode: errorNode.
									 temps := OrderedCollection new.
									 leftBar := nil.
								    ]
						ifTrue: [ rightBar := currentToken start ].
					self step]
				ifFalse: 
					[currentToken value = #'||' 
						ifTrue: 
							[rightBar := (leftBar := currentToken start) + 1.
							self step]]].
				
	aSequenceNode leftBar: leftBar temporaries: temps rightBar: rightBar! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
saveCommentsDuring: aBlock
	| currentComments |
	currentComments := comments copy.
	comments removeAll.
	^ aBlock
		ensure: [ comments := comments, currentComments ]! !

!RBParser methodsFor: 'error handling' stamp: ''!
parseErrorNode: aMessageString
	| errorPosition|
	currentToken isError
		ifTrue: [ | errorNode| 
				    errorNode := RBParseErrorNode errorMessage: currentToken cause value: currentToken value at: currentToken start.
					 self step.
					 ^errorNode].
	errorPosition := self errorPosition.
	(errorPosition = 0) ifTrue: [ errorPosition := self errorPosition].
	^ RBParseErrorNode errorMessage: aMessageString value: currentToken value asString at: errorPosition! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseUnaryPattern
	| selector |
	selector := currentToken.
	self step.
	^self methodNodeClass 
		selector: selector value asSymbol 
		keywordsPositions: (Array with: selector start) 
		arguments: #()! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseStatements: pragmaBoolean
	^ self
		parseStatements: pragmaBoolean
		into: self sequenceNodeClass new
		untilAnyCloserOf: #()! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseKeywordPragma
	| selector positions arguments |
	selector := ''.
	positions := OrderedCollection new: 2.
	arguments := OrderedCollection new: 2.
	[ currentToken isKeyword ] whileTrue: [
		selector := selector, currentToken value.
		positions add: currentToken start.
		self step.
		arguments addLast: self parsePragmaLiteral ].
	^ self pragmaNodeClass
		selector: selector asSymbol
		keywordsPositions: positions asIntegerArray
		arguments: arguments.! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parsePrimitiveIdentifier
	"Creates a Variable Node and copies the value, start position and comments in said node."
	"This method is called by parseVariableNode which makes sure current token is Identifier."
	| token node |
	token := currentToken.
	self step.
	node := self variableNodeClass identifierNamed: token value at: token start.
	self addCommentsTo: node.
	^node! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseLiteralByteArrayObject
	"Ensure that the object contained in the array is the value of a byte."
	"Return a literal value node of said byte."
	(currentToken isLiteralToken and: 
			[currentToken value isInteger and: [currentToken value between: 0 and: 255]]) 
		ifFalse: [
			| errorNode |
			errorNode := self parserError: 'Expecting 8-bit integer'.
			self step.
			^ errorNode ].
	^self parsePrimitiveLiteral! !

!RBParser methodsFor: 'initialization' stamp: ''!
initialize
	comments := OrderedCollection new! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseStatementList: pragmaBoolean into: sequenceNode until: aBlock

	"Parse a list of statements and set those statetements to a sequence node.
	Stop parsing when we finish the current scope.
	Different scopes such as blocks or methods can decide different stop conditions."

	| statements return periods |
	return := false.
	statements := sequenceNode statements.
	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: [ aBlock value ] ] whileFalse: [ 
		self parseStatementInto: statements periodList: periods ].

	statements notEmpty ifTrue: [ self addCommentsTo: statements last ].
	sequenceNode
		statements: statements;
		periods: periods.
	^ sequenceNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseUnaryMessageWith: aNode 
	| selector |
	selector := self selectorNodeClass value: currentToken value keywordPositions: (Array with: currentToken start).
	self step.
	^self messageNodeClass
		receiver: aNode
		selector:  selector
		keywordsPositions: selector keywordPositions
		arguments: #()! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseStatements: pragmaBoolean into: aSequenceNode untilAnyCloserOf: aCollectionOfClosers
	
	self parseTemporariesInto: aSequenceNode.
	
	^self
		parseStatementList: pragmaBoolean
		into: aSequenceNode
		untilAnyCloserOf: aCollectionOfClosers! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseKeywordMessage
	^self parseKeywordMessageWith: self parseBinaryMessage! !

!RBParser methodsFor: 'private - classes' stamp: ''!
literalArrayNodeClass
	^ RBLiteralArrayNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseStatementList: pragmaBoolean into: sequenceNode untilAnyCloserOf: aCollectionOfClosers

	"Parse a list of statements and set those statetements to a sequence node.
	Stop parsing when we finish the current scope, delimited by a colleciton of closers.
	Different scopes such as blocks or methods can decide different stop conditions."

	| statements return periods |
	return := false.
	statements := sequenceNode statements.
	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: [aCollectionOfClosers includes: currentToken value] ] ]
			whileFalse: [
				self 
					parseStatementInto: statements
					periodList: periods
					withAcceptedStatementClosers: aCollectionOfClosers ].

	statements
		ifEmpty: [ self addCommentsTo: sequenceNode ]
		ifNotEmpty: [ self addCommentsTo: statements last ].
	sequenceNode
		statements: statements;
		periods: periods.
	^ sequenceNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parsePragma
	"Method called by parsePragmas which already verified that current token is the special character <"
	| startToken pragma |
	startToken := currentToken.
	self step.
	pragma := self basicParsePragma.
	(currentToken isBinary and: [ currentToken value == #> ]) 
		ifFalse: [  ^self addPragma: ( self parseEnglobingError: (OrderedCollection with: pragma) with: startToken errorMessage: '''>'' expected')].
	pragma left: startToken start; right: currentToken start.
	self addPragma: pragma.! !

!RBParser methodsFor: 'private - classes' stamp: ''!
returnNodeClass
	^ RBReturnNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parsePrimitiveValueLiteral
	"Creates a literal value node from a literal token."
	| token |
	"self deprecated: 'Unnecessary method because it is the same as parseNumberLiteral, both called only by parsePrimitiveLiteral' transformWith: self parsePrimitiveLiteral."
	token := currentToken.
	self step.

	^self literalValueNodeClass 
		value: token value 
		start: token start
		stop: token stop
		source: token source! !

!RBParser methodsFor: 'private - classes' stamp: ''!
arrayNodeClass
	^ RBArrayNode! !

!RBParser methodsFor: 'private - classes' stamp: ''!
literalNodeClass
	^ RBLiteralNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseCascadeMessageWithReceiver: receiver
	
	| errorNode |
	currentToken isIdentifier 
		ifTrue: [ ^ self parseUnaryMessageWith: receiver].
		
	currentToken isKeyword 
		ifTrue: [ ^ self parseKeywordMessageWith: receiver].

	currentToken isLiteralToken ifTrue: [ self patchNegativeLiteral ].
	"Upon encountering an error in the cascade, it stores an error node as it would store a message node and continues the parsing of the cascade.
	This can allow the possibility of fixing the cascade simply by replacing the false node by another."
	currentToken isBinary ifTrue: [ 
		^ self parseBinaryMessageWith: receiver ].
	
	"At this point we know this is an invalid cascade.
	Many things can happen next: it could be a closer parenthesis or bracket, the end of the stream, a non-identifier or an empty cascade.
	For now, if it is a closer return an empty error node.
	If it is not a closer, consume it"
	errorNode := self parserError: 'Cascade message expected'.
	(currentToken value ~= $.
		and: [ ('])};' includes: currentToken value) not
			and: [ currentToken isEOF not ] ] )
				ifTrue: [ self step ].
	^ errorNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseArgs
	"Return a collection of variable node."
	| args |
	args := OrderedCollection new.
	[currentToken isIdentifier] whileTrue: [args add: self parseVariableNode].
	^args! !

!RBParser methodsFor: 'private - classes' stamp: ''!
cascadeNodeClass
	^ RBCascadeNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parsePragmaLiteral
	"A literal array token is #( or #[."
	currentToken isLiteralArrayToken 
		ifTrue: 
			[^currentToken isForByteArray 
				ifTrue: [self parseLiteralByteArray]
				ifFalse: [self parseLiteralArray]].
	currentToken isLiteralToken ifFalse: [^self parserError:'Literal constant expected'].
	"Return a literal value node."
	^self parsePrimitiveLiteral! !

!RBParser methodsFor: 'error handling' stamp: ''!
errorPosition
	^currentToken ifNotNil: [ :token | token start] ifNil:[1]! !

!RBParser methodsFor: 'accessing' stamp: ''!
currentToken
	^currentToken! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseBinaryMessageWith: aNode 
	| binaryNode |
	binaryNode := self selectorNodeClass
		value: currentToken value
		keywordPositions: (Array with: currentToken start).
	self step.
	^self messageNodeClass 
		receiver: aNode
		selector:  binaryNode
		keywordsPositions: binaryNode keywordPositions
		arguments: (Array with: self parseUnaryMessage)! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
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: [ args add:(self parserError: '''|'' expected')]]]
				ifFalse: 
					[(currentToken isSpecial and: [currentToken value = $]]) 
						ifFalse: [ args add:(self parserError: '''|'' expected')]]].
	node
		arguments: args;
		colons: colons.
	^node! !

!RBParser methodsFor: 'private - classes' stamp: ''!
selectorNodeClass
	^ RBSelectorNode! !

!RBParser methodsFor: 'parsing' stamp: ''!
parseMethod
	| methodNode sequenceNode | 
	methodNode := self parseMessagePattern.
	self parsePragmas.
	self addCommentsTo: methodNode.
	
	methodNode body ifNil: [
		sequenceNode := self sequenceNodeClass new.
		methodNode body: sequenceNode ].
	
	self parseStatements: true into: methodNode body untilAnyCloserOf: #().
		
	pragmas ifNotNil: [ methodNode pragmas: pragmas ].
	methodNode source: source.
	self atEnd ifFalse: [ ^ self parseIncompleteExpression: methodNode body ]. 
	methodNode source: source.
	^ methodNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseBinaryMessage
	| node |
	node := self parseUnaryMessage.
	
	[currentToken isLiteralToken ifTrue: [self patchNegativeLiteral].
	currentToken isBinary] 
			whileTrue: [node := self parseBinaryMessageWith: node].
	^node! !

!RBParser methodsFor: 'private' stamp: ''!
patchNegativeLiteral
	"Handle the special negative number case for binary message sends."

	currentToken value isNumber 
		ifFalse: [^self].
	currentToken value <= 0 ifFalse: [^self].
	currentToken value = 0 
		ifTrue: 
			[(source notNil and: 
					[source notEmpty 
						and: [(source at: (currentToken start min: source size)) = $-]]) 
				ifFalse: [^self]].
	nextToken := currentToken.
	currentToken := RBBinarySelectorToken value: #- start: nextToken start.
	nextToken value: nextToken value negated.
	(nextToken isKindOf: RBNumberLiteralToken) 
		ifTrue: 
			[nextToken source: (nextToken source copyFrom: 2 to: nextToken source size)].
	nextToken start: nextToken start + 1! !

!RBParser methodsFor: 'private' stamp: ''!
step
	(currentToken notNil and: [currentToken comments notNil]) 
		ifTrue: [self extractCommentsFrom: currentToken].
	nextToken notNil 
		ifTrue: 
			[currentToken := nextToken.
			nextToken := nil]
		ifFalse: [currentToken := self scannerNext].! !

!RBParser methodsFor: 'error handling' stamp: ''!
getErrorFromClosuresWithMissingOpenings: aCollection
	^((currentToken isSpecial and: ['])}' includes: currentToken value])
				" We make a distinction between the bracket and the other closures because blocks are the only ones that can contain multiple statements. "
				ifTrue: [ currentToken value = $) 
					ifFalse: [ | errorNode | 
								  errorNode := self parseEnglobingError: aCollection copy with: currentToken errorMessage: (currentToken value = $] ifTrue: [ '''['' expected' ]ifFalse: [ '''{'' expected' ]).  
								  aCollection removeAll. errorNode ]
					ifTrue: [  aCollection isEmpty 
							ifFalse: [| errorNode | errorNode := self parseEnglobingError: (OrderedCollection with: aCollection last) with: currentToken errorMessage: ''')'' expected'.  aCollection removeLast. errorNode] 
							ifTrue: [ self parseEnglobingError: aCollection copy with: currentToken errorMessage: ''')'' expected'] ] ] 			
				ifFalse: [ self parserError: 'Unknown input at end' ]).! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
basicParsePragma
	"Current token must be Identifier, Keyword or Binary. Else it throws an error."
	^ currentToken isIdentifier
		ifTrue: [ self parseUnaryPragma ]
		ifFalse: [
			currentToken isKeyword
				ifTrue: [ 	
					currentToken isPrimitiveKeyword
						ifTrue: [ ^ self parsePrimitiveKeywordPragma ].
					self parseKeywordPragma ]
				ifFalse: [ self parseBinaryPragma ] ]! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
addParserError: errorMessage to: aNode
	| errorNode |
	errorNode := self parserError: errorMessage.
	aNode addFaultyNode: errorNode.
	^ aNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parsePrimitiveObject
	| errorNode |
	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 and: ('[({' includes: currentToken value))
		ifTrue: 
			[currentToken value = $[ ifTrue: [^self saveCommentsDuring:[self parseBlock]].
			currentToken value = $( ifTrue: [^self parseParenthesizedExpression].
			currentToken value = ${ ifTrue: [^self parseArray]].
	errorNode := self parserError: 'Variable or expression expected'.
	^errorNode.! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parsePrimitiveKeywordPragma
	| selector positions arguments |
	selector := ''.
	positions := OrderedCollection new: 2.
	arguments := OrderedCollection new: 2.
	[ currentToken isKeyword ] whileTrue: [
		selector := selector, currentToken value.
		positions add: currentToken start.
		self step.
		arguments addLast: self parsePrimitiveLiteral ].
	^ self pragmaNodeClass
		selector: selector asSymbol
		keywordsPositions: positions asIntegerArray
		arguments: arguments.! !

!RBParser methodsFor: 'error handling' stamp: ''!
parserError: aString 
	"Let the errorBlock try to recover from the error. Answer a ParseNode (possibly an RBParseErrorNode) or signal there is new source"
	| errorNode errorMessage errorPosition newSource |
	errorNode := self errorBlock cull: aString cull: self errorPosition cull: self.
	errorNode ifNotNil: [ ^ errorNode ].
	currentToken isError 
		ifTrue: [ errorMessage := currentToken cause. errorPosition := currentToken location ] 
		ifFalse: [errorMessage := aString. errorPosition := currentToken start].
	
	newSource := SyntaxErrorNotification
						inClass: Object
						withCode: source
						doitFlag: false
						errorMessage: errorMessage
						location: errorPosition.
	
	"If the syntax error notification is resumed, then the source was corrected and we have to announce that parsing can restart."					
	ReparseAfterSourceEditing signalWithNewSource: newSource.! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseVariableNode
	"If called without having an Identifier Token : sends an error.
	 Return a variable node with current token value, start position and comments."
	currentToken isIdentifier 
		ifFalse: [ ^ self parserError: 'Variable name expected' ].
	^self parsePrimitiveIdentifier! !

!RBParser methodsFor: 'private - classes' stamp: ''!
methodNodeClass
	^ RBMethodNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseBinaryPattern
	| binaryToken node args |
	currentToken isBinary
		ifFalse: [ 
		^ self methodNodeClass 
			selector: #faulty
			arguments: #()
			body: (self sequenceNodeClass statements: (OrderedCollection with: (self parserError: 'Message pattern expected')))].
	
	binaryToken := currentToken.
	self step.
	args := Array with: self parseVariableNode.
	node := self methodNodeClass
		selector: binaryToken value asSymbol
		keywordsPositions: (Array with: binaryToken start)
		arguments: args.
	node comments: node comments , args last comments.
	args last comments ifNotEmpty: [ args last comments: #() ].
	^node! !

!RBParser methodsFor: 'private' stamp: ''!
addPragma: aPragma
	pragmas ifNil: [ pragmas := OrderedCollection new ].
	pragmas addLast: aPragma! !

!RBParser methodsFor: 'private - classes' stamp: ''!
assignmentNodeClass
	^ RBAssignmentNode! !

!RBParser methodsFor: 'accessing' stamp: ''!
errorBlock: aBlock 
	errorBlock := aBlock.
	scanner notNil ifTrue: [scanner errorBlock: aBlock]! !

!RBParser methodsFor: 'private - classes' stamp: ''!
variableNodeClass
	^ RBVariableNode! !

!RBParser methodsFor: 'private - classes' stamp: ''!
messageNodeClass
	^ RBMessageNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseStatementInto: statementList periodList: periods withAcceptedStatementClosers: aCollectionOfClosers

	"Parse a statement and store it into the statement list.
	Parse statements as valid only if they end in one of the accepted statement closers provided by the enclosing scope.
	E.g., if we are parsing a block, a valid closer is ].
	
	Put any period found at the end of this statement int the periods collection.
	"
	| returnPosition node startOfStatementToken |
	
	"Record the token found at the beginning of the statement.
	If at the end we did not consume it, consume it and mark it as a bad statement for now"
	startOfStatementToken := currentToken.
	
	"If the current statement starts with ^, parse it as a return + an expression.
	Otherwise just parse it as an expression.
	Expressions start with assignments, which have lower precedence"
	(currentToken isSpecial and: [ currentToken value = $^ ])
		ifTrue: [ 
			returnPosition := currentToken start.
			self step.
			node := self returnNodeClass
				        return: returnPosition
				        value: self parseAssignment ]
		ifFalse: [ node := self parseAssignment ].
		
	"If the parsing failed because it did not match anything, consume the current token and continue parsing."
	startOfStatementToken = currentToken ifTrue: [ self step ].

	"At this point we have parsed a full statement."
	"If the statement is followed by closers that do not match the current scope, consume them and produce the corresponding errors wrapping the statement."
	[(')]}' includes: currentToken value)
		and: [ (aCollectionOfClosers includes: currentToken value) not ]]
			whileTrue: [
				self parserError: 'Missing opener for closer: ', currentToken value asString.
				node := RBUnfinishedStatementErrorNode
					content: { node }
					start: node start
					stop: currentToken stop
					errorMessage: 'Missing opener for closer: ', currentToken value asString.
				self step ].
	
	"Next we should have the end of the statement
	  - a dot or
	  - an accepted scope closer e.g., )]} or
	  - or the end of the stream.
	If it is neither, we should mark our statement as unfinished statement."
	(currentToken value ~= $. 
		and: [ (aCollectionOfClosers includes: currentToken value) not
			and: [ currentToken isEOF not ] ] ) ifTrue: [
		self parserError: 'End of statement expected'.
		node := RBUnfinishedStatementErrorNode
			content: { node }
			start: node start
			stop: node stop
			errorMessage: 'End of statement expected'
	].

	"Then consume all dots and comments coming after this well formed statement, if there was any"
	(currentToken isSpecial and: [ currentToken value = $. ]) ifTrue: [ 
		periods add: currentToken start.
		self step.
		self addCommentsTo: node ].

	[ currentToken isSpecial and: [ currentToken value = $. ] ] 
		whileTrue: [ 
			periods add: currentToken start.
			self step ].

	"If the previous node in the statement list is a return node, mark this node as unreachable"
	
	(statementList notEmpty and: [ statementList last isReturn ]) ifTrue: [
		self parserError: 'Unreachable code'.
		node := RBUnreachableStatementErrorNode
			content: { node }
			start: node start
			stop: node stop
			errorMessage: 'Unreachable code' ].

	"Commit the statement to the statements list"
	statementList add: node.! !

!RBParser methodsFor: 'private - classes' stamp: ''!
parseEnglobingError: aCollection with: aToken errorMessage: anErrorMessage
	| firstParse |
	firstParse := self parserError: anErrorMessage.
	^[firstParse isParseError
		ifTrue: [ (self englobingErrorNodeClass error: aToken withNodes: aCollection) value: aToken value asString ]
		ifFalse: [ firstParse ]] on: Error do: [ firstParse ].! !

!RBParser methodsFor: 'parsing' stamp: ''!
parseExpression
	"Parse and return an AST corresponding to the expression passed as argument."
	| node |
	node := self parseStatements: false.
	(self methodNodeClass selector: #noMethod body: node) source: source.	"Make the sequence node have a method node as its parent"
	self atEnd ifFalse: [ ^ self parseIncompleteExpression: node ].
	(node statements isEmpty and: [currentToken comments notNil]) 
			ifTrue: [self extractCommentsFrom: currentToken. self addCommentsTo: node.].
	^node! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseLiteralByteArray
	"Current token is litteral array token #[ which means following tokens are part of the array 
	 until the encounter of the special character ] ."
	| stream startToken stop |
	startToken := currentToken.
	stream := (Array new: 5) writeStream.
	self step.
	[self atEnd or: [currentToken isSpecial and: [currentToken value = $]]]] 
		"Put literal value nodes corresponding to the bytes in the stream."
		whileFalse: [stream nextPut: self parseLiteralByteArrayObject].
	(currentToken isSpecial and: [currentToken value = $]]) 
		ifFalse: [ ^ self parseEnglobingError: stream contents with: startToken errorMessage: ''']'' expected'].
	stop := currentToken stop.
	self step.
	^self literalArrayNodeClass 
		startPosition: startToken start
		contents: stream contents
		stopPosition: stop
		isByteArray: true! !

!RBParser methodsFor: 'private - classes' stamp: ''!
literalValueNodeClass
	^ RBLiteralValueNode! !

!RBParser methodsFor: 'private - classes' stamp: ''!
sequenceNodeClass
	^ RBSequenceNode! !

!RBParser methodsFor: '*Refactoring2-Transformations' stamp: ''!
parsePragmaAndReturn

	self parsePragma.
	^ pragmas first! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseArray
	"Although an array node represents an array, it is not an Array-like object."
	| startToken node |
	startToken := currentToken.
	self step.
	node := self arrayNodeClass new.
	node left: startToken start.
	self parseStatementList: false  into: node untilAnyCloserOf: '}'.
	(currentToken isSpecial and: [currentToken value = $}]) 
		ifFalse: [ ^ self parseEnglobingError: node statements with: startToken errorMessage: 'expected }'].
	node right: currentToken start.
	self step.
	^ node! !

!RBParser methodsFor: 'private - classes' stamp: ''!
blockNodeClass
	^ RBBlockNode! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseLiteralArray
	| literals startToken stop |
	startToken := currentToken.
	literals := (OrderedCollection new: 5).
	self step.
	[self atEnd or: [currentToken isSpecial and: [currentToken value = $)]]] 
		whileFalse: [literals add: self parseLiteralArrayObject].
	stop := currentToken stop.
	(currentToken isSpecial and: [currentToken value = $)]) 
		ifFalse: [ ^ self parseEnglobingError: literals with: startToken errorMessage: ''')'' expected'].
	self step.
	^self literalArrayNodeClass 
		startPosition: startToken start
		contents: literals
		stopPosition: stop
		isByteArray: false! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseParenthesizedExpression
	| node startToken |
	startToken := currentToken.
	self step.
	node := self parseAssignment.
	^(currentToken isSpecial and: [currentToken value = $)])
		ifTrue: 
			[node addParenthesis: (startToken start to: currentToken start).
			self step.
			node]
		ifFalse: [ ^ self parseEnglobingError: (OrderedCollection with: node) with: startToken errorMessage: ''')'' expected']! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseIncompleteExpression: priorStatementsNode
	" This method is used when parsing an expression or a method, if the parsing of the list of statements finishes but there are some tokens left to parse."
	 | statements error |
	statements := priorStatementsNode statements copy.
	" Checks if the current token is a closure to create an englobing error node or a parse error node otherwise. "
	error := self getErrorFromClosuresWithMissingOpenings: statements.
	error parent: priorStatementsNode.
	statements add: error.
	self step.
	priorStatementsNode statements: statements.
	^self atEnd ifTrue: [ priorStatementsNode ] 
				  ifFalse: [ self parseStatementList: false into: priorStatementsNode until: [ false "No extra condition, just until the end of the stream" ].
								self atEnd ifFalse: [ self parseIncompleteExpression: priorStatementsNode ]
											  ifTrue: [ priorStatementsNode ] ]! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseLiterals: aString 
	| stream |
	stream := (Array new: 5) writeStream.
	[self atEnd or: [currentToken isSpecial and: [currentToken value = $)]]] 
		whileFalse: [stream nextPut: self parseLiteralArrayObject].
	self atEnd ifFalse: [ ^ self parserError: 'Unknown input at end'].
	^stream contents collect: [ :each | each value ]! !

!RBParser methodsFor: 'accessing' stamp: ''!
scannerClass
	^RBScanner! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
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 isError ifTrue:[ |errorNode| errorNode :=  self parserError: currentToken cause.
		 ^ errorNode].
	currentToken isLiteralToken ifFalse: [self patchLiteralArrayToken].
	^self parsePrimitiveLiteral! !

!RBParser methodsFor: 'private - parsing' stamp: ''!
parseBinaryPragma
	| binaryToken |
	currentToken isBinary 
		ifFalse: [ ^ self parserError: 'Message pattern expected' ].
	binaryToken := currentToken.
	self step.
	^ self pragmaNodeClass
		selector: binaryToken value asSymbol
		keywordsPositions: (Array with: binaryToken start)
		arguments: (Array with: self parsePragmaLiteral)! !

!RBParser methodsFor: 'private' stamp: ''!
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
				source: currentToken value asString.! !

!RBParser methodsFor: 'private' stamp: ''!
extractCommentsFrom: aToken
 
	aToken comments 
		collect: [:commentToken | RBComment with: commentToken ]
		into: comments! !

!RBParser methodsFor: 'initialization' stamp: ''!
scanner: aScanner 
	scanner := aScanner.
	pragmas := nil.
	aScanner errorBlock: self errorBlock.
	self initialize.
	self step.! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseMethodPattern: aString
	^ (self new
		   errorBlock: [ :error :position | ^ nil ];
		   initializeParserWith: aString;
		   parseMessagePattern) selector! !

!RBParser class methodsFor: 'accessing' stamp: ''!
errorNodeBlock
	^ [ :aString :position :parser| parser parseErrorNode: aString ]! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseRewriteMethod: aString 
	^self parseRewriteMethod: aString onError: nil! !

!RBParser class methodsFor: 'instance creation' stamp: ''!
newFaulty
	
	^ self newWithErrorBlock: self errorNodeBlock! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseRewriteExpression: aString 
	^self parseRewriteExpression: aString onError: nil! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseRewriteMethod: aString onError: aBlock 
	^RBPatternParser parseMethod: aString onError: aBlock! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseFaultyMethod: aString
	"parse aString even if syntactically incorrect. Instead of raising an error, we create an AST with RB RBParseErrorNode"

	^ self parseMethod: aString onError: self errorNodeBlock! !

!RBParser class methodsFor: 'instance creation' stamp: ''!
newWithErrorBlock: aBlock
	
	^ self new
		errorBlock: aBlock;
		yourself! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parsePragma: aString
	^ self new
		  initializeParserWith: aString;
		  parsePragmaAndReturn! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseMethod: aString onError: aBlock 
	| parser |
	parser := self new
		errorBlock: aBlock;
		initializeParserWith: aString.
	^ [ parser parseMethod ]
		on: ReparseAfterSourceEditing
		do: [ :exception | self parseMethod: exception newSource onError: aBlock ]! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseLiterals: aString
	^ self new
		  initializeParserWith: aString;
		  parseLiterals: aString! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseExpression: aString onError: aBlock
	| node |
	node := self new
		        errorBlock: aBlock;
		        initializeParserWith: aString;
		        parseExpression.
	^ (node statements size == 1 and: [ node temporaries isEmpty ])
		  ifTrue: [ node statements first ]
		  ifFalse: [ node ]! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseExpression: aString 
	^self parseExpression: aString onError: nil! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseMethod: aString 
	^self parseMethod: aString onError: nil! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseRewriteExpression: aString onError: aBlock 
	^RBPatternParser parseExpression: aString onError: aBlock! !

!RBParser class methodsFor: 'parsing' stamp: ''!
parseFaultyExpression: aString 
	"parse aString even if syntactically incorrect. Instead of raising an error, we create an AST with RB RBParseErrorNode"
	^self parseExpression: aString onError: self errorNodeBlock! !

!RBParserTest commentStamp: ''!
SUnit tests for RBParser!
!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testSequenceNodeStartAtFirstTokenAfterTheSelector
	"Beginning spaces are trimmed before the start of sequence node."
	| tree |
	"Here, the selector is the implicit #noMethod"
	tree := (self parserClass parseExpression: 'foo koong. ^foo').
	self assert: tree start equals: 1.
	
	"There are 2 spaces before foo."
	tree := (self parserClass parseExpression: '  foo koong. ^foo').
	self assert: tree start equals: 3.
	
	"Here, foo is the method selector so the sequence start at koong."
	tree := (self parserClass parseMethod: 'foo koong. ^foo').
	self assert: tree body start equals: 5.
	
	"There are 2 spaces before foo."
	tree := (self parserClass parseMethod: '  foo koong. ^foo').
	self assert: tree body start equals: 7.! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testErrorNodeForBadParenthesesStartAtLiteralArrayToken
	| tree expr |
	expr := '#( faulty parentheses litteral array node'.
	tree := self parseFaultyExpression: expr.
	
	self assert: tree isParseError.
	self assert: tree errorMessage equals: ''')'' expected'.
	self assert: tree start equals: 1.
	self assert: tree stop equals: expr size.! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testFaultyLiteralRaiseSyntaxError
	#('#"bar"foo' '# foo' '#1' '#12' '#12.3' '# 1' '##1' '#"bar"1') 
		do: [ :expr | 
		self should: [self parserClass parseExpression: expr] raise: SyntaxErrorNotification ]! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testNodesDo
	| size |
	size := 0.
	self treeWithEverything nodesDo: [ :e | size := size + 1 ].
	self assert: size equals: 19! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testUnclosedArrayErrorNodeContainsRightValue
	| tree |
	tree := self parseFaultyExpression: '{ faulty parentheses message node'.
	self assert: tree isParseError.
	self assert: tree formattedCode equals: '{ faulty parentheses message node'! !

!RBParserTest methodsFor: 'private' stamp: ''!
treeWithReallyEverything
	^ self parserClass
		parseMethod:
			'method: arg1 <foo> <foo: 1.2> | temps | temps := #[ 1 2 3 ]. temps := #(true false nil 1 1.2 $a foo #foo ''foo'' #() #(1 2) #[] #[1 2]). { 1 negated. 1 + 2. 1 raisedTo: 2 }. temps foo; foo: self. ^ (temps collect: [:e | | btemps | ((e isNil)) ])'! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testCreationCascadeNodeFromExpression
	self compare: (self parserClass parseExpression: 'cascade firstMessage; secondMessage; lastMessage')
		  to: (RBCascadeNode 
				messages: (OrderedCollection with: (RBMessageNode receiver: (RBVariableNode named: 'cascade') 
																					selector: (RBSelectorNode value: #firstMessage))
													  with: (RBMessageNode receiver: (RBVariableNode named: 'cascade') 
																					selector: (RBSelectorNode value: #secondMessage))
													  with: (RBMessageNode receiver: (RBVariableNode named: 'cascade') 
																					selector: (RBSelectorNode value: #lastMessage)))
				semicolons: (OrderedCollection with: 21 with: 37)).! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testPositions
	| blockNode |
	blockNode := self parserClass parseExpression: '[:a :b | ]'.
	self assert: blockNode left equals: 1.
	self assert: blockNode right equals: 10.
	self assert: blockNode bar equals: 8.
	self assert: blockNode sourceInterval equals: (1 to: 10).
	self assert: blockNode size equals: 1.	"test dummy collection protocol"
	blockNode printString.	"coverage"
	self deny: (blockNode isLast: (RBVariableNode named: 'b')).! !

!RBParserTest methodsFor: 'tests - comparing' stamp: ''!
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: ((self parserClass parseMethod: each first) equalTo: (self parserClass parseMethod: (each at: 2)) exceptForVariables: #('c'))
				identicalTo: each last ]! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testPragmaImplicitLiteralArrayIsInvalid
	| pragmaWithExpressionAsArgument pragmaWithLiteralArrayAsArgument pragmaWithStringAsArgument |
	"a pragma with arguments that look like code
	(3+4) were implicitly converted to a literal array
	#(3+4), this is not allowed anymore"
	pragmaWithExpressionAsArgument := 'foo 
	<func: (3+4) res: 7>
	^ self'.
	self should:[self parserClass parseMethod: pragmaWithExpressionAsArgument] raise: SyntaxErrorNotification.

	"an explicit literal array is allowed"
	pragmaWithLiteralArrayAsArgument := 'foo 
	<func: #(3+4) res: 7>
	^ self'.
	"Should work"
	self shouldnt: [self parserClass parseMethod: pragmaWithLiteralArrayAsArgument] raise: SyntaxErrorNotification.

	"and of course a string literal"
	pragmaWithStringAsArgument := 'foo 
	<func: ''(3+4)'' res: 7>
	^ self'.
	"should work"
	self shouldnt: [self parserClass parseMethod: pragmaWithStringAsArgument] raise: SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testNegativeNumberError
	self should: [ self parserClass parseExpression: '- 2' ] raise: SyntaxErrorNotification! !

!RBParserTest methodsFor: 'accessing' stamp: ''!
compare: anObject to: anotherObject 
	self assert: anObject hash equals: anotherObject hash.
	self assert: anObject equals: anotherObject! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
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: 'to be reworked' stamp: ''!
testQueryingPrimitiveErrorVar
	| tree |
	tree := self parserClass 
				parseMethod: 'clone
	"Answer a shallow copy of the receiver."
	<primitive: 148 error: ec>
	| copy |
	ec == #''insufficient object memory'' ifFalse:
		[|nothing| nothing := nil.
		^ noting].
   copy := nil.
	^ copy'.
	self assert: (tree body whoDefines:'copy') equals: tree body.
	self assert: (tree blockNodes first body whoDefines: 'nothing') equals: tree blockNodes first body.
	self assert: (tree body whoDefines: 'ec') equals: tree.! !

!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testMethodNodeStartAtOne
	| tree |
	"When there are multiple statements, the node returned is the Sequence node (child of the method node)."
	tree := (self parserClass parseExpression: 'foo koong. ^foo').
	self assert: tree parent start equals: 1.
	
	tree := (self parserClass parseExpression: '  foo koong. ^foo').
	self assert: tree parent start equals: 1.
	
	"parseMethod always return a method node."
	tree := (self parserClass parseMethod: 'foo koong. ^foo').
	self assert: tree start equals: 1.
	
	tree := (self parserClass parseMethod: '  foo koong. ^foo').
	self assert: tree start equals: 1.! !

!RBParserTest methodsFor: 'accessing' stamp: ''!
exampleClasses
	<sampleInstance>
	^ Array
		with: self parserClass
		with: RBScanner
		with: RBProgramNode
		with: RBComment! !

!RBParserTest methodsFor: 'tests' stamp: ''!
parseTreeSearcher
	^ RBParseTreeSearcher new! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testCreationLiteralValueNodeWithExpression
	self compare: (self parserClass parseExpression: '#literal')
		  to: (RBLiteralValueNode
				value: #literal
				start: 1
				stop: 8).! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testGeneralMethodIntervalsCascade
	"This tests that all types of nodes in a method are well made."
	| tree str |
	tree := (self parseMethod: 'Selector <pragmanode> "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node').
	str := 'cascade node; cascaded'.
	self assert: ((tree body statements at: 6) start) equals: (tree source findString: str).
	self assert: ((tree body statements at: 6) stop) equals: ((tree source findString: str) + (str size - 1)).! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testMessageWithFaultySelectorIsFaulty
	| tree |
	tree := self parseFaultyExpression: 'message 2'.
	self assert: tree isFaulty.! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testPragmaPrimitiveError
	| tree  pragma |
	tree := self parserClass 
				parseMethod: 'veryBasicAt: index 
	<primitive: #dooo module: #bar error: code>
	^ code'.
	
	self assert: tree pragmas size equals: 1.
	
	pragma := tree pragmas first.
	self assert: pragma selector equals: #primitive:module:error:! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testCreationSelfNodeWithExpression
	self compare: (self parserClass parseExpression: 'self')
		  to: RBVariableNode selfNode! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testGeneralMethodIntervalsArray
	"This tests that all types of nodes in a method are well made."
	| tree str |
	tree := (self parseMethod: 'Selector <pragmanode> "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node').
	str := '{array node}'.
	self assert: ((tree body statements at: 4) start) equals: (tree source findString: str).
	self assert: ((tree body statements at: 4) stop) equals: ((tree source findString: str) + (str size - 1)).! !

!RBParserTest methodsFor: 'tests - parsing faulty' stamp: ''!
testParseFaultyMethodExpressionHasErrorNodeAsFinal
	| node strangeExpression |
	
	strangeExpression := 'method: asd  ^ asd. n'.
	node := self parseFaultyMethod: strangeExpression.

	self assert: node isMethod.
	self assert: node isFaulty.
	self assert: node statements size equals: 2.
	self assert: node statements last isFaulty! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testGeneralMethodIntervalsBlock
	"This tests that all types of nodes in a method are well made."
	| tree str |
	tree := (self parseMethod: 'Selector <pragmanode> "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node').
	str := '[block node]'.
	self assert: ((tree body statements at: 5) start) equals: (tree source findString: str).
	self assert: ((tree body statements at: 5) stop) equals: ((tree source findString: str) + (str size - 1)).! !

!RBParserTest methodsFor: 'tests - Pragma' stamp: ''!
testParsingPragmaRecogniseArguments
	"Tests that the pragmas are correctly interpreted.
	 1. The string to be parsed.
	 2. The selector in parsed pragma.
	 3. The selector arguments."
	| tree node |
	#(('foo <foo>' 				#foo ()) 
	('foo <foo: 1>' 				#foo: (1)) 
	('foo <foo: 1.2>' 			#foo: (1.2)) 
	('foo <foo: -3>' 			#foo: (-3)) 
	('foo <foo: #a>' 			#foo: (a)) 
	('foo <foo: #< >' 			#foo: (<)) 
	('foo <foo: #> >' 			#foo: (>)) 
	('foo <foo: $a>' 			#foo: ($a)) 
	('foo <foo: ''bar''>' 		#foo: ('bar')) 
	('foo <foo: true>' 			#foo: (true)) 
	('foo <foo: false>' 			#foo: (false)) 
	('foo <foo: nil>' 			#foo: (nil)) 
	('foo <foo: #(1 2)>' 		#foo: ((1 2)))
	('foo <foo: 1 bar: 2>' 		#foo:bar: (1 2))
	('foo |t| <foo: 1.2>' 		#foo: (1.2))
	('foo |t| <foo: 1 bar: 2>' #foo:bar: (1 2))
	) do: [ :each |
		tree := self parserClass parseMethod: each first.
		self assert: tree pragmas size equals: 1.
		node := tree pragmas first.
		1 to: node arguments size do: [ :i |
			self assert: (node arguments at: i) value equals: (each last at: i) ].]! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testScopesEnclosingMatchingLiterals
	| tree |

	tree := self parserClass parseMethod: 'tmp [ $] ]'.
	self assert: tree statements first isBlock.

	tree := self parserClass parseMethod: 'tmp ($))'.
	self assert: tree statements first isLiteralNode.
	
	tree := self parserClass parseMethod: 'tmp #( $) )'.
	self assert: tree statements first isLiteralArray.
	
	tree := self parserClass parseMethod: 'tmp { $} }'.
	self assert: tree statements first isDynamicArray.! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testNodeWithMissingArgumentHasSameSourceAsOriginal
	| tree source errorNode |
	source := '1+'.
	tree := self parseFaultyExpression: source.
	errorNode := tree arguments first.
	
	self assert: errorNode value isEmpty.
	self assert: errorNode sourceInterval isEmpty! !

!RBParserTest methodsFor: 'tests - comparing' stamp: ''!
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: 'error testing' stamp: ''!
testUnclosedParenthesesErrorNodeContainsRightValue
	| tree |
	tree := self parseFaultyExpression: '( faulty parentheses message node'.
	self assert: tree isEnglobingError.
	self assert: tree formattedCode equals: '( faulty parentheses message node'! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
testPrimitives
	self assert: (Object parseTreeFor: #basicAt:) isPrimitive.
	#(('foo ^true' false ) ('foo <some: #tag> ^true' false ) (' foo <some: #tag> <primitive: 123> ^true' true ) ) 
			do: [:each | self assert: (self parserClass parseMethod: each first) isPrimitive equals: each last]! !

!RBParserTest methodsFor: 'tests - Literal' stamp: ''!
testLiteralIntevals
	| tree |
	tree := self parserClass parseExpression: '#(#a b #( c ))'.
	self assert: tree contents first start equals: 3.
	self assert: tree contents first stop equals: 4.
	self assert: tree contents last contents first start equals: 11! !

!RBParserTest methodsFor: 'garbage tests' stamp: ''!
testGarbageTemporaryVariableHasMissingClosure
	| tree |
	tree := self parseFaultyExpression: '| temp'.
	self assert: tree isFaulty.
	self assert: tree errorMessage equals: '''|'' expected'.! !

!RBParserTest methodsFor: 'tests - matching' stamp: ''!
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: 'private' stamp: ''!
parseError: each
	
	self parseError: each first onError: [ :string :pos | ^ self assert: pos equals: each last ].
	self assert: false description: 'Parser didn''t fail'! !

!RBParserTest methodsFor: 'tests - Array' stamp: ''!
testArrayNodesContainRightAmountOfStatementsAndPeriods
	"1. The array to be parsed into an array node.
	 2. The number of statements in the array node.
	 3. The number of periods in the array node."
	| 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 := self parserClass parseExpression: each first.
			self assert: tree statements size equals: each second.
			self assert: tree periods size equals: each last. ]! !

!RBParserTest methodsFor: 'tests - parsing faulty' stamp: ''!
testParseUnfinishedBlockWithFaultyBody
	| node unfinishedBlockExp missingArgExp unfinishedBlockAndMissingArgExp validBlock unfinishedBlockWithReturnExp|
	"Parsing a block as a faulty expression, where the block body is faulty and there is a missing closing bracket,
the whole expression is replaced by a single RBParseErrorNode, this makes it difficult for the highlighter to 
indicate the invalid expression."
	unfinishedBlockExp := '[:x | x missingArg: 3. '.
	missingArgExp := '[:x | x missingArg: . ]'.
	unfinishedBlockAndMissingArgExp := '[:x | x missingArg: . '.
	unfinishedBlockWithReturnExp := '[^ '.
	validBlock := '[:x | x missingArg: 3 ]. '.
	
	{unfinishedBlockExp. unfinishedBlockAndMissingArgExp. unfinishedBlockWithReturnExp}
		do: [ :faultyExpression | 
			node := self parseFaultyExpression: faultyExpression.
			self assert: node isEnglobingError.
			self assert: node isBlockError ].
		
	node := self parseFaultyExpression: missingArgExp.
	self assert: node isBlock.
	self assert: node isFaulty.
	self assert: node body isFaulty.
		
	node := self parseFaultyExpression: validBlock.
	self assert: node isBlock.
	self deny: node isFaulty.
	self deny: node body isFaulty! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testIsA
	| nodes types |
	nodes := Bag new.
	types := Set new.
	#(#(#isAssignment 1) #(#isBlock 1) #(#isCascade 1) #(#isLiteralNode 2) #(#isMessage 3) #(#isMethod 1) #(#isReturn 1) #(#isSequence 2) #(#isValue 15) #(#isVariable 7) #(#isUsed 10) #(#isDirectlyUsed 9) #(#hasParentheses 1) #(#isBinary 0) #(#isPrimitive 0) #(#isImmediateNode 10) #(#isWrite 1) #(#isRead 3))
		do: [ :each | 
			each last timesRepeat: [ nodes add: each first ].
			types add: each first ].
	self treeWithEverything nodesDo: [ :each | types do: [ :sel | ((each respondsTo: sel) and: [ each perform: sel ]) ifTrue: [ nodes remove: sel ] ] ].
	self assertEmpty: nodes! !

!RBParserTest methodsFor: 'foreign use of test' stamp: ''!
testString
	self assert: (self parserClass parseMethod: 'selector ^ ''<''') isMethod.
	self assert: (self parserClass parseMethod: 'selector ^ ''<'', self') isMethod.
	self assert: (self parserClass parseMethod: 'selector ''=''') isMethod.
	self assert: (self parserClass parseMethod: 'selector '':=''') isMethod.
	self assert: (self parserClass parseMethod: 'selector ''<''') isMethod.
	self assert: (self parserClass parseMethod: 'selector ''>''') isMethod.
	self assert: (self parserClass parseMethod: 'selector ^ ''<>''') isMethod.! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testUnclosedTemporariesErrorNodeContainsRightValue
	| tree |
	tree := self parseFaultyExpression: '| faulty temporaries'.
	self assert: tree isEnglobingError.
	self assert: tree formattedCode equals: '| faulty temporaries'! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testArrayNodesArentArrays
"Although an RBArrayNode represents an array, it is not an Array-like object.
Therefore it shouldn't return true for message #isArray (like an instance of a real
array would"
	| arrayNode nonArrayNode |
	arrayNode := self parserClass parseExpression: '{ 1 . 2 . 3}'.
				
	nonArrayNode := self parserClass parseExpression: 'a := 3'.
				
	self deny: arrayNode isArray.
	self assert: arrayNode isDynamicArray.
	self deny: nonArrayNode isDynamicArray! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testErrorNodeForBadParenthesesOfLiteralArrayIsEnglobingNode
	| tree expr |
	expr := '#( faulty parentheses litteral array node'.
	tree := self parseFaultyExpression: expr.
	self assert: tree isEnglobingError.! !

!RBParserTest methodsFor: 'garbage tests' stamp: ''!
testGarbageForgottenReceiver
	"Test made in sight of implementing the search of previous litterals when encountering an unknown 
	 variable in case it is, in fact, a selector. This works for cascade (forgotten ;) or missing 
	 receiver like self ..."
	self should: [self parserClass parseExpression: '|temp | temp := 1 + 2. + 3'] raise: SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testErrorNodeForBadParenthesesIsEnglobing
	| tree |
	tree := self parseFaultyExpression: '( faulty parentheses message node'.
	self assert: tree isEnglobingError.! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testCreationProtocol
	| messageNode |
	self compare: (RBMessageNode 
				receiver: (RBVariableNode selfNode)
				selector: (RBSelectorNode value: #+)
				arguments: (Array with: (RBLiteralNode value: 0)))
		to: (self parserClass parseExpression: 'self + 0').
	messageNode := RBMessageNode receiver: (RBVariableNode selfNode) selector: (RBSelectorNode value: #foo).
	self compare: (RBMethodNode selector: #bar
				body: (RBSequenceNode statements: (OrderedCollection 
								with: (RBCascadeNode messages: (OrderedCollection with: messageNode with: messageNode)))))
		to: (self parserClass parseMethod: 'bar self foo; foo')! !

!RBParserTest methodsFor: 'tests - Pragma' stamp: ''!
testParsingPragmaRecogniseSelector
	"Tests that the pragmas are correctly interpreted.
	 1. The string to be parsed.
	 2. The selector in parsed pragma.
	 3. The selector arguments."
	| tree node |
	#(('foo <foo>' 				#foo ()) 
	('foo <foo: 1>' 				#foo: (1)) 
	('foo <foo: 1.2>' 			#foo: (1.2)) 
	('foo <foo: -3>' 			#foo: (-3)) 
	('foo <foo: #a>' 			#foo: (a)) 
	('foo <foo: #< >' 			#foo: (<)) 
	('foo <foo: #> >' 			#foo: (>)) 
	('foo <foo: $a>' 			#foo: ($a)) 
	('foo <foo: ''bar''>' 		#foo: ('bar')) 
	('foo <foo: true>' 			#foo: (true)) 
	('foo <foo: false>' 			#foo: (false)) 
	('foo <foo: nil>' 			#foo: (nil)) 
	('foo <foo: #(1 2)>' 		#foo: ((1 2)))
	('foo <foo: 1 bar: 2>' 		#foo:bar: (1 2))
	('foo |t| <foo: 1.2>' 		#foo: (1.2))
	('foo |t| <foo: 1 bar: 2>' #foo:bar: (1 2))
	) do: [ :each |
		tree := self parserClass parseMethod: each first.
		node := tree pragmas first.
		self assert: node selector equals: each second.]! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testInvalidPragmaPosition
	#(
	'foo self. <foo: $a>'
	'<foo: $a>'
	'foo [:x | <foo: $a> ] value'
	'foo ^ <foo: $a>'
	) 
	do: [ :each | self should: [ self parserClass parseMethod: each ] raise: SyntaxErrorNotification ]! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testParseMethodWhichEndsWithUncompleteStringWithEscapedMarkAtTheEnd
	| node strangeMethod body statement message errorNode |
	strangeMethod := '
	selector  
		|temp| 
		temp := ''this is right'', ''wrong'''''.
	node := self parseFaultyMethod: strangeMethod.

	self assert: node isMethod.
	self assert: node isFaulty.
	self assertEmpty: node arguments.

	body := node body.
	self assert: body isSequence.
	self assert: body isFaulty.
	self assert: (body temporaries includes: (RBVariableNode named: 'temp')).

	statement := body statements first.
	self assert: statement isFaulty.
	self assert: statement isAssignment.

	message := statement value.
	self assert: message isFaulty.
	self assert: message arguments size equals: 1.

	errorNode := message arguments at: 1.
	self assert: errorNode isFaulty.
	self
		assert: errorNode value
		equals: 'wrong'''.
	self assert: errorNode errorMessage equals: 'Unmatched '' in string literal.' translated! !

!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testGeneralMethodIntervalsComment
	"This tests that comment nodes inside a method node correspond the right interval in the source code."
	| tree str commentNode position |
	tree := (self parseMethod: 'Selector <pragmanode> "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node').
	
	str := '"comment node"'.
	commentNode := tree comments at: 1.
	position := tree source findString: str.
	
	self assert: commentNode start equals: position.
	self assert: commentNode stop equals: position + (str size - 1).! !

!RBParserTest methodsFor: 'tests - parsing faulty' stamp: ''!
testParseFaultyMethodExpresionHasErrorNodeAsFinal
	| node strangeExpression |
	
	strangeExpression := 'method: asd  ^ asd. n'.
	node := self parseFaultyMethod: strangeExpression.

	self assert: node isMethod.
	self assert: node isFaulty.
	self assert: node statements size equals: 2.
	self assert: node statements last isFaulty! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testIntervals
	| tree |
	tree := self treeWithReallyEverything.
	tree nodesDo: 
			[:each | 
			(each parent isNil or: [each parent isCascade not and: [ each parent isLiteralNode not]]) 
				ifTrue: 
					[| newNode source |
					source := tree source copyFrom: each start to: each stop.
					each isPragma ifFalse: [
						newNode := each isMethod 
								ifTrue: [self parserClass parseMethod: source]
								ifFalse: [self parserClass parseExpression: source].
						self compare: each to: newNode]]]! !

!RBParserTest methodsFor: 'private' stamp: ''!
parseError: expression onError: aBlock
	^ self parserClass parseExpression: expression onError: aBlock! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testGeneralMethodIntervalsReturn
	"This tests that all types of nodes in a method are well made."
	| tree str |
	tree := (self parseMethod: 'Selector <pragmanode> "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node').
	str := '^return node'.
	self assert: ((tree body statements at: 8) start) equals: (tree source findString: str).
	self assert: ((tree body statements at: 8) stop) equals: ((tree source findString: str) + (str size - 1)).! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testUnclosedBracketErrorNodeContainsRightValue
	| tree |
	tree := self parseFaultyExpression: '[ faulty parentheses message node'.
	self assert: tree isEnglobingError.
	self assert: tree formattedCode equals: '[ faulty parentheses message node'! !

!RBParserTest methodsFor: 'tests - parsing faulty' stamp: ''!
testParseFaultyMethodMessagePattern
	| node faultyMessagePattern |
	faultyMessagePattern := '1'.
	node := self parseFaultyMethod: faultyMessagePattern.
	self assert: node isFaulty! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testUnfinishedStatementWithLeadingBracketRaisesError

	self should: [(self parserClass parseExpression: '[]]')] 
		  raise: SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'tests' stamp: ''!
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 - Intervals' stamp: ''!
testGeneralBlockIntervalsAssignement
	"This tests that assignement nodes inside a block node correspond the right interval in the source code."
	| tree str assignementNode position |
	tree := (self parseExpression: '["comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node]').
	
	str := 'assignement := node'.
	assignementNode := tree body statements at: 7.
	position := tree source findString: str.
	
	self assert: assignementNode start equals: position.
	self assert: assignementNode stop equals: position + (str size - 1).! !

!RBParserTest methodsFor: 'tests - Pragma' stamp: ''!
testIdentificationOfPrimitiveMethods
	"Verify if there is the pragma primitive in the parsed method."
	"The string is the element to be parsed.
	 The boolean is the expected result. true : is primitive
													false : is not primitive."
	#(('foo ^true' false ) 
	  ('foo <some: #tag> ^true' false ) 
	  (' foo <some: #tag> <primitive: 123> ^self' true ) 
	  ('foo primitive:= 123. ^self' false)) 
	do: [:each | self assert: (self parserClass parseMethod: each first) isPrimitive equals: each last]! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testUnfinishedStatementWithLeadingParenthesisRaisesError

	self should: [(self parserClass parseExpression: '[])')] 
		  raise: SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
testBinarySelectors
	"ANSI Smalltalk Standard Draft, page 32:
		binaryCharacter ::=
			'!!' | '%' | '&' | '*' | '+' | ','' | '/' | '<' | '=' | '>' | '?' | '@' | '\' | '~' | '|' | '-'
		binarySelector ::= binaryCharacter+"

	| binaryCharacters selectorStrings |
	"Create a collection of strings to parse.
	 The collection is made of every possible string sized from 1 to 3 selectors."
	binaryCharacters := '!!%&*+,/<=>?@\~-'.
	selectorStrings := OrderedCollection new.
	binaryCharacters do: [:first |
		selectorStrings addLast: (String with: first).
		binaryCharacters do: [:second |
			selectorStrings addLast: (String with: first with: second).
			binaryCharacters do: [:third |
				selectorStrings addLast: (String with: first with: second with: third)]]].

	""
	selectorStrings do: [:each | | methodNode messageNode |
		methodNode := self parseMethod: each, 'anObject
	^self',each,'anObject'.
		self assert: methodNode selector equals: each asSymbol.
		self assert: methodNode argumentNames asArray equals: #(anObject).
		self assert: methodNode statements size equals: 1.
	
		messageNode := methodNode statements first value.
		self assert: messageNode isMessage.
		self assert: messageNode receiver name equals: #self.
		self assert: messageNode selector equals: each asSymbol.
		self assert: messageNode arguments size equals: 1.
		self assert: messageNode arguments first isValue.
		self assert: messageNode arguments first name equals: #anObject].! !

!RBParserTest methodsFor: 'tests - parsing faulty' stamp: ''!
testParseFaultyMethod
	| node strangeExpressions |
	
	strangeExpressions := OrderedCollection new .
	strangeExpressions 
		add: 'method: asd   self ,';
		add: 'method: asd   self a:'; "message without needed argument"
		add: 'method: asd   []]'; 
		add: 'method: asd  [  ] ,';"binary message without second argument"
		add: 'method:  ^^'; "returning twice"
		add: 'method: asd  ['; "opening a block"
		add: 'method: asd  ^ asd. n'; "invalid expresion after return"
		add: 'method: asd  ^ {'; "Only Open a literal array"
		add: 'selector '''; 
		add: 'selector ''part1''''part2'; "string with escaped ' does not end"
		add: 'selector #^';
		add: 'selector ¿';
		add: ':nl'.


	strangeExpressions do: [ :exp | 
			node := self parseFaultyMethod: exp.
			self assert: node isMethod.
			self assert: node isFaulty
	].! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
testSymbolLiteral
	| tree |
	#(
	'#<' #<
	'#>' #>
	'#<>' #<>
	'##foo' #foo 
	'###foo' #foo 
	'#foo:' #foo:
	'#foo::' #'foo::'
	'#foo::bar' #'foo::bar'
	'#foo::bar:' #'foo::bar:'
	'#foo::bar::' #'foo::bar::') pairsDo: [ :parseString :expectedResult |
		tree := self parserClass parseExpression: parseString.
		self assert: tree value equals: expectedResult.		
		self assert: tree start equals: 1.
		self assert: tree stop equals: parseString size ].
	
	#(
	('#"bar"foo' #foo)
	('# foo' #foo)
	('#1' 1)
	('#12' 12)
	('#12.3' 12.3)
	('# 1' 1)
	('##1' 1)
	('#"bar"1' 1)) do: [ :pair | 
		self should: [self parserClass parseExpression: pair first] raise: SyntaxErrorNotification ]! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testGeneralMethodIntervalsMessage
	"This tests that all types of nodes in a method are well made."
	| tree str |
	tree := (self parseMethod: 'Selector <pragmanode> "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node').
	str := 'message node'.
	self assert: ((tree body statements at: 1) start) equals: (tree source findString: str).
	self assert: ((tree body statements at: 1) stop) equals: ((tree source findString: str) + (str size - 1)).! !

!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testSequenceNodeEndAtTheEndOfTheString
	| tree |

	tree := (self parserClass parseExpression: 'foo kung foo. 1+2+3. #''alabama''.').
	self assert: tree source equals: 'foo kung foo. 1+2+3. #''alabama''.'.
	self assert: tree stop equals: tree parent source size.
	
	tree := (self parserClass parseMethod: 'foo kung foo. 1+2+3. #''alabama''.').
	self assert: tree source equals: 'foo kung foo. 1+2+3. #''alabama''.'.
	self assert: tree body stop equals: tree source size.! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testGeneralMethodIntervalsLiteralValue
	"This tests that all types of nodes in a method are well made."
	| tree str |
	tree := (self parseMethod: 'Selector <pragmanode> "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node').
	str := '#literalNode'.
	self assert: ((tree body statements at: 2) start) equals: (tree source findString: str).
	self assert: ((tree body statements at: 2) stop) equals: ((tree source findString: str) + (str size - 1)).! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
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 := self parserClass parseExpression: each first.
		self assert: tree statements size equals: each second.
		self assert: tree periods size equals: each last ]! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
testPragmas
	| tree node |
	#(('foo <foo>' 				#foo ()) 
	('foo <foo: 1>' 				#foo: (1)) 
	('foo <foo: 1.2>' 			#foo: (1.2)) 
	('foo <foo: -3>' 			#foo: (-3)) 
	('foo <foo: #a>' 			#foo: (a)) 
	('foo <foo: #< >' 			#foo: (<)) 
	('foo <foo: #> >' 			#foo: (>)) 
	('foo <foo: $a>' 			#foo: ($a)) 
	('foo <foo: ''bar''>' 		#foo: ('bar')) 
	('foo <foo: true>' 			#foo: (true)) 
	('foo <foo: false>' 			#foo: (false)) 
	('foo <foo: nil>' 			#foo: (nil)) 
	('foo <foo: #(1 2)>' 		#foo: ((1 2)))
	('foo <foo: 1 bar: 2>' 		#foo:bar: (1 2))
	('foo |t| <foo: 1.2>' 		#foo: (1.2))
	('foo |t| <foo: 1 bar: 2>' #foo:bar: (1 2))
	) do: [ :each |
		tree := self parserClass parseMethod: each first.
		self assert: tree pragmas size equals: 1.
		node := tree pragmas first.
		self assert: node selector equals: each second.
		1 to: node arguments size do: [ :i |
			self assert: (node arguments at: i) value equals: (each last at: i) ].
		self assert: (each first at: node start) equals: $<.
		self assert: (each first at: node stop) equals: $> ].
	
	self assert: (self parserClass parseMethod: 'selector <a>') isMethod.
	self assert: (self parserClass parseMethod: '
	selector 
		"comment1" 
		|temp| 
		"comment2" 
		<a> 
		#<.
		^1') isMethod.
	self should: [self parserClass parseMethod: '
	selector 
		"comment1" 
		|temp| 
		"comment2" 
		<a> 
		<.
		^1'] raise: SyntaxErrorNotification! !

!RBParserTest methodsFor: 'garbage tests' stamp: ''!
testUnclosedParenthesesRaiseSyntaxError
	"Should propose a closing parenthese before the end of the statement. Should also offer possibility to quickly erase it."
	self should: [self parserClass parseExpression: '(temp := 1 + 3 .'] raise: SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testMethodNodeEndAtTheEndOfTheString
	| tree |
	tree := (self parserClass parseExpression: 'foo kung foo. 1+2+3. #''alabama''.  ').
	self assert: tree parent source equals: 'foo kung foo. 1+2+3. #''alabama''.  '.
	self assert: tree parent stop equals: tree parent sourceCode size.
	
	tree := (self parserClass parseMethod: 'foo kung foo. 1+2+3. #''alabama''.  ').
	self assert: tree source equals: 'foo kung foo. 1+2+3. #''alabama''.  '.
	self assert: tree stop equals: tree newSource size.! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testGeneralMethodIntervalsAssignement
	"This tests that all types of nodes in a method are well made."
	| tree str |
	tree := (self parseMethod: 'Selector <pragmanode> "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node').
	str := 'assignement := node'.
	self assert: ((tree body statements at: 7) start) equals: (tree source findString: str).
	self assert: ((tree body statements at: 7) stop) equals: ((tree source findString: str) + (str size - 1)).! !

!RBParserTest methodsFor: 'tests - Array' stamp: ''!
testParsingArrayGivesArrayNode
	| tree |
	#('{}' '{foo}' '{foo. bar.}')
	 do: [ :each |
		tree := self parserClass parseExpression: each .
		self assert: tree isDynamicArray.]! !

!RBParserTest methodsFor: 'tests - Literal' stamp: ''!
testSymbolLiteralSuccessfullyCreateLiteralNode
	"Test if the parsing of the strings gives a literal node corresponding to its' pair."
	| tree |
	#(
	'#<' #<
	'#>' #>
	'#<>' #<>
	'##foo' #foo 
	'###foo' #foo 
	'#foo:' #foo:
	'#foo::' #'foo::'
	'#foo::bar' #'foo::bar'
	'#foo::bar:' #'foo::bar:'
	'#foo::bar::' #'foo::bar::') pairsDo: [ :parseString :expectedResult |
		tree := self parserClass parseExpression: parseString.
		self assert: tree isLiteralNode.
		self assert: tree value equals: expectedResult.		
		self assert: tree start equals: 1.
		self assert: tree stop equals: parseString size ].! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testParseMethodWithErrorTokenIsWellFormed
	| node strangeMethod body statement message errorNode |
	strangeMethod := '
	selector  
		|temp| 
		temp := ''this is right'', ''wrong because no end.
		^temp'.
	node := self parseFaultyMethod: strangeMethod.

	self assert: node isMethod.
	self assert: node isFaulty.
	self assertEmpty: node arguments.

	body := node body.
	self assert: body isSequence.
	self assert: body isFaulty.
	self assert: (body temporaries includes: (RBVariableNode named: 'temp')).

	statement := body statements first.
	self assert: statement isFaulty.
	self assert: statement isAssignment.

	message := statement value.
	self assert: message isFaulty.
	self assert: message arguments size equals: 1.

	errorNode := message arguments at: 1.
	self assert: errorNode isFaulty.
	self
		assert: errorNode value
		equals:
			'wrong because no end.
		^temp'.
	self assert: errorNode errorMessage equals: 'Unmatched '' in string literal.' translated! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testQuerying
	| tree aNode arg1Node bNode |
	tree := self parserClass
		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))).
	tree doSemanticAnalysis.
	self assert: (tree selfMessages collect: [ :each | each value ]) asSortedCollection asArray equals: #(#bar #foa1 #foo:).
	self assert: (tree superMessages collect: [ :each | each value ]) asSortedCollection asArray equals: #(#foo:foo:foo: #test:).
	aNode := tree whichNodeIsContainedBy: (112 to: 112).
	self assert: aNode name equals: 'a'.
	bNode := tree whichNodeIsContainedBy: (119 to: 119).
	self assert: bNode name equals: 'b'.
	arg1Node := tree whichNodeIsContainedBy: (102 to: 105).
	self assert: arg1Node name equals: 'arg1'.
	self assert: (arg1Node statementNode isMessage and: [ arg1Node statementNode selector value = #+ ]).
	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 value equals: #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 equals: #('arg1').
	self assert: aNode temporaryVariables asSortedCollection asArray equals: #('b').
	self assert: tree allDefinedVariables asSortedCollection asArray equals: #('a' 'arg1' 'b').
	self assert: tree allArgumentVariables asSortedCollection asArray equals: #('a' 'arg1').
	self assert: tree allTemporaryVariables asSortedCollection asArray equals: #('b')! !

!RBParserTest methodsFor: 'garbage tests' stamp: ''!
testAssignToMessageRaisesSyntaxError
	"Raising a syntax exception when trying to do an assignement on a message."
	self should: [self parserClass parseExpression: 'receiver selector := 1 + 2'] raise: SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testErrorNodeForBadParenthesesHasRightMessage
	| tree |
	tree := self parseFaultyExpression: '( faulty parentheses message node'.
	self assert: tree isParseError.
	self assert: tree errorMessage equals: ''')'' expected'.! !

!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testGeneralBlockIntervalsBlock
	"This tests that block nodes inside a block node correspond the right interval in the source code."
	| tree str blockNode position |
	tree := (self parseExpression: '["comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node]').
	
	str := '[block node]'.
	blockNode := tree body statements at: 5.
	position := tree source findString: str.
	
	self assert: blockNode start equals: position.
	self assert: blockNode stop equals: position + (str size - 1).! !

!RBParserTest methodsFor: 'tests - Parentage' stamp: ''!
testParentOfSequenceNodeIsMethodNode
	| tree |
	tree := self parseMethod: 'Selector ^return something.'.
	self assert: tree body isSequence.
	self assert: tree body parent equals: tree.! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testGeneralBlockIntervalsArray
	"This tests that all types of nodes in a method are well made."
	| tree str |
	tree := (self parseExpression: '["comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node]').
	str := '{array node}'.
	self assert: ((tree body statements at: 4) start) equals: (tree source findString: str).
	self assert: ((tree body statements at: 4) stop) equals: ((tree source findString: str) + (str size - 1)).! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testMethodPatterns
	#(#('+ a ^self + a' #+) #('foo ^self foo' #foo) #('foo: a bar: b ^a + b' #foo:bar:))
		do: [ :each | self assert: (self parserClass parseMethodPattern: each first) identicalTo: each last ]! !

!RBParserTest methodsFor: 'tests - comparing' stamp: ''!
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: 'error testing' stamp: ''!
testPragmaConstantLiteralArgument
	| primitiveDeclartion validPragma invalidPragma |
	"primitive declarations with variable (code) are allowed"
	primitiveDeclartion := 'foo <primitive: #dooo module: #bar error: code> ^ nil'.
	"#Point as argument is allowed"
	validPragma := 'foo <return: #Point> ^ 0@0'.
	"Point as argument is not allowed"
	invalidPragma := 'foo <return: Point> ^ 0@0'.
	self shouldnt:[self parserClass parseMethod: primitiveDeclartion] raise: SyntaxErrorNotification.
	self shouldnt:[self parserClass 	parseMethod: validPragma] raise: SyntaxErrorNotification.
	self should:[self parserClass parseMethod: invalidPragma] raise: SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testReplacingNodes
	| tree search block |
	tree := self parserClass 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 := self parseTreeSearcher.
	block := [ :aNode :answer | aNode replaceWith: (RBVariableNode named: 'q') ].
	search
		matches: 'a' do: block;
		matchesArgument: 'a' do: block.
	search executeTree: tree.
	self
		assert: tree
		equals:
			(self parserClass 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 equals: (self parserClass parseMethod: '+ q | q b | self ifTrue: [] ifFalse: [b := c]. q := b. {q. b}. ^q')! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testGeneralMethodIntervalsPragma
	"This tests that all types of nodes in a method are well made."
	| tree str |
	tree := (self parseMethod: 'Selector <pragmanode> "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node').
	str := '<pragmanode>'.
	self assert: (tree pragmas first left) equals: (tree source findString: str).
	self assert: (tree pragmas first right) equals: ((tree source findString: str) + (str size - 1)).! !

!RBParserTest methodsFor: 'private' stamp: ''!
parserClass
	^ self class parserClass! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testUnfinishedStatementWithLeadingBracesRaisesError

	self should: [(self parserClass parseExpression: '[]}')] 
		  raise: SyntaxErrorNotification! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testModifying
	| tree |
	tree := self parserClass 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: (self parserClass parseMethod: 'bar: a foo: b | d | self first. self second. ^a + b + c').
	self
		assertEmpty:
			(tree argumentNames asSet
				removeAll: #('a' 'b');
				yourself).
	self
		assertEmpty:
			(tree allDefinedVariables asSet
				removeAll: #('a' 'b' 'd');
				yourself).
	tree := self parserClass parseExpression: 'self foo: 0'.
	tree selector: #+.
	self compare: tree to: (self parserClass parseExpression: 'self + 0')! !

!RBParserTest methodsFor: 'tests - Array' stamp: ''!
testDelimitationsOfArrayNodesAreBrackets
	| tree |
	#('{}' '{.}' '{..}' '{foo. bar}' '{foo. bar.}' '{foo. bar. .}' '{. foo. bar}' '{foo.. bar}')
	do: [ :each |  tree := self parserClass parseExpression: each.
						self assert: tree left equals: 1.
						self assert: tree right equals: each size ]! !

!RBParserTest methodsFor: 'tests - Array' stamp: ''!
testLiteralArrayContainsLiteralValues
	"Test the good parsing of the elements of a literal array which means treating each as a literal."
	| tree collection |
	tree := self parserClass 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.
	"Create a collection with the expected values contained in the literal array."
	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).
	self assert: tree isLiteralArray.
	tree value with: collection do: [ :node :value | 
		self assert: node value equals: value ]! !

!RBParserTest methodsFor: 'tests' stamp: ''!
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 - CreationProtocol' stamp: ''!
testCreationMessageNodeFromExpression
	"Verify the good parsing of an expression."
	self compare: (self parserClass parseExpression: 'self + 0')
		  to: (RBMessageNode 
				receiver: (RBVariableNode named: 'self')
				selector: (RBSelectorNode value: #+)
				arguments: (Array with: (RBLiteralNode value: 0))).! !

!RBParserTest methodsFor: 'tests - Pragma' stamp: ''!
testParsingPragmaRecogniseAndStorePragmas
	"Tests that the pragmas are correctly interpreted.
	 1. The string to be parsed.
	 2. The selector in parsed pragma.
	 3. The selector arguments."
	| tree |
	#('foo <foo>' 				
	'foo <foo: 1>' 			
	'foo <foo: 1.2>' 		
	'foo <foo: -3>' 	
	'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: 1 bar: 2>' 
	'foo |t| <foo: 1.2>'
	'foo |t| <foo: 1 bar: 2>' ) do: [ :each |
		tree := self parserClass parseMethod: each.
		self assert: tree pragmas size equals: 1.].
	
	self assert: (self parserClass parseMethod: 'foo |t| <pragma1> <pragma2>') pragmas size equals: 2.! !

!RBParserTest methodsFor: 'foreign use of test' stamp: ''!
testLiteralArray
	"Test the good parsing of the elements of a literal array which means treating each as a literal."
	| tree collection |
	tree := self parserClass 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.
	"Create a collection with the expected values contained in the literal array."
	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).
	self assert: tree isLiteralArray.
	tree value with: collection do: [ :node :value | 
		self assert: node value equals: value ]! !

!RBParserTest methodsFor: 'tests - parsing faulty' stamp: ''!
testParseFaultyMethodStop
	 | methodSource node |
	
	methodSource :=  'method: asd   self do      ('.
	node := self parseFaultyMethod: methodSource.
	
	self assert: node isMethod.
	self assert: node isFaulty.
	self assert: node stop equals: 28.! !

!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testGeneralBlockIntervalsMessage
	"This tests that message nodes inside a block node correspond the right interval in the source code."
	| tree str messageNode position |
	tree := (self parseExpression: '["comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node]').
	
	str := 'message node'.
	messageNode := tree body statements at: 1.
	position := tree source findString: str.
	
	self assert: messageNode start equals: position.
	self assert: messageNode stop equals: position + (str size - 1).! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testCreationBlockNodeWithExpression
	self compare: (self parserClass parseExpression: '[:a :b | a messaged. b messaged.]') 
		  to:(RBBlockNode
			   arguments: (OrderedCollection with: (RBVariableNode named: 'a') with: (RBVariableNode named: 'b'))
				body: (RBSequenceNode statements: (OrderedCollection with: (RBMessageNode receiver: (RBVariableNode named: #a) selector: (RBSelectorNode value: #messaged))
																						with: (RBMessageNode receiver: (RBVariableNode named: #b) selector: (RBSelectorNode value: #messaged))))).! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
testParseGivesMethod
	"The parsing of an expression or a method gives a method node.
	 For an expression we expect the selector to be #noMethod.
	 For a method we expect the selector to be the first identifier.
	 In the method node, we expect the original string (source) to be stored."
	| tree |
	"When there are multiple statements, the node returned is the Sequence node (child of the method node)."
	tree := (self parserClass parseExpression: 'foo koong. ^foo').
	self assert: tree parent isMethod.
	
	"When there is a single statement, the node returned is the overarching node of the statement (child of the sequence node)."
	tree := (self parserClass parseExpression: 'foo koong foo').
	self assert: tree parent parent isMethod.
	
	"parseMethod always return a method node."
	tree := (self parserClass parseMethod: 'foo koong. ^foo').
	self assert: tree isMethod.
	
	tree := (self parserClass parseMethod: 'foo koong foo').
	self assert: tree isMethod.! !

!RBParserTest methodsFor: 'tests - Number' stamp: ''!
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 := self parserClass parseExpression: spec first.
		self assert: node source equals: spec first.
		self assert: node value equals: spec second ]! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testCreationLiteralArrayNodeWithExpression
	self compare: (self parserClass parseExpression: '#(literal1 literal2)')
		  to: (RBLiteralArrayNode
				startPosition: 1
				contents: (Array with: (RBLiteralValueNode value: #literal1) with: (RBLiteralValueNode value: #literal2))
				stopPosition: 20
				isByteArray: false).! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
testParseExpressionGivesTheWriteAmountOfStatements
	"Testing with a list of triplets.
	 1. The string parsed.
	 2. The number of statements expected in parsed string.
	 3. The number of dots marking a period expected in parsed string."
	| 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)
	('foo. bar. foo bar.' 3 3)) do: [ :each |
		tree := self parserClass parseExpression: each first.
		self assert: tree statements size equals: each second.
		self assert: tree periods size equals: each last ]! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
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 := self parserClass parseExpression: each first.
		self assert: tree statements size equals: each second.
		self assert: tree periods size equals: each last.
		self assert: tree left equals: 1.
		self assert: tree right equals: each first size ]! !

!RBParserTest methodsFor: 'garbage tests' stamp: ''!
testGarbageTemporaryVariable
	| tree |
	tree := self parseFaultyExpression: '| temp'.
	self assert: tree isFaulty.
	self assert: tree errorMessage equals: '''|'' expected'.! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testCreationThisContexNodeWithExpression
	self compare: (self parserClass parseExpression: 'thisContext')
		  to: RBVariableNode thisContextNode! !

!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testGeneralBlockIntervalsCascade
	"This tests that cascade nodes inside a block node correspond the right interval in the source code."
	| tree str cascadeNode position |
	tree := (self parseExpression: '["comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node]').
	
	str := 'cascade node; cascaded'.
	cascadeNode := tree body statements at: 6.
	position := tree source findString: str.
	
	self assert: cascadeNode start equals: position.
	self assert: cascadeNode stop equals: position + (str size - 1).! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
testParsingLiteralMessages
	self assert: (self parserClass parseExpression: 'nil self nil') isMessage.
	self assert: (self parserClass parseExpression: 'self true') isMessage.
	self assert: (self parserClass parseExpression: 'self false') isMessage.
	self assert: (self parserClass parseExpression: 'self -1') isMessage.
	
	self assert: (self parserClass parseMethod: 'nil') isMethod.
	self assert: (self parserClass parseMethod: 'true') isMethod.
	self assert: (self parserClass parseMethod: 'false') isMethod! !

!RBParserTest methodsFor: 'tests - Parentage' stamp: ''!
testParentOfStatementsIsSequenceNode
	| tree |
	tree := self parseMethod: 'Selector: argument "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node'.
	(tree body statements) do: [ :each | self assert: each parent equals: tree body].! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
testCascade
	self assert: (self parserClass parseExpression: ' self msg; yourself') isCascade.
	self assert: (self parserClass parseExpression: ' self msg:(arg msg:arg); yourself') isCascade.
	self should: [ self parserClass parseExpression: ' (self msg); yourself' ] raise: SyntaxErrorNotification.
	self should: [ self parserClass parseExpression: ' self ; yourself' ] raise: SyntaxErrorNotification.
	self should: [ self parserClass parseExpression: ' (self) ; yourself' ] raise: SyntaxErrorNotification! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testCreationLiteralValueNodeWithExpressionForNumber
	self compare: (self parserClass parseExpression: '2r10100')
		  to: (RBLiteralValueNode
				value: 20
				start: 1
				stop: 7).! !

!RBParserTest methodsFor: 'tests - Cascade' stamp: ''!
testCascadeReplacement
	"Cascade is composed of an ordered collection of messages, each with the same receiver."
	| cascade |
	cascade := self parserClass parseExpression: 'self foo; bar; baz'.
	"The replacement is made on the collection."
	(cascade messages at: 2) 
		replaceWith: (self parserClass parseExpression: 'self bar: 2').
	self assert: cascade
		  equals: (self parserClass parseExpression: 'self foo; bar: 2; baz').
		
	"The replacement can be a message with another receiver"
	(cascade messages at: 3) 
		replaceWith: (self parserClass parseExpression: 'notself barataba').
	self assert: (cascade messages at: 3) receiver 
		  equals: (self parserClass parseExpression: 'notself').! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testBadlyPlacedPragmaRaiseError
	"The placement in the string will have an impact on the parsing methods involved.
	 Pragmas are supposed to be written in the beginning of a method."
	self shouldnt: [(self parserClass parseMethod: 'foo | token | <some: #tag> ^true')] 
		  raise: SyntaxErrorNotification.
							
	self should: [(self parserClass parseMethod: 'foo | token | ^true <some: #tag>')]
		  raise: 	SyntaxErrorNotification.
			
	self should: [(self parserClass parseMethod: 'foo | token | token:= 5 <some: #tag> ^token')]
		  raise: 	SyntaxErrorNotification.
	
	self should: [(self parserClass parseMethod: 'foo | token |  token messaged <some: #tag> ^token')]
		  raise: 	SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'tests - parsing faulty' stamp: ''!
testParseFaultyLiteral
	| faultyLiteral faultyLiteralArray node |
	"a literal or literal array object with an unknown character can be parse
	as faulty expression. If so, the error token (unknown character) needs to be consumed
	otherwise we get an endless loop"
	faultyLiteral := '¿'.
	faultyLiteralArray  := '#(¿)'.
	node := self parseFaultyExpression: faultyLiteral.
	self assert: node isParseError.
	self assert: node errorMessage equals: 'Unknown character'.	
	node := self parseFaultyExpression: faultyLiteralArray.
	self assert: node isFaulty.
	self assert: node isLiteralArray.	
	self assert: node contents first errorMessage equals: 'Unknown character'! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testCascadeWithInvalidSelectorRaisesError
	| tree |
	tree := self parseFaultyExpression: 'faulty cascade; repared ; 1; node'.
	self assert: tree isCascade.
	self assert: tree messages size equals: 4.
	
	"The presence of an error in a cascade (when parsingFaulty) parses the cascade until the end and stores the error node inside 	 the cascade."
	self assert: tree messages first isMessage.
	self assert: tree messages first receiver name equals: #faulty.
	self assert: tree messages first selectorNode equals: (RBSelectorNode value: #cascade).
	
	self assert: tree messages second isMessage.
	self assert: tree messages second receiver name equals: #faulty.
	self assert: tree messages second selectorNode equals: (RBSelectorNode value: #repared).
	
	self assert: tree messages third isFaulty.
	self assert: tree messages third errorMessage equals: 'Cascade message expected'.
	
	self assert: tree messages last isMessage.
	self assert: tree messages last receiver name equals: #faulty.
	self assert: tree messages last selectorNode equals: (RBSelectorNode value: #node).! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testErrorNodeForBadParenthesesStopAtEnd
	| tree expr |
	expr := '( faulty parentheses message node'.
	tree := self parseFaultyExpression: expr.
	self assert: tree isParseError.
	self assert: tree stop equals: expr size.! !

!RBParserTest methodsFor: 'tests - Number' stamp: ''!
testNumberRadixParsing
	2 to: 32 do: [ :radix | 
		| radixString |
		radixString := radix printString , 'r'.
		0 to: 72 do: [ :i | self assert: (self parserClass parseExpression: radixString , (i radix: radix)) value equals: i ] ]! !

!RBParserTest methodsFor: 'tests - parsing' stamp: ''!
testParseRegistersTheSourceInMethodNode
	"The parsing of an expression or a method gives a method node.
	 For an expression we expect the selector to be #noMethod.
	 For a method we expect the selector to be the first identifier.
	 In the method node, we expect the original string (source) to be stored."
	| tree |
	"When there are multiple statements, the node returned is the Sequence node (child of the method node)."
	tree := (self parserClass parseExpression: 'foo koong. ^foo').
	self assert: tree parent source equals: 'foo koong. ^foo'.
	
	"When there is a single statement, the node returned is the overarching node of the statement (child of the sequence node)."
	tree := (self parserClass parseExpression: 'foo koong foo').
	self assert: tree parent parent source equals: 'foo koong foo'.
	
	"parseMethod always return a method node."
	tree := (self parserClass parseMethod: 'foo koong. ^foo').
	self assert: tree source equals: 'foo koong. ^foo'.
	
	tree := (self parserClass parseMethod: 'foo koong foo').
	self assert: tree source equals: 'foo koong foo'.! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testPragmaInExpressionRaiseError
	"Test if a working pragma in a method is faulty in an expression."
	self should: [(self parserClass parseExpression: '| token | <some: #tag> true')] 
		  raise: SyntaxErrorNotification.
		
	self shouldnt: [(self parserClass parseExpression: '| token | true')] 
		  raise: SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'private' stamp: ''!
treeWithEverything
	^ self parserClass
		parseMethod:
			'method: arg1 | temps | temps := #(10). temps foo; foo. ^(temps collect: [:e | ])'! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testCascadeWithNoMessageRaiseError
	self should: [ self parserClass parseExpression: ' (self msg); yourself' ] raise: SyntaxErrorNotification.
	self should: [ self parserClass parseExpression: ' self ; yourself' ] raise: SyntaxErrorNotification.
	self should: [ self parserClass parseExpression: ' (self) ; yourself' ] raise: SyntaxErrorNotification.
	self should: [ self parserClass parseExpression: ' self msg ;  ; yourself' ] raise: SyntaxErrorNotification! !

!RBParserTest methodsFor: 'tests - parsing faulty' stamp: ''!
testParserErrorsWithErrorBlock
	"Parse source with errors and ensure we identify them"
	
	#(#('self foo. + 3' 1) #('self 0' 1) #('self asdf;;asfd' 1)) 
		do: [:each | |ast errorCount|
			   [ ast := self parseError: each first onError: 
					[:msg :pos :parser | parser parseErrorNode: msg]] 
						on: ReparseAfterSourceEditing do: [].
						
				errorCount := 0.
				RBParseErrorNodeVisitor visit: ast do: [ :n | errorCount := errorCount + 1 ].
				self assert: errorCount equals: each last ]! !

!RBParserTest methodsFor: 'tests - Pattern' stamp: ''!
testParseMethodPatternGivesSelector
	#(#('+ a ^self + a' 				#+) 
	  #('foo ^self foo' 				#foo)
	  #('foo: a b ^self foo: b'    #foo:) 
	  #('foo: a bar: b ^a + b' 		#foo:bar:))
		do: [ :each | self assert: (self parserClass parseMethodPattern: each first) identicalTo: each last ]! !

!RBParserTest methodsFor: 'tests - Cascade' stamp: ''!
testSemiColonAfterMessageIsCascade
	self assert: (self parserClass parseExpression: ' self msg; yourself') isCascade.
	self assert: (self parserClass parseExpression: ' self msg:(arg msg:arg); yourself') isCascade.
	self assert: (self parserClass parseExpression: ' self msg: arg msga:arga ; ibm ; yourself') isCascade.! !

!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testGeneralBlockIntervalsLiteralValue
	"This tests that literal value nodes inside a block node correspond the right interval in the source code."
	| tree str literalValueNode position |
	tree := (self parseExpression: '["comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node]').
	
	str := '#literalNode'.
	literalValueNode := tree body statements at: 2.
	position := tree source findString: str.
	
	self assert: literalValueNode start equals: position.
	self assert: literalValueNode stop equals: position + (str size - 1).! !

!RBParserTest methodsFor: 'private' stamp: ''!
parseFaultyExpression: text
	^ self parserClass parseFaultyExpression: text! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testCreationSuperNodeWithExpression
	self compare: (self parserClass parseExpression: 'super')
		  to: RBVariableNode superNode.! !

!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testGeneralBlockIntervalsReturn
	"This tests that return nodes inside a block node correspond the right interval in the source code."
	| tree str returnNode position |
	tree := (self parseExpression: '["comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node]').
	
	str := '^return node'.
	returnNode := tree body statements at: 8.
	position := tree source findString: str.
	
	self assert: returnNode start equals: position.
	self assert: returnNode stop equals: position + (str size - 1).! !

!RBParserTest methodsFor: 'tests - parsing faulty' stamp: ''!
testParserErrors
	#(#('self foo. + 3' 11) #('self 0' 6) #('self asdf;;asfd' 11)) 
		do: [:each | self parseError: each]! !

!RBParserTest methodsFor: 'tests - CreationProtocol' stamp: ''!
testCreationVariableNodeWithExpression
	self compare: (self parserClass parseExpression: 'variable')
		  to: (RBVariableNode named: #variable start: 1).! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testFormatter
	self exampleClasses do: [ :class |
		class selectors do: [ :selector | 
		self 
			compare: (class parseTreeFor: selector)
			to: (self parserClass parseMethod: (class parseTreeFor: selector) printString) ] ]! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testCascadeReplacementCanLeadToOddErrors
	| cascade |
	cascade := self parserClass parseExpression: 'self foo; bar; baz'.
	(cascade messages at: 2) 
		replaceWith: (self parserClass parseExpression: '2').
		
	cascade := self parserClass parseExpression: 'self foo; bar; baz'.
	(cascade messages at: 2) 
		replaceWith: (self parserClass parseExpression: 'temp := temp bar').
		
	"This tests create an error in the printing of self and parent of the node."! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testErrorNodeForBadParenthesesStartAtFirstParenthese
	| tree |
	tree := self parseFaultyExpression: '( faulty parentheses message node'.
	self assert: tree isParseError.
	self assert: tree start equals: 1.! !

!RBParserTest methodsFor: 'garbage tests' stamp: ''!
testGarbageTemporaryVariableIsWrong
	"The parser doesn't recognise the 2 because it is not an identifier."
	| tree errorNode |
	tree := self parseFaultyExpression: '| 2 |'.
	self assert: tree isFaulty.
	self assert: tree isSequence.
	
	errorNode := tree statements first.
	self assert: errorNode isParseError.
	self assert: errorNode errorMessage equals: '''|'' expected'.! !

!RBParserTest methodsFor: 'tests - Interval' stamp: ''!
testGeneralMethodIntervalsLiteralArray
	"This tests that all types of nodes in a method are well made."
	| tree str |
	tree := (self parseMethod: 'Selector <pragmanode> "comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node').
	str := '#(literal array node)'.
	self assert: ((tree body statements at: 3) start) equals: (tree source findString: str).
	self assert: ((tree body statements at: 3) stop) equals: ((tree source findString: str) + (str size - 1)).! !

!RBParserTest methodsFor: 'tests - Intervals' stamp: ''!
testGeneralBlockIntervalsLiteralArray
	"This tests that literal array nodes inside a block node correspond the right interval in the source code."
	| tree str literalArrayNode position |
	tree := (self parseExpression: '["comment node" | temporaries | message node. #literalNode . #(literal array node). {array node}. [block node]. cascade node; cascaded. assignement := node. ^return node]').
	
	str := '#(literal array node)'.
	literalArrayNode := tree body statements at: 3.
	position := tree source findString: str.
	
	self assert: literalArrayNode start equals: position.
	self assert: literalArrayNode stop equals: position + (str size - 1).! !

!RBParserTest methodsFor: 'garbage tests' stamp: ''!
testAssignementRightValueWithUnfortunatePontuationRaisesSyntaxError
	"The idea is for the parser to realise the first dot isn't supposed to be here and select it. Also add a side note to give suggestion     on the provenance of the error."
	self should: [self parserClass parseExpression: 'temp := .1 + 2.'] raise: SyntaxErrorNotification.
	self should: [self parserClass parseExpression: 'temp := 1. + 2.'] raise: SyntaxErrorNotification.
	self should: [self parserClass parseExpression: 'temp := 1 +. 2.'] raise: SyntaxErrorNotification.
	
	"The same could be made for other special characters."
	self should: [self parserClass parseExpression: 'temp := ;1 + 2.'] raise: SyntaxErrorNotification.
	self should: [self parserClass parseExpression: 'temp := ,1 + 2.'] raise: SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testBlockReturnNode
	| tree |
	" no explicit return"
	tree := self parserClass parseMethod:
			'tmp [ 3+4 ]'.
	self deny: tree lastIsReturn.
	" no explicit return the block local return should not count as method return "
	tree := self parserClass parseMethod:
	      'tmp [^ 3+4 ]'.
	self deny: tree lastIsReturn.
	
	" explicit return"
	tree := self parserClass parseMethod:
			'tmp ^ [ 3+4 ]'.
	self assert: tree lastIsReturn! !

!RBParserTest methodsFor: 'tests' stamp: ''!
testBlockNodeIsUsed
	| tree |
	" block node is not a used-node"
	tree := self parserClass parseMethod:
			'tmp [ 3+4 ]'.
	self deny: tree body statements last isUsed.
	" even a block node with non-local return is not *used* "
	tree := self parserClass parseMethod:
	      'tmp [^ 3+4 ]'.
	self deny: tree body statements last isUsed.
	
	"an explicit return node is *used*"
	tree := self parserClass parseMethod:
			'tmp ^[ 3+4 ]'.
	self assert: tree body statements last isUsed! !

!RBParserTest methodsFor: 'tests - Parentage' stamp: ''!
testParentOfMethodNodeIsNil
	| tree |
	tree := self parseMethod: 'Selector ^return something.'.
	self assert: tree parent isNil.! !

!RBParserTest methodsFor: 'garbage tests' stamp: ''!
testGarbageForgottenDotAfterAssignement
	| tree child error |
	self shouldnt: [self parserClass parseExpression: '|temp | temp := 1 + 2 temp + 3'] raise: SyntaxErrorNotification.
	
	tree := self parserClass parseExpression: '|temp | temp := 1 + 2 temp + 3'.
	self assert: tree isSequence.
	
	"There should only be one statement as there is no dot."
	child := tree statements.
	self assert: (child size) equals: 1.
	self assert: child first isAssignment.
	
	"Getting the part changed by missing dot."
	error := child first value receiver arguments first.
	self assert: error isMessage.
	self assert: error receiver value equals: 2.
	self assert: error selectorNode equals: (RBSelectorNode value: #temp)! !

!RBParserTest methodsFor: 'tests' stamp: ''!
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 identicalTo: node.
											self assert: each methodNode identicalTo: root ] ] ] ] ]! !

!RBParserTest methodsFor: 'garbage tests' stamp: ''!
testInvalidSelectorRaisesSyntaxError
	"Could propose multiple reparations like assignement, period, array..."
	self should: [self parserClass parseExpression: 'temp 1 + 3'] raise: SyntaxErrorNotification.! !

!RBParserTest methodsFor: 'tests - parsing faulty' stamp: ''!
testParseFaultyPragma
	| node |
	node := self parseFaultyMethod: 'a <b:'.
	self assert: node isMethod.
	self assert: node pragmas size equals: 1.
	self assert: node pragmas first isFaulty! !

!RBParserTest methodsFor: 'tests - Selector' stamp: ''!
testSelectorFromMessageIsSelectorNode
	| tree |
	tree := self parseExpression: 'receiver selector'.
	self assert: tree isMessage.
	self assert: tree selectorNode isSelector.
	self assert: tree selector equals: #selector.! !

!RBParserTest methodsFor: 'error testing' stamp: ''!
testCascadeWithMissingSelectorRaisesError
	| tree |
	tree := self parseFaultyExpression: 'faulty cascade; repared ;; node'.
	self assert: tree isCascade.
	self assert: tree messages size equals: 4.
	
	"The presence of an error in a cascade (when parsingFaulty) parses the cascade until the end and stores the error node inside 	 the cascade."
	self assert: tree messages first isMessage.
	self assert: tree messages first receiver name equals: #faulty.
	self assert: tree messages first selectorNode equals: (RBSelectorNode value: #cascade).
	
	self assert: tree messages second isMessage.
	self assert: tree messages second receiver name equals: #faulty.
	self assert: tree messages second selectorNode equals: (RBSelectorNode value: #repared).
	
	self assert: tree messages third isFaulty.
	self assert: tree messages third errorMessage equals: 'Cascade message expected'.
	
	self assert: tree messages last isMessage.
	self assert: tree messages last receiver name equals: #faulty.
	self assert: tree messages last selectorNode equals: (RBSelectorNode value: #node).! !

!RBParserTest methodsFor: 'tests - Parentage' stamp: ''!
testParentOfArgumentNodeIsMethodNode
	| tree |
	tree := self parseMethod: 'Selector: argument ^return something.'.
	self assert: tree arguments first isVariable.
	self assert: tree arguments first parent equals: tree.! !

!RBParserTest class methodsFor: 'accessing' stamp: ''!
parserClass
	^ RBParser! !

!RBPatternBlockNode commentStamp: ''!
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 the second node is the dictionary that contains all the metavariable bindings that the matcher has made thus far.

Instance Variables:
	valueBlock	<BlockClosure>	The block to execute when attempting to match this to a node.

!
!RBPatternBlockNode methodsFor: 'matching' stamp: ''!
replacePatternNodesIn: aRBBlockNode 
	aRBBlockNode body nodesDo: 
			[:each | 
			(each isVariable and: [each isPatternNode]) 
				ifTrue: 
					[each 
						replaceWith: (self constructLookupNodeFor: each name in: aRBBlockNode)]]! !

!RBPatternBlockNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor 
	^aProgramNodeVisitor visitPatternBlockNode: self! !

!RBPatternBlockNode methodsFor: 'matching' stamp: ''!
lookupMatchFor: aString in: aDictionary 
	^aDictionary at: aString
		ifAbsent: 
			[| variableNode |
			variableNode := RBPatternVariableNode named: aString.
			aDictionary at: variableNode ifAbsent: [nil]]! !

!RBPatternBlockNode methodsFor: 'testing - matching' stamp: ''!
isPatternNode
	^ true! !

!RBPatternBlockNode methodsFor: 'matching' stamp: ''!
createMatchingBlock
	| newBlock |
	self arguments size > 2 
		ifTrue: 
			[self 
				error: 'Search blocks can only contain arguments for the node and matching dictionary'].
	newBlock := RBBlockNode arguments: arguments body: body.
	newBlock arguments isEmpty 
		ifTrue: [self addArgumentWithNameBasedOn: 'aNode' to: newBlock].
	newBlock arguments size = 1 
		ifTrue: [self addArgumentWithNameBasedOn: 'aDictionary' to: newBlock].
	self replacePatternNodesIn: newBlock.
	^newBlock evaluateForReceiver: self.! !

!RBPatternBlockNode methodsFor: 'accessing' stamp: ''!
sentMessages
	^ OrderedCollection new! !

!RBPatternBlockNode methodsFor: 'matching' stamp: ''!
matchingBlock
	^ valueBlock ifNil: [valueBlock := self createMatchingBlock]! !

!RBPatternBlockNode methodsFor: 'matching' stamp: ''!
createReplacingBlock
	| newBlock |
	self arguments size > 1 
		ifTrue: 
			[self 
				error: 'Replace blocks can only contain an argument for the matching dictionary'].
	newBlock := RBBlockNode arguments: arguments body: body.
	self arguments isEmpty 
		ifTrue: [self addArgumentWithNameBasedOn: 'aDictionary' to: newBlock].
	self replacePatternNodesIn: newBlock.
	^newBlock evaluateForReceiver: self.! !

!RBPatternBlockNode methodsFor: 'matching' stamp: ''!
replacingBlock
	^ valueBlock ifNil: [valueBlock := self createReplacingBlock]! !

!RBPatternBlockNode methodsFor: '*Renraku' stamp: ''!
pattern

	^ self source
		copyFrom: self sourceInterval first
		to: self sourceInterval last! !

!RBPatternBlockNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary 
	^self matchingBlock value: aNode value: aDictionary! !

!RBPatternBlockNode methodsFor: 'matching' stamp: ''!
addArgumentWithNameBasedOn: aString to: aRBBlockNode 
	| name index vars |
	name := aString.
	vars := aRBBlockNode allDefinedVariables.
	index := 0.
	[vars includes: name] whileTrue: 
			[index := index + 1.
			name := name , index printString].
	aRBBlockNode 
		arguments: (aRBBlockNode arguments copyWith: (RBVariableNode named: name))! !

!RBPatternBlockNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	^ self replacingBlock value: aDictionary! !

!RBPatternBlockNode methodsFor: 'matching' stamp: ''!
constructLookupNodeFor: aString in: aRBBlockNode
	^ RBMessageNode
		  receiver: RBVariableNode selfNode
		  selector: #lookupMatchFor:in:
		  arguments: (Array with: (RBLiteralNode value: aString) with: aRBBlockNode arguments last copy)! !

!RBPatternBlockToken commentStamp: ''!
RBPatternBlockToken is the first-class representation of the pattern block token.

!
!RBPatternBlockToken methodsFor: 'testing' stamp: ''!
isPatternBlock
	^true! !

!RBPatternMessageNode commentStamp: ''!
RBPatternMessageNode is an RBMessageNode that will match other message nodes without their selectors being equal. 

Instance Variables:
	isCascadeList	<Boolean>	are we matching a list of message nodes in a cascaded message
	isList	<Boolean>	are we matching each keyword or matching all keywords together (e.g., `keyword1: would match a one-argument method whereas `@keywords: would match 0 or more arguments)!
!RBPatternMessageNode methodsFor: 'testing - matching' stamp: ''!
isSelectorList
	^isList! !

!RBPatternMessageNode methodsFor: 'initialization' stamp: ''!
receiver: aValueNode selector: aSymbol keywordsPositions: positionList arguments: valueNodes
	| message |
	self
		receiver: aValueNode;
		selector: aSymbol;
		keywordsPositions: positionList;
		arguments: valueNodes.
		
	isCascadeList := isList := false.
	message := self selectorParts first.
	
	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: ''!
matchSelectorAgainst: aNode inContext: aDictionary 
	self selectorParts with: aNode selectorParts do: [ :first :second |
		| keyword |
		keyword := aDictionary
			at: first
			ifAbsentPut: [ 
				first isPatternVariable 
					ifTrue: [ second ]
					ifFalse: [ first ] ].
		keyword = second 
			ifFalse: [ ^ false ] ].
	^ true! !

!RBPatternMessageNode methodsFor: 'private' stamp: ''!
matchingClass
	^RBMessageNode! !

!RBPatternMessageNode methodsFor: 'testing - matching' stamp: ''!
isPatternNode
	^true! !

!RBPatternMessageNode methodsFor: 'accessing' stamp: ''!
sentMessages
	^ super sentMessages
		remove: self selector ifAbsent: [ ];
		yourself! !

!RBPatternMessageNode methodsFor: '*Renraku' stamp: ''!
pattern

	^ self selector! !

!RBPatternMessageNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary 
	aNode class == self matchingClass ifFalse: [^false].
	(receiver match: aNode receiver inContext: aDictionary) ifFalse: [^false].
	self isSelectorList 
		ifTrue: 
			[^(aDictionary at: self selectorParts first ifAbsentPut: [aNode selector]) 
				== aNode selector and: 
						[(aDictionary at: arguments first ifAbsentPut: [aNode arguments]) 
							= aNode arguments]].
	^self matchArgumentsAgainst: aNode inContext: aDictionary! !

!RBPatternMessageNode methodsFor: 'matching' stamp: ''!
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: 'testing - matching' stamp: ''!
isList
	^isCascadeList and: [parent notNil and: [parent isCascade]]! !

!RBPatternMessageNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary
	| keywordSelector |
	self isList 
		ifTrue: [ ^ aDictionary at: self ].
	keywordSelector := self isSelectorList 
		ifTrue: [ aDictionary at: self selectorParts first ]
		ifFalse: [ '' join: (self selectorParts collect: [ :each | aDictionary at: each ])].
	^ RBMessageNode
		receiver: (self receiver copyInContext: aDictionary)
		selector: keywordSelector
		arguments: (self copyList: self arguments inContext: aDictionary)! !

!RBPatternMessageNode class methodsFor: 'instance creation' stamp: ''!
receiver: aValueNode selector: aSelector keywordsPositions: positionList arguments: valueNodes

	^aSelector value asSymbol isPatternVariable
		ifTrue: 
			[super
				receiver: aValueNode
				selector: aSelector
				keywordsPositions: positionList asIntegerArray
				arguments: valueNodes]
		ifFalse: 
			[RBMessageNode 
				receiver: aValueNode
				selector: aSelector
				keywordsPositions: positionList asIntegerArray
				arguments: valueNodes]! !

!RBPatternMethodNode commentStamp: ''!
RBPatternMethodNode is an RBMethodNode that will match other method nodes without their selectors being equal. 

Instance Variables:
	isList	<Boolean>	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: 'testing' stamp: ''!
isSelectorList
	^isList! !

!RBPatternMethodNode methodsFor: 'matching' stamp: ''!
matchSelectorAgainst: aNode inContext: aDictionary 
	self selectorParts with: aNode selectorParts do: [ :first :second |
		| keyword |
		keyword := aDictionary
			at: first
			ifAbsentPut: [ 
				first isPatternVariable 
					ifTrue: [ second ]
					ifFalse: [ first ] ].
		keyword = second 
			ifFalse: [ ^ false ] ].
	^ true! !

!RBPatternMethodNode methodsFor: 'testing - matching' stamp: ''!
isPatternNode
	^true! !

!RBPatternMethodNode methodsFor: 'private' stamp: ''!
matchingClass
	^RBMethodNode! !

!RBPatternMethodNode methodsFor: 'initialization' stamp: ''!
selector: aSymbol keywordsPositions: positionList arguments: valueNodes 
	super selector: aSymbol keywordsPositions: positionList arguments: valueNodes.
	isList := (aSymbol keywords first value at: 2) == self listCharacter! !

!RBPatternMethodNode methodsFor: '*Renraku' stamp: ''!
pattern

	^ self selector! !

!RBPatternMethodNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary 
	aNode class = self matchingClass 
		ifFalse: [ ^ false ].
	aDictionary at: '-source-' put: aNode source.
	self isSelectorList ifTrue: [
		^ (aDictionary at:  self selectorParts first ifAbsentPut: [ aNode selector ]) = aNode selector
			and: [ (arguments isEmpty or: [(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: ''!
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: ''!
copyInContext: aDictionary 
	| keywordSelector |
	keywordSelector := self isSelectorList 
		ifTrue: [ aDictionary at: self selectorParts first ]
		ifFalse: [ ('' join:(self selectorParts collect: [ :each | aDictionary at: each ])) asSymbol  ].
	^ RBMethodNode new
		selector: keywordSelector;
		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 class methodsFor: 'instance creation' stamp: ''!
selector: aSelector keywordsPositions: positionList arguments: valueNodes
	^(aSelector isPatternVariable) 
		ifTrue: [super selector: aSelector keywordsPositions: positionList arguments: valueNodes]
		ifFalse: 
			[RBMethodNode selector: aSelector keywordsPositions: positionList arguments: valueNodes]! !

!RBPatternParser commentStamp: ''!
RBPatternParser is a subclass of RBParser that allows the extended syntax that creates matching trees. These trees can be used by the ParseTreeMatcher to search and transform source code.
!
!RBPatternParser methodsFor: 'private - parsing' stamp: ''!
parsePragmaLiteral
	| node |
	currentToken isPatternBlock 
		ifTrue: [ ^ self parsePatternBlock: RBPatternBlockNode ].
	(currentToken isIdentifier and: [ currentToken isPatternVariable ]) ifTrue: [
		node := self variableNodeClass identifierNamed: currentToken value at: currentToken start.
		node isLiteralNode 
			ifFalse: [ self parseError: 'Literal pattern expected' ].
		self step.
		currentToken isPatternBlock ifTrue: [
			node := (self parsePatternBlock: RBPatternWrapperBlockNode)
				wrappedNode: node;
				yourself ].
		^ node ].
	^ super parsePragmaLiteral! !

!RBPatternParser methodsFor: 'private - parsing' stamp: ''!
parseError: aString

	self error: aString! !

!RBPatternParser methodsFor: 'private - parsing' stamp: ''!
parseLiteralByteArrayObject
	| node |
	(currentToken isIdentifier and: [currentToken isPatternVariable]) 
		ifTrue: 
			[node := self variableNodeClass identifierNamed: currentToken value at: currentToken start.
			node isLiteralNode 
				ifTrue: 
					[self step.
					^node]].
	^super parseLiteralByteArrayObject! !

!RBPatternParser methodsFor: 'private - parsing' stamp: ''!
parsePrimitiveLiteral
	| node |
	(currentToken isIdentifier and: [currentToken isPatternVariable]) 
		ifTrue: 
			[node := self variableNodeClass identifierNamed: currentToken value at: currentToken start.
			node isLiteralNode 
				ifTrue: 
					[self step.
					^node].
			currentToken := RBLiteralToken 
						value: currentToken value asSymbol
						start: currentToken start
						stop: currentToken stop].
	^super parsePrimitiveLiteral! !

!RBPatternParser methodsFor: 'private - parsing' stamp: ''!
parsePrimitiveObject
	currentToken isPatternBlock 
		ifTrue: [^self parsePatternBlock: RBPatternBlockNode].
	^super parsePrimitiveObject! !

!RBPatternParser methodsFor: 'private - classes' stamp: ''!
methodNodeClass
	^RBPatternMethodNode! !

!RBPatternParser methodsFor: 'private - classes' stamp: ''!
pragmaNodeClass
	^RBPatternPragmaNode! !

!RBPatternParser methodsFor: 'accessing' stamp: ''!
scannerClass
	^RBPatternScanner! !

!RBPatternParser methodsFor: 'private - parsing' stamp: ''!
parseWrapperPatternBlockWith: wrappedNode
	| node |

	node := self parsePatternBlock: RBPatternWrapperBlockNode.
	node class == RBPatternWrapperBlockNode ifTrue: [ 
		self flag: 'I think this is ugly, but I don''t know how to avoid checking the result of #parsePatternBlock:'.
		node wrappedNode: wrappedNode ].
	
	^ node! !

!RBPatternParser methodsFor: 'private - parsing' stamp: ''!
parseUnaryMessage
	| node |
	node := self parsePrimitiveObject.
	self addCommentsTo: node.
	
	[currentToken isLiteralToken ifTrue: [self patchLiteralMessage].
	currentToken isPatternBlock 
		ifTrue: 
			[node := self parseWrapperPatternBlockWith: node ].
	currentToken isIdentifier] 
			whileTrue: [
				currentToken isKeywordPattern
					ifTrue: [ self parserError: ' incomplete keyword pattern ' ].
				node := self parseUnaryMessageWith: node].
	self addCommentsTo: node.
	^node! !

!RBPatternParser methodsFor: 'private - classes' stamp: ''!
variableNodeClass
	^RBPatternVariableNode! !

!RBPatternParser methodsFor: 'private - classes' stamp: ''!
messageNodeClass
	^RBPatternMessageNode! !

!RBPatternParser methodsFor: 'private' stamp: ''!
patchLiteralArrayToken
	(currentToken isIdentifier and: [currentToken isPatternVariable]) 
		ifTrue: [^self].
	super patchLiteralArrayToken! !

!RBPatternParser methodsFor: 'private - parsing' stamp: ''!
parsePatternBlock: aClass 
	| position node |
	position := currentToken start.
	self step.
	node := aClass new.
	self parseBlockArgsInto: node.
	node left: position.
	
	node body: self sequenceNodeClass new.
	self
		parseStatements: false
		into: node body
		until: [ currentToken isSpecial
			and: [ currentToken value = $} ] ].
	
	(currentToken isSpecial and: [currentToken value = $}]) 
		ifFalse: [ self addParserError: '''}'' expected' to: node body.
			^ node ].
	node right: currentToken start.
	self step.
	^node! !

!RBPatternParserTest commentStamp: ''!
SUnit tests for RBPatternParser.
RBPatternParser needs some extra tests not covered by RBPatternTest for its extended syntax
(pattern variables and pattern blocks)!
!RBPatternParserTest methodsFor: 'tests - parsing' stamp: ''!
testPatternBlockNode1
	| searchPattern tree |
	searchPattern := RBPatternParser
		parseExpression: '(`a = `b) `{`a name size = `b name size}'.
	tree := self parseExpression: 'a = c'.
	self assert: (searchPattern match: tree inContext: Dictionary new)! !

!RBPatternParserTest methodsFor: 'tests - parsing' stamp: ''!
testPatternBlockNode2
	| searchPattern tree |
	searchPattern := RBPatternParser
		parseExpression: '(`a = `b) `{`a name anySatisfy: [ :e | `b name includes: e]}'.
	tree := self parseExpression: 'a = a1'.
	self assert: (searchPattern match: tree inContext: Dictionary new)! !

!RBPatternParserTest methodsFor: 'tests - parsing' stamp: ''!
testParseFaultyPatternBlock
	| node patternBlockNoArgButBar patternBlockNoArgButColon unfinishedBlock varWithUnfinishedBlock |
	"parsing pattern block should mark this block as faulty, if it is unfinished no closing brace, or missing parts (colon but no arg, 
	no arg but vertical bar)"
	patternBlockNoArgButBar := '`{ | }'.
	patternBlockNoArgButColon := '`{ : }'.
	unfinishedBlock := '`{ :  '.
	varWithUnfinishedBlock := '`sth `{ :  '.
	{patternBlockNoArgButBar. patternBlockNoArgButColon. unfinishedBlock. varWithUnfinishedBlock}
		do: [ :faultyExpression | 
			node := self parseFaultyExpression: faultyExpression.
			self assert: node isBlock.
			self assert: node isFaulty]! !

!RBPatternParserTest class methodsFor: 'accessing' stamp: ''!
parserClass
	^ RBPatternParser! !

!RBPatternPragmaNode commentStamp: ''!
RBPatternPragmaNode is an RBPragmaNode that is used by the tree searcher to
match pragma statements. Just like RBPatternMethodNode for method nodes.

Instance Variables:
	isList	<Boolean>	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)
!
!RBPatternPragmaNode methodsFor: 'testing - matching' stamp: ''!
isSelectorList
	^ isList! !

!RBPatternPragmaNode methodsFor: 'testing - matching' stamp: ''!
isPatternNode
	^ true! !

!RBPatternPragmaNode methodsFor: 'matching' stamp: ''!
matchSelectorAgainst: aNode inContext: aDictionary 
	self selectorParts with: aNode selectorParts do: [ :first :second |
		| keyword |
		keyword := aDictionary
			at: first
			ifAbsentPut: [ 
				first isPatternVariable 
					ifTrue: [ second ]
					ifFalse: [ first ] ].
		keyword = second 
			ifFalse: [ ^ false ] ].
	^ true! !

!RBPatternPragmaNode methodsFor: 'private' stamp: ''!
matchingClass
	^ RBPragmaNode! !

!RBPatternPragmaNode methodsFor: 'accessing' stamp: ''!
sentMessages
	^ super sentMessages
		remove: self selector ifAbsent: [ ];
		yourself! !

!RBPatternPragmaNode methodsFor: 'initialization' stamp: ''!
selector: aSymbol keywordsPositions: positionList arguments: valueNodes
	self 
		arguments: valueNodes;
		selector: aSymbol;
		keywordsPositions: positionList.
	isList := (aSymbol keywords first value at: 2) == self listCharacter! !

!RBPatternPragmaNode methodsFor: '*Renraku' stamp: ''!
pattern

	^ self selector! !

!RBPatternPragmaNode methodsFor: 'matching' stamp: ''!
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: ''!
match: aNode inContext: aDictionary
	aNode class = self matchingClass
		ifFalse: [ ^ false ].
	self isSelectorList ifTrue: [
		^ (aDictionary at: self selectorParts first ifAbsentPut: [ aNode selector ]) = aNode selector
			and: [ (aDictionary at: arguments first ifAbsentPut: [ aNode arguments ]) = aNode arguments ] ].
	^ self matchArgumentsAgainst: aNode inContext: aDictionary! !

!RBPatternPragmaNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	| keywordSelector |
	keywordSelector := self isSelectorList 
		ifTrue: [ aDictionary at: self selectorParts first ]
		ifFalse: [ ('' join: (self selectorParts collect: [ :each | aDictionary at: each ])) asSymbol ].
	^ RBPragmaNode
		selector: keywordSelector
		arguments: (self copyList: self arguments inContext: aDictionary)! !

!RBPatternPragmaNode class methodsFor: 'instance creation' stamp: ''!
selector: aSelector keywordsPositions: positionList arguments: valueNodes
	^(aSelector isPatternVariable)
		ifTrue: [ super selector: aSelector keywordsPositions: positionList arguments: valueNodes ]
		ifFalse: [ RBPragmaNode selector: aSelector keywordsPositions: positionList arguments: valueNodes ]! !

!RBPatternScanner commentStamp: ''!
RBPatternScanner is a subclass of RBScanner that allows the extended syntax of pattern matching trees.
!
!RBPatternScanner methodsFor: 'private - scanning' stamp: ''!
scanPatternVariable
	buffer nextPut: currentCharacter.
	self step.
	currentCharacter = ${ 
		ifTrue: 
			[self step.
			^RBPatternBlockToken value: '`{' start: tokenStart].
	[characterType = #alphabetic] whileFalse: 
			[characterType = #eof 
				ifTrue: [ ^ self scanError: 'Meta variable expected'].
			buffer nextPut: currentCharacter.
			self step].
	^self scanIdentifierOrKeyword! !

!RBPatternScanner methodsFor: 'accessing' stamp: ''!
scanToken
	currentCharacter = PatternVariableCharacter 
		ifTrue: [^self scanPatternVariable].
	currentCharacter = $} ifTrue: [^self scanSpecialCharacter].
	^super scanToken! !

!RBPatternVariableNode commentStamp: ''!
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 a 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	<Boolean>	can we match any type of node
	isList	<Boolean>	can we match a list of items (@)
	isLiteral	<Boolean>	only match a literal node (#)
	isStatement	<Boolean>	only match statements (.)
	recurseInto	<Boolean>	search for more matches in the node we match (`)

!
!RBPatternVariableNode methodsFor: 'testing - matching' stamp: ''!
isAnything
	^isAnything! !

!RBPatternVariableNode methodsFor: 'matching' stamp: ''!
matchStatement: aNode inContext: aDictionary
	(aNode parent notNil and: [aNode parent isSequence]) ifFalse: [^false].
	^ self compare: (aDictionary at: self ifAbsentPut: [aNode]) with: aNode! !

!RBPatternVariableNode methodsFor: 'testing - matching' stamp: ''!
isLiteralNode
	^isLiteral! !

!RBPatternVariableNode methodsFor: 'initialization' stamp: ''!
initializePatternVariables
	| myname |
	myname := self name.
	isAnything := isList := isLiteral := isStatement := recurseInto := false.
	2 to: myname size
		do: 
			[:i | 
			| character |
			character := myname at: i.
			character == self listCharacter 
				ifTrue: [isAnything := isList := true]
				ifFalse: 
					[character == self literalCharacter 
						ifTrue: [isLiteral := true]
						ifFalse: 
							[character == self statementCharacter 
								ifTrue: [isStatement := true]
								ifFalse: 
									[character == self recurseIntoCharacter 
										ifTrue: [recurseInto := true]
										ifFalse: [^self]]]]]! !

!RBPatternVariableNode methodsFor: 'testing - matching' stamp: ''!
recurseInto
	^recurseInto! !

!RBPatternVariableNode methodsFor: 'testing - matching' stamp: ''!
isPatternNode
	^true! !

!RBPatternVariableNode methodsFor: 'private' stamp: ''!
matchingClass
	^RBVariableNode! !

!RBPatternVariableNode methodsFor: 'matching' stamp: ''!
matchLiteral: aNode inContext: aDictionary
	^aNode isLiteralNode
		and: [ self compare: (aDictionary at: self ifAbsentPut: [aNode]) with: aNode]! !

!RBPatternVariableNode methodsFor: 'accessing' stamp: ''!
parent: aBRProgramNode 
	"Fix the case where '``@node' should match a single node, not a sequence node."

	super parent: aBRProgramNode.
	parent isDynamicArray
		ifTrue: [ self isStatement
				ifFalse: [ isList := false ] ].
	parent isSequence 
		ifTrue: 
			[(self isStatement or: [parent temporaries includes: self]) 
				ifFalse: [isList := false]]! !

!RBPatternVariableNode methodsFor: 'testing - matching' stamp: ''!
isStatement
	^isStatement! !

!RBPatternVariableNode methodsFor: 'initialization' stamp: ''!
named: aName start: aPosition

	super named: aName start: aPosition.
	self initializePatternVariables! !

!RBPatternVariableNode methodsFor: '*Renraku' stamp: ''!
pattern

	^ self name! !

!RBPatternVariableNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary
	self isAnything 
		ifTrue: [^ self compare: (aDictionary at: self ifAbsentPut: [aNode]) with: aNode].
	self isLiteralNode ifTrue: [^self matchLiteral: aNode inContext: aDictionary].
	self isStatement 
		ifTrue: [^self matchStatement: aNode inContext: aDictionary].
	(aNode isKindOf: self matchingClass) ifFalse: [^false].
	^ self compare: (aDictionary at: self ifAbsentPut: [aNode]) with: aNode! !

!RBPatternVariableNode methodsFor: 'testing - matching' stamp: ''!
isList
	^isList! !

!RBPatternVariableNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary
	^ (self isList and: [ self isStatement ])
		ifTrue: [ self copyList: (aDictionary at: self) inContext: aDictionary ]
		ifFalse: [ (aDictionary at: self) copy ]! !

!RBPatternVariableNode methodsFor: 'verification' stamp: ''!
compare: anObject with: aNode
	^ anObject isCollection  
		ifTrue: [ anObject anySatisfy: [ :e | e = aNode ] ]
		ifFalse: [ anObject = aNode ]! !

!RBPatternVariableNode class methodsFor: 'instance creation' stamp: ''!
identifierNamed: anIdentifierName at: aPosition
	^anIdentifierName isPatternVariable 
		ifTrue: [super identifierNamed: anIdentifierName at: aPosition]
		ifFalse: [RBVariableNode identifierNamed: anIdentifierName at: aPosition]! !

!RBPatternWrapperBlockNode commentStamp: ''!
RBPatternWrapperBlockNode allows further matching using a block after a node has been matched by a pattern node.

Instance Variables:
	wrappedNode	<RBProgramNode>	The original pattern node to match!
!RBPatternWrapperBlockNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor 
	^aProgramNodeVisitor visitPatternWrapperBlockNode: self! !

!RBPatternWrapperBlockNode methodsFor: 'accessing' stamp: ''!
wrappedNode
	^wrappedNode! !

!RBPatternWrapperBlockNode methodsFor: 'accessing' stamp: ''!
wrappedNode: aRBProgramNode 
	wrappedNode := aRBProgramNode.
	aRBProgramNode parent: self! !

!RBPatternWrapperBlockNode methodsFor: 'accessing' stamp: ''!
sentMessages
	^ wrappedNode sentMessages! !

!RBPatternWrapperBlockNode methodsFor: 'accessing' stamp: ''!
precedence
	^1! !

!RBPatternWrapperBlockNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary 
	(wrappedNode match: aNode inContext: aDictionary) ifFalse: [^false].
	^super match: aNode inContext: aDictionary! !

!RBPatternWrapperBlockNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	"I don't know what this would mean, so ignore it."

	^ wrappedNode copyInContext: aDictionary! !

!RBPragmaEnvironment commentStamp: ''!
I am a RBBrowserEnvironment on a set of Pragmas.
I containt all entities that define methods using this pragmas.
Example:
(RBBrowserEnvironment new) forPragmas:{ #primitive:}.!
!RBPragmaEnvironment methodsFor: 'adding' stamp: ''!
addKeyword: aSymbol
	keywords add: aSymbol! !

!RBPragmaEnvironment methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	keywords := IdentitySet new.
	condition := [ :pragma | true ]! !

!RBPragmaEnvironment methodsFor: 'accessing' stamp: ''!
basisObjects
	^ keywords ! !

!RBPragmaEnvironment methodsFor: 'testing' stamp: ''!
includesCategory: aCategory
	^ (environment includesCategory: aCategory) and: [ (self classNamesFor: aCategory) notEmpty ]! !

!RBPragmaEnvironment methodsFor: 'testing' stamp: ''!
includesSelector: aSelector in: aClass
	(environment includesSelector: aSelector in: aClass)
		ifFalse: [ ^ false ].
	^ (aClass compiledMethodAt: aSelector) pragmas
		anySatisfy: [ :each | self includesPragma: each ]! !

!RBPragmaEnvironment methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	keywords := keywords copy! !

!RBPragmaEnvironment methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass
	^ (environment includesProtocol: aProtocol in: aClass) and: [ (self selectorsFor: aProtocol in: aClass) notEmpty ]! !

!RBPragmaEnvironment methodsFor: 'initialization' stamp: ''!
condition: aBlock
	condition := aBlock! !

!RBPragmaEnvironment methodsFor: 'testing' stamp: ''!
packages
	^ (self methods collect: [:each | each package]) asSet! !

!RBPragmaEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass
	^ (environment includesClass: aClass) and: [ aClass selectors anySatisfy: [ :each | self includesSelector: each in: aClass ] ]! !

!RBPragmaEnvironment methodsFor: 'initialization' stamp: ''!
keywords: aCollection
	keywords addAll: aCollection! !

!RBPragmaEnvironment methodsFor: 'testing' stamp: ''!
includesPragma: aPragma
	^ (keywords includes: aPragma selector) and: [ condition value: aPragma ]! !

!RBPragmaEnvironment methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream nextPut: $(.
	super storeOn: aStream.
	aStream nextPutAll: ' keywords: '.
	keywords asArray storeOn: aStream.
	aStream nextPut: $)! !

!RBPragmaEnvironment methodsFor: 'private' stamp: ''!
defaultLabel
	| stream |
	stream := String new writeStream.
	keywords do: [ :each | stream nextPut: $<; nextPutAll: each; nextPut: $>; nextPut: $ ].
	^ stream contents! !

!RBPragmaEnvironment class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'Pragmas'! !

!RBPragmaEnvironment class methodsFor: 'api' stamp: ''!
keywords: aKeywordCollection
	^ self
		onEnvironment: self default
		keywords: aKeywordCollection! !

!RBPragmaEnvironment class methodsFor: 'api' stamp: ''!
onEnvironment: anEnvironment keywords: aKeywordCollection
	^ (self onEnvironment: anEnvironment)
		keywords: aKeywordCollection;
		yourself! !

!RBPragmaErrorNode commentStamp: ''!
This is a particular englobing node that is a pragma.
Exemple : < pragma node >
Can be created by forgetting 
the closure : < pragma node .
Forgetting the opening will be assumed to be a binary selector.!
!RBPragmaErrorNode methodsFor: 'testing' stamp: ''!
isPragmaError
	^true! !

!RBPragmaErrorNode class methodsFor: 'construction' stamp: ''!
error: aToken withNodes: aCollection
	"A RBPragmaErrorNode can only be created from the opening token by choice.
	 Since the closure is a superior sign, the default assumption is that it's a binary selector."
	"If the collection is empty, there is only the token in the error."
	^aCollection isEmpty
		ifTrue: [ self new content: aCollection; start: aToken start; stop: aToken stop; errorMessage: '''>'' expected' ]
		ifFalse: [ self new content: aCollection; start: aToken start; stop: aCollection last stop; errorMessage: '''>'' expected' ]! !

!RBPragmaNode commentStamp: ''!
RBPragmaNode is an AST node that represents a method pragma.

We have a fixed set of allowed "primitive" pragma keywords. Every method implemented as a primitive call uses one of this pragmas.
And as we need some special treatment for methods implemented as primitive, the RBPragmaNode adds the #isPrimitive testing method.

Instance Variables:
	arguments <SequenceableCollection of: RBLiteralNode> our argument nodes
	left <Integer | nil> position of <
	right <Integer | nil> position of >
	selector	<Symbol>	the selector we're sending
	keywordsPositions	<IntegerArray | nil>	the positions of the selector keywords!
!RBPragmaNode methodsFor: 'accessing' stamp: ''!
stop
	^ right! !

!RBPragmaNode methodsFor: 'accessing - token' stamp: ''!
left: anInteger
	left := anInteger! !

!RBPragmaNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [^true].
	self class = anObject class ifFalse: [^false].
	self selector = anObject selector ifFalse: [^false].
	self arguments size = anObject arguments size ifFalse: [^false].
	self arguments
		with: anObject arguments
		do: [:first :second | first = second ifFalse: [^false]].
	^true! !

!RBPragmaNode methodsFor: 'comparing' stamp: ''!
hash
	^ self selector hash bitXor: (self hashForCollection: self arguments)! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
keywordsPositions
	^keywordsPositions ifNil: [ (selector keywords collect: [:char| 0 ]) asIntegerArray ]! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
numArgs
	^ self selector numArgs! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
arguments: aLiteralCollection 
	arguments := aLiteralCollection.
	arguments do: [ :each | each parent: self ]! !

!RBPragmaNode methodsFor: 'testing' stamp: ''!
isFaulty
	^self arguments anySatisfy: [:each | each isFaulty]! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
children
	^ arguments! !

!RBPragmaNode methodsFor: 'testing' stamp: ''!
isKeyword
	^(selector indexOf: $:) ~= 0.! !

!RBPragmaNode methodsFor: 'testing' stamp: ''!
isBinary
	^ (self isUnary or: [self isKeyword]) not! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
selectorParts
	^ selector keywords collect: [:keyword| keyword asSymbol ].! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
sentMessages
	^ super sentMessages
		add: self selector;
		yourself! !

!RBPragmaNode methodsFor: 'testing' stamp: ''!
isUnary
	^ arguments isEmpty! !

!RBPragmaNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isPrimitiveError
	^ #( primitive:error: primitive:module:error: primitive:error:module:) includes: self selector! !

!RBPragmaNode methodsFor: '*OpalCompiler-Core' stamp: ''!
asIRPrimitive
	"return a IRPrimitive for this method to be used in the compiler intermediate representation"
	| args module name spec |
	args := (self arguments collect: [ :each | each value ]) asArray.
	"normal methods have primitive number 0"
	self isPrimitive ifFalse: [ ^ IRPrimitive null ].
	^ args first isString
		ifTrue: [ name := args first.
			module := self argumentAt: #module: ifAbsent: [ nil ].
			spec := {(module ifNotNil: [ module value asSymbol ]) . name asSymbol . 0 . 0}.
			IRPrimitive new
				num: 117;
				spec: spec;
				yourself ]
		ifFalse: [ 
			"these are standard numbered primitives"
			IRPrimitive new
				num: args first;
				spec: nil;
				yourself ]! !

!RBPragmaNode methodsFor: 'accessing - token' stamp: ''!
right: anInteger
	right := anInteger! !

!RBPragmaNode methodsFor: 'testing' stamp: ''!
isPragma
	^ true! !

!RBPragmaNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	self arguments: (arguments collect: [ :each | 
		each == aNode 
			ifTrue: [ anotherNode ]
			ifFalse: [ each ] ])! !

!RBPragmaNode methodsFor: 'accessing - token' stamp: ''!
right
	^ right! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
argumentAt: keywordSelector ifAbsent: absentBlock
	self selectorParts with: self arguments do: [ :selectorPart :argument |
		selectorPart value = keywordSelector
			ifTrue: [ ^ argument ]].
	^ absentBlock value! !

!RBPragmaNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitPragmaNode: self! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!RBPragmaNode methodsFor: 'comparing' stamp: ''!
equalTo: anObject withMapping: aDictionary 
	self class = anObject class ifFalse: [ ^ false ].
	self selector = anObject selector ifFalse: [ ^ false ].
	self arguments size = anObject arguments size ifFalse: [ ^ false ].
	self arguments with: anObject arguments do: [ :first :second |
		(first equalTo: second withMapping: aDictionary) 
			ifFalse: [ ^ false ] ].
	^ true! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!RBPragmaNode methodsFor: 'testing' stamp: ''!
defines: aName
	^ self isPrimitive and: [ arguments anySatisfy: [ :each | each value = aName ] ]! !

!RBPragmaNode methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self arguments: (self arguments collect: [ :each | each copy ])! !

!RBPragmaNode methodsFor: 'accessing - token' stamp: ''!
left
	^ left! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
selector: aSelector 
	keywordsPositions := nil.
	selector := aSelector asSymbol.! !

!RBPragmaNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	arguments := #().
	keywordsPositions := #().
	left := 0.
	right := 0! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
keywordsPositions: aPositionsList
	keywordsPositions := aPositionsList ifNotNil: [:list| list asIntegerArray ].! !

!RBPragmaNode methodsFor: '*OpalCompiler-Core' stamp: ''!
primitiveErrorVariableName
	^(self argumentAt: #error:) value! !

!RBPragmaNode methodsFor: 'testing' stamp: ''!
isPrimitive
	^ #(primitive: primitive:error: primitive:error:module: primitive:module: primitive:module:error:) includes: self selector! !

!RBPragmaNode methodsFor: 'initialization' stamp: ''!
selector: aSymbol keywordsPositions: positionList arguments: valueNodes
	aSymbol numArgs == valueNodes size
		ifFalse: 
			[self error: 'Attempting to assign selector with wrong number of arguments.'].

	self 
		arguments: valueNodes;
		selector: aSymbol;
		keywordsPositions: positionList.! !

!RBPragmaNode methodsFor: '*NECompletion' stamp: ''!
completionEntries: offset
	^Symbol allSymbols 
		select: [ :each | each beginsWith: self selector] 
		thenCollect: [ :each | NECSymbolEntry contents: each node: self ]! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
argumentAt: keywordSelector
	^ self 
		argumentAt: keywordSelector
		ifAbsent: [ KeyNotFound signalFor: keywordSelector ]! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
start
	^ left! !

!RBPragmaNode methodsFor: 'matching' stamp: ''!
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: '*OpalCompiler-Core' stamp: ''!
asPragma
	^ Pragma
		selector: selector
		arguments: (arguments collect: [ :each | each value ]) asArray! !

!RBPragmaNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	^ self class
		selector: self selector
		arguments: (self arguments collect: [ :each | each copyInContext: aDictionary ])! !

!RBPragmaNode methodsFor: 'accessing' stamp: ''!
keywordsIntervals
	^selector keywords
		with: self keywordsPositions 
		collect: [:keyword :start| start to: (start = 0 ifTrue: [ -1 ] ifFalse: [ start + keyword size - 1]) ].! !

!RBPragmaNode class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol keywordsPositions: positionList arguments: valueNodes
	^ self new selector: aSymbol keywordsPositions: positionList arguments: valueNodes! !

!RBPragmaNode class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol arguments: valueNodes
	^ self selector: aSymbol keywordsPositions: nil arguments: valueNodes! !

!RBPrettyPrintCodeRefactoring commentStamp: ''!
I am a refactoring for reformat the source code of all methods in this environment.

I have no precondition.!
!RBPrettyPrintCodeRefactoring methodsFor: 'transforming' stamp: ''!
transform
	| source tree formatted |
	self model
		allClassesDo: [ :class | 
			class selectors
				do: [ :selector | 
					(self model environment includesSelector: selector in: class realClass)
						ifTrue: [ source := class sourceCodeFor: selector.
							source
								ifNotNil: [ tree := class parseTreeFor: selector.
									tree
										ifNotNil: [ formatted := tree formattedCode.
											(source ~= formatted
												and: [ (self parserClass parseMethod: formatted) = tree ])
												ifTrue:
													[ class compile: formatted classified: (class protocolsFor: selector) ] ] ] ] ] ]! !

!RBPrettyPrintCodeRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ self emptyCondition! !

!RBProgramNode commentStamp: ''!
RBProgramNode is an abstract class that represents an abstract syntax tree node in a Smalltalk program.

Subclasses must implement the following messages:
	accessing
		start
		stop
	visitor
		acceptVisitor:
	testing
		isFaulty

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.

The #isFaulty method is used to distinguish between valid nodes and nodes created from an invalid source Smalltalk code. For example, code parsed with RBParsers #parseFaultyExpression: or #parseFaultyMethod:.

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:
	properties	<Dictionary of: Symbol -> Object>	A set of properties set to this node, for example every node can have the Property #comment to attach the method comment or the comment of the code line this node represents. Other classes or tools may add more type of properties; for example, the reflectivity support adds properties for managing Metalinks. 
	parent	<RBProgramNode>	the node we're contained in

Class Variables:
	FormatterClass	<Behavior>	the formatter class that is used when we are formatted
!
!RBProgramNode methodsFor: 'properties' stamp: ''!
removeProperty: aKey ifAbsent: aBlock
	"Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."
	
	| answer |
	properties ifNil: [ ^ aBlock value ].
	answer := properties removeKey: aKey ifAbsent: aBlock.
	properties isEmpty ifTrue: [ properties := nil ].
	^ answer! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
formattedCode
	^ self formatterClass new format: self! !

!RBProgramNode methodsFor: 'properties' stamp: ''!
propertyAt: aKey
	"Answer the property value associated with aKey."
	
	^ self propertyAt: aKey ifAbsent: [ self error: 'Property not found' ]! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
preambles
	^self propertyAt: #preambles ifAbsent: #()! !

!RBProgramNode methodsFor: 'testing - matching' stamp: ''!
recurseInto
	^false! !

!RBProgramNode methodsFor: 'accessing - meta variable' stamp: ''!
statementCharacter
	^$.! !

!RBProgramNode methodsFor: 'replacing' stamp: ''!
clearReplacements
	parent ifNil: [^self].
	parent clearReplacements! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
variableDefinitionNodes
	^ self allChildren select: [ :each | 
		  each isVariable and: [ each isDefinition ] ]! !

!RBProgramNode methodsFor: '*Renraku' stamp: ''!
match: aNode onSuccess: aBlock onFailure: anAlternativeBlock 
	| context |
	
	context := SmallDictionary new.
	
	(self match: aNode inContext: context)
		ifTrue: [ aBlock cull: context ]
		ifFalse: anAlternativeBlock! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
containsReturn
	^self children anySatisfy: [:each | each containsReturn]! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
sendNodes
	^self allChildren select: [:each | each isMessage].! !

!RBProgramNode methodsFor: 'copying' stamp: ''!
copyCommentsFrom: aNode 
	"Add all comments from aNode to us. If we already have the comment, then don't add it."

	| newComments |
	newComments := OrderedCollection new.
	aNode nodesDo: [:each | newComments addAll: each comments].
	self nodesDo: 
			[:each | 
			each comments do: [:comment | newComments remove: comment ifAbsent: []]].
	newComments isEmpty ifTrue: [^self].
	newComments := newComments asSortedCollection: [:a :b | a start < b start].
	self comments: newComments! !

!RBProgramNode methodsFor: 'enumeration' stamp: ''!
do: aBlock 
	"Hacked to fit collection protocols"

	aBlock value: self! !

!RBProgramNode methodsFor: 'replacing' stamp: ''!
replaceWith: aNode 
	parent ifNil: [self error: 'This node doesn''t have a parent'].
	self replaceMethodSource: aNode.
	parent replaceNode: self withNode: aNode! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
linkIfAbsent: metalink
	"Per-object check only.
	Links and nodes are stored in IdentitySet so there is already a guarantee that there will be no duplicates. However putting a link already existing for a given node will retrigger method compilation.
	This check is used by MetaLinkInstaller only to avoid multiple and recursive reinstallation of links on nodes." 
	(self hasMetaLinks and: [ self links includes: metalink ])
		ifTrue: [ ^ self ].
	self link: metalink! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
postambles
	^self propertyAt: #postambles ifAbsent: #()! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasMetalinkInstead
		self hasMetalink ifFalse: [^false].
		^self insteadLinks isNotEmpty! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink
	(aMetaLink checkForCompatibilityWith: self)
		ifFalse: [ self error: 'link requests reification that can not be provided by this node' ].
	(self propertyAt: #links ifAbsentPut: [ OrderedCollection new ]) add: aMetaLink.
	aMetaLink installOn: self.
	self clearReflectivityAnnotations.
	self methodNode method installLink: aMetaLink.
	aMetaLink linkInstaller propagateLinkAddition: aMetaLink forNode: self.
	aMetaLink announceInstall: self! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
clearReflectivityAnnotations
	self removeProperty: #preambles ifAbsent: [ ].
	self removeProperty: #beforeHooks ifAbsent: [ ].
	self removeProperty: #afterHooks ifAbsent: [ ].
	self removeProperty: #insteadHooks ifAbsent: [ ].! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
sourceInterval
	^ self start to: self stop! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
removeLink: aMetaLink forObject: anObject
	aMetaLink unlinkFromNode: self forObject: anObject! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isArgumentVariable
	^ false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isHaltNode
	^ false! !

!RBProgramNode methodsFor: 'testing - matching' stamp: ''!
isPatternNode
	^false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isThisContextVariable
	^ false! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasMetalink
	^self hasProperty: #links! !

!RBProgramNode methodsFor: 'enumeration' stamp: ''!
size
	"Hacked to fit collection protocols"

	^1! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
nodesWithLinks
	^ self allChildren select: [ :e | e links isNotEmpty ]! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
invalidate
	self methodNode method invalidate. ! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isSuperVariable
	^false! !

!RBProgramNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary 
	^ self = aNode! !

!RBProgramNode methodsFor: '*Renraku' stamp: ''!
package
	"a hack to make the critique check working"
	"the package information is used to determin bans"

	^ nil! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
links
	^self propertyAt: #links ifAbsent: #()! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
temporaryVariables
	^parent ifNil: [#()] ifNotNil: [parent temporaryVariables]! !

!RBProgramNode methodsFor: 'enumeration' stamp: ''!
reverseNodesDo: aBlock 
	self children reverseDo: [ :each | each reverseNodesDo: aBlock ].
	aBlock value: self! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isFaulty
	"return true if the AST contains a RBParseErrorNode"
	^false! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
getCommentsFor: anInterval
	| selectedComments |
	selectedComments := OrderedCollection new.
	self nodesDo: 
		[ :each | 
			| comments | 
			comments := each comments select: 
				[ :com | com intersectsInterval: anInterval ]. 
	"This precaution is taken to deal with cascades multiple visit of the receiver."
			(selectedComments isNotEmpty 
				and: [ comments isNotEmpty 
				and: [ comments last = selectedComments last ]]) 
					ifFalse: [selectedComments addAll: comments ] ].
	^ selectedComments! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isSelfVariable
	^ false! !

!RBProgramNode methodsFor: '*OpalCompiler-Core' stamp: ''!
doSemanticAnalysisIn: aClass
	self methodNode ifNil: [ ^self ].
	^ self methodNode doSemanticAnalysisIn: aClass! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
parent
	^parent! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
bestNodeFor: anInterval 
	| selectedChildren selectedComments |
	anInterval ifNil: [^nil ].
	selectedComments := self getCommentsFor: anInterval.
	(self intersectsInterval: anInterval) ifFalse: [^selectedComments ifNil: [ nil ] ifNotNil: [ selectedComments size = 1 ifTrue: [ selectedComments first ] ifFalse: [ nil ] ] ].
	(self containedBy: anInterval) ifTrue: [^self].
	
	selectedChildren := self children select: [:each | 
		each intersectsInterval: anInterval
	].

	^ selectedChildren size = 1 
		ifTrue: [ selectedChildren first bestNodeFor: anInterval ]
		ifFalse: [ (selectedChildren isEmpty and: [ selectedComments size = 1 ])
							ifTrue: [ selectedComments first ]
							ifFalse: [ self ] ]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
uses: aNode
	^true! !

!RBProgramNode methodsFor: 'replacing' stamp: ''!
addReplacement: aStringReplacement
	parent ifNil: [^self].
	parent addReplacement: aStringReplacement! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasLinks
	self 
		deprecated: 'use #hasMetaLinks'
		transformWith:  '`@receiver hasLinks' -> '`@receiver hasMetaLinks'.
	^self hasMetaLinks! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasBeenExecuted
	^self propertyAt: #tagExecuted ifAbsent: false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isUnfinishedStatement
	^false! !

!RBProgramNode methodsFor: 'node access' stamp: ''!
nodeForOffset: anInteger
	| children |
	"choosing the best node on the specific offset"
	children := self children.
	"when we are on a leaf, we take the leaf node"
	(children isEmpty) ifTrue: [ (self sourceInterval includes: anInteger) ifTrue: [^self]].
	"if the node has children then we check the children"
	children do: [:each | (each sourceInterval includes: anInteger) ifTrue: [^each nodeForOffset: anInteger] ].! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasExecutionCounter
	
	self hasMetalinkBefore ifFalse: [ ^false ].
	^self beforeLinks anySatisfy: [ :link | link metaObject class = ExecutionCounter ]! !

!RBProgramNode methodsFor: '*NECompletion' stamp: ''!
completionEntries: offset
	"for now we give all selectors and gloabls as a fallback"
	| selectors globals |
	self methodNode sourceCode ifNil: [ ^#() ].
	selectors := Symbol selectorTable 
		select: [ :each | each beginsWith: (self completionToken: offset)] 
		thenCollect: [ :each | NECSymbolEntry contents: each node: self ].
		
	globals := Smalltalk globals keys 
			select: [ :each | each beginsWith: (self completionToken: offset)]
			thenCollect: [ :each | NECGlobalEntry contents: each  node: self ].
			
	^ selectors , globals! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
hasComments
	"Answer whether the receiver as comments"
	
	^ self comments isNotEmpty! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
counter
	
	self hasExecutionCounter ifFalse:[^nil].
	^(self beforeLinks detect: [ :link | link metaObject class = ExecutionCounter]) metaObject! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isGlobalVariable
	^false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
assigns: aVariableName 
	^self children anySatisfy: [:each | each assigns: aVariableName]! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
formatterClass
	^ self class formatterClass! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isCascade
	^false! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
stop
	self subclassResponsibility! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isLiteralNode
	^false! !

!RBProgramNode methodsFor: 'matching' stamp: ''!
copyList: matchNodes inContext: aDictionary 
	| newNodes |
	newNodes := OrderedCollection new.
	matchNodes do: 
			[:each | 
			| object |
			object := each copyInContext: aDictionary.
			newNodes addAll: object].
	^newNodes! !

!RBProgramNode methodsFor: 'properties' stamp: ''!
propertyAt: aKey put: anObject
	"Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."

	^ (properties ifNil: [ properties := SmallDictionary new: 1 ])
		at: aKey put: anObject! !

!RBProgramNode methodsFor: 'comparing' stamp: ''!
hashForCollection: aCollection
	^ aCollection isEmpty ifTrue: [ 0 ] ifFalse: [ aCollection first hash ]! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
afterHooks
	^self propertyAt: #afterHooks ifAbsent: #()! !

!RBProgramNode methodsFor: 'hook' stamp: ''!
parserClass
	^ RBParser! !

!RBProgramNode methodsFor: 'iterating' stamp: ''!
allChildren
	| children |
	children := OrderedCollection new.
	self nodesDo: [ :each | children addLast: each ].
	^ children! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isDynamicArray
	^ false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isLiteralArrayError
	^false! !

!RBProgramNode methodsFor: 'iterating' stamp: ''!
nodesDo: aBlock 
	aBlock value: self.
	self children do: [ :each | each nodesDo: aBlock ]! !

!RBProgramNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isClean
	^ self children allSatisfy: [ :child | child isClean ]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
lastIsReturn
	^self isReturn! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
methodNode
	^parent ifNotNil: [parent methodNode]! !

!RBProgramNode methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	properties := properties copy! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isBlockError
	^false! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
statementComments
	| statementComments |
	statementComments := OrderedCollection withAll: self comments.
	self children do: [:each | statementComments addAll: each statementComments].
	^statementComments asSortedCollection: [:a :b | a start < b start]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isInstanceVariable
	^false! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
newSource
	^self formattedCode! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
bestNodeForPosition: aPosition

	"aPosition is an integer that represents the position of the caret. 
	A value of N represents that the caret is between the characters N-1 and N.
	The position 1 is at beginning of the text.
	
	Position Heuristic: If the previous character is not a separator, take selection one position before.
		This heuristic is for the cases where the caret (|) is:
		   |self foo  => the caret is before self, do not move
		   self foo|  => the caret is before foo, interpret is as if we are in foo.
			self foo | => the caret is before a space, interpret is as if we are in foo.

		This heuristic introduces although an ambiguity when code is not nicely formatted:
		   self foo:|#bar => Here a user may want foo: or bar.
		For now we decided to favor foo: to motivate people to indent code correctly	"

	| offset position precededBySeparator |
	precededBySeparator := [ 
	                       (aPosition
		                        between: 2
		                        and: self methodNode sourceCode size + 1) 
		                       and: [ 
		                       (self methodNode sourceCode at: aPosition - 1)
			                       isSeparator ] ].
	offset := (aPosition = 1 or: precededBySeparator)
		          ifTrue: [ 0 ]
		          ifFalse: [ -1 ].

	position := aPosition + offset min: self stop.

	^ self bestNodeFor: (position to: position)! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
insteadLinks
	^ self links select: [ :each | each control == #instead ]! !

!RBProgramNode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionTree
	<inspectorPresentationOrder: 35 title: 'Tree'>

	^ SpTreePresenter new 
		roots: { self };
		children: [ :aNode | aNode children ];
		display: [ :each | 
			String
				streamContents: [ :stream | 
					stream
						nextPutAll: each class name;
						nextPut: $(;
						nextPutAll: ((each formattedCode truncateTo: 50) copyReplaceAll: String cr with: String space);
						nextPut: $)
			 ] ];
		yourself! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isPragmaError
	^false! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
sourceCode

	| interval |
	interval := self sourceInterval.
	interval ifEmpty: [ ^ '' ].
	
	^ self source 
		copyFrom: interval first
		to: interval last! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
allParents
	"return all my parents. 
	See discussion in issue https://github.com/pharo-project/pharo/issues/6278"
	^ parent 
		ifNil: [ OrderedCollection new ]
		ifNotNil: [ parent withAllParents ]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isClassVariable
	^ false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isWorkspaceVariable
	^false! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
allArgumentVariables
	| children |
	children := self children.
	children isEmpty ifTrue: [^#()].
	^children inject: OrderedCollection new
		into: 
			[:vars :each | 
			vars
				addAll: each allArgumentVariables;
				yourself]! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
removeLink: aMetaLink
	self hasMetalink
		ifFalse: [ ^ self ].
	self links remove: aMetaLink ifAbsent: [  ].
	self links ifEmpty: [ self removeProperty: #links ].
	self clearReflectivityAnnotations.
	(self methodNode methodClass methodDict includesKey: self methodNode selector)
		ifFalse: [ ^ self ].
	self methodNode method removeLink: aMetaLink.
	aMetaLink linkInstaller propagateLinkRemoval: aMetaLink forNode: self.
	aMetaLink announceRemove: self! !

!RBProgramNode methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream
		nextPutAll: self class name;
		nextPut: $(;
		nextPutAll: self formattedCode;
		nextPut: $)! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isUsed
	"Answer true if this node could be used as part of another expression. For example, you could use the 
	result of this node as a receiver of a message, an argument, the right part of an assignment, or the 
	return value of a block. This differs from isDirectlyUsed in that it is conservative since it also includes 
	return values of blocks."

	^parent ifNil: [false] ifNotNil: [parent uses: self]! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
sentMessages
	^ self children
		inject: Set new
		into: [ :messages :each | 
			messages
				addAll: each sentMessages;
				yourself ]! !

!RBProgramNode methodsFor: '*OpalCompiler-Core' stamp: ''!
doSemanticAnalysis
	self methodNode ifNil: [ ^self ].
	^ self methodNode doSemanticAnalysis.! !

!RBProgramNode methodsFor: '*Renraku' stamp: ''!
suitableRulesFrom: aReRuleManager 
	^ aReRuleManager nodeRules! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
allTemporaryVariables
	| children |
	children := self children.
	children isEmpty ifTrue: [^#()].
	^children inject: OrderedCollection new
		into: 
			[:vars :each | 
			vars
				addAll: each allTemporaryVariables;
				yourself]! !

!RBProgramNode methodsFor: '*Renraku' stamp: ''!
banChecksForValidation
"returns ban levels that have to be chacked before validation"

	self methodNode ifNotNil: [ :mNode |
		mNode compiledMethod ifNotNil: [ :method |
			^ method banChecksForValidation ] ].
	
	^ #()! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
whichNodeIsContainedBy: anInterval 
	| selectedChildren |
	(self intersectsInterval: anInterval) ifFalse: [^nil].
	(self containedBy: anInterval) ifTrue: [^self].
	selectedChildren := self children 
				select: [:each | each intersectsInterval: anInterval].
	^selectedChildren size == 1 
		ifTrue: [selectedChildren first whichNodeIsContainedBy: anInterval]
		ifFalse: [nil]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isValue
	^false! !

!RBProgramNode methodsFor: 'testing - matching' stamp: ''!
isList
	^false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isPragma
	^false! !

!RBProgramNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	self error: 'I don''t store other nodes'! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isLiteralArray
	^false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
evaluatedFirst: aNode 
	self children do: 
			[:each | 
			each == aNode ifTrue: [^true].
			each isImmediateNode ifFalse: [^false]].
	^false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
defines: aName
	^false! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
variableReadNodes
	^self variableNodes select: [:each | each isRead]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isParseError
	^false! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
allComments
	"Answer a collection of objects representing the comments in the method. Return an empty collection if the method's source code does not contain a comment."

	^ self allChildren flatCollect: [:el| el comments]! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
variableValueInContext: aContext
	^nil! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
allVariables
	"Return all the variables in subnodes"

	^ self allChildren select: [ :each | each isVariable ]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isDirectlyUsed
	"This node is directly used as an argument, receiver, or part of an assignment."

	^parent ifNil: [false] ifNotNil: [parent directlyUses: self]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isReservedVariable
	^false! !

!RBProgramNode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionSourceCode
	<inspectorPresentationOrder: 30 title: 'Source code'>

	^ SpCodePresenter new 
		beForBehavior: self methodNode methodClass;
		text: (self source ifNil: [ self formattedCode ]);
		addTextSegmentDecoration: (SpTextPresenterDecorator forHighlight
			interval: (self sourceInterval first to: self sourceInterval last + 1);
			yourself);
		yourself! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isArrayError
	^false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isParenthesesError
	^false! !

!RBProgramNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary
	^ self copy! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
methodOrBlockNode
	^ parent ifNotNil: [ parent methodOrBlockNode ]! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
whoDefines: aName 
	^(self defines: aName) 
		ifTrue: [self]
		ifFalse: [parent notNil ifTrue: [parent whoDefines: aName] ifFalse: [nil]]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isAssignment
	^false! !

!RBProgramNode methodsFor: '*OpalCompiler-Core' stamp: ''!
asDoit
	"The VM can only evaluate methods. wrap this ast in a doit MethodNode"
	| methodNode |
	
	methodNode := RBMethodNode 
		selector: #DoIt
		body: self asSequenceNode transformLastToReturn.
	methodNode source: methodNode formattedCode.
	^methodNode! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
instanceVariableReadNodes
		^self variableReadNodes select: [:each | each isInstanceVariable]! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
children
	^#()! !

!RBProgramNode methodsFor: '*Renraku' stamp: ''!
nodeAtTraversalIndex: anIndex
	| index |
	index := 0.

	self nodesDo: [ :n |
		index := index + 1.
		index = anIndex ifTrue: [ ^ n ] ].
	
	NotFound signal.! !

!RBProgramNode methodsFor: 'private - replacing' stamp: ''!
replaceSourceWith: aNode 
	aNode replaceSourceFrom: self! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
containedBy: anInterval 
	^anInterval first <= self start and: [anInterval last >= self stop]! !

!RBProgramNode methodsFor: '*OpalCompiler-Core' stamp: ''!
asSequenceNode
	^RBSequenceNode statements: {self}! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
allDefinedVariables
	| children |
	children := self children.
	children isEmpty ifTrue: [^#()].
	^children inject: OrderedCollection new
		into: 
			[:vars :each | 
			vars
				addAll: each allDefinedVariables;
				yourself]! !

!RBProgramNode methodsFor: '*OpalCompiler-Core' stamp: ''!
asDoitForContext: aContext
	"The VM can only evaluate methods. wrap this ast in a doitIn MethodNode to evaluate in a context"
	| methodNode |
	
	methodNode := RBMethodNode 
		selector: #DoItIn:
		arguments: { RBVariableNode named: 'ThisContext' } 
		body: self asSequenceNode transformLastToReturn.
	
	methodNode methodClass: aContext receiver class.
	methodNode rewriteTempsForContext: aContext.
	methodNode source: methodNode formattedCode.
	^methodNode! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
debugHighlightStop

	^ self stop! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
watch
	
	self hasWatch ifFalse:[^nil].
	^(self afterLinks detect: [ :link | link metaObject class = Watch ]) metaObject! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isLocalVariable
	^false! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
debugHighlightRange

	^ self debugHighlightStart to: self debugHighlightStop! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
intersectsInterval: anInterval 
	^(anInterval first between: self start and: self stop) 
		or: [self start between: anInterval first and: anInterval last]! !

!RBProgramNode methodsFor: 'accessing - meta variable' stamp: ''!
literalCharacter
	^$#! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isUndeclaredVariable
	^false! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink forObject: anObject
	aMetaLink linkToNode: self forObject: anObject! !

!RBProgramNode methodsFor: 'comparing' stamp: ''!
equalTo: aNode withMapping: aDictionary 
	^self = aNode! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
blockVariables
	^parent ifNil: [#()] ifNotNil: [parent blockVariables]! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasBreakpoint
	^ (self hasProperty: #breakpoints) and: [ self breakpoints notEmpty ]! !

!RBProgramNode methodsFor: '*Renraku' stamp: ''!
critiques
	^ ReCriticEngine critiquesOf: self! !

!RBProgramNode methodsFor: 'accessing - meta variable' stamp: ''!
cascadeListCharacter
	^$;! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
directlyUses: aNode
	^true! !

!RBProgramNode methodsFor: 'properties' stamp: ''!
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: 'querying' stamp: ''!
variableWriteNodes
		^self variableNodes select: [:each | each isWrite]! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
variableNodes

	^ self allChildren select: [ :each | 
		  each isVariable and: [ each isDefinition not ] ]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isVariable
	^false! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
allStatements
	| children |
	children := self children.
	children isEmpty ifTrue: [^#()].
	^children inject: OrderedCollection new
		into: 
			[:vars :each | 
			vars
				addAll: each allStatements;
				yourself]! !

!RBProgramNode methodsFor: '*OpalCompiler-Core' stamp: ''!
irInstruction
	^ self methodOrBlockNode ir firstInstructionMatching: [:instr | instr sourceNode == self ]! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
mappingFor: aNode
	| method |
	method := self methodNode.
	method ifNil: [^aNode].
	^method mappingFor: aNode! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
precedence
	^6! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isSelfOrSuperVariable
	^false! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
tagExecuted
	^self propertyAt: #tagExecuted put: true ! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
availableReifications
	^RFReification subclasses 
		select: [ :e | e entities includesAny: self class withAllSuperclasses ]
		thenCollect: #key
! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isEvaluatedFirst
	"Return true if we are the first thing evaluated in this statement."

	^parent isNil or: [parent isSequence or: [parent evaluatedFirst: self]]! !

!RBProgramNode methodsFor: '*OpalCompiler-Core' stamp: ''!
owningScope

	^ parent owningScope! !

!RBProgramNode methodsFor: 'testing - matching' stamp: ''!
canMatchMethod: aCompiledMethod 
	^self sentMessages allSatisfy: 
			[:each | 
			(self class optimizedSelectors includes: each) 
				or: [aCompiledMethod refersToLiteral: each]]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isEnglobingError
	^false! !

!RBProgramNode methodsFor: 'private - replacing' stamp: ''!
replaceSourceFrom: aNode
	self == aNode
		ifFalse: [ self clearReplacements ]! !

!RBProgramNode methodsFor: 'matching' stamp: ''!
matchList: matchNodes index: matchIndex against: programNodes index: programIndex inContext: aDictionary 
	| node currentIndex currentDictionary nodes |
	matchNodes size < matchIndex ifTrue: [^programNodes size < programIndex].
	node := matchNodes at: matchIndex.
	node isList 
		ifTrue: 
			[currentIndex := programIndex - 1.
			
			[currentDictionary := aDictionary copy.
			programNodes size < currentIndex or: 
					[nodes := programNodes copyFrom: programIndex to: currentIndex.
					(currentDictionary at: node ifAbsentPut: [nodes]) = nodes and: 
							[(self 
								matchList: matchNodes
								index: matchIndex + 1
								against: programNodes
								index: currentIndex + 1
								inContext: currentDictionary) 
									ifTrue: 
										[currentDictionary 
											keysAndValuesDo: [:key :value | aDictionary at: key put: value].
										^true].
							false]]] 
					whileFalse: [currentIndex := currentIndex + 1].
			^false].
	programNodes size < programIndex ifTrue: [^false].
	(node match: (programNodes at: programIndex) inContext: aDictionary) 
		ifFalse: [^false].
	^self 
		matchList: matchNodes
		index: matchIndex + 1
		against: programNodes
		index: programIndex + 1
		inContext: aDictionary! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasMetalinkAfter
	self hasMetalink ifFalse: [^false].
	^self afterLinks isNotEmpty! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
breakpoints
	^ self propertyAt: #breakpoints ifAbsentPut: [ Set new ]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isSequence
	^false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isTempVariable
	^ false! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
superMessages
	^(self sendNodes select: [ :node | node isSuperSend ] thenCollect: [ :node | node selector ]) asSet! !

!RBProgramNode methodsFor: 'properties' stamp: ''!
propertyAt: aKey ifAbsent: aBlock
	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
	
	^ properties 
		ifNil: aBlock
		ifNotNil: [ properties at: aKey ifAbsent: aBlock ]! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasMetalink: aMetaLink
	^self links includes: aMetaLink! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
allAfterAreWeak
	self hasMetalink ifFalse: [^false].
	self isMessage ifFalse:  [^false]. "only sends are weak"
	^self afterLinks allSatisfy: [ :link | link hasOption: #optionWeakAfter ].! !

!RBProgramNode methodsFor: '*NECompletion' stamp: ''!
completionToken: offset
	"fall back: if we are not able to parse to something better, we use the word before the cursor"

	^ self methodNode sourceCode
		  ifNil: [ String new ]
		  ifNotNil: [ :source | source wordBefore: offset ]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isMethod
	^false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isLiteralVariable
	^false! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
beforeLinks
	^ self links select: [ :each | each control == #before ]! !

!RBProgramNode methodsFor: '*Renraku' stamp: ''!
traversalIndexOf: aNode
	| index |
	index := 0.

	self nodesDo: [ :n |
		index := index + 1.
		n == aNode ifTrue: [ ^ index ] ].
	
	^ -1.! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
debugHighlightStart

	^ self start! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
comments: aCollection

	(aCollection ifNil: [#()])
		ifEmpty: [ self removeProperty: #comments ifAbsent: [] ] 
		ifNotEmpty: [ self propertyAt: #comments put: aCollection ].! !

!RBProgramNode methodsFor: 'replacing' stamp: ''!
removeDeadCode
	self children do: [:each | each removeDeadCode]! !

!RBProgramNode methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
enabledForHaltOrBreakpoint
	^self propertyAt: #enabledForHaltOrBreakpoint ifAbsent: [ true ]! !

!RBProgramNode methodsFor: 'matching' stamp: ''!
matchList: matchNodes against: programNodes inContext: aDictionary 
	^self
		matchList: matchNodes
		index: 1
		against: programNodes
		index: 1
		inContext: aDictionary! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
references: aVariableName 
	^self children anySatisfy: [:each | each references: aVariableName]! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasMetalinkBefore
	self hasMetalink ifFalse: [^false].
	^self beforeLinks isNotEmpty! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
asReturn
	"Change the current node to a return node."

	parent ifNil: [self error: 'Cannot change to a return without a parent node.'].
	parent isSequence 
		ifFalse: [self error: 'Parent node must be a sequence node.'].
	(parent isLast: self) ifFalse: [self error: 'Return node must be last.'].
	^parent addReturn! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasWatch
	
	self hasMetalinkAfter ifFalse: [ ^false ].
	^self afterLinks anySatisfy: [ :link | link metaObject class = Watch ]! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
start
	self subclassResponsibility! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
statementNode
	"Return your topmost node that is contained by a sequence node."

	(parent isNil or: [parent isSequence]) ifTrue: [^self].
	^parent statementNode! !

!RBProgramNode methodsFor: '*OpalCompiler-Core' stamp: ''!
scope
	^ self methodOrBlockNode scope! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
hasMetaLinks
	^ self links notNil and: [ self links notEmpty ]! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
afterLinks
	^ self links select: [ :each | each control == #after ]! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
removeBreakpoint: aBreakpoint
	self breakpoints remove: aBreakpoint ifAbsent: []! !

!RBProgramNode methodsFor: 'replacing' stamp: ''!
replaceMethodSource: aNode 
	"We are being replaced with aNode -- if possible try to perform an in place edit of the source."

	| method |
	method := self methodNode.
	method notNil ifTrue: [method map: self to: aNode].
	aNode parent: self parent.
	[self replaceSourceWith: aNode] on: Error
		do: 
			[:ex | 
			self clearReplacements.
			ex return]! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
instanceVariableNodes
		^self variableNodes select: [:each | each isInstanceVariable]! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
source
	^ parent notNil ifTrue: [ parent source ] ifFalse: [ nil ]! !

!RBProgramNode methodsFor: 'generation' stamp: ''!
dump
	"Generate a literal expression that recreates the receiver"

	| visitor |
	visitor := RBDumpVisitor new.
	self acceptVisitor: visitor.
	^ visitor contents! !

!RBProgramNode methodsFor: 'enumeration' stamp: ''!
collect: aBlock 
	"Hacked to fit collection protocols"

	^aBlock value: self! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
blockNodes
	^self allChildren select: [:each | each isBlock].! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
isEquivalentTo: aNode
	self flag: 'should be tested, does not work on methods after links because of the wrappping now in place'.
	^ aNode methodNode selector = self methodNode selector
		and: [ aNode = self and: [ aNode start = self start and: [ aNode stop = self stop ] ] ]! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
tempVariableReadNodes
		^self variableReadNodes select: [:each | each isTempVariable]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
hasMultipleReturns
	| count |
	count := 0.
	self nodesDo: [:each | each isReturn ifTrue: [count := count + 1]].
	^count > 1! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
instanceVariableWriteNodes
		^self variableWriteNodes select: [:each | each isInstanceVariable]! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
assignmentNodes
	^self allChildren select: [:each | each isAssignment].! !

!RBProgramNode methodsFor: 'querying' stamp: ''!
selfMessages
	^(self sendNodes select: [ :node | node isSelfSend ] thenCollect: [ :node | node selector ]) asSet! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
addBreakpoint: aBreakpoint
	self breakpoints add: aBreakpoint ! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isCommentNode
	^false! !

!RBProgramNode methodsFor: '*Renraku' stamp: ''!
banLevelCandidates
"returns code entities which can ban a rule for this entity"

	self methodNode ifNotNil: [ :mNode |
		mNode compiledMethod ifNotNil: [ :method |
			^ method banLevelCandidates ] ].
	
	^ #()! !

!RBProgramNode methodsFor: 'accessing - meta variable' stamp: ''!
listCharacter
	^$@! !

!RBProgramNode methodsFor: 'comparing' stamp: ''!
equalTo: aNode exceptForVariables: variableNameCollection 
	| dictionary |
	dictionary := Dictionary new.
	(self equalTo: aNode withMapping: dictionary) ifFalse: [^false].
	dictionary keysAndValuesDo: 
			[:key :value | 
			(key = value or: [variableNameCollection includes: key]) ifFalse: [^false]].
	^true! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isImmediateNode
	^false! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isLast: aNode 
	| children |
	children := self children.
	^children notEmpty and: [children last == aNode]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isSelector
	^false! !

!RBProgramNode methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
enableHalts: aBoolean
	^self propertyAt: #enabledForHaltOrBreakpoint put: aBoolean! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
parent: aRBProgramNode 
	parent := aRBProgramNode! !

!RBProgramNode methodsFor: 'properties' stamp: ''!
propertyAt: aKey ifPresent: aPresentBlock ifAbsent: anAbsentBlock
	"Answer the property value associated with aKey or, if aKey is found, answer the result of evaluating aPresentBlock, else evaluates anAbsentBlock."

	^ properties ifNil: anAbsentBlock ifNotNil: [ properties at: aKey ifPresent: aPresentBlock ifAbsent: anAbsentBlock ]! !

!RBProgramNode methodsFor: 'accessing - meta variable' stamp: ''!
recurseIntoCharacter
	^$`! !

!RBProgramNode methodsFor: 'properties' stamp: ''!
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: 'testing' stamp: ''!
isReturn
	^false! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
withAllParents
	"return me and all my parents. Topmost parent first, me last
	See discussion in issue https://github.com/pharo-project/pharo/issues/6278"
	^ parent 
		ifNil: [ OrderedCollection with: self ]
		ifNotNil: [ 
			parent withAllParents 
				addLast: self;
				yourself ]! !

!RBProgramNode methodsFor: 'properties' stamp: ''!
hasProperty: aKey
	"Test if the property aKey is present."
	
	^ properties notNil and: [ properties includesKey: aKey ]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isTemporariesError
	^false! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
insteadHooks
	^self propertyAt: #insteadHooks ifAbsent: #()! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
statements
	^ #()! !

!RBProgramNode methodsFor: '*Reflectivity' stamp: ''!
beforeHooks
	^self propertyAt: #beforeHooks ifAbsentPut: OrderedCollection new! !

!RBProgramNode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionASTDump
	<inspectorPresentationOrder: 50 title: 'AST Dump'>

	^ SpCodePresenter new 
		text: (RBParser parseExpression: self dump) formattedCode; 
		beForScripting; "this is an expression"
		yourself! !

!RBProgramNode methodsFor: 'accessing' stamp: ''!
comments
	"Answer the comments of the receiving parse tree node"
	
	^ (self propertyAt: #comments ifAbsent: [ #() ]) ifNil:[ #() ]! !

!RBProgramNode methodsFor: 'testing' stamp: ''!
isMessage
	^false! !

!RBProgramNode class methodsFor: 'accessing' stamp: ''!
resetFormatter

	self formatterClass: nil! !

!RBProgramNode class methodsFor: 'accessing' stamp: ''!
optimizedSelectors
	^ #( and: caseOf: caseOf:otherwise: ifFalse: ifFalse:ifTrue: ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: ifTrue: ifTrue:ifFalse: or: to:by:do: to:do: whileFalse whileFalse: whileTrue whileTrue: )! !

!RBProgramNode class methodsFor: 'accessing' stamp: ''!
formatterClass: aClass
	FormatterClass := aClass! !

!RBProgramNode class methodsFor: '*Formatter-Settings' stamp: ''!
settingsGroupOn: aBuilder
	<systemsettings>
	
	(aBuilder group: #codeFormatters)
		label: 'Code Formatting';
		parent: #codeBrowsing! !

!RBProgramNode class methodsFor: '*Formatter-Settings' stamp: ''!
formatters

	^ RBProgramNodeVisitor subclasses select: [ :each | each name endsWith: 'Formatter' ]! !

!RBProgramNode class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBProgramNode! !

!RBProgramNode class methodsFor: '*Formatter-Settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	(aBuilder pickOne: #formatterClass)
		target: RBProgramNode ;
		domainValues: self formatters; 
		label: 'Default Formatter';
		order: 0;
		default: (Smalltalk at: #EFFormatter);
		description: 'To set the default code formatter.';
		parent: #codeFormatters! !

!RBProgramNode class methodsFor: 'accessing' stamp: ''!
formatterClass
	^ FormatterClass ifNil: [ RBSimpleFormatter ] ifNotNil: [ FormatterClass ]! !

!RBProgramNodeTest commentStamp: ''!
SUnit tests for RBProgramNode!
!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeForCommentInbetweenStatements
	| ast string start |
	string := '"Fourth comment"'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size - 1).
	self assert: ast isCommentNode.
	self assert: ast contents equals: 'Fourth comment'.! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeForCommentInsideACascadeNodeOnMessageNode
	| ast string start |
	string := '"Seventh comment"'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size - 1).
	self assert: ast isCommentNode.
	self assert: ast contents equals: 'Seventh comment'.! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testCursorAfterArgumentReturnsVariableNode

	| sourceCode ast bestNode |
	sourceCode := 'toto: m1
	               m1 aMessage'.
	
	ast := RBParser parseMethod: sourceCode.
	bestNode := ast bestNodeForPosition: 9.
	
	self assert: bestNode isVariable! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testAddSelfReturn
	| tree return |
	tree := self parseExpression: '1. 2'.
	return := tree addSelfReturn.
	self assert: tree statements last equals: return.
	self assert: (self parseExpression: '1. 2. ^ self') equals: tree.
	
	tree := self parseExpression: '3. ^ 4'.
	return := tree addSelfReturn.
	self assert: tree statements last equals: return.
	self assert: (self parseExpression: '3. ^ 4') equals: tree! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceMessage
	| tree |
	tree := self parseMethod: 'run "1" self "2" run "3"'.
	tree body statements first replaceWith: (self parseExpression: 'self runCase').
	self assert: tree newSource equals: 'run "1" self "2" runCase "3"'! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testAllStatementsDynamicArray
	| tree |
	tree := self parserClass parseMethod: 
			'methodName
				
				{ 1 . self send1 . self send2} '.

	self assert: tree allStatements size equals: 4.! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeForCommentInsideAssignementNode
	| ast string start |
	string := '" Third comment "'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size - 1).
	self assert: ast isCommentNode.
	self assert: ast contents equals: ' Third comment '.! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testAllStatementsSimpleBlock
	| tree stats |
	tree := self parserClass parseMethod: 
			'methodName
				^ [ 8 + 4 ] '.
	stats := tree allStatements.
	self assert: stats size equals: 2! !

!RBProgramNodeTest methodsFor: 'tests - properties' stamp: ''!
testPropertyAtIfAbsentPut
	self assert: (self node propertyAt: #foo ifAbsentPut: [ true ]).
	self assert: (self node propertyAt: #foo ifAbsentPut: [ false ])! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeFirstTempsAndFirstCommentGivesVariableNode
	| ast string start |
	string := '"First comment"'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size + 6).
	self assert: ast isVariable.! !

!RBProgramNodeTest methodsFor: 'tests - properties' stamp: ''!
testHasProperty
	self deny: (self node hasProperty: #foo).
	self node propertyAt: #foo put: 123.
	self assert: (self node hasProperty: #foo)! !

!RBProgramNodeTest methodsFor: 'tests - properties' stamp: ''!
testRemoveProperty
	self should: [ self node removeProperty: #foo ] raise: Error.
	self node propertyAt: #foo put: true.
	self assert: (self node removeProperty: #foo)! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeWithMethodSelectorGivesCommentNode
	| ast string start |
	string := '"First comment"'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (1 to: start + string size - 1).
	self assert: ast isCommentNode.! !

!RBProgramNodeTest methodsFor: 'tests - properties' stamp: ''!
testPropertyAtIfPresentIfAbsent
	self assert: (self node propertyAt: #foo ifPresent:[ false ] ifAbsent: [ true ]) equals: true.
	self node propertyAt: #foo put: true.
	self assert: (self node propertyAt: #foo ifPresent:[ true ] ifAbsent: [ false ]).
	self assert: (self node propertyAt: #toto ifPresent:[ false ] ifAbsent: [ true ])! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testAddTemporaryNamed
	| tree variable |
	tree := self parseExpression: '| a | a'.
	variable := tree addTemporaryNamed: 'b'.
	self assert: variable isVariable.
	self assert: variable name equals: 'b'.
	self assert: tree temporaries last equals: variable! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testAddNode
	| tree treeNode |
	tree := self parseExpression: '1. 2'.
	treeNode := tree addNode: (self parseExpression: '3').
	self assert: (self parseExpression: '1. 2. 3') equals: tree.
	self assert: tree statements last equals: treeNode.
	
	tree := self parseExpression: '{ 1. 2 }'.
	treeNode := tree addNode: (self parseExpression: '3').
	self assert: (self parseExpression: '{ 1. 2. 3 }') equals: tree.
	self assert: tree statements last equals: treeNode! !

!RBProgramNodeTest methodsFor: 'tests - messages' stamp: ''!
testSentMessages
	| tree messages |
	tree := self
		parseRewriteMethod:
			'methodName
				| temp |
				1 send1 send2; send3.
				temp := [:each | {4 send4} send5].
				temp send6 `{:node | node notASentMessage}'.
	messages := tree sentMessages.
	self assert: messages size equals: 6.
	1 to: 6 do:
		[ :i | self assert: (messages includes: ('send' , i printString) asSymbol) ]! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeForCommentInsideMethodNode
	| ast string start |
	string := '"First comment"'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size - 1).
	self assert: ast isCommentNode.
	self assert: ast contents equals: 'First comment'.! !

!RBProgramNodeTest methodsFor: 'tests - properties' stamp: ''!
testPropertyAt
	self should: [ self node propertyAt: #foo ] raise: Error.
	self node propertyAt: #foo put: true.
	self assert: (self node propertyAt: #foo)! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testAddReturn
	| tree return |
	tree := self parseExpression: '1. 2'.
	return := tree addReturn.
	self assert: tree statements last equals: return.
	self assert: (self parseExpression: '1. ^ 2') equals: tree.
	
	tree := self parseExpression: '3. ^ 4'.
	return := tree addReturn.
	self assert: tree statements last equals: return.
	self assert: (self parseExpression: '3. ^ 4') equals: tree! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceMethodKeywordLong
	| tree |
	tree := self parseMethod: 'deny: "1" anObject "2" description: "3" anotherObject "4" ^ "5" 6 "7"'.
	tree renameSelector: #runCase andArguments: #().
	self assert: tree newSource equals: '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 equals: '~~ 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 equals: '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 equals: 'assert: "1" first "2" description: "3" second "4" ^ "5" 6 "7"'! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeForCommentInsideACascadeNodeOnReceiver
	| ast string start |
	string := '"Sixth comment"'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size - 1).
	self assert: ast isCommentNode.
	self assert: ast contents equals: 'Sixth comment'.! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testAddTemporariesNamed
	| tree variables |
	tree := self parseExpression: '| a | a'.
	variables := tree addTemporariesNamed: #('b' 'c').
	self assert: variables first isVariable.
	self assert: variables first name equals: 'b'.
	self assert: variables second isVariable.
	self assert: variables second name equals: 'c'.
	self assert: tree temporaries second equals: variables first.
	self assert: tree temporaries last equals: variables second! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testAllStatementsTemps
	| tree stats |
	tree := self parserClass parseMethod: 
			'methodName
				| tmp1 tmp2 |
				tmp1 + tmp2'.
	stats := tree allStatements.
	self assert: stats size equals: 3! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
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') equals: tree.
	self assert: (tree statements at: 2) equals: treeNode.
	
	tree := self parseExpression: '{ 1. 3 }'.
	treeNode := tree
		addNode: (self parseExpression: '2')
		before: tree statements last.
	self assert: (self parseExpression: '{ 1. 2. 3 }') equals: tree.
	self assert: (tree statements at: 2) equals: treeNode! !

!RBProgramNodeTest methodsFor: 'tests - comments' stamp: ''!
testSetCommentsToNil

	self node comments: nil.
	self assert: self node comments equals: #()! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
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') equals: tree.
	self assert: (tree statements at: 2) equals: treeNodes first.
	self assert: (tree statements at: 3) equals: 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 }') equals: tree.
	self assert: (tree statements at: 2) equals: treeNodes first.
	self assert: (tree statements at: 3) equals: treeNodes last! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testAddNodes
	| tree treeNodes |
	tree := self parseExpression: '1. 2'.
	treeNodes := tree addNodes: (self parseExpression: '3. 4') statements.
	self assert: (self parseExpression: '1. 2. 3. 4') equals: tree.
	self assert: (tree statements at: 3) equals: treeNodes first.
	self assert: (tree statements at: 4) equals: treeNodes last.
	
	tree := self parseExpression: '{ 1. 2 }'.
	treeNodes := tree addNodes: (self parseExpression: '3. 4') statements.
	self assert: (self parseExpression: '{ 1. 2. 3. 4 }') equals: tree.
	self assert: (tree statements at: 3) equals: treeNodes first.
	self assert: (tree statements at: 4) equals: treeNodes last! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeInsideAssignementGivesSelectedValue
	| ast string start |
	string := '#node'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size - 1).
	self assert: ast isLiteralNode.
	self assert: ast value equals: #node.! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testAllStatementsBlockWithTemps
	| tree |
	tree := self parserClass parseMethod: 
			'methodName
				^ [ | tmp | tmp := 88 ] '.
	self assert: tree allStatements size equals: 3.! !

!RBProgramNodeTest methodsFor: 'tests - properties' stamp: ''!
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: 'tests - adding' stamp: ''!
testCursorInMiddleOfVariableReturnsVariableNode

	| sourceCode ast bestNode |
	sourceCode := 'toto: m1
	               m1 aMessage'.
	
	ast := RBParser parseMethod: sourceCode.
	bestNode := ast bestNodeForPosition: 27.
	
	self assert: bestNode isVariable! !

!RBProgramNodeTest methodsFor: 'accessing' stamp: ''!
getMethodString
	^'toto
		"First comment"
		| temp varaibles |
		"Second comment"
		assignement := " Third comment " #node. 
		"Fourth comment"
		message "Fifth comment", ''node''.
		"Sixth comment" cascade node; nodeux "Seventh comment"; notrois.
		^ "return" nil
		'.! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
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 equals: '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 equals: '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 equals: 'foo "1" bar "2" foo: "3" 123 "4"'! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeForCommentInsideMessageNode
	| ast string start |
	string := '"Fifth comment"'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size - 1).
	self assert: ast isCommentNode.
	self assert: ast contents equals: 'Fifth comment'.! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testAllStatementsReturns
	| tree stats |
	tree := self parserClass parseMethod: 
			'methodName
				^ self '.
	stats := tree allStatements.
	self assert: stats size equals: 1! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testCursorAfterVariableReturnsVariableNode

	| sourceCode ast bestNode |
	sourceCode := 'toto: m1
	               m1 aMessage'.
	
	ast := RBParser parseMethod: sourceCode.
	bestNode := ast bestNodeForPosition: 28.
	
	self assert: bestNode isVariable! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeForCommentInsideReturnNode
	| ast string start |
	string := '"return"'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size - 1).
	self assert: ast isCommentNode.
	self assert: ast contents equals: 'return'.! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testAddNodeFirst
	| tree treeNode |
	tree := self parseExpression: '2. 3'.
	treeNode := tree addNodeFirst: (self parseExpression: '1').
	self assert: (self parseExpression: '1. 2. 3') equals: tree.
	self assert: tree statements first equals: treeNode.
	
	tree := self parseExpression: '{ 2. 3 }'.
	treeNode := tree addNodeFirst: (self parseExpression: '1').
	self assert: (self parseExpression: '{ 1. 2. 3 }') equals: tree.
	self assert: tree statements first equals: treeNode! !

!RBProgramNodeTest methodsFor: 'tests - accessing' stamp: ''!
testAllComments
	"Testing the AST comments objects. I am the first comment to be found in this test"
	self
		assert: (RBProgramNodeTest >> #testAllComments) ast allComments first contents
		equals: 'Testing the AST comments objects. I am the first comment to be found in this test'.
	"Next test assumes this comment it's not a string like in #testComments..."
	self 
		assert: (RBProgramNodeTest >> #testAllComments) ast allComments second isString
		equals: false! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeForCommentInsideSequenceNode
	| ast string start |
	string := '"Second comment"'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size - 1).
	self assert: ast isCommentNode.
	self assert: ast contents equals: 'Second comment'.! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testAllStatementsBlockWithReturn
	| tree |
	tree := self parserClass parseMethod: 
			'methodName
				^ [ ^ self ] '.
	self assert: tree allStatements size equals: 2! !

!RBProgramNodeTest methodsFor: 'accessing' stamp: ''!
node
	^ node ifNil: [ node := RBProgramNode new ]! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceBlock
	| tree expectedTree |
	tree := self parseMethod: 'run self foo ifNil: [ ^ true ]'.
	expectedTree := self parseMethod: 'run self foo ifNil: [ ^ false ]'.
	
	tree body statements first arguments first replaceWith: (self parseExpression: '[ ^ false ]').
	self assert: tree  equals: expectedTree! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testAllStatementsTwoMessages
	| tree stats |
	tree := self parserClass parseMethod: 
			'methodName
				
				1 send1 send2'.
	stats := tree allStatements.
	self assert: stats size equals: 1.! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceMethodBinary
	| tree |
	tree := self parseMethod: '= "1" anObject "2" ^ "3" 4 "5"'.
	tree renameSelector: #runCase andArguments: #().
	self assert: tree newSource equals: '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 equals: '~~ "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 equals: '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 equals: 'assert: first description: second "2" ^ "3" 4 "5"'! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceMethodUnary
	| tree |
	tree := self parseMethod: 'run "1" ^ "2" 3 "4"'.
	tree renameSelector: #runCase andArguments: #().
	self assert: tree newSource equals: '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 equals: '~~ 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 equals: '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 equals: 'assert: first description: second "1" ^ "2" 3 "4"'! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testWithAllParents
	"check that we get all parents of a program node, and me"

	| me parentsOf7 |
	[ :a | a + 7 ].
	me := self class >> #testAllParents.
	parentsOf7 := (me ast allChildren select: [ :n | 
		               n isLiteralNode and: [ n value = 7 ] ]) first
		              withAllParents.
	self assert: parentsOf7 last value equals: 7.
	self assert: parentsOf7 first equals: me ast! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testAllStatementsReturnsMultiple
	| tree stats |
	tree := self parserClass parseMethod: 
			'methodName
				1 ifTrue: [ ^ self ].
				^ self '.
	stats := tree allStatements.
	self assert: stats size equals: 3! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testCursorBeforeVariableReturnsVariableNode

	| sourceCode ast bestNode |
	sourceCode := 'toto: m1
	               m1 aMessage'.
	
	ast := RBParser parseMethod: sourceCode.
	bestNode := ast bestNodeForPosition: 26.
	
	self assert: bestNode isVariable! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testAllStatementsAssignment
	| tree  |
	tree := self parserClass parseMethod: 
			'methodName
				
				x := 33'.

	self assert: tree allStatements size equals: 1.! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceLiteralArray1
	| tree |
	tree := self parseMethod: 'run "1" #(1 2 3) "2"'.
	tree body statements first replaceWith: (self parseExpression: '#[1 2 3]').
	self assert: tree newSource equals: '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 equals: 'run "1" 123 "2"'! !

!RBProgramNodeTest methodsFor: 'tests - properties' stamp: ''!
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: 'tests - adding' stamp: ''!
testAddNodesFirst
	| tree treeNodes |
	tree := self parseExpression: '3. 4'.
	treeNodes := tree addNodesFirst: (self parseExpression: '1. 2') statements.
	self assert: (self parseExpression: '1. 2. 3. 4') equals: tree.
	self assert: (tree statements at: 1) equals: treeNodes first.
	self assert: (tree statements at: 2) equals: treeNodes last.
	
	tree := self parseExpression: '{ 3. 4 }'.
	treeNodes := tree addNodesFirst: (self parseExpression: '1. 2') statements.
	self assert: (self parseExpression: '{ 1. 2. 3. 4 }') equals: tree.
	self assert: (tree statements at: 1) equals: treeNodes first.
	self assert: (tree statements at: 2) equals: treeNodes last! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceAssignment
	| tree expectedTree |
	tree := self parseMethod: 'run sum := 2 + 2'.
	expectedTree := self parseMethod: 'run multpppp := 2 * 2'.
	
	tree body statements first replaceWith: (self parseExpression: 'multpppp := 2 * 2').
	self assert: tree equals: expectedTree.! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceVariable
	| tree |
	tree := self parseMethod: 'run "1" foo "2"'.
	tree body statements first replaceWith: (self parseExpression: 'zork').
	self assert: tree newSource equals: 'run "1" zork "2"'.
	tree := self parseMethod: 'run "1" foo "2"'.
	tree body statements first replaceWith: (self parseExpression: '123').
	self assert: tree newSource equals: 'run "1" 123 "2"'! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
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 equals: '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 equals: '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 equals: 'foo "1" self "2" foo: "3" bar "4"'! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testCursorBeforeArgumentReturnsVariableNode

	| sourceCode ast bestNode |
	sourceCode := 'toto: m1
	               m1 aMessage'.
	
	ast := RBParser parseMethod: sourceCode.
	bestNode := ast bestNodeForPosition: 7.
	
	self assert: bestNode isVariable! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testNumberOfSentMessages
	| tree messages |
	tree := self parserClass parseMethod: 
			'methodName
				| temp |
				1 send1 send2; send3.
				temp := [:each | {4 send4} send5].
				temp send6.
				0 ifTrue: [ 1 ]'.
	messages := tree sentMessages.
	self assert: messages size equals: 7.
	"we count ifTrue:"
	1 to: 6 do:
		[ :i | self assert: (messages includes: ('send' , i printString) asSymbol) ]! !

!RBProgramNodeTest methodsFor: 'tests' stamp: ''!
testAllParents
	"check that we get all parents of a program node"

	| me parentsOf7 |
	[ :a | a + 7 ].
	me := self class >> #testAllParents.
	parentsOf7 := (me ast allChildren select: [ :n | 
		               n isLiteralNode and: [ n value = 7 ] ]) first
		              allParents.
	self assert: parentsOf7 last selector equals: #+.
	self assert: parentsOf7 first equals: me ast! !

!RBProgramNodeTest methodsFor: 'tests - adding' stamp: ''!
testCursorBeforeArgumentNextToSelectorReturnsMethodNode

	| sourceCode ast bestNode |
	sourceCode := 'toto:m1
	               m1 aMessage'.
	
	ast := RBParser parseMethod: sourceCode.
	bestNode := ast bestNodeForPosition: 6.
	
	self assert: bestNode isMethod! !

!RBProgramNodeTest methodsFor: 'tests - bestNodeFor' stamp: ''!
testBestNodeInsideAssignementGivesSelectedVariable
	| ast string start |
	string := 'assignement'.
	start := self getMethodString findString: string.
	ast := (RBParser parseMethod: self getMethodString) bestNodeFor: (start to: start + string size - 1).
	self assert: ast isVariable.
	self assert: ast name equals: 'assignement'.! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceLiteral
	| tree |
	tree := self parseMethod: 'run "1" 123 "2"'.
	tree body statements first replaceWith: (self parseExpression: '$a').
	self assert: tree newSource equals: 'run "1" $a "2"'.
	tree := self parseMethod: 'run "1" 123 "2"'.
	tree body statements first replaceWith: (self parseExpression: 'zork').
	self assert: tree newSource equals: 'run "1" zork "2"'! !

!RBProgramNodeTest methodsFor: 'accessing' stamp: ''!
getAllNodesFromAST
	| methodText |
	methodText :=
	'toto
		"First comment"
		| temp varaibles |
		"Second comment"
		assignement := " Third comment " #node. 
		"Fourth comment"
		message "Fifth comment", ''node''.
		"Sixth comment" cascade node; nodeux "Seventh comment"; notrois.
		^ "return" nil
		'.
	^ RBParser parseMethod: methodText.! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceLiteralArray2
	| tree |
	tree := self parseMethod: 'run "1" #[1 2 3] "2"'.
	tree body statements first replaceWith: (self parseExpression: '#(1 2 3)').
	self assert: tree newSource equals: '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 equals: 'run "1" 123 "2"'! !

!RBProgramNodeTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceMethodKeyword
	| tree |
	tree := self parseMethod: 'deny: "1" anObject "2" ^ "3" 4 "5"'.
	tree renameSelector: #runCase andArguments: #().
	self assert: tree newSource equals: '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 equals: '~~ "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 equals: '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 equals: 'assert: first description: second "2" ^ "3" 4 "5"'! !

!RBProgramNodeTest class methodsFor: 'accessing' stamp: ''!
packageNamesUnderTest
	^ #('AST-Core')! !

!RBProgramNodeVisitor commentStamp: ''!
RBProgramNodeVisitor is an abstract visitor for the RBProgramNodes.

!
!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitArgumentNodes: aNodeCollection
	"Sent *once* when visiting method and block nodes"

	^ aNodeCollection do: [ :each | self visitArgumentNode: each ]! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitTemporaryNodes: aNodeCollection
	"This is triggered when defining the temporaries between the pipes"

	^ aNodeCollection
		do: [ :each | self visitTemporaryDeclarationNode: each ]! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode
	self visitArgumentNodes: aBlockNode arguments.
	self visitNode: aBlockNode body! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralValueNode: aRBLiteralValueNode
	"Redirect the message by default to #visitLiteralNode: for retrocompatibility (pharo 8)"

	^ self visitLiteralNode: aRBLiteralValueNode! !

!RBProgramNodeVisitor methodsFor: 'visiting - variables' stamp: ''!
visitArgumentVariableNode: anArgumentNode

	^ self visitLocalVariableNode: anArgumentNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode
	self visitTemporaryNodes: aSequenceNode temporaries.
	aSequenceNode statements do: [ :each | self visitNode: each ]! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitGlobalNode: aSelfNode
	^ self visitVariableNode: aSelfNode! !

!RBProgramNodeVisitor methodsFor: 'visiting - variables' stamp: ''!
visitTemporaryVariableNode: aNode

	^ self visitLocalVariableNode: aNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitReturnNode: aReturnNode
	^ self visitNode: aReturnNode value! !

!RBProgramNodeVisitor methodsFor: 'visiting - variables' stamp: ''!
visitClassVariableNode: aNode

	^ self visitLiteralVariableNode: aNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: anAssignmentNode
	self visitNode: anAssignmentNode variable.
	self visitNode: anAssignmentNode value! !

!RBProgramNodeVisitor methodsFor: 'visiting - variables' stamp: ''!
visitLiteralVariableNode: aNode
	"to be backward compatible, we visit for Gloabls here (there used to be no difference)"

	^ self visitGlobalNode: aNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitCascadeNode: aCascadeNode
	aCascadeNode messages do: [ :each | self visitNode: each ]! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode
	self visitArgumentNodes: aMethodNode arguments.
	aMethodNode pragmas do: [ :each | self visitNode: each ].
	self visitNode: aMethodNode body! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralNode: aLiteralNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitNode: aNode
	^ aNode acceptVisitor: self! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitUnreachableStatement: anUnreachableStatement
	
	^ self visitEnglobingErrorNode: anUnreachableStatement! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitPragmaNode: aPragmaNode
	aPragmaNode arguments do: [ :each | self visitNode: each ]! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitLocalVariableNode: aNode
	"call visitTemporaryNode: for backward compatibility"
	^ self visitTemporaryNode: aNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitParseErrorNode: anErrorNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitThisContextNode: aThisContextNode
	^ self visitVariableNode: aThisContextNode! !

!RBProgramNodeVisitor methodsFor: '*ClassParser' stamp: ''!
visitSlotInitializationNode: aSlotInitializationNode

	^aSlotInitializationNode! !

!RBProgramNodeVisitor methodsFor: 'API' stamp: ''!
visit: aRBMessageNode 
	^ aRBMessageNode acceptVisitor: self! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitPatternWrapperBlockNode: aRBPatternWrapperBlockNode
	self visitNode: aRBPatternWrapperBlockNode wrappedNode.
	self visitArgumentNodes: aRBPatternWrapperBlockNode arguments.
	self visitNode: aRBPatternWrapperBlockNode body! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitPatternBlockNode: aRBPatternBlockNode
	self visitArgumentNodes: aRBPatternBlockNode arguments.
	self visitNode: aRBPatternBlockNode body! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitTemporaryNode: aNode
	"Sent *each time* a temporary node is found"

	^ self visitVariableNode: aNode! !

!RBProgramNodeVisitor methodsFor: 'visiting - variables' stamp: ''!
visitGlobalVariableNode: aNode

	^ self visitLiteralVariableNode: aNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitEnglobingErrorNode: anEnglobingErrorNode
	anEnglobingErrorNode content do: [ :each | self visitNode: each ].! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aRBLiteralArrayNode
	aRBLiteralArrayNode contents do: [ :each | self visitNode: each ]! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitTemporaryDeclarationNode: aTemporaryDeclarationNode
	"| temp |
	temp is a temporary node as we can find in the body of methods, but it can't be visited the same way.
	Redirect the message on argumentNodeVisitor as a way to keep retrocompatibility"

	^ self visitArgumentNode: aTemporaryDeclarationNode! !

!RBProgramNodeVisitor methodsFor: '*Reflectivity' stamp: ''!
visitStorePopIntoTempNode: aNode
	^ aNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitArgumentNode: anArgumentNode
	"Sent *each time* an argument node is found"

	^ self visitVariableNode: anArgumentNode! !

!RBProgramNodeVisitor methodsFor: '*Reflectivity' stamp: ''!
visitStoreIntoTempNode: aNode
	^ aNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitArrayNode: anArrayNode
	anArrayNode children do: [ :each | self visitNode: each ]! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitSuperNode: aSuperNode
	^ self visitVariableNode: aSuperNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitSelfNode: aSelfNode
	^ self visitVariableNode: aSelfNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitMessageNode: aMessageNode
	(aMessageNode isCascaded not or: [ aMessageNode isFirstCascaded ])
		ifTrue: [ self visitNode: aMessageNode receiver ].
	self visitNode: aMessageNode selectorNode.
	aMessageNode arguments do: [ :each | self visitNode: each ]! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitSelectorNode: aSelectorNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode
	^ aVariableNode! !

!RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitInstanceVariableNode: aSelfNode
	^ self visitVariableNode: aSelfNode! !

!RBProgramNodeVisitor class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBProgramNodeVisitor! !

!RBProtectInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testProtectInstanceVariable
	| refactoring class |
	refactoring := self createRefactoringWithArguments:  
		{('rewrite' , 'Rule1') . #RBSubclassOfClassToRename}.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBSubclassOfClassToRename.
	self assert: (class parseTreeFor: #calls1) equals: (self parseMethod: 'calls1
								^rewriteRule1 := (rewriteRule1 := self calls)').
	self assert: (class parseTreeFor: #calls) equals: (self parseMethod: 'calls
								^rewriteRule1 := rewriteRule1 , rewriteRule1').
	self deny: (class directlyDefinesMethod: ('rewrite' , 'Rule1') asSymbol).
	self deny: (class directlyDefinesMethod: ('rewrite' , 'Rule1:') asSymbol)! !

!RBProtectInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testVariableNotDefined
	self shouldFail:
		(self createRefactoringWithArguments: {'rewrite' . #RBSubclassOfClassToRename}).
	self shouldFail: 
		(self createRefactoringWithArguments: {'foo' . #RBBasicLintRuleTestData}).
	! !

!RBProtectInstanceVariableParametrizedTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	model := self abstractVariableTestData.! !

!RBProtectInstanceVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
self flag: 'need change tranformation to have the same behavior of ref'.
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBProtectInstanceVariableRefactoring .
					  #constructor -> #variable:class: };
	"	addCase: { #rbClass -> RBProtectVariableTransformation .
					  #constructor -> #instanceVariable:class: };
	"	yourself! !

!RBProtectInstanceVariableRefactoring commentStamp: ''!
I am a refactoring for protecting instance variable access.

If a class defines methods for reading and writing instance variables, they are removed and all calls on this methods.
Omit method that are redefined in subclasses.!
!RBProtectInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self setOption: #inlineExpression toUse: [:ref :string | true].
	self getterSetterMethods do: [:each | self inline: each]! !

!RBProtectInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^RBCondition definesInstanceVariable: variableName in: class! !

!RBProtectInstanceVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
getterSetterMethods
	| matcher |
	matcher := self parseTreeSearcher.
	matcher
		answer: Set new;
		matchesAnyMethodOf:
			(Array
				with: '`method ^' , variableName
				with: ('`method: `arg <1s> := `arg' expandMacrosWith: variableName)
				with: ('`method: `arg ^<1s> := `arg' expandMacrosWith: variableName))
			do: [ :aNode :answer | 
				(class subclassRedefines: aNode selector)
					ifFalse: [ answer add: aNode selector ].
				answer ].
	(class whichSelectorsReferToInstanceVariable: variableName)
		do:
			[ :each | self checkClass: class selector: each using: matcher ].
	^ matcher answer! !

!RBProtectInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
inline: aSelector 
	self onError: 
			[self performCompositeRefactoring: (RBInlineAllSendersRefactoring 
						model: self model
						sendersOf: aSelector
						in: class)]
		do: []! !

!RBProtectVariableTransformation commentStamp: ''!
Creates accessors for a variable in a class, then replaces all the direct accesses to this variable by invocation to the accessors.

Usage:
transformation := (RBProtectVariableTransformation
	instanceVariable: 'class'
	class: #RBTransformationRuleTest)
	transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
overriden from RBAddAccessorsForClassTransformation and RBRemoveDirectAccessToVariableTransformation!
!RBProtectVariableTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName class: aClassName classVariable: aBoolean

	variableName := aVariableName.
	isClassVariable := aBoolean.
	className := aClassName.! !

!RBProtectVariableTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' variable: '.
	variableName storeOn: aStream.
	aStream nextPutAll: ' class: '.
	className storeOn: aStream.
	aStream nextPutAll: ' classVariable: '.
	isClassVariable storeOn: aStream.
	aStream nextPut: $)! !

!RBProtectVariableTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	^ OrderedCollection
		with: (RBAddVariableAccessorTransformation
				model: self model
				variable: variableName asString
				class: className
				classVariable: isClassVariable)
		with: (RBRemoveDirectAccessToVariableTransformation
				model: self model
				variable: variableName asString
				class: className
				classVariable: isClassVariable)! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testVariableDoesNotExist

	self
		shouldFail: (RBProtectVariableTransformation 
						instanceVariable: 'foo'
						class: #RBBasicLintRuleTestData)
						asRefactoring;
		shouldFail: (RBProtectVariableTransformation 
						classVariable: #Foo
						class: #RBBasicLintRuleTestData)
						asRefactoring! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testVariableNotDirectlyDefined

	self 
		shouldFail: (RBProtectVariableTransformation 
						instanceVariable: 'name'
						class: #RBBasicLintRuleTestData)
						asRefactoring;
		shouldFail: (RBProtectVariableTransformation 
						classVariable: #DependentsFields
						class: #RBBasicLintRuleTestData)
						asRefactoring;
		shouldFail: (RBProtectVariableTransformation 
						model: model
						classVariable: 'ClassVarName2'
						class: #Bar)
						asRefactoring! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testVariableIsNotAccessed

	| transformation class |
	transformation := RBProtectVariableTransformation 
							instanceVariable: 'instVar'
							class: self changeMock name.
	
	class := transformation model classNamed: self changeMock name asSymbol.
	self deny: (class directlyDefinesLocalMethod: #instVar).
	self deny: (class directlyDefinesLocalMethod: #instVar:).
	
	transformation transform.	
	self assert: transformation model changes changes size equals: 2.
	self assert: (class directlyDefinesLocalMethod: #instVar).
	self assert: (class directlyDefinesLocalMethod: #instVar:).! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testAccessorsAlreadyExist

	| class |
	(RBProtectVariableTransformation
		model: model
		instanceVariable: 'instVarName1'
		class: #Foo)
		asRefactoring transform.
	
	class := model classNamed: #Foo.
	self assert: (class parseTreeFor: #bar)
		equals: (self parseMethod: 'bar
			"Add one to instVarName1"
			self instVarName11: self instVarName11 + 1').
	self assert: (class parseTreeFor: #instVarName11:) 
		equals: (self parseMethod: 'instVarName11: anObject
			instVarName1 := anObject').
	self assert: (class parseTreeFor: #instVarName11) 
		equals: (self parseMethod: 'instVarName11 ^instVarName1').
		
	self assert: ((model classNamed: #Bar) parseTreeFor: #foo) 
		equals: (self parseMethod: 'foo
			self instVarName11: self instVarName11 + instVarName2 + ClassVarName1')! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBProtectVariableTransformation
						instanceVariable: 'builder'
						class: #RBTransformationRuleTestData)
						asRefactoring transform.
	
	class := refactoring model classNamed: #RBTransformationRuleTestData.
	self assert: (class parseTreeFor: #builder) equals: (self parseMethod: 'builder ^builder').
	self assert: (class parseTreeFor: #builder:) equals: (self parseMethod: 'builder: anObject
	builder := anObject').
	self assert: (class parseTreeFor: #viewResults) equals: (self parseMethod: 'viewResults
		self builder inspect.
		self resetResult').
	self assert: (class parseTreeFor: #checkMethod:) equals: (self parseMethod: 'checkMethod: aSmalllintContext 
	class := aSmalllintContext selectedClass.
	(rewriteRule executeTree: aSmalllintContext parseTree) 
		ifTrue: 
			[(RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false) 
				ifFalse: 
					[self builder 
						compile: rewriteRule tree printString
						in: class
						classified: aSmalllintContext protocols]]')! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testMetaclassFailure

	self shouldFail: (RBProtectVariableTransformation 
							classVariable: #RecursiveSelfRule
							class: RBTransformationRuleTestData class)
							asRefactoring! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBProtectVariableTransformation
							instanceVariable: 'class'
							class: #RBTransformationRuleTestData)
							transform.
		
	class := transformation model classNamed: #RBTransformationRuleTestData.
	self assert: (class directlyDefinesLocalMethod: #class1).
	self assert: (class directlyDefinesLocalMethod: #class:).
	
	self assert: (class parseTreeFor: #superSends) equals: (self 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:) equals: (self 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]]')! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testMetaclass

	| class |
	class := model metaclassNamed: #Foo.
	class addInstanceVariable: 'foo'.
	class compile: 'zzz ^foo := foo + foo * 2' classified: #(#testing).
	
	(RBProtectVariableTransformation
		model: model
		instanceVariable: 'foo'
		class: class)
		asRefactoring transform.
				
	self assert: (class parseTreeFor: #foo1) 
			equals: (self parseMethod: 'foo1 ^foo').
	self assert: (class parseTreeFor: #foo:)
			equals: (self parseMethod: 'foo: anObject foo := anObject').
			
	self assert: (class parseTreeFor: #zzz) 
			equals: (self parseMethod: 'zzz ^self foo: self foo1 + self foo1 * 2')! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testClassVariable

	| refactoring class |
	refactoring := (RBProtectVariableTransformation 
						classVariable: 'RecursiveSelfRule'
						class: #RBTransformationRuleTestData)
						asRefactoring transform.
	
	class := (refactoring model classNamed: #RBTransformationRuleTestData) theMetaClass.
	self assert: (class parseTreeFor: #recursiveSelfRule)
			equals: (self parseMethod: 'recursiveSelfRule ^RecursiveSelfRule').
	self assert: (class parseTreeFor: #recursiveSelfRule:) 
			equals: (self parseMethod: 'recursiveSelfRule: anObject RecursiveSelfRule := anObject').
	
	self assert: (class parseTreeFor: #nuke) 
			equals: (self parseMethod: 'nuke self recursiveSelfRule: nil').
	self assert: (class parseTreeFor: #initializeAfterLoad1) 
			equals: (self parseMethod: 'initializeAfterLoad1
				self recursiveSelfRule: self parseTreeSearcher.
				self recursiveSelfRule
					addMethodSearches: #(''`@methodName: `@args | `@temps | self `@methodName: `@args'' ''`@methodName: `@args | `@temps | ^self `@methodName: `@args'')
					-> [:aNode :answer | true]').
	self assert: ((refactoring model classNamed: #RBTransformationRuleTestData) parseTreeFor: #checkMethod:) 
			equals: (self 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]]')! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testClassVariableInModel

	| class |
	(RBProtectVariableTransformation 
		model: model
		classVariable: 'ClassVarName1'
		class: #Foo)
		asRefactoring transform.
	
	class := (model classNamed: #Foo) theMetaClass.
	self assert: (class parseTreeFor: #classVarName1) 
			equals: (self parseMethod: 'classVarName1 ^ClassVarName1').
	self assert: (class parseTreeFor: #classVarName1:) 
			equals: (self parseMethod: 'classVarName1: anObject ClassVarName1 := anObject').
	
	self assert: (class parseTreeFor: #foo)
			equals: (self parseMethod: 'foo
				^self classVarName1: self classVarName1 * self classVarName1 * self classVarName1').
					
	self assert: (class theNonMetaClass parseTreeFor: #classVarName1)
			equals: (self parseMethod: 'classVarName1 ^self class classVarName1').
	self assert: (class theNonMetaClass parseTreeFor: #classVarName1:) 
			equals: (self parseMethod: 'classVarName1: anObject
				^self class classVarName1: anObject').
				
	"self assert: (class theNonMetaClass parseTreeFor: #asdf)
			equals: (RBParser parseMethod: 'asdf
				^self classVarName1: (self class classVarName1: self class classVarName1 + 1)').
	self assert: ((model classNamed: #Bar) parseTreeFor: #foo)
			equals: (RBParser parseMethod: 'foo
				instVarName1 := instVarName1 + instVarName2 + self class classVarName1').
	self assert: ((model classNamed: #Bar) parseTreeFor: #foo)
			equals: (RBParser parseMethod: 'foo
				instVarName1 := instVarName1 + instVarName2 + self class classVarName1')"! !

!RBProtectVariableTransformationTest methodsFor: 'tests' stamp: ''!
testWithAssignment

	| refactoring class |
	refactoring := (RBProtectVariableTransformation
						model: model
						instanceVariable: 'instVarName2'
						class: #Foo)
						asRefactoring transform.
	
	class := model classNamed: #Foo.
	self assert: (class parseTreeFor: #instVarName2:)
		equals: (self parseMethod: 'instVarName2: anObject instVarName2 := anObject').
	self assert: (class parseTreeFor: #instVarName2) 
		equals: (self parseMethod: 'instVarName2 ^instVarName2').
	
	self assert: (class parseTreeFor: #foo)
		equals: (self parseMethod: 'foo ^self instVarName2: 3').
	self assert: ((model classNamed: #Bar) parseTreeFor: #foo)
		equals: (self parseMethod: 'foo
			instVarName1 := instVarName1 + self instVarName2 + ClassVarName1')! !

!RBProtectVariableTransformationTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	model := self abstractVariableTestData.! !

!RBProtocolEnvironment commentStamp: ''!
I am a RBBrowserEnvironment on a set of protocols of a class.

Example:
(RBBrowserEnvironment new) forClass:Morph protocols:{'printing'}.!
!RBProtocolEnvironment methodsFor: 'private' stamp: ''!
defaultLabel
	| stream |
	stream := String new writeStream.
	stream nextPutAll: class name;
		nextPut: $>.
	protocols do: 
			[:each | 
			stream nextPutAll: each;
				nextPut: $ ].
	^stream contents! !

!RBProtocolEnvironment methodsFor: 'testing' stamp: ''!
isEmpty
	^protocols isEmpty! !

!RBProtocolEnvironment methodsFor: 'visiting' stamp: ''!
acceptVisitor: aEnvVisitor
	^ aEnvVisitor visitProtocolEnv: self! !

!RBProtocolEnvironment methodsFor: 'adding' stamp: ''!
addProtocol: aSymbol
	protocols add: aSymbol! !

!RBProtocolEnvironment methodsFor: 'accessing' stamp: ''!
basisObjects
	^ self protocols! !

!RBProtocolEnvironment methodsFor: 'testing' stamp: ''!
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' stamp: ''!
includesSelector: aSelector in: aClass 
	^(super includesSelector: aSelector in: aClass) and: 
			[protocols 
				includes: (environment whichProtocolIncludes: aSelector in: aClass)]! !

!RBProtocolEnvironment methodsFor: 'accessing' stamp: ''!
definedClass
	^ class! !

!RBProtocolEnvironment methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	protocols := protocols copy! !

!RBProtocolEnvironment methodsFor: 'description' stamp: ''!
description

	^ label ifNil: [self defaultName , ' of ', self class name, self descriptionBasis]! !

!RBProtocolEnvironment methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass
	^aClass == class and: [(super includesProtocol: aProtocol in: aClass)
			and: [protocols includes: aProtocol]]! !

!RBProtocolEnvironment methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: class name, ' protocols: '.
	protocols do: [ :cls | aStream nextPutAll: cls, ', ']! !

!RBProtocolEnvironment methodsFor: 'testing' stamp: ''!
packages
	^ self methods collect: [ :m | m package ]! !

!RBProtocolEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass
	^ aClass == class and: [super includesClass: aClass]! !

!RBProtocolEnvironment methodsFor: 'removing' stamp: ''!
removeProtocol: aSymbol
	protocols remove: aSymbol ifAbsent: [  ]! !

!RBProtocolEnvironment methodsFor: 'accessing' stamp: ''!
protocols

	^ protocols! !

!RBProtocolEnvironment methodsFor: 'testing' stamp: ''!
definesClass: aClass
	^ aClass == class and: [super definesClass: aClass]! !

!RBProtocolEnvironment methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	super storeOn: aStream.
	aStream
		nextPutAll: ' class: ';
		nextPutAll: class name;
		nextPutAll: ' protocols: '.
	protocols asArray storeOn: aStream.
	aStream nextPut: $)! !

!RBProtocolEnvironment methodsFor: 'initialization' stamp: ''!
class: aClass protocols: aCollection
	class := aClass.
	protocols := aCollection asOrderedCollection! !

!RBProtocolEnvironment class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'Protocols'! !

!RBProtocolEnvironment class methodsFor: 'instance creation' stamp: ''!
onEnvironment: anEnvironment class: aClass protocols: aCollection
	^(self onEnvironment: anEnvironment)
		class: aClass protocols: aCollection; yourself! !

!RBProtocolEnvironment class methodsFor: 'instance creation' stamp: ''!
class: aClass protocols: aCollection
	^ self 
		onEnvironment: self default
		class: aClass
		protocols: aCollection! !

!RBProtocolRegexRefactoring commentStamp: ''!
I am a regex refactoring renaming protocol names.

See comment of superclass for a nice script to be adapated to package names.!
!RBProtocolRegexRefactoring methodsFor: 'transforming' stamp: ''!
transform

	| original replacement |

	self model
		allClassesDo: [ :class | 
			class selectors
				do: [ :selector | 
					original := ( class realClass whichCategoryIncludesSelector: selector ) asString.
					original
						ifNotNil: [ replacement := self execute: original.
							replacement = original
								ifFalse: [ class compile: ( class sourceCodeFor: selector ) classified: replacement ]
							]
					]
			]! !

!RBPullUpClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
self flag: 'TODO: Some conditions are in transformation part'.

	"self shouldFail: (self createRefactoringWithArguments:
		{ #Foo . #RBLintRuleTestData })"! !

!RBPullUpClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testPullUpClassVariable
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{ #RecursiveSelfRule . #RBLintRuleTestData }.
	[ self executeRefactoring: refactoring ] 
		on: RBRefactoringError 
		do: [ :e | e resume ].
	self assert: ((refactoring model classNamed: #RBLintRuleTestData) 
		directlyDefinesClassVariable: #RecursiveSelfRule).
	self deny: ((refactoring model classNamed: #RBTransformationRuleTestData) 
		directlyDefinesClassVariable: #RecursiveSelfRule)! !

!RBPullUpClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMetaClassFailure
	self shouldFail: 
		(self createRefactoringWithArguments: 
			{ #RecursiveSelfRule . #'RBLintRuleTestData class'})! !

!RBPullUpClassVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBPullUpClassVariableRefactoring .
					  #constructor -> #variable:class: };
		addCase: { #rbClass -> RBPullUpVariableTransformation .
					  #constructor -> #classVariable:class: };
		yourself! !

!RBPullUpClassVariableRefactoring commentStamp: ''!
I am a refactoring for moving a class variable up to the superclass.!
!RBPullUpClassVariableRefactoring methodsFor: 'private - accessing' stamp: ''!
subclassDefiningVariable
	| subclasses |
	subclasses := class allSubclasses 
		select: [ :each | each isMeta not and: [ each directlyDefinesClassVariable: variableName ] ].
	subclasses ifEmpty: [ self refactoringFailure: 'Could not find a class defining ' , variableName ].
	subclasses size > 1 
		ifTrue: [ self refactoringError: 'Multiple subclasses define ' , variableName ].
	^ subclasses asArray first! !

!RBPullUpClassVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	| subclass |
	subclass := self subclassDefiningVariable.
	subclass removeClassVariable: variableName.
	class addClassVariable: variableName! !

!RBPullUpClassVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition isMetaclass: class) not! !

!RBPullUpInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPullUpVariableNotDefined
	self shouldFail: (self createRefactoringWithArguments:
		{ 'notDefinedVariable' . #RBLintRuleTestData })! !

!RBPullUpInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testPullUpInstVar
	| refactoring |
	refactoring := self createRefactoringWithArguments:
			{'result' . #RBLintRuleTestData}.
	[self executeRefactoring: refactoring] 
		on: RBRefactoringError, RBRefactoringWarning
		do: [ :e | e resume ].
	self assert: ((refactoring model classNamed: #RBLintRuleTestData) 
		directlyDefinesInstanceVariable: 'result').
	self deny: ((refactoring model classNamed: #RBBasicLintRuleTestData) 
		directlyDefinesInstanceVariable: 'result').
	self deny: ((refactoring model classNamed: #RBFooLintRuleTestData) 
		directlyDefinesInstanceVariable: 'result')! !

!RBPullUpInstanceVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBPullUpInstanceVariableRefactoring .
					  #constructor -> #variable:class: };
		addCase: { #rbClass -> RBPullUpVariableTransformation .
					  #constructor -> #instanceVariable:class: };
		yourself! !

!RBPullUpInstanceVariableRefactoring commentStamp: ''!
I am a refactoring for moving a instance  variable up to the superclass.!
!RBPullUpInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	class allSubclasses do: 
			[:each | 
			(each directlyDefinesInstanceVariable: variableName) 
				ifTrue: [each removeInstanceVariable: variableName]].
	class addInstanceVariable: variableName! !

!RBPullUpInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^RBCondition withBlock: 
			[(class hierarchyDefinesInstanceVariable: variableName) 
				ifFalse: [self refactoringFailure: 'No subclass defines ' , variableName].
			(class subclasses 
				anySatisfy: [:each | (each directlyDefinesInstanceVariable: variableName) not]) 
				ifTrue: 
					[self 
						refactoringWarning: 'Not all subclasses have an instance variable named.<n> Do you want pull up this variable anyway?' 
								, variableName , '.'].
			true]! !

!RBPullUpInstanceVariableRefactoring class methodsFor: '*SystemCommands-VariableCommands' stamp: ''!
classVariableAnalog
	^RBPullUpClassVariableRefactoring! !

!RBPullUpMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPullUpWithSuperSendThatCannotBeCopiedDown
	| class |
	self addClassHierarchy.
	(model classNamed: #Object) compile: 'foo ^3' classified: #(#accessing).
	(model classNamed: #Subclass) compile: 'foo ^super foo'
		classified: #(#accessing).
	(class := model classNamed: #Foo2) compile: 'foo ^1'
		classified: #(#accessing).
	
	self shouldFail: (self createRefactoringWithModel: model 
		andArguments: { #(#foo) . class })! !

!RBPullUpMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testPullUpAndCopyDown
	| class |
	self addClassHierarchy.
	class := model classNamed: #Foo1.
	class compile: 'yourself ^1' classified: #(#accessing).
	self proceedThroughWarning: [ 
		self executeRefactoring: (self createRefactoringWithModel: model 
			andArguments: { #(#yourself) . class }) ].
	self assert: (class superclass parseTreeFor: #yourself) 
			equals: (self parseMethod: 'yourself ^1').
	self deny: (class directlyDefinesMethod: #yourself).
	class := model classNamed: #Foo2.
	self assert: (class directlyDefinesMethod: #yourself).
	self assert: (class parseTreeFor: #yourself) 
			equals: ((model classNamed: #Object) parseTreeFor: #yourself)! !

!RBPullUpMethodParametrizedTest methodsFor: 'tests' stamp: ''!
addClassHierarchy
	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'''.! !

!RBPullUpMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testDoesntPullUpReferencesInstVar
	| refactoring class |
	class := model classNamed: ('RBTransformation', 'RuleTestData1') asSymbol.
	refactoring := self createRefactoringWithModel: model 
		andArguments: { #(#foo ) . class }.
	[ self shouldFail: refactoring ] valueSupplyingAnswer: false.! !

!RBPullUpMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testPullUpInAHighHierarchyClass
	| class superClass |
	
	self addClassHierarchy .
	class := model classNamed: #Foo1.
	self addClassHierarchy.
	superClass := model classNamed: #SomeClass .
	class compile: 'example ^1' classified: #(#accessing).
	self executeRefactoring: (rbClass 
				model: model
				pullUp: #(#example)
				from: class 
				to: superClass ).
	self assert: (superClass parseTreeFor: #example) 
				equals: (self parseMethod: 'example ^1').
	self deny: (class directlyDefinesMethod: #example).
	class := model classNamed: #Subclass.
	self assert: (class definesMethod: #example).
	self assert: (class parseTreeFor: #example) 
				equals: ((model classNamed: #SomeClass) parseTreeFor: #example)! !

!RBPullUpMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPullUpWhenSuperClassDoesNotDirectlyImplement
	| classEnvironment classes |
	classes := #(#ClassA #ClassB #ClassC)
		inject: OrderedCollection new
		into: [ :sum :each | 
			testingEnvironment
				at: each
				ifPresent: [ :class | 
					sum
						add: class;
						add: class class ].
			sum ].
	classEnvironment := RBClassEnvironment classes: classes.
	model name: 'Test'.
	"Classes"
	#('Object subclass: #ClassA
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Testing'' ' 
		
		'ClassA subclass: #ClassB
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Testing'' ' 
		
		'ClassB subclass: #ClassC
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Testing'' ') do: [ :each | model defineClass: each ].
	#(#(#ClassA #(#('foo
			^ ''ClassA foo''' #private))) #(#ClassC #(#('foo
			^ ''ClassC foo''' #private))))
		do: [ :each | 
			| class |
			class := model classNamed: each first.
			each last
				do:
					[ :methodPair | class compile: methodPair first classified: methodPair last ] ].
	self shouldntWarn:
			 (self createRefactoringWithModel: model
				andArguments: { #(#foo) . (model classNamed: #ClassC) })! !

!RBPullUpMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testPullUpReferencesInstVar
	| refactoring class superClass |
	class := model classNamed: ('RBTransformation', 'RuleTestData1') asSymbol.
	refactoring := self createRefactoringWithModel: model
		andArguments: { #(#foo ) . class }.
	[ self executeRefactoring: refactoring ] valueSupplyingAnswer: true.
	superClass := model classNamed: ('RBFooLint', 'RuleTestData1') asSymbol.
	self assert: (superClass parseTreeFor: #foo) 
				equals: (self parseMethod: 'foo ^ foo').
	self assert: (superClass directlyDefinesInstanceVariable: #foo).
	self deny: (class directlyDefinesMethod: #foo).
	self deny: (class directlyDefinesInstanceVariable: #foo).! !

!RBPullUpMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
defaultNamespace
	^RBNamespace! !

!RBPullUpMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #pullUp:from:! !

!RBPullUpMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPullUpClassMethod
	| class |
	class := model classNamed: #Object.
	class addClassVariable: #Foo.
	class classSide 
		compile: 'foo ^Foo'
		classified: #(#accessing ).
	self shouldFail: (self createRefactoringWithModel: model
		andArguments: { #(#foo ) . class classSide })! !

!RBPullUpMethodParametrizedTest methodsFor: 'tests' stamp: ''!
addClassHierarchyForPools
	model defineClass: 'SharedPool subclass: #TotoSharedPool 
		instanceVariableNames: '''' 
		classVariableNames: ''SP'' 
		poolDictionaries: '''' 
		category: #''Refactory-Test data'''.
	model defineClass: 'Object subclass: #TotoSuperclass 
		instanceVariableNames: '''' 
		classVariableNames: '''' 
		poolDictionaries: '''' 
		category: #''Refactory-Test data'''.
	model defineClass: 'TotoSuperclass subclass: #Toto 
		instanceVariableNames: '''' 
		classVariableNames: '''' 
		poolDictionaries: ''TotoSharedPool'' 
		category: #''Refactory-Test data'''.
	
	(model classNamed: #Toto) compile: 'poolReference ^ SP' classified: #(#accessing).! !

!RBPullUpMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testPullUpMethodWithCopyOverriddenMethodsDown
	| refactoring |
	self proceedThroughWarning: 
		[ refactoring := self createRefactoringWithArguments: 
			{ #(#isComposite ) . RBCompositeLintRuleTestData }.
		self executeRefactoring: refactoring ].
	self assert: ((refactoring model classNamed: #RBBasicLintRuleTestData) 
			parseTreeFor: #isComposite) 
		equals: (self parseMethod: 'isComposite ^false').
	self assert: ((refactoring model classNamed: ('RBFoo' , 'LintRuleTestData') asSymbol) 
			parseTreeFor: #isComposite) 
		equals: (self parseMethod: 'isComposite ^false').
	self assert: ((refactoring model classNamed: #RBLintRuleTestData) 
			parseTreeFor: #isComposite) 
		equals: (self parseMethod: 'isComposite ^true').
	self deny: ((refactoring model classNamed: #RBCompositeLintRuleTestData) 
		directlyDefinesMethod: #isComposite)! !

!RBPullUpMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPullUpWithMethodThatCannotBePullUp
	model 
		defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: ''Foo'' poolDictionaries: '''' category: #''Refactory-Test data'''.
	(model classNamed: #SomeClass) compile: 'yourself ^54'
		classified: #(#accessing).
	
	self shouldFail: (self createRefactoringWithModel: model
		andArguments: { #(#yourself) . (model classNamed: #SomeClass) })! !

!RBPullUpMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testPullUpMethodWithSharedPool
	| class superClass |
	
	self addClassHierarchyForPools.
	class := model classNamed: #Toto.
	superClass := model classNamed: #TotoSuperclass.
	self proceedThroughWarning: [ 
		self executeRefactoring: (rbClass
			model: model
			pullUp: #(#poolReference)
			from: class 
			to: superClass) ].
	self assert: (superClass parseTreeFor: #poolReference) 
				equals: (self parseMethod: 'poolReference ^ SP').
	self deny: (class directlyDefinesMethod: #poolReference).! !

!RBPullUpMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPullUpWithInvalidSuperSend
	| class |
	self addClassHierarchy .
	(model classNamed: #Foo2) compile: 'yourself ^super yourself + 1'
		classified: #(#accessing).
	class := model classNamed: #Foo1.
	class compile: 'yourself ^1' classified: #(#accessing).
	
	self shouldFail: (self createRefactoringWithModel: model 
		andArguments: { #(#yourself) . class })! !

!RBPullUpMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBPullUpMethodRefactoring };
		addCase: { #rbClass -> RBPullUpMethodTransformation };
		yourself! !

!RBPullUpMethodRefactoring commentStamp: ''!
I am a refactoring for moving a method up to the superclass. 

My precondition verify that this method does not refere to instance variables not accessible in the superclass. And this method does not sends a super message that is defined in the superclass.
If the method already exists and the superclass is abstract or not referenced anywhere, replace that implementation and push down the old method to all other existing subclasses.


!
!RBPullUpMethodRefactoring methodsFor: 'private' stamp: ''!
copyDownMethod: aSelector 
	| oldProtocol oldSource superclassDefiner subclasses refactoring |
	superclassDefiner := targetSuperclass whoDefinesMethod: aSelector.
	superclassDefiner ifNil: [^ self ].
	oldSource := superclassDefiner sourceCodeFor: aSelector.
	oldSource ifNil: 
			[ self 
				refactoringFailure: ('Source code for <1s> superclass method not available' 
						expandMacrosWith: aSelector)].
	oldProtocol := superclassDefiner protocolsFor: aSelector.
	subclasses := targetSuperclass subclasses 
				reject: [:each | each directlyDefinesMethod: aSelector].
	subclasses ifEmpty: [^ self ].
	(superclassDefiner parseTreeFor: aSelector) superMessages 
		detect: [:each | superclassDefiner directlyDefinesMethod: each]
		ifFound: 
			[self 
				refactoringError: ('Cannot pull up <1s> since we must copy down the superclass method in <2p><n>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 performCompositeRefactoring: refactoring.
	subclasses do: [:each | each compile: oldSource classified: oldProtocol]! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkInstVars
	selectors do: [:each | self checkInstVarsFor: each]! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkBackReferencesTo: aSelector 
	| definingClass pushUpParseTree |
	definingClass := targetSuperclass whoDefinesMethod: aSelector.
	definingClass ifNil: [^self].
	pushUpParseTree := class parseTreeFor: aSelector.
	targetSuperclass allSubclasses do: 
			[:each | 
			each selectors do: 
					[:sel | 
					| parseTree |
					parseTree := each parseTreeFor: sel.
					(parseTree notNil and: 
							[(parseTree superMessages includes: aSelector) 
								and: [definingClass == (each whoDefinesMethod: aSelector)]]) 
						ifTrue: 
							[removeDuplicates := true.
							(aSelector == sel 
								and: [parseTree equalTo: pushUpParseTree exceptForVariables: #()]) 
									ifFalse: 
										[self 
											refactoringError: ('Cannot pull up <1s> since it would override the method defined in <2p>' 
													expandMacrosWith: aSelector
													with: definingClass)]]]]! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkSuperMessages
	self checkSuperSendsFromPushedUpMethods.
	self checkSuperSendsFromSiblings! !

!RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
copyDownMethods
	selectors do: [:each | self copyDownMethod: each]! !

!RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
removeDuplicateMethods
	selectors do: [:each | self removeDuplicatesOf: each]! !

!RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
pullUpMethods
	selectors do: [:each | self pullUp: each]! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkClassVarsFor: aSelector 
	class instanceSide classVariableNames do: 
		[ :each | 
		((class whichSelectorsReferToClassVariable: each) includes: aSelector) ifTrue: 
			[ self refactoringError: ('<1p> refers to <2s> which is defined in <3p>' 
					expandMacrosWith: aSelector
					with: each
					with: class) ] ]! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
pushUpVariable: aVariable
	| refactoring |
	refactoring :=  RBPullUpInstanceVariableRefactoring 
			model: self model
			variable: aVariable
			class: targetSuperclass.
	self performCompositeRefactoring: refactoring.! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkSuperSendsFromSiblings
	| siblings |
	siblings := targetSuperclass subclasses reject: [:each | each = class].
	siblings do: [:aRBClass | self checkSiblingSuperSendsFrom: aRBClass]! !

!RBPullUpMethodRefactoring methodsFor: 'initialization' stamp: ''!
selectors
	^ selectors! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkSuperclass
	| overrideSelectors |
	overrideSelectors := selectors
		select: [ :each | targetSuperclass directlyDefinesMethod: each ].
	overrideSelectors := overrideSelectors
		reject: [ :each | 
			| myTree superTree |
			myTree := class parseTreeFor: each.
			superTree := targetSuperclass parseTreeFor: each.
			superTree equalTo: myTree exceptForVariables: #() ].
	overrideSelectors ifEmpty: [ ^ self ].
	targetSuperclass isAbstract
		ifFalse: [ self
				refactoringError:
					('Non-abstract class <2p> already defines <1p>'
						expandMacrosWith: overrideSelectors asArray first
						with: targetSuperclass) ].
	overrideSelectors do: [ :each | self checkBackReferencesTo: each ]! !

!RBPullUpMethodRefactoring methodsFor: 'initialization' stamp: ''!
selectors: aList
	selectors := aList! !

!RBPullUpMethodRefactoring methodsFor: 'initialization' stamp: ''!
superClass: anObject
	(anObject allSubclasses includes: class realClass ) 
		ifFalse: [ self refactoringError: 
			('<1s> is not a superclass of <2p>' expandMacrosWith: anObject with: class name ) ].
	targetSuperclass := self classObjectFor: anObject.! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
requestSuperClass
	^(self options at: #superClass) value: self! !

!RBPullUpMethodRefactoring methodsFor: 'initialization' stamp: ''!
pullUp: selectorCollection from: aClass 
	self pullUp: selectorCollection from: aClass to: aClass superclass ! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	self requestSuperClass.
	^(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: 'transforming' stamp: ''!
transform
	self
		copyDownMethods;
		pullUpMethods;
		removePulledUpMethods;
		removeDuplicateMethods! !

!RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
removePulledUpMethods
	selectors do: [:each | class removeMethod: each]! !

!RBPullUpMethodRefactoring methodsFor: 'initialization' stamp: ''!
pullUp: selectorCollection from: aClass to: aSuperClass
	self setOption: #superClass toUse: [ :ref | ].
	class := self classObjectFor: aClass.
	targetSuperclass := self classObjectFor: aSuperClass .
	selectors := selectorCollection.
	removeDuplicates := false! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkClassVars
	selectors do: [:each | self checkClassVarsFor: each]! !

!RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
pullUp: aSelector 
	| source refactoring |
	source := class sourceCodeFor: aSelector.
	source ifNil: [self refactoringFailure: 'Source for method not available'].
	refactoring := RBExpandReferencedPoolsRefactoring 
				model: self model
				forMethod: (class parseTreeFor: aSelector)
				fromClass: class
				toClasses: (Array with: targetSuperclass).
	self performCompositeRefactoring: refactoring.
	targetSuperclass compile: source
		classified: (class protocolsFor: aSelector)! !

!RBPullUpMethodRefactoring methodsFor: 'initialization' stamp: ''!
targetClass
	^ class! !

!RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: ''!
removeDuplicatesOf: aSelector 
	| tree |
	tree := targetSuperclass parseTreeFor: aSelector.
	targetSuperclass allSubclasses do: 
			[:each | 
			((each directlyDefinesMethod: aSelector) and: 
					[(tree equalTo: (each parseTreeFor: aSelector) exceptForVariables: #()) 
						and: [(each superclass whoDefinesMethod: aSelector) == targetSuperclass]]) 
				ifTrue: 
					[removeDuplicates 
						ifFalse: 
							[removeDuplicates := 
							self 
								refactoringConfirmWarning: 'Do you want to remove duplicate subclass methods?'].
					removeDuplicates ifTrue:[
					each removeMethod: aSelector]]]! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkInstVarsFor: aSelector 
	class instanceVariableNames do: 
			[:each | 
			((class whichSelectorsReferToInstanceVariable: each) includes: aSelector) ifTrue: 
					[ (self confirm: ('<1p> refers to #<2s> which is defined in <3p>. Do you want push up variable #<2s> also?' expandMacrosWith: aSelector
								with: each
								with: class)) 
						ifTrue: [ self pushUpVariable: each ]
						ifFalse: [ self refactoringError: 'You are about to push your method without the instance variable it uses. 
						It will bring the system is an inconsistent state. But this may be what you want.
						So do you want to push up anyway?' ] ]]! !

!RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkSuperSendsFromPushedUpMethods
	selectors do: 
			[:each | 
			| parseTree |
			parseTree := class parseTreeFor: each.
			parseTree superMessages 
				detect: [:sup | targetSuperclass directlyDefinesMethod: sup]
				ifFound: 
					[self 
						refactoringError: ('Cannot pull up <1s> since it sends a super message that is defined in the superclass.' 
								expandMacrosWith: each)]]! !

!RBPullUpMethodRefactoring methodsFor: 'printing' stamp: ''!
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: 'preconditions' stamp: ''!
checkSiblingSuperSendsFrom: aRBClass 
	aRBClass selectors do: 
			[:each | 
			| tree |
			tree := aRBClass parseTreeFor: each.
			tree ifNotNil: 
					[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 class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk pullUp: selectorCollection from: aClass 
	^ self new
		model: aRBSmalltalk;
		pullUp: selectorCollection from: aClass;
		yourself! !

!RBPullUpMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk pullUp: selectorCollection from: aClass to: aSuperClass
	^ self new
		model: aRBSmalltalk;
		pullUp: selectorCollection from: aClass to: aSuperClass;
		yourself! !

!RBPullUpMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
pullUp: selectorCollection from: aClass 
	^ self new 
		pullUp: selectorCollection from: aClass! !

!RBPullUpMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
pullUp: selectorCollection from: aClass to: aSuperClass
	^ self new 
		pullUp: selectorCollection from: aClass to: aSuperClass ! !

!RBPullUpMethodTransformation methodsFor: 'executing' stamp: ''!
copyDownMethod: aSelector
	| oldProtocol oldSource superclassDefiner subclasses refactoring |
	superclassDefiner := targetSuperclass whoDefinesMethod: aSelector.
	superclassDefiner ifNil: [^ {  } ].
	oldSource := superclassDefiner sourceCodeFor: aSelector.
	oldSource ifNil: 
			[ self 
				refactoringFailure: ('Source code for <1s> superclass method not available' 
						expandMacrosWith: aSelector)].
	oldProtocol := superclassDefiner protocolsFor: aSelector.
	subclasses := targetSuperclass subclasses 
				reject: [:each | each directlyDefinesMethod: aSelector].
	subclasses ifEmpty: [^ {  } ].
	(superclassDefiner parseTreeFor: aSelector) superMessages 
		detect: [:each | superclassDefiner directlyDefinesMethod: each]
		ifFound: 
			[self 
				refactoringError: ('Cannot pull up <1s> since we must copy down the superclass method in <2p><n>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 := RBExpandReferencedPoolsTransformation
				model: self model
				forMethod: (superclassDefiner parseTreeFor: aSelector)
				fromClass: superclassDefiner
				toClasses: subclasses.
	^ Array with: refactoring
		withAll: (subclasses collect: 
		[:each | RBAddMethodTransformation
			model: self model
			sourceCode: oldSource
			in: each
			withProtocols: oldProtocol])! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkInstVars
	selectors do: [:each | self checkInstVarsFor: each]! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkBackReferencesTo: aSelector
	| definingClass pushUpParseTree |
	definingClass := targetSuperclass whoDefinesMethod: aSelector.
	definingClass ifNil: [^self].
	pushUpParseTree := class parseTreeFor: aSelector.
	targetSuperclass 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)]]]]! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkSuperMessages
	self checkSuperSendsFromPushedUpMethods.
	self checkSuperSendsFromSiblings! !

!RBPullUpMethodTransformation methodsFor: 'executing' stamp: ''!
copyDownMethods
	^ selectors flatCollect: [:each | self copyDownMethod: each]! !

!RBPullUpMethodTransformation methodsFor: 'executing' stamp: ''!
removeDuplicateMethods
	^ selectors collect: [:each | self removeDuplicatesOf: each]! !

!RBPullUpMethodTransformation methodsFor: 'executing' stamp: ''!
pullUpMethods
	^ selectors flatCollect: [:each | self pullUp: each]! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkClassVarsFor: aSelector
	class instanceSide 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) ] ]! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
pushUpVariable: aVariable
	^ RBPullUpVariableTransformation
			model: self model
			instanceVariable: aVariable
			class: targetSuperclass! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkSuperSendsFromSiblings
	| siblings |
	siblings := targetSuperclass subclasses reject: [:each | each = class].
	siblings do: [:aRBClass | self checkSiblingSuperSendsFrom: aRBClass]! !

!RBPullUpMethodTransformation methodsFor: 'converting' stamp: ''!
asRefactoring

	^ super asRefactoring
		delegatesPreconditions: false;
		yourself! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkSuperclass
	| overrideSelectors |
	overrideSelectors := selectors
		select: [ :each | targetSuperclass directlyDefinesMethod: each ].
	overrideSelectors := overrideSelectors
		reject: [ :each | 
			| myTree superTree |
			myTree := class parseTreeFor: each.
			superTree := targetSuperclass parseTreeFor: each.
			superTree equalTo: myTree exceptForVariables: #() ].
	overrideSelectors ifEmpty: [ ^ self ].
	targetSuperclass isAbstract
		ifFalse: [ self
				refactoringError:
					('Non-abstract class <2p> already defines <1p>'
						expandMacrosWith: overrideSelectors asArray first
						with: targetSuperclass) ].
	overrideSelectors do: [ :each | self checkBackReferencesTo: each ]! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
requestSuperClass
	^ (self options at: #superClass) value: self! !

!RBPullUpMethodTransformation methodsFor: 'api' stamp: ''!
pullUp: selectorCollection from: aClass
	self pullUp: selectorCollection from: aClass to: aClass superclass ! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	self requestSuperClass.
	^(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])! !

!RBPullUpMethodTransformation methodsFor: 'executing' stamp: ''!
removePulledUpMethods
	^ selectors collect: [:symbol | 
		RBRemoveMethodTransformation 
			model: self model
			selector: symbol
			from: class ]! !

!RBPullUpMethodTransformation methodsFor: 'api' stamp: ''!
pullUp: selectorCollection from: aClass to: aSuperClass
	self setOption: #superClass toUse: [ :ref | ].
	class := self model classObjectFor: aClass.
	targetSuperclass := self model classObjectFor: aSuperClass .
	selectors := selectorCollection.
	removeDuplicates := false! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkClassVars
	selectors do: [:each | self checkClassVarsFor: each]! !

!RBPullUpMethodTransformation methodsFor: 'executing' stamp: ''!
pullUp: aSelector
	| source refactoring |
	source := class sourceCodeFor: aSelector.
	source ifNil: [self refactoringFailure: 'Source for method not available'].
	refactoring := RBExpandReferencedPoolsTransformation
				model: self model
				forMethod: (class parseTreeFor: aSelector)
				fromClass: class
				toClasses: (Array with: targetSuperclass).
	^ Array 
		with: refactoring 
		with: (RBAddMethodTransformation
		model: self model 
		sourceCode: source 
		in: targetSuperclass
		withProtocols: (class protocolsFor: aSelector))! !

!RBPullUpMethodTransformation methodsFor: 'executing' stamp: ''!
removeDuplicatesOf: aSelector
	^ RBCustomTransformation 
		model: self model 
		with: [ :rbModel | 
			| tree |
			tree := targetSuperclass parseTreeFor: aSelector.
			targetSuperclass allSubclasses collect: 
			[:aClass | 
			((aClass directlyDefinesMethod: aSelector) and: 
					[(tree equalTo: (aClass parseTreeFor: aSelector) exceptForVariables: #()) 
						and: [(aClass superclass whoDefinesMethod: aSelector) == targetSuperclass]]) 
				ifTrue: 
					[removeDuplicates 
						ifFalse: 
							[removeDuplicates := self refactoringConfirmWarning: 
							'Do you want to remove duplicate subclass methods?'].
					removeDuplicates ifTrue:[
						(RBRemoveMethodTransformation 
							model: self model
							selector: aClass
							from: aSelector) transform ]]]]! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkInstVarsFor: aSelector
	class instanceVariableNames do: 
			[:each | 
			((class whichSelectorsReferToInstanceVariable: each) includes: aSelector) ifTrue: 
					[ (self confirm: ('<1p> refers to #<2s> which is defined in <3p>. Do you want push up variable #<2s> also?' expandMacrosWith: aSelector
								with: each
								with: class)) 
						ifTrue: [ self previousTransformations add: (self pushUpVariable: each) ]
						ifFalse: [ self refactoringError: 'You are about to push your method without the instance variable it uses. 
						It will bring the system is an inconsistent state. But this may be what you want.
						So do you want to push up anyway?' ] ]]! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkSuperSendsFromPushedUpMethods
	selectors do: 
			[:each | 
			| parseTree |
			parseTree := class parseTreeFor: each.
			parseTree superMessages 
				detect: [:sup | targetSuperclass directlyDefinesMethod: sup]
				ifFound: 
					[self 
						refactoringError: ('Cannot pull up <1s> since it sends a super message that is defined in the superclass.' 
								expandMacrosWith: each)]]! !

!RBPullUpMethodTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' pullUp: ';
		nextPutAll: selectors asString;
		nextPutAll: ' from: ';
		nextPutAll: class name;
		nextPutAll: ' to: ';
		nextPutAll: targetSuperclass name.
	aStream nextPut: $)! !

!RBPullUpMethodTransformation methodsFor: 'executing' stamp: ''!
buildTransformations
	^ OrderedCollection new
		addAll: self copyDownMethods;
		addAll: self pullUpMethods;
		addAll: self removePulledUpMethods;
		addAll: self removeDuplicateMethods;
		removeAllSuchThat: [ :e | e isNil ];
		yourself! !

!RBPullUpMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkSiblingSuperSendsFrom: aRBClass
	aRBClass selectors do: 
			[:each | 
			| tree |
			tree := aRBClass parseTreeFor: each.
			tree ifNotNil: 
					[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]! !

!RBPullUpMethodTransformation class methodsFor: 'api' stamp: ''!
model: aRBNamespace pullUp: selectorCollection from: aClass
	^ self new
		model: aRBNamespace;
		pullUp: selectorCollection from: aClass;
		yourself! !

!RBPullUpMethodTransformation class methodsFor: 'api' stamp: ''!
model: aRBNamespace pullUp: selectorCollection from: aClass to: aSuperClass
	^ self new
		model: aRBNamespace;
		pullUp: selectorCollection from: aClass to: aSuperClass;
		yourself! !

!RBPullUpMethodTransformation class methodsFor: 'api' stamp: ''!
pullUp: selectorCollection from: aClass
	^ self new pullUp: selectorCollection from: aClass! !

!RBPullUpMethodTransformation class methodsFor: 'api' stamp: ''!
pullUp: selectorCollection from: aClass to: aSuperClass
	^ self new pullUp: selectorCollection from: aClass to: aSuperClass! !

!RBPullUpVariableTransformation commentStamp: ''!
Removes this variable from all the subclasses of a class, then adds this variable in this class. If none of the subclasses define a variable with the given name, this transformation works as a RBAddVariableTransformation.

Usage:
transformation := (RBPullUpVariableTransformation
		instanceVariable: 'result'
		class: #RBLintRuleTest)
		transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
overriden from RBRemoveVariableTransformation and RBAddVariableAccessorTransformation!
!RBPullUpVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditions 
	^ isClassVariable 
		ifTrue: [ (RBCondition isMetaclass: self definingClass) not ] 
		ifFalse: [ RBCondition withBlock: 
			[(self definingClass hierarchyDefinesInstanceVariable: variableName) 
				ifFalse: [self refactoringFailure: 'No subclass defines ' , variableName].
			(self definingClass subclasses 
				anySatisfy: [:each | (each directlyDefinesInstanceVariable: variableName) not]) 
				ifTrue: 
					[self 
						refactoringWarning: 'Not all subclasses have an instance variable named.<n> Do you want pull up this variable anyway?' 
								, variableName , '.'].
			true] ]! !

!RBPullUpVariableTransformation methodsFor: 'private' stamp: ''!
variableDefinitionsInHierarchy

	^ self definingClass allSubclasses
		select: [ :each |
			isClassVariable
				ifTrue: [ each isMeta not and: [ each directlyDefinesClassVariable: variableName ] ]
				ifFalse: [ each directlyDefinesInstanceVariable: variableName ] ]
		thenCollect: #name
	
	! !

!RBPullUpVariableTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName class: aClassName classVariable: aBoolean

	variableName := aVariableName.
	isClassVariable := aBoolean.
	className := aClassName.! !

!RBPullUpVariableTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' variable: '.
	variableName storeOn: aStream.
	aStream nextPutAll: ' class: '.
	className storeOn: aStream.
	aStream nextPutAll: ' classVariable: '.
	isClassVariable storeOn: aStream.
	aStream nextPut: $)! !

!RBPullUpVariableTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	^ OrderedCollection new
		addAll: (self variableDefinitionsInHierarchy
			collect: [ :each | 
				RBRemoveVariableTransformation
				model: self model
				variable: variableName
				class: each
				classVariable: isClassVariable ]);
		add: (RBAddVariableTransformation
				model: self model
				variable: variableName
				class: className
				classVariable: isClassVariable);
		yourself! !

!RBPushDownClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
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 instanceSide.
	
	self executeRefactoring: (self createRefactoringWithModel: model
		andArguments: {#Foo . #SomeClass}).
		
	self deny: (class superclass superclass directlyDefinesClassVariable: #Foo).
	self deny: (class superclass directlyDefinesClassVariable: #Foo).
	self assert: (class directlyDefinesClassVariable: #Foo)! !

!RBPushDownClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	self shouldFail: 
		(self createRefactoringWithArguments: { #Foo . #RBBasicLintRuleTestData })! !

!RBPushDownClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
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: (self createRefactoringWithModel: model
		andArguments: { #Foo . #SomeClass }).
	self deny: ((model classNamed: #SomeClass) directlyDefinesVariable: #Foo).
	self deny: ((model classNamed: #Subclass) directlyDefinesVariable: #Foo)! !

!RBPushDownClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelNonExistantName
	model defineClass: 'Object subclass: #SomeClass 
		instanceVariableNames: '''' 
		classVariableNames: '''' 
		poolDictionaries: '''' 
		category: #''Refactory-Test data'''.
	self shouldFail: (self createRefactoringWithModel: model 
		andArguments: { #Foo . #SomeClass })! !

!RBPushDownClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
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: (self createRefactoringWithModel: model 
		andArguments: { #Foo . #SomeClass })! !

!RBPushDownClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testPushDownClassVariable
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ #Foo1 . #RBLintRuleTestData }.
	class := (refactoring model classNamed: #RBLintRuleTestData).
	
	self assert: (class directlyDefinesClassVariable: #Foo1).
	
	self executeRefactoring: refactoring.
		class withAllSubclasses 
			do: [ :each | self deny: (each directlyDefinesClassVariable: #Foo1) ]! !

!RBPushDownClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
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: (self createRefactoringWithModel: model 
		andArguments: { #Foo . #SomeClass}).
	self deny: (class superclass directlyDefinesClassVariable: #Foo).
	self assert: (class directlyDefinesClassVariable: #Foo)! !

!RBPushDownClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
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: (self createRefactoringWithModel: model
		andArguments: {#Foo . #SomeClass}).
	self deny: (class superclass directlyDefinesClassVariable: #Foo).
	self assert: (class directlyDefinesClassVariable: #Foo)! !

!RBPushDownClassVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBPushDownClassVariableRefactoring .
					  #constructor -> #variable:class: };
		addCase: { #rbClass -> RBPushDownVariableTransformation .
					  #constructor -> #classVariable:class: };
		yourself! !

!RBPushDownClassVariableRefactoring commentStamp: ''!
I am a refactoring for moving a class variable down to my subclasses.

My precondition verifies that the moved variable is not referenced in the methods of the original class.!
!RBPushDownClassVariableRefactoring methodsFor: 'preconditions' stamp: ''!
findDestinationClass
	| classes |
	classes := class withAllSubclasses reject: [ :each |
		(each whichSelectorsReferToClassVariable: variableName) isEmpty
			and: [ (each classSide whichSelectorsReferToClassVariable: variableName) isEmpty ] ].
	destinationClass := classes ifEmpty: [ nil ]
		ifNotEmpty: [ classes asOrderedCollection first ].
	classes do: [ :each | 
		(destinationClass includesClass: each) 
			ifTrue: [ destinationClass := each ]
				ifFalse: [
					(each includesClass: destinationClass) 
						ifFalse: [ self signalMultipleReferenceError ] ] ].
	destinationClass = class 
		ifTrue: [ self signalStillReferencedError ].
	^ destinationClass! !

!RBPushDownClassVariableRefactoring methodsFor: 'preconditions' stamp: ''!
signalMultipleReferenceError
	self signalReferenceError: ('Multiple subclasses reference <1s>' 
				expandMacrosWith: variableName)! !

!RBPushDownClassVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform

	class removeClassVariable: variableName.
	destinationClass ifNil: [ ^ self ].
	destinationClass addClassVariable: variableName! !

!RBPushDownClassVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	"Preconditions are that only one subclass refers to the class variable."

	^(RBCondition definesClassVariable: variableName in: class) 
		& (RBCondition withBlock: 
					[self findDestinationClass.
					true])! !

!RBPushDownClassVariableRefactoring methodsFor: 'preconditions' stamp: ''!
signalReferenceError: errorString

	class realClass
		ifNil: [ self refactoringError: errorString ]
		ifNotNil: [ | classVarName error |

			error := '<1s><n>Browse references?' expandMacrosWith: errorString.
			classVarName := variableName asSymbol.
			self
				refactoringError: error
				with: [ self
						openBrowserOn: ( RBVariableEnvironment referencesToClassVariable: classVarName in: class realClass )
					]
			]! !

!RBPushDownClassVariableRefactoring methodsFor: 'preconditions' stamp: ''!
signalStillReferencedError
	self signalReferenceError: ('<1p> has references to <2s>' 
				expandMacrosWith: class
				with: variableName)! !

!RBPushDownInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	self shouldFail: 
		(self createRefactoringWithArguments: {'foo' . #RBBasicLintRuleTestData})! !

!RBPushDownInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
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: (self createRefactoringWithModel: model 
		andArguments: {'foo' . #SomeClass}).
	self deny: ((model classNamed: #SomeClass) directlyDefinesVariable: 'foo').
	self assert: ((model classNamed: #Subclass) directlyDefinesVariable: 'foo')! !

!RBPushDownInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
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: (self createRefactoringWithModel: model 
		andArguments: {'foo' . #SomeClass}).
	self deny: ((model classNamed: #SomeClass) directlyDefinesVariable: 'foo').
	self assert: ((model classNamed: #Subclass) directlyDefinesVariable: 'foo').
	self assert: ((model classNamed: #AnotherSubclass) directlyDefinesVariable: 'foo')! !

!RBPushDownInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testPushDownInstanceVariable
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{'foo1' . #RBLintRuleTestData}.
	self executeRefactoring: refactoring.
	(refactoring model classNamed: #RBLintRuleTestData) subclasses do: 
		[ :each | self assert: (each directlyDefinesInstanceVariable: 'foo1') ]! !

!RBPushDownInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
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: (self createRefactoringWithModel: model 
		andArguments: {'foo' . #'SomeClass class'}).
	self 
		deny: ((model metaclassNamed: #SomeClass) directlyDefinesVariable: 'foo').
	self 
		assert: ((model metaclassNamed: #Subclass) directlyDefinesVariable: 'foo')! !

!RBPushDownInstanceVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBPushDownInstanceVariableRefactoring .
					  #constructor -> #variable:class: };
		addCase: { #rbClass -> RBPushDownVariableTransformation .
					  #constructor -> #instanceVariable:class: };
		yourself! !

!RBPushDownInstanceVariableRefactoring commentStamp: ''!
I am a refactoring for moving a instance variable down to my subclasses.

My precondition verifies that the moved variable is not referenced in the methods of the original class.!
!RBPushDownInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	class removeInstanceVariable: variableName.
	class subclasses do: [:each | each addInstanceVariable: variableName]! !

!RBPushDownInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	| references |

	references := RBCondition referencesInstanceVariable: variableName in: class.
	class realClass
		ifNil: [ references errorMacro: ( '<1s> is referenced.' expandMacrosWith: variableName ) ]
		ifNotNil: [ references
				errorMacro: ( '<1s> is referenced.<n>Browse references?' expandMacrosWith: variableName );
				errorBlock:
						[ self openBrowserOn: ( RBBrowserEnvironment new instVarRefsTo: variableName in: class realClass ) ]
			].
	^ ( RBCondition definesInstanceVariable: variableName in: class ) & references not! !

!RBPushDownInstanceVariableRefactoring class methodsFor: '*SystemCommands-VariableCommands' stamp: ''!
classVariableAnalog
	^RBPushDownClassVariableRefactoring! !

!RBPushDownMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testPushDownMethod
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ #(#name: ) . RBLintRuleTestData }.
	self executeRefactoring: refactoring asRefactoring.
	class := refactoring model classNamed: #RBLintRuleTestData.
	self deny: (class directlyDefinesMethod: #name:).
	class subclasses do: 
		[ :each | 
		self assert: (each parseTreeFor: #name:)
			equals: (self parseMethod: 'name: aString name := aString') ]! !

!RBPushDownMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testPushDownMethodThatReferencesPoolDictionary
	| refactoring class parseTree |
	parseTree := RBLintRuleTestData parseTreeFor: #junk.
	refactoring := self createRefactoringWithArguments: 
		{ #(#junk ) . RBLintRuleTestData }.
	self executeRefactoring: refactoring asRefactoring.
	class := refactoring model classNamed: #RBLintRuleTestData.
	self deny: (class directlyDefinesMethod: #junk).
	class subclasses do: 
		[ :each | 
		self assert: (each parseTreeFor: #junk) equals: parseTree.
		self assert: (each definesPoolDictionary: 'TextConstants' asSymbol) ]! !

!RBPushDownMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPushDownNonExistantMenu
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{ #(#someMethodThatDoesNotExist ) . RBLintRuleTestData }.
	self shouldFail: refactoring asRefactoring! !

!RBPushDownMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #pushDown:from:! !

!RBPushDownMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPushDownMethodOnNonAbstractClass
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{ #(#isArray) . Array }.
	self shouldFail: refactoring asRefactoring! !

!RBPushDownMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPushDownMethodSubclassesReferToSelector
	| refactoring |
	model defineClass: 'Object subclass: #Superclass 
		instanceVariableNames: '''' 
		classVariableNames: '''' 
		poolDictionaries: '''' 
		category: #''Refactory-Test data'''.
	model defineClass: 'Superclass subclass: #Foo1 
		instanceVariableNames: '''' 
		classVariableNames: '''' 
		poolDictionaries: '''' 
		category: #''Refactory-Test data'''.
	model defineClass: 'Superclass subclass: #Foo2 
		instanceVariableNames: '''' 
		classVariableNames: '''' 
		poolDictionaries: '''' 
		category: #''Refactory-Test data'''.
	(model classNamed: #Superclass) compile: 'yourself ^1' classified: #(#accessing).
	(model classNamed: #Foo1) compile: 'method1 ^super yourself' classified: #(#accessing).
	
	refactoring := rbClass 
		model: model
		pushDown: #(#yourself)
		from: (model classNamed: #Superclass).
	self shouldFail: refactoring asRefactoring! !

!RBPushDownMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBPushDownMethodRefactoring };
		addCase: { #rbClass -> RBPushDownMethodTransformation };
		yourself! !

!RBPushDownMethodRefactoring commentStamp: ''!
I am a refactoring for moving a method down to all direct subclasses.

My preconditions verify that this method isn't refered  as a super send in the subclass. And the class defining this method is abstract or not referenced anywhere.

!
!RBPushDownMethodRefactoring methodsFor: 'transforming' stamp: ''!
selectors: aList
	selectors := aList! !

!RBPushDownMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform
	selectors do: [:each | self pushDown: each].
	selectors do: [:each | class removeMethod: each]! !

!RBPushDownMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	| condition |
	condition := selectors
		             inject: self emptyCondition
		             into: [ :cond :each | 
			             cond & (RBCondition definesSelector: each in: class)
			             &
			             (RBCondition subclassesOf: class referToSelector: each)
				             not ].
	^ condition & (RBCondition isAbstractClass: class)! !

!RBPushDownMethodRefactoring methodsFor: 'transforming' stamp: ''!
allClasses

	^ classes ifNil: [ class subclasses ]! !

!RBPushDownMethodRefactoring methodsFor: 'transforming' stamp: ''!
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: self allClasses.
	self performCompositeRefactoring: refactoring.
	self allClasses do: [ :each | 
		(each directlyDefinesMethod: aSelector) ifFalse: [ 
			each compile: code classified: protocols ] ]! !

!RBPushDownMethodRefactoring methodsFor: 'transforming' stamp: ''!
classes: aCollection
	classes := aCollection collect: [ :cls | 
		self classObjectFor: cls.
	]! !

!RBPushDownMethodRefactoring methodsFor: 'preconditions' stamp: ''!
targetClass
	^ class! !

!RBPushDownMethodRefactoring methodsFor: 'initialization' stamp: ''!
pushDown: selectorCollection from: aClass in: aCollection
	class := self classObjectFor: aClass.
	selectors := selectorCollection.
	self classes: aCollection.! !

!RBPushDownMethodRefactoring methodsFor: 'initialization' stamp: ''!
pushDown: selectorCollection from: aClass 
	class := self classObjectFor: aClass.
	selectors := selectorCollection! !

!RBPushDownMethodRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' pushDown: '.
	selectors asArray storeOn: aStream.
	aStream nextPutAll: ' from: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBPushDownMethodRefactoring methodsFor: 'transforming' stamp: ''!
selectors
	^ selectors! !

!RBPushDownMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk pushDown: selectorCollection from: aClass 
	^ self new
		model: aRBSmalltalk;
		pushDown: selectorCollection from: aClass;
		yourself! !

!RBPushDownMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
pushDown: selectorCollection from: aClass in: classes
	^ self new
		pushDown: selectorCollection from: aClass in: classes! !

!RBPushDownMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
pushDown: selectorCollection from: aClass 
	^ self new
		pushDown: selectorCollection from: aClass! !

!RBPushDownMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk pushDown: selectorCollection from: aClass in: classes
	^ self new
		model: aRBSmalltalk;
		pushDown: selectorCollection from: aClass in: classes;
		yourself! !

!RBPushDownMethodTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	| condition |
	condition := selectors
		             inject: self emptyCondition
		             into: [ :cond :each | 
			             cond & (RBCondition definesSelector: each in: class)
			             &
			             (RBCondition subclassesOf: class referToSelector: each)
				             not ].
	^ condition & (RBCondition isAbstractClass: class)! !

!RBPushDownMethodTransformation methodsFor: 'accessing' stamp: ''!
allClasses

	^ classes ifNil: [ class subclasses ]! !

!RBPushDownMethodTransformation methodsFor: 'transforming' stamp: ''!
pushDownSelectors
	^ selectors flatCollect: [:each | self pushDown: each].! !

!RBPushDownMethodTransformation methodsFor: 'transforming' stamp: ''!
pushDown: aSelector

	| code protocols refactoring |
	code := class sourceCodeFor: aSelector.
	protocols := class protocolsFor: aSelector.
	refactoring := RBExpandReferencedPoolsTransformation
		               model: self model
		               forMethod: (class parseTreeFor: aSelector)
		               fromClass: class
		               toClasses: self allClasses.
	^ {refactoring}, (self allClasses select: [ :each | (each directlyDefinesMethod: aSelector) not ] 
		thenCollect: [ :each |
				RBAddMethodTransformation
				model: self model
				sourceCode: code 
				in: each 
				withProtocols: protocols ])! !

!RBPushDownMethodTransformation methodsFor: 'accessing' stamp: ''!
classes: aCollection
	classes := aCollection collect: [ :cls | 
		self model classObjectFor: cls.
	]! !

!RBPushDownMethodTransformation methodsFor: 'accessing' stamp: ''!
targetClass
	^ class! !

!RBPushDownMethodTransformation methodsFor: 'api' stamp: ''!
pushDown: selectorCollection from: aClass in: aCollection
	class := self model classObjectFor: aClass.
	selectors := selectorCollection.
	self classes: aCollection.! !

!RBPushDownMethodTransformation methodsFor: 'api' stamp: ''!
pushDown: selectorCollection from: aClass
	class := self model classObjectFor: aClass.
	selectors := selectorCollection! !

!RBPushDownMethodTransformation methodsFor: 'transforming' stamp: ''!
removeSelectors
	^ RBRemoveMethodTransformation 
		model: self model
		selectors: selectors
		from: class! !

!RBPushDownMethodTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' pushDown: ';
		nextPutAll: selectors asString;
		nextPutAll: ' from: ';
		nextPutAll: class name;
		nextPutAll: ' in: '.
	(classes collect: [ :e | e name ]) storeOn: aStream.
	aStream nextPut: $)! !

!RBPushDownMethodTransformation methodsFor: 'converting' stamp: ''!
asRefactoring

	^ super asRefactoring
		delegatesPreconditions: false;
		yourself! !

!RBPushDownMethodTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	^ self pushDownSelectors , {self removeSelectors}! !

!RBPushDownMethodTransformation class methodsFor: 'api' stamp: ''!
model: aRBNamespace pushDown: selectorCollection from: aClass
	^ self new
		model: aRBNamespace;
		pushDown: selectorCollection from: aClass;
		yourself! !

!RBPushDownMethodTransformation class methodsFor: 'api' stamp: ''!
pushDown: selectorCollection from: aClass in: classes
	^ self new pushDown: selectorCollection from: aClass in: classes! !

!RBPushDownMethodTransformation class methodsFor: 'api' stamp: ''!
pushDown: selectorCollection from: aClass
	^ self new pushDown: selectorCollection from: aClass! !

!RBPushDownMethodTransformation class methodsFor: 'api' stamp: ''!
model: aRBNamespace pushDown: selectorCollection from: aClass in: classes
	^ self new
		model: aRBNamespace;
		pushDown: selectorCollection from: aClass in: classes;
		yourself! !

!RBPushDownVariableTransformation commentStamp: ''!
Removes this variable from the given class, then adds this variable in all the subclasses of this class.

Usage:
transformation := (RBPushDownVariableTransformation 
		instanceVariable: 'foo1'
		class: #RBLintRuleTest)
		transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
overriden from RBAddVariableTransformation and RBRemoveVariableAccessorTransformation!
!RBPushDownVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	"it does not perform when two subclasses
	(and/or their subclasses) access this variable"

	^ isClassVariable
		ifTrue: [ self preconditionsForClassVariable ]
		ifFalse: [ self preconditionsForInstanceVariable ]! !

!RBPushDownVariableTransformation methodsFor: 'private' stamp: ''!
variableDefinitionsInHierarchy

	self flag: #pharoTodo. "why the behavior is different for class and instance variable?"
	^ isClassVariable
		ifTrue: [ self definingClass allSubclasses reject: [ :each |
			(each whichSelectorsReferToClassVariable: variableName) isEmpty
			and: [ (each theMetaClass whichSelectorsReferToClassVariable: variableName) isEmpty ] ] ]
		ifFalse: [ self definingClass subclasses ] ! !

!RBPushDownVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditionsForInstanceVariable

	^ (RBCondition definesInstanceVariable: variableName in: self definingClass) 
		& (RBCondition accessesInstanceVariable: variableName in: self definingClass showIn: self)! !

!RBPushDownVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditionsForClassVariable
	"it does not perform when two subclasses (and/or their subclasses) accesses this variable"

	^ (RBCondition definesClassVariable: variableName in: self definingClass)
		& (RBCondition withBlock: [
			| numSubclassesAccessing |
			numSubclassesAccessing := self definingClass subclasses count: [ :subclass |
				subclass withAllSubclasses anySatisfy: [ :e |
					(e whichSelectorsReferToClassVariable: variableName) isNotEmpty
					or: [ (e theMetaClass whichSelectorsReferToClassVariable: variableName) isNotEmpty ] ] ].
			numSubclassesAccessing < 2 ])! !

!RBPushDownVariableTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName class: aClassName classVariable: aBoolean

	variableName := aVariableName.
	isClassVariable := aBoolean.
	className := aClassName.! !

!RBPushDownVariableTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' variable: '.
	variableName storeOn: aStream.
	aStream nextPutAll: ' class: '.
	className storeOn: aStream.
	aStream nextPutAll: ' classVariable: '.
	isClassVariable storeOn: aStream.
	aStream nextPut: $)! !

!RBPushDownVariableTransformation methodsFor: 'converting' stamp: ''!
asRefactoring

	^ super asRefactoring
		delegatesPreconditions: false;
		yourself! !

!RBPushDownVariableTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	^ OrderedCollection new
		add: (RBRemoveVariableTransformation
				model: self model
				variable: variableName
				class: className
				classVariable: isClassVariable);
		addAll: (self variableDefinitionsInHierarchy
			collect: [ :each | 
				RBAddVariableTransformation
				model: self model
				variable: variableName
				class: each
				classVariable: isClassVariable ]);
		yourself! !

!RBReadBeforeWrittenTester commentStamp: ''!
RBReadBeforeWrittenTester is a visitor that identifies variables that may have been read before they are initialized.

Instance Variables:
	checkNewTemps	<Boolean>	description of checkNewTemps
	read	<Collection>	description of read
	scopeStack	<OrderedCollection>	description of scopeStack

!
!RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''!
processIfTrueIfFalse: aNode

	| trueScope falseScope |

	self createScope.
	self executeTree: aNode arguments first body.
	trueScope := self removeScope.
	self createScope.
	self executeTree: aNode arguments last body.
	falseScope := self removeScope.
	self currentScope
		keysAndValuesDo: [ :key :value | 
			value
				ifNil: [ ( 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: 'initialization' stamp: ''!
initialize
	super initialize.
	scopeStack := OrderedCollection with: Dictionary new.
	read := Set new.
	checkNewTemps := true! !

!RBReadBeforeWrittenTester methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode 
	self processBlock: aBlockNode! !

!RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''!
createScope
	scopeStack add: (self copyDictionary: scopeStack last)! !

!RBReadBeforeWrittenTester methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode 
	self processStatementNode: aSequenceNode! !

!RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''!
variableWritten: aNode

	( self currentScope includesKey: aNode variable name )
		ifTrue: [ ( self currentScope at: aNode variable name )
				ifNil: [ self currentScope at: aNode variable name put: false ]
			]! !

!RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''!
currentScope
	^scopeStack last! !

!RBReadBeforeWrittenTester methodsFor: 'initialization' stamp: ''!
initializeVars: varNames 
	varNames do: [:each | self currentScope at: each put: nil]! !

!RBReadBeforeWrittenTester methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: anAssignmentNode 
	self visitNode: anAssignmentNode value.
	self variableWritten: anAssignmentNode! !

!RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''!
processBlock: aNode 
	| newScope |
	self createScope.
	self executeTree: aNode body.
	newScope := self removeScope.
	newScope keysAndValuesDo: 
			[:key :value | 
			(value == true and: [(self currentScope at: key) isNil]) 
				ifTrue: [self currentScope at: key put: value]]! !

!RBReadBeforeWrittenTester methodsFor: 'accessing' stamp: ''!
executeTree: aParseTree 
	^self visitNode: aParseTree! !

!RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''!
removeScope
	^scopeStack removeLast! !

!RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''!
variableRead: aNode

	( self currentScope includesKey: aNode name )
		ifTrue: [ ( self currentScope at: aNode name ) ifNil: [ self currentScope at: aNode name put: true ] ]! !

!RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''!
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: 'initialization' stamp: ''!
checkNewTemps: aBoolean 
	checkNewTemps := aBoolean! !

!RBReadBeforeWrittenTester methodsFor: 'visiting' stamp: ''!
visitMessageNode: aMessageNode 
	((#(#whileTrue: #whileFalse: #whileTrue #whileFalse #whileNil:) 
		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: 'accessing' stamp: ''!
read
	self currentScope
		keysAndValuesDo: [:key :value | value == true ifTrue: [read add: key]].
	^read! !

!RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''!
processStatementNode: aNode

	| temps |

	( checkNewTemps not or: [ aNode temporaries isEmpty ] )
		ifTrue: [ aNode statements do: [ :each | self executeTree: each ].
			^ self
			].
	self createScope.
	temps := aNode temporaries collect: [ :each | each name ].
	self initializeVars: temps.
	aNode statements do: [ :each | self executeTree: each ].
	self removeScope
		keysAndValuesDo: [ :key :value | 
			( temps includes: key )
				ifTrue: [ value == true
						ifTrue: [ read add: key ]
					]
				ifFalse: [ ( self currentScope at: key ) ifNil: [ self currentScope at: key put: value ] ]
			]! !

!RBReadBeforeWrittenTester methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode 
	self variableRead: aVariableNode! !

!RBReadBeforeWrittenTester class methodsFor: 'accessing' stamp: ''!
variablesReadBeforeWrittenIn: aParseTree 
	^(self new)
		executeTree: aParseTree;
		read! !

!RBReadBeforeWrittenTester class methodsFor: 'accessing' stamp: ''!
isVariable: aString readBeforeWrittenIn: aBRProgramNode 
	^(self isVariable: aString writtenBeforeReadIn: aBRProgramNode) not! !

!RBReadBeforeWrittenTester class methodsFor: 'accessing' stamp: ''!
isVariable: aString writtenBeforeReadIn: aBRProgramNode 
	^(self readBeforeWritten: (Array with: aString) in: aBRProgramNode) 
		isEmpty! !

!RBReadBeforeWrittenTester class methodsFor: 'accessing' stamp: ''!
readBeforeWritten: varNames in: aParseTree 
	^(self new)
		checkNewTemps: false;
		initializeVars: varNames;
		executeTree: aParseTree;
		read! !

!RBReadBeforeWrittenTesterTest commentStamp: ''!
SUnit tests for RBReadBeforeWrittenTester!
!RBReadBeforeWrittenTesterTest methodsFor: 'tests' stamp: ''!
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: (self parseExpression: each first)) includes: 'a') identicalTo: each last.
			self assert: (RBReadBeforeWrittenTester isVariable: 'a' readBeforeWrittenIn: (self parseExpression: each first)) equals: 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: (self parseExpression: each).
			self assert: (read size = 1 and: [ read includes: 'read' ]) ]! !

!RBReadBeforeWrittenTesterTest methodsFor: 'tests' stamp: ''!
testReadBeforeWritten1
	self
		assertEmpty:
			(RBReadBeforeWrittenTester
				variablesReadBeforeWrittenIn:
					(self
						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'))! !

!RBRealizeClassParametrizedTest methodsFor: 'builder' stamp: ''!
createAbstractClass 
	(model classNamed: #RBFooLintRuleTestData) 
		compile: 'bar ^ self subclassResponsibility'
		classified: #(#accessing).
	(model classNamed: #RBFooLintRuleTestData) classSide
		compile: 'foo ^ self subclassResponsibility'
		classified: #(#accessing).
	
	! !

!RBRealizeClassParametrizedTest methodsFor: 'tests' stamp: ''!
testClassWithoutChanges
	self proceedThroughWarning: [ 
		self executeRefactoring: 
			(self createRefactoringWithArguments: { model . #RBLintRuleTestData}) ].
	self assert: model changes changes isEmpty! !

!RBRealizeClassParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #model:className:! !

!RBRealizeClassParametrizedTest methodsFor: 'tests' stamp: ''!
testRealizeWithAbstractSubclass
	| class |
	class := model classNamed: #RBTransformationRuleTestData.
	class compile: 'foo: arg1 bar: arg2 self subclassResponsibility' classified: 'accessing'.
	self proceedThroughWarning: [ 
		self executeRefactoring: 
			(self createRefactoringWithArguments: { model . #RBFooLintRuleTestData }) ].
	class := model classNamed: #RBFooLintRuleTestData.
	self assert: (class parseTreeFor: #isEmpty) equals: 
	(self parseMethod: 'isEmpty
		self shouldBeImplemented').
	self assert: (class parseTreeFor: #problemCount) equals: 
	(self parseMethod: 'problemCount
		self shouldBeImplemented').
	self assert: (class parseTreeFor: #viewResults) equals: 
	(self parseMethod: 'viewResults
		self shouldBeImplemented') ! !

!RBRealizeClassParametrizedTest methodsFor: 'tests' stamp: ''!
testRealizeClass
	| class |
	class := model classNamed: #RBFooLintRuleTestData.
	self executeRefactoring: 
		(self createRefactoringWithArguments:  { model . #RBFooLintRuleTestData }).
	self assert: (class parseTreeFor: #isEmpty) equals: 
	(self parseMethod: 'isEmpty
		self shouldBeImplemented').
	self assert: (class parseTreeFor: #problemCount) equals: 
	(self parseMethod: 'problemCount
		self shouldBeImplemented').
	self assert: (class parseTreeFor: #viewResults) equals: 
	(self parseMethod: 'viewResults
		self shouldBeImplemented') ! !

!RBRealizeClassParametrizedTest methodsFor: 'tests' stamp: ''!
testRealizeAbstractClass
	| class |
	class := model classNamed: #RBFooLintRuleTestData.
	self createAbstractClass.
	self proceedThroughWarning: [ 
		self executeRefactoring: 
			(self createRefactoringWithArguments:  { model . #RBFooLintRuleTestData}) ].
	self assert: (class parseTreeFor: #isEmpty) equals: 
	(self parseMethod: 'isEmpty
		self shouldBeImplemented').
	self assert: (class parseTreeFor: #problemCount) equals: 
	(self parseMethod: 'problemCount
		self shouldBeImplemented').
	self assert: (class parseTreeFor: #viewResults) equals: 
	(self parseMethod: 'viewResults
		self shouldBeImplemented') ! !

!RBRealizeClassParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRealizeClassRefactoring };
		addCase: { #rbClass -> RBRealizeClassTransformation };
		yourself! !

!RBRealizeClassRefactoring commentStamp: ''!
Complete the set of defined methods of this class, by generating a "self shouldBeImplemented" method for all abstract methods defined in its superclass hierarchy. Where an abstract method is a method sending "self subclassResponsibilty.
Shows a warning if this class has abstract methods on its own.!
!RBRealizeClassRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self transform: self theClass.
	self transform: self theClass classSide! !

!RBRealizeClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^ RBCondition
		withBlock: [ 
			(self theClass withAllSubclasses
				detect: [ :each | 
					(each whichSelectorsReferToSymbol: #subclassResponsibility) notEmpty 
						or: [ (each classSide whichSelectorsReferToSymbol: #subclassResponsibility) notEmpty ] ]
				ifNone: [ nil ]) ifNotNil: 
				[ self refactoringWarning: 
				self theClass printString ,
					' is abstract or has abstract subclasses. Do you want to proceed?']. true ]! !

!RBRealizeClassRefactoring methodsFor: 'accessing' stamp: ''!
theClass
	^ (self classObjectFor: className) instanceSide! !

!RBRealizeClassRefactoring methodsFor: 'transforming' stamp: ''!
transform: aClass
	| class method parseTree |
	aClass allSelectors do: [ :selector | 
		class := aClass whoDefinesMethod: selector.
		(class notNil and: [ class ~= aClass ]) ifTrue: [ 
			method := class methodFor: selector.
			(method notNil and: [ method refersToSymbol: #subclassResponsibility ]) ifTrue: [ 
				parseTree := method parseTree.
				parseTree body
					temporaries: OrderedCollection new;
					statements: OrderedCollection new;
					addNode: (RBMessageNode receiver: RBVariableNode selfNode selector: #shouldBeImplemented).
				aClass compile: parseTree newSource withAttributesFrom: method ] ] ]! !

!RBRealizeClassRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' className: '.
	className storeOn: aStream.
	aStream nextPut: $)! !

!RBRealizeClassTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^ RBCondition
		withBlock: [ 
			(self theClass withAllSubclasses
				detect: [ :each | 
					(each whichSelectorsReferToSymbol: #subclassResponsibility) notEmpty 
						or: [ (each classSide whichSelectorsReferToSymbol: #subclassResponsibility) notEmpty ] ]
				ifNone: [ nil ]) ifNotNil: 
				[ self refactoringWarning: 
				self theClass printString ,
					' is abstract or has abstract subclasses. Do you want to proceed?']. true ]! !

!RBRealizeClassTransformation methodsFor: 'accessing' stamp: ''!
theClass
	^ (self model classObjectFor: className) instanceSide! !

!RBRealizeClassTransformation methodsFor: 'accessing' stamp: ''!
transform: targetClass
	| aClass method parseTree  |
	targetClass allSelectors do: [ :selector | 
		aClass := targetClass whoDefinesMethod: selector.
		(aClass notNil and: [ aClass ~= targetClass ]) ifTrue: [ 
			method := aClass methodFor: selector.
			(method notNil and: [ method refersToSymbol: #subclassResponsibility ]) ifTrue: [
				parseTree := method parseTree.
				parseTree body
					temporaries: OrderedCollection new;
					statements: OrderedCollection new;
					addNode: (RBMessageNode receiver: RBVariableNode selfNode selector: #shouldBeImplemented).
				targetClass compile: parseTree newSource withAttributesFrom: method ] ] ]! !

!RBRealizeClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' className: '.
	className storeOn: aStream.
	aStream nextPut: $)! !

!RBRealizeClassTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	self transform: self theClass.
	self transform: self theClass classSide.
! !

!RBRealizeClassTransformation class methodsFor: 'api' stamp: ''!
className: aName
	^ self new className: aName! !

!RBRealizeClassTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel className: aName 
	^ self new
		model: aRBModel;
		className: aName;
		yourself! !

!RBRefactoring commentStamp: ''!
I am the abstract base class for refactoring operations. 

I define the common workflow for a refactoring:
check precondition, 
primitive execute - a dry run collecting the changes without applying them,
and execute - run and apply changes.

I provide many utility methods used by my subclasses. 
Every  concrete subclass implements a single refactoring. They have to implement the methods
preconditions and transform.


Instance Variables

options:
Some refactorings may need user interactions or some extra data for performing
the operation, the code for requesting this data is stored in a block associated with a "refacotring option"
(see RBRefactoring>>#setOption:toUse:  and RBRefactoring class>>#initializeRefactoringOptions).

model:
My model - a RBNamespace - defines the environment in which my refactoring is applied and collects all changes (RBRefactoryChange).

A RBRefactoringManager  is used to collect the executed refactorings and provides an undo and redo facility.
!
!RBRefactoring methodsFor: 'support' stamp: ''!
convertAllReferencesTo: aSymbol of: classes using: searchReplacer 
	(self model allReferencesTo: aSymbol in: classes)
		do: 
			[:method | 
			self 
				convertMethod: method selector
				for: method modelClass
				using: searchReplacer]! !

!RBRefactoring methodsFor: 'support' stamp: ''!
checkClass: aRBClass selector: aSelector using: aMatcher 
	| parseTree |
	parseTree := aRBClass parseTreeFor: aSelector.
	parseTree ifNotNil: [aMatcher executeTree: parseTree].
	^aMatcher answer! !

!RBRefactoring methodsFor: 'utilities' stamp: ''!
associationForClassVariable: aName in: aClass ifAbsent: aBlock
	"Return the class variable association of class aClass"
	 
	^aClass realClass classPool associationAt: aName asSymbol
		ifAbsent: [aClass realClass classPool associationAt: aName asString ifAbsent: aBlock]! !

!RBRefactoring methodsFor: 'accessing' stamp: ''!
copyOptionsFrom: aDictionary 
	| dict |
	dict := self options.
	dict == self class refactoringOptions 
		ifTrue: [^self options: aDictionary copy].
	dict keysAndValuesDo: 
			[:key :value | 
			value == (self class refactoringOptions at: key ifAbsent: [nil]) 
				ifTrue: [ dict at: key put: (aDictionary at: key) ]].
	(aDictionary keys difference: dict keys) do: 
		[ :e | dict at: e put: (aDictionary at: e) ].
	self options: dict! !

!RBRefactoring methodsFor: 'transforming' stamp: ''!
execute
	self primitiveExecute.
	RBRefactoryChangeManager instance 
		performChange: self changes; 
		addUndoPointer: (RBRefactoryChangeManager nextCounter)! !

!RBRefactoring methodsFor: 'exceptions' stamp: ''!
refactoringFailure: aString with: aBlock
	^ RBRefactoringFailure signal: aString with: aBlock! !

!RBRefactoring methodsFor: 'private' stamp: ''!
classObjectFor: anObject

	(anObject isBehavior or: [ anObject isTrait ]) ifTrue: [ 
		^ self model classFor: anObject ].
	anObject isString ifTrue: [ 
		^ self model classNamed: anObject asSymbol ].
	^ anObject! !

!RBRefactoring methodsFor: 'parsing' stamp: ''!
parseTreeSearcherClass
	^ RBParseTreeSearcher! !

!RBRefactoring methodsFor: 'utilities' stamp: ''!
safeMethodNameFor: aClass basedOn: aString 
	"Creates an unused method name containing aString"

	| baseString newString hasParam i |
	baseString := aString copy.
	baseString at: 1 put: baseString first asLowercase.
	newString := baseString.
	hasParam := newString last = $:.
	hasParam 
		ifTrue: [baseString := newString copyFrom: 1 to: newString size - 1].
	i := 0.
	[aClass hierarchyDefinesMethod: newString asSymbol] whileTrue: 
			[i := i + 1.
			newString := baseString , i printString 
						, (hasParam ifTrue: [':'] ifFalse: [''])].
	^newString asSymbol! !

!RBRefactoring methodsFor: 'requests' stamp: ''!
requestMethodNameFor: aMethodName 
	^(self options at: #methodName) cull: aMethodName cull: self! !

!RBRefactoring methodsFor: 'support' stamp: ''!
convertAllReferencesToClass: aRBClass using: searchReplacer 
	self model allReferencesToClass: aRBClass
		do: 
			[:method | 
			self 
				convertMethod: method selector
				for: method modelClass
				using: searchReplacer]! !

!RBRefactoring methodsFor: 'parsing' stamp: ''!
parserClass
	^ RBParser! !

!RBRefactoring methodsFor: 'exceptions' stamp: ''!
refactoringConfirmWarning: aString
	| ret |
	ret := self uiManager 
		confirm: aString 
		orCancel: [ ^ RBRefactoringFailure signal: 'aborted' ].
	^ ret! !

!RBRefactoring methodsFor: 'requests' stamp: ''!
shouldExtractAssignmentTo: aString 
	^(self options at: #extractAssignment) value: self value: aString! !

!RBRefactoring methodsFor: 'parsing' stamp: ''!
parseTreeSearcher
	^ self parseTreeSearcherClass new! !

!RBRefactoring methodsFor: 'defining conditions' stamp: ''!
checkMethodName: aName in: aClass 
	^RBCondition checkMethodName: aName in: aClass! !

!RBRefactoring methodsFor: 'exceptions' stamp: ''!
refactoringError: aString
	^ RBRefactoringError signal: aString! !

!RBRefactoring methodsFor: 'transforming' stamp: ''!
model

	^ model
		ifNil: [ model := ( RBClassModelFactory rbNamespace onEnvironment: self defaultEnvironment )
				name: self printString;
				yourself
			]
		ifNotNil: [ model ]! !

!RBRefactoring methodsFor: 'testing' stamp: ''!
canReferenceVariable: aString in: aClass 
	(aClass definesVariable: aString) ifTrue: [^true].
	(self model includesGlobal: aString asSymbol) ifTrue: [^true].
	^(self poolVariableNamesFor: aClass) includes: aString! !

!RBRefactoring methodsFor: 'parsing' stamp: ''!
parseTreeRewriterClass
	^ RBParseTreeRewriter! !

!RBRefactoring methodsFor: 'accessing' stamp: ''!
options: aDictionary 
	options := aDictionary! !

!RBRefactoring methodsFor: 'requests' stamp: ''!
shouldUseExistingMethod: aSelector 
	^(self options at: #useExistingMethod) value: self value: aSelector! !

!RBRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	self subclassResponsibility! !

!RBRefactoring methodsFor: 'defining conditions' stamp: ''!
checkInstanceVariableName: aName in: aClass 
	^RBCondition checkInstanceVariableName: aName in: aClass! !

!RBRefactoring methodsFor: 'exceptions' stamp: ''!
refactoringWarning: aString
	^ RBRefactoringWarning signal: aString! !

!RBRefactoring methodsFor: 'private' stamp: ''!
onError: aBlock do: errorBlock 
	^aBlock on: self class preconditionSignal
		do: 
			[:ex | 
			errorBlock value.
			ex return: nil]! !

!RBRefactoring methodsFor: 'private' stamp: ''!
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: 'exceptions' stamp: ''!
refactoringError: aString with: aBlock
	^ RBRefactoringError signal: aString with: aBlock! !

!RBRefactoring methodsFor: 'transforming' stamp: ''!
defaultEnvironment
	^RBBrowserEnvironment new! !

!RBRefactoring methodsFor: 'requests' stamp: ''!
shouldOverride: aSelector in: aClass 
	^(self options at: #alreadyDefined) 
		value: self
		value: aClass
		value: aSelector! !

!RBRefactoring methodsFor: 'utilities' stamp: ''!
whichVariableNode: aParseTree inInterval: anInterval name: aName
	| matcher block |
	matcher := self parseTreeSearcher.
	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: 'transforming' stamp: ''!
poolVariableNamesIn: poolName 
	^(model classNamed: poolName) classPool keys! !

!RBRefactoring methodsFor: 'support' stamp: ''!
convertClasses: classSet select: aBlock using: searchReplacer 
	classSet do: 
			[:aClass | 
			(aBlock value: aClass) do: 
					[:selector | 
					self 
						convertMethod: selector
						for: aClass
						using: searchReplacer]]! !

!RBRefactoring methodsFor: 'requests' stamp: ''!
shouldInlineExpression: aString 
	^(self options at: #inlineExpression) value: self value: aString! !

!RBRefactoring methodsFor: '*NautilusRefactoring' stamp: ''!
whatToDisplayIn: aBrowser 

	^ (self changes changes collect: [:change | change onSystemDictionary: self model environment systemDictionary]) flatCollect: [:e | e whatToDisplayIn: aBrowser ]! !

!RBRefactoring methodsFor: 'accessing' stamp: ''!
changes
	^self model changes! !

!RBRefactoring methodsFor: 'transforming' stamp: ''!
performCompositeRefactoringThroughWarning: aRefactoring 
	[ aRefactoring copyOptionsFrom: self options.
	aRefactoring primitiveExecute ]
	on: RBRefactoringError do: [ :ex | ex resume ]

	! !

!RBRefactoring methodsFor: 'exceptions' stamp: ''!
refactoringFailure: aString
	^ RBRefactoringFailure signal: aString! !

!RBRefactoring methodsFor: 'requests' stamp: ''!
openBrowserOn: anEnvironment 
	^(self options at: #openBrowser) value: self value: anEnvironment! !

!RBRefactoring methodsFor: 'requests' stamp: ''!
selectVariableToMoveMethodTo: aSelector class: aClass 
	^(self options at: #selectVariableToMoveTo) 
		value: self
		value: aClass
		value: aSelector! !

!RBRefactoring methodsFor: 'private' stamp: ''!
uniqueMethodNameFor: anInteger 
	| before after index name |
	before := 'a'.
	after := ''.
	anInteger timesRepeat: [after := after , 'z:'].
	index := 0.
	
	[name := before , index printString , after.
	(Symbol findInterned: name) notNil] 
			whileTrue: [index := index + 1].
	^name asSymbol! !

!RBRefactoring methodsFor: '*Epicea-Refactorings' stamp: ''!
propagateTransformation
	"Perform the *secondary transformation* of the refactoring. Refactorings perform a main 
	transformations and optionally a secondary transformations. 
	For example, in a class rename, the main transformations may be removing the class and adding 
	it with another name. A secondary transformation in this case is fixing the references in 
	methods to the class."
	
	"The default is to do nothing"! !

!RBRefactoring methodsFor: 'converting' stamp: ''!
asRefactoring
	^ self! !

!RBRefactoring methodsFor: 'requests' stamp: ''!
selectVariableTypesFrom: initialTypeCollection selected: selectedTypeCollection 
	^ (self options at: #variableTypes) 
		value: self
		value: initialTypeCollection
		value: selectedTypeCollection
! !

!RBRefactoring methodsFor: 'private' stamp: ''!
primitiveExecute
	self checkPreconditions.
	self transform! !

!RBRefactoring methodsFor: 'accessing' stamp: ''!
setOption: aSymbol toUse: aBlock 
	| dict |
	dict := self options.
	dict == self class refactoringOptions ifTrue: [dict := dict copy].
	dict at: aSymbol put: aBlock.
	self options: dict! !

!RBRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self subclassResponsibility! !

!RBRefactoring methodsFor: 'parsing' stamp: ''!
parseTreeRewriter
	^ self parseTreeRewriterClass new! !

!RBRefactoring methodsFor: 'defining conditions' stamp: ''!
emptyCondition
	^ RBCondition empty! !

!RBRefactoring methodsFor: '*Epicea-Refactorings' stamp: ''!
asEpiceaEvent
	^ (EpGenericRefactoring canAccept: self)
		ifTrue: [ EpGenericRefactoring for: self ]
		ifFalse: [ EpUnknownRefactoring for: self ]! !

!RBRefactoring methodsFor: 'preconditions' stamp: ''!
checkPreconditions
	| conditions block |
	conditions := self preconditions.
	conditions check
		ifFalse: [ block := conditions errorBlock.
			block
				ifNotNil: [ self refactoringError: conditions errorString with: block ]
				ifNil: [ self refactoringError: conditions errorString ] ]! !

!RBRefactoring methodsFor: 'support' stamp: ''!
convertAllReferencesTo: aSymbol using: searchReplacer 
	|aBlock|
	aBlock := [:method | 
			self 
				convertMethod: method selector
				for: method modelClass
				using: searchReplacer].
	self model allReferencesTo: aSymbol do: aBlock! !

!RBRefactoring methodsFor: 'support' stamp: ''!
convertMethod: selector for: aClass using: searchReplacer

	"Convert the parse tree for selector using the searchReplacer. If a
	change is made then compile it into the changeBuilder."

	| parseTree |

	parseTree := aClass parseTreeFor: selector.
	parseTree ifNil: [ ^ self ].
	( searchReplacer executeTree: parseTree )
		ifTrue: [ aClass compileTree: searchReplacer tree ]! !

!RBRefactoring methodsFor: 'removing' stamp: ''!
removeReturnsOf: parseTree
	| rewriter |
	rewriter := self parseTreeRewriter.
	rewriter replace: '^``@object' with: '``@object'.
	(rewriter executeTree: parseTree) 
		ifTrue: [ ^ rewriter tree].
	^ parseTree! !

!RBRefactoring methodsFor: 'requests' stamp: ''!
requestImplementorToInline: implementorsCollection 
	^(self options at: #implementorToInline) value: self
		value: implementorsCollection! !

!RBRefactoring methodsFor: 'transforming' stamp: ''!
performCompositeRefactoring: aRefactoring 
	aRefactoring copyOptionsFrom: self options.
	aRefactoring primitiveExecute! !

!RBRefactoring methodsFor: 'initialization' stamp: ''!
model: aRBNamespace 
	model := aRBNamespace! !

!RBRefactoring methodsFor: 'requests' stamp: ''!
requestSelfArgumentName
	^(self options at: #selfArgumentName) value: self! !

!RBRefactoring methodsFor: 'utilities' stamp: ''!
poolVariableNamesFor: aClass 
	| pools |
	pools := Set new.
	aClass withAllSuperclasses do: 
			[:each | 
			each allPoolDictionaryNames do: 
					[:pool |
					pools addAll: (self poolVariableNamesIn: pool asSymbol) ] ].
	^pools! !

!RBRefactoring methodsFor: 'accessing' stamp: ''!
options

	^ options ifNil: [ self class refactoringOptions ] ifNotNil: [ options ]! !

!RBRefactoring class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RBRefactoring class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RBRefactoring class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RBRefactoring class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RBRefactoring class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RBRefactoring class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RBRefactoring class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RBRefactoring class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RBRefactoring class methodsFor: 'class initialization' stamp: ''!
initialize
	self initializeRefactoringOptions! !

!RBRefactoring class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBRefactoring class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RBRefactoring class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RBRefactoring class methodsFor: 'private - initialization' stamp: ''!
initializeRefactoringOptions
	RefactoringOptions := IdentityDictionary new.
	RefactoringOptions
		at: #implementorToInline
		put: [ :ref :imps | self error: #implementorToInline ];
		
		at: #methodName
		put: [ :methodName :ref | 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 ];
		
		at: #searchInWholeHierarchy
		put: [ self error: #searchInWholeHierarchy ]! !

!RBRefactoring class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RBRefactoring class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RBRefactoring class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBRefactoring! !

!RBRefactoring class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RBRefactoring class methodsFor: 'accessing signal' stamp: ''!
preconditionSignal
	^ RBRefactoringError , RBRefactoringWarning! !

!RBRefactoring class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RBRefactoring class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RBRefactoring class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RBRefactoring class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBRefactoring class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RBRefactoring class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RBRefactoring class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RBRefactoring class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RBRefactoring class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RBRefactoring class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RBRefactoring class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RBRefactoring class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RBRefactoring class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RBRefactoring class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RBRefactoring class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RBRefactoring class methodsFor: 'accessing' stamp: ''!
setDefaultOption: aSymbol to: aBlock 
	self refactoringOptions at: aSymbol put: aBlock! !

!RBRefactoring class methodsFor: 'accessing' stamp: ''!
refactoringOptions
	^ RefactoringOptions! !

!RBRefactoring class methodsFor: 'cleaning' stamp: ''!
cleanUp
	"RefactoringOptions holds on to blocks, we should make sure to recreate them so the block references the current method"
	self initializeRefactoringOptions.! !

!RBRefactoringBrowserTest methodsFor: 'private' stamp: ''!
objectClassVariable
	^Object classPool keys detect: [:each | true]! !

!RBRefactoringBrowserTest methodsFor: 'private' stamp: ''!
proceedThroughWarning: aBlock 
	aBlock on: RBRefactoringWarning do: [ :ex | ex resume ]! !

!RBRefactoringBrowserTest methodsFor: 'private' stamp: ''!
parserClass
	^ RBParser! !

!RBRefactoringBrowserTest methodsFor: 'private' stamp: ''!
executeRefactoring: aRefactoring
	aRefactoring primitiveExecute.
	self parserClass parseExpression: aRefactoring storeString! !

!RBRefactoringBrowserTest methodsFor: 'helpers' stamp: ''!
parseExpression: aString
	^ self parserClass parseExpression: aString! !

!RBRefactoringBrowserTest methodsFor: 'helpers' stamp: ''!
parseMethod: aString
	^ self parserClass parseMethod: aString! !

!RBRefactoringBrowserTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #RBRefactoringBrowserTest! !

!RBRefactoringChangeManagerTest methodsFor: 'tests' stamp: ''!
testChangeFactoryIsCorrectlyInitialized 

	RBRefactoryChangeManager nuke.
	self assert: RBRefactoryChangeManager changeFactory isNotNil! !

!RBRefactoringChangeTest methodsFor: 'mocking' stamp: ''!
text
	"for #testPerformAddRemoveMethodInteractively"
	^'method ^1'! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
testPerformAddRemoveClassInteractively
	| change |
	change := changeFactory addClassDefinition: 'Object subclass: #' , self changeMock name , 'Temporary
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	package: ''' , self class category , '''' for: self.
	self perform: change do: [ 
		self assert: (workingEnvironment hasClassNamed: change changeClassName).
		self assert: change definedClass name equals: change changeClassName.
		self assert: change definedClass isBehavior ].
	self deny: (workingEnvironment hasClassNamed: change changeClassName).
	self assert: change definedClass isObsolete
	! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testCompileInClassified
	| change |
	change := changes compile: 'setUp' in: self class classified: #accessing.
	self assert: change controller isNil.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change selector equals: #setUp.
	self assert: change source equals: 'setUp'.
	self assert: change protocol equals: #accessing.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'accessing' stamp: ''!
exampleTraits
    <sampleInstance>
	^ { TSortable. TAssertable }! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRenameClass
	| change |
	change := changes renameClass: self class to: self class name , 'Plus'.
	self assert: change oldName equals: self class name.
	self assert: change newName equals: (self class name , 'Plus').
	self assert: change changeClass equals: self class.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
testPerformAddRemoveMethodInteractively
	| change |
	change := changeFactory addMethodSource: '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 equals: #method! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testCompileInClass
	| change |
	change := changes compile: 'setUp' in: self class.
	self assert: change controller isNil.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change selector equals: #setUp.
	self assert: change source equals: 'setUp'.
	self assert: change protocol equals: #running.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'utilities' stamp: ''!
equalityTestFor: aChange
	self assert: aChange equals: aChange.
	self assert: aChange hash equals: aChange hash.

	self assert: aChange copy equals: aChange.
	self assert: aChange copy hash equals: aChange hash! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRemoveClass
	| change |
	change := changes removeClass: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests - pattern' stamp: ''!
testAddClassTraitPattern
	"Make sure that all class trait definitions can be parsed."
	
	self exampleTraits do: [ :trait |
		| change |
		change := changes defineClass: (ClassDefinitionPrinter oldPharo for: trait classTrait) definitionString.
		self assert: (change isKindOf: RBAddClassTraitChange).
		self assert: change changeClassName equals: trait name.
		self universalTestFor: change ]! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRemoveClassInstanceVariable
	| change |
	change := changes removeInstanceVariable: 'instVar' from: self class class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class class.
	self assert: change isMeta.
	self assert: change variable equals: 'instVar'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'accessing' stamp: ''!
exampleClasses
	<sampleInstance>
	^ { "Standard Classes" 
		ProtoObject. Object. Class. Metaclass. Behavior. ClassDescription. Dictionary. Trait.
		
		"Lots of class vars"
		SmalltalkImage
	}! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testAddClassVariable
	| change |
	change := changes addClassVariable: 'ClassVar' to: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change variable equals: 'ClassVar'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testAddInstanceVariable
	| change |
	change := changes addInstanceVariable: 'instVar' to: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change variable equals: 'instVar'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'running' stamp: ''!
tearDown
	self removeMockClass.
	super tearDown.! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testComposite
	changes 
		compile: 'method ^ 1' in: self class classified: #utilities;
		compile: 'method ^ 2' in: self class class classified: #utilities.
	self assert: changes changesSize equals: 2.
	self assert: changes problemCount equals: 2.
	self assert: (changes changeForClass: self class name selector: #method) notNil.
	self assert: (changes changeForMetaclass: self class name selector: #method) notNil.
	self universalTestFor: changes! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
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) ! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRemoveMethod
	| change |
	change := changes removeMethod: #setUp from: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change selector equals: #setUp.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'utilities' stamp: ''!
undoTestFor: aChange
	| undo |
	undo := aChange asUndoOperation.
	self assert: (undo isKindOf: RBRefactoryChange)! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
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')! !

!RBRefactoringChangeTest methodsFor: 'tests - pattern' stamp: ''!
testAddMetaclassPattern
	"Make sure that metaclass definitions can be parsed."
	
	self exampleClasses do: [ :class |
		(class isObsolete or: [ class superclass notNil and: [ class superclass isObsolete ] ]) ifFalse: [  
 		| change |
		change := changes defineClass: class class definitionString.
		self assert: (change isKindOf: RBAddMetaclassChange).
		self assert: change changeClassName equals: class name.
		self assert: change classInstanceVariableNames equals: class class instVarNames.
		self universalTestFor: change ]]! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testAddPool
	| change |
	change := changes addPool: 'PoolDict' to: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change variable equals: 'PoolDict'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'utilities' stamp: ''!
universalTestFor: aChange
	self equalityTestFor: aChange.
	self stringTestFor: aChange.
	(aChange isKindOf: RBRefactoryClassChange)
		ifTrue: [ self undoTestFor: aChange ]! !

!RBRefactoringChangeTest methodsFor: 'mocking' stamp: ''!
removeMockClass
	testingEnvironment removeClassNamed: #RBRefactoringChangeMock.! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
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')! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRenameClassVariable
	| change |
	change := changes renameClassVariable: 'ClassVar1' to: 'ClassVar2' in: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change oldName equals: 'ClassVar1'.
	self assert: change newName equals: 'ClassVar2'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
testPerformChangeMetaclass
	| change |
	change := changes
		defineClass:
			self changeMock name
				,
					' class 
	instanceVariableNames: '''''.
	self perform: change do: [ self assertEmpty: change changeClass class instVarNames ].
	self denyEmpty: change changeClass class instVarNames.
	self assert: change definedClass equals: self changeMock class! !

!RBRefactoringChangeTest methodsFor: 'utilities' stamp: ''!
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 ])! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
testPerformAddRemoveMethod
	| change |
	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 equals: #method! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
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)! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
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')! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testAddClassInteractively
	| change |
	change := changeFactory addClassDefinition: 'AbstractEnvironmentTestCase subclass: #' , self class name , '
	instanceVariableNames: ''instVar''
	classVariableNames: ''ClassVar''
	poolDictionaries: ''PoolDict''
	package: ''' , self class category , '''' for: self.
	self assert: change controller equals: self.
	self assert: change superclassName equals: self class superclass name.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change instanceVariableNames size equals: 1.
	self assert: change instanceVariableNames first equals: 'instVar'.
	self assert: change classVariableNames size equals: 1.
	self assert: change classVariableNames first equals: 'ClassVar'.
	self assert: change sharedPoolNames size equals: 1.
	self assert: change sharedPoolNames first equals: 'PoolDict'.
	self assert: change category equals: self class category.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
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 equals: self class.
			self assertEmpty: change changeClass instVarNames ].
	self assert: change changeClass superclass equals: Object.
	self denyEmpty: change changeClass instVarNames.
	self assert: change definedClass equals: self changeMock! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRemoveInstanceVariable
	| change |
	change := changes removeInstanceVariable: 'instVar' from: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change variable equals: 'instVar'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'mocking' stamp: ''!
changeMock
	^ testingEnvironment at: #RBRefactoringChangeMock! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
testPerformAddRemoveClass
	| change |
	change := changes defineClass: 'Object subclass: #' , self changeMock name , 'Temporary
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	package: ''' , self class category , ''''.
	self perform: change do: [
		self assert: (workingEnvironment  hasClassNamed: change changeClassName).
		self assert: change definedClass name equals: change changeClassName.
		self assert: change definedClass isBehavior ].
	self deny: (workingEnvironment hasClassNamed: change changeClassName).
	self assert: change definedClass isObsolete! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testCompileInInteractively
	| change |
	change := changeFactory addMethodSource: 'setUp' in: self class classified: #running for: self.
	self assert: change controller equals: self.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change selector equals: #setUp.
	self assert: change source equals: 'setUp'.
	self assert: change protocol equals: #running.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testAddClassInstanceVariable
	| change |
	change := changes addInstanceVariable: 'instVar' to: self class class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class class.
	self assert: change isMeta.
	self assert: change variable equals: 'instVar'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRenameInstanceVariable
	| change |
	change := changes renameInstanceVariable: 'instVar1' to: 'instVar2' in: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change oldName equals: 'instVar1'.
	self assert: change newName equals: 'instVar2'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'utilities' stamp: ''!
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 ] ]! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testCompileInMetaclass
	| change |
	change := changes compile: 'new' in: self class class.
	self assert: change controller isNil.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class class.
	self assert: change isMeta.
	self assert: change selector equals: #new.
	self assert: change source equals: 'new'.
	self assert: change protocol equals: #accessing.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
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) equals: 'one ^ 2' ].
	self assert: (change changeClass sourceCodeAt: #one) equals: source! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
testPerformRenameClass
	| change |
	change := changes renameClass: self changeMock to: self changeMock name , 'Plus'.
	self perform: change do: [ 
		self deny: (workingEnvironment hasClassNamed: change oldName).
		self assert: (workingEnvironment hasClassNamed: change newName) ].
	self assert: (workingEnvironment hasClassNamed: change oldName).
	self deny: (workingEnvironment hasClassNamed: change newName)! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRemoveClassVariable
	| change |
	change := changes removeClassVariable: 'ClassVar' from: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change variable equals: 'ClassVar'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	workingEnvironment := Smalltalk globals.
	"In the future we should make sure that the tests can run on a new environment."
	self createMockClass.
	changeFactory := RBRefactoryChangeManager changeFactory.
	"changeFactory is used in tests too"
	changes := changeFactory compositeRefactoryChangeNamed: 'testing'! !

!RBRefactoringChangeTest methodsFor: 'tests - pattern' stamp: ''!
testAddTraitPattern
	"Make sure that all trait definitions can be parsed."
	
	self exampleTraits do: [ :trait |
		| change |
		change := changes defineClass: trait definitionString.
		self assert: (change isKindOf: RBAddTraitChange).
		self assert: change changeClassName equals: trait name.
		self assert: change category equals: trait category.
		self universalTestFor: change ]! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRemoveClassNamed
	| change |
	change := changes removeClassNamed: self class name.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests - pattern' stamp: ''!
testAddClassPattern

	"Make sure that all class definitions can be parsed."

	self exampleClasses
		do: [ :class | 
			( class isObsolete or: [ class superclass notNil and: [ class superclass isObsolete ] ] )
				ifFalse: [ | change |

					change := changes defineClass: class oldDefinition.
					self assert: ( change isKindOf: RBAddClassChange ).
					self assert: change changeClassName equals: class name.

					class superclass
						ifNil: [ self assert: change definitionClass equals: ProtoObject ]
						ifNotNil: [ self assert: change definitionClass equals: class superclass ].

					self assert: change instanceVariableNames equals: class instVarNames asArray.
					self assert: change classVariableNames equals: class classVarNames asArray.
					self assert: change sharedPoolNames equals: class sharedPoolNames asArray.
					self assert: change category equals: class category.
					self universalTestFor: change
					]
			]! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
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 equals: 'Some Comment' ].
	self assert: change changeClass organization classComment equals: comment! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
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)! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRenameClassInstanceVariable
	| change |
	change := changes renameInstanceVariable: 'instVar1' to: 'instVar2' in: self class class.
	self assert: change changeClassName equals: self class name.
	self assert: change oldName equals: 'instVar1'.
	self assert: change newName equals: 'instVar2'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
testPerformAddRemoveClassMethod
	| change |
	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 equals: #method! !

!RBRefactoringChangeTest methodsFor: 'mocking' stamp: ''!
createMockClass
	self class compiler 
		evaluate: 'Object subclass: #RBRefactoringChangeMock
	instanceVariableNames: ''instVar''
	classVariableNames: ''ClassVar''
	poolDictionaries: ''''
	category: ''Refactoring-Tests-Changes'''.
	
	self class compiler 
		evaluate:  'RBRefactoringChangeMock class
	instanceVariableNames: ''classInstVar'''.
	
	self changeMock compile: 'one ^ 1' classified: 'accessing'.! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testComment
	| change |
	change := changes comment: 'Some Comment' in: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change comment equals: 'Some Comment'.
	self universalTestFor: change! !

!RBRefactoringChangeTest methodsFor: 'tests - perform' stamp: ''!
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)! !

!RBRefactoringChangeTest methodsFor: 'mocking' stamp: ''!
selectionInterval
	^ 1 to: 0! !

!RBRefactoringChangeTest methodsFor: 'tests' stamp: ''!
testRemovePool
	| change |
	change := changes removePool: 'PoolDict' from: self class.
	self assert: change changeClassName equals: self class name.
	self assert: change changeClass equals: self class.
	self assert: change isMeta not.
	self assert: change variable equals: 'PoolDict'.
	self universalTestFor: change! !

!RBRefactoringChangeTest class methodsFor: 'accessing' stamp: ''!
packageNamesUnderTest
	^ #('Refactoring-Changes')! !

!RBRefactoringClassesHelp commentStamp: ''!
All exising RBRefactorings !
!RBRefactoringClassesHelp class methodsFor: 'building' stamp: ''!
rootHelpClass
	^ RBRefactoring! !

!RBRefactoringCoreHelp commentStamp: ''!
A chapter with a more in-depth description of the core components of the refactoring engine.!
!RBRefactoringCoreHelp class methodsFor: 'pages' stamp: ''!
astContent
	^HelpTopic
		title: 'AST Nodes'
		contents: 
'
The AST representing the code by a tree of nodes. A node may represent 
a single element
- RBVariableNode 
- RBLiteralValueNode 
an expression
- RBAssignmentNode
- RBMessageNode
- RBReturnNode
- RBCascadeNode
a sequence of expressions
- RBSequenceNode
or a block or Method
- RBBlockNode
- RBMethodNode

This nodes are part of a class hierarchy starting with RBProgramNode an abstract class defining the common operations needed for all nodes. Every node knows about its child nodes, the source code location, any comment attached (comment prior to this node in the source code, or for RBMethodNodes the "method comment" line), and the type (by its subclass) - see the is-Methods in "testing"-protocol.

Keep in mind that the syntax tree is created from the source code only and may not distinguish all possible type information without actually analyzing the semantic context. For example, a global variable is represented as RBGlobalNode, but just from parsing an expression, the AST only knows that this is a RBVariableNode. You need to call doSemanticAnalysis on the parse tree to convert variable nodes into the  type they represent in the code.

'! !

!RBRefactoringCoreHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(overview astContent astVisiting overviewParser patternParser patternParserExamples browserEnvironments)! !

!RBRefactoringCoreHelp class methodsFor: 'pages' stamp: ''!
astVisiting
	^HelpTopic
		title: 'AST Vistor'
		contents: 
'
With this hierarchy of classes, the operations and programs working with the AST are often implemented with the visitor pattern.

AST node visitors are subclasses of a ProgramNodeVisitor, or a just any other class implementing the appropriate visitNode: / visitXXX: methods.

Some examples of ProgramNodeVisitors operating on the RBParsers AST:

Opal Compiler
Opals translator visits the AST tree to create a intermediate representation that is finally used to generated method byte code. Another step in the compiler work flow, the ClosureAnalyzer, is implemented as
a ProgramNodeVisitor too.

Reflectivity Compiler
For reflectivity support, can add MetaLinks to the nodes of the compiled method and generate new methods with code injections augmenting or modifying the executed code.

Code formatter (BIConfigurableFormatter/BISimpleFormatter)
A code formatter walks over the AST tree and reformats the code (node positions) based on a simple format rule or a configurable formatting style.

TextStyler
SHRBTextStyler builds a attributed text representation of the source code, augmented with text font, color or emphasis attributes based on the current style settings. 

And of course
RBParseTreeSearcher and RBParseTreeRewriter
The original users of this AST structure for searching and rewriting code, more on this in its own chapter.
'
! !

!RBRefactoringCoreHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'RB Refactoring Engine'! !

!RBRefactoringCoreHelp class methodsFor: 'pages' stamp: ''!
browserEnvironments
	^HelpTopic
		title: 'RBBrowserEnvironment'
		contents: 
'
The first and main use for browser environments are to restrict the namespace in which a refactoring operation is applied. For example, if you want to rename a method and and update all senders of this method, but only in a certain package, you can create a RBNamespace from a scoped ''view'' of the classes from the whole system. Only the classes in this restricted environment are affected by the transformation.

In the mean time other tools are using this environment classes as well. Finder, MessageBrowser or the SystemBrowser can work with a scoped environment to show and operate only on classes and methods in this environment.

There are different subclasses of RBBrowserEnvironment for the different kind of ''scopes''. 

RBClassEnvironment - only show classes/methods from a set of classes.
RBPackageEnvironment - only show classes / packages / methods from a set of packages.
RBSelectorEnvironment - only show classes / methods from a set of selector names.
(see the list of RBEnvironment(subclasses) pages in this book).

Instead of directly using the different subclasses for a scoped view, the base class RBBrowserEnvironment can act as a factory for creating restricted environments. See the methods in its ''environments''-protocol, on how to create the different environments.

You start with a default environment containing all classes from the system and create a new scoped environment by calling the appropriate method.

For example, creating an environment for all classes in package ''Kernel'':

RBBrowserEnvironment new forPackageNames:{''Kernel''}.

You can query the environment just like you for Smalltalk globals
|env|
env := RBBrowserEnvironment new forPackageNames:{''Kernel''}.
env allClasses "-> a list of all classes in package Kernel"

or open a browser
env browse "-> starts Calypso showing only this package"

and you can further restrict this package environment by calling one of the other factory methods:

env class "-> a RBPackageEnvironment"
(env implementorsOf:#collect:) class "->  RBSelectorEnvironment"

Another way to combine or further restrict environments is to use boolean operations and, not or or.

|implDrawOn callsDrawOn implAndCalls |
callsDrawOn := RBBrowserEnvironment new referencesTo: #drawOn:.
implDrawOn :=  RBBrowserEnvironment new implementorsOf: #drawOn:.
"create an ''anded''-environment"
implAndCalls := callsDrawOn & implDrawOn.
"collect all message and open a MessageBrowser"
MessageBrowser browse: implAndCalls methods.

This opens a MessageBrowser on all methods in the system that implement #drawOn: and calls drawOn:.

|implPrintOn notImplPrintOn |
implPrintOn := RBBrowserEnvironment new implementorsOf: #printOn:.
"create a ''not''-environment"
notImplPrintOn := implPrintOn not.
implPrintOn includesClass: Object. "-> true"
notImplPrintOn includesClass: Object. "-> false"

classes implementing #printOn: are not in the ''not''-environment.

A more generic way to create an environment by giving an explicit ''test''-block to select methods for this environment:

|implementedByMe|
implementedByMe := RBBrowserEnvironment new selectMethods:[:m | m author = Author fullName ].
implementedByMe browse.
 
This opens (may be slow) a browser with all classes with methods having my (current Author) name for its current methods version author stamp.
'! !

!RBRefactoringCoreHelp class methodsFor: 'pages' stamp: ''!
overview
	^HelpTopic
		title: 'Overview'
		contents: 
'
This book contains some chapter about the core components
the Abstract Syntax Tree (AST)
the parser (RBParser)
the extended pattern parser (RBPatternParser)
the tree searcher / rewriter (RBParseTreeSearcher/RBParseTreeRewriter)
'! !

!RBRefactoringCoreHelp class methodsFor: 'pages' stamp: ''!
patternParser
	^HelpTopic
		title: 'RBPatternParser and metavariables'
		contents: 
'
Generating an AST of Smalltalk source code and implementing a program node visitor gives already great and powerful capabilities. The refactoring framework extends this expressiveness by including so called "metavariables".

As this expressions are using an extended syntax - metavariables aren''t known to the RBParser - a special parser is needed to parse this expression, the RBPatternParser.
The following pages describe the added syntax elements. Examples on how to use or tests these expressions
can be found in the chapter "RBPatternParser examples".

metavariables are a part of a parser expression, just like any other Smalltalk code, but instead of representing an expression with the exact name, they form a variable that can be unify with any real code expression with the same *structure*.

An example:
Parsing an expression like:
a := a + 1 
creates a parse tree with an assignment node assigning to ''a'', the value of sending the message ''+'' with argument 1 to the object ''a''.

We could implement a refactoring operation (or directly use the RBParseTreeSearcher/Rewriter) to create a refactoring  for this kind of code. But of course, it would only work for code using this variable name.

We can define the expression with the meaning of ''increment a variable by one'' by using a metavariable. All metavariables start with a ´ (backquote).
`a := `a + 1

This is the simplest metavariable, a name with a backquote. It will match a single variable. And for matching the whole expression, all variables with the same name must match the same variables. 
The above expression only matches 
''x:=x+1'' 
but not 
''x:=y+1''.

If we want to match more than a single variable, we can prefix the name with a ''@'':

`a matches a single variable
`@a matches multiple items in this position

For example, 
`@a add: `@b
will match any expression with the message send #add: regardless whether the receiver or arguments are single variables
''coll add: item''
or the return of another expression
''self data add: self''

Furthermore we can restrict the expression to be matched to be a literal instead of variable by using the prefix ''#'':

`@exp add: `#item

This will match any code calling #add: on an object or expression with a literal as argument:
''coll add: 3''
''self foo add: ''text'' ''
''coll add: #symbol''

But again, #lit is a named variable and matches only the same literal in every part of the expression:

`self add: `#lit; add: `#lit

will match
''self add: #a; add: #a''
but not 
''self add: #a; add: #b''

Similar to a statement ending with a dot, the metavariable prefix ''.'' defines a variable matching a statement, resp. ''.@'' a (possible empty) list of statements.

Example, match ifTrue:ifFalse: with first statement in true and false block being the same

`@exp ifTrue:[`.stm. 
				  `.@trueCase]
      ifFalse:[`.stm. 
				  `.@falseCase]

This will match

someValue ifTrue:[ self doA.
	                self doFoo]
          ifFalse:[ self doA.
	                self doBaz]


Important especially for the rewriter, we may not only want to know the first node matching an expression but every other and for example any possible subexpression matching the metavariable. For this, we can
use a double backquote to indicate that the search should recurse into the found node expression to search for more matches.

This expression will find all senders of add:
`@exp add:`@value
but if we would use this expression to rewrite add: by addItem:
an expression like

var add: (self add: aValue).

would be replaced by

var addItem: (self add: aValue).

If we want to find the same call in the argument, we need to recurse into it by using a double backquote

`@exp add:``@value
'! !

!RBRefactoringCoreHelp class methodsFor: 'pages' stamp: ''!
patternParserExamples
	^HelpTopic
		title: 'Examples and usage of RBPatternParser expressions'
		contents: 
'
The chapter "RBPatternParser and metavariables" describes the added syntax elements for the RBPatternParser used in the refactoring engine (RBParseTreeSearcher/RBParseTreeRewriter).

In this chapter we show some example expressions and how to test and use them.

Calypso has a search function that is the simples way to use and see the result of searching expressions with pattern syntax. Open the the class menu / Refactoring / Code Rewrite / Search code or Rewrite code entry.

Search code
The search code menu will put a search pattern template in the code pane:

RBParseTreeSearcher new
	matches: ''`@object'' do: [ :node :answer | node ];
	matchesMethod: ''`@method: `@args | `@temps | `@.statements'' do: [ :node :answer | node ];
	yourself
	

This template defines two match rules, one for the code search ''matches:'' and one for the named method search ''matchesMethod'', the former looks for expression in any method while the latter one matches whole methods.

You can replace the example pattern ''`@object'' or ''`@method: `@args | `@temps | `@.statements'' by
the search pattern you want to use. And most of the time you only want to use one, the code expression search or the method search.

A first example, replace the code pane content by:
RBParseTreeSearcher new
	matchesMethod: ''drawOn: `@args | `@temps | `@.statements'' do: [ :node :answer | node ];
	yourself

You can now accept this code, instead of saving this method it will just spawn a code searcher trying all defined methods to match against this pattern and opens a MessageBrowser for all found results.
The result is actually the same as if we had searched for all implementors of #drawOn:

Next example, replace the code pane content by:
RBParseTreeSearcher new
	matches: ''`@object drawOn: `@args'' do: [ :node :answer | node ];
	yourself

The result is similar to looking for senders of #drawOn: (not the same actually, as sendersOf also looks for methods containing the symbol #drawOn: )	
	
The #do: block can be used to further test or filter the found matches. The node is the current matched node and the answer is not needed here. It is important that for every entry you want to include in the result to return "the node" and for everything else return "nil"

Example, search for all methods with at least one argument where the method name starts with ''permform'':

RBParseTreeSearcher new
		matchesMethod: ''`@method: `@args | `@temps | `@.statements''
			do: [ :node :answer | 
			((node selector beginsWith: ''perform'') and: [ node arguments isEmpty not ])
				ifTrue: [ node ]
				ifFalse: [ nil ] ];
		yourself

Another way to use extended pattern syntax is to directly instantiate a RBParseTreeSearcher and execute it on a parse tree.
First we define the pattern, instantiate a tree searcher and tell him what to do when matching this pattern (just return the matched node) and execute it on the AST of Numbers method #asPoint.

| searcher pattern parseTree |
pattern := ''^ self''.
searcher := RBParseTreeSearcher new.
searcher matches: pattern do:[:node :answer |node].
searcher executeTree: (Number>>#asPoint) ast initialAnswer: nil.

it will return nil, since no node in that method returns ''self''. If we execute the searcher instead on the method
for class Point, it will return the found node, a RBReturnNode

searcher executeTree: (Point>>#asPoint) ast initialAnswer: nil.

If we don''t just want to match an expression but collecting all matching nodes, we can collect all nodes within the #do: block:

| searcher pattern parseTree  selfMessages |
selfMessages := Set new.
pattern := ''self `@message: ``@args''.
searcher := RBParseTreeSearcher new.
searcher matches: pattern do:[:node :answer |  selfMessages add: node selector].
searcher executeTree: (Morph>>#fullDrawOn:) ast initialAnswer: nil.
selfMessages inspect.

This will collect all messages send to self in method Morph>>#fullDrawOn:


'! !

!RBRefactoringCoreHelp class methodsFor: 'pages' stamp: ''!
overviewParser
	^HelpTopic
		title: 'RBParser'
		contents: 
'
The Refactoring Framework contains its own parser.

Defining or implementing refactoring operations on the raw source code level is difficult. For example, we would have to distinguish whether a word is an instance variable name, an argument or a reserved word.
Therefor a parser first translates the source code into an abstract syntax tree (AST).

The tree consists of nodes for every source code element, tagged it with some "type" information (the node subclass), source code location, and optional properties. And it represents the whole source code structure. 

For example, the AST for the source code of a method has a RBMethodNode with child nodes RBArgument for the arguments (if any) and a RBSequenceNode for the code body. The RBSequenceNode has child nodes for any
defined temporaries and the actual code, RBAssignmentNode for variable assignments, RBMessageNode for message sends.

This is how the structure  for Numbers #sgn method AST looks:
RBParser parseMethod:''sign
	self > 0 ifTrue: [^1].
	self < 0 ifTrue: [^-1].
	^0''

|->RBMethodNode sign
  |->RBSequenceNode self > 0 ifTrue: [ ^ 1 ]. self < 0 ifTrue: [ ^ -1 ]. ^ 0
    |->RBMessageNode ifTrue:
      |->RBMessageNode >
        |->RBSelfNode self
        |->RBLiteralValueNode 0
      |->RBBlockNode [ ^ 1 ]
        |->RBSequenceNode ^ 1
          |->RBReturnNode ^ 1
            |->RBLiteralValueNode 1
    |->RBMessageNode ifTrue:
      |->RBMessageNode <
        |->RBSelfNode self
        |->RBLiteralValueNode 0
      |->RBBlockNode [ ^ -1 ]
        |->RBSequenceNode ^ -1
          |->RBReturnNode ^ -1
            |->RBLiteralValueNode -1
    |->RBReturnNode ^ 0
      |->RBLiteralValueNode 0

Although many Smalltalk implementations already include a parser as a part of its compiler tool chain, they don''t fulfill the requirements needed for the code transformations with the refactoring framework.
The AST for the compiler, is often only needed to create the byte code and therefore can ignore any code comments or the code formatting. If we use the AST in the refactoring for search and replace code, for example renaming a variable, we don''t want to reformat the whole code or remove any code comments. 

The RBParser therefore stores the original code locations and code comments, and only replaces those elements defined by the refactoring transformation and preserves the method comments.

In recent pharo versions, the RBParser actual replaces the original parser used to compile code. It is as powerful as the prior parser, maybe a little bit slower, but easier to maintain. And in the mean time other tools, despite the compiler and the refactoring framework are using this tools as well. 
(For instance, the syntax highlighting and the code formatter are based on the RBParsers AST nodes).

But the real strength of the refactoring framework comes from another (RBParser sub-) class, the 
RBPatternParser, described in its own chapter.
'! !

!RBRefactoringError commentStamp: ''!
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: ''!
actionBlock
	^ actionBlock
	! !

!RBRefactoringError methodsFor: 'accessing' stamp: ''!
actionBlock: aBlock 
	actionBlock := aBlock! !

!RBRefactoringError methodsFor: 'testing' stamp: ''!
isResumable
	^ true! !

!RBRefactoringError methodsFor: '*SystemCommands-RefactoringSupport' stamp: ''!
notifyUserOfCommand: aCommand

	| answer title |
	title := self actionBlock ifNotNil: [ 'Warning' ] ifNil: [ 'Warning. Want to proceed?' ].

	answer := self uiManager confirm: self messageText label: title. 

	answer ifTrue: [ 
		"Existing actionBlock means that there is already defined handled of refactoring error.
		We should not resume in that case. Otherwise user can resume by his own risk"
		self actionBlock 
			ifNil: [ self resume: true ] 
			ifNotNil: #value]! !

!RBRefactoringError class methodsFor: 'signalling' stamp: ''!
signal: aString with: aBlock 
	^ self new
		actionBlock: aBlock;
		signal: aString! !

!RBRefactoringExamplesHelp commentStamp: ''!
This chapter of the refactoring help book is about how to manually use the refactoring operations.!
!RBRefactoringExamplesHelp class methodsFor: 'pages' stamp: ''!
combineOperationsExample
	^HelpTopic
		title: 'Combining operations - Add class with instance variables'
		contents: 
'
As we saw, the RBAddClassRefactoring does not allow us to define any instance variables. Instead we can add a new class and then apply another refactoring, RBAddInstanceVariableRefactoring.
We just need to call them in the appropriate order and make sure that both operations operate on the same model - otherwise the instance variable refactoring would not know about the class it
should operate on.

  | model addClassRB addInstVarsRB browser |
    model := RBNamespace new.
    addClassRB := RBAddClassRefactoring
        model: model
        addClass: #SomeClass
        superclass: #Object
        subclasses: {}
        category: #Category.
    addClassRB primitiveExecute.
    addInstVarsRB := RBAddInstanceVariableRefactoring
        model: model
        variable: ''x''
        class: #SomeClass.
    addInstVarsRB primitiveExecute.
    browser := ChangesBrowser new.
    browser := ChangesBrowser changes: (model changes changes ).
    browser open

It is important to actually execute the first operation before creating the second one. The instantiation of the RBAddInstanceVariableRefactoring will query the environment the class #SomeClass and
init the reference to nil if it doesn''t yet exists.

The changes browser now includes two refactorings, you can select only the second one but this won''t work.
If you applied both, and want to undo that changes, you''ll need to call two times:
RBRefactoryChangeManager instance undoOperation.
'! !

!RBRefactoringExamplesHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#( overview firstExample combineOperationsExample restrictedEnvironmentExample refactoringOptions)! !

!RBRefactoringExamplesHelp class methodsFor: 'pages' stamp: ''!
firstExample
	^HelpTopic
		title: 'A first example'
		contents: 
'
We want to add a new class with the RBAddClassRefactoring. (This is just a simple example, most of the time you won''t use a refactoring operation for adding new classes. But it is used by tools generating classes or by other refactoring operations (RBSplitClassRefactoring)).

First we need a namespace, a RBNamespace, it collects the changes generated by this operation and provides an environment for finding other classes / methods affected by the operation.
We create a ''default'' RBNamespace that represents an environment of all system classes. The RBAddClassRefactoring needs all the information needed for the class hierarchy (name/superclass/subclasses/category) and our namespace as the ''model''. The ChangesBrowser lists all the refactoring changes in a check box list. The reason for calling ''changes changes'' not the model is, because the first ''changes'' does not give a list of all changes but a RBCompositeRefactoryChange that actually holds the list of all changes.

  | model addClassRB browser |
    model := RBNamespace new.
    addClassRB := RBAddClassRefactoring
        model: model
        addClass: #SomeClass
        superclass: #Object
        subclasses: {}
        category: #Category.
    addClassRB primitiveExecute.
    browser := ChangesBrowser changes: (model changes changes ).
    browser open

In the ChangesBrowser list of changes you can select which one to apply. Keep in mind that some compound refactorings may not show all intermediate changes.

The primitiveExecute method will check all preconditions for this Refactoring and either shows a warning or a refactoring error, if this operation can not be performed.
We can execute the above refactoring ''twice'' and will see the second time it shows an error about SomeClass already exists.

There is a global change manager - RBRefactoryChangeManager, we can use it to undo the last operation.

RBRefactoryChangeManager instance undoOperation.
and again redo
RBRefactoryChangeManager instance redoOperation.
and undo, and .... :)

'! !

!RBRefactoringExamplesHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Refactoring Examples'! !

!RBRefactoringExamplesHelp class methodsFor: 'pages' stamp: ''!
overview
	^HelpTopic
		title: 'Overview'
		contents: 
'
This chapter describes the steps needed to set up an environment and fill in the data
to execute refactoring operations.

This enables you to execute refactorings that aren''t provided by the System Browser, or combining a set of operations for a more complex refactoring. It also gives a hint on how to add refactoring support for your own tools.


These are the steps used for all of the examples:
- create a RBNamespace
- instantiate the refactoring operation
- execute it (primitiveExecute)
- open a changes browser to view and apply the changes
  applying the changes will actually execute the code transformations ''for real''.
'! !

!RBRefactoringExamplesHelp class methodsFor: 'pages' stamp: ''!
restrictedEnvironmentExample
	^HelpTopic
		title: 'Scoping Refactoring'
		contents: 
'
A refactoring operation often changes existing code by first, search for a pattern, and then transform the matching code into the new form. But in some situations you don''t want to apply the change to all found matches.
For example, you want to rename a method in all implementors and all callers of your package. If this method name is a common message in other (system) classes as well, you don''t want to rename all places and for sure you don''t want to go through the ChangesBrowser and unselect all those matches by hand.

We can restrict the search space by creating our namespace from a restricted browser environment.
(More about restricted environments in the chapter RBBrowserEnvironments)

In this example we will apply the RBPrettyPrintCodeRefactoring to all classes in the Package ''Tests'', by first creating a RBBrowserEnvironment for packages and then create the RBNamespace with this environment:

 | env model prettyPrintRB browser |
    env := RBBrowserEnvironment new forPackageNames:{''Tests''}.
    model := RBNamespace onEnvironment: env.
    prettyPrintRB := RBPrettyPrintCodeRefactoring new model: model; yourself.
    prettyPrintRB primitiveExecute.
    browser := ChangesBrowser new.
    browser := ChangesBrowser changes: (model changes changes ).
    browser open

After applying this refactoring, all methods in all classes of the package ''Tests'' will be reformatted (pretty print).
'! !

!RBRefactoringExamplesHelp class methodsFor: 'pages' stamp: ''!
refactoringOptions
	^HelpTopic
		title: 'Refactoring Options'
		contents: 
'
Some refactoring operations may require additional informations for performing the transformation. For example a ''move method '' refactoring, moving a method from one class to another may add an additional argument if the prior method had some ''self sends''. Some of the information are given by instantiating the refactoring and some information can be computed by the
operation itself. For other cases the refactoring may actually break code or create broken code. To make this operation still work the programmer or user of the refactoring engine
could provide the needed information. 

For this, the engine contains a set of ''options'' that can be set by the tool using the framework, to register callback functions used to aquire the information from the user.

The options that can be used are:

#implementorToInline - select one of a list of method names

#methodName - ask for a method name

#selfArgumentName - argument name to use for replacing self sends

#selectVariableToMoveTo - select one of a list of variable names

#variableTypes - select or provide a class

#extractAssignment - should the code extraction include the variable assignment

#inlineExpression - I don''t know

#alreadyDefined - Should it override  methods defined in the hierarchy.

#useExistingMethod - Should it use existing (equivalent) method

#openBrowser - call to open system browser

A tool now can register a callback like

refactoring setOption:#name_of_an_option toUse:[:a :b: ... a block with needed arguments]

for example, Calypso sets the option
#implementorToInline to a method showing a dialog with a list to choose one of the provided selector names.

In the following example we show how to set the needed options manually. The RBMoveMethodRefactoring will ask us three questions
- selfArgumentName
- variableTypes
- methodName

for all of this options we set a simple block that just returns the information needed for this example task. In a real world tool, we
would need some interactive tool to let the user make a choice.
This RBMoveMethodRefactoring will move the implementation from TestResult class>>#historyFor: to its argument of type TestCase

    | model rbMoveMethod browser |
    model := RBNamespace onEnvironment: RBBrowserEnvironment new.
    rbMoveMethod := RBMoveMethodRefactoring
        model: model
        selector: #historyFor:
        class: TestResult class
        variable: ''aTestCaseClass''.
    rbMoveMethod setOption: #selfArgumentName toUse: [ :ref | ''aResultClass'' ].
    rbMoveMethod
        setOption: #variableTypes
        toUse: [ :ref :types :selected | {(model classNamed: #TestCase)} ].
    rbMoveMethod
        setOption: #methodName
        toUse: [ :ref :name | RBMethodName selector: ''asHistoryFor:'' arguments: {''aTestResult''} ].
    rbMoveMethod primitiveExecute.
    browser := ChangesBrowser changes: model changes changes.
    browser open

The result of this operation is, the method #historyFor: is moved to the class TestCase and the former implementation is replaced by
  aTestCase asHistoryFor: self
as the former implementation had a call to self (self newTestDictionary) we need to add self as an argument for the new method.
The refactoring operation queries this argument name by calling the registered block for the option ''selfArgumentName'', as the refactoring can not guess the type
of the class we want to move the method, it will ask us by calling ''variableTypes'' and finally the new method name and arguments are provided by calling the block for option
''methodName''.
'! !

!RBRefactoringFailure commentStamp: ''!
This error is signalled whenever there is a non recoverable error during refactorings.!
!RBRefactoringFailure methodsFor: 'testing' stamp: ''!
isResumable
	^ false! !

!RBRefactoringFailure methodsFor: '*SystemCommands-RefactoringSupport' stamp: ''!
notifyUserOfCommand: aCommand

	self uiManager abort: self messageText! !

!RBRefactoringWarning commentStamp: ''!
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.
!
!RBRefactoringWarning methodsFor: '*SystemCommands-RefactoringSupport' stamp: ''!
notifyUserOfCommand: aCommand

	| answer title |
	title := 'Warning. Want to proceed?'.
	answer := self uiManager confirm: self messageText label: title.
	answer ifTrue: [ self resume: true ]! !

!RBRefactoryChange commentStamp: ''!
I am the superclass of all refactoring change objects. 
All I have is a name for the refactoring, but I can perform one or more refactoring operations with the message #execute. 
I am a composite object. To know about my components, ask me with #changes and #changesSize. !
!RBRefactoryChange methodsFor: 'displaying' stamp: ''!
displayString

	^ name ifNil: [ self changeString ] ifNotNil: [ name ]! !

!RBRefactoryChange methodsFor: 'private' stamp: ''!
executeNotifying: aBlock 
	self subclassResponsibility! !

!RBRefactoryChange methodsFor: '*NautilusRefactoring' stamp: ''!
accept: aText notifying: aController
	^ false! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
changeForMetaclass: aClassName selector: aSelector

	^ nil! !

!RBRefactoryChange methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	onSystemDictionary := Smalltalk globals.
	changeFactory := RBRefactoryChangeManager changeFactory! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
changeForClass: aClassName selector: aSelector

	^ nil! !

!RBRefactoryChange methodsFor: 'performing-changes' stamp: ''!
execute
	^self executeNotifying: []! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
onSystemDictionary: anObject

	onSystemDictionary := anObject! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
nameToDisplay

	^ self name! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
changeStamp

	^ Author changeStamp! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
name

	^ name ifNil: [ self changeString ] ifNotNil: [ name ]! !

!RBRefactoryChange methodsFor: 'initialization' stamp: ''!
name: aString
	name := aString! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
changes

	^ Array with: self! !

!RBRefactoryChange methodsFor: '*NautilusRefactoring' stamp: ''!
whatToDisplayIn: aChangeBrowser

	^ { self }! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
onSystemDictionary

	^ onSystemDictionary! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
oldVersionTextToDisplay

	^ ''! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
renameChangesForClass: oldClassName to: newClassName
	"We're in the middle of performing a rename operation. If we stored the class name, we need to change the class name to the new name to perform the compiles."

	self subclassResponsibility! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
textToDisplay

	^ self name! !

!RBRefactoryChange methodsFor: 'printing' stamp: ''!
changeString
	^self class name! !

!RBRefactoryChange methodsFor: 'accessing' stamp: ''!
changesSize

	^ 1! !

!RBRefactoryChangeFactory commentStamp: ''!
This object is the  abstract factory of all the changes, 
the idea is to have another version of the changes that can use the atomic class installer.!
!RBRefactoryChangeFactory methodsFor: 'refactory changes - packages' stamp: ''!
addPackageNamed: aString

	^ RBAddPackageChange addPackageNamed: aString! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - classes' stamp: ''!
addTraitDefinition: definition

	^ RBAddTraitChange definition: definition! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - packages' stamp: ''!
removePackageNamed: aString

	^ RBRemovePackageChange removePackageNamed: aString! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - variables' stamp: ''!
addPoolVariable: variableName to: aClass

	^ RBAddPoolVariableChange add: variableName to: aClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - variables' stamp: ''!
removePoolVariable: variableName from: aClass

	^ RBRemovePoolVariableChange remove: variableName from: aClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - variables' stamp: ''!
addClassVariable: variableName to: aClass

	^ RBAddClassVariableChange add: variableName to: aClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - methods' stamp: ''!
removeMethod: aSelector from: aClass

	^ RBRemoveMethodChange remove: aSelector from: aClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - methods' stamp: ''!
addMethodSource: sourceCode in: aClass classified: aProtocol for: aController

	^ RBAddMethodChange
		  compile: sourceCode
		  in: aClass
		  classified: aProtocol
		  for: aController! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - methods' stamp: ''!
addMethodSource: sourceCode in: aClass classified: aProtocol

	^ RBAddMethodChange
		  compile: sourceCode
		  in: aClass
		  classified: aProtocol! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - classes' stamp: ''!
addClassDefinition: definition for: aController context: aDictionary

	^ RBAddClassChange
		  definition: definition
		  for: aController
		  context: aDictionary! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - classes' stamp: ''!
addClassDefinition: definition for: aController

	^ RBAddClassChange definition: definition for: aController! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - classes' stamp: ''!
comment: aComment in: aRBClass

	^ RBCommentChange comment: aComment in: aRBClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - composites' stamp: ''!
compositeRefactoryChange

	^ RBCompositeRefactoryChange new! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - packages' stamp: ''!
renamePackage: aRBPackage to: newName

	^ RBRenamePackageChange rename: aRBPackage name to: newName! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - composites' stamp: ''!
compositeRefactoryChangeNamed: name

	^ RBCompositeRefactoryChange named: name! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - classes' stamp: ''!
addClassDefinition: definition

	^ RBAddClassChange definition: definition! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - variables' stamp: ''!
renameClassVariable: oldName to: newName in: aClass

	^ RBRenameClassVariableChange rename: oldName to: newName in: aClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - variables' stamp: ''!
removeInstanceVariable: variableName from: aClass

	^ RBRemoveInstanceVariableChange remove: variableName from: aClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - methods' stamp: ''!
addMethodSource: sourceCode in: aClass for: aController

	^ RBAddMethodChange compile: sourceCode in: aClass for: aController! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - methods' stamp: ''!
addMethodSource: sourceCode in: aClass

	^ RBAddMethodChange compile: sourceCode in: aClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - variables' stamp: ''!
renameInstanceVariable: oldName to: newName in: aClass

	^ RBRenameInstanceVariableChange rename: oldName to: newName in: aClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - variables' stamp: ''!
removeClassVariable: variableName from: aClass

	^ RBRemoveClassVariableChange remove: variableName from: aClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - variables' stamp: ''!
removeClassNamed: aClassName

	^ RBRemoveClassChange removeClassName: aClassName! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - classes' stamp: ''!
renameClass: aRBClass to: newName

	^ RBRenameClassChange rename: aRBClass name to: newName! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - variables' stamp: ''!
addInstanceVariable: variableName to: aClass

	^ RBAddInstanceVariableChange add: variableName to: aClass! !

!RBRefactoryChangeFactory methodsFor: 'refactory changes - packages' stamp: ''!
renamePackageNamed: aRBPackage to: newName

	^ RBRenamePackageChange rename: aRBPackage to: newName! !

!RBRefactoryChangeFactory class methodsFor: 'accessing' stamp: ''!
instance

	^ RBRefactoryChangeManager instance changeFactory! !

!RBRefactoryChangeManager commentStamp: ''!
I am a change manager keeping track of all changes applied by the refactory manager. Typically there is only a single
instance of me used in the system, so all changes can be globally added/inspected/ executed and undone/redone.

The size of my undo list is configurable in the settings browser.!
!RBRefactoryChangeManager methodsFor: 'public access' stamp: ''!
redoOperation
	redo ifEmpty: [ ^ self ].
	self ignoreChangesWhile: [ 
		| change |
		change := redo removeLast.
		undo add: change execute ]! !

!RBRefactoryChangeManager methodsFor: 'public access' stamp: ''!
undoPointers

	^ undoPointers! !

!RBRefactoryChangeManager methodsFor: 'change-factory' stamp: ''!
changeFactory

	^ changeFactory! !

!RBRefactoryChangeManager methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	changeFactory := RBRefactoryChangeFactory new.
	self clearUndoRedoList.
	isPerformingRefactoring := false.
	self connectToChanges! !

!RBRefactoryChangeManager methodsFor: 'public access' stamp: ''!
performChange: aRefactoringChange
	self ignoreChangesWhile: [ self addUndo: aRefactoringChange execute ]! !

!RBRefactoryChangeManager methodsFor: 'private' stamp: ''!
clearUndoRedoList
	undo := Stack new.
	redo := OrderedCollection new.
	undoPointers := Stack new.
	self class resetCounter.! !

!RBRefactoryChangeManager methodsFor: 'updating' stamp: ''!
update: anEvent

	isPerformingRefactoring ifFalse: [ self clearUndoRedoList ]! !

!RBRefactoryChangeManager methodsFor: 'public access' stamp: ''!
ignoreChangesWhile: aBlock
	isPerformingRefactoring
		ifTrue: [ ^ aBlock value ].
	isPerformingRefactoring := true.
	aBlock ensure: [ isPerformingRefactoring := false ]! !

!RBRefactoryChangeManager methodsFor: 'public access' stamp: ''!
redoChange
	^ redo last! !

!RBRefactoryChangeManager methodsFor: 'public access' stamp: ''!
addUndoPointer: aNumber
	undoPointers push: aNumber! !

!RBRefactoryChangeManager methodsFor: 'testing' stamp: ''!
hasRedoableOperations
	^ redo isNotEmpty! !

!RBRefactoryChangeManager methodsFor: 'public access' stamp: ''!
lastUndoPointer
	^ undoPointers pop! !

!RBRefactoryChangeManager methodsFor: 'public access' stamp: ''!
undoOperation

	undo ifEmpty: [ ^ self ].
	self ignoreChangesWhile: [ 
		| change |
		change := undo removeLast.
		redo add: change execute ]! !

!RBRefactoryChangeManager methodsFor: 'initialization' stamp: ''!
release

	self disconnectFromChanges.
	super release! !

!RBRefactoryChangeManager methodsFor: 'initialization' stamp: ''!
disconnectFromChanges

	SystemAnnouncer uniqueInstance unsubscribe: self! !

!RBRefactoryChangeManager methodsFor: 'public access' stamp: ''!
addUndo: aRefactoringChange
	undo push: aRefactoringChange.
	undo size > UndoSize
		ifTrue: [ undo removeFirst ].
	redo := OrderedCollection new! !

!RBRefactoryChangeManager methodsFor: 'testing' stamp: ''!
hasUndoableOperations
	^ undo isNotEmpty! !

!RBRefactoryChangeManager methodsFor: 'initialization' stamp: ''!
connectToChanges
	SystemAnnouncer uniqueInstance weak
		when: CategoryAdded,
			CategoryRemoved,
			CategoryRenamed,
			ClassAdded,
			ClassModifiedClassDefinition,
			ClassRemoved,
			ClassRenamed,
			ClassReorganized,
			MethodAdded,
			MethodModified,
			MethodRemoved,
			ProtocolAdded,
			ProtocolRemoved
		send: #update:
		to: self.! !

!RBRefactoryChangeManager methodsFor: 'public access' stamp: ''!
undoChange

	^ undo pop! !

!RBRefactoryChangeManager class methodsFor: 'class initialization' stamp: ''!
undoSize

	^ UndoSize! !

!RBRefactoryChangeManager class methodsFor: 'change - factory' stamp: ''!
changeFactory

	^ self instance changeFactory! !

!RBRefactoryChangeManager class methodsFor: 'instance creation' stamp: ''!
new

	^ self shouldNotImplement! !

!RBRefactoryChangeManager class methodsFor: 'class initialization' stamp: ''!
initialize

	self nuke.
	UndoSize := 20! !

!RBRefactoryChangeManager class methodsFor: 'instance creation' stamp: ''!
instance

	^ Instance ifNil: [ Instance := self basicNew initialize ]! !

!RBRefactoryChangeManager class methodsFor: 'public' stamp: ''!
nuke

	Instance notNil ifTrue: [ Instance release ].
	Instance := nil! !

!RBRefactoryChangeManager class methodsFor: 'public' stamp: ''!
unload

	self nuke! !

!RBRefactoryChangeManager class methodsFor: 'class initialization' stamp: ''!
counter

	^ Counter ifNil: [ Counter := 0 ]! !

!RBRefactoryChangeManager class methodsFor: 'actions' stamp: ''!
resetCounter

	Counter := nil! !

!RBRefactoryChangeManager class methodsFor: 'actions' stamp: ''!
nextCounter

	Counter := self counter + 1.
	^ self counter! !

!RBRefactoryChangeManager class methodsFor: 'class initialization' stamp: ''!
undoSize: anInteger

	UndoSize := anInteger max: 0! !

!RBRefactoryClassChange commentStamp: ''!
I am the abstract baseclass for a "class change" refactoring change. I know about the
class(name) whether it is a change for for the meta or the instance side.

I keep track of the undo and redo operation, but the concrete class change operation is implement by my subclasses.!
!RBRefactoryClassChange methodsFor: 'printing' stamp: ''!
displayClassName

	^ isMeta
		  ifTrue: [ self changeClassName , ' class' ]
		  ifFalse: [ self changeClassName asString ]! !

!RBRefactoryClassChange methodsFor: 'private' stamp: ''!
executeNotifying: aBlock

	| undo |
	undo := self asUndoOperation.
	undo name: self name.
	self primitiveExecute.
	aBlock value.
	^ undo! !

!RBRefactoryClassChange methodsFor: 'private' stamp: ''!
primitiveExecute

	^ self subclassResponsibility! !

!RBRefactoryClassChange methodsFor: 'comparing' stamp: ''!
= aRefactoryClassChange

	self class = aRefactoryClassChange class ifFalse: [ ^ false ].
	^ className = aRefactoryClassChange changeClassName and: [ 
		  isMeta = aRefactoryClassChange isMeta ]! !

!RBRefactoryClassChange methodsFor: 'comparing' stamp: ''!
hash

	^ self changeClassName hash! !

!RBRefactoryClassChange methodsFor: 'accessing' stamp: ''!
methodSourceFor: aSymbol

	^ (self changeClass includesSelector: aSymbol) ifTrue: [ 
		  self changeClass sourceCodeAt: aSymbol ]! !

!RBRefactoryClassChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ self subclassResponsibility! !

!RBRefactoryClassChange methodsFor: 'accessing' stamp: ''!
changeClass

	| class |
	class := onSystemDictionary
		         at: self changeClassName
		         ifAbsent: [ ^ nil ].
	^ isMeta
		  ifTrue: [ class classSide ]
		  ifFalse: [ class ]! !

!RBRefactoryClassChange methodsFor: 'accessing' stamp: ''!
changeClassName: aSymbol

	className := aSymbol.
	isMeta ifNil: [ isMeta := false ]! !

!RBRefactoryClassChange methodsFor: 'accessing' stamp: ''!
changeClass: aBehavior

	isMeta := aBehavior isMeta.
	className := aBehavior instanceSide name! !

!RBRefactoryClassChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: self displayString! !

!RBRefactoryClassChange methodsFor: 'private' stamp: ''!
isMeta

	^ isMeta! !

!RBRefactoryClassChange methodsFor: 'accessing' stamp: ''!
parserClass

	^ RBParser! !

!RBRefactoryClassChange methodsFor: 'accessing' stamp: ''!
renameChangesForClass: oldClassName to: newClassName

	^ self changeClassName = oldClassName
		  ifFalse: [ self ]
		  ifTrue: [ 
			  self copy
				  changeClassName: newClassName;
				  yourself ]! !

!RBRefactoryClassChange methodsFor: 'accessing' stamp: ''!
changeClassName

	^ className! !

!RBRefactoryClassChange methodsFor: 'printing' stamp: ''!
changeString

	^ self displayClassName! !

!RBRefactoryClassChange class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self name = #RBRefactoryClassChange! !

!RBRefactoryDefinitionChange commentStamp: ''!
I am the baseclass for a "class definition change", a change that will create a class or modify the definition of an existing class.
I hold the class definition string and a controller used by the compiler when compiling the class definition for notifying about the
compilation result. My subclass define the kind of class definition I can add, a class, a metaclass a trait or a class trait.

My instance variable "definedClass" is the new class object.!
!RBRefactoryDefinitionChange methodsFor: 'private' stamp: ''!
primitiveExecute

	definedClass := self definitionClass environment
		                defineClass: self definition
		                withController: self controller! !

!RBRefactoryDefinitionChange methodsFor: 'comparing' stamp: ''!
= aDefinitionChange

	^ self class = aDefinitionChange class and: [ 
		  self definition = aDefinitionChange definition ]! !

!RBRefactoryDefinitionChange methodsFor: 'initialization' stamp: ''!
definition: aString controller: aController

	isMeta := false.
	definition := aString.
	controller := aController! !

!RBRefactoryDefinitionChange methodsFor: 'comparing' stamp: ''!
hash

	^ definition hash! !

!RBRefactoryDefinitionChange methodsFor: 'accessing' stamp: ''!
definedClass

	^ definedClass! !

!RBRefactoryDefinitionChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: definition;
		nextPut: $!!! !

!RBRefactoryDefinitionChange methodsFor: 'private' stamp: ''!
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: 'initialization' stamp: ''!
fillOutDefinition: aDictionary

	self subclassResponsibility! !

!RBRefactoryDefinitionChange methodsFor: 'accessing' stamp: ''!
definition

	^ definition! !

!RBRefactoryDefinitionChange methodsFor: 'accessing' stamp: ''!
controller

	^ controller! !

!RBRefactoryDefinitionChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Define ' , self displayClassName! !

!RBRefactoryDefinitionChange methodsFor: 'private' stamp: ''!
definitionClass

	self subclassResponsibility! !

!RBRefactoryDefinitionChange class methodsFor: 'private' stamp: ''!
definitionPatterns

	self subclassResponsibility! !

!RBRefactoryDefinitionChange class methodsFor: 'instance creation' stamp: ''!
definition: aString for: aController

	| parseTree context |
	parseTree := RBParser
		             parseExpression: aString
		             onError: [ :err :pos | 
		             ^ self error: 'Invalid definition string' ].
	context := SmallDictionary new.
	RBRefactoryDefinitionChange allSubclassesDo: [ :class | 
		class definitionPatterns do: [ :pattern | 
			((RBParser parseRewriteExpression: pattern)
				 match: parseTree
				 inContext: context empty) ifTrue: [ 
				^ class definition: aString for: aController context: context ] ] ].
	^ self error: 'Invalid definition:' , aString! !

!RBRefactoryDefinitionChange class methodsFor: 'private' stamp: ''!
definition: aString for: aController context: aDictionary

	| dictionary |
	dictionary := SmallDictionary new.
	aDictionary keysAndValuesDo: [ :key :node | 
		dictionary at: key formattedCode put: (node isVariable
				 ifTrue: [ node name ]
				 ifFalse: [ 
					 node isLiteralNode
						 ifTrue: [ node value ]
						 ifFalse: [ node ] ]) ].
	^ self new
		  definition: aString controller: aController;
		  fillOutDefinition: dictionary;
		  yourself! !

!RBRefactoryDefinitionChange class methodsFor: 'instance creation' stamp: ''!
definition: aString

	^ self definition: aString for: nil! !

!RBRefactoryPackageChange commentStamp: ''!
I am the baseclass for all refactoring changes for all kind of package changes.!
!RBRefactoryPackageChange methodsFor: 'private' stamp: ''!
executeNotifying: aBlock
	| undo |
	undo := self asUndoOperation.
	undo name: self name.
	self primitiveExecute.
	aBlock value.
	^ undo! !

!RBRefactoryPackageChange methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	browserEnvironment := RBBrowserEnvironment default.! !

!RBRefactoryPackageChange methodsFor: 'converting' stamp: ''!
asUndoOperation
	self subclassResponsibility ! !

!RBRefactoryPackageChange methodsFor: 'private' stamp: ''!
primitiveExecute
	self subclassResponsibility! !

!RBRefactoryProtocolChange commentStamp: ''!
RBRefactoryProtocolChange is responsible for adding or removing protocols in classes in a RB model!
!RBRefactoryProtocolChange methodsFor: 'printing' stamp: ''!
displayProtocolName

	^ protocol! !

!RBRefactoryProtocolChange methodsFor: 'accessing' stamp: ''!
protocol: aString

	protocol := aString! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
returnsBooleanAndOther
	self isVariable ifTrue: [^false].
	self printString! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
called: anObject on1: aBlock 
	| each |
	each := anObject printString.
	Transcript
		show: each;
		cr.
	aBlock value: each! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
atIfAbsent
	^ Smalltalk at: #MyTest
		ifAbsent: 
			[| collection |
			collection := #().
			Smalltalk at: #MyTest put: collection]! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
callMethod
	^self renameThisMethod: 5! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
assignmentInBlock
	[^self printString] ensure: [self close]! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
demoExampleCall
	^ self demoRenameMethod: 1 PermuteArgs: 2! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
inlineFoo: aBlock 
	| bar baz asdf |
	bar := aBlock value: self.
	baz := bar + bar.
	asdf := baz + bar.
	^asdf! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
fileBlocks
	| file |
	^
	[file := 'asdf' asFileReference readStream.
	file contents] ensure: [file close]! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
sendInlineBar2
	^ self inlineBar: 'example2'! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
consistencyCheck
	^(1 to: 10) size > 0! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
multipleCalls
	self caller2.
	self caller2! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
usesAdd
	^(1 to: 10) asOrderedCollection addAll: (11 to: 20)! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
tempsReadBeforeWritten
	| temp |
	self isVariable ifTrue: [temp := 4].
	^temp! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
asOrderedCollectionNotNeeded
	self foo addAll: (1 to: 10) asOrderedCollection! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
cruft
	<haltOrBreakpointForTesting>
	self halt! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
refersToClass
	^ RBRefactoryTestDataApp! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
stringConcatenation
	| string |
	string := '' yourself.
	(1 to: 10) do: [:i | string := string , i printString].
	^string! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
called: anObject on: aBlock 
	Transcript
		show: anObject printString;
		cr.
	aBlock value! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
justSendsSuper
	super justSendsSuper! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
endTrueFalse
	self isVariable 
		ifTrue: 
			[self printString.
			self isVariable printString]
		ifFalse: 
			[self printString.
			^4]! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
literalArrayCharacters
	^#($a $b $c) includes: $a! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
inlineMethod
	| temp |
	temp := self
				foo;
				inlineMethod;
				bar.
	^temp! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
moveDefinition
	| temp |
	^(self collect: 
			[:each | 
			temp := each printString.
			temp , temp]) 
		select: 
			[:each | 
			temp := each size.
			temp odd]! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
sendInlineBar
	^ self inlineBar: #example1! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
inlineMax
	| x y q |
	x := 5.
	y := 10.
	q := x + 1 max: y.
	^q! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
selectorNotReferenced
	^self selectorNotReferenced + 4! !

!RBRefactoryTestDataApp methodsFor: 'rendering' stamp: ''!
renderContentOn: html
	html
		form: [ html text: 'Name:'.
			html textInput on: #name of: self contact.
			
			
			html break.
			html text: 'Email address:'.
			html textInput on: #emailAddress of: self contact.
			
			html break.
			html text: 'Example:'.
			
			html textInput on: #example of: self contact.
			html break.].
	html text: 'Last:'.
			html textInput on: #last of: self contact.
					html break.! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
inlineJunk
	| asdf |
	asdf := self inlineFoo: 
					[:each | 
					| temp |
					temp := each.
					temp , temp].
	^asdf foo: 
			[:bar | 
			| baz |
			baz := bar.
			baz * baz]! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
returnsIfTrue
	^self isNil ifTrue: [4]! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
modifiesCollection
	| collection |
	collection := (1 to: 10) asOrderedCollection.
	collection do: [:each | each > 5 ifTrue: [collection remove: each]].
	^collection! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
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: ''!
collectionProtocol
	| newCollection |
	newCollection := OrderedCollection new.
	(1 to: 10) asOrderedCollection do: 
			[:each | 
			| new |
			new := each * 2.
			newCollection add: new].
	^newCollection! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
inlineFailed
	| x y q |
	x := 5.
	y := 10.
	q := x + 1 fooMax: y.
	^q! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
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' stamp: ''!
threeElementPoint
	^5 @ 5 + 6 @ 6! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
noMoveDefinition
	| temp |
	^(self collect: 
			[:each | 
			temp := each printString.
			temp , temp]) 
		select: [:each | temp := each size + temp]! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
inlineBar: aSymbol
	^aSymbol isSymbol! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
rename: this two: argumentMethod
	^self printString , this , argumentMethod! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
guardingClause
	self isSymbol 
		ifFalse: 
			[self printString.
			self isSymbol printString]! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
foo: aValue
	^(1 to: 10) inject: aValue into: [:sum :each | sum + each]! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
caller
	| anObject |
	anObject := 5.
	self 
		called: anObject + 1
		on: [^anObject]! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
ifTrueReturns
	self isSymbol ifFalse: [^true].
	^false! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
precedence
	^self isArray ifFalse: [self block + 5 * 34] ifTrue: [self printString = 10]! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
returnInEnsure
	[self error: 'asdf'] ensure: [^4]! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
toDoCollect
	| array |
	array := Array new: 10.
	1 to: 10 do: [:i | array at: i put: i * i].
	^array! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
toDoWithIncrement
	| counter |
	counter := 0.
	1 to: 10
		by: 2
		do: [:i | counter := counter + 2].
	^counter! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
testFoo: anObject
	^self class + anObject! !

!RBRefactoryTestDataApp methodsFor: 'rendering' stamp: ''!
textInput: html name: aString symbol: aSymbol
	html text: aString.
	html textInput on: aSymbol of: self contact.
	html break! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
toDo
	1 to: self size do: [:i | (self at: i) printString]! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
callFoo
	^self testFoo: 5! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
tempVarOverridesInstVar
	| temporaryVariable |
	temporaryVariable := 4.
	^temporaryVariable! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
booleanPrecedence
	^true & 4 = 45! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
whileTrue
	| i |
	i := 1.
	[i < self size] whileTrue: 
			[(self at: i) printString.
			i := i + 1]! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
inlineLast
	5 = 3 ifTrue: [^self caller] ifFalse: [^self caller2]! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
equalsTrue
	^true == self! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
caller1
	| anObject |
	anObject := 5.
	self called: anObject + 1
		on1: 
			[:each | 
			each printString.
			^anObject]! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
badMessage
	self become: String new! !

!RBRefactoryTestDataApp methodsFor: 'accessing' stamp: ''!
referencesConditionFor: aClass 
	| environment association |
	^(RBCondition withBlock: 
			[association := Smalltalk globals 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.<n>Browse references?';
		errorBlock: [environment openEditor];
		yourself! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
sendsDifferentSuper
	super printString! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
sizeCheck
	self isEmpty
		ifFalse: [self do: 
					[:each | 
					Transcript
						show: each;
						cr]]! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
inlineComponent
	| a |
	a := 5.
	^a class
		superclass;
		hasImmediateInstances;
		yourself! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
inlineTemporary
	| temp |
	self isNil ifTrue: [temp := 4].
	^temp! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
detectContains
	^(1 to: 10) do: [:each | each > 2 ifTrue: [^each]]! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
symbolReference
	^#(#renameThisMethod: #(4 #renameThisMethod:))! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
fullBlocks
	^[thisContext]! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
missingYourself
	^(OrderedCollection new)
		add: 1;
		add: 2;
		removeFirst! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
testMethod
	^self class! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
assignmentInIfTrue
	| variable |
	self isVariable 
		ifTrue: [variable := self]
		ifFalse: [variable := self printString].
	^variable! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
variableAssignedLiteral
	temporaryVariable := #() ! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
yourselfNotUsed
	self
		printString;
		printString;
		yourself! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
searchingLiteral
	^self printString = #a or: [#() = self printString | ( #() == self printString)]! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
testMethod1
	^self testMethod1 
		, ([:each | each testMethod1] value: #(#(#testMethod1) 2 #testMethod1))! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
contains
	^((1 to: 10) detect: [:each | each > 2] ifNone: [nil]) isNil! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
literalArrayWithTrueFalseOrNil2
	| b c |
	b := #(#true #false #nil).
	c := #(#true (#true #false #nil) #false #nil).
^b! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
equalNotUsed
	| string |
	string = '' yourself.
	(1 to: 10) do: [:i | string := i printString].
	^string! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
inlineParameterMethod: aSymbol
	^aSymbol isSymbol! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
exampleCall
	<sampleInstance>
	^self rename: 1 two: 2! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
extraBlock
	^[:arg | arg + 43] value: 45! !

!RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''!
caller2
	^(1 to: 10) inject: 1 into: [:sum :each | sum * (self foo: each)]! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
renameThisMethod: anArg
	^self! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
collectionMessagesToExternalObject
	self someObject collection remove: 10! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
collectSelectNotUsed
	(1 to: 10) select: [:each | each = 4]! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
literalArrayWithTrueFalseOrNil
	| a b c |
	a := #(true false nil).
	b := #(#true #false #nil).
	c := {true. false. nil}.
	^{a. b. c}! !

!RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''!
release
	self printString! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
sendInlineParameterMethod
	^self inlineParameterMethod: #(#asdf)! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
demoMethodWithDuplicates
	| a b result1 result2 answer |
	a := 3.
	b := a + 5.
	result1 := a + b.
	result2 := a + 5.
	answer := result1 + result2 + (a + 5).
	^ answer! !

!RBRefactoryTestDataApp methodsFor: 'tests' stamp: ''!
demoRenameMethod: arg1 PermuteArgs: arg2
	self do: arg1. 
	self do: arg2.
	^ arg1 > arg2! !

!RBRefactoryTyper commentStamp: ''!
I am a type guesser used by refactoring operations.

I try to determine the types used for variables in a class.

Refactoring operations are using me to provide a possible list of classes that are affected by a refactoring. 
For example, for moving or delegating a method implementation to an instance variable, it might be necessary to add this implementation to multiple classes.

I analyze message sends to the instance variables and try to guess the type by looking at implementors of that messages. 
(If a method sends ifTrue:ifFalse: to an instance variable I can guess that the instance variable may be a Boolean object).

If I can guess the type to be a collection, I'll try to investigate the types of the possible contained elements as well.
You can ask for the guessed type of the variable: 
typer guessTypeFor: 'variablename'
and the contained elements: 
typer guessTypeFor: '-variablename-'

Example usage: 
| typer |
"create and initialize for a class to analyze"
typer := (RBRefactoryTyper new runOn: RBMessageNode).

"guess types for RBMessageNodes instane var 'arguments' "
typer  guessTypesFor:'arguments'.  "a Set(SequenceableCollection)"

"guess types for objects that may be put  into  'arguments' collection "
typer  guessTypesFor:'-arguments-' "a Set(RBBlockNode RBMethodNode)"


You can print a full report on all results with #printString.

(RBRefactoryTyper new runOn: Point ) printString.
"'Point
	x	<Integer>
	y	<Integer>
'"

There are two class side methods, one for creating an instance and setting the environment used to resolve names - a RBNamespace.

And another one for guessing types in a parseTree:

RBRefactoryTyper typesFor: 'var' in: (RBParser parseExpression: 'var squared') model: RBNamespace new "a Set(Number Collection)"
(Here, I can guess the types Number and Collections as these are the classes implementing the message #squared)

!
!RBRefactoryTyper methodsFor: 'selectors-collections' stamp: ''!
processCollectionFor: key messagesTo: aName in: aBlock
	| searcher |
	searcher := self parseTreeSearcher.
	searcher
		matches: aName , ' `@message: ``@args'
		do: [ :aNode :answer | 
			self processCollectionMessagesFor: key in: aNode.
			answer
				add: aNode selector;
				yourself ].
	searcher
		executeTree: aBlock
		initialAnswer:
			(variableMessages
				at: (self collectionNameFor: key)
				ifAbsentPut: [ Set new ])! !

!RBRefactoryTyper methodsFor: 'accessing' stamp: ''!
typesFor: variableName in: aParseTree model: aRBSmalltalk
	| searcher messages |
	searcher := self parseTreeSearcher.
	searcher
		matches: variableName , ' `@message: ``@args'
		do: [ :aNode :answer | 
			answer
				add: aNode selector;
				yourself ].
	messages := searcher executeTree: aParseTree initialAnswer: Set new.
	^ self
		model: aRBSmalltalk;
		findTypeFor: messages; 
		yourself! !

!RBRefactoryTyper methodsFor: 'accessing' stamp: ''!
guessTypesFor: anInstVarName 
	^bestGuesses at: anInstVarName ifAbsent: [self typesFor: anInstVarName]! !

!RBRefactoryTyper methodsFor: 'private' stamp: ''!
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: 'printing' stamp: ''!
printType: aClass for: aString on: aStream 
	| name colTypes |
	colTypes := #().
	name := self collectionNameFor: aString.
	(aClass includesClass: (model classFor: Collection))
		ifTrue: [colTypes := self guessTypesFor: name].
	colTypes ifNotEmpty: [aStream nextPut: $(].
	aClass printOn: aStream.
	colTypes ifNotEmpty: 
			[aStream nextPutAll: ' of: '.
			colTypes size > 1 ifTrue: [aStream nextPut: $(].
			self printTypeFor: name on: aStream.
			colTypes size > 1 ifTrue: [aStream nextPut: $)]].
	colTypes ifNotEmpty: [aStream nextPut: $)]! !

!RBRefactoryTyper methodsFor: 'computing types' stamp: ''!
findTypeFor: selectorCollection 
	^selectorCollection inject: self rootClasses
		into: 
			[:classes :each | 
			self refineTypes: classes
				with: (selectorLookup at: each ifAbsentPut: [self implementorsOf: each])]! !

!RBRefactoryTyper methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream
		nextPutAll: class name;
		cr.
	class instanceVariableNames do: 
			[:each | 
			aStream
				tab;
				nextPutAll: each;
				tab;
				nextPut: $<.
			self printTypeFor: each on: aStream.
			aStream
				nextPut: $>;
				cr]! !

!RBRefactoryTyper methodsFor: 'assignments' stamp: ''!
refineTypesByLookingAtAssignments
	| searcher needsSearch |
	needsSearch := false.
	searcher := self parseTreeSearcher.
	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: 'computing types' stamp: ''!
implementorsOf: aSelector 
	| classes |
	classes := OrderedCollection new.
	self rootClasses do: 
			[:each | 
			self 
				implementorsOf: aSelector
				in: each
				storeIn: classes].
	^classes! !

!RBRefactoryTyper methodsFor: 'selectors' stamp: ''!
parseTreeSearcherClass
	^ RBParseTreeSearcher! !

!RBRefactoryTyper methodsFor: 'equivalence classes' stamp: ''!
processNode: aNode 
	(aNode isVariable and: [class instanceVariableNames includes: aNode name]) 
		ifTrue: [^self merge: aNode name].
	(aNode isMessage 
		and: [aNode receiver isSelfVariable]) 
			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: 'computing types' stamp: ''!
refineTypes: aClassCollection with: anotherClassCollection 
	| classSet |
	classSet := Set new.
	aClassCollection do: 
			[:each | 
			anotherClassCollection do: 
					[:cls | 
					(cls includesClass: each) 
						ifTrue: [classSet add: cls]
						ifFalse: [(each includesClass: cls) ifTrue: [classSet add: each]]]].
	^classSet! !

!RBRefactoryTyper methodsFor: 'accessing' stamp: ''!
typesFor: anInstVarName 
	^variableTypes at: anInstVarName ifAbsent: [Set new]! !

!RBRefactoryTyper methodsFor: 'selectors-collections' stamp: ''!
parseTreeSearcher
	^ self parseTreeSearcherClass new! !

!RBRefactoryTyper methodsFor: 'private' stamp: ''!
model
	^model! !

!RBRefactoryTyper methodsFor: 'accessing' stamp: ''!
guessTypesFor: anInstVarName in: aClass 
	class = aClass ifFalse: [self runOn: aClass].
	^bestGuesses at: anInstVarName
		ifAbsent: [self typesFor: anInstVarName in: aClass]! !

!RBRefactoryTyper methodsFor: 'private' stamp: ''!
rootClasses
	^ model rootClasses! !

!RBRefactoryTyper methodsFor: 'computing types' stamp: ''!
computeTypes
	variableMessages
		keysAndValuesDo: [:key :value | variableTypes at: key put: (self findTypeFor: value)]! !

!RBRefactoryTyper methodsFor: 'printing' stamp: ''!
printTypeFor: aString on: aStream 
	| types |
	types := (self guessTypesFor: aString) 
				asSortedCollection: [:a :b | a name < b name].
	1 to: types size
		do: 
			[:i | 
			i == 1 ifFalse: [aStream nextPutAll: ' | '].
			self 
				printType: (types at: i)
				for: aString
				on: aStream]! !

!RBRefactoryTyper methodsFor: 'private' stamp: ''!
executeSearch: searcher 
	class withAllSubclasses do: 
			[:each | 
			each selectors do: 
					[:sel | 
					| parseTree |
					methodName := sel.
					parseTree := each parseTreeFor: sel.
					parseTree doSemanticAnalysis.
					parseTree notNil ifTrue: [searcher executeTree: parseTree]]]! !

!RBRefactoryTyper methodsFor: 'initialization' stamp: ''!
initialize
	model := RBClassModelFactory rbNamespace new.
	class := model classFor: Object.
	variableTypes := Dictionary new.
	variableMessages := Dictionary new.
	selectorLookup := IdentityDictionary new.
	bestGuesses := Dictionary new! !

!RBRefactoryTyper methodsFor: 'accessing' stamp: ''!
typesFor: anInstVarName in: aClass 
	class = aClass ifFalse: [self runOn: aClass].
	^variableTypes at: anInstVarName ifAbsent: [Set new]! !

!RBRefactoryTyper methodsFor: 'accessing' stamp: ''!
runOn: aClass 
	variableTypes := Dictionary new.
	variableMessages := Dictionary new.
	bestGuesses := Dictionary new.
	class := model classFor: aClass.
	class instanceVariableNames isEmpty ifTrue: [^self].
	self
		selectedClass: aClass;
		computeEquivalenceClassesForMethodsAndVars;
		computeMessagesSentToVariables;
		computeTypes;
		refineTypesByLookingAtAssignments! !

!RBRefactoryTyper methodsFor: 'selectors' stamp: ''!
computeMessagesSentToVariables
	| searcher |
	variableMessages := Dictionary new.
	class instanceVariableNames
		do: [ :each | variableMessages at: each put: Set new ].
	searcher := self parseTreeSearcher.
	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: (self parseTreeSearcherClass buildSelectorString: sel))
										asString
								do: block ] ] ].
	searcher answer: variableMessages.
	self executeSearch: searcher! !

!RBRefactoryTyper methodsFor: 'assignments' stamp: ''!
guessTypeFromAssignment: aNode

	| type set newType |

	type := nil.
	aNode value isAssignment
		ifTrue: [ ^ self
				guessTypeFromAssignment: ( RBAssignmentNode variable: aNode variable value: aNode value value )
			].
	aNode value isBlock
		ifTrue: [ type := model classFor: [  ] class ].
	aNode value isLiteralNode
		ifTrue: [ aNode value value ifNil: [ ^ 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 ifNil: [ ^ self ].
	set := variableTypes at: aNode variable name.
	newType := set detect: [ :each | type includesClass: each ] ifNone: [ nil ].
	newType ifNil: [ ^ 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: 'equivalence classes' stamp: ''!
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 := self parseTreeSearcher.
	searcher
		matches: '^``@object'
		do: [ :aNode :answer | self processNode: aNode value ].
	self executeSearch: searcher! !

!RBRefactoryTyper methodsFor: 'computing types' stamp: ''!
implementorsOf: aSelector in: aClass storeIn: classes 
	(aClass directlyDefinesMethod: aSelector) 
		ifTrue: 
			[classes add: aClass.
			^self].
	aClass subclasses do: 
			[:each | 
			self 
				implementorsOf: aSelector
				in: each
				storeIn: classes]! !

!RBRefactoryTyper methodsFor: 'accessing' stamp: ''!
selectedClass: aClass 
	class := model classFor: aClass! !

!RBRefactoryTyper methodsFor: 'private' stamp: ''!
model: aRBSmalltalk
	model := aRBSmalltalk! !

!RBRefactoryTyper methodsFor: 'equivalence classes' stamp: ''!
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: 'selectors-collections' stamp: ''!
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: do: do:displayingProgress: do:separatedBy: #flatCollect: noneSatisfy: reject: select: sum:) 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: 'printing' stamp: ''!
collectionNameFor: aString 
	^'-<1s>-' expandMacrosWith: aString! !

!RBRefactoryTyper methodsFor: 'assignments' stamp: ''!
typeFor: anObject 
	anObject isString
		ifTrue: [ ^ String ].
	anObject isInteger
		ifTrue: [ ^ Integer ].
	^ (anObject == true or: [ anObject == false ])
		ifTrue: [ Boolean ]
		ifFalse: [ anObject class ]! !

!RBRefactoryTyper methodsFor: 'private' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
newFor: aRBNamespace 
	^ self new
			model: aRBNamespace;
			yourself! !

!RBRefactoryTyper class methodsFor: 'accessing' stamp: ''!
typesFor: variableName in: aParseTree model: aRBSmalltalk 
	| searcher messages |
	searcher := RBParseTreeSearcher new.
	searcher matches: variableName , ' `@message: ``@args'
		do: 
			[:aNode :answer | 
			answer
				add: aNode selector;
				yourself].
	messages := searcher executeTree: aParseTree initialAnswer: Set new.
	^(self new)
		model: aRBSmalltalk;
		findTypeFor: messages! !

!RBRefactoryVariableChange commentStamp: ''!
I am the baseclass for all refactoring changes for all kind of variable changes, adding or removing class,  instance variables and pool variables.
I only hold the name of the actual variable. The concrete kind of variable and how the defintion for adding this variable looks like, is implemented
by my subclasses.!
!RBRefactoryVariableChange methodsFor: 'comparing' stamp: ''!
= aRefactoryVariableChange

	^ super = aRefactoryVariableChange and: [ 
		  self variable = aRefactoryVariableChange variable ]! !

!RBRefactoryVariableChange methodsFor: 'initialization' stamp: ''!
class: aBehavior variable: aString

	self changeClass: aBehavior.
	variable := aString! !

!RBRefactoryVariableChange methodsFor: 'comparing' stamp: ''!
hash

	^ self changeClassName hash bitXor: self variable hash! !

!RBRefactoryVariableChange methodsFor: 'private' stamp: ''!
changeObject

	^ self variable! !

!RBRefactoryVariableChange methodsFor: 'private' stamp: ''!
variable

	^ variable! !

!RBRefactoryVariableChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self displayClassName; nextPut: $ ;
		nextPutAll: self changeSymbol; nextPut: $ ;
		print: self variable;
		nextPut: $!!! !

!RBRefactoryVariableChange methodsFor: 'private' stamp: ''!
changeSymbol

	self subclassResponsibility! !

!RBRefactoryVariableChange methodsFor: 'private' stamp: ''!
primitiveExecute

	self changeClass perform: self changeSymbol with: self changeObject! !

!RBRefactoryVariableChange class methodsFor: 'instance creation' stamp: ''!
remove: aVariable from: aBehavior
	"This should only be called on the Remove*Change subclasses, but is here so we don't need to copy it to all subclasses"

	^ self new class: aBehavior variable: aVariable! !

!RBRefactoryVariableChange class methodsFor: 'instance creation' stamp: ''!
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! !

!RBRegexRefactoring commentStamp: ''!
I am a abstract base class for a refactoring replacing strings by a regular expression.

My concrete subclasses define on what kind of string the replace regulare expression should be applied to.
They have to implement the RBRefactoring method #transform.

I have no special precondition.

Here is a sample of a script that will change of the YK* classes of package PrefixOfPackageNames* into ZG*.

```
| pkgPrefix newClassPrefix env model |
pkgPrefix := 'PrefixOfPackageNames'.
newClassPrefix := 'ZG'.
env := RBBrowserEnvironment new 
			forPackageNames: (RPackage organizer packageNames select: [ : pkgName | (pkgName beginsWith: pkgPrefix) ]).
model := (RBClassModelFactory rbNamespace onEnvironment: env) name: 'MyModel'; yourself.
RBClassRegexRefactoring new
	model: model;
	renameClasses; 					"Here I just want a rename no copy"
	replace: '^YK(.*)$' with: newClassPrefix,'$1';
  execute.
```

- ==renameClasses== renames the classes in place
- ==copyclasses== copies the classes (pay attention we are not sure that it is fully working)






!
!RBRegexRefactoring methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	matchers := OrderedCollection new! !

!RBRegexRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ self emptyCondition! !

!RBRegexRefactoring methodsFor: 'searching' stamp: ''!
replace: aFindString with: aReplaceString
	"Replace all matches of aFindString (regular expression) with aReplaceString, where $0 references the whole match, and $1..$9 the matched groups.
	Central method of the regex based refactoring. To be used in collaboration with renameClasses and others
	
	RBClassRegexRefactoring new
		model: model;
		renameClasses;
		replace: '^YK(.*)$' with: newClassPrefix,'$1';
 		 execute.
	Check class comment for a full script. 
	"
	self replace: aFindString with: aReplaceString ignoreCase: false! !

!RBRegexRefactoring methodsFor: 'private' stamp: ''!
execute: aString
	"Perform all searches on aString and return the transformation."
	
	^ matchers 
		inject: aString asString
		into: [ :string :assoc | self execute: string replace: assoc key with: assoc value ]! !

!RBRegexRefactoring methodsFor: 'searching' stamp: ''!
replace: aFindString with: aReplaceString ignoreCase: aBoolean
	"Replace all matches of aFindString (regular expression) with aReplaceString, where $0 references the whole match, and $1..$9 the matched groups. See replace:with: comment too."
	
	| regex stream |
	regex := RxParser preferredMatcherClass
		for: (RxParser new parse: aFindString)
		ignoreCase: aBoolean.
	stream := aReplaceString readStream.
	matchers add: regex -> stream! !

!RBRegexRefactoring methodsFor: 'private' stamp: ''!
execute: aString replace: aRegex with: aReadStream
	| stream |
	^ aRegex copy: aString translatingMatchesUsing: [ :match |
		stream := WriteStream on: (String new: 2 * aString size).
		[ aReadStream atEnd ] whileFalse: [
			stream nextPutAll: (aReadStream upTo: $$).
			aReadStream atEnd ifFalse: [
				aReadStream peek isDigit
					ifFalse: [ stream nextPut: aReadStream next ]
					ifTrue: [ stream nextPutAll: (aRegex subexpression: aReadStream next asInteger - $0 asInteger + 1) ] ] ].
		aReadStream reset.
		stream contents ]! !

!RBRegexRefactoring class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBRegexRefactoring! !

!RBRemoveAllSendersParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #removeSendersOf:! !

!RBRemoveAllSendersParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveMessageInsideBlock
	| refactoring methodName |
	methodName := ('caller', '2') asSymbol.
	refactoring := self createRefactoringWithArguments: { methodName }.
	self setupInlineExpressionFor: refactoring toReturn: false.
	self proceedThroughWarning: [self executeRefactoring: refactoring ].
	"remove 2 senders"
	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #multipleCalls) equals: (self parseMethod: 'multipleCalls').
	"it doesn't remove the sender, because its result is used"
	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineLast) equals: (self parseMethod: 'inlineLast
	5 = 3 ifTrue: [^self caller] ifFalse: [^self caller2]').
	! !

!RBRemoveAllSendersParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRemoveAllSendersRefactoring };
		yourself! !

!RBRemoveAllSendersRefactoring commentStamp: ''!
I am a refactoring to remove all possible senders from a method (you cannot remove those calls where the result of the method call is used or when the method name symbol is referenced).

Example Script
----------------
```
| refactoring options |
refactoring := RBRemoveSenderRefactoring 
			remove: (90 to: 105) "node position to be removed "
			inMethod: #caller1
			forClass: RBRefactoryTestDataApp.
options := refactoring options copy.
options at: #inlineExpression put: [:ref :string | false].
refactoring options: options.
refactoring execute.
```
Before refactoring:
```
RBRefactoryTestDataApp >> caller1
	| anObject |
	anObject := 5.
	self called: anObject + 1
		on1: 
			[:each | 
			each printString.
			^anObject]
```
After refactoring (notice that the call to printstring was removed):
```
RBRefactoryTestDataApp >> caller1
	| anObject |
	anObject := 5.
	self called: anObject + 1
		on1: 
			[:each | 
			^anObject]
```!
!RBRemoveAllSendersRefactoring methodsFor: 'removing' stamp: ''!
removeMethod: aMethod of: node
	self performCompositeRefactoring: (RBRemoveSenderRefactoring
		model: self model
		remove: node sourceInterval
		inMethod: aMethod selector
		forClass: aMethod methodClass)! !

!RBRemoveAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self removeSelfSenders! !

!RBRemoveAllSendersRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^ self emptyCondition! !

!RBRemoveAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
selfSendIn: aTree
	| searcher nodes |
	nodes := OrderedCollection new.
	searcher := self parseTreeSearcher.
	searcher
		matches: self messagePattern
		do: [ :aNode :answer | nodes add: aNode ].
	searcher executeTree: aTree initialAnswer: {}.
	^ nodes! !

!RBRemoveAllSendersRefactoring methodsFor: 'removing' stamp: ''!
removeSendersOf: aSelector
	selector := aSelector.! !

!RBRemoveAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
messagePattern
	^ 'self ' , (self buildSelectorString: selector)! !

!RBRemoveAllSendersRefactoring methodsFor: 'transforming' stamp: ''!
removeSelfSenders
	| flag |
	flag := false.
	(self model allReferencesTo: selector) do: [ :e | | node index |
		index := 1.
		[ node := self selfSendIn: (e methodClass parseTreeFor: e selector). node size < index ] 
			whileFalse: [ 
				self onError: [ self removeMethod: e of: (node at: index) ]
					do: [ flag ifFalse: [ flag := true.
							self refactoringWarning: 
						'There are one or more senders that cannot be removed, <n>because their result is used or have direct references to method'' name. <n>Proceed anyway? '.].
						index := index + 1] ].
				].! !

!RBRemoveAllSendersRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' removeSendersOf: '.
	aStream nextPutAll: selector.
	aStream nextPut: $)! !

!RBRemoveAllSendersRefactoring class methodsFor: 'removing' stamp: ''!
model: aModel removeSendersOf: aSelector
	^ self new
		model: aModel;
		removeSendersOf: aSelector! !

!RBRemoveAllSendersRefactoring class methodsFor: 'removing' stamp: ''!
removeSendersOf: aSelector
	^ self new
		removeSendersOf: aSelector! !

!RBRemoveAssignmentTransformation commentStamp: ''!
I am responsible for removing an assignment statement inside a method. In this implementation, the variable name and the expression value must be described separately.

Usage:
| transformation |
transformation := (RBRemoveAssignmentTransformation
				variable: 'variable'
				value: '1 asString'
				inMethod: #methodBefore
				inClass: #RBRemoveAssignmentTransformationTest)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- there is an assignment to the given variable.

Observations about the transformation:
-  If the method has more than one assignment to the given variable, the transformation will remove the assignment that is more similar to the specified value, in terms of AST nodes.!
!RBRemoveAssignmentTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ (RBCondition
			withBlock: [ self definingClass isNotNil ]
			errorString: ('Class named <1s> does not exist' expandMacrosWith: className))
		& (RBCondition
			withBlock: [ self definingClass canUnderstand: selector ]
			errorString: ('Method named <1s> does not exist' expandMacrosWith: selector))
		& (RBCondition
			withBlock: [ (self definingMethod allChildren
				select: #isVariable thenCollect: #name)
				anySatisfy: [ :e | e asString = variableName ] ]
			errorString: ('Method named <1s> does not have an assignment for variable named <2s>'
				expandMacrosWith: selector with: variableName))
		& (RBCondition
			withBlock: [ (self definingMethod allChildren
				select: #isAssignment thenCollect: #variable)
				anySatisfy: [ :e | e name asString = variableName ] ]
			errorString: ('Method named <1s> does not have an assignment for variable named <2s>'
				expandMacrosWith: selector with: variableName))! !

!RBRemoveAssignmentTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName value: anExpression inMethod: aSelector inClass: aClassName

	self className: aClassName.
	selector := aSelector.
	variableName := aVariableName.
	value := anExpression! !

!RBRemoveAssignmentTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' variable: ''';
		nextPutAll: variableName;
		nextPutAll: ' value: ''';
		nextPutAll: value;
		nextPutAll: ' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: ''';
		nextPutAll: className.
	aStream nextPut: $)! !

!RBRemoveAssignmentTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	| methodTree valueNode assignments nodeToRemove |
	methodTree := self definingMethod.
	assignments := (methodTree allChildren select: #isAssignment)
		select: [ :each | each variable name asString = variableName ].
	nodeToRemove := assignments size = 1
		ifTrue: [ assignments first ]
		ifFalse: [ valueNode := self parserClass parseExpression: value.
			assignments
				detectMax: [ :node | 
					((node allChildren collect: [:each | each class])
						intersection: (valueNode allChildren collect: [:each | each class])) size ] ].
	nodeToRemove parent removeNode: nodeToRemove.
	class compileTree: methodTree! !

!RBRemoveAssignmentTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel variable: aVariableName value: anExpression inMethod: aSelector inClass: aClassName

	^ self new
		model: aRBModel;
		variable: aVariableName
		value: anExpression
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBRemoveAssignmentTransformation class methodsFor: 'api' stamp: ''!
variable: aVariableName value: anExpression inMethod: aSelector inClass: aClassName

	^ self new
		variable: aVariableName
		value: anExpression
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBRemoveAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testAssignmentDoesNotExist

	| refactoring |
	refactoring := (RBAddTemporaryVariableTransformation 
						variable: 'variable2'
						inMethod: #methodBefore
						inClass: #RBRemoveAssignmentTransformationTest)
						asRefactoring transform.

	self shouldFail: (RBRemoveAssignmentTransformation 
							model: refactoring model
							variable: 'variable2'
							value: '1 asString'
							inMethod: #methodBefore
							inClass: #RBRemoveAssignmentTransformationTest)
							asRefactoring ! !

!RBRemoveAssignmentTransformationTest methodsFor: 'utilities' stamp: ''!
methodAfter

	| variable |
	variable := 'String'.! !

!RBRemoveAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBRemoveAssignmentTransformation
						variable: 'variable'
						value: '1 asString'
						inMethod: #methodBefore
						inClass: #RBRemoveAssignmentTransformationTest)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 1.
	
	class := refactoring model classNamed: #RBRemoveAssignmentTransformationTest.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBRemoveAssignmentTransformationTest methodsFor: 'utilities' stamp: ''!
methodBefore

	| variable |
	variable := 'String'.
	variable := 1 asString.! !

!RBRemoveAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBRemoveAssignmentTransformation new
		variable: 'variable'
		value: '1 asString'
		inMethod: #methodBefore
		inClass: self class name)
		transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self class name.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBRemoveAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBRemoveAssignmentTransformation 
							variable: 'variable'
							value: '1 asString'
							inMethod: #method
							inClass: #RBRemoveAssignmentTransformationTest)
							asRefactoring ! !

!RBRemoveAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testClassDoesNotExist

	self shouldFail: (RBRemoveAssignmentTransformation 
							variable: 'variable'
							value: '1 asString'
							inMethod: #methodBefore
							inClass: #RBAssignmentTransformationTest)
							asRefactoring ! !

!RBRemoveAssignmentTransformationTest methodsFor: 'tests' stamp: ''!
testVariableDoesNotExist

	self shouldFail: (RBRemoveAssignmentTransformation
							variable: 'variable1'
							value: '1 asString'
							inMethod: #methodBefore
							inClass: #RBRemoveAssignmentTransformationTest)
							asRefactoring! !

!RBRemoveClassChange commentStamp: ''!
I am a class refactoring change for removing a class. On execution, my class will be removed from the system (all globals).!
!RBRemoveClassChange methodsFor: 'printing' stamp: ''!
initialize

	super initialize.
	changeFactory := RBRefactoryChangeManager changeFactory! !

!RBRemoveClassChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	| classChanges |
	classChanges := changeFactory compositeRefactoryChange.
	self changeClass withAllSubclasses do: [ :each | 
		classChanges defineClass: each oldDefinition.
		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: 'accessing' stamp: ''!
changeClass: aBehavior

	super changeClass: aBehavior.
	isMeta := false! !

!RBRemoveClassChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self displayClassName;
		nextPutAll: ' removeFromSystem';
		nextPut: $!!! !

!RBRemoveClassChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Remove ' , self displayClassName! !

!RBRemoveClassChange methodsFor: 'private' stamp: ''!
primitiveExecute

	self changeClass removeFromSystem! !

!RBRemoveClassChange class methodsFor: 'instance creation' stamp: ''!
removeClassName: aSymbol

	^ self basicNew
		  onSystemDictionary: self environment;
		  changeClassName: aSymbol;
		  initialize! !

!RBRemoveClassChange class methodsFor: 'instance creation' stamp: ''!
remove: aClass

	^ self new changeClass: aClass! !

!RBRemoveClassKeepingSubclassesParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveNotEmptySuperclass

	| refactoring class removedClass subclass |
	
	removedClass := ('RBTransformation' , 'RuleTestData1') asSymbol.
	subclass := ('RBTransformation' , 'RuleTestData2') asSymbol.
	refactoring := self createRefactoringWithArguments: { {removedClass} }. 
	class := refactoring model classNamed: subclass.
	self deny: (class directlyDefinesMethod: #foo).
	
	self executeRefactoring: refactoring.
	
	self assert: (refactoring model classNamed: removedClass) isNil.
	self assert: class superclass
		equals: (refactoring model classNamed: #RBFooLintRuleTestData1).
	self assert: (class directlyDefinesMethod: #foo)! !

!RBRemoveClassKeepingSubclassesParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRemoveClassWithReferencesRaisesRBRefactoringError
	self shouldFail: (self createRefactoringWithArguments:
		{#(#RBBasicLintRuleTestData )})! !

!RBRemoveClassKeepingSubclassesParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #classNames:! !

!RBRemoveClassKeepingSubclassesParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRemoveClassKeepingSubclassesRefactoring };
		yourself! !

!RBRemoveClassKeepingSubclassesRefactoring commentStamp: ''!
I am a refactoring for removing classes but keeping subclasses in a safe way. 

My precondition verifies that the class name exists in this namespace and the class has no references, resp. users, if this is used to remove a trait.

If this class is "not empty" (has methods and variables), any subclass is reparented to the superclass of this class, and all its methods and variables (instance and class) are push down in its subclasses.

Example
--------
```
(RBRemoveClassKeepingSubclassesRefactoring classNames: { #RBTransformationRuleTestData1 }) execute. 
```
!
!RBRemoveClassKeepingSubclassesRefactoring methodsFor: 'preconditions' stamp: ''!
transform
	self initalizeRefactorings.
	refactorings do: [ :ref | ref primitiveExecute ].
	self reparentSubclasses.
	self removeClasses	! !

!RBRemoveClassKeepingSubclassesRefactoring methodsFor: 'preconditions' stamp: ''!
initalizeRefactorings
	
	classNames do: 
			[:each | 
			| class |
			class := self model classNamed: each.
			self pushDownMethodsOf: class. 
			self pushDownInstVarsOf: class.
			self pushDownClassVarsOf: class]! !

!RBRemoveClassKeepingSubclassesRefactoring methodsFor: 'preconditions' stamp: ''!
initialize
	refactorings := OrderedCollection new! !

!RBRemoveClassKeepingSubclassesRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ classNames inject: self emptyCondition into: [ :sum :each | 
		  | aClassOrTrait |
		  aClassOrTrait := self model classNamed: each asSymbol.
		  aClassOrTrait ifNil: [ 
			  self refactoringFailure: 'No such class or trait' ].
		  sum & ((self preconditionIsNotMetaclass: aClassOrTrait)
		   & (self preconditionHasNoReferences: each)
		   & (self preconditionHasNoUsers: aClassOrTrait))
		  "& ( self preconditionEmptyOrHasNoSubclasses: aClassOrTrait )" ]! !

!RBRemoveClassKeepingSubclassesRefactoring methodsFor: 'preconditions' stamp: ''!
pushDownClassVarsOf: class
	class realClass classVariables do: [ :e |
		refactorings add: (RBPushDownClassVariableRefactoring 
		variable: e key
		class: class).
	]! !

!RBRemoveClassKeepingSubclassesRefactoring methodsFor: 'preconditions' stamp: ''!
pushDownInstVarsOf: class
	class realClass instVarNames
		do: [ :e | 
			refactorings
				add:
					(RBPushDownInstanceVariableRefactoring
						variable: e asString
						class: class) ]! !

!RBRemoveClassKeepingSubclassesRefactoring methodsFor: 'preconditions' stamp: ''!
pushDownMethodsOf: class
	refactorings add: (RBPushDownMethodRefactoring pushDown: class realClass selectors from: class)! !

!RBRemoveClassKeepingSubclassesRefactoring methodsFor: 'preconditions' stamp: ''!
removeClasses
	classNames do: [:each | self model removeClassKeepingSubclassesNamed: each]! !

!RBRemoveClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRemoveClassWithBadNameRaisesRBRefactoringError 
	self shouldFail: (self createRefactoringWithModel: model 
		andArguments: #(#RecursiveSelfRule))! !

!RBRemoveClassParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveClassesWithReferencesBetweenThem
	|aRefactoringColl|
	aRefactoringColl := self createRefactoringWithModel: model 
		andArguments: { #RBSharedPoolForTestData2 . #RBRemoveClassParametrizedTest }.
	
	self executeRefactorings: aRefactoringColl.
	
	self assert: (model classNamed: #RBRemoveClassParametrizedTest) isNil.
	self assert: (model classNamed: #RBSharedPoolForTestData2) isNil.! !

!RBRemoveClassParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveEmptySuperclass
	| aRefactoringColl classA classB classC |
	
	classA := ('RBFoo' , 'LintRuleTestData1') asSymbol.
	classB := ('RBTransformation' , 'RuleTestData1') asSymbol.
	classC := #RBLintRuleTestData.
	aRefactoringColl := self createRefactoringWithModel: model 
		andArguments: {classA}.
		
	self executeRefactorings: aRefactoringColl.
	
	self assert: (model classNamed: classA) isNil.
	self assert: (model classNamed: classB) superclass equals: (model classNamed: classC)! !

!RBRemoveClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRaisesRBRefactoringErrorWhenRemovingNonEmptySuperclass
	|class|
	class := ('RBTransformation', 'RuleTestData1') asSymbol.
	self shouldFail: (self createRefactoringWithModel: model 
		andArguments: {class} ).! !

!RBRemoveClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRemoveClassWithSubclasses

	self shouldFail: 
		(self createRefactoringWithArguments: {#RBFooLintRuleTestData1})! !

!RBRemoveClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRemoveClassWithReferencesRaisesRBRefactoringError
	self shouldFail: (self createRefactoringWithModel: model 
		andArguments: #(#RBBasicLintRuleTestData ))! !

!RBRemoveClassParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveAClassAndTheirSubclass
	|aRefactoringColl|
	
	aRefactoringColl := self createRefactoringWithModel: model 
		andArguments: {#RBSharedPoolForTestData2 . #RBSharedPoolForTestData1 }.
		
	self executeRefactorings: aRefactoringColl.
	
	self assert: (model classNamed: #RBSharedPoolForTestData2) isNil.
	self assert: (model classNamed: #RBSharedPoolForTestData1) isNil.! !

!RBRemoveClassParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	self flag:'some tests of transformation are broken'.
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRemoveClassRefactoring .
					  #constructor -> #classNames: .
					  #isComposed -> true};
		"addCase: { #rbClass -> RBRemoveClassTransformation .
					  #constructor -> #className: .
					  #isComposed -> false};	"
		yourself! !

!RBRemoveClassRefactoring commentStamp: ''!
I am a refactoring for removing classes. 

My precondition verifies that the class name exists in this namespace and the class has no references, resp. users, if this is used to remove a trait.

If this class is "empty" (has no methods and no variables), any subclass is reparented to the superclass of this class. It is not allowed to remove non-empty classes when it has subclasses.!
!RBRemoveClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditionIsNotMetaclass: aClass
	^ ((RBCondition isMetaclass: aClass) errorMacro: 'Cannot remove just the metaclass') not! !

!RBRemoveClassRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self
		reparentSubclasses;
		removeClasses! !

!RBRemoveClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ classNames inject: self emptyCondition into: [ :sum :each | 
		  | aClassOrTrait |
		  aClassOrTrait := self model classNamed: each asSymbol.
		  aClassOrTrait ifNil: [ 
			  self refactoringFailure: 'No such class or trait' ].
		  sum & ((self preconditionIsNotMetaclass: aClassOrTrait)
		   & (self preconditionHasNoReferences: each)
		   & (self preconditionEmptyOrHasNoSubclasses: aClassOrTrait)
		   & (self preconditionHasNoUsers: aClassOrTrait)) ]! !

!RBRemoveClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditionEmptyOrHasNoSubclasses: aClass
	^ (RBCondition hasSubclasses: aClass excluding: classNames) not
		|
			((RBCondition isEmptyClass: aClass)
				&
					((RBCondition withBlock: [ aClass superclass notNil ])
						errorMacro: 'Cannot remove top level class<n>when it has subclasses';
						yourself))! !

!RBRemoveClassRefactoring methodsFor: 'preconditions' stamp: ''!
environmentWithReferencesTo: aClass
	^ RBBrowserEnvironment new 
		referencesTo: (Smalltalk globals 
			associationAt: aClass 
			ifAbsent: [ aClass ])! !

!RBRemoveClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditionHasNoUsers: aClassOrTrait
	^ (RBCondition withBlock: [ (aClassOrTrait realClass users copyWithoutAll: classNames) isEmpty ])
		errorMacro: aClassOrTrait name , ' Trait is used.<n>Browse classes using it?';
		errorBlock: [ self openBrowserOn: (self environmentWithUsersOf: aClassOrTrait) ];
		yourself! !

!RBRemoveClassRefactoring methodsFor: 'transforming' stamp: ''!
reparentSubclasses
	classNames do: 
			[:each | 
			| class |
			class := self model classNamed: each.
			self model reparentClasses: class subclasses copy to: class superclass]! !

!RBRemoveClassRefactoring methodsFor: 'initialization' stamp: ''!
classNames: aClassNameCollection 
	classNames := aClassNameCollection! !

!RBRemoveClassRefactoring methodsFor: 'transforming' stamp: ''!
removeClasses
	classNames do: [:each | self model removeClassNamed: each]! !

!RBRemoveClassRefactoring methodsFor: 'preconditions' stamp: ''!
environmentWithUsersOf: aTrait
	^ RBClassEnvironment 
		onEnvironment: RBBrowserEnvironment new
		classes: aTrait realClass users! !

!RBRemoveClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditionHasNoReferences: aClass

	| env |
	env := self environmentWithReferencesTo: aClass.
	^ (RBCondition withBlock: [ (env classNames copyWithoutAll: classNames) isEmpty ])
			errorMacro: aClass , ' is referenced.<n>Browse references?';
			errorBlock: [ self openBrowserOn: (env) ];
			yourself! !

!RBRemoveClassRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' classNames: '.
	classNames asArray storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveClassRefactoring class methodsFor: 'instance creation' stamp: ''!
classNames: aClassNameCollection 
	^ self new
		classNames: aClassNameCollection! !

!RBRemoveClassRefactoring class methodsFor: 'error messages' stamp: ''!
cannotRemoveTopLevelClassErrorMesssage

	^ 'Cannot remove top level class' , String cr
	  , 'when it has subclasses'! !

!RBRemoveClassRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk classNames: aClassNameCollection 
	^ self new
		model: aRBSmalltalk;
		classNames: aClassNameCollection;
		yourself! !

!RBRemoveClassTransformation commentStamp: ''!
Removes a class from the image.

Usage:
| transformation |
transformation := (RBRemoveClassTransformation
	className: #RBRemoveClassTransformationTest)
	transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- class must exist
- class to be removed should not be referenced
- class to be removed must not have subclasses
- if it is a trait, it should not be used
!
!RBRemoveClassTransformation methodsFor: 'preconditions' stamp: ''!
preconditionIsNotMetaclass: aClass

	^ ((RBCondition isMetaclass: aClass)
		errorMacro: 'Cannot remove just the metaclass') not! !

!RBRemoveClassTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ className inject: RBCondition empty into: [ :cond :aClass |
		| aClassOrTrait |
		aClassOrTrait := self model classNamed: className asSymbol.
		aClassOrTrait ifNil: [ self
			refactoringError: 'No such class or trait named ', className ].
		
		cond 
			& ( (self preconditionIsNotMetaclass: aClassOrTrait) 
			& (self preconditionHasNoReferences: className)
			& (self preconditionHasNoSubclasses: aClassOrTrait)
			& (self preconditionHasNoUsers: aClassOrTrait ) ) ]! !

!RBRemoveClassTransformation methodsFor: 'private' stamp: ''!
reparentSubclasses

	self model 
		reparentClasses: self definingClass subclasses copy 
		to: self definingClass superclass! !

!RBRemoveClassTransformation methodsFor: 'preconditions' stamp: ''!
environmentWithReferencesTo: aClass

	^ RBBrowserEnvironment new 
		referencesTo: (self environment 
			associationAt: aClass 
			ifAbsent: [ aClass ])! !

!RBRemoveClassTransformation methodsFor: 'preconditions' stamp: ''!
preconditionHasNoUsers: aClassOrTrait

	^ (RBCondition withBlock: [ aClassOrTrait realClass users isEmpty ])
		errorMacro: aClassOrTrait name , ' Trait is used.<n>Browse classes using it?';
		errorBlock: [ self openBrowserOn: (self environmentWithUsersOf: aClassOrTrait) ];
		yourself! !

!RBRemoveClassTransformation methodsFor: 'preconditions' stamp: ''!
preconditionHasNoSubclasses: aClass

	^ (RBCondition withBlock: [ aClass subclasses isEmpty ])
		errorMacro: self class cannotRemoveTopLevelClassErrorMesssage;
		yourself! !

!RBRemoveClassTransformation methodsFor: 'preconditions' stamp: ''!
environmentWithUsersOf: aTrait

	^ RBClassEnvironment 
		onEnvironment: RBBrowserEnvironment new
		classes: aTrait realClass users! !

!RBRemoveClassTransformation methodsFor: 'preconditions' stamp: ''!
preconditionHasNoReferences: aClass

	| env |
	env := self environmentWithReferencesTo: aClass.
	^ (RBCondition withBlock: [ env isEmpty ])
		errorMacro: aClass , ' is referenced.<n>Browse references?';
		errorBlock: [ self openBrowserOn: (env) ];
		yourself! !

!RBRemoveClassTransformation methodsFor: 'private' stamp: ''!
removeClass

	self model removeClassNamed: className! !

!RBRemoveClassTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self
		reparentSubclasses;
		removeClass! !

!RBRemoveClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' className: '.
	className storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveClassTransformation class methodsFor: 'api' stamp: ''!
classNames: aCollection

	^ self 
		model: RBTransformation new model
		classNames: aCollection! !

!RBRemoveClassTransformation class methodsFor: 'api' stamp: ''!
className: aClassName

	^ self new
		className: aClassName;
		yourself! !

!RBRemoveClassTransformation class methodsFor: 'api' stamp: ''!
model: aRBSmalltalk className: aClassName

	^ self new
		model: aRBSmalltalk;
		className: aClassName;
		yourself! !

!RBRemoveClassTransformation class methodsFor: 'private' stamp: ''!
cannotRemoveTopLevelClassErrorMesssage

	^ 'Cannot remove top level class' , String cr
	  , 'when it has subclasses'! !

!RBRemoveClassTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel classNames: aCollection

	^ RBCompositeTransformation new
		transformations: (aCollection
			collect: [ :e | self model: aRBModel className: e ]);
		yourself! !

!RBRemoveClassTransformationTest methodsFor: 'private' stamp: ''!
resumeIfCannotRemove: error

	^ error messageText = RBRemoveClassTransformation
		cannotRemoveTopLevelClassErrorMesssage
		ifTrue: [ error resume ]! !

!RBRemoveClassTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring
	| refactoring |
	refactoring := (RBRemoveClassTransformation className: #RBFooDummyLintRuleTest1) 
	asRefactoring.

	[ refactoring transform ]
		on: RBRefactoringError
		do: [ :error | self resumeIfCannotRemove: error ].

	self assert: (refactoring model classNamed: #RBFooDummyLintRuleTest1) isNil.
	self assert: (refactoring model classNamed: 'RBTransformationDummyRuleTest1' asSymbol) superclass equals: (refactoring model classNamed: #RBDummyLintRuleTest)! !

!RBRemoveClassTransformationTest class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit
	^20 seconds! !

!RBRemoveClassVariableChange commentStamp: ''!
I am a refactoring for removing a class variable. My changes are executed on the instance side.!
!RBRemoveClassVariableChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ changeFactory addClassVariable: self variable to: self changeClass! !

!RBRemoveClassVariableChange methodsFor: 'accessing' stamp: ''!
changeClass: aBehavior

	super changeClass: aBehavior.
	isMeta := false! !

!RBRemoveClassVariableChange methodsFor: 'private' stamp: ''!
changeSymbol

	^ #removeClassVarNamed:! !

!RBRemoveClassVariableChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Remove class variable <1s> from <2s>'
		  expandMacrosWith: self variable
		  with: self displayClassName! !

!RBRemoveClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	self shouldFail: (self createRefactoringWithArguments: 
		{#RecursiveSelfRule1 . #RBTransformationRuleTestData})! !

!RBRemoveClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testReferencedVariable
	self shouldFail: (self createRefactoringWithArguments:
		{ #RecursiveSelfRule . #RBTransformationRuleTestData }).! !

!RBRemoveClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveClassVariable
	| refactoring class |
	refactoring :=  self createRefactoringWithArguments: 
		{'Foo1' . #RBLintRuleTestData}.
	class := refactoring model classNamed: #RBLintRuleTestData.
	self assert: (class definesClassVariable: 'Foo1').
	
	self executeRefactoring: refactoring.
	
	self deny: (class definesClassVariable: 'Foo1')! !

!RBRemoveClassVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRemoveClassVariableRefactoring .
					  #constructor -> #variable:class: };
		addCase: { #rbClass -> RBRemoveVariableTransformation .
					  #constructor -> #classVariable:class: };
		yourself! !

!RBRemoveClassVariableRefactoring commentStamp: ''!
I am a refactoring for removing class variables.

My precondition verifies that there is no reference to this class variable.!
!RBRemoveClassVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	class removeClassVariable: variableName! !

!RBRemoveClassVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ ( RBCondition isMetaclass: class ) not
		& ( RBCondition definesClassVariable: variableName in: class )
		&
			( RBCondition
				withBlock: [ | block |

					block := [ :each | 
					( each whichSelectorsReferToClassVariable: variableName ) isEmpty
						ifFalse: [ class realClass
								ifNil: [ self refactoringError: ( '<1s> is referenced.' expandMacrosWith: variableName ) ]
								ifNotNil: [ self
										refactoringError: ( '<1s> is referenced.<n>Browse references?' expandMacrosWith: variableName )
										with: [ self
												openBrowserOn:
													( RBVariableEnvironment referencesToClassVariable: variableName in: class realClass )
											]
									]
							]
					].
					class withAllSubclasses do: block.
					class classSide withAllSubclasses do: block.
					true
					] )! !

!RBRemoveDirectAccessToVariableTransformation commentStamp: ''!
Replaces all the direct accesses to this variable in this class by invocation to this variable's getter and setter. It assumes that both getter and setter are implemented in the class.

Usage:
transformation := (RBRemoveDirectAccessToVariableTransformation
	instanceVariable: 'environment'
	class: #RBNamespace)
	transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the class must exist
- the class defines a variable with the given name
- the class defines both getter and setter for this variable
!
!RBRemoveDirectAccessToVariableTransformation methodsFor: 'private' stamp: ''!
replaceInstanceAccesses

	| replacer includeGettersAndSetters |
	includeGettersAndSetters := receiver isNotNil.
	replacer := self parseTreeRewriterClass  
				variable: variableName
				getter: self getterMethod
				setter: self setterMethod
				receiver: self receiver.	
	
	self model
		convertClasses: self definingClass withAllSubclasses
		select: [ :aClass | 
			| allReferences |
			allReferences := aClass whichSelectorsReferToInstanceVariable: variableName.
			includeGettersAndSetters
				ifTrue: [ allReferences ]
				ifFalse: [ allReferences
					reject: [ :each | 
						aClass == self definingClass
						and: [ each == self getterMethod
						or: [ each == self setterMethod ] ] ] ] ]
		using: replacer! !

!RBRemoveDirectAccessToVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	class := self model classObjectFor: className.

	^ (isClassVariable
		ifTrue: [ (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')]
		ifFalse: [ (RBCondition directlyDefinesInstanceVariable: variableName in: class) ])
		& (RBCondition canUnderstand: self getterMethod in: self definingClass)
		& (RBCondition canUnderstand: self setterMethod in: self definingClass)
		! !

!RBRemoveDirectAccessToVariableTransformation methodsFor: 'private' stamp: ''!
receiver

	^ receiver ifNil: [ self receiver: 'self'. receiver ]! !

!RBRemoveDirectAccessToVariableTransformation methodsFor: 'private' stamp: ''!
replaceClassAccesses
	| replacer |
	"replace accesses in the metaclass"
	replacer := self parseTreeRewriterClass
		variable: variableName
		getter: self getterMethod
		setter: self setterMethod
		receiver: self receiver.
	self model
		convertClasses: self definingClass theMetaClass withAllSubclasses
		select: [ :aClass | 
			(aClass whichSelectorsReferToClassVariable: variableName)
				reject: [ :each | 
					aClass == self definingClass theMetaClass
						and: [ each == self getterMethod or: [ each == self setterMethod ] ] ] ]
		using: replacer.

	"replace accessed in the class"
	replacer := self parseTreeRewriterClass
		variable: variableName
		getter: 'class ' , self getterMethod
		setter: 'class ' , self setterMethod.
	self model
		convertClasses: self definingClass theNonMetaClass withAllSubclasses
		select: [ :aClass | aClass whichSelectorsReferToClassVariable: variableName ]
		using: replacer! !

!RBRemoveDirectAccessToVariableTransformation methodsFor: 'private' stamp: ''!
receiver: aString

	receiver := aString! !

!RBRemoveDirectAccessToVariableTransformation methodsFor: 'private' stamp: ''!
setterMethod

	^ setterMethod ifNil: [ 
		setterMethod := (self definingClass setterMethodFor: variableName)
			ifNil: [ 	(variableName uncapitalized, ':') asSymbol ] ]! !

!RBRemoveDirectAccessToVariableTransformation methodsFor: 'private' stamp: ''!
getterMethod

	^ getterMethod ifNil: [ 
		getterMethod := (self definingClass getterMethodFor: variableName)
			ifNil: [ variableName uncapitalized asSymbol ] ]! !

!RBRemoveDirectAccessToVariableTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	
	self replaceInstanceAccesses.
	isClassVariable ifTrue: [ self replaceClassAccesses ].! !

!RBRemoveDirectAccessToVariableTransformationTest methodsFor: 'tests' stamp: ''!
testDoesNotDefineVariable

	self
		shouldFail: (RBRemoveDirectAccessToVariableTransformation 
						model: model
						instanceVariable: 'instVarName1'
						class: #Bar)
						asRefactoring;
		shouldFail: (RBRemoveDirectAccessToVariableTransformation 
						classVariable: 'Foo1'
						class: #RBFooLintRuleTestData)
						asRefactoring ! !

!RBRemoveDirectAccessToVariableTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBRemoveDirectAccessToVariableTransformation 
						instanceVariable: 'environment'
						class: #RBNamespace)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 4.

	class := refactoring model classNamed: #RBNamespace.
	self assert: (class parseTreeFor: #includesGlobal:)
		equals: (self parseMethod: 'includesGlobal: aSymbol 
			(self hasRemoved: aSymbol) ifTrue: [^false].
			(self includesClassNamed: aSymbol) ifTrue: [^true].
			self environment at: aSymbol ifAbsent: [^false].
			^ true').
	self assert: (class parseTreeFor: #initialize) 
		equals: (self parseMethod: 'initialize
	super initialize.
	changes := changeFactory compositeRefactoryChange onSystemDictionary: self environment.
	newClasses := IdentityDictionary new.
	newPackages := IdentityDictionary new.
	changedClasses := IdentityDictionary new.
	changedPackages := IdentityDictionary new.
	removedClasses := Set new.
	removedPackages := Set new.
	implementorsCache := IdentityDictionary new.
	sendersCache := IdentityDictionary new')! !

!RBRemoveDirectAccessToVariableTransformationTest methodsFor: 'tests' stamp: ''!
testDoesNotUnderstandAccessors

	self
		shouldFail: (RBRemoveDirectAccessToVariableTransformation 
						model: model
						instanceVariable: 'instVarName1'
						class: #Foo)
						asRefactoring;
		shouldFail: (RBRemoveDirectAccessToVariableTransformation 
						classVariable: 'RecursiveSelfRule'
						class: #RBTransformationRuleTestData)
						asRefactoring ! !

!RBRemoveDirectAccessToVariableTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBRemoveDirectAccessToVariableTransformation
							instanceVariable: 'class'
							class: #RBTransformationRuleTestData)
							transform.
	
	class := transformation model classNamed: #RBTransformationRuleTestData.
	self assert: (class parseTreeFor: #superSends)
		  equals: (self parseMethod: 
	'superSends
		| rule |
		rule := RBParseTreeRewriter new.
		rule addSearch: ''super `@message: ``@args'' 
			-> (
				[:aNode | 
				(self class withAllSubclasses 
					detect: [:each | each includesSelector: aNode selector]
					ifNone: [nil]) isNil] 
						-> ''self `@message: ``@args'').
		self rewriteUsing: rule').
	
	self assert: (class parseTreeFor: #checkMethod:)
		  equals: (self 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 class
					classified: aSmalllintContext protocols]]')! !

!RBRemoveDirectAccessToVariableTransformationTest methodsFor: 'tests' stamp: ''!
testClassVariable

	| refactoring class |
	refactoring := (RBRemoveDirectAccessToVariableTransformation
						classVariable: 'UndoSize'
						class: #RBRefactoryChangeManager)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 2.
	
	class := (refactoring model classNamed: #RBRefactoryChangeManager) theMetaClass.
	self assert: (class parseTreeFor: #initialize) 
			equals: (self parseMethod: 'initialize self nuke. self undoSize: 20').
	self assert: (class theNonMetaClass parseTreeFor: #addUndo:) 
			equals: (self parseMethod: 'addUndo: aRefactoringChange
				undo push: aRefactoringChange.
				undo size > self class undoSize
					ifTrue: [ undo removeFirst ].
				redo := OrderedCollection new')! !

!RBRemoveDirectAccessToVariableTransformationTest methodsFor: 'tests' stamp: ''!
testInstanceVariable

	| class |
	(RBRemoveDirectAccessToVariableTransformation 
		model: model
		instanceVariable: 'instVarName2'
		class: #Foo)
		asRefactoring transform.
	
	class := model classNamed: #Foo.
	self assert: (class parseTreeFor: #foo) 
			equals: (self parseMethod: 'foo ^ self instVarName2: 3')! !

!RBRemoveDirectAccessToVariableTransformationTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	model := self abstractVariableTestData.! !

!RBRemoveHierarchyMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRemoveReferenced
	self shouldFail: (self createRefactoringWithArguments: { #(#msg1) . RBBasicLintRuleTestData })! !

!RBRemoveHierarchyMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveMethod
	| refactoring selectors |
	selectors := Array with: 'msg4' asSymbol.
	refactoring := self createRefactoringWithArguments: { selectors . RBSharedPoolForTestData }.
	self assert: ((refactoring model classNamed: #RBSharedPoolForTestData) directlyDefinesMethod: selectors first).
	self assert: ((refactoring model classNamed: #RBSharedPoolForTestData1) directlyDefinesMethod: selectors first).
	self assert: ((refactoring model classNamed: #RBSharedPoolForTestData2) directlyDefinesMethod: selectors first).
	self executeRefactoring: refactoring.
	self deny: ((refactoring model classNamed: #RBSharedPoolForTestData) directlyDefinesMethod: selectors first).
	self deny: ((refactoring model classNamed: #RBSharedPoolForTestData1) directlyDefinesMethod: selectors first).
	self deny: ((refactoring model classNamed: #RBSharedPoolForTestData2) directlyDefinesMethod: selectors first)! !

!RBRemoveHierarchyMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #removeMethods:from:! !

!RBRemoveHierarchyMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRemoveNonExistantMethod
	self shouldFail: (self createRefactoringWithArguments: { #(#msg7) . RBBasicLintRuleTestData})! !

!RBRemoveHierarchyMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRemoveHierarchyMethodRefactoring };
		addCase: { #rbClass -> RBRemoveHierarchyMethodTransformation };
		yourself! !

!RBRemoveHierarchyMethodRefactoring commentStamp: ''!
I am a refactoring for removing a method and those of its subclasses,
 to remove the methods use RBRemoveMethodRefactoring.

Example
-------
Script
```
(RBRemoveHierarchyMethodRefactoring 
		removeMethods: #(#msg4)
		from: RBSharedPoolForTestData) execute
```!
!RBRemoveHierarchyMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform 
	self deleteSelectors! !

!RBRemoveHierarchyMethodRefactoring methodsFor: 'transforming' stamp: ''!
deleteSelectors
	selectors do: [ :selector |
		class withAllSubclasses do: [ :aClass |
			self delete: selector in: aClass
		 ]
	 ]! !

!RBRemoveHierarchyMethodRefactoring methodsFor: 'transforming' stamp: ''!
preconditions

	^ selectors inject: self emptyCondition into: [ :cond :selector | 
		  cond & (RBCondition definesSelector: selector in: class) ]! !

!RBRemoveHierarchyMethodRefactoring methodsFor: 'transforming' stamp: ''!
delete: selector in: aClass
	 (aClass realClass includesSelector: selector) ifTrue: [ 
		 [self performCompositeRefactoring: (RBRemoveMethodRefactoring 
									model: self model
									removeMethods: { selector }
									from: aClass) ]
		on: RBRefactoringError 
			do: [ :ex | ( self confirm: 
				(ex messageText copyReplaceAll: 'Browse references?' with: 'Remove anyway?') )
				ifTrue:[ ex resume ] ] ]! !

!RBRemoveHierarchyMethodRefactoring methodsFor: 'transforming' stamp: ''!
deleteSelectorInSubclasses
	class withAllSubclasses do: 
		[ :each | each implements: selectors ]! !

!RBRemoveHierarchyMethodRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' removeMethods: '.
	selectors asArray storeOn: aStream.
	aStream nextPutAll: ' from: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveHierarchyMethodRefactoring methodsFor: 'removing' stamp: ''!
removeMethods: selectorCollection from: aClass 
	class := self classObjectFor: aClass.
	selectors := selectorCollection! !

!RBRemoveHierarchyMethodRefactoring class methodsFor: 'removing' stamp: ''!
removeMethods: selectorCollection from: aClass
	^ self new
		removeMethods: selectorCollection from: aClass! !

!RBRemoveHierarchyMethodTransformation methodsFor: 'executing' stamp: ''!
deleteSelectors
	^ selectors do:  [ :aSelector |
		class withAllSubclasses do: [ :aClass |
			self delete: aSelector in: aClass
		 ]
	 ]! !

!RBRemoveHierarchyMethodTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ selectors inject: self emptyCondition into: [ :cond :aSelector | 
		  cond & (RBCondition definesSelector: aSelector in: class) ]! !

!RBRemoveHierarchyMethodTransformation methodsFor: 'transforming' stamp: ''!
delete: aSelector in: aClass
	 (aClass realClass includesSelector: aSelector) ifTrue: [ 
		[transformations add: (RBRemoveMethodTransformation 
		model: self model
		selector: aSelector
		from: aClass).]
		 "formCompositeRefactoring: (RBRemoveMethodRefactoring 
									model: self model
									removeMethods: { aSelector }
									from: aClass) ]"
		on: RBRefactoringError 
			do: [ :ex | ( self confirm: 
				(ex messageText copyReplaceAll: 'Browse references?' with: 'Remove anyway?') )
				ifTrue:[ ex resume ] ] ]! !

!RBRemoveHierarchyMethodTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' removeMethods: '.
	selectors asArray storeOn: aStream.
	aStream nextPutAll: ' from: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveHierarchyMethodTransformation methodsFor: 'executing' stamp: ''!
buildTransformations 
	transformations := OrderedCollection new.
	self deleteSelectors. 
	^ transformations! !

!RBRemoveHierarchyMethodTransformation methodsFor: 'removing' stamp: ''!
removeMethods: selectorCollection from: aClass 
	class := self model classObjectFor: aClass.
	selectors := selectorCollection! !

!RBRemoveHierarchyMethodTransformation class methodsFor: 'removing' stamp: ''!
removeMethods: selectorCollection from: aClass
	^ self new
		removeMethods: selectorCollection from: aClass! !

!RBRemoveInstanceVariableChange commentStamp: ''!
I am a refactoring for removing an instance variable. My changes are executed on the instance or class side.!
!RBRemoveInstanceVariableChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ changeFactory
		  addInstanceVariable: self variable
		  to: self changeClass! !

!RBRemoveInstanceVariableChange methodsFor: 'private' stamp: ''!
changeSymbol

	^ #removeInstVarNamed:! !

!RBRemoveInstanceVariableChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Remove instance variable <1s> from <2s>'
		  expandMacrosWith: self variable
		  with: self displayClassName! !

!RBRemoveInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
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: (self createRefactoringWithModel: model 
		andArguments: {'foo1' . class name asSymbol }).
	
	self deny: (class definesInstanceVariable: 'foo1')! !

!RBRemoveInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	self shouldFail: (self createRefactoringWithArguments: 
		{ 'name1' . #RBLintRuleTestData })! !

!RBRemoveInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testReferencedVariable
	self shouldFail: (self createRefactoringWithArguments: 
		{ 'name' . #RBLintRuleTestData })! !

!RBRemoveInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveInstVar
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{'foo1' . #RBLintRuleTestData}.
	class := refactoring model classNamed: #RBLintRuleTestData.
	self assert: (class definesInstanceVariable: 'foo1').
	
	self executeRefactoring: refactoring.
	
	self deny: (class definesInstanceVariable: 'foo1')! !

!RBRemoveInstanceVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRemoveInstanceVariableRefactoring .
					  #constructor -> #variable:class: };
		addCase: { #rbClass -> RBRemoveVariableTransformation .
					  #constructor -> #instanceVariable:class: };
		yourself! !

!RBRemoveInstanceVariableRefactoring commentStamp: ''!
I am a refactoring for removing instance variables.

My precondition verifies that there is no reference to this instance  variable.!
!RBRemoveInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	class removeInstanceVariable: variableName! !

!RBRemoveInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	| references |

	references := RBCondition hierarchyOf: class referencesInstanceVariable: variableName.
	class realClass
		ifNil: [ references errorMacro: ( '<1s> is referenced.' expandMacrosWith: variableName ) ]
		ifNotNil: [ references
				errorMacro: ( '<1s> is referenced.<n>Browse references?' expandMacrosWith: variableName );
				errorBlock:
						[ self openBrowserOn: ( RBBrowserEnvironment new instVarRefsTo: variableName in: class realClass ) ]
			].
	^ ( RBCondition definesInstanceVariable: variableName asString in: class ) & references not! !

!RBRemoveInstanceVariableRefactoring class methodsFor: '*SystemCommands-VariableCommands' stamp: ''!
classVariableAnalog
	^RBRemoveClassVariableRefactoring ! !

!RBRemoveInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
remove: variable from: class
	^ self variable: variable class: class! !

!RBRemoveInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aNamespace remove: variable from: class
	^ self model: aNamespace variable: variable class: class! !

!RBRemoveMessageSendTransformation commentStamp: ''!
I am responsible for removing a message send inside a method. In this implementation, only the selector of the message is necessary to execute this transformation.

Usage:
| transformation |
transformation := (RBRemoveMessageSendTransformation
				messageSend: #byteAt:
				inMethod: #methodBefore
				inClass: #RBRemoveMessageSendTransformationTest)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- Check whether this method ever calls the given message.

Observations about the transformation:
- If the method contains more than one message send like the one specified in this transformation, all of these message sends will be removed.
- Removing the message send means removing the receiver, too. The only exception occurs when the receiver is another message send (e.g., in a cascade)!
!RBRemoveMessageSendTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ (RBCondition
			withBlock: [ self definingClass isNotNil ]
			errorString: ('Class named <1s> does not exist' expandMacrosWith: className))
	  & (RBCondition
			withBlock: [ self definingClass canUnderstand: selector ]
			errorString: ('Method named <1s> does not exist' expandMacrosWith: selector))
	  & (RBCondition
			withBlock: [ 
				(self definingMethod
					allChildren select: #isMessage)
					anySatisfy: [ :messageNode | messageNode selector = message asSymbol ] ]
			errorString: ('Method named <1s> does not implement this message send <2s>'
				expandMacrosWith: selector with: message))! !

!RBRemoveMessageSendTransformation methodsFor: 'api' stamp: ''!
messageSend: aMessageSend inMethod: aSelector inClass: aClassName

	self className: aClassName.
	selector := aSelector.
	message := aMessageSend! !

!RBRemoveMessageSendTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' messageSend: ''';
		nextPutAll: message asString;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveMessageSendTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	| methodTree nodesToModify |
	methodTree := self definingMethod.
	
	"try to find a message node with the same selector"
	nodesToModify := ( methodTree allChildren removeDuplicates
		select: #isMessage )
		select: [ :node | node selector = message asSymbol ].
	
	nodesToModify ifNotEmpty: [ 
		nodesToModify do: #removeFromTree.
		self definingClass compileTree: methodTree ]! !

!RBRemoveMessageSendTransformation class methodsFor: 'api' stamp: ''!
messageSend: aMessageSend inMethod: aSelector inClass: aClassName

	^ self new
		messageSend: aMessageSend
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBRemoveMessageSendTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel messageSend: aMessageSend inMethod: aSelector inClass: aClassName

	^ self new
		model: aRBModel;
		messageSend: aMessageSend
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBRemoveMethodChange commentStamp: ''!
I am a refactoring change for a method removement. I know about the class of this method, the selector and whether it is from the 
class or instance side. On removing this method (selector) will be removed from the class.!
!RBRemoveMethodChange methodsFor: 'comparing' stamp: ''!
= aRemoveMethodChange

	super = aRemoveMethodChange
		ifFalse: [ ^ false ].
	^ selector = aRemoveMethodChange selector! !

!RBRemoveMethodChange methodsFor: 'comparing' stamp: ''!
hash

	^ selector hash! !

!RBRemoveMethodChange methodsFor: 'private' stamp: ''!
selector

	^ selector! !

!RBRemoveMethodChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ changeFactory
		  addMethodSource: (self methodSourceFor: selector)
		  in: self changeClass! !

!RBRemoveMethodChange methodsFor: 'initialization' stamp: ''!
selector: aSymbol

	selector := aSymbol! !

!RBRemoveMethodChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self displayClassName;
		nextPutAll: ' removeSelector: ';
		print: self selector;
		nextPut: $!!! !

!RBRemoveMethodChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Remove <1s>>>#<2s>'
		expandMacrosWith: self displayClassName
		with: selector! !

!RBRemoveMethodChange methodsFor: 'private' stamp: ''!
primitiveExecute

	^ self changeClass removeSelector: selector! !

!RBRemoveMethodChange class methodsFor: 'instance creation' stamp: ''!
remove: aSymbol from: aClass

	^ self new
		changeClass: aClass;
		selector: aSymbol;
		yourself! !

!RBRemoveMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRemoveReferenced
	self shouldFail: (self createRefactoringWithModel: model 
	andArgumentsColl:  #(#checkClass:)
	andOtherArgs: { #RBBasicLintRuleTestData })! !

!RBRemoveMethodParametrizedTest methodsFor: 'builder' stamp: ''!
createRefactoringWithModel: rbNamespace andArgumentsColl: aParameterCollection andOtherArgs: argCollection
	^ isComposed 
	ifTrue: [ {self createRefactoringWithModel: rbNamespace 
		andArguments: {aParameterCollection}, argCollection} ] 
	ifFalse: [ aParameterCollection collect: [ :e |
		self createRefactoringWithModel: rbNamespace 
		andArguments: {e}, argCollection
	] ]! !

!RBRemoveMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveMethod
	| refactoring selectors |
	selectors := Array with: 'selectorNotReferenced' asSymbol.
	refactoring := self createRefactoringWithModel: model
		andArgumentsColl: selectors 
		andOtherArgs: { #RBRefactoryTestDataApp }.
	
	selectors do: [ :symbol |
		self assert: 
			(( model classNamed: #RBRefactoryTestDataApp) 
				directlyDefinesMethod: symbol).
	].
	
	self executeRefactorings: refactoring.
	
	selectors do: [ :symbol |
		self deny: 
			(( model classNamed: #RBRefactoryTestDataApp) 
				directlyDefinesMethod: symbol)
	].! !

!RBRemoveMethodParametrizedTest methodsFor: 'builder' stamp: ''!
createRefactoringWithModel: rbNamespace andArguments: aParameterCollection
	^ (rbClass
		perform: #model: , constructor 
		withArguments: {rbNamespace}, aParameterCollection) asRefactoring! !

!RBRemoveMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRemoveNonExistingMethod
	self shouldFail: (self createRefactoringWithModel: model
	andArgumentsColl: #(#nonExistingMethod )
	andOtherArgs: {#RBBasicLintRuleTestData})! !

!RBRemoveMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testModelRecursiveMethodThatIsNotReferencedFromOtherMethods
	| class otherClass |
	class := model classNamed: #Object.
	class compile: 'someMethodThatIsNotReferenced ^2' classified: #(#accessing).
	self assert: (class definesMethod: 'someMethodThatIsNotReferenced' asSymbol).
	otherClass := model metaclassNamed: self class superclass name.
	otherClass 
		compile: 'someMethodThatIsNotReferenced ^3 someMethodThatIsNotReferenced'
		classified: #(#accessing).
	model removeClassNamed: self class name.
	
	self executeRefactorings: (self createRefactoringWithModel: model
		andArgumentsColl: {'someMethodThatIsNotReferenced' asSymbol} 
		andOtherArgs: { #Object }).
	self deny: (class definesMethod: 'someMethodThatIsNotReferenced' asSymbol)! !

!RBRemoveMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRemoveSameMethodButSendsSuper
	<expectedFailure>
	self shouldWarn: (self createRefactoringWithModel: model
			andArgumentsColl: #(#new )   
			andOtherArgs: {#'RBBasicLintRuleTestData class'})! !

!RBRemoveMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRemoveMethodRefactoring .
					  #constructor -> #removeMethods:from: .
					  #isComposed -> true};
		addCase: { #rbClass -> RBRemoveMethodTransformation .
					  #constructor -> #selector:from: .
					  #isComposed -> false};	
		yourself! !

!RBRemoveMethodRefactoring commentStamp: ''!
I am a refactoring for removing a method.

My preconditions verify that this method is not referenced anywhere.!
!RBRemoveMethodRefactoring methodsFor: 'initialization' stamp: ''!
removeMethods: selectorCollection from: aClass 
	class := self classObjectFor: aClass.
	selectors := selectorCollection! !

!RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkReferencesToAnyOf: aSelectorCollection
	| occurrences |
	occurrences := OrderedCollection new.
	aSelectorCollection
		do: [ :each | 
			self model
				allReferencesTo: each
				do: [ :aRBMethod | 
					(aSelectorCollection includes: aRBMethod selector)
						ifFalse: [ occurrences add: each -> aRBMethod ] ] ].
	occurrences ifEmpty: [ ^ self ].
	^ self checkBrowseOccurrences: occurrences! !

!RBRemoveMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform
	selectors do: [:each | class removeMethod: each]! !

!RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkBrowseOccurrences: anCollectionOfOccurrences
	^ anCollectionOfOccurrences size = 1
		ifTrue: [ self checkBrowseOccurrenceOf: anCollectionOfOccurrences first key in: anCollectionOfOccurrences first value ]
		ifFalse: [ self checkBrowseAllOccurrences: anCollectionOfOccurrences ]! !

!RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions

	^ (selectors
		   inject: self emptyCondition
		   into: [ :cond :each | 
		   cond & (RBCondition definesSelector: each in: class) ])
	  & (RBCondition withBlock: [ 
			   self checkSuperMethods.
			   true ])! !

!RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
superclassEquivalentlyDefines: aSelector

	| superTree myTree |

	class superclass ifNil: [ ^ false ].
	superTree := class superclass parseTreeFor: aSelector.
	myTree := class parseTreeFor: aSelector.
	( superTree isNil or: [ myTree isNil ] )
		ifTrue: [ ^ false ].
	^ superTree equalTo: myTree exceptForVariables: #()! !

!RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkBrowseOccurrenceOf: selector in: aRBMethod
	self
		refactoringError:
			('Possible call to <2s> in <1p><n>Browse references?' expandMacrosWith: aRBMethod modelClass with: selector)
		with: [ self openBrowserOn: (RBBrowserEnvironment new referencesTo: selector) ]! !

!RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkBrowseAllOccurrences: anCollectionOfOccurrences
	| methods callers |
	methods := anCollectionOfOccurrences collect: [ :c | c key ] as: Set.
	callers := anCollectionOfOccurrences collect: [ :v | v value ].
	methods size = 1
		ifTrue: [ 
			self
				refactoringError:
					('Possible call to <2s> in <1p> methods.<n>Browse references?'
						expandMacrosWith: anCollectionOfOccurrences size
						with: methods anyOne)
				with: [ self openBrowserOn: (RBBrowserEnvironment new referencesTo: methods anyOne) ] ]
		ifFalse: [ 
			self
				refactoringError:
					('Possible call to the <2p> selectors in <1p> methods.<n>Browse references?'
						expandMacrosWith: callers size
						with: methods size)
				with: [ 
					| env |
					env := RBSelectorEnvironment new.
					callers do: [ :d | env addMethod: d method ].
					self openBrowserOn: env ] ]! !

!RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkSuperMethods
	| superMessages nonSupers |
	nonSupers := OrderedCollection new.
	superMessages := OrderedCollection new.
	(selectors reject: [:each | self justSendsSuper: each]) do: 
			[:each | 
			(self superclassEquivalentlyDefines: each) 
				ifTrue: 
					[(class parseTreeFor: each) superMessages isEmpty 
						ifFalse: [superMessages add: each]]
				ifFalse: [nonSupers add: each]].
	nonSupers isEmpty & superMessages isEmpty ifTrue: [^self].
	self checkReferencesToAnyOf: nonSupers.
	self checkReferencesToSuperSendsToAnyOf: superMessages! !

!RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkReferencesToSuperSendsToAnyOf: superMessages 
	[superMessages isEmpty] whileFalse: 
			[self 
				refactoringWarning: ('Although <1s> is equivalent to a superclass method,<n>it contains a super send so it might modify behavior.<n>Proceed anyway?' 
						expandMacrosWith: superMessages first).
			superMessages remove: superMessages first]! !

!RBRemoveMethodRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' removeMethods: '.
	selectors asArray storeOn: aStream.
	aStream nextPutAll: ' from: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''!
justSendsSuper: aSelector

	| matcher parseTree superclass |

	matcher := self parseTreeSearcherClass justSendsSuper.
	parseTree := class parseTreeFor: aSelector.
	( matcher executeTree: parseTree initialAnswer: false )
		ifFalse: [ ^ false ].
	parseTree lastIsReturn
		ifTrue: [ ^ true ].
	superclass := class superclass whichClassIncludesSelector: aSelector.
	superclass ifNil: [ ^ 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 := self parseTreeSearcher.
	matcher
		matches: '^``@object'
		do: [ :aNode :answer | 
			answer
				add: aNode value;
				yourself
			].
	matcher executeTree: parseTree initialAnswer: Set new.
	^ ( matcher answer anySatisfy: [ :each | each isSelfVariable not ]) not! !

!RBRemoveMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk removeMethods: selectorCollection from: aClass 
	^ self new
		model: aRBSmalltalk;
		removeMethods: selectorCollection from: aClass;
		yourself! !

!RBRemoveMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
removeMethods: selectorCollection from: aClass
	^ self new
		removeMethods: selectorCollection from: aClass! !

!RBRemoveMethodTransformation commentStamp: ''!
Removes a method from a class. Only the selector of the method is needed.

Usage:
| transformation |
transformation := (RBRemoveMethodTransformation 
		selector: #transform
		from: RBRemoveMethodTransformation)
		transform. 
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
Checks whether there are any references to this method!
!RBRemoveMethodTransformation methodsFor: 'api' stamp: ''!
selector: aSelector from: aClassName

	self className: aClassName.
	selector := aSelector
	! !

!RBRemoveMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkBrowseOccurrences: anCollectionOfOccurrences
	^ anCollectionOfOccurrences size = 1
		ifTrue: [ self checkBrowseOccurrenceIn: anCollectionOfOccurrences first value ]
		ifFalse: [ self checkBrowseAllOccurrences: anCollectionOfOccurrences ]! !

!RBRemoveMethodTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ (RBCondition definesSelector: selector in: self definingClass) 
		& (RBCondition withBlock: [ self checkSuperMethods. true ])! !

!RBRemoveMethodTransformation methodsFor: 'preconditions' stamp: ''!
superclassEquivalentlyDefines: aSelector

	| superTree myTree |

	self definingClass superclass ifNil: [ ^ false ].
	superTree := self definingClass superclass parseTreeFor: aSelector.
	myTree := self definingClass parseTreeFor: aSelector.
	( superTree isNil or: [ myTree isNil ] )
		ifTrue: [ ^ false ].
	^ superTree equalTo: myTree exceptForVariables: #()! !

!RBRemoveMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkBrowseOccurrenceIn: aRBMethod

	self refactoringError:
		('Possible call to <2s> in <1p><n>Browse references?'
			expandMacrosWith: aRBMethod modelClass
			with: selector)
		with: [ self openBrowserOn: (RBBrowserEnvironment new referencesTo: selector) ]! !

!RBRemoveMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkBrowseAllOccurrences: anCollectionOfOccurrences

	| methods callers |
	methods := anCollectionOfOccurrences collect: [ :c | c key ] as: Set.
	callers := anCollectionOfOccurrences collect: [ :v | v value ].
	methods size = 1
		ifTrue: [ self refactoringError:
				('Possible call to <2s> in <1p> methods.<n>Browse references?'
					expandMacrosWith: anCollectionOfOccurrences size
					with: methods anyOne)
				with: [ self openBrowserOn: (RBBrowserEnvironment new referencesTo: methods anyOne) ] ]
		ifFalse: [ self refactoringError:
				('Possible call to the <2p> selectors in <1p> methods.<n>Browse references?'
					expandMacrosWith: callers size
					with: methods size)
				with: [ 
					| env |
					env := RBSelectorEnvironment new.
					callers do: [ :d | env addMethod: d method ].
					self openBrowserOn: env ] ]! !

!RBRemoveMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkReferences

	| occurrences |
	occurrences := OrderedCollection new.

	self model
		  allReferencesTo: selector
		  do: [ :aRBMethod | 
				(selector = aRBMethod selector)
				ifFalse: [ occurrences add: selector -> aRBMethod ] ].
	occurrences ifEmpty: [ ^ self ].
	^ self checkBrowseOccurrences: occurrences! !

!RBRemoveMethodTransformation methodsFor: 'preconditions' stamp: ''!
checkSuperMethods

	(self justSendsSuper: selector) ifTrue: [ ^ self ]
		ifFalse: [ (self superclassEquivalentlyDefines: selector)
			ifTrue: [ (self definingClass parseTreeFor: selector) superMessages
				ifNotEmpty: [ self 
						refactoringError: ('Although <1s> is equivalent to a superclass method,<n>
							it contains a super send so it might modify behavior.'
							expandMacrosWith: selector ) ] ]
			ifFalse: [ self checkReferences ] ]! !

!RBRemoveMethodTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' selector: ';
		nextPutAll: selector;
		nextPutAll: ' from: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveMethodTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self definingClass removeMethod: selector! !

!RBRemoveMethodTransformation methodsFor: 'preconditions' stamp: ''!
justSendsSuper: aSelector
	| matcher parseTree superclass |
	matcher := self parseTreeSearcherClass justSendsSuper.
	parseTree := self definingClass parseTreeFor: aSelector.
	(matcher executeTree: parseTree initialAnswer: false)
		ifFalse: [ ^ false ].
	parseTree lastIsReturn
		ifTrue: [ ^ true ].	"Since there isn't a superclass that implements the message, we can 
	 delete it since it would be an error anyway."
	superclass := self definingClass superclass
		whichClassIncludesSelector: aSelector.
	superclass ifNil: [ ^ true ].
	parseTree := superclass parseTreeFor: aSelector.
	matcher := self parseTreeSearcherClass new.
	matcher
		matches: '^``@object'
		do: [ :aNode :answer | 
			answer
				add: aNode value;
				yourself ].
	matcher executeTree: parseTree initialAnswer: Set new.
	^ matcher answer
		allSatisfy: [ :each | "^ (matcher answer 
		detect: [:each | (each isVariable and: [each name = 'self']) not]
		ifNone: [nil]) isNil" each isVariable and: [ each name = 'self' ] ]! !

!RBRemoveMethodTransformation class methodsFor: 'api' stamp: ''!
selectors: aCollection from: aClassName

	^ self model: RBTransformation new model selectors: aCollection from: aClassName! !

!RBRemoveMethodTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel selectors: aCollection from: aClassName

	^ RBCompositeTransformation new
		transformations: (aCollection collect: [:e |
			self model: aRBModel
				  selector: e
				  from: aClassName] )! !

!RBRemoveMethodTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel selector: aSelector from: aClassName

	^ self new
		model: aRBModel;
		selector: aSelector
		from: aClassName;
		yourself! !

!RBRemoveMethodTransformation class methodsFor: 'api' stamp: ''!
selector: aSelector from: aClassName

	^ self new
		selector: aSelector
		from: aClassName;
		yourself! !

!RBRemovePackageChange commentStamp: ''!
I am a refactory change for a package removing. The RBRefactory api is implemented in my super class, I just define the concrete "package" removing.!
!RBRemovePackageChange methodsFor: 'removing' stamp: ''!
removePackageNamed: aString

	packageName := aString! !

!RBRemovePackageChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ changeFactory addPackageNamed: packageName! !

!RBRemovePackageChange methodsFor: 'accessing' stamp: ''!
package

	^ (browserEnvironment packageAt: packageName ifAbsent: [nil]) ! !

!RBRemovePackageChange methodsFor: 'private' stamp: ''!
primitiveExecute

	| pkg |
	pkg := self package.
	pkg ifNotNil: [ pkg removeFromSystem ]! !

!RBRemovePackageChange class methodsFor: 'removing' stamp: ''!
removePackageNamed: aString

	^ self new removePackageNamed: aString! !

!RBRemoveParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	self shouldFail: (self createRefactoringWithArguments: 
		{ 'asdf' . RBBasicLintRuleTestData . #checkClass: }).
	self shouldFail: (self createRefactoringWithArguments:  
		{ 'aSmalllintContext' . RBBasicLintRuleTestData . #checkClass1: })! !

!RBRemoveParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testPrimitiveMethods
	| refactoring |
	(model classNamed: #Object) 
		compile: 'foo123: a <primitive: 100> ^#() primitiveFailed'
		classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model 
		andArguments: { 'a' . Object . #foo123: }.
	self shouldFail: refactoring! !

!RBRemoveParameterParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #removeParameter:in:selector:! !

!RBRemoveParameterParametrizedTest methodsFor: 'failure tests' stamp: ''!
testReferenceArgument
	| refactoring |
	(model classNamed: #Object) 
		compile: 'methWith: arg1 ^ arg1 * 8'
		classified: #(#accessing).
	refactoring := self createRefactoringWithModel: model 
		andArguments: { 'arg1' . Object . #methWith: }.
	self shouldFail: refactoring! !

!RBRemoveParameterParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveParameter
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ 'anArg' . RBRefactoryTestDataApp . ('rename' , 'ThisMethod:') asSymbol }.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self assert: (class parseTreeFor: #renameThisMethod) equals: (self parseMethod: 'renameThisMethod
								^self').
	self assert: (class parseTreeFor: #callMethod) equals: (self parseMethod: 'callMethod
								^(self renameThisMethod)').
	self deny: (class directlyDefinesMethod: ('rename' , 'ThisMethod:') asSymbol)! !

!RBRemoveParameterParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRemoveParameterRefactoring };
		addCase: { #rbClass -> RBRemoveParameterTransformation};
		yourself! !

!RBRemoveParameterRefactoring commentStamp: ''!
I am a refactoring for removing (unused) arguments.

My preconditions verify that the argument to be removed is not referenced by the methods and that the new method name isn't alread used.
Any sender of the prior selector will be changed to the new.

If the method contains more than one argument, I request the user to choose one of the arguments.!
!RBRemoveParameterRefactoring methodsFor: 'initialization' stamp: ''!
removeParameter: aString in: aClass selector: aSelector 
	oldSelector := aSelector.
	class := self classObjectFor: aClass.
	argument := aString! !

!RBRemoveParameterRefactoring methodsFor: 'private' stamp: ''!
computeNewSelector
	| keywords |
	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.
	^ (String streamContents: [ :str | keywords do: [ :each | str nextPutAll: each ] ]) asSymbol! !

!RBRemoveParameterRefactoring methodsFor: 'preconditions' stamp: ''!
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: 'transforming' stamp: ''!
getNewSelector
	| tree |
	(class directlyDefinesMethod: oldSelector)
		ifFalse: [ self refactoringFailure: 'Method doesn''t exist' ].
	tree := class parseTreeFor: oldSelector.
	tree ifNil: [ self refactoringFailure: 'Cannot parse sources' ].
	argument ifNil:[ self refactoringFailure: 'This method does not have an argument' ].
	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: ''!
hasReferencesToTemporaryIn: each

	| tree |

	tree := each parseTreeFor: oldSelector.
	tree ifNil: [ self refactoringFailure: 'Cannot parse sources.' ].
	^ tree references: ( tree argumentNames at: parameterIndex )! !

!RBRemoveParameterRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' removeParameter: ''';
		nextPutAll: argument;
		nextPutAll: ''' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll: oldSelector.
	aStream nextPut: $)! !

!RBRemoveParameterRefactoring class methodsFor: 'instance creation' stamp: ''!
removeParameter: aString in: aClass selector: aSelector
	^ self new 
		removeParameter: aString 
		in: aClass 
		selector: aSelector! !

!RBRemoveParameterRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk removeParameter: aString in: aClass selector: aSelector 
	^ self new
		model: aRBSmalltalk;
		removeParameter: aString
			in: aClass
			selector: aSelector;
		yourself! !

!RBRemoveParameterTransformation methodsFor: 'private' stamp: ''!
removeParameter: aString in: aClass selector: aSelector 
	oldSelector := aSelector.
	class := self model classObjectFor: aClass.
	argument := aString! !

!RBRemoveParameterTransformation methodsFor: 'private' stamp: ''!
computeNewSelector
	| keywords |
	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.
	^ (String streamContents: [ :str | keywords do: [ :each | str nextPutAll: each ] ]) asSymbol! !

!RBRemoveParameterTransformation methodsFor: 'private' stamp: ''!
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!!!!')]! !

!RBRemoveParameterTransformation methodsFor: 'private' stamp: ''!
getNewSelector
	| tree |
	(class directlyDefinesMethod: oldSelector)
		ifFalse: [ self refactoringFailure: 'Method doesn''t exist' ].
	tree := class parseTreeFor: oldSelector.
	tree ifNil: [ self refactoringFailure: 'Cannot parse sources' ].
	argument ifNil:[ self refactoringFailure: 'This method does not have an argument' ].
	parameterIndex := tree argumentNames indexOf: argument ifAbsent: [ self refactoringFailure: 'Select a parameter!!!!' ].
	permutation := (1 to: oldSelector numArgs) copyWithout: parameterIndex.
	newSelector := self computeNewSelector! !

!RBRemoveParameterTransformation methodsFor: 'private' stamp: ''!
hasReferencesToTemporaryIn: each

	| tree |

	tree := each parseTreeFor: oldSelector.
	tree ifNil: [ self refactoringFailure: 'Cannot parse sources.' ].
	^ tree references: ( tree argumentNames at: parameterIndex )! !

!RBRemoveParameterTransformation methodsFor: 'private' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' removeParameter: ''';
		nextPutAll: argument;
		nextPutAll: ''' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll: oldSelector.
	aStream nextPut: $)! !

!RBRemoveParameterTransformation class methodsFor: 'instance creation' stamp: ''!
removeParameter: aString in: aClass selector: aSelector
	^ self new 
		removeParameter: aString 
		in: aClass 
		selector: aSelector! !

!RBRemoveParameterTransformation class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk removeParameter: aString in: aClass selector: aSelector 
	^ self new
		model: aRBSmalltalk;
		removeParameter: aString
			in: aClass
			selector: aSelector;
		yourself! !

!RBRemovePoolVariableChange commentStamp: ''!
I am a refactoring for removing a pool variable. My changes are executed on the instance side.!
!RBRemovePoolVariableChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ changeFactory addPoolVariable: self variable to: self changeClass! !

!RBRemovePoolVariableChange methodsFor: 'accessing' stamp: ''!
changeClass: aBehavior

	super changeClass: aBehavior.
	isMeta := false! !

!RBRemovePoolVariableChange methodsFor: 'private' stamp: ''!
changeSymbol

	^ #removeSharedPool:! !

!RBRemovePoolVariableChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Remove pool variable <1s> from <2s>'
		  expandMacrosWith: self variable
		  with: self displayClassName! !

!RBRemovePragmaTransformation commentStamp: ''!
I am responsible for removing a pragma definition in a method. In this implementation, all the pragma (i.e., selector and arguments) must be described.

Usage:
| transformation |
transformation := (RBRemovePragmaTransformation
				pragma: '<gtInspectorPresentationOrder: 34>'
				inMethod: #methodBefore
				inClass: #RBRemovePragmaTransformationTest)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the class exists,
- the methos exists, and
- this method has a pragma with the given selector.

Observations about the transformation:
- Although the pragma must be described, the transformation will remove the pragma that has the same selector as the specified one.!
!RBRemovePragmaTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition
		withBlock: [ self definingClass isNotNil ]
		errorString: ('Class named <1s> does not exist' expandMacrosWith: className))
		&
			(RBCondition
				withBlock: [ self definingClass canUnderstand: selector ]
				errorString: ('Method named <1s> does not exist' expandMacrosWith: selector))
		&
			(RBCondition
				withBlock: [ | pragmaNode |
					pragmaNode := self parserClass parsePragma: pragma.
					self definingMethod pragmas
						anySatisfy: [ :e | e selector = pragmaNode selector ] ]
				errorString:
					('Method named <1s> does not have a pragma named <2s>'
						expandMacrosWith: selector
						with: (self parserClass parsePragma: pragma) selector))! !

!RBRemovePragmaTransformation methodsFor: 'api' stamp: ''!
pragma: aPragmaDefinition inMethod: aSelector inClass: aClassName

	self className: aClassName.
	selector := aSelector.
	pragma := aPragmaDefinition.! !

!RBRemovePragmaTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' pragma: ''';
		nextPutAll: pragma;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRemovePragmaTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	| methodTree pragmaNode nodesToRemove |
	methodTree := self definingMethod.
	pragmaNode := self parserClass parsePragma: pragma.
	nodesToRemove := (methodTree allChildren removeDuplicates
		select: #isPragma)
		select: [ :node | node selector = pragmaNode selector ].
	nodesToRemove do: [ :node | node parent removePragma: node ].
	self definingClass compileTree: methodTree! !

!RBRemovePragmaTransformation class methodsFor: 'api' stamp: ''!
pragma: aPragmaDefinition inMethod: aSelector inClass: aClassName

	^ self new
		pragma: aPragmaDefinition
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBRemovePragmaTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel pragma: aPragmaDefinition inMethod: aSelector inClass: aClassName

	^ self new
		model: aRBModel;
		pragma: aPragmaDefinition
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBRemovePragmaTransformationTest methodsFor: 'utilities' stamp: ''!
methodAfter

	| variable |
	variable := 'String'.
	variable byteAt: 1.! !

!RBRemovePragmaTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBRemovePragmaTransformation 
						pragma: '<gtInspectorPresentationOrder: 34>'
						inMethod: #methodBefore
						inClass: #RBRemovePragmaTransformationTest)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 1.
	
	class := refactoring model classNamed: #RBRemovePragmaTransformationTest.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBRemovePragmaTransformationTest methodsFor: 'utilities' stamp: ''!
methodBefore
	<gtInspectorPresentationOrder: 34>

	| variable |
	variable := 'String'.
	variable byteAt: 1.! !

!RBRemovePragmaTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBRemovePragmaTransformation new
		pragma: '<gtInspectorPresentationOrder: 34>'
		inMethod: #methodBefore
		inClass: self class name)
		transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self class name.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBRemovePragmaTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBRemovePragmaTransformation 
							pragma: '<gtInspectorPresentationOrder: 34>'
							inMethod: #method
							inClass: #RBRemovePragmaTransformationTest)
							asRefactoring ! !

!RBRemovePragmaTransformationTest methodsFor: 'tests' stamp: ''!
testPragmaDoesNotExist

	self shouldFail: (RBRemovePragmaTransformation 
							pragma: '<gtPresentationOrder: 34>'
							inMethod: #methodBefore
							inClass: #RBRemovePragmaTransformationTest)
							asRefactoring! !

!RBRemovePragmaTransformationTest methodsFor: 'tests' stamp: ''!
testClassDoesNotExist

	self shouldFail: (RBRemovePragmaTransformation 
							pragma: '<gtInspectorPresentationOrder: 34>'
							inMethod: #methodBefore
							inClass: #RBPragmaTransformationTest)
							asRefactoring ! !

!RBRemoveProtocolChange commentStamp: ''!
RBRefactoryProtocolChange is responsible for removing a protocol in classes in a RB model!
!RBRemoveProtocolChange methodsFor: 'converting' stamp: ''!
asUndoOperation
	
	^ RBAddProtocolChange addProtocolNamed: protocol in: self changeClass ! !

!RBRemoveProtocolChange methodsFor: 'printing' stamp: ''!
printOn: aStream 

	aStream
		nextPutAll: self displayClassName;
		nextPutAll: ' removeProtocolNamed: ';
		print: ( self displayProtocolName );
		nextPutAll: ' stamp: ';
		print: (self changeStamp);
		nextPutAll: '!!'! !

!RBRemoveProtocolChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Remove protocol named ', self displayProtocolName, ' in ', self displayClassName! !

!RBRemoveProtocolChange methodsFor: 'private' stamp: ''!
primitiveExecute

	self changeClass organization removeProtocol: ( self changeClass organization protocolNamed: protocol )! !

!RBRemoveProtocolChange class methodsFor: 'instance creation' stamp: ''!
removeProtocolNamed: aString in: aClass

	^ self new
		changeClass: aClass;
		protocol: aString;
		yourself! !

!RBRemoveProtocolTransformation commentStamp: ''!
I am responsible for removing a protocol in a class

Usage:
| transformation |
transformation := (RBRemoveProtocolTransformation
			protocol: 'empty protocol'
			inClass: #RBDummyEmptyClass)
			transform.
(ChangesBrowser changes: transformation model changes changes) open
	
Preconditions:
- The class exists;
- A protocol with this name exists;
- No methods are categorized with this protocol.!
!RBRemoveProtocolTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ ( RBCondition
			withBlock: [ self definingClass isNotNil ]
			errorString: 'Class named ', className, ' does not exist' ) 
		& ( RBCondition
			withBlock: [ ( model environment 
			protocolsFor: self definingClass realClass )
			includes: protocol ]
			errorString: 'Protocol named ', protocol, ' does not exist' )
		& ( RBCondition
			withBlock: [ (self definingClass realClass organization protocolNamed: protocol ) canBeRemoved ]
			errorString: 'Protocol named ', protocol, ' is a virtual protocol and it cannot be removed' ) 
		& ( RBCondition
			withBlock: [ (self definingClass realClass organization protocolNamed: protocol ) isEmpty ]
			errorString: 'Protocol named ', protocol, ' is not empty and it cannot be removed' )! !

!RBRemoveProtocolTransformation methodsFor: 'api' stamp: ''!
protocol: aString inClass: aClassName

	self className: aClassName.
	protocol := aString! !

!RBRemoveProtocolTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' protocol: ''';
		nextPutAll: protocol;
		nextPutAll: ''' inClass: ''';
		nextPutAll: className.
	aStream nextPut: $)! !

!RBRemoveProtocolTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self definingClass removeProtocolNamed: protocol! !

!RBRemoveProtocolTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel protocol: aString inClass: aClassName

	^ self new
		model: aRBModel;
		protocol: aString
		inClass: aClassName;
		yourself! !

!RBRemoveProtocolTransformation class methodsFor: 'api' stamp: ''!
protocol: aString inClass: aClassName

	^ self new
		protocol: aString
		inClass: aClassName;
		yourself! !

!RBRemoveProtocolTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring
	
	| refactoring |		
	refactoring := (RBAddProtocolTransformation
						protocol: 'transforming'
						inClass: #RBDummyEmptyClass)
						transform.
	RBRefactoryChangeManager instance performChange: refactoring changes.					
						
	refactoring := (RBRemoveProtocolTransformation
						protocol: 'transforming'
						inClass: #RBDummyEmptyClass)
						asRefactoring transform.
		
	self assert: refactoring model changes changes size equals: 1! !

!RBRemoveProtocolTransformationTest methodsFor: 'tests' stamp: ''!
testTransform
	
	| transformation |
	transformation := (RBAddProtocolTransformation
							protocol: 'transforming'
							inClass: #RBDummyEmptyClass)
							transform.
		
	transformation := (RBRemoveProtocolTransformation
							model: transformation model
							protocol: 'transforming'
							inClass: #RBDummyEmptyClass)
							transform.
		
	self assert: transformation model changes changes size equals: 2! !

!RBRemoveReturnStatementTransformation commentStamp: ''!
I am responsible for removing a return statement inside a method.

Usage:
| transformation |
transformation := (RBRemoveReturnStatementTransformation
			return: '^ variable'
			inMethod: #methodBefore
			inClass: #RBRemoveReturnStatementTransformationTest)
			transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- Checks whether the method has a return.

Observations about the transformation:
- This transformation is straightforward: just remove the last node of the method.
- In Pharo, return statements can also be declared inside blocks. In this case, the transformation will try to match return statement passed as argument and remove the return values in this method. If no matching return value is found, the transformation will remove the last node.!
!RBRemoveReturnStatementTransformation methodsFor: 'api' stamp: ''!
return: anExpression inMethod: aSelector inClass: aClassName

	self className: aClassName.
	selector := aSelector.
	returnValue := anExpression! !

!RBRemoveReturnStatementTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ (RBCondition
			withBlock: [ self definingClass isNotNil ]
			errorString: ('Class named <1s> does not exist' expandMacrosWith: className))
		& (RBCondition
			withBlock: [ self definingClass canUnderstand: selector ]
			errorString: ('Method named <1s> does not exist' expandMacrosWith: selector))
		& (RBCondition
			withBlock: [ self definingMethod lastIsReturn ]
			errorString: ('Method named <1s> does not have a return statement' expandMacrosWith: selector))! !

!RBRemoveReturnStatementTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' return: ''';
		nextPutAll: returnValue;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveReturnStatementTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	| methodTree nodesToRemove |
	methodTree := self definingMethod.
	
	nodesToRemove := ( methodTree allChildren removeDuplicates
		select: #isReturn )
		select: [ :node | node sourceCode = returnValue ].
	
	nodesToRemove
		ifEmpty: [ methodTree removeLast ]
		ifNotEmpty: [ nodesToRemove do: [ :node | node parent removeNode: node ] ].
	self definingClass compileTree: methodTree.! !

!RBRemoveReturnStatementTransformation class methodsFor: 'api' stamp: ''!
return: anExpression inMethod: aSelector inClass: aClassName

	^ self new
		return: anExpression
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBRemoveReturnStatementTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel return: anExpression inMethod: aSelector inClass: aClassName

	^ self new
		model: aRBModel;
		return: anExpression
		inMethod: aSelector
		inClass: aClassName;
		yourself! !

!RBRemoveReturnStatementTransformationTest methodsFor: 'utilities' stamp: ''!
methodAfter

	| variable |
	variable := 'String'.! !

!RBRemoveReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBRemoveReturnStatementTransformation 
						return: '^ variable'
						inMethod: #methodBefore
						inClass: #RBRemoveReturnStatementTransformationTest)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 1.
	
	class := refactoring model classNamed: #RBRemoveReturnStatementTransformationTest.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBRemoveReturnStatementTransformationTest methodsFor: 'utilities' stamp: ''!
methodBefore

	| variable |
	variable := 'String'.
	^ variable! !

!RBRemoveReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBRemoveReturnStatementTransformation new
		return: '^ variable'
		inMethod: #methodBefore
		inClass: self class name)
		transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self class name.
	self assert: (class parseTreeFor: #methodBefore) body
			equals: (class parseTreeFor: #methodAfter) body.! !

!RBRemoveReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBRemoveReturnStatementTransformation 
							return: '^ variable'
							inMethod: #method
							inClass: #RBRemoveReturnStatementTransformationTest)
							asRefactoring ! !

!RBRemoveReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testReturnDoesNotExist

	self shouldFail: (RBRemoveReturnStatementTransformation
							return: '^ variable'
							inMethod: #methodAfter
							inClass: #RBRemoveReturnStatementTransformationTest)
							asRefactoring! !

!RBRemoveReturnStatementTransformationTest methodsFor: 'tests' stamp: ''!
testClassDoesNotExist

	self shouldFail: (RBRemoveReturnStatementTransformation
							return: '^ variable'
							inMethod: #methodBefore
							inClass: #RBReturnStatementTransformationTest)
							asRefactoring! !

!RBRemoveSenderMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveSenderIntoCascaded3Message
	| refactoring transformedMethod afterRefactoring1 afterRefactoring2 |
	afterRefactoring1 := self parseMethod: 'referencesConditionFor: aClass

	| environment association anObject |
	anObject := RBCondition withBlock: [ 
		            association := Smalltalk globals
			                           associationAt: aClass name
			                           ifAbsent: [ 
			                           self refactoringError:
				                           ''Could not find class'' ].
		            environment := (self environment referencesTo:
			                            association)
		                           |
		                           (self environment referencesTo:
			                            aClass name).
		            environment isEmpty ].
	anObject errorMacro: aClass , '' is referenced.<n>Browse references?''.
	^ anObject yourself' .
	afterRefactoring2 := self parseMethod: 'referencesConditionFor: aClass
	| environment association |
	^ (RBCondition withBlock: [ 
			   association := Smalltalk globals
				                  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.<n>Browse references?'';
		  yourself'.
	self proceedThroughWarning: 
		[ refactoring := self createRefactoringWithArguments:
			{{(	64 to: 461) . #errorBlock:}. 
				#referencesConditionFor: . 
				#RBRefactoryTestDataApp}.
	self setupInlineExpressionFor: refactoring toReturn: false.
	self executeRefactoring: refactoring ].
	transformedMethod := ((refactoring model classNamed: #RBRefactoryTestDataApp) 
	parseTreeFor: #referencesConditionFor:).
	self assert: (transformedMethod = afterRefactoring1 or: [transformedMethod = afterRefactoring2])! !

!RBRemoveSenderMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testIsDirectlyUsed2
	| refactoring |
	refactoring := self createRefactoringWithArguments: 
		{{(25 to: 39). #isVariable} . 
		#returnsBooleanAndOther . 
		#RBRefactoryTestDataApp}.
	self setupInlineExpressionFor: refactoring toReturn: false.
	self flag: 'TODO: refactoring2'
"	self shouldFail: refactoring."! !

!RBRemoveSenderMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveSenderIntoCascadedMessage
	| refactoring methodName |
	methodName := ('called:', 'on:') asSymbol.
	self proceedThroughWarning: 
		[ refactoring := self createRefactoringWithArguments:  
			{{(	31 to: 75) . #cr}.
			methodName . 
			#RBRefactoryTestDataApp}.
	self setupInlineExpressionFor: refactoring toReturn: false.
	
	self executeRefactoring: refactoring ].
	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: methodName) 
		equals: (self parseMethod: 'called: anObject on: aBlock 
			Transcript show: anObject printString.
			aBlock value')! !

!RBRemoveSenderMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMethodDoesNotExist
	self shouldFail: (self createRefactoringWithArguments:  
		{{(14 to: 17) . #foo: }. 
		#badMessage1 . 
		#RBRefactoryTestDataApp})! !

!RBRemoveSenderMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveSenderIntoCascaded2Message
	| refactoring transformedMethod afterRefactoring1 afterRefactoring2 |
	afterRefactoring1 := self parseMethod: 'inlineMethod
	| temp |
	self foo.
	temp := self bar.
	^ temp'.
	afterRefactoring2 := self parseMethod: 'inlineMethod
	| temp |
	temp := self
		        foo;
		        bar.
	^ temp'.
	self proceedThroughWarning: 
		[ refactoring := self createRefactoringWithArguments: 
			{ { (33 to: 62) . #inlineMethod } . 
			#inlineMethod . 
			#RBRefactoryTestDataApp}.
		self setupInlineExpressionFor: refactoring toReturn: false.
		self executeRefactoring: refactoring ].
	transformedMethod := ((refactoring model classNamed: #RBRefactoryTestDataApp) 
	parseTreeFor: #inlineMethod).
	self assert: (transformedMethod = afterRefactoring1 or: [ transformedMethod = afterRefactoring2])! !

!RBRemoveSenderMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testIsDirectlyUsed
	| refactoring methodName |
	methodName := ('caller', '2') asSymbol.
	refactoring := self createRefactoringWithArguments: 
		{ { (58 to: 73) . #foo: } . 
		methodName . 
		#RBRefactoryTestDataApp }.
	self setupInlineExpressionFor: refactoring toReturn: false.
	self flag: 'TODO: refactoring2'.
"	self shouldFail: refactoring."! !

!RBRemoveSenderMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantSelector
	self shouldFail: (self createRefactoringWithArguments:  
		{{(14 to: 17) . #foo: }. 
		#checkClass1: . 
		#RBRefactoryTestDataApp})! !

!RBRemoveSenderMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveMessageInsideBlock
	| refactoring methodName |
	methodName := ('caller', '1') asSymbol.
	refactoring := self createRefactoringWithArguments: 
		{ { (	90 to: 105) .#printString } . 
			methodName . 
			#RBRefactoryTestDataApp }.
			
	self setupInlineExpressionFor: refactoring toReturn: false.
	self executeRefactoring: refactoring .

	self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: methodName) equals: (self parseMethod: 'caller1
	| anObject |
	anObject := 5.
	self called: anObject + 1
		on1: 
			[:each | 
			^anObject]')! !

!RBRemoveSenderMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testClassDoesNotExist
	
	self shouldFail: (self createRefactoringWithArguments:
		{{(14 to: 17) . #byteAt:} . 
		#methodBefore .
		#RBMessageSendTransformationTest})! !

!RBRemoveSenderMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRemoveSimpleSenderOfMessage
	| refactoring methodName transformedMethod afterRefactoring1 afterRefactoring2 |
	afterRefactoring1 := self parseMethod: 'caller1
	| anObject arg1 |
	anObject := 5.
	arg1 := anObject + 1'.
	afterRefactoring2 :=  self parseMethod: 'caller1
	| anObject |
	anObject := 5'.
	methodName := ('caller', '1') asSymbol.
	refactoring := self createRefactoringWithArguments:  
			{{(	40 to: 120) . #called:on1:} . 
			methodName . 
			#RBRefactoryTestDataApp}.
	self setupInlineExpressionFor: refactoring toReturn: false.
	self executeRefactoring: refactoring .
	transformedMethod := ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: methodName) .
	self assert: (transformedMethod = afterRefactoring1 or: [transformedMethod = afterRefactoring2 ])
	
! !

!RBRemoveSenderMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters

	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRemoveSenderRefactoring .
					  #constructor -> #remove:inMethod:forClass: .
					  #index -> 1};
		addCase: { #rbClass -> RBRemoveMessageSendTransformation .
					  #constructor -> #messageSend:inMethod:inClass: .
					  #index -> 2};
		yourself! !

!RBRemoveSenderRefactoring commentStamp: ''!
I'm a refactoring for remove a method call.

Example
-------
```
| refactoring options |
refactoring := RBRemoveSenderRefactoring 
			remove: (	90 to: 105)
			inMethod: #caller1
			forClass: RBRefactoryTestDataApp.
options := refactoring options copy.
options at: #inlineExpression put: [:ref :string | false].
refactoring options: options.
refactoring execute.
```

Before refactoring:

```
RBRefactoryTestDataApp >> caller1
	| anObject |
	anObject := 5.
	self called: anObject + 1
		on1: 
			[:each | 
			each printString.
			^anObject]
```

After refactoring:
```
RBRefactoryTestDataApp >> caller1
	| anObject |
	anObject := 5.
	self called: anObject + 1
		on1: 
			[:each | 
			^anObject]
```
!
!RBRemoveSenderRefactoring methodsFor: 'removing' stamp: ''!
remove: anInterval inMethod: aSelector forClass: aClass 
	sourceSelector := aSelector.
	class := self classObjectFor: aClass.
	sourceInterval := anInterval! !

!RBRemoveSenderRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self inlineParseTree.
	self renameConflictingTemporaries.
	self renameSelfReferences.
	self
		renameConflictingTemporaries;
		insertInlinedMethod;
		compileMethod! !

!RBRemoveSenderRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition withBlock: [class ifNil: 
			[self refactoringError: 'Invalid class name']. true]) &
	(RBCondition definesSelector: sourceSelector in: class) 
		& (RBCondition withBlock: 
					[self findSelectedMessage.
					"self parseInlineMethod."
					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])! !

!RBRemoveSenderRefactoring methodsFor: 'transforming' stamp: ''!
inlineClassName

	^ 'Object'! !

!RBRemoveSenderRefactoring methodsFor: 'transforming' stamp: ''!
findSelectedMessage
	super findSelectedMessage.
	sourceMessage isDirectlyUsed
		ifTrue: [ self refactoringFailure: 'The sender is directly used' ].! !

!RBRemoveSenderRefactoring methodsFor: 'accessing' stamp: ''!
inlineParseTree

	| aSymbol |
	aSymbol := sourceMessage selector.
	^ inlineParseTree ifNil: [inlineParseTree := RBMethodNode 
		selector:  aSymbol
		arguments: ( (1 to: aSymbol numArgs) collect: [ :e | RBVariableNode named: 'arg', e asString ])
		body: ( RBSequenceNode statements: #())]! !

!RBRemoveSenderRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' remove: '.
	sourceInterval storeOn: aStream.
	aStream
		nextPutAll: ' inMethod: #';
		nextPutAll: sourceSelector;
		nextPutAll: ' forClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveSenderRefactoring class methodsFor: 'instance creation' stamp: ''!
remove: anInterval inMethod: aSelector forClass: aClass 
	^ self new 
		remove: anInterval
		inMethod: aSelector
		forClass: aClass! !

!RBRemoveSenderRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk remove: anInterval inMethod: aSelector forClass: aClass 
	^ self new
		model: aRBSmalltalk;
		remove: anInterval
			inMethod: aSelector
			forClass: aClass;
		yourself! !

!RBRemoveSubtreeTransformation commentStamp: ''!
Removes a subtree from a method. This is a first step on providing small AST tranformations. It might replace the message send, assignment, return, etc. transformations proposed by other tools. This transformation can also be reused by more complex ones, such as Extract Method.

Usage:
| transformation |
transformation := (RBRemoveSubtreeTransformation
		code: 'selector := aSelector'
		from: #selector:from:
		in: #RBRemoveMethodTransformation)
		transform. 
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the class and method exist
- the code from which the subtree will be extracted should be parseable!
!RBRemoveSubtreeTransformation methodsFor: 'api' stamp: ''!
code: aString from: aSelector in: aClassName

	self className: aClassName.
	selector := aSelector.
	sourceCode := aString! !

!RBRemoveSubtreeTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition definesSelector: selector in: self definingClass)
		&
			(RBCondition
				withBlock: [ | tree |
					tree := self parserClass
						parseExpression: sourceCode
						onError:
							[ :string :pos | self refactoringError: 'Invalid source to extract - ' , string ].
					tree
						ifNil: [ self refactoringError: 'Invalid source to extract - ' , sourceCode ].
					(tree isSequence and: [ tree statements isEmpty ])
						ifTrue: [ self refactoringError: 'Selected code to extract is empty' ].
					tree := ((self definingClass parseTreeFor: selector)
						extractSubtreeWith: sourceCode)
						ifNil: [ self
								refactoringError: 'Could not extract code from method ' , selector ].
					true ])! !

!RBRemoveSubtreeTransformation methodsFor: 'private' stamp: ''!
removeSubtree: aTree in: aMethodTree
	^ [ self parseTreeRewriterClass
		replaceStatements: aTree formattedCode
		with: ''
		in: aMethodTree
		onInterval: aTree sourceInterval ]
		on: Error
		do: [ self parseTreeRewriterClass
				replace: aTree formattedCode
				with: ''
				in: aMethodTree
				onInterval: aTree sourceInterval ]! !

!RBRemoveSubtreeTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' code: ''';
		nextPutAll: sourceCode;
		nextPutAll: ''' from: ''';
		nextPutAll: selector;
		nextPutAll: ''' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveSubtreeTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	| parseTree |
	"execute in terms of nodes and not in parserewriter"
	"suggest remove similar code here"
	parseTree := self definingClass parseTreeFor: selector.
	parseTree ifNil: [ ^ self ].
	
	"Halt now."
	(parseTree extractSubtreeWith: sourceCode)
		ifNotNil: [ :subtree |
			parseTree removeSubtree: subtree.
			self definingClass compileTree: parseTree ]
		ifNil: [ ^ self ].
	
	
	"(subtree := parseTree extractSubtreeWith: sourceCode) ifNil: [ ^ self ].	
	parseTree := parseTree removeSubtree: subtree.
	self definingClass compileTree: parseTree"! !

!RBRemoveSubtreeTransformation class methodsFor: 'api' stamp: ''!
code: aString from: aSelector in: aClass

	^ self new
		code: aString
		from: aSelector
		in: aClass;
		yourself! !

!RBRemoveSubtreeTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel code: aString from: aSelector in: aClass

	^ self new
		model: aRBModel;
		code: aString
		from: aSelector
		in: aClass;
		yourself! !

!RBRemoveSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testEmptyCode
	| transformation |
	transformation := (RBRemoveSubtreeTransformation code: '' from: #one in: self changeMock name) transform.
	self assertEmpty: transformation model changes changes.

	self shouldFail: (RBRemoveSubtreeTransformation code: '' from: #selector:from: in: #RBRemoveMethodTransformation) asRefactoring! !

!RBRemoveSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| transformation class |
	transformation := (RBRemoveSubtreeTransformation 
							code: 'selector := aSelector' 
							from: #selector:from:
							in: #RBRemoveMethodTransformation)
							asRefactoring transform. 
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: #RBRemoveMethodTransformation.
	self assert: (class directlyDefinesMethod: #selector:from:).
	self assert: (class parseTreeFor: #selector:from:) body statements size equals: 1! !

!RBRemoveSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testTransform
	| transformation class |
	transformation := (RBRemoveSubtreeTransformation code: '^ 1' from: #one in: self changeMock name) transform.

	self assert: transformation model changes changes size equals: 1.

	class := transformation model classNamed: self changeMock name asSymbol.
	self assert: (class directlyDefinesMethod: #one).
	self assertEmpty: (class parseTreeFor: #one) body statements! !

!RBRemoveSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testExtractFailure
	| transformation |
	transformation := (RBRemoveSubtreeTransformation code: ':= anInterval' from: #one in: self changeMock name) transform.
	self assertEmpty: transformation model changes changes.

	self shouldFail: (RBRemoveSubtreeTransformation code: ':= aSelector' from: #selector:from: in: #RBRemoveMethodTransformation) asRefactoring! !

!RBRemoveSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist
	| transformation |
	transformation := (RBRemoveSubtreeTransformation code: 'selector := aSelector' from: #two in: self changeMock name) transform.
	self assertEmpty: transformation model changes changes.

	self shouldFail: (RBRemoveSubtreeTransformation code: 'selector := aSelector' from: #selector:for: in: #RBRemoveMethodTransformation) asRefactoring! !

!RBRemoveSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testTransformNotSequenceNode
	| transformation class |
	transformation := RBCompositeTransformation new
		transformations:
			(OrderedCollection
				with: (RBAddMethodTransformation sourceCode: 'printString1 super printString' in: self changeMock name withProtocols: {#accessing})
				with: (RBRemoveSubtreeTransformation code: 'super printString' from: #printString1 in: self changeMock name)).
	transformation transform.

	self assert: transformation model changes changes size equals: 2.

	class := transformation model classNamed: self changeMock name asSymbol.
	self assert: (class directlyDefinesMethod: #printString1).
	self assertEmpty: (class parseTreeFor: #printString1) body statements! !

!RBRemoveTemporaryVariableTransformation commentStamp: ''!
RBRemoveTemporaryVariableRefactoring is responsible for removing temporary variables inside a method. In Pharo, temporary variables can be declared inside blocks as well.

Example: 
| transformation |
transformation := (RBRemoveTemporaryVariableTransformation
	variable: 'transformation'
	inMethod: #testTransform
	inClass: #RBAddTemporaryVariableTransformationTest)
	transform.
(ChangesBrowser changes: transformation model changes changes) open
	
Preconditions:
- Check whether this method has a temporary variable with the given name.

Observations about the transformation:
- The transformation looks for the variable inside blocks too!
!RBRemoveTemporaryVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	^ ( RBCondition
			withBlock: [ self definingClass isNotNil ]
			errorString: 'No such class or trait named ', className asString)
		& ( RBCondition definesSelector: selector in: self definingClass)
		& ( RBCondition
			withBlock: [ self definingMethod allTemporaryVariables includes: variableName ]
			errorString: 'Method named ', selector, ' does not define a temporary variable named ', variableName )
		& ( RBCondition
			withBlock: [ (self definingMethod allArgumentVariables includes: variableName) not ]
			errorString: 'Variable named ', variableName, ' cannot be removed because it is an argument in this method' )! !

!RBRemoveTemporaryVariableTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName inMethod: aSelector inClass: aClass

	self className: aClass.
	selector := aSelector.
	variableName := aVariableName! !

!RBRemoveTemporaryVariableTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' variable: ''';
		nextPutAll: variableName;
		nextPutAll: ''' inMethod: ''';
		nextPutAll: selector;
		nextPutAll: ''' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRemoveTemporaryVariableTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	| methodTree modifiedNode |
	methodTree := self definingMethod.

	modifiedNode := (methodTree allChildren select: [:each | each isSequence])
						detect: [ :sequence | sequence defines: variableName ]
						ifNone: [ nil ].
	
	modifiedNode ifNotNil: [ modifiedNode removeTemporaryNamed: variableName ].

	class compileTree: methodTree! !

!RBRemoveTemporaryVariableTransformation class methodsFor: 'api' stamp: ''!
variable: aString inMethod: aSelector inClass: aClass

	^ self new
		variable: aString
		inMethod: aSelector
		inClass: aClass;
		yourself! !

!RBRemoveTemporaryVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel variable: aString inMethod: aSelector inClass: aClass

	^ self new
		model: aRBModel;
		variable: aString
		inMethod: aSelector
		inClass: aClass;
		yourself! !

!RBRemoveTemporaryVariableTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	refactoring := (RBAddMethodTransformation 
						sourceCode: 'foo
										| temp bar |
										bar := 5.
										temp := bar * bar.
										Transcript show: temp printString; cr.
										^temp * temp'
						in: #RBRemoveTemporaryVariableTransformationTest
						withProtocols: {#accessing})
						asRefactoring transform.
	
	refactoring := (RBRemoveTemporaryVariableTransformation 
						model: refactoring model
						variable: 'temp'
						inMethod: #foo
						inClass: #RBRemoveTemporaryVariableTransformationTest)
						asRefactoring transform.
	
	self assert: refactoring model changes changes size equals: 2.			
	
	class := refactoring model classNamed: #RBRemoveTemporaryVariableTransformationTest.
	self assert: (class directlyDefinesMethod: #foo).		
	self assert: (class parseTreeFor: #foo) temporaries size equals: 1! !

!RBRemoveTemporaryVariableTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBAddMethodTransformation
					sourceCode: 'foo
									| temp bar |
									bar := 5.
									temp := bar * bar.
									Transcript show: temp printString; cr.
									^temp * temp'
					in: self changeMock name
					withProtocols: {#accessing})
					transform.
	
	transformation := (RBRemoveTemporaryVariableTransformation 
				model: transformation model
				variable: 'temp'
				inMethod: #foo
				inClass: self changeMock name)
				transform.
	
	self assert: transformation model changes changes size equals: 2.			
	
	class := transformation model classNamed: self changeMock name.
	self assert: (class directlyDefinesMethod: #one).		
	self assert: (class parseTreeFor: #foo) temporaries size equals: 1! !

!RBRemoveTemporaryVariableTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBRemoveTemporaryVariableTransformation 
							variable: 'temp'
							inMethod: #foofoo
							inClass: #RBRemoveTemporaryVariableTransformationTest)
							asRefactoring ! !

!RBRemoveTemporaryVariableTransformationTest methodsFor: 'tests' stamp: ''!
testClassDoesNotExist

	self shouldFail: (RBRemoveTemporaryVariableTransformation 
							variable: 'temp'
							inMethod: #foo
							inClass: #RBTemporaryVariableTransformationTest)
							asRefactoring ! !

!RBRemoveTemporaryVariableTransformationTest methodsFor: 'tests' stamp: ''!
testVariableDoesNotExist

	self shouldFail: (RBRemoveTemporaryVariableTransformation 
							variable: 'temp123'
							inMethod: #foo
							inClass: #RBRemoveTemporaryVariableTransformationTest)
							asRefactoring ! !

!RBRemoveVariableTransformation commentStamp: ''!
Removes a variable from a class. It does not remove direct accesses to this variable in the class.

Usage:
transformation := (RBRemoveVariableTransformation 
	variable: 'isClassVariable'
	class: #RBVariableTransformation
	classVariable: false)
	transform. 
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the class exists
- the class defines a variable with the given name!
!RBRemoveVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	class := self definingClass theNonMetaClass.

	^ isClassVariable
		ifTrue: [ self preconditionsForClassVariable ]
		ifFalse: [ self preconditionsForInstanceVariable ]! !

!RBRemoveVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditionsForInstanceVariable

	^ (RBCondition definesInstanceVariable: variableName asString in: class) 
		& (RBCondition doesNotAccessInstanceVariable: variableName inHierarchyOf: class showIn: self)! !

!RBRemoveVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditionsForClassVariable
	
	^ (RBCondition isMetaclass: class) not
		& (RBCondition definesClassVariable: variableName in: class)
		& (RBCondition accessesClassVariable: variableName in: class showIn: self)! !

!RBRemoveVariableTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	isClassVariable
		ifTrue: [ self definingClass theNonMetaClass removeClassVariable: variableName ]
		ifFalse: [ self definingClass removeInstanceVariable: variableName ]! !

!RBRenameAndDeprecateClassTransformation commentStamp: ''!
Rename a class but making sure that existing clients not in the system can be migrated later on:
The idea is that 
	the class A is renamed into Anew
	it gets a subclass A that is deprecated. 
	
This way client code using A will be able to load and get all the behavior of Anew. 


Usage:
transformation := (RBRenameAndDeprecateClassTransformation 
				rename: #DANode
				to: #DANodePresenter)
				transform. 
(ChangesBrowser changes: transformation model changes changes) open

!
!RBRenameAndDeprecateClassTransformation methodsFor: 'api' stamp: ''!
className: aClassName newClassName: aNewClassName

	className := aClassName.
	newClassName := aNewClassName! !

!RBRenameAndDeprecateClassTransformation methodsFor: 'private' stamp: ''!
tmpName
	"return the hidden name of the subclass"
	
	^ (#TmpSubclass,className) asSymbol! !

!RBRenameAndDeprecateClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' className ''';
		nextPutAll: className;
		nextPutAll: ''' newClassName: ''';
		nextPutAll: newClassName.
	aStream nextPut: $)! !

!RBRenameAndDeprecateClassTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	^ transformations ifNil: [ 
		transformations := OrderedCollection
			with: (RBAddClassTransformation
						addClass: self tmpName
						superclass: className asSymbol
						subclasses: #()
						category: (self model classNamed: className) category)
			with: (RBRenameClassTransformation new 
						className: className newClassName: newClassName)
			with: (RBRenameClassTransformation new
						className: self tmpName newClassName: className)
			with: (RBDeprecateClassTransformation
						class: className) ]! !

!RBRenameAndDeprecateClassTransformation class methodsFor: 'api' stamp: ''!
rename: aClassName to: aNewClassName

	^ self new
		className: aClassName
		newClassName: aNewClassName! !

!RBRenameAndDeprecateClassTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel rename: aClassName to: aNewClassName 

	^ self new
		model: aRBModel;
		className: aClassName
		newClassName: aNewClassName;
		yourself! !

!RBRenameAndDeprecateClassTransformationTest methodsFor: 'tests' stamp: ''!
testTransform
	| transformation class |
	transformation := (RBRenameAndDeprecateClassTransformation rename: self changeMock name to: #RBRefactoringChangeMock2) transform.

	self assert: transformation model changes changes size equals: 7.

	"old class"
	class := transformation model classNamed: self changeMock name asSymbol.
	self deny: class isNil.
	self assertEmpty: class selectors.
	self assert: class superclass name equals: #RBRefactoringChangeMock2.
	self assert: class comment equals: 'Deprecated!!!!!! Use superclass'.

	"new class as a superclass"
	class := transformation model classNamed: #RBRefactoringChangeMock2.
	self denyEmpty: class selectors.

	"temporary class, should not exist"
	class := transformation model classNamed: #TmpSubclass , self changeMock name asSymbol.
	self assert: class isNil! !

!RBRenameArgumentOrTemporaryRefactoring commentStamp: ''!
I am a refactoring for renaming temporary variables.
This can be applied to method arguments as well.

The variable declaration and all references in this method are renamed.

My precondition verifies that the new name is a valid variable name and not an existing instance or a class variable name!
!RBRenameArgumentOrTemporaryRefactoring methodsFor: 'tranforming' stamp: ''!
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 asString , ' isn''t a valid variable' ].
	variableNode name = oldName
		ifFalse: [ self refactoringFailure: 'Invalid selection' ].
	definingNode := variableNode whoDefines: oldName.
	definingNode ifNil: [ self refactoringFailure: oldName asString , ' isn''t defined by the method' ].
	self renameNode: definingNode.
	class compileTree: parseTree! !

!RBRenameArgumentOrTemporaryRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition
		withBlock: [ | methodSource |
			interval first > interval last
				ifTrue: [ self refactoringFailure: 'You must select a 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 ]) & (RBCondition isValidInstanceVariableName: newName for: class) & (RBCondition definesSelector: selector in: class)
		& (RBCondition definesInstanceVariable: newName in: class) not & (RBCondition definesClassVariable: newName in: class) not! !

!RBRenameArgumentOrTemporaryRefactoring methodsFor: 'tranforming' stamp: ''!
renameNode: aParseTree
	(aParseTree whoDefines: newName)
		ifNotNil: [ self refactoringError: newName asString , ' is already defined' ].
	(aParseTree allDefinedVariables includes: newName)
		ifTrue: [ self refactoringError: newName asString , ' is already defined' ].
	(self parseTreeRewriterClass rename: oldName to: newName) executeTree: aParseTree! !

!RBRenameArgumentOrTemporaryRefactoring methodsFor: 'initialization' stamp: ''!
class: aClass selector: aSelector interval: anInterval newName: aString 
	class := self classObjectFor: aClass.
	selector := aSelector.
	interval := anInterval.
	newName := aString! !

!RBRenameArgumentOrTemporaryRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' renameTemporaryFrom: '.
	interval storeOn: aStream.
	aStream
		nextPutAll: ' to: ''';
		nextPutAll: newName;
		nextPutAll: ''' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll: selector.
	aStream nextPut: $)! !

!RBRenameArgumentOrTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''!
renameTemporaryFrom: anInterval to: newName in: aClass selector: aSelector 
	^ self new
		class: aClass
		selector: aSelector
		interval: anInterval
		newName: newName! !

!RBRenameArgumentOrTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk renameTemporaryFrom: anInterval to: newName in: aClass selector: aSelector 
	^ self new
		model: aRBSmalltalk;
		class: aClass
			selector: aSelector
			interval: anInterval
			newName: newName;
		yourself! !

!RBRenameClassChange commentStamp: ''!
I am a refactory change for a class-rename refactoring. I hold the old and new name.
Executing this change will rename the (global) defined "oldName" class to "newName".!
!RBRenameClassChange methodsFor: 'private' stamp: ''!
executeNotifying: aBlock 

	| undos |
	self changeClass rename: newName.
	undos := changes collect: [ :each | 
		(each renameChangesForClass: oldName asSymbol to: newName asSymbol) 
			executeNotifying: aBlock ].
	^ self copy
		changes: undos reverse;
		rename: newName to: oldName;
		yourself! !

!RBRenameClassChange methodsFor: 'accessing' stamp: ''!
oldName

	^ oldName! !

!RBRenameClassChange methodsFor: 'comparing' stamp: ''!
= aRenameClassChange

	super class = aRenameClassChange class
		ifFalse: [ ^ false ].
	^oldName = aRenameClassChange oldName 
		and: [ newName = aRenameClassChange newName ]! !

!RBRenameClassChange methodsFor: 'comparing' stamp: ''!
hash

	^ (self class hash bitXor: self oldName hash) bitXor:
		  self newName hash! !

!RBRenameClassChange methodsFor: 'accessing' stamp: ''!
changeClass

	^ (onSystemDictionary classNamed: oldName) ifNil: [ 
		  onSystemDictionary classNamed: newName ]! !

!RBRenameClassChange methodsFor: 'accessing' stamp: ''!
newName

	^ newName! !

!RBRenameClassChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self oldName;
		nextPutAll: ' rename: ';
		print: self newName;
		nextPut: $!!! !

!RBRenameClassChange methodsFor: 'accessing' stamp: ''!
nameToDisplay

	^ self printString! !

!RBRenameClassChange methodsFor: 'initialization' stamp: ''!
rename: oldString to: newString

	oldName := oldString.
	newName := newString! !

!RBRenameClassChange methodsFor: 'accessing' stamp: ''!
whatToDisplayIn: aChangeBrowser

	^ { self }! !

!RBRenameClassChange methodsFor: 'accessing' stamp: ''!
oldVersionTextToDisplay

	^ String streamContents: [ :s | 
			self changes do: [ :c | 	s << c oldVersionTextToDisplay; cr ]]
! !

!RBRenameClassChange methodsFor: 'accessing' stamp: ''!
renameChangesForClass: oldClassName to: newClassName

	| change |
	change := super renameChangesForClass: oldClassName to: newClassName.
	oldName asSymbol = oldClassName ifTrue: [ 
		change rename: newClassName to: newName ].
	^ change! !

!RBRenameClassChange methodsFor: 'accessing' stamp: ''!
textToDisplay

	^ String streamContents: [ :s | 
         s << self printString ; cr.
         self changes do: [ :c | 	s << c textToDisplay; cr ]]
! !

!RBRenameClassChange class methodsFor: 'instance creation' stamp: ''!
rename: oldString to: newString

	^ self new
		  rename: oldString to: newString;
		  yourself! !

!RBRenameClassParametrizedTest methodsFor: 'tests' stamp: ''!
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: (self createRefactoringWithModel: model 
		andArguments: { #Foo1 . #Foo2 }).
	self executeRefactoring: (self createRefactoringWithModel: model 
		andArguments: { #Foo2 . #Foo3 }).
		
	self deny: (model includesClassNamed: #Foo1).
	self deny: (model includesClassNamed: #Foo2).
	self assert: (model includesClassNamed: #Foo3).
	self assert: ((model classNamed: #Foo3) parseTreeFor: #foo) 
		  equals: (self parseMethod: 'foo ^ Foo3').
	self assert: ((model classNamed: #Foo3) parseTreeFor: #objectName) 
		  equals: (self parseMethod: 'objectName ^ #(Foo3)')! !

!RBRenameClassParametrizedTest methodsFor: 'tests' stamp: ''!
testUnmarkRemovedClassIfRenameTargetClass
	"Unmark a removed class if we rename another class to the removed class name.
rename class A to C (class A is marked as removed)
rename class B to A
-> class A is not marked as removed (model includesClassNamed:#A -> true"

	| addClass renameClass classA classB classC |
	
	classA := ('RBClass' , 'ToRename') asSymbol.
	classB := 'TestUnmarkClassRenameSource' asSymbol.
	classC := 'TestUnmarkClassRenameTarget' asSymbol.
	addClass := RBAddClassTransformation
		model: model
		addClass: classB
		superclass: #Object
		subclasses: {}
		category: self class package name.
	self executeRefactoring: addClass asRefactoring.
	self assert: (model includesClassNamed: classA).
	renameClass := self createRefactoringWithModel: model andArguments: { classA . classC }.
	self executeRefactoring: renameClass asRefactoring.
	self deny: (model includesClassNamed: classA).
	self assert: (model includesClassNamed: classC).
	renameClass :=self createRefactoringWithModel: model andArguments: { classB . classA }.
	self executeRefactoring: renameClass asRefactoring.
	self deny: (model includesClassNamed: classB).
	self assert: (model includesClassNamed: classC).
	self assert: (model includesClassNamed: classA)! !

!RBRenameClassParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameClass
	| refactoring class classA classB classC aModel |
	
	classA := ('RBClass', 'ToRename') asSymbol.
	classB := ('RBNew', 'ClassName') asSymbol.
	classC := #RBSubclassOfClassToRename.
	
	refactoring := self createRefactoringWithArguments: { classA . classB }.
	self executeRefactoring: refactoring.
	
	aModel := refactoring model.
	self assert: ((aModel classNamed: classB) parseTreeFor: #method1) 		
		  		equals: (self parseMethod: 'method1
	^self method2').
	self deny: (aModel includesClassNamed: classA).
	class := aModel classNamed: classC.
	self assert: class superclass equals: (aModel classNamed: classB).
	self assert: (class parseTreeFor: #symbolReference) 
				equals: (self parseMethod: 'symbolReference
								^#RBNewClassName').
	self assert: (class parseTreeFor: #reference) 
				equals: (self parseMethod: 'reference
								^RBNewClassName new')! !

!RBRenameClassParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameClassFromTrait
	| refactoring class classA classB classC aModel |
	
	classA := ('RBClass', 'ToRename') asSymbol.
	classB := ('RBNew', 'ClassName') asSymbol.
	classC := #RBDummy.
	refactoring := self createRefactoringWithArguments: { classA . classB }.
	self executeRefactoring: refactoring.
	aModel := refactoring model.
	self assert: (aModel includesClassNamed: classB).
	self deny: (aModel includesClassNamed: classA).
	class := aModel classNamed: classC.
	self assert: (class parseTreeFor: #methodFromTrait) 
				equals: (self parseMethod: 'methodFromTrait
	RBNewClassName justForTest').
	self assert: ((refactoring model classNamed: #RBClassUsingSharedPoolForTestData) methodFor: #methodFromTrait) modelClass name equals: #RBDummy! !

!RBRenameClassParametrizedTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| refactoring class |
	model 	defineClass: 'Object subclass: #Foo
		instanceVariableNames: ''a''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: #''Refactoring2-Refactorings-Tests'''.
	class := model classNamed: #Foo.
	class compile: 'foo	^Object' classified: #(#accessing);
			compile: 'objectName ^#(Object)' classified: #(#accessing).
			
	refactoring := self createRefactoringWithModel: model andArguments: { #Object . #Thing }.
	
	self executeRefactoring: refactoring.
	
	self assert: (model includesClassNamed: #Thing).
	self deny: (model includesClassNamed: #Object).
	self assert: (class parseTreeFor: #foo) 
		  equals: (self parseMethod: 'foo ^Thing').
	self assert: (class parseTreeFor: #objectName) 
		  equals: (self parseMethod: 'objectName ^#(Thing)').
	self assert: class superclass name equals: #Thing! !

!RBRenameClassParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor
	^ #rename:to:! !

!RBRenameClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadName
	self shouldFail: (self createRefactoringWithArguments: 
		{ #RBLintRuleTestData . self objectClassVariable }).
	self shouldFail: (self createRefactoringWithArguments:   
		{ #RBLintRuleTestData . #'Ob ject' })! !

!RBRenameClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExistingName
	self shouldFail: 
		(self createRefactoringWithArguments:  { self class name . #Object })! !

!RBRenameClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMetaClassFailure

	self shouldFail: 
		(self createRefactoringWithArguments: { self class class name . #Foo })! !

!RBRenameClassParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRenameClassRefactoring };
		addCase: { #rbClass -> RBRenameClassTransformation };
		yourself! !

!RBRenameClassRefactoring commentStamp: ''!
I am a refactoring for renaming a class.

My preconditions verify, that the old class exists (in  the current namespace) and that the new class name is valid and not yet used as a global variable name 

The refactoring transformation will replace the current class and its definition with the new class name. And update all references in all methods in this namespace, to use the new name. Even the definition for subclasses of the old class will be changed.

Example
---------------

	(RBRenameClassRefactoring rename: 'RBRenameClassRefactoring' to: 'RBRenameClassRefactoring2') execute!
!RBRenameClassRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self model 
		renameClass: class
		to: newName
		around: [self renameReferences]! !

!RBRenameClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^((RBCondition withBlock: [class notNil and: [class isMeta not]]) 
			& (RBCondition isValidClassName: newName) 
			& (RBCondition isGlobal: newName in: self model) not) |
			(RBCondition withBlock: [ self refactoringFailure: newName , ' is not a valid class name'])! !

!RBRenameClassRefactoring methodsFor: '*Epicea-Refactorings' stamp: ''!
asEpiceaEvent
	^ EpRenameClassRefactoring 
		rename: className
		to: newName! !

!RBRenameClassRefactoring methodsFor: 'transforming' stamp: ''!
renameReferences
	| replacer |
	replacer := (self parseTreeRewriterClass 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: '*Epicea-Refactorings' stamp: ''!
propagateTransformation
	self renameReferences! !

!RBRenameClassRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' rename: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' to: #';
		nextPutAll: newName;
		nextPut: $)! !

!RBRenameClassRefactoring methodsFor: 'initialization' stamp: ''!
className: aName newName: aNewName 
	className := aName asSymbol.
	class := self model classNamed: className.
	newName := aNewName asSymbol! !

!RBRenameClassRefactoring class methodsFor: 'instance creation' stamp: ''!
rename: aClassName to: aNewName
	^ self new 
		className: aClassName 
		newName: aNewName! !

!RBRenameClassRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk rename: aClass to: aNewName 
	^ self new
		model: aRBSmalltalk;
		className: aClass newName: aNewName;
		yourself! !

!RBRenameClassTransformation commentStamp: ''!
Renames a class and all the references to this class as well

Usage:
| transformation |
transformation := (RBRenameClassTransformation
				rename: #RBDummyClassToRename
				to: #RBNewDummyClassName)
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
- the class must exist
- the new class name should be a valid name: not a reserved name, or the name of an existing class variable in the hierarchy!
!RBRenameClassTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition
		withBlock: [ self definingClass notNil and: [ self definingClass isMeta not ] ])
		& (RBCondition isValidClassName: newClassName)
		& (RBCondition isGlobal: newClassName in: self model) not
		&
			(RBCondition
				withBlock: [ | replacer |
					replacer := (self parseTreeRewriterClass
						replaceLiteral: className
						with: newClassName)
						replace: className with: newClassName;
						replaceArgument: newClassName
							withValueFrom: [ :aNode | 
							self
								refactoringError: newClassName , ' already exists within the reference scope' ];
						yourself.
					self model
						allReferencesToClass: self definingClass
						do: [ :method | 
							(method modelClass hierarchyDefinesVariable: newClassName)
								ifTrue: [ self
										refactoringError:
											newClassName , ' is already defined in hierarchy of '
												, method modelClass printString ].
							self
								convertMethod: method selector
								for: method modelClass
								using: replacer ].
					true ])
		|
			(RBCondition
				withBlock: [ self refactoringError: newClassName , ' is not a valid class name' ])! !

!RBRenameClassTransformation methodsFor: 'api' stamp: ''!
className: aClassName newClassName: aNewClassName

	self className: aClassName asSymbol.
	newClassName := aNewClassName asSymbol.! !

!RBRenameClassTransformation methodsFor: 'private' stamp: ''!
renameReferences

	| replacer |
	replacer := (self parseTreeRewriterClass
				replaceLiteral: className with: newClassName)
				replace: className with: newClassName;
				"replaceArgument: newClassName withValueFrom: 
					[ :aNode | self refactoringError: newClassName , ' already exists within the reference scope'];" "it shouldnt raise an error at the transformation level"
				yourself.
				
	self model
		allReferencesToClass: self definingClass
		do: [ :method | 
			(method modelClass hierarchyDefinesVariable: newClassName) 
				"ifTrue: [self refactoringError: newClassName,
								' is already defined in hierarchy of ', method modelClass printString]."
				ifFalse: [ self 
					convertMethod: method selector
					for: method modelClass
					using: replacer ]]! !

!RBRenameClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' className ''';
		nextPutAll: className;
		nextPutAll: ''' newClassName: ''';
		nextPutAll: newClassName.
	aStream nextPut: $)! !

!RBRenameClassTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self model 
		renameClass: self definingClass
		to: newClassName
		around: [self renameReferences]! !

!RBRenameClassTransformation class methodsFor: 'api' stamp: ''!
rename: aClassName to: aNewClassName

	^ self new
		className: aClassName
		newClassName: aNewClassName! !

!RBRenameClassTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel rename: aClassName to: aNewClassName 

	^ self new
		model: aRBModel;
		className: aClassName
		newClassName: aNewClassName;
		yourself! !

!RBRenameClassVariableChange commentStamp: ''!
I am a refactory change for a class variable renaming. The RBRefactory api is implemented in my super class, I just define
the concrete "classvariable" renaming.!
!RBRenameClassVariableChange methodsFor: 'private' stamp: ''!
addNewVariable
	(changeFactory addClassVariable: newName to: self changeClass)
		execute! !

!RBRenameClassVariableChange methodsFor: 'private' stamp: ''!
copyOldValuesToNewVariable

	| oldValue |
	oldValue := self changeClass classPool at: oldName ifAbsent: [ nil ].
	self changeClass classPool at: newName asSymbol put: oldValue! !

!RBRenameClassVariableChange methodsFor: 'printing' stamp: ''!
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: ''!
removeOldVariable
	(changeFactory removeClassVariable: oldName from: self changeClass)
		execute! !

!RBRenameClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	self shouldFail: 
		(self createRefactoringWithArguments: 
			{ #foo . 
			#newFoo . 
			#RBBasicLintRuleTestData })! !

!RBRenameClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testAlreadyExistingName
	self shouldFail: 
		(self createRefactoringWithArguments:
			{ #RecursiveSelfRule . 
			self objectClassVariable . 
			#RBTransformationRuleTestData})! !

!RBRenameClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameClassVarInSharedPool
	| refactoring class userClass |
	
	refactoring := self createRefactoringWithArguments: 
		{ #Var1 . 
		#VarOne . 
		#RBSharedPoolForTestData}.
	
	self executeRefactoring: refactoring.
	
	class := refactoring model classNamed: #RBSharedPoolForTestData.
	userClass := refactoring model classNamed: #RBClassUsingSharedPoolForTestData.
	
	self assert: (class parseTreeFor: #msg1) equals: (self parseMethod: 'msg1 ^ VarOne').	
	self assert: (class parseTreeFor: #msg2) equals: (self parseMethod: 'msg2 ^ VarOne').	
		self flag: 'TODO : fix in tranform class'
"	self assert: (userClass parseTreeFor: #msg3) equals: (self parseMethod: 'msg3 ^ VarOne').	" ! !

!RBRenameClassVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameClassVar
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ #RecursiveSelfRule . 
		#RSR . 
		#RBTransformationRuleTestData}.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBTransformationRuleTestData.
	self assert: (class directlyDefinesClassVariable: #RSR).
	self deny: (class directlyDefinesClassVariable: #RecursiveSelfRule).
	self
		assert: (class classSide parseTreeFor: #initializeAfterLoad1)
		equals:
			(self
				parseMethod:
					'initializeAfterLoad1
								RSR := self parseTreeSearcher.
								RSR
									addMethodSearches: #(''`@methodName: `@args | `@temps | self `@methodName: `@args'' ''`@methodName: `@args | `@temps | ^self `@methodName: `@args'')
											-> [:aNode :answer | true]').
	self
		assert: (class classSide parseTreeFor: #nuke)
		equals:
			(self
				parseMethod:
					'nuke
								RSR := nil').
	self
		assert: (class parseTreeFor: #checkMethod:)
		equals:
			(self
				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]]')! !

!RBRenameClassVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMetaClassFailure

	self shouldFail: 
		(self createRefactoringWithArguments: 
			{ #RecursiveSelfRule . 
			#Foo . 
			RBTransformationRuleTestData class name asSymbol })! !

!RBRenameClassVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRenameClassVariableRefactoring .
					  #constructor -> #rename:to:in: .
					  #extraArgument -> #() };
		addCase: { #rbClass -> RBRenameVariableTransformation .
					  #constructor -> #rename:to:in:classVariable: .
					  #extraArgument -> #(true) };
		yourself! !

!RBRenameClassVariableRefactoring commentStamp: ''!
I am a refactoring for rename class variables.

I rename the class variable in the class definition and in all methods refering to this variable.

My precondition verifies that the new variable is valid and not yet used in the whole class hierarchy.!
!RBRenameClassVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	class 
		renameClassVariable: variableName
		to: newName
		around: [self renameReferences]! !

!RBRenameClassVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition isMetaclass: class) not 
		& (RBCondition isValidClassVarName: newName asString for: class) 
			& (RBCondition definesClassVariable: variableName asString in: class) 
			& (RBCondition hierarchyOf: class definesVariable: newName asString) not 
			& (RBCondition isGlobal: newName asString in: self model) not! !

!RBRenameClassVariableRefactoring methodsFor: 'accessing' stamp: ''!
newName
	^ newName! !

!RBRenameClassVariableRefactoring methodsFor: 'accessing' stamp: ''!
newName: anObject
	newName := anObject! !

!RBRenameClassVariableRefactoring methodsFor: 'transforming' stamp: ''!
renameReferences
	| replacer methods |
	replacer := self parseTreeRewriterClass 
		rename: variableName
		to: newName
		handler: 
			[ self refactoringError: ('<1s> is already defined as a method or block temporary <n> variable in this class or one of its subclasses' expandMacrosWith: newName) ].

	methods := class methodsUsingClassVariableNamed: variableName.	
	methods do: [ :method | self convertMethod: method selector for: method modelClass using: replacer ]
! !

!RBRenameClassVariableRefactoring methodsFor: 'initialization' stamp: ''!
rename: aVarName to: aName in: aClass
	self variable: aVarName class: aClass.
	newName := aName! !

!RBRenameClassVariableRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' rename: ''';
		nextPutAll: variableName;
		nextPutAll: ''' to: ''';
		nextPutAll: newName;
		nextPutAll: ''' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRenameClassVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
rename: aVarName to: aName in: aClass
	^ self new
		rename: aVarName
		to: aName
		in: aClass! !

!RBRenameClassVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk rename: aVarName to: aName in: aClass 
	^ self new
		model: aRBSmalltalk;
		rename: aVarName
			to: aName
			in: aClass;
		yourself! !

!RBRenameInstanceVariableChange commentStamp: ''!
I am a refactory change for a instance variable renaming. The RBRefactory api is implemented in my super class, I just define
the concrete "instance variable" renaming.!
!RBRenameInstanceVariableChange methodsFor: 'private' stamp: ''!
addNewVariable

	(self changeClass allInstVarNames includes: newName) 
		ifFalse: [ (changeFactory addInstanceVariable: newName to: self changeClass) execute ]! !

!RBRenameInstanceVariableChange methodsFor: 'private' stamp: ''!
copyOldValuesToNewVariable

	self changeClass withAllSubclasses do: [ :class |
		class allInstances 
			do: [ :each | each instVarNamed: newName asString put: (each instVarNamed: oldName asString) ] ]! !

!RBRenameInstanceVariableChange methodsFor: 'printing' stamp: ''!
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: ''!
removeOldVariable

	(self changeClass allInstVarNames includes: oldName) ifTrue: [ 
		(changeFactory
			 removeInstanceVariable: oldName
			 from: self changeClass) execute ]! !

!RBRenameInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName

	self shouldFail: (self createRefactoringWithArguments: 
		{ 'foo' . 'newFoo' . #RBBasicLintRuleTestData })! !

!RBRenameInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameInstVar
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ 'classBlock' . 
		'asdf' . 
		#RBBasicLintRuleTestData}.
	
	self executeRefactoring: refactoring.
	
	class := refactoring model classNamed: #RBBasicLintRuleTestData.
	self assert: (class directlyDefinesInstanceVariable: 'asdf').
	self deny: (class directlyDefinesInstanceVariable: 'classBlock').
	self
		assert:
			(class parseTreeFor: #checkClass:)
				equals:
					(self
						parseMethod:
							'checkClass: aSmalllintContext 
								^asdf value: aSmalllintContext value: result').
	self
		assert:
			(class parseTreeFor: #initialize)
				equals:
					(self
						parseMethod:
							'initialize
	super initialize.
	self anInstVar: 1.
	asdf := [:context :aResult | ].
	methodBlock := [:context :aResult | ].
	self resultClass: RBSelectorEnvironment')! !

!RBRenameInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameInstVarFromTrait
	| refactoring class |
	
	refactoring := self createRefactoringWithArguments: 
		{ 'var1' . 
		'var11' . 
		#RBDummy }.
		
	self executeRefactoring: refactoring.
	
	class := refactoring model classNamed: #RBDummy.
	self assert: (class directlyDefinesInstanceVariable: 'var11').
	self deny: (class directlyDefinesInstanceVariable: 'var1').
	self
		assert: (class parseTreeFor: #var1)
		equals: (self parseMethod: 'var1 ^ var11').
	class := refactoring model classNamed: #RBClassUsingSharedPoolForTestData.
	self flag: 'TODO: for transformation'
	"self
		assert: (class parseTreeFor: #msg1)
		equals: (self parseMethod: 'msg1 var11 asString'). "
	"TODO"
	"self
		assert: (class parseTreeFor: #msg2)
		equals: (self parseMethod: 'msg2 var11')"! !

!RBRenameInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameInstVarNotAccessors
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ 'result' . 
		'whatever' . 
		#RBBasicLintRuleTestData }.
		
	self executeRefactoring: refactoring.
	
	class := refactoring model classNamed: #RBBasicLintRuleTestData.
	self assert: (class directlyDefinesInstanceVariable: 'whatever').
	self deny: (class directlyDefinesInstanceVariable: 'result').
	
	self deny: (class definesMethod: #whatever).
	self deny: (class definesMethod: #whatever:).
	self assert: (class definesMethod: #result).
! !

!RBRenameInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMetaclassFailure

	self shouldFail: (self createRefactoringWithArguments: 
		{ #RecursiveSelfRule . #Foo . RBTransformationRuleTestData class name })! !

!RBRenameInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testAlreadyExistingName

	self shouldFail: (self createRefactoringWithArguments: 
		{'classBlock' . 'name' . #RBBasicLintRuleTestData } )! !

!RBRenameInstanceVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRenameInstanceVariableRefactoring .
					  #constructor -> #rename:to:in: .
					  #extraArgument -> #() };
		addCase: { #rbClass -> RBRenameVariableTransformation .
					  #constructor -> #rename:to:in:classVariable: .
					  #extraArgument -> #(false) };
		yourself! !

!RBRenameInstanceVariableRefactoring commentStamp: ''!
I am a refactoring for rename instance variables.

I rename the instance variable in the class definition, in all methods refering to this variable and rename the old accessors.

My precondition verifies that the new variable is valid and not yet used in the whole class hierarchy.!
!RBRenameInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
addNewAccessors
	| refactoring |
	refactoring := RBCreateAccessorsForVariableRefactoring
		model: self
		variable: newName asString
		class: class
		classVariable: false.
	refactoring
		createGetterAccessor;
		createSetterAccessor! !

!RBRenameInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
removeOldAccessors
	| oldAccessors |
	oldAccessors := (class allSelectors
		select: [ :each | each = variableName asSymbol or: [ each = (variableName , ':') asSymbol ] ]
		thenCollect: [ :each | class methodFor: each ]) asOrderedCollection.
	oldAccessors do: [ :each | class removeMethod: each selector ]! !

!RBRenameInstanceVariableRefactoring methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	renameAccessors := false! !

!RBRenameInstanceVariableRefactoring methodsFor: 'accessing' stamp: ''!
renameAccessors
	^ renameAccessors! !

!RBRenameInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition isValidInstanceVariableName: newName for: class) 
		& (RBCondition definesInstanceVariable: variableName in: class) 
			& (RBCondition hierarchyOf: class definesVariable: newName) not 
			& (RBCondition isGlobal: newName in: self model) not! !

!RBRenameInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform
	renameAccessors ifTrue: [ 
		self removeOldAccessors 
	].
	
	class renameInstanceVariable: variableName to: newName around: [ self renameReferences ].
	
	renameAccessors ifFalse: [ ^ self ].
	self addNewAccessors.
	self renameAccessorsReferences.! !

!RBRenameInstanceVariableRefactoring methodsFor: '*Epicea-Refactorings' stamp: ''!
asEpiceaEvent
	^ EpRenameInstanceVariableRefactoring 
		rename: variableName
		to: newName
		in: class name! !

!RBRenameInstanceVariableRefactoring methodsFor: 'accessing' stamp: ''!
newName
	^ newName! !

!RBRenameInstanceVariableRefactoring methodsFor: 'refactoring' stamp: ''!
browsedEnvironment
	^ browsedEnvironment ifNil: [ browsedEnvironment := RBBrowserEnvironment new ]! !

!RBRenameInstanceVariableRefactoring methodsFor: 'accessing' stamp: ''!
renameAccessors: anObject
	renameAccessors := anObject! !

!RBRenameInstanceVariableRefactoring methodsFor: 'accessing' stamp: ''!
newName: anObject
	newName := anObject! !

!RBRenameInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
renameReferences
	| replacer classes |
	replacer := self parseTreeRewriterClass 
				rename: variableName
				to: newName
				handler: 
					[self 
						refactoringError: ('<1s> is already defined as a method or block temporary <n> variable in this class or one of its subclasses' 
								expandMacrosWith: newName)].
	classes := class withAllSubclasses, (class isTrait ifTrue: [class users asArray ] ifFalse: [{}]).
	self 
		convertClasses: classes
		select: [:aClass | aClass whichSelectorsReferToInstanceVariable: variableName]
		using: replacer! !

!RBRenameInstanceVariableRefactoring methodsFor: 'initialization' stamp: ''!
rename: aVarName to: aName in: aClass
	self rename: aVarName to: aName in: aClass renameAccessors: false
! !

!RBRenameInstanceVariableRefactoring methodsFor: 'initialization' stamp: ''!
rename: aVarName to: aName in: aClass renameAccessors: aBoolean
	self variable: aVarName class: aClass.
	newName := aName.
	renameAccessors := aBoolean! !

!RBRenameInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
renameAccessorsReferences
	| methods senders |
	methods := (class allSelectors select: [ :each | (class methodFor: each) isNotNil ] thenCollect: [ :each | each ])
		asOrderedCollection.
	senders := (methods
		select: [ :each | (class methodFor: each) source includesSubstring: variableName asString ]
		thenCollect: [ :each | class methodFor: each ]) asOrderedCollection.
	senders
		do: [ :each | each source: (each source copyReplaceAll: variableName asString with: newName asString asTokens: false) ].
	senders
		do: [ :each | 
			(each selector = newName or: [ each selector asString = (newName asString , ':') ])
				ifFalse: [ (model classNamed: class name) compile: each source classified: each protocols ] ]! !

!RBRenameInstanceVariableRefactoring methodsFor: '*Epicea-Refactorings' stamp: ''!
propagateTransformation
	self renameReferences! !

!RBRenameInstanceVariableRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' rename: ''';
		nextPutAll: variableName;
		nextPutAll: ''' to: ''';
		nextPutAll: newName;
		nextPutAll: ''' in: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBRenameInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
rename: aVarName to: aName in: aClass
	^ self new
		rename: aVarName
		to: aName
		in: aClass! !

!RBRenameInstanceVariableRefactoring class methodsFor: '*SystemCommands-VariableCommands' stamp: ''!
classVariableAnalog
	^RBRenameClassVariableRefactoring ! !

!RBRenameInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBNamespace rename: aVarName to: aName in: aClass 
	^ self new
		model: aRBNamespace;
		rename: aVarName
			to: aName
			in: aClass;
		yourself! !

!RBRenameInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
rename: aVarName to: aName in: aClass renameAccessors: aBoolean
	^ self new
		rename: aVarName
		to: aName
		in: aClass
		renameAccessors: aBoolean! !

!RBRenameInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBNamespace rename: aVarName to: aName in: aClass renameAccessors: aBoolean
	^ self new
		model: aRBNamespace;
		rename: aVarName
		to: aName
		in: aClass
		renameAccessors: aBoolean;
		yourself! !

!RBRenameMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameMethodFromTrait
	| refactoring class |
	refactoring := self createRefactoringWithArguments:  
		{ ('just', 'ForTest') asSymbol . RBClassToRename classSide . #justForTest1 . (1 to: 0)}.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #'RBClassToRename class'.
	self assert: (class parseTreeFor: #justForTest1) 
		equals: (self parseMethod: 'justForTest1 ^ 42').
	self assert: ((refactoring model classNamed: #RBDummy) parseTreeFor: #methodFromTrait) equals: (self parseMethod: 'methodFromTrait
	RBClassToRename justForTest1').
	self deny: (class directlyDefinesMethod: ('just', 'ForTest') asSymbol).
	self assert: ((refactoring model classNamed: #RBClassUsingSharedPoolForTestData) methodFor: #methodFromTrait) modelClass name equals: #RBDummy! !

!RBRenameMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameTestMethod1
	| refactoring class |
	refactoring := self createRefactoringWithArguments:  
		{ ('testMethod1') asSymbol . RBRefactoryTestDataApp . #testMethod2 . (1 to: 0) }.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self assert: (class parseTreeFor: #testMethod2) 
		equals: (self parseMethod: 'testMethod2
	^self testMethod2 , ([:each | each testMethod2] value: #(#(#testMethod2) 2 #testMethod2))').
	self assert: ((refactoring model classNamed: #RBBasicLintRuleTestData) parseTreeFor: #classBlock:) 		equals: (self parseMethod: 'classBlock: aBlock
	classBlock := aBlock testMethod2').
	self deny: (class directlyDefinesMethod: ('test' , 'Method1') asSymbol)! !

!RBRenameMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameMethodOnlyInSomePackages
	| refactoring class |
	model := (RBClassModelFactory rbNamespace onEnvironment: (RBPackageEnvironment packageName: 'Refactoring-Tests-Core')).
	refactoring := self createRefactoringWithModel: model andArguments:  
		{ ('check', 'Class:') asSymbol . RBBasicLintRuleTestData . #checkClass1: . (1 to: 1) }.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #RBBasicLintRuleTestData.
	self assert: (class parseTreeFor: #checkClass1:) 
		equals: (self parseMethod: 'checkClass1: aSmalllintContext 
	^classBlock value: aSmalllintContext value: result').
	! !

!RBRenameMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRenamePermuteArgs
	| refactoring class |
	refactoring := self createRefactoringWithArguments:  
		{ ('rename:' , 'two:') asSymbol . RBRefactoryTestDataApp . 
		('rename:' , 'two:') asSymbol . #(2 1 ) }.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self assert: (class parseTreeFor: ('rename:' , 'two:') asSymbol) 
		equals: (self parseMethod: 'rename: argumentMethod two: this ^self printString, this, argumentMethod').
	self assert: (class parseTreeFor: #exampleCall) 
		equals: (self parseMethod: 'exampleCall <sampleInstance> ^self rename: 2 two: 1')! !

!RBRenameMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testWithNonCorrectNumberOfArgs
	self shouldFail: (self createRefactoringWithArguments:  
		{ #checkClass: . RBBasicLintRuleTestData . #checkClass . (1 to: 1) })! !

!RBRenameMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMultipleSelectors
	self shouldWarn: (self createRefactoringWithArguments:  
		{ #checkClass: . RBBasicLintRuleTestData . #foo: . (1 to: 1) })! !

!RBRenameMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRenamePrimitive
	| refactoring count |
	count := 0.
	model allReferencesTo: #basicAt:put: do: [:method | count := count + 1].
	refactoring := self createRefactoringWithModel: model
		andArguments: { #basicAt:put: . Object . ('at:' , 'bar:') asSymbol . (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 equals: 0! !

!RBRenameMethodParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor
	^ #renameMethod:in:to:permutation:! !

!RBRenameMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameMethodPermuteArgs
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ ('demoRenameMethod:' , 'PermuteArgs:') asSymbol . RBRefactoryTestDataApp .
		('demoRenameMethod:' , 'PermuteArgs:') asSymbol . #(2 1) }.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self
		assert:
			(class parseTreeFor: ('demoRenameMethod:' , 'PermuteArgs:') asSymbol)
				equals:
					(self
						parseMethod:
							'demoRenameMethod: arg2 PermuteArgs: arg1 self do: arg1.
	self do: arg2.
	^ arg1 > arg2').
	self
		assert:
			(class parseTreeFor: #demoExampleCall)
				equals: (self parseMethod: 'demoExampleCall ^self demoRenameMethod: 2 PermuteArgs: 1')! !

!RBRenameMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameTestMethod
	| refactoring class |
	refactoring := self createRefactoringWithArguments:  
		{ ('rename' , 'ThisMethod:') asSymbol . RBRefactoryTestDataApp . #renameThisMethod2: . (1 to: 1) }.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	class := refactoring model classNamed: #RBRefactoryTestDataApp.
	self assert: (class parseTreeFor: #renameThisMethod2:) equals: (self parseMethod: 'renameThisMethod2: anArg
	^self').
	self assert: (class parseTreeFor: #callMethod) equals: (self parseMethod: 'callMethod
	^(self renameThisMethod2: 5)').
	self assert: (class parseTreeFor: #symbolReference) equals: (self parseMethod: 'symbolReference
		^ #(#renameThisMethod2: #(4 #renameThisMethod2:))').
	self deny: (class directlyDefinesMethod: ('rename' , 'ThisMethod:') asSymbol)! !

!RBRenameMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExistingSelector
	self shouldFail: (self createRefactoringWithArguments: 
		{ #checkClass: . RBBasicLintRuleTestData . #runOnEnvironment: . (1 to: 1) })! !

!RBRenameMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRenameMethodRefactoring };
		addCase: { #rbClass -> RBRenameMethodTransformation };
		yourself! !

!RBRenameMethodRefactoring commentStamp: ''!
I am a refactoring operation for renaming methods.

The new method name has to have the same number of arguments, but the order of arguments can be changed.

My preconditions verify that the number of arguments is the same and that the new method name isn't already used.

All references in senders of the old method are changed, either the method name only or the order of the supplied arguments.

Example
--------
There are two ways to rename a method, one of them is rename all senders of method:
```
(RBRenameMethodRefactoring 
		renameMethod: ('check', 'Class:') asSymbol
		in: RBBasicLintRuleTestData
		to: #checkClass1:
		permutation: (1 to: 1)) execute.
```
And the other is rename the method only in specific packages:
```
|refactoring|
refactoring :=RBRenameMethodRefactoring 
		renameMethod: ('check', 'Class:') asSymbol
		in: RBBasicLintRuleTestData
		to: #checkClass1:
		permutation: (1 to: 1).
refactoring searchInPackages:  #(#'Refactoring-Tests-Core').
refactoring execute
```!
!RBRenameMethodRefactoring methodsFor: 'transforming' stamp: ''!
parseTreeRewriter
	| rewriteRule oldString newString |
	oldString := self buildSelectorString: oldSelector.
	newString := self buildSelectorString: newSelector
				withPermuteMap: permutation.
	rewriteRule := self hasPermutedArguments 
				ifTrue: [self parseTreeRewriterClass new]
				ifFalse: [self parseTreeRewriterClass replaceLiteral: oldSelector with: newSelector].
	rewriteRule replace: '``@object ' , oldString
		with: '``@object ' , newString.
	^rewriteRule! !

!RBRenameMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	| newCondition |
	newCondition := (RBCondition 
							withBlock: [ newSelector = oldSelector ]
							errorString: 'The selector name has <1?not:> changed <1?:to #', newSelector, '>') 
						& (RBCondition 
							withBlock: [permutation asArray ~= (1 to: oldSelector numArgs) asArray]
							errorString: 'The arguments are <1?:not >permuted').
	^newCondition | super preconditions! !

!RBRenameMethodRefactoring methodsFor: 'preconditions' stamp: ''!
myConditions
	^RBCondition withBlock: [oldSelector numArgs = newSelector numArgs]
		errorString: newSelector printString 
				, ' doesn''t have the correct number of arguments.'! !

!RBRenameMethodRefactoring methodsFor: '*Epicea-Refactorings' stamp: ''!
asEpiceaEvent
	^ EpRenameMethodRefactoring 
		renameMethod: oldSelector 
		in: class name
		to: newSelector! !

!RBRenameMethodRefactoring methodsFor: 'testing' stamp: ''!
implementorsCanBePrimitives
	^self hasPermutedArguments not! !

!RBRenameMethodRefactoring methodsFor: 'private' stamp: ''!
modifyImplementorParseTree: parseTree in: aClass
	super modifyImplementorParseTree: parseTree in: aClass.
	self renameArgumentsIn: parseTree.! !

!RBRenameMethodRefactoring methodsFor: 'testing' stamp: ''!
hasPermutedArguments

	^ hasPermutedArguments
		ifNil: [ hasPermutedArguments := super hasPermutedArguments ]
		ifNotNil: [ hasPermutedArguments ]! !

!RBRenameMethodRefactoring methodsFor: '*Epicea-Refactorings' stamp: ''!
propagateTransformation
	self renameMessageSends! !

!RBRenameMethodRefactoring methodsFor: 'printing' stamp: ''!
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 class methodsFor: 'instance creation' stamp: ''!
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: ''!
renameMethod: aSelector in: aClass to: newSelector permutation: aMap
	^ self new 
		renameMethod: aSelector
		in: aClass
		to: newSelector
		permutation: aMap! !

!RBRenameMethodTransformation methodsFor: 'accessing' stamp: ''!
parseTreeRewriter
	| rewriteRule oldString newString |
	oldString := self buildSelectorString: oldSelector.
	newString := self buildSelectorString: newSelector
				withPermuteMap: permutation.
	rewriteRule := self hasPermutedArguments 
				ifTrue: [self parseTreeRewriterClass new]
				ifFalse: [self parseTreeRewriterClass replaceLiteral: oldSelector with: newSelector].
	rewriteRule replace: '``@object ' , oldString
		with: '``@object ' , newString.
	^rewriteRule! !

!RBRenameMethodTransformation methodsFor: 'accessing' stamp: ''!
preconditions
	| newCondition |
	newCondition := (RBCondition 
							withBlock: [ newSelector = oldSelector ]
							errorString: 'The selector name has <1?not:> changed <1?:to #', newSelector, '>') 
						& (RBCondition 
							withBlock: [permutation asArray ~= (1 to: oldSelector numArgs) asArray]
							errorString: 'The arguments are <1?:not >permuted').
	^newCondition | super preconditions! !

!RBRenameMethodTransformation methodsFor: 'accessing' stamp: ''!
myConditions
	^RBCondition withBlock: [oldSelector numArgs = newSelector numArgs]
		errorString: newSelector printString 
				, ' doesn''t have the correct number of arguments.'! !

!RBRenameMethodTransformation methodsFor: 'accessing' stamp: ''!
implementorsCanBePrimitives
	^self hasPermutedArguments not! !

!RBRenameMethodTransformation methodsFor: 'accessing' stamp: ''!
modifyImplementorParseTree: parseTree in: aClass
	super modifyImplementorParseTree: parseTree in: aClass.
	self renameArgumentsIn: parseTree.! !

!RBRenameMethodTransformation methodsFor: 'accessing' stamp: ''!
hasPermutedArguments

	^ hasPermutedArguments
		ifNil: [ hasPermutedArguments := super hasPermutedArguments ]
		ifNotNil: [ hasPermutedArguments ]! !

!RBRenameMethodTransformation methodsFor: 'accessing' stamp: ''!
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: $)! !

!RBRenameMethodTransformation class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk renameMethod: aSelector in: aClass to: newSelector permutation: aMap 
	^ self new
		model: aRBSmalltalk;
		renameMethod: aSelector
			in: aClass
			to: newSelector
			permutation: aMap;
		yourself! !

!RBRenameMethodTransformation class methodsFor: 'instance creation' stamp: ''!
renameMethod: aSelector in: aClass to: newSelector permutation: aMap
	^ self new 
		renameMethod: aSelector
		in: aClass
		to: newSelector
		permutation: aMap! !

!RBRenamePackageChange commentStamp: ''!
I am a refactory change for a package renaming. The RBRefactory api is implemented in my super class, I just define the concrete "package" renaming.!
!RBRenamePackageChange methodsFor: 'converting' stamp: ''!
asUndoOperation

	^ changeFactory renamePackageNamed: newName to: oldName! !

!RBRenamePackageChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: oldName;
		nextPutAll: ' renameTo: ';
		print: newName;
		nextPut: $!!! !

!RBRenamePackageChange methodsFor: 'instance creation' stamp: ''!
rename: oldString to: newString

	oldName := oldString.
	newName := newString! !

!RBRenamePackageChange methodsFor: 'accessing' stamp: ''!
changePackage

	^ (browserEnvironment packageAt: oldName ifAbsent: [ nil ]) ifNil: [ 
		  browserEnvironment packageAt: newName ifAbsent: [ nil ] ]! !

!RBRenamePackageChange methodsFor: 'private' stamp: ''!
primitiveExecute

	self changePackage renameTo: newName! !

!RBRenamePackageChange class methodsFor: 'instance creation' stamp: ''!
rename: oldString to: newString

	^ self new
		  rename: oldString to: newString;
		  yourself! !

!RBRenamePackageParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExistingPackage
	self shouldFail: (self createRefactoringWithArguments:  
		{ #'Refactoring-Tests-Core' . #'Refactoring-Tests-Changes' })! !

!RBRenamePackageParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #rename:to:! !

!RBRenamePackageParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadName
	self shouldFail: (self createRefactoringWithArguments:
		{ #'Refactoring-Tests-Core' . #'Refactoring-Tests-Core' })! !

!RBRenamePackageParametrizedTest methodsFor: 'tests' stamp: ''!
testRenamePackage
	| refactoring aModel |
	
	refactoring := (self createRefactoringWithArguments:  
		{ #'Refactoring-Tests-Core' . #'Refactoring-Tests-Core1' }).
	aModel := refactoring model.
	self executeRefactoring: refactoring.
	self assert: (aModel packageNamed: #'Refactoring-Tests-Core') isNil.
	self assert: (aModel packageNamed: #'Refactoring-Tests-Core1') isNotNil.
	! !

!RBRenamePackageParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRenamePackageRefactoring };
		addCase: { #rbClass -> RBRenamePackageTransformation };
		yourself! !

!RBRenamePackageRefactoring commentStamp: ''!
I'm a refactoring to rename a package.

My preconditions verify that the new name is different from the current package name and is a valid name.

I change all the references of the classes that are defined within the package, and if there is a manifest, it is updated with the new name of the package. 

Example
---------
```
(RBRenamePackageRefactoring 
				rename: (self getPackageNamed: #'Refactoring-Tests-Core')
				to: #'Refactoring-Tests-Core1') execute.
```!
!RBRenamePackageRefactoring methodsFor: 'initialization' stamp: ''!
packageName: aName newName: aNewName 
	packageName := aName asSymbol.
	package := self model packageNamed: packageName.
	newName := aNewName asSymbol! !

!RBRenamePackageRefactoring methodsFor: 'transforming' stamp: ''!
transform

	self renamePackage.
	self renameManifestClass.! !

!RBRenamePackageRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions 
	^ super preconditions & (RBCondition withBlock: [ newName = package name ifTrue: 
		[ self refactoringError: 'Use a different name' ].
		true ]) &
	(RBCondition withBlock: [ [RPackage organizer validatePackageDoesNotExist: newName. true]
			on: Error 
			do: [ :e | self refactoringError: e messageText ]
		])
	! !

!RBRenamePackageRefactoring methodsFor: 'transforming' stamp: ''!
renameManifestClass 
	|refactoring manifest|
	manifest := package realPackage packageManifestOrNil.
	manifest ifNotNil: [
	refactoring := RBRenameClassRefactoring 
		model: self model
		rename: manifest
		to: (self manifestClassNameFor: newName).
	self performCompositeRefactoring: refactoring]! !

!RBRenamePackageRefactoring methodsFor: 'transforming' stamp: ''!
renamePackage
	self model renamePackage: package to: newName! !

!RBRenamePackageRefactoring methodsFor: 'transforming' stamp: ''!
manifestClassNameFor: aPackageName
	"Returns a symbol representing a suitable name for a Manifest class for the given package"
	
	^('Manifest', (aPackageName select: [:each | each isAlphaNumeric ])) asSymbol! !

!RBRenamePackageRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' rename: '.
	aStream nextPutAll: package name.
	aStream
		nextPutAll: ' to: #';
		nextPutAll: newName;
		nextPut: $)! !

!RBRenamePackageRefactoring class methodsFor: 'instance creation' stamp: ''!
rename: aString to: aNewName
	^ self new
		packageName: aString newName: aNewName! !

!RBRenamePackageRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk rename: aSymbol to: aNewName 
	^ self new
		model: aRBSmalltalk;
		packageName: aSymbol newName: aNewName;
		yourself! !

!RBRenamePackageTransformation commentStamp: ''!
I'm a refactoring to rename a package.

My preconditions verify that the new name is different from the current package name and is a valid name.

I change all the references of the classes that are defined within the package, and if there is a manifest, it is updated with the new name of the package. 

Usage:
| transformation |
transformation := (RBRenamePackageTransformation
				rename: (self getPackageNamed: #'Refactoring2-Transformations-Tests')
				to: #'Refactoring2-Transformations-Tests1')
				transform.!
!RBRenamePackageTransformation methodsFor: 'executing' stamp: ''!
packageName: aName newName: aNewName 
	packageName := aName asSymbol.
	package := self model packageNamed: packageName.
	newName := aNewName asSymbol! !

!RBRenamePackageTransformation methodsFor: 'executing' stamp: ''!
preconditions 
	^ super preconditions & (RBCondition withBlock: [ newName = package name ifTrue: 
		[ self refactoringError: 'Use a different name' ].
		true ]) &
	(RBCondition withBlock: [ [RPackage organizer validatePackageDoesNotExist: newName. true]
			on: Error 
			do: [ :e | self refactoringError: e messageText ]
		])! !

!RBRenamePackageTransformation methodsFor: 'executing' stamp: ''!
renameManifestClass 
	| manifest |
	manifest := package realPackage packageManifestOrNil.
	manifest ifNotNil: [
	transformations add: ( RBRenameClassTransformation  
		model: self model
		rename: manifest
		to: (self manifestClassNameFor: newName)) ]
! !

!RBRenamePackageTransformation methodsFor: 'executing' stamp: ''!
renamePackage
	self model renamePackage: package to: newName! !

!RBRenamePackageTransformation methodsFor: 'executing' stamp: ''!
manifestClassNameFor: aPackageName
	"Returns a symbol representing a suitable name for a Manifest class for the given package"
	
	^('Manifest', (aPackageName select: [:each | each isAlphaNumeric ])) asSymbol! !

!RBRenamePackageTransformation methodsFor: 'executing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' rename: '.
	aStream nextPutAll: package name.
	aStream
		nextPutAll: ' to: #';
		nextPutAll: newName;
		nextPut: $)! !

!RBRenamePackageTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	transformations := OrderedCollection new.
	
	self 
		renamePackage;
		renameManifestClass.
		
	^ transformations

	! !

!RBRenamePackageTransformation class methodsFor: 'instance creation' stamp: ''!
rename: aString to: aNewName
	^ self new
		packageName: aString newName: aNewName! !

!RBRenamePackageTransformation class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk rename: aSymbol to: aNewName 
	^ self new
		model: aRBSmalltalk;
		packageName: aSymbol newName: aNewName;
		yourself! !

!RBRenameTemporaryParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameArg
	| refactoring |
	refactoring := self createRefactoringWithArguments: { { (7 to: 13) . #aString } .
		'asdf' . #RBLintRuleTestData . #name: }.
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBLintRuleTestData) parseTreeFor: #name:) equals: (self parseMethod: 'name: asdf 
	name := asdf')! !

!RBRenameTemporaryParametrizedTest methodsFor: 'tests' stamp: ''!
testRenameTemporary
	| refactoring |
	refactoring := self createRefactoringWithArguments: { {(15 to: 19) . #rules} .
		'asdf' . #RBLintRuleTestData .#openEditor }.
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBLintRuleTestData) parseTreeFor: #openEditor) equals: (self parseMethod: 'openEditor
								| asdf |
								asdf := self failedRules.
								asdf isEmpty ifTrue: [^self].
								asdf size == 1 ifTrue: [^asdf first viewResults]')! !

!RBRenameTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadIntervalAndVariableDoesNotExist
	self
		shouldFail:
			(self createRefactoringWithArguments: { { (14 to: 17) . #rule } .
				'asdf' . #RBRefactoryTestDataApp .#testMethod }).
	self
		shouldFail:
			(self createRefactoringWithArguments: { { (17 to: 14) . #xyz } .
				'asdf' . #RBRefactoryTestDataApp . #testMethod }).
	self
		shouldFail:
			(self createRefactoringWithArguments: { { (19 to: 24) . #temporaryVariable1 } .
				'asdf' . #RBRefactoryTestDataApp . #testMethod })! !

!RBRenameTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testBadName
	self
		shouldFail:
			(self createRefactoringWithArguments: { { (15 to: 19) . #rules }.
				'DependentFields' . #RBLintRuleTestData . #openEditor });
		shouldFail:
			(self createRefactoringWithArguments: { { (15 to: 19) . #rules }.
				'a b' . #RBLintRuleTestData . #openEditor })! !

!RBRenameTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testExistingVariable
	self
		shouldFail:
			(self createRefactoringWithArguments: { { (15 to: 19) . #rules }.
				'name' . #RBLintRuleTestData . #openEditor });
		shouldFail:
			(self createRefactoringWithArguments: { { (15 to: 19). #rules }.
				'rules' . #RBLintRuleTestData . #openEditor })! !

!RBRenameTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
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: (self createRefactoringWithModel: model	
			andArguments: { { (20 to: 24) . #temp2 } .
					'temp3' . #Object .  #aMethod: });
		shouldFail: (self createRefactoringWithModel: model 
			andArguments: { { (20 to: 24) . #temp2 } .
					'temp1' . #Object . #aMethod: })! !

!RBRenameTemporaryParametrizedTest methodsFor: 'failure tests' stamp: ''!
testModelExistingVariable

	| transformation |
	transformation := (RBAddMethodTransformation
		                   sourceCode: 'foo
									| temp bar |
									bar := 5.
									temp := bar * bar.
									Transcript show: temp printString; cr.
									^temp * temp'
		                   in: self class name
		                   withProtocols: { #accessing }) transform.

	self shouldFail: (self
			 createRefactoringWithModel: transformation model
			 andArguments: { 
					 { (16 to: 19) . #temp }.
					 #bar.
					 self class name.
					 #foo })! !

!RBRenameTemporaryParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters

	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBRenameArgumentOrTemporaryRefactoring .
					  #constructor -> #renameTemporaryFrom:to:in:selector: .
					  #index -> 1};
		addCase: { #rbClass -> RBRenameTemporaryVariableTransformation .
					  #constructor -> #rename:to:in:selector: .
					  #index -> 2};
		yourself! !

!RBRenameTemporaryVariableTransformation commentStamp: ''!
RBRenameTemporaryVariableTransformation is responsible for renaming temporary variables, including arguments, inside a method.

Example: 
| transformation |
transformation := (RBRenameTemporaryVariableTransformation 
				rename: #rules to: #asdf
				in: #RBLintRuleTest
				selector: #openEditor)
				transform.
(ChangesBrowser changes: transformation model changes changes) open
	
Preconditions:
- Check whether this method has a temporary variable with the given name.
- Check whether the class does not have instance or class variables with the given name.!
!RBRenameTemporaryVariableTransformation methodsFor: 'api' stamp: ''!
class: aClass selector: aSelector rename: anOldSymbol to: aNewSymbol 

	self className: aClass.
	selector := aSelector.
	variableName := anOldSymbol.
	newVariableName := aNewSymbol! !

!RBRenameTemporaryVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	"check whether variable exists?
	 test instance variables as well"

	^ (RBCondition isValidInstanceVariableName: newVariableName for: self definingClass)
		& (RBCondition definesSelector: selector in: self definingClass)
		& (RBCondition definesInstanceVariable: newVariableName in: self definingClass) not
		& (RBCondition definesClassVariable: newVariableName in: self definingClass) not! !

!RBRenameTemporaryVariableTransformation methodsFor: 'private' stamp: ''!
checkNewVariable: aParseTree

	aParseTree
		ifNil: [ self refactoringError: ('Temporary variable named {1} is not defined by this method.'
							format: { variableName asString }) ].
	(aParseTree whoDefines: newVariableName)
		ifNotNil: [ self refactoringError: ('Temporary variable named {1} is already defined.'
							format: { newVariableName asString }) ].
	(aParseTree allDefinedVariables includes: newVariableName)
		ifTrue: [ self refactoringError: ('Temporary variable named {1} is already defined.'
							format: { newVariableName asString }) ].! !

!RBRenameTemporaryVariableTransformation methodsFor: 'private' stamp: ''!
checkExistingVariable: variableNode

	(variableNode isNil or: [ variableNode isVariable not ])
		ifTrue: [ self refactoringError: ('Temporary variable named {1} does not exist.'
							format: { variableName asString }) ].
	variableNode name = variableName
		ifFalse: [ self refactoringError: 'Selected interval should include variable declaration' ].! !

!RBRenameTemporaryVariableTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' renameTemporary: ';
		nextPutAll: variableName;
		nextPutAll: ' to: ''';
		nextPutAll: newVariableName;
		nextPutAll: ''' in: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll: selector.
	aStream nextPut: $)! !

!RBRenameTemporaryVariableTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	| parseTree definingNode variableNode |
	parseTree := self definingMethod.
	variableNode := parseTree variableWith: variableName.
	self checkExistingVariable: variableNode.
	definingNode := variableNode whoDefines: variableName.
	self checkNewVariable: definingNode.
	(self parseTreeRewriterClass rename: variableName to: newVariableName)
		executeTree: definingNode.
	class compileTree: parseTree! !

!RBRenameTemporaryVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel rename: oldName to: newName in: aClass selector: aSelector 

	^ self new
		model: aRBModel;
		class: aClass
		selector: aSelector
		rename: oldName
		to: newName! !

!RBRenameTemporaryVariableTransformation class methodsFor: 'api' stamp: ''!
rename: oldName to: newName in: aClass selector: aSelector 

	^ self new
		class: aClass
		selector: aSelector
		rename: oldName
		to: newName! !

!RBRenameVariableChange commentStamp: ''!
I am the baseclass for a variable-name refactoring change. I know about the
class(name) for this variable renaming, whether it is on the instance or class side and the old and
new variable name. See my subclasses for the concrete implementation of renaming a class or an instance variable.

Executing this refactory change will change the variable name of the (global) class.!
!RBRenameVariableChange methodsFor: 'printing' stamp: ''!
displayClassName

	^ isMeta
		ifTrue: [ self changeClassName , ' class' ]
		ifFalse: [ self changeClassName asString ]! !

!RBRenameVariableChange methodsFor: 'private' stamp: ''!
executeNotifying: aBlock

	| undo |
	self addNewVariable.
	self copyOldValuesToNewVariable.
	undo := super executeNotifying: aBlock.
	undo
		oldName: newName;
		newName: oldName.
	self removeOldVariable.
	^ undo! !

!RBRenameVariableChange methodsFor: 'accessing' stamp: ''!
oldName

	^ oldName! !

!RBRenameVariableChange methodsFor: 'comparing' stamp: ''!
= aRenameVariableChange

	self class = aRenameVariableChange class 
		ifFalse: [ ^ false ].
	^ className = aRenameVariableChange changeClassName 
		and: [ isMeta = aRenameVariableChange isMeta 
		and: [ oldName = aRenameVariableChange oldName 
		and: [ newName = aRenameVariableChange newName ] ] ]! !

!RBRenameVariableChange methodsFor: 'private' stamp: ''!
addNewVariable

	self subclassResponsibility! !

!RBRenameVariableChange methodsFor: 'comparing' stamp: ''!
hash

	^ (self class hash bitXor: self oldName hash) bitXor: self newName hash! !

!RBRenameVariableChange methodsFor: 'accessing' stamp: ''!
removeOldVariable

	self subclassResponsibility! !

!RBRenameVariableChange methodsFor: 'private' stamp: ''!
copyOldValuesToNewVariable

	self subclassResponsibility! !

!RBRenameVariableChange methodsFor: 'accessing' stamp: ''!
changeClass

	| class |
	class := onSystemDictionary classNamed: self changeClassName.
	^ isMeta
		  ifTrue: [ class class ]
		  ifFalse: [ class ]! !

!RBRenameVariableChange methodsFor: 'accessing' stamp: ''!
changeClassName: aSymbol

	className := aSymbol.
	isMeta ifNil: [ isMeta := false ]! !

!RBRenameVariableChange methodsFor: 'accessing' stamp: ''!
changeClass: aBehavior

	isMeta := aBehavior isMeta.
	className := isMeta
		             ifTrue: [ aBehavior soleInstance name ]
		             ifFalse: [ aBehavior name ]! !

!RBRenameVariableChange methodsFor: 'accessing' stamp: ''!
nameToDisplay

	^ 'Rename ', self oldName, ' into ', self newName! !

!RBRenameVariableChange methodsFor: 'accessing' stamp: ''!
newName

	^ newName! !

!RBRenameVariableChange methodsFor: 'private' stamp: ''!
isMeta

	^ isMeta! !

!RBRenameVariableChange methodsFor: 'private' stamp: ''!
newName: aString

	newName := aString! !

!RBRenameVariableChange methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: self displayString! !

!RBRenameVariableChange methodsFor: 'accessing' stamp: ''!
whatToDisplayIn: aChangeBrowser

	| result |
	result := OrderedCollection with: self.
	^ result, (self changes flatCollect: [:e | e changes ])! !

!RBRenameVariableChange methodsFor: 'private' stamp: ''!
oldName: aString

	oldName := aString! !

!RBRenameVariableChange methodsFor: 'accessing' stamp: ''!
textToDisplay

	self printString! !

!RBRenameVariableChange methodsFor: 'accessing' stamp: ''!
changeClassName

	^ className! !

!RBRenameVariableChange methodsFor: 'printing' stamp: ''!
changeString

	^ 'Rename ' , oldName , ' to ' , newName! !

!RBRenameVariableChange class methodsFor: 'instance creation' stamp: ''!
rename: oldName to: newName in: aClass 
	^ self new
		oldName: oldName;
		newName: newName;
		changeClass: aClass;
		yourself! !

!RBRenameVariableParametrizedTest methodsFor: 'parameterization' stamp: ''!
extraArgument: anObject

	extraArgument := anObject! !

!RBRenameVariableParametrizedTest methodsFor: 'parameterization' stamp: ''!
renameVariableClass 
	^ rbClass! !

!RBRenameVariableParametrizedTest methodsFor: 'builder' stamp: ''!
createRefactoringWithArguments: aParameterCollection
	^ (self renameVariableClass 
		perform: constructor 
		withArguments: aParameterCollection , extraArgument) asRefactoring! !

!RBRenameVariableTransformation commentStamp: ''!
Renames a variable in a class and all its direct accesses. It is necessary to indicate whether the variable is an instance or class variable. It is not implemented as a composite transformation because the rename is made internally in the model.

Usage:
transformation := (RBRenameVariableTransformation
			rename: 'classBlock' to: 'asdf'
			in: #RBBasicLintRuleTest
			classVariable: false)
			transform.
(ChangesBrowser changes: transformation model changes changes) open

Preconditions:
overrides from RBAddVariableRefactoring and RBRemoveVariableRefactoring!
!RBRenameVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	class := self model classObjectFor: className.

	^ (isClassVariable
		ifTrue: [ (RBCondition isMetaclass: class) not 
					& (RBCondition isValidClassVarName: newVariableName asString for: class) 
					& (RBCondition definesClassVariable: variableName asString in: class) ]
		ifFalse: [ (RBCondition isValidInstanceVariableName: newVariableName for: class) 
					& (RBCondition definesInstanceVariable: variableName in: class) ])
		& (RBCondition hierarchyOf: class definesVariable: newVariableName) not 
		& (RBCondition isGlobal: newVariableName in: self model) not! !

!RBRenameVariableTransformation methodsFor: 'private' stamp: ''!
referencesFor: aClass

	^ isClassVariable
		ifTrue: [ aClass whichSelectorsReferToClassVariable: variableName ]
		ifFalse: [ aClass whichSelectorsReferToInstanceVariable: variableName ]
	! !

!RBRenameVariableTransformation methodsFor: 'private' stamp: ''!
renameReferences

	| replacer subclasses |
	replacer := self parseTreeRewriterClass 
				rename: variableName
				to: newVariableName
				handler: [ self refactoringError: ('<1s> is already defined as a method
					or block temporary <n> variable in this class or one of its subclasses' 
					expandMacrosWith: newVariableName )].
	subclasses := (self model classObjectFor: className) withAllSubclasses.
	isClassVariable ifTrue: [ subclasses addAll: self definingClass withAllSubclasses ].
	
	self model
		convertClasses: subclasses
		select: [ :aClass | self referencesFor: aClass ]
		using: replacer! !

!RBRenameVariableTransformation methodsFor: 'api' stamp: ''!
rename: aVariableName to: aNewVariableName class: aClassName classVariable: aBoolean

	self className: aClassName.
	variableName := aVariableName.
	newVariableName := aNewVariableName.
	isClassVariable := aBoolean.! !

!RBRenameVariableTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	isClassVariable
		ifTrue: [ self definingClass instanceSide renameClassVariable: variableName
						to: newVariableName around: [ self renameReferences ] ]
		ifFalse: [ self definingClass renameInstanceVariable: variableName
						to: newVariableName around: [ self renameReferences ]  ]! !

!RBRenameVariableTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' rename: '.
	variableName storeOn: aStream.
	aStream nextPutAll: ' to: '.
	newVariableName storeOn: aStream.
	aStream nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream nextPutAll: ' classVariable: '.
	isClassVariable storeOn: aStream.
	aStream nextPut: $)! !

!RBRenameVariableTransformation class methodsFor: 'api' stamp: ''!
renameClassVarible: aVariableName to: aNewVariableName in: aClassName

	^ self new
		rename: aVariableName
		to: aNewVariableName
		class: aClassName
		classVariable: true;
		yourself! !

!RBRenameVariableTransformation class methodsFor: 'api' stamp: ''!
rename: aVariableName to: aNewVariableName in: aClassName classVariable: aBoolean

	^ self new
		rename: aVariableName
		to: aNewVariableName
		class: aClassName
		classVariable: aBoolean;
		yourself! !

!RBRenameVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel renameInstanceVariable: aVariableName to: aNewVariableName in: aClassName

	^ self new
		model: aRBModel;
		rename: aVariableName
		to: aNewVariableName
		class: aClassName
		classVariable: false;
		yourself! !

!RBRenameVariableTransformation class methodsFor: 'api' stamp: ''!
renameInstanceVarible: aVariableName to: aNewVariableName in: aClassName

	^ self new
		rename: aVariableName
		to: aNewVariableName
		class: aClassName
		classVariable: false;
		yourself! !

!RBRenameVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel renameClassVariable: aVariableName to: aNewVariableName in: aClassName

	^ self new
		model: aRBModel;
		rename: aVariableName
		to: aNewVariableName
		class: aClassName
		classVariable: true;
		yourself! !

!RBRenameVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel rename: aVariableName to: aNewVariableName in: aClassName classVariable: aBoolean

	^ self new
		model: aRBModel;
		rename: aVariableName
		to: aNewVariableName
		class: aClassName
		classVariable: aBoolean;
		yourself! !

!RBReplaceMethodRefactoring commentStamp: ''!
I'm a refactoring operation for replace one method call by another one.

The new method's name can have a different number of arguments than the original method, if it has more arguments a list of initializers will be needed for them.

All senders of this method are changed by the other.

Example
-------
Script:
```
(RBReplaceMethodRefactoring  
	model: model
	replaceMethod: #anInstVar:
	in: RBBasicLintRuleTestData
	to: #newResultClass: 
	permutation: (1 to: 1)
	inAllClasses: true) execute
```!
!RBReplaceMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self replaceInAllClasses 
		ifTrue: [ self renameMessageSends ]
		ifFalse: [ self renameMessageSendsIn: {class} ]! !

!RBReplaceMethodRefactoring methodsFor: 'private' stamp: ''!
parseTreeRewriter
	| rewriteRule oldString newString |
	rewriteRule := self parseTreeRewriterClass new.
	oldString := self buildSelectorString: oldSelector.
	newString := self newSelectorString.
	rewriteRule replace: '``@object ' , oldString
		with: '``@object ' , newString.
	^rewriteRule! !

!RBReplaceMethodRefactoring methodsFor: 'transforming' stamp: ''!
preconditions 
	|conditions|
	
	conditions := (RBCondition withBlock: [ oldSelector numArgs < newSelector numArgs ifTrue: [ 
				(oldSelector numArgs + self initializers size) = newSelector numArgs 
					ifFalse: [ self refactoringFailure: 'You don''t have the necessary initializers to replace senders.' ] ]. true ])
						&(RBCondition definesSelector: oldSelector in: class )
						& (RBCondition definesSelector: newSelector in: class ).
	
	^ conditions & (RBCondition withBlock: 
		[ |senders|
		senders := self replaceInAllClasses 
			ifTrue: [ self model allReferencesTo: oldSelector ]
			ifFalse: [ self model allReferencesTo: oldSelector in: {class} ].
		senders size > 1 
			ifTrue: 
				[self refactoringWarning: ('This will modify all <1p> senders.<n>Proceed anyway?' 
							expandMacrosWith: senders size)].
		true])! !

!RBReplaceMethodRefactoring methodsFor: 'accessing' stamp: ''!
replaceInAllClasses
	^ replaceInAllClasses ifNil: [ replaceInAllClasses := false ]! !

!RBReplaceMethodRefactoring methodsFor: 'accessing' stamp: ''!
initializers

	^ initializers ifNil: [ initializers := {  } ]! !

!RBReplaceMethodRefactoring methodsFor: 'initialization' stamp: ''!
replaceCallMethod: aSelector in: aClass to: newSel permutation: aMap
	oldSelector := aSelector asSymbol.
	newSelector := newSel asSymbol.
	class := self classObjectFor: aClass.
	permutation := aMap.! !

!RBReplaceMethodRefactoring methodsFor: 'initialization' stamp: ''!
replaceCallMethod: aSelector in: aClass to: newSel permutation: aMap inAllClasses: aBoolean
	oldSelector := aSelector asSymbol.
	newSelector := newSel asSymbol.
	class := self classObjectFor: aClass.
	permutation := aMap.
	replaceInAllClasses := aBoolean.! !

!RBReplaceMethodRefactoring methodsFor: 'private' stamp: ''!
newSelectorString
	| stream keywords |
	stream := WriteStream on: String new.
	permutation ifEmpty: [ stream nextPutAll: newSelector ].
	keywords := newSelector keywords.
	permutation
		doWithIndex: 
			[:each :index | 
			stream nextPutAll: (keywords at: index).
			each < 0
				ifTrue: 
					[stream
						nextPut: $(;
						nextPutAll: (initializers at: each abs);
						nextPut: $)]
				ifFalse: 
					[stream
						nextPutAll: ' ``@arg';
						nextPutAll: each printString].
			stream nextPut: $ ].
	^stream contents! !

!RBReplaceMethodRefactoring methodsFor: 'accessing' stamp: ''!
initializers: anObject

	initializers := anObject! !

!RBReplaceMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
replaceCallMethod: aSelector in: aClass to: newSelector permutation: aMap 
	^self new 
		replaceCallMethod: aSelector
		in: aClass
		to: newSelector
		permutation: aMap! !

!RBReplaceMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk replaceMethod: aSelector in: aClass to: newSelector permutation: aMap 
	^ self new
		model: aRBSmalltalk;
		replaceCallMethod: aSelector
			in: aClass
			to: newSelector
			permutation: aMap;
		yourself! !

!RBReplaceMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk replaceMethod: aSelector in: aClass to: newSelector permutation: aMap inAllClasses: aBoolean
	^ self new
		model: aRBSmalltalk;
		replaceCallMethod: aSelector
			in: aClass
			to: newSelector
			permutation: aMap
			inAllClasses: aBoolean;
		yourself! !

!RBReplaceMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
replaceCallMethod: aSelector in: aClass to: newSelector permutation: aMap inAllClasses: aBoolean
	^self new 
		replaceCallMethod: aSelector
		in: aClass
		to: newSelector
		permutation: aMap
		inAllClasses: aBoolean! !

!RBReplacePreview commentStamp: ''!
I am a preview to accept or denegate a replacement an ocurrence of method (Find and replace refactoring).

Instance Variables
------------------------------------------

diffPresenter:    <SpDiffPresenter> A diff presenter to show the users the consequences of the refactorings.
change:           <Change> A  refactoring change
skipAction:       <Block> A  block with an action when press skip button
replaceAllAction: <Block> A  block with an action when press replace all button!
!RBReplacePreview methodsFor: 'initialization' stamp: ''!
initializeWidgets
	diffPresenter := self newDiff showOptions: false; contextClass: True.
	self whenBuiltDo: [ self buildDiffFor: change first ]! !

!RBReplacePreview methodsFor: 'instance creation' stamp: ''!
open
	^ self "openDialogWithSpec"openModalWithSpec ! !

!RBReplacePreview methodsFor: 'initialization' stamp: ''!
change: anObject
	|aCompositeChange |
	aCompositeChange := RBRefactoryChangeManager changeFactory compositeRefactoryChange .
	aCompositeChange addChange: anObject .
	
	change := aCompositeChange whatToDisplayIn: self ! !

!RBReplacePreview methodsFor: 'initialization' stamp: ''!
cancelAction: aBlock 
	cancelAction := aBlock! !

!RBReplacePreview methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aModalPresenter
	aModalPresenter
		initialExtent: 700 @ 500;
		
		addButton: 'Cancel' do: cancelAction;
		addButton: 'Replace' do: [ :presenter | self accept: presenter ];
		addButton: 'Skip' do: skipAction;
		addButton: 'Replace all' do: replaceAllAction ! !

!RBReplacePreview methodsFor: 'initialization' stamp: ''!
replaceAllAction: aBlock 
	replaceAllAction := aBlock! !

!RBReplacePreview methodsFor: 'initialization' stamp: ''!
skipAction: aBlock 
	skipAction := aBlock! !

!RBReplacePreview methodsFor: 'initialization' stamp: ''!
accept: presenter
	
	self okToChange
		ifFalse: [ ^ self ].
	[ change do: 
		[ :aChange | RBRefactoryChangeManager instance 
			performChange: aChange;
			addUndoPointer: (RBRefactoryChangeManager nextCounter) ] 
	] asJob
		title: 'Refactoring';
		run.
	presenter
				beOk;
				close! !

!RBReplacePreview methodsFor: 'private' stamp: ''!
buildDiffFor: aChange
	diffPresenter  
		leftText: aChange oldVersionTextToDisplay;
		rightText: aChange textToDisplay! !

!RBReplacePreview class methodsFor: 'initialization' stamp: ''!
change: anObject

	^ self new
		change: anObject;
		yourself! !

!RBReplacePreview class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ SpBoxLayout newTopToBottom 
				add: #diffPresenter;
				yourself ! !

!RBReplacePreview class methodsFor: 'specs' stamp: ''!
title 
	^ 'Refactoring Preview'! !

!RBReplaceRule commentStamp: ''!
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	<BlockClosure>	Is evaluated with the matching node. This allows for further verification of a match beyond simple tree matching.

!
!RBReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForTree: aBRProgramNode replaceWith: replaceNode 

	self subclassResponsibility! !

!RBReplaceRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	verificationBlock := [:aNode | true]! !

!RBReplaceRule methodsFor: 'private - searching' stamp: ''!
searchFor: searchString replaceWith: replaceString when: aBlock 

	self subclassResponsibility! !

!RBReplaceRule methodsFor: 'matching' stamp: ''!
foundMatchFor: aProgramNode 
	self subclassResponsibility! !

!RBReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForTree: aBRProgramNode replaceWith: replaceString when: aBlock 

	self subclassResponsibility! !

!RBReplaceRule methodsFor: 'matching' stamp: ''!
replace: aProgramNode with: newNode 
	aProgramNode replaceMethodSource: newNode! !

!RBReplaceRule methodsFor: 'testing' stamp: ''!
canMatch: aProgramNode 
	^verificationBlock value: aProgramNode! !

!RBReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForMethod: searchString replaceWith: replaceString 

	self subclassResponsibility! !

!RBReplaceRule methodsFor: 'private - searching' stamp: ''!
searchFor: searchString replaceWith: replaceString 

	self subclassResponsibility! !

!RBReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForMethod: searchString replaceWith: replaceString when: aBlock 

	self subclassResponsibility! !

!RBReplaceRule class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBReplaceRule! !

!RBReplaceSendersMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testModelReplaceMethodWithMoreArgs
	| refactoring sendersNewSelector sendersLastSelector selector newSelector |
	selector := ('called:', 'on:') asSymbol.
	newSelector := ('textInput:', 'name:', 'symbol:') asSymbol.
	sendersNewSelector := (model allReferencesTo: newSelector) size.
	sendersLastSelector := (model allReferencesTo: selector) size.
	refactoring := rbClass
				model: model
				replaceMethod: selector
				in: RBRefactoryTestDataApp
				to: newSelector 
				permutation: #(-1 2 1)
				inAllClasses: true.
	refactoring initializers: #('OrderedCollection new: 5').
	self proceedThroughWarning: [ refactoring primitiveExecute ].
	self assert: sendersNewSelector + sendersLastSelector 
		equals: (model allReferencesTo: newSelector) size! !

!RBReplaceSendersMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testReplaceMethodOnlyInClass
	| refactoring sendersNewSelector sendersLastSelector selector newSelector |
	selector := ('result', 'Class:') asSymbol.
	newSelector := ('method', 'Block:') asSymbol.
	refactoring := rbClass
				replaceCallMethod: selector
				in: RBBasicLintRuleTestData
				to: newSelector 
				permutation: (1 to: 1)
				inAllClasses: false.
	sendersNewSelector := (refactoring model allReferencesTo: newSelector) size.
	sendersLastSelector := ((refactoring model allReferencesTo: selector) select: [ :e | e modelClass name = 'RBBasicLintRuleTestData' ]) size.
	self proceedThroughWarning: [ refactoring primitiveExecute ].
	self assert: sendersNewSelector + sendersLastSelector 
		equals: (refactoring model allReferencesTo: newSelector) size! !

!RBReplaceSendersMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNotUnderstandNewSelector
	self shouldFail: (rbClass
			replaceCallMethod: #checkClass:
			in: RBBasicLintRuleTestData
			to: #checkMethod23:
			permutation: (1 to: 1))! !

!RBReplaceSendersMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNotUnderstandSelector
	self shouldFail: (rbClass
			replaceCallMethod: #checkClass123:
			in: RBBasicLintRuleTestData
			to: #checkMethod:
			permutation: (1 to: 1))! !

!RBReplaceSendersMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testModelReplaceMethodWithLessArgs
	| refactoring sendersNewSelector sendersLastSelector selector newSelector |
	selector := ('called:', 'on:') asSymbol.
	newSelector := ('foo:') asSymbol.
	sendersNewSelector := (model allReferencesTo: newSelector) size.
	sendersLastSelector := (model allReferencesTo: selector) size.
	refactoring := rbClass
				model: model
				replaceMethod: selector
				in: RBRefactoryTestDataApp
				to: newSelector 
				permutation: #(2)
				inAllClasses: true.
	self proceedThroughWarning: [ refactoring primitiveExecute ].
	self assert: sendersNewSelector + sendersLastSelector 
		equals: (model allReferencesTo: newSelector) size! !

!RBReplaceSendersMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testModelReplaceMethodOnlyInClass
	| refactoring sendersNewSelector sendersLastSelector selector newSelector |
	selector := ('result', 'Class:') asSymbol.
	newSelector := ('method', 'Block:') asSymbol.
	sendersNewSelector := (model allReferencesTo: newSelector) size.
	sendersLastSelector := ((model allReferencesTo: selector) select: [ :e | e modelClass name = 'RBBasicLintRuleTestData' ] ) size.
	refactoring := rbClass 
				model: model
				replaceMethod: selector
				in: RBBasicLintRuleTestData
				to: newSelector 
				permutation: (1 to: 1)
				inAllClasses: false.
	self proceedThroughWarning: [ refactoring primitiveExecute ].
	self assert: sendersNewSelector + sendersLastSelector 
		equals: (model allReferencesTo: newSelector) size! !

!RBReplaceSendersMethodParametrizedTest methodsFor: 'failure tests' stamp: ''!
testIncompleteInitializers
	self shouldFail: (rbClass
				model: model
				replaceMethod: ('called:', 'on:') asSymbol
				in: RBRefactoryTestDataApp
				to: ('textInput:', 'name:', 'symbol:') asSymbol 
				permutation: #(-1 2 1)
				inAllClasses: true)! !

!RBReplaceSendersMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testModelReplaceMethodWithSameArgs
	| refactoring sendersNewSelector sendersLastSelector selector newSelector |
	selector := ('called:', 'on:') asSymbol.
	newSelector := ('called:', 'on1:') asSymbol.
	sendersNewSelector := (model allReferencesTo: newSelector) size.
	sendersLastSelector := (model allReferencesTo: selector) size.
	refactoring := rbClass
				model: model
				replaceMethod: selector
				in: RBRefactoryTestDataApp
				to: newSelector 
				permutation: #(2 1)
				inAllClasses: true.
	self proceedThroughWarning: [ refactoring primitiveExecute ].
	self assert: sendersNewSelector + sendersLastSelector 
		equals: (model allReferencesTo: newSelector) size! !

!RBReplaceSendersMethodParametrizedTest methodsFor: 'tests' stamp: ''!
testReplaceMethodInAllClasses
	| refactoring sendersNewSelector sendersLastSelector selector newSelector |
	selector := ('an', 'InstVar:') asSymbol.
	newSelector := ('new', 'ResultClass:') asSymbol.
	refactoring := rbClass
				replaceCallMethod: selector
				in: RBBasicLintRuleTestData
				to: newSelector 
				permutation: (1 to: 1)
				inAllClasses: true.
	sendersNewSelector := (refactoring model allReferencesTo: newSelector) size.
	sendersLastSelector := (refactoring model allReferencesTo: selector) size.
	self proceedThroughWarning: [ refactoring primitiveExecute ].
	self assert: sendersNewSelector + sendersLastSelector 
		equals: (refactoring model allReferencesTo: newSelector) size! !

!RBReplaceSendersMethodParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBReplaceMethodRefactoring };
		yourself! !

!RBReplaceSubtreeTransformation commentStamp: ''!
Replaces a piece of code by another in a method. Internally, this transformation replaces the corresponding subtrees, so they have to be syntactically correct.

Usage:
| transformation |
transformation := (RBReplaceSubtreeTransformation
		replace: 'selector := aSelector'
		to: '^ selector'
		inMethod: #selector:from:
		inClass: #RBRemoveMethodTransformation)
		transform.
(ChangesBrowser changes: transformation model changes changes) open!
!RBReplaceSubtreeTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition definesSelector: selector in: self definingClass)
		&
			(RBCondition
				withBlock: [ | tree |
					tree := self parserClass
						parseExpression: oldSourceCode
						onError:
							[ :string :pos | self refactoringError: 'Invalid source to extract - ' , string ].
					tree
						ifNil: [ self
								refactoringError: 'Invalid source to extract - ' , oldSourceCode ].
					(tree isSequence and: [ tree statements isEmpty ])
						ifTrue: [ self refactoringError: 'Selected code to extract is empty' ].
					tree := ((self definingClass parseTreeFor: selector)
						extractSubtreeWith: oldSourceCode)
						ifNil: [ self
								refactoringError: 'Could not extract code from method ' , selector ].
					true ])
		&
			(RBCondition
				withBlock: [ self parserClass
						parseExpression: newSourceCode
						onError:
							[ :string :pos | self refactoringError: 'Invalid source to add - ' , string ].
					true ])! !

!RBReplaceSubtreeTransformation methodsFor: 'api' stamp: ''!
replace: anOldString to: aNewString inMethod: aSelector inClass: aClass

	self className: aClass.
	selector := aSelector.
	oldSourceCode := anOldString.
	newSourceCode := aNewString! !

!RBReplaceSubtreeTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream
		nextPutAll: ' replace: ''';
		nextPutAll: oldSourceCode;
		nextPutAll: ''' to: ''';
		nextPutAll: newSourceCode;
		nextPutAll: ''' inMethod: #';
		nextPutAll: selector;
		nextPutAll: ' inClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBReplaceSubtreeTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	| tree oldTree newTree |
	tree := self definingClass parseTreeFor: selector.
	tree ifNil: [ ^ self ].
	oldTree := tree extractSubtreeWith: oldSourceCode.
	oldTree ifNil: [ ^ self ].
	newTree := self parserClass
		parseExpression: newSourceCode
		onError: [ :string :pos | ^ nil ].
	newTree ifNil: [ ^ self ].
	tree := oldTree isSequence
		ifTrue: [ self parseTreeRewriterClass
				replaceStatements: oldTree formattedCode
				with: newSourceCode
				in: tree ]
		ifFalse: [ self parseTreeRewriterClass
				replace: oldTree formattedCode
				with: newSourceCode
				in: tree
				onInterval: tree sourceInterval ].
	self definingClass compileTree: tree! !

!RBReplaceSubtreeTransformation class methodsFor: 'api' stamp: ''!
replace: oldSourceCode to: newSourceCode inMethod: aSelector inClass: aClass

	^ self new
		replace: oldSourceCode
		to: newSourceCode
		inMethod: aSelector
		inClass: aClass;
		yourself ! !

!RBReplaceSubtreeTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel replace: oldSourceCode to: newSourceCode inMethod: aSelector inClass: aClass

	^ self new
		model: aRBModel;
		replace: oldSourceCode
		to: newSourceCode
		inMethod: aSelector
		inClass: aClass;
		yourself ! !

!RBReplaceSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testEmptyCode

	self shouldFail: (RBReplaceSubtreeTransformation 
							replace: ''
							to: '^ selector'
							inMethod: #selector:from:
							inClass: #RBRemoveMethodTransformation)
							asRefactoring ! !

!RBReplaceSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testParseFailure

	self shouldFail: (RBReplaceSubtreeTransformation 
							replace: 'selector := aSelector'
							to: ':= 123'
							inMethod: #selector:from:
							inClass: #RBRemoveMethodTransformation)
							asRefactoring ! !

!RBReplaceSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testRefactoring

	| transformation class |
	transformation := (RBReplaceSubtreeTransformation 
							replace: 'selector := aSelector'
							to: '^ selector'
							inMethod: #selector:from:
							inClass: #RBRemoveMethodTransformation)
							asRefactoring transform. 
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: #RBRemoveMethodTransformation.
	self assert: (class directlyDefinesMethod: #selector:from:).
	self assert: (class parseTreeFor: #selector:from:) body statements size equals: 2.
	self assert: (class parseTreeFor: #selector:from:) body statements last isReturn.! !

!RBReplaceSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBReplaceSubtreeTransformation
							replace: '^ 1'
							to: '^ 123'
							inMethod: #one
							inClass: self changeMock name)
							transform. 
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self changeMock name asSymbol.
	self assert: (class directlyDefinesMethod: #one).
	self assert: (class parseTreeFor: #one) body statements size equals: 1.
	self assert: (class parseTreeFor: #one) body statements first isReturn.
	self assert: (class parseTreeFor: #one) body statements first value value equals: 123! !

!RBReplaceSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testExtractFailure

	self shouldFail: (RBReplaceSubtreeTransformation 
							replace: ':= aSelector'
							to: '^ selector'
							inMethod: #selector:from:
							inClass: #RBRemoveMethodTransformation)
							asRefactoring ! !

!RBReplaceSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testMethodDoesNotExist

	self shouldFail: (RBReplaceSubtreeTransformation 
							replace: 'selector := aSelector'
							to: '^ selector'
							inMethod: #selector:for:
							inClass: #RBRemoveMethodTransformation)
							asRefactoring ! !

!RBReplaceSubtreeTransformationTest methodsFor: 'tests' stamp: ''!
testTransformOneOfManyStatements

	| transformation class |
	transformation := (RBReplaceSubtreeTransformation
		replace: 'self assert: (class parseTreeFor: #selector:from:) body statements size equals: 2'
		to: 'self assert: (class parseTreeFor: #selector:from:) body statements size = 2'
		inMethod: #testRefactoring
		inClass: #RBReplaceSubtreeTransformationTest)
		asRefactoring transform. 
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: #RBReplaceSubtreeTransformationTest.
	self assert: (class directlyDefinesMethod: #testRefactoring).
	self assert: (class parseTreeFor: #testRefactoring) body statements size equals: 6.
	self assert: ((((class parseTreeFor: #testRefactoring) body statements at: 5) sourceCode withBlanksCondensed copyReplaceAll: String cr with: ' ')
		includesSubstring: 'assert: (class parseTreeFor: #selector:from:) body statements size = 2').! !

!RBReturnNode commentStamp: ''!
RBReturnNode is an AST node that represents a return expression.

Instance Variables:
	return	<Integer>	the position of the ^ character
	value	<RBValueNode>	the value that is being returned

!
!RBReturnNode methodsFor: 'accessing' stamp: ''!
value: anExpression 
	value := anExpression.
	value parent: self! !

!RBReturnNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	value == aNode ifTrue: [ self value: anotherNode ]! !

!RBReturnNode methodsFor: 'accessing' stamp: ''!
stop
	value ifNil:[^ 0].
	^ value stop! !

!RBReturnNode methodsFor: 'accessing - token' stamp: ''!
return: anInteger
	return := anInteger! !

!RBReturnNode methodsFor: 'comparing' stamp: ''!
= anObject
	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ self value = anObject value! !

!RBReturnNode methodsFor: 'comparing' stamp: ''!
hash
	^self value hash! !

!RBReturnNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	return := 0! !

!RBReturnNode methodsFor: 'adding/removing' stamp: ''!
removeNode: aNode

	self parent removeNode: self! !

!RBReturnNode methodsFor: 'comparing' stamp: ''!
equalTo: anObject withMapping: aDictionary 
	^self class = anObject class 
		and: [self value equalTo: anObject value withMapping: aDictionary]! !

!RBReturnNode methodsFor: 'accessing - token' stamp: ''!
return
	^ return! !

!RBReturnNode methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self value: self value copy! !

!RBReturnNode methodsFor: 'testing' stamp: ''!
isFaulty
	^self value isFaulty! !

!RBReturnNode methodsFor: 'accessing' stamp: ''!
children
	^ { value }! !

!RBReturnNode methodsFor: 'testing' stamp: ''!
containsReturn
	^ true! !

!RBReturnNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitReturnNode: self! !

!RBReturnNode methodsFor: 'evaluating' stamp: ''!
value
	^ value! !

!RBReturnNode methodsFor: 'accessing' stamp: ''!
stop: anInteger
	self value stop: anInteger! !

!RBReturnNode methodsFor: 'accessing' stamp: ''!
start
	^ return! !

!RBReturnNode methodsFor: 'testing' stamp: ''!
isReturn
	^true! !

!RBReturnNode methodsFor: 'initialization' stamp: ''!
return: returnInteger value: anExpression 
	return := returnInteger.
	self value: anExpression! !

!RBReturnNode methodsFor: 'matching' stamp: ''!
match: aNode inContext: aDictionary 
	aNode class = self class ifFalse: [^false].
	^value match: aNode value inContext: aDictionary! !

!RBReturnNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	^ self class new
		value: (self value copyInContext: aDictionary);
		yourself! !

!RBReturnNode methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink
	(#(instead after) includes: aMetaLink control) ifTrue: [ self error: '#intead on return not supported' ].
	super link: aMetaLink ! !

!RBReturnNode class methodsFor: 'instance creation' stamp: ''!
value: aNode
	^self return: 0 value: aNode! !

!RBReturnNode class methodsFor: 'instance creation' stamp: ''!
return: returnInteger value: aValueNode 
	^self new return: returnInteger value: aValueNode! !

!RBScanner commentStamp: ''!
RBScanner is a stream that returns a sequence of tokens from the string. The tokens know where they came from in the source code and which comments were attached to them.

Instance Variables:
	buffer	<PositionableStream>	Accumulates the text for the current token.
	characterType	<ByteSymbol>	The type of the next character. (e.g. #alphabetic, etc.)
	classificationTable	<Array of: Symbol>	Mapping from Character values to their characterType.
	comments	<Collection of: Interval>	Source intervals of scanned comments that must be attached to the next token.
	currentCharacter	<Character>	The character currently being processed.
	errorBlock	<BlockClosure>	The block to execute on lexical errors.
	extendedLiterals	<Boolean>	True if IBM-type literals are allowed. In VW, this is false.
	nameSpaceCharacter	<Character>	The character used to separate namespaces.
	numberType	<ByteSymbol>	The method to perform: to scan a number. 
	separatorsInLiterals	<Boolean>	True if separators are allowed within literals.
	stream	<PositionableStream>	Contains the text to be scanned.
	tokenStart	<Integer>	The source position of the beginning of the current token

Class Instance Variables:
	classificationTable	<Array>		the default classification table for all characters

Shared Variables:
	PatternVariableCharacter	<Character>	the character that starts a pattern node!
!RBScanner methodsFor: 'error handling' stamp: ''!
errorBlock
	^errorBlock ifNil: [[:message :position | ]] ifNotNil: [errorBlock]! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanSpecialCharacter
	"Every given character gives a RBSpecialCharacterToken with only one character as value except for
	 : followed by = which gives an assignement."
	"The case of the assignement is the only one consuming more than 1 character."
	| character |
	currentCharacter = $: 
		ifTrue: [
			self step.
			^ currentCharacter = $= 
				ifTrue: [
					self step.
					RBAssignmentToken start: tokenStart]
				ifFalse: [ RBSpecialCharacterToken value: $: start: tokenStart ]].
	
	character := currentCharacter.
	self step.
	^ RBSpecialCharacterToken value: character start: tokenStart! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanUnknownCharacter
	| errorToken |
	errorToken := self scanError: 'Unknown character'.
	"advance"
	self step.
	^ errorToken! !

!RBScanner methodsFor: 'private' stamp: ''!
step
	stream atEnd 
		ifTrue: 
			[characterType := #eof.
			^currentCharacter := nil].
	currentCharacter := stream next.
	characterType := self classify: currentCharacter.
	^currentCharacter! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanName
	[characterType = #alphabetic or: [characterType = #digit]] whileTrue: 
			[buffer nextPut: currentCharacter.
			self step]! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanSymbol
	"Always return a literal token but only recognises Identifier and keyword strings.
	 Therefor any other string lead to an empty string value."
	[ 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: ''!
scanLiteralArrayToken
	"This scan accepts any character but is only meant to be used when a # is followed by ( or [ ."
	| token |
	token := RBLiteralArrayToken 
				value: (String with: $# with: currentCharacter)
				start: tokenStart.
	self step.
	^token! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanLiteral
	"Do not allow whitespace between # and the literal."

	"Do not allow number literals after the #"

	"This scan accepts keywords as well as binaries and Identifiers."
	self step.
	characterType = #alphabetic
		ifTrue: [ ^ self scanSymbol ].
	characterType = #binary
		ifTrue:
			[ ^ (self scanLiteralBinary)
				stop: self previousStepPosition ].
	currentCharacter = $'
		ifTrue: [ ^ self scanStringSymbol ].
	(currentCharacter = $( or: [ currentCharacter = $[ ])
		ifTrue: [ ^ self scanLiteralArrayToken ].
	"Accept multiple #."
	currentCharacter = $#
		ifTrue: [ ^ self scanLiteral ].
	^ (self scanError: 'Expecting a literal type') value: '#'.! !

!RBScanner methodsFor: 'testing' stamp: ''!
isSelector
	characterType = #binary
		ifTrue: [ [ characterType = #binary ] whileTrue: [ self step ].
			^ characterType = #eof ].
	characterType ~= #alphabetic
		ifTrue: [ ^ false ].
	^ self isSelectorNonBinary! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanLiteralCharacter
	"Accepts any character."
	"This scan must only be used after the encounter of a $."
	"'$$' is a correct string to be scanned and the second $ mustn't trigger a new scan."
	| token |
	self step.	"$"
	currentCharacter ifNil:[ ^ (self scanError:'A Character was expected') value: '$'].
	token := RBLiteralToken 
				value: currentCharacter
				start: tokenStart
				stop: stream position.
	self step.	"char"
	^token! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanIdentifierOrKeyword
	"!!!! Attention !!!! There are 3 case of Literal Tokens : true, false and nil."
	"This scan accepts keywords only containing a colon."
	"The presence of a colon will mark the creation of a keyword, except when followed with =.
	 Otherwise an Identifier is created."
	"To ensure the pertinence of this scanner, it must be called only if the current character is 	, 	 	 alphabetic."
	| 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: ''!
stripSeparators
	
	[[characterType = #separator] whileTrue: [self step].
	currentCharacter = $"] 
			whileTrue: [self scanComment]! !

!RBScanner methodsFor: 'error handling' stamp: ''!
scannerError: aString
	(self errorBlock cull: aString cull: self errorPosition cull: self) ifNil: [ 
		^ SyntaxErrorNotification
					inClass: Object
					withCode: stream contents
					doitFlag: false
					errorMessage: aString
					location: stream position + 1
	]! !

!RBScanner methodsFor: 'accessing' stamp: ''!
nextPut: anObject 
	"Provide an error notification that the receiver does not
	implement this message."

	self shouldNotImplement! !

!RBScanner methodsFor: 'accessing' stamp: ''!
contents
	| contentsStream |
	contentsStream := (Array new: 50) writeStream.
	[ self atEnd ]
		whileFalse: [ contentsStream nextPut: self next ].
	^ contentsStream contents! !

!RBScanner methodsFor: 'accessing' stamp: ''!
errorBlock: aBlock 
	errorBlock := aBlock! !

!RBScanner methodsFor: 'testing' stamp: ''!
atEnd
	^characterType = #eof! !

!RBScanner methodsFor: 'accessing' stamp: ''!
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 scanBinarySelector].
	characterType = #special ifTrue: [^self scanSpecialCharacter].
	currentCharacter = $' ifTrue: [^self scanLiteralString].
	currentCharacter = $# ifTrue: [^self scanLiteral].
	currentCharacter = $$ ifTrue: [^self scanLiteralCharacter].
	^self scanUnknownCharacter! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanBinarySelector
	"Used when binary characters are encountered and not beginning with #"
	^self scanBinary: RBBinarySelectorToken! !

!RBScanner methodsFor: 'error handling' stamp: ''!
parseErrorNode: aMessageString
	| sourceString |
	sourceString := stream contents copyFrom: self errorPosition to: stream contents size.
	^ RBParseErrorNode
		errorMessage: aMessageString value: sourceString at: self errorPosition! !

!RBScanner methodsFor: 'accessing' stamp: ''!
getComments
	| oldComments |
	comments isEmpty ifTrue: [^nil].
	oldComments := comments.
	comments := OrderedCollection new: 1.
	^oldComments! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanComment
	| start stop |
	start := stream position.
	buffer reset.
	self step.
	self atEnd
		ifTrue: [ ^ self scannerError: 'Unmatched " in comment.' ].
	[ currentCharacter = $" and: [ buffer nextPut: currentCharacter. self step ~= $" ] ]
		whileFalse: [ characterType = #eof
				ifTrue: [ ^ self scannerError: 'Unmatched " in comment.' ].
			buffer nextPut: currentCharacter.
			self step ].
	stop := self atEnd
		ifTrue: [ stream position ]
		ifFalse: [ stream position - 1 ].
	comments add: (RBCommentToken value: (buffer contents copyFrom: 1 to: buffer contents size -1) start: start stop: stop).! !

!RBScanner methodsFor: 'accessing' stamp: ''!
next
	| token |
	buffer reset.
	tokenStart := stream position.
	token := characterType = #eof 
				ifTrue: 
					[RBEOFToken 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: 'private - scanning' stamp: ''!
scanLiteralString
	"String can contain anything, even faulty code."
	| string |
	[stream atEnd ifTrue: [
		self step. "to handle eof"
		^ self scanError: 'Unmatched '' in string literal.'].
	string := stream upTo: $'. 
	stream peekBack = $' ifFalse: [ 
		"the peek logic here is because #upTo: does not tell if given char was found"
		buffer nextPutAll: string.
		self step. "to handle eof"
		^ self scanError: 'Unmatched '' in string literal.'].
	
	self step = $'] whileTrue: [ 
		buffer nextPutAll: string; nextPut: $'.
		string := ''].
	
	buffer position = 0 ifFalse: [ 		
		buffer nextPutAll: string.
		string := buffer contents].	
	
	"It's possible to use a plain Text for parsing.
	In that case string here could be a Text instance but literal value must be a String"	
	^RBLiteralToken 
		value: string asString 
		start: tokenStart 
		stop: self previousStepPosition! !

!RBScanner methodsFor: 'initialization' stamp: ''!
on: aStream 
	buffer := (String new: 60) writeStream.
	stream := aStream.
	classificationTable := self class classificationTable.
	comments := OrderedCollection new! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanNumber
	| start number stop string |
	start := stream position.
	stream position: start - 1.
	number := [NumberParser parse: stream] on: Error do: [:err | self scannerError: err messageText].
	stop := stream position.
	stream position: start - 1.
	string := stream next: stop - start + 1.
	stream position: stop.
	self step.
	^RBNumberLiteralToken 
		value: number
		start: start
		stop: stop
		source: string! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanLiteralBinary
	"Used when binary characters are encountered and beginning with #"
	^self scanBinary: RBLiteralToken! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanBinary: aClass 
	"This method isn't supposed to be used in a public context as it accepts any kind of RBValueToken.
	 The only 2 tokens supposed to be used are RBLiteralToken and RBBinarySelectorToken."
	
	"This method trims separators but doesn't add comments to the token created."
	
	"Puts any succession of selectors in the token, even meaningless ones."
	| 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: ''!
scanStringSymbol
	"Converting the value of the literal token to a symbol to get rid of a layer of nested comments."
	"Only supposed to be used when encountering an apostrophe."
	| literalToken |
	literalToken := self scanLiteralString.
	literalToken value: literalToken value asSymbol.
	^literalToken! !

!RBScanner methodsFor: 'private - scanning' stamp: ''!
scanKeyword
	"This scan can actually give odd keywords like a single colon.
	 : is a keyword but it is an impossible one to reach with a call to next.
	 However, a call to next can give an RBMultiKeywordLiteralToken even if the string scanned is like
	 the following : 'keyword:::::::'. Here, each colon is considered a keyword."
	"Of course, a keyword must finish with a colon. That's why arguments are not taken into account."
	| 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: ''!
scanError: theCause
	"An error token accepts every character given, recognised or not."
	"The value of an error token is one character maximum : the current character."
	| location |
	"error location is the next not parseable character. Or current stream position + 1 if 
	an expected character is missing."
	location := stream position.
	currentCharacter
		ifNotNil: [ :char | buffer nextPut: char ]
		ifNil: [ location := stream position + 1 ].
	^ RBErrorToken
		value: buffer contents asString
		start: tokenStart
		cause: theCause
		location: location! !

!RBScanner methodsFor: 'private' stamp: ''!
previousStepPosition
	^characterType = #eof 
		ifTrue: [stream position]
		ifFalse: [stream position - 1]! !

!RBScanner methodsFor: 'error handling' stamp: ''!
errorPosition
	^stream position! !

!RBScanner methodsFor: 'private' stamp: ''!
classify: aCharacter

	| index |

	aCharacter ifNil: [ ^ 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: 'testing' stamp: ''!
isSelectorNonBinary
	"inspect the next line and view as morph"

	"ZnEasy getPng: 'http://www.plantuml.com/plantuml/png/RO-n2i8m48RtUugRXRn0XzBg98wEuX2R4mlNHE8LwTkRL4Xxa2cNx_z2_ki-OgFC4mF8A4nu9QP1GeJRuOx6j7WSlOqBDlXOXy9xVhzipy5Joco-m0vfeoQuP9n2cjFp8PygRJ7_qo259m2ide8REliBBTyGNQa16p9LGUUw1C1_uThk9TBrEl9kdlW7'"

	| state |
	state := #alphaAlone.
	[ characterType = #alphabetic ]
		whileTrue: [ state = #colon
				ifTrue: [ state := #inKeyword ].
			self scanName.
			characterType = #eof
				ifTrue: [ ^ state = #alphaAlone ].
			currentCharacter = $:
				ifTrue: [ state := #colon.
					self step ] ].
	characterType = #eof
		ifTrue: [ ^ state = #colon ].
	^ false

	"Diagram by:
@startuml

title Selector
[*] --> Binary : binary
[*] --> AlphaAlone : alpha
AlphaAlone --> AlphaAlone: alpha
AlphaAlone -d-> Colon : colon
AlphaAlone -> [*] : eof


Colon -> [*] : eof
Colon -> InKeyword : alpha

InKeyword --> InKeyword : alpha
InKeyword --> Colon : colon


Binary --> Binary : binary
Binary --> [*] : eof

@enduml"! !

!RBScanner class methodsFor: 'public api' stamp: ''!
scanTokenObjects: aStringOrStream
	"Return the tokens objects."
	
	| scanner |
	scanner := self on: aStringOrStream readStream.
	^ scanner contents! !

!RBScanner class methodsFor: 'instance creation' stamp: ''!
new
	self initializeUnderscore.
	^ super new! !

!RBScanner class methodsFor: 'class initialization' stamp: ''!
initialize
	self initializeClassificationTable! !

!RBScanner class methodsFor: 'testing' stamp: ''!
isVariable: aString 
	| scanner token |
	scanner := self on: (ReadStream on: aString).
	token := scanner next.
	token isIdentifier ifFalse: [^false].
	(token start = 1 and: [token stop = aString size]) ifFalse: [^false].
	^(aString includes: $.) not! !

!RBScanner class methodsFor: 'class initialization' stamp: ''!
initializeChars: characters to: aSymbol 
	characters do: [:c | classificationTable at: c asInteger put: aSymbol]! !

!RBScanner class methodsFor: 'instance creation' stamp: ''!
on: aStream 
	"Create a scanner stream of program tokens on the argument. Users can then use stream API to consume tokens. Reader may consider scanTokens: as a better way to use the class."
	"((RBScanner on: 'Pharo (, { exist ]' readStream) next;  next) value >>> $("

	| str |
	str := self new on: aStream.
	str
		step;
		stripSeparators.
	^str! !

!RBScanner class methodsFor: 'accessing' stamp: ''!
keywordPatternCharacter
	^ KeywordPatternCharacter! !

!RBScanner class methodsFor: 'instance creation' stamp: ''!
on: aStream errorBlock: aBlock 
	| str |
	str := self new on: aStream.
	str
		errorBlock: aBlock;
		step;
		stripSeparators.
	^str! !

!RBScanner class methodsFor: 'class initialization' stamp: ''!
initializeUnderscore
	self classificationTable
		at: $_ asInteger
		put: #alphabetic! !

!RBScanner class methodsFor: 'public api' stamp: ''!
scanTokens: aStringOrStream
	"Return the tokens (and not the scanner token objects)."

	^ (self scanTokenObjects: aStringOrStream) collect: [ :t | t value ]! !

!RBScanner class methodsFor: 'accessing' stamp: ''!
cascadePatternCharacter
	^ CascadePatternCharacter! !

!RBScanner class methodsFor: 'accessing' stamp: ''!
classificationTable
	classificationTable 
		ifNil: [ self initializeClassificationTable ].
	^ classificationTable! !

!RBScanner class methodsFor: 'accessing' stamp: ''!
patternVariableCharacter
	^ PatternVariableCharacter! !

!RBScanner class methodsFor: 'testing' stamp: ''!
isSelector: aSymbol
	^ self basicNew
		on: (ReadStream on: aSymbol asString); 
		step;
		isSelector! !

!RBScanner class methodsFor: 'class initialization' stamp: ''!
initializeClassificationTable
	PatternVariableCharacter := $`.
	KeywordPatternCharacter := $@.
	CascadePatternCharacter := $;.
	classificationTable := Array new: 255.
	self 
		initializeChars: (Character allCharacters
			select: [ :each | each isLetter ])
		to: #alphabetic.
	self initializeUnderscore.
	self initializeChars: '01234567890' to: #digit.
	self initializeChars: Character specialCharacters to: #binary.
	self initializeChars: '().:;[]{}^' to: #special.
	self
		initializeChars: (Character allCharacters
			select: [ :each | each isSeparator ])
		to: #separator! !

!RBScannerTest commentStamp: ''!
SUnit tests for RBScanner!
!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextKeywordCanNotBeginWithBinary
	| scanner token |
	scanner := self buildScannerForText: '+alpha:'.
	
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '+'.
	
	token := scanner next.
	self assert: token isKeyword.
	self assert: token value equals: 'alpha:'.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextLiteralBeginningWithSpecialThrowsError
	| scanner token |
	scanner := self buildScannerForText: '#^'.
	token := scanner next.
	self assert: token isError.
	self assert: token value equals: '#'.
	self assert: token cause equals: 'Expecting a literal type'.! !

!RBScannerTest methodsFor: 'tests - Creation api' stamp: ''!
testScanTokenObjects2
	| inp exp |
	inp := 'classVariableNames: '''' "ha ha"
package: ''UndefinedClasses-Experiment'.
	exp := {'classVariableNames:' . '' . 'package:' . 'UndefinedClasses-Experiment'}.
	self assert: ((self scannerClass scanTokenObjects: inp) collect: [ :each | each value ]) equals: exp! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextLiteralArrayWithBracketStopAtBracket
	"Note: RBScanner only spots the beginning of the array."
	| scanner token |
	
	scanner := self buildScannerForText: '#['.
	token := scanner next.
	self assert: token stop equals: 2.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextWithUnFinishedCommentGivesAnError
	| scanner |
	scanner := self buildScannerForText: 'firstToken "unfinished comment secondToken'.
	self should: [scanner next] raise: SyntaxErrorNotification .! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsMiddleTab
	| scanner token |
	scanner := self buildScannerForText: 'firstToken', String tab, 'secondToken'.
	scanner next.
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token start equals: 12.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsBeginningSpaces
	| scanner token |
	scanner := self buildScannerForText: String space, String space, 'firstToken'.
	token := scanner next.
	self assert: token value equals: 'firstToken'.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextDollarSignIsError
	| scanner token |
	scanner := self buildScannerForText: '$'.
	token := scanner next.
	self assert: token isError.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextIdentifierStartAtFirstLetter
	| scanner token |
	scanner := self buildScannerForText: 'firstToken'.
	token := scanner next.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests' stamp: ''!
testNextWithAnOpeningStringsGetError
	| source scannedToken |
	source := '''only the opening'.
	scannedToken := (self buildScannerForText: source) next.
	self verifyErrorToken: scannedToken message: 'Unmatched '' in string literal.' translated valueExpected: 'only the opening'! !

!RBScannerTest methodsFor: 'tests - Identifiers' stamp: ''!
testNextAllAlphabeticsGiveIdentifier
	| scanner token |
	scanner := self buildScannerForText: 'firstToken'.
	token := scanner next.
	self assert: token isIdentifier.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsBeginningComment
	| scanner token |
	scanner := self buildScannerForText: '"start comment"firstToken'.
	token := scanner next.
	self assert: token value equals: 'firstToken'.! !

!RBScannerTest methodsFor: 'tests - Comment' stamp: ''!
testNextCommentIsCommentToken
	| scanner token |
	scanner := self buildScannerForText: String tab, ' "simple comment" firstToken'.
	token := scanner next comments first.
	self assert: token isComment.
	
	scanner := self buildScannerForText: String tab, ' """nested at beggining"" comment" firstToken'.
	token := scanner next comments first.
	self assert: token isComment.
	
	scanner := self buildScannerForText: String tab, ' "comment ""nested at end""" firstToken'.
	token := scanner next comments first.
	self assert: token isComment.! !

!RBScannerTest methodsFor: 'tests - Creation api' stamp: ''!
testScanTokenObjects1
	| inp exp |
	inp := 'Object subclass: #NameOfSubclass'.
	exp := {'Object'.
	'subclass:'.
	#NameOfSubclass asString}.
	self assert: ((self scannerClass scanTokenObjects: inp) collect: [ :each | each value ]) equals: exp.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextStringIsLiteral
	| scanner token |
	scanner := self buildScannerForText: '''the world has changed'''.
	token := scanner next.
	self assert: token isLiteralToken.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextFloatNumbersHasFloatValue
	
	| scanner token |
	scanner := self buildScannerForText: '3.2'.
	token := scanner next.
	self assert: token value equals: 3.2.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextBinarySelectorStartAtFirstLetter
	| scanner token |
	scanner := self buildScannerForText: '+-=/'.
	token := scanner next.
	self assert: token value equals: '+-=/'.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextKeywordBeginningWithSpecialCharacterIsNotKeyword
	| scanner token |
	scanner := self buildScannerForText: '^firstToken:'.
	token := scanner next.
	self assert: token isSpecial.
	self assert: token value equals: $^.
	
	scanner := self buildScannerForText: '$firstToken:'.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token value equals: $f.
	
	scanner := self buildScannerForText: '\firstToken:'.
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '\'.
	
	scanner := self buildScannerForText: '`firstToken:'.
	token := scanner next.
	self assert: token isError.
	self assert: token value equals: '`'.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextTokenStartAfterLineBreak
	"Tests that the next token adapts starting point according to it."
	| scanner token |
	scanner := self buildScannerForText: '
firstToken'.
	token := scanner next.
	self assert: token value equals: 'firstToken'.
	self assert: token start equals: 2.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextUnknownCharacterThrowsError
	| scanner token |
	scanner := self buildScannerForText: '`'.
	token := scanner next.
	self assert: token isError.
	self assert: token value equals: '`'.
	self assert: token cause equals: 'Unknown character'.! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextBinarySelectorStopAtLastLetter
	| scanner token |
	scanner := self buildScannerForText: '+-=/'.
	token := scanner next.
	self assert: token value equals: '+-=/'.
	self assert: token stop equals: 4.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextLiteralArrayWithBracketStartAtHashtag
	"Note: RBScanner only spots the beginning of the array."
	| scanner token |
	
	scanner := self buildScannerForText: '#['.
	token := scanner next.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - Comment' stamp: ''!
testCommentTokenStopAtLastQuote
	| scanner token str comment |
	str := ' "simple comment" firstToken'.
	comment := '"simple comment"'.
	scanner := self buildScannerForText: str.
	token := scanner next comments first.
	self assert: token isComment.
	self assert: token stop equals: (str findString: comment) + comment size - 1.
	
	str := ' """nested at beggining"" comment" firstToken'.
	comment := '"""nested at beggining"" comment"'.
	scanner := self buildScannerForText: str .
	token := scanner next comments first.
	self assert: token isComment.
	self assert: token stop equals: (str findString: comment) + comment size - 1.
	
	str := '"comment ""nested at end""" firstToken'.
	comment := '"comment ""nested at end"""'.
	scanner := self buildScannerForText: str.
	token := scanner next comments first.
	self assert: token isComment.
	self assert: token stop equals: (str findString: comment) + comment size - 1.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextStringContainsAllTheContent
	| scanner token |
	scanner := self buildScannerForText: '''The world has changed'''.
	token := scanner next.
	self assert: token value equals: 'The world has changed'.! !

!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextAllAlphabeticEndingWithColonGiveKeyword
	| scanner token |
	scanner := self buildScannerForText: 'firstToken:'.
	token := scanner next.
	self assert: token isKeyword.! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextAssignementStopAtEqual
	| scanner token |
	scanner := self buildScannerForText: ':='.
	token := scanner next.
	self assert: token stop equals: 2.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsEndTab
	| scanner token |
	scanner := self buildScannerForText: 'firstToken', String tab.
	scanner next.
	token := scanner next.
	self assert: token isEOF.
	self assert: token start equals: 12.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextLiteralCanBeBinary
	| scanner token |
	scanner := self buildScannerForText: '#+=-/'.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token value equals: #+=-/.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextBeginningWithDigitIsNumber
	
	| scanner token |
	scanner := self buildScannerForText: '1'.
	token := scanner next.
	self assert: token isNumberLiteralToken.
	
	scanner := self buildScannerForText: '1a'.
	token := scanner next.
	self assert: token isNumberLiteralToken.
	
	scanner := self buildScannerForText: '1='.
	token := scanner next.
	self assert: token isNumberLiteralToken.
	
	scanner := self buildScannerForText: '1$'.
	token := scanner next.
	self assert: token isNumberLiteralToken.
	
	scanner := self buildScannerForText: '123'.
	token := scanner next.
	self assert: token isNumberLiteralToken.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextAcceptRadixNumbers
	
	| scanner token |
	scanner := self buildScannerForText: '10r10'.
	token := scanner next.
	self assert: token isNumberLiteralToken.
	
	scanner := self buildScannerForText: '2r10'.
	token := scanner next.
	self assert: token isNumberLiteralToken.
	
	scanner := self buildScannerForText: '16rfa'.
	token := scanner next.
	self assert: token isNumberLiteralToken.
	
	scanner := self buildScannerForText: '400r380'.
	token := scanner next.
	self assert: token isNumberLiteralToken.! !

!RBScannerTest methodsFor: 'tests - Creation api' stamp: ''!
testScanTokens1
	| inp exp |
	inp := 'Object subclass: #NameOfSubclass'.
	exp := {'Object'.
	'subclass:'.
	#NameOfSubclass asString}.
	self assert: (self scannerClass scanTokens: inp) equals: exp.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextHashtagStringIsLiteral
	| scanner token |
	scanner := self buildScannerForText: '#''the world has changed'''.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token value equals: #'the world has changed'.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextEOFContainsCommentsWhenNoOtherToken
	| scanner token |
	scanner := self buildScannerForText: '"start comment"'.
	
	token := scanner next.
	self assert: token isEOF.
	self assert: token comments size equals: 1.
	self assert: token start equals: 16.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsMiddleSpaces
	| scanner token |
	scanner := self buildScannerForText: 'firstToken',String space, String space,'secondToken'.
	scanner next.
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token start equals: 13.! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextIdentifierStopAtLastLetter
	| scanner token |
	scanner := self buildScannerForText: 'firstToken'.
	token := scanner next.
	self assert: token stop equals: 10.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextLiteralBeginningWithApostropheThrowsError
	| scanner token |
	scanner := self buildScannerForText: '#'''.
	token := scanner next.
	self assert: token isError.
	self assert: token value equals: #''.
	self assert: token cause equals: 'Unmatched '' in string literal.'.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextTokenStartAfterTab
	"Tests that the next token adapts starting point according to it."
	| scanner token |
	scanner := self buildScannerForText: String tab, 'firstToken'.
	token := scanner next.
	self assert: token value equals: 'firstToken'.
	self assert: token start equals: 2.! !

!RBScannerTest methodsFor: 'tests - Comment' stamp: ''!
testMultipleCommentTokensAreWellSeparated
	| scanner token comments |
	scanner := self buildScannerForText: String tab, ' "first comment" " second comment" firstToken'.
	comments := scanner next comments.
	token := comments first.
	self assert: token isComment.
	self assert: token value equals: 'first comment'.
	
	token := comments second.
	self assert: token isComment.
	self assert: token value equals: ' second comment'.! !

!RBScannerTest methodsFor: 'tests' stamp: ''!
testNextWithAnOpeningCommentAtEndGetError
	| source |	
	source := 'self "'.
	self should: [(self buildScannerForText: source) next] raise: SyntaxErrorNotification! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextLiteralWithMultipleHashtagTrimThem
	| scanner token |
	scanner := self buildScannerForText: '########literal'.
	token := scanner next.
	self assert: token value equals: 'literal'.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextRadixNumbersCanBeFloatAsWell
	
	| scanner token |
	scanner := self buildScannerForText: '10r10.2'.
	token := scanner next.
	self assert: token value equals: 10.2.
	
	scanner := self buildScannerForText: '2r1010.1'.
	token := scanner next.
	self assert: token value equals: 10.5.
	
	scanner := self buildScannerForText: '16ra.a'.
	token := scanner next.
	self assert: token value equals: 10.625.
	
	scanner := self buildScannerForText: '8r12.44'.
	token := scanner next.
	self assert: token value equals: 10.5625.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsEndSpaces
	| scanner token |
	scanner := self buildScannerForText: 'firstToken', String space, String space.
	scanner next.
	token := scanner next.
	self assert: token isEOF.
	self assert: token start equals: 13.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextMultipleKeywordStartAtFirstLetter
	| scanner token |
	scanner := self buildScannerForText: 'firstToken:secondToken:'.
	token := scanner next.
	self assert: token isMultiKeyword.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - SpecialCharacters' stamp: ''!
testNextSpecialCharactereisSpecial
	| scanner token |
	scanner := self buildScannerForText: '('.
	token := scanner next.
	self assert: token isSpecial.
	
	scanner := self buildScannerForText: '^'.
	token := scanner next.
	self assert: token isSpecial.
	
	scanner := self buildScannerForText: ']'.
	token := scanner next.
	self assert: token isSpecial.! !

!RBScannerTest methodsFor: 'tests' stamp: ''!
testNextWithAnIdentifierTokenGetTheIdentifierToken
	| source scanner token |	
	source := 'identifierToken'.
	scanner := self buildScannerForText: source.
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token value equals: source! !

!RBScannerTest methodsFor: 'tests - BinarySelector' stamp: ''!
testNextBinarySelectorValueIsBinary
	| scanner token |
	scanner := self buildScannerForText: '+'.
	token := scanner next.
	self assert: token value equals: '+'.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextLiteralStartAtFirstLetter
	| scanner token |
	scanner := self buildScannerForText: '########literal'.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextFirstTokenContainsFollowingComments 
	| scanner token |
	scanner := self buildScannerForText: 'firstToken "following comment"'.
	
	"The first token 'firstToken' takes the previous comment and the following one"
	token := scanner next.
	self assert: token comments size equals: 1.
	self assert: token comments first isComment.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextLiteralCanContainColon
	| scanner token |
	
	scanner := self buildScannerForText: '#al:pha'.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token value equals: #'al:pha'.! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextNumberLiteralStopAtTheLastDigit
	
	| scanner token expr |
	expr := '-10r10'.
	scanner := self buildScannerForText: expr.
	token := scanner next.
	self assert: token stop equals: expr size.
	
	expr := '-2r1010'.
	scanner := self buildScannerForText: expr.
	token := scanner next.
	self assert: token stop equals: expr size.
	
	expr := '-16ra'.
	scanner := self buildScannerForText: expr.
	token := scanner next.
	self assert: token stop equals: expr size.
	
	expr := '-8r12'.
	scanner := self buildScannerForText: expr.
	token := scanner next.
	self assert: token stop equals: expr size.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextDollarSignExpectedACharacter
	| scanner token |
	scanner := self buildScannerForText: '$'.
	token := scanner next.
	self assert: token cause equals: 'A Character was expected'.! !

!RBScannerTest methodsFor: 'initialize' stamp: ''!
buildScannerForText: source
	^ self scannerClass on: source readStream! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextLiteralCanHaveMultipleHashtag
	| scanner token |
	scanner := self buildScannerForText: '########literal'.
	token := scanner next.
	self assert: token isLiteralToken.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextDollarSignErrorHasDollarValue
	| scanner token |
	scanner := self buildScannerForText: '$'.
	token := scanner next.
	self assert: token value equals: '$'.! !

!RBScannerTest methodsFor: 'tests' stamp: ''!
testNextWithTwoDoubleQuotesInCommentGetError
	| source |
	source := '"only the"" opening'.
	self
		should: [ (self buildScannerForText: source) next ]
		raise: SyntaxErrorNotification! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextNegativeFloatNumbersIsNumberLiteral
	
	| scanner token |
	scanner := self buildScannerForText: '-3.2'.
	token := scanner next.
	self assert: token isNumberLiteralToken.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextLiteralBeginningWithUnknownThrowsError
	| scanner token |
	scanner := self buildScannerForText: '#`'.
	token := scanner next.
	self assert: token isError.
	self assert: token value equals: '#'.
	self assert: token cause equals: 'Expecting a literal type'.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextTrueIsLiteral
	| scanner token |
	scanner := self buildScannerForText: 'true'.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token value equals: true.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsBeginningLineBreak
	| scanner token |
	scanner := self buildScannerForText: '
firstToken'.
	token := scanner next.
	self assert: token value equals: 'firstToken'.! !

!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextMultipleKeywordColonIsSufficientAfterFirstKeyword
	| scanner token |
	scanner := self buildScannerForText: 'firstToken::'.
	token := scanner next.
	self assert: token isMultiKeyword.
	self assert: token value equals: 'firstToken::'.
	
	scanner := self buildScannerForText: 'firstToken::::::'.
	token := scanner next.
	self assert: token isMultiKeyword.
	self assert: token value equals: 'firstToken::::::'.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextValueOfRadixNumbersIsConvertedToDecimal
	
	| scanner token |
	scanner := self buildScannerForText: '10r10'.
	token := scanner next.
	self assert: token value equals: 10.
	
	scanner := self buildScannerForText: '2r1010'.
	token := scanner next.
	self assert: token value equals: 10.
	
	scanner := self buildScannerForText: '16ra'.
	token := scanner next.
	self assert: token value equals: 10.
	
	scanner := self buildScannerForText: '8r12'.
	token := scanner next.
	self assert: token value equals: 10.! !

!RBScannerTest methodsFor: 'tests - Creation api' stamp: ''!
testScanTokens2
	| inp exp |
	inp := 'classVariableNames: '''' "ha ha"
package: ''UndefinedClasses-Experiment'.
	exp := {'classVariableNames:' . '' . 'package:' . 'UndefinedClasses-Experiment'}.
	self assert: (self scannerClass scanTokens: inp) equals: exp! !

!RBScannerTest methodsFor: 'utilities' stamp: ''!
verifyErrorToken: scannedToken message: message valueExpected: valueExpected
	self assert: scannedToken isError.
	self assert: scannedToken cause equals: message.
	self assert: scannedToken value equals: valueExpected.
	self assert: scannedToken start equals: 1.! !

!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextKeywordCanNotBeFullDigit
	| scanner token |
	scanner := self buildScannerForText: '123:'.
	
	"The scanner doesn't understand it as a keyword."
	token := scanner next.
	self assert: token isNumberLiteralToken.
	self assert: token value equals: 123.
	
	"The colon is therefor identified as a special character as it stands alone."
	token := scanner next.
	self assert: token isSpecial.
	self assert: token value equals: $:.! !

!RBScannerTest methodsFor: 'tests - Identifiers' stamp: ''!
testNextAlphabeticsAndDigitGiveIdentifier
	| scanner token |
	scanner := self buildScannerForText: 'first123Token'.
	token := scanner next.
	self assert: token isIdentifier.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextBaseOfRadixNumbersCanNotBeOne
	
	| scanner |
	scanner := self buildScannerForText: '1r1a'.
	self should: [scanner next] raise: SyntaxErrorNotification .! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextLiteralCharacterCanBeAnyCharacter
	| scanner token |
	scanner := self buildScannerForText: '$1'.
	token := scanner next.
	self assert: token isLiteralToken.
	
	scanner := self buildScannerForText: '$a'.
	token := scanner next.
	self assert: token isLiteralToken.
	
	scanner := self buildScannerForText: '$+'.
	token := scanner next.
	self assert: token isLiteralToken.
	
	scanner := self buildScannerForText: '$#'.
	token := scanner next.
	self assert: token isLiteralToken.
	
	scanner := self buildScannerForText: '$$'.
	token := scanner next.
	self assert: token isLiteralToken.
	
	scanner := self buildScannerForText: '$^'.
	token := scanner next.
	self assert: token isLiteralToken.
	
	scanner := self buildScannerForText: '$`'.
	token := scanner next.
	self assert: token isLiteralToken.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextLiteralCharacterHasCharacterAsValue
	| scanner token |
	scanner := self buildScannerForText: '$1'.
	token := scanner next.
	self assert: token value equals: $1.
	
	scanner := self buildScannerForText: '$a'.
	token := scanner next.
	self assert: token value equals: $a.
	
	scanner := self buildScannerForText: '$+'.
	token := scanner next.
	self assert: token value equals: $+.
	
	scanner := self buildScannerForText: '$#'.
	token := scanner next.
	self assert: token value equals: $#.
	
	scanner := self buildScannerForText: '$$'.
	token := scanner next.
	self assert: token value equals: $$.
	
	scanner := self buildScannerForText: '$`'.
	token := scanner next.
	self assert: token value equals: $`.
	
	scanner := self buildScannerForText: '$^'.
	token := scanner next.
	self assert: token value equals: $^.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsEndComment
	| scanner token |
	scanner := self buildScannerForText: 'firstToken"end comment"'.
	scanner next.
	token := scanner next.
	self assert: token isEOF.
	self assert: token start equals: 24.! !

!RBScannerTest methodsFor: 'tests - SpecialCharacters' stamp: ''!
testNextSpecialCharactereCanBeAssignement
	| scanner token |
	scanner := self buildScannerForText: ':='.
	token := scanner next.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - BinarySelector' stamp: ''!
testNextBinarySelectorCanBeMultipleBinaries
	| scanner token |
	scanner := self buildScannerForText: '+-=/'.
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '+-=/'.! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextMultipleKeywordStopAtLastLetter
	| scanner token |
	scanner := self buildScannerForText: 'firstToken:secondToken:'.
	token := scanner next.
	self assert: token isMultiKeyword.
	self assert: token stop equals: 23.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextLiteralBeginningWithDigitThrowsError
	| scanner token |
	scanner := self buildScannerForText: '#123alpha'.
	token := scanner next.
	self assert: token isError.
	self assert: token value equals: '#'.
	self assert: token cause equals: 'Expecting a literal type'.! !

!RBScannerTest methodsFor: 'tests - SpecialCharacters' stamp: ''!
testNextAcceptLiteralArrayWithParenthesis
	"Note: RBScanner only spots the beginning of the array."
	| scanner token |
	scanner := self buildScannerForText: '#('.
	token := scanner next.
	self assert: token isLiteralArrayToken.! !

!RBScannerTest methodsFor: 'tests' stamp: ''!
testNextWithAWrongSymbolGetError
	| source scanner scannedToken |
	source := '#^'.
	scanner := self buildScannerForText: source.
	scannedToken := scanner next.
	self verifyErrorToken: scannedToken message: 'Expecting a literal type' translated valueExpected: '#'! !

!RBScannerTest methodsFor: 'tests' stamp: ''!
testNextWithAnOpeningCommentGetError
	| source |	
	source := '"only the opening'.
	self should: [(self buildScannerForText: source) next] raise: SyntaxErrorNotification! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextFloatNumbersCanBeNegative
	
	| scanner token |
	scanner := self buildScannerForText: '-3.2'.
	token := scanner next.
	self assert: token value equals: -3.2.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextFloatNumbersCanNotHaveSpaces
	
	| scanner token |
	scanner := self buildScannerForText: '3 .2'.
	token := scanner next.
	self assert: token value equals: 3.
	
	scanner := self buildScannerForText: '3. 2'.
	token := scanner next.
	self assert: token value equals: 3.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextNegativeNumberIsNumberLiteral
	
	| scanner token |
	scanner := self buildScannerForText: '-12'.
	token := scanner next.
	self assert: token isNumberLiteralToken.! !

!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextKeywordValueIsStartToStop
	| scanner token |
	scanner := self buildScannerForText: 'firstToken:'.
	token := scanner next.
	self assert: token value equals: 'firstToken:'.
	
	scanner := self buildScannerForText: 'first:Token'.
	token := scanner next.
	self assert: token value equals: 'first:'.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextTokenStartAfterComment
	"Tests that the next token adapts starting point according to it."
	| scanner token |
	scanner := self buildScannerForText: '"start comment"firstToken'.
	token := scanner next.
	self assert: token value equals: 'firstToken'.
	self assert: token start equals: 16.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsMiddleComment
	| scanner token |
	scanner := self buildScannerForText: 'firstToken"middle comment"secondToken'.
	scanner next.
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token start equals: 27.! !

!RBScannerTest methodsFor: 'tests - Error' stamp: ''!
testNextHashtagCanNotStandAlone
	| scanner token |
	scanner := self buildScannerForText: '#'.
	token := scanner next.
	self assert: token isError.! !

!RBScannerTest methodsFor: 'tests' stamp: ''!
testNextWithAnUnknownCharacterGetError
	| source scanner scannedToken |	
	source := '¿'.
	scanner := self buildScannerForText: source.
	scannedToken := scanner next.
	self verifyErrorToken: scannedToken message: 'Unknown character' translated valueExpected: source! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextErrorStopAtErrorCharacter
	| scanner token |
	scanner := self buildScannerForText: '$'.
	token := scanner next.
	self assert: token stop equals: 1.
	
	scanner := self buildScannerForText: '#123alpha'.
	token := scanner next.
	self assert: token isError.
	self assert: token stop equals: 1.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextFirstTokenContainsPrecedingComments
	| scanner token |
	scanner := self buildScannerForText: '"start comment"firstToken'.
	token := scanner next.
	self assert: token comments size equals: 1.
	self assert: token comments first isComment.! !

!RBScannerTest methodsFor: 'tests' stamp: ''!
testNextLiteralCharacterWithAMissingCharacter
	| source scanner scannedToken |
	source := '$'.
	scanner := self buildScannerForText: source.
	scannedToken := scanner next.
	self verifyErrorToken: scannedToken message: 'A Character was expected' translated valueExpected: '$'! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextKeywordStopAtColon
	| scanner token |
	scanner := self buildScannerForText: 'firstToken:'.
	token := scanner next.
	self assert: token isKeyword.
	self assert: token stop equals: 11.
	
	scanner := self buildScannerForText: 'first:Token'.
	token := scanner next.
	self assert: token isKeyword.
	self assert: token stop equals: 6.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextKeyWordStartAtFirstLetter
	| scanner token |
	scanner := self buildScannerForText: 'firstToken:'.
	token := scanner next.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextLiteralCharacterHasOnlyOneCharacter
	| scanner token |
	scanner := self buildScannerForText: '$123'.
	token := scanner next.
	self assert: token value equals: $1.! !

!RBScannerTest methodsFor: 'tests - SpecialCharacters' stamp: ''!
testNextLiteralArrayHasRightValue
	"Note: RBScanner only spots the beginning of the array."
	| scanner token |
	
	scanner := self buildScannerForText: '#['.
	token := scanner next.
	self assert: token value equals: '#['.! !

!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextTwoKeywordIsMultipleKeyword
	| scanner token |
	scanner := self buildScannerForText: 'firstToken:secondToken:'.
	token := scanner next.
	self assert: token isMultiKeyword.
	self assert: token value equals: 'firstToken:secondToken:'.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsMiddleLineBreak
	| scanner token |
	scanner := self buildScannerForText: 'firstToken
secondToken'.
	scanner next.
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token start equals: 12.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsBeginningTab
	| scanner token |
	scanner := self buildScannerForText: String tab, 'firstToken'.
	token := scanner next.
	self assert: token value equals: 'firstToken'.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextTokenStartAfterSpaces
	"Tests that the next token adapts starting point according to it."
	| scanner token |
	scanner := self buildScannerForText: String space, String space, 'firstToken'.
	token := scanner next.
	self assert: token value equals: 'firstToken'.
	self assert: token start equals: 3.! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextSpecialCharacterStopAtThemself
	| scanner token |
	scanner := self buildScannerForText: '(]'.
	token := scanner next.
	self assert: token stop equals: 1.
	
	scanner := self buildScannerForText: '^('.
	token := scanner next.
	token := scanner next.
	self assert: token stop equals: 2.
	
	scanner := self buildScannerForText: ']'.
	token := scanner next.
	self assert: token stop equals: 1.! !

!RBScannerTest methodsFor: 'tests - BinarySelector' stamp: ''!
testNextBinarySelectorStopsAtNonBinary
	| scanner token |
	scanner := self buildScannerForText: '+a'.
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '+'.
	
	scanner := self buildScannerForText: '+1'.
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '+'.
	
	scanner := self buildScannerForText: '+('.
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '+'.
	
	scanner := self buildScannerForText: '+`'.
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '+'.! !

!RBScannerTest methodsFor: 'tests - Identifiers' stamp: ''!
testNextIdentifierCanContainUnderscore
	| scanner token |
	scanner := self buildScannerForText: 'first_Token'.
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token value equals: 'first_Token'.
	
	scanner := self buildScannerForText: '_firstToken'.
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token value equals: '_firstToken'.
	
	scanner := self buildScannerForText: 'firstToken_'.
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token value equals: 'firstToken_'.! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextLiteralArrayWithParenthesisStopAtParenthesis
	"Note: RBScanner only spots the beginning of the array."
	| scanner token |
	scanner := self buildScannerForText: '#('.
	token := scanner next.
	self assert: token stop equals: 2.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextFalseIsLiteral
	| scanner token |
	scanner := self buildScannerForText: 'false'.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token value equals: false.! !

!RBScannerTest methodsFor: 'tests - Identifiers' stamp: ''!
testNextIdentifierCanNotEndWithBinary
	| scanner token |
	scanner := self buildScannerForText: 'firstToken+'.
	
	"The first token is still recognised as Identifier but the + insn't taken into account."
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token value equals: 'firstToken'.
	
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '+'.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextSpecialCharacterStartAtTheBeginning
	| scanner token |
	scanner := self buildScannerForText: '(]'.
	token := scanner next.
	self assert: token start equals: 1.
	
	scanner := self buildScannerForText: '^('.
	token := scanner next.
	token := scanner next.
	self assert: token start equals: 2.
	
	scanner := self buildScannerForText: ']'.
	token := scanner next.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextStringCanContainOtherString
	| scanner token |
	scanner := self buildScannerForText: ''' The world has changed ''''I can feel it in the water'''' '''.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token value equals: ' The world has changed ''I can feel it in the water'' '.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextDoesNotAddSpacesToComments
	| scanner token |
	scanner := self buildScannerForText: String space, String space,'firstToken'.
	token := scanner next.
	self assert: token comments isNil.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextSecondTokenDoesNotConsumePrecedingComment
	| scanner token |
	scanner := self buildScannerForText: 
	'firstToken 
   "inbetween comment" secondToken
	"second inbetween" "multiple comments"'.
	"Expecting all spaces and line breaks to be trimmed."
	
	"The first token 'firstToken' takes the previous comment and the following one"
	token := scanner next.
	"The next token 'secondToken' takes the following 2 comments."
	token := scanner next.
	self assert: token comments size equals: 2.
	self assert: token start equals: 36.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextNumberLiteralStartAtTheBeginning
	
	| scanner token |
	scanner := self buildScannerForText: '-10r10'.
	token := scanner next.
	self assert: token start equals: 1.
	
	scanner := self buildScannerForText: '-2r1010'.
	token := scanner next.
	self assert: token start equals: 1.
	
	scanner := self buildScannerForText: '-16ra'.
	token := scanner next.
	self assert: token start equals: 1.
	
	scanner := self buildScannerForText: '-8r12'.
	token := scanner next.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - Identifiers' stamp: ''!
testNextIdentifierCanNotBeginWithBinary
	| scanner token |
	
	"Scanner doesn't recognise + as the beginning of an Identifier."
	scanner := self buildScannerForText: '+firstToken'.
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '+'.
	
	"Scanner separate them into 2 tokens with the second corresponding to an Identifier."
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token value equals: 'firstToken'.! !

!RBScannerTest methodsFor: 'tests - Comment' stamp: ''!
testCommentTokenStartAtFirstQuote
	| scanner token str comment |
	str := ' "simple comment" firstToken'.
	comment := '"simple comment"'.
	scanner := self buildScannerForText: str.
	token := scanner next comments first.
	self assert: token isComment.
	self assert: token start equals: (str findString: comment).
	
	str := ' """nested at beggining"" comment" firstToken'.
	comment := '"""nested at beggining"" comment"'.
	scanner := self buildScannerForText: str .
	token := scanner next comments first.
	self assert: token isComment.
	self assert: token start equals: (str findString: comment).
	
	str := '"comment ""nested at end""" firstToken'.
	comment := '"comment ""nested at end"""'.
	scanner := self buildScannerForText: str.
	token := scanner next comments first.
	self assert: token isComment.
	self assert: token start equals: (str findString: comment).! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextAcceptAllAlphabeticAsLiteral
	| scanner token |
	scanner := self buildScannerForText: '#alpha'.
	token := scanner next.
	self assert: token isLiteralToken.! !

!RBScannerTest methodsFor: 'tests - BinarySelector' stamp: ''!
testNextBinaryGivesBinarySelector
	| scanner token |
	scanner := self buildScannerForText: '+'.
	token := scanner next.
	self assert: token isBinary.! !

!RBScannerTest methodsFor: 'tests - Identifiers' stamp: ''!
testNextIdentifierCanNotBeginWithDigit
	| scanner token |
	scanner := self buildScannerForText: '123firstToken'.
	
	"Scanner doesn't recognise 123 as the beginning of an Identifier."
	token := scanner next.
	self assert: token isNumberLiteralToken.
	self assert: token value equals: 123.
	
	"Scanner separate them into 2 tokens with the second corresponding to an Identifier."
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token value equals: 'firstToken'.! !

!RBScannerTest methodsFor: 'tests - SpecialCharacters' stamp: ''!
testNextAcceptLiteralArrayWithBracket
	"Note: RBScanner only spots the beginning of the array."
	| scanner token |
	
	scanner := self buildScannerForText: '#['.
	token := scanner next.
	self assert: token isLiteralArrayToken.! !

!RBScannerTest methodsFor: 'tests - Stop' stamp: ''!
testNextLiteralStopAtLastLetter
	| scanner token |
	scanner := self buildScannerForText: '########literal'.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token stop equals: 15.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextAssignementStartAtColon
	| scanner token |
	scanner := self buildScannerForText: ':='.
	token := scanner next.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextValueOfRadixNumbersCutsWhenValueIsImpossible
	
	| scanner token |
	scanner := self buildScannerForText: '10r1a'.
	token := scanner next.
	self assert: token value equals: 1.
	
	scanner := self buildScannerForText: '2r10210'.
	token := scanner next.
	self assert: token value equals: 2.
	
	scanner := self buildScannerForText: '16r3g'.
	token := scanner next.
	self assert: token value equals: 3.
	
	scanner := self buildScannerForText: '8r192'.
	token := scanner next.
	self assert: token value equals: 1.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextErrorStartAtFirstCharacter
	| scanner token |
	scanner := self buildScannerForText: '$'.
	token := scanner next.
	self assert: token start equals: 1.
	
	scanner := self buildScannerForText: '#123alpha'.
	token := scanner next.
	self assert: token isError.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextAcceptFloatNumbers
	
	| scanner token |
	scanner := self buildScannerForText: '3.2'.
	token := scanner next.
	self assert: token isNumberLiteralToken.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextLiteralCanContainDigits
	| scanner token |
	scanner := self buildScannerForText: '#alpha123beta456'.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token value equals: #alpha123beta456.! !

!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextKeywordCanNotBeFullBinary
	| scanner token |
	scanner := self buildScannerForText: '+-=:'.
	
	"The scanner doesn't understand it as a keyword."
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '+-='.
	
	"The colon is therefor identified as a special character as it stands alone."
	token := scanner next.
	self assert: token isSpecial.
	self assert: token value equals: $:.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextTrimsEndLineBreak
	| scanner token |
	scanner := self buildScannerForText: 'firstToken
'.
	scanner next.
	token := scanner next.
	self assert: token isEOF.
	self assert: token start equals: 12.! !

!RBScannerTest methodsFor: 'tests - Comment' stamp: ''!
testCommentTokenHasTheRightValue
	| scanner token |
	scanner := self buildScannerForText: String tab, ' "simple comment" firstToken'.
	token := scanner next comments first.
	self assert: token value equals: 'simple comment'.
	
	scanner := self buildScannerForText: String tab, ' """nested at beggining"" comment" firstToken'.
	token := scanner next comments first.
	self assert: token value equals: '""nested at beggining"" comment'.
	
	scanner := self buildScannerForText: String tab, ' "comment ""nested at end""" firstToken'.
	token := scanner next comments first.
	self assert: token value equals: 'comment ""nested at end""'.! !

!RBScannerTest methodsFor: 'tests - SpecialCharacters' stamp: ''!
testNextLiteralArrayWithParenthesisHasRigthValue
	"Note: RBScanner only spots the beginning of the array."
	| scanner token |
	scanner := self buildScannerForText: '#('.
	token := scanner next.
	self assert: token value equals: '#('.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextDoesNotAddLineBreakToComments
	| scanner token |
	scanner := self buildScannerForText: '
firstToken'.
	token := scanner next.
	self assert: token comments isNil.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextStringErrorDoesNotPropagateInside
	| scanner token |
	scanner := self buildScannerForText: ''' The world has changed ''''I feel it in the water'''.
	token := scanner next.
	self assert: token value equals: ' The world has changed ''I feel it in the water'.! !

!RBScannerTest methodsFor: 'tests - Separators' stamp: ''!
testNextDoesNotAddTabToComments
	| scanner token |
	scanner := self buildScannerForText: String tab, 'firstToken'.
	token := scanner next.
	self assert: token comments isNil.! !

!RBScannerTest methodsFor: 'tests - Identifiers' stamp: ''!
testNextIdentifierValueIsName
	| scanner token |
	scanner := self buildScannerForText: 'firstToken'.
	token := scanner next.
	self assert: token value equals: 'firstToken'.! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextLiteralCanNotContainBinaryAndAlphabetic
	| scanner token |
	scanner := self buildScannerForText: '#+alpha'.
	token := scanner next.
	self assert: token value equals: #+.
	
	scanner := self buildScannerForText: '#al=pha'.
	token := scanner next.
	self assert: token value equals: #al.
	
	scanner := self buildScannerForText: '#alpha-'.
	token := scanner next.
	self assert: token value equals: #alpha.! !

!RBScannerTest methodsFor: 'tests - Start' stamp: ''!
testNextLiteralArrayWithParenthesisStartAtHashTag
	"Note: RBScanner only spots the beginning of the array."
	| scanner token |
	scanner := self buildScannerForText: '#('.
	token := scanner next.
	self assert: token start equals: 1.! !

!RBScannerTest methodsFor: 'tests - SpecialCharacters' stamp: ''!
testNextSpecialCharactereisSingle
	| scanner token |
	scanner := self buildScannerForText: '(]'.
	token := scanner next.
	self assert: token value equals: $(.
	
	scanner := self buildScannerForText: '^('.
	token := scanner next.
	self assert: token value equals: $^.
	
	scanner := self buildScannerForText: ']'.
	token := scanner next.
	self assert: token value equals: $].! !

!RBScannerTest methodsFor: 'tests - Literal' stamp: ''!
testNextNilIsLiteral
	| scanner token |
	scanner := self buildScannerForText: 'nil'.
	token := scanner next.
	self assert: token isLiteralToken.
	self assert: token value equals: nil.! !

!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextKeywordCanNotBeginWithDigit
	| scanner token |
	scanner := self buildScannerForText: '123alpha:'.
	
	token := scanner next.
	self assert: token isNumberLiteralToken.
	self assert: token value equals: 123.
	
	token := scanner next.
	self assert: token isKeyword.
	self assert: token value equals: 'alpha:'.! !

!RBScannerTest methodsFor: 'tests - Identifiers' stamp: ''!
testNextUnderscoreWithOnlyDigitsIsIdentifier

	"This test shows that the underscore is an alphabetic character."
	| scanner token |
	scanner := self buildScannerForText: '_123'.
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token value equals: '_123'.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextValueOfNegativeNumbers
	
	| scanner token |
	scanner := self buildScannerForText: '-12'.
	token := scanner next.
	self assert: token value equals: -12.
	
	scanner := self buildScannerForText: '-3'.
	token := scanner next.
	self assert: token value equals: -3.! !

!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextAlphabeticAndDigitEndingWithColonGiveKeyword
	| scanner token |
	scanner := self buildScannerForText: 'first123Token:'.
	token := scanner next.
	self assert: token isKeyword.! !

!RBScannerTest methodsFor: 'initialize' stamp: ''!
scannerClass
	^ RBScanner! !

!RBScannerTest methodsFor: 'tests - Identifiers' stamp: ''!
testNextIdentifierCanNotHaveBinary
	| scanner token |
	scanner := self buildScannerForText: 'first+Token'.
	
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token value equals: 'first'.
	
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '+'.
	
	token := scanner next.
	self assert: token isIdentifier.
	self assert: token value equals: 'Token'.! !

!RBScannerTest methodsFor: 'tests - Keyword' stamp: ''!
testNextKeywordCanContainUnderscore
	| scanner token |
	scanner := self buildScannerForText: 'first_Token:'.
	token := scanner next.
	self assert: token isKeyword.
	self assert: token value equals: 'first_Token:'.
	
	scanner := self buildScannerForText: '_firstToken:'.
	token := scanner next.
	self assert: token isKeyword.
	self assert: token value equals: '_firstToken:'.
	
	scanner := self buildScannerForText: '_firstToken:'.
	token := scanner next.
	self assert: token isKeyword.
	self assert: token value equals: '_firstToken:'.! !

!RBScannerTest methodsFor: 'tests - Comment' stamp: ''!
testNextWithTwoDoubleQuotesInComment
	| source token |
	source := '"only the"" opening"'.
	self
		shouldnt: [ token := (self buildScannerForText: source) next ]
		raise: SyntaxErrorNotification.
	self assert: token comments first value equals: 'only the"" opening'.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextRadixNumbersCanBeNegative
	
	| scanner token |
	scanner := self buildScannerForText: '-10r10'.
	token := scanner next.
	self assert: token value equals: -10.
	
	scanner := self buildScannerForText: '-2r1010'.
	token := scanner next.
	self assert: token value equals: -10.
	
	scanner := self buildScannerForText: '-16ra'.
	token := scanner next.
	self assert: token value equals: -10.
	
	scanner := self buildScannerForText: '-8r12'.
	token := scanner next.
	self assert: token value equals: -10.! !

!RBScannerTest methodsFor: 'tests - NumberLiteral' stamp: ''!
testNextNegativeNumberCanNotHaveSpaces
	
	| scanner token |
	scanner := self buildScannerForText: '- 12'.
	
	token := scanner next.
	self assert: token isBinary.
	self assert: token value equals: '-'.
	
	token := scanner next.
	self assert: token isNumberLiteralToken.
	self assert: token value equals: 12.! !

!RBSearchRule commentStamp: ''!
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 current answer. This two-argument approach allows a collection to be formed from all of the matches (Think inject:into:).

Instance Variables:
	answerBlock	<BlockClosure>	Block to evaluate with the matching node and the current answer.

!
!RBSearchRule methodsFor: 'private - searching' stamp: ''!
searchFor: aString thenDo: aBlock 
	self searchString: aString.
	answerBlock := aBlock! !

!RBSearchRule methodsFor: 'private - searching' stamp: ''!
searchForMethod: aString thenDo: aBlock 
	self methodSearchString: aString.
	answerBlock := aBlock! !

!RBSearchRule methodsFor: 'testing' stamp: ''!
canMatch: aProgramNode 
	owner answer: (answerBlock value: aProgramNode value: owner answer).
	^true! !

!RBSearchRule methodsFor: 'private - searching' stamp: ''!
searchForTree: aBRProgramNode thenDo: aBlock 
	searchTree := aBRProgramNode.
	answerBlock := aBlock! !

!RBSearchRule class methodsFor: 'instance creation' stamp: ''!
searchFor: aString thenDo: aBlock 
	^self new searchFor: aString thenDo: aBlock! !

!RBSearchRule class methodsFor: 'instance creation' stamp: ''!
searchForMethod: aString thenDo: aBlock 
	^self new searchForMethod: aString thenDo: aBlock! !

!RBSearchRule class methodsFor: 'instance creation' stamp: ''!
searchForTree: aBRProgramNode thenDo: aBlock 
	^self new searchForTree: aBRProgramNode thenDo: aBlock! !

!RBSearchTest methodsFor: 'accessing' stamp: ''!
buildSimpleLiteralSearch
	| search |
	search := self parseTreeSearcher.
	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: #(#protocolsToCheck) asBag.
	(classSearches
		at: RBBasicLintRuleTestData class
		ifAbsentPut: [ Set new ]) add: search! !

!RBSearchTest methodsFor: 'accessing' stamp: ''!
buildMethodArgumentSearch
	"Two argument methods"
	self 
		createMethodSearchWith: '`arg1: `arg1 `arg2: `arg2 | `@temps | `@.Stmts'
		selectors: #(
				#subclassOf:overrides:
				#createMatcherFor:method:
				#createParseTreeRule:name:
			)
		inClass: RBBasicLintRuleTestData class! !

!RBSearchTest methodsFor: 'accessing' stamp: ''!
createSearchWith: aCodeString selectors: selectorCollection inClass: aClass
	| search |
	search := self parseTreeSearcher.
	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: ''!
buildMessageSearch
	self 
		createSearchWith: '``@receiver -> ``@arg'
		selectors: #(#superSends #superSends )
		inClass: RBTransformationRuleTestData! !

!RBSearchTest methodsFor: 'accessing' stamp: ''!
buildArgumentSearch
	self 
		createArgumentSearchWith: 'aSmalllintContext'
		selectors: #(#checkMethod: #checkClass: )
		inClass: RBBasicLintRuleTestData! !

!RBSearchTest methodsFor: 'accessing' stamp: ''!
buildMethodTitleSearch
	self 
		createMethodSearchWith: 'initialize | `@temps | `@.Stmts'
		selectors: #(#initialize )
		inClass: RBBasicLintRuleTestData! !

!RBSearchTest methodsFor: 'accessing' stamp: ''!
createArgumentSearchWith: aCodeString selectors: selectorCollection inClass: aClass
	| search |
	search := self parseTreeSearcher.
	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: ''!
buildSimpleVariableSearch
	self 
		createSearchWith: 'result'
		selectors: #(
				#checkClass:
				#checkMethod:
				#isEmpty
				#problemCount
				#resetResult
				#resetResult
				#resetResult
				#result
				#result:
				#resultClass:
				#newResultClass:
				#viewResults
			)
		inClass: RBBasicLintRuleTestData! !

!RBSearchTest methodsFor: 'accessing' stamp: ''!
buildStatementSearch
	"Two or more statements"
	self 
		createSearchWith: '| `@temps | ``@.Stmts1. ``.Stmt1. ``@.Stmts2. ``.Stmt2. ``@.Stmts3'
		selectors: #(
				#checkMethod:
				#rewriteUsing:
				#viewResults
				#superSends
			)
		inClass: RBTransformationRuleTestData! !

!RBSearchTest methodsFor: 'accessing' stamp: ''!
createMethodSearchWith: aCodeString selectors: selectorCollection inClass: aClass
	| search |
	search := self parseTreeSearcher.
	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: ''!
buildMethodSearch
	"Simple forwarders"
	self 
		createMethodSearchWith: '`@methodName: `@args ^`@object `@methodName: `@args'
		selectors: #(#problemCount #isEmpty )
		inClass: RBTransformationRuleTestData! !

!RBSearchTest methodsFor: 'accessing' stamp: ''!
parseTreeSearcher
	^ RBParseTreeSearcher new! !

!RBSearchTest methodsFor: 'accessing' stamp: ''!
currentSelector
	^ currentSelector! !

!RBSearchTest methodsFor: 'tests' stamp: ''!
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 assertEmpty: each answer ] ]! !

!RBSearchTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	classSearches := Dictionary new.
	self
		buildMethodSearch;
		buildSimpleVariableSearch;
		buildSimpleLiteralSearch;
		buildMessageSearch;
		buildStatementSearch;
		buildArgumentSearch;
		buildMethodTitleSearch;
		buildMethodArgumentSearch! !

!RBSelectClassAndMethodsPresenter methodsFor: 'attributes' stamp: ''!
columnName 
	^ 'Methods'! !

!RBSelectClassAndMethodsPresenter methodsFor: 'attributes' stamp: ''!
columnSelector
	^ #selector! !

!RBSelectClassAndMethodsPresenter class methodsFor: 'examples' stamp: ''!
example
	<script>
	^ (self label: 'example ...' 
		dropLabel: 'Pull up methods'
		withItems: SycExtractMethodCommand methods
		selecting: OrderedCollection new
		dropItems: SycExtractMethodCommand allSuperclasses
		acceptBlock: [ :item :items |  ] )! !

!RBSelectClassAndMethodsPresenter class methodsFor: 'specs' stamp: ''!
title 
	^ 'Methods'! !

!RBSelectorEnvironment commentStamp: ''!
I am a RBBrowserEnvironment for a set of selectors. 
Usually I am constructed as a result of a query on another environment:
env referencesTo:#aselector -> a RBSelectorEnvironments.!
!RBSelectorEnvironment methodsFor: 'testing' stamp: ''!
isEmpty
	^classSelectors isEmpty and: [metaClassSelectors isEmpty]! !

!RBSelectorEnvironment methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass 
	^(super includesProtocol: aProtocol in: aClass)
		and: [(environment selectorsFor: aProtocol in: aClass)
				anySatisfy: [:aSelector | self privateIncludesSelector: aSelector inClass: aClass]]! !

!RBSelectorEnvironment methodsFor: 'accessing' stamp: ''!
packages
	"Check that packages have really class and selector included."

	| pSet |
	pSet := Set new.
	self classes
		do: [ :each | 
			each packages
				do: [ :p | 
					self
						selectorsForClass: each
						do: [ :s | 
							(p includesSelector: s ofClass: each)
								ifTrue: [ pSet add: p ] ] ] ].
	^ pSet! !

!RBSelectorEnvironment methodsFor: 'accessing - classes' stamp: ''!
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: '*Manifest-Core' stamp: ''!
smallLintCritics
	
	| array |
			
	array := OrderedCollection new.
	self classes do: [:cl | 
		self selectorsForClass: cl do: [:sel | array add:  (cl>>sel)]]. 
			
	^ array! !

!RBSelectorEnvironment methodsFor: 'private' stamp: ''!
privateIncludesSelector: aSelector inClass: aClass 
	^(self privateSelectorsForClass: aClass) includes: aSelector! !

!RBSelectorEnvironment methodsFor: 'accessing' stamp: ''!
asSelectorEnvironment
	^ self! !

!RBSelectorEnvironment methodsFor: 'private' stamp: ''!
privateSelectorsForClass: aClass 
	^aClass isMeta 
		ifTrue: [metaClassSelectors at: aClass soleInstance name ifAbsent: [#()]]
		ifFalse: [classSelectors at: aClass name ifAbsent: [#()]]! !

!RBSelectorEnvironment methodsFor: 'private' stamp: ''!
defaultLabel
	^'some methods'! !

!RBSelectorEnvironment methodsFor: 'initialization' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	super initialize.
	classSelectors := IdentityDictionary new.
	metaClassSelectors := IdentityDictionary new! !

!RBSelectorEnvironment methodsFor: 'testing' stamp: ''!
includesCategory: aCategory 
	^(super includesCategory: aCategory) and: 
			[(self classNamesFor: aCategory) anySatisfy: 
					[:className | 
					(classSelectors includesKey: className) 
						or: [metaClassSelectors includesKey: className]]]! !

!RBSelectorEnvironment methodsFor: 'testing' stamp: ''!
includesSelector: aSelector in: aClass 
	^(environment includesSelector: aSelector in: aClass)
		and: [self privateIncludesSelector: aSelector inClass: aClass]! !

!RBSelectorEnvironment methodsFor: 'accessing - classes' stamp: ''!
classNames
	^ IdentitySet new
		addAll: classSelectors keys;
		addAll: metaClassSelectors keys;
		yourself! !

!RBSelectorEnvironment methodsFor: 'initialization' stamp: ''!
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: 'copying' stamp: ''!
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: 'testing' stamp: ''!
isSelectorEnvironment
	^ true! !

!RBSelectorEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass 
	^(self privateSelectorsForClass: aClass) isNotEmpty 
		and: [super includesClass: aClass]! !

!RBSelectorEnvironment methodsFor: 'initialize-release' stamp: ''!
classSelectors: classSelectorDictionary metaClassSelectors: metaClassSelectorDictionary 
	classSelectors := classSelectorDictionary.
	metaClassSelectors := metaClassSelectorDictionary! !

!RBSelectorEnvironment methodsFor: 'accessing' stamp: ''!
selectorsForClass: aClass do: aBlock 
	^(self privateSelectorsForClass: aClass) 
		do: [:each | (aClass includesSelector: each) ifTrue: [aBlock value: each]]! !

!RBSelectorEnvironment methodsFor: 'removing' stamp: ''!
removeClass: aClass selector: aSelector 
	(aClass isMeta 
		ifTrue: [metaClassSelectors at: aClass soleInstance name ifAbsent: [^self]]
		ifFalse: [classSelectors at: aClass name ifAbsent: [^self]]) 
			remove: aSelector
			ifAbsent: []! !

!RBSelectorEnvironment methodsFor: 'adding' stamp: ''!
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: 'adding' stamp: ''!
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: 'printing' stamp: ''!
storeOn: aStream 
	| classBlock |
	aStream
		nextPutAll: '((';
		nextPutAll: self class name;
		nextPutAll: ' onEnvironment: '.
	environment storeOn: aStream.
	aStream
		nextPut: $);
		nextPutAll: ' classes: #('.
	classBlock := 
			[:key :value | 
			aStream
				nextPutAll: '#(';
				nextPutAll: key;
				nextPutAll: ' #('.
			value do: 
					[:each | 
					aStream
						nextPutAll: each;
						nextPut: $ ].
			aStream
				nextPutAll: '))';
				cr].
	classSelectors keysAndValuesDo: classBlock.
	aStream nextPutAll: ') metaClasses: #('.
	metaClassSelectors keysAndValuesDo: classBlock.
	aStream nextPutAll: '))'! !

!RBSelectorEnvironment methodsFor: 'adding' stamp: ''!
addMethod: aMethod
	"this is a method to improve addition of methods, as class and selector data can be retrieved from a single compiled method"
	
	self addClass: aMethod methodClass selector: aMethod selector! !

!RBSelectorEnvironment methodsFor: 'removing' stamp: ''!
removeClass: aClass 
	aClass isMeta 
		ifTrue: [metaClassSelectors removeKey: aClass soleInstance name ifAbsent: []]
		ifFalse: [classSelectors removeKey: aClass name ifAbsent: []]! !

!RBSelectorEnvironment class methodsFor: 'instance creation' stamp: ''!
onMethods: selectorCollection forClass: aClass
	^ self
		onMethods: selectorCollection
		forClass: aClass
		in: self default ! !

!RBSelectorEnvironment class methodsFor: 'instance creation' stamp: ''!
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: ''!
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 withAllNestedLiteralsDo: [ :literal | 
			literal isString ifTrue: [
				(aString match: literal)
					ifTrue: [ newEnvironment addClass: class selector: selector ] ] ] ].
	^ newEnvironment! !

!RBSelectorEnvironment class methodsFor: 'instance creation' stamp: ''!
implementorsMatching: aString
	^ self 
		implementorsMatching: aString 
		in: self default! !

!RBSelectorEnvironment class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Selectors'! !

!RBSelectorEnvironment class methodsFor: 'instance creation' stamp: ''!
implementorsOf: aSelector
	^ self
		implementorsOf: aSelector
		in: self default ! !

!RBSelectorEnvironment class methodsFor: 'instance creation' stamp: ''!
implementorsOf: aSelector in: anEnvironment 
	| classDict metaDict selectors |
	classDict := IdentityDictionary new.
	metaDict := IdentityDictionary new.
	selectors := IdentitySet with: aSelector.
	anEnvironment classesDo: [ :class | 
		((class includesLocalSelector: aSelector) and: [ anEnvironment includesSelector: aSelector in: class ]) 
			ifTrue: [
				class isMeta 
					ifTrue: [ metaDict at: class soleInstance name put: selectors copy ]
					ifFalse: [ classDict at: class name put: selectors copy ] ] ].
	^ (self onEnvironment: anEnvironment)
		classSelectors: classDict metaClassSelectors: metaDict;
		label: 'Implementors of ' , aSelector;
		yourself! !

!RBSelectorEnvironment class methodsFor: 'instance creation' stamp: ''!
matches: aString
	^ self
		matches: aString
		in: self default! !

!RBSelectorEnvironment class methodsFor: 'instance creation' stamp: ''!
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: ''!
referencesTo: aLiteral
	^ self
		referencesTo: aLiteral
		in: self default ! !

!RBSelectorEnvironment class methodsFor: 'instance creation' stamp: ''!
referencesTo: aLiteral in: anEnvironment 
	| classDict literalPrintString |
	literalPrintString := aLiteral isVariableBinding
		ifTrue: [ aLiteral key asString ]
		ifFalse: [
			aLiteral isString
				ifTrue: [ aLiteral ]
				ifFalse: [ aLiteral printString ] ].
	classDict := IdentityDictionary new.
	anEnvironment classesDo: [ :class | 
		| selectors |
		selectors := (class thoroughWhichSelectorsReferTo: aLiteral)
			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! !

!RBSelectorNode commentStamp: ''!
RBSelectorNode is an AST node that represents a selector (unary, binary, keyword).

Instance Variables:
	value	<String>	the selector's name I represent or the ensemble of keywords I'm made of
	start <Integer>	the position where I was found at the source code
!
!RBSelectorNode methodsFor: 'accessing' stamp: ''!
value: aString
	value := aString asSymbol! !

!RBSelectorNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [^true].
	^ self class = anObject class ifTrue: [ self value = anObject value ] ifFalse: [ false ]! !

!RBSelectorNode methodsFor: 'accessing' stamp: ''!
stopWithoutParentheses
	
	^ self keywordPositions last + self keywords last size! !

!RBSelectorNode methodsFor: 'comparing' stamp: ''!
hash
	^ self value hash! !

!RBSelectorNode methodsFor: 'testing' stamp: ''!
needsParenthesis
	^false! !

!RBSelectorNode methodsFor: 'accessing' stamp: ''!
startWithoutParentheses
	^ keywordPositions first! !

!RBSelectorNode methodsFor: 'accessing' stamp: ''!
numArgs 
	^ value numArgs! !

!RBSelectorNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitSelectorNode: self! !

!RBSelectorNode methodsFor: 'testing' stamp: ''!
isSelector
	^true! !

!RBSelectorNode methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		<< self class name
		<< '('
		<< value asString
		<< ')'! !

!RBSelectorNode methodsFor: 'accessing' stamp: ''!
value
	^value! !

!RBSelectorNode methodsFor: 'accessing' stamp: ''!
keywords

	^ value keywords! !

!RBSelectorNode methodsFor: 'accessing' stamp: ''!
keywordPositions: positions

	keywordPositions := positions! !

!RBSelectorNode methodsFor: 'accessing' stamp: ''!
keywordPositions

	^ keywordPositions! !

!RBSelectorNode class methodsFor: 'accessing' stamp: ''!
value: aString

	^ self value: aString keywordPositions: #(0)! !

!RBSelectorNode class methodsFor: 'accessing' stamp: ''!
value: aString keywordPositions: keywordPositions

	^ self new
		value: aString;
	 	keywordPositions: keywordPositions;
		yourself! !

!RBSequenceNode commentStamp: ''!
RBSequenceNode is an AST node that represents a sequence of statements. Both RBBlockNodes and RBMethodNodes contain these.

Instance Variables:
	leftBar	<Integer | nil>	the position of the left | in the temporaries definition
	rightBar	<Integer | nil>	the position of the right | in the temporaries definition
	statements	<SequenceableCollection of: RBReturnNode or RBValueNode> the statement nodes
	periods	<SequenceableCollection of: Integer>	the positions of all the periods that separate the statements
	temporaries	<SequenceableCollection of: RBVariableNode>	the temporaries defined

!
!RBSequenceNode methodsFor: 'accessing' stamp: ''!
stop
	^{  
	temporaries isEmpty ifTrue: [0] ifFalse: [ self temporaries last stop]. 
	periods isEmpty ifTrue: [0] ifFalse: [periods last].
	statements isEmpty ifTrue: [0] ifFalse: [statements last stop]
	} max! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
addTemporaryNamed: aString 
	| variableNode |
	variableNode := RBVariableNode named: aString.
	variableNode parent: self.
	temporaries := temporaries copyWith: variableNode.
	^ variableNode! !

!RBSequenceNode methodsFor: 'comparing' stamp: ''!
hash
	^ (self hashForCollection: self temporaries) bitXor: (self hashForCollection: self statements)! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
addNodeFirst: aNode
	aNode parent: self.
	statements := statements asOrderedCollection
		addFirst: aNode;
		yourself.
	^ aNode! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
children
	^(OrderedCollection new)
		addAll: temporaries;
		addAll: statements;
		yourself! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
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: 'accessing - token' stamp: ''!
leftBar: anInteger
	leftBar := anInteger! !

!RBSequenceNode methodsFor: 'converting' stamp: ''!
asSequenceNode
	^self! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
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: 'accessing' stamp: ''!
allDefinedVariables
	^(self temporaryNames asOrderedCollection)
		addAll: super allDefinedVariables;
		yourself! !

!RBSequenceNode methodsFor: 'private' stamp: ''!
indexOfNode: aNode 
	"Try to find the node by first looking for ==, and then for ="

	^(1 to: statements size) detect: [:each | (statements at: each) == aNode]
		ifNone: [statements indexOf: aNode]! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
temporaryNames
	^temporaries collect: [:each | each name]! !

!RBSequenceNode methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	periods := OrderedCollection new.
	statements := OrderedCollection new.
	temporaries := OrderedCollection new! !

!RBSequenceNode methodsFor: 'testing' stamp: ''!
lastIsReturn
	^statements notEmpty and: [statements last lastIsReturn]! !

!RBSequenceNode methodsFor: 'comparing' stamp: ''!
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].	"Not a one-to-one mapping"
	self temporaries
		do: [:each | aDictionary removeKey: each name ifAbsent: []].
	^true! !

!RBSequenceNode methodsFor: 'accessing - token' stamp: ''!
periods: anArray
	periods := anArray! !

!RBSequenceNode methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self temporaries: (self temporaries collect: [ :each | each copy ]).
	self statements: (self statements collect: [ :each | each copy ])! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
temporaries
	^temporaries! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
addNodes: aCollection before: anotherNode
	aCollection do: [ :each | self addNode: each before: anotherNode ].
	^ aCollection! !

!RBSequenceNode methodsFor: 'testing' stamp: ''!
directlyUses: aNode 
	^false! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
allStatements
	^ statements asOrderedCollection copy
			addAll: super allStatements;
			yourself! !

!RBSequenceNode methodsFor: 'accessing - token' stamp: ''!
leftBar
	^ leftBar! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
statements: stmtCollection 
	statements := stmtCollection.
	statements do: [:each | each parent: self]! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
removeTemporaryNamed: aName 
	temporaries := temporaries reject: [:each | each name = aName]! !

!RBSequenceNode methodsFor: 'matching' stamp: ''!
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: 'comparing' stamp: ''!
= anObject 
	"Can't send = to the temporaries and statements collection since they might change from arrays to OCs"

	self == anObject ifTrue: [^true].
	self class = anObject class ifFalse: [^false].
	self temporaries size = anObject temporaries size ifFalse: [^false].
	self temporaries
		with: anObject temporaries
		do: [:first :second | first = second ifFalse: [^false]].
	self statements size = anObject statements size ifFalse: [^false].
	self statements
		with: anObject statements
		do: [:first :second | first = second ifFalse: [^false]].
	^true! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
addNodesFirst: aCollection
	aCollection do: [ :each | each parent: self ].
	statements := statements asOrderedCollection
		addAllFirst: aCollection;
		yourself.
	^ aCollection! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
temporaryVariables
	^(super temporaryVariables asOrderedCollection)
		addAll: self temporaryNames;
		yourself! !

!RBSequenceNode methodsFor: 'testing' stamp: ''!
isLast: aNode 
	| last |
	statements isEmpty ifTrue: [^false].
	last := statements last.
	^last == aNode or: 
			[last isMessage and: 
					[(#(#ifTrue:ifFalse: #ifFalse:ifTrue:) includes: last selector) 
						and: [last arguments anySatisfy: [:each | each isLast: aNode]]]]! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
addReturn
	| node |
	statements isEmpty
		ifTrue: [ ^ nil ].
	statements last isReturn
		ifTrue: [ ^ statements last ].
	node := RBReturnNode value: statements last.
	statements at: statements size put: node.
	node parent: self.
	^ node! !

!RBSequenceNode methodsFor: 'testing' stamp: ''!
isFaulty
	^self statements anySatisfy: [:each | each isFaulty]! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
addNodeLast: aNode

	self lastIsReturn
		ifTrue: [ self addNode: aNode before: self statements last ]
		ifFalse: [ self addNode: aNode ]! !

!RBSequenceNode methodsFor: 'initialization' stamp: ''!
leftBar: leftInteger temporaries: variableNodes rightBar: rightInteger 
	leftBar := leftInteger.
	self temporaries: variableNodes.
	rightBar := rightInteger! !

!RBSequenceNode methodsFor: 'testing' stamp: ''!
isSequence
	^true! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
addTemporariesNamed: aCollection
	^ aCollection collect: [ :each | self addTemporaryNamed: each ]! !

!RBSequenceNode methodsFor: 'testing' stamp: ''!
hasTemporaryNamed: aString

	^ temporaries anySatisfy: [ :temp | temp name = aString ]! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
allTemporaryVariables
	^(self temporaryNames asOrderedCollection)
		addAll: super allTemporaryVariables;
		yourself! !

!RBSequenceNode methodsFor: 'querying' stamp: ''!
bestNodeFor: anInterval 
	| node |
	node := super bestNodeFor: anInterval.
	node == self 
		ifTrue: 
			[(temporaries isEmpty and: [statements size == 1]) 
				ifTrue: [^statements first]].
	^node! !

!RBSequenceNode methodsFor: 'testing' stamp: ''!
uses: aNode 
	statements isEmpty ifTrue: [^false].
	aNode == statements last ifFalse: [^false].
	^self isUsed! !

!RBSequenceNode methodsFor: 'querying' stamp: ''!
whichNodeIsContainedBy: anInterval 
	| node |
	node := super whichNodeIsContainedBy: anInterval.
	node == self 
		ifTrue: 
			[(temporaries isEmpty and: [statements size == 1]) 
				ifTrue: [^statements first]].
	^node! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
transformLastToReturn
	"transform the last statement, but this method returns the sequence, not the returnNode"
	self addReturn! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
addFaultyNode: aNode
"just like addNode, but ignore if we already include a return node, as we are faulty"
	aNode parent: self.
	statements := statements asOrderedCollection
		add: aNode;
		yourself.
	^ aNode! !

!RBSequenceNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNodes: aCollection 
	| index newStatements |
	self clearReplacements.
	index := self indexOfNode: aNode.
	newStatements := OrderedCollection new: statements size + aCollection size.
	1 to: index - 1 do: [:i | newStatements add: (statements at: i)].
	newStatements addAll: aCollection.
	index + 1 to: statements size
		do: [:i | newStatements add: (statements at: i)].
	aCollection do: [:each | each parent: self].
	statements := newStatements! !

!RBSequenceNode methodsFor: 'replacing' stamp: ''!
replaceNode: aNode withNode: anotherNode 
	self statements: (statements 
				collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]]).
	self temporaries: (temporaries 
				collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! !

!RBSequenceNode methodsFor: 'testing' stamp: ''!
hasTemporaries

	^ temporaries isNotEmpty! !

!RBSequenceNode methodsFor: 'accessing - token' stamp: ''!
rightBar: anInteger
	rightBar := anInteger! !

!RBSequenceNode methodsFor: 'replacing' stamp: ''!
removeNode: aNode
	self replaceNode: aNode withNodes: #()! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
statements
	^statements! !

!RBSequenceNode methodsFor: 'testing' stamp: ''!
defines: aName 
	^temporaries anySatisfy: [:each | each name = aName]! !

!RBSequenceNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitSequenceNode: self! !

!RBSequenceNode methodsFor: 'replacing' stamp: ''!
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: 'adding nodes' stamp: ''!
addSelfReturn
	| node |
	self lastIsReturn
		ifTrue: [ ^ self statements last ].
	node := RBReturnNode value: RBVariableNode selfNode.
	^ self addNode: node! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
addNode: aNode after: anotherNode

	| index |
	index := self indexOfNode: anotherNode.
	index = 0
		ifTrue: [ ^ self addNode: aNode ].
	statements := statements asOrderedCollection
		add: aNode afterIndex: index;
		yourself.
	aNode parent: self.
	^ aNode! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
temporaries: tempCollection 
	temporaries := tempCollection.
	temporaries do: [:each | each parent: self]! !

!RBSequenceNode methodsFor: 'testing' stamp: ''!
references: aVariableName 
	^statements anySatisfy: [:each | each references: aVariableName]! !

!RBSequenceNode methodsFor: 'accessing - token' stamp: ''!
periods
	^ periods! !

!RBSequenceNode methodsFor: 'adding nodes' stamp: ''!
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: 'accessing - token' stamp: ''!
rightBar
	^ rightBar! !

!RBSequenceNode methodsFor: 'accessing' stamp: ''!
start
	^ leftBar 
		ifNil: [statements isEmpty ifTrue: [1] ifFalse: [statements first start]]! !

!RBSequenceNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	^ self class new
		temporaries: (self copyList: self temporaries inContext: aDictionary);
		statements: (self copyList: self statements inContext: aDictionary);
		yourself! !

!RBSequenceNode class methodsFor: 'instance creation' stamp: ''!
leftBar: leftInteger temporaries: variableNodes rightBar: rightInteger 
	^(self new)
		leftBar: leftInteger
			temporaries: variableNodes
			rightBar: rightInteger;
		yourself! !

!RBSequenceNode class methodsFor: 'instance creation' stamp: ''!
statements: statementNodes 
	^self temporaries: #() statements: statementNodes! !

!RBSequenceNode class methodsFor: 'instance creation' stamp: ''!
temporaries: variableNodes statements: statementNodes 
	^(self new)
		temporaries: variableNodes;
		statements: statementNodes;
		yourself! !

!RBSequenceNodeTest methodsFor: 'tests' stamp: ''!
testStop
	| ast |
	ast := self parserClass parseMethod: 'method | temp |'.
	self assert: ast body stop equals: ast body temporaries last stop! !

!RBSequenceNodeTest methodsFor: 'tests' stamp: ''!
testModifyParametersShouldNotModifyPeriods

	| sequenceNode |
	sequenceNode := RBSequenceNode new.
	sequenceNode statements add: #example.
	self
		assertCollection: sequenceNode statements
		hasSameElements: { #example }.
	self assert: sequenceNode periods isEmpty.
	self assert: sequenceNode temporaries isEmpty! !

!RBSharedPoolForTestData methodsFor: 'tests - perform' stamp: ''!
msg2
	
	^ Var1! !

!RBSharedPoolForTestData methodsFor: 'tests - perform' stamp: ''!
msg4
	
	^ Var1! !

!RBSharedPoolForTestData methodsFor: 'tests - perform' stamp: ''!
msg1
	
	^ Var1! !

!RBSharedPoolForTestData1 methodsFor: 'tests perform' stamp: ''!
msg4
	
	^ Var1! !

!RBSharedPoolForTestData2 methodsFor: 'tests - perform' stamp: ''!
reference 	
	^ RBRemoveClassParametrizedTest! !

!RBSharedPoolForTestData2 methodsFor: 'tests - perform' stamp: ''!
msg4
	
	^ Var1! !

!RBShortAssignmentToken commentStamp: ''!
I was used for the left arrow assignment (the ASCII underscore character) operator.
In the current scanner/parser, this assignment operator is not used or allowed anymore.!
!RBShortAssignmentToken methodsFor: 'private' stamp: ''!
length
	^ 1! !

!RBSimpleFormatter commentStamp: ''!
I'm a simple formatter that prints nodes (without using source code).
I'm useful when AST are programmatically assembled. 

I could be improved, but the goal is to get the information is a more or less ok form.
!
!RBSimpleFormatter methodsFor: 'private' stamp: ''!
handleLineForArgument: anArgument

  self 
		space;
		visitNode: anArgument! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
precedenceOf: parentSelector greaterThan: childSelector
  "Put parenthesis around things that are preceived to have 'lower' precedence. For example, 'a + b * c' 
	-> '(a + b) * c' but 'a * b + c' -> 'a * b + c'"
  | childIndex parentIndex |
  childIndex := 0.
  parentIndex := 0.
  1 to: self traditionalBinaryPrecedenceArray size do: [:i | ((self traditionalBinaryPrecedenceArray at: i) includes: parentSelector first) ifTrue: [ parentIndex := i ].
        ((self traditionalBinaryPrecedenceArray at: i) includes: childSelector first) ifTrue: [ childIndex := i ] ].
  ^childIndex < parentIndex! !

!RBSimpleFormatter methodsFor: 'accessing' stamp: ''!
lineStart: anObject
	lineStart := anObject! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode
	self
		bracketWith: '[]'
		around: [ self formatBlock: aBlockNode ]! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode

	self 
		formatTemporariesFor: aSequenceNode;
		formatCommentsFor: aSequenceNode;
		formatSequenceNodeStatementsFor: aSequenceNode! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
writeString: aString
	| index |
	index := aString lastIndexOf: Character cr ifAbsent: [ 0 ].
	 codeStream nextPutAll: aString .
	index > 0
		ifTrue: [ lineStart := codeStream position - (aString size - index) ]! !

!RBSimpleFormatter methodsFor: 'accessing' stamp: ''!
indent
	^ indent! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
indent: anInteger around: aBlock
	self indent: self indent + anInteger.
	^ aBlock
		ensure: [ self indent: self indent - anInteger ]! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitReturnNode: aReturnNode 
	codeStream nextPut: $^.
	self visitNode: aReturnNode value! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatArray: anArrayNode
	anArrayNode statements
		do: [ :each | 
				self visitNode: each ]
		separatedBy: 
				[ codeStream nextPutAll: ' . '.
				self newLine ]! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
indentAround: aBlock 
	self indent: 1 around: aBlock! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatMethodPatternFor: aMethodNode
	aMethodNode arguments isEmpty
		ifTrue: [ codeStream nextPutAll: aMethodNode selector ]
		ifFalse: [ self privateFormatMethodPatternMonoLineFor: aMethodNode ]! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: anAssignmentNode 
	self visitNode: anAssignmentNode variable.
	codeStream space; nextPutAll: anAssignmentNode assignmentOperator; space.
	self visitNode: anAssignmentNode value! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatBlock: aBlockNode
	self 
		formatBlockArgumentsFor: aBlockNode;
		space;
		visitNode: aBlockNode body;
		space! !

!RBSimpleFormatter methodsFor: 'accessing' stamp: ''!
codeStream: anObject
	codeStream := anObject! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitLiteralNode: aLiteralNode
	self
		writeString:
			(aLiteralNode value isLiteral
				ifFalse: [ '''<an unprintable nonliteral value>''' ]
				ifTrue: [ aLiteralNode sourceText ])! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitNode: aNode
	| needsParenthesis |
	needsParenthesis := self needsParenthesisFor: aNode.
	self
		bracketWith:
			(needsParenthesis
				ifTrue: [ '()' ]
				ifFalse: [ '' ])
		around: [ super visitNode: aNode ]! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatBlockArgumentsFor: aBlockNode
	aBlockNode arguments isEmpty
		ifTrue: [ ^ self ].
	aBlockNode arguments
		do: [ :each | 
			   codeStream nextPut: $:.
			   self 
					visitNode: each;
			   		formatCommentsFor: each;
					space ].
	codeStream nextPutAll: '| '! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
bracketWith: bracketString around: aBlock
	bracketString isEmpty
		ifTrue: [ ^ aBlock value ].
	codeStream nextPut: bracketString first.
	^ aBlock
		ensure: [ codeStream nextPut: bracketString last ]! !

!RBSimpleFormatter methodsFor: 'public interface' stamp: ''!
format: aParseTree
	self visitNode: aParseTree.
	^ codeStream contents! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
addSpaceIfNeededForLastArgument: aPragmaNode
	aPragmaNode isUnary
		ifTrue: [ ^ self ].
	(self pragmaArgumentNeedsSeparator: aPragmaNode arguments last)
		ifTrue: [ self space ]! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
privateFormatMethodPatternMonoLineFor: aMethodNode
	self
		with: aMethodNode selectorParts
		and: aMethodNode arguments
		do: [:key :arg | 
			codeStream nextPutAll: key.
			self space.
			self visitNode: arg ]
		separatedBy: [ self space ]! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitParseErrorNode: aNode
		self writeString: aNode value! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitPatternWrapperBlockNode: aRBPatternWrapperBlockNode
	self visitNode: aRBPatternWrapperBlockNode wrappedNode.
	codeStream nextPut: $`.
	self 
		bracketWith: '{}' 
		around: [ self formatBlock: aRBPatternWrapperBlockNode ]! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatSelectorAndArguments: aMessageNode
	
	self
		indent: 2
		around: [ 
			self
				formatSelectorAndArguments: aMessageNode
				firstSeparator: [ self space ]
				restSeparator: [ self space ] ]! !

!RBSimpleFormatter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	lineStart := 0.
	self indent: 0.
	codeStream := (String new: 256) writeStream! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aRBArrayLiteralNode
	| brackets |
	codeStream nextPut: $#.
	brackets := aRBArrayLiteralNode isForByteArray
		ifTrue: [ '[]' ]
		ifFalse: [ '()' ].
	self
		bracketWith: brackets
		around: [ aRBArrayLiteralNode contents
				do: [ :each | self visitNode: each ]
				separatedBy: [ self space ] ]! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatPragmasFor: aMethodNode
	aMethodNode pragmas do: [:each | self visitNode: each; newLine ]! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatStatementCommentsFor: aStatementNode

	aStatementNode statementComments do: [ :each | 
			self
				newLine;
				basicFormatCommentFor: each
			]! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
newLines: anInteger
	anInteger + self indentString size = 0
		ifTrue: 
			[ codeStream space ].
	anInteger
		timesRepeat: 
			[ codeStream cr ].
	lineStart := codeStream position.
	self
		indent
		timesRepeat: 
			[ codeStream nextPutAll: self indentString ]! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
basicFormatCommentFor: aComment
	codeStream
		nextPut: $";
		nextPutAll: aComment contents;
		nextPut: $"! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitArrayNode: anArrayNode
	self bracketWith: '{}' around: [ self formatArray: anArrayNode ]! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatCommentsFor: aNode

	aNode comments do: [ :each | 
			self
				basicFormatCommentFor: each;
				newLine
			]! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitMessageNode: aMessageNode 
	self 
		visitNode: aMessageNode receiver;
		formatSelectorAndArguments: aMessageNode! !

!RBSimpleFormatter methodsFor: 'accessing' stamp: ''!
indent: anInteger

	indent := anInteger! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatSequenceNodeStatementsFor: aSequenceNode
	| statements |
	statements := aSequenceNode statements.
	statements isEmpty
		ifTrue: [ ^ self ].
 
	statements doWithIndex: [ :el :i | 
		self visitNode: (statements at: i).
		i < statements size
			ifTrue: [ codeStream nextPut: $.. 
						self newLine].
		self formatStatementCommentsFor: el.
		i < statements size
			ifTrue: [  ] ]! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
newLine
	self newLines: 1! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatMethodCommentFor: aNode

	aNode comments do: [ :each | 
			self
				basicFormatCommentFor: each;
				newLine
			]! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatMethodBodyFor: aMethodNode
	self
		indentAround: [ 
			self
				newLine;
				formatMethodCommentFor: aMethodNode;
				formatPragmasFor: aMethodNode;
				visitNode: aMethodNode body ]! !

!RBSimpleFormatter methodsFor: 'utilities' stamp: ''!
with: firstCollection and: secondCollection do: aBlock separatedBy: separatorBlock
	firstCollection isEmpty
		ifTrue: [ ^ self ].
	aBlock value: firstCollection first value: secondCollection first.
	2 to: firstCollection size do: [ :i | 
		separatorBlock value.
		aBlock value: (firstCollection at: i) value: (secondCollection at: i) ]! !

!RBSimpleFormatter methodsFor: 'accessing' stamp: ''!
indentString
	^ '  '! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
needsParenthesisFor: aNode
	| parent |
	aNode ifNil: [ ^ false ].
	aNode isValue
		ifFalse: [ ^ false ].
	aNode isParseError 
		ifTrue: [ ^false ].
	parent := aNode parent ifNil: [ ^ false ].
	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 isUnary
		ifTrue: [ ^ false ].
	aNode isKeyword
		ifTrue: [ ^ true ].
	(parent isMessage and: [ parent receiver == aNode ])
		ifFalse: [ ^ true ].
	aNode precedence = parent precedence
		ifFalse: [ ^ true ].
	^ self precedenceOf: parent selector greaterThan: aNode selector! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
pragmaArgumentNeedsSeparator: anArgumentNode
	^ anArgumentNode value isSymbol and: [ anArgumentNode value isBinary ]! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitCascadeNode: aCascadeNode
	self visitNode: aCascadeNode receiver.
	self
		indentAround: [ self newLine.
			aCascadeNode messages
				do: [ :each | 
					self
						indentAround: [ self
								formatSelectorAndArguments: each
								firstSeparator: [  ]
								restSeparator: [ self space ] ] ]
				separatedBy: [ codeStream nextPut: $;.
					self newLine ] ]! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode 
	self 
		formatMethodPatternFor: aMethodNode;
		formatMethodBodyFor: aMethodNode! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitPragmaNode: aPragmaNode
	codeStream nextPut: $<.
	self 
		formatSelectorAndArguments: aPragmaNode 
		firstSeparator: [ 
			aPragmaNode selector isInfix
				ifTrue: [ self space ] ]
		restSeparator: [ self space ].
	self addSpaceIfNeededForLastArgument: aPragmaNode.
	codeStream nextPut: $>! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitPatternBlockNode: aRBPatternBlockNode 
	codeStream nextPut: $`.
	self 
		bracketWith: '{}' 
		around: [ self formatBlock: aRBPatternBlockNode ]! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
formatTemporariesFor: aSequenceNode
	aSequenceNode temporaries isEmpty
		ifTrue: [ ^ self ].
	self
		bracketWith: '|'
		around: [ 
			self space.
			aSequenceNode temporaries
				do:
					[ :each | 
					self 
						visitNode: each;
						formatStatementCommentsFor: each;
						space ]].
	self newLine.! !

!RBSimpleFormatter methodsFor: 'accessing' stamp: ''!
traditionalBinaryPrecedenceArray
	^  #(#($| $& $?) #($= $~ $< $>) #($- $+) #($* $/ $% $\) #($@))! !

!RBSimpleFormatter methodsFor: 'private' stamp: ''!
space
	codeStream space! !

!RBSimpleFormatter methodsFor: 'private - formatting' stamp: ''!
formatSelectorAndArguments: aMessageNode firstSeparator: firstBlock restSeparator: restBlock
	aMessageNode isUnary
		ifTrue: [ 
			self space.
			codeStream nextPutAll: aMessageNode selector ]
		ifFalse: [ 
			aMessageNode selectorParts
				with: aMessageNode arguments
				do: [ :selector :argument | 
					self space.
					self
						indentAround: [ 
							codeStream nextPutAll: selector.
							self handleLineForArgument: argument ] ] ]! !

!RBSimpleFormatter methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode 
	codeStream nextPutAll: aVariableNode name! !

!RBSimpleFormatter methodsFor: 'accessing' stamp: ''!
codeStream
	^ codeStream! !

!RBSimpleFormatter methodsFor: 'accessing' stamp: ''!
lineStart
	^ lineStart! !

!RBSimpleFormatter class methodsFor: 'class initialization' stamp: ''!
initialize
  "self initialize"
  FormatAsYouReadPolicy := false.! !

!RBSimpleFormatter class methodsFor: 'accessing' stamp: ''!
formatAsYouReadPolicy: anObject
	FormatAsYouReadPolicy := anObject! !

!RBSimpleFormatter class methodsFor: 'public' stamp: ''!
format: aParseTree withIndents: anInteger 
	^ self new
		indent: anInteger;
		format: aParseTree! !

!RBSimpleFormatter class methodsFor: 'accessing' stamp: ''!
formatAsYouReadPolicy
	^ FormatAsYouReadPolicy! !

!RBSimpleFormatter class methodsFor: 'public' stamp: ''!
format: aParseTree 
	^self format: aParseTree withIndents: 0! !

!RBSlotInitializationNode commentStamp: ''!
I represent the Slot initialization part of a slot definition. 
I'm a transformation from the AST.

For example for this expression 'first' => (LazyClassVariable default: 5), I represent 
the default: 5 part. 

Slot initialization node works for the three slot forms below. 
To make sure that all slot definition are polymorphic, all slots have a initializationNode (some acting as null node).

Object subclass: #MyClass
		slots: {
		'first' => LazyClassVariable default: 5. 
		'second' => InstanceVariableSlot.
		'instVar3'
		}
		classVariableNames: ''
		package: #MyPackage'

'first' => LazyClassVariable default: x + 3

In this case the argument parts is a RBMessageNode.


		
	!
!RBSlotInitializationNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [^true].
	self class = anObject class ifFalse: [^false].
 	(self selectorParts = anObject selectorParts) ifFalse: [^false].
	^ self argumentParts = anObject argumentParts! !

!RBSlotInitializationNode methodsFor: 'accessing' stamp: ''!
argumentParts
	^ argumentParts! !

!RBSlotInitializationNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aVisitor
	"Continue the navigation only on non null messages."
	^ self isNull ifFalse: [ aVisitor visitSlotInitializationNode: self ]! !

!RBSlotInitializationNode methodsFor: 'accessing' stamp: ''!
argumentParts: aCollection 
	argumentParts := aCollection! !

!RBSlotInitializationNode methodsFor: 'comparing' stamp: ''!
hash
	^ self hashForCollection: self arguments! !

!RBSlotInitializationNode methodsFor: 'initialization' stamp: ''!
initialize 
	
	super initialize.
	selectorParts := #().
	argumentParts := #()! !

!RBSlotInitializationNode methodsFor: 'testing' stamp: ''!
isNull 
	^ selectorParts isEmpty! !

!RBSlotInitializationNode methodsFor: 'printing' stamp: ''!
printOn: aStream
	"We make sure that the result is empty to be used like a bad null pattern now."
	
	self isNull 
		ifFalse: [ 
				| size |
				size := selectorParts size. 
				selectorParts withIndexDo: [ :each :i |
							aStream 
								nextPutAll:  each asString  ;
								<< ' ';
								print: (argumentParts at: i) .
							i = size ifFalse: [ aStream	<< ' ']]]! !

!RBSlotInitializationNode methodsFor: 'accessing' stamp: ''!
selectorParts
	^ selectorParts! !

!RBSlotInitializationNode methodsFor: 'accessing' stamp: ''!
selectorParts: aCollection 
	selectorParts := aCollection! !

!RBSlotInitializationNode methodsFor: 'accessing' stamp: ''!
selectorString
	^ String streamContents: [ :s |  
			selectorParts do: [ :e | s <<e ] ]! !

!RBSlotInitializationNode class methodsFor: 'instance creation' stamp: ''!
selectorParts: selectors argumentParts: aCollection
	^ self new
		selectorParts: selectors;
		argumentParts: aCollection;
		yourself! !

!RBSlotInitializationNodeTest commentStamp: ''!
A RBSlotInitializationNodeTest is a test class for testing the behavior of RBSlotInitializationNode!
!RBSlotInitializationNodeTest methodsFor: 'tests' stamp: ''!
testPrintStringANullInitializationMessage
	| s1 |
	s1 := RBSlotInitializationNode new.
	self assert: s1 printString equals: ''! !

!RBSlotInitializationNodeTest methodsFor: 'tests' stamp: ''!
testEquality
	| s1 s2 |
	s1 := RBSlotInitializationNode selectorParts: #(#default:) argumentParts: 5.
	s2 := RBSlotInitializationNode selectorParts: #(#default:) argumentParts: 5.
	self assert: s1 equals: s2! !

!RBSlotInitializationNodeTest methodsFor: 'tests' stamp: ''!
testSlotInitializationCreation

	| s | 
	s := RBSlotInitializationNode selectorParts: #(#default:) argumentParts: #(5).
	self assert: s selectorString equals: #default:.
	self assert: s argumentParts equals: #(5)! !

!RBSlotInitializationNodeTest methodsFor: 'tests' stamp: ''!
testSelector
	| s1 |
	s1 := RBSlotInitializationNode selectorParts: #default:named: argumentParts: #(5 'titi').
	self assert: s1 selectorString equals: 'default:named:'.! !

!RBSlotInitializationNodeTest methodsFor: 'tests' stamp: ''!
testSlotMultipleInitializationCreation

	| s | 
	s := RBSlotInitializationNode selectorParts: #(default: named:) argumentParts: #(5 'titi').
	self assert: s selectorParts equals: #(default: named:).
	self assert: s selectorString equals: 'default:named:'.
	self assert: s argumentParts equals: #(5 'titi')! !

!RBSlotInitializationNodeTest methodsFor: 'tests' stamp: ''!
testPrintStringMultiple
	| s1 |
	s1 := RBSlotInitializationNode selectorParts: #(default: named:) argumentParts: #(5 'titi').
	self assert: s1 printString equals: 'default: 5 named: ''titi'''! !

!RBSlotInitializationNodeTest methodsFor: 'tests' stamp: ''!
testIsNull
	| s |
	s := RBSlotInitializationNode new.
	self assert: s selectorString equals: ''.
	self assert: s isNull! !

!RBSlotInitializationNodeTest methodsFor: 'tests' stamp: ''!
testPrintString
	| s1 |
	s1 := RBSlotInitializationNode selectorParts: #(#default:) argumentParts: #(5).
	self assert: s1 printString equals: 'default: 5'! !

!RBSmalllintChecker commentStamp: ''!
I apply a lint rule to all classes and methods in a given environment.

My main API is 

- ==run== which resets and runs the rules.!
!RBSmalllintChecker methodsFor: 'accessing' stamp: ''!
environment: aBrowserEnvironment 
	environment := aBrowserEnvironment! !

!RBSmalllintChecker methodsFor: 'private' stamp: ''!
checkClass: aClass 
	(environment includesClass: aClass) ifTrue: [rule checkClass: aClass]! !

!RBSmalllintChecker methodsFor: 'initialization' stamp: ''!
initialize
	methodBlock := [].
	environment := RBBrowserEnvironment new.
	context := RBSmalllintContext newNoCache! !

!RBSmalllintChecker methodsFor: 'accessing' stamp: ''!
methodBlock: aBlock 
	methodBlock := aBlock! !

!RBSmalllintChecker methodsFor: 'accessing' stamp: ''!
context: aSmalllintContext 
	context := aSmalllintContext! !

!RBSmalllintChecker methodsFor: 'initialization' stamp: ''!
release
	context release.
	super release! !

!RBSmalllintChecker methodsFor: 'actions' stamp: ''!
run
	environment classesAndTraits
		do: [ :class |
			self checkClass: class.
			self checkMethodsForClass: class.
			
			self checkClass: class classSide.
			self checkMethodsForClass: class classSide ]
		displayingProgress: [ :class | 'Running critics on: ', class name ].
	environment packages 
		do: [ :package | self checkPackage: package ]
		displayingProgress: [ :package | 'Running critics on: ', package name ].! !

!RBSmalllintChecker methodsFor: 'private' stamp: ''!
checkMethodsForClass: aClass
	^ environment
		selectorsForClass: aClass
		do: [ :each | 
			rule checkMethod: aClass>>each.
			methodBlock value ]! !

!RBSmalllintChecker methodsFor: 'accessing' stamp: ''!
rule: aLintRule 
	rule := aLintRule! !

!RBSmalllintChecker methodsFor: 'private' stamp: ''!
checkPackage: aRPackage
	(environment includesPackage: aRPackage) 
		ifTrue: [rule checkPackage: aRPackage]! !

!RBSmalllintChecker class methodsFor: 'instance creation' stamp: ''!
newWithContext
	^(self new)
		context: RBSmalllintContext new;
		yourself! !

!RBSmalllintChecker class methodsFor: 'instance creation' stamp: ''!
runRule: aLintRule onEnvironment: aBrowserEnvironment
	aLintRule resetResult.
	(self new)
		rule: aLintRule;
		environment: aBrowserEnvironment;
		run.
	^aLintRule! !

!RBSmalllintChecker class methodsFor: 'instance creation' stamp: ''!
runRule: aLintRule
	(self new)
		rule: aLintRule;
		run.
	^aLintRule! !

!RBSmalllintContext methodsFor: 'private' stamp: ''!
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: 'testing' stamp: ''!
includesBehaviorNamed: aClassName
	| current |
	current := self selectedClass.
	[ current isNil ] whileFalse: [
		current name = aClassName
			ifTrue: [ ^ true ].
		current := current superclass ].
	^ false! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
selectedClass
	^class! !

!RBSmalllintContext methodsFor: 'private' stamp: ''!
computeLiteralsForSelector: aSelector in: aClass

	| method |

	method := aClass compiledMethodAt: aSelector ifAbsent: [ nil ].
	method ifNil: [ ^ self ].
	self addLiteralsFor: method! !

!RBSmalllintContext methodsFor: 'private' stamp: ''!
buildParseTree

	| tree |

	tree := self selectedClass parseTreeFor: self selector.
	tree ifNil: [ ^ RBParser parseMethod: 'method' ].
	^ tree! !

!RBSmalllintContext methodsFor: 'private' stamp: ''!
computeLiteralsForClass: aClass 
	(selectors addAll: aClass selectors) do: 
			[:sel | 
			self computeLiteralsForSelector: sel in: aClass.
			Processor yield]! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
literals

	literalSemaphore
		ifNil: [ literals
				ifNil: [ self computeLiterals.
					literalSemaphore wait
					]
			]
		ifNotNil: [ literalSemaphore wait ].
	^ literals! !

!RBSmalllintContext methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	self selectedClass
		ifNotNil: [ aStream
				nextPut: $ ;
				nextPutAll: self selectedClass name.
			self selector
				ifNotNil: [ aStream
						nextPutAll: '>>';
						print: self selector
					]
			]! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
superMessages
    ^self parseTree superMessages
! !

!RBSmalllintContext methodsFor: 'testing' stamp: ''!
implements: aSelector 
	^self selectors includes: aSelector! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
messages
    ^(self parseTree sendNodes collect: [ :node | node selector ]) asSet! !

!RBSmalllintContext methodsFor: 'private' stamp: ''!
addLiteralsFor: aCompiledMethod
	2 to: aCompiledMethod numLiterals - 1
		do: [ :index | self checkLiteral: (aCompiledMethod objectAt: index) ]! !

!RBSmalllintContext methodsFor: 'private' stamp: ''!
specialSelectors
	| answer |
	answer := IdentityDictionary new.
	(Smalltalk specialSelectors select: [:sel | sel isSymbol]) do:
		[:sel | answer at: sel put: nil.].
	^answer.! !

!RBSmalllintContext methodsFor: 'testing' stamp: ''!
isAbstract: aClass 
	^(aClass isMeta or: 
			[(self literals includes: aClass name)
				or: [self literals includes: (Smalltalk globals associationAt: aClass name)]])
		not! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
parseTree

	^ parseTree ifNil: [ parseTree := self buildParseTree ] ifNotNil: [ parseTree ]! !

!RBSmalllintContext methodsFor: 'testing' stamp: ''!
uses: anObject 
	^self literals includes: anObject! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
selectors

	literalSemaphore
		ifNil: [ selectors
				ifNil: [ self computeLiterals.
					literalSemaphore wait
					]
			]
		ifNotNil: [ literalSemaphore wait ].
	^ selectors! !

!RBSmalllintContext methodsFor: 'private' stamp: ''!
checkLiteral: aLiteral 
	(aLiteral isSymbol or: [aLiteral isVariableBinding])
		ifTrue: [literals add: aLiteral]
		ifFalse: 
			[aLiteral class == Array
				ifTrue: [aLiteral do: [:each | self checkLiteral: each]]]! !

!RBSmalllintContext methodsFor: 'private' stamp: ''!
computeLiterals
	literalSemaphore := Semaphore new.
	literalProcess := [self primitiveComputeLiterals] fork! !

!RBSmalllintContext methodsFor: 'initialization' stamp: ''!
initialize
	self computeLiterals! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
selector
	^selector! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
selector: anObject 
	selector := anObject.
	parseTree := compiledMethod := nil! !

!RBSmalllintContext methodsFor: 'private' stamp: ''!
signalProcesses: aSemaphore

	aSemaphore ifNil: [ ^ self ].
	[ aSemaphore isEmpty ] whileFalse: [ aSemaphore signal ]! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
protocol
	^self selectedClass whichCategoryIncludesSelector: self selector! !

!RBSmalllintContext methodsFor: 'initialization' stamp: ''!
release
	literalProcess ifNotNil: [literalProcess terminate].
	super release! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
protocols
	^Array with: self protocol! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
selectedClass: anObject 
	class := anObject.
	self selector: nil! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
instVarNames
	^self selectedClass allInstVarNames! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
selfMessages
    ^self parseTree selfMessages
! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
compiledMethod
	^compiledMethod notNil
		ifTrue: [compiledMethod]
		ifFalse: [compiledMethod := class compiledMethodAt: selector]! !

!RBSmalllintContext methodsFor: 'accessing' stamp: ''!
sourceCode
	^self selectedClass sourceCodeAt: self selector ifAbsent: [ '' ].! !

!RBSmalllintContext class methodsFor: 'instance creation' stamp: ''!
newNoCache
	^self basicNew! !

!RBSmalllintTestAddRemoveDependentsGoodObject commentStamp: ''!
This class shouldn't trigger the RBAddRemoveDependentsRule critic.!
!RBSmalllintTestAddRemoveDependentsGoodObject methodsFor: 'removing' stamp: ''!
removeDependentSends
	self
		removeDependent: #one;
		removeDependent: #two! !

!RBSmalllintTestAddRemoveDependentsGoodObject methodsFor: 'adding' stamp: ''!
addDependentSends
	self
		addDependent: #one;
		addDependent: #two! !

!RBSmalllintTestAddRemoveDependentsObject commentStamp: ''!
This class should trigger the RBAddRemoveDependentsRule critic.!
!RBSmalllintTestAddRemoveDependentsObject methodsFor: 'removing' stamp: ''!
removeDependentSends
	self removeDependent: #one! !

!RBSmalllintTestAddRemoveDependentsObject methodsFor: 'adding' stamp: ''!
addDependentSends
	self
		addDependent: #one;
		addDependent: #two! !

!RBSmalllintTestClassNotReferencedObject commentStamp: ''!
This class should trigger the RBClassNotReferencedRule critic. All other classes in this hierarchy must be referenced somewhere. After adding a class to the hierarchy, evaluate the following to ensure it has at least one explicit reference:
	RBSmalllintTestSuperclassObject updateDefaultExplicitClassReferences.!
!RBSmalllintTestClassNotReferencedObject class methodsFor: 'testing' stamp: ''!
mustNotBeReferenced
	^ true! !

!RBSmalllintTestDefinesEqualNotHashGoodObject commentStamp: ''!
This class shouldn't trigger the RBDefinesEqualNotHashRule critic.!
!RBSmalllintTestDefinesEqualNotHashGoodObject methodsFor: 'comparing' stamp: ''!
= anObject
	^ self == anObject
		or: [self species == anObject species]! !

!RBSmalllintTestDefinesEqualNotHashGoodObject methodsFor: 'comparing' stamp: ''!
hash
	^ self species identityHash! !

!RBSmalllintTestDefinesEqualNotHashObject commentStamp: ''!
This class should trigger the RBDefinesEqualNotHashRule critic.!
!RBSmalllintTestDefinesEqualNotHashObject methodsFor: 'comparing' stamp: ''!
= anObject
	^ self == anObject
		or: [self species == anObject species]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject commentStamp: ''!
This class should trigger the RBLocalMethodsSameThanTraitRule!
!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock

	^[aBlock value.
 	false] 
		on: anException
		do: [:exception | 
			anotherBlock value: exception.
			exception return: true]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anException withExceptionDo: anotherBlock 

	^self assert: (self executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock)! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
assert: aBooleanOrBlock description: aStringOrBlock resumable: resumableBoolean 
	| exception |
	aBooleanOrBlock value
		ifFalse: 
			[|aString|
			aString := aStringOrBlock value.
			exception := resumableBoolean
						ifTrue: [self classForTestResult resumableFailure]
						ifFalse: [self classForTestResult failure].
			exception signal: aString]
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
deny: actual equals: expected
	^ self
		deny: expected = actual
		description: [self unexpectedEqualityStringBetween: actual and: expected]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
skipUnless: aBooleanOrBlock
	" If the assumption in aBooleanOrBlock is not true, abandon the running test
	and mark it as passed. "
	aBooleanOrBlock value ifFalse:
			[ TestSkipped signal: 'Assumption in #skipUnless: failed' ]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
assert: actualNumber closeTo: expectedNumber
	^ self
		assert: (actualNumber closeTo: expectedNumber)
		description: [self comparingStringBetween: actualNumber and: expectedNumber]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
assert: aBooleanOrBlock description: aStringOrBlock
	aBooleanOrBlock value ifFalse: [
		| message |
		message := aStringOrBlock value.
		self classForTestResult failure signal: message]
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
assert: actual identicalTo: expected
	^ self
		assert: expected == actual
		description: [self comparingIdentityStringBetween: actual and: expected]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anExceptionalEvent 
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: true]
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
fail: aDescriptionString

	^self assert: false description: aDescriptionString! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
signalFailure: aString
	self classForTestResult failure signal: aString! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
assertCollection: actual equals: expected
	"Specialized test method that generates a proper error message for collection"
	^ self
		assert: expected = actual
		description: [ self comparingCollectionBetween: actual and: expected ]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
deny: aBooleanOrBlock

	self assert: aBooleanOrBlock value not
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
shouldFix: aBlock 
	"Run the block expecting an Exception. Throw an assertion failure if the block does NOT throw an exception."
	^self should: aBlock raise: Exception! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'private' stamp: ''!
unexpectedEqualityStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: 'Unexpected equality of ';
				nextPutAll: actual fullPrintString;
				nextPutAll: ' and ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
assert: actual equals: expected
	^ self
		assert: actual = expected
		description: [self comparingStringBetween: actual and: expected]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
skip
	"Don't run this test, and don't mark it as failure"
	TestSkipped signal! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'private' stamp: ''!
unexpectedIdentityEqualityStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: 'Unexpected identity equality of ';
				nextPutAll: actual fullPrintString;
				nextPutAll: ' and ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
denyCollection: actual equals: expected
	"Specialized test method that generates a proper error message for collection"
	^ self
		deny: expected = actual
		description: [ self unexpectedEqualityStringBetween: actual and: expected ]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock
	self deny: aBlock value
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: substring description: aString 
	 
	^self
		assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: substring) not
		description: aString
! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent description: aString  
 
	^self
		assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not
		description: aString
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
deny: aBooleanOrBlock description: aString resumable: resumableBoolean 
	self
		assert: aBooleanOrBlock value not
		description: aString
		resumable: resumableBoolean
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
deny: actual identicalTo: expected
	^ self
		deny: expected == actual
		description: [self unexpectedIdentityEqualityStringBetween: actual and: expected]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
should: aBlock notTakeMoreThan: aDuration
    "Evaluate aBlock and if it takes more than given duration
    to run we report a test failure. "

	^ aBlock valueWithin: aDuration onTimeout: [
		self 
			assert: false 
			description: ['Block evaluation took more than the expected <1p>' expandMacrosWith: aDuration]
	]
	
! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent  
	 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: substring description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: substring)
		description: aString
! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
assertCollection: actual hasSameElements: expected
	"Assert that a collection contains the same elements as the given collection. Order is not checked, only the presence/absence of elements."
	| missingElements additionalElements |
	
	additionalElements := actual difference: expected.
	missingElements := expected difference: (actual intersection: expected).
	self 
		assert: (additionalElements isEmpty and: [ missingElements isEmpty ])
		description: (String streamContents: 
			[:stream |
			stream
				nextPutAll: 'Given Collections do not match!!'; lf;
				tab; nextPutAll: 'additions : '; print: additionalElements asArray; lf;
				tab; nextPutAll: 'missing: '; print: missingElements asArray; lf ])! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
denyEmpty: aCollection
	^ self assert: aCollection isNotEmpty description: aCollection asString , ' should not have been empty'! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'private' stamp: ''!
comparingStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: 'Got ';
				nextPutAll: actual fullPrintString;
				nextPutAll: ' instead of ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: substring description: aString  
	 
	^self 
		assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: substring) not
		description: aString
! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: substring description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: substring)
		description: aString
! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
deny: aBooleanOrBlock description: aString
	self assert: aBooleanOrBlock value not description: aString
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'private' stamp: ''!
comparingIdentityStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: actual fullPrintString;
				nextPutAll: ' is not identical to ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
should: aBlock description: aString
	self assert: aBlock value description: aString
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: (ex description includesSubstring: aString) not ]
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'extensions' stamp: ''!
skip: aComment
	"Don't run this test, and don't mark it as failure"
	TestSkipped signal: aComment! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock description: aString
	self deny: aBlock value description: aString
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
should: aBlock
	self assert: aBlock value
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
should: aBlock notTakeMoreThanMilliseconds: anInteger
    "For compatibility with other Smalltalks"

   self should: aBlock notTakeMoreThan: (Duration milliSeconds: anInteger).! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
fail

	^self assert: false! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: (ex description includesSubstring: aString) ]
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)
		description: aString
			! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'private' stamp: ''!
comparingCollectionBetween: left and: right
	| additionalLeft additionalRight sortBlock|
	
	"use a very slow sort block"
	sortBlock := [ :a :b | a asString <= b asString ].
	additionalLeft := (left difference: right) sorted: sortBlock.
	additionalRight := (right difference: left) sorted: sortBlock. 
	
	^ String streamContents: [:stream |
		stream
			nextPutAll: 'Given Collections do not match. Got '; lf;
			tab; nextPutAll: 'left := '; print: left; nextPut: $.; lf;
			nextPutAll: ' instead of ';
			tab; nextPutAll: ' right :='; print: left; nextPut: $.; lf.
		left size = right size
			ifFalse: [ 
				stream 
					nextPutAll: 'Collection size does not match: left='; 
					print: left size;
					nextPutAll: ' vs. right=';
					print: right size; lf ].
		additionalLeft isEmpty
			ifFalse: [ 
				stream 
					nextPutAll: 'Got ';
					print: additionalLeft size;
					nextPutAll: ' additional element(s) in the left collection: ';
					tab; print: additionalLeft  ].
		additionalRight isEmpty
			ifFalse: [ 
				stream 
					nextPutAll: 'Got ';
					print: additionalRight size;
					nextPutAll: ' additional element(s) in the right collection: ';
					tab; print: additionalRight  ]]! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
classForTestResult
	"Returns the class of the test result"
	^ TestResult! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
assertEmpty: aCollection
	^ self assert: aCollection isEmpty description: aCollection asString , ' should have been empty'! !

!RBSmalllintTestLocalMethodsSameThanTraitObject methodsFor: 'asserting' stamp: ''!
denyCollection: actual hasSameElements: expected
	"Deny that a collection contains the same elements as the given collection. Order is not checked, only the presence/absence of elements."

	self
		deny: ((actual difference: expected) isEmpty and: [ (expected difference: actual) isEmpty ])
		description: 'Given collections match!!'! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RBSmalllintTestLocalMethodsSameThanTraitObject class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RBSmalllintTestObject commentStamp: ''!
This class is used to test method critics.!
!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
returnsBooleanAndOther
	self isVariable ifTrue: [^false].
	self printString! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
transcriptMentioned
	Transcript show: 'message'! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
atIfAbsent
	^ Smalltalk at: #MyTest
		ifAbsent: 
			[| collection |
			collection := #().
			Smalltalk at: #MyTest put: collection]! !

!RBSmalllintTestObject methodsFor: 'accessing - good' stamp: ''!
nonUnaryAccessingBranchingStatementMethodWithoutReturn: anObject
	"shouldn't trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	self value isString
		ifTrue: [ self value ]
		ifFalse: [ '' ]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
assignmentInBlock
	[^self printString] ensure: [self close]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
multiplePeriodsTerminatingAssignmentStatement
	| strings |

	strings := OrderedCollection..
	strings
		add: 'one';
		add: 'two'.
	^ strings.
	! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
uncommonMessageSend
	true false! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
fileBlocks
	| file |
	^
	[file := 'asdf' asFileReference readStream.
	file contents] ensure: [file close]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
consistencyCheck
	^(1 to: 10) size > 0! !

!RBSmalllintTestObject methodsFor: 'as yet unclassified' stamp: ''!
unclassifiedMethods
	"intentionally unclassified method"! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
usesAdd
	^(1 to: 10) asOrderedCollection addAll: (11 to: 20)! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
tempsReadBeforeWritten
	| temp |
	self isVariable ifTrue: [temp := 4].
	^temp! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
asOrderedCollectionNotNeeded
	self foo addAll: (1 to: 10) asOrderedCollection! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
refersToClass
	^ RBSmalllintTestObject! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
stringConcatenation
	| string |
	string := '' yourself.
	(1 to: 10) do: [:i | string := string , i printString].
	^string! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
justSendsSuper
	super justSendsSuper! !

!RBSmalllintTestObject methodsFor: 'accessing - good' stamp: ''!
unaryAccessingMessageStatementMethodWithReturn
	"shouldn't trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	^ self value! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
anySatisfy
	^((1 to: 10) detect: [:each | each > 2] ifNone: [nil]) isNil! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
endTrueFalse
	self isVariable 
		ifTrue: 
			[self printString.
			self isVariable printString]
		ifFalse: 
			[self printString.
			^4]! !

!RBSmalllintTestObject methodsFor: 'accessing - bad' stamp: ''!
unaryAccessingMessageStatementMethodWithoutReturn
	"should trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	self value! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
literalArrayCharacters
	^#($a $b $c) includes: $a! !

!RBSmalllintTestObject methodsFor: 'accessing - good' stamp: ''!
unaryAccessingMethodWithReturn
	"shouldn't trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	^ self! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
literalArrayContainsComma
	^ #(#,)! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
collectionAtCollectionSize
	^self at: self size! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
emptyExceptionHandler
	[ ] on: Error do: [ :err | ]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
unoptimizedAndOr
	^ (true and: [ false ]) and: [ true ]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
usesTrue
	^ True! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
floatEqualityComparison
	^ 1.0 = 1! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
shouldntRaiseError
	self shouldnt: [ 0/1 ] raise: Error! !

!RBSmalllintTestObject methodsFor: 'non-accessing' stamp: ''!
unaryNonAccessingMethodWithoutReturn
	"shouldn't trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
returnsIfTrue
	^self isNil ifTrue: [4]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
modifiesCollection
	| collection |
	collection := (1 to: 10) asOrderedCollection.
	collection do: [:each | each > 5 ifTrue: [collection remove: each]].
	^collection! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
longMethods
	self printString.
	self printString.
	self printString.
	self printString.
	self printString.
	self printString.
	self printString.
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString].
	self isVariable ifTrue: [self printString]! !

!RBSmalllintTestObject methodsFor: 'accessing - bad' stamp: ''!
unaryAccessingMethodWithoutReturn
	"should trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
collectionProtocol
	| newCollection |
	newCollection := OrderedCollection new.
	(1 to: 10) asOrderedCollection do: 
			[:each | 
			| new |
			new := each * 2.
			newCollection add: new].
	^newCollection! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
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: 'non-accessing' stamp: ''!
unaryNonAccessingBranchingStatementMethodWithoutReturn
	"shouldn't trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	self value isString
		ifTrue: [ self value ]
		ifFalse: [ '' ]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
threeElementPoint
	^5 @ 5 + 6 @ 6! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
noMoveDefinition
	| temp |
	^(self collect: 
			[:each | 
			temp := each printString.
			temp , temp]) 
		select: [:each | temp := each size + temp]! !

!RBSmalllintTestObject methodsFor: 'accessing - good' stamp: ''!
nonUnaryAccessingMethodWithoutReturn: anObject
	"shouldn't trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
guardingClause
	self isSymbol 
		ifFalse: 
			[self printString.
			self isSymbol printString]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
toDoCollect
	| array |
	array := Array new: 10.
	1 to: 10 do: [:i | array at: i put: i * i].
	^array! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
ifTrueReturns
	self isSymbol ifFalse: [^true].
	^false! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
multiplePeriodsTerminatingStatement
	^ self..! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
precedence
	^self isArray ifFalse: [self block + 5 * 34] ifTrue: [self printString = 10]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
returnInEnsure
	[self error: 'asdf'] ensure: [^4]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
toDoWithIncrement
	| counter |
	counter := 0.
	1 to: 10
		by: 2
		do: [:i | counter := counter + 2].
	^counter! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
toDo
	1 to: self size do: [:i | (self at: i) printString]! !

!RBSmalllintTestObject methodsFor: 'accessing - good' stamp: ''!
unaryAccessingBranchingStatementMethodWithReturn
	"shouldn't trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	^ self value isString
		ifTrue: [ self value ]
		ifFalse: [ '' ]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
tempVarOverridesInstVar
	| temporaryVariable |
	temporaryVariable := 4.
	^temporaryVariable! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
booleanPrecedence
	^true & 4 = 45! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
whileTrue
	| i |
	i := 1.
	[i < self size] whileTrue: 
			[(self at: i) printString.
			i := i + 1]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
equalsTrue
	^true == self! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
referencesConditionFor: aClass 
	| environment association |
	^(RBCondition withBlock: 
			[association := Smalltalk globals 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.<n>Browse references?';
		errorBlock: [environment openEditor];
		yourself! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
badMessage
	self become: String new! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
haltClassMentioned
	<haltOrBreakpointForTesting>
	Halt now! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
sendsDifferentSuper
	super printString! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
sizeCheck
	self isEmpty
		ifFalse: [self do: 
					[:each | 
					]]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
inlineTemporary
	| temp |
	self isNil ifTrue: [temp := 4].
	^temp! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
uncommonMessageSend2
	|a|
	a:=3
	Object new.
	^ a! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
detectContains
	^(1 to: 10) do: [:each | each > 2 ifTrue: [^each]]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
variableAssignedLiteral
	temporaryVariable := #() ! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
codeCruftLeftInMethods
	<haltOrBreakpointForTesting>
	| a b c |
	a := b := c := 2.
	self halt.
	^ a > 0
		ifTrue: [ b ]
		ifFalse: [ c ]
		! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
flagged
	self flag: #pharoTodo! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
fullBlocks
	^[thisContext]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
assignmentInIfTrue
	| variable |
	self isVariable 
		ifTrue: [variable := self]
		ifFalse: [variable := self printString].
	^variable! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
missingYourself
	^(OrderedCollection new)
		add: 1;
		add: 2;
		removeFirst! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
onlyReadOrWrittenTemporary
	| a |
	a := 1! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
searchingLiteral
	^self printString = #a or: [#() = self printString | ( #() == self printString)]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
testMethod1
	^self testMethod1 
		, ([:each | each testMethod1] value: #(#(#testMethod1) 2 #testMethod1))! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
assignmentWithoutEffect
	| a |
	a := 1.
	a := a! !

!RBSmalllintTestObject methodsFor: 'non-accessing' stamp: ''!
unaryNonAccessingMessageStatementMethodWithoutReturn
	"shouldn't trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	self value! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
yourselfNotUsed
	self
		printString;
		printString;
		yourself! !

!RBSmalllintTestObject methodsFor: 'accessing - good' stamp: ''!
abstractUnaryAccessingMethodWithoutReturn
	"shouldn't trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	self subclassResponsibility! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
equalNotUsed
	| string |
	string = '' yourself.
	(1 to: 10) do: [:i | string := i printString].
	^string! !

!RBSmalllintTestObject methodsFor: 'accessing - bad' stamp: ''!
literalArrayContainsSuspiciousTrueFalseOrNil
	^#(#nil)! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
debbuggingMessageSent
	self rearmOneShot! !

!RBSmalllintTestObject methodsFor: 'accessing - good' stamp: ''!
nonUnaryAccessingMessageStatementMethodWithoutReturn: anObject
	"shouldn't trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	self value! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
equivalentSuperclassMethods
	"comments and formatting are ignored when comparing methods"
	^ (
		self
		identityHash
		).! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
extraBlock
	^[:arg | arg + 43] value: 45! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
ifTrueBlocks
	^ true ifFalse: self foo! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
collectionMessagesToExternalObject
	self someObject collection remove: 10! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
collectSelectNotUsed
	(1 to: 10) select: [:each | each = 4]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
release
	self printString! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
temporaryVariableCapitalization
	| Capital |
	Capital := 'Bern'.
	^ Capital! !

!RBSmalllintTestObject methodsFor: 'accessing - bad' stamp: ''!
unaryAccessingBranchingStatementMethodWithoutReturn
	"should trigger the ReUnaryAccessingMethodWithoutReturnRule rule"

	self value isString
		ifTrue: [ self value ]
		ifFalse: [ '' ]! !

!RBSmalllintTestObject methodsFor: 'methods' stamp: ''!
shouldntRaiseException
	self shouldnt: [ 0/1 ] raise: Exception! !

!RBSmalllintTestSuperclassObject commentStamp: ''!
A superclass for classes used to test critics.!
!RBSmalllintTestSuperclassObject methodsFor: 'methods' stamp: ''!
equivalentSuperclassMethods
	^ self identityHash! !

!RBSmalllintTestSuperclassObject class methodsFor: 'compiling' stamp: ''!
updateDefaultExplicitClassReferences
	"Run after adding a new subclass to the hierachy:
		self updateDefaultExplicitClassReferences
	"

	"avoid self so it's always compiled in the metaclass of the
	of the root even when sent to a subclass"
	RBSmalllintTestSuperclassObject class
		compile:
			'defaultExplicitClassReferences
	"generated by #updateDefaultExplicitClassReferences"
	^ ',
			(RBSmalllintTestSuperclassObject withAllSubclasses asArray
				reject: [ :each | each mustNotBeReferenced ]) printString
		classified: #accessing! !

!RBSmalllintTestSuperclassObject class methodsFor: 'testing' stamp: ''!
mustNotBeReferenced
	^ false! !

!RBSmalllintTestSuperclassObject class methodsFor: 'accessing' stamp: ''!
defaultExplicitClassReferences
	"generated by #updateDefaultExplicitClassReferences"
	^ {RBSmalllintTestObject. RBSmalllintTestNoClassCommentObject. RBSmalllintTestAddRemoveDependentsObject. RBSmalllintTestAddRemoveDependentsGoodObject. RBSmalllintTestDefinesEqualNotHashObject. RBSmalllintTestDefinesEqualNotHashGoodObject. RBSmalllintTestSuperclassObject. RBSmalllintTestLocalMethodsSameThanTraitObject}! !

!RBSourceRegexRefactoring commentStamp: ''!
I am a regex refactoring replacing method sources.

See comment of superclass for a nice script to be adapated to method sources.!
!RBSourceRegexRefactoring methodsFor: 'transforming' stamp: ''!
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 )
								ifNotNil: [ protocols := class protocolsFor: selector.
									( self parseSelector: replacement ) = selector
										ifFalse: [ class removeMethod: selector ].
									class compile: replacement classified: protocols
									]
							]
					]
			]! !

!RBSourceRegexRefactoring methodsFor: 'private' stamp: ''!
parseSelector: aSelector
	^ [ self parserClass parseMethodPattern: aSelector ]
		on: Error
		do: [ nil ]! !

!RBSourceRegexRefactoring methodsFor: 'private' stamp: ''!
parseMethod: aString
	^ [ self parserClass parseMethod: aString ]
		on: Error
		do: [ :err | nil ]! !

!RBSpecialCharacterToken commentStamp: ''!
RBSpecialCharacterToken is the first-class representation of special characters.

!
!RBSpecialCharacterToken methodsFor: 'testing' stamp: ''!
isSpecial
	^true! !

!RBSpecialCharacterToken methodsFor: 'private' stamp: ''!
length
	^1! !

!RBSplitCascadeParametrizedTest methodsFor: 'tests' stamp: ''!
testSplitCascadeRefactoring
	| refactoring |
	refactoring := self createRefactoringWithArguments:
		{ (54 to: 55) . #methodWithCascades . self class }.
	
	self executeRefactoring: refactoring.

	self assert: ((refactoring model classNamed: #RBSplitCascadeParametrizedTest) parseTreeFor: #methodWithCascades) equals: (self parseMethod: 'methodWithCascades
	| a receiver |
	receiver := Object new.
	receiver initialize.
	a := receiver asString.
	^ a')! !

!RBSplitCascadeParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantSelectorName
	self shouldFail: (self createRefactoringWithArguments:
		{ (54 to: 55) . #foo . self class })! !

!RBSplitCascadeParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #split:from:in:! !

!RBSplitCascadeParametrizedTest methodsFor: 'failure tests' stamp: ''!
testMethodWithoutCascade
	self shouldFail: (self createRefactoringWithArguments: 
		{ (54 to: 55) . ('an', 'InstVar:') asSymbol . RBBasicLintRuleTestData })! !

!RBSplitCascadeParametrizedTest methodsFor: 'data' stamp: ''!
methodWithCascades
	| a |
	a := Object new initialize; asString.
	^ a! !

!RBSplitCascadeParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBSplitCascadeRefactoring };
		yourself! !

!RBSplitCascadeRefactoring commentStamp: ''!
I am a refactoring splitting a cascade message send to multiple messages.

You can select an interval containing a cascade expression. The refactoring will split this expression to two message sends to the receiver. 

My preconditions verify that the selector containing the cascaded message send is defined in this class, and a cascade message can be found.

If the receiver of the cascade expression is a literal or the return value of another message send, I will add another temporary variable for the interim result.!
!RBSplitCascadeRefactoring methodsFor: 'initialization' stamp: ''!
split: anInterval from: aSelector in: aClass
	class := self classObjectFor: aClass.
	selector := aSelector.
	selectedInterval := anInterval! !

!RBSplitCascadeRefactoring methodsFor: 'preconditions' stamp: ''!
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 keywordsPositions first].
	(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' stamp: ''!
findCascadeNode

	"Find the cascade to be split."

	cascadeNode := self parseTree bestNodeFor: selectedInterval.
	[ cascadeNode isNil or: [ cascadeNode isCascade ] ]
		whileFalse: [ cascadeNode := cascadeNode parent ].
	cascadeNode
		ifNil: [ self refactoringFailure: 'The selection doesn''t appear to be within a cascade' ]! !

!RBSplitCascadeRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self extractReceiver.
	self splitCascade! !

!RBSplitCascadeRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [ 
		self findCascadeNode; findAncestorNode; findMessageNodes. 
		true ])! !

!RBSplitCascadeRefactoring methodsFor: 'transforming' stamp: ''!
extractReceiver
	| name |
	(cascadeNode receiver isLiteralNode or: [ cascadeNode receiver isVariable ])
		ifTrue: [ ^ self ].
	name := self 
		safeVariableNameFor: class 
		temporaries: self parseTree allDefinedVariables 
		basedOn: 'receiver'.
	ancestorNode parent
		addTemporaryNamed: name;
		addNode: (RBAssignmentNode 
			variable: (RBVariableNode named: name)
			value: cascadeNode receiver)
		before: ancestorNode.
	cascadeNode messages
		do: [ :each | each receiver: (RBVariableNode named: name) ]
		! !

!RBSplitCascadeRefactoring methodsFor: 'transforming' stamp: ''!
splitCascade
	ancestorNode parent
		addNode: (beforeNodes size > 1
			ifTrue: [ RBCascadeNode messages: beforeNodes ]
			ifFalse: [ beforeNodes first ])
		before: ancestorNode.
	afterNodes size > 1
		ifTrue: [ cascadeNode messages: afterNodes ]
		ifFalse: [ cascadeNode replaceWith: afterNodes first ].
	class compileTree: ancestorNode methodNode! !

!RBSplitCascadeRefactoring methodsFor: 'preconditions' stamp: ''!
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: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' split: '.
	selectedInterval storeOn: aStream.
	aStream
		nextPutAll: ' inMethod: #';
		nextPutAll: selector;
		nextPutAll: ' forClass: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBSplitCascadeRefactoring methodsFor: 'accessing' stamp: ''!
parseTree

	parseTree
		ifNil: [ parseTree := class parseTreeFor: selector.
			parseTree ifNil: [ self refactoringFailure: 'Could not parse sources' ]
			].
	^ parseTree! !

!RBSplitCascadeRefactoring class methodsFor: 'instance creation' stamp: ''!
split: anInterval from: aSelector in: aClass
	^ self new 
		split: anInterval from: aSelector in: aClass;
		yourself! !

!RBSplitCascadeRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aNamespace split: anInterval from: aSelector in: aClass
	^ self new
		model: aNamespace;
		split: anInterval from: aSelector in: aClass;
		yourself! !

!RBSplitClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInvalidInstanceVariableName
	self shouldFail: 
		(self createRefactoringWithArguments: 
			{ #RBBasicLintRuleTestData . #(#inexistentVar #classBlock) . #Object . #blocks })! !

!RBSplitClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInvalidNewClassName
	self shouldFail: 
		(self createRefactoringWithArguments:  
			{ #RBBasicLintRuleTestData . #(#methodBlock #classBlock) . #Object . #blocks })! !

!RBSplitClassParametrizedTest methodsFor: 'tests' stamp: ''!
testSplitClass
	|ref aModel|
	ref := self createRefactoringWithArguments:  
		{ #RBBasicLintRuleTestData . #(#methodBlock #classBlock) . #BlockClass . #blocks }.
	aModel := ref model.
	self executeRefactoring: ref.
	
	self assertCollection: (aModel classNamed: #RBBasicLintRuleTestData) instanceVariableNames 			hasSameElements: #(#result #blocks #anInstVar).
	self assertCollection: (aModel classNamed: #BlockClass) instanceVariableNames 
			hasSameElements: #(#methodBlock #classBlock).
			
	self assert: ((aModel classNamed: #RBBasicLintRuleTestData) parseTreeFor: #checkClass:) 
				equals: (self parseMethod: 'checkClass: aSmalllintContext 
	^blocks classBlock value: aSmalllintContext value: result').
	self assert: ((aModel classNamed: #RBBasicLintRuleTestData) parseTreeFor: #checkMethod:) 
				equals: (self parseMethod: 'checkMethod: aSmalllintContext 
	^blocks methodBlock value: aSmalllintContext value: result')! !

!RBSplitClassParametrizedTest methodsFor: 'failure tests' stamp: ''!
testInvalidReferenceVariableName
	self shouldFail: 
		(self createRefactoringWithArguments:  
			{ #RBLintRuleTestData . #(#name #foo1) . #ClassA . #result }).
	self shouldFail: 
		(self createRefactoringWithArguments:  
			{ #RBLintRuleTestData . #(#name #foo1) . #ClassA . #temp }).! !

!RBSplitClassParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #class:instanceVariables:newClassName:referenceVariableName:! !

!RBSplitClassParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBSplitClassRefactoring };
	"	addCase: { #rbClass -> RBSplitClassTransformation };
		"yourself! !

!RBSplitClassRefactoring commentStamp: ''!
I am a refactoring for extracting a set of instance variables to a new class.

You can choose which instance variables should be moved into the new class. The new class becomes an instvar of the original class and every reference to the moved variables is replaced by a accessor call.

My precondition verifies that the new instance variable is a valid variable name and not yet used in this class or its hierarchy
 the name of the new class representing the set of instance variables is a valid class name

Example:
In the following class:

```
Object subclass: #TextKlass
	instanceVariableNames: 'text color font style'
	classVariableNames: ''
	package: 'TestKlasses'
```	
the variables color/font/style should be moved to a new "TextAttributes"-Class.
We apply the Split Refactoring with this three variables and select a new class name TextAttributes used as variable new "textAttributes".
The class definition will be changed to

```
Object subclass: #TextKlass
	instanceVariableNames: 'text textAttributes'
	classVariableNames: ''
	package: 'TestKlasses'
```
	
and every reference to the old vars color / font / style will be replaced by textAttributes color / textAttributes style / textAttributesFont
!
!RBSplitClassRefactoring methodsFor: 'transforming' stamp: ''!
transform
	self
		createNewClass;
		createReference;
		abstractVariableReferences! !

!RBSplitClassRefactoring methodsFor: 'initialization' stamp: ''!
class: aClass instanceVariables: instVars newClassName: className referenceVariableName: newVariable 
	class := self model classObjectFor: aClass.
	instanceVariables := instVars.
	newClassName := className.
	referenceVariableName := newVariable! !

!RBSplitClassRefactoring methodsFor: 'private - transforming' stamp: ''!
abstractReferenceTo: each 
	| setterMethod replacer accessorRef getterMethod |
	accessorRef := RBCreateAccessorsForVariableRefactoring 
				variable: each
				class: newClass
				classVariable: false.
	self performCompositeRefactoring: accessorRef.
	getterMethod := accessorRef getterMethod.
	setterMethod := accessorRef setterMethod.
	replacer := self parseTreeRewriterClass 
				variable: each
				getter: getterMethod
				setter: setterMethod
				receiver: referenceVariableName.
	self 
		convertClasses: class withAllSubclasses
		select: [:aClass | aClass whichSelectorsReferToInstanceVariable: each]
		using: replacer.
	self performCompositeRefactoring: (RBRemoveInstanceVariableRefactoring 
				remove: each
				from: class)! !

!RBSplitClassRefactoring methodsFor: 'transforming' stamp: ''!
abstractVariableReferences
	instanceVariables do: [:each | self abstractReferenceTo: each]! !

!RBSplitClassRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition isValidClassName: newClassName) 
		& (RBCondition isGlobal: newClassName in: self model) not 
			& (RBCondition isValidInstanceVariableName: referenceVariableName for: class) 
			& (RBCondition hierarchyOf: class definesVariable: referenceVariableName) 
					not 
			& (RBCondition isGlobal: referenceVariableName in: self model) not 
			& (RBCondition definesTemporaryVariable: referenceVariableName in: class) 
					not! !

!RBSplitClassRefactoring methodsFor: 'transforming' stamp: ''!
createNewClass
	self
		addClass;
		addInstanceVariables! !

!RBSplitClassRefactoring methodsFor: 'private - transforming' stamp: ''!
addClass
	self performCompositeRefactoring: (RBAddClassRefactoring 
				model: self model
				addClass: newClassName
				superclass: Object
				subclasses: #()
				category: class category).
	newClass := self model classNamed: newClassName asSymbol! !

!RBSplitClassRefactoring methodsFor: 'transforming' stamp: ''!
createReference
	self performCompositeRefactoring: (RBAddInstanceVariableRefactoring 
				variable: referenceVariableName
				class: class)! !

!RBSplitClassRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream nextPutAll: ' instanceVariables: '.
	instanceVariables asArray storeOn: aStream.
	aStream
		nextPutAll: ' newClassName: #';
		nextPutAll: newClassName;
		nextPutAll: ' referenceVariableName: ''';
		nextPutAll: referenceVariableName;
		nextPutAll: ''')'! !

!RBSplitClassRefactoring methodsFor: 'private - transforming' stamp: ''!
addInstanceVariables
	instanceVariables do: 
			[:each | 
			self performCompositeRefactoring: (RBAddInstanceVariableRefactoring 
						model: self model
						variable: each
						class: newClass)]! !

!RBSplitClassRefactoring class methodsFor: 'instance creation' stamp: ''!
class: class instanceVariables: instVars newClassName: className referenceVariableName: newVariable 
	^ self new
		class: class
			instanceVariables: instVars
			newClassName: className
			referenceVariableName: newVariable;
		yourself! !

!RBSplitClassRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk class: class instanceVariables: instVars newClassName: className referenceVariableName: newVariable 
	^ self new 
		model: aRBSmalltalk;
		class: class
			instanceVariables: instVars
			newClassName: className
			referenceVariableName: newVariable;
		yourself! !

!RBSplitClassTransformation commentStamp: ''!
Creates another class with a subset of instance variables from an existing class. References to instance variables in the original class will be replaced by invocations to getters and setters on the new class.

Usage:
transformation := (RBSplitClassTransformation
	class: #RBRemoveDirectAccessToVariableTransformation
	instanceVariables: #(receiver)
	newClassName: #RBRemoveAccessWithReceiverTransformation
	referenceVariableName: #newReceiver)
	transform.
(ChangesBrowser changes: transformation model changes changes) open

In this example,
the class "RBRemoveAccessWithReceiverTransformation" will be created with the variable "receiver". The variable "receiver" will be removed from the original class "RBRemoveDirectAccessToVariableTransformation". All references to "receiver" in this class and its subclasses will be replaced by: "newReceiver receiver ..." or "newReceiver receiver: ..."

Preconditions::
-  the instance variable exists!
!RBSplitClassTransformation methodsFor: 'api' stamp: ''!
class: aClass instanceVariables: instVars newClassName: className referenceVariableName: newVariable
 
	class := self model classObjectFor: aClass.
	instanceVariables := instVars.
	newClassName := className.
	referenceVariableName := newVariable! !

!RBSplitClassTransformation methodsFor: 'private' stamp: ''!
abstractReferenceTo: instVar

	transformations add:
		(RBAddVariableAccessorTransformation
			model: self model 
			instanceVariable: instVar
			class: newClassName).
	
	transformations add: ((
		RBRemoveDirectAccessToVariableTransformation
			model: self model 
			instanceVariable: instVar
			class: class)
			receiver: referenceVariableName).
		
	transformations add: (
		RBRemoveVariableTransformation
			model: self model 
			instanceVariable: instVar
			class: class)! !

!RBSplitClassTransformation methodsFor: 'private' stamp: ''!
abstractVariableReferences

	instanceVariables do: [ :instVar | self abstractReferenceTo: instVar ]! !

!RBSplitClassTransformation methodsFor: 'private' stamp: ''!
definingClass

	^ self model classObjectFor: class ! !

!RBSplitClassTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	class := self definingClass.

	"check whether instVar exist"
	^(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! !

!RBSplitClassTransformation methodsFor: 'private' stamp: ''!
createNewClass

	self
		addClass;
		addInstanceVariables! !

!RBSplitClassTransformation methodsFor: 'private' stamp: ''!
addClass

	transformations add: 
		(RBAddClassTransformation 
			model: self model 
			addClass: newClassName 
			superclass: #Object
			subclasses: #()
			category: class category)! !

!RBSplitClassTransformation methodsFor: 'private' stamp: ''!
createReference

	transformations add: (
		RBAddVariableTransformation 
			model: self model 
			instanceVariable: referenceVariableName
			class: class)! !

!RBSplitClassTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream nextPutAll: ' instanceVariables: '.
	instanceVariables asArray storeOn: aStream.
	aStream
		nextPutAll: ' newClassName: #';
		nextPutAll: newClassName;
		nextPutAll: ' referenceVariableName: ''';
		nextPutAll: referenceVariableName;
		nextPutAll: ''')'! !

!RBSplitClassTransformation methodsFor: 'private' stamp: ''!
addInstanceVariables

	instanceVariables
		collect: [ :instVar |
			RBAddVariableTransformation
				model: self model 
				instanceVariable: instVar
				class: newClassName ]
		thenDo: [ :each | transformations add: each ]! !

!RBSplitClassTransformation methodsFor: 'executing' stamp: ''!
buildTransformations

	transformations := OrderedCollection new.
	
	self
		createNewClass;
		createReference;
		abstractVariableReferences.
		
	^ transformations
		! !

!RBSplitClassTransformation class methodsFor: 'api' stamp: ''!
class: aClass instanceVariables: instVars newClassName: className referenceVariableName: newVariable
 
	^ self new
		class: aClass
		instanceVariables: instVars
		newClassName: className
		referenceVariableName: newVariable! !

!RBSplitClassTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel class: aClass instanceVariables: instVars newClassName: className referenceVariableName: newVariable
 
	^ self new
		model: aRBModel;
		class: aClass
		instanceVariables: instVars
		newClassName: className
		referenceVariableName: newVariable! !

!RBSplitClassTransformationTest methodsFor: 'tests' stamp: ''!
testNonExistantName

	self shouldFail: (RBSplitClassTransformation
							class: #RBDummyLintRuleTest 
							instanceVariables: #(name1)
							newClassName: #RBDummyLintRuleTest123
							referenceVariableName: #newName)
							asRefactoring! !

!RBSplitClassTransformationTest methodsFor: 'tests' stamp: ''!
testTransform

	| transformation class |
	transformation := (RBSplitClassTransformation
							class: #RBRemoveDirectAccessToVariableTransformation
							instanceVariables: #(receiver)
							newClassName: #RBRemoveDirectAccessWithReceiverTransformation
							referenceVariableName: #newReceiver)
							transform.
		
	class := transformation model classNamed: #RBRemoveDirectAccessToVariableTransformation.
	self deny: (class instanceVariableNames includes: #receiver).
	self assert: (class instanceVariableNames includes: #newReceiver).
	
	self assert: (class parseTreeFor: #receiver:)
		  equals: (self parseMethod:
				'receiver: aString
					newReceiver receiver: aString').
					
	self assert: (class parseTreeFor: #receiver)
		  equals: (self parseMethod:
				'receiver
					^ newReceiver receiver 
						ifNil: [ self receiver: ', 'self' surroundedBySingleQuotes,
						'. newReceiver receiver ]').				
	
	class := transformation model classNamed: #RBRemoveDirectAccessWithReceiverTransformation.
	self deny: class isNil.
	self assert: (class instanceVariableNames includes: #receiver).
	self assert: (class directlyDefinesLocalMethod: #receiver).
	self assert: (class directlyDefinesLocalMethod: #receiver:)! !

!RBSplitClassTransformationTest methodsFor: 'tests' stamp: ''!
testClassVariable

	self shouldFail: (RBSplitClassTransformation
							class:  #RBDummyLintRuleTest
							instanceVariables: #(Foo1)
							newClassName: #RBDummyLintRuleTest123
							referenceVariableName: #receiver)
							asRefactoring.! !

!RBStringReplaceRule commentStamp: ''!
RBStringReplaceRule replaces a matched tree with another tree (which may include metavariable from the matching tree). This is a very succinct syntax for specifying most rewrites.

Instance Variables:
	replaceTree	<RBProgramNode>	The tree to replace the matched tree with.

!
!RBStringReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForMethod: searchString replaceWith: replaceString when: aBlock 
	self searchForMethod: searchString replaceWith: replaceString.
	verificationBlock := aBlock! !

!RBStringReplaceRule methodsFor: 'initialization' stamp: ''!
replaceString: replaceString
	replaceTree := self parserClass 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: 'private - searching' stamp: ''!
searchForTree: aBRProgramNode replaceWith: replaceNode 
	searchTree := aBRProgramNode.
	replaceTree := replaceNode! !

!RBStringReplaceRule methodsFor: 'private - searching' stamp: ''!
searchFor: searchString replaceWith: replaceString when: aBlock 
	self searchFor: searchString replaceWith: replaceString.
	verificationBlock := aBlock! !

!RBStringReplaceRule methodsFor: 'matching' stamp: ''!
foundMatchFor: aProgramNode 
	| newNode |
	newNode := replaceTree copyInContext: self context.
	aProgramNode replaceMethodSource: newNode.
	newNode copyCommentsFrom: aProgramNode.
	^newNode! !

!RBStringReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForTree: aBRProgramNode replaceWith: replaceString when: aBlock 
	self searchForTree: aBRProgramNode replaceWith: replaceString.
	verificationBlock := aBlock! !

!RBStringReplaceRule methodsFor: 'private - searching' stamp: ''!
searchForMethod: searchString replaceWith: replaceString 
	self methodSearchString: searchString.
	self methodReplaceString: replaceString! !

!RBStringReplaceRule methodsFor: 'private - searching' stamp: ''!
searchFor: searchString replaceWith: replaceString 
	self searchString: searchString.
	self replaceString: replaceString! !

!RBStringReplaceRule methodsFor: 'initialization' stamp: ''!
methodReplaceString: replaceString
	replaceTree := self parserClass parseRewriteMethod: replaceString! !

!RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchForTree: aRBProgramNode replaceWith: replaceString 
	^self new searchForTree: aRBProgramNode replaceWith: replaceString! !

!RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchFor: searchString replaceWith: replaceString when: aBlock 
	^self new 
		searchFor: searchString
		replaceWith: replaceString
		when: aBlock! !

!RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchForTree: aRBProgramNode replaceWith: replaceString when: aBlock 
	^self new 
		searchForTree: aRBProgramNode
		replaceWith: replaceString
		when: aBlock! !

!RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchForMethod: searchString replaceWith: replaceString 
	^(self new)
		searchForMethod: searchString replaceWith: replaceString;
		yourself! !

!RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchFor: searchString replaceWith: replaceString 
	^self new searchFor: searchString replaceWith: replaceString! !

!RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''!
searchForMethod: searchString replaceWith: replaceString when: aBlock 
	^self new 
		searchForMethod: searchString
		replaceWith: replaceString
		when: aBlock! !

!RBStringReplacement commentStamp: ''!
RBStringReplacement represents replacing source in the original method with a different string. These are used when reformatting code after a parse tree change has been made. Depending on the change, it may be possible to minimally change the parse tree without needing to format it.

Instance Variables:
	startPosition	<Integer>	the start position in the original source
	stopPosition	<Integer>	the end position in the original source
	string	<String>	replaces everything from the startPosition to the endPosition with this string

!
!RBStringReplacement methodsFor: 'initialization' stamp: ''!
string: aString 
	string := aString! !

!RBStringReplacement methodsFor: 'accessing' stamp: ''!
stopPosition
	^stopPosition! !

!RBStringReplacement methodsFor: 'initialization' stamp: ''!
startPosition: anInteger 
	startPosition := anInteger! !

!RBStringReplacement methodsFor: 'accessing' stamp: ''!
startPosition
	^startPosition! !

!RBStringReplacement methodsFor: 'accessing' stamp: ''!
string
	^string! !

!RBStringReplacement methodsFor: 'initialization' stamp: ''!
stopPosition: anInteger 
	stopPosition := anInteger! !

!RBStringReplacement class methodsFor: 'instance creation' stamp: ''!
replaceFrom: startInteger to: stopInteger with: aString 
	^(self new)
		startPosition: startInteger;
		stopPosition: stopInteger;
		string: aString;
		yourself! !

!RBSubclassOfClassToRename methodsFor: 'accessing' stamp: ''!
rewriteRule1
	^rewriteRule1! !

!RBSubclassOfClassToRename methodsFor: 'accessing' stamp: ''!
rewriteRule1: anObject
	^rewriteRule1 := anObject! !

!RBSubclassOfClassToRename methodsFor: 'accessing' stamp: ''!
calls1
	^self rewriteRule1: (self rewriteRule1: self calls)! !

!RBSubclassOfClassToRename methodsFor: 'performing' stamp: ''!
symbolReference
	^ #RBClassToRename! !

!RBSubclassOfClassToRename methodsFor: 'accessing' stamp: ''!
name
	^rewriteRule1! !

!RBSubclassOfClassToRename methodsFor: 'accessing' stamp: ''!
calls
	^self rewriteRule1: self name , self rewriteRule1! !

!RBSubclassOfClassToRename methodsFor: 'performing' stamp: ''!
reference
	^ RBClassToRename new! !

!RBSwapMethodRefactoring commentStamp: ''!
Move a method from the class to the instance side, or vice versa. Normally this is not considered to be a refactoring.

Only instance methods with no instance variable access or class methods with no class instance variable access can be moved.!
!RBSwapMethodRefactoring methodsFor: 'transforming' stamp: ''!
transform
	target compile: (class sourceCodeFor: selector) classified: (class protocolsFor: selector).
	class removeMethod: selector! !

!RBSwapMethodRefactoring methodsFor: 'preconditions' stamp: ''!
checkInstVars
	class instanceVariableNames do: [ :each |
		(target instanceVariableNames includes: each) ifFalse: [
			((class whichSelectorsReferToInstanceVariable: each) includes: selector) ifTrue: [
				self
					refactoringError: ('<1p> refers to <2s>, which is not defined in <3p>' expandMacrosWith: selector with: each with: target) ] ] ]! !

!RBSwapMethodRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^ (RBCondition definesSelector: selector in: class)
		& (RBCondition definesSelector: selector in: target) not
		& (RBCondition withBlock: [ self checkInstVars. true ])! !

!RBSwapMethodRefactoring methodsFor: 'initialization' stamp: ''!
swapMethod: aSelector in: aClass 
	class := self classObjectFor: aClass.
	target := self classObjectFor: (class isMeta 
			ifTrue: [ class instanceSide ]
			ifFalse: [ class classSide ]).
	selector := aSelector! !

!RBSwapMethodRefactoring methodsFor: '*NautilusRefactoring' stamp: ''!
whatToDisplayIn: aBrowser 

	^ (self changes changes 
		select: [:change | selector = change selector ]) 
		flatCollect: [:change | change whatToDisplayIn: aBrowser ]! !

!RBSwapMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
swapMethod: aSelector in: aClass
	^ self new
		swapMethod: aSelector in: aClass! !

!RBSwapMethodRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk swapMethod: aSelector in: aClass
	^ self new 
		model: aRBSmalltalk;
		swapMethod: aSelector in: aClass;
		yourself! !

!RBTRefactoringBuilder methodsFor: 'parsing' stamp: ''!
parseTreeRewriter
	^ self parseTreeRewriterClass new! !

!RBTRefactoringBuilder methodsFor: 'defining conditions' stamp: ''!
emptyCondition
	^ RBCondition empty! !

!RBTRefactoringBuilder methodsFor: 'defining conditions' stamp: ''!
checkInstanceVariableName: aName in: aClass 
	^RBCondition checkInstanceVariableName: aName in: aClass! !

!RBTRefactoringBuilder methodsFor: 'exceptions' stamp: ''!
refactoringWarning: aString
	^ RBRefactoringWarning signal: aString! !

!RBTRefactoringBuilder methodsFor: 'exceptions' stamp: ''!
refactoringFailure: aString with: aBlock
	^ RBRefactoringFailure signal: aString with: aBlock! !

!RBTRefactoringBuilder methodsFor: 'parsing' stamp: ''!
parseTreeSearcherClass
	^ RBParseTreeSearcher! !

!RBTRefactoringBuilder methodsFor: 'parsing' stamp: ''!
parserClass
	^ RBParser! !

!RBTRefactoringBuilder methodsFor: 'exceptions' stamp: ''!
refactoringConfirmWarning: aString
	| ret |
	ret := self uiManager 
		confirm: aString 
		orCancel: [ ^ RBRefactoringFailure signal: 'aborted' ].
	^ ret! !

!RBTRefactoringBuilder methodsFor: 'exceptions' stamp: ''!
refactoringFailure: aString
	^ RBRefactoringFailure signal: aString! !

!RBTRefactoringBuilder methodsFor: 'parsing' stamp: ''!
parseTreeSearcher
	^ self parseTreeSearcherClass new! !

!RBTRefactoringBuilder methodsFor: 'defining conditions' stamp: ''!
checkMethodName: aName in: aClass 
	^RBCondition checkMethodName: aName in: aClass! !

!RBTRefactoringBuilder methodsFor: 'exceptions' stamp: ''!
refactoringError: aString
	^ RBRefactoringError signal: aString! !

!RBTRefactoringBuilder methodsFor: 'exceptions' stamp: ''!
refactoringError: aString with: aBlock
	^ RBRefactoringError signal: aString with: aBlock! !

!RBTRefactoringBuilder methodsFor: 'parsing' stamp: ''!
parseTreeRewriterClass
	^ RBParseTreeRewriter! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RBTRefactoringBuilder classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RBTRefactoringBuilder classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RBTRefactoringBuilder classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RBTRefactoringBuilder classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RBTRefactoringBuilder classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RBTRefactoringBuilder classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBTRefactoringBuilder classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RBTRefactoringBuilder classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RBTRefactoringBuilder classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RBTRefactoringBuilder classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBTRefactoringBuilder classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RBTRefactoringBuilder classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RBTRefactoringBuilder classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RBTRefactoringBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RBTRefactoringBuilder classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RBTRefactoringBuilder classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RBTemporariesErrorNode commentStamp: ''!
This is a particular englobing node that is a temporaries.
Exemple : | temporaries node |
Can be created by forgetting 
the closure : | temporaries node .
Forgetting the opening will be assumed to be a binary selector.!
!RBTemporariesErrorNode methodsFor: 'testing' stamp: ''!
isTemporariesError
	^true! !

!RBTemporariesErrorNode class methodsFor: 'construction' stamp: ''!
error: aToken withNodes: aCollection
	"A RBTemporariesErrorNode can only be created from the opening token by choice.
	 Since the closure is a |, the default assumption is that it's a binary selector."
	"If the collection is empty, there is only the token in the error."
	^aCollection isEmpty
		ifTrue: [ self new content: aCollection; start: aToken start; stop: aToken stop; errorMessage: '''|'' expected' ]
		ifFalse: [ self new content: aCollection; start: aToken start; stop: aCollection last stop; errorMessage: '''|'' expected' ]! !

!RBTemporaryToInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testHierarchyDefinesVarableNamedAsTemporary
	| class |
	self addClassHierarchy.
	class := model classNamed: #Foo.
	self shouldWarn: (self createRefactoringWithArguments: 
		{ class . #someMethod . 'foo' })! !

!RBTemporaryToInstanceVariableParametrizedTest methodsFor: 'running' stamp: ''!
addClassHierarchy
	model 
		defineClass: 'Foo subclass: #Foo1 instanceVariableNames: ''foo'' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''.
	(model classNamed: #Foo)
		compile: 'someMethod | foo | foo := 4. ^foo'
		classified: #(#accessing).! !

!RBTemporaryToInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testNonExistantName
	self shouldFail: (self createRefactoringWithArguments:  
		{ RBBasicLintRuleTestData . #checkClass: .'asdf' }).
	self shouldFail: (self createRefactoringWithArguments: 
		{ RBBasicLintRuleTestData . #checkClass1: . 'aSmalllintContext' })! !

!RBTemporaryToInstanceVariableParametrizedTest methodsFor: 'failure tests' stamp: ''!
testRedefinedTemporary
	| class |
	class := model classNamed: #Foo.
	class 
		compile: 'someMethod | instVarName1 | instVarName1 := 4. ^instVarName1'
		classified: #(#accessing).
	self shouldFail: (self createRefactoringWithArguments:  
		{ class . #someMethod . 'instVarName1' })! !

!RBTemporaryToInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testWhenHierarchyDefinesVariableNamedAsTemporary
	| class refactoring |
	self addClassHierarchy.
	class := model classNamed: #Foo.
	refactoring := self createRefactoringWithArguments: 
		{ class . #someMethod . 'foo' }.
	self proceedThroughWarning: [ self executeRefactoring: refactoring ].
	self assert: (class definesInstanceVariable: 'foo').
	self deny: ((model classNamed: #Foo1) directlyDefinesInstanceVariable: 'foo').
	self assert: (class parseTreeFor: #someMethod) equals: (self parseMethod: 'someMethod foo := 4. ^ foo'). 
	! !

!RBTemporaryToInstanceVariableParametrizedTest methodsFor: 'accessing' stamp: ''!
constructor 
	^ #class:selector:variable:! !

!RBTemporaryToInstanceVariableParametrizedTest methodsFor: 'tests' stamp: ''!
testTemporaryToInstanceVariable
	| refactoring class |
	refactoring := self createRefactoringWithArguments: 
		{ RBLintRuleTestData . #displayName . 'nameStream'}.
	self executeRefactoring: refactoring.
	class := refactoring model classNamed: #RBLintRuleTestData.
	self assert: (class parseTreeFor: #displayName) equals: (self 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')! !

!RBTemporaryToInstanceVariableParametrizedTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	model := self abstractVariableTestData.! !

!RBTemporaryToInstanceVariableParametrizedTest class methodsFor: 'tests' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		addCase: { #rbClass -> RBTemporaryToInstanceVariableRefactoring };
		addCase: { #rbClass -> RBTemporaryToInstanceVariableTransformation };
		yourself! !

!RBTemporaryToInstanceVariableRefactoring commentStamp: ''!
I am a refactoring for changing a temporary variable to an instance variable.

My preconditions verify that this variable is not yet used as an instance variable in this class.

The temporary variable is added to the class definition and removed from the temporary declaration in this method .

If this instance variable is already used in a subclass it will be removed from that class, because subclasses already inherit this attribute.

The temporary variables with the same name in hierarchy will be removed, and replaced with the new instance variable.

Example
--------------------

Script refactoring:
```
(RBTemporaryToInstanceVariableRefactoring 
    class: MyClassA
    selector: #someMethod
    variable: 'log') execute
```
Before refactoring:
```
Object subclass: #MyClassA
	instanceVariableNames: ''
	classVariableNames: ''
	package: 'example'

MyClassA >> someMethod 
    |log aNumber|
    log := self newLog.
    log isNil.
    aNumber := 5.

MyClassA >> anotherMethod
    #(4 5 6 7) do: [:e | | log |
        log := e ]

MyClassA subclass: #MyClassB
	instanceVariableNames: 'log'
	classVariableNames: ''
	package: 'example'
```
After refactoring:
```
Object subclass: #MyClassA
	instanceVariableNames: 'log'
	classVariableNames: ''
	package: 'example'

MyClassA >> someMethod 
    | aNumber |
    log := self newLog.
    log isNil.
    aNumber := 5.

MyClassA >> anotherMethod
    #(4 5 6 7) do: [:e | 
        log := e ]

MyClassA subclass: #MyClassB
	instanceVariableNames: ''
	classVariableNames: ''
	package: 'example'
```!
!RBTemporaryToInstanceVariableRefactoring methodsFor: 'initialization' stamp: ''!
class: aClass selector: aSelector variable: aVariableName 
	class := self classObjectFor: aClass.
	selector := aSelector.
	temporaryVariableName := aVariableName! !

!RBTemporaryToInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''!
transform

	self removeTemporaryOfClass: class.
	class allSubclasses do: [ :cls | 
		(cls definesInstanceVariable: temporaryVariableName) 
			ifTrue: [ cls removeInstanceVariable: temporaryVariableName ]
			ifFalse: [ self removeTemporaryOfClass: cls ] ].
	class addInstanceVariable: temporaryVariableName.
	! !

!RBTemporaryToInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class)
		& (RBCondition definesInstanceVariable: temporaryVariableName asString in: class) not
		& (RBCondition withBlock: [ 
			(class allSubclasses anySatisfy: 
				[ :cls | cls definesInstanceVariable: temporaryVariableName asString ])
			ifTrue: [ self refactoringWarning: 
				('One or more subclasses of <1p> already defines an<n>instance variable with the same name. Proceed anyway?' expandMacrosWith: class name) ].
			true ])
			& (RBCondition withBlock: 
						[self checkForValidTemporaryVariable.
						true])! !

!RBTemporaryToInstanceVariableRefactoring methodsFor: 'removing' stamp: ''!
removeTemporaryOfClass: aClass
	aClass selectors do: [ :aSymbol | self removeTemporaryOfMethod: aSymbol in: aClass ]! !

!RBTemporaryToInstanceVariableRefactoring methodsFor: 'removing' stamp: ''!
removeTemporaryOfMethod: aSelector in: aClass 

	| parseTree matcher method |
	method := aClass methodFor: aSelector.
	parseTree := method parseTree.
	parseTree ifNil: [ self refactoringFailure: 'Could not parse method' ].
	( matcher := self parseTreeRewriterClass removeTemporaryNamed: temporaryVariableName )
		executeTree: parseTree.
	method compileTree: matcher tree.! !

!RBTemporaryToInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''!
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.<n>Proceed anyway?' 
							expandMacrosWith: temporaryVariableName)]! !

!RBTemporaryToInstanceVariableRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll: selector;
		nextPutAll: ' variable: ''';
		nextPutAll: temporaryVariableName;
		nextPut: $'.
	aStream nextPut: $)! !

!RBTemporaryToInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
class: aClass selector: aSelector variable: aVariableName 
	^ self new 
		class: aClass
		selector: aSelector
		variable: aVariableName! !

!RBTemporaryToInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk class: aClass selector: aSelector variable: aVariableName 
	^ self new
		model: aRBSmalltalk;
		class: aClass
			selector: aSelector
			variable: aVariableName;
		yourself! !

!RBTemporaryToInstanceVariableTransformation commentStamp: ''!
I am a responsible for changing a temporary variable to an instance variable.

My preconditions verify that this variable is not yet used as an instance variable in this class.

The temporary variable is added to the class definition and removed from the temporary declaration in this method .

If this instance variable is already used in a subclass it will be removed from that class, because subclasses already inherit this attribute.

The temporary variables with the same name in hierarchy will be removed, and replaced with the new instance variable.

Example
--------------------

Example: 
| transformation |
transformation := (RBTemporaryToInstanceVariableRefactoring 
				class: MyClassA
    			selector: #someMethod
    			variable: 'log') 
				transform.
(ChangesBrowser changes: transformation model changes changes) open

Script refactoring:
```
(RBTemporaryToInstanceVariableRefactoring 
    class: MyClassA
    selector: #someMethod
    variable: 'log') execute
```
Before refactoring:
```
Object subclass: #MyClassA
	instanceVariableNames: ''
	classVariableNames: ''
	package: 'example'

MyClassA >> someMethod 
    |log aNumber|
    log := self newLog.
    log isNil.
    aNumber := 5.

MyClassA >> anotherMethod
    #(4 5 6 7) do: [:e | | log |
        log := e ]

MyClassA subclass: #MyClassB
	instanceVariableNames: 'log'
	classVariableNames: ''
	package: 'example'
```
After refactoring:
```
Object subclass: #MyClassA
	instanceVariableNames: 'log'
	classVariableNames: ''
	package: 'example'

MyClassA >> someMethod 
    | aNumber |
    log := self newLog.
    log isNil.
    aNumber := 5.

MyClassA >> anotherMethod
    #(4 5 6 7) do: [:e | 
        log := e ]

MyClassA subclass: #MyClassB
	instanceVariableNames: ''
	classVariableNames: ''
	package: 'example'
```!
!RBTemporaryToInstanceVariableTransformation methodsFor: 'instance creation' stamp: ''!
class: aClass selector: aSelector variable: aVariableName 
	class := self model classObjectFor: aClass.
	selector := aSelector.
	temporaryVariableName := aVariableName! !

!RBTemporaryToInstanceVariableTransformation methodsFor: 'preconditions' stamp: ''!
preconditions
	^(RBCondition definesSelector: selector in: class)
		& (RBCondition definesInstanceVariable: temporaryVariableName asString in: class) not
		& (RBCondition withBlock: [ 
			(class allSubclasses anySatisfy: 
				[ :cls | cls definesInstanceVariable: temporaryVariableName asString ])
			ifTrue: [ self refactoringWarning: 
				('One or more subclasses of <1p> already defines an<n>instance variable with the same name. Proceed anyway?' expandMacrosWith: class name) ].
			true ])
			& (RBCondition withBlock: 
						[self checkForValidTemporaryVariable.
						true])! !

!RBTemporaryToInstanceVariableTransformation methodsFor: 'removing' stamp: ''!
removeTemporaryOfClass: aClass
	aClass selectors do: [ :aSymbol | self removeTemporaryOfMethod: aSymbol in: aClass ]! !

!RBTemporaryToInstanceVariableTransformation methodsFor: 'removing' stamp: ''!
removeTemporaryOfMethod: aSelector in: aClass 
	| parseTree matcher aMethod |
	aMethod := aClass methodFor: aSelector.
	parseTree := aMethod parseTree.
	parseTree ifNil: [ self refactoringFailure: 'Could not parse method' ].
	( matcher := self parseTreeRewriterClass removeTemporaryNamed: temporaryVariableName )
		executeTree: parseTree.
	aMethod compileTree: matcher tree.! !

!RBTemporaryToInstanceVariableTransformation methodsFor: 'preconditions' stamp: ''!
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.<n>Proceed anyway?' 
							expandMacrosWith: temporaryVariableName)]! !

!RBTemporaryToInstanceVariableTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream
		nextPutAll: ' selector: #';
		nextPutAll: selector;
		nextPutAll: ' variable: ''';
		nextPutAll: temporaryVariableName;
		nextPut: $'.
	aStream nextPut: $)! !

!RBTemporaryToInstanceVariableTransformation methodsFor: 'executing' stamp: ''!
privateTransform
	self removeTemporaryOfClass: class.
	class allSubclasses do: [ :cls | 
		(cls definesInstanceVariable: temporaryVariableName) 
			ifTrue: [ cls removeInstanceVariable: temporaryVariableName ]
			ifFalse: [ self removeTemporaryOfClass: cls ] ].
	class addInstanceVariable: temporaryVariableName.! !

!RBTemporaryToInstanceVariableTransformation class methodsFor: 'instance creation' stamp: ''!
class: aClass selector: aSelector variable: aVariableName 
	^ self new 
		class: aClass
		selector: aSelector
		variable: aVariableName! !

!RBTemporaryToInstanceVariableTransformation class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk class: aClass selector: aSelector variable: aVariableName 
	^ self new
		model: aRBSmalltalk;
		class: aClass
			selector: aSelector
			variable: aVariableName;
		yourself! !

!RBTest methodsFor: 'running' stamp: ''!
testExample1 	
	self someClasses.
	aString := 'Example'.
	self assert: 4 > 5 equals: false! !

!RBTest methodsFor: 'running' stamp: ''!
testExample4
	self assert: true.
	self deny: false! !

!RBTest methodsFor: 'running' stamp: ''!
testExample2
	"Example"
	self someClasses.
	aString := 'Example'.
	self assert: true! !

!RBTest methodsFor: 'running' stamp: ''!
testExample3
	"Example"
	self someClasses.
	"Comment"
	aString := 'Example'.
	self deny: false! !

!RBTest methodsFor: 'running' stamp: ''!
someClasses 
	RBRefactoryTestDataApp new! !

!RBToken commentStamp: ''!
RBToken is the abstract superclass of all of the RB tokens. These tokens (unlike the standard parser's) remember where they came from in the original source code.

Subclasses must implement the following messages:
	accessing
		length

Instance Variables:
	sourcePointer	<Integer>	The position in the original source code where this token began.
!
!RBToken methodsFor: 'testing' stamp: ''!
isNumberLiteralToken
	^false! !

!RBToken methodsFor: 'testing' stamp: ''!
isPatternVariable
	^false! !

!RBToken methodsFor: 'accessing' stamp: ''!
stop
	^ sourcePointer 
		ifNil: [ -1 ]
		ifNotNil: [ self start + self length - 1 ]! !

!RBToken methodsFor: 'testing' stamp: ''!
isAssignment
	^false! !

!RBToken methodsFor: 'accessing' stamp: ''!
comments: anObject
	comments := anObject! !

!RBToken methodsFor: 'testing' stamp: ''!
isIdentifier
	^false! !

!RBToken methodsFor: 'testing' stamp: ''!
isSpecial
	^false! !

!RBToken methodsFor: 'testing' stamp: ''!
isLiteralToken
	^false! !

!RBToken methodsFor: 'testing' stamp: ''!
isKeyword
	^false! !

!RBToken methodsFor: 'testing' stamp: ''!
isBinary
	^false! !

!RBToken methodsFor: 'testing' stamp: ''!
isPatternBlock
	^false! !

!RBToken methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream
		nextPut: $ ;
		nextPutAll: self class name! !

!RBToken methodsFor: 'accessing' stamp: ''!
removePositions
	sourcePointer := nil! !

!RBToken methodsFor: 'accessing' stamp: ''!
length
	^self subclassResponsibility! !

!RBToken methodsFor: 'testing' stamp: ''!
isError
	^false! !

!RBToken methodsFor: 'initialization' stamp: ''!
start: anInteger 
	sourcePointer := anInteger! !

!RBToken methodsFor: 'testing' stamp: ''!
isPrimitiveKeyword
	^ false! !

!RBToken methodsFor: 'testing' stamp: ''!
isKeywordPattern
	^ false! !

!RBToken methodsFor: 'accessing' stamp: ''!
comments
	^comments! !

!RBToken methodsFor: 'testing' stamp: ''!
isLiteralArrayToken
	^false! !

!RBToken methodsFor: 'testing' stamp: ''!
isEOF
	^false! !

!RBToken methodsFor: 'accessing' stamp: ''!
start
	^ sourcePointer ifNil: [ 0 ]! !

!RBToken methodsFor: 'testing' stamp: ''!
isComment
	^false! !

!RBToken class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBToken! !

!RBToken class methodsFor: 'instance creation' stamp: ''!
start: anInterval 
	^self new start: anInterval! !

!RBTrait commentStamp: ''!
I represent the instance side of a trait in a refactoring namespace. 

I shouldn't be created directly, but always be part of a refactoring namespace.
My  namespace usally knows me and my meta class.!
!RBTrait methodsFor: 'testing' stamp: ''!
isTrait
	^ true! !

!RBTrait methodsFor: 'accessing' stamp: ''!
definesInstanceVariable: aString 
	^ self directlyDefinesInstanceVariable: aString! !

!RBTrait methodsFor: 'accessing' stamp: ''!
users
	^ users ifNil: [ users := realClass users collect: [ :e | model classNamed: e name ] ]! !

!RBTrait methodsFor: 'accessing' stamp: ''!
superclass
	^ nil! !

!RBTraitedMetaclass commentStamp: ''!
I represent the class side of a trait in a refactoring namespace. 

I shouldn't be created directly, but always be part of a refactoring namespace.
My  namespace usally knows me and my non meta class.!
!RBTransformation commentStamp: ''!
I represent an elementary code transformation.
My subinstances can be composed into composite transformations. 

I'm not a refactoring since a transformation I do not pay attention to behavior preservation. 
However as a transformation, I will be used by refactorings. 

My main API is 
	- transform which is actually executing the transformation
	- asRefactoring to optionally (false by default) check preconditions, if some apply
!
!RBTransformation methodsFor: 'accessing' stamp: ''!
poolVariableNamesFor: aClass
	| pools |
	pools := Set new.
	aClass withAllSuperclasses do: 
			[:each | 
			each allPoolDictionaryNames do: 
					[:pool |
					pools addAll: (self poolVariableNamesIn: pool asSymbol) ] ].
	^pools! !

!RBTransformation methodsFor: 'private' stamp: ''!
buildSelectorString: aSelector 
	aSelector numArgs = 0 ifTrue: [^aSelector].
	^self buildSelectorString: aSelector
		withPermuteMap: (1 to: aSelector numArgs)! !

!RBTransformation methodsFor: 'private' stamp: ''!
buildSelectorString: aSelector withPermuteMap: anIntegerCollection 
	| stream keywords |
	aSelector numArgs == 0 ifTrue: [^aSelector asString].
	stream := WriteStream on: String new.
	keywords := aSelector keywords.
	keywords with: anIntegerCollection
		do: 
			[:each :i | 
			stream
				nextPutAll: each;
				nextPutAll: ' ``@arg';
				nextPutAll: i printString;
				nextPut: $ ].
	^stream contents! !

!RBTransformation methodsFor: 'accessing' stamp: ''!
poolVariableNamesIn: poolName
	^(model classNamed: poolName) classPool keys! !

!RBTransformation methodsFor: 'accessing' stamp: ''!
copyOptionsFrom: aDictionary 
	| dict |
	dict := self options.
	dict == self class refactoringOptions 
		ifTrue: [^self options: aDictionary copy].
	dict keysAndValuesDo: 
			[:key :value | 
			value == (self class refactoringOptions at: key) 
				ifTrue: [dict at: key put: (aDictionary at: key)]].
	self options: dict! !

!RBTransformation methodsFor: 'execution' stamp: ''!
execute
	self primitiveExecute.
	RBRefactoryChangeManager instance 
		performChange: self changes; 
		addUndoPointer: (RBRefactoryChangeManager nextCounter)! !

!RBTransformation methodsFor: 'exceptions' stamp: ''!
refactoringFailure: aString with: aBlock
	^ RBRefactoringFailure signal: aString with: aBlock! !

!RBTransformation methodsFor: 'parsing' stamp: ''!
parseTreeSearcherClass
	^ RBParseTreeSearcher! !

!RBTransformation methodsFor: 'displaying' stamp: ''!
whatToDisplayIn: aBrowser 
	
	^ self changes changes
		flatCollect: [ :e | e whatToDisplayIn: aBrowser ]! !

!RBTransformation methodsFor: 'accessing' stamp: ''!
changes

	^ self model changes! !

!RBTransformation methodsFor: 'parsing' stamp: ''!
parserClass
	^ RBParser! !

!RBTransformation methodsFor: 'exceptions' stamp: ''!
refactoringConfirmWarning: aString
	| ret |
	ret := self uiManager 
		confirm: aString 
		orCancel: [ ^ RBRefactoringFailure signal: 'aborted' ].
	^ ret! !

!RBTransformation methodsFor: 'exceptions' stamp: ''!
refactoringFailure: aString
	^ RBRefactoringFailure signal: aString! !

!RBTransformation methodsFor: 'parsing' stamp: ''!
parseTreeSearcher
	^ self parseTreeSearcherClass new! !

!RBTransformation methodsFor: 'defining conditions' stamp: ''!
checkMethodName: aName in: aClass 
	^RBCondition checkMethodName: aName in: aClass! !

!RBTransformation methodsFor: 'exceptions' stamp: ''!
refactoringError: aString
	^ RBRefactoringError signal: aString! !

!RBTransformation methodsFor: 'converting' stamp: ''!
asRefactoring

	^ self 
		checksPreconditions;
		yourself! !

!RBTransformation methodsFor: 'parsing' stamp: ''!
parseTreeRewriterClass
	^ RBParseTreeRewriter! !

!RBTransformation methodsFor: 'accessing' stamp: ''!
model

	^ model ifNil: [ model := self newModel ]! !

!RBTransformation methodsFor: 'executing' stamp: ''!
openBrowserOn: anEnvironment 

	^ (self options at: #openBrowser)
		value: self value: anEnvironment! !

!RBTransformation methodsFor: 'accessing' stamp: ''!
options: aDictionary 

	options := aDictionary! !

!RBTransformation methodsFor: 'executing' stamp: ''!
primitiveExecute
	"compatibility method RBRefactoring"
	self transform! !

!RBTransformation methodsFor: 'executing' stamp: ''!
privateTransform

	self subclassResponsibility! !

!RBTransformation methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	preconditionChecking := false! !

!RBTransformation methodsFor: 'parsing' stamp: ''!
parseTreeRewriter
	^ self parseTreeRewriterClass new! !

!RBTransformation methodsFor: 'preconditions' stamp: ''!
preconditions

	self subclassResponsibility! !

!RBTransformation methodsFor: 'defining conditions' stamp: ''!
emptyCondition
	^ RBCondition empty! !

!RBTransformation methodsFor: 'accessing' stamp: ''!
setOption: aSymbol toUse: aBlock

	self options at: aSymbol put: aBlock! !

!RBTransformation methodsFor: 'executing' stamp: ''!
transform
	"Performs this transformation in a model,
	 then it adds the refactoring to the manager"

	self preconditionChecking ifTrue: [ self checkPreconditions ].
	self privateTransform
	
	"below executes the refactoring without prompt"
	"RBRefactoringManager instance addRefactoring: self"! !

!RBTransformation methodsFor: 'defining conditions' stamp: ''!
checkInstanceVariableName: aName in: aClass 
	^RBCondition checkInstanceVariableName: aName in: aClass! !

!RBTransformation methodsFor: 'exceptions' stamp: ''!
refactoringWarning: aString
	^ RBRefactoringWarning signal: aString! !

!RBTransformation methodsFor: 'preconditions' stamp: ''!
checkPreconditions

	| conditions result |
	conditions := self preconditions.
	
	result := conditions check.
	result ifFalse: [ self refactoringError: conditions errorString ].
	^ result! !

!RBTransformation methodsFor: 'private' stamp: ''!
convertMethod: selector for: aClass using: searchReplacer
	"Convert the parse tree for selector using the searchReplacer. If a
	change is made then compile it into the changeBuilder."

	| parseTree |
	parseTree := aClass parseTreeFor: selector.
	parseTree ifNil: [ ^ self ].
	( searchReplacer executeTree: parseTree )
		ifTrue: [ aClass compileTree: searchReplacer tree ]! !

!RBTransformation methodsFor: 'preconditions' stamp: ''!
checksPreconditions

	self preconditionChecking: true! !

!RBTransformation methodsFor: 'preconditions' stamp: ''!
preconditionChecking: aBoolean

	preconditionChecking := aBoolean! !

!RBTransformation methodsFor: 'accessing' stamp: ''!
model: aRBNamespace

	model := aRBNamespace! !

!RBTransformation methodsFor: 'preconditions' stamp: ''!
preconditionChecking

	^ preconditionChecking! !

!RBTransformation methodsFor: 'exceptions' stamp: ''!
refactoringError: aString with: aBlock
	^ RBRefactoringError signal: aString with: aBlock! !

!RBTransformation methodsFor: 'initialize' stamp: ''!
newModel

	^ (RBNamespace
		onEnvironment: self defaultEnvironment)
		name: self printString;
		yourself! !

!RBTransformation methodsFor: 'initialize' stamp: ''!
defaultEnvironment

	^ RBBrowserEnvironment new! !

!RBTransformation methodsFor: 'accessing' stamp: ''!
options

	^ options ifNil: [ options := self class refactoringOptions copy ]! !

!RBTransformation class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RBTransformation class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RBTransformation class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RBTransformation class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RBTransformation class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RBTransformation class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RBTransformation class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RBTransformation class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RBTransformation class methodsFor: 'class initialization' stamp: ''!
initialize

	self initializeRefactoringOptions! !

!RBTransformation class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBTransformation class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RBTransformation class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RBTransformation class methodsFor: 'private - initialization' stamp: ''!
initializeRefactoringOptions

	RefactoringOptions := IdentityDictionary new.
	RefactoringOptions
		at: #implementorToInline
		put: [ :ref :imps | self error: #implementorToInline ];
		
		at: #methodName
		put: [ :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 ]! !

!RBTransformation class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RBTransformation class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RBTransformation class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RBTransformation class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RBTransformation class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RBTransformation class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RBTransformation class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RBTransformation class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RBTransformation class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RBTransformation class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RBTransformation class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RBTransformation class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RBTransformation class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RBTransformation class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RBTransformation class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RBTransformation class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RBTransformation class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RBTransformation class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RBTransformation class methodsFor: 'accessing' stamp: ''!
refactoringOptions

	^ RefactoringOptions! !

!RBTransformation class methodsFor: 'cleanup' stamp: ''!
cleanUp
	"RefactoringOptions holds on to blocks, we should make sure to recreate them
	 so the block references the current method"
	self initializeRefactoringOptions.! !

!RBTransformationDummyRuleTest methodsFor: 'testing' stamp: ''!
isEmpty
	^builder changes isEmpty! !

!RBTransformationDummyRuleTest methodsFor: 'accessing' stamp: ''!
problemCount
	^builder problemCount! !

!RBTransformationDummyRuleTest methodsFor: 'accessing' stamp: ''!
checkMethod: aSmalllintContext 
	class := aSmalllintContext selectedClass.
	(rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: 
			[(RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false)
				ifFalse: 
					[builder compile: rewriteRule tree printString
						in: class
						classified: aSmalllintContext protocols]]! !

!RBTransformationDummyRuleTest methodsFor: 'rules' stamp: ''!
parseTreeRewriter
	^ RBParseTreeRewriter new! !

!RBTransformationDummyRuleTest methodsFor: 'initialization' stamp: ''!
rewriteUsing: searchReplacer 
	rewriteRule := searchReplacer.
	self resetResult! !

!RBTransformationDummyRuleTest methodsFor: 'accessing' stamp: ''!
resetResult
	builder := RBRefactoryChangeManager changeFactory compositeRefactoryChange! !

!RBTransformationDummyRuleTest methodsFor: 'rules' stamp: ''!
superSends
	| rule |
	rule := self parseTreeRewriter.
	rule
		addSearch:
			'super `@message: ``@args'
				->
					([ :aNode | 
					(class withAllSubclasses
						detect: [ :each | each includesSelector: aNode selector ]
						ifNone: [ nil ]) isNil ] -> 'self `@message: ``@args').
	self rewriteUsing: rule! !

!RBTransformationDummyRuleTest methodsFor: 'private' stamp: ''!
viewResults
	"I reset the result so that we don't fill up memory with methods to compile in the builder."

	builder inspect.
	self resetResult! !

!RBTransformationDummyRuleTest methodsFor: 'testing' stamp: ''!
hasConflicts
	^true! !

!RBTransformationDummyRuleTest methodsFor: 'as yet unclassified' stamp: ''!
newUnclassifiedMethod! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
notElimination
	^self
		rewrite: #(
			#('``@object not not'	"->"	'``@object') 
			#('``@object not ifTrue: ``@block' 	"->"	'``@object ifFalse: ``@block') 
			#('``@object not ifFalse: ``@block'	"->"	'``@object ifTrue: ``@block') 
			#('``@collection select: [:`each | | `@temps | ``@.Statements. ``@object not]'
				"->"	'``@collection reject: [:`each | | `@temps | ``@.Statements. ``@object]')
			#('``@collection reject: [:`each | | `@temps | ``@.Statements. ``@object not]'
				"->"	'``@collection select: [:`each | | `@temps | ``@.Statements. ``@object]')
			#('[| `@temps | ``@.Statements. ``@object not] whileTrue: ``@block'
				"->"	'[| `@temps | ``@.Statements. ``@object] whileFalse: ``@block')
			#('[| `@temps | ``@.Statements. ``@object not] whileFalse: ``@block'
				"->"	'[| `@temps | ``@.Statements. ``@object] whileTrue: ``@block')
			#('[| `@temps | ``@.Statements. ``@object not] whileTrue'
				"->"	'[| `@temps | ``@.Statements. ``@object] whileFalse')
			#('[| `@temps | ``@.Statements. ``@object not] whileFalse'
				"->"	'[| `@temps | ``@.Statements. ``@object] whileTrue')
			#('(``@a <= ``@b) not' "->" '``@a > ``@b')
			#('(``@a < ``@b) not' "->" '``@a >= ``@b')
			#('(``@a = ``@b) not' "->" '``@a ~= ``@b')
			#('(``@a == ``@b) not' "->" '``@a ~~ ``@b')
			#('(``@a ~= ``@b) not' "->" '``@a = ``@b')
			#('(``@a ~~ ``@b) not' "->" '``@a == ``@b')
			#('(``@a >= ``@b) not' "->" '``@a < ``@b')
			#('(``@a > ``@b) not' "->" '``@a <= ``@b'))			
		methods: false
		name: 'Eliminate unnecessary not''s'! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
atIfAbsent
	^self rewrite: #(
			#('``@dictionary at: ``@key 
					ifAbsent: [| `@temps | 
							``@.Statements1.
							``@dictionary at: ``@key put: ``@object.
							``@.Statements2.
							``@object]'
			"->"
			'``@dictionary at: ``@key
					ifAbsentPut: [| `@temps |
							``@.Statements1.
							``@.Statements2.
							``@object]')
			#('``@dictionary at: ``@key
					ifAbsent: [| `@temps |
							``@.Statements.
							``@dictionary at: ``@key put: ``@object]'
			"->"
			'``@dictionary at: ``@key
					ifAbsentPut: [| `@temps |
							``@.Statements.
							``@object]'))
		methods: false
		name: 'at:ifAbsent: -> at:ifAbsentPut:'! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
equalNil
	^self
		rewrite: #(
			#('``@object = nil'	"->"	'``@object isNil') 
			#('``@object == nil'	"->"	'``@object isNil') 
			#('``@object ~= nil'	"->"	'``@object notNil') 
			#('``@object ~~ nil'	"->"	'``@object notNil'))
		methods: false
		name: '= nil -> isNil AND ~= nil -> notNil'! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
superSends
	^(self new)
		name: 'Rewrite super messages to self messages when both refer to same method';
		superSends;
		yourself! !

!RBTransformationDummyRuleTest class methodsFor: 'class initialization' stamp: ''!
nuke
	RecursiveSelfRule := nil! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
betweenAnd
	^self rewrite: #(
			#('``@a >= ``@b and: [``@a <= ``@c]' "->" '``@a between: ``@b and: ``@c')
			#('``@a >= ``@b & (``@a <= ``@c)' "->" '``@a between: ``@b and: ``@c')
			#('``@b <= ``@a and: [``@a <= ``@c]' "->" '``@a between: ``@b and: ``@c')
			#('``@b <= ``@a & (``@a <= ``@c)' "->" '``@a between: ``@b and: ``@c')
			#('``@a <= ``@c and: [``@a >= ``@b]' "->" '``@a between: ``@b and: ``@c')
			#('``@a <= ``@c & (``@a >= ``@b)' "->" '``@a between: ``@b and: ``@c')
			#('``@c >= ``@a and: [``@a >= ``@b]' "->" '``@a between: ``@b and: ``@c')
			#('``@c >= ``@a & (``@a >= ``@b)' "->" '``@a between: ``@b and: ``@c')
			#('``@a >= ``@b and: [``@c >= ``@a]' "->" '``@a between: ``@b and: ``@c')
			#('``@a >= ``@b & (``@c >= ``@a)' "->" '``@a between: ``@b and: ``@c')
			#('``@b <= ``@a and: [``@c >= ``@a]' "->" '``@a between: ``@b and: ``@c')
			#('``@b <= ``@a & (``@c >= ``@a)' "->" '``@a between: ``@b and: ``@c')
			#('``@a <= ``@c and: [``@b <= ``@a]' "->" '``@a between: ``@b and: ``@c')
			#('``@a <= ``@c & (``@b <= ``@a)' "->" '``@a between: ``@b and: ``@c')
			#('``@c >= ``@a and: [``@b <= ``@a]' "->" '``@a between: ``@b and: ``@c')
			#('``@c >= ``@a & (``@b <= ``@a)' "->" '``@a between: ``@b and: ``@c'))
		methods: false
		name: '"a >= b and: [a <= c]" -> "a between: b and: c"'! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
minMax
	^self rewrite: #(
			#('``@a < ``@b ifTrue: [``@a] ifFalse: [``@b]'	"->"	'``@a min: ``@b')
			#('``@a <= ``@b ifTrue: [``@a] ifFalse: [``@b]'	"->"	'``@a min: ``@b')
			#('``@a > ``@b ifTrue: [``@a] ifFalse: [``@b]'	"->"	'``@a max: ``@b')
			#('``@a >= ``@b ifTrue: [``@a] ifFalse: [``@b]'	"->"	'``@a max: ``@b')
			#('``@a < ``@b ifTrue: [``@b] ifFalse: [``@a]'	"->"	'``@a max: ``@b')
			#('``@a <= ``@b ifTrue: [``@b] ifFalse: [``@a]'	"->"	'``@a max: ``@b')
			#('``@a > ``@b ifTrue: [``@b] ifFalse: [``@a]'	"->"	'``@a min: ``@b')
			#('``@a >= ``@b ifTrue: [``@b] ifFalse: [``@a]'	"->"	'``@a min: ``@b')
			#('`a < ``@b ifTrue: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('`a <= ``@b ifTrue: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('`a < ``@b ifFalse: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('`a <= ``@b ifFalse: [`a := ``@b]'			"->"	'`a := `a min: ``@b')
			#('`a > ``@b ifTrue: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('`a >= ``@b ifTrue: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('`a > ``@b ifFalse: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('`a >= ``@b ifFalse: [`a := ``@b]'			"->"	'`a := `a max: ``@b')
			#('``@b < `a ifTrue: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('``@b <= `a ifTrue: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('``@b < `a ifFalse: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('``@b <= `a ifFalse: [`a := ``@b]'			"->"	'`a := `a max: ``@b')
			#('``@b > `a ifTrue: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('``@b >= `a ifTrue: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('``@b > `a ifFalse: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('``@b >= `a ifFalse: [`a := ``@b]'			"->"	'`a := `a min: ``@b'))
		methods: false
		name: 'Rewrite ifTrue:ifFalse: using min:/max:'! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
detectIfNone
	^self rewrite: #(
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) isNil'
				"->"	'(``@collection contains: [:`each | | `@temps | ``@.Statements]) not')
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) = nil'
				"->"	'(``@collection contains: [:`each | | `@temps | ``@.Statements]) not')
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) == nil'
				"->"	'(``@collection contains: [:`each | | `@temps | ``@.Statements]) not')
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) notNil'
				"->"	'``@collection contains: [:`each | | `@temps | ``@.Statements]')
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) ~= nil'
				"->"	'``@collection contains: [:`each | | `@temps | ``@.Statements]')
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) ~~ nil'
				"->"	'``@collection contains: [:`each | | `@temps | ``@.Statements]'))
		methods: false
		name: 'detect:ifNone: -> contains:'! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
guardClause
	^self
		rewrite: #(
			#('`@methodName: `@args 
					| `@temps | 
					`@.Statements. 
					`@condition ifTrue: [| `@trueTemps | `.Statement1. `.Statement2. `@.Statements1]'
			"->"
			'`@methodName: `@args
					| `@temps `@trueTemps |
					`@.Statements.
					`@condition ifFalse: [^self].
					`.Statement1.
					`.Statement2.
					`@.Statements1') 
			#('`@methodName: `@args 
					| `@temps | 
					`@.Statements. 
					`@condition ifFalse: [| `@falseTemps | `.Statement1. `.Statement2. `@.Statements1]'
			"->"
			'`@methodName: `@args
					| `@temps `@falseTemps |
					`@.Statements.
					`@condition ifTrue: [^self].
					`.Statement1.
					`.Statement2.
					`@.Statements1'))
		methods: true
		name: 'Eliminate guarding clauses'! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
assignmentInIfTrue
	^self rewrite: #(
			#('``@Boolean ifTrue: [`variable := ``@true] ifFalse: [`variable := ``@false]'
			"->"
			'`variable := ``@Boolean ifTrue: [``@true] ifFalse: [``@false]')
			#('``@Boolean ifFalse: [`variable := ``@true] ifTrue: [`variable := ``@false]'
			"->"
			'`variable := ``@Boolean ifFalse: [``@true] ifTrue: [``@false]'))
		methods: false
		name: 'Move variable assignment outside of single statement ifTrue:ifFalse: blocks'! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
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'! !

!RBTransformationDummyRuleTest class methodsFor: 'class initialization' stamp: ''!
initializeAfterLoad1
	RecursiveSelfRule := self parseTreeSearcher.
	RecursiveSelfRule
		addMethodSearches: #('`@methodName: `@args | `@temps | self `@methodName: `@args' '`@methodName: `@args | `@temps | ^self `@methodName: `@args')
				-> [:aNode :answer | true]! !

!RBTransformationDummyRuleTest class methodsFor: 'cleanup' stamp: ''!
cleanUp
	self nuke! !

!RBTransformationDummyRuleTest class methodsFor: 'instance creation' stamp: ''!
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! !

!RBTransformationDummyRuleTest class methodsFor: 'transformations' stamp: ''!
showWhileBlocks
	^self
		rewrite: #(
			#('``@cursor showWhile: [| `@temps | ``@.Statements. `var := ``@object]'
				"->"	'`var := ``@cursor showWhile: [| `@temps | ``@.Statements. ``@object]') 
			#('``@cursor showWhile: [| `@temps | ``@.Statements. ^``@object]'
				"->"	'^``@cursor showWhile: [| `@temps | ``@.Statements. ``@object]'))
		methods: false
		name: 'Move assignment out of showWhile: blocks'! !

!RBTransformationDummyRuleTest1 methodsFor: 'accessing' stamp: ''!
openEditor
	| rules |
	rules := self failedRules.
	rules isEmpty ifTrue: [^self].
	rules size == 1 ifTrue: [^rules first viewResults]! !

!RBTransformationRule commentStamp: ''!
A RBTransformationRule is a special rule that not only detects problems but also can automatically transform the good.!
!RBTransformationRule methodsFor: 'testing' stamp: ''!
isEmpty
	^ self builder changes isEmpty! !

!RBTransformationRule methodsFor: 'accessing' stamp: ''!
problemCount
	^ self builder problemCount! !

!RBTransformationRule methodsFor: '*Renraku' stamp: ''!
suggestedCode: aCritic

	^ (self changes detect: [ :ch | 
			(ch  isMeta = aCritic  methodClass isMeta) &
			(ch changeClassName = aCritic criticTheNonMetaclassClass name) & 
			(ch selector = aCritic selector)]) source.
		! !

!RBTransformationRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	rewriteRule := RBParseTreeRewriter new! !

!RBTransformationRule methodsFor: 'running' stamp: ''!
checkMethod: aMethod 
	(self basicCheck: aMethod) ifTrue: [
		self builder compile: rewriteRule tree newSource in: class classified: aMethod protocol ]! !

!RBTransformationRule methodsFor: 'accessing' stamp: ''!
result
	| environment |
	environment := RBParseTreeEnvironment new.
	environment matcher: self rewriteRule.
	environment label: self name.
	self changes do: [ :change |
		(change isKindOf: RBAddMethodChange)
			ifTrue: [ environment addClass: change changeClass selector: change selector ] ].
	^ environment! !

!RBTransformationRule methodsFor: 'running' stamp: ''!
resetResult
	builder := RBRefactoryChangeManager changeFactory compositeRefactoryChangeNamed: self name! !

!RBTransformationRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod 
	aMethod isFromTrait
		ifTrue: [ ^ false ].
	(self rewriteRule canMatchMethod: aMethod) 
		ifFalse: [ ^ false ].
	class := aMethod methodClass.
	^ (self rewriteRule executeTree: aMethod ast copy) and: [
	  (self class recursiveSelfRule
			executeTree: rewriteRule tree
			initialAnswer: false) not ]! !

!RBTransformationRule methodsFor: '*Renraku' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	
	(self basicCheck: aMethod)
		ifTrue: [
			aCriticBlock cull: (
				ReTransformationCritique
					for: aMethod
					by: self
					tree: rewriteRule tree)  ]
		! !

!RBTransformationRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Code Rewriting'! !

!RBTransformationRule methodsFor: 'testing' stamp: ''!
hasConflicts
	^ true! !

!RBTransformationRule methodsFor: 'accessing' stamp: ''!
builder
	^ builder
		ifNil: [ 
			self resetResult.
			builder ]! !

!RBTransformationRule methodsFor: 'accessing' stamp: ''!
changes
	^ self builder changes! !

!RBTransformationRule methodsFor: 'testing' stamp: ''!
isTransformationRule

	^ true ! !

!RBTransformationRule methodsFor: '*Manifest-Core' stamp: ''!
transform: aCritic
	| changeCode |

	changeCode := (self changes detect: [ :ch | 
			(ch  isMeta = aCritic  methodClass isMeta) &
			(ch changeClassName = aCritic criticTheNonMetaclassClass name) & 
			(ch selector = aCritic selector)]) source.
		
	aCritic methodClass compile: changeCode! !

!RBTransformationRule methodsFor: 'accessing' stamp: ''!
rewriteRule
	^ rewriteRule! !

!RBTransformationRule methodsFor: 'accessing' stamp: ''!
rewriteRule: aRule

	rewriteRule := aRule! !

!RBTransformationRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'TransformationRule'! !

!RBTransformationRule class methodsFor: 'class initialization' stamp: ''!
initialize
	self initializeRecursiveSelfRule! !

!RBTransformationRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!RBTransformationRule class methodsFor: 'private - initialization' stamp: ''!
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: 'cleanup' stamp: ''!
cleanUp
	RecursiveSelfRule := nil.! !

!RBTransformationRule class methodsFor: 'testing' stamp: ''!
isVisible
	^ self name ~= #RBTransformationRule! !

!RBTransformationRule class methodsFor: 'accessing' stamp: ''!
recursiveSelfRule
	^ RecursiveSelfRule ifNil: [ self initializeRecursiveSelfRule ]! !

!RBTransformationRuleTestData methodsFor: 'testing' stamp: ''!
isEmpty
	^builder changes isEmpty! !

!RBTransformationRuleTestData methodsFor: 'accessing' stamp: ''!
problemCount
	^builder problemCount! !

!RBTransformationRuleTestData methodsFor: 'accessing' stamp: ''!
checkMethod: aSmalllintContext 
	class := aSmalllintContext selectedClass.
	(rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: 
			[(RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false)
				ifFalse: 
					[builder compile: rewriteRule tree printString
						in: class
						classified: aSmalllintContext protocols]]! !

!RBTransformationRuleTestData methodsFor: 'initialization' stamp: ''!
rewriteUsing: searchReplacer 
	rewriteRule := searchReplacer.
	self resetResult! !

!RBTransformationRuleTestData methodsFor: 'accessing' stamp: ''!
resetResult
	builder := RBRefactoryChangeManager changeFactory compositeRefactoryChange! !

!RBTransformationRuleTestData methodsFor: 'rules' stamp: ''!
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! !

!RBTransformationRuleTestData methodsFor: 'private' stamp: ''!
viewResults
	"I reset the result so that we don't fill up memory with methods to compile in the builder."

	builder inspect.
	self resetResult! !

!RBTransformationRuleTestData methodsFor: 'accessing' stamp: ''!
rewriteRuleAsString
	^ rewriteRule tree printString! !

!RBTransformationRuleTestData methodsFor: 'testing' stamp: ''!
hasConflicts
	^true! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
notElimination
	^self
		rewrite: #(
			#('``@object not not'	"->"	'``@object') 
			#('``@object not ifTrue: ``@block' 	"->"	'``@object ifFalse: ``@block') 
			#('``@object not ifFalse: ``@block'	"->"	'``@object ifTrue: ``@block') 
			#('``@collection select: [:`each | | `@temps | ``@.Statements. ``@object not]'
				"->"	'``@collection reject: [:`each | | `@temps | ``@.Statements. ``@object]')
			#('``@collection reject: [:`each | | `@temps | ``@.Statements. ``@object not]'
				"->"	'``@collection select: [:`each | | `@temps | ``@.Statements. ``@object]')
			#('[| `@temps | ``@.Statements. ``@object not] whileTrue: ``@block'
				"->"	'[| `@temps | ``@.Statements. ``@object] whileFalse: ``@block')
			#('[| `@temps | ``@.Statements. ``@object not] whileFalse: ``@block'
				"->"	'[| `@temps | ``@.Statements. ``@object] whileTrue: ``@block')
			#('[| `@temps | ``@.Statements. ``@object not] whileTrue'
				"->"	'[| `@temps | ``@.Statements. ``@object] whileFalse')
			#('[| `@temps | ``@.Statements. ``@object not] whileFalse'
				"->"	'[| `@temps | ``@.Statements. ``@object] whileTrue')
			#('(``@a <= ``@b) not' "->" '``@a > ``@b')
			#('(``@a < ``@b) not' "->" '``@a >= ``@b')
			#('(``@a = ``@b) not' "->" '``@a ~= ``@b')
			#('(``@a == ``@b) not' "->" '``@a ~~ ``@b')
			#('(``@a ~= ``@b) not' "->" '``@a = ``@b')
			#('(``@a ~~ ``@b) not' "->" '``@a == ``@b')
			#('(``@a >= ``@b) not' "->" '``@a < ``@b')
			#('(``@a > ``@b) not' "->" '``@a <= ``@b'))			
		methods: false
		name: 'Eliminate unnecessary not''s'! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
atIfAbsent
	^self rewrite: #(
			#('``@dictionary at: ``@key 
					ifAbsent: [| `@temps | 
							``@.Statements1.
							``@dictionary at: ``@key put: ``@object.
							``@.Statements2.
							``@object]'
			"->"
			'``@dictionary at: ``@key
					ifAbsentPut: [| `@temps |
							``@.Statements1.
							``@.Statements2.
							``@object]')
			#('``@dictionary at: ``@key
					ifAbsent: [| `@temps |
							``@.Statements.
							``@dictionary at: ``@key put: ``@object]'
			"->"
			'``@dictionary at: ``@key
					ifAbsentPut: [| `@temps |
							``@.Statements.
							``@object]'))
		methods: false
		name: 'at:ifAbsent: -> at:ifAbsentPut:'! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
equalNil
	^self
		rewrite: #(
			#('``@object = nil'	"->"	'``@object isNil') 
			#('``@object == nil'	"->"	'``@object isNil') 
			#('``@object ~= nil'	"->"	'``@object notNil') 
			#('``@object ~~ nil'	"->"	'``@object notNil'))
		methods: false
		name: '= nil -> isNil AND ~= nil -> notNil'! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
superSends
	^(self new)
		name: 'Rewrite super messages to self messages when both refer to same method';
		superSends;
		yourself! !

!RBTransformationRuleTestData class methodsFor: 'class initialization' stamp: ''!
nuke
	RecursiveSelfRule := nil! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
betweenAnd
	^self rewrite: #(
			#('``@a >= ``@b and: [``@a <= ``@c]' "->" '``@a between: ``@b and: ``@c')
			#('``@a >= ``@b & (``@a <= ``@c)' "->" '``@a between: ``@b and: ``@c')
			#('``@b <= ``@a and: [``@a <= ``@c]' "->" '``@a between: ``@b and: ``@c')
			#('``@b <= ``@a & (``@a <= ``@c)' "->" '``@a between: ``@b and: ``@c')
			#('``@a <= ``@c and: [``@a >= ``@b]' "->" '``@a between: ``@b and: ``@c')
			#('``@a <= ``@c & (``@a >= ``@b)' "->" '``@a between: ``@b and: ``@c')
			#('``@c >= ``@a and: [``@a >= ``@b]' "->" '``@a between: ``@b and: ``@c')
			#('``@c >= ``@a & (``@a >= ``@b)' "->" '``@a between: ``@b and: ``@c')
			#('``@a >= ``@b and: [``@c >= ``@a]' "->" '``@a between: ``@b and: ``@c')
			#('``@a >= ``@b & (``@c >= ``@a)' "->" '``@a between: ``@b and: ``@c')
			#('``@b <= ``@a and: [``@c >= ``@a]' "->" '``@a between: ``@b and: ``@c')
			#('``@b <= ``@a & (``@c >= ``@a)' "->" '``@a between: ``@b and: ``@c')
			#('``@a <= ``@c and: [``@b <= ``@a]' "->" '``@a between: ``@b and: ``@c')
			#('``@a <= ``@c & (``@b <= ``@a)' "->" '``@a between: ``@b and: ``@c')
			#('``@c >= ``@a and: [``@b <= ``@a]' "->" '``@a between: ``@b and: ``@c')
			#('``@c >= ``@a & (``@b <= ``@a)' "->" '``@a between: ``@b and: ``@c'))
		methods: false
		name: '"a >= b and: [a <= c]" -> "a between: b and: c"'! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
minMax
	^self rewrite: #(
			#('``@a < ``@b ifTrue: [``@a] ifFalse: [``@b]'	"->"	'``@a min: ``@b')
			#('``@a <= ``@b ifTrue: [``@a] ifFalse: [``@b]'	"->"	'``@a min: ``@b')
			#('``@a > ``@b ifTrue: [``@a] ifFalse: [``@b]'	"->"	'``@a max: ``@b')
			#('``@a >= ``@b ifTrue: [``@a] ifFalse: [``@b]'	"->"	'``@a max: ``@b')
			#('``@a < ``@b ifTrue: [``@b] ifFalse: [``@a]'	"->"	'``@a max: ``@b')
			#('``@a <= ``@b ifTrue: [``@b] ifFalse: [``@a]'	"->"	'``@a max: ``@b')
			#('``@a > ``@b ifTrue: [``@b] ifFalse: [``@a]'	"->"	'``@a min: ``@b')
			#('``@a >= ``@b ifTrue: [``@b] ifFalse: [``@a]'	"->"	'``@a min: ``@b')
			#('`a < ``@b ifTrue: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('`a <= ``@b ifTrue: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('`a < ``@b ifFalse: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('`a <= ``@b ifFalse: [`a := ``@b]'			"->"	'`a := `a min: ``@b')
			#('`a > ``@b ifTrue: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('`a >= ``@b ifTrue: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('`a > ``@b ifFalse: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('`a >= ``@b ifFalse: [`a := ``@b]'			"->"	'`a := `a max: ``@b')
			#('``@b < `a ifTrue: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('``@b <= `a ifTrue: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('``@b < `a ifFalse: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('``@b <= `a ifFalse: [`a := ``@b]'			"->"	'`a := `a max: ``@b')
			#('``@b > `a ifTrue: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('``@b >= `a ifTrue: [`a := ``@b]'				"->"	'`a := `a max: ``@b')
			#('``@b > `a ifFalse: [`a := ``@b]'				"->"	'`a := `a min: ``@b')
			#('``@b >= `a ifFalse: [`a := ``@b]'			"->"	'`a := `a min: ``@b'))
		methods: false
		name: 'Rewrite ifTrue:ifFalse: using min:/max:'! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
detectIfNone
	^self rewrite: #(
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) isNil'
				"->"	'(``@collection contains: [:`each | | `@temps | ``@.Statements]) not')
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) = nil'
				"->"	'(``@collection contains: [:`each | | `@temps | ``@.Statements]) not')
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) == nil'
				"->"	'(``@collection contains: [:`each | | `@temps | ``@.Statements]) not')
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) notNil'
				"->"	'``@collection contains: [:`each | | `@temps | ``@.Statements]')
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) ~= nil'
				"->"	'``@collection contains: [:`each | | `@temps | ``@.Statements]')
			#('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) ~~ nil'
				"->"	'``@collection contains: [:`each | | `@temps | ``@.Statements]'))
		methods: false
		name: 'detect:ifNone: -> contains:'! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
guardClause
	^self
		rewrite: #(
			#('`@methodName: `@args 
					| `@temps | 
					`@.Statements. 
					`@condition ifTrue: [| `@trueTemps | `.Statement1. `.Statement2. `@.Statements1]'
			"->"
			'`@methodName: `@args
					| `@temps `@trueTemps |
					`@.Statements.
					`@condition ifFalse: [^self].
					`.Statement1.
					`.Statement2.
					`@.Statements1') 
			#('`@methodName: `@args 
					| `@temps | 
					`@.Statements. 
					`@condition ifFalse: [| `@falseTemps | `.Statement1. `.Statement2. `@.Statements1]'
			"->"
			'`@methodName: `@args
					| `@temps `@falseTemps |
					`@.Statements.
					`@condition ifTrue: [^self].
					`.Statement1.
					`.Statement2.
					`@.Statements1'))
		methods: true
		name: 'Eliminate guarding clauses'! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
assignmentInIfTrue
	^self rewrite: #(
			#('``@Boolean ifTrue: [`variable := ``@true] ifFalse: [`variable := ``@false]'
			"->"
			'`variable := ``@Boolean ifTrue: [``@true] ifFalse: [``@false]')
			#('``@Boolean ifFalse: [`variable := ``@true] ifTrue: [`variable := ``@false]'
			"->"
			'`variable := ``@Boolean ifFalse: [``@true] ifTrue: [``@false]'))
		methods: false
		name: 'Move variable assignment outside of single statement ifTrue:ifFalse: blocks'! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
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'! !

!RBTransformationRuleTestData class methodsFor: 'class initialization' stamp: ''!
initializeAfterLoad1
	RecursiveSelfRule := self parseTreeSearcher.
	RecursiveSelfRule
		addMethodSearches: #('`@methodName: `@args | `@temps | self `@methodName: `@args' '`@methodName: `@args | `@temps | ^self `@methodName: `@args')
				-> [:aNode :answer | true]! !

!RBTransformationRuleTestData class methodsFor: 'cleanup' stamp: ''!
cleanUp
	self nuke! !

!RBTransformationRuleTestData class methodsFor: 'instance creation' stamp: ''!
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! !

!RBTransformationRuleTestData class methodsFor: 'transformations' stamp: ''!
showWhileBlocks
	^self
		rewrite: #(
			#('``@cursor showWhile: [| `@temps | ``@.Statements. `var := ``@object]'
				"->"	'`var := ``@cursor showWhile: [| `@temps | ``@.Statements. ``@object]') 
			#('``@cursor showWhile: [| `@temps | ``@.Statements. ^``@object]'
				"->"	'^``@cursor showWhile: [| `@temps | ``@.Statements. ``@object]'))
		methods: false
		name: 'Move assignment out of showWhile: blocks'! !

!RBTransformationRuleTestData1 methodsFor: 'as yet unclassified' stamp: ''!
classVarA
	^A! !

!RBTransformationRuleTestData1 methodsFor: 'accessing' stamp: ''!
foo 
	^ foo! !

!RBTransformationTest methodsFor: 'running' stamp: ''!
shouldFail: aRefactoring 

	self proceedThroughWarning: [
		self should: [ aRefactoring transform ] raise: RBRefactoringError ]! !

!RBTransformationTest methodsFor: 'tests' stamp: ''!
testAPI
	"all classes must implement #storeOn: and #transform"

	| incompleteTransformations |
	incompleteTransformations := RBTransformation allSubclasses
		select: [ :each | 
			| selectors |
			selectors := each methods collect: [:m | m selector].
			each subclasses isEmpty and: [ (selectors includes: #privateTransform) not and: [ (selectors includes: #storeOn:) not ] ] ].
	self assertEmpty: incompleteTransformations.

	incompleteTransformations := RBCompositeTransformation allSubclasses
		select: [ :each | 
			| selectors |
			selectors := each methods collect: [:m | m selector].
			each subclasses isEmpty and: [ (selectors includes: #buildTransformations) not ] ].
	self assertEmpty: incompleteTransformations! !

!RBTransformationTest methodsFor: 'mocking' stamp: ''!
abstractVariableTestData

	| newModel classEnvironment classes |
	classes := #(#Bar #Foo) 
		inject: OrderedCollection new 
		into: [ :sum :each | 
			testingEnvironment at: each ifPresent: [ :class | 
				sum add: class; add: class class ].
			sum ].
	classEnvironment := RBClassEnvironment classes: classes.
	newModel := RBNamespace onEnvironment: classEnvironment not.
	newModel name: 'Test'.
	
	#('Object subclass: #Foo
		instanceVariableNames: ''instVarName1 instVarName2''
		classVariableNames: ''ClassVarName1 ClassVarName2 ''
		poolDictionaries: ''''
		category: ''Testing'' '
	'Foo subclass: #Bar
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Testing'' '
	) do: [ :each | newModel defineClass: each ].
	
	#(#(#Bar #(
		#('instVarName1
			^1242321' #tests) 
		#('foo
			instVarName1 := instVarName1 + instVarName2 + ClassVarName1' #tests))) 
	#(#Foo #(
		#('foo
			^instVarName2 := 3' #tests)
		#('bar
			"Add one to instVarName1"
			instVarName1 := instVarName1 + 1' #tests) 
		#('classVarName1
			^ClassVarName1' #tests)
		#('instVarName1: anObject
			^anObject' #tests)
		#('asdf
			^self classVarName1: (ClassVarName1 := ClassVarName1 + 1)' #tests) 
		#('instVarName2
			^instVarName2' #tests)
		#('instVarName2: anObject
			instVarName2 := anObject' #tests)
		#('classVarName1: anObject
			^ClassVarName1 := anObject' #tests)))
	
	#('Bar class' #(
		#('classVarName2: anObject
			ClassVarName2 := anObject' #tests) 
		#('classVarName2
			^ClassVarName2' #tests))) 
	#('Foo class' #(
		#('foo
			^ClassVarName1 := ClassVarName1 * ClassVarName1 * ClassVarName1' #tests)))) 
		do: [:each | 
			| class |
			class := newModel classNamed: each first.
			each last do: [ :methodPair | 
				class 
					compile: methodPair first
					classified: methodPair last]].
	^ newModel! !

!RBTransformationTest methodsFor: 'running' stamp: ''!
tearDown

	self removeMockClass.
	super tearDown! !

!RBTransformationTest methodsFor: 'mocking' stamp: ''!
changeMock

	^ testingEnvironment at: #RBRefactoringChangeMock! !

!RBTransformationTest methodsFor: 'mocking' stamp: ''!
objectClassVariable

	^ Object classPool keys detect: [:each | true]! !

!RBTransformationTest methodsFor: 'running' stamp: ''!
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 ] ]! !

!RBTransformationTest methodsFor: 'running' stamp: ''!
proceedThroughWarning: aBlock

	aBlock
		on: RBRefactoringError
		do: [ :ex | ex resume ]! !

!RBTransformationTest methodsFor: 'parsing' stamp: ''!
parserClass
	^ RBParser! !

!RBTransformationTest methodsFor: 'mocking' stamp: ''!
removeMockClass

	testingEnvironment removeClassNamed: #RBRefactoringChangeMock.! !

!RBTransformationTest methodsFor: 'mocking' stamp: ''!
createMockClass

	self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: 'RBRefactoringChangeMock';
			sharedVariablesFromString: 'ClassVar';
			slots: 'instVar' asSlotCollection;
			classSlots: 'classInstVar' asSlotCollection;
			package: 'Refactoring-Tests-Changes' ].
	
	self changeMock compile: 'one ^ 1' classified: 'accessing'.! !

!RBTransformationTest methodsFor: 'parsing' stamp: ''!
parseMethod: aString
	^ self parserClass parseMethod: aString! !

!RBTransformationTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	self createMockClass.
	model := RBNamespace new! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testPullUpVariableTransform

	| transformation |
	transformation := (RBPullUpVariableTransformation
							instanceVariable: 'result'
							class: #RBDummyLintRuleTest)
							transform.
	
	self assert: ((transformation model classNamed: #RBDummyLintRuleTest)
			directlyDefinesInstanceVariable: 'result').
	
	self deny: ((transformation model classNamed: #RBBasicDummyLintRuleTest)
			directlyDefinesInstanceVariable: 'result').
	self deny: ((transformation model classNamed: #RBFooDummyLintRuleTest)
			directlyDefinesInstanceVariable: 'result')! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testRemoveMessageSendTransform

	| transformation class methodName |
	methodName := ('called:', 'on:') asSymbol.
	transformation := (RBRemoveMessageSendTransformation new
		messageSend: #cr
		inMethod: methodName
		inClass: #RBRefactoryTestDataApp)
		transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: #RBRefactoryTestDataApp.
	self assert: (class parseTreeFor: methodName)
			equals:  (self parseMethod: 'called: anObject on: aBlock 
	Transcript show: anObject printString.
	aBlock value')! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testAddMethodCommentTransform

	| transformation method |
	transformation := (RBAddMethodCommentTransformation
		comment: 'New comment for method'
		inMethod: #one
		inClass: self changeMock name)
		transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	method := (transformation model classNamed: self changeMock name) methodFor: #one.
	self assert: method ast comments first contents equals: 'New comment for method'! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testAddTemporaryVariableTransform

	| transformation class |
	transformation := (RBAddTemporaryVariableTransformation
							variable: 'variable'
							inMethod: #one
							inClass: self changeMock name)
							transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self changeMock name asSymbol.
	self assert: (class directlyDefinesMethod: #one).
	self assert: (class parseTreeFor: #one) temporaries size equals: 1! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testRenameClassTransform

	| transformation class |
	transformation := (RBRenameClassTransformation
							rename: 'RBDummyClassToRename' asSymbol
							to: 'RBNewDummyClassName' asSymbol)
							transform.
							
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: 'RBNewDummyClassName' asSymbol.
	self assert: (class parseTreeFor: #method1)
		  equals: (self parseMethod: 'method1 ^ self method2').
	self deny: (transformation model includesClassNamed: 'RBDummyClassToRename' asSymbol).
				
	class := transformation model classNamed: 'RBDummySubclassOfClassToRename' asSymbol.
	self assert: class superclass 
		  equals: (transformation model classNamed: 'RBNewDummyClassName' asSymbol).
	self assert: (class parseTreeFor: #symbolReference) 
		  equals: (self parseMethod: 'symbolReference ^ #RBNewDummyClassName').
	self assert: (class parseTreeFor: #reference) 
		  equals: (self parseMethod: 'reference ^ RBNewDummyClassName new')! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testAddVariableTransform

	| transformation class |
	transformation := (RBAddVariableTransformation 
							instanceVariable: 'asdf'
							class: self changeMock name)
							transform. 
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self changeMock name asSymbol.
	self assert: (class directlyDefinesInstanceVariable: 'asdf').! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testAddClassTransform

	| transformation class |
	transformation := (RBAddClassCommentTransformation
		comment: 'New comment for class'
		in: self changeMock name)
		transform.
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self changeMock name.
	self assert: class comment equals: 'New comment for class'! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testRenameTemporaryTransform

	| transformation class |
	transformation := (RBAddMethodTransformation
							sourceCode: 'foo
									| temp bar |
									bar := 5.
									temp := bar * bar.
									Transcript show: temp printString; cr.
									^temp * temp'
							in: self changeMock name
							withProtocols: {#accessing})
							transform.
	
	transformation := (RBRenameTemporaryVariableTransformation 
							model: transformation model
							rename: #temp to: #temp2
							in: self changeMock name
							selector: #foo)
							transform.
	
	self assert: transformation model changes changes size equals: 2.			
	
	class := transformation model classNamed: self changeMock name.
	self assert: (class directlyDefinesMethod: #foo).		
	self assert: (class parseTreeFor: #foo) temporaries size equals: 2.
	self assert: ((class parseTreeFor: #foo) temporaries anySatisfy: [ :e | e name = #temp2 ])! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testRenameVariableTransform

	| transformation class |
	transformation := (RBRenameVariableTransformation
							rename: 'classBlock' to: 'asdf'
							in: #RBBasicLintRuleTestData
							classVariable: false)
							transform.
	
	class := transformation model classNamed: #RBBasicLintRuleTestData.
	self assert: (class directlyDefinesInstanceVariable: 'asdf').
	self deny: (class directlyDefinesInstanceVariable: 'classBlock').
	self assert: (class parseTreeFor: #checkClass:)
		  equals: (self parseMethod:
				'checkClass: aSmalllintContext 
					^asdf value: aSmalllintContext value: result').
	self assert: (class parseTreeFor: #initialize)
		  equals: (self parseMethod:
				'initialize
					super initialize.
					self anInstVar: 1.
					asdf := [:context :aResult | ].
					methodBlock := [:context :aResult | ].
					self resultClass: RBSelectorEnvironment')! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testCompositeTransform

	| transformation newClassName class |
	newClassName := (self changeMock name, 'Temporary') asSymbol.
	transformation := RBCompositeTransformation new
		transformations: (OrderedCollection new
			add: (RBAddClassTransformation
					addClass: newClassName
					superclass: #Object
					subclasses: #() 
					category: self class category);
			add: (RBAddVariableTransformation 
					instanceVariable: 'asdf'
					class: newClassName);
			add: (RBAddMethodTransformation
					sourceCode: 'printString1 ^super printString'
					in: newClassName
					withProtocols: {#accessing});
			yourself).
	transformation transform.
	
	self assert: transformation model changes changes size equals: 3.
	
	class := transformation model classNamed: (self changeMock name, 'Temporary') asSymbol.
	self assert: (class directlyDefinesInstanceVariable: 'asdf').
	self assert: (class parseTreeFor: #printString1)
		  equals: (self parseMethod: 'printString1 ^super printString')! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testRemoveClassTransform

	| transformation newClass superclass |
	transformation := (RBRemoveClassTransformation
							className: self changeMock name)
							transform.
	self assert: transformation model changes changes size equals: 1.
	newClass := transformation model classNamed: self changeMock name asSymbol.
	superclass := transformation model classNamed: #Object.
	self assert: newClass isNil.
	newClass := self changeMock name.
	self assert: ((superclass subclasses collect: [:each | each name]) includes: newClass) not.
	self assert: ((superclass theMetaClass subclasses collect: [:each | each name]) includes: newClass) not.! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testAddMethodTransform

	| transformation class |
	transformation := (RBAddMethodTransformation
		sourceCode: 'printString1 ^super printString'
		in: self changeMock name
		withProtocols: {#accessing})
		transform.
	
	class := transformation model classNamed: self changeMock name.
	self assert: (class parseTreeFor: #printString1)
		  equals: (self parseMethod: 'printString1 ^super printString')! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testCustomTransform

	| transformation newClassName class |
	newClassName := (self changeMock name, 'Temporary') asSymbol.
	transformation := RBCustomTransformation with: [ :aModel |
		"add class"
		aModel
			defineClass: ('<1p> subclass: #<2s>
				instanceVariableNames: ''''
				classVariableNames: ''''
				poolDictionaries: ''''
				category: <3p>' 
			expandMacrosWith: 'Object'
			with: newClassName
			with: self class category).
		
		"add a comment in the class description"
		(aModel classNamed: newClassName) comment: 'Deprecated!!!!!! Use super class'.
		"add an instance variable"
		(aModel classNamed: newClassName) addInstanceVariable: 'asdf' ].

	transformation transform.
	self assert: transformation model changes changes size equals: 3.
	
	class := transformation model classNamed: (self changeMock name, 'Temporary') asSymbol.
	self assert: (class directlyDefinesInstanceVariable: 'asdf')! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testRemoveMethodTransform

	| transformation class |
	transformation := (RBRemoveMethodTransformation 
		selector: #one
		from: self changeMock name)
		transform. 
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self changeMock name asSymbol.
	self deny: (class directlyDefinesMethod: #one).! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testMoveInstanceVariableToClassTransform

	| transformation oldClass newClass |
	model := RBNamespace new.
	model defineClass: 'Object subclass: #FOOBAR 
				instanceVariableNames: ''asdf'' 	
				classVariableNames: ''''
				poolDictionaries: ''''
				category: #''Refactory-Test data'''.
				
	transformation := RBMoveInstanceVariableToClassTransformation
							model: model
							variable: 'asdf'
							fromClass: #FOOBAR
							toClass: self changeMock name.
	
	oldClass := transformation model classNamed: #FOOBAR.
	newClass := transformation model classNamed: self changeMock name asSymbol.
	self assert: (oldClass directlyDefinesInstanceVariable: 'asdf').
	self deny: (newClass directlyDefinesInstanceVariable: 'asdf').
	
	transformation transform.
	self assert: transformation model changes changes size equals: 3.
	
	oldClass := transformation model classNamed: #FOOBAR.
	newClass := transformation model classNamed: self changeMock name asSymbol.
	self deny: (oldClass directlyDefinesInstanceVariable: 'asdf').
	self assert: (newClass directlyDefinesInstanceVariable: 'asdf').
	! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testRemoveVariableTransform

	| transformation class |
	transformation := (RBRemoveVariableTransformation 
							instanceVariable: 'instVar'
							class: self changeMock name)
							transform. 
	
	self assert: transformation model changes changes size equals: 1.
	
	class := transformation model classNamed: self changeMock name asSymbol.
	self deny: (class directlyDefinesInstanceVariable: 'instVar').! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testAddProtocolTransform
	
	| transformation |
	transformation := (RBAddProtocolTransformation new
		protocol: 'transforming'
		inClass: #RBDummyEmptyClass)
		transform.
		
	self assert: transformation model changes changes size equals: 1! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testPushDownVariableTransform

	| transformation |
	transformation := (RBPushDownVariableTransformation 
							instanceVariable: 'foo1'
							class: #RBDummyLintRuleTest)
							transform.
		
	(transformation model classNamed: #RBDummyLintRuleTest) 
	subclasses do: [ :each | self assert: (each directlyDefinesInstanceVariable: 'foo1') ]! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testAddVariableAccessorTransform
	| transformation class |
	transformation := (RBAddVariableAccessorTransformation 
		instanceVariable: 'instVar' 
		class: self changeMock name) 
		transform.

	self assert: transformation model changes changes size equals: 2.

	class := transformation model classNamed: self changeMock name asSymbol.
	self assert: (class parseTreeFor: #instVar) 
		equals: (self parseMethod: 'instVar ^instVar').
	self assert: (class parseTreeFor: #instVar:) 
		equals: (self parseMethod: 'instVar: anObject instVar := anObject')! !

!RBTransformationsTest methodsFor: 'tests' stamp: ''!
testDeprecateClassTransform

	| transformation class |
	transformation := (RBDeprecateClassTransformation 
							class: self changeMock name)
							transform. 

	self assert: transformation model changes changes size equals: 4.
	
	class := transformation model classNamed: self changeMock name asSymbol.
	self assert: class comment equals: 'Deprecated!!!!!! Use superclass'.
	
	class := transformation model metaclassNamed: self changeMock name.
	
	self assert: (class parseTreeFor: #new)
		equals: (self parseMethod: 'new
				self deprecated: ''Use superclass '' on: ''4 May 2016''  in: #Pharo60.
				^ super new').
	self assert: (class parseTreeFor: #deprecated)
		equals: (self parseMethod: 'deprecated ^ true').
	self assert: (class parseTreeFor: #systemIcon)
		equals: (self parseMethod: 'systemIcon
				^ Smalltalk ui icons iconNamed: #packageDelete').! !

!RBTransformationsTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	model := self abstractVariableTestData.! !

!RBUnfinishedStatementErrorNode methodsFor: 'testing' stamp: ''!
isUnfinishedStatement
	
	^ true! !

!RBUnfinishedStatementErrorNode methodsFor: 'accessing' stamp: ''!
statement
	
	^ content first! !

!RBUnreachableStatementErrorNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aVisitor

	^ aVisitor visitUnreachableStatement: self! !

!RBValueNode commentStamp: ''!
RBValueNode is an abstract class that represents a node that returns some value.

Subclasses must implement the following messages:
	accessing
		startWithoutParentheses
		stopWithoutParentheses
	testing
		needsParenthesis

Instance Variables:
	parentheses	<SequenceableCollection of: Inteval>	the positions of the parentheses around this node. We need a collection of intervals for stupid code such as "((3 + 4))" that has multiple parentheses around the same expression.

!
!RBValueNode methodsFor: 'accessing' stamp: ''!
stop
	^ parentheses ifNil: [ self stopWithoutParentheses ] ifNotNil: [ parentheses last last ]! !

!RBValueNode methodsFor: 'accessing' stamp: ''!
stopWithoutParentheses
	^self subclassResponsibility! !

!RBValueNode methodsFor: 'testing' stamp: ''!
needsParenthesis
	^self subclassResponsibility! !

!RBValueNode methodsFor: 'accessing' stamp: ''!
startWithoutParentheses
	^self subclassResponsibility! !

!RBValueNode methodsFor: 'accessing' stamp: ''!
parentheses
	^parentheses ifNil: [#()] ifNotNil: [parentheses]! !

!RBValueNode methodsFor: 'testing' stamp: ''!
hasParentheses
	^self parentheses notEmpty! !

!RBValueNode methodsFor: 'evaluating' stamp: ''!
evaluateForReceiver: aReceicer
	"evaluate the AST without taking variables into account"
	| methodNode |
	
	methodNode := self asDoit.
	methodNode methodClass: aReceicer class.
	^methodNode generateWithSource valueWithReceiver: aReceicer arguments: #().! !

!RBValueNode methodsFor: 'testing' stamp: ''!
containedBy: anInterval 
	^anInterval first <= self startWithoutParentheses 
		and: [anInterval last >= self stopWithoutParentheses]! !

!RBValueNode methodsFor: 'accessing' stamp: ''!
addParenthesis: anInterval 
	parentheses ifNil: [parentheses := OrderedCollection new: 1].
	parentheses add: anInterval! !

!RBValueNode methodsFor: 'accessing' stamp: ''!
start
	^ parentheses ifNil: [ self startWithoutParentheses ] ifNotNil: [ parentheses last first ]! !

!RBValueNode methodsFor: 'evaluating' stamp: ''!
evaluateForContext: aContext
	"evaluate the AST taking variables from the context"
	^(self asDoitForContext: aContext) 
		generateWithSource valueWithReceiver: aContext receiver arguments: {aContext}.! !

!RBValueNode methodsFor: 'evaluating' stamp: ''!
evaluate
	"evaluate the AST with a nil  receiver"
	^ self evaluateForReceiver: nil! !

!RBValueNode methodsFor: 'testing' stamp: ''!
isValue
	^true! !

!RBValueToken commentStamp: ''!
RBValueToken is the abstract superclass of all tokens that have additional information attached. For example, the BinarySelector token holds onto the actual character (e.g. $+).

Instance Variables:
	value	<String>	The value of this token

!
!RBValueToken methodsFor: 'accessing' stamp: ''!
value: anObject
	value := anObject! !

!RBValueToken methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	value printOn: aStream.
	aStream nextPutAll: ')'! !

!RBValueToken methodsFor: 'accessing' stamp: ''!
source
	^ self value! !

!RBValueToken methodsFor: 'accessing' stamp: ''!
value
	^value! !

!RBValueToken methodsFor: 'private' stamp: ''!
length
	^value size! !

!RBValueToken methodsFor: 'initialization' stamp: ''!
value: aString start: anInteger 
	value := aString.
	sourcePointer := anInteger! !

!RBValueToken class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBValueToken! !

!RBValueToken class methodsFor: 'instance creation' stamp: ''!
value: aString start: anInteger 
	^self new value: aString start: anInteger! !

!RBVariableEnvironment commentStamp: ''!
I am a RBBrowserEnvironment for items referring class or instvars.
Constructed by quering extisting environments with 
refering, reading or writing to the variables of a class.

Example:
(RBBrowserEnvironment new) instVarWritersTo:#color in: Morph.
-> a RBVariableEnvironment!
!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
numberVariables
	^self accessorMethods inject: 0
		into: [:sum :each | sum + ((self perform: each) inject: 0 into: [:s :e | s + e size])]! !

!RBVariableEnvironment methodsFor: 'testing' stamp: ''!
isEmpty
	^ self accessorMethods allSatisfy: [ :each | (self perform: each) isEmpty ]! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
problemCount
	^self numberVariables! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
selectorCacheFor: aClass 
	^self selectorCache at: aClass name ifAbsentPut: [ self computeSelectorCacheFor: aClass ]! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
addClass: aClass instanceVariable: aString 
	(instanceVariables at: aClass name ifAbsentPut: [Set new]) add: aString.
	self flushCachesFor: aClass.
	self addSearchString: aString! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
addClass: aClass instanceVariableWriter: aString 
	(instanceVariableWriters at: aClass name ifAbsentPut: [Set new]) 
		add: aString.
	self flushCachesFor: aClass.
	self addSearchString: aString! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
instanceVariableReaders: anObject
	instanceVariableReaders := anObject! !

!RBVariableEnvironment methodsFor: 'testing' stamp: ''!
includesProtocol: aProtocol in: aClass 
	^(self selectorsFor: aProtocol in: aClass) isNotEmpty! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
classNamesWithVariables
	| classNames |
	classNames := Set new.
	classNames
		addAll: instanceVariables keys;
		addAll: instanceVariableReaders keys;
		addAll: instanceVariableWriters keys;
		addAll: classVariables keys.
	^classNames! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
packages
	^ self classes collect: [:each | each package]! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
addClass: aClass instanceVariableReader: aString 
	(instanceVariableReaders at: aClass name ifAbsentPut: [Set new]) 
		add: aString.
	self flushCachesFor: aClass.
	self addSearchString: aString! !

!RBVariableEnvironment methodsFor: '*Manifest-Core' stamp: ''!
smallLintCritics
	^ self classes! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
instanceVariableWriters
	^instanceVariableWriters! !

!RBVariableEnvironment methodsFor: 'copying' stamp: ''!
copyDictionary: aDictionary 
	| copy |
	copy := Dictionary new: aDictionary size.
	aDictionary keysAndValuesDo: [:key :value | copy at: key put: value].
	^copy! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
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 whichSelectorsWrite: aString) 
						do: [:sel | selectorEnvironment addClass: each selector: sel]].
			isReader 
				ifTrue: 
					[(each whichSelectorsRead: aString) 
						do: [:sel | selectorEnvironment addClass: each selector: sel]]].
	^selectorEnvironment! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
instanceVariableReaders
	^instanceVariableReaders! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
classVariables: anObject
	classVariables := anObject! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
classVariablesFor: aClass 
	^classVariables at: aClass name ifAbsent: [#()]! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
allClassesDo: aBlock 
	| classes instVarBlock |
	classes := Set new.
	instVarBlock := 
			[:each | 
			| class |
			class := self classForName: each.
			classes addAll: class withAllSubclasses].
	instanceVariables keysDo: instVarBlock.
	instanceVariableReaders keysDo: instVarBlock.
	instanceVariableWriters keysDo: instVarBlock.
	classVariables keysDo: 
			[:each | 
			| class |
			class := self classForName: each.
			class notNil 
				ifTrue: 
					[classes
						addAll: class withAllSubclasses;
						addAll: class class withAllSubclasses]].
	classes do: aBlock! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
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: 'initialization' stamp: ''!
initialize
	super initialize.
	instanceVariables := Dictionary new.
	classVariables := Dictionary new.
	instanceVariableReaders := Dictionary new.
	instanceVariableWriters := Dictionary new! !

!RBVariableEnvironment methodsFor: 'testing' stamp: ''!
includesCategory: aCategory 
	^(self classNamesFor: aCategory) isNotEmpty! !

!RBVariableEnvironment methodsFor: 'testing' stamp: ''!
includesSelector: aSymbol in: aClass 
	^(environment includesSelector: aSymbol in: aClass) 
		and: [(self selectorCacheFor: aClass) includes: aSymbol]! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
addClass: aClass classVariable: aSymbol 
	(classVariables at: aClass name ifAbsentPut: [Set new]) add: aSymbol.
	self flushCachesFor: aClass.
	self addSearchString: aSymbol! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
classVariableSelectorsFor: aClass 
	| selectors classVars |
	selectors := Set new.
	classVars := Set new.
	classVariables keysDo: 
			[:each | 
			| cls |
			cls := self classForName: each.
			(cls notNil and: [aClass instanceSide includesBehavior: cls]) 
				ifTrue: [classVars addAll: (classVariables at: each)]].
	classVars do: 
			[:each | 
			| binding |
			binding := aClass bindingOf: each.
			binding ifNotNil: [selectors addAll: (aClass whichSelectorsReferTo: binding)]].
	^selectors! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
flushCachesFor: aClass

	selectorCache ifNil: [ ^ self ].
	aClass instanceSide withAllSubclasses
		do: [ :each | 
			selectorCache
				removeKey: each name ifAbsent: [  ];
				removeKey: each classSide name ifAbsent: [  ]
			]! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
instanceVariableWriters: anObject
	instanceVariableWriters := anObject! !

!RBVariableEnvironment methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	instanceVariables := self copyDictionary: instanceVariables.
	instanceVariableReaders := self copyDictionary: instanceVariableReaders.
	instanceVariableWriters := self copyDictionary: instanceVariableWriters.
	classVariables := self copyDictionary: classVariables.
	selectorCache := nil! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
classVariables
	^classVariables! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
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: 'private' stamp: ''!
computeSelectorCacheFor: aClass 
	^(self instanceVariableSelectorsFor: aClass)
		addAll: (self classVariableSelectorsFor: aClass);
		yourself! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
instanceVariables
	^instanceVariables! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
accessorMethods
	^#(#instanceVariables #instanceVariableReaders #instanceVariableWriters #classVariables)! !

!RBVariableEnvironment methodsFor: 'testing' stamp: ''!
isVariableEnvironment
	^ true! !

!RBVariableEnvironment methodsFor: 'testing' stamp: ''!
includesClass: aClass 
	(super includesClass: aClass) ifFalse: [^false].
	(instanceVariables includesKey: aClass name) ifTrue: [^true].
	(classVariables includesKey: aClass name) ifTrue: [^true].
	^(self selectorCacheFor: aClass) 
		anySatisfy: [:each | self includesSelector: each in: aClass]! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
instanceVariables: anObject
	instanceVariables := anObject! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
instanceVariablesFor: aClass 
	| vars name |
	vars := Set new.
	name := aClass name.
	vars
		addAll: (instanceVariables at: name ifAbsent: [#()]);
		addAll: (instanceVariableReaders at: name ifAbsent: [#()]);
		addAll: (instanceVariableWriters at: name ifAbsent: [#()]).
	^vars! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
removeClass: aClass classVariable: aSymbol 
	| vars |
	vars := classVariables at: aClass name ifAbsent: [Set new].
	vars remove: aSymbol ifAbsent: [].
	vars ifEmpty: [classVariables removeKey: aClass name ifAbsent: []].
	self flushCachesFor: aClass! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
removeClass: aClass instanceVariable: aString 
	| vars |
	vars := instanceVariables at: aClass name ifAbsent: [Set new].
	vars remove: aString ifAbsent: [].
	vars ifEmpty: [instanceVariables removeKey: aClass name ifAbsent: []].
	self flushCachesFor: aClass! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
selectorCache

	^ selectorCache ifNil: [ selectorCache := Dictionary new ] ifNotNil: [ selectorCache ]! !

!RBVariableEnvironment methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream
		nextPut: $(;
		nextPutAll: self class name;
		nextPutAll: ' new '.
	self accessorMethods do: [ :each | 
		aStream
			nextPutAll: each;
			nextPutAll: ': '.
		(self perform: each) storeOn: aStream.
		aStream nextPutAll: '; '].
	aStream nextPutAll: 'yourself)'! !

!RBVariableEnvironment methodsFor: 'accessing' stamp: ''!
removeClass: aClass instanceVariableWriter: aString 
	| vars |
	vars := instanceVariableWriters at: aClass name ifAbsent: [Set new].
	vars remove: aString ifAbsent: [].
	vars ifEmpty: [instanceVariableWriters removeKey: aClass name ifAbsent: []].
	self flushCachesFor: aClass! !

!RBVariableEnvironment methodsFor: 'private' stamp: ''!
instanceVariableSelectorsFor: aClass 
	| selectors |
	selectors := Set new.
	#(#instanceVariables #instanceVariableReaders #instanceVariableWriters) 
		with: #(#whichSelectorsAccess: #whichSelectorsRead: #whichSelectorsWrite:)
		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: 'accessing' stamp: ''!
removeClass: aClass instanceVariableReader: aString 
	| vars |
	vars := instanceVariableReaders at: aClass name ifAbsent: [Set new].
	vars remove: aString ifAbsent: [].
	vars ifEmpty: [instanceVariableReaders removeKey: aClass name ifAbsent: []].
	self flushCachesFor: aClass! !

!RBVariableEnvironment class methodsFor: 'instance creation' stamp: ''!
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 whichSelectorsWrite: aString) isEmpty
				ifFalse: [newEnv addClass: cls instanceVariableWriter: aString]].
	^newEnv! !

!RBVariableEnvironment class methodsFor: 'instance creation' stamp: ''!
on: anEnvironment referencesToInstanceVariable: aString in: aClass 
	| newEnv |
	newEnv := (self onEnvironment: anEnvironment)
				label: 'References to ''' , aString , ''' in ' , aClass name;
				yourself.
	(aClass whichClassDefinesInstVar: aString) withAllSubclassesDo: 
			[:cls | 
			((cls whichSelectorsRead: aString) isEmpty not 
				or: [(cls whichSelectorsWrite: aString) isEmpty not]) 
					ifTrue: [newEnv addClass: cls instanceVariable: aString]].
	^newEnv! !

!RBVariableEnvironment class methodsFor: 'instance creation' stamp: ''!
on: anEnvironment readersOfInstanceVariable: aString in: aClass 
	| newEnv |
	newEnv := (self onEnvironment: anEnvironment)
				label: 'Readers of ''' , aString , ''' in ' , aClass name;
				yourself.
	(aClass whichClassDefinesInstVar: aString) withAllSubclassesDo: 
			[:cls | 
			(cls whichSelectorsRead: aString) isEmpty
				ifFalse: [newEnv addClass: cls instanceVariableReader: aString]].
	^newEnv! !

!RBVariableEnvironment class methodsFor: 'instance creation' stamp: ''!
writersOfInstanceVariable: aString in: aClass 
	^ self
		on: self default
		writersOfInstanceVariable: aString 
		in: aClass ! !

!RBVariableEnvironment class methodsFor: 'instance creation' stamp: ''!
referencesToInstanceVariable: aString in: aClass 
	^ self
		on: self default 
		referencesToInstanceVariable: aString 
		in: aClass ! !

!RBVariableEnvironment class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Variables'! !

!RBVariableEnvironment class methodsFor: 'instance creation' stamp: ''!
referencesToClassVariable: aSymbol in: aClass 
	^ self 
		on: self default
		referencesToClassVariable: aSymbol 
		in: aClass ! !

!RBVariableEnvironment class methodsFor: 'instance creation' stamp: ''!
readersOfInstanceVariable: aString in: aClass 
	^ self
		on: self default
		readersOfInstanceVariable: aString
		in: aClass! !

!RBVariableEnvironment class methodsFor: 'instance creation' stamp: ''!
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) notEmpty or:[ (cls classSide whichSelectorsReferTo: assoc) notEmpty]) 
				ifTrue: [newEnv addClass: cls classVariable: aSymbol]].
	^newEnv! !

!RBVariableNode commentStamp: ''!
RBVariableNode is an AST node that represents a variable (global, inst var, temp, etc.).

Although this is the basic class for the concrete variable types, this is not an abstract class and is actually used
by the parser for all variables that aren't special builtin types like self/super/thisContext. All other variables are
just RBVariableNodes until the semantic analyser can deduce the type.

Instance Variables:
	name	<RBValueToken>	the variable's name I represent
	nameStart <Integer>	the position where I was found at the source code
!
!RBVariableNode methodsFor: 'comparing' stamp: ''!
hash
	^self name hash! !

!RBVariableNode methodsFor: '*NECompletion' stamp: ''!
entriesSpecialVariables
	^ #('self' 'super' 'thisContext' 'nil' 'false' 'true')
			select: [ :each | each beginsWith: self name ]
			thenCollect: [ :each | NECSpecialVariableEntry contents: each node: self ]! !

!RBVariableNode methodsFor: 'replacing' stamp: ''!
replaceSourceWith: aNode
	self addReplacement: (RBStringReplacement 
				replaceFrom: self start
				to: self stop
				with: aNode formattedCode)! !

!RBVariableNode methodsFor: 'accessing' stamp: ''!
startForReplacement
	"Return the start of the variable,  taking into account characters before the variable.
	This method is used when unused temporary variables are removed"
	| src t |
	src := self source.
	t := self start - 1.
	[ (src at: t) isSeparator ] whileTrue: [ t := t - 1 ].
	^ t + 1! !

!RBVariableNode methodsFor: '*NECompletion' stamp: ''!
globalEntries
	^ Smalltalk globals keys 
			select: [ :each | each beginsWith: self name ]
			thenCollect: [ :each | NECGlobalEntry contents: each  node: self ]! !

!RBVariableNode methodsFor: 'initialization' stamp: ''!
named: aName start: aPosition

	self name: aName.
	self start: aPosition.! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isWrite
	^ self parent notNil and: [ self parent isAssignment and: [ self parent variable == self ] ]! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isLocalVariable
	"returns true for temporary variables and arguments"
	^variable isLocalVariable! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isRead
	^ self isWrite not and: [ self isUsed ]! !

!RBVariableNode methodsFor: '*OpalCompiler-Core' stamp: ''!
isClean
	^ (self isInstanceVariable | self isSelfVariable | self isSuperVariable) not! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
needsParenthesis
	^false! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isUndeclaredVariable

	^variable isUndeclaredVariable! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isArgumentVariable
	^variable isArgumentVariable! !

!RBVariableNode methodsFor: 'accessing' stamp: ''!
startWithoutParentheses
	^ start! !

!RBVariableNode methodsFor: 'comparing' stamp: ''!
equalTo: anObject withMapping: aDictionary 
	^self class = anObject class and: 
			[(aDictionary at: self name ifAbsentPut: [anObject name]) = anObject name]! !

!RBVariableNode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	variable := UnresolvedVariable instance.
	name := ''.
	start := 0! !

!RBVariableNode methodsFor: '*NECompletion' stamp: ''!
poolVarEntriesForClass: lookupClass
	^ (lookupClass allSharedPools flatCollect: [ :each | each classVarNames ])
			select: [ :each | each beginsWith: self name ]
			thenCollect: [ :each | NECClassVarEntry contents: each node: self ]! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isDefinedByBlock
	"true if a variable node is defined by a block"
	^variable isDefinedByBlock! !

!RBVariableNode methodsFor: '*NECompletion' stamp: ''!
tempEntriesForMethodNode: aMethodNode
	^ aMethodNode temporaryNames
		select: [ :each | each beginsWith: self name ]
		thenCollect: [ :each | NECLocalEntry contents: each node: self ]! !

!RBVariableNode methodsFor: '*OpalCompiler-Core' stamp: ''!
variable
	^variable! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isThisContextVariable
	^variable isThisContextVariable! !

!RBVariableNode methodsFor: '*OpalCompiler-Core' stamp: ''!
binding
	^self variable! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isVariable
	^true! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isInstanceVariable
	^variable isInstanceVariable! !

!RBVariableNode methodsFor: 'accessing' stamp: ''!
precedence
	^0! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isSuperVariable
	^ variable isSuperVariable! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isSelfOrSuperVariable
	^ variable isSelfOrSuperVariable! !

!RBVariableNode methodsFor: 'accessing' stamp: ''!
stopWithoutParentheses
	^ start + name size - 1.! !

!RBVariableNode methodsFor: 'comparing' stamp: ''!
= anObject 
	self == anObject ifTrue: [^true].
	((anObject isKindOf: self class) or: [self isKindOf: anObject class]) 
		ifFalse: [^false].
	^self name = anObject name! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isImmediateNode
	^true! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isWorkspaceVariable
	^ variable isWorkspaceVariable! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isClassVariable
	^variable isClassVariable! !

!RBVariableNode methodsFor: 'replacing' stamp: ''!
replaceSourceFrom: aNode 
	self addReplacement: (RBStringReplacement 
				replaceFrom: aNode start
				to: aNode stop
				with: self name)! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isSelfVariable
	^variable isSelfVariable! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isTempVariable
	^variable isTempVariable! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
hasIncompleteIdentifier
	"check if there is any variable declared in my scope that starts with my name"

	"declared vars are never incomplete"
	variable isUndeclaredVariable ifFalse: [ ^false ].
	"for the others we have to search from the current scope"
	^self scope hasBindingThatBeginsWith: self name! !

!RBVariableNode methodsFor: 'accessing' stamp: ''!
name: aName
	name := aName asSymbol.! !

!RBVariableNode methodsFor: '*OpalCompiler-Core' stamp: ''!
binding: aSemVar
	self variable: aSemVar! !

!RBVariableNode methodsFor: '*OpalCompiler-Core' stamp: ''!
variable: aSemVar
	variable := aSemVar! !

!RBVariableNode methodsFor: '*NECompletion' stamp: ''!
completionToken: offset

	^ self name! !

!RBVariableNode methodsFor: '*NECompletion' stamp: ''!
argEntriesForMethodNode: aMethodNode
	^ aMethodNode argumentNames
		select: [ :each | each beginsWith: self name ]
		thenCollect: [ :each | NECLocalEntry contents: each node: self ]! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isLiteralVariable
	^variable isLiteralVariable! !

!RBVariableNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ variable acceptVisitor: aProgramNodeVisitor node: self! !

!RBVariableNode methodsFor: '*NECompletion' stamp: ''!
possibleSelectorEntries
	^ Symbol allSymbols
		select: [ :each | (each beginsWith: self name) and: [ each contents numArgs = 0 ] ]
		thenCollect: [ :each | NECSymbolEntry contents: each node: self ]! !

!RBVariableNode methodsFor: '*NECompletion' stamp: ''!
completionEntries: offset
	| methodNode lookupClass |
	methodNode := self methodNode.
	lookupClass := methodNode compilationContext getClass.
	self isDefinition
		ifTrue: [ ^ self possibleSelectorEntries ].
	
	^ Array streamContents: [ :str | 
		str 
			nextPutAll: (self globalEntries);
			nextPutAll: (self slotEntriesForClass: lookupClass);
			nextPutAll: (self tempEntriesForMethodNode: methodNode);
			nextPutAll: (self argEntriesForMethodNode: methodNode);
			nextPutAll: (self entriesSpecialVariables);
			nextPutAll: (self classVarEntriesForClass: lookupClass);
			nextPutAll: (self poolVarEntriesForClass: lookupClass) ]! !

!RBVariableNode methodsFor: '*Reflectivity' stamp: ''!
variableValueInContext: aContext
	^ variable readInContext: aContext! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
references: aVariableName 
	^self name = aVariableName! !

!RBVariableNode methodsFor: '*NECompletion' stamp: ''!
slotEntriesForClass: lookupClass
	^lookupClass 
		allSlots select: [ :each | each name beginsWith: self name ]
		thenCollect: [ :each | NECInstVarEntry contents: each name node: self ]! !

!RBVariableNode methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isReservedVariable
	^ variable isReservedVariable! !

!RBVariableNode methodsFor: '*NECompletion' stamp: ''!
classVarEntriesForClass: lookupClass
	^ lookupClass allClassVarNames
		select: [ :each | each beginsWith: self name ]
		thenCollect: [ :each | NECClassVarEntry contents: each node: self ]! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isDefinition
	"Check if I am a Variable defintion"
	^variable definingNode == self! !

!RBVariableNode methodsFor: 'accessing' stamp: ''!
start
	^ start! !

!RBVariableNode methodsFor: 'accessing' stamp: ''!
start: aPosition
	start := aPosition! !

!RBVariableNode methodsFor: 'testing' stamp: ''!
isGlobalVariable
	^variable isGlobalVariable! !

!RBVariableNode methodsFor: 'matching' stamp: ''!
copyInContext: aDictionary 
	^ self class named: name.! !

!RBVariableNode class methodsFor: 'instance creation' stamp: ''!
superNode
	^ (self named: 'super') variable: SuperVariable instance! !

!RBVariableNode class methodsFor: 'instance creation' stamp: ''!
selfNode
	^ (self named: 'self') variable: SelfVariable instance! !

!RBVariableNode class methodsFor: 'instance creation' stamp: ''!
named: aName
	^ self named: aName start: 0! !

!RBVariableNode class methodsFor: 'instance creation' stamp: ''!
named: aName start: aPosition
	^self new 
		named: aName start: aPosition; 
		yourself.! !

!RBVariableNode class methodsFor: 'instance creation' stamp: ''!
thisContextNode
	^ (self named: 'thisContext') variable: ThisContextVariable instance! !

!RBVariableNode class methodsFor: 'instance creation' stamp: ''!
identifierNamed: anIdentifierName at: aPosition
	
	anIdentifierName = 'self'
		ifTrue: [ ^ self selfNode named: anIdentifierName start: aPosition ].
	anIdentifierName = 'thisContext'
		ifTrue: [ ^ self thisContextNode named: anIdentifierName start: aPosition ].
	anIdentifierName = 'super'
		ifTrue: [ ^ self superNode named: anIdentifierName start: aPosition ].
	^ self named: anIdentifierName start: aPosition.! !

!RBVariableNodeTest commentStamp: ''!
SUnit tests for RBVariableNode!
!RBVariableNodeTest methodsFor: 'tests' stamp: ''!
testIsDefinition
	| ast temps |
	ast := self class compiler
		parse:
			'myMethod: arg
  | test |
  test := 2.
  test.
  ^test'.
	temps := ast allChildren select: [:each | each isTempVariable].
	
	"arguments define variables"
	self assert: ast arguments first isDefinition.
	"this is the || definition"
	self assert: temps first isDefinition.
	"all the rest are just uses"
	self deny: temps second isDefinition.
	self deny: temps third isDefinition.
	self deny: temps fourth isDefinition! !

!RBVariableNodeTest methodsFor: 'tests' stamp: ''!
testStartForReplacement02

	| source tree dTemporary |
	source := 'foo
	|a b c de 
	
d|
	de := 4'.
	tree := self parseMethod: source.
	dTemporary := tree body temporaries last.
	self assert: dTemporary name equals: #d.
	self assert: (source copyFrom: dTemporary start to: dTemporary stop) equals: 'd'.
	self assert: (source copyFrom: dTemporary startForReplacement to: dTemporary stop) equals: ' 
	
d'.
	self assert: (dTemporary start - dTemporary startForReplacement) equals: 4! !

!RBVariableNodeTest methodsFor: 'tests' stamp: ''!
testStartForReplacement

	| source tree dTemporary |
	source := 'foo
	|a b c de d|
	de := 4'.
	tree := self parseMethod: source.
	dTemporary := tree body temporaries last.
	self assert: dTemporary name equals: #d.
	self assert: (source copyFrom: dTemporary start to: dTemporary stop) equals: 'd'.
	self assert: (source copyFrom: dTemporary startForReplacement to: dTemporary stop) equals: ' d'.
	self assert: (dTemporary start - dTemporary startForReplacement) equals: 1! !

!RBVariableNodeTest methodsFor: 'tests' stamp: ''!
testIsDefinedByBlock

	| ast temps args |
	ast := self class compiler parse: 'myMethod: arg
  | test |
  test := 2.
  test.
	[ :test2 | | test3| test2. test3].
  ^test'.
	temps := ast allChildren select: [ :each | each isTempVariable ].
	"test is defined by the method"
	self deny: temps first isDefinedByBlock.
	self deny: temps second isDefinedByBlock.
	self deny: temps third isDefinedByBlock.

	"test3 definition"
	self assert: ast blockNodes first arguments first isDefinedByBlock.
	"test3 definition"
	self assert: temps fourth isDefinedByBlock.
	"test 3 use"
	self assert: temps fifth isDefinedByBlock.
	"and we are out if the block"
	self deny: temps sixth isDefinedByBlock.

	args := ast allChildren select: [ :each | each isArgumentVariable ].
	"method arg"
	self deny: args first isDefinedByBlock.
	self assert: args second isDefinedByBlock.
	"use of test3"
	self assert: args third isDefinedByBlock! !

!RBVariableRefactoring commentStamp: ''!
I am an abstract base class of refactorings modifying class or instance variables.!
!RBVariableRefactoring methodsFor: 'initialization' stamp: ''!
variable: aVarName class: aClass 
	class := self classObjectFor: aClass.
	variableName := aVarName! !

!RBVariableRefactoring methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' variable: '.
	variableName storeOn: aStream.
	aStream nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream nextPut: $)! !

!RBVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
model: aRBSmalltalk variable: aVarName class: aClass 
	^ self new
		model: aRBSmalltalk;
		variable: aVarName class: aClass;
		yourself! !

!RBVariableRefactoring class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RBVariableRefactoring! !

!RBVariableRefactoring class methodsFor: 'instance creation' stamp: ''!
variable: aVarName class: aClass
	^ self new
		variable: aVarName class: aClass! !

!RBVariableTransformation methodsFor: 'accessing' stamp: ''!
definingClass

	^ isClassVariable 
		ifTrue: [ super definingClass theMetaClass ]
		ifFalse: [ super definingClass ]! !

!RBVariableTransformation methodsFor: 'api' stamp: ''!
variable: aVariableName class: aClassName classVariable: aBoolean

	self className: aClassName.
	variableName := aVariableName.
	isClassVariable := aBoolean.! !

!RBVariableTransformation methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $(.
	self class storeOn: aStream.
	aStream nextPutAll: ' variable: '.
	variableName storeOn: aStream.
	aStream nextPutAll: ' class: '.
	class storeOn: aStream.
	aStream nextPutAll: ' classVariable: '.
	isClassVariable storeOn: aStream.
	aStream nextPut: $)! !

!RBVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel classVariable: aVariableName class: aClassName

	^ self new
		model: aRBModel;
		variable: aVariableName
		class: aClassName
		classVariable: true;
		yourself! !

!RBVariableTransformation class methodsFor: 'api' stamp: ''!
instanceVariable: aVariableName class: aClassName

	^ self new
		variable: aVariableName
		class: aClassName
		classVariable: false;
		yourself! !

!RBVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel variable: aVariableName class: aClassName classVariable: aBoolean

	^ self new
		model: aRBModel;
		variable: aVariableName
		class: aClassName
		classVariable: aBoolean;
		yourself! !

!RBVariableTransformation class methodsFor: 'api' stamp: ''!
variable: aVariableName class: aClassName classVariable: aBoolean

	^ self new
		variable: aVariableName
		class: aClassName
		classVariable: aBoolean;
		yourself! !

!RBVariableTransformation class methodsFor: 'api' stamp: ''!
classVariable: aVariableName class: aClassName

	^ self new
		variable: aVariableName
		class: aClassName
		classVariable: true;
		yourself! !

!RBVariableTransformation class methodsFor: 'api' stamp: ''!
model: aRBModel instanceVariable: aVariableName class: aClassName

	^ self new
		model: aRBModel;
		variable: aVariableName
		class: aClassName
		classVariable: false;
		yourself! !

!RBVariableTypeTest methodsFor: 'tests' stamp: ''!
testLintRuleTypes
	| typer types |
	typer := RBRefactoryTyper new.
	types := typer 
		guessTypesFor: 'name'
		in: RBLintRuleTestData.
	self assert: types size equals: 1.
	self assert: (types includes: (typer model classFor: String))! !

!RBVariableTypeTest methodsFor: 'tests' stamp: ''!
testBasicLintRuleTypes
	| typer types |
	typer := RBRefactoryTyper new.
	types := typer 
		guessTypesFor: 'classBlock'
		in: RBBasicLintRuleTestData.
	"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: RBBasicLintRuleTestData).
	"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: ''!
testCompositeLintRuleTypes
	| typer types |
	typer := RBRefactoryTyper new runOn: RBCompositeLintRuleTestData.
	types := typer guessTypesFor: 'rules'.
	self assert: (types includes: (typer model classFor: Collection)).
	types := typer typesFor: '-rules-'.
	self assert: (types includes: (typer model classFor: RBLintRuleTestData)).
	self assertEmpty: (typer guessTypesFor: 'asdf').
	typer printString! !

!RBVariableTypeTest methodsFor: 'tests' stamp: ''!
testParseTreeTypes
	| types model |
	model := RBClassModelFactory rbNamespace new.
	types := RBRefactoryTyper 
				typesFor: 'foo'
				in: (self 
						parseExpression: 'foo printString; testBasicLintRuleTypes; testParseTreeTypes')
				model: model.
	self assert: types size equals: 1.
	self assert: (types includes: (model classFor: self class))! !

!RBVariablesSelectionPresenter commentStamp: ''!
I am preview to select variables (Class Variable) !
!RBVariablesSelectionPresenter methodsFor: 'attributes' stamp: ''!
columnName
	^ 'Variables'! !

!RBVariablesSelectionPresenter methodsFor: 'attributes' stamp: ''!
columnSelector 
	^ #name! !

!RBVariablesSelectionPresenter class methodsFor: 'examples' stamp: ''!
example
	<script>
	^ (self label: 'example ...' 
		withItems: 
			{(ClassVariable named: #a) . (ClassVariable named: #b) . (ClassVariable named: #z) } asOrderedCollection 
		selecting: {(ClassVariable named: #z) . (ClassVariable named: #a) } asOrderedCollection )! !

!RBVariablesSelectionPresenter class methodsFor: 'specs' stamp: ''!
title 
	^ 'Class variables'! !

!RBWithDifferentConstructorsParametrizedTest methodsFor: 'builder' stamp: ''!
createRefactoringWithModel: rbNamespace andArguments: aParameterCollection
	^ (rbClass
		perform: #model: , constructor 
		withArguments: {rbNamespace}, aParameterCollection) asRefactoring! !

!RBWithDifferentConstructorsParametrizedTest methodsFor: 'builder' stamp: ''!
createRefactoringWithArguments: aParameterCollection
	^ (rbClass
		perform: constructor 
		withArguments: aParameterCollection) asRefactoring! !

!RBWithDifferentConstructorsParametrizedTest methodsFor: 'parameterization' stamp: ''!
constructor: anObject

	constructor := anObject! !

!RBWithDifferentsArgumentsParametrizedTest methodsFor: 'builder' stamp: ''!
createRefactoringWithModel: rbNamespace andArguments: aParameterCollection
	^ (rbClass
		perform: #model: , constructor 
		withArguments: {rbNamespace}, 
			(self selectIndex: index of: aParameterCollection)) asRefactoring! !

!RBWithDifferentsArgumentsParametrizedTest methodsFor: 'builder' stamp: ''!
createRefactoringWithArguments: aParameterCollection
	^ (rbClass
		perform: constructor 
		withArguments: (self selectIndex: index of: aParameterCollection)) asRefactoring! !

!RBWithDifferentsArgumentsParametrizedTest methodsFor: 'accessing' stamp: ''!
selectIndex: anInteger of: aCollection
	^ aCollection collect: [ :each | each isArray ifTrue: [each at: anInteger ] ifFalse: each ]! !

!RBWithDifferentsArgumentsParametrizedTest methodsFor: 'accessing' stamp: ''!
index: aBlock 

	index := aBlock! !

!RFASTClosureAnalyzer commentStamp: ''!
We need to analyse the #after hook: it is a block!
!RFASTClosureAnalyzer methodsFor: 'visiting' stamp: ''!
visitNode: aNode
	super visitNode: aNode.
	"if we have any hooks defined --> visit them to do name analysis"
	aNode beforeHooks do: [:each | super visitNode: each].
	aNode insteadHooks do: [:each | super visitNode: each].
	aNode afterHooks do: [:each | super visitNode: each].! !

!RFASTTranslator commentStamp: ''!
subclass of Opal that takes links into account!
!RFASTTranslator methodsFor: 'reflectivity' stamp: ''!
emitMetaLinkInstead: aNode
	valueTranslator visitNode: aNode insteadHooks.! !

!RFASTTranslator methodsFor: 'initialization' stamp: ''!
classForValue
	^RFASTTranslatorForValue! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitBlockNode: aBlockNode
	| compiledBlock |
	aBlockNode arguments size >15 ifTrue: [self backendError: 'Too many arguments' forNode: aBlockNode ].
	aBlockNode isInlined ifTrue: [^ self visitInlinedBlockNode: aBlockNode ].

	self emitPreamble: aBlockNode.
	self emitMetaLinkBefore: aBlockNode.


	aBlockNode hasMetalinkInstead
				ifTrue: [ self emitMetaLinkInstead: aBlockNode ]
				ifFalse: [  
	compiledBlock := self compilationContext astTranslatorClass new translateFullBlock: aBlockNode.	
	(self compilationContext optionCleanBlockClosure and: [ aBlockNode isClean ])
		ifTrue: [ methodBuilder pushLiteral: ((CleanBlockClosure new: 0) numArgs: compiledBlock numArgs; compiledBlock: compiledBlock)]
		ifFalse: [methodBuilder pushFullClosureCompiledBlock: compiledBlock copiedValues: aBlockNode scope inComingCopiedVarNames  ].
	].
	self emitMetaLinkAfterNoEnsure: aBlockNode.! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitLiteralArrayNode: aRBLiteralArrayNode
	self emitPreamble: aRBLiteralArrayNode.
	self emitMetaLinkBefore: aRBLiteralArrayNode.
	aRBLiteralArrayNode hasMetalinkInstead
		ifTrue: [ self emitMetaLinkInstead: aRBLiteralArrayNode ]
		ifFalse: [ methodBuilder pushLiteral: aRBLiteralArrayNode value ].
	self emitMetaLinkAfterNoEnsure: aRBLiteralArrayNode.
	
! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitSequenceWithAfter: aSequenceNode
	| wrappedBlock compiledBlock |
	wrappedBlock := RBBlockNode body: (RBSequenceNode statements: aSequenceNode statements).
	wrappedBlock parent: aSequenceNode.
	wrappedBlock scope: (aSequenceNode parent scope newBlockScope: 20).
	 (aSequenceNode parent scope copiedVars, aSequenceNode parent scope tempVars) do: [ :var |
		wrappedBlock scope addCopyingTempToAllScopesUpToDefTemp: var].
	
	compiledBlock := self compilationContext astTranslatorClass new translateFullBlock: wrappedBlock.
	methodBuilder pushFullClosureCompiledBlock: compiledBlock copiedValues: wrappedBlock scope copiedVarNames.
	self emitMetaLinkAfterEnsure: aSequenceNode.! !

!RFASTTranslator methodsFor: 'reflectivity' stamp: ''!
emitPreamble: aNode
	aNode preambles do: [ :pre | valueTranslator visitNode: pre].! !

!RFASTTranslator methodsFor: 'reflectivity' stamp: ''!
emitMetaLinkBefore: aNode
	aNode hasMetalinkBefore ifFalse: [ ^self ].
	aNode beforeHooks do: [ :hook | effectTranslator visitNode: hook ].! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitReturnNode: aReturnNode 

	valueTranslator visitNode: aReturnNode value.
	self emitPreamble: aReturnNode.
	self emitMetaLinkBefore: aReturnNode.
	aReturnNode hasMetalinkInstead
		ifTrue: [ self emitMetaLinkInstead: aReturnNode ]
		ifFalse: [ methodBuilder returnTop ].

		
! !

!RFASTTranslator methodsFor: 'reflectivity' stamp: ''!
visitStorePopIntoTempNode: aNode
	"we store the TOS into the temp defined by the reification node"

	aNode binding emitStore: methodBuilder.
	methodBuilder popTop.! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitAssignmentNode: anAssignmentNode 
	valueTranslator visitNode: anAssignmentNode value.
	self emitPreamble: anAssignmentNode.
	self emitMetaLinkBefore: anAssignmentNode.
	self emitPreamble: anAssignmentNode variable.
	self emitMetaLinkBefore: anAssignmentNode variable.
	
	anAssignmentNode hasMetalinkInstead
				ifTrue: [ self emitMetaLinkInstead: anAssignmentNode ]
				ifFalse: [
					 anAssignmentNode variable hasMetalinkInstead
						ifTrue: [ self emitMetaLinkInstead: anAssignmentNode variable]
						ifFalse: [ anAssignmentNode variable binding emitStore: methodBuilder]].
	self emitMetaLinkAfterNoEnsure: anAssignmentNode variable.
	self emitMetaLinkAfterNoEnsure: anAssignmentNode.
	! !

!RFASTTranslator methodsFor: 'reflectivity' stamp: ''!
visitStoreIntoTempNode: aNode
	"we store the TOS into the temp defined by the reification node"

	aNode binding emitStore: methodBuilder.
! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitCascadeNode: aCascadeNode 
	valueTranslator visitNode: aCascadeNode receiver.
	
	self emitPreamble: aCascadeNode.
	self emitMetaLinkBefore: aCascadeNode.
	aCascadeNode hasMetalinkInstead
		ifTrue: [ self emitMetaLinkInstead: aCascadeNode ]
		ifFalse: [  
			aCascadeNode messages allButLastDo: [:node |
				methodBuilder pushDup.
				effectTranslator visitNode: node.
			].
				self visitNode: aCascadeNode messages last.].
	self emitMetaLinkAfterNoEnsure: aCascadeNode.! !

!RFASTTranslator methodsFor: 'reflectivity' stamp: ''!
emitMetaLinkAfterEnsure: aNode
	| ensureBlock compiledBlock |
	
	"this saves the value from top of stack, executed [operation <here>] ensure: [ afterhook ] "
	aNode postambles do: [ :each | valueTranslator visitNode: each ].
	ensureBlock := RBBlockNode body: (RBSequenceNode statements: aNode afterHooks).
	
	ensureBlock parent: aNode.
	ensureBlock scope: (aNode parent scope newBlockScope: 20).
	(aNode parent scope copiedVars, aNode parent scope tempVars) do: [ :var |
		ensureBlock scope addCopyingTempToAllScopesUpToDefTemp: var].
	
	compiledBlock := self compilationContext astTranslatorClass new translateFullBlock: ensureBlock.
	methodBuilder pushFullClosureCompiledBlock: compiledBlock copiedValues: ensureBlock scope copiedVarNames.
	methodBuilder send: #ensure:.! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitLiteralNode: aLiteralNode
	self emitPreamble: aLiteralNode.
	self emitMetaLinkBefore: aLiteralNode.
	aLiteralNode hasMetalinkInstead
		ifTrue: [ self emitMetaLinkInstead: aLiteralNode ]
		ifFalse: [ methodBuilder pushLiteral: aLiteralNode value ].
	self emitMetaLinkAfterNoEnsure: aLiteralNode.

	
! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitMethodNode: aMethodNode
	"I ignore all links when I am primitive as ReflectiveMethod compiles a wrapper"
	
	aMethodNode arguments size > 15 ifTrue: [self backendError: 'Too many arguments' forNode: aMethodNode ].
	
	methodBuilder compilationContext: aMethodNode compilationContext.
	methodBuilder addTemps: aMethodNode scope tempVarNames.
	
	aMethodNode isPrimitive ifFalse: [self emitPreamble: aMethodNode. self emitMetaLinkBefore: aMethodNode].

	methodBuilder properties: aMethodNode methodProperties.
	methodBuilder irPrimitive: aMethodNode primitiveFromPragma.
	aMethodNode pragmas do: [:each | self visitPragmaNode: each].
	methodBuilder numArgs: aMethodNode arguments size.
	
	(aMethodNode hasMetalinkInstead and: [ aMethodNode isPrimitive not ])
				ifTrue: [ self emitMetaLinkInstead: aMethodNode. methodBuilder returnTop.
						^self. ].
				
	aMethodNode scope tempVector ifNotEmpty: [
		methodBuilder 
			createTempVectorNamed: aMethodNode scope tempVectorName 
			withVars: aMethodNode scope tempVectorVarNames.
	].
	effectTranslator visitNode: aMethodNode body.
	aMethodNode isPrimitive ifFalse: [self emitMetaLinkAfterNoEnsure: aMethodNode].
	(aMethodNode hasProperty: #wrappedPrimitive) ifTrue: [methodBuilder pushTemp: #RFReifyValueVar; returnTop].
	aMethodNode body lastIsReturn ifFalse:  [methodBuilder pushReceiver; returnTop].
! !

!RFASTTranslator methodsFor: 'initialization' stamp: ''!
classForEffect
	^RFASTTranslatorForEffect! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitArrayNode: anArrayNode 

	| elementNodes |
	
	anArrayNode statements size > 32 ifTrue: [^ self visitLargeArrayNode: anArrayNode ].
	
	elementNodes := anArrayNode children.
	elementNodes do: [:node | valueTranslator visitNode: node].
	self emitPreamble: anArrayNode.
	self emitMetaLinkBefore: anArrayNode.
	anArrayNode hasMetalinkInstead
		ifTrue: [ self emitMetaLinkInstead: anArrayNode ]
		ifFalse: [ methodBuilder pushConsArray: elementNodes size ].
	self emitMetaLinkAfterNoEnsure: anArrayNode.
! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
emitMessageNode: aMessageNode

	(aMessageNode isCascaded and: [(aMessageNode hasProperty: #hook) not])
		ifFalse: [ valueTranslator visitNode: aMessageNode receiver ].
	aMessageNode arguments do: [ :each | valueTranslator visitNode: each ].
	self emitPreamble: aMessageNode.
	self emitMetaLinkBefore: aMessageNode.
	aMessageNode hasMetalinkInstead
		ifTrue: [ self emitMetaLinkInstead: aMessageNode ]
		ifFalse: [ 
			aMessageNode isSuperSend
				ifTrue: [ methodBuilder send: aMessageNode selector toSuperOf: self compilationContext getClass ]
				ifFalse: [ methodBuilder send: aMessageNode selector ] ].
	self emitMetaLinkAfterNoEnsure: aMessageNode.! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitInlinedBlockNode: anOptimizedBlockNode

	"We are visiting a scope that is not a block, but inlined in the outer context.
	This means: 
			- we do not create a Block
			- we call IRBuilder to add temps
	"
	
	methodBuilder mapToNode: anOptimizedBlockNode.
	anOptimizedBlockNode scope tempVector ifNotEmpty: [
		methodBuilder 
			createTempVectorNamed: anOptimizedBlockNode scope tempVectorName 
			withVars: anOptimizedBlockNode scope tempVectorVarNames.
	].
	methodBuilder addTemps: anOptimizedBlockNode scope tempVarNamesWithoutArguments.
	methodBuilder addTemps: anOptimizedBlockNode scope inComingCopiedVarNames.
	methodBuilder addTemps: anOptimizedBlockNode argumentNames.
	anOptimizedBlockNode isInlinedLoop ifTrue: [
		anOptimizedBlockNode scope tempVarNamesWithoutArguments do: [ :tempName |
			methodBuilder pushLiteral: nil.
			methodBuilder storeTemp: tempName.
			methodBuilder popTop.
		 ]].
	self emitPreamble: anOptimizedBlockNode.
	self emitMetaLinkBefore: anOptimizedBlockNode.
	self visitNode: anOptimizedBlockNode body.
	self emitMetaLinkAfterNoEnsure: anOptimizedBlockNode.
	methodBuilder popMap.! !

!RFASTTranslator methodsFor: 'reflectivity' stamp: ''!
emitMetaLinkAfterNoEnsure: aNode

	aNode hasMetalinkAfter ifFalse: [ ^self ].
	aNode postambles do: [ :each | valueTranslator visitNode: each ].
	aNode afterHooks do: [ :each | effectTranslator visitNode: each ].! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitMessageNode: aMessageNode

	aMessageNode isInlined
		ifTrue: [ 
			methodBuilder addLiteral: aMessageNode selector. "so searching for senders will work"
			self emitPreamble: aMessageNode.
			self emitMetaLinkBefore: aMessageNode.
			aMessageNode hasMetalinkInstead
				ifTrue: [ self emitMetaLinkInstead: aMessageNode ]
				ifFalse: [ 
					self
						perform: (OptimizedMessages at: aMessageNode selector)
						with: aMessageNode ].
			self emitMetaLinkAfterNoEnsure: aMessageNode ]
		ifFalse: [ self emitMessageNode: aMessageNode ]! !

!RFASTTranslator methodsFor: 'visitor - double dispatching' stamp: ''!
visitVariableNode: aVariableNode
	self emitPreamble: aVariableNode.
	self emitMetaLinkBefore: aVariableNode.
	aVariableNode hasMetalinkInstead
				ifTrue: [ self emitMetaLinkInstead: aVariableNode ]
				ifFalse: [ self visitVariableValue: aVariableNode binding].
	self emitMetaLinkAfterNoEnsure: aVariableNode.
	
	! !

!RFASTTranslator methodsFor: 'reflectivity' stamp: ''!
visitVariableValue: aVariable
	self emitPreamble: aVariable. 
	self emitMetaLinkBefore: aVariable. 
	aVariable hasMetalinkInstead 
		ifTrue: [self emitMetaLinkInstead: aVariable]
		ifFalse: [aVariable emitValue: methodBuilder].
	self emitMetaLinkAfterNoEnsure: aVariable.! !

!RFASTTranslatorForEffect commentStamp: ''!
WORKAROUND: copy of OCASTTranslatorForEffect

Will be removed when the new Translor design is in place!
!RFASTTranslatorForEffect methodsFor: 'inline messages' stamp: ''!
emitIfTrue: aMessageNode

	valueTranslator visitNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #else if: false.	
		self visitInlinedBlockNode: aMessageNode arguments first.
	methodBuilder jumpAheadTarget: #else.! !

!RFASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitBlockNode: aBlockNode 
	"even though the code is never executed, we generate it to make sure that we 
	can map bytecode and access temps"
	super visitBlockNode: aBlockNode.
	methodBuilder popTop! !

!RFASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitLiteralArrayNode: aLiteralNode
	"when visiting a literal array for effect, we could push it and then pop it, but we do nothing"
	methodBuilder addLiteral: aLiteralNode value! !

!RFASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitSequenceNode: aSequenceNode
	
	self emitPreamble: aSequenceNode.
	self emitMetaLinkBefore: aSequenceNode.
		
	aSequenceNode hasMetalinkAfter ifTrue: [ ^ self visitSequenceWithAfter: aSequenceNode  ].
	
	aSequenceNode hasMetalinkInstead
		ifTrue: [ self emitMetaLinkInstead: aSequenceNode ]
		ifFalse: [ aSequenceNode statements do: [:each | self visitNode: each]. ].
	aSequenceNode hasMetalinkInstead ifTrue: [aSequenceNode parent isMethod 
			ifTrue: [methodBuilder returnTop]
			ifFalse: [methodBuilder popTop]]! !

!RFASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitAssignmentNode: anAssignmentNode 

	super visitAssignmentNode: anAssignmentNode .
	methodBuilder popTop. ! !

!RFASTTranslatorForEffect methodsFor: 'inline messages' stamp: ''!
emitOr: aMessageNode

	super emitOr: aMessageNode.
	methodBuilder popTop.! !

!RFASTTranslatorForEffect methodsFor: 'inline messages' stamp: ''!
emitAnd: aMessageNode
	
	super emitAnd: aMessageNode.
	methodBuilder popTop.! !

!RFASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitLiteralNode: aLiteralNode
	"when visiting a literal for effect, we could push it and then pop it, but we do nothing"
	methodBuilder addLiteral: aLiteralNode value! !

!RFASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitArrayNode: anArrayNode 
	"An arrayNode may have side effect, for example: '{self foo}'. So we cannot just generate nothing for this node."

	super visitArrayNode: anArrayNode.
	methodBuilder popTop.
! !

!RFASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
emitMessageNode: aMessageNode 

	super emitMessageNode: aMessageNode.
	methodBuilder popTop.
! !

!RFASTTranslatorForEffect methodsFor: 'inline messages' stamp: ''!
emitIfFalse: aMessageNode

	valueTranslator visitNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #else if: true.
		self visitInlinedBlockNode: aMessageNode arguments first.
	methodBuilder jumpAheadTarget: #else.
! !

!RFASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitParseErrorNode: anErrorNode  

	super visitParseErrorNode: anErrorNode.
	methodBuilder popTop.
! !

!RFASTTranslatorForEffect methodsFor: 'visitor - double dispatching' stamp: ''!
visitVariableNode: aVariableNode
	
	| binding |
	
	self emitPreamble: aVariableNode.
	self emitMetaLinkBefore: aVariableNode.
	
	aVariableNode hasMetalinkInstead
		ifTrue: [ self emitMetaLinkInstead: aVariableNode ].
		
	"when visiting a variable for effect, we could push it and then pop it, but we do nothing"
	binding := aVariableNode binding.
	(binding isLiteralVariable or: [ binding isUndeclaredVariable ])
		ifTrue: [ methodBuilder addLiteral: binding ].
		
	self emitMetaLinkAfterNoEnsure: aVariableNode.
! !

!RFASTTranslatorForEffect methodsFor: 'inline messages' stamp: ''!
emitIfNotNil: aMessageNode
	| args |
	valueTranslator visitNode: aMessageNode receiver.
	args := aMessageNode arguments.
	args first arguments ifNotEmpty: [ args first arguments first binding emitStore: methodBuilder ].
	methodBuilder pushLiteral: nil.
	methodBuilder send: #==.
	methodBuilder jumpAheadTo: #end if: true.
	self visitInlinedBlockNode: args first.
	methodBuilder jumpAheadTarget: #end.
	! !

!RFASTTranslatorForValue commentStamp: ''!
WORKAROUND: copy of OCASTTranslatorForValue.

Will be removed when the new Translor design is in place!
!RFASTTranslatorForValue methodsFor: 'inline messages' stamp: ''!
emitIfTrue: aMessageNode
	
	self visitNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #else if: false.
	self visitInlinedBlockNode:  aMessageNode arguments first.
	methodBuilder jumpAheadTo: #end.
	methodBuilder jumpAheadTarget: #else.
	methodBuilder pushLiteral: nil.
	methodBuilder jumpAheadTarget: #end.! !

!RFASTTranslatorForValue methodsFor: 'inline messages' stamp: ''!
emitWhileFalse: aMessageNode

	super emitWhileFalse: aMessageNode.
	methodBuilder pushLiteral: nil.
! !

!RFASTTranslatorForValue methodsFor: 'inline messages' stamp: ''!
emitWhileTrue: aMessageNode

	super emitWhileTrue: aMessageNode.
	methodBuilder pushLiteral: nil.
! !

!RFASTTranslatorForValue methodsFor: 'visitor - double dispatching' stamp: ''!
visitSequenceNode: aSequenceNode 
	| statements |
	
	self emitPreamble: aSequenceNode.
	self emitMetaLinkBefore: aSequenceNode.
	
	aSequenceNode hasMetalinkAfter ifTrue: [ ^ self visitSequenceWithAfter: aSequenceNode  ].
	
	aSequenceNode hasMetalinkInstead
		ifTrue: [ self emitMetaLinkInstead: aSequenceNode ]
		ifFalse: [ 
			statements := aSequenceNode statements.
			statements ifEmpty: [
			methodBuilder pushLiteral: nil.
			^self].
		statements allButLastDo: [:each | effectTranslator visitNode: each].
		self visitNode: statements last.
	]! !

!RFASTTranslatorForValue methodsFor: 'inline messages' stamp: ''!
emitIfFalse: aMessageNode
	
	self visitNode: aMessageNode receiver.
	methodBuilder jumpAheadTo: #false if: false.
		methodBuilder pushLiteral: nil.
		methodBuilder jumpAheadTo: #end.
		methodBuilder jumpAheadTarget: #false.
	self visitInlinedBlockNode: aMessageNode arguments first.
	methodBuilder jumpAheadTarget: #end.! !

!RFASTTranslatorForValue methodsFor: 'inline messages' stamp: ''!
emitIfNotNil: aMessageNode
	| args |
	self visitNode: aMessageNode receiver.
	args := aMessageNode arguments.
	args first arguments ifNotEmpty: [ args first arguments first binding emitStore: methodBuilder ].
	methodBuilder pushDup.
	methodBuilder pushLiteral: nil.
	methodBuilder send: #==.
	methodBuilder jumpAheadTo: #end if: true.
	methodBuilder popTop.
	self visitInlinedBlockNode: args first.
	methodBuilder jumpAheadTarget: #end.! !

!RFArgumentsReification commentStamp: ''!
reify args!
!RFArgumentsReification methodsFor: 'preamble' stamp: ''!
preambleForMethod: aNode
	| preamble arguments |
	preamble := OrderedCollection new.
	arguments := aNode argumentNames collect: [ :name | RBVariableNode named: name].
	preamble addAll: (RBArrayNode statements: arguments).
	preamble add: (RFStorePopIntoTempNode named: self varName).
	^ preamble ! !

!RFArgumentsReification methodsFor: 'generate' stamp: ''!
genForRBSequenceNode
	^RBVariableNode named: self varName.! !

!RFArgumentsReification methodsFor: 'preamble' stamp: ''!
preambleSequence: aNode
	| preamble arguments |
	preamble := OrderedCollection new.
	arguments := aNode parent argumentNames collect: [ :name | RBVariableNode named: name].
	preamble addAll: (RBArrayNode statements: arguments).
	preamble add: (RFStorePopIntoTempNode named: self varName).
	^ preamble ! !

!RFArgumentsReification methodsFor: 'generate' stamp: ''!
genForRBMessageNode
	^RBVariableNode named: self varName.! !

!RFArgumentsReification methodsFor: 'preamble' stamp: ''!
preambleForMessage: aNode
	| preamble arguments |
	preamble := OrderedCollection new.
	arguments := OrderedCollection new.

	(1 to: aNode numArgs) reverseWithIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			preamble add:  (RFStorePopIntoTempNode named: name).
	].
	
	(1 to: aNode numArgs) withIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			arguments add:  (RBVariableNode named: name).
	].
	preamble addAll: (RBArrayNode statements: arguments).
	preamble add: (RFStorePopIntoTempNode named: self varName).
	preamble addAll: arguments.
	^ preamble ! !

!RFArgumentsReification methodsFor: 'generate' stamp: ''!
varName
	^#RFArgumentsReificationVar! !

!RFArgumentsReification methodsFor: 'generate' stamp: ''!
genForRBMethodNode
	^RBVariableNode named: self varName.! !

!RFArgumentsReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#arguments! !

!RFArgumentsReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBMessageNode. RBMethodNode. RBSequenceNode}! !

!RFBlockOperation commentStamp: ''!
I model block creation. on #value, I return the created block!
!RFBlockOperation methodsFor: 'accessing' stamp: ''!
block
	^ block! !

!RFBlockOperation methodsFor: 'accessing' stamp: ''!
block: anObject
	block := anObject! !

!RFBlockOperation methodsFor: 'evaluating' stamp: ''!
value
	^block! !

!RFBlockOperation class methodsFor: 'accessing' stamp: ''!
block: aBlock
	^self new block: aBlock! !

!RFC2047MimeConverter commentStamp: ''!
I do quoted printable MIME decoding as specified in RFC 2047 ""MIME Part Three: Message Header Extensions for Non-ASCII Text". See String>>decodeMimeHeader!
!RFC2047MimeConverter methodsFor: 'converting' stamp: ''!
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: ''!
readWord

	| strm |
	strm := (String new: 20) writeStream.
	dataStream skipSeparators.
	[dataStream atEnd] whileFalse: 
		[ | c |
		c := dataStream next.
		strm nextPut: c.
		c isSeparator ifTrue: [^ strm contents]].
	^ strm contents! !

!RFC2047MimeConverter methodsFor: 'private - encoding' stamp: ''!
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: 'converting' stamp: ''!
mimeDecode
	"Do conversion reading from mimeStream writing to dataStream. See String>>decodeMimeHeader"

	| c |
	[mimeStream atEnd] whileFalse: [
		c := mimeStream next.
		c = $=
			ifTrue: [c := Character value: mimeStream next digitValue * 16
				+ mimeStream next digitValue]
			ifFalse: [c = $_ ifTrue: [c := $ ]].
		dataStream nextPut: c].
	^ dataStream! !

!RFC2047MimeConverter methodsFor: 'private - encoding' stamp: ''!
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: ''!
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]! !

!RFClassReification commentStamp: ''!
request reification of the class!
!RFClassReification methodsFor: 'generate' stamp: ''!
genForLiteralVariable
	^self generate! !

!RFClassReification methodsFor: 'generate' stamp: ''!
generate
	^RBMessageNode 
		receiver: RBVariableNode selfNode
		selector: #class! !

!RFClassReification methodsFor: 'generate' stamp: ''!
genForInstanceVariableSlot
	^self generate! !

!RFClassReification methodsFor: 'generate' stamp: ''!
genForRBProgramNode
	^self generate! !

!RFClassReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#class! !

!RFClassReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBProgramNode. Variable}! !

!RFCondition commentStamp: ''!
I can be used to reify the condition of a link.

I have myself a condition *and* I store the condtition of the link.

on #value, I evaluate my condition and after that the orginal link condition.

With this feature, we can thus reflectively controll links while not actually changing the condition of the link itself. !
!RFCondition methodsFor: 'initialization' stamp: ''!
initialize
	condition := true! !

!RFCondition methodsFor: 'enable/disable' stamp: ''!
disable
	condition := false.! !

!RFCondition methodsFor: 'accessing' stamp: ''!
reifications
	(condition isKindOf: Boolean) ifTrue: [ ^#() ].
	^condition argumentNames. ! !

!RFCondition methodsFor: 'enable/disable' stamp: ''!
enable
	condition := true! !

!RFCondition methodsFor: 'accessing' stamp: ''!
originalLinkCondition
	^ originalLinkCondition! !

!RFCondition methodsFor: 'accessing' stamp: ''!
condition: aBlockOrBoolean
	condition := aBlockOrBoolean! !

!RFCondition methodsFor: 'accessing' stamp: ''!
originalLinkCondition: aCondition
	originalLinkCondition := aCondition! !

!RFCondition methodsFor: 'evaluating' stamp: ''!
value
	^condition and: [ self linkCondition value ]! !

!RFCondition methodsFor: 'accessing' stamp: ''!
valueSelector
	"If the condition is a block with 1+ arguments, it must be sent #cull: to be evaluated. Otherwise, it's a block with no argument or directly true or false, so we send it #value to evaluate it"
	^ (self linkCondition isBlock and: [ self linkCondition numArgs isZero not ] )
		ifTrue: [ #cull: ]
		ifFalse: [ #value ]! !

!RFCondition methodsFor: 'accessing' stamp: ''!
linkCondition
	^ self originalLinkCondition ifNil: [ [ true ] ].! !

!RFCondition methodsFor: 'evaluating' stamp: ''!
cull: arguments
	"in case of my wrapped link expects arguments"

	^ condition
		and: [ self linkCondition perform: self linkCondition valueSelector withArguments: {arguments} ]! !

!RFCondition class methodsFor: 'instance creation' stamp: ''!
for: aCondition
	^self new originalLinkCondition: aCondition.! !

!RFEntityReification commentStamp: ''!
#entity stands for the structural entity that the link is installed on. It is #node for AST nodes, #variable for variables.!
!RFEntityReification methodsFor: 'generate' stamp: ''!
genForLiteralVariable
	"entity in this case is the binding of the literal"
	^RBLiteralNode value: entity! !

!RFEntityReification methodsFor: 'generate' stamp: ''!
genForInstanceVariableSlot
	
	^RBLiteralNode value: entity! !

!RFEntityReification methodsFor: 'generate' stamp: ''!
genForRBProgramNode
	
	^RBLiteralNode value: entity! !

!RFEntityReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#entity! !

!RFEntityReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBProgramNode. Variable}.! !

!RFGlobalRead commentStamp: ''!
I model the read from a global variable!
!RFGlobalRead methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!RFGlobalRead methodsFor: 'accessing' stamp: ''!
environment
	^ environment ifNil: [ Smalltalk globals ]! !

!RFGlobalRead methodsFor: 'accessing' stamp: ''!
variableName: aSymbol
	variable := self environment associationAt: aSymbol! !

!RFGlobalRead methodsFor: 'evaluating' stamp: ''!
value
	^variable read! !

!RFGlobalWrite commentStamp: ''!
I model the write to a global variable!
!RFGlobalWrite methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!RFGlobalWrite methodsFor: 'accessing' stamp: ''!
environment
	^ environment ifNil: [ Smalltalk globals ]! !

!RFGlobalWrite methodsFor: 'accessing' stamp: ''!
variableName: aSymbol
	variable := self environment associationAt: aSymbol! !

!RFGlobalWrite methodsFor: 'evaluating' stamp: ''!
value
	^variable write: assignedValue! !

!RFIndexReification commentStamp: ''!
I reify the offset of instance variables!
!RFIndexReification methodsFor: 'generate' stamp: ''!
genForRBAssignmentNode
	^entity variable binding index asLiteralNode! !

!RFIndexReification methodsFor: 'generate' stamp: ''!
genForRBVariableNode
	^entity binding index asLiteralNode! !

!RFIndexReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#index! !

!RFIndexReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBVariableNode. RBAssignmentNode}.! !

!RFLinkReification commentStamp: ''!
I reify the link itself. !
!RFLinkReification methodsFor: 'generate' stamp: ''!
genForLiteralVariable
	^RBLiteralNode value: link! !

!RFLinkReification methodsFor: 'generate' stamp: ''!
genForInstanceVariableSlot
	^RBLiteralNode value: link! !

!RFLinkReification methodsFor: 'generate' stamp: ''!
genForRBProgramNode
	^RBLiteralNode value: link! !

!RFLinkReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#link! !

!RFLinkReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBProgramNode . Variable}! !

!RFMessageNode commentStamp: ''!
A message node!
!RFMessageNode methodsFor: 'debugging' stamp: ''!
debugHighlightRange
	^ parent debugHighlightRange ! !

!RFMessageOperation commentStamp: ''!
MessageSend subclass, just here to see them all together!
!RFMetaContext commentStamp: ''!
I model the meta level when activating a MetaLink.!
!RFMetaContext methodsFor: 'initialization' stamp: ''!
initialize
 level := 0! !

!RFMetaContext methodsFor: 'testing' stamp: ''!
isMeta
	^level > 0! !

!RFMetaContext methodsFor: 'level' stamp: ''!
shiftLevelDown
	level := (level - 1) max: 0.
	self assert: level >=0! !

!RFMetaContext methodsFor: 'level' stamp: ''!
shiftLevelUp
	level := level + 1! !

!RFMetaContext methodsFor: 'testing' stamp: ''!
isActive: n
	^level = n! !

!RFMetaContext class methodsFor: 'accessing' stamp: ''!
current 
	ActiveMetaContext value ifNil:[ActiveMetaContext value: self basicNew initialize].
	^ActiveMetaContext value! !

!RFMetaContext class methodsFor: 'class initialization' stamp: ''!
reset
	ActiveMetaContext value: self new.! !

!RFMethodOperation commentStamp: ''!
I am representing a method ready to be executed. I know the receiver and the arguments, #value will execute the method!
!RFMethodOperation methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!RFMethodOperation methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!RFMethodOperation methodsFor: 'accessing' stamp: ''!
arguments: anObject
	arguments := anObject! !

!RFMethodOperation methodsFor: 'accessing' stamp: ''!
receiver
	^ receiver! !

!RFMethodOperation methodsFor: 'evaluating' stamp: ''!
value
	^method valueWithReceiver: receiver arguments: arguments  ! !

!RFMethodOperation methodsFor: 'accessing' stamp: ''!
receiver: anObject
	receiver := anObject! !

!RFMethodOperation methodsFor: 'accessing' stamp: ''!
method: anObject
	method := anObject! !

!RFMethodReification commentStamp: ''!
I reify the method where the link is installed.

Note: this is the *current* method, that is, the one that has the code of the link.

it is the same that you would get with "thisContext method", without the need to access the context (which is slow)!
!RFMethodReification methodsFor: 'generate' stamp: ''!
genForRBProgramNode
	^RBMessageNode 
		receiver: (RBMessageNode receiver: (RBLiteralNode value: entity) selector: #methodNode)
		selector: #method! !

!RFMethodReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#method! !

!RFMethodReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBProgramNode}.! !

!RFMethodToExecuteReification commentStamp: ''!
a message send at runtime has all the information to know which method will be called.

This reification uses lookupSelector: to calculate the method.!
!RFMethodToExecuteReification methodsFor: 'generate' stamp: ''!
genForRBMessageNode
	^RBMessageNode
		receiver: (RBMessageNode receiver: (RBVariableNode named: #RFReceiverReificationVar) selector: #class)
		selector: #lookupSelector:
		arguments: (RBLiteralValueNode value: entity selector)! !

!RFMethodToExecuteReification methodsFor: 'preamble' stamp: ''!
preambleForMessage: aNode
	| preamble |
	preamble := OrderedCollection new.

	(1 to: aNode numArgs) reverseWithIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			preamble add:  (RFStorePopIntoTempNode named: name).
	].
	preamble 
		add: (RFStoreIntoTempNode named: #RFReceiverReificationVar).
		(1 to: aNode numArgs) withIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			preamble add:  (RBVariableNode named: name).
	].

	^ preamble! !

!RFMethodToExecuteReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#methodToExecute! !

!RFMethodToExecuteReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBMessageNode}! !

!RFNameReification commentStamp: ''!
I reify the name of variables!
!RFNameReification methodsFor: 'generate' stamp: ''!
genForLiteralVariable
	^entity name asLiteralNode! !

!RFNameReification methodsFor: 'generate' stamp: ''!
genForRBAssignmentNode
	^entity variable name asLiteralNode! !

!RFNameReification methodsFor: 'generate' stamp: ''!
genForInstanceVariableSlot
	^entity name asLiteralNode! !

!RFNameReification methodsFor: 'generate' stamp: ''!
genForRBVariableNode
	^entity name asLiteralNode! !

!RFNameReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#name! !

!RFNameReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBVariableNode. RBAssignmentNode. Variable}.! !

!RFNewValueReification commentStamp: ''!
reify newValue!
!RFNewValueReification methodsFor: 'preamble' stamp: ''!
preambleForAssignment: aNode
	"balance stack for instead"

	^ link control = #instead
		ifTrue: [ RFStorePopIntoTempNode named: #RFNewValueReificationVar ]
		ifFalse: [ RFStoreIntoTempNode named: #RFNewValueReificationVar ]! !

!RFNewValueReification methodsFor: 'preamble' stamp: ''!
preambleForVariable: aNode
	"balance stack for instead"

	^ link control = #instead
		ifTrue: [ RFStorePopIntoTempNode named: #RFNewValueReificationVar ]
		ifFalse: [ RFStoreIntoTempNode named: #RFNewValueReificationVar ]! !

!RFNewValueReification methodsFor: 'generate' stamp: ''!
genForRBAssignmentNode
	^RBVariableNode named: #RFNewValueReificationVar.! !

!RFNewValueReification methodsFor: 'generate' stamp: ''!
genForRBVariableNode
	"same as #value for variableNodes"
	^RBVariableNode named: #RFNewValueReificationVar.! !

!RFNewValueReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#newValue! !

!RFNewValueReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBVariableNode. RBAssignmentNode}! !

!RFNodeReification commentStamp: ''!
I am the node that the link is installed on!
!RFNodeReification methodsFor: 'generate' stamp: ''!
genForRBProgramNode
	^RBLiteralNode value: entity! !

!RFNodeReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#node! !

!RFNodeReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBProgramNode}.! !

!RFObjectReification commentStamp: ''!
Using the ObjectRefification, one can pass a pointer to the object where the link is installed in!
!RFObjectReification methodsFor: 'generate' stamp: ''!
genForLiteralVariable
	^RBVariableNode selfNode! !

!RFObjectReification methodsFor: 'generate' stamp: ''!
genForInstanceVariableSlot
	^RBVariableNode selfNode! !

!RFObjectReification methodsFor: 'generate' stamp: ''!
genForRBProgramNode
	^RBVariableNode selfNode! !

!RFObjectReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#object! !

!RFObjectReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBProgramNode. Variable}! !

!RFOperationReification commentStamp: ''!
I reify operations like message send, variable read, assignment....!
!RFOperationReification methodsFor: 'generate' stamp: ''!
genForRBLiteralArrayNode
	"same as #value, no need to wrap as the literal understands #value"
	^RBLiteralArrayNode value: entity value! !

!RFOperationReification methodsFor: 'preamble' stamp: ''!
preambleForMethod: aNode
	| preamble arguments |
	preamble := OrderedCollection new.
	arguments := aNode argumentNames collect: [ :name | RBVariableNode named: name].
	preamble addAll: (RBArrayNode statements: arguments).
	preamble add: (RFStorePopIntoTempNode named: 'RFArgumentsReificationVar').
	^ preamble ! !

!RFOperationReification methodsFor: 'preamble' stamp: ''!
preambleForAssignment: aNode
	^RFStoreIntoTempNode named: #RFNewValueReificationVar! !

!RFOperationReification methodsFor: 'generate' stamp: ''!
genForRBReturnNode
	^RBParser parseExpression: 'RFReturnOperation new
			context: thisContext;
			returnValue: RFReifyValueVar'! !

!RFOperationReification methodsFor: 'generate' stamp: ''!
genForRBBlockNode
	"we just compile the block again"
	| blockNode |
	
	blockNode := RBParser parseExpression: entity formattedCode.
	^RBMessageNode 
		receiver: (RBVariableNode named: #RFBlockOperation)
		selector: #block: 
		arguments: {blockNode} ! !

!RFOperationReification methodsFor: 'generate' stamp: ''!
genForRBLiteralValueNode
	"same as #value, no need to wrap as the literal understands #value"
	^RBLiteralNode value: entity value! !

!RFOperationReification methodsFor: 'generate' stamp: ''!
genForRBArrayNode
	^RBVariableNode named: #RFReifyValueVar! !

!RFOperationReification methodsFor: 'generate' stamp: ''!
genForRBMessageNode
	^RBParser parseExpression: ('RFMessageOperation 
			receiver: RFReceiverReificationVar 
			selector: #{1} 
			arguments: RFArgumentsReificationVar.' format: {entity selector})
! !

!RFOperationReification methodsFor: 'preamble' stamp: ''!
preambleForMessage: aNode
	| preamble arguments |
	preamble := OrderedCollection new.
	arguments := OrderedCollection new.

	(1 to: aNode numArgs) reverseWithIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			preamble add:  (RFStorePopIntoTempNode named: name).
	].
	
	preamble 
		add: (RFStoreIntoTempNode named: #RFReceiverReificationVar).
	
	(1 to: aNode numArgs) withIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			arguments add:  (RBVariableNode named: name).
	].
	preamble addAll: (RBArrayNode statements: arguments).
	preamble add: (RFStorePopIntoTempNode named: 'RFArgumentsReificationVar').
	preamble addAll: arguments.
	^ preamble ! !

!RFOperationReification methodsFor: 'generate' stamp: ''!
genForRBAssignmentNode
	entity variable isLocalVariable ifTrue: [  
		^RBParser parseExpression: ('RFTempWrite new
			assignedValue: RFNewValueReificationVar; 
			context: thisContext;
			variableName: #{1}.' format: {entity variable name})].
		
	entity variable isInstanceVariable ifTrue: [  
		^RBParser parseExpression: ('RFSlotWrite new
			assignedValue: RFNewValueReificationVar; 
			object: self;
			variableName: #{1}.' format: {entity variable name})].

	entity variable variable isLiteralVariable ifTrue: [ | ast |	
		ast := RBParser parseExpression: ('RFGlobalWrite new
			assignedValue: RFNewValueReificationVar;
			variable: #toReplace.').
		ast messages second arguments: {(RBLiteralNode value: entity variable binding)}.
		^ast].
	self error: 'not supported'! !

!RFOperationReification methodsFor: 'preamble' stamp: ''!
preambleForReturn: aNode
	^RFStoreIntoTempNode named: #RFReifyValueVar! !

!RFOperationReification methodsFor: 'generate' stamp: ''!
genForRBVariableNode
	entity isInstanceVariable ifTrue: [  
		^RBParser parseExpression: ('RFSlotRead new 
			object: self;
			variableName: #{1}.' format: {entity name})].
		
	entity isLocalVariable ifTrue: [
		^RBParser parseExpression: ('RFTempRead new 
			context: thisContext;
			variableName: #{1}.' format: {entity name})].
	
	entity variable isLiteralVariable ifTrue: [ | ast |	
			ast := RBParser parseExpression: 'RFGlobalRead new
				variable: #toReplace'.
			ast arguments: {(RBLiteralNode value: entity binding)}.

			^ast. 
		].
		
	self error: 'not supported'

! !

!RFOperationReification methodsFor: 'preamble' stamp: ''!
preambleForArray: aNode
	| preamble arguments |
	preamble := OrderedCollection new.
	arguments := OrderedCollection new.

	(1 to: aNode size) reverseWithIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			preamble add:  (RFStorePopIntoTempNode named: name).
	].
	
	self flag: #pharoTodo. "for #instead we do not need to build the stack up again as the array creation bytecode is missing"
	(1 to: aNode size) withIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			arguments add:  (RBVariableNode named: name).
	].
	preamble addAll: (RBArrayNode statements: arguments).
	preamble add: (RFStorePopIntoTempNode named: 'RFReifyValueVar').
	preamble addAll: arguments.
	^ preamble 
	! !

!RFOperationReification methodsFor: 'generate' stamp: ''!
genForRBMethodNode
	| ast |
	ast := RBParser parseExpression: 'RFMethodOperation new
			receiver: self;
			method: #toReplace;
			arguments: RFArgumentsReificationVar.'.	
	
	ast messages second arguments: {(RBLiteralNode value: entity methodNode method)}.
	^ast.! !

!RFOperationReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#operation! !

!RFOperationReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBVariableNode. RBMessageNode. RBMethodNode . RBReturnNode. RBAssignmentNode. RBLiteralNode. RBBlockNode . RBLiteralArrayNode. RBArrayNode}! !

!RFOriginalMethodReification commentStamp: ''!
I reify the method where the link is installed.

Note: this is the original method, that is, the one that has this link *not* installed.!
!RFOriginalMethodReification methodsFor: 'generate' stamp: ''!
genForRBProgramNode
	^RBLiteralNode value: entity methodNode method! !

!RFOriginalMethodReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#originalmethod! !

!RFOriginalMethodReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBProgramNode}.! !

!RFReceiverReification commentStamp: ''!
I reify the receiver of a Message or a method!
!RFReceiverReification methodsFor: 'generate' stamp: ''!
genForRBMessageNode
	^RBVariableNode named: #RFReceiverReificationVar.! !

!RFReceiverReification methodsFor: 'preamble' stamp: ''!
preambleForMessage: aNode
	| preamble |
	preamble := OrderedCollection new.

	(1 to: aNode numArgs) reverseWithIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			preamble add:  (RFStorePopIntoTempNode named: name).
	].
	preamble 
		add: (RFStoreIntoTempNode named: #RFReceiverReificationVar).
		(1 to: aNode numArgs) withIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			preamble add:  (RBVariableNode named: name).
	].

	^ preamble! !

!RFReceiverReification methodsFor: 'generate' stamp: ''!
genForRBMethodNode
	^RBVariableNode selfNode
	! !

!RFReceiverReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#receiver! !

!RFReceiverReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBMethodNode. RBMessageNode}! !

!RFReflectivityASTCacheStrategy commentStamp: ''!
The ASTCache is queried when we request the ast (via #ast) of a CompiledMethod.
If the AST has already been requested before, the cache will return it.

To create the AST for a method initially, the cache uses a strategy pattern. 

This RF strategy will take the AST from the ReflectiveMethod, should it have been created (due to MetaLinks installed on the AST).

The side effect is that the AST of these methods will survive a ASTCache reset and thus image restart.!
!RFReflectivityASTCacheStrategy methodsFor: 'accessing' stamp: ''!
getASTFor: aCompiledMethod
	^ aCompiledMethod reflectiveMethod
		ifNil: [ aCompiledMethod parseTree
				doSemanticAnalysisIn: aCompiledMethod methodClass ]
		ifNotNil: [ :rfMethod | rfMethod ast ]! !

!RFReification commentStamp: ''!
Often one needs information from the base level at the meta level.

My classes model reifications of concept at the base level.!
!RFReification methodsFor: 'generate' stamp: ''!
genForLiteralVariable
	"overriden in subclass if needed"! !

!RFReification methodsFor: 'accessing' stamp: ''!
entity: aRBMessageNode 
	entity := aRBMessageNode! !

!RFReification methodsFor: 'preamble' stamp: ''!
preambleForArray: aNode
	^#()! !

!RFReification methodsFor: 'preamble' stamp: ''!
preambleForMethod: aNode
	^#()! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBReturnNode
	^self genForRBProgramNode! !

!RFReification methodsFor: 'preamble' stamp: ''!
preambleSequence: aNode
	^#()! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBArgumentNode
	^self genForRBTemporaryNode! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBBlockNode
	^self genForRBProgramNode! !

!RFReification methodsFor: 'generate' stamp: ''!
genForGlobalVariable
	^self genForLiteralVariable! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBLiteralValueNode
	^self genForRBProgramNode ! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBMessageNode
	^self genForRBProgramNode ! !

!RFReification methodsFor: 'generate' stamp: ''!
genForClassVariable
	^self genForLiteralVariable! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBAssignmentNode
	^self genForRBProgramNode! !

!RFReification methodsFor: 'generate' stamp: ''!
genForInstanceVariableSlot
	"overriden in subclass if needed"! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBProgramNode
	"overriden in subclass if needed"! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBSelfNode
	^self genForRBProgramNode ! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBLiteralArrayNode
	^self genForRBProgramNode! !

!RFReification methodsFor: 'accessing' stamp: ''!
link: anUndefinedObject 
	link := anUndefinedObject! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBLiteralNode
	^self genForRBProgramNode! !

!RFReification methodsFor: 'preamble' stamp: ''!
preambleForAssignment: aNode
	^#()! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBSequenceNode
	^self genForRBProgramNode! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBGlobalNode
	^self genForRBVariableNode ! !

!RFReification methodsFor: 'generate' stamp: ''!
postamble: aNode
	^#()! !

!RFReification methodsFor: 'preamble' stamp: ''!
preamble: aNode
	(aNode isKindOf: RBProgramNode) ifFalse: [ ^#() ]. "variables not yet suported"
	aNode isMessage ifTrue: [ ^self preambleForMessage: aNode ].
	aNode isMethod	ifTrue: [ ^self preambleForMethod: aNode ].
	aNode isSequence ifTrue: [ ^self preambleSequence: aNode ].
	aNode isReturn ifTrue: [ ^ self preambleForReturn: aNode ].
	aNode isDynamicArray ifTrue: [ ^self preambleForArray: aNode ].
	aNode isAssignment ifTrue: [ ^self preambleForAssignment: aNode ].
	aNode isVariable ifTrue: [ ^self preambleForVariable: aNode ].
	^#().! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBCascadeNode
	^self genForRBProgramNode ! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBArrayNode

	^ self genForRBProgramNode! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBInstanceVariableNode
	^self genForRBVariableNode ! !

!RFReification methodsFor: 'preamble' stamp: ''!
preambleForMessage: aNode
	^#()! !

!RFReification methodsFor: 'preamble' stamp: ''!
preambleForVariable: aNode
	^#()! !

!RFReification methodsFor: 'preamble' stamp: ''!
preambleForReturn: aNode
	^#()! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBVariableNode
	^self genForRBProgramNode! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBTemporaryNode
	^self genForRBVariableNode! !

!RFReification methodsFor: 'generate' stamp: ''!
genForRBMethodNode
	^self genForRBProgramNode ! !

!RFReification class methodsFor: 'plugin interface' stamp: ''!
allKeys
	^self subclasses collect: [:plugin | plugin key]! !

!RFReification class methodsFor: 'plugin interface' stamp: ''!
for: aSelector
	^ self subclasses detect: [ :class | class key = aSelector ]! !

!RFReification class methodsFor: 'plugin interface' stamp: ''!
key
	"Returns my 'name'"
	^self subclassResponsibility! !

!RFReification class methodsFor: 'plugin interface' stamp: ''!
entities
	"Returns the places (i.e. node classes) where I can be used"
	^self subclassResponsibility! !

!RFReification class methodsFor: 'instance creation' stamp: ''!
entity: aNodeOrVar link: aLink 
	^self new
		link: aLink;
		entity: aNodeOrVar.! !

!RFReification class methodsFor: 'testing' stamp: ''!
isUsed
	"all my sublasses are used"
	^self name = 'RFReification'
		ifTrue: [ super isUsed ]
		ifFalse: [ true ]! !

!RFReturnOperation commentStamp: ''!
I am a message send. I am here as a subsclass so we have all operations in one spot!
!RFReturnOperation methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!RFReturnOperation methodsFor: 'accessing' stamp: ''!
returnValue: anObject
	returnValue := anObject! !

!RFReturnOperation methodsFor: 'accessing' stamp: ''!
returnValue
	^ returnValue! !

!RFReturnOperation methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!RFReturnOperation methodsFor: 'evaluating' stamp: ''!
value
	context return: returnValue ! !

!RFSelectorReification commentStamp: ''!
I am the selector of a message send or method!
!RFSelectorReification methodsFor: 'generate' stamp: ''!
genForRBMessageNode
	^entity selector asLiteralNode! !

!RFSelectorReification methodsFor: 'generate' stamp: ''!
genForRBMethodNode
	^entity selector asLiteralNode! !

!RFSelectorReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#selector! !

!RFSelectorReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBMessageNode. RBMethodNode}! !

!RFSemanticAnalyzer commentStamp: ''!
I add Reflectivity link analysis to the Semantic analyzer.

I add #beforeHooks and #afterHooks anotation and make sure to visit them for semantic analysis.!
!RFSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
analyseForLinksForNodes: aNode
	| generator |
	aNode hasMetalink
		ifFalse: [ ^ self ].
	generator := HookGenerator node: aNode.
	self analyseForLinks: aNode generator: generator.
! !

!RFSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitStorePopIntoTempNode: aNode 
	| name var |
	name := aNode name.
	var := scope lookupVarForDeclaration: name.
	var	ifNil: [ 
			var := scope addTemp: (TemporaryVariable named: aNode name) ].
	aNode binding: var.! !

!RFSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: aNode
	self visitVarWrite: aNode variable.
	super visitAssignmentNode: aNode! !

!RFSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitStoreIntoTempNode: aNode 
	| name var |
	name := aNode name.
	var := scope lookupVarForDeclaration: name.
	var	ifNil: [ 
			var := scope addTemp: (TemporaryVariable named: aNode name) ].
	aNode binding: var.! !

!RFSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitVarWrite: aNode
	self analyseForLinksForNodes: aNode! !

!RFSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode
	
	scope := OCMethodScope new outerScope: compilationContext scope.
	aMethodNode scope: scope.  scope node: aMethodNode.
	aMethodNode arguments do: [:node | self declareArgumentNode: node ].
	aMethodNode pragmas do: [:each | self visitNode: each].
	self declareTemporaryNode: (RBVariableNode named: #RFReifyValueVar).
	self analyseForLinksForNodes: aMethodNode.
	self visitNode: aMethodNode body.
! !

!RFSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitNode: aNode
	"here we add the hook anotations and visit those AST parts for semantic analysis"
	super visitNode: aNode.
	aNode isMethod ifFalse: [self analyseForLinksForNodes: aNode]! !

!RFSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
analyseForLinksForVariables: aVariableNode
	| variable generator |
	variable := aVariableNode binding.
	variable hasMetalink
		ifFalse: [ ^ self ].
	generator := HookGeneratorForVariables entity: variable node: aVariableNode.
	self analyseForLinks: variable generator: generator.

! !

!RFSemanticAnalyzer methodsFor: 'api' stamp: ''!
analyze: aNode
	self visitNode: aNode.
	RFASTClosureAnalyzer new visitNode: aNode! !

!RFSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
analyseForLinks: aNode generator: aGenerator

	aNode propertyAt: #preambles put: aGenerator preamble.
	aNode preambles do: [:each | self visitNode: each].
	
	aNode hasMetalinkBefore ifTrue: [  
		aNode propertyAt: #beforeHooks put: aGenerator beforeHooks.
 		aNode beforeHooks do: [:each | self visitNode: each]].
	
	aNode hasMetalinkAfter ifTrue: [    
		aNode propertyAt: #postambles put: aGenerator postamble.
		aNode postambles do: [:each | self visitNode: each].
		aNode propertyAt: #afterHooks put: aGenerator afterHooks.
		aNode afterHooks do: [:each | self visitNode: each]].
	
	aNode hasMetalinkInstead ifTrue: [  
		aNode propertyAt: #insteadHooks put: aGenerator insteadHooks.
 		aNode insteadHooks do: [:each | self visitNode: each]].	
! !

!RFSemanticAnalyzer methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode
	super visitVariableNode: aVariableNode.
	self analyseForLinksForVariables: aVariableNode! !

!RFSenderReification commentStamp: ''!
I reify the sender for message sends and methods!
!RFSenderReification methodsFor: 'generate' stamp: ''!
genForRBMessageNode
	^RBVariableNode selfNode! !

!RFSenderReification methodsFor: 'generate' stamp: ''!
genForRBMethodNode
	^RBMessageNode 
		receiver: (RBMessageNode 
			receiver: RBVariableNode thisContextNode
			selector: #sender)
		selector: #receiver.
		! !

!RFSenderReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#sender! !

!RFSenderReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBMessageNode . RBMethodNode}! !

!RFSlotRead commentStamp: ''!
I model the read from a slot!
!RFSlotRead methodsFor: 'accessing' stamp: ''!
object: anObject
	object := anObject! !

!RFSlotRead methodsFor: 'accessing' stamp: ''!
variableName: aSymbol
	variable := object class slotNamed: aSymbol! !

!RFSlotRead methodsFor: 'evaluating' stamp: ''!
value
	^variable read: object! !

!RFSlotRead methodsFor: 'accessing' stamp: ''!
object
	^ object! !

!RFSlotWrite commentStamp: ''!
I model the write to a global variable!
!RFSlotWrite methodsFor: 'accessing' stamp: ''!
object: anObject
	object := anObject! !

!RFSlotWrite methodsFor: 'accessing' stamp: ''!
variableName: aSymbol
	variable := object class slotNamed: aSymbol! !

!RFSlotWrite methodsFor: 'accessing' stamp: ''!
value
	^variable write: assignedValue to: object ! !

!RFSlotWrite methodsFor: 'accessing' stamp: ''!
object
	^ object! !

!RFStoreIntoTempNode commentStamp: ''!
I define a temp that I can store into!
!RFStoreIntoTempNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitStoreIntoTempNode: self! !

!RFStorePopIntoTempNode commentStamp: ''!
I define a temp that I can store into!
!RFStorePopIntoTempNode methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor
	^ aProgramNodeVisitor visitStorePopIntoTempNode: self! !

!RFTempRead commentStamp: ''!
I model temp read!
!RFTempRead methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!RFTempRead methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!RFTempRead methodsFor: 'accessing' stamp: ''!
variableName: aSymbol
	variable := context temporaryVariableNamed: aSymbol ! !

!RFTempRead methodsFor: 'evaluating' stamp: ''!
value
	^variable readInContext: context! !

!RFTempWrite commentStamp: ''!
I model temp write.!
!RFTempWrite methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!RFTempWrite methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!RFTempWrite methodsFor: 'accessing' stamp: ''!
variableName: aSymbol
	variable := context temporaryVariableNamed: aSymbol ! !

!RFTempWrite methodsFor: 'evaluating' stamp: ''!
value
	^variable write: assignedValue inContext: context! !

!RFThisContextReification commentStamp: ''!
I can be used to pass the context to the meta object!
!RFThisContextReification methodsFor: 'generate' stamp: ''!
genForLiteralVariable
	^RBVariableNode thisContextNode! !

!RFThisContextReification methodsFor: 'generate' stamp: ''!
genForInstanceVariableSlot
	^RBVariableNode thisContextNode! !

!RFThisContextReification methodsFor: 'generate' stamp: ''!
genForRBProgramNode
	^RBVariableNode thisContextNode! !

!RFThisContextReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#context! !

!RFThisContextReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBProgramNode . Variable}! !

!RFValueReification commentStamp: ''!
value

Assignment:  the orginal value for before, new value for after. 

Variables: current value (same for before and after)

Message: result of the message, only availabe for *after* links.

Return: what will be returned

!
!RFValueReification methodsFor: 'generate' stamp: ''!
genForLiteralVariable
	"entity in this case is the binding of the literal"
	^RBLiteralNode value: entity value! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForRBLiteralArrayNode
	^RBLiteralArrayNode value: entity value! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForRBReturnNode
	^RBVariableNode named: self varName! !

!RFValueReification methodsFor: 'generate' stamp: ''!
postamble: aNode
	(aNode isKindOf: RBProgramNode) ifFalse: [ ^#() ].
	aNode isMessage ifTrue: [^RFStoreIntoTempNode named: self varName. ].
	aNode isCascade ifTrue: [^RFStoreIntoTempNode named: self varName. ].
	aNode isBlock ifTrue: [^RFStoreIntoTempNode named: self varName].
	^super postamble: aNode.
	 ! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForRBBlockNode
	^RBVariableNode named: self varName! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForRBCascadeNode
	^RBVariableNode named: self varName! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForRBArrayNode
	^RBVariableNode named: self varName! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForRBLiteralValueNode
	^RBLiteralValueNode value: entity value! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForRBMessageNode
	^RBVariableNode named: self varName! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForRBAssignmentNode
	"#value for Assignemnt is the old value, is that what we want?"
	^RBVariableNode named: entity variable name! !

!RFValueReification methodsFor: 'preamble' stamp: ''!
preambleForReturn: aNode
	^ RFStoreIntoTempNode named: self varName! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForInstanceVariableSlot
	"entity in this case is the binding of the instance variable"

	^ RBMessageNode
		receiver: (RBLiteralNode value: entity)
		selector: #read:
		arguments: {RBVariableNode selfNode}! !

!RFValueReification methodsFor: 'generate' stamp: ''!
varName
	^#RFReifyValueVar! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForRBVariableNode
	entity variable
		ifNotNil: [ entity variable isLiteralVariable
				ifTrue: [ ^ RBLiteralNode value: entity binding value ] ].
	^ RBVariableNode named: entity name! !

!RFValueReification methodsFor: 'preamble' stamp: ''!
preambleForArray: aNode
	| preamble arguments |
	preamble := OrderedCollection new.
	arguments := OrderedCollection new.

	(1 to: aNode size) reverseWithIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			preamble add:  (RFStorePopIntoTempNode named: name).
	].
	
	self flag: #pharoTodo. "for #instead we do not need to build the stack up again as the array creation bytecode is missing"
	(1 to: aNode size) withIndexDo: [:each :index |  
			| name |
			name := 'RFArg', index asString, 'RFReification'.
			arguments add:  (RBVariableNode named: name).
	].
	preamble addAll: (RBArrayNode statements: arguments).
	preamble add: (RFStorePopIntoTempNode named: self varName).
	preamble addAll: arguments.
	^ preamble 
	! !

!RFValueReification methodsFor: 'generate' stamp: ''!
genForRBMethodNode
	^RBVariableNode named: self varName! !

!RFValueReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#value! !

!RFValueReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBValueNode . RBReturnNode. RBMethodNode . Variable} ! !

!RFVariableAccess commentStamp: ''!
Abstract superclass for all variable accesss. !
!RFVariableAccess methodsFor: 'accessing' stamp: ''!
variable
	^variable! !

!RFVariableAccess methodsFor: 'accessing' stamp: ''!
variableName: aSymbol
	self subclassResponsibility! !

!RFVariableAccess methodsFor: 'evaluating' stamp: ''!
value
	self subclassResponsibility! !

!RFVariableAccess methodsFor: 'accessing' stamp: ''!
variable: anObject
	variable := anObject! !

!RFVariableRead commentStamp: ''!
I model the read variables. I have all the information needed to do the read when send #value!
!RFVariableReification commentStamp: ''!
I reify #variable

- GlobaVar (or subclass) 
- Slot for ivars !
!RFVariableReification methodsFor: 'generate' stamp: ''!
genForLiteralVariable
	"entity in this case is the binding of the literal"
	^RBLiteralNode value: entity! !

!RFVariableReification methodsFor: 'generate' stamp: ''!
genForInstanceVariableSlot
	"entity in this case is the binding of the literal"
	^RBLiteralNode value: entity! !

!RFVariableReification methodsFor: 'generate' stamp: ''!
genForRBVariableNode
	
	entity isTempVariable ifTrue: [ ^self error: 'Temps can not be reified yet' ]. 
	^RBLiteralNode value: entity binding! !

!RFVariableReification class methodsFor: 'plugin interface' stamp: ''!
key
	^#variable! !

!RFVariableReification class methodsFor: 'plugin interface' stamp: ''!
entities
	^{RBVariableNode. Variable}! !

!RFVariableWrite commentStamp: ''!
I model the write to variables. I have all the information needed to do the write when send #value!
!RFVariableWrite methodsFor: 'accessing' stamp: ''!
assignedValue
	^ assignedValue! !

!RFVariableWrite methodsFor: 'accessing' stamp: ''!
assignedValue: anObject
	assignedValue := anObject! !

!RGAbstractContainer commentStamp: ''!
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: 'adding/removing' stamp: 'nil'!
addElement: anObject in: aCollection

	aCollection isDictionary
		ifTrue: [ aCollection at: anObject fullName put: anObject ]
		ifFalse:[ aCollection add: anObject ]! !

!RGAbstractContainer methodsFor: 'initialization' stamp: 'nil'!
flushElements

	elements:= IdentityDictionary new! !

!RGAbstractContainer methodsFor: 'iterating elements' stamp: 'nil'!
elementsDo: aBlock
	elements valuesDo: [ :collection | collection do: [ :each | aBlock value: each ] ]! !

!RGAbstractContainer methodsFor: 'lookup elements' stamp: 'nil'!
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: 'initialization' stamp: 'nil'!
initialize

	super initialize.
	elements:= IdentityDictionary new.! !

!RGAbstractContainer methodsFor: 'managing elements groups' stamp: 'nil'!
elementsCategorized: aSymbol with: aCollection
	"Allows to define other groups of elements with a particular kind of collection"
	
	elements at: aSymbol put: aCollection! !

!RGAbstractContainer methodsFor: 'lookup elements' stamp: 'nil'!
elementNamed: elementName
	| aSymbol found |
	
	aSymbol:= elementName asSymbol.
	elements do:[ :collection| 		
		(found:= self elementNamed: aSymbol in: collection) notNil ifTrue:[ ^found ] ].
	^nil! !

!RGAbstractContainer methodsFor: 'managing elements groups' stamp: 'nil'!
elementsCategorized: aSymbol
	"Retrieves a group of elements.
	If does not exist set an Set"
	
	^elements at: aSymbol ifAbsentPut:[ Set ]! !

!RGAbstractContainer methodsFor: 'adding/removing' stamp: 'nil'!
removeElement: anObject from: aCollection

	aCollection isDictionary
		ifTrue: [ aCollection removeKey: anObject fullName ifAbsent:[ ] ]
		ifFalse:[ aCollection remove: anObject ifAbsent:[ ] ]! !

!RGAbstractContainer methodsFor: 'testing' stamp: 'nil'!
includesElement: anRGDefinition

	^anRGDefinition isIncludedInContainer: self! !

!RGAbstractContainer methodsFor: 'accessing' stamp: 'nil'!
elements
	"Retrieves the elements"
	
	^elements! !

!RGAbstractContainer methodsFor: 'testing' stamp: 'nil'!
includesElementNamed: elementName in: aCollection

	^aCollection isDictionary
		ifTrue: [ aCollection includesKey:  elementName asSymbol ]
		ifFalse:[ aCollection anySatisfy: [ :each| each name = elementName asSymbol ] ]! !

!RGAbstractContainer methodsFor: 'adding/removing' stamp: 'nil'!
removeElement: anObject

	anObject removeFromContainer: self! !

!RGAbstractContainer methodsFor: 'testing' stamp: 'nil'!
includesElementNamed: elementName

	^ elements anySatisfy: [ :collection | self includesElementNamed: elementName asSymbol in: collection ]! !

!RGAbstractContainer methodsFor: 'managing elements groups' stamp: 'nil'!
removeElementsCategorized: aSymbol
	"Deletes a group of elements"
	
	elements removeKey: aSymbol ifAbsent:[ ]! !

!RGAbstractContainer methodsFor: 'adding/removing' stamp: 'nil'!
addElement: anObject

	anObject addInContainer: self! !

!RGAnnouncementsTest methodsFor: 'tests' stamp: ''!
testBehaviorCommentModified

	| env announcements behavior | 
	
	env := RGEnvironment new.
	announcements := OrderedCollection new.
	env announcer when: ClassCommented do: [ :announcement | announcements add: announcement ].
	
	behavior := env ensureClassNamed: #SomeClass.
	self assert: announcements isEmpty.
	behavior comment content: 'some comment'.
	self assert: announcements size equals: 1.
	behavior comment author: 'SomeAuthor'.
	behavior comment time: DateAndTime new.
	self assert: announcements size equals: 3.
	self assert: (announcements allSatisfy: [:each | each classCommented == behavior ]).
	
	
	
	
	! !

!RGAnnouncementsTest methodsFor: 'tests' stamp: ''!
testDirectAnnouncement
	| def announcements |
	def := RGBehavior new.
	announcements := OrderedCollection new.
	def environment announcer when: ClassAdded do: [ :announcement | announcements add: announcement ].
	def announce: (ClassAdded class: def category: nil).

	self assert: announcements size equals: 1.
	self assert: announcements first classAffected identicalTo: def! !

!RGAnnouncementsTest methodsFor: 'tests' stamp: ''!
testBehaviorAdded
	| env announcements behavior |
	env := RGEnvironment new.
	announcements := OrderedCollection new.
	env announcer when: ClassAdded do: [ :announcement | announcements add: announcement ].

	behavior := env ensureClassNamed: #SomeClass.
	self assert: announcements size equals: 4.
	self assert: announcements first classAffected identicalTo: behavior.

	self assert: (announcements select: [ :each | each classAffected isRingResolved ]) size equals: 1! !

!RGAnnouncementsTest methodsFor: 'tests' stamp: ''!
testAnnouncerSuspendingWithStoring

	| env announcements behavior stored | 
	
	env := RGEnvironment new.
	announcements := OrderedCollection new.
	env announcer when: ClassAdded do: [ :announcement | announcements add: announcement ].
	
	stored := env announcer suspendAllWhileStoring: [ 
		behavior := env ensureClassNamed: #SomeClass.].
	
	self assert: announcements isEmpty.
	self assert: stored notEmpty.
	"TODO: more detailed check"! !

!RGAnnouncementsTest methodsFor: 'tests' stamp: ''!
testAnnouncerSuspending

	| env announcements behavior | 
	
	env := RGEnvironment new.
	announcements := OrderedCollection new.
	env announcer when: ClassAdded do: [ :announcement | announcements add: announcement ].
	
	env announcer suspendAllWhile: [ 
		behavior := env ensureClassNamed: #SomeClass.].
	
	self assert: announcements isEmpty! !

!RGAnnouncementsTest methodsFor: 'tests' stamp: ''!
testBehaviorDefinitionModifiedForSuperclass

	| env announcements class superclass1 superclass2 | 
	
	env := RGEnvironment new.
	class := env ensureClassNamed: #SomeClass.
	superclass1 := env ensureClassNamed: #SomeSuperclass1.
	superclass2 := env ensureClassNamed: #SomeSuperclass2.
	
	class superclass: superclass1.
	
	announcements := OrderedCollection new.
	env announcer when: ClassModifiedClassDefinition do: [ :announcement |
		(announcement classAffected == class) ifTrue: [ 
			announcements add: announcement]].
	
	class name: #NewName.
	self assert: announcements size equals: 1.
	superclass1 name: #NewSuperclass1.
	self assert: announcements size equals: 2.
	class superclass: superclass2.
	self assert: announcements size equals: 3.
	
	
	
	
	! !

!RGAnnouncementsTest methodsFor: 'tests' stamp: ''!
testBehaviorParentRenamed

	| env announcements class superclass | 
	
	env := RGEnvironment new.
	class := env ensureClassNamed: #SomeClass.
	superclass := env ensureClassNamed: #SomeSuperclass.
	
	class superclass: superclass.
	
	announcements := OrderedCollection new.
	env announcer when: ClassParentRenamed do: [ :announcement |
		(announcement classAffected == class) ifTrue: [ 
			announcements add: announcement]].
	
	class name: #NewName.
	self assert: announcements size equals: 0.
	superclass name: #NewSuperclass1.
	self assert: announcements size equals: 1.
	
	
	
	
	! !

!RGAnnouncementsTest methodsFor: 'tests' stamp: ''!
testBehaviorDefinitionModifiedForCategory

	| env announcements class | 
	
	env := RGEnvironment new.
	class := env ensureClassNamed: #SomeClass.
	
	announcements := OrderedCollection new.
	env announcer when: ClassModifiedClassDefinition do: [ :announcement |
		(announcement classAffected == class) ifTrue: [ 
			announcements add: announcement]].
	
	class category: 'some category'.
	self assert: announcements size equals: 1.
	
	
	
	! !

!RGAnnouncementsTest methodsFor: 'tests' stamp: ''!
testUnsubscribe

	| env announcements behavior | 
	
	env := RGEnvironment new.
	announcements := OrderedCollection new.
	env announcer when: ClassAdded do: [ :announcement | announcements add: announcement ].
	env announcer unsubscribe: self.
	
	behavior := env ensureClassNamed: #SomeClass.
	self assert: announcements isEmpty.
! !

!RGAnnouncementsTest methodsFor: 'tests' stamp: ''!
testAnnouncementTimestamps

	| env announcements start end |
	
	start := DateAndTime now.
	env := RGEnvironment new.
	announcements := OrderedCollection new.
	env announcer when: ClassAdded do: [ :announcement | announcements add: announcement ].
	
	env ensureClassNamed: #SomeClass1.
	10 milliSeconds wait.
	env ensureClassNamed: #SomeClass2.

	end := DateAndTime now.

	self assert: (announcements size >=2).
	self assert: (announcements allSatisfy: [:each | each timeStamp between: start and: end] ).
	self assert: (announcements first timeStamp < announcements last timeStamp).
		
	"try setters"
	announcements first timeStamp: end.
	self assert: announcements first timeStamp equals: end.! !

!RGBSliders commentStamp: ''!
I am an elementary Spec widget allowing a user to choose a Color by its RGB values.

self example

I manage three SliderInput.
I set their min at 0 and their max at 255.

I provide the methods color that calculate the Color obtains with the current value of the sliders.!
!RGBSliders methodsFor: 'initialization' stamp: ''!
initializeWidgets
	redSlider := self instantiate: SliderInput.
	greenSlider := self instantiate: SliderInput.
	blueSlider := self instantiate: SliderInput.
	redSlider
		min: 0;
		max: 255; label: 'Red' translated.
	greenSlider
		min: 0;
		max: 255; label: 'Green' translated.
	blueSlider
		min: 0;
		max: 255; label: 'Blue' translated.
	self focusOrder
		add: redSlider;
		add: greenSlider;
		add: blueSlider! !

!RGBSliders methodsFor: 'accessing' stamp: ''!
greenSlider
	^ greenSlider! !

!RGBSliders methodsFor: 'initialization' stamp: ''!
whenChangedDo: aBlock
	redSlider whenValueChangedDo: aBlock.
	greenSlider whenValueChangedDo: aBlock.
	blueSlider whenValueChangedDo: aBlock! !

!RGBSliders methodsFor: 'accessing' stamp: ''!
blueSlider
	^ blueSlider! !

!RGBSliders methodsFor: 'accessing' stamp: ''!
redSlider
	^ redSlider! !

!RGBSliders methodsFor: 'accessing' stamp: ''!
color
	^ (Color
				r: redSlider value
				g: greenSlider value
				b: blueSlider value
				range: 255)! !

!RGBSliders class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self new.
	example
		title: 'RGBSliders example';
		extent: 300 @ 200;
		openDialogWithSpec.
	^ example! !

!RGBSliders class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newColumn: [ :column | 
			column
				add: #redSlider;
				add: #greenSlider;
				add: #blueSlider ];
		yourself! !

!RGBWidget commentStamp: ''!
I am a Spec widget  allowing a user to choose a Color by its RGB values and providing a preview.

self example

I am composed of a RGBSliders and an ImagePresenter that display simply a form of the current color.

I provide the following methods
- color a shortcut color to access the current color of the RGBSliders.
- makeNewForm return a fresh copy of the current displayed form.

I provide extentForPreview, a point used to define the size of the preview.!
!RGBWidget methodsFor: 'api' stamp: ''!
makeNewForm
	^ (Form extent: 30 @ 30 depth: 32) fillColor: self color! !

!RGBWidget methodsFor: 'initialization' stamp: ''!
initializeWidgets
	preview := self instantiate: ImagePresenter.
	sliders := self instantiate: RGBSliders.
	preview image: (Form extent: 30 @ 30 depth: 32).
	preview image: self makeNewForm.
	self focusOrder add: sliders! !

!RGBWidget methodsFor: 'accessing' stamp: ''!
sliders
	^ sliders! !

!RGBWidget methodsFor: 'accessing' stamp: ''!
preview
	^ preview! !

!RGBWidget methodsFor: 'api - events' stamp: ''!
whenExtentForPreviewChanged: aBlock
 extentForPreview whenChangedDo: aBlock ! !

!RGBWidget methodsFor: 'api' stamp: ''!
color
 ^ sliders color! !

!RGBWidget methodsFor: 'initialization' stamp: ''!
initializePresenter
	sliders whenChangedDo: [ preview image: self makeNewForm ].! !

!RGBWidget class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self new.
	example
		title: 'RGBWidget exampe';
		extent: 300 @ 250;
		openDialogWithSpec.
	^ example! !

!RGBWidget class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newColumn: [ :column | 
			column
				add: #preview;
				add: #sliders ];
		yourself! !

!RGBackendTest methodsFor: 'accessing' stamp: ''!
backendClass

	^ RGEnvironmentBackend  ! !

!RGBackendTest methodsFor: 'accessing' stamp: ''!
testDefaultContentFor: anRGEnvironment

"	| names defaultNames kernelPackage |
	
	defaultNames := #('Behavior' 'Behavior class' 'Class' 'Class class' 'ClassDescription' 'ClassDescription class' 'Metaclass' 'Metaclass class' 'Object' 'Object class' 'ProtoObject' 'ProtoObject class').
	
	self assert: ((anRGEnvironment ask packages collect: #name) includes: 'Kernel').
	kernelPackage := anRGEnvironment ask packageNamed: 'Kernel'.

	names := (anRGEnvironment ask behaviors collect: #name).
	self assert: (names includesAll: defaultNames asSortedCollection).
	
	self assert: (anRGEnvironment ask behaviorNamed: 'ProtoObject') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'ProtoObject').
	self assert: (anRGEnvironment ask behaviorNamed: 'ProtoObject') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'ProtoObject class').

	self assert: (anRGEnvironment ask behaviorNamed: 'Object') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'ProtoObject').
	self assert: (anRGEnvironment ask behaviorNamed: 'Object') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'Object class').
	
	self assert: (anRGEnvironment ask behaviorNamed: 'Behavior') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'Object').
	self assert: (anRGEnvironment ask behaviorNamed: 'Behavior') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'Behavior class').
	
	self assert: (anRGEnvironment ask behaviorNamed: 'ClassDescription') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'Behavior').
	self assert: (anRGEnvironment ask behaviorNamed: 'ClassDescription') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'ClassDescription class').
	
	self assert: (anRGEnvironment ask behaviorNamed: 'Class') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'ClassDescription').
	self assert: (anRGEnvironment ask behaviorNamed: 'Class') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'Class class').
	
	self assert: (anRGEnvironment ask behaviorNamed: 'Metaclass') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'ClassDescription').
	self assert: (anRGEnvironment ask behaviorNamed: 'Metaclass') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'Metaclass class').
	
	self assert: (anRGEnvironment ask behaviorNamed: 'ProtoObject class') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'Class').
	self assert: (anRGEnvironment ask behaviorNamed: 'ProtoObject class') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'Metaclass').
	
	self assert: (anRGEnvironment ask behaviorNamed: 'Object class') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'ProtoObject class').
	self assert: (anRGEnvironment ask behaviorNamed: 'Object class') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'Metaclass').
	
	self assert: (anRGEnvironment ask behaviorNamed: 'Behavior class') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'Object class').
	self assert: (anRGEnvironment ask behaviorNamed: 'Behavior class') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'Metaclass').
	
	self assert: (anRGEnvironment ask behaviorNamed: 'ClassDescription class') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'Behavior class').
	self assert: (anRGEnvironment ask behaviorNamed: 'ClassDescription class') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'Metaclass').
	
	self assert: (anRGEnvironment ask behaviorNamed: 'Class class') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'ClassDescription class').
	self assert: (anRGEnvironment ask behaviorNamed: 'Class class') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'Metaclass').
	
	self assert: (anRGEnvironment ask behaviorNamed: 'Metaclass class') superclass 
		equals: (anRGEnvironment ask behaviorNamed: 'ClassDescription class').
	self assert: (anRGEnvironment ask behaviorNamed: 'Metaclass class') metaClass 
		equals: (anRGEnvironment ask behaviorNamed: 'Metaclass').
		
	"! !

!RGBadInstantiationError commentStamp: ''!
I'm a specialized error exception used for cases where you want to work directly with instances of RGBehavior without assigned behavior strategy!
!RGBehavior commentStamp: ''!
An RGBehavior is an abstract definition for class-alike entities (e.g. classes, traits)

Instance Variables
	methods:		<Collection>
	protocols:		<Collection>
	superclass:		<Object>!
!RGBehavior methodsFor: 'accessing - definition' stamp: ''!
traitCompositionString
	^ self traitComposition traitCompositionString
		! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
canUnderstand: selector
	"Answer whether the receiver can respond to the message whose selector 
	is the argument."
	
	self allSuperclassesDo: [ :each |
		(each methods anySatisfy: [ :method | method name = selector ])
			ifTrue: [ ^ true ] ].

	^ self methods anySatisfy: [ :method | method name = selector ].! !

!RGBehavior methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ self defaultEnvironmentStub! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
addLocalMethod: anRGMethod

	self backend forBehavior addLocalMethod: anRGMethod to: self.
	
	self announcer methodAdded: anRGMethod.
! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
removeFromSystem

	self parent removeBehavior: self! !

!RGBehavior methodsFor: 'testing' stamp: ''!
isWeak

	^ self layout isWeakLayout! !

!RGBehavior methodsFor: 'accessing' stamp: ''!
users
	^ #()! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
unresolveName

	| oldName subclassesWithOldDefinitions |
	
	oldName := self name.
	
	subclassesWithOldDefinitions := (self subclasses reject: [:each | each isMeta]) collect: [ :each | 
		each -> each copyForBehaviorDefinition ].
	
	self announceDefinitionChangeDuring: [ 
		super unresolveName ].
	
	self announcer behaviorRenamed: self from: oldName.

	subclassesWithOldDefinitions do: [ :assoc |
		self announcer behaviorDefinitionChangedFrom: assoc value to: assoc key.
		self announcer behaviorModificationAppliedTo: assoc key.
		self announcer behaviorParentRenamed: assoc key from: oldName ].! !

!RGBehavior methodsFor: 'converting' stamp: ''!
convertToTrait

	| traitStrategy originalName |
	
	(self resolvedProperties includesAnyOf: #("superclass" traitComposition classVariables sharedPools))
		ifTrue: [self error: 'This class cannot be converted to trait'].
		
	"TODO: check empty layout"
	"newTrait := RGTrait unresolvedWithParent: self parent.
	newTrait copyPropertiesFrom: self.
	newTrait pvtName: name.
	newTrait pvtLocalMethods: localMethods.
	newTrait pvtTags: tags.

	newTrait behaviorStrategy pvtComment: self behaviorStrategy comment.
	newTrait behaviorStrategy pvtPackage: self behaviorStrategy package."

	originalName := self name.

	traitStrategy := RGTrait newStrategyFor: self environment.
	traitStrategy owner: self.
	traitStrategy pvtClassTrait: self pvtMetaclass.
	traitStrategy pvtPackage: self behaviorStrategy pvtPackage.
	traitStrategy pvtComment: self behaviorStrategy pvtComment.
	
	self behaviorStrategy: traitStrategy.

	self environment ask replaceName: originalName with: self name.
	
	! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
removeProtocol: aSymbol

	self removeMethodTag: aSymbol.! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
metaclass

	^ self backend forBehavior metaclassFor: self! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
cleanLocalMethods

	| oldMethods |
	
	oldMethods := self localMethods.

	self backend forBehavior cleanLocalMethodsFor: self.

	self cleanProtocols.
	
	oldMethods do: [ :each |
		self announcer methodRemoved: each ]
! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtMetaclass

	^ metaclass value! !

!RGBehavior methodsFor: 'lookup' stamp: ''!
lookupVarForDeclaration: aName

	"This is a version of #lookupVar: that skips the OCRequestorScope, from here on it is the same as lookupVar:"

	^ self lookupVar: aName! !

!RGBehavior methodsFor: 'documentation' stamp: ''!
extensions

	^ self localMethods select: [ :each | each package ~= self package ]! !

!RGBehavior methodsFor: 'default model values' stamp: ''!
defaultTraitComposition

	^ self defaultTraitCompositionStubIn: self.! !

!RGBehavior methodsFor: 'queries - methods' stamp: ''!
includesSelector: aString

	^ self selectors includes: aString! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtTagWith: aSymbol
	
	tags isRingResolved ifFalse: [ 
		self pvtCleanTags  ].
	
	tags add: aSymbol.	
	! !

!RGBehavior methodsFor: 'testing - layouts' stamp: ''!
isWords

	^ self layout isWordLayout ! !

!RGBehavior methodsFor: 'private - backend interface' stamp: ''!
pvtTraitComposition

	^ traitComposition value! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
binding

	^ self environment bindingOf: self name! !

!RGBehavior methodsFor: 'announcements' stamp: ''!
announceDefinitionChangeDuring: aBlock

	| oldVersion |

	self announcer isSuspended ifTrue: [ 
		aBlock value. 
		^ self ]	.
		
	self announcer  suspendAllWhile: [ 
		oldVersion := self copyForBehaviorDefinition.].
	aBlock value.
	self announcer 	behaviorDefinitionChangedFrom: oldVersion to: self.
	self announcer behaviorModificationAppliedTo: self.

	
	! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
cleanProtocols
	
	self cleanTagsForMethods! !

!RGBehavior methodsFor: 'queries - testing' stamp: ''!
hasTraitComposition

	^	self traitComposition transformations isEmpty not! !

!RGBehavior methodsFor: 'private - backend interface' stamp: ''!
pvtRemoveLocalMethod: anRGMethod

	self environment verifyOwnership: anRGMethod.
	
	localMethods remove: anRGMethod.
	
! !

!RGBehavior methodsFor: 'testing - layouts' stamp: ''!
isVariable

	"is the definition a variable class?"

	^ self layout isVariableLayout! !

!RGBehavior methodsFor: 'testing' stamp: ''!
isPointers

	^ self isBits not! !

!RGBehavior methodsFor: 'private - backend interface' stamp: ''!
pvtSuperclass

	^ superclass value
	! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
superclass

	^ self backend forBehavior superclassFor: self! !

!RGBehavior methodsFor: '*Roassal3-UML' stamp: ''!
buildUMLCanvasWithBrowserTool: tool
	^ nil! !

!RGBehavior methodsFor: 'default model values' stamp: ''!
defaultTags

	^ Set new! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
allSelectors
	
	^ self allSelectorsWithout: {  }! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
isClassSide
	^self == self classSide! !

!RGBehavior methodsFor: 'private - backend interface' stamp: ''!
pvtCleanLocalMethods

	localMethods := self defaultLocalMethods.
	! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtMetaclass: anRGMetaclass

	self environment verifyOwnership: anRGMetaclass.

	^ metaclass := anRGMetaclass! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
cleanTagsWithoutAnnouncemnt

	self backend forBehavior cleanClassTagsFor: self.! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
withAllSuperclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's superclasses."
	aBlock value: self.
	((self superclass == nil) or: [ self superclass == self ])
		ifFalse: [self superclass withAllSuperclassesDo: aBlock]! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtAddMethodTag: aSymbol
	
	tagsForMethods isRingResolved ifFalse: [ 
		self pvtCleanTagsForMethods  ].
	
	tagsForMethods add: aSymbol.	
	! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
traitCompositionIncludes: aTrait
	^self == aTrait or: 
		[self hasTraitComposition and: 
			[self traitComposition allTraits includes: aTrait]]! !

!RGBehavior methodsFor: 'private - backend interface' stamp: ''!
pvtSuperclass: anRGBehavior

	anRGBehavior ifNotNil: [ 
		self environment verifyOwnership: anRGBehavior.].

	^ superclass := anRGBehavior
	! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
compile: aString classified: aCategory 

	^ self compile: aString classified: aCategory notifying: nil! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
protocolNamed: aString

	^ self protocols detect: [ :each | each name = aString ]! !

!RGBehavior methodsFor: 'queries - other' stamp: ''!
allInstVarNames
	"Answer an Array of the names of the receiver's instance variables. The 
	Array ordering is the order in which the variables are stored and 
	accessed by the interpreter."

	| vars |
	(self superclass == self or: [ self superclass isNil ])
		ifTrue: [vars := self instVarNames copy]	"Guarantee a copy is answered."
		ifFalse: [vars := self superclass allInstVarNames , self instVarNames].
	^vars! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
compile: aString classified: aCategory notifying: aController

	| parseTree ast selector newMethod | 
	
	parseTree := (RBParser 
		parseMethod: aString
		onError: [ :msg :pos | ^ nil ]) methodClass: self.
		
	ast :=  parseTree doSemanticAnalysisIn: self.  
	
	selector := ast selector.
	newMethod := self ensureLocalMethodNamed: selector.
	newMethod sourceCode: aString.
	aCategory ifNotNil: [ 
		newMethod tagWith: aCategory ].
	
	^ selector.
! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
subclassDefinerClass
	^RGClassDefinitionCompiler on: self environment! !

!RGBehavior methodsFor: 'queries - methods' stamp: ''!
methodNamed: aSymbol

	| allMethods |
	allMethods := IdentitySet new.
	self methods do: [ :each | each name = aSymbol ifTrue: [^ each]].
	^ nil! !

!RGBehavior methodsFor: 'testing' stamp: ''!
hasResolvedSuperclass

	^ self hasResolved: #superclass! !

!RGBehavior methodsFor: 'queries - testing' stamp: ''!
isAccessedIn: anRGMethod
	^ (anRGMethod ast variableNodes select: [ :each | 
		   each isGlobalVariable ]) anySatisfy: [ :each | 
		  each name = self name ]! !

!RGBehavior methodsFor: 'queries - tags' stamp: ''!
ensureMethodTagNamed: aSymbol

	^ self tagsForMethods detect: [ :each | each asSymbol = aSymbol ] ifNone: [ 
		self addMethodTag: aSymbol.
		aSymbol ]! !

!RGBehavior methodsFor: 'fileout' stamp: ''!
definitionStringFor: aConfiguredPrinter

	^ aConfiguredPrinter classDefinitionString ! !

!RGBehavior methodsFor: 'queries - methods' stamp: ''!
ensureLocalMethodNamed: aSymbol

	^ self localMethodNamed: aSymbol ifAbsent: [ 
		| newMethod |
		newMethod := RGMethod named: aSymbol asSymbol parent: self.
		self addLocalMethod: newMethod.
		newMethod].! !

!RGBehavior methodsFor: 'testing - layouts' stamp: ''!
isEphemeronClass

	^ self layout isEphemeronLayout ! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtUntagFrom: aSymbol
	
	(tags value includes: aSymbol)
		ifTrue: [ tags remove: aSymbol ].
	
	"TODO:Announce"
	
	! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
methodDict

	^ Dictionary newFrom: (self methods collect: [ :each | each name asSymbol -> each ])! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtRemoveMethodTag: aSymbol
	
	tagsForMethods remove: aSymbol.
	
	"TODO:Announce"
	
	! !

!RGBehavior methodsFor: 'default model values' stamp: ''!
defaultTagsForMethods

	^ Set new! !

!RGBehavior methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.

	superclass := self. "will be set later"
	metaclass := self. "will be set later"
	localMethods := self unresolvedValue: self defaultLocalMethods.
	traitComposition := self unresolvedValue: self defaultTraitComposition.
	tagsForMethods := self unresolvedValue: self defaultTagsForMethods.	
	tags := self unresolvedValue: self defaultTags.	
! !

!RGBehavior methodsFor: 'queries - methods' stamp: ''!
ensureUnresolvedLocalMethod

	| newMethod |
	newMethod := RGMethod parent: self.
	self addLocalMethod: newMethod.
	^ newMethod! !

!RGBehavior methodsFor: 'accessing - model' stamp: ''!
tags

	^ self tagsSet asArray 
! !

!RGBehavior methodsFor: 'queries - methods' stamp: ''!
localMethodNamed: aSymbol ifAbsent: aBlock

	self localMethodsDo: [ :each | (each name = aSymbol) ifTrue: [^ each]].
	
	^ aBlock value.! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
traits

	^ self traitComposition traits! !

!RGBehavior methodsFor: 'accessing - model' stamp: ''!
tagsForMethods
	"Retrieves the traits defined in the receiver"

	| allTags |
	allTags := self defaultTagsForMethods.
	self tagsForMethodsDo: [ :each | allTags add: each].
	^ allTags asArray! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
tagsForMethodsDo: aBlock

	self backend forBehavior tagsForMethodsFor: self do: aBlock! !

!RGBehavior methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	self isRingResolved ifFalse: [ ^ self ].

	super addoptToParentStub.

	self parent pvtAddBehavior: self.
	

! !

!RGBehavior methodsFor: 'lookup' stamp: ''!
lookupVar: aName

	^ self allSlots
		  detect: [ :slot | slot name == aName ]
		  ifNone: [ self bindingOf: aName ]! !

!RGBehavior methodsFor: 'copying' stamp: ''!
copyForBehaviorDefinitionPostCopy

	super copyForBehaviorDefinitionPostCopy.
	
	superclass := self superclass shallowCopy. "we need the superclass name"
	traitComposition := self traitComposition copyForBehaviorDefinition.
	tagsForMethods := self tagsForMethods copy asSet.
	tags := self tags copy asSet.
	
	behaviorStrategy := behaviorStrategy copyForBehaviorDefinitionWithOwner: self
! !

!RGBehavior methodsFor: 'queries - tags' stamp: ''!
methodsTaggedWith: aSymbol

	^ self localMethods select: [ :each | each isTaggedWith: aSymbol ]! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
hasAbstractMethods
	"Tells whether the receiver locally defines an abstract method, i.e., a method sending subclassResponsibility"
	
	
	^ false
"	^ (self methods anySatisfy: [:cm | cm sendsSelector: #subclassResponsibility ])"! !

!RGBehavior methodsFor: 'private - backend interface' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#superclass -> superclass. 
		#localMethods -> localMethods. 
		#traitComposition -> traitComposition.  
		#metaclass -> metaclass.  
		#tagsForMethods -> tagsForMethods. 
 		#tags -> tags. 
    	}, self behaviorStrategy pvtResolvableProperties
	
	! !

!RGBehavior methodsFor: 'private - backend interface' stamp: ''!
pvtTraitComposition: anRGTraitComposition

	self environment verifyOwnership: anRGTraitComposition.

	^ traitComposition := anRGTraitComposition! !

!RGBehavior methodsFor: 'testing - layouts' stamp: ''!
isImmediateClass

	^ self layout isImmediateLayout  ! !

!RGBehavior methodsFor: 'converting' stamp: ''!
convertToMetaclassTrait

	| metaclassTraitStrategy originalName |
	
	(self resolvedProperties includesAnyOf: #(traitComposition))
		ifTrue: [self error: 'This class cannot be converted to trait'].
		
	"TODO: check empty layout"
"	newMetaclassTrait := RGMetaclassTrait unresolvedWithParent: self parent.
	newMetaclassTrait copyPropertiesFrom: self.
"
	metaclassTraitStrategy := RGMetaclassTrait newStrategyFor: self environment.
	metaclassTraitStrategy owner: self.
	metaclassTraitStrategy pvtBaseTrait: self behaviorStrategy pvtBaseClass.

	self behaviorStrategy: metaclassTraitStrategy.

	originalName := self name.
	
	(self hasResolvedName)
		ifTrue: [ self pvtName: ((self name withoutSuffix: ' class'), ' classTrait') asSymbol ].
		
	self environment ask replaceName: originalName with: self name.

	
	
	! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
classPool

	^ Dictionary new.! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
includesLocalSelector: aSymbol
	^self localMethods anySatisfy: [ :each | each name = aSymbol ].! !

!RGBehavior methodsFor: 'printing' stamp: ''!
slotDefinitionString
	"Answer a string that contains an executable description of my Slots"

	"^self slots ifNotEmpty: [self slots asString] ifEmpty: ['{}']"
	
	^String streamContents: [ :str | | special |
		str nextPutAll: '{ '.
		self slots do: [:slot |
				str nextPutAll: slot definitionString.
				special := slot needsFullDefinition]				
			separatedBy: [ 
				str nextPutAll: ' . '.  
				special ifTrue: [ str cr;tab;tab;tab;tab ]].
		str nextPutAll: ' }'. ]
! !

!RGBehavior methodsFor: 'testing' stamp: ''!
hasComment

	^ self comment isEmptyOrNil not! !

!RGBehavior methodsFor: 'testing - layouts' stamp: ''!
isBytes

	^ self layout isByteLayout ! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
sourceCodeAt: aSymbol

	| method |
	method :=  self localMethodNamed: aSymbol 
						 ifAbsent: [ self error: 'Selector #', aSymbol asString, ' not found in RGClass "', self name, '"' ].
	^ method sourceCode! !

!RGBehavior methodsFor: 'testing' stamp: ''!
canMergeWith: anRGObject visited: visitedDefinitions

	| newVisited |

	(visitedDefinitions includes: self) ifTrue: [ ^ true ].
	
	(self isRingFullyResolved or: [ anRGObject isRingFullyResolved]) ifTrue: [^ true].

	(super canMergeWith: anRGObject visited: visitedDefinitions) ifFalse: [ ^ false ].

	newVisited := visitedDefinitions copyWith: self.
	
	self superclass ~~ self ifTrue: [ 
		(self superclass canMergeWith: anRGObject superclass visited: newVisited) ifFalse: [ ^ false ]].

	self metaclass ~~ self ifTrue: [ 
		(self metaclass canMergeWith: anRGObject metaclass visited: newVisited) ifFalse: [ ^ false ]].
	
	^ true.! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
withAllSubclasses

	^ self subclasses asOrderedCollection 
		add: self; 
		yourself! !

!RGBehavior methodsFor: 'private - backend interface' stamp: ''!
pvtLocalMethodsDo: aBlock

	^ localMethods value do: aBlock! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
isInstanceSide
	^self isClassSide not! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
allSelectorsWithout: behaviors
	"Returns all the selectors of the receiver and its superclasses, except the ones define in behaviors"

	| selectors |
	selectors := IdentitySet new.
	self withAllSuperclassesDo: [ :class | 
			(behaviors includes: class)
				ifFalse: [ selectors addAll: class selectors ] ].
	^ selectors! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
localMethodsDo: aBlock

	self backend forBehavior localMethodsFor: self do: aBlock! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtTagsForMethodsDo: aBlock

	^ tagsForMethods value do: aBlock! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
cleanTagsForMethods

	self backend forPackage cleanTagsForMethodsFor: self! !

!RGBehavior methodsFor: 'testing - layouts' stamp: ''!
isCompiledMethod

	^ self layout isCompiledMethodLayout ! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtTags: aCollection

	^ tags := aCollection! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
removeLocalMethod: anRGMethod 

	(anRGMethod package = self package)
		ifFalse: [ anRGMethod package removeExtensionMethod:  anRGMethod ].
		
	self backend forBehavior removeLocalMethod: anRGMethod from: self.
	
	self announcer methodRemoved: anRGMethod.
! !

!RGBehavior methodsFor: 'accessing - model' stamp: ''!
tagsForMethodsSet
	"Retrieves the traits defined in the receiver"

	| allTags |
	allTags := self defaultTagsForMethods.
	self tagsForMethodsDo: [ :each | allTags add: each].
	^ allTags! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtCleanTags

	tags := self defaultTags.
		
	"TODO:Announce if not empty"
	
	! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
allSuperclasses

	| temp |
	^ ((self superclass == nil) or: [ self superclass == self ])
		ifTrue: [ OrderedCollection new]
		ifFalse: [temp := self superclass allSuperclasses.
			temp addFirst: self superclass.
			temp] ! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
superclass: anRGBehavior

	self announceDefinitionChangeDuring: [ 
		self backend forBehavior setSuperclassFor: self to: anRGBehavior ].! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
categoryOfElement: aSymbol ifAbsent: aBlockClosure
	
	| aMethod |
	
	aMethod := (self localMethodNamed: aSymbol ifAbsent: nil).
	^ aMethod 
		ifNotNil: [ aMethod protocol ]
		ifNil: aBlockClosure! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
metaLevelScope
	^self isInstanceSide ifTrue: [ ClyInstanceSideScope ] ifFalse: [ ClyClassSideScope ]! !

!RGBehavior methodsFor: 'accessing - definition' stamp: ''!
classVariablesBindings

	^ self propertyNamed: #classVariablesBindings ifAbsentPut: [ IdentityDictionary new.]! !

!RGBehavior methodsFor: 'testing - layouts' stamp: ''!
isBits

	^ self layout isBitsLayout! !

!RGBehavior methodsFor: 'accessing' stamp: ''!
asYetUnclassifiedProtocolName

	^ Protocol unclassified ! !

!RGBehavior methodsFor: 'queries - methods' stamp: ''!
selectors

	^ self methods collect: [ :each | each name ]! !

!RGBehavior methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	"use unresolved value for superclass to avoid infinite recursion. It needs to be set later"
	superclass := RGUnresolvedValue recursive.
	metaclass := RGUnresolvedValue recursive.
	localMethods := self unresolvedValue: self defaultLocalMethods.
	traitComposition := self unresolvedValue: self defaultTraitComposition.
	tagsForMethods := self unresolvedValue: self defaultTagsForMethods.	
	tags := self unresolvedValue: self defaultTags.	
! !

!RGBehavior methodsFor: 'queries - methods' stamp: ''!
localMethodsSet

	| methods |
	
	methods := self defaultLocalMethods.
	self localMethodsDo: [ :each | methods add: each ].
	^ methods! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
lookupSelector: selector
	"Look up the given selector in my methodDictionary.
	Return the corresponding method if found.
	Otherwise chase the superclass chain and try again.
	Return nil if no method is found."
	| lookupClass |
	lookupClass := self.
	[lookupClass == nil]
		whileFalse: [ 
			lookupClass methodDict 
				at: selector
				ifPresent: [ :method | ^ method ].
			lookupClass := lookupClass superclass].
	^ nil! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
metaclass: anRGMetaclass

	self backend forBehavior setMetaclassFor: self to: anRGMetaclass.
	
! !

!RGBehavior methodsFor: 'accessing' stamp: ''!
compiler

	^ self class compiler! !

!RGBehavior methodsFor: 'queries - testing' stamp: ''!
hasMethods
	"validates the existance of methods"

	^ self methods notEmpty! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
cleanTags

	self announceDefinitionChangeDuring: [ 
		self cleanTagsWithoutAnnouncemnt ].! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
isObsolete

	^ false! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtTagsDo: aBlock

	^ tags value do: aBlock! !

!RGBehavior methodsFor: 'resolving' stamp: ''!
makeResolved

	superclass := self superclass markAsRingResolved.
	localMethods := self localMethodsSet markAsRingResolved.
	traitComposition := self traitComposition markAsRingResolved.
	metaclass := self metaclass markAsRingResolved.
	tagsForMethods := self tagsForMethodsSet markAsRingResolved.
	tags := self tagsSet markAsRingResolved.
	
	super makeResolved.! !

!RGBehavior methodsFor: 'slots' stamp: ''!
slotsNeedFullDefinition
	"return true if we define something else than InstanceVariableSlots"
	^self slots anySatisfy: [ :each | each needsFullDefinition ]! !

!RGBehavior methodsFor: 'queries - methods' stamp: ''!
localMethods

	^ self localMethodsSet asArray! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
traitComposition: anRGTraitComposition

	self announceDefinitionChangeDuring: [ 
		self backend forBehavior setTraitCompositionFor: self to: anRGTraitComposition.].! !

!RGBehavior methodsFor: 'lookup' stamp: ''!
lookupVar: aName declare: aBoolean
	^ self lookupVar: aName ! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
tagWith: aSymbol 

	self announceDefinitionChangeDuring: [ 
		self backend forBehavior tagClass: self with: aSymbol.
		self package addClassTag: aSymbol.
	].
	! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
includesMethodsAffectedBy: aSystemAnnouncement
	^aSystemAnnouncement affectsMethodsDefinedInClass: self! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
>> aSymbol

	^ self methodNamed: aSymbol! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
withAllSuperclasses
	"Answer an OrderedCollection of the receiver and the receiver's 
	superclasses. The first element is the receiver, 
	followed by its superclass; the last element is Object."

	| temp |
	temp := self allSuperclasses.
	temp addFirst: self.
	^ temp! !

!RGBehavior methodsFor: '*Roassal3-UML' stamp: ''!
withAllSuperAndSubclasses
	"Answer the receiver's class hierarchy"

	^self allSuperclasses, self withAllSubclasses! !

!RGBehavior methodsFor: 'private - backend interface' stamp: ''!
pvtAddLocalMethod: anRGMethod

	self environment verifyOwnership: anRGMethod.
	
	localMethods isRingResolved ifFalse: [ 
		self pvtCleanLocalMethods ].

	(self hasResolved: #tagsForMethods) 
		ifFalse: [ self pvtCleanTagsForMethods ].

	anRGMethod tags do: [ :aTag |
		self pvtAddMethodTag: aTag ].

	localMethods add: anRGMethod.	
	! !

!RGBehavior methodsFor: 'accessing' stamp: ''!
usedTraits

	^ self traitComposition usedTraits! !

!RGBehavior methodsFor: 'testing - layouts' stamp: ''!
isEphemeron

	^ self layout isEphemeronLayout! !

!RGBehavior methodsFor: 'accessing - model' stamp: ''!
tagsSet

	| allTags |
	allTags := self defaultTags.
	self tagsDo: [ :each | allTags add: each].
	^ allTags 
! !

!RGBehavior methodsFor: 'testing - class hierarchy' stamp: ''!
inheritsFrom: aClass 
	"Answer whether the argument, aClass, is on the receiver's superclass 
	chain."

	| aSuperclass |
	aSuperclass := self superclass.
	[aSuperclass == nil]
		whileFalse: 
			[aSuperclass == aClass ifTrue: [^true].
			aSuperclass := aSuperclass superclass].
	^false! !

!RGBehavior methodsFor: 'queries - testing' stamp: ''!
isRootInEnvironment		
		
	^ self superclass == self or: [ self superclass isNil ] ! !

!RGBehavior methodsFor: 'accessing - definition' stamp: ''!
sharedPoolsString
	"Answer a string of my class variable names separated by spaces."

	"TODO: check validity"
	^String streamContents: [ :stream | 
		self sharedPools 
			do: [ :each | stream nextPutAll: each name]
			separatedBy: [ stream space ] ]! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
includesVariablesAffectedByModificationOf: modifiedClass
	"Any class has ClassVariables which are visible from instance side and class side. That's why here we must check both class and metaclass"
	
	self instanceSide = modifiedClass instanceSide ifTrue: [ ^true ].
	self classSide = modifiedClass classSide ifTrue: [ ^true ].
	
	self isRootInEnvironment ifTrue: [ ^false ].
	
	^self superclass includesVariablesAffectedByModificationOf: modifiedClass! !

!RGBehavior methodsFor: 'private - backend access' stamp: ''!
pvtCleanTagsForMethods

	tagsForMethods := self defaultTagsForMethods.
		
	"TODO:Announce if not empty"
	
	! !

!RGBehavior methodsFor: 'accessing - class hierarchy' stamp: ''!
subclasses

	| result |
	result := IdentitySet new.
	self environment behaviorsDo: [ :each |
		(each superclass == self) ifTrue: [ result add: each] ].
	^ result asArray! !

!RGBehavior methodsFor: 'printing' stamp: ''!
printOn: aStream 
	aStream nextPutAll: self name! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
tagsDo: aBlock

	self backend forBehavior tagsForClass: self do: aBlock! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
subclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	
	self subclasses do: aBlock! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
calypsoEnvironmentType
	^ClyClass! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
name: aString

	| oldName subclassesWithOldDefinitions |
	
	oldName := self name.
	
	subclassesWithOldDefinitions := (self subclasses reject: [:each | each isMeta]) collect: [ :each | 
		each -> each copyForBehaviorDefinition ].
	
	self announceDefinitionChangeDuring: [ 
		super name: aString ].
	
	self announcer behaviorRenamed: self from: oldName.

	subclassesWithOldDefinitions do: [ :assoc |
		self announcer behaviorDefinitionChangedFrom: assoc value to: assoc key.
		self announcer behaviorModificationAppliedTo: assoc key.
		self announcer behaviorParentRenamed: assoc key from: oldName ].! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
removeMethodTag: aSymbol

	self backend forPackage removeMethodTag: aSymbol from: self.
	
	self localMethodsDo: [ :method | 
		method untagFrom: aSymbol ].! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
traitComposition

	^ self backend forBehavior traitCompositionFor: self! !

!RGBehavior methodsFor: 'queries - methods' stamp: ''!
methods

	| methodsFromTraits methodsDict |
	"TODO: make nicer"
	"^ self propertyNamed: #methods ifAbsentPut: [ "
	methodsFromTraits := self traitComposition methods collect:  [ :each | each copy parent: self ].
	methodsDict := Dictionary new.
	methodsFromTraits do: [ :each |
		methodsDict at: each name put: each ].
	self localMethodsDo: [ :each |
		methodsDict at: each name put: each ].
	^ methodsDict values asArray"]"
! !

!RGBehavior methodsFor: '*Roassal3-UML' stamp: ''!
isTestCase
	^false! !

!RGBehavior methodsFor: 'queries - protocols' stamp: ''!
ensureProtocolNamed: aSymbol
 
	^ self ensureMethodTagNamed: aSymbol! !

!RGBehavior methodsFor: 'private' stamp: ''!
pvtLocalMethods: aCollection

	"use only for low-level copying"
	localMethods := aCollection! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
compile: code notifying: requestor 

	| parseTree ast aMethod |
	
	parseTree := (RBParser 
		parseMethod: code 
		onError: [ :msg :pos | "TODO:" ^ nil ]) methodClass: self.
	
	ast := parseTree doSemanticAnalysisIn: self.

	aMethod := self ensureLocalMethodNamed: ast selector.
	aMethod sourceCode: code.
	
	^ aMethod selector
	! !

!RGBehavior methodsFor: 'fileout' stamp: ''!
oldDefinition
	
	^ ClassDefinitionPrinter legacy
		for: self;
		definitionString! !

!RGBehavior methodsFor: 'slots' stamp: ''!
slots		
		
	^ self layout slots ! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
addProtocol: aSymbol 

	self addMethodTag: aSymbol
! !

!RGBehavior methodsFor: 'default model values' stamp: ''!
defaultLocalMethods

	^ Set new! !

!RGBehavior methodsFor: 'accessing - model' stamp: ''!
tagsForAllMethods
	"I act as #tagsForMethods but I also takes into account methods comming from traits"

	^ self methods flatCollect: [ :each  | each tags ] as: Set! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
organization

	^ self! !

!RGBehavior methodsFor: 'strategy' stamp: ''!
pvtAsTrait

	| traitStrategy |
	
	(self resolvedProperties includesAnyOf: #("superclass" traitComposition classVariables sharedPools))
		ifTrue: [self error: 'This class cannot be converted to trait'].
		
	"TODO: check empty layout"
	"newTrait := RGTrait unresolvedWithParent: self parent.
	newTrait copyPropertiesFrom: self.
	newTrait pvtName: name.
	newTrait pvtLocalMethods: localMethods.
	newTrait pvtTags: tags.

	newTrait behaviorStrategy pvtComment: self behaviorStrategy comment.
	newTrait behaviorStrategy pvtPackage: self behaviorStrategy package."

	traitStrategy := RGTrait newStrategyFor: self environment.

	traitStrategy pvtComment: self behaviorStrategy comment.
	traitStrategy pvtPackage: self behaviorStrategy package.
	
	self behaviorStrategy: traitStrategy.
	
	^ self	
	! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
untagFrom: aSymbol

	self backend forPackage untagClass: self from: aSymbol! !

!RGBehavior methodsFor: 'testing' stamp: ''!
isTaggedWith: aSymbol

	^self tags includes: aSymbol ! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
unresolveSuperclass

	self announceDefinitionChangeDuring: [ 
		self pvtSuperclass: (RGUnresolvedValue recursive) ].! !

!RGBehavior methodsFor: '*Roassal3-UML' stamp: ''!
shouldUseUMLClassTab
	^ true! !

!RGBehavior methodsFor: 'accessing - backend' stamp: ''!
addMethodTag: aSymbol 

	self announceDefinitionChangeDuring: [ 
		self backend forBehavior addMethodTag: aSymbol to: self. ].! !

!RGBehavior methodsFor: 'queries - methods' stamp: ''!
localSelectors

	^ self localMethods collect: [ :each | each name ]! !

!RGBehavior methodsFor: 'default model values' stamp: ''!
defaultLayout

	^ self defaultFixedLayoutStubIn: self.! !

!RGBehavior methodsFor: 'queries - protocols' stamp: ''!
protocols

	| methodTags |
	
	methodTags := self tagsForMethods.
	^	methodTags
		ifEmpty: [ 
			self methods 
				ifEmpty: [ OrderedCollection new ]
				ifNotEmpty: [  OrderedCollection with: self class asYetUnclassifiedProtocolName   ].
			]
		ifNotEmpty: [ methodTags  ]
! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
isDefinedInPackage: aPackage

	^ self package = aPackage! !

!RGBehavior methodsFor: '*Calypso-Ring' stamp: ''!
sourceCodeTemplate
	"Answer an expression to be edited and evaluated in order to define 
	methods in this class or trait."

	^ 'messageSelectorAndArgumentNames
	"comment stating purpose of message"

	| temporary variable names |
	statements'! !

!RGBehavior methodsFor: 'testing' stamp: ''!
isBehavior

	^ true! !

!RGBehavior methodsFor: '*Ring-RuntimeSupport' stamp: ''!
allSuperclassesDo: aBlock

	^ self allSuperclasses do: aBlock! !

!RGBehavior methodsFor: 'accessing - definition' stamp: ''!
classVariablesString
	"Answer a string of my class variable names separated by spaces."

	^ self behaviorStrategy classVariablesString! !

!RGBehavior class methodsFor: 'accessing' stamp: ''!
parent: anRGObject behaviorStrategy: anRGBehaviorStrategy
	
	| aBehavior |

	aBehavior := self basicNew
		behaviorStrategy: anRGBehaviorStrategy;
		parent: anRGObject;
		initialize.
	anRGBehaviorStrategy initialize.
	^ aBehavior
! !

!RGBehavior class methodsFor: 'accessing' stamp: ''!
named: aString parent: anRGObject

	^ self badInstantiationError! !

!RGBehavior class methodsFor: 'accessing' stamp: ''!
named: aName parent: anRGObject behaviorStrategy: anRGBehaviorStrategy
	
	| aBehavior |

	aBehavior := self basicNew
		behaviorStrategy: anRGBehaviorStrategy;
		parent: anRGObject;
		initialize.
	anRGBehaviorStrategy initialize.
	^ aBehavior
		pvtName: aName asSymbol;
		yourself		
! !

!RGBehavior class methodsFor: 'accessing' stamp: ''!
unresolvedWithBehaviorStrategy: anRGBehaviorStrategy

	| aBehavior |
	
	aBehavior := self basicNew
		behaviorStrategy: anRGBehaviorStrategy;
		initializeUnresolved.
	anRGBehaviorStrategy initializeUnresolved.
	^ aBehavior
! !

!RGBehavior class methodsFor: 'instance creation' stamp: ''!
newClass

	^ self unnamedWithBehaviorStrategy: RGClassStrategy basicNew! !

!RGBehavior class methodsFor: 'accessing' stamp: ''!
named: aName behaviorStrategy: anRGBehaviorStrategy

	| aBehavior |
	
	aBehavior := self basicNew
		behaviorStrategy: anRGBehaviorStrategy;
		initialize.
	anRGBehaviorStrategy initialize.
	^ aBehavior
		pvtName: aName asSymbol;
		yourself		
! !

!RGBehavior class methodsFor: 'instance creation' stamp: ''!
newMetaclass

	^ self unnamedWithBehaviorStrategy: RGMetaclassStrategy basicNew! !

!RGBehavior class methodsFor: 'accessing' stamp: ''!
named: aString

	^ self badInstantiationError! !

!RGBehavior class methodsFor: 'private - accessing' stamp: ''!
badInstantiationError

	RGBadInstantiationError signal: 'I cannot be instantiated this way because every RGBehavior must know its proper behavior strategy. Please use a subclass of RGBehaviorFactory or my methods like #newClass'! !

!RGBehavior class methodsFor: 'accessing' stamp: ''!
unnamedWithBehaviorStrategy: anRGBehaviorStrategy

	| aBehavior |
	
	aBehavior := self basicNew
		behaviorStrategy: anRGBehaviorStrategy;
		initialize.
	anRGBehaviorStrategy initialize.
	^ aBehavior
! !

!RGBehavior class methodsFor: 'accessing' stamp: ''!
unresolvedWithParent: anRGObject behaviorStrategy: anRGBehaviorStrategy
	
	| aBehavior |

	aBehavior := self basicNew
		behaviorStrategy: anRGBehaviorStrategy;
		parent: anRGObject;
		initializeUnresolved.
	anRGBehaviorStrategy initializeUnresolved.
	^ aBehavior
! !

!RGBehavior class methodsFor: 'accessing' stamp: ''!
unresolvedNamed: aName withParent: anRGObject behaviorStrategy: anRGBehaviorStrategy
	
	| aBehavior |

	aBehavior := self basicNew
		behaviorStrategy: anRGBehaviorStrategy;
		parent: anRGObject;
		initializeUnresolved.
	anRGBehaviorStrategy initializeUnresolved.
	^ aBehavior
		pvtName: aName asSymbol;
		yourself		
! !

!RGBehavior class methodsFor: 'instance creation' stamp: ''!
newTrait

	^ self unnamedWithBehaviorStrategy: RGTrait newStrategy! !

!RGBehavior class methodsFor: 'instance creation' stamp: ''!
newMetaclassTrait

	^ self unnamedWithBehaviorStrategy: RGMetaclassTrait newStrategy! !

!RGBehaviorDefinition commentStamp: ''!
An RGBehaviorDefinition is an abstract definition for class-alike entities (e.g. classes, traits)

Instance Variables
	methods:		<Collection>
	protocols:		<Collection>
	superclass:		<Object>!
!RGBehaviorDefinition methodsFor: 'subclassing' stamp: 'nil'!
addSubclass: aRGBehaviorDefinition
	"Adds a direct subclass of the receiver"

	(self subclasses includes: aRGBehaviorDefinition)
		ifFalse:[ self subclasses add: aRGBehaviorDefinition ]! !

!RGBehaviorDefinition methodsFor: 'accessing - deprecated parallel hierarchy' stamp: 'nil'!
theMetaClass
	"This method is deprecated so consider to migrate."
	
	self
		deprecated: 'Please use #classSide instead'
		transformWith: '`@receiver theMetaClass' -> '`@receiver classSide'.
		
	^ self classSide! !

!RGBehaviorDefinition methodsFor: 'compatibility' stamp: 'nil'!
soleInstance
	"to be deprecated in the future"
	
	^self instanceSide! !

!RGBehaviorDefinition methodsFor: 'testing' stamp: 'nil'!
isDefined
	"If the class exists in the environment"
	
	^self realClass notNil
	! !

!RGBehaviorDefinition methodsFor: 'accessing - class hierarchy' stamp: 'nil'!
withAllSubclasses
	"if allSubclasses is stored should not affect the collection"

	^self allSubclasses, {self}! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
protocols: aCollection
	"set the protocols of the class"

	protocols:= aCollection! !

!RGBehaviorDefinition methodsFor: 'adding/removing protocols' stamp: 'nil'!
removeProtocol: aString
	"Removes a protocol named aString (if exists)"

	protocols remove: aString ifAbsent:[]! !

!RGBehaviorDefinition methodsFor: 'accessing - class hierarchy' stamp: 'nil'!
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: 'adding/removing methods' stamp: 'nil'!
addSelector: selectorName classified: protocolName sourced: source

	self addMethod: ((RGMethodDefinition named: selectorName) 
							parent: self;
							protocol: protocolName;
							sourceCode: source;
							yourself)! !

!RGBehaviorDefinition methodsFor: 'annotations' stamp: 'nil'!
superclassName: aSymbol

	self annotationNamed: self class superclassNameKey 
		put: aSymbol! !

!RGBehaviorDefinition methodsFor: 'annotations' stamp: 'nil'!
traitCompositionSource: anString
	"Stores aString representing the traits used by the receiver "

	self annotationNamed: self class traitCompositionSourceKey
		put: anString ! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
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
		ifFalse: [ ^ self ].
	self superclassName: aRGBehaviorDefinition name.
	aRGBehaviorDefinition addSubclass: self.
	self hasMetaclass
		ifTrue: [ self classSide superclass: aRGBehaviorDefinition classSide ]! !

!RGBehaviorDefinition methodsFor: 'accessing - methods' stamp: 'nil'!
selectors
	"Retrieves the method selectors"

	^methods keys! !

!RGBehaviorDefinition methodsFor: 'adding/removing methods' stamp: 'nil'!
removeSelector: selector
	"Removes a method named as selector"

	methods removeKey: selector ifAbsent:[]! !

!RGBehaviorDefinition methodsFor: 'annotations' stamp: 'nil'!
hasDefinitionSource
	"Tests whether the receiver has a source definition."
	
	^ self definitionSource notNil! !

!RGBehaviorDefinition methodsFor: 'initialization' stamp: 'nil'!
initialize

	super initialize.
	methods:= IdentityDictionary new.
	protocols:= Set new.! !

!RGBehaviorDefinition methodsFor: 'accessing - class hierarchy' stamp: 'nil'!
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: 'nil'!
allSubclasses: aCollection
	"Stores all the subclasses (direct and indirect) as an annotation"
	
	self annotationNamed: self class allSubclassesKey
		ifAbsentPut:[ aCollection ]! !

!RGBehaviorDefinition methodsFor: 'accessing - methods' stamp: 'nil'!
includesSelector: selector
	"Looks if selector is a key in the methods dictionary"
	
	^methods includesKey: selector asSymbol! !

!RGBehaviorDefinition methodsFor: 'testing' stamp: 'nil'!
isSameRevisionAs: aRGBehaviorDefinition
	"This method look for equality of the properties of the receiver"

	^self class = aRGBehaviorDefinition class
		and:[ self name == aRGBehaviorDefinition name ]! !

!RGBehaviorDefinition methodsFor: 'testing' stamp: 'nil'!
hasMethods
	"validates the existance of methods"

	^methods notEmpty! !

!RGBehaviorDefinition methodsFor: 'managing container' stamp: 'nil'!
removeFromContainer: aRGContainer

	aRGContainer removeClass: self! !

!RGBehaviorDefinition methodsFor: 'adding/removing methods' stamp: 'nil'!
removeMethod: aRGMethodDefinition
	"Removes aRGMethodDefinition from the methods dictionary"

	self removeMethod: aRGMethodDefinition from: methods! !

!RGBehaviorDefinition methodsFor: 'testing' stamp: 'nil'!
hasTraitComposition

	^self traitCompositionSource ~= '{}'! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
superclass

	^superclass! !

!RGBehaviorDefinition methodsFor: '*Tool-Base' stamp: ''!
browse

	^ Smalltalk tools browser openOnClass: self realClass! !

!RGBehaviorDefinition methodsFor: 'accessing - methods' stamp: 'nil'!
compiledMethodNamed: selector
	"Retrieves the compiled method from aRGMethodDefinition"
	| method |

	^(method:= self methodNamed: selector) notNil
	ifTrue: [ method compiledMethod ]
	ifFalse:[ nil ]! !

!RGBehaviorDefinition methodsFor: 'file in/out' stamp: 'nil'!
definition

	^ self definitionSource! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
realClass
	"Retrieves the current class existing in the runtime environment"

	^self rootEnvironment classNamed: self name ! !

!RGBehaviorDefinition methodsFor: 'accessing - methods' stamp: 'nil'!
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: 'managing container' stamp: 'nil'!
addInContainer: aRGContainer

	aRGContainer addClass: self! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
package
	
	self subclassResponsibility! !

!RGBehaviorDefinition methodsFor: 'annotations' stamp: 'nil'!
subclasses: aCollection
	"Stores direct subclasses of the receiver as an annotation"

	self annotationNamed: self class subclassesKey
		ifAbsentPut:[ aCollection ]! !

!RGBehaviorDefinition methodsFor: 'accessing - class hierarchy' stamp: 'nil'!
allSuperclasses: aCollection
	"Stores all the superclasses (direct and indirect) as an annotation"
	
	self annotationNamed: self class allSuperclassesKey
		ifAbsentPut:[ aCollection ]! !

!RGBehaviorDefinition methodsFor: 'annotations' stamp: 'nil'!
definitionSource: aString
	"Sets the definition template of the receiver -> aString.
	It's stored as an annotation"
	
	self annotationNamed: self class definitionSourceKey
		put: aString! !

!RGBehaviorDefinition methodsFor: 'accessing - class hierarchy' stamp: 'nil'!
withAllSuperclasses
	"if allSuperclasses is stored should not affect the collection"

	^self allSuperclasses, {self}! !

!RGBehaviorDefinition methodsFor: 'accessing - parallel hierarchy' stamp: 'nil'!
classSide
	"Return the metaclass of the couple class/metaclass. Useful to avoid explicit test."
	
	^ self subclassResponsibility! !

!RGBehaviorDefinition methodsFor: 'private' stamp: 'nil'!
removeMethod: aRGMethodDefinition from: aCollection
	"Removes aRGMethodDefinition from the collection received"

	aCollection removeKey: aRGMethodDefinition selector ifAbsent:[]! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
allInstVarNames
	^ self subclassResponsibility! !

!RGBehaviorDefinition methodsFor: 'testing - class hierarchy' stamp: 'nil'!
includesBehavior: aClass
	^self == aClass or: [self inheritsFrom: aClass]! !

!RGBehaviorDefinition methodsFor: 'printing' stamp: 'nil'!
printOn: aStream 
	aStream nextPutAll: self name! !

!RGBehaviorDefinition methodsFor: 'accessing - methods' stamp: 'nil'!
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: 'nil'!
extensionMethods

	^self methods select:[ :each | each isExtension ]! !

!RGBehaviorDefinition methodsFor: 'annotations' stamp: 'nil'!
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: '*Epicea-Ring' stamp: ''!
traitComposition
	
	^ (self class compiler evaluate: self traitCompositionSource) asTraitComposition! !

!RGBehaviorDefinition methodsFor: 'testing' stamp: 'nil'!
includesProtocol: aString
	    "Looks for a protocols named = aString"
    
	    ^protocols includes: aString! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
methods

	^methods! !

!RGBehaviorDefinition methodsFor: 'accessing - deprecated parallel hierarchy' stamp: 'nil'!
theNonMetaClass
	"This method is deprecated so consider to migrate."
	
	self
		deprecated: 'Please use #instanceSide instead'
		transformWith: '`@receiver theNonMetaClass' -> '`@receiver instanceSide'.
	
	^ self instanceSide! !

!RGBehaviorDefinition methodsFor: 'annotations' stamp: 'nil'!
traitCompositionSource
	"Retrieves aString representing the used traits"

	^self annotationNamed: self class traitCompositionSourceKey
		ifAbsentPut:[  '{}'  ]! !

!RGBehaviorDefinition methodsFor: 'testing' stamp: 'nil'!
hasSuperclass

	^superclass notNil! !

!RGBehaviorDefinition methodsFor: 'private' stamp: 'nil'!
addMethod: aRGMethodDefinition in: aCollection
	"Adds aRGMethodDefinition in the collection received"

	aRGMethodDefinition parent ifNil:[ aRGMethodDefinition parent: self ].
	aCollection at: aRGMethodDefinition selector
		put: aRGMethodDefinition! !

!RGBehaviorDefinition methodsFor: 'accessing - class hierarchy' stamp: 'nil'!
methodDict
	^ methods! !

!RGBehaviorDefinition methodsFor: 'testing' stamp: 'nil'!
hasMetaclass

	^ false! !

!RGBehaviorDefinition methodsFor: 'adding/removing protocols' stamp: 'nil'!
addProtocol: anObject
	"Adds a protocol named anObject.
	Protocols are not repeated"
	
	anObject ifNil:[ ^self ].
	protocols add: anObject! !

!RGBehaviorDefinition methodsFor: 'testing' stamp: 'nil'!
hasProtocols
	"Validates the existance of protocols"

	^protocols notEmpty! !

!RGBehaviorDefinition methodsFor: 'managing container' stamp: 'nil'!
isIncludedInContainer: aRGContainer

	^aRGContainer includesClass: self! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
methods: aDictionary

	methods:= aDictionary! !

!RGBehaviorDefinition methodsFor: 'annotations' stamp: 'nil'!
superclassName
	"Retrieves the name of the superclass if exists"

	^self annotationNamed: self class superclassNameKey! !

!RGBehaviorDefinition methodsFor: 'operations' stamp: 'nil'!
addCategory: newName before: aCategory

	^ self addProtocol: newName! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
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: 'testing' stamp: 'nil'!
isMeta
	"By default is considered a non-meta class"

	^false! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
traitNames
	"Assuming that traits in a composition can be identified by
	testing for the first character being an uppercase character
	(and thus not a special character such as {, # etc.)"
	| tokens |
	
	tokens := self traitCompositionSource parseLiterals flattened.
	^tokens select: [:each | each first isUppercase].! !

!RGBehaviorDefinition methodsFor: 'accessing - parallel hierarchy' stamp: 'nil'!
instanceSide
	"Return the class of the couple class/metaclass. Useful to avoid explicit test."
	
	^ self subclassResponsibility! !

!RGBehaviorDefinition methodsFor: 'accessing' stamp: 'nil'!
protocols
	"retrieves the protocols of the class"

	^protocols! !

!RGBehaviorDefinition methodsFor: 'subclassing' stamp: 'nil'!
removeSubclass: aRGBehaviorDefinition 
	"Removes aRGAbstractClassDefinition from the direct subclasses - without failing if does not exist"
	
	self subclasses remove: aRGBehaviorDefinition ifAbsent: []! !

!RGBehaviorDefinition methodsFor: 'annotations' stamp: 'nil'!
definitionSource
	"Retrieves the definition template of the receiver -> aString.
	This value is kept as an annotation"
	
	^self annotationNamed: self class definitionSourceKey! !

!RGBehaviorDefinition methodsFor: 'adding/removing methods' stamp: 'nil'!
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: 'accessing - class hierarchy' stamp: 'nil'!
allSuperclassesDo: aBlock

	"Evaluate the argument, aBlock, for each of the receiver's superclasses."

	self superclass ifNil: [ ^ self ].
	aBlock value: superclass.
	superclass allSuperclassesDo: aBlock! !

!RGBehaviorDefinition methodsFor: 'printing' stamp: 'nil'!
storeOn: aStream 
	self name storeOn: aStream! !

!RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'nil'!
superclassNameKey
	
	^#superclassName! !

!RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'nil'!
subclassesKey

	^#subclasses! !

!RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'nil'!
definitionSourceKey

	^#definitionSource! !

!RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'nil'!
allSuperclassesKey

	^#allSuperclasses! !

!RGBehaviorDefinition class methodsFor: 'testing' stamp: 'nil'!
isAbstract

	^ self == RGBehaviorDefinition! !

!RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'nil'!
superclassesKey

	^#superclasses! !

!RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'nil'!
traitCompositionSourceKey

	^#traitCompositionSource! !

!RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'nil'!
usersKey

	^#users! !

!RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'nil'!
allSubclassesKey

	^#allSubclasses! !

!RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'nil'!
isPoolKey

	^#isPool! !

!RGBehaviorFactory commentStamp: ''!
My subclasses are very simple factories that serve as entry point to create different kind of behaviors. There should be no instances of me.

The behaviors are composition of a RGBehavior instances and a strategy that describes a kind of the behavior. The behavior factory only create sach pairs so for example my subclass RGClass creates a composition of RGBehavior instance with a RGClassStrategy. !
!RGBehaviorFactory class methodsFor: 'instance creation' stamp: ''!
named: aString parent: anRGObject

	^ (RGBehavior named: aString parent: anRGObject  behaviorStrategy: (self newStrategyFor: anRGObject environment))
		yourself! !

!RGBehaviorFactory class methodsFor: 'instance creation' stamp: ''!
newStrategy

	self subclassResponsibility ! !

!RGBehaviorFactory class methodsFor: 'instance creation' stamp: ''!
unresolvedNamed: aString withParent: anRGDefintion

	^ RGBehavior unresolvedNamed: aString withParent: anRGDefintion behaviorStrategy: (self newStrategyFor: anRGDefintion environment)! !

!RGBehaviorFactory class methodsFor: 'instance creation' stamp: ''!
parent: anRGObject

	^ (RGBehavior parent: anRGObject behaviorStrategy: (self newStrategyFor: anRGObject environment))
		yourself! !

!RGBehaviorFactory class methodsFor: 'instance creation' stamp: ''!
newStrategyFor: anRGEnvironment

	^ self newStrategy! !

!RGBehaviorFactory class methodsFor: 'instance creation' stamp: ''!
named: aString

	^ (RGBehavior named: aString behaviorStrategy: self newStrategy)
		yourself! !

!RGBehaviorFactory class methodsFor: 'instance creation' stamp: ''!
unresolved

	^ RGBehavior unresolvedWithBehaviorStrategy: self newStrategy
! !

!RGBehaviorFactory class methodsFor: 'instance creation' stamp: ''!
unnamed

	^ RGBehavior unnamedWithBehaviorStrategy: self newStrategy
! !

!RGBehaviorFactory class methodsFor: 'instance creation' stamp: ''!
unresolvedWithParent: anRGDefintion

	^ RGBehavior unresolvedWithParent: anRGDefintion behaviorStrategy: (self newStrategyFor: anRGDefintion environment) ! !

!RGBehaviorStrategy methodsFor: 'accessing - deprecated parallel hierarchy' stamp: ''!
theMetaClass
	"This method is deprecated so consider to migrate."
	
	self
		deprecated: 'Please use #classSide instead'
		transformWith: '`@receiver theMetaClass' -> '`@receiver classSide'.
	
	^ self classSide! !

!RGBehaviorStrategy methodsFor: 'testing' stamp: ''!
isTraitStrategy

	^ false! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
cleanClassVariables

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'utilities' stamp: ''!
unresolvedValue: aDefaultValue

	^ self owner unresolvedValue: aDefaultValue! !

!RGBehaviorStrategy methodsFor: 'utilities' stamp: ''!
environment

	^ self owner environment! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
classTrait

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
removeSharedPool: anRGPoolVariable

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'accessing' stamp: ''!
owner
	^ owner! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
incompatibleBehaviorType

	RGIncompatibleBehaviorTypeError signal! !

!RGBehaviorStrategy methodsFor: 'testing' stamp: ''!
isMetaclassStrategy

	^ false! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
baseBehavior

	^ self owner! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
baseTrait

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'default model values' stamp: ''!
defaultMetaClass

	^ self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'utilities' stamp: ''!
announceDefinitionChangeDuring: aBlock

	self owner announceDefinitionChangeDuring: aBlock! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
instanceVariables: aCollectionOfSymbols

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
comment: anRGComment

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'copying' stamp: ''!
copyForBehaviorDefinitionWithOwner: aNewOwner

	^ self shallowCopy 
		owner: aNewOwner;
		copyForBehaviorDefinitionPostCopy! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
addClassVariable: anRGInstanceVariableDefinition 

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
makeResolved

	"do nothing"
! !

!RGBehaviorStrategy methodsFor: 'testing' stamp: ''!
isClassStrategy

	^ false! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
cleanSharedPools

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
baseClass: anRGClass

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
classTrait: anRGMetaclassTrait

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'testing' stamp: ''!
isMetaclassTrait
	
	^ false! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
addSharedPool: anRGPoolVariable

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
classVariablesDo: aBlock

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'class variables' stamp: ''!
classVariableDefinitionString

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'accessing' stamp: ''!
classSide

	^ self owner! !

!RGBehaviorStrategy methodsFor: 'accessing' stamp: ''!
layout: anRGLayout

	self owner announceDefinitionChangeDuring: [ 
		self backend forBehavior setLayoutFor: self owner to: anRGLayout ].
! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
sharedPools: aCollectionOfSymbols

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
bindingOf: varName

	^ self owner isRootInEnvironment
		ifFalse: [self owner superclass bindingOf: varName]
		ifTrue: [ nil ]! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
category: aString

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'utilities' stamp: ''!
instSize

	^ 0! !

!RGBehaviorStrategy methodsFor: 'testing' stamp: ''!
isMetaclass
	
	^ false! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
baseTrait: anRGClass

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
sharedPoolsDo: aBlock

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'utilities' stamp: ''!
storeName

	self subclassResponsibility ! !

!RGBehaviorStrategy methodsFor: 'variables' stamp: ''!
trait

	^ self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
allClassVariables

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'utilities' stamp: ''!
allSlots

	^ OrderedCollection new! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
removeClassVariable: anRGInstanceVariableDefinition

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'accessing - deprecated parallel hierarchy' stamp: ''!
theNonMetaClass
	"This method is deprecated so consider to migrate."
	
	self
		deprecated: 'Please use #instanceSide instead'
		transformWith: '`@receiver theNonMetaClass' -> '`@receiver instanceSide'.
	
	^ self instanceSide! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
classVariables: aCollectionOfSymbols

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'accessing' stamp: ''!
layout

	^ self backend forBehavior layoutFor: self owner! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
kindOfSubclass
	"Answer a String that is the keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, see #subclassDefiningSymbol"
	
	^ ' ', self layout class subclassDefiningSymbol, ' '! !

!RGBehaviorStrategy methodsFor: 'visiting' stamp: ''!
acceptVisitor: aVisitor

	self subclassResponsibility ! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
instanceVariablesString

	^ String new! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
baseClass

	^ self owner! !

!RGBehaviorStrategy methodsFor: 'utilities' stamp: ''!
backend

	^ self owner backend forBehavior! !

!RGBehaviorStrategy methodsFor: 'utilities' stamp: ''!
sibling

	^ self subclassResponsibility ! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
classVarNames

	^#()! !

!RGBehaviorStrategy methodsFor: 'initialization' stamp: ''!
initializeUnresolved! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
category

	self subclassResponsibility ! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
referencedPackages

	^ Array new! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
classVariables

	self incompatibleBehaviorType! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
referencedBehaviors

	^ { self owner superclass. self owner metaclass}, self owner traitComposition referencedBehaviors! !

!RGBehaviorStrategy methodsFor: 'accessing' stamp: ''!
owner: anObject
	owner := anObject! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
comment

	self subclassResponsibility! !

!RGBehaviorStrategy methodsFor: 'testing' stamp: ''!
isMeta
	"By default a non-meta class is considered"

	^false! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
allClassVarNames

	self subclassResponsibility ! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
innerBindingOf: aSymbol

	^ nil! !

!RGBehaviorStrategy methodsFor: 'accessing - parallel hierarchy' stamp: ''!
instanceSide

	^ self owner! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
sharedPoolNames

	^ OrderedCollection new! !

!RGBehaviorStrategy methodsFor: 'utilities' stamp: ''!
instVarNames

	^ OrderedCollection new! !

!RGBehaviorStrategy methodsFor: 'copying' stamp: ''!
copyForBehaviorDefinitionPostCopy

	super postCopy.
! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
sharedPools

	^ OrderedCollection new! !

!RGBehaviorStrategy methodsFor: 'testing' stamp: ''!
isMetaclassTraitStrategy

	^ false! !

!RGBehaviorStrategy methodsFor: 'utilities' stamp: ''!
pvtResolvableProperties

	^ OrderedCollection new! !

!RGBehaviorStrategy methodsFor: 'private - backend access' stamp: ''!
classVariablesString

	^ String new! !

!RGBehaviorStrategy class methodsFor: 'instance creation' stamp: ''!
unresolved

	^ self basicNew! !

!RGBehaviorStrategyUser commentStamp: ''!
I am an abstract behavior that has a behavior strategy and and delegates all messages to it!
!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
theMetaClass
	self
		deprecated: 'Please use #classSide instead'
		transformWith: '`@receiver theMetaClass' -> '`@receiver classSide'.
	
	^ self classSide! !

!RGBehaviorStrategyUser methodsFor: '*Ring-Monticello' stamp: ''!
asMCDefinition

	^ self behaviorStrategy asMCDefinition! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
cleanClassVariables

	^ self behaviorStrategy cleanClassVariables! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
classTrait

	^ self behaviorStrategy classTrait! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
removeSharedPool: anRGPoolVariable

	^ self behaviorStrategy removeSharedPool: anRGPoolVariable! !

!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
behaviorStrategy
	^ behaviorStrategy! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
package: anRGPackage

	^ self behaviorStrategy package: anRGPackage
! !

!RGBehaviorStrategyUser methodsFor: 'testing' stamp: ''!
isClass

	^ self behaviorStrategy isClass! !

!RGBehaviorStrategyUser methodsFor: 'queries - other' stamp: ''!
baseBehavior

	^ self behaviorStrategy baseBehavior! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
baseTrait

	^ self behaviorStrategy baseTrait! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
defaultMetaClass

	^ self behaviorStrategy defaultMetaClass! !

!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
instanceVariables: aCollectionOfSymbols

	^ self behaviorStrategy instanceVariables: aCollectionOfSymbols! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
comment: anRGComment

	^ self behaviorStrategy comment: anRGComment! !

!RGBehaviorStrategyUser methodsFor: 'accessing - definition' stamp: ''!
definition

	^ self behaviorStrategy definition! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
addClassVariable: anRGInstanceVariableDefinition 

	^ self behaviorStrategy addClassVariable: anRGInstanceVariableDefinition ! !

!RGBehaviorStrategyUser methodsFor: 'resolving' stamp: ''!
makeResolved

	self behaviorStrategy makeResolved.
	super makeResolved.
! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
package

	^ self behaviorStrategy package! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
cleanSharedPools

	^ self behaviorStrategy cleanSharedPools! !

!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
baseClass: anRGClass

	^ self behaviorStrategy baseClass: anRGClass! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
classTrait: anRGMetaclassTrait

	^ self behaviorStrategy classTrait: anRGMetaclassTrait! !

!RGBehaviorStrategyUser methodsFor: 'testing - types' stamp: ''!
isMetaclassTrait

	^ self behaviorStrategy isMetaclassTrait! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
addSharedPool: anRGPoolVariable

	^ self behaviorStrategy addSharedPool: anRGPoolVariable! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
classVariablesDo: aBlock

	^ self behaviorStrategy classVariablesDo: aBlock! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
isTrait

	^ self behaviorStrategy isTrait! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
classVariableDefinitionString

	^ self behaviorStrategy classVariableDefinitionString! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
classSide

	^ self behaviorStrategy classSide! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
layout: anRGLayout

	^ self behaviorStrategy layout: anRGLayout! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
sharedPools: aCollectionOfSymbols

	^ self behaviorStrategy sharedPools: aCollectionOfSymbols! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
traitTransformationString

	^ self behaviorStrategy traitTransformationString! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
bindingOf: varName

	^ self behaviorStrategy bindingOf: varName
! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
category: aString

	^ self behaviorStrategy category: aString! !

!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
instSize

	^ self behaviorStrategy instSize! !

!RGBehaviorStrategyUser methodsFor: 'testing - types' stamp: ''!
isMetaclass

	^ self behaviorStrategy isMetaclass! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
baseTrait: anRGClass

	^ self behaviorStrategy baseTrait: anRGClass! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
sharedPoolsDo: aBlock

	^ self behaviorStrategy sharedPoolsDo: aBlock! !

!RGBehaviorStrategyUser methodsFor: 'variables' stamp: ''!
trait

	"Because of API compatibility between traits and trait transformations"

	^ self behaviorStrategy trait! !

!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
behaviorStrategy: anObject

	| needsInitialization |
	
	needsInitialization := behaviorStrategy isNil.
	behaviorStrategy := anObject.
	behaviorStrategy owner: self.
	needsInitialization ifTrue: [ 
		behaviorStrategy initializeUnresolved ].
	! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
allClassVariables

	^ self behaviorStrategy allClassVariables! !

!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
allSlots

	^ self behaviorStrategy allSlots! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
removeClassVariable: anRGInstanceVariableDefinition

	^ self behaviorStrategy removeClassVariable: anRGInstanceVariableDefinition! !

!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
theNonMetaClass

	self
		deprecated: 'Please use #instanceSide instead'
		transformWith: '`@receiver theNonMetaClass' -> '`@receiver instanceSide'.
	^self instanceSide! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
classVariables: aCollectionOfSymbols

	^ self behaviorStrategy classVariables: aCollectionOfSymbols! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
layout

	^ self behaviorStrategy layout! !

!RGBehaviorStrategyUser methodsFor: 'testing - class hierarchy' stamp: ''!
kindOfSubclass
	"Answer a String that is the keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, see #subclassDefiningSymbol"
	^ self behaviorStrategy kindOfSubclass! !

!RGBehaviorStrategyUser methodsFor: 'visiting' stamp: ''!
acceptVisitor: aVisitor 
	
	^ self behaviorStrategy acceptVisitor: aVisitor! !

!RGBehaviorStrategyUser methodsFor: 'printing' stamp: ''!
instanceVariablesString

	^ self behaviorStrategy instanceVariablesString! !

!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
baseClass

	^ self behaviorStrategy baseClass! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
sibling

	^ self behaviorStrategy sibling! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
classVarNames

	^ self behaviorStrategy classVarNames! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
referencedPackages

	^ self behaviorStrategy referencedPackages! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
category

	^ self behaviorStrategy category! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
classVariables

	^ self behaviorStrategy classVariables! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
referencedBehaviors

	^ self behaviorStrategy referencedBehaviors! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
comment

	^ self behaviorStrategy comment! !

!RGBehaviorStrategyUser methodsFor: 'queries - testing' stamp: ''!
isMeta
	"By default a non-meta class is considered"

	^ self behaviorStrategy isMeta! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
allClassVarNames

	^ self behaviorStrategy allClassVarNames! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
innerBindingOf: aSymbol

	^ self behaviorStrategy innerBindingOf: aSymbol! !

!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
instanceSide

	^ self behaviorStrategy instanceSide! !

!RGBehaviorStrategyUser methodsFor: 'testing' stamp: ''!
sharedPoolNames

	^ self behaviorStrategy sharedPoolNames! !

!RGBehaviorStrategyUser methodsFor: 'accessing' stamp: ''!
instVarNames
	^ self behaviorStrategy instVarNames! !

!RGBehaviorStrategyUser methodsFor: 'strategy' stamp: ''!
sharedPools

	^ self behaviorStrategy sharedPools! !

!RGBehaviorStrategyUser methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	
	^ self behaviorStrategy storeOn: aStream! !

!RGBehaviorTest methodsFor: 'tests' stamp: ''!
testBadInstantiation

	self should: [ RGBehavior named: #SomeBehavior ] raise: RGBadInstantiationError ! !

!RGBehaviorTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGClass unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGBehaviorTest methodsFor: 'tests' stamp: ''!
testUnresolveSuperclass
	| env class1 class2 |
	
	env := RGEnvironment new.
	class1 := env ensureClassNamed: #Superclass.
	class2 := env ensureClassNamed: #Subclass.
	
	self deny: class2 hasResolvedSuperclass. 
	class2 superclass: class1.
	self assert: class2 hasResolvedSuperclass. 
	class2 unresolveSuperclass.
	self deny: class2 hasResolvedSuperclass. 
	
	self assert: class1 subclasses isEmpty.
! !

!RGBehaviorTest methodsFor: 'tests' stamp: ''!
behaviorClass

	^ RGClass! !

!RGBehaviorTest methodsFor: 'tests' stamp: ''!
testOldDefinition
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior oldDefinition equals: 'unresolved subclass: #SomeClass
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''unresolved'''! !

!RGBehaviorTest methodsFor: 'tests' stamp: ''!
testBehaviorWithProtocols
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self assert: (newBehavior hasUnresolvedAll: #(superclass localMethods protocols)).
	self assert: newBehavior methods isEmpty.

	1 to: 10 do: [ :i | newBehavior addMethodTag: ('tag' , i asString) asSymbol ].

	self assert: (newBehavior protocols allSatisfy: #isSymbol).

	self assert: newBehavior protocols size equals: 10.
	(newBehavior protocols first: 4) do: [ :each | newBehavior removeProtocol: each ].
	self assert: newBehavior protocols size equals: 6.
	newBehavior cleanProtocols.
	self assert: newBehavior protocols isEmpty! !

!RGBehaviorTest methodsFor: 'tests' stamp: ''!
testSiblings

	| newBehavior |
	newBehavior := RGClass named: #SomeBehaivor.
	self assert: newBehavior sibling equals: newBehavior metaclass.
	self assert: newBehavior baseBehavior equals: newBehavior.
	self assert: newBehavior instanceSide equals: newBehavior.
	self assert: newBehavior instanceSide equals: newBehavior.

	newBehavior := RGMetaclass named: #SomeBehaivor.
	self assert: newBehavior sibling equals: newBehavior baseClass.
	self assert: newBehavior baseBehavior equals: newBehavior baseClass.
	self assert: newBehavior instanceSide equals: newBehavior baseClass.
	self assert: newBehavior instanceSide equals: newBehavior baseClass.

	newBehavior := RGTrait named: #SomeBehaivor.
	self assert: newBehavior sibling equals: newBehavior classTrait.
	self assert: newBehavior baseBehavior equals: newBehavior.
	self assert: newBehavior instanceSide equals: newBehavior.
	self assert: newBehavior instanceSide equals: newBehavior.

	newBehavior := RGMetaclassTrait named: #SomeBehaivor.
	self assert: newBehavior sibling equals: newBehavior baseTrait.
	self assert: newBehavior baseBehavior equals: newBehavior baseTrait.
	self assert: newBehavior instanceSide equals: newBehavior baseTrait.
	self assert: newBehavior instanceSide equals: newBehavior baseTrait! !

!RGBehaviorTest methodsFor: 'tests' stamp: ''!
testBehaviorWithMethodTags
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self assert: (newBehavior hasUnresolvedAll: #(superclass localMethods protocols)).
	self assert: newBehavior methods isEmpty.

	1 to: 10 do: [ :i | newBehavior addMethodTag: ('tag' , i asString) asSymbol ].

	self assert: (newBehavior hasResolved: #tagsForMethods).

	self assert: (newBehavior tagsForMethods allSatisfy: #isSymbol).

	self assert: newBehavior tagsForMethods size equals: 10.
	(newBehavior tagsForMethods first: 4) do: [ :each | newBehavior removeMethodTag: each ].
	self assert: newBehavior tagsForMethods size equals: 6.
	newBehavior cleanTagsForMethods.
	self assert: newBehavior tagsForMethods isEmpty! !

!RGBitsLayout methodsFor: 'testing - types' stamp: ''!
isBitsLayout

	^ true! !

!RGBitsLayout methodsFor: 'testing - types' stamp: ''!
isVariableLayout

	^ true! !

!RGBitsLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton."
	
	^ #variableWordSubclass:! !

!RGByteLayout methodsFor: '*Ring-Monticello' stamp: ''!
mcType

	^ #bytes ! !

!RGByteLayout methodsFor: 'testing - types' stamp: ''!
isByteLayout

	^ true! !

!RGByteLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton."
	
	^ #variableByteSubclass:! !

!RGChunkImporter commentStamp: ''!
I'm an object holding the result of loading a file containing Pharo code definitions in chunk format.
I create Ring definitions for the elements inside the chunk stream.!
!RGChunkImporter methodsFor: 'private' stamp: ''!
createBehavior: subclassName superclassName: superclassName instanceVariableNames: instanceVariableNames classVariableNames: classVariableNames categoryName: categoryName packageName: packageName poolDictionariesNames: poolDictionariesNames layoutClass: layoutClass layoutDefinition: layoutDefinition slotsDefinition: slotsDefinition traits: traitsDefinition isTrait: isTrait hasNilSuperclass: hasNilSuperclass

	| behavior superclass |
	
	self assert: subclassName notNil.	
		
	isTrait 
		ifTrue: [ 
			superclass := nil.
			behavior := (subclassName endsWith: ' classTrait') 
				ifTrue: [ 
					self environment ensureMetaclassTraitNamed: subclassName ]
				ifFalse: [ 
					self assert: (superclassName = #Trait).
					self environment ensureTraitNamed: subclassName ]]
		ifFalse: [ 
			behavior := self environment ensureClassNamed: subclassName. 
			hasNilSuperclass
				ifTrue: [ behavior superclass: nil. ]
				ifFalse: [
					superclassName ifNotNil: [ 
						| theSuperclass | 
						theSuperclass := self environment ensureClassNamed: superclassName. 
						behavior superclass: theSuperclass ] ] ].

	isTrait ifFalse: [ 
		layoutClass ifNotNil: [ 
			behavior layout: (layoutClass parent: behavior).
			"TODO: unknown layout definition"]].

	slotsDefinition ifNotNil: [ 
		behavior layout: (layoutClass parent: behavior).
		slotsDefinition children do: [:child |
			| newSlot | 
			newSlot := (child isLiteralNode and: [ child value isSymbol ])
				ifTrue: [ RGInstanceVariableSlot named: child value parent: behavior layout ]
				ifFalse: [
					"TODO: probably needs more robust analysis"
					self assert: child isMessage.
					(RGUnknownSlot named: (self slotNameFor: child) parent: behavior layout)
						expression: child formattedCode;
						yourself].
			behavior layout addSlot: newSlot] .].

	"process instance variables after layout and slots"
	instanceVariableNames ifNotNil: [ 
		behavior instanceVariables: (instanceVariableNames substrings collect: [:each | each asSymbol])].

	classVariableNames ifNotNil: [ 
		behavior classVariables: (classVariableNames substrings collect: [:each | each asSymbol]) ].

	poolDictionariesNames ifNotNil: [ 
		behavior sharedPools: (poolDictionariesNames substrings collect: [:each | each asSymbol])].

	categoryName ifNotNil: [ 
		behavior category: categoryName ].

	packageName ifNotNil: [ 
		| pkg |
		pkg := environment ensurePackageNamed: packageName.
		behavior package: pkg ].

	traitsDefinition ifNotNil: [ 
		| composition transformations |
		composition := RGTraitComposition parent: behavior.
		transformations := RGTraitCompositionVisitor new parse: traitsDefinition for: composition.
		behavior traitComposition: composition.
		transformations do: [ :each |
			composition addTransformation: each ].
		].
	! !

!RGChunkImporter methodsFor: 'accessing' stamp: ''!
environment: anRGEnvironment

	environment := anRGEnvironment! !

!RGChunkImporter methodsFor: 'private' stamp: ''!
metaTraitDefinition: string with: chgRec
	| tokens trait |
	
	tokens := self scannedSource: string.
	trait := environment ensureTraitNamed: tokens first.
	
"	trait theMetaClass definitionSource: string"! !

!RGChunkImporter methodsFor: 'accessing' stamp: ''!
environment

	^ environment! !

!RGChunkImporter methodsFor: 'private' stamp: ''!
classNamed: className

	| behavior |
	behavior := self environment ask behaviorNamed: className.
	^ behavior 
		ifNotNil: [ behavior ]
		ifNil: [ self environment ensureClassNamed: className asSymbol. ]
! !

!RGChunkImporter methodsFor: 'accessing' stamp: ''!
packages
	
	^ { package }! !

!RGChunkImporter methodsFor: 'visitor' stamp: ''!
visitMethodChunk: aChunk

	| theClass theMethod theProtocol |
	theClass := self classNamed: aChunk behaviorName.
	aChunk isMeta ifTrue: [ theClass := theClass classSide makeResolved ].

	theMethod := theClass ensureLocalMethodNamed:
		             aChunk methodSelector asSymbol.
	theProtocol := theClass ensureProtocolNamed: aChunk category asSymbol.
	theMethod protocol: theProtocol.
	theMethod sourceCode: aChunk contents.
	theMethod author: (RGStampParser authorForStamp: aChunk stamp).
	theMethod time: (RGStampParser timeForStamp: aChunk stamp)! !

!RGChunkImporter methodsFor: 'private' stamp: ''!
slotNameFor: definitionAST

	^ (definitionAST respondsTo: #receiver)
		ifTrue: [ self slotNameFor: definitionAST receiver  ]
		ifFalse: [ definitionAST value  ]! !

!RGChunkImporter methodsFor: 'private' stamp: ''!
msgClassComment: string with: chgRec

	| tokens theClass |
	tokens := self scannedSource: string.
	
	(tokens size >= 3
		and:[ tokens last isString ])
	ifTrue:[
		theClass := self classNamed: tokens first.
		((tokens at: (tokens size - 1)) == #class
		ifTrue: [ theClass theMetaClass ]
		ifFalse:[ theClass ]) comment: tokens last asString ]! !

!RGChunkImporter methodsFor: 'visitor' stamp: ''!
visitClassCommentChunk: aChunk

	| class comment |
	
	class := self classNamed: aChunk behaviorName.
	comment := RGComment parent: class.
	comment content: aChunk contents.
	comment author: (RGStampParser authorForStamp: aChunk stamp).
	comment time: (RGStampParser timeForStamp: aChunk stamp).
	class comment: comment.
	! !

!RGChunkImporter methodsFor: 'accessing' stamp: ''!
classes
	^ package classes values! !

!RGChunkImporter methodsFor: 'visitor' stamp: ''!
visitClassOrganizationChunk: aChunk

	"Do nothing with class organizations for the moment"! !

!RGChunkImporter methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	environment := RGEnvironment new.
	package := RGPackageDefinition named: 'ChangeSet'.
	doIts := Set new.! !

!RGChunkImporter methodsFor: 'private' stamp: ''!
scannedSource: aString

	^ Smalltalk compiler parseLiterals: aString! !

!RGChunkImporter methodsFor: 'visitor' stamp: ''!
visitDoItChunk: aChunk

	| contents ast layoutClass selectorParts superclassName subclassName instanceVariableNames classVariableNames categoryName packageName poolDictionariesNames layoutDefinition slotsDefinition traitsDefinition isTrait hasNilSuperclass |

	contents := aChunk contents trimBoth.
	(contents endsWith: '!!') ifTrue: [ contents := contents allButLast ].
	
	ast := RBParser parseExpression: contents onError: [ 
		doIts add: aChunk.
		^ self ].
	
	layoutClass := selectorParts := superclassName := subclassName := instanceVariableNames := 
		classVariableNames := categoryName := packageName := poolDictionariesNames := layoutDefinition := 
		slotsDefinition := traitsDefinition := nil.
		
	isTrait := false.
	
	hasNilSuperclass := self isNilSuperclassDefinition: ast.
	hasNilSuperclass 
		ifTrue: [ ast := ast statements first ].	
	
	(ast isMessage and: [self allowedSelectors includes: ast selector]) ifTrue: [ 
		superclassName := ast receiver formattedCode.
		self assert: ast arguments isNotEmpty.
		selectorParts := ast selector findBetweenSubstrings: {$:}.
		
		(superclassName endsWith: ' classTrait') 
			ifTrue: [isTrait := true]. "for usage of #uses:"
		
		"TODO: handle removeSelector:, comment:"

		self if: selectorParts in: ast includes: #subclass do: [:argument |
			subclassName := argument value. 
			layoutClass := RGFixedLayout. ].

		self if: selectorParts in: ast includes: #named do: [:argument |
			subclassName := argument value. 
			isTrait := true.
			layoutClass := RGFixedLayout. ].

		self if: selectorParts in: ast includes: #immediateSubclass do: [:argument |
			subclassName := argument value. 
			layoutClass := RGImmediateLayout ].

		self if: selectorParts in: ast includes: #variableSubclass do: [:argument |
			subclassName := argument value. 
			layoutClass := RGVariableLayout ].

		self if: selectorParts in: ast includes: #variableByteSubclass do: [:argument |
			subclassName := argument value. 
			layoutClass := RGByteLayout ].
		
		self if: selectorParts in: ast includes: #variableWordSubclass do: [:argument |
			subclassName := argument value. 
			layoutClass := RGWordLayout ].

		self if: selectorParts in: ast includes: #weakSubclass do: [:argument |
			subclassName := argument value. 
			layoutClass := RGWeakLayout ].
		
		self if: selectorParts in: ast includes: #ephemeronSubclass do: [:argument |
			subclassName := argument value. 
			layoutClass := RGEphemeronLayout ].
		
		self if: selectorParts in: ast includes: #instanceVariableNames do: [:argument |
			instanceVariableNames := argument value. ].

		self if: selectorParts in: ast includes: #classVariableNames do: [:argument |
			classVariableNames := argument value. ].
		
		self if: selectorParts in: ast includes: #category do: [:argument |
			categoryName := argument value. ].

		self if: selectorParts in: ast includes: #package do: [:argument |
			packageName := argument value. ].
		
		self if: selectorParts in: ast includes: #poolDictionaries do: [:argument |
			poolDictionariesNames := argument value. ].

		self if: selectorParts in: ast includes: #layout do: [:argument |
			layoutDefinition := argument formattedCode. ].

		self if: selectorParts in: ast includes: #slots do: [:argument |
			slotsDefinition := argument "use AST directly". ].

		self if: selectorParts in: ast includes: #uses do: [:argument |
			traitsDefinition := argument formattedCode. ].
		
		hasNilSuperclass ifTrue: [superclassName := nil].
		
		(#(#instanceVariableNames: uses: uses:instanceVariableNames:) includes: ast selector) ifTrue: [ 			subclassName := ast receiver formattedCode asSymbol.
			superclassName := nil ].
		
		(#(CompiledBlock CompiledCode CompiledMethod) includes: subclassName) ifTrue: [ 
			layoutClass := RGCompiledMethodLayout ].
		
		^ self createBehavior: subclassName
			superclassName: superclassName 
			instanceVariableNames: instanceVariableNames 
			classVariableNames: classVariableNames 
			categoryName: categoryName 
			packageName: packageName 
			poolDictionariesNames: poolDictionariesNames 
			layoutClass: layoutClass 
			layoutDefinition: layoutDefinition 
			slotsDefinition: slotsDefinition 
			traits: traitsDefinition 
			isTrait: isTrait
			hasNilSuperclass: hasNilSuperclass.
	].

	doIts add: aChunk. ! !

!RGChunkImporter methodsFor: 'reading' stamp: ''!
fromFileNamed: aName
	
	package := RGPackageDefinition named: aName.
	self fileInFrom: aName asFileReference readStream.! !

!RGChunkImporter methodsFor: 'visitor' stamp: ''!
visitStyleChunk: aChunk

	"Do nothing with styles"! !

!RGChunkImporter methodsFor: 'accessing' stamp: ''!
allowedSelectors 

	^ #(
#ephemeronSubclass:instanceVariableNames:classVariableNames:package:
#ephemeronSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:

#immediateSubclass:instanceVariableNames:classVariableNames:package:
#immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:package:
#immediateSubclass:uses:instanceVariableNames:classVariableNames:package:
#immediateSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:package:

#subclass:
#subclass:instanceVariableNames:
#subclass:instanceVariableNames:classVariableNames:category:
#subclass:instanceVariableNames:classVariableNames:package:
#subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
#subclass:instanceVariableNames:classVariableNames:poolDictionaries:package:

#subclass:layout:slots:classVariables:category:
#subclass:layout:slots:classVariables:poolDictionaries:category:
#subclass:slots:classVariables:category:
#subclass:slots:classVariables:poolDictionaries:category:
#subclass:uses:
#subclass:uses:instanceVariableNames:classVariableNames:category:
#subclass:uses:instanceVariableNames:classVariableNames:package:
#subclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category:
#subclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:package:
#subclass:uses:layout:slots:classVariables:category:
#subclass:uses:layout:slots:classVariables:poolDictionaries:category:
#subclass:uses:slots:classVariables:category:
#subclass:uses:slots:classVariables:poolDictionaries:category:

#variableByteSubclass:instanceVariableNames:classVariableNames:category:
#variableByteSubclass:instanceVariableNames:classVariableNames:package:
#variableByteSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
#variableByteSubclass:uses:instanceVariableNames:classVariableNames:category:
#variableByteSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category:

#variableSubclass:instanceVariableNames:classVariableNames:category:
#variableSubclass:instanceVariableNames:classVariableNames:package:
#variableSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
#variableSubclass:instanceVariableNames:classVariableNames:poolDictionaries:package:
#variableSubclass:uses:instanceVariableNames:classVariableNames:category:
#variableSubclass:uses:instanceVariableNames:classVariableNames:package:
#variableSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category:
#variableSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:package:

#variableWordSubclass:instanceVariableNames:classVariableNames:category:
#variableWordSubclass:instanceVariableNames:classVariableNames:package:
#variableWordSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
#variableWordSubclass:instanceVariableNames:classVariableNames:poolDictionaries:package:
#variableWordSubclass:uses:instanceVariableNames:classVariableNames:category:
#variableWordSubclass:uses:instanceVariableNames:classVariableNames:package:
#variableWordSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category:
#variableWordSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:package:

#weakSubclass:instanceVariableNames:classVariableNames:category:
#weakSubclass:instanceVariableNames:classVariableNames:package:
#weakSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
#weakSubclass:instanceVariableNames:classVariableNames:poolDictionaries:package:
#weakSubclass:uses:instanceVariableNames:classVariableNames:category:
#weakSubclass:uses:instanceVariableNames:classVariableNames:package:
#weakSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category:
#weakSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:package:

#named:
#named:uses:category:
#named:uses:package:

instanceVariableNames:
#uses:
#uses:instanceVariableNames:
)! !

!RGChunkImporter methodsFor: 'reading' stamp: ''!
fileInFrom: aStream

	| changes |
	changes := (CodeImporter readStream: aStream) parseChunks.
	changes do: [ :change | change accept: self ].! !

!RGChunkImporter methodsFor: 'private' stamp: ''!
if: selectorParts in: ast includes: aSymbol do: aBlock

	| index |
	
	index := selectorParts indexOf: aSymbol ifAbsent: [^ self].
	aBlock value: (ast arguments at: index).! !

!RGChunkImporter methodsFor: 'private' stamp: ''!
classDefinition: aString with: chgRec
	| tokens theClass superclass |
	
	tokens := self scannedSource: aString.

	theClass := self classNamed: tokens third.
	theClass metaclass makeResolved.
	superclass := self classNamed: tokens first.
	superclass metaclass makeResolved.
	theClass superclass: superclass.
	theClass metaclass superclass: superclass metaclass.
	
	theClass cleanClassVariables.
	theClass cleanSharedPools.
	
	"theClass definitionSource: aString."
	
	theClass category: tokens last.
	
	tokens size = 11
	ifTrue:[ 
		theClass instanceVariables: (tokens fifth findTokens: ' ');
			 	classVariables: (tokens seventh findTokens: ' ');
				 sharedPools: (tokens ninth findTokens: ' ') ].
	
	tokens size = 13
	ifTrue:[
		RGTraitCompositionVisitor new parse: (tokens fifth) for: theClass traitComposition.
		theClass 
			instanceVariables: (tokens seventh findTokens: ' ');
			classVariables: (tokens ninth findTokens: ' ');
			sharedPools: ((tokens at: 11) findTokens: ' '). ].! !

!RGChunkImporter methodsFor: 'private' stamp: ''!
metaClassDefinition: string with: chgRec
	| tokens theClass |
	
	tokens := self scannedSource: string.
	
	theClass := self classNamed: tokens first.
	theClass theMetaClass instanceVariables: (tokens fourth findTokens: ' ')! !

!RGChunkImporter methodsFor: 'accessing' stamp: ''!
doIts
	^ doIts! !

!RGChunkImporter methodsFor: 'private' stamp: ''!
traitDefinition: aString with: chgRec

	| tokens trait |
	tokens := self scannedSource: aString.
	trait := environment ensureTraitNamed: tokens third.
	"trait superclassName: tokens first;
			 definitionSource: aString;"
	trait category: tokens last! !

!RGChunkImporter methodsFor: 'private' stamp: ''!
createTraitNamed: traitName

	| trait |
	trait := RGTraitDefinition named: traitName.
	trait withMetaclass.
	package addTrait: trait.
	^ trait.! !

!RGChunkImporter methodsFor: 'visitor' stamp: ''!
isNilSuperclassDefinition: ast

	^ (ast isSequence) 
		and: [(ast statements size = 2)
		and: [(ast statements allSatisfy: #isMessage)
		and: [(self allowedSelectors includes: ast statements first selector)
		and: [(ast statements second selector = #superclass:)
		and: [(ast statements second arguments first value isNil)
		and: [((ast statements first arguments first value withoutPrefix: '#') = ast statements second receiver formattedCode)]]]]]]
		! !

!RGChunkImporter class methodsFor: 'instance creation' stamp: ''!
fromStream: aStream

	^ self new fileInFrom: aStream; yourself! !

!RGChunkImporter class methodsFor: 'instance creation' stamp: ''!
fromFileNamed: fileName

	^ self new fromFileNamed: fileName; yourself! !

!RGClass commentStamp: ''!
A factory that produces instances of RG2Behavior composed with RG2ClassStrategy!
!RGClass class methodsFor: 'instance creation' stamp: ''!
newStrategy

	^ RGClassStrategy unresolved! !

!RGClassDefinition commentStamp: ''!
RGClassDefinition is the concrete representation of a class (no trait)!
!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
stamp

	^self hasComment ifTrue:[ self comment stamp ] ifFalse:[ nil ]! !

!RGClassDefinition methodsFor: 'class variables' stamp: 'nil'!
removeClassVarNamed: aString

	self removeVariable: (self classVarNamed: aString) from: classVariables! !

!RGClassDefinition methodsFor: 'accessing - parallel hierarchy' stamp: 'nil'!
classSide
	"Return the metaclass of the couple class/metaclass. Useful to avoid explicit test."
	^ metaClass! !

!RGClassDefinition methodsFor: 'testing' stamp: 'nil'!
hasComment

	^comment isEmptyOrNil not! !

!RGClassDefinition methodsFor: 'shared pools' stamp: 'nil'!
allSharedPools
	"Answer a collection of the pools the receiver shares, including those defined  
	in the superclasses of the receiver."

	^ self hasSuperclass
		ifFalse: [ sharedPools ]
		ifTrue: [ self superclass allSharedPools , sharedPools ]! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
inheritsFrom: aClass

	^ self realClass inheritsFrom: aClass! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
sharedPools: aCollection
	sharedPools := aCollection! !

!RGClassDefinition methodsFor: 'testing' stamp: 'nil'!
hasStamp

	^self stamp isEmptyOrNil not! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
category: aSymbol
	"stores a tag for its package"

	category := aSymbol! !

!RGClassDefinition methodsFor: 'managing pool users' stamp: 'nil'!
removeUser: aRGClassDefinition
	"Removes this RGClassDefinition from the users of the receiver"
	
	aRGClassDefinition isClass ifFalse:[ ^self ].
	aRGClassDefinition instanceSide removeSharedPoolNamed: self name.
	self users remove: aRGClassDefinition instanceSide ifAbsent:[ ]! !

!RGClassDefinition methodsFor: 'behavior' stamp: 'nil'!
withMetaclass
	"Registers explicitly the metaclass of a class"

	metaClass:= RGMetaclassDefinition class: self
! !

!RGClassDefinition methodsFor: 'shared pools' stamp: 'nil'!
addSharedPools: aCollection
	aCollection do: [ :pool | self addSharedPoolNamed: pool ]! !

!RGClassDefinition methodsFor: 'compiling' stamp: 'nil'!
compile: aString classified: aCategory notifying: aController

	self realClass compile: aString classified: aCategory notifying: aController! !

!RGClassDefinition methodsFor: 'managing pool users' stamp: 'nil'!
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: 'behavior' stamp: 'nil'!
withMetaclass: aRGMetaclassDefinition
	"Registers explicitly the metaclass of a class"

	metaClass:= aRGMetaclassDefinition.
	metaClass baseClass: self.  
! !

!RGClassDefinition methodsFor: 'shared pools' stamp: 'nil'!
removeSharedPool: aRGPoolVariableDefinition

	self removeVariable: aRGPoolVariableDefinition from: sharedPools! !

!RGClassDefinition methodsFor: 'class variables' stamp: 'nil'!
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: 'nil'!
removeClassVariable: aRGClassVariableDefinition

	self removeVariable: aRGClassVariableDefinition from: classVariables! !

!RGClassDefinition methodsFor: 'class variables' stamp: 'nil'!
classVarNamed: aString

	^classVariables detect:[ :v| v name = aString asSymbol ] ifNone:[ nil ]! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
package: aRGPackage
	"Sets the package in which this class is contained"
	
	package:= aRGPackage! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
classVariables: aCollection

	classVariables:= aCollection! !

!RGClassDefinition methodsFor: 'managing pool users' stamp: 'nil'!
isPool: aBoolean
	
	^self annotationNamed: self class isPoolKey put: aBoolean! !

!RGClassDefinition methodsFor: 'testing' stamp: 'nil'!
hasMetaclass

	^metaClass notNil! !

!RGClassDefinition methodsFor: 'initialization' stamp: 'nil'!
initialize

	super initialize.
	classVariables:= OrderedCollection new.
	sharedPools:= OrderedCollection new.! !

!RGClassDefinition methodsFor: 'shared pools' stamp: 'nil'!
sharedPoolNamed: poolName

	^sharedPools detect:[ :v| v name = poolName asSymbol ] ifNone:[ nil ]! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
stamp: aString

	self hasComment
	ifTrue: [ self comment stamp: aString ]
	ifFalse:[ RGCommentDefinition new
						 parent: self; 
						 stamp: aString ]! !

!RGClassDefinition methodsFor: 'shared pools' stamp: 'nil'!
allSharedPoolNames
	^ self allSharedPools collect: [ :pool | pool name ]! !

!RGClassDefinition methodsFor: 'class variables' stamp: 'nil'!
classVarNames
	"Answer a collection of the names of the class variables defined in the receiver."
	
	^classVariables collect:[ :cvar| cvar name ]! !

!RGClassDefinition methodsFor: 'managing pool users' stamp: 'nil'!
includesUser: aRGBehaviorDefinition

	^self users includes: aRGBehaviorDefinition! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
category
	"retrieves a tag for its package"
	
	^category! !

!RGClassDefinition methodsFor: 'shared pools' stamp: 'nil'!
addSharedPoolNamed: poolName
	| pool |
	pool:= (RGPoolVariableDefinition named:  poolName) parent: self.
	self addVariable: pool in: sharedPools.
	^pool! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
classVariables

	^classVariables! !

!RGClassDefinition methodsFor: 'managing pool users' stamp: 'nil'!
isPool
	"The receiver is a shared pool if it inherits from SharedPool"
	
	^self annotationNamed: self class isPoolKey 
		ifAbsent: [ self superclassName == #SharedPool ]! !

!RGClassDefinition methodsFor: 'testing' stamp: 'nil'!
isSameRevisionAs: aRGClassDefinition
	"This method look for equality of the properties of the receiver"

	^(super isSameRevisionAs: aRGClassDefinition)
		and:[ self superclassName == aRGClassDefinition superclassName
		and:[ self category = aRGClassDefinition category 
		and:[ self classVarNames sorted = aRGClassDefinition classVarNames sorted 
		and:[ self sharedPoolNames sorted = aRGClassDefinition sharedPoolNames sorted  
		and:[ self traitCompositionSource = aRGClassDefinition traitCompositionSource 
		and:[ ((self hasComment and:[ self comment isSameRevisionAs: aRGClassDefinition comment ]) or:[ self hasComment not ])
		and:[ (self classSide isSameRevisionAs: aRGClassDefinition classSide) ] ] ] ] ] ] ]! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
comment
	"Retrieves the comment definition object"

	^comment! !

!RGClassDefinition methodsFor: 'class variables' stamp: 'nil'!
allClassVarNames

	^self allClassVariables collect:[ :cvar| cvar name ]! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
comment: anObject
	"Sets a RGCommentDefinition object based on the argument"
	
	comment := anObject isRingObject 
		ifFalse: [ 
			RGCommentDefinition new
				parent: self;
				content: anObject; 
				yourself ]
		ifTrue: [anObject ]
	
	 ! !

!RGClassDefinition methodsFor: 'class variables' stamp: 'nil'!
addClassVariables: aCollection
	
	aCollection do: [:var | self addClassVarNamed: var ]! !

!RGClassDefinition methodsFor: 'class variables' stamp: 'nil'!
addClassVarNamed: aString
	| var |
	var := (RGClassVariableDefinition named: aString) parent: self.
	self addVariable: var in: classVariables.
	^var! !

!RGClassDefinition methodsFor: 'class variables' stamp: 'nil'!
addClassVariable: aRCClassVariable

	self addVariable: (aRCClassVariable parent: self) 
		in: classVariables! !

!RGClassDefinition methodsFor: 'managing pool users' stamp: 'nil'!
addUser: aRGClassDefinition

	"The receiver registers the aRGClassDefinition as an user.  An reinforces its status as a shared pool."

	aRGClassDefinition isClass
		ifFalse: [ ^ self ].
	( aRGClassDefinition instanceSide sharedPoolNamed: self name )
		ifNil: [ aRGClassDefinition instanceSide addSharedPoolNamed: self name ].
	self isPool: true.
	self users add: aRGClassDefinition instanceSide! !

!RGClassDefinition methodsFor: 'accessing - parallel hierarchy' stamp: 'nil'!
instanceSide
	"Return the class of the couple class/metaclass. Useful to avoid explicit test."
	^ self! !

!RGClassDefinition methodsFor: 'shared pools' stamp: 'nil'!
removeSharedPoolNamed: poolName

	self removeVariable: (self sharedPoolNamed: poolName) from: sharedPools! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
package
	"Retrieves the package in which this class is contained, if exists"
	
	^package! !

!RGClassDefinition methodsFor: 'shared pools' stamp: 'nil'!
addSharedPool: aRGPoolVariableDefinition
	self 
		addVariable: (aRGPoolVariableDefinition parent: self) 
		in: sharedPools! !

!RGClassDefinition methodsFor: 'shared pools' stamp: 'nil'!
sharedPoolNames
	
	^sharedPools collect:[ :pool| pool name ]! !

!RGClassDefinition methodsFor: 'accessing' stamp: 'nil'!
sharedPools
	"Keeps the pool variable relationship of the receiver"

	^ sharedPools! !

!RGClassDefinition class methodsFor: 'instance creation' stamp: 'nil'!
createSharedPoolNamed: aSymbol
	"A shared pool is a class inheriting from #SharedPool"

	^(RGClassDefinition named: aSymbol)
			superclassName: #SharedPool;
			isPool: true;
			yourself! !

!RGClassDefinitionCompiler methodsFor: 'accessing' stamp: ''!
definitionString
	^ definitionString! !

!RGClassDefinitionCompiler methodsFor: 'public access' stamp: ''!
logged: aBoolean! !

!RGClassDefinitionCompiler methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!RGClassDefinitionCompiler methodsFor: 'instance creation' stamp: ''!
new
	^self! !

!RGClassDefinitionCompiler methodsFor: 'public access' stamp: ''!
requestor: anObject 
	requestor := anObject! !

!RGClassDefinitionCompiler methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!RGClassDefinitionCompiler methodsFor: 'public access' stamp: ''!
source: aString 
	definitionString := aString! !

!RGClassDefinitionCompiler methodsFor: 'accessing' stamp: ''!
definitionString: anObject
	definitionString := anObject! !

!RGClassDefinitionCompiler methodsFor: 'public access' stamp: ''!
evaluate
	
	| importer class createdClass |
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: (definitionString, '!!') readStream.
	
	class := importer environment ask behaviors detect: [:each | 
		each isRingResolved and: [each superclass isRingResolved ]].

	importer := RGChunkImporter new.
	importer environment: environment.
	importer fileInFrom: (definitionString, '!!') readStream.
	
	createdClass := environment ask behaviorNamed: class name.

	createdClass superclass metaclass metaclass isRingResolved ifTrue: [ 
		environment cleanWithMetaclassNamed: createdClass superclass metaclass metaclass name
		].
	^createdClass! !

!RGClassDefinitionCompiler class methodsFor: 'instance creation' stamp: ''!
on: anRGEnvironment 
	^self new 
		environment: anRGEnvironment! !

!RGClassDefinitionTest commentStamp: ''!
SUnit tests for class definitions!
!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testWithComment
	| newClass newComment |
	newClass := RGClassDefinition named: #Object.
	newComment := RGCommentDefinition new
		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 equals: newComment parent.
	self assert: newComment content equals: 'This is a comment for test'.
	self assert: newComment author equals: 'VeronicaUquillas'.
	self assert: newComment timeStamp equals: '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: ''!
testAsClassDefinitionSourceDefinition
	| newClass |
	newClass := MOPTestClassC asRingDefinition.
	self
		assert: newClass definitionSource 
		equals: (ClassDefinitionPrinter new for: MOPTestClassC) definitionString.

	self
		assert: newClass classSide definitionSource
		equals: (ClassDefinitionPrinter new for: MOPTestClassC class) definitionString! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testAsClassDefinition2
	| newClass |
	newClass := MOPTestClassC asRingDefinition.

	self assert: newClass isRingObject.
	self assert: newClass isClass.
	self assert: newClass name identicalTo: #MOPTestClassC.
	self assert: newClass category notNil.
	self assert: newClass superclassName notNil.
	self assert: newClass traitCompositionSource equals: 'Trait2'.

	self assert: newClass classSide isRingObject.
	self assert: newClass classSide isClass.
	self assert: newClass classSide traitCompositionSource equals: 'Trait2 classTrait'! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testWithDefaultNamespace
	| newClass |
	newClass := RGClassDefinition named: #Object.

	self assert: newClass parent equals: Smalltalk globals.
	self assert: newClass realClass equals: Object! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testWithPoolDictionaries
	| newClass poolVar |
	newClass := (RGClassDefinition named: #Text)
		addSharedPoolNamed: #TextConstants;
		yourself.

	self assert: newClass sharedPools size equals: 1.
	self assert: newClass sharedPoolNames size equals: 1.
	self assert: newClass allSharedPools size equals: 1.	"no hierarchy"
	self assert: newClass allSharedPoolNames size equals: 1.

	poolVar := newClass sharedPoolNamed: #TextConstants.
	self assert: poolVar notNil.
	self assert: poolVar isPoolVariable.
	self assert: poolVar isVariable.
	self assert: poolVar parent equals: newClass.
	self assert: poolVar parentName identicalTo: newClass name.
	self assert: poolVar realClass equals: Text.

	newClass withMetaclass.
	self assert: newClass classSide allSharedPoolNames size equals: 1.

	newClass removeSharedPoolNamed: #TextConstants.
	self assertEmpty: newClass sharedPools! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testWithInstanceVariables
	| newClass instVar |
	newClass := RGClassDefinition named: #OrderedCollection.
	newClass addInstanceVariables: #(array firstIndex).
	newClass addInstVarNamed: #lastIndex.

	self assert: newClass instanceVariables size equals: 3.
	self assert: newClass instVarNames size equals: 3.
	self assert: newClass allInstVarNames size equals: 3.

	instVar := newClass instanceVariableNamed: #firstIndex.
	self assert: instVar notNil.
	self assert: instVar parent equals: newClass.
	self assert: instVar isInstanceVariable.
	self assert: instVar isVariable.
	self assert: instVar parentName identicalTo: newClass name.
	self assert: instVar realClass equals: OrderedCollection.

	newClass removeInstVarNamed: #array.
	self assert: newClass instanceVariables size equals: 2.
	self assert: (newClass instanceVariableNamed: #array) isNil! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testWithProtocols
	| newMethod newClass |
	newClass := RGClassDefinition named: #OrderedCollection.
	newMethod := (RGMethodDefinition named: #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 equals: 2.
	self assert: (newClass includesProtocol: 'accessing').
	self assert: (newClass methodsInProtocol: 'adding') size equals: 1.
	self assertEmpty: (newClass methodsInProtocol: 'accessing')! !

!RGClassDefinitionTest methodsFor: '*Ring-Definitions-Tests-Monticello' stamp: ''!
testAsFullClassDefinition
	| rgClass |
	rgClass := Class asRingDefinition.
	self assertEmpty: rgClass methods.
	self assert: rgClass superclass isNil.
	self assertEmpty: rgClass subclasses.
	self assert: rgClass package name equals: #Kernel.

	rgClass := Class asFullRingDefinition.
	self denyEmpty: rgClass methods.
	self assert: (rgClass methodNamed: #asRingDefinition) package name equals: #'Ring-Definitions-Core'.
	self assert: rgClass superclass notNil.
	self assert: rgClass superclass name equals: #ClassDescription.
	self denyEmpty: rgClass subclasses.
	self assert: rgClass package notNil.
	self assert: rgClass package equals: rgClass instanceSide package.
	self assert: rgClass package name equals: #Kernel.
	self assert: rgClass category equals: #'Kernel-Classes'.
	self denyEmpty: rgClass extensionMethods.

	self assert: rgClass superclass superclass isNil.
	self assert: rgClass superclass package name equals: #Kernel.
	self assert: rgClass subclasses first package name equals: #Kernel.

	rgClass := RGClassDefinition classSide asFullRingDefinition.
	self assert: rgClass package equals: rgClass instanceSide package! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testNonExistingClass
	| newClass |
	newClass := RGClassDefinition named: #Connection.
	self assert: newClass isClass.
	self assertEmpty: newClass instanceVariables.
	self assertEmpty: newClass classVariables.
	self assertEmpty: newClass sharedPools.
	self assert: newClass hasMetaclass not.
	self assert: newClass hasComment not.
	self assert: newClass hasStamp not.
	self assert: newClass parent equals: 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: ''!
testStoreOn
	| st |
	st := String
		streamContents: [ :s | 
			Point asRingDefinition storeOn: s.
			s contents ].
	self assert: st equals: '(RGClassDefinition named: #Point)'.

	st := String
		streamContents: [ :s | 
			Point class asRingDefinition storeOn: s.
			s contents ].
	self assert: st equals: '((RGMetaclassDefinition named: #''Point class'') baseClass:(RGClassDefinition named: #Point))'! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testReadFrom
	| st rg |
	rg := Point asRingDefinition.
	st := String
		streamContents: [ :s | 
			rg storeOn: s.
			s contents ].
	self assert: (Object readFrom: st) equals: rg.

	rg := Point class asRingDefinition.
	st := String
		streamContents: [ :s | 
			rg storeOn: s.
			s contents ].
	self assert: (Object readFrom: st) equals: rg! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testWithCategory
	| newClass |
	newClass := (RGClassDefinition named: #Object)
		category: 'Kernel-Objects';
		yourself.

	self assert: newClass package isNil.
	self assert: newClass category equals: 'Kernel-Objects'! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testWithClassInstanceVariables
	| newClass metaClass classInstVar |
	newClass := RGClassDefinition named: #HashTableSizes.
	newClass withMetaclass.
	metaClass := newClass classSide.
	metaClass addInstanceVariables: #(sizes).

	self assert: metaClass instanceVariables size equals: 1.
	self assert: metaClass instVarNames size equals: 1.
	self assert: metaClass allInstVarNames size equals: 1.

	classInstVar := metaClass instanceVariableNamed: #sizes.
	self assert: classInstVar notNil.
	self assert: classInstVar parent equals: metaClass.
	self assert: classInstVar isClassInstanceVariable.
	self assert: classInstVar isVariable.
	self assert: classInstVar parentName equals: metaClass name.
	self assert: classInstVar realClass equals: HashTableSizes class.

	metaClass removeInstVarNamed: #sizes.
	self assertEmpty: metaClass instanceVariables.
	self assert: (metaClass instanceVariableNamed: #sizes) isNil! !

!RGClassDefinitionTest methodsFor: '*Manifest-Tests' stamp: ''!
testArrayStringForManifest
	| class |
	class := self class.

 	self
		assert: class asRingDefinition arrayStringForManifest
		equals: { #RGClassDefinition . { class name asSymbol } }! !

!RGClassDefinitionTest methodsFor: '*Manifest-Tests' stamp: ''!
testManifestReadOn
	| class |
	class := self class.

 	self
		assert: (RGClassDefinition manifestReadOn: { class name asSymbol })
		equals: class asRingDefinition! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testExistingClass
	| newClass metaClass |
	newClass := RGClassDefinition named: #OrderedCollection.
	self assert: newClass isClass.
	self assert: newClass isDefined.
	self assert: newClass realClass equals: OrderedCollection.
	self assert: newClass isMeta not.

	newClass withMetaclass.
	self assert: newClass hasMetaclass.
	metaClass := newClass classSide.
	self assert: metaClass isMeta.
	self assert: metaClass name equals: 'OrderedCollection class'.
	self assert: metaClass instanceSide equals: newClass.
	self assert: metaClass realClass equals: OrderedCollection class! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testAsRingDefinition
	self assert: OrderedCollection asRingDefinition asRingDefinition isRingObject! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testClassEquality
	| newClass |
	self assert: OrderedCollection asRingDefinition equals: OrderedCollection asRingDefinition.

	newClass := OrderedCollection asRingDefinition category: #Kernel.
	self assert: OrderedCollection asRingDefinition equals: newClass! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testWithSuperclass
	| newClass supClass |
	supClass := (RGClassDefinition named: #Object)
		superclassName: #ProtoObject;
		yourself.

	self assert: supClass hasSuperclass not.
	self assert: supClass superclassName identicalTo: #ProtoObject.	"kept as annotation"
	self assert: supClass annotations size equals: 1.

	newClass := (RGClassDefinition named: #OrderedCollection) superclass: supClass.
	self assert: newClass superclass equals: supClass.
	self assert: newClass superclassName identicalTo: #Object.
	self assert: newClass withAllSuperclasses size equals: 2.
	self assert: newClass allSuperclasses size equals: 1.

	self assert: supClass subclasses size equals: 1.
	self assert: supClass withAllSubclasses size equals: 2.
	self assert: supClass allSubclasses size equals: 1! !

!RGClassDefinitionTest methodsFor: '*Ring-Definitions-Tests-Monticello' stamp: ''!
testAsClassDefinition3
	| newClass newSlice |
	newClass := OrderedCollection
		asRingDefinitionWithMethods: true
		withSuperclasses: false
		withSubclasses: false
		withPackages: false.
	newSlice := newClass environment.
	self assert: newClass methods size equals: OrderedCollection methods size.
	self assert: newSlice isSlice.
	self assert: newSlice classes size equals: 1.
	self assert: (newSlice classNamed: #OrderedCollection) equals: newClass.

	newClass := OrderedCollection
		asRingDefinitionWithMethods: false
		withSuperclasses: true
		withSubclasses: false
		withPackages: false.
	newSlice := newClass environment.
	self assert: newClass superclass isRingObject.
	self assert: newClass superclass name equals: OrderedCollection superclass name.
	self assert: newClass allSuperclasses size equals: OrderedCollection allSuperclasses size.
	self assert: newClass superclass equals: (newSlice classNamed: newClass superclassName).

	newClass := RGBehaviorDefinition
		asRingDefinitionWithMethods: false
		withSuperclasses: false
		withSubclasses: true
		withPackages: false.
	newSlice := newClass environment.
	self assert: newClass subclasses size equals: RGBehaviorDefinition subclasses size.
	self assert: newClass allSubclasses size equals: 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 equals: #'Ring-Definitions-Core'.
	self assert: (newSlice packageNamed: #'Ring-Definitions-Core') equals: newClass package.
	self assert: newClass package classes size equals: 1.
	self assert: newClass package classes values first equals: newClass.

	newClass := Class
		asRingDefinitionWithMethods: true
		withSuperclasses: false
		withSubclasses: false
		withPackages: true.
	newSlice := newClass environment.
	self assert: newClass package name equals: #Kernel.
	self assert: newClass extensionMethods notEmpty.
	self assert: newSlice methods size equals: newClass methods size + newClass classSide methods size.
	self assert: (newSlice packageNamed: #'Ring-Definitions-Core') methods size > 1! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testWithClassVariables
	| newClass classVar |
	newClass := (RGClassDefinition named: #Object)
		addClassVariables: #(DependentsFields);
		addClassVarNamed: #FakeVariable;
		yourself.

	self assert: newClass classVariables size equals: 2.
	self assert: newClass classVarNames size equals: 2.
	self assert: newClass allClassVarNames size equals: 2.	"no hierarchy"

	classVar := newClass classVarNamed: #DependentsFields.
	self assert: classVar notNil.
	self assert: classVar isClassVariable.
	self assert: classVar isVariable.
	self assert: classVar parent equals: newClass.
	self assert: classVar parentName identicalTo: newClass name.
	self assert: classVar realClass equals: Object.

	newClass withMetaclass.
	self assert: newClass classSide allClassVarNames size equals: 2.

	newClass removeClassVarNamed: #DependentsFields.
	self assert: newClass classVariables size equals: 1! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testAsClassDefinition
	| newClass |
	newClass := OrderedCollection asRingDefinition.

	self assert: newClass isRingObject.
	self assert: newClass isClass.
	self assert: newClass name identicalTo: #OrderedCollection.
	self assert: newClass category notNil.
	self assert: newClass superclassName notNil.

	self assert: newClass classSide isRingObject.
	self assert: newClass classSide isClass! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testRemovingMethods
	| newMethod newClass |
	newClass := RGClassDefinition named: #OrderedCollection.
	newMethod := (RGMethodDefinition named: #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 asSet equals: #(add: size) asSet.
	newClass removeSelector: #join:.
	self assert: newClass selectors asSet equals: #(add: size) asSet.
	newClass removeMethod: newMethod.
	self assert: (newClass includesSelector: #add:) not.
	newClass removeSelector: #size.
	self assert: newClass hasMethods not! !

!RGClassDefinitionTest methodsFor: 'testing' stamp: ''!
testAddingMethods
	| newMethod newClass |
	newClass := RGClassDefinition named: #OrderedCollection.
	newMethod := (RGMethodDefinition named: #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 asSet equals: #(add: size) asSet.
	self assert: (newClass includesSelector: #add:).
	self assert: (newClass methodNamed: #add:) equals: newMethod.
	self assert: newClass methods size equals: 2.
	self assert: newClass selectors size equals: 2.
	self assert: newClass allSelectors size equals: 2.	"no hierarchy"

	newMethod := newClass methodNamed: #size.
	self assert: newMethod parent equals: newClass.

	self assert: (newClass compiledMethodNamed: #size) notNil.
	self assert: (newClass compiledMethodNamed: #fakeMethod) isNil! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testCreationByParent

	| anRGBehavior parent |
	
	parent := RGEnvironment	new.
	anRGBehavior := RGClass parent: parent.
	self checkBasicPropertiesOf: anRGBehavior.
	self assert: (anRGBehavior hasResolvedName) not.
	self assert: anRGBehavior parent equals: parent.! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testEmtpyClassVariableString

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	self assert: anRGBehavior classVariablesString equals: ''.
! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testSharedPools

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	
	self assert: anRGBehavior sharedPools isEmpty.! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testUnresolvedClassGroupCreatorProperties

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	self assert: (anRGBehavior superclass propertyNamed: #creator) equals: anRGBehavior.
	self assert: (anRGBehavior metaclass propertyNamed: #creator) equals: anRGBehavior.
	self assert: (anRGBehavior metaclass superclass propertyNamed: #creator) equals: anRGBehavior.
! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testClassDescriptionResolvableProperties

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	
	self assert: (anRGBehavior pvtResolvableProperties asDictionary includesKey: #layout)! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testCopyForBehaviorDefinitionPostCopy
	| anRGBehavior copy |
	anRGBehavior := RGBehavior newClass.
	copy := anRGBehavior copyForBehaviorDefinition.
	self deny: anRGBehavior behaviorStrategy identicalTo: copy behaviorStrategy.
	self deny: (anRGBehavior behaviorStrategy instVarNamed: #layout) identicalTo: (copy behaviorStrategy instVarNamed: #layout)
	"TODO: check this failing case:"
	"	self deny: anRGBehavior behaviorStrategy layout == copy behaviorStrategy layout."! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testCreationByUnresolved

	| anRGBehavior |
	
	anRGBehavior := RGClass unresolved.
	self checkBasicPropertiesOf: anRGBehavior.
	self assert: (anRGBehavior hasResolvedName) not.
	self assert: anRGBehavior isRingResolved not.
! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testCreationByMethod

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	self checkBasicPropertiesOf: anRGBehavior! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testKindOfSubclass

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	
	self assert: anRGBehavior kindOfSubclass equals: ' subclass: '.! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testCreationByNamed

	| anRGBehavior |
	
	anRGBehavior := RGClass named: #SomeClass.
	self checkBasicPropertiesOf: anRGBehavior.
	self assert: anRGBehavior name equals: #SomeClass.
! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testInstSize

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	
	anRGBehavior instanceVariables: #(a b c).
	
	self assert: anRGBehavior instSize equals: 3.! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
checkBasicPropertiesOf: anRGBehavior

	self assert: anRGBehavior isBehavior.	
	self assert: anRGBehavior behaviorStrategy isClassStrategy.
	self assert: anRGBehavior behaviorStrategy owner equals: anRGBehavior.
	self assert: anRGBehavior layout isRingResolved not.
	self assert: anRGBehavior layout isFixedLayout.

	! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testClassDescriptionMakeResolved

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	
	self deny: (anRGBehavior hasResolved: #layout).
	anRGBehavior makeResolved.
	self assert: (anRGBehavior hasResolved: #layout).
	
	! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testCreationByUnresolvedNamed

	| anRGBehavior parent |
	
	parent := RGEnvironment	new.
	anRGBehavior := RGClass unresolvedNamed: #SomeClass withParent: parent.
	self checkBasicPropertiesOf: anRGBehavior.
	self assert: anRGBehavior name equals: #SomeClass.
	self assert: anRGBehavior parent equals: parent.
	self assert: anRGBehavior isRingResolved not.
	! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testLayout

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	self assert: anRGBehavior layout isPointerLayout ! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testDefaultMetaclass

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	self assert: anRGBehavior defaultMetaClass isMeta ! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testUnresolvedClassGroupRoleProperties

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	self assert: (anRGBehavior superclass propertyNamed: #role) equals: #superclass.
	self assert: (anRGBehavior metaclass propertyNamed: #role) equals: #metaclass.
	self assert: (anRGBehavior metaclass superclass propertyNamed: #role) equals: #superclassMetaclass.
! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testSetInstanceVariables

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	
	anRGBehavior instanceVariables: #(a b c).
	
	self assert: anRGBehavior instVarNames equals: #(a b c).! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testInstanceVariablesString

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	
	anRGBehavior instanceVariables: #(a b c).
	
	self assert: anRGBehavior instanceVariablesString equals: 'a b c'.! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testDefaultLayout

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	self assert: anRGBehavior defaultLayout isPointerLayout ! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testCreationByNamedParent

	| anRGBehavior parent |
	
	parent := RGEnvironment	new.
	anRGBehavior := RGClass named: #SomeClass parent: parent.
	self checkBasicPropertiesOf: anRGBehavior.
	self assert: anRGBehavior name equals: #SomeClass.
	self assert: anRGBehavior parent equals: parent.
! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testLayoutSet

	| anRGBehavior layout |
	
	anRGBehavior := RGBehavior newClass.
	layout := RGCompiledMethodLayout parent: anRGBehavior.
	anRGBehavior layout: layout.
	self assert: anRGBehavior layout equals: layout.! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testCreationByUnnamed

	| anRGBehavior |
	
	anRGBehavior := RGClass unnamed.
	self checkBasicPropertiesOf: anRGBehavior.
	self assert: (anRGBehavior hasResolvedName) not.
! !

!RGClassDescripitonStrategyTest methodsFor: 'tests' stamp: ''!
testAllSlots

	| env aSuperclass aSubclass |
	
	env := RGEnvironment new.
	aSuperclass := env ensureClassNamed: 'Superclass'.
	aSubclass := env ensureClassNamed: 'Subclass'.
	aSubclass superclass: aSuperclass.

	aSuperclass instanceVariables: #(a b c).
	aSubclass instanceVariables: #(d e f).
	
	self assert: (aSubclass allSlots collect: [:each | each name]) equals: #(a b c d e f).! !

!RGClassDescriptionDefinition commentStamp: ''!
RGClassDescriptionDefinition is the common parent for classes and metaclasses defining instance variables!
!RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'nil'!
removeInstanceVariable: aRGVariableDefinition
	"aRGVariableDefinition is a instance variable or class instance variable"

	self removeVariable: aRGVariableDefinition from: instanceVariables! !

!RGClassDescriptionDefinition methodsFor: 'comparing' stamp: 'nil'!
= aRGClassDefinition

	^self class = aRGClassDefinition class 
		and: [ self name = aRGClassDefinition name 
			and: [ self environment = aRGClassDefinition environment ] ]! !

!RGClassDescriptionDefinition methodsFor: 'initialization' stamp: 'nil'!
initialize

	super initialize.
	instanceVariables:= OrderedCollection new.! !

!RGClassDescriptionDefinition methodsFor: 'comparing' stamp: 'nil'!
hash

	^self name hash bitXor: self class hash! !

!RGClassDescriptionDefinition methodsFor: 'accessing - methods' stamp: 'nil'!
methodsInProtocol: aString
	"Retrieves the methods classified in protocol named aString"

	^methods select: [ :each | each protocol = aString ]! !

!RGClassDescriptionDefinition methodsFor: 'testing' stamp: 'nil'!
isSameRevisionAs: aRGClassDescriptionDefinition
	"This method look for equality of the properties of the receiver"
	"Instances variables are compared at the level of names but without any sorting"

	^(super isSameRevisionAs: aRGClassDescriptionDefinition)
		and:[ self instVarNames sort = aRGClassDescriptionDefinition instVarNames sort ]! !

!RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'nil'!
addInstVarNamed: aString
	| var |
	var := ((self isMeta 
				ifTrue: [ RGClassInstanceVariableDefinition ]
				ifFalse:[  RGInstanceVariableDefinition ])
		named: aString) parent: self.
	self addVariable: var in: instanceVariables.
	^var! !

!RGClassDescriptionDefinition methodsFor: 'testing' stamp: 'nil'!
isClass

	^true! !

!RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'nil'!
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: 'nil'!
instanceVariableNamed: aString
	^ instanceVariables 
		detect: [ :v | v name = aString asSymbol ] 
		ifNone: [ nil ]! !

!RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'nil'!
allInstVarNames

	^self allInstanceVariables collect:[ :ivar| ivar name ]! !

!RGClassDescriptionDefinition methodsFor: 'organization' stamp: 'nil'!
organization
	"Answer the instance of ClassOrganizer that represents the organization 
	of the messages of the receiver."

	organization ifNil: [
		self organization: (ClassOrganization forClass: self) ].
	"Making sure that subject is set correctly. It should not be necessary."
	organization ifNotNil: [ organization setSubject: self ].
	^ organization! !

!RGClassDescriptionDefinition methodsFor: 'accessing' stamp: 'nil'!
instanceVariables

	^instanceVariables! !

!RGClassDescriptionDefinition methodsFor: 'private' stamp: 'nil'!
removeVariable: aRGVariableDefinition from: aCollection
	"Removes a variable from a particular collection.
	This behavior is the same for any kind of variable"
	aCollection remove: aRGVariableDefinition ifAbsent:[]! !

!RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'nil'!
removeInstVarNamed: aString

	self removeVariable: (self instanceVariableNamed: aString) from: instanceVariables! !

!RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'nil'!
addInstanceVariable: aRGVariableDefinition
	"aRGVariableDefinition is a instance variable or class instance variable"

	self addVariable: (aRGVariableDefinition parent: self)
		in: instanceVariables! !

!RGClassDescriptionDefinition methodsFor: 'accessing' stamp: 'nil'!
instanceVariables: aCollection

	instanceVariables:= aCollection! !

!RGClassDescriptionDefinition methodsFor: 'accessing' stamp: 'nil'!
extendingPackages

	^ self realClass extendingPackages! !

!RGClassDescriptionDefinition methodsFor: 'accessing' stamp: 'nil'!
organization: aClassOrg
	"Install an instance of ClassOrganizer that represents the organization of the messages of the receiver."

	aClassOrg ifNotNil: [aClassOrg setSubject: self].
	organization := aClassOrg! !

!RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'nil'!
addInstanceVariables: aCollection
	
	aCollection do: [:var | self addInstVarNamed: var ]! !

!RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'nil'!
instVarNames
	"Answer a collection of the names of the instance variables defined in the receiver."
	
	^instanceVariables collect:[ :ivar| ivar name ]! !

!RGClassDescriptionDefinition methodsFor: 'private' stamp: 'nil'!
addVariable: aRGVariableDefinition in: aCollection
	"Adds a RGVariableDefinition in the collection received" 

	aCollection add: aRGVariableDefinition! !

!RGClassDescriptionDefinition methodsFor: 'printing' stamp: 'nil'!
storeOn: aStream
	aStream
		nextPutAll: '(';
		nextPutAll: self class name;
		nextPutAll: ' named: '.
	name storeOn: aStream.
	aStream nextPut: $)! !

!RGClassDescriptionDefinition methodsFor: '*Manifest-Core' stamp: ''!
arrayStringForManifest
	| array |
	array := Array new: 2.
	array at: 1 put: self class asString asSymbol.
	array at: 2 put: {(name asSymbol)}.
	^ array! !

!RGClassDescriptionDefinition class methodsFor: '*Manifest-Core' stamp: ''!
manifestReadOn: aArray

	^ self named: aArray first! !

!RGClassDescriptionDefinition class methodsFor: 'testing' stamp: 'nil'!
isAbstract

	^ self == RGClassDescriptionDefinition! !

!RGClassDescriptionStrategy methodsFor: 'private - backend interface' stamp: ''!
pvtLayout

	^ layout value! !

!RGClassDescriptionStrategy methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	layout := self unresolvedValue: self defaultLayout. 
	self owner environment backend createUnresolvedClassGroupFor: self owner.! !

!RGClassDescriptionStrategy methodsFor: 'accessing' stamp: ''!
instanceVariablesString
	"Answer a string of my instance variable names separated by spaces."

	^String streamContents: [ :stream |
		self instVarNames 
			do: [ :each | stream nextPutAll: each ]
			separatedBy: [ stream space ] ]! !

!RGClassDescriptionStrategy methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	layout := self unresolvedValue: self defaultLayout.
! !

!RGClassDescriptionStrategy methodsFor: 'initialization' stamp: ''!
instSize

	^ self owner allInstVarNames size! !

!RGClassDescriptionStrategy methodsFor: 'accessing' stamp: ''!
instanceVariables: aCollectionOfSymbols

	"specify instance variable names"

	(self owner hasUnresolved: #layout)
		ifTrue: [ self layout: (RGFixedLayout parent: self)].
		
	(self layout isPointerLayout not and: [ aCollectionOfSymbols isEmpty ])
		ifTrue: [ ^ self ].
		
	self layout cleanSlots.

	aCollectionOfSymbols do: [ :instVarName |
		layout addSlot: (RGInstanceVariableSlot named: instVarName asSymbol parent: self)].! !

!RGClassDescriptionStrategy methodsFor: 'initialization' stamp: ''!
defaultLayout

	^ self owner defaultFixedLayoutStubIn: self.! !

!RGClassDescriptionStrategy methodsFor: 'utilities' stamp: ''!
allSlots

	| superclassSlots aSuperclass |
	aSuperclass := self owner superclass.
	superclassSlots := OrderedCollection new.
	((aSuperclass == self owner) or: [aSuperclass isNil ]) ifFalse: [ 
		 superclassSlots addAll: aSuperclass allSlots ].
	^ (superclassSlots, self layout allSlots) asArray.! !

!RGClassDescriptionStrategy methodsFor: 'initialization' stamp: ''!
instVarNames
	^ self layout instVarNames! !

!RGClassDescriptionStrategy methodsFor: 'copying' stamp: ''!
copyForBehaviorDefinitionPostCopy

	super copyForBehaviorDefinitionPostCopy.
	layout := self layout copyForBehaviorDefinition.
	layout parent: self owner.
! !

!RGClassDescriptionStrategy methodsFor: 'private - backend interface' stamp: ''!
makeResolved

	super makeResolved. 
	
	layout := self layout makeResolved markAsRingResolved.
! !

!RGClassDescriptionStrategy methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream
		nextPutAll: '(';
		nextPutAll: self storeName;
		nextPutAll: ' named: '.
	self owner  name storeOn: aStream.
	aStream nextPut: $)! !

!RGClassDescriptionStrategy methodsFor: 'private - backend interface' stamp: ''!
pvtLayout: anRGLayout

	self environment verifyOwnership: anRGLayout.

	^ layout := anRGLayout! !

!RGClassDescriptionStrategy methodsFor: 'private - backend interface' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#layout -> layout. 
     	}! !

!RGClassDescriptionStrategy methodsFor: 'initialization' stamp: ''!
classVariablesString
	"Answer a string of my class variable names separated by spaces."

	^ String streamContents: [ :stream | 
		self owner classVarNames 
			do: [ :each | stream nextPutAll: each ]
			separatedBy: [ stream space ] ]! !

!RGClassDescriptionTest methodsFor: 'tests' stamp: ''!
behaviorClass

	^ RGClass! !

!RGClassInstanceVariableDefinition commentStamp: ''!
A class instance variable definition!
!RGClassInstanceVariableDefinition methodsFor: 'initialization' stamp: 'nil'!
initialize 

	super initialize.
	self isMetaSide: true.! !

!RGClassInstanceVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isClassInstanceVariable

	^true! !

!RGClassStrategy methodsFor: '*Ring-Monticello' stamp: ''!
mcType

	^ self layout mcType! !

!RGClassStrategy methodsFor: '*Ring-Monticello' stamp: ''!
classPool

	"TODO"
	^ Dictionary newFrom: (self classVarNames collect: [ :each | each -> nil ])! !

!RGClassStrategy methodsFor: 'enumerating' stamp: ''!
pvtSharedPoolsDo: aBlock

	sharedPools value do: aBlock! !

!RGClassStrategy methodsFor: '*Ring-Monticello' stamp: ''!
asMCDefinition

	^ MCClassDefinition 
		name: self owner name
		superclassName: (self owner superclass ifNil: [ 'nil' ] ifNotNil: [ :aSuperclass | aSuperclass name ])
		traitComposition: self owner traitCompositionString 
		classTraitComposition: self owner metaclass traitCompositionString
		category: self owner category 
		instVarNames: self instVarNames
		classVarNames: self owner classVarNames
		poolDictionaryNames: self owner sharedPoolNames
		classInstVarNames: self owner metaclass instVarNames
		type: self mcType
		comment: self owner comment content
		commentStamp: self owner comment stamp! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
cleanClassVariables

	self owner announceDefinitionChangeDuring: [ 
		self backend forBehavior cleanClassVariablesFor: self owner ].! !

!RGClassStrategy methodsFor: 'default model values' stamp: ''!
defaultSharedPools

	^ OrderedCollection new

	! !

!RGClassStrategy methodsFor: 'testing' stamp: ''!
pvtPackage: anRGPackage

	self owner environment verifyOwnership: anRGPackage.

	^ package := anRGPackage! !

!RGClassStrategy methodsFor: 'default model values' stamp: ''!
defaultPackage

	^ self owner defaultPackageStubIn: self environment

	! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtClassVariablesDo: aBlock

	classVariables value do: aBlock! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
removeSharedPool: anRGPoolVariable

	self owner announceDefinitionChangeDuring: [ 
		self backend forBehavior removeSharedPool: anRGPoolVariable from: self owner].! !

!RGClassStrategy methodsFor: 'testing' stamp: ''!
pvtPackage

	^ package value! !

!RGClassStrategy methodsFor: 'accessing - backend' stamp: ''!
package: anRGPackage

	| oldPackage |
	oldPackage := self package.

	self owner announceDefinitionChangeDuring: [ 
		self owner backend forBehavior setPackageFor: self owner to: anRGPackage.
		self owner environment addPackage: anRGPackage.
		(oldPackage hasResolved: #definedBehaviors)
			ifTrue: [ oldPackage removeDefinedBehavior: self owner ].
		anRGPackage addDefinedBehavior: self owner. ].
	
	self owner announce: (ClassRepackaged 
		classRepackaged: self owner
		oldPackage: oldPackage
		newPackage: anRGPackage)! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtRemoveSharedPool: anRGPoolVariableDefinition

	self owner environment verifyOwnership: anRGPoolVariableDefinition.
	
	sharedPools remove: anRGPoolVariableDefinition.! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
privAddSharedPool: anRGPoolVariable
	
	self backend forBehavior addSharedPool: anRGPoolVariable to: self owner! !

!RGClassStrategy methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	comment := self unresolvedValue: self defaultComment.	
	classVariables := self unresolvedValue: self defaultClassVariables.	
	package := self unresolvedValue: self defaultPackage.	
	sharedPools := self unresolvedValue: self defaultSharedPools.	
			
	! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtComment: anRGComment

	self owner environment verifyOwnership: anRGComment.

	^ comment := anRGComment! !

!RGClassStrategy methodsFor: 'testing' stamp: ''!
isClass

	^ true! !

!RGClassStrategy methodsFor: 'testing' stamp: ''!
defaultMetaClass

	^ self owner environment backend createNewUnresolvedMetaclassFor: self owner! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
comment: anRGComment

	self backend forBehavior setCommentFor: self owner to: anRGComment.
	
	self owner announcer behaviorCommentModified: self.! !

!RGClassStrategy methodsFor: 'testing' stamp: ''!
definition

	| aStream poolString |
	
	self owner slotsNeedFullDefinition 
		ifTrue: [ ^ self definitionWithSlots ].
		
	poolString := self owner sharedPoolsString.
	aStream := (String new: 800) writeStream.
	owner superclass
		ifNil: [ aStream nextPutAll: 'ProtoObject' ]
		ifNotNil: [ aStream nextPutAll: self owner superclass name ].
	aStream
		nextPutAll: self kindOfSubclass;
		store: self owner name.
	self owner hasTraitComposition
		ifTrue:
			[ aStream
				cr;
				tab;
				nextPutAll: 'uses: ';
				nextPutAll: self owner traitCompositionString ].
	aStream
		cr;
		tab;
		nextPutAll: 'instanceVariableNames: ';
		store: self owner instanceVariablesString.
	aStream
		cr;
		tab;
		nextPutAll: 'classVariableNames: ';
		store: self owner classVariablesString.
	poolString = ''
		ifFalse:
			[ aStream
				cr;
				tab;
				nextPutAll: 'poolDictionaries: ';
				store: poolString ].
	aStream
		cr;
		tab;
		nextPutAll: 'package: ';
		store: self owner category asString.
	owner superclass
		ifNil:
			[ aStream
				nextPutAll: '.';
				cr.
			aStream nextPutAll: self owner name.
			aStream
				space;
				nextPutAll: 'superclass: nil' ].
	^ aStream contents! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
addClassVariable: anRGInstanceVariableDefinition 

	self owner announceDefinitionChangeDuring: [ 
		self privAddClassVariable: anRGInstanceVariableDefinition ]
	
	! !

!RGClassStrategy methodsFor: 'default model values' stamp: ''!
makeResolved

	
	"try to set the correct name before resolving of it"
	((self owner hasResolvedName not) and: [ self owner metaclass isRingResolved and: [ self owner metaclass hasResolvedName ] ]) ifTrue: [ 
		self owner pvtName: (self owner metaclass name withoutSuffix: ' class') asSymbol.
		 ].
	
	super makeResolved.
	
	comment := self comment markAsRingResolved.
	classVariables := self classVariables markAsRingResolved.
	package := self package markAsRingResolved.
	sharedPools := self sharedPools markAsRingResolved.
! !

!RGClassStrategy methodsFor: 'testing' stamp: ''!
isClassStrategy

	^ true! !

!RGClassStrategy methodsFor: 'accessing - backend' stamp: ''!
package

	^ self backend forBehavior packageFor: self owner! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
cleanSharedPools

	self backend forBehavior cleanSharedPoolsFor: self owner.! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
addSharedPool: anRGPoolVariable

	self owner announceDefinitionChangeDuring: [ 
		self privAddSharedPool: anRGPoolVariable ].! !

!RGClassStrategy methodsFor: 'class variables' stamp: ''!
classVariableDefinitionString
	"Answer a string that evaluates to the definition of the class Variables"
	
	^String streamContents: [ :str | | special |
		str nextPutAll: '{ '.
		self owner classVariables do: [:global |
				str nextPutAll: global definitionString.
				special := global needsFullDefinition]				
			separatedBy: [ 
				str nextPutAll: ' . '.  
				special ifTrue: [ str cr;tab;tab;tab;tab ]].
		str nextPutAll: ' }'. ]! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
classVariablesDo: aBlock

	self backend forBehavior classVariablesFor: self owner do: aBlock! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
classSide

	^ self owner metaclass! !

!RGClassStrategy methodsFor: 'default model values' stamp: ''!
defaultClassVariables

	^ OrderedCollection new

	! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
sharedPools: aCollectionOfSymbols

	self cleanSharedPools.
	aCollectionOfSymbols do: [ :poolName |
		self addSharedPool: (RGPoolVariable named: poolName asSymbol parent: self).].! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
bindingOf: varName

	| aSymbol | 
	aSymbol := varName asSymbol.

	^ (self innerBindingOf: aSymbol) ifNil: [
		 self environment bindingOf: aSymbol ]! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
category: aString

	| aTag |
		
	self owner cleanTagsWithoutAnnouncemnt.
	aTag := self owner package 
		ifNotNil: [ 
			self owner package name = aString
				ifTrue: [ ^ self owner ] "category contains only the package name"
				ifFalse: [ aString withoutPrefix: self package name, '-'  ]]
		ifNil: [ aString ].
	self owner tagWith: aTag asSymbol.

"	self backend forBehavior setCategoryFor: self to: aaString.
	
	self announcer behaviorDefinitionModified: self.
	self announcer behaviorRecategorized: self."! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtRemoveClassVariable: anRGInstanceVariableDefinition

	self owner environment verifyOwnership: anRGInstanceVariableDefinition.
	
	classVariables remove: anRGInstanceVariableDefinition.! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
sharedPoolsDo: aBlock

	self owner backend forBehavior sharedPoolsFor: self owner do: aBlock! !

!RGClassStrategy methodsFor: 'testing' stamp: ''!
storeName

	^ 'RGClass'! !

!RGClassStrategy methodsFor: 'accessing' stamp: ''!
parent
	
	^ owner! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtAddSharedPool: anRGPoolVariable

	self owner environment verifyOwnership: anRGPoolVariable.
	
	sharedPools isRingResolved ifFalse: [ 
		self pvtCleanSharedPools  ].
	
	sharedPools add: anRGPoolVariable.	! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtAddClassVariable: anRGInstanceVariableDefinition

	self owner environment verifyOwnership: anRGInstanceVariableDefinition.
	
	classVariables isRingResolved ifFalse: [ 
		self pvtCleanClassVariables  ].
	
	classVariables add: anRGInstanceVariableDefinition.	! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
allClassVariables
	"Answer a collection of the receiver's classVariables, including those defined its superclasses"

	^ ((self owner superclass == nil) or: [ self owner superclass == self owner]) 
		ifTrue: [ self classVariables ]
		ifFalse: [ self owner superclass allClassVariables, self classVariables ]! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
privAddClassVariable: anRGInstanceVariableDefinition 

	self backend forBehavior addClassVariable: anRGInstanceVariableDefinition to: self owner	
	! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtCleanClassVariables

	classVariables := self defaultClassVariables.! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtComment

	^ comment value! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
removeClassVariable: anRGInstanceVariableDefinition

	self owner announceDefinitionChangeDuring: [ 
		self backend forBehavior removeClassVariable: anRGInstanceVariableDefinition from: self owner ].! !

!RGClassStrategy methodsFor: 'testing' stamp: ''!
definitionWithSlots

	| aStream poolString|

	poolString := self owner sharedPoolsString.

	aStream := (String new: 800) writeStream.
	self owner superclass 
		ifNil: [aStream nextPutAll: 'ProtoObject']
		ifNotNil: [aStream nextPutAll: self owner superclass name].
	aStream nextPutAll: ' subclass: ';
			store: self owner name.
	(self owner hasTraitComposition) ifTrue: [
		aStream cr; tab; nextPutAll: 'uses: ';
			nextPutAll: self owner traitCompositionString].		
			
	(self layout layoutName = #FixedLayout) ifFalse: [
		aStream cr; tab; nextPutAll: 'layout: ';
			nextPutAll: self layout layoutName].
	aStream cr; tab; nextPutAll: 'slots: ';
			nextPutAll: self owner slotDefinitionString.
	aStream cr; tab; nextPutAll: 'classVariables: ';
			nextPutAll: self owner classVariableDefinitionString.
	poolString = '' ifFalse: [
		aStream cr; tab; nextPutAll: 'poolDictionaries: ';
			store: poolString].
	aStream cr; tab; nextPutAll: 'package: ';
			store: self category asString.

	self owner superclass ifNil: [ 
		aStream nextPutAll: '.'; cr.
		aStream nextPutAll: self owner name.
		aStream space; nextPutAll: 'superclass: nil'. ].

	^ aStream contents! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
classVariables: aCollectionOfSymbols

	self cleanClassVariables.
	aCollectionOfSymbols do: [ :classVarName |
		self addClassVariable: (RGClassVariable named: classVarName asSymbol parent: self).].! !

!RGClassStrategy methodsFor: 'default model values' stamp: ''!
defaultComment

	^ self owner defaultCommentStubIn: self owner! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
acceptVisitor: aVisitor 

	^ aVisitor visitClass: self owner! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
sibling

	^ self owner metaclass.! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
classVarNames

	^ self classVariables collect: [:each | each name]! !

!RGClassStrategy methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	comment := self unresolvedValue: self defaultComment.	
	classVariables := self unresolvedValue: self defaultClassVariables.	
	package := self unresolvedValue: self defaultPackage.	
	sharedPools := self unresolvedValue: self defaultSharedPools.	
	! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
category

	^ self owner tags 
		ifEmpty: [ self owner package categoryName ]
		ifNotEmpty: [ 
			(self owner package hasResolvedName) 
				ifTrue: [ self owner package categoryName, '-', self owner tags first  ]
				ifFalse: [ self owner tags first  ]	] 
	
	"todo"! !

!RGClassStrategy methodsFor: '*Ring-Monticello' stamp: ''!
referencedPackages

	^ Array with: self package.! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
classVariables
	
	^ Array streamContents: [ :str | self classVariablesDo: [ :each | str nextPut: each ] ]! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
comment

	^ self backend forBehavior commentFor: self owner! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
allClassVarNames

	^self allClassVariables collect:[ :cvar| cvar name ]! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
innerBindingOf: aSymbol

	self classVariables detect: [ :each | each name = aSymbol  ] ifFound: [ :found | ^ found ].

	self sharedPoolsDo: [:pool | 
		((self environment ask behaviorNamed: pool name) bindingOf: aSymbol) ifNotNil: [:binding | ^binding]].

	((self owner superclass == self owner) or: [ self owner superclass isNil ]) ifFalse: [ ^ self owner superclass innerBindingOf: aSymbol].	
		
	^ nil! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
sharedPoolNames

	| allSharedPools |
	allSharedPools := OrderedCollection new.
	self sharedPoolsDo: [ :each | allSharedPools add: each name].
	^ allSharedPools asArray! !

!RGClassStrategy methodsFor: '*Ring-Monticello' stamp: ''!
classLayout
	"TODO"
	^ layout"
		ifNil: [ 
			| superLayout scope |
			superLayout := superclass classLayout.
			scope := superLayout slotScope extend.
			layout := superLayout class extending: superLayout scope: scope host: self ]"! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
copyForBehaviorDefinitionPostCopy

	| newVariables newSharedPools |
	self owner behaviorStrategy: self.
	super copyForBehaviorDefinitionPostCopy.
	newVariables := self classVariables collect: [ :each | each copyWithParent: self owner].
	newSharedPools := self sharedPools collect: [ :each | each shallowCopy. ].
	self pvtCleanClassVariables.
	self pvtCleanSharedPools.
	newVariables do: [ :each | self privAddClassVariable: each ].
	newSharedPools do: [ :each | self privAddSharedPool: each ].


! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
sharedPools

	| allSharedPools |
	allSharedPools := OrderedCollection new.
	self sharedPoolsDo: [ :each | allSharedPools add: (
		"use classes everywhare you can. TODO: really?"
		each isSymbol 
			ifTrue: [ self environment ask behaviorNamed: each name ]
			ifFalse: [ 
				(each isVariable and: [each isPoolVariable ])
					ifTrue: [ 
						| beh | 
						beh := self environment ask behaviorNamed: each name.
						beh ifNotNil: [ beh ] ifNil: [ each ] ]
					ifFalse: [ each copy ]])].
	^ allSharedPools ! !

!RGClassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtCleanSharedPools

	sharedPools := self defaultSharedPools.! !

!RGClassStrategy methodsFor: 'initialization' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#comment -> comment. 
		#classVariables -> classVariables. 
		#package -> package. 
		#sharedPools -> sharedPools. 
	}
	
	
! !

!RGClassStrategyTest methodsFor: 'tests' stamp: ''!
testCopying
	| env class classVariable1 classVariable2 copy |
	class := RGClass unnamed.
	env := class environment.

	classVariable1 := RGClassVariable named: #ClassVariable1 parent: class.
	classVariable2 := RGClassVariable named: #ClassVariable2 parent: class.

	class addClassVariable: classVariable1.
	self assert: class behaviorStrategy classVariables size equals: 1.
	self assert: (class classVariables allSatisfy: [ :each | each parent == class ]).

	copy := class copyForBehaviorDefinition.
	class behaviorStrategy classVariables.

	self deny: copy identicalTo: class.
	self assert: copy behaviorStrategy owner identicalTo: copy.
	self deny: class behaviorStrategy identicalTo: copy behaviorStrategy.
	self deny: (class behaviorStrategy instVarNamed: #classVariables) identicalTo: (copy behaviorStrategy instVarNamed: #classVariables).
	self deny: class behaviorStrategy owner identicalTo: copy behaviorStrategy owner.
	self assert: class behaviorStrategy owner identicalTo: class.
	self assert: copy behaviorStrategy owner identicalTo: copy.
	self assert: (class classVariables allSatisfy: [ :each | each parent == class ]).
	self assert: class classVariables size equals: copy classVariables size.
	self deny: class classVariables first identicalTo: copy classVariables first.

	self assert: class behaviorStrategy classVariables size equals: 1! !

!RGClassStrategyTest methodsFor: 'tests' stamp: ''!
testDefinitionWithSlots

	| aClass slot expression |
	
	aClass := RGClass named: #SomeClass.
	aClass superclass name: #Object.
	slot  := RGUnknownSlot named: #iVar parent: aClass layout.
	aClass layout addSlot: slot.
	expression := 'ToManyRelationSlot inverse: #director inClass: #SlotExampleMovie'.
	slot expression: expression.
	
	self assert: (aClass definition beginsWith: 'Object subclass: #SomeClass').
	self assert: (aClass definition includesSubstring: ('#iVar => ', expression)).
! !

!RGClassStrategyTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGClass unnamed behaviorStrategy.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGClassStrategyTest methodsFor: 'tests' stamp: ''!
testCategory
	| aClass |
	aClass := RGClass named: #SomeClass.
	aClass category: 'SomeCategory'.
	self assert: aClass category equals: 'SomeCategory'! !

!RGClassStrategyTest methodsFor: 'tests' stamp: ''!
testIncompatibleBehavior

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	
	self checkIncompatible: [ 
		anRGBehavior baseClass: (anRGBehavior environment ensureClassNamed: #SomeOtherClass) ].
	self checkIncompatible: [ 
		anRGBehavior baseTrait ].
	self checkIncompatible: [ 
		anRGBehavior baseTrait: (anRGBehavior environment ensureTraitNamed: #SomeTrait) ].
! !

!RGClassStrategyTest methodsFor: 'tests' stamp: ''!
testDefinition

	| aClass |
	
	aClass := RGClass named: #SomeClass.
	aClass superclass name: #Object.
	
	self assert: (aClass definition beginsWith: 'Object subclass: #SomeClass')	
! !

!RGClassStrategyTest methodsFor: 'tests' stamp: ''!
testStoreString

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newClass.
	self assert: anRGBehavior storeString equals: '(RGClass named: #unresolved)'.

	anRGBehavior := RGClass named: #SomeClass.
	self assert: anRGBehavior storeString equals: '(RGClass named: #SomeClass)'.	! !

!RGClassStrategyTest methodsFor: 'tests' stamp: ''!
testPackage
	| aClass aPackage |
	aClass := RGClass named: #SomeClass.
	aPackage := aClass environment ensurePackageNamed: 'Package'.

	aClass package: aPackage.
	self assert: aClass package identicalTo: aPackage! !

!RGClassStrategyTest methodsFor: 'tests' stamp: ''!
testComment
	| aClass aComment |
	aClass := RGClass named: #SomeClass.
	aComment := RGComment parent: aClass.
	aClass comment: aComment.

	self assert: aClass comment identicalTo: aComment! !

!RGClassStrategyTest methodsFor: 'tests' stamp: ''!
testKind

	| strategy |
	
	strategy := RGBehavior newClass behaviorStrategy.
	self assert: strategy isClassStrategy.
	self deny: strategy isMetaclassStrategy.
	self deny: strategy isTraitStrategy.
	self deny: strategy isMetaclassTraitStrategy.
	! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testHasMethods
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self deny: newBehavior hasMethods.
	1 to: 10 do: [ :i | 
		| m |
		m := RGMethod
			named: 'method' , i asString
			parent: newBehavior.
		newBehavior addLocalMethod: m ].
	self assert: newBehavior hasMethods.	
	newBehavior cleanLocalMethods.
	self deny: newBehavior hasMethods.
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testTypes

	| newBehavior |
	newBehavior := self behaviorClass unnamed.
	
	self deny: newBehavior isBytes.
	self deny: newBehavior isCompiledMethod.
	self deny: newBehavior isEphemeron.
	self deny: newBehavior isWeak.
	self deny: newBehavior isWords.

	! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testProtocols

	| newBehavior |
	newBehavior := self behaviorClass unnamed.
	
	self assert: newBehavior asYetUnclassifiedProtocolName isSymbol.

	! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testTagsForMethodsRemoval
	
	| class method1 method2 |

	class := RGClass unnamed.
	
	self assert: class tagsForMethods isEmpty.
	self assert: (class hasUnresolved: #tagsForMethods).
	
	method1 := class ensureLocalMethodNamed: #method1.
	method2 := class ensureLocalMethodNamed: #method2.
	
	self assert: class tagsForMethods isEmpty.
	self assert: (class hasResolved: #tagsForMethods).

	method1 tagWith: #tag1.
	self assert: method1 tags equals: #(#tag1).
	self assert: class tagsForMethods equals: #(#tag1).
	
	class removeMethodTag: #tag1.
	self assert: method1 tags isEmpty.
	self assert: class tagsForMethods isEmpty.
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testTesting

	| env behavior | 
	
	"TODO: more complete test"
	
	env := RGEnvironment new.
	behavior := env ensureClassNamed: #SomeTrait.
	self deny: behavior isBits.
	self deny: behavior isBytes.
	self deny: behavior isCompiledMethod.
	self deny: behavior isEphemeron.
	self deny: behavior isWeak.
	self deny: behavior isWords.
	self assert: behavior isPointers.
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testTagsForAllMethods
	
	| env class1 trait1 trait2 composition method1 method2 method3 method4 |
	
	env := RGEnvironment new.
	class1 := env ensureClassNamed: #Class1.
	composition :=  RGTraitComposition parent: class1.
	class1 traitComposition: composition.
	trait1 := env ensureTraitNamed: #Trait1.
	trait2 := env ensureTraitNamed: #Trait2.
	composition addTransformation: trait1.
	composition addTransformation: trait2.
	
	method1 := class1 ensureLocalMethodNamed: #method1.	
	method1 tagWith: #tag1.
	self assertCollection: class1 tagsForAllMethods hasSameElements: #(#tag1).

	method2 := trait1 ensureLocalMethodNamed: #method2.
	method2 tagWith: #tag1.
	self assertCollection: class1 tagsForAllMethods hasSameElements: #(#tag1).

	method3 := trait1 ensureLocalMethodNamed: #method3.
	method3 tagWith: #tag2.
	self assertCollection: class1 tagsForAllMethods hasSameElements: #(#tag1 tag2).
	
	method4 := trait1 ensureLocalMethodNamed: #method4.
	method4 tagWith: #tag3.
	self assertCollection: class1 tagsForAllMethods hasSameElements: #(#tag1 tag2 tag3).
	


! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testBehavior
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self deny: (newBehavior includesSelector: #method).
	method := RGMethod named: #method parent: newBehavior.
	newBehavior addLocalMethod: method.
	self deny: method isBehavior.
	self assert: (newBehavior includesSelector: #method).
	self assert: (newBehavior allInstVarNames isEmpty).
	self assert: (newBehavior allSlots isEmpty).
	self assert: (newBehavior bindingOf: #someVariable) isNil.
	self assert: (newBehavior classVariablesBindings isEmpty).
	
	self deny: (newBehavior isRingFullyUnresolved).

	self deny: newBehavior hasTraitComposition.	
	
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
behaviorClass

	^ RGClass! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testMakeReslolvedResolvesEverything

	| behavior |

	behavior := self behaviorClass unnamed.
	behavior makeResolved.
	self assert: behavior unresolvedProperties isEmpty.! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testDefinition
	| env aClass |
	env := RGEnvironment new.

	aClass := env ensureClassNamed: 'Object'.
	aClass superclass: (env ensureClassNamed: 'ProtoObject').
	aClass package: (env ensurePackageNamed: 'Kernel-Objects').
	aClass addClassVariable: (RGClassVariable named: #DependentsFields parent: aClass).

	self
		assert: aClass definition
		equals:
			'ProtoObject subclass: #Object
	instanceVariableNames: ''''
	classVariableNames: ''DependentsFields''
	package: ''Kernel-Objects'''! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testTagsForMethods
	
	| class method1 method2 |

	class := RGClass unnamed.
	
	self assert: class tagsForMethods isEmpty.
	self assert: (class hasUnresolved: #tagsForMethods).
	
	method1 := class ensureLocalMethodNamed: #method1.
	method2 := class ensureLocalMethodNamed: #method2.
	
	self assert: class tagsForMethods isEmpty.
	self assert: (class hasResolved: #tagsForMethods).

	self assert: (class methodsTaggedWith: #tag1) isEmpty.
	
	method1 tagWith: #tag1.
	self assert: method1 tags equals: #(#tag1).
	self assert: class tagsForMethods equals: #(#tag1).
	self assert: (class methodsTaggedWith: #tag1) equals: {method1}.
	
	method2 tagWith: #tag1.
	self assert: method2 tags equals: #(#tag1).
	self assert: class tagsForMethods equals: #(#tag1).
	self assert: ((class methodsTaggedWith: #tag1) includesAll: {method1. method2}).

	method1 tagWith: #tag2.
	self assert: method1 tags sorted equals: #(#tag1 #tag2).
	self assert: class tagsForMethods sorted equals: #(#tag1 #tag2).
	
	method1 untagFrom: #tag1.
	self assert: method1 tags equals: #(#tag2).
	self assert: class tagsForMethods sorted equals: #(#tag1 #tag2).
	self assert: ((class methodsTaggedWith: #tag1) includesAll: {method2}).

	method2 tagWith: #tag3.
	self assert: method2 tags sorted equals: #(#tag1 #tag3).
	self assert: class tagsForMethods sorted equals: #(#tag1 #tag2 #tag3).

	class removeLocalMethod: method1.
	self assert: class tagsForMethods sorted equals: #(#tag1 #tag2 #tag3).
	class removeLocalMethod: method2.
	self assert: class tagsForMethods sorted equals: #(#tag1 #tag2 #tag3).

	self assert: (class methodsTaggedWith: #tag1) isEmpty.
	self assert: (class methodsTaggedWith: #tag2) isEmpty.
	self assert: (class methodsTaggedWith: #tag3) isEmpty.
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testTagsForMethodsCollection
	
	| class env tag1 tag2 tag3 |

	class := RGClass unnamed.
	env := class environment.

	self assert: class tagsForMethods isEmpty.
	self assert: (class hasUnresolved: #tagsForMethods).
	
	tag1 := #tag1.
	class addMethodTag: #tag1.
	self assert: class tagsForMethods size equals: 1.

	self assert: (class hasResolved: #tagsForMethods).
	
	tag2 := #tag2.
	class addMethodTag: tag2.
	self assert: class tagsForMethods size equals: 2.
	
	tag3 := #tag3.
	class addMethodTag: tag3.
	self assert: class tagsForMethods size equals: 3.

	class removeMethodTag: tag3.
	self assert: class tagsForMethods size equals: 2.

	class cleanTagsForMethods.
	self assert: class tagsForMethods isEmpty.
	self assert: (class hasResolved: #tagsForMethods).
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testSharedPoolsCollection
	
	| class env sharedPool1 sharedPool2 sharedPool3 |

	class := RGClass unnamed.
	env := class environment.

	self assert: class sharedPools isEmpty.
	self assert: (class hasUnresolved: #sharedPools).
	
	sharedPool1 := RGPoolVariable named: #SharedPool1 parent: class.
	class addSharedPool: sharedPool1.
	self assert: class sharedPools size equals: 1.
	self deny: sharedPool1 isClassVariable.
	self assert: sharedPool1 isPoolVariable.
	
	self assert: (class hasResolved: #sharedPools).
	
	sharedPool2 := RGPoolVariable named: #SharedPool2 parent: class.
	class addSharedPool: sharedPool2.
	self assert: class sharedPools size equals: 2.
	
	sharedPool3 := RGPoolVariable named: #SharedPool3 parent: class.
	class addSharedPool: sharedPool3.
	self assert: class sharedPools size equals: 3.

	class removeSharedPool: sharedPool3.
	self assert: class sharedPools size equals: 2.

	class cleanSharedPools.
	self assert: class sharedPools isEmpty.
	self assert: (class hasResolved: #sharedPools).
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testCopyForBehaviorDefinitionForClassDescription
	
	| env aClass copy |
	
	env := RGEnvironment new.
	aClass := env ensureClassNamed: #SomeClass.
	aClass layout: (RGByteLayout parent: aClass).
		
	copy := aClass copyForBehaviorDefinition.
	
	self deny: copy == aClass. 
	self deny: copy layout == aClass layout. 
	self assert: copy layout isByteLayout.
	self assert: (copy layout parent == copy).! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testBehaviorWithOneMethod
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior localMethods isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	self assert: method environment == newBehavior environment.
	self assert: newBehavior localMethods isEmpty.	"we do not add the method to the behavior"
	newBehavior := self behaviorClass named: #SomeClass.
	newBehavior cleanLocalMethods.
	self assert: (newBehavior hasResolved: #localMethods).
	self assert: newBehavior localMethods isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	newBehavior addLocalMethod: method.
	self assert: method environment == newBehavior environment.
	self assert: (newBehavior hasResolved: #localMethods).
	self assert: newBehavior localMethods anyOne name equals: #someMethod.
	newBehavior removeLocalMethod: method.
	self assert: newBehavior localMethods isEmpty.
	self assert: (newBehavior hasResolved: #localMethods)! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testCopyForBehaviorDefinition
	
	| env aClass copy |
	
	env := RGEnvironment new.
	aClass := env ensureClassNamed: #SomeClass.
	aClass superclass: (env ensureClassNamed: #SomeSuperclass).
	aClass tagWith: #tag1.
	aClass tagWith: #tag2.
		
	copy := aClass copyForBehaviorDefinition.
	
	self deny: copy == aClass. 
	self deny: copy superclass == aClass superclass. 
	self assert: copy superclass name equals: #SomeSuperclass.
	self assert: copy tags sorted equals: #(tag1 tag2).! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testEnvironmentStubs

	| package env |
	
	package := RGClass named: 'SomeClass'.
	env := package environment.
"	self assert: (env ask behaviors size = (2)). 
	self assert: (env ask packages size = (1+2)).
	self assert: (env ask packages anySatisfy: [ :each | each unresolvedProperties includes: #name]).
"	! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testCopyForBehaviorDefinitionForClass
	"test copying for instance variables from RGClass"

	| env aClass copy classVariable1 sharedPool sharedPool2 |
	env := RGEnvironment new.
	aClass := env ensureClassNamed: #SomeClass.
	sharedPool := env ensureClassNamed: #SomePool.
	sharedPool2 := env ensureClassNamed: #SomePool2.

	classVariable1 := RGClassVariable named: #ClassVariable1 parent: aClass.
	aClass addClassVariable: classVariable1.
	aClass addSharedPool: sharedPool.

	self assert: aClass sharedPools anyOne name equals: #SomePool.

	copy := aClass copyForBehaviorDefinition.

	classVariable1 name: #ChangedClassVariable1.
	aClass cleanSharedPools.
	aClass addSharedPool: sharedPool2.

	self deny: copy identicalTo: aClass.
	self assert: copy classVarNames asArray equals: #(ClassVariable1).
	self assert: (copy classVariables allSatisfy: [ :each | each parent == copy ]).

	self assert: copy sharedPools notEmpty.
	self assert: copy sharedPools anyOne name equals: #SomePool! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testClassVariablesCollection
	
	| class env classVariable1 classVariable2 classVariable3 |

	class := RGClass unnamed.
	env := class environment.

	self assert: class classVariables isEmpty.
	self assert: (class hasUnresolved: #classVariables).
	
	classVariable1 := RGClassVariable named: #ClassVariable1 parent: class.
	class addClassVariable: classVariable1.
	self assert: class classVariables size equals: 1.
	self assert: class allClassVariables size equals: 1.
	self assert: class allClassVarNames equals: #(ClassVariable1).

	self assert: (class hasResolved: #classVariables).
	
	classVariable2 := RGClassVariable named: #ClassVariable2 parent: class.
	class addClassVariable: classVariable2.
	self assert: class classVariables size equals: 2.
	self assert: class allClassVariables size equals: 2.
	self assert: class allClassVarNames equals: #(ClassVariable1 ClassVariable2).
	
	classVariable3 := RGClassVariable named: #ClassVariable3 parent: class.
	class addClassVariable: classVariable3.
	self assert: class classVariables size equals: 3.
	self assert: class allClassVariables size equals: 3.
	self assert: class allClassVarNames equals: #(ClassVariable1 ClassVariable2 ClassVariable3).

	class removeClassVariable: classVariable3.
	self assert: class classVariables size equals: 2.
	self assert: class allClassVariables size equals: 2.
	self assert: class allClassVarNames equals: #(ClassVariable1 ClassVariable2).

	class cleanClassVariables.
	self assert: class classVariables isEmpty.
	self assert: (class hasResolved: #classVariables).
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testTagsForAllMethodsForClassWithoutTraits
	
	| class method1 method2 |

	class := RGClass unnamed.
	
	self assert: class tagsForAllMethods isEmpty.
	
	method1 := class ensureLocalMethodNamed: #method1.
	method2 := class ensureLocalMethodNamed: #method2.
	
	self assert: class tagsForMethods isEmpty.
	
	method1 tagWith: #tag1.
	self assertCollection: class tagsForAllMethods hasSameElements: #(#tag1).
	
	method2 tagWith: #tag1.
	self assertCollection: class tagsForAllMethods hasSameElements: #(#tag1).

	method1 tagWith: #tag2.
	self assertCollection: method1 tags sorted hasSameElements: #(#tag1 #tag2).
	self assertCollection: class tagsForMethods sorted hasSameElements: #(#tag1 #tag2).
	! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testConversionToTrait

	| env behavior trait | 
	
	"TODO: more complete test"
	
	env := RGEnvironment new.
	behavior := env ensureClassNamed: #SomeTrait.
	self deny: behavior isTrait.
	self assert: behavior isClass.
	
	trait := env ensureTraitNamed: #SomeTrait.
	self deny: behavior isClass.
	self assert: behavior isTrait.
	! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testIsBehavior

	| newBehavior |
	newBehavior := self behaviorClass unnamed.
	
	self assert: newBehavior isBehavior

	! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testEnsureProtocol

	| behavior |
	
	behavior := self behaviorClass named: #SomeClass.
	behavior ensureProtocolNamed: #SomeProtocol.
	self assert: behavior protocols size equals: 1.
	self assert: behavior protocols first equals: #SomeProtocol.
	! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testPrinting
	| aClass |
	
	aClass := RGClass named: 'Object'.
	
	self assert: aClass printString equals: #Object.
	! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testClassSide
	| behavior |
	behavior := RGClass unnamed.
	self assert: behavior classSide identicalTo: behavior metaclass.
	self assert: behavior metaclass classSide identicalTo: behavior metaclass! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testBehaviorWithCategorizedMethods
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior ask methods isEmpty.
	self assert: newBehavior ask protocols isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	newBehavior addLocalMethod: method.
	self assert: (newBehavior hasResolved: #tagsForMethods).
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testBehaviorWithProtocols
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods tagsForMethods)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior methods isEmpty.
	1 to: 10 do: [ :i | 
		newBehavior addProtocol: ('protocol' , i asString) asSymbol ].
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: (newBehavior protocols allSatisfy: #isSymbol).
	self assert: newBehavior protocols size equals: 10.
	(newBehavior protocols first: 4)
		do: [ :each | newBehavior removeProtocol: each ].
	self assert: newBehavior protocols size equals: 6.
	newBehavior cleanProtocols.
	self assert: newBehavior protocols isEmpty! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testNewBehavior
	| newBehavior newSuperclass |
	newBehavior := self behaviorClass unnamed.
	self assert: newBehavior isRingResolved.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	newBehavior name: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self assert: (newBehavior hasResolvedName).
	self deny: (newBehavior hasUnresolved: #name).
	newBehavior isTrait
		ifFalse: [ self assert: newBehavior superclass isRingResolved not ].
	"	self assert: (newBehavior superclass environment == newBehavior environment).
"
	newSuperclass := RGClass
		named: #MySuperclass
		parent: newBehavior environment.
	self assert: newSuperclass environment == newBehavior environment.
	self
		assert: (newSuperclass hasUnresolvedAll: #(superclass localMethods protocols))! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testBehaviorWithUnategorizedMethod
	| newBehavior method |
	
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait ifFalse: [  
		self assert: (newBehavior hasUnresolved: #superclass).].
	self assert: (newBehavior methods isEmpty).
	self assert: (newBehavior protocols isEmpty).

	method := RGMethod named: #someMethod parent: newBehavior. 
	newBehavior addLocalMethod: method.
	
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanProtocols.

	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	
	newBehavior cleanLocalMethods.
	self assert: (newBehavior protocols isEmpty).
	
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testBehaviorWithUnategorizedMethods
	| newBehavior method1 method2 |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods tagsForMethods)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior methods isEmpty.
	self assert: newBehavior protocols isEmpty.
	method1 := RGMethod named: #method1 parent: newBehavior.
	method2 := RGMethod named: #method2 parent: newBehavior.
	newBehavior addLocalMethod: method1.
	newBehavior addLocalMethod: method2.
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanProtocols.
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanLocalMethods.
	self assert: newBehavior protocols isEmpty! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testTagsCollection
	
	| class env tag1 tag2 tag3 |

	class := RGClass unnamed.
	env := class environment.

	self assert: class tags isEmpty.
	self assert: (class hasUnresolved: #tags).
	
	tag1 := #tag1.
	class tagWith: #tag1.
	self assert: class tags size equals: 1.

	self assert: (class hasResolved: #tags).
	
	tag2 := #tag2.
	class tagWith: tag2.
	self assert: class tags size equals: 2.
	
	tag3 := #tag3.
	class tagWith: tag3.
	self assert: class tags size equals: 3.

	class untagFrom: tag3.
	self assert: class tags size equals: 2.

	class cleanTags.
	self assert: class tags isEmpty.
	self assert: (class hasResolved: #tags).
! !

!RGClassTest methodsFor: 'tests' stamp: ''!
testBehaviorWithMethods
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior localMethods isEmpty.
	1 to: 10 do: [ :i | 
		| m |
		m := RGMethod
			named: 'method' , i asString
			parent: newBehavior.
		newBehavior addLocalMethod: m ].
	self assert: (newBehavior hasResolved: #localMethods).
	self
		assert:
			(newBehavior localMethods
				allSatisfy: [ :each | each environment = newBehavior environment ]).
	self assert: newBehavior localMethods size equals: 10.
	(newBehavior localMethods first: 4)
		do: [ :each | newBehavior removeLocalMethod: each ].
	self assert: newBehavior localMethods size equals: 6.
	newBehavior cleanLocalMethods.
	self assert: newBehavior localMethods isEmpty! !

!RGClassTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RGClassTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RGClassTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RGClassTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RGClassTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RGClassTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RGClassTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RGClassTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RGClassTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGClassTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RGClassTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RGClassTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RGClassTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RGClassTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RGClassTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RGClassTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RGClassTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RGClassTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGClassTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RGClassTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RGClassTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RGClassTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RGClassTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RGClassTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RGClassTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RGClassTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RGClassTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RGClassTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RGClassTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RGClassVariable commentStamp: ''!
A class variable definition!
!RGClassVariable methodsFor: 'printing' stamp: ''!
definitionString

	"TODO: special class variables?"

	^ self name printString
! !

!RGClassVariable methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ self defaultClassStub! !

!RGClassVariable methodsFor: 'testing' stamp: ''!
isClassVariable

	^true! !

!RGClassVariable methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	super addoptToParentStub.
	self environment backend createUnresolvedClassGroupFor: self parent.
	self parent addClassVariable: self.! !

!RGClassVariableDefinition commentStamp: ''!
A class variable definition!
!RGClassVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isClassVariable

	^true! !

!RGClassVariableTest methodsFor: 'tests' stamp: ''!
testClassVariableImplicitEnvironment

	| classVariable |
	
	classVariable := RGClassVariable unnamed.
	self assert: (classVariable hasResolvedName not).
	self checkImplicitSingleClassEnvironmentOf: classVariable parent.
	
	classVariable := RGClassVariable named: #SomeClassVariable.
	self assert: (classVariable hasResolvedName).
	self checkImplicitSingleClassEnvironmentOf: classVariable parent.
	
	
	
! !

!RGClassVariableTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGClassVariable unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGClassVariableTest methodsFor: 'tests' stamp: ''!
testNewClassVariable

	| classVariable | 
	classVariable  := RGClassVariable unnamed.
	self assert: (classVariable isRingResolved).
	self assert: (classVariable hasUnresolved: #name).
	self assert: (classVariable isVariable).
	self assert: (classVariable isClassVariable).	
	self deny: (classVariable isPoolVariable).	

	classVariable  := RGClassVariable named: #SomeClassVariable.
	self assert: (classVariable isRingResolved).
	self assert: (classVariable hasResolvedAll: #(name)).
	self assert: classVariable name equals: #SomeClassVariable.
	self assert: (classVariable isClassVariable).
	self assert: (classVariable isClassVariable).	
	! !

!RGComment commentStamp: ''!
RGComment is a first-class representation of class's comments!
!RGComment methodsFor: 'backward compatibility' stamp: ''!
sourceCode

	^ self content   ! !

!RGComment methodsFor: '*Ring-Monticello' stamp: ''!
stamp

	"TODO:"
	^ self author! !

!RGComment methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ self defaultClassStub! !

!RGComment methodsFor: 'private - backend interface' stamp: ''!
pvtContent

	^ content value! !

!RGComment methodsFor: 'default model values' stamp: ''!
defaultAuthor

	^ ''! !

!RGComment methodsFor: 'printing' stamp: ''!
printOn: aStream 

	self parent name ifNotNil: [
		aStream nextPutAll: self parent name;
				  nextPutAll: ' ' ].
	aStream nextPutAll: self name asString! !

!RGComment methodsFor: 'accessing' stamp: ''!
fullName
	
	^ (self parent name, ' comment') asSymbol! !

!RGComment methodsFor: 'testing' stamp: ''!
isComment

	^ true! !

!RGComment methodsFor: 'private - backend interface' stamp: ''!
pvtTime

	^ time value! !

!RGComment methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	content := self unresolvedValue: self defaultContent.	
	author := self unresolvedValue: self defaultAuthor.	
	time := self unresolvedValue: self defaultTime.	
	! !

!RGComment methodsFor: 'default model values' stamp: ''!
defaultTime

	^ DateAndTime new! !

!RGComment methodsFor: 'private - backend interface' stamp: ''!
pvtTime: aDateAndTime

	^ time := aDateAndTime! !

!RGComment methodsFor: 'accessing - backend' stamp: ''!
author

	^ self backend forBehavior classCommentAuthorFor: self! !

!RGComment methodsFor: '*Calypso-Ring' stamp: ''!
asText

	^ (self content ifNil: ['']) asText! !

!RGComment methodsFor: 'accessing - backend' stamp: ''!
content: aString

	self backend forBehavior setClassCommentContentFor: self to: aString.
	
	self announcer behaviorCommentModified: self parent.! !

!RGComment methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	content := self unresolvedValue: self defaultContent.	
	author := self unresolvedValue: self defaultAuthor.	
	time := self unresolvedValue: self defaultTime.	
	! !

!RGComment methodsFor: 'testing' stamp: ''!
isEmptyOrNil

	^ self content isEmptyOrNil ! !

!RGComment methodsFor: 'accessing - backend' stamp: ''!
time

	^ self backend forBehavior classCommentTimeFor: self! !

!RGComment methodsFor: 'accessing - backend' stamp: ''!
author: aString

	self backend forBehavior setClassCommentAuthorFor: self to: aString.
	
	self announcer behaviorCommentModified: self parent.! !

!RGComment methodsFor: 'default model values' stamp: ''!
defaultContent

	^ ''! !

!RGComment methodsFor: 'private - backend interface' stamp: ''!
pvtAuthor

	^ author value! !

!RGComment methodsFor: 'private - backend interface' stamp: ''!
pvtContent: aString

	^ content := aString! !

!RGComment methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	super addoptToParentStub.

	self environment backend createUnresolvedClassGroupFor: self parent! !

!RGComment methodsFor: 'accessing - backend' stamp: ''!
content

	^ self backend forBehavior classCommentContentFor: self! !

!RGComment methodsFor: 'accessing - backend' stamp: ''!
time: aDateAndTime

	self backend forBehavior setClassCommentTimeFor: self to: aDateAndTime.
	
	self announcer behaviorCommentModified: self parent.! !

!RGComment methodsFor: 'resolving' stamp: ''!
makeResolved

	super makeResolved.
	
	content := self content markAsRingResolved.
	author := self author markAsRingResolved.
	time := self time markAsRingResolved.! !

!RGComment methodsFor: 'private - backend interface' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#content -> content. 
		#author -> author. 
		#time -> time. 
	}
	
	! !

!RGComment methodsFor: 'private - backend interface' stamp: ''!
pvtAuthor: aString

	^ author := aString! !

!RGCommentDefinition commentStamp: ''!
RGCommentDefinition is a first-class representation of class's comments!
!RGCommentDefinition methodsFor: 'accessing' stamp: 'nil'!
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: 'type of comments' stamp: 'nil'!
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"

	| realClass |
	self isActive
		ifFalse: [ ^ self ].
	realClass := self realClass.
	realClass notNil
		ifTrue: [ 
			self content: realClass organization classComment.
			self stamp: realClass organization commentStamp ].
	self asPassive! !

!RGCommentDefinition methodsFor: 'to remove as soon as possible' stamp: 'nil'!
methodClass
	^ self realClass! !

!RGCommentDefinition methodsFor: 'stamp values' stamp: 'nil'!
timeStamp 

	^ self annotationNamed: self class timeStampKey 
		ifAbsentPut: [ self class 
							parseTimestampFrom: self stamp 
							default: (DateAndTime epoch) ]! !

!RGCommentDefinition methodsFor: 'testing' stamp: 'nil'!
hasStamp

	^stamp isEmptyOrNil not

	! !

!RGCommentDefinition methodsFor: 'type of comments' stamp: 'nil'!
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: 'nil'!
isPassive

	"A ring comment isPassive by default.  In this case it will retrieve the data that was assigned in its creation"
	^(self annotationNamed: self class statusKey) 
		ifNil:[ true ] 
		ifNotNil:[ :status| status == #passive ]! !

!RGCommentDefinition methodsFor: 'printing' stamp: 'nil'!
printOn: aStream 

	self parentName ifNotNil: [
		aStream nextPutAll: self parentName;
				  nextPutAll: ' ' ].
	aStream nextPutAll: self name! !

!RGCommentDefinition methodsFor: 'type of comments' stamp: 'nil'!
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: 'testing' stamp: 'nil'!
hasAuthor

	^self hasStamp and:[ self author isEmptyOrNil not ]! !

!RGCommentDefinition methodsFor: 'accessing' stamp: 'nil'!
fullName
	"Keeps a unique description for the receiver. As annotation to avoid converting each time is invoked"
	
	^self annotationNamed: self class fullNameKey
		ifAbsentPut:[ (self parentName, ' ', self name) asSymbol ]! !

!RGCommentDefinition methodsFor: 'type of comments' stamp: 'nil'!
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: 'testing' stamp: 'nil'!
isComment

	^true! !

!RGCommentDefinition methodsFor: 'type of comments' stamp: 'nil'!
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: 'accessing' stamp: 'nil'!
stamp: anObject

	stamp:= anObject! !

!RGCommentDefinition methodsFor: 'to remove as soon as possible' stamp: 'nil'!
selector
	^ self name! !

!RGCommentDefinition methodsFor: 'stamp values' stamp: 'nil'!
author 

	^self annotationNamed: self class authorKey
		ifAbsentPut:[ self class parseAuthorAliasFrom: stamp ]! !

!RGCommentDefinition methodsFor: 'testing' stamp: 'nil'!
isFromTrait
	^false! !

!RGCommentDefinition methodsFor: 'accessing' stamp: 'nil'!
content: anObject

	content:= anObject! !

!RGCommentDefinition methodsFor: 'testing' stamp: 'nil'!
isEmptyOrNil

	^content isEmptyOrNil ! !

!RGCommentDefinition methodsFor: 'source pointers' stamp: 'nil'!
commentDataPointers
	"Retrieves the combination key to look for information of the receiver in the source file"
	^'commentStamp:' -> #commentStamp:! !

!RGCommentDefinition methodsFor: 'to remove as soon as possible' stamp: 'nil'!
category
	^self realClass category! !

!RGCommentDefinition methodsFor: 'source pointers' stamp: 'nil'!
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: 'stamp values' stamp: 'nil'!
author: aString 

	self annotationNamed: self class authorKey
			put: aString ! !

!RGCommentDefinition methodsFor: 'testing' stamp: 'nil'!
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: 'source pointers' stamp: 'nil'!
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: 'nil'!
timeStamp: aTimestamp 

	self annotationNamed: self class timeStampKey
			put: aTimestamp ! !

!RGCommentDefinition methodsFor: '*Text-Core' stamp: ''!
asStringOrText
	| text |
	self realClass ifNil: [ ^ self fullName ].
	text := self fullName asText.
	text addAttribute: TextEmphasis italic.
	^ text! !

!RGCommentDefinition methodsFor: 'accessing' stamp: 'nil'!
name

	^name ifNil:[ name := #Comment ]! !

!RGCommentDefinition methodsFor: 'accessing' stamp: 'nil'!
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: 'to remove as soon as possible' stamp: 'nil'!
isValid
	"for compatibility with method definition"

	^ true! !

!RGCommentDefinition methodsFor: 'type of comments' stamp: 'nil'!
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: 'source pointers' stamp: 'nil'!
sourcePointer: aNumber

	self annotationNamed:  self class sourcePointerKey put: aNumber ! !

!RGCommentDefinition methodsFor: 'source pointers' stamp: 'nil'!
sourcePointer
	"Retrieves the sourcePointer for this definition if exists"
	
	^self annotationNamed:  self class sourcePointerKey   ! !

!RGCommentDefinition methodsFor: 'type of comments' stamp: 'nil'!
asHistorical

	"Sets the receiver as historical object, which will allow itself to retrieve its data using the sourcePointer"

	self annotationNamed: self class statusKey put: #historical.
	self sourcePointer ifNil: [ 
		self realClass ifNotNil: [ :realClass | 
			self sourcePointer: realClass organization commentSourcePointer ] ]! !

!RGCommentDefinition methodsFor: 'comparing' stamp: 'nil'!
<= aRGCommentDefinition
	"Sort comment definition according to: 1) name of the class"
	
	^(self parentName <= aRGCommentDefinition parentName)! !

!RGCommentDefinition methodsFor: 'backward compatibility' stamp: 'nil'!
sourceCode

	^ self content   ! !

!RGCommentDefinition class methodsFor: 'instance creation' stamp: 'nil'!
realClass: aClass
	"Creates a ring comment definition from a Smalltalk class"
	^(super realClass: aClass)
		asActive;
		yourself! !

!RGCommentDefinitionTest commentStamp: ''!
SUnit tests for comment definitions!
!RGCommentDefinitionTest methodsFor: 'testing' stamp: ''!
testSorting

	| rgComm1 rgComm2 |
	rgComm1 := RGCommentDefinition realClass: RGClassDefinition.
	rgComm2 := RGCommentDefinition realClass: RGElementDefinition.
	self assert: rgComm1 <= rgComm2! !

!RGCommentDefinitionTest methodsFor: 'testing' stamp: ''!
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: ''!
testingConversion
	
	| rgComm |
	rgComm := RGCommentDefinition realClass: RGClassDefinition.
	self assert: rgComm asString equals: 'RGClassDefinition Comment'.
	
	rgComm := RGCommentDefinition class: (RGClassDefinition named: #Foo).
	self assert: rgComm asString equals: 'Foo Comment'! !

!RGCommentDefinitionTest methodsFor: 'testing' stamp: ''!
testNewComment
	| newComment |
	newComment := RGCommentDefinition new
		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 equals: #Comment.
	self assert: newComment hasStamp.
	self assert: newComment hasAuthor.
	self assert: newComment timeStamp notNil.

	self assert: newComment author equals: 'VeronicaUquillas'.
	self assert: newComment timeStamp equals: '3/22/2011 14:51' asDateAndTime.
	self assert: newComment parent equals: nil.
	self assert: newComment environment equals: Smalltalk globals! !

!RGCommentDefinitionTest methodsFor: 'testing' stamp: ''!
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 equals: ''.

	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: ''!
testCommentWithoutAuthor
	| newComment |
	
	newComment:= RGCommentDefinition new
						content: 'This is a comment for test';
						stamp: '3/22/2011 14:51';
						yourself.
	
	self assert: (newComment hasAuthor not).! !

!RGCommentTest methodsFor: 'tests' stamp: ''!
testMakeReslolved

	| comment |

	comment := RGComment unnamed.
	comment makeResolved.
	self assert: comment unresolvedProperties isEmpty.
	self assert: comment content equals: ''.
	self assert: comment author equals: ''.
	self assert: (comment time isKindOf: DateAndTime).
	! !

!RGCommentTest methodsFor: 'tests' stamp: ''!
testImplicitEnvironment
	
	| def def2 env |

	def := RGComment unnamed.
	env := def environment.

	self checkImplicitSingleClassEnvironmentOf: def parent.	

	self assert: (def isRingResolved).
	
	def2 := RGComment parent: def parent .
	self checkImplicitSingleClassEnvironmentOf: def parent.	
! !

!RGCommentTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGComment unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGCommentTest methodsFor: 'tests' stamp: ''!
testTransformations
	| comment time |
	
	comment := RGComment unnamed.
	
	self assert: (comment isRingResolved).
	
	self assert: (comment hasUnresolvedAll: #(content author time name)).
	
	self assert: comment content equals: ''.
	comment content: 'some class comment'.
	self assert: (comment hasUnresolvedAll: #(author time name)).
	self assert: comment content equals: 'some class comment'.
	
	self assert: comment author equals: ''.
	comment author: 'FullAuthorName'.
	self assert: (comment hasUnresolvedAll: #(time name)).
	self assert: comment author equals: 'FullAuthorName'.
	
	time := DateAndTime now.
	self assert: comment time equals: DateAndTime new.
	comment time: time.
	self assert: (comment hasUnresolved: #name).
	self assert: comment time equals: time.
! !

!RGCommentTest methodsFor: 'tests' stamp: ''!
testNewComment
	| comment time |
	
	comment := RGComment unnamed.
	
	self assert: (comment isRingResolved).
	self assert: (comment isComment).
	
	self assert: (comment hasUnresolvedAll: #(content author time name)).
	
	self assert: (comment isEmptyOrNil).
	
	self assert: comment content equals: ''.
	comment content: 'some class comment'.
	self assert: (comment hasUnresolvedAll: #(author time name)).
	self assert: comment content equals: 'some class comment'.
	self deny: (comment isEmptyOrNil).
	self assert: comment content equals: comment sourceCode.
	
	self assert: comment author equals: ''.
	comment author: 'FullAuthorName'.
	self assert: (comment hasUnresolvedAll: #(time name)).
	self assert: comment author equals: 'FullAuthorName'.
	
	time := DateAndTime now.
	self assert: comment time equals: DateAndTime new.
	comment time: time.
	self assert: (comment hasUnresolved: #name).
	self assert: comment time equals: time.
! !

!RGCommentTest methodsFor: 'tests' stamp: ''!
testClass

	| environment aClass aPackage aComment |
	
	environment := RGEnvironment new.
	aClass := environment ensureClassNamed: #SomeClass.
	aPackage := environment ensurePackageNamed: #SomePackage.
	aClass package: aPackage.
	aComment := RGComment parent: aClass.
	aComment content: 'some comment'.
	self deny: aClass hasComment.
	aClass comment: aComment.
	self assert: aComment package equals: aPackage.
	self assert: aClass hasComment.
	
	self assert: aComment fullName equals: 'SomeClass comment'.
! !

!RGCompiledMethodLayout methodsFor: '*Ring-Monticello' stamp: ''!
mcType

	^ #compiledMethod ! !

!RGCompiledMethodLayout methodsFor: 'testing - types' stamp: ''!
isByteLayout

	^ true! !

!RGCompiledMethodLayout methodsFor: 'testing - types' stamp: ''!
isCompiledMethodLayout

	^ true! !

!RGCompiledMethodLayout methodsFor: 'testing - types' stamp: ''!
isBitsLayout

	^ true! !

!RGCompiledMethodLayout methodsFor: 'testing - types' stamp: ''!
isVariableLayout

	^ true! !

!RGContainer commentStamp: ''!
A concrete container already knows how to treat classes, methods and packages. !
!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
addPackageNamed: packageName
	"adds a child package with the given name"

	(self includesPackageNamed: packageName) ifTrue: [ ^self ].
	self addPackage: (RGPackageDefinition named: packageName)! !

!RGContainer methodsFor: 'iterating' stamp: 'nil'!
traitsDo: aBlock

	self traits do: [ :each|
		aBlock value: each.
		each hasMetaclass
			ifTrue:[ aBlock value: each classSide ] ]! !

!RGContainer methodsFor: 'convenient accesses' stamp: 'nil'!
allClasses
	"convenient method"

	^self classes! !

!RGContainer methodsFor: 'utilities' stamp: 'nil'!
isMetaclassName: aSymbol
	"Validates if the arguments corresponds to a nonMetaClass"
	
	^(aSymbol
		indexOfSubCollection: ' class'
		startingAt: 1) > 0! !

!RGContainer methodsFor: 'lookup by name' stamp: 'nil'!
packageNamed: packageName
	"Look for a child package named packageName"
	
	^self elementNamed: packageName in: self packages! !

!RGContainer methodsFor: 'lookup by name' stamp: 'nil'!
classNamed: className
	"Retrieves an RGBehaviorDefinition object.
	className could be theMetaClass name"
	
	^self classOrTraitNamed: className! !

!RGContainer methodsFor: 'testing' stamp: 'nil'!
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: 'adding/removing' stamp: 'nil'!
removePackage: aRGPackage
	"removes a child aRGPackage"

	aRGPackage isPackage ifFalse:[ ^self ].
	self removeElement: aRGPackage from: self packages! !

!RGContainer methodsFor: 'accessing' stamp: 'nil'!
definedClasses: aCollection
	"Set the classes collection"

	self elements at: #definedClasses put: aCollection! !

!RGContainer methodsFor: 'iterating' stamp: 'nil'!
definedClassesDo: aBlock

	self definedClasses do: [ :each|
		aBlock value: each.
		each hasMetaclass
			ifTrue:[ aBlock value: each classSide ] ]! !

!RGContainer methodsFor: 'convenient accesses' stamp: 'nil'!
allTraits
	"convenient method"
	
	^self allClasses select:[ :each | each isTrait ]! !

!RGContainer methodsFor: 'accessing' stamp: 'nil'!
packages: aCollection

	self elementsCategorized: #packages with: aCollection! !

!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
addTrait: aRGTraitDefinition
	"convenient method"

	self addClass: aRGTraitDefinition! !

!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
addClassNamed: className 
	"Creates a class with the given name"
	self addClass: (RGClassDefinition named: className)! !

!RGContainer methodsFor: 'iterating' stamp: 'nil'!
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 classSide ] ]! !

!RGContainer methodsFor: 'convenient accesses' stamp: 'nil'!
allMethods
	"convenient method"

	^self methods! !

!RGContainer methodsFor: 'initialization' stamp: 'nil'!
initialize

	super initialize.
	self definedClasses: IdentityDictionary new.
	self methods: IdentityDictionary new.
	self packages: IdentityDictionary new.! !

!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
addPackage: aRGPackage
	"adds a child package"

	aRGPackage isPackage ifFalse:[ ^self ].
	self addElement: aRGPackage in: self packages! !

!RGContainer methodsFor: 'image package loading' stamp: 'nil'!
setPackageOfClass: rgClass using: packageKeys
	"Set the package to aRGBehaviorDefinition"

	(self findPackageOfClass: rgClass using: packageKeys) 
		ifNotNil:[ :pck| pck addClass: rgClass ]
	! !

!RGContainer methodsFor: 'image class and method loading' stamp: 'nil'!
loadTraitUsers
	"Set the users of a trait"
	| users |
	
	users := self classes select: [ :cls | cls hasTraitComposition ].
	users do:[ :each |  | rgTrait |
		each traitNames do:[ :tname|
			rgTrait := self traitNamed: tname.
			rgTrait notNil ifTrue: [
				rgTrait addUser: each.
				rgTrait classSide addUser: each classSide ] ] ]! !

!RGContainer methodsFor: 'image class and method loading' stamp: 'nil'!
loadMethod: aRGMethodDefinition inClass: aRGBehaviorDefinition using: packageKeys

	self addMethod: aRGMethodDefinition.
	aRGBehaviorDefinition addMethod: aRGMethodDefinition.
	self setPackageOfMethod: aRGMethodDefinition ofClass: aRGBehaviorDefinition using: packageKeys! !

!RGContainer methodsFor: 'testing' stamp: 'nil'!
hasMethods

	^self methods notEmpty! !

!RGContainer methodsFor: 'lookup by name' stamp: 'nil'!
traitNamed: traitName
	"Retrieves an RGTraitDefinition object.
	traitName could be theMetaClass name"
	| trait |
	
	^(trait:= self classOrTraitNamed: traitName) isTrait
	ifTrue:[ trait ]
	ifFalse:[ nil ]! !

!RGContainer methodsFor: 'image package loading' stamp: 'nil'!
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: 'adding/removing' stamp: 'nil'!
removeMethod: aRGMethodDefinition

	self removeElement: aRGMethodDefinition from: self methods! !

!RGContainer methodsFor: 'testing' stamp: 'nil'!
includesMethodNamed: fullSelectorName
	
	^self includesElementNamed: fullSelectorName in: self methods! !

!RGContainer methodsFor: 'testing' stamp: 'nil'!
includesPackage: aRGPackage
	"Verifies if a child package == aRGPackage exists"
	
	^self packages includes: aRGPackage! !

!RGContainer methodsFor: 'testing' stamp: 'nil'!
includesClass: aRGBehaviorDefinition
	"Returns true if the receiver includes aRGBehaviorDefinition in the defined classes"

	^self definedClasses includes: aRGBehaviorDefinition! !

!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
withoutMethods
	
	self removeElementsCategorized: #methods! !

!RGContainer methodsFor: 'testing' stamp: 'nil'!
hasClasses

	^self definedClasses notEmpty! !

!RGContainer methodsFor: 'image package loading' stamp: 'nil'!
loadPackagesFromImage

	| rgPackage rgPackageKeys |
	rgPackageKeys := OrderedCollection new.
	self class allManagers do: [ :pck | 
		rgPackage := RGPackageDefinition named: pck package name asSymbol.
		rgPackageKeys add: (rgPackage name -> ('*', rgPackage name asLowercase)).
		self addPackage: rgPackage ].
	^ rgPackageKeys! !

!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
removeClass: aRGAbstractClassDefinition

	self removeElement: aRGAbstractClassDefinition from: self definedClasses! !

!RGContainer methodsFor: 'iterating' stamp: 'nil'!
allTraitsDo: aBlock
	"Evaluate the argument, aBlock, for each trait"

	self allTraits do: [ :each|
		aBlock value: each.
		each hasMetaclass
			ifTrue:[ aBlock value: each classSide ] ]! !

!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
addTraitNamed: traitName 
	"Creates a trait with the given name"
	self addClass:  (RGTraitDefinition named: traitName)! !

!RGContainer methodsFor: 'iterating' stamp: 'nil'!
methodsDo: aBlock

	self methods
		do:[ :each| aBlock value: each ]! !

!RGContainer methodsFor: 'lookup by name' stamp: 'nil'!
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 classSide ]
		ifFalse:[ theClass ] ! !

!RGContainer methodsFor: 'convenient accesses' stamp: 'nil'!
classes: aCollection
	"convenient method"

	self definedClasses: aCollection! !

!RGContainer methodsFor: 'iterating' stamp: 'nil'!
classesDo: aBlock

	self classes do: [ :each|
		aBlock value: each.
		each hasMetaclass
			ifTrue:[ aBlock value: each classSide ] ]! !

!RGContainer methodsFor: 'convenient accesses' stamp: 'nil'!
extensionMethods
	"Retrieves a collection (by default a dictionary) with the extensions methods of the receiver"

	^self methods values select:[ :mth| mth isExtension ]! !

!RGContainer methodsFor: 'lookup by name' stamp: 'nil'!
methodNamed: fullSelectorName

	^self elementNamed: fullSelectorName in: self methods! !

!RGContainer methodsFor: 'accessing' stamp: 'nil'!
packages
	"Retrieves the children packages defined in the receiver"

	^self elements at: #packages ifAbsentPut:[ IdentityDictionary new ]! !

!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
withoutPackages
	
	self removeElementsCategorized: #packages! !

!RGContainer methodsFor: 'accessing' stamp: 'nil'!
definedClasses
	"Retrieves classes (traits are included)"

	^self elements at: #definedClasses ifAbsentPut:[ IdentityDictionary new ]! !

!RGContainer methodsFor: 'image package loading' stamp: 'nil'!
cleanEmptyPackages
	(self packages select: [ :pck | pck classes isEmpty and: [ pck methods isEmpty ] ]) do: [ :pck | self removePackage: pck ]! !

!RGContainer methodsFor: 'accessing' stamp: 'nil'!
methods
	"Retrieves methods defined in the container"
	
	^self elements at: #methods ifAbsentPut:[ IdentityDictionary new ]! !

!RGContainer methodsFor: 'convenient accesses' stamp: 'nil'!
classes
	"convenient method"

	^self definedClasses! !

!RGContainer methodsFor: 'lookup by name' stamp: 'nil'!
metaclassNamed: metaclassName
	| theClass |
	
	theClass:= (self classOrTraitNamed: metaclassName).
	theClass notNil
	ifTrue:[ ^theClass isMeta 
		      ifTrue: [ theClass ]
		      ifFalse:[ theClass classSide ] ].
	
	^nil! !

!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
withoutClasses

	self removeElementsCategorized: #definedClasses! !

!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
removeTrait: aRGTraitDefinition
	"convenient method"

	self removeClass: aRGTraitDefinition! !

!RGContainer methodsFor: 'accessing' stamp: 'nil'!
methods: aCollection
	"Set the methods collection"
	
	self elements at: #methods put: aCollection! !

!RGContainer methodsFor: 'convenient accesses' stamp: 'nil'!
classNames
	"Retrieves class names (including traits)"
	
	^ self definedClasses isDictionary
		ifTrue: [ self definedClasses keys ]
		ifFalse:[ self definedClasses collect:[ :class|  class name ] ]! !

!RGContainer methodsFor: 'image package loading' stamp: 'nil'!
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: 'nil'!
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: 'convenient accesses' stamp: 'nil'!
traits
	"Retrieves a collection (by default a dictionary) containing only defined traits"

	^self definedClasses select:[ :each| each isTrait ]! !

!RGContainer methodsFor: 'utilities' stamp: 'nil'!
theNonMetaClassNameOf: aSymbol
	"Rejects the prefix ' class' or ' classTrait' of the argument"
	| index |
	
	index := aSymbol
				indexOfSubCollection: ' class'
				startingAt: 1
				ifAbsent: [ ^aSymbol asSymbol ].

	^(aSymbol 
		copyFrom: 1
		to: index - 1) asSymbol! !

!RGContainer methodsFor: 'testing' stamp: 'nil'!
includesMethod: aRGMethodDefinition

	^self methods includes: aRGMethodDefinition! !

!RGContainer methodsFor: 'convenient accesses' stamp: 'nil'!
traitNames
	"Retrieves the names of defined traits"

	^ self traits isDictionary
		ifTrue: [ self traits keys ]
		ifFalse:[ self traits collect:[ :trait| trait name ] ]! !

!RGContainer methodsFor: 'testing' stamp: 'nil'!
includesPackageNamed: packageName
	"Verifies if a child package with name = packageName exists"
	
	^self includesElementNamed: packageName in: self packages! !

!RGContainer methodsFor: 'image class and method loading' stamp: 'nil'!
loadClass: aRGBehaviorDefinition using: packageKeys

	self setPackageOfClass: aRGBehaviorDefinition using: packageKeys.
	self addClass: aRGBehaviorDefinition! !

!RGContainer methodsFor: 'adding/removing' stamp: 'nil'!
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: 'nil'!
addMethod: aRGMethodDefinition
	"aRGMethodDefinition needs to satisfy the status isMethod"

	aRGMethodDefinition isMethod ifFalse:[ ^self ].
	self addElement: aRGMethodDefinition in: self methods! !

!RGContainer class methodsFor: 'image package loading' stamp: 'nil'!
allManagers

	^ Smalltalk globals at: #MCWorkingCopy 
		ifPresent: [:mcwc | mcwc allManagers ] 
		ifAbsent: [OrderedCollection new ]
! !

!RGContainer class methodsFor: 'image package loading' stamp: 'nil'!
packageOfMethod: aRGMethodDefinition

	^ self packageOfMethod: aRGMethodDefinition using: self packageKeys! !

!RGContainer class methodsFor: 'image package loading' stamp: 'nil'!
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:[ RGPackageDefinition named: pName ]! !

!RGContainer class methodsFor: 'image package loading' stamp: 'nil'!
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:[ RGPackageDefinition named: pName key ]! !

!RGContainer class methodsFor: 'image package loading' stamp: 'nil'!
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: 'nil'!
packageNames

	^ self allManagers collect: [ :pck | pck package name asSymbol ]! !

!RGContainer class methodsFor: 'image package loading' stamp: 'nil'!
packageOfClass: aRGBehaviorDefinition

	^ self packageOfClass: aRGBehaviorDefinition using: self packageNames.! !

!RGContainer class methodsFor: 'image package loading' stamp: 'nil'!
packageKeys

	^ self allManagers collect: [ :pck | pck package name asSymbol -> ('*', pck package name asLowercase) ]! !

!RGContainerTest commentStamp: ''!
SUnit tests for container!
!RGContainerTest methodsFor: '*Ring-Definitions-Tests-Monticello' stamp: ''!
testRetrievingPackages
	| rgClass rgMethod |
	rgClass := OrderedCollection asRingDefinition.
	rgClass package: (RGContainer packageOfClass: rgClass).
	self assert: rgClass package name equals: #'Collections-Sequenceable'.

	rgMethod := RGMethodDefinition realClass: Class selector: #asRingDefinition.
	rgMethod package: (RGContainer packageOfMethod: rgMethod).
	self assert: rgMethod parent isNil.
	self assert: rgMethod package name equals: #'Ring-Definitions-Core'.

	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 equals: rgClass package! !

!RGDefinition commentStamp: ''!
I am the root class of the Ring meta-model.
A Ring definition has a name, can be annotated and knows its environment!
!RGDefinition methodsFor: 'annotations' stamp: 'nil'!
annotationNames
	
	self hasAnnotations
		ifFalse:[ ^OrderedCollection new ].
	^annotations keys! !

!RGDefinition methodsFor: 'accessing' stamp: 'nil'!
environment: namespace

	namespace = self class environment
		ifFalse:[ self annotationNamed: #environment put: namespace ]! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isRingObject

	^true! !

!RGDefinition methodsFor: 'annotations' stamp: 'nil'!
removeAnnotationNamed: annotationName 
	"Remove the annotation named <annotationName>. Fails quietly if there 
	is no annotation with the given name."
	
	(self hasAnnotationNamed: annotationName)
		ifTrue:[ annotations removeKey: annotationName ]! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isOrganization 

	^false! !

!RGDefinition methodsFor: 'accessing' stamp: 'nil'!
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: 'nil'!
rootEnvironment
	"Retrieves the runtime environment of an RGObject"
	"If the receiver is defined in an RGContainer the runtime environment is the one associated to its container"
	| parent |
	
	parent:= self environment.
	[ parent isRingObject ]
		whileTrue:[ parent:= parent environment ].

	^parent! !

!RGDefinition methodsFor: 'accessing' stamp: 'nil'!
name: anObject
	"a symbol or a string should be expected"
	
	name:= anObject! !

!RGDefinition methodsFor: 'annotations' stamp: 'nil'!
annotationNamed: annotationName 
	"Answer the value of the annotation named <annotationName>, or 
	nil if the annotation is not defined for the receiver."
	
	^ self
		annotationNamed: annotationName
		ifAbsent: [ nil ]! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isPackage

	^false! !

!RGDefinition methodsFor: 'accessing' stamp: 'nil'!
fullName

	^self name! !

!RGDefinition methodsFor: 'annotations' stamp: 'nil'!
annotationNamed: annotationName ifAbsentPut: blockValue 

	^self annotations
		at: annotationName
		ifAbsentPut: blockValue! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isComment

	^false! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isMethod

	^false! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isInvocation

	^false! !

!RGDefinition methodsFor: 'annotations' stamp: 'nil'!
hasAnnotationNamed: annotationName
	"Answer <true> if the receiver contains the annotation named <annotationName>. "
	
	self hasAnnotations	
		ifFalse:[ ^false ].
	^annotations includesKey: annotationName! !

!RGDefinition methodsFor: 'annotations' stamp: 'nil'!
annotationNamed: annotationName ifAbsent: exceptionBlock 
	"Answer the value of the annotation named <annotationName>. If the 
	annotation is not defined for the receiver, answer the result of 
	evaluating the <exceptionBlock>."

	self hasAnnotations
		ifFalse: [ ^exceptionBlock value ].

	^self annotations
			at: annotationName
			ifAbsent: [ exceptionBlock value ]! !

!RGDefinition methodsFor: 'annotations' stamp: 'nil'!
annotations

	^annotations ifNil:[ annotations:= IdentityDictionary new ]! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isPool

	^false! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isSlice

	^false! !

!RGDefinition methodsFor: 'converting' stamp: 'nil'!
asRingDefinition
	^ self! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isReference 

	^false! !

!RGDefinition methodsFor: '*Epicea-Ring' stamp: ''!
asEpiceaRingDefinition

	^ self! !

!RGDefinition methodsFor: 'accessing' stamp: 'nil'!
name

	^name! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isNamespace

	^false! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isVariable

	^false! !

!RGDefinition methodsFor: 'annotations' stamp: 'nil'!
annotationNamed: annotationName put: value 

	self annotations
		at: annotationName
		put: value! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isInheritance

	^false! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isGlobalVariable

	^false! !

!RGDefinition methodsFor: 'testing - types' stamp: 'nil'!
isAccess 

	^false! !

!RGDefinition methodsFor: 'annotations' stamp: 'nil'!
hasAnnotations

	^annotations notNil! !

!RGDefinition class methodsFor: 'annotations' stamp: 'nil'!
fullNameKey

	^#fullName! !

!RGDefinition class methodsFor: 'annotations' stamp: 'nil'!
authorKey

	^#author! !

!RGDefinition class methodsFor: 'class initialization' stamp: 'nil'!
named: aName

	^self new
		name: aName asSymbol;
		yourself! !

!RGDefinition class methodsFor: 'testing' stamp: 'nil'!
isAbstract

	^ self == RGDefinition! !

!RGDefinition class methodsFor: 'annotations' stamp: 'nil'!
timeStampKey

	^#timestamp! !

!RGDoubleByteLayout commentStamp: ''!
Ring2 model of DoubleByteLayout!
!RGDoubleByteLayout methodsFor: 'testing - types' stamp: ''!
isByteLayout

	^ true! !

!RGDoubleWordLayout commentStamp: ''!
Ring2 model of DoubleWordLayout!
!RGDoubleWordLayout methodsFor: 'testing' stamp: ''!
isWordLayout
	^ true! !

!RGElement commentStamp: ''!
RG2Element is the abstract class for representing elements of a class-alike definition (i.e., methods, variables, comment).

parent holds the RG2ClassDefinition or RG2Metaclass 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
	aRG2MethodDefinition parentName
	
Example:
	(Point>>#dist:) asRing2Definition parentName
		->  #Point
		
* If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent
	aRG2MethodDefinition parent
	
Example:
	aRG2MethodDefinition(Point>>#dist:) parent
		->  aRG2ClassDefinition(Point)
		
* If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realParent
	aRG2MethodDefinition realParent
	
Example:
	(Point>>#dist:) asRing2Definition 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:) asRing2Definition class
		->  RingMethodDefinition
		
* The message className returns the name of the ring class defining the reingMethodDefinition.

Example:
	(Point>>#dist:) asRing2Definition className
		->  #Point		
		
* If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent
	aRG2MethodDefinition ringClass
	
Example:
	aRG2MethodDefinition(Point>>#dist:) ringClass
		->  aRG2ClassDefinition(Point)
		
		
* If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realClass
	aRG2MethodDefinition realClass
	
Example:
	(Point>>#dist:) asRing2Definition realClass
		->  Point

!
!RGElementDefinition commentStamp: ''!
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: 'nil'!
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: 'comparing' stamp: 'nil'!
= 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: 'testing' stamp: 'nil'!
isDefined
	"isDefined when the receiver has its realClass defined in the system"

	^self realClass notNil! !

!RGElementDefinition methodsFor: 'comparing' stamp: 'nil'!
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: 'nil'!
instanceSideParentName
	"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: 'generic parent api' stamp: 'nil'!
parentName
	"Retrieves the name of the class defining the receiver. Its value is kept as an annotation"

	^ self annotationNamed: self class classNameKey! !

!RGElementDefinition methodsFor: '*Epicea-Ring' stamp: ''!
epiceaCleanUp

	parent := nil.! !

!RGElementDefinition methodsFor: 'class element specific api' stamp: 'nil'!
className: aName
	
	^ self parentName: aName! !

!RGElementDefinition methodsFor: 'testing' stamp: 'nil'!
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: '*Epicea-Ring' stamp: ''!
asEpiceaRingDefinition

	^ self shallowCopy
		epiceaCleanUp;
		yourself! !

!RGElementDefinition methodsFor: 'private' stamp: 'nil'!
setParentInfo: anObject
	"anObject is aRGBehaviorDefinition or aClass/aTrait"

	self parentName: anObject name. 
	self isMetaSide: anObject isMeta! !

!RGElementDefinition methodsFor: 'class element specific api' stamp: 'nil'!
ringClass
	"Return the ring definition of the class containing the receiver."
	
	^ self parent! !

!RGElementDefinition methodsFor: 'generic parent api' stamp: 'nil'!
parent: aRGBehaviorDefinition
	"Set the class associated to the receiver"

	parent := aRGBehaviorDefinition.
	self setParentInfo: aRGBehaviorDefinition.! !

!RGElementDefinition methodsFor: '*Deprecated10' stamp: ''!
theNonMetaParentName

	self
		deprecated: 'Please use #instanceSideParentName instead'
		transformWith: '`@receiver theNonMetaParentName' -> '`@receiver instanceSideParentName'.
	^ self instanceSideParentName! !

!RGElementDefinition methodsFor: 'generic parent api' stamp: 'nil'!
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: '*Tool-Base' stamp: ''!
browse

	^ Smalltalk tools browser openOnClass: self realClass! !

!RGElementDefinition methodsFor: 'backward compatibility' stamp: 'nil'!
actualClass
	"returns the Smalltalk class of the receiver"
	
	^ self realClass! !

!RGElementDefinition methodsFor: 'accessing' stamp: 'nil'!
fullName: aString

	^ self annotationNamed: self class fullNameKey put: aString asSymbol! !

!RGElementDefinition methodsFor: 'generic parent api' stamp: 'nil'!
parentName: aString

	self annotationNamed: self class classNameKey put: aString asSymbol! !

!RGElementDefinition methodsFor: 'class element specific api' stamp: 'nil'!
realClass
	"Retrieves the Class/Trait/.. object in the System corresponding to the class of the this element."
	
	^ self realParent! !

!RGElementDefinition methodsFor: 'accessing' stamp: 'nil'!
package
	^ self parent ifNotNil: [ :p | p package ]! !

!RGElementDefinition methodsFor: 'generic parent api' stamp: 'nil'!
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: 'class element specific api' stamp: 'nil'!
className
	
	^ self parentName! !

!RGElementDefinition methodsFor: 'accessing' stamp: 'nil'!
isMetaSide: aBoolean

	self annotationNamed: self class isMetaSideKey put: aBoolean! !

!RGElementDefinition class methodsFor: 'parsing stamp' stamp: 'nil'!
parseTimestampFrom: aString
	
	^self parseTimestampFrom: aString default: nil! !

!RGElementDefinition class methodsFor: 'parsing stamp' stamp: 'nil'!
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:
		<authorname><date><time>. 
		<authorname><date>
		<date><time>
		<date><time><authorname>
		<date><authorname>
		<historical>
	All fields can be separated by spaces or line ends but a separator between author alias/name and date can be missing as well"
	"unknown:= 'unknown'."
	unknown := nil.
	aString isEmptyOrNil
		ifTrue: [ ^ unknown ].
	dateStartIndex := (aString indexOf: $/) - 1.	"If there is no / character in the timestamp, no author alias/name exists"
	dateStartIndex = -1
		ifTrue: [ ^ unknown ].
	^ [ 
	"Go the start of the date string (there can be 1 or 2 digits and a space separator can be missing at the front!!!!)"
	(dateStartIndex >= 2 and: [ (aString at: dateStartIndex - 1) isDigit ])
		ifTrue: [ dateStartIndex := dateStartIndex - 1 ].	"Extract only those tokens that do not possible represent date or time - meaning that authorname may be at the end"
	tokens := (aString copyFrom: dateStartIndex to: aString size) substrings
		reject: [ :token | (token occurrencesOf: $/) = 2 or: [ (token occurrencesOf: $:) = 1 ] ].	"only one token should be left if author name/alias exists"
	^ tokens isEmpty
		ifTrue: [ 
			"if dateStartIndex is not 1 then the authorname may be at the beginning"
			dateStartIndex > 1
				ifTrue: [ (aString copyFrom: 1 to: dateStartIndex - 1) trimBoth ]
				ifFalse: [ unknown ] ]
		ifFalse: [ tokens first ] ]
		on: Exception
		do: [ :e | unknown ]! !

!RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'nil'!
statusKey

	^#statusKey! !

!RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'nil'!
classNameKey

	^#className! !

!RGElementDefinition class methodsFor: 'class initialization' stamp: 'nil'!
realClass: aClass
	"The argument is a Smalltalk class and the parent of a method, variable, class comment.
	However it is not set as parent but only its name and scope (instance/class)"

	^self new
		parent: aClass asRingDefinition;
		yourself! !

!RGElementDefinition class methodsFor: 'class initialization' stamp: 'nil'!
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: 'testing' stamp: 'nil'!
isAbstract

	^ self == RGElementDefinition! !

!RGElementDefinition class methodsFor: 'parsing stamp' stamp: 'nil'!
parseAuthorAliasFrom: aString
	"Allows other applications  to treat a different empty alias by overriding this method"
	
	^self basicParseAuthorAliasFrom: aString! !

!RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'nil'!
isMetaSideKey

	^#isMetaSide! !

!RGElementDefinition class methodsFor: 'parsing stamp' stamp: 'nil'!
parseTimestampFrom: aString default: anObject
	"Parse a date-time from a timestamp-string that is extracted from a source file. If there is no timestamp, or we cannot make sense of it, we return the default value."

	| tokens dateStartIndex unknown |
	"The following timestamp strings are supported:
		<authorname><date><time>. 
		<authorname><date>
		<date><time>
		<date><time><authorname>
		<date><authorname>
		<historical>
	All fields can be separated by spaces or line ends but a separator between authorname and date can be missing as well"
	unknown := anObject.
	aString isEmptyOrNil
		ifTrue: [ ^ unknown ].
	dateStartIndex := (aString indexOf: $/) - 1.	"If there is no / character in the timestamp, we cannot parse a date and return the epoch"
	dateStartIndex = -1
		ifTrue: [ ^ unknown ].
	^ [ 
	"Go the start of the date string (there can be 1 or 2 digits and a space separator can be missing at the front!!!!)"
	(dateStartIndex >= 2 and: [ (aString at: dateStartIndex - 1) isDigit ])
		ifTrue: [ dateStartIndex := dateStartIndex - 1 ].	"Extract only those tokens that possibly represent date or time"
	tokens := (aString copyFrom: dateStartIndex to: aString size) substrings
		select: [ :token | (token occurrencesOf: $/) = 2 or: [ (token occurrencesOf: $:) = 1 ] ].	"2 tokens is a datetime"
	tokens size = 2
		ifTrue: [ (tokens joinUsing: Character space) asDateAndTime ]
		ifFalse: [ tokens first asDate asDateAndTime ] ]
		on: Exception
		do: [ :e | unknown ]! !

!RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'nil'!
sourcePointerKey 

	^#sourcePointer! !

!RGEmptyLayout methodsFor: 'testing - types' stamp: ''!
isEmptyLayout

	^ true! !

!RGEnsureTraitTest methodsFor: 'running' stamp: ''!
testTraitIfClassAlreadyExists
	"test creation of named trait if a class of the realted name already exists"

	| existing |
	existing := environment ensureClassNamed: 'SomeTrait'.
	self assert: existing isClass.
	self assert: existing isRingResolved.

	definition := environment ensureTraitNamed: 'SomeTrait'.
	self assert: definition identicalTo: existing.
	self assert: definition isClass not.
	self assert: definition isMetaclass not.
	self assert: definition isTrait.
	self assert: definition isMetaclassTrait not! !

!RGEnsureTraitTest methodsFor: 'running' stamp: ''!
testClassTraitIfTraitAlreadyExists
	"test creation of named class trait if a related trait already exists"

	| existing |
	existing := (environment ensureTraitNamed: 'SomeTrait') classTrait.
	self assert: existing isMetaclassTrait.
	self assert: existing isRingResolved not.

	definition := environment ensureTraitNamed: 'SomeTrait classTrait'.
	self assert: definition identicalTo: existing.
	self assert: definition isClass not.
	self assert: definition isMetaclass not.
	self assert: definition isTrait.
	self assert: definition isMetaclassTrait.
	self assert: definition baseTrait name equals: #SomeTrait! !

!RGEnsureTraitTest methodsFor: 'running' stamp: ''!
testClassTrait
		
	"test creation of named class trait on empty environment"

	definition := environment ensureTraitNamed: 'SomeTrait classTrait'.
	self assert: definition isClass not. 
	self assert: definition isMetaclass not. 	
	self assert: definition isTrait. 	
	self assert: definition isMetaclassTrait. 	
! !

!RGEnsureTraitTest methodsFor: 'running' stamp: ''!
testClassTraitIfMetaclassAlreadyExists
	"test creation of named class trait if a related metaclass already exists"

	| existing |
	existing := (environment ensureClassNamed: 'SomeTrait class') baseClass.
	self assert: existing isClass.
	self assert: existing isRingResolved not.

	definition := environment ensureTraitNamed: 'SomeTrait classTrait'.
	self assert: definition baseTrait identicalTo: existing.
	self assert: definition baseTrait isClass not.
	self assert: definition baseTrait isMetaclass not.
	self assert: definition baseTrait isTrait.
	self assert: definition baseTrait isMetaclassTrait not.
	self assert: definition baseTrait name equals: #SomeTrait! !

!RGEnsureTraitTest methodsFor: 'running' stamp: ''!
testTraitIfClassTraitAlreadyExists
	"test creation of named trait if a related class trait already exists"

	| existing |
	existing := (environment ensureTraitNamed: 'SomeTrait classTrait') baseTrait.
	self assert: existing isTrait.
	self assert: existing isRingResolved not.

	definition := environment ensureTraitNamed: 'SomeTrait'.
	self assert: definition identicalTo: existing.
	self assert: definition isClass not.
	self assert: definition isMetaclass not.
	self assert: definition isTrait.
	self assert: definition isMetaclassTrait not! !

!RGEnsureTraitTest methodsFor: 'running' stamp: ''!
testTrait

	"test creation of named trait on empty environment"
		
	definition := environment ensureTraitNamed: 'SomeTrait'.
	self assert: definition isClass not. 
	self assert: definition isMetaclass not. 	
	self assert: definition isTrait. 	
	self assert: definition isMetaclassTrait not. 	! !

!RGEnsureTraitTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	environment := RGEnvironment new.! !

!RGEnvironment commentStamp: ''!
I'm a representation of a Pharo environment that contains behaviors, packages and global variables. I have my own announcer for processing of events inside of the environment. 

I'm connected to a data source - backend, that provides me real data I'm working with. 

In most cases, you should communicate with me using my query interface. You will get it by sending me a message #ask.
!
!RGEnvironment methodsFor: 'utilities' stamp: ''!
createDefaultEnvironment

	| protoobject protoobjectClass object objectClass class classClass classDescription classDescriptionClass behavior behaviorClass metaclass metaclassClass kernelPackage |
	
	protoobject := RGClass unresolvedNamed: #'ProtoObject' withParent: self.
	protoobjectClass := RGMetaclass unresolvedNamed: #'ProtoObject class' withParent: self.
	object := RGClass unresolvedNamed: #'Object' withParent: self.
	objectClass := RGMetaclass unresolvedNamed: #'Object class' withParent: self.
	class := RGClass unresolvedNamed: #'Class' withParent: self.
	classClass := RGMetaclass unresolvedNamed: #'Class class' withParent: self.
	classDescription := RGClass unresolvedNamed: #'ClassDescription' withParent: self.
	classDescriptionClass := RGMetaclass unresolvedNamed: #'ClassDescription class' withParent: self.
	behavior := RGClass unresolvedNamed: #'Behavior' withParent: self.
	behaviorClass := RGMetaclass unresolvedNamed: #'Behavior class' withParent: self.
	metaclass := RGClass unresolvedNamed: #'Metaclass' withParent: self.
	metaclassClass := RGMetaclass unresolvedNamed: #'Metaclass class' withParent: self.
	kernelPackage := RGPackage unresolvedNamed: #'Kernel' withParent: self.
	
	{ protoobject. protoobjectClass. object. objectClass. class. classClass. classDescription. classDescriptionClass. behavior. behaviorClass. metaclass. metaclassClass } do: [ :each |
		kernelPackage pvtAddDefinedBehavior: each.
		self pvtAddBehavior: each.].
	self pvtAddPackage: kernelPackage.
	
	protoobject pvtSuperclass: protoobject.
	protoobject pvtMetaclass: protoobjectClass.
	protoobject behaviorStrategy pvtPackage: kernelPackage.

	protoobjectClass pvtSuperclass: class.
	protoobjectClass pvtMetaclass: metaclass.

	object pvtSuperclass: protoobject.
	object pvtMetaclass: objectClass.
	object behaviorStrategy pvtPackage: kernelPackage.

	objectClass pvtSuperclass: protoobjectClass.
	objectClass pvtMetaclass: metaclass.

	class pvtSuperclass: classDescription.
	class pvtMetaclass: classClass.
	class behaviorStrategy pvtPackage: kernelPackage.

	classClass pvtSuperclass: classDescriptionClass.
	classClass pvtMetaclass: metaclass.

	classDescription pvtSuperclass: behavior.
	classDescription pvtMetaclass: classDescriptionClass.
	classDescription behaviorStrategy pvtPackage: kernelPackage.

	classDescriptionClass pvtSuperclass: behaviorClass.
	classDescriptionClass pvtMetaclass: metaclass.

	behavior pvtSuperclass: object.
	behavior pvtMetaclass: behaviorClass.
	behavior behaviorStrategy pvtPackage: kernelPackage.

	behaviorClass pvtSuperclass: objectClass.
	behaviorClass pvtMetaclass: metaclass.

	metaclass pvtSuperclass: classDescription.
	metaclass pvtMetaclass: metaclassClass.
	metaclass behaviorStrategy pvtPackage: kernelPackage.

	metaclassClass pvtSuperclass: classDescriptionClass.
	metaclassClass pvtMetaclass: metaclass.


		! !

!RGEnvironment methodsFor: 'private - backend interface' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#behaviors -> behaviors. 
		#packages -> packages. 
		#globalVariables -> globalVariables. 
	}
	
	! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
removeBehavior: anRGBehavior

	self backend forEnvironment removeBehavior: anRGBehavior from: self.
	
	"remove extensions methods deleted with the behavior from owning packages"
	anRGBehavior extensions do: [ :each |
		each package removeExtensionMethod: each ].
	
	(anRGBehavior package notNil and: [anRGBehavior package  definedBehaviors includes: anRGBehavior]) ifTrue: [ 
	anRGBehavior package removeDefinedBehavior: anRGBehavior.
	].
	
	self announcer behaviorRemoved: anRGBehavior.
	
	(anRGBehavior hasResolvedName) ifTrue: [ 
		self queryInterface behaviorsDictionary removeKey: anRGBehavior name ifAbsent: []].
! !

!RGEnvironment methodsFor: 'accessing' stamp: ''!
definitionFor: anObject

	^ self backend definitionFor: anObject.! !

!RGEnvironment methodsFor: 'private - backend access' stamp: ''!
pvtAddGlobalVariable: anRGGlobalVariable

	self environment verifyOwnership: anRGGlobalVariable.
	
	globalVariables isRingResolved ifFalse: [ 
		self pvtCleanGlobalVariables  ].
	
	globalVariables add: anRGGlobalVariable.	! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
ensureMetaclass

	| aMetaclass |
	
	aMetaclass := self ask behaviorNamed: #Metaclass.
	aMetaclass ifNotNil: [ ^ aMetaclass ].
	
	aMetaclass := self ask behaviors detect: [ :each | 
		(each propertyNamed: #Metaclass ifAbsent: [ false ]) ] ifNone: [ nil ].
	aMetaclass ifNotNil: [ ^ aMetaclass ].

	aMetaclass := self ensureClassNamed: #Metaclass.	
	
	aMetaclass propertyNamed: #Metaclass put: true.	
	
	^ aMetaclass.! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
addBehavior: anRGBehavior

	self backend forEnvironment
		addBehavior: anRGBehavior
		to: self.
	anRGBehavior isMeta ifFalse: [
		anRGBehavior package
			ifNotNil: [ :package | 
				self backend forEnvironment addPackage: anRGBehavior package	to: self.
				package addDefinedBehavior: anRGBehavior. ].
		"self backend forEnvironment
					addGlobalVariable: (RGGlobalVariable named: anRGBehavior name parent: self)
					to: self" ].

	(anRGBehavior hasResolvedName)
		ifTrue: [ self queryInterface behaviorsDictionary at: anRGBehavior name asSymbol put: anRGBehavior ].
				
! !

!RGEnvironment methodsFor: 'accessing' stamp: ''!
environment 

	^ self! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
cleanSuperclassesOfMetaclasses

	"fix suprclasses of metaclasses do not pointing to metaclasses of superclasses"
	 
	self ask behaviorsDo: [ :each | 
		(each isMetaclass and: [ each superclass isRingResolved not ])
			ifTrue: [ 
				each baseClass superclass ifNotNil: [ 
					each superclass: each baseClass superclass metaclass] ] ].
! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
packagesDo: aBlock

	self backend  packagesFor: self do: aBlock! !

!RGEnvironment methodsFor: '*Ring-RuntimeSupport' stamp: ''!
hasBindingThatBeginsWith: aString
	"Use the cached class and non-class names for better performance."

	| aName searchBlock |
	searchBlock := [ :element |
		(element beginsWith: aString)
			ifTrue: [ 0 ]
			ifFalse: [
				aString < element
					ifTrue: [ -1 ]
					ifFalse: [ 1 ] ] ].
	aName := self classNames 
		findBinary: searchBlock
		ifNone: [nil].
	aName ifNotNil: [ ^true ].
	aName := self nonClassNames 
		findBinary: searchBlock
		ifNone: [nil].
	^aName notNil! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
classNamed: aString 
	| association |
	association := self bindingOf: aString.
	^ association ifNotNil: [ association value ]
		ifNil: [ self error: 'Class "', aString, '" not found' ]! !

!RGEnvironment methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
adoptForBrowser
	| unresolved extensionsPackage |
	extensionsPackage := self ensurePackageNamed: '*Extensions*'.
	unresolved := packages reject: [ :each | each hasResolved: #name ].
	unresolved do: [ :each | 
		each classes 
			select: [ :eachClass | (eachClass hasResolved: #name) and: [ 
					eachClass extensions notEmpty or: [ eachClass classSide extensions notEmpty ] ] ] 
			thenDo: [ :eachClass | eachClass package: extensionsPackage] ].
	unresolved do: [ :each | self removePackage: each ].! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
removePackage: anRGPackage

	self backend forPackage removePackage: anRGPackage from: self.
	
	self announce: (RPackageUnregistered to: anRGPackage).
! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
clean

	self cleanWithMetaclassNamed: #Metaclass
! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
unifyMetaclass

	"set all metaclasses of metaclasses to the same object (Metaclass) "

	| aMetaclass |

	aMetaclass := self ensureMetaclass.
	 
	self ask behaviorsDo: [ :each | 
		(each isMetaclass)
			ifTrue: [ each metaclass: aMetaclass] ].
! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
cleanUnusedUnreferencedBehaviors

	"remove behaviors that are not linked in the graph of the named behaviors"
	
	| referenced unreferenced newelyAdded |
	
	referenced := IdentitySet new.
	self ask behaviorsDo: [ :each |
		(each hasResolvedName) ifTrue: [ 
			referenced add: each.
			referenced addAll: (each referencedBehaviors copyWithoutAll: {each. nil}) ]  ].
	[	newelyAdded := IdentitySet new.
		(referenced copyWithout: nil) do: [ :each | 
			each referencedBehaviors do: [ :ref |
				(referenced includes: ref) ifFalse: [
					referenced add: ref.
					newelyAdded add: ref]]].
		newelyAdded isEmpty ] whileFalse.

	unreferenced := (self ask behaviors copyWithoutAll: referenced).

	unreferenced do: [:each | self removeBehavior: each  ].
	
	^ unreferenced! !

!RGEnvironment methodsFor: '*Ring-RuntimeSupport' stamp: ''!
addGlobalsNamed: anArrayOfSymbols

	anArrayOfSymbols do: [ :each |
		self addGlobalVariable: (RGGlobalVariable named: each parent: self)].! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
browseAs: browserTitleString

	 | clyEnv clyNavEnv browser |
	self adoptForBrowser.
	clyEnv := ClyRing2Environment new.
	clyEnv environment: self.
	clyEnv name: browserTitleString.

	clyNavEnv := (ClyNavigationEnvironment over: clyEnv)
		addPlugin: ClyDefaultSystemEnvironmentPlugin new;
	   attachToSystem.

	browser := ClyFullBrowserMorph new 
		navigationEnvironment: clyNavEnv;
		addPlugin: ClyStandardBrowserPlugin new.

	^ browser open.! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
behaviorsDo: aBlock

	self backend forEnvironment behaviorsFor: self do: aBlock! !

!RGEnvironment methodsFor: 'default model values' stamp: ''!
defaultPackages

	^ IdentitySet new! !

!RGEnvironment methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	behaviors := self unresolvedValue: self defaultBehaviors.
	packages := self unresolvedValue: self defaultPackages.
	globalVariables := self unresolvedValue: self defaultGlobalVariables.
	
	version := self defaultVersion
	
! !

!RGEnvironment methodsFor: 'binding' stamp: ''!
globalVariablesBindings

	^ self propertyNamed: #globalVariablesBindings ifAbsentPut: [ IdentityDictionary new.]! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
systemDictionary
	^ self! !

!RGEnvironment methodsFor: 'accessing' stamp: ''!
backend: anRGEnvironmentBackend

	^ backend := anRGEnvironmentBackend! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
addPackage: anRGPackage

	self backend forPackage addPackage: anRGPackage to: self.
	
	self announce: (RPackageRegistered to: anRGPackage).
! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
compileANewClassFrom: aString notifying: aMorph startingFrom: aClass 
	| importer |
	
	importer := RGChunkImporter new.
	importer environment: self environment.
	importer fileInFrom: (aString, '!!') readStream.
	
	^ aClass! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
unifyMetaclass: aProposedName

	"set all metaclasses of metaclasses to the same object (Metaclass) "

	| aMetaclass |

	aMetaclass := self ensureMetaclass: aProposedName.
	 
	self ask behaviorsDo: [ :each | 
		(each isMetaclass)
			ifTrue: [ each metaclass: aMetaclass] ].
! !

!RGEnvironment methodsFor: 'private - backend access' stamp: ''!
pvtCleanGlobalVariables

	globalVariables := self defaultGlobalVariables.! !

!RGEnvironment methodsFor: 'private - backend interface' stamp: ''!
pvtCleanPackages

	packages := self defaultPackages.
		
	"TODO:Announce if not empty"
	
	! !

!RGEnvironment methodsFor: 'unpackaged' stamp: ''!
removeUnusedPackages

	"remove all packages that are not used in the system. It cannot be done automatically
	for every change in the package structure because then it would be impossible to 
	create e.g. an environment with one empty package"
	
	| usedPackages | 
	
	usedPackages := IdentitySet new.
	self behaviorsDo: [ :behavior |
		behavior isMeta 
			ifFalse: [ usedPackages add: behavior package]. 
		behavior localMethodsDo: [ :method |
			  usedPackages add: method package]].
		
	self ask packages copy do: [ :each |
		(usedPackages includes: each) 
			ifFalse: [ self removePackage: each ] ].! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
unifyTrait

	"set all metaclasses of metaclasses to the same object (Metaclass) "

	| aTrait |

	aTrait := self ensureTrait.
	 
	self ask behaviorsDo: [ :each | 
		(each isTrait)
			ifTrue: [ each metaclass: aTrait]].
		
	(self ask behaviors select: [ :each | each isRingResolved not and: [(each propertyNamed: #role) = #trait] ]) do: [:each | self removeBehavior: each  ].
			
! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
browse

	^self browseAs: self printString! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
cleanGlobalVariables

	self backend forBehavior cleanGlobalVariablesFor: self.! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
cleanUnusedUnreferencedPackages

	"remove packages that are not not used"
	
	| referenced unreferenced |
	
	referenced := IdentitySet new.
	self ask behaviorsDo: [ :each |
		referenced addAll: each referencedPackages ].
	
	unreferenced := (self ask packages copyWithoutAll: referenced).

	unreferenced do: [:each | self removePackage: each  ].
	
	^ unreferenced! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
ensureMetaclass: aProposedName

	| aMetaclass |
	
	aMetaclass := self ask behaviorNamed: aProposedName.
	aMetaclass ifNotNil: [ ^ aMetaclass ].
	
	aMetaclass := self ask behaviors detect: [ :each | 
		(each propertyNamed: #Metaclass ifAbsent: [ false ]) ] ifNone: [ nil ].
	aMetaclass ifNotNil: [ ^ aMetaclass ].

	aMetaclass := self ensureClassNamed: aProposedName.	
	
	aMetaclass propertyNamed: #Metaclass put: true.	
	
	^ aMetaclass.! !

!RGEnvironment methodsFor: 'unpackaged' stamp: ''!
ensureUnpackagedPackage

	^ self unpackagedPackageOrNil
		ifNotNil: [ :found | found ]
		ifNil: [ | newPackage |
			newPackage := RGPackage unresolvedWithParent: self.
			newPackage pvtName: self unpackagedPackageName.
			self pvtAddPackage: newPackage.
			^ newPackage ]! !

!RGEnvironment methodsFor: 'private - backend interface' stamp: ''!
pvtAddBehavior: anRGBehavior

	self environment verifyOwnership: anRGBehavior.
	
	behaviors isRingResolved ifFalse: [ 
		self pvtCleanBehaviors ].
	
	(behaviors includes: anRGBehavior)
		ifFalse: [ 
			behaviors add: anRGBehavior.
			self announcer behaviorAdded: anRGBehavior].
		
	
		! !

!RGEnvironment methodsFor: 'resolving' stamp: ''!
makeResolved

	super makeResolved.
	
	behaviors := self ask behaviors markAsRingResolved.
	packages := self ask packages markAsRingResolved.
	globalVariables := self ask globalVariables markAsRingResolved.
	
! !

!RGEnvironment methodsFor: 'accessing' stamp: ''!
queryInterface

	^ self ask! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
ensureTraitNamed: aSymbol

	| found siblingName sibling |
	
	self assert: (aSymbol endsWith: ' class') not.

	"process classTraits"
	(aSymbol endsWith: ' classTrait') ifTrue: [ 
		^ self ensureMetaclassTraitNamed: aSymbol ].
	
	"a trait with the same name already exists"
	found := self ask behaviorNamedExactlyAs: aSymbol.
	(found notNil and: [ found isTrait ]) ifTrue: [ ^ found ].
	
	^ found 
		ifNil: [ 
			"trait not found, check if the environment contains already a correspoinding metaclass trait"
			siblingName := (aSymbol, ' classTrait') asSymbol.
			sibling := self ask behaviorNamedExactlyAs: siblingName.
			sibling 
				ifNotNil: [ 
					"resolve and return existing corresponding trait"
					| existing |
					existing := sibling baseTrait.
					existing name: aSymbol.
					existing propertyNamed: #resolved put: true.
					existing ]
				ifNil: [ 
					"we need to create new behavior"
					| newBehavior |
					newBehavior := RGTrait named: aSymbol parent: self.
					self addBehavior: newBehavior.
					newBehavior ] ]
		ifNotNil: [
			"some non-trait behavior found. We created this trait before as a class because correct behavior type was not known."
			found convertToTrait.
			found metaclass convertToMetaclassTrait.
			found ].
	
	! !

!RGEnvironment methodsFor: 'unpackaged' stamp: ''!
unpackagedPackageName

	^ '_UnpackagedPackage' asSymbol! !

!RGEnvironment methodsFor: 'accessing' stamp: ''!
package

	^ nil! !

!RGEnvironment methodsFor: 'default model values' stamp: ''!
defaultBehaviors

	^ IdentitySet new! !

!RGEnvironment methodsFor: 'private - backend interface' stamp: ''!
pvtCleanBehaviors

	behaviors := self defaultBehaviors.
		
	"TODO:Announce if not empty"
	
	! !

!RGEnvironment methodsFor: 'private - backend access' stamp: ''!
pvtRemoveGlobalVariable: anRGGlobalVariable

	self environment verifyOwnership: anRGGlobalVariable.
	
	globalVariables remove: anRGGlobalVariable.! !

!RGEnvironment methodsFor: 'default model values' stamp: ''!
defaultGlobalVariables

	^ IdentitySet new! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
associationsDo: aBlock

	self bindings do: aBlock! !

!RGEnvironment methodsFor: 'unpackaged' stamp: ''!
unpackagedPackageOrNil

	self packagesDo: [ :each |
		(each name = self unpackagedPackageName) ifTrue: [ ^ each ] ].
	
	^ nil.
! !

!RGEnvironment methodsFor: 'binding' stamp: ''!
bindingOf: aSymbol
	
	| behavior result |	

	(ReservedVariable nameIsReserved: aSymbol)
		ifTrue: [ ^ ReservedVariable lookupDictionary at: aSymbol ].

	self globalVariablesBindings at: aSymbol ifPresent: [ :val | ^ val ].
	
	self ask globalVariables detect: [ :each | each name = aSymbol  ] ifFound: [ :found | 
		self globalVariablesBindings at: aSymbol put: found.
		^ found ].

	behavior := self ask behaviorNamed: aSymbol.
	result := behavior ifNotNil: [ GlobalVariable key: aSymbol value: behavior].
	self globalVariablesBindings at: aSymbol put: result.
	^ result! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
ensureClassTrait

	| aClassTrait |
	
	aClassTrait := self ask behaviorNamed: #ClassTrait.
	aClassTrait ifNotNil: [ ^ aClassTrait ].
	
	aClassTrait := self ask behaviors detect: [ :each | 
		(each propertyNamed: #ClassTrait ifAbsent: [ false ]) ] ifNone: [ nil ].
	aClassTrait ifNotNil: [ ^ aClassTrait ].

	aClassTrait := self ensureClassNamed: #ClassTrait.	
	
	aClassTrait propertyNamed: #ClassTrait put: true.	
	
	^ aClassTrait.! !

!RGEnvironment methodsFor: 'unpackaged' stamp: ''!
unpackagedPackage

	| aProtocol |
	aProtocol := RGPackage unresolvedWithParent: self.
	aProtocol pvtName: self unpackagedPackageName.
	
	^ aProtocol
! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
addGlobalVariable: anRGGlobalVariable 

	self backend forBehavior addGlobalVariable: anRGGlobalVariable to: self.! !

!RGEnvironment methodsFor: '*Ring-Monticello' stamp: ''!
writeIntoFileTree: aMCFileTreeRepository

	(self ask packages select: #isRingResolved) do: [ :aPackage |
		| aSnapshot info aVersion |
		aSnapshot := aPackage asMCSnapshot.

		info := MCVersionInfo new.
		info instVarNamed: #name put: aPackage name, '-author'.
		aVersion := MCVersion package: (MCPackage new name: aPackage name) info: info snapshot: aSnapshot dependencies: #().
		IceMetadatalessFileTreeWriter
			fileOut: (aVersion)
			on: (aMCFileTreeRepository) ].
		! !

!RGEnvironment methodsFor: '*Ring-Monticello' stamp: ''!
writeIntoTonel: aFileReference

	(self ask packages select: #isRingResolved) do: [ :aPackage |
		| aSnapshot info aVersion |
		aSnapshot := aPackage asMCSnapshot.

		info := MCVersionInfo new.
		info instVarNamed: #name put: aPackage name, '-author'.
		aVersion := MCVersion package: (MCPackage new name: aPackage name) info: info snapshot: aSnapshot dependencies: #().
		TonelWriter 
			fileOut: (aVersion)
			on: aFileReference ]		! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
ensureClassNamed: aSymbol

	self assert: (aSymbol endsWith: ' classTrait') not.

	^ self ask behaviorNamedExactlyAs: aSymbol ifAbsent: [ 
		 | behaviorClass newBehavior sibling siblingName |
		siblingName := (aSymbol endsWith: ' class') 
			ifTrue: [ aSymbol withoutSuffix: ' class' ]
			ifFalse: [ (aSymbol, ' class') asSymbol ].
				
			sibling := self ask behaviors detect: [ :each | each name = siblingName ] ifNone: nil.
			sibling ifNotNil: [ 
				| result |
				result := sibling isMetaclass 
					ifTrue: [ sibling baseClass ]
					ifFalse: [ sibling metaclass ].
				result name: aSymbol.
				result propertyNamed: #resolved put: true.
				^ result ].
			
			behaviorClass := (aSymbol endsWith: ' class') 
				ifFalse: [ RGClass ]
				ifTrue: [ RGMetaclass ].
			newBehavior := behaviorClass named: aSymbol parent: self.
			self addBehavior: newBehavior.
			newBehavior ] ! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
cleanBehaviors

	| oldBehaviors |
	
	oldBehaviors := self ask behaviors.
	
	self backend forPackage cleanBehaviorsFor: self.
	
	oldBehaviors do: [ :each |
		self announcer behaviorRemoved: each ].
	
	self queryInterface resetBehaviorsDictionary.
! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
ensureTrait

	| aTrait |
	
	aTrait := self ask behaviorNamed: #Trait.
	aTrait ifNotNil: [ ^ aTrait ].
	
	aTrait := self ask behaviors detect: [ :each | 
		(each propertyNamed: #Trait ifAbsent: [ false ]) ] ifNone: [ nil ].
	aTrait ifNotNil: [ ^ aTrait ].

	aTrait := self ensureClassNamed: #Trait.	
	
	aTrait propertyNamed: #Trait put: true.	
	
	^ aTrait.! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
globalVariablesDo: aBlock

	self backend forBehavior globalVariablesFor: self do: aBlock! !

!RGEnvironment methodsFor: 'accessing' stamp: ''!
ask 

	^ queryInterface ifNil: [ queryInterface := RGEnvironmentQueryInterface for: self ].! !

!RGEnvironment methodsFor: 'testing' stamp: ''!
hasTraits

	self behaviorsDo: [ :each |
		each isTrait ifTrue: [ ^ true ] ].
	
	^ false! !

!RGEnvironment methodsFor: 'testing - types' stamp: ''!
isEnvironment

	^ true! !

!RGEnvironment methodsFor: 'events' stamp: ''!
child: aChildDefinition renamedFrom: oldName to: newName

	self queryInterface behaviorsDictionary removeKey: oldName ifAbsent: [].
	self queryInterface behaviorsDictionary at: newName asSymbol put: aChildDefinition.
! !

!RGEnvironment methodsFor: 'private - backend interface' stamp: ''!
pvtRemoveBehavior: anRGBehavior

	self verifyOwnership: anRGBehavior.
	
	behaviors remove: anRGBehavior.
	
	"TODO:Announce"
	
	! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
ensureMetaclassTraitNamed: aSymbol

	| found newTrait newMetaclassTrait similarMetaclass similarMetaclassName siblingName sibling originalMetaclass  |
	
	self assert: (aSymbol endsWith: ' class') not.
	self assert: (aSymbol endsWith: ' classTrait').

	found := self ask behaviorNamedExactlyAs: aSymbol.
	(found notNil and: [ found isMetaclassTrait ]) ifTrue: [ ^ found ].		

	^ found 
		ifNil: [ 
			"trait not found, check if the environment contains already a correspoinding trait"
			siblingName := (aSymbol withoutSuffix: ' classTrait') asSymbol.
			sibling := self ask behaviorNamedExactlyAs: siblingName.
			sibling 
				ifNotNil: [ 
					"resolve and return existing corresponding trait"
					| existing |
					sibling isTrait
						ifTrue: [ 
							existing := sibling classTrait.
							existing name: aSymbol.
							existing propertyNamed: #resolved put: true.
							existing ]
						ifFalse: [ 
							sibling convertToTrait.
							sibling classSide convertToMetaclassTrait.
							"sibling metaclass becomeForward: newMetaclassTrait.
							originalMetaclass becomeForward: newMetaclassTrait.
							sibling becomeForward: newTrait."
							"sibling classTrait: newMetaclassTrait.
							newMetaclassTrait baseTrait: sibling.
							"
							sibling classSide name: (siblingName, ' classTrait') asSymbol.
							sibling classSide propertyNamed: #resolved put: true.
							sibling classSide
							]]
				ifNil: [ 
					similarMetaclassName := ((aSymbol withoutSuffix: ' classTrait'), ' class') asSymbol.
					similarMetaclass := self ask behaviorNamed: similarMetaclassName.	
					similarMetaclass 
						ifNotNil: [
							"environment already contains metaclass of the similar name. It was probably 
							created because correct type was not known. Convert it to classTrait"
							| similarClass |
							similarClass := similarMetaclass baseClass.
							newMetaclassTrait := similarMetaclass behaviorStrategy pvtAsMetaclassTrait.
							newTrait := similarClass convertToTrait.
							"similarMetaclass becomeForward: newMetaclassTrait.
							similarClass becomeForward: newTrait."
							newTrait classTrait: newMetaclassTrait.
							newMetaclassTrait baseTrait: newTrait.
							newTrait name: siblingName asSymbol.
							newMetaclassTrait ]
						ifNil: [ 
							"we need to create new behavior"
							| newBehavior |
							newBehavior := RGMetaclassTrait named: aSymbol parent: self.
							self addBehavior: newBehavior.
							newBehavior ] ] ]
		ifNotNil: [
			"some non-trait behavior found. We created this trait before as a class because correct behavior type was not known."
			newTrait := found convertToTrait.
			originalMetaclass := found metaclass.
			newMetaclassTrait := originalMetaclass pvtAsMetaclassTrait.
			self ask replaceName: originalMetaclass name with: newMetaclassTrait name.
			"found becomeForward: newTrait.
			found metaclass becomeForward: newMetaclassTrait.
			originalMetaclass becomeForward: newMetaclassTrait."
			found ].
	
				
! !

!RGEnvironment methodsFor: 'private - backend interface' stamp: ''!
pvtRemovePackage: anRGPackage

	self verifyOwnership: anRGPackage.
	
	packages remove: anRGPackage.
	
	"TODO:Announce"
	
	! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
at: aSymbol

	^ self ask behaviorNamed: aSymbol! !

!RGEnvironment methodsFor: 'accessing' stamp: ''!
announcer

	^ announcer ifNil: [ announcer := RGEnvironmentAnnouncer new ]! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
at: aString ifAbsent: aBlockClosure 
	| association |
	association := self bindingOf: aString.
	^ association 
		ifNotNil: [ association value ]
		ifNil: aBlockClosure! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
bindings

	"TODO:"

	| dict |
	
	dict := Dictionary new.
	self globalVariablesDo: [ :each | 
		each name -> each ].
	
	^ dict.! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
defineClass: aString withController: anObject 
	^ self compileANewClassFrom: aString notifying: nil startingFrom: nil! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
fixProtoObjectClassSuperclass

	(self ask classNamed: #'ProtoObject class') superclass: (self ask classNamed: #Class).
! !

!RGEnvironment methodsFor: 'private - backend interface' stamp: ''!
pvtBehaviorsDo: aBlock

	^ behaviors value do: aBlock! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
unifyClassTrait

	"set all metaclasses of classTraits to the same object (ClassTrait) "

	| aTrait |

	aTrait := self ensureClassTrait.
	 
	self ask behaviorsDo: [ :each | 
		(each isMetaclassTrait)
			ifTrue: [ each metaclass: aTrait]].
! !

!RGEnvironment methodsFor: 'utilities' stamp: ''!
verifyOwnership: anRGObject

	"ignore unresolved values. TODO: check default values ownership?"
	anRGObject isRingResolved ifFalse: [ ^ self.].

	(anRGObject environment = self)
		ifFalse: [ RGWrongEnvironment signal ].! !

!RGEnvironment methodsFor: 'accessing' stamp: ''!
backend 

	^ backend ifNil: [ backend := RGEnvironmentBackend for: self ].! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
cleanPackages

	self backend forEnvironment cleanPackagesFor: self! !

!RGEnvironment methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.

	behaviors := self unresolvedValue: self defaultBehaviors.
	packages := self unresolvedValue: self defaultPackages.
	globalVariables := self unresolvedValue: self defaultGlobalVariables.
	
	version := self defaultVersion
! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
classNames

	^ self allClasses collect: [ :each | each name ].! !

!RGEnvironment methodsFor: 'accessing' stamp: ''!
version: anObject
	version := anObject! !

!RGEnvironment methodsFor: '*Calypso-Ring' stamp: ''!
nonClassNames

	"TODO:"
	^ #()! !

!RGEnvironment methodsFor: 'private - backend interface' stamp: ''!
pvtPackagesDo: aBlock

	^ packages value do: aBlock! !

!RGEnvironment methodsFor: 'default model values' stamp: ''!
defaultVersion

	^ 6! !

!RGEnvironment methodsFor: 'accessing - backend' stamp: ''!
removeGlobalVariable: anRGGlobalVariable

	self backend forBehavior removeGlobalVariable: anRGGlobalVariable from: self! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
cleanWithMetaclassNamed: aProposedName

	self unifyMetaclass: aProposedName.
	self hasTraits ifTrue: [ 
		self unifyTrait.
		self unifyClassTrait. ].
	self cleanSuperclassesOfMetaclasses.
	self cleanUnusedUnreferencedBehaviors.
	self cleanUnusedUnreferencedPackages.! !

!RGEnvironment methodsFor: 'cleaning' stamp: ''!
ensurePackageNamed: aSymbol

	^ self ask packages 
		detect: [:each | each name = aSymbol] 
		ifNone: [ | newPackage |
				newPackage := RGPackage named: aSymbol parent: self.
				self addPackage: newPackage.
				newPackage ].
			
! !

!RGEnvironment methodsFor: 'private - backend access' stamp: ''!
pvtGlobalVariablesDo: aBlock

	globalVariables value do: aBlock! !

!RGEnvironment methodsFor: 'private - backend interface' stamp: ''!
pvtAddPackage: anRGPackage

	self environment verifyOwnership: anRGPackage.
	
	packages isRingResolved ifFalse: [ 
		self pvtCleanPackages ].
	
	packages add: anRGPackage.	
		! !

!RGEnvironmentAnnouncer commentStamp: ''!
This class plays the role of the announcer for events raised by the Pharo system.

BEWARE: You should not need to subclass me. Think about just using me to send your announces (if you need system behavior) or using your own announcers as instance or class  variables.!
!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
behaviorParentRenamed: anRGBehavior from: oldName

	self announce: (ClassParentRenamed 
		classParentOf: anRGBehavior
		renamedFrom: oldName
		to: anRGBehavior name)! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
behaviorRemoved: anRGBehavior

	self announce: (ClassRemoved 
		class: anRGBehavior category: anRGBehavior category)! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
behaviorModificationAppliedTo: anRGBehavior

	self announce: (ClassModificationApplied toClass: anRGBehavior)! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
behaviorDefinitionChangedFrom: oldRGBehavior to: newRGBehavior

	self announce: (ClassModifiedClassDefinition  
		classDefinitionChangedFrom:  oldRGBehavior
		to: newRGBehavior)! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
behaviorRecategorized: anRGBehavior 

	self announce: (ClassRecategorized 
		class: anRGBehavior 
		recategorizedFrom: nil 
		to: anRGBehavior category)! !

!RGEnvironmentAnnouncer methodsFor: 'announce' stamp: ''!
suspendAllWhileStoring: aBlock
	| reentring |
	" Suspend all the announcements, storing them in an OrderedCollection, then returns this collection"
	
	reentring := storedAnnouncements isNotNil.
	
	reentring ifFalse:[
		storedAnnouncements := OrderedCollection new.
	].

	[ 
		self suspendAllWhile: aBlock.
		^ storedAnnouncements.
	] ensure:[
		reentring ifFalse:[
			storedAnnouncements := nil.
		]
	]! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
behaviorRenamed: anRGBehavior from: oldName

	self announce: (ClassRenamed 
		class: anRGBehavior 
		category: anRGBehavior category 
		oldName: oldName 
		newName: anRGBehavior name)! !

!RGEnvironmentAnnouncer methodsFor: 'subscription' stamp: ''!
unsubscribe: anObject
	self private unsubscribe: anObject.	
	super unsubscribe: anObject.
! !

!RGEnvironmentAnnouncer methodsFor: 'announce' stamp: ''!
suspendAllWhile: aBlock
	| oldSuspended |
	oldSuspended := self isSuspended.
	suspended := true.
	^aBlock ensure: [ suspended := oldSuspended ]! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
behaviorAdded: anRGBehavior

	self announce: (ClassAdded class: anRGBehavior category: nil)! !

!RGEnvironmentAnnouncer methodsFor: 'announce' stamp: ''!
announce: anAnnouncement
	self isSuspended 
		ifFalse: [ 
			self private announce: anAnnouncement.
			super announce: anAnnouncement ]
		ifTrue:[
			storedAnnouncements ifNotNil:[ storedAnnouncements add: anAnnouncement ]
		].! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
methodAdded: aMethod 

	self announce: (MethodAdded method: aMethod)! !

!RGEnvironmentAnnouncer methodsFor: 'accessing' stamp: ''!
private
	^private ifNil: [ private := Announcer new ]! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
behaviorDefinitionModified: anRGBehavior

	self announce: (ClassModificationApplied toClass: anRGBehavior)! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
behaviorReorganized: anRGBehavior

	self announce: (ClassReorganized class: anRGBehavior)! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
behaviorCommentModified: anRGBehavior

	self announce: (ClassCommented classCommented: anRGBehavior)! !

!RGEnvironmentAnnouncer methodsFor: 'triggering' stamp: ''!
methodRemoved: aMethod 

	self announce: (MethodRemoved methodRemoved: aMethod protocol: aMethod protocol origin: aMethod parent)! !

!RGEnvironmentAnnouncer methodsFor: 'testing' stamp: ''!
isSuspended
	^suspended ifNil: [ suspended := false ]! !

!RGEnvironmentBackend methodsFor: 'accessing' stamp: ''!
definitionFor: anObject 

	^ self definitionFor: anObject ifAbsentRegister: [ anObject ensureRingDefinitionIn: self environment ]
! !

!RGEnvironmentBackend methodsFor: 'pointer layout' stamp: ''!
cleanSlotsFor: anRGLayout

	^ anRGLayout pvtCleanSlots! !

!RGEnvironmentBackend methodsFor: 'general' stamp: ''!
nameFor: anRGObject

	^ anRGObject pvtName! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
methodPackageFor: anRGMethod

	^  anRGMethod pvtPackage! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
sharedPoolsFor: anRGBehavior do: aBlock

	^ anRGBehavior behaviorStrategy pvtSharedPoolsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'behavior' stamp: ''!
traitCompositionFor: anRGBehavior

	^  anRGBehavior pvtTraitComposition! !

!RGEnvironmentBackend methodsFor: 'general' stamp: ''!
setNameFor: anRGObject to: aString

	^ anRGObject pvtName: aString! !

!RGEnvironmentBackend methodsFor: 'pointer layout' stamp: ''!
addSlot: anRGSlot to: anRGLayout

	^ anRGLayout pvtAddSlot: anRGSlot! !

!RGEnvironmentBackend methodsFor: 'trait exclusion' stamp: ''!
addExclusion: aSymbol to: anRGTraitExclusion

	^ anRGTraitExclusion pvtAddExclusion: aSymbol! !

!RGEnvironmentBackend methodsFor: 'behavior' stamp: ''!
cleanLocalMethodsFor: anRGBehavior

	^ anRGBehavior pvtCleanLocalMethods! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
packageFor: anRGBehavior

	^  anRGBehavior behaviorStrategy pvtPackage! !

!RGEnvironmentBackend methodsFor: 'slot' stamp: ''!
setExpressionFor: anRGUnknownSlot to: aString

	^  anRGUnknownSlot pvtExpression: aString! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
setCommentFor: anRGBehavior to: anRGComment

	^  anRGBehavior behaviorStrategy pvtComment: anRGComment! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
setMethodPackageFor: anRGMethod to: anRGPackage

	^  anRGMethod pvtPackage: anRGPackage! !

!RGEnvironmentBackend methodsFor: 'pointer layout' stamp: ''!
removeSlot: anRGSlot from: anRGLayout

	^ anRGLayout pvtRemoveSlot: anRGSlot! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
definedBehaviorsFor: anRGPackage do: aBlock

	^  anRGPackage pvtDefinedBehaviorsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
behaviorsFor: anRGEnvironment do: aBlock

	^  anRGEnvironment pvtBehaviorsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
addPackage: anRGPackage to: anRGEnvironment

	^ anRGEnvironment pvtAddPackage: anRGPackage! !

!RGEnvironmentBackend methodsFor: 'unresolved objects' stamp: ''!
createNewUnresolvedMetaclassFor: anRGBehavior

	| metaclassStub superclassMetaclass |
	
	metaclassStub := RGMetaclass unresolvedWithParent: self environment.

	superclassMetaclass := anRGBehavior pvtSuperclass pvtMetaclass.
	superclassMetaclass 
		ifNotNil: [ 
			metaclassStub pvtSuperclass: superclassMetaclass.
			metaclassStub pvtMetaclass: superclassMetaclass ]
		ifNil: [ 
			metaclassStub pvtSuperclass: metaclassStub.
			metaclassStub pvtMetaclass: metaclassStub ].
	self environment pvtAddBehavior: metaclassStub.

	^ metaclassStub	
! !

!RGEnvironmentBackend methodsFor: 'class comment' stamp: ''!
classCommentTimeFor: anRGComment

	^  anRGComment pvtTime! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
removeClassVariable: anRGInstanceVariableDefinition from: anRGBehavior

	^ anRGBehavior behaviorStrategy pvtRemoveClassVariable: anRGInstanceVariableDefinition! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
cleanGlobalVariablesFor: anRGEnvironment

	^ anRGEnvironment pvtCleanGlobalVariables! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
authorFor: anRGMethod

	^  anRGMethod pvtAuthor! !

!RGEnvironmentBackend methodsFor: 'resolving' stamp: ''!
hasFullyUnresolved: anRGObject		
		
	^ anRGObject pvtFullyUnresolved! !

!RGEnvironmentBackend methodsFor: 'trait exclusion' stamp: ''!
cleanExclusionsFor: anRGTraitExclusion

	^ anRGTraitExclusion pvtCleanExclusions! !

!RGEnvironmentBackend methodsFor: 'metaclass trait' stamp: ''!
metaclassTraitBaseTraitFor: anRGMetaclassTrait

	^  anRGMetaclassTrait behaviorStrategy pvtBaseTrait! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
removeGlobalVariable: anRGGlobalVariable from: anRGEnvironment

	^ anRGEnvironment pvtRemoveGlobalVariable: anRGGlobalVariable! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
removeDefinedBehavior: anRGBehavior from: anRGPackage

	^ anRGPackage pvtRemoveDefinedBehavior: anRGBehavior! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
packagesFor: anRGEnvironment do: aBlock

	^  anRGEnvironment pvtPackagesDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'behavior' stamp: ''!
setSuperclassFor: anRGBehavior to: anObject

	^  anRGBehavior pvtSuperclass: anObject! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
addExtensionMethod: anRGMethod to: anRGPackage

	^ anRGPackage pvtAddExtensionMethod: anRGMethod! !

!RGEnvironmentBackend methodsFor: 'trait alias' stamp: ''!
aliasesFor: anRGTraitAlias do: aBlock

	^ anRGTraitAlias pvtAliasesDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
tagsForClassesFor: anRGPackage do: aBlock

	^  anRGPackage pvtTagsForClassesDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
cleanBehaviorsFor: anRGEnvironment

	anRGEnvironment pvtCleanBehaviors.! !

!RGEnvironmentBackend methodsFor: 'behavior' stamp: ''!
addLocalMethod: anRGMethod to: anRGBehavior

	^ anRGBehavior pvtAddLocalMethod: anRGMethod! !

!RGEnvironmentBackend methodsFor: 'metaclass' stamp: ''!
metaclassFor: anRGBehavior

	^  anRGBehavior pvtMetaclass! !

!RGEnvironmentBackend methodsFor: 'unresolved objects' stamp: ''!
createNewUnresolvedClass

	| classStub metaclassStub packageStub |
	
	classStub := RGClass unresolvedWithParent: self environment.
	packageStub := RGPackage unresolvedWithParent: self environment.
	classStub behaviorStrategy pvtPackage: packageStub.
	packageStub pvtAddDefinedBehavior: classStub.
	metaclassStub := self createNewUnresolvedMetaclassFor: classStub.

	classStub pvtSuperclass: classStub.
	classStub pvtMetaclass: metaclassStub.
	classStub pvtPackage: packageStub.
	packageStub pvtAddDefinedBehavior: classStub.
	self environment pvtAddBehavior: classStub.
	self environment pvtAddPackage: packageStub.

	^ classStub
	

! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
addClassTag: aSymbol to: anRGPackage

	^ anRGPackage pvtAddClassTag: aSymbol! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
cleanDefinedBehaviorsFor: anRGPackage

	anRGPackage pvtCleanDefinedBehaviors.! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
hasSourceCodeFor: anRGMethod 

	^ anRGMethod pvtSourceCode notNil! !

!RGEnvironmentBackend methodsFor: 'metaclass trait' stamp: ''!
setMetaclassTraitBaseTraitFor: anRGMetaclassTrait to: anRGTrait

	^  anRGMetaclassTrait pvtBaseTrait: anRGTrait! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
addMethodTag: aSymbol to: anRGBehavior

	^ anRGBehavior pvtAddMethodTag: aSymbol! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
setSourceCodeFor: anRGMethod to: anObject

	anRGMethod pvtSourceCode: anObject! !

!RGEnvironmentBackend methodsFor: 'trait exclusion' stamp: ''!
exclusionsFor: anRGTraitExclusion do: aBlock

	^ anRGTraitExclusion pvtExclusionsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'class comment' stamp: ''!
setClassCommentTimeFor: anRGComment to: aDateAndTime

	^  anRGComment pvtTime: aDateAndTime! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
commentFor: anRGBehavior

	^  anRGBehavior behaviorStrategy pvtComment! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
cleanMethodTagsFor: anRGMethod

	anRGMethod pvtCleanTags.! !

!RGEnvironmentBackend methodsFor: 'class comment' stamp: ''!
setClassCommentContentFor: anRGComment to: anObject

	anRGComment pvtContent: anObject.
! !

!RGEnvironmentBackend methodsFor: 'accessing' stamp: ''!
definitionFor: anObject ifAbsentRegister: aDefinitionOrBlock

	^ providedDefinitions at: anObject 
		ifPresent: [:definition | definition ]
		ifAbsentPut: [ aDefinitionOrBlock value ].! !

!RGEnvironmentBackend methodsFor: 'metaclass' stamp: ''!
baseClassFor: anRGBehavior

	^  anRGBehavior behaviorStrategy pvtBaseClass! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
setPackageFor: anRGBehavior to: anRGPackage

	^  anRGBehavior behaviorStrategy pvtPackage: anRGPackage! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
sourceCodeFor: anRGMethod 

	^ anRGMethod pvtSafeSourceCode
! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
addBehavior: anRGBehavior to: anRGEnvironment

	^ anRGEnvironment pvtAddBehavior: anRGBehavior! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
cleanTagsForMethodsFor: anRGBehavior

	anRGBehavior pvtCleanTagsForMethods.! !

!RGEnvironmentBackend methodsFor: 'subbackends' stamp: ''!
forMethod

	^ self ! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
removePackage: anRGPackage from: anRGEnvironment

	^ anRGEnvironment pvtRemovePackage: anRGPackage! !

!RGEnvironmentBackend methodsFor: 'trait' stamp: ''!
setTraitPackageFor: anRGBehavior to: anRGPackage

	^  anRGBehavior pvtPackage: anRGPackage! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
removeMethodTag: aSymbol from: anRGBehavior

	^ anRGBehavior pvtRemoveMethodTag: aSymbol! !

!RGEnvironmentBackend methodsFor: 'behavior' stamp: ''!
setTraitCompositionFor: anRGBehavior to: anRGTraitComposition

	^  anRGBehavior pvtTraitComposition: anRGTraitComposition! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
cleanClassTagsFor: anRGBehavior

	anRGBehavior pvtCleanTags.! !

!RGEnvironmentBackend methodsFor: 'trait' stamp: ''!
setClassTraitFor: anRGTrait to: anRGMetatraitDefinition

	^  anRGTrait behaviorStrategy pvtClassTrait: anRGMetatraitDefinition! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
cleanSharedPoolsFor: anRGBehavior

	^ anRGBehavior behaviorStrategy pvtCleanSharedPools! !

!RGEnvironmentBackend methodsFor: 'behavior' stamp: ''!
superclassFor: anRGBehavior

	^  anRGBehavior pvtSuperclass! !

!RGEnvironmentBackend methodsFor: 'trait' stamp: ''!
traitPackageFor: anRGBehavior

	^  anRGBehavior behaviorStrategy pvtPackage! !

!RGEnvironmentBackend methodsFor: 'trait composition' stamp: ''!
cleanTransformationsFor: anRGTraitComposition

	^ anRGTraitComposition pvtCleanTransformations! !

!RGEnvironmentBackend methodsFor: 'trait' stamp: ''!
traitCommentFor: anRGBehavior

	^  anRGBehavior behaviorStrategy pvtComment! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
extensionMethodsFor: anRGPackage do: aBlock

	^ anRGPackage pvtExtensionMethodsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'class comment' stamp: ''!
classCommentAuthorFor: anRGComment

	^  anRGComment pvtAuthor! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
tagsForMethodsFor: anRGBehavior do: aBlock

	^  anRGBehavior pvtTagsForMethodsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'accessing' stamp: ''!
environment
		
	^ environment! !

!RGEnvironmentBackend methodsFor: 'trait transormation' stamp: ''!
setSubjectFor: anRGTraitComposition to: anRGTrait

	^  anRGTraitComposition pvtSubject: anRGTrait! !

!RGEnvironmentBackend methodsFor: 'trait composition' stamp: ''!
addTransformation: anRGTraitTransformation to: anRGTraitComposition

	^ anRGTraitComposition pvtAddTransformation: anRGTraitTransformation! !

!RGEnvironmentBackend methodsFor: 'unresolved objects' stamp: ''!
createUnresolvedTraitGroupFor: anRGBehavior 

	| traitStub classTraitStub traitMetaclassStub classTraitMetaclassStub packageStub1  |

	traitStub := anRGBehavior isMeta
		ifFalse: [ anRGBehavior ]
		ifTrue: [ RGTrait unresolvedWithParent: self environment ].
	traitStub propertyNamed: #creator put: anRGBehavior.
	traitStub propertyNamed: #role put: #trait.
		
	classTraitStub := anRGBehavior isMeta
		ifFalse: [ RGMetaclassTrait unresolvedWithParent: self environment ]
		ifTrue: [ anRGBehavior ].
	classTraitStub propertyNamed: #creator put: anRGBehavior.
	classTraitStub propertyNamed: #role put: #classTrait.

	"Trait"
	traitMetaclassStub := RGClass unresolvedWithParent: self environment.
	self createUnresolvedClassGroupFor: traitMetaclassStub.
	traitMetaclassStub propertyNamed: #creator put: anRGBehavior.
	traitMetaclassStub propertyNamed: #role put: #traitMetaclass.
	
	"ClassTrait"
	classTraitMetaclassStub := RGClass unresolvedWithParent: self environment.
	self createUnresolvedClassGroupFor: classTraitMetaclassStub.
	classTraitMetaclassStub propertyNamed: #creator put: anRGBehavior.
	classTraitMetaclassStub propertyNamed: #role put: #classTraitMetaclass.

	packageStub1 := RGPackage unresolvedWithParent: self environment.
	packageStub1 propertyNamed: #creator put: anRGBehavior.
	packageStub1 propertyNamed: #role put: #traitMetaclassPackage.

	traitStub behaviorStrategy pvtPackage: packageStub1.
	packageStub1 pvtAddDefinedBehavior: traitStub.
	traitStub pvtSuperclass: traitStub.
	traitStub pvtMetaclass: traitMetaclassStub.
	traitStub behaviorStrategy pvtClassTrait: classTraitStub.

	classTraitStub pvtSuperclass: classTraitStub.
	classTraitStub pvtMetaclass: classTraitMetaclassStub.
	classTraitStub behaviorStrategy pvtBaseTrait: traitStub.
	
	self environment pvtAddBehavior: traitStub.		
	self environment pvtAddBehavior: classTraitStub.	
	self environment pvtAddBehavior: traitMetaclassStub.
	self environment pvtAddBehavior: classTraitMetaclassStub.
	self environment pvtAddPackage: packageStub1.

	^ 	anRGBehavior isMeta
		ifFalse: [ traitStub ]
		ifTrue: [ classTraitStub ].
! !

!RGEnvironmentBackend methodsFor: 'metaclass' stamp: ''!
setMetaclassFor: anRGBehavior to: anRGMetaclass

	^  anRGBehavior pvtMetaclass: anRGMetaclass! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
untagClass: anRGBehavior from: aSymbol

	^ anRGBehavior pvtUntagFrom: aSymbol! !

!RGEnvironmentBackend methodsFor: 'trait alias' stamp: ''!
addAlias: aSymbol to: anRGTraitAlias

	^ anRGTraitAlias pvtAddAlias: aSymbol! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
cleanExtensionMethodsFor: anRGPackage

	anRGPackage pvtCleanExtensionMethods! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
removeSharedPool: anRGPoolVariable from: anRGBehavior

	^ anRGBehavior behaviorStrategy pvtRemoveSharedPool: anRGPoolVariable! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
timeFor: anRGMethod

	^  anRGMethod pvtTime! !

!RGEnvironmentBackend methodsFor: 'pointer layout' stamp: ''!
slotsFor: anRGLayout do: aBlock

	^ anRGLayout pvtSlotsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'resolving' stamp: ''!
resolvedPropertiesFor: anRGObject

	^ anRGObject pvtResolvedProperties! !

!RGEnvironmentBackend methodsFor: 'behavior' stamp: ''!
setLayoutFor: anRGBehavior to: anRGLayout

	^  anRGBehavior behaviorStrategy pvtLayout: anRGLayout! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
setTimeFor: anRGMethod to: aDateAndTime

	^  anRGMethod pvtTime: aDateAndTime! !

!RGEnvironmentBackend methodsFor: 'class comment' stamp: ''!
setClassCommentAuthorFor: anRGComment to: aString

	^  anRGComment pvtAuthor: aString! !

!RGEnvironmentBackend methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	providedDefinitions := IdentityDictionary new.! !

!RGEnvironmentBackend methodsFor: 'trait' stamp: ''!
classTraitFor: anRGTrait

	^  anRGTrait behaviorStrategy pvtClassTrait! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
classVariablesFor: anRGBehavior do: aBlock

	^ anRGBehavior behaviorStrategy pvtClassVariablesDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'behavior' stamp: ''!
localMethodsFor: anRGBehavior do: aBlock

	^ anRGBehavior pvtLocalMethodsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'subbackends' stamp: ''!
forBehavior

	^ self ! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
tagsForClass: anRGBehavior do: aBlock

	^  anRGBehavior pvtTagsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'behavior' stamp: ''!
removeLocalMethod: anRGMethod from: anRGBehavior

	^ anRGBehavior pvtRemoveLocalMethod: anRGMethod! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
astFor: anRGMethod

	^  anRGMethod astFromSource! !

!RGEnvironmentBackend methodsFor: 'slot' stamp: ''!
expressionFor: anRGUnknownSlot

	^  anRGUnknownSlot pvtExpression! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
removeBehavior: anRGBehavior from: anRGEnvironment

	anRGEnvironment pvtRemoveBehavior: anRGBehavior.
	
! !

!RGEnvironmentBackend methodsFor: 'trait transormation' stamp: ''!
subjectFor: anRGTraitComposition

	^  anRGTraitComposition pvtSubject! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
addSharedPool: anRGPoolVariable to: anRGBehavior

	^ anRGBehavior behaviorStrategy pvtAddSharedPool: anRGPoolVariable! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
setAuthorFor: anRGMethod to: aDateAndTime

	^  anRGMethod pvtAuthor: aDateAndTime! !

!RGEnvironmentBackend methodsFor: 'unresolved objects' stamp: ''!
createUnresolvedClassGroupFor: anRGBehavior 

	| classStub metaclassStub superclassStub superclassMetaclassStub packageStub1 packageStub2 |

	classStub := anRGBehavior isMeta
		ifFalse: [ anRGBehavior ]
		ifTrue: [ RGClass unresolvedWithParent: self environment ].
	classStub propertyNamed: #creator put: anRGBehavior.
	classStub propertyNamed: #role put: #class.
		
	metaclassStub := anRGBehavior isMeta
		ifFalse: [ RGMetaclass unresolvedWithParent: self environment ]
		ifTrue: [ anRGBehavior ].
	metaclassStub propertyNamed: #creator put: anRGBehavior.
	metaclassStub propertyNamed: #role put: #metaclass.

	superclassStub := RGClass unresolvedWithParent: self environment.
	superclassStub propertyNamed: #creator put: anRGBehavior.
	superclassStub propertyNamed: #role put: #superclass.

	superclassMetaclassStub := RGMetaclass unresolvedWithParent: self environment.
	superclassMetaclassStub propertyNamed: #creator put: anRGBehavior.
	superclassMetaclassStub propertyNamed: #role put: #superclassMetaclass.
	
	packageStub1 := RGPackage unresolvedWithParent: self environment.
	classStub behaviorStrategy pvtPackage: packageStub1.
	self environment pvtAddPackage: packageStub1.
	packageStub1 pvtAddDefinedBehavior: classStub.
	packageStub1 propertyNamed: #creator put: anRGBehavior.
	packageStub1 propertyNamed: #role put: #package.
	
	packageStub2 := RGPackage unresolvedWithParent: self environment.
	superclassStub behaviorStrategy pvtPackage: packageStub2.
	self environment pvtAddPackage: packageStub2.
	packageStub2 pvtAddDefinedBehavior: superclassStub.
	packageStub2 propertyNamed: #creator put: anRGBehavior.
	packageStub2 propertyNamed: #role put: #superclassPackage.

	classStub pvtSuperclass: superclassStub.
	classStub pvtMetaclass: metaclassStub.
	
	superclassStub pvtSuperclass: superclassStub.
	superclassStub pvtMetaclass: superclassMetaclassStub.
	
	metaclassStub pvtSuperclass: superclassMetaclassStub.
	metaclassStub pvtMetaclass: superclassMetaclassStub.
	metaclassStub behaviorStrategy pvtBaseClass: classStub.
	
	superclassMetaclassStub pvtSuperclass: superclassMetaclassStub.
	superclassMetaclassStub pvtMetaclass: superclassMetaclassStub.
	superclassMetaclassStub behaviorStrategy pvtBaseClass: superclassStub.
	
	self environment pvtAddBehavior: classStub.
	self environment pvtAddBehavior: metaclassStub. 	
	self environment pvtAddBehavior: superclassStub.
	self environment pvtAddBehavior: superclassMetaclassStub.
	

	^ 	anRGBehavior isMeta
		ifFalse: [ metaclassStub ]
		ifTrue: [ classStub ].
! !

!RGEnvironmentBackend methodsFor: 'trait composition' stamp: ''!
removeTransformation: anRGTraitTransformation from: anRGTraitComposition

	^ anRGTraitComposition pvtRemoveTransformation: anRGTraitTransformation! !

!RGEnvironmentBackend methodsFor: 'accessing' stamp: ''!
environment: anRGEnironment
		
	environment := anRGEnironment! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
addClassVariable: anRGInstanceVariableDefinition to: anRGBehavior

	^ anRGBehavior behaviorStrategy pvtAddClassVariable: anRGInstanceVariableDefinition! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
globalVariablesFor: anRGEnvironment do: aBlock

	^ anRGEnvironment pvtGlobalVariablesDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'trait alias' stamp: ''!
cleanAliasesFor: anRGTraitAlias

	^ anRGTraitAlias pvtCleanAliases! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
cleanClassVariablesFor: anRGBehavior

	^ anRGBehavior behaviorStrategy pvtCleanClassVariables! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
cleanPackagesFor: anRGEnvironment

	anRGEnvironment pvtCleanPackages! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
removeClassTag: aSymbol from: anRGPackage

	^ anRGPackage pvtRemoveClassTag: aSymbol! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
cleanTagsForClassesFor: anRGPackage

	anRGPackage pvtCleanTagsForClasses.! !

!RGEnvironmentBackend methodsFor: 'trait alias' stamp: ''!
removeAlias: aSymbol from: anRGTraitAlias

	^ anRGTraitAlias pvtRemoveAlias: aSymbol! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
addDefinedBehavior: anRGBehavior to: anRGPackage

	^ anRGPackage pvtAddDefinedBehavior: anRGBehavior! !

!RGEnvironmentBackend methodsFor: 'subbackends' stamp: ''!
forEnvironment

	^ self ! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
tagMethod: anRGMethod with: aSymbol

	^ anRGMethod pvtTagWith: aSymbol! !

!RGEnvironmentBackend methodsFor: 'resolving' stamp: ''!
unresolvedPropertiesFor: anRGObject

	^ anRGObject pvtUnresolvedProperties! !

!RGEnvironmentBackend methodsFor: 'resolving' stamp: ''!
hasFullyResolved: anRGObject

	^ anRGObject pvtFullyResolved
! !

!RGEnvironmentBackend methodsFor: 'behavior' stamp: ''!
layoutFor: anRGBehavior

	^  anRGBehavior behaviorStrategy pvtLayout! !

!RGEnvironmentBackend methodsFor: 'metaclass' stamp: ''!
setBaseClassFor: anRGBehavior to: anRGClass

	^  anRGBehavior behaviorStrategy pvtBaseClass: anRGClass! !

!RGEnvironmentBackend methodsFor: 'trait' stamp: ''!
setTraitCommentFor: anRGBehavior to: anRGComment

	^  anRGBehavior behaviorStrategy pvtComment: anRGComment! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
untagMethod: anRGMethod from: aSymbol

	^ anRGMethod pvtUntagFrom: aSymbol
	
! !

!RGEnvironmentBackend methodsFor: 'method' stamp: ''!
tagsForMethod: anRGMethod do: aBlock

	^  anRGMethod pvtTagsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'trait composition' stamp: ''!
transformationsFor: anRGTraitComposition do: aBlock

	^ anRGTraitComposition pvtTransformationsDo: aBlock! !

!RGEnvironmentBackend methodsFor: 'subbackends' stamp: ''!
forPackage

	^ self ! !

!RGEnvironmentBackend methodsFor: 'environment' stamp: ''!
addGlobalVariable: anRGGlobalVariable to: anRGEnvironment

	^ anRGEnvironment pvtAddGlobalVariable: anRGGlobalVariable! !

!RGEnvironmentBackend methodsFor: 'package' stamp: ''!
removeExtensionMethod: anRGMethod from: anRGPackage

	^ anRGPackage pvtRemoveExtensionMethod: anRGMethod! !

!RGEnvironmentBackend methodsFor: 'trait exclusion' stamp: ''!
removeExclusion: aSymbol from: anRGTraitExclusion

	^ anRGTraitExclusion pvtRemoveExclusion: aSymbol! !

!RGEnvironmentBackend methodsFor: 'class' stamp: ''!
tagClass: anRGBehavior with: aSymbol

	^ anRGBehavior pvtTagWith: aSymbol! !

!RGEnvironmentBackend methodsFor: 'class comment' stamp: ''!
classCommentContentFor: anRGComment

	^ anRGComment pvtContent
! !

!RGEnvironmentBackend class methodsFor: 'instance creation' stamp: ''!
for: anRGEnvironment

	^ self new 
		environment: anRGEnvironment;
		yourself! !

!RGEnvironmentBackendTest methodsFor: 'tests' stamp: ''!
testReadOnlyErrors

	| selectors backend |
	
	selectors := #(#addAlias:to: #addBehavior:to: #addClassTag:to: #addClassVariable:to: #addDefinedBehavior:to: #addExclusion:to: #addExtensionMethod:to: #addGlobalVariable:to: #addInstanceVariable:to: #addLocalMethod:to: #addMethodTag:to: #addPackage:to: #addSharedPool:to: #addSlot:to: #addTransformation:to: #cleanAliasesFor: #cleanBehaviorsFor: #cleanClassTagsFor: #cleanClassVariablesFor: #cleanDefinedBehaviorsFor: #cleanExclusionsFor: #cleanExtensionMethodsFor: #cleanGlobalVariablesFor: #cleanInstanceVariablesFor: #cleanLocalMethodsFor: #cleanMethodTagsFor: #cleanPackagesFor: #cleanSharedPoolsFor: #cleanSlotsFor: #cleanTagsForClassesFor: #cleanTagsForMethodsFor: #cleanTransformationsFor: #createNewUnresolvedClass #createNewUnresolvedMetaclassFor: #createNewUnresolvedMetaclassMetaclassFor: #readOnlyError #removeAlias:from: #removeBehavior:from: #removeClassTag:from: #removeClassVariable:from: #removeDefinedBehavior:from: #removeExclusion:from: #removeExtensionMethod:from: #removeGlobalVariable:from: #removeInstanceVariable:from: #removeLocalMethod:from: #removeMethodTag:from: #removePackage:from: #removeSharedPool:from: #removeSlot:from: #removeTransformation:from: #setBaseClassFor:to: #setClassCommentAuthorFor:to: #setClassCommentContentFor:to: #setClassCommentTimeFor:to: #setClassTraitFor:to: #setCommentFor:to: #setExpressionFor:to: #setLayoutFor:to: #setMetaClassFor:to: #setMethodPackageFor:to: #setNameFor:to: #setPackageFor:to: #setProtocolFor:to: #setSourceCodeFor:to: #setSubjectFor:to: #setSuperclassFor:to: #setTraitCommentFor:to: #setTraitPackageFor:to: #tagClass:with: #tagMethod:with: #untagClass:from: #untagMethod:from: cleanProtocolsFor: removeProtocol:from: addProtocol:to:).
	
	backend := self backendClass new.
	
	selectors do: [:selector |
		self should: [backend perform: selector withEnoughArguments: #() ] raise: Error]
! !

!RGEnvironmentBackendTest methodsFor: 'tests' stamp: ''!
testCreationOfDefinitions
	| env1 method |
	env1 := RGEnvironment new.

	"self should: [ (Object>>#isRingObject) asRingDefinitionIn: env1 ] raise: RGNotFoundError."
	method := Object >> #isRGObject ensureRingDefinitionIn: env1.
	self assert: method class equals: RGMethod.
	self assert: method selector equals: #isRGObject.
	self assert: method parent name equals: #Object.
	self assert: method environment identicalTo: env1! !

!RGEnvironmentBackendTest methodsFor: 'tests' stamp: ''!
testImplicitEnvironmentContentForClassDefinition
	
	| def def2 env |

	def := RGClass named: #SomeClass.
	env := def environment.

	"we have SomeClass, SomeClass class, SomeClass superclass, SomeClass superclass class"
	self assert: env ask behaviors size equals: 4.

	"we have one package for SomeClass and SomeClass class, other for SomeClass superclass 
	and SomeClass superclass class"	
	self assert: env ask packages size equals: 2.
	self assert: (env ask behaviors select: #isMeta) size equals: 2.

	self checkHierarchyConsistencyOf: def.
	
	self assert: (def isRingResolved).
	self deny: (def superclass isRingResolved).
	self deny: (def metaclass isRingResolved).
	self deny: (def superclass metaclass isRingResolved).
	
	def2 := RGClass named: #SomeOtherClass parent: env.
	self assert: env ask behaviors size equals: 8. 
	self assert: env ask packages size equals: 4.
	
	self checkHierarchyConsistencyOf: def2.

	self assert: (def2 isRingResolved).
	self deny: (def2 superclass isRingResolved).
	self deny: (def2 metaclass isRingResolved).
	self deny: (def2 superclass metaclass isRingResolved).
	
! !

!RGEnvironmentBackendTest methodsFor: 'tests' stamp: ''!
testDefinitionsIdentity
	| env1 |
	env1 := RGEnvironment new.

	self assert: (Object >> #isRGObject ensureRingDefinitionIn: env1) identicalTo: (Object >> #isRGObject ensureRingDefinitionIn: env1).

	self assert: (Object >> #isRGObject ensureRingDefinitionIn: env1) parent identicalTo: (Object >> #isRGObject ensureRingDefinitionIn: env1) parent! !

!RGEnvironmentBackendTest methodsFor: 'tests' stamp: ''!
testDefaultEnvironmentContent
	
	| env |
	
	env := RGEnvironment unnamed.
	
	self testDefaultContentFor: env.
	
"	self assert: env ask behaviors size equals: 12.
	self assert: env ask packages size equals: 1.
"! !

!RGEnvironmentBackendTest methodsFor: 'tests' stamp: ''!
testImplicitEnvironmentContentForMethodDefinition
	
	| def env |

	def := RGMethod named: #someMethod.
	env := def environment.

	"we have SomeClass, SomeClass class, SomeClass superclass, SomeClass superclass class"
	self assert: env ask behaviors size equals: 4.

	"we have one package for SomeClass and SomeClass class, other for SomeClass superclass 
	and SomeClass superclass class"	
	self assert: env ask packages size equals: 2.
	self assert: (env ask behaviors select: #isMeta) size equals: 2.

	self checkHierarchyConsistencyOf: def parent.
	
	self deny: (def parent isRingResolved).
	self deny: (def parent superclass isRingResolved).
	self deny: (def parent metaclass isRingResolved).
	self deny: (def parent superclass metaclass isRingResolved).
	
! !

!RGEnvironmentBackendTest methodsFor: 'tests' stamp: ''!
testImplicitEnvironmentContentForMetaclassDefinition
	
	| def env baseClass|

	def := RGMetaclass named: #'SomeClass class'.
	env := def environment.

	"we have SomeClass, SomeClass class, SomeClass superclass, SomeClass superclass class"
	self assert: env ask behaviors size equals: 4.

	"we have one package for SomeClass and SomeClass class, other for SomeClass superclass 
	and SomeClass superclass class"	
	self assert: env ask packages size equals: 2.
	self assert: (env ask behaviors select: #isMeta) size equals: 2.

	baseClass := def baseClass.
	self checkHierarchyConsistencyOf: baseClass.
	
	self deny: (baseClass isRingResolved).
	self deny: (baseClass superclass isRingResolved).
	self assert: (baseClass metaclass isRingResolved).
	self deny: (baseClass superclass metaclass isRingResolved).
	
! !

!RGEnvironmentBackendTest methodsFor: 'tests' stamp: ''!
testAST

	| method anAst |
	
	method := RGMethod new.
	method sourceCode: 'someMethod ^ true'.
	anAst := method ast.
	self assert: (anAst isMethod).
	self assert: (anAst lastIsReturn)

! !

!RGEnvironmentBackendTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RGEnvironmentBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RGEnvironmentBackendTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RGEnvironmentBackendTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RGEnvironmentBackendTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RGEnvironmentBackendTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RGEnvironmentBackendTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RGEnvironmentBackendTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RGEnvironmentBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGEnvironmentBackendTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RGEnvironmentBackendTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RGEnvironmentBackendTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RGEnvironmentBackendTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RGEnvironmentBackendTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RGEnvironmentBackendTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RGEnvironmentBackendTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RGEnvironmentBackendTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RGEnvironmentBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGEnvironmentBackendTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RGEnvironmentBackendTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RGEnvironmentBackendTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RGEnvironmentBackendTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RGEnvironmentBackendTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RGEnvironmentBackendTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RGEnvironmentBackendTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RGEnvironmentBackendTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RGEnvironmentBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RGEnvironmentBackendTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RGEnvironmentBackendTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RGEnvironmentQueryInterface methodsFor: 'caching' stamp: ''!
behaviorsDictionary

	^ behaviorsDictionary ifNil: [ 
		behaviorsDictionary := IdentityDictionary new.
		self behaviorsDo: [:each |
			behaviorsDictionary at: each name put: each ]. 
		behaviorsDictionary
		]! !

!RGEnvironmentQueryInterface methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!RGEnvironmentQueryInterface methodsFor: 'caching' stamp: ''!
invalidateName: aSymbol

	behaviorsDictionary removeKey: aSymbol! !

!RGEnvironmentQueryInterface methodsFor: 'classes' stamp: ''!
behaviors
	"Retrieves the traits defined in the receiver"

	| allBehaviors |
	allBehaviors := IdentitySet new.
	self behaviorsDo: [ :each | allBehaviors add: each].
	^ allBehaviors asArray
! !

!RGEnvironmentQueryInterface methodsFor: 'caching' stamp: ''!
replaceName: aSymbol with: aNewSymbol

	| anRGBehavior |
	anRGBehavior := behaviorsDictionary at: aSymbol ifAbsent: [ nil ].
	anRGBehavior ifNotNil: [ 
		behaviorsDictionary removeKey: aSymbol.
		behaviorsDictionary at: aNewSymbol put: anRGBehavior.
		 ]
	! !

!RGEnvironmentQueryInterface methodsFor: 'accessing' stamp: ''!
allClasses

	^ self behaviors select: [ :each | each isClass ] ! !

!RGEnvironmentQueryInterface methodsFor: 'globals' stamp: ''!
globalVariables
	"Retrieves the traits defined in the receiver"

	| allGlobalVariables |
	allGlobalVariables := IdentitySet new.
	self globalVariablesDo: [ :each | allGlobalVariables add: each].
	^ allGlobalVariables asArray
! !

!RGEnvironmentQueryInterface methodsFor: 'packages' stamp: ''!
packageNamed: aString
	
	self packagesDo: [:each |
		(each name = aString) ifTrue: [ ^ each ] ].
	
	^ nil! !

!RGEnvironmentQueryInterface methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!RGEnvironmentQueryInterface methodsFor: 'classes' stamp: ''!
behaviorNamedExactlyAs: aSymbol 

	^ self behaviorNamedExactlyAs: aSymbol ifAbsent: [nil]! !

!RGEnvironmentQueryInterface methodsFor: 'classes' stamp: ''!
classNamed: aSymbol

	^ self behaviorNamed: aSymbol! !

!RGEnvironmentQueryInterface methodsFor: 'classes' stamp: ''!
classOrTraitNamed: aSymbol
	
	^ self behaviorNamed: aSymbol! !

!RGEnvironmentQueryInterface methodsFor: 'classes' stamp: ''!
allClassesAndTraits

	^ self behaviors select: [ :each | each isClass or: [ each isTrait and: [ each isMetaclassTrait not ] ] ]! !

!RGEnvironmentQueryInterface methodsFor: 'accessing' stamp: ''!
behaviorNamed: aSymbol

	^ self behaviorNamed: aSymbol ifAbsent: [ nil]
! !

!RGEnvironmentQueryInterface methodsFor: 'testing' stamp: ''!
includesClassNamed: aSymbol 

	self globalVariablesDo: [ :var |
		var name = aSymbol ifTrue: [ ^ true ] ].

	^ self behaviorsDictionary 
		at: aSymbol asSymbol 
		ifPresent: [ :element | true ]
		ifAbsent: [ false ]
	"	
	self behaviorsDo: [:each |
		(each name = aSymbol) ifTrue: [ ^ each ] ].
	
	^ nil
	"! !

!RGEnvironmentQueryInterface methodsFor: 'globals' stamp: ''!
globalVariablesDo: aBlock

	self environment globalVariablesDo: aBlock! !

!RGEnvironmentQueryInterface methodsFor: 'packages' stamp: ''!
packages
	"Retrieves the traits defined in the receiver"

	| allPackages |
	allPackages := IdentitySet new.
	self packagesDo: [ :each | allPackages add: each].
	^ allPackages asArray
! !

!RGEnvironmentQueryInterface methodsFor: 'packages' stamp: ''!
packagesDo: aBlock

	self environment packagesDo: aBlock! !

!RGEnvironmentQueryInterface methodsFor: 'classes' stamp: ''!
traitNamed: traitName
	"Retrieves an RGTrait object. The traitName could be theMetaClass name"
	| trait |
	
	^(trait:= self classOrTraitNamed: traitName) isTrait
		ifTrue:[ trait ]
		ifFalse:[ nil ]! !

!RGEnvironmentQueryInterface methodsFor: 'classes' stamp: ''!
behaviorNamedExactlyAs: aSymbol ifAbsent: aBlock

	^ self behaviorsDictionary at: aSymbol asSymbol ifAbsent: aBlock
	"	
	self behaviorsDo: [:each |
		(each name = aSymbol) ifTrue: [ ^ each ] ].
	
	^ nil
	"! !

!RGEnvironmentQueryInterface methodsFor: 'classes' stamp: ''!
behaviorNamed: aSymbol ifAbsent: aBlock

	| found siblingName | 
	
	found := self behaviorNamedExactlyAs: aSymbol ifAbsent: [nil].
	found ifNotNil: [ ^ found ].
	
	(aSymbol endsWith: ' class') 
		ifTrue: [ 
			siblingName := (aSymbol withoutSuffix: ' class').
			found := self behaviorNamedExactlyAs: siblingName ifAbsent: [nil].
			found ifNotNil: [ 
				found isClass ifTrue: [ ^ found metaclass ]]].

	(aSymbol endsWith: ' classTrait') 
		ifTrue: [ 
			siblingName := (aSymbol withoutSuffix: ' classTrait').
			found := self behaviorNamedExactlyAs: siblingName ifAbsent: [nil].
			found ifNotNil: [ 
				found isTrait ifTrue: [ ^ found classTrait ]]].
		
	siblingName := (aSymbol, ' class').
	found := self behaviorNamedExactlyAs: siblingName ifAbsent: [nil].
	found ifNotNil: [ ^ found baseClass ].		

	siblingName := (aSymbol, ' classTrait').
	found := self behaviorNamedExactlyAs: siblingName ifAbsent: [nil].
	found ifNotNil: [ ^ found baseTrait ].		
					
	^ aBlock value.! !

!RGEnvironmentQueryInterface methodsFor: 'caching' stamp: ''!
resetBehaviorsDictionary

	behaviorsDictionary := IdentityDictionary new! !

!RGEnvironmentQueryInterface methodsFor: 'classes' stamp: ''!
behaviorsDo: aBlock

	self environment behaviorsDo: aBlock! !

!RGEnvironmentQueryInterface class methodsFor: 'instance creation' stamp: ''!
for: anRGEnvironment

	^ self new 
		environment: anRGEnvironment;
		yourself.! !

!RGEnvironmentQueryInterfaceTest methodsFor: 'tests' stamp: ''!
testCachingBehaviors

	| env behavior |
	
	env := RGEnvironment new.
	self assert: (env ask behaviorsDictionary isEmpty).
	behavior := env ensureClassNamed: #SomeBehavior.
	self assert: (env ask behaviorsDictionary at: #SomeBehavior) equals: behavior.
	self assert: (env ask includesClassNamed: #SomeBehavior).
	
	self assert: (env ask allClasses notEmpty).
	self assert: (env ask allClassesAndTraits notEmpty).
	
	env ask invalidateName: #SomeBehavior.
	self assert: (env ask behaviorsDictionary isEmpty).

	env := RGEnvironment new.
	self assert: (env ask behaviorsDictionary isEmpty).
	behavior := env ensureClassNamed: #SomeBehavior.
	self assert: (env ask behaviorsDictionary at: #SomeBehavior) equals: behavior.
	env ask resetBehaviorsDictionary.
	self assert: (env ask behaviorsDictionary isEmpty).

	env := RGEnvironment new.
	self assert: (env ask behaviorsDictionary isEmpty).
	behavior := env ensureClassNamed: #SomeBehavior.
	self assert: (env ask behaviorsDictionary at: #SomeBehavior) equals: behavior.
	"change class to trait"
	behavior := env ensureTraitNamed: #SomeBehavior.
	self assert: (env ask behaviorsDictionary at: #SomeBehavior) equals: behavior.

	! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testCleanUnusedUnreferencedBehaviors

	| env class1 class2 | 
	
	env := RGEnvironment new.
	class1 := env ensureClassNamed: 'SomeClass1'.
	class2 := env ensureClassNamed: 'SomeClass2'.
	self assert: env ask behaviors size equals: 8. "only pre-check"
	
	"class1 superclass makeResolved.
	class1 metaclass makeResolved.	
	class1 superclass metaclass makeResolved."
	
	class2 superclass: class1 superclass.
	class2 metaclass superclass: class1 metaclass superclass.
	class2 metaclass metaclass: class1 metaclass metaclass.
	self assert: env ask behaviors size equals: 8. "nothing changed"
	
	env cleanUnusedUnreferencedBehaviors.
	self assert: env ask behaviors size equals: 6. 
	
	
	
	
! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testTraitNamed

	| env trait | 
	
	env := RGEnvironment new.
	trait := env ensureTraitNamed: 'SomeTrait'.
	self assert: (env ask traitNamed: 'SomeTrait') equals: trait.
	
	env := RGEnvironment new.
	trait := env ensureTraitNamed: 'SomeTrait classTrait'.
	self assert: (env ask traitNamed: 'SomeTrait classTrait') equals: trait.
	
	env := RGEnvironment new.
	trait := env ensureClassNamed: 'SomeTrait'.
	self assert: (env ask traitNamed: 'SomeTrait') equals: nil.! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testBehaviortNamedIndirect

	| env behavior | 
	
	env := RGEnvironment new.
	behavior := env ensureClassNamed: 'SomeClass'.
	self assert: (env ask behaviorNamed: 'SomeClass') equals: behavior.
	self assert: (env ask behaviorNamed: 'SomeClass class') equals: behavior metaclass.
	self assert: (env ask behaviorNamed: 'SomeClass classTrait') equals: nil.

	env := RGEnvironment new.
	behavior := env ensureClassNamed: 'SomeClass class'.
	self assert: (env ask behaviorNamed: 'SomeClass class') equals: behavior.
	self assert: (env ask behaviorNamed: 'SomeClass') equals: behavior baseClass.
	self assert: (env ask behaviorNamed: 'SomeClass classTrait') equals: nil.

	env := RGEnvironment new.
	behavior := env ensureTraitNamed: 'SomeTrait'.
	self assert: (env ask behaviorNamed: 'SomeTrait') equals: behavior.
	self assert: (env ask behaviorNamed: 'SomeTrait classTrait') equals: behavior classTrait.
	self assert: (env ask behaviorNamed: 'SomeTrait class') equals: nil.

	env := RGEnvironment new.
	behavior := env ensureTraitNamed: 'SomeTrait classTrait'.
	self assert: (env ask behaviorNamed: 'SomeTrait classTrait') equals: behavior.
	self assert: (env ask behaviorNamed: 'SomeTrait') equals: behavior baseTrait.
	self assert: (env ask behaviorNamed: 'SomeTrait class') equals: nil.
! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testCompatibility

	"TODO: needs rewriting"
	
"	env1 := RGEnvironment named: 'env1'.
	env2 := RGEnvironment named: 'env2'.	
	self deny: (env1 compatibleWith: env2).

	env1 := RGEnvironment named: 'env'.
	env2 := RGEnvironment named: 'env'.	
	self assert: (env1 compatibleWith: env2).

	env1 := RGEnvironment unnamed.
	env2 := RGEnvironment unnamed.
	self assert: (env1 compatibleWith: env2).
	
	env1 := RGEnvironment named: 'env1'.
	env2 := RGEnvironment unnamed.
	self deny: (env1 compatibleWith: env2).

	env1 := RGEnvironment unnamed.
	env2 := RGEnvironment named: 'env2'.
	self deny: (env1 compatibleWith: env2).		
			
	env1 := RGEnvironment unnamed.
	env1 cleanBehaviors.
	env2 := RGEnvironment unnamed.
	env2 cleanBehaviors.
	self assert: (env1 compatibleWith: env2).

"
! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testUnifyMetaclass
	| env class1 class2 metaclass |
	env := RGEnvironment new.
	class1 := env ensureClassNamed: 'SomeClass1'.
	class2 := env ensureClassNamed: 'SomeClass2'.

	self deny: class1 metaclass metaclass equals: class2 metaclass metaclass.
	env unifyMetaclass.
	self assert: class1 metaclass metaclass equals: class2 metaclass metaclass.

	env := RGEnvironment new.
	class1 := env ensureClassNamed: 'SomeClass1'.
	class2 := env ensureClassNamed: 'SomeClass2'.
	metaclass := env ensureTraitNamed: 'Metaclass'.

	self deny: class1 metaclass metaclass equals: class2 metaclass metaclass.
	self deny: class1 metaclass metaclass equals: metaclass.
	env unifyMetaclass.
	self assert: class1 metaclass metaclass equals: class2 metaclass metaclass.
	self assert: class1 metaclass metaclass equals: metaclass! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testUnifyTrait
	| env trait1 trait2 trait |
	env := RGEnvironment new.
	trait1 := env ensureTraitNamed: 'SomeTrait1'.
	trait2 := env ensureTraitNamed: 'SomeTrait2'.

	self deny: trait1 metaclass equals: trait2 metaclass.
	env unifyTrait.
	self assert: trait1 metaclass equals: trait2 metaclass.

	env := RGEnvironment new.
	trait1 := env ensureTraitNamed: 'SomeTrait1'.
	trait2 := env ensureTraitNamed: 'SomeTrait2'.
	trait := env ensureClassNamed: 'Trait'.

	self deny: trait1 metaclass equals: trait2 metaclass.
	self deny: trait1 metaclass equals: trait.
	env unifyTrait.
	self assert: trait1 metaclass equals: trait2 metaclass.
	self assert: trait1 metaclass equals: trait! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testUnpackagedPackage

	| env package | 
	
	env := RGEnvironment new.
	self assert: env unpackagedPackageOrNil equals: nil.
	package := env ensurePackageNamed: '_UnpackagedPackage'.
	
	self assert: env unpackagedPackageOrNil equals: package.
	
	! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testBehaviortNamed

	| env behavior | 
	
	env := RGEnvironment new.
	behavior := env ensureClassNamed: 'SomeClass'.
	self assert: (env ask behaviorNamed: 'SomeClass') equals: behavior.

	env := RGEnvironment new.
	behavior := env ensureClassNamed: 'SomeClass class'.
	self assert: (env ask behaviorNamed: 'SomeClass class') equals: behavior.
	
	env := RGEnvironment new.
	behavior := env ensureClassNamed: 'SomeTrait'.
	self assert: (env ask behaviorNamed: 'SomeTrait') equals: behavior.
	
	env := RGEnvironment new.
	behavior := env ensureTraitNamed: 'SomeTrait classTrait'.
	self assert: (env ask behaviorNamed: 'SomeTrait classTrait') equals: behavior.
	
	env := RGEnvironment new.
	self assert: (env ask behaviorNamed: 'NonexistingBehavior') equals: nil.
	self assert: (env ask behaviorNamed: 'NonexistingBehavior class') equals: nil.
	self assert: (env ask behaviorNamed: 'NonexistingBehavior classTrait') equals: nil.
! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testMerging

"	| env1 env2 |
	
	env1 := RGEnvironment named: 'env1'.
	env2 := RGEnvironment named: 'env2'.	
	self deny: (env1 canMergeSimplyWith: env2).
	
	env1 := RGEnvironment unnamed.
	env2 := RGEnvironment unnamed.
	self deny: (env1 canMergeSimplyWith: env2).
	
	env1 := RGEnvironment named: 'env1'.
	env2 := RGEnvironment unnamed.
	self deny: (env1 canMergeSimplyWith: env2).

	env1 := RGEnvironment unnamed.
	env2 := RGEnvironment named: 'env2'.
	self deny: (env1 canMergeSimplyWith: env2).		
			
	env1 := RGEnvironment unnamed.
	env1 cleanPackages.
	env2 := RGEnvironment unnamed.
	env2 cleanPackages.
	self deny: (env1 canMergeSimplyWith: env2).


"! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testPackageNamed

	| env package | 
	
	env := RGEnvironment new.
	package := env ensurePackageNamed: 'SomePackage'.
	self assert: (env ask packageNamed: 'SomePackage') equals: package.
	
	env := RGEnvironment new.
	self assert: (env ask packageNamed: 'SomePackage') equals: nil.! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testNewEnvironment
	| newEnvironment |
	newEnvironment := RGEnvironment named: 'Testing environment'.

	self assert: newEnvironment isRingResolved.

	self assert: newEnvironment isEnvironment.
	self assert: newEnvironment name equals: 'Testing environment'.
	self assert: newEnvironment ask behaviors isEmpty.
	self assert: newEnvironment hasResolvedName.
	self assert: (newEnvironment hasUnresolved: #behaviors).
	self assert: (newEnvironment hasUnresolved: #globalVariables).

	newEnvironment cleanPackages.
	newEnvironment cleanBehaviors.
	newEnvironment cleanGlobalVariables.

	self assert: newEnvironment unresolvedProperties isEmpty.
	self assert: newEnvironment ask packages isEmpty! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testUnifyClassTrait
	| env trait1 trait2 classTrait |
	env := RGEnvironment new.
	trait1 := env ensureTraitNamed: 'SomeTrait1'.
	trait2 := env ensureTraitNamed: 'SomeTrait2'.

	self deny: trait1 classTrait metaclass equals: trait2 classTrait metaclass.
	env unifyClassTrait.
	self assert: trait1 classTrait metaclass equals: trait2 classTrait metaclass.

	env := RGEnvironment new.
	trait1 := env ensureTraitNamed: 'SomeTrait1'.
	trait2 := env ensureTraitNamed: 'SomeTrait2'.
	classTrait := env ensureClassNamed: 'ClassTrait'.

	self deny: trait1 classTrait metaclass equals: trait2 classTrait metaclass.
	self deny: trait1 classTrait metaclass equals: classTrait.
	env unifyClassTrait.
	self assert: trait1 classTrait metaclass equals: trait2 classTrait metaclass.
	self assert: trait1 classTrait metaclass equals: classTrait! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testEnsureClassNamed

	| env definition | 
	
	env := RGEnvironment new.
	definition := env ensurePackageNamed: 'SomePackage'.
	self assert: definition isPackage. 

	env := RGEnvironment new.
	definition := env ensureClassNamed: 'SomeClass'.
	self assert: definition isClass. 
	self assert: definition isMetaclass not. 	
	self assert: definition isTrait not. 	
	self assert: definition isMetaclassTrait not. 	

	env := RGEnvironment new.
	definition := env ensureClassNamed: 'SomeClass class'.
	self assert: definition isClass not. 
	self assert: definition isMetaclass. 	
	self assert: definition isTrait not. 	
	self assert: definition isMetaclassTrait not. 	

! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testReferencedPackages

	| env | 
	
	env := RGEnvironment new.
	"
	self assert: env referencedPackages isEmpty."! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testDefaultEnvironment

	| env  | 
	env := RGEnvironment new.
	env createDefaultEnvironment.
	self assert: (env ask behaviors collect: [:each | each name]) asSortedCollection equals: #(#Behavior #'Behavior class' #Class #'Class class' #ClassDescription #'ClassDescription class' #Metaclass #'Metaclass class' #Object #'Object class' #ProtoObject #'ProtoObject class') asSortedCollection.! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testFixProtoObjectClassSuperclass
	| env protoObject class |
	env := RGEnvironment new.
	protoObject := env ensureClassNamed: 'ProtoObject'.
	class := env ensureClassNamed: 'Class'.

	self deny: protoObject classSide superclass equals: class.
	env fixProtoObjectClassSuperclass.
	self assert: protoObject classSide superclass equals: class! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testEnvironmentWithNamespace

	| newEnvironment newPackage|
	
	newEnvironment := RGEnvironment named: 'Testing environment'.
	
	self assert: (newEnvironment isRingResolved).
	
	newPackage := RGPackage named: 'Collections-Sequenceable'.
	
	self assert: (newPackage isRingResolved).
	self deny: (newPackage isRingFullyResolved).
	self deny: (newPackage isRingFullyUnresolved).
	newPackage cleanDefinedBehaviors.
	newPackage cleanExtensionMethods.
	newPackage cleanTagsForClasses.
	self assert: (newPackage isRingResolved).
	self assert: (newPackage isRingFullyResolved).
	self deny: (newPackage isRingFullyUnresolved).
	
	self should: [newEnvironment addPackage: newPackage] raise: RGWrongEnvironment.! !

!RGEnvironmentTest methodsFor: 'tests' stamp: ''!
testCleanUnusedUnreferencedPackages

	| env package1 package2 | 
	
	env := RGEnvironment new.
	
	self assert: env ask packages isEmpty.
	env cleanUnusedUnreferencedPackages.
	self assert: env ask packages isEmpty.

	env ensurePackageNamed: #SomePackage.
	self assert: env ask packages size equals: 1.
	env cleanUnusedUnreferencedPackages.
	self assert: env ask packages isEmpty.
	
	(env ensureClassNamed: #SomeClass)
		package: (package1 := env ensurePackageNamed: #SomeUsedPackage).
	package2 := env ensurePackageNamed: #SomeUnusedPackage.
	self assert: (env ask packages includes: package1).  
	self assert: (env ask packages includes: package2).  
	env cleanUnusedUnreferencedPackages.
	self assert: (env ask packages includes: package1).  
	self deny: (env ask packages includes: package2).  
	! !

!RGEphemeronLayout methodsFor: '*Ring-Monticello' stamp: ''!
mcType

	^ #ephemeron ! !

!RGEphemeronLayout methodsFor: 'testing - types' stamp: ''!
isEphemeronLayout

	^ true! !

!RGEphemeronLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton."
	
	^ #ephemeronSubclass:! !

!RGFixedLayout methodsFor: '*Ring-Monticello' stamp: ''!
mcType

	^ #normal ! !

!RGFixedLayout methodsFor: 'testing - types' stamp: ''!
isFixedLayout

	^ true! !

!RGGlobalDefinition commentStamp: ''!
An RGGlobalDefinition is an abstract superclass for representing classes, global variables and shared pools
!
!RGGlobalDefinition methodsFor: 'comparing' stamp: 'nil'!
= aRGGlobalDefinition
	"This method look for equality of the properties of the receiver"
	"Verifies the class and the name of the receiver"

	^self class = aRGGlobalDefinition class
		and:[ self name == aRGGlobalDefinition name ]! !

!RGGlobalDefinition methodsFor: 'comparing' stamp: 'nil'!
hash
	"Hash is re-implemented because #= is re-implemented"
	
	^self class hash bitXor: (self name hash)! !

!RGGlobalDefinition methodsFor: 'accessing' stamp: 'nil'!
parent
	"Retrieves the namespace in which the receiver is known"
	
	^self environment! !

!RGGlobalDefinition class methodsFor: 'testing' stamp: 'nil'!
isAbstract

	^ self == RGGlobalDefinition! !

!RGGlobalDefinitionTest commentStamp: ''!
SUnit tests for global definitions (pools, global variables)!
!RGGlobalDefinitionTest methodsFor: 'testing' stamp: ''!
testEquality
	| global1 global2 |
	global1 := RGGlobalVariableDefinition named: #Transcript.
	global2 := RGGlobalVariableDefinition named: #Transcript.
	self assert: global1 equals: global2.

	global2 := RGGlobalVariableDefinition named: #Transcript2.
	self deny: global1 equals: global2! !

!RGGlobalDefinitionTest methodsFor: 'testing' stamp: ''!
testPoolDefinition
	| pool newClass |
	pool := RGClassDefinition createSharedPoolNamed: #TextConstants.
	self assert: pool isPool.
	self assertEmpty: pool users.
	self assert: pool parent equals: Smalltalk globals.
	newClass := RGClassDefinition named: #OrderedCollection.
	pool addUser: newClass.
	self assert: pool users size equals: 1.
	self assert: (pool includesUser: newClass).
	self assert: (newClass sharedPoolNamed: #TextConstants) isPoolVariable.
	pool := RGClassDefinition named: #TextConstants.
	pool superclassName: #SharedPool.
	self assert: pool isPool.
	self assertEmpty: pool users! !

!RGGlobalDefinitionTest methodsFor: 'testing' stamp: ''!
testGlobalVariableDefinition
	| global |
	global := RGGlobalVariableDefinition named: #Transcript.
	self assert: global isGlobalVariable.
	self assert: global parent equals: Smalltalk globals! !

!RGGlobalVariable commentStamp: ''!
A global variable definition!
!RGGlobalVariable methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ self defaultEnvironmentStub! !

!RGGlobalVariable methodsFor: 'analyzing' stamp: ''!
analyzeRead: aRBVariableNode by: anOCASTSemanticAnalyzer 

	! !

!RGGlobalVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode

	^ aProgramNodeVisitor visitGlobalVariableNode: aNode! !

!RGGlobalVariable methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	super addoptToParentStub.
	self parent addGlobalVariable: self.! !

!RGGlobalVariable methodsFor: 'testing' stamp: ''!
isSuperVariable 

	^ false! !

!RGGlobalVariable methodsFor: 'testing' stamp: ''!
isGlobalVariable

	^true! !

!RGGlobalVariableDefinition commentStamp: ''!
A global variable definition!
!RGGlobalVariableDefinition methodsFor: 'accessing' stamp: 'nil'!
value: anObject

	value := anObject! !

!RGGlobalVariableDefinition methodsFor: 'managing container' stamp: 'nil'!
isIncludedInContainer: aRGContainer

	^aRGContainer includesGlobalVariable: self! !

!RGGlobalVariableDefinition methodsFor: 'managing container' stamp: 'nil'!
removeFromContainer: aRGContainer

	aRGContainer removeGlobalVariable: self! !

!RGGlobalVariableDefinition methodsFor: 'accessing' stamp: 'nil'!
value
	"Retrieves the current value of the global variable"

	^ value! !

!RGGlobalVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isVariable

	^true! !

!RGGlobalVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isGlobalVariable

	^true! !

!RGGlobalVariableDefinition methodsFor: 'managing container' stamp: 'nil'!
addInContainer: aRGContainer

	aRGContainer addGlobalVariable: self! !

!RGGlobalVariableTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGGlobalVariable unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGGlobalVariableTest methodsFor: 'tests' stamp: ''!
testNewGlobalVariable

	| classVariable | 
	classVariable  := RGGlobalVariable named: #SomeGlobalVariable.
	self assert: (classVariable isRingResolved).
	self assert: (classVariable hasResolvedName).
	self assert: (classVariable isGlobalVariable).


	! !

!RGGlobalVariableTest methodsFor: 'tests' stamp: ''!
testGlobalVariableImplicitEnvironment
	| globalVariable |
	globalVariable := RGGlobalVariable unnamed.
	self assert: (globalVariable hasUnresolved: #name).
	self assert: globalVariable environment ask globalVariables size equals: 1.
	self assert: globalVariable environment ask globalVariables anyOne identicalTo: globalVariable! !

!RGImmediateLayout methodsFor: '*Ring-Monticello' stamp: ''!
mcType

	^ #immediate ! !

!RGImmediateLayout methodsFor: 'testing - types' stamp: ''!
isImmediateLayout

	^ true! !

!RGImmediateLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton."
	
	^ #immediateSubclass:! !

!RGIncompatibleBehaviorTypeError methodsFor: 'accessing' stamp: ''!
messageText

	^ 'This message cannot be sent. Incompatible behavior type.'! !

!RGInstanceVariableDefinition commentStamp: ''!
An instance variable definition!
!RGInstanceVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isInstanceVariable

	^true! !

!RGInstanceVariableSlot methodsFor: 'testing' stamp: ''!
needsFullDefinition
	"I am just a backward compatible ivar slot and can use simple definitions.
	 Note: my subclasses need full definitions"

	^ self class ~= RGInstanceVariableSlot! !

!RGInstanceVariableSlot methodsFor: '*Ring-RuntimeSupport' stamp: ''!
emitValue: methodBuilder

	methodBuilder pushInstVar: self index.
! !

!RGInstanceVariableSlot methodsFor: '*Ring-RuntimeSupport' stamp: ''!
emitStore: methodBuilder

	methodBuilder storeInstVar: self index! !

!RGInstanceVariableSlot methodsFor: '*Ring-RuntimeSupport' stamp: ''!
index

	"TODO!!"
	^ self parent parent allSlots indexOf: self! !

!RGLayout methodsFor: '*Ring-Monticello' stamp: ''!
mcType
	^ self layoutName! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isByteLayout

	^ false! !

!RGLayout methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ self defaultClassStub! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isCompiledMethodLayout

	^ false! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isPointerLayout

	^ false! !

!RGLayout methodsFor: 'accessing' stamp: ''!
layoutName
	^ (self class name allButFirst: 2) asSymbol! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isObjectLayout

	^ false! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isWordLayout

	^ false! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isWeakLayout

	^ false! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isBitsLayout

	^ false! !

!RGLayout methodsFor: 'accessing' stamp: ''!
resolveSlot: aName ifFound: foundBlock ifNone: exceptionBlock
	^exceptionBlock value! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isLayout

	^true! !

!RGLayout methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	super addoptToParentStub.
	self environment backend createUnresolvedClassGroupFor: self parent.
	self parent behaviorStrategy pvtLayout: self.! !

!RGLayout methodsFor: 'accessing' stamp: ''!
allSlots

	^ {  }! !

!RGLayout methodsFor: 'accessing' stamp: ''!
instVarNames
	^ {}! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isEphemeronLayout

	^ false! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isVariableLayout

	^ false! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isFixedLayout

	^ false! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isImmediateLayout

	^ false! !

!RGLayout methodsFor: 'testing - types' stamp: ''!
isEmptyLayout

	^ false! !

!RGLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton."
	
	^ #subclass:! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsImmediateLayout

	self assert: (RGImmediateLayout unnamed isImmediateLayout).
	self deny: (RGFixedLayout unnamed isImmediateLayout).
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testImplicitEnvironment
	
	RGLayout allSubclasses do: [ :layoutClass |
		| layout | 
		layout  := layoutClass unnamed.
		self checkImplicitSingleClassEnvironmentOf: layout parent. ].	

! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGPointerLayout unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsVariableLayout

	self assert: (RGVariableLayout unnamed isVariableLayout).
	self assert: (RGBitsLayout unnamed isVariableLayout).
	self deny: (RGFixedLayout unnamed isVariableLayout).
	self assert: (RGCompiledMethodLayout unnamed isVariableLayout).
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsWordLayouts

	self assert: (RGWordLayout unnamed isWordLayout).
	self deny: (RGEmptyLayout unnamed isWordLayout).
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsFixedLayout

	self assert: (RGFixedLayout unnamed isFixedLayout).
	self deny: (RGWordLayout unnamed isFixedLayout).
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsObjectLayout

	self assert: (RGImmediateLayout unnamed isObjectLayout).
	self deny: (RGEmptyLayout unnamed isObjectLayout).
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsPointerLayout

	self assert: (RGFixedLayout unnamed isPointerLayout).
	self deny: (RGEmptyLayout unnamed isPointerLayout).
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsBitsLayout

	self assert: (RGByteLayout unnamed isBitsLayout).
	self assert: (RGWordLayout unnamed isBitsLayout).
	self assert: (RGCompiledMethodLayout unnamed isBitsLayout).
	self deny: (RGFixedLayout unnamed isBitsLayout).
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsBytesLayout

	self assert: (RGByteLayout unnamed isByteLayout).
	self assert: (RGCompiledMethodLayout unnamed isByteLayout).
	self deny: (RGFixedLayout unnamed isByteLayout).
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsWeakLayout

	self assert: (RGWeakLayout unnamed isWeakLayout).
	self deny: (RGEmptyLayout unnamed isWeakLayout).
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsCompiledMethodLayout

	self assert: (RGCompiledMethodLayout unnamed isCompiledMethodLayout).
	self deny: (RGFixedLayout unnamed isCompiledMethodLayout).
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsEmptyLayout

	| layout layoutClass | 
		
	layoutClass := 	RGEmptyLayout.
	layout  := layoutClass unnamed.
	self assert: (layout isEmptyLayout).
	(RGLayout allSubclasses copyWithout: layoutClass) do: [ :each |
		self deny: (each unnamed isEmptyLayout) ]
	! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testNewLayouts

	RGLayout allSubclasses do: [ :layoutClass |
		| layout | 
		layout  := layoutClass unnamed.
		self assert: (layout isRingResolved).
		self assert: (layout hasUnresolved: #name).
		self assert: (layout isLayout).
		self assert: (layout allSlots isEmpty).
		self assert: (layout instVarNames isEmpty). ]! !

!RGLayoutDefinitionTest methodsFor: 'tests' stamp: ''!
testIsEphemeronLayout

	self assert: (RGEphemeronLayout unnamed isEphemeronLayout).
	self deny: (RGFixedLayout unnamed isEphemeronLayout).
	! !

!RGMCClassTest methodsFor: 'tests' stamp: ''!
testClassesWithTraits
	
	"classes without special slots"
	
	self skip. 
	"skip because of https://pharo.fogbugz.com/f/cases/22080/Monticello-wrongly-resolves-names-for-instance-variables-in-classes-that-contain-slots"
	
	Smalltalk allClasses
		select: [ :each | each isTrait not and: [each traits notEmpty or: [ each class traits notEmpty ]] ] 
		thenDo: [ :each | self testClass: each ]
	! !

!RGMCClassTest methodsFor: 'tests' stamp: ''!
testNormalKernelClasses
	
	"classes without special slots"
	
	(#Kernel asPackage definedClasses select: [:each | each isClass and: [each needsSlotClassDefinition  not]]) do: [ :each |
		self testClass: each].! !

!RGMCClassTest methodsFor: 'tests' stamp: ''!
testSpecialClasses
	
	"classes without special slots"
	
	(#Kernel asPackage definedClasses select: [:each | each isClass and: [each needsSlotClassDefinition]]) do: [ :each |
		self testClass: each].! !

!RGMCClassTest methodsFor: 'tests' stamp: ''!
testNormalClass
	
	"a class with instance variables, class variables and class instance variables"
	self testClass: MCMockClassB ! !

!RGMCTest methodsFor: 'tests' stamp: ''!
testClass: aClass
	
	| mcDef def env|
	mcDef := 	aClass asClassDefinition.
	def := mcDef asRGDefinition.
	env := def environment.
	
	self assert: def name equals: aClass name.
	aClass superclass ifNotNil: [ "ProtoObject & co."
		self assert: def superclass name equals: aClass superclass name.].
	self assert: def category equals: aClass category.
	self assert: def layout class equals: (self layoutClassesMapping at: aClass classLayout class).
	
	def layout isPointerLayout ifTrue: [ 
		self assert: (def layout slots collect: [:each | each name]) equals: aClass instVarNames.].
	self assert: (def metaclass layout slots collect: [:each | each name]) equals: aClass class instVarNames.	
	self assert: (def classVariables collect: [:each | each name]) equals: aClass classVarNames.	
	self assert: (def sharedPoolNames asArray) equals: aClass sharedPoolNames asArray.	
	
	"Monticello class definition still use only class categories, packages are unresolved"
	self assert: (def hasUnresolved: #package).
	self assert: (def hasResolved: #traitComposition).
	self compareTraitComposition: aClass traitComposition with: def traitComposition.
	self compareTraitComposition: aClass class traitComposition with: def metaclass traitComposition.! !

!RGMCTest methodsFor: 'tests' stamp: ''!
compareTraitComposition: aTraitComposition with: anRGTraitComposition
	
	self assert: aTraitComposition transformations size equals: anRGTraitComposition transformations size.
	
	aTraitComposition transformations with: anRGTraitComposition transformations do: [ :real :model |
		self assert: real isTrait equals: model isTrait.
		self assert: real isTraitAlias equals: model isTraitAlias.
		self assert: real isTraitExclusion equals: model isTraitExclusion.
		real isTraitExclusion ifTrue: [ 
			self assert: real subject name equals: model subject name.
			real exclusions with: model exclusions do: [:realExclusion :modelExclusion |
				self assert: realExclusion equals: modelExclusion	]].
		real isTraitAlias ifTrue: [ 
			self assert: real subject name equals: model subject name.
			real aliases associations with: model aliases do: [:realAlias :modelAlias |
				self assert: realAlias equals: modelAlias ]].
	  ].
	! !

!RGMCTest methodsFor: 'tests' stamp: ''!
layoutClassesMapping

	^ Dictionary newFrom: { 
		CompiledMethodLayout -> RGCompiledMethodLayout. 
		ByteLayout -> RGByteLayout. 
		ImmediateLayout -> RGImmediateLayout. 
		WordLayout -> RGWordLayout. 
		WeakLayout -> RGWeakLayout.
		VariableLayout -> RGVariableLayout.
		EphemeronLayout -> RGEphemeronLayout.
		FixedLayout -> RGFixedLayout.
	}! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testAlias

	| composition result |

	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: 'Trait2 @ {#a -> #c}' for: composition.
	
	self assert: result isCollection.
	self assert: (result allSatisfy: #isTraitAlias).
	self assert: (result allSatisfy: #isRGObject).
	self assert: result size equals: 1.
	self assert: result first subject isTrait.	
	self assert: result first subject name equals: #Trait2.
	self assert: result first aliases isCollection.
	self assert: result first aliases first equals: (#a -> #c).
	! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testMultipleTraits

	| composition result |

	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: 'Trait1 + Trait2 + Trait3 + Trait4' for: composition.
	
	self assert: result isCollection.
	self assert: result size equals: 4.

	self assert: (result allSatisfy: [:each | each isTrait]).
	self assert: (result allSatisfy: [:each | each isRGObject]).
	self assert: (result collect: [:each | each name ]) equals: #(Trait1 Trait2 Trait3 Trait4) asOrderedCollection.! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testEmpty

	| composition result |

	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: '' for: composition.
	
	self assert: result isCollection.
	self assert: result isEmpty.
	
	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: '{}' for: composition.
	
	self assert: result isCollection.
	self assert: result isEmpty.! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testClassTrait

	| composition result |
	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: 'Trait1 classTrait + Trait2 classTrait' for: composition.
	
	self assert: result isCollection.
	self assert: (result allSatisfy: [:each | each isTrait]).
	self assert: (result allSatisfy: [:each | each isRGObject]).
	self assert: (result collect: [:each | each name]) equals: #('Trait1 classTrait' 'Trait2 classTrait') asOrderedCollection.! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testExclusionWithMultipleExclusions
	| composition result |
	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: 'Trait2 - {#a. #b:. #c:d:}' for: composition.

	self assert: result isCollection.
	self assert: (result allSatisfy: #isTraitExclusion).
	self assert: (result allSatisfy: #isRGObject).
	self assert: result size equals: 1.
	self assert: result first subject isTrait.
	self assert: result first subject name equals: #Trait2.
	self assert: result first exclusions isCollection.
	self assert: result first exclusions asArray equals: #(#a #b: #c:d:)! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testAliasWithMultipleAliases

	| composition result |

	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: 'Trait2 @ {#a -> #b. #c: -> #d:}' for: composition.
	
	self assert: result isCollection.
	self assert: (result allSatisfy: #isTraitAlias).
	self assert: (result allSatisfy: #isRGObject).
	self assert: result size equals: 1.
	self assert: result first subject isTrait.	
	self assert: result first subject name equals: #Trait2.
	self assert: result first aliases isCollection.
	self assert: result first aliases size equals: 2.
	self assert: result first aliases first equals: (#a -> #b).
	self assert: result first aliases second equals: (#c: -> #d:).
	! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testExclusionWithLiteralArray
	| composition result |
	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: 'Trait2 - #(c)' for: composition.

	self assert: result isCollection.
	self assert: (result allSatisfy: #isTraitExclusion).
	self assert: (result allSatisfy: #isRGObject).
	self assert: result size equals: 1.
	self assert: result first subject isTrait.
	self assert: result first subject name equals: #Trait2.
	self assert: result first exclusions isCollection.
	self assert: result first exclusions asArray equals: #(#c)! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testComplexDefinition
	| composition result |
	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: 'Trait1 + (Trait2 @ {#a -> #b. #c: -> #d:}) + (Trait3 - {#e. #f:})' for: composition.

	self assert: result isCollection.
	self assert: (result allSatisfy: #isRGObject).
	self assert: result size equals: 3.

	self assert: result first isTrait.
	self assert: result first name equals: #Trait1.

	self assert: result second isTraitAlias.
	self assert: result second subject isTrait.
	self assert: result second subject name equals: #Trait2.
	self assert: result second aliases isCollection.
	self assert: result second aliases size equals: 2.
	self assert: result second aliases first equals: #a -> #b.
	self assert: result second aliases second equals: #c: -> #d:.

	self assert: result third isTraitExclusion.
	self assert: result third isRGObject.
	self assert: result third subject isTrait.
	self assert: result third subject name equals: #Trait3.
	self assert: result third exclusions isCollection.
	self assert: result third exclusions asArray equals: #(#e #f:)! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testExclusion
	| composition result |
	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: 'Trait2 - {#c}' for: composition.

	self assert: result isCollection.
	self assert: (result allSatisfy: #isTraitExclusion).
	self assert: (result allSatisfy: #isRGObject).
	self assert: result size equals: 1.
	self assert: result first subject isTrait.
	self assert: result first subject name equals: #Trait2.
	self assert: result first exclusions isCollection.
	self assert: result first exclusions asArray equals: #(#c)! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testSingleTrait

	| composition result |

	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: 'Trait1' for: composition.
	
	self assert: result isCollection.
	self assert: (result allSatisfy: [:each | each isTrait]).
	self assert: (result allSatisfy: [:each | each isRGObject]).
	self assert: (result collect: [:each | each name]) equals: #(Trait1) asOrderedCollection.! !

!RGMCTraitCompositionVisitorTest methodsFor: 'tests' stamp: ''!
testTwoTraits

	| composition result |

	composition := RGTraitComposition unnamed.
	result := RGTraitCompositionVisitor new parse: 'Trait1 + Trait2' for: composition.
	
	self assert: result isCollection.
	self assert: (result allSatisfy: [:each | each isTrait]).
	self assert: (result allSatisfy: [:each | each isRGObject]).
	self assert: (result collect: [:each | each name]) equals: #(Trait1 Trait2) asOrderedCollection.! !

!RGMergeError methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!RGMergeError methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!RGMergeError methodsFor: 'accessing' stamp: ''!
property: anObject
	property := anObject! !

!RGMergeError methodsFor: 'accessing' stamp: ''!
property
	^ property! !

!RGMergeError methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!RGMergeError methodsFor: 'accessing' stamp: ''!
target: anObject
	target := anObject! !

!RGMergeError class methodsFor: 'instance creation' stamp: ''!
property: propertySymbol target: targetDefinition source: sourceDefinition

	^ self new
		property: propertySymbol;
		target: targetDefinition;
		source: sourceDefinition;
		signal.
		! !

!RGMetaclass commentStamp: ''!
A factory that produces instances of RG2Behavior composed with RGMetaclassStrategy!
!RGMetaclass class methodsFor: 'instance creation' stamp: ''!
newStrategy

	^ RGMetaclassStrategy unresolved! !

!RGMetaclassDefinition commentStamp: ''!
RGMetaclassDefinition is a concrete representation of metaclasses of classes (traits are excluded)!
!RGMetaclassDefinition methodsFor: 'accessing - parallel hierarchy' stamp: 'nil'!
classSide
	"Return the metaclass of the couple class/metaclass. Useful to avoid explicit test."
	^ self! !

!RGMetaclassDefinition methodsFor: 'accessing' stamp: 'nil'!
inheritsFrom: aClass

	^ self realClass inheritsFrom: aClass! !

!RGMetaclassDefinition methodsFor: 'variables' stamp: 'nil'!
allSharedPoolNames

	^self instanceSide allSharedPoolNames! !

!RGMetaclassDefinition methodsFor: 'testing' stamp: 'nil'!
isSameRevisionAs: aRGMetaclassDefinition
	"This method look for equality of the properties of the receiver"

	^(super isSameRevisionAs: aRGMetaclassDefinition)
		and:[ self traitCompositionSource = aRGMetaclassDefinition traitCompositionSource ]! !

!RGMetaclassDefinition methodsFor: 'accessing' stamp: 'nil'!
environment

	^baseClass environment! !

!RGMetaclassDefinition methodsFor: 'accessing' stamp: 'nil'!
category
	^ self instanceSide category! !

!RGMetaclassDefinition methodsFor: 'testing' stamp: 'nil'!
isMeta

	^true! !

!RGMetaclassDefinition methodsFor: 'variables' stamp: 'nil'!
allClassVarNames

	^self instanceSide allClassVarNames! !

!RGMetaclassDefinition methodsFor: 'accessing - parallel hierarchy' stamp: 'nil'!
instanceSide
	"Return the class of the couple class/metaclass. Useful to avoid explicit test."
	^ baseClass! !

!RGMetaclassDefinition methodsFor: 'accessing' stamp: 'nil'!
realClass

	^baseClass realClass classSide! !

!RGMetaclassDefinition methodsFor: 'accessing' stamp: 'nil'!
package

	^baseClass package! !

!RGMetaclassDefinition methodsFor: 'printing' stamp: 'nil'!
storeOn: aStream
	
	aStream nextPut: $(. 
	super storeOn: aStream.
	aStream nextPutAll: ' baseClass:'.
	self instanceSide storeOn: aStream.
	aStream nextPut: $).
	
! !

!RGMetaclassDefinition methodsFor: 'accessing' stamp: 'nil'!
baseClass: aRGClassDefinition

	baseClass:= aRGClassDefinition.
	self name: (baseClass name, ' class') asSymbol! !

!RGMetaclassDefinition methodsFor: '*Manifest-Core' stamp: ''!
arrayStringForManifest
	| array |
	array := Array new: 2.
	array at: 1 put: self class asString asSymbol.
	array
		at: 2
		put:
			{(name asSymbol).
			(self instanceSide asString asSymbol)}.
	^ array! !

!RGMetaclassDefinition class methodsFor: '*Manifest-Core' stamp: ''!
manifestReadOn: aArray

	^ (self named:( aArray at:1))
		baseClass: (RGClassDefinition named: (aArray at:2))! !

!RGMetaclassDefinition class methodsFor: 'class initialization' stamp: 'nil'!
class: anORClassDefinition

	^self new
		baseClass: anORClassDefinition;
		yourself! !

!RGMetaclassDefinitionTest commentStamp: ''!
SUnit tests for Ring metaclass definitions!
!RGMetaclassDefinitionTest methodsFor: '*Manifest-Tests' stamp: ''!
testManifestReadOn
	| class |
	class := self class.

 	self
		assert: (RGMetaclassDefinition manifestReadOn: { class class name asSymbol . class name asSymbol })
		equals: class class asRingDefinition! !

!RGMetaclassDefinitionTest methodsFor: 'testing' stamp: ''!
testAsMetaclassDefinition
	| rgClass class |
	class := Class class.
	rgClass := class asRingDefinition.

	self assert: rgClass isRingObject.
	self assert: rgClass isClass.
	self assert: rgClass name identicalTo: #'Class class'.
	self assert: rgClass category identicalTo: class category.
	self assert: rgClass classSide identicalTo: rgClass! !

!RGMetaclassDefinitionTest methodsFor: '*Manifest-Tests' stamp: ''!
testArrayStringForManifest
	| class |
	class := self class class.

 	self
		assert: class asRingDefinition arrayStringForManifest
		equals: { #RGMetaclassDefinition . { class name asSymbol . self class name asSymbol } }! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
bindingOf: varName
	
	^ self baseClass bindingOf: varName! !

!RGMetaclassStrategy methodsFor: 'testing' stamp: ''!
storeName

	^ 'RGMetaclass'! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
isMetaclass

	^true! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtAsMetaclassTrait

	| newMetaclassTrait |
	
	(self owner resolvedProperties includesAnyOf: #(superclass traitComposition))
		ifTrue: [self error: 'This class cannot be converted to trait'].
		
	"TODO: check empty layout"
	newMetaclassTrait := RGMetaclassTrait unresolvedWithParent: self owner parent.
	newMetaclassTrait copyPropertiesFrom: self owner.

	(self owner hasResolvedName)
		ifTrue: [ newMetaclassTrait pvtName: ((self owner name withoutSuffix: ' class'), ' classTrait') asSymbol ].
	newMetaclassTrait pvtLocalMethods: self owner localMethods.
	
	^ newMetaclassTrait
	
	! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
metaclass

	"temporary" 
	^ self! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
initialize

	baseClass := RGUnresolvedValue recursive.
	
	super initialize.
	
	! !

!RGMetaclassStrategy methodsFor: 'visiting' stamp: ''!
acceptVisitor: aVisitor 

	^ aVisitor visitMetaclass: self owner! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
baseClass

	^ self backend forBehavior baseClassFor: self owner! !

!RGMetaclassStrategy methodsFor: 'testing' stamp: ''!
isMetaclassStrategy

	^ true! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtBaseClass: anRGClass

	self owner environment verifyOwnership: anRGClass.

	^ baseClass := anRGClass! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
classVarNames

	^ self instanceSide classVarNames! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
sibling

	^ self baseClass.! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
baseBehavior

	^ self baseClass! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
category

	^ self baseClass category! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
referencedBehaviors

	^ super referencedBehaviors, {self baseClass}! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
defaultMetaClass

	"will be set correctly together with baseClass"
	^ RGUnresolvedValue new default: nil.! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
comment

	^ self baseClass comment! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
isMeta

	^true! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
allClassVarNames

	self owner instanceSide allClassVarNames ! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
innerBindingOf: varName

	^self instanceSide innerBindingOf: varName! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
instanceSide
	^ self baseClass ! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
definition
	"Refer to the comment in ClassDescription|definition."

	^ String streamContents: 
		[:strm |
		strm print: self.
		self owner hasTraitComposition ifTrue: [
			strm
				crtab;
				nextPutAll: 'uses: ';
				print: self traitComposition ].
		
		(self owner slotsNeedFullDefinition or: [ ClassDefinitionPrinter showFluidClassDefinition ])
			ifFalse: [  
						strm
							crtab;
							nextPutAll: 'instanceVariableNames: ';
							store: self owner instanceVariablesString]
			ifTrue: [ 
						strm
							crtab;
							nextPutAll: 'slots: ';
							nextPutAll: self owner slotDefinitionString]]! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
makeResolved

	"try to set the correct name before resolving of it"
	((self owner hasUnresolved: #name) and: [ self baseClass isRingResolved and: [ self baseClass hasResolvedName ] ]) ifTrue: [ 
		self owner pvtName: (self baseClass name, ' class') asSymbol.
		 ].
	
	super makeResolved markAsRingResolved.
	
	baseClass := self baseClass.! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
package

	^ self baseClass package! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#baseClass -> baseClass. 
   	}
	
	! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
baseClass: anRGClass

	self backend forBehavior setBaseClassFor: self owner to: anRGClass! !

!RGMetaclassStrategy methodsFor: 'private - backend access' stamp: ''!
pvtBaseClass

	^ baseClass value! !

!RGMetaclassStrategyTest methodsFor: 'tests' stamp: ''!
testSharedPools

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newMetaclass.
	self assert: (anRGBehavior sharedPools) isEmpty.! !

!RGMetaclassStrategyTest methodsFor: 'tests' stamp: ''!
testTheMetaclass

	| anRGBehavior |
	anRGBehavior := RGBehavior newMetaclass.
	self assert: anRGBehavior classSide equals: anRGBehavior! !

!RGMetaclassStrategyTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGMetaclass unnamed behaviorStrategy.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGMetaclassStrategyTest methodsFor: 'tests' stamp: ''!
testCreationByMethod

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newMetaclass.
	self assert: (anRGBehavior isBehavior).	
	self assert: (anRGBehavior behaviorStrategy isMetaclassStrategy).! !

!RGMetaclassStrategyTest methodsFor: 'tests' stamp: ''!
testSetBaseClass

	| env class1 class2 |
	
	env := RGEnvironment new.
	class1 := env ensureClassNamed: 'SomeClass1'.
	class2 := env ensureClassNamed: 'SomeClass2'.
	self assert: class1 metaclass baseBehavior equals: class1.
	class1 metaclass baseClass: class2.
	self assert: class1 metaclass baseBehavior equals: class2.
	! !

!RGMetaclassStrategyTest methodsFor: 'tests' stamp: ''!
testIncompatibleBehavior

	| anRGBehavior aTrait |
	
	anRGBehavior := RGBehavior newMetaclass.
	aTrait := anRGBehavior environment ensureTraitNamed: 'SomeTrait'.
	
	self checkIncompatible: [ 
		anRGBehavior addClassVariable: (RGClassVariable named: #classVar parent: anRGBehavior) ].
	self checkIncompatible: [ 
		anRGBehavior allClassVariables ].
	self checkIncompatible: [ 
		anRGBehavior classVariableDefinitionString ].
	self checkIncompatible: [ 
		anRGBehavior classVariables ].
	self checkIncompatible: [ 
		anRGBehavior classVariables: Array new ].
	self checkIncompatible: [ 
		anRGBehavior classVariablesDo: [:classVar | ] ].
	self checkIncompatible: [ 
		anRGBehavior cleanClassVariables ].
	
	self checkIncompatible: [ 
		anRGBehavior addSharedPool: (anRGBehavior environment ensureClassNamed: #SomePool) ].
	self checkIncompatible: [ 
		anRGBehavior cleanSharedPools ].

	self checkIncompatible: [ 
		anRGBehavior category: #someCategory ].

	self checkIncompatible: [ 
		anRGBehavior classTrait ].

	self checkIncompatible: [ 
		anRGBehavior classTrait: aTrait classTrait ].

	self checkIncompatible: [ 
		anRGBehavior comment: (RGComment parent: anRGBehavior) ].

	self checkIncompatible: [ 
		anRGBehavior sharedPools: Array new ].

	self checkIncompatible: [ 
		anRGBehavior trait ].

! !

!RGMetaclassStrategyTest methodsFor: 'tests' stamp: ''!
testStoreString

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newMetaclass.
	self assert: anRGBehavior storeString equals: '(RGMetaclass named: #unresolved)'.

	anRGBehavior := RGMetaclass named: #SomeMetaclass.
	self assert: anRGBehavior storeString equals: '(RGMetaclass named: #SomeMetaclass)'.	! !

!RGMetaclassStrategyTest methodsFor: 'tests' stamp: ''!
testKind

	| strategy |
	
	strategy := RGBehavior newMetaclass behaviorStrategy.
	self deny: strategy isClassStrategy.
	self assert: strategy isMetaclassStrategy.
	self deny: strategy isTraitStrategy.
	self deny: strategy isMetaclassTraitStrategy.
	! !

!RGMetaclassTrait commentStamp: ''!
A factory that produces instances of RG2Behavior composed with RGMetaclassTraitStrategy!
!RGMetaclassTrait class methodsFor: 'instance creation' stamp: ''!
strategyClassForVersion: aVersionNumber

	^ (aVersionNumber <= 6)
		ifTrue: [ RGMetaclassTraitStrategy ]
		ifFalse: [ RGMetaclassTraitV2Strategy ]
! !

!RGMetaclassTrait class methodsFor: 'instance creation' stamp: ''!
newStrategy

	^ RGMetaclassTraitStrategy unresolved! !

!RGMetaclassTrait class methodsFor: 'instance creation' stamp: ''!
newStrategyFor: anRGEnvironment

	^ (self strategyClassForVersion: anRGEnvironment version) unresolved
! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
traitTransformationString		
		
	^ self owner name ! !

!RGMetaclassTraitStrategy methodsFor: 'visiting' stamp: ''!
acceptVisitor: aVisitor 

	^ aVisitor visitClassTrait: self owner! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
sibling

	^ self baseTrait.! !

!RGMetaclassTraitStrategy methodsFor: 'testing' stamp: ''!
storeName

	^ 'RGMetaclassTrait'! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
baseBehavior

	^ self baseTrait! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
baseTrait

	^ self backend forBehavior metaclassTraitBaseTraitFor: self owner! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
category

	^ self baseTrait category! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
baseTrait: anRGClass

	self backend forBehavior setMetaclassTraitBaseTraitFor: self to: anRGClass! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
referencedBehaviors

	^ super referencedBehaviors, {self baseTrait}! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
comment

	^ self baseTrait comment! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
isMeta

	^true! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
instanceSide

	^ self baseTrait! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
pvtBaseTrait: anRGTrait

	self owner environment verifyOwnership: anRGTrait.

	^ baseTrait := anRGTrait! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
definition
	^String streamContents: [:stream |
		stream
			nextPutAll: self baseTrait name;
			nextPutAll: ' clasTrait';
			crtab;
			nextPutAll: 'uses: ';
			nextPutAll: self owner traitCompositionString]! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
makeResolved

	
	"try to set the correct name before resolving of it"
	((self owner hasUnresolved: #name) and: [ self baseClass isRingResolved and: [ self baseTrait hasResolvedName] ]) ifTrue: [ 
		self owner pvtName: (self baseTrait name, ' classTrait') asSymbol.
		 ].

	super makeResolved.
	
	baseTrait := self baseTrait markAsRingResolved.! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
pvtBaseTrait

	^ baseTrait value! !

!RGMetaclassTraitStrategy methodsFor: 'testing' stamp: ''!
isMetaclassTraitStrategy

	^ true! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
package

	^ self baseTrait package! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, {
		#baseTrait -> baseTrait. 
   	}
	
	! !

!RGMetaclassTraitStrategy methodsFor: 'private - backend access' stamp: ''!
isMetaclassTrait

	^ true! !

!RGMetaclassTraitStrategyTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGMetaclassTrait unnamed behaviorStrategy.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGMetaclassTraitStrategyTest methodsFor: 'tests' stamp: ''!
testCreationByMethod

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newMetaclassTrait.
	self assert: (anRGBehavior isBehavior).	
	self assert: (anRGBehavior behaviorStrategy isMetaclassTraitStrategy).! !

!RGMetaclassTraitStrategyTest methodsFor: 'tests' stamp: ''!
testKind

	| strategy |
	
	strategy := RGBehavior newMetaclassTrait behaviorStrategy.
	self deny: strategy isClassStrategy.
	self deny: strategy isMetaclassStrategy.
	self deny: strategy isTraitStrategy.
	self assert: strategy isMetaclassTraitStrategy.
	! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testHasMethods
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self deny: newBehavior hasMethods.
	1 to: 10 do: [ :i | 
		| m |
		m := RGMethod
			named: 'method' , i asString
			parent: newBehavior.
		newBehavior addLocalMethod: m ].
	self assert: newBehavior hasMethods.	
	newBehavior cleanLocalMethods.
	self deny: newBehavior hasMethods.
! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testImplicitConversionFromClassProperties

	| env entity |
	
	env := RGEnvironment new.
	entity := env ensureClassNamed: #SomeTrait.	
	entity := env ensureTraitNamed: #'SomeTrait'.
	self assert: entity classTrait isTrait.
	self assert: entity classTrait baseTrait equals: entity.
! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testProtocols

	| newBehavior |
	newBehavior := self behaviorClass unnamed.
	
	self assert: newBehavior asYetUnclassifiedProtocolName isSymbol.

	! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testImplicitConversionFromClass

	| env |
	
	env := RGEnvironment new.
	env ensureClassNamed: #SomeTrait.
	self assert: (env ask behaviors select: [ :e | e name = #'SomeTrait' ]) size equals: 1.
	self assert: (env ask behaviors select: [ :e | e name = #'SomeTrait clss' ]) size equals: 0.
	
	env ensureTraitNamed: #'SomeTrait'.
	self assert: (env ask behaviors select: [ :e | e name = #'SomeTrait' ]) size equals: 1.
	self assert: (env ask behaviors select: [ :e | e name = #'SomeTrait classTrait' ]) size equals: 0.
	self assert: (env ask behaviors select: [ :e | e name = #'SomeTrait clss' ]) size equals: 0.
	env.
! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testBehavior
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self deny: (newBehavior includesSelector: #method).
	method := RGMethod named: #method parent: newBehavior.
	newBehavior addLocalMethod: method.
	self deny: method isBehavior.
	self assert: (newBehavior includesSelector: #method).
	self assert: (newBehavior allInstVarNames isEmpty).
	self assert: (newBehavior allSlots isEmpty).
	self assert: (newBehavior bindingOf: #someVariable) isNil.
	self assert: (newBehavior classVariablesBindings isEmpty).
	
	self deny: (newBehavior isRingFullyUnresolved).

	self deny: newBehavior hasTraitComposition.	
	
! !

!RGMetaclassTraitTest methodsFor: 'accessing' stamp: ''!
behaviorClass

	^ RGMetaclassTrait! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testIsBehavior

	| newBehavior |
	newBehavior := self behaviorClass unnamed.
	
	self assert: newBehavior isBehavior

	! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testMakeReslolvedResolvesEverything

	| behavior |

	behavior := self behaviorClass unnamed.
	behavior makeResolved.
	self assert: behavior unresolvedProperties isEmpty.! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testEnsureProtocol

	| behavior |
	
	behavior := self behaviorClass named: #SomeClass.
	behavior ensureProtocolNamed: #SomeProtocol.
	self assert: behavior protocols size equals: 1.
	self assert: behavior protocols first equals: #SomeProtocol.
	! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithCategorizedMethods
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior ask methods isEmpty.
	self assert: newBehavior ask protocols isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	newBehavior addLocalMethod: method.
	self assert: (newBehavior hasResolved: #tagsForMethods).
! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithProtocols
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods tagsForMethods)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior methods isEmpty.
	1 to: 10 do: [ :i | 
		newBehavior addProtocol: ('protocol' , i asString) asSymbol ].
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: (newBehavior protocols allSatisfy: #isSymbol).
	self assert: newBehavior protocols size equals: 10.
	(newBehavior protocols first: 4)
		do: [ :each | newBehavior removeProtocol: each ].
	self assert: newBehavior protocols size equals: 6.
	newBehavior cleanProtocols.
	self assert: newBehavior protocols isEmpty! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testNewBehavior
	| newBehavior newSuperclass |
	newBehavior := self behaviorClass unnamed.
	self assert: newBehavior isRingResolved.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	newBehavior name: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self assert: (newBehavior hasResolvedName).
	self deny: (newBehavior hasUnresolved: #name).
	newBehavior isTrait
		ifFalse: [ self assert: newBehavior superclass isRingResolved not ].
	"	self assert: (newBehavior superclass environment == newBehavior environment).
"
	newSuperclass := RGClass
		named: #MySuperclass
		parent: newBehavior environment.
	self assert: newSuperclass environment == newBehavior environment.
	self
		assert: (newSuperclass hasUnresolvedAll: #(superclass localMethods protocols))! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithUnategorizedMethod
	| newBehavior method |
	
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait ifFalse: [  
		self assert: (newBehavior hasUnresolved: #superclass).].
	self assert: (newBehavior methods isEmpty).
	self assert: (newBehavior protocols isEmpty).

	method := RGMethod named: #someMethod parent: newBehavior. 
	newBehavior addLocalMethod: method.
	
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanProtocols.

	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	
	newBehavior cleanLocalMethods.
	self assert: (newBehavior protocols isEmpty).
	
! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithUnategorizedMethods
	| newBehavior method1 method2 |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods tagsForMethods)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior methods isEmpty.
	self assert: newBehavior protocols isEmpty.
	method1 := RGMethod named: #method1 parent: newBehavior.
	method2 := RGMethod named: #method2 parent: newBehavior.
	newBehavior addLocalMethod: method1.
	newBehavior addLocalMethod: method2.
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanProtocols.
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanLocalMethods.
	self assert: newBehavior protocols isEmpty! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testMetaclassTraitImplicitEnvironment

	| trait |
	
	trait := RGMetaclassTrait unnamed.
	self assert: (trait hasUnresolved: #name).
	self checkImplicitSingleTraitEnvironmentOf: trait baseTrait.
	
	
	
	
! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithOneMethod
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior localMethods isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	self assert: method environment == newBehavior environment.
	self assert: newBehavior localMethods isEmpty.	"we do not add the method to the behavior"
	newBehavior := self behaviorClass named: #SomeClass.
	newBehavior cleanLocalMethods.
	self assert: (newBehavior hasResolved: #localMethods).
	self assert: newBehavior localMethods isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	newBehavior addLocalMethod: method.
	self assert: method environment == newBehavior environment.
	self assert: (newBehavior hasResolved: #localMethods).
	self assert: newBehavior localMethods anyOne name equals: #someMethod.
	newBehavior removeLocalMethod: method.
	self assert: newBehavior localMethods isEmpty.
	self assert: (newBehavior hasResolved: #localMethods)! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testCopyForBehaviorDefinition
	
	| env aClass copy |
	
	env := RGEnvironment new.
	aClass := env ensureClassNamed: #SomeClass.
	aClass superclass: (env ensureClassNamed: #SomeSuperclass).
	aClass tagWith: #tag1.
	aClass tagWith: #tag2.
		
	copy := aClass copyForBehaviorDefinition.
	
	self deny: copy == aClass. 
	self deny: copy superclass == aClass superclass. 
	self assert: copy superclass name equals: #SomeSuperclass.
	self assert: copy tags sorted equals: #(tag1 tag2).! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithMethods
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior localMethods isEmpty.
	1 to: 10 do: [ :i | 
		| m |
		m := RGMethod
			named: 'method' , i asString
			parent: newBehavior.
		newBehavior addLocalMethod: m ].
	self assert: (newBehavior hasResolved: #localMethods).
	self
		assert:
			(newBehavior localMethods
				allSatisfy: [ :each | each environment = newBehavior environment ]).
	self assert: newBehavior localMethods size equals: 10.
	(newBehavior localMethods first: 4)
		do: [ :each | newBehavior removeLocalMethod: each ].
	self assert: newBehavior localMethods size equals: 6.
	newBehavior cleanLocalMethods.
	self assert: newBehavior localMethods isEmpty! !

!RGMetaclassTraitTest methodsFor: 'tests' stamp: ''!
testNewMetaclassTrait
	| trait baseTrait |
	trait := RGMetaclassTrait unnamed.
	self assert: trait isRingResolved.
	self assert: (trait hasUnresolved: #baseTrait).
	self assert: trait isTrait.

	baseTrait := RGTrait parent: trait environment.
	trait baseTrait: baseTrait.
	self assert: (trait hasResolved: #baseTrait).
	self assert: trait baseTrait identicalTo: baseTrait! !

!RGMetaclassTraitTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RGMetaclassTraitTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RGMetaclassTraitTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RGMetaclassTraitTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RGMetaclassTraitTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RGMetaclassTraitTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RGMetaclassTraitTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RGMetaclassTraitTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RGMetaclassTraitTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGMetaclassTraitTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RGMetaclassTraitTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RGMetaclassTraitTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RGMetaclassTraitTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RGMetaclassTraitTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RGMetaclassTraitTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RGMetaclassTraitTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RGMetaclassTraitTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RGMetaclassTraitTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGMetaclassTraitTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RGMetaclassTraitTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RGMetaclassTraitTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RGMetaclassTraitTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RGMetaclassTraitTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RGMetaclassTraitTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RGMetaclassTraitTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RGMetaclassTraitTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RGMetaclassTraitTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RGMetaclassTraitTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RGMetaclassTraitTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
initialize

	baseClass := RGUnresolvedValue recursive.
	
	super initialize.
	
	! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
baseClass

	^ self backend forBehavior baseClassFor: self owner! !

!RGMetaclassTraitV2Strategy methodsFor: 'testing' stamp: ''!
isMetaclassStrategy

	^ true! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtBaseClass: anRGClass

	self owner environment verifyOwnership: anRGClass.

	^ baseClass := anRGClass! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
classVarNames

	^ self instanceSide classVarNames! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
bindingOf: varName
	
	^ self baseClass bindingOf: varName! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
baseBehavior

	^ self baseClass! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
category

	^ self baseClass category! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
isMetaclass

	^true! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
defaultMetaClass

	"will be set correctly together with baseClass"
	^ RGUnresolvedValue new default: nil.! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
referencedBehaviors

	^ super referencedBehaviors, {self baseClass}! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
sibling

	^ self baseClass.! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
comment

	^ self baseClass comment! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
isMeta

	^true! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtAsMetaclassTrait

	| newMetaclassTrait |
	
	(self owner resolvedProperties includesAnyOf: #(superclass traitComposition))
		ifTrue: [self error: 'This class cannot be converted to trait'].
		
	"TODO: check empty layout"
	newMetaclassTrait := RGMetaclassTrait unresolvedWithParent: self owner parent.
	newMetaclassTrait copyPropertiesFrom: self owner.

	(self owner hasResolvedName)
		ifTrue: [ newMetaclassTrait pvtName: ((self owner name withoutSuffix: ' class'), ' classTrait') asSymbol ].
	newMetaclassTrait pvtLocalMethods: self owner localMethods.
	
	^ newMetaclassTrait
	
	! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
instanceSide
	^ self baseClass ! !

!RGMetaclassTraitV2Strategy methodsFor: 'testing' stamp: ''!
storeName

	^ 'RGMetaclass'! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
definition
	^String streamContents: [:stream |
		stream
			nextPutAll: self baseTrait name;
			nextPutAll: ' clasTrait';
			crtab;
			nextPutAll: 'uses: ';
			nextPutAll: self owner traitCompositionString.
		(self owner slots size > 0) ifTrue: [ 
			(self owner slotsNeedFullDefinition or: [ ClassDefinitionPrinter showFluidClassDefinition ])
				ifFalse: [  
							stream
								crtab;
								nextPutAll: 'instanceVariableNames: ';
								store: self owner instanceVariablesString]
				ifTrue: [ 
							stream
								crtab;
								nextPutAll: 'slots: ';
								nextPutAll: self owner slotDefinitionString]]]! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
makeResolved

	"try to set the correct name before resolving of it"
	((self owner hasUnresolved: #name) and: [ self baseClass isRingResolved and: [ self baseClass hasResolvedName ] ]) ifTrue: [ 
		self owner pvtName: (self baseClass name, ' class') asSymbol.
		 ].
	
	super makeResolved.
	
	baseClass := self baseClass markAsRingResolved.! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
metaclass

	"temporary" 
	^ self! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
package

	^ self baseClass package! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#baseClass -> baseClass. 
   	}
	
	! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
baseClass: anRGClass

	self backend forBehavior setBaseClassFor: self owner to: anRGClass! !

!RGMetaclassTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtBaseClass

	^ baseClass value! !

!RGMetatraitDefinition commentStamp: ''!
RGMetatraitDefinition is a concrete representation of metaclasses of traits!
!RGMetatraitDefinition methodsFor: 'accessing - parallel hierarchy' stamp: 'nil'!
classSide
	"Return the metaclass of the couple class/metaclass. Useful to avoid explicit test."
	^ self! !

!RGMetatraitDefinition methodsFor: 'testing' stamp: 'nil'!
isSameRevisionAs: aRGMetatraitDefinition
	"This method look for equality of the properties of the receiver"

	^(super isSameRevisionAs: aRGMetatraitDefinition)
		and: [ self traitCompositionSource = aRGMetatraitDefinition traitCompositionSource ]! !

!RGMetatraitDefinition methodsFor: 'accessing' stamp: 'nil'!
environment

	^baseClass environment! !

!RGMetatraitDefinition methodsFor: 'accessing' stamp: 'nil'!
category
	^ self instanceSide category! !

!RGMetatraitDefinition methodsFor: 'testing' stamp: 'nil'!
isMeta

	^true! !

!RGMetatraitDefinition methodsFor: 'accessing - parallel hierarchy' stamp: 'nil'!
instanceSide
	"Return the class of the couple class/metaclass. Useful to avoid explicit test."
	^ baseClass! !

!RGMetatraitDefinition methodsFor: 'accessing' stamp: 'nil'!
realClass

	^baseClass realClass classSide! !

!RGMetatraitDefinition methodsFor: 'accessing' stamp: 'nil'!
package

	^baseClass package! !

!RGMetatraitDefinition methodsFor: 'accessing' stamp: 'nil'!
baseClass: anRGTraitDefinition

	baseClass:= anRGTraitDefinition.
	self name: (baseClass name, ' classTrait') asSymbol! !

!RGMetatraitDefinition class methodsFor: 'class initialization' stamp: 'nil'!
class: anORTraitDefinition

	^self new
		baseClass: anORTraitDefinition;
		yourself! !

!RGMetatraitDefinitionTest commentStamp: ''!
SUnit tests for Ring classtrait definitions!
!RGMetatraitDefinitionTest methodsFor: 'testing' stamp: ''!
testAsClassTraitfinition
	| rgCTrait cTrait |
	cTrait := TSortable classTrait.
	rgCTrait := cTrait asRingDefinition.
	self assert: rgCTrait isRingObject.
	self assert: rgCTrait isTrait.
	self assert: rgCTrait name identicalTo: #'TSortable classTrait'.
	self assert: rgCTrait category identicalTo: cTrait category.
	self assert: rgCTrait classSide identicalTo: rgCTrait! !

!RGMethod commentStamp: ''!
RG2Method is a concrete representation of methods. It can be used to build browser for methods that are not in the image. It is polymorphic with CompiledMethod. 

* We can ask a RG2Method for its selector using the selector message.
Example:
	(Point>>#dist:) asRing2Definition selector
		-> #dist

We can also ask the ring object representation of its class or the Smalltalk class actually implementing the corresponding compiledMethod. 

* To access the ring class definition name, use parentName
	aRG2MethodDefinition parentName
	
Example:
	(Point>>#dist:) asRing2Definition parentName
		->  #Point
		
* If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent
	aRG2MethodDefinition parent
	
Example:
	aRG2MethodDefinition(Point>>#dist:) parent
		->  aRG2ClassDefinition(Point)
		
* If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realParent
	aRG2MethodDefinition realParent
	
Example:
	(Point>>#dist:) asRing2Definition realParent
		->  Point
		

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


* The message class returns the class of the object :).

Example:
	(Point>>#dist:) asRing2Definition class
		->  RingMethodDefinition
		
* The message className returns the name of the ring class defining the reingMethodDefinition.

Example:
	(Point>>#dist:) asRing2Definition className
		->  #Point		
		
* If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent
	aRG2MethodDefinition ringClass
	
Example:
	aRG2MethodDefinition(Point>>#dist:) ringClass
		->  aRG2ClassDefinition(Point)
		
		
* If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realClass
	aRG2MethodDefinition realClass
	
Example:
	(Point>>#dist:) asRing2Definition realClass
		->  Point

!
!RGMethod methodsFor: 'testing' stamp: ''!
isMetaSide

	^ self parent isMeta! !

!RGMethod methodsFor: 'queries - class' stamp: ''!
methodClass

	^ self parent! !

!RGMethod methodsFor: 'accessing' stamp: ''!
sourceCodeForNoSource

	^ self selector asMethodPreamble, String cr, String tab, '"source code for the method model not set"'! !

!RGMethod methodsFor: 'private' stamp: ''!
changeProtocolDuring: aBlock

	| oldProtocol |
	
	oldProtocol := self protocol.
	aBlock value.
	self announce: (MethodRecategorized method: self oldProtocol: oldProtocol)! !

!RGMethod methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ self defaultClassStub! !

!RGMethod methodsFor: '*Ring-Monticello' stamp: ''!
asMCDefinition

	^ MCMethodDefinition 
		className: self parent instanceSide name
		classIsMeta: self parent isMeta
		selector: self name
		category: self protocol
		timeStamp: ''
		source: self sourceCode! !

!RGMethod methodsFor: 'accessing' stamp: ''!
numArgs
	^ self selector asString numArgs! !

!RGMethod methodsFor: 'private - backend interface' stamp: ''!
pvtPackage: anRGPackageDefinition

	self environment verifyOwnership: anRGPackageDefinition.

	^ package := anRGPackageDefinition! !

!RGMethod methodsFor: 'removing' stamp: ''!
removeFromSystem

	^ self parent removeLocalMethod: self! !

!RGMethod methodsFor: 'accessing' stamp: ''!
sourceCodeForNoSelector

	^ 'unresolvedMessage', String cr, String tab, '"source code for the method model not set"'! !

!RGMethod methodsFor: 'accessing' stamp: ''!
argumentNames		

	^ self ast argumentNames! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
sendNodes
	^self ast sendNodes! !

!RGMethod methodsFor: 'accessing' stamp: ''!
sourceCode: anObject

	"ATTENTION: There is no check here if the selector is changed!!"

	self backend forMethod setSourceCodeFor: self to: anObject asString
	"TODO: announcements"! !

!RGMethod methodsFor: '*Roassal3-UML' stamp: ''!
isTestMethod
	^ false! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
hasSelector: aSelector 
	"Answers true if the method refers to the selector"
	(self selector = aSelector) ifTrue: [ ^ true ].
	^ self sendsSelector: aSelector! !

!RGMethod methodsFor: 'accessing' stamp: ''!
isExtension
	"The receiver is an extension when is defined in a different package to the one of its parent"
	
	^ self parent package ~= self package! !

!RGMethod methodsFor: 'private' stamp: ''!
pvtSafeSourceCode

	| aStringOrUnresolved |
	aStringOrUnresolved := self pvtSourceCode. 
	^ aStringOrUnresolved isRingResolved
		ifFalse: [ 
			self pvtName isRingResolved 
				ifTrue: [ self sourceCodeForNoSource ]
				ifFalse: [ self sourceCodeForNoSelector ] ]
		ifTrue: [ aStringOrUnresolved value ]! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
hasPragmaNamed: aSymbol
	^ self pragmas anySatisfy: [ :pragma | pragma selector = aSymbol ]! !

!RGMethod methodsFor: 'private - backend interface' stamp: ''!
pvtCleanTags

	tags := self defaultTags.
		
	"TODO:Announce if not empty"
	
	! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
package: anRGPackage

	self backend forMethod setMethodPackageFor: self to: anRGPackage.
	self environment addPackage: anRGPackage.
	(self parent package = anRGPackage)
		ifFalse: [ self package addExtensionMethod: self ].
! !

!RGMethod methodsFor: 'private - backend interface' stamp: ''!
pvtPackage

	^ package value! !

!RGMethod methodsFor: 'accessing' stamp: ''!
parseTree

	^(RBParser 
		parseMethod: self sourceCode 
		onError: [ :msg :pos | ^ nil ]) methodClass: self methodClass.
! !

!RGMethod methodsFor: 'accessing' stamp: ''!
ast
	"Answer my AST with semantic analysis. See #parseTree."
	
	^ self propertyNamed: #ast ifAbsentPut: [ self parseTree doSemanticAnalysisIn: self methodClass ]

! !

!RGMethod methodsFor: 'private - backend interface' stamp: ''!
pvtTime

	^ time value! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
implementors

	^ #()! !

!RGMethod methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	sourceCode := self unresolvedValue: self defaultSourceCode.
	tags := self unresolvedValue: self defaultTags.	"tags must be set before package"
	package := self unresolvedValue: self parent package.
	author := self unresolvedValue: self defaultAuthor.
	time := self unresolvedValue: self defaultTime.
	! !

!RGMethod methodsFor: 'accessing' stamp: ''!
hasSourceCode

	^ self backend forMethod hasSourceCodeFor: self! !

!RGMethod methodsFor: 'accessing' stamp: ''!
selector
	"Retrieves the name of the method"

	^ self name asSymbol! !

!RGMethod methodsFor: 'private' stamp: ''!
astFromSource

	^ RBParser parseMethod: self sourceCode! !

!RGMethod methodsFor: 'private - backend interface' stamp: ''!
pvtTagWith: aSymbol
	
	tags isRingResolved ifFalse: [ 
		self pvtCleanTags  ].
	
	tags add: aSymbol.	
	! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
literalAt: anIndex

	^ self ast literals at: anIndex! !

!RGMethod methodsFor: 'private - backend interface' stamp: ''!
pvtAuthor

	^ author value! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
variableNodes
	^self ast variableNodes! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
cleanTags

	self changeProtocolDuring: [ 
		self cleanTagsWithoutAnnouncemnt ]! !

!RGMethod methodsFor: 'private' stamp: ''!
pvtTagsDo: aBlock

	^ tags value do: aBlock! !

!RGMethod methodsFor: 'resolving' stamp: ''!
makeResolved

	super makeResolved.
	
	sourceCode := self sourceCode markAsRingResolved.
	package := self package markAsRingResolved.	
	author := self author markAsRingResolved.	
	time := self time markAsRingResolved.	
	tags := self tags markAsRingResolved.! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
time: aDateAndTime

	self backend forBehavior setTimeFor: self to: aDateAndTime! !

!RGMethod methodsFor: 'default model values' stamp: ''!
defaultTags

	^ Set new! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
astForStylingInCalypso
	"this method simplified remote method styling. 
	Remote proxy will redefine it by building AST on client side"
	^self ast! !

!RGMethod methodsFor: 'accessing' stamp: ''!
compiledMethod
	^ self! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
package

	^ self backend forMethod methodPackageFor: self! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
tagWith: aSymbol 

	self changeProtocolDuring: [ 
		self backend forMethod tagMethod: self with: aSymbol.
		self parent addMethodTag: aSymbol.
	]
! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
cleanTagsWithoutAnnouncemnt 

	self backend forMethod cleanMethodTagsFor: self.! !

!RGMethod methodsFor: 'accessing' stamp: ''!
sourceCode

	^ self backend forMethod sourceCodeFor: self! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
hasSelector: selector specialSelectorIndex: specialOrNil

	^ self ast sentMessages includes: selector! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
pragmas

	^ self ast pragmas! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
readsSlot: aSlot
	| nodes |
	nodes := self ast instanceVariableNodes select: [:each | each isInstanceVariable].
	nodes := nodes reject: [ :node | node parent isAssignment and: [ node parent variable = node ] ].
	^ nodes anySatisfy: [ :node | node binding == aSlot ]! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
isInstalled 
	^ true! !

!RGMethod methodsFor: 'default model values' stamp: ''!
defaultAuthor

	^ ''! !

!RGMethod methodsFor: 'default model values' stamp: ''!
defaultSourceCode

	^ self sourceCodeForNoSelector! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
calypsoEnvironmentType
	^ClyMethod! !

!RGMethod methodsFor: 'printing' stamp: ''!
printOn: aStream 

	self parent name ifNotNil: [
		aStream nextPutAll: self parent name;
				  nextPutAll: '>>' ].
	aStream print: self selector! !

!RGMethod methodsFor: 'private' stamp: ''!
pvtSourceCode: anObject

	sourceCode := anObject! !

!RGMethod methodsFor: 'private' stamp: ''!
pvtSourceCode

	^ sourceCode ! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
tagsDo: aBlock

	self backend forMethod tagsForMethod: self do: aBlock! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
origin

	^ self parent! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
sendsSelector: aSymbol 	
	"Answer whether the method sends a particular selector"
	^ self messages includes: aSymbol! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
messages

	^ self ast sentMessages! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
writesSlot: aSlot
	self ast nodesDo: [ :node | 
		node isVariable and: [
			node parent isAssignment and: [  
				(node parent variable = node) and: [  
					node isInstanceVariable and: [
						(node binding ==  aSlot)
					 		ifTrue: [^true]]]]]]. 
	^false! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
protocol: aSymbol

	self cleanTagsWithoutAnnouncemnt.
	self tagWith: aSymbol.
	
	! !

!RGMethod methodsFor: 'accessing' stamp: ''!
fullName
	"Keeps a unique description for the receiver. As annotation to avoid converting each time is invoked"
	
	^ (self parent name, '>>#', self selector) asSymbol! !

!RGMethod methodsFor: 'private - backend interface' stamp: ''!
pvtUntagFrom: aSymbol
	
	(tags value includes: aSymbol)
		ifTrue: [ tags remove: aSymbol ].
	
	"TODO:Announce"
	
	! !

!RGMethod methodsFor: 'testing' stamp: ''!
isMethod

	^true! !

!RGMethod methodsFor: 'testing' stamp: ''!
isLiteralMethod
	"Ring methods does not know how to detect if they are literal"
	^ false! !

!RGMethod methodsFor: 'default model values' stamp: ''!
defaultTime

	^ DateAndTime new! !

!RGMethod methodsFor: 'private - backend interface' stamp: ''!
pvtTime: aDateAndTime

	^ time := aDateAndTime! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
author

	^ self backend forBehavior authorFor: self! !

!RGMethod methodsFor: 'testing' stamp: ''!
isFromTrait
	^ self parent isTrait! !

!RGMethod methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.

	sourceCode := self unresolvedValue: self defaultSourceCode.
	tags := self unresolvedValue: self defaultTags.	
	package := self unresolvedValue: self parent package.
	author := self unresolvedValue: self defaultAuthor.
	time := self unresolvedValue: self defaultTime.
	! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
time

	^ self backend forBehavior timeFor: self! !

!RGMethod methodsFor: 'backward compatibility' stamp: ''!
category

	^ self protocol! !

!RGMethod methodsFor: 'accessing - model' stamp: ''!
tags

	| allTags |
	allTags := IdentitySet new.
	self tagsDo: [ :each | allTags add: each].
	^ allTags asArray
! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
author: aString

	self backend forBehavior setAuthorFor: self to: aString! !

!RGMethod methodsFor: 'queries - tags' stamp: ''!
isTaggedWith: aSymbol

	^self tags includes: aSymbol ! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
untagFrom: aSymbol

	self backend forMethod untagMethod: self from: aSymbol! !

!RGMethod methodsFor: 'accessing - backend' stamp: ''!
protocol

	| methodTags |
	
	methodTags := self tags.
	^	methodTags
		ifEmpty: [  self class asYetUnclassifiedProtocolName]
		ifNotEmpty: [ methodTags sorted first ]
! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
writesRef: literalAssociation 
	"Answer whether the receiver stores into the argument."
	self ast nodesDo: [ :node | 
		node isVariable and: [
			node parent isAssignment and: [  
				(node parent variable = node) and: [  
					(node binding =  literalAssociation)
					 		ifTrue: [^true]]]]]. 
	^false! !

!RGMethod methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	super addoptToParentStub.
	self environment backend createUnresolvedClassGroupFor: self parent.
	self parent pvtAddLocalMethod: self.
	
	
! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
readsRef: literalAssociation 
	"Answer whether the receiver loads the argument."
	^ self ast allChildren anySatisfy: [:each | 
		each isVariable and: [ each name = literalAssociation key ]]
	
	"self ast nodesDo: [ :node | 
		node isVariable and: [
			node parent isAssignment not and: [  
				(node binding =  literalAssociation)
					 		ifTrue: [^true]]]]. 
	^false"! !

!RGMethod methodsFor: '*Calypso-Ring' stamp: ''!
isDefinedInPackage: aPackage

	^ self package = aPackage! !

!RGMethod methodsFor: 'private - backend interface' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#sourceCode -> sourceCode. 
		#package -> package. 
		#author -> author. 
		#time -> time. 
		#tags -> tags. 
	}
	
	! !

!RGMethod methodsFor: 'private - backend interface' stamp: ''!
pvtAuthor: aString

	^ author := aString! !

!RGMethodDefinition commentStamp: ''!
RGMethodDefinition is a concrete representation of methods. It can be used to build browser for methods that are not in the image. It is polymorphic with CompiledMethod. 

* We can ask a RGMethodDefinition for its selector using the selector message.
Example:
	(Point>>#dist:) asRingDefinition selector
		-> #dist

We can also ask the ring object representation of its class or the Smalltalk class actually implementing the corresponding compiledMethod. 

* 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
		

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


* The message class returns 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

!
!RGMethodDefinition methodsFor: 'type of methods' stamp: 'nil'!
fromActiveToPassive
	"If the receiver was generated as an active method, it can be converted to a passive one by reading the data of the compiled method (if exists)"

	| compiledMethod |
	self isActive
		ifFalse: [ ^ self ].
	compiledMethod := self compiledMethod.
	compiledMethod notNil
		ifTrue: [ 
			self protocol: compiledMethod category.
			self sourceCode: compiledMethod sourceCode.
			self stamp: compiledMethod timeStamp ].
	self asPassive! !

!RGMethodDefinition methodsFor: 'testing - SUnit-support' stamp: 'nil'!
isErrorTest
	"Is the receiver a test method that raised an error?"

	^ self methodClass isTestCase
		and: [ self methodClass methodRaisedError: self selector ]! !

!RGMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isDefined
	"Answer whether the receiver exists in the environment"
	
	| rClass |
	self selector isDoIt ifTrue:[ ^false ].
	rClass := self realClass.
	^rClass notNil and: [ rClass includesSelector: self selector ]! !

!RGMethodDefinition methodsFor: 'comparing' stamp: 'nil'!
hash

	^super hash bitXor: self selector hash! !

!RGMethodDefinition methodsFor: 'backward compatibility' stamp: 'nil'!
methodClass
	"Return the class to which the receiver belongs to."
	
	^ self realClass! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
numArgs
	^ self selector asString numArgs! !

!RGMethodDefinition methodsFor: 'source pointers' stamp: 'nil'!
protocolAtPointer

	"A RGMethodDefinition that was set as historical will retrieve the protocol using the sourcePointer"

	^ self sourcePointer notNil
		ifTrue: [ SourceFiles protocolAt: self sourcePointer ]
		ifFalse:[ nil ]! !

!RGMethodDefinition methodsFor: 'operations' stamp: 'nil'!
recompile
	self method recompile! !

!RGMethodDefinition methodsFor: 'traits' stamp: 'nil'!
argumentNames
	"Return an array with the argument names of the method's selector"

	self isActive
		ifTrue: [ ^ self compiledMethod argumentNames ].
	^ self ast ifNotNil:[:ast | ast arguments collect:  [:each | each name] ]! !

!RGMethodDefinition methodsFor: 'type of methods' stamp: 'nil'!
isPassive

	"A ring method isPassive when it retrieves the data that was assigned in its creation.
	By default is passive"
	^(self annotationNamed: self class statusKey) 
		ifNil:[ true ] 
		ifNotNil:[ :status| status == #passive ]! !

!RGMethodDefinition methodsFor: 'testing - SUnit-support' stamp: 'nil'!
isTestMethod

	^ self methodClass isTestCase and: [ self selector isTestSelector ]! !

!RGMethodDefinition methodsFor: 'literals' stamp: 'nil'!
literals
	
	"bad code but I do not know how to properly retrieve the good compiled method using a RGMethodDefinition"


	^ self compiledMethod literals.! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
sourceCode: anObject

	sourceCode := anObject! !

!RGMethodDefinition methodsFor: 'type of methods' stamp: 'nil'!
asActive

	"Sets the receiver as active object, which will allow itself to retrieve its data from the compiled method"
	self annotationNamed: self class statusKey put: #active! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
isExtension
	"The receiver is an extension when is defined in a different package to the one of its parent.
	Ring allows to set this property. If not assigned tries to find its value "
	
	^self 
		annotationNamed: self class isExtensionKey
		ifAbsent: [  
			(self parent notNil and:[ self package notNil ])
				ifTrue: [ | value |
					       value :=  self parent package ~= self package.
						 self annotationNamed: self class isExtensionKey put: value.
						 value ]
				ifFalse: [ self protocol ifNil:[ false ] ifNotNil:[ :prot|  prot beginsWith: '*' ] ] ]! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
package: aRGPackage

	package:= aRGPackage! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
ast
	self isActive
		ifTrue: [ ^ self compiledMethod ast ].
	^  self sourceCode ifNotNil: [ ^ self astFromSource ]! !

!RGMethodDefinition methodsFor: 'to remove as soon as possible' stamp: 'nil'!
classIsMeta

	^self isMetaSide! !

!RGMethodDefinition methodsFor: 'type of methods' stamp: 'nil'!
isActive

	"A ring method isActive when it needs to access the compiledMethod for retrieving its data"
	^(self annotationNamed: self class statusKey) 
		ifNil:[ false ] 
		ifNotNil:[ :status| status == #active ]! !

!RGMethodDefinition methodsFor: 'testing - SUnit-support' stamp: 'nil'!
isPassedTest
	"Is the receiver a test method that passed?"

	^ self methodClass isTestCase
		and: [ self methodClass methodPassed: self selector ]! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
selector
	"Retrieves the name of the method"

	^name! !

!RGMethodDefinition methodsFor: 'private' stamp: 'nil'!
astFromSource
	^ RBParser parseMethod: self sourceCode! !

!RGMethodDefinition methodsFor: 'traits' stamp: 'nil'!
isBinarySelector
	^self selector
		allSatisfy: [:each | each isSpecial]! !

!RGMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isSameRevisionAs: aRGMethodDefinition
	"This method look for equality of the properties of the receiver"
	"Stamp is ignored as in many cases a method is saved without containing any change. However it appears as changed due to a different stamp"
	self flag: 'needs to be evaluated'.

	^(super isSameRevisionAs: aRGMethodDefinition)
		and: [ self selector = aRGMethodDefinition selector 
			and: [ self protocol = aRGMethodDefinition protocol
				and: [ self sourceCode = aRGMethodDefinition sourceCode ] ] ]! !

!RGMethodDefinition methodsFor: 'source pointers' stamp: 'nil'!
sourceCodeAtPointer

	"A RGMethodDefinition that was set as historical will retrieve the sourceCode using the sourcePointer"

	^ self sourcePointer notNil
		ifTrue: [ SourceFiles sourceCodeAt: self sourcePointer ]
		ifFalse:[ nil ]! !

!RGMethodDefinition methodsFor: '*Text-Core' stamp: ''!
asStringOrText

	| text |
	self realClass ifNil: [ ^self fullName ].
	text := (self fullName,' {', (self protocol ifNil: ['']), '} ') asText.
	self isLocalSelector
		ifFalse: [ text addAttribute: TextEmphasis italic ].
	^ text! !

!RGMethodDefinition methodsFor: 'managing container' stamp: 'nil'!
removeFromContainer: aRGContainer

	aRGContainer removeMethod: self! !

!RGMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isOverridden
	self isActive
		ifTrue: [ ^ self compiledMethod isOverridden ].
	^ false! !

!RGMethodDefinition methodsFor: 'stamp values' stamp: 'nil'!
timeStamp: aTimestamp 

	self annotationNamed: self class timeStampKey put: aTimestamp ! !

!RGMethodDefinition methodsFor: '*Tool-Base' stamp: ''!
browse

	^ Smalltalk tools browser
		openOnClass: self realClass 
		selector: (self isDefined ifTrue: [ self selector ] ifFalse: [ nil ])! !

!RGMethodDefinition methodsFor: '*Reflectivity' stamp: ''!
installLink: aMetaLink 
	self compiledMethod installLink: aMetaLink ! !

!RGMethodDefinition methodsFor: '*Reflectivity' stamp: ''!
variableNodes
	^self compiledMethod variableNodes.! !

!RGMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isAbstract
	self isActive
		ifTrue: [ ^ self compiledMethod isAbstract ].
	^ false! !

!RGMethodDefinition methodsFor: 'testing - SUnit-support' stamp: 'nil'!
isFailedTest
	"Is the receiver a test method that failed?"

	^ self methodClass isTestCase
		and: [ self methodClass methodFailed: self selector ]! !

!RGMethodDefinition methodsFor: '*Reflectivity' stamp: ''!
invalidate
	self compiledMethod invalidate! !

!RGMethodDefinition methodsFor: '*Refactoring-Changes' stamp: ''!
nameToDisplay

	^ self printString! !

!RGMethodDefinition methodsFor: '*Renraku' stamp: ''!
critiques
	^ self compiledMethod critiques! !

!RGMethodDefinition methodsFor: 'source pointers' stamp: 'nil'!
sourcePointer: aNumber

	self annotationNamed:  self class sourcePointerKey put: aNumber ! !

!RGMethodDefinition methodsFor: '*NewTools-MethodBrowsers' stamp: ''!
displayName

	^ String streamContents: [ :aStream | 
		self parentName 
			ifNotNil: [ aStream << self parentName << '>>' ].
		aStream print: self selector ]! !

!RGMethodDefinition methodsFor: 'managing container' stamp: 'nil'!
addInContainer: aRGContainer

	aRGContainer addMethod: self
	! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
compiledMethod
	"Retrieves the compiled method of this definition if exists"
	
	| rClass |
	(rClass := self realClass) notNil
		ifTrue: [ (rClass includesSelector: self selector)
			ifTrue: [ ^rClass >> self selector ] ].
			
	^nil! !

!RGMethodDefinition methodsFor: 'type of methods' stamp: 'nil'!
asHistorical

	"Sets the receiver as historical object, which will allow itself to retrieve its data using the sourcePointer"
	self annotationNamed: self class statusKey put: #historical.
	self sourcePointer ifNil:[ | pointer compiledMethod |
		pointer := 0.
		compiledMethod := self compiledMethod.
		compiledMethod notNil ifTrue: [
			pointer := compiledMethod sourcePointer ].
		pointer isZero
			ifFalse:[ self sourcePointer: pointer ] ]! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
package
	"Retrieves the package in which this class is contained, if exists"
	
	^package! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
sourceCode

	self isActive 
		ifTrue: [ ^ self compiledMethod ifNil:[ sourceCode ] ifNotNil: [ self compiledMethod sourceCode ]].
	self isHistorical
		ifTrue: [ ^ self sourceCodeAtPointer ifNil:[ self compiledMethod ifNil:[ sourceCode ] ifNotNil:[ :cm| cm sourceCode ] ] ].	
	^ sourceCode! !

!RGMethodDefinition methodsFor: 'source pointers' stamp: 'nil'!
sourcePointer
	"Retrieves the sourcePointer for this definition if exists"
	
	^ self isActive 
		ifTrue: [ self compiledMethod sourcePointer ]
		ifFalse: [ self annotationNamed: self class sourcePointerKey ]! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
stamp

	self isActive 
		ifTrue: [ ^ self compiledMethod timeStamp ].
	self isHistorical
		ifTrue: [ ^ self stampAtPointer ifNil:[ self compiledMethod ifNil:[ stamp ] ifNotNil:[ :cm| cm timeStamp ] ] ].
	^ stamp! !

!RGMethodDefinition methodsFor: '*Reflectivity' stamp: ''!
createTwin
	self compiledMethod createTwin! !

!RGMethodDefinition methodsFor: 'comparing' stamp: 'nil'!
= aRGMethodDefinition
	"This method look for equality of the key properties of the receiver"


	^(super = aRGMethodDefinition)
		and: [ self selector == aRGMethodDefinition selector]! !

!RGMethodDefinition methodsFor: 'stamp values' stamp: 'nil'!
timeStamp 

	^self annotationNamed: self class timeStampKey 
		ifAbsentPut: [ self class 
							parseTimestampFrom: self stamp 
							default: (DateAndTime epoch) ]! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
isExtension: aBoolean
	"Explicitily set that the receiver is an extension"
	
	self annotationNamed: self class isExtensionKey put: aBoolean ! !

!RGMethodDefinition methodsFor: 'testing' stamp: 'nil'!
containsHalt
	
	^ self method containsHalt! !

!RGMethodDefinition methodsFor: 'testing' stamp: 'nil'!
hasStamp

	^stamp isEmptyOrNil not! !

!RGMethodDefinition methodsFor: 'type of methods' stamp: 'nil'!
isHistorical

	"A ring method 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 ]! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
origin
	"Return the real oring of this method."
	^ self compiledMethod 
		ifNil: [ self methodClass ]
		ifNotNil: [ :compileMethod| compileMethod origin ]! !

!RGMethodDefinition methodsFor: '*Reflectivity' stamp: ''!
removeLink: aLink
	self compiledMethod removeLink: aLink! !

!RGMethodDefinition methodsFor: 'printing' stamp: 'nil'!
printOn: aStream 

	aStream print: self methodClass; nextPutAll: '>>'; print: self selector.! !

!RGMethodDefinition methodsFor: '*Monticello' stamp: 'nil'!
basicAsMCMethodDefinition
   "Creates a MCMethodDefinition from the receiver"
   
	^ self isActive 
		ifTrue: [ self asMCMethodDefinitionFromActiveDefinition ]
		ifFalse: [
		   ^ MCMethodDefinition
				className: self instanceSideParentName
		 	   	classIsMeta: self isMetaSide
				selector: self selector
				category: self protocol
				timeStamp: self stamp
				source: self sourceCode ]! !

!RGMethodDefinition methodsFor: 'backward compatibility' stamp: 'nil'!
messages
	self isActive
		ifTrue: [ ^ self method messages ].
	^ self ast ifNotNil: [ :ast | ast sentMessages ] ifNil: [ #() ]! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
protocol: anObject

	protocol := anObject! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
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 selector) asSymbol ]! !

!RGMethodDefinition methodsFor: 'type of methods' stamp: 'nil'!
fromActiveToHistorical
	"If the receiver was generated as an active method, it can be converted to a historical one by reading the data of the compiled method (if exists)"
	
	self isActive ifTrue: [
		self asHistorical ]! !

!RGMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isMethod

	^true! !

!RGMethodDefinition methodsFor: '*Monticello' stamp: 'nil'!
asMCMethodDefinition
   "Creates a MCMethodDefinition from the receiver"
	| cached |
	cached := MCMethodDefinition cachedDefinitions
		at: self compiledMethod
		ifAbsent: [ nil ].

	"we compare that the cached version is in sync with the version 
	the receiver represents because it is an identity structure and the container (here the method definition may have changed internally: different packages, protocol.... )"
	(cached notNil and: [ self sameAsMCDefinition: cached ]) ifFalse: [
		cached := self basicAsMCMethodDefinition.
		MCMethodDefinition cachedDefinitions 
			at: self compiledMethod 
			put: cached ].

	^ cached! !

!RGMethodDefinition methodsFor: 'source pointers' stamp: 'nil'!
getPreambleFrom: aFileStream at: position
	^ SourceFiles getPreambleFrom: aFileStream at: position! !

!RGMethodDefinition methodsFor: 'backward compatibility' stamp: 'nil'!
method

	^self compiledMethod! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
stamp: anObject
	"stores an author alias and a timestamp"
	
	stamp := anObject! !

!RGMethodDefinition methodsFor: 'backward compatibility' stamp: 'nil'!
symbolic

	^ self method symbolic! !

!RGMethodDefinition methodsFor: 'managing container' stamp: 'nil'!
isIncludedInContainer: aRGContainer

	^aRGContainer includesMethod: self! !

!RGMethodDefinition methodsFor: 'stamp values' stamp: 'nil'!
author 

	^self 
		annotationNamed: self class authorKey
		ifAbsentPut: [ self class parseAuthorAliasFrom: self stamp ]! !

!RGMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isFromTrait

	"Return true for methods that have been included from Traits"
	^ self origin isTrait and: [ self origin ~= self methodClass ]! !

!RGMethodDefinition methodsFor: 'metrics' stamp: 'nil'!
numberOfLinesOfCode

	^ self annotationNamed: #numberOfLinesOfCode ifAbsentPut: [ self sourceCode lineCount ]! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
symbolicBytecodes
	^self compiledMethod symbolicBytecodes! !

!RGMethodDefinition methodsFor: 'testing' stamp: 'nil'!
isLocalSelector
	"Answer whether the receiver exists in the environment as a local implementation"
	
	| rClass |
	rClass:= self realClass.
	^rClass notNil and: [ rClass includesLocalSelector: self selector ]! !

!RGMethodDefinition methodsFor: 'backward compatibility' stamp: 'nil'!
category

	^ self protocol! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
selector: aSymbol
	"The name of a method is known as #selector"

	name := aSymbol! !

!RGMethodDefinition methodsFor: 'stamp values' stamp: 'nil'!
author: aString 

	self annotationNamed: self class authorKey put: aString ! !

!RGMethodDefinition methodsFor: 'source pointers' stamp: 'nil'!
stampAtPointer	

	"A RGMethodDefinition that was set as historical will retrieve the stamp using the sourcePointer"

	^ self sourcePointer notNil
		ifTrue: [ SourceFiles timeStampAt: self sourcePointer ]
		ifFalse:[ nil ]! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
protocol

	self isActive 
		ifTrue: [ ^ self compiledMethod ifNil: [ protocol ] ifNotNil: [ self compiledMethod protocol ]].
	self isHistorical
		ifTrue: [ ^ self protocolAtPointer ifNil: [ self compiledMethod ifNil: [ protocol ] ifNotNil:[ :cm | cm protocol ] ] ].
	^ protocol			! !

!RGMethodDefinition methodsFor: '*Monticello' stamp: 'nil'!
asMCMethodDefinitionFromActiveDefinition
	"Creates a MCMethodDefinition from a source file assuming the current method isActive."

	| compiledMethod methodClass|
	compiledMethod := self compiledMethod.
	methodClass := compiledMethod methodClass.
	
   ^ MCMethodDefinition
		className: methodClass instanceSide name
 	   	classIsMeta: methodClass isMeta
		selector: compiledMethod selector
		category: compiledMethod category
		timeStamp: compiledMethod timeStamp
		source: compiledMethod sourceCode! !

!RGMethodDefinition methodsFor: 'accessing' stamp: 'nil'!
name
	"name ivar is used for selector, but the name of a method is Class>>selector"
	^self printString! !

!RGMethodDefinition methodsFor: '*Ring-Definitions-Monticello' stamp: 'nil'!
sameAsMCDefinition: anMCMethodDefinition
	^ anMCMethodDefinition selector = self selector
		and:
			[ 
			anMCMethodDefinition className = self className
				and:
					[ 
					anMCMethodDefinition classIsMeta = self isMetaSide
						and:
							[ 
							anMCMethodDefinition category = self protocol
								and: [ anMCMethodDefinition source = self sourceCode ] ] ] ]! !

!RGMethodDefinition methodsFor: 'to remove as soon as possible' stamp: 'nil'!
isValid
	"verifies that the receiver is locally defined in the class and that is not a DoIt"

	^self isDefined! !

!RGMethodDefinition methodsFor: 'type of methods' stamp: 'nil'!
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! !

!RGMethodDefinition methodsFor: '*Manifest-Core' stamp: ''!
storeOn: aStream
	aStream nextPut: $(.
	aStream nextPutAll: self class asString.
	aStream nextPutAll: ' className: '''.
	aStream nextPutAll: self parentName.
	aStream nextPutAll: ''' selector: '.
	aStream nextPutAll: self selector printString.
	aStream nextPutAll: ' isMetaSide: '.
	aStream nextPutAll: self isMetaSide printString.
	aStream nextPut: $)! !

!RGMethodDefinition methodsFor: 'comparing' stamp: 'nil'!
<= aRGMethodDefinition
	"Sort method definitions according to: 1. class name - 2. class comment - 3. method selector - 4. timestamp"

	self parentName < aRGMethodDefinition parentName ifTrue: [^true].
	self parentName > aRGMethodDefinition parentName ifTrue: [^false].

	self flag: 'This ugly test is needed right now because the old system is used to represent 
	class comment as method with Comment selector. And to mix comment and methods'.
	aRGMethodDefinition isComment ifTrue: [^false].
	
	^(self selector < aRGMethodDefinition selector) 
 		  or: [ (self selector == aRGMethodDefinition selector) and: [
    			  self timeStamp <= aRGMethodDefinition timeStamp ]]! !

!RGMethodDefinition methodsFor: '*Manifest-Core' stamp: ''!
arrayStringForManifest
	| array |
	array := Array new: 2.
	array at: 1 put: (self class asString asSymbol).
	array at: 2 put: {self parentName asSymbol. self selector asSymbol. self isMetaSide asString  asSymbol}.
	^ array! !

!RGMethodDefinition class methodsFor: 'instance creation' stamp: 'nil'!
class: aRGBehaviorDefinition selector: aString
	"Create a ring method definition from a ring class and a selector"

	^(self class: aRGBehaviorDefinition)
		selector: aString asSymbol;
		yourself! !

!RGMethodDefinition class methodsFor: 'elements-annotations' stamp: 'nil'!
isExtensionKey 

	^#isExtension! !

!RGMethodDefinition class methodsFor: 'instance creation' stamp: 'nil'!
realClass: aClass selector: aString
	"Creates a ring method definition from a Smalltalk class and a selector <compiledMethod>"

	^(aClass>>aString asSymbol) asActiveRingDefinition! !

!RGMethodDefinition class methodsFor: 'instance creation' stamp: 'nil'!
className: aString selector: aSelector isMetaSide: aBoolean

	^ (self class: (RGClassDefinition named: aString) selector: aSelector) isMetaSide: aBoolean; yourself! !

!RGMethodDefinition class methodsFor: 'categories' stamp: 'nil'!
unclassifiedProtocolName
	"Return the string labeling the unclassified protocol."

	^ 'as yet unclassified'! !

!RGMethodDefinition class methodsFor: '*Manifest-Core' stamp: ''!
manifestReadOn: aArray

 	^ self className: (aArray at: 1) 
		selector: (aArray at: 2)
		isMetaSide: ((aArray at: 3) = #true)! !

!RGMethodDefinitionTest commentStamp: ''!
SUnit tests for method definitions!
!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testSorting

	| rgMethod1 rgMethod2 |
	rgMethod1 := RGMethodDefinition realClass: RGInstanceVariableDefinition selector: #isInstanceVariable.
	rgMethod2 := RGMethodDefinition realClass: RGElementDefinition selector: #isMetaSide.
	self assert: rgMethod2 <= rgMethod1.
	
	rgMethod1 := RGMethodDefinition realClass: RGElementDefinition selector: #parentName.
	self assert: rgMethod2 <= rgMethod1. 
	! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testAsActive
	| newMethod |
	RGMethodDefinitionTest compileSilently: 'foo	^ ''first version''' classified: 'test'.
	newMethod := (RGMethodDefinitionTest >> #foo) asActiveRingDefinition.
	self assert: newMethod isActive.
	self assert: newMethod sourcePointer notNil.
	self assert: newMethod sourceCode equals: newMethod compiledMethod sourceCode.

	RGMethodDefinitionTest compileSilently: 'foo	^ ''second version''' classified: 'test'.
	self assert: newMethod sourceCode equals: newMethod compiledMethod sourceCode.

	newMethod := (Class >> #asRingDefinition) asActiveRingDefinition.
	newMethod fromActiveToPassive.
	self assert: newMethod isPassive.
	self assert: newMethod sourceCode equals: (Class >> #asRingDefinition) sourceCode.
	newMethod sourceCode: 'asRingDefinition   ^true'.
	self assert: newMethod sourceCode ~= (Class >> #asRingDefinition) sourceCode.

	newMethod := (Class >> #asRingDefinition) asActiveRingDefinition.
	newMethod fromActiveToHistorical.
	self assert: newMethod isHistorical.
	self assert: newMethod sourcePointer notNil! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testAsHistorical
	| firstVersion secondVersion |
	RGMethodDefinitionTest compileSilently: 'foo	^ ''first version''' classified: 'test'.
	firstVersion := (RGMethodDefinitionTest >> #foo) asHistoricalRingDefinition.
	self assert: firstVersion isHistorical.
	self assert: firstVersion sourceCode equals: firstVersion compiledMethod sourceCode.
	self assert: firstVersion stamp equals: firstVersion compiledMethod timeStamp.

	RGMethodDefinitionTest compileSilently: 'foo	^ ''second version''' classified: 'test'.
	secondVersion := (RGMethodDefinitionTest >> #foo) asHistoricalRingDefinition.
	self assert: secondVersion isHistorical.
	self assert: secondVersion sourceCode equals: secondVersion compiledMethod sourceCode.
	self assert: secondVersion stamp equals: secondVersion compiledMethod timeStamp.

	self deny: firstVersion sourcePointer equals: secondVersion sourcePointer.
	self deny: firstVersion sourceCode equals: secondVersion sourceCode! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testArgumentNamesNonExistingMethodWithSource
	"accessing ring methods arguments for passive ring definition created with source"

	| newMethod newClass source |
	source := 'class: aClass selector: aSelector
              "new passive method"'.
	newClass := RGClassDefinition named: #RGMethodDefinition.
	newMethod := (RGMethodDefinition named: #class:selector:) parent: newClass.
	newMethod sourceCode: source.
	self assert: newMethod isPassive.
	self assertCollection: newMethod argumentNames hasSameElements: #( #aClass #aSelector).
! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testAsMethodDefinition2
	| newMethod |
	newMethod := (Object >> #printOn:) asRingDefinition.
	self assert: newMethod protocol equals: 'printing'.

	newMethod := (TCloneTest >> #testCopyEmpty) asRingDefinition.
	self assert: newMethod protocol equals: 'tests - copy - clone'.

	newMethod := (ArrayTest >> #testCopyEmpty) asRingDefinition.
	self assert: newMethod protocol equals: 'tests - copy - clone'! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testMethodEquality
	| newMethod newClass |
	self assert: (OrderedCollection >> #size) asRingDefinition equals: (OrderedCollection >> #size) asRingDefinition.

	newMethod := (OrderedCollection >> #size) asRingDefinition
		sourceCode:
			'size
						^0'.
	self assert: (OrderedCollection >> #size) asRingDefinition equals: newMethod.

	newClass := RGClassDefinition named: #OrderedCollection.
	newMethod := (RGMethodDefinition named: #size) parent: newClass.
	self assert: (OrderedCollection >> #size) asRingDefinition equals: newMethod.

	newMethod := (RGMethodDefinition named: #size) parent: SortedCollection asRingDefinition.
	self deny: (OrderedCollection >> #size) asRingDefinition equals: newMethod! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testClassNameSelectorIsMetaSide
	| rg |
	rg := RGMethodDefinition className: 'Point' selector: #x isMetaSide: false.
	self assert: rg parentName equals: 'Point'.
	self assert: (rg parent isKindOf: RGClassDefinition).
	self assert: rg selector equals: #x.
	self assert: rg isMetaSide not! !

!RGMethodDefinitionTest methodsFor: '*Manifest-Tests' stamp: ''!
testManifestReadOn
	| method |
	method := thisContext method.

 	self
		assert: (RGMethodDefinition manifestReadOn: {
			self class name asSymbol .
			method selector .
			#false })
		equals: method asRingDefinition! !

!RGMethodDefinitionTest methodsFor: '*Manifest-Tests' stamp: ''!
testReadFrom
	| st rg |
	rg := (Point >> #x) asRingDefinition.
	st := String
		streamContents: [ :s | 
			rg storeOn: s.
			s contents ].
	self assert: (Object readFrom: st) equals: rg! !

!RGMethodDefinitionTest methodsFor: '*Ring-Definitions-Tests-Monticello' stamp: ''!
testAsFullMethodDefinition
	| rgMethod |
	rgMethod := (Class >> #asRingDefinition) asRingDefinition.
	self assert: rgMethod parent isNil.
	self assert: rgMethod package isNil.

	"retrieves package information from protocol name (class extension)"
	rgMethod := (Class >> #asRingDefinition) asFullRingDefinition.
	self assert: rgMethod parent notNil.
	self assert: rgMethod parentName equals: #Class.
	self assert: rgMethod parent methods size equals: 1.
	self assert: rgMethod parent package name equals: #Kernel.
	self assert: rgMethod package notNil.
	self assert: rgMethod package name equals: #'Ring-Definitions-Core'.

	"retrieves package information from class package name "
	rgMethod := (Class >> #name) asFullRingDefinition.
	self assert: rgMethod parent notNil.
	self assert: rgMethod parentName equals: #Class.
	self assert: rgMethod parent methods size equals: 1.
	self assert: rgMethod parent package name equals: #Kernel.
	self assert: rgMethod package notNil.
	self assert: rgMethod package name equals: #Kernel! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testExistingMethodWithPointer
	| newMethod |
	newMethod := (OrderedCollection >> #size) asActiveRingDefinition.

	self assert: newMethod parent isNil.
	self assert: newMethod parentName identicalTo: #OrderedCollection.
	self assert: newMethod sourcePointer notNil.
	self assert: newMethod sourceCode notNil.
	self assert: newMethod protocol notNil.
	self assert: newMethod stamp notNil.
	self assert: newMethod isExtension not! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testArgumentNamesExistingMethod
	"accessing ring methods arguments from active method"

	| method |
	method := (RGMethodDefinition class >> #class:selector:) asRingDefinition.
	self assert: method isActive.
	self assertCollection: method argumentNames  hasSameElements: #(#aRGBehaviorDefinition #aString) ! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testMessagesExistingMethod
	"accessing ring sent messages for active method"

	| method |
	method := (RGMethodDefinition class >> #class:selector:) asRingDefinition.
	self assert: method isActive.
	self assert: method messages equals: method compiledMethod messages.! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testArgumentNamesNonExistingMethodWithNoSource
	"accessing ring methods arguments for passive ring definition created with source"

	| newMethod newClass |
	newClass := RGClassDefinition named: #RGMethodDefinition.
	newMethod := (RGMethodDefinition named: #foo:) parent: newClass.
	self assert: newMethod isPassive.
	self assert: newMethod argumentNames isNil.
! !

!RGMethodDefinitionTest methodsFor: 'running' stamp: ''!
tearDown

	self class removeSelectorSilently: #foo.
	self class removeProtocol: 'test'.
	super tearDown ! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testAsMethodDefinition
	| newMethod |
	newMethod := (OrderedCollection >> #size) asRingDefinition.

	self assert: newMethod isRingObject.
	self assert: newMethod parent isNil.
	self assert: newMethod isMethod.
	self assert: newMethod selector identicalTo: #size.
	self assert: newMethod protocol notNil.
	self assert: newMethod stamp notNil! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testASTExistingMethod
	"accessing ring methods ast from active method"

	| method |
	method := (RGMethodDefinition class >> #class:selector:) asRingDefinition.
	self assert: method isActive.
	self assert: method ast equals: method compiledMethod ast.! !

!RGMethodDefinitionTest methodsFor: '*Manifest-Tests' stamp: ''!
testStoreOn
	| st |
	st := String
		streamContents: [ :s | 
			(Point >> #x) asRingDefinition storeOn: s.
			s contents ].
	self assert: st equals: '(RGMethodDefinition className: ''Point'' selector: #x isMetaSide: false)'! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testASTNonExistingMethodWithSource
	"accessing ring methods ast for passive ring definition created with source"

	| newMethod newClass source |
	source := 'foo
   ^ self'.
	newClass := RGClassDefinition named: #RGMethodDefinition.
	newMethod := (RGMethodDefinition named: #foo) parent: newClass.
	newMethod sourceCode: source.
	self assert: newMethod isPassive.
	self assert: newMethod ast equals: (RBParser parseMethod: source)
! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testMessagesNonExistingMethodWithSource
	"accessing ring sent messages for passive method created with source"

	| newMethod newClass source |
	source := 'class: aClass selector: aSelector
              ^ self new; yourself'.
	newClass := RGClassDefinition named: #RGMethodDefinition.
	newMethod := (RGMethodDefinition named: #class:selector:) parent: newClass.
	newMethod sourceCode: source.
	self assert: newMethod isPassive.
	self assertCollection: newMethod messages hasSameElements: #( #new #yourself).
! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testASTNonExistingMethodWithNoSource
	"accessing ring methods ast for passive ring definition with no source"

	| newMethod newClass |
	newClass := RGClassDefinition named: #RGMethodDefinition.
	newMethod := (RGMethodDefinition named: #foo) parent: newClass.
	self assert: newMethod isPassive.
	self assert: newMethod ast isNil.! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testDifferentObjectButSameMethodInSet
	| s rgmethod rgmethod2 |
	s := Set new.
	rgmethod := (OrderedCollection >> #size) asRingDefinition.
	s add: rgmethod.
	rgmethod2 := (OrderedCollection >> #size) asRingDefinition.
	s add: rgmethod2.

	self assert: s size equals: 1.
	self assert: (s includes: rgmethod).
	self assert: (s includes: rgmethod2)! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testIsAbstractNonExistingMethod
	"testing non existing ring method isAbstract"

	| newMethod newClass |
	newClass := RGClassDefinition named: #RGMethodDefinition.
	newMethod := (RGMethodDefinition named: #foo:) parent: newClass.
	self assert: newMethod isPassive.
	self deny: newMethod isAbstract.
! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testNonExistingMethodWithClass
	"method does not exist in OrderedCollection"

	| newMethod newClass |
	newClass := RGClassDefinition named: #OrderedCollection.
	newClass withMetaclass.

	newMethod := (RGMethodDefinition named: #foo) parent: newClass classSide.
	newMethod
		sourceCode:
			'foo
									^true'.

	self assert: newMethod isMethod.
	self assert: newMethod selector identicalTo: #foo.
	self assert: newMethod isMetaSide.
	self assert: newMethod protocol equals: nil.

	self assert: newMethod parent equals: newClass classSide.
	self assert: newMethod parentName equals: newClass classSide name.

	self assert: newMethod environment identicalTo: Smalltalk globals.
	self assert: newMethod realClass equals: OrderedCollection class.
	self assert: newMethod compiledMethod isNil! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testSameMethodInSet
	| s rgmethod |
	s := Set new.
	rgmethod := (OrderedCollection >> #size) asRingDefinition.
	s add: rgmethod.
	self assert: (s includes: rgmethod).

	s add: rgmethod.
	self assert: s size equals: 1.
	self assert: (s includes: rgmethod)! !

!RGMethodDefinitionTest methodsFor: '*Manifest-Tests' stamp: ''!
testArrayStringForManifest
	| method |
	method := thisContext method.

 	self
		assert: method asRingDefinition arrayStringForManifest
		equals: { #RGMethodDefinition . { self class name asSymbol . method selector . #false } }! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testMessagesNonExistingMethodWithNoSource
	"accessing ring sent messages for passive method with no source"

	| newMethod newClass |
	newClass := RGClassDefinition named: #RGMethodDefinition.
	newMethod := (RGMethodDefinition named: #class:selector:) parent: newClass.
	self assert: newMethod isPassive.
	self assert: newMethod messages equals: #()
! !

!RGMethodDefinitionTest methodsFor: 'running' stamp: ''!
runCase

	SystemAnnouncer uniqueInstance suspendAllWhile: [ 
		Author useAuthor: self class name asString during: [ super runCase ]
	]
! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testExistingMethodWithClass
	| newMethod newClass |
	newClass := RGClassDefinition named: #OrderedCollection.
	newMethod := (RGMethodDefinition named: #add:)
		parent: newClass;
		protocol: 'adding';
		sourceCode:
			'add: newObject
									^self addLast: newObject'.

	self assert: newMethod isMethod.
	self assert: newMethod selector identicalTo: #add:.
	self assert: newMethod isMetaSide not.

	self assert: newMethod parent equals: newClass.
	self assert: newMethod parentName identicalTo: newClass name.

	self assert: newMethod parent parent identicalTo: Smalltalk globals.
	self assert: newMethod realClass equals: OrderedCollection.
	self assert: newMethod compiledMethod equals: (OrderedCollection compiledMethodAt: #add:)! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testAsPassive
	| newMethod |
	RGMethodDefinitionTest compileSilently: 'foo	^ ''first version''' classified: 'test'.
	newMethod := (RGMethodDefinitionTest >> #foo) asPassiveRingDefinition.
	self assert: newMethod isPassive.
	self assert: newMethod sourceCode equals: newMethod compiledMethod sourceCode.

	RGMethodDefinitionTest compileSilently: 'foo	^ ''second version''' classified: 'test'.
	self assert: newMethod sourceCode equals: 'foo	^ ''first version'''.
	self assert: newMethod compiledMethod sourceCode equals: 'foo	^ ''second version'''! !

!RGMethodDefinitionTest methodsFor: 'test - accessing source' stamp: ''!
testIsAbstractExistingMethod
	"testing existing ring method isAbstract"

	| method |
	method := (RGMethodDefinition class >> #class:selector:) asRingDefinition.
	self assert: method isActive.
	self deny: method isAbstract.! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testExtensionMethod
	| newMethod newClass newPackage newPackageExt |

	newMethod:= (RGMethodDefinition named: #+)
					isExtension: true.
	self assert: (newMethod protocol isNil).
	self assert: (newMethod isExtension).

	newMethod:= (Collection >> #+) asRingDefinition.	
	self assert: (newMethod isMethod).  
	self assert: newMethod protocol equals: '*Collections-arithmetic'.
	self assert: (newMethod isExtension).
	
	newPackage := RGPackageDefinition named: #Package.
	newPackageExt := RGPackageDefinition named:  #PackageExtensions.
	newClass := RGClassDefinition named: #Class.
	newMethod := (RGMethodDefinition named: #foo) parent: newClass.
	newPackage addClass: newClass.
	newMethod package: newPackageExt.
	self assert: (newMethod isExtension).! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testCreatingMethodsWithoutFactory
	| newMethod newClass |
	newMethod := RGMethodDefinition realClass: OrderedCollection selector: 'size'.
	self assert: newMethod isMethod.
	self assert: newMethod selector identicalTo: #size.
	self assert: newMethod protocol notNil.
	self assert: newMethod sourceCode notEmpty.
	self assert: newMethod stamp notNil.

	newClass := RGClassDefinition named: #OrderedCollection.
	newMethod := RGMethodDefinition class: newClass selector: 'size'.
	self assert: newMethod isMethod.
	self assert: newMethod selector identicalTo: #size.
	self assert: newMethod protocol isNil.
	self assert: newMethod sourceCode isNil.
	self assert: newMethod stamp isNil.

	newMethod := RGMethodDefinition realClass: OrderedCollection classSide selector: #arrayType.
	self assert: newMethod isMethod.
	self assert: newMethod selector identicalTo: #arrayType.
	self assert: newMethod protocol notNil.
	self assert: newMethod sourceCode notEmpty.
	self assert: newMethod stamp notNil! !

!RGMethodDefinitionTest methodsFor: 'testing' stamp: ''!
testExistingMethodWithoutClass
	"its parent class is not assigned only its name"

	| newMethod |
	newMethod := (RGMethodDefinition named: #add:)
		parentName: #OrderedCollection;
		selector: #add:;
		isMetaSide: false;
		protocol: 'adding';
		sourceCode:
			'add: newObject
									^self addLast: newObject'.

	self assert: newMethod isMethod.
	self assert: newMethod selector identicalTo: #add:.
	self assert: newMethod isMetaSide not.
	self assert: newMethod protocol equals: #adding.
	self assert: newMethod fullName equals: 'OrderedCollection>>add:'.
	self
		assert: newMethod sourceCode
		equals:
			'add: newObject
									^self addLast: newObject'.
	self assert: newMethod hasStamp not.
	self assert: newMethod parent isNil.
	self assert: newMethod parentName identicalTo: #OrderedCollection.

	self assert: newMethod environment identicalTo: Smalltalk globals.
	self assert: newMethod realClass equals: OrderedCollection.
	self assert: newMethod compiledMethod equals: (OrderedCollection compiledMethodAt: #add:)! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testNewMethod
	| method time |
	
	method := RGMethod unnamed.
	self assert: method isMethod. 
	
	self assert: (method isRingResolved).
	
	self assert: (method hasUnresolvedAll: #(name protocol sourceCode package author time)).


	self assert: (method hasUnresolvedAll: #(name sourceCode package author time)).
	self assert: method sourceCode lines first trimBoth equals: 'unresolvedMessage'.
	method sourceCode: 'someMessage ^ yourself'.
	self assert: (method hasUnresolvedAll: #(name package author time)).
	self assert: method sourceCode equals: 'someMessage ^ yourself'.

	self assert: method author equals: ''.
	method author: 'FullAuthorName'.
	self assert: (method hasUnresolvedAll: #(time name)).
	self assert: method author equals: 'FullAuthorName'.
	
	time := DateAndTime now.
	self assert: method time equals: DateAndTime new.
	method time: time.
	self assert: (method hasUnresolved: #name).
	self assert: method time equals: time.
! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testRemovePackage
	| method class |
	method := RGMethod unnamed.
	class := method parent.

	method package: (RGPackage named: 'SomePackage' parent: method environment).

	self assert: method parent package ~~ method package.
	self assert: method environment ask packages size equals: 3.

	method package: method parent package.	"return it"

	self assert: method parent package identicalTo: method package.
	self assert: method environment ask packages size equals: 3.

	method environment removeUnusedPackages.
	self assert: method environment ask packages size equals: 2! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testImplicitEnvironment
	
	| def def2 env |

	def := RGMethod unnamed.
	env := def environment.

	self checkImplicitSingleClassEnvironmentOf: def parent.	
	self assert: def parent localMethods size equals: 1.
	self assert: def parent protocols size equals: 1.
	self assert: (def parent hasResolved: #tagsForMethods).
	self assert: def parent tagsForMethods isEmpty.
	self assert: def parent protocols size equals: 1.
	self assert: def parent protocols anyOne equals: 'as yet unclassified'.

	self assert: (def isRingResolved).
	
	def2 := RGMethod named: #someMethod parent: def parent.
	def2 parent addLocalMethod: def2.
	self assert: def parent localSelectors sorted equals: #(someMethod unresolved).
	self checkImplicitSingleClassEnvironmentOf: def parent.	

	self assert: def parent protocols size equals: 1.
	self assert: def2 parent localMethods size equals: 2.
! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testPackages
	| method class |
	" implicit environment "
	method := RGMethod unnamed.

	self assert: method parent package identicalTo: method package.
	self assert: method environment ask packages size equals: 2.

	" adding to existing class definition "
	class := RGClass unnamed.
	method := RGMethod parent: class.
	class addLocalMethod: method.

	self assert: method parent package identicalTo: method package.
	self assert: method environment ask packages size equals: 2.

	" adding to existing class definition with package "
	class := RGClass unnamed.
	method := RGMethod parent: class.
	class addLocalMethod: method.
	method package: (RGPackage named: 'SomePackage' parent: method environment).

	self assert: method parent package ~~ method package.
	self assert: method environment ask packages size equals: 3! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGMethod unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testFullName
	
	| method |

	method := RGMethod named: #someMethod.
	method parent: (method environment ensureClassNamed: #SomeClass).
	self assert: method fullName equals: 'SomeClass>>#someMethod'.

	method parent metaclass makeResolved.
	method parent: method parent metaclass.
	self assert: method fullName equals: 'SomeClass class>>#someMethod'.	! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testAST
	
	| method ast |

	method := RGMethod named: #someMethod.
	ast := method ast.
	self assert: ast isMethod.
	self assert: ast selector equals: #someMethod.
	

	
	! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testSourceCode
	
	| method source |

	method := RGMethod named: #someMethod.
	self assert: method hasSourceCode.
	source := 'someMethod ^ self'.
	method sourceCode: source.
	self assert: method hasSourceCode.
	self assert: method sourceCode equals: source.
	self assert: method selector equals: #someMethod.
	self assert: method numArgs equals: 0.
	
	method := RGMethod named: #+.
	self assert: method numArgs equals: 1.
	method := RGMethod named: #someMethod:.
	self assert: method numArgs equals: 1.
	method := RGMethod named: #someMethod:arg:.
	self assert: method numArgs equals: 2.

	
	! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testMetaSide

	| anEnvironemnt aMethod |
	
	anEnvironemnt := RGEnvironment new.
	aMethod := (anEnvironemnt ensureClassNamed: 'SomeClass class') ensureLocalMethodNamed: #someMethod.
	self assert: aMethod isMetaSide.
	self deny: aMethod isFromTrait.
	aMethod := (anEnvironemnt ensureClassNamed: 'SomeClass') ensureLocalMethodNamed: #someMethod.
	self deny: aMethod isMetaSide.
	self deny: aMethod isFromTrait.
	aMethod := (anEnvironemnt ensureTraitNamed: 'SomeTrait classTrait') ensureLocalMethodNamed: #someMethod.
	self assert: aMethod isMetaSide.
	self assert: aMethod isFromTrait.
	aMethod := (anEnvironemnt ensureTraitNamed: 'SomeTrait') ensureLocalMethodNamed: #someMethod.
	self deny: aMethod isMetaSide.
	self assert: aMethod isFromTrait.

	! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testTagsCollection
	
	| method env tag1 tag2 tag3 |

	method := RGMethod unnamed.
	env := method environment.

	self assert: method tags isEmpty.
	self assert: (method hasUnresolved: #tags).
	
	tag1 := #tag1.
	method tagWith: #tag1.
	self assert: method tags size equals: 1.

	self assert: (method hasResolved: #tags).
	
	tag2 := #tag2.
	method tagWith: tag2.
	self assert: method tags size equals: 2.
	
	tag3 := #tag3.
	method tagWith: tag3.
	self assert: method tags size equals: 3.

	method untagFrom: tag3.
	self assert: method tags size equals: 2.

	method cleanTags.
	self assert: method tags isEmpty.
	self assert: (method hasResolved: #tags).
! !

!RGMethodTest methodsFor: 'tests' stamp: ''!
testNewNamedMethod

	| method |
	
	method := RGMethod named: #someMessage.
	
	self assert: (method isRingResolved).
	
	self assert: (method hasResolvedName).
	self assert: (method hasUnresolved: #sourceCode).

	self assert: method selector equals: 'someMessage'.
	self assert: method sourceCode lines first equals: 'someMessage'.

	self deny: method isMetaSide.
! !

!RGMonticelloTest commentStamp: ''!
SUnit tests for monticello!
!RGMonticelloTest methodsFor: 'testing' stamp: ''!
testConvertingMCMethodDefinition
	| mcMethod ringMethod |
	
	ringMethod := (OrderedCollection >> #add: ) asRingDefinition.
	mcMethod := ringMethod asMCMethodDefinition.
	
	self assert: (ringMethod isMethod).
	self assert: (ringMethod isSameRevisionAs: ((OrderedCollection >> #add: ) asRingDefinition)).
	self deny: (ringMethod isSameRevisionAs: ((OrderedCollection >> #addAll: ) asRingDefinition))! !

!RGMonticelloTest methodsFor: 'testing' stamp: ''!
testConvertingMCOrganizationDefinition
	| mcOrganization ringOrganization mcOrganization2 |
	
	mcOrganization := MCOrganizationDefinition categories: {#'Ring-Definitions-Core' . #'Ring-Definitions-Core-Definitions'}.
	mcOrganization2 := MCOrganizationDefinition categories: {#'Ring-Definitions-Core' . #'Ring-Definitions-Core-Definitions' . #'Ring-Definitions-Core-Variables'}.
	ringOrganization := mcOrganization asRingDefinition.
	
	self assert: (ringOrganization isOrganization).
	self deny: (ringOrganization isSameRevisionAs: mcOrganization2 asRingDefinition)! !

!RGMonticelloTest methodsFor: 'testing' stamp: ''!
testConvertingMCTraitDefinition
	| mcClass ringClass |
	mcClass := TSortable asClassDefinition.
	ringClass := mcClass asRingDefinition.

	self assert: ringClass isTrait.
	self assert: ringClass classSide realClass equals: TSortable classSide.
	self assert: (ringClass isSameRevisionAs: TSortable asRingDefinition).
	self deny: (ringClass isSameRevisionAs: TAssertable asRingDefinition)! !

!RGMonticelloTest methodsFor: 'testing' stamp: ''!
testConvertingMCClassDefinition
	| mcClass ringClass |
	mcClass := OrderedCollection asClassDefinition.
	ringClass := mcClass asRingDefinition.

	self assert: ringClass isClass.
	self assert: ringClass classSide realClass equals: OrderedCollection class.
	self assert: (ringClass isSameRevisionAs: OrderedCollection asRingDefinition).
	self deny: (ringClass isSameRevisionAs: SortedCollection asRingDefinition)! !

!RGMonticelloTest methodsFor: 'testing' stamp: ''!
testAsMCMethodDefinition
	| ringMethod mcMethod |
	ringMethod := (OrderedCollection >> #size) asActiveRingDefinition.
	mcMethod := ringMethod asMCMethodDefinition.

	self assert: ringMethod equals: mcMethod asRingDefinition.
	self assert: mcMethod className equals: #OrderedCollection.
	self deny: mcMethod classIsMeta.
	self assert: mcMethod selector equals: #size.
	self assert: mcMethod category equals: #accessing.
	self assert: mcMethod source equals: (OrderedCollection >> #size) sourceCode! !

!RGNamespace commentStamp: ''!
A namespace is a container that in addition to managing classes and methods, it also knows how to treat pools and global variables!
!RGNamespace methodsFor: 'adding' stamp: 'nil'!
addElement: anObject in: aCollection

	anObject environment: self.
	super addElement: anObject in: aCollection! !

!RGNamespace methodsFor: 'testing' stamp: 'nil'!
includesPool: anORPoolDefinition

	^self pools includes: anORPoolDefinition! !

!RGNamespace methodsFor: 'testing' stamp: 'nil'!
includesPoolNamed: poolName
	
	^self includesElementNamed: poolName in: self pools! !

!RGNamespace methodsFor: 'initialization' stamp: 'nil'!
initialize

	super initialize.
	self globalVariables: IdentityDictionary new.
	self pools: IdentityDictionary new.! !

!RGNamespace methodsFor: 'adding' stamp: 'nil'!
addPool: anORPoolDefinition
	"adds anORPoolDefinition to the pools dictionary if satisfies it #isPool"

	anORPoolDefinition isPool ifFalse:[ ^self ].
	self addElement: anORPoolDefinition in: self pools! !

!RGNamespace methodsFor: 'adding' stamp: 'nil'!
addPoolNamed: poolName
	"creates a RGPoolDefinition with the given name.
	It's verified that a pool with that name does not exist"
	| pool |

	(self includesPoolNamed: poolName) ifTrue: [ ^self ].
	"A shared pool is a class inheriting from #SharedPool"
	pool := (RGClassDefinition named: poolName)
			superclassName: #SharedPool;
			isPool: true;
			yourself.
	self addPool: pool.! !

!RGNamespace methodsFor: 'accessing - global variables' stamp: 'nil'!
globalVariables
	"retrieves global variables"

	^self elementsCategorized: #globalVariables! !

!RGNamespace methodsFor: 'accessing - global variables' stamp: 'nil'!
globalVariableNamed: globalVariableName

	^self elementNamed: globalVariableName in: self globalVariables! !

!RGNamespace methodsFor: 'accessing - pools' stamp: 'nil'!
pools: aCollection

	self elementsCategorized: #pools with: aCollection! !

!RGNamespace methodsFor: 'accessing - global variables' stamp: 'nil'!
globalVariables: aCollection

	self elementsCategorized: #globalVariables with: aCollection! !

!RGNamespace methodsFor: 'adding' stamp: 'nil'!
addGlobalVariable: anORGlobalVariableDefinition
	"adds anORGlobalVariableDefinition to the globals dictionary if satisfies it #isGlobalVariable"

	anORGlobalVariableDefinition isGlobalVariable ifFalse:[ ^self ].
	self addElement: anORGlobalVariableDefinition in: self globalVariables! !

!RGNamespace methodsFor: 'removing' stamp: 'nil'!
removePool: anORPoolDefinition
	"removes anORPoolDefinition from the pools dictionary if satisfies it #isPool"

	anORPoolDefinition isPool ifFalse:[ ^self ].
	self removeElement: anORPoolDefinition from: self pools! !

!RGNamespace methodsFor: 'removing' stamp: 'nil'!
withoutPools

	self removeElementsCategorized: #pools! !

!RGNamespace methodsFor: 'removing' stamp: 'nil'!
withoutGlobalVariables

	self removeElementsCategorized: #globalVariables! !

!RGNamespace methodsFor: 'adding' stamp: 'nil'!
addGlobalVariableNamed: globalVariableName
	"creates a RGGlobalVariableDefinition with the given name.
	It's verified that a pool with that name does not exist"

	(self includesGlobalVariableNamed: globalVariableName) ifTrue: [ ^self ].
	self addGlobalVariable: (RGGlobalVariableDefinition named: globalVariableName).! !

!RGNamespace methodsFor: 'testing' stamp: 'nil'!
isNamespace

	^true! !

!RGNamespace methodsFor: 'removing' stamp: 'nil'!
removeGlobalVariable: anORGlobalVariableDefinition
	"removes anORGlobalVariableDefinition from the globals dictionary if satisfies it #isGlobalVariable"

	anORGlobalVariableDefinition isGlobalVariable ifFalse:[ ^self ].
	self removeElement: anORGlobalVariableDefinition from: self globalVariables! !

!RGNamespace methodsFor: 'accessing - pools' stamp: 'nil'!
pools
	"retrieves the shares pools"

	^self elementsCategorized: #pools! !

!RGNamespace methodsFor: 'testing' stamp: 'nil'!
includesGlobalVariableNamed: globalVariableName
	
	^self includesElementNamed: globalVariableName in: self globalVariables! !

!RGNamespace methodsFor: 'accessing - pools' stamp: 'nil'!
poolNamed: poolName

	^self elementNamed: poolName in: self pools! !

!RGNamespace methodsFor: 'testing' stamp: 'nil'!
includesGlobalVariable: anORGlobalVariableDefinition

	^self globalVariables includes: anORGlobalVariableDefinition! !

!RGNamespaceTest commentStamp: ''!
SUnit tests for namespaces!
!RGNamespaceTest methodsFor: 'testing' stamp: ''!
testCreatingNamespace
	| newNamespace newPackage newClass |
	newNamespace := RGNamespace named: #RingNamespace.
	newPackage := RGPackageDefinition named: #'Collections-Sequenceable'.
	newClass := RGClassDefinition named: #OrderedCollection.
	newPackage addClass: newClass.
	newNamespace
		addPackage: newPackage;
		addClass: newClass.

	self assert: newNamespace isNamespace.
	self assert: (newNamespace packageNamed: #'Collections-Sequenceable') identicalTo: newPackage.
	self assert: (newNamespace classNamed: #OrderedCollection) identicalTo: newClass.
	self assertEmpty: newNamespace methods.
	self assertEmpty: newNamespace pools.
	self assertEmpty: newNamespace globalVariables.

	newNamespace removeClass: newClass.
	self assert: (newNamespace classNamed: #OrderedCollection) isNil.
	self assert: (newPackage classNamed: #OrderedCollection) notNil! !

!RGObject commentStamp: ''!
I am the root class of the Ring meta-model definitions.
A Ring definition has a name, properties and knows its environment!
!RGObject methodsFor: 'private - backend interface' stamp: ''!
pvtUnresolvedProperties

	^ self pvtResolvableProperties select: [:each | each value isRingResolved not ] thenCollect: #key! !

!RGObject methodsFor: 'managing container' stamp: ''!
defaultParentStub

	self subclassResponsibility! !

!RGObject methodsFor: 'resolving' stamp: ''!
resolvedProperties

	^ (self backend resolvedPropertiesFor: self)! !

!RGObject methodsFor: 'properties' stamp: ''!
propertyNamed: annotationName put: value 

	self properties
		at: annotationName
		put: value! !

!RGObject methodsFor: 'converting' stamp: ''!
unresolvedValue: aDefaultValue

	^ RGUnresolvedValue new
		default: aDefaultValue;
		yourself! !

!RGObject methodsFor: 'properties' stamp: ''!
propertyNamed: annotationName ifAbsentPut: blockValue 

	^ self properties
		at: annotationName
		ifAbsentPut: blockValue! !

!RGObject methodsFor: 'accessing' stamp: ''!
environment
	
	^ self propertyNamed: #environment ifAbsent: [ self parent environment ].! !

!RGObject methodsFor: 'testing' stamp: ''!
isRingResolved

	^ self propertyNamed: #resolved ifAbsent: [ true ]! !

!RGObject methodsFor: 'hierarchy - defaults' stamp: ''!
defaultFixedLayoutStubIn: anRGBehavior

	^ RGFixedLayout unresolved
		parent: anRGBehavior;
		yourself.! !

!RGObject methodsFor: 'accessing' stamp: ''!
unresolveName

	| oldName result |
	
	oldName := name.
	result := self unresolvedValue: self unresolvedName.
	self pvtName: result.
	self parent child: self renamedFrom: oldName to: result value.
	^ result! !

!RGObject methodsFor: 'announcements' stamp: ''!
announce: anAnnouncement

	self environment announcer announce: anAnnouncement! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isTraitAlias

	^ false! !

!RGObject methodsFor: 'private - backend interface' stamp: ''!
pvtFullyResolved

	^ (self pvtResolvableProperties collect: [:each | each value]) allSatisfy: [:each | each isRingFullyResolved]! !

!RGObject methodsFor: 'hierarchy - defaults' stamp: ''!
defaultCommentStubIn: anRGBehavior

	^ RGComment unresolved
		parent: anRGBehavior;
		yourself.! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isPackage

	^false! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isProtocol

	^false! !

!RGObject methodsFor: 'properties' stamp: ''!
propertyNamed: propertyName 
	
	^ self
		propertyNamed: propertyName
		ifAbsent: [ nil ]! !

!RGObject methodsFor: 'resolving' stamp: ''!
hasResolved: propertySymbol

	^ self resolvedProperties includes: propertySymbol


! !

!RGObject methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	name := self unresolvedValue: self unresolvedName.

! !

!RGObject methodsFor: 'resolving' stamp: ''!
markAsRingResolved

	self propertyNamed: #resolved put: true.
	! !

!RGObject methodsFor: 'hierarchy - defaults' stamp: ''!
defaultClassStub

	^ RGClass unresolved! !

!RGObject methodsFor: 'hierarchy - defaults' stamp: ''!
defaultFixedLayoutStub

	^ RGFixedLayout unresolved! !

!RGObject methodsFor: 'copying' stamp: ''!
postCopy

	super postCopy.
	
	properties := properties copy.! !

!RGObject methodsFor: 'private - backend interface' stamp: ''!
pvtName: aString

	 name := aString! !

!RGObject methodsFor: 'private - backend interface' stamp: ''!
pvtResolvedProperties

	^ self pvtResolvableProperties select: [:each | each value isRingResolved ] thenCollect: #key! !

!RGObject methodsFor: 'properties' stamp: ''!
copyPropertiesFrom: anRGObject

	properties := anRGObject properties copy.! !

!RGObject methodsFor: 'resolving' stamp: ''!
hasUnresolvedAll: aCollectionOfSymbols

	^ (self resolvedProperties includesAll: aCollectionOfSymbols) not


! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isLayout

	^false! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isVariable

	"is the definition a variable class?"

	^ false! !

!RGObject methodsFor: 'resolving' stamp: ''!
unresolvedProperties

	^ (self backend unresolvedPropertiesFor: self)! !

!RGObject methodsFor: 'resolving' stamp: ''!
isRingFullyUnresolved		
	
	^ self backend hasFullyUnresolved: self 		

! !

!RGObject methodsFor: 'resolving' stamp: ''!
makeResolved

	self markAsRingResolved.
	
	name := self name markAsRingResolved.! !

!RGObject methodsFor: 'properties' stamp: ''!
removePropertyNamed: propertyName

	(self hasProperty: propertyName) ifTrue: [ 
		properties removeKey: propertyName ]! !

!RGObject methodsFor: 'accessing' stamp: ''!
package

	^ self parent package! !

!RGObject methodsFor: 'testing' stamp: ''!
hasResolvedName		
	
	^ self hasResolved: #name! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isMetaclassTrait

	^ false! !

!RGObject methodsFor: 'private' stamp: ''!
pvtParent: anRGObject

	parent := anRGObject.! !

!RGObject methodsFor: 'converting' stamp: ''!
unresolvedValue

	^ RGUnresolvedValue new.! !

!RGObject methodsFor: 'hierarchy - defaults' stamp: ''!
defaultPackageStubIn: anRGEnvironment

	^ RGPackage unresolved
		parent: anRGEnvironment;
		yourself.! !

!RGObject methodsFor: 'copying' stamp: ''!
fullCopy

	^ self copy.! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isTraitTransformation

	^ false! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isTraitComposition

	^ false! !

!RGObject methodsFor: 'resolving' stamp: ''!
hasUnresolved: propertySymbol

	^ (self resolvedProperties includes: propertySymbol) not


! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isTraitExclusion

	^ false! !

!RGObject methodsFor: 'accessing' stamp: ''!
resolvedNameOrNil

	^ self hasResolvedName
		ifTrue: [ self name. ]
		ifFalse: [ nil ].		! !

!RGObject methodsFor: 'hierarchy - defaults' stamp: ''!
defaultTraitCompositionStub

	^ RGTraitComposition unresolved! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isMetaclass

	^ false! !

!RGObject methodsFor: 'copying' stamp: ''!
copyForBehaviorDefinition

	"returns copy of the behavior model that contains only information related to the behavior 
	definition"
	^ self shallowCopy copyForBehaviorDefinitionPostCopy! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isSlot

	^ false! !

!RGObject methodsFor: 'accessing' stamp: ''!
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 ifNil: [ 
		self parent: self defaultParentStub.
		self addoptToParentStub ].
	
	^ parent.! !

!RGObject methodsFor: 'testing' stamp: ''!
isRGObject

	^true! !

!RGObject methodsFor: 'accessing' stamp: ''!
name: aString

	| oldName |
	
	oldName := name.
	self backend setNameFor: self to: aString.
	self parent child: self renamedFrom: oldName to: aString.
! !

!RGObject methodsFor: 'accessing' stamp: ''!
parent: anRGBehavior

	"If possible, do not use this method directly."

	parent := anRGBehavior.
	"self addoptToParentStub."

	! !

!RGObject methodsFor: 'accessing' stamp: ''!
ask

	^ self ! !

!RGObject methodsFor: 'private - backend interface' stamp: ''!
pvtFullyUnresolved		
		
	^ (self pvtResolvableProperties collect: [:each | each value]) noneSatisfy: [:each | each isRingFullyResolved ]! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isEnvironment

	^false! !

!RGObject methodsFor: 'events' stamp: ''!
child: aChildDefinition renamedFrom: oldName to: newName

	"react on renaming of a child definition. By default do nothing"! !

!RGObject methodsFor: 'accessing' stamp: ''!
fullName

	^self name! !

!RGObject methodsFor: 'properties' stamp: ''!
hasProperty: propertyName

	^ self hasProperties
		ifTrue: [ properties includesKey: propertyName ]	
		ifFalse:[ false ].
! !

!RGObject methodsFor: 'properties' stamp: ''!
hasProperties

	^ properties isEmptyOrNil not! !

!RGObject methodsFor: 'defaults' stamp: ''!
unresolvedName

	^ #unresolved! !

!RGObject methodsFor: 'announcements' stamp: ''!
announcer

	^ self environment announcer! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isComment

	^false! !

!RGObject methodsFor: 'resolving' stamp: ''!
hasResolvedAll: aCollectionOfSymbols

	^ self resolvedProperties includesAll: aCollectionOfSymbols


! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isMethod

	^false! !

!RGObject methodsFor: 'properties' stamp: ''!
propertyNames
	
	self hasProperties
		ifFalse:[ ^ OrderedCollection new ].
	^ properties keys! !

!RGObject methodsFor: 'accessing' stamp: ''!
backend
	
	^ self environment backend! !

!RGObject methodsFor: 'resolving' stamp: ''!
isRingFullyResolved

	^ self backend hasFullyResolved: self! !

!RGObject methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	self propertyNamed: #resolved put: false. 
	name := self unresolvedValue: self unresolvedName.
	

! !

!RGObject methodsFor: 'copying' stamp: ''!
copyWithParent: newParent

	"create copy of the definition and then assign the new parent"
	
	^ self copy 
		parent: newParent;
		yourself.! !

!RGObject methodsFor: 'hierarchy - defaults' stamp: ''!
defaultTraitCompositionStubIn: anRGBehavior

	^ RGTraitComposition unresolved
		parent: anRGBehavior;
		yourself.! !

!RGObject methodsFor: 'converting' stamp: ''!
asRGDefinition

	^ self! !

!RGObject methodsFor: 'testing' stamp: ''!
isMeta

	^ false! !

!RGObject methodsFor: 'accessing' stamp: ''!
name

	^ (self backend nameFor: self) orDefaultForUnresolved ! !

!RGObject methodsFor: 'properties' stamp: ''!
properties

	^ properties ifNil: [ properties := IdentityDictionary new ]! !

!RGObject methodsFor: 'managing container' stamp: ''!
addoptToParentStub! !

!RGObject methodsFor: 'hierarchy - defaults' stamp: ''!
defaultEnvironmentStub

	^ RGEnvironment unresolved! !

!RGObject methodsFor: 'copying' stamp: ''!
copyForBehaviorDefinitionPostCopy
	super postCopy
	
	
	! !

!RGObject methodsFor: 'testing - types' stamp: ''!
isGlobalVariable

	^false! !

!RGObject methodsFor: 'private - backend interface' stamp: ''!
pvtResolvableProperties

	^ { #name -> name }.! !

!RGObject methodsFor: 'properties' stamp: ''!
propertyNamed: annotationName ifAbsent: exceptionBlock 

	^ self properties
			at: annotationName
			ifAbsent: [ exceptionBlock value ]! !

!RGObject methodsFor: 'private - backend interface' stamp: ''!
pvtName

	^ name! !

!RGObject class methodsFor: 'instance creation' stamp: ''!
asYetUnclassifiedProtocolName

	^ Protocol unclassified ! !

!RGObject class methodsFor: 'instance creation' stamp: ''!
named: aName parent: anRGObject

	^self basicNew
		parent: anRGObject;
		initialize;
		pvtName: aName asSymbol;
		yourself! !

!RGObject class methodsFor: 'instance creation' stamp: ''!
unresolvedNamed: aString withParent: anRGDefintion

	^self basicNew
		initializeUnresolved; 
		pvtName: aString asSymbol;
		parent: anRGDefintion;
		yourself! !

!RGObject class methodsFor: 'instance creation' stamp: ''!
parent: anRGObject

	^self basicNew
		parent: anRGObject;
		initialize;
		yourself! !

!RGObject class methodsFor: 'instance creation' stamp: ''!
named: aString

	"create model in its own environment"

	^self new
		pvtName: aString;
		yourself! !

!RGObject class methodsFor: 'instance creation' stamp: ''!
unresolved

	^ self basicNew
		initializeUnresolved;
		yourself.! !

!RGObject class methodsFor: 'instance creation' stamp: ''!
unnamed

	^self new! !

!RGObject class methodsFor: 'instance creation' stamp: ''!
unresolvedWithParent: anRGDefintion

	^self basicNew
		initializeUnresolved; 
		parent: anRGDefintion;
		yourself! !

!RGObjectLayout methodsFor: 'accessing' stamp: ''!
slots 

	"only for API compatibility purposes"
	^ Array new! !

!RGObjectLayout methodsFor: 'testing - types' stamp: ''!
isObjectLayout

	^ true! !

!RGObjectTest methodsFor: 'tests' stamp: ''!
testTypes

	"check all testing methods"

	| def | 
	
	def := RGObject new.
	
	self deny: def isComment.
	self deny: def isEnvironment.
	self deny: def isGlobalVariable.
	self deny: def isLayout.
	self deny: def isMethod.
	self deny: def isPackage.
	self deny: def isSlot.
	self deny: def isTraitComposition.
	self deny: def isTraitTransformation.
	self deny: def isVariable.
	self deny: def isSlot.
	self deny: def isClass.
	self deny: def isMetaclass.
	self deny: def isMetaclassTrait.
	self deny: def isProtocol.
	self deny: def isTraitAlias.
	self deny: def isTraitComposition.
	self deny: def isTraitExclusion.
	self deny: def isTraitTransformation.
	self deny: def isVariable.
! !

!RGObjectTest methodsFor: 'tests' stamp: ''!
testProperties

	"test all method that access properties of Ring objects"

	| def |
	def := RGObject new.

	self assert: def hasProperties not.
	self assert: (def hasProperty: #note) not.
	self assert: def propertyNames isEmpty.
	self
		assert: (def propertyNamed: #note ifAbsent: [ #someNote ])
		equals: #someNote.
	self assert: (def hasProperty: #note) not.
	self
		assert: (def propertyNamed: #note ifAbsentPut: [ #someNote ])
		equals: #someNote.
	self assert: (def hasProperty: #note).
	self assert: (def propertyNamed: #note) equals: #someNote.
	self assert: def hasProperties.
	self assert: def propertyNames asArray equals: { #note }.
	def propertyNamed: #note2 put: #someNote2.
	self assert:
		(def propertyNames asArray includesAll: { #note. #note2 }).
	def removePropertyNamed: #note.
	self
		shouldnt: [ def removePropertyNamed: #nonexisting ]
		raise: KeyNotFound.
	self assert: def propertyNames asArray equals: { #note2 }.
	def removePropertyNamed: #note2.
	self assert: def hasProperties not.
	self assert: (def hasProperty: #note) not.
	self assert: def propertyNames isEmpty! !

!RGObjectTest methodsFor: 'tests' stamp: ''!
testFullCopy

	| def fullCopy | 
	
	"we cannot test RGObject directly here"
	def := RGClass named: #SomeDefinition.
	
	fullCopy := def fullCopy.
	self assert: (fullCopy ~~ def).
	self assert: fullCopy name equals: def name.
	
	! !

!RGObjectTest methodsFor: 'tests' stamp: ''!
testResolveability

	"test if we can resolve standard objects. They should be all resolved"
	
	{ Object. 42. 'aString'. #aSymbol } do: [ :each |
		self deny: each isRGObject.
		self assert: each isRingFullyResolved.
		self deny: each isRingFullyUnresolved  ]
	! !

!RGObjectTest methodsFor: 'tests' stamp: ''!
testUnresolvedValue

	| def | 
	
	def := RGObject named: #SomeDefinition.

	self deny: (def unresolvedValue isRingResolved).
	
	
	! !

!RGObjectTest methodsFor: 'tests' stamp: ''!
testTrivialMethods

	| def | 
	
	def := RGObject named: #SomeDefinition.

	self deny: (def unresolvedValue isRingResolved).
	
	
	! !

!RGObjectTest methodsFor: 'tests' stamp: ''!
testNameAccess
	| def |
	"we cannot test RGObject directly here"
	def := RGClass named: #SomeDefinition.
	self assert: def asRGDefinition identicalTo: def.
	self assert: def name equals: #SomeDefinition.
	self assert: def fullName equals: #SomeDefinition.
	def name: #NewName.
	self assert: def name equals: #NewName.
	self assert: def fullName equals: #NewName! !

!RGObjectTest methodsFor: 'tests' stamp: ''!
testResolvedNameOrNil

	"should return nil for unresolved names"

	| def | 
	
	def := RGClass unresolved.
	self assert: def resolvedNameOrNil equals: nil.
	
	def := RGClass named: #SomeName.
	self assert: def resolvedNameOrNil equals: #SomeName.
		! !

!RGObjectTest methodsFor: 'tests' stamp: ''!
testUnresolveName

	"The name of any Ring object should be unresolveable"

	| def result | 
	
	"try to unresolve already unresolved"
	def := RGComment unresolved.
	self deny: (def hasResolvedName).
	def unresolveName.
	self deny: (def hasResolvedName).

	"unresolve existing name"
	def name: #SomeName.
	self assert: (def hasResolvedName).
	result := def unresolveName.
	self deny: (def hasResolvedName).
	self assert: result isRGUnresolvedValue.! !

!RGObjectTest methodsFor: 'tests' stamp: ''!
testParent
	"test link to parent object"

	| def1 def2 |
	def1 := RGObject new.
	def2 := RGObject new.
	def2 pvtParent: def1.
	self assert: def2 parent identicalTo: def1! !

!RGOrganization commentStamp: ''!
An organization with categories!
!RGOrganization methodsFor: 'initialization' stamp: 'nil'!
initialize

	super initialize.
	self categories: OrderedCollection new.! !

!RGOrganization methodsFor: 'accessing' stamp: 'nil'!
categories
	"Retrieves categories in the system (tag-packages)"

	^self elements at: #categories ifAbsent:[ #() ]! !

!RGOrganization methodsFor: 'testing' stamp: 'nil'!
isSameRevisionAs: aRGOrganization
	"This method look for equality of the properties of the receiver"

	^(self class = aRGOrganization class)
		and:[ self categories = aRGOrganization categories ]! !

!RGOrganization methodsFor: 'testing' stamp: 'nil'!
isOrganization

	^true! !

!RGOrganization methodsFor: 'accessing' stamp: 'nil'!
categories: aCollection
	"Set the categories collection"

	self elements at: #categories put: aCollection! !

!RGOrganization methodsFor: 'accessing' stamp: 'nil'!
fullName

	^#organization! !

!RGPackage commentStamp: ''!
RGPackage is the representation for packages.
A package manages classes, methods and children packages as elements.
A package can also know in which package is defined
!
!RGPackage methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ RGEnvironment new
		yourself.! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
removeFromSystem

	self environment removePackage: self.! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtAddExtensionMethod: aMethodDefinition

	self environment verifyOwnership: aMethodDefinition.
	
	extensionMethods isRingResolved ifFalse: [ 
		self pvtCleanExtensionMethods  ].
	
	extensionMethods add: aMethodDefinition.
	
	"TODO:Announce"
	
	! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtRemoveExtensionMethod: anRGMethod

	self environment verifyOwnership: anRGMethod.
	
	extensionMethods remove: anRGMethod.
	
	"TODO:Announce"
	
	! !

!RGPackage methodsFor: 'accessing' stamp: ''!
extendedClasses
	
	^ self extendedBehaviors! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
includesClassesAffectedBy: aSystemAnnouncement

	^(aSystemAnnouncement affectsClassesDefinedInPackage: self)
		or: [ aSystemAnnouncement affectsClassesExtendedInPackage: self ]! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
definedBehaviorsDo: aBlock

	self backend forPackage definedBehaviorsFor: self do: aBlock! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
packageName

	^ self name! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
renameTo: aString

	self name: aString! !

!RGPackage methodsFor: 'accessing' stamp: ''!
definedTraits
	"Retrieves the traits defined in the receiver"

	^self definedBehaviors select: #isTrait! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
cleanTagsForClasses

	self backend forPackage cleanTagsForClassesFor: self! !

!RGPackage methodsFor: 'testing' stamp: ''!
isPackage

	^true! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
extensionMethodsDo: aBlock

	self backend forPackage extensionMethodsFor: self do: aBlock! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
cleanExtensionMethods

	self backend forPackage cleanExtensionMethodsFor: self! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
classesForClassTag: aTag

	^ self classes select: [ :each | each category  = aTag or: [ each category = (self packageName, '-', aTag) ] ]! !

!RGPackage methodsFor: 'accessing' stamp: ''!
categoryName

	^ self name ! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtExtensionMethodsDo: aBlock

	^ extensionMethods value do: aBlock! !

!RGPackage methodsFor: 'accessing - model' stamp: ''!
tagsForClasses
	"Retrieves the traits defined in the receiver"

	| allTags |
	allTags := IdentitySet new.
	self tagsForClassesDo: [ :each | allTags add: each].
	^ allTags asArray
! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
extensionSelectorsForClass: aClass

	^ (self extensionMethods select: [ :each | each parent = aClass ]) collect: [:each | each name]! !

!RGPackage methodsFor: 'accessing' stamp: ''!
extendedSelectors
	"Retrieves the names of the methods"
	
	^ self extensionMethods collect: [ :each | each selector ]! !

!RGPackage methodsFor: 'accessing' stamp: ''!
categories
	
	^ self definedBehaviors collect: #category as: Set
! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
cleanDefinedBehaviors

	self backend forPackage cleanDefinedBehaviorsFor: self! !

!RGPackage methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	extensionMethods := self unresolvedValue: self defaultExtensionMethods.
	definedBehaviors := self unresolvedValue: self defaultDefinedBehaviors.
	tagsForClasses := self unresolvedValue: self defaultTagsForClasses.
! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtRemoveClassTag: aSymbol
	
	tagsForClasses remove: aSymbol.
	
	"TODO:Announce"
	
	! !

!RGPackage methodsFor: 'queries - behaviors' stamp: ''!
definedBehaviors

	| allDefinedBehaviors |
	allDefinedBehaviors := IdentitySet new.
	self definedBehaviorsDo: [ :each | allDefinedBehaviors add: each].
	^ allDefinedBehaviors asArray
	! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
removeClassTag: aSymbol

	self backend forPackage removeClassTag: aSymbol from: self! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
extendsClass: aClass

	^ self extendedClasses includes: aClass.! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
packageManifestOrNil

	^ nil "TODO"! !

!RGPackage methodsFor: 'accessing - model' stamp: ''!
classesTaggedWith: aSymbol

	^ self definedBehaviors select: [ :each | each isTaggedWith: aSymbol ]! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtTagsForClassesDo: aBlock

	^ tagsForClasses value do: aBlock! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
extendedClassNames

	^ self extendedClasses collect: [ :each | each name ]! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
importClasses: classCollection
	classCollection do: [ :each | 
		each package: self. ]! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
addDefinedBehavior: anRGBehavior

	self backend forPackage addDefinedBehavior: anRGBehavior to: self! !

!RGPackage methodsFor: 'accessing' stamp: ''!
extendedTraits
	
	^ (self extensionMethods collect: [:each | each parent]) select: [:each | each isTrait]! !

!RGPackage methodsFor: 'resolving' stamp: ''!
makeResolved

	super makeResolved.
	
	definedBehaviors := self definedBehaviors markAsRingResolved.
	extensionMethods := self extensionMethods markAsRingResolved.
	tagsForClasses := self tagsForClasses markAsRingResolved.
! !

!RGPackage methodsFor: 'accessing' stamp: ''!
package

	^ self! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
tagsForClassesDo: aBlock

	self backend forPackage tagsForClassesFor: self do: aBlock! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
asPackageName

	^ self name! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
isAboutPackage: aPackage

	^self == aPackage! !

!RGPackage methodsFor: 'accessing' stamp: ''!
definedClassNames

	^ self definedClassesOnly collect: [ :each | each name ] ! !

!RGPackage methodsFor: 'accessing' stamp: ''!
extendedClassesAndTraits
	
	^ self extendedBehaviors! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtAddClassTag: aSymbol
	
	tagsForClasses isRingResolved ifFalse: [ 
		self pvtCleanTagsForClasses  ].
	
	tagsForClasses add: aSymbol.	
	! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
isEmpty

	^ self definedClasses isEmpty and: [ self extensionMethods isEmpty ]! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
calypsoEnvironmentType
	^RPackage! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
addExtensionMethod: anRGMethod 

	self backend forPackage addExtensionMethod: anRGMethod to: self! !

!RGPackage methodsFor: 'default model values' stamp: ''!
defaultTagsForClasses

	^ Set new! !

!RGPackage methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream
		nextPutAll: self class name;
		nextPutAll: '(';
		nextPutAll: self name;
		nextPutAll: ')'! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtCleanTagsForClasses

	tagsForClasses := self defaultTagsForClasses.
		
	"TODO:Announce if not empty"
	
	! !

!RGPackage methodsFor: 'default model values' stamp: ''!
defaultDefinedBehaviors

	^ Set new! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
addClassTag: sSymbol

	self backend forPackage addClassTag: sSymbol to: self! !

!RGPackage methodsFor: 'accessing' stamp: ''!
extensionMethods

	| allMethods |
	allMethods := IdentitySet new.
	self extensionMethodsDo: [ :each | allMethods add: each].
	^ allMethods asArray
! !

!RGPackage methodsFor: 'accessing' stamp: ''!
name: aString

	| oldName |
	
	oldName := self name.
	super name: aString.
	
	self announce: (RPackageRenamed 
			to: self 
			oldName: oldName 
			newName: aString)! !

!RGPackage methodsFor: 'accessing' stamp: ''!
definedClasses

	^ self definedBehaviors! !

!RGPackage methodsFor: 'accessing' stamp: ''!
methods
	"Retrieves all the methods defined in the receiver. 
	#methods holds the methods of defined classes"
	
	^ (self definedBehaviors flatCollect: #methods), self extensionMethods ! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtCleanExtensionMethods

	extensionMethods := self defaultExtensionMethods.
		
	"TODO:Announce if not empty"
	
	! !

!RGPackage methodsFor: 'accessing' stamp: ''!
extendedBehaviors
	
	^ ((self extensionMethods collect: [:each | each parent]) collect: [:behavior |
		behavior isClass 
			ifTrue: [behavior ]
			ifFalse: [ behavior baseClass]] as: IdentitySet) asArray! !

!RGPackage methodsFor: 'accessing' stamp: ''!
classes
	"Retrieves a collection of classes defined in the receiver and classes holding extension methods"
		
	^self definedClassesOnly, self extendedClasses ! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtCleanDefinedBehaviors

	definedBehaviors := self defaultDefinedBehaviors.
		
	"TODO:Announce if not empty"
	
	! !

!RGPackage methodsFor: '*Calypso-Ring' stamp: ''!
classTags

	self isRingResolved not ifTrue: [ ^ '' ].
	
	 ^ self classes collect: [:aClass | (aClass category ifNil: [ '' ]) withoutPrefix: (self name, '-')] as: Set! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtAddDefinedBehavior: anRGBehavior

	self environment verifyOwnership: anRGBehavior.
	
	definedBehaviors isRingResolved ifFalse: [ 
		self pvtCleanDefinedBehaviors  ].
	
	definedBehaviors add: anRGBehavior.	
	! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
removeExtensionMethod: anRGMethod 

	self backend forPackage removeExtensionMethod: anRGMethod from: self! !

!RGPackage methodsFor: 'accessing' stamp: ''!
classNames

	^ self classes collect: [ :each | each name ]! !

!RGPackage methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.

	extensionMethods := self unresolvedValue: self defaultDefinedBehaviors.
	definedBehaviors := self unresolvedValue: self defaultExtensionMethods.
	tagsForClasses := self unresolvedValue: self defaultTagsForClasses.
! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtRemoveDefinedBehavior: anRGBehavior

	self environment verifyOwnership: anRGBehavior.
	
	definedBehaviors remove: anRGBehavior.
	
	"TODO:Announce"
	
	! !

!RGPackage methodsFor: '*Ring-Monticello' stamp: ''!
asMCSnapshot

	| definitions | 
	
	definitions := ((((self definedBehaviors reject: [:each | each isMeta]) sorted: [:a :b | a name < b name ]) collect: [:each | each asMCDefinition]), (self extensionMethods collect: [:each | each asMCDefinition])) asOrderedCollection.
	definitions addAll: ((self definedBehaviors, (self definedBehaviors collect: [:each | each classSide])) flatCollect: [ :behavior |
		(behavior localMethods reject: [:each | (each  parent instanceSide package = each package) not])
			collect: [ :method | method asMCDefinition] ]).
	
	^ MCSnapshot fromDefinitions: definitions.! !

!RGPackage methodsFor: 'accessing' stamp: ''!
traits
	"Retrieves a collection of classes defined in the receiver and classes holding extension methods"
		
	^self definedTraits, self extendedTraits! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtDefinedBehaviorsDo: aBlock

	^ definedBehaviors value do: aBlock! !

!RGPackage methodsFor: 'accessing - backend' stamp: ''!
removeDefinedBehavior: anRGBehavior

	self backend forPackage removeDefinedBehavior: anRGBehavior from: self! !

!RGPackage methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	self isRingResolved ifFalse: [ ^ self ].
	
	super addoptToParentStub.

	^ self parent addPackage: self.! !

!RGPackage methodsFor: 'default model values' stamp: ''!
defaultExtensionMethods

	^ Set new! !

!RGPackage methodsFor: 'queries - behaviors' stamp: ''!
definedClassesOnly

	^ self definedBehaviors select: #isClass! !

!RGPackage methodsFor: 'private - backend interface' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#definedBehaviors -> definedBehaviors. 
		#extensionMethods -> extensionMethods. 
		#tagsForClasses -> tagsForClasses
	}
	
	! !

!RGPackageDefinition commentStamp: ''!
RGPackage is the representation for packages.
A package manages classes, methods and children packages as elements.
A package can also know in which package is defined
!
!RGPackageDefinition methodsFor: 'adding/removing' stamp: 'nil'!
addElement: aRGDefinition in: aCollection

	aRGDefinition package: self.
	super addElement: aRGDefinition in: aCollection.! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
definedClassNames

	^ super classNames! !

!RGPackageDefinition methodsFor: 'testing' stamp: 'nil'!
definesOrExtendsClass: aRGBehaviorDefinition
	"Returns true whether the class, aRGBehaviorDefinition, is one locally defined classes of the receiver or 
	if the receiver extends such class (that is defined in another package)"
	
	^ (self definesClass: aRGBehaviorDefinition) or:[ self extendsClass: aRGBehaviorDefinition ]! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
realPackage

	^ RPackageOrganizer default packageNamed: self name! !

!RGPackageDefinition methodsFor: 'adding/removing' stamp: 'nil'!
withoutCategories

	self removeElementsCategorized: #categories! !

!RGPackageDefinition methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	aStream
		nextPutAll: self class name;
		nextPutAll: '(';
		nextPutAll: self name;
		nextPutAll: ')'! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
extendedClasses
	"Retrieves the classes holding the extension methods and returns a dictionary as well"
	|  classesOfExt |
	classesOfExt := Dictionary new.
	
	self extensionMethods
		do:[ :mth| (classesOfExt includesKey: mth parentName)
					ifFalse:[ classesOfExt at: mth parentName put: mth parent ] ].
	
	^classesOfExt! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
extensionMethods
	"Retrieves extension methods"
	
	^self elements at: #extensionMethods! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
parent
	"Retrieves the environment linked to this package"
	
	^self environment! !

!RGPackageDefinition methodsFor: 'lookup' stamp: 'nil'!
lookupClassNamed: className
	"Look for the class named className in the receiver's defined classes or in any of its package children"
	| class |
	
	class:= self classNamed: className.
	class ifNotNil:[ ^class ].
	
	self packages
		do:[ :each| class:= each lookupClassNamed: className.
				    class ifNotNil:[ ^class ] ].
	^nil! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
extensionMethods: aCollection
	"Set the extension methods collection"
	
	self elements at: #extensionMethods put: aCollection! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
methods
	"Retrieves all the methods defined in the receiver. 
	#methods holds the methods of defined classes"
	
	^super methods, self extensionMethods ! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
definedTraits
	"Retrieves the traits defined in the receiver"

	^self traits! !

!RGPackageDefinition methodsFor: 'testing' stamp: 'nil'!
isPackage

	^true! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
package: aRGPackage
	"Sets the outer package of the receiver if exists"

	package:= aRGPackage! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
classes
	"Retrieves a collection (by default a dictionary) of classes defined in the receiver and classes holding extension methods"
	
	^self definedClasses, self extendedClasses ! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
extendedSelectors
	"Retrieves the names of the methods"
	
	^ self extensionMethods keys! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
categories
	"Retrieves class categories of the receiver"
	
	^self elements at: #categories! !

!RGPackageDefinition methodsFor: 'initialization' stamp: 'nil'!
initialize

	super initialize.
	self withoutPackages.	"By default the receiver has no child packages"
	self extensionMethods: IdentityDictionary new.		
	self categories: OrderedCollection new.! !

!RGPackageDefinition methodsFor: 'metrics' stamp: 'nil'!
numberOfLinesOfCode
	
	^ self 
		annotationNamed: #numberOfLinesOfCode
		ifAbsentPut: [
			| number |
			number := self classes inject: 0 into: [ :sum :each | sum + each numberOfLinesOfCode + each classSide numberOfLinesOfCode ].
			number := self methods inject: number into: [ :sum :each | sum + each numberOfLinesOfCode ].
			number ]! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
classNames

	^ self classes isDictionary
		ifTrue: [ self classes keys ]
		ifFalse:[ self classes collect:[ :class|  class name ] ]	! !

!RGPackageDefinition methodsFor: 'testing' stamp: 'nil'!
extendsClass: aRGBehaviorDefinition
	"Returns true if the receiver extends aRGBehaviorDefinition (that is defined in another package)"
	
	^ self extendedClasses includes: aRGBehaviorDefinition! !

!RGPackageDefinition methodsFor: 'adding/removing' stamp: 'nil'!
removeMethod: aRGMethodDefinition

	self 
		removeElement: aRGMethodDefinition 
		from: (aRGMethodDefinition isExtension 
				ifTrue: [ self extensionMethods ]
				ifFalse:[ super methods ])! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
extendedClassNames

	^ self extendedClasses isDictionary
		ifTrue: [ self extendedClasses keys ]
		ifFalse:[ self extendedClasses collect:[ :each| each name ]]! !

!RGPackageDefinition methodsFor: 'testing' stamp: 'nil'!
definesClass: aRGBehaviorDefinition
	"Returns true if the receiver includes aRGBehaviorDefinition in the defined classes"

	^ self includesClass: aRGBehaviorDefinition! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
categories: aCollection
	"Set the class categories collection"
	
	self elements at: #categories put: (aCollection asOrderedCollection)! !

!RGPackageDefinition methodsFor: 'managing container' stamp: 'nil'!
addInContainer: anRGContainer

	anRGContainer addPackage: self! !

!RGPackageDefinition methodsFor: 'adding/removing' stamp: 'nil'!
addMethod: aRGMethodDefinition
	"aRGMethodDefinition needs to satisfy the status isMethod"

	aRGMethodDefinition isMethod ifFalse:[ ^self ].
	aRGMethodDefinition package: self.	"Needed to evaluate #isExtension if it was not set in advance"
	self 
		addElement: aRGMethodDefinition 
		in: (aRGMethodDefinition isExtension 
			ifTrue: [ self extensionMethods ]
			ifFalse:[ super methods ])! !

!RGPackageDefinition methodsFor: 'accessing' stamp: 'nil'!
package
	"Retrieves the  package in which self is contained"

	^package! !

!RGPackageDefinition methodsFor: '*Manifest-Core' stamp: ''!
arrayStringForManifest
	| array |
	array := Array new: 2.
	array at: 1 put: self class asString asSymbol.
	array at: 2 put: {(name asSymbol)}.
	^ array! !

!RGPackageDefinition class methodsFor: '*Manifest-Core' stamp: ''!
manifestReadOn: aArray

	^ self named:( aArray first)! !

!RGPackageDefinitionTest commentStamp: ''!
SUnit tests for packages!
!RGPackageDefinitionTest methodsFor: 'testing' stamp: ''!
testAddingPackage
	| newPackage childPackage |
	newPackage := RGPackageDefinition named: #Collections.
	newPackage addPackageNamed: #'Collections-Sequenceable'.

	self assert: (newPackage includesPackageNamed: #'Collections-Sequenceable').
	self assert: newPackage packages size equals: 1.

	childPackage := newPackage packageNamed: #'Collections-Sequenceable'.
	self assert: childPackage parent equals: newPackage parent.
	self assert: childPackage package equals: newPackage! !

!RGPackageDefinitionTest methodsFor: 'testing' stamp: ''!
testNewPackage
	| newPackage |
	newPackage := RGPackageDefinition named: 'Collections-Sequenceable'.

	self assert: newPackage isPackage.
	self assert: newPackage name equals: 'Collections-Sequenceable'.
	self assertEmpty: newPackage classes.
	self assertEmpty: newPackage traits.
	self assertEmpty: newPackage packages.
	self assert: newPackage package isNil.
	self assert: newPackage parent identicalTo: Smalltalk globals! !

!RGPackageDefinitionTest methodsFor: 'testing' stamp: ''!
testAddingClass
	| newPackage newClass |
	newPackage := RGPackageDefinition named: #'Collections-Sequenceable'.
	newClass := RGClassDefinition named: #OrderedCollection.
	newPackage addClass: newClass.

	self assert: newPackage hasClasses.
	self assert: newClass package identicalTo: newPackage.
	self assert: (newPackage classNamed: #OrderedCollection) identicalTo: newClass! !

!RGPackageTest commentStamp: ''!
SUnit tests for packages!
!RGPackageTest methodsFor: 'testing' stamp: ''!
testCategories
	| package env class1 class2 |
	package := RGPackage named: 'SomePackage'.
	env := package environment.

	class1 := env ensureClassNamed: #Class1.
	class2 := env ensureClassNamed: #Class2.

	class1 package: package.
	class2 package: package.

	self assert: package categories asArray equals: #('SomePackage').

	class1 tagWith: #tag1.
	class2 tagWith: #tag1.

	self assert: package categories asArray sorted equals: #('SomePackage-tag1').

	class2 untagFrom: #tag1.
	class2 tagWith: #tag2.

	self assert: package categories asArray sorted equals: #('SomePackage-tag1' 'SomePackage-tag2')! !

!RGPackageTest methodsFor: 'testing' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGPackage unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGPackageTest methodsFor: 'tests - new' stamp: ''!
testStubPackage
	| env package package2 |
	env := RGEnvironment new.
	self assert: env ask packages size equals: 0.

	package := RGPackage named: 'Collections-Sequenceable'.
	env := package environment.
	self assert: env ask packages size equals: 1.

	package2 := RGPackage named: 'Collections-Sequenceable' parent: env
	"self assert: (env ask packages size = 2).
	env addPackage: package2.
	self assert: (env ask packages size = 3)."! !

!RGPackageTest methodsFor: 'testing' stamp: ''!
testTagsForClassesCollection
	
	| package env tag1 tag2 tag3 |

	package := RGPackage unnamed.
	env := package environment.

	self assert: package tagsForClasses isEmpty.
	self assert: (package hasUnresolved: #tagsForMethods).
	
	tag1 := #tag1.
	package addClassTag: #tag1.
	self assert: package tagsForClasses size equals: 1.

	self assert: (package hasResolved: #tagsForClasses).
	
	tag2 := #tag2.
	package addClassTag: tag2.
	self assert: package tagsForClasses size equals: 2.
	
	tag3 := #tag3.
	package addClassTag: tag3.
	self assert: package tagsForClasses size equals: 3.

	package removeClassTag: tag3.
	self assert: package tagsForClasses size equals: 2.

	package cleanTagsForClasses.
	self assert: package tagsForClasses isEmpty.
	self assert: (package hasResolved: #tagsForClasses).
! !

!RGPackageTest methodsFor: 'testing' stamp: ''!
testTagsForClasses
	
	| package env class1 class2 |

	package := RGPackage unnamed.
	env := package environment.
	
	self assert: package tagsForClasses isEmpty.
	self assert: (package hasUnresolved: #tagsForClasses).
	
	class1 := env ensureClassNamed: #Class1.
	class2 := env ensureClassNamed: #Class2.
	
	class1 package: package.
	class2 package: package.
	
	self assert: package tagsForClasses isEmpty.
	self assert: (package hasUnresolved: #tagsForClasses).

	self assert: (package classesTaggedWith: #tag1) isEmpty.
	
	class1 tagWith: #tag1.
	self assert: class1 tags equals: #(#tag1).
	self assert: package tagsForClasses equals: #(#tag1).
	self assert: (package classesTaggedWith: #tag1) equals: {class1}.
	
	class2 tagWith: #tag1.
	self assert: class2 tags equals: #(#tag1).
	self assert: package tagsForClasses equals: #(#tag1).
	self assert: ((package classesTaggedWith: #tag1) includesAll: {class1. class2}).

	class1 tagWith: #tag2.
	self assert: class1 tags sorted equals: #(#tag1 #tag2).
	self assert: package tagsForClasses sorted equals: #(#tag1 #tag2).
	
	class1 untagFrom: #tag1.
	self assert: class1 tags equals: #(#tag2).
	self assert: package tagsForClasses sorted equals: #(#tag1 #tag2).
	self assert: ((package classesTaggedWith: #tag1) includesAll: {class2}).

	class2 tagWith: #tag3.
	self assert: class2 tags sorted equals: #(#tag1 #tag3).
	self assert: package tagsForClasses sorted equals: #(#tag1 #tag2 #tag3).

	package removeDefinedBehavior: class1.
	self assert: package tagsForClasses sorted equals: #(#tag1 #tag2 #tag3).
	package removeDefinedBehavior: class2.
	self assert: package tagsForClasses sorted equals: #(#tag1 #tag2 #tag3).

	self assert: (package classesTaggedWith: #tag1) isEmpty.
	self assert: (package classesTaggedWith: #tag2) isEmpty.
	self assert: (package classesTaggedWith: #tag3) isEmpty.
! !

!RGPackageTest methodsFor: 'testing' stamp: ''!
testAddingPackage
"	| newPackage childPackage |
	
	newPackage:= RGPackage named: #'Collections'.
	newPackage addPackageNamed: #'Collections-Sequenceable'.
		
	self assert: (newPackage includesPackageNamed: #'Collections-Sequenceable').
	self assert: newPackage packages size equals: 1.
	
	childPackage:= newPackage packageNamed: #'Collections-Sequenceable'.
	self assert: (childPackage parent = newPackage parent).
	self assert: (childPackage package = newPackage)."! !

!RGPackageTest methodsFor: 'testing' stamp: ''!
testDefinedBehaviorsCollection
	
	| package env behavior1 behavior2 behavior3 |

	package := RGPackage unnamed.
	env := package environment.

	self assert: package definedBehaviors isEmpty.
	self assert: (package hasUnresolved: #definedBehaviors).
	
	behavior1 := env ensureClassNamed: #Behavior1.
	package addDefinedBehavior: behavior1.
	self assert: package definedBehaviors size equals: 1.

	self assert: (package hasResolved: #definedBehaviors).
	
	behavior2 := env ensureClassNamed: #'Behavior2 class'.
	package addDefinedBehavior: behavior2.
	self assert: package definedBehaviors size equals: 2.
	
	behavior3 := env ensureTraitNamed: #Behavior3.
	package addDefinedBehavior: behavior3.
	self assert: package definedBehaviors size equals: 3.

	package removeDefinedBehavior: behavior3.
	self assert: package definedBehaviors size equals: 2.

	package cleanDefinedBehaviors.
	self assert: package definedBehaviors isEmpty.
	self assert: (package hasResolved: #definedBehaviors).
! !

!RGPackageTest methodsFor: 'testing' stamp: ''!
testDefinedBehaviorsOfUnresolvedPackages

	| env class |
	
	env := RGEnvironment new.
	class := env ensureClassNamed: #SomeClass.
	self assert: class package definedBehaviors size equals: 1.
	self assert: class package definedBehaviors anyOne equals: class.
! !

!RGPackageTest methodsFor: 'testing' stamp: ''!
testClasses
	
	| package env class1 class2 trait1 |

	package := RGPackage named: 'SomePackage'.
	env := package environment.
	
	self assert: package classes isEmpty.
	self assert: package definedClasses isEmpty.
	self assert: package definedTraits isEmpty.
	self assert: package classNames isEmpty.
	self assert: package extendedBehaviors isEmpty.
	self assert: package extendedClasses isEmpty.
	self assert: package extendedClassesAndTraits isEmpty.
	self assert: package extendedSelectors isEmpty.
	self assert: package extendedTraits isEmpty.
		
	class1 := env ensureClassNamed: #Class1.
	class2 := env ensureClassNamed: #Class2.
	
	class1 package: package.
	class2 package: package.
	
	self assert: package classes size equals: 2.
	self assert: (package classes includes: class1).
	self assert: (package classes includes: class2).
	
	self assert: package definedClasses size equals: 2.
	self assert: (package definedClasses includes: class1).
	self assert: (package definedClasses includes: class2).

	self assert: package classNames asArray sorted equals: #(Class1 Class2).

	trait1 := env ensureTraitNamed: #Trait1.
	trait1 package: package.

	self assert: package definedClasses size equals: 3.
	self assert: (package definedClasses includes: trait1).
	self assert: package definedClassesOnly size equals: 2.
	self assert: (package definedClassesOnly allSatisfy: #isClass).

	self assert: package definedTraits size equals: 1.
	self assert: (package definedClasses includes: trait1).
! !

!RGPackageTest methodsFor: 'tests - new' stamp: ''!
testPrinting
	| newPackage |
	
	newPackage := RGPackage named: 'Collections-Sequenceable'.
	
	self assert: newPackage printString equals: ('RGPackage(Collections-Sequenceable)').
	! !

!RGPackageTest methodsFor: 'tests - new' stamp: ''!
testNewPackage
	| newPackage |
	newPackage := RGPackage named: 'Collections-Sequenceable'.

	self assert: newPackage isRingResolved.

	self assert: newPackage isPackage.
	self assert: newPackage name equals: 'Collections-Sequenceable'.

	newPackage name: 'NewCollections'.
	self assert: newPackage name equals: 'NewCollections'.

	self assert: newPackage definedBehaviors isEmpty.
	self assert: newPackage extensionMethods isEmpty.
	self assert: (newPackage hasUnresolvedAll: #(#definedBehaviors #extensionMethods)).

	newPackage cleanDefinedBehaviors.

	self assert: (newPackage hasUnresolved: #extensionMethods).
	self assert: newPackage definedBehaviors isEmpty.
	self assert: newPackage extensionMethods isEmpty.

	newPackage cleanExtensionMethods.
	newPackage cleanTagsForClasses.

	self assert: newPackage unresolvedProperties isEmpty.
	self assert: newPackage definedBehaviors isEmpty.
	self assert: newPackage extensionMethods isEmpty.

	self assert: newPackage isRingResolved.
	self assert: newPackage isRingFullyResolved.
	self deny: newPackage isRingFullyUnresolved.

	self assert: newPackage package equals: newPackage.

	self assert: newPackage traits isEmpty! !

!RGPackageTest methodsFor: 'testing' stamp: ''!
testAddingClass

	| newPackage newClass env |
	
	newPackage := RGPackage named: 'Collections-Sequenceable'.
	env := newPackage environment.
	newClass:= RGClass named: #OrderedCollection parent: env.
	
	self assert: (env ask packages notEmpty).
	
	newPackage addDefinedBehavior: newClass.
! !

!RGPointerLayout methodsFor: 'accessing - backend' stamp: ''!
removeSlot: anRGSlot

	self parent announceDefinitionChangeDuring: [ 
		self backend forBehavior removeSlot: anRGSlot from: self ].! !

!RGPointerLayout methodsFor: 'private - backend access' stamp: ''!
pvtSlotsDo: aBlock

	slots value do: aBlock! !

!RGPointerLayout methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	slots := self unresolvedValue: self defaultSlots.

! !

!RGPointerLayout methodsFor: 'testing - types' stamp: ''!
isPointerLayout

	^ true! !

!RGPointerLayout methodsFor: 'queries - slots' stamp: ''!
slots

	| allSlots |
	allSlots := OrderedCollection new.
	self slotsDo: [ :each | allSlots add: each].
	^ allSlots asArray! !

!RGPointerLayout methodsFor: 'private - backend access' stamp: ''!
pvtRemoveSlot: anRGSlot

	self environment verifyOwnership: anRGSlot.
	
	slots remove: anRGSlot.
	
! !

!RGPointerLayout methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	slots := self unresolvedValue: self defaultSlots.

! !

!RGPointerLayout methodsFor: 'accessing - backend' stamp: ''!
cleanSlots

	self parent announceDefinitionChangeDuring: [ 
		self backend forBehavior cleanSlotsFor: self ].
	
	! !

!RGPointerLayout methodsFor: 'private - backend access' stamp: ''!
pvtCleanSlots

	slots := self defaultSlots.! !

!RGPointerLayout methodsFor: 'accessing - backend' stamp: ''!
addSlot: anRGSlot 

	self parent announceDefinitionChangeDuring: [ 
		self backend forBehavior addSlot: anRGSlot to: self ].! !

!RGPointerLayout methodsFor: 'accessing' stamp: ''!
resolveSlot: aName ifFound: foundBlock ifNone: noneBlock

	self allSlots do: [ :slot | 
		slot name == aName ifTrue: [ ^ foundBlock cull: slot ] ].
	^ noneBlock value! !

!RGPointerLayout methodsFor: 'queries - slots' stamp: ''!
allSlots 

	^ self slots! !

!RGPointerLayout methodsFor: 'queries - slots' stamp: ''!
instVarNames
	^ self slots collect: [:each | each name]! !

!RGPointerLayout methodsFor: 'resolving' stamp: ''!
makeResolved

	super makeResolved.
	
	slots := self slots asOrderedCollection markAsRingResolved.
! !

!RGPointerLayout methodsFor: 'accessing - backend' stamp: ''!
slotsDo: aBlock

	self backend forBehavior slotsFor: self do: aBlock! !

!RGPointerLayout methodsFor: 'private - backend access' stamp: ''!
pvtAddSlot: anRGSlot

	self environment verifyOwnership: anRGSlot.
	
	slots isRingResolved ifFalse: [ 
		self pvtCleanSlots  ].
	
	slots add: anRGSlot.	! !

!RGPointerLayout methodsFor: 'default model values' stamp: ''!
defaultSlots

	^ OrderedCollection new! !

!RGPointerLayout methodsFor: 'private - backend access' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#slots -> slots. 
	}
	
	! !

!RGPoolVariable commentStamp: ''!
A pool variable definition!
!RGPoolVariable methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ self defaultClassStub! !

!RGPoolVariable methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	super addoptToParentStub.

	self environment backend createUnresolvedClassGroupFor: self parent! !

!RGPoolVariable methodsFor: 'testing' stamp: ''!
isPoolVariable

	^true! !

!RGPoolVariableDefinition commentStamp: ''!
A pool variable definition!
!RGPoolVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isPoolVariable

	^true! !

!RGPoolVariableTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGPoolVariable unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGPoolVariableTest methodsFor: 'tests' stamp: ''!
testPoolVariableImplicitEnvironment

	| poolVariable |
	
	poolVariable := RGPoolVariable unnamed.
	self assert: (poolVariable hasUnresolved: #name).
	self assert: (poolVariable parent isClass).
	self checkImplicitSingleClassEnvironmentOf: poolVariable parent.
	
	
	
	
! !

!RGReadOnlyBackend methodsFor: 'trait composition' stamp: ''!
cleanTransformationsFor: anRGTraitComposition

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'pointer layout' stamp: ''!
cleanSlotsFor: anRGLayout

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'general' stamp: ''!
setNameFor: anRGObject to: aString

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'pointer layout' stamp: ''!
addSlot: anRGSlot to: anRGLayout

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'trait exclusion' stamp: ''!
addExclusion: aSymbol to: anRGTraitExclusion

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'trait transormation' stamp: ''!
setSubjectFor: anRGTraitComposition to: anRGTrait

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'trait composition' stamp: ''!
addTransformation: anRGTraitTransformation to: anRGTraitComposition

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'behavior' stamp: ''!
cleanLocalMethodsFor: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
untagClass: anRGBehavior from: aSymbol

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'trait alias' stamp: ''!
addAlias: aSymbol to: anRGTraitAlias

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'package' stamp: ''!
cleanExtensionMethodsFor: anRGPackage

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
removeSharedPool: anRGPoolVariable from: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'slot' stamp: ''!
setExpressionFor: anRGUnknownSlot to: aString

	self readOnlyError! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
setCommentFor: anRGBehavior to: anRGComment

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'behavior' stamp: ''!
removeProtocol: anRGProtocolDefinition from: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'behavior' stamp: ''!
setLayoutFor: anRGBehavior to: anRGLayout

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class description' stamp: ''!
removeInstanceVariable: anRGInstanceVariableDefinition from: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'pointer layout' stamp: ''!
removeSlot: anRGSlot from: anRGLayout

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'class comment' stamp: ''!
setClassCommentAuthorFor: anRGComment to: aString

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'method' stamp: ''!
setMethodPackageFor: anRGMethod to: anRGPackageDefinition

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'environment' stamp: ''!
addPackage: anRGPackageDefinition to: anRGEnvironment

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'unresolved objects' stamp: ''!
createNewUnresolvedMetaclassFor: anRGBehavior

	self readOnlyError 
	"^ RGUnresolvedValue recursive"! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
removeClassVariable: anRGInstanceVariableDefinition from: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'environment' stamp: ''!
cleanGlobalVariablesFor: anRGEnvironment

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'behavior' stamp: ''!
removeLocalMethod: anRGMethod from: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'environment' stamp: ''!
removeGlobalVariable: anRGGlobalVariable from: anRGEnvironment

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'trait exclusion' stamp: ''!
cleanExclusionsFor: anRGTraitExclusion

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'environment' stamp: ''!
removeBehavior: anRGBehavior from: anRGEnvironment

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'package' stamp: ''!
removeDefinedBehavior: anRGBehavior from: anRGPackage

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'behavior' stamp: ''!
setSuperclassFor: anRGBehavior to: anObject

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
addSharedPool: anRGPoolVariable to: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class description' stamp: ''!
setMetaClassFor: anRGBehavior to: anRGMetaclass

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'package' stamp: ''!
addExtensionMethod: anRGMethod to: anRGPackageDefinition

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'unresolved objects' stamp: ''!
createNewUnresolvedMetaclassMetaclassFor: anRGBehavior

	self readOnlyError 
	"| unresolvedValue |
	
	unresolvedValue := RGUnresolvedValue new.
	unresolvedValue default: unresolvedValue.
	^ unresolvedValue."! !

!RGReadOnlyBackend methodsFor: 'trait composition' stamp: ''!
removeTransformation: anRGTraitTransformation from: anRGTraitComposition

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'environment' stamp: ''!
cleanBehaviorsFor: anRGEnvironment

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'behavior' stamp: ''!
addLocalMethod: anRGMethod to: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class description' stamp: ''!
cleanInstanceVariablesFor: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'behavior' stamp: ''!
addProtocol: anRGProtocolDefinition to: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'package' stamp: ''!
addClassTag: aSymbol to: anRGPackageDefinition

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'package' stamp: ''!
cleanDefinedBehaviorsFor: anRGPackage

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
addClassVariable: anRGInstanceVariableDefinition to: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'unresolved objects' stamp: ''!
createNewUnresolvedClass

	self readOnlyError 
"	| unresolvedValue |
	
	unresolvedValue := RGUnresolvedValue new.
	unresolvedValue default: unresolvedValue.
	^ unresolvedValue."
! !

!RGReadOnlyBackend methodsFor: 'trait alias' stamp: ''!
cleanAliasesFor: anRGTraitAlias

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
cleanClassVariablesFor: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'environment' stamp: ''!
cleanPackagesFor: anRGEnvironment

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'package' stamp: ''!
removeClassTag: aSymbol from: anRGPackageDefinition

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
addMethodTag: aSymbol to: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'method' stamp: ''!
setMethodStampFor: anRGMethod to: anObject

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'package' stamp: ''!
cleanTagsForClassesFor: anRGPackage

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'trait alias' stamp: ''!
removeAlias: aSymbol from: anRGTraitAlias

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'method' stamp: ''!
setSourceCodeFor: anRGMethod to: anObject

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'package' stamp: ''!
addDefinedBehavior: anRGBehavior to: anRGPackage

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class comment' stamp: ''!
setClassCommentTimeFor: anRGComment to: aDateAndTime

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
tagMethod: anRGMethod with: aSymbol

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class comment' stamp: ''!
setClassCommentContentFor: anRGComment to: anObject

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'method' stamp: ''!
cleanMethodTagsFor: anRGMethod

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'metaclass' stamp: ''!
setBaseClassFor: anRGBehavior to: anRGClass

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'trait' stamp: ''!
setTraitCommentFor: anRGBehavior to: anRGComment

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
setPackageFor: anRGBehavior to: anRGPackageDefinition

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'method' stamp: ''!
untagMethod: anRGMethod from: aSymbol

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'environment' stamp: ''!
addBehavior: anRGBehavior to: anRGEnvironment

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'method' stamp: ''!
cleanTagsForMethodsFor: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'environment' stamp: ''!
removePackage: anRGPackageDefinition from: anRGEnvironment

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'trait' stamp: ''!
setTraitPackageFor: anRGBehavior to: anRGPackageDefinition

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
removeMethodTag: aSymbol from: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'environment' stamp: ''!
addGlobalVariable: anRGGlobalVariable to: anRGEnvironment

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'method' stamp: ''!
setProtocolFor: anRGMethod to: anObject

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
cleanClassTagsFor: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'package' stamp: ''!
removeExtensionMethod: anRGMethod from: anRGPackage

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'trait exclusion' stamp: ''!
removeExclusion: aSymbol from: anRGTraitExclusion

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
cleanSharedPoolsFor: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'errors' stamp: ''!
readOnlyError

	self error: 'read-only environment'! !

!RGReadOnlyBackend methodsFor: 'class description' stamp: ''!
addInstanceVariable: anRGInstanceVariableDefinition to: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'trait' stamp: ''!
setClassTraitFor: anRGTrait to: anRGMetatraitDefinition

	self readOnlyError ! !

!RGReadOnlyBackend methodsFor: 'class' stamp: ''!
tagClass: anRGBehavior with: aSymbol

	self readOnlyError.! !

!RGReadOnlyBackend methodsFor: 'behavior' stamp: ''!
cleanProtocolsFor: anRGBehavior

	self readOnlyError.! !

!RGReadOnlyBackendTest methodsFor: 'tests' stamp: ''!
testReadOnlyErrors

	| selectors backend |
	
	selectors := #(#addAlias:to: #addBehavior:to: #addClassTag:to: #addClassVariable:to: #addDefinedBehavior:to: #addExclusion:to: #addExtensionMethod:to: #addGlobalVariable:to: #addInstanceVariable:to: #addLocalMethod:to: #addMethodTag:to: #addPackage:to: #addSharedPool:to: #addSlot:to: #addTransformation:to: #cleanAliasesFor: #cleanBehaviorsFor: #cleanClassTagsFor: #cleanClassVariablesFor: #cleanDefinedBehaviorsFor: #cleanExclusionsFor: #cleanExtensionMethodsFor: #cleanGlobalVariablesFor: #cleanInstanceVariablesFor: #cleanLocalMethodsFor: #cleanMethodTagsFor: #cleanPackagesFor: #cleanSharedPoolsFor: #cleanSlotsFor: #cleanTagsForClassesFor: #cleanTagsForMethodsFor: #cleanTransformationsFor: #createNewUnresolvedClass #createNewUnresolvedMetaclassFor: #createNewUnresolvedMetaclassMetaclassFor: #readOnlyError #removeAlias:from: #removeBehavior:from: #removeClassTag:from: #removeClassVariable:from: #removeDefinedBehavior:from: #removeExclusion:from: #removeExtensionMethod:from: #removeGlobalVariable:from: #removeInstanceVariable:from: #removeLocalMethod:from: #removeMethodTag:from: #removePackage:from: #removeSharedPool:from: #removeSlot:from: #removeTransformation:from: #setBaseClassFor:to: #setClassCommentAuthorFor:to: #setClassCommentContentFor:to: #setClassCommentTimeFor:to: #setClassTraitFor:to: #setCommentFor:to: #setExpressionFor:to: #setLayoutFor:to: #setMetaClassFor:to: #setMethodPackageFor:to: #setNameFor:to: #setPackageFor:to: #setProtocolFor:to: #setSourceCodeFor:to: #setSubjectFor:to: #setSuperclassFor:to: #setTraitCommentFor:to: #setTraitPackageFor:to: #tagClass:with: #tagMethod:with: #untagClass:from: #untagMethod:from: cleanProtocolsFor: removeProtocol:from: addProtocol:to:).
	
	backend := self backendClass new.
	
	selectors do: [:selector |
		self should: [backend perform: selector withEnoughArguments: #() ] raise: Error]
! !

!RGReadOnlyBackendTest methodsFor: 'accessing' stamp: ''!
backendClass

	^ RGReadOnlyBackend! !

!RGReadOnlyBackendTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RGReadOnlyBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RGReadOnlyBackendTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RGReadOnlyBackendTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RGReadOnlyBackendTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RGReadOnlyBackendTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RGReadOnlyBackendTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RGReadOnlyBackendTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RGReadOnlyBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGReadOnlyBackendTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RGReadOnlyBackendTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RGReadOnlyBackendTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RGReadOnlyBackendTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RGReadOnlyBackendTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RGReadOnlyBackendTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RGReadOnlyBackendTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RGReadOnlyBackendTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RGReadOnlyBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGReadOnlyBackendTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RGReadOnlyBackendTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RGReadOnlyBackendTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RGReadOnlyBackendTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RGReadOnlyBackendTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RGReadOnlyBackendTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RGReadOnlyBackendTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RGReadOnlyBackendTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RGReadOnlyBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RGReadOnlyBackendTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RGReadOnlyBackendTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RGReadOnlyImageBackend methodsFor: 'trait alias' stamp: ''!
aliasesFor: anRGTraitAlias do: aBlock

	^ (anRGTraitAlias propertyNamed: #realObject ifAbsent: [ self error: 'You can use only trait transformations generated directly by this backend' ]) aliases associations do: [:each | aBlock value: each ]! !

!RGReadOnlyImageBackend methodsFor: 'unresolved objects' stamp: ''!
createUnresolvedClassGroupFor: anRGBehavior 

	^ 	anRGBehavior isMeta
		ifFalse: [ anRGBehavior ]
		ifTrue: [ anRGBehavior metaclass].
! !

!RGReadOnlyImageBackend methodsFor: 'behavior' stamp: ''!
metaclassFor: anRGBehavior

	| realBehavior realMetaclass def |
	
	realBehavior := self realBehaviorFor: anRGBehavior.
	realMetaclass := realBehavior class.
	def := self 	definitionFor: realMetaclass ifAbsentRegister: [ 
			realMetaclass asRingMinimalDefinitionIn: anRGBehavior environment ].
	^ def
! !

!RGReadOnlyImageBackend methodsFor: 'trait' stamp: ''!
traitCommentFor: anRGBehavior

	^  (self realBehaviorFor: anRGBehavior) asRingMinimalCommentDefinitionIn: self environment! !

!RGReadOnlyImageBackend methodsFor: 'method' stamp: ''!
hasSourceCodeFor: anRGMethod 

	^ (self realMethodFor: anRGMethod) sourceCode! !

!RGReadOnlyImageBackend methodsFor: 'package' stamp: ''!
extensionMethodsFor: anRGPackage do: aBlock

	| realPackage |
	
	realPackage := self realPackageFor: anRGPackage.
	realPackage ifNotNil: [ 
		realPackage extensionMethods do: [:aCompiledMethod |
			| def | 
			def := self definitionFor: aCompiledMethod ifAbsentRegister: [aCompiledMethod asRingMinimalDefinitionIn: anRGPackage environment].
			aBlock value: def.]]! !

!RGReadOnlyImageBackend methodsFor: 'class comment' stamp: ''!
classCommentAuthorFor: anRGComment

	^ RGStampParser authorForStamp: (self realBehaviorFor: anRGComment parent) organization commentStamp.
! !

!RGReadOnlyImageBackend methodsFor: 'method' stamp: ''!
methodPackageFor: anRGMethod

	^ (self realMethodFor: anRGMethod) package asRingMinimalDefinitionIn: anRGMethod environment.! !

!RGReadOnlyImageBackend methodsFor: 'method' stamp: ''!
tagsForMethodsFor: anRGBehavior do: aBlock

	(self realBehaviorFor: anRGBehavior) protocols do: aBlock
! !

!RGReadOnlyImageBackend methodsFor: 'behavior' stamp: ''!
traitCompositionFor: anRGBehavior

	| realClass realTraitComposition def |
	
	realClass := self realBehaviorFor: anRGBehavior.
	realTraitComposition := realClass traitComposition.
	def := self 	definitionFor: realTraitComposition ifAbsentRegister: [ 
			realTraitComposition asRingMinimalDefinitionIn: anRGBehavior environment ].
	^ def
! !

!RGReadOnlyImageBackend methodsFor: 'class' stamp: ''!
categoryFor: anRGBehavior

	^ (self realBehaviorFor: anRGBehavior) category
! !

!RGReadOnlyImageBackend methodsFor: 'environment' stamp: ''!
globalVariablesFor: anRGEnvironment do: aBlock

	Smalltalk globals associations do: [:each |
		| def | 
		def := self definitionFor: each ifAbsentRegister: [each asRingMinimalDefinitionIn: anRGEnvironment].
		aBlock value: def.].! !

!RGReadOnlyImageBackend methodsFor: 'class' stamp: ''!
packageFor: anRGBehavior

	^ (self realBehaviorFor: anRGBehavior) package asRingMinimalDefinitionIn: anRGBehavior environment.! !

!RGReadOnlyImageBackend methodsFor: 'method' stamp: ''!
timeFor: anRGMethod

	^ RGStampParser timeForStamp: (self realMethodFor: anRGMethod) stamp! !

!RGReadOnlyImageBackend methodsFor: 'accessing' stamp: ''!
realMethodFor: anRGMethod

	"TODO: should we cache the definition?"
	^ ((self realBehaviorFor: anRGMethod parent) >> anRGMethod selector)
	
! !

!RGReadOnlyImageBackend methodsFor: 'pointer layout' stamp: ''!
slotsFor: anRGLayout do: aBlock
	| realClass |
	realClass := self realBehaviorFor: anRGLayout parent.
	realClass classLayout slots
		do: [ :each | 
			| def |
			def := self
				definitionFor: each
				ifAbsentRegister: [ each asRingMinimalDefinitionIn: anRGLayout environment ].
			aBlock value: def ]! !

!RGReadOnlyImageBackend methodsFor: 'trait exclusion' stamp: ''!
exclusionsFor: anRGTraitExclusion do: aBlock

	^ (anRGTraitExclusion propertyNamed: #realObject ifAbsent: [ self error: 'You can use only trait transformations generated directly by this backend' ]) exclusions do: [:each | aBlock value: each ]! !

!RGReadOnlyImageBackend methodsFor: 'resolving' stamp: ''!
resolvedPropertiesFor: anRGObject

	^ anRGObject pvtResolvableProperties collect: [:each | each key]! !

!RGReadOnlyImageBackend methodsFor: 'class' stamp: ''!
commentFor: anRGBehavior

	^  (self realBehaviorFor: anRGBehavior) asRingMinimalCommentDefinitionIn: self environment! !

!RGReadOnlyImageBackend methodsFor: 'resolving' stamp: ''!
unresolvedPropertiesFor: anRGObject

	^ Dictionary new.! !

!RGReadOnlyImageBackend methodsFor: 'resolving' stamp: ''!
hasFullyResolved: anRGObject

	^ true
! !

!RGReadOnlyImageBackend methodsFor: 'resolving' stamp: ''!
hasResolved: anRGObject

	^ true
! !

!RGReadOnlyImageBackend methodsFor: 'metaclass' stamp: ''!
baseClassFor: anRGMetaclassTrait

	^ (self realBehaviorFor: anRGMetaclassTrait) baseClass asRingMinimalDefinitionIn: anRGMetaclassTrait environment.! !

!RGReadOnlyImageBackend methodsFor: 'behavior' stamp: ''!
layoutFor: anRGBehavior

	| realClass realLayout def |
	
	realClass := self realBehaviorFor: anRGBehavior.
	realLayout := realClass classLayout.
	def := self 	definitionFor: realLayout ifAbsentRegister: [ 
			realLayout asRingMinimalDefinitionIn: anRGBehavior environment ].
	^ def! !

!RGReadOnlyImageBackend methodsFor: 'trait' stamp: ''!
classTraitFor: anRGTrait

	^ (self realBehaviorFor: anRGTrait) classTrait asRingMinimalDefinitionIn: anRGTrait environment.! !

!RGReadOnlyImageBackend methodsFor: 'environment' stamp: ''!
behaviorsFor: anRGEnvironment do: aBlock

	SystemNavigation default allBehaviors do: [:each |
		| def | 
		def := self definitionFor: each ifAbsentRegister: [each asRingMinimalDefinitionIn: anRGEnvironment].
		aBlock value: def.].! !

!RGReadOnlyImageBackend methodsFor: 'class' stamp: ''!
classVariablesFor: anRGBehavior do: aBlock

	| realClass |
	realClass := self realBehaviorFor: anRGBehavior.
	realClass classVariables do: [ :classVariable | 
		| def |
		def := RGClassVariable named: classVariable key parent: anRGBehavior.
		aBlock value: def. ]! !

!RGReadOnlyImageBackend methodsFor: 'package' stamp: ''!
definedBehaviorsFor: anRGPackage do: aBlock

	| realPackage |
	
	realPackage := self realPackageFor: anRGPackage.
	realPackage ifNotNil: [ 
		realPackage definedClassesDo: [:behaviorName |
			| def cls | 
			cls := Smalltalk classOrTraitNamed: behaviorName.
			def := self definitionFor: cls ifAbsentRegister: [cls asRingMinimalDefinitionIn: anRGPackage environment].
			aBlock value: def.]]! !

!RGReadOnlyImageBackend methodsFor: 'behavior' stamp: ''!
localMethodsFor: anRGBehavior do: aBlock

	(self realBehaviorFor: anRGBehavior) localMethods do: [:method |
		| def |
		def := self definitionFor: method ifAbsentRegister: [
			method asRingMinimalDefinitionIn: anRGBehavior environment].
		aBlock value: def]
! !

!RGReadOnlyImageBackend methodsFor: 'method' stamp: ''!
sourceCodeFor: anRGMethod 

	^ (self realMethodFor: anRGMethod) sourceCode
! !

!RGReadOnlyImageBackend methodsFor: 'method' stamp: ''!
tagsForMethod: anRGMethod do: aBlock

	| realMethod |
	
	realMethod := self realMethodFor: anRGMethod.
	{ realMethod protocol } do: aBlock.! !

!RGReadOnlyImageBackend methodsFor: 'class comment' stamp: ''!
classCommentTimeFor: anRGComment

	^ RGStampParser timeForStamp: (self realBehaviorFor: anRGComment parent) organization commentStamp.! !

!RGReadOnlyImageBackend methodsFor: 'trait composition' stamp: ''!
transformationsFor: anRGTraitComposition do: aBlock

	| realBehavior realTraitComposition |
	"^ anRGTraitComposition pvtTransformationsDo: aBlock"

	realBehavior := self realBehaviorFor: anRGTraitComposition parent.
	realTraitComposition := realBehavior traitComposition.

	realTraitComposition transformations do: [:transformation |
		| def |
		def := self definitionFor: transformation ifAbsentRegister: [
			transformation asRingMinimalDefinitionIn: anRGTraitComposition environment].
		aBlock value: def]
! !

!RGReadOnlyImageBackend methodsFor: 'behavior' stamp: ''!
tagsForClass: anRGBehavior do: aBlock

	| realClass |
	
	realClass := self realBehaviorFor: anRGBehavior.
	realClass tags do: [:tag | aBlock value: tag ]
! !

!RGReadOnlyImageBackend methodsFor: 'method' stamp: ''!
authorFor: anRGMethod

	^ RGStampParser authorForStamp: (self realMethodFor: anRGMethod) stamp! !

!RGReadOnlyImageBackend methodsFor: 'class description' stamp: ''!
metaClassFor: anRGBehavior

	| realClass realMetaclass def |
	
	realClass := self realBehaviorFor: anRGBehavior.
	realMetaclass := realClass class.
	def := self 	definitionFor: realMetaclass ifAbsentRegister: [ 
			realMetaclass asRingMinimalDefinitionIn: anRGBehavior environment ].
	^ def
! !

!RGReadOnlyImageBackend methodsFor: 'resolving' stamp: ''!
hasFullyUnresolved: anRGObject		
		
	^ false! !

!RGReadOnlyImageBackend methodsFor: 'metaclass trait' stamp: ''!
metaclassTraitBaseTraitFor: anRGMetaclassTrait
	^ (self realBehaviorFor: anRGMetaclassTrait) instanceSide
		asRingMinimalDefinitionIn: anRGMetaclassTrait environment! !

!RGReadOnlyImageBackend methodsFor: 'slot' stamp: ''!
expressionFor: anRGUnknownSlot

	| realClass realSlot |
	
	realClass := self realBehaviorFor: anRGUnknownSlot parent parent.
	realSlot := realClass slotNamed: anRGUnknownSlot name.
	^ (realSlot printString copyAfter: $>) trimBoth
! !

!RGReadOnlyImageBackend methodsFor: 'accessing' stamp: ''!
realBehaviorFor: anRGBehavior

	"TODO: should we cache the definition?"
	^ Smalltalk classOrTraitNamed: anRGBehavior name asSymbol! !

!RGReadOnlyImageBackend methodsFor: 'accessing' stamp: ''!
realPackageFor: anRGPackage

	^ RPackageOrganizer default packageNamed: anRGPackage name ifAbsent: [nil].! !

!RGReadOnlyImageBackend methodsFor: 'trait transormation' stamp: ''!
subjectFor: anRGTraitTransformation

	^ (anRGTraitTransformation propertyNamed: #realObject ifAbsent: [ self error: 'You can use only trait transformations generated directly by this backend' ]) subject asRingMinimalDefinitionIn: anRGTraitTransformation environment! !

!RGReadOnlyImageBackend methodsFor: 'class comment' stamp: ''!
classCommentContentFor: anRGComment

	^ (self realBehaviorFor: anRGComment parent) organization classComment.
! !

!RGReadOnlyImageBackend methodsFor: 'environment' stamp: ''!
packagesFor: anRGEnvironment do: aBlock

	RPackageOrganizer default packagesDo: [:each |
		| def | 
		def := self definitionFor: each ifAbsentRegister: [each asRingMinimalDefinitionIn: anRGEnvironment].
		aBlock value: def.].! !

!RGReadOnlyImageBackend methodsFor: 'behavior' stamp: ''!
superclassFor: anRGBehavior

	| realClass realSuperclass def |
	
	realClass := self realBehaviorFor: anRGBehavior.
	realSuperclass := realClass superclass.
	realSuperclass ifNil: [ realSuperclass := realClass ].
	def := self 	definitionFor: realSuperclass ifAbsentRegister: [ 
			realSuperclass asRingMinimalDefinitionIn: anRGBehavior environment ].
	^ def
! !

!RGReadOnlyImageBackend methodsFor: 'trait' stamp: ''!
traitPackageFor: anRGBehavior

	^ (self realBehaviorFor: anRGBehavior) package asRingMinimalDefinitionIn: anRGBehavior environment.! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testReadOnlyErrors

	| selectors backend |
	
	selectors := #(#addAlias:to: #addBehavior:to: #addClassTag:to: #addClassVariable:to: #addDefinedBehavior:to: #addExclusion:to: #addExtensionMethod:to: #addGlobalVariable:to: #addInstanceVariable:to: #addLocalMethod:to: #addMethodTag:to: #addPackage:to: #addSharedPool:to: #addSlot:to: #addTransformation:to: #cleanAliasesFor: #cleanBehaviorsFor: #cleanClassTagsFor: #cleanClassVariablesFor: #cleanDefinedBehaviorsFor: #cleanExclusionsFor: #cleanExtensionMethodsFor: #cleanGlobalVariablesFor: #cleanInstanceVariablesFor: #cleanLocalMethodsFor: #cleanMethodTagsFor: #cleanPackagesFor: #cleanSharedPoolsFor: #cleanSlotsFor: #cleanTagsForClassesFor: #cleanTagsForMethodsFor: #cleanTransformationsFor: #createNewUnresolvedClass #createNewUnresolvedMetaclassFor: #createNewUnresolvedMetaclassMetaclassFor: #readOnlyError #removeAlias:from: #removeBehavior:from: #removeClassTag:from: #removeClassVariable:from: #removeDefinedBehavior:from: #removeExclusion:from: #removeExtensionMethod:from: #removeGlobalVariable:from: #removeInstanceVariable:from: #removeLocalMethod:from: #removeMethodTag:from: #removePackage:from: #removeSharedPool:from: #removeSlot:from: #removeTransformation:from: #setBaseClassFor:to: #setClassCommentAuthorFor:to: #setClassCommentContentFor:to: #setClassCommentTimeFor:to: #setClassTraitFor:to: #setCommentFor:to: #setExpressionFor:to: #setLayoutFor:to: #setMetaClassFor:to: #setMethodPackageFor:to: #setNameFor:to: #setPackageFor:to: #setProtocolFor:to: #setSourceCodeFor:to: #setSubjectFor:to: #setSuperclassFor:to: #setTraitCommentFor:to: #setTraitPackageFor:to: #tagClass:with: #tagMethod:with: #untagClass:from: #untagMethod:from: cleanProtocolsFor: removeProtocol:from: addProtocol:to:).
	
	backend := self backendClass new.
	
	selectors do: [:selector |
		self should: [backend perform: selector withEnoughArguments: #() ] raise: Error]
! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testLayouts

	| env layout |
	
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).
	
	layout := (ByteString asRingMinimalDefinitionIn: env) layout.
	self assert: layout isLayout.
	self assert: layout isByteLayout.

	layout := (WordArray asRingMinimalDefinitionIn: env) layout.
	self assert: layout isLayout.
	self assert: layout isWordLayout.	

	layout := (CompiledMethod asRingMinimalDefinitionIn: env) layout.
	self assert: layout isLayout.
	self assert: layout isCompiledMethodLayout.	

	layout := (CompiledMethod asRingMinimalDefinitionIn: env) layout.
	self assert: layout isLayout.
	self assert: layout isCompiledMethodLayout.				
		
	layout := (SmallInteger asRingMinimalDefinitionIn: env) layout.
	self assert: layout isLayout.
	self assert: layout isImmediateLayout.				
		
	layout := (Ephemeron asRingMinimalDefinitionIn: env) layout.
	self assert: layout isLayout.
	self assert: layout isEphemeronLayout.				

	layout := (Object asRingMinimalDefinitionIn: env) layout.
	self assert: layout isLayout.
	self assert: layout isFixedLayout.				

	layout := (Array asRingMinimalDefinitionIn: env) layout.
	self assert: layout isLayout.
	self assert: layout isVariableLayout.				

	layout := (WeakArray asRingMinimalDefinitionIn: env) layout.
	self assert: layout isLayout.
	self assert: layout isWeakLayout.				

			! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testClassComment

	| env comment |
	
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).
	
	comment := (Point asRingMinimalDefinitionIn: env) comment.
	
	comment content notEmpty.
	comment author notEmpty.
	comment time > DateAndTime new.
	comment time <= DateAndTime now.
	
	! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testProtocols
	| env1 point method method2 protocol protocol2 |
	env1 := RGEnvironment new.
	env1 backend: (RGReadOnlyImageBackend for: env1).

	point := Point asRingMinimalDefinitionIn: env1.
	self assert: point protocols notEmpty.
	protocol := point protocols detect: [ :each | each = 'accessing' ].
	self assert: protocol isSymbol.

	method := Point >> #x asRingMinimalDefinitionIn: env1.
	protocol := method protocol.
	method2 := Point >> #y asRingMinimalDefinitionIn: env1.
	protocol2 := method2 protocol.

	self assert: protocol identicalTo: protocol2.
	self assert: protocol isSymbol.
	self assert: protocol equals: 'accessing'.

	self should: [ (Protocol name: 'aProtocol') asRingMinimalDefinitionIn: RGEnvironment new ] raise: Error! !

!RGReadOnlyImageBackendTest methodsFor: 'accessing' stamp: ''!
newEnvironment

	| env | 
	
	env := RGEnvironment unnamed.
	env backend: (RGReadOnlyImageBackend for: env).
	
	^ env! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testBehaviorLocalMethods

	| env1 point selectors |
	
	env1 := RGEnvironment new.
	env1 backend: (RGReadOnlyImageBackend for: env1).

	point := Point asRingMinimalDefinitionIn: env1.
	
	self assert: point ask localMethods size equals: Point localMethods size.
	self assert: (point ask localMethods 
		allSatisfy: [:each | each isKindOf: RGMethod]).
	selectors := point ask localMethods collect: [ :each | each ask selector ].
	self assert: (selectors allSatisfy: [:each | each isSymbol]).
	self assert: selectors asSortedCollection equals: Point localSelectors asSortedCollection.
	
	! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testEmptyLayout

	| env |
	
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).
	
	self should: [EmptyLayout instance asRingMinimalDefinitionIn: env] raise: Error.! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testTraitAlias
	| env traitAlias |
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).

	traitAlias := MOPTestClassD traitComposition transformations first asRingMinimalDefinitionIn: env.
	self assert: traitAlias isTraitAlias.
	self assert: traitAlias subject name equals: #Trait2.
	self assert: traitAlias aliases size equals: 1.
	self assert: traitAlias aliases first key identicalTo: #c3.
	self assert: traitAlias aliases first value identicalTo: #c2! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testDefinitionsIdentity
	| env1 |
	env1 := RGEnvironment new.
	env1 backend: (RGReadOnlyImageBackend for: env1).

	self assert: (Object >> #isRGObject asRingMinimalDefinitionIn: env1) identicalTo: (Object >> #isRGObject asRingMinimalDefinitionIn: env1).

	self assert: (Object >> #isRGObject asRingMinimalDefinitionIn: env1) parent identicalTo: (Object >> #isRGObject asRingMinimalDefinitionIn: env1) parent! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testClassTrait

	| env classTrait |
	
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).
	
	classTrait := RGTestTrait classTrait asRingMinimalDefinitionIn: env.
	self assert: classTrait isTrait.
	self assert: classTrait isMeta.
	self assert: classTrait name equals: 'RGTestTrait classTrait'.
	self assert: classTrait baseTrait name equals: 'RGTestTrait'.
	self assert: classTrait category equals: 'Ring-Tests-Core'.
	self assert: classTrait superclass name equals: #Trait.
	self assert: classTrait comment content equals: RGTestTrait organization comment.
	self assert: classTrait localMethods size equals: RGTestTrait classTrait localMethods size.
	self assert: classTrait protocols asSortedCollection equals: RGTestTrait classTrait protocols asSortedCollection.
	self assert: classTrait metaclass name equals: #MetaclassForTraits.
	self assert: classTrait package name equals: 'Ring-Tests-Core'.
	
! !

!RGReadOnlyImageBackendTest methodsFor: 'accessing' stamp: ''!
testDefaultEnvironmentContent

	| env |
	
	env := RGEnvironment unnamed.
	env backend: (RGReadOnlyImageBackend for: env).
	
	self testDefaultContentFor: env.
	
			
	
	
! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testBehavior
	| env1 point point2 object method |
	env1 := RGEnvironment new.
	env1 backend: (RGReadOnlyImageBackend for: env1).

	point := Point asRingMinimalDefinitionIn: env1.
	"different access method"
	point2 := env1 ask behaviors detect: [ :each | each name == #Point ].
	object := Object asRingMinimalDefinitionIn: env1.
	method := Point >> #x asRingMinimalDefinitionIn: env1.

	self assert: point identicalTo: point2.
	self assert: point superclass identicalTo: object.
	self assert: point identicalTo: method parent.

	self assert: point unresolvedProperties size equals: 0.
	self assert: point ask localMethods size equals: Point localMethods size! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testGlobalVariable
	| env real globalVariable |
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).

	real := Smalltalk globals associations detect: [ :each | each key = #Smalltalk ].
	globalVariable := real asRingMinimalDefinitionIn: env.

	self assert: globalVariable name equals: #Smalltalk! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testSlots

	| env slot |
	
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).
	
	slot := (Point slotNamed: #x) asRingMinimalDefinitionIn: env.
	self assert: slot isSlot.
	self assert: slot name equals: #x.
	self assert: slot parent isLayout.
	self assert: slot parent isFixedLayout.
	self assert: slot parent parent name equals: #Point.
	
! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testTraitComposition

	| env traitComposition |
	
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).
	
	traitComposition := RGTestClass traitComposition asRingMinimalDefinitionIn: env.
	self assert: traitComposition isTraitComposition.
	self assert: traitComposition transformations size equals: 1.
	self assert: traitComposition transformations first name equals: #RGTestTrait.
	self assert: traitComposition transformations first isTrait.
	self assert: traitComposition transformations first isRGObject.
	
	self assert: traitComposition parent traitComposition equals: traitComposition.
	! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testClassVariable
	| env classVariable |
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).

	classVariable := (UIManager classVariableNamed: #Default) asRingMinimalDefinitionIn: env.
	self assert: classVariable isClassVariable.
	self assert: classVariable name equals: #Default.
	self assert: classVariable parent name equals: #UIManager! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testMethod
	| env method |
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).

	method := Point >> #x asRingMinimalDefinitionIn: env.

	self assert: method author notEmpty.
	self assert: (method time <= DateAndTime now).
	self assert: method selector equals: #x.
	self assert: (method package isRGObject and: [ method package isPackage ]).
	self assert: method package name equals: 'Kernel'.
	self assert: method package identicalTo: method parent package.
	self assert: method sourceCode equals: (Point >> #x) sourceCode.
	self assert: method ast equals: (Point >> #x) ast! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testTrait
	| env trait |
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).

	trait := RGTestTrait asRingMinimalDefinitionIn: env.
	self assert: trait isTrait.
	self assert: trait isMeta not.
	self assert: trait name equals: #RGTestTrait.
	self assert: trait classTrait name equals: 'RGTestTrait classTrait'.
	self assert: trait category equals: 'Ring-Tests-Core'.
	self assert: trait superclass identicalTo: trait.	"cycle, nil in reality"
	self assert: trait comment content equals: RGTestTrait organization comment.
	self assert: trait localMethods size equals: RGTestTrait localMethods size.
	self assert: trait protocols asSortedCollection equals: RGTestTrait protocols asSortedCollection.
	self assert: trait metaclass name equals: 'RGTestTrait classTrait'.
	self assert: trait metaclass superclass name equals: 'Trait'.
	self assert: trait package name equals: 'Ring-Tests-Core'! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testTraitExclusions

	| env traitExclusion |
	
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).
	
	traitExclusion := (MOPTestClassB traitComposition transformations second) asRingMinimalDefinitionIn: env.
	self assert: traitExclusion isTraitExclusion.
	self assert: traitExclusion subject name equals: #Trait2.
	self assert: traitExclusion exclusions size equals: 1.
	self assert: traitExclusion exclusions first equals: #c.

	
	
	! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
testUnknownSlots

	| env slot |
	
	env := RGEnvironment new.
	env backend: (RGReadOnlyImageBackend for: env).
	
	slot := (SlotExamplePerson slotNamed: #directedMovies) asRingMinimalDefinitionIn: env.
	self assert: slot isSlot.
	self assert: slot name equals: #directedMovies.
	self assert: slot expression equals: 'ToManyRelationSlot inverse: #director inClass: #SlotExampleMovie'.
	self assert: slot parent isLayout.
	self assert: slot parent isFixedLayout.
	self assert: slot parent parent name equals: #SlotExamplePerson.
	
	
! !

!RGReadOnlyImageBackendTest methodsFor: 'tests' stamp: ''!
backendClass

	^ RGReadOnlyImageBackend ! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RGReadOnlyImageBackendTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RGReadOnlyImageBackendTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RGReadOnlyImageBackendTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RGReadOnlyImageBackendTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RGReadOnlyImageBackendTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RGReadOnlyImageBackendTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGReadOnlyImageBackendTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RGReadOnlyImageBackendTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RGReadOnlyImageBackendTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RGReadOnlyImageBackendTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGReadOnlyImageBackendTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RGReadOnlyImageBackendTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RGReadOnlyImageBackendTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RGReadOnlyImageBackendTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RGReadOnlyImageBackendTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RGReadOnlyImageBackendTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RGReadOnlyImageBackendTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RGReadOnlyImageBackendTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RGResolvingError commentStamp: ''!
I'm a specialized error exception used mainly during failures in applying of changes on Ring models in cases when you cannot determine to which entity in the model the change should be applied. 

!
!RGSlice commentStamp: ''!
A slice is an arbitrary container of elements (working unit)
By inheritance it knows how to treat classes and methods
!
!RGSlice methodsFor: 'adding/removing' stamp: 'nil'!
addElement: aRGDefinition in: aCollection

	aRGDefinition environment: self.
	super addElement: aRGDefinition in: aCollection! !

!RGSlice methodsFor: 'testing' stamp: 'nil'!
isSlice

	^true! !

!RGSliceTest commentStamp: ''!
SUnit tests for slices!
!RGSliceTest methodsFor: 'testing' stamp: ''!
testNewSlice
	| newSlice |
	newSlice := RGSlice named: 'Foo'.

	self assert: newSlice isSlice.
	self assertEmpty: newSlice classes.
	self assert: newSlice environment identicalTo: Smalltalk globals! !

!RGSliceTest methodsFor: 'testing' stamp: ''!
testNestingContainers
	| newSlice newSlice2 newClass newTrait newClass2 |
	newSlice := RGSlice named: #Root.
	newSlice2 := RGSlice named: #Child.
	newSlice2 environment: newSlice.

	newSlice addClassNamed: #OrderedCollection.
	newClass := newSlice classNamed: #OrderedCollection.
	newSlice addTraitNamed: #TSortable.
	newTrait := newSlice traitNamed: #TSortable.
	newSlice2 addClassNamed: #SortedCollection.
	newClass2 := newSlice classNamed: #SortedCollection.

	self assert: newSlice classes size equals: 2.
	self assert: newSlice2 classes size equals: 1.
	self assert: newSlice2 environment equals: newSlice.
	self assert: newSlice2 rootEnvironment equals: newSlice environment! !

!RGSliceTest methodsFor: 'testing' stamp: ''!
testAddingClasses
	| newSlice newClass newTrait |
	newSlice := RGSlice named: 'Foo'.
	newClass := RGClassDefinition named: #OrderedCollection.
	newTrait := RGTraitDefinition named: #TSortable.

	newSlice
		addClassNamed: #SortedCollection;
		addClass: newClass;
		addTrait: newTrait.

	self assert: newSlice classes size equals: 3.
	self assert: newSlice traits size equals: 1.
	self assert: (newSlice includesClassNamed: #OrderedCollection).
	self assert: (newSlice classNamed: #OrderedCollection) identicalTo: newClass.
	self assert: (newSlice traitNamed: #TSortable) identicalTo: newTrait.
	self assert: (newClass isIncludedInContainer: newSlice).
	self assert: (newTrait isIncludedInContainer: newSlice).
	self assert: newSlice allClasses size equals: 3.
	self assert: newSlice allTraits size equals: 1.
	self assert: newClass parent equals: newSlice.
	self assert: newClass rootEnvironment equals: newSlice environment! !

!RGSlot methodsFor: 'accessing' stamp: ''!
definitionString

	^ String streamContents: [ :aStream |
		aStream nextPutAll: '#'; nextPutAll: self name]! !

!RGSlot methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ self defaultFixedLayoutStub! !

!RGSlot methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode 
	^ aProgramNodeVisitor visitInstanceVariableNode: aNode! !

!RGSlot methodsFor: 'testing - types' stamp: ''!
isSlot

	^ true! !

!RGSlot methodsFor: 'accessing' stamp: ''!
name: aString

	self parent parent announceDefinitionChangeDuring: [ 
		super name: aString ].! !

!RGSlot methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	super addoptToParentStub.
	self parent addSlot: self.! !

!RGSlot methodsFor: 'bootstrap' stamp: ''!
accept: anInterpreter assign: aValue inNode: aVariableNode
	self error: #TBD! !

!RGSlot methodsFor: 'testing' stamp: ''!
isInstanceVariable
	^ true! !

!RGSlotTest methodsFor: 'tests' stamp: ''!
testSlotsImplicitEnvironment

	| layout |
	
	layout := RGInstanceVariableSlot unnamed.
	self assert: (layout hasUnresolved: #name).
	self assert: (layout parent isLayout).
	self checkImplicitSingleClassEnvironmentOf: layout parent parent.
	
	
	
	
! !

!RGSlotTest methodsFor: 'tests' stamp: ''!
testNewSlot

	| slot | 
	slot  := RGFixedLayout unnamed.
	self assert: (slot isRingResolved).
	self assert: (slot hasUnresolved: #name).
	self assert: (slot isLayout).
	! !

!RGSlotTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGInstanceVariableSlot unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGSlotTest methodsFor: 'tests' stamp: ''!
testResolvingConsistencyUnknown

	| anObject |
	anObject := RGUnknownSlot unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGSlotTest methodsFor: 'tests' stamp: ''!
testUnknownSlot

	| slot expression | 
	slot  := RGUnknownSlot unnamed.
	self assert: (slot isRingResolved).
	self assert: (slot hasUnresolvedAll: #(name expression)).
	self assert: (slot isSlot).
	expression := 'ToManyRelationSlot inverse: #director inClass: #SlotExampleMovie'.
	slot expression: expression.
	self assert: slot expression equals: expression.
	! !

!RGStampParser methodsFor: 'parsing' stamp: ''!
parseTimestampFrom: aString
	
	^self parseTimestampFrom: aString default: nil! !

!RGStampParser methodsFor: 'parsing stamp' stamp: ''!
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:
		<authorname><date><time>. 
		<authorname><date>
		<date><time>
		<date><time><authorname>
		<date><authorname>
		<historical>
	All fields can be separated by spaces or line ends but a separator between author alias/name and date can be missing as well"
	"unknown:= 'unknown'."
	
	aString = '<historical>' ifTrue: [ ^ aString ].
	
	unknown := nil.
	aString isEmptyOrNil
		ifTrue: [ ^ unknown ].
	dateStartIndex := (aString indexOf: $/) - 1.	"If there is no / character in the timestamp, no author alias/name exists"
	dateStartIndex = -1
		ifTrue: [ ^ unknown ].
	^ [ 
	"Go the start of the date string (there can be 1 or 2 digits and a space separator can be missing at the front!!!!)"
	(dateStartIndex >= 2 and: [ (aString at: dateStartIndex - 1) isDigit ])
		ifTrue: [ dateStartIndex := dateStartIndex - 1 ].	"Extract only those tokens that do not possible represent date or time - meaning that authorname may be at the end"
	tokens := (aString copyFrom: dateStartIndex to: aString size) substrings
		reject: [ :token | (token occurrencesOf: $/) = 2 or: [ (token occurrencesOf: $:) = 1 ] ].	"only one token should be left if author name/alias exists"
	^ tokens isEmpty
		ifTrue: [ 
			"if dateStartIndex is not 1 then the authorname may be at the beginning"
			dateStartIndex > 1
				ifTrue: [ (aString copyFrom: 1 to: dateStartIndex - 1) trimBoth ]
				ifFalse: [ unknown ] ]
		ifFalse: [ tokens first ] ]
		on: Exception
		do: [ :e | unknown ]! !

!RGStampParser methodsFor: 'parsing stamp' stamp: ''!
timeForStamp: stamp

	^ stamp
		ifNil: [ 	DateAndTime new]
		ifNotNil: [ 
			| substrings |
			substrings := stamp substrings.
			([(DateAndTime fromString: (' ' join: substrings allButFirst ))] on: Exception do: [DateAndTime epoch]) ]. 
	! !

!RGStampParser methodsFor: 'parsing stamp' stamp: ''!
parseAuthorAliasFrom: aString
	"Allows other applications  to treat a different empty alias by overriding this method"
	
	^self basicParseAuthorAliasFrom: aString! !

!RGStampParser methodsFor: 'parsing' stamp: ''!
parseTimestampFrom: aString default: anObject
	"Parse a date-time from a timestamp-string that is extracted from a source file. If there is no timestamp, or we cannot make sense of it, we return the default value."

	| tokens dateStartIndex unknown |
	"The following timestamp strings are supported:
		<authorname><date><time>. 
		<authorname><date>
		<date><time>
		<date><time><authorname>
		<date><authorname>
		<historical>
	All fields can be separated by spaces or line ends but a separator between authorname and date can be missing as well"
	unknown := anObject.
	aString isEmptyOrNil
		ifTrue: [ ^ unknown ].
	dateStartIndex := (aString indexOf: $/) - 1.	"If there is no / character in the timestamp, we cannot parse a date and return the epoch"
	dateStartIndex = -1
		ifTrue: [ ^ unknown ].
	^ [ 
	"Go the start of the date string (there can be 1 or 2 digits and a space separator can be missing at the front!!!!)"
	(dateStartIndex >= 2 and: [ (aString at: dateStartIndex - 1) isDigit ])
		ifTrue: [ dateStartIndex := dateStartIndex - 1 ].	"Extract only those tokens that possibly represent date or time"
	tokens := (aString copyFrom: dateStartIndex to: aString size) substrings
		select: [ :token | (token occurrencesOf: $/) = 2 or: [ (token occurrencesOf: $:) = 1 ] ].	"2 tokens is a datetime"
	tokens size = 2
		ifTrue: [ (tokens joinUsing: Character space) asDateAndTime ]
		ifFalse: [ tokens first asDate asDateAndTime ] ]
		on: Exception
		do: [ :e | unknown ]! !

!RGStampParser class methodsFor: 'parsing' stamp: ''!
parseTimestampFrom: aString
		
	^ self new parseTimestampFrom: aString! !

!RGStampParser class methodsFor: 'parsing' stamp: ''!
timeForStamp: stamp

	^ self new timeForStamp: stamp! !

!RGStampParser class methodsFor: 'parsing' stamp: ''!
historicalStamp

	^ '<historical>'! !

!RGStampParser class methodsFor: 'parsing' stamp: ''!
authorForStamp: aString
	
	^ aString isEmptyOrNil
		ifTrue: [ self historicalStamp ]
		ifFalse: [ self parseAuthorAliasFrom: aString ].! !

!RGStampParser class methodsFor: 'parsing' stamp: ''!
parseAuthorAliasFrom: aString
		
	^ self new basicParseAuthorAliasFrom: aString! !

!RGStampParserTest methodsFor: 'tests' stamp: ''!
testAuthor

	"TODO: improve"
	self assert: (RGStampParser parseAuthorAliasFrom: 'StephaneDucasse 11/10/2015 18:13') equals: 'StephaneDucasse'.
	
! !

!RGStampParserTest methodsFor: 'tests' stamp: ''!
testTime

	"TODO: improve"
	self assert: (RGStampParser parseTimestampFrom: '11/10/2015 18:13') equals: '2015-11-10T18:13:00' asDateAndTime.
	
! !

!RGTest methodsFor: 'tests' stamp: ''!
checkIncompatible: aBlock

	"prove that the block tries to do an action not suitable for a particular behavior strategy"

	self should: aBlock raise: RGIncompatibleBehaviorTypeError
! !

!RGTest methodsFor: 'utilities' stamp: ''!
checkImplicitSingleClassEnvironmentOf: anRGClass
	
	self deny: (anRGClass isRingResolved).

	"we have SomeClass, SomeClass class, SomeClass superclass, SomeClass superclass class"
	self assert: anRGClass environment ask behaviors size equals: 4.

	"we have one package for SomeClass and SomeClass class, other for SomeClass superclass 
	and SomeClass superclass class"	
	self assert: anRGClass environment ask packages size equals: 2.

	self checkHierarchyConsistencyOf: anRGClass.
	
	
	
! !

!RGTest methodsFor: 'utilities' stamp: ''!
checkImplicitSingleTraitEnvironmentOf: anRGTrait
	self assert: anRGTrait environment ask behaviors size equals: 10.
	self assert: anRGTrait environment ask packages size equals: 5.

	self checkHierarchyConsistencyOf: anRGTrait metaclass.

	self assert: anRGTrait ~~ anRGTrait classTrait.
	self assert: anRGTrait superclass identicalTo: anRGTrait superclass.
	self assert: anRGTrait classTrait superclass identicalTo: anRGTrait classTrait superclass! !

!RGTest methodsFor: 'utilities' stamp: ''!
checkHierarchyConsistencyOf: anRGClass
	"prove that all relations between class, superclass, metaclass and superclass metaclass are consistent"

	self assert: anRGClass ~~ anRGClass superclass.
	self assert: anRGClass ~~ anRGClass metaclass.
	self assert: anRGClass ~~ anRGClass superclass metaclass.

	self assert: anRGClass superclass ~~ anRGClass metaclass.
	self assert: anRGClass superclass ~~ anRGClass superclass metaclass.
	self assert: anRGClass metaclass ~~ anRGClass superclass metaclass.

	self assert: anRGClass superclass superclass identicalTo: anRGClass superclass.
	self assert: anRGClass superclass metaclass identicalTo: anRGClass metaclass superclass.

	self assert: anRGClass superclass metaclass superclass identicalTo: anRGClass superclass metaclass.
	self assert: anRGClass superclass metaclass metaclass identicalTo: anRGClass superclass metaclass! !

!RGTest methodsFor: 'tests' stamp: ''!
checkClassesConsistency: object1 and: object2

	"check if instance variables have the same types (after sending of #value)"

	self assert: (object1 class instVarNames collect: [ :var | 
		var -> (object1 instVarNamed: var) value class ]) 
		equals: (object2 class instVarNames collect: [ :var | 
		var -> (object2 instVarNamed: var) value class ]) ! !

!RGTestClass class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RGTestClass class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RGTestClass class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RGTestClass class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RGTestClass class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RGTestClass class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RGTestClass class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RGTestClass class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RGTestClass class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGTestClass class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RGTestClass class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RGTestClass class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RGTestClass class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RGTestClass class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RGTestClass class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RGTestClass class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RGTestClass class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RGTestClass class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGTestClass class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RGTestClass class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RGTestClass class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RGTestClass class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RGTestClass class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RGTestClass class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RGTestClass class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RGTestClass class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RGTestClass class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RGTestClass class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RGTestClass class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RGTestTrait classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RGTestTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RGTestTrait classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RGTestTrait classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RGTestTrait classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RGTestTrait classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RGTestTrait classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RGTestTrait classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RGTestTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGTestTrait classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RGTestTrait classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RGTestTrait classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RGTestTrait classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RGTestTrait classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RGTestTrait classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RGTestTrait classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RGTestTrait classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RGTestTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGTestTrait classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RGTestTrait classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RGTestTrait classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RGTestTrait classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RGTestTrait classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RGTestTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RGTestTrait classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RGTestTrait classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RGTrait commentStamp: ''!
A factory that produces instances of RGBehavior composed with RGTraitStrategy!
!RGTrait class methodsFor: 'instance creation' stamp: ''!
strategyClassForVersion: aVersionNumber

	^ (aVersionNumber <= 6)
		ifTrue: [ RGTraitStrategy ]
		ifFalse: [ RGTraitV2Strategy ]
! !

!RGTrait class methodsFor: 'instance creation' stamp: ''!
newStrategy

	^ RGTraitStrategy basicNew! !

!RGTrait class methodsFor: 'instance creation' stamp: ''!
newStrategyFor: anRGEnvironment

	^ (self strategyClassForVersion: anRGEnvironment version) basicNew
! !

!RGTraitAlias methodsFor: 'queries - aliases' stamp: ''!
aliases

	| allAliases |
	allAliases := OrderedCollection new.
	self aliasesDo: [ :each | allAliases add: each].
	^ allAliases 
! !

!RGTraitAlias methodsFor: 'accessing - backend' stamp: ''!
cleanAliases

	self parent parent announceDefinitionChangeDuring: [ 
		self backend forBehavior cleanAliasesFor: self ].! !

!RGTraitAlias methodsFor: 'private - backend access' stamp: ''!
pvtRemoveAlias: aSymbol

	aliases remove: aSymbol.! !

!RGTraitAlias methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.
	
	aliases := self unresolvedValue: self defaultAliases.! !

!RGTraitAlias methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ String streamContents: [:aStream |	
		aStream 
			nextPutAll: self subject traitTransformationString;
			space;
			nextPut: $@;
			space;
			nextPut: ${.
	self aliases do: [:each | aStream print: each]
		separatedBy: [aStream nextPutAll: '. '].
	aStream nextPut: $}].! !

!RGTraitAlias methodsFor: 'private - backend access' stamp: ''!
pvtCleanAliases

	aliases := self defaultAliases.! !

!RGTraitAlias methodsFor: 'initialize' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	aliases := self unresolvedValue: self defaultAliases.! !

!RGTraitAlias methodsFor: 'default model values' stamp: ''!
defaultAliases

	^ OrderedCollection new! !

!RGTraitAlias methodsFor: 'private - backend access' stamp: ''!
pvtAliasesDo: aBlock

	aliases value do: aBlock! !

!RGTraitAlias methodsFor: 'accessing - backend' stamp: ''!
removeAlias: aSymbol

	self parent parent announceDefinitionChangeDuring: [ 
		self backend forBehavior removeAlias: aSymbol from: self ].! !

!RGTraitAlias methodsFor: 'accessing - backend' stamp: ''!
addAlias: aSymbol 

	self parent parent announceDefinitionChangeDuring: [ 
		self backend forBehavior addAlias: aSymbol to: self ].! !

!RGTraitAlias methodsFor: 'accessing - backend' stamp: ''!
aliasesDo: aBlock

	self backend forBehavior aliasesFor: self do: aBlock! !

!RGTraitAlias methodsFor: 'testing - types' stamp: ''!
isTraitAlias

	^ true! !

!RGTraitAlias methodsFor: 'queries - methods' stamp: ''!
methods

	"TODO"
	^ self subject methods reject: [ :each | self aliases includes: each name  ]! !

!RGTraitAlias methodsFor: 'resolving' stamp: ''!
makeResolved

	super makeResolved.
	
	aliases := self aliases markAsRingResolved.
! !

!RGTraitAlias methodsFor: 'accessing' stamp: ''!
traitTransformationString

	^ String streamContents: [:aStream |	
		aStream 
			nextPut: $(;
			nextPutAll: self subject name;
			space;
			nextPut: $@;
			space;
			nextPut: ${.
	self aliases do: [:each | aStream print: each]
		separatedBy: [aStream nextPutAll: '. '].
	aStream nextPut: $}.
	aStream nextPut: $)].! !

!RGTraitAlias methodsFor: 'private - backend access' stamp: ''!
pvtAddAlias: aSymbol

	aliases isRingResolved ifFalse: [ 
		self pvtCleanAliases  ].
	
	aliases add: aSymbol.	! !

!RGTraitAlias methodsFor: 'private - backend access' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#aliases -> aliases. 
	}
	
	! !

!RGTraitAliasTest methodsFor: 'tests' stamp: ''!
testAliasesCollection
	
	| traitAlias env alias1 alias2 alias3 |

	traitAlias := RGTraitAlias unnamed.
	env := traitAlias environment.

	self assert: traitAlias aliases isEmpty.
	self assert: (traitAlias hasUnresolved: #aliases).
	
	alias1 := (#m2 -> #m1).
	traitAlias addAlias: alias1.
	self assert: traitAlias aliases size equals: 1.

	self assert: (traitAlias hasResolved: #aliases).
	
	alias2 := (#m4 -> #m3).
	traitAlias addAlias: alias2.
	self assert: traitAlias aliases size equals: 2.
	
	alias3 := (#m6 -> #m5).
	traitAlias addAlias: alias3.
	self assert: traitAlias aliases size equals: 3.

	traitAlias removeAlias: alias3.
	self assert: traitAlias aliases size equals: 2.

	traitAlias cleanAliases.
	self assert: traitAlias aliases isEmpty.
	self assert: (traitAlias hasResolved: #aliases).
! !

!RGTraitAliasTest methodsFor: 'tests' stamp: ''!
testImplicitEnvironment
	
	| def def2 env |

	def := RGTraitAlias unnamed.
	env := def environment.

	self assert: (def isRingResolved).
		
	self assert: def parent isTraitComposition.
	self assert: def parent isRingResolved not.

	self assert: def parent parent isClass.
	self assert: def parent parent isRingResolved not.
	
	self assert: def parent transformations size equals: 1.

	self checkImplicitSingleClassEnvironmentOf: def parent parent.	

	def2 := RGTraitAlias parent: def parent.
	def parent addTransformation: def2.
	
	self checkImplicitSingleClassEnvironmentOf: def parent parent.	
	
	self assert: def parent transformations size equals: 2.
! !

!RGTraitAliasTest methodsFor: 'tests' stamp: ''!
testNewTraitAlias

	| traitAlias | 
	traitAlias  := RGTraitAlias unnamed.
	self assert: (traitAlias isRingResolved).
	self assert: (traitAlias hasUnresolvedAll: #(name subject aliases)).
	self assert: (traitAlias isTraitTransformation).
	! !

!RGTraitAliasTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGTraitAlias unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGTraitAliasTest methodsFor: 'tests' stamp: ''!
testUsedTraits

	| traitAlias trait usedTraits | 
	
	traitAlias := RGTraitAlias unnamed.
	trait := traitAlias environment ensureTraitNamed: #SomeTrait.
	traitAlias subject: trait.
	usedTraits := traitAlias usedTraits.
	
	self assert: usedTraits size equals: 1.
	self assert: usedTraits anyOne equals: trait.
	
	self assert:  traitAlias trait equals: trait.! !

!RGTraitComposition methodsFor: 'accessing - backend' stamp: ''!
cleanTransformations

	self parent announceDefinitionChangeDuring: [ 
		self backend forBehavior cleanTransformationsFor: self ].! !

!RGTraitComposition methodsFor: 'accessing' stamp: ''!
traitCompositionString

	self transformations isEmpty ifTrue: [ ^ '{}' ].
	
	^String streamContents: [ :stream | 
		self transformations 
			do: [ :each | stream nextPutAll: each traitTransformationString ]
			separatedBy: [ stream nextPutAll: ' + ' ] ]	
	! !

!RGTraitComposition methodsFor: 'private - backend access' stamp: ''!
pvtCleanTransformations

	transformations := self defaultTransformations.! !

!RGTraitComposition methodsFor: 'private - backend access' stamp: ''!
pvtTransformationsDo: aBlock

	transformations value do: aBlock! !

!RGTraitComposition methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ self defaultClassStub! !

!RGTraitComposition methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	transformations := self unresolvedValue: self defaultTransformations.! !

!RGTraitComposition methodsFor: 'testing - types' stamp: ''!
isTraitComposition

	^ true! !

!RGTraitComposition methodsFor: 'accessing - backend' stamp: ''!
removeTransformation: anRGTraitTransformation

	self parent announceDefinitionChangeDuring: [ 
		self backend forBehavior removeTransformation: anRGTraitTransformation from: self ].! !

!RGTraitComposition methodsFor: 'accessing - backend' stamp: ''!
addTransformation: anRGTraitTransformation 

	self parent announceDefinitionChangeDuring: [ 
		self backend forBehavior addTransformation: anRGTraitTransformation to: self ].! !

!RGTraitComposition methodsFor: 'accessing - backend' stamp: ''!
transformationsDo: aBlock

	self backend forBehavior transformationsFor: self do: aBlock! !

!RGTraitComposition methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	transformations := self unresolvedValue: self defaultTransformations.! !

!RGTraitComposition methodsFor: 'queries - transformations' stamp: ''!
transformations

	| allTransformations |
	allTransformations := OrderedCollection new.
	self transformationsDo: [ :each | allTransformations add: each].
	^ allTransformations
! !

!RGTraitComposition methodsFor: 'accessing' stamp: ''!
usedTraits

	^ self transformations flatCollect: [ :each | 
		each isTrait 
			ifTrue: [ {each} ]
			ifFalse: [ each usedTraits ].
		 ] as: IdentitySet! !

!RGTraitComposition methodsFor: 'accessing' stamp: ''!
referencedBehaviors

	^ self transformations collect: [ :each |
		each isTrait 
			ifTrue: [ each ]
			ifFalse: [ each subject ] ]! !

!RGTraitComposition methodsFor: 'accessing' stamp: ''!
traits

	^ self transformations collect: [:each | each trait ]! !

!RGTraitComposition methodsFor: 'private - backend access' stamp: ''!
pvtAddTransformation: anRGTraitTransformation

	self environment verifyOwnership: anRGTraitTransformation.
	
	transformations isRingResolved ifFalse: [ 
		self pvtCleanTransformations  ].
	
	transformations add: anRGTraitTransformation.	! !

!RGTraitComposition methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	super addoptToParentStub.

	self environment backend createUnresolvedClassGroupFor: self parent! !

!RGTraitComposition methodsFor: 'queries - methods' stamp: ''!
methods

	^ Array streamContents: [ :stream | 
		self transformationsDo: [ :transformation | stream nextPutAll: transformation methods ]]! !

!RGTraitComposition methodsFor: 'resolving' stamp: ''!
makeResolved

	super makeResolved.
	
	transformations := self transformations markAsRingResolved.
! !

!RGTraitComposition methodsFor: 'private - backend access' stamp: ''!
pvtRemoveTransformation: anRGTraitTransformation

	self environment verifyOwnership: anRGTraitTransformation.
	
	transformations remove: anRGTraitTransformation.! !

!RGTraitComposition methodsFor: 'private - backend access' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#transformations -> transformations. 
	}
	
	! !

!RGTraitComposition methodsFor: '*Ring-RuntimeSupport' stamp: ''!
allTraits

	^self traits flatCollect: [:trait |
		trait hasTraitComposition
			ifTrue: [trait traitComposition allTraits copyWith: trait]
			ifFalse: [Array with: trait]]! !

!RGTraitComposition methodsFor: 'accessing' stamp: ''!
defaultTransformations

	^ OrderedCollection new! !

!RGTraitCompositionTest methodsFor: 'tests' stamp: ''!
testImplicitEnvironment
	
	| def def2 env |

	def := RGTraitComposition unnamed.
	env := def environment.

	self checkImplicitSingleClassEnvironmentOf: def parent.	

	self assert: (def isRingResolved).
	
	def2 := RGTraitComposition parent: def parent .
	self checkImplicitSingleClassEnvironmentOf: def parent.	
! !

!RGTraitCompositionTest methodsFor: 'tests' stamp: ''!
testTransformationsCollection
	
	| traitComposition env transformation1 transformation2 transformation3 |

	traitComposition := RGTraitComposition unnamed.
	env := traitComposition environment.

	self assert: traitComposition transformations isEmpty.
	self assert: (traitComposition hasUnresolved: #transformations).
	
	transformation1 := RGTraitComposition parent: env.
	env addBehavior: transformation1.
	traitComposition addTransformation: transformation1.
	self assert: traitComposition transformations size equals: 1.

	self assert: (traitComposition hasResolved: #transformations).
	
	transformation2 := RGTraitAlias parent: traitComposition.
	traitComposition addTransformation: transformation2.
	self assert: traitComposition transformations size equals: 2.
	
	transformation3 := RGTraitExclusion parent: traitComposition.
	traitComposition addTransformation: transformation3.
	self assert: traitComposition transformations size equals: 3.

	traitComposition removeTransformation: transformation3.
	self assert: traitComposition transformations size equals: 2.

	traitComposition cleanTransformations.
	self assert: traitComposition transformations isEmpty.
	self assert: (traitComposition hasResolved: #transformations).
! !

!RGTraitCompositionTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGTraitComposition unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGTraitCompositionTest methodsFor: 'tests' stamp: ''!
testNewTraitComposition

	| traitComposition | 
	traitComposition  := RGTraitComposition unnamed.
	self assert: (traitComposition isRingResolved).
	self assert: (traitComposition hasUnresolvedAll: #(name transformations)).
	self assert: (traitComposition isTraitComposition).
	! !

!RGTraitCompositionTest methodsFor: 'tests' stamp: ''!
testUsedTraits
	| traitComposition env trait1 trait2 trait3 trait4 transformation2 transformation3 usedTraits |
	traitComposition := RGTraitComposition unnamed.
	env := traitComposition environment.
	trait1 := env ensureTraitNamed: #SomeTrait1.
	trait2 := env ensureTraitNamed: #SomeTrait2.
	trait3 := env ensureTraitNamed: #SomeTrait3.
	trait4 := env ensureTraitNamed: #SomeTrait4.
	traitComposition addTransformation: trait1.
	transformation2 := RGTraitAlias parent: traitComposition.
	transformation2 subject: trait2.
	traitComposition addTransformation: transformation2.
	self assert: traitComposition transformations size equals: 2.
	transformation3 := RGTraitExclusion
		parent: traitComposition.
	transformation3 subject: trait3.
	traitComposition addTransformation: transformation3.
	self assert: traitComposition transformations size equals: 3.
	usedTraits := traitComposition usedTraits.
	self assert: usedTraits size equals: 3.
	self
		assert:
			(usedTraits
				includesAll:
					{trait1.
					trait2.
					trait3})! !

!RGTraitCompositionTest methodsFor: 'tests' stamp: ''!
testGlobalVariablesCollection
	
	| globalVariable globalVariable2 env |

	env := RGEnvironment new.

	self assert: env ask globalVariables isEmpty.
	self assert: (env hasUnresolved: #globalVariables).
	
	globalVariable := RGGlobalVariable named: #SomeGlobal parent: env.
	env addGlobalVariable: globalVariable.
	self assert: env ask globalVariables size equals: 1.

	self assert: (env hasResolved: #globalVariables).
	
	globalVariable2 := RGGlobalVariable named: #SomeGlobal2 parent: env.
	env addGlobalVariable: globalVariable2.
	self assert: env ask globalVariables size equals: 2.
	
	env removeGlobalVariable: globalVariable2.
	self assert: env ask globalVariables size equals: 1.

	env cleanGlobalVariables.
	self assert: env ask globalVariables isEmpty.
	self assert: (env hasResolved: #globalVariables).
! !

!RGTraitCompositionVisitor commentStamp: ''!
ast := (RBParser parseExpression: 'Trait1 + Trait2 + Trait3 + Trait4').
ast := (RBParser parseExpression: '(Trait2 - {#c})').
ast := (RBParser parseExpression: 'Trait1 + (Trait2 - {#c})').
ast := (RBParser parseExpression: 'Trait1 + (Trait2 - {#c}) + Trait3').
ast := (RBParser parseExpression: 'Trait1 + (Trait2 - #(c ahoj bla: bla:bla:)) + Trait3').

composition := RGTraitComposition unnamed.

visitor := RGTraitCompositionVisitor new.
visitor traitComposition: composition.
ast acceptVisitor: visitor.




!
!RGTraitCompositionVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aRBLiteralArrayNode 

	^ aRBLiteralArrayNode contents collect: [:each | self visitNode: each]! !

!RGTraitCompositionVisitor methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode 

	^ aSequenceNode statements collect: [:each | self visitNode: each].! !

!RGTraitCompositionVisitor methodsFor: 'parsing' stamp: ''!
parse: anExpressionString for: anRGTraitCompositionDefinition

	| ast result |
	ast := (RBParser parseExpression: anExpressionString).
	self traitComposition: anRGTraitCompositionDefinition.
	result := ast acceptVisitor: self.
	
	result isCollection 
		ifFalse: [ result := OrderedCollection with: result. ].
		
	^ result.! !

!RGTraitCompositionVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralNode: aLiteralNode

	^ aLiteralNode value! !

!RGTraitCompositionVisitor methodsFor: 'visiting' stamp: ''!
visitArrayNode: anArrayNode 

	^ anArrayNode children collect: [:each | self visitNode: each] ! !

!RGTraitCompositionVisitor methodsFor: 'accessing' stamp: ''!
traitComposition
	^ traitComposition! !

!RGTraitCompositionVisitor methodsFor: 'visiting' stamp: ''!
visitMessageNode: aMessageNode 
	
	| rec args | 
	rec := (self visitNode: aMessageNode receiver).
	args := (aMessageNode arguments collect: [ :each | self visitNode: each ]).

	(aMessageNode selector = #+) ifTrue: [
		rec isCollection 
			ifTrue: [ rec add: args first ]
			ifFalse: [ rec := { rec. args first } asOrderedCollection ].
		^ rec].
	
	(aMessageNode selector = #-) ifTrue: [ 
		| exclusion | 
		exclusion := RGTraitExclusion parent: self traitComposition.
		exclusion pvtSubject: rec.
		exclusion pvtCleanExclusions.
		args first do: [:each | exclusion pvtAddExclusion: each ]. 
		^ exclusion].
	
	"an Array(Trait2 @ {#c3->#c2})"
	(aMessageNode selector = #@) ifTrue: [ 
		| exclusion | 
		exclusion := RGTraitAlias parent: self traitComposition.
		exclusion pvtSubject: rec.
		exclusion pvtCleanAliases.
		args first do: [:each | exclusion pvtAddAlias: each ]. 
		^ exclusion].

	(aMessageNode selector = #->) ifTrue: [
		"for associations in aliases"
		^ rec -> args first
		].
	
	(aMessageNode selector = #classTrait) ifTrue: [
		"for associations in aliases"
		rec classTrait makeResolved.
		rec classTrait name: rec name, ' classTrait'.
		^ rec classTrait.
		].

	self error: 'Unknown trait composition message'.! !

!RGTraitCompositionVisitor methodsFor: 'accessing' stamp: ''!
traitComposition: anObject
	traitComposition := anObject.
	traitComposition pvtCleanTransformations.! !

!RGTraitCompositionVisitor methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode
	
	^ self traitComposition environment ensureTraitNamed: aVariableNode name
! !

!RGTraitDefinition commentStamp: ''!
RGTraitDefinition is the concrete representation of a trait (no class)!
!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
stamp

	^self hasComment ifTrue:[ self comment stamp ] ifFalse:[ nil ]! !

!RGTraitDefinition methodsFor: 'testing' stamp: 'nil'!
hasMetaclass

	^metaClass notNil! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
stamp: aString

	self hasComment
	ifTrue: [ self comment stamp: aString ]
	ifFalse:[ RGCommentDefinition new
						 parent: self; 
						 stamp: aString ]! !

!RGTraitDefinition methodsFor: 'accessing - parallel hierarchy' stamp: 'nil'!
classSide
	"Return the metaclass of the couple class/metaclass. Useful to avoid explicit test."
	^ metaClass! !

!RGTraitDefinition methodsFor: 'testing' stamp: 'nil'!
hasComment

	^comment isEmptyOrNil not! !

!RGTraitDefinition methodsFor: 'behavior' stamp: 'nil'!
withMetaclass
	"Registers explicitly the metaclass of a trait"

	metaClass:= RGMetatraitDefinition class: self.
! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
inheritsFrom: aClass

	^ self realClass inheritsFrom: aClass! !

!RGTraitDefinition methodsFor: 'testing' stamp: 'nil'!
isSameRevisionAs: aRGTraitDefinition
	"This method look for equality of the properties of the receiver"

	^(super isSameRevisionAs: aRGTraitDefinition)
		and: [ self category = aRGTraitDefinition category 
		and: [ self traitCompositionSource = aRGTraitDefinition traitCompositionSource 
		and: [ ((self hasComment and: [ self comment isSameRevisionAs: aRGTraitDefinition comment ]) or:[ self hasComment not ])
		and: [ (self classSide isSameRevisionAs: aRGTraitDefinition classSide) ] ] ] ]! !

!RGTraitDefinition methodsFor: 'testing' stamp: 'nil'!
hasStamp

	^self stamp isEmptyOrNil not! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
category: aSymbol

	category:= aSymbol! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
category
	"Retrieves the tag-package associated to the receiver"

	^category! !

!RGTraitDefinition methodsFor: 'behavior' stamp: 'nil'!
withMetaclass: aRGMetatraitDefinition
	"Registers explicitly the metaclass of a class"

	metaClass:= aRGMetatraitDefinition.
	metaClass baseClass: self.  
! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
classVariables

	^#()! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
instanceVariables

	^#()! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
comment
	"Retrieves the comment definition object associated to the receiver"
	
	^comment! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
comment: anObject
	"Sets a RGCommentDefinition object based on the argument"
	
	comment := anObject isRingObject 
		ifFalse: [ 
			RGCommentDefinition new
				parent: self;
				content: anObject; 
				yourself ]
		ifTrue: [anObject ]
	! !

!RGTraitDefinition methodsFor: 'accessing - parallel hierarchy' stamp: 'nil'!
instanceSide
	"Return the class of the couple class/metaclass. Useful to avoid explicit test."
	^ self! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
sharedPools

	^#()! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
package: aRGPackage
	"Sets the package in which this trait is contained"
	
	package:= aRGPackage! !

!RGTraitDefinition methodsFor: 'accessing' stamp: 'nil'!
package
	"Retrieves the package in which this trait is contained"
	
	^package! !

!RGTraitDefinitionTest commentStamp: ''!
SUnit tests for trait definitions!
!RGTraitDefinitionTest methodsFor: 'testing' stamp: ''!
testExistingTrait
	| newClass metaClass |
	newClass := RGTraitDefinition named: #TSortable.
	self assert: newClass isTrait.
	self assert: newClass isDefined.
	self assert: newClass realClass equals: TSortable.
	self assert: newClass isMeta not.

	newClass withMetaclass.
	self assert: newClass hasMetaclass.
	metaClass := newClass classSide.
	self assert: metaClass isMeta.
	self assert: metaClass name equals: 'TSortable classTrait'.
	self assert: metaClass instanceSide equals: newClass.
	self assert: metaClass realClass equals: TSortable classSide! !

!RGTraitDefinitionTest methodsFor: 'testing' stamp: ''!
testNonExistingClass
	| newClass |
	newClass := RGTraitDefinition named: #TConnection.
	self assert: newClass isTrait.
	self assert: newClass hasMetaclass not.
	self assert: newClass hasComment not.
	self assert: newClass hasStamp not.
	self assert: newClass parent equals: 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! !

!RGTraitDefinitionTest methodsFor: 'testing' stamp: ''!
testAsTraitDefinition2
	| newTrait newClass newSlice |
	newClass := MOPTestClassC
		asRingDefinitionWithMethods: false
		withSuperclasses: false
		withSubclasses: true
		withPackages: false.
	newSlice := newClass environment.
	self assert: newClass allSubclasses size equals: 0.
	self assert: newClass traitNames size equals: 1.
	self assert: newClass traits first equals: (newSlice traitNamed: #Trait2).

	newTrait := MOPTestClassA
		asRingDefinitionWithMethods: true
		withSuperclasses: true
		withSubclasses: false
		withPackages: true.
	newSlice := newTrait environment.
	self assert: newTrait superclass equals: (newSlice classNamed: #Object).
	self assert: newTrait methods size < newSlice methods size.
	self assert: newTrait category equals: #'Tests-Traits-MOP'.
	self assertEmpty: newTrait subclasses! !

!RGTraitDefinitionTest methodsFor: 'testing' stamp: ''!
testTraitEquality
	| newClass |
	self assert: TSortable asRingDefinition equals: TSortable asRingDefinition.

	newClass := TSortable asRingDefinition category: #Kernel.
	self assert: TSortable asRingDefinition equals: newClass! !

!RGTraitDefinitionTest methodsFor: '*Ring-Definitions-Tests-Monticello' stamp: ''!
testAsFullTraitDefinition
	| rgClass |
	rgClass := TSortable asRingDefinition.
	self assertEmpty: rgClass methods.
	self assert: rgClass superclass isNil.
	self assertEmpty: rgClass subclasses.
	self assert: rgClass package isNil.

	rgClass := TSortable asFullRingDefinition.
	self assert: rgClass methods notEmpty.
	self assert: (rgClass methodNamed: #isSorted) package notNil.
	self assert: rgClass superclass notNil.
	self assert: rgClass superclass name equals: #Trait.
	self assertEmpty: rgClass subclasses.
	self assert: rgClass package notNil.
	self assert: rgClass package equals: rgClass instanceSide package.
	self assert: rgClass package name equals: #'Collections-Abstract-Traits'.
	self assert: rgClass category equals: #'Collections-Abstract-Traits-Base'.

	self assert: rgClass superclass superclass isNil.
	self assert: rgClass superclass package name equals: #TraitsV2.

	rgClass := TBehavior classSide asFullRingDefinition.
	self assert: rgClass package equals: rgClass classSide package! !

!RGTraitDefinitionTest methodsFor: 'testing' stamp: ''!
testAsTraitDefinition
	| newTrait |
	newTrait := TSortable asRingDefinition.
	self assert: newTrait isRingObject.
	self assert: newTrait isTrait.
	self assert: newTrait name identicalTo: #TSortable.
	self assert: newTrait category notNil.
	self assert: newTrait superclassName notNil.


	self assert: newTrait classSide isRingObject.
	self assert: newTrait classSide isTrait.
	self assert: newTrait classSide traitCompositionSource equals: '{}'! !

!RGTraitDefinitionTest methodsFor: 'testing' stamp: ''!
testAddingMethods
	| newMethod newClass |
	newClass := RGTraitDefinition named: #TSortable.
	newMethod := (RGMethodDefinition named: #sort)
		parent: newClass;
		protocol: 'sorting';
		sourceCode:
			'sort
									self sort: [:a :b | a <= b]'.

	self assert: newMethod isMetaSide not.
	self assert: newClass hasMethods not.

	newClass addMethod: newMethod.
	newClass
		addSelector: #size
		classified: 'accessing'
		sourced:
			'foo
							^lastIndex - firstIndex + 1'.

	self assert: newClass hasMethods.
	self assert: newClass selectors asSet equals: #(sort size) asSet.
	self assert: (newClass includesSelector: #sort).
	self assert: (newClass methodNamed: #sort) equals: newMethod.
	self assert: newClass methods size equals: 2.
	self assert: newClass selectors size equals: 2.
	self assert: newClass allSelectors size equals: 2.	"no hierarchy"

	newMethod := newClass methodNamed: #size.
	self assert: newMethod parent equals: newClass.

	self assert: (newClass compiledMethodNamed: #sort) notNil.
	self assert: (newClass compiledMethodNamed: #foo) isNil! !

!RGTraitDescriptionDefinition commentStamp: ''!
RGTraitDescriptionDefinition is the common parent for traits and metatraits that know their users (ie. classes/metaclasses)!
!RGTraitDescriptionDefinition methodsFor: 'accessing' stamp: 'nil'!
traitUsers
	"Retrieves the receiver's classes and traits"
	
	^users ifNil:[ users := OrderedCollection new ]! !

!RGTraitDescriptionDefinition methodsFor: 'testing' stamp: 'nil'!
isTrait

	^true! !

!RGTraitDescriptionDefinition methodsFor: 'variables' stamp: 'nil'!
allSharedPoolNames

	^#()! !

!RGTraitDescriptionDefinition methodsFor: 'adding/removing users' stamp: 'nil'!
removeUser: aRGBehavior

	self users remove: aRGBehavior ifAbsent:[]! !

!RGTraitDescriptionDefinition methodsFor: 'variables' stamp: 'nil'!
allInstVarNames

	^#()! !

!RGTraitDescriptionDefinition methodsFor: 'accessing' stamp: 'nil'!
users
	"Retrieves the receiver's classes and traits"
	
	^users ifNil:[ users := OrderedCollection new ]! !

!RGTraitDescriptionDefinition methodsFor: 'accessing' stamp: 'nil'!
users: aCollection

	users:= aCollection! !

!RGTraitDescriptionDefinition methodsFor: 'variables' stamp: 'nil'!
allClassVarNames

	^#()! !

!RGTraitDescriptionDefinition methodsFor: 'adding/removing users' stamp: 'nil'!
addUser: aRGBehavior

	self users add: aRGBehavior! !

!RGTraitDescriptionDefinition methodsFor: 'accessing' stamp: 'nil'!
traitUsers: aCollection

	users:= aCollection! !

!RGTraitDescriptionDefinition class methodsFor: 'testing' stamp: 'nil'!
isAbstract

	^ self == RGTraitDescriptionDefinition! !

!RGTraitDescriptionStrategy methodsFor: 'accessing' stamp: ''!
layout

	self incompatibleBehaviorType! !

!RGTraitDescriptionStrategy methodsFor: 'variables' stamp: ''!
isTrait

	^true! !

!RGTraitDescriptionStrategy methodsFor: 'variables' stamp: ''!
initialize

	super initialize.
	
	self owner environment backend createUnresolvedTraitGroupFor: self owner.
	! !

!RGTraitDescriptionStrategy methodsFor: 'accessing' stamp: ''!
layout: anRGLayout

	self incompatibleBehaviorType! !

!RGTraitDescriptionStrategy methodsFor: 'variables' stamp: ''!
allSharedPoolNames

	^#()! !

!RGTraitDescriptionStrategy methodsFor: 'private - backend access' stamp: ''!
bindingOf: varName

	^ self environment bindingOf: varName! !

!RGTraitDescriptionStrategy methodsFor: 'variables' stamp: ''!
users
	
	"return collection of user of the trait"

	| result |
	
	result := IdentitySet new.

	self environment ask behaviorsDo: [ :each |
		(each usedTraits includes: self) ifTrue: [ result add: each ] ].
	
	^ result.! !

!RGTraitDescriptionStrategy methodsFor: 'variables' stamp: ''!
trait

	^ self owner! !

!RGTraitDescriptionStrategy methodsFor: 'variables' stamp: ''!
name: aString

	| usersWithOldDefinition |

	usersWithOldDefinition := self users collect: [ :each | 
		each -> each copyForBehaviorDefinition ].

	super name: aString.
	
	usersWithOldDefinition do: [ :assoc |
		self trait announcer behaviorDefinitionChangedFrom: assoc value to: assoc key.
		self trait announcer behaviorModificationAppliedTo: assoc key. ].		! !

!RGTraitDescriptionStrategy methodsFor: 'variables' stamp: ''!
methods

	| allMethods |
	allMethods := IdentitySet new.
	self localMethodsDo: [ :each | allMethods add: each].
	^ allMethods asArray
! !

!RGTraitExclusion methodsFor: 'accessing' stamp: ''!
traitTransformationString

	^ String streamContents: [:aStream |	
		aStream 
			nextPut: $(;
			nextPutAll: self subject name;
			space;
			nextPut: $-;
			space;
			nextPut: ${.
	self exclusions do: [:each | aStream print: each]
		separatedBy: [aStream nextPutAll: '. '].
	aStream nextPut: $}.
	aStream nextPut: $).].! !

!RGTraitExclusion methodsFor: 'traits' stamp: ''!
traitCompositionString

	^ String streamContents: [:aStream |	
		aStream 
			nextPutAll: self subject name traitTransformationString;
			space;
			nextPut: $-;
			space;
			nextPut: ${.
	self exclusions do: [:each | aStream print: each]
		separatedBy: [aStream nextPutAll: '. '].
	aStream nextPut: $}].! !

!RGTraitExclusion methodsFor: 'accessing - backend' stamp: ''!
cleanExclusions

	self parent parent announceDefinitionChangeDuring: [ 
		self backend forBehavior cleanExclusionsFor: self. ].
	! !

!RGTraitExclusion methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	exclusions := self unresolvedValue: self defaultExclusions.! !

!RGTraitExclusion methodsFor: 'private - backend access' stamp: ''!
pvtCleanExclusions

	exclusions := self defaultExclusions.! !

!RGTraitExclusion methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	exclusions := self unresolvedValue: self defaultExclusions.! !

!RGTraitExclusion methodsFor: 'accessing - backend' stamp: ''!
addExclusion: aSymbol 

	self parent parent announceDefinitionChangeDuring: [ 
		self backend forBehavior addExclusion: aSymbol to: self. ].! !

!RGTraitExclusion methodsFor: 'testing - types' stamp: ''!
isTraitExclusion

	^ true! !

!RGTraitExclusion methodsFor: 'private - backend access' stamp: ''!
pvtExclusionsDo: aBlock

	exclusions value do: aBlock! !

!RGTraitExclusion methodsFor: 'private - backend access' stamp: ''!
pvtAddExclusion: aSymbol


	exclusions isRingResolved ifFalse: [ 
		self pvtCleanExclusions  ].
	
	exclusions add: aSymbol.	! !

!RGTraitExclusion methodsFor: 'queries - methods' stamp: ''!
methods

	^ self subject methods reject: [ :each | self exclusions includes: each name  ]! !

!RGTraitExclusion methodsFor: 'default model values' stamp: ''!
defaultExclusions

	^ OrderedCollection new! !

!RGTraitExclusion methodsFor: 'resolving' stamp: ''!
makeResolved

	super makeResolved.
	
	exclusions := self exclusions markAsRingResolved.
! !

!RGTraitExclusion methodsFor: 'accessing - backend' stamp: ''!
removeExclusion: aSymbol

	self parent parent announceDefinitionChangeDuring: [ 
		self backend forBehavior removeExclusion: aSymbol from: self. ].! !

!RGTraitExclusion methodsFor: 'private - backend access' stamp: ''!
pvtRemoveExclusion: aSymbol

	exclusions remove: aSymbol.! !

!RGTraitExclusion methodsFor: 'private - backend access' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#exclusions -> exclusions. 
	}
	
	! !

!RGTraitExclusion methodsFor: 'queries - exclusions' stamp: ''!
exclusions

	| allExclusions |
	allExclusions := OrderedCollection new.
	self exclusionsDo: [ :each | allExclusions add: each].
	^ allExclusions
! !

!RGTraitExclusion methodsFor: 'accessing - backend' stamp: ''!
exclusionsDo: aBlock

	self backend forBehavior exclusionsFor: self do: aBlock! !

!RGTraitExclusionTest methodsFor: 'tests' stamp: ''!
testAliasesCollection
	
	| traitAlias env alias1 alias2 alias3 |

	traitAlias := RGTraitAlias unnamed.
	env := traitAlias environment.

	self assert: traitAlias aliases isEmpty.
	self assert: (traitAlias hasUnresolved: #aliases).
	
	alias1 := (#m2 -> #m1).
	traitAlias addAlias: alias1.
	self assert: traitAlias aliases size equals: 1.

	self assert: (traitAlias hasResolved: #aliases).
	
	alias2 := (#m4 -> #m3).
	traitAlias addAlias: alias2.
	self assert: traitAlias aliases size equals: 2.
	
	alias3 := (#m6 -> #m5).
	traitAlias addAlias: alias3.
	self assert: traitAlias aliases size equals: 3.

	traitAlias removeAlias: alias3.
	self assert: traitAlias aliases size equals: 2.

	traitAlias cleanAliases.
	self assert: traitAlias aliases isEmpty.
	self assert: (traitAlias hasResolved: #aliases).
! !

!RGTraitExclusionTest methodsFor: 'tests' stamp: ''!
testImplicitEnvironment
	
	| def def2 env |

	def := RGTraitExclusion unnamed.
	env := def environment.

	self assert: (def isRingResolved).
		
	self assert: def parent isTraitComposition.
	self assert: def parent isRingResolved not.

	self assert: def parent parent isClass.
	self assert: def parent parent isRingResolved not.
	
	self assert: def parent transformations size equals: 1.

	self checkImplicitSingleClassEnvironmentOf: def parent parent.	

	def2 := RGTraitExclusion parent: def parent.
	def parent addTransformation: def2.
	
	self checkImplicitSingleClassEnvironmentOf: def parent parent.	
	
	self assert: def parent transformations size equals: 2.
! !

!RGTraitExclusionTest methodsFor: 'tests' stamp: ''!
testNewTraitAlias

	| traitAlias | 
	traitAlias  := RGTraitAlias unnamed.
	self assert: (traitAlias isRingResolved).
	self assert: (traitAlias hasUnresolvedAll: #(name subject aliases)).
	self assert: (traitAlias isTraitTransformation).
	! !

!RGTraitExclusionTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGTraitExclusion unnamed.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGTraitExclusionTest methodsFor: 'tests' stamp: ''!
testUsedTraits

	| traitExclusion trait usedTraits | 
	
	traitExclusion := RGTraitExclusion unnamed.
	trait := traitExclusion environment ensureTraitNamed: #SomeTrait.
	traitExclusion subject: trait.
	usedTraits := traitExclusion usedTraits.
	
	self assert: usedTraits size equals: 1.
	self assert: usedTraits anyOne equals: trait.! !

!RGTraitExclusionTest methodsFor: 'tests' stamp: ''!
testNewTraitExlusion

	| traitExclusion | 
	traitExclusion  := RGTraitExclusion unnamed.
	self assert: (traitExclusion isRingResolved).
	self assert: (traitExclusion hasUnresolvedAll: #(name subject exclusions)).
	self assert: (traitExclusion isTraitTransformation).
	! !

!RGTraitExclusionTest methodsFor: 'tests' stamp: ''!
testExclusionsCollection
	
	| traitExclusion env exclusion1 exclusion2 exclusion3 |

	traitExclusion := RGTraitExclusion unnamed.
	env := traitExclusion environment.

	self assert: traitExclusion exclusions isEmpty.
	self assert: (traitExclusion hasUnresolved: #exclusions).
	
	exclusion1 := #m1.
	traitExclusion addExclusion: exclusion1.
	self assert: traitExclusion exclusions size equals: 1.

	self assert: (traitExclusion hasResolved: #exclusions).
	
	exclusion2 := #m2.
	traitExclusion addExclusion: exclusion2.
	self assert: traitExclusion exclusions size equals: 2.
	
	exclusion3 := #m3.
	traitExclusion addExclusion: exclusion3.
	self assert: traitExclusion exclusions size equals: 3.

	traitExclusion removeExclusion: exclusion3.
	self assert: traitExclusion exclusions size equals: 2.

	traitExclusion cleanExclusions.
	self assert: traitExclusion exclusions isEmpty.
	self assert: (traitExclusion hasResolved: #exclusions).
! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
defaultCategory

	^ nil! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
isTraitStrategy

	^ true! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
pvtClassTrait: anRGMetatraitDefinition

	self owner environment verifyOwnership: anRGMetatraitDefinition.

	^ classTrait := anRGMetatraitDefinition! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
classSide

	^ self classTrait! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
hasComment

	^ self comment isEmptyOrNil not! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
pvtPackage: anRGPackage

	self owner environment verifyOwnership: anRGPackage.

	^ package := anRGPackage! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
pvtClassTrait

	^ classTrait value! !

!RGTraitStrategy methodsFor: 'private - backend access' stamp: ''!
category: aString

	| aTag |
		
	self owner cleanTags.
	aTag := self package 
		ifNotNil: [ 
			self package name = aString
				ifTrue: [ ^ self ] "category contains only the package name"
				ifFalse: [ aString withoutPrefix: self package name, '-'  ]]
		ifNil: [ aString ].
	self owner tagWith: aTag asSymbol.

"	self backend forBehavior setCategoryFor: self to: aaString.
	
	self announcer behaviorDefinitionModified: self.
	self announcer behaviorRecategorized: self."! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
defaultPackage

	^ self owner defaultPackageStubIn: self environment

	! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
storeName

	^ 'RGTrait'! !

!RGTraitStrategy methodsFor: 'private - backend access' stamp: ''!
classTrait

	^ self backend forBehavior classTraitFor: self owner! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
pvtComment

	^ comment value! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
pvtPackage

	^ package value! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
package: anRGPackage

	self announceDefinitionChangeDuring: [ 
		self backend forBehavior setTraitPackageFor: self to: anRGPackage.
		self environment addPackage: anRGPackage.
		anRGPackage addDefinedBehavior: self owner. ].! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
defaultComment

	^ self owner defaultCommentStubIn: self owner! !

!RGTraitStrategy methodsFor: 'private - backend access' stamp: ''!
acceptVisitor: aVisitor 

	^ aVisitor visitTrait: self owner! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
initialize

	super initialize.
	
	"classTrait is set in the superclass"
	comment := self unresolvedValue: self defaultComment.
	package := self unresolvedValue: self defaultPackage.
! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
pvtComment: anRGComment

	self owner environment verifyOwnership: anRGComment.

	^ comment := anRGComment! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
sibling

	^ self classTrait! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	classTrait := RGUnresolvedValue recursive.
	comment := self unresolvedValue: self defaultComment.
	package := self unresolvedValue: self defaultPackage.
! !

!RGTraitStrategy methodsFor: 'private - backend access' stamp: ''!
category

	^ self owner tags 
		ifEmpty: [ self owner package categoryName ]
		ifNotEmpty: [ 
			(self package hasResolvedName) 
				ifTrue: [ self owner package categoryName, '-', self owner tags first  ]
				ifFalse: [ self owner tags first  ]	] 
	
	"todo"! !

!RGTraitStrategy methodsFor: 'private - backend access' stamp: ''!
baseTrait

	^ self owner! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
referencedBehaviors

	^ super referencedBehaviors, {self classTrait}.! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
referencedPackages

	^ Array with: package! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
comment

	^ self backend forBehavior traitCommentFor: self owner! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
comment: anRGComment

	self backend forBehavior setTraitCommentFor: self owner to: anRGComment.
	
	self owner announcer behaviorCommentModified: self owner.! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
instanceSide
	^ self baseTrait! !

!RGTraitStrategy methodsFor: 'testing' stamp: ''!
definition
	"Answer a String that defines the receiver"

	^String streamContents: [:stream |
		stream nextPutAll: 'Trait'.
		stream nextPutAll: ' named: ';
				store: self owner name.
		stream cr; tab; nextPutAll: 'uses: ';
				nextPutAll: self owner traitCompositionString.
		stream cr; tab; nextPutAll: 'package: ';
				store: self owner category asString].! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
makeResolved

	
	"try to set the correct name before resolving of it"
	((self owner hasResolvedName not) and: [ self classTrait isRingResolved and: [ self classTrait hasResolvedName ] ]) ifTrue: [ 
		self owner pvtName: (self classTrait name withoutSuffix: ' classTrait') asSymbol.
		 ].
	
	super makeResolved.
	classTrait := self classTrait markAsRingResolved.
	comment := self comment markAsRingResolved.
	package := self package markAsRingResolved.
	! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
package

	^ self backend forBehavior traitPackageFor: self owner! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#classTrait -> classTrait. 
		#comment -> comment. 
		#package -> package. 
   	}
	
	! !

!RGTraitStrategy methodsFor: 'private - backend access' stamp: ''!
classTrait: anRGMetatraitDefinition

	self backend forBehavior setClassTraitFor: self owner to: anRGMetatraitDefinition! !

!RGTraitStrategy methodsFor: 'accessing' stamp: ''!
traitTransformationString

	^ self owner name! !

!RGTraitStrategyTest methodsFor: 'tests' stamp: ''!
testSharedPools

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newTrait.
	self assert: (anRGBehavior sharedPools isEmpty).! !

!RGTraitStrategyTest methodsFor: 'tests' stamp: ''!
testClassVariablesString

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newTrait.

	self assert: anRGBehavior classVariablesString equals: ''

! !

!RGTraitStrategyTest methodsFor: 'tests' stamp: ''!
testResolvingConsistency

	| anObject |
	anObject := RGTrait unnamed behaviorStrategy.
	self checkClassesConsistency: anObject and: anObject makeResolved! !

!RGTraitStrategyTest methodsFor: 'tests' stamp: ''!
testCreationByMethod

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newTrait.
	self assert: (anRGBehavior isBehavior).	
	self assert: (anRGBehavior behaviorStrategy isTraitStrategy).! !

!RGTraitStrategyTest methodsFor: 'tests' stamp: ''!
testSharedPoolNames

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newTrait.
	self assert: (anRGBehavior sharedPoolNames isEmpty).! !

!RGTraitStrategyTest methodsFor: 'tests' stamp: ''!
testInstSize

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newTrait.
	self assert: anRGBehavior instSize equals: 0! !

!RGTraitStrategyTest methodsFor: 'tests' stamp: ''!
testIncompatibleBehavior

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newTrait.
	
	self checkIncompatible: [ 
		anRGBehavior instanceVariables: Array new ].
	self checkIncompatible: [ 
		anRGBehavior kindOfSubclass].
	self checkIncompatible: [ 
		anRGBehavior removeClassVariable: (RGClassVariable named: #ClassVar parent: anRGBehavior)].
	self checkIncompatible: [ 
		anRGBehavior removeSharedPool: (anRGBehavior environment ensureClassNamed: #SomeClass)].
	self checkIncompatible: [ 
		anRGBehavior sharedPoolsDo: [ :sharedPool | ] ].
	self checkIncompatible: [ 
		anRGBehavior defaultMetaClass ].
! !

!RGTraitStrategyTest methodsFor: 'tests' stamp: ''!
testTrait

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newTrait.
	self assert: anRGBehavior trait equals: anRGBehavior! !

!RGTraitStrategyTest methodsFor: 'tests' stamp: ''!
testInstanceVariablesString

	| anRGBehavior |
	
	anRGBehavior := RGBehavior newTrait.
	self assert: anRGBehavior instanceVariablesString equals: ''! !

!RGTraitStrategyTest methodsFor: 'tests' stamp: ''!
testKind

	| strategy |
	
	strategy := RGBehavior newTrait behaviorStrategy.
	self deny: strategy isClassStrategy.
	self deny: strategy isMetaclassStrategy.
	self assert: strategy isTraitStrategy.
	self deny: strategy isMetaclassTraitStrategy.
	! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testHasMethods
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self deny: newBehavior hasMethods.
	1 to: 10 do: [ :i | 
		| m |
		m := RGMethod
			named: 'method' , i asString
			parent: newBehavior.
		newBehavior addLocalMethod: m ].
	self assert: newBehavior hasMethods.	
	newBehavior cleanLocalMethods.
	self deny: newBehavior hasMethods.
! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testTraitImplicitEnvironment

	| trait |
	
	trait := RGTrait unnamed.
	self assert: (trait hasUnresolved: #name).
	self checkImplicitSingleTraitEnvironmentOf: trait.
	
	
	
	
! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testProtocols

	| newBehavior |
	newBehavior := self behaviorClass unnamed.
	
	self assert: newBehavior asYetUnclassifiedProtocolName isSymbol.

	! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testNewTrait

	| trait metaclassTrait comment category package |
	trait := RGTrait unnamed.
	self assert: trait isRingResolved.
	self assert:
		(trait hasUnresolvedAll: #( classTrait comment category package )).
	self assert: trait isTrait.
	self assert: trait trait identicalTo: trait.

	metaclassTrait := RGMetaclassTrait parent: trait environment.
	trait classTrait: metaclassTrait.
	self assert: (trait hasResolved: #classTrait).
	self assert: trait classTrait identicalTo: metaclassTrait.
	self assert: trait classSide identicalTo: metaclassTrait.

	comment := RGComment parent: metaclassTrait.
	self deny: trait hasComment.
	trait comment: comment.
	self assert: (trait hasResolved: #comment).
	self assert: trait comment identicalTo: comment.
	self deny: trait hasComment. "the comment has no content"
	comment content: 'some comment'.
	self assert: trait hasComment.

	category := #SomeCategory.
	trait category: category.
	self assert: (trait hasResolved: #tags).
	self assert: trait category identicalTo: category.

	package := RGPackage parent: trait environment.
	trait package: package.
	self assert: (trait hasResolved: #package).
	self assert: trait package identicalTo: package.

	trait classVarNames isEmpty.
	trait sharedPools isEmpty! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testBehavior
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self deny: (newBehavior includesSelector: #method).
	method := RGMethod named: #method parent: newBehavior.
	newBehavior addLocalMethod: method.
	self deny: method isBehavior.
	self assert: (newBehavior includesSelector: #method).
	self assert: (newBehavior allInstVarNames isEmpty).
	self assert: (newBehavior allSlots isEmpty).
	self assert: (newBehavior bindingOf: #someVariable) isNil.
	self assert: (newBehavior classVariablesBindings isEmpty).
	
	self deny: (newBehavior isRingFullyUnresolved).

	self deny: newBehavior hasTraitComposition.	
	
! !

!RGTraitTest methodsFor: 'accessing' stamp: ''!
behaviorClass

	^ RGTrait! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testIsBehavior

	| newBehavior |
	newBehavior := self behaviorClass unnamed.
	
	self assert: newBehavior isBehavior

	! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testMakeReslolvedResolvesEverything

	| behavior |

	behavior := self behaviorClass unnamed.
	behavior makeResolved.
	self assert: behavior unresolvedProperties isEmpty.! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testClassSide
	| behavior |
	behavior := RGTrait unnamed.
	self assert: behavior classSide identicalTo: behavior classTrait.
	self assert: behavior classTrait classSide identicalTo: behavior classTrait! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithCategorizedMethods
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior ask methods isEmpty.
	self assert: newBehavior ask protocols isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	newBehavior addLocalMethod: method.
	self assert: (newBehavior hasResolved: #tagsForMethods).
! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithProtocols
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods tagsForMethods)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior methods isEmpty.
	1 to: 10 do: [ :i | 
		newBehavior addProtocol: ('protocol' , i asString) asSymbol ].
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: (newBehavior protocols allSatisfy: #isSymbol).
	self assert: newBehavior protocols size equals: 10.
	(newBehavior protocols first: 4)
		do: [ :each | newBehavior removeProtocol: each ].
	self assert: newBehavior protocols size equals: 6.
	newBehavior cleanProtocols.
	self assert: newBehavior protocols isEmpty! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testNewBehavior
	| newBehavior newSuperclass |
	newBehavior := self behaviorClass unnamed.
	self assert: newBehavior isRingResolved.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	newBehavior name: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self assert: (newBehavior hasResolvedName).
	self deny: (newBehavior hasUnresolved: #name).
	newBehavior isTrait
		ifFalse: [ self assert: newBehavior superclass isRingResolved not ].
	"	self assert: (newBehavior superclass environment == newBehavior environment).
"
	newSuperclass := RGClass
		named: #MySuperclass
		parent: newBehavior environment.
	self assert: newSuperclass environment == newBehavior environment.
	self
		assert: (newSuperclass hasUnresolvedAll: #(superclass localMethods protocols))! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithUnategorizedMethod
	| newBehavior method |
	
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait ifFalse: [  
		self assert: (newBehavior hasUnresolved: #superclass).].
	self assert: (newBehavior methods isEmpty).
	self assert: (newBehavior protocols isEmpty).

	method := RGMethod named: #someMethod parent: newBehavior. 
	newBehavior addLocalMethod: method.
	
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanProtocols.

	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	
	newBehavior cleanLocalMethods.
	self assert: (newBehavior protocols isEmpty).
	
! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithUnategorizedMethods
	| newBehavior method1 method2 |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods tagsForMethods)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior methods isEmpty.
	self assert: newBehavior protocols isEmpty.
	method1 := RGMethod named: #method1 parent: newBehavior.
	method2 := RGMethod named: #method2 parent: newBehavior.
	newBehavior addLocalMethod: method1.
	newBehavior addLocalMethod: method2.
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanProtocols.
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanLocalMethods.
	self assert: newBehavior protocols isEmpty! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testEnsureProtocol

	| behavior |
	
	behavior := self behaviorClass named: #SomeClass.
	behavior ensureProtocolNamed: #SomeProtocol.
	self assert: behavior protocols size equals: 1.
	self assert: behavior protocols first equals: #SomeProtocol.
	! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithOneMethod
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior localMethods isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	self assert: method environment == newBehavior environment.
	self assert: newBehavior localMethods isEmpty.	"we do not add the method to the behavior"
	newBehavior := self behaviorClass named: #SomeClass.
	newBehavior cleanLocalMethods.
	self assert: (newBehavior hasResolved: #localMethods).
	self assert: newBehavior localMethods isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	newBehavior addLocalMethod: method.
	self assert: method environment == newBehavior environment.
	self assert: (newBehavior hasResolved: #localMethods).
	self assert: newBehavior localMethods anyOne name equals: #someMethod.
	newBehavior removeLocalMethod: method.
	self assert: newBehavior localMethods isEmpty.
	self assert: (newBehavior hasResolved: #localMethods)! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testCopyForBehaviorDefinition
	
	| env aClass copy |
	
	env := RGEnvironment new.
	aClass := env ensureClassNamed: #SomeClass.
	aClass superclass: (env ensureClassNamed: #SomeSuperclass).
	aClass tagWith: #tag1.
	aClass tagWith: #tag2.
		
	copy := aClass copyForBehaviorDefinition.
	
	self deny: copy == aClass. 
	self deny: copy superclass == aClass superclass. 
	self assert: copy superclass name equals: #SomeSuperclass.
	self assert: copy tags sorted equals: #(tag1 tag2).! !

!RGTraitTest methodsFor: 'tests' stamp: ''!
testBehaviorWithMethods
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior localMethods isEmpty.
	1 to: 10 do: [ :i | 
		| m |
		m := RGMethod
			named: 'method' , i asString
			parent: newBehavior.
		newBehavior addLocalMethod: m ].
	self assert: (newBehavior hasResolved: #localMethods).
	self
		assert:
			(newBehavior localMethods
				allSatisfy: [ :each | each environment = newBehavior environment ]).
	self assert: newBehavior localMethods size equals: 10.
	(newBehavior localMethods first: 4)
		do: [ :each | newBehavior removeLocalMethod: each ].
	self assert: newBehavior localMethods size equals: 6.
	newBehavior cleanLocalMethods.
	self assert: newBehavior localMethods isEmpty! !

!RGTraitTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RGTraitTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RGTraitTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RGTraitTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RGTraitTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RGTraitTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RGTraitTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RGTraitTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RGTraitTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGTraitTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RGTraitTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RGTraitTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RGTraitTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RGTraitTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RGTraitTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RGTraitTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RGTraitTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RGTraitTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RGTraitTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RGTraitTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RGTraitTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RGTraitTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RGTraitTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RGTraitTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RGTraitTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RGTraitTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RGTraitTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RGTraitTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RGTraitTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RGTraitTransformation methodsFor: 'managing container' stamp: ''!
defaultParentStub

	^ self defaultTraitCompositionStub! !

!RGTraitTransformation methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.
	
	subject := self unresolvedValue: self defaultSubject.! !

!RGTraitTransformation methodsFor: 'testing - types' stamp: ''!
isTraitTransformation

	^ true! !

!RGTraitTransformation methodsFor: 'accessing - backend' stamp: ''!
usedTraits

	^ IdentitySet with: subject.! !

!RGTraitTransformation methodsFor: 'initialize' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	subject := self unresolvedValue: self defaultSubject.! !

!RGTraitTransformation methodsFor: 'accessing - backend' stamp: ''!
subject: anRGTrait

	self parent parent announceDefinitionChangeDuring: [ 
		self backend forBehavior setSubjectFor: self to: anRGTrait. ].! !

!RGTraitTransformation methodsFor: 'accessing - backend' stamp: ''!
subject

	^ self backend forBehavior subjectFor: self! !

!RGTraitTransformation methodsFor: 'accessing' stamp: ''!
trait
	
	^ self subject trait! !

!RGTraitTransformation methodsFor: 'accessing - backend' stamp: ''!
name: aString

	self parent parent announceDefinitionChangeDuring: [ 
		super name: aString ].! !

!RGTraitTransformation methodsFor: 'managing container' stamp: ''!
addoptToParentStub

	super addoptToParentStub.
	self parent addTransformation: self.! !

!RGTraitTransformation methodsFor: 'private - backend interface' stamp: ''!
pvtSubject

	^ subject value! !

!RGTraitTransformation methodsFor: 'queries - methods' stamp: ''!
methods

	self subclassResponsibility ! !

!RGTraitTransformation methodsFor: 'resolving' stamp: ''!
makeResolved

	super makeResolved.
	
	subject := self subject markAsRingResolved.
! !

!RGTraitTransformation methodsFor: 'default model values' stamp: ''!
defaultSubject

	^ RGUnresolvedValue recursive! !

!RGTraitTransformation methodsFor: 'private - backend interface' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#subject -> subject. 
	}
	
	! !

!RGTraitTransformation methodsFor: 'private - backend interface' stamp: ''!
pvtSubject: anRGTrait

	self environment verifyOwnership: anRGTrait.

	^ subject := anRGTrait! !

!RGTraitV2DescriptionStrategy methodsFor: 'private - backend interface' stamp: ''!
pvtLayout

	^ layout value! !

!RGTraitV2DescriptionStrategy methodsFor: 'private - backend access' stamp: ''!
traitTransformationString		
		
	^ self owner name ! !

!RGTraitV2DescriptionStrategy methodsFor: 'private - backend interface' stamp: ''!
isTrait

	^true! !

!RGTraitV2DescriptionStrategy methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	layout := self unresolvedValue: self defaultLayout. 
	self owner environment backend createUnresolvedClassGroupFor: self owner.! !

!RGTraitV2DescriptionStrategy methodsFor: 'accessing' stamp: ''!
instanceVariablesString
	"Answer a string of my instance variable names separated by spaces."

	^String streamContents: [ :stream |
		self instVarNames 
			do: [ :each | stream nextPutAll: each ]
			separatedBy: [ stream space ] ]! !

!RGTraitV2DescriptionStrategy methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	layout := self unresolvedValue: self defaultLayout.
! !

!RGTraitV2DescriptionStrategy methodsFor: 'initialization' stamp: ''!
instSize

	^ self owner allInstVarNames size! !

!RGTraitV2DescriptionStrategy methodsFor: 'variables' stamp: ''!
trait

	^ self owner! !

!RGTraitV2DescriptionStrategy methodsFor: 'accessing' stamp: ''!
instanceVariables: aCollectionOfSymbols

	"specify instance variable names"

	(self owner hasUnresolved: #layout)
		ifTrue: [ self layout: (RGFixedLayout parent: self)].
		
	(self layout isPointerLayout not and: [ aCollectionOfSymbols isEmpty ])
		ifTrue: [ ^ self ].
		
	self layout cleanSlots.

	aCollectionOfSymbols do: [ :instVarName |
		layout addSlot: (RGInstanceVariableSlot named: instVarName asSymbol parent: self)].! !

!RGTraitV2DescriptionStrategy methodsFor: 'initialization' stamp: ''!
defaultLayout

	^ self owner defaultFixedLayoutStubIn: self.! !

!RGTraitV2DescriptionStrategy methodsFor: 'utilities' stamp: ''!
allSlots

	| superclassSlots aSuperclass |
	aSuperclass := self owner superclass.
	superclassSlots := OrderedCollection new.
	((aSuperclass == self owner) or: [aSuperclass isNil ]) ifFalse: [ 
		 superclassSlots addAll: aSuperclass allSlots ].
	^ (superclassSlots, self layout allSlots) asArray.! !

!RGTraitV2DescriptionStrategy methodsFor: 'initialization' stamp: ''!
instVarNames
	^ self layout instVarNames! !

!RGTraitV2DescriptionStrategy methodsFor: 'copying' stamp: ''!
copyForBehaviorDefinitionPostCopy

	super copyForBehaviorDefinitionPostCopy.
	layout := self layout copyForBehaviorDefinition.
	layout parent: self owner.
! !

!RGTraitV2DescriptionStrategy methodsFor: 'private - backend interface' stamp: ''!
makeResolved

	super makeResolved. 
	
	layout := self layout makeResolved markAsRingResolved.
! !

!RGTraitV2DescriptionStrategy methodsFor: 'printing' stamp: ''!
storeOn: aStream
	aStream
		nextPutAll: '(';
		nextPutAll: self storeName;
		nextPutAll: ' named: '.
	self owner  name storeOn: aStream.
	aStream nextPut: $)! !

!RGTraitV2DescriptionStrategy methodsFor: 'private - backend interface' stamp: ''!
pvtLayout: anRGLayout

	self owner environment verifyOwnership: anRGLayout.

	^ layout := anRGLayout! !

!RGTraitV2DescriptionStrategy methodsFor: 'private - backend interface' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#layout -> layout. 
     	}! !

!RGTraitV2DescriptionStrategy methodsFor: 'initialization' stamp: ''!
classVariablesString
	"Answer a string of my class variable names separated by spaces."

	^ String streamContents: [ :stream | 
		self owner classVarNames 
			do: [ :each | stream nextPutAll: each ]
			separatedBy: [ stream space ] ]! !

!RGTraitV2Strategy methodsFor: '*Ring-Monticello' stamp: ''!
mcType

	^ self layout mcType! !

!RGTraitV2Strategy methodsFor: '*Ring-Monticello' stamp: ''!
classPool

	"TODO"
	^ Dictionary newFrom: (self classVarNames collect: [ :each | each -> nil ])! !

!RGTraitV2Strategy methodsFor: 'enumerating' stamp: ''!
pvtSharedPoolsDo: aBlock

	sharedPools value do: aBlock! !

!RGTraitV2Strategy methodsFor: '*Ring-Monticello' stamp: ''!
asMCDefinition

	^ MCClassDefinition 
		name: self name
		superclassName: (self superclass ifNil: [ 'nil' ] ifNotNil: [ :aSuperclass | aSuperclass name ])
		traitComposition: self owner traitCompositionString 
		classTraitComposition: self owner metaclass traitCompositionString
		category: self category 
		instVarNames: self instVarNames
		classVarNames: self classVarNames
		poolDictionaryNames: self sharedPoolNames
		classInstVarNames: self metaclass instVarNames
		type: self mcType
		comment: self comment content
		commentStamp: self comment stamp! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
cleanClassVariables

	self owner announceDefinitionChangeDuring: [ 
		self backend forBehavior cleanClassVariablesFor: self owner ].! !

!RGTraitV2Strategy methodsFor: 'default model values' stamp: ''!
defaultSharedPools

	^ OrderedCollection new

	! !

!RGTraitV2Strategy methodsFor: 'testing' stamp: ''!
pvtPackage: anRGPackage

	self owner environment verifyOwnership: anRGPackage.

	^ package := anRGPackage! !

!RGTraitV2Strategy methodsFor: 'default model values' stamp: ''!
defaultPackage

	^ self owner defaultPackageStubIn: self environment

	! !

!RGTraitV2Strategy methodsFor: 'accessing' stamp: ''!
classTrait

	^ self backend forBehavior classTraitFor: self owner! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtClassVariablesDo: aBlock

	classVariables value do: aBlock! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
removeSharedPool: anRGPoolVariable

	self owner announceDefinitionChangeDuring: [ 
		self backend forBehavior removeSharedPool: anRGPoolVariable from: self owner].! !

!RGTraitV2Strategy methodsFor: 'testing' stamp: ''!
pvtPackage

	^ package value! !

!RGTraitV2Strategy methodsFor: 'accessing - backend' stamp: ''!
package: anRGPackage

	| oldPackage |
	oldPackage := self package.

	self owner announceDefinitionChangeDuring: [ 
		self owner backend forBehavior setPackageFor: self owner to: anRGPackage.
		self owner environment addPackage: anRGPackage.
		(oldPackage hasResolved: #definedBehaviors)
			ifTrue: [ oldPackage removeDefinedBehavior: self owner ].
		anRGPackage addDefinedBehavior: self owner. ].
	
	self owner announce: (ClassRepackaged 
		classRepackaged: self owner
		oldPackage: oldPackage
		newPackage: anRGPackage)! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtRemoveSharedPool: anRGPoolVariableDefinition

	self owner environment verifyOwnership: anRGPoolVariableDefinition.
	
	sharedPools remove: anRGPoolVariableDefinition.! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
privAddSharedPool: anRGPoolVariable
	
	self backend forBehavior addSharedPool: anRGPoolVariable to: self owner! !

!RGTraitV2Strategy methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	comment := self unresolvedValue: self defaultComment.	
	classVariables := self unresolvedValue: self defaultClassVariables.	
	package := self unresolvedValue: self defaultPackage.	
	sharedPools := self unresolvedValue: self defaultSharedPools.	
			
	! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtComment: anRGComment

	self owner environment verifyOwnership: anRGComment.

	^ comment := anRGComment! !

!RGTraitV2Strategy methodsFor: 'testing' stamp: ''!
isClass

	^ true! !

!RGTraitV2Strategy methodsFor: 'testing' stamp: ''!
defaultMetaClass

	^ self owner environment backend createNewUnresolvedMetaclassFor: self owner! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
comment: anRGComment

	self backend forBehavior setCommentFor: self owner to: anRGComment.
	
	self owner announcer behaviorCommentModified: self.! !

!RGTraitV2Strategy methodsFor: 'testing' stamp: ''!
definition
	"Answer a String that defines the receiver"

	^String streamContents: [:stream |
		stream nextPutAll: 'Trait'.
		stream nextPutAll: ' named: ';
				store: self owner name.
		stream cr; tab; nextPutAll: 'uses: ';
				nextPutAll: self owner traitCompositionString.
		(self owner slots size > 0) ifTrue: [ 
			stream
				crtab;
				nextPutAll: 'slots: ';
				nextPutAll: self owner slotDefinitionString].
		stream cr; tab; nextPutAll: 'package: ';
				store: self category asString].! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
addClassVariable: anRGInstanceVariableDefinition 

	self owner announceDefinitionChangeDuring: [ 
		self privAddClassVariable: anRGInstanceVariableDefinition ]
	
	! !

!RGTraitV2Strategy methodsFor: 'default model values' stamp: ''!
makeResolved

	
	"try to set the correct name before resolving of it"
	((self owner hasResolvedName not) and: [ self owner metaclass isRingResolved and: [ self metaclass hasResolvedName ] ]) ifTrue: [ 
		self owner pvtName: (self owner metaclass name withoutSuffix: ' class') asSymbol.
		 ].
	
	super makeResolved.
	
	classTrait := self classTrait markAsRingResolved.
	comment := self comment markAsRingResolved.
	classVariables := self classVariables markAsRingResolved.
	package := self package markAsRingResolved.
	sharedPools := self sharedPools markAsRingResolved.
! !

!RGTraitV2Strategy methodsFor: 'accessing - backend' stamp: ''!
package

	^ self backend forBehavior packageFor: self owner! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
cleanSharedPools

	self backend forBehavior cleanSharedPoolsFor: self owner.! !

!RGTraitV2Strategy methodsFor: 'accessing' stamp: ''!
classTrait: anRGMetatraitDefinition

	self backend forBehavior setClassTraitFor: self owner to: anRGMetatraitDefinition! !

!RGTraitV2Strategy methodsFor: 'class variables' stamp: ''!
classVariableDefinitionString
	"Answer a string that evaluates to the definition of the class Variables"
	
	^String streamContents: [ :str | | special |
		str nextPutAll: '{ '.
		self owner classVariables do: [:global |
				str nextPutAll: global definitionString.
				special := global needsFullDefinition]				
			separatedBy: [ 
				str nextPutAll: ' . '.  
				special ifTrue: [ str cr;tab;tab;tab;tab ]].
		str nextPutAll: ' }'. ]! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
classVariablesDo: aBlock

	self backend forBehavior classVariablesFor: self owner do: aBlock! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
addSharedPool: anRGPoolVariable

	self owner announceDefinitionChangeDuring: [ 
		self privAddSharedPool: anRGPoolVariable ].! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtClassTrait: anRGMetatraitDefinition

	self owner environment verifyOwnership: anRGMetatraitDefinition.

	^ classTrait := anRGMetatraitDefinition! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
classSide

	^ self owner metaclass! !

!RGTraitV2Strategy methodsFor: 'default model values' stamp: ''!
defaultClassVariables

	^ OrderedCollection new

	! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
sharedPools: aCollectionOfSymbols

	self cleanSharedPools.
	aCollectionOfSymbols do: [ :poolName |
		self addSharedPool: (RGPoolVariable named: poolName asSymbol parent: self).].! !

!RGTraitV2Strategy methodsFor: 'testing' stamp: ''!
pvtClassTrait

	^ classTrait value! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
bindingOf: varName

	| aSymbol | 
	aSymbol := varName asSymbol.

	^ (self innerBindingOf: aSymbol) ifNil: [
		 self environment bindingOf: aSymbol ]! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
category: aString

	| aTag |
		
	self owner cleanTagsWithoutAnnouncemnt.
	aTag := self owner package 
		ifNotNil: [ 
			self owner package name = aString
				ifTrue: [ ^ self owner ] "category contains only the package name"
				ifFalse: [ aString withoutPrefix: self package name, '-'  ]]
		ifNil: [ aString ].
	self owner tagWith: aTag asSymbol.

"	self backend forBehavior setCategoryFor: self to: aaString.
	
	self announcer behaviorDefinitionModified: self.
	self announcer behaviorRecategorized: self."! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtRemoveClassVariable: anRGInstanceVariableDefinition

	self owner environment verifyOwnership: anRGInstanceVariableDefinition.
	
	classVariables remove: anRGInstanceVariableDefinition.! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
sharedPoolsDo: aBlock

	self owner backend forBehavior sharedPoolsFor: self owner do: aBlock! !

!RGTraitV2Strategy methodsFor: 'testing' stamp: ''!
storeName

	^ 'RGClass'! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtAddSharedPool: anRGPoolVariable

	self owner environment verifyOwnership: anRGPoolVariable.
	
	sharedPools isRingResolved ifFalse: [ 
		self pvtCleanSharedPools  ].
	
	sharedPools add: anRGPoolVariable.	! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtAddClassVariable: anRGInstanceVariableDefinition

	self owner environment verifyOwnership: anRGInstanceVariableDefinition.
	
	classVariables isRingResolved ifFalse: [ 
		self pvtCleanClassVariables  ].
	
	classVariables add: anRGInstanceVariableDefinition.	! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
allClassVariables
	"Answer a collection of the receiver's classVariables, including those defined its superclasses"

	^ ((self owner superclass == nil) or: [ self owner superclass == self owner]) 
		ifTrue: [ self classVariables ]
		ifFalse: [ self owner superclass allClassVariables, classVariables ]! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
privAddClassVariable: anRGInstanceVariableDefinition 

	self backend forBehavior addClassVariable: anRGInstanceVariableDefinition to: self owner	
	! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtCleanClassVariables

	classVariables := self defaultClassVariables.! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtComment

	^ comment value! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
removeClassVariable: anRGInstanceVariableDefinition

	self owner announceDefinitionChangeDuring: [ 
		self backend forBehavior removeClassVariable: anRGInstanceVariableDefinition from: self owner ].! !

!RGTraitV2Strategy methodsFor: 'testing' stamp: ''!
definitionWithSlots

	| aStream poolString|

	poolString := self owner sharedPoolsString.

	aStream := (String new: 800) writeStream.
	self owner superclass 
		ifNil: [aStream nextPutAll: 'ProtoObject']
		ifNotNil: [aStream nextPutAll: self owner superclass name].
	aStream nextPutAll: ' subclass: ';
			store: self owner name.
	(self owner hasTraitComposition) ifTrue: [
		aStream cr; tab; nextPutAll: 'uses: ';
			nextPutAll: self owner traitCompositionString].		
			
	(self layout layoutName = #FixedLayout) ifFalse: [
		aStream cr; tab; nextPutAll: 'layout: ';
			nextPutAll: self layout layoutName].
	aStream cr; tab; nextPutAll: 'slots: ';
			nextPutAll: self owner slotDefinitionString.
	aStream cr; tab; nextPutAll: 'classVariables: ';
			nextPutAll: self owner classVariableDefinitionString.
	poolString = '' ifFalse: [
		aStream cr; tab; nextPutAll: 'poolDictionaries: ';
			store: poolString].
	aStream cr; tab; nextPutAll: 'package: ';
			store: self category asString.

	self owner superclass ifNil: [ 
		aStream nextPutAll: '.'; cr.
		aStream nextPutAll: self owner name.
		aStream space; nextPutAll: 'superclass: nil'. ].

	^ aStream contents! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
classVariables: aCollectionOfSymbols

	self cleanClassVariables.
	aCollectionOfSymbols do: [ :classVarName |
		self addClassVariable: (RGClassVariable named: classVarName asSymbol parent: self).].! !

!RGTraitV2Strategy methodsFor: 'default model values' stamp: ''!
defaultComment

	^ self owner defaultCommentStubIn: self owner! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
acceptVisitor: aVisitor 

	^ aVisitor visitClass: self owner! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
sibling

	^ self owner metaclass.! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
classVarNames

	^ self classVariables collect: [ :each | each name ]! !

!RGTraitV2Strategy methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	comment := self unresolvedValue: self defaultComment.	
	classVariables := self unresolvedValue: self defaultClassVariables.	
	package := self unresolvedValue: self defaultPackage.	
	sharedPools := self unresolvedValue: self defaultSharedPools.	
	! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
category

	^ self owner tags 
		ifEmpty: [ self owner package categoryName ]
		ifNotEmpty: [ 
			(self owner package hasResolvedName) 
				ifTrue: [ self owner package categoryName, '-', self owner tags first  ]
				ifFalse: [ self owner tags first  ]	] 
	
	"todo"! !

!RGTraitV2Strategy methodsFor: '*Ring-Monticello' stamp: ''!
referencedPackages

	^ Array with: self package.! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
classVariables

	^ Array streamContents: [ :str | self classVariablesDo: [ :each | str nextPut: each ] ]! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
comment

	^ self backend forBehavior commentFor: self owner! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
allClassVarNames

	^self allClassVariables collect:[ :cvar| cvar name ]! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
innerBindingOf: aSymbol

	self classVariables detect: [ :each | each name = aSymbol  ] ifFound: [ :found | ^ found ].

	self sharedPoolsDo: [:pool | 
		((self environment ask behaviorNamed: pool name) bindingOf: aSymbol) ifNotNil: [:binding | ^binding]].

	((self owner superclass == self owner) or: [ self owner superclass isNil ]) ifFalse: [ ^ self owner superclass innerBindingOf: aSymbol].	
		
	^ nil! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
sharedPoolNames

	| allSharedPools |
	allSharedPools := OrderedCollection new.
	self sharedPoolsDo: [ :each | allSharedPools add: each name].
	^ allSharedPools asArray! !

!RGTraitV2Strategy methodsFor: '*Ring-Monticello' stamp: ''!
classLayout
	"TODO"
	^ layout"
		ifNil: [ 
			| superLayout scope |
			superLayout := superclass classLayout.
			scope := superLayout slotScope extend.
			layout := superLayout class extending: superLayout scope: scope host: self ]"! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
copyForBehaviorDefinitionPostCopy

	| newVariables newSharedPools |
	
	self owner behaviorStrategy: self.
	
	super copyForBehaviorDefinitionPostCopy.
	
	newVariables := self classVariables collect: [ :each | each copyWithParent: self owner].
	newSharedPools := self sharedPools collect: [ :each | each shallowCopy. ].

	self pvtCleanClassVariables.
	self pvtCleanSharedPools.
	
	newVariables do: [ :each | self privAddClassVariable: each ].
	newSharedPools do: [ :each | self privAddSharedPool: each ].


! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
sharedPools

	| allSharedPools |
	allSharedPools := OrderedCollection new.
	self sharedPoolsDo: [ :each | allSharedPools add: (
		"use classes everywhare you can. TODO: really?"
		each isSymbol 
			ifTrue: [ self environment ask behaviorNamed: each name ]
			ifFalse: [ 
				(each isVariable and: [each isPoolVariable ])
					ifTrue: [ 
						| beh | 
						beh := self environment ask behaviorNamed: each name.
						beh ifNotNil: [ beh ] ifNil: [ each ] ]
					ifFalse: [ each copy ]])].
	^ allSharedPools ! !

!RGTraitV2Strategy methodsFor: 'private - backend access' stamp: ''!
pvtCleanSharedPools

	sharedPools := self defaultSharedPools.! !

!RGTraitV2Strategy methodsFor: 'initialization' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#comment -> comment. 
		#classVariables -> classVariables. 
		#package -> package. 
		#sharedPools -> sharedPools. 
	}
	
	
! !

!RGUnknownSlot methodsFor: 'private - backend interface' stamp: ''!
definitionString

	^ String streamContents: [ :aStream |
		aStream nextPutAll: '#'; nextPutAll: self name; nextPutAll: ' => '; nextPutAll: self expression ]! !

!RGUnknownSlot methodsFor: 'private - backend interface' stamp: ''!
pvtExpression

	^ expression value! !

!RGUnknownSlot methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	expression := self unresolvedValue: self defaultExpression.
! !

!RGUnknownSlot methodsFor: 'accessing - backend' stamp: ''!
expression: aString

	self parent parent announceDefinitionChangeDuring: [ 
		self backend forBehavior setExpressionFor: self to: aString ].

! !

!RGUnknownSlot methodsFor: 'initialization' stamp: ''!
initializeUnresolved

	super initializeUnresolved.
	
	expression := self unresolvedValue: self defaultExpression.! !

!RGUnknownSlot methodsFor: 'private - backend interface' stamp: ''!
pvtExpression: aString

	^ expression := aString! !

!RGUnknownSlot methodsFor: 'accessing - backend' stamp: ''!
expression

	^ self backend forBehavior expressionFor: self! !

!RGUnknownSlot methodsFor: 'default model values' stamp: ''!
defaultExpression

	'InstanceVariableSlot named: #slotOfUnknownType'! !

!RGUnknownSlot methodsFor: 'resolving' stamp: ''!
makeResolved

	super makeResolved.
	
	expression := self expression markAsRingResolved.
! !

!RGUnknownSlot methodsFor: 'private - backend interface' stamp: ''!
pvtResolvableProperties

	^ super pvtResolvableProperties, { 
		#expression -> expression. 
	}
	
	! !

!RGUnresolvedValue methodsFor: 'accessing' stamp: ''!
orDefaultForUnresolved

	^ self default! !

!RGUnresolvedValue methodsFor: 'testing' stamp: ''!
isRingFullyResolved

	^ false! !

!RGUnresolvedValue methodsFor: 'testing' stamp: ''!
isRingResolved

	^ false! !

!RGUnresolvedValue methodsFor: 'accessing' stamp: ''!
referencedBehaviors

	^ #()! !

!RGUnresolvedValue methodsFor: 'accessing' stamp: ''!
value

	^ self default! !

!RGUnresolvedValue methodsFor: 'testing' stamp: ''!
isRGUnresolvedValue

	^ true! !

!RGUnresolvedValue methodsFor: 'accessing' stamp: ''!
default
	^ default! !

!RGUnresolvedValue methodsFor: 'testing' stamp: ''!
isRingFullyUnresolved

	^ true! !

!RGUnresolvedValue methodsFor: 'accessing' stamp: ''!
default: anObject
	default := anObject! !

!RGUnresolvedValue class methodsFor: 'instance creation' stamp: ''!
recursive

	| unresolvedValue |
	
	unresolvedValue := self new.
	unresolvedValue default: unresolvedValue.
	^ unresolvedValue.! !

!RGUnresolvedValueTest methodsFor: 'tests' stamp: ''!
testReferencedBehaviors

	| unresolved | 
	
	unresolved := RGUnresolvedValue new.
	self assert: unresolved referencedBehaviors isEmpty.! !

!RGUnresolvedValueTest methodsFor: 'tests' stamp: ''!
testDefaultValue

	| unresolved | 
	
	unresolved := RGUnresolvedValue new.
	self deny: unresolved isRingResolved.
	self deny: unresolved isRingFullyResolved.
	self assert: unresolved isRingFullyUnresolved.
	self assert: unresolved value isNil.
	self assert: unresolved value isRingResolved.
	
	unresolved := RGUnresolvedValue new default: #someObject.
	self deny: unresolved isRingResolved.
	self assert: unresolved value equals: #someObject.
	self assert: unresolved value isRingResolved.
	
	unresolved := RGUnresolvedValue new default: #someObject.
	self deny: unresolved isRingResolved.
	self assert: unresolved value equals: #someObject.
	self assert: unresolved value isRingResolved.

	unresolved := RGUnresolvedValue recursive.
	self deny: unresolved isRingResolved.
	self deny: unresolved value isRingResolved.
! !

!RGVariable commentStamp: ''!
A variable definition!
!RGVariable methodsFor: 'accessing' stamp: ''!
definitionString
	"non special globals are defined by the symbol"
	^self needsFullDefinition
		ifTrue: [ String streamContents: [ :aStream |
			aStream nextPutAll: '#'; nextPutAll: self name]]
		ifFalse: [self name printString]
! !

!RGVariable methodsFor: 'testing' stamp: ''!
isArgumentVariable
	^false! !

!RGVariable methodsFor: 'testing' stamp: ''!
isClassVariable

	^false! !

!RGVariable methodsFor: 'testing' stamp: ''!
isWorkspaceVariable
	^ false! !

!RGVariable methodsFor: 'read/write usage' stamp: ''!
analyzeRead: aVariableNode by: aSemanticAnalyzer! !

!RGVariable methodsFor: '*Calypso-Ring' stamp: ''!
isReadIn: aCompiledCode
"TODO"
	^aCompiledCode readsSlot: self! !

!RGVariable methodsFor: '*Calypso-Ring' stamp: ''!
isWrittenIn: aCompiledCode

"TODO"
	^aCompiledCode writesSlot: self! !

!RGVariable methodsFor: 'testing' stamp: ''!
needsFullDefinition
	"all but InstanceVariableSlot and ClassVariable need to print the full definition"
	^true! !

!RGVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitVariableNode: aNode! !

!RGVariable methodsFor: 'testing' stamp: ''!
isTempVariable
	^false! !

!RGVariable methodsFor: 'testing' stamp: ''!
isUninitialized
	^false! !

!RGVariable methodsFor: 'testing' stamp: ''!
isReservedVariable
	"Ring2 does not model self, super, thisContext"
	^false! !

!RGVariable methodsFor: 'read/write usage' stamp: ''!
analyzeWrite: aVariableNode by: aSemanticAnalyzer! !

!RGVariable methodsFor: 'testing' stamp: ''!
isVariable
	^true! !

!RGVariable methodsFor: 'testing' stamp: ''!
isClassInstanceVariable

	^false! !

!RGVariable methodsFor: 'testing' stamp: ''!
isInstanceVariable
	"check if the var is an instance variable (a Slot)"
	^false! !

!RGVariable methodsFor: 'testing' stamp: ''!
isSuperVariable
	
	^ false! !

!RGVariable methodsFor: 'testing' stamp: ''!
isPoolVariable

	^false! !

!RGVariable methodsFor: 'testing' stamp: ''!
isLocalVariable
	^false! !

!RGVariable methodsFor: 'testing' stamp: ''!
isWritable
	"Ring2 variables are all writable, e.g. it does not model Arguments"
	^true! !

!RGVariable methodsFor: 'accessing' stamp: ''!
name: aString

	self parent announceDefinitionChangeDuring: [ 
		super name: aString ].
! !

!RGVariableDefinition commentStamp: ''!
A variable definition!
!RGVariableDefinition methodsFor: 'comparing' stamp: 'nil'!
= aRGVariableDefinition
	"This variable look for equality of the key properties of the receiver"

	^(super = aRGVariableDefinition)
		and:[ self name == aRGVariableDefinition name ]! !

!RGVariableDefinition methodsFor: 'comparing' stamp: 'nil'!
hash

	^super hash bitXor: self name hash! !

!RGVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isClassVariable

	^false! !

!RGVariableDefinition methodsFor: 'accessing' stamp: 'nil'!
environment

	^ self parent environment ! !

!RGVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isVariable

	^true! !

!RGVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isClassInstanceVariable

	^false! !

!RGVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isInstanceVariable

	^false! !

!RGVariableDefinition methodsFor: 'accessing' stamp: 'nil'!
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 ]! !

!RGVariableDefinition methodsFor: 'testing' stamp: 'nil'!
isPoolVariable

	^false! !

!RGVariableDefinition class methodsFor: 'testing' stamp: 'nil'!
isAbstract

	^ self == RGVariableDefinition! !

!RGVariableDefinitionTest commentStamp: ''!
SUnit tests for variable definitions!
!RGVariableDefinitionTest methodsFor: 'testing' stamp: ''!
testClassInstanceVariable
	| instVar newClass metaClass |
	instVar := RGClassInstanceVariableDefinition named: 'sizes'.

	self assert: instVar isClassInstanceVariable.
	self assert: instVar isVariable.
	self assert: instVar name equals: 'sizes'.
	self assert: instVar parent isNil.
	self assert: instVar isMetaSide.

	newClass := RGClassDefinition named: #OrderedCollection.
	newClass withMetaclass.
	metaClass := newClass classSide.
	instVar := metaClass addInstVarNamed: 'sizes'.
	self assert: instVar parent equals: metaClass.
	self assert: metaClass instanceVariables size equals: 1! !

!RGVariableDefinitionTest methodsFor: 'testing' stamp: ''!
testVariableEquality
	| variable1 variable2 |
	variable1 := OrderedCollection asRingDefinition instanceVariableNamed: #array.
	variable2 := OrderedCollection asRingDefinition instanceVariableNamed: #array.
	self assert: variable1 equals: variable2.

	variable1 := (RGClassVariableDefinition named: #Foo) parentName: #Test.
	variable2 := (RGClassVariableDefinition named: #Foo) parentName: #Test.
	self assert: variable1 equals: variable2.

	variable2 := (RGClassVariableDefinition named: #Foo) parentName: #Test2.
	self deny: variable1 equals: variable2! !

!RGVariableDefinitionTest methodsFor: 'testing' stamp: ''!
testPoolVariable
	| poolVar newClass |
	poolVar := RGPoolVariableDefinition named: 'TextConstants'.

	self assert: poolVar isPoolVariable.
	self assert: poolVar isVariable.
	self assert: poolVar name equals: 'TextConstants'.
	self assert: poolVar parent isNil.
	self assert: poolVar isMetaSide not.

	newClass := RGClassDefinition named: #OrderedCollection.
	poolVar := (RGPoolVariableDefinition named: 'TextConstants') parent: newClass.
	self assert: poolVar parent equals: newClass.
	self assertEmpty: newClass sharedPools.

	newClass sharedPools add: poolVar.
	self assert: newClass sharedPools size equals: 1! !

!RGVariableDefinitionTest methodsFor: 'testing' stamp: ''!
testClassVariable
	| instVar newClass |
	instVar := RGClassVariableDefinition named: 'DependentsFields'.

	self assert: instVar isClassVariable.
	self assert: instVar isVariable.
	self assert: instVar name equals: 'DependentsFields'.
	self assert: instVar parent isNil.
	self assert: instVar isMetaSide not.

	newClass := RGClassDefinition named: #Object.
	instVar := (RGClassVariableDefinition named: 'DependentsFields') parent: newClass.

	self assert: instVar parent equals: newClass.
	self assertEmpty: newClass classVariables.

	newClass classVariables add: instVar.
	self assert: newClass classVariables size equals: 1! !

!RGVariableDefinitionTest methodsFor: 'testing' stamp: ''!
testInstanceVariable
	| instVar newClass |
	instVar := RGInstanceVariableDefinition named: 'size'.

	self assert: instVar isInstanceVariable.
	self assert: instVar isVariable.
	self assert: instVar name equals: 'size'.
	self assert: instVar parent isNil.
	self assert: instVar isMetaSide not.

	newClass := RGClassDefinition named: #OrderedCollection.
	instVar := newClass addInstVarNamed: 'array'.
	self assert: instVar parent equals: newClass.
	self assert: newClass instanceVariables size equals: 1! !

!RGVariableLayout methodsFor: '*Ring-Monticello' stamp: ''!
mcType

	^ #variable ! !

!RGVariableLayout methodsFor: 'testing - types' stamp: ''!
isVariableLayout

	^ true! !

!RGVariableLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton."
	
	^ #variableSubclass:! !

!RGWeakLayout methodsFor: '*Ring-Monticello' stamp: ''!
mcType

	^ #weak ! !

!RGWeakLayout methodsFor: 'testing - types' stamp: ''!
isWeakLayout

	^ true! !

!RGWeakLayout methodsFor: 'testing - types' stamp: ''!
isVariableLayout

	^ true! !

!RGWeakLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton."
	
	^ #weakSubclass:! !

!RGWordLayout methodsFor: '*Ring-Monticello' stamp: ''!
mcType

	^ #words ! !

!RGWordLayout methodsFor: 'testing - types' stamp: ''!
isWordLayout

	^ true! !

!RGWrongEnvironment commentStamp: ''!
Trying to add to a model an element from a different environment.!
!RPackage commentStamp: ''!
A RPackage is a new implementation of package. Note that it does not touch classes but it is just a layer on top of classes therefore removing a method from a package does not change the underlying class. 


Instance Variables
	classDefinedSelectors:		Dictionary
	classExtensionSelectors:		Dictionary
	metaclassDefinedSelectors:		Dictionary
	metaclassExtensionSelectors:		Dictionary
	packageName:		String
	classes: OrderedCollection of Symbols
	classTags: is a mapping from tags to classNames

The reason we use four dictionaries is that this way we only store #Point in both as the class and the metaclass are involved. We do not have to with Point_class problem when comparing defined and extended classes. The idea is taken from the RBSelectorEnvironment. 					
		
Class Invariant one:
	Classes should not contain metaclass name, but only class names
	
	

Implementation notes 
====================
This class went over 3 internal representations implementation. 
	- first: 	a list of class + two dictionaries: class * methods
	This was not good since we add to go all the time over the list of classes.
	- second: 4 dictionaries class * selectors 
	This was not good since we want to have defined classes without methods. 
	- third: 4 dictionaries + definedClasses

Originally I wanted to avoid to have a defined class list and I wanted to avoid to have to declare the class as defined. But this is not really good since
	- we will want to know if a class definition (without method for example is defined in a given package)
	- second this is easier to hook the packageOf: behavior (we register the package class when the class is 	added to the package).

defined classes information is redundant with the dictionary keys of defined methods but we would have to check and register the class to the packageOrganizer the first time a method is defined then also check on remove to unregister the class from the packageOrganizer.

Adding a method does not define the class as a defined package class. This has to be done explictly. The reason for this choice is that a class should register to the packageOrganizer and that I do not want to do it each time a method is added and I do not want to test it each time a method is added. Now this is done only when the class is declared as defined. 
We could also give the complete freedom to the client to register the class but I thought it was a good compromise. 
	
	
ClassTag are tags that can be associated to classes. They help user organizing their class internal. 
So that we can have a package infrastructure as follows:
	Package1
		ClassA
		ClassB
	in case there is no tags associated to the package
	or
	Package2	
		Tag1
			ClassA
			ClassB
		Tag2
			ClassC
			ClassD
			ClassE
			ClassA		
	
Todo
====
	Next: 
	- finish 
	- build up a synchronizer that import PackageInfo.
	

	

	
!
!RPackage methodsFor: 'properties' stamp: ''!
propertyAt: propName
	^ self
		propertyAt: propName
		ifAbsent: [ nil ]! !

!RPackage methodsFor: 'properties' stamp: ''!
removeProperty: propName ifAbsent: aBlock
	| property |
	self properties ifNil: [^aBlock value].
	property := self properties
		removeKey: propName
		ifAbsent: aBlock.
	self removePropertiesIfEmpty.
	^ property! !

!RPackage methodsFor: 'class tags' stamp: ''!
addClassDefinition: aClass toClassTag: aSymbol
	"Tags the class aClass with the tag aSymbol"
	
	self addClassDefinitionName: aClass name toClassTag: aSymbol! !

!RPackage methodsFor: 'testing' stamp: ''!
definesOrExtendsClass: aClass
	"Returns true whether the class, aClass, is one of the locally defined classes of the receiver or 
	if the receiver extends such class (that is defined in another package)"
	
	| canonizedName |
	canonizedName := aClass instanceSide name.
	^ (classes includes: canonizedName) 
		or: [self extendedClassNames includes: canonizedName]! !

!RPackage methodsFor: 'private' stamp: ''!
toTagName: aSymbol
	^ (aSymbol beginsWith: self name, '-')
		ifTrue: [ (aSymbol allButFirst: self name size + 1) asSymbol ]
		ifFalse: [ aSymbol ]! !

!RPackage methodsFor: 'class tags' stamp: ''!
extensionsForTag: aRPackageTag

	^ self extensionMethods select: [ :extensionMethod | | category |
		category := extensionMethod protocol allButFirst.
		self category: category matches: aRPackageTag categoryName ]! !

!RPackage methodsFor: 'add method - selector' stamp: ''!
addSelector: aSelector ofClassName: aClassName
	"Add the method to the receiver. If the class is not locally defined in that package then the method is defined as a method extension: ie extending another package. Note that this method does not add the method to the class, it just records in the package that the method is packaged."
	
	( self includesClassNamed: aClassName)
		ifFalse: [(classExtensionSelectors at: aClassName asSymbol ifAbsentPut: [Set new]) add: aSelector]
		ifTrue: [(classDefinedSelectors at: aClassName asSymbol ifAbsentPut: [Set new]) add: aSelector].
	^ aSelector.! !

!RPackage methodsFor: 'testing' stamp: ''!
includesExtensionSelector: aSelector ofClass: aClass
	"Return true if the receiver includes the method of selector aSelector. Only checks methods extending other packages"
	
	| sels |
	sels := self extensionSelectorsForClass: aClass.
	^ sels includes: aSelector.! !

!RPackage methodsFor: 'testing' stamp: ''!
includesSelector: aSelector ofMetaclassName: aClassName
	"Return true if the receiver includes the method of selector aSelector. Checks methods defined locally as well as extending other packages"
	
	^ (self includesDefinedSelector: aSelector ofMetaclassName: aClassName)
		or: [(self includesExtensionSelector: aSelector ofMetaclassName: aClassName)]! !

!RPackage methodsFor: 'private' stamp: ''!
organizer
	^ self class organizer! !

!RPackage methodsFor: 'private - register' stamp: ''!
registerClassName: aClassNameSymbol
	"Private method that declares the mapping between a class and its package."
	self organizer
		registerPackage: self forClassName: aClassNameSymbol! !

!RPackage methodsFor: 'removing' stamp: ''!
removeFromSystem
	| extendedClasses |

	extendedClasses := self extendedClasses.
	
	self definedClasses do: #removeFromSystem.
	self extensionMethods do: #removeFromSystem.

	extendedClasses do:[:each | each organization removeProtocolIfEmpty: ('*' , name) asSymbol].
	self unregister.! !

!RPackage methodsFor: 'accessing' stamp: ''!
definedMethodsForClass: aClass

	^ (self definedSelectorsForClass: aClass) asOrderedCollection collect: [ :each | aClass >> each ]! !

!RPackage methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterTagsFor: aStep
	<stSpotterOrder: 20>
	self classTags size <= 1 ifTrue: [ ^ self ].
	aStep listProcessor
			allCandidates: [ self classTags sorted: [ :a :b | a name < b name ] ];
			title: 'Tags';
			itemName: [ :item | item name ];
			filter: StFilterSubstring! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
systemOrganization 

	^ Smalltalk globals organization! !

!RPackage methodsFor: 'accessing' stamp: ''!
extendedClasses 
	"Return classes and metaclasses that are extended in the receiver. They represent the classes of method extensions"
	^ (metaclassExtensionSelectors keys 
		select: [ :each| Smalltalk globals includesKey: each ]
		thenCollect: [:each | (Smalltalk globals at: each) classSide])
			union:  (classExtensionSelectors keys 
						select: [ :each| Smalltalk globals includesKey: each ]
						thenCollect: [:each | Smalltalk globals at: each])! !

!RPackage methodsFor: 'accessing' stamp: ''!
extensionSelectors
	"Extension methods are methods defined on classes that are not defined in the receiver"

	| classSels |
	classSels := Set new.
	classExtensionSelectors valuesDo: [ :each | classSels addAll: each ].
	metaclassExtensionSelectors valuesDo: [ :each | classSels addAll: each ].
	^ classSels! !

!RPackage methodsFor: 'class tags' stamp: ''!
removeClassDefinitionName: aClassName fromClassTag: aSymbol
	"Detags the class aClass with the tag aSymbol"
	| tag |
	
	tag := self classTagNamed: (self toTagName: aSymbol) ifAbsent: [ ^ self ].
	tag removeClassNamed: aClassName.
	tag isEmpty 
		ifTrue: [ self basicRemoveTag: tag ].! !

!RPackage methodsFor: 'accessing' stamp: ''!
orderedClasses

	| tmp |
	tmp := self definedClasses asArray sort: [:a :b | a name <= b name].
	tmp := tmp, (self extendedClasses asArray sort: [:a :b | a name <= b name]).
	^tmp collect: [:e | e instanceSide ]! !

!RPackage methodsFor: 'register' stamp: ''!
renameTo: aSymbol
	"Rename a package with a different name, provided as a symbol"

	| oldName newName oldCategoryNames repositoryGroup |
	oldName := self name.
	newName := aSymbol asSymbol.
	repositoryGroup := self mcPackage workingCopy repositoryGroup.
	self organizer validatePackageDoesNotExist: aSymbol.
	oldCategoryNames := (self classTags collect: [:each | each categoryName] as: Set)
		add: self name;
		difference: {newName}.
	self name: aSymbol.
	SystemAnnouncer uniqueInstance
		suspendAllWhile: [ self definedClasses
				do:
					[ :each | each category: newName , (each category allButFirst: oldName size) ].
			oldCategoryNames
				do: [ :each | SystemOrganizer default removeCategory: each ] ].
	self renameTagsPrefixedWith: oldName to: newName.
	self renameExtensionsPrefixedWith: oldName to: newName.
	self organizer
		basicUnregisterPackageNamed: oldName;
		basicRegisterPackage: self.
	self mcPackage workingCopy repositoryGroup: repositoryGroup.
	SystemAnnouncer uniqueInstance
		announce:
			(RPackageRenamed to: self oldName: oldName newName: newName)! !

!RPackage methodsFor: '*CodeExport' stamp: ''!
fileOut
	| internalStream |
	
	internalStream := (String new: 1000) writeStream.

	self classTags do: [ :each | 
		SystemOrganization 
			fileOutCategory: each categoryName 
			on: internalStream ].	
	
	classExtensionSelectors keysAndValuesDo: [ :className :selectors | 
		selectors do: [ :selector | | extendedClass |
			extendedClass := self class environment classNamed: className.
			extendedClass fileOutMethod: selector on: internalStream ] ].
	
	metaclassExtensionSelectors keysAndValuesDo: [ :className :selectors | 
		selectors do: [ :selector | | extendedClass |
			extendedClass := self class environment classNamed: className.
			extendedClass classSide fileOutMethod: selector on: internalStream ] ].
	
	^ CodeExporter writeSourceCodeFrom: internalStream baseName: self name isSt: true.! !

!RPackage methodsFor: 'iteration' stamp: ''!
definedClassesDo: aBlock

	classDefinedSelectors keysDo: aBlock.
	metaclassDefinedSelectors keysDo: aBlock.! !

!RPackage methodsFor: '*SUnit-Visitor' stamp: ''!
acceptSUnitVisitor: aTSUnitVisitor
	^ aTSUnitVisitor visitRPackage: self! !

!RPackage methodsFor: '*Tool-DependencyAnalyser' stamp: ''!
manuallyResolvedDependencies

	^ self packageManifestOrNil
		ifNil: [ #() ]
		ifNotNil: #manuallyResolvedDependencies! !

!RPackage methodsFor: '*Manifest-Core' stamp: ''!
packageComment
	^ self packageManifestOrNil ifNil: [ '' ] ifNotNil: [ :manifest | manifest comment ]! !

!RPackage methodsFor: 'testing' stamp: ''!
isDefault
	"Return whether the receiver is the default package, i.e. the one used when nothing else is specified."
	^ self name = self class defaultPackageName! !

!RPackage methodsFor: 'private' stamp: ''!
definedMethodsBecomeExtendedForMetaclass: aClassName
	"the package may contain defined methods and their class is removed to the receiver. The status of such methods should now be extended"
	"Precondition: aClassName is in the defined list"
	
	| ext |
	(metaclassDefinedSelectors keys includes: aClassName) ifFalse: [^ self].
	ext := metaclassDefinedSelectors at: aClassName.
	metaclassDefinedSelectors removeKey: aClassName ifAbsent: [self reportBogusBehaviorOf: #definedMethodsBecomeExtendedForMetaclass:].
	(metaclassExtensionSelectors keys includes: aClassName) ifTrue: [self error: aClassName , ' should not be defined in extension'.]. "we should remove this check later"
	metaclassDefinedSelectors at: aClassName put: ext.! !

!RPackage methodsFor: 'class tags' stamp: ''!
classesForClassTag: aSymbol
	"Returns the classes tagged using aSymbol"
	
	^ (self 
		classTagNamed: (self toTagName: aSymbol) 
		ifAbsent: [ ^ #() ])
		classes! !

!RPackage methodsFor: '*System-Support' stamp: ''!
allUnsentMessages
	^SystemNavigation new allUnsentMessagesIn: (self methods collect: [ :cm | cm selector ]) asSet! !

!RPackage methodsFor: 'accessing' stamp: ''!
definedSelectorsForClass: aClass

	^ aClass isMeta
		ifTrue: [ metaclassDefinedSelectors at: aClass instanceSide originalName ifAbsent: [ #() ] ]
		ifFalse: [ classDefinedSelectors at: aClass originalName ifAbsent: [ #() ] ]! !

!RPackage methodsFor: 'private' stamp: ''!
importPackage: anRPackage 
	anRPackage definedClasses  
		do: [ :className | self importClass: className ].
	"new rpackage inherits the extentions"
	classExtensionSelectors :=  classExtensionSelectors, (anRPackage classExtensionSelectors).
	metaclassExtensionSelectors := metaclassExtensionSelectors, (anRPackage metaclassExtensionSelectors).! !

!RPackage methodsFor: 'testing' stamp: ''!
isDeprecated
	^ self packageManifestOrNil 
		ifNil: [ ^ false ]
		ifNotNil: [ :manifest | manifest isDeprecated ]! !

!RPackage methodsFor: 'queries' stamp: ''!
tagsForClasses
	"Any class could be tagged for user purpose.
	Now we implement it on top of RPackageTag"
	
	^self classTags reject: [:each | each isRoot] thenCollect: [:each | each name]! !

!RPackage methodsFor: '*SUnit-Tests' stamp: ''!
testSuite

	| suite |
	
	suite := TestSuite named: self packageName.
	suite addTests: ((self classes select: #isTestCase) flatCollect: [:aTestClass | aTestClass suite tests]).
	
	^ suite ! !

!RPackage methodsFor: '*Calypso-SystemQueries' stamp: ''!
definesOverridesOf: aMethod

	aMethod origin isInstanceSide 
		ifTrue: [  
			(self definesOverridesOf: aMethod in: classDefinedSelectors) ifTrue: [^true].
			(self definesOverridesOf: aMethod in: classExtensionSelectors) ifTrue: [^true]]
		ifFalse: [ 
			(self definesOverridesOfClassSide: aMethod in: metaclassDefinedSelectors) ifTrue: [^true].
			(self definesOverridesOfClassSide: aMethod in: metaclassExtensionSelectors) ifTrue: [^true]].
	
	^false! !

!RPackage methodsFor: 'accessing' stamp: ''!
selectorsForClass: aClass
	"Returns all selectors for a class in the receiver without distinction of extensions or not"
	
	^ (self includesClass: aClass)
		ifFalse: [self extensionSelectorsForClass: aClass]
		ifTrue: [self definedSelectorsForClass: aClass]! !

!RPackage methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterMonticelloWorkingCopyFor: aStep
	<stSpotterOrder: 42>
	aStep listProcessor
		title: 'Monticello Working Copy';
		allCandidates: [ self mcPackage 
			ifNotNil: [ :mcPackage | Array with: mcPackage workingCopy ] 
			ifNil: [ #() ] ];
		itemIcon: [ Smalltalk ui icons iconNamed: #versionControlIcon ];
		filter: StFilterSubstring! !

!RPackage methodsFor: '*Calypso-SystemQueries' stamp: ''!
definesOverridesOf: aMethod in: classAndSelectors

	| methodClass selector |
	methodClass := aMethod origin.
	selector := aMethod selector.
	
	classAndSelectors keysAndValuesDo: [ :className :selectors |
		((selectors includes: selector) 
			and: [ (Smalltalk globals classNamed: className) inheritsFrom: methodClass ])
				ifTrue: [ ^true ] ].
	^false! !

!RPackage methodsFor: 'class tags' stamp: ''!
classTagNamed: aSymbol ifPresent: aBlock
	^ classTags 
		detect: [ :each | each name = aSymbol ] 
		ifFound: [ :tag | aBlock cull: tag ] 
		ifNone: [ nil ]! !

!RPackage methodsFor: 'class tags' stamp: ''!
removeClassTag: aSymbol
	"Remove the class tag from the receiver."
	
	self basicRemoveTag: (self 
		classTagNamed:  (self toTagName: aSymbol) 
		ifAbsent: [ ^ self ])! !

!RPackage methodsFor: 'properties' stamp: ''!
removePropertiesIfEmpty
	^ Properties at: self ifPresent: [ :dict |
		dict ifEmpty: [ Properties removeKey: self ] ]! !

!RPackage methodsFor: '*Renraku' stamp: ''!
critiques
	^ ReCriticEngine critiquesOf: self! !

!RPackage methodsFor: 'properties' stamp: ''!
removeProperty: propName
	^ self
		removeProperty: propName
		ifAbsent: [ nil ]! !

!RPackage methodsFor: '*Tool-DependencyAnalyser' stamp: ''!
ignoredDependencies

	^ self packageManifestOrNil
		ifNil: [ #() ]
		ifNotNil: #ignoredDependencies! !

!RPackage methodsFor: 'add method - compiled method' stamp: ''!
removeMethod: aCompiledMethod 
	"Remove the method to the receiver as a defined method."
	|  methodClass |
	
	methodClass := aCompiledMethod methodClass. 
	methodClass isMeta
		ifTrue: [
			self 
				removeSelector: aCompiledMethod selector 
				ofMetaclassName: methodClass instanceSide originalName ]
		ifFalse: [
			self 
				removeSelector: aCompiledMethod selector 
				ofClassName: methodClass originalName ].

	^ aCompiledMethod.! !

!RPackage methodsFor: 'private' stamp: ''!
classExtensionSelectors
	^ classExtensionSelectors! !

!RPackage methodsFor: 'testing' stamp: ''!
definesClass: aClass
	"Returns true if the class, aClass, is one of the locally defined classes"
	"should be probably removed since this is the same as includesClass: or the inverse"
	^ self includesClass: aClass! !

!RPackage methodsFor: 'private' stamp: ''!
extendedMethodsBecomeDefinedForClass: aClassName
	"the package may contain extension methods and their class is added to the receiver. The status of such methods should now be defined"
	"Precondition: aClassName is in the defined list"
	
	| ext |
	(classExtensionSelectors keys includes: aClassName) ifFalse: [^ self].
	ext := classExtensionSelectors at: aClassName.
	classExtensionSelectors removeKey: aClassName ifAbsent: [self reportBogusBehaviorOf:   #extendedMethodsBecomeDefinedForClass: ].
	(classDefinedSelectors keys includes: aClassName) ifTrue: [self error: aClassName , ' should not be defined in extension'.]. "we should remove this check later"
	classDefinedSelectors at: aClassName put: ext.! !

!RPackage methodsFor: 'private' stamp: ''!
importClass: aClass
	"import a class already created but not attached to a package to the receiver. 
	Handle also *- convention. Methods defined in *category are not added to the package.
	Pay attention that it will not import anything from the metaClass side"

	self basicImportClass: aClass.
	self basicImportClass: aClass classSide.	
	self 
		addClassDefinition:  aClass
		toClassTag: (self toTagName: aClass category)! !

!RPackage methodsFor: 'private' stamp: ''!
metaclassExtensionSelectors
	^ metaclassExtensionSelectors! !

!RPackage methodsFor: '*Renraku' stamp: ''!
package
	^ self! !

!RPackage methodsFor: 'removing' stamp: ''!
removeClass: aClass
	"Remove the class and all its methods from the receiver. If we have a protocol which looks like an extension of us, rename it to 'as yet unclassified' to avoid breaking things afterwards."

	aClass organization categories
		do: [ :each | 
			(self isYourClassExtension: each)
				ifTrue: [ aClass organization renameCategory: each toBe: Protocol defaultName ] ].
	(self definedMethodsForClass: aClass instanceSide) do: [ :aCompiledMethod | self removeMethod: aCompiledMethod ].
		"we also have also have to remove methods from class side"
	(self definedMethodsForClass: aClass classSide) do: [ :aCompiledMethod | self removeMethod: aCompiledMethod ].
	self removeClassDefinitionWithoutCheckingMethods: aClass.
	self removeClassTagsForClassNamed: aClass name! !

!RPackage methodsFor: '*Manifest-Core' stamp: ''!
criticNameOn: aStream
	"This behavior may be folded later by changing the name of this method or using another one."
	
	aStream << self packageName! !

!RPackage methodsFor: 'add method - selector' stamp: ''!
addSelector: aSelector ofMetaclassName: aClassName
	"Add the method to the receiver. If the class is not locally defined in that package then the method is defined as a method extension: ie extending another package. Note that this method does not add the method to the class, it just records in the package that the method is packaged. aClassName is the sole instance class name and not its metaclass one: i.e. adding Point class>>new is done as addSelector: #new ofMetaclassName: #Point"
	
	( self includesClassNamed: aClassName) 
		ifFalse: [(metaclassExtensionSelectors at: aClassName asSymbol ifAbsentPut: [Set new]) add: aSelector]
		ifTrue: [(metaclassDefinedSelectors at: aClassName asSymbol ifAbsentPut: [Set new]) add: aSelector].
	^ aSelector.! !

!RPackage methodsFor: 'class tags' stamp: ''!
removeClassDefinition: aClass fromClassTag: aSymbol
	"Detags the class aClass with the tag aSymbol"
	
	self 
		removeClassDefinitionName: aClass name 
		fromClassTag: aSymbol! !

!RPackage methodsFor: '*Calypso-SystemQueries' stamp: ''!
isAboutPackage: aPackage

	^self == aPackage! !

!RPackage methodsFor: 'class tags' stamp: ''!
classNamesForClassTag: aSymbol
	"Returns the classes tagged using aSymbol"
	
	^ (self 
		classTagNamed: aSymbol 
		ifAbsent: [ ^ #() ]) classNames.! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
systemCategoryPrefix
	^ self name! !

!RPackage methodsFor: 'converting' stamp: ''!
demoteToTagInPackageNamed: aString
	| newRPackage |

	aString = self name ifTrue: [ ^ self ].
	
	self unregister.
	newRPackage := self class organizer 
		packageNamed: aString 
		ifAbsent:  [ (self class named: aString) register ].
	newRPackage importPackage: self.
		
	newRPackage classes do: [ :each | 
		SystemAnnouncer uniqueInstance 
			classRepackaged: each 
			from: self  
			to: newRPackage ].! !

!RPackage methodsFor: 'class tags' stamp: ''!
actualClassTags
	
	(classTags size = 1 and: [classTags anyOne isRoot]) ifTrue: [ ^#() ].
	
	^classTags! !

!RPackage methodsFor: '*Iceberg-Core' stamp: ''!
iceRepository
	^ Iceberg repositoryForPackage: self
! !

!RPackage methodsFor: 'class tags' stamp: ''!
classTagCategoryNames
	^ (Set with: self packageName), (self classTags collect: [:each | each categoryName]).! !

!RPackage methodsFor: 'accessing' stamp: ''!
methodsForClass: aClass
	"Returns all compiled methods for a class in the receiver without distinction of extensions or not"
	
	^ (self includesClass: aClass)
		ifFalse: [self extensionMethodsForClass: aClass]
		ifTrue: [self definedMethodsForClass: aClass]! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
packages 
	"Compatibility with monticello and old PackageInfo"
	^ self classTags! !

!RPackage methodsFor: 'private' stamp: ''!
moveClass: aClass fromPackage: oldPackage toTag: aTag 

	oldPackage removeClass: aClass.
	self importClass: aClass inTag: aTag.
	
	SystemAnnouncer uniqueInstance 
		classRepackaged: aClass 
		from: oldPackage 
		to: self.! !

!RPackage methodsFor: 'class tags' stamp: ''!
addClassTag: aSymbol
	"Add the class tag from the receiver, if already added do nothing."
	| tagName newTag |

	"strip package name if needed"
	tagName := self toTagName: aSymbol.
	
	^ self 
		classTagNamed: tagName
		ifAbsent: [ 
			self class organizer 
				validateCanBeAddedPackage: self
				tagName: tagName.
			newTag := self basicAddClassTag: tagName.
			SystemAnnouncer uniqueInstance classTagAdded: tagName inPackage: self.
			^newTag]! !

!RPackage methodsFor: 'updating' stamp: ''!
updateSelector: oldSelector inClass: aClass withNewSelector: newSelector

	"here we check if the old seletor is defined in the package or if it is an extension. Then we dispatch the work to the corresponding method.
	For one specific class, a selector is either a defined selector or an extension selector, there is no way to have a couple of class->selector present in both dictionary"
	
	(self includesDefinedSelector: oldSelector ofClass: aClass) 
		ifTrue: [^ self updateDefinedSelector: oldSelector inClass: aClass  withNewSelector: newSelector].
	(self includesExtensionSelector: oldSelector ofClass: aClass)
		ifTrue: [^ self updateExtensionSelector: oldSelector inClass: aClass  withNewSelector: newSelector].! !

!RPackage methodsFor: '*Refactoring-Environment' stamp: ''!
asEnvironment
	^ RBPackageEnvironment package: self! !

!RPackage methodsFor: 'slices' stamp: ''!
metaclassDefinedSlicesDo: aBlock
	"This method iterates over the defined class and their associated selectors. a slice is a class * list of selectors. aBlock will be applied to all the extensions slices of the receiver. aBlok first argument is the class and the second argument a list of method selectors"
	
	metaclassDefinedSelectors keysAndValuesDo: aBlock! !

!RPackage methodsFor: 'accessing' stamp: ''!
definedClasses 
	| definedClasses |
	definedClasses := Set new.
	classes do: [:each | 
		Smalltalk globals 
			at: each 
			ifPresent: [:aClass| definedClasses add: aClass ]].
	^ definedClasses! !

!RPackage methodsFor: 'properties' stamp: ''!
propertyAt: propName ifAbsent: aBlock
	self properties ifNil: [^aBlock value].
	^ self properties
		at: propName
		ifAbsent: aBlock! !

!RPackage methodsFor: 'register' stamp: ''!
unregister
	self organizer unregisterPackage: self! !

!RPackage methodsFor: 'updating' stamp: ''!
updateDefinedSelector: oldSelector inClass: aClass withNewSelector: newSelector

	aClass isMeta
		ifTrue: [
			(metaclassDefinedSelectors at: aClass instanceSide name asSymbol) remove: oldSelector. 
			(metaclassDefinedSelectors at: aClass instanceSide name asSymbol) add: newSelector. ]
		ifFalse: [
			(classDefinedSelectors  at: aClass name asSymbol) remove: oldSelector. 
			(classDefinedSelectors  at: aClass name asSymbol) add: newSelector. ]! !

!RPackage methodsFor: 'private' stamp: ''!
importProtocol: aProtocol forClass: aClass
	"import all the methods of a protocol as defined in the receiver."

	(aClass organization listAtCategoryNamed: aProtocol) do: [ :each | 
		aClass
			compiledMethodAt: each
			ifPresent: [ :method | method isFromTrait ifFalse: [ self addMethod: method ] ] ]! !

!RPackage methodsFor: '*Manifest-Core' stamp: ''!
packageComment: aDescription
	^ self packageManifest
		ifNil: [ '' ]
		ifNotNil: [ :manifest | manifest comment: aDescription stamp: Author changeStamp]! !

!RPackage methodsFor: 'add class' stamp: ''!
addClassDefinition: aClass
	"Add only the class definition of aClass, as a class defined by the receiver. The term classdefinition denotes the fact that we do not treat its methods. aClass methods are not added to the package. aClass can be either a class or a metaclass"
	
	self addClassDefinitionName: aClass instanceSide name.! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
methodCategoryPrefix
	^ '*', self name asLowercase! !

!RPackage methodsFor: 'private - register' stamp: ''!
removeClassDefinitionNamed: aClassNameSymbol
	"aClassNameSymbol should be the name of a class and not a metaclass to be coherent with the class invariant that classes are only class names and not metaclass ones. 
	
	This method removes the class definition from the receiver and its organizer"

	| removed |
	removed := classes remove: aClassNameSymbol ifAbsent: [nil].
	removed ifNotNil: [ self unregisterClassName: aClassNameSymbol.]! !

!RPackage methodsFor: 'testing' stamp: ''!
includesDefinedSelector: aSelector ofClassName: aClassName
	"Return true if the receiver includes the method of selector aSelector. Only checks methods defined (not extended by other packages or package extensions)"
	
	| sels |
	sels := classDefinedSelectors at: aClassName ifAbsent: [^ false].
	^ sels includes: aSelector.! !

!RPackage methodsFor: 'accessing' stamp: ''!
hierarchyRoots
	"Returns all the hiearchy roots (by opposition to single classes inheriting from class outside the package) of a package"

	^ self definedClasses
		select: [ :each | (each superclass isNil or: [ each superclass package ~~ self ]) and: [ each hasSubclasses ] ]! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
isForeignClassExtension: categoryName
	^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]! !

!RPackage methodsFor: 'class tags' stamp: ''!
addClassDefinitionName: aClassName toClassTag: aSymbol
	"Tags the class aClass with the tag aSymbol"
	
	(self addClassTag: aSymbol) addClassNamed: aClassName.! !

!RPackage methodsFor: 'queries' stamp: ''!
linesOfCode
	"An approximate measure of lines of code.
	Includes comments, but excludes blank lines."
	^self methods inject: 0 into: [:sum :each | sum + each linesOfCode]! !

!RPackage methodsFor: 'private' stamp: ''!
renameExtensionsPrefixedWith: oldName to: newName
	| protocols |
	
	protocols := self extensionMethods 
		collect: [ :each | each origin organization protocolNamed:  each protocol ]
		as: Set.
		
	protocols do: [ :each | each rename: '*', newName, (each name allButFirst: oldName size + 1) ]! !

!RPackage methodsFor: 'slices' stamp: ''!
classNamesAndExtensionSelectorsDo: aBlock
	"Iterate over the extended methods grouped by classes and apply the argument.
	The block will be passed a class name and each individual selectors.
	Only classes with methods are paired with their methods"
	
	classExtensionSelectors keysAndValuesDo: [ :classSymbol :methods |
			methods do: [ :sel |  aBlock value: classSymbol	value: sel]].
	
	metaclassExtensionSelectors keysAndValuesDo: [ :classSymbol :methods |
			methods do: [ :sel |  aBlock 
									value: (classSymbol, '_class') asSymbol
									value: sel]].! !

!RPackage methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterExtensionMethodsFor: aStep
	<stSpotterOrder: 30>
	aStep listProcessor
			allCandidates: [ self extensionMethods ];
			title: 'Extension Methods';
			filter: StFilterSubstring! !

!RPackage methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
stActDefault

	^ Smalltalk tools browser openOnPackage: self! !

!RPackage methodsFor: 'class tags' stamp: ''!
removeClassesMatchingTag: aTag
	
	aTag classes do: [ :class | self removeClassDefinition: class ]! !

!RPackage methodsFor: 'add class' stamp: ''!
addClassDefinitionName: aClassName
	"aClassName should only be a class (and not a metaclass name)"

	| aClassNameSymbol |
	('* class' match: aClassName)
		ifTrue: [ ^ self error: 'no metaclass name' ].
	aClassNameSymbol := aClassName asSymbol.
	(classes includes: aClassNameSymbol)
		ifTrue: [ ^ self ].
	classes add: aClassNameSymbol.
	self extendedMethodsShouldBecomeDefinedWhenAddingClassName: aClassNameSymbol.
	self registerClassName: aClassNameSymbol! !

!RPackage methodsFor: 'add method - compiled method' stamp: ''!
removeMethods: aCollection 
	aCollection do: [ :each | self removeMethod: each ]! !

!RPackage methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!RPackage methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterMonticelloPackageFor: aStep
	<stSpotterOrder: 41>
	aStep listProcessor
		title: 'Monticello Package';
		allCandidates: [ self mcPackage 
			ifNotNil: [ :mcPackage | Array with: mcPackage ] 
			ifNil: [ #() ] ];
		itemIcon: [ Smalltalk ui icons iconNamed: #monticelloPackageIcon ];
		filter: StFilterSubstring! !

!RPackage methodsFor: '*Monticello-RPackage' stamp: 'nil'!
mcPackage
	"Normally the corresponding MCPackage should exist, but in certain cases it could happen that it does not"
	
	^ self mcWorkingCopy ifNotNil: [ :workingCopy | workingCopy package ].
	! !

!RPackage methodsFor: '*Renraku' stamp: ''!
reBanName

	^ self name, ' (Package)'! !

!RPackage methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterClassesFor: aStep
	<stSpotterOrder: 20>
	aStep listProcessor
			allCandidates: [ self definedClasses sorted: [ :a :b | a name < b name ] ];
			title: 'Classes';
			filter: StFilterSubstring! !

!RPackage methodsFor: 'testing' stamp: ''!
includesExtensionSelector: aSelector ofMetaclassName: aClassName
	"Return true if the receiver includes the method of selector aSelector. Only checks methods extending other packages"
	
	| sels |
	sels := metaclassExtensionSelectors at: aClassName ifAbsent: [^ false].
	^ sels includes: aSelector.! !

!RPackage methodsFor: 'slices' stamp: ''!
metaclassExtensionSlicesDo: aBlock
	"This method iterates over the metaclass extensions and their associated selectors. A slice is a class * list of selectors. aBlock will be applied to all the extensions slices of the receiver. aBlok first argument is the class and second argument a list of selectors"
	
	metaclassExtensionSelectors keysAndValuesDo: aBlock! !

!RPackage methodsFor: 'add method - compiled method' stamp: ''!
addMethod: aCompiledMethod 
	"Add the method to the receiver as a defined method if the class is  defined in it, else as an extension."
	| methodClass |
	
	methodClass := aCompiledMethod methodClass. 
	(self includesClass: methodClass )
		ifTrue: [
			methodClass isMeta
				ifTrue: [
					(metaclassDefinedSelectors 
						at: methodClass instanceSide name  
						ifAbsentPut: [ Set new ]) 
						add: aCompiledMethod selector]
				ifFalse: [
					(classDefinedSelectors 
						at: methodClass name 
						ifAbsentPut: [ Set new ]) 
						add: aCompiledMethod selector ] ]
		ifFalse:  [
			methodClass isMeta
				ifTrue: [
					(metaclassExtensionSelectors 
						at: methodClass instanceSide name  
						ifAbsentPut: [ Set new ]) 
						add: aCompiledMethod selector.]
				ifFalse: [
					(classExtensionSelectors 
						at: methodClass name 
						ifAbsentPut: [ Set new ]) 
						add: aCompiledMethod selector].
				"we added a method extension so the receiver is an extending package of the class"
				self organizer registerExtendingPackage: self forClass: methodClass ].
					
	^ aCompiledMethod.! !

!RPackage methodsFor: 'comparing' stamp: ''!
<= aRPackage 

	^ self name <= aRPackage name! !

!RPackage methodsFor: '*Manifest-Core' stamp: ''!
manifestBuilderForRuleChecker: aRuleChecker
	"Return the manifestsince the rulechecker is keeping a cache, we ask it back"

	^ aRuleChecker manifestBuilderOfPackage: self! !

!RPackage methodsFor: 'accessing' stamp: ''!
extensionMethodsForClass: aClass
	"Change the set of extensions selectors to an Array to avoid compiled methods collisions in the resulting set."

	^ (self extensionSelectorsForClass: aClass) asArray collect: [ :each | aClass >> each ]! !

!RPackage methodsFor: 'add method - selector' stamp: ''!
removeSelector: aSelector ofClassName: aClassName
	"Remove the method in the package but does not propagate to the class itself.  Note that this method does not remove the method from the class, it just records in the package that the method is not in the package anymore."
	
	self basicRemoveSelector: aSelector ofClassName: aClassName.
	(classExtensionSelectors at: aClassName ifAbsent: [ #() ]) ifEmpty: [
		classExtensionSelectors removeKey: aClassName ifAbsent: [].
	].
	(classDefinedSelectors at: aClassName ifAbsent: [ #() ]) ifEmpty: [
		classDefinedSelectors removeKey: aClassName ifAbsent: [].
	].

	((metaclassExtensionSelectors at: aClassName ifAbsent: [#()]) isEmpty and: [(classExtensionSelectors at: aClassName ifAbsent: [#()]) isEmpty])
		ifTrue: [
				self organizer unregisterExtendingPackage: self forClassName: aClassName
	]! !

!RPackage methodsFor: 'private - register' stamp: ''!
removeAllMethodsFromClassNamed: aClassNameSymbol
	"Remove all the methods (defined and extensions) that are related to class aClassNameSymbol. aClassNameSymbol is the name of a class and not a metaclass - see class comment."

	classDefinedSelectors removeKey: aClassNameSymbol ifAbsent: [nil].
	classExtensionSelectors removeKey: aClassNameSymbol ifAbsent: [nil].
	metaclassDefinedSelectors removeKey: aClassNameSymbol ifAbsent: [nil].
	metaclassExtensionSelectors removeKey: aClassNameSymbol ifAbsent: [nil].! !

!RPackage methodsFor: 'private' stamp: ''!
extendedMethodsBecomeDefinedForMetaclass: aClassName
	"the package may contain extension methods and their class is added to the receiver. The status of such methods should now be defined"
	"Precondition: aClassName is in the defined list"
	
	| ext |
	(metaclassExtensionSelectors keys includes: aClassName) ifFalse: [^ self].
	ext := metaclassExtensionSelectors at: aClassName.
	metaclassExtensionSelectors removeKey: aClassName  ifAbsent: [self reportBogusBehaviorOf:  #extendedMethodsBecomeDefinedForMetaclass: ].
	(metaclassDefinedSelectors keys includes: aClassName) 
			ifTrue: [self error: aClassName , ' should not be defined in extension'.]. "we should remove this check later"
	metaclassDefinedSelectors at: aClassName put: ext.! !

!RPackage methodsFor: 'private' stamp: ''!
basicAddClassTag: tagName
	| packageTag |
			
	packageTag := RPackageTag package: self name: tagName.
	classTags add: packageTag.
	packageTag ensureSystemCategory.
	
	^ packageTag! !

!RPackage methodsFor: 'private' stamp: ''!
extendedMethodsShouldBecomeDefinedWhenAddingClassName: aClassName
	"the package may contain extension methods and their class is added to the receiver. The status of such methods should now be defined"
	"Precondition: aClassName is in the defined list"
	
	self extendedMethodsBecomeDefinedForClass: aClassName.
	self extendedMethodsBecomeDefinedForMetaclass: aClassName.! !

!RPackage methodsFor: 'testing' stamp: ''!
includesClassNamed: aSymbol
	"Returns true if the receiver includes class named aSymbol in the classes that are defined within it: only class definition are considered - not class extensions"
	
	^ classes includes: aSymbol asSymbol! !

!RPackage methodsFor: 'testing' stamp: ''!
includesClassesAffectedBy: aSystemAnnouncement

	^(aSystemAnnouncement affectsClassesDefinedInPackage: self)
		or: [ aSystemAnnouncement affectsClassesExtendedInPackage: self ]! !

!RPackage methodsFor: 'properties' stamp: ''!
propertyAt: propName put: propValue
	^ self ensureProperties
		at: propName
		put: propValue! !

!RPackage methodsFor: 'testing' stamp: ''!
includesDefinedSelector: aSelector ofMetaclassName: aClassName
	"Return true if the receiver includes the method of selector aSelector. Only checks methods defined (not extended by other packages or package extensions)"
	
	| sels |
	sels := metaclassDefinedSelectors at: aClassName ifAbsent: [^ false].
	^ sels includes: aSelector.! !

!RPackage methodsFor: '*Manifest-Core' stamp: ''!
packageManifest
	^ self definedClasses
		detect: [ :each | each isManifest ]
		ifNone: [ TheManifestBuilder new createManifestNamed: name]! !

!RPackage methodsFor: 'accessing' stamp: ''!
packageName

	^ name! !

!RPackage methodsFor: 'accessing' stamp: ''!
roots
	"Returns all the root classes of a package. A root class is a class whose superclass is not defined in the package. 
	Root classes are potentially root of inheritance trees defined in a package."

	^ self definedClasses
		select: [ :each | each superclass isNil or: [ each superclass package ~~ self ] ]! !

!RPackage methodsFor: 'accessing' stamp: ''!
selectors

	| sel |
	sel := Set new.
	metaclassExtensionSelectors valuesDo: [:each | sel addAll: each].
	classExtensionSelectors valuesDo: [:each | sel addAll: each].
	metaclassDefinedSelectors valuesDo: [:each | sel addAll: each].
	classDefinedSelectors valuesDo: [:each | sel addAll: each].
	^ sel! !

!RPackage methodsFor: 'accessing' stamp: ''!
extensionSelectorsForClass: aClass

	^ aClass isMeta
		ifTrue: [ metaclassExtensionSelectors at: aClass instanceSide originalName ifAbsent: [ #() ] ]
		ifFalse: [ classExtensionSelectors at: aClass originalName ifAbsent: [ #() ] ]! !

!RPackage methodsFor: 'testing' stamp: ''!
includesSelector: aSelector ofClass: aClass
	"Return true if the receiver includes the method of selector aSelector. Checks methods defined locally as well as extending other packages"
	
	^ aClass isMeta
		ifTrue: [ self includesSelector: aSelector ofMetaclassName: aClass instanceSide name  ]
		ifFalse: [ self includesSelector: aSelector ofClassName: aClass name  ]! !

!RPackage methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.	
	classes := Set new.
	metaclassExtensionSelectors := Dictionary new.
	classExtensionSelectors := Dictionary new.
	classDefinedSelectors := Dictionary new.
	metaclassDefinedSelectors := Dictionary new.
	classTags := Set new.! !

!RPackage methodsFor: 'private - register' stamp: ''!
unregisterClass: aClass
	"Private method that declares the mapping between a class and its package."
	self organizer
		unregisterPackage: self forClass: aClass.! !

!RPackage methodsFor: '*Calypso-SystemQueries' stamp: ''!
definesOverridesOfClassSide: aMethod in: classAndSelectors

	| methodClass selector |
	methodClass := aMethod origin.
	selector := aMethod selector.
	
	classAndSelectors keysAndValuesDo: [ :className :selectors |
		((selectors includes: selector) 
			and: [ (Smalltalk globals classNamed: className) classSide inheritsFrom: methodClass ])
				ifTrue: [ ^true ] ].
	^false! !

!RPackage methodsFor: 'accessing' stamp: ''!
packageManifestOrNil
	^ self definedClasses
		detect: [ :each | each isManifest ]
		ifNone: [ nil ]! !

!RPackage methodsFor: 'class tags' stamp: ''!
classTagForClass: aClass 
	^ self 
		classTagNamed: (self toTagName: aClass category) 
		ifAbsent: [ nil ]! !

!RPackage methodsFor: 'properties' stamp: ''!
ensureProperties
	^ Properties at: self ifAbsentPut: WeakKeyDictionary new! !

!RPackage methodsFor: 'testing' stamp: ''!
extendsClass: aClass
	"Returns true if the receiver extends aClass (that is defined in another package)"
	
	| canonizedName |
	canonizedName := aClass instanceSide name.
	^ self extendedClassNames includes: canonizedName! !

!RPackage methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asRingDefinition
	^RGPackageDefinition named: self name asSymbol! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
extensionCategoriesForClass: aClass
	self flag: #stef. "only used by goferCleanUp and PackageEnvironment of RB"
	^ aClass organization categories 
		select: [ :cat | self isYourClassExtension: cat ]! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
category: categoryName matches: prefix
	"self default category: 'Compression-Archives' matches: 'Compression'"
	"self default category: 'Compression' matches: 'Compression-Archives'"
	"self default category: 'Compression' matches: 'Compression'"
	"self default category: 'Compression-Arh' matches: 'Compression'"
	| 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 ]) = $-! !

!RPackage methodsFor: 'private' stamp: ''!
reportBogusBehaviorOf: aSelector

	self traceCr: 'RPackage log: Something wrong around ', aSelector asString , 'since the removeKey: is called on not present information.'.! !

!RPackage methodsFor: '*Monticello-RPackage' stamp: 'nil'!
isDirty
	
	| mcp |
	
	mcp := MCPackage named: self name.

	^(MCWorkingCopy registry 
		at: mcp
		ifPresent: [ :item | item modified ]
		ifAbsent: [ false ])! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
includesSystemCategory: categoryName
	^ self category: categoryName matches: self systemCategoryPrefix! !

!RPackage methodsFor: 'queries' stamp: ''!
classesTaggedWith: aSymbol
	"Any class could be tagged for user purpose.
	This method select all classes which are tagged by given symbol"
	
	^(self classTagNamed: aSymbol) classes! !

!RPackage methodsFor: 'slices' stamp: ''!
classExtensionSlicesDo: aBlock
	"This method iterates over the class extensions and their associated selectors. A slice is a class * list of selectors. aBlock will be applied to all the extensions slices of the receiver. aBlock first argument is the class and the second argument a list of method selectors"
	
	classExtensionSelectors keysAndValuesDo: aBlock! !

!RPackage methodsFor: 'private' stamp: ''!
basicImportClass: aClass
	"Add the class definition and all the selectors which are not extensions of other packages. If the class had an extension to us, then all methods in that extension are moved to 'as yet unclassified' and the extension protocol is deleted (should I use silently or not?)."
	
	"Note: Protocol defaultName is #'as yet unclassified'"

	"Question: should we check that for each extension, there is a real package behind or not?"

	| protocols |
	self addClassDefinition: aClass.
	aClass organization categories
		do: [ :each | 
			(self isYourClassExtension: each)
				ifTrue: [ aClass organization renameCategory: each toBe: Protocol defaultName ] ].
	protocols := aClass organization categories reject: [ :each | each first = $* ].
	protocols do: [ :each | self importProtocol: each forClass: aClass ]! !

!RPackage methodsFor: 'accessing' stamp: ''!
extendedClassNames 
	"Return the name of the classes which are extended by the receiver package. if a metaclass is extended, just get its sole instance class name."
	
	^ classExtensionSelectors keys union: metaclassExtensionSelectors keys! !

!RPackage methodsFor: 'testing' stamp: ''!
includesClass: aClass	
	"Returns true if the receiver includes aClass in the classes that are defined within it: only class definition are considered - not class extensions"
	
	^ self includesClassNamed: aClass instanceSide name! !

!RPackage methodsFor: 'private' stamp: ''!
removeClassDefinitionWithoutCheckingMethods: aClass
	"Same than 'removeClassDefinition', excepts that it does not make any check to set defined methods as extensions"
	
	| removed aClassName|
	aClassName := aClass instanceSide name.
	removed := classes remove: aClassName ifAbsent: [nil].
	removed ifNotNil: [
		self unregisterClass: aClass.]! !

!RPackage methodsFor: 'removing' stamp: ''!
removeClassNamed: className
	self removeClassDefinitionName: className.
	self removeAllMethodsFromClassNamed: className. 
	self removeClassTagsForClassNamed: className.! !

!RPackage methodsFor: 'updating' stamp: ''!
updateExtensionSelector: oldSelector inClass: aClass withNewSelector: newSelector

	aClass isMeta
		ifTrue: [
			(metaclassExtensionSelectors at: aClass instanceSide name asSymbol) remove: oldSelector. 
			(metaclassExtensionSelectors at: aClass instanceSide name asSymbol) add: newSelector. 
			]
		ifFalse: [
			(classExtensionSelectors  at: aClass name asSymbol) remove: oldSelector. 
			(classExtensionSelectors  at: aClass name asSymbol) add: newSelector. 
			]! !

!RPackage methodsFor: '*Tool-Base' stamp: ''!
browse
	^ Smalltalk tools browser openOnPackage: self! !

!RPackage methodsFor: 'testing' stamp: ''!
includesMethodsAffectedBy: aSystemAnnouncement

	^aSystemAnnouncement affectsMethodsDefinedInPackage: self! !

!RPackage methodsFor: 'add class' stamp: ''!
removeClassDefinitionName: aClassName
	"remove the class definition from the package but not its method"
	
	| removed aClassNameSymbol |
	('* class' match: aClassName) ifTrue: [^ self error: 'no metaclass name'].
	aClassNameSymbol := aClassName asSymbol.
	"clean up class tags"
	classTags do: [ :tag| tag removeClassNamed: aClassName ].
	(classTags select: #isEmpty)
		do: [ :eachTag | self basicRemoveTag: eachTag ].
	"remove the class definition"
	removed := classes remove: aClassNameSymbol ifAbsent: [nil].
	removed ifNotNil: [
		self definedMethodsShouldBecomeExtensionWhenRemovingClass: aClassName.
		self unregisterClassName: aClassNameSymbol ]! !

!RPackage methodsFor: 'class tags' stamp: ''!
removeClassTagsForClassNamed: aString 
	(self classTags 
		select: [ :eachTag | eachTag hasClassNamed: aString ])
		do: [ :eachTag |	
			self 
				removeClassDefinitionName: aString 
				fromClassTag: eachTag name ]! !

!RPackage methodsFor: 'updating' stamp: ''!
updateExtensionForClassNamed: oldString withNewName: newString

	"=> update the 'classExtensionsSelectors' dictionary (replace the old key by the new one)
        => update the 'metaclassclassExtensionsSelectors' dictionary (replace the old key by the new one)"
	"classes remove: oldString.
	classes add: newString."
	
	(metaclassExtensionSelectors at: oldString ifAbsent: [nil]) ifNotNil: [
		metaclassExtensionSelectors at: newString put: (metaclassExtensionSelectors at: oldString).
		metaclassExtensionSelectors removeKey: oldString  ifAbsent: [self reportBogusBehaviorOf: #updateExtensionForClassNamed:withNewName:   ]
		].
	
	(classExtensionSelectors at: oldString ifAbsent: [nil]) ifNotNil: [
		classExtensionSelectors at: newString put: (classExtensionSelectors at: oldString).
		classExtensionSelectors removeKey: oldString ifAbsent: [self reportBogusBehaviorOf: #updateExtensionForClassNamed:withNewName:   ]
		].! !

!RPackage methodsFor: 'testing' stamp: ''!
isEmpty
	self name = self class defaultPackageName ifTrue: [ ^false ].
	^self classes isEmpty and: [ self extensionSelectors isEmpty]! !

!RPackage methodsFor: '*Renraku' stamp: ''!
banLevelCandidates
"returns code entities which can ban a rule for this entity"

	^ { self . ReImageRuleBaner . RePersistentImageRuleBaner }  ! !

!RPackage methodsFor: 'accessing' stamp: ''!
definedClassNames 
	"Return the class names having methods defined in the receiver."
	
	^ classes! !

!RPackage methodsFor: '*Calypso-SystemQueries' stamp: ''!
importClasses: classCollection
	classCollection do: [ :each | self addClass: each ]! !

!RPackage methodsFor: 'private - register' stamp: ''!
unregisterClassName: aClassNameSymbol
	"Private method that declares the mapping between a class and its package."
	self organizer unregisterPackage: self forClassName: aClassNameSymbol! !

!RPackage methodsFor: '*Roassal3' stamp: ''!
dependentPackages
	"
	Return the list of packages that I depend on
	
	(RPackageOrganizer default packageNamed: 'Roassal3') dependentPackages
	"
	^ (self definedClasses flatCollect: #dependentClasses), self extendedClasses collect: #package as: Set! !

!RPackage methodsFor: 'add class' stamp: ''!
removeClassDefinition: aClass
	"Remove the class definition from the package but not its methods."
	^ self removeClassDefinitionName: aClass instanceSide originalName.! !

!RPackage methodsFor: 'private' stamp: ''!
definedMethodsBecomeExtendedForClass: aClassName
	"the package may contain defined methods and their class is removed to the receiver. The status of such methods should now be extended"
	"Precondition: aClassName is in the defined list"
	
	| ext |
	(classDefinedSelectors keys includes: aClassName) ifFalse: [^ self].
	ext := classDefinedSelectors at: aClassName.
	classDefinedSelectors removeKey: aClassName ifAbsent: [self reportBogusBehaviorOf:   #definedMethodsBecomeExtendedForClass: ].
	(classExtensionSelectors keys includes: aClassName) ifTrue: [self error: aClassName , ' should not be defined in extension'.]. "we should remove this check later"
	classExtensionSelectors at: aClassName put: ext.! !

!RPackage methodsFor: '*Renraku' stamp: ''!
suitableRulesFrom: aReRuleManager 
	^ aReRuleManager packageRules! !

!RPackage methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	aStream nextPutAll: self name.
	aStream nextPut: $)! !

!RPackage methodsFor: 'testing' stamp: ''!
includesSelector: aSelector ofClassName: aClassName
	"Return true if the receiver includes the method of selector aSelector. Checks methods defined locally as well as extending other packages"
	
	^ (self includesDefinedSelector: aSelector ofClassName: aClassName)
		or: [(self includesExtensionSelector: aSelector ofClassName: aClassName)]! !

!RPackage methodsFor: 'private' stamp: ''!
definedMethodsShouldBecomeExtensionWhenRemovingClass: aClassName
	"the package may contain defined methods and their class is removed from the receiver. The status of such methods should now be extensions"
	
	self definedMethodsBecomeExtendedForClass: aClassName.
	self definedMethodsBecomeExtendedForMetaclass: aClassName.! !

!RPackage methodsFor: 'accessing' stamp: ''!
extensionMethods
	"Extension methods are methods defined on classes that are not defined in the receiver"
	| allExtensionMethods |
	
	allExtensionMethods := OrderedCollection new.
	classExtensionSelectors keysAndValuesDo: [ :classSymbol :methods |
		methods do: [ :selector | allExtensionMethods add: ((Smalltalk globals at: classSymbol) >> selector) ] ].
	metaclassExtensionSelectors keysAndValuesDo: [ :classSymbol :methods |
		methods do: [ :selector | allExtensionMethods add: ((Smalltalk globals at: classSymbol) classSide >> selector) ] ].	
	
	^ allExtensionMethods! !

!RPackage methodsFor: 'accessing' stamp: ''!
name: aSymbol
	"Set the name of a package. This method is private and should not be used.
	If you wish to rename a package, use #renameTo: instead"
	name := aSymbol asSymbol.! !

!RPackage methodsFor: 'private' stamp: ''!
moveClass: aClass toTag: aTag
	"TODO: deprecate system categories / replace this with a direct call to moveClass:fromPackage:toTag:"
	
	"This change the class category as appropriate.
		(and by cascade, ensure systemClassRecategorizedAction: is called)."

	aClass category: aTag categoryName! !

!RPackage methodsFor: 'properties' stamp: ''!
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 ]! !

!RPackage methodsFor: 'accessing' stamp: ''!
methods
	"Return all the methods defined in this package. Including extension methods (i.e., methods defined on a class that is not defined by me)"
	| methods |
	
	methods := OrderedCollection new.
	
	metaclassExtensionSelectors keysAndValuesDo: [:key :val | 
		val do: [:sel | 	methods add: ((Smalltalk globals at: key) classSide >> sel)]].
	classExtensionSelectors keysAndValuesDo: [:key :val |
		val do: [:sel | methods add: ((Smalltalk globals at: key) >> sel)]].
	
	metaclassDefinedSelectors keysAndValuesDo: [:key :val | 
		val do: [:sel | methods add: ((Smalltalk globals at: key) classSide >> sel)]].
	classDefinedSelectors keysAndValuesDo: [:key :val | 
		val do: [:sel | methods add: ((Smalltalk globals at: key) >> sel)]].
	
	^ methods! !

!RPackage methodsFor: 'add method - selector' stamp: ''!
removeSelector: aSelector ofMetaclassName: aClassName
	"Remove the method in the package. Note that this method does not remove the method from the class, it just records in the package that the method is not in the package anymore. aClassName is the sole instance class name and not its metaclass one: i.e. adding Point class>>new is done as removeSelector: #new ofMetaclassName: #Point"
	
	self basicRemoveSelector: aSelector ofMetaclassName: aClassName.
	(metaclassExtensionSelectors at: aClassName ifAbsent: [ #() ]) ifEmpty: [
		metaclassExtensionSelectors removeKey: aClassName ifAbsent: [].
	].
	(metaclassDefinedSelectors at: aClassName ifAbsent: [ #() ]) ifEmpty: [
		metaclassDefinedSelectors removeKey: aClassName ifAbsent: [].
	].

	((metaclassExtensionSelectors at: aClassName ifAbsent: [#()]) isEmpty and: [(classExtensionSelectors at: aClassName ifAbsent: [#()]) isEmpty])
		ifTrue: [
				self organizer unregisterExtendingPackage: self forClassName: aClassName
	]! !

!RPackage methodsFor: 'properties' stamp: ''!
hasProperty: aKey
	self propertyAt: aKey ifAbsent: [ ^ false ].
	^ true! !

!RPackage methodsFor: 'updating' stamp: ''!
updateDefinedClassNamed: oldString withNewName: newString
	"this method should only be used with class names , and not metaclass names"

	(oldString substrings size > 1 or: [ newString substrings size > 1 ])
		ifTrue: [ Error signal: 'You should not use metaclass names' ].	"=> update the 'classDefinedSelectors' dictionary (replace the old key by the new one)
       => update the 'metaclassDefinedSelectors' dictionary (replace the old key by the new one)"
	classes remove: oldString.
	classes add: newString.	"Don't forget that class tags also register the classes names."
	self classTags do: [ :aTag | aTag updateDefinedClassNamed: oldString withNewName: newString ].
	self flag: #cyrille.	"what happens if this is a metaclass: it breaks the invariant of the package"	"worse so far the second block below breaks"	"the name of the method should be updateDefinedClassNamed: withNewName:"	"CD: i only use this method when a class is renamed in the system (systemClassRenamedActionFrom:). Normally we are not able to rename a metaclass in the system (?) so we should never end up in a case with metaclass names ?  "
	(classDefinedSelectors at: oldString ifAbsent: [ nil ])
		ifNotNil: [ 
			classDefinedSelectors at: newString put: (classDefinedSelectors at: oldString).
			classDefinedSelectors
				removeKey: oldString
				ifAbsent: [ self reportBogusBehaviorOf: #updateDefinedClassNamed:withNewName: ] ].
	(metaclassDefinedSelectors at: oldString ifAbsent: [ nil ])
		ifNotNil: [ 
			metaclassDefinedSelectors at: newString put: (metaclassDefinedSelectors at: oldString).
			metaclassDefinedSelectors
				removeKey: oldString
				ifAbsent: [ self reportBogusBehaviorOf: #updateDefinedClassNamed:withNewName: ] ]! !

!RPackage methodsFor: 'add method - selector' stamp: ''!
basicRemoveSelector: aSelector ofMetaclassName: aClassName
	"Remove the method in the package. Note that this method does not remove the method from the class, it just records in the package that the method is not in the package anymore. aClassName is the sole instance class name and not its metaclass one: i.e. adding Point class>>new is done as removeSelector: #new ofMetaclassName: #Point"
	
	| selectors |
	selectors := ( self includesClassNamed: aClassName)
		ifFalse: [(metaclassExtensionSelectors  at: aClassName ifAbsent: [ ^ Set new])]
		ifTrue: [(metaclassDefinedSelectors  at: aClassName ifAbsent: [ ^ Set new])].

	selectors remove: aSelector ifAbsent: [  ].! !

!RPackage methodsFor: 'add method - selector' stamp: ''!
basicRemoveSelector: aSelector ofClassName: aClassName
	"Remove the method in the package but does not propagate to the class itself.  Note that this method does not remove the method from the class, it just records in the package that the method is not in the package anymore."
	
	| selectors |

	selectors := ( self includesClassNamed: aClassName)
		ifFalse: [(classExtensionSelectors  at: aClassName ifAbsent: [ ^ Set new])]
		ifTrue: [(classDefinedSelectors  at: aClassName ifAbsent: [ ^ Set new])].
		
	selectors remove: aSelector ifAbsent: [ ].! !

!RPackage methodsFor: '*Monticello-RPackage' stamp: 'nil'!
mcWorkingCopy
	
	^ MCWorkingCopy allManagers 
		detect: [ :each | each package name = name ]
		ifNone: [ nil ].
	! !

!RPackage methodsFor: 'class tags' stamp: ''!
classTagNamed: aSymbol ifAbsent: aBlock 
	^ classTags 
		detect: [ :each | each name = aSymbol ]
		ifNone: aBlock! !

!RPackage methodsFor: 'accessing' stamp: ''!
classes
	"Return all the classes"
	^ self definedClasses, self extendedClasses! !

!RPackage methodsFor: '*Renraku' stamp: ''!
banChecksForValidation
	
	^ {}! !

!RPackage methodsFor: 'class tags' stamp: ''!
classTags
	"Returns the tags of the receiver"
	
	^ classTags! !

!RPackage methodsFor: 'testing' stamp: ''!
isTestPackage
	"1. Test package ends with suffix -Tests. Suffix is case sensitive.
	 2. Or test package contains '-Tests-' in middle.
	Some examples: "
	"(RPackage named: 'MockPackage-Tests') isTestPackage >>> true"
	"(RPackage named: 'MockPackage-tests') isTestPackage >>> false"
	"(RPackage named: 'MockPackage') isTestPackage >>> false"
	"(RPackage named: 'MockPackage-Tests-Package') isTestPackage >>> true"
	
	^ (self name endsWith: '-Tests') or: [self name includesSubstring: '-Tests-']! !

!RPackage methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGPackage named: self name asSymbol parent: anRGEnvironment ]! !

!RPackage methodsFor: 'class tags' stamp: ''!
classTagNamed: aSymbol

	^ classTags detect: [ :each | each name = aSymbol ]! !

!RPackage methodsFor: '*Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	"I'm on a package and the package is a baseline package."
	self class environment
		at: self name
		ifPresent: [ :cls | 
			aBuilder
				header: [ aBuilder text: self name ] withLevel: 1;
				horizontalLine;
				text: 'A baseline is a kind of map to load project.';
				newLine;
				header: [ aBuilder text: 'Description' ] withLevel: 3;
				text: aString;
				newLine;
				header: [ aBuilder text: 'Dependencies' ] withLevel: 3;
				codeblockTag: 'pharo'
					withBody:
					(cls
						sourceCodeAt: #baseline:
						ifAbsent: [ 'No baseline!! Houston we have a problem' ]) ]
		ifAbsent: [ aBuilder
				header: [ 
					aBuilder
						text: 'Package: ';
						text: self name ]
					withLevel: 1;
				horizontalLine;
				text: aString ]! !

!RPackage methodsFor: 'testing' stamp: ''!
includesExtensionSelector: aSelector ofClassName: aClassName
	"Return true if the receiver includes the method of selector aSelector. Only checks methods extending other packages"
	
	| sels |
	sels := classExtensionSelectors at: aClassName ifAbsent: [^ false].
	^ sels includes: aSelector.! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
isYourClassExtension: categoryName
	^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]! !

!RPackage methodsFor: 'private' stamp: ''!
renameTagsPrefixedWith: oldName to: newName
	| oldPrefix newPrefix |
	
	oldName ifNil: [ ^ self ].
	
	self 
		classTagNamed: oldName 
		ifPresent: [ :tag | tag renameTo: newName category: newName ].	
	
	oldPrefix := oldName, '-'.
	newPrefix := newName, '-'.
	(self classTags 
		select: [ :each | each categoryName beginsWith: oldPrefix ])
		do: [ :each | 
			each 
				renameTo: each name 
				category: newPrefix, (each name) ]! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
includesMethodCategory: categoryName ofClass: aClass
	^ (self isYourClassExtension: categoryName)
		or: [(self includesClass: aClass)
				and: [(self isForeignClassExtension: categoryName) not]]! !

!RPackage methodsFor: 'testing' stamp: ''!
includesDefinedSelector: aSelector ofClass: aClass
	"Return true if the receiver includes the method of selector aSelector. Only checks methods defined in this package"
	
	| sels |
	sels := self definedSelectorsForClass: aClass.
	^ sels includes: aSelector.! !

!RPackage methodsFor: 'register' stamp: ''!
register
	self organizer registerPackage: self! !

!RPackage methodsFor: 'private - register' stamp: ''!
registerClass: aClass
	"Private method that declares the mapping between a class and its package."
	self organizer
		registerPackage: self forClass: aClass! !

!RPackage methodsFor: 'system compatibility' stamp: ''!
systemCategories
	"(RPackageOrganizer default packageNamed: 'HelpSystem-Core' asSymbol) systemCategories"

	^ self systemOrganization categories select: [:cat | self includesSystemCategory: cat]! !

!RPackage methodsFor: 'slices' stamp: ''!
classDefinedSlicesDo: aBlock
	"This method iterates over the defined class and their associated selectors. a slice is a class * list of selectors. aBlock will be applied to all the extensions slices of the receiver. aBlok first argument is the class and the second argument a list of method selectors"
	
	classDefinedSelectors keysAndValuesDo: aBlock! !

!RPackage methodsFor: 'properties' stamp: ''!
properties
	^ Properties at: self ifAbsent: nil! !

!RPackage methodsFor: 'private' stamp: ''!
importClass: aClass inTag: aTag
	"import a class already created but not attached to a package to the receiver. 
	Handle also *- convention. Methods defined in *category are not added to the package.
	Pay attention that it will not import anything from the metaClass side"

	self basicImportClass: aClass.
	self basicImportClass: aClass classSide.	
	self 
		addClassDefinition:  aClass
		toClassTag: aTag name! !

!RPackage methodsFor: 'testing' stamp: ''!
includesClassTagNamed: aString
	^ self classTags anySatisfy: [ :each | each name = aString ]! !

!RPackage methodsFor: 'add class' stamp: ''!
addClass: aClass
	"TODO: deprecate system category / replace this with a direct call to moveClass:fromPackage:toTag:"

	"This does two things:
		- make sure the class tag for ourselves exists
		- change the class category as appropriate.
			(and by cascade, ensure systemClassRecategorizedAction: is called)."

	aClass category: (self addClassTag: self name) categoryName! !

!RPackage methodsFor: '*Renraku' stamp: ''!
ban: aCritique

	ReSystemAnnouncer uniqueInstance
		notifyCritique: aCritique
		of: aCritique sourceAnchor entity
		bannedOn: self.

	(TheManifestBuilder of: self)
		banRule: aCritique rule for: self.! !

!RPackage methodsFor: 'class tags' stamp: ''!
basicRemoveTag: tag
	classTags remove: tag ifAbsent: [].
	
	SystemAnnouncer uniqueInstance 
		classTagRemoved: tag name fromPackage: self! !

!RPackage class methodsFor: '*Calypso-SystemQueries' stamp: ''!
prepareClassQueriesFrom: packages in: aNavigationEnvironment
	^{
		ClyAllClassesQuery from: ClyPackageScope ofAll: packages in: aNavigationEnvironment.
		ClyAllClassesQuery from: ClyPackageExtensionScope ofAll: packages in: aNavigationEnvironment 
	}! !

!RPackage class methodsFor: 'help' stamp: ''!
help
	<wikiStyleHelp: 'RPackage'>	
	|stream|
	stream := String new writeStream.
	stream 
		nextPut: $!!;
		nextPutAll: self name asString;
		cr;
		nextPutAll: self comment;
		cr;
		nextPut: $!!;
		nextPutAll: self packageOrganizerClass name asString;
		cr;
		nextPutAll: self packageOrganizerClass comment.		
	^stream contents! !

!RPackage class methodsFor: 'class initialization' stamp: ''!
initialize
	"self initialize"
	
	"Ensure the organizer will be the RPackageOrganizer default"
	self organizer: nil.
	Properties
		ifNil: [ self initializeProperties ]
		ifNotNil: [ | newDict | 
			newDict := WeakIdentityKeyDictionary newFrom: Properties.
			newDict rehash.
			Properties := newDict ]! !

!RPackage class methodsFor: 'protected only for tests' stamp: ''!
withOrganizer: aNewOrganizer do: aBlock
	"Perform an action locally to aNewOrganizer. Does not impact any other organizers."
	
	| old |
	[ old := self organizer.
	old unregister.
	self organizer: aNewOrganizer.
	aNewOrganizer register.
	aBlock cull: aNewOrganizer] ensure: [ 
		self organizer: old. 
		old register.
		aNewOrganizer unregister]! !

!RPackage class methodsFor: '*Calypso-SystemQueries' stamp: ''!
defaultSortFunctionForCalypso
	^ClySortByNameFunction ascending! !

!RPackage class methodsFor: '*Calypso-SystemQueries' stamp: ''!
prepareClassGroupQueryFrom: aPackage in: aNavigationEnvironment
	^ ClyAllClassGroupsQuery
		sortedFrom: (ClyPackageScope of: aPackage in: aNavigationEnvironment)! !

!RPackage class methodsFor: 'protected only for tests' stamp: ''!
organizer
	^ PackageGlobalOrganizer ifNil: [ RPackageOrganizer default ].! !

!RPackage class methodsFor: 'constants' stamp: ''!
defaultPackageName
	^ #'_UnpackagedPackage'! !

!RPackage class methodsFor: 'class initialization' stamp: ''!
packageOrganizerClass
	^ RPackageOrganizer! !

!RPackage class methodsFor: '*Calypso-SystemQueries' stamp: ''!
decorateBrowserItem: aBrowserItem by: anEnvironmentPlugin
	^ anEnvironmentPlugin
		decorateBrowserItem: aBrowserItem
		ofPackage: aBrowserItem actualObject! !

!RPackage class methodsFor: 'instance creation' stamp: ''!
named: aString

	| newPackage |
	newPackage := self new name: aString ;yourself.
	^ newPackage! !

!RPackage class methodsFor: 'protected only for tests' stamp: ''!
organizer: aPackageOrganizer

	PackageGlobalOrganizer := aPackageOrganizer! !

!RPackage class methodsFor: 'class initialization' stamp: ''!
initializeProperties
	Properties := WeakIdentityKeyDictionary new.! !

!RPackage class methodsFor: '*Calypso-SystemQueries' stamp: ''!
itemsSortOrderForCalypso 
	^10! !

!RPackage class methodsFor: '*Calypso-SystemQueries' stamp: ''!
convertToCalypsoBrowserItem: aPackage

	^ClyBrowserItem named: aPackage name with: aPackage! !

!RPackageAnnouncement commentStamp: ''!
Common superclass for package related announcements!
!RPackageAnnouncement methodsFor: 'testing' stamp: ''!
affectsPackages
	 
	^true! !

!RPackageAnnouncement methodsFor: 'accessing' stamp: ''!
package

	^ package! !

!RPackageAnnouncement methodsFor: 'accessing' stamp: ''!
package: anObject

	package := anObject! !

!RPackageAnnouncement class methodsFor: 'instance creation' stamp: ''!
to: aPackage

	^ self new package: aPackage! !

!RPackageCategorySynchronisationTest commentStamp: ''!
SUnit tests for RPackage category synchronization!
!RPackageCategorySynchronisationTest methodsFor: 'tests - operations on categories' stamp: ''!
testRenameCategoryAlsoRenameAllExtensionProtocols
	"test that when we rename a category, all corresponding extension protocols in the system are renamed"

	| XPackage YPackage ZPackage classInY classInZ |
	self addXCategory.
	self addYCategory.
	self addZCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	ZPackage := self organizer packageNamed: #ZZZZZ.

	classInY := self createNewClassNamed: 'ClassInYPackage' inCategory: 'YYYYY'.
	classInZ := self createNewClassNamed: 'ClassInZPackage' inCategory: 'ZZZZZ'.

	self createMethodNamed: 'extensionFromXInClassInY' inClass: classInY inCategory: '*XXXXX'.
	self createMethodNamed: 'longNameExtensionFromXInClassInY' inClass: classInY inCategory: '*XXXXX-subcategory'.
	self createMethodNamed: 'extensionFromXInClassInZ' inClass: classInZ inCategory: '*XXXXX'.

	Smalltalk organization renameCategory: 'XXXXX' toBe: 'NewCategoryName'.

	self assert: XPackage name equals: 'NewCategoryName'.
	self assert: (classInY >> #extensionFromXInClassInY) category equals: '*NewCategoryName'.
	self assert: (classInY >> #longNameExtensionFromXInClassInY) category equals: '*NewCategoryName'.
	self assert: (classInZ >> #extensionFromXInClassInZ) category equals: '*NewCategoryName'! !

!RPackageCategorySynchronisationTest methodsFor: 'tests - operations on categories' stamp: ''!
testRenameCategoryChangeTheNameOfThePackage
	"test that when we rename a category, the RPackage corresponding is updated with this new name"

	| XPackage |
	self addXCategory.
	XPackage := self organizer packageNamed: #XXXXX.

	Smalltalk organization renameCategory: 'XXXXX' toBe: 'YYYYY'.
	self assert: XPackage name equals: 'YYYYY'! !

!RPackageCategorySynchronisationTest methodsFor: 'tests - operations on categories' stamp: ''!
testAddCategoryIsAlreadyAPackageDoesNotCreatePackage
	"test that when we add a category corresponding to an existing package, we do not create a second package"

	| tmpPackage |
	self flag: #pharoTodo.	"To be removed when Categories are kicked out"

	self addXCategory.
	tmpPackage := self organizer packageNamed: #XXXXX.
	self addXCategory.
	self assert: tmpPackage equals: (self organizer packageNamed: #XXXXX)! !

!RPackageCategorySynchronisationTest methodsFor: 'tests - operations on categories' stamp: ''!
testRenameCategoryUpdateTheOrganizer
	"test that when we rename a category, the organizer dictionary is update with this new name, so that we can access the package with this new name as key"

	| XPackage |
	self addXCategory.

	XPackage := self organizer packageNamed: #XXXXX.
	Smalltalk organization renameCategory: 'XXXXX' toBe: 'YYYYY'.
	self assert: (self organizer packageNamed: 'YYYYY' asSymbol) equals: XPackage.
	self deny: (self organizer includesPackageNamed: #XXXXX)! !

!RPackageCategorySynchronisationTest methodsFor: 'tests - operations on categories' stamp: ''!
testRenameUnknownCategoryCreatesNewRPackage
	"test that when we rename a category that is not registered in RPackage , it does not raise errors and simply create a new package. We need this behaviour as for now, create a new category with the class browser does not emit the corrects events, and therefore RPackage can not be directly updated"
	
	SystemAnnouncer uniqueInstance suspendAllWhile: [
		self addXCategory.
		].
	self deny: (self organizer includesPackageNamed: #XXXXX).
	Smalltalk organization renameCategory: 'XXXXX' toBe: 'YYYYY'.
	self assert: (self organizer includesPackageNamed: #YYYYY).! !

!RPackageCategorySynchronisationTest methodsFor: 'tests - operations on categories' stamp: ''!
testAddCategoryCreatesPackage
	"test that when we add a category that does not yet correspond to an existing package, a new package is created"
		
	self flag: #pharoTodo. "To be removed when Categories are kicked out"
	
	self addXCategory.
	self assert: (self organizer includesPackageNamed: #XXXXX)! !

!RPackageClassesSynchronisationTest commentStamp: ''!
SUnit tests for RPackage classes synchronisation!
!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on protocols' stamp: ''!
testReorganizeClassByRenamingExtensionCategoryToClassicCategoryMoveAllMethodsFromExtendingPackageToParentPackage
	"test that when we reoganized a class by renaming an extension category (a category beginning with '*') to a classic category, all the methods are moved from the  extendingPackage to the parent package of the class"
	
	|XPackage YPackage class| 
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage  := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: '*yyyyy'.
	self createMethodNamed: 'stubMethod2' inClass: class  inCategory: '*yyyyy'.
	
	class organization renameCategory: '*yyyyy' toBe: 'classic category'.
	
	self deny: (YPackage includesExtensionSelector: #stubMethod ofClass: class).
	self deny: (YPackage includesExtensionSelector: #stubMethod2 ofClass: class).
	self assert: (XPackage includesDefinedSelector: #stubMethod ofClass: class).
	self assert: (XPackage includesDefinedSelector: #stubMethod2 ofClass: class).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on classes' stamp: ''!
testRenameClassUpdateOrganizerClassExtendingPackagesMapping
	"test that when we rename a class, the classExtendingPackages dictionary of the organizer is updated with the new name, so that we can access the packages when specifying the new name"
	
	| XPackage YPackage class |
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'RPackageOldStubClass' inCategory: 'XXXXX'.
	self createMethodNamed: #stubMethod inClass: class inCategory: '*yyyyy'. 
	
	class rename: 'RPackageNewStubClass'.
	
	self assert: ((self organizer extendingPackagesOfClassNamed: 'RPackageNewStubClass' asSymbol) includes: YPackage). 
	self deny: ((self organizer extendingPackagesOfClassNamed: 'RPackageOldStubClass' asSymbol) includes: YPackage).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on protocols' stamp: ''!
testReorganizeClassByRenamingExtensionCategoryToClassicCategoryMoveMethodsFromExtendingPackageToParentPackage
	"test that when we reoganized a class by renaming an extension category (a category beginning with '*') to a classic category, all the methods are moved from the  extendingPackage to the parent package of the class"
	
	|XPackage YPackage class| 
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage  := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: '*yyyyy'.
	class organization renameCategory: '*yyyyy' toBe: 'classic category'.
	self deny: (YPackage includesExtensionSelector: #stubMethod ofClass: class).
	self assert: (XPackage includesDefinedSelector: #stubMethod ofClass: class)! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on protocols' stamp: ''!
testReorganizeClassByRemovingExtensionCategoryRemoveMethodsFromTheExtendingPackage
	"test that when we reoganized a class by removing an extension category (a category beginning with '*'), all the methods that were inside are removed from the extending package"
	 
	|XPackage YPackage class| 
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage  := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: '*yyyyy'.
	
	class removeProtocol: '*yyyyy'.
	
	self deny: (YPackage includesExtensionSelector: #stubMethod ofClass: class).
	self deny: (XPackage includesDefinedSelector: #stubMethod ofClass: class).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - recategorizing class' stamp: ''!
testRecategorizeClassWithMetaClassMethodsRegisterAllClassMethodsInTheNewPackage

	"test that when we recategorize a class (having methods defined in both instance and class side), the new package in which it is defined include all the methods (from instance and class side) defined in this class (not extensions)"
	
	| XPackage YPackage ZPackage class|
	self addXCategory.
	self addYCategory.
	self addZCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	ZPackage := self organizer packageNamed: #ZZZZZ.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	
	self createMethodNamed: 'method1' inClass: class classSide inCategory: 'category'.
	self createMethodNamed: 'method2' inClass: class classSide inCategory: '*yyyyy'.
	self createMethodNamed: 'method3' inClass: class classSide inCategory: '*zzzzz'.
	
	class category: 'YYYYY'.
	
	"lets check metaclass methods"
	self assert: (YPackage includesDefinedSelector: #method1 ofMetaclassName: class name).
	
	self assert: (YPackage includesDefinedSelector: #method2 ofMetaclassName: class name). 
	
	self assert: (ZPackage includesExtensionSelector: #method3 ofMetaclassName: class name ).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - removing classes' stamp: ''!
testRemoveClassUnregisterTheClassFromItsPackage
	"test that when we remove a class, the class is removed from its parent Package"	

	|XPackage  class|
	self addXCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	
	Smalltalk removeClassNamed: 'NewClass'. 
	self deny: (XPackage includesClass: class)! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - recategorizing class' stamp: ''!
testRecategorizeClassRegisterTheClassMethodsInTheNewPackage

	"test that when we recategorize a class, the new package in which it is defined include all the methods defined in this class (not extensions)"
	
	| XPackage YPackage ZPackage class|
	self addXCategory.
	self addYCategory.
	self addZCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	ZPackage := self organizer packageNamed: #ZZZZZ.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'method1' inClass: class inCategory: 'category'.
	self createMethodNamed: 'method2' inClass: class inCategory: '*zzzzz'.
	self createMethodNamed: 'method3' inClass: class inCategory: '*yyyyy'.
		
	class category: 'YYYYY'.
	
	self assert: (YPackage includesDefinedSelector: #method1 ofClass: class ). 
	self deny: (XPackage includesSelector: #method1 ofClass: class ). 
	self deny: (ZPackage includesSelector: #method1 ofClass: class ). 
	
	self deny: (XPackage includesSelector: #method2 ofClass: class ). 
	self deny: (YPackage includesSelector: #method2 ofClass: class ). 
	self assert: (ZPackage includesExtensionSelector: #method2 ofClass: class ). 

	self deny: (XPackage includesSelector: #method3 ofClass: class ). 
	self assert: (YPackage includesDefinedSelector: #method3 ofClass: class ). 
	self deny: (ZPackage includesSelector: #method3 ofClass: class ). 
! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - recategorizing class' stamp: ''!
testRecategorizeClassRegisterTheClassInTheMatchingPackage
	"test that when we recategorize a class, the new package in which it is defined include it"

	| XPackage YPackage class |
	self addXCategory.
	self addYCategory.

	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.

	class := self createNewClassNamed: 'NewClass' inCategory: 'YYYYY'.

	class category: 'XXXXX'.
	self deny: (self organizer packageOf: class) equals: YPackage.
	self assert: (self organizer packageOf: class) equals: XPackage! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on classes' stamp: ''!
testRenameClassUpdateMetaclassDefinedSelectorsInTheParentPackage
	"test that when we rename a class, the  'metaclassDefinedSelectors' dictionary of the parent package is updated with the new name. Ther fore we test that we can correctly access the selector from the package by specifying the right name (the new name)"
	
	| XPackage  class |
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'RPackageOldStubClass' asSymbol inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClassSideOfClass: class  inCategory: 'classic category'.
	
	class rename: 'RPackageNewStubClass'.
	
	self assert: (XPackage  includesDefinedSelector: #stubMethod ofMetaclassName: 'RPackageNewStubClass' asSymbol ). 
	self deny: (XPackage  includesDefinedSelector: #stubMethod ofMetaclassName: 'RPackageOldStubClass' asSymbol ).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - adding classes' stamp: ''!
testAddClassUpdateTheOrganizerMappings
	"test that when we add a class, the organizer 'classPackageMapping' dictionary is updated, so that the class is linked to its package and so that we can access its owning package"

	|tmpPackage class|
	self addXCategory.
	
	tmpPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	 
	self assert: class package equals: tmpPackage! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - adding classes' stamp: ''!
testAddClassAddItIntoPackageExactName

	|tmpPackage class|
	self addXCategory.
	self addXMatchCategory.

	tmpPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.

	self assert: (tmpPackage definesClass: class).
	self assert: class package equals: tmpPackage! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - removing classes' stamp: ''!
testRemoveClassUnregisterTheClassExtensionMethodsFromTheCorrespondingPackage
	"test that when we remove a class, the class extension methods are all removed  from theire corresponding parent Package"
	
	|XPackage YPackage class|
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: '*yyyyy'. 
	
	Smalltalk removeClassNamed: 'NewClass'. 
	self deny: (YPackage includesSelector: #stubMethod ofClass: class). ! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on classes' stamp: ''!
testRenameClassUpdateClassExtensionSelectorsInTheExtendingPackages
	"test that when we rename a class, the  'classExtensionSelectors' dictionaries of the extending packages  are updated with the new name. Therfore we test that we can correctly access the selectors from the package by specifying the right name (the new name)"

	| XPackage YPackage class |
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'RPackageOldStubClass' asSymbol inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: '*yyyyy'.
	
	class rename: 'RPackageNewStubClass'.
	
	self assert: (YPackage includesExtensionSelector: #stubMethod ofClassName: 'RPackageNewStubClass' asSymbol ). 
	self deny: (YPackage includesExtensionSelector: #stubMethod ofClassName: 'RPackageOldStubClass' asSymbol ).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - recategorizing class' stamp: ''!
testRecategorizeClassUnregisterTheClassMethodsFromTheOldPackage
	"test that when we recategorize a class, the old package in which it was defined don't include its defined methods (not extensions) anymore"	
		
	|XPackage YPackage ZPackage class|
	self addXCategory.
	self addYCategory.
	self addZCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	ZPackage := self organizer packageNamed: #ZZZZZ.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'method1' inClass: class inCategory: 'category'.
	self createMethodNamed: 'method2' inClass: class inCategory: '*zzzzz'.
	self createMethodNamed: 'method3' inClass: class inCategory: '*yyyyy'.
	
	class category: 'YYYYY'.
	self deny: (XPackage includesSelector: #method1 ofClass: class ). 
	self deny: (XPackage includesSelector: #method2 ofClass: class ). 
	self deny: (XPackage includesSelector: #method3 ofClass: class ).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on protocols' stamp: ''!
testReorganizeClassByAddingExtensionProtocol
	"test that when we reoganized a class by adding a category, nothing change from  RPackage point of vue."
	
	|class| 
	self addXCategory.
	 
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'newMethod' inClass: class inCategory: 'xxxxx'.  
	class organization addCategory: '*yyyyy' before: nil.
	
	self assert: (self organizer includesPackageNamed: #Yyyyy).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on protocols' stamp: ''!
testReorganizeClassByRenamingExtensionCategoryToAnotherExtensionCategoryAddMethodsToTheNewPackage
	"test that when we reoganized a class by renaming an extension category (a category beginning with '*') to another extension category, all the methods are moved to the new extendingPackage"
	
	|XPackage YPackage ZPackage class| 
	self addXYZCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage  := self organizer packageNamed: #YYYYY.
	ZPackage  := self organizer packageNamed: #ZZZZZ.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: '*yyyyy'.
	class organization renameCategory: '*yyyyy' toBe: '*zzzzz'.
	self assert: (ZPackage includesExtensionSelector: #stubMethod ofClass: class).
	self deny: (YPackage includesExtensionSelector: #stubMethod ofClass: class).
	self deny: (XPackage includesDefinedSelector: #stubMethod ofClass: class)! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - recategorizing class' stamp: ''!
testRecategorizeClassRegisterTheClassInTheBestMatchPackage
	"test that when we recategorize a class, the new package in which it is defined include it"

	| XPackage YPackage class |
	self addXCategory.
	self addXMatchCategory.
	self addYCategory.

	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.

	class := self createNewClassNamed: 'NewClass' inCategory: 'YYYYY'.

	class category: 'XXXXX-YYYY'.
	self assert: (self organizer packageOf: class) equals: XPackage.
	self deny: (self organizer packageOf: class) equals: YPackage! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on protocols' stamp: ''!
testReorganizeClassByRenamingClassicCategoryToExtensionCategoryMoveMethodsFromParentPackageToExtendingPackage
	"test that when we reoganized a class by renaming a  classic category (a category not beginning with '*') to an extension category, all the methods are moved from the  parent package of the class to the extending package"

	|XPackage YPackage class| 
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage  := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: 'classic category'.
	class organization renameCategory: 'classic category' toBe: '*yyyyy'.
	self assert: (YPackage includesExtensionSelector: #stubMethod ofClass: class).
	self deny: (XPackage includesDefinedSelector: #stubMethod ofClass: class)! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on classes' stamp: ''!
testRenameClassUpdateOrganizerClassPackageMapping
	"test that when we rename a class, the classPackage dictionary of the organizer is updated with the new name, so that we can access the package when specifying the new name"

	| XPackage class |
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'RPackageOldStubClass' inCategory: 'XXXXX'.

	class rename: 'RPackageNewStubClass'.

	self assert: (self organizer packageOfClassNamed: 'RPackageNewStubClass' asSymbol) equals: XPackage.
	self assert: (self organizer packageOfClassNamed: 'RPackageOldStubClass' asSymbol) equals: nil! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on protocols' stamp: ''!
testReorganizeClassByAddingNewProtocolDoesNothing
	"test that when we reoganized a class by adding a category, nothing change from  RPackage point of vue."

	| XPackage class |
	self addXCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'newMethod' inClass: class inCategory: 'xxxxx'.
	class organization addCategory: 'accessing' before: nil.

	self assert: (XPackage includesClass: class).
	self assert: (XPackage includesDefinedSelector: #newMethod ofClass: class).
	self assert: XPackage extensionMethods size equals: 0! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - recategorizing class' stamp: ''!
testRecategorizeClassWithUnexistingPackageNameRegisterTheClassInANewPackage
	"test that when we recategorize a class in category not yet registered in RPackage, a new rPackage is created with the class inside"

	| XPackage YPackage class |
	self addXCategory.
	XPackage := self organizer packageNamed: #XXXXX.

	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self assert: (self organizer packageOf: class) equals: XPackage.

	class category: 'YYYYY'.
	YPackage := self organizer packageNamed: #YYYYY.

	self assert: (self organizer packageOf: class) equals: YPackage.
	self deny: (self organizer packageOf: class) equals: XPackage! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on classes' stamp: ''!
testRenameClassUpdateClassDefinedSelectorsInTheParentPackage
	"test that when we rename a class, the  'classDefinedSelectors' dictionary of the parent package is updated with the new name. There fore we test that we can correctly access the selector from the package by specifying the right name (the new name)"
	
	| XPackage  class |
	self addXCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'RPackageOldStubClass' asSymbol inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: 'classic category'.
	
	class rename: 'RPackageNewStubClass'.
	
	self assert: (XPackage includesDefinedSelector: #stubMethod ofClassName: 'RPackageNewStubClass' asSymbol ). 
	self deny: (XPackage includesDefinedSelector: #stubMethod ofClassName: 'RPackageOldStubClass' asSymbol ).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - recategorizing class' stamp: ''!
testRecategorizeClassRaisesClassRepackagedEvent
	"test that when we recategorize a class, the organizer is updated so that the class name point the the new RPackage"
	
	| XPackage YPackage class ann |
	
	ann := nil.
	SystemAnnouncer uniqueInstance
		when: ClassRepackaged do: [ :a |
			ann := a.
		].
	
	self addXCategory.
	self addYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	class category: 'YYYYY'.	
	
	self assert: ann notNil.
	self assert: ann classRepackaged equals: class.
	self assert: ann oldPackage equals: XPackage.
	self assert: ann newPackage equals: YPackage.! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on classes' stamp: ''!
testRenameClassUpdateMetaclassExtensionSelectorsInTheExtendingPackages
	"test that when we rename a class, the  'metaclassExtensionSelectors' dictionaries of the extending packages  are updated with the new name. Ther fore we test that we can correctly access the selectors from the package by specifying the right name (the new name)"
	
	| XPackage YPackage class |
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'RPackageOldStubClass' asSymbol inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClassSideOfClass: class  inCategory: '*yyyyy'.
	
	class rename: 'RPackageNewStubClass'.
	
	self assert: (YPackage includesExtensionSelector: #stubMethod ofMetaclassName: 'RPackageNewStubClass' asSymbol ). 
	self deny: (YPackage includesExtensionSelector: #stubMethod ofMetaclassName: 'RPackageOldStubClass' asSymbol ).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - recategorizing class' stamp: ''!
testRecategorizeClassRegisterTheClassInTheExactMatchPackage
	"test that when we recategorize a class, the new package in which it is defined include it"

	| XPackage YPackage class |
	self addXCategory.
	self addXMatchCategory.
	self addYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'YYYYY'.

	class category: 'XXXXX'.

	self assert: (self organizer packageOf: class) equals: XPackage.
	self deny: (self organizer packageOf: class) equals: YPackage! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on protocols' stamp: ''!
testReorganizeClassByRemovingClassicCategoryRemoveMethodsFromTheParentPackage
	"test that when we reoganized a class by removing a classic category (a category not beginning with '*'), the methods from this category are removed from the parent RPackage of the class"
	
	|XPackage  class| 
		
	self addXCategory.
	XPackage := self organizer packageNamed: 'XXXXX'.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: 'classic category'.
	class removeProtocol: 'classic category'.
	self deny: (XPackage includesDefinedSelector: #stubMethod ofClass: class).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on classes' stamp: ''!
testRenameClassUpdateClassDefinedInTheParentPackage
	"test that when we rename a class, the classes Defined in the parent package includes the new name"
		
	| XPackage class |
	self addXCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	
	class := self createNewClassNamed: 'RPackageOldStubClass' inCategory: 'XXXXX'.	
	class rename: 'RPackageNewStubClass'.
	
	self assert: (XPackage includesClassNamed: 'RPackageNewStubClass'). 
	self deny: (XPackage includesClassNamed: 'RPackageOldStubClass').! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - removing classes' stamp: ''!
testRemoveClassUnregisterTheClassDefinedMethodsFromItsPackage
	"test that when we remove a class, the class methods defined in the parent package (not extensions) are all removed  from its parent Package"
	
	|XPackage  class|
	self addXCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: 'classic category'. 
	
	Smalltalk removeClassNamed: 'NewClass'. 
	self deny: (XPackage includesSelector: #stubMethod ofClass: class). ! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - recategorizing class' stamp: ''!
testRecategorizeClassUnregisterTheClassFromTheOldPackage
	"test that when we recategorize a class, the old package in which it was defined don't include it anymore"
	

	|XPackage YPackage class|
	self addXCategory.
	self addYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.

	class category: 'YYYYY'.
	self deny: (XPackage includesClass: class).! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - adding classes' stamp: ''!
testAddClassAddItIntoPackageBestMatchName

	|tmpPackage class|
	self addXCategory.
	self addXMatchCategory.
	
	tmpPackage := self organizer packageNamed: #'XXXXX'.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX-YYYY'.

	self assert: (tmpPackage definesClass: class).
	self assert: class package equals: tmpPackage! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - removing classes' stamp: ''!
testRemoveClassUpdateTheOrganizerMappings
	"test that when we remove a class, the organizer is updated so that the class is no longer present in the  'classPackageDictionary' dictionary"
	
	|XPackage  class|
	self addXCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.

	Smalltalk removeClassNamed: 'NewClass'. 
	self deny: (self organizer includesPackageBackPointerForClass: class)! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - recategorizing class' stamp: ''!
testRecategorizeClassUpdateTheOrganizerMappings
	"test that when we recategorize a class, the organizer is updated so that the class name point the the new RPackage"
	
	|XPackage YPackage class|
	self addXCategory.
	self addYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	class category: 'YYYYY'.	
	self assert: (self organizer packageOf: class) equals: YPackage		! !

!RPackageClassesSynchronisationTest methodsFor: 'tests - operations on protocols' stamp: ''!
testReorganizeClassByRenamingClassicCategoryToExtensionCategoryMoveAllMethodsFromParentPackageToExtendingPackage	 
	"test that when we reoganized a class by renaming a  classic category (a category not beginning with '*') to an extension category, all the methods are moved from the  parent package of the class to the extending package"
	|XPackage YPackage class| 
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage  := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: 'classic category'.
	self createMethodNamed: 'stubMethod2' inClass: class  inCategory: 'classic category'.
	
	class organization renameCategory: 'classic category' toBe: '*yyyyy'.
	
	self assert: (YPackage includesExtensionSelector: #stubMethod ofClass: class).
	self assert: (YPackage includesExtensionSelector: #stubMethod2 ofClass: class).
	self deny: (XPackage includesDefinedSelector: #stubMethod ofClass: class).
	self deny: (XPackage includesDefinedSelector: #stubMethod2 ofClass: class).! !

!RPackageCompleteSetupButForModificationTest commentStamp: ''!
SUnit tests for RPackage!
!RPackageCompleteSetupButForModificationTest methodsFor: 'test - starting situation' stamp: ''!
testExtensionMethodOfClass
	"P1 
		A1DefinedInP1>>methodDefinedInP1
		B1DefinedInP1	
		A2DefinedInP2>>methodDefinedInP1  (was *P2)
	
	P2
		A2DefinedInP2>>methodDefinedInP2
		B2DefinedInB2	

	P3
		A3DefinedInP3	
		A2DefinedInP2>>methodDefinedInP3  (was *P2*)"
		
	self assert: a2 selectors size equals: 3.
	"the class contains methods defined by several packages 
	however when looking with a package view we only see the package 
	extension."
		
	self assert: (p2 extensionMethodsForClass: a2) size equals: 0.
	self assert: (p1 extensionMethodsForClass: a1) size equals: 0.
	"show that extensionMethodsForClass: does works for methods of class
	defined in the package"
	
	self assert: (p1 extensionMethodsForClass: a2) size equals: 1.
	self assert: (p3 extensionMethodsForClass: a2) size equals: 1.! !

!RPackageCompleteSetupButForModificationTest methodsFor: 'test - addition' stamp: ''!
testRemoveMethod

	p1 removeMethod: a1 >> #methodDefinedInP1.
	self deny: (p1 includesSelector: #methodDefinedInP1 ofClass: a1).! !

!RPackageCompleteSetupButForModificationTest methodsFor: 'test - addition' stamp: ''!
testRemoveMethodDoesNotRemoveFromClass
	"we remove a method so it is not in the package but also not from the class anymore"

	p1 removeMethod:  a1 >> #methodDefinedInP1.
	self deny: (p1 includesSelector: #methodDefinedInP1 ofClass: a1).
	self assert: (a1 selectors includes: #methodDefinedInP1)! !

!RPackageCompleteSetupButForModificationTest methodsFor: 'test - addition' stamp: ''!
testRemoveShouldRaiseErrorWhenMethodIsNotInPackage
	
	self should: [ p2 removeMethod: a2>>#methodDefinedZork ] raise: Error! !

!RPackageCompleteSetupButForModificationTest methodsFor: 'test - starting situation' stamp: ''!
testStartingSituation

	self deny: (p2 includesClass: b1).
	self assert: (p2 includesClass: b2).
	"a locally defined class not extended by other packages"
	
	self assert: (p2 includesClass: a2).  
	"a locally defined class extended by other packages"
	
	self assert: (p1 definesOrExtendsClass: a2).
	self deny: (p1 includesClass: a2).! !

!RPackageCompleteSetupButForModificationTest methodsFor: 'test - addition' stamp: ''!
testBasicRemoveClass
	"we remove a class we check that it is not in the package anymore"

	|  size |
	size := p1 definedClasses size. 
	self assert: size equals: 2.
	self assert: (p1 includesClass: a1).
	self assert: (p1 includesClass: a1 class).
	p1 removeClassDefinition: a1.
	self assert: p1 definedClasses size equals: (size - 1).
	self assert: (p1 includesClass: b1).
	self assert: (p1 includesClass: b1 class).
	self deny: (p1 includesClass: a1).
	self deny: (p1 includesClass: a1 class).
	p1 removeClassDefinition: b1.
	self assert: p1 definedClasses size equals: (size - 2).
	self deny: (p1 includesClass: b1).
	self deny: (p1 includesClass: b1 class)! !

!RPackageCompleteSetupButForModificationTest methodsFor: 'test - addition' stamp: ''!
testAddMethod
		
	self assert: (p1 includesSelector: #methodDefinedInP1 ofClass: a1).
	
	a1 compileSilently: 'zork ^ #methodDefinedInP1'.
	p1 addMethod: (a1>>#zork).
	self assert: (p1 includesSelector: #zork ofClass: a1).
	
	self assert: (p3 includesSelector: #classSideMethodDefinedInP3 ofClass: a2 class)! !

!RPackageCompleteSetupButForModificationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	p1 := self createNewPackageNamed: self p1Name.
	p2 := self createNewPackageNamed: self p2Name.
	p3 := self createNewPackageNamed: self p3Name.
	
	a1 :=  self createNewClassNamed: #A1DefinedInP1 inPackage: p1.
	b1 := self createNewClassNamed: #B1DefinedInP1 inPackage: p1.
	a2 := self createNewClassNamed: #A2DefinedInP2 inPackage: p2.
	b2 := self createNewClassNamed: #B2DefinedInP2 inPackage: p2.
	a3 := self createNewClassNamed: #A3DefinedInP3 inPackage: p3.
	
	a1 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a1>>#methodDefinedInP1).
	a1 compileSilently: 'anotherMethodDefinedInP1 ^ #anotherMethodDefinedInP1'.
	p1 addMethod: (a1>>#anotherMethodDefinedInP1).
	
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	
	a2 compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addMethod: (a2>>#methodDefinedInP2).
	
	a2 compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addMethod: (a2>>#methodDefinedInP3).

	a2 class compileSilently: 'classSideMethodDefinedInP3 ^ #classSideMethodDefinedInP3'.
	p3 addMethod: (a2 class>>#classSideMethodDefinedInP3)! !

!RPackageConflictError commentStamp: ''!
I'm an error that happens when someone attempts to register a package with a conflicting name. 
Conflicting names can be of two ways: 

PackageA(tagB) conflicts with PackageA-B
PackageA-B conflicts with PackageA(tagB)!
!RPackageExtensionMethodsSynchronisationTest commentStamp: ''!
SUnit tests for RPackage extension methods!
!RPackageExtensionMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testMoveClassInPackageWithExtensionsOnClass2
	"Move a class in package XXXXX (with extensions from XXXX) to package YYYYY."

	| class secondPackage |
	self addXYCategory.
	secondPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class inCategory: '*XXXXX'.

	secondPackage addClass: class.

	"Everything should now be in second package (and not listed as an extension)."
	self assert: (class >> #stubMethod) category equals: Protocol defaultName.
	self assert: (secondPackage includesDefinedSelector: #stubMethod ofClass: class).
	self deny: (secondPackage includesExtensionSelector: #stubMethod ofClass: class).
	self assert: (class >> #stubMethod packageFromOrganizer: self organizer) equals: secondPackage! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testRemoveAllExtensionMethodsFromMetaAndInstanceSideUpdateOrganizerExtensionsMapping
	"test that In a class (from the meta  and the instance side ), when we remove all the method extended by the same external package, the class get unregistered from the classExtendingPackagesMapping of the organizer "

	|XPackage  class YPackage|
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage  := self organizer packageNamed: #YYYYY.

	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: '*yyyyy'. 
	self createMethodNamed: 'stubMethod2' inClass: class classSide  inCategory: '*yyyyy'. 

	class removeSelector: #stubMethod.
	class classSide removeSelector: #stubMethod2.
	"there should be no differences made between class and metaClass:"
	self deny: ((self organizer extendingPackagesOf: class) includes: YPackage). 
	self deny: ((self organizer extendingPackagesOf: class classSide) includes: YPackage). ! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testRemoveExtensionMethodRemoveMethodFromItsPackage
	"test that when we remove a method that is an extension from an external package, the method is removed from this package"

	|XPackage  class YPackage|
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage  := self organizer packageNamed: #YYYYY.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: '*yyyyy'.
	
	class removeSelector: #stubMethod.
	self deny: (YPackage includesExtensionSelector: #stubMethod ofClass: class). ! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testMoveClassInPackageWithExtensionsOnClassAndBack
	"Move a class in package XXXXX (with extensions from YYYY) to package YYYYY."

	| class firstPackage secondPackage |
	self addXYCategory.
	firstPackage := self organizer packageNamed: #XXXXX.
	secondPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class inCategory: secondPackage methodCategoryPrefix.

	secondPackage addClass: class.

	"Everything should now be in second package (and not listed as an extension, but instead as 'as yet unclassified')."

	self assert: (class >> #stubMethod) category equals: Protocol defaultName.
	self assert: (secondPackage includesDefinedSelector: #stubMethod ofClass: class).
	self deny: (secondPackage includesExtensionSelector: #stubMethod ofClass: class).
	self assert: (class >> #stubMethod packageFromOrganizer: self organizer) equals: secondPackage.

	"Moving back, we should not see the extension reappear."

	firstPackage addClass: class.

	self assert: (class >> #stubMethod) category equals: Protocol defaultName.
	self assert: (firstPackage includesDefinedSelector: #stubMethod ofClass: class).
	self deny: (secondPackage includesExtensionSelector: #stubMethod ofClass: class)! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'we are not sure' stamp: ''!
testAddMethodInExtensionCategoryNotRespectingCaseAddMethodToTheExtendingPackage
	"test that when we add a method  in an extension category ( beginning with *)thae does not match the case of the corresponding package (for example *packagea for PackageA), this method is added to the corresponding extending package"
	
	| class firstPackage secondPackage|
	self addXYCategory.
	firstPackage := self organizer packageNamed: #XXXXX.
	secondPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	
	self createMethodNamed: 'stubMethod' inClass:  class inCategory: '*yyYyY'.
	
	self assert: (secondPackage includesExtensionSelector: #stubMethod ofClass: class).
	self deny: (firstPackage includesDefinedSelector: #stubMethod ofClass: class).
	
	self assert: ((class >> #stubMethod) packageFromOrganizer: self organizer ) equals: secondPackage.! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testModifyMethodByChangingCode
	"test that when we modify the code of a method, everything work well: NOTHING SHOULD HAPPEN REGARDING THE PACKAGING"

	| class firstPackage |
	self addXCategory.
	firstPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class inCategory: 'classic category'.

	class compile: 'stubMethod ^22222222222'.

	"nothing should change"
	self assert: (class >> #stubMethod) category equals: 'classic category'.
	self assert: (firstPackage includesDefinedSelector: #stubMethod ofClass: class).
	self deny: (firstPackage includesExtensionSelector: #stubMethod ofClass: class).
	self assert: (class >> #stubMethod packageFromOrganizer: self organizer) equals: firstPackage! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testRemoveAllExtensionMethodsRemoveTheClassFromExtendedClasses
	"test that In a class, when we remove all the method extended by the same external package, the class get unregistered from the extended classes of the external package "

	|XPackage  class YPackage|
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage  := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: '*yyyyy'. 
	self createMethodNamed: 'stubMethod2' inClass: class  inCategory: '*yyyyy'. 
	
	self assert: (YPackage includesExtensionSelector: #stubMethod ofClass: class). 
	self assert: (YPackage includesExtensionSelector: #stubMethod2 ofClass: class). 

	class removeSelector: #stubMethod.
	class removeSelector: #stubMethod2.
	self deny: (YPackage extendsClass: class).
	self deny: (YPackage extendsClass: class classSide).! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'we are not sure' stamp: ''!
testAddMethodInExtensionCategoryWithExactMatchAddMethodToTheExtendingPackage
	"test that when we add a method to a  class in an extension category ( beginning with *), this method is added to the corresponding extending package"

	| class firstPackage secondPackage |
	self addXYCategory.
	self addXMatchCategory.

	firstPackage := self organizer packageNamed: #XXXXX.
	secondPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.


	self createMethodNamed: 'stubMethod' inClass: class inCategory: '*YYYYY'.

	self assert: (secondPackage includesExtensionSelector: #stubMethod ofClass: class).
	self deny: (firstPackage includesDefinedSelector: #stubMethod ofClass: class).

	self assert: (class >> #stubMethod packageFromOrganizer: self organizer) equals: secondPackage! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'we are not sure' stamp: ''!
testAddMethodInExtensionCategoryBestMatchingNameAddMethodToTheExtendingPackage
	"test that when we add a method  in an extension category ( beginning with*) that enlarge a package name (for example *mondrian-accessing for Mondrian), this method is added to the corresponding extending package"

	| class XPackage YPackage |
	self addXYCategory.
	self addXMatchCategory.

	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX-YYYY'.

	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.

	class := self createNewClassNamed: 'NewClass' inCategory: 'YYYYY'.

	self createMethodNamed: #newMethod inClass: class inCategory: '*XXXXX-YYYY'.

	self deny: (YPackage includesDefinedSelector: #newMethod ofClass: class).
	self assert: (XPackage includesExtensionSelector: #newMethod ofClass: class).

	self assert: (class >> #newMethod packageFromOrganizer: self organizer) equals: XPackage! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testMoveClassInPackageWithExtensionsOnClass
	"Move a class in package XXXXX (with extensions from YYYY) to package YYYYY."

	| class secondPackage |
	self addXYCategory.
	secondPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class inCategory: secondPackage methodCategoryPrefix.

	secondPackage addClass: class.

	"Everything should now be in second package (and not listed as an extension)."
	self assert: (class >> #stubMethod) category equals: Protocol defaultName.
	self assert: (secondPackage includesDefinedSelector: #stubMethod ofClass: class).
	self deny: (secondPackage includesExtensionSelector: #stubMethod ofClass: class).
	self assert: (class >> #stubMethod packageFromOrganizer: self organizer) equals: secondPackage! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testRemoveExtensionMethodDoesNotRemoveExtendingPackage
	"test that when we remove a method that is an extension from an external package, the package is not removed from the the class extending packages if another extension still exist"

	|XPackage  class YPackage|
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage  := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: '*yyyyy'. 
	self createMethodNamed: 'stubMethod2' inClass: class  inCategory: '*yyyyy'. 
	
	self assert: (YPackage includesExtensionSelector: #stubMethod ofClass: class). 
	self assert: (YPackage includesExtensionSelector: #stubMethod2 ofClass: class). 

	"If we only remove one of the extension methods, the package should still be extending the class."
	class removeSelector: #stubMethod.
	self assert: (YPackage extendsClass: class).
	self assert: (YPackage extendsClass: class classSide).! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'testing' stamp: ''!
testAddMethodInExtensionCategoryNotExistingCreateANewPackageAndInstallsMethodInIt
	"test that when we add a method  in an extension category ( beginning with *)that does not refer to an existing categorya new package with the name of this category is added, and that the method is added to this new package"
	| class firstPackage |
	
	self addXCategory.
	
	firstPackage := self organizer packageNamed: #XXXXX.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	
	self createMethodNamed: #newMethod inClass:  class inCategory: '*SomethingDifferentNothingToDoWithWhatWeHave'.
	
	self deny: (class package includesDefinedSelector: #newMethod ofClass: class).
	
	self assert: (self organizer includesPackageNamed: #SomethingDifferentNothingToDoWithWhatWeHave).
	self assert: ((class >> #newMethod) packageFromOrganizer: self organizer ) equals: (self organizer packageNamed: #SomethingDifferentNothingToDoWithWhatWeHave).! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'testing' stamp: ''!
testAddMethodInExtensionCategoryNotExistingCreateANewPackage
	"test that when we add a method  in an extension category ( beginning with *)that does not refer to an existing categorya new package with the name of this category is added, and that the method is added to this new package"
	| class firstPackage |
	
	self addXCategory.
	
	firstPackage := self organizer packageNamed: #XXXXX.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	
	self createMethodNamed: #newMethod inClass:  class inCategory: '*SomethingDifferentNothingToDoWithWhatWeHave'.
	
	self deny: (class package includesDefinedSelector: #newMethod ofClass: class).
	
	self assert: (self organizer includesPackageNamed: #SomethingDifferentNothingToDoWithWhatWeHave).! !

!RPackageExtensionMethodsSynchronisationTest methodsFor: 'we are not sure' stamp: ''!
testAddMethodInExtensionCategoryMatchingNameAddMethodToTheExtendingPackage
	"test that when we add a method  in an extension category ( beginning with*) that enlarge a package name (for example *mondrian-accessing for Mondrian), this method is added to the corresponding extending package"

	| class XPackage YPackage |
	self addXYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.

	self createMethodNamed: #newMethod inClass: class inCategory: '*YYYYY-subcategory'.

	self assert: (YPackage includesExtensionSelector: #newMethod ofClass: class).
	self deny: (XPackage includesDefinedSelector: #newMethod ofClass: class).

	self assert: (class >> #newMethod packageFromOrganizer: self organizer) equals: YPackage! !

!RPackageIncrementalTest commentStamp: ''!
The tests takes as fixture the following situation (which is constructed partially)
For tests that do not need to check the incremental construction.


P1 
	A1DefinedInP1>>methodDefinedInP1
	B1DefinedInP1	
	A2DefinedInP2>>methodDefinedInP1  (was *P2)
	
P2
	A2DefinedInP2>>methodDefinedInP2
	B2DefinedInB2	

P3
	A3DefinedInP3	
	A2DefinedInP2>>methodDefinedInP3  (was *P2*)!
!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testIncludesMethodOfClassInPresenceOfOtherPackageExtensions
	| p1 p2 p3 a2  a2name |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.
	a2name := #A2InPackageP2.
	a2 := self createNewClassNamed: a2name inPackage: p2.
	
	a2 compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addMethod: (a2>>#methodDefinedInP2).
	self assert: (p2 includesDefinedSelector: #methodDefinedInP2 ofClassName: a2name).
	
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	self assert: (p1 includesExtensionSelector: #methodDefinedInP1 ofClassName: a2name).
	
	a2 compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addMethod: (a2>>#methodDefinedInP3).
	self assert: (p3 includesExtensionSelector: #methodDefinedInP3 ofClassName: a2name).
		
	self assert: (p2 includesDefinedSelector: #methodDefinedInP2 ofClassName: a2name).
	self deny: (p2 includesDefinedSelector: #methodDefinedInP3 ofClassName: a2name).
	self deny: (p2 includesExtensionSelector: #methodDefinedInP3 ofClassName: a2name).
	self deny: (p2 includesDefinedSelector: #methodDefinedInP1 ofClassName: a2name).
	self deny: (p2 includesExtensionSelector: #methodDefinedInP1 ofClassName: a2name).! !

!RPackageIncrementalTest methodsFor: 'tests - method addition removal' stamp: ''!
testAddRemoveMethod
	| p1 p2 p3 a2   a2Name |
	a2Name := #A2InPackageP2.
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.
	a2 := self createNewClassNamed: a2Name inPackage: p2.
	a2 compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	
	p2 addMethod: (a2>>#methodDefinedInP2).
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	a2 compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addMethod: (a2>>#methodDefinedInP3).
	
	self assert: (p2 includesDefinedSelector: #methodDefinedInP2 ofClassName: a2Name).
	self deny: (p2 includesExtensionSelector: #methodDefinedInP2 ofClassName: a2Name).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP3 ofClassName: a2Name).
	self assert: (p3 includesExtensionSelector: #methodDefinedInP3 ofClassName: a2Name).
	self assert: (p1 includesExtensionSelector: #methodDefinedInP1 ofClassName: a2Name).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP1 ofClassName: a2Name).
	
	"removeMethod by default removes from defined methods and not extension"
	p2 removeMethod: (a2>>#methodDefinedInP2).
	self deny: (p2 includesDefinedSelector: #methodDefinedInP2 ofClassName: a2Name).
	self deny: (p2 includesExtensionSelector: #methodDefinedInP2 ofClassName: a2Name).
	
	p1 removeMethod: (a2>>#methodDefinedInP1).
	self deny: (p1 includesDefinedSelector: #methodDefinedInP3 ofClassName: a2Name).
	self deny: (p1 includesExtensionSelector: #methodDefinedInP3 ofClassName: a2Name).! !

!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testExtensionClassesWithCompiledMethod
	| p1 p2  a2 b2 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	b2 := self createNewClassNamed: #B2InPackageP2 inPackage: p2.
	self deny: (p1 includesClass: a2).
	self assert: (p2 includesClass: b2).
	self assert: (p2 includesClass: b2).
	
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	
	self assert: p1 extensionMethods size equals: 1.
	self assert: p1 extensionSelectors size equals: 1.
	self assert: p1 extendedClasses size equals: 1.
	self deny: (p1 includesClass: a2).
	"method extension class are not included in packages"
	
	b2 compile: 'firstMethodInB2PackagedInP1 ^ 1'.
	p1 addMethod: (b2>>#firstMethodInB2PackagedInP1).
	
	self assert: p1 extensionSelectors size equals: 2.
	self assert: p1 extensionMethods size equals: 2.
	self assert: p1 extendedClasses size equals: 2.
	self deny: (p1 includesClass: b2).
	
	b2 compileSilently: 'secondMethodInB2PackagedInP1 ^ 2'.
	p1 addMethod: (b2>>#secondMethodInB2PackagedInP1).
	
	self assert: p1 extensionSelectors size equals: 3.
	self assert: p1 extensionMethods size equals: 3.
	self assert: p1 extendedClasses size equals: 2.
	self deny: (p1 includesClass: b2).! !

!RPackageIncrementalTest methodsFor: 'tests - method addition removal' stamp: ''!
testMethodPackageResolution
	| a1Name p1 a1 |
	a1Name := #A2InPackageP2.
	p1 := self createNewPackageNamed: 'P1'.
	a1 := self createNewClassNamed: a1Name inPackage: p1.
	a1 compileSilently: 'method ^ #methodDefinedInP2'.
	a1 class compileSilently: 'method ^ #methodDefinedInP2'.

	p1 addMethod: a1 >> #method.
	p1 addMethod: a1 class >> #method.

	self assert: (a1 >> #method) package identicalTo: p1.
	self assert: (a1 class >> #method) package identicalTo: p1! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testClassDefinitionRemovalName
	| p a1 b1|
	p := self createNewPackageNamed: self p1Name.
	a1 := self createNewClassNamed: #A1InPAckageP1 inCategory: self p1Name.
	b1 := self createNewClassNamed: #B1InPAckageP1 inCategory: self p1Name.
	self assert: p definedClasses size equals: 0.
	p addClassDefinitionName: a1 name.
	p addClassDefinitionName: b1 name.
	self assert: p definedClasses size equals: 2.
	self assert: (p includesClass: a1).
	self assert: (p includesClass: b1).
	p removeClassDefinitionName: a1 name.
	self assert: p definedClasses size equals: 1.
	self deny: (p includesClass: a1).
	self assert: (p includesClass: b1).
	self should: [p removeClassDefinitionName: b1 class name] raise: Error.
	p removeClassDefinitionName: b1 name.
	self deny: (p includesClass: b1).! !

!RPackageIncrementalTest methodsFor: 'utilities' stamp: ''!
p1Name
	^ 'RPackageTestP1'! !

!RPackageIncrementalTest methodsFor: 'tests - registration' stamp: ''!
testPrivateClassRegisterUnregister
	"Verify that when we register a class, the package organizer register it."
	| p a1 |
	p := self createNewPackageNamed: 'P1'.
	a1 := self createNewClassNamed: #A1InPackageP1.
	p definedClassNames add: #A1InPackageP1.
		"ugly but necessary to test registerClass: independantly from addClassDefinition:"
		"No event should be raised."
	p registerClass: a1.
	self assert: (self packageClass organizer packageOf: a1) equals: p.
	p definedClassNames remove: #A1InPackageP1.
	p unregisterClass: a1.
	self assert: (self packageClass organizer packageOf: a1) isDefault.
	
	p definedClassNames add: #A1InPackageP1.
		"ugly but necessary to test registerClass: independant from addClassDefinition:"
	p registerClassName: a1 name.
	self assert: (self packageClass organizer packageOf: a1) equals: p.
	p definedClassNames remove: #A1InPackageP1.
	p unregisterClassName: a1 name.
	self assert: (self packageClass organizer packageOf: a1) isDefault! !

!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testIncludeSelectorOfMetaClass
	| p1 p2 p3 a2  a2class |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.
	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	a2class := a2 class.
	a2class compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addMethod: (a2class>>#methodDefinedInP2).
	a2class compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2class>>#methodDefinedInP1).
	a2class compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addMethod: (a2class>>#methodDefinedInP3).
	
	"includesSelector checks both in defined and extension so we test both"
	self assert: (p2 includesSelector: #methodDefinedInP2 ofClass: a2class).
	self assert: (p2 includesDefinedSelector: #methodDefinedInP2 ofMetaclassName: a2 name).
	self assert: (p2 includesDefinedSelector: #methodDefinedInP2 ofClass: a2class).
	self deny: (p2 includesExtensionSelector: #methodDefinedInP2 ofMetaclassName: a2 name).
	
	self deny: (p2 includesSelector: #methodDefinedInP3 ofClass: a2).
	self assert: (p3 includesExtensionSelector: #methodDefinedInP3 ofMetaclassName: a2 name).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP3 ofMetaclassName: a2 name).
	
	self deny: (p2 includesSelector: #methodDefinedInP1 ofMetaclassName: a2).
	self assert: (p1 includesExtensionSelector: #methodDefinedInP1 ofMetaclassName: a2 name).
	self assert: (p1 includesExtensionSelector: #methodDefinedInP1 ofClass: a2 class).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP1 ofClassName: a2 name).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP1 ofClass: a2).! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testRemoveClassRemovesExtensions
	| p1 p2 a1 |
	p1 := self createNewPackageNamed: self p1Name.
	p2 := self createNewPackageNamed: self p2Name.
	"the class is created but not added to the package for now"
	a1 := self createNewClassNamed: #A1InPackageP1 inCategory: self p1Name.
	p1 addClassDefinition: a1.
	self assert: p1 definedClasses size equals: 1.
	a1 compileSilently: 'newlyAddedToA1 ^ #methodDefinedInP1'.
	p2 addMethod: (a1>>#newlyAddedToA1).
	
	self assert: (p2 includesSelector: #newlyAddedToA1 ofClass: a1).
	self assert: (p2 includesExtensionSelector: #newlyAddedToA1 ofClass: a1).
	
	a1 removeFromSystem.
	
	self deny: (p2 includesSelector: #newlyAddedToA1 ofClass: a1).
	self deny: (p2 includesExtensionSelector: #newlyAddedToA1 ofClass: a1).
	self deny: (p2 includesDefinedSelector: #newlyAddedToA1 ofClass: a1)! !

!RPackageIncrementalTest methodsFor: 'tests - method addition removal' stamp: ''!
testAddRemoveSelector
	| p1 p2 p3 a2   a2Name |
	a2Name := #A2InPackageP2.
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.
	a2 := self createNewClassNamed: a2Name inPackage: p2.
	a2 compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addSelector: #methodDefinedInP2 ofClassName: a2Name.
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addSelector: #methodDefinedInP1 ofClassName: a2Name.
	a2 compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addSelector: #methodDefinedInP3 ofClassName: a2Name.
	
	self assert: (p2 includesDefinedSelector: #methodDefinedInP2 ofClassName: a2Name).
	self deny: (p2 includesExtensionSelector: #methodDefinedInP2 ofClassName: a2Name).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP3 ofClassName: a2Name).
	self assert: (p3 includesExtensionSelector: #methodDefinedInP3 ofClassName: a2Name).
	self assert: (p1 includesExtensionSelector: #methodDefinedInP1 ofClassName: a2Name).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP1 ofClassName: a2Name).
	
	p2 removeSelector: #methodDefinedInP2 ofClassName:  a2Name.
	self deny: (p2 includesDefinedSelector: #methodDefinedInP2 ofClassName: a2Name).
	self deny: (p2 includesExtensionSelector: #methodDefinedInP2 ofClassName: a2Name).
	
	p1 removeSelector: #methodDefinedInP1 ofClassName:  a2Name.
	self deny: (p1 includesDefinedSelector: #methodDefinedInP3 ofClassName: a2Name).
	self deny: (p1 includesExtensionSelector: #methodDefinedInP3 ofClassName: a2Name).! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testClassDefinitionRemoval
	| p a1 b1|
	
	p := self createNewPackageNamed: self p1Name.
	a1 := self createNewClassNamed: #A1InPAckageP1 inCategory: self p1Name.
	b1 := self createNewClassNamed: #B1InPAckageP1 inCategory: self p1Name.
	self assert: p definedClasses size equals: 0.
	
	p addClassDefinition: a1.
	p addClassDefinition: b1.
	self assert: p definedClasses size equals: 2.
	
	self assert: (p includesClass: a1).
	self assert: (p includesClass: b1).
	
	p removeClassDefinition: a1.
	self assert: p definedClasses size equals: 1.
	self deny: (p includesClass: a1).
	self assert: (p includesClass: b1).
	
	p removeClassDefinition: b1 class.
	self deny: (p includesClass: b1).! !

!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testIncludeSelectorOfClass
	| p1 p2 p3 a2  |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.
	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	a2 compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addMethod: (a2>>#methodDefinedInP2).
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	a2 compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addMethod: (a2>>#methodDefinedInP3).
	
	"includesSelector checks both in defined and extension so we test both"
	self assert: (p2 includesSelector: #methodDefinedInP2 ofClass: a2).
	self assert: (p2 includesDefinedSelector: #methodDefinedInP2 ofClassName: a2 name).
	self deny: (p2 includesExtensionSelector: #methodDefinedInP2 ofClassName: a2 name).
	
	self deny: (p2 includesSelector: #methodDefinedInP3 ofClass: a2).
	self assert: (p3 includesExtensionSelector: #methodDefinedInP3 ofClassName: a2 name).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP3 ofClassName: a2 name).
	
	self deny: (p2 includesSelector: #methodDefinedInP1 ofClass: a2).
	self assert: (p1 includesExtensionSelector: #methodDefinedInP1 ofClassName: a2 name).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP1 ofClassName: a2 name).! !

!RPackageIncrementalTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	Author fullName ifNil: [Author fullName: 'RPackage'].! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testAddClassAfterMethods
	| p1 a1 |
	p1 := self createNewPackageNamed: self p1Name.
	"the class is created but not added to the package for now"
	a1 := self createNewClassNamed: #A1InPackageP1 inCategory: self p1Name.
	self assert: p1 definedClasses size equals: 0.
	
	"now we add a new method to the class and the to the package: it is considered
	as class extension"
	
	a1 compileSilently: 'newlyAddedToA1 ^ #methodDefinedInP1'.
	p1 addMethod: (a1>>#newlyAddedToA1).
	self assert: (p1 includesSelector: #newlyAddedToA1 ofClass: a1).
	self assert: (p1 includesExtensionSelector: #newlyAddedToA1 ofClass: a1).
	self deny: (p1 includesDefinedSelector: #newlyAddedToA1 ofClass: a1).
	
	"Now we add the class and this means that the method is not an extension anymore but 
	a defined method"
	
	p1 addClassDefinition: a1.
	self assert: p1 definedClasses size equals: 1.
	
	self deny: (p1 includesExtensionSelector: #newlyAddedToA1 ofClass: a1).
	self assert: (p1 includesDefinedSelector: #newlyAddedToA1 ofClass: a1).
	
	
"
	self assert: (p1 includesSelector: #methodDefinedInP1 ofClass: a1).
	self assert: (p3 includesSelector: #classSideMethodDefinedInP3 ofClass: a2 class)
	"! !

!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testIncludesOrTouches
	| p1 p2 a2  |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.

	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	self deny: (p1 includesClass: a2).
	self assert: (p2 includesClass: a2).
	
	a2 compileSilently: 'methodPackagedInP1 ^ #methodPackagedInP1'.
	p1 addMethod: (a2>>#methodPackagedInP1).
	
	self assert: p1 extensionMethods size equals: 1.
	self assert: p1 extensionSelectors size equals: 1.
	self deny: (p1 includesClass: a2).
	self assert: (p1 definesOrExtendsClass: a2).
	self assert: (p2 includesClass: a2).! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testRemoveClassAfterMethods
	| p1 a1 |
	p1 := self createNewPackageNamed: self p1Name.
	"the class is created but not added to the package for now"
	a1 := self createNewClassNamed: #A1InPackageP1 inCategory: self p1Name.
	p1 addClassDefinition: a1.
	self assert: p1 definedClasses size equals: 1.
	a1 compileSilently: 'newlyAddedToA1 ^ #methodDefinedInP1'.
	p1 addMethod: (a1>>#newlyAddedToA1).
	
	"now we add a new method to the class and the to the package: it is considered
	as defined"
	self deny: (p1 includesExtensionSelector: #newlyAddedToA1 ofClass: a1).
	self assert: (p1 includesDefinedSelector: #newlyAddedToA1 ofClass: a1).
	
	p1 removeClassDefinition: a1.
	self assert: p1 definedClasses size equals: 0.
	
	self assert: (p1 includesSelector: #newlyAddedToA1 ofClass: a1).
	self assert: (p1 includesExtensionSelector: #newlyAddedToA1 ofClass: a1).
	self deny: (p1 includesDefinedSelector: #newlyAddedToA1 ofClass: a1).
	
	"Now we add the class and this means that the method is not defined anymore but an extension "! !

!RPackageIncrementalTest methodsFor: 'running' stamp: ''!
tearDown
	
	| logging |
	createdPackages  do: [:each | self removePackage: each name].
	"just remove package from package organizer dictionary"
	
	createdPackages  do: [:each |
		|mCPackage|
		mCPackage := self allManagers 
							detect: [:mcPackage | mcPackage packageName = each packageName asString] 
							ifNone: [nil].
		mCPackage ifNotNil: [mCPackage unregister].
		each extendedClasses do: [ :extendedClass|
			self packageClass organizer
		 		unregisterExtendingPackage: each forClass: extendedClass.]].
	"all ***extending*** classes the packages are also unregistered from PackageOrganizer"									
	(createdClasses reject: [:c| c isObsolete]) do: [:cls| 
		"(RPackage organizer includesPackageBackPointerForClass: cls) 
			ifTrue: [cls package unregisterClass: cls.]. 
		when RPackageOrganizer was not looking at system event we had to do the commented actions"
		logging := false.
		cls removeFromSystem: logging.  
		"not logging so no event are raised"
		"but this also means that the consistency cannot be ensured by internal system announcer too."
		].					
	createdCategories do: [:each | 
		SystemOrganization removeCategory: each.
		 ].
	super tearDown.! !

!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testTwoClassesWithExtensions	
	| p1 p2 a2  b2 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.

	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	b2 := self createNewClassNamed: #B2InPackageP2 inPackage: p2.
	a2 compileSilently: 'methodPackagedInP1 ^ #methodPackagedInP1'.
	p1 addMethod: (a2>>#methodPackagedInP1).
	b2 class compileSilently: 'methodPackagedInP1 ^ #methodPackagedInP1'.
	p1 addMethod: (b2 class>>#methodPackagedInP1).
	
	self assert: p1 classes size equals: 2.
	self assert: p2 classes size equals: 2! !

!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testIncludeClass
	| p1 p2 a2  |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	a2 compileSilently: 'methodPackagedInP1 ^ #methodPackagedInP1'.
	
	self deny: (p1 includesClass: a2).
	p1 addMethod: (a2>>#methodPackagedInP1).
	self deny: (p1 includesClass: a2).
	"We should declare the class explictly. Adding a method does not declare
	the class as defined. The reason is that like that the client controls the granularity 
	and moment of class registration."
	
	p1 addClassDefinition: a2.
	self assert: (p1 includesClass: a2).
	self assert: (p1 includesClassNamed: a2 name).! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testBogusClassAddition
	| p a1 |
	p := self createNewPackageNamed: self p1Name.
	a1 := self createNewClassNamed: #A1InPAckageP1 inCategory: self p1Name.
	self assert: p definedClasses size equals: 0.
	p addClassDefinitionName: a1 name.
	self assert: p definedClasses size equals: 1.
	self assert: (p includesClass: a1).
	self should: [p addClassDefinitionName: a1 class name] raise: Error! !

!RPackageIncrementalTest methodsFor: 'tests - package belonging' stamp: ''!
testPackageOfClassForClassesNotDefinedInPackageButJustExtendingIt
	| p1 p2 a2 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.

	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: a2 >> #methodDefinedInP1.

	self assert: a2 package equals: p2.
	p1 extensionMethods do: [ :each | self deny: each methodClass package equals: p1 ]
	"the package of a class which is extended inside a package p, is not p
	but the package where the class was defined"! !

!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testIncludeClassMore
	| p1 p2 p3 a2  |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.
	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	a2 compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addMethod: (a2>>#methodDefinedInP2).
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	a2 compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addMethod: (a2>>#methodDefinedInP3).
	
	self assert: (p2 includesClass: a2).
	self deny: (p1 includesClass: a2).
	self deny: (p3 includesClass: a2).! !

!RPackageIncrementalTest methodsFor: 'utilities' stamp: ''!
p2Name
	^ 'RPackageTestP2'! !

!RPackageIncrementalTest methodsFor: 'utilities' stamp: ''!
p3Name
	^ 'RPackageTestP3'! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testAddClassDefinitionNoDuplicate
	| p a1 b1 |
	p := self createNewPackageNamed: self p1Name.
	a1 := self createNewClassNamed: #A1InPackageP1 inCategory: self p1Name.
	self assert: p definedClasses size equals: 0.
	p addClassDefinition: a1.
	self assert: p definedClasses size equals: 1.
	b1 := self createNewClassNamed: #B1InPackageP1 inCategory: self p1Name.
	p addClassDefinition: a1.
	"adding the same class does not do anything - luckily"
	self assert: p definedClasses size equals: 1.
	p addClassDefinition: b1.
	self assert: p definedClasses size equals: 2.! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testDefinedClassesAndDefinedClassNames
	| p a1 b1 |
	p := self createNewPackageNamed: self p1Name.
	a1 := self createNewClassNamed: #A1InPackageP1 inCategory: self p1Name.
	self assert: p definedClasses size equals: 0.
	p addClassDefinition: a1.
	self assert: p definedClasses size equals: 1.
	self assert: (p definedClasses  includes: a1).
	self assert: (p definedClassNames includes: a1 name).
	
	b1 := self createNewClassNamed: #B1InPackageP1 inCategory: self p1Name.
	p addClassDefinition: b1.
	self assert: p definedClasses size equals: 2.
	self assert: (p definedClasses includes: b1).
	self assert: (p definedClassNames includes: b1 name)! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testClassDefinitionWithTagsRemoval
	| p a1 b1|
	
	p := self createNewPackageNamed: self p1Name.
	a1 := self createNewClassNamed: #A1InPAckageP1 inCategory: self p1Name.
	b1 := self createNewClassNamed: #B1InPAckageP1 inCategory: self p1Name.
	self assert: p definedClasses size equals: 0.
	
	p addClassDefinition: a1.
	p addClassDefinition: b1.
	self assert: p definedClasses size equals: 2.
	
	p addClassDefinition: a1 toClassTag: 'a1-tag'. 
	p addClassDefinition: b1 toClassTag: 'b1-tag'.
	self assert: p classTags size equals: 2.
	
	self assert: (p includesClass: a1).
	self assert: (p includesClass: b1).
	
	p removeClassDefinition: a1.
	self assert: p definedClasses size equals: 1.
	self deny: (p includesClass: a1).
	self assert: (p includesClass: b1).
	
	p removeClassDefinition: b1 class.
	self deny: (p includesClass: b1).
	self assert: p classTags size equals: 0.! !

!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testExtensionClassNames
	| p1 p2  a2 b2 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	b2 := self createNewClassNamed: #B2InPackageP2 inPackage: p2.
	self deny: (p1 includesClass: a2).
	self assert: (p2 includesClass: b2).
	self assert: (p2 includesClass: a2).
	
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addSelector: #methodDefinedInP1 ofClassName: a2 name.
	
	self assert: p1 extensionSelectors size equals: 1.
	self assert: p1 extensionMethods size equals: 1.
	self assert: (p1 extendedClassNames includes: #A2InPackageP2).
	self deny: (p1 includesClass: a2).
	"method extension class are not included in packages"
	
	b2 compile: 'firstMethodInB2PackagedInP1 ^ 1'.
	p1 addSelector: #firstMethodInB2PackagedInP1 ofClassName: b2 name.
	
	self assert: p1 extensionSelectors size equals: 2.
	self assert: p1 extensionMethods size equals: 2.
	self assert: (p1 extendedClassNames includes: #B2InPackageP2).
	self deny: (p1 includesClass: b2).
	
	b2 compileSilently: 'secondMethodInB2PackagedInP1 ^ 2'.
	p1 addSelector: #secondMethodInB2PackagedInP1 ofClassName: b2 name.
	
	self assert: p1 extensionSelectors size equals: 3.
	self assert: p1 extensionMethods size equals: 3.
	self assert: p1 extendedClasses size equals: 2.
	self assert: (p1 extendedClassNames includes: #B2InPackageP2).
	self deny: (p1 includesClass: b2).! !

!RPackageIncrementalTest methodsFor: 'utilities' stamp: ''!
removeClassNamedIfExists: aClassNameSymbol
	testingEnvironment at: aClassNameSymbol asSymbol ifPresent: [:c| c removeFromSystem]! !

!RPackageIncrementalTest methodsFor: 'tests - method addition removal' stamp: ''!
testMethodAddition
	| p1 a1 |
	p1 := self createNewPackageNamed: 'P1'.
	a1 := self createNewClassNamed: #A1DefinedInP1 inPackage: p1.
	a1 compileSilently: 'foo ^ 10'.
	p1 addMethod:  (a1>>#foo).
	self assert: (p1 includesSelector: #foo ofClass: a1).! !

!RPackageIncrementalTest methodsFor: 'tests - method addition removal' stamp: ''!
testAddRemoveSelectorOfMetaclass
	| p1 p2 p3 a2   a2Name a2class |
	a2Name := #A2InPackageP2.
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.
	a2 := self createNewClassNamed: a2Name inPackage: p2.
	a2class := a2 class.
	a2class compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addSelector: #methodDefinedInP2 ofMetaclassName: a2Name.
	a2class compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addSelector: #methodDefinedInP1 ofMetaclassName: a2Name.
	a2class compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addSelector: #methodDefinedInP3 ofMetaclassName: a2Name.
	
	self assert: (p2 includesDefinedSelector: #methodDefinedInP2 ofMetaclassName: a2Name).
	self deny: (p2 includesExtensionSelector: #methodDefinedInP2 ofMetaclassName: a2Name).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP3 ofMetaclassName: a2Name).
	self assert: (p3 includesExtensionSelector: #methodDefinedInP3 ofMetaclassName: a2Name).
	self assert: (p1 includesExtensionSelector: #methodDefinedInP1 ofMetaclassName: a2Name).
	self deny: (p3 includesDefinedSelector: #methodDefinedInP1 ofMetaclassName: a2Name).
	
	p2 removeSelector: #methodDefinedInP2 ofMetaclassName:  a2Name.
	self deny: (p2 includesDefinedSelector: #methodDefinedInP2 ofMetaclassName: a2Name).
	self deny: (p2 includesExtensionSelector: #methodDefinedInP2 ofMetaclassName: a2Name).
	
	p1 removeSelector: #methodDefinedInP1 ofMetaclassName:  a2Name.
	self deny: (p1 includesDefinedSelector: #methodDefinedInP3 ofMetaclassName: a2Name).
	self deny: (p1 includesExtensionSelector: #methodDefinedInP3 ofMetaclassName: a2Name).! !

!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testExtensionClasses
	| p1 p2 a2  b2 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.

	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	b2 := self createNewClassNamed: #B2InPackageP2 inPackage: p2.
	self deny: (p1 includesClass: a2).
	self assert: (p2 includesClass: a2).
	
	a2 compileSilently: 'methodPackagedInP1 ^ #methodPackagedInP1'.
	p1 addMethod: (a2>>#methodPackagedInP1).
	
	self assert: p1 extendedClasses size equals: 1.
	self assert: (p1 extendedClasses  includes: a2).
	self assert: p1 extendedClassNames size equals: 1.
	self assert: (p1 extendedClassNames  includes: a2 name).
	
	b2 class compileSilently: 'methodPackagedInP1 ^ #methodPackagedInP1'.
	p1 addMethod: (b2 class>>#methodPackagedInP1).
	
	self assert: p1 extendedClasses size equals: 2.
	self assert: (p1 extendedClasses  includes: b2 class).
	"extensionClasses returns or metaclasses while extensionClassNames returns class names (but not metaclass names)"

	self assert: p1 extendedClassNames size equals: 2.
	self assert: (p1 extendedClassNames  includes: b2 name).! !

!RPackageIncrementalTest methodsFor: 'tests - package belonging' stamp: ''!
testPackageOfClassForDefinedClasses
	| p a1 b1 |
	p := self createNewPackageNamed: 'P1'.
	a1 := self createNewClassNamed: #A1InPAckageP1 inPackage: p.
	b1 := self createNewClassNamed: #B1InPAckageP1 inPackage: p.

	self assert: a1 package equals: p.
	self assert: b1 package equals: p.! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testClassAddition
	| p a1 |
	p := self createNewPackageNamed: self p1Name.
	a1 := self createNewClassNamed: #A1InPAckageP1 inCategory: self p1Name.
	self assert: p definedClasses size equals: 0.
	p addClassDefinition: a1.
	self assert: p definedClasses size equals: 1.
	self assert: (p includesClass: a1).
	self assert: (p includesClass: a1 class)! !

!RPackageIncrementalTest methodsFor: 'tests - extension' stamp: ''!
testExtensionMethods	
	| p1 p2 a2  b2 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.

	a2 := self createNewClassNamed: #A2InPackageP2 inPackage: p2.
	b2 := self createNewClassNamed: #B2InPackageP2 inPackage: p2.
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	
	self assert: p1 extensionSelectors size equals: 1.
	self deny: (p1 includesClass: a2).
	"method extension class are not included in packages"
	
	b2 compileSilently: 'firstMethodInB2PackagedInP1 ^ 1'.
	p1 addMethod: (b2>>#firstMethodInB2PackagedInP1).
	self assert: p1 extensionSelectors size equals: 2.! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testRemoveExtensionMethodRemovesExtensionsFromRPackage
	| p1 p2 a1 |
	p1 := self createNewPackageNamed: self p1Name.
	p2 := self createNewPackageNamed: self p2Name.
	"the class is created but not added to the package for now"
	a1 := self createNewClassNamed: #A1InPackageP1 inCategory: self p1Name.
	p1 addClassDefinition: a1.
	self assert: p1 definedClasses size equals: 1.
	a1 compileSilently: 'newlyAddedToA1 ^ #methodDefinedInP1'.
	p2 addMethod: (a1>>#newlyAddedToA1).
	
	self assert: (p2 includesSelector: #newlyAddedToA1 ofClass: a1).
	self assert: (p2 includesExtensionSelector: #newlyAddedToA1 ofClass: a1).
	
	a1 removeSelector: #newlyAddedToA1.
	
	self deny: (p2 includesSelector: #newlyAddedToA1 ofClass: a1).
	self deny: (p2 includesExtensionSelector: #newlyAddedToA1 ofClass: a1).
	self deny: (p2 includesDefinedSelector: #newlyAddedToA1 ofClass: a1)! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testUniqueClassInDefinedClassesUsingAddClassDefinition
	| p a1 |
	p := self createNewPackageNamed: self p1Name.
	a1 := self createNewClassNamed: #A1InPAckageP1 inCategory: self p1Name.
	self assert: p definedClasses size equals: 0.
	p addClassDefinition: a1.
	self assert: p definedClasses size equals: 1.
	p addClassDefinition: a1.
	self assert: p definedClasses size equals: 1.
	p addClassDefinition: a1 class.
	self assert: p definedClasses size equals: 1! !

!RPackageIncrementalTest methodsFor: 'tests - class addition removal' stamp: ''!
testAddClassAfterMethodsAtMetaclassToo
	| p1 a1 |
	p1 := self createNewPackageNamed: self p1Name.
	"the class is created but not added to the package for now"
	a1 := self createNewClassNamed: #A1InPackageP1 inCategory: self p1Name.
	self assert: p1 definedClasses size equals: 0.
	
	"now we add a new method to the class and the to the package: it is considered
	as class extension"
	
	a1 class compileSilently: 'newlyAddedToA1Class ^ #methodDefinedInP1'.
	p1 addMethod: (a1 class>>#newlyAddedToA1Class).
	self assert: (p1 includesSelector: #newlyAddedToA1Class ofClass: a1 class).
	self assert: (p1 includesExtensionSelector: #newlyAddedToA1Class ofClass: a1 class).
	self deny: (p1 includesDefinedSelector: #newlyAddedToA1Class ofClass: a1 class).
	
	"Now we add the class and this means that the method is not an extension anymore but 
	a defined method"
	
	p1 addClassDefinition: a1.
	self assert: p1 definedClasses size equals: 1.
	
	self deny: (p1 includesExtensionSelector: #newlyAddedToA1Class ofClass: a1 class).
	self assert: (p1 includesDefinedSelector: #newlyAddedToA1Class ofClass: a1 class).
	
	
"
	self assert: (p1 includesSelector: #methodDefinedInP1 ofClass: a1).
	self assert: (p3 includesSelector: #classSideMethodDefinedInP3 ofClass: a2 class)
	"! !

!RPackageMCSynchronisationTest commentStamp: ''!
I had some problems using the 'ensure:' method. There was some conflicts with the organizer used for the test when trying to clean the classes, categories and packages generated for the test. 
There is something I don't get with this method. Therefore I choosed to clean by default all possible generated classes, categories and packages after each test using the tearDown method.

For now, all that was in the 'ensure:' methods has been commented.
Look for example at:
    testAddMethodInClassicCategoryAddMethodToTheParentPackageOfItsClass
and try to uncomment it!
!RPackageMCSynchronisationTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	
	emptyOrganizer := self organizer debuggingName: 'MCSynchronisation Package Organizer'; yourself.
	emptyOrganizer registerPackage: (self packageClass named: 'as yet unclassified').

	Author fullName 
		ifNil: [ Author fullName: 'Tester' ].! !

!RPackageMCSynchronisationTest methodsFor: 'tests' stamp: ''!
testIsDefinedAsPackageOrSubPackageInMC
	"test whether a given category is defined as a MC package or whether it is defined as top part of package"
	
	self assert: (self organizer isDefinedAsPackageOrSubPackageInMC: #'Compression').
	self deny: (self organizer isDefinedAsPackageOrSubPackageInMC: #'Compression-Archives').
	"Indeed compression-archives is a category but not a MC package"
	
	self assert: (self organizer isDefinedAsPackageOrSubPackageInMC: #'Collections').
	"#Collection is not defined as a package but as a package #'Collections-Unordered'"
	self assert: (self organizer isDefinedAsPackageOrSubPackageInMC: #'Collections-Unordered').
	self deny: (self organizer isDefinedAsPackageOrSubPackageInMC: #'Collections-Unordered-Test').! !

!RPackageMCSynchronisationTest methodsFor: 'to move to a simple RPackage test case' stamp: ''!
testRepackagedAnnouncementWhenModifyMethodByMovingFromExtensionCategoryToClassicCategory

	| ann class firstPackage secondPackage|
	
	ann := nil.
	SystemAnnouncer uniqueInstance
		when: MethodRepackaged do: [ :a | ann := a ].
	
	self addXYCategory. 
	firstPackage := self organizer  packageNamed: #XXXXX.
	secondPackage := self organizer  packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass:  class inCategory: '*yyyyy'.
	
	class organization classify: #stubMethod under: 'classic one'.		

	self assert: ann notNil.
	self assert: ann methodRepackaged selector equals: #stubMethod.
	self assert: ann oldPackage equals: secondPackage.
	self assert: ann newPackage equals: firstPackage.! !

!RPackageMCSynchronisationTest methodsFor: 'utilities' stamp: ''!
addXYCategory

	self addXCategory.
	self addYCategory.
			! !

!RPackageMCSynchronisationTest methodsFor: 'utilities' stamp: ''!
addXCategory
	testingEnvironment organization addCategory: 'XXXXX'.! !

!RPackageMCSynchronisationTest methodsFor: 'utilities' stamp: ''!
addZCategory

	testingEnvironment organization addCategory: 'ZZZZZ'.
			! !

!RPackageMCSynchronisationTest methodsFor: 'announcer handling' stamp: ''!
initializeAnnouncers
	super initializeAnnouncers.
	
	oldAnnouncer := MCWorkingCopy announcer.
	MCWorkingCopy announcer: announcerForTest.! !

!RPackageMCSynchronisationTest methodsFor: 'setup' stamp: ''!
cleanClassesPackagesAndCategories

		|mCPackage|
		Smalltalk removeClassNamed: 'NewClass'.
		Smalltalk removeClassNamed: 'RPackageNewStubClass'.
		Smalltalk removeClassNamed: 'RPackageOldStubClass'.
		Smalltalk removeClassNamed: 'Foo'.
		Smalltalk removeClassNamed: 'FooOther'.
		Smalltalk removeClassNamed: 'NewTrait'.
		Smalltalk removeClassNamed: 'ClassInYPackage'.
		Smalltalk removeClassNamed: 'ClassInZPackage'.
		Smalltalk organization removeCategory: 'Zork'.
		Smalltalk organization removeCategory: 'XXXXX'.
		Smalltalk organization removeCategory: 'XXXXX-YYYY'.
		Smalltalk organization removeCategory: 'XXXX'.
		Smalltalk organization removeCategory: 'YYYYY'.
		Smalltalk organization removeCategory: 'ZZZZZ'.
		Smalltalk organization removeCategory: 'FooPackage-Core'.
		Smalltalk organization removeCategory: 'FooPackage-Other'.
		Smalltalk organization removeCategory: 'FooPackage'.
		Smalltalk organization removeCategory: 'OriginalCategory'.
		Smalltalk organization removeCategory: 'NewCategoryName'.
		Smalltalk organization removeCategory: 'Y'.
		mCPackage := (self allManagers detect: [:each | each packageName = 'OriginalCategory'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'XXXXX'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'XXXX'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'YYYYY'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'YYYY'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'Yyyyy'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].	
		mCPackage := (self allManagers detect: [:each | each packageName = 'YyYyY'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'Y'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'ZZZZZ'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].	
		mCPackage := (self allManagers detect: [:each | each packageName = 'Zzzzz'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'FooPackage-Core'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'FooPackage-Other'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'FooPackage'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
		mCPackage := (self allManagers detect: [:each | each packageName = 'Zork'] ifNone: [nil]) .
		mCPackage ifNotNil: [mCPackage unregister].
			! !

!RPackageMCSynchronisationTest methodsFor: 'running' stamp: ''!
tearDown
	MCWorkingCopy removeDependent: self emptyOrganizer.
	self cleanClassesPackagesAndCategories.
	super tearDown.! !

!RPackageMCSynchronisationTest methodsFor: 'to move to a simple RPackage test case' stamp: ''!
testNotRepackagedAnnouncementWhenModifyMethodByMovingInSameExtensionCategory
	
	| ann class firstPackage secondPackage|
	
	ann := nil.
	SystemAnnouncer uniqueInstance
		when: MethodRepackaged do: [ :a | ann := a ].
	
	self addXYCategory. 
	firstPackage := self organizer  packageNamed: #XXXXX.
	secondPackage := self organizer  packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.

	self createMethodNamed: 'stubMethod' inClass:  class inCategory: '*yyyyy'.
	
	self assert: ann isNil.

	class organization classify: #stubMethod under: '*yyyyy-suncategory'.

	self assert: ann isNil.! !

!RPackageMCSynchronisationTest methodsFor: 'utilities' stamp: ''!
addXYZCategory

	self addXCategory.
	self addYCategory.
	self addZCategory.
			! !

!RPackageMCSynchronisationTest methodsFor: 'announcer handling' stamp: ''!
restoreAnnouncers
	super restoreAnnouncers.
	MCWorkingCopy announcer: oldAnnouncer.! !

!RPackageMCSynchronisationTest methodsFor: 'private' stamp: ''!
createMethodNamed: methodName inClass: aClass inCategory: aCategoryName 

	^ aClass compile: (methodName, ' ^nil') classified: aCategoryName.! !

!RPackageMCSynchronisationTest methodsFor: 'private' stamp: ''!
createMethodNamed: methodName inClassSideOfClass: aClass inCategory: aCategoryName 

	^ aClass classSide compile: (methodName, ' ^nil') classified: aCategoryName.! !

!RPackageMCSynchronisationTest methodsFor: 'utilities' stamp: ''!
addXMatchCategory
	testingEnvironment organization addCategory: 'XXXXX-YYYY'.! !

!RPackageMCSynchronisationTest methodsFor: 'private' stamp: ''!
createNewTraitNamed: aName inCategory: aCategoryName
	
	| trait |

	trait := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: aName;
			package: aCategoryName;
			beTrait ].								
			
	^ trait! !

!RPackageMCSynchronisationTest methodsFor: 'accessing' stamp: ''!
emptyOrganizer 

	^ emptyOrganizer! !

!RPackageMCSynchronisationTest methodsFor: 'to move to a simple RPackage test case' stamp: ''!
testNotRepackagedAnnouncementWhenMovingClassicCategories

	| ann class firstPackage secondPackage|
	
	ann := nil.
	SystemAnnouncer uniqueInstance
		when: MethodRepackaged do: [ :a | ann := a ].
	
	self addXYCategory. 
	firstPackage := self organizer  packageNamed: #XXXXX.
	secondPackage := self organizer  packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.

	self createMethodNamed: 'stubMethod' inClass:  class inCategory: 'classic'.
	
	self assert: ann isNil.

	class organization classify: #stubMethod under: 'another classic one'.

	self assert: ann isNil.! !

!RPackageMCSynchronisationTest methodsFor: 'to move to a simple RPackage test case' stamp: ''!
testRepackagedAnnouncementWhenModifyMethodByMovingFromClassicCategoryToExtensionCategory
	
	| ann class firstPackage secondPackage|
	
	ann := nil.
	SystemAnnouncer uniqueInstance
		when: MethodRepackaged do: [ :a | ann := a ].
	
	self addXYCategory. 
	firstPackage := self organizer  packageNamed: #XXXXX.
	secondPackage := self organizer  packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass:  class inCategory: 'classic category'.
	
	class organization classify: #stubMethod under: '*yyyyy'.		

	self assert: ann notNil.
	self assert: ann methodRepackaged selector equals: #stubMethod.
	self assert: ann oldPackage equals: firstPackage.
	self assert: ann newPackage equals: secondPackage.
	ann := nil.

	class organization classify: #stubMethod under: '*yyyyy-suncategory'.

	self assert: ann isNil.! !

!RPackageMCSynchronisationTest methodsFor: 'to move to a simple RPackage test case' stamp: ''!
testRepackagedAnnouncementWhenModifyMethodByMovingFromDifferentExtensionCategories

	| ann class firstPackage secondPackage thirdPackage |
	
	ann := nil.
	SystemAnnouncer uniqueInstance
		when: MethodRepackaged do: [ :a | ann := a ].
	
	self addXYZCategory. 
	firstPackage := self organizer  packageNamed: #XXXXX.
	secondPackage := self organizer packageNamed: #YYYYY.
	thirdPackage := self organizer packageNamed: #ZZZZZ.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass:  class inCategory: '*yyyyy'.
	
	class organization classify: #stubMethod under: '*zzzzz'.

	self assert: ann notNil.
	self assert: ann methodRepackaged selector equals: #stubMethod.
	self assert: ann oldPackage equals: secondPackage.
	self assert: ann newPackage equals: thirdPackage.! !

!RPackageMCSynchronisationTest methodsFor: 'tests' stamp: ''!
testCategoryMatching
	
	self assert: (self organizer category: 'Compression-Archives' matches: 'Compression').
	self deny: (self organizer category: 'Compression' matches: 'Compression-Archives').
	self assert: (self organizer category: 'Compression' matches: 'Compression').
	self assert: (self organizer category: 'Compression-Arh' matches: 'Compression').
	self deny: (self organizer category: 'XXXX' matches: 'Compression-Archives').! !

!RPackageMCSynchronisationTest methodsFor: 'private' stamp: ''!
createNewClassNamed: aName
	
	| cls |

	cls := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: aName;
			package: 'RPackageTest' ].

	^ cls! !

!RPackageMCSynchronisationTest methodsFor: 'utilities' stamp: ''!
addYCategory

	testingEnvironment organization addCategory: 'YYYYY'.
			! !

!RPackageMethodsSynchronisationTest commentStamp: ''!
SUnit tests for RPackage method synchronization!
!RPackageMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testAddMethodInClassicCategoryAddMethodToTheParentPackageOfItsClass
	"test that when we add a method to a  class in a classic category (not beginning with *), this method is added to the parent package of the class"
	
	|tmpPackage class|
	self addXCategory.
	
	tmpPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.

	self createMethodNamed: 'stubMethod' inClass:  class inCategory: 'classic category'.

	self assert: (class package includesDefinedSelector: #stubMethod ofClass: class).
	self assert: ((class >> #stubMethod) packageFromOrganizer: self organizer ) equals: class package.! !

!RPackageMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testModifyMethodByMovingFromClassicCategoryToExtensionCategoryMoveItFromClassPackageToExtendingPackage
	"test that when we move a method from a classic category (not begining with *) to an extension category , the method is moved from the parent package of the class to the extending package"

	| class firstPackage secondPackage |
	self addXYCategory.
	firstPackage := self organizer packageNamed: #XXXXX.
	secondPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class inCategory: 'classic category'.

	class organization classify: #stubMethod under: '*yyyyy'.
	self deny: (firstPackage includesDefinedSelector: #stubMethod ofClass: class).
	self assert: (secondPackage includesExtensionSelector: #stubMethod ofClass: class).
	self assert: (class >> #stubMethod packageFromOrganizer: self organizer) equals: secondPackage.

	class organization classify: #stubMethod under: '*yyyyy-subcategory'.
	self deny: (firstPackage includesDefinedSelector: #stubMethod ofClass: class).
	self assert: (secondPackage includesExtensionSelector: #stubMethod ofClass: class).
	self assert: (class >> #stubMethod packageFromOrganizer: self organizer) equals: secondPackage! !

!RPackageMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testModifyMethodByMovingFromExtensionCategoryToExtensionCategoryMoveItFromExtendingPackageToSecondExtendingPackage
	"test that when we move a method from an extension category ( begining with *) to another extending package , the method is moved from the extending package to the other extending package"

	| class XPackage YPackage ZPackage |
	self addXYZCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	ZPackage := self organizer packageNamed: #ZZZZZ.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: #newMethod inClass: class inCategory: '*yyyyy'.

	class organization classify: #newMethod under: '*zzzzz'.
	self deny: (XPackage includesDefinedSelector: #newMethod ofClass: class).
	self deny: (YPackage includesExtensionSelector: #newMethod ofClass: class).
	self assert: (ZPackage includesExtensionSelector: #newMethod ofClass: class).
	self assert: (class >> #newMethod packageFromOrganizer: self organizer) equals: ZPackage! !

!RPackageMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testAddMethodInClassicCategoryAddMethodToTheParentPackageOfItsTrait
	"test that when we add a method to a  trait in a classic category (*not beginning with *), this method is added to the parent package of the class"

	| tmpPackage trait |
	self addXCategory.

	tmpPackage := self organizer packageNamed: #XXXXX.
	trait := self createNewTraitNamed: 'NewClass' inCategory: 'XXXXX'.

	self createMethodNamed: 'stubMethod' inClass: trait inCategory: 'classic category'.

	self assert: (trait package includesDefinedSelector: #stubMethod ofClass: trait).
	self assert: (trait >> #stubMethod packageFromOrganizer: self organizer) equals: trait package! !

!RPackageMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testModifyMethodByMovingFromClassicCategoryToClassicCategoryDoesNothing
	"test that when we move a method from a classic category (not begining with *) to another classic category , the packaging keeps the same"

	| class firstPackage |
	self addXCategory.
	firstPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class inCategory: 'classic category'.

	"this we do"
	class organization classify: #stubMethod under: 'new category'.

	"this we check"
	self assert: (class >> #stubMethod) category equals: 'new category'.
	self assert: (firstPackage includesDefinedSelector: #stubMethod ofClass: class).
	self deny: (firstPackage includesExtensionSelector: #stubMethod ofClass: class).
	self assert: (class >> #stubMethod packageFromOrganizer: self organizer) equals: firstPackage! !

!RPackageMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testModifyMethodByMovingFromExtensionCategoryToClassicCategoryMoveItFromExtendingPackageToClassPackage
	"test that when we move a method from an extension category ( begining with *) to a classic category , the method is moved from the extending package to the parent package of the class"

	| class firstPackage secondPackage |
	self addXYCategory.

	firstPackage := self organizer packageNamed: #XXXXX.
	secondPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class inCategory: '*yyyyy'.

	class organization classify: #stubMethod under: 'classic category'.
	self assert: (firstPackage includesDefinedSelector: #stubMethod ofClass: class).
	self deny: (secondPackage includesExtensionSelector: #stubMethod ofClass: class).
	self assert: (class >> #stubMethod packageFromOrganizer: self organizer) equals: firstPackage! !

!RPackageMethodsSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testRemoveMethodRemoveMethodFromItsPackage
	"test that when we remove a method, the method is remod from the package in which the method is defined"
	
	|XPackage  class|
	self addXCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: 'classic category'. 
	
	class removeSelector: #stubMethod.
	
	self deny: (XPackage includesDefinedSelector: #stubMethod ofClass: class). 
	self deny: (XPackage includesExtensionSelector: #stubMethod ofClass: class). 
	self deny: (XPackage includesSelector: #stubMethod ofClass: class).! !

!RPackageMonticelloSynchronisationTest commentStamp: ''!
SUnit tests for RPackage Monticello synchronization!
!RPackageMonticelloSynchronisationTest methodsFor: 'tests - operations on MCPackages' stamp: ''!
testAddMCPackageForCategoryAlreadyExistingDoesNotCreateAPackage
	"test that when we create a MCPackage and that a category of this name already exists, no package is created"
 
	|tmpPackage|
	testingEnvironment organization addCategory: 'Zork'.
	tmpPackage := self organizer packageNamed: #Zork.
	MCWorkingCopy forPackage: (MCPackage new name: #Zork).
	self assert: tmpPackage equals: (self organizer packageNamed: #Zork).
		
		
					  ! !

!RPackageMonticelloSynchronisationTest methodsFor: 'tests - operations on MCPackages' stamp: ''!
testAddMCPackageCreatesAPackage
	"test that when we create a MCPackage, a corresponding package is created"
	
	MCWorkingCopy forPackage: (MCPackage new name: #Zork).
	self assert: (self organizer includesPackageNamed: #Zork).
		
					  ! !

!RPackageMonticelloSynchronisationTest methodsFor: 'tests - operations on MCPackages' stamp: ''!
testUnloadMCPackageRemovesRPackage
	"test that when we remove a MC Package, the corresponding RPackage is removed from the organizer"

	MCWorkingCopy forPackage: (MCPackage new name: 'XXXXX').
	(self allManagers detect: [:each | each packageName = 'XXXXX']) unload.

	self deny: (self organizer includesPackageNamed: #XXXXX).! !

!RPackageMonticelloSynchronisationTest methodsFor: 'tests - operations on MCPackages' stamp: ''!
testUnregisterMCPackageKeepsRPackage
	"test that when we remove a MC Package, the corresponding RPackage is removed from the organizer"
	
	MCWorkingCopy forPackage: (MCPackage new name: 'XXXXX').
	(self allManagers detect: [:each | each packageName = 'XXXXX']) unregister.
	
	self assert: (self organizer includesPackageNamed: #XXXXX).! !

!RPackageObsoleteTest commentStamp: ''!
SUnit tests for RPackage!
!RPackageObsoleteTest methodsFor: 'accessing' stamp: ''!
setNotRun 
	notRun := true! !

!RPackageObsoleteTest methodsFor: 'tests' stamp: ''!
testMethodPackageFromObsoleteClass
	
	| pack method foo | 
	[
	pack := self createNewPackageNamed: 'P1'.
	foo := self createNewClassNamed: #FooForTest inPackage: pack.
	foo compile: 'bar ^42'.
	method := foo>>#bar.

	foo obsolete.
	self assert: (method packageFromOrganizer: pack organizer) equals: foo package.
	] ensure: [ 
		foo ifNotNil: [ 
			foo setName: foo originalName.
			foo removeFromSystem.
			].
		testingEnvironment removeKey: #FooForTest  ifAbsent:  [].
	]! !

!RPackageObsoleteTest methodsFor: 'tests' stamp: ''!
testMethodPackageOfRemovedClass
	
	| pack method foo | 
	pack := self createNewPackageNamed: 'P1'.
	foo := self createNewClassNamed: #FooForTest2 inPackage: pack.
	foo compileSilently: 'bar ^42'.
	method := foo>>#bar.
	foo removeFromSystem.
	self deny: (pack includesClassNamed: #FooForTest2 )! !

!RPackageObsoleteTest methodsFor: 'tests' stamp: ''!
testAnnouncementClassRemovedIsRaisedOnRemoveFromSystem	
	| foo | 	
	[ notRun := false.
	  SystemAnnouncer uniqueInstance 
		when: ClassRemoved send: #setNotRun to: self.
	foo := self createNewClassNamed: #FooForTest2.
	self deny: notRun.
	foo removeFromSystem.
	self assert: notRun ]
ensure: [ SystemAnnouncer uniqueInstance unsubscribe: self ].! !

!RPackageOrganizer commentStamp: ''!
A RPackageOrganizer is responsible for providing all the package currently defined in the system.
In addition it provides a back pointer from the class to its package.

The classPackageMapping and the classExtendingPackageMapping should be moved in the future to the classes themselves. 


For tests or actions that could destroy the package organizer,  do not access directly the singleton of RPackageOrganizer.
Use instead 
		RPackage withOrganizer: aNewOrganizer do: ablock
			or via RPackage organizer
		
	
RPackageOrganizer fillUp will fill up the system from the current PackageOrganizer
	"self fillUp"
	
-----------------------------------------------------------------------------------------------------------------------------------------------	
	
	
A rpackageOrganizer update itself when some changes are made in the system. It does that by registering to a systemAnnoucer, specifying an action when an annoucement is triggered.
Here is what I (Cyrille Delaunay) propose to do for each annocuement triggered:

SystemCategoryAddedAnnouncement 	
	=> I would just register a new RPackage (if it does not already exist) in the RPackageOrganizer
	
SystemCategoryRemovedAnnouncement 
     => I would just unregister the RPackage concerned from the organizer

SystemCategoryRenamedAnnouncement
     => I would update the RPackage concerned, by changing its name
     => I would update the 'packages' dictionary of the organizer, putting the new name as key

SystemClassAddedAnnouncement 
    => Import the class in the RPackage concerned (RPackage >> importClass:)
    => Register the class in the 'classPackageMapping' dictionary of the organizer (RPackageOrganizer >> registerPackage:forClass)
    (=> maybe we should pay attention if both the class and the metaclass launch this kind of event ?)

SystemClassRecategorizedAnnouncement
    => I would update the old RPackage concerned:
            => unregister the class
            => unregister all defined methods of the class
    => I would update the new RPackage:
            => Import the class in the RPackage (importClass:)
    => I would update the organizer:
            => update the 'classPackageDictionary' to point on the new RPackage

 
SystemClassRemovedAnnouncement
    => I would update the RPackake concerned
             => unregister the class
             => unregister all defined methods of the class
    => I would update the organizer:
             => update the 'classPackageDictionary' to remove the class

SystemClassRenamedAnnouncement
    => I would update the RPackage in which the class is defined:
             => update the 'classDefinedSelectors' dictionary (replace the old key by the new one)
             => update the 'metaclassDefinedSelectors' dictionary (replace the old key by the new one)
    => I would update all RPackages extending this class
             => update the 'classExtensionsSelectors' dictionary (replace the old key by the new one)
             => update the 'metaclassclassExtensionsSelectors' dictionary (replace the old key by the new one)
    => I would update the organizer
             => update the 'classPackageDictionary' to replace the key with the new class name
             => update the 'classExtendingPackagesMapping' to replace the key with the new class name
                          
SystemClassReorganizedAnnouncement 
    (=> I guess we should check if extensions have not been added or removed ? 
      (to retrieve this information, the only thing I found is ClassDescription >> organization, and then check each category begining with '*' and compare with the organizer. seems to be painful, no?))
	=> when an extension is removed, all methods inside are removed. Therefore, the MethodRemovedAnnounecement will do the job. Not sur this one still usefull

SystemProtocolAddedAnnouncement
    => I don't see anything to do for this annoucement

SystemProtocolRemovedAnnoucement
    => If the category is an extension from a package, I would move all the methods concerned, from the extending RPackage to the class RPackage

SystemMethodAddedAnnouncement
       => I would check the category in which the method has been defined
               => if it correspond to an extending package -> add the method to the extending RPackage
               => if not, add the method to the class parentPackage

SystemMethodModifiedAnnouncement
       this annoucement can correspond to several kind of modifications:
	       *  a method has been renamed
                       => I would update the rPackage in which the method is defined to replace the old selector by the new one
		* a method has been move to another category 
			-maybe from a classic category to an extending package
                             => we should move the method from the  method class parentPackage to extendingPackage package
			-maybe from an extending package to another extending package
                             => we should move the method from the  extendingPackage package to the other extendingPackage package
			-maybe from an extending package to a classic category
                             =>  we should move the method from the  extendingPackage to the method class parentPackage
		        -maybe from a classic category to another classic category
                             => we have nothing to do
			

SystemMethodRecategorizedAnnouncement
          same thing than above

SystemMethodRemovedAnnouncement
       => I would simply remove the method from the RPackage in which it is register!
!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
packageForProtocol: aProtocolName inClass: aClass
	"According aProtocolName is an extension protocol, will look for a matching package. If no matching package is found ,  return nil. If aProtocolName is not an extension protocol, return the parent package of aClass"
	
	|tmpProtocol|
	tmpProtocol := aProtocolName ifNil: [''].
	^ (tmpProtocol beginsWith: '*')
		ifTrue: [  (self packageMatchingExtensionName: (tmpProtocol copyWithout: $*)) ]
		ifFalse: [ aClass package ]! !

!RPackageOrganizer methodsFor: '*Monticello-RPackage' stamp: 'nil'!
basicInitializeFromMC

	self basicInitializeFromPackagesList: (self allManagers collect: [ :workingCopy | workingCopy packageName]).! !

!RPackageOrganizer methodsFor: 'initialization - data' stamp: ''!
initializeFor: aBehavior
	| package |
		
	package := self packageMatchingExtensionName: aBehavior category.
	package ifNil: [ 
		"It should not happen. 
		 But actually could happen that one class is in a SystemCategory and not in a MC"
		package := self basicRegisterPackage: (self packageClass named: aBehavior category) ]. 
	package addClassDefinition: aBehavior.
	package 
		addClassDefinition: aBehavior 
		toClassTag: aBehavior category asSymbol.
	self registerPackage: package forClass: aBehavior.! !

!RPackageOrganizer methodsFor: 'package - names-cache' stamp: ''!
packageNames 

	^ packageNames ifNil: [ packageNames := packages keys asSortedCollection ]! !

!RPackageOrganizer methodsFor: 'initialization' stamp: ''!
defineUnpackagedClassesPackage
	^ self ensureExistAndRegisterPackageNamed: self packageClass defaultPackageName! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
packageMatchingExtensionName: anExtensionName

	"return nil if no package is not found"
	| tmpPackageName |
	
	"we first look if their is a package matching exactly the name specified"
	(self packageExactlyMatchingExtensionName: anExtensionName)
		ifNotNil: [ :package | ^ package ].
	
	"if no package was found, we try to find one matching the begining of the name specified"
	tmpPackageName := ''.
	packages keysDo: [:aSymbol |
		(anExtensionName beginsWith: (aSymbol asString, '-') caseSensitive: false)
			ifTrue: [
				"we keep the longest package name found"
				(aSymbol size > tmpPackageName size) 
					ifTrue: [ tmpPackageName := aSymbol ]]].
	
	^ tmpPackageName = ''
		ifTrue: [ nil ] 
		ifFalse: [ self packageNamed: tmpPackageName ]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
hasPackageForProtocol: aProtocolName inClass: aClass
	"According aProtocolName is an extension protocol, will look for a matching package. If no matching package is found ,  return nil. If aProtocolName is not an extension protocol, return the parent package of aClass"
	
	|tmpProtocol|
	tmpProtocol := aProtocolName ifNil: [''].
	^ (tmpProtocol beginsWith: '*') not or: [ self hasPackageMatchingExtensionName:  (tmpProtocol copyWithout: $*) ]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemCategoryRenamedActionFrom: ann
	| rPackage oldName newName |

	oldName := ann oldCategoryName asSymbol.
	newName := ann newCategoryName asSymbol.
	rPackage := self packageMatchingExtensionName: ann oldCategoryName.
	rPackage ifNil: [ rPackage := (self packageClass named: newName) register ].
	rPackage name = ann oldCategoryName ifTrue: [ 
		self 
			renamePackage: rPackage 
			from: oldName 
			to: newName ].
		
	rPackage 
		classTagNamed: oldName
		ifPresent: [ :tag | tag basicRenameTo: newName ]! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
checkPackageExistsOrRegister: packageName
	(self packages 
		anySatisfy: [ :each | self category: packageName matches: each packageName ])
		ifFalse: [ (self packageClass named: packageName capitalized) register ]! !

!RPackageOrganizer methodsFor: 'registration' stamp: ''!
validatePackageDoesNotExist: aPackageName

	(self includesPackageNamed: aPackageName)
		ifTrue: [ self signalPackageExists: aPackageName ]! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
unregisterPackage: aPackage forClassName: aClassName
	"Unregister the package back pointer for a given class. The class should not belong to the package anymore before removing the back pointer."

	(aPackage includesClassNamed: aClassName asSymbol) 
		ifTrue: 
			[self error: aPackage name , ' still includes the class ' , aClassName asSymbol].
	^classPackageMapping removeKey: aClassName asSymbol ifAbsent: [self reportBogusBehaviorOf: #unregisterPackage:forClassName:  ]! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
packageClass
	"Return the system class that represent packages."
	
	^ RPackage! !

!RPackageOrganizer methodsFor: 'registration' stamp: ''!
signalPackageExists: aPackageName

	RPackageConflictError signal: ('A package named {1} already exists' format: {aPackageName})! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemMethodAddedActionFrom: ann
	| method |
	
	"If the method origin is not the one of the event, we do not care about that method"
	
	method := ann method.
	method origin = ann methodClass
		ifFalse: [ ^ self ].
		
	self addMethod: method! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
unregisterPackage: aPackage forClass: aClass 
	"unregister the back pointer mapping from classes to packages."
		
	^classPackageMapping 
		removeKey: aClass instanceSide name 
		ifAbsent: [ self reportExtraRemovalOf: aClass ]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemMethodRemovedActionFrom: ann

	| method methodPackage |
	method := ann method.
	"If the method is provided by a trait, we do not care about it"
	ann isProvidedByATrait ifTrue: [^ self].

	ann methodClass isMeta
		ifFalse: [ 
			methodPackage := self packageDefiningOrExtendingSelector: ann selector inClassNamed: ann methodClass instanceSide originalName.
			methodPackage ifNotNil: [ 
				methodPackage removeSelector: ann selector ofClassName: ann methodClass instanceSide originalName].
		]
		ifTrue: [ 
			methodPackage := self packageDefiningOrExtendingSelector: ann selector inMetaclassNamed: ann methodClass instanceSide originalName.
			methodPackage ifNotNil: [ 
				methodPackage removeSelector: ann selector ofMetaclassName: ann methodClass instanceSide originalName].
		]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemProtocolRemovedActionFrom: ann
	"to be unregistered"! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemClassReorganizedActionFrom: ann
	"when a class is reorganized, we have to check if an extension has not been added"
	| clazz classOrganization |

	clazz := ann classReorganized.
	classOrganization := clazz organization.
	classOrganization categories do: [ :each | 
		(each beginsWith: '*')
			ifTrue:  [ self checkPackageExistsOrRegister: each allButFirst ] ]! !

!RPackageOrganizer methodsFor: 'private - testing' stamp: ''!
debuggingName

	^ debuggingName! !

!RPackageOrganizer methodsFor: 'package - names-cache' stamp: ''!
addPackageNameToCache: aPackageName

	packageNames ifNil: [ ^ self ].
	
	packageNames add: aPackageName! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemClassRemovedActionFrom: ann
	"A class has been removed, we should update the package adequately."
	
	| class className |	
	class := ann classRemoved.
	className  := class originalName.
		
	self fullyRemoveClassNamed: className.! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemProtocolAddedActionFrom: ann

	"for now I don't see anything to do'"! !

!RPackageOrganizer methodsFor: 'registration' stamp: ''!
createPackageNamed: aString 

	| instance |
	self validatePackageDoesNotExist: aString.
	
	instance := self packageClass named: aString.
	self registerPackage: instance.
	^ instance! !

!RPackageOrganizer methodsFor: 'private' stamp: ''!
reportExtraRemovalOf: aClass

	self traceCr: 'The class ', aClass name printString , ' is removed twice'! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
unregisterExtendingPackage: aPackage forClassName: aClassName

	| cur |

	cur := classExtendingPackagesMapping at: aClassName asSymbol ifAbsent: [ nil ].
	cur ifNotNil: [ cur remove: aPackage ifAbsent: [ "not happy with this one" ] ]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
fullyRemoveClassNamed: className
	"Remove the class, the class backpointer, the extensions and the extension backPointer from the receiver and the class involved with the class named: className. className is a class name and should not be a metaclass one. "	
	| rPackage |	
		
	rPackage := self packageOfClassNamed: className.
	rPackage ifNil: [ ^ self ].
	rPackage removeClassNamed: className.
	(self extendingPackagesOfClassNamed: className)
		do: [:each | each removeAllMethodsFromClassNamed: className. ].! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
registerPackage: aPackage forClass: aClass 
	(aPackage includesClass: aClass) 
		ifFalse: 
			[self error: aPackage name , ' does not includes the class ' , aClass name].
	^classPackageMapping at: aClass instanceSide name put: aPackage! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemClassRecategorizedActionFrom: ann
	| class newRPackage newRPackageTag oldRPackage newCategoryName oldCategoryName|
	
	class := ann classAffected.	

	newCategoryName := ann newCategory asSymbol.
	oldCategoryName := ann oldCategory asSymbol.
	oldRPackage := self packageMatchingExtensionName: oldCategoryName includingClass: class.
	newRPackage := (self packageMatchingExtensionName: newCategoryName) 
		ifNil: [ self registerPackage: (self packageClass named: newCategoryName) ].

	newRPackageTag := newRPackage addClassTag: newCategoryName.

	newRPackage 
		moveClass: class 
		fromPackage: oldRPackage 
		toTag: newRPackageTag! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
packages
	
	^ packages values! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
registerExtendingPackage: aPackage forClassName: aClassName

	| cur |

	cur := classExtendingPackagesMapping at: aClassName asSymbol ifAbsent: [ nil ].
	cur
		ifNil: [ classExtendingPackagesMapping at: aClassName asSymbol put: ( Set with: aPackage ) ]
		ifNotNil: [ cur add: aPackage ]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemClassRenamedActionFrom: ann
	"When a class is renamed, we update its package as well as the organizer"
	
	| newName oldName class rPackage extendingRPackages packageName |
	class := ann classAffected.
	packageName := ann category.
	oldName := ann oldName.
	newName := ann newName.
	rPackage := self packageOfClassNamed: oldName.
	extendingRPackages := self extendingPackagesOfClassNamed: oldName.
	
	rPackage updateDefinedClassNamed: oldName withNewName: newName.
	"we have to update all RPackages extending this class"
	extendingRPackages do: [:aRPackage | 
		aRPackage updateExtensionForClassNamed: oldName withNewName: newName].
		
	"we have to update the RPackageOrganizer.
	update the 'classPackageDictionary' to replace the key with the new class name"
	self unregisterPackage: rPackage forClassName: oldName.
	self registerPackage: rPackage forClassName: newName.	
		
	"update the 'classExtendingPackagesMapping' to replace the key with the new class name"
	extendingRPackages do: [:aRPackage |
		self unregisterExtendingPackage: aRPackage forClassName: oldName.
		self registerExtendingPackage:  aRPackage forClassName: newName   
		].
	self flag: #cyrille. "we will see that."
	"maybe we should remove also the key from the extendedPackages dictionary"
	"CD: This is what are doing the lines above I think"! !

!RPackageOrganizer methodsFor: '*Monticello-RPackage' stamp: 'nil'!
updateAfterNewMCPackageUnregistred: anAnnouncement
! !

!RPackageOrganizer methodsFor: 'initialization' stamp: ''!
unregister
	SystemAnnouncer uniqueInstance unsubscribe: self.! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
packageMatchingExtensionName: aString includingClass: aClass
	| package categoryName |
	
	categoryName := aString.
	package := self packageMatchingExtensionName: categoryName.
	[ package includesClass: aClass ] 
		whileFalse: [ 
			(categoryName includes: $-)
				ifFalse: [ self error: 'Class not categorized!!' ].
				
			categoryName := categoryName copyUpToLast: $-.
			package := self packageMatchingExtensionName: categoryName ].
		
	^ package! !

!RPackageOrganizer methodsFor: 'registration' stamp: ''!
unregisterPackage: aPackage
	"Unregister the specified package from the list of registered packages. Raise the announcement RPackageUnregistered."

	self basicUnregisterPackage: aPackage.
	aPackage extendedClasses 
		do: [ :extendedClass | self unregisterExtendingPackage: aPackage forClass: extendedClass].
	aPackage definedClasses 
		do: [ :definedClass | self unregisterPackage: aPackage forClass: definedClass].
	SystemAnnouncer uniqueInstance announce: (RPackageUnregistered to: aPackage).
	
	^ aPackage! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
packageNamed: aSymbol  ifAbsent: errorBlock
	^ packages 
		at: aSymbol asSymbol 
		ifAbsent: errorBlock! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
packageDefiningOrExtendingSelector: aSelector inMetaclassNamed: aClassNameSymbol
	"this implementation is slower
		aClass packages detect: [:each | each includesSelector: aSelector ofClass: aClass ]"
	| classPackage |
	
	classPackage := self packageOfClassNamed: aClassNameSymbol.
	classPackage ifNil: [ ^ nil ].
	(classPackage includesSelector: aSelector ofMetaclassName: aClassNameSymbol)
		ifTrue: [ ^classPackage ].
		
	^(self extendingPackagesOfClassNamed: aClassNameSymbol)
		detect: [ :p | p includesSelector: aSelector ofMetaclassName: aClassNameSymbol ]
		ifNone: [ nil ]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemCategoryRemovedActionFrom: ann
	"When a system category is removed, we may: remove a tag, or remove a rpackage. If we remove a RPackage, unregister the linked MCWorkingCopy. If it is a tag, do nothing? (from what I know of RPackage, the tag should already have disappeared because it would have been empty)."

	| rPackage categoryName categoryNameSymbol managers |
	categoryName := ann categoryName.
	categoryNameSymbol := categoryName asSymbol.
	self flag: #hack.	"for decoupling MC"
	managers := (self respondsTo: #allManagers)
		ifTrue: [ self perform: #allManagers ]
		ifFalse: [ #() ].	
	"Reverse the test. First check that this is the root category of a RPackage. If yes, unregister the RPackage and the corresponding MCWorkingCopy."
	rPackage := packages at: categoryNameSymbol ifAbsent: [ ^ self ].
	"Consider that a rPackage with extension selectors or tags is not empty and shouldn't be removed."
	(rPackage extensionSelectors notEmpty
		or: [ (rPackage classTags reject: [ :tag | tag name = categoryName ]) notEmpty ])
		ifTrue: [ ^ self ].
	self basicUnregisterPackageNamed: categoryNameSymbol.
	(managers detect: [ :each | each packageName = categoryName ] ifNone: [  ])
		ifNotNil: [ :mcWorkingCopy | mcWorkingCopy unregister ]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
renamePackage: rPackage from: oldName to: newName 
	| classesAndProtocolsToRename |
	
	rPackage name: newName. 
	
	"we update the organizer"
	self removePackageNameFromCache: oldName.
	self addPackageNameToCache: newName.
	
	packages 
		at: newName 
		put: rPackage.
	packages 
		removeKey: oldName 
		ifAbsent: [ self reportBogusBehaviorOf:   #systemCategoryRenamedActionFrom: ]. 
	
	"we also rename all the extension protocols in the system with the new name"
	classesAndProtocolsToRename := rPackage extensionMethods asIdentitySet.
	classesAndProtocolsToRename 
		do: [:method | 
			method methodClass organization 
				silentlyRenameCategory: method category 
				toBe: '*', newName ]! !

!RPackageOrganizer methodsFor: 'initialization - data' stamp: ''!
basicInitializeFromPackagesList: aPackagesList

	aPackagesList
		do: [ :packageName | 
		  | package |
		  package := (self packageClass named: packageName).
		  packages at: packageName asSymbol put: package. ]
		displayingProgress: 'Importing monticello packages'.
		
	Smalltalk allClassesAndTraits 
		do: [ :eachBehavior | self initializeFor: eachBehavior ]
		displayingProgress: 'Importing behaviors'.

	Smalltalk allClassesAndTraits 
		do: [ :eachBehavior | 
			self initializeMethodsFor: eachBehavior.
			self initializeMethodsFor: eachBehavior classSide ]
		displayingProgress: 'Importing methods'.

	Smalltalk allClassesAndTraits 
		do: [ :eachBehavior |
			eachBehavior organization extensionProtocols do: [ :eachProtocol | 
				self 
					initializeExtensionsFor: eachBehavior 
					protocol: eachProtocol ].
			eachBehavior classSide organization extensionProtocols do: [ :eachProtocol | 
				self 
					initializeExtensionsFor: eachBehavior classSide 
					protocol: eachProtocol ] ]
		displayingProgress: 'Importing extensions'.
	
	"I reset the cache of names"
	packageNames := nil.! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
packageDefiningOrExtendingSelector: aSelector inClass: aClass
	"this implementation is slower
		aClass packages detect: [:each | each includesSelector: aSelector ofClass: aClass ]"

	
	^ (aClass packages) detect: [:each | each includesSelector: aSelector ofClass: aClass ] ifNone: [
		"if we do not find in the packages of the class, it means that the method is coming from a trait: "
		|tmpTrait|
		tmpTrait := (aClass traitComposition traitProvidingSelector: aSelector).
		(aClass traitComposition traitProvidingSelector: aSelector) packages detect: [:each |
			each includesSelector: aSelector ofClass: tmpTrait.   
			].
		]
	
"	self packages detect: [:each | 
		each includesSelector: aSelector ofClass: aClass ].
"! !

!RPackageOrganizer methodsFor: 'initialization - data' stamp: ''!
initializeMethodsFor: aBehavior
	| package |
	
	package := aBehavior package.  
	(aBehavior organization protocols
		select: [ :each | each isExtensionProtocol not ])
		do: [ :eachProtocol | 
			 (eachProtocol methodSelectors 
				select: [ :eachSelector | (aBehavior >> eachSelector) origin = aBehavior ])
				do: [ :eachSelector | package addMethod: (aBehavior >> eachSelector) ] ]! !

!RPackageOrganizer methodsFor: 'registration' stamp: ''!
registerPackageNamed: aString 
	^ self 
		packageNamed: aString asSymbol
		ifAbsent: [ (self packageClass named: aString asSymbol) register ]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
unregisterInterestToSystemAnnouncement
	"self unregisterInterestToSystemAnnouncement"

	SystemAnnouncer uniqueInstance unsubscribe: self! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
packageExactlyMatchingExtensionName: anExtensionName
	"only look for a package for which the name match 'anExtensionName', making no difference about case. Return nil if no package is found"
	
	| extension |
	extension := anExtensionName asSymbol.
	
	packages keysDo: [:aSymbol |
		(aSymbol sameAs: extension)
			ifTrue: [ ^ self packageNamed: aSymbol ]].

	^ nil! !

!RPackageOrganizer methodsFor: 'private - testing' stamp: ''!
includesPackageBackPointerForClass: aClass

	^ classPackageMapping includesKey: aClass instanceSide name asSymbol! !

!RPackageOrganizer methodsFor: 'testing' stamp: ''!
includesPackageNamed: aSymbol
	"Answer whether the receiver get a package named aSymbol as registered."
	^ packages includesKey:  aSymbol asSymbol! !

!RPackageOrganizer methodsFor: 'package - access from class' stamp: ''!
packageOf: aClass

	^ classPackageMapping 
		at: aClass instanceSide originalName
		ifAbsent: [self packageNamed: self packageClass defaultPackageName]! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
registerExtendingPackage: aPackage forClass: aClass

	| cur |

	cur := classExtendingPackagesMapping at: aClass instanceSide name ifAbsent: [ nil ].
	cur
		ifNil: [ classExtendingPackagesMapping at: aClass instanceSide name put: ( Set with: aPackage ) ]
		ifNotNil: [ cur add: aPackage ]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
registerInterestToSystemAnnouncement
	"self registerInterestToSystemAnnouncement"
	<systemEventRegistration>
	
	self registerInterestToAnnouncer: self announcer! !

!RPackageOrganizer methodsFor: 'private' stamp: ''!
stopNotification
	"(self instVarNamed: #default) stopNotification"
	
	"pay attention that we can break the system using this method"
	
	SystemAnnouncer uniqueInstance unsubscribe: self.
	
	self class environment at: #MCWorkingCopy ifPresent: [:wc | 
		wc removeDependent: self].! !

!RPackageOrganizer methodsFor: 'private' stamp: ''!
addMethod: method
	"we have to register the method in the parent RPackage of the class. 
	to do that, we first have to look if the method is an extension from an external package:"

	| rPackage protocol |
	
	protocol := method protocol ifNil: [ Error signal: 'Should not happen' ].
	
	"If the class is not packaged yet, ignore the situation. This method is created during the creation of the class or on an anonymous class"
	(method methodClass package name = RPackage defaultPackageName) ifTrue: [ ^ self ].
	
	rPackage := (self hasPackageForProtocol: protocol inClass: method methodClass)
		ifTrue: [ self packageForProtocol: protocol inClass: method methodClass ]
		ifFalse: [ self registerPackage: (self packageClass named: (protocol copyWithout: $*)) ].
		
	rPackage addMethod: method! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
testPackageNames
	
	^ packages keys select: [:nameSymbol | (self packageNamed: nameSymbol) isTestPackage]! !

!RPackageOrganizer methodsFor: 'package - access from class' stamp: ''!
extendingPackagesOfClassNamed: aName
	"Returns the packages extending the class named a Symbol"
	^ classExtendingPackagesMapping at: aName asSymbol ifAbsent: [#()]! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
basicRegisterPackage: aPackage
	"A new package is now available and declared in the receiver. Note that it is a low level implementation method since it does not deal with package contained information and does not update the related mapping tables."
	
	packages 
		at: aPackage name asSymbol 
		put: aPackage.

	"register mc package"
	self flag: #hack. "for decoupling MC"
	self class environment at: #MCWorkingCopy ifPresent: [ :wc |
		wc forPackage: ((self class environment at: #MCPackage) named: aPackage name)].
	
	self addPackageNameToCache: aPackage name asSymbol.
	
	^ aPackage! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
packageNamed: aSymbol
	^ self 
		packageNamed: aSymbol 
		ifAbsent: [ KeyNotFound signalFor: aSymbol ]! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
packagesDo: aBlock
	
	packages valuesDo: aBlock! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
basicUnregisterPackageNamed: aSymbolName
	"Unregister the specified package from the list of registered packages. Raise the RPackageUnregistered announcement. This is a low level action. It does not unregister the back pointer from classes to packages or any other information managed by the organizer"
	
	packages
		removeKey: aSymbolName asSymbol
		ifAbsent: [ ].
	
	self removePackageNameFromCache: aSymbolName asSymbol! !

!RPackageOrganizer methodsFor: 'initialization - data' stamp: ''!
initializeFromPackagesList: aPackagesList
 	self packageClass 
		withOrganizer: self  
		do:  [  self basicInitializeFromPackagesList: aPackagesList ].! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
unregisterExtendingPackage: aPackage forClass: aClass
	| extendingPackageForClass |
	
	extendingPackageForClass := classExtendingPackagesMapping 
		at: aClass instanceSide name 
		ifAbsent: [ nil ].
	extendingPackageForClass ifNotNil: [ 
		extendingPackageForClass 
			remove: aPackage 
			ifAbsent: [] "not happy with this one" ]! !

!RPackageOrganizer methodsFor: '*Monticello-RPackage' stamp: 'nil'!
updateAfterNewMCPackageRegistred: anAnnouncement
	"User create a new package, MCWorkingCopy propagates changes. We react accordingly."
	|  name |
	
	name := anAnnouncement package name.
	(self packageExactlyMatchingExtensionName: name) 
		ifNil: [ self ensureExistAndRegisterPackageNamed: name ]! !

!RPackageOrganizer methodsFor: 'private' stamp: ''!
validateCanBeAddedPackage: aPackage
	self validateCanBeAddedPackageName: aPackage name tagName: nil! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
hasPackageExactlyMatchingExtensionName: anExtensionName
	| extension |
	extension := anExtensionName asSymbol.
	"fast version"
	(self includesPackageNamed: extension)
		ifTrue: [  ^ true ].
		
	"slow version ignoring case"
	packages keysDo: [ :aSymbol | 
		(aSymbol sameAs: extension)
			ifTrue: [ ^ true]].
	^ false! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
packageDefiningOrExtendingMethod: aCompiledMethod
	^ self packageDefiningOrExtendingSelector: aCompiledMethod selector inClass: aCompiledMethod methodClass! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
packageDefiningOrExtendingSelector: aSelector inClassNamed: aClassNameSymbol
	"this implementation is slower
		aClass packages detect: [:each | each includesSelector: aSelector ofClass: aClass ]"
	| classPackage |
	
	classPackage := self packageOfClassNamed: aClassNameSymbol.
	classPackage ifNil: [ ^ nil ].
	(classPackage includesSelector: aSelector ofClassName: aClassNameSymbol)
		ifTrue: [ ^classPackage ].
		
	^(self extendingPackagesOfClassNamed: aClassNameSymbol)
		detect: [ :p | p includesSelector: aSelector ofClassName: aClassNameSymbol ]
		ifNone: [ nil ]! !

!RPackageOrganizer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	packages := IdentityDictionary new.
	classPackageMapping := IdentityDictionary new.
	classExtendingPackagesMapping := IdentityDictionary new.
	debuggingName := ''.
	
	self defineUnpackagedClassesPackage! !

!RPackageOrganizer methodsFor: 'private - testing' stamp: ''!
debuggingName: aString

	debuggingName := aString! !

!RPackageOrganizer methodsFor: 'registration' stamp: ''!
unregisterPackageNamed: symbol
	"Unregister the specified package from the list of registered packages. Raise the announcement RPackageUnregistered."
	
	| aPackage |
	aPackage := packages at: symbol asSymbol ifAbsent: [ nil].
	aPackage 
		ifNotNil: [self unregisterPackage: aPackage].
	^ aPackage! !

!RPackageOrganizer methodsFor: 'initialization - data' stamp: ''!
initializeExtensionsFor: aBehavior protocol: aProtocol
	| package protocolName nonTraitMethods |
	
	protocolName := (aProtocol name allButFirst) trimBoth.
	package := self packageMatchingExtensionName: protocolName.
	package ifNil: [
		package := self basicRegisterPackage: (self packageClass named: protocolName) ].
	nonTraitMethods := aProtocol methodSelectors 
		select: [ :eachSelector | (aBehavior >> eachSelector) origin = aBehavior ].
	nonTraitMethods ifEmpty:[^ self].
	self registerExtendingPackage: package forClass: aBehavior.
	nonTraitMethods
		do: [ :eachSelector | package addMethod: aBehavior >> eachSelector ]! !

!RPackageOrganizer methodsFor: 'system compatibility' stamp: ''!
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 ]) = $-! !

!RPackageOrganizer methodsFor: 'private' stamp: ''!
reportBogusBehaviorOf: aSelector

	self traceCr: 'RPackage log: Something wrong around ', aSelector asString , 'since the removeKey: is called on not present information.'.! !

!RPackageOrganizer methodsFor: 'testing' stamp: ''!
includesPackage: aPackage
	"Answer whether the receiver get a package as registered."
	^ self includesPackageNamed: aPackage name! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemCategoryAddedActionFrom: ann
	| package |
	
	package := self packageMatchingExtensionName: ann categoryName asString.
	package ifNil: [ 
		package := self registerPackage: (self packageClass named: ann categoryName asSymbol) ].
	package addClassTag: ann categoryName asSymbol.! !

!RPackageOrganizer methodsFor: 'private' stamp: ''!
validateCanBeAddedPackageName: packageName tagName: tagName 
	| package |
	
	package := self 
		packageNamed: packageName
		ifAbsent: [ 
			(packageName includes: $-) ifFalse: [ ^ self ].
			 
			^ self 
				validateCanBeAddedPackageName: (packageName copyUpToLast: $-)
				tagName: ((packageName copyAfterLast: $-), (tagName 
					ifNotNil: [ '-', tagName ]
					ifNil: [ '' ] )) ].
		
	(tagName isEmptyOrNil or: [ package includesClassTagNamed: tagName ])
		ifTrue: [ 
			RPackageConflictError signal: ('Package/Tag can not be added because it conflicts with package {1} tag {2}' format: { packageName. tagName })  ]! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
ensureExistAndRegisterPackageNamed: aSymbol
	"A new package is now available and declared in the receiver."
	
	| package |
	
	package := packages 
		at: aSymbol asSymbol 
		ifAbsentPut: [ 
			"I add the package to the packageName cache"
			self addPackageNameToCache: aSymbol asSymbol.
			self packageClass named: aSymbol ].
		
	package extendedClasses do: [ :extendedClass|
			self registerExtendingPackage: package forClass: extendedClass].
	package definedClasses do: [ :definedClass|
			self registerPackage: package forClass: definedClass].
	
	SystemAnnouncer uniqueInstance announce: (RPackageRegistered to: package).
	
	^ package! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
hasPackageMatchingExtensionName: anExtensionName

	(self hasPackageExactlyMatchingExtensionName: anExtensionName)
		ifTrue: [ ^true ].
		
	packages keysDo: [ :aSymbol | 
		(anExtensionName beginsWith: aSymbol asString, '-' caseSensitive: false)
			ifTrue: [ ^ true]].
	^ false! !

!RPackageOrganizer methodsFor: 'package - names-cache' stamp: ''!
removePackageNameFromCache: aPackageName

	packageNames ifNil: [ ^ self ].	
	packageNames remove: aPackageName ifAbsent: [  ]! !

!RPackageOrganizer methodsFor: 'package - access from class' stamp: ''!
packageOfClassNamed: aName

	self flag: #pharoFixMe. "Should probably return _UnunpackagedPackage instead of nil"
	^ classPackageMapping at: aName asSymbol ifAbsent: [nil]! !

!RPackageOrganizer methodsFor: '*Monticello-RPackage' stamp: 'nil'!
allManagers

	^ self class allManagers ! !

!RPackageOrganizer methodsFor: 'package - access from class' stamp: ''!
extendingPackagesOf: aClass
	"Returns the packages extending the class aClass"
	^ classExtendingPackagesMapping at: aClass instanceSide name ifAbsent: [#()]! !

!RPackageOrganizer methodsFor: 'registration' stamp: ''!
registerPackage: aPackage
	"A new package is now available and declared in the receiver. "
	
	self validateCanBeAddedPackage: aPackage.
	
	self basicRegisterPackage: aPackage.
	aPackage extendedClasses 
		do: [ :extendedClass | self registerExtendingPackage: aPackage forClass: extendedClass].
	aPackage definedClasses 
		do: [ :definedClass | self registerPackage: aPackage forClass: definedClass].
		
	SystemAnnouncer uniqueInstance announce: (RPackageRegistered to: aPackage).
	
	^ aPackage! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemMethodRecategorizedActionFrom: ann
	"a protocol has been renamed
	a method has been removed. // WILL BE TREATED WITH SystemMethodRemovedAnnouncement
	a method has been moved to another category 
		-maybe from the classic category to an extending package
		-maybe from an extending package to another extending package
		-maybe from an extending package to a classic category
		- maybe from a classic category to another classic category.
	Get out of here if my organizer has no package for the class!! (Anonymous classes)"
		
	| oldProtocol newProtocol method methodPackage destinationPackage |

	method := ann method.
	method ifNil: [ ^ self ].
	method origin = ann methodClass ifFalse: [ ^ self].
	(self packageOfClassNamed: ann methodClass instanceSide name) ifNil: [ ^ self ].

	newProtocol := ann  newProtocol.
	newProtocol ifNil: [ ^ self ].

	oldProtocol := ann oldProtocol ifNil: [ '' ].
	
	methodPackage := method packageFromOrganizer: self.
	newProtocol asLowercase = oldProtocol asLowercase ifTrue: [ ^ self ].
		
	destinationPackage := (self hasPackageForProtocol: newProtocol inClass: method methodClass)
		ifTrue: [ 
			self packageForProtocol: newProtocol inClass: method methodClass ]
		ifFalse: [ 
			(newProtocol beginsWith: '*')
				ifTrue: [ self ensureExistAndRegisterPackageNamed: newProtocol allButFirst capitalized ]
				ifFalse: [ method methodClass package ] ].
			
	methodPackage := (self hasPackageForProtocol: oldProtocol inClass: method methodClass)
		ifTrue: [ self packageForProtocol: oldProtocol inClass: method methodClass ]
		ifFalse: [ method methodClass package ].

	methodPackage = destinationPackage
		ifFalse: [
			(methodPackage methods includes: method) 
				ifTrue: [ methodPackage removeMethod: method ].
			
			destinationPackage addMethod: method.
			
			SystemAnnouncer uniqueInstance
				methodRepackaged: method
				from: methodPackage
				to: destinationPackage ]! !

!RPackageOrganizer methodsFor: 'private' stamp: ''!
packageNamedIgnoreCase: aSymbol ifAbsent: aBlock
	"In case of extensions, I can need to take a package ignoring name"
	self packagesDo: [  :each | 
		(each name sameAs: aSymbol) 
			ifTrue: [  ^ each  ]  ].
		
	^ aBlock value.! !

!RPackageOrganizer methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	debuggingName ifNotNil: [aStream nextPutAll: debuggingName ].! !

!RPackageOrganizer methodsFor: '*Monticello-RPackage' stamp: 'nil'!
isDefinedAsPackageOrSubPackageInMC: aSymbol
	"a category has been added. "
	
	^ self allManagers anySatisfy: [ :each | 
		self 
			category: each packageName asSymbol 
			matches: aSymbol ]! !

!RPackageOrganizer methodsFor: '*Monticello-RPackage' stamp: 'nil'!
initializeFromMC
 	self packageClass 
		withOrganizer: self  
		do:  [  self basicInitializeFromMC ].
! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemMethodModifiedActionFrom: ann

	"this announcement can correspond to several kind of modifications:
		=> a method has been renamed
		=> a method has been move to another category // SHOULD BE TREATED WITH SystemMethodRecategorizedEvent
		(
			-maybe from the classic category to an extending package
			-maybe from an extending package to another extending package
			-maybe from an extending package to a classic category
			- maybe from a classic category to another classic category
			)
	"
	| oldMethod newMethod methodPackage |
	newMethod := ann newMethod.
	oldMethod := ann oldMethod.
	self flag: #cyrille. 
	"This is not clear that we need to do soemthing here since the method is removed and added so the other events should be handled correctly
	We should remove this method to see if this is working."
	
	"If the method origin is not the one of the event, we do not care about that method"
	newMethod origin = ann methodClass ifFalse: [^ self].
	
	
	"Special case for trait methods added an override"
	newMethod origin = oldMethod origin
		ifFalse: [ ^ self addMethod: newMethod ].
	
	methodPackage := newMethod packageFromOrganizer: self.
	"maybe the name of the method has changed"
	oldMethod selector = newMethod selector
		ifFalse: [ methodPackage updateSelector: oldMethod selector inClass: oldMethod methodClass withNewSelector: newMethod selector].! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
basicUnregisterPackage: aPackage
	"Unregister the specified package from the list of registered packages. Raise the announcement RPackageUnregistered. This is a low level action. It does not unregister the back pointer from classes to packages or any other information managed by the organizer"
	
	packages
		removeKey: aPackage name asSymbol
		ifAbsent: [ self reportExtraRemovalOf: aPackage ].

	"unregister also mc package"
	self flag: #hack. "for decoupling MC"
	self class environment at: #MCWorkingCopy ifPresent: [ 
		aPackage mcPackage 
			ifNotNil: [ :mcPackage | mcPackage workingCopy unregister ]].
		
	self removePackageNameFromCache: aPackage name asSymbol! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
announcer 
	^SystemAnnouncer uniqueInstance private! !

!RPackageOrganizer methodsFor: 'package - names-cache' stamp: ''!
packageNamesDo: aBlock

	^ self packageNames do: aBlock! !

!RPackageOrganizer methodsFor: 'accessing' stamp: ''!
testPackages
	
	^ packages values select: #isTestPackage! !

!RPackageOrganizer methodsFor: 'private - registration' stamp: ''!
registerPackage: aPackage forClassName: aClassNameSymbol
	"Register aPackage as the package of the class aClassNameSymbol. The package should contain the class in its class definitions."
	
	(aPackage includesClassNamed: aClassNameSymbol asSymbol) 
		ifFalse: 
			[self error: aPackage name , ' does not include the class ' , aClassNameSymbol].
	^classPackageMapping at: aClassNameSymbol put: aPackage! !

!RPackageOrganizer methodsFor: 'initialization' stamp: ''!
register

	"self registerInterestToMC."
	self registerInterestToSystemAnnouncement.! !

!RPackageOrganizer methodsFor: 'testing' stamp: ''!
hasRegistered
	"return true if this package organizer has already registered interest to system events and Monticello changes "
	
	^ self announcer hasSubscriber: self
	
	"|actionSequence|
	self announcer subscriptions ifNil: [^ true].
	actionSequence := self announcer subscriptions values 
								detect: [:each | each anySatisfy: [:anAction | anAction receiver = RPackage organizer]] ifNone: [nil].
	self flag: #cyril.
	^ (actionSequence isNil not) and: [(MCWorkingCopy myDependents includes: self)]"! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
systemClassAddedActionFrom: ann
	| class rPackage categoryNameSymbol |
	
	class := ann classAffected.

	categoryNameSymbol := class category.
	rPackage := (self packageMatchingExtensionName: categoryNameSymbol) 
		ifNil: [ self registerPackage: (self packageClass named: categoryNameSymbol) ].		
	
	rPackage importClass: class.! !

!RPackageOrganizer methodsFor: 'package - access from class' stamp: ''!
globalPackageOf: aClass
	"this method should return the 'global' parent package of aClass, that means the package holding the (possible) subcategory in which aClass is concretely defined. For example, 'Object package' returns Kernel-Object, whereas 'PackageOrganizer packageOf: Object' returns Kernel. So I guess that all use of 'packageOf' should be replaced by this method  "

	"RPackageOrganizer default globalPackageOf: Object"

	| classPackage |
	classPackage := self packageOf: aClass.
	^ self packages
		detect: [ :aRPackage | aRPackage ~= classPackage and: [ aRPackage systemCategories includes: classPackage name ] ]
		ifNone: [ classPackage ]! !

!RPackageOrganizer methodsFor: 'system integration' stamp: ''!
registerInterestToAnnouncer: anAnnouncer	
	"There should be only one"
	anAnnouncer unsubscribe: self.
	
	anAnnouncer weak
		when: CategoryAdded send: #systemCategoryAddedActionFrom: to: self;
		when: CategoryRemoved send: #systemCategoryRemovedActionFrom: to: self;
		when: CategoryRenamed send: #systemCategoryRenamedActionFrom: to: self;
		when:  ClassAdded send: #systemClassAddedActionFrom: to: self;
		when:  ClassRecategorized send: #systemClassRecategorizedActionFrom: to: self;
		when:  ClassRemoved send: #systemClassRemovedActionFrom: to: self;
		when:  ClassRenamed send: #systemClassRenamedActionFrom: to: self;
		when:  ClassReorganized send: #systemClassReorganizedActionFrom: to: self;
		when:  MethodAdded send: #systemMethodAddedActionFrom: to: self;
		when:  MethodModified send: #systemMethodModifiedActionFrom: to: self;
		when:  MethodRecategorized send: #systemMethodRecategorizedActionFrom: to: self;
		when:  MethodRemoved send: #systemMethodRemovedActionFrom: to: self;
		when:  ProtocolAdded send: #systemProtocolAddedActionFrom: to: self;
		when:  ProtocolRemoved send: #systemProtocolRemovedActionFrom: to: self.
		
	self flag: #hack. "for decoupling MC"
	self class environment at: #MCWorkingCopy ifPresent: [ 
		anAnnouncer weak
			when: (self class environment at: #MCWorkingCopyCreated) 
				send: #updateAfterNewMCPackageRegistred: 
				to: self;
			when: (self class environment at: #MCWorkingCopyDeleted) 
				send: #updateAfterNewMCPackageUnregistred: 
				to: self	].! !

!RPackageOrganizer methodsFor: 'private' stamp: ''!
validateCanBeAddedPackage: aPackage tagName: aSymbol
	aPackage name = aSymbol
		ifTrue: [ ^ self ].
	self
		validateCanBeAddedPackageName: aPackage name , '-' , aSymbol
		tagName: nil! !

!RPackageOrganizer class methodsFor: '*Monticello-RPackage' stamp: 'nil'!
allManagers

	^ MCWorkingCopy allManagers! !

!RPackageOrganizer class methodsFor: 'class initialization' stamp: ''!
initialize
	"You need manually filll the data: 
	
	self initializeDefaultFromMC.
	
	is the usual way (but is not in this package by default, it depends on MC)"! !

!RPackageOrganizer class methodsFor: 'private' stamp: ''!
packageClass

	^ RPackage! !

!RPackageOrganizer class methodsFor: 'quieries' stamp: ''!
isPackageDefinedForClass: aClass

	^ (self default packageOf: aClass) notNil! !

!RPackageOrganizer class methodsFor: '*Monticello-RPackage' stamp: 'nil'!
initializeDefaultFromMC

	"self initializeDefaultFromMC"
	self setDefault:  self new initializeFromMC.! !

!RPackageOrganizer class methodsFor: 'private' stamp: ''!
methodAdded: anEvent
	"precondition: package exist, class exist"
	
	| methodCategory |
	methodCategory := anEvent protocol.
	(methodCategory isEmptyOrNil or:[ methodCategory first ~= $* ]) 
		ifFalse: [
			(self isPackageDefinedForClass: anEvent methodClass)
					ifFalse: [self packageClass new named: (Smalltalk organization categoryOfElement: anEvent methodClass instanceSide asSymbol) ].
		].! !

!RPackageOrganizer class methodsFor: 'class initialization' stamp: ''!
unregisterInterestToSystemAnnouncement

	self default unregisterInterestToSystemAnnouncement! !

!RPackageOrganizer class methodsFor: 'singleton' stamp: ''!
default
	"WARNING: Since this component can be changed (i.e. for testing) you should NOT use it directly. 
	  Use RPackage class>>#organizer instead"
	
	^ default ifNil: [  default := self new ]! !

!RPackageOrganizer class methodsFor: 'singleton' stamp: ''!
resetDefault

	"self resetDefault"
	default  ifNotNil: [
		"When an Organizer is not used anymore, we should always pay attention that these two actions are corretly done."
		default unregisterInterestToSystemAnnouncement.
		
		self flag: #hack. "for decoupling MC"
		self class environment at: #MCWorkingCopy ifPresent: [ :wc |
			wc removeDependent: default]].
	default := self new.
	self packageClass initialize! !

!RPackageOrganizer class methodsFor: 'class initialization' stamp: ''!
registerInterestToSystemAnnouncement

	self default unregisterInterestToSystemAnnouncement.
	"To make sure that we do not have it twice registered"
	self default registerInterestToSystemAnnouncement! !

!RPackageOrganizer class methodsFor: 'private' stamp: ''!
setDefault: anOrganizer 
	default ifNotNil: [ default unregister ].
	default := anOrganizer.
	default register.
	RPackage organizer: nil.! !

!RPackageOrganizerTest commentStamp: ''!
RPackageOrganizerTest tests the behavior of PackageOrganizer. 
Note that it does not rely on announcement to be emitted to maintain invariants.
Therefore the new created PackageOrganizer is not registered to listen to event.

!
!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testRegisterPackageConflictWithPackage

	| package1 package2 |
	package1 := self createNewPackageNamed: 'P1'.
	package1 register.
	
	package2 := self packageClass named: 'P1'.
	self 
		should: [ package2 register ]
		raise: Error! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testUnregisterBasedOnNames
	| p1 p2 p3 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.

	self packageOrganizer basicRegisterPackage: p1.
	self packageOrganizer basicRegisterPackage: p2.
	self packageOrganizer basicRegisterPackage: p3.
	self assert: self packageOrganizer packageNames size equals: 4.

	{p1 . p2 . p3} do: [:each | 
		(self packageOrganizer basicUnregisterPackageNamed: each name).
		self deny:  (self packageOrganizer packageNames includes: each name)]! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testFullRegistration	

	| p1 p2 p3 a1 a2 b1 b2 a3 |
	"taken from setup of RPackageReadOnlyCompleteSetup"
	
	p1 := self createNewPackageNamed: self p1Name.
	p2 := self createNewPackageNamed: self p2Name.
	p3 := self createNewPackageNamed: self p3Name.
	
	a1 :=  self createNewClassNamed: #A1DefinedInP1 inPackage: p1.
	b1 := self createNewClassNamed: #B1DefinedInP1 inPackage: p1.
	a2 := self createNewClassNamed: #A2DefinedInP2 inPackage: p2.
	b2 := self createNewClassNamed: #B2DefinedInP2 inPackage: p2.
	a3 := self createNewClassNamed: #A3DefinedInP3 inPackage: p3.
	
	a1 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a1>>#methodDefinedInP1).
	a1 compileSilently: 'anotherMethodDefinedInP1 ^ #anotherMethodDefinedInP1'.
	p1 addMethod: (a1>>#anotherMethodDefinedInP1).
	
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	
	a2 compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addMethod: (a2>>#methodDefinedInP2).
	
	a2 compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addMethod: (a2>>#methodDefinedInP3).

	a2 class compileSilently: 'classSideMethodDefinedInP3 ^ #classSideMethodDefinedInP3'.
	p3 addMethod: (a2 class>>#classSideMethodDefinedInP3).
	

	self packageOrganizer registerPackage: p1.
	self packageOrganizer registerPackage: p2.
	self packageOrganizer registerPackage: p3.
	
	self deny: (p2 includesClass: b1).
	self assert: (p2 includesClass: b2).
	"a locally defined class not extended by other packages"
	
	self assert: (p2 includesClass: a2).  
	"a locally defined class extended by other packages"
	
	self assert: (p1 definesOrExtendsClass: a2).
	self deny: (p1 includesClass: a2).! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testExtensionMethodNotExactlyTheName
	| p1 p2 c1 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.

	self packageOrganizer basicRegisterPackage: p1.
	self packageOrganizer basicRegisterPackage: p2.

	c1 := self createNewClassNamed: #C1 inPackage: p2.
	
	c1 compileSilently: 'methodPackagedInP1 ^ #methodPackagedInP1' classified: '*p1-something'.
	packageOrganizer addMethod: (c1 >> #methodPackagedInP1).

	self deny: (packageOrganizer includesPackageNamed: #'p1-something').
	self assert: (p1 extendedClasses includes: c1)! !

!RPackageOrganizerTest methodsFor: 'tests - extending' stamp: ''!
stringCharacterInCollPackage
	| p |
	p := self packageClass named: #CollPackage.
	p addClassDefinition: String.
	p addClassDefinition: Character.
	p addMethod: String>>#indexOf:.
	p addMethod: String>>#isAllDigits.
	p addMethod: String class>>#cr.
	p addMethod: Character>>#asInteger.
	p addMethod: Text>>#allBold.
	^ p! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testAccessingPackage	

	| p1 |
	p1 := self createNewPackageNamed: 'P1'.
	self packageOrganizer registerPackage: p1.
	p1 addClassDefinition: Point.
	p1 addMethod: Point>>#x.
	p1 addMethod: Point class>>#x:y:. 
	self assert: (self packageOrganizer packageNamed: #P1) equals: p1.
	self should: [(self packageOrganizer packageNamed: #P22)] raise: Error! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testEmpty
	
	self assert: self packageOrganizer packageNames size equals: 1.
	self assert: (self packageOrganizer packageNames includes: self packageClass defaultPackageName)! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testCreateNewPackageWithoutConflictCreatesPackage

	packageOrganizer createPackageNamed: 'P1'.
	self assert: (packageOrganizer includesPackageNamed: 'P1')! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
p1Name
	^ 'RPackageTestP1'! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testTestPackageNames

	| packages |
	packages := self createMockTestPackages.
	packages do: [:aPackage | self packageOrganizer registerPackage: aPackage].
	
	"Only 2 mock package names are test packages:  'MockPackage-Tests' 'MockPackage-Tests-Package'"
	self assert: self packageOrganizer testPackageNames size equals: 2.
	
	"Names of test packages are symbols."
	self assert: (self packageOrganizer testPackageNames allSatisfy: #isSymbol) equals: true.! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testTestPackages

	| packages |
	packages := self createMockTestPackages.
	packages do: [:aPackage | self packageOrganizer registerPackage: aPackage].
	
	"Only 2 mock packages are test packages:  'MockPackage-Tests' 'MockPackage-Tests-Package'."
	self assert: self packageOrganizer testPackages size equals: 2.
	
	"all items from resulting collection are test packages."
	self assert: (self packageOrganizer testPackages allSatisfy: #isTestPackage) equals: true.! !

!RPackageOrganizerTest methodsFor: 'tests - extending' stamp: ''!
pointRectangleInGraphElement 
	| p |
	p := self packageClass named: #GraphElement.
	p addClassDefinition: Point.
	p addMethod: Point>>#x.
	p addMethod: Point>>#rotateBy:about:. 
	p addClassDefinition: Rectangle.
	p addMethod: self quadrangleClass >>#intersect:.
	^ p! !

!RPackageOrganizerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	createdClasses := OrderedCollection new.
	createdPackages := OrderedCollection new.
	packageOrganizer := self packageOrganizerClass basicNew initialize.
	packageOrganizer debuggingName: 'For PackageOrganizerTest'.
	previousAuthor := Author fullName ifNil: [Author fullName: 'RPackage'].
	
	self createNewClassNamed: 'QuadrangleForTesting' inCategory: self class category.
	self quadrangleClass compileSilently: 'intersect:aPoint ^ false'.! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testFullUnregistration

	| p1 p2 p3 a1 a2 b1 b2 a3 |
	"taken from setup of RPackageReadOnlyCompleteSetup"
	
	p1 := self createNewPackageNamed: self p1Name.
	p2 := self createNewPackageNamed: self p2Name.
	p3 := self createNewPackageNamed: self p3Name.
	
	a1 :=  self createNewClassNamed: #A1DefinedInP1 inPackage: p1.
	b1 := self createNewClassNamed: #B1DefinedInP1 inPackage: p1.
	a2 := self createNewClassNamed: #A2DefinedInP2 inPackage: p2.
	b2 := self createNewClassNamed: #B2DefinedInP2 inPackage: p2.
	a3 := self createNewClassNamed: #A3DefinedInP3 inPackage: p3.
	
	a1 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a1>>#methodDefinedInP1).
	a1 compileSilently: 'anotherMethodDefinedInP1 ^ #anotherMethodDefinedInP1'.
	p1 addMethod: (a1>>#anotherMethodDefinedInP1).
	
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	
	a2 compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addMethod: (a2>>#methodDefinedInP2).
	
	a2 compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addMethod: (a2>>#methodDefinedInP3).

	a2 class compileSilently: 'classSideMethodDefinedInP3 ^ #classSideMethodDefinedInP3'.
	p3 addMethod: (a2 class>>#classSideMethodDefinedInP3).
	

	self packageOrganizer registerPackage: p1.
	self packageOrganizer registerPackage: p2.
	self packageOrganizer registerPackage: p3.
	
	self packageOrganizer unregisterPackage: p1.
	self packageOrganizer unregisterPackage: p2.
	self packageOrganizer unregisterPackage: p3.
	

	self deny: (self packageOrganizer includesPackageBackPointerForClass: a1).
	self deny: (self packageOrganizer includesPackageBackPointerForClass: a2).
	self deny: (self packageOrganizer includesPackageBackPointerForClass: b1).
	self deny: (self packageOrganizer includesPackageBackPointerForClass: b2).
	self deny: (self packageOrganizer includesPackageBackPointerForClass: a3).! !

!RPackageOrganizerTest methodsFor: 'utilities' stamp: ''!
packageOrganizer

	^ packageOrganizer! !

!RPackageOrganizerTest methodsFor: 'running' stamp: ''!
tearDown 
	
	Author fullName: previousAuthor.
	
	(createdClasses reject: [:c| c isObsolete])
		do: [:cls| 
				"(self packageClass organizer includesClass: cls)
					ifTrue: [self packageOrganizer unregisterClass: cls.]."
				cls removeFromSystem ].
	"createdPackages do:
		[:each | self packageOrganizer unregisterPackage: each]"
	super tearDown! !

!RPackageOrganizerTest methodsFor: 'tests - extending' stamp: ''!
testUnregistrationExtendingPackages
	| p |
	p := self pointRectangleInGraphElement.
	self packageOrganizer registerExtendingPackage: p forClass: self quadrangleClass.
	self denyEmpty: (self packageOrganizer extendingPackagesOf: self quadrangleClass).
	self assert: (self packageOrganizer extendingPackagesOf: self quadrangleClass) anyOne name equals: #GraphElement.
	self packageOrganizer unregisterExtendingPackage: p forClass: self quadrangleClass.
	self assertEmpty: (self packageOrganizer extendingPackagesOf: self quadrangleClass)! !

!RPackageOrganizerTest methodsFor: 'tests - extending' stamp: ''!
testRegistrationExtendingPackages
	| p |
	self assertEmpty: (self packageOrganizer extendingPackagesOf: self quadrangleClass).
	p := self pointRectangleInGraphElement.
	self packageOrganizer registerExtendingPackage: p forClass: self quadrangleClass.
	self denyEmpty: (self packageOrganizer extendingPackagesOf: self quadrangleClass).
	self assert: (self packageOrganizer extendingPackagesOf: self quadrangleClass) anyOne name equals: #GraphElement! !

!RPackageOrganizerTest methodsFor: 'tests - extensions' stamp: ''!
testSilentlyRenameCategoryToBe

	| class |
	
	class := self createNewClassNamed: #ClassForTestAboutSilentRecategorization inCategory: 'RPackage-Tests'.
	class organization addCategory:#foo.
	self assert: (class organization categories includes: #foo).
	self deny: (class organization categories includes: #bar).
	class organization silentlyRenameCategory: #foo toBe: #bar.
	
	self assert: (class organization categories includes: #bar).
	self deny: (class organization categories includes: #foo).! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testRegisterPackageConflictWithPackageTag

	| package1 package2 |

	package1 := self createNewPackageNamed: 'P1'.
	package1 register.
	package1 addClassTag: #T1.
	
	package2 := self createNewPackageNamed: 'P1-T1'.
	self 
		should: [ package2 register ]
		raise: Error! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testDefinedClassesInstanceAndMetaSideAPI
	
	| p1 |
	p1 := self createNewPackageNamed: 'P1'.
	self packageOrganizer registerPackage: p1.
	p1 addClassDefinition: Point.
	p1 addMethod: Point>>#x.
	p1 addMethod: Point class>>#x:y:. 
	self assert: self packageOrganizer packageNames size equals: 2.
	self assert: self packageOrganizer packages size equals: 2.
	self assert: (self packageOrganizer packageNamed: #P1) definedClasses size equals: 1! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
p2Name
	^ 'RPackageTestP2'! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
p3Name
	^ 'RPackageTestP3'! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testRegisteredIsIncludedInPackageNames	
	| p1 p2 p3 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.

	self packageOrganizer registerPackage: p1.
	self packageOrganizer registerPackage: p2.
	self packageOrganizer registerPackage: p3.
	self assert: self packageOrganizer packageNames size equals: 4.
	self assert: (self packageOrganizer includesPackage: p1). 
	self assert: (self packageOrganizer includesPackageNamed: p1 name). 
	{p1 . p2 . p3} do: [:each | self assert:  (self packageOrganizer packageNames includes: each name)]! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testRegisteredNumberOfPackageIsOk
	| p1 p2 p3 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.

	self packageOrganizer basicRegisterPackage: p1.
	self packageOrganizer basicRegisterPackage: p2.
	self packageOrganizer basicRegisterPackage: p3.
	self assert: self packageOrganizer packageNames size equals: 4.
	self packageOrganizer basicUnregisterPackage: p3.
	self assert: self packageOrganizer packageNames size equals: 3.! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testRegisterPackageTagConflictWithPackage
	| package1 package2 |

	package1 := self createNewPackageNamed: 'P1-T1'.
	package1 register.	
	
	package2 := self createNewPackageNamed: 'P1'.
	self 
		should: [ package2 addClassTag: #T1 ]
		raise: Error! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testRegisteredIsThere	
	| p1 p2 p3 |
	p1 := self createNewPackageNamed: 'P1'.
	p2 := self createNewPackageNamed: 'P2'.
	p3 := self createNewPackageNamed: 'P3'.

	self packageOrganizer basicRegisterPackage: p1.
	self packageOrganizer basicRegisterPackage: p2.
	self packageOrganizer basicRegisterPackage: p3.
	self assert: self packageOrganizer packageNames size equals: 4.
	
	{p1 . p2 . p3} do: [:each | 
		self assert:  (self packageOrganizer packageNames includes: each name)]! !

!RPackageOrganizerTest methodsFor: 'utilities' stamp: ''!
quadrangleClass
	^ self class environment at: #QuadrangleForTesting! !

!RPackageOrganizerTest methodsFor: 'tests' stamp: ''!
testCreateNewPackageWithConflictRaisesConflictException

	packageOrganizer createPackageNamed: 'P1'.
	self
		should: [ packageOrganizer createPackageNamed: 'P1' ]
		raise: RPackageConflictError! !

!RPackageOrganizerTest class methodsFor: 'utilities' stamp: ''!
removePackageIfExist: aName

	self packageOrganizer basicUnregisterPackageNamed: aName asSymbol.! !

!RPackageOrganizerTest class methodsFor: 'utilities' stamp: ''!
removeClassNamedIfExists: aClassNameSymbol

	self environment at: aClassNameSymbol asSymbol ifPresent: [ :c | c removeFromSystem ]! !

!RPackagePrequisitesTest commentStamp: ''!
SUnit tests for RPackage prerequisites!
!RPackagePrequisitesTest methodsFor: 'tests' stamp: ''!
testNoPackagesOverride
	"Class side packages should not be overridden"

	self assertEmpty: (Object allSubclasses select: [ :each | (each class compiledMethodAt: #packages ifAbsent: [ nil ]) isNotNil ])! !

!RPackageReadOnlyCompleteSetupTest commentStamp: ''!
The tests takes as fixture the following situation and exercises the readonly queries.
We should be able to use a test resources to speed it up.

P1 
	A1DefinedInP1
	A1DefinedInP1>>methodDefinedInP1
	B1DefinedInP1	
	A2DefinedInP2>>methodDefinedInP1
	
P2
	A2DefinedInP2
	A2DefinedInP2>>methodDefinedInP2
	B2DefinedInB2	

P3
	A3DefinedInP3	
	A2DefinedInP2>>methodDefinedInP3 !
!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - compiled method' stamp: ''!
testCompiledMethodIsDefinedInPackage

	self assert: (((testingEnvironment at: #A1DefinedInP1) >> #methodDefinedInP1) isDefinedInPackage: p1).
	self deny: (((testingEnvironment at: #A2DefinedInP2) >> #methodDefinedInP1) isDefinedInPackage: p1).! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - tag class' stamp: ''!
testRemoveTaggedClasses
	
	p1 addClassDefinitionName: #A1DefinedInP1 toClassTag: #foo.
	p1 addClassDefinitionName: #B1DefinedInP1 toClassTag: #foo.
	p1 addClassDefinitionName: #B1DefinedInP1 toClassTag: #zork.
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #A1DefinedInP1).
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 2.
	self deny: (((p1 classesForClassTag: #zork) collect: [:each | each name]) includes: #A1DefinedInP1).
	self assert: (((p1 classesForClassTag: #zork) collect: [:each | each name]) includes: #B1DefinedInP1).	"now when we remove a class"	"from an existing tags list"
	p1 removeClassDefinitionName: #A1DefinedInP1 fromClassTag: #foo.
	self deny: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #A1DefinedInP1).
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 1.	"from a nonexisting tag list"
	p1 removeClassDefinitionName: #B1DefinedInP1 fromClassTag: #taz.
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (((p1 classesForClassTag: #zork) collect: [:each | each name]) includes: #B1DefinedInP1).	"with a class not registered to a tag list"
	p1 removeClassDefinitionName: #Tagada fromClassTag: #foo.
	self deny: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #A1DefinedInP1).
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 1! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - tag class' stamp: ''!
testEmpty
	self assertEmpty: p1 classTags! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - tag class' stamp: ''!
testAddTagsToAClass
	self assertEmpty: p1 classTags.
	p1 addClassDefinitionName: #A1DefinedInP1 toClassTag: #foo.
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #A1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 1.
	p1 addClassDefinitionName: #B1DefinedInP1 toClassTag: #foo.
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 2.

	p1 addClassDefinitionName: #B1DefinedInP1 toClassTag: #zork.
	self assert: (((p1 classesForClassTag: #zork) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 2.
	self assert: (p1 classesForClassTag: #zork) size equals: 1! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - accessing' stamp: ''!
testExtendingPackagesOfClass
	"since a class can be extended by several packages, we want the list of packages that extend
	the class"

	| packages |
	packages := a2 extendingPackages.
	"a2 is extended by p1 and p3"
	self assert: packages size equals: 2.
	self assert: (packages includes: p1).
	self deny: (packages includes: p2).
	self assert: (packages includes: p3).

	packages := a1 extendingPackages.
	self assertEmpty: packages! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - situation' stamp: ''!
testSelectorsForClass
	self assert: (p1 selectorsForClass: a1) size equals: 2.
	self assert: ((p1 selectorsForClass: a1) includes: #methodDefinedInP1).
	self assert: ((p1 selectorsForClass: a1) includes: #anotherMethodDefinedInP1).
	self assertEmpty: (p1 selectorsForClass: b1).
	self assertEmpty: (p1 selectorsForClass: Object).
	self assertEmpty: (p1 selectorsForClass: Object class).

	self assert: (p3 selectorsForClass: a2) size equals: 1.
	self assert: ((p3 selectorsForClass: a2) includes: #methodDefinedInP3).
	self assert: (p3 selectorsForClass: a2 class) size equals: 1.
	self assert: ((p3 selectorsForClass: a2 class) includes: #classSideMethodDefinedInP3)! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - compiled method' stamp: ''!
testCompiledMethodIsExtensionInPackage

	self deny: (((testingEnvironment at: #A1DefinedInP1) >> #methodDefinedInP1) isExtensionInPackage: p1).
	self assert: (((testingEnvironment at: #A2DefinedInP2) >> #methodDefinedInP1) isExtensionInPackage: p1).! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - situation' stamp: ''!
testMethods

	| m1 m3 |
	m1 := p1 methods.
	self assert: m1 size equals: 3. 
	self assert: (m1 includes: a1>>#methodDefinedInP1).
	self assert: (m1 includes: a1>>#anotherMethodDefinedInP1). 
	self assert: (m1 includes: a2>>#methodDefinedInP1).
	m3 := p3 methods.
	self assert: m3 size equals: 2.
	self assert: (m3 includes: a2>>#methodDefinedInP3).
	self assert: (m3 includes: a2 class>>#classSideMethodDefinedInP3)! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - accessing' stamp: ''!
testPackagesOfClass
	"since a class can be extended by several packages, we want the complete list of packages that define or extend
	the class"
	
	| packages extending |
	packages := a2 packages.
	"a2 is extended by p1 and p3"
	extending := a2 extendingPackages.
	self assert: extending size equals: 2. 
	self assert: (extending includes: p1).
	self assert: (extending includes: p3).
	
	self assert: packages size equals: 3. 
	self assert: (packages includes: p1).
	self assert: (packages includes: p2).
	self assert: (packages includes: p3).! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - tag class' stamp: ''!
testAddTagNames
	self assertEmpty: p1 classTags.
	p1 addClassTag: #baz.
	self assert: (p1 classTags anySatisfy: [ :tag | tag name = #baz ]).
	self assert: p1 classTags size equals: 1.

	p1 addClassDefinitionName: #A1DefinedInP1 toClassTag: #foo.
	p1 addClassDefinitionName: #B1DefinedInP1 toClassTag: #foo.
	self assert: (p1 classTags anySatisfy: [ :tag | tag name = #foo ]).
	self assert: p1 classTags size equals: 2.
	self assert: ((p1 classNamesForClassTag: #foo) includes: #A1DefinedInP1).
	self assert: ((p1 classNamesForClassTag: #foo) includes: #B1DefinedInP1).
	self assert: (p1 classNamesForClassTag: #foo) size equals: 2.

	p1 addClassTag: #foo.
	self assert: (p1 classTags anySatisfy: [ :tag | tag name = #baz ]).
	self assert: (p1 classTags anySatisfy: [ :tag | tag name = #foo ]).
	self assert: ((p1 classNamesForClassTag: #foo) includes: #A1DefinedInP1).
	self assert: ((p1 classNamesForClassTag: #foo) includes: #B1DefinedInP1).
	self assert: (p1 classNamesForClassTag: #foo) size equals: 2! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - tag class' stamp: ''!
testAddTag
	self assertEmpty: p1 classTags.
	p1 addClassTag: #baz.
	self assert: (p1 classTags anySatisfy: [ :tag | tag name = #baz ]).
	self assert: p1 classTags size equals: 1.

	p1 addClassDefinitionName: #A1DefinedInP1 toClassTag: #foo.
	p1 addClassDefinitionName: #B1DefinedInP1 toClassTag: #foo.
	self assert: (p1 classTags anySatisfy: [ :tag | tag name = #foo ]).
	self assert: p1 classTags size equals: 2.
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #A1DefinedInP1).
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 2.

	p1 addClassTag: #foo.
	self assert: (p1 classTags anySatisfy: [ :tag | tag name = #baz ]).
	self assert: (p1 classTags anySatisfy: [ :tag | tag name = #foo ]).
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #A1DefinedInP1).
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 2! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	p1 := self createNewPackageNamed: self p1Name.
	p2 := self createNewPackageNamed: self p2Name.
	p3 := self createNewPackageNamed: self p3Name.
	
	a1 := self createNewClassNamed: #A1DefinedInP1 inPackage: p1.
	b1 := self createNewClassNamed: #B1DefinedInP1 inPackage: p1.
	a2 := self createNewClassNamed: #A2DefinedInP2 inPackage: p2.
	b2 := self createNewClassNamed: #B2DefinedInP2 inPackage: p2.
	a3 := self createNewClassNamed: #A3DefinedInP3 inPackage: p3.
	
	a1 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a1>>#methodDefinedInP1).
	a1 compileSilently: 'anotherMethodDefinedInP1 ^ #anotherMethodDefinedInP1'.
	p1 addMethod: (a1>>#anotherMethodDefinedInP1).
	
	a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	
	a2 compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addMethod: (a2>>#methodDefinedInP2).
	
	a2 compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addMethod: (a2>>#methodDefinedInP3).

	a2 class compileSilently: 'classSideMethodDefinedInP3 ^ #classSideMethodDefinedInP3'.
	p3 addMethod: (a2 class>>#classSideMethodDefinedInP3).! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - slice' stamp: ''!
testClassesAndExtensionMethodsDo
	| block |
	self assert: (String streamContents: [:stream |
		block := [ :aClassName :selectors |
				stream nextPutAll: aClassName ; nextPutAll: ' '.
				selectors do: [ :selector | stream nextPutAll: selector asString].
				stream cr.].
		{p1 . p2 . p3} do: [ :p |
			p classExtensionSlicesDo: block.
			p metaclassExtensionSlicesDo: block.]]) 
		equals: 'A2DefinedInP2 methodDefinedInP1
A2DefinedInP2 methodDefinedInP3
A2DefinedInP2 classSideMethodDefinedInP3
'! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - slice' stamp: ''!
testClassNamesAndExtensionSelectorsDo
	self assert: (String streamContents: [:stream |
		{p1 . p2 .p3} do: [:p |
			p classNamesAndExtensionSelectorsDo: [:aClassName :selector |
				stream nextPutAll: aClassName  ; nextPutAll: ' ' ; nextPutAll:  selector asString; cr ]]])
		equals: 'A2DefinedInP2 methodDefinedInP1
A2DefinedInP2 methodDefinedInP3
A2DefinedInP2_class classSideMethodDefinedInP3
'.! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - situation' stamp: ''!
testExtensionSelectorsForClass
	self assert: (p1 extensionSelectorsForClass: a2) size equals: 1.
	self assert: ((p1 extensionSelectorsForClass: a2) includes: #methodDefinedInP1).
	self assert: ((p1 extensionMethodsForClass: a2) includes: (testingEnvironment at: #A2DefinedInP2) >> #methodDefinedInP1).
	self assertEmpty: (p1 extensionSelectorsForClass: Object).
	self assertEmpty: (p1 extensionSelectorsForClass: Object class)! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - compiled method' stamp: ''!
testClassIsExtendedInPackage
	self deny: ((testingEnvironment at: #A1DefinedInP1) isExtendedInPackage: p1).
	self assert: (p1 includesClass: (testingEnvironment at: #A1DefinedInP1)).
	self deny: (p1 extendsClass: (testingEnvironment at: #A1DefinedInP1)).
	self assert: ((testingEnvironment at: #A2DefinedInP2) isExtendedInPackage: p1).
	self deny: (p1 includesClass: (testingEnvironment at: #A2DefinedInP2)).
	self assert: (p1 extendsClass: (testingEnvironment at: #A2DefinedInP2)).! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - situation' stamp: ''!
testMetaclassHasExtensions

	self assert: (p3 includesExtensionSelector: #methodDefinedInP3 ofClassName: a2  name).
	self assert: (p3 includesExtensionSelector: #methodDefinedInP3 ofClass: a2).
	self assert: (p3 includesExtensionSelector: #classSideMethodDefinedInP3 ofMetaclassName: a2 name).
	self assert: (p3 includesExtensionSelector: #classSideMethodDefinedInP3 ofClass: a2 class)! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - situation' stamp: ''!
testStartingSituation	

 	self deny: (p2 includesClass: b1).
	self assert: (p2 includesClass: b2).
	"a locally defined class not extended by other packages"
	
	self assert: (p2 includesClass: a2).  
	"a locally defined class extended by other packages"
	
	self assert: (p1 definesOrExtendsClass: a2).
	self deny: (p1 includesClass: a2).! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - compiled method' stamp: ''!
testCompiledMethodPackageFromOrganizer
	
	| method |
	method := (testingEnvironment at: #A1DefinedInP1) >> #methodDefinedInP1.
	self assert: (method packageFromOrganizer: self packageClass organizer) equals: p1.
	method := (testingEnvironment at: #A2DefinedInP2) >> #methodDefinedInP1.
	self assert: (method packageFromOrganizer: self packageClass organizer) equals: p1! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - situation' stamp: ''!
testDefinedSelectors

	self assert: a1 definedSelectors size equals: 2. 
	self assert: ((a1 definedSelectors) includes: #methodDefinedInP1).
	self assert: ((a1 definedSelectors) includes: #anotherMethodDefinedInP1). 

	self assert: a2 definedSelectors size equals: 1.
	self assert: (a2 definedSelectors includes: #methodDefinedInP2).! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - accessing' stamp: ''!
testExtensionMethods
	"a package can extend several classes, either the class or  the meta-class side. 'extensionMethods' should list all the methods involved in shuch extensions. P3 extend a2 and a2 class"

	| package extensionMethods cpt |
	package := p3.
	extensionMethods := package extensionMethods.	"self assert: (extensionMethods size = 2)."
	self assert: (extensionMethods includes: a2 >> #methodDefinedInP3).
	self assert: (extensionMethods includes: a2 class >> #classSideMethodDefinedInP3).
	cpt := 0.
	package
		metaclassExtensionSlicesDo: [ :className :listOfSelectors | (className = a2 name and: [ listOfSelectors includes: #classSideMethodDefinedInP3 ]) ifTrue: [ cpt := cpt + 1 ] ].
	self assert: cpt equals: 1.
	cpt := 0.
	package
		classExtensionSlicesDo: [ :className :listOfSelectors | (className = a2 name and: [ listOfSelectors includes: #methodDefinedInP3 ]) ifTrue: [ cpt := cpt + 1 ] ].
	self assert: cpt equals: 1! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - situation' stamp: ''!
testSelectors
		
	self assert: (p1 selectors) size equals: 2. 
	self assert: ((p1 selectors) includes: #methodDefinedInP1).
	self assert: ((p1 selectors) includes: #anotherMethodDefinedInP1). 

	self assert: p3 selectors size equals: 2.
	self assert: (p3 selectors includes: #methodDefinedInP3).
	self assert:  (p3 selectors includes: #classSideMethodDefinedInP3)! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - situation' stamp: ''!
testMethodsForClass
	self assert: (p1 methodsForClass: a1) size equals: 2.
	self assert: ((p1 methodsForClass: a1) includes: (testingEnvironment at: #A1DefinedInP1) >> #methodDefinedInP1).
	self assert: ((p1 methodsForClass: a1) includes: (testingEnvironment at: #A1DefinedInP1) >> #anotherMethodDefinedInP1).
	self assertEmpty: (p1 methodsForClass: b1).
	self assertEmpty: (p1 methodsForClass: Object).
	self assertEmpty: (p1 methodsForClass: Object class).

	self assert: (p3 methodsForClass: a2) size equals: 1.
	self assert: ((p3 methodsForClass: a2) includes: (testingEnvironment at: #A2DefinedInP2) >> #methodDefinedInP3).
	self assert: (p3 methodsForClass: a2 class) size equals: 1.
	self assert: ((p3 methodsForClass: a2 class) includes: (testingEnvironment at: #A2DefinedInP2) class >> #classSideMethodDefinedInP3)! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - tag class' stamp: ''!
testRemoveTag
	self assertEmpty: p1 classTags.
	p1 addClassDefinitionName: #A1DefinedInP1 toClassTag: #foo.
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #A1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 1.
	p1 addClassDefinitionName: #B1DefinedInP1 toClassTag: #foo.
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 2.
	p1 removeClassTag: #bar.
	self assert: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 2.
	p1 removeClassTag: #foo.
	self deny: (((p1 classesForClassTag: #foo) collect: [:each | each name]) includes: #B1DefinedInP1).
	self assert: (p1 classesForClassTag: #foo) size equals: 0! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - situation' stamp: ''!
testDefinedSelectorsForClass
	self assert: (p1 definedSelectorsForClass: a1) size equals: 2.
	self assert: (p1 definedMethodsForClass: a1) size equals: 2.
	self assert: ((p1 definedSelectorsForClass: a1) includes: #methodDefinedInP1).
	self assert: ((p1 definedSelectorsForClass: a1) includes: #anotherMethodDefinedInP1).
	self assert: ((p1 definedMethodsForClass: a1) includes: (testingEnvironment at: #A1DefinedInP1) >> #methodDefinedInP1).
	self assertEmpty: (p1 definedSelectorsForClass: Object).
	self assertEmpty: (p1 definedSelectorsForClass: Object class)! !

!RPackageReadOnlyCompleteSetupTest methodsFor: 'tests - situation' stamp: ''!
testExtensionSelectors
	self assertEmpty: a1 extensionSelectors.

	self assert: a2 extensionSelectors size equals: 2.
	self assert: (a2 extensionSelectors includes: #methodDefinedInP1).
	self assert: (a2 extensionSelectors includes: #methodDefinedInP3)! !

!RPackageRegistered commentStamp: ''!
I am a public announcement sent when a new RPackage is created!
!RPackageRenameTest commentStamp: ''!
SUnit tests on renaming packages!
!RPackageRenameTest methodsFor: 'running' stamp: ''!
tearDown

	SystemAnnouncer announcer: oldSystemAnnouncer.
	self class environment at: #TestClass ifPresent: [ :class | class removeFromSystem ].
	self class environment at: #TestClass1 ifPresent: [ :class | class removeFromSystem ].
	self class environment at: #TestClass2 ifPresent: [ :class | class removeFromSystem ].
	self class environment at: #TestClass3 ifPresent: [ :class | class removeFromSystem ].
	super tearDown! !

!RPackageRenameTest methodsFor: 'tests' stamp: ''!
testRenamePackageUppercase
"Test that we do rename the package as expected."
| package pkg oldWorkingCopy |

"preparation: creation of a pkg and its associated mcworkingcopy"
[package := RPackageOrganizer default registerPackageNamed: 'Test1'.
oldWorkingCopy := MCWorkingCopy forPackage: (MCPackage new name: 'Test1').
self assert: (RPackageOrganizer default includesPackageNamed: #Test1).
self assert: (MCWorkingCopy hasPackageNamed: #Test1) isNotNil.

"renaming"
package renameTo: 'TEST1'.


pkg := RPackageOrganizer default packageNamed: 'Test1'  ifAbsent: [ nil ].
self assert: pkg isNil.
self assert: 'TEST1' asPackage isNotNil.
self deny: 'TEST1' asPackage mcWorkingCopy equals: oldWorkingCopy.
self assert: 'TEST1' asPackage mcWorkingCopy isNotNil.
self assert: (RPackageOrganizer default includesPackageNamed: #TEST1).
self assert: (MCWorkingCopy hasPackageNamed: #TEST1) isNotNil.

] ensure: 
["cleaning"
'TEST1' asPackage removeFromSystem.
self deny: (RPackageOrganizer default includesPackageNamed: #TEST1).
self deny: (MCWorkingCopy hasPackageNamed: #TEST1).
self deny: (RPackageOrganizer default includesPackageNamed: #Test1).
self deny: (MCWorkingCopy hasPackageNamed: #Test1).]! !

!RPackageRenameTest methodsFor: 'tests' stamp: ''!
testRenamePackageToOwnTagNameWithClassesInRoot
	"If we rename a package to the (full)category name of one of its tags and the (non-tag)package is not empty"
	| package workingCopy class1 class2 class3|

	package := RPackageOrganizer default registerPackageNamed: 'Test1'.
	workingCopy := MCWorkingCopy forPackage: (MCPackage new name: 'Test1').
	class1 := Object subclass: #TestClass1 instanceVariableNames: '' classVariableNames: '' package: 'Test1-Core'.
	class2 := Object subclass: #TestClass2 instanceVariableNames: '' classVariableNames: '' package: 'Test1-Util'.
	class3 := Object subclass: #TestClass3 instanceVariableNames: '' classVariableNames: '' package: 'Test1'.
	
	self assert: (package classTagNamed: #Core ifAbsent: [ nil ]) notNil.
	self assert: (package classTagNamed: #Util ifAbsent: [ nil ]) notNil.
	self assert: (package classTagForClass: class1) name equals: #Core.
	self assert: (package classTagForClass: class2) name equals: #Util.
	self assert: (package classTagForClass: class3) name equals: #Test1.
	package renameTo: 'Test1-Core'.
	self assert: (package classTagForClass: class1) name equals: #Core.
	self assert: (package classTagForClass: class2) name equals: #Util.
	self assert: (package classTagForClass: class3) name equals: #'Test1-Core'.
	"cleaning"
	workingCopy := MCWorkingCopy forPackage: (MCPackage new name: 'Test1-Core').
	self assert: workingCopy modified.
	workingCopy unload.	
	self deny: (RPackageOrganizer default includesPackageNamed: #'Test1-Core').
	self deny: (MCWorkingCopy hasPackageNamed: #'Test1-Core').! !

!RPackageRenameTest methodsFor: 'tests' stamp: ''!
testRenamePackageToOwnTagName
	"If we rename a package to the (full)category name of one of its tags"
	| package workingCopy class1 class2 |

	package := RPackageOrganizer default registerPackageNamed: 'Test1'.
	workingCopy := MCWorkingCopy forPackage: (MCPackage new name: 'Test1').
	class1 := Object subclass: #TestClass1 instanceVariableNames: '' classVariableNames: '' package: 'Test1-Core'.
	class2 := Object subclass: #TestClass2 instanceVariableNames: '' classVariableNames: '' package: 'Test1-Util'.
	
	self assert: (package classTagNamed: #Core ifAbsent: [ nil ]) notNil.
	self assert: (package classTagNamed: #Util ifAbsent: [ nil ]) notNil.
	package renameTo: 'Test1-Core'.
	self assert: (package includesClass: class1).
	self assert: (package includesClass: class2).
	self assert: (package classTagNamed: #'Core' ifAbsent: [ nil ]) notNil.
	self assert: (package classTagNamed: #'Util' ifAbsent: [ nil ]) notNil.
	self assert: ((package classTagNamed: #'Core' ifAbsent: [ nil ]) includesClass: class1).
	self assert: ((package classTagNamed: #'Util' ifAbsent: [ nil ]) includesClass: class2).	
	"cleaning"
	workingCopy := MCWorkingCopy forPackage: (MCPackage new name: 'Test1-Core').
	self assert: workingCopy modified.
	workingCopy unload.	
	self deny: (RPackageOrganizer default includesPackageNamed: #'Test1-Core').
	self deny: (MCWorkingCopy hasPackageNamed: #'Test1-Core').! !

!RPackageRenameTest methodsFor: 'tests' stamp: ''!
testRenamePackage
	"Test that we do rename the package as expected."

	| package workingCopy class |
	package := RPackageOrganizer default registerPackageNamed: 'Test1'.
	workingCopy := MCWorkingCopy forPackage: (MCPackage new name: 'Test1').
	class := Object
		subclass: #TestClass
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Test1-TAG'.
	self assert: (package includesClass: class).
	self assert: (package classTagNamed: #TAG ifAbsent: [ nil ]) notNil.
	self assert: ((package classTagNamed: #TAG ifAbsent: [ nil ]) includesClass: class).
	self assert: workingCopy modified.
	package renameTo: 'TestRename'.
	self assert: (package includesClass: class).
	self assert: (package classTagNamed: #TAG ifAbsent: [ nil ]) notNil.
	self assert: ((package classTagNamed: #TAG ifAbsent: [ nil ]) includesClass: class).
	self assert: class category equals: #'TestRename-TAG'.
	self deny: (Smalltalk organization includesCategory: #Test1).
	self deny: (MCWorkingCopy hasPackageNamed: #Test1).

	"cleaning"
	workingCopy := MCWorkingCopy forPackage: (MCPackage new name: 'TestRename').
	self assert: workingCopy modified.
	workingCopy unload.
	self deny: (RPackageOrganizer default includesPackageNamed: #TestRename).
	self deny: (MCWorkingCopy hasPackageNamed: #TestRename)! !

!RPackageRenameTest methodsFor: 'tests' stamp: ''!
testUnregisterPackage
	"Test that we do rename the package as expected."
	| package workingCopy class |

	package := RPackageOrganizer default registerPackageNamed: 'Test1'.
	workingCopy := MCWorkingCopy forPackage: (MCPackage new name: 'Test1').
	class := Object
		subclass: #TestClass
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Test1-TAG'.
	self assert: (package includesClass: class).
	self assert: (package classTagNamed: #TAG ifAbsent: [ nil ]) notNil.
	self assert: ((package classTagNamed: #TAG ifAbsent: [ nil ]) includesClass: class).
	self assert: workingCopy modified.
	
	package unregister.
	
	self deny: (RPackageOrganizer default includesPackageNamed: #Test1).
	self deny: (MCWorkingCopy hasPackageNamed: #Test1).! !

!RPackageRenameTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	oldSystemAnnouncer := SystemAnnouncer uniqueInstance.
	SystemAnnouncer restoreAllNotifications! !

!RPackageRenamed commentStamp: ''!
I am a public announcement sent when a new RPackage is renamed!
!RPackageRenamed methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInPackage: aPackage

	^package == aPackage! !

!RPackageRenamed methodsFor: 'accessing' stamp: ''!
oldName

	^ oldName! !

!RPackageRenamed methodsFor: 'testing' stamp: ''!
affectsMethodsDefinedInClass: aClass

	^(package definesClass: aClass)
		or: [ package extendsClass: aClass ]! !

!RPackageRenamed methodsFor: 'accessing' stamp: ''!
newName: anObject

	newName := anObject! !

!RPackageRenamed methodsFor: 'accessing' stamp: ''!
oldName: anObject

	oldName := anObject! !

!RPackageRenamed methodsFor: 'testing' stamp: ''!
affectsMethod: aMethod
	^package == aMethod package! !

!RPackageRenamed methodsFor: '*Calypso-SystemQueries' stamp: ''!
canAffectResultOfMethodQuery: aMethodQuery
	^true! !

!RPackageRenamed methodsFor: 'testing' stamp: ''!
affectsMethods
	"methods belong to package which could be represented by tools as part of method"
	^true! !

!RPackageRenamed methodsFor: 'testing' stamp: ''!
affectsClass: aClass
	^package == aClass package! !

!RPackageRenamed methodsFor: 'accessing' stamp: ''!
newName

	^ newName! !

!RPackageRenamed class methodsFor: 'instance creation' stamp: ''!
to: aPackage oldName: aSymbol newName: anotherSymbol

	^ (self to: aPackage) 
		oldName: aSymbol;
		newName: anotherSymbol;
		yourself! !

!RPackageSet commentStamp: ''!
I'm a set who can be instantiated by pattern matching RPackages ("name" and "name-*").
My purpose is to provide a bridge between monticello and system packages, to allow backward compatibility with old packaging. 
!
!RPackageSet methodsFor: 'accessing' stamp: ''!
classes
	^classes ifNil: [ classes := self packages flatCollect: #definedClasses ]! !

!RPackageSet methodsFor: '*Gofer-Core' stamp: ''!
coreCategoriesForClass: aClass
	^ self packages
		flatCollect: [ :p | aClass organization categories reject: [ :cat | p isForeignClassExtension: cat ] ]! !

!RPackageSet methodsFor: 'system compatibility' stamp: ''!
isForeignClassExtension: categoryName
	^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]! !

!RPackageSet methodsFor: 'system compatibility' stamp: ''!
asRPackageSet
	^self! !

!RPackageSet methodsFor: 'system compatibility' stamp: ''!
isYourClassExtension: categoryName
	^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]! !

!RPackageSet methodsFor: '*Gofer-Core' stamp: ''!
classesAndMetaClasses
	^ self packages
		flatCollect: [ :p | p definedClasses , (p definedClasses collect: [ :each | each classSide ]) ]! !

!RPackageSet methodsFor: 'system compatibility' stamp: ''!
systemCategories
	^ systemCategories ifNil: [ systemCategories := (self packages flatCollect: #systemCategories as: Set) asArray ]! !

!RPackageSet methodsFor: 'system compatibility' stamp: ''!
includesMethodCategory: categoryName ofClass: aClass
	^ (self isYourClassExtension: categoryName)
		or: [(self includesClass: aClass)
				and: [(self isForeignClassExtension: categoryName) not ]]! !

!RPackageSet methodsFor: 'accessing' stamp: ''!
categoryNames
	^  self packages 	
		inject:  #()
		into: [ :all :each | all, (each classTagCategoryNames asArray) ]! !

!RPackageSet methodsFor: 'system compatibility' stamp: ''!
category: categoryName matches: prefix
	^ RPackageOrganizer default category: categoryName matches: prefix! !

!RPackageSet methodsFor: 'system compatibility' stamp: ''!
extendedClasses
	^ self packages flatCollect: #extendedClasses! !

!RPackageSet methodsFor: 'system compatibility' stamp: ''!
extensionCategoriesForClass: aClass
	^ aClass organization categories select: [:cat | self isYourClassExtension: cat]! !

!RPackageSet methodsFor: 'accessing' stamp: ''!
extensionMethods
	^ extensionMethods ifNil: [
		extensionMethods :=
		(self packages flatCollect: [ :p | p extensionMethods ] as: Set) asArray ]! !

!RPackageSet methodsFor: 'testing' stamp: ''!
includesClass: aClass
	^self packages anySatisfy: [ :each | each includesClass: aClass ]! !

!RPackageSet methodsFor: 'system compatibility' stamp: ''!
includesSystemCategory: categoryName
	^self packages anySatisfy: [ :each | 
		each includesSystemCategory: categoryName ]! !

!RPackageSet methodsFor: 'accessing' stamp: ''!
packageName
	^packageName! !

!RPackageSet methodsFor: 'accessing' stamp: ''!
definedClasses
	^definedClasses ifNil: [ definedClasses := self packages flatCollect: #definedClasses ]! !

!RPackageSet methodsFor: 'accessing' stamp: ''!
methods
	^ methods ifNil: [ methods := (self packages flatCollect: [ :p | p methods ]) ]! !

!RPackageSet methodsFor: 'accessing' stamp: ''!
packages
	^packages! !

!RPackageSet methodsFor: 'accessing' stamp: ''!
unregister
	self packages do: #unregister! !

!RPackageSet methodsFor: 'initialization' stamp: ''!
initialize: aString
	self initialize.
	packageName := aString asSymbol.
	packages := (RPackage organizer packageNamed: aString ifAbsent: [  nil ])
		ifNotNil: [ :package | { package }  ]
		ifNil: [ {} ]! !

!RPackageSet methodsFor: 'system compatibility' stamp: ''!
methodCategoryPrefix
	^ '*', self packageName asLowercase! !

!RPackageSet class methodsFor: 'testing' stamp: ''!
isCacheActive 
	^ cacheActive ifNil: [ cacheActive := false ].! !

!RPackageSet class methodsFor: 'private' stamp: ''!
cacheActive: aBoolean 
	cacheActive := aBoolean! !

!RPackageSet class methodsFor: 'private' stamp: ''!
cachePackages 
	^ cachePackages ifNil: [ cachePackages := IdentityDictionary new ]! !

!RPackageSet class methodsFor: 'private' stamp: ''!
basicNamed: aString
	^ self basicNew 
		initialize: aString;
		yourself! !

!RPackageSet class methodsFor: 'instance creation' stamp: ''!
named: aString

	^ self isCacheActive 
		ifTrue: [ 
			self 
				cachePackageAt: aString 
				ifAbsentPut: [ self basicNamed: aString ] ]
		ifFalse: [ self basicNamed: aString ].! !

!RPackageSet class methodsFor: 'accessing' stamp: ''!
withCacheDo: aBlock 
	| oldActive |
	
	oldActive := self isCacheActive.
	self cacheActive: true.
	aBlock ensure: [ 
		self cacheActive: oldActive.
		self isCacheActive ifFalse: [ self resetCache ] ].! !

!RPackageSet class methodsFor: '*Iceberg' stamp: ''!
withoutCacheDo: aBlock 
	| oldActive |
	
	oldActive := self isCacheActive.
	self cacheActive: false.
	aBlock ensure: [ self cacheActive: oldActive ].! !

!RPackageSet class methodsFor: 'private' stamp: ''!
cachePackageAt: aString ifAbsentPut: aBlock
	"self addCount: aString."
	^ self cachePackages 
		at: aString asSymbol
		ifAbsentPut: aBlock! !

!RPackageSet class methodsFor: 'private' stamp: ''!
resetCache 
	cachePackages := nil.! !

!RPackageStringExtensionTest commentStamp: ''!
SUnit tests on string extensions used for packages!
!RPackageStringExtensionTest methodsFor: 'tests' stamp: ''!
testAsPackageIfAbsent
	self assert: ('___inexistent___package___' asPackageIfAbsent: [ true ])! !

!RPackageStringExtensionTest methodsFor: 'tests' stamp: ''!
testAsPackage
	self assert: self class package name asPackage notNil! !

!RPackageStringExtensionTest methodsFor: 'tests' stamp: ''!
testAsPackageWithError
	self 
		should: ['___inexistent___package___' asPackage]
		raise: NotFound! !

!RPackageTag commentStamp: ''!
I'm a class tag for an RPackage. 
Class tags can be any kind of metadata the user needs, but they are for now equivalent to class categories. !
!RPackageTag methodsFor: 'initialization' stamp: ''!
initializePackage: aPackage name: aString 
	package := aPackage.
	name := aString.
	self initialize.! !

!RPackageTag methodsFor: 'testing' stamp: ''!
isEmpty
	^ self classNames isEmpty! !

!RPackageTag methodsFor: 'testing' stamp: ''!
isRoot
	^ self name = self packageName! !

!RPackageTag methodsFor: 'printing' stamp: ''!
printOn: aStream 
	super printOn: aStream.
	aStream nextPut: $(.
	aStream nextPutAll: self name.
	aStream nextPut: $)! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
extendedClasses
	^ #()! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
orderedClasses
	^ self package orderedClasses select:[:c | c category = self categoryName]! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
packageName 
	^ self package name! !

!RPackageTag methodsFor: 'converting' stamp: ''!
promoteAsRPackage
	"This method converts this rpackage tag into an rpackage, removes the tag from the parent package with all classes included and registers the new package in the system.
	The tag has to be removed before registering to avoid conflicts.
	Smells like we could have an error and lose package tags!! registerPackage should not fail because names Package-Tag are unique in the system."
	| newRPackage |
	
	newRPackage := self asRPackage.
	self classes do: [ :each | self package removeClass: each  ].
	self package removeClassTag: self name.
	self package removeMethods: newRPackage extensionMethods.
	RPackage organizer registerPackage: newRPackage.
	
	newRPackage classes do: [ :each | 
		SystemAnnouncer uniqueInstance 
			classRepackaged: each 
			from: self package
			to:  newRPackage ].! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
renameTo: newTagName
	| oldName categoryName tagName |
	tagName := self name.
	oldName := self toCategoryName: tagName.
	categoryName := self toCategoryName: newTagName. 
	
	oldName = categoryName ifTrue: [ ^ self ].
	
	self basicRenameTo: newTagName.
	SystemAnnouncer uniqueInstance suspendAllWhile: [
		self classes do: [ :each | each category: categoryName ].
		self class environment organization 
			renameCategory: oldName 
			toBe: categoryName].
	SystemAnnouncer uniqueInstance 
		classTagRenamed: tagName 
		inPackage: self package 
		to: newTagName! !

!RPackageTag methodsFor: 'private' stamp: ''!
toCategoryName: aString 
	^ aString = self packageName
		ifTrue: [ aString ]
		ifFalse: [ self packageName, '-', aString ]! !

!RPackageTag methodsFor: 'updating' stamp: ''!
updateDefinedClassNamed: oldString withNewName: newString
	(self hasClassNamed: oldString)
		ifFalse: [ ^ self ].
	self removeClassNamed: oldString.
	self addClassNamed: newString! !

!RPackageTag methodsFor: '*CodeExport' stamp: ''!
fileOut
	| internalStream |
	
	internalStream := (String new: 1000) writeStream.
	
	SystemOrganization 
		fileOutCategory: self categoryName 
		on: internalStream.
		
	^ CodeExporter writeSourceCodeFrom: internalStream baseName: self name isSt: true.! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
categoryName 
	"Answer this tag as a SystemCategory. 
    That would be RPackage, '-', RPackageTag, unless tag is root (same name as RPackage)"
	^ self toCategoryName: self name! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
classes
	^ self classNames collect: [ :each | self class environment at: each ]! !

!RPackageTag methodsFor: 'testing' stamp: ''!
includesSelector: aSelector ofClass: aClass
	^ self package 
		includesSelector: aSelector 
		ofClass: aClass! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
addClassNamed: aSymbol 
	(classNames includes: aSymbol) ifTrue: [ ^ self ].
	^ classNames add: aSymbol.! !

!RPackageTag methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	classNames := Set new.! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
removeFromPackage
	self 
		assert: self isEmpty 
		description: 'Package tag is not empty'.
		
	self package basicRemoveTag: self! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
classNames 
	^ classNames! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
renameTo: aString category: categoryName
	| oldName |
	
	oldName := self toCategoryName: self name.
	oldName = categoryName ifTrue: [ ^ self ].
	
	self basicRenameTo: aString.
	SystemAnnouncer uniqueInstance suspendAllWhile: [
		self classes do: [ :each | each category: categoryName ].
		self class environment organization 
			renameCategory: oldName 
			toBe: categoryName. ].! !

!RPackageTag methodsFor: 'testing' stamp: ''!
hasClass: aClass 
	^  self hasClassNamed: aClass name! !

!RPackageTag methodsFor: 'testing' stamp: ''!
includesMethodCategory: aProtocol ofClass: aClass 
	^ self package 
		includesMethodCategory: aProtocol 
		ofClass: aClass! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
extensionCategoriesForClass: aClass 
	^ self package extensionCategoriesForClass: aClass! !

!RPackageTag methodsFor: 'testing' stamp: ''!
hasClassNamed: aSymbol 
	^ self classNames includes: aSymbol! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
name 
	^ name! !

!RPackageTag methodsFor: 'testing' stamp: ''!
includesClass: aClass 
	^ self hasClassNamed: aClass name! !

!RPackageTag methodsFor: 'private' stamp: ''!
asRPackage
	"Create a new RPackage with the same contents as this rpackage tag"
	| newRPackage |
	
	newRPackage := RPackage named: self categoryName.
	self classes 
		do: [ :className | newRPackage importClass: className ].
	(self package extensionsForTag: self) 
		do: [ :extensionMethod | newRPackage addMethod: extensionMethod ].
	
	^ newRPackage! !

!RPackageTag methodsFor: 'private' stamp: ''!
basicRenameTo: aString
	name := aString.! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
removeClassNamed: aSymbol 
	^ classNames remove: aSymbol ifAbsent: [].! !

!RPackageTag methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterClassesFor: aStep
	<stSpotterOrder: 20>
	aStep listProcessor
			allCandidates: [ self classes sorted: [ :a :b | a name < b name ] ];
			title: 'Classes';
			filter: StFilterSubstring! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
addClass: aClass
	aClass category: self categoryName! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
package 
	^ package! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
ensureSystemCategory 
	SystemOrganization addCategory: self categoryName! !

!RPackageTag methodsFor: 'accessing' stamp: ''!
removeClass: aClass
	^ self removeClassNamed: aClass name.! !

!RPackageTag methodsFor: '*Manifest-Core' stamp: ''!
manifestBuilderForRuleChecker: aRuleChecker
	"Return the manifestsince the rulechecker is keeping a cache, we ask it back"

	^ aRuleChecker manifestBuilderOfPackage: self package! !

!RPackageTag class methodsFor: 'instance creation' stamp: ''!
new 
	self error: 'Use #package:name:'! !

!RPackageTag class methodsFor: 'instance creation' stamp: ''!
package: aPackage name: aString 
	^ self basicNew 
		initializePackage: aPackage name: aString;
		yourself! !

!RPackageTag class methodsFor: '*Ombu-Ston' stamp: ''!
fromSton: stonReader
	"Specialize generic implementation since #new is forbidden in this class."
	
	^ self basicNew
		fromSton: stonReader;
		yourself! !

!RPackageTagTest commentStamp: ''!
SUnit tests for RPackage tags!
!RPackageTagTest methodsFor: 'running' stamp: ''!
tearDown 
	
	#(TestClass TestClassOther) 
		do: [ :each | 
			self class environment at: each ifPresent: #removeFromSystem ].
	super tearDown.! !

!RPackageTagTest methodsFor: 'tests' stamp: ''!
testAsRPackage
	| package1 tag convertedTag class |

	package1 := (self packageClass named: #Test1) register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG1'.
	class compile: 'foo ^42' classified: 'accessing'.
	
	tag := (package1 classTagNamed: #TAG1).
	
	convertedTag := tag asRPackage.
	
	self assert: (convertedTag includesClass: class).
	self assert: (convertedTag includesSelector: 'foo' ofClass:  class).! !

!RPackageTagTest methodsFor: 'tests' stamp: ''!
testAddClassFromTag
	| package1 package2 class |

	package1 := (self packageClass named: #Test1) register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG1'.
	
	self assert: (package1 includesClass: class).
	self assert: (package1 classTagNamed: #TAG1 ifAbsent: [ nil ]) notNil.
	self assert: ((package1 classTagNamed: #TAG1 ifAbsent: [ nil ]) includesClass: class).
	
	package2 := (self packageClass named: #Test2) register.
	
	(package2 addClassTag: #TAG2) addClass: class.
	
	self deny: (package1 includesClass: class).
	self assert: (package2 includesClass: class).	
	self assert: (package2 classTagNamed: #TAG2 ifAbsent: [ nil ]) notNil.
	self assert: ((package2 classTagNamed: #TAG2 ifAbsent: [ nil ]) includesClass: class).! !

!RPackageTagTest methodsFor: 'tests' stamp: ''!
testAddClass
	| package1 package2 class |

	package1 := (self packageClass named: #Test1) register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1'.
	
	self assert: (package1 includesClass: class).
	
	package2 := (self packageClass named: #Test2) register.
	
	(package2 addClassTag: #TAG) addClass: class.
	
	self deny: (package1 includesClass: class).
	self assert: (package2 includesClass: class).	
	self assert: (package2 classTagNamed: #TAG ifAbsent: [ nil ]) notNil.
	self assert: ((package2 classTagNamed: #TAG ifAbsent: [ nil ]) includesClass: class).! !

!RPackageTagTest methodsFor: 'tests' stamp: ''!
testPromoteAsRPackage
	| package1 package2 class tag1 |

	package1 := (self packageClass named: #Test1) register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG1'.
	class compile: 'foo ^42' classified: 'accessing'.

	tag1 := package1 classTagNamed: 'TAG1'.
	
	tag1 promoteAsRPackage.

	package2:= self packageClass organizer packageNamed: 'Test1-TAG1'.	
	self assert: package2 notNil. 
	self assert: (package2 classes includes: class).
	self deny: (package1 classes includes: class).! !

!RPackageTagTest methodsFor: 'tests' stamp: ''!
testPromoteAsRPackageWithExtension
	| packageOriginal packagePromoted class classOther tag |

	packageOriginal := (self packageClass named: #Test1) register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG1'.
	class compile: 'foo ^42' classified: #'accessing'.

	classOther := self createNewClassNamed: 'TestClassOther' inCategory: 'XXXX'.
	classOther compile: 'bar ^42' classified: #'*Test1-TAG1'.

	tag := packageOriginal classTagNamed: 'TAG1'.
	tag promoteAsRPackage.

	packagePromoted:= RPackage organizer packageNamed: 'Test1-TAG1'.	
	self assert: packagePromoted notNil. 
	self assert: (packagePromoted classes includes: class).
	self assert: (packagePromoted extensionMethods includes: classOther>>#bar).	
	self assert: (classOther>>#bar) protocol equals: '*Test1-TAG1'. 
	self deny: (packageOriginal classes includes: class).
	self deny: (packageOriginal extensionMethods includes: classOther>>#bar)! !

!RPackageTagTest methodsFor: 'tests' stamp: ''!
testAsRPackageWithExtensionMethods
	| package1 convertedTag class |
	package1 := (self packageClass named: #Test1) register.
	package1 addClassTag: #TAG1.

	(self packageClass named: #Test2) register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test2'.

	class compile: 'foo ^42' classified: '*Test1-TAG1'.

	convertedTag := (package1 classTagNamed: #TAG1) asRPackage.

	self assertEmpty: convertedTag definedClasses.
	self assert: (convertedTag includesExtensionSelector: 'foo' ofClass: class)! !

!RPackageTest commentStamp: ''!
SUnit tests for RPackage !
!RPackageTest methodsFor: 'tests' stamp: ''!
testDemoteToRPackageNamedMultilevelPackage1
	| package1 package2  class  |

	package1 := (self packageClass named: #'Test1-TAG1-X1') register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG1-X1'.
	class compile: 'foo ^42' classified: 'accessing'.

	package1 demoteToTagInPackageNamed: 'Test1'.

	self deny: (self packageClass organizer includesPackage: package1).
	package2 := self packageClass organizer packageNamed: 'Test1'.
	self assert: package2 notNil. 
	self assert: (package2 classes includes: class).
	self assert: ((package2 classTagNamed: 'TAG1-X1') classes includes: class).! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testDemoteToRPackageNamedExistingPackage
	| package1 package2 packageExisting class  |

	package1 := (self packageClass named: #'Test1-TAG1') register.
	packageExisting := (self packageClass named: #'Test1') register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG1'.
	class compile: 'foo ^42' classified: 'accessing'.

	package1 demoteToTagInPackageNamed: 'Test1'.

	self deny: (self packageClass organizer includesPackage: package1).
	package2 := self packageClass organizer packageNamed: 'Test1'.
	self assert: package2 notNil. 
	self assert: package2 equals: packageExisting. 
	self assert: (package2 classes includes: class).
	self assert: ((package2 classTagNamed: 'TAG1') classes includes: class).! !

!RPackageTest methodsFor: 'running' stamp: ''!
tearDown 
	
	#(TestClass TestClassOther) 
		do: [ :each | 
			self class environment at: each ifPresent: #removeFromSystem ].
	super tearDown! !

!RPackageTest methodsFor: 'tests - MC' stamp: ''!
testMcPackage

	| rPackage |
	rPackage := self organizer registerPackageNamed: #Test1.
	self assert: rPackage mcPackage equals: (MCPackage new name: #Test1).! !

!RPackageTest methodsFor: 'tests - properties' stamp: ''!
testPropertyAtPut

	| testValue package |
	
	testValue := Date today.
	package := self class package.
	
	package propertyAt: #testKeySelector put: testValue.
	self
		assert: (package propertyAt: #testKeySelector)
		equals: testValue.

	package removeProperty: #testKeySelector.
	self assert: package properties isNil.! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testDemoteToRPackageNamedWithExtension
	| packageOriginal packageDemoted class classOther |

	packageOriginal := (RPackage named: #'Test1-TAG1') register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG1'.
	class compile: 'foo ^42' classified: 'accessing'.

	classOther := self createNewClassNamed: 'TestClassOther' inCategory: 'XXXX'.
	classOther compile: 'bar ^42' classified: #'*Test1-TAG1'.

	packageOriginal demoteToTagInPackageNamed: 'Test1'.

	self deny: (RPackage organizer includesPackage: packageOriginal).
	packageDemoted := RPackage organizer packageNamed: 'Test1'.
	self assert: packageDemoted notNil. 
	self assert: (packageDemoted classes includes: class).
	self assert: ((packageDemoted classTagNamed: 'TAG1') classes includes: class).
	self assert: (packageDemoted extensionMethods includes: classOther>>#bar).	
	self assert: ((classOther>>#bar) protocol) equals: '*Test1-TAG1'.
	self assert: (packageDemoted classes	includesAll: {class. classOther}).! !

!RPackageTest methodsFor: 'tests - MC' stamp: ''!
testMcWorkingCopy

	| rPackage |
	rPackage := self organizer registerPackageNamed: #Test1.
	self assert: rPackage mcWorkingCopy equals: (MCWorkingCopy forPackage: (MCPackage new name: #Test1)).! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testAllUnsentMessages
	| package class1 class2 |
	
	package := (RPackage named: #Test1) register.
	
	class1 := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG'.
	class2 := self createNewClassNamed: 'TestClassOther' inCategory: 'Test1-TAG'.
	
	class1
		compile: 'nonexistingMethodName1 42';
		compile: 'nonexistingMethodName2 42'.
		
	class2
		compile: 'nonexistingMethodName1 42';
		compile: 'nonexistingMethodName3 42';
		compile: 'nonexistingMethodName4 class1 new nonexistingMethodName2'.
		
	self assert: package allUnsentMessages size equals: 3.
	
	self assert: package allUnsentMessages equals: (#('nonexistingMethodName1' 'nonexistingMethodName3' 'nonexistingMethodName4') collect: [:each | each asSymbol]) asSet.! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testAddClassFromTag
	| package1 package2 class |

	package1 := (self packageClass named: #Test1) register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG'.
	
	self assert: (package1 includesClass: class).
	
	package2 := (self packageClass named: #Test2) register.
	
	package2 addClass: class.
	
	self deny: (package1 includesClass: class).
	self assert: (package2 includesClass: class).	
	self assert: (package2 classTagNamed: #Test2 ifAbsent: [ nil ]) notNil.
	self assert: ((package2 classTagNamed: #Test2 ifAbsent: [ nil ]) includesClass: class)! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testAddClass
	| package1 package2 class done |

	package1 := (RPackage named: #Test1) register.
	done := 0.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG'.
	SystemAnnouncer uniqueInstance when: ClassRecategorized do: [ done := done + 1].
	
	self assert: (package1 includesClass: class).
	self assert: (package1 classTagNamed: #TAG ifAbsent: [ nil ]) notNil.
	self assert: ((package1 classTagNamed: #TAG ifAbsent: [ nil ]) includesClass: class).
	
	package2 := (RPackage named: #Test2) register.
	
	package2 addClass: class.
	
	self assert: done equals: 1.
	self deny: (package1 includesClass: class).
	self assert: (package2 includesClass: class).	
	self assert: (package2 classTagNamed: #Test2 ifAbsent: [ nil ]) notNil.
	self assert: ((package2 classTagNamed: #Test2 ifAbsent: [ nil ]) includesClass: class).! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testIsTestPackage

	|packages |
	packages := self createMockTestPackages.
	"Happy case: test package 'MockPackage-Tests' must contain -Tests suffix."
	self assert: packages first isTestPackage equals: true.
	
	"Package 'MockPackage-tests' is not test package, since it has lowercase suffix."
	self assert: packages second isTestPackage  equals: false.
	
	"Happy case: regular package 'MockPackage' without -Tests suffix is not a test package."
	self assert: packages third isTestPackage  equals: false.

	"Package 'MockPackage-Tests-Package' containting -Tests- in middle, so it is test package."
	self assert: packages fourth isTestPackage equals: true.
	
	"cleanup of inst.vars should be done in tearDown"! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testDemoteToRPackageNamed
	| package1 package2 class  |

	package1 := (self packageClass named: #'Test1-TAG1') register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG1'.
	class compile: 'foo ^42' classified: 'accessing'.

	package1 demoteToTagInPackageNamed: 'Test1'.

	self deny: (self packageClass organizer includesPackage: package1).
	package2 := self packageClass organizer packageNamed: 'Test1'.
	self assert: package2 notNil. 
	self assert: (package2 classes includes: class).
	self assert: ((package2 classTagNamed: 'TAG1') classes includes: class)! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testRenameToMakesMCDirty
	| package |
	
	package := (self packageClass named: #'Test1') register.
	self createNewClassNamed: 'TestClass' inCategory: 'Test1'.
	
	package renameTo: 'Test2'.! !

!RPackageTest methodsFor: 'tests - properties' stamp: ''!
testHasProperty
	| package testValue |
	
	testValue := Date today.
	package := self class package.
	
	package propertyAt: #testKeySelector put: testValue.
	self	assert: (package hasProperty: #testKeySelector).
	
	package removeProperty: #testKeySelector.
	self deny: (package hasProperty: #testKeySelector).! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testDemoteToRPackageNamedMultilevelPackage2
	| package1 package2  class  |

	package1 := (self packageClass named: #'Test1-TAG1-X1') register.
	class := self createNewClassNamed: 'TestClass' inCategory: 'Test1-TAG1-X1'.
	class compile: 'foo ^42' classified: 'accessing'.

	package1 demoteToTagInPackageNamed: 'Test1-TAG1'.

	self deny: (self packageClass organizer includesPackage: package1).
	package2 := self packageClass organizer packageNamed: 'Test1-TAG1'.
	self assert: package2 notNil. 
	self assert: (package2 classes includes: class).
	self assert: ((package2 classTagNamed: 'X1') classes includes: class).! !

!RPackageTest methodsFor: 'tests - queries' stamp: ''!
testHierarchyRoots
	| roots |
	roots := (RPackageOrganizer default packageNamed: #'RPackage-Tests') hierarchyRoots. 
	roots := roots collect: [ :each | each name ].
	#(RPackageTestCase)
		do: [ :each | roots includes: each ]! !

!RPackageTest methodsFor: 'tests - queries' stamp: ''!
testRoots
	| roots |
	roots := (RPackageOrganizer default packageNamed: #'RPackage-Tests') roots.
	roots := roots collect: [ :each | each name ].
	#(RPackageStringExtensionTest RPackageRenameTest TestRPackagePrequisites RPackageTestCase RPackageWithDoTest) do: [ :each | roots includes: each ]! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testActualClassTags
	| packageWithoutClassTags packageWithClassTags |
	packageWithoutClassTags := RPackageOrganizer default packageOf: StartupAction.
	self denyEmpty: packageWithoutClassTags classTags.
	self assertEmpty: packageWithoutClassTags actualClassTags.

	packageWithClassTags := RPackageOrganizer default packageOf: Object.
	self assert: packageWithClassTags actualClassTags equals: packageWithClassTags classTags! !

!RPackageTest methodsFor: 'tests' stamp: ''!
testAnonymousClassAndSelector
	"jgeidel test case from issue 12628."

	"Make sure we don't have a registration or a package for the method."

	| ghost method uPackage |
	ghost := Object newAnonymousSubclass.
	uPackage := self organizer packageNamed: #'_UnpackagedPackage'.
	method := ghost compiler compile: 'rpackagetest'.
	ghost addSelector: #rpackagetest withMethod: method.
	self deny: (uPackage includesDefinedSelector: #rpackagetest ofClass: ghost).
	self deny: (self organizer packageOfClassNamed: ghost name) notNil.
	ghost organization classify: #rpackagetest under: '*rpackagetest'! !

!RPackageTestCase commentStamp: ''!
Common superclass for RPackage related tests!
!RPackageTestCase methodsFor: 'accessing' stamp: ''!
allManagers

	^ MCWorkingCopy allManagers! !

!RPackageTestCase methodsFor: 'announcer handling' stamp: ''!
initializeAnnouncers
	oldSystemAnnouncer := SystemAnnouncer uniqueInstance.

	SystemAnnouncer announcer: (announcerForTest := SystemAnnouncer new).! !

!RPackageTestCase methodsFor: 'accessing' stamp: ''!
packageClass 
	"returns the system class that represents Packages"
	^ RPackage! !

!RPackageTestCase methodsFor: 'utilities' stamp: ''!
createNewTraitNamed: aName
	^ self createNewTraitNamed: aName inCategory: 'RPackageTest'! !

!RPackageTestCase methodsFor: 'accessing' stamp: ''!
organizer
	"This method will access the organizer that will temporarily swapped using the withOrganizer:do: method"
	^ self packageClass organizer! !

!RPackageTestCase methodsFor: 'utilities' stamp: ''!
createMockTestPackages

	^ self namesOfMockTestPackages collect: [:pName | self createNewPackageNamed: pName]! !

!RPackageTestCase methodsFor: 'utilities' stamp: ''!
namesOfMockTestPackages
	
	^ #( 'MockPackage-Tests' 'MockPackage-tests' 'MockPackage' 'MockPackage-Tests-Package')! !

!RPackageTestCase methodsFor: 'accessing' stamp: ''!
packageOrganizerClass 
	"returns the package organizer class"
	^ RPackageOrganizer! !

!RPackageTestCase methodsFor: 'announcer handling' stamp: ''!
restoreAnnouncers
	SystemAnnouncer announcer: oldSystemAnnouncer.! !

!RPackageTestCase methodsFor: 'utilities' stamp: ''!
createNewTraitNamed: aName inCategory: cat
	
	| cls |
	cls := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: aName;
			package:  cat;
			beTrait ].					

	createdClasses add: cls.
	createdCategories add: cat.
	^ cls! !

!RPackageTestCase methodsFor: 'utilities' stamp: ''!
createNewClassNamed: aName inPackage: p
	
	| cls |
	cls := self createNewClassNamed: aName.
	p addClassDefinition: cls.
	^ cls! !

!RPackageTestCase methodsFor: 'utilities' stamp: ''!
removePackage: aName
	self packageClass organizer basicUnregisterPackageNamed: aName.! !

!RPackageTestCase methodsFor: 'utilities' stamp: ''!
createNewPackageNamed: aName

	| pack |
	self removePackage: aName.
	pack := self packageClass named: aName.
	createdPackages add: pack.
	^ pack! !

!RPackageTestCase methodsFor: 'accessing' stamp: ''!
setupOrganizer
	^ self packageOrganizerClass basicNew initialize; debuggingName: 'Organizer for RPackageTest'; yourself! !

!RPackageTestCase methodsFor: 'running' stamp: ''!
runCase
	[
	self initializeAnnouncers.
	
	^ self packageClass 
		withOrganizer: self setupOrganizer
		do: [ 
			self resources do: [:each | each availableFor: self].
			self setUp.
			self performTest
			]
	] ensure: [ 
		self tearDown.
		self restoreAnnouncers.
		self cleanUpInstanceVariables
	]! !

!RPackageTestCase methodsFor: 'utilities' stamp: ''!
createNewClassNamed: aName inCategory: cat
	
	| cls |
	cls := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: aName;
			package: cat ].

	createdClasses add: cls.
	createdCategories add: cat.
	^ cls! !

!RPackageTestCase methodsFor: 'utilities' stamp: ''!
createNewTraitNamed: aName inPackage: p
	
	| cls |
	cls := self createNewTraitNamed: aName.
	p addClassDefinition: cls.
	^ cls! !

!RPackageTestCase methodsFor: 'utilities' stamp: ''!
createNewClassNamed: aName
	^ self createNewClassNamed: aName inCategory: 'RPackageTest'! !

!RPackageTestCase methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	createdClasses := OrderedCollection new.
	createdPackages := OrderedCollection new.
	createdCategories := Set new.! !

!RPackageTraitSynchronisationTest commentStamp: ''!
SUnit tests for RPackage trait synchronization
!
!RPackageTraitSynchronisationTest methodsFor: 'tests - operations on traits' stamp: ''!
testAddTraitAddItIntoPackageExactName
	
	|tmpPackage class|
	self addXCategory.
	self addXMatchCategory.

	tmpPackage := self organizer packageNamed: #XXXXX.
	class := self createNewTraitNamed: 'NewClass' inCategory: 'XXXXX'.

	self assert: (tmpPackage definesClass: class).
	self assert: tmpPackage equals: class package.! !

!RPackageTraitSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testRemoveMethodComingFromTraitDoesNotRemoveMethodFromTraitPackage
	"test that when we remove a class method coming from a trait, the method is not removed from the parent package of the trait"
	
	|XPackage YPackage class trait|
	self addXCategory.
	self addYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	trait := self createNewTraitNamed: 'NewTrait' inCategory: 'YYYYY'.
	
	self createMethodNamed: 'stubMethod' inClass: trait  inCategory: 'classic protocol'. 
	class setTraitComposition: trait asTraitComposition.
	
	class removeSelector: #stubMethod.
	self assert: (YPackage includesDefinedSelector: #stubMethod ofClass: trait). 
	self deny: (XPackage includesDefinedSelector: #stubMethod ofClass: class). ! !

!RPackageTraitSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testTraitCompositionMethodsArePackagedWithTheirTraits
	"test that when we remove a class method coming from a trait, the method is not removed from the parent package of the trait"
	
	|XPackage YPackage class trait|
	self addXCategory.
	self addYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	trait := self createNewTraitNamed: 'NewTrait' inCategory: 'YYYYY'.
	
	self createMethodNamed: 'stubMethod' inClass: trait  inCategory: 'classic protocol'. 
	class setTraitComposition: trait asTraitComposition.
	
	self assert: (YPackage includesDefinedSelector: #stubMethod ofClass: trait). 
	self deny: (XPackage includesDefinedSelector: #stubMethod ofClass: class).! !

!RPackageTraitSynchronisationTest methodsFor: 'tests - operations on traits' stamp: ''!
testAddTraitUpdateTheOrganizerMappings
	"test that when we add a Trait, the organizer 'classPackageMapping' dictionary is updated, so that the trait is linked to its package and so that we can access its owning package"

	|tmpPackage class|
	self addXCategory.
	
	tmpPackage := self organizer packageNamed: #XXXXX.
	class := self createNewTraitNamed: 'NewClass' inCategory: 'XXXXX'.
	 
	self assert: class package equals: tmpPackage! !

!RPackageTraitSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testAddMethodByUsingATraitDoesNotAddTheMethodToThePackage
	"test that when a method is added to a class bu using a trait, this method is not imported in the parent package of the class"

	| XPackage YPackage class trait |
	self addXCategory.
	self addYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	trait := self createNewTraitNamed: 'NewTrait' inCategory: 'YYYYY'.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	self createMethodNamed: 'stubMethod' inClass: trait inCategory: 'trait category'.

	self assertEmpty: XPackage methods.
	self denyEmpty: YPackage methods.
	class addToComposition: trait.
	self assert: (YPackage includesDefinedSelector: #stubMethod ofClass: trait).
	self assertEmpty: XPackage methods! !

!RPackageTraitSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testRemoveTraitMethod
	"test that when we remove a method from a trait used by a class, the method is removed from the trait package normally"
	
	|XPackage YPackage class trait|
	self addXCategory.
	self addYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	trait := self createNewTraitNamed: 'NewTrait' inCategory: 'YYYYY'.
	self createMethodNamed: 'stubMethod' inClass: trait  inCategory: 'classic protocol'. 
	class setTraitComposition: trait asTraitComposition.
	
	trait removeSelector: #stubMethod.
	self deny: (YPackage includesSelector: #stubMethod ofClass: trait). 
	self deny: (XPackage includesSelector: #stubMethod ofClass: class).! !

!RPackageTraitSynchronisationTest methodsFor: 'tests - operations on traits' stamp: ''!
testAddTraitAddItIntoPackageBestMatchName
	
	|tmpPackage class|
	self addXCategory.
	self addXMatchCategory.
	
	tmpPackage := self organizer packageNamed: #'XXXXX'.
	class := self createNewTraitNamed: 'NewClass' inCategory: 'XXXXX-YYYY'.

	self assert: (tmpPackage definesClass: class).
	self assert: tmpPackage equals: class package.! !

!RPackageTraitSynchronisationTest methodsFor: 'tests - operations on methods' stamp: ''!
testRemoveTraitMethodOverridenByClassDoesRemoveMethodFromClassPackage
	"test that when we remove a class method overriding the one from a trait, the method is removed from the class package"
	
	|XPackage YPackage class trait|
	self addXCategory.
	self addYCategory.
	XPackage := self organizer packageNamed: #XXXXX.
	YPackage := self organizer packageNamed: #YYYYY.
	
	class := self createNewClassNamed: 'NewClass' inCategory: 'XXXXX'.
	trait := self createNewTraitNamed: 'NewTrait' inCategory: 'YYYYY'.
	
	self createMethodNamed: 'stubMethod' inClass: trait  inCategory: 'classic protocol'. 
	class setTraitComposition: trait asTraitComposition.
	self createMethodNamed: 'stubMethod' inClass: class  inCategory: 'classic protocol'. 
	
	class removeSelector: #stubMethod.
	self deny: (XPackage includesDefinedSelector: #stubMethod ofClass: class). ! !

!RPackageTraitTest commentStamp: ''!
SUnit tests for RPackage!
!RPackageTraitTest methodsFor: 'tests' stamp: ''!
testPackageOfClassMethodFromTraitIsTraitPackage
	"test that a class method coming from a trait is packaged in the trait package"

	self assert: (a1 >> #traitMethodDefinedInP4 packageFromOrganizer: self packageClass organizer) equals: p4.
	self assert: (a1 >> #traitMethodDefinedInP5 packageFromOrganizer: self packageOrganizerClass default) equals: p5! !

!RPackageTraitTest methodsFor: 'setup' stamp: ''!
p5Name

	^ 'RPackageTestP5'! !

!RPackageTraitTest methodsFor: 'tests' stamp: ''!
testStartingSituation
	
	self deny: (p5 includesClass: a1).
	self assert: (p4 includesClass: a1).
	self assert: (p4 includesClass: t1).
	self assert: (p4 definesOrExtendsClass: a1).
	self assert: (p5 includesClass: t2).! !

!RPackageTraitTest methodsFor: 'tests' stamp: ''!
testPackageOfClassMethodFromTraitExtensionIsExtendingPackage
	"The package of a method defined in atrait but package in another package than the extended trait is the 
	package containing the extension."

	"The package of a method in A1 (which is coming from the trait T1 used by A1) is the package of T1"

	self assert: (a1 >> #traitMethodExtendedFromP4 packageFromOrganizer: self packageClass organizer) equals: p4.
	"The package of a method in A1 (which is coming from the trait T1 used by A1 but extended in package T2) is the package of T2"
	self assert: (a1 >> #traitMethodExtendedFromP6 packageFromOrganizer: self packageClass organizer) equals: p6! !

!RPackageTraitTest methodsFor: 'tests' stamp: ''!
testPackageOfClassMethodIsClassPackage
	"The package of a local method (not defined in a trait) is the package of its class"

	self assert: (a1 >> #localMethodDefinedInP1 packageFromOrganizer: self packageClass organizer) equals: p4.
	self assert: (a1 >> #anotherLocalMethodDefinedInP1 packageFromOrganizer: self packageOrganizerClass default) equals: p4.
	self assert: (a1 >> #anotherLocalMethodDefinedInP1 packageFromOrganizer: self packageClass organizer) equals: p4! !

!RPackageTraitTest methodsFor: 'setup' stamp: ''!
p4Name

	^ 'RPackageTestP4'! !

!RPackageTraitTest methodsFor: 'tests' stamp: ''!
testPackageOfTraitMethodIsTraitPackage
	"The package of a trait method is the package of its trait."

	self assert: (a1 >> #traitMethodDefinedInP5 packageFromOrganizer: self packageClass organizer) equals: p5.
	self assert: (a1 >> #traitMethodDefinedInP5 packageFromOrganizer: self packageOrganizerClass default) equals: p5.
	self assert: (a1 >> #traitMethodDefinedInP4 packageFromOrganizer: self packageClass organizer) equals: p4! !

!RPackageTraitTest methodsFor: 'setup' stamp: ''!
p6Name

	^ 'RPackageTestP6'! !

!RPackageTraitTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	
	p4 := self createNewPackageNamed: self p4Name.  
	p5 := self createNewPackageNamed: self p5Name. 
	p6 := self createNewPackageNamed: self p6Name.  
	
	a1 :=  self createNewClassNamed: #A1DefinedInP1 inPackage: p4.
	
	"a1 defines two normal = local methods"
	a1 compileSilently: 'localMethodDefinedInP1 ^ #methodDefinedInP1'.
	p4 addMethod: (a1>>#localMethodDefinedInP1).
	a1 compileSilently: 'anotherLocalMethodDefinedInP1 ^ #anotherMethodDefinedInP1'.
	p4 addMethod: (a1>>#anotherLocalMethodDefinedInP1).
	
	t1 := self createNewTraitNamed: #TraitInPackageP4 inPackage: p4.
	t1 compileSilently: 'traitMethodDefinedInP4 ^ #traitMethodDefinedInP4'.
	p4 addMethod: (t1>>#traitMethodDefinedInP4).
	
	"P6 defines a new method extension on T1 (packaged in p4)"
	t1 compileSilently: 'traitMethodExtendedFromP6 ^ #traitMethodExtendedFromP6' classified: ('*',self p6Name). 
	p6 addMethod: (t1>>#traitMethodExtendedFromP6).
	
	t2 := self createNewTraitNamed: #TraitInPackageP5 inPackage: p5.
	t2 compileSilently: 'traitMethodDefinedInP5 ^ #traitMethodDefinedInP5'.
	
	p5 addMethod: (t2 >> #traitMethodDefinedInP5).  
	
	"Here P4 extends T2 from P5 with a new method"
	t2 compileSilently: 'traitMethodExtendedFromP4 ^ #traitMethodExtendedFromP4' classified: ('*',self p4Name). 
	p4 addMethod: (t2 >> #traitMethodExtendedFromP4).
	
	a1 setTraitComposition: (t1 + t2) asTraitComposition.
	
	"a2 compileSilently: 'methodDefinedInP1 ^ #methodDefinedInP1'.
	p1 addMethod: (a2>>#methodDefinedInP1).
	
	a2 compileSilently: 'methodDefinedInP2 ^ #methodDefinedInP2'.
	p2 addMethod: (a2>>#methodDefinedInP2).
	
	a2 compileSilently: 'methodDefinedInP3 ^ #methodDefinedInP3'.
	p3 addMethod: (a2>>#methodDefinedInP3).

	a2 class compileSilently: 'classSideMethodDefinedInP3 ^ #classSideMethodDefinedInP3'.
	p3 addMethod: (a2 class>>#classSideMethodDefinedInP3)."! !

!RPackageUnregistered commentStamp: ''!
I am a public announcement sent when a new RPackage is unregistred ( kind  of removed from the system )!
!RPackageWithDoTest commentStamp: ''!
SUnit tests for RPackage!
!RPackageWithDoTest methodsFor: 'tests - simple ensuring' stamp: ''!
testDo2
	[ self do: [ self error ] ]
		on: Error
		do: [ :ex |  ].
	"necessary else SUnit believes that the error is not handled"
	self assert: x equals: 3! !

!RPackageWithDoTest methodsFor: 'tests - simple ensuring' stamp: ''!
doC: aBlock 
	
	x := 5.
	[aBlock value] ifCurtailed: [x :=3]! !

!RPackageWithDoTest methodsFor: 'tests' stamp: ''!
packageClass
	^ RPackage! !

!RPackageWithDoTest methodsFor: 'tests - simple ensuring' stamp: ''!
testDo
	[ self do: [ Error signal ] ]
		on: Error
		do: [ :ex |  ].
	"necessary else SUnit believes that the error is not handled"
	self assert: x equals: 3! !

!RPackageWithDoTest methodsFor: 'tests' stamp: ''!
testOrganizerContainsPackages
	self assert: self packageOrganizerClass default packageNames isNotEmpty description: 'RPackageOrganizer should contains package names since an image should at least contains one package.'.
	self assert: self packageOrganizerClass default packages isNotEmpty description: 'RPackageOrganizer should not be empty since an image should at least contains one package.'! !

!RPackageWithDoTest methodsFor: 'tests' stamp: ''!
packageOrganizerClass
	^ RPackageOrganizer! !

!RPackageWithDoTest methodsFor: 'tests' stamp: ''!
testWithDoIsCorrectlyReinstallingDefault
	| current empty |
	current := self packageOrganizerClass default.
	empty := self packageOrganizerClass basicNew initialize.
	empty debuggingName: 'empty from PackageWithDoTest'.
	self packageClass
		withOrganizer: empty
		do: [ self assert: (self organizerAnnouncer hasSubscriber: empty) description: 'During #withOrganizer:do:, the system announcer should have the organizer as parameter in its subscriber.'.
			self deny: (self organizerAnnouncer hasSubscriber: current) description: 'During #withOrganizer:do:, the system announcer shouldn''t have the default organizer in its subscriber.' ].
	self assert: (self organizerAnnouncer hasSubscriber: current) description: 'After the use of #withOrganizer:do:, the default organizer should be reinstalled in system announcer subscribers.'.
	self deny: (self organizerAnnouncer hasSubscriber: empty) description: 'After the use of #withOrganizer:do:, the empty organizer should be removed from the system announcer subscribers.'! !

!RPackageWithDoTest methodsFor: 'tests - simple ensuring' stamp: ''!
do: aBlock 

	x := 5.
	[aBlock value] ensure: [x :=3.]! !

!RPackageWithDoTest methodsFor: 'tests - simple ensuring' stamp: ''!
testDoC
	[ self doC: [ self error ] ]
		on: Error
		do: [ :e |  ].
	"necessary else SUnit believes that the error is not handled"
	self assert: x equals: 3! !

!RPackageWithDoTest methodsFor: 'tests' stamp: ''!
testWithDoIsCorrectlyReinstallingDefaultEvenIfHalt
	| current empty |
	current := self packageOrganizerClass default.
	empty := self packageOrganizerClass basicNew initialize.
	[ self packageClass
		withOrganizer: empty
		do: [ self assert: (self organizerAnnouncer hasSubscriber: empty) description: 'During #withOrganizer:do:, the system announcer should have the organizer as parameter in its subscriber.'.
			self deny: (self organizerAnnouncer hasSubscriber: current) description: 'During #withOrganizer:do:, the system announcer shouldn''t have the default organizer in its subscriber.'.
			self error ] ]
		on: Error
		do: [ :ex |  ].
	self assert: (self organizerAnnouncer hasSubscriber: current) description: 'After the use of #withOrganizer:do:, the default organizer should be reinstalled in system announcer subscribers.'.
	self deny: (self organizerAnnouncer hasSubscriber: empty) description: 'After the use of #withOrganizer:do:, the empty organizer should be removed from the system announcer subscribers.'! !

!RPackageWithDoTest methodsFor: 'tests - simple ensuring' stamp: ''!
doOnDo: aBlock 
	
	x := 5.
	[aBlock value.
	self ensure] on: Error do:  [:ex | self ensure].! !

!RPackageWithDoTest methodsFor: 'accessing' stamp: ''!
organizerAnnouncer
	^ SystemAnnouncer uniqueInstance private! !

!RPackageWithDoTest methodsFor: 'tests - simple ensuring' stamp: ''!
ensure

	x := 3! !

!RPackageWithDoTest methodsFor: 'tests - simple ensuring' stamp: ''!
testOnDo
	self doOnDo: [ self error ].
	self assert: x equals: 3.
	x := 77.
	self doOnDo: [ x = 21 ].
	self assert: x equals: 3! !

!RSAbstractAnimation commentStamp: ''!
I am the abstract class that defines animations for roassal3!
!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
startPauseTime
	^ startPauseTime! !

!RSAbstractAnimation methodsFor: 'actions' stamp: ''!
stop
	isRunning := false.
	hasCompleted := true.! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
endTime
	^ endTime! !

!RSAbstractAnimation methodsFor: 'actions' stamp: ''!
toggle
	self isPaused 
		ifTrue: [ self continue ]
		ifFalse: [ self pause ]! !

!RSAbstractAnimation methodsFor: 'testing' stamp: ''!
hasInteraction: anInteractionClass
	"Return true or false if the receiver has an interaction. Note that the argument has to be an interaction class. And not an event"
	self announcer subscriptions ifNil: [ ^ false ].
	^ self announcer subscriptions handleSubscriberClass: anInteractionClass! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
duration
	^ self subclassResponsibility! !

!RSAbstractAnimation methodsFor: 'refreshing' stamp: ''!
refresh
	self hasCompleted
		ifTrue: [ ^ self ].
	self isDelayDone
		ifFalse: [ ^ self ].
	self isPaused 
		ifTrue: [ ^ self ].
	self step.
	! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
canvas: aCanvas
	canvas := aCanvas! !

!RSAbstractAnimation methodsFor: 'refreshing' stamp: ''!
step
	self subclassResponsibility! !

!RSAbstractAnimation methodsFor: 'removing' stamp: ''!
removeInteractionIfPresent: anInteractionClass
	"Remove all the callbacks associated to the interaction."
	(self hasInteraction: anInteractionClass) ifFalse: [ ^ self ].
	(self getInteractionsForClass: anInteractionClass) do: [ :int | self announcer unsubscribe: int ]! !

!RSAbstractAnimation methodsFor: 'api - running' stamp: ''!
repeat
	"make receiver to be a repeating timer"
	self loops: Float infinity! !

!RSAbstractAnimation methodsFor: 'testing' stamp: ''!
isRunning 
	^ isRunning! !

!RSAbstractAnimation methodsFor: 'private' stamp: ''!
startStep
	currentLoop 
		ifNil: [ currentLoop := 0 ].
	startLoopTime 
		ifNil: [ startLoopTime := self currentTime ].! !

!RSAbstractAnimation methodsFor: 'actions' stamp: ''!
continue
	isPaused ifFalse: [ ^ self ].
	isPaused := false.
	endPauseTime := self currentTime.
	pauseTime := pauseTime + endPauseTime - startPauseTime.! !

!RSAbstractAnimation methodsFor: 'announcer' stamp: ''!
announce: anEvent
	| a |
	a := self privateAnnouncer.
	a ifNil: [ ^ self ].
	a announce: anEvent value! !

!RSAbstractAnimation methodsFor: 'public' stamp: ''!
executeWithoutAnnouncer: aBlock
	| ann |
	ann := self privateAnnouncer.
	self announcer: nil.
	aBlock value.
	self announcer: ann.! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
currentLoop
	^ currentLoop! !

!RSAbstractAnimation methodsFor: 'testing' stamp: ''!
hasCompleted
	 ^ hasCompleted! !

!RSAbstractAnimation methodsFor: 'private' stamp: ''!
loopDone
	currentLoop := currentLoop + 1.
	startPauseTime := endPauseTime := pauseTime := 0.
	startLoopTime := self currentTime.
	self announce: (RSAnimationLoopEvent new animation: self).! !

!RSAbstractAnimation methodsFor: 'private' stamp: ''!
updateHasCompleted
	hasCompleted ifFalse: [ hasCompleted := currentLoop >= loops ].! !

!RSAbstractAnimation methodsFor: 'announcer' stamp: ''!
privateAnnouncer
	^ announcer! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
allDuration
	^  self duration * (self isRepeating
		ifTrue: [ 1 ]
		ifFalse: [ self loops ])! !

!RSAbstractAnimation methodsFor: 'initialization' stamp: ''!
reset
	isRunning := false.
	self noRepeat.
	hasCompleted := false.
	isPaused := false.
	currentLoop := nil.
	startLoopTime := nil.
	startPauseTime := 0.
	endPauseTime := 0.
	pauseTime := 0.! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
canvas
	^ canvas ! !

!RSAbstractAnimation methodsFor: 'private' stamp: ''!
currentTime
	^ canvas currentTime! !

!RSAbstractAnimation methodsFor: 'announcer' stamp: ''!
announcer
	^ self privateAnnouncer ifNil: [ 
		| a |
		a := Announcer new.
		self announcer: a.
		a ]! !

!RSAbstractAnimation methodsFor: 'testing' stamp: ''!
isDelayDone
	delay ifNil: [ ^ true ].
	^ startTime + delay < self currentTime.! !

!RSAbstractAnimation methodsFor: 'api - running' stamp: ''!
noRepeat
	self loops: 1! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
startLoopTime
	^ startLoopTime ! !

!RSAbstractAnimation methodsFor: 'announcer' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject
	self announcer when: anAnnouncementClass send: aSelector to: anObject! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
delay 
	^ delay! !

!RSAbstractAnimation methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self reset.
	canvas := RSDefaultTimer new.! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
endPauseTime
	^ endPauseTime! !

!RSAbstractAnimation methodsFor: 'actions' stamp: ''!
pause
	isPaused ifTrue: [ ^ self ].
	isPaused := true.
	startPauseTime := self currentTime.
	! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
delay: aDuration
	delay := aDuration asMilliSeconds! !

!RSAbstractAnimation methodsFor: 'announcer' stamp: ''!
when: event do: aBlock
	self announcer when: event do: aBlock! !

!RSAbstractAnimation methodsFor: 'announcer' stamp: ''!
announcementClasses
	^ RSAnimationEvent subclasses! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
loops
	^ loops! !

!RSAbstractAnimation methodsFor: 'announcer' stamp: ''!
getInteractionsForClass: anInteractionClass
	"Return the Announcement subscriptions for the interaction"
	^ self announcer subscriptions getInteractionsForClass: anInteractionClass! !

!RSAbstractAnimation methodsFor: 'announcer' stamp: ''!
announcer: anAnnouncer
	announcer := anAnnouncer! !

!RSAbstractAnimation methodsFor: 'testing' stamp: ''!
isPaused
	^ isPaused! !

!RSAbstractAnimation methodsFor: 'testing' stamp: ''!
isRepeating
	^ loops isInfinite.! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
loops: aNumber
	self assert: aNumber >= 1 description: 'The number of times to repeat this animation'.
	loops := aNumber! !

!RSAbstractAnimation methodsFor: 'dependencies' stamp: ''!
release
	self class instVarNames do: [ :n | self instVarNamed: n put: nil ]! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
pauseTime
	^ pauseTime! !

!RSAbstractAnimation methodsFor: 'actions' stamp: ''!
remove
	canvas animations remove: self ifAbsent: [  ].
	endTime := self currentTime.
	isRunning := false.
	currentLoop := nil.
	startLoopTime := nil.
	self announce: (RSAnimationEndEvent new animation: self)
	! !

!RSAbstractAnimation methodsFor: 'actions' stamp: ''!
start
	isRunning := true.
	hasCompleted := false.
	startTime := self currentTime.
	self announce: (RSAnimationStartEvent new animation: self)! !

!RSAbstractAnimation methodsFor: 'accessing' stamp: ''!
startTime
	^ startTime ! !

!RSAbstractAnimation class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSAbstractAnimation class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSAbstractAnimation class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSAbstractAnimation class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSAbstractAnimation class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSAbstractAnimation class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSAbstractAnimation class methodsFor: 'accessing - defaults' stamp: ''!
defaultDuration
	^ self subclassResponsibility! !

!RSAbstractAnimation class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSAbstractAnimation class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSAbstractAnimation class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSAbstractAnimation class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSAbstractAnimation class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSAbstractAnimation class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSAbstractAnimation class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSAbstractAnimation class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSAbstractAnimation class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSAbstractAnimation class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSAbstractAnimation class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSAbstractAnimation class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSAbstractAnimation class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSAbstractAnimation class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSAbstractAnimation class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSAbstractAnimation class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RSAbstractAnimation class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RSAbstractAnimation class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RSAbstractAnimation class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSAbstractAnimation class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSAbstractAnimation class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSAbstractAnimation class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSAbstractAnimation class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSAbstractBarPlot commentStamp: ''!
The abstract class for bar plots!
!RSAbstractBarPlot methodsFor: 'hooks' stamp: ''!
computeRectagleFor: aPoint index: index
	^ self subclassResponsibility! !

!RSAbstractBarPlot methodsFor: 'accessing' stamp: ''!
barOffset: aNumber
	barOffset := aNumber! !

!RSAbstractBarPlot methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		gapRatio: 0.1;
		barOffset: 0.! !

!RSAbstractBarPlot methodsFor: 'accessing' stamp: ''!
barOffset
	^ barOffset! !

!RSAbstractBarPlot methodsFor: 'accessing' stamp: ''!
gapRatio: aNumber
	"aNumber between 0 and 1"
	gapRatio := aNumber! !

!RSAbstractBarPlot methodsFor: 'accessing' stamp: ''!
barScale
	^ self subclassResponsibility! !

!RSAbstractBarPlot methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	| index |
	self checkAssertion.
	index := 1.
	bars := xValues collect: [ :xt | 
		| yt bar |
		yt := yValues at: index.
		bar := self createBarFor: xt@yt index: index.
		index := index + 1.
		bar ] as: RSGroup.
	canvas addAll: bars.
! !

!RSAbstractBarPlot methodsFor: 'accessing' stamp: ''!
createdShapes
	^ bars! !

!RSAbstractBarPlot methodsFor: 'hooks' stamp: ''!
modelFor: aPoint
	^ self subclassResponsibility! !

!RSAbstractBarPlot methodsFor: 'accessing' stamp: ''!
bars
	^ bars! !

!RSAbstractBarPlot methodsFor: 'initialization' stamp: ''!
defaultShape
	^ RSBox new noPaint! !

!RSAbstractBarPlot methodsFor: 'testing' stamp: ''!
isBarPlot
	^ true! !

!RSAbstractBarPlot methodsFor: 'accessing' stamp: ''!
gapRatio
	^ gapRatio! !

!RSAbstractBarPlot methodsFor: 'accessing' stamp: ''!
barSize: aBarWidth
	"Set the width of the bar"
	barSize := aBarWidth! !

!RSAbstractBarPlot methodsFor: 'accessing' stamp: ''!
barSize
	"Return the width of each bar"
	^ barSize ifNil: [ self barScale rangeBand ]! !

!RSAbstractBarPlot methodsFor: 'rendering' stamp: ''!
createBarFor: aPoint index: index
	^ self shape copy
		model: (self modelFor: aPoint);
		color: self computeColor;
		fromRectangle: (self computeRectagleFor: aPoint index: index);
		yourself! !

!RSAbstractBinning commentStamp: ''!
source from

https://www.answerminer.com/blog/binning-guide-ideal-histogram!
!RSAbstractBinning methodsFor: 'hooks' stamp: ''!
computeSizeFor: values
	^ self subclassResponsibility! !

!RSAbstractCPAPController commentStamp: ''!
I apply the attach point, then I return an array with the control points for the current edge.

- controlPointsFrom:to: is an abstract method, recives 2 points and it should return a collection of points!
!RSAbstractCPAPController methodsFor: 'hooks' stamp: ''!
controlPointsFrom: fromPoint to: toPoint
	^ self subclassResponsibility! !

!RSAbstractCPAPController methodsFor: 'hooks' stamp: ''!
controlPointsFor: aLine
	| ap |
	ap := aLine attachPoint.
	^ self
		controlPointsFrom: (ap startingPointOf: aLine)
		to: (ap endingPointOf: aLine).! !

!RSAbstractCPAPController class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RSAbstractCPAPController! !

!RSAbstractCPController commentStamp: ''!
My subclasses can determine the control points for an object usefull for the update process of lines/edges with control points

- controlPointsFor: is an abstract method, recibes an edge and it should return a collection of points!
!RSAbstractCPController methodsFor: 'hooks' stamp: ''!
controlPointsFor: aLine
	"return an array of points generated from the edge"
	^ self subclassResponsibility ! !

!RSAbstractCPController class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RSAbstractCPController! !

!RSAbstractCanvasInteraction commentStamp: ''!
Subclasses of myself are interaction for the view.!
!RSAbstractCanvasInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	self subclassResponsibility! !

!RSAbstractCanvasMonitorInteraction commentStamp: ''!
I am an interaction for RSView, I can add to the a fixed shape that contains basic information about

Frames per second, this number show the quantity of frames rendered. useful to debug animations!
!RSAbstractCanvasMonitorInteraction methodsFor: 'update' stamp: ''!
updateShape
	self subclassResponsibility! !

!RSAbstractCanvasMonitorInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self initializeShape.! !

!RSAbstractCanvasMonitorInteraction methodsFor: 'accessing' stamp: ''!
lastFrameCPUConsumption
	| res current |
	current := self currentTime.
	lastFrameEndTime ifNil: [ 
		lastFrameEndTime := current ].
	res := (current - lastFrameEndTime) * 1e-3.
	lastFrameEndTime := current.
	^ res! !

!RSAbstractCanvasMonitorInteraction methodsFor: 'initialization' stamp: ''!
initializeShape
	self subclassResponsibility.! !

!RSAbstractCanvasMonitorInteraction methodsFor: 'accessing' stamp: ''!
shape
	^ shape! !

!RSAbstractCanvasMonitorInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	| location |
	self assert: shape notNil description: 'Define your monitor shape'.
	shape isFixed: true.
	aCanvas addShape: shape. 
	location := RSLocation new inner; bottom; left; offset: 10@0.
	canvas := aCanvas.
	aCanvas newAnimation
		repeat;
		onStepDo: [ :t |
			self updateShape.
			location move: shape on: aCanvas basicRectangle ].! !

!RSAbstractCanvasMonitorInteraction methodsFor: 'accessing' stamp: ''!
shape: aShape
	shape := aShape! !

!RSAbstractCanvasMonitorInteraction methodsFor: 'accessing' stamp: ''!
currentTime
	^ canvas currentTime! !

!RSAbstractCanvasMonitorInteraction methodsFor: 'accessing' stamp: ''!
lastFramePerSecond
	| delta |
	delta := self lastFrameCPUConsumption.
	^ (1.0 / (delta max: 0.001) ) asInteger! !

!RSAbstractChartPlot commentStamp: ''!
TODO!
!RSAbstractChartPlot methodsFor: 'accessing' stamp: ''!
chart
	^ chart! !

!RSAbstractChartPlot methodsFor: 'rendering' stamp: ''!
createXScale
	| padding |
	xScale ifNil: [ xScale := NSScale linear ].
	xScale class = NSOrdinalScale ifTrue: [ ^ self ].
	padding := chart padding x.
	xScale
		domain:
			{chart minValueX.
			chart maxValueX};
		range:
			{0 + padding.
			chart extent x - padding}! !

!RSAbstractChartPlot methodsFor: 'accessing' stamp: ''!
yScale: aScale
	yScale := aScale! !

!RSAbstractChartPlot methodsFor: 'rendering' stamp: ''!
createYScale
	| padding |
	yScale ifNil: [ yScale := NSScale linear ].
	yScale class = NSOrdinalScale ifTrue: [ ^ self ].
	padding := chart padding y.
	yScale
		domain:
			{chart minValueY.
			chart maxValueY};
		range:
			{0 - padding.
			chart extent y negated + padding }
! !

!RSAbstractChartPlot methodsFor: 'rendering' stamp: ''!
beforeRenderingIn: aChart
	"do nothing here"! !

!RSAbstractChartPlot methodsFor: 'accessing' stamp: ''!
yScale
	^ yScale! !

!RSAbstractChartPlot methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	"Need to be overridden in subclasses. This methods has to be use trachel to enrich a visualization"
	self subclassResponsibility! !

!RSAbstractChartPlot methodsFor: 'accessing' stamp: ''!
chart: aChart
	chart := aChart! !

!RSAbstractChartPlot methodsFor: 'accessing' stamp: ''!
createdShapes
	^ self subclassResponsibility! !

!RSAbstractChartPlot methodsFor: 'rendering' stamp: ''!
spine
	"Return the Trachel shape that describe the spine"
	^ (chart decorations
		detect: [ :d | d class == RSChartSpineDecoration ]
		ifNone: [ self error: 'No spine is added in the plt, you need to add one' ])
		shape! !

!RSAbstractChartPlot methodsFor: 'rendering' stamp: ''!
addShape: aShape
	"Add a shape to the canvas"
	chart canvas add: aShape! !

!RSAbstractChartPlot methodsFor: 'accessing' stamp: ''!
xScale
	^ xScale! !

!RSAbstractChartPlot methodsFor: 'accessing' stamp: ''!
xScale: aScale
	xScale := aScale! !

!RSAbstractChartPopupBuilder commentStamp: ''!
Abstract class to descripbe how to create a popup for a given position!
!RSAbstractChartPopupBuilder methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!RSAbstractChartPopupBuilder methodsFor: 'accessing' stamp: ''!
position: aPoint
	position := aPoint! !

!RSAbstractChartPopupBuilder methodsFor: 'hooks' stamp: ''!
shapeFor: aRSChart
	^ self subclassResponsibility! !

!RSAbstractChartTest methodsFor: 'tests' stamp: ''!
classToTest
	self subclassResponsibility! !

!RSAbstractChartTest methodsFor: 'tests' stamp: ''!
testWithOnePlotWithTitle

	| p |
	p := self classToTest new x: #(1 2 3) y: #(1 2 3).
	chart addPlot: p.
	self assert: chart numberOfPlots equals: 1.
	chart title: 'Hello World'.
	chart build.
	
	self assert: chart plots size equals: 1.
	self assert: chart plots first equals: p.
	self assert: p chart equals: chart! !

!RSAbstractChartTest methodsFor: 'tests' stamp: ''!
testWithOnePlot

	| p |
	p := self classToTest new x: #(1 2 3) y: #(1 2 3).
	chart addPlot: p.
	self assert: chart numberOfPlots equals: 1.
	chart build.
	
	self assert: chart plots size equals: 1.
	self assert: chart plots first equals: p.
	self assert: p chart equals: chart! !

!RSAbstractChartTest methodsFor: 'tests' stamp: ''!
testBasic

	self assert: chart numberOfPlots equals: 0! !

!RSAbstractChartTest methodsFor: 'tests' stamp: ''!
testEmptyPlot

	| p |
	p := self classToTest new x: #(0) y: #(0).
	chart addPlot: p.
	chart addDecoration: (RSVerticalTick new integer fontSize: 10; doNotUseNiceLabel).
	chart addDecoration: (RSHorizontalTick new  integer fontSize: 10; doNotUseNiceLabel).
	chart build.! !

!RSAbstractChartTest methodsFor: 'tests' stamp: ''!
testOpening
	| x |
	chart := RSChart new.
	x := 0 to: 2 by: 1 / 100.
	chart addPlot: (self classToTest new x: x y: x).
	chart addPlot: (self classToTest new x: x y: (x collect: #squared)).
	chart addPlot: (self classToTest new x: x y: (x collect: [ :v | v * v * v ])).
	chart build.
	chart show delete! !

!RSAbstractChartTest methodsFor: 'tests' stamp: ''!
testWithOnePlotWithTitleAndTitleOnAxes

	| p |
	p := self classToTest new x: #(1 2 3) y: #(1 2 3).
	chart addPlot: p.
	chart xlabel: 'X Axis'.
	chart ylabel: 'Y Axis'.
	self assert: chart numberOfPlots equals: 1.
	chart title: 'Hello World'.
	chart build.
	
	self assert: chart plots size equals: 1.
	self assert: chart plots first equals: p.
	self assert: p chart equals: chart! !

!RSAbstractChartTest methodsFor: 'tests' stamp: ''!
testWithTwoPlots

	| p1 p2 |
	p1 := self classToTest new x: #(1 2 3) y: #(1 2 3).
	p2 := self classToTest new x: #(-1 0 1) y: #(-2 0 2).
	chart addPlot: p1.
	chart addPlot: p2.
	self assert: chart numberOfPlots equals: 2.

	self assert: chart minValueX equals: -1.
	self assert: chart maxValueX equals: 3.
	self assert: chart maxValueY equals: 3.
	self assert: chart minValueY equals: -2.! !

!RSAbstractChartTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	chart := RSChart new.
	! !

!RSAbstractChartTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self =  RSAbstractChartTest! !

!RSAbstractCircleLayout commentStamp: ''!
TODO!
!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
initialAngle
	"Return the initial angle, in radian"
	^ initialAngle! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
initialIncrementalAngleInDegree: aNumberInDegree
	self initialIncrementalAngle: aNumberInDegree * Float pi / 180! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
initialIncrementalAngle: aNumberInRadian
	initialIncrementalAngle := aNumberInRadian! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
initialAngleInDegree: aNumber
	"Set the initial angle in radian"
	self initialAngle: aNumber * Float pi / 180! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
initialIncrementalAngle
	"Return the initial incremental angle"
	^ initialIncrementalAngle! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
initialRadius: aNumber
	"Set the radius of the circle"
	initialRadius := aNumber! !

!RSAbstractCircleLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	"Initialize a newly created instance. This method must answer the receiver."
	
	super initialize.
	self scaleBy: 11.
	
	"Represent the initial angle to place the elements"
	initialAngle := 0.
	
	"Distance of the circle. If it is 0 when entering doExecute, then it is computed"
	initialRadius := 0.
	
	"0 means that it is computed, and not set by the user"
	initialIncrementalAngle := 0.! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
scaleBy: aNumber
	factor := aNumber! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
initialRadius
	"Return the radius in pixels of the circle"
	^ initialRadius! !

!RSAbstractCircleLayout methodsFor: 'hook' stamp: ''!
computeRadiusFor: elements
	"Return the radius of the circle. If none has been set (i.e., initialRadius = 0), then it is computed as the scale factor times the number of elements"
	^ initialRadius = 0 
		ifTrue: [ elements size * self scaleFactor ]
		ifFalse: [ initialRadius ]! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
initialAngleInDegree 
	"Return the initial angle in degree"
	^ self initialAngle * 180 / Float pi! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
initialAngle: aFloat
	"aFloat is an angle in Radian."
	initialAngle := aFloat! !

!RSAbstractCircleLayout methodsFor: 'hook' stamp: ''!
computeIncrementalAngleFor: elements
	"Return the value _in radian_ of the incremental angle"
	
	^ initialIncrementalAngle = 0
		ifTrue: [ 2 * Float pi / elements size ]
		ifFalse: [ initialIncrementalAngle ]! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
radius: aNumber
	"Set the radius in pixels of the layout
```
nodes := (1 to: 5).

canvas := RSCanvas new.
shapes := RSCircle models: nodes.
shapes size: 30.
canvas addAll: shapes.

RSCircleLayout new radius: 20; on: shapes.
canvas @ RSCanvasController.
canvas 
```
	"
	^ self initialRadius: aNumber! !

!RSAbstractCircleLayout methodsFor: 'accessing' stamp: ''!
scaleFactor
	^ factor! !

!RSAbstractCircleLayout class methodsFor: 'public' stamp: ''!
isAbstract
	^ self name = #RSAbstractCircleLayout! !

!RSAbstractCompactTreeLayout commentStamp: ''!
TODO!
!RSAbstractCompactTreeLayout methodsFor: 'initialize-release' stamp: ''!
greedyCycleRemoval: aGraph! !

!RSAbstractCompactTreeLayout methodsFor: 'initialize-release' stamp: ''!
initialLayout: aLayout
	initialLayout := aLayout ! !

!RSAbstractCompactTreeLayout methodsFor: 'initialize-release' stamp: ''!
initialize 
	super initialize.
	verticalGap := 20.
	horizontalGap := 30.
	margin := 40. 
	sonsDictionary := Dictionary new! !

!RSAbstractCompactTreeLayout methodsFor: 'algorithm' stamp: ''!
followRightContour: aNode toLayer: anInteger
	"return the node in the right contour begining at anode in layer anInteger"

	((self layerOf: aNode) = anInteger ) ifTrue: [^ aNode  ].
	((self layerOf: aNode) > anInteger ) ifTrue: [^ nil  ].

	(self rightContourOf: aNode) isNil ifTrue: [ (self pointerOf: aNode) isNil ifTrue: [ ^ nil ] 
														 ifFalse: [ ^ ( self followRightContour: (self pointerOf: aNode) toLayer: anInteger ) ] ]
	
			  				ifFalse: [ ^ (self followRightContour: (self rightContourOf: aNode) toLayer: anInteger ) ]! !

!RSAbstractCompactTreeLayout methodsFor: 'algorithm' stamp: ''!
computePosition: aNode
"compute the position of the given node and of his sons recursively"
	self subclassResponsibility.! !

!RSAbstractCompactTreeLayout methodsFor: 'algorithm' stamp: ''!
followLeftContour: aNode toLayer: anInteger
	"return the last node in the left contour begining at anode"
	
	((self layerOf: aNode) = anInteger ) ifTrue: [^ aNode  ].
	((self layerOf: aNode) > anInteger ) ifTrue: [^ nil  ].
	
	(self leftContourOf: aNode) isNil ifTrue: [ (self pointerOf: aNode)  isNil ifTrue: [ ^ nil ] 
														 ifFalse: [ ^ ( self followLeftContour: (self pointerOf: aNode) toLayer: anInteger ) ] ]
	
			  				ifFalse: [ ^ (self followLeftContour: (self leftContourOf: aNode) toLayer: anInteger ) ]! !

!RSAbstractCompactTreeLayout methodsFor: 'algorithm' stamp: ''!
leftSiblingOf: aNode
	"return the left sibling of the given node "
	| children |

	(self fatherOf: aNode) isNil ifTrue: ["has no sibling" ^ nil]
					    ifFalse: [ children := self childrenFor: (self fatherOf: aNode).
								(children first) = aNode ifTrue: ["as no left sibling" ^ nil ]
																    ifFalse: [^ children at: ((children indexOf: aNode) - 1) ] ]! !

!RSAbstractCompactTreeLayout methodsFor: 'initialize-release' stamp: ''!
root: aNode 
	root := aNode ! !

!RSAbstractCompactTreeLayout methodsFor: 'private' stamp: ''!
childrenFor: aNode 
	^ sonsDictionary isEmpty 
		ifTrue: [ super childrenFor: aNode ] 
		ifFalse: [ sonsDictionary at: aNode ifAbsent: [ ^ OrderedCollection new ] ]! !

!RSAbstractCompactTreeLayout methodsFor: 'initialize-release' stamp: ''!
initialize: aNode whoseFatherIs: another 
	self fatherOf: aNode put: another.
	
	another isNil ifTrue: [ self layerOf: aNode put: 0 ] ifFalse: [ self layerOf: aNode put: (self layerOf: another) + 1 ] .
	
	( self childrenFor: aNode ) do: [ :e | self initialize: e whoseFatherIs: aNode ]! !

!RSAbstractCompactTreeLayout methodsFor: 'algorithm' stamp: ''!
getAbcissaOf: aNode inSubtreeFromLayer: anInteger
	| node x |
	
	(anInteger < 0) ifTrue: [^ self getAbcissaOf: aNode inSubtreeFromLayer: 0 ].
	
	((self layerOf: aNode) = anInteger ) ifTrue: [ ^ self xOf: aNode ].
	((self layerOf: aNode) < anInteger ) ifTrue: [ ^ nil ].
	
	x := (self xOf: aNode) + (self modOf: aNode).
	
	node := self fatherOf: aNode.
	
	[(self layerOf: node) = anInteger  ] whileFalse: [ x := x + (self modOf: node).
									node := self fatherOf: node ].
								
	^ x! !

!RSAbstractCompactTreeLayout methodsFor: 'algorithm' stamp: ''!
compareContourOf: aNode with: another
	"return the number of radians the subtree induced by aNode must be displaced to be separated by a predefined distance (horizontalGap) from the one induced by anotherNode"
	self subclassResponsibility! !

!RSAbstractCompactTreeLayout class methodsFor: 'testing' stamp: ''!
horizontalGap: anInteger
	^ self new horizontalGap: anInteger; yourself! !

!RSAbstractCompactTreeLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #RSAbstractCompactTreeLayout

! !

!RSAbstractCompactTreeLayout class methodsFor: 'testing' stamp: ''!
verticalGap: anInteger
	^ self new verticalGap: anInteger; yourself! !

!RSAbstractCompactTreeLayout class methodsFor: 'testing' stamp: ''!
horizontalGap: anInt verticalGap: another

	| new |
	
	new := self new.
	new horizontalGap: anInt.
	new verticalGap: another.
	
	
	^ new ! !

!RSAbstractContainerBuilder commentStamp: ''!
I am the base for roassal visualizations. When a user wants to create a new visualization, he will need to create a new subclass of me.

A container builder(RSAbstractContainerBuilder), is an object that creates roassal shapes and keeps those shapes in a container (which could be either a RSCanvas or a RSComposite). The builder can modify the canvas and register new callbacks for events, as for interactions.

Methods
- #build, because a builder news to build
- #container:, to set the container where shapes will be added.
- #renderIn:, is abstract class and recives a container, usually a canvas.

Example:

We can define an new calendar builder, that creates a calendar for a given year.

```Smalltalk
card := RSPunchCardBuilder new.
card objects: String withAllSubclasses.
card addMetric: [:cls | cls numberOfMethods] name: 'NOM'.
card build.
```

Then RSPunchCardBuilder should define 2 methods to run this example `objects:` and `renderIn:`. Check 
RSPunchCardBuilder for more details.

Then you can use this builder to create a canvas with several punch cards

```Smalltalk
canvas := RSCanvas new.
card := RSPunchCardBuilder new.
card addMetric: [:cls | cls numberOfMethods] name: 'NOM'.
card addMetric: [:cls | cls linesOfCode ] name: 'NLC'.
card addMetric: [:cls | cls numberOfVariables] name: 'NOV'.
{ String. Array. StringMorph } do: [ :class | 
	composite := RSComposite new.
	card 
		objects: class withAllSubclasses;
		renderIn: composite.
	composite adjustToChildren.
	canvas add: composite.
	 ].
RSVerticalLineLayout on: canvas nodes.
"each node is a calendar for one year"
canvas @ RSCanvasController
```!
!RSAbstractContainerBuilder methodsFor: 'accessing - defaults' stamp: ''!
defaultContainer
	^ RSCanvas new! !

!RSAbstractContainerBuilder methodsFor: 'public' stamp: ''!
open
	self build.
	^ self canvas open! !

!RSAbstractContainerBuilder methodsFor: 'hooks' stamp: ''!
renderIn: aCanvas
	self subclassResponsibility! !

!RSAbstractContainerBuilder methodsFor: 'accessing' stamp: ''!
shapes
	^ shapes! !

!RSAbstractContainerBuilder methodsFor: 'building' stamp: ''!
build
	self renderIn: self container.
	^ self container! !

!RSAbstractContainerBuilder methodsFor: 'accessing' stamp: ''!
container
	^ container ifNil: [ container := self defaultContainer ].! !

!RSAbstractContainerBuilder methodsFor: 'accessing' stamp: ''!
container: aTContainer
	container := aTContainer! !

!RSAbstractContainerBuilder methodsFor: 'accessing' stamp: ''!
canvas
	^ self container canvas! !

!RSAbstractContextInteraction commentStamp: ''!
A context is very usefull to describe de default interactions for a canvas.

My subclasses should override interaction!
!RSAbstractContextInteraction methodsFor: 'accessing' stamp: ''!
presentation: aGlamourPresentation
	presentation := aGlamourPresentation! !

!RSAbstractContextInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self propagateToChildren: true.! !

!RSAbstractContextInteraction methodsFor: 'accessing' stamp: ''!
propagateToChildren: bool
	propagateToChildren := bool! !

!RSAbstractContextInteraction methodsFor: 'hooks' stamp: ''!
interactionsToBeRegistered
	^ self subclassResponsibility! !

!RSAbstractContextInteraction methodsFor: 'accessing' stamp: ''!
propagateToChildren
	^ propagateToChildren! !

!RSAbstractContextInteraction methodsFor: 'hooks' stamp: ''!
onShape: aShape
	aShape removeInteractionIfPresent: self class.
	self interactionsToBeRegistered do: [ :i | 
		i presentation: self presentation.
		aShape addInteraction: i ].
	self propagateToChildren ifFalse: [ ^ self ].
	aShape children ifNil: [ ^ self ].
	
	aShape children do: [ :child | child addInteraction: self ].
	aShape
		when: RSShapeAddedEvent
		do: [ :evt | evt shape @ self ].! !

!RSAbstractContextInteraction methodsFor: 'accessing' stamp: ''!
presentation
	^ presentation! !

!RSAbstractControlCanvasInteraction commentStamp: ''!
I interact with RSControlsView. my subclasses are added to the controls!
!RSAbstractControlCanvasInteraction methodsFor: 'rendering' stamp: ''!
renderLegendOn: aLegendBuilder
	self subclassResponsibility! !

!RSAbstractControlCanvasInteraction methodsFor: 'utilities' stamp: ''!
correctCameraPosition: aCanvas 
	^ self 
		correctCameraPosition: aCanvas
		inRectangle: (self expandedRectangle: aCanvas)
		position: aCanvas camera position
		scale: aCanvas camera scale! !

!RSAbstractControlCanvasInteraction methodsFor: 'accessing' stamp: ''!
configuration
	^ limits ifNil: [ limits := RSControlConfiguration new ]! !

!RSAbstractControlCanvasInteraction methodsFor: 'utilities' stamp: ''!
removeRectanglesFor: aCanvas
	aCanvas 
		removeKey: #encompassingRectangle;
		removeKey: #expanedEncompassingRectangle! !

!RSAbstractControlCanvasInteraction methodsFor: 'utilities' stamp: ''!
scaleFor: aScale
	| l |
	l := self configuration.
	^ (l maxScale min: aScale ) max: l minScale! !

!RSAbstractControlCanvasInteraction methodsFor: 'accessing' stamp: ''!
configuration: aRSControlLimits
	limits := aRSControlLimits! !

!RSAbstractControlCanvasInteraction methodsFor: 'utilities' stamp: ''!
correctCameraPosition: aCanvas inRectangle: rectangle position: position scale: scale
	| canvasRect x y p |
	p := position.
	canvasRect := Rectangle
		floatCenter: p
		extent: aCanvas extent / scale.
	x := rectangle width <= canvasRect width
		ifTrue: [rectangle origin x < canvasRect origin x
			ifTrue: [ p x - (canvasRect origin x - rectangle origin x) ]
			ifFalse: [ rectangle corner x < canvasRect corner x
				ifTrue: [ p x ]
				ifFalse: [ p x - (canvasRect corner x - rectangle corner x) ] ] ]
		ifFalse: [ canvasRect origin x < rectangle origin x
			ifTrue: [ p x - (canvasRect origin x - rectangle origin x) ]
			ifFalse: [ rectangle corner x < canvasRect corner x
				ifTrue: [ p x - (canvasRect corner x - rectangle corner x) ]
				ifFalse: [ p x ] ] ].
	y := rectangle height <= canvasRect height
		ifTrue: [rectangle origin y < canvasRect origin y
			ifTrue: [ p y - (canvasRect origin y - rectangle origin y) ]
			ifFalse: [ rectangle corner y < canvasRect corner y
				ifTrue: [ p y ]
				ifFalse: [ p y - (canvasRect corner y - rectangle corner y) ] ] ]
		ifFalse: [ canvasRect origin y < rectangle origin y
			ifTrue: [ p y - (canvasRect origin y - rectangle origin y) ]
			ifFalse: [ rectangle corner y < canvasRect corner y
				ifTrue: [ p y - (canvasRect corner y - rectangle corner y) ]
				ifFalse: [ p y ] ] ].
	^ x@y! !

!RSAbstractControlCanvasInteraction methodsFor: 'utilities' stamp: ''!
correctCameraPosition: aCanvas scale: scale
	^ self 
		correctCameraPosition: aCanvas
		inRectangle: (self expandedRectangle: aCanvas)
		position: aCanvas camera position
		scale: scale! !

!RSAbstractControlCanvasInteraction methodsFor: 'utilities' stamp: ''!
encompassingRectangleFor: aCanvas
	^ aCanvas propertyAt: #encompassingRectangle 
		ifAbsentPut: [ aCanvas encompassingRectangle  ].! !

!RSAbstractControlCanvasInteraction methodsFor: 'utilities' stamp: ''!
expandedRectangle: aCanvas
	| key | 
	key := #expanedEncompassingRectangle.
	^ aCanvas propertyAt: key ifAbsentPut: [ 
		| rectangle |
		rectangle := self encompassingRectangleFor: aCanvas.
		self configuration padding expandRectangle: rectangle ].
	! !

!RSAbstractControlPointsLine commentStamp: ''!
I am an abstract class for lines with control points!
!RSAbstractControlPointsLine methodsFor: 'testing' stamp: ''!
isControlPointsLine
	^ true! !

!RSAbstractControlPointsLine methodsFor: 'update' stamp: ''!
update
	controlPointsController ifNil: [ ^ self ].
	self
		controlPoints: (controlPointsController controlPointsFor: self);
		notifyExtentChanged.! !

!RSAbstractControlPointsLine methodsFor: 'accessing' stamp: ''!
controlPointsController: aCPController
	controlPointsController := aCPController! !

!RSAbstractControlPointsLine methodsFor: 'actions' stamp: ''!
basicTranslateBy: delta
	controlPoints := controlPoints collect: [:p | p + delta ].! !

!RSAbstractControlPointsLine methodsFor: 'accessing' stamp: ''!
controlPointsController
	^ controlPointsController! !

!RSAbstractControlPointsLine methodsFor: 'accessing' stamp: ''!
controlPoints: anArrayOfPoints
	controlPoints := anArrayOfPoints collect: #asFloatPoint.
	self resetPath.! !

!RSAbstractControlPointsLine methodsFor: 'accessing' stamp: ''!
startPoint
	^ self controlPoints first! !

!RSAbstractControlPointsLine methodsFor: 'accessing' stamp: ''!
endPoint
	^ self controlPoints last! !

!RSAbstractControlPointsLine methodsFor: 'accessing' stamp: ''!
startPoint: aPoint
	self controlPoints at: 1 put: aPoint.
	self resetPath.! !

!RSAbstractControlPointsLine methodsFor: 'accessing' stamp: ''!
endPoint: aPoint
	self controlPoints 
		at: self controlPoints size
		put: aPoint.
	self resetPath.! !

!RSAbstractControlPointsLine methodsFor: 'accessing' stamp: ''!
controlPoints
	^ controlPoints ifNil: [ controlPoints := { 0@0. 0@0 } ].! !

!RSAbstractControlPointsLine class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self =  RSAbstractControlPointsLine! !

!RSAbstractDualLine commentStamp: ''!
I am an abtract shape that has an start and one end!
!RSAbstractDualLine methodsFor: 'transforming' stamp: ''!
position
	^ self encompassingRectangle floatCenter! !

!RSAbstractDualLine methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	startPoint := 0@0.
	endPoint := 100@100.! !

!RSAbstractDualLine methodsFor: 'update' stamp: ''!
update
	"Note that before calling this method, an attach point has to be set. Consider the following example:
```
b1 := RSBox new size: 20.
b2 := RSBox new size: 20.
b1 translateTo: 20 @ 30.
b2 translateTo: 40 @ 50.

l := RSLine new from: b1; to: b2.
l attachPoint: RSBorderAttachPoint new .
l update.
```

Removing the call to #attachPoint: raised an error
	"
	(attachPoint isNil | from isNil | to isNil) ifTrue: [ ^ self ].
	self
		startPoint: (attachPoint startingPointOf: self);
		endPoint: (attachPoint endingPointOf: self);
		notifyExtentChanged.! !

!RSAbstractDualLine methodsFor: 'transforming' stamp: ''!
basicTranslateBy: delta
	self translateBy: delta! !

!RSAbstractDualLine methodsFor: 'transforming' stamp: ''!
translateBy: delta
	self
		startPoint: startPoint + delta;
		endPoint: endPoint + delta.
	self resetPath! !

!RSAbstractDualLine methodsFor: 'accessing' stamp: ''!
startPoint 
	^ startPoint! !

!RSAbstractDualLine methodsFor: 'accessing' stamp: ''!
endPoint
	^ endPoint! !

!RSAbstractDualLine methodsFor: 'transforming' stamp: ''!
translateTo: delta
	| center |
	center := (startPoint + endPoint ) /2.
	self translateBy: delta - center! !

!RSAbstractDualLine methodsFor: 'accessing' stamp: ''!
startPoint: point
	startPoint := point.
	self resetPath! !

!RSAbstractDualLine methodsFor: 'accessing' stamp: ''!
endPoint: point
	endPoint := point.
	self resetPath.
	self notifyExtentChanged.! !

!RSAbstractDualLine methodsFor: 'accessing' stamp: ''!
controlPoints 
	^ Array with: self startPoint with: self endPoint! !

!RSAbstractDualLine class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = RSAbstractDualLine! !

!RSAbstractFlowLayout commentStamp: ''!
TODO!
!RSAbstractFlowLayout methodsFor: 'accessing' stamp: ''!
gapSize: aSizeInPixels
	gapSize := aSizeInPixels! !

!RSAbstractFlowLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	maxWidth := self defaultMaxWidth.
	gapSize := self defaultGapSize.! !

!RSAbstractFlowLayout methodsFor: 'accessing' stamp: ''!
maxWidth: aSizeInPixels
	maxWidth := aSizeInPixels! !

!RSAbstractFlowLayout methodsFor: 'hook' stamp: ''!
doExecute: elements

	| lines align |
	elements ifEmpty: [ ^ self ].
	lines := self linesFor: elements.
	align := RSAlignment new.
	lines do: [ :line | 
		align shapes: line.
		alignment value: align.
		 ].
	
	! !

!RSAbstractFlowLayout methodsFor: 'hook' stamp: ''!
linesFor: elements 
	^ self subclassResponsibility! !

!RSAbstractFlowLayout methodsFor: 'accessing' stamp: ''!
maxWidth
	^ maxWidth! !

!RSAbstractFlowLayout methodsFor: 'configuration' stamp: ''!
defaultMaxWidth
	^ [ :elements | 
		(elements size < 4) ifTrue: [ (((elements collect: [ :each | each width * each height]) * 2) sum ) + (elements size * (gapSize squared)) ]
			ifFalse: [
			((((elements collect: [ :each | each width * each height]) * 2) sum) + (elements size * (gapSize squared))) sqrt ceiling truncated.
			]
		]! !

!RSAbstractFlowLayout methodsFor: 'configuration' stamp: ''!
defaultGapSize
	^ 5! !

!RSAbstractFlowLayout methodsFor: 'accessing' stamp: ''!
gapSize
	^ gapSize! !

!RSAbstractFlowLayout class methodsFor: 'instance creation' stamp: ''!
withMaxWidth: anInteger withGap: anotherInteger
	
	^(self new)
		maxWidth: anInteger;
		gapSize: anotherInteger;
		yourself! !

!RSAbstractFlowLayout class methodsFor: 'instance creation' stamp: ''!
withMaxWidth: anInteger
	
	^(self new)
		maxWidth: anInteger;
		yourself! !

!RSAbstractFlowLayout class methodsFor: 'public' stamp: ''!
isAbstract
	^ self name = #RSAbstractFlowLayout! !

!RSAbstractGraphLayout commentStamp: ''!
TODO!
!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
maximumDiameter: aCollection
	^ aCollection
		inject: 0
		into: [:max :node | max max: (node radius * 2) ]
 ! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
cachedParentsWithHighestNestings
	cachedParentsWithHighestNestings
		ifNil: [cachedParentsWithHighestNestings := IdentityDictionary new: 1000].
	^ cachedParentsWithHighestNestings! !

!RSAbstractGraphLayout methodsFor: 'accessing' stamp: ''!
horizontalGap: anInteger
	"Set the horizontal space, in pixel, between two neighbors"
	horizontalGap := anInteger! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
parentsFor: aNode
	^ self cachedParents
		at: aNode
		ifAbsentPut:
			[ | nodes |
			nodes := OrderedCollection new.
			self edgesDo:
					[:edge | edge to == aNode ifTrue: [ nodes add: edge from ] ].
			nodes ]! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
shiftTree: aNode by: aPoint
	aNode translateBy: aPoint.
	(self childrenFor: aNode) do: [:child | self shiftTree: child by: aPoint]! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
highestNestingParentFor: aNodeFigure
	| parents |
	^self cachedParentsWithHighestNestings
		at: aNodeFigure
		ifAbsentPut:
			[parents := self parentsFor: aNodeFigure.
			parents isEmpty
				ifTrue: [0]
				ifFalse:
					[parents detectMax: [:eachParent | self nestingLevelFor: eachParent]]]! !

!RSAbstractGraphLayout methodsFor: 'accessing' stamp: ''!
verticalGap
	"Return the vertical space, in pixel, between a layer and a children layer"
	^ verticalGap ifNil: [ self class verticalGap ]! !

!RSAbstractGraphLayout methodsFor: 'actions' stamp: ''!
on: el edges: edgs
	"Do the layout of the elements tacking into account the provided edges"
	self userDefinedEdges ifNil: [ self userDefinedEdges: edgs ].

	^ self applyOn: el.! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
childrenFor: aNode
	^ self cachedChildren
		at: aNode
		ifAbsentPut:
			[| nodes |
			nodes := OrderedCollection new.
			self edgesDo:
					[:edge | 
					(edge from == aNode and: [edge to ~= aNode])
						ifTrue:
							[(nodes includes: edge from) ifFalse: [nodes add: edge to]]].
			nodes]! !

!RSAbstractGraphLayout methodsFor: 'hook' stamp: ''!
doInitialize: elements 
	super doInitialize: elements.
	self clear.
	"self greedyCycleRemoval: elements"! !

!RSAbstractGraphLayout methodsFor: 'public' stamp: ''!
validateCycles
	shouldValidateCycles := true! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
cachedParents
	cachedParents ifNil: [cachedParents := IdentityDictionary new: 1000].
	^ cachedParents! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
cachedChildren
	cachedChildren ifNil: [cachedChildren := IdentityDictionary new: 1000].
	^ cachedChildren! !

!RSAbstractGraphLayout methodsFor: 'testing' stamp: ''!
shouldValidateCycles
	^ shouldValidateCycles! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
childrenWithHighestNestingLevelFor: aNode
	^ (self childrenFor: aNode)
		select: [:eachChild | (self highestNestingParentFor: eachChild) == aNode]! !

!RSAbstractGraphLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self doNotValidateCycles.! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
validateCachedParents
	self shouldValidateCycles ifFalse: [ ^ self ].
	self cachedParents keysDo: [ :node | 
		self validateCycleFor: node path: Set new ].! !

!RSAbstractGraphLayout methodsFor: 'accessing' stamp: ''!
horizontalGap
	"Return the horizontal space, in pixel, between two neighbors"
	^ horizontalGap ifNil: [ self class horizontalGap ]! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
nestingLevelFor: aNodeFigure
	| parents parentsNesting |
	parents := self parentsFor: aNodeFigure.
	parentsNesting := parents
		collect: [:eachParent | self nestingLevelFor: eachParent].
	^parentsNesting isEmpty
		ifTrue: [0]
		ifFalse: [parentsNesting max + 1]
! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
maximumRadius: aCollection
	^ aCollection
		inject: 0
		into: [:max :node | max max: node radius]! !

!RSAbstractGraphLayout methodsFor: 'public' stamp: ''!
doNotValidateCycles
	shouldValidateCycles := false! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
childrenFor: aNode except: aNodeCollection
	^ (self childrenFor: aNode) 
		reject: [:each | aNodeCollection includes: each]
	
	"we are explicitly not using the default Collection>>difference: behavior here because we want to preserve the order of the collection"! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
clear
	cachedParents := nil.
	cachedChildren := nil.
	cachedParentsWithHighestNestings := nil! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
validateCycleFor: node path: aSet
	(aSet includes: node)
		ifTrue: [ self error: 'cycle with: ', aSet asString ].
	aSet add: node.
	(self parentsFor: node) do: [ :parent| self validateCycleFor: parent path: aSet ].
	! !

!RSAbstractGraphLayout methodsFor: 'private' stamp: ''!
rootNodesFor: aCollection
	^ aCollection select: [:node | 
		(self parentsFor: node) isEmpty ].! !

!RSAbstractGraphLayout methodsFor: 'accessing' stamp: ''!
verticalGap: anInteger
	"Set the vertical space, in pixel, between a layer and a children layer"
	verticalGap := anInteger! !

!RSAbstractGraphLayout class methodsFor: 'constants' stamp: ''!
horizontalGap
	
	^3.0! !

!RSAbstractGraphLayout class methodsFor: 'constants' stamp: ''!
verticalGap
	
	^20.0! !

!RSAbstractGraphLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #RSAbstractGraphLayout! !

!RSAbstractGraphLayout class methodsFor: 'public' stamp: ''!
on: elements edges: edges
	"Do the layout of the elements tacking into account the provided edges"

	^ self new 
		userDefinedEdges: edges;
		applyOn: elements.! !

!RSAbstractGridLayout commentStamp: ''!
A ROAbstractGridLayout is xxxxxxxxx.

Instance Variables
	gapSize:		<Object>
	lineItemsCountBlock:		<Object>

gapSize
	- xxxxx

lineItemsCountBlock
	- xxxxx
!
!RSAbstractGridLayout methodsFor: 'accessing' stamp: ''!
defaultLineItemsCount
	^ [ :elements | 
			| height width |
			(elements size < 3 
				ifTrue: [ (elements size max: 1) @ 1 ]
				ifFalse: 
					[ height := (elements size * 0.618034) sqrt ceiling truncated.
					width := (elements size / height) ceiling truncated.
					width @ height ]) x ]! !

!RSAbstractGridLayout methodsFor: 'accessing' stamp: ''!
gapSize: anInteger
	gapSize := anInteger! !

!RSAbstractGridLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	gapSize := self defaultGapSize.
	lineItemsCountBlock := self defaultLineItemsCount.! !

!RSAbstractGridLayout methodsFor: 'accessing' stamp: ''!
lineItemsCount: aNumberOrASymbolOrABlock
	"The argument will be evaluated (using rsValue:) against the set of elements to perform the layout on. The result of this evaluation has to be a number, which indicates the number of elements per line"
	lineItemsCountBlock := aNumberOrASymbolOrABlock! !

!RSAbstractGridLayout methodsFor: 'initialize-release' stamp: ''!
defaultGapSize
	^ 5! !

!RSAbstractGridLayout methodsFor: 'accessing' stamp: ''!
lineItemsCountBlock
	^ lineItemsCountBlock! !

!RSAbstractGridLayout methodsFor: 'accessing' stamp: ''!
gapSize
	^ gapSize! !

!RSAbstractGridLayout class methodsFor: 'instance creation' stamp: ''!
withGap: anInteger 

	^ self new 
			gapSize: anInteger; 
			yourself! !

!RSAbstractGridLayout class methodsFor: 'instance creation' stamp: ''!
withLineItemsCount: aBlock
	
	^self new
		lineItemsCount: aBlock;
		yourself! !

!RSAbstractGridLayout class methodsFor: 'instance creation' stamp: ''!
withGap: anInteger withLineItemsCount: aBlock
	
	^self new
		gapSize: anInteger;
		lineItemsCount: aBlock;
		yourself! !

!RSAbstractGridLayout class methodsFor: 'public' stamp: ''!
isAbstract
	^ self name = #RSAbstractGridLayout! !

!RSAbstractGridLayout class methodsFor: 'public' stamp: ''!
on: aCollectionOfElements withGap: anInteger withLineItemsCount: aBlock
	"place the elements in a grid with (aBlock roValue: aCollectionOfElements) as the amount of elements horizontally"
	
	| myLayout |
	myLayout := self new gapSize: anInteger;  lineItemsCount: aBlock; yourself.
	myLayout applyOn: aCollectionOfElements.
	^ aCollectionOfElements! !

!RSAbstractGridLayout class methodsFor: 'public' stamp: ''!
on: aCollectionOfElements withLineItemsCount: aBlock
	"place the elements in a grid with (aBlock roValue: aCollectionOfElements) as the amount of elements horizontally

	For example:
	self on: (ROElement forCollection: (1 to: 20)) withLineItemsCount: 5
	=> place the 20 elements on a grid 5 x 4
	
	self on: (ROElement forCollection: (1 to: 20)) withLineItemsCount: [ :elements | elements size // 3 ]
	=> place the 20 elements on a grid 3 x 7
	"
	
	
	| myLayout |
	myLayout := self new lineItemsCount: aBlock; yourself.
	myLayout applyOn: aCollectionOfElements.
	^ aCollectionOfElements! !

!RSAbstractHorizontalTreeLayout commentStamp: ''!
TODO!
!RSAbstractHorizontalTreeLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	verticalGap := 3.
	horizontalGap := 20! !

!RSAbstractHorizontalTreeLayout methodsFor: 'private - hook' stamp: ''!
computeChildrenFor: aNode
	self subclassResponsibility! !

!RSAbstractHorizontalTreeLayout methodsFor: 'private' stamp: ''!
rearrangeByLayers: aGraph
	| cursor layerDepthSize |
	cursor := self leftGap.
	nodesByLayer do: [ :eachSetOfNodes |
		layerDepthSize := eachSetOfNodes inject: 0 into: [ :max :eachNode | 
			translator translateTopLeftOf: eachNode to: (cursor @ eachNode encompassingRectangle top).
			max max: eachNode width ].
		cursor := cursor + layerDepthSize + self horizontalGap ]! !

!RSAbstractHorizontalTreeLayout methodsFor: 'private - hook' stamp: ''!
layout: aNodeCollection atPoint: aPoint atLayer: aNumber
	| treeSize childrenPosition x y middleOfTree |
	aNodeCollection isEmpty ifTrue: [ ^ 0 ].
	x := aPoint x.
	y := aPoint y.
	alreadyLayoutedNodes addAll: aNodeCollection.
	self atLayer: aNumber add: aNodeCollection.
	aNodeCollection do: [ :each | 
		childrenPosition := x + each width + self horizontalGap.
		treeSize := each height
			max: (self layout: (self computeChildrenFor: each) atPoint: childrenPosition @ y atLayer: aNumber + 1).
		middleOfTree := y + (treeSize / 2.0) - (each height / 2.0).
		translator translateTopLeftOf: each to: (x @ middleOfTree).
		y := y + treeSize + self verticalGap.
		self step ].
	^ y - aPoint y - self verticalGap! !

!RSAbstractHorizontalTreeLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = RSAbstractHorizontalTreeLayout! !

!RSAbstractLabelDecoration commentStamp: ''!
TODO!
!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
fontSize
	"Return the font size to use when generating labels"
	^ baseShape fontSize! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
vertical
	"Set the label vertical"
	self rotationAngle: -90! !

!RSAbstractLabelDecoration methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	baseShape := RSLabel new.
	location := RSLocation new.! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
location
	^ location! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
baseShape
	^ baseShape! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
location: aRSLocation
	^ location! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
offset: aPointOrNumber
	"Set the translation distance to set the label"
	location offset: aPointOrNumber! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
baseShape: aRSLabel
	baseShape := aRSLabel! !

!RSAbstractLabelDecoration methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	label := self createLabel.
	location move: label on: canvas encompassingRectangle.
	canvas add: label! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
title: aLabelAsString
	"This method is useful to set the name of an axis"
	title := aLabelAsString! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
createdShapes
	^ { label }! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
offset
	^ location offset! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
fontSize: fontSizeToUse
	"Set the font size to use when generating labels"
	baseShape fontSize: fontSizeToUse! !

!RSAbstractLabelDecoration methodsFor: 'rendering' stamp: ''!
createLabel
	"Utility method to create a label"
	^ baseShape copy
		text: title;
		yourself
		! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
horizontal
	"Set the label horizontal"
	self rotationAngle: 0! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!RSAbstractLabelDecoration methodsFor: 'accessing' stamp: ''!
rotationAngle: anAngleAsFloat
	"Set the rotation the label should have"
	^ baseShape rotateByDegrees: anAngleAsFloat! !

!RSAbstractLine commentStamp: ''!
I represent the abstract lines that have start and end points

For example:
-=-=-=-=-=-=-=-=-=-=-=-=
c := RSCanvas new.

circle := RSEllipse new color: Color green; size: 10.
box := RSBox new color: Color red; size: 10.
c add: circle; add: box.

dragMeLabel := RSLabel new text: 'Drag me'.
c add: dragMeLabel.
RSLocation new
	above; center;
	stick: dragMeLabel on: box.

c add: (RSLine new color: Color veryVeryLightGray; from: 0 @ -1000; to: 0 @ 1000).
c add: (RSLine new color: Color veryVeryLightGray; from: -1000 @ 0; to: 1000 @ 0).

box translateBy: 50 @ 50.
box @ RSDraggable.

c add: (RSLine new color: Color blue; from: box; to: circle).

c
-=-=-=-=-=-=-=-=-=-=-=-=!
!RSAbstractLine methodsFor: 'testing' stamp: ''!
basicIncludesPoint: aPoint
	^ false! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
color: aColor
	self strokePaint: aColor! !

!RSAbstractLine methodsFor: 'attach point' stamp: ''!
withBorderAttachPoint
	self attachPoint: RSBorderAttachPoint new.! !

!RSAbstractLine methodsFor: 'style - join' stamp: ''!
joinBevel
	self border joinBevel! !

!RSAbstractLine methodsFor: 'testing' stamp: ''!
hasMarkers
	| m |
	m := self privateMarkers.
	^ m notNil and: [ 
		m anySatisfy: [ :mar | mar notNil ].  ]! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
markerMid: marker
	| m |
	marker ifNil: [ ^ nil ].
	m := marker asMarker.
	self markers at: 2 put: m.
	^ m! !

!RSAbstractLine methodsFor: 'testing' stamp: ''!
isLine
	^ true! !

!RSAbstractLine methodsFor: 'style - cap' stamp: ''!
capButt
	self border capButt! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
privateMarkers
	^ markers! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
startPoint: aPoint
	self subclassResponsibility! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
markersDo: block
	self markers do: [ :m | m ifNotNil: block  ].! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
endPoint: aPoint
	self subclassResponsibility! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
controlPoints
	^ self subclassResponsibility! !

!RSAbstractLine methodsFor: 'style - cap' stamp: ''!
capSquare
	self border capSquare! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
to 	
	^ to! !

!RSAbstractLine methodsFor: 'testing' stamp: ''!
markersIncludesPoint: aPoint 
	self hasMarkers ifFalse: [ ^ false ].
	self markerShapesInPositionDo: [ :m | 
		(m shape includesPoint: aPoint) 
			ifTrue: [ ^ true ] ].
	^ false! !

!RSAbstractLine methodsFor: 'public' stamp: ''!
fmt: aString
	"Format for lines a shortcut to define a line styles, or markers
	
	For markers use
	'o' - circle
	'^' - arrow
	's' - square
	'p' - pentagon
	'h' - hexagon
	'+' - plus
	'd' - diamond
	'*' - star
	
	For stroke styles use:
	'--' dashed line.
	'-.' dashed line with small line then point
	'.' dashed line with points
	
	Example:
```
| canvas |
canvas := RSCanvas new.
canvas add: (RSLine new 
	startPoint: 0@0;
	endPoint: 100@0;
	fmt:'-.*';
	color: Color red;
	yourself).
canvas @ RSCanvasController.
canvas open
````
	 "
	(RSShapeFactory shapeFromString: aString) 
		ifNotNil: [ :shape |self shape marker: (shape size: self border width * 4) ].
	(RSStrokeStyle fromString: aString)
		ifNotNil: [ :style | self shape border style: style ]
	! !

!RSAbstractLine methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	self
		withBorder;
		noPaint;
		withCenteredAttachPoint.
	! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
from: aShapeOrAPoint
	"Set the end point of the line"
	from := self setAnchor: from shape: aShapeOrAPoint! !

!RSAbstractLine methodsFor: 'attach point' stamp: ''!
attachPoint
	^ attachPoint! !

!RSAbstractLine methodsFor: 'testing' stamp: ''!
intersects: aRectangle
	| rect res globalMatrix |
	self isInACanvas ifFalse: [ ^ false ].
	globalMatrix := self parent globalMatrix.
	rect := self 
		computeEncompassingRectangleFor: self encompassingRectangle 
		matrix: globalMatrix.
	res := rect intersects: aRectangle.
	res ifTrue: [ ^ true ].
	self hasMarkers ifFalse: [ ^ false ].
	self markerShapesInPositionDo: [ :m |
		rect := self 
			computeEncompassingRectangleFor: m shape encompassingRectangle
			matrix: globalMatrix.
		(rect intersects: aRectangle) ifTrue: [ ^ true ].
		 ].
	^ false.! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
computeEncompassingRectangle
	| cp |
	cp := self controlPoints.
	^ cp 
			ifEmpty: [ 0@0 corner: 0@0 ]
			ifNotEmpty: [ Rectangle encompassing: cp ]! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
marker: aMarker
	| m |
	m := aMarker asMarker. 
	self 
		markerStart: m;
		markerMid: m;
		markerEnd: m.
	^ m! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
markerMid
	^ self markers 
		ifNil: [ nil ]
		ifNotNil: [ :m | m second ] ! !

!RSAbstractLine methodsFor: 'attach point' stamp: ''!
attachPoint: anAttachPoint
	attachPoint := anAttachPoint! !

!RSAbstractLine methodsFor: 'style - join' stamp: ''!
joinRound
	self border joinRound! !

!RSAbstractLine methodsFor: 'private' stamp: ''!
removeFromParent: aShape
	aShape ifNil: [ ^ self ].
	aShape isPoint ifTrue: [ ^ self ].
	aShape connectedLines remove: self ifAbsent: [  ].
! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
markerStart 
	^ self markers 
		ifNil: [ nil ]
		ifNotNil: [ :m | m first ] ! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
color
	^ self strokePaint! !

!RSAbstractLine methodsFor: 'event handling' stamp: ''!
notifyExtentChanged
	self announce: [ RSExtentChangedEvent new 
		shape: self;
		oldExtent: nil;
		newExtent: self controlPoints first - self controlPoints last ]! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
markers
	^ self privateMarkers 
		ifNil: [ | array |
			array := Array new: 3.
			self privateMarkers: array.
			array ]! !

!RSAbstractLine methodsFor: 'testing' stamp: ''!
includesPoint: aPoint
	^ self hasBorder and: [ (self basicIncludesPoint: aPoint) or: [ self markersIncludesPoint: aPoint ] ]! !

!RSAbstractLine methodsFor: 'attach point' stamp: ''!
withHorizontalAttachPoint
	self attachPoint: RSHorizontalAttachPoint new.! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
markerEnd
	^ self markers 
		ifNil: [ nil ]
		ifNotNil: [ :m | m third ] ! !

!RSAbstractLine methodsFor: 'testing' stamp: ''!
isEdge
	^ true! !

!RSAbstractLine methodsFor: 'update' stamp: ''!
update
	self subclassResponsibility! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
markerEnd: marker
	| m |
	marker ifNil: [ ^ nil ].
	m := marker asMarker.
	self markers at: 3 put: m.
	^ m! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
to: aShapeOrAPoint
	"Set the end point of the line"
	to := self setAnchor: to shape: aShapeOrAPoint! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
strokePaint: aPaint
	self border paint: aPaint.
	self markersDo: [:m | m shape paint: aPaint ].! !

!RSAbstractLine methodsFor: 'path' stamp: ''!
sessionChanged
	"This method releases all the native graphical resources. This method is typically invoked when starting a Pharo image with a visualization that was previously open"
	self resetPath.
	self hasMarkers ifFalse: [ ^ self ].
	self markersDo: [ :mark | mark shape sessionChanged ].
	! !

!RSAbstractLine methodsFor: 'public' stamp: ''!
markerShapesInPositionDo: aBlock
	| cp |
	cp := self controlPoints.
	self markerStart ifNotNil: [ :marker | marker withStart: cp do: aBlock ].
	self markerMid ifNotNil: [ :marker | marker withMid: cp do: aBlock ].
	self markerEnd ifNotNil: [ :marker | marker withEnd: cp do: aBlock ].! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
markerStart: marker
	| m |
	marker ifNil: [ ^ nil ].
	m := marker asMarker.
	self markers at: 1 put: m.
	^ m! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
from
	^ from! !

!RSAbstractLine methodsFor: 'style - dashes' stamp: ''!
dashed
	self dashArray: #(4).! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
width: aNumber
	self border width: aNumber.! !

!RSAbstractLine methodsFor: 'testing' stamp: ''!
isControlPointsLine
	^ false! !

!RSAbstractLine methodsFor: 'style - cap' stamp: ''!
capRound
	self border capRound! !

!RSAbstractLine methodsFor: 'private' stamp: ''!
setAnchor: ref shape: anObject
	ref isNotNil ifTrue: [ ref removeConnectedLine: self ].
	anObject isPoint ifFalse: [ anObject addConnectedLine: self ].
	^ anObject! !

!RSAbstractLine methodsFor: 'path' stamp: ''!
resetPath
	super resetPath.
	self resetBBox! !

!RSAbstractLine methodsFor: 'attach point' stamp: ''!
withCenteredAttachPoint
	self attachPoint: RSCenteredAttachPoint new.! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
privateMarkers: array 
	markers := array! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
startPoint
	^ self subclassResponsibility! !

!RSAbstractLine methodsFor: 'style - join' stamp: ''!
joinMiter
	self border joinMiter! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
endPoint
	^ self subclassResponsibility! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
includedRadius
	^ self border width / 2! !

!RSAbstractLine methodsFor: 'adding' stamp: ''!
remove
	parent ifNil: [ ^ self ].
	parent removeEdge: self.
	self 
		removeFromParent: to;
		removeFromParent: from.
	super remove! !

!RSAbstractLine methodsFor: 'public' stamp: ''!
resetMarkers
	self privateMarkers: nil! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
strokeColor: aColor
	self strokePaint: aColor! !

!RSAbstractLine methodsFor: 'adding' stamp: ''!
renderOn: aCanvas
	aCanvas addEdge: self.
	self update.! !

!RSAbstractLine methodsFor: 'accessing' stamp: ''!
strokePaint
	^ self border paint! !

!RSAbstractLine methodsFor: 'style - dashes' stamp: ''!
dashArray: arrayOfNumbers
	self border dashArray: arrayOfNumbers
	! !

!RSAbstractLine methodsFor: 'visiting' stamp: ''!
accept: visitor
	visitor visitLine: self.! !

!RSAbstractLine methodsFor: 'accessing - markers' stamp: ''!
markerStartEnd: aMarker
	| m |
	m := aMarker asMarker. 
	self 
		markerStart: m;
		markerEnd: m.
	^ m! !

!RSAbstractLine methodsFor: 'attach point' stamp: ''!
withVerticalAttachPoint
	self attachPoint: RSVerticalAttachPoint new.! !

!RSAbstractLine class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self =  RSAbstractLine! !

!RSAbstractLineLayout commentStamp: ''!
A ROAbstractLineLayout is the abstract superclass of the line layout.

Instance Variables
	alignment:		<Object>
	gapSize:		<Object>
	horizontalGap:		<Object>
	horizontalOutGap:		<Object>
	horizontallyStretchable:		<Object>
	verticalGap:		<Object>
	verticalOutGap:		<Object>
	verticallyStretchable:		<Object>

alignment
	- xxxxx

gapSize
	- xxxxx

horizontalGap
	- xxxxx

horizontalOutGap
	- xxxxx

horizontallyStretchable
	- xxxxx

verticalGap
	- xxxxx

verticalOutGap
	- xxxxx

verticallyStretchable
	- xxxxx
!
!RSAbstractLineLayout methodsFor: 'accessing' stamp: ''!
gapSize: aNumber
	gapSize := aNumber. " This value is never used actually "
	
	verticalGap := 2 * aNumber.
	horizontalGap := 2 * aNumber! !

!RSAbstractLineLayout methodsFor: 'accessing' stamp: ''!
horizontalGap: anInteger
	"Set the horizontal space, in pixel, between two neighbors"
	horizontalGap := anInteger! !

!RSAbstractLineLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	verticalGap := 10.
	horizontalGap := 10.! !

!RSAbstractLineLayout methodsFor: 'hook' stamp: ''!
doExecute: elements 
	| pointer delta |
	pointer := self positionOriginalPointer: elements.
	elements do: [ :element |
		delta := self deltaFor: element.
		translator translateTopLeftOf: element to: pointer - delta.
		pointer := self 
			movePointer: pointer
			accordingToFigure: element.
		].! !

!RSAbstractLineLayout methodsFor: 'accessing' stamp: ''!
horizontalGap
	^ horizontalGap! !

!RSAbstractLineLayout methodsFor: 'accessing' stamp: ''!
verticalGap
	^ verticalGap! !

!RSAbstractLineLayout methodsFor: 'hook' stamp: ''!
deltaFor: aNodeFigure
	^ self subclassResponsibility! !

!RSAbstractLineLayout methodsFor: 'accessing' stamp: ''!
alignment: anObject
	alignment := anObject! !

!RSAbstractLineLayout methodsFor: 'hook' stamp: ''!
movePointer: pointer accordingToFigure: aNodeFigure
	self subclassResponsibility! !

!RSAbstractLineLayout methodsFor: 'accessing' stamp: ''!
alignment
	^ alignment! !

!RSAbstractLineLayout methodsFor: 'accessing' stamp: ''!
verticalGap: anInteger
	"Set the vertical space, in pixel, between a layer and a children layer"
	verticalGap := anInteger! !

!RSAbstractLineLayout methodsFor: 'accessing' stamp: ''!
gapSize
	^ gapSize! !

!RSAbstractLineLayout methodsFor: 'hook' stamp: ''!
positionOriginalPointer: aGraph
	^ self subclassResponsibility! !

!RSAbstractLineLayout class methodsFor: 'instance creation' stamp: ''!
withGap: anInteger
	
	^(self new)
		gapSize: anInteger;
		yourself! !

!RSAbstractLineLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #RSAbstractLineLayout! !

!RSAbstractMarkerDecoration commentStamp: ''!
Set a marker in the chart. For example:

=-=-=-==-=-=-==-=-=-=
x := (-3.14 to: 3.14 by: 0.01).
c := RSChart new.

p := RSLinePlot new.
p x: x y: x sin * 0.22.
c addPlot: p.

p := RSLinePlot new.
p x: x y: x cos * 0.18.
c addPlot: p.

c addDecoration: RSHorizontalTick new.
c addDecoration: (RSVerticalTick new asFloat).
c addDecoration: (RSYMarkerDecoration new ).
c 
=-=-=-==-=-=-==-=-=-=!
!RSAbstractMarkerDecoration methodsFor: 'public - configuration' stamp: ''!
max
	self subclassResponsibility! !

!RSAbstractMarkerDecoration methodsFor: 'public - configuration' stamp: ''!
value: aValue
	"Mark the value"
	getRelevantValueBlock := aValue! !

!RSAbstractMarkerDecoration methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	"Per default, mark the max value"
	self max.
	markerColor := self defaultMarkerColor! !

!RSAbstractMarkerDecoration methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	chart plots
		do: [ :p | 
			line := self createMarkerLineFromPlot: p.
			line
				dashArray: self defaultDashStyle;
				color: markerColor;
				yourself.
			self addShape: line ]
! !

!RSAbstractMarkerDecoration methodsFor: 'accessing' stamp: ''!
createdShapes
	^ { line }! !

!RSAbstractMarkerDecoration methodsFor: 'rendering' stamp: ''!
createMarkerLineFromPlot: aPlot
	"This method should be overriden to produce a line"
	self subclassResponsibility! !

!RSAbstractMarkerDecoration methodsFor: 'public - configuration' stamp: ''!
average
	self subclassResponsibility! !

!RSAbstractMarkerDecoration methodsFor: 'public - configuration' stamp: ''!
min
	self subclassResponsibility! !

!RSAbstractMarkerDecoration methodsFor: 'initialization' stamp: ''!
defaultMarkerColor
	^ Color red! !

!RSAbstractMarkerDecoration methodsFor: 'rendering' stamp: ''!
defaultDashStyle
	^ #(2 2 2)! !

!RSAbstractMarkerDecoration methodsFor: 'accessing' stamp: ''!
line
	^ line! !

!RSAbstractMarkerDecoration methodsFor: 'rendering' stamp: ''!
getValueToBeMarkedFromPlot: p
	^ getRelevantValueBlock rsValue: p! !

!RSAbstractMouseClick commentStamp: ''!
abstract for mouse click events!
!RSAbstractMouseEvent commentStamp: ''!
Abstract for mouse events!
!RSAbstractMouseEvent methodsFor: 'testing' stamp: ''!
isPositionAboveShape
	^ shape encompassingRectangle containsPoint: self positionFromCamera! !

!RSAbstractPieDecorator commentStamp: ''!
I can decorate builders inspired on decorator pattern!
!RSAbstractPieDecorator methodsFor: 'rendering' stamp: ''!
render
	self subclassResponsibility! !

!RSAbstractPieDecorator methodsFor: 'accessing' stamp: ''!
builder: aBuilder
	builder := aBuilder! !

!RSAbstractPieDecorator methodsFor: 'accessing' stamp: ''!
builder
	^ builder! !

!RSAbstractPieDecorator class methodsFor: 'instance creation' stamp: ''!
on: aPieBuilder
	self new builder: aPieBuilder; render! !

!RSAbstractPlot commentStamp: ''!
TODO!
!RSAbstractPlot methodsFor: 'public - shape' stamp: ''!
color: aColor
	self shape color: aColor! !

!RSAbstractPlot methodsFor: 'rendering' stamp: ''!
definedValuesX
	"Return the list of X values that are defined"
	^ xValues select: [ :v | v isNaN not and: [ v isInfinite not ] ]! !

!RSAbstractPlot methodsFor: 'rendering' stamp: ''!
maxValueY
	"Return the maximum Y value of the plot, excluding NaN and infinite"

	^ self definedValuesY max! !

!RSAbstractPlot methodsFor: 'accessing' stamp: ''!
yValues
	^ yValues! !

!RSAbstractPlot methodsFor: 'accessing - computed' stamp: ''!
scalePoint: aPoint
	^ (xScale scale: aPoint x) @ (yScale scale: aPoint y)! !

!RSAbstractPlot methodsFor: 'public' stamp: ''!
y: aCollection
	"Define a plot with only a Y coordinate. The X coordinate is the index of the data point.
	
	For example:
-=-=-=-=-=-=-=-=-=
x := (-3.14 to: 3.14 by: 0.01).
c := RSChart new.

p := RSLinePlot new.
p y: x sin * 0.22.
c addPlot: p.

p := RSLinePlot new.
p y: x cos * 0.18.
c addPlot: p.

c addDecoration: RSHorizontalTick new.
c addDecoration: (RSVerticalTick new asFloat).
c 
-=-=-=-=-=-=-=-=-=
	"
	self x: (1 to: aCollection size) y: aCollection! !

!RSAbstractPlot methodsFor: 'testing' stamp: ''!
isBarPlot
	^ false! !

!RSAbstractPlot methodsFor: 'initialization' stamp: ''!
defaultShape
	^ self subclassResponsibility! !

!RSAbstractPlot methodsFor: 'public - shape' stamp: ''!
shape: aShape
	shape := aShape! !

!RSAbstractPlot methodsFor: 'accessing' stamp: ''!
xValues
	^ xValues! !

!RSAbstractPlot methodsFor: 'rendering' stamp: ''!
definedValuesY
	"Return the list Y values that are defined"
	^ yValues select: [ :v | v isNaN not and: [ v isInfinite not ] ]! !

!RSAbstractPlot methodsFor: 'rendering' stamp: ''!
minValueY
	"Return the minimum Y value of the plot, excluding NaN and infinite"
	^ self definedValuesY min! !

!RSAbstractPlot methodsFor: 'accessing' stamp: ''!
index
	"Return the index of the plot within the list of plots to display in the plt object"
	^ chart plots indexOf: self! !

!RSAbstractPlot methodsFor: 'testing' stamp: ''!
checkAssertion
	self
		assert: [ xValues notNil and: [ yValues notNil ] ]
		description: 'X and Y values must be added'.
	self
		assert: [ xValues size = yValues size ]
		description: 'X and Y values have not the same size, and they should'! !

!RSAbstractPlot methodsFor: 'testing' stamp: ''!
isHorizontalBarPlot
	^ false! !

!RSAbstractPlot methodsFor: 'testing' stamp: ''!
isLinePlot
	^ false! !

!RSAbstractPlot methodsFor: 'testing' stamp: ''!
isVerticalBarPlot
	^ false! !

!RSAbstractPlot methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	shape := self defaultShape! !

!RSAbstractPlot methodsFor: 'public' stamp: ''!
x: aCollection y: aCollection2 
	"Define a plot with the X and Y coordinates. Both X and Y are collections of the same size.
	
	For example:
```
x := (-3.14 to: 3.14 by: 0.01).
c := RSChart new.

p := RSLinePlot new.
p x: x y: x sin * 0.22.
c addPlot: p.

p := RSLinePlot new.
p x: x y: x cos * 0.18.
c addPlot: p.

c addDecoration: RSHorizontalTick new.
c addDecoration: RSVerticalTick new asFloat.
c addDecoration: RSYMarkerDecoration new.
c 
```
	"
	self assert: [ aCollection notNil ] description: 'Cannot be nil'.
	self assert: [ aCollection2 notNil ] description: 'Cannot be nil'.
	self assert: [ aCollection size = aCollection2 size ] description: 'The two collections must have the same size'.
 	
	xValues := aCollection.
	yValues := aCollection2! !

!RSAbstractPlot methodsFor: 'rendering' stamp: ''!
beforeRenderingIn: aChart
	super beforeRenderingIn: aChart.
	self createXScale.
	self createYScale! !

!RSAbstractPlot methodsFor: 'rendering' stamp: ''!
minValueX
	"Return the minimum X value of the plot, excluding NaN and infinite"
	^ self definedValuesX min! !

!RSAbstractPlot methodsFor: 'rendering' stamp: ''!
maxValueX
	"Return the maximum X value of the plot, excluding NaN and infinite"

	^ self definedValuesX max! !

!RSAbstractPlot methodsFor: 'public - shape' stamp: ''!
shape
	^ shape! !

!RSAbstractPlot methodsFor: 'public' stamp: ''!
computeColor
	"Return the color used by the chart element. The color is computed from the chart and from the colorBlock variable"
	^ self color ifNil: [ chart colorFor: self ].! !

!RSAbstractPlot methodsFor: 'testing' stamp: ''!
isPointWellDefined: aPoint
	"Indicate whether the point deserves to be displayed"
	^ (aPoint x isInfinite not and: [ aPoint y isInfinite not ])
		and: [ (aPoint x isNaN not and: [ aPoint y isNaN not ]) ]! !

!RSAbstractPlot methodsFor: 'testing' stamp: ''!
isScatterPlot
	^ false! !

!RSAbstractPlot methodsFor: 'public - shape' stamp: ''!
color
	^ self shape color! !

!RSAbstractPopupInteraction commentStamp: ''!
I defined basic behaviors about popups in general, my subclasses needs to override:
*
*!
!RSAbstractPopupInteraction methodsFor: 'hooks' stamp: ''!
createPopupFor: aShape event: event
	^ self subclassResponsibility! !

!RSAbstractPopupInteraction methodsFor: 'hooks' stamp: ''!
translatePopup: popup event: evt
	self subclassResponsibility! !

!RSAbstractPopupInteraction methodsFor: 'hooks' stamp: ''!
createOrGetPopupOn: aShape event: event
	"Create a popup and register it"
	| prop popupShape key |
	prop := event canvas properties.
	key := self popupKey.

	"We checked if the very same shape has emitted the popup.
	If this is the case, then we use the popup previously created, 
	else, we remove it"
	((prop includesKey: key) and: [ (prop includesKey: #shapeWithPopup) ])
		ifTrue: [ | popup |
			popup := prop at: key.
			(prop at: #shapeWithPopup) == aShape
				ifTrue: [ ^ popup ]
				ifFalse: [ self releasePopup: popup ] ].

	popupShape := self createPopupFor: aShape event: event.
	prop at: key put: popupShape.
	prop at: #shapeWithPopup put: aShape.
	^ popupShape
	! !

!RSAbstractPopupInteraction methodsFor: 'hooks' stamp: ''!
releasePopup: popup
	self subclassResponsibility! !

!RSAbstractPopupInteraction methodsFor: 'accessing' stamp: ''!
popupKey
	^ #popup! !

!RSAbstractPopupInteraction methodsFor: 'hooks' stamp: ''!
onShape: aShape
	aShape removeInteractionIfPresent: self class.
	
	self registerRemoveEventsOn: aShape.
	aShape
		when: self class activationEvent do: [ :evt | | popup |
			popup := self createOrGetPopupOn: evt shape event: evt.
			self translatePopup: popup event: evt.
			evt signalUpdate. ]
! !

!RSAbstractPopupInteraction methodsFor: 'hooks' stamp: ''!
removePopupOn: evt
	| att popup key |
	"It may happen that the canvas is not set. This is the case when an element is not added to a view.
	If the element is not part of a view, then there is nothing to remove, so we exit early."
	evt canvas ifNil: [ ^ self ].
	att := evt canvas properties.
	key := self popupKey.
	(att includesKey: key) ifFalse: [ ^ self ].
	popup := att at: key.
	self releasePopup: popup.
	att removeKey: key.
	evt signalUpdate.! !

!RSAbstractPopupInteraction methodsFor: 'hooks' stamp: ''!
registerRemoveEventsOn: aShape
	self class removeEvents do: [ :clsEvent | 
		aShape 
			when: clsEvent
			do: [ :evt |
				self removePopupOn: evt ] ]! !

!RSAbstractPopupInteraction class methodsFor: 'accessing' stamp: ''!
activationEvent
	^ RSMouseMove! !

!RSAbstractPopupInteraction class methodsFor: 'accessing' stamp: ''!
removeEvents
	^ { RSMouseClick. RSMouseEnter. RSMouseLeave. RSMouseDragging }! !

!RSAbstractRegularTreeLayout commentStamp: ''!
TODO!
!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
leftGap: anInteger
	"Perform an horizontal translation of the nodes"
	leftGap := anInteger! !

!RSAbstractRegularTreeLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	topGap := 5.
	leftGap := 5.
	isLayered := false.
	shouldBeHorizontallyReversed := false.
	shouldBeVerticallyReversed := false.! !

!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
shouldBeVerticallyReversed
	"Return if the layout is vertically reversed"
	^ shouldBeVerticallyReversed! !

!RSAbstractRegularTreeLayout methodsFor: 'private' stamp: ''!
rearrangeByLayers: aGraph
	self subclassResponsibility! !

!RSAbstractRegularTreeLayout methodsFor: 'hook' stamp: ''!
doExecute: elements
	| rootNodes |
	alreadyLayoutedNodes := OrderedCollection new.
	rootNodes := self rootNodesFor: elements.
	self validateCachedParents.
	nodesByLayer := OrderedCollection new.
	self
		layout: rootNodes
		atPoint: self leftGap @ self topGap
		atLayer: 1.
	self isLayered ifTrue: [
		self rearrangeByLayers: elements ]! !

!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
topGap: anInteger
	"Perform a vertical translation of the nodes"
	topGap := anInteger! !

!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
isLayered
	"Is the layout layered"
	^ isLayered! !

!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
shouldBeHorizontallyReversed
	"Return if the layout is horizontally reversed"
	^ shouldBeHorizontallyReversed ! !

!RSAbstractRegularTreeLayout methodsFor: 'private' stamp: ''!
atLayer: aNumber add: aNodeCollection
	| collection |
	collection := nodesByLayer at: aNumber ifAbsentPut: [OrderedCollection new].
	collection addAll: aNodeCollection! !

!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
isLayered: boolean
	"Is the layout layered"
	isLayered := boolean! !

!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
verticallyReverse
	"Reverse the edge extremities"
	"Here is an example:

| b |	
b := RTMondrian new.
b nodes: (1 to: 100).
b edges connectFrom: [ :v | v // 2 ].
b layout tree verticallyReverse.
b
"
	shouldBeVerticallyReversed := true
	
! !

!RSAbstractRegularTreeLayout methodsFor: 'hook' stamp: ''!
doPost: elements
	shouldBeHorizontallyReversed ifTrue: [ self horizontallyReverse: elements ].
	shouldBeVerticallyReversed ifTrue: [ self verticallyReverse: elements ].! !

!RSAbstractRegularTreeLayout methodsFor: 'reversing' stamp: ''!
verticallyReverse: elements
	"Vertically reverse the elements, as well as the attachpoints"
	| g hauteur |
	g := elements asGroup.
	hauteur := g extent y.
	elements
		do: [ :el | el translateTo: el position x @ (hauteur - el position y) ]! !

!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
layered
	self isLayered: true! !

!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
horizontallyReverse
	shouldBeHorizontallyReversed := true! !

!RSAbstractRegularTreeLayout methodsFor: 'private - hook' stamp: ''!
layout: aNodeCollection atPoint: aPoint atLayer: anObject
	self subclassResponsibility! !

!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
topGap
	^ topGap! !

!RSAbstractRegularTreeLayout methodsFor: 'accessing' stamp: ''!
leftGap
	^ leftGap! !

!RSAbstractRegularTreeLayout methodsFor: 'hook' stamp: ''!
doInitialize: elements 
	self clear! !

!RSAbstractRegularTreeLayout methodsFor: 'reversing' stamp: ''!
horizontallyReverse: elements
	"Horizontally reverse the elements, as well as the attachpoints"
	| g largeur |
	g := elements asGroup.
	largeur := g extent x.
	elements
		do: [ :el | el translateTo: (largeur - el position x) @ el position y ]! !

!RSAbstractRegularTreeLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = RSAbstractRegularTreeLayout! !

!RSAbstractScaleInteraction commentStamp: ''!
I define accessors for min and max scale value for some scale interactions!
!RSAbstractScaleInteraction methodsFor: 'accessing' stamp: ''!
maxScale: aNumber
	maxScale := aNumber! !

!RSAbstractScaleInteraction methodsFor: 'accessing' stamp: ''!
minScale
	^ minScale! !

!RSAbstractScaleInteraction methodsFor: 'accessing' stamp: ''!
initialize
	super initialize.
	self 
		minScale: 0.1;
		maxScale: 3.! !

!RSAbstractScaleInteraction methodsFor: 'accessing' stamp: ''!
scaleFor: anEvent
	| delta |
	delta := 1 / anEvent newScale.
	^ (maxScale min: delta ) max: minScale.! !

!RSAbstractScaleInteraction methodsFor: 'accessing' stamp: ''!
minScale: aNumber
	minScale := aNumber! !

!RSAbstractScaleInteraction methodsFor: 'accessing' stamp: ''!
maxScale
	^ maxScale! !

!RSAbstractShapeHandling commentStamp: ''!
I am base class for RSAlignment and RSResize!
!RSAbstractShapeHandling methodsFor: 'accessing' stamp: ''!
fixedShape: aShape
	"Designate a particular shape for which all the other will be aligned against"
	fixedShape := aShape! !

!RSAbstractShapeHandling methodsFor: 'accessing' stamp: ''!
shapes: someShapes
	shapes := someShapes asGroup! !

!RSAbstractShapeHandling methodsFor: 'accessing' stamp: ''!
shapes
	^ shapes! !

!RSAbstractShapeHandling methodsFor: 'private - configuration' stamp: ''!
ifNoFixedShapeThen: aBlock
	fixedShape ifNil: [ aBlock value  ]! !

!RSAbstractShapeHandling methodsFor: 'accessing' stamp: ''!
fixedShape
	^ fixedShape! !

!RSAbstractShapesBuilder commentStamp: ''!
I can create shapes
I redefine #renderIn: 
My subclasses needs to implement #objects and: #shapesFor:!
!RSAbstractShapesBuilder methodsFor: 'hooks' stamp: ''!
renderIn: aCanvas
	aCanvas addAll: (shapes := self shapesFor: self objects).! !

!RSAbstractShapesBuilder methodsFor: 'hooks' stamp: ''!
shapesFor: aCollection
	| k |
	k := 0.
	^ aCollection collect: [ :m |
		k := k + 1. 
		self shapeFor: m yourself index: k.
		 ] as: RSGroup.! !

!RSAbstractShapesBuilder methodsFor: 'hooks' stamp: ''!
objects
	^ self subclassResponsibility! !

!RSAbstractShapesBuilder methodsFor: 'hooks' stamp: ''!
shapeFor: anObject index: index
	^ self subclassResponsibility! !

!RSAbstractSunburstLayout commentStamp: ''!
I am the abstract class for sunburst visualizations in Roassal2, check my subclasses 

* RTSunburstConstanWidthLayout
* RtSunburstExtentLayout

You can use this layout in with RTLayoutBuilder or with RTSunburstBuilder
and their examples to get more info!
!RSAbstractSunburstLayout methodsFor: 'hook' stamp: ''!
setNormalRadius: shape
	self subclassResponsibility! !

!RSAbstractSunburstLayout methodsFor: 'hook' stamp: ''!
setRadius: shape
	firstNode
		ifTrue: [ 
			self hasCenter 
				ifTrue: [ self setCenterRadius: shape ].
			shape betaAngle: 360. ]
		ifFalse: [ self setNormalRadius: shape ].
	firstNode := false.! !

!RSAbstractSunburstLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self
		hasCenter: true;
		radialSpacing: 5.! !

!RSAbstractSunburstLayout methodsFor: 'accessing' stamp: ''!
radialSpacing
	^ radialSpacing ! !

!RSAbstractSunburstLayout methodsFor: 'hook' stamp: ''!
setCenterRadius: shape
	self subclassResponsibility! !

!RSAbstractSunburstLayout methodsFor: 'hook' stamp: ''!
doExecute: shapes
	| virtual |
	shapes isEmpty ifTrue: [ ^  self ].
	firstNode := true.
	shapes size = 1 ifTrue: [ 
		^ self layoutSunburst: shapes first ].
	virtual := RSPieSlice new.
	virtual schildren: shapes.
	shapes do: [ :shape | shape sparent: virtual ].
	virtual sparent: nil.
	virtual depth: 0.
	self layoutSunburst: virtual.
	shapes do: [ :shape | shape sparent: nil ].! !

!RSAbstractSunburstLayout methodsFor: 'accessing' stamp: ''!
builder: aSunburstBuilder
	builder := aSunburstBuilder! !

!RSAbstractSunburstLayout methodsFor: 'accessing' stamp: ''!
hasCenter: aBool
	hasCenter := aBool! !

!RSAbstractSunburstLayout methodsFor: 'hook' stamp: ''!
setChildrenAngles: shape
	| children parentAngle angleOffset parentWeight |
	children := shape schildren.
	parentAngle := shape alphaAngle.
	parentWeight := builder weightOf: shape.
	angleOffset := (shape betaAngle - shape alphaAngle) / parentWeight.
	children doWithIndex: [ :child :index |
		| a b |
		a := parentAngle.
		b := angleOffset * (builder weightOf: child) + a.
		child
			alphaAngle: a;
			betaAngle: b.
		self layoutSunburst: child.
		parentAngle := b. ].! !

!RSAbstractSunburstLayout methodsFor: 'accessing' stamp: ''!
builder
	^ builder! !

!RSAbstractSunburstLayout methodsFor: 'accessing' stamp: ''!
radialSpacing: aNumber
	radialSpacing := aNumber! !

!RSAbstractSunburstLayout methodsFor: 'hook' stamp: ''!
layoutSunburst: shape
	self 
		setRadius: shape;
		setChildrenAngles: shape.! !

!RSAbstractSunburstLayout methodsFor: 'accessing' stamp: ''!
hasCenter
	^ hasCenter! !

!RSAbstractSunburstLayout class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == RSAbstractSunburstLayout! !

!RSAbstractTick commentStamp: ''!
I define basic configuration for ticks, my subclasses creates lines and labels for each defined axis!
!RSAbstractTick methodsFor: 'public' stamp: ''!
asFloat
	self asFloat: 3! !

!RSAbstractTick methodsFor: 'rendering' stamp: ''!
createTickLineFor: aNumber
	^ self subclassResponsibility! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
numberOfTicks: aNumber
	"Set the number of ticks to be used. Can be used with doNotUseNiceLabels or not.
	
For example:
```Smalltalk
x := (-3.14 to: 3.14 count: 20).
y := x sin.

c := RSChart new.
d := RSLinePlot new x: x y: y.
c addPlot: d.
c addDecoration: (RSVerticalTick new).
c addDecoration: (RSHorizontalTick new numberOfTicks: 10; asFloat: 2).
c
```Smalltalk
	"
	self configuration numberOfTicks: aNumber! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
useNiceLabel
	"Ticks use RSNiceLabelGenerator"
	self configuration shouldUseNiceLabel: true! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
configuration
	^ configuration ifNil: [ configuration := self defaultConfiguration ]! !

!RSAbstractTick methodsFor: 'accessing - defaults' stamp: ''!
defaultConfiguration
	^ RSTickConfiguration new
		numberOfTicks: 5;
		fontSize: 5;
		labelRotation: 0;
		shouldHaveLabels: true;
		shouldUseNiceLabel: true;
		labelConversion: [ :value | value asFloat round: 3 ] ;
		tickSize: 3;
		yourself! !

!RSAbstractTick methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	| ticksData |
	ticksData := self ticksData.
	ticks := ticksData collect: [ :value | self createTickLineFor: value ].
	canvas addAll: ticks.
	self configuration shouldHaveLabels ifFalse: [
		labels := #().
		 ^ self ].
	labels := ticksData collectWithIndex: [ :value :index | 
		self createLabelFor: value index: index ].
	canvas addAll: labels.! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
withNoLabels
	"Ticks have no label"
	self configuration shouldHaveLabels: false! !

!RSAbstractTick methodsFor: 'accessing - defaults' stamp: ''!
defaultLabelLocation
	^ self subclassResponsibility! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
integerWithCommas
	"Do not convert the value when determining labels"
	self labelConversion: [ :value | value asInteger asStringWithCommas ]! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
createdShapes
	^ labels, ticks! !

!RSAbstractTick methodsFor: 'rendering' stamp: ''!
createLabelFor: aValue index: index
	"Create a label and returns it."
	| tick lbl |
	tick := self ticks at: index.
	lbl := self configuration createLabelFor: aValue.
	self color ifNotNil: [ lbl color: self color ].
	self labelLocation move: lbl on: tick.
	^ lbl
	! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
labelLocation
	^ labelLocation ifNil: [ labelLocation := self defaultLabelLocation ].! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
labelRotation: aNumber
	self configuration labelRotation: aNumber! !

!RSAbstractTick methodsFor: 'initialization' stamp: ''!
defaultShape
	^ RSLine new! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
doNotUseNiceLabel
	"Ticks use RSNiceLabelGenerator"
	self configuration shouldUseNiceLabel: false! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
ticks
	^ ticks! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
noConvertion
	"Do not convert the value when determining labels"
	self labelConversion: [ :value | value ]! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
labelConversion: oneArgBlock
	"This method is used to convert numerical values into a label. This is useful to particularlize labels on the X or Y axes. The parameter block accepts one argument, which is a numerical value. The block should return a string or any other object. When displayed, the message asString will be sent to it. 
	
	For example:
-=-=-=-=-=-=-=-=-=
x := #(-2 -1 0 1 2).
y := #(5 10 12 14 20).

c := RSChart new.
d := RSLinePlot new x: x y: y.
c addPlot: d.

c addDecoration: (RSVerticalTick new).
c addDecoration: (RSHorizontalTick new 
							numberOfTicks: x size; 
							labelConversion: [ :val | Date today addDays: val ] ).
c mustInclude0inY.
c
-=-=-=-=-=-=-=-=-=
	"
	self configuration labelConversion: oneArgBlock ! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
asFloat: numberOfDecimals
	"Do not convert the value when determining labels"
	self labelConversion: [ :value | value asFloat round: numberOfDecimals ]! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
createNiceLabelIn: aChart
	| nice |
	nice := aChart niceGenerator 
		searchMin: self min
		max: self max
		desired: self configuration numberOfTicks.
	^ nice! !

!RSAbstractTick methodsFor: 'rendering' stamp: ''!
beforeRenderingIn: aChart
	self min = self max 
		ifTrue: [ 
			niceLabel := self defaultNiceLabel.
			^ super beforeRenderingIn: aChart. ].
		
	niceLabel := self configuration shouldUseNiceLabel 
		ifTrue: [ self createNiceLabelIn: aChart ]
		ifFalse: [ self defaultNiceLabel ].
	super beforeRenderingIn: aChart.! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
ticksData
	niceLabel step isZero ifTrue: [ niceLabel step: 1 ].
	^ niceLabel min to: niceLabel max by: niceLabel step. 
	! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
min
	^ self subclassResponsibility! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
labelRotation
	^ self configuration labelRotation! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
integer
	"Do not convert the value when determining labels"
	self labelConversion: [ :value | value asInteger ]! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
withLabels
	"Make the tick have label"
	self configuration shouldHaveLabels: true! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
configuration: aRSTickConfiguration
	configuration := aRSTickConfiguration! !

!RSAbstractTick methodsFor: 'accessing - defaults' stamp: ''!
defaultNiceLabel
	| nice |
	nice := RSNiceLabel new.
	nice
		min: self min;
		max: self max;
		step: nice ticks / self configuration numberOfTicks.
	^ nice! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
fontSize: fontSizeToSet
	"Set the font size used by the labels associated to ticks"
	
"
For example:
-=-=-=-=-=-=-=-=-=
x := (-10 to: 10).
y := x * x.

c := RSChart new.
d := RSLinePlot new x: x y: y.
c addPlot: d.

c extent: 400 @ 400.
c addDecoration: (RSVerticalTick new fontSize: 20).
c addDecoration: (RSHorizontalTick new fontSize: 20).
c
-=-=-=-=-=-=-=-=-=
"
	self configuration fontSize: fontSizeToSet! !

!RSAbstractTick methodsFor: 'public' stamp: ''!
fromNames: aCollectionOfStrings
	self
		doNotUseNiceLabel;
		numberOfTicks: aCollectionOfStrings size-1.
	
	self labelConversion: [ :x | 
		x isZero 
			ifTrue: [ '' ]
			ifFalse: [aCollectionOfStrings at: x asInteger ] ].
		! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
labels
	^ labels! !

!RSAbstractTick methodsFor: 'accessing' stamp: ''!
max
	^ self subclassResponsibility! !

!RSAbstractTimer commentStamp: ''!
Users can set the timer of the canvas this will affect the animations process, by changing the speed of all of them in a canvas!
!RSAbstractTimer methodsFor: 'public' stamp: ''!
currentTime
	^ self subclassResponsibility! !

!RSAbstractTreeBuilder commentStamp: ''!
I am a abstract class to create visual elements based on tree structured in roassal3!
!RSAbstractTreeBuilder methodsFor: 'accessing - keys' stamp: ''!
weightKey
	^ #weight! !

!RSAbstractTreeBuilder methodsFor: 'private' stamp: ''!
createElements: atree nesting: block1 leaves: block2 depth: depth
	| children e leaves nodes|
	
	e := self shapeFor: atree.
	shapes add: e.
	
	children := block1 rsValue: atree.
	e properties at: #depth put: depth.
	children := children collect: [ :child | | e2 |
		e2 := self createElements: child nesting: block1 
			leaves: block2 depth: depth + 1.
		e2 properties at: #parent put: e.
		e2 ] as: Array.
	leaves := (block2 rsValue: atree) collect: [:child | | e2 |
		e2 := self createElements: child nesting: #() 
			leaves: #() depth: depth +1.
		e2 properties at: #parent put: e.
		e2 ] as: Array.
	nodes := OrderedCollection new: (leaves size + children size).
	nodes addAll: children; addAll: leaves.
		
	e schildren: nodes.
	^ e.! !

!RSAbstractTreeBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	rootNodes := RSGroup new.! !

!RSAbstractTreeBuilder methodsFor: 'public - building' stamp: ''!
from: objects using: ablock
	shapes := RSGroup new.
	"This is the main public method. Takes a list of objects, and a block to specify how to recurse"
	rootNodes := objects collect: [:obj | self createElements: obj using: ablock depth: 1 ].
	^ rootNodes! !

!RSAbstractTreeBuilder methodsFor: 'private' stamp: ''!
weightFromChildren: shape block: aBlock
	| children weightValue |
	children := shape schildren.
	weightValue := children
		ifEmpty: [ aBlock rsValue: shape model ]
		ifNotEmpty: [ 
			children 
				inject: 0 
				into: [ :s :child | s + (self weightLeafShape: child block: aBlock) ] ].
	^ weightValue max: self minWeightValue.
	! !

!RSAbstractTreeBuilder methodsFor: 'public - building' stamp: ''!
from: objects nesting: block1 leaves: block2
	shapes := RSGroup new.
	rootNodes := objects collect: [:obj | self createElements: obj nesting: block1 leaves: block2 depth: 1 ].
	^ rootNodes! !

!RSAbstractTreeBuilder methodsFor: 'private' stamp: ''!
weightLeafShape: shape block: aBlock
	^ shape
		propertyAt: self weightKey
		ifAbsentPut: [ 
			self weightFromChildren: shape block: aBlock ]! !

!RSAbstractTreeBuilder methodsFor: 'hooks' stamp: ''!
renderIn: aCanvas
	aCanvas addAll: self shapes! !

!RSAbstractTreeBuilder methodsFor: 'accessing' stamp: ''!
rootNodes: anArray
	rootNodes := anArray! !

!RSAbstractTreeBuilder methodsFor: 'private' stamp: ''!
createElements: atree using: ablock depth: depth
	| children shape |
	
	shape := self shapeFor: atree.
	shapes add: shape.
	
	children := ablock rsValue: atree.
	shape depth: depth.
	children := children collect: [ :child | | e2 |
		e2 := self createElements: child using: ablock depth: depth + 1.
		e2 sparent: shape.
		e2 ] as: Array.
	shape schildren: children.
	^ shape.! !

!RSAbstractTreeBuilder methodsFor: 'public - building' stamp: ''!
explore: atree nesting: block1 leaves: block2
	shapes := RSGroup new.
	^ (self from: (Array with: atree) nesting: block1 leaves: block2) first! !

!RSAbstractTreeBuilder methodsFor: 'hooks' stamp: ''!
shapeFor: anObject
	^ self subclassResponsibility! !

!RSAbstractTreeBuilder methodsFor: 'weight' stamp: ''!
weight: anObject
	"one arg block, example [:aRoassalShape | ]"
	weight := anObject! !

!RSAbstractTreeBuilder methodsFor: 'weight' stamp: ''!
leafWeight: block
	self weight: [ :shape | self weightLeafShape: shape block: block ].! !

!RSAbstractTreeBuilder methodsFor: 'weight' stamp: ''!
weight
	^ weight! !

!RSAbstractTreeBuilder methodsFor: 'weight' stamp: ''!
weightOf: aShape
	^ self weight rsValue: aShape! !

!RSAbstractTreeBuilder methodsFor: 'weight' stamp: ''!
modelWeight: anObject
	self weight: [ :shape | anObject rsValue: shape model ].! !

!RSAbstractTreeBuilder methodsFor: 'accessing' stamp: ''!
rootNodes
	^ rootNodes! !

!RSAbstractTreeBuilder methodsFor: 'accessing - defaults' stamp: ''!
minWeightValue
	^ 1! !

!RSAbstractTreeBuilder methodsFor: 'public - building' stamp: ''!
explore: atree using: ablock
	shapes := RSGroup new.
	^ (self from: (Array with: atree) using: ablock) first.
	! !

!RSAbstractUMLCalypso commentStamp: ''!
Base class for a calypso tool with uml over classes!
!RSAbstractUMLCalypso methodsFor: 'building' stamp: ''!
umlBuilder
	| builder |
	builder := RSUMLClassBuilder new.
	builder renderer: RSUMLCalypsoRenderer new.
	builder container: RSCanvas new.
	self applyTheme: builder.
	^ builder! !

!RSAbstractUMLCalypso methodsFor: 'private - utilities' stamp: ''!
limitedClasses: aCollection
	| limit |
	limit := 100.
	^ aCollection size < limit 
		ifTrue: [ aCollection ]
		ifFalse: [ aCollection copyFrom: 1 to: limit ].! !

!RSAbstractUMLCalypso methodsFor: 'accessing' stamp: ''!
computeClasses
	^ self subclassResponsibility! !

!RSAbstractUMLCalypso methodsFor: 'building' stamp: ''!
addClassInteractions: builder
	builder canvas nodes 
		when: RSMouseDoubleClick do: [ :evt | evt shape model browse ];
		when: RSMouseRightClick do: [ :evt | 
			| menu newContext tool |
			tool := ClyFullBrowserMorph on: ClyNavigationEnvironment currentImage.
			tool 
				prepareInitialStateBy: [ :b | b selectClass: evt shape model ].
			"newContext := ClyFullBrowserClassContext for: tool."
			newContext := context copy.
			newContext tool: tool.
			menu := CmdContextMenuActivation 
				buildContextMenuFor: evt canvas morph 
				inContext: newContext.
			menu popUpInWorld: self currentWorld.
			].! !

!RSAbstractUMLCalypso methodsFor: 'accessing' stamp: ''!
classesToShow: aCollection
	classesToShow := aCollection! !

!RSAbstractUMLCalypso methodsFor: 'building' stamp: ''!
applyTheme: builder
	| theme renderer |
	theme := Smalltalk ui theme.
	builder canvas color: theme backgroundColor.
	renderer := builder renderer.
	renderer border color: theme textColor.
	renderer marker shape color: theme backgroundColor.
	renderer textColor: theme textColor.
	renderer boxColor: theme classBoxBackgroundColor.
	builder modelDescriptor methodsLimit: theme methodsLimitUML.! !

!RSAbstractUMLCalypso methodsFor: 'building' stamp: ''!
build
	| canvas morph |
	canvas := self buildUmlCanvas.
	morph := canvas createMorph.
	morph onAnnouncement: MorphDeleted 
		do: [ self containerTab owner ifNotNil: [ self containerTab delete]].
	canvas when: RSMouseEnter do: [ morph takeKeyboardFocus].
	self addMorph: morph fullFrame: LayoutFrame identity! !

!RSAbstractUMLCalypso methodsFor: 'building' stamp: ''!
buildUmlCanvas
	| builder |
	builder := self umlBuilder.
	builder classes: self classesToShow.
	builder canvas @ self canvasController.
	builder build.
	self addClassInteractions: builder.
	
	^ builder canvas! !

!RSAbstractUMLCalypso methodsFor: 'accessing' stamp: ''!
classesToShow
	^ classesToShow ifNil: [ classesToShow := self limitedClasses: self computeClasses ]! !

!RSAbstractUMLCalypso methodsFor: 'public - hooks' stamp: ''!
canvasController
	| controls |
	controls := RSCanvasController new.
	controls configuration 
		useBasicZoom;
		maxScale: 2.
	^ controls! !

!RSAbstractUMLCalypso methodsFor: 'initialization' stamp: ''!
defaultIconName
	^#hierarchy! !

!RSAbstractUMLClassRenderer commentStamp: ''!
I have the roassal shapes to build the visualizacion!
!RSAbstractUMLClassRenderer methodsFor: 'accessing' stamp: ''!
classBoxPadding: aPoint
	padding := aPoint! !

!RSAbstractUMLClassRenderer methodsFor: 'defaults' stamp: ''!
defaultClassBoxPadding
	^ 10@10! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
methodFor: method
	^ RSLabel new
		model: method;
		color: self textColor;
		text: (modelDescriptor methodSelector rsValue: method);
		popup;
		yourself! !

!RSAbstractUMLClassRenderer methodsFor: 'layout' stamp: ''!
applyVLayoutOn: shapes
	self applyLayoutOn: shapes! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
methodsFor: model
	| shapes methods |
	methods := currentClassMethods := modelDescriptor methods rsValue: model.
	currentClassMethods size > modelDescriptor methodsLimit
		ifTrue: [ methods := currentClassMethods 
			copyFrom: 1 
			to: modelDescriptor methodsLimit ].
	shapes := methods collect: [ :met | self methodFor: met ].
	self applyMLayoutOn: shapes.
	^ RSComposite new
		shapes: shapes;
		yourself! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
adjustBox: box on: shapes 
	| rect |
	rect := shapes encompassingRectangle.
	box
		extent: rect extent + self classBoxPadding;
		position: rect floatCenter.! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
groupFor: shapes
	^ RSGroup streamContents: [ :stream |
		shapes do: [ :s | s hasChildren ifTrue: [ stream << s ] ] ]. ! !

!RSAbstractUMLClassRenderer methodsFor: 'testing' stamp: ''!
needsEllipsis 
	^ currentClassMethods isNotNil 
		and:  [ currentClassMethods size > modelDescriptor methodsLimit ]
		! !

!RSAbstractUMLClassRenderer methodsFor: 'defaults' stamp: ''!
defaultEdgeBuilder
	| offset |
	offset := -2.5.
	^ RSLineBuilder orthoVertical
		attachPoint: (RSVerticalAttachPoint new 
			startOffset: 11 - offset;
			endOffset: offset;
			yourself);
		border: self border;
		markerStart: self marker;
		yourself! !

!RSAbstractUMLClassRenderer methodsFor: 'edges' stamp: ''!
edgeBuilder: anEdgeBuilder
	edgeBuilder := anEdgeBuilder! !

!RSAbstractUMLClassRenderer methodsFor: 'public' stamp: ''!
renderAssociation: aCollection shape: aRSLine 
	aCollection ifNil: [ ^ self ].
	(RSLineBuilder new: aRSLine)
		withBorderAttachPoint;
		shapes: edgeBuilder fromShapes;
		useAssociations: aCollection.! !

!RSAbstractUMLClassRenderer methodsFor: 'defaults' stamp: ''!
defaultMarker
	^ RSMarker new 
		shape: (RSShapeFactory triangle
			color: Color white;
			border: self border;
			size: 20;
			yourself);
		yourself! !

!RSAbstractUMLClassRenderer methodsFor: 'edges' stamp: ''!
edgeBuilder
	^ edgeBuilder ifNil: [ edgeBuilder := self defaultEdgeBuilder ]! !

!RSAbstractUMLClassRenderer methodsFor: 'layout' stamp: ''!
applyLayoutOn: shapes
	RSVerticalLineLayout new gapSize: 1.5; on: shapes.! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
varFor: model

	^ RSLabel new
		  model: model;
		  color: self textColor;
		  text: (modelDescriptor instVarSelector rsValue: model);
		  yourself! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
ellipsisShape
	^ RSLabel new
		text: '...';
		color: self textColor;
		addInteraction: (RSPopup text: 'This class has more methods.' )
		yourself! !

!RSAbstractUMLClassRenderer methodsFor: 'accessing' stamp: ''!
aggregationShape
	| shape |
	shape := self compositionShape.
	
	shape markerEnd shape color: Color white.
	^ shape! !

!RSAbstractUMLClassRenderer methodsFor: 'layout' stamp: ''!
applyMLayoutOn: shapes
	self applyLayoutOn: shapes! !

!RSAbstractUMLClassRenderer methodsFor: 'public' stamp: ''!
renderAssociations
	self renderAssociation: self modelDescriptor compositions shape: self compositionShape.
	self renderAssociation: self modelDescriptor aggregations shape: self aggregationShape.
	! !

!RSAbstractUMLClassRenderer methodsFor: 'accessing' stamp: ''!
compositionShape
	| m |
	m := RSShapeFactory diamond extent: 10@15.
	m border: self border; color: self border color.
	m := m asMarker.
	m offset: 15 / 2.0.
	^ RSLine new
		markerEnd: m;
		border: self border;
		yourself.! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
titleFor: model
	| label |
	label := RSLabel new
		color: self textColor;
		text: (modelDescriptor classname rsValue: model);
		yourself.
	(modelDescriptor isAbstract rsValue: model) ifTrue: [ 
		label italic ].
	label fontSize: label fontSize.
	^ { label } asGroup asShape padding: 0@ 5; yourself
	! !

!RSAbstractUMLClassRenderer methodsFor: 'accessing' stamp: ''!
classBoxPadding
	^ padding ifNil: [ padding := self defaultClassBoxPadding ]! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
adjustTitle: title on: shapes 
	title position: shapes encompassingRectangle floatCenter x @ title position y.! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
createEllipsisIfNecessaryOn: aGroup
	| rect ellipsis |
	self needsEllipsis ifFalse: [ ^ self ].
	
	ellipsis := self ellipsisShape.
	rect := aGroup encompassingRectangle.
	ellipsis position: rect bottomCenter + (0@10).
	aGroup add: ellipsis.
	! !

!RSAbstractUMLClassRenderer methodsFor: 'defaults' stamp: ''!
defaultLayout
	| defaultLayout |
	defaultLayout := RSLayoutBuilder new.
	defaultLayout tree 
		verticalGap: 50; 
		horizontalGap: 50.
	^ defaultLayout! !

!RSAbstractUMLClassRenderer methodsFor: 'accessing' stamp: ''!
marker: aMarker
	marker := aMarker.! !

!RSAbstractUMLClassRenderer methodsFor: 'accessing' stamp: ''!
marker 
	^ marker ifNil: [ marker := self defaultMarker ]! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
varsFor: model
	| vars shapes |
	vars := modelDescriptor instVars rsValue: model.
	shapes := vars collect: [ :m | self varFor: m ].
	self applyVLayoutOn: shapes.
	^ RSComposite new
		shapes: shapes;
		padding: (Margin left: 0 right: 0 top: 3  bottom: 8 );
		yourself
		! !

!RSAbstractUMLClassRenderer methodsFor: 'hooks' stamp: ''!
classBoxShapeFor: aClass 
	^ RSBox new
		paint: self boxColor;
		border: self boxBorder;
		yourself! !

!RSAbstractUMLClassRenderer class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self name = #RSAbstractUMLClassRenderer ! !

!RSAbstractUMLPackageRenderer commentStamp: ''!
Abstract renderer for UML packages!
!RSAbstractUMLPackageRenderer methodsFor: 'accessing' stamp: ''!
packageColor
	^ packageColor ifNil: [ packageColor := self defaultPackageColor ]! !

!RSAbstractUMLPackageRenderer methodsFor: 'hooks' stamp: ''!
classBoxFor: aClass and: classNameShape
	^ RSBox new
		cornerRadius: 5;
		color: self classColor;
		border: self border;
		extent: classNameShape extent + 10;
		position: classNameShape position
		yourself! !

!RSAbstractUMLPackageRenderer methodsFor: 'accessing' stamp: ''!
packageColor: aColor
	packageColor := aColor! !

!RSAbstractUMLPackageRenderer methodsFor: 'accessing' stamp: ''!
classColor: aColor
	classColor := aColor! !

!RSAbstractUMLPackageRenderer methodsFor: 'defaults' stamp: ''!
defaultPackageColor
	^ Color colorFrom: '9ECAE1'! !

!RSAbstractUMLPackageRenderer methodsFor: 'hooks' stamp: ''!
packageBoxFor: title and: classes
	| boxTitle boxClasses rect cradius |
	RSVerticalLineLayout new gapSize: 0; on: { title. classes }.
	title translateBy: 10@ -5.
	rect := classes encompassingRectangle.
	cradius := RSCornerRadius new
		radius: 5;
		yourself.
	boxTitle := RSBox new
		position: title position; 
		extent: title extent + 10;
		cornerRadius: cradius;
		border: self border;
		color: self packageColor;
		yourself.
	boxClasses := RSBox new 
		position: rect floatCenter;
		extent: rect extent+10;
		cornerRadius: cradius;
		border: self border;
		color: self packageColor;
		yourself.
	^ RSComposite new
		addAll: { boxTitle. boxClasses };
		yourself.! !

!RSAbstractUMLPackageRenderer methodsFor: 'hooks' stamp: ''!
packageNameFor: aPackage
	| shape |
	shape := RSLabel new
		bold;
		text: (modelDescriptor packagename rsValue: aPackage);
		yourself.
	shape fontSize: shape fontSize * 1.2.
	^ shape! !

!RSAbstractUMLPackageRenderer methodsFor: 'hooks' stamp: ''!
classNameFor: aClass
	^ RSLabel new
		text: (modelDescriptor classname rsValue: aClass);
		yourself! !

!RSAbstractUMLPackageRenderer methodsFor: 'hooks' stamp: ''!
classesFor: aPackage
	| classes shapes |
	classes := modelDescriptor classes rsValue: aPackage.
	shapes := classes collect: [ :cls | self classFor: cls ].
	RSFlowLayout on: shapes.
	^ RSComposite new
		shapes: shapes;
		yourself.! !

!RSAbstractUMLPackageRenderer methodsFor: 'defaults' stamp: ''!
defaultClassColor
	^ Color colorFrom: 'DEEBF7'! !

!RSAbstractUMLPackageRenderer methodsFor: 'accessing' stamp: ''!
classColor
	^ classColor ifNil: [ classColor := self defaultClassColor ]! !

!RSAbstractUMLPackageRenderer methodsFor: 'hooks' stamp: ''!
classFor: aClass
	| box className |
	className := self classNameFor: aClass.
	box := self classBoxFor: aClass and: className.
	^ RSComposite new
		model: aClass;
		shapes: { box. className };
		popup;
		browseable;
		yourself.! !

!RSAbstractUMLPackageRenderer methodsFor: 'accessing' stamp: ''!
defaultLayout

	| defaultLayout |
	defaultLayout := RSLayoutBuilder new.
	defaultLayout vertical 
		verticalGap: 100; 
		horizontalGap: 50.
	^defaultLayout! !

!RSAbstractUMLPackageRenderer class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self name = #RSAbstractUMLPackageRenderer! !

!RSAbstractUMLRenderer commentStamp: ''!
Abstract renderer for UML!
!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
border
	^ border ifNil: [ border := self defaultBorder ].! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
layout
	^ layout ifNil: [ layout := self defaultLayout ]! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
boxColor: aColor
	boxColor := aColor! !

!RSAbstractUMLRenderer methodsFor: 'defaults' stamp: ''!
defaultBoxBorder
	^ RSBorder new
		width: 5; 
		joinMiter; 
		color: '666EA0';
		yourself ! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
modelDescriptor: aModelDescriptor
	modelDescriptor := aModelDescriptor! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
textColor: aColor
	textColor := aColor! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
boxBorder
	^ boxBorder ifNil: [ boxBorder := self defaultBoxBorder ]! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
defaultBoxColor
	^ Color colorFrom: 'cfd9df'! !

!RSAbstractUMLRenderer methodsFor: 'hooks' stamp: ''!
shapeFor: anObject
	^ self subclassResponsibility! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
boxColor 
	^ boxColor ifNil: [ boxColor := self defaultBoxColor ]! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
textColor
	^ textColor ifNil: [ textColor := self defaultTextColor ]! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
border: aBorder
	border := aBorder! !

!RSAbstractUMLRenderer methodsFor: 'hooks' stamp: ''!
setUpCanvas: aCanvas
	"overridde me"! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
defaultLayout
	^ self subclassResponsibility! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
boxBorder: aBorder
	boxBorder := aBorder! !

!RSAbstractUMLRenderer methodsFor: 'defaults' stamp: ''!
defaultTextColor
	^ Color black! !

!RSAbstractUMLRenderer methodsFor: 'accessing' stamp: ''!
modelDescriptor
	^ modelDescriptor! !

!RSAbstractUMLRenderer methodsFor: 'defaults' stamp: ''!
defaultBorder
	^ RSBorder new
		color: self textColor;
		yourself! !

!RSAbstractUMLRenderer class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self name = #RSAbstractUMLRenderer! !

!RSAbstractVerticalTreeLayout commentStamp: ''!
TODO!
!RSAbstractVerticalTreeLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	verticalGap := 20.
	horizontalGap := 3! !

!RSAbstractVerticalTreeLayout methodsFor: 'private - hook' stamp: ''!
computeChildrenFor: aNode
	self subclassResponsibility! !

!RSAbstractVerticalTreeLayout methodsFor: 'private' stamp: ''!
rearrangeByLayers: aGraph
	| cursor layerDepthSize |
	cursor := self topGap.
	nodesByLayer do: [:eachSetOfNodes |
		layerDepthSize := eachSetOfNodes inject: 0 into: [ :max :eachNode | 
			translator translateTopLeftOf: eachNode to: (eachNode position x @ cursor).
			max max: eachNode height ].
		cursor := cursor + layerDepthSize + self verticalGap ]! !

!RSAbstractVerticalTreeLayout methodsFor: 'private - hook' stamp: ''!
layout: aNodeCollection atPoint: aPoint atLayer: aNumber
	| treeSize childrenPosition x y middleOfTree |
	aNodeCollection isEmpty ifTrue: [ ^ 0 ].
	x := aPoint x.
	y := aPoint y.
	alreadyLayoutedNodes addAll: aNodeCollection.
	self atLayer: aNumber add: aNodeCollection.
	aNodeCollection do: [ :each |
		| children |
		childrenPosition := y + each height + self verticalGap.
		children := self computeChildrenFor: each.
		treeSize := self 
			layout: children
			atPoint: x @ childrenPosition
			atLayer: aNumber + 1.
		treeSize < each width ifTrue: [ 
			self translate: children by: (each width - treeSize) / 2.0 @ 0.
			treeSize := each width. ].
		
		middleOfTree := x + (treeSize / 2.0) - (each width / 2.0).
		translator translateTopLeftOf: each to: middleOfTree @ y.
		x := x + treeSize + self horizontalGap.
		self step ].
	^ x - aPoint x - self horizontalGap! !

!RSAbstractVerticalTreeLayout methodsFor: 'private - hook' stamp: ''!
translate: aNodeCollection by: delta
	aNodeCollection ifEmpty: [ ^ self ].
	aNodeCollection do: [ :each | 
		each translateBy: delta.
		self translate: (self childrenFor: each) by: delta]! !

!RSAbstractVerticalTreeLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = RSAbstractVerticalTreeLayout! !

!RSAbstractWeightedCircleLayout commentStamp: ''!
I am the abstract root class of weighted circle layout. Look at the class comments of my subclasses for more details.!
!RSAbstractWeightedCircleLayout methodsFor: 'hook' stamp: ''!
doExecute: elements
	"This method is used polymorphically"! !

!RSAbstractWeightedCircleLayout methodsFor: 'hook' stamp: ''!
weightSum: elements
	"Computes the sum of all elements 'weight' or size"
	| sum |
	sum := 0.
	elements
		do: [ :each |
			sum := sum + (each height)
		].
	^sum! !

!RSAbstractWrapStrategy commentStamp: ''!
My subclasses can define the way to wrap a text!
!RSAbstractWrapStrategy methodsFor: 'accessing' stamp: ''!
wrapMaxWidth: aNumber
	wrapMaxWidth := aNumber! !

!RSAbstractWrapStrategy methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self wrapMaxWidth: 200! !

!RSAbstractWrapStrategy methodsFor: 'accessing' stamp: ''!
wrapMaxWidth
	^ wrapMaxWidth! !

!RSAbstractWrapStrategy methodsFor: 'hooks' stamp: ''!
wrapTextFor: aString with: aRSMultilineLabelBuilder
	^ self subclassResponsibility! !

!RSAdaptativePopup commentStamp: ''!
This class is used to modify the popup behavior in Roassal3-UML

When classes in canvas are too small it will try to show the the entire class scaled to fit in the canvas. if not it will display the name in a box!
!RSAdaptativePopup methodsFor: 'accessing' stamp: ''!
smallBuilder: aRSSimplePopupBuilder 
	smallBuilder := aRSSimplePopupBuilder! !

!RSAdaptativePopup methodsFor: 'hooks' stamp: ''!
shapeFor: aRSShape
	^ (self isShapeWillVisibleInCanvas: aRSShape)
		ifTrue: [ self smallShapeFor: aRSShape ]
		ifFalse: [ self bigShapeFor: aRSShape ]! !

!RSAdaptativePopup methodsFor: 'hooks' stamp: ''!
smallShapeFor: aRSShape
	^ smallBuilder shapeFor: aRSShape model! !

!RSAdaptativePopup methodsFor: 'accessing' stamp: ''!
bigBuilder: aRSBuilder
	bigBuilder := aRSBuilder! !

!RSAdaptativePopup methodsFor: 'testing' stamp: ''!
isShapeWillVisibleInCanvas: aRSShape
	^ aRSShape canvas camera scale > 0.4! !

!RSAdaptativePopup methodsFor: 'hooks' stamp: ''!
bigShapeFor: aRSShape
	| popup |
	popup := bigBuilder shapeFor: aRSShape model.
	popup removeInteractionIfPresent: RSPopup.
	^ popup! !

!RSAlignment commentStamp: ''!
Define alignment of elements. 

For example, inspect the following:
-=-=-=
c := RSCanvas new.
es := (1 to: 5) collect: [ :v | RSBox new size: v * 5 ] as: RSGroup.
RSVerticalLineLayout on: es.
align := RSAlignment new.
align shapes: es.
align right.
c addAll: es.
c
-=-=-=!
!RSAlignment methodsFor: 'public' stamp: ''!
center
"
Center all the shapes along their X coordinate
-=-=-=-
c := RSCanvas new.
es := (1 to: 5) collect: [ :v | RSBox new color: Color gray trans; size: v * 5 ] as: RSGroup.
RSVerticalLineLayout on: es.
align := RSAlignment new.
align shapes: es.
align center.
c addAll: es.
c
-=-=-=-
"
	self hasShape ifFalse: [ ^ self ].
	self alignFromCenterUsing: self centerMostShape! !

!RSAlignment methodsFor: 'alignment' stamp: ''!
alignFromMiddleUsing: aShape
	| midY |
	midY := aShape position y.	
	shapes do: [ :s |	
		s translateTo: s position x @ midY
	]! !

!RSAlignment methodsFor: 'public' stamp: ''!
bottom
"
Align all the shapes on the bottoms of the shapes.

-=-=-=-=-=-=-=-=
c := RSCanvas new.
es := (1 to: 5) collect: [ :v | RSBox new color: Color gray trans; size: v * 5 ] as: RSGroup.
RSHorizontalLineLayout on: es.
align := RSAlignment new.
align shapes: es.
align bottom.
c addAll: es.
c
-=-=-=-=
"
	self hasShape ifFalse: [ ^ self ].
	self alignFromBottomUsing: self bottomMostShape ! !

!RSAlignment methodsFor: 'public' stamp: ''!
right
	self hasShape ifFalse: [ ^ self ].
	self alignFromRightUsing: self rightMostShape ! !

!RSAlignment methodsFor: 'alignment' stamp: ''!
alignFromLeftUsing: aShape
	| topX newX |
	topX := aShape encompassingRectangle topLeft x.
	shapes do: [ :s |
		newX := topX + (s encompassingRectangle width / 2).
		s translateTo: newX @ s position y
	]! !

!RSAlignment methodsFor: 'public' stamp: ''!
left
	self hasShape ifFalse: [ ^ self ].
	self alignFromLeftUsing: self leftMostShape ! !

!RSAlignment methodsFor: 'alignment' stamp: ''!
alignFromLabelUsing: aRSLabel
	| topY yb |
	topY := aRSLabel encompassingRectangle top.
	yb := aRSLabel textExtents y_bearing.
	shapes do: [ :s |	
		s translateTo: s position x @ (topY + (s extent y / 2.0) + s textExtents y_bearing-yb).
	]! !

!RSAlignment methodsFor: 'accessing - computed' stamp: ''!
topMostShape
	fixedShape ifNotNil: [ ^ fixedShape ].
	^ shapes inject: shapes first into: [ :maxS :s | 
			maxS encompassingRectangle top >= s encompassingRectangle top
					ifTrue: [ s ] ifFalse: [ maxS ] ] ! !

!RSAlignment methodsFor: 'alignment' stamp: ''!
alignFromCenterUsing: aShape
	| topX |
	topX := aShape position x.
	shapes do: [ :s |
		s translateTo: topX @ s position y
	]! !

!RSAlignment methodsFor: 'accessing - computed' stamp: ''!
centerMostShape
	fixedShape ifNotNil: [ ^ fixedShape ].
	^ shapes inject: shapes first into: [ :maxS :s | 
			maxS encompassingRectangle floatCenter <= s encompassingRectangle floatCenter
					ifTrue: [ s ] ifFalse: [ maxS ] ]! !

!RSAlignment methodsFor: 'alignment' stamp: ''!
alignFromBottomUsing: aShape
	"The argument aShape is a fix point. It does not move"
	| topY newY |
	topY := aShape encompassingRectangle bottomCenter y.
	shapes do: [ :s |
		newY := topY - (s encompassingRectangle height / 2).
		s translateTo: s position x @ newY
	]! !

!RSAlignment methodsFor: 'alignment' stamp: ''!
alignFromTopUsing: aShape
	| topY newY |
	topY := aShape encompassingRectangle topCenter y.
	shapes do: [ :s |
		newY := topY + (s encompassingRectangle height / 2).
		s translateTo: s position x @ newY
	]! !

!RSAlignment methodsFor: 'alignment' stamp: ''!
alignFromRightUsing: aShape
	| topX newX |
	topX := aShape encompassingRectangle topRight x.
	shapes do: [ :s |
		newX := topX - (s encompassingRectangle width / 2).
		s translateTo: newX @ s position y
	]! !

!RSAlignment methodsFor: 'public' stamp: ''!
middle
"Center all the shapes along their Y coordinate

```Smalltalk
c := RSCanvas new.
es := (1 to: 5) collect: [ :v | RSBox new color: Color gray translucent; size: v * 5 ] as: RSGroup.
RSHorizontalLineLayout on: es.
align := RSAlignment new.
align shapes: es.
align middle.
c addAll: es.
c
```
"
	self hasShape ifFalse: [ ^ self ].
	self alignFromMiddleUsing: self centerMostShape! !

!RSAlignment methodsFor: 'accessing - computed' stamp: ''!
rightMostShape
	"Return the shape that is the located the most on the right hand side"
	fixedShape ifNotNil: [ ^ fixedShape ].
	^ shapes inject: shapes first into: [ :maxS :s | 
			maxS encompassingRectangle right <= s encompassingRectangle right
					ifTrue: [ s ] ifFalse: [ maxS ] ] ! !

!RSAlignment methodsFor: 'public' stamp: ''!
top
	self hasShape ifFalse: [ ^ self ].
	self alignFromTopUsing: self topMostShape ! !

!RSAlignment methodsFor: 'testing' stamp: ''!
hasShape
	"Return true if some shapes have been set"
	^ (shapes isNil or: [ shapes isEmpty ]) not! !

!RSAlignment methodsFor: 'accessing - computed' stamp: ''!
bottomMostShape
	fixedShape ifNotNil: [ ^ fixedShape ].
	^ shapes inject: shapes first into: [ :maxS :s | 
			maxS encompassingRectangle bottom <= s encompassingRectangle bottom
					ifTrue: [ s ] ifFalse: [ maxS ] ] ! !

!RSAlignment methodsFor: 'public' stamp: ''!
label
	self hasShape ifFalse: [ ^ self ].
	self alignFromLabelUsing: self centerMostShape! !

!RSAlignment methodsFor: 'accessing - computed' stamp: ''!
leftMostShape
	"Return the shape that is the located the most on the left hand side"
	fixedShape ifNotNil: [ ^ fixedShape ].
	^ shapes inject: shapes first into: [ :maxS :s | 
			maxS encompassingRectangle left >= s encompassingRectangle left
					ifTrue: [ s ] ifFalse: [ maxS ] ] ! !

!RSAlignmentTest methodsFor: 'tests' stamp: ''!
testFromLeftWithAFixShape
	| es |
	es := (10 to: 100 by: 10) collect: [ :n | RSBox new size: n; yourself ].
	align shapes: es.
	RSVerticalLineLayout on: es.
	es second translateBy: -150 @ 0.
	align fixedShape: es first.
	align left.
	self assert: (es collect: [ :e | e encompassingRectangle left ]) asArray equals: #(0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)
"	
	RSView new addAll: es; inspect.
	"! !

!RSAlignmentTest methodsFor: 'tests' stamp: ''!
testFromTopWithAFixShape
	| es |
	es := (10 to: 100 by: 10) collect: [ :n | RSBox new size: n; yourself ].
	align shapes: es.
	RSHorizontalLineLayout on: es.
	es second translateBy: 0 @ -50.
	align fixedShape: es third.
	
	self assert: (es collect: [ :e | e encompassingRectangle top ]) asArray equals: #(0.0 -50.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0).
	self assert: align topMostShape equals: es third.
	align top.
	self assert: (es collect: [ :e | e encompassingRectangle top ]) asArray equals: #(0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0).
"
For debugging only:

RSCanvas new addAll: es; yourself.
"! !

!RSAlignmentTest methodsFor: 'tests' stamp: ''!
testFromBottom
	| es |
	es := (10 to: 100 by: 10) collect: [ :n | RSBox new size: n; yourself ].
	align shapes: es.
	RSHorizontalLineLayout on: es.
	es second translateBy: 0 @ 150.
	self assert: (es collect: [ :e | e encompassingRectangle bottom ]) asArray equals: #(10.0 170.0 30.0 40.0 50.0 60.0 70.0 80.0 90.0 100.0).
	self assert: align bottomMostShape equals: es second.
	align bottom.
	self assert: (es collect: [ :e | e encompassingRectangle bottom ]) asArray equals: #(170.0 170.0 170.0 170.0 170.0 170.0 170.0 170.0 170.0 170.0)
	"	
	RSView new addAll: es; yourself.
	"! !

!RSAlignmentTest methodsFor: 'tests' stamp: ''!
testFromLeftWithFixedShape
	| es c |
	es := (10 to: 100 by: 10) collect: [ :n | RSBox new size: n; yourself ].
	align shapes: es.
	RSVerticalLineLayout on: es.
	es second translateBy: -150 @ 0.

	c := RSCanvas new.
	c addAll: es.
	es do: [ :s | s setAsFixed ].

	self assert: (es collect: [ :e | e encompassingRectangle left ]) asArray equals: #(0.0 -150.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0).
	self assert: align leftMostShape equals: es second.
	align left.
	self assert: (es collect: [ :e | e encompassingRectangle left ]) asArray equals: #(-150.0 -150.0 -150.0 -150.0 -150.0 -150.0 -150.0 -150.0 -150.0 -150.0)
"	
	RSView new addAll: es; inspect.
	"! !

!RSAlignmentTest methodsFor: 'tests' stamp: ''!
testCenter 
	| es |
	es := (1 to: 5) collect: [ :v | RSBox new size: 10 ] as: RSGroup.
	RSHorizontalLineLayout on: es.
	align shapes: es.
	self assert: align middle equals: align.
	self assert: es encompassingRectangle equals: ((0.0@0.0) corner: (90.0@10.0)).
	"	
	RSCanvas new addAll: es; yourself.
	"! !

!RSAlignmentTest methodsFor: 'tests' stamp: ''!
testFromLeft
	| es |
	es := (10 to: 100 by: 10) collect: [ :n | RSBox new size: n; yourself ].
	align shapes: es.
	RSVerticalLineLayout on: es.
	es second translateBy: -150 @ 0.
	self assert: (es collect: [ :e | e encompassingRectangle left ]) asArray equals: #(0.0 -150.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0).
	self assert: align leftMostShape equals: es second.
	align left.
	self assert: (es collect: [ :e | e encompassingRectangle left ]) asArray equals: #(-150.0 -150.0 -150.0 -150.0 -150.0 -150.0 -150.0 -150.0 -150.0 -150.0)
"	
	RSView new addAll: es; inspect.
	"! !

!RSAlignmentTest methodsFor: 'tests' stamp: ''!
testHasElement
	self deny: align hasShape.
	align shapes: (Array with: RSBox new).
	self assert: align hasShape.
	align shapes: #().
	self deny: align hasShape.! !

!RSAlignmentTest methodsFor: 'tests' stamp: ''!
testFromTop
	| es |
	es := (10 to: 100 by: 10) collect: [ :n | RSBox new size: n; yourself ].
	align shapes: es.
	RSHorizontalLineLayout on: es.
	es second translateBy: 0 @ -50.
	self assert: (es collect: [ :e | e encompassingRectangle top ]) asArray equals: #(0.0 -50.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0).
	self assert: align topMostShape equals: es second.
	align top.
	self assert: (es collect: [ :e | e encompassingRectangle top ]) asArray equals: #(-50.0 -50.0 -50.0 -50.0 -50.0 -50.0 -50.0 -50.0 -50.0 -50.0).! !

!RSAlignmentTest methodsFor: 'tests' stamp: ''!
testFromRight
	| es |
	es := (10 to: 100 by: 10) collect: [ :n | RSBox new size: n; yourself ].
	align shapes: es.
	RSVerticalLineLayout on: es.
	es second translateBy: 150 @ 0.
	self assert: (es collect: [ :e | e encompassingRectangle right ]) asArray equals: #(10.0 170.0 30.0 40.0 50.0 60.0 70.0 80.0 90.0 100.0).
	self assert: align rightMostShape equals: es second.
	align right.
	self assert: (es collect: [ :e | e encompassingRectangle right ]) asArray equals: #(170.0 170.0 170.0 170.0 170.0 170.0 170.0 170.0 170.0 170.0)! !

!RSAlignmentTest methodsFor: 'tests' stamp: ''!
testNoErrorOnDefault

	RSAlignment new left; right; top; bottom! !

!RSAlignmentTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	align := RSAlignment new.! !

!RSAnimatedPopup commentStamp: ''!
I am a basic popup for animated content in a view of roassal3!
!RSAnimatedPopup methodsFor: 'hooks' stamp: ''!
translatePopup: popup event: evt 
	| p pscale canvasExtent side scale rect shape canvas |
	canvas := evt canvas.
	shape := evt shape.
	canvasExtent := canvas extent.
	
	popup translateTo: 0@0.
	shape isFixed ifTrue: [ 
		rect := shape encompassingRectangle.
		p := rect floatCenter.
		p := p + (0@(shape height + popup height + 10 / 2)).
	] ifFalse: [ 
		rect := shape 
			computeEncompassingRectangleFor: shape baseRectangle 
			matrix: shape globalMatrix.
		p := (canvas camera 
			fromSpaceToPixel: rect bottomCenter)+(0@(popup height +	10/ 2)).
	 ].
	
	side := popup width / 2.
	p x + side > canvasExtent x
		ifTrue: [ p := (canvasExtent x - side - 5)@ p y ].
	
	popup translateTo: p.
	
	"animation part"
	pscale := NSScale linear range: { p x @ (p y - (popup height / 2) ) . p }.
	scale := popup matrix sx @ popup matrix sy.
	evt shape newAnimation 
		duration: 300 milliSeconds; 
		from: 0.05; to: 1;
		easing: RSEasingInterpolator backOut;
		onStepDo: [ :t | 
			popup matrix 
				loadIdentity;
				translation: (pscale scale: t);
				scaleBy: (1@t) * scale.
			evt signalUpdate.
			].! !

!RSAnimatedPopup class methodsFor: 'accessing' stamp: ''!
activationEvent
	^ RSMouseEnter! !

!RSAnimatedPopup class methodsFor: 'accessing' stamp: ''!
removeEvents
	^ { RSMouseClick. RSMouseLeave. RSMouseDragging }! !

!RSAnimationEndEvent commentStamp: ''!
For when the animation is removed or ends from the canvas!
!RSAnimationEvent commentStamp: ''!
I an an event for animations in trachel!
!RSAnimationEvent methodsFor: 'accessing' stamp: ''!
animation
	^ animation! !

!RSAnimationEvent methodsFor: 'accessing' stamp: ''!
animation: anAnimation
	animation := anAnimation.! !

!RSAnimationLoopEvent commentStamp: ''!
for loop events!
!RSAnimationLoopEvent methodsFor: 'accessing' stamp: ''!
currentLoop
	^ animation currentLoop! !

!RSAnimationStartEvent commentStamp: ''!
When the animation starts!
!RSAnimationTest commentStamp: ''!
base of animation tests!
!RSAnimationTest methodsFor: 'tests' stamp: ''!
addingInComposite: compositeAnimation duration: aDuration
	compositeAnimation
		add: (RSTransitionAnimation new
			duration: 1 second);
		add: (RSTransitionAnimation new
			duration: 2 seconds).
	canvas addAnimation: compositeAnimation.
	self assert: compositeAnimation isRunning.
	self assert: compositeAnimation duration equals: aDuration.! !

!RSAnimationTest methodsFor: 'tests' stamp: ''!
createAnimationWith: block animationClass: class
	| animation |
	self assert: canvas animations size equals: 0.
	animation := block value.
	self assert: canvas animations size equals: 1.
	self assert: animation class equals: class.
	! !

!RSAnimationTest methodsFor: 'running' stamp: ''!
runAnimation: animation threshold: threshold
	| time ended |
	
	ended := false.
	animation when: RSAnimationEndEvent do: [ :evt | ended := true ].
	time := Time now asDuration.
	[ ended ] whileFalse: [ 
		(Time now asDuration - time) > threshold milliSeconds ifTrue: [ 
			"time up"
			self error: 'Time up'.
			^ self ].
		canvas playAnimations.
		].! !

!RSAnimationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new.! !

!RSArrowedLine commentStamp: ''!
`RSArrowedLine` describes a line with a head or marker. 

Here is an example:

```
| c from to l |
c := RSCanvas new.

from := RSBox new size: 30.
to := RSEllipse new size: 30.

from @ RSDraggable.
to @ RSDraggable.

c add: from.
c add: to.

l := RSArrowedLine new.
l attachPoint: RSCenteredAttachPoint new.
l from: from.
l to: to.
c add: l.

to translateBy: 50 @ 40.

c @ RSCanvasController.
c open
```

Adding single line can be complex in some situation. You may want to look at RSLineBuilder arrowedLine!
!RSArrowedLine methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self markerEnd: self defaultHead.! !

!RSArrowedLine methodsFor: 'initialization' stamp: ''!
defaultHead
	^ RSPolygon new
		privatePoints: { -5@5. 0@0. 5@5. 0@0 };
		border: self border;
		yourself! !

!RSArrowedLine methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	markers := nil.
	self markerEnd: self defaultHead.
	self border: self border copy.! !

!RSArrowedLine methodsFor: 'copying' stamp: ''!
copy
	| copy head |
	copy := super copy.
	head := copy markerEnd shape.
	copy markerEnd: self markerEnd copy.
	copy markerEnd shape: head.
	^ copy! !

!RSArrowedLine methodsFor: 'border' stamp: ''!
border: aRSBorder
	super border: aRSBorder.
	self markersDo: [ :m | m shape border: aRSBorder ].! !

!RSAthensMorph commentStamp: ''!
A RSAthensMorph is at the interface between Morphic and Roassal. 
I am directly referenced by RSCanvas!
!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
shapeForEvent: anEvent
	"Return the Trachel shape for the event provided as argument"
	^ self shapeWithActionForPositionInPixels: (self relativePositionFor: anEvent)! !

!RSAthensMorph methodsFor: 'testing' stamp: ''!
isDragging
	^ eventBeginingDragging notNil! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
shapeWithActionForPositionInPixels: point
	"Return the shape with event handler located that contains point"
	 ^ roassalCanvas shapeWithActionForPositionInPixels: point! !

!RSAthensMorph methodsFor: 'events - roassal' stamp: ''!
relativePositionFor: evt
	^ evt position - self bounds origin! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventMouseUp: aMorphicEvent
	| trEvent |
	trEvent := self
		mouseEventOfClass: RSMouseUp
		ifLeftButton: RSMouseUpLeft  
		ifRightButton: RSMouseUpRight
		from: aMorphicEvent.
	trEvent position: (roassalCanvas camera fromPixelToSpace: trEvent position).
	trEvent shape announce: trEvent.! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
wouldAcceptKeyboardFocusUponTab
	"Answer whether the receiver might accept keyboard focus if 
	tab were hit in some container playfield"
	^ true! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
roassalCanvas
	"Return the Roassal canvas that I have to render"
	^ roassalCanvas! !

!RSAthensMorph methodsFor: 'initialization' stamp: ''!
layoutChanged
	"react on morph resize"

	super layoutChanged.
	self checkSession.
	! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventMouseEnter: aMorphicEvent
	| trEvent |
	trEvent := self eventOfClass: RSMouseEnter from: aMorphicEvent.
	trEvent shape announce: trEvent.! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventKeyUp: aMorphicEvent
	| trEvent |
	trEvent := self eventOfClass: RSKeyUp from: aMorphicEvent.
	trEvent
		position: (roassalCanvas camera fromPixelToSpace: trEvent position);
		keyValue: aMorphicEvent keyValue;
		keyName: aMorphicEvent key name.
	trEvent shape announce: trEvent! !

!RSAthensMorph methodsFor: 'events - processing' stamp: ''!
handlesMouseWheel: evt
	^true! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
renderer
	^ renderer! !

!RSAthensMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self createSurface.
	session := Smalltalk session.
	isDrawing := false! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
mouseEnter: evt
	evt anyButtonPressed
		ifFalse: [ self eventMouseEnter: evt ].
	evt wasHandled: true! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventMouseDragStart: aMorphicEvent
	| trEvent trEventClass |
	eventBeginingDragging := aMorphicEvent copy.
	
	trEventClass := RSMouseDragStart.
	aMorphicEvent redButtonChanged
		ifTrue: [ trEventClass := RSMouseLeftDragStart ].
	aMorphicEvent yellowButtonChanged
		ifTrue: [ trEventClass := RSMouseRightDragStart ].
	aMorphicEvent blueButtonChanged
		ifTrue: [ trEventClass := RSMouseMiddleDragStart ].
	trEvent := self eventOfClass: trEventClass actionClass: RSMouseDragging from: aMorphicEvent.

	shapeBeingPointed := trEvent shape.
	shapeBeingPointed announce: trEvent.
	! !

!RSAthensMorph methodsFor: 'events - processing' stamp: ''!
handleMouseOver: aMorphicEvent
	| currentElement trEvent |
	super handleMouseOver: aMorphicEvent.
	aMorphicEvent wasHandled
		ifTrue: [ ^ self ].	"Do nothing if it was already handled"
	self isDragging
		ifTrue: [ ^ self ].	"Do nothing if we are dragging"
	lastMousePosition = aMorphicEvent position 
		ifTrue: [ ^ self].		"Do nothing if it is in the same position"
	shapeBeingPointed ifNil: [ shapeBeingPointed := self shapeForEvent: aMorphicEvent ].
	
	currentElement := self shapeForEvent: aMorphicEvent.
	lastMousePosition := aMorphicEvent position.
	currentElement == shapeBeingPointed 
		ifTrue: [ ^ self ].
	trEvent := self eventOfClass: RSMouseLeave from: aMorphicEvent.
	trEvent shape: shapeBeingPointed.
	shapeBeingPointed announce: trEvent.
	shapeBeingPointed := currentElement.
	self eventMouseEnter: aMorphicEvent.! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventMouseWheel: aMorphicEvent
	| trEvent |
	trEvent := self eventOfClass: RSMouseWheelEvent from: aMorphicEvent.
	trEvent
		direction: aMorphicEvent direction;
		position: (roassalCanvas camera fromPixelToSpace: trEvent position).
	trEvent shape announce: trEvent.! !

!RSAthensMorph methodsFor: 'signaling' stamp: ''!
signalUpdate
	self changed! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventMouseDoubleClick: aMorphicEvent
	| trEvent |
	trEvent := self
		mouseEventOfClass: RSMouseDoubleClick
		ifLeftButton: RSMouseDoubleLeftClick
		ifRightButton: RSMouseDoubleRightClick
		from: aMorphicEvent.
	trEvent position: (roassalCanvas camera fromPixelToSpace: trEvent position).
	trEvent shape announce: trEvent.! !

!RSAthensMorph methodsFor: 'testing' stamp: ''!
wantsSteps
	^ roassalCanvas hasAnimation ! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
mouseUp: evt
	self isDragging
		ifTrue: [ self eventMouseDragEnd: evt ]
		ifFalse: [ self eventMouseUp: evt ].
	evt wasHandled: true! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: anEvent
	^ anEvent wasHandled not	"not interested if handled"! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
hasFocus
	^ true! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventMouseDragging: aMorphicEvent
	| trEvent step |
	eventBeginingDragging ifNil: [ ^ self ].
	step := aMorphicEvent position - eventBeginingDragging position.

	trEvent := self eventOfClass: RSMouseDragging from: aMorphicEvent.
	trEvent position: (roassalCanvas camera fromPixelToSpace: trEvent position).
	trEvent step: step.

	shapeBeingPointed ifNil: [ shapeBeingPointed := trEvent shape ].
	"If the element was removed during the drag then cancel the event"
	shapeBeingPointed parent ifNil: [
		eventBeginingDragging := nil.
		shapeBeingPointed := nil.
		^ self ].

	trEvent shape: shapeBeingPointed.
	shapeBeingPointed announce: trEvent.
	eventBeginingDragging := aMorphicEvent copy.
	! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
shapeWithAction: eventClass forPositionInPixels: position
	"Return the shape with event handler located that contains point"
	 ^ roassalCanvas shapeWithAction: eventClass forPositionInPixels: position! !

!RSAthensMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Draw the whole visualization"
	isDrawing ifTrue: [ ^ self ].
	isDrawing := true.
	[ 
		self checkSession.
		self recreateSurfaceIfNecessary.
		aCanvas fillRectangle: bounds color: roassalCanvas color.
		roassalCanvas playAnimations.
		self drawShapes.

		surface hasBeenFreed
			ifTrue: [ self createSurface ].
		[ aCanvas
			image: surface asForm
			at: self bounds origin asIntegerPoint
			sourceRect: (0 @ 0 extent: surface extent)
			rule: 34 ]
		on: Exception
		do: [ :ex |  ] ] 
	ensure: [ 
		isDrawing := false ]! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
shapeForPositionInPixels: point
	"Return the shape located that contains point"
	 ^ roassalCanvas shapeForPositionInPixels: point! !

!RSAthensMorph methodsFor: 'signaling' stamp: ''!
step
	self wantsSteps ifFalse: [ ^ self ].
	self changed! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
canvas: aRoassalCanvas
	roassalCanvas := aRoassalCanvas! !

!RSAthensMorph methodsFor: 'surface management' stamp: ''!
createSurface
	surface := AthensCairoSurface extent: self extent asIntegerPoint.
	session := Smalltalk session.! !

!RSAthensMorph methodsFor: 'drawing' stamp: ''!
showRectanglesIfNecessary: shapes
	roassalCanvas showRectangles ifFalse: [ ^ self ].
	
	renderer canvas setPaint: (Color blue alpha: 0.2).
	shapes do: [ :shape | | r |
		r := shape encompassingRectangle.
		r := r origin asFloatPoint corner: r corner asFloatPoint.
		renderer canvas drawShape: r.
		].! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
mouseWheel: evt
	self eventMouseWheel: evt.
	evt wasHandled: true! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
surface
	^ surface! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: evt
	evt anyButtonPressed
		ifFalse: [ self eventMouseLeave: evt ].
	evt wasHandled: true! !

!RSAthensMorph methodsFor: 'public' stamp: ''!
setTakeKeyboardFocus
	self takeKeyboardFocus.
	roassalCanvas when: RSUserInputEvent do: [ self takeKeyboardFocus ].! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt
	^ true! !

!RSAthensMorph methodsFor: 'events - processing' stamp: ''!
handleMouseMove: anEvent
	super handleMouseMove: anEvent.
	anEvent anyButtonPressed ifFalse: [ self eventMouseMove: anEvent ].
	
	! !

!RSAthensMorph methodsFor: 'drawing' stamp: ''!
drawOnMockCanvas
	"This method is used to trigger all the rendering in a temporary FormCanvas. This method is useful when a bug happens when rendering. Such situation are difficult to debug to the multi-threading and low level graphical primitive. The method #drawOnMockCanvas helps addressing this.

Here is an example:
v := RTView new.
es := RTBox elementsOn: (1 to: 10).
v addAll: es.
RTGridLayout on: es.
v canvas buildMorph drawOnMockCanvas

	"
	self drawOn: (FormCanvas extent: self extent)! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
surface: anAthensCairoSurface 
	surface := anAthensCairoSurface! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
canvas
	^ roassalCanvas! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventMouseMove: aMorphicEvent
	| trEvent |
	trEvent := self eventOfClass: RSMouseMove from: aMorphicEvent.
	trEvent position: (roassalCanvas camera fromPixelToSpace: trEvent position).
	trEvent shape announce: trEvent.! !

!RSAthensMorph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: aCanvas
	self fullDrawOnAthensCanvas: aCanvas! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventMouseLeave: aMorphicEvent
	| trEvent |
	trEvent := self eventOfClass: RSMouseLeave from: aMorphicEvent.
	shapeBeingPointed ifNotNil: [ 
		trEvent shape: shapeBeingPointed].
	trEvent shape announce: trEvent.! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
mouseMove: evt
	evt anyButtonPressed
		ifTrue: [ self eventMouseDragging: evt ]
		ifFalse: [ self eventMouseMove: evt ].
	evt wasHandled: true! !

!RSAthensMorph methodsFor: 'signaling' stamp: ''!
stepTime
	"Answer the desired time between steps in milliseconds. This default implementation requests that the 'step' method be called once every second."

	^ 10! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventMouseDragEnd: aMorphicEvent
	| trEvent |
	trEvent := self eventOfClass: RSMouseDragEnd from: aMorphicEvent.
	trEvent shape: shapeBeingPointed.
	shapeBeingPointed announce: trEvent.
	
	eventBeginingDragging := nil.! !

!RSAthensMorph methodsFor: 'drawing' stamp: ''!
fullDrawOnAthensCanvas: aCanvas

	isDrawing ifTrue: [ ^ self ].
	isDrawing := true.
	[  
		self checkSession.
		self recreateSurfaceIfNecessary.
		
		aCanvas setPaint: roassalCanvas color.
		aCanvas drawShape: bounds.
		roassalCanvas playAnimations.
		self drawShapes.
		surface hasBeenFreed ifTrue: [ self createSurface ].	

		aCanvas pathTransform restoreAfter: [
			aCanvas pathTransform loadIdentity.
			aCanvas paintMode restoreAfter: [
				aCanvas 
					setPaint: surface;
					drawShape: (0@0 extent: self extent) ] ] ]
	ensure: [ 
		isDrawing := false ]! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
handleKeyDown: anEvent
	
	super handleKeyDown: anEvent.
	self eventKeyDown: anEvent.! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventKeyDown: aMorphicEvent
	| trEvent |
	trEvent := self eventOfClass: RSKeyDown from: aMorphicEvent.
	trEvent
		position: (roassalCanvas camera fromPixelToSpace: trEvent position);
		keyValue: aMorphicEvent keyValue;
		keyName: aMorphicEvent key name. "(self class keyNameFor: aMorphicEvent keyValue)".
	trEvent shape announce: trEvent.
! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
isDrawing
	^ isDrawing! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventOfClass: anEventClass actionClass: anActionClass from: aMorphicEvent
	| relativePosition trEvent shape |
	relativePosition := self relativePositionFor: aMorphicEvent.
	shape := self shapeWithAction: anActionClass forPositionInPixels: relativePosition. 
	
	trEvent := anEventClass fromEvent: aMorphicEvent.
	trEvent
		morph: self;
		canvas: roassalCanvas;
		shape: shape;
		position: relativePosition.
	^ trEvent! !

!RSAthensMorph methodsFor: 'accessing' stamp: ''!
renderer: aRenderer
	renderer := aRenderer! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventMouseClick: aMorphicEvent
	| trEvent |
	trEvent := self
		mouseEventOfClass: RSMouseClick
		ifLeftButton: RSMouseLeftClick
		ifRightButton: RSMouseRightClick
		from: aMorphicEvent.
	trEvent position: (roassalCanvas camera fromPixelToSpace: trEvent position).
	trEvent shape announce: trEvent.! !

!RSAthensMorph methodsFor: 'drawing' stamp: ''!
drawShapes
	"The drawing has to be done when a change in the shapes occured or when there is an animation."
	
	surface drawDuring: [ :athensCanvas | 
		| camera canvasRect |
		roassalCanvas clearBackground
			ifTrue: [ surface clear ].
		"We display the elements that are subject to the camera"
		camera := roassalCanvas camera.
		athensCanvas pathTransform
			translateBy: (self extent / 2) asFloatPoint;
			scaleBy: camera scale asFloat;
			translateBy: camera position negated asFloatPoint.
		renderer canvas: athensCanvas.
		canvasRect := roassalCanvas visibleRectangle.
		renderer isFixedShapesDrawing: false.
		roassalCanvas shapes
			select: [ :roassalShape | roassalShape intersects: canvasRect ]
			thenDo: [ :roassalShape | roassalShape accept: renderer ].
		
		self showRectanglesIfNecessary: roassalCanvas shapes.
		"We display the elements that are _NOT_ subject to the camera"
		athensCanvas pathTransform loadIdentity scaleBy: 1.0001.
		renderer isFixedShapesDrawing: true.
		roassalCanvas fixedShapes do: [ :roassalShape | 
			roassalShape accept: renderer ].
		"debug mode to show encompassingRectangles"
		self showRectanglesIfNecessary: roassalCanvas fixedShapes. ]
		
! !

!RSAthensMorph methodsFor: 'testing' stamp: ''!
handlesKeyboard: evt
	^true! !

!RSAthensMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	eventBeginingDragging
		ifNil:
			[ evt hand
				waitForClicksOrDrag: self
				event: evt
				selectors: {#eventMouseClick:. #eventMouseDoubleClick:. nil. #eventMouseDragStart:. }
				threshold: 5.
			^ self ].

	evt anyButtonPressed
		ifTrue: [ self eventMouseDragging: evt ].
	evt wasHandled: true! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventOfClass: anEventClass shape: aShape from: aMorphicEvent
	| relativePosition trEvent |
	relativePosition := self relativePositionFor: aMorphicEvent.

	trEvent := anEventClass fromEvent: aMorphicEvent.
	trEvent
		morph: self;
		canvas: roassalCanvas;
		shape: aShape;
		position: relativePosition.
	^ trEvent! !

!RSAthensMorph methodsFor: 'dependencies' stamp: ''!
release
	"This method is useful in case some references of TRMorph cannot be garbage collected, as it may happen with GT."
	self class instVarNames do: [ :n | self instVarNamed: n put: nil ]! !

!RSAthensMorph methodsFor: 'session management' stamp: ''!
checkSession
	"The mechanism of session is useful in case you have a visualization open, save-and-quit the image, and open the image again.
	Naturally, you wish to see the visualization again. The session mechanism makes sure that low-level resources that belongs to Cairo are properly recreated"
	session == Smalltalk session ifTrue: [ ^ self ].
	surface := nil.
	self createSurface.
	roassalCanvas shapes do: [ :s | s sessionChanged ].
	roassalCanvas fixedShapes do: [ :s | s sessionChanged ].
	! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
mouseEventOfClass: defaultClass ifLeftButton: leftButtonClass ifRightButton: rightButtonClass from: aMorphicEvent
	| trEventClass |
	trEventClass := defaultClass.
	aMorphicEvent redButtonChanged
		ifTrue: [ trEventClass := leftButtonClass ].
	aMorphicEvent yellowButtonChanged
		ifTrue: [ trEventClass := rightButtonClass ].
	^ self eventOfClass: trEventClass actionClass: defaultClass from: aMorphicEvent! !

!RSAthensMorph methodsFor: 'recategorized' stamp: ''!
recreateSurfaceIfNecessary
	surface
		ifNotNil: [ self extent asIntegerPoint ~= surface extent
				ifTrue: [ self createSurface.
					roassalCanvas extent: self extent ] ]! !

!RSAthensMorph methodsFor: 'events - processed' stamp: ''!
eventOfClass: anEventClass from: aMorphicEvent
	^ self eventOfClass: anEventClass actionClass: anEventClass from: aMorphicEvent! !

!RSAthensMorph methodsFor: 'events - processing' stamp: ''!
handleKeyUp: anEvent
	super handleKeyUp: anEvent.
	self eventKeyUp: anEvent! !

!RSAthensMorph methodsFor: 'events - processing' stamp: ''!
takesKeyboardFocus
	^ true! !

!RSAthensRenderer commentStamp: ''!
<keyClass>
Roassal uses Athens (and therefore Cairo) to performs the rendering. The rendering in Roassal is modularized in the class `RSAthensRenderer`. The connection between Roassal and Athens is expressed by the class `RSAthensRenderer`.

The class `RSAthensRenderer` is essentially a visitor for a `RSCanvas`. The renderer visits the canvas and ultimately calls the Athens primitives for each visited shapes.

If you wish to add a new rendering engine (to produce a PDF file or use an alternative low level graphic engine such as Moz2D), you need to subclass the class `RSRenderer`.

`RSAthensRenderer` visits the canvas and its contained shapes to draw it in a AthensSurface.

*Responsibility*: invoke the low level primitives offered by Athens to render the visual aspect of shapes.

*Collaborators*: `RSAthensMorph` is using the class `RSAthensRenderer` to "draw" a `RSCanvas` instance.
!
!RSAthensRenderer methodsFor: 'paint' stamp: ''!
paintFor: shape form: form
	form isForm ifFalse: [ ^ form ].
	
	^ CairoBackendCache soleInstance 
		at: form
		ifAbsentPut: [ 
			| paint |
			paint := (AthensCairoPatternSurfacePaint 
				createForSurface: (AthensCairoSurface 
				fromForm: form)).
			paint origin: (form extent /2) negated asFloatPoint.
			paint ]! !

!RSAthensRenderer methodsFor: 'creating path' stamp: ''!
buildEllipsePath: ellipse
	| extent halfWidth halfHeight |
	extent := ellipse baseRectangle extent.
	halfWidth := extent x / 2 asFloat.
	halfHeight := extent y / 2 asFloat.
	
	builder
		absolute;
		moveTo: 0@0;
		relative;
		moveTo: halfWidth negated @ 0;
		curveVia: 0 @ (halfHeight negated * 0.55)
			and: (0.45 * halfWidth) @ halfHeight negated
			to: halfWidth @ halfHeight negated;
		curveVia: (halfWidth * 0.55) @ 0
			and: halfWidth @ (0.45 * halfHeight)
			to: halfWidth @ halfHeight;
		curveVia: 0 @ (halfHeight * 0.55)
			and: (0.45 * halfWidth negated) @ halfHeight
			to: halfWidth negated @ halfHeight;
		curveVia: (halfWidth negated * 0.55) @ 0
			and: halfWidth negated @ (halfHeight negated * 0.45)
			to: halfWidth negated @ halfHeight negated.
	

! !

!RSAthensRenderer methodsFor: 'creating path' stamp: ''!
buildLinePath: line
	builder
		absolute;
		moveTo: line startPoint;
		lineTo: line endPoint.! !

!RSAthensRenderer methodsFor: 'visiting - helpers' stamp: ''!
drawPathLabel: label
	| utf8String act f stroke |
	utf8String := label path.
	utf8String ifNil: [ 
		act := AthensCairoText new.
		utf8String := act convertTextUtf8: label text.
		label path: utf8String.
	 ].
	f := label cairoFont.
	
	athensCanvas newPath.
	f lock.
	athensCanvas 
		setPathMatrix;
		setScaledFont: f.
	label paint ifNotNil: [ 
		(label paint asAthensPaintOn: athensCanvas)"
			setMatrix: athensCanvas paintTransform inverted;"
			loadOnCairoCanvas: athensCanvas. ].
	athensCanvas textPath: utf8String.
	label paint ifNotNil: [ athensCanvas fillPreserve ].
	label hasBorder ifTrue: [ 
		stroke := label border accept: self.
		stroke prepareForDrawingOn: athensCanvas.
		athensCanvas stroke.
	 ].
	f unlock.

! !

!RSAthensRenderer methodsFor: 'visiting' stamp: ''!
visitLine: line
	| path paint |
	athensCanvas setPathMatrix.
	path := self getOrCreatePathOf: line.
	
	paint := line paintOn: self.
	paint ifNotNil: [ 
		athensCanvas
			setPaint: paint;
			drawShape: path ].
	self visitBorderIfNecessary: line.
	line markerShapesInPositionDo: [ :shape | shape accept: self ].
	"self visitMarkersIfNecessary: line."
	! !

!RSAthensRenderer methodsFor: 'accessing' stamp: ''!
isFixedShapesDrawing: aBoolean
	fixedShapesDrawing := aBoolean! !

!RSAthensRenderer methodsFor: 'creating path' stamp: ''!
buildRingPath: ring
	| aAngle bAngle xAngle i e center ap epsilon aAngle2 bAngle2 
	rp da da0 da1 rc x1 x2 x3 x4 y1 y2 y3 y4 rc0 rc1 t41 t23  t14 t32 |
	epsilon := 1e-12.
	ap := (ring segmentSpacing / 2) degreesToRadians.
	aAngle := ring alphaAngle degreesToRadians.
	bAngle := ring betaAngle degreesToRadians.
	da := da0 := da1 := (aAngle - bAngle) abs.
	aAngle2 := aAngle.
	bAngle2 := bAngle.
	center := 0@0.
	i := ring innerRadius asFloat.
	e := ring externalRadius asFloat.
	e < i ifTrue: [ | r0 | 
		r0 := i. i := e. e := r0. ].
	
	builder absolute.
	"is it a point? "
	e < epsilon ifTrue: [ ^ builder  moveTo: center ].
	
	"or is a circle? "
	da0 > (Float pi * 2 - epsilon) ifTrue: [ 
		builder 
			moveTo: ((e * aAngle cos)@( e * aAngle sin negated)) + center ;
			arcAround: center radius: e startAngle: aAngle endAngle: bAngle.
		i > epsilon ifTrue: [ 
			builder
				moveTo: (i * (aAngle cos @ aAngle sin negated) )+ center ;
				arcAround: center radius: i startAngle: aAngle endAngle: bAngle ].
		builder close.
		^ self ]. 
	"circle part"
	xAngle := (aAngle + bAngle)/2.
	rp := ((i*i) + (e*e)) sqrt.
	"apply padding"
	rp > epsilon ifTrue: [ | p0 p1 |
		p0 := i isZero 
			ifTrue: [ self asin: Float infinity ]
			ifFalse: [ self asin: (rp / i * ap sin) ].
		p1 := self asin: (rp / e * ap sin).
		da0 := da0 - (p0*2).
		da0 > epsilon
			ifTrue: [ aAngle2 := aAngle2 + p0. bAngle2 := bAngle - p0 ] 	
			ifFalse: [ aAngle2 := bAngle2 := (aAngle + bAngle)/2. ].
		da1 := da1 - (p1*2).
		da1 > epsilon
			ifTrue: [ aAngle := aAngle + p1. bAngle := bAngle - p1 ]
			ifFalse: [ aAngle := bAngle := xAngle ] ].
	x1 := e*aAngle cos.
	y1 := e*aAngle sin.
	x2 := e*bAngle cos.
	y2 := e*bAngle sin.
	x4 := i*aAngle2 cos.
	y4 := i*aAngle2 sin.
	x3 := i*bAngle2 cos.
	y3 := i*bAngle2 sin.
	
	"is it small circle part?"
	(aAngle - bAngle) abs < 0.001 ifTrue: [ 
		builder 
			moveTo: (x3@y3) + center;
			close.
		^ self ].
	"apply corner radius"
	rc := ((i -e) abs /2) min: ring cornerRadii.
	rc0 := rc1 := rc.
	(da > epsilon and: [ rc > 0.001 ]) ifTrue: [ 	
		da < Float pi ifTrue: [ 
			| oc ax ay bx by kc lc |
			oc := self geomPolygonIntersectC: x1@y1 d: x4@y4 a: x2@y2  b: x3@y3.
			ax := x1 - oc x.
			ay := y1 - oc y.
			bx := x2 - oc x.
			by := y2 - oc y.
			kc := 1 / (( ((ax*bx) + (ay*by)) /  ( ((ax*ax)+ (ay*ay)) sqrt * ( (bx*bx)+(by*by) ) sqrt ) ) arcCos / 2) sin.
			lc := ((oc x * oc x) + (oc y*oc y)) sqrt.
			rc0 := rc0 min: ((e - lc) / (kc + 1)).
			rc1 := rc1 min: ((i - lc) / (kc - 1)) ].

		t41 := self arcCornerTangets: x4@y4 p1: x1@y1 r: e rc: rc0 cw: true.
		t23 := self arcCornerTangets: x2@y2 p1: x3@y3 r: e rc: rc0 cw: true.
		builder moveTo: t41 key + center.
		rc0 == rc ifTrue: [ 
			builder 
				ellipticalArc2: rc0@rc0 
					xrot: 0
					large: 0
					sweep: 0
					to: t41 value + center;
				ellipticalArc2: e@e
					xrot: 0
					large: (self arcSweep: t41 value and: t23 value)
					sweep: 0
					to: t23 value + center;
				ellipticalArc2: rc0@rc0
					xrot: 0
					large: 0
					sweep: 0
					to: t23 key + center.
				 ]
		ifFalse: [ 
			builder 
				ellipticalArc2: rc0@rc0 
					xrot: 0 
					large: 1 
					sweep: 0
					to: t23 key + center ].

		(x4 isZero & y4 isZero) ifTrue: [ 
			builder lineTo: center. ]
		ifFalse: [ 
			t14 := self arcCornerTangets: x1@y1 p1: x4@y4 r: i rc: rc1 negated cw: true.
			t32 := self arcCornerTangets: x3@y3 p1: x2@y2 r: i rc: rc1 negated cw: true.
			builder lineTo: t32 key + center.
			(rc == rc1 and: [da0 > 0 ]) ifTrue: [ 
				builder 
					ellipticalArc2: rc1@ rc1
						xrot: 0
						large: 0
						sweep: 0
						to: t32 value + center;
					ellipticalArc2: i@i
						xrot: 0
						large: (self arcSweep: t14 value and: t32 value) 
						sweep: 1
						to: t14 value + center;
					ellipticalArc2: rc1@rc1
						xrot: 0
						large: 0
						sweep: 0
						to: t14 key + center
			] ifFalse: [ 
				builder 
					ellipticalArc2: rc1@ rc1
						xrot: 0
						large: 0
						sweep: 0
						to: t14 key + center
		 ] ]
	] ifFalse: [ | l0 l1 |
		l1 := (bAngle - aAngle) abs <= Float pi ifTrue: [ 0 ] ifFalse: [ 1 ].
		l0 := (bAngle2 - aAngle2) abs <= Float pi ifTrue: [ 0 ] ifFalse: [ 1 ].
		
		builder
			moveTo: x1 @ y1 negated;
			ellipticalArc2: e@ e negated
		 		xrot: 0
				large: l1
				sweep: 0
				to: x2@y2 negated;
			lineTo: x3@y3 negated;
			ellipticalArc2: i@i negated
				xrot: 0
				large: l0
				sweep: 1
				to: x4@y4 negated.
	].
	builder close.! !

!RSAthensRenderer methodsFor: 'visiting - helpers' stamp: ''!
visitLabelDecoratorsIfNecessary: label
	| advance |
	(label isUnderlined or: [label isStruckOut]) ifFalse: [ ^ self ].
	
	athensCanvas setPaint: label paint.
	advance := (CairoFontMetricsProvider new
			font: label font;
			extentsOf: label text) x_advance.
	label isUnderlined
		ifTrue: [ athensCanvas drawShape: ((0 @ 1 extent: advance @ 1)) ].
	label isStruckOut ifFalse:  [ ^ self ]. 
	
	athensCanvas pathTransform
		translateBy: (0@ (label textHeight / 4)) negated asFloatPoint.
	athensCanvas drawShape: ((0 @ 1 extent: advance @ 1))! !

!RSAthensRenderer methodsFor: 'utilities' stamp: ''!
asin: x
	^ x >= 1
	ifTrue: [ 1.5707963267948966 ]
	ifFalse: [ x <= -1
		ifTrue: [ -1.5707963267948966 ]
		ifFalse: [ x arcSin ] ].
	! !

!RSAthensRenderer methodsFor: 'creating path' stamp: ''!
buildBezierPath: bezier
	| points |
	points := bezier controlPoints.
	points size = 2 ifTrue: [ 
		builder 
			absolute; 
			moveTo: points first; 
			lineTo: points second.
		^ self ].
	points size = 3 ifTrue: [ 
		builder 
			absolute; 
			moveTo: points first; 
			curveVia: points second 
				to: points third.
		^ self ].
	points size = 4 ifTrue: [ 
		builder
			absolute; 
			moveTo: points first; 
			curveVia: points second 
				and: points third 
				to: points fourth  ].

	! !

!RSAthensRenderer methodsFor: 'utilities' stamp: ''!
arcSweep: p1 and: p2
	^ ((p1 x - p2 x)* p1 y) - ((p1 y - p2 y) * p1 x) > 0
		ifTrue: [ 1 ] 
		ifFalse: [ 0 ]! !

!RSAthensRenderer methodsFor: 'utilities' stamp: ''!
geomPolygonIntersectC: c d: d a: a b: b

	| x1 x3 x21 x43 y1 y3 y21 y43 ua |
	x1 := c x.
	x3 := a x.
	x21 := d x - x1.
	x43 := b x - x3.
	y1 := c y.
	y3 := a y.
	y21 := d y - y1.
	y43 := b y - y3.
	ua := ((x43 *  (y1 - y3)) - (y43 * (x1 - x3))) / ((y43 * x21) - (x43 * y21 )).
	^ (x1 + (ua * x21))@
	(y1 +(ua * y21))! !

!RSAthensRenderer methodsFor: 'creating path' stamp: ''!
buildBoxPath: box
	box hasCornerRadius 
		ifTrue: [ self buildCornerBoxPath: box ]
		ifFalse: [ self buildSimpleBoxPath: box ]
	! !

!RSAthensRenderer methodsFor: 'visiting - helpers' stamp: ''!
visitChildrenIfNecessary: shape
	| canvasRect | 
	shape hasChildren ifFalse: [ ^ self ].
	self isFixedShapesDrawing ifTrue: [ 
		shape children do: [ :child | child accept: self ].
		^ self ].
	canvasRect := shape canvas visibleRectangle.
	shape children 
		select: [ :child | child intersects: canvasRect ]
		thenDo: [ :child | child accept: self ].! !

!RSAthensRenderer methodsFor: 'utilities' stamp: ''!
arcCornerTangets: p0 p1: p1 r: r1 rc: rc cw: cw
	| x01 y01 lo ox oy x1 y1 x2 y2 x3 y3 dx dy d2 r d D cx0 cy0 cx1 cy1 dx0 dy0 dx1 dy1 |
	x01 := p0 x - p1 x.
	y01 := p0 y - p1 y.
	lo := (cw ifTrue:[rc ] ifFalse: [ rc negated ]) / ((x01 * x01) + (y01*y01)) sqrt.
	ox := lo * y01.
	oy := lo negated * x01.
	x1 := p0 x + ox.
	y1 := p0 y + oy.
	x2 := p1 x + ox.
	y2 := p1 y + oy.
	x3 := (x1 + x2)/2.
	y3 := (y1 + y2)/2.
	dx := x2 - x1.
	dy := y2 - y1.
	d2 := (dx * dx) + (dy * dy).
	r := r1 - rc.
	D := (x1 * y2) - (x2 * y1).
	d := (dy < 0 ifTrue: [ -1 ] ifFalse: [ 1 ]) * (0 max: ((r*r *d2) - (D * D) ) ) sqrt.
	cx0 := ((D * dy) - (dx * d)) / d2.
	cy0 := ( (D negated * dx) - (dy * d) ) / d2.
	cx1 := ((D * dy) + (dx * d)) / d2.
	cy1 := ( (D negated * dx) + (dy * d) ) / d2.
	dx0 := cx0 - x3.
	dy0 := cy0 - y3.
	dx1 := cx1 - x3.
	dy1 := cy1 - y3.
	((dx0 * dx0) + (dy0 * dy0)) > ((dx1 * dx1) + (dy1 * dy1)) ifTrue: [ 
		cx0 := cx1.
		cy0 := cy1 ].
	^  (cx0 - ox)@ (cy0 - oy) negated -> ((cx0 * r1 / r)@(cy0 * r1/r) negated).


! !

!RSAthensRenderer methodsFor: 'creating path' stamp: ''!
buildPolylinePath: line
	| first cp radius |
	builder absolute.
	cp := line controlPoints.
	radius := line cornerRadii.
	(radius ~= 0 and: [ cp size > 2 ]) ifTrue: [ 
		builder moveTo: cp first.
		self applyRadius: radius on: cp from: 0 to: cp size - 3.
		builder lineTo: cp last.
		^ self ].
	first := true.
	cp do: [ :point | 
		first ifTrue: [ 
			first := false.
			builder moveTo: point ]
		ifFalse: [ 
			builder lineTo: point ] ]! !

!RSAthensRenderer methodsFor: 'visiting - helpers' stamp: ''!
visitBorderIfNecessary: shape
	shape hasBorder ifFalse: [ ^ self ].
	athensCanvas setShape: shape path.
	shape border accept: self.
	athensCanvas draw.! !

!RSAthensRenderer methodsFor: 'visiting' stamp: ''!
visitLabel: label
	label hasText ifFalse: [ ^ self ].
	athensCanvas pathTransform restoreAfter: [ 
		athensCanvas pathTransform
			multiplyBy: label matrix asFloatTransform;
			translateBy: label textExtents translationPoint. 
		label hasBorder
			ifTrue: [ self drawPathLabel: label ]
			ifFalse: [ self drawSimpleLabel: label ].
		
		self visitLabelDecoratorsIfNecessary: label.
	].
	
! !

!RSAthensRenderer methodsFor: 'creating path' stamp: ''!
buildCornerBoxPath: box
	| c rectangle e w2 h2 tl tr bl br min |
	c := box cornerRadius.
	rectangle := box baseRectangle.
	e := rectangle extent.
	w2 := e x / 2.0.
	h2 := e y / 2.0.
	min := w2 min: h2.
	tl := (c topLeft min: min) max: 0.
	tr := (c topRight min: min) max: 0.
	bl := (c bottomLeft min: min) max: 0.
	br := (c bottomRight min: min) max: 0.
	
	builder
		absolute;
		moveTo: rectangle topLeft + (tl@0);
		lineTo: rectangle topRight - (tr@0);
		cwArcTo: rectangle topRight + (0@tr) angle: Float halfPi;
		lineTo: rectangle bottomRight- (0 @ br);
		cwArcTo: rectangle bottomRight - (br @ 0) angle: Float halfPi;
		lineTo: rectangle bottomLeft + (bl @ 0);
		cwArcTo: rectangle bottomLeft - (0@ bl) angle: Float halfPi;
		lineTo: rectangle topLeft + (0@ tl);
		cwArcTo: rectangle topLeft + (tl @0) angle: Float halfPi;
		closePath.! !

!RSAthensRenderer methodsFor: 'visiting - helpers' stamp: ''!
drawSimpleLabel: label
	| font |
	(label paint isNil or: [ label cairoGlyphs isNil ]) ifTrue: [ ^ self ].
	
	"returns a CairoScaledFont"
	font := label cairoFont.
	font lock.

	athensCanvas
		setPathMatrix;
		setScaledFont: font.
	(label paint asAthensPaintOn: athensCanvas)
		loadOnCairoCanvas: athensCanvas.

	athensCanvas
		showGlyphs: label cairoGlyphs getHandle
		size: label cairoGlyphs size.

	font unlock! !

!RSAthensRenderer methodsFor: 'accessing' stamp: ''!
isFixedShapesDrawing
	^ fixedShapesDrawing! !

!RSAthensRenderer methodsFor: 'utilities' stamp: ''!
applyRadius: radius on: controlPoints from: start to: end
	"based on https://riptutorial.com/html5-canvas/example/18766/render-a-rounded-polygon-"
	| cp p1 p2 p3 arc v1 len1 a1 v2 len2 a2 sinA sin90 
	angle radDir drawDir halfAngle cRadius lenOut p a b len |
	cp := controlPoints.
	len := cp size.
	p1 := p2 := p3 := nil.
	arc := [ 
		v1 := p1 - p2.
		len1 := ((v1 x * v1 x) + (v1 y * v1 y)) sqrt.
		v1 := v1 / len1.
		a1 := v1 angle.
		
		v2 := p3 - p2.
		len2 := ((v2 x * v2 x) + (v2 y * v2 y)) sqrt.
		v2 := v2 / len2.
		a2 := v2 angle.
			
		sinA := (v1 x * v2 y) - (v1 y * v2 x).
		sin90 := (v1 x * v2 x) - (v1 y * v2 y negated).
		angle := sinA arcSin.
		radDir := 1.
		drawDir := false.
		
		sin90 < 0 ifTrue: [ 
			angle < 0 ifTrue: [ 
				angle := angle + Float pi ]
			ifFalse: [ 
				angle := angle - Float pi.
				radDir := -1.
				drawDir := true ] ]
		ifFalse: [ 
			angle >= 0 ifTrue: [ 
				radDir := -1.
				drawDir := true. ] ].
		halfAngle := angle / 2.
		sinA :=  halfAngle sin.
		lenOut := sinA = 0 
			ifTrue: [ Float infinity ]
			ifFalse: [ (halfAngle cos * radius/ sinA) abs].
		cRadius := radius.
		lenOut > ((len1 / 2) min: (len2 / 2)) ifTrue: [ 
			lenOut := (len1 / 2) min: (len2 / 2).
			cRadius := (lenOut * halfAngle tan) abs.
			].
		p := p2 + (v2 * lenOut) + (v2 y negated@ v2 x * cRadius * radDir).
		a := a1 + (Float halfPi * radDir).
		b := a2 - (Float halfPi * radDir). 
		(a closeTo: b) ifTrue: [ a := b ].
		builder 
			arcAround: p
			radius: cRadius
			startAngle: a
			endAngle: b
			cw: drawDir. ].
	start to: end do: [ :i |
		p1 := cp at: (i)%len + 1.
		p2 := cp at: (i + 1)%len + 1.
		p3 := cp at: (i + 2)%len + 1.
		(p1 = p2 or: [p2 = p3]) ifFalse: [ arc value ] ].
	! !

!RSAthensRenderer methodsFor: 'accessing' stamp: ''!
builder
	^ builder! !

!RSAthensRenderer methodsFor: 'visiting' stamp: ''!
visitBorder: border
	| stroke style |
	stroke := athensCanvas setStrokePaint: border paint.
	stroke width: border width asFloat.
	style := border style.
	style ifNil: [ ^ stroke ].
	style dashArray 
		ifNotNil: [ :a | stroke dashes: a offset: style dashOffset ].
		
	style capStyle
		ifNotNil: [:s | stroke perform: s].
	style joinStyle
		ifNotNil: [:s | stroke perform: s].
	^ stroke.
	! !

!RSAthensRenderer methodsFor: 'creating path' stamp: ''!
getOrCreatePathOf: shape
	| path |
	path := shape path.
	path ifNotNil: [ ^ path ].
	path := athensCanvas
		createPath: [ :pathBuilder |
			builder := pathBuilder.
			shape buildPathOn: self ].
	builder := nil.
	shape path: path.
	^ path! !

!RSAthensRenderer methodsFor: 'creating path' stamp: ''!
buildPolygonPath: polygon
	| first radius cp |
	builder absolute.
	radius := polygon cornerRadii.
	cp := polygon points.
	[
	(radius ~= 0 and: [ cp size > 2 ]) ifTrue: [ 
		builder moveTo: (cp first + cp second) /2.
		self applyRadius: radius on: cp from: 0 to: cp size-1.
		^ self ].
	first := true.
	cp do: [ :point |
		first ifTrue: [ 
			first := false.
			builder moveTo: point ]
		ifFalse: [ 
			builder lineTo: point ] ].
	] ensure: [ builder closePath. ].
	
	
	! !

!RSAthensRenderer methodsFor: 'creating path' stamp: ''!
buildSimpleBoxPath: box
	| rectangle |
	rectangle := box baseRectangle.
	builder
		absolute;
		moveTo: rectangle topLeft;
		lineTo: rectangle topRight;
		lineTo: rectangle bottomRight;
		lineTo: rectangle bottomLeft;
		lineTo: rectangle topLeft;
		closePath! !

!RSAthensRenderer methodsFor: 'visiting' stamp: ''!
visitBoundingShape: shape
	| path paint |
	athensCanvas setPathMatrix.
	path := self getOrCreatePathOf: shape.
	athensCanvas pathTransform restoreAfter: [ 
		athensCanvas pathTransform
			multiplyBy: shape matrix asFloatTransform.
		paint := shape paintOn: self.
		paint ifNotNil: [ 
			athensCanvas 
				fillRuleEvenOdd;
				setPaint: paint;
				drawShape: path ].
		self visitBorderIfNecessary: shape.
		self visitChildrenIfNecessary: shape.
		].
	! !

!RSAthensRendererTest commentStamp: ''!
I am the test class for TSAthensRenderer !
!RSAthensRendererTest methodsFor: 'tests' stamp: ''!
testArcCorner
	| renderer |
	renderer := RSAthensRenderer new.
	self assert: (renderer
		arcCornerTangets: -17.172947580489485@ -71.29423293069038
		p1: -58.258908750504766 @ -212.1459392757739
		r: 220
		rc: 11.316433244555238
		cw: true)
		
		equals: (-54.9506649278924@ 200.80455223867077) -> (-46.47771241701749@ 215.03446758248086)! !

!RSAttachPoint commentStamp: ''!
I am the base for attach points!
!RSAttachPoint methodsFor: 'private' stamp: ''!
commonParents: shape in: anEdge
	| current parents |
	current := shape parent.
	parents := OrderedCollection new.
	[ current = anEdge parent ] whileFalse: [ 
		current ifNil: [ ^ nil ].
		current parent = current ifTrue: [ ^ nil ].
		parents add: current.
		current := current parent ].
	^ parents! !

!RSAttachPoint methodsFor: 'public - hooks' stamp: ''!
initialize
	super initialize.
	inverted := false.! !

!RSAttachPoint methodsFor: 'private' stamp: ''!
positionFor: shape in: anEdge point: pos
	| commonParents |
	shape isPoint ifTrue: [ ^ shape ].
	(self hasParents: shape in: anEdge) ifFalse: [ ^ pos ].
	shape parent = anEdge parent ifTrue: [ ^ pos ].
	"TODO we can cache this info"
	commonParents := self commonParents: shape in: anEdge.
	commonParents ifNil: [ ^ pos ].
	^ (self matrixFor: commonParents) transform: pos. ! !

!RSAttachPoint methodsFor: 'private' stamp: ''!
hasParents: shape in: anEdge
	^ shape parent notNil and: [ anEdge parent notNil ]! !

!RSAttachPoint methodsFor: 'private' stamp: ''!
matrixFor: commonParents
	| matrix |
	matrix := AthensAffineTransform new.
	commonParents reverseDo: [ :s | matrix multiplyBy: s matrix ].
	^ matrix! !

!RSAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicEndingPointOf: anEdge
	^ self subclassResponsibility ! !

!RSAttachPoint methodsFor: 'public - hooks' stamp: ''!
endingPointOf: aLine
	"Return the end point of a line.
	
	b1 := RSBox new size: 20.
	b2 := RSBox new size: 20.
	b1 translateTo: 20 @ 30.
	b2 translateTo: 60 @ 50.
	l := RSLine new
		from: b1;
		to: b2.
	l attachPoint: RSBorderAttachPoint new.
	l update.
	b1 @ RSDraggable.
	b2 @ RSDraggable.
	c := RSCanvas new.
	c
		add: b1;
		add: b2;
		add: l.
	
	l attachPoint startingPointOf: l
=> 	50 @ 45
	"
	(aLine from = aLine to) 
		ifTrue: [ ^ self positionFor: aLine from in: aLine ].
    ^ inverted
        ifTrue: [ self basicStartingPointOf: aLine ]
        ifFalse: [ self basicEndingPointOf: aLine ]! !

!RSAttachPoint methodsFor: 'private' stamp: ''!
positionFor: shape in: anEdge
	shape isPoint ifTrue: [ ^ shape ].
	^ self positionFor: shape in: anEdge point: shape position! !

!RSAttachPoint methodsFor: 'public - hooks' stamp: ''!
startingPointOf: aLine
"Return the starting point of a line.
	
	b1 := RSBox new size: 20.
	b2 := RSBox new size: 20.
	b1 translateTo: 20 @ 30.
	b2 translateTo: 60 @ 50.
	l := RSLine new
		from: b1;
		to: b2.
	l attachPoint: RSBorderAttachPoint new.
	l update.
	b1 @ RSDraggable.
	b2 @ RSDraggable.
	c := RSCanvas new.
	c
		add: b1;
		add: b2;
		add: l.
	
	l attachPoint startingPointOf: l
=> 	30 @ 35
	"
	(aLine from = aLine to) 
		ifTrue: [ ^ self positionFor: aLine from in: aLine ].
    ^ inverted
        ifTrue: [ self basicEndingPointOf: aLine ]
        ifFalse: [ self basicStartingPointOf: aLine ]
! !

!RSAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicStartingPointOf: anEdge
	^ self subclassResponsibility ! !

!RSAttachPoint class methodsFor: 'instance creation' stamp: ''!
centered
	^ RSCenteredAttachPoint new! !

!RSAttachPoint class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self == RSAttachPoint! !

!RSAttachPointTest methodsFor: 'tests' stamp: ''!
testBorderAttachPoint
	| b1 b2 l c |
	b1 := RSBox new size: 20.
	b2 := RSBox new size: 20.
	b1 translateTo: 20 @ 30.
	b2 translateTo: 60 @ 50.
	l := RSLine new
		from: b1;
		to: b2.
	l attachPoint: RSBorderAttachPoint new.
	l update.
	c := RSCanvas new.
	c
		add: b1;
		add: b2;
		add: l.
	self assert: (l attachPoint startingPointOf: l) equals: 30 @ 35.
	self assert: (l attachPoint endingPointOf: l) equals: 50 @ 45! !

!RSAttachPointTest methodsFor: 'tests' stamp: ''!
testHorizontalAttachPoint
	| b1 b2 l c |
	b1 := RSBox new size: 20.
	b2 := RSBox new size: 20.
	b1 translateTo: 20 @ 30.
	b2 translateTo: 60 @ 50.
	l := RSLine new
		from: b1;
		to: b2.
	l attachPoint: RSHorizontalAttachPoint new.
	l update.
	c := RSCanvas new.
	c
		add: b1;
		add: b2;
		add: l.
	self assert: (l attachPoint startingPointOf: l) equals: 30 @ 30.
	self assert: (l attachPoint endingPointOf: l) equals: 50 @ 50! !

!RSAttachPointTest methodsFor: 'tests' stamp: ''!
testVerticalAttachPoint
	| b1 b2 l c |
	b1 := RSBox new size: 20.
	b2 := RSBox new size: 20.
	b1 translateTo: 20 @ 30.
	b2 translateTo: 60 @ 50.
	l := RSLine new
		from: b1;
		to: b2.
	l attachPoint: RSVerticalAttachPoint new.
	l update.
	c := RSCanvas new.
	c
		add: b1;
		add: b2;
		add: l.
	self assert: (l attachPoint startingPointOf: l) equals: 20 @ 40.
	self assert: (l attachPoint endingPointOf: l) equals: 60 @ 40! !

!RSAttachPointTest methodsFor: 'tests' stamp: ''!
testCenteredAttachPoint
	| b1 b2 l c |
	b1 := RSBox new size: 20.
	b2 := RSBox new size: 20.
	b1 translateTo: 20 @ 30.
	b2 translateTo: 60 @ 50.
	l := RSLine new
		from: b1;
		to: b2.
	l attachPoint: RSCenteredAttachPoint new.
	l update.
	c := RSCanvas new.
	c
		add: b1;
		add: b2;
		add: l.
	self assert: (l attachPoint startingPointOf: l) equals: 20 @ 30.
	self assert: (l attachPoint endingPointOf: l) equals: 60 @ 50! !

!RSBackInterpolator commentStamp: ''!
TSEasing backIn
Anticipatory easing, like a dancer bending his knees before jumping off the floor. The degree of overshoot is configurable; if not specified, it defaults to 1.70158.

TSEasing backOut 
Reverse anticipatory easing; equivalent to 1 - (backIn value: 1 - t).

TSEasing back 
TSEasing backInOut
Symmetric anticipatory easing; scales backIn for t in [0, 0.5] and backOut for t in [0.5, 1].!
!RSBackInterpolator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	overshoot := 1.70158! !

!RSBackInterpolator methodsFor: 'accessing' stamp: ''!
overshoot
	^ overshoot! !

!RSBackInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateIn: t
	^ t * t * ((overshoot + 1) * t - overshoot)! !

!RSBackInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateInOut: i
	"((t *= 2) < 1 ? t * t * ((s + 1) * t - s) : (t -= 2) * t * ((s + 1) * t + s) + 2) / 2;"
	| t |
	t := i * 2.
	^ (t < 1
		ifTrue: [ t * t * ((overshoot + 1) * t - overshoot) ]
		ifFalse: [ 
			t := t -2.
			t * t * ((overshoot + 1) * t + overshoot) + 2 ])/2! !

!RSBackInterpolator methodsFor: 'accessing' stamp: ''!
overshoot: aNumber
	overshoot := aNumber! !

!RSBackInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateOut: i
	| t |
	t := i -1.
	^ t * t * ((overshoot + 1) * t + overshoot) + 1! !

!RSBarPlot commentStamp: ''!
<keyClass>
`RSBarPlot` is a plot for Roassal's chart that represents a bar chart.

*Responsibility*: display a bar chart, with adequate color & bar width value per default.

*Collaborators*: a bar plot is added to `RSChart`.

*Variables*:
- `barWidth`: width of a bar. A default computed value is assigned.

*Example*:
```Smalltalk
data := #(4 10 5 9).
c := RSChart new.

d := RSBarPlot new.
d color: Color green darker darker darker.
d y: data.
c addPlot: d.

c addDecoration: (RSVerticalTick new integer).
c addDecoration: (RSHorizontalTick new).

c addDecoration: (RSYLabelDecoration new title: 'Difference'; rotationAngle: -90; offset: -25 @ 0).
c addDecoration: (RSXLabelDecoration new title: 'Evolution').
c
```!
!RSBarPlot methodsFor: 'hooks' stamp: ''!
computeRectagleFor: aPoint index: index
	| origin corner sizeOffset offset zero |
	zero := 0.
	bottom ifNotNil: [ zero := bottom at: index ].
	origin := self scalePoint: aPoint + (0@ zero).
	corner := origin x @ (yScale scale: zero ).
	sizeOffset := (self barSize / 2.0) @ 0.
	offset := self barOffset @ 0.
	^ Rectangle 
		origin: origin + offset - sizeOffset
		corner: corner + offset + sizeOffset! !

!RSBarPlot methodsFor: 'testing' stamp: ''!
isVerticalBarPlot
	^ true! !

!RSBarPlot methodsFor: 'accessing' stamp: ''!
bottom
	^ bottom! !

!RSBarPlot methodsFor: 'accessing' stamp: ''!
bottom: aCollection
	self 
		assert: xValues size = aCollection size
		description: 'Invalid size'.
	bottom := aCollection! !

!RSBarPlot methodsFor: 'rendering' stamp: ''!
beforeRenderingIn: aChart
	| barScale |
	super beforeRenderingIn: aChart.
	xScale class = NSOrdinalScale ifTrue: [ ^ self ].
	barScale := NSOrdinalScale new 
		domain: xValues;
		rangeBands: xScale range padding: gapRatio.
	aChart xScale: barScale! !

!RSBarPlot methodsFor: 'accessing' stamp: ''!
barScale
	^ xScale! !

!RSBarPlot methodsFor: 'hooks' stamp: ''!
modelFor: aPoint
	^ aPoint y! !

!RSBarPlot methodsFor: 'rendering' stamp: ''!
definedValuesY
	"Return the list Y values that are defined"
	| res |
	res := yValues.
	bottom ifNotNil: [ res := yValues + bottom ].
	^ res, {0}! !

!RSBarPlotTest methodsFor: 'tests' stamp: ''!
classToTest
	^ RSBarPlot! !

!RSBarPlotTest methodsFor: 'tests' stamp: ''!
testVerticalBar
	| c p x y |
	x := 0.0 to: 2 count: 10.
	y := (x raisedTo: 2) - 2.
	c := RSChart new.
	p := RSBarPlot new x: x y: y.
	
	self assert: p isVerticalBarPlot.
	self deny: p isHorizontalBarPlot.
	c addPlot: p.
	c addDecoration: (RSVerticalTick new 
		numberOfTicks: 10;
		asFloat).
	c build.
	self assert: (p bars allSatisfy: [ :shape |
		 shape width closeTo: p bars anyOne width ]).
	
! !

!RSBarPlotTest methodsFor: 'tests' stamp: ''!
testHorizontalBar
	| c p x y |
	x := 0.0 to: 2 count: 10.
	y := (x raisedTo: 2) - 2.
	c := RSChart new.
	p := RSHorizontalBarPlot new x: x y: y.
	
	self deny: p isVerticalBarPlot.
	self assert: p isHorizontalBarPlot.
	c addPlot: p.
	c build.
	self assert: (p bars allSatisfy: [ :shape |
		 shape height closeTo: p bars anyOne height ]).
	
! !

!RSBarPlotTest methodsFor: 'tests' stamp: ''!
test2BarPlots
	| d1 d2 extent vtick |
	d1 := #(4 10 5 9).
	d2 := #(-5 -6 -3 -3 ).
	extent := chart extent.
	chart addPlot: (RSBarPlot new y: d1).
	chart addPlot: (RSBarPlot new y: d2).
	vtick := RSVerticalTick new withNoLabels.
	chart addDecoration: vtick.
	chart build.
	self 
		assert: chart canvas encompassingRectangle extent 
		equals: extent+(vtick configuration tickSize @0).! !

!RSBaselineCalypso commentStamp: ''!
This class visualize dependencies of instances of BaselineOf!
!RSBaselineCalypso methodsFor: 'accessing' stamp: ''!
collectAllProjects
	| projects |
	projects := Dictionary new.
	self collectAllProjectsIn: projects class: self targetClass level: 0.
	^ projects! !

!RSBaselineCalypso methodsFor: 'accessing' stamp: ''!
border
	^ lineBorder ifNil: [ lineBorder := RSBorder new color: Color black; yourself ].! !

!RSBaselineCalypso methodsFor: 'building' stamp: ''!
highlightable
	^ high ifNil: [ 
		high := RSHighlightable new withOutgoingEdges.
		high highlightBorder: (RSBorder new color: Smalltalk ui theme selectionColor; width: 2).
		high ]! !

!RSBaselineCalypso methodsFor: 'building - menus' stamp: ''!
showHideNames: evt
	| label textColor |
	label := evt canvas nodes first propertyAt: #RSLabeled.
	textColor :=  Smalltalk ui theme textColor.
	label ifNil: [ 
		| labeled |
		labeled := RSLabeled new highlightable.
		labeled shapeBuilder: [ :m | RSLabel new color: textColor; text: m ].
		labeled lowColor: textColor translucent.
		evt canvas nodes @ labeled.
		evt shape text: 'Hide names' ]
	ifNotNil: [ 
		evt canvas nodes do: [ :node | 
			(node propertyAt: #RSLabeled) remove.
			node removeKey: #RSLabeled.
			node removeInteractionIfPresent: RSLabeled. ].
		evt shape text: 'Show names' ].
	evt signalUpdate! !

!RSBaselineCalypso methodsFor: 'building - menus' stamp: ''!
resizeNodes: evt
	| minSize newText propertyKey |
	isUsingPackageSize ifNil: [ isUsingPackageSize := true ].
	minSize := 15.
	isUsingPackageSize ifTrue: [ 
		isUsingPackageSize := false.
		newText := 'Change node size using number of packages'.
		propertyKey := #linesOfCode.
	] ifFalse: [ 
		isUsingPackageSize := true.
		propertyKey := #packagesSize.
		newText := 'Change node size using lines of code of each baseline class' ].
	
	evt canvas nodes do: [ :node |
		node size: minSize + (node propertyAt: propertyKey).
		node updateConnectedLines ].
	evt shape text: newText.
	evt signalUpdate.! !

!RSBaselineCalypso methodsFor: 'building' stamp: ''!
buildLegendOn: canvas
	| b miniGraph interaction arrow |
	miniGraph := RSComposite new.
	interaction  := RSLabeled new.
	interaction location middle.
	miniGraph add: (RSEllipse new size: 20; model: 'A').
	miniGraph add: (RSEllipse new size: 20; model: 'B').
	miniGraph nodes @ interaction.
	arrow := RSShapeFactory arrow size: 10.
	miniGraph add: (RSLine new 
		from: miniGraph nodes first; 
		to: miniGraph nodes second;
		attachPoint: (RSBorderAttachPoint new endOffset: 5);
		markerEnd: arrow;
		yourself).
	RSHorizontalLineLayout new gapSize: 10; on: miniGraph nodes.
	miniGraph adjustToChildren.
	
	b := RSLegend new.
	b container: canvas.
	b title: 'Dependencies of ', self targetClass name.
	b text: 'A loaded baseline' withCircleColor: Color gray.
	b text: self targetClass name withCircleColor: Color blue.
	b text: 'Not loaded baseline' withCircleColor: Color red.
	b text: 'A depends on B' withShape: miniGraph.
	b 
		text: 'Error in baseline' 
		withShape: (RSShapeFactory star 
			size: 20; 
			color: Color red; 
			yourself).
	b text: ' '.
	b title: 'Interactions on nodes'.
	b text: '-Double click to open class'.
	b text: '-Mouse over to see direct dependencies'.
	b onDemand: 'GraphInfo'.
	b legendDo: [ :s | s color: (Color white alpha: 0.8); withBorder; padding: 10 ].
	b build.
		! !

!RSBaselineCalypso methodsFor: 'building' stamp: ''!
applyControlsOn: canvas
	| controller |
	controller := RSCanvasController new.
	controller addInteraction: (RSSearchInCanvasInteraction new
		colorToHighlight: Color yellow;
		yourself).
	canvas @ controller! !

!RSBaselineCalypso methodsFor: 'building - menus' stamp: ''!
buildMenuOn: canvas
	
	| menus |
	menus := RSGroup new.
	#('Show names' 'showHideNames:'
	'Change node size using number of packages' 'resizeNodes:') pairsDo: [ :name :action | 
		| label |
		label := RSLabel new
			text: name;
			isFixed: true;
			@ self highlightableMenu;
			when: RSMouseClick send: action asSymbol to: self;
			yourself.
		label when: RSExtentChangedEvent do: [ :evt |
			self layoutMenu: menus.
			 ].
		menus add: label.
		].
	self layoutMenu: menus.
	
	canvas addAllShapes: menus.! !

!RSBaselineCalypso methodsFor: 'building - menus' stamp: ''!
menuAnimationFor: shape to: delta
	| pos |
	pos := shape propertyAt: #opos.
	shape newAnimation
		duration: 200 milliSeconds;
		from: shape position;
		to: pos + delta;
		on: shape set: #position:.! !

!RSBaselineCalypso methodsFor: 'initialization' stamp: ''!
defaultTitle
	^'Baselines-Graph'! !

!RSBaselineCalypso methodsFor: 'building' stamp: ''!
shapeFor: assoc
	| shape minSize |
	minSize := 15.
	shape := RSEllipse new
		border: self border;
		@ self highlightable;
		model: assoc key;
		yourself.
	shape
		when: RSMouseDoubleClick
		do: [ :evt | (self class environment at: evt shape model) browse ].
	assoc value ifNil: [ 
		shape @ self notLoadedPopup.
		shape color: Color red.
		shape propertyAt: #linesOfCode put: 0.
		shape propertyAt: #packagesSize put: 0.
		shape size: minSize ]
	ifNotNil: [ :cls | 
		assoc key = self targetClass name
			ifTrue: [ shape color: Color blue ].
		shape @ self loadedPopup.
		
		shape propertyAt: #linesOfCode put: cls linesOfCode sqrt*2.
		
		[| size |
		size := cls version packages size.
		shape propertyAt: #packagesSize put: size.
		shape size: minSize + size. ] on: Error do: [ :ex | 
			| newShape |
			newShape := RSShapeFactory star.
			newShape announcer: shape announcer.
			newShape properties addAll: shape properties.
			newShape model: shape model.
			newShape color: Color red.
			shape := newShape.
			shape propertyAt: #packagesSize put: 0.
			shape size: minSize.
		 ].
	].
	^ shape! !

!RSBaselineCalypso methodsFor: 'building - menus' stamp: ''!
highlightableMenu
	^ highMenu ifNil: [ 
		highMenu := RSHighlightable new.
		highMenu 
			when: RSHighlightEvent do: [ :evt |
				evt shape color: Color blue; underline.
				self menuAnimationFor: evt shape to: -5@0 ];
			when: RSUnHighlightEvent do: [ :evt |
				evt shape color: Color gray; normal.
				self menuAnimationFor: evt shape to: 0 ].
		highMenu ]! !

!RSBaselineCalypso methodsFor: 'accessing' stamp: ''!
collectAllProjectsIn: projects class: clazz level: level
	| version |
	version := nil.
	projects at: clazz name asSymbol put: clazz.
	[ version := clazz version ] on: Error do: [ :ex | 
		^ self ].
	"This is baseline"
	
	(version projects collect: #constructClassName)
		select: [ :name | name notNil ]
	 	thenDo: [ :name |
			Smalltalk globals at: name asSymbol
				ifPresent: [ :cls | self collectAllProjectsIn: projects class: cls level: level + 1 ]
				ifAbsent: [ projects at: name asSymbol put: nil ]
		]! !

!RSBaselineCalypso methodsFor: 'building' stamp: ''!
dependenciesOf: name
	^ Smalltalk globals at: name
		ifPresent: [ :cls |
			
			[cls version projects collect: #constructClassName] on: Error do: [ :ex | #() ] ]
		ifAbsent: [ #() ]! !

!RSBaselineCalypso methodsFor: 'building' stamp: ''!
applyTheme: canvas
	| theme |
	theme := Smalltalk ui theme.
	canvas color: theme backgroundColor.
	self border color: theme textColor.
	canvas edges do: [ :ed | ed color: theme textColor ].! !

!RSBaselineCalypso methodsFor: 'building - menus' stamp: ''!
layoutMenu: menus
	RSVerticalLineLayout on: menus.
	menus translateBy: 10@10.
	menus do: [ :lb | lb propertyAt: #opos put: lb position ].! !

!RSBaselineCalypso methodsFor: 'accessing' stamp: ''!
notLoadedPopup
	^ notLoadedPopup ifNil: [ notLoadedPopup := 
		RSPopup text: [ :name | name, String crlf, '--Not loaded--' ].
		notLoadedPopup shapeBuilder labelBuilder 
			layout: (RSVerticalLineLayout new gapSize: 0; alignCenter; yourself).
		notLoadedPopup ]! !

!RSBaselineCalypso methodsFor: 'building' stamp: ''!
addEdgesOn: canvas
	| arrow |
	arrow := (RSShapeFactory arrow size: 10; color: Color red translucent) asMarker.
	arrow offset: 0.
	
	RSLineBuilder line
		markerEnd: arrow;
		canvas: canvas;
		attachPoint: (RSBorderAttachPoint new endOffset: 5);
		border: self border;
		connectToAll: [:name | self dependenciesOf: name ].! !

!RSBaselineCalypso methodsFor: 'building' stamp: ''!
buildUmlCanvas
	| canvas allProjects |
	canvas := RSCanvas new.
	allProjects := self collectAllProjects.
	canvas addAll: (allProjects associations collect: [:asso | self shapeFor: asso ]).
	self addEdgesOn: canvas.
	self applyLayoutOn: canvas.
	self applyControlsOn: canvas.
	self applyTheme: canvas.
	self buildMenuOn: canvas.
	self buildLegendOn: canvas.
	^ canvas! !

!RSBaselineCalypso methodsFor: 'accessing' stamp: ''!
loadedPopup
	^ loadedPopup ifNil: [ loadedPopup := RSPopup new ]! !

!RSBaselineCalypso methodsFor: 'building' stamp: ''!
applyLayoutOn: canvas
	| interaction layout |
	interaction := RSForceLayoutSteppingInteraction new.
	layout := RSRectangleForceLayout new.
	interaction layout: layout.
	layout 
		initialLayout: RSGridLayout new;
		enclosingRectangle: (Rectangle floatCenter: 0@0 extent: 300@100);
		length: 50;
		charge: -600.
	canvas when: RSExtentChangedEvent do: [:evt | 
		layout enclosingRectangle: (Rectangle floatCenter: 0@0 extent: canvas extent).
		interaction startSimpleAnimation: canvas.
		canvas newAnimation
			duration: 2 seconds;
			onStepDo: [ canvas zoomToFit ].
		 ].
	canvas @ interaction.
	! !

!RSBaselineCalypso methodsFor: 'initialization' stamp: ''!
defaultIconName
	^ #objects! !

!RSBaselineCalypso class methodsFor: 'testing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	^ RSUMLCalypsoSettings useCalypsoUML 
		and: [ aBrowserContext isClassSelected 
			and: [ aBrowserContext lastSelectedClass inheritsFrom: BaselineOf ] ].
	! !

!RSBasicUMLClassRenderer commentStamp: ''!
I am the default renderer that RSUMLClassBuilder !
!RSBasicUMLClassRenderer methodsFor: 'hooks' stamp: ''!
initialize
	super initialize.
	popup := RSPopup new model: #yourself.
	popup shapeBuilder: (RSAdaptativePopup new
		smallBuilder: popup shapeBuilder;
		bigBuilder: self;
		yourself).! !

!RSBasicUMLClassRenderer methodsFor: 'accessing - shapes' stamp: ''!
classInnerLine
	^ classInnerLine ifNil: [
		classInnerLine := RSLine new
			border: self border;
			yourself ]! !

!RSBasicUMLClassRenderer methodsFor: 'hooks' stamp: ''!
shapeFor: aClass
	| shapes box title vars methods |
	title := self titleFor: aClass.
	vars := self varsFor: aClass.
	
	methods := self methodsFor: aClass.
	shapes := self groupFor: { vars. methods }.
	shapes addFirst: title.
	box := self classBoxShapeFor: aClass.
	self applyLayoutOn: shapes.
	self adjustTitle: title on: shapes.
	
	self createEllipsisIfNecessaryOn: shapes.
	shapes addFirst: box.
	self adjustBox: box on: shapes.
	self addLines: shapes title: title.
	^ RSComposite new
		draggable;
		addInteraction: popup;
		model: aClass;
		shapes: shapes;
		yourself.! !

!RSBasicUMLClassRenderer methodsFor: 'hooks' stamp: ''!
addLines: group title: title 
	| line rec offset |
	line := self classInnerLine.
	rec := group encompassingRectangle.
	offset := 2.5.
	group size > 2 ifTrue: [ 
		group add: (line copy
			startPoint: (rec origin x + offset) @ title height;
			endPoint: (rec corner x - offset) @ title height) ].
	group size > 4 ifTrue: [ 
		group add: (line copy
			startPoint: (rec origin x + offset) @ (title height + group third height);
			endPoint: (rec corner x - offset) @ (title height + group third height)) ].! !

!RSBasicUMLClassRenderer methodsFor: 'accessing - shapes' stamp: ''!
classInnerLine: aShape
	classInnerLine := aShape! !

!RSBasicUMLPackageRenderer commentStamp: ''!
A basic renderer for UML packages!
!RSBasicUMLPackageRenderer methodsFor: 'hooks' stamp: ''!
shapeFor: aPackage
	| title classes box |
	title := self packageNameFor: aPackage.
	classes := self classesFor: aPackage.
	box := self packageBoxFor: title and: classes.
	^ RSComposite new
		model: aPackage;
		shapes: { box. title. classes };
		popup;
		browseable;
		draggable;
		yourself! !

!RSBezier commentStamp: ''!
RSBezier represents a bezier lines of one and 2 control points.

Here is an example:
```Smalltalk
	c := RSCanvas new.
	c add: (RSBezier new
		color: Color red;
		controlPoints:
			{(0 @ 0).
			(100 @ 100).
			(200 @ 0).
			(300 @ 100)}).
	c 
```

Another example:
```Smalltalk
canvas := RSCanvas new.
 
box1 := RSBox new color: Color blue.
box2 := RSBox new color: Color red.
box2 translateTo: 100 @ -200.

box1 @ RSDraggable.
box2 @ RSDraggable.
canvas add: box1; add: box2.
 
bezierLine := RSBezier new
	withVerticalAttachPoint;
	from: box1;
	to: box2;
	controlPointsController: (
			RSBlockCPController new
				block: [ :aLine |
					| mid |
   					mid := (box1 position + box2 position) / 2.
					{(box1 position) . 
					(box1 position x @ mid y) .
					(box2 position x @ mid y) .
					(box2 position)} ];
				yourself);
  yourself.
canvas add: bezierLine.
canvas zoomToFit.
canvas open
```

Here is an example of a bezier line with a marker
```
b := RSCanvas  new.
b addAll: ((1 to: 3) collect: [:i |
	RSEllipse new
		model: i;
		size: 5]).

b nodes @ RSDraggable.

marker := RSPolygon new
		points: { -5@5. 0@0. 5@5. 0@0 };
		extent: 2 @ 2;
		color: Color red;
		withBorder;
		asMarker.

RSEdgeBuilder verticalBezier
	color: Color red translucent;
	canvas: b;
	withVerticalAttachPoint;
	noRepetition;
	markerEnd: marker;
	useAssociations: { 1 -> 2 . 2 -> 3 . 1 -> 2}.
	
RSVerticalLineLayout on: b nodes.

b @ RSCanvasController.
b open
```!
!RSBezier methodsFor: 'testing' stamp: ''!
basicIncludesPoint: aPoint
	"Not perfect but close enough"
	| cp lines ir |
	cp := self controlPoints.
	ir := self includedRadius.
	cp size = 2 ifTrue: [ 
		^ aPoint
			onLineFrom: cp first
			to: cp second
			within: ir
		 ].
	lines := self lines.
	lines ifNil: [ ^ false ].
	^ (1 to: lines size - 1) anySatisfy: [ :i |
		| p1 p2 |
		p1 := lines at: i.
		p2 := lines at: i + 1.
		(aPoint 
			onLineFrom: p1
			to: p2
			within: ir )
		 ].
	! !

!RSBezier methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	controlPoints := { 0@0. 100@100 }.! !

!RSBezier methodsFor: 'accessing' stamp: ''!
controlPoints: anArrayOfPoints
	self
		assert: anArrayOfPoints notNil 
		description: 'The argument can not be nil';
		assert: (anArrayOfPoints size between: 2 and: 4)
		description: 'The array size must be between 2 and 4 points'.
	super controlPoints: anArrayOfPoints! !

!RSBezier methodsFor: 'visiting' stamp: ''!
buildPathOn: visitor
	visitor buildBezierPath: self.! !

!RSBezier methodsFor: 'private' stamp: ''!
lines
	| c b a via1 via2 start end cp |
	cp := controlPoints.
	cp size <3 ifTrue: [ ^ nil ].
	start := cp first.
	via1 := cp second.
	via2 := cp third.
	end := cp size = 3 
		ifTrue: [ via2 ]
		ifFalse: [ cp fourth ].
	c := 3 * (via1 - start).
	b := 3 * (via2 - via1) - c.
	a := end - start - c - b.

	^ (0 to: 1 by: 0.2) collect: [ :t | 
		a * (t raisedTo: 3) + (b * (t * t)) + (c * t) + start. 
		]! !

!RSBitmap commentStamp: ''!
I can draw Forms!
!RSBitmap methodsFor: 'accessing' stamp: ''!
form
	^ form! !

!RSBitmap methodsFor: 'accessing' stamp: ''!
paintOn: visitor
	^ visitor paintFor: self form: self form! !

!RSBitmap methodsFor: 'accessing' stamp: ''!
form: aForm
	aForm ifNil: [ ^ self ].
	form := aForm.
	self computeRectangle.! !

!RSBitmap methodsFor: 'private' stamp: ''!
computeRectangle
	baseRectangle := Rectangle floatCenter: 0@0 extent: (form 
		ifNil: [ 0@0 ]
		ifNotNil: [ form extent ]).
	encompassingRectangle := nil! !

!RSBitmap methodsFor: 'accessing' stamp: ''!
extent: newExtent
	| oldExtent |
	oldExtent := self extent.
	(oldExtent = (0 @ 0)) ifTrue: [ ^ self ].
	matrix scaleBy: newExtent / oldExtent.
! !

!RSBitmap methodsFor: 'visiting' stamp: ''!
path
	^ self baseRectangle! !

!RSBlink commentStamp: ''!
Make the shape blink.

For example:

```
c := RSCanvas new.
shapes := RSCircle models: (1 to: 9).
shapes size: 30.
c addAll: shapes.
RSGridLayout on: shapes.
shapes when: RSMouseClick do: [ :evt | evt shape @ RSBlink ].

shapes fifth @ RSBlink.
c @ RSCanvasController
```!
!RSBlink methodsFor: 'hooks' stamp: ''!
onShape: aShape
	| canvas previousColor |
	canvas := aShape canvas.
	previousColor := aShape color.
	aShape color: Color red.
	canvas signalUpdate.
	canvas newAnimation
				duration: 0.5 second;
				when: RSAnimationEndEvent do: [ :evt | 
					aShape color: previousColor.
					canvas signalUpdate. ]! !

!RSBlockCPController commentStamp: ''!
I have am useful to define the control points in a fast way, but if you plan to use this controller in many scenarios, try to create a new subclass of RSAbstractCPController and avoid to use this class

```
canvas := RSCanvas new.
 
box1 := RSBox new color: Color blue.
box2 := RSBox new color: Color red.
box2 translateTo: 100 @ -200.

box1 @ RSDraggable.
box2 @ RSDraggable.
canvas add: box1; add: box2.
 
bezierLine := RSBezier new
	withVerticalAttachPoint;
	from: box1;
	to: box2;
	controlPointsController: (
			RSBlockCPController new
				block: [ :aLine |
					| mid |
   					mid := (box1 position + box2 position) / 2.
					{(box1 position) . 
					(box1 position x @ mid y) .
					(box2 position x @ mid y) .
					(box2 position)} ];
				yourself);
  yourself.
canvas add: bezierLine.
canvas zoomToFit.
canvas open
```!
!RSBlockCPController methodsFor: 'accessing' stamp: ''!
block
	^ block! !

!RSBlockCPController methodsFor: 'accessing' stamp: ''!
block: aBlockClosure
	block := aBlockClosure! !

!RSBlockCPController methodsFor: 'hooks' stamp: ''!
controlPointsFor: aLine
	^ block cull: aLine! !

!RSBlockChartPopupBuilder commentStamp: ''!
This uses a block, avoid to use this class and create a subclass of RSLineChartPopupBuilder!
!RSBlockChartPopupBuilder methodsFor: 'accessing' stamp: ''!
rowShapeBlock: aBlock
	"two arguments block
	first argument is the line plot.
	second argument is the point value
	should return a RSShape "
	rowShapeBlock := aBlock! !

!RSBlockChartPopupBuilder methodsFor: 'accessing' stamp: ''!
rowShapeBlock
	^ rowShapeBlock! !

!RSBlockChartPopupBuilder methodsFor: 'hooks' stamp: ''!
rowShapeFor: aRSLinePlot point: aPoint
	^ rowShapeBlock value: aRSLinePlot value: aPoint! !

!RSBorder commentStamp: ''!
I represent borders and line styles.

A same border can be shared amoung different shapes. Here is an example:

```Smalltalk
c := RSCanvas new.

b := RSBorder new color: Color blue.
(30 to: 50 by: 5) do: [ :nb |
	box := RSBox new size: nb.
	ellipse := RSEllipse new width: nb; height: nb + 10.
	box border: b.
	ellipse border: b.
	c add: box; add: ellipse.
	 ].

RSFlowLayout on: c shapes.
c @ RSCanvasController.
c open
```

Another example, using animation: 
```Smalltalk
c := RSCanvas new.

b := RSBorder new color: Color blue.
b dashArray: #(5 1 5).
(30 to: 60) do: [ :nb |
 box := RSBox new size: nb.
 ellipse := RSEllipse new width: nb; height: nb + 10.
 box border: b.
 ellipse border: b.
 c add: box; add: ellipse.
  ].

RSFlowLayout on: c shapes.
c @ RSCanvasController.

c newAnimation 
 from: 0;
 to: 40;
 on: b set: #dashOffset:.
c open
```
!
!RSBorder methodsFor: 'accessing' stamp: ''!
color: aColor
	"Set a color to the border. The color is provided as argument, and can be either a color object (e.g., `Color red`) or a symbol (e.g., `#yellow`)."
	paint := aColor.
	paint isColor ifTrue: [ ^ self ].
	paint := Color colorFrom: aColor.! !

!RSBorder methodsFor: 'style - cap' stamp: ''!
capSquare
	self pStyle capStyle: #capSquare.! !

!RSBorder methodsFor: 'accessing' stamp: ''!
width: anInteger 
	"Set the width of the border. 
	
For example:
```Smalltalk
c := RSCanvas new.
shapes := (1 to: 30) collect: [ :v | RSBox new border: (RSBorder new color: Color red; width: 3); model: v ] as: RSGroup.
c addAll: shapes.
shapes @ RSPopup.

RSNormalizer size
	shapes: shapes;
	normalize: #yourself.

interaction := RSHighlightable new.
interaction highlightColor: Color blue.
interaction highlightBorder: (RSBorder new color: Color black; width: 3).
shapes @ interaction.

RSGridLayout on: shapes.
c @ RSCanvasController
```
	"
	width := anInteger! !

!RSBorder methodsFor: 'accessing' stamp: ''!
width 
	^ width! !

!RSBorder methodsFor: 'style - cap' stamp: ''!
capRound
	self pStyle capStyle: #capRound.! !

!RSBorder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	paint := Color gray.
	width := 1.! !

!RSBorder methodsFor: 'style - join' stamp: ''!
joinBevel
	self pStyle joinStyle: #joinBevel! !

!RSBorder methodsFor: 'accessing' stamp: ''!
dashOffset: offset
	"Set the offset for the dash. The offset is useful when animating. 

```Smalltalk
c := RSCanvas new.

b := RSBorder new color: Color blue.
b dashArray: #(5 1 5).
(30 to: 60) do: [ :nb |
	box := RSBox new size: nb.
	ellipse := RSEllipse new width: nb; height: nb + 10.
	box border: b.
	ellipse border: b.
	c add: box; add: ellipse.
	 ].

RSFlowLayout on: c shapes.
c @ RSControlsCanvas.

c newAnimation 
	from: 0;
	to: 40;
	on: b set: #dashOffset:.

c
```
	"
	self pStyle dashOffset: offset! !

!RSBorder methodsFor: 'accessing' stamp: ''!
style
	^style! !

!RSBorder methodsFor: 'private' stamp: ''!
pStyle 
	^ style ifNil: [ style := RSStrokeStyle new ].! !

!RSBorder methodsFor: 'accessing' stamp: ''!
style: aStyle
	style := aStyle! !

!RSBorder methodsFor: 'printing' stamp: ''!
printOn: stream
	width printOn: stream.
	stream nextPutAll: ', '.
	paint printOn: stream.
	style ifNil: [ ^ self ].
	stream nextPutAll: ', '.
	style printOn: stream.! !

!RSBorder methodsFor: 'style - join' stamp: ''!
joinMiter
	self pStyle joinStyle: #joinMiter! !

!RSBorder methodsFor: 'accessing' stamp: ''!
paint 
	^ paint! !

!RSBorder methodsFor: 'accessing' stamp: ''!
dashOffset
	^ self pStyle dashOffset! !

!RSBorder methodsFor: 'accessing' stamp: ''!
paint: aPaint
	paint := aPaint! !

!RSBorder methodsFor: 'style - cap' stamp: ''!
capButt
	self pStyle capStyle: #capButt.! !

!RSBorder methodsFor: 'style - join' stamp: ''!
joinRound
	self pStyle joinStyle: #joinRound! !

!RSBorder methodsFor: 'style - dashes' stamp: ''!
dashArray: arrayOfNumbers
	"Set the pattern for the dash. For example:
-=-=-=-=-=-=-=-=-=-=-=-=
c := RSCanvas new.

b := RSBorder new color: Color blue.
b dashArray: #(1 5 10 15).
(30 to: 60) do: [ :nb |
	box := RSBox new size: nb.
	ellipse := RSEllipse new width: nb; height: nb + 10.
	box border: b.
	ellipse border: b.
	c add: box; add: ellipse.
	 ].

RSFlowLayout on: c shapes.
c @ RSControlsCanvas.
c
-=-=-=-=-=-=-=-=-=-=-=-=

	"
	self pStyle dashArray: arrayOfNumbers
	! !

!RSBorder methodsFor: 'visiting' stamp: ''!
accept: visitor
	^ visitor visitBorder: self! !

!RSBorder methodsFor: 'accessing' stamp: ''!
color
	^ paint! !

!RSBorderAttachPoint commentStamp: ''!
I am an attach point that will end the line on the border of the end shapes.

Unline ContinuousAttachPoint & co. you don't need to care about what the end shape is, as long as it is one of the basic shapes.

Indirect way to use it:
-=-=-=-=
c := RSCanvas new.

shapes := (30 to: 50) collect: [ :nb |
	RSEllipse new size: nb; model: nb; yourself.
	 ] as: RSGroup.

c addAll: shapes.

RSEdgeBuilder line
	canvas: c;
	withBorderAttachPoint;
	connectFrom: 30 toAll: (31 to: 50).


RSGridLayout on: shapes. 
RSLocation new
	above;
	move: shapes first on: shapes allButFirst.
shapes @ RSDraggable.

c @ RSCanvasController
-=-=-=-=


Manual way to set an attach point:
-=-=-=-=
c := RSCanvas new.

shapes := (30 to: 50) collect: [ :nb |
	RSEllipse new size: nb; model: nb; yourself.
	 ] as: RSGroup.

c addAll: shapes.

lines := RSEdgeBuilder line
	canvas: c;
	connectFrom: 30 toAll: (31 to: 50).

lines do: [ :l | l attachPoint: (RSBorderAttachPoint new) ].

RSGridLayout on: shapes. 
RSLocation new
	above;
	move: shapes first on: shapes allButFirst.
shapes @ RSDraggable.

c @ RSCanvasController
-=-=-=-=!
!RSBorderAttachPoint methodsFor: 'public - hooks' stamp: ''!
geometryFor: shape edge: anEdge
	| g commonParents matrix |
	g := shape geometry.
	(self hasParents: shape in: anEdge)
		ifFalse: [ ^ g ].
	shape parent = anEdge parent
		ifTrue: [ ^ g ].
	commonParents := self commonParents: shape in: anEdge.
	commonParents ifNil: [ ^ g ].
	matrix := self matrixFor: commonParents.
	g := g rsScaleWith: matrix.
	^ g! !

!RSBorderAttachPoint methodsFor: 'public - hooks' stamp: ''!
borderPointFrom: aSource to: aTarget via: aLine
	^ ((aLine intersectionsWith: aSource) detectMin: [ :p | p asPoint distanceTo: aLine v2 ])
		ifNil: [ aSource center ]! !

!RSBorderAttachPoint methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	offset := 5! !

!RSBorderAttachPoint methodsFor: 'accessing' stamp: ''!
offset: aNumber
	offset := aNumber! !

!RSBorderAttachPoint methodsFor: 'public - hooks' stamp: ''!
offsetNormalFor: anEdge
	"Return the offset in case of multiple edges with the same starting and ending points"

	| indexOfEdge multipleEdges |
	multipleEdges := OrderedCollection new.
	multipleEdges
		addAll:
			(anEdge to connectedLines
				select: [ :e | e from == anEdge from and: [ e to == anEdge to ] ]).
	multipleEdges
		addAll:
			(anEdge to connectedLines
				select: [ :e | e to == anEdge from and: [ e from == anEdge to ] ]).
	multipleEdges size <= 1
		ifTrue: [ ^ 0 @ 0 ].
	indexOfEdge := multipleEdges indexOf: anEdge.
	^ (indexOfEdge - 1 - (multipleEdges size / 2)) * offset! !

!RSBorderAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicPointFrom: fromShape to: toShape of: anEdge offset: aNumber
	| source target line shift res vector unit |
	source := self geometryFor: fromShape edge: anEdge.
	target := self geometryFor: toShape edge: anEdge.
	shift := self offsetNormalFor: anEdge.
	line := GLine through: source center and: target center.
	vector := line v2 asPoint - line v1 asPoint.
	vector := vector x @ vector y.
	unit := vector / (vector r max: 1).
	shift := vector normal * shift.
	anEdge from = toShape
		ifTrue: [ shift := shift * -1 ].
	line := GLine
		through: source center asPoint + shift
		and: target center asPoint + shift.
	res := self borderPointFrom: source to: target via: line.
	^ res asPoint + (unit * aNumber)! !

!RSBorderAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicEndingPointOf: anEdge
	^ self
		basicPointFrom: anEdge to
		to: anEdge from
		of: anEdge
		offset: endOffset! !

!RSBorderAttachPoint methodsFor: 'accessing' stamp: ''!
offset
	^ offset! !

!RSBorderAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicStartingPointOf: anEdge
	^ self 
		basicPointFrom: anEdge from 
		to: anEdge to 
		of: anEdge 
		offset: startOffset! !

!RSBounceInterpolator commentStamp: ''!
TSEasing bounceIn
Bounce easing, like a rubber ball.

TSEasing bounce
TSEasing bounceOut
Reverse bounce easing; equivalent to 1 - bounceIn(1 - t).

TSEasing bounceInOut
Symmetric bounce easing; scales bounceIn for t in [0, 0.5] and bounceOut for t in [0.5, 1].!
!RSBounceInterpolator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	b1 := 4 / 11.
	b2 := 6 / 11.
	b3 := 8 / 11.
	b4 := 3 / 4.
	b5 := 9 / 11.
	b6 := 10 / 11.
	b7 := 15 / 16.
	b8 := 21 / 22.
	b9 := 63 / 64.
	b0 := 1 / b1 / b1! !

!RSBounceInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateIn: t
	^ 1 - (self interpolateOut: 1 - t)! !

!RSBounceInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateInOut: i
	"((t *= 2) <= 1 ? 1 - bounceOut(1 - t) : bounceOut(t - 1) + 1) / 2;"
	| t |
	t := i * 2.
	^ (t <= 1
		ifTrue: [ 1 - (self interpolateOut: 1 -t) ]
		ifFalse: [ (self interpolateOut: t - 1) + 1 ] )/2! !

!RSBounceInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateOut: i
	| t |
	t := i.
	^ t < b1 
		ifTrue: [ b0 * t * t ]
		ifFalse: [ 
			t < b3 ifTrue: [ 
				t := t - b2.
				b0 * t * t + b4 ]
			ifFalse: [ 
				t < b6 ifTrue: [ 
					t := t - b5.
					b0 * t * t + b7 ]
				ifFalse: [ 
					t := t - b8.
					b0 * t * t + b9 ] ] ] ! !

!RSBoundingShape commentStamp: ''!
My subclasses has an extent and a transformation matrix!
!RSBoundingShape methodsFor: 'metrics' stamp: ''!
numberOfOutgoingLines
	"Return the number of lines incoming to the shape"
	^ self outgoingLines size! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
rotateByRadians: angle
	"Rotate the shape. Here is an exanmple:
-=-=-=
c := RSCanvas new.
c add: (RSBox new
	size: 10;
	rotateByRadians: Float pi / 3;
	yourself).
c
-=-=-=
	"
	matrix rotateByRadians: angle! !

!RSBoundingShape methodsFor: 'metrics' stamp: ''!
numberOfIncomingLines
	"Return the number of lines incoming to the shape"
	^ self incomingLines size! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
updateLinesOFF
	shouldUpdateLines := false! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
matrix
	^ matrix! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
removeConnectedLines
	"Remove all the edges connected (incoming and outgoing)."
	self connectedLines copy do: [ :aLine | aLine remove ]! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
position: aPoint
	"This method is private. Use #translateTo: instead."
	self 
		assert: [ (aPoint x isNaN | aPoint y isNaN) not ]
		description: 'you must provide a real point'.
	matrix translation: aPoint.
	self resetBBox.
	self updateConnectedLines.! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
y: aNumber
	"Set the y position"
	self position: self position x @ aNumber! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
incomingLines
	"Return the list of incoming edges from the node"
	connectedLines ifNil: [ ^ #() ].
	^ self connectedLines select: [ :e | e to == self ]! !

!RSBoundingShape methodsFor: 'edges - deprecated' stamp: ''!
incomingEdges
	"Return the list of incoming edges from the node"
	connectedLines ifNil: [ ^ #() ].
	^ self connectedEdges select: [ :e | e to == self ]! !

!RSBoundingShape methodsFor: 'accessing' stamp: ''!
baseRectangle
	^ baseRectangle! !

!RSBoundingShape methodsFor: 'accessing' stamp: ''!
positionInCanvas
	^ self globalMatrix transform: 0@0.! !

!RSBoundingShape methodsFor: 'edges - deprecated' stamp: ''!
shouldUpdateEdges
	"Moving a shape around usually involve recomputing the original of the connected egdes. This may be disabled. This method indicates whether edges are updated when the shape is moved."
	^ shouldUpdateLines and: [ connectedLines notNil ]! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
scale
	^ matrix scale! !

!RSBoundingShape methodsFor: 'actions' stamp: ''!
translateBottomLeftTo: aPositionAsPoint
	"Translate the shape to make the top left corner at a given position

```
c := RSCanvas new.
lbl := RSLabel text: 'Top left corner'.
c add: lbl.
lbl translateBottomLeftTo: 0 @ 0.

dot := RSCircle new.
c add: dot.
c zoomToFit.
c open
```
	
"
	self translateTo: aPositionAsPoint + ((self extent / 2) * (1 @ -1))! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
globalMatrix
	^ parent globalMatrix multiplyBy: matrix.! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
isDirectlyConnectedTo: aShape
	connectedLines ifNil: [ ^ false ].
	^ connectedLines anySatisfy: [ :edge | edge to == aShape ]! !

!RSBoundingShape methodsFor: 'edges - deprecated' stamp: ''!
updateEdgesON
	shouldUpdateLines := true! !

!RSBoundingShape methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self initializeMatrix; updateEdgesON.
	
	baseRectangle := 0@0 corner: 0@0.
	self extent: 10 @ 10.! !

!RSBoundingShape methodsFor: 'edges - deprecated' stamp: ''!
removeConnectedEdges
	"Remove all the edges connected (incoming and outgoing)."
	self connectedEdges copy do: [ :edge | edge remove ]! !

!RSBoundingShape methodsFor: 'edges - deprecated' stamp: ''!
updateEdgesOFF
	shouldUpdateLines := false! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
basicTranslateBy: delta
	self updateLinesOFF.
	self position: self position + delta.
	self updateLinesON.! !

!RSBoundingShape methodsFor: 'testing' stamp: ''!
intersects: aRectangle
	| rect |
	self isInACanvas ifFalse: [ ^ false ].
	rect := self 
		computeEncompassingRectangleFor: self baseRectangle 
		matrix: self globalMatrix.
	^ rect intersects: aRectangle! !

!RSBoundingShape methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self matrix: self matrix copy! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
connectedLines: aCollection
	connectedLines := aCollection! !

!RSBoundingShape methodsFor: 'accessing' stamp: ''!
computeEncompassingRectangle
	^ self computeEncompassingRectangleFor: self baseRectangle.
	! !

!RSBoundingShape methodsFor: 'initialization' stamp: ''!
fromRectangle: aRectangle
	"Set the position and extent of the shape, using a rectangle as argument.
For example:	
```
c := RSCanvas new.
box := RSBox new.
box fromRectangle: (10 @ 10 corner: 50 @ 40).
c add: box.
c
```
"
	self 
		translateTo: aRectangle floatCenter;
		extent: aRectangle extent! !

!RSBoundingShape methodsFor: 'initialization' stamp: ''!
initializeMatrix
	matrix := AthensAffineTransform new! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
removeConnectedLine: aLine
	self assert: [  aLine isLine ].
	self connectedLines remove: aLine ifAbsent: [ ]! !

!RSBoundingShape methodsFor: 'actions' stamp: ''!
translateTo: aPoint
	"Translate a shape to a new position, expressed as a point"
	| oldPosition |
	oldPosition := self position.
	oldPosition = aPoint ifTrue: [ ^ self ].
	self position: aPoint.
	self announce: [RSPositionChangedEvent new 
		shape: self; 
		oldPosition: oldPosition;
		newPosition: aPoint ].
! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
updateLinesON
	shouldUpdateLines := true! !

!RSBoundingShape methodsFor: 'private' stamp: ''!
allRecursiveConnectedShapesIn: aCollection
	"Private method"
	
	"If we already went through me, there is nothing to do"
	(aCollection includes: self) ifTrue: [ ^ self ].
	
	"Else, we add it and we do the recursion"
	aCollection add: self.
	self incomingShapes do: [ :s | s allRecursiveConnectedShapesIn: aCollection ].
	self outgoingShapes do: [ :s | s allRecursiveConnectedShapesIn: aCollection ].! !

!RSBoundingShape methodsFor: 'edges - deprecated' stamp: ''!
outgoingEdges
	"Return the list of outgoing edges from the node"
	connectedLines ifNil: [ ^ #() ].
	^ self connectedEdges select: [ :e | e from == self ]! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
incomingShapes
	"Return the shapes that goes to the shape"
	^ self incomingLines collect: #from! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
transform: aPoint
	"useful for attachpoints"
	^ matrix transform: aPoint! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
outgoingShapes
	"Return the shapes that leaves the shape"
	^ self outgoingLines collect: #to! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
connectedLines
	"Return the list of connected egdes (i.e., incoming and outgoing edges)"
	connectedLines ifNil: [ connectedLines := RSGroup new ].
	^ connectedLines! !

!RSBoundingShape methodsFor: 'testing' stamp: ''!
includesPoint: aPoint
	"Return true if the provided point is included in the encompassing rectangle of the shape."
	| invertedPoint |
	invertedPoint := matrix rsInverseTransform: aPoint.
	^ self baseRectangle containsPoint: invertedPoint.! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
position 
	^ matrix translation! !

!RSBoundingShape methodsFor: 'edges - deprecated' stamp: ''!
addConnectedEdge: anEdge
	self assert: anEdge isEdge.
	(self connectedEdges includes: anEdge) 
		ifFalse: [ self connectedEdges add: anEdge ]! !

!RSBoundingShape methodsFor: 'edges - deprecated' stamp: ''!
updateConnectedEdges
	self shouldUpdateEdges
		ifFalse: [ ^ self ].
	self connectedEdges do: [ :edge | edge update ].! !

!RSBoundingShape methodsFor: 'actions' stamp: ''!
translateBy: deltaAsPoint
	"Move a shape by a delta value, expressed as a point"
	self translateTo: self position + deltaAsPoint
	! !

!RSBoundingShape methodsFor: 'testing' stamp: ''!
shouldUpdateLines
	"Moving a shape around usually involve recomputing the original of the connected egdes. This may be disabled. This method indicates whether edges are updated when the shape is moved."
	^ shouldUpdateLines and: [ connectedLines notNil ]! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
x: aNumber
	"Set the x position"
	self position: aNumber @ self position y! !

!RSBoundingShape methodsFor: 'accessing' stamp: ''!
computeEncompassingRectangleFor: rect 
	^ self computeEncompassingRectangleFor: rect matrix: self matrix! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
loadIdentity
	matrix loadIdentity! !

!RSBoundingShape methodsFor: 'actions' stamp: ''!
translateMiddleRightTo: aPositionAsPoint
	"Translate the shape to make the middle right position at a given position

```
c := RSCanvas new.

center := RSEllipse new size: 2; color: Color red.
c add: center.
center translateTo: 0 @ 0.

lbl := RSLabel text: 'Middle right corner'.
c add: lbl.
lbl translateMiddleRightTo: 0 @ 0.
c @ RSCanvasController.
c open
```
	
"
	self translateTo: aPositionAsPoint - ((self extent x / 2) @ 0)! !

!RSBoundingShape methodsFor: 'accessing' stamp: ''!
extent: aPoint
	| oldExtent extent |
	extent := baseRectangle extent.
	extent = aPoint ifTrue: [ ^ self ].
	self assert: aPoint isPoint.
	oldExtent := extent.
	baseRectangle := Rectangle floatCenter: 0@0 extent: aPoint.
	self resetBBox; resetPath.
	self announce: [ RSExtentChangedEvent new 
		shape: self;
		oldExtent: oldExtent;
		newExtent: extent ]! !

!RSBoundingShape methodsFor: 'edges - deprecated' stamp: ''!
connectedEdges
	"Return the list of connected egdes (i.e., incoming and outgoing edges)"
	^ self connectedLines! !

!RSBoundingShape methodsFor: 'actions' stamp: ''!
translateTopRightTo: aPositionAsPoint
	"Translate the shape to make the top left corner at a given position

```
c := RSCanvas new.
lbl := RSLabel text: 'Top right corner'.
c add: lbl.
lbl translateTopRightTo: 0 @ 0.

dot := RSCircle new.
c add: dot.
c zoomToFit.
c open
```
	
"
	self translateTo: aPositionAsPoint + ((self extent / 2) * (-1 @ 1))! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
rotateByDegrees: angle
	"Rotate the shape. Here is an example:
```
c := RSCanvas new.

polygon := RSPolygon new
		points: { 0 @ -50 . 50 @ 0 . -50 @ 0 };
		color: 'FFAE0B'.
polygon cornerRadii: 5.
polygon rotateByDegrees: -45.		

c add: polygon.
c	
```

Another example:
```
c := RSCanvas new.

(0 to: 90 count: 10) do: [ :rotation |
	lbl := RSLabel text: 'Hello world'.
	lbl color: Color gray translucent.
	lbl rotateByDegrees: rotation.
	lbl @ RSHighlightable red.
	lbl translateTopLeftTo: 0 @ 0.
	c add: lbl
	 ].
c @ RSCanvasController.
c open
```
	"
	matrix rotateByDegrees: angle! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
outgoingLines
	"Return the list of outgoing edges from the node"
	connectedLines ifNil: [ ^ #() ].
	^ self connectedLines select: [ :e | e from == self ]! !

!RSBoundingShape methodsFor: 'testing' stamp: ''!
hasEdges
	"Return true if the shape has any outgoing or incoming edge"
	^ connectedLines notNil! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
scaleBy: scale 
	"Scale the shape. For example:

```
c := RSCanvas new.

polygon := RSPolygon new
		points: { 0 @ -50 . 50 @ 0 . -50 @ 0 };
		color: 'FFAE0B'.
polygon cornerRadii: 5.
polygon rotateByDegrees: -45.		
polygon scaleBy: 4.
c add: polygon.
c
```
	"
	matrix scaleBy: scale! !

!RSBoundingShape methodsFor: 'actions' stamp: ''!
translateBottomRightTo: aPositionAsPoint
	"Translate the shape to make the top left corner at a given position

```
c := RSCanvas new.
lbl := RSLabel text: 'Top left corner'.
c add: lbl.
lbl translateBottomRightTo: 0 @ 0.

dot := RSCircle new.
c add: dot.
c zoomToFit.
c open
```
	
"
	self translateTo: aPositionAsPoint + ((self extent / 2) * (-1 @ -1))! !

!RSBoundingShape methodsFor: 'accessing' stamp: ''!
width: aNumber
	self extent: aNumber @ self extent y! !

!RSBoundingShape methodsFor: 'edges - deprecated' stamp: ''!
removeConnectedEdge: anEdge
	[  anEdge isEdge ] assert.
	self connectedEdges remove: anEdge ifAbsent: [ ]! !

!RSBoundingShape methodsFor: 'geometry' stamp: ''!
geometry
	| rect e |
	rect := self encompassingRectangle.
	e := rect extent.
	e = (0@0) ifTrue: [ ^ rect floatCenter asGPoint ].
	^ GRectangle
		origin: rect origin 
		corner: rect corner! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
updateConnectedLines
	self shouldUpdateLines
		ifFalse: [ ^ self ].
	self connectedLines do: [ :line | line update ].! !

!RSBoundingShape methodsFor: 'accessing' stamp: ''!
size: anInteger
	"Set the size of the shape by providing a number."
	self extent: anInteger asPoint! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
matrixDo: aBlock
	aBlock value: matrix.
	self resetBBox.! !

!RSBoundingShape methodsFor: 'lines' stamp: ''!
addConnectedLine: aLine
	self assert: [ aLine isLine ] description: 'Only a line can be added'.
	(self connectedLines includes: aLine) 
		ifFalse: [ self connectedLines add: aLine ]! !

!RSBoundingShape methodsFor: 'actions' stamp: ''!
translateTopLeftTo: aPositionAsPoint
	"Translate the shape to make the top left corner at a given position

```
c := RSCanvas new.
lbl := RSLabel text: 'Top left corner'.
c add: lbl.
lbl setAsFixed.
lbl translateTopLeftTo: 0 @ 0.
c open
```
	
"
	self translateTo: aPositionAsPoint + (self extent / 2)! !

!RSBoundingShape methodsFor: 'accessing' stamp: ''!
height: aNumber
	self extent: self extent x @ aNumber! !

!RSBoundingShape methodsFor: 'actions' stamp: ''!
remove
	parent ifNil: [ ^ self ].
	parent removeNode: self.
	self removeConnectedLines.
	super remove! !

!RSBoundingShape methodsFor: 'testing' stamp: ''!
isNode
	^ true! !

!RSBoundingShape methodsFor: 'adding' stamp: ''!
renderOn: aCanvas
	aCanvas addNode: self! !

!RSBoundingShape methodsFor: 'accessing' stamp: ''!
allRecursiveConnectedShapes
	"Return the set of all recursively connected shapes."
	| r |
	r := Set new.
	self allRecursiveConnectedShapesIn: r.
	^ r! !

!RSBoundingShape methodsFor: 'visiting' stamp: ''!
accept: visitor
	visitor visitBoundingShape: self! !

!RSBoundingShape methodsFor: 'matrix' stamp: ''!
matrix: aMatrix
	matrix := aMatrix! !

!RSBoundingShape class methodsFor: 'accessing' stamp: ''!
models: someObjects size: aOneArgBlockOrSymbol
	"Create a RSGroup made of shapes. Each shape has an element of the argument as model and a size.

For example:
```
c := RSCanvas new.

shapes := RSCircle models: (30 to: 50) size: [ :nb | nb ]. 

c addAll: shapes.

lines := RSEdgeBuilder line
	canvas: c;
	connectFrom: 30 toAll: (31 to: 50).

lines do: [ :l | l attachPoint: (RSHorizontalAttachPoint new) ].

RSGridLayout on: shapes. 
RSLocation new
	above;
	move: shapes first on: shapes allButFirst.
shapes @ RSDraggable.

c @ RSCanvasController.
c open
```	
"

	^ someObjects
		  collect: [ :obj | 
		  (self model: obj) size: (aOneArgBlockOrSymbol rsValue: obj) ]
		  as: RSGroup! !

!RSBoundingShape class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == RSBoundingShape! !

!RSBoundingTest commentStamp: ''!
Test for all shapes with a matrix an one encompassing rectangle!
!RSBoundingTest methodsFor: 'tests' stamp: ''!
testTranslateTopLeftTo

	| b |
	b := RSBox new size: 10.
	b translateTopLeftTo: 0 @ 0.
	self assert: b position equals: 5 @ 5.
	
	b translateTopLeftTo: 10 @ 50.
	self assert: b position equals: 15 @ 55.! !

!RSBoundingTest methodsFor: 'running' stamp: ''!
testDrawPolygon
	canvas addShape: (RSPolygon new).
	canvas addShape: (RSPolygon new
		points: { 200@10. 250@190. 160@210 };
		yourself).
	canvas addShape: (RSPolygon new
		cornerRadii: 20;
		points: { 200@10. 250@190. 160@210 };
		yourself).
	self assert: canvas shapes second points equals: {(-5@ -100). (45@80). (-45@100)}.
	canvas createMorph drawOnMockCanvas.! !

!RSBoundingTest methodsFor: 'tests' stamp: ''!
testHasChildren
	| b |
	b := RSBox new.
	self deny: b hasChildren.
	b := RSEllipse new.
	self deny: b hasChildren! !

!RSBoundingTest methodsFor: 'tests' stamp: ''!
testCreating
	| values boxes |
	values := #(20 30 40 50 10).
	boxes := RSBox models: values.
	self assert: boxes class equals: RSGroup.
	self assert: (boxes allSatisfy: [ :s | s class == RSBox ])! !

!RSBoundingTest methodsFor: 'running' stamp: ''!
testDrawBitmap
	canvas addShape: (RSBitmap new
		form: (ColorForm extent: 100@100 depth: 32)).
	canvas createMorph drawOnMockCanvas.! !

!RSBoundingTest methodsFor: 'tests' stamp: ''!
testFromRectangle

	| box |
	box := RSBox new.
	self assert: box position equals: 0 @ 0.
	self assert: box extent > (0 @ 0).
	box fromRectangle: (10 @ 10 corner: 50 @ 40).
	self assert: box position equals: 30 @ 25.
	self assert: box extent equals: 40 @ 30.
	
	! !

!RSBoundingTest methodsFor: 'tests' stamp: ''!
testPosition
	| b |
	b := RSBox new.
	self assert: b position equals: 0@0.
	b position: 0@0.! !

!RSBoundingTest methodsFor: 'running' stamp: ''!
testDrawBoxCornerRadius
	canvas addShape: (RSBox new
		extent: 100@100;
		cornerRadius: 5;
		yourself).
	canvas createMorph drawOnMockCanvas.! !

!RSBoundingTest methodsFor: 'running' stamp: ''!
testDrawRing
	| r |
	r := RSPieSlice new.
	"empty"
	canvas addShape: r.
	"circle"
	canvas addShape: (RSPieSlice new
		innerRadius: 0;
		externalRadius: 100;
		alphaAngle: 0;
		betaAngle: 360).
	"slice"
	canvas addShape: (RSPieSlice new
		externalRadius: 100;
		alphaAngle: 30;
		betaAngle: 90;
		segmentSpacing: 5).
	"donut"
	canvas addShape: (RSPieSlice new
		externalRadius: 100;
		innerRadius: 50;
		alphaAngle: 0;
		betaAngle: 360).
	"corner radii"
	canvas addShape: (RSPieSlice new
		externalRadius: 100;
		innerRadius: 50;
		alphaAngle: 0;
		betaAngle: 45;
		cornerRadii: 20).
	"same radius"
	canvas addShape: (RSPieSlice new
		externalRadius: 100;
		innerRadius: 100;
		alphaAngle: 0;
		betaAngle: 45;
		cornerRadii: 20).
	canvas createMorph drawOnMockCanvas.! !

!RSBoundingTest methodsFor: 'running' stamp: ''!
testDrawBorder
	canvas addShape: (RSEllipse new
		radius: 100;
		withBorder;
		yourself).
	canvas createMorph drawOnMockCanvas.! !

!RSBoundingTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new! !

!RSBox commentStamp: ''!
<keyClass>
`RSBox` represents a box shape, which can be decorated in many ways.

*Responsibility*: represents a 2 dimentional box 

*Collaborators*: may interact with many classes covering composite shapes (e.g., `RSComposite`, `RSGroup`), the `RSCanvas` class, and interaction (e.g., `RSDraggable`, `RSPopup`).

*Variables*:
- `cornerRadius`: angle of the radius. If no radius is applied, the variable is nil

*Example*:
```Smalltalk
RSCanvas new
	add: (RSBox new size: 30);
	yourself
```

A slightly more complex example could be:

```Smalltalk
gradient := LinearGradientPaint new colorRamp: {  0 -> Color red. 1 -> Color black }.

gradient
			start: -50 asPoint;
			stop: 50 asPoint.
c := RSCanvas new.
s := RSBox new size: 80; cornerRadius: 20.
s color: gradient.
c add: s.	
c
```

!
!RSBox methodsFor: 'accessing' stamp: ''!
cornerRadius
	^ cornerRadius! !

!RSBox methodsFor: 'accessing' stamp: ''!
cornerRadius: aRSCornerRadius
	"Set the radius of the corners. Accept a number as argument or a RSCornerRadius.

	For example:
```
c := RSCanvas new.
r := Random seed: 42.
40 timesRepeat: [
	box := RSBox new extent: (r nextInteger: 80) @ (r nextInteger: 80); color: Color gray; cornerRadius: 10.
	box color: Color random translucent.
	box translateTo: (r nextInteger: 200) @ (r nextInteger: 200).
	c add: box.
].
c @ RSCanvasController.
c open
```
"

	cornerRadius := aRSCornerRadius isNumber 
		ifTrue: [ RSCornerRadius new radius: aRSCornerRadius ]
		ifFalse: [ aRSCornerRadius ].
	self resetPath.! !

!RSBox methodsFor: 'visiting' stamp: ''!
buildPathOn: visitor
	visitor buildBoxPath: self! !

!RSBox methodsFor: 'testing' stamp: ''!
hasCornerRadius
	^ cornerRadius notNil
		and: [ cornerRadius max > 0 and: [ cornerRadius min >= 0 ] ]! !

!RSBoxPlot commentStamp: ''!
I am a box and whisker plot used for comparing the distributions of datasets.

I require a 2D collection where the first dimension are the individual box-and-whisker and the inner 
collection are the data points. 

```
| c p y |

"With PolyMath loaded SortedCollection responds to the quantile: message"
y := { { 1. 2. 3. 4. 5. } . 
			 { 5. 6. 7. 5. 10. }  .
			 { 12. 12. 13. 14. 15. 24. }  }. 
c := RSChart new.
p := RSBoxPlot new y: y.
	
c addPlot: p.
	
c addDecoration: (RSHorizontalTick new 
		numberOfTicks: y size).
c xlabel: 'X Axis'.
c addDecoration: (RSVerticalTick new 
		numberOfTicks: 10;
		asFloat).
c ylabel: 'Y Axis'.
c title: 'Box Plot'.
c openOnce.
```!
!RSBoxPlot methodsFor: 'public' stamp: ''!
x: aCollection y: aCollection2
	xValues := aCollection.
	yValues := aCollection2.
	self computeBoxAndWhiskerExtent: aCollection2.! !

!RSBoxPlot methodsFor: 'accessing' stamp: ''!
barOffset: aNumber
	barOffset := aNumber! !

!RSBoxPlot methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		gapRatio: 0.1;
		barOffset: 0.! !

!RSBoxPlot methodsFor: 'rendering' stamp: ''!
computeRectagleAndLinesFor: index 
   "Convert the box and whisker extents to their positions in the plot using the scale"
	| lowerOutliers upperOutliers boxAndWhis origin sizeOffset offset zero aPoint topLeft bottomRight bottomWhiskerExtent topWhiskerExtent corner center |
	
	boxAndWhis := boxAndWhisker at: index.
	aPoint := (xValues at: index) @ (boxAndWhis at: 5).
	zero := boxAndWhis at: 3.
	"origin is the top left of the rectangle"
	origin := self scalePoint: aPoint.
	corner := origin x @ (yScale scale: zero ).
	
	sizeOffset := (self barSize / 2.0) @ 0.
	offset := self barOffset @ 0.
	
	topLeft := origin + offset - sizeOffset.
	
	bottomRight := corner + offset + sizeOffset.
	
	center := (topLeft x + bottomRight x) / 2.
	
	"These are a collection of RSEllipse for the outlying points of the dataset"
	lowerOutliers := self computeOutliersFor: (boxAndWhis at: 1) at: center.
	upperOutliers := self computeOutliersFor: (boxAndWhis at: 7) at: center. 
	
	bottomWhiskerExtent := center @ (yScale scale: (boxAndWhis at: 2)).
	topWhiskerExtent := center @ (yScale scale: (boxAndWhis at: 6)).
	
	
	^{ 	self shape copy
		model: (self modelFor: aPoint);
		color: self computeColor;
		fromRectangle: (Rectangle origin: topLeft corner: bottomRight );
		yourself.
		RSLine new 
			startPoint: (topLeft x  @ (yScale scale: (boxAndWhis at: 4))); 
			endPoint: (bottomRight x @(yScale scale: (boxAndWhis at: 4))).
		RSLine new 
			startPoint: center @ corner y; 
			endPoint: bottomWhiskerExtent .  
		RSLine new 
			startPoint: center @ origin y; 
			endPoint: topWhiskerExtent}, 
		lowerOutliers, 
		upperOutliers.! !

!RSBoxPlot methodsFor: 'rendering' stamp: ''!
beforeRenderingIn: aChart
	| barScale |
	super beforeRenderingIn: aChart.
	xScale class = NSOrdinalScale ifTrue: [ ^ self ].
	barScale := NSOrdinalScale new 
		domain: xValues;
		rangeBands: xScale range padding: gapRatio.
	aChart xScale: barScale! !

!RSBoxPlot methodsFor: 'accessing' stamp: ''!
barOffset
	^ barOffset! !

!RSBoxPlot methodsFor: 'testing' stamp: ''!
isBoxPlot
	^ true! !

!RSBoxPlot methodsFor: 'rendering' stamp: ''!
computeOutliersFor: points at: xValue

	"Translates a collection of points to the plot coordinates and returns a collection of RSEllipse"
	"xValue has already been converted into the xscale but points are still in the original data scale"
	
	^points collect: [ :i |
		| newPoint |
		newPoint := xValue @ (yScale scale: i).
		RSEllipse new
				radius: 2;
				color: self computeColor;
				translateTo: newPoint .
	].! !

!RSBoxPlot methodsFor: 'accessing' stamp: ''!
barScale
	^ xScale.! !

!RSBoxPlot methodsFor: 'accessing' stamp: ''!
gapRatio: aNumber
	"aNumber between 0 and 1"
	gapRatio := aNumber! !

!RSBoxPlot methodsFor: 'math functions' stamp: ''!
quantile: aProbability for: aSortedCollection
	"returns the expected quantile only, if I use my standard initialization method"

	^ self quantile: aProbability for: aSortedCollection withProbs: self modeBased.! !

!RSBoxPlot methodsFor: 'private' stamp: ''!
computeBoxAndWhiskerExtent: aCollection
	"Converts a 2D collection of data points into the poisition of the 1 and 3 quartile, the whiskers, and outlieing points.
	
	Returns an array with the following:
	1. An array of the lower outlying data
	2. The y value of the bottom whisker 
	3. The y value of the bottom of the box 
	4. The y value of the median
	5. The y value of the top of the box 
	6. The y value of the top whisker
	7. An array of the upper outlying data
	"
	boxAndWhisker := aCollection collect: [ :i |
		|iSort quartile1 quartile3 minVal maxVal bottomWhiskerExtent topWhiskerExtent iqr bottomOutliers topOutliers |
		
		iSort := i asSortedCollection .
		
		minVal := iSort min.
		maxVal := iSort max.
		quartile1 := self quantile: 0.25 for: iSort.
		quartile3 := self quantile: 0.75 for: iSort.
		iqr := quartile3 - quartile1 .
		
		bottomWhiskerExtent := quartile1 - (iqr * 1.5).
		bottomWhiskerExtent <= minVal 
			ifTrue: [ bottomWhiskerExtent := minVal. bottomOutliers := Array new ]
			ifFalse: [ bottomOutliers := i select: [ :j | j < bottomWhiskerExtent  ] ].
		
		topWhiskerExtent := quartile3 + (iqr * 1.5).
		topWhiskerExtent >= maxVal 
			ifTrue: [ topWhiskerExtent := maxVal. topOutliers := Array new ]
			ifFalse: [ topOutliers := i select: [ :j | j > topWhiskerExtent  ] ].
			
		{ bottomOutliers . bottomWhiskerExtent . quartile1. iSort median. quartile3. topWhiskerExtent . topOutliers  }
	].
! !

!RSBoxPlot methodsFor: 'accessing' stamp: ''!
createdShapes
	^ bars! !

!RSBoxPlot methodsFor: 'hooks' stamp: ''!
modelFor: aPoint
	^ aPoint y! !

!RSBoxPlot methodsFor: 'math functions' stamp: ''!
quantile: aProbability for: aSortedCollection withProbs: anArray
	| a b c d p f |
	a := anArray at: 1.
	b := anArray at: 2.
	c := anArray at: 3.
	d := anArray at: 4.
	p := (aSortedCollection size + b) * aProbability + a.
	p := p < 1
		ifTrue: [ 1 ]
		ifFalse: [ p min: aSortedCollection size ].
	^ p truncated = p
		ifTrue: [ aSortedCollection at: p asInteger ]
		ifFalse: [ (f := aSortedCollection at: p floor)
				+ (((aSortedCollection at: p ceiling) - f) * (p fractionPart * d + c)) ]
	! !

!RSBoxPlot methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	| index |
	self checkAssertion.
	index := 1.
	bars := xValues flatCollect: [ :xt | 
		| bar |
		bar := self computeRectagleAndLinesFor: index.
		index := index + 1.
		bar ] as: RSGroup.
	canvas addAll: bars.

! !

!RSBoxPlot methodsFor: 'math functions' stamp: ''!
modeBased
	"Initialize the quantile calculation with this input"
	^ Array with: 1 with: -1 with: 0 with: 1! !

!RSBoxPlot methodsFor: 'accessing' stamp: ''!
bars
	^ bars! !

!RSBoxPlot methodsFor: 'initialization' stamp: ''!
defaultShape
	^ RSBox new noPaint! !

!RSBoxPlot methodsFor: 'accessing' stamp: ''!
gapRatio
	^ gapRatio! !

!RSBoxPlot methodsFor: 'accessing' stamp: ''!
barSize: aBarWidth
	"Set the width of the bar"
	barSize := aBarWidth! !

!RSBoxPlot methodsFor: 'rendering' stamp: ''!
definedValuesY
	"Return the list Y values that are defined"
	| res |
	res := yValues flatCollect: [ :i | i]. 
	^ res, {0}! !

!RSBoxPlot methodsFor: 'accessing' stamp: ''!
barSize
	"Return the width of each bar"
	^ barSize ifNil: [ self barScale rangeBand ]! !

!RSCairoCachedMetricsProvider commentStamp: ''!
I am a basic example of how to provide a text cache for roassal3 RSLabel text extent. But the idea is to use RSCairoMetricsProvider or RSCairoFitMetricsProvider. Only if you want speed for your labels

I use a Dictionary for each font, then for each font there is a new Dictionary where key is a char and value is the width of that char with that value.

This class allows us to use a cache and improve the speed of text calculation.

But it is not precise. There are some issues but in our benchmarks it shows a speed improvement.

Here an example

```Smalltalk
| c words mp can |
c := RSCanvas new.
words := String loremIpsum splitOn: ' '.
mp := RSCairoCachedMetricsProvider new.
"words ," #(
offic culp PŘÍLIŠ ŽLUŤOUČKÝ KŮN ÚPĚL ĎÁBELSKÉ ÓDY
ca caff Šca Šcaff Žca Žcaff Sca Scaff Zca Zcaff w . Ů) do: [ :word | 
	c add: (RSLabel new
		"fontName: 'Viner Hand ITC';"
		metricsProvider: mp;
		text: word;
		yourself)].
RSFlowLayout on: c nodes.
c showEncompassingRectangles.
can := RSCanvasController new.
can configuration maxScale: 40.
c @ can.
c
```!
!RSCairoCachedMetricsProvider methodsFor: 'initialization' stamp: ''!
initialize
	cache := Dictionary new.! !

!RSCairoCachedMetricsProvider methodsFor: 'hooks' stamp: ''!
dictionaryFor: font
	^ Dictionary new.
	! !

!RSCairoCachedMetricsProvider methodsFor: 'hooks' stamp: ''!
extentsOf: aRSLabel
	| map font h w |
	font := aRSLabel font.
	map := cache 
		at: font 
		ifAbsentPut: [ self dictionaryFor: font ].
	"this need to calculate the x_bearing and the kerning between characters"
	w := aRSLabel text 
		ifEmpty: [ 0 ]
	 	ifNotEmpty: [ (aRSLabel text
			collect: [ :char | self widthOf: char map: map font: font ] 
			as: Array) sum asFloat ].
	h := font getPreciseHeight asFloat.
	
	^ RSTextExtents new
		width: w;
		height: h;
		x_advance: 0;
		y_advance: 0;
		x_bearing: 0;
		y_bearing: font getPreciseAscent negated;
		yourself.
! !

!RSCairoCachedMetricsProvider methodsFor: 'hooks' stamp: ''!
widthOf: char map: map font: aLogicalFont
	^ map at: char
		ifAbsentPut: [ 
			| glyphs rawExt cairoFont |
			glyphs := CairoFontMetricsProvider new
				font: aLogicalFont;
				glyphsOf: char asString.
			rawExt := CairoTextExtents new.
			cairoFont := CairoScaledFont fromFreetypeFont: aLogicalFont asFreetypeFont.
			cairoFont getExtentsOfGlyphs: glyphs getHandle ofLength: glyphs size into: rawExt.
			rawExt x_advance
			].! !

!RSCairoFitMetricsProvider commentStamp: ''!
This provider uses the exact width and height of CairoFontMetricsProvider!
!RSCairoFitMetricsProvider methodsFor: 'hooks' stamp: ''!
extentsOf: aRSLabel
	| rawExt cairoFont glyphs |
	cairoFont := aRSLabel cairoFont.
	glyphs := aRSLabel cairoGlyphs.
	rawExt := CairoTextExtents new.
	cairoFont getExtentsOfGlyphs: glyphs getHandle ofLength: glyphs size into: rawExt.
	^ RSTextExtents new
		from: rawExt;
		yourself.! !

!RSCairoMetricsProvider commentStamp: ''!
This provider uses CairoFontMetricsProvider to calculate the width of text, but uses `font height` to calculate the height. It is the default metric profider used for labels.!
!RSCairoMetricsProvider methodsFor: 'hooks' stamp: ''!
extentsOf: aRSLabel
	| res font h |
	font := aRSLabel font.
	res := super extentsOf: aRSLabel.
	h := font getPreciseHeight asFloat.
	res
		height: h;
		y_bearing: font getPreciseAscent negated.
	^ res! !

!RSCamera commentStamp: ''!
<keyClass>
All shapes in Roassal are contained in a `RSCanvas`. The canvas has an infinite 2D dimension. The portion of the canvas that is visible within the window is given by a camera. `RSCamera` describes a camera in Roassal. A camera has a scale and a position.

*Responsibility*: identify the portion and the zoom level of a canvas that must be visible. Whenever the canvas is scrolled with the mouse or the key, then the camera is responsible for this.

*Collaborators*: A `RSCanvas` has a `RSCamera`. 

*Variables*:
`position` is a point representing coordinates of the canvas on which the viewing window frame will be centered. Position can be changes with the method `#translateBy:` and `#translateTo:`. Both methods accept canvas based coordinates

`scale` defines a magnitude of zooming applied to the canvas and its elements.

*Example*:
```Smalltalk
c := RSCanvas new.
1 to: 100 do: [ :i |
	| g |
	g := RSGroup new.
	g add: (RSEllipse new size: 30; color: Color gray lighter).
	g add: (RSLabel new text: i).
	c add: g asShape ].
RSGridLayout on: c shapes.
camera := c canvas camera.
camera translateBy: 500 @ 50.
camera scale: 0.5.
c
```!
!RSCamera methodsFor: 'accessing' stamp: ''!
position
	"Return the position of the camera. For example:
```
c := RSCanvas new.
c add: (RSEllipse new size: 30).
c camera translateBy: 25 @ 15.
c camera position
```

returns the value `25 @ 15`
"
	^ position! !

!RSCamera methodsFor: 'accessing' stamp: ''!
originMode 

	"#center or #topLeft"

	^ originMode! !

!RSCamera methodsFor: 'convertion' stamp: ''!
distanceFromPixelToSpace: aPoint
	^ (aPoint / self scale) asFloatPoint! !

!RSCamera methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	position := 0@0.
	scale := 1.0000001.
	originMode := #center.! !

!RSCamera methodsFor: 'convertion' stamp: ''!
fromPixelToSpace: aPoint

	^ AthensAffineTransform new
		translateBy: self position;
		scaleBy: 1 / self scale;
		translateBy: (self canvas extent / 2) negated;
		transform: aPoint! !

!RSCamera methodsFor: 'convertion' stamp: ''!
fromSpaceToPixel: aPoint

	^ AthensAffineTransform new
		translateBy: self canvas extent / 2;
		scaleBy: self scale;
		translateBy: self position negated;
		transform: aPoint
	! !

!RSCamera methodsFor: 'accessing' stamp: ''!
canvas: aCanvas
	canvas := aCanvas! !

!RSCamera methodsFor: 'actions' stamp: ''!
translateBy: deltaAsPoint
	"Move a shape by a delta value, expressed as a point"
	self translateTo: self position + deltaAsPoint
	! !

!RSCamera methodsFor: 'accessing' stamp: ''!
position: aPoint
	"Set the camera position"
 	position := aPoint! !

!RSCamera methodsFor: 'accessing' stamp: ''!
originMode: anObject

	originMode := anObject! !

!RSCamera methodsFor: 'zoom' stamp: ''!
zoomToFit
	self zoomToFit: canvas extent * 0.9! !

!RSCamera methodsFor: 'accessing' stamp: ''!
extent 

	^ extent! !

!RSCamera methodsFor: 'zoom' stamp: ''!
zoomToFit: anExtent extent: otherExtent
	self 
		zoomToFit: anExtent 
		rectangle: (Rectangle floatCenter: 0@0 extent: otherExtent)
	! !

!RSCamera methodsFor: 'private' stamp: ''!
privExtent: aRect

	extent := aRect! !

!RSCamera methodsFor: 'actions' stamp: ''!
translateTo: aPoint
	"Translate a shape to a new position, expressed as a point"
	| oldPosition |
	oldPosition := self position.
	oldPosition = aPoint ifTrue: [ ^ self ].
	self position: aPoint.
	self announce: [RSPositionChangedEvent new 
		shape: self; 
		oldPosition: oldPosition;
		newPosition: aPoint ].
! !

!RSCamera methodsFor: 'announce' stamp: ''!
announce: anEvent
	canvas announce: anEvent! !

!RSCamera methodsFor: 'accessing' stamp: ''!
scale
	^ scale! !

!RSCamera methodsFor: 'accessing' stamp: ''!
scale: aFloatNumber
	"Set the scaling factor applied by the camera. A factor of 1.0 means that no zooming is applied. if the factor is < 1, then the perceived effect is a zoom out. If the factor is > 1, then the effect is a zoom out."
	| oldScale |
	scale = aFloatNumber ifTrue: [ ^ self ].
	oldScale := scale.
	scale := aFloatNumber.
	self canvas announce: [ RSScaleChangedEvent new
		canvas: self canvas;
		oldScale: oldScale;
		newScale: aFloatNumber ]! !

!RSCamera methodsFor: 'accessing' stamp: ''!
visibleRectangle
	^ Rectangle 
		floatCenter: self position
		extent: self canvas extent / self scale.! !

!RSCamera methodsFor: 'zoom' stamp: ''!
zoomToFit: anExtent
	self 
		zoomToFit: anExtent 
		rectangle: canvas encompassingRectangle
	! !

!RSCamera methodsFor: 'accessing' stamp: ''!
canvas
	^ canvas! !

!RSCamera methodsFor: 'zoom' stamp: ''!
zoomToFit: anExtent rectangle: rect
	| sc |
	sc := anExtent / (self class maxExtentFor: rect).
	sc := sc x min: sc y.
	self 
		translateTo: rect floatCenter;
		scale: sc.! !

!RSCamera class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSCamera class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSCamera class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSCamera class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSCamera class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSCamera class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSCamera class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSCamera class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSCamera class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSCamera class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSCamera class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSCamera class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSCamera class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSCamera class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSCamera class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSCamera class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSCamera class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSCamera class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSCamera class methodsFor: 'utilities' stamp: ''!
maxExtentFor: rectangle
	^ rectangle extent max: self minimumExtent! !

!RSCamera class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSCamera class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSCamera class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSCamera class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RSCamera class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RSCamera class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RSCamera class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSCamera class methodsFor: 'utilities' stamp: ''!
minimumExtent
	^ 0.0001 asPoint! !

!RSCamera class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSCamera class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSCamera class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSCamera class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSCameraTest methodsFor: 'tests' stamp: ''!
testPosition

	| c |
	c := RSCanvas new.
	c add: (RSEllipse new size: 30).
	c camera translateBy: 25 @ 15.
	self assert: c camera position equals: 25 @ 15! !

!RSCanvas commentStamp: ''!
<keyClass>
Roassal keeps its shapes (i.e., instance of a subclass of `RSShape`) into a canvas. The class `RSCanvas` implements the Roassal canvas.

*Responsibility*: keep the (i) structure of the Roassal shapes (both fixed and non-fixed) and (ii) the animations. `RSCanvas` hides the creation of the `RSAthensMorph`.

*Collaborators*: This class is the entry point of Roassal. As soon as one wishes to use Roassal, she has to go through a canvas.

*Variables*:
- `shapes` keeps a collection of shapes (i.e., instance of a subclass of `RSShape`) as an instance of `RSGroup`. Shapes contained in `shapes` are considered as non-fixed, which means that they are subject to the camera.
- `fixedShapes` is an instance of `RSGroup` that contains "fixed" shapes. A fixed shape is a shape that is not subject to the state of the camera. A fixed shape remains at the same position, independently if the canvas is scrolled.
- `color` is an instance of the Pharo class `Color` and is used to paint the background.
- `morph` refers to an instance of the class `RSAthensMorph`, which is the object that intersects Roassal and Morphic.
- `camera` refers to the camera of the canvas.
- `clearBackground` is a boolean indicating whether the background must be cleared at each refresh. This is useful sometime to obtain some interesting visual effects.

*Example*:
```Smalltalk
c := RSCanvas new.
c add: (RSLabel new text: 'Hello from Roassal').
c
```!
!RSCanvas methodsFor: 'accessing' stamp: ''!
color: aColor
	"Set the color of the canvas background.

```Smalltalk
c := RSCanvas new .
c color: Color blue.
c add: (RSBox new size: 30; color: #red).
c
```
"
	color := aColor.
	color isColor ifTrue: [ ^ self ].
	color := Color colorFrom: aColor.! !

!RSCanvas methodsFor: 'looking up shapes' stamp: ''!
deepShapeFromModel: anObject result: result
	"Private method"
	| t |
	t := self shapeFromModel: anObject.
	t ifNotNil: [ result add: t ].
	self nodes do: [ :c | c deepShapeFromModel: anObject result: result ]! !

!RSCanvas methodsFor: 'adding nodes edges' stamp: ''!
addLine: aShape
	self lines add: aShape.
	^ aShape! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
children
	^ self nodes! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
deepNodes
	"Return the list of all the nodes contained in the visualization"
	| result |
	result := OrderedCollection new. 
	self nodes do: [ :n |
		n addRecursivelyIn: result ].
	^ result! !

!RSCanvas methodsFor: 'camera' stamp: ''!
zoomToFit
	"Adjust the camera to make all the displayed shapes visible.

```Smalltalk
	c := RSCanvas new.

	blueBox := RSBox new
		          size: 80;
		          color: #blue.
	redBox := RSBox new
		          size: 80;
		          color: #red.

	c
		add: blueBox;
		add: redBox.
	blueBox translateBy: 40 @ 20.
	c zoomToFit
```
"
	self camera zoomToFit! !

!RSCanvas methodsFor: '*Roassal3-Animation' stamp: ''!
animationFrom: array
	^ self compositeAnimation: self sequentialAnimation from: array! !

!RSCanvas methodsFor: 'private' stamp: ''!
createMorph
	"Create a Morph that contains myself. This is a private method"
	morph := RSAthensMorph new. 
	morph renderer: RSAthensRenderer new.
	morph canvas: self.
	^ morph! !

!RSCanvas methodsFor: 'debug support' stamp: ''!
hideEncompassingRectangles
	showRectangles := false.! !

!RSCanvas methodsFor: 'matrix' stamp: ''!
globalMatrix
	^ AthensAffineTransform new! !

!RSCanvas methodsFor: 'private' stamp: ''!
privateEdges: aTSGroup
	edges := aTSGroup! !

!RSCanvas methodsFor: '*Roassal3-Animation' stamp: ''!
currentTime
	^ self timer currentTime.
	! !

!RSCanvas methodsFor: 'looking up shapes' stamp: ''!
deepShapeFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"
	| result |
	result := RSGroup new.
	self deepShapeFromModel: anObject result: result.
	result isEmpty ifTrue: [ ^ nil ].
	^ result first! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
topParent
	"A top parent is a canvas"
	^ self! !

!RSCanvas methodsFor: 'private' stamp: ''!
privateNodes
	^ nodes! !

!RSCanvas methodsFor: 'animations' stamp: ''!
animations
	^ animations! !

!RSCanvas methodsFor: 'debug support' stamp: ''!
showEncompassingRectangles
	showRectangles := true.! !

!RSCanvas methodsFor: '*Roassal3-Shapes' stamp: ''!
asShapeModel: aModelObject
	"Convert a canvas as a composite shape. Note that all the shapes are removed from the canvas after the convertion. Attach a model to the composite shape. Here is an example:
	
Another example:
```
g1 := RSChart new.
p1 := RSLinePlot new.
p1 y: #(5 10 3 -4 -5 15).
g1 addPlot: p1.
g1 addDecoration: (RSXLabelDecoration new title: 'Time'; offset: 0 @ 10).
g1 addDecoration: (RSYLabelDecoration new title: 'Value'; offset: -20 @ 0).
g1 addDecoration: (RSHorizontalTick new).
g1 addDecoration: (RSVerticalTick new).
g1 build.

g2 := RSChart new.
p2 := RSLinePlot new.
p2 y: #(2 10 50 -20 40 30 25 12 4).
g2 addPlot: p2.
g2 addDecoration: (RSXLabelDecoration new title: 'Time'; offset: 0 @ 10).
g2 addDecoration: (RSYLabelDecoration new title: 'Value'; offset: -20 @ 0).
g2 addDecoration: (RSHorizontalTick new).
g2 addDecoration: (RSVerticalTick new).
g2 build.

c := RSCanvas new.
c add: (g1 canvas asShapeModel: 1).
c add: (g2 canvas asShapeModel: 2).
RSHorizontalLineLayout on: c shapes.

c shapes @ RSDraggable.

lb := RSLineBuilder arrowedLine.
lb withBorderAttachPoint.
lb canvas: c.
lb useAssociation: 1 -> 2.

c @ RSCanvasController.
c
```
	"
	^ self asShape model: aModelObject! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
shapes
	"Return all the shapes added to the canvas. An empty canvas would return an empty collection.
	
For example
```Smalltalk
s1 := RSBox new.
s2 := RSEllipse new.
c := RSCanvas new.
c add: s1; add: s2.
```
The expression `c shapes` returns a `RSGroup` containing both `s1` and `s2`
"
	^ shapes copy! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
extent
	^ extent! !

!RSCanvas methodsFor: 'updating' stamp: ''!
signalUpdate
	"Signal a platform signal that the canvas should be refreshed. This is important when some shapes are modified (color or position)."
	morph changed! !

!RSCanvas methodsFor: 'camera' stamp: ''!
camera
	"Return the camera used by the canvas:

For example:
```Smalltalk
c := RSCanvas new.
(1 to: 10) do: [ :i | c add: (RSEllipse new size: 20) ]. 
RSGridLayout on: c shapes.
c camera translateBy: -30 @ 50.
c 
```"
	^ camera! !

!RSCanvas methodsFor: '*Roassal3-Interaction' stamp: ''!
controllerInteraction
	^ self propertyAt: RSCanvasController! !

!RSCanvas methodsFor: 'adding' stamp: ''!
addShape: aShape
	aShape addedIn: self! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
lines
	"Return all the lines contained in the canvas."
	^ self privateEdges
		ifNil: [ | res |
			self privateEdges: (res := RSGroup new).
			res ]! !

!RSCanvas methodsFor: '*Roassal3-Animation' stamp: ''!
sequentialAnimation 
	^ RSSequentialAnimation new! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
color 
	"Return the color of the canvas background"
	^ color! !

!RSCanvas methodsFor: 'adding - nodes edges' stamp: ''!
add: aShape
	"Main method to add a shape to a shape to a canvas"
	self
		assert: aShape notNil
		description: 'Nil cannot be added to a canvas'.
		
	self 
		assert: (aShape class inheritsFrom: RSShape)
		description: 'A shape must be provided'.
	aShape 
		addedIn: self;
		renderOn: self.
	^ aShape! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
basicRectangle
	"Return a rectangle encompassing all the elements"
	^ Rectangle origin: 0@0 extent: self extent! !

!RSCanvas methodsFor: 'accessing - computed' stamp: ''!
numberOfDeepNodes
	^ self deepNodes size! !

!RSCanvas methodsFor: 'opening' stamp: ''!
open
	^ self openWithTitle: 'Roassal'! !

!RSCanvas methodsFor: 'looking up shapes' stamp: ''!
shapesFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"

	^ self nodes shapesFromModel: anObject! !

!RSCanvas methodsFor: 'opening' stamp: ''!
openOnce
	^ self openOnceWithTitle: 'Roassal'! !

!RSCanvas methodsFor: '*Roassal3-Inspector' stamp: ''!
gtInspectorViewIn: composite
	<gtInspectorPresentationOrder: -10>
	composite roassal3
		title: ['Canvas'];
		initializeCanvas: [ self ]
		! !

!RSCanvas methodsFor: 'accessing - shapes' stamp: ''!
shapesFromModels: objects
	"Return shapes that corresponds to the objects provided as parameter. If none is found, then return an empty collection"
	^ self nodes shapesFromModels: objects
! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
parent
	"A canvas has no parent. Shapes may have a parent other than the canvas when they are nested"
	^ self! !

!RSCanvas methodsFor: 'animations' stamp: ''!
hasAnimation
	"True if at least one animation is running"
	^ animations notEmpty! !

!RSCanvas methodsFor: 'adding - removing shapes' stamp: ''!
addBasicShape: aShape
	shapes add: aShape! !

!RSCanvas methodsFor: 'opening' stamp: ''!
openOnceWithTitle: aTitle
	"Open a visualization and record the position. When #openOnce is called a second time,
	the new window replace the previous one, at the recorded position. This method is useful when 
	demoing and scripting. Return the open window"
	| bounds win |
	bounds := nil. 
	Smalltalk at: #previousWindow ifPresent: [ :w | bounds := w bounds. w close ].
	win := self openWithTitle: aTitle.
	Smalltalk at: #previousWindow put: win.
	bounds ifNotNil: [
		win bounds: bounds ].
	^ win! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
canvas
	"Useful method to have it polymorphic with shapes"
	^ self! !

!RSCanvas methodsFor: 'adding - removing shapes' stamp: ''!
setAsFixed: aShape
	self removeShape: aShape.
	aShape isFixed: true.
	self addShape: aShape.
	! !

!RSCanvas methodsFor: 'shapes ordering' stamp: ''!
pushBack: aShape
	"Shapes are ordered in the same order they are inserted. The order can be changed using #pushFront: and #pushBack.

For example:
```Smalltalk
c := RSCanvas new.
shape1 := RSEllipse new size: 50; color: #red.
shape2 := RSEllipse new size: 50; color: #blue.
shape2 translateBy: -25@0.
c add: shape1; add: shape2.
c pushBack: shape2.
c.
```	
"
	| col |
	col := aShape isFixed 
		ifTrue: [ fixedShapes ]
		ifFalse: [ shapes ].
	col 
		remove: aShape;
		addFirst: aShape.! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
nodes 
	"Return all the shapes except lines contained in the canvas."
	^ self privateNodes
		ifNil: [ | res |
			self privateNodes: (res := RSGroup new).
			res ]! !

!RSCanvas methodsFor: 'adding' stamp: ''!
addAllShapes: aCollection
	self assert: [ aCollection isCollection ] description: 'Need to provide a collection as argument'.
	self assert: [ aCollection allSatisfy: [ :e | e isKindOf: RSShape ] ] description: 'Need to provide a collection of RSShape'.
	aCollection do: [ :shape | self addShape: shape ].! !

!RSCanvas methodsFor: '*Roassal3-Inspector' stamp: ''!
inspectorCanvas
	<inspectorPresentationOrder: 90 title: 'Canvas'>
	^ SpRoassal3InspectorPresenter new
		canvas: self;
		yourself! !

!RSCanvas methodsFor: '*Roassal3-Interaction' stamp: ''!
controllerInteraction: aCanvasController
	self propertyAt: RSCanvasController put: aCanvasController! !

!RSCanvas methodsFor: '*Roassal3-Inspector' stamp: ''!
inspectorContext
	"Return the context used in the canvas. The inspector context contains all the registration that is added to a canvas per default, when being used in the GTInspector. Registrations can be easily diseabled, for example, in case one wishes to disable the opening of a new inspector pane by clicking on an object using:
```
c inspectorContext interactionsToBeRegistered removeAll.
```
`c`, being a canvas.

Here is an example:
```
c := RSCanvas new.
c addAll: ((1 to: 10) collect: [ :n | RSEllipse new size: 20; model: n ]).
RSFlowLayout on: c nodes.
c inspectorContext interactionsToBeRegistered removeAll.
c
```
In the example given above, clicking on a circle does not open a new pane in the GT inspector.
	"
	^ self
		propertyAt: RSAbstractContextInteraction name asSymbol
		ifAbsentPut: [ RSContextInteraction new ]! !

!RSCanvas methodsFor: '*Roassal3-Animation' stamp: ''!
transitionAnimation 
	^ RSTransitionAnimation new! !

!RSCanvas methodsFor: 'adding nodes edges' stamp: ''!
addAll: aCollection
	"Add a collection of shapes to the canvas. The argument is a collection of shapes."
	self assert: [ aCollection isCollection ] description: 'Need to provide a collection as argument'.
	self assert: [ aCollection allSatisfy: [ :e | e isKindOf: RSShape ] ] description: 'Need to provide a collection of RSShape'.
	
	"Add each shape"
	aCollection do: [ :aShape | self add: aShape ]! !

!RSCanvas methodsFor: '*Roassal3-Animation' stamp: ''!
timer
	^ self propertyAt: #timer ifAbsentPut: [ RSDefaultTimer new ].! !

!RSCanvas methodsFor: 'visiting' stamp: ''!
accept: visitor
	visitor visitCanvas: self! !

!RSCanvas methodsFor: '*Roassal3-Animation' stamp: ''!
newAnimation
	"Define a new transition animation, schedule it, and return it (useful to tune it).

-=-==-=-=-=
	c := RSCanvas new.
	b := RSBox new
		extent: 100@100;
		withBorder.
	c add: b.
	c newAnimation
			from: -100 @ -100;
			to: 100 @ 100;
			on: b set: #position:.
	c
-=-==-=-=-=
		
	"
	| anime |
	anime := self transitionAnimation.
	self addAnimation: anime.
	^ anime! !

!RSCanvas methodsFor: 'camera' stamp: ''!
camera: aCamera
	"Set a new camera for the canvas."
	camera := aCamera! !

!RSCanvas methodsFor: 'accessing - shapes' stamp: ''!
shapeWithActionForPositionInPixels: position
	"position is in pixel, it corresponds to the physical location in the window.
	e.g., 0 @ 0 is top left of the window"
	| block |
	block := [ :list :pos |
		list reverseDo: [ :s | | shape |
			shape := s shapeWithActionForPosition: pos.
			shape ifNotNil: [^ shape ] ] ].
	block value: fixedShapes value: position.
	block value: shapes value: (self camera fromPixelToSpace: position).
	^ self
	! !

!RSCanvas methodsFor: 'testing' stamp: ''!
showRectangles
	^ showRectangles! !

!RSCanvas methodsFor: 'removing' stamp: ''!
removeEdge: anEdge
	self edges remove: anEdge ifAbsent: [  ].! !

!RSCanvas methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModels: someObjects
	"Retreive a shape from a given model. Return nil if not found"
	| result |
	result := RSGroup new.
	self deepShapesFromModels: someObjects result: result.
	^ result! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
morph
	"Return the Athens morph used by the canvas to render the visualization"
	^ morph! !

!RSCanvas methodsFor: 'actions' stamp: ''!
pushBackEdges
	"Push back all the edges"
	self edges do: [ :e | e pushBack ]! !

!RSCanvas methodsFor: 'private' stamp: ''!
privateEdges
	^ edges! !

!RSCanvas methodsFor: 'announcer' stamp: ''!
announce: anEventOrAnEventClass
	"Send an event"
	| theEventToSend |
	announcer ifNil: [ ^ self ].
	theEventToSend := anEventOrAnEventClass value asAnnouncement.
	theEventToSend canvas: self.
	announcer announce: theEventToSend.! !

!RSCanvas methodsFor: 'private' stamp: ''!
privateShapes: aCollection
	shapes := aCollection! !

!RSCanvas methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModel: someObjects result: result
	"Private method"
	self nodes do: [ :c | c deepShapesFromModel: someObjects result: result ]! !

!RSCanvas methodsFor: 'adding nodes edges' stamp: ''!
addNode: aShape
	self nodes add: aShape.
	^ aShape! !

!RSCanvas methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"
	| result |
	result := RSGroup new.
	self deepShapesFromModel: anObject result: result.
	^ result! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
allChildren
	| allChildren index |
	index := 1.
	allChildren := OrderedCollection withAll: self children.
	[ index <= allChildren size ] whileTrue: [ 
		allChildren addAll: ((allChildren at: index) children ifNil: [#()]).
		index := index + 1 ].
	^ allChildren! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
fixedShapes: aCollection 
	fixedShapes := aCollection! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
fixedShapes
	"Return the list of shapes that are fixed, i.e., not subjet to the camera"
	^ fixedShapes ! !

!RSCanvas methodsFor: 'testing' stamp: ''!
isShape
	"Useful to lookup the canvas in a hierarchy of nested shapes"
	^ false! !

!RSCanvas methodsFor: 'adding - removing shapes' stamp: ''!
addFixedShape: aShape
	"This is a private method. Should not be called directly (use RSShape>>setAsFixed instead). 
Add a shape and make the shape fixed. It is therefore not subject to the camera.
```
c := RSCanvas new.

lbl := RSLabel text: 'Fixed Label'.
c addFixedShape: lbl.
lbl translateBy: 100 @ 20.

lbl := RSLabel text: 'Unfixed Label'.
c addShape: lbl.

c @ RSCanvasController.
```
"
	fixedShapes add: aShape! !

!RSCanvas methodsFor: 'adding - removing shapes' stamp: ''!
removeShape: shape
	| evt index |
	index := shapes indexOf: shape.
	index = 0 
		ifTrue: [ index := fixedShapes indexOf: shape.
			index = 0 ifFalse: [ fixedShapes remove: shape ] ]
		ifFalse: [ shapes removeAt: index ].
	
	shape parent: nil.
	evt := RSShapeRemovedEvent new shape: shape.
	self announce: evt.
	shape announce: evt.
	! !

!RSCanvas methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	showRectangles := false.
	shapes := RSGroup new.
	fixedShapes := RSGroup new.
	nodes := RSGroup new.
	edges := RSGroup new.
	animations := OrderedCollection new.
	clearBackground := true.
	color := Color white.
	extent := 500@500.
	camera := RSCamera new
		canvas: self;
		yourself.! !

!RSCanvas methodsFor: 'adding nodes edges' stamp: ''!
addEdge: aShape
	self edges add: aShape.
	^ aShape! !

!RSCanvas methodsFor: '*Roassal3-Animation' stamp: ''!
parallelAnimation 
	^ RSParallelAnimation new! !

!RSCanvas methodsFor: 'accessing - computed' stamp: ''!
encompassingRectangleOf: aCollectionOfShapes
	| r |
	r := aCollectionOfShapes
		ifEmpty: [ 0@0 corner: 0@0 ]
		ifNotEmpty: [ Rectangle 
			merging: (aCollectionOfShapes 
				collect: [:each | each encompassingRectangle] ) ].
	^ r topLeft extent: (self camera class maxExtentFor: r)! !

!RSCanvas methodsFor: 'animations' stamp: ''!
addAnimation: anAnimation
	"Schedule an animation, and run it until its completion"
	animations add: anAnimation.
	anAnimation canvas: self.
	anAnimation start.
	self signalUpdate! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
morph: aMorph
	"Set the RSAthensMorph. The canvas will directly render in the morph"
	morph := aMorph! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
numberOfNodes
	"Return the number of nodes contained in the container"
	^ self privateNodes
		ifNil: [ 0 ]
		ifNotNil: [ :aGroupOfNodes | aGroupOfNodes size ]! !

!RSCanvas methodsFor: 'private' stamp: ''!
privExtent: aRect

	extent := aRect! !

!RSCanvas methodsFor: 'accessing - computed' stamp: ''!
encompassingRectangle
	^ self encompassingRectangleOf: shapes! !

!RSCanvas methodsFor: '*Roassal3-Shapes' stamp: ''!
asShape
	"Convert a canvas as a composite shape. Note that all the shapes are removed from the canvas after the convertion. Here is an example:
	
```
canvas := RSCanvas new.
5 timesRepeat: [ 
	tmpCanvas := RSCanvas new.
	someShapes := RSCircle models: (1 to: 50) forEach: [ :s :e | s size: 10 ].
	tmpCanvas addAll: someShapes.
	RSGridLayout on: tmpCanvas shapes.
	tmpCanvas shapes color: Color random translucent.
	canvas add: tmpCanvas asShape.
].

RSGridLayout on: canvas shapes.
canvas @ RSCanvasController
```

Another example:
```
g1 := RSChart new.
p1 := RSLinePlot new.
p1 y: #(5 10 3 -4 -5 15).
g1 addPlot: p1.
g1 addDecoration: (RSXLabelDecoration new title: 'Time'; offset: 0 @ 10).
g1 addDecoration: (RSYLabelDecoration new title: 'Value'; offset: -20 @ 0).
g1 addDecoration: (RSHorizontalTick new).
g1 addDecoration: (RSVerticalTick new).
g1 build.

g2 := RSChart new.
p2 := RSLinePlot new.
p2 y: #(2 10 50 -20 40 30 25 12 4).
g2 addPlot: p2.
g2 addDecoration: (RSXLabelDecoration new title: 'Time'; offset: 0 @ 10).
g2 addDecoration: (RSYLabelDecoration new title: 'Value'; offset: -20 @ 0).
g2 addDecoration: (RSHorizontalTick new).
g2 addDecoration: (RSVerticalTick new).
g2 build.

c := RSCanvas new.
c add: (g1 canvas asShape).
c add: (g2 canvas asShape).
RSHorizontalLineLayout on: c shapes.
c @ RSCanvasController.
c
```
	"
	| g |
	g := self shapes copy.
	g do: #remove.
	^ RSComposite new
		shapes: g;
		yourself.
	! !

!RSCanvas methodsFor: 'accessing - computed' stamp: ''!
transform: aPoint
	^ aPoint! !

!RSCanvas methodsFor: 'accessing - computed' stamp: ''!
visibleRectangle
	^ self camera visibleRectangle! !

!RSCanvas methodsFor: '*Roassal3-Animation' stamp: ''!
compositeAnimation: aRSCompositeAnimation from: array
	aRSCompositeAnimation addAll: array.
	self addAnimation: aRSCompositeAnimation.
	^ aRSCompositeAnimation
	! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
clearBackground: aBool
	"Determine if the canvas must be cleaned at each screen refresh. Per default it is, which means that if some shapes are translated, a footprint is left. This is useful to realize interesting visual effects.
	
For example, evaluate the following script:
```
c := RSCanvas new.
c clearBackground: false.
(1 to: 10) do: [ :i | c add: (RSEllipse new size: 20) ]. 
RSGridLayout on: c shapes.
c.
```

And execute the expression `c camera translateBy: 1 @ 1.`

"
	clearBackground := aBool! !

!RSCanvas methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModels: someObjects result: result
	"Private method"
	self nodes do: [ :c | c deepShapesFromModels: someObjects result: result ]! !

!RSCanvas methodsFor: 'testing' stamp: ''!
clearBackground
	"Return whether the screen must be cleaned at each screen refresh"
	^ clearBackground! !

!RSCanvas methodsFor: 'accessing - shapes' stamp: ''!
shapeWithAction: eventClass forPositionInPixels: position
	"position is in pixel, it corresponds to the physical location in the window.
	e.g., 0 @ 0 is top left of the window"
	| block |
	block := [ :list :pos| 
		list reverseDo: [ :s | | shape |
			shape := s shapeWithAction: eventClass forPosition: pos.
			shape ifNotNil: [ ^ shape ] ] ].
	block value: fixedShapes value: position.
	block value: shapes value: (self camera fromPixelToSpace: position).
	^ self! !

!RSCanvas methodsFor: '*Roassal3-Inspector' stamp: ''!
gtInspectorShapesIn: composite
	<gtInspectorPresentationOrder: 20>
	composite table 
		title: 'Shapes';
		showOnly: 50;
		display: [ :each | each shapes ];
		children: #children;
		column: 'Shape' evaluated: [ :each | each asString ];
		column: 'Model' evaluated: [ :each | each model asString ];
		column: 'Paint' evaluated: [ :each | each paint asString ];
		column: 'Border' evaluated: [ :each | each border asString ].! !

!RSCanvas methodsFor: 'looking up shapes' stamp: ''!
shapeFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"

	^ self nodes shapeFromModel: anObject! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
numberOfFixedShapes
	"Return the number of fixed shapes"
	^ fixedShapes size! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
numberOfEdges
	"Return the number of edges contained in the container"
	^ self privateEdges
		ifNil: [ 0 ]
		ifNotNil: [ :aGroupOfEdges | aGroupOfEdges size ]! !

!RSCanvas methodsFor: '*Roassal3-Inspector' stamp: ''!
inspectorCanvasContext: aContext
  
  aContext withoutEvaluator! !

!RSCanvas methodsFor: 'animations' stamp: ''!
numberOfAnimations
	"Return the number of animations contained in the canvas"
	^ animations size! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
edges
	"Return all the lines contained in the canvas."
	^ self privateEdges
		ifNil: [ | res |
			self privateEdges: (res := RSGroup new).
			res ]! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
extent: aPoint
	"Set the extent of the canvas. This method is called when a window is resized. An event is raised when the extension happens. "
	| evt |
	evt := RSExtentChangedEvent new
		shape: self;
		oldExtent: extent;
		newExtent: (extent := aPoint).
	self announce: evt! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
withAllChildren
	^ self allChildren
		add: self;
		yourself! !

!RSCanvas methodsFor: 'opening' stamp: ''!
openWithTitle: aTitleAsString
	"Open a canvas with a given title"
	| window |
	self createMorph.
	window := morph openInWindowLabeled: aTitleAsString.
	window extent: 500 @ 500.
	morph privateOwner: window.
	^ window
	! !

!RSCanvas methodsFor: '*Roassal3-Animation' stamp: ''!
parallelAnimationFrom: array
	^ self compositeAnimation: self parallelAnimation from: array
	! !

!RSCanvas methodsFor: 'private' stamp: ''!
privateShapes
	^ shapes! !

!RSCanvas methodsFor: 'removing' stamp: ''!
removeNode: aNode
	self nodes remove: aNode ifAbsent: [  ].! !

!RSCanvas methodsFor: 'accessing' stamp: ''!
numberOfShapes
	"Return the number of non-fixed shapes"
	^ shapes size! !

!RSCanvas methodsFor: 'shapes ordering' stamp: ''!
pushFront: aShape
	"Shapes are ordered in the same order they are inserted. The order can be changed using #pushFront: and #pushBack.

For example:
```Smalltalk
c := RSCanvas new.
shape1 := RSEllipse new size: 50; color: #red.
shape2 := RSEllipse new size: 50; color: #blue.
shape2 translateBy: -25@0.
c add: shape1; add: shape2.
c pushFront: shape1.
c.
```
The red circle is in front of the blue one, despite the red one is inserted first.
"
	| col |
	col := aShape isFixed 
		ifTrue: [ fixedShapes ]
		ifFalse: [ shapes ].
	col 
		remove: aShape ifAbsent: [];
		addLast: aShape.! !

!RSCanvas methodsFor: '*Roassal3-Inspector' stamp: ''!
inspectorShapes
	<inspectorPresentationOrder: 100 title: 'Shapes'>
	^ SpTablePresenter new
		items: self shapes, self fixedShapes;
		addColumn: (SpStringTableColumn 
			title: 'Shape'
			evaluated: [ :each | each asString ] );
		addColumn: (SpStringTableColumn 
			title: 'Model'
			evaluated: [ :each | each model asString ] );
		addColumn: (SpStringTableColumn 
			title: 'Paint'
			evaluated: [ :each | each paint asString ] );
		addColumn: (SpStringTableColumn 
			title: 'Border'
			evaluated: [ :each | each border asString ] )! !

!RSCanvas methodsFor: 'announcer' stamp: ''!
announcementClasses
	^ {RSCanvasEvent. RSShapeEvent} 
		flatCollect: [ :cls | 
			cls withAllSubclasses reject: [ :subcls|
				subcls hasSubclasses ] ]! !

!RSCanvas methodsFor: '*Roassal3-Inspector' stamp: ''!
inspectorContext: aRSContext
	^ self
		propertyAt: RSAbstractContextInteraction name asSymbol
		put: aRSContext! !

!RSCanvas methodsFor: 'adding - removing shapes' stamp: ''!
addShape: aShape before: otherShape
	aShape addedIn: self.
	shapes remove: aShape.
	shapes add: aShape before: otherShape.! !

!RSCanvas methodsFor: 'private' stamp: ''!
privateNodes: aTSGroup
	nodes := aTSGroup! !

!RSCanvas methodsFor: 'animations' stamp: ''!
playAnimations
	| shouldClean |
	shouldClean := false.
	animations do: [ :animation | 
		animation refresh. 
		animation hasCompleted
			ifTrue: [ shouldClean := true. ] ].
	shouldClean ifTrue: [ 
		animations copy do: [ :animation |
			animation hasCompleted ifTrue: [ animation remove ] ] ].! !

!RSCanvas methodsFor: '*Roassal3-Animation' stamp: ''!
timer: aRSAbstractTimer
	self propertyAt: #timer put: aRSAbstractTimer! !

!RSCanvas methodsFor: 'animations' stamp: ''!
hasAnimation: anAnimation
	"True if anAnimation is running"
	^ animations includes: anAnimation! !

!RSCanvas methodsFor: 'adding - removing shapes' stamp: ''!
removeFixedShape: aShape
	fixedShapes remove: aShape! !

!RSCanvasController commentStamp: ''!
I the main interaction that handles roassal3 general control about a view.
I interact with the Abstract class RSAbstractControlView. I creates instances of all subclasses of RSAbstractControlsView !
!RSCanvasController methodsFor: 'configuration' stamp: ''!
noLegend
	withLegend := false! !

!RSCanvasController methodsFor: 'testing' stamp: ''!
shouldShowLegend
	^ withLegend! !

!RSCanvasController methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self interactions: (self defaultInteractions collect: #new).
	self
		withLegend;
		configuration: RSControlConfiguration new.! !

!RSCanvasController methodsFor: 'accessing' stamp: ''!
addInteraction: anInteractionObject

	self interactions: (self interactions, (Array with: anInteractionObject class -> anInteractionObject)).
	anInteractionObject configuration: configuration! !

!RSCanvasController methodsFor: 'initialization' stamp: ''!
defaultInteractions
	"create a subclass of RSControslView and define your own custom interactions for your canvas"
	^ { RSDraggableCanvasInteraction. RSKeyNavigationCanvasInteraction. RSZoomToFitCanvasInteraction. RSZoomableCanvasInteraction. RSScrollBarsCanvasInteraction . RSSearchInCanvasInteraction }! !

!RSCanvasController methodsFor: 'accessing' stamp: ''!
configuration
	^ configuration! !

!RSCanvasController methodsFor: 'accessing' stamp: ''!
addInteractionClass: anInteractionClass
	"This method is commanded for public use."
	self addInteraction: anInteractionClass new! !

!RSCanvasController methodsFor: 'configuration' stamp: ''!
withLegend
	withLegend := true! !

!RSCanvasController methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	aCanvas controllerInteraction ifNotNil: [ ^ self ].
	aCanvas controllerInteraction: self.
	self interactions do: [ :int | int onShape: aCanvas ].
	self renderLegendOn: aCanvas.
	! !

!RSCanvasController methodsFor: 'accessing' stamp: ''!
configuration: aRSControlLimits
	configuration := aRSControlLimits.
	self interactions do: [ :i | i configuration: configuration ].! !

!RSCanvasController methodsFor: 'accessing' stamp: ''!
interactions: aCollectionOfInteractions
	interactions := OrderedDictionary new.
	aCollectionOfInteractions do: [ :int |
		interactions at: int class put: int ].
	! !

!RSCanvasController methodsFor: 'accessing' stamp: ''!
interactions
	^ interactions! !

!RSCanvasController methodsFor: 'hooks' stamp: ''!
renderLegendOn: aCanvas
	| lb |
	self shouldShowLegend ifFalse: [ ^ self ].
	lb := RSLegend new 
		container: aCanvas;
		yourself.
	lb defaultTitle fontSize: 12.
	lb defaultLabel fontSize: 10.
	lb defaultBoldText fontSize: 10.
	lb legendDo: [ :l |
		l 
			border: RSBorder new;
			color: (Color white alpha: 0.8);
			padding: 10.
		].
	lb title: 'Shortcuts'.
	self interactions do: [ :int | int renderLegendOn: lb ].
	lb onDemand.
	lb build.! !

!RSCanvasEvent commentStamp: ''!
I am top class for canvas event!
!RSCanvasTest commentStamp: ''!
I have common tests for shapes and canvas!
!RSCanvasTest methodsFor: 'tests - shapes ordering' stamp: ''!
testPushBackEdges

	| c blueBox redBox l |
	c := RSCanvas new.

	blueBox := RSBox new
		          size: 80;
		          color: #blue.
	redBox := RSBox new
		          size: 80;
		          color: #red.

	c
		add: blueBox;
		add: redBox.
	blueBox translateBy: 40 @ 20.
	
	l := RSLine new from: blueBox; to: redBox.
	c add: l.
	
	self assert: c shapes asArray equals: { blueBox . redBox . l }.
	
	c pushBackEdges.
	self assert: c shapes asArray equals: { l . blueBox . redBox }.
	! !

!RSCanvasTest methodsFor: 'tests' stamp: ''!
testEncompassingRectangle
	| rect |
	rect := canvas encompassingRectangle.
	self assert: rect equals: (Rectangle center: 0@0 extent: RSCamera minimumExtent).
	
! !

!RSCanvasTest methodsFor: 'tests - shapes ordering' stamp: ''!
testAddShapeBefore
	| shape1 shape2 |
	shape1 := RSBox new size: 20.
	shape2 := RSEllipse new size: 10.
	
	canvas add: shape2.
	canvas addShape: shape1 before: shape2.
	self assert: canvas shapes asArray equals: { shape1 . shape2 }! !

!RSCanvasTest methodsFor: 'running' stamp: ''!
testEmpty
	self assert: canvas numberOfShapes equals: 0! !

!RSCanvasTest methodsFor: 'tests - composite' stamp: ''!
testNestedShapeNotAddedToACanvas

	| shape innerShape |
	shape := RSComposite new.
	innerShape := RSBox new.
	shape add: innerShape.
	
	self assert: shape canvas isNil.
	self assert: innerShape parent equals: shape.
	self assert: innerShape canvas isNil.
	! !

!RSCanvasTest methodsFor: 'running' stamp: ''!
testNodesShapesAndEdges
	| n1 n2 n3 eb nodes |
	n1 := RSEllipse new size: 10; model: 1.
	n2 := RSEllipse new size: 10; model: 2.
	n3 := RSEllipse new size: 10; model: 3.
	nodes := Array with: n1 with: n2 with: n3.
	canvas addAll: nodes.
	eb := RSLineBuilder line.
	eb canvas: canvas.
	eb useAssociations: (Array with: (1 -> 2) with: (2 -> 3) with: (3 -> 1)).
	self assert: canvas shapes size equals: 6.
	self assert: (canvas shapes includesAll: nodes).

	self assert: canvas nodes equals: nodes asGroup.
	self assert: canvas edges size equals: 3.! !

!RSCanvasTest methodsFor: 'tests - composite' stamp: ''!
testShapeFromModelAndComposite2

	| compo compo2 compo3 |
	compo := RSComposite new.
	compo add: (RSBox new size: 20; model: 42).
	compo model: 41.
	canvas add: compo.
	
	compo2 := RSComposite new.
	compo2 add: (RSBox new size: 20; model: 42).
	compo2 model: 41.
	canvas add: compo2.
	
	compo3 := RSComposite new.
	compo3 add: (RSBox new size: 20; model: 2).
	compo3 model: 1.
	canvas add: compo3.
	
	self assert: canvas numberOfShapes equals: 3.
	self assert: (canvas shapesFromModel: 41) asArray equals: { compo . compo2 }.
	self assert: (canvas shapesFromModel: 42) isEmpty.
	
	self assert: (canvas deepShapesFromModel: 41) asArray equals: { compo . compo2 }.
	self assert: (canvas deepShapesFromModel: 42) asArray equals: { compo children first . compo2 children first }. 
	
	self assert: (canvas deepShapesFromModel: 2) asArray equals: { compo3 children first }! !

!RSCanvasTest methodsFor: 'tests' stamp: ''!
testEventKnowsItsCanvas

	| evt t |
	evt := RSEvent new.
	t := false.
	canvas when: RSEvent do: [ :ex | t := true ].
	canvas announce: evt.
	self assert: evt canvas equals: canvas.
	self assert: t.! !

!RSCanvasTest methodsFor: 'events' stamp: ''!
testLowLevelEvent
	| box |
	box := RSBox new size: 30.
	box when: RSMouseDragging do: [ :evt | box ].
	canvas addShape: box.
	self assert: canvas extent equals: 500 asPoint.
	self
		assert: (canvas shapeWithAction: RSMouseDragging forPositionInPixels: 250 @ 250)
		identicalTo: box! !

!RSCanvasTest methodsFor: 'events' stamp: ''!
testEvent 
	| box |
	box := RSBox new.
	box when: RSMouseClick do: [ :evt |  ]! !

!RSCanvasTest methodsFor: 'running' stamp: ''!
testOpening
	canvas open delete! !

!RSCanvasTest methodsFor: 'tests - shapes ordering' stamp: ''!
testPushFront

	| c blueBox redBox |
	c := RSCanvas new.

	blueBox := RSBox new
		          size: 80;
		          color: #blue.
	redBox := RSBox new
		          size: 80;
		          color: #red.

	c
		add: blueBox;
		add: redBox.
	blueBox translateBy: 40 @ 20.
	
	"red is in front of blue"
	self assert: c shapes asArray equals: { blueBox . redBox }.
	
	blueBox pushFront.
	self assert: c shapes asArray equals: { redBox . blueBox }.
	
	redBox pushFront.
	self assert: c shapes asArray equals: { blueBox . redBox }.

	c pushFront: blueBox.
	self assert: c shapes asArray equals: { redBox . blueBox }.
	
	c pushBack: blueBox.
	self assert: c shapes asArray equals: { blueBox . redBox }.! !

!RSCanvasTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new! !

!RSCanvasTest methodsFor: 'running' stamp: ''!
testDrawCanvas
	canvas addShape: (RSBox new
		extent: 100@100;
		yourself).
	canvas addShape: (RSEllipse new
		position: 100@100;
		extent: 100@100;
		yourself).
	canvas createMorph drawOnMockCanvas.! !

!RSCanvasTest methodsFor: 'tests - composite' stamp: ''!
testNestedShape

	| shape innerShape |
	shape := RSComposite new.
	canvas addShape: shape.
	innerShape := RSBox new.
	shape add: innerShape.
	
	self assert: shape canvas equals: canvas.
	self assert: innerShape parent equals: shape.
	self assert: innerShape canvas equals: canvas.
	! !

!RSCanvasTest methodsFor: 'tests' stamp: ''!
testShapeFromModel
	| shapes |
	shapes := (1 to: 3) collect: [ :m | RSBox new model: m; yourself ].
	canvas addAll: shapes.
	
	self assert: (canvas shapeFromModel: 1) equals: shapes first.
	self assert: (canvas shapeFromModel: 2) equals: shapes second.
	self assert: (canvas shapeFromModel: 3) equals: shapes third.
	self assert: (canvas shapeFromModel: 4) isNil! !

!RSCanvasTest methodsFor: 'tests' stamp: ''!
testDeepNodes

	| c compo box |
	c := RSCanvas new.

	compo := RSComposite new.
	box := RSBox new.
	compo addShape: box.
	compo adjustToChildren.

	c add: compo.

	self assert: c numberOfNodes equals: 1.
	self assert: c numberOfDeepNodes equals: 2.

	self assert: c deepNodes size equals: 2.
	self assert: (c deepNodes includesAll: { 
				 box.
				 compo })! !

!RSCanvasTest methodsFor: 'tests - opening' stamp: ''!
testOpenOnce

	| c win morph |
	c := RSCanvas new.
	win := c openOnce.
	self assert: win class equals: SystemWindow.
	
	morph := win findDeeplyA: RSAthensMorph.
	self assert: morph class equals: RSAthensMorph.
	self assert: morph canvas equals: c.
	win delete.! !

!RSCanvasTest methodsFor: 'running' stamp: ''!
testAddOneShape

	canvas addShape: RSBox new.
	self assert: canvas numberOfShapes equals: 1.
	self assert: canvas numberOfFixedShapes equals: 0! !

!RSCanvasTest methodsFor: 'tests - opening' stamp: ''!
testOpen

	| c win |
	c := RSCanvas new.
	win := c open.
	self assert: win class equals: SystemWindow.
	win delete.! !

!RSCanvasTest methodsFor: 'tests - composite' stamp: ''!
testShapeFromModelAndComposite3

	| compo compo2 compo3 |
	compo := RSComposite new.
	compo add: (RSBox new size: 20; model: 42).
	compo model: 41.
	canvas add: compo.
	
	compo2 := RSComposite new.
	compo2 add: (RSBox new size: 20; model: 42).
	compo2 model: 41.
	canvas add: compo2.
	
	compo3 := RSComposite new.
	compo3 add: (RSBox new size: 20; model: 2).
	compo3 model: 1.
	canvas add: compo3.
	
	self assert: canvas numberOfShapes equals: 3.
	self assert: (canvas shapesFromModels: #(41 1)) asArray equals: { compo . compo2 . compo3 }.
	self assert: (canvas shapesFromModels: #(42)) isEmpty.
	
	self assert: (canvas deepShapesFromModels: #(41 42)) asArray equals: { compo . compo children first  . compo2 . compo2 children first }. 
! !

!RSCanvasTest methodsFor: 'tests - opening' stamp: ''!
testMultipleOpenOnce

	| c1 c2 win1 win2 |
	c1 := RSCanvas new.
	win1 := c1 openOnce.

	c2 := RSCanvas new.
	win2 := c2 openOnce.

	[ 
		self deny: win1 isDisplayed.
		self assert: win2 isDisplayed
	] ensure: [ win1 delete. win2 delete. ]
	 ! !

!RSCanvasTest methodsFor: 'tests - shapes ordering' stamp: ''!
testRemovingShapes
	| e |
	e := RSEllipse new.
	canvas addShape: e.
	self assert: canvas shapes size equals: 1.
	e remove.
	self assert: canvas shapes size equals: 0.! !

!RSCanvasTest methodsFor: 'tests - composite' stamp: ''!
testShapeFromModelAndComposite

	| compo |
	compo := RSComposite new.
	compo add: (RSBox new size: 20; model: 42).
	compo model: 41.
	
	canvas add: compo.
	
	self assert: canvas numberOfShapes equals: 1.
	self assert: (canvas shapeFromModel: 41) equals: compo.
	self assert: (canvas shapeFromModel: 42) isNil.
	
	self assert: (canvas deepShapeFromModel: 41) equals: compo.
	self assert: (canvas deepShapeFromModel: 42) equals: compo children first.
	
	self assert: (canvas deepShapeFromModel: 43) isNil! !

!RSCanvasTest methodsFor: 'tests - converting' stamp: ''!
testAsShapeModel

	| c compositeShape |
	c :=RSCanvas new.
	c addAll: (RSBox models: (1 to: 20)).
	RSGridLayout on: c shapes.
	
	compositeShape := c asShapeModel: 'Hello'.
	self assert: compositeShape class equals: RSComposite.
	self assert: compositeShape model equals: 'Hello'.
	self assert: compositeShape children size equals: 20! !

!RSCanvasTest methodsFor: 'tests - shapes ordering' stamp: ''!
testPush

	| c blueBox redBox |
	c := RSCanvas new.

	blueBox := RSBox new
		          size: 80;
		          color: #blue.
	redBox := RSBox new
		          size: 80;
		          color: #red.

	c
		add: blueBox;
		add: redBox.
	blueBox translateBy: 40 @ 20.
	
	"red is in front of blue"
	self assert: c shapes asArray equals: { blueBox . redBox }.
	
	redBox pushBack.
	self assert: c shapes asArray equals: { redBox . blueBox }.
	
	blueBox pushBack.
	self assert: c shapes asArray equals: { blueBox . redBox }.

	c pushBack: redBox.
	self assert: c shapes asArray equals: { redBox . blueBox }.! !

!RSCanvasTest methodsFor: 'running' stamp: ''!
testDrawFixed
	| box |
	box := RSBox new
		extent: 100@100;
		yourself.
	box isFixed: true.
	canvas addShape: box.
	
	box := RSBox new
		extent: 100@100;
		yourself.
	canvas addShape: box.
	self deny: box isFixed.
	box setAsFixed.
	self assert: box isFixed.
	self assert: canvas numberOfShapes equals: 0.
	self assert: canvas numberOfFixedShapes equals: 2.
	canvas createMorph drawOnMockCanvas.! !

!RSCanvasTest methodsFor: 'tests' stamp: ''!
testEventKnowsItsCanvas02

	| evt shape |
	shape := RSBox new size: 20.
	canvas add: shape.
	
	evt := RSShapeAddedEvent new shape: shape.
	canvas announce: evt.
	self assert: evt canvas equals: canvas.! !

!RSCanvasTest methodsFor: 'running' stamp: ''!
testDrawCanvasWithGroup
	| g |
	g := RSComposite new.
	g add: (RSBox new
		extent: 100@100;
		yourself).
	g add: (RSEllipse new
		position: 100@100;
		extent: 100@100;
		yourself).
	canvas addShape: g.
	canvas createMorph drawOnMockCanvas.! !

!RSCellLayout commentStamp: ''!
A ROCellLayout is like ROGridLayout. Elements of each column are centered along the same vertical line. And elements of each row are centered along the same horizontal line.

Instance Variables
	inCellPosition:		<Object | Block>

inCellPosition
	- Object which computes position of each element inside a cell. The cell is the space allocated for an element. Its height is maximum of heights of elements on the row. Its width is maximum of widths of elements on the column. By default elements are in the middle of their cell.!
!RSCellLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self leftCentered! !

!RSCellLayout methodsFor: 'hook' stamp: ''!
doExecute: shapes 
	| lineItemSize pointer columnCount rowCount maxHeight columnsWidths rowHeights |
	lineItemSize := self lineItemsCountBlock rsValue: shapes.

	"We compute the size of the grid"
	columnCount := 1.
	rowCount := 1.
	maxHeight := 0.
	columnsWidths := OrderedCollection new.
	rowHeights := OrderedCollection new.
	shapes do: [ :e |
		columnsWidths size < columnCount ifTrue: [ columnsWidths add: 0 ].
		columnsWidths at: columnCount put: ((columnsWidths at: columnCount) max: e extent x).		
		maxHeight := maxHeight max: e extent y.
		columnCount := columnCount + 1.
		
		columnCount > lineItemSize
			ifTrue: [ 
				columnCount := 1. 
				rowHeights add: maxHeight.
				maxHeight := 0 ]
	].
	rowHeights add: maxHeight.


	"We do the translation"
	columnCount := 1.
	rowCount := 1.
	pointer := (((columnsWidths at: 1) / 2) @ ((rowHeights at: 1) / 2)).
	shapes do: [ :e | 
		e translateTo: pointer.
		pointer := pointer + (self gapSize * 2 @ 0) + (((columnsWidths at: columnCount) / 2) @ 0).

		columnCount := columnCount + 1.
		columnCount > lineItemSize
			ifTrue: [ 
				columnCount := 1.
				pointer := (((columnsWidths at: 1) / 2) @ pointer y)  + (0 @ ((rowHeights at: rowCount) / 2)).
				rowCount := rowCount + 1.
				rowCount <= rowHeights size 
					ifTrue: [ pointer := pointer + (0 @ ((rowHeights at: rowCount) / 2)) ].				 
				 ]
			ifFalse: [ pointer := pointer + (self gapSize * 2 @ 0) + (((columnsWidths at: columnCount ) / 2) @ 0) ].
	]! !

!RSCellLayout methodsFor: 'accessing' stamp: ''!
leftCentered
	align := #left.

	translateElement := [ :aTranslator :anElement :newPos | translator translateTopLeftOf: anElement to: newPos ].
	
	"self inCellPosition: [ :cell | 0 @ ((cell extent y - cell element height) / 2) ]"
	self inCellPosition: [ :cell | cell extent x @ 0 ]
! !

!RSCellLayout methodsFor: 'accessing' stamp: ''!
centered
	align := #center.
	translateElement := [ :aTranslator :anElement :newPos | translator translateCenterLeftOf: anElement to: newPos ].
	
	self inCellPosition: [ :cell | cell extent x @ 0 ]
! !

!RSCellLayout methodsFor: 'accessing' stamp: ''!
inCellPosition: anObjectOrOneArgBlock
	inCellPosition := anObjectOrOneArgBlock! !

!RSCenteredAttachPoint commentStamp: ''!
I am the centered attach point

-=-=-=-=
c := RSCanvas new.

shapes := (30 to: 50) collect: [ :nb |
	RSEllipse new size: nb; model: nb; yourself.
	 ] as: RSGroup.

c addAll: shapes.

lines := RSEdgeBuilder line
	canvas: c;
	connectFrom: 30 toAll: (31 to: 50).

lines do: [ :l | l attachPoint: (RSCenteredAttachPoint new) ].

RSGridLayout on: shapes. 
RSLocation new
	above;
	move: shapes first on: shapes allButFirst.
shapes @ RSDraggable.

c @ RSCanvasController
-=-=-=-=!
!RSCenteredAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicEndingPointOf: anEdge
	^ self positionFor: anEdge to in: anEdge.
	! !

!RSCenteredAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicStartingPointOf: anEdge
	^ self positionFor: anEdge from in: anEdge.
	! !

!RSChart commentStamp: ''!
<keyClass>
`RSChart` is the main class to build charts.

*Responsibility*: maintain and render plots

*Collaborators*: a chart closely interacts with plots and decorations. 

*Variables*:
- `plots`: the list of plots 
- `extent`: size of the produced chart. Note that this extent is for the area on which plots are draw. It does not comprise ticks and axis titles
- `decorations`: collection of decorations to annotate the chart
- `generator`: nice label generator, useful to have labels that are visually appealing
- `colors`: default color palette

*Example*:
Here is an example that adjust the font size used for the title, and axis labels:

```Smalltalk
x := -3.14 to: 3.14 by: 0.1.
y := x sin.

c := RSChart new.
c addPlot: (RSLinePlot new x: x y: y).
c addDecoration: (RSChartTitleDecoration new title: 'hello'; fontSize: 20).
c addDecoration: (RSXLabelDecoration new title: 'My X Axis'; fontSize: 12).
c addDecoration: (RSYLabelDecoration new title: 'My Y Axis'; fontSize: 15; vertical).
c
```!
!RSChart methodsFor: 'public - scales' stamp: ''!
yScale: aScale
	plots, decorations do: [ :e | e yScale: aScale ].
	^ aScale! !

!RSChart methodsFor: 'color' stamp: ''!
defaultPlotColors
	^ NSScale category20! !

!RSChart methodsFor: 'public - configuration' stamp: ''!
mustInclude0inY
	"Make sure that the 0 value is in the chart"
	(self minValueY <= 0 and: [ 0 <= self maxValueY ]) ifTrue: [ ^ self ].
	
	self maxValueY > 0 
		ifTrue: [ self minValueY: 0 ]
		ifFalse: [ self maxValueY: 0 ]! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
padding: aPoint
	self chartExtents padding: aPoint asPoint! !

!RSChart methodsFor: 'hooks' stamp: ''!
renderIn: aCanvas
	decorations, plots do: [ :e | e beforeRenderingIn: self ].
	self renderDecorationIn: aCanvas.
	self renderPlotsIn: aCanvas.
	shapes := decorations, plots flatCollect: [ :element | 
		element createdShapes ] as: RSGroup.! !

!RSChart methodsFor: 'color' stamp: ''!
colorFor: aRSPlot 
	"Return a color for the given plot. Colors are defined as in #defaultPlotColors"
	^ colors scale: aRSPlot! !

!RSChart methodsFor: 'public - plots' stamp: ''!
barHeights: aCollectionY
	| res |
	self addPlot: (res := RSBarPlot new 
		x: (1 to: aCollectionY size) 
		y: aCollectionY).
	^ res! !

!RSChart methodsFor: 'adding' stamp: ''!
addPlot: aPlot
	"Add a plot to the chart.
	
For example:
```Smalltalk
x := -3.14 to: 3.14 by: 0.1.
y := x sin.
c := RSChart new.
c addPlot: (RSLinePlot new x: x y: y).
c
```
	"
	plots add: aPlot.
	aPlot chart: self! !

!RSChart methodsFor: 'accessing' stamp: ''!
plots
	^ plots! !

!RSChart methodsFor: 'accessing' stamp: ''!
colors: someColors
	"Set the palette to be use to plots"
	colors := someColors! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
chartExtents: aRSChartExtents
	extents := aRSChartExtents! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
padding
	^ self chartExtents padding
		ifNil: [ | res |
			self chartExtents padding: (res := 0@0).
			res ]
		ifNotNil: [:res | res ].! !

!RSChart methodsFor: 'decoration' stamp: ''!
xlabel: aTitle
	"Set a label on the horizontal axis"
	^ self addDecoration: (RSXLabelDecoration new title: aTitle)! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
minValueY
	^ self chartExtents minValueY
		ifNil: [ | res |
			self chartExtents minValueY: (res := (plots collect: #minValueY) min).
			res ]
		ifNotNil: [:res | res ].! !

!RSChart methodsFor: 'decoration' stamp: ''!
ylabel: aTitle offset: aPointOrANumber
	"Set a label on the vertical axis, using an offset (useful to avoid overlap with axis labels)"
	^ self addDecoration: (RSYLabelDecoration new title: aTitle ; offset: aPointOrANumber)! !

!RSChart methodsFor: 'public - scales' stamp: ''!
xLinear
	^ self xScale: NSScale linear! !

!RSChart methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	plots := OrderedCollection new.
	self extent: 200 @ 200.
	self initializeDecorations.
	colors := self defaultPlotColors.! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
chartExtents
	^ extents ifNil: [ extents := RSChartExtents new ]! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
minValueX 
	^ self chartExtents minValueX
		ifNil: [ | res |
			self chartExtents minValueX: (res := (plots collect: #minValueX) min).
			res ]
		ifNotNil: [:res | res ].! !

!RSChart methodsFor: 'public - scales' stamp: ''!
yLinear
	^ self yScale: NSScale linear! !

!RSChart methodsFor: 'public - scales' stamp: ''!
ySqrt
	^ self yScale: NSScale sqrt! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
minValueX: aNumber
	self chartExtents minValueX: aNumber! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
extent
	^ self chartExtents extent! !

!RSChart methodsFor: 'decoration' stamp: ''!
ylabel: aTitle
	"Set a label on the vertical axis"
	^ self addDecoration: (RSYLabelDecoration new title: aTitle)! !

!RSChart methodsFor: 'building' stamp: ''!
show
	^ self open! !

!RSChart methodsFor: 'public - plots' stamp: ''!
lineX: aCollectionX y: aCollectionY
	| res |
	self addPlot: (res := RSLinePlot new x: aCollectionX y: aCollectionY).
	^ res! !

!RSChart methodsFor: 'public - scales' stamp: ''!
xRawLog
	self xScale: NSScale log! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
maxValueX: aNumber
	self chartExtents maxValueX: aNumber! !

!RSChart methodsFor: 'public - scales' stamp: ''!
yRawLog
	"ensure all your data and axis do not contains zero"
	^ self yScale: NSScale log! !

!RSChart methodsFor: 'public - scales' stamp: ''!
xSqrt
	^ self xScale: NSScale sqrt! !

!RSChart methodsFor: 'public - scales' stamp: ''!
xLn
	^ self xScale: NSScale ln! !

!RSChart methodsFor: 'defaults' stamp: ''!
defaultContainer
	^ RSCanvas new @ RSCanvasController! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
maxValueY
	^ self chartExtents maxValueY
		ifNil: [ | res |
			self chartExtents maxValueY: (res := (plots collect: #maxValueY) max).
			res ]
		ifNotNil: [:res | res ].
		! !

!RSChart methodsFor: 'building' stamp: ''!
renderDecorationIn: aCanvas
	decorations do: [ :d | d renderIn: aCanvas ]! !

!RSChart methodsFor: 'building' stamp: ''!
renderPlotsIn: aCanvas
	plots do: [ :p | p renderIn: aCanvas ].
	! !

!RSChart methodsFor: 'public' stamp: ''!
openOnce
	self build.
	^ self canvas openOnce! !

!RSChart methodsFor: 'visualization' stamp: ''!
gtInspectorViewIn: composite
	<gtInspectorPresentationOrder: -10>
	composite roassal3
		title: ['Canvas'];
		initializeCanvas: [ self build; canvas ]
		! !

!RSChart methodsFor: 'decoration' stamp: ''!
xlabelTop: aTitle
	"Set a label on the horizontal top axis"
	^ self addDecoration: (RSXLabelDecoration new title: aTitle; above).! !

!RSChart methodsFor: 'inspector' stamp: ''!
inspectorCanvasContext: aContext
  
  aContext withoutEvaluator! !

!RSChart methodsFor: 'public - plots' stamp: ''!
barWidths: aCollectionX
	| res |
	self addPlot: (res := RSHorizontalBarPlot new 
		x: aCollectionX
		y: (1 to: aCollectionX size)).
	^ res! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
minValueY: aNumber
	self chartExtents minValueY: aNumber! !

!RSChart methodsFor: 'decoration' stamp: ''!
ylabelRight: aTitle
	"Set a label on the vertical axis"
	^ self addDecoration: (RSYLabelDecoration new title: aTitle; right; yourself)! !

!RSChart methodsFor: 'adding' stamp: ''!
addDecoration: aDecoration
	"Add a decoration to the chart

For example:
```Smalltalk
x := -3.14 to: 3.14 by: 0.1.
y := x sin.
c := RSChart new.
c addPlot: (RSLinePlot new x: x y: y).
c addDecoration: (RSHorizontalTick new).
c addDecoration: (RSVerticalTick new).
c
```"
	decorations add: aDecoration.
	aDecoration chart: self.
	^ aDecoration! !

!RSChart methodsFor: 'public - scales' stamp: ''!
xLog
	^ self xScale: NSScale symlog! !

!RSChart methodsFor: 'accessing' stamp: ''!
niceGenerator
	"Produce a generator for nice labels. Whether nice labels are used or not is a choice made by the horizontal or vertical ticks."
	^ generator ifNil: [ 
		generator := RSLabelGenerator new.
		generator setLooseFlag: true.
		generator ].! !

!RSChart methodsFor: 'public - scales' stamp: ''!
xScale: aScale
	plots, decorations do: [ :e | e xScale: aScale ].
	^ aScale! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
extent: aPoint
	self chartExtents extent: aPoint! !

!RSChart methodsFor: 'public - configuration' stamp: ''!
mustInclude0inX
	"Make sure that the 0 value is in the chart"
	((self minValueX to: self maxValueX) includes: 0) ifTrue: [ ^ self ].
	
	self maxValueX > 0 
		ifTrue: [ self minValueX: 0 ]
		ifFalse: [ self maxValueX: 0 ]! !

!RSChart methodsFor: 'public - scales' stamp: ''!
yLn
	^ self yScale: NSScale ln! !

!RSChart methodsFor: 'accessing' stamp: ''!
title: aTitle
	"Set the title of a chart. For example:
	
```Smalltalk
c := RSChart new.
c addPlot: (RSLinePlot new x: (1 to: 200) y: (1 to: 200) sqrt).
c title: 'Square root'.
c
```
	"
	^ self addDecoration: (RSChartTitleDecoration new title: aTitle)! !

!RSChart methodsFor: 'inspector' stamp: ''!
inspectorCanvas
	<inspectorPresentationOrder: 90 title: 'Canvas'>
	self build. 
	^ SpRoassal3InspectorPresenter new
		canvas: self canvas;
		yourself! !

!RSChart methodsFor: 'accessing' stamp: ''!
numberOfPlots
	"Return the number of plots contained in the chart"
	^ plots size! !

!RSChart methodsFor: 'accessing' stamp: ''!
decorations
	"Return the list of decorations used to annotate plots"
	^ decorations! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
maxValueX
	^ self chartExtents maxValueX
		ifNil: [ | res |
			self chartExtents maxValueX: (res := (plots collect: #maxValueX) max).
			res ]
		ifNotNil: [:res | res ].! !

!RSChart methodsFor: 'decoration' stamp: ''!
xlabel: aTitle offset: aPointOrANumber
	"Set a label on the horizontal axis, using an offset (useful to avoid overlap with axis labels)"
	^ self addDecoration: (RSXLabelDecoration new title: aTitle; offset: aPointOrANumber)! !

!RSChart methodsFor: 'public - scales' stamp: ''!
yLog
	^ self yScale: NSScale symlog! !

!RSChart methodsFor: 'accessing - extension' stamp: ''!
maxValueY: aNumber
	self chartExtents maxValueY: aNumber! !

!RSChart methodsFor: 'initialization' stamp: ''!
initializeDecorations
	decorations := OrderedCollection new.
	self addDecoration: RSChartSpineDecoration new.! !

!RSChart methodsFor: 'accessing' stamp: ''!
colors
	"Return the palette"
	^ colors! !

!RSChartDecoration commentStamp: ''!
TODO!
!RSChartDecoration methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	"Need to be overridden in subclasses. Useful to enrich a visualization"
	self subclassResponsibility! !

!RSChartExtents commentStamp: ''!
This class provides some extents for RSChart

- extent: the extent of one chart
- max min: for each axis of this 2d chart
- padding: an internal gap between plots and base rectangle!
!RSChartExtents methodsFor: 'accessing' stamp: ''!
maxValueY
	^ maxValueY! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
padding: aPoint
	padding := aPoint! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
minValueX
	^ minValueX! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
minValueX: aNumber
	minValueX := aNumber! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
extent
	^ extent! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
maxValueX
	^ maxValueX! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
minValueY: aNumber
	minValueY := aNumber! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
maxValueX: aNumber
	maxValueX := aNumber! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
maxValueY: aNumber
	maxValueY := aNumber! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
padding
	^ padding! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
extent: aPoint
	extent := aPoint! !

!RSChartExtents methodsFor: 'accessing' stamp: ''!
minValueY
	^ minValueY! !

!RSChartPopupDecoration commentStamp: ''!
Specific popup, used by RSPopupDecoration!
!RSChartPopupDecoration methodsFor: 'accessing' stamp: ''!
chart
	^ chart! !

!RSChartPopupDecoration methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	"this composite is created once when the mouse enter into the box shape"
	self shapeBuilder: [ :obj | RSComposite new ].
	! !

!RSChartPopupDecoration methodsFor: 'hooks' stamp: ''!
translatePopup: popup event: evt
	self 
		updatePopup: popup event: evt;
		updateMarkers: evt.
	super translatePopup: popup event: evt! !

!RSChartPopupDecoration methodsFor: 'hooks' stamp: ''!
updateMarkers: evt

	| markers key container builder |
	builder := self markersPopupBuilder.
	builder position: evt position.
	markers := builder shapeFor: self chart.
	container := self chart container.
	key := #popupMarkers.
	container propertyAt: key ifPresent: [ :old | old remove ].
	container addShape: markers.
	container propertyAt: key put: markers.
	^ builder! !

!RSChartPopupDecoration methodsFor: 'hooks' stamp: ''!
releasePopup: popup
	popup remove.
	chart container propertyAt: #popupMarkers ifPresent: [ :old | old remove ].! !

!RSChartPopupDecoration methodsFor: 'accessing' stamp: ''!
chart: aRSChart
	chart := aRSChart! !

!RSChartPopupDecoration methodsFor: 'hooks' stamp: ''!
updatePopup: popup event: evt
	"we recreate the popup content each time, since the popup should show the nodes change"
	| builder |
	popup children do: #remove. "we recreate the popup content each time, since the popup should show the nodes change"
	builder := self chartPopupBuilder.
	builder position: evt position.
	popup addShape: (builder shapeFor: self chart).
	popup adjustToChildren.
	! !

!RSChartPopupDecoration methodsFor: 'accessing' stamp: ''!
chartPopupBuilder: aShapeBuilder
	chartPopupBuilder := aShapeBuilder! !

!RSChartPopupDecoration methodsFor: 'accessing' stamp: ''!
markersPopupBuilder: aRSAbstractChartPopupBuilder
	markersPopupBuilder := aRSAbstractChartPopupBuilder! !

!RSChartPopupDecoration methodsFor: 'accessing' stamp: ''!
chartPopupBuilder
	^ chartPopupBuilder! !

!RSChartPopupDecoration methodsFor: 'accessing' stamp: ''!
markersPopupBuilder
	^ markersPopupBuilder! !

!RSChartSpineDecoration commentStamp: ''!
The PLTSpineDecoration class represent the spine of a matplot visualization. It represents the surrounding box that contains plots and scatters.

The class has the responsibilty to draw a usually black box around a visualization. 

The class collaborates with PLT and PLTTitleDecoration. The PLTTitleDecoration class requires the shape in order to put a title above.

The method is not meant to be used by a normal user as it represents a functionality to be used directly by PLT, and does not offer much configuration.

  Instance Variables
	shape:		<TSBox>	The box that surrounds the visualization
!
!RSChartSpineDecoration methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	shape := RSBox new color: nil; extent: chart extent; withBorder.
	shape translateTo: (chart extent x / 2) @ (chart extent y negated / 2).
	canvas add: shape! !

!RSChartSpineDecoration methodsFor: 'accessing' stamp: ''!
createdShapes
	^ { shape }! !

!RSChartSpineDecoration methodsFor: 'rendering' stamp: ''!
shape
	^ shape! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testMustInclude02

	| y c |
	y := #(-10 -13 -15).
	c := RSChart new.
	c addPlot: (RSLinePlot new y: y).
	c mustInclude0inY.
	c build.
	self assert: c minValueX equals: 1.
	self assert: c maxValueX equals: 3.
	self assert: c minValueY equals: -15.
	self assert: c maxValueY equals: 0.! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testMustInclude03

	| y c x |
	y := #(-10 -13 -15).
	x := #(4 6 9).
	c := RSChart new.
	c addPlot: (RSLinePlot new x: x y: y).
	c mustInclude0inX.
	c build.
	self assert: c minValueX equals: 0.
	self assert: c maxValueX equals: 9.
	self assert: c minValueY equals: -15.
	self assert: c maxValueY equals: -10.! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testBasic

	| x |
	x := -10.0 to: 20.0 count: 100.

	RSChart new
    addPlot: (RSScatterPlot new x: x y: (x raisedTo: 3));
    addPlot: (RSLinePlot new x: x y: (x raisedTo: 2));
	addDecoration: RSHorizontalTick new;
	addDecoration: RSVerticalTick new;
	build! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testMustInclude04

	| y c |
	y := OrderedCollection new.
	-3.14 to: 3.14 by: 0.1 do: [ :x |
		y add: x sin ].
	
	c := RSChart new.
	c addPlot: (RSLinePlot new y: y).
	c build.
	
	self assert: c minValueY equals: -0.9995258306054791.
	self assert: c maxValueY equals: 0.9999417202299663.! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testYMarker

	| x c p1 p2 marker line |
	x := -3.14 to: 3.14 by: 0.01.
	c := RSChart new.
	p1 := RSLinePlot new.
	p1 x: x y: x sin * 0.22.
	c addPlot: p1.
	p2 := RSLinePlot new.
	p2 x: x y: x cos * 0.18.
	c addPlot: p2.
	c addDecoration: RSHorizontalTick new.
	c addDecoration: RSVerticalTick new asFloat.

	marker := RSYMarkerDecoration new.
	c addDecoration: marker.
	c build.
	
	line := marker createMarkerLineFromPlot: p2.
	self assert: line from equals: (0@ -175.0).
	self assert: line to equals: (200@ -175.0)! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testSameMinMax

	| c plot |
	c := RSChart new.
	plot := RSLinePlot new.
	plot y: #( 2 2 ).
	c addPlot: plot.

	c addDecoration: (RSChartTitleDecoration new
			 title: 'Reward evolution';
			 fontSize: 20).
	c xlabel: 'Episode' offset: 0 @ 10.
	c ylabel: 'Reward' offset: -20 @ 0.
	c addDecoration: RSHorizontalTick new.
	c addDecoration: RSVerticalTick new.
	c build! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testMinMaxValue

	| y c |
	y := #(10 13 15).
	c := RSChart new.
	c addPlot: (RSLinePlot new y: y).
	c build.
	self assert: c minValueX equals: 1.
	self assert: c maxValueX equals: 3.
	self assert: c minValueY equals: 10.
	self assert: c maxValueY equals: 15.! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testWithWeirdValuesLine

	| values g d line c |
	values := {Float infinity negated. Float infinity negated. 0.30102999566398114. 0.47712125471966244}.
	g := RSChart new.
	d := RSLinePlot new y: values.
	g addPlot: d.
	g build.
	c := g canvas.
	
	self assert: c numberOfShapes equals: 2.
	self assert: c shapes first class equals: RSBox.
	
	line := c shapes second.
	self assert: line controlPoints size equals: 2.! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testMustInclude0

	| y c |
	y := #(10 13 15).
	c := RSChart new.
	c addPlot: (RSLinePlot new y: y).
	c mustInclude0inY.
	c build.
	self assert: c minValueX equals: 1.
	self assert: c maxValueX equals: 3.
	self assert: c minValueY equals: 0.
	self assert: c maxValueY equals: 15.! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testWithWeirdValues

	| values g d line c |
	values := {Float infinity negated. Float infinity negated. 0.30102999566398114. 0.47712125471966244}.
	g := RSChart new.
	d := RSLinePlot new y: values.
	g addPlot: d.
	g build.
	c := g canvas.
	
	self assert: c numberOfShapes equals: 2.
	self assert: c shapes first class equals: RSBox.
	
	line := c shapes second.
	self assert: line controlPoints size equals: 2.! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testWithWeirdValuesLineWithTicks2
	| x g d c labels |
	x := { -5 . 0 . 1 . 2 }.
	g := RSChart new.
	d := RSLinePlot new x: x y: x log.
	g addPlot: d.
	g addDecoration: RSVerticalTick new.
	g build.
	
	self assert: g minValueX equals: -5.
	self assert: g minValueY equals: 0.

	self assert: g maxValueX equals: 2.
	self assert: g maxValueY equals: 8 / 25.

	c := g canvas.
	
	labels := c shapes select: [ :s | s class == RSLabel ].
	self assert: labels first position y <= 0
	! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testWithWeirdValuesLineWithTicks

	| values g d line c |
	values := {Float infinity negated. Float infinity negated. 0.30102999566398114. 0.47712125471966244}.
	g := RSChart new.
	d := RSLinePlot new y: values.
	g addPlot: d.
	g addDecoration: RSHorizontalTick new.
	g addDecoration: RSVerticalTick new.
	g build.
	c := g canvas.
	
	self assert: c numberOfShapes equals: 20.
	self assert: c shapes first class equals: RSBox.
	
	line := c shapes second.
	self assert: line controlPoints size equals: 2.! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testMustInclude05

	| y c |
	y := OrderedCollection new.
	-3.14 to: 3.14 by: 0.1 do: [ :x |
		y add: x sin ].
	
	c := RSChart new.
	c addPlot: (RSLinePlot new y: y).
	c mustInclude0inY.
	c build.
	
	self assert: c minValueY equals: -0.9995258306054791.
	self assert: c maxValueY equals: 0.9999417202299663.! !

!RSChartTest methodsFor: 'tests' stamp: ''!
testMinMaxValue2

	| y c x |
	y := #(-10 -13 -15).
	x := #(4 6 9).
	c := RSChart new.
	c addPlot: (RSLinePlot new x: x y: y).
	c build.
	self assert: c minValueX equals: 4.
	self assert: c maxValueX equals: 9.
	self assert: c minValueY equals: -15.
	self assert: c maxValueY equals: -10.! !

!RSChartTickTest methodsFor: 'tests' stamp: ''!
testDoNotUseNiceLabel
	| x c numberOfTicks vertical |
	x := -10.0 to: 20.0 count: 100.
	numberOfTicks := 2.
	c := RSChart new
		addPlot: (RSScatterPlot new x: x y: (x raisedTo: 3));
		addPlot: (RSLinePlot new x: x y: (x raisedTo: 2));
		addDecoration: (RSHorizontalTick new 
			numberOfTicks: 20;
			integer);
		addDecoration: (vertical := RSVerticalTick new integer 
			numberOfTicks: numberOfTicks;
			doNotUseNiceLabel);
		yourself.
	c build.
	self assert: vertical labels size equals: numberOfTicks+1.
	! !

!RSChartTickTest methodsFor: 'tests' stamp: ''!
testFromNames
	| dates y data x c horizontal |
	dates := OrderedCollection new.
	y := OrderedCollection new.
	data := 
	{'04-jun-2020'.800.
	'03-jun-2020'.	900.
	'02-jun-2020'.	850} reverse.
		data pairsDo: [ :f :d |
			dates add: d.
			y add: f ].
	x := 1 to: dates size.
	c := RSChart new.
	c extent: 300@200.
	
	c addPlot: (RSLinePlot new x: x y: y).

	c addDecoration: ( horizontal := RSHorizontalTick new fromNames: dates).
	c addDecoration: (RSVerticalTick new numberOfTicks: 10; asFloat).
	c build.
	self assert: horizontal labels size equals: dates size.! !

!RSChartTitleDecoration commentStamp: ''!
<keyClass>
`RSChartTitleDecoration` is a `RSChartDecoration` that adds a title to a chart.

*Responsibility*: To display a title on top of a chart per default

*Collaborators*: must be added to `RSChart`

*Example*:
```Smalltalk
c := RSChart new.
c addPlot: (RSLinePlot new x: (1 to: 200) y: (1 to: 200) sqrt).
c addDecoration: (RSChartTitleDecoration new title: 'Square root').

"The line above can also be writen as:
c title: 'Square root'.
"
c open
```!
!RSChartTitleDecoration methodsFor: 'rendering' stamp: ''!
initialize
	super initialize.
	self fontSize: 15.
	location
		offset: 0@ -2;
		above; center.! !

!RSChartTitleDecoration methodsFor: 'rendering' stamp: ''!
defaultFontSize
	^ 15! !

!RSChartTitleDecorationTest methodsFor: 'tests' stamp: ''!
testBasic
	| c title label |
	c := RSChart new.
	title := c title: 'hello'.
	title baseShape
		color: Color blue.
	c build.
	
	self assert: c canvas numberOfShapes equals: 2.
	label := c canvas shapes second.
	self assert: label class equals: RSLabel.
	self assert: label color equals: Color blue.
	! !

!RSChartTitleDecorationTest methodsFor: 'tests' stamp: ''!
testBasic2
	| c |
	c := RSChart new.
	c addDecoration: (RSChartTitleDecoration new title: 'hello'; fontSize: 20).
	c build.
	 
	self assert: c canvas numberOfShapes equals: 2.
	self assert: c canvas shapes second class equals: RSLabel.
	self assert: c canvas shapes second fontSize equals: 20! !

!RSChessBackgroundInteraction commentStamp: ''!
I am a basici class!
!RSChessBackgroundInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	| boxes theme color |
	theme := Smalltalk ui theme.
	aCanvas color: theme backgroundColor.
	color := theme caretColor alpha: 0.2.
	boxes := nil.
	aCanvas when: RSExtentChangedEvent do: [ 
		| extent side counter even camera |
		boxes ifNotNil: [ boxes do: #remove ].
		extent := aCanvas extent.
		camera := aCanvas camera.
		
		aCanvas zoomToFit.
		side := 20.
		boxes := RSGroup new.
		counter := 0.
		(side / 2) to: extent x by: 20 do: [ :j |
			even := counter even.
			(side / 2) to: extent y by: 20 do: [ :k |
				| box |
				even ifTrue: [ 
					box := RSBox new
						color: color;
						size: side / camera scale;
						position: (camera fromPixelToSpace: j@k).
					boxes add: box.
					aCanvas addShape: box.
				 ].
				even := even not.
			].
			counter := counter + 1 ].
		boxes pushBack.
		aCanvas signalUpdate ].
	
! !

!RSCircle commentStamp: ''!
I am a circle shape

Here an example:

```Smalltalk
c := RSCanvas new.
(30 to: 150 by: 10) do: [ :nb |
b := RSCircle new size: nb.
c add: b ].
RSFlowLayout on: c nodes.
c @ RSCanvasController.
c open
```!
!RSCircle methodsFor: 'matrix' stamp: ''!
width: anInteger
	self error: 'Should not be performed'! !

!RSCircle methodsFor: 'testing' stamp: ''!
includesPoint: aPoint
	"Implementation is taken over from EllipseMorph>>containsPoint:"
	| invertedPoint radius other delta xOverY t1 t2 rect |
	invertedPoint := matrix rsInverseTransform: aPoint.
	rect := self baseRectangle.
	(rect containsPoint: invertedPoint) ifFalse: [ ^ false ]. "quick elimination"
	radius := rect height asFloat / 2.
	other := rect width asFloat / 2.
	delta := invertedPoint - rect topLeft - (other@radius).
	xOverY := rect width asFloat / rect height asFloat.
	t1 := (delta x asFloat / xOverY) squared + delta y squared.
	t2 := radius squared.
	^ (t1 < t2)  or: [ t1 closeTo: t2 ].! !

!RSCircle methodsFor: 'matrix' stamp: ''!
y: anInteger
	self error: 'Should not be performed'! !

!RSCircle methodsFor: 'geometry' stamp: ''!
geometry 
	| rect e p |
	rect := self encompassingRectangle.
	e := rect extent / 2.
	p := self position.
	e = (0@0) ifTrue: [ ^ p asGPoint ].
	^ GEllipse 
		center: p
		vertex: p + (0@ e y)
		coVertex:p + (e x@ 0) ! !

!RSCircle methodsFor: 'matrix' stamp: ''!
x: anInteger
	self error: 'Should not be performed'! !

!RSCircle methodsFor: 'accessing' stamp: ''!
radius
	^ self extent x / 2! !

!RSCircle methodsFor: 'matrix' stamp: ''!
height: anInteger
	self error: 'Should not be performed'! !

!RSCircle methodsFor: 'visiting' stamp: ''!
buildPathOn: visitor
	visitor buildEllipsePath: self! !

!RSCircle methodsFor: 'accessing' stamp: ''!
radius: integer
	self extent: integer * 2 asPoint! !

!RSCircle methodsFor: 'accessing' stamp: ''!
extent: aPoint
	self assert: [ aPoint x = aPoint y ] description: 'Width and height should have the same value'.
	super extent: aPoint! !

!RSCircleInterpolator commentStamp: ''!
TSEasing circleIn
Circular easing.

TSEasing circleOut
Is Reverse circular easing; equivalent to 1 - interpolateIn: 1 - t.

TSEasing circleInOut
TSEasing circle
Symmetric circular easing; scales circleIn for t in {0. 0.5} and circleOut for t in {0.5, 1}.

!
!RSCircleInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateIn:  t
	^ 1 - (1 - (t * t) ) sqrt! !

!RSCircleInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateInOut: i
	| t |
	t := i * 2.
	^ (t<=1
		ifTrue: [ 1 - (1 - (t*t)) sqrt ]
		ifFalse: [ 
			t := t - 2.
			(1 - (t*t)) sqrt + 1 ])/2! !

!RSCircleInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateOut: i
	| t |
	t := i -1.
	^ (1 - (t* t)) sqrt.
! !

!RSCircleLayout commentStamp: ''!
TODO!
!RSCircleLayout methodsFor: 'hook' stamp: ''!
doExecute: elements
	| angleIncrement angle rad center |
	rad := self computeRadiusFor: elements.
	center := Point x: rad y: rad.
	angleIncrement := self computeIncrementalAngleFor: elements.
	angle := self initialAngle.
	elements
		do: [ :each | 
			| point |
			point := center + (Point r: rad theta: angle).
			angle := angle + angleIncrement.
			translator translateTopLeftOf: each to: point.
			self step ]! !

!RSCircleLayout class methodsFor: 'instance creation' stamp: ''!
scaleBy: aNumber
	
	^self new scaleBy: aNumber! !

!RSCircleTest methodsFor: 'tests' stamp: ''!
testBasic

	self assert: (RSCircle new extent) equals: 10 @ 10! !

!RSCircularShape commentStamp: ''!
Each of my subclasses describes a circular shape!
!RSCircularShape class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == RSCircularShape! !

!RSCircularShape class methodsFor: 'accessing' stamp: ''!
size: anInteger
	"Create a new circular shape with a given size"
	^ self new size: anInteger! !

!RSClusterLayout commentStamp: ''!
TODO!
!RSClusterLayout methodsFor: 'initialize-release' stamp: ''!
initialize 
	super initialize.
	verticalGap := 30.
	horizontalGap := 20.
	externalLayer := OrderedCollection new! !

!RSClusterLayout methodsFor: 'hook' stamp: ''!
doExecute: nodeElements 
	| rootNodes gap |
	"Not much to do if there is only one element"
	nodeElements size = 1 ifTrue: [ ^ self ].
	
	rootNodes := self rootNodesFor: nodeElements.
	self validateCachedParents.
	rootNodes do: [ :e | self initializeNode: e ].
	rootNodes do: [ :e | self computePosition: e ].
	
	maxLayer := (rootNodes collect: [ :e | self layerOf: e ]) max.
	
	(rootNodes size > 1) ifTrue: [ maxLayer := maxLayer + 1 ].
	
	maxAbcissa := (self xOf: externalLayer last) + horizontalGap .
	
	gap := maxAbcissa "+ horizontalGap "/ 2 / Float pi / maxLayer.
	
	verticalGap := verticalGap max: gap.
	
	rootNodes do: [ :e | self draw: e. self step ].
	
	! !

!RSClusterLayout methodsFor: 'drawing - general' stamp: ''!
draw: aNode
	(self childrenFor: aNode) do: [ :e | self draw: e ].
	translator 
		translateTopLeftOf: aNode 
		to: (Point r: (maxLayer - (self layerOf: aNode)) * verticalGap theta: (maxAbcissa - (self xOf: aNode) / maxAbcissa) * 2 * Float pi )! !

!RSClusterLayout methodsFor: 'algorithm' stamp: ''!
computePosition: aNode
	| children previous |
	children := self childrenFor: aNode.
	children do: [ :e | self computePosition: e ].
	children isEmpty
		ifTrue: [ externalLayer first = aNode
				ifFalse: [ previous := externalLayer at: (externalLayer indexOf: aNode) - 1.
					(self fatherOf: previous) = (self fatherOf: aNode)
						ifTrue: [ self xOf: aNode put: (self xOf: previous) + (horizontalGap / 2) ]
						ifFalse: [ self xOf: aNode put: (self xOf: previous) + horizontalGap ] ] ]
		ifFalse: [ self
				xOf: aNode
				put:
					((self xOf: (self leftContourOf: aNode))
						+ (self xOf: (self rightContourOf: aNode))) / 2 ]! !

!RSClusterLayout methodsFor: 'initialize-release' stamp: ''!
initializeNode: aNode
	|children|
	children := self childrenFor: aNode.
	
	children do: [ :e | self initializeNode: e.
						self fatherOf: e put: aNode ].
	
	children isEmpty ifTrue: [ self layerOf: aNode put: 0.
							externalLayer add: aNode ] 
					ifFalse: [ self layerOf: aNode put: ((children collect: [ :e | (self layerOf: e) ]) max + 1).
							self leftContourOf: aNode put: children first.
							self rightContourOf: aNode put: children last ].
					! !

!RSClusteringLayout commentStamp: ''!
```
m := RSMondrian new.
m nodes: Collection allSubclasses.
m line connectFrom: #superclass.
m normalizeSize: #numberOfLinesOfCode.
m build.

nodes := m canvas nodes.

RSConditionalLayout new
	ifNotConnectedThen: RSGridLayout new;
	else: (RSClusteringLayout new 
				clustersLayout: RSFlowLayout new;
				forEachLayout: RSTreeLayout new);
	on: nodes.


m canvas.
```

Another example:

```
m := RSMondrian new.
m nodes: (10 to: 50).
m line connectFrom: [ :nb | nb // 2 ].
m build.

nodes := m canvas nodes.

RSConditionalLayout new
	ifNotConnectedThen: RSGridLayout new;
	else: (RSClusteringLayout new 
				clustersLayout: RSFlowLayout new;
				forEachLayout: RSTreeLayout new);
	on: nodes.



m canvas.
```!
!RSClusteringLayout methodsFor: 'accessing' stamp: ''!
clustersLayout: anObject

	clustersLayout := anObject! !

!RSClusteringLayout methodsFor: 'accessing' stamp: ''!
forEachLayout

	^ forEachLayout! !

!RSClusteringLayout methodsFor: 'accessing' stamp: ''!
forEachLayout: anObject

	forEachLayout := anObject! !

!RSClusteringLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	forEachLayout := RSHorizontalLineLayout new.
	clustersLayout := RSFlowLayout new! !

!RSClusteringLayout methodsFor: 'hook' stamp: ''!
doExecute: shapes
	"Performs the layout"

	"A collection of collections"
	| clusters |
	clusters := self getClusterFor: shapes.
	clusters do: [ :group | forEachLayout on: group ].
	clustersLayout on: clusters  ! !

!RSClusteringLayout methodsFor: 'hook' stamp: ''!
getClusterFor: shapes
	| result resultWithGroups st |
	result := OrderedCollection new. 
	shapes do: [ :s |
		| t |
		t := s allRecursiveConnectedShapes.
		(result includes: t) ifFalse: [ result add: t ]
		 ].
	
	resultWithGroups := RSGroup new.
	result do: [ :coll | 
		st := coll asArray sortedAs: #asString. 
		resultWithGroups add: st asGroup ].
	^ resultWithGroups

"	| clusters groupToBeIncluded g |
	clusters := RSGroup new.
	
	shapes do: [ :s |
		groupToBeIncluded := s incomingShapes 
									ifEmpty: [ nil ]
									ifNotEmpty: [
			 									clusters detect: [ :group | group includes: s incomingShapes anyOne ] ifNone: [ nil ] ].
		groupToBeIncluded 
			ifNil: [ g := RSGroup new. g add: s. clusters add: g ]
			ifNotNil: [ groupToBeIncluded add: s ]. 
		].
	
	self assert: ((clusters collect: #size) sum = (clusters collect: #yourself as: Set) size).
	^ clusters"! !

!RSClusteringLayout methodsFor: 'accessing' stamp: ''!
clustersLayout

	^ clustersLayout! !

!RSClusteringLayoutTest methodsFor: 'tests' stamp: ''!
testCycles 
	| chars canvas shapes |
	canvas := RSCanvas new.
	chars := $a to: $e.
	shapes := RSComposite models: chars forEach: [ :composite :char |
		| box label |
		label := RSLabel text: char.
		box := RSBox new 
			position: label position;
			extent: label extent + 10;
			yourself.
		
		composite 
			draggable;
			add: box;
			add: label;
			yourself.
		].

	canvas addAll: shapes.
	RSLineBuilder arrowedLine
		canvas: canvas;
		withVerticalAttachPoint;
		useAssociations: 
			{$a -> $b.
			$a -> $e.
			$b -> $c.
			$c -> $d.
			$d -> $a}. "cycle"
	self should: [RSClusterLayout on: shapes] raise: Error.
	! !

!RSClusteringLayoutTest methodsFor: 'tests' stamp: ''!
testBasic

	| c shapes lb nodes |
	c := RSCanvas new.
	shapes := RSBox models: (10 to: 50).
	c addAll: shapes.

	RSFlowLayout on: shapes.

	lb := RSLineBuilder line.
	lb shapes: shapes.
	lb connectFrom: [ :nb | nb // 2 ].
	c @ RSCanvasController.


	nodes := c nodes.

	RSConditionalLayout new
		ifNotConnectedThen: RSGridLayout new;
		else: (RSClusteringLayout new
				 clustersLayout: RSFlowLayout new;
				 forEachLayout: RSTreeLayout new);
		on: nodes.

	self
		assert: (nodes collect: #position) asArray 
		equals: ((Array new: 41) at: 1 put: ((29.0@10.0)); at: 2 put: ((83.0@10.0)); at: 3 put: ((131.0@10.0)); at: 4 put: ((165.0@10.0)); at: 5 put: ((16.0@85.0)); at: 6 put: ((44.0@85.0)); at: 7 put: ((72.0@85.0)); at: 8 put: ((100.0@85.0)); at: 9 put: ((128.0@85.0)); at: 10 put: ((156.0@85.0)); at: 11 put: ((16.0@40.0)); at: 12 put: ((42.0@40.0)); at: 13 put: ((70.0@40.0)); at: 14 put: ((96.0@40.0)); at: 15 put: ((124.5@40.0)); at: 16 put: ((144.0@40.0)); at: 17 put: ((158.5@40.0)); at: 18 put: ((171.5@40.0)); at: 19 put: ((9.5@115.0)); at: 20 put: ((22.5@115.0)); at: 21 put: ((37.5@115.0)); at: 22 put: ((50.5@115.0)); at: 23 put: ((65.5@115.0)); at: 24 put: ((78.5@115.0)); at: 25 put: ((93.5@115.0)); at: 26 put: ((106.5@115.0)); at: 27 put: ((121.5@115.0)); at: 28 put: ((134.5@115.0)); at: 29 put: ((149.5@115.0)); at: 30 put: ((162.5@115.0)); at: 31 put: ((9.5@70.0)); at: 32 put: ((22.5@70.0)); at: 33 put: ((35.5@70.0)); at: 34 put: ((48.5@70.0)); at: 35 put: ((63.5@70.0)); at: 36 put: ((76.5@70.0)); at: 37 put: ((89.5@70.0)); at: 38 put: ((102.5@70.0)); at: 39 put: ((118.0@70.0)); at: 40 put: ((131.0@70.0)); at: 41 put: ((144.0@70.0)); yourself)! !

!RSClusteringLayoutTest methodsFor: 'tests' stamp: ''!
testBasic2

	| shapes c lb nodes clusters |
	c := RSCanvas new.
	shapes := RSBox models: (10 to: 50).
	c addAll: shapes.

	RSFlowLayout on: shapes.

	lb := RSLineBuilder line.
	lb shapes: shapes.
	lb connectFrom: [ :nb | nb // 2 ].
	c @ RSCanvasController.


	nodes := c nodes.

	clusters := RSClusteringLayout new getClusterFor: nodes.
	self assert: clusters size equals: 10.! !

!RSClusteringLayoutTest methodsFor: 'tests' stamp: ''!
testBasic3

	| c shapes lb nodes clusters |
	c := RSCanvas new.
	shapes := RSBox models: (1 to: 50).
	c addAll: shapes.

	RSFlowLayout on: shapes.

	lb := RSLineBuilder line.
	lb shapes: shapes.
	lb connectFrom: [ :nb | nb // 2 ].
	c @ RSCanvasController.

	nodes := c nodes.

	clusters := RSClusteringLayout new getClusterFor: nodes.
	self assert: clusters size equals: 1.! !

!RSColorPalette commentStamp: ''!
Each ColorPalette is a set of beautiful color schemes in a context for a specific purpose.

Each palette contains several color schemes. Each scheme can be selected in different numbers of colors: 3 or 5 or 11 (depends on each scheme).

We have three palettes:
- Qualitative: helps to distinguish different classes of data. 
- Sequential: useful for showing graduable data with a very light "low color" increasing darkness to "high color".
- Diverging: it contains color scales with diverging colors on the extremes and transition colors from one extreme to the other. 

More detailed information is on it class comments.

To see the palettes:
RSShapeBasicExamples new example34PaletteVisualization open

---Copyright:
All colors, palettes and schemes are from www.ColorBrewer.org by Cynthia A. Brewer, Geography, Pennsylvania State University.
Code by Cynthia is under the Apache License 2.0 (https://github.com/axismaps/colorbrewer/blob/master/LICENCE.txt)
Roassal3 is distributed under the MIT License, which is compatible with Apache License 2.0 !
!RSColorPalette methodsFor: 'instance creation' stamp: ''!
fromTriplet: array
	^ NSScale ordinal
		range: (array collect: [ :arr | 
			Color
				r: arr first
				g: arr second
				b: arr third
				range: 255 ]);
		yourself! !

!RSColorPalette class methodsFor: 'accessing' stamp: ''!
paletteName
	^ self subclassResponsibility! !

!RSColorPalette class methodsFor: 'instance creation' stamp: ''!
qualitative
	^ RSQualitativeColorPalette new! !

!RSColorPalette class methodsFor: 'instance creation' stamp: ''!
sequential
	^ RSSequentialColorPalette new! !

!RSColorPalette class methodsFor: 'instance creation' stamp: ''!
diverging
	^ RSDivergingColorPalette new! !

!RSColorSelection commentStamp: ''!
Highlight the target class from the canvas to a darker color in one second!
!RSColorSelection methodsFor: 'instance creation' stamp: ''!
on: aCanvas
	| shape c1 c2 |
	shape := aCanvas shapeFromModel: self targetClass.
	(shape isNil or: [ aCanvas nodes size < 3 ]) ifTrue: [ ^ self ].
	shape := shape children first.
	c1 := shape color.
	c2 := c1 muchDarker.
	aCanvas newAnimation
		duration: 1 second;
		scale: (NSScale linear 
			domain: #(0 0.25 0.5 0.75 1);
			range: {c1. c2. c1. c2. c1});
		on: shape set: #color:. ! !

!RSColoredTreePalette commentStamp: ''!
Set the colors on a tree, based on the number of leaves

```
c := RSCanvas new.
nodes := RSBox models: (1 to: 10).
c addAll: nodes.
nodes @ RSPopup.
lb := RSLineBuilder orthoVertical.
lb withVerticalAttachPoint.
lb shapes: nodes.
lb connectFrom: [ :nb | nb // 2 ].

RSTreeLayout on: nodes.

c @ RSCanvasController.

ctp := RSColoredTreePalette new.
ctp shapes: c nodes.
ctp assignColor.

c.
```

```
m := RSMondrian new.
m nodes: Collection withAllSubclasses.

m orthoVerticalLine 
	connectFrom: #superclass.
m layout tree.
m normalizeSize: #numberOfLinesOfCode.
m build.

ctp := RSColoredTreePalette new.
ctp shapes: m canvas nodes.
ctp assignColor.

m canvas
```

!
!RSColoredTreePalette methodsFor: 'private' stamp: ''!
allLeavesAccessibleFrom: aShape in: result

	aShape numberOfOutgoingLines = 0 
		ifTrue: [
			result add: self ]
		ifFalse: [ 
			 (aShape outgoingLines collect: #to) do: [ :s | self allLeavesAccessibleFrom: s in: result ]
			 ]
! !

!RSColoredTreePalette methodsFor: 'private' stamp: ''!
assignColorToChildren: children low: low high: high
	| step hs |
	step := high - low / children size.
	hs := low to: high count: children size.

	children with: hs do: [ :s :h |
		self assignColorToRoot: s h: (h min: 360 max: 0)
	]
	! !

!RSColoredTreePalette methodsFor: 'accessing' stamp: ''!
totalNumberOfLeaves
	"Return the total number of leaves"
	^ totalNumberOfLeaves! !

!RSColoredTreePalette methodsFor: 'private' stamp: ''!
assignColorToRoot: aRootShape
	self assignColorToRoot: aRootShape h: 360 / 2! !

!RSColoredTreePalette methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	alpha := 1.0! !

!RSColoredTreePalette methodsFor: 'accessing' stamp: ''!
shapes: someShapes
	"Set the shapes (the nodes) that must be colored"
	shapes := someShapes.
	totalNumberOfLeaves := 0.
	(someShapes select: [ :s | s numberOfIncomingLines = 0 ]) do: [ :s | 
		totalNumberOfLeaves := totalNumberOfLeaves + (self allLeavesAccessibleFrom: s)
	]! !

!RSColoredTreePalette methodsFor: 'accessing' stamp: ''!
shapes

	^ shapes! !

!RSColoredTreePalette methodsFor: 'private' stamp: ''!
assignColorToRoot: aRootShape h: h
	| children span |
	
	aRootShape color: ((Color h: h s: 1 v: 1) alpha: alpha).

	children := aRootShape outgoingShapes.
	children ifEmpty: [ ^ self ].
	span := (self allLeavesAccessibleFrom: aRootShape) * 360 / (totalNumberOfLeaves * 2).
	self assignColorToChildren: children low: h - (span / 2) high: h + (span / 2).! !

!RSColoredTreePalette methodsFor: 'private' stamp: ''!
allLeavesAccessibleFrom: aRootShape 

	| c |
	c := OrderedCollection new.
	self allLeavesAccessibleFrom: aRootShape in: c.
	^ c size! !

!RSColoredTreePalette methodsFor: 'accessing' stamp: ''!
alpha: alphaValueAsFloat
	"Set the transparency of the colors. Take as argument a number between 0.0 and 1.0"
	alpha := alphaValueAsFloat! !

!RSColoredTreePalette methodsFor: 'public' stamp: ''!
assignColor

	| roots |
	roots := shapes select: [ :s | s numberOfIncomingLines = 0 ].
	roots do: [ :r | self assignColorToRoot: r ]! !

!RSColoredTreePaletteTest methodsFor: 'tests' stamp: ''!
testBasic

	| c nodes lb ctp node1 node2 node3 |
	c := RSCanvas new.
	nodes := RSBox models: (1 to: 10).
	c addAll: nodes.
	nodes @ RSPopup.
	lb := RSLineBuilder orthoVertical.
	lb withVerticalAttachPoint.
	lb shapes: nodes.
	lb connectFrom: [ :nb | nb // 2 ].

	RSTreeLayout on: nodes.

	c @ RSCanvasController.
	
	node1 := c shapeFromModel: 1. "The root"
	node2 := c shapeFromModel: 2. "Right below 1"
	node3 := c shapeFromModel: 3. "Right below 1"
	
	self assert: node1 color == node2 color.
	self assert: node3 color == node2 color.
	
	"Assign the color"
	ctp := RSColoredTreePalette new.
	ctp shapes: c nodes.
	ctp assignColor.

	self assert: node3 color ~= node2 color.
	self assert: node1 color ~= node2 color.
	

	! !

!RSColoredTreePaletteTest methodsFor: 'tests' stamp: ''!
testPalettes

	RSColorPalette subclasses do: [ :cls |
		cls selectors do: [ :sel | cls new perform: sel ] ]! !

!RSColoredTreePaletteTest methodsFor: 'tests' stamp: ''!
testLeaves

	| c nodes lb ctp node1 node2 node3 |
	c := RSCanvas new.
	nodes := RSBox models: (1 to: 10).
	c addAll: nodes.
	nodes @ RSPopup.
	lb := RSLineBuilder orthoVertical.
	lb withVerticalAttachPoint.
	lb shapes: nodes.
	lb connectFrom: [ :nb | nb // 2 ].

	RSTreeLayout on: nodes.

	c @ RSCanvasController.
	
	node1 := c shapeFromModel: 1. "The root"
	node2 := c shapeFromModel: 2. "Right below 1"
	node3 := c shapeFromModel: 3. "Right below 1"
	
	"Assign the color"
	ctp := RSColoredTreePalette new.
	ctp shapes: c nodes.
	ctp assignColor.
	
	self assert: ctp totalNumberOfLeaves equals: 5! !

!RSComposite commentStamp: ''!
I am a composite shapes. I can therefore contain other shapes.

Here is a simple example:
```
c := RSCanvas new.

box := RSBox new width: 40; height: 10; color: Color blue.
label := RSLabel new text: 'Hello Roassal3'.
RSLocation new above; move: box on: label.
composite := RSComposite new.
composite shapes: { label . box }.
composite @ RSDraggable.

c add: composite.
c open
```

A composite can also have a background color. Simply use #color: for this:
```
c := RSCanvas new.

box := RSBox new width: 40; height: 10; color: Color blue.
label := RSLabel new color: Color black; text: 'Hello Roassal3'.
RSLocation new above; move: box on: label.
composite := RSComposite new.
composite color: Color gray.
composite shapes: { label . box }.
composite @ RSDraggable.

c add: composite.
c open
```

A padding describes a space between the border of the composite element and the inner shapes. It can be adjusted using the message #padding:

```
c := RSCanvas new.

box := RSBox new width: 40; height: 10; color: Color blue.
label := RSLabel new color: Color black; text: 'Hello Roassal3'.
RSLocation new above; move: box on: label.
composite := RSComposite new.
composite color: Color gray.
composite shapes: { label . box }.
composite @ RSDraggable.
composite padding: 10.

c add: composite.
c open
```

Inner nodes can be layouted:
```
classes := RSObject withAllSubclasses.

c := RSCanvas new.

classes do: [ :cls |
	label := RSLabel new text: cls name.
	methods := 
		cls methods collect: [ :m |
			RSBox new model: m; size: m sourceCode size sqrt; color: Color blue ] as: RSGroup.
	RSGridLayout on: methods.
	methods @ RSPopup.
	RSLocation new above; move: label on: methods.
	composite := RSComposite new.
	composite color: Color gray.
	composite shapes: { label }, methods.
	composite @ RSDraggable.
	composite padding: 10.
	c add: composite.
].

RSFlowLayout on: c shapes.

c @ RSCanvasController.
c open
```

Lines can be added between composite. Here is an example:
```
classes := RSObject withAllSubclasses.

c := RSCanvas new.

classes do: [ :cls |
	label := RSLabel new text: cls name.
	methods := 
		cls methods collect: [ :m |
			RSBox new model: m; size: m sourceCode size sqrt; color: Color blue ] as: RSGroup.
	RSGridLayout on: methods.
	methods @ RSPopup.
	RSLocation new above; move: label on: methods.
	composite := RSComposite new.
	composite model: cls.
	composite color: Color gray.
	composite shapes: { label }, methods.
	composite @ RSDraggable.
	composite padding: 10.
	c add: composite.
].

RSEdgeBuilder orthoVertical
	canvas: c;
	withVerticalAttachPoint;
	connectFrom: #superclass.

RSTreeLayout on: c nodes.

c @ RSCanvasController.
c open.
```!
!RSComposite methodsFor: 'accessing' stamp: ''!
padding: anObject
	"Set the padding, i.e., the distance between the nested shapes and the outter composite shape.
The argument, anObject can be a number, a point or Margin. 

IMPORTANT:
- The shapes must be added in the composite before calling #padding:
- The padding must be set after having performed #adjustToChildren
	
Here is an example of usage:
```Smalltalk
box := RSBox new
    color: Color blue translucent;
    fromRectangle: ((-38.5@ -20.0) corner: (38.5@20.0));
    yourself.
label := RSLabel new
    text: 'Smalltalk';
    yourself.
g := RSGroup new.
g add: box.
g add: label.
composite := g asShape.
composite padding: 20.
composite color: Color red.

c := RSCanvas new.
c add: composite.

c
```
	"
	
	| margin rect center temp |
	temp := children 
		ifNil: [ RSGroup new: 0 ]
		ifNotNil: [children].
	margin := anObject asMargin. 
	rect := temp encompassingRectangle.
	rect := margin expandRectangle: rect.
	self extent: rect extent.
	
	(center := rect floatCenter) = (0@0) ifTrue: [ ^ self ].
	center := center negated.
	temp do: [ :s | s basicTranslateBy: center ].! !

!RSComposite methodsFor: 'adding nodes edges' stamp: ''!
addLine: aShape
	self lines add: aShape.
	^ aShape! !

!RSComposite methodsFor: 'accessing' stamp: ''!
children
	^ children ifNil: [ children := RSGroup new ]! !

!RSComposite methodsFor: 'removing' stamp: ''!
removeEdge: anEdge
	self edges remove: anEdge ifAbsent: [  ].! !

!RSComposite methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModels: someObjects
	"Retreive a shape from a given model. Return nil if not found"
	| result |
	result := RSGroup new.
	self deepShapesFromModels: someObjects result: result.
	^ result! !

!RSComposite methodsFor: 'actions' stamp: ''!
pushBackEdges
	"Push back all the edges"
	self edges do: [ :e | e pushBack ]! !

!RSComposite methodsFor: 'private' stamp: ''!
privateEdges
	^ edges! !

!RSComposite methodsFor: 'private' stamp: ''!
privateShapes: aCollection
	children := aCollection! !

!RSComposite methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModel: anObject result: result
	"Private method"
	self model = anObject ifTrue: [ result add: self ].
	self nodes do: [ :c | c deepShapesFromModel: anObject result: result ]! !

!RSComposite methodsFor: 'adding nodes edges' stamp: ''!
addNode: aShape
	self nodes add: aShape.
	^ aShape! !

!RSComposite methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"
	| result |
	result := RSGroup new.
	self deepShapesFromModel: anObject result: result.
	^ result! !

!RSComposite methodsFor: 'accessing - computed' stamp: ''!
shapeWithAction: eventClass forPosition: position
	| res pos |
	pos := self matrix rsInverseTransform: position.
	self shapes reverseDo: [ :s |
		res := s shapeWithAction: eventClass forPosition: pos.
		res ifNotNil: [ ^ res] ].
	
	^ super shapeWithAction: eventClass forPosition: position.! !

!RSComposite methodsFor: 'private' stamp: ''!
privateEdges: aRSGroup
	edges := aRSGroup! !

!RSComposite methodsFor: 'accessing' stamp: ''!
allChildren
	| allChildren index |
	index := 1.
	allChildren := OrderedCollection withAll: self children.
	[ index <= allChildren size ] whileTrue: [ 
		allChildren addAll: ((allChildren at: index) children ifNil: [#()]).
		index := index + 1 ].
	^ allChildren! !

!RSComposite methodsFor: 'adding' stamp: ''!
addFixedShape: aShape
	self error: 'Composite can not add a fixed shape'! !

!RSComposite methodsFor: 'removing' stamp: ''!
removeShape: shape
	| evt |
	children remove: shape.
	shape parent: nil.
	evt := RSShapeRemovedEvent new shape: shape.
	self announce: evt.
	shape announce: evt.
	! !

!RSComposite methodsFor: 'looking up shapes' stamp: ''!
deepShapeFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"
	| result |
	result := RSGroup new.
	self deepShapeFromModel: anObject result: result.
	result isEmpty ifTrue: [ ^ nil ].
	^ result first! !

!RSComposite methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self paint: nil.
	self resetPath.
	! !

!RSComposite methodsFor: 'adding nodes edges' stamp: ''!
addEdge: aShape
	self edges add: aShape.
	^ aShape! !

!RSComposite methodsFor: 'private' stamp: ''!
privateNodes
	^ nodes! !

!RSComposite methodsFor: 'accessing' stamp: ''!
shapes: aRSGroup
	self children: aRSGroup! !

!RSComposite methodsFor: 'accessing' stamp: ''!
shapes
	^ self children! !

!RSComposite methodsFor: 'accessing' stamp: ''!
numberOfNodes
	"Return the number of nodes contained in the container"
	^ self privateNodes
		ifNil: [ 0 ]
		ifNotNil: [ :aGroupOfNodes | aGroupOfNodes size ]! !

!RSComposite methodsFor: 'accessing' stamp: ''!
camera
	^ parent camera! !

!RSComposite methodsFor: 'accessing' stamp: ''!
children: aRSGroup
	"
	create a groups of elements or trachel shapes, then added them to this composite shape
	this method changes the position of the shapes and set the position of this composite shape
	to the center of the encompassingRectangle.
	"
	aRSGroup copy do: [ :s | 
		s isInACanvas 
			ifTrue: [ s remove ] ].
	self addAll: aRSGroup.
	self adjustToChildren.

	! !

!RSComposite methodsFor: 'public' stamp: ''!
resetChildren
	children := nil.! !

!RSComposite methodsFor: 'public' stamp: ''!
adjustToChildren
"Recompute the encompassing rectangle of the composite shape from the position of the children. 

In case one wishes to have a padding in the composite, the method #padding: must be called _after_ calling #adjustToChildren

Consider the following example:
```Smalltalk
box := RSBox new size: 20.
circle := RSEllipse new size: 20.
g := RSGroup new.
g add: box; add: circle.
composite := g asShape.
composite extent. '=> (20.0@20.0)'

RSVerticalLineLayout on: g.
composite extent. '=> (20.0@20.0)'
composite adjustToChildren.
composite extent '=> (20.0@50.0)'
```
"
	| rect delta |
	children ifNil: [ ^ self ].
	rect := children encompassingRectangle.
	delta := rect floatCenter negated.
	
	children do: [ :s | s basicTranslateBy: delta ].
	self 
		extent: rect extent;
		translateTo: delta negated.! !

!RSComposite methodsFor: 'adding' stamp: ''!
addShape: aShape
	aShape addedIn: self! !

!RSComposite methodsFor: 'accessing' stamp: ''!
lines
	"Return all the lines contained in the canvas."
	^ self privateEdges
		ifNil: [ | res |
			self privateEdges: (res := RSGroup new).
			res ]! !

!RSComposite methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModels: someObjects result: result
	"Private method"
	(someObjects includes: self model) ifTrue: [ result add: self ].
	self nodes do: [ :c | c deepShapesFromModels: someObjects result: result ]! !

!RSComposite methodsFor: 'looking up shapes' stamp: ''!
shapeFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"

	^ self nodes shapeFromModel: anObject! !

!RSComposite methodsFor: 'edges - deprecated' stamp: ''!
updateConnectedEdges
	"Update the edge connected to elements contained in the composite. This happens when a shape is drag and dropped. For example:
	
-=-=-=-=-=-=-=-=-=
c := RSCanvas new.

c add: (RSLabel new text: 'I am connected to'; model: 0).
c shapes first translateBy: -50 @ 50.

g := RSGroup new.
g add: (RSLabel new text: '1'; model: 1).
g add: (RSLabel new text: '2'; model: 2).
RSHorizontalLineLayout on: g.
composite := g asShape.
composite color: Color lightBlue.
c add: composite.

c shapes @ RSDraggable.

c add: (RSLine new color: Color red; from: c shapes first; to: g first).
c add: (RSLine new color: Color red; from: c shapes first; to: g second).
c @ RSCanvasController
-=-=-=-=-=-=-=-=-=
"
	self shouldUpdateEdges 
		ifTrue: [ connectedLines do: [ :edge | edge update ] ].
	self children do: [ :child | 
		child isNode
			ifTrue: [ child updateConnectedEdges ] ]! !

!RSComposite methodsFor: 'adding nodes edges' stamp: ''!
add: aShape
	self
		assert: aShape notNil
		description: 'Nil cannot be added to a canvas'.
	aShape 
		addedIn: self;
		renderOn: self.
	^ aShape! !

!RSComposite methodsFor: 'accessing' stamp: ''!
numberOfEdges
	"Return the number of edges contained in the container"
	^ self privateEdges
		ifNil: [ 0 ]
		ifNotNil: [ :aGroupOfEdges | aGroupOfEdges size ]! !

!RSComposite methodsFor: 'looking up shapes' stamp: ''!
shapesFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"

	^ self nodes shapesFromModel: anObject! !

!RSComposite methodsFor: 'testing' stamp: ''!
hasChildren
	^ children notNil and: [ children isNotEmpty ]! !

!RSComposite methodsFor: 'adding' stamp: ''!
addBasicShape: aShape
	self shapes add: aShape! !

!RSComposite methodsFor: 'path' stamp: ''!
sessionChanged
	"This method releases all the native graphical resources. This method is typically invoked when starting a Pharo image with a visualization that was previously open"
	self resetPath.
	children ifNil: [ ^ self ].
	children do: #sessionChanged! !

!RSComposite methodsFor: 'accessing - computed' stamp: ''!
shapeWithActionForPosition: position
	| res pos |
	pos := self matrix rsInverseTransform: position.
	self shapes reverseDo: [ :s |
		res := s shapeWithActionForPosition: pos.
		res ifNotNil: [ ^ res] ].
	^ super shapeWithActionForPosition: position.! !

!RSComposite methodsFor: 'accessing' stamp: ''!
edges
	"Return all the lines contained in the canvas."
	^ self privateEdges
		ifNil: [ | res |
			self privateEdges: (res := RSGroup new).
			res ]! !

!RSComposite methodsFor: 'adding' stamp: ''!
addRecursivelyIn: aCollection
	super addRecursivelyIn: aCollection.
	self shapes do: [ :n | n addRecursivelyIn: aCollection ]! !

!RSComposite methodsFor: 'actions' stamp: ''!
pushBack: aShape
	"Put a shape behind all other shapes"
	children
		remove: aShape;
		addFirst: aShape! !

!RSComposite methodsFor: 'accessing' stamp: ''!
withAllChildren
	^ self allChildren
		add: self;
		yourself! !

!RSComposite methodsFor: 'accessing' stamp: ''!
nodes 
	"Return all the shapes except lines contained in the canvas."
	^ self privateNodes
		ifNil: [ | res |
			self privateNodes: (res := RSGroup new).
			res ]! !

!RSComposite methodsFor: 'adding' stamp: ''!
addAllShapes: aCollection
	self assert: [ aCollection isCollection ] description: 'Need to provide a collection as argument'.
	self assert: [ aCollection allSatisfy: [ :e | e isKindOf: RSShape ] ] description: 'Need to provide a collection of RSShape'.
	aCollection do: [ :shape | self addShape: shape ].! !

!RSComposite methodsFor: 'path' stamp: ''!
resetPath
	path := baseRectangle! !

!RSComposite methodsFor: 'private' stamp: ''!
privateShapes
	^ children! !

!RSComposite methodsFor: 'removing' stamp: ''!
removeNode: aNode
	self nodes remove: aNode ifAbsent: [  ].! !

!RSComposite methodsFor: 'actions' stamp: ''!
pushFront: shape
	children 
		remove: shape ifAbsent: [];
		addLast: shape. 
	! !

!RSComposite methodsFor: 'lines' stamp: ''!
updateConnectedLines
	"Update the lines connected to elements contained in the composite. This happens when a shape is drag and dropped. For example:
	
```
c := RSCanvas new.

c add: (RSLabel new text: 'I am connected to'; model: 0).
c shapes first translateBy: -50 @ 50.

g := RSGroup new.
g add: (RSLabel new text: '1'; model: 1).
g add: (RSLabel new text: '2'; model: 2).
RSHorizontalLineLayout on: g.
composite := g asShape.
composite color: Color lightBlue.
c add: composite.

c shapes @ RSDraggable.

c add: (RSLine new color: Color red; from: c shapes first; to: g first).
c add: (RSLine new color: Color red; from: c shapes first; to: g second).
c @ RSCanvasController
```
"
	self shouldUpdateLines 
		ifTrue: [ connectedLines do: [ :line | line update ] ].
	self children do: [ :child | 
		child isNode
			ifTrue: [ child updateConnectedLines ] ]! !

!RSComposite methodsFor: 'adding' stamp: ''!
addShape: aShape before: otherShape 
	"Add a shape in a composite shape"
	aShape addedIn: self.
	self children
		remove: aShape;
		add: aShape before: otherShape! !

!RSComposite methodsFor: 'private' stamp: ''!
privateNodes: aRSGroup
	nodes := aRSGroup! !

!RSComposite methodsFor: 'adding nodes edges' stamp: ''!
addAll: aCollection
	"Add a collection of shapes to the canvas. The argument is a collection of shapes."
	self assert: [ aCollection isCollection ] description: 'Need to provide a collection as argument'.
	self assert: [ aCollection allSatisfy: [ :e | e isKindOf: RSShape ] ] description: 'Need to provide a collection of RSShape'.
	
	"Add each shape"
	aCollection do: [ :aShape | self add: aShape ]! !

!RSComposite methodsFor: 'public' stamp: ''!
resizeWithChildrenTo: aPointExtent
	self scaleBy: aPointExtent / self baseRectangle extent
	! !

!RSComposite methodsFor: 'looking up shapes' stamp: ''!
deepShapeFromModel: anObject result: result
	"Private method"
	| t |
	t := self shapeFromModel: anObject.
	t ifNotNil: [ result add: t ].
	self nodes do: [ :c | c deepShapeFromModel: anObject result: result ]! !

!RSComposite class methodsFor: 'public - creation' stamp: ''!
models: someObjects forEach: twoArgsBlock
	"This method returns a collection (RSGroup) of composite shapes, for which each shape is defined using the the oneArgBlock. 
	
For example:
```
classes := ByteArray withAllSubclasses.

c := RSCanvas new.

boxes := RSComposite models: classes forEach: [ :cls :c |
	c add: (RSLabel new text: cls name).
	c add: (RSBox new size: cls numberOfLinesOfCode sqrt).
	c model: cls.
	RSVerticalLineLayout new alignCenter; on: c shapes.
	c @ RSDraggable.
].

c addAll: boxes. 
RSFlowLayout on: c shapes.

lb := RSLineBuilder line.
lb withVerticalAttachPoint.
lb shapes: boxes.
lb connectFrom: #superclass.

RSTreeLayout on: c nodes.
c @ RSCanvasController.
c open
```	
"

	^ someObjects
		  collect: [ :obj | 
				| t |
		  		t := twoArgsBlock valueWithArguments: (Array with: (self model: obj) with: obj).
				t adjustToChildren ]
		  as: RSGroup! !

!RSComposite class methodsFor: 'public - creation' stamp: ''!
model: anObject forIt: twoArgsBlock
	"This method returns a collection (RSGroup) of composite shapes, for which each shape is defined using the the twoArgsBlock. The variable twoArgsBlock points to a two argument block. The first argument is the object model, and the second argument is the composite.
	
For example:
```
c := RSCanvas new.

compoShape := RSComposite model: 'Hello' forIt: [ :composite :title |
	composite add: (RSLabel text: title).
	composite add: (RSCircle new size: 20).
	RSVerticalLineLayout new alignCenter; on: composite shapes.
	composite @ RSDraggable ].
c add: compoShape.

c open 
```	
"

	^ (self models: (Array with: anObject) forEach: twoArgsBlock) first! !

!RSCompositeAnimation commentStamp: ''!
Super class of composite animations!
!RSCompositeAnimation methodsFor: 'adding' stamp: ''!
add: anAnimation
	animations add: anAnimation ! !

!RSCompositeAnimation methodsFor: 'accessing' stamp: ''!
animations
	^ animations! !

!RSCompositeAnimation methodsFor: 'private' stamp: ''!
startIfNessesary: animation
	animation isRunning ifTrue: [ ^ self ].
	animation canvas: self canvas.
	animation start! !

!RSCompositeAnimation methodsFor: 'adding' stamp: ''!
addAll: array
	animations addAll: array.! !

!RSCompositeAnimation methodsFor: 'initialization' stamp: ''!
reset
	super reset.
	animations := OrderedCollection new.! !

!RSCompositeAnimation class methodsFor: 'accessing - defaults' stamp: ''!
defaultDuration
	^ 0 seconds! !

!RSCompositeTest commentStamp: ''!
I am test class for composite shapes in roassal!
!RSCompositeTest methodsFor: 'tests' stamp: ''!
testEdgesCanvasAndComposite04
	"from child to child"
	| c b1 b2 e1 com1 com2 |
	c := RSCanvas new.
	com1 := RSComposite new.
	b1 := RSBox new size: 10; position: 0@0.
	com1 add: b1.
	com1 adjustToChildren.
	b1 position: 50@50.
	com1 position: 200@0.
	
	com2 := RSComposite new.
	b2 := RSBox new size: 10.
	com2 add: b2.
	com2 adjustToChildren.
	com2 position: -100@0.
	b2 position: 100@100.
	
	e1 := RSLine new from: b1; to: b2.
	c addAll: { com1. com2. e1 }.
	
	self assert: e1 startPoint equals: com1 position + b1 position.
	self assert: e1 endPoint equals: com2 position + b2 position.! !

!RSCompositeTest methodsFor: 'tests' stamp: ''!
testEdgesCanvasAndComposite02
	"basic example in composite"
	| c b1 b2 e1 |
	c := RSComposite new.
	b1 := RSBox new position: 0@0.
	b2 := RSBox new position: 100@100.
	e1 := RSLine new from: b1; to: b2.
	c shapes: { b1. b2. e1 }.
	
	self assert: e1 startPoint equals: b1 position.
	self assert: e1 endPoint equals: b2 position.! !

!RSCompositeTest methodsFor: 'tests' stamp: ''!
testEdgesCanvasAndComposite01
	"basic case in a canvas"
	| c b1 b2 e1 |
	c := RSCanvas new.
	b1 := RSBox new position: 0 @ 0.
	b2 := RSBox new position: 100 @ 100.
	e1 := RSLine new from: b1; to: b2.
	c addAll: { b1. b2. e1 }.
	
	self assert: e1 startPoint equals: b1 position.
	self assert: e1 endPoint equals: b2 position.! !

!RSCompositeTest methodsFor: 'tests' stamp: ''!
testHasChildren
	| b |
	b := RSComposite new.
	self deny: b hasChildren.
	b shapes: {}.
	self deny: b hasChildren.
	b shapes: {RSBox new. RSEllipse new}.
	self assert: b hasChildren.! !

!RSCompositeTest methodsFor: 'tests' stamp: ''!
testPaddingOkay
	"No error should be raised"
	
	RSComposite new
		shapes: (RSGroup new add: RSBox new; yourself);
		padding: 5.

	RSComposite new
		shapes: (RSGroup new add: RSBox new; add: RSBox new; yourself);
		padding: 5.
		
	RSComposite new
		shapes: (RSGroup new);
		padding: 5.! !

!RSCompositeTest methodsFor: 'tests' stamp: ''!
testAdjustChildren

	| box circle g composite |
	box := RSBox new size: 20.
	circle := RSEllipse new size: 20.
	g := RSGroup new.
	g add: box; add: circle.
	composite := g asShape.
	self assert: composite extent equals: (20 @ 20). 

	RSVerticalLineLayout on: g.
	self assert: composite extent equals: (20 @ 20).
	composite adjustToChildren.
	self assert: composite extent equals: (20 @ 50).

! !

!RSCompositeTest methodsFor: 'tests' stamp: ''!
testModelForIt

	| s |
	s := RSComposite model: 42 forIt: [ :ss :obj | ss model: (obj + 1). ss color: Color pink ].
	self assert: s class equals: RSComposite.
	self assert: s model equals: 43.
	self assert: s color equals: Color pink! !

!RSCompositeTest methodsFor: 'tests' stamp: ''!
testPositionInCanvas
	| box composite canvas |
	canvas := RSCanvas new.
	box := RSBox new
		size: 100;
		yourself.
	composite := RSComposite new
		shapes: { box };
		position: 100@100;
		yourself.
	canvas add: composite.
	box translateTo: 10@10.
	self assert: composite position equals: 100@100.
	self assert: composite positionInCanvas equals: 100@100.
	self assert: box position equals: 10@10.
	self assert: box positionInCanvas equals: 110@110.! !

!RSCompositeTest methodsFor: 'tests' stamp: ''!
testEdgesCanvasAndComposite03
	"from box to child"
	| c b1 b2 e1 com |
	c := RSCanvas new.
	com := RSComposite new.
	b1 := RSBox new size: 10; position: 0@0.
	com add: b1.
	com adjustToChildren.
	b1 position: 50@50.
	com position: 200@0.
	b2 := RSBox new size: 10; position: 100@100.
	e1 := RSLine new from: b1; to: b2.
	c addAll: { com. b2. e1 }.
	
	self assert: e1 startPoint equals: com position + b1 position.
	self assert: e1 endPoint equals: b2 position.! !

!RSCompositeTest methodsFor: 'tests' stamp: ''!
testEdgesCanvasAndComposite05
	"from child to box, where the edge is with the child"
	| c b1 b2 e1 com |
	c := RSCanvas new.
	com := RSComposite new.
	b1 := RSBox new size: 10; position: 50@50.
	com add: b1.
	com position: 200@0.
	b2 := RSBox new size: 10; position: 100@100.
	e1 := RSLine new from: b1; to: b2.
	
	com add: e1.
	com adjustToChildren.
	c addAll: { com. b2. }.
	
	self assert: e1 startPoint equals: b1 position.
	"but b2 is not in the space of com"
	self assert: e1 endPoint equals: b2 position.
	
	! !

!RSConditionalLayout commentStamp: ''!
<keyClass>
`RSConditionalLayout` applies two layouts on a set of shapes using a condition

*Responsibility*: Shapes matching a given condition use a particular layout, else another layout is applied 

*Collaborators*: Shapes and layouts

*Variables*:
- `if`: one-arg block or symbol to be applied on a shape. Must return a boolean when applied. 
- `thenLayout`: a layout used for the shapes that matches the condition
- `thenLayout `: a layout used for the shapes that do not match the condition

*Example*:
```Smalltalk
classes := Collection allSubclasses.
shapes := classes collect: [ :c | RSBox new size: 10; model: c ] as: RSGroup.

c := RSCanvas new.
c addAll: shapes.
eb := RSEdgeBuilder orthoVertical.
eb canvas: c.
eb withVerticalAttachPoint.
eb shapes: shapes.
eb connectFrom: #superclass.

"RSTreeLayout on: shapes."
RSConditionalLayout new
	ifNotConnectedThen: RSGridLayout new;
	else: RSTreeLayout new;
	on: shapes.
c @ RSCanvasController
```

Another example:

```Smalltalk
classes := Collection allSubclasses.
shapes := classes collect: [ :c | RSBox new size: 10; model: c ] as: RSGroup.

c := RSCanvas new.
c addAll: shapes.
eb := RSEdgeBuilder orthoVertical.
eb canvas: c.
eb withVerticalAttachPoint.
eb shapes: shapes.
eb connectFrom: #superclass.

"RSTreeLayout on: shapes."
RSConditionalLayout new
	ifConnectedThen: RSTreeLayout new;
	else: RSGridLayout new;
	on: shapes.
c @ RSCanvasController
```!
!RSConditionalLayout methodsFor: 'accessing' stamp: ''!
if: aOneArgBlockOrSymbol
	"Take as argument a block that will be used on the shapes. The block should return a boolean"
	if := aOneArgBlockOrSymbol! !

!RSConditionalLayout methodsFor: 'accessing' stamp: ''!
ifNotConnectedThen: aLayout
	self if: [ :shape | shape hasEdges not ].
	self then: aLayout! !

!RSConditionalLayout methodsFor: 'hook' stamp: ''!
doExecute: shapes
	"Performs the layout"

	| thenShapes elseShapes |
	thenShapes := (shapes select: if) asGroup.
	elseShapes := (shapes reject: if) asGroup.
	thenLayout on: thenShapes.
	elseLayout on: elseShapes.

	RSLocation new
		left;
		outer;
		offset: -20 @ 0;
		move: thenShapes on: elseShapes.
! !

!RSConditionalLayout methodsFor: 'accessing' stamp: ''!
ifConnectedThen: aLayout
	self if: [ :shape | shape hasEdges ].
	self then: aLayout! !

!RSConditionalLayout methodsFor: 'accessing' stamp: ''!
then: aLayout
	thenLayout := aLayout! !

!RSConditionalLayout methodsFor: 'accessing' stamp: ''!
if
	^ if! !

!RSConditionalLayout methodsFor: 'accessing' stamp: ''!
else: aLayout
	elseLayout := aLayout! !

!RSConfigurableCamera commentStamp: ''!
I am a camera to control the zoom interaction!
!RSConfigurableCamera methodsFor: 'accessing' stamp: ''!
zoomInteraction
	^ zoomInteraction! !

!RSConfigurableCamera methodsFor: 'zoom' stamp: ''!
zoomToFit
	| shapesRect canvasExtent sc canvasRect original int |
	int := self zoomInteraction.
	shapesRect := int encompassingRectangleFor: canvas.
	canvasExtent := canvas extent * 0.9.
	sc := canvasExtent / (self class maxExtentFor: shapesRect).
	original := sc x min: sc y.
	sc := int scaleFor: original.
	canvasRect := Rectangle 
		floatCenter: shapesRect floatCenter
		extent: canvas extent / 1.
	self translateTo: shapesRect floatCenter.
	int configuration shouldUseBasicZoom ifTrue: [ 
		(canvasRect containsRect: shapesRect )
			ifTrue: [ self scale: 1]
			ifFalse: [
				int configuration minScale: original.
				self scale: original ]
	] ifFalse: [ self scale: sc].
	int removeRectanglesFor: canvas.
	canvas signalUpdate.
	! !

!RSConfigurableCamera methodsFor: 'accessing' stamp: ''!
zoomInteraction: anInteraction
	zoomInteraction := anInteraction! !

!RSContextInteraction commentStamp: ''!
I put a default interaction for each shape in the canvas!
!RSContextInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	interactions := OrderedCollection new
		add: RSSelectionPresentationInteraction new;
		yourself.! !

!RSContextInteraction methodsFor: 'hooks' stamp: ''!
interactionsToBeRegistered
	^ interactions! !

!RSControlConfiguration commentStamp: ''!
A control configuration is made to set a configuration for the canvas. For example, by modifying a control configuraiton, you can decide if you wish to have an horizontal scrollbar or no, the minimum zoom, or maximum zoom, the padding, ...

For example:
-=-=--=-=--=-=--=-=-
c := RSCanvas new. 
controller := RSCanvasController new.
controller configuration: (RSControlConfiguration new maxScale: 10).
c @ controller.
-=-=--=-=--=-=--=-=-


-=-=--=-=--=-=--=-=-
canvas := RSCanvas new.
shapes := #('hello' 'world' 'from' 'Roassal3') collect: [ :s | RSLabel new text: s ] as: RSGroup.
canvas addAll: shapes.
RSVerticalLineLayout on: shapes.
int := RSCanvasController new.
int configuration
	minScale: 1;
	maxScale: 3.
canvas @ int.
canvas
-=-=--=-=--=-=--=-=-!
!RSControlConfiguration methodsFor: 'configuration' stamp: ''!
useZoomToFitOnExtendChanged
	zoomToFitOnExtent := true! !

!RSControlConfiguration methodsFor: 'accessing' stamp: ''!
maxScale: aNum
	"Set the maximum scale for the configuration"
	maxScale := aNum! !

!RSControlConfiguration methodsFor: 'accessing' stamp: ''!
minScale
	^ minScale! !

!RSControlConfiguration methodsFor: 'scrollbar managing' stamp: ''!
hasVerticalScrolling
	^ hasVerticalScrolling! !

!RSControlConfiguration methodsFor: 'scrollbar managing' stamp: ''!
hasHorizontalScrolling
	^ hasHorizontalScrolling! !

!RSControlConfiguration methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		minScale: 0.04;
		maxScale: 7;
		padding: 25;
		useZoomToFitOnExtendChanged;
		useZoomToFitOnStart;
		noBasicZoom;
		hasHorizontalScrolling: true;
		hasVerticalScrolling: true.! !

!RSControlConfiguration methodsFor: 'accessing' stamp: ''!
padding: aMargin
	padding := aMargin asMargin! !

!RSControlConfiguration methodsFor: 'configuration' stamp: ''!
useZoomToFitOnStart
	zoomToFitOnStart := true.! !

!RSControlConfiguration methodsFor: 'configuration' stamp: ''!
noBasicZoom
	shouldUseBasicZoom := false.! !

!RSControlConfiguration methodsFor: 'configuration' stamp: ''!
useBasicZoom
	shouldUseBasicZoom := true.! !

!RSControlConfiguration methodsFor: 'configuration' stamp: ''!
noZoomToFitOnExtendChanged
	zoomToFitOnExtent := false! !

!RSControlConfiguration methodsFor: 'configuration' stamp: ''!
noZoomToFitOnStart
	zoomToFitOnStart := false.! !

!RSControlConfiguration methodsFor: 'scrollbar managing' stamp: ''!
hasHorizontalScrolling: aBool
	hasHorizontalScrolling := aBool! !

!RSControlConfiguration methodsFor: 'testing' stamp: ''!
shouldUseBasicZoom
	^ shouldUseBasicZoom! !

!RSControlConfiguration methodsFor: 'scrollbar managing' stamp: ''!
hasVerticalScrolling: aBool
	hasVerticalScrolling := aBool! !

!RSControlConfiguration methodsFor: 'accessing' stamp: ''!
minScale: aNum
	"Set the minimum scale allowed by the configuration."
	minScale := aNum! !

!RSControlConfiguration methodsFor: 'accessing' stamp: ''!
padding
	^ padding! !

!RSControlConfiguration methodsFor: 'testing' stamp: ''!
shouldZoomToFitOnExtendChanged
	^ zoomToFitOnExtent! !

!RSControlConfiguration methodsFor: 'accessing' stamp: ''!
maxScale
	^ maxScale! !

!RSControlConfiguration methodsFor: 'testing' stamp: ''!
shouldZoomToFitOnStart
	^ zoomToFitOnStart! !

!RSControlsViewTest methodsFor: 'tests' stamp: ''!
testBasic
	| canvas controller |
	canvas := RSCanvas new.
	canvas @ RSCanvasController.
	controller := canvas controllerInteraction.
	self assert: controller class equals: RSCanvasController.
	canvas @ RSCanvasController.
	self assert: controller equals: canvas controllerInteraction.
	! !

!RSCornerRadius commentStamp: ''!
I have information about the corner radius and methods to create it!
!RSCornerRadius methodsFor: 'accessing' stamp: ''!
right: aNumber
	topRight := bottomRight := aNumber! !

!RSCornerRadius methodsFor: 'transforming' stamp: ''!
interpolateTo: other at: t
	"other is an instance of RSCornerRadius
	t is a float between 0 and 1"
	| |
	^ self class new
		topLeft: (self topLeft interpolateTo: other topLeft at: t);
		topRight: (self topRight interpolateTo: other topRight at: t);
		bottomLeft: (self bottomLeft interpolateTo: other bottomLeft at: t);
		bottomRight: (self bottomRight interpolateTo: other bottomRight at: t);
		yourself! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
topRight
	^ topRight! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
left: aNumber
	topLeft := bottomLeft := aNumber! !

!RSCornerRadius methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self radius: 0.! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
topRight: aNumber
	topRight := aNumber! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
bottomLeft: aNumber
	bottomLeft := aNumber! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
bottom: aNumber
	bottomLeft := bottomRight := aNumber! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
topLeft: aNumber
	topLeft := aNumber! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
top: aNumber
	topLeft := topRight := aNumber! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
bottomRight
	^ bottomRight ! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
topLeft
	^ topLeft ! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
min
	^ topLeft min: (topRight min: (bottomLeft min: bottomRight))! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
bottomRight: aNumber
	"Example of value could be 200"
	bottomRight := aNumber! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
bottomLeft 
	"Define the bottom left of the radius"
	^ bottomLeft! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
radius: aNumber
	topLeft := topRight := bottomLeft := bottomRight := aNumber! !

!RSCornerRadius methodsFor: 'accessing' stamp: ''!
max
	^ topLeft max: (topRight max: (bottomLeft max: bottomRight))! !

!RSCubicInterpolator commentStamp: ''!
TSEasing cubicIn
Cubic easing; equivalent to: TSEasing poly exponent: 3.

TSEasing cubicOut
Reverse cubic easing; equivalent to 1 - TSEasing cubicIn interpolate: (1 - t). Also equivalent to TSEasing polyOut exponent: 3.

TSEasing cubic 
TSEasing cubicInOut 
Symmetric cubic easing; scales cubicIn for t in {0. 0.5} and cubicOut for t in {0.5. 1}. 
Also equivalent to TSEasing poly exponent: 3.
!
!RSCubicInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateIn: t
	^ t * t * t! !

!RSCubicInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateInOut: i
	| t |
	t := i * 2.
	^ (t <= 1 
		ifTrue: [ t * t * t  ]
		ifFalse: [ 
			t := t - 2.
			t * t * t + 2 ])/2! !

!RSCubicInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateOut: i
	| t |
	t := i -1.
	^ t * t * t + 1! !

!RSCustomCPController commentStamp: ''!
I am a custom control points controller to define crazy things with controls points.
I am more like an example and not for applications!
!RSCustomCPController methodsFor: 'accessing' stamp: ''!
models: aCollection
	models := aCollection! !

!RSCustomCPController methodsFor: 'hooks' stamp: ''!
controlPointsFor: aLine
	^ self models collect: [ :m | self controlPointFor: m at: aLine ].! !

!RSCustomCPController methodsFor: 'hooks' stamp: ''!
controlPointFor: model at: aLine
	| point |
	model isPoint ifTrue: [ ^ model ].
	point  := model value.
	(model isKindOf: RSShape) ifTrue: [ 
		model addConnectedLine: aLine.
		point := model position ].
	^ point! !

!RSCustomCPController methodsFor: 'accessing' stamp: ''!
models
	^ models! !

!RSDancingSelection commentStamp: ''!
When the uml is open, this class will move the target class of the canvas, in one second!
!RSDancingSelection methodsFor: 'instance creation' stamp: ''!
on: aCanvas
	| shape p d|
	shape := aCanvas shapeFromModel: self targetClass.
	(shape isNil or: [ aCanvas nodes size < 3 ]) ifTrue: [ ^ self ].
	p := shape position.
	d := 20.
	aCanvas newAnimation
		duration: 1 second;
		scale: (NSScale linear 
			domain: #(0 0.25 0.5 0.75 1);
			range: {p. p+d. p. p+d. p});
		on: shape set: #translateTo: . ! !

!RSDefaultBinning commentStamp: ''!
TODO!
!RSDefaultBinning methodsFor: 'hooks' stamp: ''!
computeSizeFor: values
	^ 10! !

!RSDefaultTimer commentStamp: ''!
The default timer uses the pharo current time!
!RSDefaultTimer methodsFor: 'public' stamp: ''!
currentTime
	^ Time millisecondClockValue! !

!RSDependencyTest methodsFor: 'testing' stamp: ''!
hasPackage: aString 
	
	^ (self packageNamed: aString) notNil.! !

!RSDependencyTest methodsFor: 'private - asserting' stamp: ''!
assertPackage: p1Name dependOn: p2Name

	| p1 p2 |
	p1 := self packageNamed: p1Name.
	p2 := self packageNamed: p2Name.
	self assert: (p1 dependentPackages includes: p2).! !

!RSDependencyTest methodsFor: 'private - accessing' stamp: ''!
packageNamed: aSymbol
	^ RPackageOrganizer default packageNamed: aSymbol 
		ifAbsent: [ nil ]! !

!RSDependencyTest methodsFor: 'private - asserting' stamp: ''!
assertPackage: p1Name doesNotDependOn: p2Name

	| p1 p2 |
	p1 := self packageNamed: p1Name.
	p2 := self packageNamed: p2Name.
	self deny: (p1 dependentPackages includes: p2).! !

!RSDependencyTest methodsFor: 'tests' stamp: ''!
testDependencies

	self assertPackage: 'Roassal3' doesNotDependOn: 'Roassal3-Layouts'.
	self assertPackage: 'Roassal3' doesNotDependOn: 'Roassal3-Animation'.
	self assertPackage: 'Roassal3' doesNotDependOn: 'Roassal3-Builders'.
	self assertPackage: 'Roassal3' doesNotDependOn: 'Roassal3-Chart'.
	self assertPackage: 'Roassal3' doesNotDependOn: 'Roassal3-Colors'.
	self assertPackage: 'Roassal3-Shapes' doesNotDependOn: 'Roassal3-Layouts'.
	self assertPackage: 'Roassal3-Animation' dependOn: 'Roassal3'.

	"Chart uses RSLocation from Layouts"
	self assertPackage: 'Roassal3-Chart' dependOn: 'Roassal3-Layouts'.
	
	self assertPackage: 'Roassal3' dependOn: 'Announcements-Core'.! !

!RSDirectLayoutTranslator commentStamp: ''!
TODO!
!RSDirectLayoutTranslator methodsFor: 'hook' stamp: ''!
translate: element to: newPosition
	element translateTo: newPosition! !

!RSDirectLayoutTranslator class methodsFor: 'testing' stamp: ''!
isDefault
	^ true! !

!RSDirectedBezierCPAPController commentStamp: ''!
Directed controlpoints controller based on attach point from each line.

This directed bezier uses 3 control points!
!RSDirectedBezierCPAPController methodsFor: 'hooks' stamp: ''!
controlPointsFrom: fromPoint to: toPoint
	| a b vector u unit mid height width dist |
	a := fromPoint.
	b := toPoint.
	dist := a distanceTo: b.
	height := dist * 0.20.
	width := dist * 0.50.
	vector := a - b.
	u := vector normal.
	unit := vector / (vector r max: 1).
	mid := a - (unit * height).
	mid := mid + (u * width).
	^ {fromPoint.
	mid.
	toPoint.}! !

!RSDivergingColorPalette commentStamp: ''!
Diverging schemes put equal emphasis on mid-range critical values and extremes at both ends of the data range. The critical class or break in the middle of the legend is emphasized with light colors and low and high extremes are emphasized with dark colors that have contrasting hues.

Check it out by executing:
RSShapeBasicExamples new example34PaletteVisualization open

More info:
http://colorbrewer2.org/learnmore/schemes_full.html#diverging 

---Copyright:
All colors, palettes and schemes are from www.ColorBrewer.org by Cynthia A. Brewer, Geography, Pennsylvania State University.
Code by Cynthia is under the Apache License 2.0 (https://github.com/axismaps/colorbrewer/blob/master/LICENCE.txt)
Roassal3 is distributed under the MIT License, which is compatible with Apache License 2.0 !
!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylgn4
	^ self fromTriplet: #(#(215 25 28) #(253 174 97) #(166 217 106) #(26 150 65))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
brbg11
	^ self fromTriplet: #(#(84 48 5) #(140 81 10) #(191 129 45) #(223 194 125) #(246 232 195) #(245 245 245) #(199 234 229) #(128 205 193) #(53 151 143) #(1 102 94) #(0 60 48))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylbu7
	^ self fromTriplet: #(#(215 48 39) #(252 141 89) #(254 224 144) #(255 255 191) #(224 243 248) #(145 191 219) #(69 117 180))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
spectral9
	^ self fromTriplet: #(#(213 62 79) #(244 109 67) #(253 174 97) #(254 224 139) #(255 255 191) #(230 245 152) #(171 221 164) #(102 194 165) #(50 136 189))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdbu11
	^ self fromTriplet: #(#(103 0 31) #(178 24 43) #(214 96 77) #(244 165 130) #(253 219 199) #(247 247 247) #(209 229 240) #(146 197 222) #(67 147 195) #(33 102 172) #(5 48 97))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdgy5
	^ self fromTriplet: #(#(202 0 32) #(244 165 130) #(255 255 255) #(186 186 186) #(64 64 64))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
prgn11
	^ self fromTriplet: #(#(64 0 75) #(118 42 131) #(153 112 171) #(194 165 207) #(231 212 232) #(247 247 247) #(217 240 211) #(166 219 160) #(90 174 97) #(27 120 55) #(0 68 27))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdgy8
	^ self fromTriplet: #(#(178 24 43) #(214 96 77) #(244 165 130) #(253 219 199) #(224 224 224) #(186 186 186) #(135 135 135) #(77 77 77))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
piyg6
	^ self fromTriplet: #(#(197 27 125) #(233 163 201) #(253 224 239) #(230 245 208) #(161 215 106) #(77 146 33))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
spectral10
	^ self fromTriplet: #(#(158 1 66) #(213 62 79) #(244 109 67) #(253 174 97) #(254 224 139) #(230 245 152) #(171 221 164) #(102 194 165) #(50 136 189) #(94 79 162))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdbu8
	^ self fromTriplet: #(#(178 24 43) #(214 96 77) #(244 165 130) #(253 219 199) #(209 229 240) #(146 197 222) #(67 147 195) #(33 102 172))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylbu10
	^ self fromTriplet: #(#(165 0 38) #(215 48 39) #(244 109 67) #(253 174 97) #(254 224 144) #(224 243 248) #(171 217 233) #(116 173 209) #(69 117 180) #(49 54 149))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
piyg11
	^ self fromTriplet: #(#(142 1 82) #(197 27 125) #(222 119 174) #(241 182 218) #(253 224 239) #(247 247 247) #(230 245 208) #(184 225 134) #(127 188 65) #(77 146 33) #(39 100 25))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylgn5
	^ self fromTriplet: #(#(215 25 28) #(253 174 97) #(255 255 191) #(166 217 106) #(26 150 65))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
piyg7
	^ self fromTriplet: #(#(197 27 125) #(233 163 201) #(253 224 239) #(247 247 247) #(230 245 208) #(161 215 106) #(77 146 33))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdgy6
	^ self fromTriplet: #(#(178 24 43) #(239 138 98) #(253 219 199) #(224 224 224) #(153 153 153) #(77 77 77))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdbu9
	^ self fromTriplet: #(#(178 24 43) #(214 96 77) #(244 165 130) #(253 219 199) #(247 247 247) #(209 229 240) #(146 197 222) #(67 147 195) #(33 102 172))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdbu4
	^ self fromTriplet: #(#(202 0 32) #(244 165 130) #(146 197 222) #(5 113 176))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
puor3
	^ self fromTriplet: #(#(241 163 64) #(247 247 247) #(153 142 195))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylgn11
	^ self fromTriplet: #(#(165 0 38) #(215 48 39) #(244 109 67) #(253 174 97) #(254 224 139) #(255 255 191) #(217 239 139) #(166 217 106) #(102 189 99) #(26 152 80) #(0 104 55))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdbu6
	^ self fromTriplet: #(#(178 24 43) #(239 138 98) #(253 219 199) #(209 229 240) #(103 169 207) #(33 102 172))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylgn10
	^ self fromTriplet: #(#(165 0 38) #(215 48 39) #(244 109 67) #(253 174 97) #(254 224 139) #(217 239 139) #(166 217 106) #(102 189 99) #(26 152 80) #(0 104 55))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
spectral6
	^ self fromTriplet: #(#(213 62 79) #(252 141 89) #(254 224 139) #(230 245 152) #(153 213 148) #(50 136 189))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdbu10
	^ self fromTriplet: #(#(103 0 31) #(178 24 43) #(214 96 77) #(244 165 130) #(253 219 199) #(209 229 240) #(146 197 222) #(67 147 195) #(33 102 172) #(5 48 97))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylbu3
	^ self fromTriplet: #(#(252 141 89) #(255 255 191) #(145 191 219))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdbu3
	^ self fromTriplet: #(#(239 138 98) #(247 247 247) #(103 169 207))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
spectral7
	^ self fromTriplet: #(#(213 62 79) #(252 141 89) #(254 224 139) #(255 255 191) #(230 245 152) #(153 213 148) #(50 136 189))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
prgn4
	^ self fromTriplet: #(#(123 50 148) #(194 165 207) #(166 219 160) #(0 136 55))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
puor8
	^ self fromTriplet: #(#(179 88 6) #(224 130 20) #(253 184 99) #(254 224 182) #(216 218 235) #(178 171 210) #(128 115 172) #(84 39 136))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
puor11
	^ self fromTriplet: #(#(127 59 8) #(179 88 6) #(224 130 20) #(253 184 99) #(254 224 182) #(247 247 247) #(216 218 235) #(178 171 210) #(128 115 172) #(84 39 136) #(45 0 75))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
puor7
	^ self fromTriplet: #(#(179 88 6) #(241 163 64) #(254 224 182) #(247 247 247) #(216 218 235) #(153 142 195) #(84 39 136))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdgy4
	^ self fromTriplet: #(#(202 0 32) #(244 165 130) #(186 186 186) #(64 64 64))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
brbg4
	^ self fromTriplet: #(#(166 97 26) #(223 194 125) #(128 205 193) #(1 133 113))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
spectral3
	^ self fromTriplet: #(#(252 141 89) #(255 255 191) #(153 213 148))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylgn7
	^ self fromTriplet: #(#(215 48 39) #(252 141 89) #(254 224 139) #(255 255 191) #(217 239 139) #(145 207 96) #(26 152 80))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
puor10
	^ self fromTriplet: #(#(127 59 8) #(179 88 6) #(224 130 20) #(253 184 99) #(254 224 182) #(216 218 235) #(178 171 210) #(128 115 172) #(84 39 136) #(45 0 75))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdgy7
	^ self fromTriplet: #(#(178 24 43) #(239 138 98) #(253 219 199) #(255 255 255) #(224 224 224) #(153 153 153) #(77 77 77))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
prgn3
	^ self fromTriplet: #(#(175 141 195) #(247 247 247) #(127 191 123))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdbu5
	^ self fromTriplet: #(#(202 0 32) #(244 165 130) #(247 247 247) #(146 197 222) #(5 113 176))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
spectral4
	^ self fromTriplet: #(#(215 25 28) #(253 174 97) #(171 221 164) #(43 131 186))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
prgn5
	^ self fromTriplet: #(#(123 50 148) #(194 165 207) #(247 247 247) #(166 219 160) #(0 136 55))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
piyg5
	^ self fromTriplet: #(#(208 28 139) #(241 182 218) #(247 247 247) #(184 225 134) #(77 172 38))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
prgn6
	^ self fromTriplet: #(#(118 42 131) #(175 141 195) #(231 212 232) #(217 240 211) #(127 191 123) #(27 120 55))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
prgn8
	^ self fromTriplet: #(#(118 42 131) #(153 112 171) #(194 165 207) #(231 212 232) #(217 240 211) #(166 219 160) #(90 174 97) #(27 120 55))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdgy3
	^ self fromTriplet: #(#(239 138 98) #(255 255 255) #(153 153 153))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylbu9
	^ self fromTriplet: #(#(215 48 39) #(244 109 67) #(253 174 97) #(254 224 144) #(255 255 191) #(224 243 248) #(171 217 233) #(116 173 209) #(69 117 180))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
prgn10
	^ self fromTriplet: #(#(64 0 75) #(118 42 131) #(153 112 171) #(194 165 207) #(231 212 232) #(217 240 211) #(166 219 160) #(90 174 97) #(27 120 55) #(0 68 27))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
piyg4
	^ self fromTriplet: #(#(208 28 139) #(241 182 218) #(184 225 134) #(77 172 38))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylgn9
	^ self fromTriplet: #(#(215 48 39) #(244 109 67) #(253 174 97) #(254 224 139) #(255 255 191) #(217 239 139) #(166 217 106) #(102 189 99) #(26 152 80))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
puor6
	^ self fromTriplet: #(#(179 88 6) #(241 163 64) #(254 224 182) #(216 218 235) #(153 142 195) #(84 39 136))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylbu5
	^ self fromTriplet: #(#(215 25 28) #(253 174 97) #(255 255 191) #(171 217 233) #(44 123 182))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylbu8
	^ self fromTriplet: #(#(215 48 39) #(244 109 67) #(253 174 97) #(254 224 144) #(224 243 248) #(171 217 233) #(116 173 209) #(69 117 180))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
spectral11
	^ self fromTriplet: #(#(158 1 66) #(213 62 79) #(244 109 67) #(253 174 97) #(254 224 139) #(255 255 191) #(230 245 152) #(171 221 164) #(102 194 165) #(50 136 189) #(94 79 162))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
brbg5
	^ self fromTriplet: #(#(166 97 26) #(223 194 125) #(245 245 245) #(128 205 193) #(1 133 113))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
brbg6
	^ self fromTriplet: #(#(140 81 10) #(216 179 101) #(246 232 195) #(199 234 229) #(90 180 172) #(1 102 94))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
prgn7
	^ self fromTriplet: #(#(118 42 131) #(175 141 195) #(231 212 232) #(247 247 247) #(217 240 211) #(127 191 123) #(27 120 55))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
piyg9
	^ self fromTriplet: #(#(197 27 125) #(222 119 174) #(241 182 218) #(253 224 239) #(247 247 247) #(230 245 208) #(184 225 134) #(127 188 65) #(77 146 33))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
brbg7
	^ self fromTriplet: #(#(140 81 10) #(216 179 101) #(246 232 195) #(245 245 245) #(199 234 229) #(90 180 172) #(1 102 94))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdgy11
	^ self fromTriplet: #(#(103 0 31) #(178 24 43) #(214 96 77) #(244 165 130) #(253 219 199) #(255 255 255) #(224 224 224) #(186 186 186) #(135 135 135) #(77 77 77) #(26 26 26))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdgy9
	^ self fromTriplet: #(#(178 24 43) #(214 96 77) #(244 165 130) #(253 219 199) #(255 255 255) #(224 224 224) #(186 186 186) #(135 135 135) #(77 77 77))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
brbg3
	^ self fromTriplet: #(#(216 179 101) #(245 245 245) #(90 180 172))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
piyg3
	^ self fromTriplet: #(#(233 163 201) #(247 247 247) #(161 215 106))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylgn3
	^ self fromTriplet: #(#(252 141 89) #(255 255 191) #(145 207 96))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
piyg8
	^ self fromTriplet: #(#(197 27 125) #(222 119 174) #(241 182 218) #(253 224 239) #(230 245 208) #(184 225 134) #(127 188 65) #(77 146 33))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
puor9
	^ self fromTriplet: #(#(179 88 6) #(224 130 20) #(253 184 99) #(254 224 182) #(247 247 247) #(216 218 235) #(178 171 210) #(128 115 172) #(84 39 136))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdbu7
	^ self fromTriplet: #(#(178 24 43) #(239 138 98) #(253 219 199) #(247 247 247) #(209 229 240) #(103 169 207) #(33 102 172))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylbu6
	^ self fromTriplet: #(#(215 48 39) #(252 141 89) #(254 224 144) #(224 243 248) #(145 191 219) #(69 117 180))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
spectral5
	^ self fromTriplet: #(#(215 25 28) #(253 174 97) #(255 255 191) #(171 221 164) #(43 131 186))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
brbg8
	^ self fromTriplet: #(#(140 81 10) #(191 129 45) #(223 194 125) #(246 232 195) #(199 234 229) #(128 205 193) #(53 151 143) #(1 102 94))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
piyg10
	^ self fromTriplet: #(#(142 1 82) #(197 27 125) #(222 119 174) #(241 182 218) #(253 224 239) #(230 245 208) #(184 225 134) #(127 188 65) #(77 146 33) #(39 100 25))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
puor5
	^ self fromTriplet: #(#(230 97 1) #(253 184 99) #(247 247 247) #(178 171 210) #(94 60 153))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
brbg9
	^ self fromTriplet: #(#(140 81 10) #(191 129 45) #(223 194 125) #(246 232 195) #(245 245 245) #(199 234 229) #(128 205 193) #(53 151 143) #(1 102 94))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylbu11
	^ self fromTriplet: #(#(165 0 38) #(215 48 39) #(244 109 67) #(253 174 97) #(254 224 144) #(255 255 191) #(224 243 248) #(171 217 233) #(116 173 209) #(69 117 180) #(49 54 149))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdgy10
	^ self fromTriplet: #(#(103 0 31) #(178 24 43) #(214 96 77) #(244 165 130) #(253 219 199) #(224 224 224) #(186 186 186) #(135 135 135) #(77 77 77) #(26 26 26))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylbu4
	^ self fromTriplet: #(#(215 25 28) #(253 174 97) #(171 217 233) #(44 123 182))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
puor4
	^ self fromTriplet: #(#(230 97 1) #(253 184 99) #(178 171 210) #(94 60 153))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylgn6
	^ self fromTriplet: #(#(215 48 39) #(252 141 89) #(254 224 139) #(217 239 139) #(145 207 96) #(26 152 80))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
spectral8
	^ self fromTriplet: #(#(213 62 79) #(244 109 67) #(253 174 97) #(254 224 139) #(230 245 152) #(171 221 164) #(102 194 165) #(50 136 189))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
rdylgn8
	^ self fromTriplet: #(#(215 48 39) #(244 109 67) #(253 174 97) #(254 224 139) #(217 239 139) #(166 217 106) #(102 189 99) #(26 152 80))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
brbg10
	^ self fromTriplet: #(#(84 48 5) #(140 81 10) #(191 129 45) #(223 194 125) #(246 232 195) #(199 234 229) #(128 205 193) #(53 151 143) #(1 102 94) #(0 60 48))! !

!RSDivergingColorPalette methodsFor: 'palette' stamp: ''!
prgn9
	^ self fromTriplet: #(#(118 42 131) #(153 112 171) #(194 165 207) #(231 212 232) #(247 247 247) #(217 240 211) #(166 219 160) #(90 174 97) #(27 120 55))! !

!RSDivergingColorPalette class methodsFor: 'accessing' stamp: ''!
paletteName
	^ #diverging! !

!RSDominanceTreeLayout commentStamp: ''!
TODO!
!RSDominanceTreeLayout methodsFor: 'private - hook' stamp: ''!
computeChildrenFor: aNode
	^ self childrenWithHighestNestingLevelFor: aNode! !

!RSDoubleBarPlot commentStamp: ''!
RSDoubleBarPlot renders 2 different bars!
!RSDoubleBarPlot methodsFor: 'rendering' stamp: ''!
createXScale
	| padding |
	super createXScale.
	x2Scale ifNil: [ x2Scale := NSScale linear ].
	x2Scale class = NSOrdinalScale ifTrue: [ ^ self ].
	padding := chart padding x.
	x2Scale
		domain:
			{x2Values min.
			x2Values max};
		range:
			{0 + padding.
			chart extent x - padding}! !

!RSDoubleBarPlot methodsFor: 'accessing' stamp: ''!
x2Values
	^ x2Values! !

!RSDoubleBarPlot methodsFor: 'accessing' stamp: ''!
x1: x1 x2: x2 y: y
	self assert: x1 size = y size description: 'The two collections must have the same size'.
	self x: x1 y: y.
	x2Values := x2.! !

!RSDoubleBarPlot methodsFor: 'public' stamp: ''!
computeSecondColor
	^ secondColor ifNil: [ chart colorFor: x2Values ]! !

!RSDoubleBarPlot methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	| index |
	super renderIn: canvas.
	index := 1.
	bars2 := x2Values collect: [ :xt | 
		| yt bar |
		yt := yValues at: index.
		bar := self createBar2For: xt@yt index: index.
		index := index + 1.
		bar ] as: RSGroup.
	canvas addAll: bars2.
! !

!RSDoubleBarPlot methodsFor: 'accessing' stamp: ''!
secondColor
	^ secondColor! !

!RSDoubleBarPlot methodsFor: 'rendering' stamp: ''!
createBar2For: aPoint index: index
	^ self shape copy
		model: (self modelFor: aPoint);
		color: self computeSecondColor;
		fromRectangle: (self computeSecondRectagleFor: aPoint index: index);
		yourself! !

!RSDoubleBarPlot methodsFor: 'accessing' stamp: ''!
createdShapes
	^ bars, bars2! !

!RSDoubleBarPlot methodsFor: 'accessing' stamp: ''!
bars2
	^ bars2! !

!RSDoubleBarPlot methodsFor: 'hooks' stamp: ''!
computeSecondRectagleFor: aPoint index: index
	| origin corner sizeOffset offset zero |
	zero := 0.
	left ifNotNil: [ zero := left at: index ].
	origin := (x2Scale scale: aPoint x) @ (yScale scale: aPoint y).
	corner := (x2Scale scale: zero) @ origin y.
	sizeOffset := 0@(self barSize * 0.3).
	offset := 0@ self barOffset.
	^ Rectangle 
		origin: origin + offset - sizeOffset
		corner: corner + offset + sizeOffset! !

!RSDraggable commentStamp: ''!
I can move an element from its position!
!RSDraggable methodsFor: 'hooks' stamp: ''!
processDrag: evt 
	| d |
	d := evt camera distanceFromPixelToSpace: evt step.
	evt shape translateBy: d.
	evt signalUpdate ! !

!RSDraggable methodsFor: 'hooks' stamp: ''!
onShape: aShape
	aShape when: RSMouseDragging send: #processDrag: to: self! !

!RSDraggable class methodsFor: 'instance creation' stamp: ''!
wantsUniqueInstance
	^ true! !

!RSDraggableCanvasInteraction commentStamp: ''!
I set the drag event for view, I use a basic bars to do that.

Use example:
```Smalltalk
c := RSCanvas new.
c add: (RSBox new size: 30).
c @ RSDraggableCanvas
```!
!RSDraggableCanvasInteraction methodsFor: 'mouse' stamp: ''!
right
	mouseEvent := RSMouseRightDragStart.! !

!RSDraggableCanvasInteraction methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	self all.
	isMoving := false.! !

!RSDraggableCanvasInteraction methodsFor: 'mouse' stamp: ''!
mouseEvent
	^ mouseEvent! !

!RSDraggableCanvasInteraction methodsFor: 'mouse' stamp: ''!
left
	mouseEvent := RSMouseLeftDragStart! !

!RSDraggableCanvasInteraction methodsFor: 'events' stamp: ''!
mouseEnd: evt
	| threshold aCanvas camera delta p correct |
	isMoving := false.
	lastStep ifNil: [ ^ self ].
	aCanvas := evt canvas.
	camera := evt camera.
	threshold := 4.
	(lastStep distanceTo: 0@0) < threshold
		ifTrue: [ ^ self checkCamera: aCanvas ].
		
	delta := lastStep * 2.5.
	lastStep := nil.
	camera translateBy: delta.
	correct := self correctCameraPosition: aCanvas.
	camera translateBy: delta negated.
			
	p := (correct - camera position) abs max: 1@1.
	p := p x sqrt @ p y sqrt.
	
	aCanvas newAnimation 
		easing: RSEasingInterpolator cubicOut;
		duration: 200 milliSeconds;
		from: camera position; to: camera position + (delta / p);
		on: camera set: #translateTo:;
		when: RSAnimationEndEvent do: [ self checkCamera: aCanvas ].
		
! !

!RSDraggableCanvasInteraction methodsFor: 'events' stamp: ''!
mouseStart: evt
	self removeRectanglesFor: evt canvas.
	isMoving := true.
	lastStep := nil.! !

!RSDraggableCanvasInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	aCanvas 
		when: self mouseEvent send: #mouseStart: to: self;
		when: RSMouseDragging send: #mouseMove: to: self;
		when: RSMouseDragEnd send: #mouseEnd: to: self.! !

!RSDraggableCanvasInteraction methodsFor: 'mouse' stamp: ''!
middle
	mouseEvent := RSMouseMiddleDragStart! !

!RSDraggableCanvasInteraction methodsFor: 'mouse' stamp: ''!
mouseEvent: aRSMouseDragEvent
	mouseEvent := aRSMouseDragEvent! !

!RSDraggableCanvasInteraction methodsFor: 'mouse' stamp: ''!
all
	"Any mouse button can be used to drag and drop the view"
	mouseEvent := RSMouseDragStart.! !

!RSDraggableCanvasInteraction methodsFor: 'computing' stamp: ''!
checkCamera: aCanvas
	| camera p correct |
	camera := aCanvas camera.
	p := camera position.
	correct := self correctCameraPosition: aCanvas.
	correct = p ifTrue: [ ^ self ].
	
	self removeRectanglesFor: aCanvas.
	
	aCanvas newAnimation
		easing: RSEasingInterpolator cubicIn;
		duration: 200 milliSeconds;
		from: p;
		to: correct;
		on: camera set: #translateTo:.! !

!RSDraggableCanvasInteraction methodsFor: 'events' stamp: ''!
mouseMove: evt
	| camera p correct |
	isMoving ifFalse: [ ^ self ].
	camera := evt camera.
	lastStep := evt step negated / camera scale.
	correct  := self correctCameraPosition: evt canvas.
	p := (correct - camera position) abs max: 1@1.
	p := p x sqrt @ p y sqrt.
	camera translateBy: lastStep/ p.
	evt signalUpdate.! !

!RSDraggableCanvasInteraction methodsFor: 'rendering' stamp: ''!
renderLegendOn: lb
	lb text: 'Mouse click' description: 'To move the view''s camera'! !

!RSDraggableCanvasInteraction class methodsFor: 'accessing' stamp: ''!
right
	^ self new right! !

!RSDraggableCanvasInteraction class methodsFor: 'accessing' stamp: ''!
left
	^ self new left! !

!RSDraggableCanvasInteraction class methodsFor: 'accessing' stamp: ''!
middle
	^ self new middle! !

!RSDraggableCanvasTest commentStamp: ''!
For drag view tests!
!RSDraggableCanvasTest methodsFor: 'tests' stamp: ''!
testDefault
	self assert: canvas canvas camera position equals: 0@0.! !

!RSDraggableCanvasTest methodsFor: 'tests' stamp: ''!
testDraggingOnNotDraggable
	canvas canvas announce: (RSMouseDragging step: 10 @ 5).
	self assert: canvas canvas camera position = (0 @ 0)! !

!RSDraggableCanvasTest methodsFor: 'tests' stamp: ''!
testDraggingModeLeft
	canvas @ RSDraggableCanvasInteraction left.
	canvas canvas announce: (RSMouseDragging new step: 10 @ 5; canvas: canvas canvas).
	self assert: (canvas canvas camera position closeTo: (0 @ 0)).
	
	canvas removeInteractionIfPresent: RSDraggableCanvasInteraction.
	
	canvas @ RSDraggableCanvasInteraction left.
	canvas canvas announce: (RSMouseDragStart new canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragging new step: 10 @ 5; canvas: canvas canvas ).
	canvas canvas announce: (RSMouseDragEnd new canvas: canvas canvas).
	self assert: (canvas canvas camera position closeTo: (0 @ 0)).
	
	canvas canvas announce: (RSMouseLeftDragStart new canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragging new step: 10 @ 5; canvas: canvas canvas ).
	canvas canvas announce: (RSMouseDragEnd new canvas: canvas canvas).
	self assert: (canvas canvas camera position closeTo: (-10 @ -5)).

! !

!RSDraggableCanvasTest methodsFor: 'tests' stamp: ''!
testDraggingModeMiddle
	canvas @ RSDraggableCanvasInteraction middle.
	canvas canvas announce: (RSMouseDragging new step: 10 @ 5; canvas: canvas canvas).
	self assert: (canvas canvas camera position closeTo: (0 @ 0)).
	
	canvas removeInteractionIfPresent: RSDraggableCanvasInteraction.
	
	canvas @ RSDraggableCanvasInteraction middle.
	canvas canvas announce: (RSMouseDragStart new canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragging new step: 10 @ 5; canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragEnd new canvas: canvas canvas).
	self assert: (canvas canvas camera position closeTo: (0 @ 0)).
	
	canvas canvas announce: (RSMouseMiddleDragStart new canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragging new step: 10 @ 5; canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragEnd new canvas: canvas canvas).
	self assert: (canvas canvas camera position closeTo: (-10 @ -5)).

! !

!RSDraggableCanvasTest methodsFor: 'tests' stamp: ''!
testDraggingModeRight
	canvas @ RSDraggableCanvasInteraction right.
	canvas canvas announce: (RSMouseDragging new step: 10 @ 5; canvas: canvas canvas).
	self assert: (canvas canvas camera position closeTo: (0 @ 0)).
	
	canvas removeInteractionIfPresent: RSDraggableCanvasInteraction.
	
	canvas @ RSDraggableCanvasInteraction right.
	canvas canvas announce: (RSMouseDragStart new canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragging new step: 10 @ 5; canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragEnd new canvas: canvas canvas).
	self assert: (canvas canvas camera position closeTo: (0 @ 0)).
	
	canvas canvas announce: (RSMouseRightDragStart new canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragging new step: 10 @ 5; canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragEnd new canvas: canvas canvas).
	self assert: (canvas canvas camera position closeTo: (-10 @ -5)).

! !

!RSDraggableCanvasTest methodsFor: 'tests' stamp: ''!
testDraggingOnDraggable
	canvas @ RSDraggableCanvasInteraction.
	canvas canvas announce: (RSMouseDragStart new canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragging new step: 10 @ 5; canvas: canvas canvas).
	canvas canvas announce: (RSMouseDragEnd new canvas: canvas canvas).
	self assert: (canvas canvas camera position closeTo: (-10 @ -5))! !

!RSDraggableCanvasTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new.
	canvas add: (RSEllipse new width: 40; height: 20; yourself).
	! !

!RSDraggableForceInteraction commentStamp: ''!
I am a special case to drag elements with the draggable interaction and the RSForceBasedLayout!
!RSDraggableForceInteraction methodsFor: 'hooks' stamp: ''!
layout
	^ layout! !

!RSDraggableForceInteraction methodsFor: 'hooks' stamp: ''!
layout: aForceLayout
	layout := aForceLayout! !

!RSDraggableForceInteraction methodsFor: 'hooks' stamp: ''!
onShape: aShape

	aShape removeInteractionIfPresent: RSDraggable.
	aShape 
		when: RSMouseDragStart do: [ :evt | 
			layout
				mockElementAt: evt shape
				ifPresent: [ :mock | mock isFixed: true ] ];
		when: RSMouseDragging do: [ :evt |
			| d |
			d := evt shape parent camera distanceFromPixelToSpace: evt step.
			evt shape translateBy: d.
			layout
				mockElementAt: evt shape
				ifPresent: [ :mock | mock fixPosition: evt shape position ].
			evt shape signalUpdate ];
		when: RSMouseDragEnd do:[:evt | 
			layout
				mockElementAt: evt shape
				ifPresent: [ :mock | mock isFixed: false ] ].! !

!RSDummyNode commentStamp: ''!
A RODummyNode is used by the sugiyama layout!
!RSDummyNode methodsFor: 'accessing' stamp: ''!
position
	^ 0 @ 0! !

!RSDummyNode methodsFor: 'accessing' stamp: ''!
edge
	^ edge! !

!RSDummyNode methodsFor: 'accessing' stamp: ''!
width
	^ 0! !

!RSDummyNode methodsFor: 'accessing' stamp: ''!
translateBy: apoint
	"do nothing"! !

!RSDummyNode methodsFor: 'accessing' stamp: ''!
slot: anIndex
	! !

!RSDummyNode methodsFor: 'accessing' stamp: ''!
extent
	^ self height @ self width! !

!RSDummyNode methodsFor: 'accessing' stamp: ''!
signalUpdate
	"do nothing"! !

!RSDummyNode methodsFor: 'accessing' stamp: ''!
height
	^ 0! !

!RSDummyNode methodsFor: 'accessing' stamp: ''!
translateTo: aPoint
	"edge index: index point: aPoint"! !

!RSDummyNode methodsFor: 'accessing' stamp: ''!
edge: anEdge
	edge := anEdge! !

!RSDummyNode class methodsFor: 'instance creation' stamp: ''!
on: anEdge slot: anIndex
	
	^(self new)
		edge: anEdge;
		slot: anIndex;
		yourself! !

!RSEasingInterpolator commentStamp: ''!
Given the specified normalized time t, typically in the range [0,1], returns the “eased” time tʹ, also typically in [0,1]. 0 represents the start of the animation and 1 represents the end. A good implementation returns 0 if t = 0 and 1 if t = 1.

I am highly inspired from d3js source code https://github.com/d3/d3-transition and from the base animation of Bloc https://github.com/pharo-graphics/Bloc!
!RSEasingInterpolator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self inOut.! !

!RSEasingInterpolator methodsFor: 'actions' stamp: ''!
in
	useIn := true.! !

!RSEasingInterpolator methodsFor: 'actions' stamp: ''!
inOut
	useIn := useOut := false! !

!RSEasingInterpolator methodsFor: 'actions' stamp: ''!
out 
	useOut := true.! !

!RSEasingInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateIn: t
	^ self subclassResponsibility! !

!RSEasingInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateInOut: t
	^ self subclassResponsibility ! !

!RSEasingInterpolator methodsFor: 'interpolation' stamp: ''!
interpolate: t
	useIn ifTrue: [ ^ self interpolateIn: t ].
	useOut ifTrue: [ ^ self interpolateOut: t ].
	^ self interpolateInOut: t.! !

!RSEasingInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateOut: t
	^ self subclassResponsibility! !

!RSEasingInterpolator class methodsFor: 'back' stamp: ''!
backIn
	^ RSBackInterpolator new in! !

!RSEasingInterpolator class methodsFor: 'back' stamp: ''!
back
	^ self backInOut! !

!RSEasingInterpolator class methodsFor: 'back' stamp: ''!
backOut
	^ RSBackInterpolator new out! !

!RSEasingInterpolator class methodsFor: 'elastic' stamp: ''!
elasticInOut
	^ RSElasticInterpolator new! !

!RSEasingInterpolator class methodsFor: 'poly' stamp: ''!
polyOut
	^ RSPolyInterpolator new out! !

!RSEasingInterpolator class methodsFor: 'bounce' stamp: ''!
bounceInOut
	^ RSBounceInterpolator new! !

!RSEasingInterpolator class methodsFor: 'circle' stamp: ''!
circle
	^ self circleInOut! !

!RSEasingInterpolator class methodsFor: 'sin' stamp: ''!
sin
	^ self sinInOut! !

!RSEasingInterpolator class methodsFor: 'sin' stamp: ''!
sinOut
	^ RSSinInterpolator new out! !

!RSEasingInterpolator class methodsFor: 'circle' stamp: ''!
circleInOut
	^ RSCircleInterpolator new! !

!RSEasingInterpolator class methodsFor: 'quad' stamp: ''!
quadInOut
	^ RSQuadInterpolator new! !

!RSEasingInterpolator class methodsFor: 'quad' stamp: ''!
quadIn
	^ RSQuadInterpolator new in! !

!RSEasingInterpolator class methodsFor: 'elastic' stamp: ''!
elasticIn
	^ RSElasticInterpolator new in! !

!RSEasingInterpolator class methodsFor: 'poly' stamp: ''!
polyIn
	^ RSPolyInterpolator new in! !

!RSEasingInterpolator class methodsFor: 'exp' stamp: ''!
expInOut
	^ RSExpInterpolator new! !

!RSEasingInterpolator class methodsFor: 'quad' stamp: ''!
quadOut
	^ RSQuadInterpolator new out! !

!RSEasingInterpolator class methodsFor: 'exp' stamp: ''!
expOut
	^ RSExpInterpolator new out! !

!RSEasingInterpolator class methodsFor: 'cubic' stamp: ''!
cubicIn
	^ RSCubicInterpolator new in! !

!RSEasingInterpolator class methodsFor: 'poly' stamp: ''!
poly
	^ self polyInOut! !

!RSEasingInterpolator class methodsFor: 'elastic' stamp: ''!
elasticOut
	^ RSElasticInterpolator new out! !

!RSEasingInterpolator class methodsFor: 'elastic' stamp: ''!
elastic
	^ self elasticInOut! !

!RSEasingInterpolator class methodsFor: 'sin' stamp: ''!
sinInOut
	^ RSSinInterpolator new! !

!RSEasingInterpolator class methodsFor: 'cubic' stamp: ''!
cubicOut
	^ RSCubicInterpolator new out! !

!RSEasingInterpolator class methodsFor: 'circle' stamp: ''!
circleIn
	^ RSCircleInterpolator new in! !

!RSEasingInterpolator class methodsFor: 'back' stamp: ''!
backInOut
	^ RSBackInterpolator new! !

!RSEasingInterpolator class methodsFor: 'cubic' stamp: ''!
cubic
	^ self cubicInOut! !

!RSEasingInterpolator class methodsFor: 'circle' stamp: ''!
circleOut
	^ RSCircleInterpolator new out! !

!RSEasingInterpolator class methodsFor: 'cubic' stamp: ''!
cubicInOut
	^ RSCubicInterpolator new! !

!RSEasingInterpolator class methodsFor: 'linear' stamp: ''!
linear
	^ RSLinearInterpolator new! !

!RSEasingInterpolator class methodsFor: 'bounce' stamp: ''!
bounceOut
	^ RSBounceInterpolator new out! !

!RSEasingInterpolator class methodsFor: 'exp' stamp: ''!
exp
	^ self expInOut! !

!RSEasingInterpolator class methodsFor: 'bounce' stamp: ''!
bounce
	^ self bounceOut! !

!RSEasingInterpolator class methodsFor: 'poly' stamp: ''!
polyInOut
	^ RSPolyInterpolator new.! !

!RSEasingInterpolator class methodsFor: 'sin' stamp: ''!
sinIn
	^ RSSinInterpolator new in! !

!RSEasingInterpolator class methodsFor: 'bounce' stamp: ''!
bounceIn
	^ RSBounceInterpolator new in! !

!RSEasingInterpolator class methodsFor: 'exp' stamp: ''!
expIn
	^ RSExpInterpolator new in! !

!RSEasingInterpolator class methodsFor: 'quad' stamp: ''!
quad
	^ self quadInOut! !

!RSEasingInterpolatorTest methodsFor: 'tests' stamp: ''!
testAllEasing
	"Simply check if no error is raised"
	| someX |
	someX := (0 to: 1 by: 0.01).
	RSEasingInterpolator allSubclassesDo: [ :cls |
		someX collect: [ :v | cls new interpolate: v; interpolateOut: v ].
	]
! !

!RSEdgeBuilder commentStamp: ''!
For compatibility!! The use of RSEdgeBuilder is deprecated!
!RSEdgeBuilder methodsFor: 'documentation' stamp: ''!
README
	"This class is voluntarily empty" ! !

!RSEdgeBuilderTest commentStamp: ''!
I have tests for RSEdgeBuilder!
!RSEdgeBuilderTest methodsFor: '*Roassal3-Layouts-Tests' stamp: ''!
testUseInLayoutDefault

	b 
		canvas: canvas;
		connectTo: [ :v | v + 1 ].
	RSTreeLayout on: canvas nodes.
	
	self assert: (canvas nodes collect: #position) asArray equals: ((Array new: 10) at: 1 put: ((7.5@7.5)); at: 2 put: ((7.5@32.5)); at: 3 put: ((7.5@57.5)); at: 4 put: ((7.5@82.5)); at: 5 put: ((7.5@107.5)); at: 6 put: ((7.5@132.5)); at: 7 put: ((7.5@157.5)); at: 8 put: ((7.5@182.5)); at: 9 put: ((7.5@207.5)); at: 10 put: ((7.5@232.5)); yourself)! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testElementsToLookup

	| es1 es2 edges c |
	es1 := #(1 2 3) collect: [:n | RSEllipse new model: n; yourself].
	es2 := #(1 2 3) collect: [:n | RSBox new model: n; yourself].
	c := RSCanvas new.
	c addAll: es1.
	c addAll: es2.
	edges := RSLineBuilder line
					canvas: c;
					fromShapes: es1;
					toShapes: es2;
					connectTo: #yourself.
	self assert: edges size equals: 3.
	
	self assert: edges first from equals: es1 first.
	self assert: edges first to equals: es2 first.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testObjects
	b canvas: canvas.
	b objects: (1 to: 5).
	self assert: b fromShapes equals: (shapes copyFrom: 1 to: 5)

"	view := RTView new.
	elements := RTBox elementsOn: (1 to: 10).
	view addAll: elements. 
	b := RTEdgeBuilder new."! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testShouldNotInstantiate

	self should: [ RSLineBuilder new ] raise: Error! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testSimple4

	RSLineBuilder line
		canvas: canvas;
		fromObjects: #(1 2 3 6);
		toObjects: #(1 2 3 6);
		connectFrom: #yourself to: [ :v | v + 1 ].
	self assert: canvas numberOfEdges equals: 2.
	self assert: (canvas edges collect: [ :e | e from model -> e to model ]) asArray equals: ((Array new: 2) at: 1 put: (1->2); at: 2 put: (2->3); yourself)! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testDefault
	self assert: canvas numberOfEdges equals: 0! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testConnectFrom
	| e |
	b canvas: canvas.
	b objects: #(1 2).
	b connectFrom: [ :v | v - 1 ].
	
	self assert: canvas numberOfEdges equals: 1.
	
	e := canvas edges anyOne.
	self assert: e from model equals: 1.
	self assert: e to model equals: 2.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testConnectTo
	| e |
	b canvas: canvas.
	b objects: #(1 2).
	b connectTo: [ :v | v - 1 ].
	
	self assert: canvas numberOfEdges equals: 1.
	
	e := canvas edges anyOne.
	self assert: e from model equals: 2.
	self assert: e to model equals: 1.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testConnectToAll
	| eFrom eTo |
	b canvas: canvas.
	b objects: #(1 2 3).
	b connectToAll: [ :v | Array with: v - 1 with: v - 2 ].
	
	self assert: canvas numberOfEdges equals: 3.
	 
	eFrom := (canvas edges collect: [ :edge | edge from model ]) sorted asArray.
	eTo := (canvas edges collect: [ :edge | edge to model ]) sorted asArray.
	self assert: eFrom equals: #(2 3 3).
	self assert: eTo equals: #(1 1 2).! !

!RSEdgeBuilderTest methodsFor: 'tests - error' stamp: ''!
testErrors
	| eb |
	eb := RSLineBuilder line.
	
	self should: [ eb shapes: #(1 2 3) ] raise: AssertionFailure.
	self should: [ eb shapes: 'hello world' ] raise: AssertionFailure.
	self should: [ eb shapes: 42 ] raise: AssertionFailure.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testObjects02
	b canvas: canvas.
	b objects: #even.
	self assert: (b fromShapes collect: #model) asArray equals: #(2 4 6 8 10)
! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testSimple2

	RSLineBuilder line
		canvas: canvas;
		useAssociations: (Array 
									with: 1 -> 2
									with: 2 -> 3
									with: 5 -> 6).
	self assert: canvas numberOfEdges equals: 3! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testSimple5

	RSLineBuilder line
		canvas: canvas;
		fromObjects: #(1 2 3 6);
		connectFrom: #yourself toAll: [ :v | Array with: v + 1 with: v + 2 ].
		
	self assert: canvas numberOfEdges equals: 8.
! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testObjects03
	b canvas: canvas.
	b objects: #odd.
	self assert: (b fromShapes collect: #model) asArray equals: #(1 3 5 7 9)! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testInit
	| eb |
	eb := RSLineBuilder line.
	self deny: eb shouldAllowRepetition.
	eb allowRepetition.
	self assert: eb shouldAllowRepetition.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testAllowRepetitionAndUseAssociations

	| eb |
	canvas := RSCanvas new.
	canvas addAll: ((1 to: 3) collect: [ :n | RSBox new model: n; yourself] ).

	eb := RSLineBuilder line.
	eb canvas: canvas.
	eb color: (Color red alpha: 0.5).
	eb noRepetition.
	eb useAssociations: (Array with: 1 -> 2 with: 2 -> 3 with: 1 -> 2).
	
	(Smalltalk globals at: #RSGridLayout)  on: canvas nodes.
	
	self assert: canvas numberOfEdges equals: 2! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testObjectFrom
	| e |
	b canvas: canvas.
	b objects: #(1 2); connectFrom: [ :v | v - 1 ].
	
	self assert: canvas numberOfEdges equals: 1.
	
	e := canvas edges anyOne.
	self assert: e from model equals: 1.
	self assert: e to model equals: 2.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testFromObjectsToElements
	| edges |
	b canvas: canvas.
	edges := 
		b fromObjects: #(1 2);
			toShapes: (shapes copyFrom: 10 to: 10);
			connectTo: 10.
	self assert: edges size equals: 2.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testNoMoveBehind
	RSLineBuilder line
		canvas: canvas;
		useAssociations: (Array 
									with: 1 -> 2
									with: 2 -> 3
									with: 5 -> 6).
	self assert: (canvas canvas shapes collect: [ :c | c class name ]) asArray equals: #(#RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSLine #RSLine #RSLine)! !

!RSEdgeBuilderTest methodsFor: '*Roassal3-Layouts-Tests' stamp: ''!
testUseInLayout
	b
		canvas: canvas;
		connectTo: [ :v | v + 1 ].
	RSTreeLayout on: canvas nodes.
	self assert: (canvas nodes collect: #position) asArray equals: ({(7.5@7.5). (7.5@32.5). (7.5@57.5). (7.5@82.5). (7.5@107.5). (7.5@132.5). (7.5@157.5). (7.5@182.5). (7.5@207.5). (7.5@232.5)})! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testInferCanvas

	self assert: b canvas isNil.
	b toShapes: canvas nodes.
	self assert: b canvas isNil.
	
	b fromShapes: canvas nodes.
	self assert: b canvas equals: canvas.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testSimple6

	RSLineBuilder line
		canvas: canvas;
		fromObjects: (Array with: 2);
		connectFromAll: (Array with: 2) to: 3.
	self assert: canvas numberOfEdges equals: 1.
! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testInferCanvas2

	self assert: b canvas isNil.
	b shapes: canvas nodes.
	self assert: b canvas equals: canvas.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testConnectFromAll
	| c es |
	c := RSCanvas new.
	es := (1 to: 2) collect: [ :m | RSEllipse new size: 20; model: m; yourself ].
	c addAll: es.
	
	self assert: c edges size equals: 0.
	RSLineBuilder line
		canvas: c;
		objects: (1 to: 2);
		connectFromAll: (Array with: 1) to: 2.
		
	(Smalltalk globals at: #RSTreeLayout) on: es.

	self assert: c edges size equals: 1.
	self assert: c edges first from position equals: (15.0@15.0).
	self assert: c edges first to position equals: (15.0@55.0).! !

!RSEdgeBuilderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new.
	shapes := (1 to: 10) collect: [ :n | RSBox new model: n; size: 5; yourself ] as: RSGroup.
	canvas addAll: shapes. 
	b := RSLineBuilder line.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testFromObjects
	| edges |
	b canvas: canvas.
	b fromObjects: #(1 2).
	b connectFrom: #yourself to: 10.
	self assert: canvas numberOfEdges equals: 2.
	edges := canvas edges.
	self assert: edges first from model equals: 1.
	self assert: edges first to model equals: 10.

	self assert: b toObjects asArray equals: (1 to: 10) asArray.
	self assert: b fromObjects asArray equals: #(1 2).! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testFromObjectsError

"
view := RTView new.
	elements := RTBox elementsOn: (1 to: 10).
	view addAll: elements. 
	b := RTEdgeBuilder new."
	self should: [ RSLineBuilder new  fromObjects: #(1 2) ] raise: Error! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testWithMoveBehind02

	RSLineBuilder line
		canvas: canvas;
		moveBehind;
		connectFrom: [ :v | v - 1 ].
	self assert: (canvas canvas shapes collect: [ :c | c class name ]) asArray equals: #(#RSLine #RSLine #RSLine #RSLine #RSLine #RSLine #RSLine #RSLine #RSLine #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox)! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testObjectTo
	| e |
	b canvas: canvas.
	b objects: #(1 2); connectTo: [ :v | v - 1 ].
	
	self assert: canvas numberOfEdges equals: 1.
	
	e := canvas edges anyOne.
	self assert: e from model equals: 2.
	self assert: e to model equals: 1.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testSource
	| c es eb col |
	c := RSCanvas new.
	es := #(1 2 3) collect: [:n | RSBox new model: n; yourself]. 
	c addAll: es.
	
	eb := RSLineBuilder line.
	eb canvas: c.
	
	col := OrderedCollection new.
	col add: 1 -> 2.
	col add: 3 -> 1.
	eb source: col connectFrom: #key to: #value.
	
	self assert: c numberOfEdges equals: 2! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testFromObjects02
	b canvas: canvas.
	b fromObjects: #(1).
	b connectFrom: #yourself to: 10.
	self assert: canvas numberOfEdges equals: 1.

	self assert: b toObjects asArray equals: (1 to: 10) asArray.
	self assert: b fromObjects asArray equals: #(1).! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testSimple7

	RSLineBuilder line
		canvas: canvas;
		useAssociation: 1 -> 2;
		useAssociation: 2 -> 3;
		useAssociation: 5 -> 6.

	self assert: canvas numberOfEdges equals: 3! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testToObjects
	b canvas: canvas.
	b toObjects: #(1 2).
	b connectFrom: #yourself to: 10.
	self assert: canvas numberOfEdges equals: 0.

	self assert: b toObjects asArray equals: #(1 2).
	self assert: b fromObjects asArray equals: (1 to: 10) asArray.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testconnectFromToAll

	| es1 es2 edges c |
	es1 := #(1 2 3) collect: [:n | RSEllipse new model: n; yourself].
	es2 := #(1 2 3) collect: [:n | RSBox new model: n; yourself].
	c := RSCanvas new.
	c addAll: es1; addAll: es2.
	edges := RSLineBuilder line
					canvas: c;
					fromShapes: es1;
					toShapes: es2;
					connectFrom: #yourself toAll: [ :obj | Array with: obj ].
	self assert: edges size equals: 3.
	
	self assert: edges first from equals: es1 first.
	self assert: edges first to equals: es2 first.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testShouldNotAllowBidirection

	self assert: canvas numberOfEdges equals: 0.
	b canvas: canvas.
	b objects: #(1 2).
	b useAssociations: (Array with: 1 -> 2 with: 2 -> 1).
	self assert: canvas numberOfEdges equals: 2.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testElements

	| es |
	b := RSLineBuilder line.
	b canvas: canvas.
	self assert: b fromShapes equals: canvas nodes.
	
	es := (1 to: 4) collect: [:n | RSBox new model: n; yourself] as: RSGroup.
	b shapes: es.
	self assert: b fromShapes equals: es.! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testBorder
	| numberOfEdges |
	b canvas: canvas.
	b connectFrom: [ :vv | vv // 2 ].
	
	numberOfEdges := canvas edges size.
	self assert: numberOfEdges > 0.
	
	self assert: (canvas edges collect: #border) asSet size equals: numberOfEdges! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testHasEdges
	| s1 s2 |
	s1 := canvas nodes first.
	s2 := canvas nodes second.
	self deny: s1 hasEdges.
	self deny: s2 hasEdges.
	
	b canvas: canvas.
	b objects: #(1 2).
	b connectTo: [ :v | v - 1 ].
	
	self assert: s1 hasEdges.
	self assert: s2 hasEdges.
	self assert: s1 connectedLines size equals: 1
	! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testSimple3

	RSLineBuilder line
		canvas: canvas;
		fromObjects: #(1 2 3 6);
		toObjects: (1 to: 10);
		connectFrom: #yourself to: [ :v | v + 1 ].
	self assert: canvas numberOfEdges equals: 4.
	self assert: (canvas edges collect: [ :e | e from model -> e to model ]) asArray equals: ((Array new: 4) at: 1 put: (1->2); at: 2 put: (2->3); at: 3 put: (3->4); at: 4 put: (6->7); yourself)! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testSimple

	RSLineBuilder line
		canvas: canvas;
		useElementAssociations: (Array 
									with: shapes first -> shapes second
									with: shapes second -> shapes third).
	self assert: canvas numberOfEdges equals: 2! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testWithMoveBehind

	RSLineBuilder line
		canvas: canvas;
		moveBehind;
		useAssociations: (Array 
									with: 1 -> 2
									with: 2 -> 3
									with: 5 -> 6).
	self assert: (canvas canvas shapes collect: [ :c | c class name ]) asArray equals: #(#RSLine #RSLine #RSLine #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox #RSBox)! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testInferCanvas3

	| c |
	c := RSCanvas new.
	1 to: 100 do: [ :i | 
		c add: (RSLabel new
				 text: i;
				 model: i) ].

	RSLineBuilder line
		shapes: c nodes;
		connectFrom: [ :i | i // 2 ].

	RSGridLayout on: c nodes.
	c @ RSCanvasController.

	self assert: c numberOfEdges equals: 99! !

!RSEdgeBuilderTest methodsFor: 'tests' stamp: ''!
testShouldAllowBidirection

	self assert: canvas numberOfEdges equals: 0.
	self assert: b isBidirectional.
	b canvas: canvas.
	b noBidirectional.
	b objects: #(1 2).
	b useAssociations: (Array with: 1 -> 2 with: 2 -> 1 ).
	self deny: b isBidirectional. 
	
	shapes := canvas shapesFromModels: #(1 2).
	self assert: shapes size equals: 2.
	self assert: (b shouldCreateEdgeFrom: shapes first to: shapes second).
	
	self assert: canvas numberOfEdges equals: 1.
	self assert: canvas edges anyOne from model equals: 1.
	self assert: canvas edges anyOne to model equals: 2.! !

!RSElasticBoxInteraction commentStamp: ''!
Elastic box interaction creates an selection box for a group o elements

this interaction works with an announcer. with this events `RSSelectionChangedEvent`, `RSSelectionEndEvent` and `RSSelectionEndEvent`.
!
!RSElasticBoxInteraction methodsFor: 'helper' stamp: ''!
selectedShapesWith: shape
	| rect |
	rect := shape encompassingRectangle.
	
	^ (targetShapes rsValue: shape canvas)
		select: [ :node | (node = shape) not and: [ node encompassingRectangle intersects: rect] ]! !

!RSElasticBoxInteraction methodsFor: 'public' stamp: ''!
useNegativeBox
	shouldUseNegativeBox := true.! !

!RSElasticBoxInteraction methodsFor: 'event processing' stamp: ''!
processDragEnd: event
	draggingCanvas
		ifTrue: [ draggingCanvas := false ]
		ifFalse: [ self boxEnded: event ]
	! !

!RSElasticBoxInteraction methodsFor: 'testing' stamp: ''!
hasInteraction: anInteractionClass
	"Return true or false if the receiver has an interaction. Note that the argument has to be an interaction class. And not an event"
	self announcer subscriptions ifNil: [ ^ false ].
	^ self announcer subscriptions handleSubscriberClass: anInteractionClass! !

!RSElasticBoxInteraction methodsFor: 'helper' stamp: ''!
createElasticBox: event
	| canvas elasticBox |
	canvas := event canvas.
	elasticBox := self box copy.
	canvas addShape: elasticBox.
	^ elasticBox! !

!RSElasticBoxInteraction methodsFor: 'event processing' stamp: ''!
enableDrag: event
	draggingCanvas := true.! !

!RSElasticBoxInteraction methodsFor: 'removing' stamp: ''!
removeInteractionIfPresent: anInteractionClass
	"Remove all the callbacks associated to the interaction."
	(self hasInteraction: anInteractionClass) ifFalse: [ ^ self ].
	(self getInteractionsForClass: anInteractionClass) do: [ :int | self announcer unsubscribe: int ]! !

!RSElasticBoxInteraction methodsFor: 'public' stamp: ''!
leftRight
	events := { RSMouseLeftDragStart. RSMouseRightDragStart }.! !

!RSElasticBoxInteraction methodsFor: 'announcer' stamp: ''!
announce: anEvent
	| a |
	a := self privateAnnouncer.
	a ifNil: [ ^ self ].
	a announce: anEvent value! !

!RSElasticBoxInteraction methodsFor: 'public' stamp: ''!
executeWithoutAnnouncer: aBlock
	| ann |
	ann := self privateAnnouncer.
	self announcer: nil.
	aBlock value.
	self announcer: ann.! !

!RSElasticBoxInteraction methodsFor: 'testing' stamp: ''!
shouldUseNegativeBox
	^ shouldUseNegativeBox! !

!RSElasticBoxInteraction methodsFor: 'accessing' stamp: ''!
events
	"return an array with 2 elements the `boxStartEvent` and `dragStartEvent` "
	^ events! !

!RSElasticBoxInteraction methodsFor: 'announcer' stamp: ''!
privateAnnouncer
	^ announcer! !

!RSElasticBoxInteraction methodsFor: 'announcer' stamp: ''!
announcer
	^ self privateAnnouncer ifNil: [ 
		| a |
		a := Announcer new.
		self announcer: a.
		a ]! !

!RSElasticBoxInteraction methodsFor: 'event processing' stamp: ''!
processDrag: event
	draggingCanvas ifTrue: [ ^ self ].
	self boxUpdated: event! !

!RSElasticBoxInteraction methodsFor: 'announcer' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject
	self announcer when: anAnnouncementClass send: aSelector to: anObject! !

!RSElasticBoxInteraction methodsFor: 'helper' stamp: ''!
updateBoxRectangle: shape with: event
	| corner |
	corner := event position.
	((corner x < startPosition x or: [ corner y < startPosition y ])
		 and: [ self shouldUseNegativeBox not ] )
			ifTrue: [ corner := startPosition ].
	shape fromRectangle: 	(startPosition corner: corner)! !

!RSElasticBoxInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self leftRight.
	baseBox := self defaultBox.
	self useNegativeBox.
	self targetShapes: #nodes.
	draggingCanvas := false.
	! !

!RSElasticBoxInteraction methodsFor: 'event processing' stamp: ''!
boxEnded: event
	| boxEvent |
	boxEvent := self createEvent: RSSelectionEndEvent with: event.
	boxEvent shape remove.
	event canvas removeKey: self className.
	boxEvent selectedShapes: selectedShapes.
	self announce: boxEvent.
	event signalUpdate.! !

!RSElasticBoxInteraction methodsFor: 'public' stamp: ''!
noNegativeBox
	shouldUseNegativeBox := false.! !

!RSElasticBoxInteraction methodsFor: 'helper' stamp: ''!
createEvent: clazzEvent with: originalEvent
	^ clazzEvent new
		canvas: originalEvent canvas;
		shape: (self getOrCreateElasticBox: originalEvent);
		yourself! !

!RSElasticBoxInteraction methodsFor: 'accessing' stamp: ''!
targetShapes
	"Return the targetShapes, usually a collection where the elasticbox with intersets its encompassing rectangle"
	^ targetShapes! !

!RSElasticBoxInteraction methodsFor: 'initialization' stamp: ''!
defaultBox
	| color |
	color := Color colorFrom: '3399FF'.
	^ RSBox new 
		border: (RSBorder new color: color);
		color: (color alpha: 0.2)
		yourself! !

!RSElasticBoxInteraction methodsFor: 'accessing' stamp: ''!
targetShapes: anObject
	"
	Expermode related to read documentation of `rsValue:`
	targetShapes is used to intersect it with the `elastic box`.
	targetShapes can be a collection, selector or block. If this is a selector or block, its argument will be the current Canvas.
	By default targetShapes is `#nodes`.
	Example
	```
	shapes := (1 to: 10) collect: [ :i | RSBox new size: 5 ].
	elastic := RSElasticBox new.
	elastic targetShapes: shapes.
	canvas @ elastic
	```
	"
	targetShapes := anObject! !

!RSElasticBoxInteraction methodsFor: 'accessing' stamp: ''!
dragStartEvent
	"return the drag activation event for RSDraggableCanvas"
	^ self events first! !

!RSElasticBoxInteraction methodsFor: 'announcer' stamp: ''!
when: event do: aBlock
	self announcer when: event do: aBlock! !

!RSElasticBoxInteraction methodsFor: 'announcer' stamp: ''!
announcementClasses
	^ RSSelectionEvent subclasses! !

!RSElasticBoxInteraction methodsFor: 'event processing' stamp: ''!
disableDrag: event
	draggingCanvas := false.
	self boxStarted: event.! !

!RSElasticBoxInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	aCanvas removeInteractionIfPresent: RSDraggableCanvasInteraction.
	aCanvas addInteraction: (RSDraggableCanvasInteraction new 
		mouseEvent: self dragStartEvent).
	aCanvas
		when: self dragStartEvent send: #enableDrag: to: self;
		when: self boxStartEvent send: #disableDrag: to: self;
		when: RSMouseDragging send: #processDrag: to: self;
		when: RSMouseDragEnd send: #processDragEnd: to: self! !

!RSElasticBoxInteraction methodsFor: 'announcer' stamp: ''!
getInteractionsForClass: anInteractionClass
	"Return the Announcement subscriptions for the interaction"
	^ self announcer subscriptions getInteractionsForClass: anInteractionClass! !

!RSElasticBoxInteraction methodsFor: 'announcer' stamp: ''!
announcer: anAnnouncer
	announcer := anAnnouncer! !

!RSElasticBoxInteraction methodsFor: 'event processing' stamp: ''!
boxUpdated: event
	| boxEvent newSelectedShapes |
	boxEvent := self createEvent: RSSelectionChangedEvent with: event.
	self updateBoxRectangle: boxEvent shape with: event.
	newSelectedShapes := self selectedShapesWith: boxEvent shape.
	selectedShapes = newSelectedShapes ifFalse: [ 
		boxEvent
			oldSelectedShapes: selectedShapes;
			selectedShapes: newSelectedShapes.
		selectedShapes := newSelectedShapes.
		self announce: boxEvent.
	].
	
	event signalUpdate.
	! !

!RSElasticBoxInteraction methodsFor: 'helper' stamp: ''!
getOrCreateElasticBox: event
	^ event canvas 
		propertyAt: self className
		ifAbsentPut: [ self createElasticBox: event ]! !

!RSElasticBoxInteraction methodsFor: 'public' stamp: ''!
rightLeft
	events := { RSMouseRightDragStart. RSMouseLeftDragStart }.! !

!RSElasticBoxInteraction methodsFor: 'public' stamp: ''!
box
	^ baseBox! !

!RSElasticBoxInteraction methodsFor: 'accessing' stamp: ''!
selectedShapes
	"return the current selected shapes"
	^ selectedShapes! !

!RSElasticBoxInteraction methodsFor: 'event processing' stamp: ''!
boxStarted: event
	| boxEvent |
	boxEvent := self createEvent: RSSelectionStartEvent with: event.
	boxEvent selectedShapes: (selectedShapes := RSGroup new).
	startPosition := event camera fromPixelToSpace: event position.
	self announce: boxEvent.! !

!RSElasticBoxInteraction methodsFor: 'accessing' stamp: ''!
boxStartEvent
	"return the activation box start event"
	^ self events second! !

!RSElasticBoxInteraction class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSElasticBoxInteraction class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSElasticBoxInteraction class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSElasticBoxInteraction class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSElasticBoxInteraction class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSElasticBoxInteraction class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSElasticBoxInteraction class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSElasticBoxInteraction class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSElasticBoxInteraction class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSElasticBoxInteraction class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSElasticBoxInteraction class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSElasticBoxInteraction class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSElasticBoxInteraction class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSElasticBoxInteraction class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSElasticBoxInteraction class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSElasticBoxInteraction class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSElasticBoxInteraction class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSElasticBoxInteraction class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSElasticBoxInteraction class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSElasticBoxInteraction class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSElasticBoxInteraction class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSElasticBoxInteraction class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RSElasticBoxInteraction class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RSElasticBoxInteraction class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RSElasticBoxInteraction class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSElasticBoxInteraction class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSElasticBoxInteraction class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSElasticBoxInteraction class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSElasticBoxInteraction class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSElasticBoxTest commentStamp: ''!
A RSAbstractElasticBoxTest is a test class for testing the behavior of RSAbstractElasticBox!
!RSElasticBoxTest methodsFor: 'tests' stamp: ''!
testBasic
	canvas @ RSElasticBoxInteraction! !

!RSElasticBoxTest methodsFor: 'tests' stamp: ''!
testEvents
	| number elastic |
	elastic := RSElasticBoxInteraction new.
	number := nil.
	elastic 
		when: RSSelectionStartEvent do: [ :evt | number := 0 ];
		when: RSSelectionChangedEvent do: [ :evt | number := number + 1 ];
		when: RSSelectionEndEvent do: [ :evt | number := number +10 ].
	canvas @ elastic.
	canvas announce: (RSMouseRightDragStart new position: 0@0).
	self assert: number equals: 0.
	canvas announce: (RSMouseDragging new position: 10@10).
	self assert: number equals: 1.
	canvas announce: (RSMouseDragEnd new position: 0@0).
	self assert: number equals: 11.! !

!RSElasticBoxTest methodsFor: 'tests' stamp: ''!
testEventsDraggableCanvas
	| elastic number |
	elastic := RSElasticBoxInteraction new.
	elastic rightLeft.
	canvas @ elastic.
	number := nil.
	elastic when: RSSelectionStartEvent do: [ :evt | number := 0 ].
	canvas announce: (RSMouseLeftDragStart new position: 0@0).
	self assert: number equals: 0.! !

!RSElasticBoxTest methodsFor: 'running' stamp: ''!
setUp
	| shapes |
	super setUp.
	canvas := RSCanvas new.
	shapes := (1 to: 10) collect: [ :i | RSBox new size: 5; yourself ].
	RSGridLayout on: shapes.
	canvas addAll: shapes.! !

!RSElasticInterpolator commentStamp: ''!
TSEasing elasticIn
Elastic easing, like a rubber band. The amplitude and period of the oscillation are configurable; if not specified, they default to 1 and 0.3, respectively.

TSEasing elasticOut
Reverse elastic easing; equivalent to 1 - elasticIn(1 - t).

TSEasing elastic 
TSEasing elasticInOut.
Symmetric elastic easing; scales elasticIn for t in [0, 0.5] and elasticOut for t in [0.5, 1].!
!RSElasticInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateOut: t
	^ 1 - (amplitude * (2 raisedTo: -10 * t ) * ((t + s) / period) sin )! !

!RSElasticInterpolator methodsFor: 'accessing' stamp: ''!
amplitude
	^ amplitude! !

!RSElasticInterpolator methodsFor: 'accessing' stamp: ''!
period: p
	period := p.
	self calculateS.! !

!RSElasticInterpolator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	tau := 2* Float pi.
	amplitude := 1.
	period := 0.3.
	
	self calculateS! !

!RSElasticInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateIn: i
	| t |
	t := i -1.
	^ amplitude * (2 raisedTo: 10*t) * ((s - t) / period) sin! !

!RSElasticInterpolator methodsFor: 'accessing' stamp: ''!
period
	^ period! !

!RSElasticInterpolator methodsFor: 'accessing' stamp: ''!
calculateS
	"var s = Math.asin(1 / (a = Math.max(1, a))) * (p /= tau);"
	amplitude := 1 max: amplitude.
	period := period / tau.
	s := (1 / amplitude) arcSin * period ! !

!RSElasticInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateInOut: i
	| t |
	t := i * 2 - 1.
	^ (t < 0
		ifTrue: [ amplitude * (2 raisedTo: 10 * t) * ((s - t)/period) sin ]
		ifFalse: [ 2 - (amplitude * (2 raisedTo: -10 * t) * ((s + t)/period) sin )   ]) / 2.! !

!RSElasticInterpolator methodsFor: 'accessing' stamp: ''!
amplitude: a
	amplitude := a.
	period := period * tau.
	self calculateS.! !

!RSEllipse commentStamp: ''!
I am an ellipse shape

Here an example:

```Smalltalk
c := RSCanvas new.
(30 to: 150 by: 10) do: [ :nb |
b := RSEllipse new width: nb; height: nb / 2.
c add: b ].
RSFlowLayout on: c nodes.
c @ RSCanvasController.
c open
```!
!RSEllipse methodsFor: 'testing' stamp: ''!
includesPoint: aPoint
	"Implementation is taken over from EllipseMorph>>containsPoint:"
	| invertedPoint radius other delta xOverY t1 t2 rect |
	invertedPoint := matrix rsInverseTransform: aPoint.
	rect := self baseRectangle.
	(rect containsPoint: invertedPoint) ifFalse: [ ^ false ]. "quick elimination"
	radius := rect height asFloat / 2.
	other := rect width asFloat / 2.
	delta := invertedPoint - rect topLeft - (other@radius).
	xOverY := rect width asFloat / rect height asFloat.
	t1 := (delta x asFloat / xOverY) squared + delta y squared.
	t2 := radius squared.
	^ (t1 < t2)  or: [ t1 closeTo: t2 ].! !

!RSEllipse methodsFor: 'geometry' stamp: ''!
geometry 
	| rect e p |
	rect := self encompassingRectangle.
	e := rect extent / 2.
	p := self position.
	e = (0@0) ifTrue: [ ^ p asGPoint ].
	^ GEllipse 
		center: p
		vertex: p + (e x@ 0)
		coVertex: p + (0@ e y)! !

!RSEllipse methodsFor: 'accessing' stamp: ''!
radius
	^ self extent x / 2! !

!RSEllipse methodsFor: 'visiting' stamp: ''!
buildPathOn: visitor
	visitor buildEllipsePath: self! !

!RSEllipse methodsFor: 'accessing' stamp: ''!
radius: integer
	self extent: integer * 2 asPoint! !

!RSEmptyContextInteraction commentStamp: ''!
I do not register any interaction to the RSCanvas and its shapes!
!RSEmptyContextInteraction methodsFor: 'hooks' stamp: ''!
interactionsToBeRegistered
	^ #()! !

!RSEquidistantCircleLayout commentStamp: ''!
RTEquidistantCircleLayout is a circle layout in which elements are equidistant from each other: the layout maintains the same distance between elements.

Here is an example:
-=-=-=-=-=-=-=-=-=-=-=-=
v := RSView new.
elements := (RSShapeBuilder circle size: 5; color: Color red; size: [:vv | vv * 4 ]) elementsOn: (1 to: 15).
v addAll: elements.
RSEquidistantCircleLayout on: elements.
v @ RSControlsView.
v open
-=-=-=-=-=-=-=-=-=-=-=-=!
!RSEquidistantCircleLayout methodsFor: 'hook' stamp: ''!
doExecute: elements
	| angle rad center angleIncrement |
	rad := self computeRadiusFor: elements.
	center := Point x: rad y: rad.
	angle := self initialAngle.
	elements
		do: [ :each | 
			| point |
			"First, the angle is increased only by the angle given by the element radius (height/2),
			then the point is set, and then it's increased by the rest of the total increment"
			"This is to consider both last and next elements weights"
			angle := angle + ((each height)/(2*rad)).
			point := center + (Point r: rad theta: angle).
			angleIncrement := (((each height)/2) + (self computeSeparationFor: elements))/rad.
			angle := angle + angleIncrement.
			translator translate: each to: point.
		]! !

!RSEquidistantCircleLayout methodsFor: 'hook' stamp: ''!
computeSeparationFor: elements
"Compute the separation between each element, this separation will always be the same"
	| sep |
	sep := ((2 * Float pi * (self computeRadiusFor: elements)) - (self weightSum: elements))/
	(elements size).
	^sep! !

!RSEvent commentStamp: ''!
<keyClass>
`RSEvent` is the root of all the events handled by Roassal. Events are expressed as an instance of a subclass of `RSEvent`. Some events describe the actions made by the users (e.g., `RSMouseDragEnd`), some other event describes some state change of a shape (e.g., `RSShapeAddedEvent`, `RSHighlightEvent`).

*Responsibility*: model an event triggered either by a user action or a state change.

*Collaborators*: events are emitted by `RSAthensMorph` or by some interaction (e.g., `RSHighlightable`)

*Variables*:
- `canvas`: the `RSCanvas` 
- `morph`: the `RSAthensMorph` 
- `shape`: the shape related to the event
  !
!RSEvent methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self timeStamp! !

!RSEvent methodsFor: 'accessing' stamp: ''!
timeStamp
	"Return the millisecond clock value at which the event was generated"
	^ timeStamp ifNil:[ timeStamp := Time millisecondClockValue ]! !

!RSEvent methodsFor: 'accessing' stamp: ''!
canvas: aRSCanvas
	canvas := aRSCanvas! !

!RSEvent methodsFor: 'accessing' stamp: ''!
morph
	^ morph ifNil: [ ^ morph := self canvas morph ]! !

!RSEvent methodsFor: 'accessing' stamp: ''!
morph: aMorph
	morph := aMorph! !

!RSEvent methodsFor: 'accessing' stamp: ''!
camera
	^ self canvas camera! !

!RSEvent methodsFor: 'accessing' stamp: ''!
shape
	^ shape! !

!RSEvent methodsFor: 'accessing' stamp: ''!
signalUpdate
	"Trigger a refresh of the morph. The method signalUpdate has to be called when some visual properties are changed (e.g., color, position)"
	morph notNil ifTrue: [ morph changed ]
	! !

!RSEvent methodsFor: 'accessing' stamp: ''!
timeStamp: stamp
	timeStamp := stamp! !

!RSEvent methodsFor: 'accessing' stamp: ''!
shape: aRSShape
	"An event should now the shape to which it is related to. 
	The shape has to be set before emitting the event."
	shape := aRSShape! !

!RSEvent methodsFor: 'accessing' stamp: ''!
canvas
	^ canvas ifNil: [ canvas := shape canvas ].! !

!RSExamplesTest methodsFor: 'tests' stamp: ''!
executeTest: method in: exampleClass
	| res |
	res := exampleClass perform: method selector.
	self
		deny: res = exampleClass
		description: '''' , method selector, ''', should return a canvas or view.'
		! !

!RSExamplesTest methodsFor: 'tests' stamp: ''!
testExamples
	"This tests execute all the examples of Roassal. Introspectively, it looks for subclasses of RSAbstractExamples"
	| clazz |
	self timeLimit: 10 minutes.
	clazz := Smalltalk at: #RSAbstractExamples ifAbsent: [ ^ self ].
	clazz subclasses do: [ :cls | 
		| inst methods |
		inst := cls new.
		methods := cls methods 
			select: [ :met | 
				(met selector beginsWith: 'example') 
				and: [ (met hasPragmaNamed: 'noTest') not ] ].
		methods sort: CompiledMethod sortBlock.
		methods
			do: [ :met | self executeTest: met in: inst ]
			displayingProgress: [ :met | met selector ]
			every: 100 ]
		displayingProgress: [ :cls | cls asString ]
		every: 500! !

!RSExpInterpolator commentStamp: ''!
TSEasing expIn
Exponential easing; raises 2 to the exponent 10 * (t - 1).

TSEasing expOut 
Reverse exponential easing; equivalent to 1 - expIn(1 - t).

TSEasing exp 
TSEasing expInOut 
Symmetric exponential easing; scales expIn for t in [0, 0.5] and expOut for t in [0.5, 1].!
!RSExpInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateIn: t
	^ 2 raisedTo: (10 * t - 10).! !

!RSExpInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateInOut: i
	| t |
	t := i * 2.
 
	^ (t <= 1
		ifTrue: [ 2 raisedTo: 10 * t - 10 ]
		ifFalse: [ 2 - (2 raisedTo: 10 - (10 * t)) ])/2! !

!RSExpInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateOut: t
	^ 1 - (2 raisedTo: -10 * t).! !

!RSExtentChangedEvent commentStamp: ''!
When a bounding shape uses extent:, width: or height: I will trigger 

Consider the following example:

```
nodes := (1 to: 20) shuffled.

canvas := RSCanvas new.
shapes := RSCircle models: nodes.
shapes size: 30.
canvas addAll: shapes.
RSNormalizer size
    shapes: shapes;
    normalize.

RSFlowLayout on: shapes.
canvas zoomToFit.
canvas when: RSExtentChangedEvent do: [ :event |
    RSFlowLayout new 
        maxWidth: event newExtent;
        on: shapes.
    canvas zoomToFit.
].
canvas open
```!
!RSExtentChangedEvent methodsFor: 'accessing' stamp: ''!
oldExtent: aPoint
	oldExtent := aPoint! !

!RSExtentChangedEvent methodsFor: 'accessing' stamp: ''!
newExtent: aPoint
	newExtent := aPoint! !

!RSExtentChangedEvent methodsFor: 'accessing' stamp: ''!
newExtent
	^ newExtent! !

!RSExtentChangedEvent methodsFor: 'accessing' stamp: ''!
oldExtent
	^ oldExtent! !

!RSFlowLayout commentStamp: ''!
A RTFlowLayout arrange elements in a rectangle including space (gapSize) between them, ideally it give you a square if all elements have an equal height and width .
!
!RSFlowLayout methodsFor: 'alignment' stamp: ''!
alignBottom
	alignment := #bottom! !

!RSFlowLayout methodsFor: 'testing' stamp: ''!
isAlignBottom
	^ alignment = #bottom! !

!RSFlowLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self alignTop.! !

!RSFlowLayout methodsFor: 'alignment' stamp: ''!
alignMiddle
	alignment := #middle! !

!RSFlowLayout methodsFor: 'hook' stamp: ''!
linesFor: shapes
	| x y maxLastLineHeight nextElement maxWidthFloat lines currentLine gap |
	gap := self gapSize.
	x := y := gap.
	maxLastLineHeight := 0.
	maxWidthFloat := self maxWidth rsValue: shapes.
	lines := OrderedCollection new.
	currentLine := OrderedCollection new.
	shapes doWithIndex: [ :element :index |
		element translateTo: (x @ y) + (element extent / 2.0).
		currentLine add: element.
		x := x + element width + gap.
		maxLastLineHeight := maxLastLineHeight max: element height.
		nextElement := shapes at: (index + 1 min: shapes size).
		(x + nextElement width) > maxWidthFloat ifTrue: [
			
			lines add: currentLine.
			x := gap.
			y := y + maxLastLineHeight + gap.
			currentLine := OrderedCollection new.
			maxLastLineHeight := 0.
		].
		
	].
	currentLine ifNotEmpty: [ lines add: currentLine ].
	^ lines! !

!RSFlowLayout methodsFor: 'alignment' stamp: ''!
alignTop
	alignment := #top! !

!RSFlowLayout methodsFor: 'testing' stamp: ''!
isAlignLabel
	^ alignment = #label! !

!RSFlowLayout methodsFor: 'testing' stamp: ''!
isAlignMiddle
	^ alignment = #middle! !

!RSFlowLayout methodsFor: 'testing' stamp: ''!
isAlignTop
	^ alignment = #top! !

!RSFlowLayout methodsFor: 'alignment' stamp: ''!
alignLabel
	"Allow to align labels along their baseline.
	
```Smalltalk
words := (String loremIpsum: 100) substrings.
r := Random new.
wordShapes := words collect: [ :w | RSLabel new fontSize: (r nextInt: 30); text: w ] as: RSGroup.

c := RSCanvas new.
c addAll: wordShapes.
RSFlowLayout new alignLabel; on: wordShapes.
c @ RSCanvasController.
c open
```
"
	alignment := #label! !

!RSFlowLayoutTest methodsFor: 'tests' stamp: ''!
testLinesEven
	| layout lines line n |
	layout := RSFlowLayout new.
	layout maxWidth: 20.
	lines := layout linesFor: shapes.
	n := 5.
	self assert: lines size equals: n.
	line := lines last.
	"all shapes has the same size"
	
	self 
		assert: line first position y 
		equals: (layout gapSize* n)+(shapes first height * (n - 0.5))! !

!RSFlowLayoutTest methodsFor: 'tests' stamp: ''!
testLinesOdd
	| layout lines line n |
	layout := RSFlowLayout new.
	layout maxWidth: 30.
	layout on: shapes.
	lines := layout linesFor: shapes.
	n := 4.
	self assert: lines size equals: n.
	line := lines last.
	"all shapes has the same size"
	
	self 
		assert: line first position y 
		equals: (layout gapSize* n)+(shapes first height * (n - 0.5))! !

!RSForceBasedLayout commentStamp: ''!
I am a layout that uses forces in each elements, I have create a light representation of one element.
For example:
-=-=-=-=-=-=-=-=-=
c := RSCanvas new.
c addAll: ((1 to: 100) collect: [:i | RSEllipse new size: 10; model: i]).

eb := RSEdgeBuilder line.
eb canvas: c.
eb connectFrom: [ :v | v // 2 ].

RSForceBasedLayout on: c nodes.
c
-=-=-=-=-=-=-=-=-=!
!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
center
	^ center! !

!RSForceBasedLayout methodsFor: 'events' stamp: ''!
stepGravityForce
	"Apply gravity"
	| k |
	k := alpha * gravity.
	(k closeTo: 0) ifTrue: [ ^ self ].
	nodes do: [ :each | 
		| pos |
		pos := each position.
		each translateTo: pos + (k * (center - pos)) ]
! !

!RSForceBasedLayout methodsFor: 'events' stamp: ''!
stepFriction
	"Apply friction. This is the last to do in a step, after new positions have been defined."
	nodes do: [ :each | 
		| current new old |
		current := each position.
		old := each oldPosition.

		new := current - ((old - current) * friction).
		each translateTo: new.
		each oldPosition: current ]! !

!RSForceBasedLayout methodsFor: 'private - initialization' stamp: ''!
newMockLineFor: e
	| from to |
	from := self mockElementAt: e from.
	to := self mockElementAt: e to.
	from addWeight.
	to addWeight.
	^ RSMockLine new
		from: from;
		to: to;
		strength: strength;
		length: length;
		realLine: e;
		yourself! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
length: aFloat
	"Specifiy the length of the edges. E.g., 50"
	length := aFloat! !

!RSForceBasedLayout methodsFor: 'accessing - model' stamp: ''!
mockElementAt: realNode ifPresent: presentBlock

	^ nodes
		  detect: [ :each | each realShape == realNode ]
		  ifFound: presentBlock! !

!RSForceBasedLayout methodsFor: 'adding/removing' stamp: ''!
removeEdge: aRealEdge

	self mockLineAt: aRealEdge ifPresent: [ :edge | lines remove: edge ]! !

!RSForceBasedLayout methodsFor: 'adding/removing' stamp: ''!
addNodes: realElements
	| newMockElements |
	newMockElements := (realElements collect: [ :e | self newMockElementFor: e ]).
	nodes class = Array ifTrue: [ nodes := nodes asOrderedCollection ].
	nodes addAll: newMockElements.
	! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
charge: aFloat
	"Typically a negative value. E.g., -300.
	This value affects new nodes. then you can change charge for each node"
	charge := aFloat! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
friction: aNumber
	"usuarly a value between 0 and 1
	This affects all nodes"
	friction := aNumber! !

!RSForceBasedLayout methodsFor: 'events' stamp: ''!
stepEdgeForces
	"Apply forces of edges."
	lines do: [ :each | 
		| from to fp tp len k pd |
		from := each from.
		to := each to.
		fp := from position.
		tp := to position.
		pd := tp - fp.
		len := tp distanceTo: fp.
		(len closeTo: 0) ifFalse: [
			len := alpha * (each strength) * (len - (each length)) / len.
			pd := pd * len.
			k := from weight / (from weight + to weight).
			to translateTo: tp - (pd * k).
			k := 1 - k.
			from translateTo: fp + (pd * k).]
	].
! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
autoRepulse: aBoolean
	autoRepulse := aBoolean ! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
strength: aFloat
	"Set the force of attraction for the edges. A high value results in having nodes together.
	The default value is 1.0"
	strength := aFloat! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
alpha
	^ alpha! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
currentQuadtree
	^ quadtree! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
autoRepulse
	^ autoRepulse! !

!RSForceBasedLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	random := Random seed: 42.
	self
		autoRepulse: false;
		iterations: 0;
		edges: #();
		nodes: #();
		initialLayout: RSGridLayout new;
		gravity: 0.1;
		friction: 0.9;
		theta: 0.8;
		strength: 1;
		length: 20;
		charge: -30;
		center: 0@0;
		useProgressBar.! !

!RSForceBasedLayout methodsFor: 'events' stamp: ''!
stepNodeRepulsion
	"Handle fixed nodes. Do this after all forces in a step were already applied."
	quadtree := RSQuadTreeF withAll: nodes.
	self accumulate: quadtree.
	nodes
		do: [ :each | 
			each isFixed
				ifTrue: [ each translateTo: each fixPosition ]
				ifFalse: [ self repulse: each from: quadtree ] ]! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
charge
	^ charge! !

!RSForceBasedLayout methodsFor: 'hook' stamp: ''!
runLayoutSimply
	self runLayoutIn: Job new.
	"iterations = 0 ifTrue: [ 
		[ alpha := alpha * 0.99.
		alpha > 0.005 ] whileTrue: [ self step ] ]
	ifFalse: [ 
		iterations timesRepeat: [ 
			alpha := alpha * 0.99.
			self step ] ]"! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
initialLayout
	^ initialLayout! !

!RSForceBasedLayout methodsFor: 'testing' stamp: ''!
shouldUseProgressBar
	^ shouldUseProgressBar! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
iterations: aNumber
	"aNumber is a 0 positive number used to run this layout aNumber times"
	iterations := aNumber! !

!RSForceBasedLayout methodsFor: 'algorithm' stamp: ''!
repulse: aNode from: aQuad
	
	aQuad soleChild = aNode ifFalse: [
		| d |
		d := aQuad centerOfCharge - aNode position.
		(d closeTo: 0@0) ifFalse: [
			| dn p k |
			dn := 1 / d r.
			p := aNode oldPosition.
			aQuad rectangle width * dn < theta
				ifTrue: [
					k := aQuad charge * dn * dn.
					aNode oldPosition: p - (d * k).
					^ self ].
			(aQuad soleChild notNil and: [ dn < 1e9 ])
				ifTrue: [
					k := aQuad soleChild charge * dn * dn * alpha.
					aNode oldPosition: p - (d * k).] ] ].
 
	(aQuad charge closeTo: 0) ifFalse: [ 
		aQuad subQuadsDo: [ :aSubQuad | self repulse: aNode from: aSubQuad ] ]
! !

!RSForceBasedLayout methodsFor: 'events' stamp: ''!
step
	nodes ifEmpty: [ ^ self ].
	self stepEdgeForces.
	self stepGravityForce.
	self stepNodeRepulsion.
	self stepFriction.
	nodes do: #applyToRealElement! !

!RSForceBasedLayout methodsFor: 'algorithm' stamp: ''!
accumulate: aQuad 
	| centerCharge |
	centerCharge := 0@0.
	aQuad charge: 0; centerOfCharge: 0@0.
	aQuad isLeaf ifFalse: [
		aQuad subQuadsDo: [ :aSubQuad |
			self accumulate: aSubQuad.
			aQuad charge: aQuad charge + aSubQuad charge.
			centerCharge := centerCharge + (aSubQuad charge * aSubQuad centerOfCharge)] ].

	aQuad soleChild ifNotNil: [ :soleChild |
		| k |
		aQuad isLeaf ifFalse: [
			soleChild translateTo: soleChild position + (random next @ random next) - 0.5 ].
		k := alpha * soleChild charge.
		aQuad charge: aQuad charge + k.
		centerCharge := centerCharge + (k * soleChild position) ].
		
	aQuad charge = 0 ifTrue: [ ^ self ].		
	aQuad centerOfCharge: centerCharge / aQuad charge.		
! !

!RSForceBasedLayout methodsFor: 'hook' stamp: ''!
runLayoutIn: job
	"Central method"
	iterations isZero ifTrue: [ 
		[alpha := alpha * 0.99.
		alpha > 0.005 ] whileTrue: [ 
			self step.
			job currentValue: 1 - alpha ] ]
	ifFalse: [ 
		iterations timesRepeat: [ 
			alpha := alpha * 0.99.
			self step.
		job currentValue: 1 - alpha ] ]! !

!RSForceBasedLayout methodsFor: 'public - configuration' stamp: ''!
doNotUseProgressBar
	shouldUseProgressBar := false! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
gravity
	^ gravity! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
length
	^ length! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
alpha: aFloat
	"alpha is a value between 0 and 1.
	- 1 represents a strong change in nodes position.
	- 0.01 represents a weak change"
	alpha := aFloat! !

!RSForceBasedLayout methodsFor: 'accessing - model' stamp: ''!
mockElementAt: realNode
	^ nodes detect: [ :each | each realShape == realNode ]! !

!RSForceBasedLayout methodsFor: 'private - initialization' stamp: ''!
newMockElementFor: e
	^ RSMockShape new
		realShape: e;
		charge: charge;
		weight: 0;
		yourself! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
center: aPoint
	"gravity moves elements to that point"
	center := aPoint.! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
initialLayout: aLayout
	"The default layout performed before run this layout"
	initialLayout := aLayout! !

!RSForceBasedLayout methodsFor: 'accessing - model' stamp: ''!
nodes
	^ nodes! !

!RSForceBasedLayout methodsFor: 'hook' stamp: ''!
calculateAutoRepulseFor: line
	| e1 e2 n |
	e1 := line from extent.
	e2 := line to extent.
	e1 := e1 x max: e1 y.
	e2 := e2 x max: e2 y.
	n := (e1 + e2) * 0.7.
	line length: n.
		
	! !

!RSForceBasedLayout methodsFor: 'hook' stamp: ''!
doExecute: nodeShapes
	nodeShapes do: [ :n | n updateLinesOFF ].
	self nodes: nodeShapes.
	self start.
	self shouldUseProgressBar
		ifTrue: [ self runLayoutInJob ]
		ifFalse: [ self runLayoutSimply ].
	alpha := 0.
	nodes do: [ :e | translator translateTopLeftOf: e to: e position ].
	nodeShapes do: [ :n | n updateLinesON. n connectedLines do: #update ].! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
gravity: aNumber
	"it is the force from nodes to move around center"
	gravity := aNumber! !

!RSForceBasedLayout methodsFor: 'adding/removing' stamp: ''!
removeNode: aRealNode
	| node |
	node := self mockElementAt: aRealNode.
	nodes remove: node.
	! !

!RSForceBasedLayout methodsFor: 'accessing - model' stamp: ''!
mockLineAt: anEdge
	^ lines detect: [ :each | each realLine == anEdge ] ifNone: [ nil ]! !

!RSForceBasedLayout methodsFor: 'public - configuration' stamp: ''!
useProgressBar
	"Public method. Make the layout use a progress bar"
	shouldUseProgressBar := true! !

!RSForceBasedLayout methodsFor: 'hook' stamp: ''!
calculateAutoRepulse
	lines do: [ :line | self calculateAutoRepulseFor: line ].
	nodes do: [ :node | | e |
		e := node extent.
		e := e x max: e y.
		node charge: e * -2 ].
	! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
friction
	^ friction! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
theta: aNumber
	"Theta coefficient from Barnes-Hut simulation
	- Value ranges on [0, 1]
  	- Performance is better with smaller values
  	- Very small values may not create enough force to give a good result"
	theta := aNumber! !

!RSForceBasedLayout methodsFor: 'accessing - model' stamp: ''!
nodes: aCollection
	nodes := aCollection! !

!RSForceBasedLayout methodsFor: 'adding/removing' stamp: ''!
addLines: realLines
	| newMockLines |
	newMockLines := realLines collect: [ :e | self newMockLineFor: e ].
	lines class = Array ifTrue: [ lines := OrderedCollection new ].
	lines addAll: newMockLines.
! !

!RSForceBasedLayout methodsFor: 'accessing - model' stamp: ''!
mockLineAt: anEdge ifPresent: presentBlock
	^ lines detect: [ :each | each realLine == anEdge ] ifFound: presentBlock! !

!RSForceBasedLayout methodsFor: 'hook' stamp: ''!
runLayoutInJob
	[ :job | 
		job
			title: 'Laying out elements';
			min: 1 - alpha;
			max: 1.
		self runLayoutIn: job ] asJob run! !

!RSForceBasedLayout methodsFor: 'hook' stamp: ''!
start
	"mandatory for animations"
	initialLayout on: nodes.
	nodes := nodes collect: [ :node | self newMockElementFor: node ].
	lines := lines collect: [ :e | self newMockLineFor: e ].
	self autoRepulse ifTrue: [ 
		self calculateAutoRepulse.
		 ].
	alpha ifNil: [ alpha :=  0.1 ]! !

!RSForceBasedLayout methodsFor: 'accessing' stamp: ''!
theta
	^ theta! !

!RSForceBasedLayoutTest methodsFor: 'tests' stamp: ''!
testAutoRepulse
	self assert: RSForceBasedLayout new autoRepulse equals: false.
	RSForceBasedLayout new
		autoRepulse: true;
		on: boxes.

	self assert: (boxes collect: #position as: Array) equals: {(0.889897903270647@ -26.64950618107099). (36.789778253524084@49.42621842228547). (-40.85950835555051@35.533490168858094). (-23.954627132264314@ -71.27472748447899). (49.58827498691415@ -52.80088255971976). (17.87614168165759@ -55.75505686471987). (61.87648734703305@ -0.9076901998445767). (-60.5091564515173@ -37.68032357780954). (4.896025624083695@21.1931800643391). (-68.06874847265544@2.5223581824636616). (-10.951498331656955@ -37.28323120477288). (4.297688603124512@ -11.052973390226192). (51.920939775077336@45.6269505152328). (21.923903211386914@54.90579786747414). (-42.02055569669671@51.840884764740245). (-27.831612602948724@26.334088383681074). (-38.53640151040798@ -65.53114745133016). (-8.746555941058311@ -73.94644589750672). (49.53660675690446@ -36.71773319395541). (63.859851991715566@ -46.556029126764585). (24.7974672940329@ -41.92154739527213). (21.815172466870894@ -70.36796693436904). (76.00557956197717@ -5.405135878363031). (47.118617816183146@ -3.175014189825418). (-71.11995162800334@ -26.33917108681172). (-51.14899405282955@ -24.968832025299193). (1.1538900254637785@36.105209875955424). (20.345979951088417@18.52808970034326). (-71.76456282043816@17.44421857429005). (-52.56778893889752@4.419384904642408). (-25.358670899184528@ -43.585313480262336). (-22.61995878864715@ -25.78342536811189). (-8.88172375558412@ -1.924273621283506). (20.143996985233866@ -9.18910150273737). (65.64770779499827@37.68004157688667). (50.079217793732056@29.651096079372053). (8.163918670283628@63.168700650713966). (25.962191094343886@70.08263223784023). (-57.51760240762769@49.80167488184632). (-32.208912828349256@64.48141989235883). (-20.391917700674068@40.633477772824314)}! !

!RSForceBasedLayoutTest methodsFor: 'tests' stamp: ''!
testBasic
	RSForceBasedLayout new
		doNotUseProgressBar;
		on: boxes.
		
	self assert: (boxes collect: #position as: Array) equals: {(0.454927162200802@ -44.54221403928398). (53.37581092890057@27.670211543492943). (-56.2859815804936@37.029480656729284). (-32.33446963249424@ -87.0430717441884). (57.91816782423318@ -41.44558073281318). (39.66493611803014@ -76.07962752549906). (77.93230939425497@5.419385881745582). (-69.25159776653548@ -32.73708840422655). (4.610659587814698@72.30962056673572). (-91.62325361102737@ -11.919890690387835). (-19.287428176096537@ -53.01502756481294). (5.750504537546112@ -23.523467318608176). (32.513585562287005@21.34365997370242). (70.77743976425991@40.782176512132175). (-66.8497494464371@55.93131308549673). (-36.665692368700824@27.75134465146806). (-52.62578042768019@ -78.87022922311459). (-10.963721279232619@ -89.0979345880265). (78.10482483005474@ -34.328117882349304). (68.86265870227328@ -59.99073039579607). (30.988214973855793@ -56.38930189547585). (23.194787144522333@ -89.12325188171897). (59.81808478922064@ -5.8440545311732865). (97.42109010758212@ -1.373342061274858). (-63.1947859637622@ -11.181787134804535). (-49.73916736500038@ -21.816303252876086). (-10.49746088544301@87.25938625861075). (21.66130271633641@85.29983538216666). (-98.60102185545328@8.68273975750693). (-78.92722114045554@6.91875924294493). (-40.95247965167202@ -54.644095463334665). (-25.732680489621295@ -31.986026632838836). (-4.44372938212735@ -4.3767932245306636). (25.557875569514447@ -15.936230910472633). (26.33544067515422@42.58785504183399). (11.160168008454821@24.27630378168977). (56.00868159956866@57.952420367099585). (76.98955309121966@61.14957043860566). (-58.8766805125466@76.27922958224977). (-45.18245972261805@62.47246694917919). (-18.069288207849475@38.788862990211285)}! !

!RSForceBasedLayoutTest methodsFor: 'tests' stamp: ''!
testAttributes
	RSForceBasedLayout new
		length: 100;
		charge: -300;
		center: 200@200;
		on: boxes.
	
	self assert: (boxes collect: #position as: Array) equals: {(181.36169178662738@36.316036454042305). (340.716801610261@305.81832193719885). (8.50433539059589@310.7758161932311). (76.6516959166559@ -59.20475956937193). (333.6392914905099@ -76.53121743449714). (263.90419253156705@43.30650708072338). (479.08098170547817@117.38058991830584). (19.30011840177135@215.11746164041105). (203.9447059384078@362.26518768239345). (-67.94956534700167@92.53296143356859). (80.86446278264185@30.812714389684714). (228.89468545328134@128.6801766266105). (443.14374760712377@309.6187351195402). (293.46210945645413@397.12700049212526). (18.26183616653404@410.2180519415626). (105.85124037828402@331.70588495391644). (-9.444718869615206@ -7.95578781723829). (168.52752072462545@ -96.02346541513958). (337.92969751526084@21.5226944733643). (414.3794328985994@ -12.338360667688402). (356.4263152004545@85.6821006093476). (235.51798720811172@ -53.33841718169906). (384.3257723829778@150.64698612030801). (427.44137110530437@205.82236333110282). (112.33398609252319@250.84524565444843). (11.302715417781338@112.99963840895114). (203.17108943679037@463.53319161963645). (257.45213393823514@279.0757253876397). (-113.9100226736106@183.9273722260484). (-53.05852092210428@195.44012877251865). (83.96151223730722@133.52046721416698). (146.23502510635467@107.5108048395725). (191.55980232320624@221.6610884058037). (300.90450241790643@198.35108684028563). (501.8854617267401@229.15858480867703). (427.0163771585679@411.03433395620215). (283.60696991667714@495.39085533153735). (385.85636952335983@365.04696864445873). (-61.418341798452914@349.10829410682754). (83.76423188596154@485.1752612604357). (131.3324580558331@426.86864604934004)}! !

!RSForceBasedLayoutTest methodsFor: 'tests' stamp: ''!
testAddNodesAndEdges

	RSForceBasedLayout new
		start;
		addNodes: boxes;
		addLines: canvas edges;
		step.
	
	self assert: (boxes collect: #position as: Array) equals: {(204.1381767192054@ -34.65975567128365). (41.6086750973881@ -330.64514821559214). (-437.64121980646655@138.4449837721012). (629.106833418821@ -213.35229450714166). (-171.26791462481438@ -114.27272445604714). (165.05247082344806@ -170.18306072876882). (-143.86418278241095@179.70435711976). (-45.14813741792285@348.1141409355912). (526.169880616215@ -88.70743211410085). (176.3244614439574@ -83.50029028072399). (-332.02040632080855@124.43126055068214). (-68.861761464375@402.1189842427126). (-93.64122655285627@134.0071205210135). (209.0701564771561@46.16793117345678). (-145.88222068511843@ -187.856251669607). (-245.59594460619587@ -998.5852435459608). (69.17634804610802@ -389.22699598484235). (-81.058777229675@ -266.8242152617776). (-239.1677329629107@387.38247425908116). (-298.244019432684@ -478.6636378594302). (554.2864294374763@ -345.0449450754109). (83.77169882312965@307.80828092151535). (154.51065837660113@124.67245322480098). (-97.78774438677755@119.71040238490563). (-114.84373567808449@ -196.79917392925398). (-2630.492471838436@5619.89941797112). (287.8792223887767@22.99051914576157). (69.19603469859378@ -352.6677751569359). (148.3754047315037@ -205.04539909521708). (35.46378454321605@265.52467506793124). (-148.93212453920935@147.7573881438297). (-332.82400226848773@ -126.40573430977705). (-289.8209003737269@ -230.8639904888284). (263.2113898041367@11.242914359614108). (-145.73522573503845@149.16645846308464). (166.65319011541882@ -578.7962139728857). (218.49866543137253@34.42504672803043). (-170.65430176680417@ -392.4494042748909). (300.0018302573603@ -200.09384102093748). (-223.95997500210785@42.27475866338375). (472.45208863125396@1527.2444661739955)} ! !

!RSForceBasedLayoutTest methodsFor: 'tests' stamp: ''!
testBasic02
	RSForceBasedLayout on: boxes.

	self assert: (boxes collect: #position as: Array) equals: {(0.454927162200802@ -44.54221403928398). (53.37581092890057@27.670211543492943). (-56.2859815804936@37.029480656729284). (-32.33446963249424@ -87.0430717441884). (57.91816782423318@ -41.44558073281318). (39.66493611803014@ -76.07962752549906). (77.93230939425497@5.419385881745582). (-69.25159776653548@ -32.73708840422655). (4.610659587814698@72.30962056673572). (-91.62325361102737@ -11.919890690387835). (-19.287428176096537@ -53.01502756481294). (5.750504537546112@ -23.523467318608176). (32.513585562287005@21.34365997370242). (70.77743976425991@40.782176512132175). (-66.8497494464371@55.93131308549673). (-36.665692368700824@27.75134465146806). (-52.62578042768019@ -78.87022922311459). (-10.963721279232619@ -89.0979345880265). (78.10482483005474@ -34.328117882349304). (68.86265870227328@ -59.99073039579607). (30.988214973855793@ -56.38930189547585). (23.194787144522333@ -89.12325188171897). (59.81808478922064@ -5.8440545311732865). (97.42109010758212@ -1.373342061274858). (-63.1947859637622@ -11.181787134804535). (-49.73916736500038@ -21.816303252876086). (-10.49746088544301@87.25938625861075). (21.66130271633641@85.29983538216666). (-98.60102185545328@8.68273975750693). (-78.92722114045554@6.91875924294493). (-40.95247965167202@ -54.644095463334665). (-25.732680489621295@ -31.986026632838836). (-4.44372938212735@ -4.3767932245306636). (25.557875569514447@ -15.936230910472633). (26.33544067515422@42.58785504183399). (11.160168008454821@24.27630378168977). (56.00868159956866@57.952420367099585). (76.98955309121966@61.14957043860566). (-58.8766805125466@76.27922958224977). (-45.18245972261805@62.47246694917919). (-18.069288207849475@38.788862990211285)}! !

!RSForceBasedLayoutTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new.
	boxes := RSBox models: (10 to: 50).
	RSLineBuilder line
		canvas: canvas;
		shapes: boxes;
		color: (Color blue alpha: 0.5);
		connectFrom: [ :nb | nb // 2 ].
	canvas addAll: boxes.! !

!RSForceLayoutSteppingInteraction commentStamp: ''!
Hi!!, I can control the RSForceBaseLayout step method, in order to use it only when it needs!
!RSForceLayoutSteppingInteraction methodsFor: 'animation' stamp: ''!
startFirstAnimation: aCanvas
	| alpha |
	animation ifNotNil: #stop.
	alpha := 1.
	animation := aCanvas newAnimation
		repeat;
		onStepDo: [ :t | layout alpha: alpha; step.
			alpha := alpha * 0.99.
			alpha < 0.005 ifTrue: [ animation stop ] ];
		yourself! !

!RSForceLayoutSteppingInteraction methodsFor: 'accessing' stamp: ''!
layout
	^ layout ifNil: [ layout := RSForceBasedLayout new ]! !

!RSForceLayoutSteppingInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self draggable.! !

!RSForceLayoutSteppingInteraction methodsFor: 'accessing' stamp: ''!
layout: aRSForceBasedLayout
	layout := aRSForceBasedLayout! !

!RSForceLayoutSteppingInteraction methodsFor: 'animation' stamp: ''!
startForceAnimation: aCanvas
	animation ifNotNil: #stop.
	animation := aCanvas animationFrom: {
		"Start smoothly"
		aCanvas transitionAnimation
			easing: RSEasingInterpolator cubicOut;
			duration: 500 milliSeconds;
			range: self alphaRange;
			onStepDo: [ :t | layout alpha: t; step ].

		"Continue on max alpha undefinitely"
		aCanvas transitionAnimation
			repeat;
			onStepDo: [ :t | layout step ] }.
! !

!RSForceLayoutSteppingInteraction methodsFor: 'configuration' stamp: ''!
draggable
	hasDraggable := true! !

!RSForceLayoutSteppingInteraction methodsFor: 'testing' stamp: ''!
hasDraggable
	^ hasDraggable! !

!RSForceLayoutSteppingInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	self configureLayoutOn: aCanvas.
	aCanvas nodes do: [ :s | self addEventsTo: s ].
	self startFirstAnimation: aCanvas.
	aCanvas newAnimation onStepDo: [:t| aCanvas zoomToFit ].! !

!RSForceLayoutSteppingInteraction methodsFor: 'accessing' stamp: ''!
alphaRange
	^ #(0 0.1)! !

!RSForceLayoutSteppingInteraction methodsFor: 'animation' stamp: ''!
startSimpleAnimation: aCanvas
	animation ifNotNil: #stop.
	animation := aCanvas newAnimation 
		easing: RSEasingInterpolator cubicInOut;
		range: self alphaRange reversed;
		duration: 2 seconds;
		onStepDo: [ :t | layout alpha: t; step  ];
		yourself! !

!RSForceLayoutSteppingInteraction methodsFor: 'hooks' stamp: ''!
configureLayoutOn: aCanvas
	self hasDraggable ifTrue: [
		aCanvas nodes @ (RSDraggableForceInteraction new layout: self layout)].
	self layout
		nodes: aCanvas nodes;
		edges: aCanvas edges;
		start.! !

!RSForceLayoutSteppingInteraction methodsFor: 'hooks' stamp: ''!
addEventsTo: shape
	| mock |
	shape 
		when: RSMouseDragStart do: [ :evt | 
			mock := layout mockElementAt: evt shape.
			mock isFixed: true.
			self startForceAnimation: evt canvas ];
		when: RSMouseDragging do: [ :evt |
			mock fixPosition: evt shape position ];
		when: RSMouseDragEnd do:[:evt | 
			mock isFixed: false.
			mock := nil.
			self startSimpleAnimation: evt canvas ].! !

!RSForceLayoutSteppingInteraction methodsFor: 'configuration' stamp: ''!
noDraggable
	hasDraggable := false.! !

!RSGhostDraggable commentStamp: ''!
This interaction creates a new box(a ghost box) and it moves the box instead of the entire shape!
!RSGhostDraggable methodsFor: 'accessing' stamp: ''!
color: anObject

	color := anObject! !

!RSGhostDraggable methodsFor: 'hooks' stamp: ''!
createGhost: evt
	| shape |
	shape := evt shape.
	ghost := shape copy
		fromRectangle: shape encompassingRectangle;
		border: (RSBorder new joinMiter; color: self color; dashArray: #(7 5));
		connectedLines: nil;
		resetChildren;
		noPaint;
		yourself.
		
	shape parent add: ghost.

	! !

!RSGhostDraggable methodsFor: 'hooks' stamp: ''!
removeGhost: evt
	ghost remove.
	evt shape translateTo: ghost position.
	ghost := nil.
	evt signalUpdate.! !

!RSGhostDraggable methodsFor: 'hooks' stamp: ''!
updateGhost: evt
	| d |
	d := evt camera distanceFromPixelToSpace: evt step.
	ghost translateBy: d.
	evt signalUpdate ! !

!RSGhostDraggable methodsFor: 'accessing' stamp: ''!
ghost
	^ ghost! !

!RSGhostDraggable methodsFor: 'hooks' stamp: ''!
onShape: aShape
	aShape
		when: RSMouseDragStart send: #createGhost: to: self;
		when: RSMouseDragging send: #updateGhost: to: self;
		when: RSMouseDragEnd send: #removeGhost: to: self.! !

!RSGhostDraggable methodsFor: 'accessing' stamp: ''!
color
	^ color ifNil: [ color := Color gray ].! !

!RSGhostDraggableTest commentStamp: ''!
A RSGhostDraggableTest is a test class for testing the behavior of RSGhostDraggable!
!RSGhostDraggableTest methodsFor: 'tests' stamp: ''!
testComposite
	| shape interaction c |
	c := RSCanvas new.
	
	shape := RSComposite new
		children: (RSBox 
			models: Collection withAllSubclasses 
			forEach: [ :s :cls| 
				s size: 10.
			 ]);
		adjustToChildren;
		yourself.
	c add: shape.
	interaction := RSGhostDraggable new.
	
	shape @ interaction.
	shape announce: RSMouseDragStart new.
	self assert: interaction ghost notNil.
	self assert: interaction ghost class equals: RSComposite.
	self assert: interaction ghost privateShapes isNil.
	shape announce: RSMouseDragEnd new.
	self assert: interaction ghost isNil.
		
! !

!RSGhostDraggableTest methodsFor: 'tests' stamp: ''!
testBasic
	| shape interaction c |
	c := RSCanvas new.
	
	shape := RSShapeFactory star
		size: 10;
		yourself.
	c add: shape.
	interaction := RSGhostDraggable new.
	
	shape @ interaction.
	self assert: interaction ghost isNil.
	shape announce: RSMouseDragStart new.
	self assert: interaction ghost notNil.
	self assert: interaction ghost class equals: RSPolygon.
	shape announce: RSMouseDragEnd new.
	self assert: interaction ghost isNil.
		
! !

!RSGradientPalette commentStamp: ''!
I have instances of linear gradient paints
I use the colors from this website https://webgradients.com/!
!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
malibuBeach
	^ LinearGradientPaint fromArray:
		{0->'4facfe'. 
		1->'00f2fe' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
morpheusDen
	^ LinearGradientPaint fromArray:
		{0->'30cfd0'. 
		1->'330867' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
cloudyKnoxville
	^ LinearGradientPaint fromArray:
		{0->'fdfbfb'. 
		1->'ebedee' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
deepBlue
	^ LinearGradientPaint fromArray:
		{0->'e0c3fc'. 
		1->'8ec5fc' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
nightFade
	^ LinearGradientPaint fromArray:
		{0->'a18cd1'. 
		1->'fbc2eb' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
dustyGrass
	^ LinearGradientPaint fromArray:
		{0->'d4fc79'. 
		1->'96e6a1' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
temptingAzure
	^ LinearGradientPaint fromArray:
		{0->'84fab0'. 
		1->'8fd3f4' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
trueSunset
	^ LinearGradientPaint fromArray:
		{0->'fa709a'. 
		1->'fee140' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
fabledSunset
	^ LinearGradientPaint fromArray:
		{0->'231557'. 
		0.29->'44107A'.
		0.67->'FF1361'.
		1->'FFF800' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
warmFlame
	^ LinearGradientPaint fromArray:
		{0-> 'ff9a9e'. 
		1->'fad0c4' }.
	! !

!RSGradientPalette class methodsFor: 'palette' stamp: ''!
gradient21
	^ NSScale ordinal range:( 
		#('warmFlame' 
			'nightFade' 
			'youngPassion' 
			'sunnyMorning' 
			'rainyAshville'
			'winterNeva'
			'dustyGrass'
			'temptingAzure'
			'heavyRain'
			'deepBlue'
			'cloudyKnoxville'
			'malibuBeach'
			'trueSunset'
			'morpheusDen'
			'nearMoon'
			'happyFisher'
			'sweetPeriod'
			'burningSpring'
			'redSalvation'
			'northMiracle'
			'fabledSunset') collect: [ :selector | self perform: selector asSymbol ] );
		yourself! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
winterNeva
	^ LinearGradientPaint fromArray:
		{0->'a1c4fd'. 
		1->'c2e9fb' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
heavyRain
	^ LinearGradientPaint fromArray:
		{0->'cfd9df'. 
		1->'e2ebf0' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
burningSpring
	^ LinearGradientPaint fromArray:
		{0->'4fb576'. 
		0.30->'44c489'.
		0.46->'28a9ae'.
		0.59->'28a2b7'.
		0.71->'4c7788'.
		0.86->'6c4f63'.
		1->'432c39' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
redSalvation
	^ LinearGradientPaint fromArray:
		{0->'f43b47'. 
		1->'453a94' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
sunnyMorning
	^ LinearGradientPaint fromArray:
		{0->'f6d365'. 
		1->'fda085' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
sweetPeriod
	^ LinearGradientPaint fromArray:
		{0->'3f51b1'. 
		0.13->'5a55ae'.
		0.25->'7b5fac'.
		0.38->'8f6aae'.
		0.50->'a86aa4'.
		0.62->'cc6b8e'.
		0.75->'f18271'.
		0.87->'f3a469'.
		1->'f7c978' }! !

!RSGradientPalette class methodsFor: 'view' stamp: ''!
roassalCanvas
	<example>
	| canvas gradients |
	canvas := RSCanvas new.
	gradients := self class methods select: [ :met | met category = #gradients ].
	canvas addAll: (gradients collect: [ :met |
		| paint |
		paint := met selector value: self.
		paint start: 0@ -15; stop: 0@15.
		RSEllipse new 
			model: met selector;
			popup;
			paint: paint;
			radius: 30.
		]).
	RSGridLayout on: canvas nodes.
	canvas @ RSCanvasController.
	canvas open.! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
nearMoon
	^ LinearGradientPaint fromArray:
		{0->'5ee7df'. 
		1->'b490ca' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
rainyAshville
	^ LinearGradientPaint fromArray:
		{0->'fbc2eb'. 
		1->'a6c1ee' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
youngPassion
	^ LinearGradientPaint fromArray:
		{(0 -> 'ff867a').
		(0.21 -> 'ff8c7f').
		(0.52 -> 'f99185').
		(0.78 -> 'cf556c').
		(1 -> 'b12a5b')}! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
northMiracle
	^ LinearGradientPaint fromArray:
		{0->'00dbde'. 
		1->'fc00ff' }! !

!RSGradientPalette class methodsFor: 'gradients' stamp: ''!
happyFisher
	^ LinearGradientPaint fromArray:
		{0->'89f7fe'. 
		1->'66a6ff' }! !

!RSGraphCanvasMonitorInteraction commentStamp: ''!
I have a canvas monitor!
!RSGraphCanvasMonitorInteraction methodsFor: 'update' stamp: ''!
updateShape
	| cp |
	frames add: self lastFramePerSecond.
	
	frames size > shape shapes first extent x
		ifTrue: [ frames removeFirst ].
	self label text: frames last asString, 'fps'.
	frames first = 1000 ifTrue: [ frames removeFirst ].
	cp := frames collectWithIndex: [ :frame :i |
		polyScale scale: i @ frame ].
	self polyline controlPoints: cp.
	cp := cp copy.
	cp 
		add: (polyScale scale: cp size @ 0);
		add: (polyScale scale: 1@0).
	self polygon points: cp! !

!RSGraphCanvasMonitorInteraction methodsFor: 'accessing' stamp: ''!
polyline
	^ polyline ifNil: [ polyline := self defaultPolyline ]! !

!RSGraphCanvasMonitorInteraction methodsFor: 'initialization' stamp: ''!
initialize
	polyScale := NSScale linear
		domain: { 1@0. 100@65 };
		range: { -50 @ 25. 50@ -25 }.
	frames := OrderedCollection new.
	super initialize.
	
	! !

!RSGraphCanvasMonitorInteraction methodsFor: 'initialization' stamp: ''!
initializeShape
	shape := RSShapeFactory composite
		noPaint;
		shapes: { self box. self polygon. self  polyline. self label};
		padding: 5;
		yourself! !

!RSGraphCanvasMonitorInteraction methodsFor: 'defaults' stamp: ''!
defaultPolyline
	^ RSPolyline new
		controlPoints: #();
		border: (RSBorder new
			paint: ((LinearGradientPaint fromArray:
					{0  -> 'red'.
					0.5 -> 'orange'.
					1   -> 'gree'})
				start: 0@25;
				stop: 0@ -20;
				yourself))! !

!RSGraphCanvasMonitorInteraction methodsFor: 'accessing' stamp: ''!
box
	^ RSBox new
		extent: 100@ 50;
		color: Color lightGray translucent;
		cornerRadius: 5;
		yourself.! !

!RSGraphCanvasMonitorInteraction methodsFor: 'defaults' stamp: ''!
defaultPolygon
	^ RSPolygon new
		paint: ((LinearGradientPaint fromArray:
				{0  -> Color red translucent.
				0.5 -> Color orange translucent.
				1   -> Color green translucent. } )
			start: 0@25;
			stop: 0@ -20;
			yourself);
		cornerRadii: 5;
		yourself! !

!RSGraphCanvasMonitorInteraction methodsFor: 'accessing' stamp: ''!
label
	^ label ifNil: [ label := self defaultLabel ]! !

!RSGraphCanvasMonitorInteraction methodsFor: 'accessing' stamp: ''!
polygon
	^ polygon ifNil: [ polygon := self defaultPolygon ]! !

!RSGraphCanvasMonitorInteraction methodsFor: 'defaults' stamp: ''!
defaultLabel
	^ RSLabel new
		bold;
		text: '';
		position: 25 @ 15;
		color: Color blue;
		yourself! !

!RSGridLayout commentStamp: ''!
RSGridLayout places shapes as a grid. Shapes keeps their order, from left to right.

Here is an example

```
c := RSCanvas new.

shapes := RSLabel models: (1 to: 9).
c addAll: shapes.
RSGridLayout on: shapes.
c @ RSCanvasController
```!
!RSGridLayout methodsFor: 'hook' stamp: ''!
doExecute: shapes
	| pointer lineItemCount lineItemSize maxLastLineHeight originalGapLeft originalGapTop |
	originalGapLeft := 0.
	originalGapTop := 0.
	
	pointer := originalGapLeft @ originalGapTop.
	lineItemSize := self lineItemsCountBlock rsValue: shapes.
	lineItemCount := 0.
	maxLastLineHeight := 0.

	shapes
		do: [ :element | 
			translator translateTopLeftOf: element to: pointer.
			pointer := (pointer x + element width + self gapSize) @ pointer y.
			lineItemCount := lineItemCount + 1.
			maxLastLineHeight := maxLastLineHeight max: element height.
			lineItemCount >= lineItemSize
				ifTrue: [ 
					pointer := originalGapLeft @ (pointer y + (self gapSize) + maxLastLineHeight).
					
					maxLastLineHeight := 0.
					lineItemCount := 0 ].
			self step ].
! !

!RSGridLayoutTest methodsFor: 'tests' stamp: ''!
testBasic

	RSGridLayout on: canvas nodes.
	self assert: (shapes collect: #position) asArray equals: {(2.5@2.5). (12.5@2.5). (22.5@2.5). (32.5@2.5). (2.5@12.5). (12.5@12.5). (22.5@12.5). (32.5@12.5). (2.5@22.5). (12.5@22.5)}! !

!RSGroup commentStamp: ''!
<keyClass>
A `RSGroup` represents a collection of Roassal shapes. As soon as one assume a collection contains graphical elements, then it is convenient to be able to perform some operations (e.g., getting the encompassing rectangle of the elements, transforming a collection into a composite shape). `RSGroup` is a subclass of `OrderedCollection`. A `RSGroup` is not designed to contain other things than Roassal shapes. 

*Responsibility*: handle a collection of graphical shapes in an intuitive and efficient way. A group is also responsible to retrieve shapes from a given model object.

*Collaborators*: `RSGroup` is a central class in Roassal. Shapes are held in instance of `RSGroup`.

*Variables*:
- `shapeFromModelCache`: a group of shapes must remember the model to speed up the retreival of shapes from a given object model.


*Example*:
```Smalltalk
shapes := (1 to: 20) collect: [ :value | 
	| g |
	g := RSGroup new.
	g add: (RSEllipse new size: 30 atRandom).
	g add: (RSLabel new text: value).
	g asShape ].

c := RSCanvas new.
c addAll: shapes.
RSFlowLayout on: shapes.
c @ RSCanvasController.
```

Layout may be applied on a group
```Smalltalk
shapes := (1 to: 20) collect: [ :value | 
	| g |
	g := RSGroup new.
	g add: (RSLabel new text: value).
	g add: (RSEllipse new size: 30 atRandom).
	RSVerticalLineLayout new center; gapSize: 0; on: g.
	g asShape ].

c := RSCanvas new.
c addAll: shapes.
RSFlowLayout on: shapes.
c @ RSCanvasController.
```

```Smalltalk
g := RSGroup new.
g add: (RSBox new model: 'hello').
g add: (RSEllipse new model: 'world').
g shapeFromModel: 'hello' "=> a RSBox(hello))"
```
!
!RSGroup methodsFor: 'public - forwarding' stamp: ''!
color: aColor
	"Give the same color to all the shapes"
	self do: [ :s | s color: aColor ]! !

!RSGroup methodsFor: 'transforming' stamp: ''!
position
	^ self encompassingRectangle center! !

!RSGroup methodsFor: 'accessing' stamp: ''!
shapeFromModel: anObject
	"Return a shape that corresponds to the object provided as parameter. If none is found, then return nil
	
```Smalltalk
g := RSGroup new.
g add: (RSBox new model: 'hello').
g add: (RSEllipse new model: 'world').
g shapeFromModel: 'hello'
```
=> a RSBox(hello))

	"
	| t |
	self shapeFromModelCache 
		at: anObject 
		ifPresent: [ :v |
			v isCollection ifFalse: [ ^ v ] ].

	"We have this line because of a bug of the implementation of CompiledMethod>>#="
	t := (anObject class == CompiledMethod) 
		ifTrue: [ self detect: [ :el | el model == anObject ] ifNone: [ nil ] ]
		ifFalse: [ self detect: [ :el | el model = anObject ] ifNone: [ nil ] ].
	
	self shapeFromModelCache at: anObject put: t.
	^ t! !

!RSGroup methodsFor: 'accessing' stamp: ''!
add: shape
	self resetShapeFromModelCache.
	^ super add: shape! !

!RSGroup methodsFor: '*Roassal3-Interaction' stamp: ''!
addInteraction: interaction
	self do: [ :e | e addInteraction: interaction ].! !

!RSGroup methodsFor: 'accessing' stamp: ''!
shapeFromModelCache
	"Define a cache for the element lookup from models"
	shapeFromModelCache ifNil: [ shapeFromModelCache := Dictionary new ].
	^ shapeFromModelCache! !

!RSGroup methodsFor: 'accessing' stamp: ''!
shapesFromModel: anObject
	"Return a shape that corresponds to the object provided as parameter. If none is found, then return nil.

For example:
-=-=-=-=-=-=-=-=-=
g := RSGroup new.
g add: (RSBox new model: 'hello').
g add: (RSEllipse new model: 'world').
g shapesFromModel: 'hello' 
-=-=-=-=-=-=-=-=-=
=> a RSGroup(a RSBox(hello))
	"	

	| t key |
	self shapeFromModelCache at: anObject ifPresent: [ :v | v isCollection ifTrue: [ ^ v ] ].

	"We have this line because of a bug of the implementation of CompiledMethod>>#="
	t := (anObject class == CompiledMethod) 
				ifTrue: [ self select: [ :el | el model == anObject ] ]
				ifFalse: [ self select: [ :el | el model = anObject ] ].

	"We have this hack for nil objects because in visualWorks a dictionary cannot have nil as a key"
	key := anObject isNil ifTrue: [ 'KeyForNilObjects' ] ifFalse: [ anObject ].
	self shapeFromModelCache at: key put: t.
	^ t! !

!RSGroup methodsFor: 'transforming' stamp: ''!
translateBy: delta
	self do: [ :e | e translateBy: delta ]! !

!RSGroup methodsFor: '*Roassal3-Inspector' stamp: ''!
gtInspectorViewIn: composite
	<gtInspectorPresentationOrder: 0>
	
	composite roassal3
		title: ['Canvas'];
		initializeCanvas: [ | canvas |
			canvas := RSCanvas new
				addShape: (RSComposite new
					shapes: self;
					yourself).
			canvas when: RSExtentChangedEvent do: [ canvas zoomToFit ].
			canvas ]
		! !

!RSGroup methodsFor: 'public - forwarding' stamp: ''!
withBorder
	"Makes all the shapes having a border
```
c := RSCanvas new.
circles := RSCircle models: (1 to: 20).
circles size: 20.
circles withBorder.
c addAll: circles.
RSGridLayout on: circles.
c 
```
	"
	self do: #withBorder! !

!RSGroup methodsFor: 'accessing' stamp: ''!
shapesFromModels: objects
	"Return elements that corresponds to the objects provided as parameter. If none is found, then return an empty collection"
	| answer t |
	self assert: [ objects isCollection ] description: 'Provide a set of shapes instead of one single shape'. 
	answer := RSGroup new.
	objects do: [ :o |
		t := self shapesFromModel: o.
		t notNil ifTrue: [ answer addAll: t ] ].
	^ answer! !

!RSGroup methodsFor: 'converting' stamp: ''!
asGroup
	^ self! !

!RSGroup methodsFor: '*Roassal3-Interaction' stamp: ''!
@ interaction
	"Apply an interaction on each shape contained in the group.
	
For example:
```Smalltalk
g := RSGroup new.
g add: (RSBox new size: 10; model: 'hello').
g add: (RSBox new size: 10; model: 'World').
RSHorizontalLineLayout on: g.
g @ RSPopup.
c := RSCanvas new.
c addAll: g.
c
```
"
	self do: [ :e | e @ interaction ].! !

!RSGroup methodsFor: 'public - forwarding' stamp: ''!
pushFront
	self do: #pushFront! !

!RSGroup methodsFor: 'accessing' stamp: ''!
models: someModels
	"Set the model of each shapes contained in the collection. The size of the group must be the same than the someModels collection"
	self assert: [ someModels isCollection ] description: 'Must provide a collection'.
	self assert: [ self size = someModels size ] description: 'The argument must of the same size then the group'.
	self with: someModels do: [ :s :m | s model: m ]! !

!RSGroup methodsFor: 'public - forwarding' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject
	self do: [ :shape | shape when: anAnnouncementClass send: aSelector to: anObject]! !

!RSGroup methodsFor: 'accessing' stamp: ''!
width 
	"Return the width of the encompassing rectangle of the group"
	^ self extent x! !

!RSGroup methodsFor: 'accessing' stamp: ''!
nodes
	"Return the nodes (i.e., shapes that are not lines) contained in a group"
	^ self select: #isNode! !

!RSGroup methodsFor: 'public - forwarding' stamp: ''!
translucent
	"Make all shapes in the group as translucent"
	self do: [ :s | s color: s color translucent ]! !

!RSGroup methodsFor: 'accessing' stamp: ''!
extent
	^ self encompassingRectangle extent! !

!RSGroup methodsFor: 'public - forwarding' stamp: ''!
size: aNumber
	"Convenient method. For example:
```
c := RSCanvas new.
shapes := RSCircle models: (1 to: 9).
shapes size: 30.
c addAll: shapes.
RSGridLayout on: shapes.
c @ RSCanvasController
```"
	self do: [ :s | s size: aNumber ]
	! !

!RSGroup methodsFor: 'public - forwarding' stamp: ''!
when: event do: aOneArgBlock
	"Define a callback for each of the shape contained in the group. For example:
```
c := RSCanvas new.
shapes := RSCircle models: (1 to: 9).
shapes size: 30.
c addAll: shapes.
RSGridLayout on: shapes.
shapes when: RSMouseClick do: [ :evt | evt shape @ RSBlink ].
c @ RSCanvasController
```"
	self do: [ :shape | shape when: event do: aOneArgBlock ]! !

!RSGroup methodsFor: '*Roassal3-Shapes' stamp: ''!
asShapeFor: model
	"Convert a RSGroup into a shape, and tis shape has a model. Pretty convenient to create a group of shapes as a composite.
Consider the following example:

```
c := RSCanvas new.

classes := Collection withAllSubclasses.
elements := classes collect: [ :cls |
	g := RSGroup new
		add: (RSLabel new text: cls name);
		add: (RSEllipse new size: (cls numberOfMethods + 5) sqrt; color: Color blue );
		yourself.
	RSVerticalLineLayout new alignCenter; on: g.
	g asShapeFor: cls ] as: RSGroup.

c addAll: elements.
elements @ RSHighlightable red.
RSGridLayout on: elements.
c @ RSCanvasController
```
"
	^ RSComposite new 
		model: model;
		shapes: self;
		yourself! !

!RSGroup methodsFor: 'accessing' stamp: ''!
height 
	^ self extent y! !

!RSGroup methodsFor: 'transforming' stamp: ''!
translateTo: aPosition
	| center |
	center := self encompassingRectangle floatCenter.
	self translateBy: aPosition - center! !

!RSGroup methodsFor: 'accessing' stamp: ''!
encompassingRectangle
	^ self
		ifEmpty: [ (0 @ 0) corner: (0 @ 0) ]
		ifNotEmpty: [ Rectangle merging: (self collect: #encompassingRectangle) ]! !

!RSGroup methodsFor: 'transforming' stamp: ''!
translateTopLeftTo: aPosition
	| center |
	center := self encompassingRectangle topLeft.
	self translateBy: aPosition - center! !

!RSGroup methodsFor: 'accessing' stamp: ''!
addAll: shapes
	self resetShapeFromModelCache.
	^ super addAll: shapes! !

!RSGroup methodsFor: '*Roassal3-Shapes' stamp: ''!
asShape
	"Convert a RSGroup into a shape. Pretty convenient to create a group of shapes as a composite.
Consider the following example:

-=-=-=-=-=-=-=-=-=-=-=-=
c := RSCanvas new.

classes := Collection withAllSubclasses.
elements := classes collect: [ :cls |
	g := RSGroup new
		add: (RSLabel new text: cls name);
		add: (RSEllipse new size: (cls numberOfMethods + 5) sqrt; color: Color blue );
		yourself.
	RSVerticalLineLayout new center; on: g.
	g asShape ] as: RSGroup.

c addAll: elements.
elements @ RSHighlightable defaultRed.
RSGridLayout on: elements.
c @ RSCanvasController
-=-=-=-=-=-=-=-=-=-=-=-=

"
	^ self asShapeFor: nil! !

!RSGroup methodsFor: 'public - forwarding' stamp: ''!
pushBack 
	"Push back all the shapes contained in the group"
	self do: [ :each | each pushBack ]! !

!RSGroup methodsFor: 'accessing' stamp: ''!
resetShapeFromModelCache
	"Reset the cache"
	shapeFromModelCache := nil! !

!RSGroup methodsFor: 'accessing' stamp: ''!
lines
	"Return the nodes (i.e., shapes that are not lines) contained in a group"
	^ self select: #isLine! !

!RSGroup methodsFor: 'visiting' stamp: ''!
accept: aVisitor
	aVisitor visitGroup: self! !

!RSGroupTest commentStamp: ''!
A TSGroupTest is a test class for testing the behavior of TSGroup!
!RSGroupTest methodsFor: 'tests' stamp: ''!
testCache04

	| es |
	es := #(1) collect: [:n | RSBox new model: n; yourself] as: RSGroup.
	self assert: (es shapesFromModel: 1) size equals: 1.
	
	es addAll: (#(1) collect: [:n | RSBox new model: n; yourself] as: RSGroup). 
	self assert: (es shapesFromModel: 1) size equals: 2.! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testCache02

	| shapes s sps |
	shapes := #(1 1) collect: [:n | RSBox new model: n; yourself] as: RSGroup.
	
	s := shapes shapeFromModel: 1.
	self assert: s class equals: RSBox.
	self assert: s model equals: 1.
	
	sps := shapes shapesFromModel: 1.
	self assert: sps class equals: RSGroup.
	self assert: sps size equals: 2! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testModels
	| g |
	g := RSGroup new.
	g add: RSBox new.
	g add: RSBox new.
	g add: RSBox new.

	self assert: (g allSatisfy: [ :s | s model isNil ]).
	g models: #('hello' 'world' 'bonjour').
	
	self assert: (g collect: [ :s | s model ]) asArray equals: #('hello' 'world' 'bonjour')
	 ! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testTranslateTopLeftTo 
	| g |
	g := RSBox models: #(1 2).
	RSHorizontalLineLayout on: g.
	self assert: (g collect: #position as: Array) equals: {(5.0@5.0). (25.0@5.0)}.
	self assert: g position equals: 15 @ 5.
	
	g translateTopLeftTo: 40 @ 42.
	self assert: (g collect: #position as: Array) equals: {(45.0@47.0). (65.0@47.0)}.
	self assert: g position equals: 55 @ 47.! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testCache01

	| shapes shape |
	shapes := (1 to: 5) collect: [:n | RSBox new model: n; yourself ] as: RSGroup.
	self assert: shapes class equals: RSGroup.
	self assert: shapes shapeFromModelCache isEmpty.
	
	shape := shapes shapeFromModel: 2.
	self assert: shape class equals: RSBox.
	self assert: shape model equals: 2.
	
	self deny: shapes shapeFromModelCache isEmpty.! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testShapeFromModel
	| group |
	group := (1 to: 5) collect: [:n | RSBox new model: n; yourself] as: RSGroup.
	self assert: (group shapeFromModel: 1) equals: group first.
	self assert: (group shapeFromModel: 5) equals: group last.
! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testTranslucent
	| g |
	g := RSGroup new.
	g add: RSBox new.
	g add: RSBox new.
	g add: RSBox new.

	self assert: (g allSatisfy: [ :s | s color alpha = 1 ]).
	g translucent.
	self assert: (g allSatisfy: [ :s | s color alpha < 1 ]).
	 ! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testAddShape
	| g |
	g := RSGroup new.
	g add: RSBox new.! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testAsGroup
	| t |
	t := #(1 2 3) asGroup.
	self assert: t asArray equals: #(1 2 3).
	self assert: t class equals: RSGroup! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testNodesAndLines

	| g |
	g := RSGroup new.
	g addAll: (RSCircle models: (1 to: 10)).
	g addAll: (RSLine models: (1 to: 5)). 
	
	self assert: g nodes size equals: 10.
	self assert: g lines size equals: 5.! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testCache03

	| shapes shape |
	shapes := #(1 1) collect: [:n | RSBox new model: n; yourself] as: RSGroup.
	
	shapes shapesFromModel: 1.
	shape := shapes shapeFromModel: 1.
	self assert: shape class equals: RSBox.
	self assert: shape model equals: 1.
	! !

!RSGroupTest methodsFor: 'tests' stamp: ''!
testDrawGroup
	| g c com |
	c := RSCanvas new.
	g := RSGroup new.
	g add: RSBox new.
	com := RSComposite new
		shapes: g.
	c addShape: com.
	self assert: c numberOfShapes equals: 1.
	c createMorph drawOnMockCanvas.! !

!RSHierarchyPackerInteraction commentStamp: ''!
This interaction layouts the connected subgraphs of a view using a rectangle pack layout each time the view changes it's extent (e.g. a window resize).

Adapt the layout based on the window size:
-=-=-=-=-=-=-=-=-=
numberOfBoxes := 50.
r := Random seed: 42.
shapes := RSGroup new.
numberOfBoxes timesRepeat: [ 
    shapes add: (RSBox new width: (r nextInt: 40); height: (r nextInt: 40)) ].

c := RSCanvas new. 
c addAll: shapes.
RSRectanglePackLayout new useProgressBar; on: shapes.
c @ RSCanvasController @ RSHierarchyPacker.
c open
-=-=-=-=-=-=-=-=-=

Another example:
-=-=-=-=-=-=-=-=-=
"Try resizing the window. Note that it also works in the inspector"
classes := { 'Roassal3-Layouts'. 'Roassal3' }
	flatCollect: [:pkgname | (RPackage organizer
		packageNamed: pkgname) definedClasses ].
shapes := RSGroup new.
classes do: [ :c | shapes add: (RSEllipse new model: c) ].

c := RSCanvas new.
c addAll: shapes.

eb := RSEdgeBuilder orthoVertical.
eb canvas: c.
eb connectFrom: #superclass.

RSNormalizer size
	shapes: shapes;
	normalize: [ :c | c numberOfMethods + 5 ].
RSTreeLayout on: shapes.
c @ RSCanvasController @ RSHierarchyPacker.
c open
-=-=-=-=-=-=-=-=-=

Another example:
-=-=-=-=-=-=-=-=-=
builder := RSUMLClassBuilder new.
classes := { 'Roassal3-Layouts'. 'Roassal3' }
	flatCollect: [:pkgname | (RPackage organizer
		packageNamed: pkgname) definedClasses ].
builder classes: classes.
builder renderer: RSTorchUMLClassRenderer new.
builder build.
builder canvas @ RSHierarchyPacker.
builder canvas open
-=-=-=-=-=-=-=-=-=!
!RSHierarchyPackerInteraction methodsFor: 'private' stamp: ''!
initialize
	super initialize.
	
	rectanglePackLayout := RSRectanglePackLayout new
		doNotUseProgressBar;
		yourself.! !

!RSHierarchyPackerInteraction methodsFor: 'private' stamp: ''!
onShape: aCanvas
	| layout connectedAsGroups connected isolated all |
	layout := RSTreeLayout new
		edges: aCanvas edges.
	connectedAsGroups := aCanvas nodes.
	connected := connectedAsGroups select: #hasEdges.
	isolated := connectedAsGroups reject: #hasEdges.

	connectedAsGroups := (layout rootNodesFor: connected) collect: [ :e | 
		| group |
		group :=  RSGroup new.
		self fill: group with: e.
		group ]. 
	
	all := connectedAsGroups, isolated.

	aCanvas when: RSExtentChangedEvent do: [
		rectanglePackLayout
			preferredAngle: aCanvas extent angle;
			on: all.
		aCanvas zoomToFit; signalUpdate ].
! !

!RSHierarchyPackerInteraction methodsFor: 'private' stamp: ''!
fill: group with: aShape
	group add: aShape.
	aShape outgoingLines do: [ :ed | 
		self fill: group with: ed to ].! !

!RSHierarchyPackerInteraction methodsFor: 'accessing' stamp: ''!
rectanglePackLayout: anObject
	rectanglePackLayout := anObject! !

!RSHierarchyPackerInteraction methodsFor: 'accessing' stamp: ''!
rectanglePackLayout
	^ rectanglePackLayout! !

!RSHighlightEvent commentStamp: ''!
I am a basic event when RSHightlightable needs to highlight an element!
!RSHighlightable commentStamp: ''!
<keyClass>
`RSHighlightable` is an interaction for shapes to make them highlightable. 

*Responsibility*: make shapes highlightable

*Collaborators*: closely colaborate with `RSShape`

*Variables*:
- `announcer`: highlightable uses announcement to trigger the interaction. 
- `copyKey`: symbol that is used to keep in the property the previous color. One needs to modity the `copyKey` to avoid conflict between several highlightable interactions.
- `highlightShapes`: refers to a one-arg-block that takes as parameter a shape and returns the shapes that must be highlighted. 
- `propertyKey`: symbol that is used in the property of the `RSCanvas` to keep highlighted shapes. This is useful to avoid conflicts between different highlightable.
   

*Example*:
```Smalltalk
c := RSCanvas new.

shapes := (1 to: 10) collect: [ :v | RSEllipse new size: 20; model: v ] as: RSGroup.
c addAll: shapes.
shapes @ RSPopup @ RSDraggable.

RSGridLayout on: shapes.

eb := RSEdgeBuilder arrowedLineWithOffset: 0.5.
eb canvas: c.
eb connectTo: [ :v | 1 ].

int := RSHighlightable new withEdges highlightColor: Color red.
shapes @ int.

c @ RSCanvasController
```

Another example:
```Smalltalk
c := RSCanvas new.
shapes := (1 to: 30) collect: [ :v | RSBox new border: (RSBorder new color: Color red; width: 3); model: v ] as: RSGroup.
c addAll: shapes.
shapes @ RSPopup.

RSNormalizer size
	shapes: shapes;
	normalize: #yourself.

interaction := RSHighlightable new.
interaction highlightColor: Color blue.
interaction highlightBorder: (RSBorder new color: Color black; width: 3).
shapes @ interaction.

RSGridLayout on: shapes.
c @ RSCanvasController
```

Another example:
```Smalltalk
c := RSCanvas new.
shapes := (1 to: 30) collect: [ :v | RSEllipse new  model: v; size: 10 ] as: RSGroup.
c addAll: shapes.
shapes @ RSPopup.

RSEdgeBuilder line
	canvas: c;
	withBorderAttachPoint;
	connectFrom: [ :v | v // 2 ].

interaction := RSHighlightable new.
interaction highlightBorder: (RSBorder new color: Color black; width: 3).
interaction withEdges.
shapes @ interaction.

RSTreeLayout on: shapes.
c @ RSCanvasController
```

```Smalltalk
c := RSCanvas new.
shapes := (1 to: 30) collect: [ :v | RSBox new  size: 20; model: v ] as: RSGroup.
c addAll: shapes.
shapes @ RSPopup.

interaction := RSHighlightable new.
interaction highlightBorder: (RSBorder new width: 3; color: Color pink).
shapes @ interaction.

RSGridLayout on: shapes.
c @ RSCanvasController
```

Example of multiple selections:
```Smalltalk
classes := Collection withAllSubclasses.

c := RSCanvas new.
shapes := classes collect: [ :cls | RSBox new model: cls ] as: RSGroup.

c addAll: shapes.
RSNormalizer size shapes: shapes; normalize: #numberOfMethods.
RSFlowLayout on: shapes.

shapes @ RSPopup.


buttonReset := RSLabel text: 'Reset'.
c add: buttonReset.
buttonReset setAsFixed.
buttonReset @ (RSHighlightable defaultRed).
buttonReset when: RSMouseClick do: [ :evt | 
	selectedShapes do: [ :s | highlightable restore: s selector: #color ].
	selectedShapes := RSGroup new.
	lbl text: ''.
	c signalUpdate. ].

buttonInspect := RSLabel text: 'Inspect'.
c add: buttonInspect.
buttonInspect setAsFixed.
buttonInspect @ (RSHighlightable defaultRed).
buttonInspect when: RSMouseClick do: [ :evt | selectedShapes inspect ].

lbl := RSLabel new.
c add: lbl.
lbl setAsFixed.
lbl translateTo: 90 @ 30.

g := {buttonReset . buttonInspect } asGroup.
RSHorizontalLineLayout on: g.
g translateTo: g extent / 2 + (10 @ 10).

selectedShapes := RSGroup new.
highlightable := RSHighlightable new.
shapes when: RSMouseClick do: [ :evt |
	(selectedShapes includes: evt shape) 
		ifFalse: [ selectedShapes add: evt shape ].
	highlightable
			record: evt shape
			selector: #color
			value: Color red.
	lbl text: selectedShapes size asString, ' selected shapes'.
	c signalUpdate.
		 ].

c @ RSCanvasController.
c openOnce
```!
!RSHighlightable methodsFor: 'actions' stamp: ''!
resetHighlightedShapes: shapeOrGroupOrCanvas
	| att top |
	(shapeOrGroupOrCanvas class == RSGroup)
		ifTrue: [ 
			shapeOrGroupOrCanvas ifEmpty: [ ^ self ].
			top := shapeOrGroupOrCanvas anyOne canvas ]
		ifFalse: [
			top := shapeOrGroupOrCanvas topParent ]. 
		
	att := top properties.
	(att includesKey: self propertyKey) ifFalse: [ ^ self ].
	att removeKey: self propertyKey! !

!RSHighlightable methodsFor: 'public - hooks' stamp: ''!
withEdges
	self highlightShapes: [ :s | 
		| list |
		list := s connectedLines copy.
		list add: s.
		list ].! !

!RSHighlightable methodsFor: 'testing' stamp: ''!
hasInteraction: anInteractionClass
	"Return true or false if the receiver has an interaction. Note that the argument has to be an interaction class. And not an event"
	self announcer subscriptions ifNil: [ ^ false ].
	^ self announcer subscriptions handleSubscriberClass: anInteractionClass! !

!RSHighlightable methodsFor: 'announcer' stamp: ''!
announceUnHightlight: shape source: shapeOrCanvas
	self announce: [ RSUnHighlightEvent new
		interaction: self;
		shape: shape;
		source: shapeOrCanvas ].! !

!RSHighlightable methodsFor: 'public - hooks' stamp: ''!
withOutgoingLines
	self highlightShapes: [ :s | 
		| list |
		list := s outgoingLines collect: #yourself as: RSGroup.
		list addAll: (s outgoingLines collect: #to). 
		list ].! !

!RSHighlightable methodsFor: 'removing' stamp: ''!
removeInteractionIfPresent: anInteractionClass
	"Remove all the callbacks associated to the interaction."
	(self hasInteraction: anInteractionClass) ifFalse: [ ^ self ].
	(self getInteractionsForClass: anInteractionClass) do: [ :int | self announcer unsubscribe: int ]! !

!RSHighlightable methodsFor: 'public - hooks' stamp: ''!
incomingLines
	self highlightShapes: [ :s | 
		s incomingLines collect: #yourself as: RSGroup ].! !

!RSHighlightable methodsFor: 'announcer' stamp: ''!
announce: anEvent
	| a |
	a := self privateAnnouncer.
	a ifNil: [ ^ self ].
	a announce: anEvent value! !

!RSHighlightable methodsFor: 'public' stamp: ''!
executeWithoutAnnouncer: aBlock
	| ann |
	ann := self privateAnnouncer.
	self announcer: nil.
	aBlock value.
	self announcer: ann.! !

!RSHighlightable methodsFor: 'accessing - keys' stamp: ''!
copyKey: aSymbol
	copyKey := aSymbol! !

!RSHighlightable methodsFor: 'private' stamp: ''!
highlightShapesFor: aShape
	^ highlightShapes rsValue: aShape! !

!RSHighlightable methodsFor: 'actions' stamp: ''!
doHighlightShapes: shapes
	"Assuming all the shapes belongs to the same canvas"
	| allHShapes |
	shapes ifEmpty: [ ^ self ].
	self unhighlightRecordedShapes: shapes first.
	allHShapes := shapes flatCollect: [ :s | | hshapes |
		hshapes := self highlightShapesFor: s.
		hshapes do: [ :hs | self announceHighlight: hs source: s ].
		hshapes ].
	shapes first canvas propertyAt: self propertyKey put: allHShapes.! !

!RSHighlightable methodsFor: 'public - hooks' stamp: ''!
withIncomingLines
	self highlightShapes: [ :s | 
		| list |
		list := s incomingLines collect: #yourself as: RSGroup.
		list add: s.
		list ].! !

!RSHighlightable methodsFor: 'actions' stamp: ''!
unhighlightRecordedShapes: shapeOrGroupOrCanvas
	| top |
	(shapeOrGroupOrCanvas class == RSGroup)
		ifTrue: [ 
			shapeOrGroupOrCanvas ifEmpty: [ ^ self ].
			top := shapeOrGroupOrCanvas anyOne canvas ]
		ifFalse: [
			top := shapeOrGroupOrCanvas topParent ]. 
		
	top ifNil: [ ^ self ].
	top
		propertyAt: self propertyKey 
		ifPresent: [ :shapes |
			shapes do: [ :s | self announceUnHightlight: s source: shapeOrGroupOrCanvas ].
		 ].
	self resetHighlightedShapes: shapeOrGroupOrCanvas! !

!RSHighlightable methodsFor: 'announcer' stamp: ''!
privateAnnouncer
	^ announcer! !

!RSHighlightable methodsFor: 'announcer' stamp: ''!
announceHighlight: shape source: shapeOrCanvas
	self announce: [ RSHighlightEvent new
		interaction: self;
		shape: shape;
		source: shapeOrCanvas ].! !

!RSHighlightable methodsFor: 'public - hooks' stamp: ''!
highlightShapes: aBlock butKeep: aRSHighlightable
	"aBlock receives a shape and returns a collection of shapes"
	self highlightShapes: [ :e | 
		| shapes |
		shapes := aBlock value: e.
		e canvas properties
			at: aRSHighlightable propertyKey
			ifPresent: [ :hshapes | 
				shapes reject: [ :hs | hshapes includes: hs ] ]
			ifAbsent: [ shapes ] ]! !

!RSHighlightable methodsFor: 'public' stamp: ''!
lowColor: lowColor highColor: highColor
	self 
		when: RSHighlightEvent do: [ :evt | evt shape color: highColor  ];
		when: RSUnHighlightEvent do: [ :evt | evt shape color: lowColor ].
	! !

!RSHighlightable methodsFor: 'public - hooks' stamp: ''!
withConnectedShapes
	"Highlight shapes that are connected to the pointed shape. For example:
```
numberOfNodes := 25. 
numberOfLines := 90.
r := Random seed: 42.
graph := Dictionary new.

1 to: numberOfNodes do: [ :aNode |
	graph at: aNode put: Set new ].

numberOfLines timesRepeat: [ 
	fromNode := r nextInteger: numberOfNodes.
	toNode := r nextInteger: numberOfNodes.
	(graph at: fromNode) add: toNode ].

canvas := RSCanvas new.
nodes := RSCircle models: (1 to: numberOfNodes).
nodes @ RSDraggable @ RSPopup. 
canvas addAll: nodes.

highlightable := RSHighlightable new.
highlightable highlightColor: Color red.
highlightable withEdges.
nodes @ highlightable.

highlightable2 := RSHighlightable new.
highlightable2 highlightColor: Color blue.
highlightable2 withConnectedShapes.
nodes @ highlightable2.

lb := RSLineBuilder line.
lb canvas: canvas.
lb withBorderAttachPoint.
lb makeBidirectional.
lb moveBehind.
lb objects: (1 to: numberOfNodes).
lb connectToAll: [ :aNumber | graph at: aNumber ].

RSForceBasedLayout new charge: -300; on: nodes.
canvas @ RSCanvasController.
canvas open
```
	"

	self highlightShapes: [ :s | 
		| listIncoming listOutgoing |
		listIncoming := s incomingLines collect: [ :aLine | aLine from ] as: RSGroup.
		listOutgoing := s outgoingLines collect: [ :aLine | aLine to ] as: RSGroup.
		listIncoming, listOutgoing ].! !

!RSHighlightable methodsFor: 'announcer' stamp: ''!
announcer
	^ self privateAnnouncer ifNil: [ 
		| a |
		a := Announcer new.
		self announcer: a.
		a ]! !

!RSHighlightable methodsFor: 'announcer' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject
	self announcer when: anAnnouncementClass send: aSelector to: anObject! !

!RSHighlightable methodsFor: 'public - hooks' stamp: ''!
outgoingLines
	self highlightShapes: [ :s | 
		s outgoingLines collect: #yourself as: RSGroup ].! !

!RSHighlightable methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self highlightShapes: [ :shape | Array with: shape ].
! !

!RSHighlightable methodsFor: 'private' stamp: ''!
restore: aShape selector: selector
	"Main method to restore the attribute of a shape.

	-=-=-=-=-=-=-=-=-=-=-=-=
	c := RSCanvas new.
	shapes := (1 to: 10) collect: [ :n | RSEllipse new size: 20; model: n ] as: RSGroup.
	c addAll: shapes.
	RSGridLayout on: shapes.
	RSHighlightable new record: shapes fifth selector: #color value: Color blue.
	RSHighlightable new restore: shapes fifth selector: #color.
	c
	-=-=-=-=-=-=-=-=-=-=-=-=
"
	| key savedValues |
	key := self copyKey, selector.
	savedValues := aShape properties 
		at: key
		ifAbsent: [ ^ self ].
	aShape
		perform: selector asMutator
		with: savedValues removeLast.
	savedValues ifEmpty: [ aShape properties removeKey: key ]
	! !

!RSHighlightable methodsFor: 'public' stamp: ''!
highlightColor: aColor
	"Set the highlight color. For example:

```Smalltalk
c := RSCanvas new.
shapes := (1 to: 30) collect: [ :v | RSBox new  size: 20; model: v ] as: RSGroup.
c addAll: shapes.
shapes @ RSPopup.

interaction := RSHighlightable new.
interaction highlightColor: Color blue.
shapes @ interaction.

RSGridLayout on: shapes.
c @ RSCanvasController
```

Here is another example:
```Smalltalk
c := RSCanvas new.

shapes := (1 to: 10) collect: [ :v | RSEllipse new size: 20; model: v ] as: RSGroup.
c addAll: shapes.
shapes @ RSPopup @ RSDraggable.

RSGridLayout on: shapes.

eb := RSEdgeBuilder arrowedLineWithOffset: 0.5.
eb canvas: c.
eb connectTo: [ :v | 1 ].

int := RSHighlightable new withEdges highlightColor: Color red.
shapes @ int.

c @ RSCanvasController
```
	"
	self 
		when: RSHighlightEvent do: [ :evt | self record: evt shape selector: #color value: aColor ];
		when: RSUnHighlightEvent do: [ :evt | self restore: evt shape selector: #color ].! !

!RSHighlightable methodsFor: 'obsolete' stamp: ''!
withOutgoingEdges
	self highlightShapes: [ :s | 
		| list |
		list := s outgoingLines collect: #yourself as: RSGroup.
		list addAll: (s outgoingLines collect: #to). 
		list ].! !

!RSHighlightable methodsFor: 'actions' stamp: ''!
doUnhighlight: aShape
	self unhighlightRecordedShapes: aShape! !

!RSHighlightable methodsFor: 'obsolete' stamp: ''!
withIncomingEdges
	self highlightShapes: [ :s | 
		| list |
		list := s incomingLines collect: #yourself as: RSGroup.
		list add: s.
		list ].! !

!RSHighlightable methodsFor: 'announcer' stamp: ''!
when: event do: aBlock
	self announcer when: event do: aBlock! !

!RSHighlightable methodsFor: 'announcer' stamp: ''!
announcementClasses
	^ RSHighlightableEvent subclasses! !

!RSHighlightable methodsFor: 'public' stamp: ''!
highlightBorder: aBorder
	"Set the border. For example:

```Smalltalk
c := RSCanvas new.
shapes := (1 to: 30) collect: [ :v | RSBox new  size: 20; model: v ] as: RSGroup.
c addAll: shapes.
shapes @ RSPopup.

interaction := RSHighlightable new.
interaction highlightBorder: (RSBorder new width: 3; color: Color pink).
shapes @ interaction.

RSGridLayout on: shapes.
c @ RSCanvasController
```
	"
	self 
		when: RSHighlightEvent do: [ :evt | 
			self record: evt shape selector: #border value: aBorder ];
		when: RSUnHighlightEvent do: [ :evt | self restore: evt shape selector: #border ].! !

!RSHighlightable methodsFor: 'public - hooks' stamp: ''!
highlightShapesButKeep: aRSHighlightable
	self 
		highlightShapes: [ :e | { e } ]
		butKeep: aRSHighlightable! !

!RSHighlightable methodsFor: 'announcer' stamp: ''!
getInteractionsForClass: anInteractionClass
	"Return the Announcement subscriptions for the interaction"
	^ self announcer subscriptions getInteractionsForClass: anInteractionClass! !

!RSHighlightable methodsFor: 'announcer' stamp: ''!
announcer: anAnnouncer
	announcer := anAnnouncer! !

!RSHighlightable methodsFor: 'accessing' stamp: ''!
highlightShapes: aOneArgBlock
	"the block accepts a shape (the one selected) should return a collection of shapes. Consider the example:
```	
canvas := RSCanvas new.

shapes := RSEllipse models: (1 to: 30).
shapes @ RSPopup @ RSDraggable.
canvas addAll: shapes.

highlightable := RSHighlightable new.
highlightable highlightColor: Color green.
highlightable highlightShapes: [ :aShape | 
	shapes select: [ :s | (-1 to: 1) includes: (s model - aShape model)  ] ].
shapes @ highlightable.
RSGridLayout on: shapes.

canvas @ RSCanvasController.

canvas open
```
	"
	highlightShapes := aOneArgBlock! !

!RSHighlightable methodsFor: 'hooks' stamp: ''!
onShape: aShape
	aShape
		when: RSMouseEnter do: [ :evt | self doHighlight: evt shape. evt signalUpdate ];
		when: RSMouseLeave do: [ :evt | self doUnhighlight: evt shape. evt signalUpdate ]! !

!RSHighlightable methodsFor: 'accessing - keys' stamp: ''!
propertyKey: aSymbol
	propertyKey := aSymbol.! !

!RSHighlightable methodsFor: 'private' stamp: ''!
record: aShape selector: selector value: anObject
	"Main method to change an attribute of a shape (e.g., colors, border)
	
For example:

	-=-=-=-=
	c := RSCanvas new.
	shapes := (1 to: 10) collect: [ :n | RSEllipse new size: 20; model: n ] as: RSGroup.
	c addAll: shapes.
	RSGridLayout on: shapes.
	RSHighlightable new record: shapes fifth selector: #color value: Color blue.
	c
	-=-=-=-=
	
	"
	| savedValues |
	savedValues := aShape properties
		at: self copyKey , selector
		ifAbsentPut: [ OrderedCollection new ].
	savedValues add: (aShape perform: selector).
	
	aShape
		perform: selector asMutator
		with: (anObject rsValue: aShape)! !

!RSHighlightable methodsFor: 'actions' stamp: ''!
doHighlight: shape
	| shapes |
	self unhighlightRecordedShapes: shape.
	shapes := self highlightShapesFor: shape.
	shapes do: [ :e | self announceHighlight: e source: shape ].
	
	shape topParent propertyAt: self propertyKey put: shapes.! !

!RSHighlightable methodsFor: 'accessing - keys' stamp: ''!
copyKey
	^ copyKey ifNil: [ copyKey := #original ].! !

!RSHighlightable methodsFor: 'public - hooks' stamp: ''!
withLines
	self highlightShapes: [ :s | 
		| list |
		list := s connectedLines copy.
		list add: s.
		list ].! !

!RSHighlightable methodsFor: 'accessing - keys' stamp: ''!
propertyKey
	^ propertyKey ifNil: [ propertyKey := self hash asString ]! !

!RSHighlightable class methodsFor: 'instance colors' stamp: ''!
color: aColor
	| inst |
	inst := self new.
	inst highlightColor: aColor.
	^ inst
	! !

!RSHighlightable class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSHighlightable class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSHighlightable class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSHighlightable class methodsFor: 'obsolete' stamp: ''!
withEdges

	^ self withLines! !

!RSHighlightable class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSHighlightable class methodsFor: 'instance colors' stamp: ''!
red
	^ self color: Color red! !

!RSHighlightable class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSHighlightable class methodsFor: 'public' stamp: ''!
withAntAnimation
	| i |
	i := self new.
	i withLines.
	i when: RSHighlightEvent do: [ :evt | | shape border |
		shape := evt shape.
		border := shape border.
		shape propertyAt: #ob put: border.
		border ifNil: [ border := RSBorder new ].
		shape border: (RSBorder new width: border width * 2; color: border color).
		shape isNode ifTrue: [ 
			| array anime |
			array := #(4).
			shape connectedLines do: [ :edge | edge border 
				color: Color blue; 
				width: 2;
				dashArray: array. ].
			anime := shape newAnimation
				repeat;
				from: 0;
				to: -8;
				duration: 1 second;
				onStepDo: [ :t |
					shape connectedLines do: [ :ed |ed border dashOffset: t ].
					shape signalUpdate ].
			shape topParent propertyAt: #antAnimation put: anime.
		].
	].
	i when: RSUnHighlightEvent do: [ :evt | 
		| att shape |
		shape := evt shape.
		shape border: (shape propertyAt: #ob).
		shape removeKey: #ob.
		shape isNode ifTrue: [ 
			att := shape topParent properties.
			(att at: #antAnimation) stop.
			att removeKey: #antAnimation.
		 ]
	].
	^ i! !

!RSHighlightable class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSHighlightable class methodsFor: 'public - lines' stamp: ''!
createEdgesWith: aBlock shape: aShape using: aRSLine from: aRSGroup
	| models lines shapes parent |
	models := aBlock value: aShape model.
	parent := aShape parent.
	shapes := parent shapesFromModels: models.
	lines := shapes collect: [:s | 
		aRSLine copy
			from: aShape;
			to: s;
			yourself ].
	parent addAll: lines.
	^ lines! !

!RSHighlightable class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSHighlightable class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSHighlightable class methodsFor: 'instance colors' stamp: ''!
blue
	^ self color: Color blue
	! !

!RSHighlightable class methodsFor: 'public - lines' stamp: ''!
showEdges: aBlock using: aRSLine
	^ self showEdges: aBlock using: aRSLine from: [ :aShape | aShape parent shapes ] ! !

!RSHighlightable class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSHighlightable class methodsFor: 'instance creation' stamp: ''!
sameModel: aCanvas
	"Define an highlight object that is able to highlight the same elements pointed by the mouse.
	
For example:
```Smalltalk
values := #(1 1 2 2 2 2 3 3 3 4 4 5 5 5 5 ).

c := RSCanvas new.
boxes := values collect: [ :vv | RSBox new size: 10; model: vv ] as: RSGroup.
c addAll: boxes.
boxes @ RSPopup.
boxes @ (RSHighlightable sameModel: c).
RSGridLayout on: boxes.
c @ RSCanvasController
```"
	^ self new 
		highlightBorder: (RSBorder new color: Color yellow; width: 5); 
		highlightShapes: [ :ss | aCanvas nodes select: [ :sss | (sss model == ss model) and: [ sss ~~ ss ]  ] ]! !

!RSHighlightable class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSHighlightable class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSHighlightable class methodsFor: 'instance colors' stamp: ''!
green
	^ self color: Color green! !

!RSHighlightable class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSHighlightable class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSHighlightable class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSHighlightable class methodsFor: 'public - lines' stamp: ''!
showEdges: aBlock using: aRSLine from: aRSGroup
	| i |
	i := self new.
	i 
		when: RSHighlightEvent do: [ :evt | 
			evt canvas
				propertyAt: #lines 
				put: (self 
					createEdgesWith: aBlock 
					shape: evt shape 
					using: aRSLine 
					from: aRSGroup).
		];
		when: RSUnHighlightEvent do: [:evt |
			evt shape parent propertyAt: #lines ifPresent: [:lines | lines do: #remove ].
		].
	^ i ! !

!RSHighlightable class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSHighlightable class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSHighlightable class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSHighlightable class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSHighlightable class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSHighlightable class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSHighlightable class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSHighlightable class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RSHighlightable class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RSHighlightable class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RSHighlightable class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSHighlightable class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSHighlightable class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSHighlightable class methodsFor: 'instance creation' stamp: ''!
withLines

	^ self new
		  withLines;
		  highlightBorder: (RSBorder new
				   color: Color black)! !

!RSHighlightable class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSHighlightable class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSHighlightableEvent commentStamp: ''!
I am a basic event for class RSHighlightable interaction!
!RSHighlightableEvent methodsFor: 'accessing' stamp: ''!
interaction
	^ interaction! !

!RSHighlightableEvent methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!RSHighlightableEvent methodsFor: 'accessing' stamp: ''!
source: anElementOrView
	source := anElementOrView! !

!RSHighlightableEvent methodsFor: 'accessing' stamp: ''!
interaction: aInteraction
	interaction := aInteraction! !

!RSHighlightableTest methodsFor: 'tests' stamp: ''!
testWithEdges2
	| canvas shapes interaction |
	canvas := RSCanvas new.
	shapes := (1 to: 20) collect: [ :i |
		RSBox new
			size: 10;
			model: i;
			draggable;
			withBorder;
			yourself ].
	shapes := shapes asGroup.
	RSLineBuilder line
		shapes: shapes;
		canvas: canvas;
		connectFrom: [ :n | n // 2 ].
	canvas edges do: #withBorder.
	canvas addAll: shapes.
	RSClusterLayout on: shapes.
	
	interaction := RSHighlightable withLines.
	shapes @ interaction.
	
	self assert: (shapes second outgoingLines collect: #color) asSet size equals: 1.
	self assert: (shapes second outgoingLines collect: #color) anyOne equals: Color gray.
	
	shapes second announce: RSMouseEnter.
	self assert: (shapes second outgoingLines collect: #color) asSet size equals: 1.
	self assert: (shapes second outgoingLines collect: #color) anyOne equals: Color black.
	
	shapes second announce: RSMouseLeave.
	self assert: (shapes second outgoingLines collect: #color) asSet size equals: 1.
	self assert: (shapes second outgoingLines collect: #color) anyOne equals: Color gray.

	! !

!RSHighlightableTest methodsFor: 'tests' stamp: ''!
testBasic

	| c shapes previousColor |
	c := RSCanvas new.
	shapes := (1 to: 10) collect: [ :n | RSEllipse new size: 20; model: n ] as: RSGroup.
	c addAll: shapes.
	RSGridLayout on: shapes.

	previousColor := shapes fifth color.
	RSHighlightable new doHighlight: shapes fifth.
	self assert: shapes fifth color equals: previousColor.
	
	RSHighlightable new record: shapes fifth selector: #color value: Color blue.
	self assert: shapes fifth color equals: Color blue.
	
	RSHighlightable new restore: shapes fifth selector: #color.
	self assert: shapes fifth color equals: previousColor.! !

!RSHighlightableTest methodsFor: 'tests' stamp: ''!
testSameModel

	| values c boxes |
	values := #(1 1 2 2 2 2 3 3 3 4 4 5 5 5 5 ).

	c := RSCanvas new.
	boxes := values collect: [ :vv | RSBox new size: 10; model: vv ] as: RSGroup.
	c addAll: boxes.
	boxes @ RSPopup.
	boxes @ (RSHighlightable sameModel: c).
	RSGridLayout on: boxes.
	c @ RSCanvasController.
	
	c nodes first announce: RSMouseEnter! !

!RSHighlightableTest methodsFor: 'tests' stamp: ''!
testWithEdges
	| canvas shapes interaction |
	canvas := RSCanvas new.
	shapes := (1 to: 20) collect: [ :i |
		RSBox new
			size: 10;
			model: i;
			draggable;
			withBorder;
			yourself ].
	shapes := shapes asGroup.
	RSLineBuilder line
		shapes: shapes;
		canvas: canvas;
		connectFrom: [ :n | n // 2 ].
	canvas edges do: #withBorder.
	canvas addAll: shapes.
	RSClusterLayout on: shapes.
	
	interaction := RSHighlightable red.
	interaction withLines.
	shapes @ interaction.
	
	self assert: (shapes second outgoingLines collect: #color) asSet size equals: 1.
	self assert: (shapes second outgoingLines collect: #color) anyOne equals: Color gray.
	
	shapes second announce: RSMouseEnter.
	self assert: (shapes second outgoingLines collect: #color) asSet size equals: 1.
	self assert: (shapes second outgoingLines collect: #color) anyOne equals: Color red.
	
	shapes second announce: RSMouseLeave.
	self assert: (shapes second outgoingLines collect: #color) asSet size equals: 1.
	self assert: (shapes second outgoingLines collect: #color) anyOne equals: Color gray.

! !

!RSHistogramPlot commentStamp: ''!
Histogram Plot for Roassal
```
| values c plot |
values := #(0.5 0.5 0.3 -0.2 1.6 0 0.1 0.1 0.6 0.4).
c := RSChart new.
plot := RSHistogramPlot new x: values; bins: #(-0.5 0 0.5 1 0.5 1 1.5 2).
c addPlot: plot.
c addDecoration: RSVerticalTick new.
c addDecoration: RSHorizontalTick new doNotUseNiceLabel.
^ c
```

- Bins, can be a number or array of sorted numbers.
- By default bins is 10.
- For the previous example bins are `#(-0.5 0 0.5 1 0.5 1 1.5 2)`.
- First bin is #(-0.5 0), second bin is #(0 0.5), etc.
- All bins but last use this expression to calculate the number of values in each bin: `start <= n and: [n < end]`
- Last bin uses this expression `n between: start and: end`
- `binningStrategy:` allows to the user define different strategies to calculate the size for bins. Check `RSBinningStrategy`!
!RSHistogramPlot methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self binningStrategy: RSDefaultBinning new.! !

!RSHistogramPlot methodsFor: 'accessing' stamp: ''!
bins: aCollectionOrNumber
	bins := aCollectionOrNumber.
	self computeXYValues.! !

!RSHistogramPlot methodsFor: 'accessing' stamp: ''!
binningStrategy: aBinningStrategy

	binningStrategy := aBinningStrategy! !

!RSHistogramPlot methodsFor: 'accessing' stamp: ''!
binningStrategy

	^ binningStrategy! !

!RSHistogramPlot methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	bars := yValues collectWithIndex: [ :yVal :index |
		| rect xVal xVal2 |
		xVal := xValues at: index.
		xVal2 := xValues at: index +1.
		rect := Rectangle 
			origin: (self scalePoint: xVal @ yVal)
			corner: (self scalePoint: xVal2 @ 0).
		self shape copy
			model: (xVal->xVal2) -> yVal;
			color: self computeColor;
			fromRectangle: rect;
			yourself ].
	bars := bars asGroup.
	canvas addAll: bars.! !

!RSHistogramPlot methodsFor: 'accessing' stamp: ''!
bins
	^ bins! !

!RSHistogramPlot methodsFor: 'accessing' stamp: ''!
x: aCollection
	x := aCollection sorted.
	self computeXYValues.! !

!RSHistogramPlot methodsFor: 'accessing' stamp: ''!
createdShapes
	^ bars! !

!RSHistogramPlot methodsFor: 'private' stamp: ''!
computeBins
	| binsSize |
	(bins notNil and:[bins isCollection ]) ifTrue: [ ^ bins ].
	binsSize := bins.
	binsSize
		ifNil: [ binsSize := binningStrategy computeSizeFor: x. ].
	binsSize := binsSize + 1.
	bins := x first to: x last count: binsSize.
	^ bins! !

!RSHistogramPlot methodsFor: 'accessing' stamp: ''!
bars
	^ bars! !

!RSHistogramPlot methodsFor: 'initialization' stamp: ''!
defaultShape
	^ RSBox new noPaint! !

!RSHistogramPlot methodsFor: 'rendering' stamp: ''!
definedValuesY
	"Return the list Y values that are defined"
	^ yValues, {0}! !

!RSHistogramPlot methodsFor: 'private' stamp: ''!
computeXYValues
	| prev |
	bins := self computeBins.
	xValues := bins.
	prev := bins first.
	yValues := bins allButLast collectWithIndex: [ :val1 :index | 
		| val2 condition |
		val2 := bins at: index + 1.
		condition := index + 1 = bins size 
			ifTrue: [ [ :value | value between: val1 and: val2 ] ]
			ifFalse: [ [ :value | val1 <= value and: [ value < val2 ] ] ].
		"TODO"
		(x select: condition ) size.
	].
	
	
	! !

!RSHistogramPlotTest methodsFor: 'tests' stamp: ''!
testBasic
	| c values plot |
	c := RSChart new.
	values := #(1 2 3 4 5 6 7 8 9 10).
	c addPlot: (plot := RSHistogramPlot new x: values).
	c build.
	self assert: plot bars size equals: 10.
	self assert: plot xValues equals: (1 to: 10 count: 11).
	self assert: (plot yValues allSatisfy: [ :v | v = 1 ]).
	! !

!RSHistogramPlotTest methodsFor: 'tests' stamp: ''!
testBinsCollection
	| c values plot |
	c := RSChart new.
	values := #(1 2 3 4 5 6 7 8 9 10).
	c addPlot: (plot := RSHistogramPlot new x: values; bins: #(1 5 8 10)).
	c build.
	self assert: plot bars size equals: 3.
	self assert: plot xValues equals: #(1 5 8 10).
	self assert: plot yValues equals: #(4 3 3).
	! !

!RSHistogramPlotTest methodsFor: 'tests' stamp: ''!
testBins
	| c values plot |
	c := RSChart new.
	values := #(1 2 3 4 5 6 7 8 9 10).
	c addPlot: (plot := RSHistogramPlot new x: values; bins: 2).
	c build.
	self assert: plot bars size equals: 2.
	self assert: plot xValues equals: (1 to: 10 count: 3).
	self assert: (plot yValues allSatisfy: [ :v | v = 5 ]).
	! !

!RSHistogramPlotTest methodsFor: 'tests' stamp: ''!
testBinsStrat
	| c values plot |
	c := RSChart new.
	values := (1 to: 100) shuffled.
	c addPlot: (plot := RSHistogramPlot new x: values; binningStrategy: RSSturgesBinning new).
	c build.
	self assert: plot bars size equals: 10.
	self assert: plot xValues equals: (1 to: 100 by: 99/10).
	self assert: plot yValues equals: (Array new: 10 withAll: 10).
	! !

!RSHorizontalAttachPoint commentStamp: ''!
Horizontal attach points between elements when drawing lines.  Useful for horizontal tree layout.

-=-=-=-=
c := RSCanvas new.

shapes := (30 to: 50) collect: [ :nb |
	RSEllipse new size: nb; model: nb; yourself.
	 ] as: RSGroup.

c addAll: shapes.

lines := RSEdgeBuilder line
	canvas: c;
	connectFrom: 30 toAll: (31 to: 50).

lines do: [ :l | l attachPoint: (RSHorizontalAttachPoint new) ].

RSGridLayout on: shapes. 
RSLocation new
	above;
	move: shapes first on: shapes allButFirst.
shapes @ RSDraggable.

c @ RSControlsCanvas
-=-=-=-=!
!RSHorizontalAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicEndingPointOf: edge
	^ self 
		positionFor: edge to 
		in: edge 
		point: edge to encompassingRectangle leftCenter + (endOffset@0)! !

!RSHorizontalAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicStartingPointOf: edge
	^ self 
		positionFor: edge from
		in: edge 
		point: edge from encompassingRectangle rightCenter + (startOffset@0)! !

!RSHorizontalBarPlot commentStamp: ''!
The class for horizontal bar plots!
!RSHorizontalBarPlot methodsFor: 'hooks' stamp: ''!
computeRectagleFor: aPoint index: index
	| origin corner sizeOffset offset zero |
	zero := 0.
	left ifNotNil: [ zero := left at: index ].
	origin := self scalePoint: aPoint+(zero@0) .
	corner := (xScale scale: zero) @ origin y.
	sizeOffset := 0@(self barSize/ 2.0).
	offset := 0@self barOffset.
	^ Rectangle 
		origin: origin + offset - sizeOffset
		corner: corner + offset + sizeOffset! !

!RSHorizontalBarPlot methodsFor: 'rendering' stamp: ''!
definedValuesX
	"Return the list Y values that are defined"
	| res |
	res := xValues.
	left ifNotNil: [ res := xValues + left ].
	^ res, {0}! !

!RSHorizontalBarPlot methodsFor: 'testing' stamp: ''!
isHorizontalBarPlot
	^ true! !

!RSHorizontalBarPlot methodsFor: 'accessing' stamp: ''!
left: aCollection
	self 
		assert: yValues size = aCollection size
		description: 'Invalid size'.
	left := aCollection! !

!RSHorizontalBarPlot methodsFor: 'rendering' stamp: ''!
beforeRenderingIn: aChart
	| barScale |
	super beforeRenderingIn: aChart.
	yScale class = NSOrdinalScale ifTrue: [ ^ self ].
	barScale := NSOrdinalScale new 
		domain: yValues;
		rangeBands: yScale range padding: gapRatio.
	aChart yScale: barScale! !

!RSHorizontalBarPlot methodsFor: 'accessing' stamp: ''!
left
	^ left! !

!RSHorizontalBarPlot methodsFor: 'accessing' stamp: ''!
barScale
	^ yScale! !

!RSHorizontalBarPlot methodsFor: 'hooks' stamp: ''!
modelFor: aPoint
	^ aPoint x! !

!RSHorizontalCPAPController commentStamp: ''!
I can return the control points for horizontal lines

```
	v := RSCanvas new.
	
	e1 := RSBox new size: 100; color: Color blue.
	e2 := RSBox new size: 100; color: Color red.
	e1 translateTo: 100 @ -200.

	e1 @ RSDraggable.
	e2 @ RSDraggable.
	v
		add: e1;
		add: e2.
	
	l := RSBezier new
		withVerticalAttachPoint;
		from: e1;
		to: e2;
		controlPointsController: (RSHorizontalCPAPController new);
		yourself.
	v add: l.
	v open
```!
!RSHorizontalCPAPController methodsFor: 'hooks' stamp: ''!
controlPointsFrom: from to: to
	| mid |
	mid := (from + to)/2.
	^ Array 
		with: from
		with: mid x @ from y
		with: mid x @ to y
		with: to ! !

!RSHorizontalDominanceTreeLayout commentStamp: ''!
TODO!
!RSHorizontalDominanceTreeLayout methodsFor: 'private - hook' stamp: ''!
computeChildrenFor: aNode
	^ self childrenWithHighestNestingLevelFor: aNode! !

!RSHorizontalFlowLayout commentStamp: ''!
A RTHorizontalFlowLayout is a FlowLayout horizontaly arranged, right queued at default.
!
!RSHorizontalFlowLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self alignLeft.! !

!RSHorizontalFlowLayout methodsFor: 'testing' stamp: ''!
isAlignCenter
	^ alignment = #center! !

!RSHorizontalFlowLayout methodsFor: 'testing' stamp: ''!
isAlignLeft
	^ alignment = #left! !

!RSHorizontalFlowLayout methodsFor: 'hook' stamp: ''!
linesFor: shapes
	| gap y x maxLastLineWidth lines currentLine maxHeight nextElement |
	gap := self gapSize.
	x := y := gap.
	maxLastLineWidth := 0.
	maxHeight := self maxWidth rsValue: shapes.
	lines := OrderedCollection new.
	currentLine := OrderedCollection new.
	shapes doWithIndex: [ :element :index |
		"maybe we need to use a mock element in all layouts"
		element translateTo: (x @ y) + (element extent / 2.0).
		currentLine add: element.
		y := y + element height + gap.
		maxLastLineWidth := maxLastLineWidth max: element width.
		nextElement := shapes at: (index + 1 min: shapes size).
		(y + nextElement height) > maxHeight ifTrue: [
			lines add: currentLine.
			y := gap.
			x := x + maxLastLineWidth + gap.
			currentLine := OrderedCollection new.
			maxLastLineWidth := 0.
		].
		
	].
	currentLine ifNotEmpty: [ lines add: currentLine ].
	^ lines! !

!RSHorizontalFlowLayout methodsFor: 'alignment' stamp: ''!
alignRight
	alignment := #right! !

!RSHorizontalFlowLayout methodsFor: 'alignment' stamp: ''!
alignCenter
	alignment := #center! !

!RSHorizontalFlowLayout methodsFor: 'testing' stamp: ''!
isAlignRight
	^ alignment = #right! !

!RSHorizontalFlowLayout methodsFor: 'alignment' stamp: ''!
alignLeft
	alignment := #left! !

!RSHorizontalLineLayout commentStamp: ''!
A RTHorizontalLineLayout locates all the elements horizontally!
!RSHorizontalLineLayout methodsFor: 'alignment' stamp: ''!
alignBottom
	alignment := #bottom! !

!RSHorizontalLineLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self alignTop! !

!RSHorizontalLineLayout methodsFor: 'alignment' stamp: ''!
alignMiddle
	"Make the element middle"
	alignment := #middle! !

!RSHorizontalLineLayout methodsFor: 'hook' stamp: ''!
deltaFor: aNodeFigure
	| delta |
	delta := 0.
	alignment = #bottom ifTrue: [delta := aNodeFigure height].
	alignment = #middle ifTrue: [delta := aNodeFigure height / 2.0].
	alignment = #label 
		ifTrue: [ delta := aNodeFigure textExtents y_bearing negated ].
	^ 0 @ delta! !

!RSHorizontalLineLayout methodsFor: 'alignment' stamp: ''!
alignTop
	alignment := #top! !

!RSHorizontalLineLayout methodsFor: 'hook' stamp: ''!
movePointer: pointer accordingToFigure: element
	^ (pointer x + element width + self horizontalGap) @ pointer y! !

!RSHorizontalLineLayout methodsFor: 'hook' stamp: ''!
positionOriginalPointer: elements 
	| maxHeight delta |
	delta := 0.
	self alignment == #bottom ifTrue: 
		[ maxHeight := elements maxValue: #height.
		delta := maxHeight ].
	self alignment == #center ifTrue: 
		[ maxHeight := elements maxValue: #height.
		delta := maxHeight / 2.0 ].
	^ (0) @ ((0) + delta)! !

!RSHorizontalLineLayout methodsFor: 'alignment' stamp: ''!
alignLabel
	"Align shapes along the label baseline. It is here assumed that shapes are labels"
	alignment := #label! !

!RSHorizontalTick commentStamp: ''!
<keyClass>
`RSHorizontalTick` defines ticks for the horizontal axis. It is a decoration that can be added to a `RSChart`.

*Responsibility*: define, customize, and render ticks

*Collaborators*: `RSHorizontalTick` is added to `RSChart`

*Example*:
```Smalltalk
	x := -3.14 to: 3.14 by: 0.01.
	c := RSChart new.
	p := RSLinePlot new.
	p x: x y: x sin * 0.22 + 0.5.
	c addPlot: p.
	c addDecoration: RSHorizontalTick new.
	c addDecoration: RSVerticalTick new asFloat.
	c
```!
!RSHorizontalTick methodsFor: 'rendering' stamp: ''!
createTickLineFor: aNumber
	| value |
	value := xScale scale: aNumber.
	^ self shape copy
		startPoint: value @ 0;
		endPoint: value @ self configuration tickSize;
		yourself! !

!RSHorizontalTick methodsFor: 'rendering' stamp: ''!
createNiceLabelIn: aChart
	| nice |
	nice := super createNiceLabelIn: aChart.
	aChart 
		minValueX: nice min;
		maxValueX: nice max.
	^ nice! !

!RSHorizontalTick methodsFor: 'public' stamp: ''!
useVerticalLabel
	self labelRotation: -90.! !

!RSHorizontalTick methodsFor: 'accessing - defaults' stamp: ''!
defaultLabelLocation
	^ RSLocation new below offset: 0@3! !

!RSHorizontalTick methodsFor: 'accessing' stamp: ''!
min
	^ chart minValueX! !

!RSHorizontalTick methodsFor: 'public' stamp: ''!
useDiagonalLabel
	self labelRotation: -45.
	self labelLocation outer; bottom; left; offset: (self configuration fontSize * 0.5 @ 0).! !

!RSHorizontalTick methodsFor: 'accessing' stamp: ''!
max
	^ chart maxValueX! !

!RSHorizontalTopTick commentStamp: ''!
A horizontal tick but in top of the chart, takes values from RSChart, this tick does not use the default scale from the chart. Also this tick decoration does not modify the max and min values from the chart
!
!RSHorizontalTopTick methodsFor: 'rendering' stamp: ''!
createXScale
	| padding |
	xScale ifNil: [ xScale := NSScale linear ].
	xScale class = NSOrdinalScale ifTrue: [ ^ self ].
	padding := chart padding x.
	xScale
		domain:
			{self min.
			self max};
		range:
			{0 + padding.
			chart extent x - padding}! !

!RSHorizontalTopTick methodsFor: 'rendering' stamp: ''!
createTickLineFor: aNumber
	| value y |
	value := xScale scale: aNumber.
	y := chart extent y negated.
	^ self shape copy
		startPoint: value @ y;
		endPoint: value @ (y - self configuration tickSize);
		yourself! !

!RSHorizontalTopTick methodsFor: 'accessing - defaults' stamp: ''!
defaultLabelLocation
	^ RSLocation new above offset: 0@ -3! !

!RSHorizontalTopTick methodsFor: 'accessing' stamp: ''!
min
	^ values min! !

!RSHorizontalTopTick methodsFor: 'accessing' stamp: ''!
values
	^ values! !

!RSHorizontalTopTick methodsFor: 'accessing' stamp: ''!
values: aCollection
	values := aCollection! !

!RSHorizontalTopTick methodsFor: 'accessing' stamp: ''!
max
	^ values max! !

!RSHorizontalTreeLayout commentStamp: ''!
TODO!
!RSHorizontalTreeLayout methodsFor: 'private - hook' stamp: ''!
computeChildrenFor: aNode
	^ self childrenFor: aNode except: alreadyLayoutedNodes! !

!RSHorizontalTreeLayoutTest methodsFor: 'tests' stamp: ''!
testCycles 
	| chars |
	canvas := RSCanvas new.
	chars := $a to: $e.
	shapes := RSComposite models: chars forEach: [ :composite :char |
		| box label |
		label := RSLabel text: char.
		box := RSBox new 
			position: label position;
			extent: label extent + 10;
			yourself.
		
		composite 
			draggable;
			add: box;
			add: label;
			yourself.
		].

	canvas addAll: shapes.
	RSLineBuilder arrowedLine
		canvas: canvas;
		withVerticalAttachPoint;
		useAssociations: 
			{$a -> $b.
			$a -> $e.
			$b -> $c.
			$c -> $d.
			$d -> $a}. "cycle"
	self shouldnt: [RSHorizontalTreeLayout on: shapes] raise: Error.
	self should: [RSHorizontalTreeLayout new validateCycles; on: shapes] raise: Error.! !

!RSHorizontalTreeLayoutTest methodsFor: 'tests' stamp: ''!
testBasic
	RSHorizontalTreeLayout on: canvas nodes.
	self assert: (shapes collect: #position) asArray equals: {(7.5@23.5). (32.5@15.5). (32.5@35.5). (57.5@11.5). (57.5@23.5). (57.5@31.5). (57.5@39.5). (82.5@7.5). (82.5@15.5). (82.5@23.5)}! !

!RSHorizontalTreeLayoutTest methodsFor: 'tests' stamp: ''!
testBasicWithLeftGap
	| withNoGap withGap |
	RSHorizontalTreeLayout new leftGap: 15; on: canvas nodes.
	withNoGap := {(7.5@23.5). (32.5@15.5). (32.5@35.5). (57.5@11.5). (57.5@23.5). (57.5@31.5). (57.5@39.5). (82.5@7.5). (82.5@15.5). (82.5@23.5)}.
	withGap := withNoGap collect: [ :p | p + (10 @ 0) ].
	self assert: (shapes collect: #position) asArray equals: withGap! !

!RSHorizontalTreeLayoutTest methodsFor: 'tests' stamp: ''!
testBasicWithVerticalGap
	RSHorizontalTreeLayout new verticalGap: 50; on: canvas nodes.
	self assert: (shapes collect: #position) asArray equals: {(7.5@117.5). (32.5@62.5). (32.5@200.0). (57.5@35.0). (57.5@117.5). (57.5@172.5). (57.5@227.5). (82.5@7.5). (82.5@62.5). (82.5@117.5)}! !

!RSHorizontalTreeLayoutTest methodsFor: 'tests' stamp: ''!
testBasicWithHorizontalGap
	RSHorizontalTreeLayout new horizontalGap: 50; on: canvas nodes.
	self assert: (shapes collect: #position) asArray equals: {(7.5@23.5). (62.5@15.5). (62.5@35.5). (117.5@11.5). (117.5@23.5). (117.5@31.5). (117.5@39.5). (172.5@7.5). (172.5@15.5). (172.5@23.5)}! !

!RSHorizontalTreeLayoutTest methodsFor: 'tests' stamp: ''!
testBasicWithTopGap
	| withNoGap withGap |
	RSHorizontalTreeLayout new topGap: 15; on: canvas nodes.
	withNoGap := {(7.5@23.5). (32.5@15.5). (32.5@35.5). (57.5@11.5). (57.5@23.5). (57.5@31.5). (57.5@39.5). (82.5@7.5). (82.5@15.5). (82.5@23.5)}.
	withGap := withNoGap collect: [ :p | p + (0 @ 10) ].
	self assert: (shapes collect: #position) asArray equals: withGap! !

!RSHorizontalVanDerPloegTreeLayout commentStamp: ''!
I am the horizontal tree layout algorithm described in the publication "Drawing non-layered tidy trees in linear time" by Atze van der Ploeg [1] (companion repo at [2]).

I use the trait `RSTWalkBasedRegularTreeLayout` to get the main behavior and fullfil the explicit requirements to have a tree layout growing toward the horizontal dimension.

[1]: https://www.semanticscholar.org/paper/Drawing-non-layered-tidy-trees-in-linear-time-Ploeg/d45f66231e053590c64c9d901fb7b028dbc5c923
[2]: https://github.com/cwi-swat/non-layered-tidy-trees!
!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
mselOf: aNode put: aFloat

	^ aNode propertyAt: #msel put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
separate: v children: children at: i rest: aValueLink

	| sr cl mssr mscl ih |
	"Right contour node of left siblings and its sum of modfiers."
	sr := children at: i - 1.
	mssr := self modOf: sr.

	"Left contour node of current subtree and its sum of modfiers."
	cl := children at: i.
	mscl := self modOf: cl.

	"Looping"
	ih := aValueLink.
	[ sr isNotNil and: [ cl isNotNil ] ] whileTrue: [ 
		| dist sy cy |
		(self depthBoundOf: sr) > (self lowYofIYL: ih) ifTrue: [ 
			ih := ih nextLink ].

		"How far to the left of the right side of sr is the left side of cl?"
		dist := mssr + (self prelimOf: sr) + (self breadthMeasureOf: sr)
		        + (self breadthGapAmong: sr and: cl) - mscl
		        - (self prelimOf: cl).

		dist > 0 ifTrue: [ 
			mscl := mscl + dist.
			self
				moveSubtree: children
				at: i
				other: (self indexOfIYL: ih)
				distance: dist ].

		"Advance highest node(s) and sum(s) of modifiers (Coordinate system increases downwards)"
		sy := self depthBoundOf: sr.
		cy := self depthBoundOf: cl.

		sy <= cy ifTrue: [ 
			sr := self nextRightContour: sr.
			sr ifNotNil: [ mssr := mssr + (self modOf: sr) ] ].

		sy >= cy ifTrue: [ 
			cl := self nextLeftContour: cl.
			cl ifNotNil: [ mscl := mscl + (self modOf: cl) ] ] ].

	"Set threads and update extreme nodes."
	(sr isNil and: [ cl isNotNil ])
		ifTrue: [ "the current subtree must be taller than the left siblings."
			self
				setLeftThread: v
				leftMostChild: children first
				currentChild: (children at: i)
				child: cl
				acc: mscl ]
		ifFalse: [ "the left siblings must be taller than the current subtree."
			(sr isNotNil and: [ cl isNil ]) ifTrue: [ 
				self
					setRightThread: v
					previousChild: (children at: i - 1)
					currentChild: (children at: i)
					child: sr
					acc: mssr ] ]! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
mselOf: aNode update: aBlock

	^ self mselOf: aNode put: (aBlock value: (self mselOf: aNode))! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'accessing' stamp: ''!
verticalGap

	self explicitRequirement! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
shiftOf: aNode update: aBlock

	^ self shiftOf: aNode put: (aBlock value: (self shiftOf: aNode))! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
completedInitializationOf: aNode

	^ aNode propertyAt: #vdpInitialized put: true! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
elOf: aNode put: aFloat

	^ aNode propertyAt: #el put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
firstWalk: v

	self
		is: v
		ifLeaf: [ self setExtremesOfLeaf: v ]
		ifNotLeaf: [ :children | 
			| leftMostChild rightMostChild chain bound |
			leftMostChild := children first.
			rightMostChild := children last.

			"Recur down on v's leftmost child."
			self firstWalk: leftMostChild.

			"Create siblings in contour minimal vertical coordinate and index list."
			bound := self depthBoundOf: (self elOf: leftMostChild).

			chain := (2 to: children size)
				         inject: (self updateIYL: bound at: 1 rest: nil)
				         into: [ :ih :i | 
					         | child |
					         child := children at: i.

					         self firstWalk: child.

					         bound := self depthBoundOf: (self erOf: child).

					         "/Store lowest vertical coordinate while extreme nodes still point in current subtree."
					         self
						         separate: v
						         children: children
						         at: i
						         rest: ih.

					         "Update data about the widths"
					         self updateIYL: bound at: i rest: ih ].

			self
				positionRoot: v
				leftMostChild: leftMostChild
				rightMostChild: rightMostChild.

			self
				setExtremesOfNonLeaf: v
				leftMostChild: leftMostChild
				rightMostChild: rightMostChild ]! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
setExtremesOfNonLeaf: v leftMostChild: leftMostChild rightMostChild: rightMostChild

	self
		elOf: v put: (self elOf: leftMostChild);
		erOf: v put: (self erOf: rightMostChild);
		mselOf: v put: (self mselOf: leftMostChild);
		mserOf: v put: (self mserOf: rightMostChild)! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
secondWalk: aShape depth: n breadth: m

	| mNext children depth breadth position |
	mNext := m + (self modOf: aShape).

	depth := n + (self depthOf: aShape).
	breadth := (self prelimOf: aShape) + mNext.

	position := self
		            positionOfShape: aShape
		            atDepth: depth
		            atBreadth: breadth.
	self positionOf: aShape put: position.

	children := self childrenOf: aShape.

	self addChildSpacing: children.

	"Recur over my onw children."
	children do: [ :aChild | 
		self secondWalk: aChild depth: n breadth: mNext ]! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
prelimOf: aNode update: aBlock

	^ self prelimOf: aNode put: (aBlock value: (self prelimOf: aNode))! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
mselOf: aNode

	^ aNode propertyAt: #msel! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
nextRightContour: v

	^ self
		  is: v
		  ifLeaf: [ self rthreadOf: v ]
		  ifNotLeaf: [ (self childrenOf: v) last ]! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
setExtremesOfLeaf: v

	self
		elOf: v put: v;
		erOf: v put: v;
		mselOf: v put: 0;
		mserOf: v put: 0! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
depthOf: aNode

	^ aNode propertyAt: #depth! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
threadOf: aNode put: aFloat

	^ aNode propertyAt: #thread put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
changeOf: aNode put: aFloat

	^ aNode propertyAt: #change put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
is: aShape ifLeaf: lBlock ifNotLeaf: nlBlock

	^ (self childrenOf: aShape) ifEmpty: lBlock ifNotEmpty: nlBlock! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
changeOf: aNode update: aBlock

	^ self changeOf: aNode put: (aBlock value: (self changeOf: aNode))! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'positioning' stamp: ''!
depthMeasureOf: aShape

	^ aShape width! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
modOf: aNode

	^ aNode propertyAt: #mod! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'positioning' stamp: ''!
depthGapAmong: aShapeParent and: aShape

	^ self
		  horizontalGapAmong: aShapeParent
		  and: aShape
		  default: RSAbstractGraphLayout verticalGap! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'gap' stamp: ''!
verticalGapAmong: aShapeParent and: aShape default: anObject

	| gap |
	gap := self verticalGap.

	^ [ gap value: aShapeParent value: aShape value: anObject ]
		  onDNU: #value:value:value:
		  do: [ gap ]! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
moveSubtree: children at: i other: si distance: dist

	"Move subtree by changing mod."

	| child intermediateChildren |
	child := children at: i.

	self
		modOf: child update: [ :mod | mod + dist ];
		mselOf: child update: [ :msel | msel + dist ];
		mserOf: child update: [ :mser | mser + dist ].

	"Are there intermediate children? (originally extracted in the `distributedExtra` function)"
	self assert: i > si.

	(intermediateChildren := i - si) > 1 ifTrue: [ 
		| siChild ratio |
		ratio := dist / intermediateChildren.
		siChild := children at: si + 1.
		self
			shiftOf: siChild update: [ :shift | shift + ratio ];
			shiftOf: child update: [ :shift | shift - ratio ];
			changeOf: child update: [ :change | change - dist + ratio ] ]! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
erOf: aNode

	^ aNode propertyAt: #er! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'hook' stamp: ''!
layout: rootNodes atPoint: aPoint atLayer: aLayer

	^ self layout: root depth: aPoint x breadth: aPoint y! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
levelOf: aNode put: aFloat

	^ aNode propertyAt: #vdpLevel put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
modOf: aNode update: aBlock

	^ self modOf: aNode put: (aBlock value: (self modOf: aNode))! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
prelimOf: aNode

	^ aNode propertyAt: #prelim! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
nextLeftContour: v

	^ self
		  is: v
		  ifLeaf: [ self threadOf: v ]
		  ifNotLeaf: [ (self childrenOf: v) first ]! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'positioning' stamp: ''!
breadthGapAmong: aShapeParent and: aShape

	^ self
		  verticalGapAmong: aShapeParent
		  and: aShape
		  default: RSAbstractGraphLayout horizontalGap! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
childrenOf: aNode

	^ aNode propertyAt: #children! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'gap' stamp: ''!
horizontalGapAmong: aShapeParent and: aShape default: anObject

	| gap |
	gap := self horizontalGap.

	^ [ gap value: aShapeParent value: aShape value: anObject ]
		  onDNU: #value:value:value:
		  do: [ gap ]! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
rthreadOf: aNode

	^ aNode propertyAt: #rthread! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
hasBeenInitializedOf: aNode

	^ aNode propertyAt: #vdpInitialized ifAbsent: [ false ]! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
mserOf: aNode

	^ aNode propertyAt: #mser! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'positioning' stamp: ''!
positionOfShape: aShape atDepth: depth atBreadth: breadth

	| shift |
	shift := aShape extent / 2.
	^ depth @ breadth + shift! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
positionOf: aShape put: aPoint

	^ aShape position: aPoint! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
updateIYL: minY at: i rest: aValueLink

	| ih |
	"Remove siblings that are hidden by the new subtree."
	ih := aValueLink.
	[ ih isNotNil and: [ minY >= (self lowYofIYL: ih) ] ] whileTrue: [ 
		ih := ih nextLink ].

	"Prepend the new subtree"
	^ ValueLink new
		  value: i -> minY;
		  nextLink: ih;
		  yourself! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
threadOf: aNode

	^ aNode propertyAt: #thread! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
setLeftThread: v leftMostChild: leftMostChild currentChild: child child: cl acc: mscl

	| li diff |
	li := self elOf: leftMostChild.
	self threadOf: li put: cl.

	"Change mod so that the sum of modifier after following thread is correct."
	diff := mscl - (self modOf: cl) - (self mselOf: leftMostChild).
	self modOf: li update: [ :mod | mod + diff ].

	"Change preliminary x coordinate so that the node does not move."
	self prelimOf: li update: [ :prelim | prelim - diff ].

	"Update extreme node and its sum of modifiers."
	self
		elOf: leftMostChild put: (self elOf: child);
		mselOf: leftMostChild put: (self mselOf: child)! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
erOf: aNode put: aFloat

	^ aNode propertyAt: #er put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
elOf: aNode

	^ aNode propertyAt: #el! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
modOf: aNode put: aFloat

	^ aNode propertyAt: #mod put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
depthOf: aNode put: aFloat

	^ aNode propertyAt: #depth put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
levelOf: aNode

	^ aNode propertyAt: #vdpLevel! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
rthreadOf: aNode put: aFloat

	^ aNode propertyAt: #rthread put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
mserOf: aNode update: aBlock

	^ self mserOf: aNode put: (aBlock value: (self mserOf: aNode))! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'API' stamp: ''!
layout: aRootShape depth: aDepth breadth: aBreadth

	self
		firstWalk: aRootShape;
		secondWalk: aRootShape depth: aDepth breadth: aBreadth! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'initialization' stamp: ''!
initialize: elements lineEdges: aGroupOfLines

	| associations |
	associations := aGroupOfLines collect: [ :line | line from -> line to ].
	^ self initialize: elements associationEdges: associations! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
depthBoundOf: aShape

	^ (self depthOf: aShape) + (self depthMeasureOf: aShape)! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'initialization' stamp: ''!
initializeForShape: aShape fathers: fathers

	| depth |
	self
		modOf: aShape put: 0;
		changeOf: aShape put: 0;
		shiftOf: aShape put: 0;
		prelimOf: aShape put: 0;
		mselOf: aShape put: 0;
		mserOf: aShape put: 0;
		threadOf: aShape put: nil;
		rthreadOf: aShape put: nil;
		elOf: aShape put: nil;
		erOf: aShape put: nil.

	depth := fathers
		         at: aShape
		         ifPresent: [ :parents | 
			         | level |
			         parents
				         reject: [ :each | self hasBeenInitializedOf: each ]
				         thenDo: [ :each | 
				         self initializeForShape: each fathers: fathers ].

			         level := (parents collect: [ :each | self levelOf: each ])
				                  max.

			         self levelOf: aShape put: level + 1.

			         (parents collect: [ :aShapeParent | 
				          (self depthBoundOf: aShapeParent)
				          + (self depthGapAmong: aShapeParent and: aShape) ]) max ]
		         ifAbsent: [ self levelOf: aShape put: 0 ].

	self
		depthOf: aShape put: depth;
		completedInitializationOf: aShape.

	^ aShape! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
childrenOf: aNode put: aValue

	^ aNode propertyAt: #children put: aValue! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'initialization' stamp: ''!
initialize: elements associationEdges: associations

	| hierarchy roots fathers rootNode leaves |
	hierarchy := IdentityDictionary new.
	roots := IdentitySet withAll: elements.
	leaves := IdentitySet withAll: elements.
	fathers := IdentityDictionary new.

	associations do: [ :anAssociation | 
		| children child father multipleParents fathersOfChild |
		father := anAssociation key.
		child := anAssociation value.

		multipleParents := false.
		roots remove: child ifAbsent: [ multipleParents := true ].

		leaves
			remove: father
			ifAbsent: [ "is it okay to try to remove father more than one time"
			 ].

		fathersOfChild := fathers
			                  at: child
			                  ifAbsentPut: [ OrderedCollection new ].

		fathersOfChild add: father.

		children := hierarchy
			            at: father
			            ifAbsentPut: [ 
			            self childrenOf: father put: OrderedCollection new ].

		multipleParents ifFalse: [ children add: child ] ].

	rootNode := roots size > 1
		        ifTrue: [ 
			        roots collect: [ :each | 
				        self assert: (fathers includesKey: each) not
				        "fathers at: each put: { rootBox }" ].

			        RSComposite new
				        in: [ :aRootShape | 
					        self childrenOf: aRootShape put: roots asArray ];
				        yourself ]
		        ifFalse: [ roots anyOne ].

	leaves do: [ :each | 
		self
			assert: (self childrenOf: each) isNil;
			childrenOf: each put: Array empty;
			initializeForShape: each fathers: fathers ].

	^ self initializeForShape: rootNode fathers: fathers! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
setRightThread: v previousChild: previousChild currentChild: currentChild child: sr acc: mssr

	| ri diff |
	ri := self erOf: currentChild.
	self rthreadOf: ri put: sr.

	"Change mod so that the sum of modifier after following thread is correct."
	diff := mssr - (self modOf: sr) - (self mserOf: currentChild).
	self modOf: ri update: [ :mod | mod + diff ].

	"Change preliminary x coordinate so that the node does not move."
	self prelimOf: ri update: [ :prelim | prelim - diff ].

	"Update extreme node and its sum of modifiers."
	self
		erOf: currentChild put: (self erOf: previousChild);
		mserOf: currentChild put: (self mserOf: previousChild)! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'accessing' stamp: ''!
horizontalGap

	self explicitRequirement! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
lowYofIYL: aValueLink

	| anAssoc |
	anAssoc := aValueLink value.
	^ anAssoc value! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
shiftOf: aNode put: aFloat

	^ aNode propertyAt: #shift put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'hook' stamp: ''!
doInitialize: elements

	super doInitialize: elements.

	root := self initialize: elements lineEdges: self edges! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
prelimOf: aNode put: aFloat

	^ aNode propertyAt: #prelim put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
mserOf: aNode put: aFloat

	^ aNode propertyAt: #mser put: aFloat! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
addChildSpacing: children

	^ children inject: 0 @ 0 into: [ :aPoint :child | 
		  | x newPoint y |
		  x := aPoint x + (self shiftOf: child).
		  y := x + aPoint y + (self changeOf: child).
		  newPoint := Point x: x y: y.
		  self modOf: child update: [ :mod | mod + newPoint y ].
		  newPoint ]! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
shiftOf: aNode

	^ aNode propertyAt: #shift! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
positionRoot: v leftMostChild: leftMostChild rightMostChild: rightMostChild

	| childrenPrelim |
	"Set the prelim for hierarchy item v."
	childrenPrelim := (self prelimOf: leftMostChild)
	                  + (self modOf: leftMostChild)
	                  + (self prelimOf: rightMostChild)
	                  + (self modOf: rightMostChild)
	                  + (self breadthMeasureOf: rightMostChild)
	                  - (self breadthMeasureOf: v).

	self prelimOf: v put: childrenPrelim / 2! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
changeOf: aNode

	^ aNode propertyAt: #change! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'positioning' stamp: ''!
breadthMeasureOf: aShape

	^ aShape height! !

!RSHorizontalVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
indexOfIYL: aValueLink

	| anAssoc |
	anAssoc := aValueLink value.
	^ anAssoc key! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSHorizontalVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSIdentityMatrix commentStamp: ''!
TODO!
!RSIdentityMatrix methodsFor: 'accessing' stamp: ''!
at: u at: v
	| row |
	row := rows
		at: u
		ifAbsentPut: [IdentityDictionary new].
	^row
		at: v
		ifAbsent: [false]! !

!RSIdentityMatrix methodsFor: 'initialize-release' stamp: ''!
initialize
	rows := IdentityDictionary new! !

!RSIdentityMatrix methodsFor: 'accessing' stamp: ''!
at: u at: v put: aBoolean
	| row |
	"u -> v"
	row := rows
		at: u
		ifAbsentPut: [IdentityDictionary new].
	row at: v put: aBoolean.	"v -> u"
	row := rows
		at: v
		ifAbsentPut: [IdentityDictionary new].
	row at: u put: aBoolean! !

!RSIdentityMatrix methodsFor: 'accessing' stamp: ''!
at: u
	| row |
	row := rows
		at: u
		ifAbsentPut: [IdentityDictionary new].
	^row keys! !

!RSInitialSelection commentStamp: ''!
Use int the calypso system setting, you can create a new subclass and define a new selection strategy!
!RSInitialSelection methodsFor: 'accessing' stamp: ''!
targetClass: anObject

	targetClass := anObject! !

!RSInitialSelection methodsFor: 'instance creation' stamp: ''!
on: aCanvas
	self subclassResponsibility! !

!RSInitialSelection methodsFor: 'accessing' stamp: ''!
targetClass

	^ targetClass! !

!RSInspectableInteraction commentStamp: ''!
I allow to inspect another view or windows. It can be configurable to set the kind of view you want to inspect!
!RSInspectableInteraction methodsFor: 'accessing' stamp: ''!
inspectShapeBlock: oneArgBlock
	"The block should return a window"
	inspectShapeBlock := oneArgBlock! !

!RSInspectableInteraction methodsFor: 'hooks' stamp: ''!
initialize
	super initialize.
	highlightable := RSHighlightable new.! !

!RSInspectableInteraction methodsFor: 'hooks' stamp: ''!
deselectIfNecessary
	"Nothing to unselect"
	selectedShape ifNil: [ ^ self ].
	highlightable doUnhighlight: selectedShape
	! !

!RSInspectableInteraction methodsFor: 'accessing' stamp: ''!
inspectElementBlock
	^ inspectShapeBlock! !

!RSInspectableInteraction methodsFor: 'hooks' stamp: ''!
inspectShape: aShape
	| oldInspectorWindow canvasMorph |
	self deselectIfNecessary.
	selectedShape := aShape.
	highlightable doHighlight: selectedShape.
	
	oldInspectorWindow := inspectorWindow.
	inspectorWindow := inspectShapeBlock rsValue: aShape model.
	inspectorWindow setLabel: aShape model asString.
	canvasMorph := aShape canvas morph.
	canvasMorph root activate.
	"If there is a previous inspector window, then we use the same position and extent"
	oldInspectorWindow ifNil: [ ^ self ].
	inspectorWindow 
		position: oldInspectorWindow position;
		extent: oldInspectorWindow extent.
	oldInspectorWindow delete.
	oldInspectorWindow := nil
	
	! !

!RSInspectableInteraction methodsFor: 'hooks' stamp: ''!
onShape: aShape
	aShape 
		when: RSMouseLeftClick
		do: [ :evt | self inspectShape: aShape ]! !

!RSInspectableInteraction methodsFor: 'accessing' stamp: ''!
highlightable: anObject
	highlightable := anObject! !

!RSInspectableInteraction methodsFor: 'accessing' stamp: ''!
highlightable
	^ highlightable! !

!RSInteraction commentStamp: ''!
I am the top class for interactions in roassal.

You can add an interaction to an instance of RSElement or RSEdge or RSView with: 

-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
element addInteraction: RSDraggable.
edge addInteraction: (RSHighlightable new).
view @ RSDraggableView.
-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
!
!RSInteraction methodsFor: 'hooks' stamp: ''!
onShape: aShape
	self subclassResponsibility 
	! !

!RSInteraction class methodsFor: 'instance creation' stamp: ''!
instance
	^ instance ifNil: [ instance := self new ].! !

!RSInteraction class methodsFor: 'instance creation' stamp: ''!
onShape: aShape
	| inst |
	inst := self wantsUniqueInstance 
		ifTrue: [ self instance ]
		ifFalse: [ self new ].
	inst onShape: aShape.
	^ inst! !

!RSInteraction class methodsFor: 'instance creation' stamp: ''!
wantsUniqueInstance 
	^ false! !

!RSInteraction class methodsFor: 'class initialization' stamp: ''!
reset
	<script: 'self reset'>
	instance := nil! !

!RSKeepBorderWidthRatioInteraction commentStamp: ''!
I am a simple interaction that allows to shapes keep size ratio or with in the case of the border

Here is an example:
| v sb label box |
	v := RSView new.
	label := RSShapeBuilder label.
	box := RSShapeBuilder box
		border: TSBorder new;
		cornerRadius: (TSCornerRadius new right: 10);
		extent: [ :lb | lb extent + 5 ].
	sb := RSShapeBuilder composite
		interactionDo: #draggable;
		shapes: [ :m | | l |
			l := label elementOn: m.
			TSGroup with: (box elementOn: l) with: l].
	v addAll: (sb elementsOn: ArrayedCollection withAllSubclasses).
	v @ RSControlsView.
	RSEdgeBuilder orthoHorizontal
		markerEnd: (TSMarker new 
			offsetRatio: 0.1;
			shape: (RSShapeBuilder triangle 
				color: Color red;
				size: 10;
				element));
		attachPoint: RSHorizontalAttachPoint new; 
		border: (TSBorder new);
		view: v;
		elements: v elements;
		connectFrom: #superclass.
	"v edges @ RSKeepBorderWidthRatio. Not necessary since all edges shares the same border"
	
	v edges first @ RSKeepBorderWidthRatio. 
	v edges first @ RSKeepMarkersSizeRatio.
	RSHorizontalTreeLayout new on: v elements.
	v open setLabel: 'Horizontal Tree'!
!RSKeepBorderWidthRatioInteraction methodsFor: 'hooks' stamp: ''!
onShape: aShape
	| width |
	aShape isInACanvas ifFalse: [ self error: 'aShape needs to be part of one canvas' ].
	width := aShape border width.
	aShape canvas when: RSScaleChangedEvent do: [:evt | 
		aShape border width: (self scaleFor: evt) * width.
		evt signalUpdate ]. ! !

!RSKeepFontSizeRatioInteraction commentStamp: ''!
Interaction for RSLabels, modify the font size based on the scale of the canvas!
!RSKeepFontSizeRatioInteraction methodsFor: 'hooks' stamp: ''!
onShape: aLabel
	| fontSize |
	aLabel isInACanvas ifFalse: [ self error: 'add this label to a canvas first' ].
	fontSize := aLabel fontSize.
	aLabel canvas when: RSScaleChangedEvent do: [ :evt |
		aLabel fontSize: (self scaleFor: evt) * fontSize.
		evt signalUpdate ]! !

!RSKeepMarkersSizeRatioInteraction commentStamp: ''!
I am an interaction for edges becacuse I access to markers from edges.

I change the size of the marker allow it to remain in the same size

Example:
| v sb label box |
	v := RSView new.
	label := RSShapeBuilder label.
	box := RSShapeBuilder box
		border: TSBorder new;
		cornerRadius: (TSCornerRadius new right: 10);
		extent: [ :lb | lb extent + 5 ].
	sb := RSShapeBuilder composite
		interactionDo: #draggable;
		shapes: [ :m | | l |
			l := label elementOn: m.
			TSGroup with: (box elementOn: l) with: l].
	v addAll: (sb elementsOn: ArrayedCollection withAllSubclasses).
	v @ RSControlsView.
	RSEdgeBuilder orthoHorizontal
		markerEnd: (TSMarker new 
			offsetRatio: 0.1;
			shape: (RSShapeBuilder triangle 
				color: Color red;
				size: 10;
				element));
		attachPoint: RSHorizontalAttachPoint new; 
		border: (TSBorder new);
		view: v;
		elements: v elements;
		connectFrom: #superclass.
	"v edges @ RSKeepBorderWidthRatio. Not necessary since all edges shares the same border"
	
	v edges first @ RSKeepBorderWidthRatio. 
	v edges first @ RSKeepMarkersSizeRatio.
	RSHorizontalTreeLayout new on: v elements.
	v open setLabel: 'Horizontal Tree'
	!
!RSKeepMarkersSizeRatioInteraction methodsFor: 'hooks' stamp: ''!
onShape: anEdge
	| markers sizes offsets |
	anEdge isInACanvas ifFalse: [ self error: 'add this edge to a canvas first' ].
	markers := anEdge markers select: #notNil.
	sizes := markers collect: [:marker | marker shape extent].
	offsets := markers collect: #offset.
	anEdge canvas when: RSScaleChangedEvent do: [ :evt | | delta |
		delta := self scaleFor: evt.
		markers doWithIndex: [ :marker :index | 
			marker shape extent: delta * (sizes at: index).
			marker offset: delta * (offsets at: index)  ] ].! !

!RSKeyDown commentStamp: ''!
Event representing a key pressing (but not releasing)

-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
c := TSCanvas new.
e := TSEllipse new.
c addShape: e.
e when: TRKeyDown do: [ :event |
	event keyCombination = $r asKeyCombination ifTrue: [
		e color: Color random.
		v signalUpdate.
	]
].

c open
-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=!
!RSKeyNavigationCanvasInteraction commentStamp: ''!
I add key events to the view to move it, zoom it with the key board!
!RSKeyNavigationCanvasInteraction methodsFor: 'events-processing' stamp: ''!
zoomMove: aCanvas delta: delta
	| scale camera newScale correct |
	camera := aCanvas camera.
	scale := camera scale.
	newScale := self scaleFor: delta * scale. 
	aCanvas newAnimation 
		easing: RSEasingInterpolator backOut;
		duration: 200 milliSeconds;
		from: scale;
		to: newScale;
		on: camera set: #scale:.
	correct := self 
		correctCameraPosition: aCanvas
		scale: newScale.
	correct = camera position ifTrue: [ ^ self ].
	aCanvas newAnimation 
		easing: RSEasingInterpolator backOut;
		duration: 200 milliSeconds;
		from: camera position;
		to: correct;
		on: camera set: #translateTo:.! !

!RSKeyNavigationCanvasInteraction methodsFor: 'events' stamp: ''!
processKeyUp: evt
	| keyName |
	steps removeAll.
	keyName := evt keyName.
	keyName = #M ifTrue: [ ^ self expandCollapse: evt ].
	animation ifNil: [ ^ self ].
	self removeRectanglesFor: evt canvas.
	animation stop.
	animation := nil.! !

!RSKeyNavigationCanvasInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	steps := Set new.
	speed := 1.
		
	! !

!RSKeyNavigationCanvasInteraction methodsFor: 'events-processing' stamp: ''!
expandCollapse: evt
	evt canvas morph window expandBoxHit! !

!RSKeyNavigationCanvasInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	aCanvas 
		when: RSKeyDown do: [ :evt | self processKeyDown: evt ];
		when: RSKeyUp do: [ :evt | self processKeyUp: evt ].! !

!RSKeyNavigationCanvasInteraction methodsFor: 'events-processing' stamp: ''!
zoomIn: aCanvas
	self zoomMove: aCanvas delta: 1.5! !

!RSKeyNavigationCanvasInteraction methodsFor: 'events-processing' stamp: ''!
zoomOut: aCanvas
	self zoomMove: aCanvas delta: 0.5.
	! !

!RSKeyNavigationCanvasInteraction methodsFor: 'events' stamp: ''!
processKeyDown: evt
	| keyName |
	keyName := evt keyName.
	keyName = #I ifTrue: [ ^ self zoomIn: evt canvas ].
	keyName = #O ifTrue: [ ^ self zoomOut: evt canvas ].
	self configuration hasHorizontalScrolling ifTrue: [ 
		keyName = #LEFT ifTrue: [ steps add: -1@0 ].
		keyName = #RIGHT ifTrue: [ steps add: 1@0 ].
	].
	self configuration hasVerticalScrolling ifTrue: [ 
		keyName = #UP ifTrue: [ steps add: 0@ -1 ].
		keyName = #DOWN ifTrue: [ steps add: 0@ 1 ].
	].
	
	speedMult := evt shiftKeyPressed
		ifTrue: [ 4 ] 
		ifFalse: [ 1 ].
	animation ifNotNil: [ ^ self ].
	steps ifEmpty: [ ^ self ].
	self processStepsOn: evt canvas! !

!RSKeyNavigationCanvasInteraction methodsFor: 'events' stamp: ''!
processStepsOn: aCanvas

	| rect lastMS |
	rect := self encompassingRectangleFor: aCanvas.
	speed := (rect width min: rect height) * 0.0005.
	animation := nil.
	lastMS := nil.
	animation := aCanvas newAnimation repeat onStepDo: [ :t |
		| step camera correct position deltaMS current |
		current := animation currentTime.
		lastMS ifNil: [ lastMS := current-1 ].
		deltaMS := current - lastMS.
		lastMS := current.
		step := steps inject: 0@0 into: [:p :s |p+s ].
		camera := aCanvas camera.
		camera translateBy: step / (aCanvas camera scale / (speed * speedMult * deltaMS)).
		position := camera position.
		correct := self correctCameraPosition: aCanvas.
		correct = position 
			ifFalse: [ camera position: correct ].
		aCanvas signalUpdate.
		].! !

!RSKeyNavigationCanvasInteraction methodsFor: 'rendering' stamp: ''!
renderLegendOn: lb
	lb
		text: '↑ ↓ → ←' description: 'Arrow keys to move the view';
		text: 'Shift + arrows' description: 'Accelerate the move';
		text: 'M' description: 'Maximize or restore the window';
		text: 'I' description: 'Zoom in';
		text: 'O' description: 'Zoom out'.! !

!RSKeyUp commentStamp: ''!
Event representing a key release.

[[[
c := TSCanvas new.

c when: TRKeyDown do: [ :event |
	self log: '[DOWN]'; logCr: event keyCombination.
].

c when: TRKeyUp do: [ :event |
	self log: '[UP]'; logCr: event keyCombination.
].

c open
]]]!
!RSKeyboardEvent commentStamp: ''!
A base class for keyboard events.!
!RSKeyboardEvent methodsFor: 'accessing' stamp: ''!
keyName
	^ keyName! !

!RSKeyboardEvent methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	keyValue := 0! !

!RSKeyboardEvent methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Append a sequence of characters to aStream that identify the receiver."

	super printOn: aStream.
	aStream
		nextPutAll: ' keyName: ';
		print: keyName.
	aStream
		nextPutAll: ' keyValue: ';
		print: keyValue.
	aStream
		nextPutAll: ' commandKeyPressed: ';
		print: commandKeyPressed.
	aStream
		nextPutAll: ' controlKeyPressed: ';
		print: controlKeyPressed.
	aStream
		nextPutAll: ' optionKeyPressed: ';
		print: optionKeyPressed.
	aStream
		nextPutAll: ' shiftKeyPressed: ';
		print: shiftKeyPressed! !

!RSKeyboardEvent methodsFor: 'accessing' stamp: ''!
keyName: aString
	keyName := aString! !

!RSKeyboardEvent methodsFor: 'accessing' stamp: ''!
keyValue
	^ keyValue! !

!RSKeyboardEvent methodsFor: 'accessing' stamp: ''!
keyValue: anObject
	keyValue := anObject! !

!RSLabel commentStamp: ''!
Instances of RSLabel uses font, text metrics, and a string. These labels can share fonts.

Instance variables:
- text: a String without character cr or lf or tabs.
- fontName: a String, the font family name, Eg: `Source Code Pro`.
- fontSize: a positive number.
- font: an instance of LogicalFont, Eg: `LogicalFont familyName: 'Source Code Pro' pointSize: 20`
- emphasis: an instance of TextEmphasis, Eg: `TextEmphasis italic`
- metricsProvider: an instance of RSMetricProvider. Users of RSLabel can define a subvclass of RSMetricProvider in order to have differnt metrics for this class.
- textExtents: an instance of RSTextExtents, it has text information of this class.
- cairoGlyphs: private varible used to compute extents and draw this shape on the canvas


```Smalltalk
| c font words |
c := RSCanvas new.
font := LogicalFont familyName: 'Source Code Pro' pointSize: 20.
words := String loremIpsum splitOn: ' '.
c addAll: (words collect: [:word | 
	RSLabel new
		font: font;
		text: word;
		yourself ]).
c showEncompassingRectangles.
RSFlowLayout on: c nodes.
	
c @ RSCanvasController.
c

```

For more fonts of your system use: `FreeTypeFontProvider current updateFromSystem families`.!
!RSLabel methodsFor: 'initialization' stamp: ''!
resetCache 
	font ifNil: [ font := self createFont ].
	
	textExtents := nil.
	self resetCairoGlyphs.
	self extent: self textWidth @ self textHeight.! !

!RSLabel methodsFor: 'accessing' stamp: ''!
fontSize
	^ fontSize ! !

!RSLabel methodsFor: 'accessing' stamp: ''!
cairoFont
	"used in drawing and extents computation"
	^ CairoScaledFont fromFreetypeFont: font asFreetypeFont! !

!RSLabel methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!RSLabel methodsFor: 'managing font' stamp: ''!
bold
"Make the label bold
```
| c lbl1 lbl2 |
c := RSCanvas new.
lbl1 := RSLabel new bold; text: 'hello'.
c addShape: lbl1.
lbl2 := RSLabel new text: 'world'.
c addShape: lbl2.
RSLocation new below; move: lbl2 on: lbl1.
c @ RSCanvasController.
c open
```
"
	self emphasisAdd: TextEmphasis bold.! !

!RSLabel methodsFor: 'private' stamp: ''!
privateFontName
	^ font realFont isTTCFont
		ifTrue: [ font familyName ] 
		ifFalse: [ self class familyFontName ]
	! !

!RSLabel methodsFor: 'initialization' stamp: ''!
resetCairoGlyphs
	cairoGlyphs := nil! !

!RSLabel methodsFor: 'accessing' stamp: ''!
font
	^ font! !

!RSLabel methodsFor: 'metrics' stamp: ''!
metricsProvider
	^ metricsProvider ifNil: [ metricsProvider := RSMetricsProvider default ]! !

!RSLabel methodsFor: 'managing font' stamp: ''!
struckOut
	"Make the label strickethrough
	
```
| c lbl1 lbl2 |
c := RSCanvas new.
lbl1 := RSLabel new struckOut; text: 'hello'.
c addShape: lbl1.
lbl2 := RSLabel new text: 'world'.
c addShape: lbl2.
RSLocation new below; move: lbl2 on: lbl1.
c @ RSCanvasController.
c open
```
"
	self emphasisAdd: TextEmphasis struckOut.! !

!RSLabel methodsFor: 'accessing' stamp: ''!
cairoGlyphs
	"used in drawing and extents computation"
	^ cairoGlyphs ifNil: [
		cairoGlyphs := CairoFontMetricsProvider new
			font: font;
			glyphsOf: text ].! !

!RSLabel methodsFor: 'accessing' stamp: ''!
emphasis: aTextEmphasis
"
| c lbl |
c := RSCanvas new.
lbl := RSLabel new text: 'hello'; emphasis: TextEmphasis italic.
c addShape: lbl.
c @ RSCanvasController.
c open
"
	emphasis = aTextEmphasis ifTrue: [ ^ self ].
	emphasis := aTextEmphasis.
	self resetFont.! !

!RSLabel methodsFor: 'private' stamp: ''!
createFont
	| aFont |
	aFont := LogicalFont 
		familyName: fontName
		pointSize: fontSize.
	aFont := aFont emphasized: emphasis emphasisCode.
	^ aFont! !

!RSLabel methodsFor: 'accessing' stamp: ''!
fontName
	^ fontName! !

!RSLabel methodsFor: 'testing' stamp: ''!
isUnderlined
	^ self is: 4! !

!RSLabel methodsFor: 'managing font' stamp: ''!
normal
	self emphasis: TextEmphasis normal.! !

!RSLabel methodsFor: 'accessing' stamp: ''!
textExtents
	^ textExtents ifNil: [ textExtents := self computeTextExtents ].! !

!RSLabel methodsFor: 'private' stamp: ''!
is: anInteger
	"anInteger is a valid code"
	^ (emphasis emphasisCode bitAnd: anInteger) > 0! !

!RSLabel methodsFor: 'managing font' stamp: ''!
underline
	"Make the label underlined
```
| c lbl1 lbl2 |
c := RSCanvas new.
lbl1 := RSLabel new underline; text: 'hello'.
c addShape: lbl1.
lbl2 := RSLabel new text: 'world'.
c addShape: lbl2.
RSLocation new below; move: lbl2 on: lbl1.
c @ RSCanvasController.
c open
```
"
	self emphasisAdd: TextEmphasis underlined.! !

!RSLabel methodsFor: 'path' stamp: ''!
sessionChanged
	super sessionChanged.
	self resetCairoGlyphs! !

!RSLabel methodsFor: 'testing' stamp: ''!
hasText
	^ text notNil and: [ text isNotEmpty ]! !

!RSLabel methodsFor: 'testing' stamp: ''!
isItalic
	^ self is: 2! !

!RSLabel methodsFor: 'managing font' stamp: ''!
emphasisAdd: anEmphasis
	emphasis add: anEmphasis.
	self resetFont.! !

!RSLabel methodsFor: 'accessing' stamp: ''!
textHeight
	"without any transformation"

	^ self textExtents height! !

!RSLabel methodsFor: 'managing font' stamp: ''!
italic
	"Make the label italic
```
| c lbl1 lbl2 |
c := RSCanvas new.
lbl1 := RSLabel new italic; text: 'hello'.
c addShape: lbl1.
lbl2 := RSLabel new text: 'world'.
c addShape: lbl2.
RSLocation new below; move: lbl2 on: lbl1.
c @ RSCanvasController.
c open
```
"
	self emphasisAdd: TextEmphasis italic.! !

!RSLabel methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	paint := Color gray.
	self font: self class defaultFont.
	! !

!RSLabel methodsFor: 'accessing' stamp: ''!
textWidth
	"without any transformation"
	
	^ self textExtents width! !

!RSLabel methodsFor: 'accessing' stamp: ''!
text: string
	"Set the text of a label. do not try to write in the `text` variable directly."
	text = string ifTrue: [ ^ self ].
	text := string asString.
	self resetCache; resetPath.! !

!RSLabel methodsFor: 'testing' stamp: ''!
isStruckOut
	^ self is: 16! !

!RSLabel methodsFor: 'accessing' stamp: ''!
font: aLogicalFont
	font = aLogicalFont ifTrue: [ ^ self ].
	font := aLogicalFont.
	fontSize := font pointSize.
	fontName := font familyName.
	emphasis := TextEmphasis fromCode: font emphasis.
	self fontName: self privateFontName.
	self resetCache.
	! !

!RSLabel methodsFor: 'accessing' stamp: ''!
emphasis
	^ emphasis! !

!RSLabel methodsFor: 'initialization' stamp: ''!
resetFont
	font := nil.
	self resetCache.! !

!RSLabel methodsFor: 'metrics' stamp: ''!
metricsProvider: aRSMetricsProvider
	"Set the way metrics related to the label (e.g., height, width), can be computed. The metric provier per default is RSCairoMetricsProvider.
	
	 The argument must be a subclass of RSMetricsProvider.
	
	For example:
	
```Smalltalk
metricsProvider := RSCairoMetricsProvider new.

words := (String loremIpsum: 2000) substrings.
labels := words collect: [ :w | RSLabel new metricsProvider: metricsProvider; text: w ].

c := RSCanvas new.
c addAll: labels.
RSFlowLayout on: labels.
c @ RSCanvasController
c open
```
	"
	metricsProvider := aRSMetricsProvider.
	self resetCache.! !

!RSLabel methodsFor: 'accessing' stamp: ''!
fontName: aString
	"
	LogicalFontManager current allFamilies inspect
	"
	fontName = aString ifTrue: [ ^ self ].
	fontName := aString.
	self resetFont.
	! !

!RSLabel methodsFor: 'accessing - attributes' stamp: ''!
model: anObject
	"model is used to create popups and other interactions"
	super model: anObject.
	self hasText ifFalse: [ self text: anObject asString ]! !

!RSLabel methodsFor: 'accessing' stamp: ''!
fontSize: aNumber
	"Set the size of the label.
Here is an example:
```Smalltalk
c := RSCanvas new.

(1 to: 100 by: 5) shuffled do: [ :i |
	lbl := RSLabel new fontSize: i; text: 'hello'; model: i.
	c add: lbl.
	lbl @ RSPopup.
].
RSFlowLayout on: c shapes.
c @ RSCanvasController
```
"
	fontSize = aNumber ifTrue: [ ^ self ].
	fontSize := aNumber.
	self resetFont.! !

!RSLabel methodsFor: 'testing' stamp: ''!
isBold
	^ self is: 1! !

!RSLabel methodsFor: 'testing' stamp: ''!
isNormal
	^ emphasis emphasisCode = 0! !

!RSLabel methodsFor: 'visiting' stamp: ''!
accept: visitor
	visitor visitLabel: self.! !

!RSLabel methodsFor: 'metrics' stamp: ''!
computeTextExtents
	^ self hasText 
		ifTrue: [ self metricsProvider extentsOf: self ]
		ifFalse: [ RSTextExtents empty ]! !

!RSLabel class methodsFor: 'accessing' stamp: ''!
text: aText
	^ self new text: aText! !

!RSLabel class methodsFor: 'public' stamp: ''!
familyFontName
	"
	self familyFontName
	"
	| fontList |
	fontList := LogicalFontManager current allFamilies collect: #familyName.
	
	(fontList includes: 'Source Sans Pro') ifTrue: [ ^ 'Source Sans Pro' ].
	(fontList includes: 'DejaVu Sans') ifTrue: [ ^ 'DejaVu Sans' ].
	fontList ifEmpty: [ ^ StandardFonts defaultFont familyName ].
	
	(fontList includes: StandardFonts listFont familyName ) 
		ifTrue: [ ^ StandardFonts listFont familyName ].
		
	
	^  StandardFonts defaultFont familyName ! !

!RSLabel class methodsFor: 'public' stamp: ''!
defaultFont
	^ StandardFonts defaultFont! !

!RSLabel class methodsFor: 'accessing' stamp: ''!
text: aText model: aModelObject
	"Initialize a label with a text and a model"
	^ self new text: aText; model: aModelObject! !

!RSLabelGenerator commentStamp: ''!
Reference:
 	[1] An Extension of Wilkinson's Algorithm for positioning Tick Labels on Axes  (Justin Talbot, Sharon Lin, Pat Hanrahan)!
!RSLabelGenerator methodsFor: 'private' stamp: ''!
densityMax: k m: m
	(k >= m) ifTrue: [ ^ 2 - ((k-1)/(m-1)) ].
	^ 1! !

!RSLabelGenerator methodsFor: 'public' stamp: ''!
searchMin: dmin max: dmax desired: desiredNumberOfTicks
	| best sm dm cm delta bestScore k |
	best := RSNiceLabel new.
	bestScore := -2.
	desiredNumberOfTicks <= 0 ifTrue: [ self error: 'The minimun value of desiredNumberOfTicks is 1' ].
	
	"In case of a particular situation"
	(dmin = 0 and: [ dmax = 0 ]) ifTrue: [ 
		best
			min: 0;
			max: 1;
			step: 1;
			score: bestScore.
		^ best ].
	
	[ :break |
		[ true ] whileTrue: [ 
			n := nice next.
			sm := self simplicityMax.
			((self w: sm c: 1 d: 1 l: 1) < bestScore)
				ifTrue: [ break value ].
			k := 2.
			[ :break2 |
				[ true ] whileTrue: [ | z |
					dm := [ self densityMax: k m: desiredNumberOfTicks ] on: ZeroDivide do: [ :ex | self error: 'Please increase the value of desiredNumberOfTicks/labels' ].
					((self w: sm c: 1 d: dm l: 1) < bestScore) 
						ifTrue: [ break2 value ].
					delta := (dmax - dmin)/(k+1)/ n j/ (nice qat: n i).
					z := (nice logB: delta) ceiling.
					[ :break3|
						[ true ] whileTrue: [ 
							[ :continue | | minStart maxStart step |
								step := n j * (nice qat: n i) * (nice base raisedTo: z).
								cm := self coverageMin: dmin max: dmax span: step * (k-1).
								((self w: sm c: cm d: dm l: 1) < bestScore) 
									ifTrue: [ break3 value ].
								minStart := ((dmax / step) floor - (k-1)) * n j.
								maxStart := (dmin / step) ceiling * n j.
								(minStart > maxStart) ifTrue: [ 
									z := z +1.
									continue value. ].
						
								(minStart to: maxStart) do: [ :start |
									| lmin lmax lstep c s d l score |
									lmin := start * step / n j. 
									lmax := lmin + (step * (k -1)).
									lstep := step.
									c := self coverageMin: dmin max: dmax lmin: lmin lmax: lmax.
									s := self simplicity: lmin max: lmax step: lstep.
									d := self density: k m: desiredNumberOfTicks dmin: dmin dmax: dmax lmin: lmin lmax: lmax.
									l := self legibility: lmin max: lmax step: lstep.
									score := self w: s c: c d: d l: l.
							
									((score > bestScore) and: 
									[ loose not or: [ (lmin <= dmin) and: 
														  [ lmax >= dmax ] ] ]) ifTrue: [
										best
											min: lmin;
											max: lmax;
											step: lstep;
											score: score.
											bestScore := score.
									 ].
								].
								z := z +1.
							] valueWithExit.
						].
					] valueWithExit. 
					k := k +1.
				].
			] valueWithExit.
		 ]
	] valueWithExit.
	
	nice reset.
	
	^ best.! !

!RSLabelGenerator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	loose := false.
	w := #(0.25 0.2 0.5 0.05).
	self nice: RSNiceStepSizeGenerator new.! !

!RSLabelGenerator methodsFor: 'private' stamp: ''!
legibility: min max: max step: step
	^ 1! !

!RSLabelGenerator methodsFor: 'private' stamp: ''!
density: k m: m dmin: dmin dmax: dmax lmin: lmin lmax: lmax
	"* k		number of labels
	 * m		number of desired labels
	 * dmin	data range minimum
	 * dmax	data range maximum
	 * lmin	label range minimum
	 * lmax	label range maximum
	 * ^	density
	  
	 k-1 number of intervals between labels
	 m-1 number of intervals between desired number of labels
	 r   label interval length/label range
	 rt  desired label interval length/actual range"
	| r rt |
	r := (k -1)/(lmax - lmin).
	rt := (m - 1)/((lmax max: dmax) - (lmin min: dmin) ).
	^ 2 - ( (r/rt) max: (rt/r) ).! !

!RSLabelGenerator methodsFor: 'private' stamp: ''!
coverageMin: dmin max: dmax span: span
	| range r half|
	range := dmax - dmin.
	(span > range) ifTrue: [ 
		half := (span - range)/2.
		r := 0.1*range.
		^ 1 - (half * half / (r * r) )].
	^ 1.0! !

!RSLabelGenerator methodsFor: 'private' stamp: ''!
w: s c: c d: d l: l
	^ (w first * s) + (w second * c) + (w third * d) + (w fourth * l)! !

!RSLabelGenerator methodsFor: 'public' stamp: ''!
setLooseFlag: aBool
	"Configuration to 'loose' labelings.
	The extreme labels can be placement both inside(setLooseFlag: false) and outside (setLooseFlag: true) of the range of the data.
	
	Example
	.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=
	lg setLooseFlag: true.
	label := lg searchMin: -98.0 max: 18.0 desired: 3.
	self assert: label asString = '(Score: 0.14) -100.00	-60.00	-20.00	20.00	'.
	lg setLooseFlag: false.
	label := lg searchMin: -98.0 max: 18.0 desired: 3.
	self assert: label asString = '(Score: 0.62) -100.00	-50.00	0.00	'.
	.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=
	"
	loose := aBool.
	nice reset.! !

!RSLabelGenerator methodsFor: 'public' stamp: ''!
nice: aNiceGenerator
	nice := aNiceGenerator! !

!RSLabelGenerator methodsFor: 'private' stamp: ''!
flooredMod: a n: num
	^ a - (num * (a / num) floor).! !

!RSLabelGenerator methodsFor: 'private' stamp: ''!
vMin: min max: max step: step
	^ ((self flooredMod: min n: step) < (self epsilon) 
	and: [ min <= 0 and: [ max >= 0 ] ]) ifTrue: [ 1 ] ifFalse: [ 0 ]! !

!RSLabelGenerator methodsFor: 'private' stamp: ''!
epsilon
	" Compute the machine epsilon for the float type, the largest positive 
 	floating-point value that, when added to 1, results in a value equal to 1 due to 
 	roundoff."
	| temp |
	epsilon ifNotNil: [ ^ epsilon ].
	temp := 0.5.
	[ (1 + temp) > 1 ] whileTrue: [ temp := temp / 2 ].
	epsilon := temp.
	^ epsilon.
	! !

!RSLabelGenerator methodsFor: 'private' stamp: ''!
simplicity: min max: max step: step
	(nice qvar size > 1) ifTrue: [ 
		^ 1 - (n i/ (nice qvar size - 1)) - n j + (self vMin: min max: max step: step) ].
	^ 1 - n j + (self vMin: min max: max step: step)
		! !

!RSLabelGenerator methodsFor: 'private' stamp: ''!
coverageMin: dmin max: dmax lmin: lmin lmax: lmax
	| a b c|
	a := dmax - lmax.
	b := dmin - lmin.
	c := 0.1 * (dmax - dmin).
	^ 1 - ( 0.5 * (((a * a) + (b * b))/ (c * c)) )
	! !

!RSLabelGenerator methodsFor: 'private' stamp: ''!
simplicityMax
	(nice qvar size > 1) ifTrue: [ ^ 1 - ((n i )/(nice qvar size -1)) - n j + 1.0 ].
	 ^ 1 - n j + 1.0! !

!RSLabelGenerator class methodsFor: 'instance creation' stamp: ''!
nice: aNiceGenerator
	^ self new nice: aNiceGenerator! !

!RSLabelGeneratorTest methodsFor: 'tests' stamp: ''!
testError
	self
		should: [ lg searchMin: -98.0 max: 18.0 desired: 1 ]
		raise: Error
		description: 'entry to short'.
	self
		should: [ lg searchMin: -98.0 max: 18.0 desired: 0 ]
		raise: Error
		description: 'entry to short'! !

!RSLabelGeneratorTest methodsFor: 'tests' stamp: ''!
testSearch
	| label |
	lg setLooseFlag: true.
	label := lg searchMin: -98.0 max: 18.0 desired: 3.
	self
		assert: label asString
		equals: '(Score: 0.14) -100.00	-60.00	-20.00	20.00	'.
	lg setLooseFlag: false.
	label := lg searchMin: -98.0 max: 18.0 desired: 3.
	self
		assert: label asString
		equals: '(Score: 0.62) -100.00	-50.00	0.00	'.
	lg setLooseFlag: true.
	label := lg searchMin: -1 max: 3.5 desired: 4.
	self
		assert: label asString
		equals: '(Score: 0.54) -1.00	0.00	1.00	2.00	3.00	4.00	'.
	lg setLooseFlag: false.
	label := lg searchMin: -1 max: 3.5 desired: 4.
	self
		assert: label asString
		equals: '(Score: 0.63) -1.00	0.00	1.00	2.00	3.00	'.
	lg setLooseFlag: true.
	label := lg searchMin: -1 max: 200 desired: 3.
	self
		assert: label asString
		equals: '(Score: -0.29) -25.00	50.00	125.00	200.00	'.
	lg setLooseFlag: false.
	label := lg searchMin: -1 max: 200 desired: 3.
	self
		assert: label asString
		equals: '(Score: 1.00) 0.00	100.00	200.00	'.
	lg setLooseFlag: true.
	label := lg searchMin: 119 max: 178 desired: 3.
	self
		assert:
			(label asString = '(Score: -0.65) 110.00	150.00	190.00	'
				or: [ label asString
						= '(Score: -0.65) 110.00	130.00	150.00	170.00	190.00	' ]).
	lg setLooseFlag: false.
	label := lg searchMin: 119 max: 178 desired: 3.
	self
		assert: label asString
		equals: '(Score: 0.48) 120.00	150.00	180.00	'.
	lg setLooseFlag: true.
	label := lg searchMin: -31 max: 27 desired: 4.
	self
		assert: label asString
		equals: '(Score: 0.07) -40.00	-30.00	-20.00	-10.00	0.00	10.00	20.00	30.00	'.
	lg setLooseFlag: false.
	label := lg searchMin: -31 max: 27 desired: 3.
	self
		assert: label asString
		equals: '(Score: 0.71) -30.00	0.00	30.00	'.
	lg setLooseFlag: true.
	label := lg searchMin: -55.45 max: -49.99 desired: 2.
	self assert: label asString equals: '(Score: -1.13) -56.00	-48.00	'.
	lg setLooseFlag: false.
	label := lg searchMin: -55.45 max: -49.99 desired: 3.
	self
		assert: label asString
		equals: '(Score: 0.49) -55.00	-52.50	-50.00	'.
	lg setLooseFlag: false.
	label := lg searchMin: 0 max: 100 desired: 2.
	self assert: label asString equals: '(Score: 1.00) 0.00	100.00	'.
	label := lg searchMin: 0 max: 100 desired: 3.
	self
		assert: label asString
		equals: '(Score: 0.95) 0.00	50.00	100.00	'.
	label := lg searchMin: 0 max: 100 desired: 4.
	self
		assert: label asString
		equals: '(Score: 0.70) 0.00	50.00	100.00	'.
	label := lg searchMin: 0 max: 100 desired: 5.
	self
		assert: label asString
		equals: '(Score: 0.85) 0.00	25.00	50.00	75.00	100.00	'.
	label := lg searchMin: 0 max: 100 desired: 6.
	self
		assert: label asString
		equals: '(Score: 0.90) 0.00	20.00	40.00	60.00	80.00	100.00	'.
	label := lg searchMin: 0 max: 100 desired: 7.
	self
		assert: label asString
		equals: '(Score: 0.80) 0.00	20.00	40.00	60.00	80.00	100.00	'.
	label := lg searchMin: 0 max: 100 desired: 8.
	self
		assert: label asString
		equals:
			'(Score: 0.79) 0.00	10.00	20.00	30.00	40.00	50.00	60.00	70.00	80.00	90.00	100.00	'.
	label := lg searchMin: 0 max: 100 desired: 9.
	self
		assert: label asString
		equals:
			'(Score: 0.88) 0.00	10.00	20.00	30.00	40.00	50.00	60.00	70.00	80.00	90.00	100.00	'.
	label := lg searchMin: 0 max: 100 desired: 10.
	self
		assert: label asString
		equals:
			'(Score: 0.94) 0.00	10.00	20.00	30.00	40.00	50.00	60.00	70.00	80.00	90.00	100.00	'! !

!RSLabelGeneratorTest methodsFor: 'running' stamp: ''!
setUp
	| nice |
	super setUp.
	nice := RSNiceStepSizeGenerator new.
	lg := RSLabelGenerator nice: nice! !

!RSLabelTest commentStamp: ''!
A TSLabelTest is a test class for testing the behavior of TSLabel!
!RSLabelTest methodsFor: 'tests' stamp: ''!
testDrawLabel
	
	canvas addShape: (RSLabel new
		color: (Color purple alpha: 0.5);
		position: -50 @ 0;
		text: 'Hello world!!';
		yourself).
	canvas createMorph drawOnMockCanvas.! !

!RSLabelTest methodsFor: 'tests' stamp: ''!
testBuilding2

	| l |
	l := RSLabel text: 'Hello' model: 42.
	self assert: l class equals: RSLabel.
	self assert: l text equals: 'Hello'.
	self assert: l model equals: 42.
	! !

!RSLabelTest methodsFor: 'tests' stamp: ''!
testCairoCachedMetricProvider
	| label provider |
	label := RSLabel new.
	label text: ''.
	provider := RSCairoCachedMetricsProvider new.
	label metricsProvider: provider.
	
	self assert: label extent class equals: Point.
	self assert: (provider extentsOf: label) class equals: RSTextExtents.! !

!RSLabelTest methodsFor: 'tests' stamp: ''!
testDrawBorderLabel
	|  |
	canvas addShape: (RSLabel new
		withBorder;
		color: (Color purple alpha: 0.5);
		fontName: 'Source Sans Pro';
		position: -50 @ 0;
		text: 'Hello world!!';
		yourself).
	canvas createMorph drawOnMockCanvas.! !

!RSLabelTest methodsFor: 'tests' stamp: ''!
testHasChildren
	| b |
	b := RSLabel new.
	self deny: b hasChildren.
	! !

!RSLabelTest methodsFor: 'tests' stamp: ''!
testModelWithoutText

	| l |
	l := RSLabel new.
	self assert: l text isNil.
	self assert: l model isNil.
	
	l model: 42.
	self assert: l model equals: 42.
	self assert: l text equals: '42'! !

!RSLabelTest methodsFor: 'tests' stamp: ''!
testSameSize
	| l1 l2 |
	l1 := RSLabel model: 123.
	l2 := RSLabel new text: 123.
	
	self assert: l1 extent equals: l2 extent! !

!RSLabelTest methodsFor: 'tests' stamp: ''!
testUnderlineStruckout
	| label |
	label := RSLabel new.
	self assert: label isNormal.
	label underline.
	label bold.
	self assert: label isBold.
	self assert: label isUnderlined.! !

!RSLabelTest methodsFor: 'tests' stamp: ''!
testBuilding

	| l |
	l := RSLabel text: 'Hello'.
	self assert: l class equals: RSLabel.
	self assert: l text equals: 'Hello'
	! !

!RSLabelTest methodsFor: 'tests' stamp: ''!
testCairoFitMetricsProvider
	| label h |
	label := RSLabel new.
	label text: '.'.
	h := label height.
	label metricsProvider: (RSCairoFitMetricsProvider new).
	self assert: h > label height.! !

!RSLabelTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new! !

!RSLabeled commentStamp: ''!
<keyClass>
`RSLabeled` adds a label on shape. Per default, it is added on top of the shape. The label may be particularized using #text: in the default string representation is not sufficient. 

*Responsibility*: locate a label on top of a shape.

*Collaborators*: can be added to any Roassal shape

*Variables*:
- `location`: a `RSLocation` indicating where the label should be located
- `isHighlightable`: a boolean indicating whether the label should be highlighted
- `lowColor`: a boolean indicating whether the label should be highlighted

*Example*:
```Smalltalk
c := RSCanvas new.

shapes := RSGroup new.
1 to: 3 do: [ :v |
	shapes add: (RSBox new model: v) ].

shapes @ (RSLabeled new text: [ :m | 'Value = ', m asString ]).

RSNormalizer size
	shapes: shapes;
	from: 20; to: 40;
	normalize: [ :aModel | aModel ].

c addAll: shapes.
RSVerticalLineLayout new gapSize: 30; on: shapes.
c @ RSCanvasController
```

Another example:
```Smalltalk
c := RSCanvas new.
shapes := (1 to: 10) collect: [ :v | RSBox new model: v; size: 30 ] as: RSGroup.
c addAll: shapes.
shapes @ RSLabeled new highlightable.
RSNormalizer size shapes: shapes; normalize: #yourself.
RSGridLayout on: shapes.
c @ RSCanvasController.
c 
```
!
!RSLabeled methodsFor: 'accessing' stamp: ''!
lowColor: aColor
	lowColor := aColor! !

!RSLabeled methodsFor: 'accessing' stamp: ''!
target: aBlock
	target := aBlock! !

!RSLabeled methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	self shapeBuilder: RSMultilineLabelBuilder new.
	self model: #model.
	location := RSLocation new above.
	isHighlightable := false.! !

!RSLabeled methodsFor: 'accessing' stamp: ''!
lowColor
	^ lowColor! !

!RSLabeled methodsFor: 'public - configuration' stamp: ''!
text: aBlockOrSymbol
	"Set the label on a shape. The argument is either a block or a symbol, and is used to compute the label to use from the shape model.
For example:
```Smalltalk
someShapes := #(10 20 30) collect: [ :v | RSEllipse new size: 20; model: v ] as: RSGroup.
c := RSCanvas new.
c addAll: someShapes.

someShapes @ (RSLabeled new text: [:model | 'Value = ', model asString]).
RSFlowLayout on: someShapes.
someShapes @ RSDraggable.
c @ RSCanvasController
```
"
	shapeBuilder textBlock: aBlockOrSymbol! !

!RSLabeled methodsFor: 'accessing' stamp: ''!
location
	^ location! !

!RSLabeled methodsFor: 'hooks' stamp: ''!
createLabel: aShape
	| label color set targetLabel |
	label := self shapeBuilder shapeFor: (self modelFor: aShape).
	location stick: label on: aShape.
	isHighlightable 
		ifFalse: [ ^ label ].
	targetLabel := target value: label.
	color := targetLabel color.
	targetLabel color: self lowColor.
	set := [ :c | 
		label pushFront.
		targetLabel color: c.
		label signalUpdate ].
	aShape 
		when: RSMouseEnter do: [ set value: color ];
		when: RSMouseLeave do: [ set value: lowColor ];
		when: RSShapeRemovedEvent do: [ label remove ].
	^ label! !

!RSLabeled methodsFor: 'hooks' stamp: ''!
getOrCreateLabel: aShape
	| label parent |
	label := aShape properties 
		at: #RSLabeled
		ifAbsentPut: [ self createLabel: aShape ].
	parent :=aShape parent.
	aShape when: RSShapeRemovedEvent send: #remove to: label.
	(label isInACanvas not and: [parent notNil ]) 
		ifTrue: [ parent addShape: label shape ].
	^ label! !

!RSLabeled methodsFor: 'accessing' stamp: ''!
shapeBuilder: aShapeBuilder
	shapeBuilder := aShapeBuilder! !

!RSLabeled methodsFor: 'accessing' stamp: ''!
locationDo: aBlock
	aBlock value: location! !

!RSLabeled methodsFor: 'hooks' stamp: ''!
modelFor: aRSShape
	^ modelBlock rsValue: aRSShape! !

!RSLabeled methodsFor: 'public - configuration' stamp: ''!
middle
	self location middle! !

!RSLabeled methodsFor: 'hooks' stamp: ''!
onShape: aShape
	
	aShape isInACanvas 
		ifTrue: [ self getOrCreateLabel: aShape ]
		ifFalse: [ aShape when: RSShapeAddedEvent do: [ :evt | 
			self getOrCreateLabel: evt shape ] ].! !

!RSLabeled methodsFor: 'accessing' stamp: ''!
shapeBuilder
	^ shapeBuilder! !

!RSLabeled methodsFor: 'accessing' stamp: ''!
model: aBlock
	modelBlock := aBlock! !

!RSLabeled methodsFor: 'public - configuration' stamp: ''!
fontSize: fontSizeAsNumber
	"Set the font size of the label

```Smalltalk
c := RSCanvas new.

shapes := (1 to: 100) collect: [ :v |
	RSBox new model: v.
] as: RSGroup .

c addAll: shapes.
RSNormalizer size 
	shapes: shapes;
	from: 10;
	to: 30;
	normalize: #yourself.
RSGridLayout on: shapes.

shapes @ (RSLabeled new fontSize: 10).

c @ RSCanvasController.
```	
"
	self shapeBuilder labelShape fontSize: fontSizeAsNumber! !

!RSLabeled methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!RSLabeled methodsFor: 'accessing' stamp: ''!
model
	^ modelBlock! !

!RSLabeled methodsFor: 'public - configuration' stamp: ''!
highlightable
	"Make the label highlightable.
For example:
```Smalltalk
c := RSCanvas new.
shapes := (1 to: 10) collect: [ :v | RSBox new model: v; size: 30 ] as: RSGroup.
c addAll: shapes.
shapes @ RSLabeled new highlightable.
RSNormalizer size shapes: shapes; normalize: #yourself.
RSGridLayout on: shapes.
c @ RSCanvasController.
c 
```
"
	isHighlightable := true.
	self 
		lowColor: Color veryVeryLightGray;
		target: #yourself.! !

!RSLabeled class methodsFor: 'accessing' stamp: ''!
text: aText
	"Utility method to define a labeled interaction with a text"
	^ self new text: aText! !

!RSLabeled class methodsFor: 'accessing' stamp: ''!
middle
	^ self new middle! !

!RSLabeled class methodsFor: 'accessing' stamp: ''!
highlightable
	"Create a label interaction that is highligtable
```
canvas := RSCanvas new.

someColors := { Color red . Color blue . Color green }.
shapes := (someColors collect: [ :aColor | 
	RSEllipse new size: 30; model: aColor; color: aColor ]) asGroup.

canvas addAll: shapes.

shapes @ RSDraggable.
shapes @ RSLabeled highlightable.

RSHorizontalLineLayout on: shapes.

canvas @ RSCanvasController
```	
"
	^ self new highlightable! !

!RSLabeledTest commentStamp: ''!
A RSLabeledTest is a test class for testing the behavior of RSLabeled!
!RSLabeledTest methodsFor: 'tests' stamp: ''!
testFontSize

	| c shapes labels |
	c := RSCanvas new.

	shapes := (1 to: 100)
		          collect: [ :v | RSBox new model: v ]
		          as: RSGroup.

	c addAll: shapes.
	RSNormalizer size
		shapes: shapes;
		from: 10;
		to: 30;
		normalize: #yourself.
	RSGridLayout on: shapes.

	self assert: c numberOfShapes equals: 100.

	shapes @ (RSLabeled new fontSize: 8).
	self assert: c numberOfShapes equals: 200.
	
	"We check the size of the labels"
	labels := c shapes select: [ :s | s class == RSLabel ].
	self assert: labels size equals: 100.
	self assert: (labels allSatisfy: [ :s | s fontSize = 8 ])! !

!RSLayout commentStamp: ''!
TODO!
!RSLayout methodsFor: 'utilities' stamp: ''!
layerOf: aNode put: aValue
	aNode propertyAt: #layout put: aValue! !

!RSLayout methodsFor: 'accessing' stamp: ''!
translator
	^ translator! !

!RSLayout methodsFor: 'events' stamp: ''!
step! !

!RSLayout methodsFor: 'utilities' stamp: ''!
rOf: aNode put: aValue
	^ aNode propertyAt: #r put: aValue! !

!RSLayout methodsFor: 'utilities' stamp: ''!
thetaOf: aNode put: aValue
	^ aNode propertyAt: #theta put: aValue! !

!RSLayout methodsFor: 'hook' stamp: ''!
userDefinedEdges: edges
	"Do nothing"! !

!RSLayout methodsFor: 'utilities' stamp: ''!
fatherOf: aNode put: aValue
	aNode propertyAt: #father put: aValue! !

!RSLayout methodsFor: 'hook' stamp: ''!
executeOnElements: elements 
	"Execute the layout, myself, on the elements"
		
	self doInitialize: elements.
	self doExecute: elements asOrderedCollection.
	self doPost: elements.
! !

!RSLayout methodsFor: 'hook' stamp: ''!
on: elements edges: edges
	self applyOn: elements! !

!RSLayout methodsFor: 'utilities' stamp: ''!
rightContourOf: aNode
	^ aNode propertyAt: #rightContour! !

!RSLayout methodsFor: 'utilities' stamp: ''!
modOf: aNode put: aFloat
	aNode propertyAt: #mod put: aFloat
! !

!RSLayout methodsFor: 'hook' stamp: ''!
doInitialize: elements
	"Method executed before beginning the layout. Useful when the graph to be ordered need to be prepared"
	"self announce: (ROLayoutBegin new elements: elements)."! !

!RSLayout methodsFor: 'utilities' stamp: ''!
xOf: aNode put: aValue
	aNode propertyAt: #x put: aValue! !

!RSLayout methodsFor: 'utilities' stamp: ''!
pointerOf: aNode
	^ aNode propertyAt: #pointer! !

!RSLayout methodsFor: 'utilities' stamp: ''!
thetaOf: aNode
	^ aNode propertyAt: #theta ifAbsent: [ ^ 0 ]! !

!RSLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	translator := RSLayoutTranslator default! !

!RSLayout methodsFor: 'hook' stamp: ''!
doExecute: shapes
	"Performs the layout"

	self subclassResponsibility! !

!RSLayout methodsFor: 'utilities' stamp: ''!
leftContourOf: aNode put: aValue
	aNode propertyAt: #leftContour put: aValue! !

!RSLayout methodsFor: 'hook' stamp: ''!
on: elements
	self applyOn: elements! !

!RSLayout methodsFor: 'hook' stamp: ''!
doPost: elements
	"Method executed after performing the layout"
! !

!RSLayout methodsFor: 'testing' stamp: ''!
isEdgeDrivenLayout
	^ false! !

!RSLayout methodsFor: 'utilities' stamp: ''!
fatherOf: aNode
	^ aNode propertyAt: #father! !

!RSLayout methodsFor: 'utilities' stamp: ''!
rOf: aNode 
	^ aNode propertyAt: #r ifAbsent: [ 0 ]
	! !

!RSLayout methodsFor: 'hook' stamp: ''!
applyOn: elements
	"Return quickly if there is nothing to do"
	elements isEmpty ifTrue: [ ^ self ].
	self executeOnElements: elements! !

!RSLayout methodsFor: 'utilities' stamp: ''!
modOf: aNode
	^ aNode propertyAt: #mod ifAbsent: [ 0 ]
! !

!RSLayout methodsFor: 'utilities' stamp: ''!
layerOf: aNode
	^ aNode propertyAt: #layout! !

!RSLayout methodsFor: 'utilities' stamp: ''!
pointerOf: aNode put: aValue
	^ aNode propertyAt: #pointer put: aValue! !

!RSLayout methodsFor: 'accessing' stamp: ''!
translator: aTranslator
	translator := aTranslator! !

!RSLayout methodsFor: 'utilities' stamp: ''!
leftContourOf: aNode
	^ aNode propertyAt: #leftContour! !

!RSLayout methodsFor: 'utilities' stamp: ''!
xOf: aNode 
	^ aNode propertyAt: #x ifAbsent: [ 0 ]! !

!RSLayout methodsFor: 'utilities' stamp: ''!
rightContourOf: aNode put: aValue
	aNode propertyAt: #rightContour put: aValue! !

!RSLayout class methodsFor: 'public' stamp: ''!
onElement: aRoassalViewOrRoassalElement

	^ self on: aRoassalViewOrRoassalElement elements! !

!RSLayout class methodsFor: 'public' stamp: ''!
on: aCollection
	"main entry point of the class"
	
	"If aCollection is empty, then there is not much to do"
	aCollection isEmpty ifTrue: [ ^ aCollection ].
	self new applyOn: aCollection.
	^ aCollection! !

!RSLayout class methodsFor: 'public' stamp: ''!
isNotAbstract
	^ self isAbstract not! !

!RSLayout class methodsFor: 'public' stamp: ''!
isAbstract
	^ self name = #RSLayout! !

!RSLayout class methodsFor: 'public' stamp: ''!
on: elements edges: edges
	"To make all the layout polymorphic"
	
	^ self on: elements ! !

!RSLayout class methodsFor: 'public' stamp: ''!
onView: aRoassalView

	^ self on: aRoassalView elements! !

!RSLayoutBuilder commentStamp: ''!
RTLayoutBuilder is a higher abstract to manage layout. Most builder use it as it significantly shorten the use of layouts.!
!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
force
	^ layout := RSForceBasedLayout new! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
none
	layout := RSNoLayout new.
	^ layout! !

!RSLayoutBuilder methodsFor: 'accessing' stamp: ''!
layout
	^ layout ! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
sugiyama
	^ layout := RSSugiyamaLayout new.! !

!RSLayoutBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self flow.
	! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
horizontalTree
	^ layout := RSHorizontalTreeLayout new.! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
tidyTree
	"For example:
	
```
packages := RPackage organizer packages select: [ :pak | pak packageName beginsWith: 'Roassal3' ].
classes := packages flatCollect: #definedClasses.

m := RSMondrian new.
m nodes: classes.
m line connectFrom: #superclass.
m layout tidyTree.
m 
```"


	^ layout := RSConditionalLayout new
					 ifNotConnectedThen: RSGridLayout new;
					 else: (RSClusteringLayout new 
					    clustersLayout: RSFlowLayout new;
					    forEachLayout: RSTreeLayout new)! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
radial
	^ layout := RSRadialTreeLayout new.! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
vertical
	^ layout := RSVerticalLineLayout new.! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
on: shapes
	layout on: shapes! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
tree
	^ layout := RSTreeLayout new.! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
circle
	^ layout := RSCircleLayout new.! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
ifConnected: aLayout
	^ self ifConnected: aLayout ifNotConnected: RSGridLayout new! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
flow
	^ layout := RSFlowLayout new.! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
rawForce
	^ layout := RSForceBasedLayout new useProgressBar.! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
horizontalCompactTree

	^ layout := RSHorizontalVanDerPloegTreeLayout new! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
ifConnected: aLayout ifNotConnected: anotherLayout

	^ layout := RSConditionalLayout new
					 ifNotConnectedThen: anotherLayout;
					 else: aLayout! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
cluster
	^ layout := RSClusterLayout new.! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
horizontal
	^ layout := RSHorizontalLineLayout new.! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
cell
	^ layout := RSCellLayout new.! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
compactTree

	^ layout := RSVanDerPloegTreeLayout new! !

!RSLayoutBuilder methodsFor: 'public - layout' stamp: ''!
grid
	^ layout := RSGridLayout new.! !

!RSLayoutTest methodsFor: 'running' stamp: ''!
setUp
	| eb |
	super setUp.
	
	canvas := RSCanvas new.
	shapes := (1 to: 10) collect: [ :i | RSBox new size: 5; model: i ] as: RSGroup.
	canvas addAll: shapes.
	
	eb := RSLineBuilder line.
	eb canvas: canvas.
	eb shapes: shapes.
	eb connectFrom: [ :nb | nb // 2 ]
	
! !

!RSLayoutTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self ==  RSLayoutTest! !

!RSLayoutTranslator commentStamp: ''!
TODO!
!RSLayoutTranslator methodsFor: 'public - translating' stamp: ''!
translateTopLeftOf: element to: newPosition
	"Translate the top right corner of the element"

	self translate: element to: newPosition direction: 1 @ 1! !

!RSLayoutTranslator methodsFor: 'hook' stamp: ''!
translate: element to: newPosition
	"Translate of the center of the element"
	self subclassResponsibility ! !

!RSLayoutTranslator methodsFor: 'public - translating' stamp: ''!
translateBottomLeftOf: element to: newPosition
	"Translate the bottom left corner of the element"

	self translate: element to: newPosition direction: 1 @ -1.! !

!RSLayoutTranslator methodsFor: 'public - translating' stamp: ''!
translate: element to: newPosition direction: aDirection
	"Translate the bottom left corner of the element"

	self translate: element to: newPosition + (element extent / 2 * aDirection)! !

!RSLayoutTranslator methodsFor: 'public - translating' stamp: ''!
translateCenterLeftOf: element to: newPosition
	"Translate the left center of the element to newPosition"

	self translate: element to: newPosition direction: 1 @ 0! !

!RSLayoutTranslator methodsFor: 'hook' stamp: ''!
translate: element by: deltaPosition
	"Translate of the center of the element by a step"
	self translate: element to: element position + deltaPosition! !

!RSLayoutTranslator class methodsFor: 'accessing' stamp: ''!
defaultClass
	^ self allSubclasses detect: #isDefault! !

!RSLayoutTranslator class methodsFor: 'accessing' stamp: ''!
default
	"Return the default translator, the one used in the layouts"

	defaultTranslator ifNotNil: [ ^ defaultTranslator ].
	^ defaultTranslator := self defaultClass new! !

!RSLayoutTranslator class methodsFor: 'testing' stamp: ''!
isDefault
	^ false! !

!RSLegend commentStamp: ''!
I am an handy class to build legend in a visualization

```Smalltalk
scale := NSScale ordinalColored: 4.

values := { 'Bonjour' . 'Guten Morgen' . 'Hello' . 'Hola' }.
c := RSCanvas new.
c @ RSCanvasController.
1 to: 20 do: [ :i |
	txt := values atRandom.
	c add: (RSLabel new text: txt; color: (scale scale: txt)).
].
RSFlowLayout on: c shapes.


legend := RSLegend new.
legend container: c.
legend title: 'Color legend'.
legend text: 'French' withBoxColor: (scale scale: values first).
legend text: 'German' withBoxColor: (scale scale: values second).
legend text: 'English' withBoxColor: (scale scale: values third).
legend text: 'Espagnol' withBoxColor: (scale scale: values fourth).
legend build.

c
```!
!RSLegend methodsFor: 'hooks' stamp: ''!
renderOnDemandIn: aCanvas
	| i legendLabels update |
	menuShape isFixed: true.
	aCanvas addShape: menuShape.
	i := RSAnimatedPopup new.
	i shapeBuilder: [ self legend ].
	menuShape @ i.
	legendLabels := nil.
	update := [ 
		RSHorizontalLineLayout on: legendLabels.
		RSLocation new
			inner; top; right;
			offset: -5 @ 5;
			move: legendLabels
				on: aCanvas basicRectangle.
	].
	legendLabels := aCanvas propertyAt: #legendLabels
		ifAbsentPut: [ 
			aCanvas when: RSExtentChangedEvent do: update.
			RSGroup new: 5 ].
	legendLabels add: menuShape.
	update value.

	! !

!RSLegend methodsFor: 'public' stamp: ''!
onDemand
	^ self onDemand: 'Help'.! !

!RSLegend methodsFor: 'public' stamp: ''!
legendDo: aBlock
	legendBlock := aBlock! !

!RSLegend methodsFor: 'public - specific' stamp: ''!
text: aString withFadingRamp: ramp
	| gradient s |
	"very specific shape"
	gradient := LinearGradientPaint fromArray: ramp.
	gradient start: -20@0; stop: 20@0.
	s := RSBox new
		extent: 40@20;
		paint: gradient;
		yourself.
	^ self text: aString withShape: s.
	! !

!RSLegend methodsFor: 'public - specific' stamp: ''!
customText: anObject shape: aShape
	| shape |
	"general propuse, you can add and define anything in aShape to be a legend"
	shape := aShape copy text: anObject.
	shapes add: shape.
	^ shape.! !

!RSLegend methodsFor: 'accessing' stamp: ''!
defaultCircle
	^ defaultCircle ifNil: [ defaultCircle := RSEllipse new size: 15. ]! !

!RSLegend methodsFor: 'hooks' stamp: ''!
basicRenderIn: aCanvas
	| legend |
	legend := self legend.
	location move: legend on: aCanvas shapes.
	aCanvas addShape: legend.! !

!RSLegend methodsFor: 'accessing' stamp: ''!
location
	^ location! !

!RSLegend methodsFor: 'hooks' stamp: ''!
renderIn: aCanvas
	self isOnDemand 
		ifTrue: [ self renderOnDemandIn: aCanvas ]
		ifFalse: [self basicRenderIn: aCanvas ].
	! !

!RSLegend methodsFor: 'accessing' stamp: ''!
legend
	| legend |
	layout on: self shapes.
	legend := RSComposite new
		shapes: self shapes;
		yourself.
	legendBlock value: legend.
	^ legend! !

!RSLegend methodsFor: 'public' stamp: ''!
withFrame
	"Set a frame around the legend"
	self legendDo: [ :l |
		l 
			border: RSBorder new;
			color: (Color white alpha: 0.8);
			padding: 10.
		].! !

!RSLegend methodsFor: 'public' stamp: ''!
text: aString withShape: aShape
	| text tshapes line l |
	text := self defaultLabel copy.
	text text: aString.
	tshapes := RSGroup with: aShape with: text.
	l := RSHorizontalLineLayout new alignMiddle.
	l on: tshapes.
	line := RSComposite new
		shapes: tshapes;
		yourself.
	self shapes add: line.
	^ line! !

!RSLegend methodsFor: 'public' stamp: ''!
text: aString withCircleColor: color
	^ self text: aString withShape: (self shape: self defaultCircle withColor: color).! !

!RSLegend methodsFor: 'utilities' stamp: ''!
shape: aShape withColor: color
	| copy |
	copy := aShape copy.
	copy color: (color rsValue: copy).
	^ copy! !

!RSLegend methodsFor: 'initialization' stamp: ''!
reset
	legendBlock := [ :l | l draggable ].
	shapes := RSGroup new.
	location := RSLocation new below.
	layout := RSLayoutBuilder new.
	layout vertical gapSize: 0.
	defaultBox := defaultCircle := defaultLabel := defaultTitle := nil.
	
		
	! !

!RSLegend methodsFor: 'accessing' stamp: ''!
defaultTitle: aShape
	defaultTitle := aShape! !

!RSLegend methodsFor: 'accessing' stamp: ''!
defaultLabel
	^ defaultLabel ifNil: [ defaultLabel := RSLabel new ].! !

!RSLegend methodsFor: 'layout' stamp: ''!
layout 
	^ layout! !

!RSLegend methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self reset.! !

!RSLegend methodsFor: 'accessing' stamp: ''!
menuShape
	^ menuShape! !

!RSLegend methodsFor: 'public' stamp: ''!
text: aString
	^ self customText: aString shape: self defaultLabel! !

!RSLegend methodsFor: 'public' stamp: ''!
title: aString
	^ self customText: aString shape: self defaultTitle! !

!RSLegend methodsFor: 'public' stamp: ''!
text: aString description: desc
	| text tshapes line l d|
	text := self defaultBoldText copy.
	text text: aString.
	d := self defaultLabel copy text: desc.
	tshapes := RSGroup with: text with: d.
	l := RSHorizontalLineLayout new alignMiddle.
	l on: tshapes.
	line := RSComposite new
		shapes: tshapes;
		yourself.
	self shapes add: line.
	^ line! !

!RSLegend methodsFor: 'accessing' stamp: ''!
defaultBox
	^ defaultBox ifNil: [ defaultBox := RSBox new size: 15 ].! !

!RSLegend methodsFor: 'public - specific' stamp: ''!
polymetricWidth: labelWidth height: labelHeight box: labelBox
	"very very specific shape"
	| box s marker line g l1 l2 l3 line1 line2  |
	box := RSBox new
		size: 100.
	marker := RSShapeFactory triangle
		color: Color black;
		size: 5.
	line := RSLine new 
		marker: marker;
		yourself.
	g := RSGroup new.
	l1 := defaultLabel copy text: labelWidth.
	l2 := defaultLabel copy text: labelHeight.
	l3 := defaultLabel copy text: labelBox.
	l1 position: 0@70.
	l3 scaleBy: 90/ l3 width.
	l2 position: l2 width / 2 negated - 60 @ 0.
	line1 := line copy startPoint:  -50@60; endPoint: 50@60.
	line2 := line copy startPoint: -60@ -50; endPoint: -60@ 50.
	g addAll: {box. l1. l2. l3. line1. line2 }.
	s := RSComposite new
		shapes: g.
	self shapes add: s.
	
! !

!RSLegend methodsFor: 'accessing' stamp: ''!
defaultTitle
	^ defaultTitle ifNil: [ defaultTitle := RSLabel new bold.
		defaultTitle fontSize: defaultTitle fontSize * 1.2.
		defaultTitle ].! !

!RSLegend methodsFor: 'public' stamp: ''!
text: aString withBoxColor: color
	^ self text: aString withShape: (self shape: self defaultBox withColor: color).! !

!RSLegend methodsFor: 'public' stamp: ''!
onDemand: text
	^ menuShape := RSLabel new
		text: text;
		color: Color lightGray;
		@ (RSHighlightable new lowColor: Color lightGray highColor: Color blue);
		yourself! !

!RSLegend methodsFor: 'testing' stamp: ''!
isOnDemand
	^ menuShape notNil! !

!RSLegend methodsFor: 'accessing' stamp: ''!
defaultBoldText
	^ defaultBoldText ifNil: [ defaultBoldText := RSLabel new bold ].! !

!RSLegend methodsFor: 'accessing' stamp: ''!
defaultLabel: aShape
	defaultLabel := aShape! !

!RSLine commentStamp: ''!
RSLine describes a line. A line typically links two shapes.

Here is an example:

-=-=-=-=
| c from to l |
c := RSCanvas new.

from := RSBox new size: 30.
to := RSEllipse new size: 30.

from @ RSDraggable.
to @ RSDraggable.

c add: from.
c add: to.

l := RSLine new.
l attachPoint: RSCenteredAttachPoint new.
l from: from.
l to: to.
c add: l.

to translateBy: 50 @ 40.

c @ RSCanvasController.
c
-=-=-=-=

Adding single line can be complex in some situation. You may want to look at RSEdgeBuilder to ease the edge creation. !
!RSLine methodsFor: 'testing' stamp: ''!
basicIncludesPoint: aPoint
	^ aPoint
		onLineFrom: self startPoint 
		to: self endPoint 
		within: self includedRadius! !

!RSLine methodsFor: 'visiting' stamp: ''!
buildPathOn: visitor
	visitor buildLinePath: self! !

!RSLineBuilder commentStamp: ''!
`RSLineBuilder` offers an API to easily build lines.

Here is an example:
```Smalltalk
c := RSCanvas new.

classes := Collection withAllSubclasses.
boxes := classes collect: [ :cls |
				RSBox new
					width: (cls instVarNames size * 5 max: 5);
					height: (cls numberOfMethods max: 5);
					model: cls;
					yourself ] as: RSGroup.


boxes @ RSDraggable.
c addAll: boxes.

RSEdgeBuilder orthoVertical
	canvas: c;
	attachPoint: RSVerticalAttachPoint new;
	shapes: boxes;
	connectFrom: #superclass.

RSTreeLayout on: c nodes.
c @ RSCanvasController.
c open
```

Another example:
```Smalltalk
c := RSCanvas new.

shapes := RSCircle models: (30 to: 50) size: [ :nb | nb ]. 

c addAll: shapes.

lines := RSEdgeBuilder line
	canvas: c;
	connectFrom: 30 toAll: (31 to: 50).

lines do: [ :l | l attachPoint: (RSHorizontalAttachPoint new) ].

RSGridLayout on: shapes. 
RSLocation new
	above;
	move: shapes first on: shapes allButFirst.
shapes @ RSDraggable.

c @ RSCanvasController.
c open
```

Another example:
```
classes := Collection withAllSubclasses.

c := RSCanvas new.

boxes := RSCircle models: classes.
c addAll: boxes. 
RSFlowLayout on: c shapes.

lb := RSLineBuilder orthoVertical.
lb withVerticalAttachPoint.
lb capRound.
lb shapes: boxes.
lb connectFrom: #superclass.

RSTreeLayout on: c nodes.

boxes @ RSPopup.
RSNormalizer color
	shapes: boxes;
	from: #gray; to: #red;
	normalize: #numberOfMethods.

c @ RSCanvasController.
c open
```!
!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
color: aColor
	self shape color: aColor! !

!RSLineBuilder methodsFor: 'public - line' stamp: ''!
connectFrom: aBlockOrASymbol
	"Connect each shapes with the shapes for which the model matches aBlockOrASymbol"
	^ self connectFrom: aBlockOrASymbol to: [ :each | each ]! !

!RSLineBuilder methodsFor: 'public - attach point' stamp: ''!
withBorderAttachPoint
	"Make the produced line use a border attach point. For example:
-=-=-=-=-=-=-=-=-=-=
c := RSCanvas new.

from := RSBox new size: 30; model: 'from'.
to := RSEllipse new size: 30; model: 'to'.

c add: from.
c add: to.

RSEdgeBuilder line
	canvas: c;
	withBorderAttachPoint;
	connectFrom: 'from' to: 'to'.


from @ RSDraggable.
to @ RSDraggable.

to translateTo: 50 @ 40.

c @ RSCanvasController
-=-=-=-=-=-=-=-=-=-=
	"
	self attachPoint: RSBorderAttachPoint new.! !

!RSLineBuilder methodsFor: 'public - attach point' stamp: ''!
withVerticalAttachPoint
	"Make the produced line use a vertical attach point. For example:
```
c := RSCanvas new.

from := RSBox new size: 30; model: 'from'.
to := RSEllipse new size: 30; model: 'to'.

c add: from.
c add: to.

RSEdgeBuilder line
	canvas: c;
	withVerticalAttachPoint;
	connectFrom: 'from' to: 'to'.


from @ RSDraggable.
to @ RSDraggable.

to translateTo: 50 @ 40.

c @ RSCanvasController
```
	"
	self attachPoint: RSVerticalAttachPoint new.! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
moveBehind
	"Set the builder as such that edge that are built and added in the view _behind_ the extremities of each edges"
	shouldMoveBehind := true! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
borderColor: aColor
	self shape borderColor: aColor! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
object: anObject
	^ self objects: (Array with: anObject)! !

!RSLineBuilder methodsFor: 'public - source' stamp: ''!
source: objects connectFromAll: fromBlock to: toBlock
	"Define some edges from objects that are not part of the view
	
nbOfNodes := 40.
nbOfRandomEdges := 40.

nodes := 1 to: nbOfNodes.
edges := (1 to: nbOfRandomEdges) 
				collect: [ :notUsed | {nodes atRandom . nodes atRandom} -> nodes atRandom ].

b := RSCanvas new .

b addAll: (nodes collect: [ :n|
	RSEllipse new
		model: n;
		size: 5;
		color: (Color black alpha: 0.5)]).

RSEdgeBuilder line
	color: (Color gray alpha: 0.3);
	canvas: b;
	source: edges connectFromAll: #key to: #value.

RSForceBasedLayout on: b nodes.
b"
	| assocs allObjects |
	allObjects := Set new.

	assocs := objects flatCollect: [ :o | 
		| cc |
		cc := fromBlock rsValue: o.
		cc collect: [ :ccc | 
			| t |
			t := toBlock rsValue: o.
			allObjects add: ccc; add: t.
			ccc -> t ] ].
	self objects: allObjects asArray.
	^ self useAssociations: assocs! !

!RSLineBuilder methodsFor: 'public - line' stamp: ''!
connectFrom: aFromBlock to: aBlockOrASymbol
	| toShape fromShape |
	self resetCreatedEdges.
	self fromShapes copy do: [ :e | 
			fromShape := self fromShapes shapeFromModel: (aFromBlock rsValue: e model).
			toShape := self toShapes shapeFromModel: (aBlockOrASymbol rsValue: e model).
			toShape ifNotNil: [ self createEdgeIfNecessaryFrom: fromShape to: toShape ] ].
	self moveBehindIfNecessary: createdEdges.
	^ createdEdges! !

!RSLineBuilder methodsFor: 'public - line' stamp: ''!
connectFrom: aFromBlock toAll: aBlockOrASymbol
	"Define edges from a particular shape to another set of shapes. For example:

```
c := RSCanvas new.

shapes := (30 to: 50) collect: [ :nb |
	RSEllipse new size: nb; model: nb; yourself.
	 ] as: RSGroup.

c addAll: shapes.

RSEdgeBuilder line
	canvas: c;
	withBorderAttachPoint;
	connectFrom: 30 toAll: (31 to: 50).


RSGridLayout on: shapes. 
RSLocation new
	above;
	move: shapes first on: shapes allButFirst.
shapes @ RSDraggable.

c @ RSCanvasController.
c open
```
	"

	| fromElement tes |
	self resetCreatedEdges.
	self fromShapes copy do: [ :e | 
		fromElement := self fromShapes shapeFromModel: (aFromBlock rsValue: e model).
		tes := self toShapes shapesFromModels: (aBlockOrASymbol rsValue: e model).
		tes ifNotNil: [ 
			tes do: [ :toE | 
				self createEdgeIfNecessaryFrom: fromElement to: toE ] ] ].
	self moveBehindIfNecessary: createdEdges.
	^ createdEdges ! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
toShapes
	toShapes ifNil: [ ^ self canvasNodes ].
	^ toShapes! !

!RSLineBuilder methodsFor: 'public - associations' stamp: ''!
useElementAssociations: associationsBetweenElements
	associationsBetweenElements do: [ :assoc |
		self edgeFrom: assoc key to: assoc value ]! !

!RSLineBuilder methodsFor: 'private - utility' stamp: ''!
edgeFrom: source to: target 
	"source and target are elements"
	| line |
	line := self shape copy
		model: source model -> target model;
		from: source;
		to: target;
		resetMarkers;
		markerStart: self shape markerStart copy;
		markerMid: self shape markerMid copy;
		markerEnd: self shape markerEnd copy;
		border: self shape border copy;
		yourself.
	self canvas ifNotNil: [ canvas add: line ].
	^ line! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
shape: aRSShape
	"Set the shape used to build edges"
	self assert: [ aRSShape isLine ] description: 'Only a line can be provided to a line builder'.
	shape := aRSShape! !

!RSLineBuilder methodsFor: 'public - configuration' stamp: ''!
beDirectional
	"When lines are created, this allow for having lines going from A to B, and from B to A"
	beDirectional := true! !

!RSLineBuilder methodsFor: 'public - source' stamp: ''!
source: objects connectFrom: fromblock to: toBlock
	"Define some edges from objects that are not part of the canvas"
	"
	nbOfNodes := 40.
nbOfRandomEdges := 40.

nodes := 1 to: nbOfNodes.
edges := (1 to: nbOfRandomEdges) 
				collect: [ :notUsed | nodes atRandom -> nodes atRandom ].

b := RSCanvas new .

b addAll: (nodes collect: [ :n|
	RSEllipse new
		model: n;
		size: 5;
		color: (Color black alpha: 0.5)]).

RSEdgeBuilder line
	color: (Color gray alpha: 0.3);
	canvas: b;
	source: edges connectFrom: #key to: #value.

RSForceBasedLayout on: b nodes.
b"
	| assocs allObjects |
	self assert: [ objects notNil ] description: 'Cannot provide a nil value as the source'.
	self assert: [ objects isCollection ] description: 'Need to provide a collection as the source'.
	allObjects := Set new.
	
	assocs := objects collect: [ :o | 
		| f t |
		f := fromblock rsValue: o.
		t := toBlock rsValue: o.
		allObjects add: f; add: t.
		f -> t ].
	self objects: allObjects asArray.
	^ self useAssociations: assocs! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
format: aString
	
	"want more markers? submit a new issue in roassal3"
	| marker bs |
	marker := RSShapeFactory shapeFromString: aString.
	bs := RSStrokeStyle fromString: aString.
	marker ifNotNil: [ self shape marker: marker ].
	! !

!RSLineBuilder methodsFor: 'public - line' stamp: ''!
arrowMarkerEnd

	self markerEnd: (RSShapeFactory arrow size: 10; color: self shape color)! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
toObjects: someObjectsOrABlock
	"Identify the elements we are considering for the edge building process. Note that the view has to be set beforehand."
	self assert: [ canvasHasBeenManuallySet ] description: 'A view has to be set, please use #view:'.
	 
	(someObjectsOrABlock isCollection and: [ someObjectsOrABlock isSymbol not ])
		ifTrue: [ self toShapes: (canvas shapesFromModels: someObjectsOrABlock) ]
		ifFalse: [ self toShapes: (canvas nodes select: [ :el | someObjectsOrABlock rsValue: el model ]) ]! !

!RSLineBuilder methodsFor: 'public - associations' stamp: ''!
useAssociation: assoc
	"assoc have to be between model objects"
	| result |
	self assert: [ assoc isKindOf: Association ] description: 'Please, provide an association instead'.
	
	result := self useAssociations: (Array with: assoc).
	result ifEmpty: [ ^ nil ].
	^ result first! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
border
	^ self shape border! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
fmt: aString
	self shape fmt: aString.! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
width
	^ self shape border width! !

!RSLineBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self noRepetition.
	shouldMoveBehind := false.
	
	"The view has to be explicitly set by the end-user"
	canvasHasBeenManuallySet := false.
	"We could have edges from A to B, and from B to A"
	self beDirectional.! !

!RSLineBuilder methodsFor: 'public - configuration' stamp: ''!
makeBidirectional
	"When lines are created, this method does not allow for having lines going from A to B, and from B to A. Only A to B, __OR__, B to A is created"
	beDirectional := false! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
controlPointsController: aCPController
	self shape controlPointsController: aCPController! !

!RSLineBuilder methodsFor: 'public - attach point' stamp: ''!
attachPoint
	^ self shape attachPoint! !

!RSLineBuilder methodsFor: 'private - utility' stamp: ''!
moveBehindIfNecessary: someEdges
	shouldMoveBehind ifFalse: [ ^ self ].
	someEdges pushBack! !

!RSLineBuilder methodsFor: 'public - configuration' stamp: ''!
noRepetition
	"Avoid having more than one edge between two elements

```
b := RSMondrian new.
b nodes: (1 to: 3).
b line
		color: Color red translucent;
		withVerticalAttachPoint;
		noRepetition; 
		useAssociations: { 1 -> 2 . 2 -> 3 . 1 -> 2}.
b layout grid.
b build.
b canvas numberOfEdges
```
	"
	allowRepetition := false! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
shapes: someShapes
	"This method is used to provide a set of Roassal shapes. Models will be looked up in these elements"
	self assert: [ someShapes isCollection ] description: 'Must provide a collection'.
	self assert: [ someShapes allSatisfy: [ :obj | obj class inheritsFrom: RSShape ] ] description: 'Must provide a collection of Roassal shapes'.
	self assert: [ someShapes allSatisfy: #hasModel ] description: 'All shapes must have a model'.
	 
	self toShapes: someShapes.
	self fromShapes: someShapes! !

!RSLineBuilder methodsFor: 'public - configuration' stamp: ''!
noBidirectional
	"When lines are created, this method does not allow for having lines going from A to B, and from B to A. Only A to B, __OR__, B to A is created"
	beDirectional := false! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
toObjects
	"Return the list of objects considered as sources for the edges"
	^ self toShapes collect: #model! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
marker: aMarker
	self shape marker: aMarker! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
fromObjects: someObjectsOrABlock
	"Identify the elements we are considering for the edge building process. Note that the view has to be set beforehand."
	self assert: [ canvasHasBeenManuallySet ] description: 'A canvas has to be set, please use #canvas: before'.
	 
	(someObjectsOrABlock isCollection and: [ someObjectsOrABlock isSymbol not ])
		ifTrue: [ self fromShapes: (canvas shapesFromModels: someObjectsOrABlock) ]
		ifFalse: [ self fromShapes: (canvas nodes select: [ :el | someObjectsOrABlock rsValue: el model ]) ]! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
paint: aPaint
	self shape paint: aPaint! !

!RSLineBuilder methodsFor: 'public - line' stamp: ''!
connectToAll: aBlockOrASymbol
	"Should this method use connectFrom:ToAll: ?????"
	| tmptoElements |
	self resetCreatedEdges.
	self fromShapes copy do: [ :e | 
		tmptoElements := self toShapes shapesFromModels: (aBlockOrASymbol rsValue: e model).
		tmptoElements ifNotNil: [ 
			tmptoElements do: [ :toE | 
				self createEdgeIfNecessaryFrom: e to: toE ] ] ].
	self moveBehindIfNecessary: createdEdges.
	^ createdEdges! !

!RSLineBuilder methodsFor: 'public - attach point' stamp: ''!
attachPoint: anAttachPoint
	self shape attachPoint: anAttachPoint! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
joinRound
	self shape joinRound! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
cornerRadii: aNumber
	^ self shape cornerRadii: aNumber! !

!RSLineBuilder methodsFor: 'public - attach point' stamp: ''!
withHorizontalAttachPoint
	"Make the produced line use a vertical attach point. For example:
-=-=-=-=-=-=-=-=-=-=
c := RSCanvas new.

from := RSBox new size: 30; model: 'from'.
to := RSEllipse new size: 30; model: 'to'.

c add: from.
c add: to.

RSEdgeBuilder line
	canvas: c;
	withHorizontalAttachPoint;
	connectFrom: 'from' to: 'to'.


from @ RSDraggable.
to @ RSDraggable.

to translateTo: 50 @ 40.

c @ RSCanvasController
-=-=-=-=-=-=-=-=-=-=
	"
	self attachPoint: RSHorizontalAttachPoint new.! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
addInteraction: anInteraction
	self shape addInteraction: anInteraction! !

!RSLineBuilder methodsFor: 'testing' stamp: ''!
shouldCreateEdgeFrom: fromShape to: toShape
	"Return true if an edge has to be created"
	fromShape == toShape ifTrue: [ ^ false ].
	(fromShape isNil or: [ toShape isNil ]) ifTrue: [ ^ false ].
	beDirectional ifFalse: [ ^ (toShape isDirectlyConnectedTo: fromShape) not ].
	allowRepetition ifFalse: [ ^ fromShape outgoingLines noneSatisfy: [ :edge | edge to == toShape ] ].
	^ true! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
canvas: aCanvas
	"Provide a reference to the Roassal canvas in which (i) shapes will be looked up and (ii) lines will be added"
	canvasHasBeenManuallySet := true.
	canvas := aCanvas! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
markerEnd: aMarker
	self shape markerEnd: aMarker! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
noBorder
	self shape noBorder! !

!RSLineBuilder methodsFor: 'public - associations' stamp: ''!
useAssociations: associations
	"Draw edges between shapes using associations. Each association has to follow the pattern: startmodel -> endmodel
	
For example
```
b := RSCanvas  new.
b addAll: (RSCircle models: (1 to: 3)).

RSLineBuilder line
	color: Color red translucent;
	canvas: b;
	withVerticalAttachPoint;
	noRepetition;
	useAssociations: { 1 -> 2 . 2 -> 3 . 1 -> 2}.
RSForceBasedLayout on: b nodes.

b @ RSCanvasController.
b open
```
"
	| fromElement toElement |
	createdEdges := RSGroup new.
	associations do: [ :assoc |
		fromElement := self fromShapes shapeFromModel: assoc key.
		toElement := self toShapes shapeFromModel: assoc value.
		(fromElement notNil and: [ toElement notNil ])
			ifTrue: [ self createEdgeIfNecessaryFrom: fromElement to: toElement ] ].
	self moveBehindIfNecessary: createdEdges.
	^ createdEdges! !

!RSLineBuilder methodsFor: 'public - line' stamp: ''!
connectTo: aBlockOrASymbol
	^ self connectFrom: [ :each | each ] to: aBlockOrASymbol! !

!RSLineBuilder methodsFor: 'public - line' stamp: ''!
connectFromAll: aFromBlockOrSymbol to: aBlockOrASymbol

	| toElement tfromElements |
	self resetCreatedEdges.
	self fromShapes copy do: [ :e | 
		tfromElements := self fromShapes shapesFromModels: (aFromBlockOrSymbol rsValue: e model). 
		toElement := self toShapes shapeFromModel: (aBlockOrASymbol rsValue: e model).
		tfromElements ifNotNil: [ 
			tfromElements do: [ :fromElement | 
				self createEdgeIfNecessaryFrom: fromElement to: toElement ] ] ].
	self moveBehindIfNecessary: createdEdges.
	^ createdEdges! !

!RSLineBuilder methodsFor: 'public - repetition' stamp: ''!
shouldAllowRepetition
	^ allowRepetition! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
markerStart: aMarker
	self shape markerStart: aMarker! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
canvas
	"Return the canvas if it was manually set using #canvas: or infer it from the shapes added to the builder"
	(canvas isNil and: [ fromShapes notNil ]) ifTrue: [ canvas := fromShapes anyOne canvas ].
	
	^ canvas! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
toShapes: someShapes
	toShapes := someShapes asGroup! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
dashed
	self shape dashed! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
width: aNumber
	"Set the width of the line. For example:
	
-=-=-=-=-=-=-=-=-=-=
c := RSCanvas new.

from := RSBox new size: 30; model: 'from'.
to := RSEllipse new size: 30; model: 'to'.

c add: from.
c add: to.

RSEdgeBuilder line
	canvas: c;
	width: 10;
	connectFrom: 'from' to: 'to'.


from @ RSDraggable.
to @ RSDraggable.

to translateTo: 50 @ 40.

c @ RSCanvasController
-=-=-=-=-=-=-=-=-=-=
	"
	self shape width: aNumber! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
fromObjects
	"Return the list of objects considered as targets for the edges"
	^ self fromShapes collect: #model! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
capRound
	self shape capRound! !

!RSLineBuilder methodsFor: 'testing' stamp: ''!
isBidirectional
	"Return true or false, indicating whether the edge builder is bidirectional or not (i.e., if 
	edges from A to B, __and__ B to A can be created"
	^ beDirectional ! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
controlPointsController
	^ self shape controlPointsController! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
fromShapes
	fromShapes ifNil: [ ^ self canvasNodes select: #hasModel ].
	^ fromShapes! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
border: aBorder
	self shape border: aBorder! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
shape
	^ shape! !

!RSLineBuilder methodsFor: 'private - utility' stamp: ''!
createEdgeIfNecessaryFrom: fromShape to: toShape
	"This is a private method. Create, if necessary, an edge between two elements"
	(self shouldCreateEdgeFrom: fromShape to: toShape)
		ifTrue: [ createdEdges add: (self edgeFrom: fromShape to: toShape) ]! !

!RSLineBuilder methodsFor: 'private - utility' stamp: ''!
resetCreatedEdges
	createdEdges := RSGroup new! !

!RSLineBuilder methodsFor: 'public - source' stamp: ''!
source: objects connectFrom: fromblock toAll: toBlock
	"Define some edges from objects that are not part of the view
	
nbOfNodes := 40.
nbOfRandomEdges := 40.

nodes := 1 to: nbOfNodes.
edges := (1 to: nbOfRandomEdges) 
				collect: [ :notUsed | nodes atRandom -> {nodes atRandom . nodes atRandom} ].

b := RSCanvas new .

b addAll: (nodes collect: [ :n|
	RSEllipse new
		model: n;
		size: 5;
		color: (Color black alpha: 0.5)]).

RSEdgeBuilder line
	color: (Color gray alpha: 0.3);
	canvas: b;
	source: edges connectFrom: #key toAll: #value.

RSForceBasedLayout on: b nodes.
b"
	| assocs allObjects |
	allObjects := Set new.

	assocs := objects flatCollect: [ :o | 
		| cc |
		cc := toBlock rsValue: o.
		cc collect: [ :ccc | 
			| t |
			t := fromblock rsValue: o.
			allObjects add: t; add: ccc.
			t -> ccc ] ].
	self objects: allObjects asArray.
	^ self useAssociations: assocs! !

!RSLineBuilder methodsFor: 'attach point' stamp: ''!
startAttachPoint: startAttachPoint endAttachPoint: endAttachPoint

	| controller |
	controller := RSStartEndCPAPController new
		              controller: self controlPointsController;
		              startAttachPoint: startAttachPoint;
		              endAttachPoint: endAttachPoint;
		              yourself.
	self controlPointsController: controller! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
objects: someObjectsOrABlock
	"Identify the elements we are considering for the edge building process. Note that the view has to be set beforehand."
	self assert: [ canvasHasBeenManuallySet ] description: 'A view has to be set, please use #view:'.
	self toObjects: someObjectsOrABlock.
	self fromObjects: someObjectsOrABlock.! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
toObject: anObject
	^ self toObjects: (Array with: anObject)! !

!RSLineBuilder methodsFor: 'public - line' stamp: ''!
connectFromAll: aFromBlockOrSymbol
	^ self connectFromAll: aFromBlockOrSymbol to: [ :each | each ]
! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
canvasNodes
	"Return the nodes of the canvas"
	canvas ifNil: [ ^ #() ].
	^ canvas nodes! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
dashArray: anArray
	^ self shape dashArray: anArray! !

!RSLineBuilder methodsFor: 'public - shape' stamp: ''!
markerStartEnd: aMarker
	self shape markerStartEnd: aMarker! !

!RSLineBuilder methodsFor: 'accessing' stamp: ''!
fromShapes: someShapes
	self assert: [ someShapes isCollection ].
	self assert: [ someShapes allSatisfy: [ :s | s class inheritsFrom: RSShape ] ] description: 'Need to provide a collection of RSShape'.
	self assert: [ someShapes allSatisfy: #hasModel ] description: 'All shapes must have a model, else lines cannot be properly defined'.
	fromShapes := someShapes asGroup! !

!RSLineBuilder methodsFor: 'public - repetition' stamp: ''!
allowRepetition
	allowRepetition := true! !

!RSLineBuilder class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
new
	^ self error: 'Should not use #new to create an edge builder. Instead, use a #line, #arrowedLine.'! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
polyline
	^ self new: RSPolyline new! !

!RSLineBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSLineBuilder class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSLineBuilder class methodsFor: '*Roassal3-Sunburst' stamp: ''!
sunburstBezier
	^ self bezier
		controlPointsController: RSSunburstCPController new;
		yourself.
	! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
arrowedLineWithOffset
	^ self arrowedLineWithOffset: 0.2! !

!RSLineBuilder class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
horizontalLine: aShape
	^ (self new: aShape)
		controlPointsController: RSHorizontalCPAPController new;
		yourself.
	! !

!RSLineBuilder class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSLineBuilder class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
arrowedDirectedBezier
	| marker ext |
	ext := 15 @ 20.
	marker := RSShapeFactory triangle
		extent: ext;
		withBorder;
		asMarker.
	marker offset: ext y / 2.
	
	^ self directedBezier
		markerEnd: marker;
		attachPoint: (RSBorderAttachPoint new endOffset: 0);
		yourself! !

!RSLineBuilder class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
line
	^ self new: RSLine new! !

!RSLineBuilder class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSLineBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSLineBuilder class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSLineBuilder class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
horizontalBezier
	^ self horizontalLine: RSBezier new! !

!RSLineBuilder class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSLineBuilder class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
arrowedLineWithOffset: aFloat
	"[0, 1] value"
	| inst |
	inst := self arrowedLine.
	inst shape markerEnd offsetRatio: aFloat.
	^ inst! !

!RSLineBuilder class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSLineBuilder class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSLineBuilder class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSLineBuilder class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSLineBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
arrowedLine
	^ self new: RSShapeFactory arrowedLine! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
verticalBezier
	^ self verticalLine: RSBezier new! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
verticalLine: aShape
	^ (self new: aShape)
		controlPointsController: RSVerticalCPAPController new;
		yourself.
	! !

!RSLineBuilder class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSLineBuilder class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSLineBuilder class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
bezier
	^ self new: RSBezier new! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
orthoHorizontal
	^ self horizontalLine: RSPolyline new.! !

!RSLineBuilder class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RSLineBuilder class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RSLineBuilder class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RSLineBuilder class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
new: aRSShape
	 ^ super new 
		shape: aRSShape;
		yourself
		! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
orthoVertical
	^ self verticalLine: RSPolyline new.! !

!RSLineBuilder class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSLineBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSLineBuilder class methodsFor: 'instance creation' stamp: ''!
directedBezier
	^ (self new: RSBezier new)
		controlPointsController: RSDirectedBezierCPAPController new;
		yourself! !

!RSLineBuilder class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSLineBuilder class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSLineChartPopupBuilder commentStamp: ''!
TODO!
!RSLineChartPopupBuilder methodsFor: 'hooks' stamp: ''!
shapeFor: aRSChart
	| plots |
	plots := aRSChart plots select: #isLinePlot.
	plots := plots 
		collect: [ :plot | self rowShapeFor: plot ]
		as: RSGroup.
	plots := plots reject: #isNil.
	RSVerticalLineLayout new gapSize: 0; on: plots.
	^ plots asShape
		padding: 10;
		color: (Color white alpha: 0.8);
		withBorder;
		yourself.! !

!RSLineChartPopupBuilder methodsFor: 'hooks' stamp: ''!
rowShapeFor: aRSLinePlot
	| valuePoint |
	valuePoint := self valuePointFor: aRSLinePlot.
	valuePoint ifNil: [ ^ nil ].
	^ self rowShapeFor: aRSLinePlot point: valuePoint.! !

!RSLineChartPopupBuilder methodsFor: 'hooks' stamp: ''!
rowShapeFor: aRSLinePlot point: aPoint
	^ self subclassResponsibility! !

!RSLineChartPopupBuilder methodsFor: 'hooks' stamp: ''!
valuePointFor: aRSLinePlot
	| xValue yValue |
	xValue := (aRSLinePlot xScale invert: position x) asInteger.
	(xValue between: 1 and: aRSLinePlot yValues size)
		ifFalse: [ ^ nil ].
	yValue := aRSLinePlot yValues at: xValue.
	^ xValue @ yValue
	! !

!RSLineDrivenLayout commentStamp: ''!
TODO!
!RSLineDrivenLayout methodsFor: 'iterator' stamp: ''!
edgesDo: aBlock
	"Iterates over all the edges of the receiver."
	lines ifNil: [ ^ self ].
	lines do: aBlock
! !

!RSLineDrivenLayout methodsFor: 'hook' stamp: ''!
doExecute: elements
	self subclassResponsibility! !

!RSLineDrivenLayout methodsFor: 'accessing' stamp: ''!
edges: aCollection
	"Set the list of edges that should be considered for the layout.
	If none is specified (i.e., if this method is not called), then the 
	edges are infered."
	lines := aCollection! !

!RSLineDrivenLayout methodsFor: 'accessing' stamp: ''!
toPositions: anArray
	toPositions := anArray! !

!RSLineDrivenLayout methodsFor: 'accessing' stamp: ''!
userDefinedEdges: aCollectionOfEdges
	"useful to tell to the layout which edges have to be used for the layout"
	userDefinedEdges := aCollectionOfEdges.
	! !

!RSLineDrivenLayout methodsFor: 'testing' stamp: ''!
isEdgeDrivenLayout
	^ true! !

!RSLineDrivenLayout methodsFor: 'hook' stamp: ''!
doIncrementallyExecute: anElementNode
	"called by refreshLayoutEvery: ms. It is used to convey a feeling of incremental execution."
	self doExecute: anElementNode! !

!RSLineDrivenLayout methodsFor: 'private' stamp: ''!
userDefinedEdges
	^ userDefinedEdges! !

!RSLineDrivenLayout methodsFor: 'hook' stamp: ''!
executeOnElements: elements
	"Execute the layout, myself, on the elements"
	self userDefinedEdges
		ifNil: [ self setEdgesFromElements: elements ]
		ifNotNil: [ | flat |
			flat := OrderedCollection new.
			self userDefinedEdges
				do: [ :each | 
					each isCollection
						ifTrue: [ flat addAll: each ]
						ifFalse: [ flat add: each ] ].
			self edges: flat ].
	super executeOnElements: elements! !

!RSLineDrivenLayout methodsFor: 'accessing' stamp: ''!
setEdgesFromElements: elements
	elements isEmpty ifTrue: [ ^ self ].
	
	^ self edges:
		((elements flatCollect: #incomingLines)
			select: [ :anEdge |elements includes: anEdge from])
! !

!RSLineDrivenLayout methodsFor: 'accessing' stamp: ''!
fromPositions: anArray
	fromPositions := anArray! !

!RSLineDrivenLayout methodsFor: 'private' stamp: ''!
edges
	^ lines! !

!RSLineDrivenLayout class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = RSLineDrivenLayout! !

!RSLineDrivenLayout class methodsFor: 'public' stamp: ''!
on: elements edges: edges
	^ self new on: elements edges: edges! !

!RSLineDrivenLayout class methodsFor: 'instance creation' stamp: ''!
withEdges: aCollection
	
	^self new initialize userDefinedEdges: aCollection! !

!RSLinePlot commentStamp: ''!
TODO!
!RSLinePlot methodsFor: 'public - shape' stamp: ''!
color: aColor
	self shape color: aColor! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
addInteraction: anInteraction
	self shape addInteraction: anInteraction! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
markerEnd: aMarker
	self shape markerEnd: aMarker! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
noBorder
	self shape noBorder! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
borderColor: aColor
	self shape borderColor: aColor! !

!RSLinePlot methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	| controlPoints |
	self checkAssertion. 
	controlPoints := OrderedCollection new.
	(1 to: xValues size) do: [ :i |
			| xt yt |
			xt := xValues at: i.
			yt := yValues at: i.
			(self isPointWellDefined: xt @ yt)
				ifTrue: [ controlPoints add: (self scalePoint: xt @ yt) ] ].
	canvas add: (line := self shape copy
		color: self computeColor;
		controlPoints: controlPoints;
		yourself).! !

!RSLinePlot methodsFor: 'accessing' stamp: ''!
createdShapes
	^ { line }! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
shape: aShape
	self shouldNotImplement! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
markerStart: aMarker
	self shape markerStart: aMarker! !

!RSLinePlot methodsFor: 'initialization' stamp: ''!
defaultShape
	^ RSPolyline new color: nil.! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
format: aString
	
	"want more markers? submit a new issue in roassal3"
	| marker bs |
	marker := RSShapeFactory shapeFromString: aString.
	bs := RSStrokeStyle fromString: aString.
	marker ifNotNil: [ self shape marker: marker ].
	! !

!RSLinePlot methodsFor: 'accessing' stamp: ''!
line
	^ line! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
dashed
	self shape dashed! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
border
	^ self shape border! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
width: aNumber
	"Set the width of the line. For example:
	
-=-=-=-=-=-=-=-=-=-=
c := RSCanvas new.

from := RSBox new size: 30; model: 'from'.
to := RSEllipse new size: 30; model: 'to'.

c add: from.
c add: to.

RSEdgeBuilder line
	canvas: c;
	width: 10;
	connectFrom: 'from' to: 'to'.


from @ RSDraggable.
to @ RSDraggable.

to translateTo: 50 @ 40.

c @ RSCanvasController
-=-=-=-=-=-=-=-=-=-=
	"
	self shape width: aNumber! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
fmt: aString
	self shape fmt: aString.! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
capRound
	self shape capRound! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
width
	^ self shape border width! !

!RSLinePlot methodsFor: 'testing' stamp: ''!
isLinePlot
	^ true! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
controlPointsController: aCPController
	self shape controlPointsController: aCPController! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
controlPointsController
	^ self shape controlPointsController! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
border: aBorder
	self shape border: aBorder! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
shape
	| lineShape |
	lineShape := super shape.
	^ lineShape! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
marker: aMarker
	self shape marker: aMarker! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
paint: aPaint
	self shape paint: aPaint! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
joinRound
	self shape joinRound! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
dashArray: anArray
	^ self shape dashArray: anArray! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
markerStartEnd: aMarker
	self shape markerStartEnd: aMarker! !

!RSLinePlot methodsFor: 'public - shape' stamp: ''!
cornerRadii: aNumber
	^ self shape cornerRadii: aNumber! !

!RSLinePlot class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSLinePlot class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSLinePlot class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSLinePlot class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSLinePlot class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSLinePlot class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSLinePlot class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSLinePlot class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSLinePlot class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSLinePlot class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSLinePlot class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSLinePlot class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSLinePlot class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSLinePlot class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSLinePlot class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSLinePlot class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSLinePlot class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSLinePlot class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSLinePlot class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSLinePlot class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSLinePlot class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSLinePlot class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RSLinePlot class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RSLinePlot class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RSLinePlot class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSLinePlot class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSLinePlot class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSLinePlot class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSLinePlot class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSLinePlotTest methodsFor: 'tests' stamp: ''!
classToTest
	^ RSLinePlot! !

!RSLinearInterpolator commentStamp: ''!
I return the linear interpolation!
!RSLinearInterpolator methodsFor: 'interpolation' stamp: ''!
interpolate: aNumber
	^ aNumber! !

!RSLinesTest commentStamp: ''!
Test for all the lines of trachel!
!RSLinesTest methodsFor: 'running' stamp: ''!
testDrawLine
	canvas addShape: (RSLine new
		strokeColor: Color red;
		width: 2). 
	canvas createMorph drawOnMockCanvas.! !

!RSLinesTest methodsFor: 'running' stamp: ''!
testDrawMarkers
	| line m |
	m := RSPolygon new 
		points: { -10@0. 0@ -10. 10@0 };
		color: Color black;
		size: 10.
	line := RSLine new
		startPoint: 50@50;
		endPoint: 250@50.
	line markerStart: m.
	canvas addShape: line.
	canvas createMorph drawOnMockCanvas.! !

!RSLinesTest methodsFor: 'running' stamp: ''!
testMarkerOffset
	| line marker |
	line := RSLine new
		startPoint: 0@0;
		endPoint: 100@0;
		yourself.
	marker := RSBox new size: 20; withBorder; noPaint; asMarker.
	marker offsetRatio: 0.5.
	line markerEnd: marker.
	
	self assert: (line includesPoint: 50@ 9).
	marker offset: 20.
	self deny: (line includesPoint: 50@ 9).
	self assert: (line includesPoint: 30@ 9).	
! !

!RSLinesTest methodsFor: 'running' stamp: ''!
testMarkersIncludesPoint
	| line marker |
	line := RSLine new
		startPoint: 0@ 0;
		endPoint: 200@0;
		yourself.
	marker := RSBox new
		size: 20;
		asMarker.
	self assert: (line includesPoint: 0@0).
	self assert: (line includesPoint: 100@0).
	self assert: (line includesPoint: 200@0).
	self deny: (line includesPoint: 210@0).
	self deny: (line includesPoint: 210@10).
	self deny: (line includesPoint: 210@ -10).
	line markerEnd: marker.
	self assert: (line includesPoint: 210@0).
	self assert: (line includesPoint: 200@9).
	self assert: (line includesPoint: 210@ -10).
	self deny: (line includesPoint: 210@ -11).! !

!RSLinesTest methodsFor: 'running' stamp: ''!
testPolylineIncludesPoint
	| line |
	line := RSPolyline new.
	line width: 10.
	line controlPoints: { 0@0. 0@100 }.
	self assert: (line includesPoint: 0@0).
	self assert: (line includesPoint: 0@100).
	self assert: (line includesPoint: 0@50).
	self assert: (line includesPoint: 5@50).
	
	self deny: (line includesPoint: 500@500).
	self deny: (line includesPoint: 6@50).! !

!RSLinesTest methodsFor: 'tests - colors' stamp: ''!
testColorLineAndMarker
	| line |
	line := RSShapeFactory arrowedLine.
	line color: Color blue.
	self 
		assert: line color equals: Color blue;
		assert: line markerEnd shape borderColor equals: Color blue.! !

!RSLinesTest methodsFor: 'running' stamp: ''!
testArrowedLine
	| line head other |
	line := RSArrowedLine new.
	line startPoint: 0@0; endPoint: 100@100.
	head := line markerEnd.
	self assert: head isNotNil.
	
	head := head shape.
	self assert: head class equals: RSPolygon.
	line color: Color blue.
	self assert: line color equals: Color blue.
	self assert: head border color equals: Color blue.
	
	line border: (RSBorder new width: 2; color: Color red).
	self assert: line border width equals: 2.
	self assert: line color equals: Color red.
	self assert: head border width equals: 2.
	self assert: line color equals: Color red.
	
	other := line copy.
	self deny: other equals: line.
	self deny: other markerEnd hash equals: line markerEnd hash.
	! !

!RSLinesTest methodsFor: 'running' stamp: ''!
testLineIncludesPoint
	| line |
	line := RSLine new
		startPoint: 0@0;
		endPoint: 0@100;
		width: 8;
		yourself.
	self assert: (line includesPoint: 0@0).
	self assert: (line includesPoint: 0@100).
	self assert: (line includesPoint: 0@50).
	self assert: (line includesPoint: 4@50).
	self deny: (line includesPoint: 5@50).
	self deny: (line includesPoint: 500@500).
! !

!RSLinesTest methodsFor: 'running' stamp: ''!
testDrawBezierLine
	canvas addShape: (RSBezier new
		strokeColor: Color red;
		width: 2). 
	canvas createMorph drawOnMockCanvas.! !

!RSLinesTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new! !

!RSLocation commentStamp: ''!
<keyClass>
`RSLocation` locates shapes with respect to other shapes. Shapes can be positioned in a sticky fashion or not. Being sticky means whether the base shapes "drag" the sitcky shapes when dragged. `RSLocation` iteratively builds constraint for moving and positioning a shape on top of another one.

*Responsibility*: locate permanently or not some shapes with respect to other shapes.

*Collaborators*: closely interact with `RSShape`, `RSExtentChangedEvent`, and `RSPositionChangedEvent`

*Variables*:
- `offset`: offset between the positioned shape and the base shape
- `orientation`: a value that could be -1, 0, 1 indicating the orientation of the location
- `direction`: a point indicating the direction of the lcoation

*Example*:
Here is a simple example:
```Smalltalk
c := RSCanvas new.

box1 := RSBox new size: 50; color: Color gray translucent.
box2 := RSBox new size: 30; color: Color gray translucent.
box1 @ RSDraggable.
box2 @ RSDraggable.
c add: box1; add: box2.

box1 translateBy: 150 @ -40.

label := RSLabel new text: 'Move the mouse above me'.
c add: label.
RSLocation new 
	above;
	stick: label on: box1.
c
```


```Smalltalk
c := RSCanvas new.

g := RSGroup new.
g add: (RSLabel new text: 'Base shape, drag me').
baseShape := g asShape adjustToChildren.
baseShape color: #lightBlue.
baseShape @ RSDraggable.
c add: baseShape.

redShape := RSBox new extent: 60 @ 30; color: #red.
c add: redShape.

RSLocation new
	bottom;
	outer;
	right;
	offset: 20;
	stick: redShape on: baseShape.
"Try changing stick:on: by move:on. Replacing bottom by top"
c
```

A more complex example:

```Smalltalk
v := RSCanvas new.

classes := Collection withAllSubclasses.
boxes := classes collect: [ :cls |
	RSBox new
		width: (cls instVarNames size * 5 max: 5);
		height: (cls numberOfMethods max: 5);
		model: cls
] as: RSGroup.

boxes @ RSDraggable.
v addAll: boxes.

RSEdgeBuilder orthoVertical
	canvas: v;
	attachPoint: RSVerticalAttachPoint new;
	shapes: boxes;
	connectFrom: #superclass.

boxes do: [ :b |
	| t |
	t := RSLabel new height: 2; text: b model name.
	v add: t.
	RSLocation new
		offset: 1;
		above; center;
		stick: t on: b.
].

RSTreeLayout on: boxes.
v @ RSCanvasController.
v open
```!
!RSLocation methodsFor: 'public - modifiers' stamp: ''!
border
	orientation := 0! !

!RSLocation methodsFor: 'public - positioning' stamp: ''!
center
	fixedX := [ :rec | rec floatCenter x ].
	direction := 0 @ direction y! !

!RSLocation methodsFor: 'public - positioning' stamp: ''!
bottom
	"Locate the shape at the bottom of the base shape.
For example:
```Smalltalk
c := RSCanvas new.

g := RSGroup new.
g add: (RSLabel new text: 'Base shape').
baseShape := g asShape adjustToChildren.
baseShape color: #lightBlue.
baseShape @ RSDraggable.
c add: baseShape.

redShape := RSBox new extent: 60 @ 30; color: #red.
c add: redShape.

RSLocation new
	bottom;
	outer;
	right;
	move: redShape on: baseShape.
c
```
	"
	fixedY := #bottom.
	direction := direction x @ -1.! !

!RSLocation methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	direction := 0 @ 0.
	self
		offset: 0;
		inner;
		middle;
		center! !

!RSLocation methodsFor: 'private' stamp: ''!
parentPosition: fixedShape
	| rec |
	rec := fixedShape.
	rec isRectangle ifFalse:  [ rec := rec encompassingRectangle ] .
	^ (fixedX value: rec)@ (fixedY value: rec).! !

!RSLocation methodsFor: 'public - modifiers' stamp: ''!
outer
	orientation := -1! !

!RSLocation methodsFor: 'public - modifiers' stamp: ''!
offset: aNumber
	"Let an offset between the positioned shape and the base shape.
	
For example
```Smalltalk
c := RSCanvas new.

g := RSGroup new.
g add: (RSLabel new text: 'Base shape').
baseShape := g asShape adjustToChildren.
baseShape color: #lightBlue.
baseShape @ RSDraggable.
c add: baseShape.

redShape := RSBox new extent: 60 @ 30; color: #red.
c add: redShape.

RSLocation new
	bottom;
	outer;
	right;
	offset: 20;
	move: redShape on: baseShape.
c
```"
	offset := aNumber asPoint! !

!RSLocation methodsFor: 'public - positioning' stamp: ''!
right
	"Locate the shape on the right of the base shape.
For example:
```Smalltalk
c := RSCanvas new.

g := RSGroup new.
g add: (RSLabel new text: 'Base shape').
baseShape := g asShape adjustToChildren.
baseShape color: #lightBlue.
baseShape @ RSDraggable.
c add: baseShape.

redShape := RSBox new extent: 60 @ 30; color: #red.
c add: redShape.

RSLocation new
	above;
	right;
	move: redShape on: baseShape.
c
```"
	fixedX := #right.
	direction := -1 @ direction y.! !

!RSLocation methodsFor: 'public - positioning shorcuts' stamp: ''!
below 
	self bottom; outer! !

!RSLocation methodsFor: 'public - positioning' stamp: ''!
left
	"Locate the shape on the left of the base shape.
For example:
```Smalltalk
c := RSCanvas new.

g := RSGroup new.
g add: (RSLabel new text: 'Base shape').
baseShape := g asShape adjustToChildren.
baseShape color: #lightBlue.
baseShape @ RSDraggable.
c add: baseShape.

redShape := RSBox new extent: 60 @ 30; color: #red.
c add: redShape.

RSLocation new
	above;
	left;
	move: redShape on: baseShape.
c
```"
	fixedX := #left.
	direction := 1@ direction y! !

!RSLocation methodsFor: 'public - executing' stamp: ''!
stick: movableShape on: baseShape
	| block |
	block := [ self move: movableShape on: baseShape ].
	block value.
	baseShape 
		when: RSExtentChangedEvent do: block;
		when: RSPositionChangedEvent do: block.! !

!RSLocation methodsFor: 'private' stamp: ''!
computePosition: movableShape on: fixedShape
	^ movableShape extent / 2 * orientation * direction + (self parentPosition: fixedShape) + offset.! !

!RSLocation methodsFor: 'public - executing' stamp: ''!
move: movableShape on: baseShape
	"Utility method"
	movableShape translateTo: (self computePosition: movableShape on: baseShape).! !

!RSLocation methodsFor: 'public - modifiers' stamp: ''!
inner
	orientation := 1! !

!RSLocation methodsFor: 'public - positioning' stamp: ''!
middle
	"Locate the shape in the middle of the base shape.
For example:
```Smalltalk
c := RSCanvas new.

g := RSGroup new.
g add: (RSLabel new text: 'Base shape').
baseShape := g asShape adjustToChildren.
baseShape color: #lightBlue.
baseShape @ RSDraggable.
c add: baseShape.

redShape := RSBox new extent: 60 @ 30; color: #red.
c add: redShape.

RSLocation new
	middle;
	above;
	move: redShape on: baseShape.
c
```
	"
	fixedY := [ :r | r floatCenter y ].
	direction := direction x @ 0! !

!RSLocation methodsFor: 'public - positioning' stamp: ''!
top
	fixedY := #top.
	direction := direction x @ 1! !

!RSLocation methodsFor: 'public - modifiers' stamp: ''!
offset
	^ offset! !

!RSLocation methodsFor: 'public - positioning shorcuts' stamp: ''!
above 
	self top; outer.! !

!RSLocation class methodsFor: 'public' stamp: ''!
move: aShapeOrAGroup1 below: aShapeOrAGroup2
	self new below; move: aShapeOrAGroup1 on: aShapeOrAGroup2! !

!RSLocation class methodsFor: 'public' stamp: ''!
move: aShapeOrAGroup1 above: aShapeOrAGroup2
	self new above; move: aShapeOrAGroup1 on: aShapeOrAGroup2! !

!RSMarker commentStamp: ''!
I represent a marker for RSLine, RSPolygon and RSBezier!
!RSMarker methodsFor: 'converting' stamp: ''!
asMarker
	^ self! !

!RSMarker methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	offset := 0.
	offsetRatio := 0.! !

!RSMarker methodsFor: 'accessing' stamp: ''!
offset: aNumber
	"Set the offset in pixel. Consider:
```
c := RSCanvas new.

box := RSBox new.
circle := RSCircle new.

c add: box; add: circle.
box @ RSDraggable.
circle @ RSDraggable.

circle translateTo: 50 @ 40.

line := RSLine new.
line withBorderAttachPoint.
marker := (RSCircle new size: 5; color: #red) asMarker.
marker offset: 10.
line marker: marker.
line from: box.
line to: circle.
c add: line.
c zoomToFit.
c open
```"
	offset := aNumber! !

!RSMarker methodsFor: 'copying' stamp: ''!
postCopy
	shape := shape copy! !

!RSMarker methodsFor: 'accessing' stamp: ''!
offsetRatio: aFloat
	"Set the offset ratio of the marker. The argument is a float and has to range from 0 to 1.
	
```
c := RSCanvas new.

box := RSBox new.
circle := RSCircle new.

c add: box; add: circle.
box @ RSDraggable.
circle @ RSDraggable.

circle translateTo: 50 @ 40.

line := RSLine new.
line withBorderAttachPoint.
marker := (RSCircle new size: 5; color: #red) asMarker.
marker offsetRatio: 0.7.
line marker: marker.
line from: box.
line to: circle.
c add: line.
c zoomToFit.
c open
```
"
	offsetRatio := aFloat! !

!RSMarker methodsFor: 'public' stamp: ''!
withEnd: controlPoints do: aBlock
	| from to |
	controlPoints size < 2 ifTrue: [ ^ self ].
	from := controlPoints at: controlPoints size - 1.
	to := controlPoints last.
	self setPositionTo: to vector: to-from do: aBlock.! !

!RSMarker methodsFor: 'public' stamp: ''!
withStart: controlPoints do: aBlock
	| from to |
	controlPoints size < 2 ifTrue: [ ^ self ].
	from := controlPoints first.
	to := controlPoints second.
	self setPositionTo: from vector: from - to do: aBlock.! !

!RSMarker methodsFor: 'accessing' stamp: ''!
shape
	^ shape! !

!RSMarker methodsFor: 'public' stamp: ''!
setPositionTo: from vector: vector do: aBlock
	| angle pos |
	angle := vector angle.
	"0.00001 in order to avoid inverseTransform bad result with sx = 0"
	angle := angle + Float halfPi.
	pos := from.
	
	shape matrix
		loadIdentity;
		rotateByRadians: angle.
	(self offset isZero and: [ self offsetRatio isZero ]) ifFalse: [ 
		| unit |
		unit := vector / (vector r max: 1).
		pos := pos -(vector * self offsetRatio) - (unit * self offset)
		 ].
	shape position: pos.
	aBlock value: shape
	! !

!RSMarker methodsFor: 'public' stamp: ''!
withMid: controlPoints do: aBlock
	controlPoints size < 3 ifTrue: [ ^ self ].
	1 to: controlPoints size - 2 do: [ :i | | a b |
		a := controlPoints at: i.
		b := controlPoints at: i + 1.
		self setPositionTo: b vector: b - a do: aBlock ]! !

!RSMarker methodsFor: 'accessing' stamp: ''!
offset
	^ offset! !

!RSMarker methodsFor: 'accessing' stamp: ''!
shape: anObject
	shape := anObject! !

!RSMarker methodsFor: 'accessing' stamp: ''!
offsetRatio
	^ offsetRatio! !

!RSMenuActivable commentStamp: ''!
With the mouse right click event I show a basic popup

Example:
```Smalltalk
m := RSMondrian new.
m nodes: (1 to: 10).
m build.

m canvas nodes @ (RSMenuActivable new menuDo: [ :menu :element | menu add: 'Inspect' target: element model selector: #inspect ]).

m open
```!
!RSMenuActivable methodsFor: 'enumerating' stamp: ''!
menuDo: block
	"a block with two args
	first arg, a MenuMorph
	second arg, a RSElement or RSView
	"
	menuBlock := block! !

!RSMenuActivable methodsFor: 'hooks' stamp: ''!
onShape: aShape
	"No need to do anything if empty"
	menuBlock isNil ifTrue: [ ^ self ].
	aShape when: RSMouseRightClick do: [ :evt | 
		| menu |
		menu := MenuMorph new.
		menuBlock value: menu value: evt shape.
		menu popUpInWorld ].
	! !

!RSMetricsProvider commentStamp: ''!
A metric provider returns an instance of RSTextExtents, used by RSLabel.
Users can propose a different RSMetricProvider. RSLabel uses by default `RSMetricProvider defaultProvider`
!
!RSMetricsProvider methodsFor: 'hooks' stamp: ''!
extentsOf: aRSLabel
	^ self subclassResponsibility! !

!RSMetricsProvider class methodsFor: 'accessing' stamp: ''!
default
	^ default ifNil: [ default := RSCairoMetricsProvider new ].! !

!RSMetricsProvider class methodsFor: 'accessing' stamp: ''!
default: aRSMetricsProvider
	default := aRSMetricsProvider! !

!RSMockLine commentStamp: ''!
TODO!
!RSMockLine methodsFor: 'accessing' stamp: ''!
to
	^ to! !

!RSMockLine methodsFor: 'accessing' stamp: ''!
from: aMockElement
	from := aMockElement! !

!RSMockLine methodsFor: 'accessing' stamp: ''!
length: aNumber
	length := aNumber! !

!RSMockLine methodsFor: 'accessing' stamp: ''!
realLine: anRSLine
	realLine := anRSLine! !

!RSMockLine methodsFor: 'accessing' stamp: ''!
strength 
	^ strength! !

!RSMockLine methodsFor: 'accessing' stamp: ''!
realLine
	^ realLine! !

!RSMockLine methodsFor: 'accessing' stamp: ''!
to: aMockElement
	to := aMockElement! !

!RSMockLine methodsFor: 'accessing' stamp: ''!
length
	^ length! !

!RSMockLine methodsFor: 'accessing' stamp: ''!
from
	^ from! !

!RSMockLine methodsFor: 'accessing' stamp: ''!
strength: aNumber
	strength := aNumber! !

!RSMockShape commentStamp: ''!
TODO!
!RSMockShape methodsFor: 'actions' stamp: ''!
addWeight
	weight := weight + 1! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
realShape: rtElement
	realShape := rtElement.
	position := rtElement position.
	self oldPosition: position.! !

!RSMockShape methodsFor: 'actions' stamp: ''!
initialize
	super initialize.
	isFixed := false.! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
oldPosition: aPoint
	oldPosition := aPoint! !

!RSMockShape methodsFor: 'actions' stamp: ''!
applyToRealElement
	isFixed ifTrue: [ ^ self ].
	realShape translateTo: position ! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
realShape
	^ realShape! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
width
	^ realShape width! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
extent
	^ realShape extent! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
fixPosition
	^ fixPosition! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
weight: aNumber
	weight := aNumber! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
charge: aNum
	charge := aNum! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
height
	^ realShape height! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
charge
	^ charge! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
encompassingRectangle 
	^ realShape encompassingRectangle! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
fixPosition: aPoint
	fixPosition := aPoint! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
isFixed: aBool
	isFixed := aBool! !

!RSMockShape methodsFor: 'actions' stamp: ''!
translateTo: aPosition
	position := aPosition! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
weight
	^ weight! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
isFixed
	^ isFixed ! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
canvas
	^ realShape canvas! !

!RSMockShape methodsFor: 'accessing' stamp: ''!
oldPosition
	^ oldPosition! !

!RSMonitorEvents commentStamp: ''!
Based on https://developers.google.com/web/tools/chrome-devtools/console/events

MonitoEvents for Roassal3 in order to log some events !
!RSMonitorEvents methodsFor: 'accessing' stamp: ''!
announcementClasses: aCollection
	"aCollection of Announcement "
	announcementClasses := aCollection! !

!RSMonitorEvents methodsFor: 'accessing' stamp: ''!
announcementClasses
	^ announcementClasses! !

!RSMonitorEvents methodsFor: 'public' stamp: ''!
onNewEventDo: aBlockClosure
	| events |
	self assert: self target isNotNil description: 'Must provide a target'.
	events := self announcementClasses.
	events ifNil:  [ events := target announcementClasses ].
	events do: [ :evt |
		target when: evt do: aBlockClosure ].! !

!RSMonitorEvents methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!RSMonitorEvents methodsFor: 'public' stamp: ''!
unRegister
	target removeInteractionIfPresent: self class.! !

!RSMonitorEvents methodsFor: 'accessing' stamp: ''!
target: aRSTAnnounceable
	target := aRSTAnnounceable! !

!RSMonitorEventsTest methodsFor: 'tests' stamp: ''!
testBasic
	| canvas monitor eventClass timeStamp |
	canvas := RSCanvas new.
	monitor := RSMonitorEvents new.
	monitor target: canvas.
	
	eventClass := nil.
	timeStamp := nil.
	monitor onNewEventDo: [ :evt | 
		eventClass := evt class.
		timeStamp := evt timeStamp.
	].
	
	canvas announce: RSMouseLeftClick new.
	self assert: eventClass equals: RSMouseLeftClick.
	self assert: timeStamp isNumber.
	
	monitor unRegister.
	eventClass := nil.
	self assert: eventClass isNil.! !

!RSMonitorEventsTest methodsFor: 'tests' stamp: ''!
testNoTarget 
	| monitor |
	monitor := RSMonitorEvents new.
	self should: [ monitor onNewEventDo: [  ] ] raise: Error! !

!RSMonitorEventsTest methodsFor: 'tests' stamp: ''!
testWriteToFile
	| canvas monitor events box fileName storage |
	canvas := RSCanvas new.
	box := RSBox new size: 20; yourself.
	monitor := RSMonitorEvents new.
	monitor target: box.
	events := OrderedCollection new.
	monitor onNewEventDo: [:evt | events add: evt className -> evt timeStamp ].
	box announce: (RSPositionChangedEvent new newPosition: 100@100; yourself).
	self assert: events isNotEmpty.
	
	fileName := Time microsecondClockValue asString, '.fuel'.
	
	storage := FLSerializer serializeToByteArray: events.
	self assert: storage size > 100.
	! !

!RSMorphicPopupInteraction commentStamp: ''!
I am a popup that uses Morphic and can be visible outside of the RSCanvas.!
!RSMorphicPopupInteraction methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ Smalltalk ui theme backgroundColor! !

!RSMorphicPopupInteraction methodsFor: 'hooks' stamp: ''!
createPopupFor: aShape event: event
	| popup vertices targetMorph world |
	targetMorph := self morphBuilder cull: aShape model.
	vertices := SimpleBalloonMorph getVertices: targetMorph bounds.
	popup := SimpleBalloonMorph new
		color: self backgroundColor;
		addMorph: targetMorph;
		setTarget: nil;
		setVertices: vertices.
	world := event canvas morph world.
	world ifNil: [ ^ popup ].
	world addMorphFront: popup.
	world activeHand balloonHelp: popup.
	^ popup! !

!RSMorphicPopupInteraction methodsFor: 'accessing' stamp: ''!
gapFromPointer: aPoint
	gapFromPointer := aPoint! !

!RSMorphicPopupInteraction methodsFor: 'accessing' stamp: ''!
gapFromPointer
	^ gapFromPointer! !

!RSMorphicPopupInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self morphBuilder: [ :model | model asString asTextMorph ].
	gapFromPointer := 0@0.! !

!RSMorphicPopupInteraction methodsFor: 'hooks' stamp: ''!
releasePopup: popup
	popup delete! !

!RSMorphicPopupInteraction methodsFor: 'accessing' stamp: ''!
morphBuilder: aBlock
	morphBuilder := aBlock! !

!RSMorphicPopupInteraction methodsFor: 'hooks' stamp: ''!
translatePopup: aMorph event: evt 
	| position xdelta ydelta cMorph world |
	cMorph := evt canvas morph.
	world := cMorph world.
	position := (evt camera fromSpaceToPixel: evt position) + cMorph position.
	xdelta := gapFromPointer x.
	ydelta := gapFromPointer y.
	
	(position x + aMorph width) > world width 
		ifTrue: [ xdelta := xdelta negated - aMorph width ].
	(position y + aMorph height) > world height
		ifTrue: [ ydelta := ydelta negated - aMorph height ].
	
	aMorph
		lock;
		fullBounds;
		setProperty: #morphicLayerNumber toValue: aMorph morphicLayerNumber.
	
	aMorph position: ((position x + xdelta) max: 0) @ ((position y + ydelta) max: 0)
! !

!RSMorphicPopupInteraction methodsFor: 'hooks' stamp: ''!
popupKey
	^ #popupMorph! !

!RSMorphicPopupInteraction methodsFor: 'accessing' stamp: ''!
morphBuilder
	^ morphBuilder! !

!RSMouseClick commentStamp: ''!
Common event for mouse clicks!
!RSMouseDoubleClick commentStamp: ''!
Events for double clicks!
!RSMouseDoubleLeftClick commentStamp: ''!
Double click for the left button!
!RSMouseDoubleRightClick commentStamp: ''!
Double clicks for right button!
!RSMouseDragEnd commentStamp: ''!
When: at the end of DragDrop event
Target: dragged element!
!RSMouseDragStart commentStamp: ''!
When: when a valid draggable element is grabbed
Target: dragged element!
!RSMouseDragging commentStamp: ''!
When: during dragging of the element
Target: dragged element!
!RSMouseDragging methodsFor: 'initialize - release' stamp: ''!
initialize
	super initialize.
	step := 0 @ 0.! !

!RSMouseDragging methodsFor: 'accessing' stamp: ''!
step
	^ step! !

!RSMouseDragging methodsFor: 'accessing' stamp: ''!
step: aPoint
	step := aPoint! !

!RSMouseDragging class methodsFor: 'instance creation' stamp: ''!
step: aStepAsPoint
	^ self new step: aStepAsPoint! !

!RSMouseEnter commentStamp: ''!
When: when a mouse cursor entered an element
Target: entered element!
!RSMouseLeave commentStamp: ''!
When: when a mouse cursor left an element
Target: entered element!
!RSMouseLeftClick commentStamp: ''!
Common event for mouse left click!
!RSMouseLeftDragStart commentStamp: ''!
left buttom!
!RSMouseMiddleDragStart commentStamp: ''!
middle button!
!RSMouseMove commentStamp: ''!
Performed while mouse is moving over the morph!
!RSMouseRightClick commentStamp: ''!
Common event for mouse right clicks!
!RSMouseRightDragStart commentStamp: ''!
right button!
!RSMouseUp commentStamp: ''!
Events for mouseUp!
!RSMouseUpLeft commentStamp: ''!
left buttom!
!RSMouseUpRight commentStamp: ''!
Event for mouse up right!
!RSMouseWheelEvent commentStamp: ''!
I'm a mouse wheel scrolling event.
!
!RSMouseWheelEvent methodsFor: 'accessing' stamp: ''!
direction: anObject
	direction := anObject! !

!RSMouseWheelEvent methodsFor: 'testing' stamp: ''!
isUp
	^ direction = Character arrowUp! !

!RSMouseWheelEvent methodsFor: 'testing' stamp: ''!
isLeft
	^ direction = Character arrowLeft! !

!RSMouseWheelEvent methodsFor: 'accessing' stamp: ''!
direction
	^ direction! !

!RSMouseWheelEvent methodsFor: 'testing' stamp: ''!
isDown
	^ direction = Character arrowDown! !

!RSMouseWheelEvent methodsFor: 'testing' stamp: ''!
isRight
	^ direction = Character arrowRight! !

!RSMultilineLabelBuilder commentStamp: ''!
I am a builder that can create labels with multiline in roassal3 from objects

```Smalltalk
canvas := RSCanvas new.
shapeBuilder := RSMultilineLabelBuilder new.
shapeBuilder labelShape
 fontSize: 20;
 italic.
canvas add:(shapeBuilder shapeFor: '"tu est loin, 
très loin de tous ces regards vicieux 
qui s''alimentent de ta lumière"').
canvas nodes when: RSMouseClick do: [ :evt | canvas nodes last inspect ].
canvas showEncompassingRectangles.
canvas @ RSCanvasController
```!
!RSMultilineLabelBuilder methodsFor: 'accessing' stamp: ''!
labelShape
	^ labelShape! !

!RSMultilineLabelBuilder methodsFor: 'accessing' stamp: ''!
layout
	^ layout ifNil: [ layout := RSVerticalLineLayout new 
		alignLeft; 
		gapSize: 0;
		yourself ].! !

!RSMultilineLabelBuilder methodsFor: 'accessing' stamp: ''!
textFor: anObject
	^ (textBlock rsValue: anObject) asString! !

!RSMultilineLabelBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self labelShape: RSLabel new; textBlock: #asString.
	self wrapStrategy: RSNoWrapStrategy new.! !

!RSMultilineLabelBuilder methodsFor: 'accessing' stamp: ''!
layout: aRSLayout
	layout := aRSLayout! !

!RSMultilineLabelBuilder methodsFor: 'accessing' stamp: ''!
labelShape: aLabelShape
	labelShape := aLabelShape! !

!RSMultilineLabelBuilder methodsFor: 'hooks' stamp: ''!
basicShapeFor: aString
	| lines |
	lines := aString lines.
	
	^ lines size = 1 
		ifTrue: [ self singleLabelFor: lines first ]
		ifFalse: [ self compositeLabelFor: lines ]! !

!RSMultilineLabelBuilder methodsFor: 'hooks' stamp: ''!
shapeFor: anObject
	| text |
	text := self textFor: anObject.
	^ wrapStrategy wrapTextFor: text with: self.
	
	! !

!RSMultilineLabelBuilder methodsFor: 'hooks' stamp: ''!
singleLabelFor: text
	^ self labelShape copy
		text: text;
		yourself
		! !

!RSMultilineLabelBuilder methodsFor: 'accessing' stamp: ''!
textBlock: aBlock
	textBlock := aBlock! !

!RSMultilineLabelBuilder methodsFor: 'hooks' stamp: ''!
compositeLabelFor: lines 
	| shapes |
	shapes := lines collect: [:line | 
		self singleLabelFor: (line copyReplaceAll: String tab with: '   ') ] 
		as: RSGroup.
	self layout on: shapes.
	^ shapes asShape 
		position: 0@0;
		yourself.! !

!RSMultilineLabelBuilder methodsFor: 'accessing' stamp: ''!
wrapStrategy
	^ wrapStrategy! !

!RSMultilineLabelBuilder methodsFor: 'accessing' stamp: ''!
wrapStrategy: aRSWrapStrategy
	wrapStrategy := aRSWrapStrategy! !

!RSNiceLabel commentStamp: ''!
I am an utility class for RSLabelGenerator.

-=-=-=-=-=-=-=-=-=
values := #(1 2.3 4.3).
c := RSChart new.
d := RSScatterPlot new x: values y: values.
c addPlot: d.
c addDecoration: RSHorizontalTick new.

tick := RSVerticalTick new.
c addDecoration: tick.
c build.

tick createNiceLabelIn: c 
-=-=-=-=-=-=-=-=-=

prints the following: "(Score: 0.75) 1.00	2.00	3.00	4.00	5.00	"
					
The min and max represents the range of the ticks!
!RSNiceLabel methodsFor: 'accessing' stamp: ''!
max: aNumber
	max := aNumber! !

!RSNiceLabel methodsFor: 'accessing' stamp: ''!
score
	^ score! !

!RSNiceLabel methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	score := 0.! !

!RSNiceLabel methodsFor: 'accessing' stamp: ''!
step
	^ step! !

!RSNiceLabel methodsFor: 'accessing' stamp: ''!
numberOfTicks
	^ self ticks / step.! !

!RSNiceLabel methodsFor: 'printing' stamp: ''!
printOn: aStream
	| x |
	aStream 
		nextPutAll: '(Score: ';
		nextPutAll: (score printShowingDecimalPlaces: 2);
		nextPutAll: ') '.
	x := min.
	[x <= max ] whileTrue: [ 
		aStream nextPutAll: (x printShowingDecimalPlaces: 2).
		aStream nextPutAll: String tab.
		x := x + step ].
	
	! !

!RSNiceLabel methodsFor: 'accessing' stamp: ''!
min
	^ min! !

!RSNiceLabel methodsFor: 'accessing' stamp: ''!
min: aNumber
	min := aNumber! !

!RSNiceLabel methodsFor: 'accessing' stamp: ''!
score: aNumber
	score := aNumber! !

!RSNiceLabel methodsFor: 'accessing' stamp: ''!
step: aNumber
	step := aNumber! !

!RSNiceLabel methodsFor: 'accessing' stamp: ''!
ticks
	^  min < 0 ifTrue: [ 
		 max < 0 
			ifTrue: [ (max - min) abs ] 
			ifFalse: [ max + min abs  ]
	] ifFalse: [ max - min ]! !

!RSNiceLabel methodsFor: 'accessing' stamp: ''!
max
	^ max! !

!RSNiceStep commentStamp: ''!
I am an utility class for RTNiceStepSizeGenerator>>next
!
!RSNiceStep methodsFor: 'accessing' stamp: ''!
i
	^ i! !

!RSNiceStep methodsFor: 'accessing' stamp: ''!
offset: aNumber
	offset := aNumber! !

!RSNiceStep methodsFor: 'accessing' stamp: ''!
j
	^ j! !

!RSNiceStep methodsFor: 'accessing' stamp: ''!
j: aNumber
	j := aNumber! !

!RSNiceStep methodsFor: 'accessing' stamp: ''!
stepSize: aNumber
	stepSize := aNumber! !

!RSNiceStep methodsFor: 'accessing' stamp: ''!
offset
	^ offset! !

!RSNiceStep methodsFor: 'accessing' stamp: ''!
stepSize
	^ stepSize! !

!RSNiceStep methodsFor: 'accessing' stamp: ''!
i: aNumber
	i := aNumber! !

!RSNiceStepSizeGenerator commentStamp: ''!
Nice numbers are just step sizes and used for tick spacing. We will use only niceStep tick
 spaces and place tick marks at multiples of tick spacing.
  
  References:
  	[1] An Extension of Wilkinson's Algorithm for positioning Tick Labels on Axes
  		 				(Justin Talbot, Sharon Lin, Pat Hanrahan)
   [2] Nice Numbers for Graph Labels (Paul S. Heckbert, Graphic Gems I)

Here is an example on how to use it:
-=-=-=-=-=-=-=-=-=
nice := RSNiceStepSizeGenerator new.
lg := RSLabelGenerator nice: nice.

lg setLooseFlag: true.
label := lg searchMin: -98.0 max: 18.0 desired: 3.
label asString
-=-=-=-=-=-=-=-=-=
This prints  '(Score: 0.14) -100.00	-60.00	-20.00	20.00	'!
!RSNiceStepSizeGenerator methodsFor: 'private' stamp: ''!
logB: a
	^ a ln / base ln! !

!RSNiceStepSizeGenerator methodsFor: 'private' stamp: ''!
qat: index
	^ qvar at: index + 1! !

!RSNiceStepSizeGenerator methodsFor: 'initialization' stamp: ''!
initialize
	"Generates a NiceNumberGenerator"
	
	super initialize.
	niceStep := RSNiceStep new.
	o := 0.0.
	self setQ: #(1 5 2 2.5 4 3) base: 10.
	! !

!RSNiceStepSizeGenerator methodsFor: 'public' stamp: ''!
next
	| oSet |
	
	niceStep
		stepSize: ss;
		offset: o;
		i: i; "all output and calculations shouls add 1 because wilkinsons index start from 1"
		j: j.
	"Keep track of existing offsets and stepSizes to avoid duplicate returns of 
	step size, offset pairs"
	(ssOffMap includesKey: ss) ifTrue: [ 
		oSet := ssOffMap at: ss.
		[ | b | 
			b := oSet includes: o.
			oSet add: o.
			b not and: [io < (ovar size - 1)] ] whileTrue: [
			 io := io +1.
			 niceStep offset: (o := ovar at: io +1 ). ].
		 ] ifFalse: [ 
		oSet := Set new.
		oSet add: o.
		ssOffMap at: ss put: oSet.
		 ].
	io := io +1."position for next offset if it exists"
	
	"iterate for next call"
	io < ovar size ifTrue: [ o := ovar at: io +1  ]
	ifFalse: [ 
		io := 0.
		i := (i< (qvar size - 1) ) ifTrue: [ i+1 ] ifFalse: [ 0 ] .
		j := i = 0 ifTrue: [ j+1 ] ifFalse: [ j ].
		q := self qat: i.
		ss := self stepSize: j q: q.
		ovar := self offsets: j q: q.
		o := ovar at: io + 1.
	].
	resetRequired := true.
	^ niceStep! !

!RSNiceStepSizeGenerator methodsFor: 'initialization' stamp: ''!
setQ: anArray base: aNumber
	"anArray: preference ordered list of niceStep step sizes. 
	The deault is set by the initializer selector
	
	aNumber: is a number of logs and exps usually changed together with Q"
	qvar := anArray.
	base := aNumber.
	i := 0.
	io := 0.
	j := 1.
	q := self qat: i.
	ss := self stepSize: j q: q.
	ovar := self offsets: j q: q.
	ssOffMap := Dictionary new.
	resetRequired := false.
	
	! !

!RSNiceStepSizeGenerator methodsFor: 'private' stamp: ''!
stepSize: tj q: tq

	^ tj * tq / (base raisedTo: (self logB: tj*tq ) floor ).
	
! !

!RSNiceStepSizeGenerator methodsFor: 'accessing' stamp: ''!
base
	^ base! !

!RSNiceStepSizeGenerator methodsFor: 'private' stamp: ''!
offsets: tj q: tq
	| offs |
	offs := Array new: tj.
	(0 to: tj-1) do: [ :ti |
		offs at: ti+1 put: ((tq*ti) raisedTo: (self logB: tj*tq) ) ].
	^ offs! !

!RSNiceStepSizeGenerator methodsFor: 'accessing' stamp: ''!
qvar
	^ qvar! !

!RSNiceStepSizeGenerator methodsFor: 'public' stamp: ''!
reset
	resetRequired ifFalse: [ ^ self ].
	i := 0.
	io := 0.
	j := 1.
	q := self qat: i.
	ss := self stepSize: j q: q.
	ssOffMap := Dictionary new.
	resetRequired := false.! !

!RSNoLayout commentStamp: ''!
Here is an example:

v := RTView new.

es := (RTEllipse new color: Color blue trans; size: 20) elementsOn: (1 to: 30).
v addAll: es.
RTEdgeBuilder new
	view: v;
	elements: es;
	connectFrom: [ :vv | vv // 2 ].

v addMenu: 'Remember!!' callback: [ 
	positions := es collect: #position.
	 ].

v addMenu: 'Recall!!' callback: [ 
	positions with: es do: [ :p :e | e translateTo: p ].
	v signalUpdate.
	 ].

v addMenu: 'Start layout!!' callback: [ 
	force := RTForceBasedLayout new.
	force initialLayout: RTNoLayout new.
	animation := RTSpringLayoutStepping new.
	animation layoutWithoutPreparing: force.
	animation inView: v.
].

v addMenu: 'Stop layout!!' callback: [ 
	animation stopAndRemove
].
v !
!RSNoLayout methodsFor: 'hook' stamp: ''!
doExecute: elements
	"Do nothing"! !

!RSNoWrapStrategy commentStamp: ''!
This does not apply a wrap in the text!
!RSNoWrapStrategy methodsFor: 'initialization' stamp: ''!
initialize
	"Subclasses should redefine this method to perform initializations on instance creation" ! !

!RSNoWrapStrategy methodsFor: 'hooks' stamp: ''!
wrapTextFor: aString with: aRSMultilineLabelBuilder
	^ aRSMultilineLabelBuilder basicShapeFor: aString! !

!RSNormalizer commentStamp: ''!
<keyClass>
A normalizer is made to assign a color for a particual visual cue (e.g., size, color, font size). The normalization is performed using the model of the considered shapes.

Scales can be set, useful for transformation (e.g., logarithmic).

*Responsibility*: normalize a 

*Collaborators*: interact with `RSShape` and the shape's model

*Variables*:
- `scale`: refers to `NSScale` 
- `executeBlock`: one-arg block useful to compute a metric or property from the shape model. The block takes a shape model as argument
- `shapes`: shapes that are normalized
 
*Example*:
```Smalltalk
c := RSCanvas new.
shapes := (1 to: 150) collect: [ :n | RSEllipse new size: 20; model: n ] as: RSGroup.

c addAll: shapes.
RSGridLayout on: shapes.

RSNormalizer color
	shapes: shapes;
	scale: NSScale category20b;
	normalize: #yourself.

c @ RSCanvasController.
c

```

```Smalltalk
classes := Collection withAllSubclasses.
c := RSCanvas new.

shapes := classes collect: [ :cls |
	b := RSBox new.
	b model: cls.
	b size: cls numberOfMethods.
	b @ RSDraggable @ RSPopup.
	b ].

RSNormalizer color
	shapes: shapes;
	normalize: #numberOfMethods.

c addAll: shapes.
RSFlowLayout on: shapes.

c @ RSCanvasController 
```


```Smalltalk
canvas := RSCanvas new.
classes := Collection withAllSubclasses.
shapes := classes collect: [ :cls |
    RSEllipse new
        size: 10;
        model: cls;
        draggable;
        yourself ].
canvas addAll: shapes.

RSNormalizer size
    from: 10;
    to: 100;
    shapes: shapes;
    normalize: #numberOfMethods.
RSNormalizer color
    from: Color green;
    to: Color red;
    shapes: shapes;
    normalize: #numberOfMethods.

RSEdgeBuilder orthoVertical
    withVerticalAttachPoint;
    markerStart: (RSShapeFactory arrow size: 5; color: Color blue);
    canvas: canvas;
    shapes: shapes;
    connectFrom: #superclass.
    
RSTreeLayout on: shapes.
canvas @ RSCanvasController.
canvas
```

```Smalltalk
c := RSCanvas new.

(30 to: 100 by: 5) do: [ :nb |
	c add: (RSEllipse new size: nb; model: nb) ].

RSNormalizer size
	shapes: c shapes;
	normalize: #yourself.

RSNormalizer color
	shapes: c shapes;
	normalize: #yourself.
RSFlowLayout on: c shapes.
c shapes @ RSPopup.
c @ RSCanvasController
```!
!RSNormalizer methodsFor: 'private - accessing' stamp: ''!
executeBlock: anOneArgBlock
	"Set the block to be executed for the normalizer. The end user should not call this method
	Instead, it is called from methods on the class side"
	executeBlock := anOneArgBlock! !

!RSNormalizer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	scale := NSScale linear.
	shapes := #().
	minAndMaxBlock := #yourself! !

!RSNormalizer methodsFor: 'accessing' stamp: ''!
from: aValue
	"Set the lower limit of the normalized value. For example:

```Smalltalk
v := RSCanvas new.

classes := Collection withAllSubclasses.
es := classes collect: [ :cls | RSEllipse new model: cls ] as: RSGroup.

v addAll: es.
es @ RSPopup @ RSDraggable.

RSNormalizer size
	shapes: es;
	from: 5;
	to: 20;
	normalize: #numberOfMethods.
	
RSNormalizer color
	shapes: es;
	to: Color pink;
	normalize: #numberOfMethods.
RSGridLayout on: es.
v @ RSCanvasController.
v  
```
"
	scale from: aValue! !

!RSNormalizer methodsFor: 'private - accessing' stamp: ''!
key
	^ #normalizerValue! !

!RSNormalizer methodsFor: 'normalizer' stamp: ''!
normalize
	"Normalize the shapes assuming that each shape refers to a number
```Smalltalk
values := #(20 30 40 50 10).

c := RSCanvas new.
shapes := RSEllipse models: values.
shapes @ RSPopup.
c addAll: shapes.

RSNormalizer size
	shapes: shapes;
	from: 20;
	to: 30;
	normalize. 

RSNormalizer color
	shapes: shapes;
	normalize. 
	
RSGridLayout new gapSize: 40; on: shapes.
shapes @ RSLabeled.

c @ RSCanvasController.
c openOnce
```
"
	self normalize: #yourself! !

!RSNormalizer methodsFor: 'accessing' stamp: ''!
to: aValue
	"Set the upper limit of the normalized value. For example:

```Smalltalk
v := RSCanvas new.

classes := Collection withAllSubclasses.
es := classes collect: [ :cls | RSEllipse new model: cls ] as: RSGroup.

v addAll: es.
es @ RSPopup @ RSDraggable.


RSNormalizer size
	shapes: es;
	to: 20;
	normalize: #numberOfMethods.
	
RSNormalizer color
	shapes: es;
	to: Color pink;
	normalize: #numberOfMethods.
RSGridLayout on: es.
v @ RSCanvasController.
v  
```
"
	scale to: aValue
! !

!RSNormalizer methodsFor: 'accessing' stamp: ''!
shapes: someShapes
	"Set to the normalizer the elements that should be normalized"
	someShapes ifNil: [ self error: 'Should not provide nil' ].
	shapes := someShapes! !

!RSNormalizer methodsFor: 'accessing' stamp: ''!
shapes
	"Return the shapes that should be normalized"
	^ shapes
! !

!RSNormalizer methodsFor: 'private - accessing' stamp: ''!
minAndMaxFor: anOneArgBlockOrSymbol
	| min max |
	min := SmallInteger maxVal.
	max := SmallInteger minVal.
	shapes do: [ :shape | | res |
		res := anOneArgBlockOrSymbol rsValue: shape model.
		shape propertyAt: self key put: res.
		min := min min: res.
		max := max max: res ].
	^ minAndMaxBlock rsValue: { min . max }! !

!RSNormalizer methodsFor: 'accessing' stamp: ''!
minAndMaxBlock: aOneArgBlock
	"This method sets the min and the max values for the provided shapes. It is useful to override the value found in the shapes. The argument is evaluated with one argument of a tupple of size 2"
	minAndMaxBlock := aOneArgBlock! !

!RSNormalizer methodsFor: 'accessing' stamp: ''!
scale
	^ scale
! !

!RSNormalizer methodsFor: 'accessing' stamp: ''!
scale: aNSScale
	"Set the scale of the normalizer. For example
	
```Smalltalk
c := RSCanvas new.
shapes := (1 to: 150) collect: [ :n | RSEllipse new size: 20; model: n ] as: RSGroup.

c addAll: shapes.
RSGridLayout on: shapes.

RSNormalizer color
	shapes: shapes;
	scale: NSScale category20b;
	normalize: #yourself.

c @ RSCanvasController.
c
```
"
	scale := aNSScale.
	! !

!RSNormalizer methodsFor: 'normalizer' stamp: ''!
normalize: anOneArgBlockOrSymbol
	"Trigger the normalization using a particular metric to normalize.
The metric is computed on each model of the shapes that are considered.

For example:
```Smalltalk
values := #(20 30 40 50 10).

c := RSCanvas new.
shapes := RSEllipse models: values.
shapes @ RSPopup.
c addAll: shapes.

RSNormalizer size
	shapes: shapes;
	from: 20;
	to: 30;
	normalize: #yourself. 

RSNormalizer color
	shapes: shapes;
	normalize: #yourself. 
	
RSGridLayout new gapSize: 40; on: shapes.
shapes @ RSLabeled.

c @ RSCanvasController.
c openOnce
```	

	"
	| minAndMax |
	minAndMax := self minAndMaxFor: anOneArgBlockOrSymbol.
	scale domain: minAndMax.
	shapes do: [ :shape |
		| scaledValue objectValue |
		objectValue := shape propertyAt: self key.
		scaledValue := scale scale: objectValue.
		executeBlock value: shape value: scaledValue ]
! !

!RSNormalizer class methodsFor: 'instance creation' stamp: ''!
fontSize 
"Here is example
```
v := RSCanvas new.
v @ RSCanvasController.

shapes := RSLabel models: (Collection withAllSubclasses).

shapes do: [ :e | e translateTo: (Random new nextInt: 300) @ (Random new nextInt: 300) ].
v addAll: shapes.

RSNormalizer fontSize
	shapes: shapes;
	to: 30;
	normalize: #numberOfMethods.

v zoomToFit.
v open
```
"

	| n |
	n := self new.
	n from: 5.
	n to: 100.
	n executeBlock: [ :shape :scaledValue | shape fontSize: scaledValue ].
	^ n
! !

!RSNormalizer class methodsFor: 'instance creation' stamp: ''!
position 
	"Create a normalizer for position.
	
Here is an example:
-=-=-=
classes := Collection withAllSubclasses.

v := RSView new.
es := RSShapeBuilder circle
			color: (Color gray alpha: 0.3);
			elementsOn: classes.
es @ RSPopup.
v addAll: es.
RSNormalizer size
	elements: es;
	from: 5;
	to: 20;
	normalize: [ :cls | cls instVarNames size ].
	
RSNormalizer position
	to: 500 @ -500;
	elements: es;
	normalize: [ :cls | cls numberOfMethods @ cls linesOfCode ].
v open		
-=-=-=		

and a more elaborated example:
-=-=-=
classes := Collection withAllSubclasses.

v := RSView new.
line := RSSingleEdgeBuilder polyline 
	width: 2;
	controlPoints: { 0@ -600. 0@0. 600@0 };
	markerStartEnd: (RSShapeBuilder triangle
		size: 20;
		color: Color black;
		element);
	edge.
es := RSShapeBuilder circle
	interactionDo: [ :i | i popup; browseable ];
	border: TSBorder new;
	color: TSColorPalette sequential orrd9;
	elementsOn: classes.
v addAll: es.
v add: line.
RSNormalizer size
	from: 5;
	to: 20;
	elements: es;
	normalize: [ :cls | cls instVarNames size ].
	
RSNormalizer position
	from: 0@0;
	to: 600@ -600;
	elements: es;
	normalize: [ :cls | cls numberOfMethods @ cls linesOfCode ].
v @ RSControlsView.
v 
-=-=-=
	"
	| n |
	n := self new.
	n from: 0 @ 0.
	n to: 100 @ 100.
	n executeBlock: [ :shape :scaledValue | shape translateTo: scaledValue ].
	^ n
! !

!RSNormalizer class methodsFor: 'instance creation' stamp: ''!
width 
	| n |
	n := self new.
	n from: 5.
	n to: 100.
	n executeBlock: [ :shape :scaledValue | shape width: scaledValue ].
	^ n
! !

!RSNormalizer class methodsFor: 'instance creation' stamp: ''!
size 
	| n |
	n := self new.
	n from: 5.
	n to: 100.
	n executeBlock: [ :shape :scaledValue | shape size: scaledValue ].
	^ n
! !

!RSNormalizer class methodsFor: 'instance creation' stamp: ''!
height 
	| n |
	n := self new.
	n from: 5.
	n to: 100.
	n executeBlock: [ :shape :scaledValue | shape height: scaledValue ].
	^ n
! !

!RSNormalizer class methodsFor: 'instance creation' stamp: ''!
color
	"Define a linear color normalizer. For example:
	
```Smalltalk
values := 1 to: 5.

c := RSCanvas new.
shapes := values collect: [ :v | RSEllipse new size: 20; model: v ] as: RSGroup.
c addAll: shapes.

shapes @ RSPopup.

RSNormalizer color
	shapes: shapes;
	normalize: #yourself.
RSFlowLayout on: shapes.
c
```
"
	| n |
	n := self new.
	n from: Color green.
	n to: Color red.
	n executeBlock: [ :shape :scaledValue | shape color: scaledValue ].
	^ n
! !

!RSNormalizerTest commentStamp: ''!
I am test for RSNormalizer!
!RSNormalizerTest methodsFor: 'tests' stamp: ''!
testBasic 
	| shapes |
	shapes := (1 to: 2) collect: [ :n | RSBox new model: n; yourself ].
	
	self assert: shapes size equals: 2.
	self assert: shapes first color equals: Color lightGray.
	RSNormalizer color
		shapes: shapes;
		normalize: #yourself.
	self assert: shapes first color equals: Color green.
	RSNormalizer size
		shapes: shapes;
		from: 100;
		to: 200;
		normalize: #yourself.
	self assert: shapes first extent equals: 100@100.
	self assert: shapes first extent equals: 100@100.! !

!RSNothingSelection commentStamp: ''!
do nothing!
!RSNothingSelection methodsFor: 'instance creation' stamp: ''!
on: aCanvas
	"nothing"! !

!RSNumberTest methodsFor: 'tests' stamp: ''!
testToCount3

	| c |
	c := 1 to: 10 count: 1.
	self assert: c size equals: 1.
	self assert: c equals: (Array with: 1)! !

!RSNumberTest methodsFor: 'tests' stamp: ''!
testToCount2

	| c |
	c := 1 to: 10 count: 2.
	self assert: c size equals: 2! !

!RSNumberTest methodsFor: 'tests' stamp: ''!
testToCount4

	| c |
	c := 0.02 to: 1.0 count: 120.
	self assert: c first equals: 0.02.
	self assert: c last equals: 1.0.
	self assert: c size equals: 120! !

!RSNumberTest methodsFor: 'tests' stamp: ''!
testToCount

	| c |
	c := 1 to: 10 count: 5.
	self assert: c size equals: 5! !

!RSObject commentStamp: ''!
Root of most of the Roassal classes.!
!RSObjectWithProperty commentStamp: ''!
This class has a set of properties useful to contains some meta-information.
Properties may be added, removed, and tested.
Furthermore, `RSObjectWithProperty` has an announcer and offers some abilities to handle event with interactions. 
My subclasses have attributes useful to add extra data to each component

*Responsibility*: support properties defined in terms of pairs key->values, and can do some event handling.

*Collaborators*: subclasses!
!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
propertyAt: aKey
	^ self properties at: aKey ifAbsent: [ nil ]! !

!RSObjectWithProperty methodsFor: 'interactions' stamp: ''!
addInteraction: anInteractionClassOrInstance
 	anInteractionClassOrInstance onShape: self! !

!RSObjectWithProperty methodsFor: 'testing' stamp: ''!
hasInteraction: anInteractionClass
	"Return true or false if the receiver has an interaction. Note that the argument has to be an interaction class. And not an event"
	self announcer subscriptions ifNil: [ ^ false ].
	^ self announcer subscriptions handleSubscriberClass: anInteractionClass! !

!RSObjectWithProperty methodsFor: '*Roassal3-Sunburst' stamp: ''!
sparent: anObject
	"children is used by tree builders usefull to relationate hierarchy visualizations"
	self propertyAt: #sparent put: anObject! !

!RSObjectWithProperty methodsFor: 'removing' stamp: ''!
removeInteractionIfPresent: anInteractionClass
	"Remove all the callbacks associated to the interaction."
	(self hasInteraction: anInteractionClass) ifFalse: [ ^ self ].
	(self getInteractionsForClass: anInteractionClass) do: [ :int | self announcer unsubscribe: int ]! !

!RSObjectWithProperty methodsFor: 'events' stamp: ''!
click
	"Simulate a click. 
	
For example:
-=-=-=-=-=-=-=-=-=
c := RSCanvas new.
box := RSBox new size: 40.
box when: RSMouseClick do: [ :evt | self inform: 'hello' ].
c add: box.

box click.

c
-=-=-=-=-=-=-=-=-=
"
	self announcer announce: (RSMouseClick new 
		canvas: self canvas;
		shape: self; 
		yourself).! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
propertyAt: aKey put: value
	"Keep a value under a key. The key is usually a symbol.
For example:
```
RSBox new propertyAt: #hello put: 'World'; propertyAt: #hello 
```
return World
	"

	^ self properties at: aKey put: value! !

!RSObjectWithProperty methodsFor: 'announcer' stamp: ''!
announce: anEvent
	| a |
	a := self privateAnnouncer.
	a ifNil: [ ^ self ].
	a announce: anEvent value! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
propertyAt: aKey ifPresent: aPresentBlock ifAbsent: anAbsentBlock
	^ self properties at: aKey ifPresent: aPresentBlock ifAbsent: anAbsentBlock! !

!RSObjectWithProperty methodsFor: 'public' stamp: ''!
executeWithoutAnnouncer: aBlock
	| ann |
	ann := self privateAnnouncer.
	self announcer: nil.
	aBlock value.
	self announcer: ann.! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
propertyAt: aKey ifAbsentPut: anAbsentBlock 
	^ self properties at: aKey ifAbsentPut: anAbsentBlock ! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
propertyAt: aKey ifAbsent: anAbsentBlock 
	^ self properties at: aKey ifAbsent: anAbsentBlock ! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
removePropertyAt: aKey ifAbsent: anErrorBlock
	^ self properties removeKey: aKey ifAbsent: anErrorBlock! !

!RSObjectWithProperty methodsFor: 'announcer' stamp: ''!
privateAnnouncer
	^ announcer! !

!RSObjectWithProperty methodsFor: 'interactions' stamp: ''!
@ anInteractionClassOrInstance
	"Add an interaction to the canvas or a shape.
Here is an example that illustrate two interactions, one for a shape and another for the canvas:
-=-=-=-=-=-=-=-=-=
c := RSCanvas new.
shape := RSEllipse new size: 30; model: 'hello'.
c add: shape.
shape @ RSPopup.
c @ RSCanvasController
-=-=-=-=-=-=-=-=-=
	"
	
	self addInteraction: anInteractionClassOrInstance! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
hasProperty: aKey 
	^ properties notNil and: [ properties includesKey: aKey ]! !

!RSObjectWithProperty methodsFor: 'accessing' stamp: ''!
canvas
	^ self subclassResponsibility! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
hasProperties
	^ properties notNil and: [ properties notEmpty ]! !

!RSObjectWithProperty methodsFor: 'announcer' stamp: ''!
announcer
	^ self privateAnnouncer ifNil: [ 
		| a |
		a := Announcer new.
		self announcer: a.
		a ]! !

!RSObjectWithProperty methodsFor: 'announcer' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject
	self announcer when: anAnnouncementClass send: aSelector to: anObject! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
propertyAt: aKey ifPresent: aPresentBlock 
	^ self properties at: aKey ifPresent: aPresentBlock ! !

!RSObjectWithProperty methodsFor: '*Roassal3-Sunburst' stamp: ''!
sparent
	^ self propertyAt: #sparent! !

!RSObjectWithProperty methodsFor: 'announcer' stamp: ''!
when: event do: aBlock
	self announcer when: event do: aBlock! !

!RSObjectWithProperty methodsFor: 'announcer' stamp: ''!
announcementClasses
	"must return a collection of Announcement classes"
	^ self subclassResponsibility! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
removeKey: aKey
	| prop |
	prop := self properties.
	(prop includesKey: aKey) ifFalse: [ ^ self ].
	prop removeKey: aKey.
	prop ifEmpty: [ prop := nil ]
	! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
properties
	^ properties ifNil: [ properties := Dictionary new ]! !

!RSObjectWithProperty methodsFor: 'announcer' stamp: ''!
getInteractionsForClass: anInteractionClass
	"Return the Announcement subscriptions for the interaction"
	^ self announcer subscriptions getInteractionsForClass: anInteractionClass! !

!RSObjectWithProperty methodsFor: 'announcer' stamp: ''!
announcer: anAnnouncer
	announcer := anAnnouncer! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
propertiesDo: block
	self hasProperties ifFalse: [ ^ self ].
	block value: self properties.! !

!RSObjectWithProperty methodsFor: 'events' stamp: ''!
release
	self class instVarNames do: [ :n | self instVarNamed: n put: nil ]! !

!RSObjectWithProperty methodsFor: '*Roassal3-Sunburst' stamp: ''!
isSLeaf
	^ self schildren isEmpty! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
removePropertyAt: aKey
	^ self properties removeKey: aKey! !

!RSObjectWithProperty methodsFor: '*Roassal3-Sunburst' stamp: ''!
schildren
	^ self propertyAt: #schildren! !

!RSObjectWithProperty methodsFor: '*Roassal3-Sunburst' stamp: ''!
schildren: anObject
	"children is used by tree builders usefull to relationate hierarchy visualizations"
	self propertyAt: #schildren put: anObject! !

!RSObjectWithProperty methodsFor: '*Roassal3-Inspector' stamp: ''!
gtInspectorProperties: composite
	<gtInspectorPresentationOrder: 25>
	self hasProperties ifFalse: [ ^ self ].
	self properties gtInspectorItemsIn: composite! !

!RSObjectWithProperty methodsFor: 'properties' stamp: ''!
propertyAt: aKey ifPresent: aPresentBlock ifAbsentPut: anAbsentBlock
	^ self properties at: aKey ifPresent: aPresentBlock ifAbsentPut: anAbsentBlock! !

!RSObjectWithProperty class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSObjectWithProperty class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSObjectWithProperty class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSObjectWithProperty class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSObjectWithProperty class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSObjectWithProperty class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSObjectWithProperty class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSObjectWithProperty class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSObjectWithProperty class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSObjectWithProperty class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSObjectWithProperty class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSObjectWithProperty class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSObjectWithProperty class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSObjectWithProperty class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSObjectWithProperty class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSObjectWithProperty class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSObjectWithProperty class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSObjectWithProperty class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSObjectWithProperty class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSObjectWithProperty class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSObjectWithProperty class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSObjectWithProperty class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RSObjectWithProperty class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RSObjectWithProperty class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RSObjectWithProperty class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSObjectWithProperty class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSObjectWithProperty class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSObjectWithProperty class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSObjectWithProperty class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSOffsetAttachPoint commentStamp: ''!
I can define offsets in each side of the attach point!
!RSOffsetAttachPoint methodsFor: 'accessing' stamp: ''!
startOffset: aNumber
	startOffset := aNumber.! !

!RSOffsetAttachPoint methodsFor: 'public - hooks' stamp: ''!
initialize 
	super initialize.
	startOffset := endOffset := 0.! !

!RSOffsetAttachPoint methodsFor: 'accessing' stamp: ''!
endOffset
	^ endOffset! !

!RSOffsetAttachPoint methodsFor: 'accessing' stamp: ''!
endOffset: aNumber
	endOffset := aNumber! !

!RSOffsetAttachPoint methodsFor: 'accessing' stamp: ''!
startOffset
	^ startOffset! !

!RSOffsetAttachPoint class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self == RSOffsetAttachPoint! !

!RSPAnimationTest methodsFor: 'tests' stamp: ''!
testError

	| c shape ani |
	c := RSCanvas new.

	shape := RSCircle new color: Color gray.
	c add: shape.

	ani := c newAnimation
				from: -50 @ -50;
				to: 100 @ 0.
	self should: [ ani on: shape set: #position ] raise: AssertionFailure.
	! !

!RSPAnimationTest methodsFor: 'tests' stamp: ''!
testBasicInCanvas
	| animation |
	animation := self animationClass new.
	canvas addAnimation: animation.
	self assert: canvas animations size equals: 1.
	
	self assert: animation isRunning.
	self assert: animation duration equals: self animationClass defaultDuration! !

!RSPAnimationTest methodsFor: 'accessing' stamp: ''!
animationClass: aClass
	animationClass := aClass! !

!RSPAnimationTest methodsFor: 'tests' stamp: ''!
testBasic
	| animation |
	animation := self animationClass new.
	self assert: animation loops equals: 1.
	self deny: animation hasCompleted.
	
	self deny: animation isRunning.
	self assert: animation startTime isNil.
	self deny: animation isPaused.
	animation start.
	self assert: animation isRunning.
	self deny: animation startTime isNil.
	self deny: animation isPaused.
	
	animation pause.
	self assert: animation isPaused.
	animation continue.
	self deny: animation isPaused.
	
	self assert: animation loops equals: 1.
	self should: [animation loops: 0 ] raise: Error.
	animation loops: 3.
	self assert: animation loops equals: 3.! !

!RSPAnimationTest methodsFor: 'tests' stamp: ''!
testDelay
	| animation |
	animation := self animationClass new.
	animation delay: 100 milliSeconds.
	animation start.
	self deny: animation isDelayDone.
	(Delay forMilliseconds: 201) wait.
	self assert: animation isDelayDone.! !

!RSPAnimationTest methodsFor: 'accessing' stamp: ''!
animationClass
	^ animationClass! !

!RSPAnimationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new! !

!RSPAnimationTest class methodsFor: 'building suites' stamp: ''!
testParameters
	| m classesToConsider |
	m := ParametrizedTestMatrix new.
	classesToConsider := RSAbstractAnimation allSubclasses select: [ :c | c subclasses isEmpty ].
	classesToConsider do: [ :cls | 
		m addCase: { (#animationClass -> cls) }
	].
	^ m 
	! !

!RSPBoundingTest methodsFor: 'accessing' stamp: ''!
shapeClass: aShapeClass
	shapeClass := aShapeClass! !

!RSPBoundingTest methodsFor: 'accessing' stamp: ''!
shapeClass
	^ shapeClass! !

!RSPBoundingTest methodsFor: 'tests' stamp: ''!
testDraw
	canvas addShape: (self shapeClass new extent: 50 @ 50).
	canvas createMorph drawOnMockCanvas.! !

!RSPBoundingTest methodsFor: 'tests' stamp: ''!
testPosition
	| b |
	b := self shapeClass new.
	self assert: b position equals: 0@0.
	b position: 0@0.! !

!RSPBoundingTest methodsFor: 'tests' stamp: ''!
testDrawBorder
	canvas addShape: (self shapeClass new
		extent: 100 @ 100;
		withBorder;
		yourself).
	canvas createMorph drawOnMockCanvas.! !

!RSPBoundingTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new! !

!RSPBoundingTest class methodsFor: 'building suites' stamp: ''!
testParameters
	| m classesToConsider |
	m := ParametrizedTestMatrix new.
	classesToConsider := RSBoundingShape allSubclasses select: [ :c | c isAbstract not ].
	classesToConsider do: [ :cls | 
		m addCase: { (#shapeClass -> cls) }
	].
	^ m 
	! !

!RSPLinesTest methodsFor: 'tests' stamp: ''!
testDrawMarkers
	| line m |
	m := RSPolygon new 
		points: { -10@0. 0@ -10. 10@0 };
		color: Color black;
		size: 10.
	line := self shapeClass new
		startPoint: 50@50;
		endPoint: 250@50.
	line markerStart: m.
	canvas addShape: line.
	canvas createMorph drawOnMockCanvas.! !

!RSPLinesTest methodsFor: 'accessing' stamp: ''!
shapeClass: aClass
	"It is expected to have a subclass of RSAbstractLine"
	shapeClass := aClass! !

!RSPLinesTest methodsFor: 'accessing' stamp: ''!
shapeClass
	^ shapeClass! !

!RSPLinesTest methodsFor: 'tests' stamp: ''!
testDraw

	canvas addShape: (self shapeClass new
		strokeColor: Color red;
		width: 2). 
	canvas createMorph drawOnMockCanvas.! !

!RSPLinesTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new! !

!RSPLinesTest class methodsFor: 'building suites' stamp: ''!
testParameters
	| m classesToConsider |
	m := ParametrizedTestMatrix new.
	classesToConsider := RSAbstractLine allSubclasses select: [ :c | c isAbstract not ].
	classesToConsider do: [ :cls | 
		m addCase: { (#shapeClass -> cls) }
	].
	^ m 
	! !

!RSParallelAnimation commentStamp: ''!
I excecute my animations at the same time!
!RSParallelAnimation methodsFor: 'refreshing' stamp: ''!
step
	| activeAnimations activeSize |
	self startStep.
	activeAnimations := animations reject: [ :animation | animation hasCompleted ].
	activeSize := 0.
	activeAnimations do: [ :animation | 
		self startIfNessesary: animation.
		animation refresh.
		animation hasCompleted 
			ifTrue: [ animation remove ]
			ifFalse: [ activeSize := activeSize + 1 ] ].
	activeSize isZero ifTrue: [ self loopDone ].
	self updateHasCompleted.
	
	! !

!RSParallelAnimation methodsFor: 'accessing' stamp: ''!
duration
	animations ifEmpty: [ ^ 0 asDuration ].
	^ (animations collect: #allDuration) max! !

!RSParallelAnimation methodsFor: 'actions' stamp: ''!
pause
	super pause.
	animations do: #pause.! !

!RSParallelAnimation methodsFor: 'actions' stamp: ''!
continue
	super continue.
	animations do: #continue.! !

!RSParallelAnimation methodsFor: 'actions' stamp: ''!
start
	super start.
	animations do: [ :anime | self startIfNessesary: anime ]! !

!RSParallelAnimationTest methodsFor: 'tests' stamp: ''!
testParallelAnimationCreation
	self 
		createAnimationWith: [ canvas parallelAnimationFrom: {} ]
		animationClass: RSParallelAnimation.
	! !

!RSParallelAnimationTest methodsFor: 'tests' stamp: ''!
testAddingAnimations
	self 
		addingInComposite: canvas parallelAnimation
		duration: 2 second! !

!RSParallelAnimationTest methodsFor: 'tests' stamp: ''!
testStep
	| value animation |
	value := 0.
	animation := RSParallelAnimation new
		add: (RSTransitionAnimation new 
			onStepDo: [ :t| value := value + 1 ]);
		add: (RSTransitionAnimation new 
			onStepDo: [ :t| value := value + 1 ]);
		yourself.
	canvas addAnimation: animation.
	self assert: value equals: 0.
	canvas playAnimations.
	self assert: value equals: 2.! !

!RSParallelAnimationTest methodsFor: 'tests' stamp: ''!
testDuration 
	| animation |
	animation := RSParallelAnimation new.
	self assert: animation duration equals: 0 seconds.
	
	animation := RSParallelAnimation new
		add: (RSTransitionAnimation new duration: 2 seconds);
		add: (RSTransitionAnimation new duration: 4 seconds);
		yourself.
	self assert: animation duration equals: 4 seconds.
	self assert: animation allDuration equals: 4 seconds.
	
	animation := RSParallelAnimation new
		loops: 5;
		add: (RSTransitionAnimation new duration: 2 seconds; loops: 5);
		add: (RSTransitionAnimation new duration: 4 seconds);
		yourself.
	self assert: animation duration equals: 10 seconds.
	self assert: animation allDuration equals: 50 seconds.
	
	animation := RSParallelAnimation new
		repeat;
		add: (RSTransitionAnimation new duration: 2 seconds; repeat);
		add: (RSTransitionAnimation new duration: 4 seconds);
		yourself.
	self assert: animation duration equals: 4 seconds.
	self assert: animation allDuration equals: 4 seconds.! !

!RSParallelAnimationTest methodsFor: 'tests' stamp: ''!
testStepEvent
	| value loop animation |
	value := nil.
	loop := 0.
	animation := RSParallelAnimation new
		loops: 3;
		add: (RSTransitionAnimation new 
			duration: 100 milliSeconds;
			onStepDo: [ :t| value := t ]);
		when: RSAnimationLoopEvent do: [ :evt | loop := loop + 1.].
	canvas addAnimation: animation.
	self assert: value isNil.
	self assert: loop equals: 0.
	self assert: animation endTime isNil.
	self runAnimation: animation threshold: 500.
	self deny: value isNil.
	self assert: loop equals: 3.
	self deny: animation endTime isNil.
	self deny: animation isRunning.! !

!RSPharoMetricsProvider commentStamp: ''!
Old version of metrics provider used in Roassal2 with fonts. It is a little slow!
!RSPharoMetricsProvider methodsFor: 'hooks' stamp: ''!
extentsOf: aRSLabel
	| w h font text |
	font := aRSLabel font.
	text := aRSLabel text.
	w := (font widthOfString: text) asFloat.
	h := font height asFloat.
	^ RSTextExtents new
		width: w;
		height: h;
		x_advance: w;
		y_advance: h;
		x_bearing: 0;
		y_bearing: (h / 4) - h;
		yourself.! !

!RSPie commentStamp: ''!
I am the basic pie builder, check my examples.

About me 
* My shape is an "arc"... not really my shape is an instance of "RSShapeBuilder arc"
* the default background color of each arc even
* I use a layout to set the arcs position 
* I also have a #label to create labels around my arcs

.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=
| b classes |
classes := { Array. String. Dictionary. Set }.
b := RSPieBuilder new.
b objects: classes.
b slice: #numberOfMethods.s
b build.
b open
.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=.=!
!RSPie methodsFor: 'accessing - computed' stamp: ''!
betaAngleFor: aShape
	^ ((sumValues at: aShape index) + (values at: aShape index )) * 360 / totalSum.! !

!RSPie methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self sliceColor: [ :slice | 
		slice index even 
			ifTrue: [ Color lightGray ]
			ifFalse: [ Color gray ] ].
	sliceShape := RSPieSlice new
		segmentSpacing: 0;
		cornerRadii: 0;
		innerRadius: 0;
		externalRadius: 120.! !

!RSPie methodsFor: 'accessing' stamp: ''!
sliceColor
	^ sliceColor! !

!RSPie methodsFor: 'hooks' stamp: ''!
shapeFor: anObject
	| slice |
	slice := self sliceShape copy.
	slice
		model: anObject;
		color: (self sliceColor rsValue: slice);
		alphaAngle: (self alphaAngleFor: slice);
		betaAngle: (self betaAngleFor: slice);
		popup.
	^ slice! !

!RSPie methodsFor: 'accessing - computed' stamp: ''!
totalSum
	^ totalSum! !

!RSPie methodsFor: 'accessing' stamp: ''!
objects: someObjects
	objects := someObjects! !

!RSPie methodsFor: 'accessing' stamp: ''!
values
	^ values! !

!RSPie methodsFor: 'accessing' stamp: ''!
objects
	^ objects! !

!RSPie methodsFor: 'accessing' stamp: ''!
sliceShape
	"you can modify with simples values all atributes of slices except color and angles"
	"review #sliceColor and #slice:"
	^ sliceShape! !

!RSPie methodsFor: 'hooks' stamp: ''!
shapeFor: anObject index: index
	| slice |
	slice := self sliceShape copy.
	slice
		model: anObject;
		index: index;
		color: (self sliceColor rsValue: slice);
		alphaAngle: (self alphaAngleFor: slice);
		betaAngle: (self betaAngleFor: slice);
		popup.
	^ slice! !

!RSPie methodsFor: 'accessing' stamp: ''!
sliceColor: anObject
	"a block or object that can anwser rsValue:"
	sliceColor := anObject 
	! !

!RSPie methodsFor: 'accessing - computed' stamp: ''!
alphaAngleFor: aShape
	values ifNil: [ self slice: #yourself ].
	^ (sumValues at: aShape index) * 360 / totalSum.! !

!RSPie methodsFor: 'public' stamp: ''!
slice: aBlockOrASymbol
	"Set the way we give a pie share for each element."
	| tempSum |
	values := objects collect: [:m | aBlockOrASymbol value: m value ] as: Array.
	sumValues := Array new: objects size.
	tempSum := 0.
	values doWithIndex: [ :v :i |
		sumValues at: i put: tempSum.
		tempSum := tempSum + v
		 ].
	totalSum := tempSum.! !

!RSPieLabeledInteraction commentStamp: ''!
I can create labels for a pie builder and set the position acording to arc!
!RSPieLabeledInteraction methodsFor: 'accessing' stamp: ''!
labelShape
	^ labelShape! !

!RSPieLabeledInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self labelShape: RSLabel new.
	self labelColor: Color black.
	offset := 0.
	rotated := false.! !

!RSPieLabeledInteraction methodsFor: 'accessing' stamp: ''!
labelText
	^ labelText! !

!RSPieLabeledInteraction methodsFor: 'accessing' stamp: ''!
offset: aNumber
	offset := aNumber! !

!RSPieLabeledInteraction methodsFor: 'accessing - keys' stamp: ''!
labelKey
	^ #RSPieLabeledInteraction! !

!RSPieLabeledInteraction methodsFor: 'accessing' stamp: ''!
labelShape: aLabel
	labelShape := aLabel! !

!RSPieLabeledInteraction methodsFor: 'testing' stamp: ''!
isRotated
	^ rotated! !

!RSPieLabeledInteraction methodsFor: 'hooks' stamp: ''!
shapeFor: aPieSliceShape
	| res arc ang |
	arc := aPieSliceShape.
	res := labelShape copy
		text: (self labelText rsValue: arc model);
		color: (self labelColor rsValue: arc model);
		position: (arc centroid: self offset) + arc position;
		yourself.
	self isRotated ifFalse: [ ^ res ].
	ang := arc middleAngle.
	(ang between: 90 and: 270) ifTrue: [ ang := ang - 180 ].
	res rotateByDegrees: ang negated.
	^ res! !

!RSPieLabeledInteraction methodsFor: 'hooks' stamp: ''!
onShape: aShape
	| label parent |
	label := self shapeFor: aShape.
	aShape propertyAt: self labelKey put: label.
	parent := aShape parent.
	parent add: label.! !

!RSPieLabeledInteraction methodsFor: 'accessing' stamp: ''!
labelColor: aColor
	"can be a color, a block or color scale"
	"self labelColor: Color white"
	"self labelColor: [:model | model modelColor ]"
	"self labelColor: TSScale category20"
	labelColor := aColor! !

!RSPieLabeledInteraction methodsFor: 'accessing' stamp: ''!
offset
	^ offset! !

!RSPieLabeledInteraction methodsFor: 'accessing' stamp: ''!
labelColor
	^ labelColor! !

!RSPieLabeledInteraction methodsFor: 'accessing' stamp: ''!
labelText: anObject
	"can be an object or block"
	"self labelText: 'Hi'"
	"self labelText: [:model | 'The model: ', model asString]"
	labelText := anObject! !

!RSPieLabeledInteraction methodsFor: 'accessing' stamp: ''!
rotated
	rotated := true.! !

!RSPieSlice commentStamp: ''!
A ring shape to draw ring in a circle shape, not in a ellipse.
!
!RSPieSlice methodsFor: 'testing' stamp: ''!
includesPoint: aPoint
	| invertedPoint a b i e n d |
	invertedPoint := matrix rsInverseTransform: aPoint.
	(self baseRectangle containsPoint: invertedPoint)
		ifFalse: [ ^ false ].
	i := innerRadius.
	e := externalRadius.
	d := invertedPoint distanceTo: 0 @ 0.
	(d between: i and: e)
		ifFalse: [ ^ false ].
	n := invertedPoint angle negated radiansToDegrees.
	a := alphaAngle.
	b := betaAngle.
	n := (360 + (n % 360)) % 360.
	a := (3600000 + a) % 360.
	b := (3600000 + b) % 360.
	^ a < b
		ifTrue: [ n between: a and: b ]
		ifFalse: [ a <= n | (n <= b) ]! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
alphaAngle
	^ alphaAngle! !

!RSPieSlice methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	cornerRadii := innerRadius := externalRadius := betaAngle := alphaAngle := segmentSpacing := 0.
	! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
segmentSpacing
	^ segmentSpacing! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
betaAngle
	^ betaAngle! !

!RSPieSlice methodsFor: 'public' stamp: ''!
arcRadiusAuto
	| e i |
	e := externalRadius.
	i := innerRadius.
	self cornerRadii: ((i * i) + (e * e)) sqrt! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
innerRadius
	^ innerRadius! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
middleAngle
	^ (alphaAngle + betaAngle) / 2! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
betaAngle: ndAngle
	"Finishing angle"
	| old |
	old := betaAngle.
	betaAngle := ndAngle.
	old = betaAngle ifTrue: [ ^ self ].
	self resetPath.! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
shiftAngles: aNumber 
	self 
		alphaAngle: alphaAngle + aNumber;
		betaAngle: betaAngle + aNumber
	! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
centroid: off
	| r a |
	r := innerRadius isZero
		ifTrue: [ 0 ]
		ifFalse: [ (innerRadius + externalRadius)/2 ].
	r := r + off.
	a := self middleAngle degreesToRadians.
	^ (a cos @ (a sin negated) * r)  + self position.! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
innerRadius: iR
	| old |
	old := innerRadius.
	innerRadius := iR asFloat.
	old = innerRadius ifTrue: [ ^ self ].
	self resetPath.! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
cornerRadii
	^ cornerRadii! !

!RSPieSlice methodsFor: 'visiting' stamp: ''!
buildPathOn: visitor
	visitor buildRingPath: self! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
segmentSpacing: anAngleInDegrees
	| old |
	old := segmentSpacing.
	segmentSpacing := anAngleInDegrees.
	old = segmentSpacing ifTrue: [ ^self ].
	self resetPath.! !

!RSPieSlice methodsFor: 'utilities' stamp: ''!
emphasizeWith: anInteger 
	self translateBy: (self centroid: anInteger)! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
alphaAngle: stAngle
	"Starting angle"
	| old |
	old := alphaAngle.
	alphaAngle := stAngle.
	old = alphaAngle ifTrue: [ ^ self ].
	self resetPath.! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
externalRadius
	^ externalRadius! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
extent: aPoint
	super extent: aPoint.
	externalRadius := (aPoint x min: aPoint y)/2.! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
externalRadius: eR
	self extent: (eR * 2) asPoint.! !

!RSPieSlice methodsFor: 'accessing' stamp: ''!
cornerRadii: aNumber
	| old |
	self 
		assert: [ aNumber >= 0 ]
		description: 'Corner radius must be a non-negative!!'.
	old := cornerRadii.
	cornerRadii := aNumber.
	old = cornerRadii ifTrue: [ ^ self ].
	self resetPath.! !

!RSPieTitleInteraction commentStamp: ''!
I can add a basic title in a pie!
!RSPieTitleInteraction methodsFor: 'accessing' stamp: ''!
labelShape
	^ labelBuilder labelShape! !

!RSPieTitleInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	labelBuilder := RSMultilineLabelBuilder new.
	labelBuilder layout alignCenter.! !

!RSPieTitleInteraction methodsFor: 'accessing' stamp: ''!
labelText
	^ labelText! !

!RSPieTitleInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	| label |
	label := labelBuilder shapeFor: self labelText.
	aCanvas add: label.
	
	! !

!RSPieTitleInteraction methodsFor: 'accessing' stamp: ''!
labelText: aString
	labelText := aString! !

!RSPolyInterpolator commentStamp: ''!
linear := TSEasing poly exponent: 1.
quad := TSEasing poly exponent: 2.
cubic := TSEasing poly exponent: 3

TSEasing polyIn 
Polynomial easing; raises t to the specified exponent. If the exponent is not specified, it defaults to 3, equivalent to cubicIn.

TSEasing polyOut
Reverse polynomial easing; equivalent to 1 - polyIn(1 - t). If the exponent is not specified, it defaults to 3, equivalent to cubicOut.

TSEasing poly 
TSEasing polyInOut 
Symmetric polynomial easing; scales polyIn for t in [0, 0.5] and polyOut for t in [0.5, 1]. If the exponent is not specified, it defaults to 3, equivalent to cubic.!
!RSPolyInterpolator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self exponent: 3.! !

!RSPolyInterpolator methodsFor: 'accessing' stamp: ''!
exponent: aNumber
	exponent := aNumber! !

!RSPolyInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateIn: i
	^ i raisedTo: exponent.! !

!RSPolyInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateInOut: i
	| t |
	t := i * 2.
	^ (t <= 1
		ifTrue: [ t raisedTo: exponent ]
		ifFalse: [ 2 - ( ( 2 - t) raisedTo: exponent ) ]) / 2
	! !

!RSPolyInterpolator methodsFor: 'accessing' stamp: ''!
exponent
	^ exponent! !

!RSPolyInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateOut:  t
	^ 1 - ((1 -t) raisedTo: exponent).! !

!RSPolygon commentStamp: ''!
Define a polygon shape, ready to be added to a Roassal canvas.

For example:
```
c := RSCanvas new.

polygon := RSPolygon new
		points: { 0 @ -50 . 50 @ 0 . -50 @ 0 };
		color: 'FFAE0B'.
polygon cornerRadii: 5.
		

polygon2 := RSPolygon new
		points: { 0 @ -50 . 50 @ 0 . -50 @ 0 };
		color: Color red translucent.
		
polygon2 rotateByDegrees: 90.
polygon2 translateBy: 0 @ -50.

c add: polygon.
c add: polygon2.

c
```!
!RSPolygon methodsFor: 'testing' stamp: ''!
includesPoint: aPoint
	"Return true or false if a point is contained in the shape"
	| invertedPoint |
	invertedPoint := matrix rsInverseTransform: aPoint.
	^ (self baseRectangle containsPoint: invertedPoint)
		ifFalse: [ false ]
		ifTrue: [(AthensPolygonTester new 
			polygon: points) includesPoint: invertedPoint]! !

!RSPolygon methodsFor: 'private' stamp: ''!
centerPoints
	"Private method, should not be used externally"

	| r center |
	r := points 
		ifEmpty: [ 0@0 corner: 0@0 ]
		ifNotEmpty: [ Rectangle encompassing: points ].
	center := r floatCenter.
	points := points collect: [ :p | p - center ].
	^ r! !

!RSPolygon methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	points := #().! !

!RSPolygon methodsFor: 'accessing' stamp: ''!
points
	"Return the points defining the polygon"
	^ points! !

!RSPolygon methodsFor: 'geometry' stamp: ''!
geometry
	| rect e |
	rect := self encompassingRectangle.
	e := rect extent.
	e = (0@0) ifTrue: [ ^ rect floatCenter asGPoint ].
	^ GPolygon
		vertices: self points + self position! !

!RSPolygon methodsFor: 'testing' stamp: ''!
hasPoints
	^ points notNil and: [ points isNotEmpty ]! !

!RSPolygon methodsFor: 'accessing' stamp: ''!
points: anArray
	"Set the points used to draw the polygon."
	| rec |
	self privatePoints: anArray.
	rec := self centerPoints.
	self translateTo: rec floatCenter.
	super extent: rec extent! !

!RSPolygon methodsFor: 'accessing' stamp: ''!
cornerRadii 
	"Return the corner radii, indicating how smooth the polygon corners shoulid be"
	^ radius ifNil: [ 0 ]! !

!RSPolygon methodsFor: 'visiting' stamp: ''!
buildPathOn: visitor
	visitor buildPolygonPath: self! !

!RSPolygon methodsFor: 'private' stamp: ''!
extent: newExtent
	| min max s extent |
	self hasPoints 
		ifFalse: [ ^ self ].
	extent := baseRectangle extent.
	extent = newExtent
		ifTrue: [ ^ self ].
	min := Float fmax asPoint.
	max := Float fmin asPoint.
	points do: [ :p | 
		min := min min: p.
		max := max max: p ].
	s := newExtent / (max - min).
	points := points collect: [ :p | p * s ].
	super extent: newExtent! !

!RSPolygon methodsFor: 'private' stamp: ''!
privatePoints: anArray
	"Private method, should bot be used externally"
	points := anArray! !

!RSPolygon methodsFor: 'accessing' stamp: ''!
cornerRadii: aNumber
	"Set the corner radii. Has the effect to make corners smooth 
	For example:

c := RSCanvas new.

polygon := RSPolygon new
		points: { 0 @ -50 . 50 @ 0 . -50 @ 0 };
		color: 'FFAE0B'.
polygon cornerRadii: 5.
		

polygon2 := RSPolygon new
		points: { 0 @ -50 . 50 @ 0 . -50 @ 0 };
		color: Color red trans.
		
polygon2 rotateByDegrees: 90.
polygon2 translateBy: 0 @ -50.

c add: polygon.
c add: polygon2.

c

	"
	radius := aNumber abs.
	self resetPath.! !

!RSPolygon class methodsFor: 'utilities' stamp: ''!
generatePointsFitSquare: sides
	| points |
	points := self generateUnitNgonPoints: sides rotation: 0.
	points := self fitPolygonToSquare: points.
	^ points! !

!RSPolygon class methodsFor: 'utilities' stamp: ''!
fitPolygonToSquare: points
	| maxx minx maxy miny sx sy x y |
	minx := maxx :=  points first x.
	miny := maxy :=  points first y.
	points do: [ :p | 
		minx := minx min: p x.
		miny := miny min: p y.
		maxx := maxx max: p x.
		maxy := maxy max: p y ].
	"stretch factors"
	sx := 2/(maxx - minx).
	sy := 2/(maxy - miny).
	points doWithIndex: [ :p :i|
		x := p x * sx.
		y := p y * sy.
		points at: i put: x@y.
		minx := minx min: x.
		miny := miny min: y.
		maxx := maxx max: x.
		maxy := maxy max: y ].
	miny < -1 ifTrue: [ 
		points doWithIndex: [ :p :i |
			points at: i put: p x @ ( p y - 1 - miny ) ] ].
	^ points.! !

!RSPolygon class methodsFor: 'utilities' stamp: ''!
generateUnitNgonPoints: sides rotation: rotationAngle
	
	^ self generateUnitNgonPoints: sides  rotation: rotationAngle
		angle: [ :a :i | a negated ] 
		radius: [ :a :i | 1 ]! !

!RSPolygon class methodsFor: 'utilities' stamp: ''!
generateUnitNgonPoints: sides rotation: rotationAngle angle: angleBloc radius: radiusBloc
	"sides a Number
	rotation is a number in radians
	angle is a function of 2 args(current angle and index of angle) this return an angle
	radius is a function of 2 args (current angle and index of angle) this retunr a number "
	| increment startAngle points currentAngle currentRadius |
	increment := 1.0 / sides * 2 * Float pi.
	startAngle := sides even
		ifTrue: [ (Float pi / 2) + (increment / 2) ]
		ifFalse: [ Float pi / 2 ].
	startAngle := startAngle + rotationAngle.
	points := Array new: sides.
	0 to: sides - 1 do: [ :i | 
		currentAngle := i * increment + startAngle.
		currentAngle := angleBloc value: currentAngle value: i.
		currentRadius := radiusBloc value: currentAngle value: i.
		points at: i+1 put: (currentAngle cos @ currentAngle sin) * currentRadius ].
	^ points! !

!RSPolyline commentStamp: ''!
`RSPolyline` represents a line joining a number of points

```
c := RSCanvas new.

polyline := RSPolyline new.
polyline controlPoints: { 0@0 . 20@30 . 100@40 }.
c add: polyline.

c open
```!
!RSPolyline methodsFor: 'testing' stamp: ''!
basicIncludesPoint: aPoint
	"Answer whether any segment of this polyline includes aPoint."
	self controlPoints overlappingPairsDo: [ :a :b | 
		(aPoint onLineFrom: a to: b within: self includedRadius)
			ifTrue: [ ^ true ] ].
	^ false! !

!RSPolyline methodsFor: 'accessing' stamp: ''!
cornerRadii
	^ radius ifNil: [ 0 ].! !

!RSPolyline methodsFor: 'visiting' stamp: ''!
buildPathOn: visitor
	visitor buildPolylinePath: self! !

!RSPolyline methodsFor: 'accessing' stamp: ''!
cornerRadii: aNumber
	radius := aNumber abs.
	self resetPath.! !

!RSPopup commentStamp: ''!
I can add a popup on an element when a move over event occurs.

Here is an example:
```
c := RSCanvas new.

classes := RSObject withAllSubclasses.

scale := NSScale linear
domain: { (classes collect: #numberOfMethods) min . (classes collect: #numberOfMethods) max};
range: { 'red'. 'blue' }.

classes do: [ :cls |
| b |
b := RSEllipse new.
b size: cls numberOfMethods.
b color: (scale scale: cls numberOfMethods).
b model: cls.
b @ RSPopup.
c add: b ].

RSFlowLayout on: c shapes.

c @ RSCanvasController
```

Per default, `RSPopup` gives a label as a popup. However, it may be easily customized by using `shapeBuilder:`, which takes a one-argument-block and must return a shape or a composite shape. Consider: 

```
canvas := RSCanvas new.

shapes := RSLabel models: (1 to: 10).
canvas addAll: shapes.
RSGridLayout on: shapes.

popup := RSPopup new.
popup shapeBuilder: [ :aNumber |
	| g |
	g := RSGroup new.
	g addAll: (RSCircle models: (1 to: aNumber)).
	RSGridLayout on: g.
	g asShape 
		color: Color white darker darker;
		padding: 5.
].
shapes @ popup.

canvas zoomToFit.
```

Anoter example, more complex:

```
packages := RPackageOrganizer default packages select: [ :rPak | rPak packageName beginsWith: 'Roassal3' ].

canvas := RSCanvas new.
shapes := RSBox models: packages.
canvas addAll: shapes.

shapes @ RSDraggable.

RSNormalizer size
	shapes: shapes;
	from: 5; to: 20;
	normalize: [ :rPackage | rPackage definedClasses size ].

lb := RSLineBuilder line.
lb shape color: Color gray translucent.
lb moveBehind.
lb shapes: shapes.
lb connectToAll: #dependentPackages.

popup := RSPopup new.
popup shapeBuilder: [ :package |
	| g nodes lbl |
	g := RSGroup new.
	nodes := RSBox models: package definedClasses.
	nodes color: Color blue.
	g addAll: nodes.
	tlb := RSLineBuilder orthoVertical.
	tlb canvas: g.
	tlb shapes: nodes.
	tlb connectFrom: #superclass.
	RSTreeLayout on: nodes.
	lbl := RSLabel text: package packageName.
	g add: lbl.
	RSLocation move: lbl above: nodes.
	g asShape 
		color: Color white darker translucent; 
		borderColor: #black;
		padding: 3.
].
shapes @ popup.

shapes @ RSHighlightable red withOutgoingLines.
shapes @ RSHighlightable green incomingLines.

RSForceBasedLayout new charge: -800; on: shapes.
canvas @ RSCanvasController.
```!
!RSPopup methodsFor: 'hooks' stamp: ''!
createPopupFor: aShape event: event
	| popupShape |
	popupShape := shapeBuilder shapeFor: (self modelFor: aShape).
	popupShape isFixed: true.
	event canvas addShape: popupShape.
	^ popupShape.! !

!RSPopup methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self model: #model.
	shapeBuilder := RSSimplePopupBuilder new.! !

!RSPopup methodsFor: 'accessing' stamp: ''!
text: oneArgBlock
	"The block is evaluated with the model provided as argument"
	self shapeBuilder textBlock: oneArgBlock! !

!RSPopup methodsFor: 'hooks' stamp: ''!
translatePopup: popup event: evt 
	| p e extent |
	p := evt camera fromSpaceToPixel: evt position.
	extent := popup canvas extent.
	e := (popup extent /2) + 5.
	p x + popup width > extent x ifTrue: [ 
		e := e x negated @ e y.
		p x - popup width < 0
		ifTrue: [ e := p x negated + (popup width/2 + 4) @ e y ].
		].
	p y + popup height > extent y ifTrue: [ 
		e := e x @ e y negated.
		p y - popup height < 0
		ifTrue: [ e := e x @ ( p y negated + (popup height/2 + 4) ) ]
		]. 
	popup translateTo: p + e.! !

!RSPopup methodsFor: 'hooks' stamp: ''!
releasePopup: popup
	popup remove! !

!RSPopup methodsFor: 'accessing' stamp: ''!
shapeBuilder: aShapeBuilder
	"Let one customize the way the popup is generated. The method accept a shape builder or a one-argument-block. For example:
	
```
canvas := RSCanvas new.

shapes := RSLabel models: (1 to: 10).
canvas addAll: shapes.
RSGridLayout on: shapes.

popup := RSPopup new.
popup shapeBuilder: [ :aNumber |
	| g |
	g := RSGroup new.
	g addAll: (RSCircle models: (1 to: aNumber)).
	RSGridLayout on: g.
	g asShape 
		color: Color white darker darker;
		padding: 5.
].
shapes @ popup.

canvas zoomToFit.
canvas open
```"
	shapeBuilder := aShapeBuilder! !

!RSPopup methodsFor: 'accessing' stamp: ''!
modelFor: aRSShape
	^ modelBlock rsValue: aRSShape! !

!RSPopup methodsFor: 'accessing' stamp: ''!
shapeBuilder
	^ shapeBuilder! !

!RSPopup methodsFor: 'accessing' stamp: ''!
model: anObject
	"
	- can be a one arg BlockClosure 
	- can be a ByteString
	"
	modelBlock := anObject.! !

!RSPopup methodsFor: 'accessing' stamp: ''!
model
	^ modelBlock! !

!RSPopup class methodsFor: 'accessing' stamp: ''!
text: aStringOrOneArgBlock
	"Define a Popup interaction with a particular text. The argument can either be a text, a symbol, or a one-argument block that is evaluated on the model object of the shape. For example:
```
canvas := RSCanvas new.

someColors := { Color red . Color blue . Color green }.
shapes := RSGroup new.
someColors do: [ :aColor | 
	shapes add: (RSEllipse new size: 30; model: aColor; color: aColor) ].

canvas addAll: shapes.

shapes @ RSDraggable.
shapes @ RSLabeled highlightable.
shapes @ (RSPopup text: [ :aColor | 'My color is ', aColor asString]).

RSHorizontalLineLayout on: shapes.

canvas @ RSCanvasController.
canvas open.
```
	"
	| inst |
	inst := self new.
	inst shapeBuilder textBlock: aStringOrOneArgBlock.
	^ inst! !

!RSPopupDecoration commentStamp: ''!
I am a popup decoration for instances of line Plots in RSChart by default but you can customize this popup decoration with differents shapebuilders, or popups!
!RSPopupDecoration methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	popup := RSChartPopupDecoration new
		chartPopupBuilder: RSSimpleChartPopupBuilder new;
		markersPopupBuilder: RSSimpleMarkerPopupBuilder new;
		yourself.! !

!RSPopupDecoration methodsFor: 'accessing' stamp: ''!
popup: aRSPopup
	popup := aRSPopup! !

!RSPopupDecoration methodsFor: 'accessing' stamp: ''!
popup
	^ popup! !

!RSPopupDecoration methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	| box |
	box := chart decorations first shape.
	popup chart: chart.
	box addInteraction: popup.! !

!RSPopupDecoration methodsFor: 'accessing' stamp: ''!
createdShapes
	^ #()! !

!RSPopupDecoration methodsFor: 'accessing' stamp: ''!
chartPopupBuilder: aRSAbstractChartPopupBuilder
	self popup chartPopupBuilder: aRSAbstractChartPopupBuilder! !

!RSPopupDecoration methodsFor: 'accessing' stamp: ''!
chartPopupBuilder
	^ self popup chartPopupBuilder! !

!RSPopupTest methodsFor: 'tests' stamp: ''!
testMultiline
	shapes @ RSPopup.
	self assert: canvas fixedShapes size equals: 0 .
	
	shapes last announce: RSMouseMove.
	self assert: canvas numberOfShapes equals: shapes size.
	self assert: canvas fixedShapes size equals: 1.
	self assert: canvas fixedShapes first shapes second shapes size equals: 2! !

!RSPopupTest methodsFor: 'tests' stamp: ''!
testPopupWithoutMouseLeave
	"Test created while debugging https://github.com/ObjectProfile/Roassal3/issues/150"
	| c |
	c := RSCanvas new.
	shapes := (1 to: 30) collect: [ :v | RSEllipse new  model: v; size: 10 ] as: RSGroup.
	shapes @ RSPopup.
	c addAll: shapes.

	RSLineBuilder line
	    canvas: c;
	    withBorderAttachPoint;
	    connectFrom: [ :v | v // 2 ].

	RSTreeLayout on: shapes.
"	c edges pushBack."
	c @ RSCanvasController.

	self assert: c numberOfShapes equals: 59.
	self assert: c fixedShapes size equals: 3.
	shapes first announce: RSMouseMove.
	self assert: shapes first model equals: 1.
	self assert: c numberOfShapes equals: 59.
	self assert: c fixedShapes size equals: 4.
	self assert: c fixedShapes last children last text equals: '1'.
	
	"Note that we do not announce RSMouseLeave"
	shapes second announce: RSMouseMove.
	self assert: c fixedShapes size equals: 4.
	self assert: c fixedShapes last children last text equals: '2'.! !

!RSPopupTest methodsFor: 'tests' stamp: ''!
testWithPopup
	shapes @ RSPopup.
	self assert: canvas fixedShapes size equals: 0 .
	
	shapes first announce: RSMouseMove.
	self assert: canvas numberOfShapes equals: shapes size.
	self assert: canvas fixedShapes size equals: 1.! !

!RSPopupTest methodsFor: 'tests' stamp: ''!
testNoPopup
	shapes first announce: RSMouseEnter.
	self assert: canvas numberOfShapes equals: shapes size.! !

!RSPopupTest methodsFor: 'tests' stamp: ''!
testPopupOnElementNotAddedToAView
	| b |
	b := RSBox new.
	b @ RSPopup.
	b announce: RSMouseEnter.
	"Should not produce an error"! !

!RSPopupTest methodsFor: 'tests' stamp: ''!
testPopup
	"Test created while debugging https://github.com/ObjectProfile/Roassal3/issues/150"
	| c |
	c := RSCanvas new.
	shapes := (1 to: 30) collect: [ :v | RSEllipse new  model: v; size: 10 ] as: RSGroup.
	shapes @ RSPopup.
	c addAll: shapes.

	RSLineBuilder line
	    canvas: c;
	    withBorderAttachPoint;
	    connectFrom: [ :v | v // 2 ].

	RSTreeLayout on: shapes.
"	c edges pushBack."
	c @ RSCanvasController.

	self assert: c numberOfShapes equals: 59.
	self assert: c fixedShapes size equals: 3.
	shapes first announce: RSMouseMove.
	self assert: shapes first model equals: 1.
	self assert: c numberOfShapes equals: 59.
	self assert: c fixedShapes size equals: 4.
	self assert: c fixedShapes last children last text equals: '1'.
	
	shapes first announce: RSMouseLeave.
	
	shapes second announce: RSMouseMove.
	self assert: c fixedShapes size equals: 4.
	self assert: c fixedShapes last children last text equals: '2'.! !

!RSPopupTest methodsFor: 'tests' stamp: ''!
testPopupSimple
	| c s |
	c := RSCanvas new.
	s := RSEllipse new size: 10; model: 42.
	s @ RSPopup.
	c add: s.

	self assert: c numberOfShapes equals: 1.
	self assert: c fixedShapes isEmpty.
	c shapes first announce: RSMouseMove.
	self assert: c shapes first model equals: 42.
	self assert: c numberOfShapes equals: 1.
	self assert: c fixedShapes size equals: 1.
	self assert: c fixedShapes first children second text equals: '42'! !

!RSPopupTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new.
	shapes := #(1 2) collect: [ :m | RSBox new model: m; yourself ] as: RSGroup.
	shapes addLast: (RSBox new
		model: 'Foo
bar';
		yourself).
	canvas addAll: shapes! !

!RSPositionChangedEvent commentStamp: ''!
When the shape uses translateBy: or translateTo:, position: does not trigger this event!
!RSPositionChangedEvent methodsFor: 'accessing' stamp: ''!
newPosition: aPoint
	newPosition := aPoint! !

!RSPositionChangedEvent methodsFor: 'accessing' stamp: ''!
oldPosition: aPoint
	oldPosition := aPoint! !

!RSPositionChangedEvent methodsFor: 'accessing' stamp: ''!
newPosition
	^ newPosition! !

!RSPositionChangedEvent methodsFor: 'accessing' stamp: ''!
oldPosition
	^ oldPosition! !

!RSPunchCardBuilder commentStamp: ''!
I am an example!
!RSPunchCardBuilder methodsFor: 'accessing - defaults' stamp: ''!
defaultContainer
	^ RSCanvas new @ RSCanvasController! !

!RSPunchCardBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	metrics := OrderedDictionary new.
	size := 10.! !

!RSPunchCardBuilder methodsFor: 'accessing' stamp: ''!
metrics
	^ metrics! !

!RSPunchCardBuilder methodsFor: 'hooks' stamp: ''!
renderDots: aCanvas
	| base |
	base := RSEllipse new popup.
	objects
		doWithIndex: [ :cls :x | 
			metrics keys
				doWithIndex: [ :k :y | 
					| metric res |
					metric := metrics at: k.
					res := metric rsValue: cls.
					aCanvas
						add:
							(base copy
								model: res;
								position: x @ y * size;
								size: (res + 1) ln + 1;
								announcer: base announcer) ] ]! !

!RSPunchCardBuilder methodsFor: 'hooks' stamp: ''!
renderIn: aCanvas
	self 
	renderDots: aCanvas;
	renderXAxis: aCanvas;
	renderYAxis: aCanvas.! !

!RSPunchCardBuilder methodsFor: 'hooks' stamp: ''!
renderYAxis: aCanvas
	| labels |
	labels := metrics keys collectWithIndex: [ :k :i |
		(self labelFor: k)
			position: 0@ i * size;
			yourself ].
	RSAlignment new
		shapes: labels;
		right.
	aCanvas addAll: labels! !

!RSPunchCardBuilder methodsFor: 'accessing' stamp: ''!
objects: aCollection
	objects := aCollection! !

!RSPunchCardBuilder methodsFor: 'accessing' stamp: ''!
objects
	^ objects! !

!RSPunchCardBuilder methodsFor: 'accessing' stamp: ''!
addMetric: aRoassalValue name: name
	metrics at: name put: aRoassalValue.! !

!RSPunchCardBuilder methodsFor: 'hooks' stamp: ''!
renderXAxis: aCanvas
	| labels |
	labels := objects
		collectWithIndex: [ :cls :x | 
			| label |
			label := (self labelFor: cls) rotateByDegrees: -90.
			label position: x @ 0 * size.
			label ].
	RSAlignment new
		shapes: labels;
		bottom.
	aCanvas addAll: labels! !

!RSPunchCardBuilder methodsFor: 'hooks' stamp: ''!
labelFor: obj
	^ RSLabel new
		text: obj;
		scaleBy: 0.2;
		yourself! !

!RSQuadInterpolator commentStamp: ''!
TSEasing quadIn
Quadratic easing. Equivalent to: TSEasing polyIn exponent: 2

TSEasing quadOut
Reverse quadratic easing. Equivalent to 1 - (1 - t) quadIn. Also equivalent to: TSEasing polyOut exponent: 2.

TSEasing quad 
TSEasing quadInOut 
Symmetric quadratic easing; scales quadIn for t in [0, 0.5] and quadOut for t in [0.5, 1].
Also equivalent to TSEasing poly exponent: 2.!
!RSQuadInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateIn: t
	 ^ t*t! !

!RSQuadInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateInOut: i
	| t |
	t := i *2.
	^ (t <= 1 
		ifTrue: [ t*t ]
		ifFalse: [ 
			t := t-1.
			t * (2- t)+1 ]) /2
	! !

!RSQuadInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateOut: t
	^ t * (2 - t)! !

!RSQuadTreeF commentStamp: ''!
TODO!
!RSQuadTreeF methodsFor: 'accessing' stamp: ''!
soleChild
	^ soleChild! !

!RSQuadTreeF methodsFor: 'adding' stamp: ''!
add: aNode
	leaf
		ifTrue: [
			soleChild isNil
				ifTrue: [ soleChild := aNode ]
				ifFalse: [
					(soleChild position closeTo: aNode position)
						ifTrue: [ self addChild: aNode ]
						ifFalse: [
							| firstChild |
							firstChild := soleChild.
							soleChild := nil.
							self
								addChild: aNode;
								addChild: firstChild ] ] ]
		ifFalse: [ self addChild: aNode ]
! !

!RSQuadTreeF methodsFor: 'accessing' stamp: ''!
centerOfCharge
	^ centerOfCharge! !

!RSQuadTreeF methodsFor: 'initialize-release' stamp: ''!
initialize 
	super initialize.
	
	leaf := true.
! !

!RSQuadTreeF methodsFor: 'accessing' stamp: ''!
rectangle: aRectangle 
	rectangle := aRectangle! !

!RSQuadTreeF methodsFor: 'testing' stamp: ''!
isLeaf
	^ leaf! !

!RSQuadTreeF methodsFor: 'accessing' stamp: ''!
charge: anObject
	charge := anObject! !

!RSQuadTreeF methodsFor: 'accessing' stamp: ''!
charge
	^ charge! !

!RSQuadTreeF methodsFor: 'accessing' stamp: ''!
rectangle
	^ rectangle! !

!RSQuadTreeF methodsFor: 'accessing' stamp: ''!
subQuadsDo: aBlockClosure
  northWestQuad ifNotNil: aBlockClosure.
  northEastQuad ifNotNil: aBlockClosure.
  southWestQuad ifNotNil: aBlockClosure.
  southEastQuad ifNotNil: aBlockClosure.
! !

!RSQuadTreeF methodsFor: 'adding' stamp: ''!
addChild: aNode
	| s origin corner |
	leaf := false.
	s := rectangle floatCenter.
	origin := rectangle origin.
	corner := rectangle corner.

	aNode position x < s x
		ifTrue: [
			aNode position y < s y
				ifTrue: [
					northWestQuad ifNil: [ 
						northWestQuad := RSQuadTreeF new
							rectangle: (origin corner: s);
							yourself ].
					northWestQuad add: aNode ]
				ifFalse: [
					southWestQuad ifNil: [ 
						southWestQuad := RSQuadTreeF new
							rectangle: ((origin x @ s y ) corner: (s x @ corner y));
							yourself ].
					southWestQuad add: aNode ] ]
		ifFalse: [
			aNode position y < s y
				ifTrue: [
					northEastQuad ifNil: [
						northEastQuad := RSQuadTreeF new
							rectangle: ((s x @ origin y) corner: (corner x @ s y));
							yourself ].
					northEastQuad add: aNode ]
				ifFalse: [
					southEastQuad ifNil: [ 
						southEastQuad := RSQuadTreeF new
							rectangle: (s corner: corner);
							yourself ].
					southEastQuad add: aNode ] ]
! !

!RSQuadTreeF methodsFor: 'accessing' stamp: ''!
centerOfCharge: aPoint
	centerOfCharge := aPoint! !

!RSQuadTreeF class methodsFor: 'public' stamp: ''!
withAll: aNodeCollection rectangle: rectangle
	
	| root extent |
	extent := rectangle extent.

	(extent x closeTo: extent y) ifTrue: [ 
		root := self new.
		root rectangle: rectangle.
		aNodeCollection do: [ :e | root add: e ].
		^ root ].
	
	^ extent x > extent y
		ifTrue: [ 
			self 
				withAll: aNodeCollection
				rectangle: (rectangle origin corner: rectangle corner x @ (extent x + rectangle origin y)) ]
		ifFalse: [
			self 
				withAll: aNodeCollection
				rectangle: (rectangle origin corner: (extent y + rectangle origin x) @ rectangle corner y) ]

! !

!RSQuadTreeF class methodsFor: 'public' stamp: ''!
withAll: aNodeCollection
	^ self
		withAll: aNodeCollection
		rectangle: (Rectangle encompassing: (aNodeCollection collect: #position))! !

!RSQualitativeColorPalette commentStamp: ''!
Qualitative schemes do not imply magnitude differences between legend classes, and hues are used to create the primary visual differences between classes. Qualitative schemes are best suited to representing nominal or categorical data.

More info: 
http://colorbrewer2.org/learnmore/schemes_full.html#qualitative

---Copyright:
All colors, palettes and schemes are from www.ColorBrewer.org by Cynthia A. Brewer, Geography, Pennsylvania State University.
Code by Cynthia is under the Apache License 2.0 (https://github.com/axismaps/colorbrewer/blob/master/LICENCE.txt)
Roassal3 is distributed under the MIT License, which is compatible with Apache License 2.0 

FalutUI1 color scheme come from: http://flatuicolors.com/!
!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
paired5
	^ self fromTriplet: #(#(166 206 227) #(31 120 180) #(178 223 138) #(51 160 44) #(251 154 153))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui13
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set19
	^ self fromTriplet: #(#(228 26 28) #(55 126 184) #(77 175 74) #(152 78 163) #(255 127 0) #(255 255 51) #(166 86 40) #(247 129 191) #(153 153 153))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set23
	^ self fromTriplet: #(#(102 194 165) #(252 141 98) #(141 160 203))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set25
	^ self fromTriplet: #(#(102 194 165) #(252 141 98) #(141 160 203) #(231 138 195) #(166 216 84))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
paired3
	^ self fromTriplet: #(#(166 206 227) #(31 120 180) #(178 223 138))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set15
	^ self fromTriplet: #(#(228 26 28) #(55 126 184) #(77 175 74) #(152 78 163) #(255 127 0))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
accent5
	^ self fromTriplet: #(#(127 201 127) #(190 174 212) #(253 192 134) #(255 255 153) #(56 108 176))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set18
	^ self fromTriplet: #(#(228 26 28) #(55 126 184) #(77 175 74) #(152 78 163) #(255 127 0) #(255 255 51) #(166 86 40) #(247 129 191))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui112
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80) #(241 196 15) #(230 126 34))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel28
	^ self fromTriplet: #(#(179 226 205) #(253 205 172) #(203 213 232) #(244 202 228) #(230 245 201) #(255 242 174) #(241 226 204) #(204 204 204))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set33
	^ self fromTriplet: #(#(141 211 199) #(255 255 179) #(190 186 218))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set36
	^ self fromTriplet: #(#(141 211 199) #(255 255 179) #(190 186 218) #(251 128 114) #(128 177 211) #(253 180 98))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
dark28
	^ self fromTriplet: #(#(27 158 119) #(217 95 2) #(117 112 179) #(231 41 138) #(102 166 30) #(230 171 2) #(166 118 29) #(102 102 102))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
dark25
	^ self fromTriplet: #(#(27 158 119) #(217 95 2) #(117 112 179) #(231 41 138) #(102 166 30))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
dark24
	^ self fromTriplet: #(#(27 158 119) #(217 95 2) #(117 112 179) #(231 41 138))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel17
	^ self fromTriplet: #(#(251 180 174) #(179 205 227) #(204 235 197) #(222 203 228) #(254 217 166) #(255 255 204) #(229 216 189))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set27
	^ self fromTriplet: #(#(102 194 165) #(252 141 98) #(141 160 203) #(231 138 195) #(166 216 84) #(255 217 47) #(229 196 148))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
accent7
	^ self fromTriplet: #(#(127 201 127) #(190 174 212) #(253 192 134) #(255 255 153) #(56 108 176) #(240 2 127) #(191 91 23))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel19
	^ self fromTriplet: #(#(251 180 174) #(179 205 227) #(204 235 197) #(222 203 228) #(254 217 166) #(255 255 204) #(229 216 189) #(253 218 236) #(242 242 242))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
dark23
	^ self fromTriplet: #(#(27 158 119) #(217 95 2) #(117 112 179))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui18
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set24
	^ self fromTriplet: #(#(102 194 165) #(252 141 98) #(141 160 203) #(231 138 195))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel15
	^ self fromTriplet: #(#(251 180 174) #(179 205 227) #(204 235 197) #(222 203 228) #(254 217 166))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
paired6
	^ self fromTriplet: #(#(166 206 227) #(31 120 180) #(178 223 138) #(51 160 44) #(251 154 153) #(227 26 28))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set37
	^ self fromTriplet: #(#(141 211 199) #(255 255 179) #(190 186 218) #(251 128 114) #(128 177 211) #(253 180 98) #(179 222 105))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set16
	^ self fromTriplet: #(#(228 26 28) #(55 126 184) #(77 175 74) #(152 78 163) #(255 127 0) #(255 255 51))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel16
	^ self fromTriplet: #(#(251 180 174) #(179 205 227) #(204 235 197) #(222 203 228) #(254 217 166) #(255 255 204))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set311
	^ self fromTriplet: #(#(141 211 199) #(255 255 179) #(190 186 218) #(251 128 114) #(128 177 211) #(253 180 98) #(179 222 105) #(252 205 229) #(217 217 217) #(188 128 189) #(204 235 197))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
paired9
	^ self fromTriplet: #(#(166 206 227) #(31 120 180) #(178 223 138) #(51 160 44) #(251 154 153) #(227 26 28) #(253 191 111) #(255 127 0) #(202 178 214))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel24
	^ self fromTriplet: #(#(179 226 205) #(253 205 172) #(203 213 232) #(244 202 228))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
paired11
	^ self fromTriplet: #(#(166 206 227) #(31 120 180) #(178 223 138) #(51 160 44) #(251 154 153) #(227 26 28) #(253 191 111) #(255 127 0) #(202 178 214) #(106 61 154) #(255 255 153))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui15
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set26
	^ self fromTriplet: #(#(102 194 165) #(252 141 98) #(141 160 203) #(231 138 195) #(166 216 84) #(255 217 47))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set13
	^ self fromTriplet: #(#(228 26 28) #(55 126 184) #(77 175 74))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set28
	^ self fromTriplet: #(#(102 194 165) #(252 141 98) #(141 160 203) #(231 138 195) #(166 216 84) #(255 217 47) #(229 196 148) #(179 179 179))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set34
	^ self fromTriplet: #(#(141 211 199) #(255 255 179) #(190 186 218) #(251 128 114))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel13
	^ self fromTriplet: #(#(251 180 174) #(179 205 227) #(204 235 197))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui114
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80) #(241 196 15) #(230 126 34) #(231 76 60) #(236 240 241))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui115
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80) #(241 196 15) #(230 126 34) #(231 76 60) #(236 240 241) #(149 165 166))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set310
	^ self fromTriplet: #(#(141 211 199) #(255 255 179) #(190 186 218) #(251 128 114) #(128 177 211) #(253 180 98) #(179 222 105) #(252 205 229) #(217 217 217) #(188 128 189))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui117
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80) #(241 196 15) #(230 126 34) #(231 76 60) #(236 240 241) #(149 165 166) #(243 156 18) #(211 84 0))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui110
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel18
	^ self fromTriplet: #(#(251 180 174) #(179 205 227) #(204 235 197) #(222 203 228) #(254 217 166) #(255 255 204) #(229 216 189) #(253 218 236))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui113
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80) #(241 196 15) #(230 126 34) #(231 76 60))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
dark26
	^ self fromTriplet: #(#(27 158 119) #(217 95 2) #(117 112 179) #(231 41 138) #(102 166 30) #(230 171 2))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set17
	^ self fromTriplet: #(#(228 26 28) #(55 126 184) #(77 175 74) #(152 78 163) #(255 127 0) #(255 255 51) #(166 86 40))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui16
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui19
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set14
	^ self fromTriplet: #(#(228 26 28) #(55 126 184) #(77 175 74) #(152 78 163))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel27
	^ self fromTriplet: #(#(179 226 205) #(253 205 172) #(203 213 232) #(244 202 228) #(230 245 201) #(255 242 174) #(241 226 204))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel26
	^ self fromTriplet: #(#(179 226 205) #(253 205 172) #(203 213 232) #(244 202 228) #(230 245 201) #(255 242 174))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
accent4
	^ self fromTriplet: #(#(127 201 127) #(190 174 212) #(253 192 134) #(255 255 153))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set39
	^ self fromTriplet: #(#(141 211 199) #(255 255 179) #(190 186 218) #(251 128 114) #(128 177 211) #(253 180 98) #(179 222 105) #(252 205 229) #(217 217 217))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui119
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80) #(241 196 15) #(230 126 34) #(231 76 60) #(236 240 241) #(149 165 166) #(243 156 18) #(211 84 0) #(192 57 43) #(189 195 199))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
paired12
	^ self fromTriplet: #(#(166 206 227) #(31 120 180) #(178 223 138) #(51 160 44) #(251 154 153) #(227 26 28) #(253 191 111) #(255 127 0) #(202 178 214) #(106 61 154) #(255 255 153) #(177 89 40))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
accent6
	^ self fromTriplet: #(#(127 201 127) #(190 174 212) #(253 192 134) #(255 255 153) #(56 108 176) #(240 2 127))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
paired7
	^ self fromTriplet: #(#(166 206 227) #(31 120 180) #(178 223 138) #(51 160 44) #(251 154 153) #(227 26 28) #(253 191 111))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel23
	^ self fromTriplet: #(#(179 226 205) #(253 205 172) #(203 213 232))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel25
	^ self fromTriplet: #(#(179 226 205) #(253 205 172) #(203 213 232) #(244 202 228) #(230 245 201))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set35
	^ self fromTriplet: #(#(141 211 199) #(255 255 179) #(190 186 218) #(251 128 114) #(128 177 211))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui116
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80) #(241 196 15) #(230 126 34) #(231 76 60) #(236 240 241) #(149 165 166) #(243 156 18))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
paired10
	^ self fromTriplet: #(#(166 206 227) #(31 120 180) #(178 223 138) #(51 160 44) #(251 154 153) #(227 26 28) #(253 191 111) #(255 127 0) #(202 178 214) #(106 61 154))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui111
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80) #(241 196 15))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
accent3
	^ self fromTriplet: #(#(127 201 127) #(190 174 212) #(253 192 134))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
paired8
	^ self fromTriplet: #(#(166 206 227) #(31 120 180) #(178 223 138) #(51 160 44) #(251 154 153) #(227 26 28) #(253 191 111) #(255 127 0))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui14
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
paired4
	^ self fromTriplet: #(#(166 206 227) #(31 120 180) #(178 223 138) #(51 160 44))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
accent8
	^ self fromTriplet: #(#(127 201 127) #(190 174 212) #(253 192 134) #(255 255 153) #(56 108 176) #(240 2 127) #(191 91 23) #(102 102 102))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set38
	^ self fromTriplet: #(#(141 211 199) #(255 255 179) #(190 186 218) #(251 128 114) #(128 177 211) #(253 180 98) #(179 222 105) #(252 205 229))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
pastel14
	^ self fromTriplet: #(#(251 180 174) #(179 205 227) #(204 235 197) #(222 203 228))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui118
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80) #(241 196 15) #(230 126 34) #(231 76 60) #(236 240 241) #(149 165 166) #(243 156 18) #(211 84 0) #(192 57 43))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
dark27
	^ self fromTriplet: #(#(27 158 119) #(217 95 2) #(117 112 179) #(231 41 138) #(102 166 30) #(230 171 2) #(166 118 29))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
set312
	^ self fromTriplet: #(#(141 211 199) #(255 255 179) #(190 186 218) #(251 128 114) #(128 177 211) #(253 180 98) #(179 222 105) #(252 205 229) #(217 217 217) #(188 128 189) #(204 235 197) #(255 237 111))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui120
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96) #(41 128 185) #(142 68 173) #(44 62 80) #(241 196 15) #(230 126 34) #(231 76 60) #(236 240 241) #(149 165 166) #(243 156 18) #(211 84 0) #(192 57 43) #(189 195 199) #(127 140 141))! !

!RSQualitativeColorPalette methodsFor: 'palette' stamp: ''!
flatui17
	^ self fromTriplet: #(#(26 188 156) #(46 204 113) #(52 152 219) #(155 89 182) #(52 73 94) #(22 160 133) #(39 174 96))! !

!RSQualitativeColorPalette class methodsFor: 'accessing' stamp: ''!
paletteName
	^ #qualitative! !

!RSRadialTreeLayout commentStamp: ''!
TODO!
!RSRadialTreeLayout methodsFor: 'hook' stamp: ''!
computeGap: aNode
	" compute the vertical gap needed for drawing the radial tree "
	| gap maxAbcissa i abc nodeL nodeR layer |	
	gap := 0.
	maxAbcissa := 0.
	layer := 1.
	
	i := 1.
	[ nodeL :=(self followLeftContour: aNode toLayer: i).
	nodeR := (self followRightContour: aNode toLayer: i).
	nodeL isNil not & nodeR isNil not ] whileTrue: [ abc := (((self getAbcissaOf: nodeR inSubtreeFromLayer: 0) - (self getAbcissaOf: nodeL inSubtreeFromLayer: 0 ) + (horizontalGap / layer/2)) / layer).
																	(abc > maxAbcissa) ifTrue: [ maxAbcissa := abc. 
																								layer := layer ].
																	i := i + 1 ].

	
	gap:= (maxAbcissa / 2 /Float pi ) floor +1.
	
	((verticalGap isNil) or: [gap > verticalGap])  ifTrue: [ self verticalGap: gap ]! !

!RSRadialTreeLayout methodsFor: 'hook' stamp: ''!
doExecute: nodeElements
	| rootNodes xOffset maximumRadius | 
	initialLayout isNil
		ifFalse: [ initialLayout new executeOnElements: nodeElements ].
	rootNodes := self rootNodesFor: nodeElements.
	rootNodes
		do: [ :e | self initialize: e whoseFatherIs: nil ];
		do: [ :e | self computePosition: e. self step];
		do: [ :e | self computeGap: e ];
		do: [ :e | self toRadialTree: e withMod: 0 ].
	xOffset := 0.
	rootNodes
		do: [ :e | 
			maximumRadius := self radialDraw: e.
			"Shifting all the subgroups"
			self shiftTree: e by:  (maximumRadius+xOffset)@maximumRadius.
			xOffset := xOffset + (2 * maximumRadius) + 10.  ].

! !

!RSRadialTreeLayout methodsFor: 'algorithm' stamp: ''!
toRadialTree: aNode withMod: aFloat
	"compute polar coordinates of the subtree induced by anode from its cartesian coordinates "
	| children |
	self rOf: aNode put: ((self layerOf: aNode) * verticalGap ).
	((self rOf: aNode) = 0) ifTrue: [ self thetaOf: aNode put: 0 ] 
					ifFalse: [ self thetaOf: aNode put: ((self xOf: aNode)  + aFloat + (self modOf: aNode)) / verticalGap ].
	
	children := self childrenFor: aNode.
	
	children do: [ :e | self toRadialTree: e withMod: ( (self modOf: aNode) + aFloat) ]! !

!RSRadialTreeLayout methodsFor: 'private' stamp: ''!
layoutLayer: aCollection radius: oldRadius from: aFromAngle to: aToAngle
	| delta childRadius maximumRadius myRadius fromAngle toAngle |
	"Initialize with default value"
	maximumRadius := oldRadius.
	aCollection isEmpty
		ifFalse:
			[myRadius := oldRadius + self gap + (self maximumRadius: aCollection).
			childRadius := oldRadius + self gap + (self maximumDiameter: aCollection).	"This is a purely optical tweak"
			(aCollection size = 1 and: [aToAngle - aFromAngle = (2 * Float pi)])
				ifTrue:
					[delta := 0.4 * Float pi.
					fromAngle := 0.8 * Float pi.
					toAngle := fromAngle + delta]
				ifFalse:
					[delta := (aToAngle - aFromAngle) / aCollection size.
					fromAngle := aFromAngle.
					toAngle := aFromAngle + delta].
			aCollection
				do:
					[:child | 
					translator translateTopLeftOf: child to: (Point
								r: myRadius
								theta: toAngle - (delta / 2.0)).
					"child
						translateTo:
							(Point
								radius: myRadius
								theta: toAngle - (delta / 2.0))."
					maximumRadius := maximumRadius
						max:
							(self
								layoutLayer: (self childrenFor: child)
								radius: childRadius
								from: fromAngle
								to: toAngle).
					fromAngle := toAngle.
					toAngle := toAngle + delta]].
	^maximumRadius! !

!RSRadialTreeLayout methodsFor: 'algorithm' stamp: ''!
computePosition: aNode
	"compute the position of the given node and of his sons recursively"
	| children neighbor nodeA |
	children := self childrenFor: aNode.
	neighbor := self leftSiblingOf: aNode.
	children isEmpty ifTrue: [
		 neighbor
			ifNil: [ self xOf: aNode put: 0.
				self modOf: aNode put: 0 ]
			ifNotNil: [ self
					xOf: aNode
					put: (self xOf: neighbor) + (horizontalGap / (self layerOf: aNode) / 2).
				self modOf: aNode put: (self modOf: neighbor).
				self
					pointerOf: aNode
					put: (self followRightContour: neighbor toLayer: (self layerOf: aNode) + 1) ] ]
	ifFalse: [ 
		self leftContourOf: aNode put: children first.
		self rightContourOf: aNode put: children last.
		children do: [ :e | self computePosition: e ].
		self
			xOf: aNode
			put:
				((self xOf: (self leftContourOf: aNode))
					+ (self xOf: (self rightContourOf: aNode))
					+ (self modOf: (self rightContourOf: aNode))) / 2.
		self modOf: aNode put: 0.
		neighbor
			ifNotNil:
				[ self modOf: aNode put: (self compareContourOf: aNode with: neighbor).
				nodeA := self
					followLeftContour: (self fatherOf: aNode)
					toLayer: (self layerOf: aNode).
				[ (self
					followLeftContour: nodeA
					toLayer: (self layerOf: nodeA) + 1) isNil ]
					whileFalse: [ nodeA := self
							followLeftContour: nodeA
							toLayer: (self layerOf: nodeA) + 1 ].
				self
					pointerOf: nodeA
					put: (self followLeftContour: aNode toLayer: (self layerOf: nodeA) + 1).
				nodeA := self
					followRightContour: aNode
					toLayer: (self layerOf: aNode) + 1.
				nodeA ifNil: [ ^ self ].
				[ (self
					followRightContour: nodeA
					toLayer: (self layerOf: nodeA) + 1) isNil ]
					whileFalse: [ nodeA := self
							followRightContour: nodeA
							toLayer: (self layerOf: nodeA) + 1 ].
				self
					pointerOf: nodeA
					put: (self followRightContour: neighbor toLayer: (self layerOf: nodeA) + 1) ] ]! !

!RSRadialTreeLayout methodsFor: 'hook' stamp: ''!
rotateSubtreeFrom: aNode by: aFloat
	aNode theta: aNode theta + aFloat.
	(self childrenFor: aNode) do: [ :e | 
		self rotateSubtreeFrom: e by: aFloat ]! !

!RSRadialTreeLayout methodsFor: 'algorithm' stamp: ''!
radialDraw: aNode
	"draw the subtree induced by the given node"
	| children r max |
	r := (self rOf: aNode).
	translator translateTopLeftOf: aNode to: (Point r: r theta: (self thetaOf: aNode)).
	"aNode translateTo: (Point radius: (aNode r) theta: (aNode theta))."
	children := self childrenFor: aNode.
	max := 0.
	children do: [ :e | max := max max: (self radialDraw: e) ].
	^ r + max.! !

!RSRadialTreeLayout methodsFor: 'private' stamp: ''!
gap
	^ self verticalGap! !

!RSRadialTreeLayout methodsFor: 'private' stamp: ''!
moveAllElementsToTopLeft: elements
	| pos min |
	pos := elements collect: #position.
	min := pos inject: 0 @ 0 into: [ :minimum :p | minimum min: p ].
	elements do: [ :e | e translateBy: min negated ] ! !

!RSRadialTreeLayout methodsFor: 'algorithm' stamp: ''!
compareContourOf: aNode with: another
	"return the number of radians the subtree induced by aNode must be displaced to be separated by a predefined distance (horizontalGap) from the one induced by anotherNode"
	| difference max nodeA nodeB |
	nodeB := aNode.	"the right one"
	nodeA := another.	"the left one"
	max := aNode = another
		ifTrue: [ 0 ]
		ifFalse: [ horizontalGap / (self layerOf: nodeB) / 2 - ((self xOf: nodeB) - (self getAbcissaOf: nodeA inSubtreeFromLayer: (self layerOf: aNode) - 1)) ].
	nodeB := self followLeftContour: nodeB toLayer: (self layerOf: nodeB) + 1.
	nodeA := self followRightContour: nodeA toLayer: (self layerOf: nodeA) + 1.
	[ nodeB isNil not & nodeA isNil not ]
		whileTrue: [ 
			difference := horizontalGap / (self layerOf: nodeA)
				-
					((self getAbcissaOf: nodeB inSubtreeFromLayer: (self layerOf: aNode) - 1)
						- (self getAbcissaOf: nodeA inSubtreeFromLayer: (self layerOf: aNode) - 1)).
			max := max max: difference.
			nodeB := self followLeftContour: nodeB toLayer: (self layerOf: nodeB) + 1.
			nodeA := self followRightContour: nodeA toLayer: (self layerOf: nodeA) + 1 ].
	^ max! !

!RSRectangleForceLayout commentStamp: ''!
I am a specific kind of force based layout that has an enclosing rectangle for elements. On each step, I apply a repulsion force to elements that are close to the enclosing rectangle.
!
!RSRectangleForceLayout methodsFor: 'accessing' stamp: ''!
enclosingThreshold: aNumber
	"Establishes the distance from the enclosing rectangle where the repulsion force applies to elements."

	enclosingThreshold := aNumber! !

!RSRectangleForceLayout methodsFor: 'events' stamp: ''!
initialize
	super initialize.

	enclosingThreshold := 50.
	enclosingForce := 0.3.
! !

!RSRectangleForceLayout methodsFor: 'events' stamp: ''!
step
	self stepRectangleForces.
	super step.
! !

!RSRectangleForceLayout methodsFor: 'accessing' stamp: ''!
enclosingForce
	^ enclosingForce! !

!RSRectangleForceLayout methodsFor: 'accessing' stamp: ''!
enclosingRectangle: aRectangleInCanvasSpaceCoordinates
	"Establishes the rectangle to enclose the elements."

	enclosingRectangle := aRectangleInCanvasSpaceCoordinates! !

!RSRectangleForceLayout methodsFor: 'accessing' stamp: ''!
enclosingRectangle
	^ enclosingRectangle! !

!RSRectangleForceLayout methodsFor: 'accessing' stamp: ''!
enclosingForce: aNumber
	"Establishes the force that is applied to the elements when they are close enough to the enclosing rectangle."

	enclosingForce := aNumber! !

!RSRectangleForceLayout methodsFor: 'accessing' stamp: ''!
enclosingThreshold
	^ enclosingThreshold! !

!RSRectangleForceLayout methodsFor: 'events' stamp: ''!
stepRectangleForces
	"Apply a repulsion force to elements that are close to the enclosing rectangle."

	| k |
	k := enclosingForce * alpha.
	(k closeTo: 0) ifTrue: [ ^ self ].
	
	nodes do: [ :each |
		| eachRect diff |
		eachRect := each encompassingRectangle.

		"horizontal"
		(diff := eachRect left - enclosingRectangle left) < enclosingThreshold ifTrue: [ 
			each translateTo: each position + (k * (enclosingThreshold - diff)@0) ].

		(diff := enclosingRectangle right - eachRect right) < enclosingThreshold ifTrue: [ 
			each translateTo: each position - (k * (enclosingThreshold - diff)@0) ].

		"vertical"
		(diff := eachRect top - enclosingRectangle top) < enclosingThreshold ifTrue: [ 
			each translateTo: each position + (0@(k * (enclosingThreshold - diff))) ].

		(diff := enclosingRectangle bottom - eachRect bottom) < enclosingThreshold ifTrue: [ 
			each translateTo: each position - (0@(k * (enclosingThreshold - diff))) ].
		].
! !

!RSRectanglePackLayout commentStamp: ''!
A layout that packs elements according to their bounding box. Check #gap and #preferredAngle.

Here is an example:
```
numberOfBoxes := 900.
r := Random seed: 42.
shapes := RSGroup new.
numberOfBoxes timesRepeat: [ 
	shapes add: (RSBox new width: (r nextInt: 40); height: (r nextInt: 40)) ].

c := RSCanvas new.
c addAll: shapes.
RSRectanglePackLayout new useProgressBar; on: shapes.
c @ RSCanvasController
```

Another example:
```
nodes := (1 to: 20) asArray shuffleBy: (Random seed: 42).

canvas := RSCanvas new.
shapes := RSCircle models: nodes.
shapes size: 30.
canvas addAll: shapes.
RSNormalizer size
    shapes: shapes;
    normalize.

RSRectanglePackLayout on: shapes.
canvas zoomToFit.
canvas open
```!
!RSRectanglePackLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self doNotUseProgressBar.
	gap := 0.2.
	preferredAngle := Float pi / 4. "Squared"! !

!RSRectanglePackLayout methodsFor: 'public - configuration' stamp: ''!
useProgressBar
	"Public method. Make the layout use a progress bar"
	shouldUseProgressBar := true! !

!RSRectanglePackLayout methodsFor: 'execution' stamp: ''!
packIn: anElement
	translator translateTopLeftOf: anElement to: (self bestSpaceFor: anElement) origin + padding.
	bounds := bounds max: anElement encompassingRectangle bottomRight + padding.
	
	self recalculateFreeSpacesWith: anElement! !

!RSRectanglePackLayout methodsFor: 'hook' stamp: ''!
doExecute: elements
	| sortedElements maxSpace |
	bounds := 0@0.
	
	maxSpace := elements
		inject: 0@0
		into: [ :sum :el | sum + el extent ].
		
	padding := maxSpace / elements size * gap / 2.
	maxSpace :=(1 + gap) * maxSpace.
	
	freeSpace := Set with: (0@0 corner: maxSpace).
	
	sortedElements := SortedCollection sortBlock:  [ :larger :smaller |
		larger  encompassingRectangle halfPerimeter >
		smaller encompassingRectangle halfPerimeter ].
	sortedElements addAll: elements.
	
	sortedElements size <= 2 ifTrue: [
		^ RSHorizontalLineLayout on: sortedElements ].

	self shouldUseProgressBar
		ifTrue: [
			sortedElements
				do: [ :element | self packIn: element ]
				displayingProgress: 'Laying out elements' ]
		ifFalse: [
			sortedElements 
				do: [ :element | self packIn: element ] ]
! !

!RSRectanglePackLayout methodsFor: 'space-calculation' stamp: ''!
recalculateFreeSpacesWith: anElement
	| rectangle |
	rectangle := anElement encompassingRectangle expandBy: padding.
	freeSpace := freeSpace inject: Set new into: [ :set :space |
		 set
			addAll: (space areasOverlapingOutside: rectangle); 
			yourself ].
		
	"remove subspaces"
	freeSpace := freeSpace reject: [ :subspace | 
		freeSpace anySatisfy: [ :space |
			space ~~ subspace and: [ 
				space containsRect: subspace ] ] ]
	! !

!RSRectanglePackLayout methodsFor: 'public - configuration' stamp: ''!
doNotUseProgressBar
	shouldUseProgressBar := false! !

!RSRectanglePackLayout methodsFor: 'space-calculation' stamp: ''!
bestSpaceFor: anElement
	| elementsPadedBox suitableSpaces |
	
	elementsPadedBox := anElement encompassingRectangle extendBy: padding * 2.
	
	suitableSpaces := freeSpace select: [ :space |
		elementsPadedBox width <= space width and:
			[ elementsPadedBox height <= space height ] ].
	
	^ suitableSpaces
		fold: [ :best :current |
			| bestExt currentExt | 
			((currentExt := self extentByInserting: elementsPadedBox into: current) <
			(bestExt := self extentByInserting: elementsPadedBox into: best) or: [ 
				currentExt = bestExt and: [
					current halfPerimeter < best halfPerimeter ] ])
						ifTrue: [ current ]
						ifFalse: [ best ] ]! !

!RSRectanglePackLayout methodsFor: 'space-calculation' stamp: ''!
extentByInserting: aRectangle into: aSpace
	| futureCorner preferredAngleInDegrees |
	futureCorner := aSpace origin + aRectangle extent.
	 
	preferredAngleInDegrees := preferredAngle radiansToDegrees.
	
	^ (((futureCorner max: bounds) degrees - preferredAngleInDegrees) abs / preferredAngleInDegrees + 1) 
! !

!RSRectanglePackLayout methodsFor: 'accessing' stamp: ''!
preferredAngle: angleInRadians
	preferredAngle := angleInRadians! !

!RSRectanglePackLayout methodsFor: 'accessing' stamp: ''!
gap
	"Answer the gap between elements, defined as ''percentage'' of average size. For example, 0.2 means 20%."
	^ gap! !

!RSRectanglePackLayout methodsFor: 'accessing' stamp: ''!
preferredAngle
	"Answer the angle (in radians) that the pack algorithm will use to distribute (layout) the elements. For example, setting value of '(2@1) angle', the elements will tend to be distributed horizontally."
	^ preferredAngle! !

!RSRectanglePackLayout methodsFor: 'testing' stamp: ''!
shouldUseProgressBar
	^ shouldUseProgressBar! !

!RSRectanglePackLayout methodsFor: 'accessing' stamp: ''!
gap: aFloat
	gap := aFloat! !

!RSRectanglePackLayout methodsFor: 'accessing' stamp: ''!
boundingBox
	^ bounds! !

!RSRenderer commentStamp: ''!
A renderer recives a canvas a then it visit each element of the canvas.

RSRenderer is like a visitor for the RSCanvas.

RSCanvas and RSShapes accept this visitor.

RSCanvas can be rendered with the next 

- RSAthensRenderer renders the canvas in a Athens Surface using an athens library

Future renderes: 
- RSPngRenderer, this can produce an image with different parameters 
- RSBlocRenderer, this render a canvas with the bloc/sparta commponents
- RSPDFRenderer, creates a pdf documents
- RSGifRenderer, creates gif files with animation
- RSSourceRenderer, creates a method with the content of the canvas.
- RSJavascriptRenderer, creates and html file with css and javascript code to render the canvas with basic insteractions.
- RSVideoRenderer, creates a mp4 video with the canvas animation and transparency.
!
!RSRenderer methodsFor: 'accessing' stamp: ''!
canvas: aCanvas
	"aCanvas is AthensCanvas"
	athensCanvas := aCanvas! !

!RSRenderer methodsFor: 'accessing' stamp: ''!
visitCanvas: canvas! !

!RSRenderer methodsFor: 'accessing' stamp: ''!
canvas
	^ athensCanvas ! !

!RSResize commentStamp: ''!
Adjust the size of the Elements.

[ [ [ 
	values := #(35 26 5 18 17 60 36 13 16 28 29 3 8 0 3 2 14 12 13 17 1 9 3 3 4 1 1 1 2 1 1 61).
	v := RSView new.
	n := TSScale category20c.
	shape := RSShapeBuilder box color: n; size: #yourself.
	es := shape elementsOn: values.
	v addAll: es.
	RTResize new elements: es; sameSize.
	RSHorizontalLineLayout new gapSize: 0; on: es.
	
	v @ RSControlsView.
	v open
 ] ] ]!
!RSResize methodsFor: 'accessing - computed' stamp: ''!
biggestShape
	^ shapes inject: shapes anyOne into: [ :biggestShape :e | 
			biggestShape extent < e extent
				ifTrue: [ e ] ifFalse: [ biggestShape ] ] ! !

!RSResize methodsFor: 'public' stamp: ''!
sameSize
	self ifNoFixedShapeThen: [ self useBiggestShape ].
	shapes do: [ :e | e extent: self fixedShape extent ]! !

!RSResize methodsFor: 'accessing - computed' stamp: ''!
widestShape
	^ shapes inject: shapes anyOne into: [ :widestElement :e | 
			widestElement extent x < e extent x
				ifTrue: [ e ] ifFalse: [ widestElement ] ] ! !

!RSResize methodsFor: 'public' stamp: ''!
sameHeight
	self ifNoFixedShapeThen: [ self useHighestShape ].
	shapes do: [ :e | e height: self fixedShape height ]! !

!RSResize methodsFor: 'public - configuration' stamp: ''!
useWidestShape
	self fixedShape: self widestShape! !

!RSResize methodsFor: 'public - configuration' stamp: ''!
useBiggestShape
	self fixedShape: self biggestShape! !

!RSResize methodsFor: 'accessing - computed' stamp: ''!
highestShape
	^ shapes inject: shapes anyOne into: [ :highestShape :e | 
			highestShape extent y < e extent y
				ifTrue: [ e ] ifFalse: [ highestShape ] ] ! !

!RSResize methodsFor: 'public' stamp: ''!
sameWidth
	self ifNoFixedShapeThen: [ self useWidestShape ].
	shapes do: [ :e | e width: self fixedShape width ]! !

!RSResize methodsFor: 'public - configuration' stamp: ''!
useHighestShape
	self fixedShape: self highestShape ! !

!RSResize methodsFor: 'accessing - computed' stamp: ''!
biggestExtent
	fixedShape ifNotNil: [ ^ fixedShape extent ].
	^ shapes inject: 0 @ 0 into: [ :maxExtent :e | 
			maxExtent max: e extent ] ! !

!RSResizeParentWhenChildMoves commentStamp: ''!
Based on simple moves of inner children, this interactions allow nodes to keep in the parent and update it!
!RSResizeParentWhenChildMoves methodsFor: 'hooks' stamp: ''!
resizeParent: evt
	| shape parent lastPosition delta children brother reference |
	shape := evt shape.
	parent := self parentFor: shape.
	(self isValidParent: parent) ifFalse: [^ self ].
	
	lastPosition := parent position.
	delta := evt newPosition - evt oldPosition.
	children := self childrenFor: parent.
	
	brother := self brotherFor: shape from: children.
	reference := nil.
	brother ifNotNil: [ 
		reference := brother parent globalMatrix 
			transform: brother position ].
	parent executeWithoutAnnouncer: [ 
		self prepare: shape with: parent.
		parent adjustToChildren.
		parent padding: self padding.
		 ].
	children size = 1 ifTrue: [ 
		shape position: evt oldPosition.
		parent translateTo: lastPosition + delta.
		^ self ].
	parent position: lastPosition.
	delta := (brother parent globalMatrix transform: brother position) - reference.
	parent translateBy: delta negated.
	
	
	
	! !

!RSResizeParentWhenChildMoves methodsFor: 'hooks' stamp: ''!
brotherFor: shape from: children
	^ children 
		detect: [ :child | child ~= shape ]
		ifNone: [ nil ]! !

!RSResizeParentWhenChildMoves methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self padding: self defaultPadding.! !

!RSResizeParentWhenChildMoves methodsFor: 'accessing' stamp: ''!
padding: aNumberPointOrMargin
	padding := aNumberPointOrMargin! !

!RSResizeParentWhenChildMoves methodsFor: 'hooks' stamp: ''!
parentFor: shape
	^ shape parent! !

!RSResizeParentWhenChildMoves methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	aCanvas isShape 
		ifTrue: [ ^ self registerShape: aCanvas ].
		
	aCanvas allChildren do: [ :child | self registerShape: child ]! !

!RSResizeParentWhenChildMoves methodsFor: 'initialization' stamp: ''!
defaultPadding
	^ 10! !

!RSResizeParentWhenChildMoves methodsFor: 'hooks' stamp: ''!
prepare: shape with: parent
	"do nothing"! !

!RSResizeParentWhenChildMoves methodsFor: 'hooks' stamp: ''!
childrenFor: parent
	^ parent children! !

!RSResizeParentWhenChildMoves methodsFor: 'accessing' stamp: ''!
padding
	^ padding! !

!RSResizeParentWhenChildMoves methodsFor: 'testing' stamp: ''!
isValidParent: parent
	^ parent isNotNil and: [ parent isShape ]! !

!RSResizeParentWhenChildMoves methodsFor: 'hooks' stamp: ''!
registerShape: child
	child 
		when: RSPositionChangedEvent
		send: #resizeParent:
		to: self ! !

!RSResizeTest methodsFor: 'tests' stamp: ''!
testBiggestExtent
	self assert: resize biggestExtent equals: 4 @ 3! !

!RSResizeTest methodsFor: 'tests' stamp: ''!
testSameHeight
	resize fixedShape: shapes second.
	resize sameHeight.
	self assert: (shapes collect: #extent) sorted asArray equals: (Array with: (2.0@2.0) with: (3.0@2.0) with: (4.0@2.0))! !

!RSResizeTest methodsFor: 'tests' stamp: ''!
testHighestShape
	self assert: resize highestShape equals: shapes last.
! !

!RSResizeTest methodsFor: 'tests' stamp: ''!
testSameSizeWithoutFixedShape
	resize sameSize.
	self assert: (shapes collect: #extent) asSet asArray equals: (Array with: (4.0 @ 3.0))! !

!RSResizeTest methodsFor: 'tests' stamp: ''!
testSameSize
	resize fixedShape: shapes second.
	resize sameSize.
	self assert: (shapes collect: #extent) asSet asArray equals: (Array with: (3.0@2.0))! !

!RSResizeTest methodsFor: 'tests' stamp: ''!
testWidestShape
	self assert: resize widestShape equals: shapes last.
! !

!RSResizeTest methodsFor: 'tests' stamp: ''!
testBiggestShape
	self assert: resize biggestShape equals: shapes last.
	resize useBiggestShape.
	self assert: resize fixedShape equals: shapes last.! !

!RSResizeTest methodsFor: 'tests' stamp: ''!
testSameWidth
	resize fixedShape: shapes second.
	resize sameWidth.
	self assert: (shapes collect: #extent) sorted asArray equals: (Array with: (3.0@1.0) with:(3.0@2.0) with: (3.0@3.0))! !

!RSResizeTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	shapes := (1 to: 3) collect: [ :o | 
		RSBox new
			height: o;
			width: o + 1;
			yourself ].
	resize := RSResize new.
	resize shapes: shapes.! !

!RSRiceBinning commentStamp: ''!
TODO!
!RSRiceBinning methodsFor: 'hooks' stamp: ''!
computeSizeFor: values
	^ 2 * (values size raisedTo: 1/3)! !

!RSRoassal3Test methodsFor: 'tests' stamp: ''!
testOpenOnce

	| v |
	v := RSCanvas new openOnce.
	self assert: v class == SystemWindow.
	v delete.! !

!RSRoassal3Test methodsFor: 'tests' stamp: ''!
testSubscriberClass
	| box |
	box := RSBox new.
	self deny: (box announcer handleSubscriberClass: RSPopup).
	box popup.
	self assert: (box announcer handleSubscriberClass: RSPopup).
	"but popup adds a lot of events, RSPopup is not an event"
	self deny: (box announcer handleEventClass: RSPopup).
	{RSPopup activationEvent}, RSPopup removeEvents do: [ :evt | self assert:  (box announcer handleEventClass: evt). ]
! !

!RSRoassal3Test methodsFor: 'tests' stamp: ''!
testOpen

	| v |
	v := RSCanvas new open.
	self assert: v class == SystemWindow.
	v delete.! !

!RSRoassal3Test methodsFor: 'tests' stamp: ''!
testRemoveInteractionIfPresent
	| box |
	box := RSBox new.
	self deny: (box announcer handleSubscriberClass: RSPopup).
	box popup.
	self assert: (box announcer handleSubscriberClass: RSPopup).
	
	box removeInteractionIfPresent: RSPopup.
	self deny: (box announcer handleSubscriberClass: RSPopup).
	self deny: box hasEventCallback.
	
	box := RSBox new.
	box popup. 
	self assert: (box announcer handleEventClass: RSMouseMove).
	box removeInteractionIfPresent: RSMouseMove.
	self assert: (box announcer handleEventClass: RSMouseMove).! !

!RSRoassal3Test methodsFor: 'tests' stamp: ''!
testsRsValue
	| myCutomObjectValueProvider posiblesValuesForRoassal model colors |
	myCutomObjectValueProvider := NSScale category10.
		
	posiblesValuesForRoassal:= {
		Color red.
		nil.
		Color random.
		[ Color random ].
		#color.
		[ :obj | obj color ].
		myCutomObjectValueProvider  }.
		
	model := Morph new.

	colors := posiblesValuesForRoassal collect: [ :value |
		value rsValue: model ] as: OrderedCollection.
	self assert: (colors includes: nil).
	colors remove: nil.
	colors do: [ :color | self assert: color class equals: Color ]! !

!RSRotated commentStamp: ''!
I can rotate one shape on its parent!
!RSRotated methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	drag := false.! !

!RSRotated methodsFor: 'hooks' stamp: ''!
dragStart: evt
	drag := true.! !

!RSRotated methodsFor: 'hooks' stamp: ''!
onShape: aShape
	targetShape := aShape.
	aShape parent
		when: RSMouseLeftDragStart do: [ :evt|  self dragStart: evt ];
		when: RSMouseDragging do: [ :evt | self dragging: evt ];
		when: RSMouseDragEnd do: [ :evt | self dragEnd: evt ].! !

!RSRotated methodsFor: 'hooks' stamp: ''!
dragging: evt
	| angle |
	drag ifFalse: [ ^ self ].
	angle := evt position angle.
	totalAngle ifNil: [ totalAngle := 0 ].
	prevAngle ifNil: [ prevAngle := angle ].
	totalAngle := totalAngle + (angle - prevAngle).
	prevAngle := angle.
	targetShape matrix
		loadIdentity;
		rotateByRadians: totalAngle.
	evt signalUpdate! !

!RSRotated methodsFor: 'hooks' stamp: ''!
dragEnd: evt
	drag := false.
	prevAngle := nil.! !

!RSRotatedPieLabelDecorator commentStamp: ''!
I am a specific interaction based on the example23RotatedAnimation!
!RSRotatedPieLabelDecorator methodsFor: 'rendering' stamp: ''!
render
	| container |
	self createLabels.
	self createLines.
	container := self builder container.
	container
		addAll: lines;
		addAll: labels.
	builder shapes when: RSMouseClick do: [ animation toggle ].
	self createAnimation.
	self stepShapes: 0! !

!RSRotatedPieLabelDecorator methodsFor: 'rendering' stamp: ''!
stepShapes: t
	builder shapes doWithIndex: [ :shape :index | 
		  | a b label ang ext x p1 p2 p3 line |
		  a := shape propertyAt: #a ifAbsentPut: [ shape alphaAngle ].
		  b := shape propertyAt: #b ifAbsentPut: [ shape betaAngle ].
		  shape
			  alphaAngle: a + t;
			  betaAngle: b + t.
		  label := labels at: index.
		  ang := shape alphaAngle + shape betaAngle / 2 % 360.
		  ext := label extent x / 2 @ 0.
		  x := -250.
		  (ang between: 90 and: 270) ifFalse: [ 
			  ext := ext negated.
			  x := x negated ].
		  p1 := shape centroid: 0.
		  p2 := shape centroid: 50.
		  p3 := x @ p2 y.
		  line := lines at: index.
		  line shape controlPoints: { 
				  p1.
				  p2.
				  p3 }.
		  label position: p3 - ext ]! !

!RSRotatedPieLabelDecorator methodsFor: 'rendering' stamp: ''!
createAnimation
	animation := builder container newAnimation
		from: 0;
		to: 360;
		repeat;
		duration: 15 seconds;
		onStepDo: [ :t | self stepShapes: t ]! !

!RSRotatedPieLabelDecorator methodsFor: 'rendering' stamp: ''!
createLabels
	labels := builder objects collect: [ :obj |
		RSLabel new
			text: obj;
			yourself ]! !

!RSRotatedPieLabelDecorator methodsFor: 'rendering' stamp: ''!
createLines
	lines := builder objects collect: [ :obj | 
		RSPolyline new
			dashArray: #( 4 );
			yourself ]! !

!RSScaleChangedEvent commentStamp: ''!
When canvas changes the scale value of the TSCamera!
!RSScaleChangedEvent methodsFor: 'accessing' stamp: ''!
newScale: aNumber
	newScale := aNumber! !

!RSScaleChangedEvent methodsFor: 'accessing' stamp: ''!
oldScale: aNumber
	oldScale := aNumber! !

!RSScaleChangedEvent methodsFor: 'accessing' stamp: ''!
newScale
	^ newScale! !

!RSScaleChangedEvent methodsFor: 'accessing' stamp: ''!
oldScale
	^ oldScale! !

!RSScatterPlot commentStamp: ''!
<keyClass>
`RSScatterPlot` is a scatter plot. Shapes are defined using two components, X and Y. 

*Responsibility*: create shapes that represent a scatter plot.

*Collaborators*: used by `RSChart`

*Variables*:
- `processBlock`: is either `nil` or refer to a one argument block. This block is used to particularize the shapes.

*Example*:
```Smalltalk
x := OrderedCollection new.
y := OrderedCollection new.
z := OrderedCollection new.
r := Random seed: 42.
1 to: 100 do: [ :i |
	x add: i + (r nextInt: 10).
	y add: i + (r nextInt: 10).
	z add: i + (r nextInt: 10).
].

c := RSChart new.
p := RSScatterPlot new x: x y: y.
p color: Color blue translucent.
p processBlock: [ :shapes | 
		shapes models: z.
		RSNormalizer size
			shapes: shapes;
			from: 2;
			to: 10;
			normalize: #yourself.
		RSNormalizer color
			shapes: shapes;
			normalize: #yourself.
			
			 ].
c addPlot: p.
 
c addDecoration: (RSHorizontalTick new doNotUseNiceLabel asFloat: 3).
c addDecoration: RSVerticalTick new.

c
```


!
!RSScatterPlot methodsFor: 'accessing' stamp: ''!
ellipses
	^ ellipses! !

!RSScatterPlot methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	| newPoint color |
	color := self computeColor.
	self checkAssertion.
	ellipses := (1 to: xValues size)
		collect: [ :notUsed | 
			self shape copy
				radius: 2;
				color: color ] as: RSGroup.
	xValues doWithIndex: [ :xt :i | 
		| yt et |
		et := ellipses at: i.
		yt := yValues at: i.
		newPoint := self scalePoint: xt @ yt.
		(self isPointWellDefined: newPoint)
			ifTrue: [ 
				et model: xt @ yt.
				et translateTo: newPoint.
				canvas add: et ] ].
		
	! !

!RSScatterPlot methodsFor: 'accessing' stamp: ''!
createdShapes
	^ ellipses! !

!RSScatterPlot methodsFor: 'initialization' stamp: ''!
defaultShape
	^ RSEllipse new noPaint! !

!RSScatterPlot methodsFor: 'testing' stamp: ''!
isScatterPlot
	^ true! !

!RSScatterPlotTest methodsFor: 'tests' stamp: ''!
classToTest
	^ RSScatterPlot! !

!RSScrollBarsCanvasInteraction commentStamp: ''!
I put a scrool shapes to the view when the view moves!
!RSScrollBarsCanvasInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self initializeShape.! !

!RSScrollBarsCanvasInteraction methodsFor: 'hooks' stamp: ''!
updateAnimation
	| canvas |
	canvas := vertical parent.
	hideAnimation 
		ifNil: [ self initializeHideAnimation ].
	animation ifNotNil: [ 
		animation stop.
		hideAnimation stop.
		^ canvas addAnimation: animation.
		].
	animation := canvas newAnimation
		duration: 700 milliSeconds;
		onStepDo: [ :t | canvas signalUpdate ];
		when: RSAnimationLoopEvent do: [ 
			canvas addAnimation: hideAnimation ].
		! !

!RSScrollBarsCanvasInteraction methodsFor: 'initialization' stamp: ''!
initializeShape
	barShape := RSBox new
		cornerRadius: (RSCornerRadius new radius: 5);
		size: 10;
		noPaint;
		isFixed: true;
		when: RSMouseDragging do: [:evt| self moveScroll: evt ];
		when: RSMouseEnter do: [ :evt| | shape |
			self updateScrollbars.
			shape := evt shape.
			shape color isTransparent 
				ifFalse: [ shape color: (self scrollColor alpha: 1) ].
			animation stop.
			hideAnimation stop ];
		when: RSMouseLeave do: [ :evt| | shape |
			shape := evt shape.
			shape color isTransparent 
				ifFalse: [ shape color: self scrollColor ].
			self removeRectanglesFor: evt canvas.
			vertical parent addAnimation: animation ];
		yourself! !

!RSScrollBarsCanvasInteraction methodsFor: 'hooks' stamp: ''!
addScrollBars: aCanvas
	vertical := self barShapeCopy.
	horizontal := self barShapeCopy.
	
	aCanvas addShape: vertical; addShape: horizontal.
	! !

!RSScrollBarsCanvasInteraction methodsFor: 'initialization' stamp: ''!
initializeHideAnimation
	| sc1 sc2 |
	sc1 := NSScale linear range: { self scrollColor. Color transparent }.
	sc2 := NSScale linear range: { self scrollBorderColor. Color transparent }.
	hideAnimation := vertical parent transitionAnimation
		duration: 1 second;
		onStepDo: [ :t | 
			self 
				color: (sc1 scale: t) 
				border: (sc2 scale: t).
			vertical signalUpdate. ] ! !

!RSScrollBarsCanvasInteraction methodsFor: 'accessing' stamp: ''!
scrollColor
	^ Color lightGray translucent.! !

!RSScrollBarsCanvasInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	self addScrollBars: aCanvas.
	
	aCanvas when: RSPositionChangedEvent do: [ self updateScrollbars ].
	aCanvas when: RSScaleChangedEvent do: [ self updateScrollbars ].! !

!RSScrollBarsCanvasInteraction methodsFor: 'accessing' stamp: ''!
scrollBorderColor
	^ Color lightGray translucent! !

!RSScrollBarsCanvasInteraction methodsFor: 'accessing' stamp: ''!
shape
	^ barShape! !

!RSScrollBarsCanvasInteraction methodsFor: 'hooks' stamp: ''!
barShapeCopy
	^ barShape copy
		announcer: barShape announcer;
		border: (RSBorder new
			color: Color transparent;
			width: 0.5;
			yourself);
		yourself! !

!RSScrollBarsCanvasInteraction methodsFor: 'private' stamp: ''!
color: color1 border: color2
	| c1 c2 extent |
	c1 := color1.
	c2 := color2.
	extent := vertical parent extent.
	vertical height >= extent y
		ifTrue: [ c1 := c2 := Color transparent ].
	vertical
		color: c1;
		borderColor: c2.
	c1 := color1.
	c2 := color2.
	horizontal width >= extent x
		ifTrue: [ c1 := c2 := Color transparent ].
	horizontal
	 	color: c1;
		borderColor: c2.! !

!RSScrollBarsCanvasInteraction methodsFor: 'hooks' stamp: ''!
moveScroll: evt
	| shape delta position camera canvasExtent shapesRect correct |
	shape := evt shape.
	delta := evt step.
	delta := shape = vertical shape
		ifTrue: [ 0@delta y ]
		ifFalse: [ delta x@0 ].
	shape translateBy: delta.
	canvasExtent := evt canvas extent.
	shapesRect := self encompassingRectangleFor: evt canvas.
	position := horizontal position x @ vertical position y.
	position := position * shapesRect extent / canvasExtent.
	
	camera := evt camera.
	camera position: position + shapesRect origin.
	correct := self correctCameraPosition: evt canvas.
	correct = camera position ifFalse: [ 
		camera position: correct.
		self updateBasicScrollbars. ].
	evt signalUpdate. ! !

!RSScrollBarsCanvasInteraction methodsFor: 'hooks' stamp: ''!
updateBasicScrollbars
	| canvas canvasRect shapesRect p pd ext scrollExtent |
	canvas := vertical parent.
	canvasRect := canvas visibleRectangle.
	shapesRect := self encompassingRectangleFor: canvas.
	
	scrollExtent := vertical width @ horizontal height.
	p := canvas extent - 1 - (scrollExtent / 2).
	
	pd := canvas extent * (canvasRect floatCenter - shapesRect origin) / shapesRect extent.
	ext := canvasRect extent * canvas extent / shapesRect extent.
	vertical position: p x @ pd y ; height: ext y.
	horizontal position: pd x @ p y; width: ext x.! !

!RSScrollBarsCanvasInteraction methodsFor: 'hooks' stamp: ''!
updateScrollbars
	self updateBasicScrollbars.
	self color: self scrollColor border: self scrollBorderColor.
	self updateAnimation.
	vertical signalUpdate! !

!RSScrollBarsCanvasInteraction methodsFor: 'rendering' stamp: ''!
renderLegendOn: lb 
	lb text: '' description: 'Use scrool bars to navigate'! !

!RSScrollWheelCanvasInteraction commentStamp: ''!
I am a interaction for translate the canvas in vertical position with the mouse wheel!
!RSScrollWheelCanvasInteraction methodsFor: 'events - processing' stamp: ''!
move: aCanvas delta: delta

	| correct p |
	correct := self correctCameraPosition: aCanvas.
	p := (correct - aCanvas camera position) abs max: 1@1.
	p := p x sqrt @ p y sqrt.
	aCanvas camera translateBy: (0@ delta)/p.
	aCanvas signalUpdate.
	
	animation ifNotNil: [ animation stop ].
	animation := aCanvas newAnimation
		duration: 300 milliSeconds;
		onStepDo: [ :t | aCanvas signalUpdate ];
		when: RSAnimationLoopEvent do: [ :e | 
			aCanvas newAnimation
				duration: 200 milliSeconds;
				from: aCanvas camera position;
				to: (self correctCameraPosition: aCanvas);
				onStepDo: [ :t | 
					aCanvas camera translateTo: t.
					aCanvas signalUpdate ].
			].
	
	
	! !

!RSScrollWheelCanvasInteraction methodsFor: 'events - processing' stamp: ''!
processEvent: evt
	| delta |
	delta := (evt isUp
		ifTrue: [ -1]
		ifFalse: [ 1 ]) * 30.
		
	self move: evt canvas delta: delta.! !

!RSScrollWheelCanvasInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	aCanvas when: RSMouseWheelEvent do: [ :evt | self processEvent: evt ]! !

!RSScrollWheelCanvasInteraction methodsFor: 'rendering' stamp: ''!
renderLegendOn: aLegendBuilder
	! !

!RSSearchInCanvasInteraction commentStamp: ''!
`RSSearchInCanvas` am an option for the canvas controller. 
You can use `RSSearchInCanvas` as follows (press the S key and the R key):

```Smalltalk
c := RSCanvas new.
shapes := Collection withAllSubclasses collect: [ :n | RSEllipse new size: 20; model: n ] as: RSGroup.
c addAll: shapes.
shapes @ RSPopup.
eb := RSEdgeBuilder line.
eb canvas: c.
eb connectFrom: #superclass.
RSTreeLayout on: shapes.
c @ RSCanvasController.
```

```Smalltalk
c := RSCanvas new.
shapes := (1 to: 10) collect: [ :n | RSEllipse new size: 20; model: n ] as: RSGroup.
c addAll: shapes.
RSGridLayout on: shapes.
shapes @ RSPopup.
con := RSCanvasController new.
con addInteraction: RSSearchInCanvas new.
c @ con.
```

Another example:
```Smalltalk
c := RSCanvas new.

classes := Collection withAllSubclasses.
elements := classes collect: [ :cls |
	g := RSGroup new
		add: (RSLabel new text: cls name);
		add: (RSEllipse new size: (cls numberOfMethods + 5) sqrt; color: Color blue );
		yourself.
	RSVerticalLineLayout new center; on: g.
	g asShapeFor: cls ] as: RSGroup.

c addAll: elements.
high := RSHighlightable defaultRed.
elements @ high.
RSGridLayout new
	lineItemsCount: 5;
	on: elements.

con := RSCanvasController new.
con addInteraction: (search := RSSearchInCanvas new 
	colorToHighlight: Color blue translucent;
	yourself).

c @ con.
```
!
!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
adjustRegExpIfNecessary: regExp

	^ useExactMatch ifTrue: [ regExp ] ifFalse: [ '*', regExp, '*' ]! !

!RSSearchInCanvasInteraction methodsFor: 'private - events' stamp: ''!
click: evt
	| shapes label index shadow nextShadow |
	label := evt shape.
	shapes := label propertyAt: #shapesToHighlight.
	(shapes isNil or: [shapes isEmpty]) ifTrue: [ ^ self ].
	index := label propertyAt: #index ifAbsent: [ 1 ].
	shadow := (shapes at: index) propertyAt: #shadow.
	shadow color: label color.
	
	index := evt class == RSMouseLeftClick 
		ifTrue: [ index % shapes size + 1]
		ifFalse: [ index - 1 ].
	index = 0 ifTrue: [ index := shapes size ].
	label propertyAt: #index put: index.
	nextShadow := (shapes at: index) propertyAt: #shadow.
	self animateShadowPosition: nextShadow.! !

!RSSearchInCanvasInteraction methodsFor: 'accessing' stamp: ''!
fixedLabels
	"Return the label that are created when a search is performed"
	^ fixedLabels! !

!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
resetAllHighlightedShapes

	"Restore the colors of all the highlighted shapes. This method is called whtn keyForReset is pressed"

	self cleanAndResetFixedshapes.
	self doUnhighlightShapes.
	canvas signalUpdate! !

!RSSearchInCanvasInteraction methodsFor: 'util' stamp: ''!
isRegExpValid: regExp
	"Is the regular expression relevant to be processed"
	^ regExp notNil and: [ regExp notEmpty ]! !

!RSSearchInCanvasInteraction methodsFor: 'util' stamp: ''!
unhighlightShapes: shapesToHighlight
	shapesToHighlight do: [ :s | self unhighlightShape: s ]! !

!RSSearchInCanvasInteraction methodsFor: 'accessing' stamp: ''!
canvas: aCanvas
	"Set the canvas from which shapes should be searched in"
	canvas := aCanvas! !

!RSSearchInCanvasInteraction methodsFor: 'accessing' stamp: ''!
numberOfPerformedSearches
	"Return the number of searches that have been done since the last reset. This number is the same than the number of fixed labels that were already set."
	^ fixedLabels size! !

!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
searchForShapes
	"callback called when some shapes have to be search"
	| regExp |
	regExp := self obtainRegExpToHighlight.
	(self isRegExpValid: regExp)
		ifFalse: [ ^ self ].
	self searchForShapes: regExp! !

!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
putShadowOn: shape
	| shadow pad |
	pad := 5/ (self scaleFrom: shape).
	shadow := RSBox new
		fromRectangle: (shape encompassingRectangle expandBy: pad);
		paint: self colorToUseToHighlight;
		cornerRadius: pad * 0.75;
		yourself.
	
	shape removeInteractionIfPresent: self class.
	shape 
		when: RSPositionChangedEvent do: [ RSLocation new move: shadow on: shape ];
		when: RSExtentChangedEvent do: [ RSLocation new move: shadow on: shape ].
	
	shape parent ifNotNil: [ shape parent addShape: shadow before: shape ].
	shape propertyAt: #shadow
		ifPresent: [ :oldShadow | oldShadow remove ].
		
	shape propertyAt: #shadow put: shadow.! !

!RSSearchInCanvasInteraction methodsFor: 'public - configuration' stamp: ''!
doNotUseExactMatch
	"Expect a regular expression as input, but a * is prepended and appended to the regexp"
	useExactMatch := false! !

!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
doHighlightShapes: shapesToHighlight
	shapesToHighlight do: [ :s | self putShadowOn: s ].
	"We record the highlighted shapes"
	highlightesShapes addAll: shapesToHighlight! !

!RSSearchInCanvasInteraction methodsFor: 'private - events' stamp: ''!
animateShadowPosition: shadow
	(canvas visibleRectangle containsRect: shadow encompassingRectangle)
		ifTrue: [ ^ self ].
	canvas newAnimation
		duration: 500 milliSeconds;
		from: canvas camera position;
		to: shadow position;
		on: canvas camera set: #position:.! !

!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
colorsToUse: aNSOrdinalScale
	colorsToUse := aNSOrdinalScale! !

!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
colorToUseToHighlight

	^ colorsToUse scale: self numberOfPerformedSearches! !

!RSSearchInCanvasInteraction methodsFor: 'util' stamp: ''!
unhighlightShape: s
	^ RSHighlightable new restore: s selector: #color! !

!RSSearchInCanvasInteraction methodsFor: 'public - configuration' stamp: ''!
colorToHighlight: aColor
	"Set the color to highlight shapes when searching"
	colorsToUse range at: 1 put: aColor.! !

!RSSearchInCanvasInteraction methodsFor: 'private' stamp: ''!
obtainRegExpToHighlight
	"Open a UI"
	^ UIManager default
		request: 'Enter a reg exp to search for an item'
		initialAnswer: '*value*'! !

!RSSearchInCanvasInteraction methodsFor: 'util' stamp: ''!
shapesToHighlightUsingRegExp: regExp
	"Return the shapes to be highlighted"	

	| candidateShapes shapesToHighlight |
	candidateShapes := self candidateShapes.
	shapesToHighlight := candidateShapes
		select: [ :s | regExp match: s model asString ].

	^ shapesToHighlight! !

!RSSearchInCanvasInteraction methodsFor: 'rendering' stamp: ''!
renderLegendOn: aLegendBuilder
	aLegendBuilder
		text: self keyForSearch
		description: 'Search and highlight items'.
	aLegendBuilder
		text: self keyForReset
		description: 'Unhighlight all items'! !

!RSSearchInCanvasInteraction methodsFor: 'public - configuration' stamp: ''!
useExactMatch
	"Expect a regular expression as input"
	useExactMatch := true! !

!RSSearchInCanvasInteraction methodsFor: 'private - events' stamp: ''!
hideCurrentShadow: evt
	| shapes label index shadow anime |
	label := evt shape.
	shapes := label propertyAt: #shapesToHighlight.
	anime := label propertyAt: #animation.
	anime ifNotNil: [ 
		anime stop.
		label removeKey: #animation ].
	(shapes isNil or: [shapes isEmpty]) ifTrue: [ ^ self ].
	index := label propertyAt: #index ifAbsent: [ 1 ].
	
	shadow := (shapes at: index) propertyAt: #shadow.
	shadow color: label color.
	
	! !

!RSSearchInCanvasInteraction methodsFor: 'private - events' stamp: ''!
processKeyUp: evt
	| keyName |
	self canvas: evt canvas.
	keyName := evt keyName.
	evt anyModifierKeyPressed ifTrue: [ ^ self ].
	keyName = self keyForSearch ifTrue: [ self searchForShapes ].
	keyName = self keyForReset ifTrue: [ self resetAllHighlightedShapes ]! !

!RSSearchInCanvasInteraction methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self resetFixedShapes.
	highlightesShapes := RSGroup new.
	
	colorsToUse := NSScale ordinalColored: 7.
	highlightableLabels := RSHighlightable new
		when: RSHighlightEvent send: #showCurrentShadow: to: self;
		when: RSUnHighlightEvent send: #hideCurrentShadow: to: self;
		yourself.
	
	"The variable highlightedShapes contains the shapes that have been searched and therefore highlighted"
	self doNotUseExactMatch! !

!RSSearchInCanvasInteraction methodsFor: 'private' stamp: ''!
scaleFrom: s
	"Return the scale used by the canvas of the shape"
	s canvas ifNil: [ ^ 1 ].
	^ s canvas camera scale! !

!RSSearchInCanvasInteraction methodsFor: 'private - events' stamp: ''!
showCurrentShadow: evt
	| shapes label anime index shadow |
	label := evt shape.
	shapes := label propertyAt: #shapesToHighlight.
	anime := label propertyAt: #animation.
	anime ifNotNil: [ anime stop ].
	(shapes isNil or: [shapes isEmpty]) ifTrue: [ ^ self ].
	index := label propertyAt: #index ifAbsent: [ 1 ].
	shadow := (shapes at: index) propertyAt: #shadow.
	self animateShadowPosition: shadow.
	anime := label newAnimation
		repeat;
		duration: 1 second;
		scale: (NSScale linear
			domain: #(0 0.5 1);
			range: {label color. label color muchDarker. label color});
		onStepDo: [:newColor | 
			
			index := label propertyAt: #index ifAbsent: [ 1 ].
			shadow := (shapes at: index) propertyAt: #shadow.
			shadow color: newColor.
			shadow signalUpdate.
			].
	label propertyAt: #animation put: anime.
	
	! !

!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
doUnhighlightShapes

	highlightesShapes do: [ :s | 
		s propertyAt: #shadow ifPresent: [ :shadow | 
			shadow remove.
			s removeKey: #shadow.
			]. ].
	highlightesShapes := RSGroup new.
! !

!RSSearchInCanvasInteraction methodsFor: 'initialization' stamp: ''!
resetFixedShapes
	fixedLabels := RSGroup new! !

!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
onShape: aCanvas
	aCanvas 
		when: RSKeyUp do: [ :evt | self processKeyUp: evt ]! !

!RSSearchInCanvasInteraction methodsFor: 'util' stamp: ''!
numberOfHighlightedShapes
	"Return the number of shapes that have been highlited"
	^ highlightesShapes size! !

!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
searchForShapes: regExp
	"callback called when some shapes have to be search"

	| shapesToHighlight lbl |
	shapesToHighlight := self shapesToHighlightUsingRegExp:
		                     (self adjustRegExpIfNecessary: regExp).

	"No need to pursue if we have not found anything"
	shapesToHighlight ifEmpty: [ ^ self ].
	self doHighlightShapes: shapesToHighlight.

	lbl := RSLabel text: regExp model: shapesToHighlight size asString, ' elements'.
	lbl propertyAt: #shapesToHighlight put: shapesToHighlight.
	
	lbl fontSize: 14.
	lbl @ RSPopup; @ highlightableLabels.
	lbl when: RSMouseClick send: #click: to: self.
	lbl color: self colorToUseToHighlight.
	canvas add: lbl.
	lbl setAsFixed.
	fixedLabels add: lbl.
	RSHorizontalLineLayout on: fixedLabels.
	fixedLabels translateTo: fixedLabels extent / 2 + (5 @ 5).


	canvas signalUpdate! !

!RSSearchInCanvasInteraction methodsFor: 'configuration' stamp: ''!
keyForSearch
	^ 'S'! !

!RSSearchInCanvasInteraction methodsFor: 'util' stamp: ''!
candidateShapes
	"Return shapes for which the model has to be matched. 
	 Only shapes that are not a line and having a model may be eligeable to be highligted"
	self assert: [ canvas notNil ] description: 'Canvas should be set first'.
	^ canvas shapes select: [ :s | s model notNil and: [ s isNode ] ]! !

!RSSearchInCanvasInteraction methodsFor: 'configuration' stamp: ''!
keyForReset
	^ 'R'! !

!RSSearchInCanvasInteraction methodsFor: 'public' stamp: ''!
cleanAndResetFixedshapes

	fixedLabels do: [ :s | canvas removeFixedShape: s ].
	self resetFixedShapes! !

!RSSearchInCanvasTest methodsFor: 'tests' stamp: ''!
testFixedShapesAndPopup

	| lbl |
	search searchForShapes: '4'.
	lbl := search fixedLabels first.
	lbl announce: RSMouseEnter new.! !

!RSSearchInCanvasTest methodsFor: 'tests' stamp: ''!
testIsRegExpValid
	self deny: (search isRegExpValid: '').
	self deny: (search isRegExpValid: nil).! !

!RSSearchInCanvasTest methodsFor: 'tests' stamp: ''!
testFixedShapes

	self assert: c numberOfFixedShapes equals: 3.
	search searchForShapes: '4'.
	self assert: c numberOfFixedShapes equals: 4.
	search searchForShapes: '5'.
	self assert: c numberOfFixedShapes equals: 5.
	
	search resetAllHighlightedShapes.
	self assert: c numberOfFixedShapes equals: 3.! !

!RSSearchInCanvasTest methodsFor: 'tests' stamp: ''!
testBasic
	search searchForShapes: '*4*'.
	self assert: (shapes fourth hasProperty: #shadow).
	self deny: (shapes fifth hasProperty: #shadow).
	
	search searchForShapes: '*5*'.
	self assert: (shapes fourth hasProperty: #shadow).
	self assert: (shapes fifth hasProperty: #shadow).
	
	self assert: search numberOfHighlightedShapes equals: 2.

	search resetAllHighlightedShapes.
	self deny: (shapes fourth hasProperty: #shadow).
	self deny: (shapes fifth hasProperty: #shadow).
! !

!RSSearchInCanvasTest methodsFor: 'tests' stamp: ''!
testWithEdge

	| l |
	l := RSLine new.
	l attachPoint: RSCenteredAttachPoint new.
	l color: Color black.
	l from: shapes first.
	l to: shapes last.
	c add: l.
	
	search searchForShapes: '*5*'.
	self assert: l color equals: Color black.
	
	search searchForShapes: '*1*'.
	self assert: l color equals: Color black.
	
	search searchForShapes: '*10*'.
	self assert: l color equals: Color black! !

!RSSearchInCanvasTest methodsFor: 'tests' stamp: ''!
testWithEdgeAndhighlightable

	| l interaction |
	
	interaction := RSHighlightable new.
	interaction highlightBorder: (RSBorder new width: 2).
	interaction withLines.
	c shapes @ interaction.
	
	l := RSLine new.
	l attachPoint: RSCenteredAttachPoint new.
	l color: Color black.
	l from: shapes first.
	l to: shapes last.
	c add: l.
	
	search searchForShapes: '*5*'.
	self assert: l color equals: Color black.
	
	search searchForShapes: '*1*'.
	self assert: l color equals: Color black.
	
	search searchForShapes: '*10*'.
	self assert: l color equals: Color black! !

!RSSearchInCanvasTest methodsFor: 'tests' stamp: ''!
testNoSearch

	self assert: (c shapes allSatisfy: [ :s | s color = Color gray ])! !

!RSSearchInCanvasTest methodsFor: 'tests' stamp: ''!
testNumberOfHighlightedShapes
	self assert: search numberOfHighlightedShapes equals: 0.
	search searchForShapes: '4'.
	self assert: search numberOfHighlightedShapes equals: 1.
	search searchForShapes: '5'.
	self assert: search numberOfHighlightedShapes equals: 2.
	search searchForShapes: '3'.
	self assert: search numberOfHighlightedShapes equals: 3.
	
	search resetAllHighlightedShapes.
	self assert: search numberOfHighlightedShapes equals: 0.! !

!RSSearchInCanvasTest methodsFor: 'tests' stamp: ''!
testShadow
	self assert: search numberOfPerformedSearches equals: 0.
	
	search searchForShapes: '4'.
	self assert: (shapes fourth hasProperty: #shadow).
	self deny: (shapes fifth hasProperty: #shadow).
	self assert: search numberOfPerformedSearches equals: 1.
	
	search searchForShapes: '5'.
	self assert: (shapes fourth hasProperty: #shadow).
	self assert: (shapes fifth hasProperty: #shadow).
	self 
		deny: (shapes fourth propertyAt: #shadow) color 
		equals: (shapes fifth propertyAt: #shadow) color.
	self assert: search numberOfPerformedSearches equals: 2.
	
	self assert: search numberOfHighlightedShapes equals: 2.

	search resetAllHighlightedShapes.
	self deny: (shapes fourth hasProperty: #shadow).
	self deny: (shapes fifth hasProperty: #shadow).
	self assert: search numberOfPerformedSearches equals: 0.
! !

!RSSearchInCanvasTest methodsFor: 'tests' stamp: ''!
testExactMatch
	search useExactMatch.
	search searchForShapes: '4'.
	self deny: (shapes fourth hasProperty: #shadow).
	
	search doNotUseExactMatch.
	search searchForShapes: '4'.
	self assert: (shapes fourth hasProperty: #shadow).! !

!RSSearchInCanvasTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	c := RSCanvas new.
	shapes := (1 to: 10) * 100
		collect: [ :n | 
			RSEllipse new
				size: 20;
				color: Color gray;
				model: n ]
		as: RSGroup.
	c addAll: shapes.
	RSGridLayout on: shapes.
	shapes @ RSPopup.
	con := RSCanvasController new.
	search := RSSearchInCanvasInteraction new.
	con addInteraction: search.
	search canvas: c.
	c @ con! !

!RSSelectionChangedEvent commentStamp: ''!
called when user changes the selection area with mouse dragging event!
!RSSelectionChangedEvent methodsFor: 'accessing' stamp: ''!
oldSelectedShapes: aRSGroup
	oldSelectedShapes := aRSGroup! !

!RSSelectionChangedEvent methodsFor: 'accessing' stamp: ''!
oldSelectedShapes
	^ oldSelectedShapes! !

!RSSelectionEndEvent commentStamp: ''!
called when user mouse up the selection area!
!RSSelectionEvent commentStamp: ''!
I represent new event with selection for elastic boxes!
!RSSelectionEvent methodsFor: 'accessing' stamp: ''!
selectedShapes: aRSGroup
	selectedShapes := aRSGroup! !

!RSSelectionEvent methodsFor: 'accessing' stamp: ''!
selectedShapes
	^ selectedShapes! !

!RSSelectionPresentationInteraction commentStamp: ''!
Define the interaction used by the inspector to highlight a selected shape. This is very convenient in the inspector for example. Normally, it should not be invoked directly.

Here is an example:

```Smalltalk
c := RSCanvas new.
shapes := (1 to: 100) collect: [ :v | RSBox new model: v ] as: RSGroup.
c addAll: shapes.
RSNormalizer size shapes: shapes; normalize: #yourself.
RSFlowLayout on: shapes.
shapes @ RSSelectionPresentation.
c @ RSCanvasController.
c open
```
!
!RSSelectionPresentationInteraction methodsFor: 'accessing' stamp: ''!
presentation: aRSRoassalPresentation
	presentation := aRSRoassalPresentation! !

!RSSelectionPresentationInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self padding: 10.! !

!RSSelectionPresentationInteraction methodsFor: 'hooks' stamp: ''!
scaleFrom: aShape
	"Return the scale used by the canvas of the shape"
	aShape canvas ifNil: [ ^ 1 ].
	^ aShape canvas camera scale! !

!RSSelectionPresentationInteraction methodsFor: 'accessing' stamp: ''!
padding: aNumber
	padding := aNumber! !

!RSSelectionPresentationInteraction methodsFor: 'accessing' stamp: ''!
key
	^ self class name! !

!RSSelectionPresentationInteraction methodsFor: 'accessing' stamp: ''!
shadowColor: aColor
	shadowColor := aColor! !

!RSSelectionPresentationInteraction methodsFor: 'hooks' stamp: ''!
putShadowOn: aShape

	| shadow pad |
	"Make sure that  the size is indenpendent of the camera scale"
	pad := self padding / (self scaleFrom: aShape).
	shadow := RSBox new
		          fromRectangle:
			          (aShape encompassingRectangle expandBy: pad);
		          paint: self shadowColor;
		          cornerRadius: pad * 0.75;
		          yourself.
	aShape removeInteractionIfPresent: RSLocation.
	RSLocation new stick: shadow on: aShape.
	
	(aShape parent notNil or: [ aShape canvas ]) ifNil: [ ^ self ].
	aShape parent addShape: shadow before: aShape.
	aShape canvas propertyAt: self key put: shadow! !

!RSSelectionPresentationInteraction methodsFor: 'hooks' stamp: ''!
onShape: aShape
	aShape model ifNil: [ ^ self ].
	aShape canvas ifNotNil: [ :c | 
		c propertyAt: #canvasInspectorSelection ifAbsentPut: [ 
			c removeInteractionIfPresent: self class.
			c when: RSMouseClick do: [ :evt |
				self removeShadowOn: evt.
				evt signalUpdate. ].
			1 ].
		 ].
	aShape when: RSMouseClick do: [ :evt | self selection: evt shape ].! !

!RSSelectionPresentationInteraction methodsFor: 'dependencies' stamp: ''!
release
	presentation := nil! !

!RSSelectionPresentationInteraction methodsFor: 'hooks' stamp: ''!
removeShadowOn: aShape
	"Nothing to do if there is no canvas"
	aShape canvas ifNil: [ ^ self ].
	
	aShape canvas
		propertyAt: self key
		ifPresent: [ :shadow | shadow remove ].
	aShape canvas removeKey: self key.! !

!RSSelectionPresentationInteraction methodsFor: 'accessing' stamp: ''!
shadowColor
	^ shadowColor ifNil: [ shadowColor := Color blue alpha: 0.3 ]! !

!RSSelectionPresentationInteraction methodsFor: 'accessing' stamp: ''!
padding
	^ padding! !

!RSSelectionPresentationInteraction methodsFor: 'accessing' stamp: ''!
presentation
	^ presentation! !

!RSSelectionPresentationInteraction methodsFor: 'hooks' stamp: ''!
selection: aShape
	self presentation ifNotNil: [ 
		self presentation value: (SpWrappedItem new selectedItem: aShape model) ]. 
	self
		removeShadowOn: aShape;
		putShadowOn: aShape.
		
	aShape canvas ifNotNil: [ 
		aShape canvas signalUpdate ]! !

!RSSelectionPresentationTest methodsFor: 'tests' stamp: ''!
testBasic

	| c shapes |
	c := RSCanvas new.
	shapes := (1 to: 100) collect: [ :v | RSBox new model: v ] as: RSGroup.
	c addAll: shapes.
	RSNormalizer size shapes: shapes; normalize: #yourself.
	RSFlowLayout on: shapes.
	shapes @ RSSelectionPresentationInteraction.
	c @ RSCanvasController.

	"make sure there is no error when clicking on an element, while being outside the GTInspector"
	c nodes first announce: RSMouseClick
! !

!RSSelectionPresentationTest methodsFor: 'tests' stamp: ''!
testCanvasInspect
	| c  window |
	c := RSCanvas new.
	c add: RSBox new.
	window := c inspect.
	window class = RSCanvas 
		ifTrue: [ c morph window delete ]
		ifFalse: [ window delete ]
	! !

!RSSelectionPresentationTest methodsFor: 'tests' stamp: ''!
testWithNoCanvas

	| shapes |
	shapes := (1 to: 100) collect: [ :v | RSBox new model: v ] as: RSGroup.
	shapes @ RSSelectionPresentationInteraction.
	shapes first announce: RSMouseClick! !

!RSSelectionStartEvent commentStamp: ''!
called when user starts the selection!
!RSSequentialAnimation commentStamp: ''!
I wait until one animation ends to start the another animation!
!RSSequentialAnimation methodsFor: 'refreshing' stamp: ''!
current
	^ animations at: currentIndex ifAbsent: [ nil ].! !

!RSSequentialAnimation methodsFor: 'refreshing' stamp: ''!
step
	self startStep.
	self stepCurrent.
	self currentHasCompleted ifTrue: [ 
		self current remove.
		currentIndex := currentIndex + 1. ].
	currentIndex > animations size ifTrue: [ 
		currentIndex := 1.
		self loopDone ].
	self updateHasCompleted.! !

!RSSequentialAnimation methodsFor: 'accessing' stamp: ''!
duration
	animations ifEmpty: [ ^ 0 asDuration ].
	^ (animations collect: #allDuration) sum! !

!RSSequentialAnimation methodsFor: 'actions' stamp: ''!
currentDo: block
	| current |
	current := self current.
	current ifNil: [ ^ self ].
	block value: current.! !

!RSSequentialAnimation methodsFor: 'actions' stamp: ''!
pause
	super pause.
	self currentDo: #pause.! !

!RSSequentialAnimation methodsFor: 'refreshing' stamp: ''!
currentHasCompleted
	| current |
	current := self current.
	current ifNil: [ ^ false ].
	^ current hasCompleted! !

!RSSequentialAnimation methodsFor: 'refreshing' stamp: ''!
stepCurrent
	| current |
	current := self current.
	current ifNil: [ ^ self ].
	self startIfNessesary: current.
	current refresh.! !

!RSSequentialAnimation methodsFor: 'actions' stamp: ''!
continue
	super continue.
	self currentDo: #continue.! !

!RSSequentialAnimation methodsFor: 'actions' stamp: ''!
start
	super start.
	currentIndex := 1.! !

!RSSequentialAnimationTest commentStamp: ''!
I have test for sequential animation!
!RSSequentialAnimationTest methodsFor: 'tests' stamp: ''!
testAddingAnimations
	self 
		addingInComposite: canvas sequentialAnimation
		duration: 3 second! !

!RSSequentialAnimationTest methodsFor: 'tests' stamp: ''!
testStep
	| value animation |
	value := 0.
	animation := RSSequentialAnimation new
		add: (RSTransitionAnimation new 
			onStepDo: [ :t| value := value + 1 ]);
		yourself.
	canvas addAnimation: animation.
	self assert: value equals: 0.
	canvas playAnimations.
	self assert: value equals: 1.! !

!RSSequentialAnimationTest methodsFor: 'tests' stamp: ''!
testSequentialAnimationCreation
	self 
		createAnimationWith: [ canvas animationFrom: {} ]
		animationClass: RSSequentialAnimation.! !

!RSSequentialAnimationTest methodsFor: 'tests' stamp: ''!
testDuration
	| animation |
	animation := RSSequentialAnimation new.
	self assert: animation duration equals: 0 seconds.
	
	animation := RSSequentialAnimation new
		add: (RSTransitionAnimation new duration: 2 seconds);
		yourself.
	self assert: animation duration equals: 2 seconds.
	self assert: animation allDuration equals: 2 seconds.
	
	animation := RSSequentialAnimation new
		loops: 5;
		add: (RSTransitionAnimation new duration: 2 seconds; loops: 5);
		yourself.
	self assert: animation duration equals: 10 seconds.
	self assert: animation allDuration equals: 50 seconds.
	
	animation := RSSequentialAnimation new
		repeat;
		add: (RSTransitionAnimation new duration: 2 seconds;  repeat);
		yourself.
	self assert: animation duration equals: 2 seconds.
	self assert: animation allDuration equals: 2 seconds.! !

!RSSequentialAnimationTest methodsFor: 'tests' stamp: ''!
testStepEvent
	| value loop animation |
	value := nil.
	loop := 0.
	animation := RSSequentialAnimation new
		loops: 3;
		add: (RSTransitionAnimation new 
			duration: 100 milliSeconds;
			onStepDo: [ :t| value := t ]);
		when: RSAnimationLoopEvent do: [ :evt | loop := loop + 1.].
	canvas addAnimation: animation.
	self assert: value isNil.
	self assert: loop equals: 0.
	self assert: animation endTime isNil.
	self runAnimation: animation threshold: 500.
	self deny: value isNil.
	self assert: loop equals: 3.
	self deny: animation endTime isNil.
	self deny: animation isRunning.! !

!RSSequentialColorPalette commentStamp: ''!
Sequential schemes are suited to ordered data that progress from low to high. Lightness steps dominate the look of these schemes, with light colors for low data values to dark colors for high data values.

More info: 
http://colorbrewer2.org/learnmore/schemes_full.html

---Copyright:
All colors, palettes and schemes are from www.ColorBrewer.org by Cynthia A. Brewer, Geography, Pennsylvania State University.
Code by Cynthia is under the Apache License 2.0 (https://github.com/axismaps/colorbrewer/blob/master/LICENCE.txt)
Roassal3 is distributed under the MIT License, which is compatible with Apache License 2.0 !
!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purd3
	^ self fromTriplet: #(#(231 225 239) #(201 148 199) #(221 28 119))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
blues5
	^ self fromTriplet: #(#(239 243 255) #(189 215 231) #(107 174 214) #(49 130 189) #(8 81 156))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
oranges8
	^ self fromTriplet: #(#(255 245 235) #(254 230 206) #(253 208 162) #(253 174 107) #(253 141 60) #(241 105 19) #(217 72 1) #(140 45 4))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubu6
	^ self fromTriplet: #(#(241 238 246) #(208 209 230) #(166 189 219) #(116 169 207) #(43 140 190) #(4 90 141))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greens4
	^ self fromTriplet: #(#(237 248 233) #(186 228 179) #(116 196 118) #(35 139 69))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
blues4
	^ self fromTriplet: #(#(239 243 255) #(189 215 231) #(107 174 214) #(33 113 181))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubugn4
	^ self fromTriplet: #(#(246 239 247) #(189 201 225) #(103 169 207) #(2 129 138))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bupu9
	^ self fromTriplet: #(#(247 252 253) #(224 236 244) #(191 211 230) #(158 188 218) #(140 150 198) #(140 107 177) #(136 65 157) #(129 15 124) #(77 0 75))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
blues6
	^ self fromTriplet: #(#(239 243 255) #(198 219 239) #(158 202 225) #(107 174 214) #(49 130 189) #(8 81 156))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
gnbu7
	^ self fromTriplet: #(#(240 249 232) #(204 235 197) #(168 221 181) #(123 204 196) #(78 179 211) #(43 140 190) #(8 88 158))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purples3
	^ self fromTriplet: #(#(239 237 245) #(188 189 220) #(117 107 177))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubu7
	^ self fromTriplet: #(#(241 238 246) #(208 209 230) #(166 189 219) #(116 169 207) #(54 144 192) #(5 112 176) #(3 78 123))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
orrd8
	^ self fromTriplet: #(#(255 247 236) #(254 232 200) #(253 212 158) #(253 187 132) #(252 141 89) #(239 101 72) #(215 48 31) #(153 0 0))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
orrd3
	^ self fromTriplet: #(#(254 232 200) #(253 187 132) #(227 74 51))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greys7
	^ self fromTriplet: #(#(247 247 247) #(217 217 217) #(189 189 189) #(150 150 150) #(115 115 115) #(82 82 82) #(37 37 37))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgn5
	^ self fromTriplet: #(#(255 255 204) #(194 230 153) #(120 198 121) #(49 163 84) #(0 104 55))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorrd9
	^ self fromTriplet: #(#(255 255 204) #(255 237 160) #(254 217 118) #(254 178 76) #(253 141 60) #(252 78 42) #(227 26 28) #(189 0 38) #(128 0 38))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purd6
	^ self fromTriplet: #(#(241 238 246) #(212 185 218) #(201 148 199) #(223 101 176) #(221 28 119) #(152 0 67))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
reds9
	^ self fromTriplet: #(#(255 245 240) #(254 224 210) #(252 187 161) #(252 146 114) #(251 106 74) #(239 59 44) #(203 24 29) #(165 15 21) #(103 0 13))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgn4
	^ self fromTriplet: #(#(255 255 204) #(194 230 153) #(120 198 121) #(35 132 67))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bugn4
	^ self fromTriplet: #(#(237 248 251) #(178 226 226) #(102 194 164) #(35 139 69))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorrd5
	^ self fromTriplet: #(#(255 255 178) #(254 204 92) #(253 141 60) #(240 59 32) #(189 0 38))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
rdpu7
	^ self fromTriplet: #(#(254 235 226) #(252 197 192) #(250 159 181) #(247 104 161) #(221 52 151) #(174 1 126) #(122 1 119))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greens6
	^ self fromTriplet: #(#(237 248 233) #(199 233 192) #(161 217 155) #(116 196 118) #(49 163 84) #(0 109 44))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greys6
	^ self fromTriplet: #(#(247 247 247) #(217 217 217) #(189 189 189) #(150 150 150) #(99 99 99) #(37 37 37))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
oranges4
	^ self fromTriplet: #(#(254 237 222) #(253 190 133) #(253 141 60) #(217 71 1))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greys5
	^ self fromTriplet: #(#(247 247 247) #(204 204 204) #(150 150 150) #(99 99 99) #(37 37 37))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
rdpu4
	^ self fromTriplet: #(#(254 235 226) #(251 180 185) #(247 104 161) #(174 1 126))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greens7
	^ self fromTriplet: #(#(237 248 233) #(199 233 192) #(161 217 155) #(116 196 118) #(65 171 93) #(35 139 69) #(0 90 50))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
gnbu5
	^ self fromTriplet: #(#(240 249 232) #(186 228 188) #(123 204 196) #(67 162 202) #(8 104 172))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgnbu8
	^ self fromTriplet: #(#(255 255 217) #(237 248 177) #(199 233 180) #(127 205 187) #(65 182 196) #(29 145 192) #(34 94 168) #(12 44 132))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greens3
	^ self fromTriplet: #(#(229 245 224) #(161 217 155) #(49 163 84))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
gnbu4
	^ self fromTriplet: #(#(240 249 232) #(186 228 188) #(123 204 196) #(43 140 190))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorbr3
	^ self fromTriplet: #(#(255 247 188) #(254 196 79) #(217 95 14))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubugn8
	^ self fromTriplet: #(#(255 247 251) #(236 226 240) #(208 209 230) #(166 189 219) #(103 169 207) #(54 144 192) #(2 129 138) #(1 100 80))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purples9
	^ self fromTriplet: #(#(252 251 253) #(239 237 245) #(218 218 235) #(188 189 220) #(158 154 200) #(128 125 186) #(106 81 163) #(84 39 143) #(63 0 125))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgnbu6
	^ self fromTriplet: #(#(255 255 204) #(199 233 180) #(127 205 187) #(65 182 196) #(44 127 184) #(37 52 148))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorrd3
	^ self fromTriplet: #(#(255 237 160) #(254 178 76) #(240 59 32))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorrd6
	^ self fromTriplet: #(#(255 255 178) #(254 217 118) #(254 178 76) #(253 141 60) #(240 59 32) #(189 0 38))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bupu4
	^ self fromTriplet: #(#(237 248 251) #(179 205 227) #(140 150 198) #(136 65 157))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
gnbu9
	^ self fromTriplet: #(#(247 252 240) #(224 243 219) #(204 235 197) #(168 221 181) #(123 204 196) #(78 179 211) #(43 140 190) #(8 104 172) #(8 64 129))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
reds6
	^ self fromTriplet: #(#(254 229 217) #(252 187 161) #(252 146 114) #(251 106 74) #(222 45 38) #(165 15 21))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubu3
	^ self fromTriplet: #(#(236 231 242) #(166 189 219) #(43 140 190))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorbr5
	^ self fromTriplet: #(#(255 255 212) #(254 217 142) #(254 153 41) #(217 95 14) #(153 52 4))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
blues9
	^ self fromTriplet: #(#(247 251 255) #(222 235 247) #(198 219 239) #(158 202 225) #(107 174 214) #(66 146 198) #(33 113 181) #(8 81 156) #(8 48 107))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
oranges6
	^ self fromTriplet: #(#(254 237 222) #(253 208 162) #(253 174 107) #(253 141 60) #(230 85 13) #(166 54 3))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgnbu9
	^ self fromTriplet: #(#(255 255 217) #(237 248 177) #(199 233 180) #(127 205 187) #(65 182 196) #(29 145 192) #(34 94 168) #(37 52 148) #(8 29 88))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorrd7
	^ self fromTriplet: #(#(255 255 178) #(254 217 118) #(254 178 76) #(253 141 60) #(252 78 42) #(227 26 28) #(177 0 38))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bupu6
	^ self fromTriplet: #(#(237 248 251) #(191 211 230) #(158 188 218) #(140 150 198) #(136 86 167) #(129 15 124))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bugn3
	^ self fromTriplet: #(#(229 245 249) #(153 216 201) #(44 162 95))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
reds5
	^ self fromTriplet: #(#(254 229 217) #(252 174 145) #(251 106 74) #(222 45 38) #(165 15 21))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgnbu4
	^ self fromTriplet: #(#(255 255 204) #(161 218 180) #(65 182 196) #(34 94 168))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greys9
	^ self fromTriplet: #(#(255 255 255) #(240 240 240) #(217 217 217) #(189 189 189) #(150 150 150) #(115 115 115) #(82 82 82) #(37 37 37) #(0 0 0))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
blues3
	^ self fromTriplet: #(#(222 235 247) #(158 202 225) #(49 130 189))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubugn5
	^ self fromTriplet: #(#(246 239 247) #(189 201 225) #(103 169 207) #(28 144 153) #(1 108 89))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubugn7
	^ self fromTriplet: #(#(246 239 247) #(208 209 230) #(166 189 219) #(103 169 207) #(54 144 192) #(2 129 138) #(1 100 80))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purples4
	^ self fromTriplet: #(#(242 240 247) #(203 201 226) #(158 154 200) #(106 81 163))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
rdpu8
	^ self fromTriplet: #(#(255 247 243) #(253 224 221) #(252 197 192) #(250 159 181) #(247 104 161) #(221 52 151) #(174 1 126) #(122 1 119))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgn3
	^ self fromTriplet: #(#(247 252 185) #(173 221 142) #(49 163 84))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purples6
	^ self fromTriplet: #(#(242 240 247) #(218 218 235) #(188 189 220) #(158 154 200) #(117 107 177) #(84 39 143))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgn8
	^ self fromTriplet: #(#(255 255 229) #(247 252 185) #(217 240 163) #(173 221 142) #(120 198 121) #(65 171 93) #(35 132 67) #(0 90 50))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greys4
	^ self fromTriplet: #(#(247 247 247) #(204 204 204) #(150 150 150) #(82 82 82))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorbr4
	^ self fromTriplet: #(#(255 255 212) #(254 217 142) #(254 153 41) #(204 76 2))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purd9
	^ self fromTriplet: #(#(247 244 249) #(231 225 239) #(212 185 218) #(201 148 199) #(223 101 176) #(231 41 138) #(206 18 86) #(152 0 67) #(103 0 31))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bugn7
	^ self fromTriplet: #(#(237 248 251) #(204 236 230) #(153 216 201) #(102 194 164) #(65 174 118) #(35 139 69) #(0 88 36))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
rdpu9
	^ self fromTriplet: #(#(255 247 243) #(253 224 221) #(252 197 192) #(250 159 181) #(247 104 161) #(221 52 151) #(174 1 126) #(122 1 119) #(73 0 106))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorbr7
	^ self fromTriplet: #(#(255 255 212) #(254 227 145) #(254 196 79) #(254 153 41) #(236 112 20) #(204 76 2) #(140 45 4))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
blues8
	^ self fromTriplet: #(#(247 251 255) #(222 235 247) #(198 219 239) #(158 202 225) #(107 174 214) #(66 146 198) #(33 113 181) #(8 69 148))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubu9
	^ self fromTriplet: #(#(255 247 251) #(236 231 242) #(208 209 230) #(166 189 219) #(116 169 207) #(54 144 192) #(5 112 176) #(4 90 141) #(2 56 88))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
gnbu6
	^ self fromTriplet: #(#(240 249 232) #(204 235 197) #(168 221 181) #(123 204 196) #(67 162 202) #(8 104 172))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purples8
	^ self fromTriplet: #(#(252 251 253) #(239 237 245) #(218 218 235) #(188 189 220) #(158 154 200) #(128 125 186) #(106 81 163) #(74 20 134))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
orrd7
	^ self fromTriplet: #(#(254 240 217) #(253 212 158) #(253 187 132) #(252 141 89) #(239 101 72) #(215 48 31) #(153 0 0))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
reds7
	^ self fromTriplet: #(#(254 229 217) #(252 187 161) #(252 146 114) #(251 106 74) #(239 59 44) #(203 24 29) #(153 0 13))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgnbu5
	^ self fromTriplet: #(#(255 255 204) #(161 218 180) #(65 182 196) #(44 127 184) #(37 52 148))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgn9
	^ self fromTriplet: #(#(255 255 229) #(247 252 185) #(217 240 163) #(173 221 142) #(120 198 121) #(65 171 93) #(35 132 67) #(0 104 55) #(0 69 41))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgn6
	^ self fromTriplet: #(#(255 255 204) #(217 240 163) #(173 221 142) #(120 198 121) #(49 163 84) #(0 104 55))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purd7
	^ self fromTriplet: #(#(241 238 246) #(212 185 218) #(201 148 199) #(223 101 176) #(231 41 138) #(206 18 86) #(145 0 63))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
orrd5
	^ self fromTriplet: #(#(254 240 217) #(253 204 138) #(252 141 89) #(227 74 51) #(179 0 0))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
rdpu6
	^ self fromTriplet: #(#(254 235 226) #(252 197 192) #(250 159 181) #(247 104 161) #(197 27 138) #(122 1 119))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
oranges7
	^ self fromTriplet: #(#(254 237 222) #(253 208 162) #(253 174 107) #(253 141 60) #(241 105 19) #(217 72 1) #(140 45 4))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubugn6
	^ self fromTriplet: #(#(246 239 247) #(208 209 230) #(166 189 219) #(103 169 207) #(28 144 153) #(1 108 89))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
oranges9
	^ self fromTriplet: #(#(255 245 235) #(254 230 206) #(253 208 162) #(253 174 107) #(253 141 60) #(241 105 19) #(217 72 1) #(166 54 3) #(127 39 4))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
blues7
	^ self fromTriplet: #(#(239 243 255) #(198 219 239) #(158 202 225) #(107 174 214) #(66 146 198) #(33 113 181) #(8 69 148))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
oranges5
	^ self fromTriplet: #(#(254 237 222) #(253 190 133) #(253 141 60) #(230 85 13) #(166 54 3))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubu5
	^ self fromTriplet: #(#(241 238 246) #(189 201 225) #(116 169 207) #(43 140 190) #(4 90 141))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bugn9
	^ self fromTriplet: #(#(247 252 253) #(229 245 249) #(204 236 230) #(153 216 201) #(102 194 164) #(65 174 118) #(35 139 69) #(0 109 44) #(0 68 27))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
rdpu3
	^ self fromTriplet: #(#(253 224 221) #(250 159 181) #(197 27 138))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purples5
	^ self fromTriplet: #(#(242 240 247) #(203 201 226) #(158 154 200) #(117 107 177) #(84 39 143))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorrd8
	^ self fromTriplet: #(#(255 255 204) #(255 237 160) #(254 217 118) #(254 178 76) #(253 141 60) #(252 78 42) #(227 26 28) #(177 0 38))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
reds3
	^ self fromTriplet: #(#(254 224 210) #(252 146 114) #(222 45 38))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorbr9
	^ self fromTriplet: #(#(255 255 229) #(255 247 188) #(254 227 145) #(254 196 79) #(254 153 41) #(236 112 20) #(204 76 2) #(153 52 4) #(102 37 6))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubu8
	^ self fromTriplet: #(#(255 247 251) #(236 231 242) #(208 209 230) #(166 189 219) #(116 169 207) #(54 144 192) #(5 112 176) #(3 78 123))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greens5
	^ self fromTriplet: #(#(237 248 233) #(186 228 179) #(116 196 118) #(49 163 84) #(0 109 44))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bugn5
	^ self fromTriplet: #(#(237 248 251) #(178 226 226) #(102 194 164) #(44 162 95) #(0 109 44))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
orrd4
	^ self fromTriplet: #(#(254 240 217) #(253 204 138) #(252 141 89) #(215 48 31))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greens8
	^ self fromTriplet: #(#(247 252 245) #(229 245 224) #(199 233 192) #(161 217 155) #(116 196 118) #(65 171 93) #(35 139 69) #(0 90 50))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgnbu7
	^ self fromTriplet: #(#(255 255 204) #(199 233 180) #(127 205 187) #(65 182 196) #(29 145 192) #(34 94 168) #(12 44 132))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greys3
	^ self fromTriplet: #(#(240 240 240) #(189 189 189) #(99 99 99))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubu4
	^ self fromTriplet: #(#(241 238 246) #(189 201 225) #(116 169 207) #(5 112 176))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purd5
	^ self fromTriplet: #(#(241 238 246) #(215 181 216) #(223 101 176) #(221 28 119) #(152 0 67))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purples7
	^ self fromTriplet: #(#(242 240 247) #(218 218 235) #(188 189 220) #(158 154 200) #(128 125 186) #(106 81 163) #(74 20 134))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
oranges3
	^ self fromTriplet: #(#(254 230 206) #(253 174 107) #(230 85 13))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purd4
	^ self fromTriplet: #(#(241 238 246) #(215 181 216) #(223 101 176) #(206 18 86))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgnbu3
	^ self fromTriplet: #(#(237 248 177) #(127 205 187) #(44 127 184))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylgn7
	^ self fromTriplet: #(#(255 255 204) #(217 240 163) #(173 221 142) #(120 198 121) #(65 171 93) #(35 132 67) #(0 90 50))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bupu3
	^ self fromTriplet: #(#(224 236 244) #(158 188 218) #(136 86 167))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greens9
	^ self fromTriplet: #(#(247 252 245) #(229 245 224) #(199 233 192) #(161 217 155) #(116 196 118) #(65 171 93) #(35 139 69) #(0 109 44) #(0 68 27))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bupu5
	^ self fromTriplet: #(#(237 248 251) #(179 205 227) #(140 150 198) #(136 86 167) #(129 15 124))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubugn3
	^ self fromTriplet: #(#(236 226 240) #(166 189 219) #(28 144 153))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bugn8
	^ self fromTriplet: #(#(247 252 253) #(229 245 249) #(204 236 230) #(153 216 201) #(102 194 164) #(65 174 118) #(35 139 69) #(0 88 36))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
gnbu3
	^ self fromTriplet: #(#(224 243 219) #(168 221 181) #(67 162 202))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
purd8
	^ self fromTriplet: #(#(247 244 249) #(231 225 239) #(212 185 218) #(201 148 199) #(223 101 176) #(231 41 138) #(206 18 86) #(145 0 63))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
gnbu8
	^ self fromTriplet: #(#(247 252 240) #(224 243 219) #(204 235 197) #(168 221 181) #(123 204 196) #(78 179 211) #(43 140 190) #(8 88 158))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
orrd6
	^ self fromTriplet: #(#(254 240 217) #(253 212 158) #(253 187 132) #(252 141 89) #(227 74 51) #(179 0 0))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
reds8
	^ self fromTriplet: #(#(255 245 240) #(254 224 210) #(252 187 161) #(252 146 114) #(251 106 74) #(239 59 44) #(203 24 29) #(153 0 13))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
pubugn9
	^ self fromTriplet: #(#(255 247 251) #(236 226 240) #(208 209 230) #(166 189 219) #(103 169 207) #(54 144 192) #(2 129 138) #(1 108 89) #(1 70 54))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
rdpu5
	^ self fromTriplet: #(#(254 235 226) #(251 180 185) #(247 104 161) #(197 27 138) #(122 1 119))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
reds4
	^ self fromTriplet: #(#(254 229 217) #(252 174 145) #(251 106 74) #(203 24 29))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bupu8
	^ self fromTriplet: #(#(247 252 253) #(224 236 244) #(191 211 230) #(158 188 218) #(140 150 198) #(140 107 177) #(136 65 157) #(110 1 107))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bupu7
	^ self fromTriplet: #(#(237 248 251) #(191 211 230) #(158 188 218) #(140 150 198) #(140 107 177) #(136 65 157) #(110 1 107))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorbr8
	^ self fromTriplet: #(#(255 255 229) #(255 247 188) #(254 227 145) #(254 196 79) #(254 153 41) #(236 112 20) #(204 76 2) #(140 45 4))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
orrd9
	^ self fromTriplet: #(#(255 247 236) #(254 232 200) #(253 212 158) #(253 187 132) #(252 141 89) #(239 101 72) #(215 48 31) #(179 0 0) #(127 0 0))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
greys8
	^ self fromTriplet: #(#(255 255 255) #(240 240 240) #(217 217 217) #(189 189 189) #(150 150 150) #(115 115 115) #(82 82 82) #(37 37 37))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
bugn6
	^ self fromTriplet: #(#(237 248 251) #(204 236 230) #(153 216 201) #(102 194 164) #(44 162 95) #(0 109 44))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorbr6
	^ self fromTriplet: #(#(255 255 212) #(254 227 145) #(254 196 79) #(254 153 41) #(217 95 14) #(153 52 4))! !

!RSSequentialColorPalette methodsFor: 'palette' stamp: ''!
ylorrd4
	^ self fromTriplet: #(#(255 255 178) #(254 204 92) #(253 141 60) #(227 26 28))! !

!RSSequentialColorPalette class methodsFor: 'accessing' stamp: ''!
paletteName
	^ #sequential! !

!RSShape commentStamp: ''!
<keyClass>
A shape is a visual element meant to be displayed. Roassal offers numerous shapes, themselves highly configurable. The class `RSShape` is the root of all the Roassal shapes, and a shape is typically created by instantiating a subclass of `RSShape`. For example, a box is defined by instantiating `RSBox`. 

For example, a colored box with a thick border may be defined as:

```Smalltalk
box := RSBox new
			size: 80;
			color: #yellow;
			border: (RSBorder new color: #blue; width: 10).
```

Colors may be provided either as a color object (e.g., `Color blue` or `Color r: 0 g: 0 b: 1.0`) or as a symbol (e.g., `#yellow`). In case a symbol is provided, it is converted to a color object using `Color>>colorFrom:`, as in `Color>>colorFrom: #yellow`. 

Although most of the configuration may be carried out by directly sending an object with a literal (e.g., `size: 80`), part of the configuration of the shape may involve dedicated objects, such as `RSBorder`.

`RSShape` is the root of all the Roassal shapes. A shape represents a visual element meant to be inserted in a `RSCanvas`. `RSShape` is an abstract class, not meant to be directly instantiated therefore.

*Responsibility*: A shape, i.e., subclass of the class `RSShape` is responsible to model a visual element. 

*Collaborators*: A shape is meaningful when inserted in a canvas

*Variables*:
- `paint`: the color of the Athens paint object used to render the visual shape
- `path`: refers to AthensCairoPath, which is a resource of a foreign object, ie., the cairo on
- `border`:
- `parent`: the parent shape
- `isFixed`: a boolean indicating if the shape is fixed (ie., not subject to the camera position and movement)
!
!RSShape methodsFor: 'accessing' stamp: ''!
color: aColor
	"Set the color of the shape. 

```Smalltalk
c := RSCanvas new.
c add: (RSBox new size: 50; color: #blue).
c
```
	
```Smalltalk
c := RSCanvas new.
c add: (RSBox new size: 50; color: Color blue).
c
```
	"
	paint := aColor.
	paint isColor ifTrue: [ ^ self ].
	paint := Color colorFrom: aColor.! !

!RSShape methodsFor: 'testing' stamp: ''!
isInACanvas
	^ parent notNil! !

!RSShape methodsFor: '*Roassal3-Animation' stamp: ''!
newAnimation
	"Create a new animation"
	^ parent ifNil: [ 
		| animations anime |
		animations := self propertyAt: #todoAnimations ifAbsentPut: [ OrderedCollection new ].
		anime := RSTransitionAnimation new. 
		animations add: anime.
		anime.
		 ] ifNotNil: [ parent newAnimation ]! !

!RSShape methodsFor: 'accessing' stamp: ''!
children
	"only RSComposite can use children"
	^ nil! !

!RSShape methodsFor: 'border' stamp: ''!
borderColor: aColor
	"Set a border with the provided color. For example:

```
c := RSCanvas new.
r := Random seed: 42.
40 timesRepeat: [
	box := RSBox new width: (r nextInteger: 80); height: (r nextInteger: 80); color: Color gray; cornerRadius: 10.
	box borderColor: #black.
	box color: Color random translucent.
	box translateTo: (r nextInteger: 200) @ (r nextInteger: 200).
	c add: box.
].
c @ RSCanvasController.
c open
```"
	border ifNil: [ self withBorder ].
	self border color: aColor! !

!RSShape methodsFor: 'path' stamp: ''!
path: aPath
	"Set the path of the shape. It set an AthensCairoPath. Note that this value is set to nil when the Pharo image is restarted"
	path := aPath! !

!RSShape methodsFor: 'accessing - attributes' stamp: ''!
depth
	^ self propertyAt: #depth! !

!RSShape methodsFor: 'accessing' stamp: ''!
noPaint
	paint := nil! !

!RSShape methodsFor: 'announcer' stamp: ''!
announce: anEventOrAnEventClassOrABlock
	"Send an event. The event is provided as argument, and may be either an event object, an event class, or a block (taking no argument) that returns an event object. These different way of specifying events addresses some performance concern."
	| theEventToSend |
	announcer ifNil: [ ^ self ].
	theEventToSend := anEventOrAnEventClassOrABlock value asAnnouncement.
	theEventToSend canvas: self canvas.
	theEventToSend shape: self.
	announcer announce: theEventToSend.! !

!RSShape methodsFor: 'accessing' stamp: ''!
paint
	^ paint! !

!RSShape methodsFor: 'testing' stamp: ''!
isLine
	^ false! !

!RSShape methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModel: anObject result: result
	self model = anObject ifTrue: [ result add: self ]! !

!RSShape methodsFor: 'accessing - computed' stamp: ''!
shapeWithAction: eventClass forPosition: position
	^ (self hasEventCallback and: [ 
		(self announcer handleEventClass: eventClass)
			and: [ self includesPoint: position ] ]) 
			ifTrue: [ self ]
			ifFalse: [ nil ]! !

!RSShape methodsFor: 'actions' stamp: ''!
setAsFixed
	"Per default, a shape is subject to the camera mouvement. If the camera is relocated, shapes appears to be relocated. This behavior can be avoided by sending the message #setAsFixed to a shape, which makes the shape fixed in the canvas. This is useful to define menus.
	
	The message setAsFixed must be send after being added to a canvas"
	parent ifNil: [ self error: 'Add first this shape in the canvas' ].
	parent setAsFixed: self.
	isFixed := true.! !

!RSShape methodsFor: 'accessing - attributes' stamp: ''!
index: anObject
	"the current index of this object in an object collection"
	self propertyAt: #index put: anObject! !

!RSShape methodsFor: 'accessing - attributes' stamp: ''!
model
	"Return the model object of the shape. If no model has been set, it return `nil`"
	^ model! !

!RSShape methodsFor: 'path' stamp: ''!
path
	^ path! !

!RSShape methodsFor: '*Roassal3-Interaction' stamp: ''!
labeled
	self @ RSLabeled.! !

!RSShape methodsFor: 'testing' stamp: ''!
isShape
	"Useful to lookup the canvas in a hierarchy of nested shapes"
	^ true! !

!RSShape methodsFor: 'border' stamp: ''!
border
	^ border! !

!RSShape methodsFor: '*Roassal3-Inspector' stamp: ''!
gtCanvasForInspector
	| canvas copy |
	canvas := RSCanvas new.
	copy := self copy.
	canvas addShape: copy.
	canvas @ RSChessBackgroundInteraction.
	^ canvas! !

!RSShape methodsFor: 'copying' stamp: ''!
copyWithAnnouncer
	"Answer a copy of this shape that shares the same instance of announcer (The default #postCopy cleans it). 
	This means that interactions and subscription handlers to any RSEvent will be shared between both instances. 
	This is useful for optimizations. Senders should be careful!! 
	
	Example:
		base := RSBox new
		    size: 100;
		    color: Color blue;
		    popup;
		    draggable.
		    
		shapes := (1 to: 20) collect:[:i | 
		    base copyWithEvents
		        model: i;
		        yourself.
		    ].
		c := RSCanvas new.
		RSHorizontalLineLayout on: shapes.
		c addAll: shapes.
		c zoomToFit.
	"

	^ self copy
		announcer: announcer;
		yourself! !

!RSShape methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	paint := Color lightGray.
	isFixed := false.! !

!RSShape methodsFor: 'accessing' stamp: ''!
topParent
	^ parent ifNotNil: [ parent topParent ]! !

!RSShape methodsFor: 'accessing' stamp: ''!
width
	^ self extent x! !

!RSShape methodsFor: 'testing' stamp: ''!
intersects: aRectangle
	"used in drawing operation
	aRectangle is the visible rectangle of the canvas, then this method is used
	to draw or not this shape"
	^ self subclassResponsibility! !

!RSShape methodsFor: 'copying' stamp: ''!
postCopy
	self 
		parent: nil;
		announcer: nil;
		resetPath;
		resetBBox! !

!RSShape methodsFor: 'accessing' stamp: ''!
computeEncompassingRectangle
	self subclassResponsibility! !

!RSShape methodsFor: 'accessing' stamp: ''!
encompassingRectangle: aRectangle
	encompassingRectangle := aRectangle! !

!RSShape methodsFor: 'accessing' stamp: ''!
extent
	^ self encompassingRectangle extent! !

!RSShape methodsFor: 'actions' stamp: ''!
signalUpdate
	"Refresh the canvas"
	parent ifNil: [ ^ self ].
	parent signalUpdate! !

!RSShape methodsFor: 'accessing' stamp: ''!
height
	^ self extent y! !

!RSShape methodsFor: 'accessing' stamp: ''!
encompassingRectangle
	^ encompassingRectangle ifNil: [ 
		encompassingRectangle := self computeEncompassingRectangle ].! !

!RSShape methodsFor: 'accessing' stamp: ''!
paint: aPaint
	"Receive a Color or an Athens paint object"
	paint := aPaint! !

!RSShape methodsFor: 'accessing' stamp: ''!
resetChildren
	! !

!RSShape methodsFor: '*Roassal3-Shapes' stamp: ''!
borderDo: aBlock
	border ifNil: [ border := RSBorder new ].
	aBlock value: border! !

!RSShape methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModels: someObjects result: result
	(someObjects includes: self model) ifTrue: [ result add: self ]! !

!RSShape methodsFor: 'accessing' stamp: ''!
color
	^ paint ! !

!RSShape methodsFor: 'testing' stamp: ''!
includesPoint: aPoint
	"Answer whether this shape includes aPoint."

	^ false! !

!RSShape methodsFor: 'private - adding' stamp: ''!
addPendingAnimationsIn: aShapeOrCanvas
	| key myAnimations parentAnimations |
	key := #todoAnimations.
	(self hasProperty: key) ifFalse: [ ^ self ].
	myAnimations := self propertyAt: key.
	aShapeOrCanvas isShape ifTrue: [ 
		parentAnimations := parent propertyAt: key ifAbsentPut: [ OrderedCollection new ].
		parentAnimations addAll: myAnimations.
	] ifFalse: [ 
		myAnimations do: [:anime| 
			aShapeOrCanvas addAnimation: anime ] ].
	self removeKey: key.! !

!RSShape methodsFor: 'testing' stamp: ''!
isEdge
	^ false! !

!RSShape methodsFor: 'border' stamp: ''!
noBorder
	border := nil! !

!RSShape methodsFor: '*Roassal3-Shapes' stamp: ''!
withBorder
	self border: RSBorder new! !

!RSShape methodsFor: 'testing' stamp: ''!
hasChildren
	^ false! !

!RSShape methodsFor: 'testing' stamp: ''!
hasModel
	"Return true if a model is set in the shape. Return false otherwise"
	^ model notNil! !

!RSShape methodsFor: 'accessing' stamp: ''!
parent: aCanvasOrComposite
	parent := aCanvasOrComposite! !

!RSShape methodsFor: 'accessing' stamp: ''!
computeEncompassingRectangleFor: rect matrix: aMatrix
	| groupOfPoints |
	groupOfPoints := #(topLeft topRight bottomRight bottomLeft)
		collect: [ :s | aMatrix transform: (s value: rect) ].
	^ Rectangle encompassing: groupOfPoints.
	! !

!RSShape methodsFor: 'accessing' stamp: ''!
parent
	^ parent! !

!RSShape methodsFor: 'testing' stamp: ''!
hasBorder
	^ border notNil and: [ border width > 0 ].! !

!RSShape methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	model ifNil: [ ^ self ].
	stream << '('; << model asString; << ')'.! !

!RSShape methodsFor: '*Roassal3-Inspector' stamp: ''!
gtInspectorCanvasIn: composite
	<gtInspectorPresentationOrder: -10>
	composite roassal3
		title: ['Shape'];
		initializeCanvas: [ self gtCanvasForInspector ]! !

!RSShape methodsFor: 'path' stamp: ''!
sessionChanged
	"This method releases all the native graphical resources. This method is typically invoked when starting a Pharo image with a visualization that was previously open"
	self resetPath! !

!RSShape methodsFor: 'accessing - computed' stamp: ''!
shapeWithActionForPosition: position
	^ (self hasEventCallback and: [ self includesPoint: position ] ) 
			ifTrue: [ self ]
			ifFalse: [ nil ]! !

!RSShape methodsFor: '*Roassal3-Interaction' stamp: ''!
popupText: aBlock
	self @ (RSPopup text: aBlock).! !

!RSShape methodsFor: 'testing' stamp: ''!
isFixed 
	^ isFixed! !

!RSShape methodsFor: 'accessing - computed' stamp: ''!
canvas
	"Return the canvas in which I belong to. Can return nil if the shape is not added to a canvas" 
	parent ifNil: [ ^ nil ].
	^ parent isShape 
		ifTrue: [ parent canvas ]
		ifFalse: [ parent ]! !

!RSShape methodsFor: 'private - adding' stamp: ''!
addedIn: aCanvas
	"This is a private method"
	| evt |
	self isFixed
		ifTrue: [ aCanvas addFixedShape: self ]
		ifFalse: [ aCanvas addBasicShape: self ].
	parent ifNotNil: [ self remove ].
	parent := aCanvas.
	self addPendingAnimationsIn: parent.
	
	evt := RSShapeAddedEvent new shape: self.
	aCanvas announce: evt.
	self announce: evt.
! !

!RSShape methodsFor: 'adding' stamp: ''!
addRecursivelyIn: aCollection
	aCollection add: self! !

!RSShape methodsFor: 'border' stamp: ''!
borderColor
	^ self border color! !

!RSShape methodsFor: 'accessing - attributes' stamp: ''!
index
	^ self propertyAt: #index! !

!RSShape methodsFor: 'actions' stamp: ''!
pushFront
	parent pushFront: self.! !

!RSShape methodsFor: '*Roassal3-Shapes' stamp: ''!
asMarker
	^ RSMarker new shape: self! !

!RSShape methodsFor: 'path' stamp: ''!
resetPath
	path := nil! !

!RSShape methodsFor: '*Roassal3-UML' stamp: ''!
browseable
	self when: RSMouseClick do: [ self model browse  ].! !

!RSShape methodsFor: '*Roassal3-Interaction' stamp: ''!
popup
	self @ RSPopup.! !

!RSShape methodsFor: 'border' stamp: ''!
border: aBorder
	border := aBorder! !

!RSShape methodsFor: 'announcer' stamp: ''!
announcementClasses
	^ RSShapeEvent withAllSubclasses 
		reject: [ :subcls| subcls hasSubclasses ]! !

!RSShape methodsFor: 'accessing' stamp: ''!
shape
	^ self! !

!RSShape methodsFor: '*Roassal3-Interaction' stamp: ''!
draggable
	self @ RSDraggable.! !

!RSShape methodsFor: 'accessing' stamp: ''!
paintOn: visitor
	^ visitor paintFor: self form: self paint! !

!RSShape methodsFor: 'accessing' stamp: ''!
isFixed: aBool
	isFixed := aBool! !

!RSShape methodsFor: 'actions' stamp: ''!
remove
	"Do nothing if the line is not already in a canvas"
	self isInACanvas ifFalse: [ ^ self ].
	parent removeShape: self
	! !

!RSShape methodsFor: 'testing' stamp: ''!
hasEventCallback
	"Return true if at least one event callback has been added to the shape"
	^ announcer notNil and: [ announcer numberOfSubscriptions > 0 ]! !

!RSShape methodsFor: 'testing' stamp: ''!
isNode
	^ false! !

!RSShape methodsFor: 'accessing - attributes' stamp: ''!
model: anObject
	"Set the model of the shape. A shape represents a visual description of the model object. In case no model is specified, the value is nil. A model is used when using interaction (e.g., popup, labeled) and normalizations."
	model := anObject! !

!RSShape methodsFor: 'accessing - attributes' stamp: ''!
depth: anObject
	"depth is used by tree builders usefull to relationate hierarchy visualizations"
	self propertyAt: #depth put: anObject! !

!RSShape methodsFor: 'actions' stamp: ''!
pushBack
	"Move the element behind. This method can be called only if the shape is in a canvas"
	self assert: [ parent notNil ] description: 'Should add the shape in a canvas first'.
	parent pushBack: self.! !

!RSShape methodsFor: 'adding' stamp: ''!
renderOn: aCanvas
	self subclassResponsibility! !

!RSShape methodsFor: 'initialization' stamp: ''!
resetBBox
	encompassingRectangle := nil.! !

!RSShape methodsFor: 'adding' stamp: ''!
accept: aVisitor
	self subclassResponsibility ! !

!RSShape methodsFor: '*Roassal3-Inspector' stamp: ''!
inspectorShape
	<inspectorPresentationOrder: 90 title: 'Shape'>

	^ SpRoassal3InspectorPresenter new
		canvas: self gtCanvasForInspector;
		yourself! !

!RSShape methodsFor: 'looking up shapes' stamp: ''!
deepShapeFromModel: anObject result: result
	self model = anObject ifTrue: [ result add: self ]! !

!RSShape class methodsFor: 'accessing' stamp: ''!
models: someObjects
	"Create a RSGroup made of shapes. Each shape has an element of the argument as model."
	^ someObjects collect: [ :obj | self model: obj ] as: RSGroup.
! !

!RSShape class methodsFor: 'accessing' stamp: ''!
models: someObjects forEach: twoArgBlock
	"Create a RSGroup made of shapes. Each shape has an element of the argument as model. The second argument is used to initialize the shape.
	
	For example:
```
c := RSCanvas new.

classes := RSCircle models: Collection withAllSubclasses forEach: [ :aShape :aClass | aShape size: aClass numberOfMethods ].

c addAll: classes.
RSFlowLayout on: classes.
c @ RSCanvasController
```
	"

	| r |
	r := someObjects collect: [ :obj | self model: obj ] as: RSGroup.
	r with: someObjects do: [ :aShape :anObject | twoArgBlock value: aShape value: anObject ].
	^ r
! !

!RSShape class methodsFor: 'accessing' stamp: ''!
model: anObject
	"Create an instance of myself with anObject as model"
	^ self new model: anObject! !

!RSShape class methodsFor: 'accessing' stamp: ''!
model: anObject forIt: aTwoArgBlock
	"Create an instance of myself with anObject as model. The second argument is a one arg block that is used to initialize the shape"
	| r |
	r := self new.
	r model: anObject.
	aTwoArgBlock value: r value: anObject.
	^ r! !

!RSShapeAddedEvent commentStamp: ''!
When the canvas add a shape!
!RSShapeEvent commentStamp: ''!
TSShapeEvent represent all events with shapes and the canvas!
!RSShapeEvent methodsFor: 'accessing' stamp: ''!
position 
	^ position ifNil: [ self shape position ]! !

!RSShapeEvent methodsFor: 'accessing' stamp: ''!
positionFromCamera
	"Return the position from the camera. I.e., 0 @ 0 is at the center of the window if the camera has not been translated"
	^ canvas 
		ifNotNil: [ canvas camera fromPixelToSpace: self position ]
		ifNil: [ -250 @ -250 ]
! !

!RSShapeEvent methodsFor: 'accessing' stamp: ''!
position: aPoint
	position := aPoint ! !

!RSShapeFactory commentStamp: ''!
I can create shapes in order that the client can modify it!
!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
star
	| star5Points outerPoints innerPoints innerRadius ar |
	star5Points := Array new: 10.
	outerPoints := RSPolygon generateUnitNgonPoints: 5 rotation: 0.
	innerPoints := RSPolygon generateUnitNgonPoints: 5 rotation: Float pi / -5.
	"Outer radius is 1; inner radius of star is smaller"
	innerRadius := 0.5.
	innerPoints
		doWithIndex: [ :p :i | innerPoints at: i put: (p x * innerRadius) @ (p y * innerRadius) ].
	star5Points
		doWithIndex: [ :p :i | 
			ar := i even
				ifTrue: [ outerPoints ]
				ifFalse: [ innerPoints ].
			star5Points at: i put: (ar at: i // 2 + (i % 2)) ].
	star5Points := RSPolygon fitPolygonToSquare: star5Points.
	^ self polygonWithPoints: star5Points! !

!RSShapeFactory class methodsFor: 'lines' stamp: ''!
arrowedLine
	^ RSArrowedLine new! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
square
	^ self polygonWithPoints: (RSPolygon generatePointsFitSquare: 4)! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
circle
	^ self ellipse! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
vee
	^ self polygonWithPoints: (Array
		with: -1 @ -1
		with: 0 @ -0.333
		with: 1 @ -1
		with: 0 @ 1)! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
rectangle
	^ RSBox new! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
pentagon
	^ self polygonWithPoints: (RSPolygon generatePointsFitSquare: 5)! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
heptagon
	^ self polygonWithPoints: (RSPolygon generatePointsFitSquare: 7)! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
hexagon
	^ self polygonWithPoints: (RSPolygon generatePointsFitSquare: 6)! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
plus
	| t t1 |
	t := 2 / 6 asFloat.
	t1 := t negated.
	^ self polygonWithPoints:
		{(-1 @ t1).
		(t1 @ t1).
		(t1 @ -1).
		(t @ -1).
		(t @ t1).
		(1 @ t1).
		(1 @ t).
		(t @ t).
		(t @ 1).
		(t1@ 1).
		(t1@ t).
		(-1@ t)}! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
label
	^ RSLabel new! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
diamond
	^ self polygonWithPoints: (Array
		with: 0 @ 1
		with: 1 @ 0
		with: 0 @ -1
		with: -1 @ 0)! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
arrow
	"inverted vee"
	^ self polygonWithPoints: (Array
		with: 1 @ 1
		with: 0 @ 0.333
		with: -1 @ 1
		with: 0 @ -1)! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
ellipse
	^ RSEllipse new! !

!RSShapeFactory class methodsFor: 'utilities' stamp: ''!
polygonWithPoints: points
	^ self polygon
		privatePoints: points;
		yourself! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
bitmap
	^ RSBitmap new! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
arc
	^ RSPieSlice new! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
rhomboid
	^ self polygonWithPoints: (Array
		with: -1 @ -1
		with: 0.333 @ -1
		with: 1 @ 1
		with: -0.333 @ 1)! !

!RSShapeFactory class methodsFor: 'lines' stamp: ''!
arrowedLineWithOffset: aFloat
	"[0 1] value"
	| inst |
	inst := self arrowedLine.
	inst shape markerEnd offsetRatio: aFloat.
	^ inst! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
composite 
	^ RSComposite new! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
triangle
	^ self polygonWithPoints: (RSPolygon generatePointsFitSquare: 3)! !

!RSShapeFactory class methodsFor: 'utilities' stamp: ''!
shapeFromString: aString
	"self shapeFromString: 'd'"
	#(o circle
	^ arrow
	s square
	p pentagon
	h hexagon
	+ plus
	d diamond
	* star ) pairsDo: [ :k :sel |
		(aString includesSubstring: k)
			ifTrue: [ ^ sel value: self ] ].
	^ nil
	! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
box
	^ self rectangle! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
polygon
	^ RSPolygon new! !

!RSShapeFactory class methodsFor: 'shapes' stamp: ''!
octagon
	^ self polygonWithPoints: (RSPolygon generatePointsFitSquare: 8)! !

!RSShapeRemovedEvent commentStamp: ''!
When a canvas removes a shape!
!RSShapeTest methodsFor: 'tests' stamp: ''!
testModels

	| shapes |
	shapes := RSCircle models: (1 to: 10).
	self assert: shapes isCollection.
	self assert: shapes class equals: RSGroup.
	self assert: (shapes allSatisfy: [ :s | s class == RSCircle ]).
	self assert: (shapes collect: #width) asSet asArray equals: #(10)! !

!RSShapeTest methodsFor: 'tests' stamp: ''!
testTranslateMiddleRightTo

	| c center lbl |
	c := RSCanvas new.

	center := RSEllipse new size: 2; color: Color red.
	c add: center.
	center translateTo: 0 @ 0.

	lbl := RSLabel text: 'Middle right corner'.
	c add: lbl.
	lbl translateMiddleRightTo: 0 @ 0.
	
	self assert: (lbl position x < 0).
	self assert: (lbl position y = 0).
	! !

!RSShapeTest methodsFor: 'tests' stamp: ''!
testModelsSize

	| shapes |
	shapes := RSCircle models: (1 to: 10) size: #yourself.
	self assert: shapes isCollection.
	self assert: shapes class equals: RSGroup.
	self assert: (shapes allSatisfy: [ :s | s class == RSCircle ]).
	self assert: (shapes collect: #width) asArray equals: (1 to: 10) asArray.
	self assert: (shapes collect: #height) asArray equals: (1 to: 10) asArray! !

!RSShapeTest methodsFor: 'tests' stamp: ''!
testIncomingAndOutgoingShapes

	| c shapes lb node1 node5 |
	c := RSCanvas new.
	shapes := RSBox models: (1 to: 10).
	c addAll: shapes.
	lb := RSLineBuilder line.
	lb canvas: c.
	lb connectFrom: [ :nb | nb // 2 ].
	
	node1 := c shapeFromModel: 1.
	self assert: node1 model equals: 1.
	
	self assert: node1 outgoingLines size equals: 2.
	self assert: node1 outgoingShapes size equals: 2.
	self assert: node1 outgoingShapes equals: (c shapesFromModels: #(2 3)).
	
	self assert: node1 incomingLines isEmpty.
	self assert: node1 incomingShapes isEmpty.
	
	node5 := c shapeFromModel: 5.
	self assert: node5 incomingShapes equals: (c shapesFromModels: #(2)).
	self assert: node5 outgoingShapes equals: (c shapesFromModels: #(10 11)).
	
	! !

!RSShapeTest methodsFor: 'tests' stamp: ''!
testAllConnectedShapes
	| c shapes lb node1 node2 node3 node5 node6 |
	c := RSCanvas new.


	shapes := RSLabel models: (1 to: 6).
	c addAll: shapes.
	shapes @ RSDraggable.
	lb := RSLineBuilder arrowedLine.
	lb withBorderAttachPoint.
	lb shapes: shapes.
	lb useAssociations: { 1 -> 3 . 3 -> 2 . 3 -> 4 . 5 -> 6. }.
	RSForceBasedLayout on: shapes.
	c @ RSCanvasController.
	
	node1 := c shapeFromModel: 1.
	node2 := c shapeFromModel: 2.
	node3 := c shapeFromModel: 3.
	node5 := c shapeFromModel: 5.
	node6 := c shapeFromModel: 6.
	
	self assert: (node1 allRecursiveConnectedShapes collect: #model) asSortedCollection asArray equals: (1 to: 4).
	
	self assert: node1 allRecursiveConnectedShapes equals: node2 allRecursiveConnectedShapes.
	self assert: node1 allRecursiveConnectedShapes equals: node3 allRecursiveConnectedShapes.
	self assert: node2 allRecursiveConnectedShapes equals: node3 allRecursiveConnectedShapes.

	self assert: node1 allRecursiveConnectedShapes ~= node5 allRecursiveConnectedShapes.
	
	self assert: node5 allRecursiveConnectedShapes equals: node6 allRecursiveConnectedShapes.
! !

!RSShapeTest methodsFor: 'tests' stamp: ''!
testHasModel

	self deny: RSCircle new hasModel.
	self assert: (RSShape new model: 52) hasModel.
	self assert: (RSLine new model: 52) hasModel.
	self deny: RSLine new hasModel.! !

!RSShapeTest methodsFor: 'tests' stamp: ''!
testModelForIt

	| s |
	s := RSBox model: 42 forIt: [ :ss :object | ss color: Color pink ].
	self assert: s class equals: RSBox.
	self assert: s model equals: 42.
	self assert: s color equals: Color pink! !

!RSShowProgressLabelDecorator commentStamp: ''!
I put interactions on the shapes and a label for updating!
!RSShowProgressLabelDecorator methodsFor: 'accessing' stamp: ''!
labelShape
	^ labelShape! !

!RSShowProgressLabelDecorator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	labelShape := RSLabel new.
	highlight := RSHighlightable new.
	highlight 
		highlightColor: [ :shape | shape color adjustBrightness: 0.08 ]; 
		when: RSHighlightEvent do: [ :evt | self updateLabel: evt shape ];
		when: RSUnHighlightEvent do: [ :evt | self updateLabel: nil ].
	! !

!RSShowProgressLabelDecorator methodsFor: 'accessing' stamp: ''!
progressLabel
	^ progressLabel! !

!RSShowProgressLabelDecorator methodsFor: 'rendering' stamp: ''!
render
	| canvas |
	progressLabel := self labelShape copy.
	progressLabel text: ''.
	canvas := builder container.
	canvas add: progressLabel.
	builder shapes @ highlight.
	! !

!RSShowProgressLabelDecorator methodsFor: 'updating' stamp: ''!
progressFor: aShape
	^ ((builder values at: aShape index) * 100 / builder totalSum) rounded! !

!RSShowProgressLabelDecorator methodsFor: 'updating' stamp: ''!
updateLabel: aShape
	aShape ifNil: [ ^ progressLabel text: '' ].
	progressLabel
		color: aShape color;
		text: (self progressFor: aShape) asString, '%'! !

!RSSimpleCanvasMonitorInteraction commentStamp: ''!
I am a simple monitor!
!RSSimpleCanvasMonitorInteraction methodsFor: 'initialization' stamp: ''!
initializeShape
	shape := RSLabel new
		color: Color green;
		yourself! !

!RSSimpleCanvasMonitorInteraction methodsFor: 'update' stamp: ''!
updateShape
	shape text: self lastFramePerSecond asString, 'fps'! !

!RSSimpleChartPopupBuilder commentStamp: ''!
I am a simple chart popup builder. I create a row for each line bar plot.
Then I apply a vertical line layout to each row.

Users can create a subclass and override `rowShapefor:`

This class is a simple demo of how to create a basic popup for a RSChart with lines plots.

It could be different, in that case feel free extend classes like `RSPopupDecoration`
or `RSMarkerPopupChart`

```Smalltalk
| x cumsum c  y error popup |
x := 1 to: 100.
cumsum := [:arr | | sum |
	sum := 0.
	arr collect: [ :v | sum := sum + v. sum ] ].

c := RSChart new.
c extent: 800@400.

popup := RSPopupDecoration new.
c addDecoration: popup.

#(
series1 red
series2 blue) pairsDo: [ :label :color |
	| col plot |
	y := (x collect: [ :i | 50 atRandom - 25 ]).
	y := cumsum value: y.
	error := x.
	col := color value: Color.
	
	c addPlot: (RSAreaPlot new 
		x: x y1: y + error y2: y - error;
		color: col translucent).
	c addPlot: (plot := RSLinePlot new x: x y: y; fmt: 'o';
		color: col;
		yourself).
	popup chartPopupBuilder
		for: plot text: label color: col.
	 ].

c build.

^ c canvas.
```!
!RSSimpleChartPopupBuilder methodsFor: 'public' stamp: ''!
for: aRSLinePlot color: aColor
	self for: aRSLinePlot icon: (RSEllipse new 
		size: 10; 
		color: aColor;
		yourself)! !

!RSSimpleChartPopupBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	labels := Dictionary new.
	icons := Dictionary new.! !

!RSSimpleChartPopupBuilder methodsFor: 'hooks' stamp: ''!
rowShapeFor: aRSLinePlot point: aPoint
	| group |
	group := RSGroup new.
	
	icons at: aRSLinePlot ifPresent: [ :icon |
		group add: icon copy ].
	labels at: aRSLinePlot ifPresent: [ :label |
		group add: (RSLabel new text: label) ].
	group add: (RSLabel new text: aPoint y).
	RSHorizontalLineLayout new gapSize: 5; alignMiddle; on: group.
	^ group asShape! !

!RSSimpleChartPopupBuilder methodsFor: 'public' stamp: ''!
for: aRSLinePlot text: aString
	labels at: aRSLinePlot put: aString! !

!RSSimpleChartPopupBuilder methodsFor: 'public' stamp: ''!
for: aRSLinePlot text: aString color: aColor
	self 
		for: aRSLinePlot text: aString;
		for: aRSLinePlot color: aColor.! !

!RSSimpleChartPopupBuilder methodsFor: 'public' stamp: ''!
for: aRSLinePlot icon: aRSShape
	icons at: aRSLinePlot put: aRSShape! !

!RSSimpleForceBasedLayout methodsFor: 'hook' stamp: ''!
doExecute: shapes
	| layout es |
	shapes do: [ :n | n updateLinesOFF ].
	layout := RSForceBasedLayout new.
	layout nodes: shapes.
	es := shapes flatCollect: #outgoingLines.
	layout edges: es.
	layout start.
	shapes do: [ :node | (layout mockElementAt: node)
		charge: node width * -10;
		weight: node width ].
	es do: [ :edge | (layout mockLineAt: edge)
		strength: 1;
		length: (edge from width + edge to width) ].
	layout runLayoutSimply.
	shapes do: [ :n | n updateLinesON. n connectedLines do: #update ].! !

!RSSimpleMarkerPopupBuilder commentStamp: ''!
I create markers in the visualization!
!RSSimpleMarkerPopupBuilder methodsFor: 'hooks' stamp: ''!
shapeFor: aRSChart
	| line box |
	line := RSLine new dashArray: #(3).
	box := aRSChart decorations first shape encompassingRectangle.
	line 
		startPoint: position x@ box top;
		endPoint: position x@ box bottom .
	^ line
	! !

!RSSimplePopupBuilder commentStamp: ''!
I create a popup from an object!
!RSSimplePopupBuilder methodsFor: 'initialization' stamp: ''!
labelBuilder
	^ labelBuilder! !

!RSSimplePopupBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self labelBuilder: RSMultilineLabelBuilder new.! !

!RSSimplePopupBuilder methodsFor: 'hooks' stamp: ''!
textBlock: aBlock
	labelBuilder textBlock: aBlock! !

!RSSimplePopupBuilder methodsFor: 'hooks' stamp: ''!
shapeFor: anObject
	| lbl box |
	lbl := self labelFor: anObject.
	box := self boxFor: lbl.
	^ RSComposite new
		shapes: {box. lbl};
		yourself! !

!RSSimplePopupBuilder methodsFor: 'hooks' stamp: ''!
boxFor: lbl
	^ RSBox new
		color: (Color colorFrom: 'efefef');
		cornerRadius: 5;
		border: (RSBorder new color: Color gray);
		extent: lbl extent + (10@7);
		yourself! !

!RSSimplePopupBuilder methodsFor: 'initialization' stamp: ''!
labelBuilder: aLabelBuilder
	labelBuilder := aLabelBuilder! !

!RSSimplePopupBuilder methodsFor: 'hooks' stamp: ''!
labelFor: anObject
	^ labelBuilder shapeFor: anObject! !

!RSSinInterpolator commentStamp: ''!
TSEasing sinIn
Sinusoidal easing; returns sin(t).

TSEasing sinOut
Reverse sinusoidal easing; equivalent to 1 - sinIn(1 - t).

TSEasing sin 
TSEasing sinInOut
Symmetric sinusoidal easing; scales sinIn for t in [0, 0.5] and sinOut for t in [0.5, 1].!
!RSSinInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateIn: t
	^ 1 - (t * Float halfPi) cos! !

!RSSinInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateInOut: t
	^ (1 - (Float pi * t) cos ) / 2.! !

!RSSinInterpolator methodsFor: 'interpolation' stamp: ''!
interpolateOut: t
	^ (t * Float halfPi) sin! !

!RSSortBlock commentStamp: ''!
TODO!
!RSSortBlock methodsFor: 'accessing' stamp: ''!
value: assocA value: assocB
	"Return false if assocA is bigger than assocB.
	Return true if assocA is smaller than assocB.
	-> Inverted list with biggest elements first"
	
	| a b offset |
	offset := 0.
	a := assocA value.
	b := assocB value.
	[(a size > offset)
		and: [(b size > offset) and: [(a at: a size - offset) = (b at: b size - offset)]]]
		whileTrue: [offset := offset + 1].	"Corner cases"
	(a size = b size and: [b size = offset]) ifTrue: [ ^ true ].	"[3, 3], [3, 3]"
	(a size > offset and: [b size = offset]) ifTrue: [ ^ true ].	"[3, 3, 6], [3, 3]"
	(b size > offset and: [a size = offset]) ifTrue: [ ^ false ].	"[3, 3], [3, 3, 6]"	"Normal case"
	^(a at: a size - offset) >= (b at: b size - offset)! !

!RSSortBlock methodsFor: 'accessing' stamp: ''!
fixTemps! !

!RSStartEndAttachPoint methodsFor: 'accessing' stamp: ''!
startAttachPoint: anObject

	startAttachPoint := anObject! !

!RSStartEndAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicEndingPointOf: anEdge

	^ endAttachPoint basicEndingPointOf: anEdge! !

!RSStartEndAttachPoint methodsFor: 'accessing' stamp: ''!
endAttachPoint

	^ endAttachPoint! !

!RSStartEndAttachPoint methodsFor: 'accessing' stamp: ''!
startAttachPoint

	^ startAttachPoint! !

!RSStartEndAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicStartingPointOf: anEdge

	^ startAttachPoint basicStartingPointOf: anEdge! !

!RSStartEndAttachPoint methodsFor: 'accessing' stamp: ''!
endAttachPoint: anObject

	endAttachPoint := anObject! !

!RSStartEndCPAPController methodsFor: 'hooks' stamp: ''!
controlPointsFrom: fromPoint to: toPoint

	^ controller controlPointsFrom: fromPoint to: toPoint! !

!RSStartEndCPAPController methodsFor: 'accessing' stamp: ''!
startAttachPoint: anAttachPoint

	startAttachPoint := anAttachPoint! !

!RSStartEndCPAPController methodsFor: 'hooks' stamp: ''!
controlPointsFor: anEdge

	| ap sp ep |
	ap := anEdge attachPoint.
	sp := startAttachPoint ifNil: [ ap ].
	ep := endAttachPoint ifNil: [ ap ].
	^ self
		  controlPointsFrom: (sp startingPointOf: anEdge)
		  to: (ep endingPointOf: anEdge)! !

!RSStartEndCPAPController methodsFor: 'accessing' stamp: ''!
controller: aCPAPController

	controller := aCPAPController! !

!RSStartEndCPAPController methodsFor: 'accessing' stamp: ''!
endAttachPoint: anAttachPoint

	endAttachPoint := anAttachPoint! !

!RSStrokeStyle commentStamp: ''!
I represent different styles for the stroke!
!RSStrokeStyle methodsFor: 'accessing' stamp: ''!
dashArray
	^ dashArray! !

!RSStrokeStyle methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	dashOffset := 0! !

!RSStrokeStyle methodsFor: 'accessing' stamp: ''!
capStyle
	^ capStyle! !

!RSStrokeStyle methodsFor: 'accessing' stamp: ''!
dashOffset: aNumber
	dashOffset := aNumber! !

!RSStrokeStyle methodsFor: 'accessing' stamp: ''!
capStyle: symbol
	capStyle := symbol! !

!RSStrokeStyle methodsFor: 'accessing' stamp: ''!
dashOffset
	^ dashOffset! !

!RSStrokeStyle methodsFor: 'accessing' stamp: ''!
joinStyle: symbol
	joinStyle := symbol! !

!RSStrokeStyle methodsFor: 'accessing' stamp: ''!
joinStyle
	^ joinStyle! !

!RSStrokeStyle methodsFor: 'accessing' stamp: ''!
dashArray: array
	self assert: array isArray description: 'enter an array of numbers'.
	dashArray := array! !

!RSStrokeStyle class methodsFor: 'instance creation' stamp: ''!
fromString: aString 
	| inst |
	inst := self new.
	(aString includesSubstring: '--')
		ifTrue: [ ^ inst dashArray: #(4 2) ].
	(aString includesSubstring: '-.')
		ifTrue: [ ^ inst dashArray: #(4 1 1 1) ].
	(aString includesSubstring: '.')
		ifTrue: [ ^ inst dashArray: #(1) ].
	
	^ nil! !

!RSSturgesBinning commentStamp: ''!
TODO!
!RSSturgesBinning methodsFor: 'hooks' stamp: ''!
computeSizeFor: values
	^ (values size log / 2 log) ceiling + 1! !

!RSSugiyamaLayout commentStamp: ''!
TODO!
!RSSugiyamaLayout methodsFor: 'private' stamp: ''!
assignLabels: aNodeCollection 
	"Initialize label dictionary"
	| label vertices parentLabels |
	labels := IdentityDictionary new.
	label := 1.	"Assign labels to the roots"
	(self rootNodesFor: aNodeCollection) do: 
		[ :node | 
		labels 
			at: node
			put: label.
		label := label + 1 ].	"Assign labels to the rest"
	[ labels keys size < aNodeCollection size ] whileTrue: 
		[ vertices := SortedCollection sortBlock: self sortBlock.
		aNodeCollection do: 
			[ :node | 
			(labels includesKey: node) ifFalse: 
				[ parentLabels := ((self parentsFor: node) collect: 
					[ :pn | 
					labels 
						at: pn
						ifAbsent: [ self maxFloat ] ]) asSortedCollection.
				parentLabels last ~= self maxFloat ifTrue: [ vertices add: node -> parentLabels ] ] ].
		labels 
			at: vertices first key
			put: label.
		label := label + 1 ]! !

!RSSugiyamaLayout methodsFor: 'hook' stamp: ''!
doExecute: aNodeCollection 
	"Coffman-Graham-Layering. Di Battista Book, page 275, chapter, 9.2.1"
	self assignLabels: aNodeCollection.
	self buildLayers: aNodeCollection copy.
	self addDummyNodes.
	self reduceCrossing.
	self layoutAt: self verticalGap @ self horizontalGap! !

!RSSugiyamaLayout methodsFor: 'private' stamp: ''!
buildLayers: g
	| w layerNr u vertices vertex layer done |
	w := self maxFloat.
	u := OrderedCollection new.
	layers := IdentityDictionary new.
	layerNrs := IdentityDictionary new.	"Assign all nodes to layers"
	[g isEmpty]
		whileFalse:
			[vertices := g
				select:
					[:e | (self childrenFor: e) allSatisfy: [:node | u includes: node]].
			vertex := vertices detectMax: [:e | labels at: e].
			done := false.
			layerNr := 1.
			[done]
				whileFalse:
					[layer := layers
						at: layerNr
						ifAbsentPut: [OrderedCollection new].
					(layer size >= w
						or:
							[(self childrenFor: vertex) anySatisfy: [:n | (layerNrs at: n) >= layerNr]])
						ifTrue: [layerNr := layerNr + 1]
						ifFalse: [done := true]].
			layer add: vertex.
			layerNrs at: vertex put: layerNr.
			u add: vertex.
			g remove: vertex]! !

!RSSugiyamaLayout methodsFor: 'private' stamp: ''!
maxFloat
	^ 1e10! !

!RSSugiyamaLayout methodsFor: 'private' stamp: ''!
cl: layer u: u v: v
	"Calculates cuv. Di Battista, chapter 9.2.2, page 283"
	| partnersOfU partnersOfV c partnersOfUIndex partnersOfVIndex layerNr |
	layerNr := layerNrs at: u.	":= layerNrs at: v"
	partnersOfU := (connections at: u)
		select: [:each | (layerNrs at: each) = (layerNr - 1)].
	partnersOfV := (connections at: v)
		select: [:each | (layerNrs at: each) = (layerNr - 1)].
	c := 0.
	partnersOfUIndex := partnersOfU collect: [:node | layer indexOf: node].
	partnersOfVIndex := partnersOfV collect: [:node | layer indexOf: node].
	partnersOfUIndex
		do:
			[:uIndex | partnersOfVIndex do: [:vIndex | vIndex < uIndex ifTrue: [c := c + 1]]].
	^c! !

!RSSugiyamaLayout methodsFor: 'private' stamp: ''!
layoutAt: aPoint
	| treeWidth layerKeys layer layerWidth horizontalPosition verticalPosition layerHeight |
	treeWidth := layers values
		inject: self maxFloat negated
		into:
			[:max :e | max max: (e sumNumbers: #width) + ((e size - 1) * self horizontalGap)].
	verticalPosition := self horizontalGap.	"For visual reasons NOT: self class verticalGap"
	layerKeys := layers keys asSortedCollection reverse.
	layerKeys
		do:
			[:aKey | 
			layer := layers at: aKey.
			layerWidth := (layer sum: #width)
				+ ((layer size - 1) * self horizontalGap).
			layerHeight := (layer detectMax: #height) height.
			horizontalPosition := treeWidth / 2.0 + aPoint x - (layerWidth / 2.0).
			layer
				do:
					[:node | 
					translator translateTopLeftOf: node to:  horizontalPosition @ verticalPosition.
					
					horizontalPosition := horizontalPosition + node width
						+ self horizontalGap ].
			verticalPosition := verticalPosition + layerHeight + self verticalGap ]! !

!RSSugiyamaLayout methodsFor: 'private' stamp: ''!
addDummyNodes
	| layer layerNr |
	connections := RSIdentityMatrix new.
	self edgesDo:
			[:edge | 
			| a b span fromNode toNode |
			"edge hints removeAll."
			a := layerNrs at: edge from.
			b := layerNrs at: edge to.
			span := (a - b) abs.
			span = 1
				ifTrue:
					[connections
						at: edge from
						at: edge to
						put: true].	"Normal case where nodes are in adjacent layers"
			fromNode := edge from.
			[span > 1]
				whileTrue:
					[span := span - 1.
					layerNr := b + span.
					layer := layers at: layerNr.
					toNode := RSDummyNode
						on: edge
						slot: a - span.
					layer add: toNode.
					layerNrs at: toNode put: layerNr.
					connections at: fromNode at: toNode put: true.
					fromNode := toNode].
			(a - b) abs > 1
				ifTrue:
					[connections
						at: fromNode
						at: edge to
						put: true]]! !

!RSSugiyamaLayout methodsFor: 'private' stamp: ''!
sortBlock
	sortBlock isNil ifTrue: [ sortBlock := self class sortBlock ].
	^sortBlock! !

!RSSugiyamaLayout methodsFor: 'private' stamp: ''!
reduceCrossing
	"Crossing reduction"
	| layer2 u v c1 c2 layer1 done |
	2
		to: layers keys size
		do:
			[:index | 
			layer1 := layers at: index - 1.
			layer2 := layers at: index.
			done := false.
			[done]
				whileFalse:
					[done := true.
					2
						to: layer2 size
						do:
							[:i | 
							u := layer2 at: i - 1.
							v := layer2 at: i.
							c1 := self cl: layer1 u: u v: v.
							c2 := self cl: layer1 u: v v: u.
							c1 > c2
								ifTrue:
									[layer2 rsSwapElement: u withElement: v.
									done := false]]]]! !

!RSSugiyamaLayout class methodsFor: 'utilities' stamp: ''!
sortBlock
	
	^ RSSortBlock new! !

!RSSunburstAttachPoint commentStamp: ''!
I am an attach point to build edges!
!RSSunburstAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicEndingPointOf: anEdge
	^ anEdge to centroid: 0! !

!RSSunburstAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicStartingPointOf: anEdge
	^ anEdge from centroid: 0! !

!RSSunburstBuilder commentStamp: ''!
I am a class to create visualizations about rings, center is the root of the tree and arcs are the sub trees.

You can customize the angle of the arc, and play with the with radius and width of each arc.
!
!RSSunburstBuilder methodsFor: 'public - shape' stamp: ''!
color: aBlock
	"an object"
	color := aBlock! !

!RSSunburstBuilder methodsFor: 'accessing' stamp: ''!
maxLevel
	^ maxLevel! !

!RSSunburstBuilder methodsFor: 'accessing' stamp: ''!
strategy
	^ strategy! !

!RSSunburstBuilder methodsFor: 'strategy' stamp: ''!
extentStrategy
	self strategy: RSSunburstExtentLayout new.
	^ strategy! !

!RSSunburstBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize. 
	self extentStrategy extent: 500@500.
	self leafWeight: 1.
	self sliceColor: NSScale category20c.
	sliceShape := RSPieSlice new.
	maxLevel := 0.! !

!RSSunburstBuilder methodsFor: 'public - building' stamp: ''!
from: objects using: ablock
	| r |
	r := super from: objects using: ablock.
	r do: [ :e | e propertyAt: #parent put: nil].
	^ r! !

!RSSunburstBuilder methodsFor: 'public - building' stamp: ''!
from: objects nesting: block1 leaves: block2
	| r |
	r := super from: objects nesting: block1 leaves: block2.
	r do: [ :e | e propertyAt: #parent put: nil].
	^ r! !

!RSSunburstBuilder methodsFor: 'hooks' stamp: ''!
renderIn: aCanvas
	super renderIn: aCanvas.
	self strategy on: self rootNodes! !

!RSSunburstBuilder methodsFor: 'hooks' stamp: ''!
shapeFor: anObject
	| slice |
	slice := self sliceShape copy
		model: anObject;
		popup;
		draggable;
		yourself.
	slice color: (color rsValue: slice).
	^ slice ! !

!RSSunburstBuilder methodsFor: 'strategy' stamp: ''!
constantWidthStrategy
	self strategy: RSSunburstConstantWidthLayout new.
	^ strategy! !

!RSSunburstBuilder methodsFor: 'accessing' stamp: ''!
sliceShape
	^ sliceShape! !

!RSSunburstBuilder methodsFor: 'public - shape' stamp: ''!
sliceColor: aBlock
	"an object"
	color := aBlock! !

!RSSunburstBuilder methodsFor: 'accessing' stamp: ''!
strategy: anStrategy
	strategy := anStrategy.
	strategy builder: self! !

!RSSunburstCPController commentStamp: ''!
I am prepared to sunburst arcs!
!RSSunburstCPController methodsFor: 'hooks' stamp: ''!
controlPointsFor: anEdge
	| cp1 cp2 cp3 cp4 from to width1 width2 |
	from := anEdge from.
	to := anEdge to.
	width1 := (from externalRadius - from innerRadius)/2.
	from innerRadius isZero ifTrue: [ width1 := 0 ].
	cp1 := from centroid: width1 negated.
	cp2 := from centroid: width1.
	
	width2 := (to externalRadius - to innerRadius)/2.
	cp3 := to centroid: (width1 * 2 + width2) negated.
	cp4 := to centroid: width2 negated.
	^ Array
		with: cp1
		with: cp2
		with: cp3
		with: cp4! !

!RSSunburstConstantWidthLayout commentStamp: ''!
I am a layout for sunburst visualization,

I put the arcs in a constant delta separation, you can define the center width.!
!RSSunburstConstantWidthLayout methodsFor: 'hook' stamp: ''!
setNormalRadius: shape
	| r1 r2 off depth |
	depth := shape propertyAt: #depth.
	off := self radialSpacing * (depth-1).
	r1 := ((depth - 2) * arcWidth) + off.
	r2 := ((depth -1 )* arcWidth ) + off.
	shape
		innerRadius: r1 + self centerWidth;
		externalRadius: r2 + self centerWidth.! !

!RSSunburstConstantWidthLayout methodsFor: 'accessing' stamp: ''!
arcWidth
	^ arcWidth! !

!RSSunburstConstantWidthLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self arcWidth: 50.
	self centerWidth: 50.! !

!RSSunburstConstantWidthLayout methodsFor: 'hook' stamp: ''!
setCenterRadius: shape
	shape externalRadius: self centerWidth.
	! !

!RSSunburstConstantWidthLayout methodsFor: 'accessing' stamp: ''!
arcWidth: aNumber
	arcWidth := aNumber! !

!RSSunburstConstantWidthLayout methodsFor: 'accessing' stamp: ''!
centerWidth
	^ centerWidth! !

!RSSunburstConstantWidthLayout methodsFor: 'accessing' stamp: ''!
centerWidth: anObject
	centerWidth := anObject! !

!RSSunburstExtentLayout commentStamp: ''!
I am a layout for Sunburst Visualization, I use a radius to calculate the better distance of all arcs in the visualization.

You can use radius to set the total radius of sunburst
or use the selector extent:, that uses radius size!
!RSSunburstExtentLayout methodsFor: 'hook' stamp: ''!
setNormalRadius: shape
	| r1 r2 off depth |
	depth := shape propertyAt: #depth.
	off := self radialSpacing * (depth -1 ).
	r1 := (self radiusForDepth: depth -1) + off.
	r2 := (self radiusForDepth: depth) + off.
	shape
		innerRadius: r1;
		externalRadius: r2.! !

!RSSunburstExtentLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self extent: 500@500! !

!RSSunburstExtentLayout methodsFor: 'hook' stamp: ''!
setCenterRadius: shape
	shape externalRadius: (self radiusForDepth: 1).
	! !

!RSSunburstExtentLayout methodsFor: 'accessing' stamp: ''!
radiusForDepth: depth
	| w2 maxDepth |
	w2 := wside/2.
	maxDepth := builder maxLevel.
	^ ((depth * w2 * w2) / (maxDepth + 1) ) sqrt! !

!RSSunburstExtentLayout methodsFor: 'accessing' stamp: ''!
extent: aPoint
	wside := aPoint x min: aPoint y! !

!RSSunburstFadeInteraction commentStamp: ''!
I define a new basic highlight interaction!
!RSSunburstFadeInteraction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self highlightColor: [ :shape | shape color alpha: 0.15 ].! !

!RSSunburstFadeInteraction methodsFor: 'accessing' stamp: ''!
builder: aBuilder
	builder := aBuilder! !

!RSSunburstFadeInteraction methodsFor: 'initialization' stamp: ''!
onShape: aShape
	aShape
		when: RSMouseEnter do: [ :evt | 
			still := true.
			self doHighlight: evt shape.
			evt signalUpdate ];
		when: RSMouseLeave do: [ :evt | 
			still := false.
			evt canvas newAnimation
				duration: 300 milliSeconds; 
				onStepDo: [ :t | evt signalUpdate ];
				when: RSAnimationLoopEvent do: [ :e | 
					still ifFalse: [ self doUnhighlight: evt shape. ].
					].
			evt signalUpdate ]! !

!RSSunburstFadeInteraction methodsFor: 'accessing' stamp: ''!
builder
	^ builder! !

!RSSunburstFadeInteraction methodsFor: 'initialization' stamp: ''!
highlightShapesFor: shape
	| parents |
	parents := self pathFor: shape.
	^ builder shapes 
		reject: [ :s | parents includes: s].! !

!RSSunburstFadeInteraction methodsFor: 'initialization' stamp: ''!
pathFor: shape
	| list current |
	list := OrderedCollection new.
	current := shape.
	[ current notNil ] whileTrue: [
		list add: current.
		current := current sparent ].
	^ list ! !

!RSTAnnounceable commentStamp: ''!
Used for objects and shapes with an announcer!
!RSTAnnounceable methodsFor: 'announcer' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject
	self announcer when: anAnnouncementClass send: aSelector to: anObject! !

!RSTAnnounceable methodsFor: 'testing' stamp: ''!
hasInteraction: anInteractionClass
	"Return true or false if the receiver has an interaction. Note that the argument has to be an interaction class. And not an event"
	self announcer subscriptions ifNil: [ ^ false ].
	^ self announcer subscriptions handleSubscriberClass: anInteractionClass! !

!RSTAnnounceable methodsFor: 'removing' stamp: ''!
removeInteractionIfPresent: anInteractionClass
	"Remove all the callbacks associated to the interaction."
	(self hasInteraction: anInteractionClass) ifFalse: [ ^ self ].
	(self getInteractionsForClass: anInteractionClass) do: [ :int | self announcer unsubscribe: int ]! !

!RSTAnnounceable methodsFor: 'announcer' stamp: ''!
when: event do: aBlock
	self announcer when: event do: aBlock! !

!RSTAnnounceable methodsFor: 'announcer' stamp: ''!
announcementClasses
	"must return a collection of Announcement classes"
	^ self explicitRequirement! !

!RSTAnnounceable methodsFor: 'announcer' stamp: ''!
announce: anEvent
	| a |
	a := self privateAnnouncer.
	a ifNil: [ ^ self ].
	a announce: anEvent value! !

!RSTAnnounceable methodsFor: 'public' stamp: ''!
executeWithoutAnnouncer: aBlock
	| ann |
	ann := self privateAnnouncer.
	self announcer: nil.
	aBlock value.
	self announcer: ann.! !

!RSTAnnounceable methodsFor: 'announcer' stamp: ''!
announcer: anAnnouncer
	self explicitRequirement! !

!RSTAnnounceable methodsFor: 'announcer' stamp: ''!
getInteractionsForClass: anInteractionClass
	"Return the Announcement subscriptions for the interaction"
	^ self announcer subscriptions getInteractionsForClass: anInteractionClass! !

!RSTAnnounceable methodsFor: 'announcer' stamp: ''!
privateAnnouncer
	^ self explicitRequirement! !

!RSTAnnounceable methodsFor: 'announcer' stamp: ''!
announcer
	^ self privateAnnouncer ifNil: [ 
		| a |
		a := Announcer new.
		self announcer: a.
		a ]! !

!RSTAnnounceable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTAnnounceable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTAnnounceable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTAnnounceable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTAnnounceable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTAnnounceable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTAnnounceable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTAnnounceable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTAnnounceable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTAnnounceable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTAnnounceable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTAnnounceable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTAnnounceable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTAnnounceable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTAnnounceable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTAnnounceable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTAnnounceable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTAnnounceable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTAnnounceable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTAnnounceable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTAnnounceable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTAnnounceable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTAnnounceable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTAnnounceable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTAnnounceable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTAnnounceable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTContainer commentStamp: ''!
My users can have edges and nodes useful to build graphs with roassal!
!RSTContainer methodsFor: 'looking up shapes' stamp: ''!
shapeFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"

	^ self nodes shapeFromModel: anObject! !

!RSTContainer methodsFor: 'adding nodes edges' stamp: ''!
add: aShape
	self
		assert: aShape notNil
		description: 'Nil cannot be added to a canvas'.
	aShape 
		addedIn: self;
		renderOn: self.
	^ aShape! !

!RSTContainer methodsFor: 'accessing' stamp: ''!
numberOfEdges
	"Return the number of edges contained in the container"
	^ self privateEdges
		ifNil: [ 0 ]
		ifNotNil: [ :aGroupOfEdges | aGroupOfEdges size ]! !

!RSTContainer methodsFor: 'adding nodes edges' stamp: ''!
addLine: aShape
	self lines add: aShape.
	^ aShape! !

!RSTContainer methodsFor: 'looking up shapes' stamp: ''!
shapesFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"

	^ self nodes shapesFromModel: anObject! !

!RSTContainer methodsFor: 'accessing' stamp: ''!
children
	^ self nodes! !

!RSTContainer methodsFor: 'removing' stamp: ''!
removeEdge: anEdge
	self edges remove: anEdge ifAbsent: [  ].! !

!RSTContainer methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModels: someObjects
	"Retreive a shape from a given model. Return nil if not found"
	| result |
	result := RSGroup new.
	self deepShapesFromModels: someObjects result: result.
	^ result! !

!RSTContainer methodsFor: 'actions' stamp: ''!
pushBackEdges
	"Push back all the edges"
	self edges do: [ :e | e pushBack ]! !

!RSTContainer methodsFor: 'private' stamp: ''!
privateEdges
	^ self explicitRequirement! !

!RSTContainer methodsFor: 'private' stamp: ''!
privateShapes: aCollection
	self explicitRequirement! !

!RSTContainer methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModel: anObject result: result
	"Private method"
	self model = anObject ifTrue: [ result add: self ].
	self nodes do: [ :c | c deepShapesFromModel: anObject result: result ]! !

!RSTContainer methodsFor: 'adding nodes edges' stamp: ''!
addNode: aShape
	self nodes add: aShape.
	^ aShape! !

!RSTContainer methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"
	| result |
	result := RSGroup new.
	self deepShapesFromModel: anObject result: result.
	^ result! !

!RSTContainer methodsFor: 'accessing' stamp: ''!
edges
	"Return all the lines contained in the canvas."
	^ self privateEdges
		ifNil: [ | res |
			self privateEdges: (res := RSGroup new).
			res ]! !

!RSTContainer methodsFor: 'private' stamp: ''!
privateEdges: aTSGroup
	self explicitRequirement! !

!RSTContainer methodsFor: 'accessing' stamp: ''!
allChildren
	| allChildren index |
	index := 1.
	allChildren := OrderedCollection withAll: self children.
	[ index <= allChildren size ] whileTrue: [ 
		allChildren addAll: ((allChildren at: index) children ifNil: [#()]).
		index := index + 1 ].
	^ allChildren! !

!RSTContainer methodsFor: 'accessing' stamp: ''!
withAllChildren
	^ self allChildren
		add: self;
		yourself! !

!RSTContainer methodsFor: 'looking up shapes' stamp: ''!
deepShapeFromModel: anObject
	"Retreive a shape from a given model. Return nil if not found"
	| result |
	result := RSGroup new.
	self deepShapeFromModel: anObject result: result.
	result isEmpty ifTrue: [ ^ nil ].
	^ result first! !

!RSTContainer methodsFor: 'accessing' stamp: ''!
nodes 
	"Return all the shapes except lines contained in the canvas."
	^ self privateNodes
		ifNil: [ | res |
			self privateNodes: (res := RSGroup new).
			res ]! !

!RSTContainer methodsFor: 'adding' stamp: ''!
addAllShapes: aCollection
	self assert: [ aCollection isCollection ] description: 'Need to provide a collection as argument'.
	self assert: [ aCollection allSatisfy: [ :e | e isKindOf: RSShape ] ] description: 'Need to provide a collection of RSShape'.
	aCollection do: [ :shape | self addShape: shape ].! !

!RSTContainer methodsFor: 'adding nodes edges' stamp: ''!
addEdge: aShape
	self edges add: aShape.
	^ aShape! !

!RSTContainer methodsFor: 'private' stamp: ''!
privateShapes
	^ self explicitRequirement! !

!RSTContainer methodsFor: 'private' stamp: ''!
privateNodes
	^ self explicitRequirement! !

!RSTContainer methodsFor: 'removing' stamp: ''!
removeNode: aNode
	self nodes remove: aNode ifAbsent: [  ].! !

!RSTContainer methodsFor: 'accessing' stamp: ''!
shapes 
	^ self privateShapes
		ifNil: [ | res |
			self privateShapes: (res := RSGroup new).
			res ]! !

!RSTContainer methodsFor: 'accessing' stamp: ''!
numberOfNodes
	"Return the number of nodes contained in the container"
	^ self privateNodes
		ifNil: [ 0 ]
		ifNotNil: [ :aGroupOfNodes | aGroupOfNodes size ]! !

!RSTContainer methodsFor: 'private' stamp: ''!
privateNodes: aTSGroup
	self explicitRequirement! !

!RSTContainer methodsFor: 'adding nodes edges' stamp: ''!
addAll: aCollection
	"Add a collection of shapes to the canvas. The argument is a collection of shapes."
	self assert: [ aCollection isCollection ] description: 'Need to provide a collection as argument'.
	self assert: [ aCollection allSatisfy: [ :e | e isKindOf: RSShape ] ] description: 'Need to provide a collection of RSShape'.
	
	"Add each shape"
	aCollection do: [ :aShape | self add: aShape ]! !

!RSTContainer methodsFor: 'adding' stamp: ''!
addShape: aShape
	aShape addedIn: self! !

!RSTContainer methodsFor: 'accessing' stamp: ''!
lines
	"Return all the lines contained in the canvas."
	^ self privateEdges
		ifNil: [ | res |
			self privateEdges: (res := RSGroup new).
			res ]! !

!RSTContainer methodsFor: 'looking up shapes' stamp: ''!
deepShapesFromModels: someObjects result: result
	"Private method"
	(someObjects includes: self model) ifTrue: [ result add: self ].
	self nodes do: [ :c | c deepShapesFromModel: someObjects result: result ]! !

!RSTContainer methodsFor: 'looking up shapes' stamp: ''!
deepShapeFromModel: anObject result: result
	"Private method"
	| t |
	t := self shapeFromModel: anObject.
	t ifNotNil: [ result add: t ].
	self nodes do: [ :c | c deepShapeFromModel: anObject result: result ]! !

!RSTContainer classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTContainer classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTContainer classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTContainer classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTContainer classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTContainer classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTContainer classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTContainer classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTContainer classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTContainer classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTContainer classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTContainer classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTContainer classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTContainer classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTContainer classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTContainer classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTContainer classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTContainer classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTContainer classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTContainer classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTContainer classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTContainer classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTContainer classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTContainer classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTContainer classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTContainer classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTEdge commentStamp: ''!
My users have a line shape to interact with it. This trait has common methods to handle lines!
!RSTEdge methodsFor: 'public - shape' stamp: ''!
color: aColor
	self shape color: aColor! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
border
	^ self shape border! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
dashed
	self shape dashed! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
fmt: aString
	self shape fmt: aString.! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
capRound
	self shape capRound! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
addInteraction: anInteraction
	self shape addInteraction: anInteraction! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
width
	^ self shape border width! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
controlPointsController: aCPController
	self shape controlPointsController: aCPController! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
width: aNumber
	"Set the width of the line. For example:
	
-=-=-=-=-=-=-=-=-=-=
c := RSCanvas new.

from := RSBox new size: 30; model: 'from'.
to := RSEllipse new size: 30; model: 'to'.

c add: from.
c add: to.

RSEdgeBuilder line
	canvas: c;
	width: 10;
	connectFrom: 'from' to: 'to'.


from @ RSDraggable.
to @ RSDraggable.

to translateTo: 50 @ 40.

c @ RSCanvasController
-=-=-=-=-=-=-=-=-=-=
	"
	self shape width: aNumber! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
controlPointsController
	^ self shape controlPointsController! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
markerEnd: aMarker
	self shape markerEnd: aMarker! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
noBorder
	self shape noBorder! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
borderColor: aColor
	self shape borderColor: aColor! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
border: aBorder
	self shape border: aBorder! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
shape
	^ self explicitRequirement! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
marker: aMarker
	self shape marker: aMarker! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
paint: aPaint
	self shape paint: aPaint! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
shape: aRSAbstractLine
	self explicitRequirement! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
markerStart: aMarker
	self shape markerStart: aMarker! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
joinRound
	self shape joinRound! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
format: aString
	
	"want more markers? submit a new issue in roassal3"
	| marker bs |
	marker := RSShapeFactory shapeFromString: aString.
	bs := RSStrokeStyle fromString: aString.
	marker ifNotNil: [ self shape marker: marker ].
	! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
dashArray: anArray
	^ self shape dashArray: anArray! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
markerStartEnd: aMarker
	self shape markerStartEnd: aMarker! !

!RSTEdge methodsFor: 'public - shape' stamp: ''!
cornerRadii: aNumber
	^ self shape cornerRadii: aNumber! !

!RSTEdge classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTEdge classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTEdge classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTEdge classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTEdge classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTEdge classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTEdge classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTEdge classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTEdge classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTEdge classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTEdge classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTEdge classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTEdge classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTEdge classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTEdge classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTEdge classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTEdge classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTEdge classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTEdge classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTEdge classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTEdge classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTEdge classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTEdge classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTEdge classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTEdge classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTEdge classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTGapsHolder methodsFor: 'accessing' stamp: ''!
horizontalGap

	self explicitRequirement! !

!RSTGapsHolder methodsFor: 'gap' stamp: ''!
horizontalGapAmong: aShapeParent and: aShape default: anObject

	| gap |
	gap := self horizontalGap.

	^ [ gap value: aShapeParent value: aShape value: anObject ]
		  onDNU: #value:value:value:
		  do: [ gap ]! !

!RSTGapsHolder methodsFor: 'accessing' stamp: ''!
verticalGap

	self explicitRequirement! !

!RSTGapsHolder methodsFor: 'gap' stamp: ''!
verticalGapAmong: aShapeParent and: aShape default: anObject

	| gap |
	gap := self verticalGap.

	^ [ gap value: aShapeParent value: aShape value: anObject ]
		  onDNU: #value:value:value:
		  do: [ gap ]! !

!RSTGapsHolder classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTGapsHolder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTGapsHolder classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTGapsHolder classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTGapsHolder classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTGapsHolder classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTGapsHolder classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTGapsHolder classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTGapsHolder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTGapsHolder classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTGapsHolder classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTGapsHolder classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTGapsHolder classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTGapsHolder classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTGapsHolder classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTGapsHolder classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTGapsHolder classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTGapsHolder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTGapsHolder classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTGapsHolder classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTGapsHolder classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTGapsHolder classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTGapsHolder classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTGapsHolder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTGapsHolder classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTGapsHolder classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTMarkeable commentStamp: ''!
I am a trait to create markers in some especific classes!
!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
markerEnd
	^ self markers 
		ifNil: [ nil ]
		ifNotNil: [ :m | m third ] ! !

!RSTMarkeable methodsFor: 'testing' stamp: ''!
markersIncludesPoint: aPoint 
	self hasMarkers ifFalse: [ ^ false ].
	self markerShapesInPositionDo: [ :m | 
		(m shape includesPoint: aPoint) 
			ifTrue: [ ^ true ] ].
	^ false! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
markerEnd: marker
	| m |
	marker ifNil: [ ^ nil ].
	m := marker asMarker.
	self markers at: 3 put: m.
	^ m! !

!RSTMarkeable methodsFor: 'testing' stamp: ''!
hasMarkers
	| m |
	m := self privateMarkers.
	^ m notNil and: [ 
		m anySatisfy: [ :mar | mar notNil ].  ]! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
markerMid: marker
	| m |
	marker ifNil: [ ^ nil ].
	m := marker asMarker.
	self markers at: 2 put: m.
	^ m! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
privateMarkers: array
	 self explicitRequirement! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
marker: aMarker
	| m |
	m := aMarker asMarker. 
	self 
		markerStart: m;
		markerMid: m;
		markerEnd: m.
	^ m! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
markerMid
	^ self markers 
		ifNil: [ nil ]
		ifNotNil: [ :m | m second ] ! !

!RSTMarkeable methodsFor: 'public' stamp: ''!
markerShapesInPositionDo: aBlock
	| cp |
	cp := self controlPoints.
	self markerStart ifNotNil: [ :marker | marker withStart: cp do: aBlock ].
	self markerMid ifNotNil: [ :marker | marker withMid: cp do: aBlock ].
	self markerEnd ifNotNil: [ :marker | marker withEnd: cp do: aBlock ].! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
privateMarkers
	^ self explicitRequirement! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
markerStart: marker
	| m |
	marker ifNil: [ ^ nil ].
	m := marker asMarker.
	self markers at: 1 put: m.
	^ m! !

!RSTMarkeable methodsFor: 'public' stamp: ''!
resetMarkers
	self privateMarkers: nil! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
markerStart 
	^ self markers 
		ifNil: [ nil ]
		ifNotNil: [ :m | m first ] ! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
markersDo: block
	self markers do: [ :m | m ifNotNil: block  ].! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
markerStartEnd: aMarker
	| m |
	m := aMarker asMarker. 
	self 
		markerStart: m;
		markerEnd: m.
	^ m! !

!RSTMarkeable methodsFor: 'accessing - markers' stamp: ''!
markers
	^ self privateMarkers 
		ifNil: [ | array |
			array := Array new: 3.
			self privateMarkers: array.
			array ]! !

!RSTMarkeable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTMarkeable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTMarkeable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTMarkeable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTMarkeable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTMarkeable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTMarkeable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTMarkeable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTMarkeable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTMarkeable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTMarkeable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTMarkeable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTMarkeable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTMarkeable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTMarkeable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTMarkeable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTMarkeable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTMarkeable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTMarkeable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTMarkeable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTMarkeable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTMarkeable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTMarkeable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTMarkeable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTMarkeable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTMarkeable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTPositionable commentStamp: ''!
I am a trait for BoundingShape and Camera since both of them uses an announcement when the position of both changes!
!RSTPositionable methodsFor: 'actions' stamp: ''!
translateBy: deltaAsPoint
	"Move a shape by a delta value, expressed as a point"
	self translateTo: self position + deltaAsPoint
	! !

!RSTPositionable methodsFor: 'actions' stamp: ''!
translateTo: aPoint
	"Translate a shape to a new position, expressed as a point"
	| oldPosition |
	oldPosition := self position.
	oldPosition = aPoint ifTrue: [ ^ self ].
	self position: aPoint.
	self announce: [RSPositionChangedEvent new 
		shape: self; 
		oldPosition: oldPosition;
		newPosition: aPoint ].
! !

!RSTPositionable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTPositionable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTPositionable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTPositionable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTPositionable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTPositionable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTPositionable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTPositionable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTPositionable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTPositionable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTPositionable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTPositionable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTPositionable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTPositionable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTPositionable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTPositionable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTPositionable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTPositionable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTPositionable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTPositionable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTPositionable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTPositionable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTPositionable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTPositionable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTPositionable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTPositionable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTWalkBasedRegularHorizontalTreeLayout methodsFor: 'positioning' stamp: ''!
breadthGapAmong: aShapeParent and: aShape

	^ self
		  verticalGapAmong: aShapeParent
		  and: aShape
		  default: RSAbstractGraphLayout horizontalGap! !

!RSTWalkBasedRegularHorizontalTreeLayout methodsFor: 'accessing' stamp: ''!
horizontalGap

	self explicitRequirement! !

!RSTWalkBasedRegularHorizontalTreeLayout methodsFor: 'gap' stamp: ''!
horizontalGapAmong: aShapeParent and: aShape default: anObject

	| gap |
	gap := self horizontalGap.

	^ [ gap value: aShapeParent value: aShape value: anObject ]
		  onDNU: #value:value:value:
		  do: [ gap ]! !

!RSTWalkBasedRegularHorizontalTreeLayout methodsFor: 'accessing' stamp: ''!
verticalGap

	self explicitRequirement! !

!RSTWalkBasedRegularHorizontalTreeLayout methodsFor: 'positioning' stamp: ''!
positionOfShape: aShape atDepth: depth atBreadth: breadth

	| shift |
	shift := aShape extent / 2.
	^ depth @ breadth + shift! !

!RSTWalkBasedRegularHorizontalTreeLayout methodsFor: 'positioning' stamp: ''!
depthMeasureOf: aShape

	^ aShape width! !

!RSTWalkBasedRegularHorizontalTreeLayout methodsFor: 'positioning' stamp: ''!
depthGapAmong: aShapeParent and: aShape

	^ self
		  horizontalGapAmong: aShapeParent
		  and: aShape
		  default: RSAbstractGraphLayout verticalGap! !

!RSTWalkBasedRegularHorizontalTreeLayout methodsFor: 'gap' stamp: ''!
verticalGapAmong: aShapeParent and: aShape default: anObject

	| gap |
	gap := self verticalGap.

	^ [ gap value: aShapeParent value: aShape value: anObject ]
		  onDNU: #value:value:value:
		  do: [ gap ]! !

!RSTWalkBasedRegularHorizontalTreeLayout methodsFor: 'positioning' stamp: ''!
breadthMeasureOf: aShape

	^ aShape height! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTWalkBasedRegularHorizontalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTWalkBasedRegularTreeLayout commentStamp: ''!
I am the tree layout algorithm described in the publication "Drawing non-layered tidy trees in linear time" by Atze van der Ploeg [1] (companion repo at [2]).

I encode the main algorithm leaving objects that use my behavior to fullfil some explicit requirements concerning the dimension the tree will grow toward to.

[1]: https://www.semanticscholar.org/paper/Drawing-non-layered-tidy-trees-in-linear-time-Ploeg/d45f66231e053590c64c9d901fb7b028dbc5c923
[2]: https://github.com/cwi-swat/non-layered-tidy-trees!
!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
mselOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
separate: v children: children at: i rest: aValueLink

	| sr cl mssr mscl ih |
	"Right contour node of left siblings and its sum of modfiers."
	sr := children at: i - 1.
	mssr := self modOf: sr.

	"Left contour node of current subtree and its sum of modfiers."
	cl := children at: i.
	mscl := self modOf: cl.

	"Looping"
	ih := aValueLink.
	[ sr isNotNil and: [ cl isNotNil ] ] whileTrue: [ 
		| dist sy cy |
		(self depthBoundOf: sr) > (self lowYofIYL: ih) ifTrue: [ 
			ih := ih nextLink ].

		"How far to the left of the right side of sr is the left side of cl?"
		dist := mssr + (self prelimOf: sr) + (self breadthMeasureOf: sr)
		        + (self breadthGapAmong: sr and: cl) - mscl
		        - (self prelimOf: cl).

		dist > 0 ifTrue: [ 
			mscl := mscl + dist.
			self
				moveSubtree: children
				at: i
				other: (self indexOfIYL: ih)
				distance: dist ].

		"Advance highest node(s) and sum(s) of modifiers (Coordinate system increases downwards)"
		sy := self depthBoundOf: sr.
		cy := self depthBoundOf: cl.

		sy <= cy ifTrue: [ 
			sr := self nextRightContour: sr.
			sr ifNotNil: [ mssr := mssr + (self modOf: sr) ] ].

		sy >= cy ifTrue: [ 
			cl := self nextLeftContour: cl.
			cl ifNotNil: [ mscl := mscl + (self modOf: cl) ] ] ].

	"Set threads and update extreme nodes."
	(sr isNil and: [ cl isNotNil ])
		ifTrue: [ "the current subtree must be taller than the left siblings."
			self
				setLeftThread: v
				leftMostChild: children first
				currentChild: (children at: i)
				child: cl
				acc: mscl ]
		ifFalse: [ "the left siblings must be taller than the current subtree."
			(sr isNotNil and: [ cl isNil ]) ifTrue: [ 
				self
					setRightThread: v
					previousChild: (children at: i - 1)
					currentChild: (children at: i)
					child: sr
					acc: mssr ] ]! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'updating properties' stamp: ''!
mselOf: aNode update: aBlock

	^ self mselOf: aNode put: (aBlock value: (self mselOf: aNode))! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'updating properties' stamp: ''!
shiftOf: aNode update: aBlock

	^ self shiftOf: aNode put: (aBlock value: (self shiftOf: aNode))! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
completedInitializationOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
elOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
firstWalk: v

	self
		is: v
		ifLeaf: [ self setExtremesOfLeaf: v ]
		ifNotLeaf: [ :children | 
			| leftMostChild rightMostChild chain bound |
			leftMostChild := children first.
			rightMostChild := children last.

			"Recur down on v's leftmost child."
			self firstWalk: leftMostChild.

			"Create siblings in contour minimal vertical coordinate and index list."
			bound := self depthBoundOf: (self elOf: leftMostChild).

			chain := (2 to: children size)
				         inject: (self updateIYL: bound at: 1 rest: nil)
				         into: [ :ih :i | 
					         | child |
					         child := children at: i.

					         self firstWalk: child.

					         bound := self depthBoundOf: (self erOf: child).

					         "/Store lowest vertical coordinate while extreme nodes still point in current subtree."
					         self
						         separate: v
						         children: children
						         at: i
						         rest: ih.

					         "Update data about the widths"
					         self updateIYL: bound at: i rest: ih ].

			self
				positionRoot: v
				leftMostChild: leftMostChild
				rightMostChild: rightMostChild.

			self
				setExtremesOfNonLeaf: v
				leftMostChild: leftMostChild
				rightMostChild: rightMostChild ]! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
setExtremesOfNonLeaf: v leftMostChild: leftMostChild rightMostChild: rightMostChild

	self
		elOf: v put: (self elOf: leftMostChild);
		erOf: v put: (self erOf: rightMostChild);
		mselOf: v put: (self mselOf: leftMostChild);
		mserOf: v put: (self mserOf: rightMostChild)! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
secondWalk: aShape depth: n breadth: m

	| mNext children depth breadth position |
	mNext := m + (self modOf: aShape).

	depth := n + (self depthOf: aShape).
	breadth := (self prelimOf: aShape) + mNext.

	position := self
		            positionOfShape: aShape
		            atDepth: depth
		            atBreadth: breadth.
	self positionOf: aShape put: position.

	children := self childrenOf: aShape.

	self addChildSpacing: children.

	"Recur over my onw children."
	children do: [ :aChild | 
		self secondWalk: aChild depth: n breadth: mNext ]! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'updating properties' stamp: ''!
prelimOf: aNode update: aBlock

	^ self prelimOf: aNode put: (aBlock value: (self prelimOf: aNode))! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
mselOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
nextRightContour: v

	^ self
		  is: v
		  ifLeaf: [ self rthreadOf: v ]
		  ifNotLeaf: [ (self childrenOf: v) last ]! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
setExtremesOfLeaf: v

	self
		elOf: v put: v;
		erOf: v put: v;
		mselOf: v put: 0;
		mserOf: v put: 0! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
depthOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
threadOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
changeOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
is: aShape ifLeaf: lBlock ifNotLeaf: nlBlock

	^ (self childrenOf: aShape) ifEmpty: lBlock ifNotEmpty: nlBlock! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'updating properties' stamp: ''!
changeOf: aNode update: aBlock

	^ self changeOf: aNode put: (aBlock value: (self changeOf: aNode))! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'positioning' stamp: ''!
depthMeasureOf: aShape

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
modOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'positioning' stamp: ''!
depthGapAmong: aShapeParent and: aShape

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
moveSubtree: children at: i other: si distance: dist

	"Move subtree by changing mod."

	| child intermediateChildren |
	child := children at: i.

	self
		modOf: child update: [ :mod | mod + dist ];
		mselOf: child update: [ :msel | msel + dist ];
		mserOf: child update: [ :mser | mser + dist ].

	"Are there intermediate children? (originally extracted in the `distributedExtra` function)"
	self assert: i > si.

	(intermediateChildren := i - si) > 1 ifTrue: [ 
		| siChild ratio |
		ratio := dist / intermediateChildren.
		siChild := children at: si + 1.
		self
			shiftOf: siChild update: [ :shift | shift + ratio ];
			shiftOf: child update: [ :shift | shift - ratio ];
			changeOf: child update: [ :change | change - dist + ratio ] ]! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
erOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
levelOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'updating properties' stamp: ''!
modOf: aNode update: aBlock

	^ self modOf: aNode put: (aBlock value: (self modOf: aNode))! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
prelimOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
nextLeftContour: v

	^ self
		  is: v
		  ifLeaf: [ self threadOf: v ]
		  ifNotLeaf: [ (self childrenOf: v) first ]! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'positioning' stamp: ''!
breadthGapAmong: aShapeParent and: aShape

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
childrenOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
rthreadOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
hasBeenInitializedOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
mserOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
positionOf: aShape put: aPoint

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'positioning' stamp: ''!
positionOfShape: aShape atDepth: depth atBreadth: breadth

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
updateIYL: minY at: i rest: aValueLink

	| ih |
	"Remove siblings that are hidden by the new subtree."
	ih := aValueLink.
	[ ih isNotNil and: [ minY >= (self lowYofIYL: ih) ] ] whileTrue: [ 
		ih := ih nextLink ].

	"Prepend the new subtree"
	^ ValueLink new
		  value: i -> minY;
		  nextLink: ih;
		  yourself! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
threadOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
setLeftThread: v leftMostChild: leftMostChild currentChild: child child: cl acc: mscl

	| li diff |
	li := self elOf: leftMostChild.
	self threadOf: li put: cl.

	"Change mod so that the sum of modifier after following thread is correct."
	diff := mscl - (self modOf: cl) - (self mselOf: leftMostChild).
	self modOf: li update: [ :mod | mod + diff ].

	"Change preliminary x coordinate so that the node does not move."
	self prelimOf: li update: [ :prelim | prelim - diff ].

	"Update extreme node and its sum of modifiers."
	self
		elOf: leftMostChild put: (self elOf: child);
		mselOf: leftMostChild put: (self mselOf: child)! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
erOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
elOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
modOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
depthOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
levelOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
rthreadOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'updating properties' stamp: ''!
mserOf: aNode update: aBlock

	^ self mserOf: aNode put: (aBlock value: (self mserOf: aNode))! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'API' stamp: ''!
layout: aRootShape depth: aDepth breadth: aBreadth

	self
		firstWalk: aRootShape;
		secondWalk: aRootShape depth: aDepth breadth: aBreadth! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'initialization' stamp: ''!
initialize: elements lineEdges: aGroupOfLines

	| associations |
	associations := aGroupOfLines collect: [ :line | line from -> line to ].
	^ self initialize: elements associationEdges: associations! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
depthBoundOf: aShape

	^ (self depthOf: aShape) + (self depthMeasureOf: aShape)! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'initialization' stamp: ''!
initializeForShape: aShape fathers: fathers

	| depth |
	self
		modOf: aShape put: 0;
		changeOf: aShape put: 0;
		shiftOf: aShape put: 0;
		prelimOf: aShape put: 0;
		mselOf: aShape put: 0;
		mserOf: aShape put: 0;
		threadOf: aShape put: nil;
		rthreadOf: aShape put: nil;
		elOf: aShape put: nil;
		erOf: aShape put: nil.

	depth := fathers
		         at: aShape
		         ifPresent: [ :parents | 
			         | level |
			         parents
				         reject: [ :each | self hasBeenInitializedOf: each ]
				         thenDo: [ :each | 
				         self initializeForShape: each fathers: fathers ].

			         level := (parents collect: [ :each | self levelOf: each ])
				                  max.

			         self levelOf: aShape put: level + 1.

			         (parents collect: [ :aShapeParent | 
				          (self depthBoundOf: aShapeParent)
				          + (self depthGapAmong: aShapeParent and: aShape) ]) max ]
		         ifAbsent: [ self levelOf: aShape put: 0 ].

	self
		depthOf: aShape put: depth;
		completedInitializationOf: aShape.

	^ aShape! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
childrenOf: aNode put: aValue

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'initialization' stamp: ''!
initialize: elements associationEdges: associations

	| hierarchy roots fathers rootNode leaves |
	hierarchy := IdentityDictionary new.
	roots := IdentitySet withAll: elements.
	leaves := IdentitySet withAll: elements.
	fathers := IdentityDictionary new.

	associations do: [ :anAssociation | 
		| children child father multipleParents fathersOfChild |
		father := anAssociation key.
		child := anAssociation value.

		multipleParents := false.
		roots remove: child ifAbsent: [ multipleParents := true ].

		leaves
			remove: father
			ifAbsent: [ "is it okay to try to remove father more than one time"
			 ].

		fathersOfChild := fathers
			                  at: child
			                  ifAbsentPut: [ OrderedCollection new ].

		fathersOfChild add: father.

		children := hierarchy
			            at: father
			            ifAbsentPut: [ 
			            self childrenOf: father put: OrderedCollection new ].

		multipleParents ifFalse: [ children add: child ] ].

	rootNode := roots size > 1
		        ifTrue: [ 
			        roots collect: [ :each | 
				        self assert: (fathers includesKey: each) not
				        "fathers at: each put: { rootBox }" ].

			        RSComposite new
				        in: [ :aRootShape | 
					        self childrenOf: aRootShape put: roots asArray ];
				        yourself ]
		        ifFalse: [ roots anyOne ].

	leaves do: [ :each | 
		self
			assert: (self childrenOf: each) isNil;
			childrenOf: each put: Array empty;
			initializeForShape: each fathers: fathers ].

	^ self initializeForShape: rootNode fathers: fathers! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
setRightThread: v previousChild: previousChild currentChild: currentChild child: sr acc: mssr

	| ri diff |
	ri := self erOf: currentChild.
	self rthreadOf: ri put: sr.

	"Change mod so that the sum of modifier after following thread is correct."
	diff := mssr - (self modOf: sr) - (self mserOf: currentChild).
	self modOf: ri update: [ :mod | mod + diff ].

	"Change preliminary x coordinate so that the node does not move."
	self prelimOf: ri update: [ :prelim | prelim - diff ].

	"Update extreme node and its sum of modifiers."
	self
		erOf: currentChild put: (self erOf: previousChild);
		mserOf: currentChild put: (self mserOf: previousChild)! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
lowYofIYL: aValueLink

	| anAssoc |
	anAssoc := aValueLink value.
	^ anAssoc value! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
shiftOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
prelimOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
mserOf: aNode put: aFloat

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
addChildSpacing: children

	^ children inject: 0 @ 0 into: [ :aPoint :child | 
		  | x newPoint y |
		  x := aPoint x + (self shiftOf: child).
		  y := x + aPoint y + (self changeOf: child).
		  newPoint := Point x: x y: y.
		  self modOf: child update: [ :mod | mod + newPoint y ].
		  newPoint ]! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
shiftOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
positionRoot: v leftMostChild: leftMostChild rightMostChild: rightMostChild

	| childrenPrelim |
	"Set the prelim for hierarchy item v."
	childrenPrelim := (self prelimOf: leftMostChild)
	                  + (self modOf: leftMostChild)
	                  + (self prelimOf: rightMostChild)
	                  + (self modOf: rightMostChild)
	                  + (self breadthMeasureOf: rightMostChild)
	                  - (self breadthMeasureOf: v).

	self prelimOf: v put: childrenPrelim / 2! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'properties' stamp: ''!
changeOf: aNode

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'positioning' stamp: ''!
breadthMeasureOf: aShape

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayout methodsFor: 'algorithm' stamp: ''!
indexOfIYL: aValueLink

	| anAssoc |
	anAssoc := aValueLink value.
	^ anAssoc key! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTWalkBasedRegularTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
mselOf: aNode put: aFloat

	^ aNode propertyAt: #msel put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
prelimOf: aNode

	^ aNode propertyAt: #prelim! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
childrenOf: aNode

	^ aNode propertyAt: #children! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
rthreadOf: aNode

	^ aNode propertyAt: #rthread! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
hasBeenInitializedOf: aNode

	^ aNode propertyAt: #vdpInitialized ifAbsent: [ false ]! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
mserOf: aNode

	^ aNode propertyAt: #mser! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
positionOf: aShape put: aPoint

	^ aShape position: aPoint! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
completedInitializationOf: aNode

	^ aNode propertyAt: #vdpInitialized put: true! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
elOf: aNode put: aFloat

	^ aNode propertyAt: #el put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
threadOf: aNode

	^ aNode propertyAt: #thread! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
erOf: aNode put: aFloat

	^ aNode propertyAt: #er put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
elOf: aNode

	^ aNode propertyAt: #el! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
modOf: aNode put: aFloat

	^ aNode propertyAt: #mod put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
mselOf: aNode

	^ aNode propertyAt: #msel! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
rthreadOf: aNode put: aFloat

	^ aNode propertyAt: #rthread put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
depthOf: aNode put: aFloat

	^ aNode propertyAt: #depth put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
levelOf: aNode

	^ aNode propertyAt: #vdpLevel! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
depthOf: aNode

	^ aNode propertyAt: #depth! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
childrenOf: aNode put: aValue

	^ aNode propertyAt: #children put: aValue! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
threadOf: aNode put: aFloat

	^ aNode propertyAt: #thread put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
changeOf: aNode put: aFloat

	^ aNode propertyAt: #change put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
shiftOf: aNode put: aFloat

	^ aNode propertyAt: #shift put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
prelimOf: aNode put: aFloat

	^ aNode propertyAt: #prelim put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
mserOf: aNode put: aFloat

	^ aNode propertyAt: #mser put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
shiftOf: aNode

	^ aNode propertyAt: #shift! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
changeOf: aNode

	^ aNode propertyAt: #change! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
modOf: aNode

	^ aNode propertyAt: #mod! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
erOf: aNode

	^ aNode propertyAt: #er! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties methodsFor: 'properties' stamp: ''!
levelOf: aNode put: aFloat

	^ aNode propertyAt: #vdpLevel put: aFloat! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTWalkBasedRegularTreeLayoutOnShapeProperties classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning methodsFor: 'accessing' stamp: ''!
random

	^ random ifNil: [ random := Random new ]! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning methodsFor: 'positioning' stamp: ''!
positionOfShape: aShape atDepth: depth atBreadth: breadth

	^ (self rawPositionOfShape: aShape atDepth: depth atBreadth: breadth)
	  + (self random next asPoint * Float goldenRatio)! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning methodsFor: 'accessing' stamp: ''!
random: aRandom

	random := aRandom! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning methodsFor: 'positioning' stamp: ''!
rawPositionOfShape: aShape atDepth: depth atBreadth: breadth

	self explicitRequirement! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTWalkBasedRegularTreeLayoutRandomizedPositioning classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTWalkBasedRegularVerticalTreeLayout methodsFor: 'positioning' stamp: ''!
breadthGapAmong: aShapeParent and: aShape

	^ self
		  horizontalGapAmong: aShapeParent
		  and: aShape
		  default: RSAbstractGraphLayout horizontalGap! !

!RSTWalkBasedRegularVerticalTreeLayout methodsFor: 'accessing' stamp: ''!
horizontalGap

	self explicitRequirement! !

!RSTWalkBasedRegularVerticalTreeLayout methodsFor: 'gap' stamp: ''!
horizontalGapAmong: aShapeParent and: aShape default: anObject

	| gap |
	gap := self horizontalGap.

	^ [ gap value: aShapeParent value: aShape value: anObject ]
		  onDNU: #value:value:value:
		  do: [ gap ]! !

!RSTWalkBasedRegularVerticalTreeLayout methodsFor: 'accessing' stamp: ''!
verticalGap

	self explicitRequirement! !

!RSTWalkBasedRegularVerticalTreeLayout methodsFor: 'positioning' stamp: ''!
positionOfShape: aShape atDepth: depth atBreadth: breadth

	| shift |
	shift := aShape extent / 2.
	^ breadth @ depth + shift! !

!RSTWalkBasedRegularVerticalTreeLayout methodsFor: 'positioning' stamp: ''!
depthMeasureOf: aShape

	^ aShape height! !

!RSTWalkBasedRegularVerticalTreeLayout methodsFor: 'positioning' stamp: ''!
depthGapAmong: aShapeParent and: aShape

	^ self
		  verticalGapAmong: aShapeParent
		  and: aShape
		  default: RSAbstractGraphLayout verticalGap! !

!RSTWalkBasedRegularVerticalTreeLayout methodsFor: 'gap' stamp: ''!
verticalGapAmong: aShapeParent and: aShape default: anObject

	| gap |
	gap := self verticalGap.

	^ [ gap value: aShapeParent value: aShape value: anObject ]
		  onDNU: #value:value:value:
		  do: [ gap ]! !

!RSTWalkBasedRegularVerticalTreeLayout methodsFor: 'positioning' stamp: ''!
breadthMeasureOf: aShape

	^ aShape width! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSTWalkBasedRegularVerticalTreeLayout classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSTest commentStamp: ''!
I am the top class for tests!
!RSTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = RSTest! !

!RSTextExtents commentStamp: ''!
Extents for RSLabel!
!RSTextExtents methodsFor: 'accessing' stamp: ''!
width: aNumber
	width := aNumber! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
x_advance: aNumber
	x_advance := aNumber! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
x_bearing
	^ x_bearing! !

!RSTextExtents methodsFor: 'public' stamp: ''!
from: ref 
	"ref is a CairoTextExtents"
	self 
		width: ref width;
		height: ref height;
		x_advance: ref x_advance;
		y_advance: ref y_advance;
		x_bearing: ref x_bearing;
		y_bearing: ref y_bearing.
! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
y_advance
	^ y_advance! !

!RSTextExtents methodsFor: 'public' stamp: ''!
empty
	self 
		width: 0;
		height: 0;
		x_advance: 0;
		y_advance: 0;
		x_bearing: 0;
		y_bearing: 0.
! !

!RSTextExtents methodsFor: 'printing' stamp: ''!
printOn: s
	s << self className; << '('.
	#(x_bearing y_bearing width height x_advance y_advance) do: [ :sel |
		s << sel; << ':'; << String tab.
		(sel value: self) printOn: s.
		 ] separatedBy: [ s << String crlf ].
	s << ')'.! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
x_advance
	^ x_advance! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
height
	^ height! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
y_bearing: aNumber
	y_bearing := aNumber! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
height: aNumber
	height := aNumber! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
x_bearing: aNumber
	x_bearing := aNumber! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
y_bearing
	^ y_bearing! !

!RSTextExtents methodsFor: 'public' stamp: ''!
translationPoint
	| ybn |
	ybn := y_bearing negated.
	^ (((width/ -2) - x_bearing)  @ 0) + (0@((ybn/2)- ((height- ybn)/2)))! !

!RSTextExtents methodsFor: 'accessing' stamp: ''!
y_advance: aNumber
	y_advance := aNumber! !

!RSTextExtents class methodsFor: 'requirements' stamp: ''!
empty
	^ empty ifNil: [ empty := self new empty ]! !

!RSTickConfiguration commentStamp: ''!
<keyClass>
`RSTickConfiguration` describes a configuration for a vertical or horizontal tick. Note that the same configuration can be shared for the two tick objects.

*Responsibility*: maintain the different configurable attributes for vertical or horizontal tickis.

*Collaborators*: used by `RSAbstractTick`

*Variables*:
- `numberOfTicks`: number of ticks the tick decoration should have
- `shouldHaveLabels`: a boolean indicating whether a the tick should have labels or not
- `labelConversion`: one arg block to transform a value. E.g., `[ :p | 'V', p asString ]`
- `shouldUseNiceLabel`: a boolean indicating whether the tick should use the nice tick label generator (e.g., `RSNiceLabel`)
- `labelRotation`: rotation degree of the label
- `fontSize`: size of the label font
- `tickSize`: size of the tick, in pixels

*Example*:
```Smalltalk
classes := RSObject withAllSubclasses.
x := classes collect: [ :c | c numberOfMethods ].
y := classes collect: [ :c | c linesOfCode ].

c := RSChart new.

d := RSScatterPlot new.
d color: Color blue translucent.
d x: x y: y.
c addPlot: d.

tickConfiguration := RSTickConfiguration new
		numberOfTicks: 5;
		fontSize: 5;
		labelRotation: 0;
		shouldHaveLabels: true;
		shouldUseNiceLabel: true;
		labelConversion: [ :value | value ] ;
		tickSize: 3;
		yourself.
c addDecoration: (RSHorizontalTick new configuration: tickConfiguration).
c addDecoration: (RSVerticalTick new configuration: tickConfiguration).
c
```

Another similar example:
```Smalltalk
classes := RSObject withAllSubclasses.
x := classes collect: [ :c | c numberOfMethods ].
y := classes collect: [ :c | c linesOfCode ].

c := RSChart new.

d := RSScatterPlot new.
d color: Color blue translucent.
d x: x y: y.
c addPlot: d.

tickConfiguration := RSTickConfiguration new.
tickConfiguration labelConversion: [ :p | 'V', p asString ].

c addDecoration: (RSHorizontalTick new configuration: tickConfiguration).
c
```!
!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
shouldHaveLabels
	^ shouldHaveLabels! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
fontSize
	^ fontSize! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
labelConversion: aOneArgBlock
	labelConversion := aOneArgBlock! !

!RSTickConfiguration methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self numberOfTicks: 5;
		fontSize: 5;
		labelRotation: 0;
		shouldHaveLabels: true;
		shouldUseNiceLabel: true;
		labelConversion: [ :value | value ];
		tickSize: 3! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
labelConversion
	^ labelConversion! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
numberOfTicks: aNumber
	numberOfTicks := aNumber! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
tickSize: aNumber
	tickSize := aNumber! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
numberOfTicks
	^ numberOfTicks! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
shouldUseNiceLabel: aBoolean
	shouldUseNiceLabel := aBoolean! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
shouldHaveLabels: aBoolean
	shouldHaveLabels := aBoolean! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
tickSize
	^ tickSize! !

!RSTickConfiguration methodsFor: 'public' stamp: ''!
createLabelFor: aValue
	^ RSLabel new 
		fontSize: self fontSize; 
		text: (self labelConversion rsValue: aValue); 
		rotateByDegrees: self labelRotation;
		yourself! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
labelRotation
	^ labelRotation! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
labelRotation: degreesAsNumber
	labelRotation := degreesAsNumber! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
fontSize: aNumber
	fontSize := aNumber! !

!RSTickConfiguration methodsFor: 'accessing' stamp: ''!
shouldUseNiceLabel
	^ shouldUseNiceLabel! !

!RSTimeLinePlot commentStamp: ''!
Define a time line, a bit like a Gantt diagram.!
!RSTimeLinePlot methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self gapRatio: 0.1.! !

!RSTimeLinePlot methodsFor: 'rendering' stamp: ''!
beforeRenderingIn: aChart
	| barScale |
	super beforeRenderingIn: aChart.
	yScale class = NSOrdinalScale ifTrue: [ ^ self ].
	
	barScale := NSOrdinalScale new 
		domain: (aChart minValueY to: aChart maxValueY);
		rangeBands: yScale range padding: gapRatio.
	aChart yScale: barScale! !

!RSTimeLinePlot methodsFor: 'accessing' stamp: ''!
gapRatio: anObject
	gapRatio := anObject! !

!RSTimeLinePlot methodsFor: 'accessing' stamp: ''!
barScale
	^ yScale! !

!RSTimeLinePlot methodsFor: 'rendering' stamp: ''!
renderIn: canvas
	bars := RSGroup new.
	1 to: xValues size by: 2 do: [ :index |	
		| x1 y1 x2 y2 origin corner rectangle sizeOffset |
		x1 := xValues at: index.
		y1 := yValues at: index.
		x2 := xValues at: index+1.
		y2 := yValues at: index+1.
		origin := self scalePoint: x1 @ y1.
		corner := self scalePoint: x2 @ y2.
		sizeOffset := 0@ self barSize / 2.0.
		rectangle := Rectangle
			origin: origin-sizeOffset
			corner: corner+sizeOffset.
		bars add: (self shape copy
			model: (x1 -> x2);
			color: self computeColor;
			fromRectangle: rectangle;
			yourself)
		].
	canvas addAll: bars. ! !

!RSTimeLinePlot methodsFor: 'accessing' stamp: ''!
createdShapes
	^ bars! !

!RSTimeLinePlot methodsFor: 'accessing' stamp: ''!
bars 
	^ bars! !

!RSTimeLinePlot methodsFor: 'initialization' stamp: ''!
defaultShape
	^ RSBox new noPaint! !

!RSTimeLinePlot methodsFor: 'accessing' stamp: ''!
gapRatio
	^ gapRatio! !

!RSTimeLinePlot methodsFor: 'accessing' stamp: ''!
barSize: aBarWidth
	"Set the width of the bar"
	barSize := aBarWidth! !

!RSTimeLinePlot methodsFor: 'accessing' stamp: ''!
entries: aCollection at: aNumber
	self 
		x: aCollection
		y: (Array new: aCollection size withAll: aNumber).! !

!RSTimeLinePlot methodsFor: 'accessing' stamp: ''!
barSize
	"Return the width of each bar"
	^ barSize ifNil: [ self barScale rangeBand ]! !

!RSTopHorizontalTick commentStamp: ''!
A horizontal tick but in top of the chart, takes values from RSChart !
!RSTopHorizontalTick methodsFor: 'rendering' stamp: ''!
createXScale
	| padding |
	xScale ifNil: [ xScale := NSScale linear ].
	xScale class = NSOrdinalScale ifTrue: [ ^ self ].
	padding := chart padding x.
	xScale
		domain:
			{self min.
			self max};
		range:
			{0 + padding.
			chart extent x - padding}! !

!RSTopHorizontalTick methodsFor: 'rendering' stamp: ''!
createTickLineFor: aNumber
	| value y |
	value := xScale scale: aNumber.
	y := chart extent y negated.
	^ self shape copy
		startPoint: value @ y;
		endPoint: value @ (y - self configuration tickSize);
		yourself! !

!RSTopHorizontalTick methodsFor: 'accessing - defaults' stamp: ''!
defaultLabelLocation
	^ RSLocation new above offset: 0@ -3! !

!RSTopHorizontalTick methodsFor: 'accessing' stamp: ''!
min
	^ values min! !

!RSTopHorizontalTick methodsFor: 'accessing' stamp: ''!
values
	^ values! !

!RSTopHorizontalTick methodsFor: 'accessing' stamp: ''!
values: aCollection
	values := aCollection! !

!RSTopHorizontalTick methodsFor: 'accessing' stamp: ''!
max
	^ values max! !

!RSTorchUMLClassRenderer commentStamp: ''!
I am a second different way to draw an UML class, similar to the system Torch.

Here is an example:
-=-=-=-=-=-=-=-=-=
builder := RSUMLClassBuilder new.
classes := { 'Roassal3-Layouts'. 'Roassal3' }
	flatCollect: [:pkgname | (RPackage organizer
		packageNamed: pkgname) definedClasses ].
builder classes: classes.
builder renderer: RSTorchUMLClassRenderer new.
builder build.
builder canvas @ RSHierarchyPacker.
builder canvas
-=-=-=-=-=-=-=-=-=!
!RSTorchUMLClassRenderer methodsFor: 'hooks' stamp: ''!
classNameBoxFor: aClass 
	^ RSBox new
		color: self titleBoxColor;
		yourself! !

!RSTorchUMLClassRenderer methodsFor: 'defaults' stamp: ''!
defaultClassBoxPadding
	^ 10@0! !

!RSTorchUMLClassRenderer methodsFor: 'layout' stamp: ''!
applyMLayoutOn: shapes
	RSFlowLayout new 
		gapSize: 2;
		maxWidth: self currentMaxWidth;
		on: shapes.! !

!RSTorchUMLClassRenderer methodsFor: 'hooks' stamp: ''!
methodFor: aMethod
	^ RSBox new
		width: 20;
		height: aMethod linesOfCode * 5 + 1;
		popup;
		yourself! !

!RSTorchUMLClassRenderer methodsFor: 'layout' stamp: ''!
applyVLayoutOn: shapes
	self applyMLayoutOn: shapes! !

!RSTorchUMLClassRenderer methodsFor: 'hooks' stamp: ''!
titleFor: aClass
	| s |
	s := super titleFor: aClass.
	currentTitleWidth := s children first textWidth.
	^ s! !

!RSTorchUMLClassRenderer methodsFor: 'hooks' stamp: ''!
methodsFor: aClass
	^ (super methodsFor: aClass)
		padding: ( Margin 
		 	left: 0
			right: 0
			top: 5
			bottom: 5);
		yourself! !

!RSTorchUMLClassRenderer methodsFor: 'hooks' stamp: ''!
shapeFor: aClass
	| shapes box title vars methods boxTitle |
	title := self titleFor: aClass.
	vars := self varsFor: aClass.
	methods := self methodsFor: aClass.
	shapes := self groupFor: { vars. methods }.
	shapes addFirst: title.
	box := self classBoxShapeFor: aClass.
	boxTitle := self classNameBoxFor: aClass.
	self applyLayoutOn: shapes.
	self adjustTitle: title on: shapes.
	shapes addFirst: boxTitle.
	shapes addLast: box.
	self adjustBox: box on: shapes. 
	boxTitle 
		position: box position x @ title position y ;
		extent: (box width @ title height).
	^ RSComposite new
		popup;
		draggable;
		model: aClass;
		shapes: shapes;
		yourself.! !

!RSTorchUMLClassRenderer methodsFor: 'accessing - shapes' stamp: ''!
minMethodsWidth
	^ 200! !

!RSTorchUMLClassRenderer methodsFor: 'defaults' stamp: ''!
defaultLayout
	^ super defaultLayout tree
		verticalGap: 50;
		horizontalGap: 10;
		yourself! !

!RSTorchUMLClassRenderer methodsFor: 'defaults' stamp: ''!
defaultTitleBoxColor
	^ Color colorFrom: 'AFD2EE'! !

!RSTorchUMLClassRenderer methodsFor: 'accessing' stamp: ''!
titleBoxColor
	^ titleBoxColor ifNil: [ titleBoxColor := self defaultTitleBoxColor ]! !

!RSTorchUMLClassRenderer methodsFor: 'accessing - shapes' stamp: ''!
currentMaxWidth
	^ currentTitleWidth max: self minMethodsWidth! !

!RSTorchUMLClassRenderer methodsFor: 'hooks' stamp: ''!
varFor: model
	^ RSShapeFactory triangle
		model: model;
		popup;
		size: 20;
		yourself
		! !

!RSTorchUMLClassRenderer methodsFor: 'accessing' stamp: ''!
titleBoxColor: aColor
	titleBoxColor := aColor! !

!RSTorchUMLClassRenderer methodsFor: 'hooks' stamp: ''!
classBoxShapeFor: aClass
	^ RSBox new
		noPaint;
		border: self boxBorder;
		yourself! !

!RSTransformable commentStamp: ''!
I provide element resizing in all eight directions. 

Resizing handles are displayed after clicking on an associated shape, and are automatically removed when clicked on a canvas or another shape.

!!!! Assumptions

You must provide this class with aCanvas instance or the initialized element must be already added to the canvas.

!
!RSTransformable methodsFor: 'public' stamp: ''!
disableHandles: evt
	| shape key bool |
	shape := evt shape.
	key := self key.
	bool := shape hasProperty: key.
	self removeHandles: evt.
	bool ifFalse: [ ^ self ].
	shape propertyAt: key put: #disable.! !

!RSTransformable methodsFor: 'private' stamp: ''!
saveCurrentShapeState
	| r matrix |
	currentShape ifNil: [ ^ self ].
	matrix := currentShape matrix.
	r := matrix.
	r := r sx sign @ r sy sign.
	r := currentShape extent * r / 2.
	
	baseRectangle := Rectangle basicNew
		privateSetOrigin: r negated;
		privateSetCorner: r;
		yourself.
		
	currentMatrix := matrix copy
		loadIdentity;
		translation: currentShape position.! !

!RSTransformable methodsFor: 'rectangle' stamp: ''!
topRight: position rectangle: rectangle 
	^ (rectangle origin x @ position y) -> (position x @ rectangle corner y)! !

!RSTransformable methodsFor: 'private' stamp: ''!
saveHandles: handles evt: evt
	evt canvas propertyAt: self key put: handles.! !

!RSTransformable methodsFor: 'cursor' stamp: ''!
showCursor: evt
	self setCursor: (self cursorForCorner: evt shape model value).! !

!RSTransformable methodsFor: 'rectangle' stamp: ''!
bottomLeft: position rectangle: rectangle 
	^ (position x @ rectangle origin y) -> (rectangle corner x @ position y)! !

!RSTransformable methodsFor: 'accessing - shapes' stamp: ''!
rotationShape
	"TODO"
	^ RSBitmap new
		form: (self iconNamed: #smallUpdate);
		scaleBy: 2;
		when: RSMouseEnter send: #showRotationCursor to: self;
		when: RSMouseLeave send: #removeCursor to: self;
		yourself! !

!RSTransformable methodsFor: 'rectangle' stamp: ''!
rightCenter: position rectangle: rectangle 
	^ rectangle origin -> (position x @ rectangle corner y)! !

!RSTransformable methodsFor: 'update' stamp: ''!
updateCurrentShape: evt
	| handle  newRec scale pos rect  e |
	currentShape ifNil: [ ^ self ].
	handle := evt shape.
	pos := currentMatrix rsInverseTransform: handle position.
	newRec := self 
		perform: (handle model key, ':rectangle:') asSymbol
		withArguments: { pos. baseRectangle}.
	scale := (newRec value - newRec key) / currentShape baseRectangle extent.
	
	e := Float epsilon.
	scale x abs < e ifTrue: [ scale := (e * scale x sign) @ scale y ].
	scale y abs < e ifTrue: [ scale := scale x @ (e * scale y sign) ].
	
	rect := newRec value corner: newRec key.
	rect := currentShape 
		computeEncompassingRectangleFor: (newRec key corner: newRec value)
		matrix: currentMatrix.

	currentShape matrix
		loadIdentity.
	currentShape scaleBy: scale.
	currentShape translateTo: rect floatCenter.
	
	self updateHandles: evt.
	evt signalUpdate.! !

!RSTransformable methodsFor: 'public' stamp: ''!
showHandles: evt 
	
	| parent shape handles |
	self removeHandles: evt.
	self registerCanvasEventsIfNecessary: evt.
	shape := evt shape.
	shape propertyAt: self key put: #enable.
	handles := self createHandlesFor: shape.
	
	parent := shape parent.
	parent addAll: handles.
	evt signalUpdate.
	
	
	
	
		
		
		
	
	! !

!RSTransformable methodsFor: 'rectangle' stamp: ''!
leftCenter: position rectangle: rectangle 
	^ (position x @ rectangle origin y) -> rectangle corner! !

!RSTransformable methodsFor: 'cursor' stamp: ''!
removeCursor
	self setCursor: nil
	! !

!RSTransformable methodsFor: 'rectangle' stamp: ''!
topCenter: position rectangle: rectangle 
	^ (rectangle origin x @ position y) -> rectangle corner! !

!RSTransformable methodsFor: 'accessing' stamp: ''!
cornersAndSides
	^ {
	
	#topLeft -> #topLeft.
	#topCenter -> #top.
	#topRight -> #topRight.
	#rightCenter -> #right.
	#bottomRight -> #bottomRight.
	#bottomCenter -> #bottom.
	#bottomLeft -> #bottomLeft.
	#leftCenter -> #left.}.! !

!RSTransformable methodsFor: 'public' stamp: ''!
removeHandles: evt
	| canvas key handles |
	canvas := evt canvas.
	key := self key.
	handles := canvas propertyAt: key.
	handles ifNil: [ ^ self ].
	evt shape ifNotNil: [ :s | s removeKey: key ].
	
	handles do: #remove.
	canvas removeKey: key.
	canvas signalUpdate.! !

!RSTransformable methodsFor: 'accessing' stamp: ''!
key
	^ self class name! !

!RSTransformable methodsFor: 'update' stamp: ''!
updateHandles: evt
	| canvas handles rect base points circles matrix  |
	currentShape ifNil: [ ^ self ].
	canvas := evt canvas.
	handles := canvas propertyAt: self key ifAbsent: [ ^ self ].
	rect := currentShape baseRectangle.
	base := handles first.
	circles := handles copyFrom: 2 to: handles size.
	points := Array new: circles size.
	matrix := currentShape matrix.
	circles doWithIndex: [ :h :index | | position |
		position := matrix transform: (h model key value: rect).
		h position: position.
		points at: index put: position ].
	base points: points.
	
	"TODO
	rotate := handles last.
	rotate position: (matrix transform: rect topCenter - (0@30) )."! !

!RSTransformable methodsFor: 'accessing - shapes' stamp: ''!
createHandlesFor: shape
	| handles circles |
	handles := RSGroup new.
	currentShape := shape.
	self saveCurrentShapeState.
	handles add: self boxShape.
	circles := self cornersAndSides collect: [ :sel | self createHandleFor: sel ].
	handles addAll: circles.
	"TODO
	handles add: self rotationShape."
	self saveHandles: handles evt: shape.
	self updateHandles: shape.
	^ handles.
		
	
	! !

!RSTransformable methodsFor: 'rectangle' stamp: ''!
bottomCenter: position rectangle: rectangle 
	^ rectangle origin -> (rectangle corner x @ position y)! !

!RSTransformable methodsFor: 'cursor' stamp: ''!
setCursor: cursor
	self currentWorld currentHand showTemporaryCursor: cursor! !

!RSTransformable methodsFor: 'accessing - shapes' stamp: ''!
boxShape
	^ RSPolygon new
		noPaint;
		border: (RSBorder new
			color: Color gray);
		yourself
		
	
	! !

!RSTransformable methodsFor: 'rectangle' stamp: ''!
bottomRight: position rectangle: rectangle 
	^ rectangle origin -> position! !

!RSTransformable methodsFor: 'hooks' stamp: ''!
onShape: aShape
	aShape isNode ifFalse: [ ^ self ].
	aShape announcer
		when: RSMouseLeftClick send: #showHandles: to: self;
		when: RSMouseDragStart send: #disableHandles: to: self;
		when: RSMouseDragEnd send: #enableHandles: to: self.! !

!RSTransformable methodsFor: 'public' stamp: ''!
enableHandles: evt
	| shape key |
	shape := evt shape.
	key := self key.
	(shape hasProperty: key) ifFalse: [ ^ self ].
	shape removeKey: key.
	self showHandles: evt.
	! !

!RSTransformable methodsFor: 'accessing - shapes' stamp: ''!
createHandleFor: association
	| handle |
	handle := RSEllipse new
		size: 20;
		model: association;
		color: Color white;
		border: (RSBorder new width: 5; color: Color gray);
		draggable;
		yourself.
	handle announcer
		when: RSMouseEnter send: #showCursor: to: self;
		when: RSMouseLeave send: #removeCursor to: self;
		when: RSMouseDragStart send: #saveCurrentShapeState to: self;
		when: RSPositionChangedEvent send: #updateCurrentShape: to: self.
	^ handle! !

!RSTransformable methodsFor: 'cursor' stamp: ''!
showRotationCursor
	self setCursor: Cursor webLink! !

!RSTransformable methodsFor: 'private' stamp: ''!
registerCanvasEventsIfNecessary: evt
	| canvas |
	canvas := evt canvas.
	(canvas hasInteraction: self class) ifTrue: [ ^ self ].
	canvas announcer
		when: RSMouseClick 
		send: #removeHandles:
		to: self! !

!RSTransformable methodsFor: 'rectangle' stamp: ''!
topLeft: position rectangle: rectangle 
	^ position -> rectangle corner! !

!RSTransformable methodsFor: 'cursor' stamp: ''!
cursorForCorner: aCorner
	^ Cursor perform: ('resize' , aCorner capitalized) asSymbol! !

!RSTransformableTest methodsFor: 'running' stamp: ''!
testCornerDirections
	| interaction base new |
	interaction := RSTransformable new.
	base := 20@20 corner: 100@100.
	
	new := interaction bottomRight: 10@120 rectangle: base.
	self assert: new equals: 20@20 -> (10@120).
	
	new := interaction bottomCenter: 10@120 rectangle: base.
	self assert: new equals: 20@20 -> (100@120).
	
	new := interaction bottomLeft: 0@120 rectangle: base.
	self assert: new equals: 0@20 -> (100@120).
	
	new := interaction topLeft: 0@0 rectangle: base.
	self assert: new equals: 0@0 -> (100@100).
	
	new := interaction topCenter: 50@0 rectangle: base.
	self assert: new equals: 20@0 -> (100@100).
	
	new := interaction topRight: 120@0 rectangle: base.
	self assert: new equals: 20@0 -> (120@100).
	
	new := interaction leftCenter: 0@120 rectangle: base.
	self assert: new equals: 0@20 -> (100@100).
	
	new := interaction rightCenter: 120@120 rectangle: base.
	self assert: new equals: 20@20 -> (120@100).! !

!RSTransformableTest methodsFor: 'running' stamp: ''!
testBasic
	shapes @ RSTransformable.
	! !

!RSTransformableTest methodsFor: 'running' stamp: ''!
testDrag
	| s interaction |
	interaction := RSTransformable new.
	shapes @ interaction .
	s := shapes first.
	s announce: RSMouseLeftClick new.
	self assert: (canvas propertyAt: interaction key) notNil.
	s announce: RSMouseDragStart new.
	self assert: (canvas propertyAt: interaction key) isNil.
	s announce: RSMouseDragEnd new.
	self assert: (canvas propertyAt: interaction key) notNil.! !

!RSTransformableTest methodsFor: 'running' stamp: ''!
testDrag2
	| s interaction |
	interaction := RSTransformable new.
	shapes @ interaction .
	s := shapes first.
	s announce: RSMouseDragStart new.
	self assert: (canvas propertyAt: interaction key) isNil.
	s announce: RSMouseDragEnd new.
	self assert: (canvas propertyAt: interaction key) isNil.! !

!RSTransformableTest methodsFor: 'running' stamp: ''!
testUpdateShape
	| s interaction rect handles |
	interaction := RSTransformable new.
	shapes @ interaction .
	s := shapes first.
	s announce: RSMouseLeftClick new.
	rect := s encompassingRectangle.
	handles := (canvas propertyAt: interaction key).
	self assert: handles first class equals: RSPolygon.
	handles second 
		translateTo: 10@10.
	self deny: rect equals: s encompassingRectangle.
	! !

!RSTransformableTest methodsFor: 'running' stamp: ''!
testBasic02
	| s interaction handles |
	interaction := RSTransformable new.
	shapes @ interaction .
	s := shapes first.
	s announce: RSMouseLeftClick new.
	self assert: canvas shapes size > shapes size.
	handles := canvas propertyAt: interaction key.
	self assert: handles notNil.
	self assert: handles isNotEmpty.
	
	canvas announce: RSMouseClick new.
	
	self assert: canvas shapes size equals: shapes size.
	handles := canvas propertyAt: interaction key.
	self assert: handles isNil.
	
	
	! !

!RSTransformableTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	canvas := RSCanvas new.
	shapes := (1 to: 5) 
		collect: [ :i | RSBox new size: 10; position: 10@10 * i]
		as: RSGroup.
	canvas addAll: shapes.! !

!RSTransitionAnimation commentStamp: ''!
I am an animation that provides a number interpolating between 0 and 1. and apply it the value to one block!
!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
duration: aDuration
	duration := aDuration asMilliSeconds! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
easing: anInterpolator
	easing := anInterpolator ! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
easing
	^ easing! !

!RSTransitionAnimation methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self onStepDo: [ :t | ].
	! !

!RSTransitionAnimation methodsFor: 'accessing - computed' stamp: ''!
progress 
	| progress |
	self startStep.
	progress := (self currentTime - pauseTime - startLoopTime)/ duration asFloat.
	progress > 1 ifTrue: [ 
		self loopDone.
		progress := 1.
		 ].
	
	^ progress! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
from: anObject
	scale from: anObject! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
duration
	^ Duration milliSeconds: duration! !

!RSTransitionAnimation methodsFor: 'action handling' stamp: ''!
onStepDo: aBlock
	stepAction := aBlock! !

!RSTransitionAnimation methodsFor: 'accessing - computed' stamp: ''!
progressValue: progress
	| value |
	"interpolate the progress"
	value := easing interpolate: progress.
	"apply progress to the value"
	^ self scale scale: value.! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
ramp: arrayOfAssociations
	scale := NSScale linear
		domain: (arrayOfAssociations collect: #key);
		range: (arrayOfAssociations collect: #value)! !

!RSTransitionAnimation methodsFor: 'refreshing' stamp: ''!
step 
	| value |
	value := self progressValue: self progress.
	stepAction cull: value.
	self updateHasCompleted
	
	! !

!RSTransitionAnimation methodsFor: 'action handling' stamp: ''!
on: object set: setSelector
	"Key method to set an animation. the first argument receives an object, typically a shape, a border, a line. The second argument is a selector that will be used to set the animated value. The selector must take one argument as parameter. Here is an example:

```
c := RSCanvas new.

b := RSBorder new color: Color blue.
b dashArray: #(5 1 5).
(30 to: 60) do: [ :nb |
	box := RSBox new size: nb.
	ellipse := RSEllipse new width: nb; height: nb + 10.
	box border: b.
	ellipse border: b.
	c add: box; add: ellipse.
	 ].

RSFlowLayout on: c shapes.
c @ RSControlsCanvas.

c newAnimation 
	from: 0;
	to: 40;
	on: b set: #dashOffset:.
c
```

Another example, simpler: 
```
c := RSCanvas new.

b := RSBox new size: 30.
c add: b.

c newAnimation 
	from: 0 @ 0;
	to: 100 @ 100;
	on: b set: #position:.

c
```
	"
	| sel |
	sel := setSelector asSymbol.
	self assert: [ sel numArgs = 1 ] description: [ 'The selector ', sel, ' should accept one argument' ].
	self 
		assert: (object class canUnderstand: sel) 
		description: 'Invalid input'.
	
	self onStepDo: [ :t |
		object perform: sel withArguments: { t }.
		canvas signalUpdate.
	]
	
	! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
range: aTwoArrayOfNumbers
	scale range: aTwoArrayOfNumbers! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
stepAction
	^ stepAction! !

!RSTransitionAnimation methodsFor: 'action handling' stamp: ''!
onStepDo: aBlockClosure with: anObject
	self onStepDo: [ :t | aBlockClosure value: t value: anObject ]! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
to
	^ scale range last! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
to: aValue
	scale to: aValue.! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
scale
	^ scale! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
scale: aScale
	scale := aScale! !

!RSTransitionAnimation methodsFor: 'initialization' stamp: ''!
reset
	super reset.
	self duration: self class defaultDuration.
	easing := RSLinearInterpolator new.
	scale := NSScale linear.! !

!RSTransitionAnimation methodsFor: 'accessing' stamp: ''!
from
	^ scale range first! !

!RSTransitionAnimation class methodsFor: 'accessing - defaults' stamp: ''!
defaultDuration
	^ 2 seconds! !

!RSTransitionAnimationTest commentStamp: ''!
I have test for animation in trachel!
!RSTransitionAnimationTest methodsFor: 'tests' stamp: ''!
testStepReset
	| animation |
	animation := canvas newAnimation
		duration: 100 milliSeconds.
	self runAnimation: animation threshold: 500.
	
	self deny: animation isRunning.
	self assert: animation currentLoop equals: nil.
	self assert: canvas animations size equals: 0.
	
	animation reset;
		duration: 100 milliSeconds.
	canvas addAnimation: animation.
	
	self assert: canvas animations size equals: 1.
	self runAnimation: animation threshold: 500.! !

!RSTransitionAnimationTest methodsFor: 'tests' stamp: ''!
testStep
	| value |
	value := 0.
	canvas newAnimation
		onStepDo: [ :t | value := value + 1 ].
		
	self assert: value equals: 0.
	canvas playAnimations.
	self assert: value equals: 1.! !

!RSTransitionAnimationTest methodsFor: 'tests' stamp: ''!
testTransitionAnimationCreation
	self 
		createAnimationWith: [ canvas newAnimation ]
		animationClass: RSTransitionAnimation.! !

!RSTransitionAnimationTest methodsFor: 'tests' stamp: ''!
testDuration
	| animation |
	animation := RSTransitionAnimation new duration: 2 seconds.
	self assert: animation duration equals: 2 seconds.
	self assert: animation allDuration equals: 2 seconds.
	
	animation := RSTransitionAnimation new duration: 2 seconds; loops: 5.
	self assert: animation duration equals: 2 seconds.
	self assert: animation allDuration equals: 10 seconds.
	
	animation := RSTransitionAnimation new duration: 2 seconds; repeat.
	self assert: animation duration equals: 2 seconds.
	self assert: animation allDuration equals: 2 seconds.! !

!RSTransitionAnimationTest methodsFor: 'tests' stamp: ''!
testStepEvent
	| value loop animation |
	value := nil.
	loop := 0.
	animation := canvas newAnimation
		duration: 100 milliSeconds;
		loops: 3;
		onStepDo: [ :t| value := t ];
		when: RSAnimationLoopEvent do: [ :evt | loop := loop + 1.].
	self assert: value isNil.
	self assert: loop equals: 0.
	self assert: animation endTime isNil.
	self runAnimation: animation threshold: 3000.
	self deny: value isNil.
	self assert: loop equals: 3.
	self deny: animation endTime isNil.
	self deny: animation isRunning.! !

!RSTreeLayout commentStamp: ''!
TODO!
!RSTreeLayout methodsFor: 'private - hook' stamp: ''!
computeChildrenFor: aNode
	^ self childrenFor: aNode except: alreadyLayoutedNodes! !

!RSTreeLayoutTest methodsFor: 'tests' stamp: ''!
testCycles 
	| chars |
	canvas := RSCanvas new.
	chars := $a to: $e.
	shapes := RSComposite models: chars forEach: [ :composite :char |
		| box label |
		label := RSLabel text: char.
		box := RSBox new 
			position: label position;
			extent: label extent + 10;
			yourself.
		
		composite 
			draggable;
			add: box;
			add: label;
			yourself.
		].

	canvas addAll: shapes.
	RSLineBuilder arrowedLine
		canvas: canvas;
		withVerticalAttachPoint;
		useAssociations: 
			{$a -> $b.
			$a -> $e.
			$b -> $c.
			$c -> $d.
			$d -> $a}. "cycle"
	self should: [ RSTreeLayout new validateCycles on: shapes ] raise: Error.
	RSTreeLayout new doNotValidateCycles; on: shapes
	! !

!RSTreeLayoutTest methodsFor: 'tests' stamp: ''!
testBasic
	RSTreeLayout on: canvas nodes.
	self assert: (shapes collect: #position) asArray equals: {(23.5@7.5). (15.5@32.5). (35.5@32.5). (11.5@57.5). (23.5@57.5). (31.5@57.5). (39.5@57.5). (7.5@82.5). (15.5@82.5). (23.5@82.5)}! !

!RSTreeLayoutTest methodsFor: 'tests' stamp: ''!
testBasicWithLeftGap
	| withNoGap withGap |
	RSTreeLayout new leftGap: 15; on: canvas nodes.
	withNoGap := {(23.5@7.5). (15.5@32.5). (35.5@32.5). (11.5@57.5). (23.5@57.5). (31.5@57.5). (39.5@57.5). (7.5@82.5). (15.5@82.5). (23.5@82.5)}.
	withGap := withNoGap collect: [ :p | p + (10 @ 0) ].
	self assert: (shapes collect: #position) asArray equals: withGap! !

!RSTreeLayoutTest methodsFor: 'tests' stamp: ''!
testBasicWithVerticalGap
	RSTreeLayout new verticalGap: 50; on: canvas nodes.
	self assert: (shapes collect: #position) asArray equals: {(23.5@7.5). (15.5@62.5). (35.5@62.5). (11.5@117.5). (23.5@117.5). (31.5@117.5). (39.5@117.5). (7.5@172.5). (15.5@172.5). (23.5@172.5)}! !

!RSTreeLayoutTest methodsFor: 'tests' stamp: ''!
testBasicWithHorizontalGap
	RSTreeLayout new horizontalGap: 50; on: canvas nodes.
	self assert: (shapes collect: #position) asArray equals: {(117.5@7.5). (62.5@32.5). (200.0@32.5). (35.0@57.5). (117.5@57.5). (172.5@57.5). (227.5@57.5). (7.5@82.5). (62.5@82.5). (117.5@82.5)}! !

!RSTreeLayoutTest methodsFor: 'tests' stamp: ''!
testBasicWithTopGap
	| withNoGap withGap |
	RSTreeLayout new topGap: 15; on: canvas nodes.
	withNoGap := {(23.5@7.5). (15.5@32.5). (35.5@32.5). (11.5@57.5). (23.5@57.5). (31.5@57.5). (39.5@57.5). (7.5@82.5). (15.5@82.5). (23.5@82.5)}.
	withGap := withNoGap collect: [ :p | p + (0 @ 10) ].
	self assert: (shapes collect: #position) asArray equals: withGap! !

!RSUMLAbstractBuilder commentStamp: ''!
An abstract builder for UML shapes based on a model description (like a class or package description)!
!RSUMLAbstractBuilder methodsFor: 'accessing' stamp: ''!
renderer
	^ renderer! !

!RSUMLAbstractBuilder methodsFor: 'accessing' stamp: ''!
layout
	^ renderer layout! !

!RSUMLAbstractBuilder methodsFor: 'private' stamp: ''!
defaultContainer
	^ RSCanvas new 
		addInteraction: RSCanvasController new;
		yourself.! !

!RSUMLAbstractBuilder methodsFor: 'accessing' stamp: ''!
modelDescriptor: aRSClassDescriptor
	modelDescriptor := aRSClassDescriptor.
	renderer ifNotNil: [ renderer modelDescriptor: modelDescriptor ].! !

!RSUMLAbstractBuilder methodsFor: 'accessing' stamp: ''!
renderer: aRSUMLRenderer
	renderer := aRSUMLRenderer.
	renderer modelDescriptor: modelDescriptor! !

!RSUMLAbstractBuilder methodsFor: 'hooks' stamp: ''!
shapeFor: anObject index: index
	^ self renderer shapeFor: anObject! !

!RSUMLAbstractBuilder methodsFor: 'accessing' stamp: ''!
modelDescriptor
	^ modelDescriptor! !

!RSUMLAbstractBuilder class methodsFor: 'testing' stamp: ''!
isAbstract 
	^self name = #RSUMLAbstractBuilder! !

!RSUMLAbstractModelDescriptor commentStamp: ''!
Abstract descriptor for UML artifacts!
!RSUMLAbstractModelDescriptor methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self forPharo.! !

!RSUMLAbstractModelDescriptor methodsFor: 'public' stamp: ''!
forPharo

	self subclassResponsibility ! !

!RSUMLAbstractModelDescriptor class methodsFor: 'testing' stamp: ''!
isAbstract 
	^self name = #RSUMLAbstractModelDescriptor ! !

!RSUMLCalypsoRenderer commentStamp: ''!
Specific renderer for calypso!
!RSUMLCalypsoRenderer methodsFor: 'hooks' stamp: ''!
methodFor: method
	| label icon com |
	label := super methodFor: method.
	method isTestMethod ifFalse: [ ^ label ].
	icon := RSEllipse new size: label fontSize.
	method isPassedTest ifTrue: [ icon color: Color green ].
	method isFailedTest ifTrue: [ icon color: Color yellow ].
	method isErrorTest ifTrue: [ icon color: Color red ].
	com := RSComposite new
		add: icon; 
		add: label;
		yourself.	
	RSHorizontalLineLayout new 
		alignMiddle; 
		gapSize: label fontSize / 3; 
		on: com children.
	com adjustToChildren.
	^ com! !

!RSUMLCalypsoRenderer methodsFor: 'hooks' stamp: ''!
classBoxShapeFor: aClass 
	| box alpha |
	box := super classBoxShapeFor: aClass.
	alpha := 0.3.
	aClass isTestCase ifTrue: [ 
		aClass hasPassedTest ifTrue: [ box color: Color green ].
		aClass hasFailedTest ifTrue: [ box color: Color yellow ].
		aClass hasErrorTest ifTrue: [ box color: Color red ].
		box color: (box color alpha: alpha).
		 ].
	^ box! !

!RSUMLCalypsoSettings commentStamp: ''!
Settings for UML use within Calypso!
!RSUMLCalypsoSettings class methodsFor: 'accessing - defaults' stamp: ''!
defaultLightThemeColorUMLClass

	^Color colorFrom: 'ffffce'! !

!RSUMLCalypsoSettings class methodsFor: 'accessing' stamp: ''!
initialSelectionClass: aClass
	initialSelectionClass := aClass! !

!RSUMLCalypsoSettings class methodsFor: 'settings' stamp: ''!
settingsForCalypsoUMLOn: aBuilder
	<systemsettings>
	(aBuilder group: #CalypsoUMLValues)
		parent: #useCalypsoUML;
		label: 'Capypso UML Methods' ;  
		description: 'All settings concerned with the size of variables to show';
		with: [
			(aBuilder range: #methodsLimitUML)
				target: self;
				label: 'Limit for number of methods to show in UML class';
				default: 30;
				range: ( 0 to: 200). ]! !

!RSUMLCalypsoSettings class methodsFor: 'accessing' stamp: ''!
lightThemeUMLClassColor: aColor
	lightThemeUMLClassColor := aColor! !

!RSUMLCalypsoSettings class methodsFor: 'accessing - defaults' stamp: ''!
defaultDarkThemeColorUMLClass

	^Color colorFrom: '2C3E50'! !

!RSUMLCalypsoSettings class methodsFor: 'accessing' stamp: ''!
methodsLimitUML
	^ methodsLimitUML ifNil: [ methodsLimitUML := 30 ]! !

!RSUMLCalypsoSettings class methodsFor: 'accessing' stamp: ''!
lightThemeUMLClassColor
	^ lightThemeUMLClassColor ifNil: [ self defaultLightThemeColorUMLClass ]! !

!RSUMLCalypsoSettings class methodsFor: 'accessing' stamp: ''!
darkThemeUMLClassColor: aColor
	darkThemeUMLClassColor := aColor! !

!RSUMLCalypsoSettings class methodsFor: 'accessing' stamp: ''!
methodsLimitUML: aNumber
	methodsLimitUML := aNumber! !

!RSUMLCalypsoSettings class methodsFor: 'accessing' stamp: ''!
darkThemeUMLClassColor
	^ darkThemeUMLClassColor ifNil: [ self defaultDarkThemeColorUMLClass ]! !

!RSUMLCalypsoSettings class methodsFor: 'accessing' stamp: ''!
initialSelectionClass
	^ initialSelectionClass ifNil: [ RSDancingSelection ].! !

!RSUMLCalypsoSettings class methodsFor: 'settings' stamp: ''!
settingsForCalypsoUMLColorsOn: aBuilder
	<systemsettings>
	(aBuilder group: #CalypsoUMLColors)
		parent: #useCalypsoUML;
		label: 'UML Colors' ;  
		description: 'All settings concerned with the look''n feel of your system';
		with: [
			(aBuilder setting: #lightThemeUMLClassColor)
				target: self;
				label: 'Light Theme UML Class color';
				default: self defaultLightThemeColorUMLClass.
			
			(aBuilder setting: #darkThemeUMLClassColor)
				target: self;
				label: 'Dark Theme UML Class color';
				default: self defaultDarkThemeColorUMLClass	 ]! !

!RSUMLCalypsoSettings class methodsFor: 'settings' stamp: ''!
settingsGroupOn: aBuilder
	<systemsettings>
	(aBuilder setting: #useCalypsoUML)
		label: 'Calypso UML';
		parent: #Calypso;
		default: true;
		target: self;
		description: 'Settings related to the UML within Calypso browser'.! !

!RSUMLCalypsoSettings class methodsFor: 'settings' stamp: ''!
useCalypsoUML: aBoolean
	useCalypsoUML := aBoolean! !

!RSUMLCalypsoSettings class methodsFor: 'settings' stamp: ''!
settingsForCalypsoUMLInitialSelectionOn: aBuilder
	<systemsettings>
	(aBuilder pickOne: #initialSelectionClass)
		parent: #useCalypsoUML;
		label: 'UML initial selection' ;  
		description: 'Selected a strategy when you open a class with the uml';
		target: self;
		domainValues: RSInitialSelection allSubclasses;
		default: RSDancingSelection! !

!RSUMLCalypsoSettings class methodsFor: 'settings' stamp: ''!
useCalypsoUML
	^ useCalypsoUML ifNil: [ ^ true ]! !

!RSUMLClassBuilder commentStamp: ''!
I am a builder to create UML diagrams in Roassal3, see examples!
!RSUMLClassBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		modelDescriptor: RSUMLClassDescriptor new;
		renderer: RSBasicUMLClassRenderer new! !

!RSUMLClassBuilder methodsFor: 'hooks' stamp: ''!
renderIn: aCanvas
	super renderIn: aCanvas.
	self renderer edgeBuilder
		canvas: aCanvas;
		shapes: shapes;
		connectFrom: modelDescriptor superclass.
	self layout on: shapes.
	self renderer renderAssociations.
	renderer setUpCanvas: aCanvas.
! !

!RSUMLClassBuilder methodsFor: 'accessing' stamp: ''!
classes: aColletionOfClasses
	classes := aColletionOfClasses ! !

!RSUMLClassBuilder methodsFor: 'hooks' stamp: ''!
objects
	^ classes! !

!RSUMLClassBuilder methodsFor: 'accessing' stamp: ''!
classes
	^ classes! !

!RSUMLClassBuilderTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ RSUMLClassBuilder! !

!RSUMLClassBuilderTest methodsFor: 'tests' stamp: ''!
testBasic
	| builder classes |
	classes := RSAttachPoint withAllSubclasses.
	builder := self classToTest new.
	builder classes: classes.
	builder build.
	self assert: builder shapes size equals: classes size! !

!RSUMLClassBuilderTest methodsFor: 'tests' stamp: ''!
testJustClassName
	| builder shape  |
	builder := self classToTest new.
	builder classes: {RSMouseMove}.
	builder build.
	shape := builder shapes first.
	self assert: shape shapes size equals: 2.
	self assert: shape shapes first class equals: RSBox.
	self assert: shape shapes second class equals: RSComposite.
	
	builder := self classToTest new.
	builder classes: {RSMouseMove}.
	builder renderer: RSTorchUMLClassRenderer new.
	builder build.
	shape := builder shapes first.
	self assert: shape shapes size equals: 3.
	self assert: shape shapes first class equals: RSBox.
	self assert: shape shapes second class equals: RSComposite.
	self assert: shape shapes third class equals: RSBox.! !

!RSUMLClassCalypso commentStamp: ''!
UMLClass builder for calypso is a basic calypso tab. 

## Hooks: 

- Activation, use `shouldUseUMLClassTab` to enable or disable uml tabs in your classes.
- Customize, use `createCanvasUMLWithTool:` to create a canvas for each class, if you want. By default a class uses this tool to create the uml builder!
!RSUMLClassCalypso methodsFor: 'initialization' stamp: ''!
setUpModelFromContext
	self targetClass: context lastSelectedClass! !

!RSUMLClassCalypso methodsFor: 'accessing' stamp: ''!
targetClass: aClass
	targetClass := aClass! !

!RSUMLClassCalypso methodsFor: 'initialization' stamp: ''!
defaultTitle
	^'UML-Class'! !

!RSUMLClassCalypso methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserTool
	(super isSimilarTo: anotherBrowserTool) ifFalse: [ ^false ].
	^ self targetClass = anotherBrowserTool targetClass! !

!RSUMLClassCalypso methodsFor: 'accessing' stamp: ''!
computeClasses
	| clazzes |
	clazzes := self targetClass withAllSuperAndSubclasses.
	^ clazzes copyWithoutAll: { Object. ProtoObject }.
	! !

!RSUMLClassCalypso methodsFor: 'accessing' stamp: ''!
targetClass
	^ targetClass! !

!RSUMLClassCalypso methodsFor: 'building' stamp: ''!
buildUmlCanvas
	| canvas |
	canvas := self targetClass buildUMLCanvasWithBrowserTool: self.
	canvas ifNil: [ canvas := super buildUmlCanvas ].
	RSUMLCalypsoSettings initialSelectionClass new 
		targetClass: self targetClass;
		on: canvas.
	^ canvas! !

!RSUMLClassCalypso methodsFor: 'accessing' stamp: ''!
activationPriority
	^ -200! !

!RSUMLClassCalypso class methodsFor: 'activation' stamp: ''!
classUmlTapActivation
	<classAnnotation>
	^ ClyTabActivationStrategyAnnotation for: ClyClass asCalypsoItemContext! !

!RSUMLClassCalypso class methodsFor: 'accessing' stamp: ''!
tabOrder
	^ 200! !

!RSUMLClassCalypso class methodsFor: 'testing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	^ RSUMLCalypsoSettings useCalypsoUML 
		and: [ aBrowserContext isClassSelected 
			and: [ aBrowserContext lastSelectedClass shouldUseUMLClassTab ] ].
	! !

!RSUMLClassDescriptor commentStamp: ''!
I have information about how to accessing to one class in the Roassal Uml class builder!
!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
instVars
	^ instVars! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
superclass: aSymbolOrBlock
	superclass := aSymbolOrBlock! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
methodsLimit: aNumber
	self assert: aNumber >= 1 description: 'Cannot have a negative limit'.
	methodsLimit := aNumber! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
aggregations: aCollection
	aggregations := aCollection! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
classname: aSymbolOrBlock
	"In classname N is because this method does not have relation with className method"
	classname := aSymbolOrBlock! !

!RSUMLClassDescriptor methodsFor: 'public' stamp: ''!
forPharo
	self
		classname: #name;
		instVars: [:cls | cls instVarNames sorted ];
		methods: [ :cls | cls methods sorted: CompiledMethod sortBlock ];
		isAbstract: #isAbstract;
		superclass: #superclass;
		methodSelector: #selector;
		instVarSelector: #yourself;
		methodsLimit: SmallInteger maxVal.
		! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
methods: aSymbolOrBlock
	methods := aSymbolOrBlock! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
methodSelector
	^ methodSelector! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
methodSelector: aSymbolOrBlock
	methodSelector := aSymbolOrBlock! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
instVarSelector
	^ instVarSelector! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
superclass
	^ superclass! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
compositions: aCollection
	compositions := aCollection! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
compositions
	^ compositions! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
isAbstract
	^ isAbstract! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
methods
	^ methods! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
instVars: aSymbolOrBlock
	instVars := aSymbolOrBlock! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
instVarSelector: aSymbolOrBlock
	instVarSelector := aSymbolOrBlock! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
isAbstract: aBlockOrString
	isAbstract := aBlockOrString! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
classname
	^ classname! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
methodsLimit
	^ methodsLimit! !

!RSUMLClassDescriptor methodsFor: 'accessing' stamp: ''!
aggregations
	^ aggregations! !

!RSUMLPackageBuilder commentStamp: ''!
I am a builder to create UML package diagrams in Roassal3, see examples!
!RSUMLPackageBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		modelDescriptor: RSUMLPackageDescriptor new;
		renderer: RSBasicUMLPackageRenderer new! !

!RSUMLPackageBuilder methodsFor: 'hooks' stamp: ''!
renderIn: aCanvas
	super renderIn: aCanvas.
	self layout on: shapes.! !

!RSUMLPackageBuilder methodsFor: 'accessing' stamp: ''!
packages 

	^packages ! !

!RSUMLPackageBuilder methodsFor: 'hooks' stamp: ''!
objects
	^ packages! !

!RSUMLPackageBuilder methodsFor: 'accessing' stamp: ''!
packages: aCollection

	packages := aCollection! !

!RSUMLPackageCalypso commentStamp: ''!
A browser tool for uml with packages and packages tags!
!RSUMLPackageCalypso methodsFor: 'initialization' stamp: ''!
setUpModelFromContext
	self packages: (context isClassTagSelected 
		ifTrue: [ context selectedClassGroups ]
		ifFalse: [ context selectedPackages ]).! !

!RSUMLPackageCalypso methodsFor: 'initialization' stamp: ''!
defaultTitle
	^'UML-Package'! !

!RSUMLPackageCalypso methodsFor: 'testing' stamp: ''!
isSimilarTo: anotherBrowserTool
	(super isSimilarTo: anotherBrowserTool) ifFalse: [ ^false ].
	^ self packages = anotherBrowserTool packages! !

!RSUMLPackageCalypso methodsFor: 'accessing' stamp: ''!
computeClasses
	^ self packages flatCollect: #classes.
	! !

!RSUMLPackageCalypso methodsFor: 'accessing' stamp: ''!
packages
	^ packages! !

!RSUMLPackageCalypso methodsFor: 'accessing' stamp: ''!
packages: aCollection
	packages := aCollection! !

!RSUMLPackageCalypso class methodsFor: 'activation' stamp: ''!
classUmlTapActivation
	<classAnnotation>
	^ ClyTabActivationStrategyAnnotation for: ClyClassGroup asCalypsoItemContext! !

!RSUMLPackageCalypso class methodsFor: 'activation' stamp: ''!
classUmlTapActivation2
	<classAnnotation>
	^ClyTabActivationStrategyAnnotation for: RPackage asCalypsoItemContext! !

!RSUMLPackageCalypso class methodsFor: 'accessing' stamp: ''!
tabOrder
	^ -10! !

!RSUMLPackageCalypso class methodsFor: 'accessing' stamp: ''!
shouldBeActivatedInContext: aBrowserContext
	^ RSUMLCalypsoSettings useCalypsoUML
		and: [ aBrowserContext isPackageSelected 
			and: [aBrowserContext isClassSelected not]]! !

!RSUMLPackageDescriptor commentStamp: ''!
A package descriptor!
!RSUMLPackageDescriptor methodsFor: 'accessing' stamp: ''!
classname: anObject
	classname := anObject! !

!RSUMLPackageDescriptor methodsFor: 'public' stamp: ''!
forPharo
	self
		packagename: #name;
		classes: [:pkg| pkg definedClasses sorted: Behavior sortBlock ];
		classname: #name! !

!RSUMLPackageDescriptor methodsFor: 'accessing' stamp: ''!
packagename
	^ packagename! !

!RSUMLPackageDescriptor methodsFor: 'accessing' stamp: ''!
classes: anObject
	classes := anObject! !

!RSUMLPackageDescriptor methodsFor: 'accessing' stamp: ''!
packagename: anObject
	packagename := anObject! !

!RSUMLPackageDescriptor methodsFor: 'accessing' stamp: ''!
classname
	^ classname! !

!RSUMLPackageDescriptor methodsFor: 'accessing' stamp: ''!
classes
	^ classes! !

!RSUnHighlightEvent commentStamp: ''!
I am a basic event when RSHightlightable needs to unhighlight an element!
!RSUserInputEvent commentStamp: ''!
for user input events!
!RSUserInputEvent methodsFor: 'modifier state' stamp: ''!
altKeyPressed
	"Answer true if the alt/option key on the keyboard was being held down when this event occurred."

	^ self optionKeyPressed! !

!RSUserInputEvent methodsFor: 'modifier state' stamp: ''!
shiftPressed
	"Answer true if the shift key on the keyboard was being held down when this event occurred.
	This method is here for Morphic compatibility"

	^ self shiftKeyPressed! !

!RSUserInputEvent methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	commandKeyPressed := false.
	controlKeyPressed := false.
	optionKeyPressed := false.
	shiftKeyPressed := false! !

!RSUserInputEvent methodsFor: 'private - accessing' stamp: ''!
shiftKeyPressed: aBoolean
	shiftKeyPressed := aBoolean! !

!RSUserInputEvent methodsFor: 'modifier state' stamp: ''!
anyModifierKeyPressed
	"Answer true if command, option/alt or control key on the keyboard was being held down when this event occurred. Ignores shift key."

	^ self commandKeyPressed or: [ self optionKeyPressed or: [ self controlKeyPressed ] ]! !

!RSUserInputEvent methodsFor: 'private - accessing' stamp: ''!
optionKeyPressed: aBoolean
	optionKeyPressed := aBoolean! !

!RSUserInputEvent methodsFor: 'modifier state' stamp: ''!
controlKeyPressed
	"Answer true if the control key on the keyboard was being held down when this event occurred."

	^ controlKeyPressed! !

!RSUserInputEvent methodsFor: 'private - accessing' stamp: ''!
modifiers: modifiers
	commandKeyPressed := modifiers anyMask: 2r01000000.
	controlKeyPressed := modifiers anyMask: 2r00010000.
	optionKeyPressed := modifiers anyMask: 2r00100000.
	shiftKeyPressed := modifiers anyMask: 2r00001000! !

!RSUserInputEvent methodsFor: 'private - accessing' stamp: ''!
commandKeyPressed: aBoolean
	commandKeyPressed := aBoolean! !

!RSUserInputEvent methodsFor: 'modifier state' stamp: ''!
shiftKeyPressed
	"Answer true if the shift key on the keyboard was being held down when this event occurred"

	^ shiftKeyPressed! !

!RSUserInputEvent methodsFor: 'modifier state' stamp: ''!
commandKeyPressed
	"Answer true if the command key on the keyboard was being held down when this event occurred."

	^ commandKeyPressed! !

!RSUserInputEvent methodsFor: 'private - accessing' stamp: ''!
controlKeyPressed: aBoolean
	controlKeyPressed := aBoolean! !

!RSUserInputEvent methodsFor: 'modifier state' stamp: ''!
optionKeyPressed
	"Answer true if the alt/option key on the keyboard was being held down when this event occurred."

	^ optionKeyPressed! !

!RSUserInputEvent class methodsFor: 'instance creation' stamp: ''!
fromEvent: aUserInputEvent
	^ self new
		commandKeyPressed: aUserInputEvent commandKeyPressed;
		controlKeyPressed: aUserInputEvent controlKeyPressed;
		shiftKeyPressed: aUserInputEvent shiftPressed;
		optionKeyPressed: aUserInputEvent optionKeyPressed;
		yourself! !

!RSVanDerPloegTreeLayout commentStamp: ''!
I am the vertical tree layout algorithm described in the publication "Drawing non-layered tidy trees in linear time" by Atze van der Ploeg [1] (companion repo at [2]).

I use the trait `RSTWalkBasedRegularTreeLayout` to get the main behavior and fullfil the explicit requirements to have a tree layout growing toward the vertical dimension.

[1]: https://www.semanticscholar.org/paper/Drawing-non-layered-tidy-trees-in-linear-time-Ploeg/d45f66231e053590c64c9d901fb7b028dbc5c923
[2]: https://github.com/cwi-swat/non-layered-tidy-trees!
!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
mselOf: aNode put: aFloat

	^ aNode propertyAt: #msel put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
separate: v children: children at: i rest: aValueLink

	| sr cl mssr mscl ih |
	"Right contour node of left siblings and its sum of modfiers."
	sr := children at: i - 1.
	mssr := self modOf: sr.

	"Left contour node of current subtree and its sum of modfiers."
	cl := children at: i.
	mscl := self modOf: cl.

	"Looping"
	ih := aValueLink.
	[ sr isNotNil and: [ cl isNotNil ] ] whileTrue: [ 
		| dist sy cy |
		(self depthBoundOf: sr) > (self lowYofIYL: ih) ifTrue: [ 
			ih := ih nextLink ].

		"How far to the left of the right side of sr is the left side of cl?"
		dist := mssr + (self prelimOf: sr) + (self breadthMeasureOf: sr)
		        + (self breadthGapAmong: sr and: cl) - mscl
		        - (self prelimOf: cl).

		dist > 0 ifTrue: [ 
			mscl := mscl + dist.
			self
				moveSubtree: children
				at: i
				other: (self indexOfIYL: ih)
				distance: dist ].

		"Advance highest node(s) and sum(s) of modifiers (Coordinate system increases downwards)"
		sy := self depthBoundOf: sr.
		cy := self depthBoundOf: cl.

		sy <= cy ifTrue: [ 
			sr := self nextRightContour: sr.
			sr ifNotNil: [ mssr := mssr + (self modOf: sr) ] ].

		sy >= cy ifTrue: [ 
			cl := self nextLeftContour: cl.
			cl ifNotNil: [ mscl := mscl + (self modOf: cl) ] ] ].

	"Set threads and update extreme nodes."
	(sr isNil and: [ cl isNotNil ])
		ifTrue: [ "the current subtree must be taller than the left siblings."
			self
				setLeftThread: v
				leftMostChild: children first
				currentChild: (children at: i)
				child: cl
				acc: mscl ]
		ifFalse: [ "the left siblings must be taller than the current subtree."
			(sr isNotNil and: [ cl isNil ]) ifTrue: [ 
				self
					setRightThread: v
					previousChild: (children at: i - 1)
					currentChild: (children at: i)
					child: sr
					acc: mssr ] ]! !

!RSVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
mselOf: aNode update: aBlock

	^ self mselOf: aNode put: (aBlock value: (self mselOf: aNode))! !

!RSVanDerPloegTreeLayout methodsFor: 'accessing' stamp: ''!
verticalGap

	self explicitRequirement! !

!RSVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
shiftOf: aNode update: aBlock

	^ self shiftOf: aNode put: (aBlock value: (self shiftOf: aNode))! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
completedInitializationOf: aNode

	^ aNode propertyAt: #vdpInitialized put: true! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
elOf: aNode put: aFloat

	^ aNode propertyAt: #el put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
firstWalk: v

	self
		is: v
		ifLeaf: [ self setExtremesOfLeaf: v ]
		ifNotLeaf: [ :children | 
			| leftMostChild rightMostChild chain bound |
			leftMostChild := children first.
			rightMostChild := children last.

			"Recur down on v's leftmost child."
			self firstWalk: leftMostChild.

			"Create siblings in contour minimal vertical coordinate and index list."
			bound := self depthBoundOf: (self elOf: leftMostChild).

			chain := (2 to: children size)
				         inject: (self updateIYL: bound at: 1 rest: nil)
				         into: [ :ih :i | 
					         | child |
					         child := children at: i.

					         self firstWalk: child.

					         bound := self depthBoundOf: (self erOf: child).

					         "/Store lowest vertical coordinate while extreme nodes still point in current subtree."
					         self
						         separate: v
						         children: children
						         at: i
						         rest: ih.

					         "Update data about the widths"
					         self updateIYL: bound at: i rest: ih ].

			self
				positionRoot: v
				leftMostChild: leftMostChild
				rightMostChild: rightMostChild.

			self
				setExtremesOfNonLeaf: v
				leftMostChild: leftMostChild
				rightMostChild: rightMostChild ]! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
setExtremesOfNonLeaf: v leftMostChild: leftMostChild rightMostChild: rightMostChild

	self
		elOf: v put: (self elOf: leftMostChild);
		erOf: v put: (self erOf: rightMostChild);
		mselOf: v put: (self mselOf: leftMostChild);
		mserOf: v put: (self mserOf: rightMostChild)! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
secondWalk: aShape depth: n breadth: m

	| mNext children depth breadth position |
	mNext := m + (self modOf: aShape).

	depth := n + (self depthOf: aShape).
	breadth := (self prelimOf: aShape) + mNext.

	position := self
		            positionOfShape: aShape
		            atDepth: depth
		            atBreadth: breadth.
	self positionOf: aShape put: position.

	children := self childrenOf: aShape.

	self addChildSpacing: children.

	"Recur over my onw children."
	children do: [ :aChild | 
		self secondWalk: aChild depth: n breadth: mNext ]! !

!RSVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
prelimOf: aNode update: aBlock

	^ self prelimOf: aNode put: (aBlock value: (self prelimOf: aNode))! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
mselOf: aNode

	^ aNode propertyAt: #msel! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
nextRightContour: v

	^ self
		  is: v
		  ifLeaf: [ self rthreadOf: v ]
		  ifNotLeaf: [ (self childrenOf: v) last ]! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
setExtremesOfLeaf: v

	self
		elOf: v put: v;
		erOf: v put: v;
		mselOf: v put: 0;
		mserOf: v put: 0! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
depthOf: aNode

	^ aNode propertyAt: #depth! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
threadOf: aNode put: aFloat

	^ aNode propertyAt: #thread put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
changeOf: aNode put: aFloat

	^ aNode propertyAt: #change put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
is: aShape ifLeaf: lBlock ifNotLeaf: nlBlock

	^ (self childrenOf: aShape) ifEmpty: lBlock ifNotEmpty: nlBlock! !

!RSVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
changeOf: aNode update: aBlock

	^ self changeOf: aNode put: (aBlock value: (self changeOf: aNode))! !

!RSVanDerPloegTreeLayout methodsFor: 'positioning' stamp: ''!
depthMeasureOf: aShape

	^ aShape height! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
modOf: aNode

	^ aNode propertyAt: #mod! !

!RSVanDerPloegTreeLayout methodsFor: 'positioning' stamp: ''!
depthGapAmong: aShapeParent and: aShape

	^ self
		  verticalGapAmong: aShapeParent
		  and: aShape
		  default: RSAbstractGraphLayout verticalGap! !

!RSVanDerPloegTreeLayout methodsFor: 'gap' stamp: ''!
verticalGapAmong: aShapeParent and: aShape default: anObject

	| gap |
	gap := self verticalGap.

	^ [ gap value: aShapeParent value: aShape value: anObject ]
		  onDNU: #value:value:value:
		  do: [ gap ]! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
moveSubtree: children at: i other: si distance: dist

	"Move subtree by changing mod."

	| child intermediateChildren |
	child := children at: i.

	self
		modOf: child update: [ :mod | mod + dist ];
		mselOf: child update: [ :msel | msel + dist ];
		mserOf: child update: [ :mser | mser + dist ].

	"Are there intermediate children? (originally extracted in the `distributedExtra` function)"
	self assert: i > si.

	(intermediateChildren := i - si) > 1 ifTrue: [ 
		| siChild ratio |
		ratio := dist / intermediateChildren.
		siChild := children at: si + 1.
		self
			shiftOf: siChild update: [ :shift | shift + ratio ];
			shiftOf: child update: [ :shift | shift - ratio ];
			changeOf: child update: [ :change | change - dist + ratio ] ]! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
erOf: aNode

	^ aNode propertyAt: #er! !

!RSVanDerPloegTreeLayout methodsFor: 'hook-private' stamp: ''!
layout: rootNodes atPoint: aPoint atLayer: aLayer

	^ self layout: root depth: aPoint y breadth: aPoint x! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
levelOf: aNode put: aFloat

	^ aNode propertyAt: #vdpLevel put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
modOf: aNode update: aBlock

	^ self modOf: aNode put: (aBlock value: (self modOf: aNode))! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
prelimOf: aNode

	^ aNode propertyAt: #prelim! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
nextLeftContour: v

	^ self
		  is: v
		  ifLeaf: [ self threadOf: v ]
		  ifNotLeaf: [ (self childrenOf: v) first ]! !

!RSVanDerPloegTreeLayout methodsFor: 'positioning' stamp: ''!
breadthGapAmong: aShapeParent and: aShape

	^ self
		  horizontalGapAmong: aShapeParent
		  and: aShape
		  default: RSAbstractGraphLayout horizontalGap! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
childrenOf: aNode

	^ aNode propertyAt: #children! !

!RSVanDerPloegTreeLayout methodsFor: 'gap' stamp: ''!
horizontalGapAmong: aShapeParent and: aShape default: anObject

	| gap |
	gap := self horizontalGap.

	^ [ gap value: aShapeParent value: aShape value: anObject ]
		  onDNU: #value:value:value:
		  do: [ gap ]! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
rthreadOf: aNode

	^ aNode propertyAt: #rthread! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
hasBeenInitializedOf: aNode

	^ aNode propertyAt: #vdpInitialized ifAbsent: [ false ]! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
mserOf: aNode

	^ aNode propertyAt: #mser! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
positionOf: aShape put: aPoint

	^ aShape position: aPoint! !

!RSVanDerPloegTreeLayout methodsFor: 'positioning' stamp: ''!
positionOfShape: aShape atDepth: depth atBreadth: breadth

	| shift |
	shift := aShape extent / 2.
	^ breadth @ depth + shift! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
updateIYL: minY at: i rest: aValueLink

	| ih |
	"Remove siblings that are hidden by the new subtree."
	ih := aValueLink.
	[ ih isNotNil and: [ minY >= (self lowYofIYL: ih) ] ] whileTrue: [ 
		ih := ih nextLink ].

	"Prepend the new subtree"
	^ ValueLink new
		  value: i -> minY;
		  nextLink: ih;
		  yourself! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
threadOf: aNode

	^ aNode propertyAt: #thread! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
setLeftThread: v leftMostChild: leftMostChild currentChild: child child: cl acc: mscl

	| li diff |
	li := self elOf: leftMostChild.
	self threadOf: li put: cl.

	"Change mod so that the sum of modifier after following thread is correct."
	diff := mscl - (self modOf: cl) - (self mselOf: leftMostChild).
	self modOf: li update: [ :mod | mod + diff ].

	"Change preliminary x coordinate so that the node does not move."
	self prelimOf: li update: [ :prelim | prelim - diff ].

	"Update extreme node and its sum of modifiers."
	self
		elOf: leftMostChild put: (self elOf: child);
		mselOf: leftMostChild put: (self mselOf: child)! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
erOf: aNode put: aFloat

	^ aNode propertyAt: #er put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
elOf: aNode

	^ aNode propertyAt: #el! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
modOf: aNode put: aFloat

	^ aNode propertyAt: #mod put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
depthOf: aNode put: aFloat

	^ aNode propertyAt: #depth put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
levelOf: aNode

	^ aNode propertyAt: #vdpLevel! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
rthreadOf: aNode put: aFloat

	^ aNode propertyAt: #rthread put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'updating properties' stamp: ''!
mserOf: aNode update: aBlock

	^ self mserOf: aNode put: (aBlock value: (self mserOf: aNode))! !

!RSVanDerPloegTreeLayout methodsFor: 'API' stamp: ''!
layout: aRootShape depth: aDepth breadth: aBreadth

	self
		firstWalk: aRootShape;
		secondWalk: aRootShape depth: aDepth breadth: aBreadth! !

!RSVanDerPloegTreeLayout methodsFor: 'initialization' stamp: ''!
initialize: elements lineEdges: aGroupOfLines

	| associations |
	associations := aGroupOfLines collect: [ :line | line from -> line to ].
	^ self initialize: elements associationEdges: associations! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
depthBoundOf: aShape

	^ (self depthOf: aShape) + (self depthMeasureOf: aShape)! !

!RSVanDerPloegTreeLayout methodsFor: 'initialization' stamp: ''!
initializeForShape: aShape fathers: fathers

	| depth |
	self
		modOf: aShape put: 0;
		changeOf: aShape put: 0;
		shiftOf: aShape put: 0;
		prelimOf: aShape put: 0;
		mselOf: aShape put: 0;
		mserOf: aShape put: 0;
		threadOf: aShape put: nil;
		rthreadOf: aShape put: nil;
		elOf: aShape put: nil;
		erOf: aShape put: nil.

	depth := fathers
		         at: aShape
		         ifPresent: [ :parents | 
			         | level |
			         parents
				         reject: [ :each | self hasBeenInitializedOf: each ]
				         thenDo: [ :each | 
				         self initializeForShape: each fathers: fathers ].

			         level := (parents collect: [ :each | self levelOf: each ])
				                  max.

			         self levelOf: aShape put: level + 1.

			         (parents collect: [ :aShapeParent | 
				          (self depthBoundOf: aShapeParent)
				          + (self depthGapAmong: aShapeParent and: aShape) ]) max ]
		         ifAbsent: [ self levelOf: aShape put: 0 ].

	self
		depthOf: aShape put: depth;
		completedInitializationOf: aShape.

	^ aShape! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
childrenOf: aNode put: aValue

	^ aNode propertyAt: #children put: aValue! !

!RSVanDerPloegTreeLayout methodsFor: 'initialization' stamp: ''!
initialize: elements associationEdges: associations

	| hierarchy roots fathers rootNode leaves |
	hierarchy := IdentityDictionary new.
	roots := IdentitySet withAll: elements.
	leaves := IdentitySet withAll: elements.
	fathers := IdentityDictionary new.

	associations do: [ :anAssociation | 
		| children child father multipleParents fathersOfChild |
		father := anAssociation key.
		child := anAssociation value.

		multipleParents := false.
		roots remove: child ifAbsent: [ multipleParents := true ].

		leaves
			remove: father
			ifAbsent: [ "is it okay to try to remove father more than one time"
			 ].

		fathersOfChild := fathers
			                  at: child
			                  ifAbsentPut: [ OrderedCollection new ].

		fathersOfChild add: father.

		children := hierarchy
			            at: father
			            ifAbsentPut: [ 
			            self childrenOf: father put: OrderedCollection new ].

		multipleParents ifFalse: [ children add: child ] ].

	rootNode := roots size > 1
		        ifTrue: [ 
			        roots collect: [ :each | 
				        self assert: (fathers includesKey: each) not
				        "fathers at: each put: { rootBox }" ].

			        RSComposite new
				        in: [ :aRootShape | 
					        self childrenOf: aRootShape put: roots asArray ];
				        yourself ]
		        ifFalse: [ roots anyOne ].

	leaves do: [ :each | 
		self
			assert: (self childrenOf: each) isNil;
			childrenOf: each put: Array empty;
			initializeForShape: each fathers: fathers ].

	^ self initializeForShape: rootNode fathers: fathers! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
setRightThread: v previousChild: previousChild currentChild: currentChild child: sr acc: mssr

	| ri diff |
	ri := self erOf: currentChild.
	self rthreadOf: ri put: sr.

	"Change mod so that the sum of modifier after following thread is correct."
	diff := mssr - (self modOf: sr) - (self mserOf: currentChild).
	self modOf: ri update: [ :mod | mod + diff ].

	"Change preliminary x coordinate so that the node does not move."
	self prelimOf: ri update: [ :prelim | prelim - diff ].

	"Update extreme node and its sum of modifiers."
	self
		erOf: currentChild put: (self erOf: previousChild);
		mserOf: currentChild put: (self mserOf: previousChild)! !

!RSVanDerPloegTreeLayout methodsFor: 'accessing' stamp: ''!
horizontalGap

	self explicitRequirement! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
lowYofIYL: aValueLink

	| anAssoc |
	anAssoc := aValueLink value.
	^ anAssoc value! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
shiftOf: aNode put: aFloat

	^ aNode propertyAt: #shift put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'hook' stamp: ''!
doInitialize: elements

	super doInitialize: elements.

	root := self initialize: elements lineEdges: self edges! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
prelimOf: aNode put: aFloat

	^ aNode propertyAt: #prelim put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
mserOf: aNode put: aFloat

	^ aNode propertyAt: #mser put: aFloat! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
addChildSpacing: children

	^ children inject: 0 @ 0 into: [ :aPoint :child | 
		  | x newPoint y |
		  x := aPoint x + (self shiftOf: child).
		  y := x + aPoint y + (self changeOf: child).
		  newPoint := Point x: x y: y.
		  self modOf: child update: [ :mod | mod + newPoint y ].
		  newPoint ]! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
shiftOf: aNode

	^ aNode propertyAt: #shift! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
positionRoot: v leftMostChild: leftMostChild rightMostChild: rightMostChild

	| childrenPrelim |
	"Set the prelim for hierarchy item v."
	childrenPrelim := (self prelimOf: leftMostChild)
	                  + (self modOf: leftMostChild)
	                  + (self prelimOf: rightMostChild)
	                  + (self modOf: rightMostChild)
	                  + (self breadthMeasureOf: rightMostChild)
	                  - (self breadthMeasureOf: v).

	self prelimOf: v put: childrenPrelim / 2! !

!RSVanDerPloegTreeLayout methodsFor: 'properties' stamp: ''!
changeOf: aNode

	^ aNode propertyAt: #change! !

!RSVanDerPloegTreeLayout methodsFor: 'positioning' stamp: ''!
breadthMeasureOf: aShape

	^ aShape width! !

!RSVanDerPloegTreeLayout methodsFor: 'algorithm' stamp: ''!
indexOfIYL: aValueLink

	| anAssoc |
	anAssoc := aValueLink value.
	^ anAssoc key! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RSVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RSVanDerPloegTreeLayout class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RSVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RSVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RSVanDerPloegTreeLayout class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RSVanDerPloegTreeLayout class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSVanDerPloegTreeLayout class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RSVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RSVanDerPloegTreeLayout class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RSVanDerPloegTreeLayout class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RSVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RSVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RSVanDerPloegTreeLayout class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RSVanDerPloegTreeLayout class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RSVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RSVanDerPloegTreeLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RSVanDerPloegTreeLayout class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RSVanDerPloegTreeLayout class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RSVariableTimer commentStamp: ''!
This roassal timer, changes the time depending the user's needs. Ideally you add time when you complete a task with the canvas!
!RSVariableTimer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	currentTime := RSDefaultTimer new currentTime.! !

!RSVariableTimer methodsFor: 'public' stamp: ''!
addTime: aDuration
	currentTime := currentTime + aDuration asMilliSeconds.! !

!RSVariableTimer methodsFor: 'public' stamp: ''!
currentTime
	^ currentTime! !

!RSVerticalAttachPoint commentStamp: ''!
Vertical attach points between elements when drawing lines. Useful for (vertical) tree layout

-=-=-=-=
c := RSCanvas new.

shapes := (30 to: 50) collect: [ :nb |
	RSEllipse new size: nb; model: nb; yourself.
	 ] as: RSGroup.

c addAll: shapes.

lines := RSEdgeBuilder line
	canvas: c;
	connectFrom: 30 toAll: (31 to: 50).

lines do: [ :l | l attachPoint: (RSVerticalAttachPoint new) ].

RSGridLayout on: shapes. 
RSLocation new
	above;
	move: shapes first on: shapes allButFirst.
shapes @ RSDraggable.

c @ RSControlsCanvas
-=-=-=-=!
!RSVerticalAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicEndingPointOf: anEdge
	^ self 
		positionFor: anEdge to 
		in: anEdge 
		point: anEdge to encompassingRectangle topCenter + (0@endOffset)! !

!RSVerticalAttachPoint methodsFor: 'public - hooks' stamp: ''!
basicStartingPointOf: anEdge
	^ self 
		positionFor: anEdge from
		in: anEdge 
		point: anEdge from encompassingRectangle bottomCenter + (0@startOffset)! !

!RSVerticalCPAPController commentStamp: ''!
I can return the control points for vertical lines

```
v := RSCanvas new.
	
	e1 := RSBox new size: 100; color: Color blue.
	e2 := RSBox new size: 100; color: Color red.
	e1 translateTo: 100 @ -200.

	e1 @ RSDraggable.
	e2 @ RSDraggable.
	v
		add: e1;
		add: e2.
	
	l := RSBezier new
		withVerticalAttachPoint;
		from: e1;
		to: e2;
		controlPointsController: (RSVerticalCPAPController new);
		yourself.
	v add: l.
	v open
```!
!RSVerticalCPAPController methodsFor: 'hooks' stamp: ''!
controlPointsFrom: from to: to
	| mid |
	mid := (from + to)/2.
	^ Array
		with: from
		with: from x @ mid y
		with: to x @ mid y
		with: to! !

!RSVerticalGridLayout commentStamp: ''!
RSVerticalGridLayout places shapes as a grid. Shapes keeps their order, from top to down, and then left to right.

Here is an example

```
c := RSCanvas new.

shapes := RSLabel models: (1 to: 9).
c addAll: shapes.
RSVerticalGridLayout on: shapes.
c @ RSCanvasController
```!
!RSVerticalGridLayout methodsFor: 'hook' stamp: ''!
doExecute: shapes
	| pointer lineItemCount lineItemSize maxLastLineWidth originalGapLeft originalGapTop |
	originalGapLeft := 0.
	originalGapTop := 0.
	
	pointer := originalGapLeft @ originalGapTop.
	lineItemSize := self lineItemsCountBlock rsValue: shapes.
	lineItemCount := 0.
	maxLastLineWidth := 0.

	shapes
		do: [ :aShape | 
			translator translateTopLeftOf: aShape to: pointer.
			pointer := pointer x @ (pointer y + aShape height + self gapSize).
			lineItemCount := lineItemCount + 1.
			maxLastLineWidth := maxLastLineWidth max: aShape width.
			lineItemCount >= lineItemSize
				ifTrue: [ 
					pointer := (pointer x + (self gapSize) + maxLastLineWidth) @ originalGapLeft.
					
					maxLastLineWidth := 0.
					lineItemCount := 0 ].
			self step ].
! !

!RSVerticalGridLayoutTest methodsFor: 'tests' stamp: ''!
testBasic

	RSVerticalGridLayout on: canvas nodes.
	self assert: (shapes collect: #position) asArray equals: {(2.5@2.5). (2.5@12.5). (2.5@22.5). (2.5@32.5). (12.5@2.5). (12.5@12.5). (12.5@22.5). (12.5@32.5). (22.5@2.5). (22.5@12.5)}! !

!RSVerticalLineLayout commentStamp: ''!
A RTVerticalLineLayout locates all the elements vertically!
!RSVerticalLineLayout methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self alignLeft! !

!RSVerticalLineLayout methodsFor: 'alignment' stamp: ''!
alignRight
	alignment := #right! !

!RSVerticalLineLayout methodsFor: 'hook' stamp: ''!
deltaFor: aNodeFigure
	| delta |
	delta := 0.
	self alignment == #right ifTrue: [delta := aNodeFigure width].
	self alignment == #center ifTrue: [delta := aNodeFigure width / 2.0].
	^delta @ 0! !

!RSVerticalLineLayout methodsFor: 'alignment' stamp: ''!
alignCenter
	"Make the element centered"
	alignment := #center! !

!RSVerticalLineLayout methodsFor: 'hook' stamp: ''!
movePointer: pointer accordingToFigure: aNodeFigure
	^ pointer x @ (pointer y + aNodeFigure height + self verticalGap)! !

!RSVerticalLineLayout methodsFor: 'hook' stamp: ''!
positionOriginalPointer: elements 
	| maxWidth delta |
	delta := 0.
	self alignment == #right ifTrue: 
		[ maxWidth := elements maxValue: #width.
		delta := maxWidth ].
	self alignment == #center ifTrue: 
		[ maxWidth := elements maxValue: #width.
		delta := maxWidth / 2.0 ].
	^ ((0) + delta) @ (0)
! !

!RSVerticalLineLayout methodsFor: 'alignment' stamp: ''!
alignLeft
	alignment := #left! !

!RSVerticalRightTick commentStamp: ''!
Similar to vertical tick and hortizonal top tick!
!RSVerticalRightTick methodsFor: 'rendering' stamp: ''!
createTickLineFor: aNumber
	| scaledNumber x |
	scaledNumber := yScale scale: aNumber.
	x := chart extent x.
	^ self shape copy
		startPoint: x @ scaledNumber;
		endPoint: (x + self configuration tickSize) @ scaledNumber;
		yourself! !

!RSVerticalRightTick methodsFor: 'accessing - defaults' stamp: ''!
defaultLabelLocation
	^ RSLocation new outer; right; offset: 2@0! !

!RSVerticalRightTick methodsFor: 'accessing' stamp: ''!
min
	^ values min! !

!RSVerticalRightTick methodsFor: 'accessing' stamp: ''!
values

	^ values! !

!RSVerticalRightTick methodsFor: 'accessing' stamp: ''!
values: anObject

	values := anObject! !

!RSVerticalRightTick methodsFor: 'accessing' stamp: ''!
max
	^ values max! !

!RSVerticalTick commentStamp: ''!
<keyClass>
`RSVerticalTick` defines ticks for the vertical axis. It is a decoration that can be added to a `RSChart`.

*Responsibility*: define, customize, and render ticks

*Collaborators*: `RSVerticalTick` is added to `RSChart`

*Example*:
```Smalltalk
	x := -3.14 to: 3.14 by: 0.01.
	c := RSChart new.
	p := RSLinePlot new.
	p x: x y: x sin * 0.22 + 0.5.
	c addPlot: p.
	c addDecoration: RSHorizontalTick new.
	c addDecoration: RSVerticalTick new asFloat.
	c
```!
!RSVerticalTick methodsFor: 'rendering' stamp: ''!
createTickLineFor: aNumber
	| scaledNumber |
	scaledNumber := yScale scale: aNumber.
	^ self shape copy
		startPoint: 0 @ scaledNumber;
		endPoint: self configuration tickSize negated @ scaledNumber;
		yourself! !

!RSVerticalTick methodsFor: 'rendering' stamp: ''!
createNiceLabelIn: aChart
	| nice |
	nice := super createNiceLabelIn: aChart.
	aChart 
		minValueY: nice min;
		maxValueY: nice max.
	^ nice! !

!RSVerticalTick methodsFor: 'accessing - defaults' stamp: ''!
defaultLabelLocation
	^ RSLocation new outer; left; offset: -2@0! !

!RSVerticalTick methodsFor: 'accessing' stamp: ''!
min
	^ chart minValueY! !

!RSVerticalTick methodsFor: 'accessing' stamp: ''!
max
	^ chart maxValueY! !

!RSWeightedCircleLayout commentStamp: ''!
RTWeightedCircleLayout is a circle layout that gives more space to big elements and fewer space to small elements.

Here is an example:
-=-=-=-=-=-=-=-=-=-=-=-=
v := RSView new.
elements := (RSShapeBuilder circle size: 5; color: Color red; size: [:vv | vv * 4 ]) elementsOn: (1 to: 15).
v addAll: elements.
RSWeightedCircleLayout on: elements.
v @ RSControlsView.
v open
-=-=-=-=-=-=-=-=-=-=-=-=!
!RSWeightedCircleLayout methodsFor: 'hook' stamp: ''!
doExecute: elements
	| angle rad center angleIncrement |
	rad := self computeRadiusFor: elements.
	center := Point x: rad y: rad.
	angleIncrement := self computeIncrementalAngleFor: elements.
	angle := self initialAngle.
	elements
		do: [ :each | 
			| point fctr |
			"The factor weighs the angleIncrement"
			"The angle is increased by half of the total increment,
			then the point is set, and then it's increased by the other half"
			"This is to consider both last and next elements weights"
			fctr := (elements size)*(each height)/(self weightSum: elements).
			angle := angle + (angleIncrement*(fctr/2)).
			point := center + (Point r: rad theta: angle).
			angle := angle + (angleIncrement*(fctr/2)).
			translator translate: each to: point. ]! !

!RSWorldMenu commentStamp: ''!
I am have the menu items for the menu Roassal3 on Tools!
!RSWorldMenu class methodsFor: 'menu' stamp: ''!
menu07LoadFullVersionOn: aBuilder

	<worldMenu>
	(aBuilder item: #Roassal3LoadFullVersion)
		parent: #Roassal3;
		order: 5;
		label: 'Load full version';
		help: 'Load full version of Roassal';
		icon: self roassalIcon;
		action: [ self loadFullVersion ]! !

!RSWorldMenu class methodsFor: 'menu' stamp: ''!
loadFullVersion
	[Metacello new
		baseline: 'Roassal3';
		repository: 'github://ObjectProfile/Roassal3';
		load: 'Full' ] on: MCMergeOrLoadWarning do: [:warning | warning load ]! !

!RSWorldMenu class methodsFor: 'streams' stamp: ''!
roassalIconStream
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAABMUlEQVQ4T2NkoBAwgvS/sAr5D6LNi6MZ/v39z/D3LwPD3z8MEPrvf4b3ycFgddgAwoD/DF8ljq/hkV217v/jsCC4BsG5a/+DDPuUjt0QDJPRDQDZyjdz7f9/fxkYvmRhGkKUASBDeKat/U/QAPm1ayX//WV8huwFmL8JGqC0cT3Yr8iB+DIWEhZEeQFkwD3/QEZYGIgvXvf/4vRlDJrJkeAYIRiIIAP+/f2//u8fhsC//xi+/f3NwAUyAAQkjq3BH40wf8qvBRsCjv9nkUGML6zDKjWTwtsIpgPkBIItHVBuAO9fdoawsF8wi17ahAb+//d/HchrRKUDUCwgByIs6WMY8NIq5Pd/BgYW9ECDRSMkf0DzSkkI2HIUFyCbjC3jcE5e++R7brAMshzO6CE2lwMAVKG/Eb0e33UAAAAASUVORK5CYII='! !

!RSWorldMenu class methodsFor: 'utility' stamp: ''!
loadFullStableVersion

	[ 
	Metacello new
		baseline: 'Roassal3';
		repository: 'github://ObjectProfile/Roassal3:v0.9.4';
		load ]
		on: MCMergeOrLoadWarning
		do: [ :warning | warning load ]! !

!RSWorldMenu class methodsFor: 'icons' stamp: ''!
roassalIcon
	^ roassalIcon ifNil: [ roassalIcon := Form fromBinaryStream: self roassalIconStream base64Decoded readStream ]! !

!RSWorldMenu class methodsFor: 'menu' stamp: ''!
menu04DocumentationOn: aBuilder
	<worldMenu>
	(aBuilder item: #Roassal3Documentation)
		parent: #Roassal3;
		order: 4;
		label: 'Online documentation';
		help: 'Will open the webpage https://github.com/ObjectProfile/Roassal3Documentation';
		icon: (self iconNamed: #smallHelp);
		action: [ WebBrowser openOn: 'https://github.com/ObjectProfile/Roassal3Documentation' ]! !

!RSWorldMenu class methodsFor: 'menu' stamp: ''!
menu00RoassalOn: aBuilder
	<worldMenu>
	(aBuilder item: #Roassal3)
		parent: #Tools;
		label: 'Roassal3';
		icon: self roassalIcon;
		help: 'A visualization engine';
		order: 777! !

!RSWorldMenu class methodsFor: 'icons' stamp: ''!
discord
	^ discord ifNil: [ discord := PNGReadWriter formFromStream: self discordPNGByteArray readStream ]! !

!RSWorldMenu class methodsFor: 'menu' stamp: ''!
menu06PluginsOn: aBuilder
	"<worldMenu>
	(aBuilder item: #Roassal3Plugins)
		parent: #Roassal3;
		order: 6;
		label: 'Plugins';
		help: 'TODO';
		icon: self roassalIcon;
		action: [ self inform: 'TODO' ]"! !

!RSWorldMenu class methodsFor: 'menu' stamp: ''!
menu11SelfOn: aBuilder
	<worldMenu>
	(aBuilder item: #Roassal3Self)
		parent: #Roassal3;
		order: 11;
		label: 'This menu';
		help: 'Open RSWorldMenu';
		icon: (self iconNamed: 'smallExport');
		action: [ self browse ]! !

!RSWorldMenu class methodsFor: 'menu' stamp: ''!
menu02GithubOn: aBuilder
	<worldMenu>
	(aBuilder item: #Roassal3Git)
		parent: #Roassal3;
		order: 2;
		label: 'Github';
		help: 'Open Roassal3 git hubpage';
		icon: (self iconNamed: 'github');
		action: [ WebBrowser openOn: 'https://github.com/ObjectProfile/Roassal3/' ]! !

!RSWorldMenu class methodsFor: 'utility' stamp: ''!
areExamplesAlreadyLoaded

	^ Smalltalk globals hasClassNamed: #RSAbstractExamples! !

!RSWorldMenu class methodsFor: 'streams' stamp: ''!
discordPNGByteArray
	^ #[137 80 78 71 13 10 26 10 0 0 0 13 73 72 68 82 0 0 0 16 0 0 0 16 8 6 0 0 0 31 243 255 97 0 0 0 4 103 65 77 65 0 0 177 143 11 252 97 5 0 0 0 32 99 72 82 77 0 0 122 38 0 0 128 132 0 0 250 0 0 0 128 232 0 0 117 48 0 0 234 96 0 0 58 152 0 0 23 112 156 186 81 60 0 0 0 9 112 72 89 115 0 0 11 19 0 0 11 19 1 0 154 156 24 0 0 1 203 105 84 88 116 88 77 76 58 99 111 109 46 97 100 111 98 101 46 120 109 112 0 0 0 0 0 60 120 58 120 109 112 109 101 116 97 32 120 109 108 110 115 58 120 61 34 97 100 111 98 101 58 110 115 58 109 101 116 97 47 34 32 120 58 120 109 112 116 107 61 34 88 77 80 32 67 111 114 101 32 53 46 52 46 48 34 62 10 32 32 32 60 114 100 102 58 82 68 70 32 120 109 108 110 115 58 114 100 102 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 49 57 57 57 47 48 50 47 50 50 45 114 100 102 45 115 121 110 116 97 120 45 110 115 35 34 62 10 32 32 32 32 32 32 60 114 100 102 58 68 101 115 99 114 105 112 116 105 111 110 32 114 100 102 58 97 98 111 117 116 61 34 34 10 32 32 32 32 32 32 32 32 32 32 32 32 120 109 108 110 115 58 116 105 102 102 61 34 104 116 116 112 58 47 47 110 115 46 97 100 111 98 101 46 99 111 109 47 116 105 102 102 47 49 46 48 47 34 10 32 32 32 32 32 32 32 32 32 32 32 32 120 109 108 110 115 58 120 109 112 61 34 104 116 116 112 58 47 47 110 115 46 97 100 111 98 101 46 99 111 109 47 120 97 112 47 49 46 48 47 34 62 10 32 32 32 32 32 32 32 32 32 60 116 105 102 102 58 79 114 105 101 110 116 97 116 105 111 110 62 49 60 47 116 105 102 102 58 79 114 105 101 110 116 97 116 105 111 110 62 10 32 32 32 32 32 32 32 32 32 60 120 109 112 58 67 114 101 97 116 111 114 84 111 111 108 62 65 100 111 98 101 32 73 109 97 103 101 82 101 97 100 121 60 47 120 109 112 58 67 114 101 97 116 111 114 84 111 111 108 62 10 32 32 32 32 32 32 60 47 114 100 102 58 68 101 115 99 114 105 112 116 105 111 110 62 10 32 32 32 60 47 114 100 102 58 82 68 70 62 10 60 47 120 58 120 109 112 109 101 116 97 62 10 178 35 126 241 0 0 2 168 73 68 65 84 56 17 109 83 75 107 83 65 20 254 230 113 147 38 49 125 102 97 17 90 95 180 40 162 32 74 74 235 198 62 246 174 10 130 85 112 43 40 198 141 127 194 138 27 23 46 4 173 32 22 23 238 107 91 186 104 177 186 113 161 139 46 164 166 130 45 86 105 154 54 105 110 238 220 25 207 153 52 88 197 3 147 156 185 231 245 205 119 206 17 216 151 233 105 167 198 199 69 204 215 135 207 220 104 108 49 18 4 232 225 123 20 97 77 73 204 222 189 33 222 242 253 160 175 56 248 225 209 148 27 148 2 147 16 200 171 0 112 150 173 128 144 64 28 145 226 176 108 29 10 119 38 196 82 51 137 104 42 15 158 186 107 58 192 84 68 24 76 29 86 74 88 66 225 11 144 238 40 153 212 9 200 64 145 61 194 196 189 155 226 5 199 122 7 174 76 153 23 235 117 224 88 183 49 29 173 177 222 248 165 25 186 23 122 10 14 119 25 108 149 149 89 93 215 58 145 0 8 233 16 35 209 13 23 15 27 99 249 170 233 106 55 154 161 159 237 223 67 160 29 161 166 138 70 96 175 38 33 4 244 201 30 101 22 62 102 56 110 146 206 128 120 252 202 141 238 86 48 115 162 59 178 99 67 59 50 138 4 148 116 176 206 131 219 207 207 21 29 98 43 124 210 153 165 172 253 178 30 200 67 25 140 201 168 102 71 36 229 235 59 26 146 153 120 162 146 76 154 86 92 187 33 172 83 245 134 141 254 251 122 67 203 49 81 136 97 25 11 217 147 77 1 185 14 35 76 76 24 9 246 218 247 36 86 86 91 40 136 3 157 215 215 214 147 222 198 62 185 78 35 56 134 248 238 149 53 34 46 215 6 164 146 214 87 136 201 97 246 125 26 175 231 211 8 235 210 31 214 249 27 219 24 97 170 197 34 215 14 112 172 222 169 96 173 147 18 40 5 199 189 102 226 46 158 174 161 82 149 72 4 141 103 140 156 15 145 73 91 111 139 136 80 26 42 215 217 10 16 119 69 93 220 194 108 75 16 223 215 218 202 221 138 166 138 2 231 78 85 185 77 96 103 150 75 23 118 97 169 51 229 93 229 185 72 167 98 73 49 248 186 165 230 188 199 243 55 238 221 229 124 156 111 207 108 155 159 37 173 75 101 133 36 85 103 168 44 220 194 144 186 211 158 141 153 43 83 170 180 233 249 101 181 124 253 138 24 240 115 240 185 136 194 102 73 45 246 247 180 234 227 71 106 102 99 51 208 75 159 18 200 166 125 60 202 85 96 232 76 157 147 154 133 15 173 122 229 155 194 143 109 20 216 250 215 40 215 45 166 252 240 198 176 201 4 161 62 48 202 97 29 18 138 14 209 146 144 255 140 114 115 31 158 188 140 6 195 88 55 150 137 176 241 187 89 104 23 16 27 82 104 153 164 50 133 91 87 131 63 203 228 61 232 167 153 132 239 188 206 180 27 195 90 163 151 239 198 160 24 8 204 221 254 207 58 255 6 33 135 81 38 156 4 58 218 0 0 0 0 73 69 78 68 174 66 96 130]! !

!RSWorldMenu class methodsFor: 'menu' stamp: ''!
menu01ReportABugOn: aBuilder
	<worldMenu>
	(aBuilder item: #Roassal3Bug)
		parent: #Roassal3;
		order: 1;
		label: 'Report a Bug';
		icon: (self iconNamed: 'smallDebug');
		help: 'Will open the github page to report an issue';
		action: [ WebBrowser openOn: 'https://github.com/ObjectProfile/Roassal3/issues/new' ]! !

!RSWorldMenu class methodsFor: 'menu' stamp: ''!
menu03DiscordOn: aBuilder
	<worldMenu>
	(aBuilder item: #Roassal3Chat)
		parent: #Roassal3;
		order: 3;
		label: 'Chat with us';
		help: 'Will open discord web to chat with us in Pharo server';
		icon: self discord;
		action: [ WebBrowser openOn: 'https://discord.gg/YTEaAu6' ]! !

!RSWrapEllipsisStrategy commentStamp: ''!
Basic ellipsis for a single line text!
!RSWrapEllipsisStrategy methodsFor: 'accessing' stamp: ''!
ellipsis
	^ '...'! !

!RSWrapEllipsisStrategy methodsFor: 'hooks' stamp: ''!
wrapTextFor: aString with: aRSMultilineLabelBuilder
	| width lines label currentTextWithEllipsis currentText ellipsis |
	lines := aString lines.
	lines size > 1 ifTrue: [ self error: 'Not supported for multiline' ].
	width := self wrapMaxWidth.
	ellipsis := self ellipsis.
	currentText := currentTextWithEllipsis := aString. 
	
	[label := aRSMultilineLabelBuilder singleLabelFor: currentTextWithEllipsis.
	label width > width and: [ currentText isNotEmpty ] ] whileTrue: [ 
		currentText := currentText copyFrom: 1 to: currentText size - 1.
		currentTextWithEllipsis := currentText , ellipsis.
	].

	^ label
	
	! !

!RSWrapStrategy commentStamp: ''!
This uses a wrapMaxWidth and creates a multiline label!
!RSWrapStrategy methodsFor: 'hooks' stamp: ''!
wrapLineShapesFor: line with: aRSMultilineLabelBuilder
	| label tokens newLines i currentLine width lastLabel |
	label := aRSMultilineLabelBuilder 
		singleLabelFor: line.
	width := self wrapMaxWidth.
	label width < width
		ifTrue: [ ^ { label } ].
	tokens := self wordsAndSpacesFor: line.
	newLines := OrderedCollection new.
	i := 1.
	lastLabel := nil.
	currentLine := ''.
	[ i <= tokens size ] whileTrue: [
		| token |
		token := tokens at: i.
		label := aRSMultilineLabelBuilder 
			singleLabelFor: currentLine, token.
		label width > width
			ifTrue: [ 
				lastLabel ifNil: [ 
					| k ok |
					token := label text.
					k := token size - 1.
					ok := false.
					[ k > 1 and: [ ok not ] ] whileTrue: [ 
						lastLabel := aRSMultilineLabelBuilder 
							singleLabelFor: (token copyFrom: 1 to: k).
						lastLabel width < width ifTrue: [
							ok := true.
							] ifFalse: [ k := k - 1 ] .
					].
					newLines add: lastLabel.
					tokens at: i put: (token copyFrom: k+1 to: token size).
				 ] ifNotNil: [ 
					newLines add: lastLabel.
					currentLine := ''.
					lastLabel := nil
				 ].
			] ifFalse: [ 
				currentLine := label text.
				lastLabel := label.
				i := i + 1 ]
	].
	currentLine ifNotEmpty: [ 
		newLines add: (aRSMultilineLabelBuilder 
			singleLabelFor: currentLine). ].
	
	^ newLines.! !

!RSWrapStrategy methodsFor: 'hooks' stamp: ''!
wordsAndSpacesFor: aString
	| tokens flag isWord i |
	tokens := OrderedCollection new.
	isWord := nil.
	i := 1.
	aString doWithIndex: [ :char :index | 
		flag := char tokenish.
		isWord ifNil: [ isWord := flag ].
		isWord = flag ifFalse: [ 
			tokens add: (aString copyFrom: i to: index-1).
			i := index.
			isWord := flag.
			].
		].
	tokens add: (aString copyFrom: i to: aString size).
	^ tokens! !

!RSWrapStrategy methodsFor: 'hooks' stamp: ''!
wrapTextFor: aString with: aRSMultilineLabelBuilder
	| lines shapes |
	lines := aString lines.
	shapes := lines flatCollect: [ :line | 
		self wrapLineShapesFor: line with: aRSMultilineLabelBuilder ] 
		as: RSGroup.
	aRSMultilineLabelBuilder layout on: shapes.
	^ shapes asShape position: 0@0; yourself.! !

!RSXLabelDecoration commentStamp: ''!
<keyClass>
`RSXLabelDecoration` adds a title to the X-axis in a chart.

*Responsibility*: Add a title and allows for its style to be defined (e.g., color, size, rotation, offset)

*Collaborators*: must be added to an `RSChart`

*Example*:
```Smalltalk
x := -3.14 to: 3.14 by: 0.1.
y := x sin.

c := RSChart new.
c addPlot: (RSLinePlot new x: x y: y).
c addDecoration: (RSChartTitleDecoration new title: 'hello'; fontSize: 20).
c addDecoration: (RSXLabelDecoration new title: 'My X Axis'; fontSize: 12).
c addDecoration: (RSYLabelDecoration new title: 'My Y Axis'; fontSize: 15; horizontal).
c open
```!
!RSXLabelDecoration methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self below.! !

!RSXLabelDecoration methodsFor: 'public - positioning shorcuts' stamp: ''!
below
	self location 
		offset: 0@5;
		below;
		center! !

!RSXLabelDecoration methodsFor: 'public - positioning shorcuts' stamp: ''!
above
	self location 
		offset: 0@ -5;
		above;
		center! !

!RSXMarkerDecoration commentStamp: ''!
Set some markers along the X axis. 

-=-=-=-=-=-=-=-=-=
x := (-3.14 to: 3.14 by: 0.01).
c := RSChart new.

p := RSLinePlot new.
p x: x y: x sin * 0.22 + 0.5.
c addPlot: p.


c addDecoration: RSHorizontalTick new.
c addDecoration: (RSVerticalTick new asFloat).

c addDecoration: (RSYMarkerDecoration new average).
c addDecoration: (RSYMarkerDecoration new min).
c addDecoration: (RSYMarkerDecoration new max).

c addDecoration: (RSXMarkerDecoration new max).
c addDecoration: (RSXMarkerDecoration new min).
c addDecoration: (RSXMarkerDecoration new value: 0).
c 
-=-=-=-=-=-=-=-=-=!
!RSXMarkerDecoration methodsFor: 'rendering' stamp: ''!
createMarkerLineFromPlot: aPlot

	| value |
	value := self getValueToBeMarkedFromPlot: aPlot.

	^ RSLine new
			from: (aPlot xScale scale: value) @ 0;
			to: (aPlot xScale scale: value) @ chart extent y negated! !

!RSXMarkerDecoration methodsFor: 'public - configuration' stamp: ''!
average
	getRelevantValueBlock := [ :aPlot | aPlot definedValuesX average ]! !

!RSXMarkerDecoration methodsFor: 'public - configuration' stamp: ''!
min
	getRelevantValueBlock := [ :p | p minValueX ]! !

!RSXMarkerDecoration methodsFor: 'public - configuration' stamp: ''!
max
	getRelevantValueBlock := [ :p | p maxValueX ]! !

!RSYLabelDecoration commentStamp: ''!
<keyClass>
`RSYLabelDecoration` adds a title to the Y-axis in a chart.

*Responsibility*: Add a title and allows for its style to be defined (e.g., color, size, rotation, offset)

*Collaborators*: must be added to an `RSChart`

*Example*:
```Smalltalk
x := -3.14 to: 3.14 by: 0.1.
y := x sin.

c := RSChart new.
c addPlot: (RSLinePlot new x: x y: y).
c addDecoration: (RSChartTitleDecoration new title: 'hello'; fontSize: 20).
c addDecoration: (RSXLabelDecoration new title: 'My X Axis'; fontSize: 12).
c addDecoration: (RSYLabelDecoration new title: 'My Y Axis'; fontSize: 15; horizontal).
c open
```!
!RSYLabelDecoration methodsFor: 'accessing' stamp: ''!
right
	self location 
		offset: 5 @ 0;
		right;
		outer;
		middle! !

!RSYLabelDecoration methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self vertical.
	self left! !

!RSYLabelDecoration methodsFor: 'accessing' stamp: ''!
left
	self location 
		offset: -5 @ 0;
		left;
		outer;
		middle! !

!RSYMarkerDecoration commentStamp: ''!
Set some markers along the Y axis. 

-=-=-=-=-=-=-=-=-=
x := (-3.14 to: 3.14 by: 0.01).
c := RSChart new.

p := RSLinePlot new.
p x: x y: x sin * 0.22 + 0.5.
c addPlot: p.


c addDecoration: RSHorizontalTick new.
c addDecoration: (RSVerticalTick new asFloat).

c addDecoration: (RSYMarkerDecoration new average).
c addDecoration: (RSYMarkerDecoration new min).
c addDecoration: (RSYMarkerDecoration new max).

c addDecoration: (RSXMarkerDecoration new max).
c addDecoration: (RSXMarkerDecoration new min).
c addDecoration: (RSXMarkerDecoration new value: 0).
c 
-=-=-=-=-=-=-=-=-=!
!RSYMarkerDecoration methodsFor: 'rendering' stamp: ''!
createMarkerLineFromPlot: aPlot

	| value |
	value := self getValueToBeMarkedFromPlot: aPlot.
	^ RSLine new
			from: 0 @ (aPlot yScale scale: value);
			to: chart extent x @ (aPlot yScale scale: value)! !

!RSYMarkerDecoration methodsFor: 'public - configuration' stamp: ''!
average
	getRelevantValueBlock := [ :aPlot | aPlot definedValuesY average ]! !

!RSYMarkerDecoration methodsFor: 'public - configuration' stamp: ''!
min
	getRelevantValueBlock := [ :p | p minValueY ]! !

!RSYMarkerDecoration methodsFor: 'public - configuration' stamp: ''!
max
	getRelevantValueBlock := [ :p | p maxValueY ]! !

!RSZoomToFitCanvasInteraction commentStamp: ''!
I add an interaction for the view!
!RSZoomToFitCanvasInteraction methodsFor: 'private - events' stamp: ''!
processKeyUp: evt
	evt keyName = #SPACE ifFalse:  [ ^ self ].
	self animatedZoomToFit: evt canvas! !

!RSZoomToFitCanvasInteraction methodsFor: 'hooks' stamp: ''!
cameraFor: aCanvas
	^ RSConfigurableCamera new
		canvas: aCanvas;
		zoomInteraction: self;
		yourself! !

!RSZoomToFitCanvasInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	aCanvas when: RSKeyUp do: [ :evt | self processKeyUp: evt ].
	aCanvas when: RSExtentChangedEvent do: [ self zoomToFitIfNecessary: aCanvas ].
	aCanvas camera: (self cameraFor: aCanvas). 
	self configuration shouldZoomToFitOnStart ifFalse: [ ^ self ].
	aCanvas zoomToFit.! !

!RSZoomToFitCanvasInteraction methodsFor: 'zoom animation' stamp: ''!
zoomToFitIfNecessary: aCanvas
	self configuration shouldZoomToFitOnExtendChanged ifFalse: [ ^ self ].
	aCanvas zoomToFit! !

!RSZoomToFitCanvasInteraction methodsFor: 'zoom animation' stamp: ''!
animatedZoomToFit: aCanvas
	| sc position scale camera pos |
	camera := aCanvas camera.
	sc := camera scale.
	pos := camera position.
	aCanvas zoomToFit. 
	
	position := NSScale linear
		from: pos;
		to: camera position.
	scale := NSScale linear
		from: sc;
		to: camera scale.
	camera translateTo: pos; scale: sc.
	sc < 1 ifTrue: [ 
		aCanvas newAnimation
			duration: 500 milliSeconds;
			easing: RSEasingInterpolator backOut;
			onStepDo: [ :t | 
				camera
					position: (position scale: t);
					scale: (scale scale: t).
				aCanvas signalUpdate ].
		^ self ].
	aCanvas newAnimation 
		delay: 150 milliSeconds;
		duration: 700 milliSeconds;
		easing: RSEasingInterpolator backOut;
		onStepDo: [:t |
			camera position: (position scale: t).
			aCanvas signalUpdate].
	aCanvas newAnimation
		duration: 300 milliSeconds;
		easing: RSEasingInterpolator exp;
		onStepDo: [ :t | 
				camera scale: (scale scale: t).
				aCanvas signalUpdate ]
	
	! !

!RSZoomToFitCanvasInteraction methodsFor: 'rendering' stamp: ''!
renderLegendOn: lb
	lb text: 'Space' description: 'To zoom to fit the view'.! !

!RSZoomableCanvasInteraction commentStamp: ''!
I handle the zoom interaction with mouse wheel event, also I handle all the zoom process!
!RSZoomableCanvasInteraction methodsFor: 'events - processing' stamp: ''!
processEvent: evt
	| delta |
	animation ifNotNil: [ ^ self ].
	delta := evt isUp
		ifTrue: [ 1.25@0.2 ]
		ifFalse: [ 0.8@ -0.25 ].
	self move: evt canvas evtPosition: evt position delta: delta.! !

!RSZoomableCanvasInteraction methodsFor: 'events - processing' stamp: ''!
move: aCanvas evtPosition: evtPosition delta: delta

	| camera sc dist correct scale position |
	camera := aCanvas camera.
	sc := camera scale * delta x.
	sc = (self scaleFor: sc) ifFalse: [ ^ self ].
	dist := evtPosition - camera position.
	correct := self
		correctCameraPosition: aCanvas 
		inRectangle: (self expandedRectangle: aCanvas)
		position: camera position + (dist * delta y)
		scale: sc.
	scale := NSScale sqrt range: { camera scale. sc }.
	position := NSScale sqrt range: { camera position. correct }.
	animation := aCanvas newAnimation
		duration: 200 milliSeconds;
		onStepDo: [ :t |
			camera 
				scale: (scale scale: t);
				translateTo: (position scale: t).
			aCanvas signalUpdate ];
		when: RSAnimationEndEvent do: [ animation := nil ]! !

!RSZoomableCanvasInteraction methodsFor: 'hooks' stamp: ''!
onShape: aCanvas
	aCanvas when: RSMouseWheelEvent do: [ :evt | self processEvent: evt ]! !

!RSZoomableCanvasInteraction methodsFor: 'rendering' stamp: ''!
renderOn: lb
	lb text: 'Wheel' description: 'To zoom in-out the view'.! !

!RSZoomableCanvasInteraction methodsFor: 'rendering' stamp: ''!
renderLegendOn: lb
	lb text: 'Wheel' description: 'To zoom in-out the view'.! !

!RadialGradientPaint commentStamp: ''!
I represent a radial gradient paint.

The center point and radius defining a circle where gradient will be drawn in user space coordinates.

The gradient's ramp color at 0 maps to the focal point and ramp color at 1 maps to the edge of the circle,
interpolating colors in between.

Also check the comment of my superclass to know better how and when you can use me.
!
!RadialGradientPaint methodsFor: 'accessing' stamp: ''!
center
	
	^ center! !

!RadialGradientPaint methodsFor: 'accessing' stamp: ''!
center: aPoint

	center := aPoint! !

!RadialGradientPaint methodsFor: 'accessing' stamp: ''!
focalPoint: aPoint

	focalPoint := aPoint! !

!RadialGradientPaint methodsFor: 'converting' stamp: ''!
asAthensPaintOn: aCanvas
	^ aCanvas surface
		createRadialGradient:  colorRamp
		center: center
		radius: radius
		focalPoint: focalPoint! !

!RadialGradientPaint methodsFor: 'accessing' stamp: ''!
radius
	
	^ radius! !

!RadialGradientPaint methodsFor: 'accessing' stamp: ''!
radius: aNumber

	radius := aNumber! !

!RadialGradientPaint methodsFor: 'accessing' stamp: ''!
focalPoint
	
	^ focalPoint! !

!RadioButtonGroup commentStamp: ''!
I am a group for radio buttons which ensures that only one button is activated at the same time.

I collaborate with
- RadioButtonPresenter are usually the buttons I manage.
- ValueHolder to link buttons.

I provide the following methods
- addRadioButton: to add the button in my collection and link it at the other.
- buttons getter of my collection.
- default: activate a button when it is built.

todo
- canDeselectByClick!
!RadioButtonGroup methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	buttons := OrderedCollection new.
	canDeselectByClick := false asValueHolder.
	currentlyActivated := nil asValueHolder.
	
	self whenCanDeselectByClickChanged: [ :aBoolean | 
		buttons do: [ :each | each canDeselectByClick: aBoolean ]].! !

!RadioButtonGroup methodsFor: 'accessing' stamp: ''!
currentlyActivated: anObject
	currentlyActivated := anObject! !

!RadioButtonGroup methodsFor: 'api' stamp: ''!
addRadioButton: aButton

	buttons do: [:b | 
		aButton whenActivatedDo: [ b privateSetState: false ].
		b whenActivatedDo: [ aButton privateSetState: false ]].
		
	aButton whenActivatedDo: [ self currentlyActivated: aButton ].
		
	aButton canDeselectByClick: self canDeselectByClick.
	buttons add: aButton.
	aButton privateSetState: false! !

!RadioButtonGroup methodsFor: 'api' stamp: ''!
canDeselectByClick
	"Return true clicking on a selected radio button deselects it"

	^ canDeselectByClick value! !

!RadioButtonGroup methodsFor: 'api - events' stamp: ''!
whenCurrentlyActivatedChanged: aBlock
	"This method is triggered when `canDeselectByClick` changes"
	
	currentlyActivated whenChangedDo: aBlock! !

!RadioButtonGroup methodsFor: 'accessing' stamp: ''!
buttons
	^ buttons! !

!RadioButtonGroup methodsFor: 'api - events' stamp: ''!
whenCanDeselectByClickChanged: aBlock
	"This method is triggered when `canDeselectByClick` changes"
	
	canDeselectByClick whenChangedDo: aBlock! !

!RadioButtonGroup methodsFor: 'api' stamp: ''!
canDeselectByClick: aBoolean
	"Set if clicking on a selected radio button can deselect it"
	
	canDeselectByClick value: aBoolean! !

!RadioButtonGroup methodsFor: 'accessing' stamp: ''!
currentlyActivated
	^ currentlyActivated! !

!RadioButtonGroup methodsFor: 'api' stamp: ''!
default: aButton

	aButton privateSetState: true.
	aButton takeKeyboardFocus.
	aButton whenBuiltDo: [ aButton privateSetState: true ]! !

!RadioButtonGroupPresenter commentStamp: ''!
I am a group for radio buttons.
See DynamicComposablePresenter

self example

You can also have a look at MrAndMrsRadioButton and RadioButtonGroupExample for more examples.

I ensures that only one button is activated at the same time and I hold the button activated.

I provide the following variables and their accessors
- buttons is the collection of the buttons I manage.
- currentActivated is the last activated button.

I provide the following methods
- addRadioButton: to add a button in my collection and link it at others.
- default: to activate the button when I am built.
- linkRadioButton: to make the button deselected when another is selected.

defaultOnce: is use to avoid a problem appearing with default: when it is include in other DynamicComposablePresenter but it should be replace by a fix.

I use the following method for my internal work
- createWidgets assign each button of my collection in my super class collection that manage dynamical subwidgets.
- dynamicLayout refresh the layout using my super class collection.
- rebuildWidget trigger the steps for refresh the widget and the layout.

todo
- canDeselectByClick!
!RadioButtonGroupPresenter methodsFor: 'accessing' stamp: ''!
rebuildWidget
	self widgets removeAll.
	self createWidgets.
	self needFullRebuild: false.
	self buildWithSpecLayout: self dynamicLayout! !

!RadioButtonGroupPresenter methodsFor: 'accessing' stamp: ''!
currentActivated
	^ currentActivated value! !

!RadioButtonGroupPresenter methodsFor: 'specs' stamp: ''!
dynamicLayout
	|lay|
	lay := SpecLayout composed
		newColumn: [ :column | 
			widgets keysDo: [ :item | column newRow: [ :row | row add: item ] ].
			column newRow: [ :row |  ] ].
	self layout: lay.
	^ lay! !

!RadioButtonGroupPresenter methodsFor: 'initialization' stamp: ''!
initialize
	buttons := OrderedCollection new.
	canDeselectByClick := false asValueHolder.
	currentActivated := nil asValueHolder.
	super initialize.! !

!RadioButtonGroupPresenter methodsFor: 'accessing' stamp: ''!
createWidgets
	buttons
		withIndexDo: [ :each :i | 
			self assign: each to: ('radio' , i asString) asSymbol.
			 ]! !

!RadioButtonGroupPresenter methodsFor: 'accessing' stamp: ''!
currentActivated: aRadioButton
	currentActivated value: aRadioButton! !

!RadioButtonGroupPresenter methodsFor: 'protocol' stamp: ''!
addRadioButton: aButton
	self linkRadioButton: aButton.
	aButton canDeselectByClick: self canDeselectByClick.
	buttons add: aButton.
	aButton privateSetState: false;
		owner: self.
	self focusOrder add: aButton.
	self rebuildWidget! !

!RadioButtonGroupPresenter methodsFor: 'protocol' stamp: ''!
canDeselectByClick
	"Return true clicking on a selected radio button deselects it"

	^ canDeselectByClick value! !

!RadioButtonGroupPresenter methodsFor: 'protocol' stamp: ''!
defaultOnce: aButton
	aButton privateSetState: true.
	self currentActivated: aButton.
	"This method is used to avoid a problem of default: with a DynamicComposablePresenter but a fix would be better (if possible)"! !

!RadioButtonGroupPresenter methodsFor: 'accessing' stamp: ''!
buttons
	^ buttons! !

!RadioButtonGroupPresenter methodsFor: 'protocol-events' stamp: ''!
whenCanDeselectByClickChanged: aBlock
	"This method is triggered when `canDeselectByClick` changes"
	
	canDeselectByClick whenChangedDo: aBlock! !

!RadioButtonGroupPresenter methodsFor: 'protocol-events' stamp: ''!
whenCurrentActivatedChanged: aBlock

	currentActivated whenChangedDo: aBlock! !

!RadioButtonGroupPresenter methodsFor: 'protocol' stamp: ''!
canDeselectByClick: aBoolean
	<api: #boolean getter: #canDeselectByClick registration: #whenCanDeselectByClickChanged>
	"Set if clicking on a selected radio button can deselect it"
	
	canDeselectByClick value: aBoolean! !

!RadioButtonGroupPresenter methodsFor: 'protocol' stamp: ''!
default: aButton
	aButton privateSetState: true.
	aButton takeKeyboardFocus.
	aButton
		whenBuiltDo: [ aButton privateSetState: true.
			self currentActivated: aButton]
	! !

!RadioButtonGroupPresenter methodsFor: 'protocol' stamp: ''!
linkRadioButton: aButton
	buttons
		do: [ :b | 
			aButton whenActivatedDo: [ b privateSetState: false ].
			b whenActivatedDo: [ aButton privateSetState: false ] ].
	aButton whenActivatedDo: [ self currentActivated: aButton ].! !

!RadioButtonGroupPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	self
		whenCanDeselectByClickChanged: [ :aBoolean | buttons do: [ :each | each canDeselectByClick: aBoolean ] ]! !

!RadioButtonGroupPresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := RadioButtonGroupPresenter new.
	example
		addRadioButton: (RadioButtonPresenter new label: '1');
		addRadioButton: (RadioButtonPresenter new label: '2');
		addRadioButton: (RadioButtonPresenter new label: '3');
		whenCurrentActivatedChanged: [ self inform: example currentActivated label ].
	example openWithSpec.
	^ example! !

!RadioButtonGroupPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newColumn: [ :column |  ];
		yourself! !

!RadioButtonModelExample commentStamp: ''!
Model used for radio buttons in example of basic controls (see "UITheme exampleBasicControls").!
!RadioButtonModelExample methodsFor: 'accessing' stamp: ''!
isCenter
	"Answer whether the option if #center."

	^self option == #center! !

!RadioButtonModelExample methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		option: #left! !

!RadioButtonModelExample methodsFor: 'accessing' stamp: ''!
option
	"Answer the value of option"

	^ option! !

!RadioButtonModelExample methodsFor: 'accessing' stamp: ''!
option: aSymbol
	"Set the value of option"

	option := aSymbol.
	self
		changed: #isLeft;
		changed: #isCenter;
		changed: #isRight! !

!RadioButtonModelExample methodsFor: 'accessing' stamp: ''!
beCenter
	"Set the option to #center."

	self option: #center! !

!RadioButtonModelExample methodsFor: 'accessing' stamp: ''!
isLeft
	"Answer whether the option if #left."

	^self option == #left! !

!RadioButtonModelExample methodsFor: 'accessing' stamp: ''!
beRight
	"Set the option to #right."

	self option: #right! !

!RadioButtonModelExample methodsFor: 'accessing' stamp: ''!
isRight
	"Answer whether the option if #right."

	^self option == #right! !

!RadioButtonModelExample methodsFor: 'accessing' stamp: ''!
beLeft
	"Set the option to #left."

	self option: #left! !

!RadioButtonPresenter commentStamp: ''!
A RadioButtonPresenter is a spec presenter for RadioButton.
See AbstractFormButtonPresenter

self example

!! The method privateSetState: is really private and should only be used by RadioButtonGroup or RadioButtonGroupPresenter !!

You can also have a look at RadioButtonGroupExample for a full example of how to use them with a group.

I provide more accessors on my super class ValueHolder
- actionWhenActivatedHolder
- actionWhenDeactivatedHolder
- enabledHolder
- stateHolder

I provide the variable canDeselectByClick and its accessors, it is a boolean representing if the radio can be deselect directly by the user using a click on it.

I specialize state: to use the variable canDeselectByClick.!
!RadioButtonPresenter methodsFor: 'accessing' stamp: ''!
stateHolder
	
	^ stateHolder! !

!RadioButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	canDeselectByClick := false asValueHolder.! !

!RadioButtonPresenter methodsFor: 'accessing' stamp: ''!
actionWhenActivatedHolder
	
	^ actionWhenActivatedHolder! !

!RadioButtonPresenter methodsFor: 'accessing' stamp: ''!
actionWhenDeactivatedHolder
	
	^ actionWhenDeactivatedHolder! !

!RadioButtonPresenter methodsFor: 'protocol' stamp: ''!
state: aBoolean
	"Set if the radio is activated or not"

	<api: #boolean getter: #state>
	self canDeselectByClick
		ifTrue: [ stateHolder value: aBoolean ]
		ifFalse: [ self state
				ifFalse: [ stateHolder value: aBoolean ] ]! !

!RadioButtonPresenter methodsFor: 'protocol' stamp: ''!
canDeselectByClick
	"Return true clicking on a selected radio button deselects it"

	^ canDeselectByClick value! !

!RadioButtonPresenter methodsFor: 'protocol-events' stamp: ''!
whenCanDeselectByClickChanged: aBlock
	"This method is triggered when `canDeselectByClick` changes"
	
	canDeselectByClick whenChangedDo: aBlock! !

!RadioButtonPresenter methodsFor: 'api' stamp: ''!
enabled: aBoolean
	"<api: #boolean getter: #enabled registration: #whenEnabledChanged:>"
	"Set if the button is enabled (clickable)"

	super enabled: aBoolean.
	self changed: #enabled.
! !

!RadioButtonPresenter methodsFor: 'protocol' stamp: ''!
canDeselectByClick: aBoolean
	<api: #boolean getter: #canDeselectByClick registration: #whenCanDeselectByClickChanged>
	"Set if clicking on a selected radio button can deselect it"
	
	canDeselectByClick value: aBoolean! !

!RadioButtonPresenter methodsFor: 'private' stamp: ''!
privateSetState: aBoolean
	"Should only be used by RadioButtonGroup"
	
	stateHolder value: aBoolean.
	self changed: #state! !

!RadioButtonPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(RadioButtonAdapter
		adapt: #(model))! !

!RadioButtonPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #RadioButtonAdapter! !

!RadioButtonPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Radio Button'! !

!RaisedBorder commentStamp: ''!
see BorderedMorph!
!RaisedBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!RaisedBorderStyle commentStamp: ''!
see BorderedMorph!
!RaisedBorderStyle methodsFor: 'accessing' stamp: ''!
style
	^#raised! !

!RaisedBorderStyle methodsFor: 'color tracking' stamp: ''!
trackColorFrom: aMorph
	baseColor ifNil:[self color: aMorph raisedColor].! !

!RaisedBorderStyle methodsFor: 'accessing' stamp: ''!
topLeftColor
	"Changed from direct access to color since, if nil,
	self color is transparent."

	^width = 1 
		ifTrue: [self color twiceLighter]
		ifFalse: [self color lighter]! !

!RaisedBorderStyle methodsFor: 'accessing' stamp: ''!
bottomRightColor
	"Changed from direct access to color since, if nil,
	self color is transparent."
	
	^width = 1 
		ifTrue: [self color twiceDarker]
		ifFalse: [self color darker]! !

!RaisedBorderStyle methodsFor: 'accessing' stamp: ''!
colorsAtCorners
	| c c14 c23 |
	c := self color.
	c14 := c lighter. c23 := c darker.
	^Array with: c14 with: c23 with: c23 with: c14! !

!Random commentStamp: ''!
This Random Number Generator graciously contributed by David N. Smith.  It is an adaptation of the Park-Miller RNG [1] which uses Floats to avoid the need for LargeInteger arithmetic.

If you just want a quick random integer, use:
		10 atRandom
Every integer interval can give a random number:
		(6 to: 12) atRandom
SequenceableCollections can give randomly selected elements:
		'pick one of these letters randomly' atRandom
SequenceableCollections also respond to shuffled, as in:
		($A to: $Z) shuffled

The correct way to use class Random is to store one in an instance or class variable:
		myGenerator := Random new.
Then use it every time you need another number between 0.0 and 1.0 (excluding)
		myGenerator next
You can also generate a positive integer
		myGenerator nextInt: 10
		
[1] 'Random Number Generators:  Good Ones Are Hard to Find' 
by Stephen K. Park and Keith W. Miller 
(Comm. Asso. Comp. Mach., 31(10):1192--1201, 1988). http://www.firstpr.com.au/dsp/rand31/p1192-park.pdf!
!Random methodsFor: 'private' stamp: ''!
seed
	"Since [1] says... 
	    'After initialization the ideal solution is to hide seed from the user'
	...this method is placed in the 'private' protocol. Perhaps it sould even be deleted."
	^ seed! !

!Random methodsFor: 'initialization' stamp: ''!
seed: aNumber
	"Refer #privateNextSeed and [1], seed should be positive and less than m"
	| newSeed |
	newSeed := aNumber.
	[ newSeed > 0 ] whileFalse: 
		[ newSeed := newSeed + m ].
	[ newSeed < m ] whileFalse:
		[ newSeed := newSeed - m ].
	seed := newSeed.
! !

!Random methodsFor: 'initialization' stamp: ''!
initialize
	self useClockBasedSeed.
	a := 16r000041A7 asFloat.    " magic constant =      16807 = 7^5"
	m := 16r7FFFFFFF asFloat.    " magic constant = 2147483647 = 2^31 - 1"
	q := (m quo: a) asFloat.
	r  := (m \\ a) asFloat.
! !

!Random methodsFor: 'initialization' stamp: ''!
useClockBasedSeed
	"Set a reasonable Park-Miller starting seed [1] based on the ms clock."

	[ seed := (Time millisecondClockValue bitAnd: 16r3FFFFFFF) bitXor: self hash.
	seed = 0 ] whileTrue: [ "Try again if ever get a seed = 0" ]! !

!Random methodsFor: 'accessing' stamp: ''!
nextInteger: anInteger
	"Answer a random integer in the interval [1, anInteger].
	Handle large numbers too (for cryptography)."

	anInteger strictlyPositive ifFalse: [ self error: 'Range must be positive' ].
	anInteger asFloat isInfinite "are we outside the range of float? - use fraction"
		ifTrue: [^(self privateNextValue asFraction * anInteger) truncated + 1].
	^ (self privateNextValue * anInteger) truncated + 1! !

!Random methodsFor: 'accessing' stamp: ''!
next
	"Answer a random Float in the interval [0 to 1)."

	^ self privateNextValue! !

!Random methodsFor: 'accessing' stamp: ''!
next: anInteger
	^ self next: anInteger into: (Array new: anInteger)! !

!Random methodsFor: 'initialization' stamp: ''!
useUnixRandomGeneratorSeed
	"Try to seed the receiver using random bytes from a Unix OS' /dev/random.
	Return true if we succeeded, false otherwise.
	Note that this might block until the OS thinks it has enough entropy."

	^ [ (File named: '/dev/random') readStreamDo: [ :in | 
			[ seed := (in next: 4) asInteger.
			seed isZero ] whileTrue. "Try again if we ever get a zero value"
			true ] ]
		on: Error
		do: [ false ]! !

!Random methodsFor: 'private' stamp: ''!
privateNextSeed
	"This method generates random instances of Integer 	in the interval
	0 to 16r7FFFFFFF. This method does NOT update the seed; repeated sends
	answer the same value. The algorithm is described in detail in [1]"

	| lo hi aLoRHi |
	hi := (seed quo: q) asFloat.
	lo := seed - (hi * q).  " = seed rem: q"  
	aLoRHi := (a * lo) - (r * hi).
	^(aLoRHi > 0.0)
		ifTrue:  [aLoRHi]
		ifFalse: [aLoRHi + m].! !

!Random methodsFor: 'accessing' stamp: ''!
nextIntegerBetween: lowerBound and: higherBound
	"Answer a random integer number from the inclusive range [lowerBound, higherBound]"
	^ lowerBound + (self nextInteger: (higherBound - lowerBound + 1)) - 1! !

!Random methodsFor: 'private' stamp: ''!
privateNextValue
	"Answer a random Float in the interval [0 to 1)."

	^ (seed := self privateNextSeed) / m! !

!Random methodsFor: '*NumericInterpolator' stamp: ''!
rsNext: limit
	^ self rsNext: 0 and: limit.! !

!Random methodsFor: '*NumericInterpolator' stamp: ''!
rsNext: u and: v
	^ NSScale linear range: {u. v}; scale: self next.! !

!Random methodsFor: 'accessing' stamp: ''!
nextBetween: lowerBound and: higherBound
	"Answer a random float number from the range [lowerBound, higherBound)"
	^ lowerBound + (self next * (higherBound - lowerBound))! !

!Random methodsFor: 'accessing' stamp: ''!
next: anInteger into: anArray
	1 to: anInteger do: [:index | anArray at: index put: self privateNextValue].
	^ anArray! !

!Random class methodsFor: 'instance creation' stamp: ''!
seed: anInteger 
	^self new seed: anInteger! !

!Random class methodsFor: 'testing' stamp: ''!
bucketTest: randy
	"Execute this:   Random bucketTest: Random new"

	" A quick-and-dirty bucket test. Prints nbuckets values on the
Transcript.
	  Each should be 'near' the value of ntries. Any run with any value
'far' from ntries
	  indicates something is very wrong. Each run generates different
values.
	  For a slightly better test, try values of nbuckets of 200-1000 or
more; go get coffee.
	  This is a poor test; see Knuth.   Some 'OK' runs:
		1000 1023 998 969 997 1018 1030 1019 1054 985 1003
		1011 987 982 980 982 974 968 1044 976
		1029 1011 1025 1016 997 1019 991 954 968 999 991
		978 1035 995 988 1038 1009 988 993 976
"

	<script: 'Random bucketTest: Random new'>
	| nbuckets buckets ntrys |
	nbuckets := 20.
	buckets := Array new: nbuckets.
	buckets atAllPut: 0.
	ntrys := 100.
	ntrys * nbuckets
		timesRepeat: [ | slot |
			slot := (randy next * nbuckets) floor + 1.
			buckets at: slot put: (buckets at: slot) + 1 ].
	self
		trace:
			(String
				streamContents: [ :stream | 
					stream cr.
					1 to: nbuckets do: [ :nb | 
						(buckets at: nb) printOn: stream.
						stream space ] ])! !

!RandomTest commentStamp: ''!
SUnit tests for random generator!
!RandomTest methodsFor: 'tests' stamp: ''!
testNext

	10000 timesRepeat: [ 
		| next | 
		next := gen next.
		self assert: (next >= 0).
		self assert: (next < 1).
	].! !

!RandomTest methodsFor: 'tests' stamp: ''!
testNextBetweenAnd
	
	10000 timesRepeat: [ 
		| next | 
		next := gen nextBetween: -10 and: 5.
		self assert: (next >= -10).
		self assert: (next < 5) ].! !

!RandomTest methodsFor: 'tests' stamp: ''!
testNextIntegerBetweenAnd
	
	10000 timesRepeat: [ 
		| next | 
		next := gen nextIntegerBetween: -3 and: 5.
		self assert: next isInteger.
		self assert: (next between: -3 and: 5) ].! !

!RandomTest methodsFor: 'tests' stamp: ''!
testDistribution
	| results occurrences generator |
	1 to: 100 do: [ :i |
		results := Bag new.
		generator := Random new seed: 1234567+i.
		2000 timesRepeat: [ results add: (100 atRandom: generator) ].
		occurrences := Array new: 100 streamContents: [ :out |
			results doWithOccurrences: [ :element :occurrence |
				self assert: (element between: 1 and: 100).
				out nextPut: occurrence.
				self assert: (occurrence between: 5 and: 40) ] ].
		self assert: occurrences average equals: 20.
		self assert: occurrences stdev < 10].! !

!RandomTest methodsFor: 'tests' stamp: ''!
testIfCompletelyBroken
	"If the results are not these values (accounting for precision of printing) 
	then something is horribly wrong"

	gen seed: 2345678901.
	self
		assert: ((1 to: 10) collect: [ :i | gen next round: 15 ])
		equals:
			#(0.149243269650845 0.331633021743797 0.756196448000239 0.393701540023881 0.941783181364547 0.549929193942775 0.659962596213428 0.991354559078512 0.696074432551895 0.922987899707159)! !

!RandomTest methodsFor: 'tests' stamp: ''!
testNextInto
	| array |
	array := Array new: 8.
	array := gen next: 8 into: array.
	self assert: (array allSatisfy: [ :each | each isFloat and: [ each >= 0 and: [ each < 1 ] ] ])! !

!RandomTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Random! !

!RandomTest methodsFor: 'tests' stamp: ''!
testNextInteger
	| int |
	int := gen nextInteger: 256.
	self assert: int isInteger.
	self assert: (int between: 1 and: 256)! !

!RandomTest methodsFor: 'tests' stamp: ''!
testUnixRandomGeneratorSeed
	"the test is very slow on the CI (>2 minutes)"
	self skipOnPharoCITestingEnvironment.
	gen useUnixRandomGeneratorSeed.
	100 timesRepeat: [ | next |
			next := gen next.
			self assert: next >= 0.
			self assert: next < 1 ]! !

!RandomTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	gen := Random seed: 112629.! !

!RangeSettingDeclaration commentStamp: ''!
A RangeSettingValue is a setting for which the value domain is an interval.  See SettingManager comment for more explanations.

Instance Variables
	range:		<Interval>

range
	- The interval which define the value domain
!
!RangeSettingDeclaration methodsFor: 'accessing' stamp: ''!
realValue: aValue
	aValue
		ifNil: [self settingReceiver perform: self setSelector with: nil]
		ifNotNil: [self settingReceiver perform: self setSelector with: ((aValue max: self range first) min: self range last)].
	self triggerEvent: self privateChangeEvent with: self.
	^ true
	! !

!RangeSettingDeclaration methodsFor: 'user interface' stamp: ''!
hasEditableList
	^ false! !

!RangeSettingDeclaration methodsFor: 'accessing' stamp: ''!
range: anInterval
	range := anInterval! !

!RangeSettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidget
	^ (self theme
			newRowIn: self
			for: {
				(self theme 
					newTextEntryIn: self
					for: self
					get: #realValue
					set: #realValue:
					class: (Smalltalk globals at: self type)
					getEnabled: #enabled
					help: nil)
						hResizing: #rigid;
						width: 80;
						wantsFrameAdornments: true;
						yourself. 
				(PluggableSliderMorph new max: self range last;
					 min: self range first;
					 quantum: self range increment;
					on: self
					getValue: #realValue
					setValue: #realValue:) hResizing: #spaceFill;
					 vResizing: #spaceFIll;
					 setBalloonText: self description;
					 minWidth: 300; height: 20;
					 yourself}) 
		cellInset: 10;
		yourself! !

!RangeSettingDeclaration methodsFor: 'accessing' stamp: ''!
range
	^ range ! !

!RbScriptingSetBeforeModel commentStamp: ''!
You have to call scripting methods after #model: or it will not work!
!RbScriptingSetBeforeModel methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	self add: #(beForSmalltalkScripting beForSmalltalkCode) requiresPreSend: #model:! !

!RbScriptingSetBeforeModel methodsFor: 'accessing' stamp: ''!
group
	^ 'Rubric'! !

!ReAbstractCritique commentStamp: ''!
I am an abstract critique class.

A critique links a quality rule to a source code target. It is the main unit that should be used to provide information to the user.

I specialize the ReProperty class by extracting information from the rule that reported the violation. 
The #title is extracted from the rule's #name, the #icon based on the rule's #severity and a #description is provided based on the rule's #rationale.

A critique has the #providesChange method which returns a boolean value specifying whether the critique can provide a change which will resolve the issue. The #change method can be used to obtain an object of RBRefactoryChange kind.

The reference to the critized entity is established through ReSourceAnchor.
A critique has a reference to the criticized entity.

This link is established through ReSourceAnchor. A source anchor has a reference to the actual class, method, or other entity that is criticized. An anchor also has a #providesInterval method that returns a boolean indicating if the anchor provides a selection interval to the actual source of the critique. The interval can be accessed through the #interval method.

There are two subclasses of ReSourceAnchor.
ReIntervalSourceAnchor stores the actual interval object which is set during initialization.
ReSearchStringSourceAnchor stores a searchString which will be searched for in the entities source code on demand to find an interval of substring!
!ReAbstractCritique methodsFor: 'actions' stamp: ''!
ban
	self entity ban: self! !

!ReAbstractCritique methodsFor: 'testing' stamp: ''!
providesChange

	^ self subclassResponsibility ! !

!ReAbstractCritique methodsFor: 'accessing' stamp: ''!
title
	^ (self tinyHint isNil or: [ self tinyHint isEmpty ])
		ifTrue: [ rule name ]
		ifFalse: [
			String streamContents: [ :s |
				s
					nextPut: $[;
					nextPutAll: self tinyHint;
					nextPutAll: '] ';
					nextPutAll: rule name ] ]! !

!ReAbstractCritique methodsFor: 'actions' stamp: ''!
actions 

	| actions |
	
	actions := OrderedCollection new: 3.

	actions add: (RePropertyAction new
			icon: (self iconNamed: #smallQuestionIcon);
			description: 'View rationale behind the rule';
			action: [ :crit |
				crit popDescriptionUp.
				ReSystemAnnouncer uniqueInstance
					notifyCritique: crit
					descriptionViewedFor: crit sourceAnchor entity ];
			yourself).
	
	self providesChange ifTrue: [ 
		actions add: (RePropertyAction new
			icon: (self iconNamed: #repairIcon);
			description: 'Automatically resolve the issue';
			action: [ :crit |
				| changesBrowser |
				
				changesBrowser := (ChangesBrowser changes: { crit change })
					extent: 500@400;
					setModal: SystemWindow topWindow;
					yourself.
					
				changesBrowser openDialogWithSpec
					okAction: [ changesBrowser accept ];
					centered ];
			yourself) ].
	
	actions add: (RePropertyAction new
			icon: (self iconNamed: #smallCancelIcon);
			description: 'Ban this rule';
			action: [ :crit | crit guidedBan ];
			yourself).

	^ actions! !

!ReAbstractCritique methodsFor: 'accessing' stamp: ''!
tinyHint

	^ tinyHint! !

!ReAbstractCritique methodsFor: 'accessing' stamp: ''!
description
	^ rule rationale! !

!ReAbstractCritique methodsFor: 'actions' stamp: ''!
guidedBan

	ReCriticEngine guidedBy: self entity  ban: self! !

!ReAbstractCritique methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' (', self title, ')'! !

!ReAbstractCritique methodsFor: 'accessing' stamp: ''!
change
	
	^ self subclassResponsibility ! !

!ReAbstractCritique methodsFor: 'actions' stamp: ''!
providePositiveFeedback: aComment
	ReFeedbacker positiveFeedback: aComment about: self! !

!ReAbstractCritique methodsFor: 'accessing' stamp: ''!
icon

	^ self iconNamed: ('small', rule severity capitalized, 'Icon') asSymbol! !

!ReAbstractCritique methodsFor: 'actions' stamp: ''!
popDescriptionUp
	UIManager default longMessage: self description title: self title! !

!ReAbstractCritique methodsFor: 'accessing' stamp: ''!
rule
	^ rule! !

!ReAbstractCritique methodsFor: 'initialization' stamp: ''!
initializeRule: aRule target: anEntity

	self
		initializeRule: aRule
		sourceAnchor: (ReSourceAnchor entity: anEntity)! !

!ReAbstractCritique methodsFor: 'initialization' stamp: ''!
initializeRule: aRule sourceAnchor: anAnchor

	self initializeSourceAnchor: anAnchor.
	rule := aRule.! !

!ReAbstractCritique methodsFor: 'testing' stamp: ''!
isCritique
	^ true! !

!ReAbstractCritique methodsFor: 'actions' stamp: ''!
provideNegativeFeedback: aComment
	ReFeedbacker negativeFeedback: aComment about: self! !

!ReAbstractCritique methodsFor: 'accessing' stamp: ''!
color

	^ ({
	#error -> Color red .
	#warning -> Color yellow .
	#information -> Color blue
	 } asDictionary at: rule severity ifAbsent: [ super color ]) alpha: 0.1
! !

!ReAbstractCritique methodsFor: 'accessing' stamp: ''!
tinyHint: anObject
	tinyHint := anObject! !

!ReAbstractCritique class methodsFor: 'special instance creation' stamp: ''!
withAnchor: anAnchor by: aRule hint: aString

	^ (self
		withAnchor: anAnchor
		by: aRule)
		tinyHint: aString;
		yourself! !

!ReAbstractCritique class methodsFor: '*Calypso-SystemPlugins-Critic-Queries' stamp: ''!
decorateBrowserItem: aBrowserItem by: anEnvironmentPlugin
	| critique |
	critique := aBrowserItem actualObject.
	
	aBrowserItem addProperty: (ClyCritiqueSeverityProperty of: critique).
	critique sourceAnchor ifNotNil: [ :anchor | 
		anchor providesInterval ifTrue: [ 
			aBrowserItem addProperty: (ClySourceNodeCritiqueIntervalProperty from: anchor interval)]].
	critique providesChange	ifTrue: [ aBrowserItem markWith: ClyCritiqueFixableTag ]! !

!ReAbstractCritique class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self == ReAbstractCritique! !

!ReAbstractCritique class methodsFor: 'instance creation' stamp: ''!
for: anEntity by: aRule

	^ self basicNew
		initializeRule: aRule
		target: anEntity;
		yourself! !

!ReAbstractCritique class methodsFor: 'instance creation' stamp: ''!
withAnchor: anAnchor by: aRule

	^ self basicNew
		initializeRule: aRule
		sourceAnchor: anAnchor;
		yourself! !

!ReAbstractRule commentStamp: ''!
I am the root of all quality rules rules.

Each rule should provide a short name string returned from the #name method. You also have to override the #rationale method to return a detailed description about the rule. You may also put the rationale in the class comment, as by default #rationale method returns the comment of the rule's class.

The class-side methods #checksMethod, #checksClass, #checksPackage and #checksNode return true if the rule checks methods, classes or traits, packages and AST nodes respectively. Tools will pass entities of the specified type to the rule for checking. 

To check the rule, while there is a default implementation which relies on #basicCheck: and creates an instance of ReTrivialCritique, it is advised to override the #check:forCritiquesDo: method. 

It's a good idea to assign your rule to a specific group. For this override the #group method and return string with the name of the group. While you can use any name you want, maybe you would like to put your rule into one of the existing groups: API Change, API Hints, Architectural, Bugs, Coding Idiom Violation, Design Flaws, Optimization, Potential Bugs, Rubric, SUnit, Style, Unclassified rules.

You can also specify the severity of your rue by returning one of: #information, #warning, or #error symbols from the #severity method.



It is fairly easy to run your rule and obtain the results. Just create an instance of it an send it the #check: message with the entity you want to check. The result is a collection of critiques. For example inspecting

	RBExcessiveMethodsRule new check: Object

should give you a collection with one critique (because the Object class always has many methods ;) ). Go on click on the critique item and inspect it. You will see that there is a special "description" tab. This is the power of critique objects, they can present themselves in a different way. Guess what: you can even visualize the critique if needed.


To have quality assistant (and maybe other tools) pick up your changes you have to reset the cache. Do this by going to System > Settings > Code Browsing > QualityAssistant > Renraku > Rule Cache
and pressing the reset button. Or simply executing  ReRuleManager reset


When you load complete rules into the system, the cache will be reset automatically. But as you are creating a new rule and it is in the incomplete state you have to reset the cache once you are ready.

If you want to learn more about the features of rules or how to create your own, please read:

RenrakuRuleHelp readInHelpBrowser!
!ReAbstractRule methodsFor: 'running' stamp: ''!
check: anEntity

	| critiques |
	critiques := OrderedCollection new.
	self
		check: anEntity
		forCritiquesDo: [ :critique | critiques add: critique ].
	^ critiques! !

!ReAbstractRule methodsFor: 'accessing' stamp: ''!
rationale
	"Answer an explanation of the rule, usually in one line. Long description can be obtained using longDescription."

	^ self class comment! !

!ReAbstractRule methodsFor: 'compatibility' stamp: ''!
resetResult! !

!ReAbstractRule methodsFor: 'running' stamp: ''!
basicCheck: anEntity
	"If you end here, you should most likely implement this in a subclass"
	
	^ self shouldBeImplemented  ! !

!ReAbstractRule methodsFor: 'helpers' stamp: ''!
anchorFor: anEntity

	^ ReSourceAnchor entity: anEntity! !

!ReAbstractRule methodsFor: 'utilities' stamp: ''!
createTrivialCritiqueOn: method intervalOf: node hint: hint

	^ ReTrivialCritique
		  withAnchor:
		  (ReIntervalSourceAnchor
			   entity: method
			   interval: node sourceInterval)
		  by: self
		  hint: hint! !

!ReAbstractRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Unclassified rules'! !

!ReAbstractRule methodsFor: 'accessing' stamp: ''!
severity
	"Answer the severity of issues reported by this rule. This method should return one of #error, #warning, or #information."

	^ #warning! !

!ReAbstractRule methodsFor: 'running' stamp: ''!
check: anEntity forCritiquesDo: aCriticBlock
	"Accepts an entity and a block which could be evaluated for each detected critique
	aCriticBlock may accept one argument: the critique object"
	
	(self basicCheck: anEntity)
		ifTrue: [ aCriticBlock cull: (self critiqueFor: anEntity) ]! !

!ReAbstractRule methodsFor: 'accessing' stamp: ''!
name
	"Answer a human readable name of the rule."

	^ self subclassResponsibility! !

!ReAbstractRule methodsFor: 'helpers' stamp: ''!
critiqueFor: anEntity

	^ ReTrivialCritique
		withAnchor: (self anchorFor: anEntity)
		by: self! !

!ReAbstractRule methodsFor: 'running' stamp: ''!
check: anEntity forCritiquesDo: aCriticBlock ifNone: alternativeBlock

	| encounteredCritique |
	encounteredCritique := false.

	self check: anEntity forCritiquesDo: [ :crit | 
		encounteredCritique := true.
		aCriticBlock cull: crit ].

	encounteredCritique ifFalse: alternativeBlock! !

!ReAbstractRule methodsFor: 'running - helpers' stamp: ''!
critiqueFor: aClass about: aVarName

	| crit |
	crit := ReTrivialCritique
		withAnchor: (ReVarSearchSourceAnchor
			entity: aClass
			string: aVarName)
		by: self.
	crit tinyHint: aVarName.	
	^ crit! !

!ReAbstractRule methodsFor: 'running' stamp: ''!
check: anEntity ifNoCritiques: alternativeBlock

	| critiques |
	critiques := OrderedCollection new.
	self
		check: anEntity
		forCritiquesDo: [ :critique | critiques add: critique ]
		ifNone: alternativeBlock.
	^ critiques! !

!ReAbstractRule methodsFor: 'testing' stamp: ''!
isComposite

	^ false! !

!ReAbstractRule methodsFor: 'testing' stamp: ''!
isRewriteRule

	^ false! !

!ReAbstractRule class methodsFor: 'testing - interest' stamp: ''!
checksPackage
	"Not checking a package by default - but subclasses should return true when the receiver rule checks on package level."
	
	^ false! !

!ReAbstractRule class methodsFor: 'manifest' stamp: ''!
isDefaultRule

	^ true! !

!ReAbstractRule class methodsFor: 'manifest' stamp: ''!
uniqueIdentifierNumber
	"This number should be unique and should change only when the rule completely change semantics"
	^ 0! !

!ReAbstractRule class methodsFor: 'accessing' stamp: ''!
enabledSettingID

	^ (self name, '_enabled') asSymbol! !

!ReAbstractRule class methodsFor: 'testing - interest' stamp: ''!
checksMethod
	"Not checking a method by default - but subclasses should return true when the receiver rule checks on method level."
	
	^ false! !

!ReAbstractRule class methodsFor: 'manifest' stamp: ''!
identifierMinorVersionNumber
	"This number identifies the version of the rule definition. Each time the rule is updated and its changes invalidates previous false positives identification (and as such should be reassessed by developers) the number should be increased."

	^ 1! !

!ReAbstractRule class methodsFor: 'manifest' stamp: ''!
isBeginnerRule

	^ false! !

!ReAbstractRule class methodsFor: 'testing' stamp: ''!
isUsed
	"all my sublasses are used"
	
	^self name = 'ReAbstractRule'
		ifTrue: [ super isUsed ]
		ifFalse: [ true ]! !

!ReAbstractRule class methodsFor: 'accessing' stamp: ''!
enabled

	^ enabled ifNil: [ enabled := true ]! !

!ReAbstractRule class methodsFor: 'properties' stamp: ''!
methodOfInteresetSelectors

	^ #(checksMethod checksClass checksPackage checksNode)! !

!ReAbstractRule class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self = ReAbstractRule! !

!ReAbstractRule class methodsFor: 'testing - interest' stamp: ''!
checksClass
	"Not checking a class by default - but subclasses should return true when the receiver rule checks on class level."
	
	^ false! !

!ReAbstractRule class methodsFor: 'testing - interest' stamp: ''!
checksNode
	"Not checking a node by default - but subclasses should return true when the receiver rule checks on AST node level."
	
	^ false! !

!ReAbstractRule class methodsFor: 'accessing' stamp: ''!
enabled: aBoolean

	enabled := aBoolean.
	ReRuleManager reset! !

!ReAbstractRule class methodsFor: 'testing' stamp: ''!
isVisible
	
	^ self methodOfInteresetSelectors anySatisfy: [ :selector |
		self perform: selector ]! !

!ReAbstractRule class methodsFor: 'manifest' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^ self name! !

!ReAbstractRuleTestCase methodsFor: 'utilities' stamp: ''!
myCritiquesOnMethod: method
	| critiques |
	critiques := OrderedCollection new.
	self subjectUnderTest  new 
		check: method forCritiquesDo:[:critique | critiques add: critique].
	^critiques! !

!ReAbstractRuleTestCase methodsFor: 'utilities' stamp: ''!
subjectUnderTest 
	^(self class name allButLast: 4) asClass! !

!ReAbstractRuleTestCase methodsFor: 'utilities' stamp: ''!
myCritiquesOnClass: aClass
	| critiques |
	critiques := OrderedCollection new.
	self subjectUnderTest new 
		check: aClass forCritiquesDo:[:critique | critiques add: critique].
	^critiques! !

!ReAbstractRuleTestCase methodsFor: 'utilities' stamp: ''!
sourceAtChritique: critique
	^ critique sourceAnchor in: [ :anchor | anchor entity sourceCode atAll: anchor interval ]! !

!ReAbstractRuleTestCase methodsFor: 'utilities' stamp: ''!
critiguesFor: ruleClass onMethod: method
	| critiques |
	critiques := OrderedCollection new.
	ruleClass new 
		check: method forCritiquesDo:[:critique | critiques add: critique].
	^critiques! !

!ReAbstractRuleTestCase methodsFor: 'utilities' stamp: ''!
myCritiques
	| critiques |
	critiques := OrderedCollection new.
	self subjectUnderTest  new 
		check: (self class >> #sampleMethod ) forCritiquesDo:[:critique | critiques add: critique].
	^critiques! !

!ReAbstractRuleTestCase class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self == ReAbstractRuleTestCase! !

!ReAddRemoveDependentsRule commentStamp: ''!
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.!
!ReAddRemoveDependentsRule methodsFor: 'running' stamp: ''!
basicCheck: aClass
	| methods addSends removeSends |
	addSends := 0.
	removeSends := 0.
	methods := (aClass whichMethodsReferTo: #addDependent:) asSet, (aClass whichMethodsReferTo: #removeDependent:).
	
	methods do: [ :method | | messages |
			messages := method ast allChildren select: [ :each | each isMessage ].
				addSends := addSends + (messages count: [ :each | each selector == #addDependent:]).
				removeSends := removeSends + (messages count: [ :each | each selector == #removeDependent:])].
	^ addSends > removeSends! !

!ReAddRemoveDependentsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReAddRemoveDependentsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Number of addDependent: messages > removeDependent:'! !

!ReAddRemoveDependentsRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReAddRemoveDependentsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'AddRemoveDependentsRule'! !

!ReAllAnyNoneSatisfyRule commentStamp: ''!
Replace ad-hoc implementations (using explicit logic based on do:) of ==allSatisfy:==, ==anySatisfy:== and ==noneSatisfy:== by the adequate calls to ==allSatisfy:==, ==anySatisfy:== or ==noneSatisfy:==. 

For example 

[[[  
collection do: [ :each |
				...
				condition
					ifFalse: [ ^ false ] ]
]]]
is transformed into 

[[[  
collection allSatisfy: [ :each | condition ]
]]]!
!ReAllAnyNoneSatisfyRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
	
		" allSatisfy: "
		addMatchingMethod: '`@method: `@args
			| `@temps |
			`@.statements.
			`@collection do: [ :`each |
				| `@blocktemps |
				`@.blockstatements.
				`@condition
					ifFalse: [ ^ false ] ].
			^ true'
		rewriteTo: '`@method: `@args
			| `@temps |
			`@.statements. 
			^ `@collection allSatisfy: [ :`each |
				| `@blocktemps |
				`@.blockstatements.
				`@condition ]';

		" anySatisfy: "
		addMatchingMethod: '`@method: `@args
			| `@temps |
			`@.statements.
			`@collection do: [ :`each |
				| `@blocktemps |
				`@.blockstatements.
				`@condition
					ifTrue: [ ^ true ] ].
			^ false'
		rewriteTo: '`@method: `@args
			| `@temps |
			`@.statements.
			^ `@collection anySatisfy: [ :`each | 
				| `@blocktemps |
				`@.blockstatements.
				`@condition ]';

		" noneSatisfy: "
		addMatchingMethod: '`@method: `@args
			| `@temps |
			`@.statements.
			`@collection do: [ :`each |
				| `@blocktemps |
				`@.blockstatements.
				`@condition
					ifTrue: [ ^ false ] ].
			^ true'
		rewriteTo: '`@method: `@args
			| `@temps |
			`@.statements.
			^ `@collection noneSatisfy: [ :`each | 
				| `@blocktemps |
				`@.blockstatements.				
				`@condition ]'! !

!ReAllAnyNoneSatisfyRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Replace ad-hoc implementations (using explicit logic based on do:) of allSatisfy:, anySatisfy: and noneSatisfy: by the adequate calls to #allSatisfy:, #anySatisfy: or #noneSatisfy:. '! !

!ReAllAnyNoneSatisfyRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReAllAnyNoneSatisfyRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Replace with #allSatisfy:, #anySatisfy: or #noneSatisfy:'! !

!ReAllAnyNoneSatisfyRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'AllAnyNoneSatisfyRule'! !

!ReAnySatisfyRule commentStamp: ''!
Checks for the common code fragment: "(aCollection detect: [:each | ''some condition''] ifNone: [nil]) ~= nil". contains: can simplify this code to "aCollection anySatisfy: [:each | ''some condition'']". Not only is the anySatisfy: variant shorter, it better signifies what the code is doing.!
!ReAnySatisfyRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'(`@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]' )! !

!ReAnySatisfyRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Checks for the common code fragment: "(aCollection detect: [:each | ''some condition''] ifNone: [nil]) ~= nil".'! !

!ReAnySatisfyRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReAnySatisfyRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses detect:ifNone: instead of anySatisfy:'! !

!ReAnySatisfyRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'AnySatisfyRule'! !

!ReAsClassRule commentStamp: ''!
Do not use methods such as

	#asClass
	#asClassIfAbsent:
	#asClassIfPresent:
	
because they do not take into account an environment. Instead use `self class environment at: #ClassName`!
!ReAsClassRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: '`@expr asClass'
		   with: 'self class environment at: `@expr';
		
		replace: '`@expr asClassIfAbsent: `@block'
		with: 'self class environment at: `@expr ifAbsent: `@block';
		
	replace: '`@expr asClassIfPresent: `@block'
		with: 'self class environment at: `@expr ifPresent: `@block'! !

!ReAsClassRule methodsFor: 'accessing' stamp: ''!
severity

	^ #error! !

!ReAsClassRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Design Flaws'! !

!ReAsClassRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Do not use #asClass & similar'! !

!ReAsOrderedCollectionNotNeededRule commentStamp: ''!
A prior conversion to an Array or OrderedCollection is not necessary when adding all elements to a collection.
!
!ReAsOrderedCollectionNotNeededRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	#('addAll:' 'removeAll:' 'includesAll:' 'copyWithoutAll:')
		do: [ :collectionMessage | 
			#('asArray' 'asOrderedCollection' 'asSortedCollection')
				do: [ :conversionMessage | 
					| baseString |
					baseString := '``@receiver ' , collectionMessage , ' ``@arg '.
					self replace: baseString , conversionMessage with: baseString ] ]! !

!ReAsOrderedCollectionNotNeededRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReAsOrderedCollectionNotNeededRule methodsFor: 'accessing' stamp: ''!
name
	^ '#asOrderedCollection/#asArray not needed'! !

!ReAsOrderedCollectionNotNeededRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'AsOrderedCollectionNotNeededRule'! !

!ReAssertEqualSignIntoAssertEqualsRule commentStamp: ''!
Using assert:equals: produces better context on rule failure!
!ReAssertEqualSignIntoAssertEqualsRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self replace: 'self assert: ``@object1 = ``@object2' with: 'self assert: ``@object1 equals: ``@object2'.
	self replace: 'self deny: ``@object1 = ``@object2' with: 'self deny: ``@object1 equals: ``@object2'.
	self replace: 'self assert: ``@object1 == ``@object2' with: 'self assert: ``@object1 identicalTo: ``@object2'.
	self replace: 'self deny: ``@object1 == ``@object2' with: 'self deny: ``@object1 identicalTo: ``@object2'! !

!ReAssertEqualSignIntoAssertEqualsRule methodsFor: 'running' stamp: ''!
group
	^ 'SUnit'! !

!ReAssertEqualSignIntoAssertEqualsRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Use assert:equals: instead of assert: and = (or deny:/identicalTo: and ==)'! !

!ReAssertEqualSignIntoAssertEqualsRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	"would be nice to test if the class uses TAssertable,
	 but it is more complicated"
	
	^ [ aNode methodNode methodClass canUnderstand: #assert:equals: ]
		on: MessageNotUnderstood "methodNode or methodClass may be nil"
		do: [ false ]! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ReAssertEqualSignIntoAssertEqualsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'AssertEqualSignIntoAssertEquals'! !

!ReAssignmentInBlockRule commentStamp: ''!
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.!
!ReAssignmentInBlockRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self  matchesAny: #(
			'`@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' )! !

!ReAssignmentInBlockRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReAssignmentInBlockRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Unnecessary assignment or return in block'! !

!ReAssignmentInBlockRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'AssignmentInBlockRule'! !

!ReAssignmentInIfTrueRule commentStamp: ''!
Moving assignments outside blocks leads to shorter and more efficient code.
For example:
test 
	ifTrue: [var := 1]
	ifFalse: [var:= 2]
is equivalent to:
var :=  test 
	ifTrue: [1]
	ifFalse: [2]!
!ReAssignmentInIfTrueRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		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]'! !

!ReAssignmentInIfTrueRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Moving assignments outside blocks leads to shorter and more efficient code.'! !

!ReAssignmentInIfTrueRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReAssignmentInIfTrueRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Move variable assignment outside of single statement ifTrue:ifFalse: blocks'! !

!ReAssignmentInIfTrueRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'AssignmentInIfTrueRule'! !

!ReAssignmentWithoutEffectRule commentStamp: ''!
This smell arises when a statement such as x := x is found. This statement has not effect, it can be removed.!
!ReAssignmentWithoutEffectRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self  matches: '`var := `var'! !

!ReAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Assignment has no effect'! !

!ReAssignmentWithoutEffectRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'AssignmentWithoutEffectRule'! !

!ReAtIfAbsentRule commentStamp: ''!
Replaces at:ifAbsent: by at:ifAbsentPut:. Its leads to shorter and more readable code.

!
!ReAtIfAbsentRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		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]'! !

!ReAtIfAbsentRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReAtIfAbsentRule methodsFor: 'accessing' stamp: ''!
name
	^ 'at:ifAbsent: -> at:ifAbsentPut:'! !

!ReAtIfAbsentRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'AtIfAbsentRule'! !

!ReBadMessageRule commentStamp: ''!
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:

This rule is not active for methods in test classes.!
!ReBadMessageRule methodsFor: 'private' stamp: ''!
badSelectors
	^ #( #become: #isKindOf: #respondsTo: #isMemberOf: #perform: #perform:arguments: #perform:with: #perform:with:with: #perform:with:with:with: #allOwners #instVarAt: #instVarAt:put: #nextInstance instVarsInclude: #nextObject caseOf: caseOf:otherwise: caseError isThisEverCalled isThisEverCalled: becomeForward: instVarNamed: instVarNamed:put: someObject primitiveChangeClassTo:)! !

!ReBadMessageRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Check methods that send messages that perform low level things.'! !

!ReBadMessageRule methodsFor: 'enumerating' stamp: ''!
basicCheck: aNode
	aNode isMessage ifFalse: [ ^false ].
	"In tests using these messages (like isKindOf:) is no problem"
	aNode methodNode methodClass isTestCase ifTrue: [ ^false ].
	^ self badSelectors includes: aNode selector! !

!ReBadMessageRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReBadMessageRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Sends "questionable" message'! !

!ReBadMessageRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'BadMessageRule2'! !

!ReBasicScenarioExceptionStrategyTest methodsFor: 'tests' stamp: ''!
testPass

	ReExceptionStrategy current: RePassExceptionStrategy.
	
	self
		should: [ self validationScenario  ]
		raise: MyTestError! !

!ReBasicScenarioExceptionStrategyTest methodsFor: 'tests' stamp: ''!
testIgnore
	| critiques |
	ReExceptionStrategy current: ReIgnoreExceptionStrategy.

	self shouldnt: [ critiques := self validationScenario ] raise: MyTestError.

	self assertEmpty: critiques! !

!ReBasicScenarioExceptionStrategyTest methodsFor: 'helpers' stamp: ''!
validationScenario
	| critiques |
	
	critiques := Set new.

	[ MyTestError signal: self errorMessage ]
		on: Error
		do: [ :er |
			ReExceptionStrategy current
				handle: er
				about: self
				forPropertiesDo: [ :prop |
					critiques add: prop ] ].
			
	^ critiques
	! !

!ReBasicScenarioExceptionStrategyTest methodsFor: 'tests' stamp: ''!
testLog
	| critiques |

	ReExceptionStrategy current: ReLogExceptionStrategy.
	
	self
		shouldnt: [
			critiques := self validationScenario  ]
		raise: MyTestError.
		
	self assert: critiques isNotEmpty.
	self assert: (
		critiques anySatisfy: [ :crit |
		 (crit isKindOf: ReExceptionProperty) and: [ 
			crit message includesSubstring: self errorMessage ] ])! !

!ReBetweenAndRule commentStamp: ''!
Replaces "a >= b and: [a <= c]" by "a between: b and: c.!
!ReBetweenAndRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		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'! !

!ReBetweenAndRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReBetweenAndRule methodsFor: 'accessing' stamp: ''!
name
	^ '"a >= b and: [a <= c]" -> "a between: b and: c"'! !

!ReBetweenAndRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'BetweenAndRule'! !

!ReBooleanPrecedenceRule commentStamp: ''!
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.!
!ReBooleanPrecedenceRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self  matchesAny: #(
			'`@object1 | `@object2 = `@object3'
			'`@object1 | `@object2 == `@object3'
			'`@object1 & `@object2 = `@object3'
			'`@object1 & `@object2 == `@object3'
			'`@object1 | `@object2 ~= `@object3'
			'`@object1 | `@object2 ~~ `@object3'
			'`@object1 & `@object2 ~= `@object3'
			'`@object1 & `@object2 ~~ `@object3' )! !

!ReBooleanPrecedenceRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReBooleanPrecedenceRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReBooleanPrecedenceRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses A | B = C instead of A | (B = C)'! !

!ReBooleanPrecedenceRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'BooleanPrecedenceRule'! !

!ReCascadedNextPutAllsRule commentStamp: ''!
Use cascaded nextPutAll:''s instead of #, in #nextPutAll:.
Indeed this is really important to understand that the implementation of the concatenation of strings creates a new string for each uses of ,.
Therefore if you use five , to concatenate an expression you create 5 intermediate strings for nothing. Using nextPutAll: just add the string in the stream.

Have a look at  streamContents:. Here is an example

String streamContents: [ :s|
		s nextPutAll: '---'.
		s nextPutAll: self.
		s nextPutAll: '---' ].!
!ReCascadedNextPutAllsRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: '``@rcvr nextPutAll: ``@object1 , ``@object2' with: '``@rcvr nextPutAll: ``@object1; nextPutAll: ``@object2';
		replace: '``@rcvr show: ``@object1 , ``@object2' with: '``@rcvr show: ``@object1; show: ``@object2'! !

!ReCascadedNextPutAllsRule methodsFor: 'accessing' stamp: ''!
rationale 
	^ 'Use cascaded nextPutAll:''s instead of #, in #nextPutAll:.'! !

!ReCascadedNextPutAllsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReCascadedNextPutAllsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Use cascaded nextPutAll:''s instead of #, in #nextPutAll:'! !

!ReCascadedNextPutAllsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'CascadedNextPutAllsRule'! !

!ReClassNameInSelectorRule commentStamp: ''!
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.!
!ReClassNameInSelectorRule methodsFor: 'running' stamp: ''!
critiqueFor: aMethod withInterval: anInterval

	^ ReTrivialCritique
		withAnchor: (ReIntervalSourceAnchor
			entity: aMethod
			interval: anInterval)
		by: self! !

!ReClassNameInSelectorRule methodsFor: 'accessing' stamp: ''!
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.'! !

!ReClassNameInSelectorRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Style'! !

!ReClassNameInSelectorRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	| className classNameIndex |
	(aMethod methodClass isMeta) ifFalse: [ ^ self ].
	className := aMethod methodClass soleInstance name.
	classNameIndex := aMethod selector 
		indexOfSubCollection: className
		startingAt: 1.
		
	classNameIndex > 0 ifTrue: [ aCriticBlock cull: (
		(self 
			critiqueFor: aMethod
			withInterval: (classNameIndex to: classNameIndex + className size ))
			tinyHint: className;
			yourself) ]! !

!ReClassNameInSelectorRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Redundant class name in selector'! !

!ReClassNameInSelectorRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReClassNameInSelectorRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ClassNameInSelectorRule'! !

!ReClassNotCategorizedRule commentStamp: ''!
If a package contains classes that are not tagged then this is OK. But when a tag (possibly with other categorized classes) exists in the package of a class then a class should also be categorized using a class tag.

The goal is to have no classes that are shown as "Uncategorized" in the system browser.!
!ReClassNotCategorizedRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Classes should be categorized with a tag if other class tags exist in the package. Use "Base" as default if you can not provide a better name.'! !

!ReClassNotCategorizedRule methodsFor: 'accessing' stamp: ''!
severity

	^ #information! !

!ReClassNotCategorizedRule methodsFor: 'running' stamp: ''!
basicCheck: aClass
	aClass isMeta ifTrue: [ ^ false ].
	
	^aClass tags isEmpty and: [ aClass package classTags size > 1 ]! !

!ReClassNotCategorizedRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReClassNotCategorizedRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Uncategorized class - missing class tag'! !

!ReClassNotCategorizedRule class methodsFor: 'testing' stamp: ''!
checksClass

	^ true! !

!ReClassNotCategorizedRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ReClassNotCategorizedRule'! !

!ReClassNotReferencedRule commentStamp: ''!
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.!
!ReClassNotReferencedRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Check if a class is referenced either directly or indirectly by a symbol. If a class is not referenced, it can be removed.'! !

!ReClassNotReferencedRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReClassNotReferencedRule methodsFor: 'enumerating' stamp: ''!
basicCheck: aClass
	^ aClass isUsed not! !

!ReClassNotReferencedRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReClassNotReferencedRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Class not referenced'! !

!ReClassNotReferencedRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReClassNotReferencedRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ClassNotReferencedRule'! !

!ReClassSideResetMethodProtocolRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	"If you end here, you should most likely implement this in a subclass"
	
	^ aMethod selector = #reset and: [ aMethod protocol ~= #'class initialization' ]! !

!ReClassSideResetMethodProtocolRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Class side methods called #reset should be in the ''class initialization'' protocol'! !

!ReClassSideResetMethodProtocolRule methodsFor: 'helpers' stamp: ''!
critiqueFor: aMethod

	| methodSymbol classSymbol |
	methodSymbol := aMethod selector asSymbol.
	classSymbol := aMethod methodClass name asSymbol.

	^ (ReRefactoringCritique
		   withAnchor: (self anchorFor: aMethod)
		   by: self) refactoring: (RBMethodProtocolTransformation
			   protocol: 'class initialization'
			   inMethod: methodSymbol
			   inClass: classSymbol) asRefactoring! !

!ReClassSideResetMethodProtocolRule class methodsFor: 'testing - interest' stamp: ''!
checksMethod
	
	^ true! !

!ReClassSideResetMethodProtocolRuleTest methodsFor: 'running' stamp: ''!
testIgnoredMethodWrongProtocol

	| method critiques |
	testClass class compile: 'resetIrrelevant
	^ self' classified: 'class warfare'.
	
	method := (testClass class methodNamed: #resetIrrelevant).
	
	critiques := ReClassSideResetMethodProtocolRule new check: method.
	self assert: critiques isEmpty.! !

!ReClassSideResetMethodProtocolRuleTest methodsFor: 'running' stamp: ''!
testRightMethodWrongProtocol

	| method critiques |
	testClass class
		compile: 'reset
	^ self'
		classified: 'class warfare'.

	method := testClass class methodNamed: #reset.

	critiques := ReClassSideResetMethodProtocolRule
		             new check: method.
	self deny: critiques isEmpty! !

!ReClassSideResetMethodProtocolRuleTest methodsFor: 'running' stamp: ''!
tearDown

	testClass removeFromSystem.
	
	super tearDown! !

!ReClassSideResetMethodProtocolRuleTest methodsFor: 'running' stamp: ''!
testAutomatedFix

	| method critiques refactoring |
	testClass class
		compile: 'reset
	^ self'
		classified: 'class warfare'.

	method := testClass class methodNamed: #reset.

	critiques := ReClassSideResetMethodProtocolRule new check: method.
	refactoring := critiques first refactoring transform.
	RBRefactoryChangeManager instance performChange: refactoring changes.

	self assert: method protocol equals: #'class initialization'! !

!ReClassSideResetMethodProtocolRuleTest methodsFor: 'running' stamp: ''!
testRightMethodRightProtocol

	| method critiques |
	testClass class compile: 'reset
	^ self' classified: 'class initialization'.
	
	method := (testClass class methodNamed: #reset).
	
	critiques := ReClassSideResetMethodProtocolRule new check: method.
	self assert: critiques isEmpty! !

!ReClassSideResetMethodProtocolRuleTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.

	testClassName := #ReClassSideResetMethodProtocolRuleTestTestClass.
	testClass := Object subclass: testClassName! !

!ReClassVariableCapitalizationRule commentStamp: ''!
Class and pool variable names should start with an uppercase letter.!
!ReClassVariableCapitalizationRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Style'! !

!ReClassVariableCapitalizationRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock
	aClass isMeta ifTrue: [ ^ self ].
	aClass classVarNames, aClass sharedPoolNames
		select: [ :each | each first isLowercase ]
		thenDo: [ :each |
			aCriticBlock cull:
				(self critiqueFor: aClass about: each) ]! !

!ReClassVariableCapitalizationRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Class (or pool) variable not capitalized'! !

!ReClassVariableCapitalizationRule methodsFor: 'running - helpers' stamp: ''!
critiqueFor: aClass about: aVarName

	| crit |
	crit := ReRefactoringCritique
		withAnchor: (ReVarSearchSourceAnchor
			entity: aClass
			string: aVarName)
		by: self.
	
	crit	
		tinyHint: aVarName;
		refactoring: (
			RBRenameClassVariableRefactoring
				rename: aVarName
				to: aVarName capitalized
				in: aClass).
				
	^ crit! !

!ReClassVariableCapitalizationRule class methodsFor: 'testing-interest' stamp: ''!
checksClass
	^ true! !

!ReClassVariableNeitherReadNorWrittenRule commentStamp: ''!
This smell arises when a class variable is not both read and written. If a class 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.!
!ReClassVariableNeitherReadNorWrittenRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReClassVariableNeitherReadNorWrittenRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock
	aClass classVariables
		select: [ :variable | variable isReferenced not ]
		thenDo: [ :variable | aCriticBlock cull: (self critiqueFor: aClass about: variable name) ]! !

!ReClassVariableNeitherReadNorWrittenRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Class variable not read or not written'! !

!ReClassVariableNeitherReadNorWrittenRule class methodsFor: 'testing-interest' stamp: ''!
checksClass
	^ true! !

!ReClassVariableNeitherReadNorWrittenRuleTest methodsFor: 'tests' stamp: ''!
testRuleDoesNotAppear
	| critiques |
	critiques := self myCritiquesOnClass: self class.
	self assert: critiques size equals: 0.! !

!ReClassVariableNeitherReadNorWrittenRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| critiques |
	critiques := self myCritiquesOnClass: RBLintRuleTestData.
	self assert: critiques size equals: 1.! !

!ReClassVariablesShadowingRule commentStamp: ''!
This rule checks if a instance or class variable shadows a global!
!ReClassVariablesShadowingRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReClassVariablesShadowingRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock

	aClass definedVariables
		select: [ :variable | variable isShadowing ]
		thenDo: [ :variable | aCriticBlock cull: (self critiqueFor: aClass about: variable name) ]! !

!ReClassVariablesShadowingRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Variable shadows a global variable'! !

!ReClassVariablesShadowingRule class methodsFor: 'testing-interest' stamp: ''!
checksClass

	^ true! !

!ReCodeBasedTestCase commentStamp: ''!
I provide a testing class and method which are destroyed later!
!ReCodeBasedTestCase methodsFor: 'running' stamp: ''!
tearDown

	testPackage methods do: #removeFromSystem.
	testPackage definedClasses do: #removeFromSystem.
	super tearDown! !

!ReCodeBasedTestCase methodsFor: 'running' stamp: ''!
setUp
	super setUp.

	testClass := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: #RenrakuProgrammaticallyCreatedClassTestClass;
			package: testPackage name ].


	testMethod := testClass
		>> (testClass compile: 'testingMethod ^ self').

	testClass2 := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: #RenrakuProgrammaticallyCreatedClassTestClass2;
			package: testPackage name ]! !

!ReCodeBasedTestCase class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self = ReCodeBasedTestCase! !

!ReCodeCruftLeftInMethodsRule commentStamp: ''!
This smell arises when a breakpoint,  logging statement,  etc is found in a method. This debugging code should not be left in production code.  Here are messages currently checked: clearHaltOnce,  doOnlyOnce: ,  halt, halt:   onCount:  object2, haltOnCount: , haltOnce, hatIf: , inspectOnCount: , inspectOnce, inspectUntilCount: , rearmOneShot, setHaltOnce, flag: , isThisEverCalled, isThisEverCalled: , logEntry, logExecution, logExit, needsWork and Transcript  messages.!
!ReCodeCruftLeftInMethodsRule methodsFor: 'private' stamp: ''!
debuggingSelectors
	
	^ (Object allSelectorsInProtocol: 'flagging'),
	(Object allSelectorsInProtocol: 'debugging')! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self patterns do: [ :halt | self addRuleRemoving: halt ]! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'private' stamp: ''!
patterns
	^ self debuggingPatterns, self haltPatterns! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Breakpoints, logging statements, etc. should not be left in production code.'! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'private' stamp: ''!
addRuleRemoving: patternString
	"When you are completely removing statement(s), you can not just match the relevant node. You must match the whole method and then replace it minus the part to be removed"

	| findString replaceString methodTemplate |
	methodTemplate := '| `@Temps |
``@.Statements1.
{1}.
``@.Statements2'.
	findString := methodTemplate format: { patternString }.
	replaceString := methodTemplate format: { '' }.
	self replace: findString with: replaceString! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'helpers' stamp: ''!
anchorFor: aNode
	"we do not use the method of the superclass as it hightlights far too much"
    ^ ReIntervalSourceAnchor
            entity: aNode
            interval: (1 to: aNode methodNode selector size).! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'private' stamp: ''!
haltSelectors
	| objectConvenience miscellaneous |
	objectConvenience := Object allSelectorsInProtocol: #halting.
	miscellaneous := #(inspectOnce).
	^ objectConvenience, miscellaneous! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Debugging code left in methods'! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'private' stamp: ''!
haltPatterns
	| result |
	result := self haltSelectors collect: [ :e | self patternFor: e ].
	^ result, { 'Halt `@message: `@arg' }! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'private' stamp: ''!
patternForKeywordSelector: selector
	|  index |
	^ String streamContents: [ :str |
		str nextPutAll: '`@object '.
		index := 1.
		selector keywords
			do: [ :keyword | 
				str
					nextPutAll: keyword;
					nextPutAll: ' `@arg';
					print: index ]
			separatedBy: [ 
				index := index + 1.
				str space ] ]! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'private' stamp: ''!
patternFor: selector
	selector isUnary ifTrue: [ ^ '`@object ', selector ].
	selector isBinary ifTrue: [ ^ '`@object ', selector, ' `@arg' ].
	^ self patternForKeywordSelector: selector! !

!ReCodeCruftLeftInMethodsRule methodsFor: 'private' stamp: ''!
debuggingPatterns
	| result |
	result := self debuggingSelectors collect: [ :e | self patternFor: e ].
	^ result, { 'Transcript `@message: `@arg' }! !

!ReCodeCruftLeftInMethodsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'CodeCruftLeftInMethodsRule'! !

!ReCollectSelectNotUsedRule commentStamp: ''!
Checks for senders of typical collection enumeration methods that return an unused result.

For example, check that the result of a select: or detect: is used.!
!ReCollectSelectNotUsedRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	aNode isMessage ifFalse: [ ^ false ].
	(#(#select: #collect: #reject:) includes: aNode selector) ifFalse: [ ^ false ].
	^ aNode isUsed not! !

!ReCollectSelectNotUsedRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReCollectSelectNotUsedRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Doesn''t use the result of a collect:/select:'! !

!ReCollectSelectNotUsedRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'CollectSelectNotUsedRule'! !

!ReCollectionAtCollectionSizeRule commentStamp: ''!
Checks for code using  "collection at: collection size" instead of "collection last".!
!ReCollectionAtCollectionSizeRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self  matchesAny: #('`@collection at: `@collection size')! !

!ReCollectionAtCollectionSizeRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReCollectionAtCollectionSizeRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses "collection at: collection size" instead of "collection last"'! !

!ReCollectionAtCollectionSizeRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ReCollectionAtCollectionSizeRule'! !

!ReCollectionCopyEmptyRule commentStamp: ''!
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.!
!ReCollectionCopyEmptyRule methodsFor: 'running' stamp: ''!
basicCheck: aClass
	^ (aClass inheritsFrom: Collection) and: [ aClass isVariable and: [ (aClass includesSelector: #copyEmpty) not and: [ aClass instVarNames isNotEmpty ] ] ]! !

!ReCollectionCopyEmptyRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReCollectionCopyEmptyRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Subclass of collection that has instance variable but doesn''t define copyEmpty'! !

!ReCollectionCopyEmptyRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReCollectionCopyEmptyRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'CollectionCopyEmptyRule'! !

!ReCollectionMessagesToExternalObjectRule commentStamp: ''!
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 containers of all its parts when adding a new component.!
!ReCollectionMessagesToExternalObjectRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
		'(`@collectionOwner `@collectionGetter: `@args) add:           `@arg'
		'(`@collectionOwner `@collectionGetter: `@args) remove:     `@arg'
		'(`@collectionOwner `@collectionGetter: `@args) addAll:       `@arg'
		'(`@collectionOwner `@collectionGetter: `@args) removeAll: `@arg'
		)! !

!ReCollectionMessagesToExternalObjectRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReCollectionMessagesToExternalObjectRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Sends add:/remove: to external collection'! !

!ReCollectionMessagesToExternalObjectRule methodsFor: 'helpers' stamp: ''!
isNotSpecialVariable: variableNode

	variableNode isReservedVariable ifTrue: [ ^false ]. 
	(Smalltalk globals includesKey: variableNode name asSymbol) ifTrue: [ ^ false ].
	^ true! !

!ReCollectionMessagesToExternalObjectRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	| collectionOwner |
	((mappingDict at: '`@collectionGetter:') beginsWith: 'as') ifTrue: [ ^ false ].
	collectionOwner := mappingDict at: (RBPatternVariableNode named: '`@collectionOwner').
	 collectionOwner isVariable ifFalse: [ ^ true ].
	^ self isNotSpecialVariable: collectionOwner.! !

!ReCollectionMessagesToExternalObjectRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'CollectionMessagesToExternalObjectRule'! !

!ReCollectionProtocolRule commentStamp: ''!
Checks code 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.!
!ReCollectionProtocolRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
		'`@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]' )! !

!ReCollectionProtocolRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReCollectionProtocolRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses do: instead of collect: or select:''s'! !

!ReCollectionProtocolRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'CollectionProtocolRule'! !

!ReCriticEngine commentStamp: ''!
I keep information about the critiques that exist on certain entities.
I'm invoked usually as follows:
	
	Point critiques
	(Point >> #degrees) critiques
	
I contain some functionality shared between code entities!
!ReCriticEngine methodsFor: 'banning' stamp: ''!
guidedBy: anEntity ban: aCritique

	| candidates |
		
	candidates := anEntity banLevelCandidates.
	
	(UIManager default
		chooseFrom: (candidates collect: [:each | each reBanName])
		values: candidates
		title: 'On which level do you want to ban the rule?')
			ifNotNil: [ :entity | entity ban: aCritique ]! !

!ReCriticEngine methodsFor: 'running' stamp: ''!
critiquesOf: anEntity
	| rules critiques manifest builder |
	
	builder := TheManifestBuilder new.
	manifest := builder manifestOf: anEntity.
		
	rules := anEntity suitableRulesFrom: (ReRuleManager managerFor: anEntity).
	critiques := Set new.
	rules
		reject: [ :rule |
			manifest isNotNil and:
			[ anEntity banChecksForValidation
				anySatisfy: [ :banLevel |
					builder bansRule: rule for: banLevel ] ] ]
		thenDo: [ :rule |
			[ rule resetResult.
			  rule
				  check: anEntity
				  forCritiquesDo: [ :critic |
					  critiques add: critic ]
			] on: Error
			  do: [ :er |
				ReExceptionStrategy current
					handle: er
					about: anEntity
					forPropertiesDo: [ :prop |
						critiques add: prop ] ].
			Processor yield ].
	
	ReSystemAnnouncer uniqueInstance notifyEntity: anEntity criticizedWith: critiques.
	
	^ critiques ! !

!ReCriticEngine methodsFor: 'running' stamp: ''!
nodeCritiquesOf: aMethod
	"this method exists because we have rules that check
	ast nodes, but we display their critiques together with
	method critiques… And because we do not want to re-check
	the banned rules for exery node, I do in once for all
	the nodes of a method. I have to find a better solution to
	do this, but for thow the method will stay like this."


	| rules critiques manifest builder |
	
	builder := TheManifestBuilder new.
	manifest := builder manifestOf: aMethod.
		
	rules := (ReRuleManager managerFor: aMethod) nodeRules.
	critiques := Set new.
	rules := rules
		reject: [ :rule |
			manifest isNotNil and:
			[ aMethod banChecksForValidation
				anySatisfy: [ :banLevel |
					builder bansRule: rule for: banLevel ] ] ].
		rules do: [ :rule |
			| ast |
			ast := aMethod ast.
			"for rewrite rules, we run every rule on a copy of the ast"
			rule isRewriteRule ifTrue: [ ast := ast copy  ].
			ast nodesDo: [ :node |
			[
			  rule
				  check: node
				  forCritiquesDo: [ :critique |
						critique sourceAnchor initializeEnitity: aMethod.
					  critiques add: critique ]
			] on: Error
			  do: [ :er |
				ReExceptionStrategy current
					handle: er
					about: aMethod
					forPropertiesDo: [ :prop |
						critiques add: prop ] ].
			Processor yield ] ].
	
	ReSystemAnnouncer uniqueInstance notifyEntity: aMethod criticizedWith: critiques.
	
	^ critiques! !

!ReCriticEngine class methodsFor: 'banning' stamp: ''!
guidedBy: anEntity ban: aCritique

	^ self uniqueInstance guidedBy: anEntity ban: aCritique! !

!ReCriticEngine class methodsFor: 'running' stamp: ''!
critiquesOf: anEntity

	^ self uniqueInstance critiquesOf: anEntity! !

!ReCriticEngine class methodsFor: 'accessing' stamp: ''!
uniqueInstance

	^ uniqueInstance ifNil: [ uniqueInstance := self new ]! !

!ReCriticEngine class methodsFor: 'running' stamp: ''!
nodeCritiquesOf: anEntity

	^ self uniqueInstance nodeCritiquesOf: anEntity! !

!ReCritiqueAutofixed commentStamp: ''!
Event of a critic being automatically fixed by entity transformation!
!ReCritiqueBanned commentStamp: ''!
Announced when a critic gets banned.!
!ReCritiqueBanned methodsFor: 'accessing' stamp: ''!
entityBanLevel
	^ entityBanLevel! !

!ReCritiqueBanned methodsFor: 'accessing' stamp: ''!
entityBanLevel: anObject
	entityBanLevel := anObject! !

!ReCritiqueDescriptionViewed commentStamp: ''!
Happens when someone clicks a question mark and a popup with critic's description appears!
!ReCritiqueEvent commentStamp: ''!
A Renraku critic event about an entity!
!ReCritiqueEvent methodsFor: 'accessing' stamp: ''!
entity
	^ entity! !

!ReCritiqueEvent methodsFor: 'accessing' stamp: ''!
entity: anObject

	entity := anObject ! !

!ReCritiqueTest methodsFor: 'tests' stamp: ''!
testTarget
	| rule critic |
	
	rule := (ReAbstractRule allSubclasses select: #isVisible)	 anyOne new.
	critic := ReAbstractCritique for: thisContext method by: rule.
	
	self assert: critic sourceAnchor entity equals: thisContext method! !

!ReCritiqueTest methodsFor: 'tests' stamp: ''!
testTitle
	| rule critic |
	
	rule := (ReAbstractRule allSubclasses select: #isVisible)	 anyOne new.
	critic := ReAbstractCritique for: thisContext method by: rule.
	
	self assert: critic title equals: rule name! !

!ReCritiqueTest methodsFor: 'tests' stamp: ''!
testBan
	| criticToSkip |
		
	criticToSkip := testClass critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	criticToSkip ban.
	
	self assert: (testClass critiques noneSatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!ReCritiqueTest methodsFor: 'tests' stamp: ''!
testDescription
	| rule critic |
	
	rule := (ReAbstractRule allSubclasses select: #isVisible) anyOne new.
	critic := ReAbstractCritique for: thisContext method by: rule.
	
	self assert: critic description equals: rule rationale! !

!ReCritiqueTest methodsFor: 'tests' stamp: ''!
testRule
	| rule critic |
	
	rule := (ReAbstractRule allSubclasses select: #isVisible)	 anyOne new.
	critic := ReAbstractCritique for: thisContext method by: rule.
	
	self assert: critic rule equals: rule! !

!ReCritiqueTest methodsFor: 'tests' stamp: ''!
testBan1
	| criticToSkip |
	
		
	criticToSkip := testMethod critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	criticToSkip ban.
	
	self assert: (testMethod critiques noneSatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!ReDeadBlockRule commentStamp: ''!
Dead Block. The block is not assigned, not returned and no message is send to it.
Often this is a left over from using blocks to comment out code.!
!ReDeadBlockRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Dead Block. The block is not assigned, not returned and no message is send to it.
Often this is a left over from using blocks to comment out code.'! !

!ReDeadBlockRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReDeadBlockRule methodsFor: 'running' stamp: ''!
basicCheck: node
	^ node isBlock and: [ node isUsed not ]! !

!ReDeadBlockRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReDeadBlockRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Dead Block'! !

!ReDeadBlockRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'DeadBlockRule'! !

!ReDefineBasicCheckRule commentStamp: ''!
Each rule should define a #basicCheck: method which accepts an entity to be validated by the rule.

If the entity violates the rule, method should ruturn "true", otherwise - "false".

It is recommended to reuse #basicCheck: functionality in #checkClass: and #checkMethod:!
!ReDefineBasicCheckRule methodsFor: 'running' stamp: ''!
basicCheck: aClass
	^ (aClass inheritsFrom: RBLintRule) and: [ aClass isVisible and: [ (aClass lookupSelector: #basicCheck:) isSubclassResponsibility ] ]! !

!ReDefineBasicCheckRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReDefineBasicCheckRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Rule does not define #basicCheck:'! !

!ReDefineBasicCheckRule methodsFor: 'helpers' stamp: ''!
critiqueFor: aClass
	^ (ReMissingMethodCritique
		for: aClass
		by: self
		class: aClass
		selector: #basicCheck:) beShouldBeImplemented! !

!ReDefineBasicCheckRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReDefineEntityComplianceCheckRule commentStamp: ''!
The rule checks if the class rule in question specifies which entities it can check!
!ReDefineEntityComplianceCheckRule methodsFor: 'accessing' stamp: ''!
rationale

	^ 'You should override on the CLASS SIDE at least one of #',
	  (self complianceMethods joinUsing: ', #'),
	  ' methods to return true and so indicate which entities can be checked by your rule.'! !

!ReDefineEntityComplianceCheckRule methodsFor: 'running' stamp: ''!
basicCheck: aClass
	^ (aClass inheritsFrom: RBLintRule) and: [ aClass isVisible and: [ self complianceMethods noneSatisfy: [ :method | aClass perform: method ] ] ]! !

!ReDefineEntityComplianceCheckRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReDefineEntityComplianceCheckRule methodsFor: 'properties' stamp: ''!
complianceMethods

	^ #(checksMethod checksClass checksPackage)! !

!ReDefineEntityComplianceCheckRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Rule does not define entity compliance'! !

!ReDefineEntityComplianceCheckRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReDefinesEqualNotHashRule commentStamp: ''!
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.

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		!
!ReDefinesEqualNotHashRule methodsFor: 'enumerating' stamp: ''!
basicCheck: aClass
	^ (aClass includesSelector: #=) and: [ (aClass includesSelector: #hash) not ]! !

!ReDefinesEqualNotHashRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReDefinesEqualNotHashRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Defines = but not hash'! !

!ReDefinesEqualNotHashRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReDefinesEqualNotHashRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'DefinesEqualNotHashRule'! !

!ReDeprecateWithFirstCharacterDownshiftedRule commentStamp: ''!
Use uncapitalized instead of withFirstCharacterDownshifted since withFirstCharacterDownshifted is ugly and is deprecated now.!
!ReDeprecateWithFirstCharacterDownshiftedRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: '``@object withFirstCharacterDownshifted' with: '``@object uncapitalized'.! !

!ReDeprecateWithFirstCharacterDownshiftedRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Style'! !

!ReDeprecateWithFirstCharacterDownshiftedRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Use uncapitalized instead of withFirstCharacterDownshifted'! !

!ReDeprecateWithFirstCharacterDownshiftedRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'FirstCharacterDownShifted'! !

!ReDetectContainsRule commentStamp: ''!
Checks for bytecodePrimEqual  using the do: method instead of using the contains: or detect: methods.!
!ReDetectContainsRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'`@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]' )! !

!ReDetectContainsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReDetectContainsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses do: instead of contains: or detect:''s'! !

!ReDetectContainsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'DetectContainsRule'! !

!ReDetectIfNoneRule commentStamp: ''!
Replaces detect:ifNone: and contains: when used with the semantics of anySatisfy: by anySatisfy:.

For example, 

[[[ 
collection detect: [:each | .... ] ifNone: [nil]) notNil	
]]]
is transformed into 

[[[ 
collection anySatisfy: [ :each | .... ])
]]]!
!ReDetectIfNoneRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		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]'! !

!ReDetectIfNoneRule methodsFor: 'accessing' stamp: ''!
rationale 
	^ 'Replaces detect:ifNone: and contains: by anySatisfy:'! !

!ReDetectIfNoneRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReDetectIfNoneRule methodsFor: 'accessing' stamp: ''!
name
	^ '#detect:ifNone: or #contains: -> #anySatisfy:'! !

!ReDetectIfNoneRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'DetectIfNoneRule'! !

!ReDoNotSendSuperInitializeInClassSideRule commentStamp: ''!
Don't send super initialize in class side because the class initialize methods of your superclass  may maintain state level shared state and it can be dangerous to automatically reinitialize it. 

For example, 

[[[  
ZnServer class>>initialize
	ManagedServers := IdentitySet new.
	AlwaysRestart := true.
	Smalltalk addToStartUpList: self.
	Smalltalk addToShutDownList: self
]]]!
!ReDoNotSendSuperInitializeInClassSideRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		replace: 'super initialize' 
		with: ''! !

!ReDoNotSendSuperInitializeInClassSideRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReDoNotSendSuperInitializeInClassSideRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Class-side #initialize should not send "super initialize".'! !

!ReDoNotSendSuperInitializeInClassSideRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
		
	aNode methodNode ifNotNil: [ :methNode |
		methNode compiledMethod ifNotNil: [ :method |
			(method selector = #initialize and: [ 
			method methodClass isMeta ])
				ifTrue: [ ^ true ] ] ].
		
	^ false! !

!ReDoNotSendSuperInitializeInClassSideRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'DoNotSendSuperInitializeInClassSideRule'! !

!ReEmptyExceptionHandlerRule commentStamp: ''!
Empty exception handler blocks hide potential bugs. The situation should be handled in a more robust way.

[  .... ]
	on: Error
	do: [  ]
	
having an empty block is a bad idea because the program silently fails.!
!ReEmptyExceptionHandlerRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matches:
		'`@block 
			on: `exception
			do: [ :`@err | | `@temps | ]'! !

!ReEmptyExceptionHandlerRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReEmptyExceptionHandlerRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Empty exception handler'! !

!ReEmptyExceptionHandlerRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	| exception class |
	exception := mappingDict at: '`exception'.
	
	exception isVariable ifFalse: [ ^ false ].
	(class := aNode methodNode methodClass environment classNamed: exception name) ifNil: [ ^ false ].
	(class includesBehavior: Exception) ifFalse: [ ^ false ].
	(class includesBehavior: Notification) ifTrue: [ ^false ].
	
	^ true! !

!ReEmptyExceptionHandlerRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'EmptyExceptionHandlerRule'! !

!ReEndTrueFalseRule commentStamp: ''!
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 ]!
!ReEndTrueFalseRule methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self matchesAny:
			#('`@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]')! !

!ReEndTrueFalseRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Checks for ifTrue:ifFalse: blocks that have the same code at the beginning or end.'! !

!ReEndTrueFalseRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReEndTrueFalseRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReEndTrueFalseRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Check for same statements at end of ifTrue:ifFalse: blocks'! !

!ReEndTrueFalseRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	"after a node was match you can do a post-validation here on the node and the dictionalry of wildcars with matched nodes as values"

	^ mappingDict
		ifNil: [ | statement |
			statement := aNode arguments first body statements last.
			( statement isVariable and: [ statement = aNode arguments last body statements last ] ) not] 
		ifNotNil: [ true ]! !

!ReEndTrueFalseRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'EndTrueFalseRule'! !

!ReEntityCriticized commentStamp: ''!
I am an event of an entity being criticized by the rules. Happens when #critics is called!
!ReEqualNilRule commentStamp: ''!
Replaces = nil and == nil by isNil, ~= nil and ~~ nil by notNil to make the code more readable.  !
!ReEqualNilRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: '``@object = nil' with: '``@object isNil';
		replace: '``@object == nil' with: '``@object isNil';
		replace: '``@object ~= nil' with: '``@object notNil';
		replace: '``@object ~~ nil' with: '``@object notNil'! !

!ReEqualNilRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReEqualNilRule methodsFor: 'accessing' stamp: ''!
name
	^ '= nil -> isNil AND ~= nil -> notNil'! !

!ReEqualNilRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'EqualNilRule'! !

!ReEqualNotUsedRule commentStamp: ''!
Checks for senders of comparator messages that do not use the result of the comparison.!
!ReEqualNotUsedRule methodsFor: 'running' stamp: ''!
basicCheck: node
	^ node isMessage and: [ node isUsed not and: [ #(#= #== #~= #~~ #< #> #<= #>=) includes: node selector ] ]! !

!ReEqualNotUsedRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReEqualNotUsedRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Doesn''t use the result of a =, ~=, etc.'! !

!ReEqualNotUsedRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'EqualNotUsedRule'! !

!ReEqualsTrueRule commentStamp: ''!
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.!
!ReEqualsTrueRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReEqualsTrueRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	| parent |
	aNode isLiteralNode ifFalse: [ ^ false ].
	(#(true false) includes: aNode value) ifFalse: [ ^ false ].
	(parent := aNode parent) ifNil: [ ^ false ].
	parent isMessage ifFalse: [ ^ false ].
	^ #(#= #== #~= #~~) includes: parent selector! !

!ReEqualsTrueRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReEqualsTrueRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Unnecessary "= true"'! !

!ReEqualsTrueRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'EqualsTrueRule'! !

!ReEquivalentSuperclassMethodsRule commentStamp: ''!
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!
!ReEquivalentSuperclassMethodsRule methodsFor: 'accessing' stamp: ''!
ignoredSelectors
	"These methods are often overridden for compatilbity with other platforms."

	^ #(new initialize)! !

!ReEquivalentSuperclassMethodsRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Check for methods that are equivalent to their superclass methods.'! !

!ReEquivalentSuperclassMethodsRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	(self ignoredSelectors includes: aMethod selector) ifTrue: [ ^ false ].

	^ aMethod methodClass superclass
		ifNotNil: [ :superclass | (superclass lookupSelector: aMethod selector)
			ifNotNil: [ :overridenMethod | aMethod equivalentTo: overridenMethod ]
			ifNil: [ false ] ]
		ifNil: [ false ]! !

!ReEquivalentSuperclassMethodsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReEquivalentSuperclassMethodsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Methods equivalently defined in superclass'! !

!ReEquivalentSuperclassMethodsRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReEquivalentSuperclassMethodsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'EquivalentSuperclassMethodsRule'! !

!ReExceptionProperty commentStamp: ''!
This property represents exceptions that occured during other properties computation. This way tools can work witout interuptions, but users will be aware the there were some exceptions.!
!ReExceptionProperty methodsFor: 'accessing' stamp: ''!
message: anObject
	message := anObject! !

!ReExceptionProperty methodsFor: 'actions' stamp: ''!
actions

	^ { (RePropertyAction new
		   icon: (self iconNamed: #smallDebug);
		   description: 'Debug the exception';
		   action: [ :prop | 
			   (OupsDebugRequest newForContext: prop stack)
				   label: prop message;
				   submit ];
		   yourself) }! !

!ReExceptionProperty methodsFor: 'accessing' stamp: ''!
stack
	^ stack! !

!ReExceptionProperty methodsFor: 'accessing' stamp: ''!
stack: anObject
	stack := anObject! !

!ReExceptionProperty methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #exceptionIcon! !

!ReExceptionProperty methodsFor: 'accessing' stamp: ''!
message
	^ message! !

!ReExceptionProperty methodsFor: 'accessing' stamp: ''!
title
	^ '~Exception: [', message, ']'! !

!ReExceptionProperty class methodsFor: 'instance creation' stamp: ''!
for: anEntity with: anException
	
	^ self new
		initializeSourceAnchor: (
			ReSourceAnchor entity: anEntity);
		stack: anException signalerContext copyStack;
		message: anException description;
		yourself
		! !

!ReExceptionStrategy commentStamp: ''!
The subclasses of this class define how Renraku should handle exceptions signalled by analyzers!
!ReExceptionStrategy class methodsFor: 'accessing' stamp: ''!
current

	^ current ifNil: [ current := ReLogExceptionStrategy ]! !

!ReExceptionStrategy class methodsFor: 'accessing' stamp: ''!
current: aStrategy

	^ current := aStrategy! !

!ReExceptionStrategy class methodsFor: 'accessing' stamp: ''!
strategyDescription
	"a string that will be used as a part of the setting explenation"

	^ self subclassResponsibility! !

!ReExceptionStrategy class methodsFor: 'accessing' stamp: ''!
strategyTitle
	"a string the will be displayed for the setting option"

	^ self subclassResponsibility! !

!ReExceptionStrategy class methodsFor: 'settings' stamp: ''!
settingDescription
	
	^ String streamContents: [ :stream |
		stream nextPutAll: 'The selected strategy defines how to handle exceptions that occur during a renraku validation of an entity.'.
		stream cr.
		
		self allSubclassesDo: [ :cls |
			stream
				cr;
				nextPutAll: cls strategyTitle;
				nextPutAll: ': ';
				nextPutAll: cls strategyDescription ] ]! !

!ReExceptionStrategy class methodsFor: 'settings' stamp: ''!
exceptionStrategySettingsOn: aBuilder
	<systemsettings>
	
	(aBuilder pickOne: #current)
		label: 'Exception handling strategy';
		target: self;
		parent: #qualityAssistant;
		default: ReLogExceptionStrategy;
		description: self settingDescription;
		domainValues: (
			self allSubclasses collect: [ :c |
				c strategyTitle -> c ])! !

!ReExceptionStrategy class methodsFor: 'error handling' stamp: ''!
handle: anException about: anEntity forPropertiesDo: aBlock
	"do something with anException that occured during anEntity validation.
	in case you want to produce a new renraku property evaluate aBlock with it"
	
	self subclassResponsibility ! !

!ReExceptionStrategyBaseTest commentStamp: ''!
A super test case that (re)stores  the setting value!
!ReExceptionStrategyBaseTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	currentStrategy := ReExceptionStrategy current.! !

!ReExceptionStrategyBaseTest methodsFor: 'running' stamp: ''!
tearDown
	
	ReExceptionStrategy current: currentStrategy.
	super tearDown.! !

!ReExceptionStrategyBaseTest methodsFor: 'helpers' stamp: ''!
errorMessage

	^ 'test message'! !

!ReExceptionStrategyBaseTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self = ReExceptionStrategyBaseTest! !

!ReExceptionStrategyTest methodsFor: 'tests' stamp: ''!
testSettingDescription

	ReExceptionStrategy allSubclassesDo: [ :strategy |
		self assert: (
			ReExceptionStrategy settingDescription
				includesSubstring: strategy strategyDescription) ]! !

!ReExcessiveArgumentsRule commentStamp: ''!
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.

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.!
!ReExcessiveArgumentsRule methodsFor: 'private' stamp: ''!
argumentsCount
	^ 5! !

!ReExcessiveArgumentsRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Long argument lists (five or more) can indicate that a new object should be created to wrap the numerous parameters.'! !

!ReExcessiveArgumentsRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod

	"If method includes UFFI calls then it is OK to have high number of arguments"
	aMethod isFFIMethod ifTrue: [ ^false ].
 
	^ aMethod numArgs >= self argumentsCount! !

!ReExcessiveArgumentsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReExcessiveArgumentsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Excessive number of arguments'! !

!ReExcessiveArgumentsRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReExcessiveArgumentsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ExcessiveArgumentsRule'! !

!ReExcessiveArgumentsRuleTest commentStamp: ''!
This class contains tests for class `ReExcessiveArgumentsRule`!
!ReExcessiveArgumentsRuleTest methodsFor: 'tests' stamp: ''!
longArgMethodCallingFFI: arg1 with: arg2 with: arg3 with: arg4 with: arg5
	"This method should not be critisized as it includes an FFI call"
	
	^self ffiCall: #( 
			int SomeFFI(
     				String* arg1,
         			String* arg2,
     				String* arg3,
     				String* arg4,
        			int arg5)) module: #someModule! !

!ReExcessiveArgumentsRuleTest methodsFor: 'tests' stamp: ''!
longArgMethod: arg1 with: arg2 with: arg3 with: arg4 with: arg5
	"This method should be critisized due to too many arguments"
	
	^self! !

!ReExcessiveArgumentsRuleTest methodsFor: 'tests' stamp: ''!
testRuleNotApplyToFFICallingMethods

	| critiques|	
	critiques := self myCritiquesOnMethod: self class >> #longArgMethodCallingFFI:with:with:with:with:.	
	self assert: critiques isEmpty! !

!ReExcessiveArgumentsRuleTest methodsFor: 'tests' stamp: ''!
testRule

	| critiques|	
	critiques := self myCritiquesOnMethod: self class >> #longArgMethod:with:with:with:with:.	
	self assert: critiques size equals: 1! !

!ReExcessiveInheritanceRule commentStamp: ''!
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.

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.!
!ReExcessiveInheritanceRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Deep inheritance (10+ depth) is usually a sign of a design flaw.'! !

!ReExcessiveInheritanceRule methodsFor: 'enumerating' stamp: ''!
basicCheck: aClass
	aClass isMeta ifTrue: [ ^ false ].
	
	^ aClass allSuperclasses size >= self inheritanceDepth! !

!ReExcessiveInheritanceRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReExcessiveInheritanceRule methodsFor: 'private' stamp: ''!
inheritanceDepth
	^ 10! !

!ReExcessiveInheritanceRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Excessive inheritance depth'! !

!ReExcessiveInheritanceRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReExcessiveInheritanceRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ExcessiveInheritanceRule'! !

!ReExcessiveMethodsRule commentStamp: ''!
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.

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.!
!ReExcessiveMethodsRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Large classes are indications that the class may be trying to do too much.'! !

!ReExcessiveMethodsRule methodsFor: 'running' stamp: ''!
basicCheck: aClass
	^ aClass selectors size >= self methodsCount! !

!ReExcessiveMethodsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReExcessiveMethodsRule methodsFor: 'private' stamp: ''!
methodsCount
	^ 60! !

!ReExcessiveMethodsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Excessive number of methods'! !

!ReExcessiveMethodsRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReExcessiveMethodsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ExcessiveMethodsRule'! !

!ReExcessiveVariablesRule commentStamp: ''!
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.!
!ReExcessiveVariablesRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Classes that have too many instance variables (10+) could be redesigned to have fewer fields, possibly through some nested object grouping.'! !

!ReExcessiveVariablesRule methodsFor: 'running' stamp: ''!
basicCheck: aClass
	^ aClass instVarNames size >= self variablesCount or: [ 
		"Shared pools are just there to define vars, so it is ok for them to have a lot"
		(aClass instanceSide isPool not) and: [aClass classVarNames size >= self variablesCount ]]! !

!ReExcessiveVariablesRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReExcessiveVariablesRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Excessive number of variables'! !

!ReExcessiveVariablesRule methodsFor: 'private' stamp: ''!
variablesCount
	^ 10! !

!ReExcessiveVariablesRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReExcessiveVariablesRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ExcessiveVariablesRule'! !

!ReExclusivelyBeginnersRule commentStamp: ''!
I represent an abstract class for rules that are meant exclusively for beginners.

My subclasses will only be enabled if the 'Beginners' profile is selected in the settings. To make rules that are meant for beginners and non-beginners you should inherit from other Rule class and overwrite the 'isBeginnerRule' to return true. !
!ReExclusivelyBeginnersRule class methodsFor: 'manifest' stamp: ''!
isDefaultRule
	^ false! !

!ReExclusivelyBeginnersRule class methodsFor: 'manifest' stamp: ''!
isBeginnerRule
	^ true! !

!ReExclusivelyBeginnersRule class methodsFor: 'testing' stamp: ''!
isAbstract

	 ^ self = ReExclusivelyBeginnersRule! !

!ReExplicitRequirementMethodsRule commentStamp: ''!
Classes that use traits with explicit requirement methods should either implement the method or inherit it.!
!ReExplicitRequirementMethodsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReExplicitRequirementMethodsRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCritiqueBlock
	| explicitRequirementMethods |
	aClass isTrait ifTrue: [ ^ self ].

	"Maybe the subclasses will define the method, so we should not raise a critic on abstract classes."
	aClass isAbstract ifTrue: [ ^ self ].

	explicitRequirementMethods := aClass traitComposition allSelectors
		collect: [ :selector | aClass >> selector ]
		thenSelect: [ :method | method isRequired and: [ method isSubclassResponsibility not ] ].

	explicitRequirementMethods
		select: [ :method | aClass withAllSuperclasses noneSatisfy: [ :superclass | superclass canPerform: method selector ] ]
		thenDo: [ :method | 
			aCritiqueBlock
				cull:
					((self critiqueFor: aClass)
						tinyHint: method selector;
						yourself) ]! !

!ReExplicitRequirementMethodsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Explicit requirement methods'! !

!ReExplicitRequirementMethodsRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReExplicitRequirementMethodsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName

	^ 'ExplicitRequirementMethodsRule'! !

!ReExtraBlockRule commentStamp: ''!
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!
!ReExtraBlockRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReExtraBlockRule methodsFor: 'enumerating' stamp: ''!
basicCheck: node
	node isMessage ifFalse: [ ^ false ].
	node receiver isBlock ifFalse: [ ^ false ].
	node parent isCascade ifTrue: [ ^ false ].
	^ self blockEvaluatingMessages includes: node selector! !

!ReExtraBlockRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReExtraBlockRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Block immediately evaluated'! !

!ReExtraBlockRule methodsFor: 'enumerating' stamp: ''!
blockEvaluatingMessages
	^ #(value 
	value: value:value: value:value:value: value:value:value:value:
	cull: cull:cull: cull:cull:cull: cull:cull:cull:cull:
	#valueWithArguments: valueWithPossibleArgs: valueWithPossibleArgument)! !

!ReExtraBlockRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ExtraBlockRule'! !

!ReFeedbacker commentStamp: ''!
I am reporting complaints about critics. No one should use me dirrectly. Use ReCritic>>#reportUselessness instead!
!ReFeedbacker class methodsFor: 'actions' stamp: ''!
feedback: aComment positive: aBoolean about: aReCritic 
	[ 
	ZnClient new
		beOneShot;
		http;
		host: 'renraku.inf.usi.ch';
		addPath: 'feedback';
		formAt: 'uuid' put: self uuid asString;
		formAt: 'pharoVersion' put: SystemVersion current highestUpdate asString;
		formAt: 'author' put: Author fullName;
		formAt: 'rule' put: aReCritic rule class name;
		formAt: 'target' put: aReCritic sourceAnchor entity name;
		formAt: 'time' put: DateAndTime now asString;
		formAt: 'positive' put: aBoolean asString;
		formAt: 'comment' put: aComment;
		post ]
		on: NetworkError
		do: [ :ex | ^ false ].
		
	^ true! !

!ReFeedbacker class methodsFor: 'properties' stamp: ''!
uuid
	^ uuid ifNil: [ uuid := UUID new ]! !

!ReFeedbacker class methodsFor: 'actions' stamp: ''!
positiveFeedback: aComment about: aReCritic
	
	^ self feedback: aComment positive: true about: aReCritic! !

!ReFeedbacker class methodsFor: 'actions' stamp: ''!
negativeFeedback: aComment about: aReCritic
	
	^ self feedback: aComment positive: false about: aReCritic! !

!ReFileBlocksRule commentStamp: ''!
Checks assignment to a variable that is the first statement inside the value block that is also used in the unwind block. For example

| inputStream  |
    [
    inputStream := self openStream. "may fail !!"
    inputStream doSomeOperation. "may fail !!"
    ] ensure: [ inputStream ifNotNil: [ inputStream close ]].

 if "openStream" fails, we don't need to ensure the stream is closed.
And otherwise, if we move the assignment outside of the block, we don't need
an "ifNotNil"-check for the ensure block if "doSomeOperation" fails.
This code can be changed to

| inputStream  |
    inputStream := self openStream. "may fail !!"
    [inputStream doSomeOperation. "may fail !!"
    ] ensure: [ inputStream close ].!
!ReFileBlocksRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'[| `@temps | 
				`var := `@object.  
				`@.statements] 
						ensure: 
							[`var `@messages: `@args]'
			'[| `@temps | 
				`var := `@object.  
				`@.statements] 
						ifCurtailed: 
							[`var `@messages: `@args]' )! !

!ReFileBlocksRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Checks assignment to a variable that is the first statement inside the value block that is also used in the unwind block.'! !

!ReFileBlocksRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReFileBlocksRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Assignment inside unwind blocks should be outside.'! !

!ReFileBlocksRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'FileBlocksRule'! !

!ReFloatEqualityComparisonRule commentStamp: ''!
Floating point types are imprecise. Using the operators = or ~= might not yield the expected result due to internal rounding differences.!
!ReFloatEqualityComparisonRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'`#floatLiteral = `@expr'
			'`#floatLiteral ~= `@expr'
			'`@expr = `#floatLiteral'
			'`@expr ~= `#floatLiteral' )! !

!ReFloatEqualityComparisonRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReFloatEqualityComparisonRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Float equality comparison'! !

!ReFloatEqualityComparisonRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	^ (mappingDict at: '`#floatLiteral') value isFloat! !

!ReFloatEqualityComparisonRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'FloatEqualityComparisonRule'! !

!ReGlobalVariablesUsageRule commentStamp: ''!
Global Variables are a known design smell. 

Specially in Pharo, we do not want to keep global bindings because their usage can a will produce undesirable implicit coupling, avoiding out language to evolve into the usage of powerful modules. !
!ReGlobalVariablesUsageRule methodsFor: 'running' stamp: ''!
rationale
	^ 'http://wiki.c2.com/?GlobalVariablesAreBad
	
	Why Global Variables Should Be Avoided When Unnecessary

    Non-locality -- Source code is easiest to understand when the scope of its individual elements are limited. Global variables can be read or modified by any part of the program, making it difficult to remember or reason about every possible use.
    No Access Control or Constraint Checking -- A global variable can be get or set by any part of the program, and any rules regarding its use can be easily broken or forgotten. (In other words, get/set accessors are generally preferable over direct data access, and this is even more so for global data.) By extension, the lack of access control greatly hinders achieving security in situations where you may wish to run untrusted code (such as working with 3rd party plugins).
    Implicit coupling -- A program with many global variables often has tight couplings between some of those variables, and couplings between variables and functions. Grouping coupled items into cohesive units usually leads to better programs.
    Concurrency issues -- if globals can be accessed by multiple threads of execution, synchronization is necessary (and too-often neglected). When dynamically linking modules with globals, the composed system might not be thread-safe even if the two independent modules tested in dozens of different contexts were safe.
    Namespace pollution -- Global names are available everywhere. You may unknowingly end up using a global when you think you are using a local (by misspelling or forgetting to declare the local) or vice versa. Also, if you ever have to link together modules that have the same global variable names, if you are lucky, you will get linking errors. If you are unlucky, the linker will simply treat all uses of the same name as the same object.
    Memory allocation issues -- Some environments have memory allocation schemes that make allocation of globals tricky. This is especially true in languages where "constructors" have side-effects other than allocation (because, in that case, you can express unsafe situations where two globals mutually depend on one another). Also, when dynamically linking modules, it can be unclear whether different libraries have their own instances of globals or whether the globals are shared.
    Testing and Confinement - source that utilizes globals is somewhat more difficult to test because one cannot readily set up a ''clean'' environment between runs. More generally, source that utilizes global services of any sort (e.g. reading and writing files or databases) that aren''t explicitly provided to that source is difficult to test for the same reason. For communicating systems, the ability to test system invariants may require running more than one ''copy'' of a system simultaneously, which is greatly hindered by any use of shared services - including global memory - that are not provided for sharing as part of the test. 
	
	'! !

!ReGlobalVariablesUsageRule methodsFor: 'running' stamp: ''!
group
	^ 'Design Flaws'! !

!ReGlobalVariablesUsageRule methodsFor: 'testing' stamp: ''!
isKnownGlobal: aString
	^ #(
			ActiveEvent
			ActiveHand
			ActiveWorld
			Display
			Processor
			Smalltalk
			SourceFiles
			SystemOrganization
			Transcript
			Undeclared
			World
		) includes: aString! !

!ReGlobalVariablesUsageRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	aMethod ast allChildren
		select: [ :node |
				node isGlobalVariable and: [
					node variable isGlobalClassNameBinding not and: [
					(self isKnownGlobal: node name) not ] ] ]
		thenDo: [ :node |
			aCriticBlock cull: (self
				createTrivialCritiqueOn: aMethod
				intervalOf: node
				hint: node name) ]! !

!ReGlobalVariablesUsageRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Global variable usage'! !

!ReGlobalVariablesUsageRule class methodsFor: 'testing-interest' stamp: ''!
checksMethod
	^ true! !

!ReGlobalVariablesUsageRuleTest commentStamp: ''!
A RBGlobalVariablesUsageTest is a test class for testing the behavior of RBGlobalVariablesUsage!
!ReGlobalVariablesUsageRuleTest methodsFor: 'running' stamp: ''!
tearDown
	self class compile: (Smalltalk globals at: #MyGlobal).
	Smalltalk globals removeKey: #MyGlobal.

	super tearDown! !

!ReGlobalVariablesUsageRuleTest methodsFor: 'sample' stamp: ''!
sampleMethod
	"Global variable are stored in Smalltalk globals, and one should avoid them when possible. 
	Examples are Display and Sensor"
	
	"Note: we compile this method in #setUp and #tearDown to add
	a global variable that would otherwise be undeclared"
	Smalltalk value.! !

!ReGlobalVariablesUsageRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| critiques |
 	critiques := self myCritiques.

	"Sensor and Display are both known globals"
 	self assert: critiques size equals: 1.
 	self assert: (self sourceAtChritique: critiques first) equals: 'MyGlobal'! !

!ReGlobalVariablesUsageRuleTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	"Register a new unknown global"
	Smalltalk globals
		at: #MyGlobal
		put: (self class >> #sampleMethod) sourceCode.
		
	self class compile: 'sampleMethod
	sampleMethod
		Smalltalk value.
		MyGlobal value'! !

!ReGuardClauseRule commentStamp: ''!
Transforms single branch conditionals with multi-statement bodies into a sequence of statements guarded by a conditional return.
For example

[[[ 
foo 
	statements. 
	condition ifTrue: [ statement1. statement2 ]
]]]

is transformed into 

[[[  
foo
	statements.
	condition ifFalse: [^self].
	statement1.
	statement2.
]]]!
!ReGuardClauseRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		addMatchingMethod: '`@methodName: `@args 
					| `@temps | 
					`@.Statements. 
					`@condition ifTrue: [| `@trueTemps | `.Statement1. `.Statement2. `@.Statements1]'
		rewriteTo: '`@methodName: `@args
					| `@temps `@trueTemps |
					`@.Statements.
					`@condition ifFalse: [^self].
					`.Statement1.
					`.Statement2.
					`@.Statements1';
		addMatchingMethod: '`@methodName: `@args 
					| `@temps | 
					`@.Statements. 
					`@condition ifFalse: [| `@falseTemps | `.Statement1. `.Statement2. `@.Statements1]'
		rewriteTo: '`@methodName: `@args
					| `@temps `@falseTemps |
					`@.Statements.
					`@condition ifTrue: [^self].
					`.Statement1.
					`.Statement2.
					`@.Statements1'! !

!ReGuardClauseRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReGuardClauseRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Replace single branch conditional with guard clause'! !

!ReGuardingClauseRule commentStamp: ''!
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.!
!ReGuardingClauseRule methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self addMatchingMethod: 
				'`@MethodName: `@args 
				| `@temps | 
				`@.Statements. 
				`@condition ifTrue: [| `@BlockTemps | `.Statement1. `.Statement2. `@.BStatements]'.
	self addMatchingMethod: 
				'`@MethodName 
				`@.Statements. 
				`@condition ifFalse: [| `@BlockTemps | `.Statement1. `.Statement2. `@.BStatements]'! !

!ReGuardingClauseRule methodsFor: 'accessing' stamp: ''!
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.'! !

!ReGuardingClauseRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReGuardingClauseRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Guarding clauses'! !

!ReGuardingClauseRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'GuardingClauseRule'! !

!ReIconHardcodedMessageRule commentStamp: ''!
According to the new API you should use

	self iconNamed: #symbol
	
Instead of

	Smalltalk ui icons iconNamed: #symbol!
!ReIconHardcodedMessageRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: 'Smalltalk ui icons `iconName'
		byEvaluating: [ :node :matchMap | 
			RBParser
				parseExpression: 'self iconNamed: #' , (matchMap at: #'`iconName') ]! !

!ReIconHardcodedMessageRule methodsFor: 'accessing' stamp: ''!
severity

	^ #error! !

!ReIconHardcodedMessageRule methodsFor: 'accessing' stamp: ''!
group

	^ 'API Change'! !

!ReIconHardcodedMessageRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Use self iconNamed: #symbol instead of asIcon or Smalltalk ui icons iconNamed: #symbol'! !

!ReIfNotNilDoRule commentStamp: ''!
ifNotNilDo: should not be used as ifNotNil: works for blocks with arguments, too.!
!ReIfNotNilDoRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: '`@receiver ifNotNilDo: `@statements'
			with: '`@receiver ifNotNil: `@statements';	
		replace: '`@receiver ifNotNilDo: `@statements1 ifNil: `@statements2'
			with: '`@receiver ifNotNil: `@statements1 ifNil: `@statements2';
		replace: '`@receiver ifNil: `@statements1 ifNotNilDo: `@statements2'
			with: '`@receiver ifNil: `@statements1 ifNotNil: `@statements2'! !

!ReIfNotNilDoRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReIfNotNilDoRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Use "ifNotNil:" not "ifNotNilDo:"'! !

!ReIfNotNilDoRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName

	^ 'RuleIfNotNilDo'! !

!ReIgnoreExceptionStrategy commentStamp: ''!
Ignore the exception silently and continue the execution!
!ReIgnoreExceptionStrategy class methodsFor: 'accessing' stamp: ''!
strategyDescription

	^ 'Ignore the exception silently and continue the execution'! !

!ReIgnoreExceptionStrategy class methodsFor: 'accessing' stamp: ''!
strategyTitle

	^ 'Ignore Exception'! !

!ReIgnoreExceptionStrategy class methodsFor: 'error handling' stamp: ''!
handle: anException about: anEntity forPropertiesDo: aBlock

	"do nothing"! !

!ReImageRuleBaner commentStamp: ''!
A pluggable functionality used to ban rules in the image scale!
!ReImageRuleBaner class methodsFor: 'properties' stamp: ''!
reBanName
	^ 'The whole image'! !

!ReImageRuleBaner class methodsFor: 'actions' stamp: ''!
ban: aCritique
	
	ReSystemAnnouncer uniqueInstance
		notifyCritique: aCritique
		of: aCritique sourceAnchor entity
		bannedOn: self.

	aCritique rule class enabled: false! !

!ReImplementedNotSentRule commentStamp: ''!
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
		 
NOTE: the rule updates its data with messages send in new methods, but does not remove messages till the next image startup. The reason is that it would be to slow to re-calculate the data at each method removal.

It can be forced to update by executing:

	ReImplementedNotSentRule reset!
!ReImplementedNotSentRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReImplementedNotSentRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	"Check if there are any senders. Furthermore methods with pragmas are likely to be sent through reflection, thus do not report those."

	aMethod pragmas ifNotEmpty: [ ^ false ].
	aMethod isTestMethod ifTrue: [ ^ false ].

	^ (self class allMessages includes: aMethod selector) not! !

!ReImplementedNotSentRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReImplementedNotSentRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Methods implemented but not sent'! !

!ReImplementedNotSentRule class methodsFor: 'announcement' stamp: ''!
unsubscribe

	SystemAnnouncer uniqueInstance unsubscribe: self! !

!ReImplementedNotSentRule class methodsFor: 'class initialization' stamp: ''!
initialize
	"we do not want to register if the rule is disabled"
	self enabled ifFalse: [ ^self ].
	self reset.
	self subscribe.
	SessionManager default 
		registerToolClassNamed: self name! !

!ReImplementedNotSentRule class methodsFor: 'accessing' stamp: ''!
allMessages
	"return all 'message sends' in the system and cache them"

	^allMessages ifNil: [
		allMessages := IdentitySet new.
		Smalltalk globals allBehaviors do: [ :behavior | 
				behavior methodsDo: [ :method |
						allMessages addAll: method messages ] ].
		allMessages	]! !

!ReImplementedNotSentRule class methodsFor: 'announcement' stamp: ''!
subscribe
	<systemEventRegistration>
	self unsubscribe.
	
	SystemAnnouncer uniqueInstance weak
		when: MethodAdded    send: #methodAdded: to: self;
		when: MethodModified send: #methodModified: to: self! !

!ReImplementedNotSentRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReImplementedNotSentRule class methodsFor: 'cleanup' stamp: ''!
shutDown	
	self reset! !

!ReImplementedNotSentRule class methodsFor: 'accessing' stamp: ''!
enabled
	^ enabled ifNil: [ enabled := false ]! !

!ReImplementedNotSentRule class methodsFor: 'system announcements' stamp: ''!
methodAdded: anAnnouncement

	self allMessages addAll: anAnnouncement methodAdded messages! !

!ReImplementedNotSentRule class methodsFor: 'system announcements' stamp: ''!
methodModified: anAnnouncement

	self allMessages addAll: anAnnouncement newMethod messages! !

!ReImplementedNotSentRule class methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	super enabled: aBoolean.
	self reset.
	aBoolean 
		ifTrue: [ self subscribe ]
		ifFalse: [ self unsubscribe ]! !

!ReImplementedNotSentRule class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	allMessages := nil! !

!ReImplementedNotSentRule class methodsFor: 'cleanup' stamp: ''!
cleanUp
	self reset! !

!ReImplementedNotSentRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ImplementedNotSentRule'! !

!ReInconsistentMethodClassificationRule commentStamp: ''!
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 standard style in Pharo. 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.

!
!ReInconsistentMethodClassificationRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReInconsistentMethodClassificationRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReInconsistentMethodClassificationRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCritiqueBlock
	| ownerProtocol |
	ownerProtocol := aMethod protocol.
	ownerProtocol ifNil: [ ^ self ].
	((#('as yet unclassified' 'deprecation') includes: ownerProtocol)
				or: [ ownerProtocol first = $*	 ]) ifTrue: [ ^ self ].
	
	aMethod methodClass superclass ifNotNil: [ :superclass |
			(superclass lookupSelector: aMethod selector) ifNotNil: [ :superMethod |
				| superProtocol |
				superProtocol := superMethod protocol.
				(superProtocol isNil or: [ 
			 	 superProtocol == #'as yet unclassified' or: [ 
			 	 superProtocol first = $*	 ] ]) ifFalse: [ 
					ownerProtocol ~= superProtocol ifTrue: [
        aCritiqueBlock cull: ((self critiqueFor: aMethod) tinyHint: 'superclass categorizes as: ' , superProtocol) ]] ] ].! !

!ReInconsistentMethodClassificationRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Inconsistent method classification'! !

!ReInconsistentMethodClassificationRule methodsFor: 'helpers' stamp: ''!
critiqueFor: aMethod
	| supercategory |
	supercategory := (aMethod methodClass superclass lookupSelector:
		                  aMethod selector) protocol.
		
	^ (ReRefactoringCritique
		   withAnchor: (self anchorFor: aMethod)
		   by: self) refactoring: (RBMethodProtocolTransformation
			   protocol: { supercategory }
			   inMethod: aMethod selector
			   inClass: aMethod methodClass name) asRefactoring! !

!ReInconsistentMethodClassificationRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReInconsistentMethodClassificationRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'InconsistentMethodClassificationRule'! !

!ReInstVarInSubclassesRule commentStamp: ''!
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.

!
!ReInstVarInSubclassesRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'All subclasses of this class define the same variable. Most likely this variable should be pulled up to the superclass.'! !

!ReInstVarInSubclassesRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReInstVarInSubclassesRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReInstVarInSubclassesRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCritiqueBlock
 
	| subs sels |
	subs := aClass subclasses.
	subs size > 1 ifFalse: [ ^ self ].

	sels := subs flatCollect: #instVarNames as: Bag.
	
	sels asSet
		select: [ :sel | 
			(sels occurrencesOf: sel) == subs size ]
		thenDo: [ :sel | aCritiqueBlock cull: (
			(self critiqueFor: aClass)
				tinyHint: sel;
				refactoring: (
					RBPullUpInstanceVariableRefactoring
						variable: sel
						class: aClass);
				yourself) ]! !

!ReInstVarInSubclassesRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Same instance variable defined in ALL subclasses'! !

!ReInstVarInSubclassesRule methodsFor: 'running' stamp: ''!
critiqueFor: aClass
	^ ReRefactoringCritique
			withAnchor: (self anchorFor: aClass)
			by: self! !

!ReInstVarInSubclassesRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReInstVarInSubclassesRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'InstVarInSubclassesRule'! !

!ReInstanceVariableCapitalizationRule commentStamp: ''!
Instance variable names on the instance- and class-side should start with a lowercase letter.!
!ReInstanceVariableCapitalizationRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Style'! !

!ReInstanceVariableCapitalizationRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock

	aClass instVarNames
		select: [ :each | each first isUppercase ]
		thenDo: [ :each | aCriticBlock cull: (self critiqueFor: aClass about: each) ]! !

!ReInstanceVariableCapitalizationRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Instance variable capitalized'! !

!ReInstanceVariableCapitalizationRule methodsFor: 'running - helpers' stamp: ''!
critiqueFor: aClass about: aVarName

	| crit |
	crit := ReRefactoringCritique
		withAnchor: (ReVarSearchSourceAnchor
			entity: aClass
			string: aVarName)
		by: self.
	
	crit	
		tinyHint: aVarName;
		refactoring: (
			RBRenameInstanceVariableRefactoring
				rename: aVarName
				to: aVarName uncapitalized
				in: aClass).
				
	^ crit! !

!ReInstanceVariableCapitalizationRule class methodsFor: 'testing-interest' stamp: ''!
checksClass
	^ true! !

!ReIntervalSourceAnchor commentStamp: ''!
This anchor stores the actual interval object which is set during initialization.!
!ReIntervalSourceAnchor methodsFor: 'accessing' stamp: ''!
interval

	^ interval ! !

!ReIntervalSourceAnchor methodsFor: 'initialization' stamp: ''!
initializeEnitity: anEntiy interval: anInterval 
	
	self initializeEnitity: anEntiy.
	interval := anInterval ! !

!ReIntervalSourceAnchor methodsFor: 'testing' stamp: ''!
providesInterval

	^ true! !

!ReIntervalSourceAnchor class methodsFor: 'instance creation' stamp: ''!
entity: anEntity interval: anInterval 
	
	^ self basicNew
		initializeEnitity: anEntity
		interval: anInterval;
		yourself! !

!ReInvocationOrderCritique commentStamp: ''!
A critic which represents that there is an issue with the order of messages being sent!
!ReInvocationOrderCritique methodsFor: 'initialization' stamp: ''!
initializeRule: aRule sourceAnchor: anAnchor method: aString condition: aCondition

	self initializeRule: aRule sourceAnchor: anAnchor.
	targetMethodName := aString.
	condition := aCondition ! !

!ReInvocationOrderCritique methodsFor: 'testing' stamp: ''!
providesChange
	^ false! !

!ReInvocationOrderCritique class methodsFor: 'instance creation' stamp: ''!
withAnchor: anAnchor by: aRule method: aString condition: aCondition

	^ self new
		initializeRule:	aRule
		  sourceAnchor: anAnchor
		        method: aString
		     condition: aCondition;
		
		yourself! !

!ReInvocationSequenceRule commentStamp: ''!
I am checking for the violation in message sequences.

Subclass me and rewrite initialization method to all super initialize and then all the sequences with the methods for adding protocol.

Check the class side examples for examples.

You have to call
ReRuleManager reset
to make changes take place!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!ReInvocationSequenceRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	preConditions := Set new.
	postConditions := Set new.! !

!ReInvocationSequenceRule methodsFor: 'adding' stamp: ''!
add: postSelectors requiresPreSend: preSelectors

	preConditions add: (
		ReInvocationSequenceRuleSequence
			before: preSelectors
			after: postSelectors)! !

!ReInvocationSequenceRule methodsFor: 'critic creation' stamp: ''!
postCriticFor: ast at: node regarding: sequence

	^ self critic: ReLaterInvocationCritique for: ast at: node regarding: sequence ! !

!ReInvocationSequenceRule methodsFor: 'running' stamp: ''!
check: aNode forCritiquesDo: aCriticBlock

	aNode isMethod ifFalse: [ ^ self ].
	
	(self  preCheck: aNode forCriticsDo: aCriticBlock) &  
	(self postCheck: aNode forCriticsDo: aCriticBlock)! !

!ReInvocationSequenceRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Invocation order incorect'! !

!ReInvocationSequenceRule methodsFor: 'running' stamp: ''!
postCheck: anAST forCriticsDo: aCriticBlock
	| remainingPostConditions encounteredCritics |	
	postConditions ifEmpty: [ ^ false ].
	encounteredCritics := false.
	
	remainingPostConditions := postConditions copy.
	
	anAST reverseNodesDo: [ :node |
		
		remainingPostConditions ifEmpty: [ ^ encounteredCritics ].
		node isMessage ifTrue: [ 
			
			"remove the matched conditions while criticizing before-matches"
			remainingPostConditions removeAllSuchThat: [ :cond |
				| beforeMatched |
				(beforeMatched := cond beforeMatches: node selector) ifTrue: [ 
					
					encounteredCritics := true.
					aCriticBlock cull: (
						self postCriticFor: anAST at: node regarding: cond) ].
				 "if the following expression is true, the condition will be removed"
				beforeMatched or: [ cond afterMatches: node selector] ] ] ].
					

	^ encounteredCritics! !

!ReInvocationSequenceRule methodsFor: 'running' stamp: ''!
preCheck: anAST forCriticsDo: aCriticBlock
	| remainingPreConditions encounteredCritics |	
		
	preConditions ifEmpty: [ ^ false ].
	encounteredCritics := false.
	
	remainingPreConditions := preConditions copy.
	
	anAST nodesDo: [ :node |
		remainingPreConditions ifEmpty: [ ^ encounteredCritics ].
		node isMessage ifTrue: [ 
			
			"remove the matched conditions while criticizing after-matches"
			remainingPreConditions removeAllSuchThat:  [ :cond |
				| afterMatched |
				(afterMatched := cond afterMatches: node selector) ifTrue: [ 
					encounteredCritics := true.
					aCriticBlock cull: (
						self preCriticFor: anAST at: node regarding: cond) ].
				 
				"if the following expression is true, the condition will be removed"
				afterMatched or: [ cond beforeMatches: node selector] ] ] ].
					

	^ encounteredCritics! !

!ReInvocationSequenceRule methodsFor: 'adding' stamp: ''!
add: preSelectors requiresPostSend: postSelectors

	postConditions add: (
		ReInvocationSequenceRuleSequence
			before: preSelectors
			after: postSelectors)! !

!ReInvocationSequenceRule methodsFor: 'critic creation' stamp: ''!
critic: aCriticClass for: ast at: node regarding: sequence

	^ aCriticClass 
		withAnchor: (
			ReIntervalSourceAnchor
				entity: ast
				interval: node sourceInterval)
		by: self
		method: node selector
		condition: sequence
		! !

!ReInvocationSequenceRule methodsFor: 'critic creation' stamp: ''!
preCriticFor: ast at: node regarding: sequence

	^ self critic: RePriorInvocationCritique for: ast at: node regarding: sequence ! !

!ReInvocationSequenceRule class methodsFor: 'compiling' stamp: ''!
noteCompilationOf: aSelector meta: isMeta

	 aSelector == #initialize & isMeta not ifTrue: [ 
		ReRuleManager reset ]! !

!ReInvocationSequenceRule class methodsFor: 'examples' stamp: ''!
exampleSequenceMethods
	<sampleInstance>
	<gtExample>
	<label: 'You should not do this. Instead subclass and call #add:… in the initialization method'>
	
	^ self new
		add: #initiallize requiresPreSend: #(basicNew new);
		add: #(setAsFixed setAsNotFixed) requiresPostSend: #(add: addAll:);
		add: #edges requiresPreSend: #nodes! !

!ReInvocationSequenceRule class methodsFor: 'examples' stamp: ''!
checksNode
	^ true! !

!ReInvocationSequenceRule class methodsFor: 'testing' stamp: ''!
isVisible

	^ self name ~= #ReInvocationSequenceRule and: [ 
		super isVisible ]! !

!ReInvocationSequenceRuleSequence commentStamp: ''!
I simply hold the method names that have to be called before/after each other!
!ReInvocationSequenceRuleSequence methodsFor: 'accessing' stamp: ''!
after
	^ after! !

!ReInvocationSequenceRuleSequence methodsFor: 'printing' stamp: ''!
beforeDescriptionString

	^ self descriptionStringFor: before! !

!ReInvocationSequenceRuleSequence methodsFor: 'accessing' stamp: ''!
afterMatches: aSymbol
	^ after includes: aSymbol! !

!ReInvocationSequenceRuleSequence methodsFor: 'printing' stamp: ''!
descriptionStringFor: aSet

	^ aSet size = 1
		ifTrue: [ '#', aSet anyOne, ' message' ]
		ifFalse: [ 'any one of #', (aSet joinUsing: ', #'), ' messages' ]! !

!ReInvocationSequenceRuleSequence methodsFor: 'initialization' stamp: ''!
initializeBefore: beforeSymols after: afterSymbols

	before :=
		 (beforeSymols isCollection and:
		[ beforeSymols isString not ])
			ifFalse: [ Array with: beforeSymols asSymbol ]
			ifTrue: [ beforeSymols ].
	after := 
		(afterSymbols isCollection and:
		[ afterSymbols isString not ])
			ifFalse: [ Array with: afterSymbols asSymbol ]
			ifTrue: [ afterSymbols ].! !

!ReInvocationSequenceRuleSequence methodsFor: 'printing' stamp: ''!
afterDescriptionString

	^ self descriptionStringFor: after! !

!ReInvocationSequenceRuleSequence methodsFor: 'accessing' stamp: ''!
before
	^ before! !

!ReInvocationSequenceRuleSequence methodsFor: 'accessing' stamp: ''!
beforeMatches: aSymbol
	^ before includes: aSymbol! !

!ReInvocationSequenceRuleSequence class methodsFor: 'instance creation' stamp: ''!
before: beforeSymbol after: afterSymbol

	^ self new
		initializeBefore: beforeSymbol
		           after: afterSymbol;
		yourself! !

!ReIsNilAndConditionalRule commentStamp: ''!
Replaces isNil ifTrue , isNil ifFalse and isNil ifTrue:ifFalse by ifNil: , ifNotNil and ifNil:ifNotNil: to make the code more readable. Helps to avoid unnecesary temporal variables.!
!ReIsNilAndConditionalRule methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self
		replace: '``@receiver isNil ifFalse: ``@notNilBlock' with: '``@receiver ifNotNil: ``@notNilBlock';
		replace: '``@receiver isNil ifTrue: ``@nilBlock' with: '``@receiver ifNil: ``@nilBlock';
		replace: '``@receiver isNil ifTrue: ``@nilBlock ifFalse: ``@notNilBlock'
			with: '``@receiver ifNil: ``@nilBlock ifNotNil: ``@notNilBlock';
		replace: '``@receiver isNil ifFalse: ``@notNilBlock ifTrue: ``@nilBlock'
			with: '``@receiver ifNil: ``@nilBlock ifNotNil: ``@notNilBlock'! !

!ReIsNilAndConditionalRule methodsFor: 'accessing' stamp: ''!
rationale

	^ 'Using specific conditional methods leads to shorter code and helps in avoiding unneeded temporary variables.<n><n>Replaces<n><t>isNil ifTrue: ~~> ifNil:<n><t>isNil ifFalse: ~~> ifNotNil:<n><t>isNil ifTrue:ifFalse ~~> ifNil:ifNotNil:'
		expandMacros! !

!ReIsNilAndConditionalRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Coding Idiom Violation'! !

!ReIsNilAndConditionalRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Sends isNil and a conditional check instead of using #ifNil: #ifNotNil: or #ifNil:ifNotNil:'! !

!ReIvarNeitherReadNorWrittenRule commentStamp: ''!
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.!
!ReIvarNeitherReadNorWrittenRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReIvarNeitherReadNorWrittenRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock
	aClass slots
		select: [ :slot | slot isReferenced not ]
		thenDo: [ :slot | aCriticBlock cull: (self critiqueFor: aClass about: slot name) ]! !

!ReIvarNeitherReadNorWrittenRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Instance variable not read or not written'! !

!ReIvarNeitherReadNorWrittenRule class methodsFor: 'testing-interest' stamp: ''!
checksClass
	^ true! !

!ReJustSendsSuperRule commentStamp: ''!
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.!
!ReJustSendsSuperRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	matcher := RBParseTreeSearcher justSendsSuper! !

!ReJustSendsSuperRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Check for methods that just forward the message to its superclass.'! !

!ReJustSendsSuperRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReJustSendsSuperRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	^ aMethod ast isPrimitive not and: [ matcher executeMethod: aMethod ast initialAnswer: false ]! !

!ReJustSendsSuperRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReJustSendsSuperRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Method just sends super message'! !

!ReJustSendsSuperRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReJustSendsSuperRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'JustSendsSuperRule'! !

!ReKeysDoRule commentStamp: ''!
Replaces keys/values do: by keysDo: and valuesDo:.  This rule is based on the observation that using aDict keys do: or aDict values do: create an intermediary collection. 

Dictionary>>keys
	"Answer an Array containing the receiver's keys."
	
	^Array new: self size streamContents: [:s| self keysDo: [:key| s nextPut: key]]
	
This array can be quite large and using the keysDo: does not create such intermediate collection.!
!ReKeysDoRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: '``@object keys do: ``@block' with: '``@object keysDo: ``@block';
		replace: '``@object values do: ``@block' with: '``@object valuesDo: ``@block'! !

!ReKeysDoRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'The use of keysDo:/valuesDo: means one intermediate collection created less'! !

!ReKeysDoRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReKeysDoRule methodsFor: 'accessing' stamp: ''!
name
	^ 'keys do: -> keysDo: and valuesDo:'! !

!ReKeysDoRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'keysDoRule'! !

!ReLaterInvocationCritique commentStamp: ''!
A critic which represents that the method is missing some required messages after the one in questiong!
!ReLaterInvocationCritique methodsFor: 'accessing' stamp: ''!
description

	^ 'The functionality of #', targetMethodName, ' is intended to influence ', condition afterDescriptionString, '. In your case it is not followed by the previously mentioned messages which suggests that you are doing something wrong.' ! !

!ReLaterInvocationCritique methodsFor: 'accessing' stamp: ''!
title

	^ 'Message #', targetMethodName, ' not followed by ',
		(condition afterDescriptionString truncateWithElipsisTo: 30)! !

!ReLiteralArrayCharactersRule commentStamp: ''!
Literal arrays containing only characters can more efficiently represented as strings.!
!ReLiteralArrayCharactersRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	aNode isLiteralArray ifFalse: [ ^ false ].
	aNode value ifEmpty: [ ^ false ].
	^ aNode value allSatisfy: #isCharacter! !

!ReLiteralArrayCharactersRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReLiteralArrayCharactersRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Literal array contains only characters'! !

!ReLiteralArrayCharactersRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'LiteralArrayCharactersRule'! !

!ReLiteralArrayContainsCommaRule commentStamp: ''!
Checks for literal arrays that contain the #, symbol. The user may have thought that it was a separator.!
!ReLiteralArrayContainsCommaRule methodsFor: 'running' stamp: ''!
basicCheck: aNode

	aNode isLiteralArray ifFalse: [ ^ false ].
	
	"ffiCall: parameters and other UFFI call variants contain a $, so do not warn in this case"
	(aNode parent parent isMessage and: [ 
		 FFICompilerPlugin ffiCalloutSelectors includes: aNode parent parent selector ]) ifTrue: [ ^ false ].
	
	^ aNode value includes: #,! !

!ReLiteralArrayContainsCommaRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReLiteralArrayContainsCommaRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Literal array contains a #,'! !

!ReLiteralArrayContainsCommaRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'LiteralArrayContainsCommaRule'! !

!ReLiteralArrayContainsSuspiciousTrueFalseOrNilRule commentStamp: ''!
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. 
	 !
!ReLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	^ aNode isLiteralArray and: [ #(#true #false #nil) anySatisfy: [ :each | aNode value identityIncludes: each]]! !

!ReLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Literal array contains a #true, #false, or #nil.'! !

!ReLiteralArrayContainsSuspiciousTrueFalseOrNilRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'LiteralArrayContainsSuspiciousTrueFalseOrNilRule'! !

!ReLocalMethodsSameThanTraitRule commentStamp: ''!
If a class has a method in its trait composition, the method should not be implemented in the class.!
!ReLocalMethodsSameThanTraitRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReLocalMethodsSameThanTraitRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock
	"The comparison between methods is made using the ast, this is better than comparing source code only since it does not take into account identations, extra parenthesis, etc"

	aClass isTrait ifTrue: [ ^ self ].
	aClass hasTraitComposition ifFalse: [ ^ self ].
	aClass localMethods
		select: [ :method | 
			| traitCompositionMethod |
			traitCompositionMethod := aClass traitComposition compiledMethodAt: method selector ifAbsent: [ nil ].
			traitCompositionMethod notNil and: [ traitCompositionMethod ast = method ast ] ]
		thenDo: [ :duplicatedMethod |
			aCriticBlock cull:
				(ReRemoveMethodCritique for: aClass selector: duplicatedMethod selector by: self) ]! !

!ReLocalMethodsSameThanTraitRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Repeated methods in the trait composition'! !

!ReLocalMethodsSameThanTraitRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReLocalMethodsSameThanTraitRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'MethodInClassVsTrait'! !

!ReLogExceptionStrategy commentStamp: ''!
Report exception as a property (critique) which can be debuged afterwards!
!ReLogExceptionStrategy class methodsFor: 'accessing' stamp: ''!
strategyDescription

	^ 'Report exception as a property (critique) which can be debuged afterwards.'! !

!ReLogExceptionStrategy class methodsFor: 'accessing' stamp: ''!
strategyTitle

	^ 'Log Exception'! !

!ReLogExceptionStrategy class methodsFor: 'error handling' stamp: ''!
handle: anException about: anEntity forPropertiesDo: aBlock

	aBlock value: (
		ReExceptionProperty
			for: anEntity
			with: anException)
	
	! !

!ReLongMethodsRule commentStamp: ''!
This smell arises when a long method is found with meny statements. Note that, it counts statements, not lines. Long methods should often be split into several smaller ones. 

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. !
!ReLongMethodsRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'This smell arises when a long method is found (with {1} or more statements). Note that, it counts statements, not lines. Long methods should often be split into several smaller ones. 

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. '
	format: { self longMethodSize }! !

!ReLongMethodsRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	| numberOfStatements |
	numberOfStatements := 0.

	aMethod ast
		nodesDo: [ :node | 
			node isSequence
				ifTrue: [ numberOfStatements := numberOfStatements + node statements size.
					numberOfStatements >= self longMethodSize ifTrue: [ ^ true ] ] ].
	^ false! !

!ReLongMethodsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReLongMethodsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Long methods'! !

!ReLongMethodsRule methodsFor: 'private' stamp: ''!
longMethodSize
	^ 20! !

!ReLongMethodsRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReLongMethodsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'LongMethodsRule'! !

!ReMethodHasSyntaxErrorRule commentStamp: ''!
Methods can be compiled with syntax errors, fix the code and recompile the method!
!ReMethodHasSyntaxErrorRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReMethodHasSyntaxErrorRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	^aMethod isFaulty! !

!ReMethodHasSyntaxErrorRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReMethodHasSyntaxErrorRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Method source has syntax errors'! !

!ReMethodHasSyntaxErrorRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReMethodHasSyntaxErrorRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'MethodSyntaxError'! !

!ReMethodSignaturePeriodRule commentStamp: ''!
A rule to check for a period terminating the method signature, which is unnecessary, probably unintentional, and can cause problems when portin to other platforms like GemStone.!
!ReMethodSignaturePeriodRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReMethodSignaturePeriodRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock

	| firstLine hasDot |
	firstLine := aMethod sourceCode lines first.
	hasDot := firstLine trimRight last == $..
	hasDot ifTrue: [ 
		aCriticBlock cull: (ReTrivialCritique
				 withAnchor: (ReIntervalSourceAnchor
						  entity: aMethod
						  interval: (1 to: firstLine size))
				 by: self) ]! !

!ReMethodSignaturePeriodRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Method signature has terminating period'! !

!ReMethodSignaturePeriodRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReMethodSourceContainsLinefeedsRule commentStamp: ''!
Pharo code should not contain linefeed characters.!
!ReMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReMethodSourceContainsLinefeedsRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	| linefeeds |
	linefeeds := aMethod sourceCode allRangesOfSubstring: String lf.
	
	linefeeds do: [ :lfInterval |
			aCriticBlock cull: (ReTrivialCritique  
			withAnchor: (ReIntervalSourceAnchor
				entity: aMethod
				interval: lfInterval)
			by: self
			hint: 'lf') ]! !

!ReMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Method source contains linefeeds'! !

!ReMethodSourceContainsLinefeedsRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReMethodSourceContainsLinefeedsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'MethodSourceContainsLinefeedsRule'! !

!ReMethodSourceContainsLinefeedsRuleTest commentStamp: ''!
A RBMethodSourceContainsLinefeedsRuleTest is a test class for testing the behavior of RBMethodSourceContainsLinefeedsRule!
!ReMethodSourceContainsLinefeedsRuleTest methodsFor: 'sample' stamp: ''!
sampleMethod
	"This method contains two linefeeds which should be carriage returns."
	"There is one after this line" 7.
	"Noone here" 9.
	"and one here" 8 .
	"That was it." -1! !

!ReMethodSourceContainsLinefeedsRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| sampleMethod critiques|
	sampleMethod := 'sampleMethod
	"This method contains two linefeeds which should be carriage returns."
	"There is one after this line" 7.', String lf,
	'	"Noone here" 9.
	"and one here" 8 .', String lf,
	'	"That was it." -1'.
	self class compile: sampleMethod classified: 'test-help'.
 	critiques := self myCritiques .

 	self assert: critiques size equals: 2.
 	self assert: (self sourceAtChritique:  critiques first) equals: String lf.! !

!ReMinMaxRule commentStamp: ''!
The use of the messages #min: and #max: improves code readability and avoids heavily nested conditionals.

For example 

[[[ 
	a < b ifTrue: [a] ifFalse: [b]
]]]			

is transformed into 

[[[  
a min: b
]]]
			
		!
!ReMinMaxRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		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'! !

!ReMinMaxRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'The use of the messages #min: and #max: improves code readability and avoids heavily nested conditionals.'! !

!ReMinMaxRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReMinMaxRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Rewrite ifTrue:ifFalse: using min:/max:'! !

!ReMinMaxRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'MinMaxRule'! !

!ReMissingMethodCritique commentStamp: ''!
This kind of critiques occur when a method is missing. The critique knows what is the selector of the missing method, and it's perspective class. The critique provides a change which is a creation of the missing method. Also a sourcecode of a method can be specified. For now there are two shortcuts for the source code, that set it to either subclassResponsability or shouldBeImplemented !
!ReMissingMethodCritique methodsFor: 'actions' stamp: ''!
beSubclassResponsibility
	"set the sorce code of the method-to-be-created to subclassResponsibility"

	source := '^ self subclassResponsibility' ! !

!ReMissingMethodCritique methodsFor: 'testing' stamp: ''!
providesChange
	^ true! !

!ReMissingMethodCritique methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	source := ''! !

!ReMissingMethodCritique methodsFor: 'private' stamp: ''!
methodHeader

	 ^ ($: split: selector) allButLast
		ifEmpty: [ selector ]
		ifNotEmpty: [ :keywords |
			| index |
			index := 0.
			keywords inject: '' into: [ :header :keyword |
				header, keyword, ': arg', (index := index + 1) asString, ' ' ] ]! !

!ReMissingMethodCritique methodsFor: 'actions' stamp: ''!
beShouldBeImplemented
	"set the sorce code of the method-to-be-created to shouldBeImplemented"

	source := '^ self shouldBeImplemented' ! !

!ReMissingMethodCritique methodsFor: 'accessing' stamp: ''!
source
	"source code of the method-to-be-created excluding selector and args"
	^ source! !

!ReMissingMethodCritique methodsFor: 'accessing' stamp: ''!
change
	"an 'add method' change that create the missing method"
	
	^ (RBRefactoryChangeFactory instance) 
		addMethodSource: (self methodHeader), String cr, String tab, source
		in: class! !

!ReMissingMethodCritique methodsFor: 'accessing' stamp: ''!
source: anObject
	"set the source code of the method-to-be-created. This should not include the selector and args"

	source := anObject! !

!ReMissingMethodCritique methodsFor: 'initialization' stamp: ''!
initializeRule: aRule target: anEntity class: aClass selector: aSymbol

	self initializeRule: aRule target: anEntity.
	class := aClass.
	selector :=  aSymbol.
	
	tinyHint := class == self entity 
		ifTrue: [ selector ]
		ifFalse: [ class name, '>>#', selector ]! !

!ReMissingMethodCritique class methodsFor: 'instance creation' stamp: ''!
for: anEntity by: aRule class: aClass selector: aSymbol

	^ self basicNew 
		initializeRule: aRule target: anEntity class: aClass selector: aSymbol;
		yourself ! !

!ReMissingSubclassResponsibilityRule commentStamp: ''!
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.!
!ReMissingSubclassResponsibilityRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReMissingSubclassResponsibilityRule methodsFor: 'enumerating' stamp: ''!
check: aClass forCritiquesDo: aCritiqueBlock
	
	| subs |
	subs := aClass subclasses.
	(subs size > 1) ifTrue: 
		[ | sels noSuperSels |
		sels := Bag new.
		subs do: [ :each | sels addAll: each selectors ].
		noSuperSels := sels asSet select: [ :each | 
			((sels occurrencesOf: each) == subs size and: [
			(aClass canUnderstand: each) not ]) ].
		noSuperSels ifNotEmpty: [ 
			noSuperSels collect: [ :selector |
				(ReMissingMethodCritique
					for: aClass
					by: self
					class: aClass
					selector: selector)
					beSubclassResponsibility;
					yourself ]
				thenDo: [ :critic |
					aCritiqueBlock cull: critic ].
				^ self ] ].! !

!ReMissingSubclassResponsibilityRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Method defined in all subclasses, but not in superclass'! !

!ReMissingSubclassResponsibilityRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReMissingSubclassResponsibilityRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'MissingSubclassResponsibilityRule'! !

!ReMissingSuperSendsRule commentStamp: ''!
Checks that methods who 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.!
!ReMissingSuperSendsRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod

	| definer superMethod |
	aMethod methodClass isMeta ifTrue: [ ^ false ].
	(self methodsRequiringSuper includes: aMethod selector) ifFalse: [ ^ false ].

	definer := aMethod methodClass superclass ifNotNil: [ :sc | sc whichClassIncludesSelector: aMethod selector ].
	definer ifNil: [ ^ false ].

	"super defines same method"
	(aMethod superMessages includes: aMethod selector) ifTrue: [ ^ false ].

	"but I don't call it"
	superMethod := definer compiledMethodAt: aMethod selector ifAbsent: [  ].

	superMethod isReturnSelf ifTrue: [ ^ false ].
	^ (superMethod sendsSelector: #subclassResponsibility) not! !

!ReMissingSuperSendsRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Potential Bugs'! !

!ReMissingSuperSendsRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Missing super sends in selected methods.'! !

!ReMissingSuperSendsRule methodsFor: 'accessing' stamp: ''!
methodsRequiringSuper

	^ #( #release #postCopy #postBuildWith: #preBuildWith: #postOpenWith:
	     #noticeOfWindowClose: #initialize )! !

!ReMissingSuperSendsRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReMissingSuperSendsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'MissingSuperSendsRule'! !

!ReModifiesCollectionRule commentStamp: ''!
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.

For example turning

aCol do: [ :each |  ... aCol remove:... ]

into 

aCol copy do: [ :each |  ... aCol remove:... ]!
!ReModifiesCollectionRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		matchesAny: #(
			'`@collection do: [:`each | | `@temps | `@.Statements]' 
			'`@collection collect: [:`each | | `@temps | `@.Statements]' 
			'`@collection select: [:`each | | `@temps | `@.Statements]' 
			'`@collection reject: [:`each | | `@temps | `@.Statements]' 
			'`@collection inject: `@value into: [:`sum :`each | | `@temps | `@.Statements]')! !

!ReModifiesCollectionRule methodsFor: 'accessing' stamp: ''!
rationale
	
	^ 'Checks for remove:''s of elements inside of collection iteration methods such as do:. '! !

!ReModifiesCollectionRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReModifiesCollectionRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Modifies collection while iterating over it'! !

!ReModifiesCollectionRule methodsFor: 'private' stamp: ''!
modifiesCollection: aCollectionNode inAnyStatement: aStatementCollection 
	aStatementCollection do: [ :statement |
		statement nodesDo: [ :node |
			node = aCollectionNode ifTrue: [ ^ true ] ] ].

	^ false! !

!ReModifiesCollectionRule methodsFor: 'initialization' stamp: ''!
afterCheck: aNode mappings: mappingDict
	^ self
		modifiesCollection: (mappingDict at: '`@collection')
		inAnyStatement: (mappingDict at: '`@.Statements')! !

!ReModifiesCollectionRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ModifiesCollectionRule'! !

!ReMultipleCritiquesEvent commentStamp: ''!
A Renraku event with multiple critics.!
!ReMultipleCritiquesEvent methodsFor: 'accessing' stamp: ''!
critiques
	^ critiques! !

!ReMultipleCritiquesEvent methodsFor: 'accessing' stamp: ''!
critiques: aCollection
	critiques := aCollection! !

!ReMultiplePeriodsTerminatingStatementRule commentStamp: ''!
A rule to check for multiple periods terminating the same statement, which is unnecessary, probably unintentional, and can cause problems when porting to other platforms like GemStone.!
!ReMultiplePeriodsTerminatingStatementRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReMultiplePeriodsTerminatingStatementRule methodsFor: 'running' stamp: ''!
periodPairs: node critiqueBlock: aCriticBlock in: aMethod
	| periods |
	periods := node periods.
	2 to: periods size do: [ :index | |code start stop |
		start := periods at: index-1.
		stop := periods at: index.
		code := node methodNode sourceCode copyFrom: start+1 to: stop-1.
		code trim ifEmpty: [ 
			aCriticBlock cull: (ReTrivialCritique  
			withAnchor: (ReIntervalSourceAnchor
				entity: aMethod
				interval: (start to: stop))
			by: self
			hint: 'two periods') ] ]! !

!ReMultiplePeriodsTerminatingStatementRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	
	aMethod ast
		nodesDo: [ :node | 
			(node isSequence and:
			[ node periods size > node statements size ])
				ifTrue: [ 
					self periodPairs: node critiqueBlock: aCriticBlock in: aMethod ] ]! !

!ReMultiplePeriodsTerminatingStatementRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Multiple periods terminating the same statement'! !

!ReMultiplePeriodsTerminatingStatementRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReMultiplePeriodsTerminatingStatementRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName

	^ 'MultiplePeriodsTerminatingStatementRule'! !

!ReMultiplePeriodsTerminatingStatementRuleTest commentStamp: ''!
A RBMultiplePeriodsTerminatingStatementRuleTest is a test class for testing the behavior of RBMultiplePeriodsTerminatingStatementRule!
!ReMultiplePeriodsTerminatingStatementRuleTest methodsFor: 'sample' stamp: ''!
sampleMethod
	"I have two periods between statements"
	2+3.  .
	{1.2..3}.
	99.
.! !

!ReMultiplePeriodsTerminatingStatementRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| critiques |
	critiques := self myCritiques .
	
	self assert: critiques size equals: 2.
	self assert: (self sourceAtChritique: critiques first) equals: '.  .'.! !

!ReNoClassCommentRule commentStamp: ''!
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.!
!ReNoClassCommentRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Classes should have comments to explain their purpose, collaborations with other classes, and optionally provide examples of use.'! !

!ReNoClassCommentRule methodsFor: 'running' stamp: ''!
basicCheck: aClass
	(aClass isMeta or: [ aClass isTestCase ]) ifTrue: [ ^ false ].
	^ aClass hasComment not! !

!ReNoClassCommentRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReNoClassCommentRule methodsFor: 'accessing' stamp: ''!
name
	^ 'No class comment'! !

!ReNoClassCommentRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReNoClassCommentRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'NoClassCommentRule'! !

!ReNoNilAssignationInInitializeRule commentStamp: ''!
Instance variables are initialized to nil by default. There is no need to do it explicitly in the initialize method.!
!ReNoNilAssignationInInitializeRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReNoNilAssignationInInitializeRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Style'! !

!ReNoNilAssignationInInitializeRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	| problemAssigments|
	(aMethod selector = #initialize and: [ aMethod methodClass isInstanceSide ]) ifFalse: [ ^ self ].

	problemAssigments := aMethod ast assignmentNodes select: [ :assignment | assignment value value isNil ].
	
	problemAssigments do: [ :assignment | 
			aCriticBlock cull: (self createTrivialCritiqueOn: aMethod intervalOf: assignment hint: 'nil').
		 ]
! !

!ReNoNilAssignationInInitializeRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Initialize method does not need nil assignation'! !

!ReNoNilAssignationInInitializeRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReNoPrintStringInPrintOnRule commentStamp: ''!
#printString is implemented by manipulating a stream.
Using it inside a #printOn: will imply a useless creation of stream and its pass to #printOn: one, instead of using directely the stream parameter to #printOn:!
!ReNoPrintStringInPrintOnRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Use the stream argument to #printOn: e.g.( stream print: anObject ) instead of creating an extra stream by using printString. e.g.( stream nextPutAll: anObject printString ).'! !

!ReNoPrintStringInPrintOnRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReNoPrintStringInPrintOnRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	| problemPrintStrings |
	aMethod selector = #printOn: ifFalse: [ ^self ].
	problemPrintStrings := 
		aMethod sendNodes select: [ :msgSend | msgSend selector = #printString].
	
	problemPrintStrings do: [ :msgSend |
			aCriticBlock cull: (self 
				createTrivialCritiqueOn: aMethod 
				intervalOf: msgSend 
				hint: msgSend selector asString )]! !

!ReNoPrintStringInPrintOnRule methodsFor: 'accessing' stamp: ''!
name
	^ 'No printString inside printOn' ! !

!ReNoPrintStringInPrintOnRule class methodsFor: 'class initialization' stamp: ''!
initialize
    ReRuleManager cleanUp ! !

!ReNoPrintStringInPrintOnRule class methodsFor: 'testing - interest' stamp: ''!
checksMethod

	^ true! !

!ReNoPrintStringInPrintOnRuleTest methodsFor: 'printing' stamp: ''!
printOn: aStream
	"I violate my rule on not using pringString inside a printOn:"
	super printOn: aStream.
	3 factorial printString.
	2 even ifFalse: [ 3.14 printString ]! !

!ReNoPrintStringInPrintOnRuleTest methodsFor: 'tests' stamp: ''!
testRule
	|method critiques|
	method := self class >> #printOn:.
	critiques := OrderedCollection new.
	ReNoPrintStringInPrintOnRule new check: method forCritiquesDo:[:critique | critiques add: critique].
	
	self assert: critiques size equals: 2.
	self assert: critiques first sourceAnchor interval equals: (108 to: 130)! !

!ReNoPrintStringInPrintOnRuleTest methodsFor: 'tests' stamp: ''!
testBasicCheck
	
	testMethod := testClass >> (testClass compile: 
	'printOn: aStream 
		| anObject | 
		anObject := { ''one'', ''two'' } asOrderedCollection. 
		^ aStream nextPutAll: anObject printString.' ).
	
	self
		assert: (testMethod critiques anySatisfy: [ :critic | critic rule class = ReNoPrintStringInPrintOnRule ]).
	
	testMethod := testClass >> (testClass compile: 
	'printOn: aStream 
		| anObject | 
		anObject := { ''one'', ''two'' } asOrderedCollection. 
		^ aStream print anObject.').
	
	self
		assert: (testMethod critiques noneSatisfy: [ :critic | critic rule class = ReNoPrintStringInPrintOnRule ])! !

!ReNoSpaceAroundMethodCategoryNameRule commentStamp: ''!
Provide rule to have no leading or trailing space in method category name!
!ReNoSpaceAroundMethodCategoryNameRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	protocolName := aMethod protocol.
	^ (protocolName endsWith: ' ')
			or: [ protocolName beginsWith: ' ' ]! !

!ReNoSpaceAroundMethodCategoryNameRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Coding Idiom Violation'! !

!ReNoSpaceAroundMethodCategoryNameRule methodsFor: 'accessing' stamp: ''!
name 

	^ 'Category name "{1}" should be trimmed (includes space at start or end)'
		format: { protocolName }! !

!ReNoSpaceAroundMethodCategoryNameRule methodsFor: 'running' stamp: ''!
critiqueFor: aMethod
	| proposedCategory |
	proposedCategory := protocolName trimBoth.
		
	^ (ReRefactoringCritique
		   withAnchor: (self anchorFor: aMethod)
		   by: self) refactoring: (RBMethodProtocolTransformation
			   protocol: { proposedCategory }
			   inMethod: aMethod selector
			   inClass: aMethod methodClass name asSymbol) asRefactoring! !

!ReNoSpaceAroundMethodCategoryNameRule class methodsFor: 'testing' stamp: ''!
checksMethod 

	^ true! !

!ReNoSpaceAroundMethodCategoryNameRule class methodsFor: 'manifest' stamp: ''!
uniqueIdentifierName 

	^ 'ReNoSpaceAroundMethodCategoryNameRule'! !

!ReNoUnusedInstanceVariableRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Classes should have instance variables that are actually used - instance variables without a reference should be removed.'! !

!ReNoUnusedInstanceVariableRule methodsFor: 'accessing' stamp: ''!
group 

	^ 'Optimization'! !

!ReNoUnusedInstanceVariableRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock
	aClass slots
		select: [ :slot | slot isReferenced not ]
		thenDo: [ :slot | aCriticBlock cull: (self critiqueFor: aClass about: slot name) ]! !

!ReNoUnusedInstanceVariableRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Unused instance variable'! !

!ReNoUnusedInstanceVariableRule methodsFor: 'running' stamp: ''!
critiqueFor: aClass about: aVarName

	| crit |
	crit :=  ReRemoveInstanceVariableCritique
				         for: aClass
				         instanceVariable: aVarName
				         by: self .




	^ crit! !

!ReNoUnusedInstanceVariableRule class methodsFor: 'testing' stamp: ''!
checksClass

	^ true! !

!ReNoUnusedInstanceVariableRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'NoUnusedInstanceVariableRule'! !

!ReNodeBasedRule commentStamp: ''!
A base superclass for rules that check AST nodes.!
!ReNodeBasedRule methodsFor: 'helpers' stamp: ''!
anchorFor: aNode

	^ ReIntervalSourceAnchor
			entity: aNode
			interval: aNode sourceInterval.
			
	! !

!ReNodeBasedRule class methodsFor: 'testing' stamp: ''!
isAbstract 

	 ^ self = ReNodeBasedRule! !

!ReNodeBasedRule class methodsFor: 'testing' stamp: ''!
checksNode

	^ true! !

!ReNodeBasedRule class methodsFor: 'testing' stamp: ''!
isVisible

	^ self name ~=  #ReNodeBasedRule! !

!ReNodeMatchRule commentStamp: ''!
The base rule for smalltalk code pattern matching (relies on rewrite expressions). The rule operates on AST nodes.

Use the following methods in the initialization to setup your subclass:

- matches:
- addMatchingExpression:
	add a string of rewrite expression to be matched by rule

- matchesAny:
	same as previous but takes a collection of strings to match
	
- addMatchingMethod:
	add a string of rewrite expression which should be parsed as a method
	
you may use #afterCheck:mappings: to do a post-matching validation of a matched node and mapping of wildcards.!
!ReNodeMatchRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	matchers := Set new.! !

!ReNodeMatchRule methodsFor: 'adding' stamp: ''!
matchesAny: aStringCollection
	"add a collection of rewrite expression strings to be matched by the rule"

	aStringCollection do: [ :string |
		self addMatchingExpression: string ]! !

!ReNodeMatchRule methodsFor: 'running' stamp: ''!
check: aNode forCritiquesDo: aCriticBlock
	
	matchers do: [ :matcher |
		matcher
			match: aNode
			onSuccess: [ :map |
				(self
					afterCheck: aNode
					mappings: (self flattenMatchMap: map))
						ifTrue: [
							aCriticBlock cull: (self critiqueFor: aNode) ] ]
			onFailure: [  ] ]
	! !

!ReNodeMatchRule methodsFor: 'adding' stamp: ''!
matches: aString
	"add a string of rewrite expression to be matched by rule"

	self addMatchingExpression: aString! !

!ReNodeMatchRule methodsFor: 'adding' stamp: ''!
addMatchingMethod: aString
	"add a string of rewrite expression which should be parsed as a method"

	matchers add: (RBParser parseRewriteMethod: aString)! !

!ReNodeMatchRule methodsFor: 'adding' stamp: ''!
addMatchingExpression: aString
	"add a string of rewrite expression to be matched by rule"

	matchers add: (RBParser parseRewriteExpression: aString)! !

!ReNodeMatchRule class methodsFor: 'testing' stamp: ''!
isAbstract 

	 ^ self = ReNodeMatchRule! !

!ReNodeMatchRule class methodsFor: 'testing' stamp: ''!
isVisible

	^ self name ~= #ReNodeMatchRule! !

!ReNodeRewriteRule commentStamp: ''!
The base rule for smalltalk code match & rewrite rules. The rule operates on AST nodes.

Use the following methods in the initialization to setup your subclass:

- replace:with:
- addMatchingExpression:rewriteTo:
	add a "from->to" pair of strings that represent a rewrite expression string to match and a rewrite expression to replace the matched node.

- addMatchingMethod:rewriteTo: 
	same as the previous, but the rewrite expression are parsed as method definitions

- replace:by:
- addMatchingExpression:rewriteWith:
	add 	a "from->to" pair, first element of which is a rewrite expression in a form of a string that is used to match nodes. The second parameter is a block that has to return a node which should replace the matched one. The block may accept 2 atguments: the matched node, and a dictionary of wildcard variables mapping. 
	!
!ReNodeRewriteRule methodsFor: 'adding' stamp: ''!
addMatchingMethod: aString rewriteWith: aBlock
	"add 	a 'from->to' pair, first element of which is a rewrite method code in a form of a string that is used to match methods. The second parameter is a block that has to return a method ast which should replace the matched one. The block may accept 2 atguments: the matched ast, and a dictionary of wildcard variables mapping"

	matches
		at: (RBParser parseRewriteMethod: aString)
		put: (ReRewriteBlockWrapper on: aBlock)! !

!ReNodeRewriteRule methodsFor: 'helpers' stamp: ''!
critiqueFor: aNode by: rewriter withMappings: map


	^ ReReplaceNodeCritique
		rule: self
		achor: (self anchorFor: aNode)
		oldNode: aNode
		newNode: (rewriter rewriten: aNode with: map)! !

!ReNodeRewriteRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	matches := Dictionary new.! !

!ReNodeRewriteRule methodsFor: 'adding' stamp: ''!
addMatchingMethod: aString rewriteTo: aRewriteString
	"add a 'from->to' pair of strings that represent a match method string to match and a rewrite method to replace the matched mathod"

	matches
		at: (RBParser parseRewriteMethod: aString)
		put: (ReRewriteTreeWrapper on: (
			RBParser parseRewriteMethod: aRewriteString))! !

!ReNodeRewriteRule methodsFor: 'adding' stamp: ''!
replace: aString with: aRewriteString
	"add a 'from->to' pair of strings that represent a match expression string to match and a rewrite expression to replace the matched node"

	self addMatchingExpression: aString rewriteTo: aRewriteString! !

!ReNodeRewriteRule methodsFor: 'running' stamp: ''!
check: aNode forCritiquesDo: aCriticBlock

	matches keysAndValuesDo: [ :matcher :rewriter |
		matcher
			match: aNode
			onSuccess: [ :map |
				(self
					afterCheck: aNode
					mappings: (self flattenMatchMap: map))
						ifTrue: [
							aCriticBlock cull: (
								self
									critiqueFor: aNode
									by: rewriter
									withMappings: map). ] ]
			onFailure: [  ] ]! !

!ReNodeRewriteRule methodsFor: 'adding' stamp: ''!
replaceMethod: aString with: aRewriteString
	"add a 'from->to' pair of strings that represent a match method string to match and a rewrite method to replace the matched code"

	self addMatchingMethod: aString rewriteTo: aRewriteString! !

!ReNodeRewriteRule methodsFor: 'adding' stamp: ''!
addMatchingExpression: aString rewriteTo: aRewriteString
	"add a 'from->to' pair of strings that represent a rewrite expression string to match and a rewrite expression to replace the matched node."

	matches
		at: (RBParser parseRewriteExpression: aString)
		put: (ReRewriteTreeWrapper on: (
			RBParser parseRewriteExpression: aRewriteString))! !

!ReNodeRewriteRule methodsFor: 'adding' stamp: ''!
addMatchingExpression: aString rewriteWith: aBlock
	"add 	a 'from->to' pair, first element of which is a rewrite expression in a form of a string that is used to match nodes. The second parameter is a block that has to return a node which should replace the matched one. The block may accept 2 atguments: the matched node, and a dictionary of wildcard variables mapping"

	matches
		at: (RBParser parseRewriteExpression: aString)
		put: (ReRewriteBlockWrapper on: aBlock)! !

!ReNodeRewriteRule methodsFor: 'adding' stamp: ''!
replace: aString byEvaluating: aBlock
	"add 	a 'from->to' pair, first element of which is a rewrite expression in a form of a string that is used to match nodes. The second parameter is a block that has to return a node which should replace the matched one. The block may accept 2 atguments: the matched node, and a dictionary of wildcard variables mapping"

	self addMatchingExpression: aString rewriteWith: aBlock! !

!ReNodeRewriteRule methodsFor: 'testing' stamp: ''!
isRewriteRule
	^true! !

!ReNodeRewriteRule class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self == ReNodeRewriteRule! !

!ReNodeRewriteRule class methodsFor: 'testing' stamp: ''!
isVisible
	
	^ self name ~=  #ReNodeRewriteRule! !

!ReNotEliminationRule commentStamp: ''!
Eliminate unnecessary not''s in relation of conditionals.
For example test not ifTrue:[] is equivalent to test ifFalse:[]' 

[[[
anObject not ifFalse: block'
]]]

is transformed into

[[[  
anObject ifTrue: block'
]]]

[[[
aCollection select: [ :each | ... anObject not ] 
]]]
	
is transformed into 	

[[[
aCollection reject: [ :each | ... anObject ] 
]]]!
!ReNotEliminationRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: '``@object not not' with: '``@object';
		replace: '``@object isEmpty not' with: '``@object isNotEmpty';
		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'! !

!ReNotEliminationRule methodsFor: 'accessing' stamp: ''!
rationale  
	^ 'Eliminate unnecessary not''s in relation of conditionals'! !

!ReNotEliminationRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReNotEliminationRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Eliminate unnecessary not''s'! !

!ReNotEliminationRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'NotEliminationRule'! !

!ReOverridesSpecialMessageRule commentStamp: ''!
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.!
!ReOverridesSpecialMessageRule methodsFor: 'accessing' stamp: ''!
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.
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) ),'.'! !

!ReOverridesSpecialMessageRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReOverridesSpecialMessageRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReOverridesSpecialMessageRule methodsFor: 'private' stamp: ''!
classShouldNotOverride
	^ #( #== #~~ #class #basicAt: #basicAt:put: #basicSize #identityHash )! !

!ReOverridesSpecialMessageRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock
	| selectors |
	selectors := aClass isMeta 
		ifTrue: [ self metaclassShouldNotOverride ]
		ifFalse: [ self classShouldNotOverride ].
	(selectors anySatisfy: [ :each |
		(aClass superclass notNil
			and: [ (aClass superclass canUnderstand: each)
			and: [ (aClass includesSelector: each) ] ]) ]) ifTrue: [ 
		aCriticBlock cull: (self critiqueFor: aClass) ]! !

!ReOverridesSpecialMessageRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Overrides a "special" message'! !

!ReOverridesSpecialMessageRule methodsFor: 'private' stamp: ''!
metaclassShouldNotOverride
	^ #( #basicNew #basicNew #class #comment #name )! !

!ReOverridesSpecialMessageRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReOverridesSpecialMessageRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'OverridesSpecialMessageRule'! !

!RePackageManifestShouldBePackagedInManifestTagRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Check if the package manifest is tagged in class category ''Manifest'' to align with other packages and fulfil common expectations.'! !

!RePackageManifestShouldBePackagedInManifestTagRule methodsFor: 'running' stamp: ''!
basicCheck: aClass

	^ (aClass inheritsFrom: PackageManifest) and: [ 
		((aClass package classesForClassTag: 'Manifest') includes: aClass) not ]! !

!RePackageManifestShouldBePackagedInManifestTagRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Coding Idiom Violation'! !

!RePackageManifestShouldBePackagedInManifestTagRule methodsFor: 'accessing' stamp: ''!
name
	^ 'A package manifest should be tagged using ''Manifest'' class tag'! !

!RePackageManifestShouldBePackagedInManifestTagRule class methodsFor: 'testing - interest' stamp: ''!
checksClass

	^ true! !

!RePassExceptionStrategy commentStamp: ''!
Pass the exception on, allowing handlers up the stach to deal with it, or open the debugger if there are no handlers.!
!RePassExceptionStrategy class methodsFor: 'accessing' stamp: ''!
strategyDescription

	^ 'Pass the exception on, allowing handlers up the stach to deal with it, or open the debugger if there are no handlers.'! !

!RePassExceptionStrategy class methodsFor: 'accessing' stamp: ''!
strategyTitle

	^ 'Pass Exception'! !

!RePassExceptionStrategy class methodsFor: 'error handling' stamp: ''!
handle: anException about: anEntity forPropertiesDo: aBlock

	anException pass! !

!RePatternCodeRule commentStamp: ''!
An abstract class containing common tools for match and rewrite rules!
!RePatternCodeRule methodsFor: 'private' stamp: ''!
flattenMatchMap: aDictionary
	^ aDictionary keysAndValuesDo: [ :key :val |
		((key isKindOf: RBProgramNode) and: [ 
		 key isPatternNode ])
			ifTrue: [
				aDictionary
					at: key pattern
					put: val ] ] ! !

!RePatternCodeRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	"after a node was match you can do a post-validation here on the node and the dictionalry of wildcars with matched nodes as values"

	^ true	! !

!RePatternCodeRule class methodsFor: 'testing' stamp: ''!
noteCompilationOf: aSelector meta: isMeta

	 aSelector == #initialize & isMeta not ifTrue: [ 
		ReRuleManager reset ]! !

!RePatternCodeRule class methodsFor: 'testing' stamp: ''!
isAbstract 

	 ^ self = RePatternCodeRule! !

!RePatternCodeRule class methodsFor: 'testing' stamp: ''!
isVisible
	
	^ self name ~=  #RePatternCodeRule! !

!RePersistentImageRuleBaner commentStamp: ''!
Same as the superclass but also saves the banned rule with a setting!
!RePersistentImageRuleBaner class methodsFor: 'properties' stamp: ''!
reBanName

	^ super reBanName, ' and future images'! !

!RePersistentImageRuleBaner class methodsFor: 'actions' stamp: ''!
ban: aCritique

	super ban: aCritique.
	
	SystemSettingsPersistence storeIdentifier: 
		ReRuleManager ruleToggleGroupID printString,
		aCritique rule class enabledSettingID printString
		"printString to ensure symbol hash"! !

!RePlatformDependentUserInteractionRule commentStamp: ''!
Check the methods that  use platform dependent user interactions.

This rule should be updated.!
!RePlatformDependentUserInteractionRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	 self matchesAny: #(
			'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'
			 )! !

!RePlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Check the methods that  use platform dependent user interactions.'! !

!RePlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!RePlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!RePlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Platform dependent user interaction'! !

!RePlatformDependentUserInteractionRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'PlatformDependentUserInteractionRule'! !

!RePrecedenceRule commentStamp: ''!
Checks for mathematical expressions that might be evaluated different (from left-to-right) than the developer thinks.!
!RePrecedenceRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	| leftOperand |
	aNode isMessage ifFalse: [ ^ false ].
	aNode selector = #* ifFalse: [ ^ false ].
	leftOperand := aNode receiver.
	leftOperand isMessage ifFalse: [ ^ false ].
	leftOperand hasParentheses ifTrue: [ ^ false ].
	^ #(#+ #-) includes: leftOperand selector! !

!RePrecedenceRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!RePrecedenceRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Inspect instances of "A + B * C" might be "A + (B * C)"'! !

!RePrecedenceRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'PrecedenceRule'! !

!RePriorInvocationCritique commentStamp: ''!
The critic tells that a required message is missing prior to the one in question!
!RePriorInvocationCritique methodsFor: 'accessing' stamp: ''!
description

	^ 'In order for #', targetMethodName, ' to work you have to call ', condition beforeDescriptionString, ' before' ! !

!RePriorInvocationCritique methodsFor: 'accessing' stamp: ''!
title

	^ 'Message #', targetMethodName, ' not preceded by ',
		(condition beforeDescriptionString truncateWithElipsisTo: 30)! !

!ReProperMethodProtocolNameForAccessingRule commentStamp: ''!
Rule to favour 'accessing' method protocol over similar ones (like 'accessor' or other)!
!ReProperMethodProtocolNameForAccessingRule class methodsFor: 'idioms' stamp: ''!
protocolIdiom 

	^self use: 'accessing' insteadOf: #('accessor' 'accessors' 'acessing' 'acccessing' 'accesing' 'acesing')! !

!ReProperMethodProtocolNameForConvertingRule commentStamp: ''!
Rule to favour 'converting' method protocol over similar ones (like 'conversion' or other)!
!ReProperMethodProtocolNameForConvertingRule class methodsFor: 'idioms' stamp: ''!
protocolIdiom 

	^self use: 'converting' insteadOf: #('conversion' 'conversions')! !

!ReProperMethodProtocolNameForFileInOutRule class methodsFor: 'idioms' stamp: ''!
protocolIdiom 

	^self use: 'file in/out' insteadOf: #('filein/out' 'fileIn/Out' 'fileIn/out' 'filein/Out' 'file-in/out')! !

!ReProperMethodProtocolNameForInstanceCreationRule commentStamp: ''!
Rule to favour 'instance creation' method protocol over similar ones (like 'instance-creation' or other)!
!ReProperMethodProtocolNameForInstanceCreationRule class methodsFor: 'idioms' stamp: ''!
protocolIdiom 

	^self use: 'instance creation' insteadOf: #('instance-creation' 'instances-creation' 'instances creation')! !

!ReProperMethodProtocolNameForRemovalRule class methodsFor: 'idioms' stamp: ''!
protocolIdiom 

	^self use: 'removing' insteadOf: #('remove' 'removal')! !

!ReProperMethodProtocolNameForTestsRule commentStamp: ''!
Rule to favour 'tests' method protocol for SUnit tests over 'test' as typically several test methods can/will be in the category!
!ReProperMethodProtocolNameForTestsRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	"We only check for SUnit test methods"
	
	^ aMethod isTestMethod and: [ self class badMethodProtocolNames includes: aMethod category ]! !

!ReProperMethodProtocolNameForTestsRule class methodsFor: 'idioms' stamp: ''!
protocolIdiom 

	^self use: 'tests' insteadOf: #('test')! !

!ReProperMethodProtocolNameForUtilitiesRule commentStamp: ''!
Rule to favour 'utilities' method protocol over similar ones (like 'utils' or other)!
!ReProperMethodProtocolNameForUtilitiesRule class methodsFor: 'idioms' stamp: ''!
protocolIdiom 

	^self use: 'utilities' insteadOf: #('utils' 'utility')! !

!ReProperMethodProtocolNameRule commentStamp: ''!
This is an abstract rule class to check for an appropriate method
protol name.

Subclasses should override #protocolIdiom to return an association of a good protocol name and the bad protocol names it should replace.!
!ReProperMethodProtocolNameRule methodsFor: 'accessing' stamp: ''!
rationale

	^ 'Check if the method protocol name is appropriate and fulfils common expectations.'! !

!ReProperMethodProtocolNameRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	self methodProtocolName: aMethod category.
	^ self class badMethodProtocolNames includes: aMethod category! !

!ReProperMethodProtocolNameRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Coding Idiom Violation'! !

!ReProperMethodProtocolNameRule methodsFor: 'accessing' stamp: ''!
methodProtocolName: anObject

	methodProtocolName := anObject! !

!ReProperMethodProtocolNameRule methodsFor: 'private - utilities' stamp: ''!
use: valid insteadOf: arrayOfInvalid
	"Instead of directly creating an array we use this utility method for better readability
	 in senders of this method"
	
	^self class use: valid insteadOf: arrayOfInvalid! !

!ReProperMethodProtocolNameRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Method categorization: use ''' 
		  	, self class goodMethodProtocolName
  	  		, ''' as protocol name instead of '''
	  		, self methodProtocolName asString , ''''! !

!ReProperMethodProtocolNameRule methodsFor: 'helpers' stamp: ''!
critiqueFor: aMethod
	| proposedCategory |
	proposedCategory := self class goodMethodProtocolName asSymbol.
		
	^ (ReRefactoringCritique
		   withAnchor: (self anchorFor: aMethod)
		   by: self) refactoring: (RBMethodProtocolTransformation
			   protocol: { proposedCategory }
			   inMethod: aMethod selector
			   inClass: aMethod methodClass name) asRefactoring! !

!ReProperMethodProtocolNameRule methodsFor: 'accessing' stamp: ''!
methodProtocolName

	^ methodProtocolName! !

!ReProperMethodProtocolNameRule class methodsFor: 'private - utilities' stamp: ''!
use: valid insteadOf: arrayOfInvalid
	"Instead of directly creating an array we use this utility method for better readability
	 in senders of this method"
	
	^valid -> arrayOfInvalid ! !

!ReProperMethodProtocolNameRule class methodsFor: 'testing - interest' stamp: ''!
checksMethod
	"This one is abstract but subclasses should run as rules"
	
	^ self name ~= #ReProperMethodProtocolNameRule! !

!ReProperMethodProtocolNameRule class methodsFor: 'private - accessing' stamp: ''!
goodMethodProtocolName

	^self protocolIdiom key! !

!ReProperMethodProtocolNameRule class methodsFor: 'private - accessing' stamp: ''!
badMethodProtocolNames

	^self protocolIdiom value collect: [:each | each asSymbol ]! !

!ReProperMethodProtocolNameRule class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == ReProperMethodProtocolNameRule! !

!ReProperMethodProtocolNameRule class methodsFor: 'idioms' stamp: ''!
protocolIdiom
	"Subclasses should override to return an association between a
	 wished category and an array of category names that are not so good."
 
	^self subclassResponsibility! !

!ReProperty commentStamp: ''!
I'm an external property of some entity related to a piece of code.

I define a basic interface of a #title and an #icon that can be used to display it in a user interface
I also have a source anchor with a reference to the actual class, method, or other source code entity that I am related to.!
!ReProperty methodsFor: 'actions' stamp: ''!
actions 

	^ #()! !

!ReProperty methodsFor: 'accessing' stamp: ''!
sourceAnchor
	^ sourceAnchor! !

!ReProperty methodsFor: 'accessing' stamp: ''!
entity
	^ self sourceAnchor entity! !

!ReProperty methodsFor: 'accessing' stamp: ''!
icon

	^ Form extent: 16@16 depth: 32! !

!ReProperty methodsFor: 'initialization' stamp: ''!
initializeSourceAnchor: anAnchor

	self initialize.
	sourceAnchor := anAnchor! !

!ReProperty methodsFor: 'testing' stamp: ''!
isCritique
	^ false! !

!ReProperty methodsFor: 'accessing' stamp: ''!
title

	^ self subclassResponsibility ! !

!ReProperty methodsFor: 'accessing' stamp: ''!
color

	^ Color black alpha: 0.1! !

!ReProperty class methodsFor: '*Calypso-SystemPlugins-Critic-Queries' stamp: ''!
decorateBrowserItem: aBrowserItem by: anEnvironmentPlugin
	"Following code is to support Pharo 7 Exception property when there is problem with critiques.
	Pharo 6 has not this class. So this special trick is used"
	| property |
	property := aBrowserItem actualObject.
	property class name = #ReExceptionProperty ifTrue: [
		aBrowserItem markWith: ClyBrokenCritiqueTag]! !

!ReProperty class methodsFor: '*Calypso-SystemPlugins-Critic-Queries' stamp: ''!
convertToCalypsoBrowserItem: aProperty
	^ClyBrowserItem named: aProperty title with: aProperty! !

!RePropertyAction commentStamp: ''!
I am an action that appears in the Nautiluas qa plugin next the the item's title.

icon - a Form that will appear on the button (green square by default)

description - the description that will be present on popup on hower

action - a two (ortional) parameter block that is evaluated with the critic and the current code entity (class, method…) when the button is pressed
 No newline at end of file
!
!RePropertyAction methodsFor: 'accessing' stamp: ''!
action: anObject
	action := anObject
! !

!RePropertyAction methodsFor: 'evaluating' stamp: ''!
actOnCritic: aCritic ofEntity: anEntity

	action cull: aCritic cull: anEntity 
! !

!RePropertyAction methodsFor: 'initialization' stamp: ''!
initialize 
	
	icon := (Form extent: 16@16 depth: 32) fillColor: Color green.
	description := ''.
	action := [ :critic :entity | ]
! !

!RePropertyAction methodsFor: 'accessing' stamp: ''!
action
	^ action
! !

!RePropertyAction methodsFor: 'accessing' stamp: ''!
description: anObject
	description := anObject
! !

!RePropertyAction methodsFor: 'accessing' stamp: ''!
description
	^ description
! !

!RePropertyAction methodsFor: 'accessing' stamp: ''!
icon 
	^ icon
! !

!RePropertyAction methodsFor: 'accessing' stamp: ''!
icon: anObject
	icon := anObject
! !

!ReRefactoringCritique commentStamp: ''!
A critique which has a refactoring needed to solve the issue!
!ReRefactoringCritique methodsFor: 'testing' stamp: ''!
providesChange
	
	^ true! !

!ReRefactoringCritique methodsFor: 'initialization' stamp: ''!
initialize
	
	alreadyExecuted := false! !

!ReRefactoringCritique methodsFor: 'accessing' stamp: ''!
change
	"return changes provided by the refactoring"
	
	alreadyExecuted ifFalse: [
		refactoring primitiveExecute.
		alreadyExecuted := true ].
	
	^ refactoring changes! !

!ReRefactoringCritique methodsFor: 'accessing' stamp: ''!
refactoring
	^ refactoring! !

!ReRefactoringCritique methodsFor: 'accessing' stamp: ''!
refactoring: anObject
	refactoring := anObject! !

!ReReferencesObsoleteClassRule commentStamp: ''!
You are referencing a class that is obsolete, that is, it has been removed
!
!ReReferencesObsoleteClassRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReReferencesObsoleteClassRule methodsFor: 'helpers' stamp: ''!
basicCheck: aNode
 	^ aNode isGlobalVariable
 			and: [ aNode variable isGlobalClassNameBinding
 				and: [ aNode variable value isObsolete ] ]! !

!ReReferencesObsoleteClassRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReReferencesObsoleteClassRule methodsFor: 'accessing' stamp: ''!
name
	^ 'References an obsolete class'! !

!ReReferencesObsoleteClassRule methodsFor: 'helpers' stamp: ''!
critiqueFor: aNode
	^ (super critiqueFor: aNode)
		  tinyHint: aNode name;
		  yourself! !

!ReRefersToClassRule commentStamp: ''!
This smell arises when a class has its class name directly in the source instead of "self class" (or just "self" when on the class side). The self class / self variant allows you to create subclasses without needing to redefine that method.
However we cannot systematically replace Class reference by self class or self because a Class reference is static and a self expression is dynamic. So the programmer may want to send messages to root of an hierarchy and not to the leaf classes. Therefore this rule generates false positives, please double check when fixing!!!
!ReRefersToClassRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Checks for direct reference to classes themselves.'! !

!ReRefersToClassRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReRefersToClassRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	| class problemLiterals |
	
	"The class method #isAbstract needs to explicitly hardcode class references. 
	So we do not criticize this."
	(aMethod isClassSide and: [ aMethod selector = #isAbstract ]) ifTrue: [ ^ self ].
	
	class := aMethod methodClass instanceSide.
	problemLiterals := (aMethod ast allChildren 
			select: [ :node | node isGlobalVariable ])
			select: [ :var | var name = class name].
		
	problemLiterals do: [ :literal |
			aCriticBlock cull: (self createTrivialCritiqueOn: aMethod intervalOf: literal hint:literal name )]! !

!ReRefersToClassRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Refers to class name instead of "self class"'! !

!ReRefersToClassRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReRefersToClassRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'RefersToClassRule'! !

!ReRefersToClassRuleTest commentStamp: ''!
A RBRefersToClassRuleTest is a test class for testing the behavior of RBRefersToClassRule!
!ReRefersToClassRuleTest methodsFor: 'tests' stamp: ''!
testIsAbstractNotDetected
	| critiques|
 	critiques := self myCritiquesOnMethod: self class class >> #isAbstract.

 	self assert: critiques size equals: 0.! !

!ReRefersToClassRuleTest methodsFor: 'sample' stamp: ''!
referToClassName
	"I refer to my own class by name - RBRefersToClassRuleTest"
	ReRefersToClassRuleTest name,
	88,
	ReRefersToClassRuleTest name! !

!ReRefersToClassRuleTest methodsFor: 'tests' stamp: ''!
testRuleDetectHardCodedClass
	| critiques|
 	critiques := self myCritiquesOnMethod: self class >> #referToClassName.

 	self assert: critiques size equals: 2.
 	self assert: (self sourceAtChritique:  critiques first) equals: ReRefersToClassRuleTest name asString.! !

!ReRefersToClassRuleTest class methodsFor: 'testing' stamp: ''!
isAbstract
	"I can refer to RBRefersToClassRuleTest without error"
	'It is ok to refert to', ReRefersToClassRuleTest name.
	^ false! !

!ReRemoveAssignmentWithoutEffectRule commentStamp: ''!
See my #longDescription .!
!ReRemoveAssignmentWithoutEffectRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
 
	self
		replace: 	'`var := `var' with: ''! !

!ReRemoveAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: ''!
rationale 
	^ 'Remove assignment has no effect. For example, var := var is unless'! !

!ReRemoveAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReRemoveAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Remove assignment has no effect'! !

!ReRemoveAssignmentWithoutEffectRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName

	^ 'RemoveAssignmentWithoutEffectRule'! !

!ReRemoveInstanceVariableCritique commentStamp: ''!
I am a critique that will propose to the user to remove an instance variable.!
!ReRemoveInstanceVariableCritique methodsFor: 'testing' stamp: ''!
providesChange

	^ true! !

!ReRemoveInstanceVariableCritique methodsFor: 'accessing' stamp: ''!
change

	^ (RBRefactoryChangeFactory instance)
		removeInstanceVariable: self tinyHint from: self entity! !

!ReRemoveInstanceVariableCritique class methodsFor: 'instance creation' stamp: ''!
for: anEntity instanceVariable: anInstanceVariable by: aRule

	^ (self for: anEntity by: aRule)
		tinyHint: anInstanceVariable;
		yourself! !

!ReRemoveMethodCritique commentStamp: ''!
I am a critique that will propose to the user to remove a method.!
!ReRemoveMethodCritique methodsFor: 'testing' stamp: ''!
providesChange
	^ true! !

!ReRemoveMethodCritique methodsFor: 'accessing' stamp: ''!
change
	^ (RBRefactoryChangeFactory instance)
		removeMethod: self tinyHint 
		from: self entity! !

!ReRemoveMethodCritique class methodsFor: 'instance creation' stamp: ''!
for: anEntity selector: aSelector by: aRule
	^ (self for: anEntity by: aRule)
		tinyHint: aSelector;
		yourself! !

!ReReplaceNodeCritique commentStamp: ''!
A critique which know which node should be replaced by another one. This critiques are used first of all in rewrite rules.!
!ReReplaceNodeCritique methodsFor: 'testing' stamp: ''!
providesChange

	^ self entity isCompiledMethod! !

!ReReplaceNodeCritique methodsFor: 'initialization' stamp: ''!
initializeRule: aRule sourceAnchor: anAnchor oldNode: aNode newNode: anotherNode

	self initializeRule: aRule sourceAnchor: anAnchor.
	oldNode := aNode.
	newNode := anotherNode 
! !

!ReReplaceNodeCritique methodsFor: 'accessing' stamp: ''!
change
	"creates new AST by replacing the node. Then the 'add method' change is generated from new AST"

	| newTree newTreeNode |
	newTree := self entity  parseTree.
	newTreeNode := newTree nodeAtTraversalIndex: (
		oldNode methodNode traversalIndexOf: oldNode).
	self assert: newTreeNode = oldNode.

	newTreeNode replaceMethodSource: newNode.
	newTreeNode becomeForward: newNode.
	^ (RBRefactoryChangeFactory instance)
		addMethodSource: newTree methodNode newSource
		in: self entity  methodClass! !

!ReReplaceNodeCritique class methodsFor: 'instance creation' stamp: ''!
rule: aRule achor: anAnchor oldNode: aNode newNode: anotherNode

	^ self basicNew 
		initializeRule: aRule
		sourceAnchor: anAnchor
		oldNode: aNode
		newNode: anotherNode! !

!ReReturnInEnsureRule commentStamp: ''!
Checks for return statements within ensure: blocks that can have unintended side-effects.!
!ReReturnInEnsureRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #( 
		'`@rcv ensure: [| `@temps | `@.Stmts]'
		'`@rcv ifCurtailed: [| `@temps | `@.Stmts]')! !

!ReReturnInEnsureRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReReturnInEnsureRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Contains a return in an ensure: block'! !

!ReReturnInEnsureRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	^ (mappingDict at: '`@.Stmts')
		anySatisfy: #containsReturn! !

!ReReturnInEnsureRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ReturnInEnsureRule'! !

!ReReturnMethodRule commentStamp: ''!
Somewhere in the override hierarchy there is a pragma that tells that this method should explicitly return a value.

Currently (2019-12-09) there is no methods in Pharo 8 which use #shouldReturn
!
!ReReturnMethodRule methodsFor: 'accessing' stamp: ''!
severity

	^ #error! !

!ReReturnMethodRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	(aMethod overriddenMethods anySatisfy: [ :method | method hasPragmaNamed: #shouldReturn ]) ifFalse: [ ^ false ].

	^ aMethod ast lastIsReturn not! !

!ReReturnMethodRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Bugs'! !

!ReReturnMethodRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Method should explicitly return a value'! !

!ReReturnMethodRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReReturnsBooleanAndOtherRule commentStamp: ''!
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.!
!ReReturnsBooleanAndOtherRule methodsFor: 'private' stamp: ''!
checkIfNodeIsNotBool: node
	^ node isSelfVariable or:
		[ node isLiteralNode and: [ (#(true false) includes: node value) not ] ]! !

!ReReturnsBooleanAndOtherRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReReturnsBooleanAndOtherRule methodsFor: 'private' stamp: ''!
checkIfNodeIsBool: node
	^ (node isLiteralNode and: [ #(true false) includes: node value ])
		or: [ node isMessage and: [ #(and: or:) includes: node selector ] ]! !

!ReReturnsBooleanAndOtherRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	| returnsBool returnsNonBool |
	returnsBool := false.
	"no return in the end? -> returns self"
	returnsNonBool := aMethod ast lastIsReturn not.
	
	aMethod ast nodesDo: [ :node | 
		node isReturn ifTrue: [
			| returnedNode |
			returnedNode := node value.
			
			returnsBool :=
				returnsBool or:
				[ self checkIfNodeIsBool: returnedNode ].
			returnsNonBool :=
				returnsNonBool or:
				[ self checkIfNodeIsNotBool: returnedNode ].

			returnsBool & returnsNonBool ifTrue: [
				^ aCriticBlock cull: (self critiqueFor: aMethod) ] ] ]! !

!ReReturnsBooleanAndOtherRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Returns a boolean and non boolean'! !

!ReReturnsBooleanAndOtherRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReReturnsBooleanAndOtherRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ReturnsBooleanAndOtherRule'! !

!ReReturnsIfTrueRule commentStamp: ''!
Check for methods that return the value of an ifTrue: or ifFalse: message. These statements return nil when the block is not executed.!
!ReReturnsIfTrueRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'^`@condition ifTrue: [| `@temps | `@.statements]'
			'^`@condition ifFalse: [| `@temps | `@.statements]' )! !

!ReReturnsIfTrueRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReReturnsIfTrueRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Returns value of ifTrue:/ifFalse: without ifFalse:/ifTrue: block'! !

!ReReturnsIfTrueRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ReturnsIfTrueRule'! !

!ReRewriteBlockWrapper commentStamp: ''!
A concrete wrapper implementation that uses a block to create new nodes!
!ReRewriteBlockWrapper methodsFor: 'initialization' stamp: ''!
initializeBlock: aBlock
	block := aBlock! !

!ReRewriteBlockWrapper methodsFor: 'actions' stamp: ''!
rewriten: aNode with: aMap

	^ block cull: aNode cull: aMap! !

!ReRewriteBlockWrapper class methodsFor: 'instance creation' stamp: ''!
on: aBlock

	^ self basicNew
		initializeBlock: aBlock;
		yourself! !

!ReRewriteTreeWrapper commentStamp: ''!
A concrete wrapper implementation that uses a rewrite expression to create a new node!
!ReRewriteTreeWrapper methodsFor: 'initialization' stamp: ''!
initializeTree: aTree
	tree := aTree! !

!ReRewriteTreeWrapper methodsFor: 'actions' stamp: ''!
rewriten: aNode with: aMap

	^ tree copyInContext: aMap! !

!ReRewriteTreeWrapper class methodsFor: 'instance creation' stamp: ''!
on: aTree

	^ self basicNew
		initializeTree: aTree;
		yourself! !

!ReRewriteWrapper commentStamp: ''!
A wrapper that provides a single interface to produce a new node from the matched node and a maping of wildcard variables.!
!ReRewriteWrapper methodsFor: 'actions' stamp: ''!
rewriten: aNode with: aMap

	^ self subclassResponsibility ! !

!ReRewriteWrapper class methodsFor: 'testing' stamp: ''!
isAbstract 

	 ^ self = ReRewriteWrapper! !

!ReRuleManager commentStamp: ''!
I should be used as singleton which provides sets of rules for checking classes and methods.

Use:

ReRuleManager uniqueInstance classRules "to get rules for checking classes"
ReRuleManager uniqueInstance methodRules "to get rules for checking methods"!
!ReRuleManager methodsFor: 'accessing' stamp: ''!
allRules

	^ rules! !

!ReRuleManager methodsFor: 'initialization' stamp: ''!
initializeRules: aCollection

	rules := aCollection copy! !

!ReRuleManager methodsFor: 'accessing' stamp: ''!
methodRules

	^ self allRules select: [ :rule | rule class checksMethod ]! !

!ReRuleManager methodsFor: 'accessing' stamp: ''!
nodeRules
	
	^ self allRules select: [ :rule | rule class checksNode ]! !

!ReRuleManager methodsFor: 'accessing' stamp: ''!
packageRules

	^ self allRules select: [ :rule | rule class checksPackage ]! !

!ReRuleManager methodsFor: 'accessing' stamp: ''!
classRules

	^ self allRules select: [ :rule | rule class checksClass ]! !

!ReRuleManager class methodsFor: 'accessing' stamp: ''!
ruleProfileSettingsOn: aBuilder 
	<systemsettings>
	(aBuilder pickOne: #rulesProfile)
		order: 1;
		label: 'Select a quality rules profile ';
		description: 'Select a profile according to your experience with Pharo. This will allow the QualityAssistant to show the rules that are appropiate to your level.';
		parent: #qualityAssistant;
		target: self;
		default: #setDefaultProfile;
		domainValues: {'Default' translated -> #setDefaultProfile . 
							'Beginner' translated -> #setBeginnerProfile }! !

!ReRuleManager class methodsFor: 'accessing' stamp: ''!
rulesProfile: aSelector

	RulesProfile := aSelector.
	self perform: RulesProfile ! !

!ReRuleManager class methodsFor: 'utilities' stamp: ''!
availableRuleGroups
	^ (self visibleRuleClasses
		collect: [ :r | r new group ]
		as: Set)
			asArray sorted! !

!ReRuleManager class methodsFor: 'event subscriptions' stamp: ''!
unsubscribe

	SystemAnnouncer uniqueInstance unsubscribe: self.
	ReSystemAnnouncer uniqueInstance unsubscribe: self! !

!ReRuleManager class methodsFor: 'settings' stamp: ''!
ruleToggleSettingsOn: aBuilder 
	<systemsettings>
	(aBuilder group: self ruleToggleGroupID)
		order: 1;
		label: 'Toggle rules to run';
		description: 'Select which rules do you want to see in the live feedback';
		parent: #qualityAssistant;
		with: [ 
			(self visibleRuleClasses sorted: [ :a :b | a name < b name ])
				do: [ :rule | 
					| inst |
					inst := rule new.
					(aBuilder setting: rule enabledSettingID)
					selector: #enabled;
					target: rule;
					default: rule enabled;
					label: inst name;
					description: inst rationale ] ]! !

!ReRuleManager class methodsFor: 'accessing' stamp: ''!
managers
	^ managers ifNil: [ managers := WeakKeyDictionary new ]! !

!ReRuleManager class methodsFor: 'settings' stamp: ''!
ruleToggleGroupID

	^ #ruleToggle! !

!ReRuleManager class methodsFor: 'utilities' stamp: ''!
resetWithInform

	self reset.
	self inform: 'Cache of the Renraku rule manager has been reset'! !

!ReRuleManager class methodsFor: 'accessing' stamp: ''!
setBeginnerProfile

	self visibleRuleClasses do: [ :rule | rule enabled: rule isBeginnerRule ].
	self reset! !

!ReRuleManager class methodsFor: 'event subscriptions' stamp: ''!
classAddedOrRemoved: aClassAddedAnnouncement 
	| class |
	class := aClassAddedAnnouncement classAffected.

	((class inheritsFrom: RBLintRule) or: [ 
	  class inheritsFrom: ReAbstractRule ]) 
		ifTrue: [ self reset ] ! !

!ReRuleManager class methodsFor: 'instance creation' stamp: ''!
newManagerForPackage: aRPackage 
	| builder manifest defaultRules rules |
	aRPackage ifNil: [ ^ self default ].
	builder := TheManifestBuilder new.
	manifest := builder manifestOf: aRPackage.
	manifest ifNil: [ ^ self default ].
	
	defaultRules := self defaultRules.
	"remove rules banned for the package"
	rules := defaultRules reject: [ :rule |
		builder bansRule: rule for: aRPackage ].
	(rules size = defaultRules size and: [ 
	 manifest forcedRules isEmpty ])
		ifTrue: [ ^ self default ].
	"add rules forced for the packages"
	manifest forcedRules do: [ :ruleClass |
		rules addIfNotPresent:
			(self class environment at: ruleClass) new ].
	^ self newWithRules: rules! !

!ReRuleManager class methodsFor: 'event subscriptions' stamp: ''!
critiqueBanned: aReCritiqueBanned
	| baner |
	baner := aReCritiqueBanned entityBanLevel.
	
	baner class = RPackage
		ifTrue: [ self removeManagerFor: baner ]! !

!ReRuleManager class methodsFor: 'event subscriptions' stamp: ''!
removeManagerFor: anRPackage

	self managers
		removeKey: anRPackage 
		ifAbsent: [  ]
	! !

!ReRuleManager class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	managers := nil.
	default := nil.! !

!ReRuleManager class methodsFor: 'accessing' stamp: ''!
rulesProfile

	^ RulesProfile ifNil: [ RulesProfile := #setDefaultProfile ]! !

!ReRuleManager class methodsFor: 'accessing' stamp: ''!
setDefaultProfile

	self visibleRuleClasses do: [ :rule | rule enabled: rule isDefaultRule ].
	self reset! !

!ReRuleManager class methodsFor: 'class initialization' stamp: ''!
initialize
	self reset.
	self subscribe! !

!ReRuleManager class methodsFor: 'instance creation' stamp: ''!
managerFor: aCodeEntity 
	^ self managers
		at: aCodeEntity package
		ifAbsentPut: [ self newManagerForPackage: aCodeEntity package ]! !

!ReRuleManager class methodsFor: 'event subscriptions' stamp: ''!
subscribe
	<systemEventRegistration>
	self unsubscribe.
	
	SystemAnnouncer uniqueInstance weak
		when: ClassAdded   send: #classAddedOrRemoved: to: self;
		when: ClassRemoved send: #classAddedOrRemoved: to: self.
		
	ReSystemAnnouncer uniqueInstance weak
		when: ReCritiqueBanned
		send: #critiqueBanned:
		to: self! !

!ReRuleManager class methodsFor: 'utilities' stamp: ''!
visibleRuleClasses

	^ (ReAbstractRule withAllSubclasses select: [:each | each isVisible])
	"remove this in the future ->", RBLintRule withAllSubclasses select: [:each | each isVisible]! !

!ReRuleManager class methodsFor: 'initialize-release' stamp: ''!
unload

	self reset! !

!ReRuleManager class methodsFor: 'helpers' stamp: ''!
defaultRules
	^ self visibleRuleClasses
			select: [ :ruleClass | ruleClass enabled ] 
			thenCollect: [:ruleClass | ruleClass new]! !

!ReRuleManager class methodsFor: 'instance creation' stamp: ''!
uniqueInstance
	"Not a singleton anymore"
	^ self default! !

!ReRuleManager class methodsFor: 'instance creation' stamp: ''!
default
	^ default ifNil: [ default := self newWithRules: self defaultRules ]! !

!ReRuleManager class methodsFor: 'instance creation' stamp: ''!
newWithRules: aCollection 
	^ self basicNew
		initializeRules: aCollection;
		yourself! !

!ReRuleManager class methodsFor: 'cleanup' stamp: ''!
cleanUp

	self reset! !

!ReRuleManagerTest methodsFor: 'tests' stamp: ''!
testClassAdded

	| rule rulesCount |
	
	ReRuleManager reset.
	
	rulesCount := ReRuleManager default nodeRules size.

	rule := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: #ReRuleManagerTestingRule;
			superclass: ReNodeMatchRule;
			package: testPackage name ].
			
	rule compile: 'name ^ ''test'''.

	self
		assert: ReRuleManager default nodeRules size - rulesCount
		equals: 1.

	self assert:
		(ReRuleManager default allRules anySatisfy: [ :r |
			r class == rule ]).
		
	rule removeFromSystem.! !

!ReRuleManagerTest methodsFor: 'tests' stamp: ''!
testClassRemoved

	| rule |
	
	rule := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: #ReRuleManagerTestingRule;
			superclass: ReAbstractRule;
			package: testPackage name ].

	rule class
		compile: 'checksMethod ^ true'.
		
	rule compile: 'name ^ ''test'''.

	ReRuleManager reset.

	self assert:
		(ReRuleManager default allRules anySatisfy: [ :r |
			r class == rule ]).
		
	rule removeFromSystem.
		
	self assert:
		(ReRuleManager default allRules noneSatisfy: [ :r |
			r class == rule ]).! !

!ReSearchStringSourceAnchor commentStamp: ''!
This class stores a searchString which will be searched for in the entities source code on demand to find an interval of substring!
!ReSearchStringSourceAnchor methodsFor: 'accessing' stamp: ''!
interval

	| start tweekedSubstring |
	tweekedSubstring := self searchString isSymbol
		                    ifTrue: [ self searchString keywords first ]
		                    ifFalse: [ self searchString ].

	start := sourceEntity definitionString
		         indexOfSubCollection: tweekedSubstring
		         startingAt: 1.

	^ start to: start + tweekedSubstring size - 1! !

!ReSearchStringSourceAnchor methodsFor: 'initialization' stamp: ''!
initializeEnitity: anEntiy searchString: aString 
	
	self initializeEnitity: anEntiy.
	searchString := aString ! !

!ReSearchStringSourceAnchor methodsFor: 'testing' stamp: ''!
providesInterval

	^ searchString notNil! !

!ReSearchStringSourceAnchor methodsFor: 'accessing' stamp: ''!
searchString
	^ searchString! !

!ReSearchStringSourceAnchor class methodsFor: 'instance creation' stamp: ''!
entity: anEntity string: aString 
	
	^ self basicNew 
		initializeEnitity: anEntity
		searchString: aString;
		yourself! !

!ReSearchingLiteralRule commentStamp: ''!
Checks for repeated literal equality tests that should rather be implemented as a search in a literal collection.!
!ReSearchingLiteralRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'``@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)')! !

!ReSearchingLiteralRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReSearchingLiteralRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses or instead of a searching literal'! !

!ReSearchingLiteralRule methodsFor: 'private' stamp: ''!
isSearchingLiteralExpression: aSearchingNode for: anObjectNode 
	| argument arguments |
	aSearchingNode isMessage ifFalse: [^false].
	arguments := aSearchingNode arguments.
	arguments size = 1 ifFalse: [^false].
	argument := arguments first.
	(#(#= #==) includes: aSearchingNode selector) 
		ifTrue: 
			[^(aSearchingNode receiver = anObjectNode 
				and: [aSearchingNode arguments first isLiteralNode]) or: 
						[aSearchingNode arguments first = anObjectNode 
							and: [aSearchingNode receiver isLiteralNode]]].
	aSearchingNode selector = #| 
		ifTrue: 
			[^(self isSearchingLiteralExpression: aSearchingNode receiver
				for: anObjectNode) 
					and: [self isSearchingLiteralExpression: argument for: anObjectNode]].
	aSearchingNode selector = #or: ifFalse: [^false].
	argument isBlock ifFalse: [^false].
	argument body statements size = 1 ifFalse: [^false].
	^(self isSearchingLiteralExpression: aSearchingNode receiver
		for: anObjectNode) and: 
				[self isSearchingLiteralExpression: argument body statements first
					for: anObjectNode]! !

!ReSearchingLiteralRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	^ self
		isSearchingLiteralExpression: aNode
		for: (mappingDict at: '``@object')! !

!ReSearchingLiteralRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'SearchingLiteralRule'! !

!ReSelfSentNotImplementedRule commentStamp: ''!
This smell arises when a message is sent to self by a method,  but no class in the superclass chain implements such a message. This method sent will certainly cause a doesNotUnderstand: message when they are executed.!
!ReSelfSentNotImplementedRule methodsFor: 'accessing' stamp: ''!
rationale
	^ '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.'! !

!ReSelfSentNotImplementedRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReSelfSentNotImplementedRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReSelfSentNotImplementedRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	| problemSends |
	aMethod methodClass isTrait ifTrue: [ ^ self ].
	problemSends := 
		(aMethod sendNodes select: [ :msgSend | msgSend isSelfSend  | msgSend isSuperSend ]) 
			reject: [:msgSend | aMethod methodClass canUnderstand: (msgSend selector)].
	
	problemSends do: [ :msgSend |
			aCriticBlock cull: (self createTrivialCritiqueOn: aMethod intervalOf: msgSend hint: msgSend selector asString)]! !

!ReSelfSentNotImplementedRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Super and Self Messages sent but not implemented'! !

!ReSelfSentNotImplementedRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReSelfSentNotImplementedRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'SelfSentNotImplementedRule'! !

!ReSelfSentNotImplementedRuleTest commentStamp: ''!
A RBSelfSentNotImplementedRuleTest is a test class for testing the behavior of RBSelfSentNotImplementedRule!
!ReSelfSentNotImplementedRuleTest methodsFor: 'sample' stamp: ''!
sampleMethod
	"Do not highlight this bar. I am a method used in testCheckForCritiques"

	self bar.
	self bar; bar.
	(2 + 5) bar.
	7 < 10 ifTrue: [ self check:7 forCritiquesDo: 9 ]! !

!ReSelfSentNotImplementedRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| critiques|
	critiques := self myCritiques .
	
	self assert: critiques size equals: 4.
	self assert: (self sourceAtChritique: critiques first) equals: 'self bar'.! !

!ReSendsDifferentSuperRule commentStamp: ''!
Checks for methods whose source sends a different super message.

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.!
!ReSendsDifferentSuperRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Checks for methods whose source sends a different super message.'! !

!ReSendsDifferentSuperRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	^ aMethod superMessages anySatisfy: [ :message | message ~= aMethod selector ]! !

!ReSendsDifferentSuperRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReSendsDifferentSuperRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Sends different super message'! !

!ReSendsDifferentSuperRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReSendsDifferentSuperRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'SendsDifferentSuperRule'! !

!ReSendsMethodDictRule commentStamp: ''!
Nobody should directly access the method dictionary. It is purely an implementation artefact that we use one dictionary and it might change in the future.!
!ReSendsMethodDictRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Nobody should directly access the method dictionary. It is purely an implementation artefact that we use one dictionary and it might change in the future'! !

!ReSendsMethodDictRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReSendsMethodDictRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	"in the Behavior classes we want to use the accessor (see comment #methodDict)"
	({Behavior . ClassDescription . Class. Metaclass. TraitedMetaclass. MetaclassForTraits} includes: aMethod methodClass) 
		ifTrue: [ ^ false ].
	^(aMethod refersToLiteral: #methodDict) and: [aMethod messages includes: #methodDict]! !

!ReSendsMethodDictRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReSendsMethodDictRule methodsFor: 'accessing' stamp: ''!
name
	^ 'No direct access of methodDict'! !

!ReSendsMethodDictRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReSendsMethodDictRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'NobodyShouldSendMethodDict'! !

!ReSendsUnknownMessageToGlobalRule commentStamp: ''!
Checks for messages that are sent but not implemented by a global. Reported methods will certainly cause a doesNotUnderstand: message when they are executed.!
!ReSendsUnknownMessageToGlobalRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReSendsUnknownMessageToGlobalRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	aNode isMessage ifFalse: [ ^ false ].

	aNode receiver isLiteralVariable ifFalse: [ ^ false ].
	aNode receiver isUndeclaredVariable ifTrue: [ ^false ].
	aNode receiver isClassVariable ifTrue: [ ^false ].
	
	^ (aNode receiver variable value respondsTo: aNode selector) not! !

!ReSendsUnknownMessageToGlobalRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReSendsUnknownMessageToGlobalRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Sends unknown message to global'! !

!ReSendsUnknownMessageToGlobalRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'SendsUnknownMessageToGlobalRule'! !

!ReSentNotImplementedRule commentStamp: ''!
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.!
!ReSentNotImplementedRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Checks for messages that are sent by a method, but no class in the system implements such a message. Reported methods will certainly cause a doesNotUnderstand: message when they are executed.'! !

!ReSentNotImplementedRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReSentNotImplementedRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReSentNotImplementedRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	| problemSends |
	problemSends := aMethod sendNodes reject: [ :msgSend | 
		                msgSend selector isSelectorSymbol ].
	problemSends do: [ :msgSend | 
		aCriticBlock cull: (self
				 createTrivialCritiqueOn: aMethod
				 intervalOf: msgSend
				 hint: msgSend selector asString) ]! !

!ReSentNotImplementedRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Messages sent but not implemented'! !

!ReSentNotImplementedRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReSentNotImplementedRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'SentNotImplementedRule'! !

!ReSentNotImplementedRuleTest commentStamp: ''!
A RBSentNotImplementedRuleTest is a test class for testing the behavior of RBSentNotImplementedRule!
!ReSentNotImplementedRuleTest methodsFor: 'sample' stamp: ''!
sampleMethod 
	"this is a comment, so whatShallIDoNow should not highlight"
	99 whatShallIDoNow.
	77 andThisIsBogusToo.
	88 even.
	88 whatShallIDoNow! !

!ReSentNotImplementedRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| critiques |
	critiques := self myCritiques.
	
	self assert: critiques size equals: 3.
	self assert: (self sourceAtChritique:  critiques third) equals: '88 whatShallIDoNow'.! !

!ReSettings commentStamp: ''!
i have settings for QA recording functions!
!ReSettings class methodsFor: 'settings-accessing' stamp: ''!
showErrors
	self flag: 'switch to exception strategy completely'.
	"Utilize the ReExceptionStrategy to either skip the exception,
	pass it on, or create a list of exceptions as a reparete
	'category' with all the exceptions that happened."
	
	^ ReExceptionStrategy current = RePassExceptionStrategy! !

!ReSettings class methodsFor: 'settings-definition' stamp: ''!
showErrorsSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #showErrors)
		target: self;
		order: 5;
		default: false;
		label: 'Show errors (dev. only!!)';
		description: 'Signal errors that happen during critique-checking (and related). This should be used by developers.';
		parent: #qualityAssistant.! !

!ReSettings class methodsFor: 'settings-definition' stamp: ''!
resetButtonSettingsOn: aBuilder
	<systemsettings>
		
	(aBuilder group: #'resetRules')
		order: 10;
		target: self;
		label: 'Rule cache';
		parent: #qualityAssistant;
		description: 'Renraku (the engine behind quality rules) caches the rule objects for performance boost. Here you can reset the cache, this may be useful if you''ve implemented a new rule and want to include it.';
		dialog: [
			SimpleButtonMorph new
				target: ReRuleManager;
				label: 'Reset rule cache';
				actionSelector: #resetWithInform;
				themeChanged;
				yourself ].! !

!ReSettings class methodsFor: 'accessing' stamp: ''!
uniqueInstance
	
	^ uniqueInstance ifNil: [ uniqueInstance := self new ]! !

!ReSettings class methodsFor: 'cleanup' stamp: ''!
cleanUp
	
	uniqueInstance := nil! !

!ReSettings class methodsFor: 'settings-accessing' stamp: ''!
showErrors: aBoolean

	ReExceptionStrategy current: (aBoolean 
		ifTrue: [ RePassExceptionStrategy ]
		ifFalse: [ ReIgnoreExceptionStrategy ]).! !

!ReShouldSendSuperSetUpAsFirstMessage commentStamp: ''!
In a test case the setUp method should call super setUp as first message!
!ReShouldSendSuperSetUpAsFirstMessage methodsFor: 'testing' stamp: ''!
isClassToCheck: aClass

	^ { TestCase. TestResource } anySatisfy: [:each | aClass inheritsFrom: each ]! !

!ReShouldSendSuperSetUpAsFirstMessage methodsFor: 'running' stamp: ''!
basicCheck: aMethod

	^ (self isClassToCheck: aMethod methodClass) and: [ aMethod selector = #setUp and: [ self class superSetUpNotCalledFirstIn: aMethod ] ]! !

!ReShouldSendSuperSetUpAsFirstMessage methodsFor: 'running' stamp: ''!
group
	^ 'SUnit'! !

!ReShouldSendSuperSetUpAsFirstMessage methodsFor: 'accessing' stamp: ''!
name

	^ 'Provide a call to super setUp as the first message in the setUp method'! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'testing-interest' stamp: ''!
checksMethod

	^ true! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'utilities' stamp: ''!
parseTreeSearcher
	^ RBParseTreeSearcher new! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'utilities' stamp: ''!
superSetUpNotCalledFirstIn: aCompiledMethod
	"Return true if the method is a setUp method and a call to super setUp is not the first message send."

	| searcher |
	searcher := self parseTreeSearcher
		matchesAnyMethodOf:
			#('setUp             super setUp. `.@any' 'setUp | `@temps | super setUp. `.@any')
			do: [ :node :answer | true ];
		yourself.
	^ (searcher
		executeTree: aCompiledMethod ast
		initialAnswer: false) not! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ReShouldSendSuperSetUpAsFirstMessage class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ReShouldSendSuperTearDownAsLastMessage commentStamp: ''!
In a test case the tearDown method should call super tearDown as last message!
!ReShouldSendSuperTearDownAsLastMessage methodsFor: 'testing' stamp: ''!
isClassToCheck: aClass

	^ { TestCase. TestResource } anySatisfy: [:each | aClass inheritsFrom: each ]! !

!ReShouldSendSuperTearDownAsLastMessage methodsFor: 'running' stamp: ''!
basicCheck: aMethod

	^ (self isClassToCheck: aMethod methodClass) and: [ aMethod selector = #tearDown and: [ self class superTearDownNotCalledLastIn: aMethod ] ]! !

!ReShouldSendSuperTearDownAsLastMessage methodsFor: 'running' stamp: ''!
group
	^ 'SUnit'! !

!ReShouldSendSuperTearDownAsLastMessage methodsFor: 'accessing' stamp: ''!
name

	^ 'Provide a call to super tearDown as the last message in the tearDown method'! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'testing-interest' stamp: ''!
checksMethod

	^ true! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'utilities' stamp: ''!
parseTreeSearcher
	^ RBParseTreeSearcher new! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'utilities' stamp: ''!
superTearDownNotCalledLastIn: aCompiledMethod
	"Return true if the method is a tearDown method and a call to super tearDown is not the last message send."

	| searcher |
	searcher := self parseTreeSearcher
		matchesAnyMethodOf:
			#('tearDown             `.@any. super tearDown' 'tearDown | `@temps | `.@any. super tearDown')
			do: [ :node :answer | true ];
		yourself.
	^ (searcher
		executeTree: aCompiledMethod ast
		initialAnswer: false) not! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ReShouldSendSuperTearDownAsLastMessage class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ReShouldTransformedIntoAssertRule commentStamp: ''!
should: will be deprecated sooner or leater. Use assert: instead!
!ReShouldTransformedIntoAssertRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	self
		replace: 'self should: [ ``@object1 ]'
		with: 'self assert: ``@object1'! !

!ReShouldTransformedIntoAssertRule methodsFor: 'running' stamp: ''!
group
	^ 'SUnit'! !

!ReShouldTransformedIntoAssertRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Use assert: instead of should:'! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ReShouldTransformedIntoAssertRule class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ReShouldTransformedIntoAssertRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	
	^'ShouldTransformedIntoAssert'! !

!ReShouldntRaiseErrorRule commentStamp: ''!
#shouldnt:raise: is a rather tricky method, it is mostly used to make a
test "read" nicer, however it some severe drawbacks. Hence, it should only
be used in certain cases. Consider the following examples.

Example 1:
----------
	self
		shouldnt: [ 1 somethingNotUnderstood ]
		raise: MessageNotUnderstood.

In this particular case the expectations meet the result, the test fails with
an assertion failure since a MNU is raised.

Example 2:
----------
	self shouldnt: [ 1/0 ] raise: MessageNotUnderstood.

In this case the test will fail with a ZeroDivide. So in the negative case
#shouldnt:raise: is not very helpful. 

As a result, #shouldnt:raise: does not change much on the test outcome, the
statement itself produces the same failures. However there is the third and
most common use case.

Example 3:
----------
	self shouldnt: [ 1/0 ] raise: Error.

In this case the test fails, as expected, however not on a ZeroDivide but an
internal error message that shadows the real error. Using Error as argument for
#shouldnt:raise: shadows any possible error that might happen and thus should
be avoided.!
!ReShouldntRaiseErrorRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: 'self shouldnt: [ `@statements ] raise: Error' with: '`@statements';
		replace: 'self shouldnt: [ `@statements ] raise: Exception' with: '`@statements'! !

!ReShouldntRaiseErrorRule methodsFor: 'accessing' stamp: ''!
rationale 
	^ 'Replaces `shouldnt: [ ... ] raise: Error` with  `[ ... ]`'! !

!ReShouldntRaiseErrorRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReShouldntRaiseErrorRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Do not use  `shouldnt: [ ... ] raise: Error` '! !

!ReShouldntRaiseErrorRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ShouldntRaiseErrorRule'! !

!ReSingleCritiqueEvent commentStamp: ''!
A Renraku event with a single critic.!
!ReSingleCritiqueEvent methodsFor: 'accessing' stamp: ''!
critique
	^ critique! !

!ReSingleCritiqueEvent methodsFor: 'accessing' stamp: ''!
critique: aCritique
	critique := aCritique! !

!ReSizeCheckRule commentStamp: ''!
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.!
!ReSizeCheckRule methodsFor: 'initialization' stamp: ''!
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 matchesAny: patterns! !

!ReSizeCheckRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReSizeCheckRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Unnecessary size check'! !

!ReSizeCheckRule methodsFor: 'private' stamp: ''!
genericPatternForSelector: aSymbol
	^ String streamContents: [ :stream |
		aSymbol keywords keysAndValuesDo: [ :index :value |
			stream space; nextPutAll: value.
			aSymbol last = $:
				ifTrue: [ stream space; nextPutAll: '`@object'; print: index ] ] ]! !

!ReSizeCheckRule methodsFor: 'private' stamp: ''!
selectors
	^ #( collect: do: reject: select: )! !

!ReSizeCheckRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'SizeCheckRule'! !

!ReSmalllintChecker commentStamp: ''!
Same as SmalllintManifestChecker but with tweaks for Renraku model !
!ReSmalllintChecker methodsFor: 'private' stamp: ''!
reParseRule

	methodRules := Set new.
	nodeRules := Set new.
	classRules := Set new.
	packageRules := Set new.

	self rule do: [ :r | 
		r class checksMethod ifTrue: [ methodRules add: r ].
		r class checksNode ifTrue: [ nodeRules add: r ].
		r class checksClass ifTrue: [ classRules add: r ] ]! !

!ReSmalllintChecker methodsFor: 'private' stamp: ''!
checkClass: aClass

	(environment includesClass: aClass) ifFalse: [ ^ self ].

	self getCritiquesAbout: aClass by: classRules! !

!ReSmalllintChecker methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self resetResult ! !

!ReSmalllintChecker methodsFor: 'running' stamp: ''!
resetResult

	critiques := Set new! !

!ReSmalllintChecker methodsFor: 'accessing' stamp: ''!
criticsOf: aRule

	^ critiques
		select: [ :c | c rule class = aRule class ]! !

!ReSmalllintChecker methodsFor: 'manifest' stamp: ''!
falsePositiveOf: aRule

	| ruleCritiques rId rV mb |

	ruleCritiques := self criticsOf: aRule.
	rId := aRule class uniqueIdentifierName.
	rV := aRule class identifierMinorVersionNumber.
	^ ruleCritiques
		select: [ :critique | 
			| entity |

			entity := critique sourceAnchor entity.
			mb := self manifestBuilderOf: entity.
			mb ifNil: [ false ] ifNotNil: [ mb isFalsePositive: entity onRule: rId version: rV ]
			]! !

!ReSmalllintChecker methodsFor: 'private' stamp: ''!
getCritiquesAbout: anEntity by: rules

	rules do: [ :r |
		[ r
			check: anEntity
			forCritiquesDo: [ :crit |
				self addCritique: crit ] ]
			
			on: Error
			do: [ :er | ReSettings showErrors ifTrue: [ er pass ]  ] ]! !

!ReSmalllintChecker methodsFor: 'accessing' stamp: ''!
rule
	
	^ (rule isKindOf: RBCompositeLintRule)
		ifTrue: [ rule leaves ]
		ifFalse: [ rule ]! !

!ReSmalllintChecker methodsFor: 'actions' stamp: ''!
run
	self reParseRule.
	super run! !

!ReSmalllintChecker methodsFor: 'adding' stamp: ''!
addCritique: aCritique
		^ critiques add: aCritique! !

!ReSmalllintChecker methodsFor: 'private' stamp: ''!
checkMethodsForClass: aClass
	
	environment
		selectorsForClass: aClass
		do: [ :selector | | method ast |
			method := aClass>>selector.
			self getCritiquesAbout: method by: methodRules.
			nodeRules do: [ :r |
				ast := method ast.
				"for rewrite rules, we run every rule on a copy of the ast"
				r isRewriteRule ifTrue: [ ast := ast copy  ].
				ast nodesDo: [ :node |
						r
							check: node
							forCritiquesDo: [ :crit |
								crit sourceAnchor initializeEnitity: method.
								self addCritique: crit ] ] ]] ! !

!ReSmalllintChecker methodsFor: 'manifest' stamp: ''!
toDoOf: aRule

	| ruleCritiques rId rV mb |

	ruleCritiques := self criticsOf: aRule.
	rId := aRule class uniqueIdentifierName.
	rV := aRule class identifierMinorVersionNumber.
	^ ruleCritiques
		select: [ :critique | 
			| entity |

			entity := critique sourceAnchor entity.
			mb := self manifestBuilderOf: entity.
			mb ifNil: [ false ] ifNotNil: [ mb containsToDo: entity onRule: rId version: rV ]
			]! !

!ReSmalllintChecker methodsFor: 'private' stamp: ''!
checkPackage: aPackage

	(environment includesPackage: aPackage) ifTrue: [
		self getCritiquesAbout: aPackage by: packageRules ]! !

!ReSmalllintCheckerTest methodsFor: 'tests' stamp: ''!
testRun
	| checker |
	
	checker := ReSmalllintChecker new
		rule: { ScreamerRule new };
		environment: testPackage asEnvironment;
		yourself.
		
	checker run.
	
	self assert: (checker criticsOf: ScreamerRule new) notEmpty.! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
classRuleFor: aTestSelector plusClasses: aCollectionOfTestedClasses
	| result expectedResultEnvironment |
	result := self
		runRuleFor: aTestSelector
		onEnvironment: self classEnvironmentWithAllObjectClasses.
	expectedResultEnvironment :=
		self classEnvironmentWithAll:
			(aCollectionOfTestedClasses copyWith:
				(self objectClassFor: aTestSelector)).
	self
		assertResultOfRule: result
		hasSameClassesAsEnvironment: expectedResultEnvironment! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testFloatEqualityComparison
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
assertIsValidRule: aRule
	self
		assert: (aRule name isString and: [ aRule name notEmpty ])
		description: 'Missing rule name'.
	self
		assert: (aRule group isString and: [ aRule group notEmpty ])
		description: 'Missing group name'.
	self
		assert: (aRule rationale isString and: [ aRule rationale notEmpty ])
		description: 'Missing rationale'.
	self
		assert: (#(error warning information) includes: aRule severity)
		description: 'Invalid severity'! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testTempVarOverridesInstVar
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
assertEnvironment: anEnvironment hasAllMethodsOfTheResult: critiques

	critiques do: [ :crit |
		| target |
		target := crit entity.
		self assert: target isCompiledMethod.
		self assert: (anEnvironment includesMethod: target) ]! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testToDoWithIncrement
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testUnaryAccessingMethodWithoutReturn
	self
		ruleFor: self currentSelector
		plusSelectors:
			#(#unaryAccessingMessageStatementMethodWithoutReturn
				#unaryAccessingBranchingStatementMethodWithoutReturn)! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testCollectSelectNotUsed
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testUncommonMessageSend
	self ruleFor: self currentSelector plusSelectors: {#uncommonMessageSend2}! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testEqualsTrue
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testCodeCruftLeftInMethods
	self ruleFor: self currentSelector plusSelectors: #(haltClassMentioned flagged transcriptMentioned debbuggingMessageSent)! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
classNamed: aSymbol
	^ self class environment
		at: aSymbol
		ifAbsent: [ self error: aSymbol asString , ' class not found' ]! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testBadMessage
	self ruleFor: self currentSelector plusSelectors: #(badMessage collectionMessagesToExternalObject)! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testExtraBlock
	self 
		ruleFor: self currentSelector
		plusSelectors: #(#testMethod1 )! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testReturnInEnsure
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testUnoptimizedAndOr
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testAssignmentInBlock
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testReturnsIfTrue
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
assertResultOfRule: critiques hasSameSelectorsAsEnvironment: anEnvironment
	self assertResult: critiques hasAllMethodsInEnvironment: anEnvironment.
	self assertEnvironment: anEnvironment hasAllMethodsOfTheResult: critiques! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testYourselfNotUsed
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testUnclassifiedMethods
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testRBMissingSubclassResponsibilityRule
	| superClass subClass1 subClass2 rule |
	rule := ReMissingSubclassResponsibilityRule new.

	superClass := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: 'MySuperclass';
			package: self class category ].

	subClass1 := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: 'MySubclass1';
			superclass: superClass;
			package: self class category ].

	subClass2 := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: 'MySubclass2';
			superclass: superClass;
			package: self class category ].

	subClass1 compile: 'method ^ 3'.
	subClass2 compile: 'method ^ 5'.

	self denyEmpty: (rule check: superClass).

	superClass compile: 'method ^ 2'.

	self assertEmpty: (rule check: superClass).

	superClass compile: 'method ^self subclassResponsibility'.

	self assertEmpty: (rule check: superClass).

	subClass1 removeFromSystem.
	subClass2 removeFromSystem.
	superClass removeFromSystem! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testModifiesCollection
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testCollectionProtocol
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
objectClassSelectorFor: aTestSelector
	^ (aTestSelector asString allButFirst: 4) "'test' size"
		uncapitalized asSymbol! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testSendsDifferentSuper
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testBooleanPrecedence
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testGuardingClause
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testLongMethods
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
assertEnvironment: anEnvironment hasAllClassesOfTheResult: critiques

	critiques do: [ :crit |
		| target |
		target := crit entity.
		self assert: target isClass.
		self assert: (anEnvironment includesClass: target) ]! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testNoClassComment
	self classAndMetaClassRuleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
classEnvironmentWithAll: aClassCollection
	| classEnvironment |
	classEnvironment := RBClassEnvironment new.
	aClassCollection do: [ :each | classEnvironment addClass: each ].
	^ classEnvironment! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
runRule: aRule onEnvironment: anEnvironment
	| runner |
	self assertIsValidRule: aRule.
	runner := ReSmalllintChecker new.
	runner 
		rule: {aRule};
		environment: anEnvironment;
		run.
	^ runner.! !

!ReSmalllintTest methodsFor: 'tests - unique identifier' stamp: ''!
testUniqueIdentifierName

	| idToRules |

	idToRules := Dictionary new.
	RBLintRule allSubclasses do: [ :ruleClass | 
		(idToRules at: ruleClass uniqueIdentifierName ifAbsentPut: [ Set new ]) add: ruleClass ].
	self assert: (idToRules noneSatisfy: [ :ruleClasses | ruleClasses size > 1 ]).! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
ruleFor: aTestSelector plusSelectors: aCollectionOfTestedSelectors
	| result expectedResultEnvironment |
	result := self
		runRuleFor: aTestSelector
		onEnvironment: (self classEnvironmentWith: RBSmalllintTestObject).
	expectedResultEnvironment := RBSelectorEnvironment new.
	(aCollectionOfTestedSelectors
		copyWith: (self objectClassSelectorFor: aTestSelector))
		do: [ :each | 
			expectedResultEnvironment addClass: RBSmalllintTestObject selector: each.
			self
				assert: (RBSmalllintTestObject includesSelector: each)
				description: 'Missing test method RBSmalllintTestObject>>' , each printString ].
	self
		assertResultOfRule: result
		hasSameSelectorsAsEnvironment: expectedResultEnvironment! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testEmptyExceptionHandler
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
runRuleFor: aTestSelector onEnvironment: anEnvironment
	| rule runner |
	rule := (self ruleClassFor: aTestSelector) new.
	self assertIsValidRule: rule.
	runner := ReSmalllintChecker new.
	runner 
		rule: {rule};
		environment: anEnvironment;
		run.
	^ runner criticsOf: rule.! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testLiteralArrayContainsComma
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testAnySatisfy
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testEqualNotUsed
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testRefersToClass
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'asserting' stamp: ''!
assertResult: critiques hasAllMethodsInEnvironment: anEnvironment
	anEnvironment methodsDo: [ :method |
		self assert: (critiques anySatisfy: [ :crit |
			crit entity = method ]) ]! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testDefinesEqualNotHash
	self classRuleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testClassNotReferenced
	self classAndMetaClassRuleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testPrecedence
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testLiteralArrayContainsSuspiciousTrueFalseOrNil
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testAssignmentWithoutEffect
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testThreeElementPoint
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
classAndMetaClassRuleFor: aTestSelector
	self classAndMetaClassRuleFor: aTestSelector plusClasses: #()! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testTempsReadBeforeWritten
	self ruleFor: self currentSelector
		plusSelectors: #(#inlineTemporary #noMoveDefinition #tempsReadBeforeWritten #equalNotUsed #fileBlocks #referencesConditionFor:)! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testSizeCheck
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
classEnvironmentWithAllObjectClasses
	^ self classEnvironmentWithAll: RBSmalllintTestSuperclassObject withAllSubclasses! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testEquivalentSuperclassMethods
	^ self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testAssignmentInIfTrue
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testWhileTrue
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testDetectContains
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
ruleFor: aTestSelector
	self ruleFor: aTestSelector plusSelectors: #()! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testAtIfAbsent
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testCollectionMessagesToExternalObject
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testMinMax
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
classRuleFor: aTestSelector
	^ self classRuleFor: aTestSelector plusClasses: #()! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testCollectionAtCollectionSize
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testReturnsBooleanAndOther
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testJustSendsSuper
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testMultiplePeriodsTerminatingStatement
	self
		ruleFor: self currentSelector
		plusSelectors: #(multiplePeriodsTerminatingAssignmentStatement)! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
assertResultOfRule: critiques hasSameClassesAsEnvironment: anEnvironment
	self assertResult: critiques hasAllClassesInEnvironment: anEnvironment.
	self assertEnvironment: anEnvironment hasAllClassesOfTheResult: critiques! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testStringConcatenation
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testAsOrderedCollectionNotNeeded
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
objectClassFor: aTestSelector
	^ self classNamed:
		('RBSmalllintTest',
		(aTestSelector asString allButFirst: 4 "'test' size"),
		'Object') asSymbol! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testAddRemoveDependents
	self classRuleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'asserting' stamp: ''!
assertResult: critiques hasAllClassesInEnvironment: anEnvironment
	anEnvironment classesDo: [ :class |
		self assert: (critiques anySatisfy: [ :crit |
			crit entity instanceSide = class instanceSide ]) ]! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
classEnvironmentWith: aClass
	^ self classEnvironmentWithAll: (Array with: aClass)! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testLiteralArrayCharacters
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testSearchingLiteral
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testToDo
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testFileBlocks
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testShouldntRaiseError
	self
		ruleFor: self currentSelector
		plusSelectors: #(shouldntRaiseException)! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testToDoCollect
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
ruleClassFor: aTestSelector
	^ self classNamed:
		('Re',
		(aTestSelector asString allButFirst: 4), "'test' size"
		'Rule') asSymbol.! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testEndTrueFalse
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testLocalMethodsSameThanTrait
	self classAndMetaClassRuleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
classAndMetaClassRuleFor: aTestSelector plusClasses: aCollectionOfTestedClasses
	| result expectedResultClasses expectedResultEnvironment |
	result := self
		runRuleFor: aTestSelector
		onEnvironment: self classEnvironmentWithAllObjectClasses.
	expectedResultClasses :=
		(aCollectionOfTestedClasses copyWith: (self objectClassFor: aTestSelector)).
	expectedResultEnvironment :=
		self classEnvironmentWithAll: expectedResultClasses.
	expectedResultClasses do: [ :each |
		expectedResultEnvironment addClass: each classSide ].
	self
		assertResultOfRule: result
		hasSameClassesAsEnvironment: expectedResultEnvironment! !

!ReSmalllintTest methodsFor: 'private' stamp: ''!
currentSelector
	^ testSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testUsesAdd
	self ruleFor: self currentSelector! !

!ReSmalllintTest methodsFor: 'tests' stamp: ''!
testUsesTrue
	self ruleFor: self currentSelector! !

!ReSmalllintTest class methodsFor: 'accessing' stamp: ''!
packageNamesUnderTest
	^ #('Refactoring-Critics')! !

!ReSmalltalkGlobalsRule commentStamp: ''!
Do not send requests to "Smalltalk" (which models the whole image)  that are related to the envionment of defines classes and globals!
!ReSmalltalkGlobalsRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: 'Smalltalk allClasses'
			with: 'Smalltalk globals allClasses';
		replace: 'Smalltalk allClassesDo: `@statements'
			with: 'Smalltalk globals allClassesDo: `@statements';
		replace: 'Smalltalk allTraits'
			with: 'Smalltalk globals allTraits';
		replace: 'Smalltalk includes:`@statements'
			with: 'Smalltalk globals includes: `@statements';
		replace: 'Smalltalk flushClassNameCache'
			with: 'Smalltalk globals flushClassNameCache';
		replace: 'Smalltalk includesKey: `@statements'
			with: 'Smalltalk globals includesKey: `@statements'.! !

!ReSmalltalkGlobalsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReSmalltalkGlobalsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Use "Smalltalk globals" instead of "Smalltalk"'! !

!ReSmalltalkGlobalsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^ 'SmalltalkGlobalsRule'! !

!ReSmokeExceptionStrategyTest methodsFor: 'running' stamp: ''!
tearDown

	brokenRule removeFromSystem.
	brokenRule := nil.
	super tearDown.! !

!ReSmokeExceptionStrategyTest methodsFor: 'tests' stamp: ''!
testPass

	ReExceptionStrategy current: RePassExceptionStrategy.
	
	self should: [ thisContext method method critiques ]
		raise: MyTestError.! !

!ReSmokeExceptionStrategyTest methodsFor: 'tests' stamp: ''!
testIgnore
	| critiques |

	ReExceptionStrategy current: ReIgnoreExceptionStrategy.
	
	self shouldnt: [
			critiques := thisContext method method critiques ]
		raise: MyTestError.! !

!ReSmokeExceptionStrategyTest methodsFor: 'tests' stamp: ''!
testLog
	| critiques method |
	method := thisContext method.

	ReExceptionStrategy current: ReLogExceptionStrategy.
	
	self shouldnt: [
		critiques := method critiques ]
		raise: MyTestError.
		
	self assert: (critiques anySatisfy: [ :crit | 
		(crit isKindOf: ReExceptionProperty) and: [
		 crit sourceAnchor entity = method and: [
		(crit message includesSubstring: self errorMessage) and: [
		 crit stack callChainAnySatisfy: [ :context |
			context method = method ] ] ] ] ])! !

!ReSmokeExceptionStrategyTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.

	brokenRule := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: #ReBrokenRuleForTesting;
			superclass: ReAbstractRule;
			package: self class category ].

		
	brokenRule class
		compile: 'checksMethod ^ true'.
		
	brokenRule
		compile: 'name ^ ''A purpously broken rule to test exception handling''';
		compile: 'check: aNode forCritiquesDo: aBlock
						MyTestError signal: ',
						self errorMessage surroundedBySingleQuotes.
						
	ReRuleManager reset! !

!ReSourceAnchor commentStamp: ''!
A source anchor has a reference to the actual class, method, or other entity that is criticized. An anchor also has a #providesInterval method that returns a boolean indicating if the anchor provides a selection interval to the actual source of the critique. The interval can be accessed through the #interval method.!
!ReSourceAnchor methodsFor: 'initialization' stamp: ''!
initializeEnitity: anEntity 
	
	sourceEntity := anEntity! !

!ReSourceAnchor methodsFor: 'accessing' stamp: ''!
interval

	^ nil! !

!ReSourceAnchor methodsFor: 'accessing' stamp: ''!
entity
	^ self sourceEntity! !

!ReSourceAnchor methodsFor: 'testing' stamp: ''!
providesInterval

	^ false! !

!ReSourceAnchor methodsFor: 'accessing' stamp: ''!
sourceEntity
	^ sourceEntity! !

!ReSourceAnchor class methodsFor: 'instance creation' stamp: ''!
entity: anEntity 
	^ self basicNew
		initializeEnitity: anEntity;
		yourself! !

!ReStringBasedCritique commentStamp: ''!
I am a critic that provides a selection interval by searching a 'faulty substring' in the target's source code. I also use the 'faulty substring' to enhence the critic's title!
!ReStringBasedCritique methodsFor: 'testing' stamp: ''!
providesChange
	^ false! !

!ReStringBasedCritique methodsFor: 'initialization' stamp: ''!
initializeRule: aRule target: anEntity badString: aString

	self
		initializeRule: aRule
		sourceAnchor: (
			ReSearchStringSourceAnchor
				entity: anEntity
				string: aString)! !

!ReStringBasedCritique methodsFor: 'accessing' stamp: ''!
change
	^ self shouldNotImplement! !

!ReStringBasedCritique methodsFor: 'accessing' stamp: ''!
title
	^ '[', sourceAnchor searchString, '] ', super title! !

!ReStringBasedCritique class methodsFor: 'instance creation' stamp: ''!
for: anEntity by: aRule badString: aString
	^ self basicNew
		initializeRule: aRule target: anEntity badString: aString;
		yourself ! !

!ReStringConcatenationRule commentStamp: ''!
Check for string concatenation inside some iteration message. Since string concatenation is O(n^2), it is better to use streaming since it is O(n) - assuming that n is large enough. As a general principal avoid , since the receiver is copied. Therefore chaining , messages will lead to multiple useless copies of the receiver. 

Instead of writing
	| string | 
	string := String new.
	#(1 2 3) do: [ :each |
		string := string, each asString].
	^ string

Write, it is much more efficient.

	String streamContents: [:s | 
		#(1 2 3)  do: [:each | s nextPutAll: each asString]]
	
or more concisely...
	'''' join: {1. 1+1. 3}	
!
!ReStringConcatenationRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self  matchesAny: #(
		'``@collection do: ``@argument' 
		'``@collection do: ``@argument separatedBy: ``@argument2' 
		'``@start to: ``@stop do: ``@argument' 
		'``@collection detect: ``@argument' 
		'``@collection detect: ``@argument ifNone: ``@argument2' 
		'``@collection select: ``@argument'
		'``@collection reject: ``@argument' 
		'``@collection inject: ``@value into: ``@argument'
		'``@collection anySatisfy: ``@argument'
		'``@collection allSatisfy: ``@argument'
		'``@collection noneSatisfy: ``@argument' )! !

!ReStringConcatenationRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReStringConcatenationRule methodsFor: 'hooks' stamp: ''!
performsConcatenation: aNode

	aNode isBlock ifFalse: [ ^ false ].
	aNode nodesDo: [ :node |
		(node isMessage and: [ 
		node selector = #, ]) ifTrue: [ 
			^ true ] ].
	
	^ false! !

!ReStringConcatenationRule methodsFor: 'accessing' stamp: ''!
name
	^ 'String concatenation instead of streams'! !

!ReStringConcatenationRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	(self performsConcatenation: (mappingDict at: '``@argument'))
		ifTrue: [ ^ true ].
		
	(mappingDict
		at: '``@argument2'
		ifPresent: [ :arg2 |
			^ self performsConcatenation: arg2 ]).
		
	^ false! !

!ReStringConcatenationRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'StringConcatenationRule'! !

!ReSubclassResponsibilityNotDefinedRule commentStamp: ''!
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.!
!ReSubclassResponsibilityNotDefinedRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Checks that all methods which send #subclassResponsibility, which indicates that they are abstract, are defined in all leaf classes.'! !

!ReSubclassResponsibilityNotDefinedRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReSubclassResponsibilityNotDefinedRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReSubclassResponsibilityNotDefinedRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock

	(aClass whichSelectorsReferTo: #subclassResponsibility) do:  
		[ :selector | 
		(aClass subclasses do: [ :class | 
				(class subclasses isEmpty and:
				[ (class whichClassIncludesSelector: selector) == aClass ]) ifTrue: [ 
					aCriticBlock cull: (ReMissingMethodCritique
						for: aClass
						by: self
						class: class
						selector: selector)
						beShouldBeImplemented;
						yourself ] ]) ].! !

!ReSubclassResponsibilityNotDefinedRule methodsFor: 'accessing' stamp: ''!
name
	^ '#subclassResponsibility not defined'! !

!ReSubclassResponsibilityNotDefinedRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReSubclassResponsibilityNotDefinedRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'SubclassResponsibilityNotDefinedRule'! !

!ReSuperSendsNewRule commentStamp: ''!
This rule checks for method that wrongly initialize an object twice. Contrary to other Smalltalk implementations Pharo automatically calls #initiailize on object creation.
A warning is raised when the statement self new initialize is found in a method.!
!ReSuperSendsNewRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'super new initialize'
			'(super new: `@expr) initialize'
			'self new initialize'
			'(self new: `@expr) initialize' )! !

!ReSuperSendsNewRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReSuperSendsNewRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Sends super new initialize or self new initialize'! !

!ReSuperSendsNewRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	^ aNode methodNode methodClass isMeta! !

!ReSuperSendsNewRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'SuperSendsNewRule'! !

!ReSuperSendsRule commentStamp: ''!
Rewrite super messages to self messages when both refer to same method!
!ReSuperSendsRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		replace: 'super `@message: ``@args' 
		with: 'self `@message: ``@args'! !

!ReSuperSendsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReSuperSendsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Rewrite super messages to self messages'! !

!ReSuperSendsRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict

	^aNode methodNode methodClass withAllSubclasses noneSatisfy: [: class | 
		class includesSelector: aNode selector ]! !

!ReSuperSendsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'SuperSendsRule'! !

!ReSuperWithoutSend commentStamp: ''!
"super" only makes sense when used as the receiver of a message.

	super doSomething.
	
For every other use, it is just the same as "self".
!
!ReSuperWithoutSend methodsFor: 'running' stamp: ''!
basicCheck: aNode
	aNode isVariable ifFalse: [ ^ false ].
	aNode isSuperVariable ifFalse: [ ^ false ].
	aNode parent isMessage ifTrue: [
		"if we are the receiver, everything is ok"  
		^aNode parent receiver ~= aNode
	].
	^true.! !

!ReSuperWithoutSend methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReSuperWithoutSend methodsFor: 'accessing' stamp: ''!
name
	^ 'super makes only sense as the receiver of a message'! !

!ReSuperWithoutSendTest methodsFor: 'tests' stamp: ''!
testBasicCheck

	| ast |
	ast :=  self class compiler parse: 'testMethod ^super'.
	self assert: (ReSuperWithoutSend new basicCheck: ast variableNodes first).
	self deny: (ReSuperWithoutSend new basicCheck: ast statements first).
	ast := self class compiler parse: 'testMethod ^ super doit'.
	self deny: (ReSuperWithoutSend new basicCheck: ast variableNodes first).
	ast := self class compiler parse: 'testMethod ^ self doit: super'.
	self assert: (ReSuperWithoutSend new basicCheck: ast variableNodes second).! !

!ReSystemAnnouncer commentStamp: ''!
I announnce events related to Renraku and it's users.

To see the possible announcements check ReCriticEvent hierarchy.

To subscribe use:

```Smalltalk
ReSystemAnnouncer uniqueInstance weak ...
``` !
!ReSystemAnnouncer methodsFor: 'announce' stamp: ''!
notifyCritique: aCritique descriptionViewedFor: anEntity

	self announce: (
		ReCritiqueDescriptionViewed new 
			critique: aCritique;
			entity: anEntity;
			yourself)
  ! !

!ReSystemAnnouncer methodsFor: 'announce' stamp: ''!
notifyEntity: anEntity criticizedWith: critiques

	self announce: (
		ReEntityCriticized new 
			critiques: critiques;
			entity: anEntity;
			yourself)
! !

!ReSystemAnnouncer methodsFor: 'announce' stamp: ''!
notifyCritique: aCritique of: anEntity bannedOn: anEntityBanLevel

	self announce: (
		ReCritiqueBanned new
			critique: aCritique;
			entity: anEntity;
			entityBanLevel: anEntityBanLevel;
			yourself)
! !

!ReSystemAnnouncer class methodsFor: 'instance creation' stamp: ''!
uniqueInstance
	"I'm a singleton…"
	
	^ uniqueInstance ifNil: [ uniqueInstance := self new ]! !

!ReTSUnitGroupedRule commentStamp: ''!
Marker Trait for rules within SUnit group!
!ReTSUnitGroupedRule methodsFor: 'running' stamp: ''!
group
	^ 'SUnit'! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ReTSUnitGroupedRule classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ReTSUnitGroupedRule classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ReTSUnitGroupedRule classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ReTSUnitGroupedRule classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ReTSUnitGroupedRule classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ReTSUnitGroupedRule classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReTSUnitGroupedRule classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ReTSUnitGroupedRule classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ReTSUnitGroupedRule classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ReTSUnitGroupedRule classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReTSUnitGroupedRule classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ReTSUnitGroupedRule classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ReTSUnitGroupedRule classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ReTSUnitGroupedRule classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ReTSUnitGroupedRule classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ReTSUnitGroupedRule classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ReTempVarOverridesInstVarRule commentStamp: ''!
Finds methods whose arguments or temporary variables ooverride an instance variable. This causes problems if you want to use the instance variable inside the method.!
!ReTempVarOverridesInstVarRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReTempVarOverridesInstVarRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock

	| problemTemps |
	problemTemps := aMethod ast variableDefinitionNodes 
		 collect: [ :node | node variable ]
		 thenSelect: [ :var | var isShadowing ].
	problemTemps do: [ :var | 
		aCriticBlock cull:
			(self critiqueFor: aMethod about: var definingNode) ]! !

!ReTempVarOverridesInstVarRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Outer variable shadowed by temporary variable or argument'! !

!ReTempVarOverridesInstVarRule methodsFor: 'running - helpers' stamp: ''!
critiqueFor: aMethod about: aVarNode
	^ (ReTrivialCritique
		withAnchor: (ReIntervalSourceAnchor
			entity: aMethod
			interval: aVarNode sourceInterval)
		by: self)
		tinyHint: aVarNode name;
		yourself! !

!ReTempVarOverridesInstVarRule class methodsFor: 'testing-interest' stamp: ''!
checksMethod
	^ true! !

!ReTempVarOverridesInstVarRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'TempVarOverridesInstVarRule'! !

!ReTempVarOverridesInstVarRuleTest commentStamp: ''!
A RBTempVarOverridesInstVarRuleTest is a test class for testing the behavior of RBTempVarOverridesInstVarRule!
!ReTempVarOverridesInstVarRuleTest methodsFor: 'accessing' stamp: ''!
dummy2
	^ dummy2! !

!ReTempVarOverridesInstVarRuleTest methodsFor: 'accessing' stamp: ''!
dummy4
	^ dummy4! !

!ReTempVarOverridesInstVarRuleTest methodsFor: 'accessing' stamp: ''!
dummy3
	^ dummy3! !

!ReTempVarOverridesInstVarRuleTest methodsFor: 'sample' stamp: ''!
sampleMethod: dummy1
	"I override dummy1, dummy2, dummy3  "
	| dummy2 |
	dummy2 := [ :dummy3 | dummy4 := dummy1 + dummy3 ].
	^ dummy2 value: dummy1.! !

!ReTempVarOverridesInstVarRuleTest methodsFor: 'accessing' stamp: ''!
dummy1
	^ dummy1! !

!ReTempVarOverridesInstVarRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| critiques |
	critiques := self myCritiquesOnMethod: self class >> #sampleMethod:.
	
	self assert: critiques size equals: 3.
	self assert: (self sourceAtChritique:  critiques first) equals: 'dummy1'.
	self assert: (self sourceAtChritique:  critiques second) equals: 'dummy2'.
	self assert: (self sourceAtChritique:  critiques third) equals: 'dummy3'.! !

!ReTemporaryNeitherReadNorWrittenRule commentStamp: ''!
There is something wrong in the method as you have variables that are either nor read or not written (or both).!
!ReTemporaryNeitherReadNorWrittenRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReTemporaryNeitherReadNorWrittenRule methodsFor: 'running' stamp: ''!
check: aNode forCritiquesDo: aBlock
	aNode isTempVariable ifFalse: [ ^ self ].
	aNode isDefinition ifFalse: [ ^ self ].
	aNode variable isReferenced ifFalse: [ 
		aBlock cull: (self critiqueFor: aNode) ]! !

!ReTemporaryNeitherReadNorWrittenRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Temporary variables not read or not written'! !

!ReTemporaryVariableCapitalizationRule commentStamp: ''!
Temporary and argument variable names should start with a lowercase letter.!
!ReTemporaryVariableCapitalizationRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	aNode isLocalVariable ifFalse: [ ^false ].
	aNode isDefinition ifFalse: [ ^false ].
	^aNode name first isUppercase! !

!ReTemporaryVariableCapitalizationRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Style'! !

!ReTemporaryVariableCapitalizationRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Temporary variable (or parameter) capitalized'! !

!ReTemporaryVariableCapitalizationRule methodsFor: 'helpers' stamp: ''!
critiqueFor: aNode
	| crit |

	crit := ReRefactoringCritique
		withAnchor: (self anchorFor: aNode)
		by: self.
		
	crit	
		tinyHint: aNode name;
		refactoring: (
			RBRenameArgumentOrTemporaryRefactoring
				renameTemporaryFrom: aNode sourceInterval
				to: aNode name uncapitalized
				in: aNode methodNode methodClass
				selector: aNode methodNode selector).
				
	^ crit! !

!ReTempsReadBeforeWrittenRule commentStamp: ''!
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.

The rule detects, for example, when the assignment is done in a block that might not be executed. 

exampleMethod
	| temp |
	self doSomething: [ temp := 1].
	^temp.

As the rule can not know about the semantics of the method doSomething:, it assumes the block will not
be exected.

NOTE: This rule detects *many* false positives.!
!ReTempsReadBeforeWrittenRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	^ (RBReadBeforeWrittenTester variablesReadBeforeWrittenIn: aMethod ast) isNotEmpty! !

!ReTempsReadBeforeWrittenRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReTempsReadBeforeWrittenRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Temporaries may be read before written'! !

!ReTempsReadBeforeWrittenRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReTempsReadBeforeWrittenRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'TempsReadBeforeWrittenRule'! !

!ReTestCaseShouldNotUseInitializeRule commentStamp: ''!
The testing framework nil out all the instance variables but it does not reinvoke the initialize method. 
It means that you can get a test breaking and when you rerun your test you get the environment of the test broken full of nil while you are thinking that the initialize should have been executed.

Initialize should only use variables defined in #instanceVariablesToKeep.!
!ReTestCaseShouldNotUseInitializeRule methodsFor: 'accessing' stamp: ''!
basicCheck: aClass

	| alteredVariables expectedVariables |
	
	aClass isTestCase 
		ifFalse: [ ^ false ].
		
	(aClass selectors includes: #initialize)
		ifFalse: [ ^ false ].
	
	alteredVariables := (aClass >> #initialize) ast allChildren 
					select: [ :e | e isAssignment and: [ e variable isInstanceVariable ] ]
					thenCollect: [ :e | e variable ].
	
	expectedVariables := aClass new instanceVariablesToKeep.
					
	^ alteredVariables anySatisfy: [ :e | (expectedVariables includes: e name) not ].! !

!ReTestCaseShouldNotUseInitializeRule methodsFor: 'accessing' stamp: ''!
name
	
	^ 'Tests should not use initialize'! !

!ReTestCaseShouldNotUseInitializeRule class methodsFor: 'testing-interest' stamp: ''!
checksClass

	^ true! !

!ReTestCaseShouldNotUseInitializeRuleTest methodsFor: 'running' stamp: ''!
tearDown 

	self class removeSelector: #initialize.
	super tearDown.! !

!ReTestCaseShouldNotUseInitializeRuleTest methodsFor: 'tests' stamp: ''!
testRuleDoesNotAppear
	| critiques |
	self class compile: 'initialize
		super initialize. ' classified: 'test-help'.

	critiques := self myCritiquesOnClass: self class.
	
	self assert: critiques size equals: 0.! !

!ReTestCaseShouldNotUseInitializeRuleTest methodsFor: 'accessing' stamp: ''!
aDummyVar
	"Only necessary that ivar does not appear unused"
	
	^ aDummyVar! !

!ReTestCaseShouldNotUseInitializeRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| critiques |
	self class compile: 'initialize
		super initialize.
		aDummyVar := 2 ' classified: 'test-help'.

	critiques := self myCritiquesOnClass: self class.
	
	self assert: critiques size equals: 1.! !

!ReTestClassNameShouldEndWithTestRule commentStamp: ''!
Check if a subclass of TestCase ends with 'Test' or 'TestCase'.!
!ReTestClassNameShouldEndWithTestRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'A test class (subclass of TestCase) should have it''s name ending with ''Test'' or ''TestCase'''! !

!ReTestClassNameShouldEndWithTestRule methodsFor: 'running' stamp: ''!
basicCheck: aClass
	| suffixes |
	suffixes := #('Test' 'TestCase').
	^ (aClass inheritsFrom: TestCase) and: [ suffixes noneSatisfy: [ :suffix | aClass name asString endsWith: suffix ] ]! !

!ReTestClassNameShouldEndWithTestRule methodsFor: 'running' stamp: ''!
group
	^ 'SUnit'! !

!ReTestClassNameShouldEndWithTestRule methodsFor: 'accessing' stamp: ''!
name
	^ 'A Test class'' name should end with ''Test'' '! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'testing-interest' stamp: ''!
checksClass

	^ true! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ReTestClassNameShouldEndWithTestRule class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ReTestClassNameShouldNotEndWithTests commentStamp: ''!
Check if a test class' name ends with 'Tests' instead of 'Test'!
!ReTestClassNameShouldNotEndWithTests methodsFor: 'accessing' stamp: ''!
rationale
	^ 'A test class (subclass of TestCase) should have it''s name ending with ''Test'' instead of ''Tests'' '! !

!ReTestClassNameShouldNotEndWithTests methodsFor: 'running' stamp: ''!
basicCheck: aClass

	^ (aClass inheritsFrom: TestCase) and: [aClass name asString endsWith: 'Tests'].! !

!ReTestClassNameShouldNotEndWithTests methodsFor: 'running' stamp: ''!
group
	^ 'SUnit'! !

!ReTestClassNameShouldNotEndWithTests methodsFor: 'accessing' stamp: ''!
name
	^ 'A Test class'' name should not end with ''Tests'' '! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'testing-interest' stamp: ''!
checksClass

	^ true! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ReTestClassNameShouldNotEndWithTests class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ReTestClassNotInPackageWithTestEndingNameRule commentStamp: ''!
A subclass of TestCase should be in package which name is ending with '-Tests'!
!ReTestClassNotInPackageWithTestEndingNameRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'A test class (subclass of TestCase) should be placed in a package with a ''-Tests'' suffix'! !

!ReTestClassNotInPackageWithTestEndingNameRule methodsFor: 'running' stamp: ''!
basicCheck: aClass

	^ (aClass inheritsFrom: TestCase) and: [(aClass package name asString endsWith: '-Tests') not].! !

!ReTestClassNotInPackageWithTestEndingNameRule methodsFor: 'running' stamp: ''!
group
	^ 'SUnit'! !

!ReTestClassNotInPackageWithTestEndingNameRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Test class not in a package with name ending with ''-Tests'' '! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'testing - interest' stamp: ''!
checksClass

	^ true! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ReTestClassNotInPackageWithTestEndingNameRule class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!ReThemeAPIUpdateRule commentStamp: ''!
Do not explicitly refer to UITheme current but use Smalltalk ui theme. Similarly do not directly refer to ThemeIcons current but use Smalltalk ui icons.
!
!ReThemeAPIUpdateRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		replace: 'UITheme current'
			with: 'Smalltalk ui theme';
		replace: 'ThemeIcons current'
			with: 'Smalltalk ui icons'! !

!ReThemeAPIUpdateRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReThemeAPIUpdateRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Use "Smalltalk ui theme" and "Smalltalk ui icons"'! !

!ReThemeAPIUpdateRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ThemeAPIUpdateRule'! !

!ReThemeAccessRule commentStamp: ''!
Morph and Model subclasses methods should access GUI theme via 'self theme' instead of 'Smalltalk ui theme'.!
!ReThemeAccessRule methodsFor: 'running' stamp: ''!
group
	^ 'API Hints'! !

!ReThemeAccessRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock 
	| problemThemes |
	((aMethod methodClass inheritsFrom: Morph) 
		or: [aMethod methodClass inheritsFrom: Model]) ifFalse: [ ^ self ].
		
	problemThemes := 
		(aMethod sendNodes select: [ :msgSend | msgSend selector = #theme 
				and: [msgSend receiver sourceCode withSeparatorsCompacted = 'Smalltalk ui'] ]).
	
	problemThemes do: [ :msgSend |
			aCriticBlock cull: (self 
				createTrivialCritiqueOn: aMethod 
				intervalOf: msgSend 
				hint: msgSend selector asString) ]! !

!ReThemeAccessRule methodsFor: 'running' stamp: ''!
name
	^ 'Access to UI theme.'! !

!ReThemeAccessRule class methodsFor: 'class initialization' stamp: ''!
initialize
   " ReRuleManager cleanUp "! !

!ReThemeAccessRule class methodsFor: 'testing-interest' stamp: ''!
checksMethod
	^ true! !

!ReThreeElementPointRule commentStamp: ''!
Checks arithmetic statements for possible three element points (i.e., a point that has another point in its x or y part).!
!ReThreeElementPointRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReThreeElementPointRule methodsFor: 'running' stamp: ''!
check: aNode forCritiquesDo: aCriticBlock
	| parentPoint |
	
	aNode isMessage ifFalse: [ ^ self ].
	aNode selector = #@ ifFalse: [ ^ self ].
	
	parentPoint := self
		findSuspiciousParentFor: aNode
		ifNone: [ ^self ].

	aCriticBlock cull: (
		self critiqueFor: parentPoint)! !

!ReThreeElementPointRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Possible three element point (e.g., x @ y + q @ r)'! !

!ReThreeElementPointRule methodsFor: 'running' stamp: ''!
findSuspiciousParentFor: aNode ifNone: alternativeBlock
	| tentativeNode |

	tentativeNode := aNode parent.
	tentativeNode ifNil: [ ^ alternativeBlock value ].
	tentativeNode isMessage ifFalse: [
		^ self
			findSuspiciousParentFor: tentativeNode
			ifNone: alternativeBlock ].
	tentativeNode isBinary ifFalse: [ ^ alternativeBlock value ].
	tentativeNode selector = #@ ifTrue: [ ^ tentativeNode ].
	
	^ self
		findSuspiciousParentFor: tentativeNode
		ifNone: alternativeBlock! !

!ReThreeElementPointRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ThreeElementPointRule'! !

!ReToDoCollectRule commentStamp: ''!
Checks for users of to:do: when the shorter collect: would work.!
!ReToDoCollectRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'| `@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' )! !

!ReToDoCollectRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReToDoCollectRule methodsFor: 'accessing' stamp: ''!
name
	^ 'to:do: used instead of collect:'! !

!ReToDoCollectRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ToDoCollectRule'! !

!ReToDoRule commentStamp: ''!
Checks for use of to:do: when a do:, with:do: or timesRepeat: when should be used.!
!ReToDoRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matches: '1 to: ``@object size do: [:`each | | `@temps | `@.Statements]'! !

!ReToDoRule methodsFor: 'accessing' stamp: ''!
group

	^ 'Coding Idiom Violation'! !

!ReToDoRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses to:do: instead of do:, with:do: or timesRepeat:'! !

!ReToDoRule methodsFor: 'hooks' stamp: ''!
sendsAtWith: aVariableNode inAnyOf: aStatementCollection

	aStatementCollection do: [ :statement |
		statement nodesDo: [ :node |
			(node isMessage and: [ 
			node selector = #at: and: [ 
			node arguments first = aVariableNode ] ])
				ifTrue: [ ^ true ] ] ].
		
	^ false! !

!ReToDoRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	^ self
		sendsAtWith: (mappingDict at: '`each')
		inAnyOf: (mappingDict at: '`@.Statements')! !

!ReToDoRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ToDoRule'! !

!ReToDoWithIncrementRule commentStamp: ''!
Checks for users of to:do: that also increment or decrement a counter.
In Pharo you do not increment or decrement counter but should use the message to:do:by:.

1 to: 100 by: 3 do: [ :each | ... ]!
!ReToDoWithIncrementRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'`@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]')! !

!ReToDoWithIncrementRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Checks for users of to:do: that also increment or decrement a counter.'! !

!ReToDoWithIncrementRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReToDoWithIncrementRule methodsFor: 'accessing' stamp: ''!
name
	^ 'to:do: loop also increments a counter'! !

!ReToDoWithIncrementRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ToDoWithIncrementRule'! !

!ReTransformationCritique commentStamp: ''!
A critique which contains the AST that should replace the existing one of the criticized entity!
!ReTransformationCritique methodsFor: 'testing' stamp: ''!
providesChange
	
	^ true! !

!ReTransformationCritique methodsFor: 'accessing' stamp: ''!
change
	"re-add the method compiled from the new AST"
	
	^ (RBRefactoryChangeFactory instance) 
		addMethodSource: newTree newSource 
		in: self entity methodClass! !

!ReTransformationCritique methodsFor: 'initialization' stamp: ''!
initializeRule: aRule target: anEntity tree: newAST

	self initializeRule: aRule target: anEntity.
	newTree := newAST ! !

!ReTransformationCritique class methodsFor: 'instance creation' stamp: ''!
for: anEntity by: aRule tree: newAST

	^ self basicNew
		initializeRule: aRule
		target: anEntity
		tree: newAST;
		yourself! !

!ReTrivialCritique commentStamp: ''!
I am a trivial tritic that does not provide any more information other than my target and rule!
!ReTrivialCritique methodsFor: 'testing' stamp: ''!
providesChange
	
	^ false! !

!ReTrivialCritique methodsFor: 'accessing' stamp: ''!
change
	^ self shouldNotImplement ! !

!ReTrueFalseDuplicationRule commentStamp: ''!
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 ]!
!ReTrueFalseDuplicationRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		"true/false last common"
		replace: '
		`.@PreStatements.
		`@boolExp 
			ifTrue: [ | `@trueTemps | `@.TrueStatements. `.LastStatement ] 
			ifFalse: [ | `@falseTemps | `@.FalseStatements. `.LastStatement ].
		`.@PostStatements.'
		with: '
		`.@PreStatements.
		`@boolExp 
			ifTrue: [ | `@trueTemps | `@.TrueStatements. ] 
			ifFalse: [ | `@falseTemps | `@.FalseStatements. ].
		`.LastStatement.
		`.@PostStatements.';
		
		"false/true last common"
		replace: '
		`.@PreStatements.
		`@boolExp 
			ifFalse: [ | `@falseTemps | `@.FalseStatements. `.LastStatement ] 
			ifTrue: [ | `@trueTemps | `@.TrueStatements. `.LastStatement ].
		`.@PostStatements.'
		with: '
		`.@PreStatements.
		`@boolExp 
			ifFalse: [ | `@falseTemps | `@.FalseStatements. ] 
			ifTrue: [ | `@trueTemps | `@.TrueStatements. ].
		`.LastStatement.
		`.@PostStatements.';
		
		"true/false first common"
		replace: '
		`.@PreStatements.
		`@boolExp 
			ifTrue: [ | `@trueTemps | `.FirstStatement. `@.TrueStatements. ] 
			ifFalse: [ | `@falseTemps | `.FirstStatement. `@.FalseStatements. ].
		`.@PostStatements.'
		with: '
		`.@PreStatements.
		`.FirstStatement.
		`@boolExp 
			ifTrue: [ | `@trueTemps | `@.TrueStatements. ] 
			ifFalse: [ | `@falseTemps | `@.FalseStatements. ].
		`.@PostStatements.';
		
		"false/true first common"
		replace: '
		`.@PreStatements.
		`@boolExp 
			ifFalse: [ | `@falseTemps | `.FirstStatement. `@.FalseStatements. ]
			ifTrue: [ | `@trueTemps | `.FirstStatement. `@.TrueStatements. ].
		`.@PostStatements.'
		with: '
		`.@PreStatements.
		`.FirstStatement.
		`@boolExp 
			ifFalse: [ | `@falseTemps | `@.FalseStatements. ]
			ifTrue: [ | `@trueTemps | `@.TrueStatements. ].
		`.@PostStatements.'! !

!ReTrueFalseDuplicationRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Checks for ifTrue:ifFalse: blocks that have the same code at the beginning or end.'! !

!ReTrueFalseDuplicationRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReTrueFalseDuplicationRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReTrueFalseDuplicationRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Check for same statements at end of ifTrue:ifFalse: blocks'! !

!ReTrueFalseDuplicationRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	
	mappingDict
		at: '`.LastStatement'
		ifPresent: [ :statement |
			^ statement isVariable not ].
	
	"the first statement is duplicated"
	^ true! !

!ReTrueFalseDuplicationRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'EndTrueFalseRule'! !

!ReUnaryAccessingMethodWithoutReturnRule commentStamp: ''!
Checks for any unary "accessing" methods without explicit return statements.!
!ReUnaryAccessingMethodWithoutReturnRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod

	(aMethod numArgs > 0 or: [ aMethod isAbstract ]) ifTrue: [ ^ false ].
	(aMethod category beginsWith: 'accessing') ifFalse: [ ^ false ].
	^ aMethod ast allChildren noneSatisfy: [ :each | each isReturn ]! !

!ReUnaryAccessingMethodWithoutReturnRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReUnaryAccessingMethodWithoutReturnRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Unary "accessing" method without explicit return'! !

!ReUnaryAccessingMethodWithoutReturnRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReUnaryAccessingMethodWithoutReturnRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName

	^ 'UnaryAccessingMethodWithoutReturnRule'! !

!ReUnclassifiedMethodsRule commentStamp: ''!
All methods should be put into a protocol (method category) for better readability.!
!ReUnclassifiedMethodsRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	^ aMethod protocol = Protocol unclassified! !

!ReUnclassifiedMethodsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Style'! !

!ReUnclassifiedMethodsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Unclassified methods'! !

!ReUnclassifiedMethodsRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReUnclassifiedMethodsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UnclassifiedMethodsRule'! !

!ReUncommonMessageSendRule commentStamp: ''!
Sending messages with a common literal (e.g. "Object self") or an uppercase selector name are usually bugs, introduced through missing statement separators.

Notice, problems of this kind will most likely also cause RBSentNotImplementedRule to be invoked, because one should not use such method names in the first place.!
!ReUncommonMessageSendRule methodsFor: 'accessing' stamp: ''!
commonLiterals

	^ #(#self #super #thisContext #true #false #nil)! !

!ReUncommonMessageSendRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReUncommonMessageSendRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	| problemSelectors |
	problemSelectors := 
		aMethod sendNodes select: [ :msgSend | 
			msgSend selector first isUppercase | (self commonLiterals includes: msgSend selector) ].
	
	problemSelectors do: [ :msgSend |
			aCriticBlock cull: (self createTrivialCritiqueOn: aMethod intervalOf: msgSend hint: msgSend selector asString) ]! !

!ReUncommonMessageSendRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uncommon message send'! !

!ReUncommonMessageSendRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReUncommonMessageSendRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UncommonMessageSendRule'! !

!ReUncommonMessageSendRuleTest commentStamp: ''!
A RBUncommonMessageSendRuleTest is a test class for testing the behavior of RBUncommonMessageSendRule!
!ReUncommonMessageSendRuleTest methodsFor: 'sample' stamp: ''!
sampleMethod
	"I check that no uncommon method sends occour. For instance using self or true as method names, or method names with capital - like '7 BadSelector'"
	99 self.
	3 factorial.
	7 BadSelector.! !

!ReUncommonMessageSendRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| critiques |
	critiques := self myCritiques.
	
	self assert: critiques size equals: 2.
	self assert: (self sourceAtChritique:  critiques second) equals: '7 BadSelector'.! !

!ReUnconditionalRecursionRule commentStamp: ''!
Checks for unconditional recursion that might cause the image to hang when executed.!
!ReUnconditionalRecursionRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self addMatchingMethod:
		'`@message: `@args
			| `@temps |
			`@.before.
			self `@message: `@args.
			`@.after'! !

!ReUnconditionalRecursionRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReUnconditionalRecursionRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReUnconditionalRecursionRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Unconditional recursion'! !

!ReUnconditionalRecursionRule methodsFor: 'hooks' stamp: ''!
afterCheck: aNode mappings: mappingDict
	^ (mappingDict at: '`@.before') noneSatisfy: #containsReturn! !

!ReUnconditionalRecursionRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UnconditionalRecursionRule'! !

!ReUndeclaredVariableRule commentStamp: ''!
You are referencing a variable that is not declared anywhere. There is no temp, instance var, class var, or a global variable that can be bound to by this reference. Most likely you got into this state by writing an entirely correct code, but then the variable was removed.!
!ReUndeclaredVariableRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReUndeclaredVariableRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	^ aNode isVariable and: [ aNode isUndeclaredVariable ]! !

!ReUndeclaredVariableRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReUndeclaredVariableRule methodsFor: 'accessing' stamp: ''!
name
	^ 'References an undeclared variable'! !

!ReUndeclaredVariableRule methodsFor: 'helpers' stamp: ''!
critiqueFor: aNode
	^ (super critiqueFor: aNode)
		tinyHint: aNode name;
		yourself! !

!ReUnnecessaryAssignmentRule commentStamp: ''!
Checks for assignements to temporaries that are not used afterwards.!
!ReUnnecessaryAssignmentRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReUnnecessaryAssignmentRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	aNode isReturn ifFalse: [ ^ false ].
	aNode isAssignment ifFalse: [ ^ false ].
	^ (aNode whoDefines: aNode variable name) isNotNil! !

!ReUnnecessaryAssignmentRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReUnnecessaryAssignmentRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Unnecessary assignment to a temporary variable'! !

!ReUnnecessaryAssignmentRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UnnecessaryAssignmentRule'! !

!ReUnoptimizedAndOrRule commentStamp: ''!
Checks for inefficient nesting of logical conditions.!
!ReUnoptimizedAndOrRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'(`@a and: `@b) and: `@c'
			'(`@a or: `@b) or: `@c' )! !

!ReUnoptimizedAndOrRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReUnoptimizedAndOrRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses "(a and: [b]) and: [c]" instead of "a and: [b and: [c]]"'! !

!ReUnoptimizedAndOrRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UnoptimizedAndOrRule'! !

!ReUnoptimizedToDoRule commentStamp: ''!
Checks for inefficient uses of to:do: that create an unnecessary Interval instance.

( 1 to: 10 ) do: aBlock

can be more efficiently expressed as 

1 to: 10 do: aBlock!
!ReUnoptimizedToDoRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matches: '(`@a to: `@b) do: `@c'! !

!ReUnoptimizedToDoRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReUnoptimizedToDoRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses (to:)do: instead of to:do:'! !

!ReUnoptimizedToDoRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UnoptimizedToDoRule'! !

!ReUnpackagedCodeRule commentStamp: ''!
Code that is not contained in a Monticello package is not versioned and cannot be brought into a different image.!
!ReUnpackagedCodeRule methodsFor: 'running' stamp: ''!
basicCheck: anEntity
	^ anEntity package isNotNil and: [ anEntity package isDefault ]! !

!ReUnpackagedCodeRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReUnpackagedCodeRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Unpackaged code'! !

!ReUnpackagedCodeRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReUnpackagedCodeRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReUnpackagedCodeRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UnpackagedCodeRule'! !

!ReUnwindBlocksRule commentStamp: ''!
Move assignment out of unwind blocks.

For example

[[[
[ statements. 
var := object ] ifCurtailed: block
]]]


[[[ 
var := [ statements. 
	    object] ifCurtailed: block
]]]!
!ReUnwindBlocksRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		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'! !

!ReUnwindBlocksRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReUnwindBlocksRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Move assignment out of unwind blocks'! !

!ReUnwindBlocksRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UnwindBlocksRule'! !

!ReUseIsEmptyNotSizeRule commentStamp: ''!
Checks for code 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.!
!ReUseIsEmptyNotSizeRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self  matchesAny: #(
		'`@object size == 0'
		'`@object size = 0'
		'`@object size > 0'
		'`@object size >= 1')! !

!ReUseIsEmptyNotSizeRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReUseIsEmptyNotSizeRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Checks for empty collection using #size instead of #isEmpty" or #isNotEmpty'! !

!ReUseIsEmptyNotSizeRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'ConsistencyCheckRule'! !

!ReUsesAddRule commentStamp: ''!
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.!
!ReUsesAddRule methodsFor: 'running' stamp: ''!
basicCheck: node
	^ node isMessage and: [ (#(#add: #addAll:) includes: node selector) and: [ node isDirectlyUsed ] ]! !

!ReUsesAddRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Potential Bugs'! !

!ReUsesAddRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses the result of an add: message'! !

!ReUsesAddRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UsesAddRule'! !

!ReUsesTrueRule commentStamp: ''!
Checks for uses of the classes True and False instead of the objects true and false.

true is the object true, while True is the class whose true is the sole instance.!
!ReUsesTrueRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!ReUsesTrueRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReUsesTrueRule methodsFor: 'running' stamp: ''!
check: aMethod forCritiquesDo: aCriticBlock
	| problemUsages |
	problemUsages := aMethod ast variableNodes select: [ :aNode | 
			                 aNode isGlobalVariable and: [ #( True False ) includes: aNode name ] ].
	problemUsages do: [ :ref | 
		aCriticBlock cull: (self createTrivialCritiqueOn: aMethod intervalOf: ref hint: ref name asString)]! !

!ReUsesTrueRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses True/False instead of true/false'! !

!ReUsesTrueRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReUsesTrueRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UsesTrueRule'! !

!ReUsesTrueRuleTest commentStamp: ''!
A RBUsesTrueRuleTest is a test class for testing the behavior of RBUsesTrueRule!
!ReUsesTrueRuleTest methodsFor: 'sample' stamp: ''!
sampleMethod
	"You should not use True or False, but true and false. Unless it is the classes you refer to"
	| foo balse|
	foo := True.
	balse := False | foo! !

!ReUsesTrueRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| critiques|
 	critiques := self myCritiques .

 	self assert: critiques size equals: 2.
 	self assert: (self sourceAtChritique:  critiques second) equals: 'False'.! !

!ReUsesWorldGlobalRule commentStamp: ''!
The direct use of the global variables World and ActiveWorld is incorrect. 
Use "self currentWorld" instead.!
!ReUsesWorldGlobalRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	^ aNode isGlobalVariable and: [ #(#World #ActiveWorld) includes: aNode name ]! !

!ReUsesWorldGlobalRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Bugs'! !

!ReUsesWorldGlobalRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses World or ActiveWorld directly'! !

!ReUsesWorldGlobalRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UsesWorldGlobalRule'! !

!ReUtilityMethodsRule commentStamp: ''!
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.!
!ReUtilityMethodsRule methodsFor: 'running' stamp: ''!
basicCheck: aMethod
	aMethod methodClass isMeta ifTrue: [ ^false ].
	aMethod selector isUnary ifTrue: [ ^false ].
	(self utilityProtocols includes: aMethod protocol) ifTrue: [ ^false ].
	aMethod isOverridden ifTrue: [ ^ false ].
   aMethod sendsToSuper ifTrue: [ ^ false ].
	aMethod selfMessages isEmpty ifFalse: [ ^ false ].
	^aMethod methodClass definedVariables noneSatisfy: [ :variable | variable isAccessedIn: aMethod ]! !

!ReUtilityMethodsRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReUtilityMethodsRule methodsFor: 'private' stamp: ''!
utilityProtocols
	"If a method is defined in one of these protocols, then don't check if its a utility method."
	^ #('utility' 'visiting' 'visitor')! !

!ReUtilityMethodsRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Utility methods'! !

!ReUtilityMethodsRule class methodsFor: 'testing' stamp: ''!
checksMethod
	^ true! !

!ReUtilityMethodsRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'UtilityMethodsRule'! !

!ReUtilityMethodsRuleTest methodsFor: 'sample' stamp: ''!
sampleMethod: arg
	^arg! !

!ReUtilityMethodsRuleTest methodsFor: 'accessing' stamp: ''!
myCritiques
	| critiques |
	critiques := OrderedCollection new.
	self subjectUnderTest  new 
		check: (self class >> #sampleMethod: ) forCritiquesDo:[:critique | critiques add: critique].
	^critiques! !

!ReUtilityMethodsRuleTest methodsFor: 'tests' stamp: ''!
testRule
	| critiques|
 	critiques := self myCritiques.

 	self assert: critiques size equals: 1.
 	self assert: critiques first rule class equals: ReUtilityMethodsRule! !

!ReVarSearchSourceAnchor commentStamp: ''!
Same as search string source anchor but uses specific heuristics for finding a better string based on the fact that we are looking in a class definition!
!ReVarSearchSourceAnchor methodsFor: 'accessing' stamp: ''!
interval
	^ super interval allButLast ! !

!ReVarSearchSourceAnchor methodsFor: 'private' stamp: ''!
modify: aString for: aStringCollection

	aStringCollection size = 1 ifTrue: [ 
		^ aString surroundedBySingleQuotes ].
	aStringCollection first = aString ifTrue: [ 
		^ '''', aString, String space ].
	aStringCollection last = aString ifTrue: [ 
		^ String space, aString, '''' ].
	^ aString surroundedBy: String space.! !

!ReVarSearchSourceAnchor methodsFor: 'accessing' stamp: ''!
searchString
	| origString |
	
	origString := super searchString.
	(sourceEntity instVarNames includes: origString) ifTrue: [ 
		^ self modify: origString for: sourceEntity instVarNames ].
	(sourceEntity classVarNames includes: origString) ifTrue: [ 
		^ self modify: origString for: sourceEntity classVarNames ].

	^ origString! !

!ReVarSearchSourceAnchorTest methodsFor: 'tests' stamp: ''!
testSearchString

	| anchor |
	
	anchor := ReVarSearchSourceAnchor
		entity: Object newAnonymousSubclass
		string: 'var'.
		
	self
		assert: anchor searchString
		equals: 'var'! !

!ReVarSearchSourceAnchorTest methodsFor: 'tests' stamp: ''!
testModifyFor
	| anchor |
	anchor := ReVarSearchSourceAnchor new.
	
	self
		assert: (anchor modify: 'one' for: #(one))
		equals: '''one'''.
	
	self
		assert: (anchor modify: 'one' for: #(one two))
		equals: '''one '.
	
	self
		assert: (anchor modify: 'two' for: #(one two))
		equals: ' two'''.
	
	self
		assert: (anchor modify: 'two' for: #(one two three))
		equals: ' two '! !

!ReVarSearchSourceAnchorTest methodsFor: 'tests' stamp: ''!
testSearchString2

	| anchor |
	
	anchor := ReVarSearchSourceAnchor
		entity: (
			Object newAnonymousSubclass
				addClassVarNamed: 'Var';
				yourself)
		string: 'Var'.
		
	self
		assert: anchor searchString
		equals: '''Var'''! !

!ReVariableAssignedLiteralRule commentStamp: ''!
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.!
!ReVariableAssignedLiteralRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReVariableAssignedLiteralRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock

	aClass definedVariables do: [ :variable | 
		| assignmentNodes |
		"Pools are often used to define constants and can read without an accessor"
		variable isPoolVariable ifTrue: [ ^ self ].
		assignmentNodes := variable assignmentNodes.
		assignmentNodes size = 1 ifFalse: [ ^ self ].
		assignmentNodes first value isLiteralNode ifTrue: [ 
			aCriticBlock cull: (self critiqueFor: aClass about: variable name) ] ]! !

!ReVariableAssignedLiteralRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Variable is only assigned a single literal value'! !

!ReVariableAssignedLiteralRule class methodsFor: 'testing-interest' stamp: ''!
checksClass

	^ true! !

!ReVariableReferencedOnceRule commentStamp: ''!
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).!
!ReVariableReferencedOnceRule methodsFor: 'accessing' stamp: ''!
severity
	^ #information! !

!ReVariableReferencedOnceRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!ReVariableReferencedOnceRule methodsFor: 'running' stamp: ''!
check: aClass forCritiquesDo: aCriticBlock
		aClass slots do: [ :slot | 
		  | usingMethods |
		  usingMethods := slot usingMethods.
		  usingMethods size = 1 ifFalse:  [ ^ self ].
		  (RBReadBeforeWrittenTester
				  isVariable: slot name
				  writtenBeforeReadIn: usingMethods first ast) ifTrue: [aCriticBlock cull: (self critiqueFor: aClass about: slot  name)   ]]! !

!ReVariableReferencedOnceRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Variable referenced in only one method and always assigned first'! !

!ReVariableReferencedOnceRule class methodsFor: 'testing' stamp: ''!
checksClass
	^ true! !

!ReVariableReferencedOnceRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'VariableReferencedOnceRule'! !

!ReWhileTrueRule commentStamp: ''!
Checks for users of whileTrue: when the shorter to:do: would work.

For example
 
statements1. 
[index <= stop] 
	whileTrue: 
	[ 
	blockStmts1. 
	index := index + 1].
statements2!
!ReWhileTrueRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self matchesAny: #(
			'| `@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' )! !

!ReWhileTrueRule methodsFor: 'accessing' stamp: ''!
rationale
	^ 'Checks for users of whileTrue: when the shorter to:do: would work.'! !

!ReWhileTrueRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Coding Idiom Violation'! !

!ReWhileTrueRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Uses whileTrue: instead of to:do:'! !

!ReWhileTrueRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'WhileTrueRule'! !

!ReYourselfNotUsedRule commentStamp: ''!
Check for methods sending the yourself message when it is not necessary.!
!ReYourselfNotUsedRule methodsFor: 'enumerating' stamp: ''!
basicCheck: aNode
	aNode isMessage ifFalse: [ ^ false ].
	aNode selector = #yourself ifFalse: [ ^ false ].
	^ aNode isUsed not! !

!ReYourselfNotUsedRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Optimization'! !

!ReYourselfNotUsedRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Doesn''t use the result of a yourself message'! !

!ReYourselfNotUsedRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^ 'YourselfNotUsedRule'! !

!ReadOnlyFileException commentStamp: ''!
I am raised on an attempt to write to a read-only file store.!
!ReadOnlyFileHandle commentStamp: ''!
I am a file handle on a read-only store.!
!ReadOnlyFileHandle methodsFor: 'testing' stamp: ''!
truncateTo: anInteger

	ReadOnlyFileException signal: 'Attempt to truncate file ', reference pathString, ' on a read-only file system'.

	^ self! !

!ReadOnlyFileHandle methodsFor: 'testing' stamp: ''!
setReference: aReference writable: aBoolean

	reference := aReference resolve.

	aBoolean ifTrue: [ 
		ReadOnlyFileException signal: 'Attempt to open file ', reference pathString, ' as writable on a read-only file system' ].

	writable := aBoolean! !

!ReadOnlyFileHandle methodsFor: 'testing' stamp: ''!
isWritable
	^ false! !

!ReadOnlyMacStore commentStamp: ''!
I'm a specific store for macOS file systems that allows only read-only access. All read-only DiskStore subclasses share the same behavior. Usage of traits would be appropriate here, but it is not used because the kernel should not contain traits.!
!ReadOnlyMacStore methodsFor: 'public' stamp: ''!
file: path symlinkUid: uidInteger gid: gidInteger

	ReadOnlyFileException signal: 'Attempt to modify file ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyMacStore methodsFor: 'public' stamp: ''!
file: path posixPermissions: anInteger

	ReadOnlyFileException signal: 'Attempt to modify file ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyMacStore methodsFor: 'public' stamp: ''!
basicOpen: aPath writable: aBoolean

	aBoolean ifTrue: [ 
		ReadOnlyFileException signal: 'Attempt to open file ', aPath pathString, ' as writable on a read-only file system'.
		^ self ].
		
	^ super basicOpen: aPath writable: aBoolean.! !

!ReadOnlyMacStore methodsFor: 'public' stamp: ''!
file: path uid: uidInteger gid: gidInteger

	ReadOnlyFileException signal: 'Attempt to modify file ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyMacStore methodsFor: 'public' stamp: ''!
createDirectory: path

	ReadOnlyFileException signal: 'Attempt crate directory ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyMacStore methodsFor: 'public' stamp: ''!
rename: sourcePath to: destinationPath

	ReadOnlyFileException signal: 'Attempt to rename file ', sourcePath pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyMacStore methodsFor: 'public' stamp: ''!
delete: path

	ReadOnlyFileException signal: 'Attempt delete ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyMacStore methodsFor: 'public' stamp: ''!
isWritable

	^ false! !

!ReadOnlyMacStore methodsFor: 'public' stamp: ''!
handleClass
	^ ReadOnlyFileHandle! !

!ReadOnlyMacStore methodsFor: 'public' stamp: ''!
isWritable: aPath

	^ false! !

!ReadOnlyMacStore class methodsFor: 'public' stamp: ''!
writableVariant

	^ MacStore! !

!ReadOnlyMacStore class methodsFor: 'public' stamp: ''!
isActiveClass

	^ false! !

!ReadOnlyUnixStore commentStamp: ''!
I'm a specific store for Unix file systems that allows only read-only access. All read-only DiskStore subclasses share the same behavior. Usage of traits would be appropriate here, but it is not used because the kernel should not contain traits.!
!ReadOnlyUnixStore methodsFor: 'public' stamp: ''!
file: path symlinkUid: uidInteger gid: gidInteger

	ReadOnlyFileException signal: 'Attempt to modify file ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyUnixStore methodsFor: 'public' stamp: ''!
file: path posixPermissions: anInteger

	ReadOnlyFileException signal: 'Attempt to modify file ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyUnixStore methodsFor: 'public' stamp: ''!
basicOpen: aPath writable: aBoolean

	aBoolean ifTrue: [ 
		ReadOnlyFileException signal: 'Attempt to open file ', aPath pathString, ' as writable on a read-only file system'.
		^ self ].
		
	^ super basicOpen: aPath writable: aBoolean.! !

!ReadOnlyUnixStore methodsFor: 'public' stamp: ''!
file: path uid: uidInteger gid: gidInteger

	ReadOnlyFileException signal: 'Attempt to modify file ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyUnixStore methodsFor: 'public' stamp: ''!
createDirectory: path

	ReadOnlyFileException signal: 'Attempt crate directory ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyUnixStore methodsFor: 'public' stamp: ''!
rename: sourcePath to: destinationPath

	ReadOnlyFileException signal: 'Attempt to rename file ' , sourcePath pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyUnixStore methodsFor: 'public' stamp: ''!
delete: path

	ReadOnlyFileException signal: 'Attempt delete ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyUnixStore methodsFor: 'public' stamp: ''!
isWritable

	^ false! !

!ReadOnlyUnixStore methodsFor: 'public' stamp: ''!
handleClass
	^ ReadOnlyFileHandle! !

!ReadOnlyUnixStore methodsFor: 'public' stamp: ''!
isWritable: aPath

	^ false! !

!ReadOnlyUnixStore class methodsFor: 'public' stamp: ''!
writableVariant

	^ UnixStore! !

!ReadOnlyUnixStore class methodsFor: 'public' stamp: ''!
isActiveClass

	^ false! !

!ReadOnlyWindowsStore commentStamp: ''!
I'm a specific store for Windows file systems that allows only read-only access. All read-only DiskStore subclasses share the same behavior. Usage of traits would be appropriate here, but it is not used because the kernel should not contain traits.!
!ReadOnlyWindowsStore methodsFor: 'public' stamp: ''!
file: path symlinkUid: uidInteger gid: gidInteger

	ReadOnlyFileException signal: 'Attempt to modify file ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyWindowsStore methodsFor: 'public' stamp: ''!
file: path posixPermissions: anInteger

	ReadOnlyFileException signal: 'Attempt to modify file ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyWindowsStore methodsFor: 'public' stamp: ''!
basicOpen: aPath writable: aBoolean

	aBoolean ifTrue: [ 
		ReadOnlyFileException signal: 'Attempt to open file ' , aPath pathString, ' as writable on a read-only file system'.
		^ self ].
		
	^ super basicOpen: aPath writable: aBoolean.! !

!ReadOnlyWindowsStore methodsFor: 'public' stamp: ''!
file: path uid: uidInteger gid: gidInteger

	ReadOnlyFileException signal: 'Attempt to modify file ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyWindowsStore methodsFor: 'public' stamp: ''!
createDirectory: path

	ReadOnlyFileException signal: 'Attempt crate directory ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyWindowsStore methodsFor: 'public' stamp: ''!
rename: sourcePath to: destinationPath

	ReadOnlyFileException signal: 'Attempt to rename file ', sourcePath pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyWindowsStore methodsFor: 'public' stamp: ''!
delete: path

	ReadOnlyFileException signal: 'Attempt delete ', path pathString, ' on a read-only file system'.
	
	^ self! !

!ReadOnlyWindowsStore methodsFor: 'public' stamp: ''!
isWritable

	^ false! !

!ReadOnlyWindowsStore methodsFor: 'public' stamp: ''!
handleClass
	^ ReadOnlyFileHandle! !

!ReadOnlyWindowsStore methodsFor: 'public' stamp: ''!
isWritable: aPath

	^ false! !

!ReadOnlyWindowsStore class methodsFor: 'public' stamp: ''!
writableVariant

	^ WindowsStore! !

!ReadOnlyWindowsStore class methodsFor: 'public' stamp: ''!
isActiveClass

	^ false! !

!ReadStream commentStamp: ''!
I represent an accessor for a sequence of objects that can only read objects from the sequence.!
!ReadStream methodsFor: 'accessing' stamp: ''!
next
	"Primitive. Answer the next object in the Stream represented by the
	receiver. Fail if the collection of this stream is not an Array or a String.
	Fail if the stream is positioned at its end, or if the position is out of
	bounds in the collection. Optional. See Object documentation
	whatIsAPrimitive."

	^ position >= readLimit
		ifTrue: [ nil ]
		ifFalse: [ collection at: (position := position + 1) ]! !

!ReadStream methodsFor: 'accessing' stamp: ''!
next: anInteger 
	"Answer the next anInteger elements of my collection.  overriden for efficiency"

	| ans endPosition |

	endPosition := position + anInteger  min:  readLimit.
	ans := collection copyFrom: position+1 to: endPosition.
	position := endPosition.
	^ans! !

!ReadStream methodsFor: 'accessing' stamp: ''!
upToAnyOf: aCollection do: aBlock
	"Overriden for speed"
	| end result |
	end := collection indexOfAnyOf: aCollection startingAt: 1 + position ifAbsent: [0].
	(end = 0 or: [end > readLimit]) ifTrue: [^self upToEnd].
	result := collection copyFrom: 1 + position to: -1 + end.
	position := end.
	aBlock value: (collection at: end).
	^result! !

!ReadStream methodsFor: 'accessing' stamp: ''!
upToEnd
	| start |
	start := 1 + position.
	position := readLimit.
	^collection copyFrom: start to: position! !

!ReadStream methodsFor: 'accessing' stamp: ''!
size
	"Compatibility with other streams (e.g., FileStream)"
	^readLimit! !

!ReadStream methodsFor: 'accessing' stamp: ''!
nextPut: anObject
	self shouldNotImplement! !

!ReadStream methodsFor: 'accessing' stamp: ''!
upTo: anObject
	"fast version using indexOf:"
	| start end |

	start := position+1.
	end := collection indexOf: anObject startingAt: start ifAbsent: [ 0 ].

	"not present--return rest of the collection"	
	(end = 0 or: [end > readLimit]) ifTrue: [ ^self upToEnd ].

	"skip to the end and return the data passed over"
	position := end.
	^collection copyFrom: start to: (end-1)! !

!ReadStream methodsFor: 'accessing' stamp: ''!
readInto: aCollection startingAt: startIndex count: n
	"Read n objects into the given collection. 
	Return number of elements that have been read."
	
	| max |
	max := (readLimit - position) min: n.
	aCollection 
		replaceFrom: startIndex 
		to: startIndex + max - 1
		with: collection
		startingAt: position + 1.
	position := position + max.
	^ max! !

!ReadStream methodsFor: 'accessing' stamp: ''!
localName
	^'ReadStream'! !

!ReadStream methodsFor: 'modes' stamp: ''!
ascii! !

!ReadStream methodsFor: 'initialization' stamp: ''!
on: aCollection from: firstIndex to: lastIndex

	| len |
	collection := aCollection.
	readLimit :=  lastIndex > (len := collection size)
						ifTrue: [len]
						ifFalse: [lastIndex].
	position := firstIndex <= 1
				ifTrue: [0]
				ifFalse: [firstIndex - 1]! !

!ReadStream methodsFor: 'accessing' stamp: ''!
readStream
	"polymorphic with SequenceableCollection.  Return self"

	^ self! !

!ReadStream methodsFor: 'accessing' stamp: ''!
skipTo: anObject
	"fast version using indexOf:"
	| end |
	end := collection indexOf: anObject startingAt: position+1 ifAbsent: [ 0 ].

	^(end = 0 or: [end > readLimit]) 
		ifTrue: [ self setToEnd. false ]
		ifFalse: [ position := end. true]! !

!ReadStreamTest commentStamp: ''!
I am an SUnit test for ReadStream.
I have no test fixtures.!
!ReadStreamTest methodsFor: 'tests' stamp: ''!
testOldPeekBack
	"Test the old behavior of the method peekBack. The method #oldBack is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. The method #oldBack considers that the pointer is *on* an element. (Damien Cassou - 1 August 2007)"
	| stream |
	stream := 'abc' readStream.
	stream setToEnd.
	self assert: stream oldPeekBack equals: $b.! !

!ReadStreamTest methodsFor: 'tests - accessing' stamp: ''!
testUpTo3
	| stream string |
	string := 'XYZabcdUVW'.
	stream := ReadStream on: string from: (string indexOf: $a) to: (string indexOf: $d).
	self assert: stream upToEnd equals: 'abcd'.
	self assert: stream atEnd.
	stream := ReadStream on: string from: (string indexOf: $a) to: (string indexOf: $d).
	self assert: (stream upTo: $c) equals: 'ab'.
	self assert: stream next equals: $d.
	stream := ReadStream on: string from: (string indexOf: $a) to: (string indexOf: $d).
	self assert: (stream upTo: $e) equals: 'abcd'.
	self assert: stream atEnd! !

!ReadStreamTest methodsFor: 'tests' stamp: ''!
testPositionOfSubCollection
	
	self assert: ('xyz' readStream positionOfSubCollection: 'q' ) equals: 0.
	self assert: ('xyz' readStream positionOfSubCollection: 'x' ) equals: 1.

	self assert: ('xyz' readStream positionOfSubCollection: 'y' ) equals: 2.
	self assert: ('xyz' readStream positionOfSubCollection: 'z' ) equals: 3.! !

!ReadStreamTest methodsFor: 'tests' stamp: ''!
testBackOnPosition1
	"Test the new implementation of the method back."
	| stream |
	stream := 'abc' readStream.
	stream next.
	self assert: stream back equals: $a.! !

!ReadStreamTest methodsFor: 'tests' stamp: ''!
testOldBackOnPosition1
	"Test the old behavior of the method back. The method #oldBack is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. The method #oldBack considers that the pointer is *on* an element. (Damien Cassou - 1 August 2007)"

	| stream |
	stream := 'abc' readStream.
	stream next.
	self assert: stream oldBack isNil! !

!ReadStreamTest methodsFor: 'accessing - defaults' stamp: ''!
streamOnString
	^ ReadStream on: 'abcde'.! !

!ReadStreamTest methodsFor: 'tests' stamp: ''!
testOldBack
	"Test the old behavior of the method back. The method #oldBack is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. The method #oldBack considers that the pointer is *on* an element. (Damien Cassou - 1 August 2007)"
	| stream |
	stream := 'abc' readStream.
	stream setToEnd.
	self assert: stream oldBack equals: $b.! !

!ReadStreamTest methodsFor: 'tests - testing' stamp: ''!
testAtEnd
	self assert: self emptyStream atEnd.
	self deny: self streamOnString atEnd! !

!ReadStreamTest methodsFor: 'utilities' stamp: ''!
streamOn: collection upToAll: subcollection 
	^ collection readStream upToAll: subcollection! !

!ReadStreamTest methodsFor: 'tests' stamp: ''!
testUpToAll
	self assert: (self streamOn: 'abcdefgh' upToAll: 'cd') equals: 'ab'.
	self assert: (self streamOn: 'abcdefgh' upToAll: 'cd' upToAll: 'gh') equals: 'ef'.
	self assert: (self streamOn: '' upToAll: '') equals: ''.
	self assert: (self streamOn: 'a' upToAll: '') equals: ''.
	self assert: (self streamOn: 'a' upToAll: 'a') equals: ''.
	self assert: (self streamOn: 'a' upToAll: 'b') equals: 'a'.
	self assert: (self streamOn: 'ab' upToAll: '') equals: ''.
	self assert: (self streamOn: 'ab' upToAll: 'a') equals: ''.
	self assert: (self streamOn: 'ab' upToAll: 'b') equals: 'a'.
	self assert: (self streamOn: 'ab' upToAll: 'c') equals: 'ab'.
	self assert: (self streamOn: 'ab' upToAll: 'ab') equals: ''.
	self assert: (self streamOn: 'abc' upToAll: '') equals: ''.
	self assert: (self streamOn: 'abc' upToAll: 'a') equals: ''.
	self assert: (self streamOn: 'abc' upToAll: 'b') equals: 'a'.
	self assert: (self streamOn: 'abc' upToAll: 'c') equals: 'ab'.
	self assert: (self streamOn: 'abc' upToAll: 'd') equals: 'abc'.
	self assert: (self streamOn: 'abc' upToAll: 'ab') equals: ''.
	self assert: (self streamOn: 'abc' upToAll: 'bc') equals: 'a'.
	self assert: (self streamOn: 'abc' upToAll: 'cd') equals: 'abc'! !

!ReadStreamTest methodsFor: 'utilities' stamp: ''!
streamOn: collection upToAll: subcollection1 upToAll: subcollection2 
	^ collection readStream
		upToAll: subcollection1;
		upToAll: subcollection2! !

!ReadStreamTest methodsFor: 'accessing - defaults' stamp: ''!
streamOnArray
	^ ReadStream on: (Array with: 1 with: #(a b c) with: false).! !

!ReadStreamTest methodsFor: 'tests' stamp: ''!
testBack
	| stream |
	stream := 'abc' readStream.
	stream setToEnd.
	self assert: stream back equals: $c.! !

!ReadStreamTest methodsFor: 'tests - testing' stamp: ''!
testIsEmpty
	| stream |
	self assert: self emptyStream isEmpty.
	
	stream := self streamOnArray.
	self deny: stream isEmpty.
	stream skip: 3.
	self deny: stream isEmpty.
	
	stream := self streamOnString.
	self deny: stream isEmpty.
	stream next;next;next.
	self deny: stream isEmpty.
	stream setToEnd.
	self deny: stream isEmpty.! !

!ReadStreamTest methodsFor: 'tests' stamp: ''!
testPeekBack
	"Test the new implementation of the method peekBack due to changing #back."
	| stream |
	stream := 'abc' readStream.
	stream setToEnd.
	self assert: stream peekBack equals: $c.! !

!ReadStreamTest methodsFor: 'accessing - defaults' stamp: ''!
emptyStream
	^ ReadStream on: String new.! !

!ReadStreamTest methodsFor: 'tests - accessing' stamp: ''!
testContents
	| stream |
	stream := self streamOnString.
	self assert: stream contents equals: 'abcde'.
	stream next: 2.
	self assert: stream contents equals: 'abcde'! !

!ReadWriteStream commentStamp: ''!
I represent an accessor for a sequence of objects. My instances can both read and store objects.!
!ReadWriteStream methodsFor: 'comparing' stamp: ''!
= other

	(self class == ReadWriteStream and: [other class == ReadWriteStream]) ifFalse: [
		^ super = other].	"does an identity test.  Don't read contents of FileStream"
	^ self position = other position and: [self contents = other contents]! !

!ReadWriteStream methodsFor: 'accessing' stamp: ''!
name
	^ 'a stream'   "for fileIn compatibility"! !

!ReadWriteStream methodsFor: 'comparing' stamp: ''!
hash

	self class == ReadWriteStream ifFalse: [^ super hash].
	^ (self position + readLimit + 53) hash! !

!ReadWriteStream methodsFor: 'accessing' stamp: ''!
readInto: aCollection startingAt: startIndex count: n
	"Read n objects into the given collection. 
	Return number of elements that have been read."
	
	| max |
	max := (readLimit - position) min: n.
	aCollection 
		replaceFrom: startIndex 
		to: startIndex + max - 1
		with: collection
		startingAt: position + 1.
	position := position + max.
	^ max! !

!ReadWriteStream methodsFor: 'accessing' stamp: ''!
next
	"Primitive. Return the next object in the Stream represented by the
	receiver. Fail if the collection of this stream is not an Array or a String.
	Fail if the stream is positioned at its end, or if the position is out of
	bounds in the collection. Optional. See Object documentation
	whatIsAPrimitive."

	"treat me as a FIFO"
	position >= readLimit
		ifTrue: [^nil]
		ifFalse: [^collection at: (position := position + 1)]! !

!ReadWriteStream methodsFor: 'accessing' stamp: ''!
contents

	readLimit := readLimit max: position.
	^ collection copyFrom: 1 to: readLimit! !

!ReadWriteStream methodsFor: 'accessing' stamp: ''!
next: anInteger 
	"Answer the next anInteger elements of my collection.  overriden for efficiency"

	| ans endPosition |
	readLimit := readLimit max: position.

	endPosition := position + anInteger  min:  readLimit.
	ans := collection copyFrom: position+1 to: endPosition.
	position := endPosition.
	^ans! !

!ReadWriteStream methodsFor: 'converting' stamp: ''!
readStream
	"polymorphic with SequenceableCollection.  Return self"

	^ self! !

!ReadWriteStream methodsFor: '*Compression' stamp: 'nil'!
isZipArchive
	"Determine if this appears to be a valid Zip archive"
	| sig |
	self binary.
	sig := self next: 4.
	self position: self position - 4. "rewind"
	^ZipArchive validSignatures includes: sig! !

!ReadWriteStreamTest commentStamp: ''!
This is the unit test for the class ReadWriteStream.
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!
!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testReset
	| stream |
	stream := self emptyStream.
	stream
		nextPutAll: 'abc';
		reset.
	stream next: 2.
	stream reset.
	self assert: stream next equals: $a.
	stream := self emptyStream.
	stream 
		nextPutAll: 'abc';
		reset.
	stream nextPutAll: 'def'.
	self assert: stream contents equals: 'def'.
	stream := self emptyByteStream.
	stream
		nextPutAll: 'abc' asByteArray;
		reset.
	stream next: 2.
	stream reset.
	self assert: stream next equals: 97! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testNextPutAll
	| stream |
	stream := self emptyStream.
	stream nextPutAll: 'abc'.
	self assert: stream contents equals: 'abc'.
	stream := self emptyStream.
	stream nextPutAll: #($a $b $c).
	self assert: stream contents equals: 'abc'.
	stream := self emptyByteStream.
	stream nextPutAll: #(97 98 99 ) asByteArray.
	self assert: stream contents equals: 'abc' asByteArray! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testNext
	| stream |
	stream := self emptyStream.
	stream
		nextPutAll: 'abcd';
		reset.
	self assert: stream next equals: $a.
	self assert: (stream next: 0) equals: ''.
	self assert: (stream next: 1) equals: 'b'.
	self assert: (stream next: 2) equals: 'cd'.
	stream := self emptyByteStream.
	stream
		nextPutAll: 'abcd' asByteArray;
		reset.
	self assert: stream next equals: 97.
	self assert: (stream next: 0) equals: '' asByteArray.
	self assert: (stream next: 1) equals: 'b' asByteArray.
	self assert: (stream next: 2) equals: 'cd' asByteArray! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testSkip
	| stream |
	stream := self emptyStream.
	stream
		nextPutAll: 'abcd';
		reset.
	self assert: (stream skip: 2; peek) equals: $c.
	stream := self emptyByteStream.
	stream
		nextPutAll: 'abcd' asByteArray;
		reset.
	self assert: (stream skip: 2; peek) equals: 99! !

!ReadWriteStreamTest methodsFor: 'accessing - defaults' stamp: ''!
emptyByteStream
	^ ReadWriteStream on: (ByteArray new: 4096).! !

!ReadWriteStreamTest methodsFor: 'accessing - defaults' stamp: ''!
streamOnString
	^ ReadWriteStream with: 'abcde'.! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testConstructionUsingWith
	"Use the with: constructor."

	| aStream |
	aStream := ReadWriteStream with: #(1 2).
	self assert: (aStream contents = #(1 2)) description: 'Ensure correct initialization.'! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testPeek
	| stream |
	stream := self emptyStream.
	self assert: stream peek isNil.
	stream := self emptyStream.
	stream
		nextPutAll: 'abcd';
		reset.
	self assert: stream peek equals: $a.
	stream := self emptyByteStream.
	stream
		nextPutAll: 'abcd' asByteArray;
		reset.
	self assert: stream peek equals: 97! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testUpToEnd
	| stream |
	stream := self emptyStream.
	stream
		nextPutAll: 'abcd';
		reset.
	self assert: stream upToEnd equals: 'abcd'.
	self assert: stream atEnd.
	self assert: stream upToEnd equals: ''.
	self assert: stream atEnd.
	stream reset.
	stream upTo: $b.
	self assert: stream upToEnd equals: 'cd'.
	self assert: stream atEnd.
	stream := self emptyByteStream.
	stream
		nextPutAll: 'abcd' asByteArray;
		reset.
	self assert: stream upToEnd equals: #(97 98 99 100) asByteArray.
	self assert: stream atEnd.
	self assert: stream upToEnd equals: #() asByteArray.
	self assert: stream atEnd.
	stream reset.
	stream upTo: 98.
	self assert: stream upToEnd equals: #(99 100) asByteArray.
	self assert: stream atEnd! !

!ReadWriteStreamTest methodsFor: 'tests - testing' stamp: ''!
testAtEnd
	| stream |
	stream := self emptyStream.
	self assert: stream atEnd.
	stream
		nextPut: $a;
		reset.
	self deny: stream atEnd! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testTab
	| stream |
	stream := self emptyStream.
	stream tab.
	self assert: stream contents first equals: Character tab! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testUpTo
	| stream |
	stream := self emptyStream.
	stream
		nextPutAll: 'abcd';
		reset.
	self assert: (stream upTo: $c) equals: 'ab'.
	self assert: stream next equals: $d.
	stream := self emptyStream.
	stream
		nextPutAll: 'abcd';
		reset.
	self assert: (stream upTo: $x) equals: 'abcd'.
	self assert: stream atEnd.
	stream := self emptyByteStream.
	stream
		nextPutAll: 'abcd' asByteArray;
		reset.
	self assert: (stream upTo: 99) equals: #(97 98) asByteArray.
	self assert: stream next equals: 100.
	stream := self emptyByteStream.
	stream
		nextPutAll: 'abcd' asByteArray;
		reset.
	self assert: (stream upTo: 120) equals: #(97 98 99 100) asByteArray.
	self assert: stream atEnd! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testPosition
	| stream |
	stream := self emptyStream.
	stream
		nextPutAll: 'abc';
		reset.
	self assert: stream position equals: 0.
	stream next.
	self assert: stream position equals: 1.
	stream next.
	self assert: stream position equals: 2.
	stream next.
	self assert: stream position equals: 3.
	stream position: 1.
	self assert: stream position equals: 1.
	self assert: stream next equals: $b.
	stream position: 0.
	self assert: stream position equals: 0.
	self assert: stream next equals: $a.
	stream position: 3.
	self assert: stream atEnd.
	stream := self emptyByteStream.
	stream
		nextPutAll: 'abc' asByteArray;
		reset.
	self assert: stream position equals: 0.
	stream next.
	self assert: stream position equals: 1.
	stream next.
	self assert: stream position equals: 2.
	stream next.
	self assert: stream position equals: 3.
	stream position: 1.
	self assert: stream position equals: 1.
	self assert: stream next equals: 98.
	stream position: 0.
	self assert: stream position equals: 0.
	self assert: stream next equals: 97.
	stream position: 3.
	self assert: stream atEnd! !

!ReadWriteStreamTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ ReadWriteStream! !

!ReadWriteStreamTest methodsFor: 'tests - testing' stamp: ''!
testIsEmpty
	| stream |
	stream := self emptyStream.
	self assertEmpty: stream.
	stream nextPut: $a.
	self deny: stream isEmpty.
	stream reset.
	self deny: stream isEmpty.
	stream next.
	self deny: stream isEmpty.! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testNextPut
	| stream |
	stream := self emptyStream.
	stream nextPut: $a.
	self assert: stream contents equals: 'a'.
	stream := self emptyByteStream.
	stream nextPut: 97.
	self assert: stream contents equals: 'a' asByteArray! !

!ReadWriteStreamTest methodsFor: 'accessing - defaults' stamp: ''!
emptyStream
	^ ReadWriteStream on: (String new: 4096).! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testNew

	self should: [ ReadWriteStream new ] raise: Error.! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testContents
	| stream |
	stream := self emptyStream.
	stream
		nextPutAll: 'abc';
		reset.
	self assert: stream contents equals: 'abc'.
	stream next: 2.
	self assert: stream contents equals: 'abc'.
	stream := self emptyByteStream.
	stream
		nextPutAll: 'abc' asByteArray;
		reset.
	self assert: stream contents equals: 'abc' asByteArray.
	stream next: 2.
	self assert: stream contents equals: 'abc' asByteArray! !

!RealEstateAgent commentStamp: ''!
Responsible for real-estate management on the screen, which is to say, controlling where new windows appear, with what sizes, etc.  5/20/96 sw!
!RealEstateAgent class methodsFor: 'settings' stamp: ''!
windowColumnsDesired
	"Answer how many separate vertical columns of windows are
	wanted."
	^ (self usedStrategy = #staggerFor:initialExtent:world:)
		ifTrue: [1]
		ifFalse: [self maximumUsableArea width > 640
				ifTrue: [2]
				ifFalse: [1]]! !

!RealEstateAgent class methodsFor: 'class initialization' stamp: ''!
initialize
	"RealEstateAgent initialize"

	StaggerOffset := 20 @ 40.
	StandardSize := 700@500.! !

!RealEstateAgent class methodsFor: 'accessing' stamp: ''!
standardPositionsInWorld: aWorldOrNil
	"Return a list of standard window positions -- this may have one, two, or four of them, depending on the size and shape of the display screen.  "

	| anArea aList  midX midY |
	anArea := self maximumUsableAreaInWorld: aWorldOrNil.
	midX := self scrollBarSetback +   ((anArea width - self scrollBarSetback)  // 2).
	midY := self screenTopSetback + ((anArea height - self screenTopSetback) // 2).
	aList := OrderedCollection with: (self scrollBarSetback @ self screenTopSetback).
	self windowColumnsDesired > 1
		ifTrue: 	[ aList add: (midX @ self screenTopSetback)].
	self windowRowsDesired > 1
		ifTrue: 
			[ aList add: (self scrollBarSetback @ (midY+self screenTopSetback)).
			self windowColumnsDesired > 1 ifTrue:
				[ aList add: (midX @ (midY+self screenTopSetback))]].
	^ aList! !

!RealEstateAgent class methodsFor: 'accessing' stamp: ''!
maximumUsableAreaInWorld: aWorldOrNil

	| allowedArea |
	
	allowedArea := 0@0 extent: self standardSize. "fallback default size"
	
	aWorldOrNil ifNotNil: [
		allowedArea := aWorldOrNil displayArea intersect: aWorldOrNil visibleClearArea ifNone: [ allowedArea ]].
	^allowedArea! !

!RealEstateAgent class methodsFor: 'settings' stamp: ''!
screenTopSetback
	^ 0! !

!RealEstateAgent class methodsFor: 'utilities' stamp: ''!
assignCollapseFrameFor: aSSView 
	"Offer up a location along the left edge of the screen for a collapsed
	SSView. Make sure it doesn't overlap any other collapsed frames."
	| grid otherFrames topLeft viewBox collapsedFrame extent newFrame verticalBorderDistance top |
	grid := 8.
	verticalBorderDistance := 8.
	otherFrames := ( aSSView world windowsSatisfying: [:w | w ~= aSSView])
				collect: [:w | w collapsedFrame]
				thenSelect: [:rect | rect notNil].
	viewBox := aSSView world viewBox.
	collapsedFrame := aSSView collapsedFrame.
	extent := collapsedFrame notNil
				ifTrue: [collapsedFrame extent]
				ifFalse: [aSSView getRawLabel width + aSSView labelWidgetAllowance @ (aSSView labelHeight + 2)].
	collapsedFrame notNil
		ifTrue: [(otherFrames
					anySatisfy: [:f | collapsedFrame intersects: f])
				ifFalse: ["non overlapping"
					^ collapsedFrame]].
	top := viewBox top + verticalBorderDistance.
	[topLeft := viewBox left @ top.
	newFrame := topLeft extent: extent.
	newFrame bottom <= (viewBox height - verticalBorderDistance)]
		whileTrue: [(otherFrames
					anySatisfy: [:w | newFrame intersects: w])
				ifFalse: ["no overlap"
					^ newFrame].
			top := top + grid].
	"If all else fails... (really to many wins here)"
	^ 0 @ 0 extent: extent! !

!RealEstateAgent class methodsFor: 'strategy' stamp: ''!
cascadeFor: aView initialExtent: initialExtent world: aWorld

	| position allowedArea |
	allowedArea := self maximumUsableAreaInWorld: aWorld.
	position := aWorld currentWindow isMorph 
		ifFalse: [ aWorld center - (initialExtent / 2)]
		ifTrue: [ aWorld currentWindow position + 20].
	^ (position extent: initialExtent)
		translatedAndSquishedToBeWithin: allowedArea! !

!RealEstateAgent class methodsFor: 'accessing' stamp: ''!
maximumUsableArea

	| allowedArea |
	allowedArea := Display usableArea.
	allowedArea := allowedArea intersect: self currentWorld visibleClearArea ifNone: [ allowedArea ].
	^allowedArea! !

!RealEstateAgent class methodsFor: 'settings' stamp: ''!
scrollBarSetback
	^ 16-3 "width = 16; inset from border by 3"! !

!RealEstateAgent class methodsFor: 'strategy' stamp: ''!
staggerFor: aView initialExtent: initialExtent world: aWorld

	^ self strictlyStaggeredInitialFrameFor: aView
				initialExtent: initialExtent
				world: aWorld! !

!RealEstateAgent class methodsFor: 'strategy' stamp: ''!
standardFor: aView initialExtent: initialExtent world: aWorld

	| allOrigins screenRight screenBottom putativeOrigin putativeFrame allowedArea staggerOrigin otherFrames |
	allowedArea := self maximumUsableAreaInWorld: aWorld.
	screenRight := allowedArea right.
	screenBottom := allowedArea bottom.
	otherFrames := (aWorld
				windowsSatisfying: [:w | w isCollapsed not])
				collect: [:w | w bounds].
	allOrigins := otherFrames
				collect: [:f | f origin].
	(self standardPositionsInWorld: aWorld)
		do: [:aPosition | "First see if one of the standard positions is free"
			(allOrigins includes: aPosition)
				ifFalse: ["First see if one of the standard positions is free"
					^ (aPosition extent: initialExtent)
						translatedAndSquishedToBeWithin: allowedArea"First see if one of the standard positions is free"]].
	staggerOrigin := (self standardPositionsInWorld: aWorld) first.
	"Fallback: try offsetting from top left"
	putativeOrigin := staggerOrigin.
	[putativeOrigin := putativeOrigin + StaggerOffset.
	putativeFrame := putativeOrigin extent: initialExtent.
	putativeFrame bottom < screenBottom
		and: [putativeFrame right < screenRight]]
		whileTrue: [(allOrigins includes: putativeOrigin)
				ifFalse: [^ (putativeOrigin extent: initialExtent)
						translatedAndSquishedToBeWithin: allowedArea]].
	^ (self scrollBarSetback @ self screenTopSetback extent: initialExtent)
		translatedAndSquishedToBeWithin: allowedArea! !

!RealEstateAgent class methodsFor: 'accessing' stamp: ''!
standardSize

	^ StandardSize! !

!RealEstateAgent class methodsFor: 'accessing' stamp: ''!
standardSize: extent

	StandardSize := extent! !

!RealEstateAgent class methodsFor: 'settings' stamp: ''!
usedStrategy
	^ UsedStrategy ifNil: [UsedStrategy := #staggerFor:initialExtent:world:]! !

!RealEstateAgent class methodsFor: 'settings' stamp: ''!
windowRowsDesired
	"Answer how many separate horizontal rows of windows are wanted."
	^ (self usedStrategy = #staggerFor:initialExtent:world:)
		ifTrue: [1]
		ifFalse: [self maximumUsableArea height > 480
				ifTrue: [2]
				ifFalse: [1]]! !

!RealEstateAgent class methodsFor: 'utilities' stamp: ''!
assignCollapsePointFor: aSSView 
	"Offer up a location along the left edge of the screen for a collapsed
	SSView. Make sure it doesn't overlap any other collapsed frames."
	| grid otherFrames y free topLeft viewBox |
	grid := 24.
	"should be mult of 8, since manual move is gridded by 8"
	otherFrames := ( aSSView world   windowsSatisfying: [:w | true])
				collect: [:w | w collapsedFrame]
				thenSelect: [:rect | rect notNil].
	viewBox := aSSView world viewBox.
	y := viewBox top.
	[(y := y + grid) <= (viewBox height - grid)]
		whileTrue: [topLeft := viewBox left @ y.
			free := true.
			otherFrames
				do: [:w | free := free & (topLeft ~= w topLeft)].
			free
				ifTrue: [^ topLeft]].
	"If all else fails..."
	^ 0 @ 0! !

!RealEstateAgent class methodsFor: 'settings' stamp: ''!
standardWindowExtent
	"Answer the standard default extent for new windows. "
	| effectiveExtent width strips height grid allowedArea maxLevel |
	effectiveExtent := self maximumUsableArea extent - (self scrollBarSetback @ self screenTopSetback).
	(self usedStrategy = #staggerFor:initialExtent:world:)
		ifTrue: ["NOTE: following copied from
			strictlyStaggeredInitialFrameFor: "
			"Number to be staggered at each corner (less on small
			screens) "
			allowedArea := self maximumUsableArea
						insetBy: (self scrollBarSetback @ self screenTopSetback extent: 0 @ 0).
			"NOTE: following copied from
			strictlyStaggeredInitialFrameFor: "
			"Number to be staggered at each corner (less on small
			screens) "
			maxLevel := allowedArea area > 300000
						ifTrue: [3]
						ifFalse: [2].
			"Amount by which to stagger (less on small screens)"
			grid := allowedArea area > 500000
						ifTrue: [40]
						ifFalse: [20].
			^ allowedArea extent - (grid * (maxLevel + 1 * 2) + (grid // 2)) max: StandardSize].
	width := (strips := self windowColumnsDesired) > 1
				ifTrue: [effectiveExtent x // strips]
				ifFalse: [3 * effectiveExtent x // 4].
	height := (strips := self windowRowsDesired) > 1
				ifTrue: [effectiveExtent y // strips]
				ifFalse: [3 * effectiveExtent y // 4].
	^ width @ height max: StandardSize "RealEstateAgent standardWindowExtent"! !

!RealEstateAgent class methodsFor: 'framing' stamp: ''!
initialFrameFor: aView world: aWorld
	"Find a plausible initial screen area for the supplied view.  See called method."

	^ self initialFrameFor: aView initialExtent: aView initialExtent world: aWorld! !

!RealEstateAgent class methodsFor: 'framing' stamp: ''!
strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld
	"This method implements a staggered window placement policy that I (di) like.
	Basically it provides for up to 4 windows, staggered from each of the 4 corners.
	The windows are staggered so that there will always be a corner visible."

	| allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel |

	allowedArea :=(self maximumUsableAreaInWorld: aWorld)
		insetBy: (self scrollBarSetback @ self screenTopSetback extent: 0@0).
	"Number to be staggered at each corner (less on small screens)"
	maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2].
	"Amount by which to stagger (less on small screens)"
	grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20].
	initialFrame := 0@0 extent: ((initialExtent
							"min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))))
							min: 600@400")).
	otherFrames := (aWorld windowsSatisfying: [:w | w isCollapsed not])
					collect: [:w | w bounds].
	0 to: maxLevel do:
		[:level | 
		1 to: 4 do:
			[:ci | cornerSel := #(topLeft topRight bottomRight bottomLeft) at: ci.
			corner := allowedArea perform: cornerSel.
			"The extra grid//2 in delta helps to keep title tabs distinct"
			delta := (maxLevel-level*grid+(grid//2)) @ (level*grid).
			1 to: ci-1 do: [:i | delta := delta rotateBy: #right centerAt: 0@0]. "slow way"
			putativeCorner := corner + delta.
			free := true.
			otherFrames do:
				[:w |
				free := free & ((w perform: cornerSel) ~= putativeCorner)].
			free ifTrue:
				[^ (initialFrame align: (initialFrame perform: cornerSel)
								with: putativeCorner)
						 translatedAndSquishedToBeWithin: allowedArea]]].
	"If all else fails..."
	^ (self scrollBarSetback @ self screenTopSetback extent: initialFrame extent)
		translatedAndSquishedToBeWithin: allowedArea! !

!RealEstateAgent class methodsFor: 'settings' stamp: ''!
usedStrategy: aSelector
	UsedStrategy := aSelector! !

!RealEstateAgent class methodsFor: 'framing' stamp: ''!
initialFrameFor: aView initialExtent: initialExtent world: aWorld 
	"Find a plausible initial screen area for the supplied view, which
	should be a StandardSystemView, taking into account the
	'reverseWindowStagger' Preference, the size needed, and other
	windows currently on the screen."
	
	^self perform: self usedStrategy with: aView with: initialExtent with: aWorld! !

!Rectangle commentStamp: ''!
I represent a rectangular area of the screen. Arithmetic functions take points as arguments and carry out scaling and translating operations to create new instances of me. Rectangle functions create new instances by determining intersections of rectangles with rectangles.

Note 1: only rectangles parallel to reference frame (Screen) can be represented by this class.

Note 2: the Rectangle is represented by two extremities of one diagonal. By convention, it must be the diagonal:
	from rectangle origin (the point having smallest coordinates in reference frame),
	to rectangle corner (the point having largest coordinates in reference frame).

Note 3: Screen coordinates conventions are:
	x is horizontal axis, zero at left border, oriented toward right;
	y is vertical axis, zero at top border, oriented toward bottom.
This corresponds to the latin convention for writing text from left to right and top to bottom.

Note 4: the Rectangle extent is obtained by subtracting rectangle origin to rectangle corner coordinates.
If this leads to a negative width (extent x coordinate) and/or a negative height (extent y coordinate), then the Rectangle is degenerated and considered empty.

Instance variables:
	origin	<Point> the coordinates of corner having smallest coordinates (top left in Screen coordinates)
	corner	<Point> the coordinates of corner having largest coordinates (bottom right in Screen coordinates)
!
!Rectangle methodsFor: 'accessing' stamp: ''!
topRight
	"Answer the point at the top right corner of the receiver's top horizontal 
	line."

	^corner x @ origin y! !

!Rectangle methodsFor: 'transforming' stamp: ''!
squishedWithin: aRectangle
	"Return an adjustment of the receiver that fits within aRectangle by reducing its size, not by changing its origin.  "

	^ origin corner: (corner min: aRectangle bottomRight)

"(50 @ 50 corner: 160 @ 100) squishedWithin:  (20 @ 10 corner: 90 @ 85)"! !

!Rectangle methodsFor: 'accessing' stamp: ''!
corners
	"Return an array of corner points in the order of a quadrilateral spec for WarpBlt."

	^ Array
		with: self topLeft
		with: self bottomLeft
		with: self bottomRight
		with: self topRight! !

!Rectangle methodsFor: 'accessing' stamp: ''!
top: aNumber
	^origin x @ aNumber corner: corner! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
withSideOrCorner: side setToPoint: newPoint minExtent: minExtent
	"Return a copy with side set to newPoint"
	^self withSideOrCorner: side setToPoint: newPoint minExtent: minExtent
		limit: ((#(left top) includes: side) ifTrue: [SmallInteger minVal] ifFalse: [SmallInteger maxVal])! !

!Rectangle methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating
	^ self class == Rectangle! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
withTop: y 
	"Return a copy of me with a different top y"
	^ origin x @ (y min: corner y) corner: corner x @ corner y! !

!Rectangle methodsFor: '*Morphic-Base' stamp: ''!
drawReverseFrame: rect

	Display 
		border: rect
		width: 2
		rule: Form reverse
		fillColor: Color gray! !

!Rectangle methodsFor: '*Athens-Core' stamp: ''!
asAthensShapeOn: anAthensCanvas 
	"Just answer self. Receiver don't needs any conversion to be used with Athens"
	
	^ self! !

!Rectangle methodsFor: 'transforming' stamp: ''!
translatedAndSquishedToBeWithin: aRectangle
	"Return an adjustment of the receiver that fits within aRectangle by
		- translating it to be within aRectangle if necessary, then
		- reducing its size, if necessary"

	^ (self translatedToBeWithin: aRectangle) squishedWithin: aRectangle! !

!Rectangle methodsFor: 'accessing' stamp: ''!
width
	"Answer the width of the receiver."

	^corner x - origin x! !

!Rectangle methodsFor: 'accessing' stamp: ''!
bottom: aNumber
	^origin corner: corner x @ aNumber! !

!Rectangle methodsFor: 'accessing' stamp: ''!
left
	"Answer the position of the receiver's left vertical line."

	^origin x! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
insetOriginBy: originDeltaPoint cornerBy: cornerDeltaPoint 
	"Answer a Rectangle that is inset from the receiver by a given amount in 
	the origin and corner."

	^Rectangle
		origin: origin + originDeltaPoint
		corner: corner - cornerDeltaPoint! !

!Rectangle methodsFor: 'accessing' stamp: ''!
topCenter
	"Answer the point at the center of the receiver's top horizontal line."

	^self center x @ self top! !

!Rectangle methodsFor: 'accessing' stamp: ''!
extent
	"Answer a point with the receiver's width @ the receiver's height."

	^corner - origin! !

!Rectangle methodsFor: 'accessing' stamp: ''!
topLeft
	"Answer the point at the top left corner of the receiver's top horizontal line."

	^origin! !

!Rectangle methodsFor: 'truncation and roundoff' stamp: ''!
expanded
	"Answer a Rectangle whose origin and corner are rounded to integers.
	Rounding is done by upper value on origin and lower value on corner so that
	self is inside rounded rectangle."

	^Rectangle origin: origin floor corner: corner ceiling! !

!Rectangle methodsFor: '*Spec-Core' stamp: ''!
asSpecLayoutFrame
	"Answer an instance of LayoutFrame which uses fractions from receiver "
	
	^ SpecLayoutFrame new
		leftFraction: self left;
		rightFraction: self right;
		topFraction: self top;
		bottomFraction: self bottom;
		yourself
		! !

!Rectangle methodsFor: 'truncation and round off' stamp: ''!
truncated
	"Answer a Rectangle whose origin and corner have any fractional parts removed. Answer the receiver if its coordinates are already integral."

	(origin x isInteger and:
	[origin y isInteger and:
	[corner x isInteger and:
	[corner y isInteger]]])
		ifTrue: [^ self].

	^ Rectangle origin: origin truncated corner: corner truncated! !

!Rectangle methodsFor: 'testing' stamp: ''!
isWide
	^ self width > self height! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
forPoint: aPoint closestSideDistLen: sideDistLenBlock 
	"Evaluate the block with my side (symbol) closest to aPoint,
		the approx distance of aPoint from that side, and
		the length of the side (or 0 if aPoint is beyond the side)"
	| side |
	side := self sideNearestTo: aPoint.
	side == #right ifTrue: 
		[ ^ sideDistLenBlock 
			value: side
			value: (self right - aPoint x) abs
			value: ((aPoint y 
					between: self top
					and: self bottom) 
					ifTrue: [ self height ]
					ifFalse: [ 0 ]) ].
	side == #left ifTrue: 
		[ ^ sideDistLenBlock 
			value: side
			value: (self left - aPoint x) abs
			value: ((aPoint y 
					between: self top
					and: self bottom) 
					ifTrue: [ self height ]
					ifFalse: [ 0 ]) ].
	side == #bottom ifTrue: 
		[ ^ sideDistLenBlock 
			value: side
			value: (self bottom - aPoint y) abs
			value: ((aPoint x 
					between: self left
					and: self right) 
					ifTrue: [ self width ]
					ifFalse: [ 0 ]) ].
	side == #top ifTrue: 
		[ ^ sideDistLenBlock 
			value: side
			value: (self top - aPoint y) abs
			value: ((aPoint x 
					between: self left
					and: self right) 
					ifTrue: [ self width ]
					ifFalse: [ 0 ]) ]! !

!Rectangle methodsFor: 'fmp' stamp: ''!
deltaToEnsureInOrCentered: r extra: aNumber 
	| dX dY halfXDiff halfYDiff |
	dX := dY := 0.
	halfXDiff := ((r width - self width) * aNumber) truncated.
	halfYDiff := ((r height - self height) * aNumber) truncated.
	self left < r left 
		ifTrue: [ dX := self left - r left - halfXDiff ]
		ifFalse: 
			[ self right > r right ifTrue: [ dX := self right - r right + halfXDiff ] ].
	self top < r top 
		ifTrue: [ dY := self top - r top - halfYDiff ]
		ifFalse: 
			[ self bottom > r bottom ifTrue: [ dY := self bottom - r bottom + halfYDiff ] ].
	^ dX @ dY! !

!Rectangle methodsFor: 'private' stamp: ''!
setLeft: left right: right top: top bottom: bottom 

	origin := (left min: right) @ (top min: bottom).
	corner := (left max: right) @ (top max: bottom).! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
withSideOrCorner: side setToPoint: newPoint
	"Return a copy with side set to newPoint"

	^ self withSideOrCorner: side setToPoint: newPoint minExtent: 0@0! !

!Rectangle methodsFor: '*Morphic-Base' stamp: ''!
newRectButtonPressedDo: newRectBlock inWorld: aWorld
	"Track the outline of a new rectangle until mouse button changes. newFrameBlock produces each new rectangle from the previous. Only tracks while mouse is down."
	| rect newRect buttonNow hand |
	
	hand := aWorld activeHand.
	
	buttonNow := hand anyButtonPressed.
	rect := self.
	self drawReverseFrame: rect.
		
	hand captureEventsWhile: [:evt |
		evt isMouse ifTrue: [
			buttonNow := evt anyButtonPressed.
			newRect := newRectBlock value: rect value: evt cursorPoint.
			newRect = rect ifFalse: 
				[self drawReverseFrame: rect.
				self drawReverseFrame: newRect.	
				rect := newRect ]. 

			 buttonNow 
			] ifFalse: [ true ]
		].
	
	self drawReverseFrame: rect.
	aWorld activeHand
		newMouseFocus: nil;
		showTemporaryCursor: nil.
	^ rect! !

!Rectangle methodsFor: 'comparing' stamp: ''!
= aRectangle 
	"Answer true if the receiver's species, origin and corner match aRectangle's."

	self species = aRectangle species
		ifTrue: [^origin = aRectangle origin and: [corner = aRectangle corner]]
		ifFalse: [^false]! !

!Rectangle methodsFor: 'accessing' stamp: ''!
left: aNumber
	^aNumber @ origin y corner: corner! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
pointNearestTo: aPoint 
	"Return the point on my border closest to aPoint"
	| side |
	(self containsPoint: aPoint) 
		ifTrue: 
			[ side := self sideNearestTo: aPoint.
			side == #right ifTrue: [ ^ self right @ aPoint y ].
			side == #left ifTrue: [ ^ self left @ aPoint y ].
			side == #bottom ifTrue: [ ^ aPoint x @ self bottom ].
			side == #top ifTrue: [ ^ aPoint x @ self top ] ]
		ifFalse: [ ^ aPoint adhereTo: self ]! !

!Rectangle methodsFor: 'transforming' stamp: ''!
translateBy: factor 
	"Answer a Rectangle translated by factor, a Point or a scalar."

	^Rectangle origin: origin + factor corner: corner + factor! !

!Rectangle methodsFor: '*Fuel-Core' stamp: ''!
fuelSetOrigin: originPoint corner: cornerPoint
	origin := originPoint.
	corner := cornerPoint! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
rectanglesAt: y height: ht
	(y+ht) > self bottom ifTrue: [^ Array new].
	^ Array with: (origin x @ y corner: corner x @ (y+ht))! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
expandBy: delta 
	"Answer a Rectangle that is outset from the receiver by delta. delta is a 
	Rectangle, Point, or scalar."
	
	^ delta asMargin expandRectangle: self! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
encompass: aPoint 
	"Answer a Rectangle that contains both the receiver and aPoint."

	^ Rectangle 
		origin: (origin min: aPoint)
		corner: (corner max:  aPoint)! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
intersect: aRectangle ifNone: aBlock
	"Answer a Rectangle that is the area in which the receiver overlaps with 
	aRectangle. 
	If there's no overlap, evaluate the block instead 
	"

	| aPoint left right top bottom |
	(self intersects: aRectangle)
		ifFalse: [ ^ aBlock value ].
	aPoint := aRectangle origin.
	left := aPoint x max: origin x.
	top := aPoint y max: origin y.
	aPoint := aRectangle corner.
	right := aPoint x min: corner x.
	bottom := aPoint y min: corner y.
	^ Rectangle origin: left @ top corner: right @ bottom! !

!Rectangle methodsFor: 'transforming' stamp: ''!
scaleFrom: rect1 to: rect2
	"Produce a rectangle stretched according to the stretch from rect1 to rect2"
	^ (origin scaleFrom: rect1 to: rect2)
		corner: (corner scaleFrom: rect1 to: rect2)! !

!Rectangle methodsFor: 'truncation and roundoff' stamp: ''!
isIntegerRectangle
	"Answer true if all component of receiver are integral."

	^ origin isIntegerPoint and: [ corner isIntegerPoint ]! !

!Rectangle methodsFor: 'accessing' stamp: ''!
right
	"Answer the position of the receiver's right vertical line."

	^corner x! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
intersect: aRectangle 
	"Answer a Rectangle that is the area in which the receiver overlaps with 
	aRectangle."
	^ self intersect: aRectangle ifNone:[0@0 extent:0@0]! !

!Rectangle methodsFor: 'transforming' stamp: ''!
scaleBy: scale 
	"Answer a Rectangle scaled by scale, a Point or a scalar."

	^Rectangle origin: origin * scale corner: corner * scale! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
withWidth: width 
	"Return a copy of me with a different width"
	^ origin corner: (origin x + width) @ corner y! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
extendBy: deltaMargin 
	"Answer a Rectangle with the same origin as the receiver, but whose corner is offset by deltaMargin."

	^ deltaMargin asMargin extendRectangle: self! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
bordersOn: her along: herSide 
	((herSide = #right and: [self left = her right])
	or: [herSide = #left and: [self right = her left]])
		ifTrue:
		[^ (self top max: her top) < (self bottom min: her bottom)].
	((herSide = #bottom and: [self top = her bottom])
	or: [herSide = #top and: [self bottom = her top]])
		ifTrue:
		[^ (self left max: her left) < (self right min: her right)].
	^ false! !

!Rectangle methodsFor: 'truncation and roundoff' stamp: ''!
roundTo: grid
	"Answer a Rectangle whose origin and corner are rounded to grid x and grid y."

	^Rectangle origin: (origin roundTo: grid)
				corner: (corner roundTo: grid)! !

!Rectangle methodsFor: 'accessing' stamp: ''!
top
	"Answer the position of the receiver's top horizontal line."

	^origin y! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
withLeft: x 
	"Return a copy of me with a different left x (but not going over right side)"
	^ (x min: corner x) @ origin y corner: corner x @ corner y! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
withSideOrCorner: side setToPoint: newPoint minExtent: minExtent limit: limit
	"Return a copy with side set to newPoint"
	side = #top ifTrue: [^ self withTop: (newPoint y min: corner y - minExtent y max: limit + minExtent y)].
	side = #bottom ifTrue: [^ self withBottom: (newPoint y min: limit - minExtent y max: origin y + minExtent y)].
	side = #left ifTrue: [^ self withLeft: (newPoint x min: corner x - minExtent x max: limit + minExtent x)].
	side = #right ifTrue: [^ self withRight: (newPoint x min: limit - minExtent x max: origin x + minExtent x)].
	side = #topLeft ifTrue: [^ (newPoint min: corner - minExtent) corner: self bottomRight].
	side = #bottomRight ifTrue: [^ self topLeft corner: (newPoint max: origin + minExtent)].
	side = #bottomLeft ifTrue: [^ self topRight rectangle: ((newPoint x min: corner x - minExtent x) @ (newPoint y max: origin y + minExtent y))].
	side = #topRight ifTrue: [^ self bottomLeft rectangle: ((newPoint x max: origin x + minExtent x) @ (newPoint y min: corner y - minExtent y))].! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
adjustTo: newRect along: side 
	"Return a copy adjusted to fit a neighbor that has changed size."
	side = #left ifTrue: [^ self withRight: newRect left].
	side = #right ifTrue: [^ self withLeft: newRect right].
	side = #top ifTrue: [^ self withBottom: newRect top].
	side = #bottom ifTrue: [^ self withTop: newRect bottom].! !

!Rectangle methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	"printed form is good for storing too"
	
	aStream nextPut: $(.
	self printOn: aStream.
	aStream nextPut: $).! !

!Rectangle methodsFor: 'truncation and roundoff' stamp: ''!
expandTo: grid
	"Answer a Rectangle whose origin and corner are rounded to grid x and grid y.
	Rounding is done by upper value on origin and lower value on corner so that
	self is inside rounded rectangle."

	^Rectangle origin: (origin roundDownTo: grid)
				corner: (corner roundUpTo: grid)! !

!Rectangle methodsFor: 'truncation and roundoff' stamp: ''!
floor
	"Answer the integer rectangle to the topLeft of receiver.
	Return receiver if it is already an integerRectangle."

	self isIntegerRectangle ifTrue: [ ^ self ] .

	^ origin floor corner: corner floor! !

!Rectangle methodsFor: 'accessing' stamp: ''!
center
	"Answer the point at the center of the receiver."

	^self topLeft + self bottomRight // 2! !

!Rectangle methodsFor: 'transforming' stamp: ''!
flipBy: direction centerAt: aPoint 
	"Return a copy flipped #vertical or #horizontal, about aPoint."
	^ (origin flipBy: direction centerAt: aPoint)
		rectangle: (corner flipBy: direction centerAt: aPoint)! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
areasOutside: aRectangle 
	"Answer an Array of Rectangles comprising the parts of the receiver not 
	intersecting aRectangle."
	"Make sure the intersection is non-empty"
	
	(self intersects: aRectangle) ifFalse: [ ^ Array with: self ].
	^ Array new: 4 streamContents: [ :aStream |
		| yOrigin yCorner |
		aRectangle origin y > origin y 
			ifTrue:
				[ aStream nextPut: (origin corner: corner x @ (yOrigin := aRectangle origin y)) ]
			ifFalse: [ yOrigin := origin y ].
		aRectangle corner y < corner y 
			ifTrue: 
				[ aStream nextPut: (origin x @ (yCorner := aRectangle corner y) corner: corner) ]
			ifFalse: [ yCorner := corner y ].
		aRectangle origin x > origin x ifTrue: 
			[ aStream nextPut: (origin x @ yOrigin corner: aRectangle origin x @ yCorner) ].
		aRectangle corner x < corner x ifTrue: 
			[ aStream nextPut: (aRectangle corner x @ yOrigin corner: corner x @ yCorner) ] ]! !

!Rectangle methodsFor: 'comparing' stamp: ''!
closeTo: aRectangle precision: aPrecision
 	^ (origin closeTo: aRectangle origin precision: aPrecision) and: [
		corner closeTo: aRectangle corner precision: aPrecision ]! !

!Rectangle methodsFor: 'testing' stamp: ''!
containsRect: aRect
	"Answer whether aRect is within the receiver (OK to coincide)."

	^ aRect origin >= origin and: [aRect corner <= corner]! !

!Rectangle methodsFor: 'comparing' stamp: ''!
hash
	"Hash is reimplemented because = is implemented."

	^origin hash bitXor: corner hash! !

!Rectangle methodsFor: 'transforming' stamp: ''!
rotateBy: direction centerAt: aPoint
	"Return a copy rotated #right, #left, or #pi about aPoint"
	^ (origin rotateBy: direction centerAt: aPoint)
		rectangle: (corner rotateBy: direction centerAt: aPoint)! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
translatedToBeWithin: aRectangle
	"Answer a copy of the receiver that does not extend beyond aRectangle."

	^ self translateBy: (self amountToTranslateWithin: aRectangle)! !

!Rectangle methodsFor: '*Athens-Core' stamp: ''!
asPolygonTransformedBy: aTransform
	"answer a clock-wise oriented polygon, representing receiver,
	transformed by transform"
	
	^ {
		aTransform transform: origin.
		aTransform transformX: corner x Y: origin y.
		aTransform transform: corner.
		aTransform transformX: origin x Y: corner y.
	}! !

!Rectangle methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper
	"Since we can have subclasses of Rectangle, like CharacterBlock that adds new instVars, we cannot use the visitRectangle: for it."
	^ (self class == Rectangle) 
		ifTrue: [ aGeneralMapper visitRectangle: self ]
		ifFalse: [ super fuelAccept: aGeneralMapper   ] 
	
! !

!Rectangle methodsFor: 'transforming' stamp: ''!
quickMergePoint: aPoint
	"Answer the receiver if it encloses the given point or the expansion of the
	receiver to do so if it doesn't. "

	| useRcvr minX maxX minY maxY |
	useRcvr := true.
	minX := aPoint x < origin x ifTrue: [useRcvr := false. aPoint x] ifFalse: [origin x].
	maxX := aPoint x >= corner x ifTrue: [useRcvr := false. aPoint x + 1] ifFalse: [corner x].
	minY := aPoint y < origin y ifTrue: [useRcvr := false. aPoint y] ifFalse: [origin y].
	maxY := aPoint y >= corner y ifTrue: [useRcvr := false. aPoint y + 1] ifFalse: [corner y].
	^useRcvr
		ifTrue: [self]
		ifFalse: [minX@minY corner: maxX@maxY]! !

!Rectangle methodsFor: 'private' stamp: ''!
setPoint: pt1 point: pt2

	origin := (pt1 x min: pt2 x)@(pt1 y min: pt2 y).
	corner := (pt1 x max: pt2 x)@(pt1 y max: pt2 y).! !

!Rectangle methodsFor: '*Roassal3-Layouts' stamp: ''!
halfPerimeter
	^ self width + self height! !

!Rectangle methodsFor: 'transforming' stamp: ''!
align: aPoint1 with: aPoint2 
	"Answer a Rectangle that is a translated by aPoint2 - aPoint1."

	^self translateBy: aPoint2 - aPoint1! !

!Rectangle methodsFor: 'testing' stamp: ''!
isZero
	^origin isZero and:[corner isZero]! !

!Rectangle methodsFor: 'accessing' stamp: ''!
pointAtSideOrCorner: loc
	"Answer the point represented by the given location."
	
	^ self
		perform: (#(topLeft topCenter topRight rightCenter
					bottomRight bottomCenter bottomLeft leftCenter)
						at: (#(topLeft top topRight right
					bottomRight bottom bottomLeft left) indexOf: loc))! !

!Rectangle methodsFor: 'accessing' stamp: ''!
bottomLeft
	"Answer the point at the left edge of the bottom horizontal line of the 
	receiver."

	^origin x @ corner y! !

!Rectangle methodsFor: '*OSWindow-SDL2' stamp: ''!
asSDLRect
	
	^SDL_Rect newX: origin x rounded y: origin y rounded w: (corner x - origin x) rounded h: (corner y - origin y) rounded.! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
quickMerge: aRectangle 
	"Answer the receiver if it encloses the given rectangle or the merge of the two rectangles if it doesn't. THis method is an optimization to reduce extra rectangle creations."
	| useRcvr rOrigin rCorner minX maxX minY maxY |
	
	aRectangle ifNil: [ ^self ].
	
	useRcvr := true.
	rOrigin := aRectangle topLeft.
	rCorner := aRectangle bottomRight.
	minX := rOrigin x < origin x 
		ifTrue: 
			[ useRcvr := false.
			rOrigin x ]
		ifFalse: [ origin x ].
	maxX := rCorner x > corner x 
		ifTrue: 
			[ useRcvr := false.
			rCorner x ]
		ifFalse: [ corner x ].
	minY := rOrigin y < origin y 
		ifTrue: 
			[ useRcvr := false.
			rOrigin y ]
		ifFalse: [ origin y ].
	maxY := rCorner y > corner y 
		ifTrue: 
			[ useRcvr := false.
			rCorner y ]
		ifFalse: [ corner y ].
	useRcvr 
		ifTrue: [ ^ self ]
		ifFalse: 
			[ ^ Rectangle 
				origin: minX @ minY
				corner: maxX @ maxY ]! !

!Rectangle methodsFor: 'testing' stamp: ''!
isTall
	^ self height > self width! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
withRight: x 
	"Return a copy of me with a different right x"
	^ origin x @ origin y corner: (x max: origin x) @ corner y! !

!Rectangle methodsFor: 'accessing' stamp: ''!
right: aNumber
	^origin corner: aNumber @ corner y! !

!Rectangle methodsFor: 'accessing' stamp: ''!
bottom
	"Answer the position of the receiver's bottom horizontal line."

	^corner y! !

!Rectangle methodsFor: 'testing' stamp: ''!
intersects: aRectangle 
	"Answer whether aRectangle intersects the receiver anywhere."
	"Optimized; old code answered:
		(origin max: aRectangle origin) < (corner min: aRectangle corner)"
	| rOrigin rCorner |
	rOrigin := aRectangle origin.
	rCorner := aRectangle corner.
	rCorner x <= origin x ifTrue: [ ^ false ].
	rCorner y <= origin y ifTrue: [ ^ false ].
	rOrigin x >= corner x ifTrue: [ ^ false ].
	rOrigin y >= corner y ifTrue: [ ^ false ].
	^ true! !

!Rectangle methodsFor: 'truncation and round off' stamp: ''!
rounded
	"Answer a Rectangle whose origin and corner are rounded."

	^Rectangle origin: origin rounded corner: corner rounded! !

!Rectangle methodsFor: 'truncation and roundoff' stamp: ''!
ceiling
	"Answer the integer rectangle to the bottom right of receiver.
	Return receiver if it is already an integerRectangle."

	self isIntegerRectangle ifTrue: [ ^ self ].
	^origin ceiling corner: corner ceiling! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
allAreasOutsideList: aCollection do: aBlock
	"Enumerate aBlock with all areas of the receiver not overlapping 
	any rectangle in the given collection"
	^self allAreasOutsideList: aCollection startingAt: 1 do: aBlock! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
amountToTranslateWithin: aRectangle 
	"Answer a Point, delta, such that self + delta is forced within aRectangle.
	Keep self topLeft inside when all of self cannot be made to fit"
	| dx dy |
	dx := 0.
	dy := 0.
	self right > aRectangle right ifTrue: [ dx := aRectangle right - self right ].
	self bottom > aRectangle bottom ifTrue: [ dy := aRectangle bottom - self bottom ].
	self left + dx < aRectangle left ifTrue: [ dx := aRectangle left - self left ].
	self top + dy < aRectangle top ifTrue: [ dy := aRectangle top - self top ].
	^ dx @ dy! !

!Rectangle methodsFor: 'accessing' stamp: ''!
height
	"Answer the height of the receiver."

	^corner y - origin y! !

!Rectangle methodsFor: 'accessing' stamp: ''!
floatCenter
	"Answer the float point at the center of the receiver."
	^ self topLeft + self bottomRight / 2.0! !

!Rectangle methodsFor: 'accessing' stamp: ''!
rightCenter
	"Answer the point at the center of the receiver's right vertical line."

	^self right @ self center y! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
sideNearestTo: aPoint 
	| distToLeft distToRight distToTop distToBottom closest side |
	distToLeft := aPoint x - self left.
	distToRight := self right - aPoint x.
	distToTop := aPoint y - self top.
	distToBottom := self bottom - aPoint y.
	closest := distToLeft.
	side := #left.
	distToRight < closest ifTrue: 
		[ closest := distToRight.
		side := #right ].
	distToTop < closest ifTrue: 
		[ closest := distToTop.
		side := #top ].
	distToBottom < closest ifTrue: 
		[ closest := distToBottom.
		side := #bottom ].
	^ side
	"
 | r | r := Rectangle fromUser.
Display border: r width: 1.
[Sensor anyButtonPressed] whileFalse:
	[(r sideNearestTo: Sensor cursorPoint) , '      ' displayAt: 0@0]
"! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
withHeight: height 
	"Return a copy of me with a different height"
	^ origin corner: corner x @ (origin y + height)! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
merge: aRectangle 
	"Answer a Rectangle that contains both the receiver and aRectangle."

	^Rectangle 
		origin: (origin min: aRectangle origin)
		corner: (corner max: aRectangle corner)! !

!Rectangle methodsFor: '*Athens-Core' stamp: ''!
paintFillsUsing: aPaint on: anAthensCanvas 
	"This method is a part of rendering dispatch  Canvas->receiver->paint"
	
	^ aPaint athensFillRectangle: self on: anAthensCanvas! !

!Rectangle methodsFor: 'accessing' stamp: ''!
corner
	"Answer the point at the bottom right corner of the receiver."

	^corner! !

!Rectangle methodsFor: 'transforming' stamp: ''!
interpolateTo: end at: amountDone
	"Interpolate between the instance and end after the specified amount has been done (0 - 1)."

	^(self origin interpolateTo: end origin at: amountDone)
		corner: (self corner interpolateTo: end corner at: amountDone)! !

!Rectangle methodsFor: 'accessing' stamp: ''!
bottomCenter
	"Answer the point at the center of the bottom horizontal line of the 
	receiver."

	^self center x @ self bottom! !

!Rectangle methodsFor: 'accessing' stamp: ''!
innerCorners
	"Return an array of inner corner points,
	ie, the most extreme pixels included,
	in the order of a quadrilateral spec for WarpBlt"
	| r1 |
	r1 := self topLeft corner: self bottomRight - (1 @ 1).
	^ Array 
		with: r1 topLeft
		with: r1 bottomLeft
		with: r1 bottomRight
		with: r1 topRight! !

!Rectangle methodsFor: '*Rubric' stamp: ''!
privateSetOrigin: topLeft 
	origin := topLeft! !

!Rectangle methodsFor: 'transforming' stamp: ''!
scaledAndCenteredIn: aRect
	"Answer a new rectangle that fits into aRectangle and is centered
	but with the same aspect ratio as the receiver."
	
	^self width / aRect width > (self height / aRect height)
		ifTrue: [aRect left @ (aRect leftCenter y - (self height * (aRect width / self width) / 2))
					corner: aRect right @ (aRect rightCenter y + (self height * (aRect width / self width) / 2))]
		ifFalse: [aRect topCenter x - (self width * (aRect height / self height) / 2) @ aRect top
					corner: (aRect topCenter x + (self width * (aRect height / self height) / 2)) @ aRect bottom]! !

!Rectangle methodsFor: 'accessing' stamp: ''!
bottomRight
	"Answer the point at the right edge of the bottom horizontal line of the 
	receiver."

	^corner! !

!Rectangle methodsFor: 'accessing' stamp: ''!
area
	"Answer the receiver's area, the product of width and height."
	| w |
	(w := self width) <= 0 ifTrue: [ ^ 0 ].
	^ w * self height max: 0! !

!Rectangle methodsFor: 'comparing' stamp: ''!
closeTo: aRectangle
 	^ (origin closeTo: aRectangle origin) and: [ corner closeTo: aRectangle corner ]! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
insetBy: delta 
	"Answer a Rectangle that is inset from the receiver by delta. delta is a 
	Rectangle, Point, or scalar."
	
	^ delta asMargin insetRectangle: self! !

!Rectangle methodsFor: 'accessing' stamp: ''!
origin
	"Answer the point at the top left corner of the receiver."

	^origin! !

!Rectangle methodsFor: 'printing' stamp: ''!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	origin printOn: aStream.
	aStream nextPutAll: ' corner: '.
	corner printOn: aStream! !

!Rectangle methodsFor: 'truncation and roundoff' stamp: ''!
compressed
	"Answer a Rectangle whose origin and corner are rounded to integers.
	Rounding is done by upper value on origin and lower value on corner so that
	rounded rectangle is inside self."

	^Rectangle origin: origin ceiling corner: corner floor! !

!Rectangle methodsFor: 'converting' stamp: ''!
asMargin

	^ Margin fromRectangle: self! !

!Rectangle methodsFor: 'truncation and round off' stamp: ''!
truncateTo: grid
	"Answer a Rectangle whose origin and corner are truncated to grid x and grid y."

	^Rectangle origin: (origin truncateTo: grid)
				corner: (corner truncateTo: grid)! !

!Rectangle methodsFor: 'accessing' stamp: ''!
leftCenter
	"Answer the point at the center of the receiver's left vertical line."

	^self left @ self center y! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
allAreasOutsideList: aCollection startingAt: startIndex do: aBlock 
	"Enumerate aBlock with all areas of the receiver not overlapping 
	any rectangle in the given collection"
	| yOrigin yCorner aRectangle index rr |
	index := startIndex.

	"Find the next intersecting rectangle from aCollection"
	
	[ index <= aCollection size ifFalse: [ ^ aBlock value: self ].
	aRectangle := aCollection at: index.
	origin <= aRectangle corner and: [ aRectangle origin <= corner ] ] whileFalse: [ index := index + 1 ].

	"aRectangle is intersecting; process it"
	aRectangle origin y > origin y 
		ifTrue: 
			[ rr := origin corner: corner x @ (yOrigin := aRectangle origin y).
			rr 
				allAreasOutsideList: aCollection
				startingAt: index + 1
				do: aBlock ]
		ifFalse: [ yOrigin := origin y ].
	aRectangle corner y < corner y 
		ifTrue: 
			[ rr := origin x @ (yCorner := aRectangle corner y) corner: corner.
			rr 
				allAreasOutsideList: aCollection
				startingAt: index + 1
				do: aBlock ]
		ifFalse: [ yCorner := corner y ].
	aRectangle origin x > origin x ifTrue: 
		[ rr := origin x @ yOrigin corner: aRectangle origin x @ yCorner.
		rr 
			allAreasOutsideList: aCollection
			startingAt: index + 1
			do: aBlock ].
	aRectangle corner x < corner x ifTrue: 
		[ rr := aRectangle corner x @ yOrigin corner: corner x @ yCorner.
		rr 
			allAreasOutsideList: aCollection
			startingAt: index + 1
			do: aBlock ]! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
withSide: side setTo: value  "return a copy with side set to value"
	^ self perform: (#(withLeft: withRight: withTop: withBottom: )
							at: (#(left right top bottom) indexOf: side))
		with: value! !

!Rectangle methodsFor: 'accessing' stamp: ''!
boundingBox
	^ self! !

!Rectangle methodsFor: 'testing' stamp: ''!
isRectangle
	^true! !

!Rectangle methodsFor: 'rectangle functions' stamp: ''!
withBottom: y 
	"Return a copy of me with a different bottom y"
	^ origin x @ origin y corner: corner x @ (y max: origin y)! !

!Rectangle methodsFor: '*Roassal3-Layouts' stamp: ''!
areasOverlapingOutside: aRectangle 
	"Answer an Array of maximized Rectangles comprising (overlaped by each other) the parts of the receiver not 
	intersecting aRectangle."
	"Make sure the intersection is non-empty"
	| areas o c |
	(self intersects: aRectangle) ifFalse: [ ^ Array with: self ].
	areas := OrderedCollection new.
	o := self topLeft.
	c := self bottomRight.
	aRectangle topLeft y > o y 
		ifTrue: 
			[ areas addLast: (o corner: c x @ aRectangle topLeft y) ].
	aRectangle bottomRight y < c y 
		ifTrue: 
			[ areas addLast: (o x @ aRectangle bottomRight y corner: c) ].
	aRectangle topLeft x > o x 
		ifTrue: 
			[ areas addLast: (o corner: aRectangle topLeft x @ c y) ].
	aRectangle bottomRight x < c x 
		ifTrue: 
			[ areas addLast: (aRectangle bottomRight x @ o y corner: c) ].
	^ areas! !

!Rectangle methodsFor: 'truncation and roundoff' stamp: ''!
compressTo: grid
	"Answer a Rectangle whose origin and corner are rounded to grid x and grid y.
	Rounding is done by upper value on origin and lower value on corner so that
	rounded rectangle is inside self."

	^Rectangle origin: (origin roundUpTo: grid)
				corner: (corner roundDownTo: grid)! !

!Rectangle methodsFor: '*Rubric' stamp: ''!
privateSetCorner: bottomRight 
	corner := bottomRight! !

!Rectangle methodsFor: 'testing' stamp: ''!
hasPositiveExtent
	^ (corner x > origin x) and: [corner y > origin y]! !

!Rectangle methodsFor: '*Morphic-Base' stamp: ''!
asLayoutFrame
	"Answer an instance of LayoutFrame which uses fractions from receiver "
	
	^ LayoutFrame new
		leftFraction: self left;
		rightFraction: self right;
		topFraction: self top;
		bottomFraction: self bottom;
		yourself! !

!Rectangle methodsFor: 'transforming' stamp: ''!
centeredBeneath: aRectangle
	 "Move the receiver so that its top center point coincides with the bottom center point of aRectangle."

	^ self align: self topCenter with: aRectangle bottomCenter! !

!Rectangle methodsFor: '*Spec2-Layout' stamp: ''!
asSpLayoutFrame
	"Answer an instance of LayoutFrame which uses fractions from receiver "
	
	^ SpLayoutFrame new
		leftFraction: self left;
		rightFraction: self right;
		topFraction: self top;
		bottomFraction: self bottom;
		yourself
		! !

!Rectangle methodsFor: 'testing' stamp: ''!
containsPoint: aPoint 
	"Answer whether aPoint is within the receiver."

	^origin <= aPoint and: [aPoint < corner]! !

!Rectangle methodsFor: '*Morphic-Base' stamp: ''!
newRectFrom: newRectBlock inWorld: aWorld
	"Track the outline of a new rectangle until mouse button changes. newFrameBlock produces each new rectangle from the previous"
	| rect newRect buttonStart buttonNow  hand |

	hand := aWorld activeHand.
	
	buttonStart := buttonNow := hand anyButtonPressed.
	rect := self.

	self drawReverseFrame: rect.

	hand captureEventsWhile: [:evt |
		evt isMouse ifTrue: [
			buttonNow := evt anyButtonPressed.
			newRect := newRectBlock value: rect value: evt cursorPoint.
			newRect = rect ifFalse: 
				[self drawReverseFrame: rect.
				self drawReverseFrame: newRect.	
				rect := newRect ]. 

			 buttonNow = buttonStart
			] ifFalse: [ true ]
		].
	
	self drawReverseFrame:  rect.
	
	hand
		newMouseFocus: nil;
		showTemporaryCursor: nil.
	^ rect! !

!Rectangle methodsFor: 'accessing' stamp: ''!
aboveCenter
	"Answer the point slightly above the center of the receiver."

	^self topLeft + self bottomRight // (2@3)! !

!Rectangle class methodsFor: '*Morphic-Base' stamp: ''!
fromUser: gridPoint 

	^ self fromUser: gridPoint inWorld: self currentWorld! !

!Rectangle class methodsFor: '*Morphic-Base' stamp: ''!
fromUser
	"Answer an instance of me that is determined by having the user 
	designate the top left and bottom right corners. The gridding for user 
	selection is 1@1."

	^ self fromUser: 1 @ 1! !

!Rectangle class methodsFor: 'instance creation' stamp: ''!
center: centerPoint extent: extentPoint 
	"Answer an instance of me whose center is centerPoint asInteger  "

	^self origin: centerPoint - (extentPoint//2) extent: extentPoint! !

!Rectangle class methodsFor: 'instance creation' stamp: ''!
floatCenter: centerPoint extent: extentPoint 
	"Answer an instance of me whose center is centerPoint and width 
	by height is extentPoint."
	^self origin: centerPoint - (extentPoint/2.0) extent: extentPoint! !

!Rectangle class methodsFor: 'instance creation' stamp: ''!
merging: listOfRects 
	"A number of callers of merge: should use this method."
	| minX minY maxX maxY |
	listOfRects do: 
		[ :r | 
		minX 
			ifNil: 
				[ minX := r topLeft x.
				minY := r topLeft y.
				maxX := r bottomRight x.
				maxY := r bottomRight y ]
			ifNotNil: 
				[ minX := minX min: r topLeft x.
				minY := minY min: r topLeft y.
				maxX := maxX max: r bottomRight x.
				maxY := maxY max: r bottomRight y ] ].
	^ minX @ minY corner: maxX @ maxY! !

!Rectangle class methodsFor: '*Morphic-Base' stamp: ''!
fromUser: gridPoint inWorld: aWorld
	"Answer a Rectangle that is determined by having the user 
	designate the top left and bottom right corners. 
	The cursor reamins linked with the sensor, but
	the outline is kept gridded."
	| originRect |
	aWorld activeHand showTemporaryCursor: Cursor origin.

	originRect :=  ((aWorld activeHand cursorPoint grid: gridPoint) extent: 0 @ 0) 
					newRectFrom: [ :f :pt | (pt grid: gridPoint) extent: 0 @ 0 ]
					inWorld: aWorld.
					
	aWorld activeHand showTemporaryCursor: Cursor bottomRight.

	^  originRect
			newRectFrom: [ :f :pt | f origin corner: (pt grid: gridPoint) ]
			inWorld: aWorld! !

!Rectangle class methodsFor: '*Tool-Finder' stamp: ''!
approvedSelectorsForMethodFinder

	^ self selectors! !

!Rectangle class methodsFor: 'instance creation' stamp: ''!
left: left right: right top: top bottom: bottom 
	"Answer an instance of me whose left, right, top, and bottom coordinates 
	are determined by the arguments."

	^ self basicNew setLeft: left right: right top: top bottom: bottom! !

!Rectangle class methodsFor: 'instance creation' stamp: ''!
origin: originPoint extent: extentPoint 
	"Answer an instance of me whose top left corner is originPoint and width by height is extentPoint. Note that extentPoint should be non negative since it represents the size of the rectangle"

	
	^self basicNew 
		setPoint: originPoint 
		point: (originPoint x+ (extentPoint x max: 0)) @ (originPoint y + (extentPoint y max: 0)).! !

!Rectangle class methodsFor: 'instance creation' stamp: ''!
encompassing: listOfPoints 
	"A number of callers of encompass: should use this method."
	| topLeft bottomRight |
	topLeft := bottomRight := listOfPoints first.
	listOfPoints allButFirstDo: [ :p | 
		topLeft := topLeft min: p.
		bottomRight := bottomRight max: p ].
	^ topLeft corner: bottomRight! !

!Rectangle class methodsFor: 'instance creation' stamp: ''!
origin: originPoint corner: cornerPoint 
	"Answer an instance of me whose corners (top left and bottom right) are 
	determined by the arguments."

	^self basicNew setPoint: originPoint point: cornerPoint! !

!Rectangle class methodsFor: 'instance creation' stamp: ''!
point: pt1 point: pt2 
	"Answer an instance of me constructed from two points."

	^self basicNew setPoint: pt1 point: pt2! !

!RectangleTest commentStamp: ''!
SUnit tests for class Rectangle!
!RectangleTest methodsFor: 'tests - rectangle functions' stamp: ''!
testWithWidth
	| r |
	r := Rectangle new.
	r := 1 @ 2 corner: 5 @ 5.
	self assert: (r withWidth: 7) equals: (1 @ 2 corner: 8 @ 5).
	self assert: (r withWidth: 3) equals: (1 @ 2 corner: 4 @ 5)! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testScaleBy
	| rect |
	rect := 2 @ 2 corner: 6 @ 4.

	self assert: (rect scaleBy: 2) left equals: 4.
	self assert: (rect scaleBy: 2) right equals: 12.
	self assert: (rect scaleBy: 2) top equals: 4.
	self assert: (rect scaleBy: 2) bottom equals: 8.

	self assert: (rect scaleBy: 1 / 2) left equals: 1.
	self assert: (rect scaleBy: 1 / 2) right equals: 3.
	self assert: (rect scaleBy: 1 / 2) top equals: 1.
	self assert: (rect scaleBy: 1 / 2) bottom equals: 2.

	self assert: (rect scaleBy: 0) left equals: 0.
	self assert: (rect scaleBy: 0) right equals: 0.
	self assert: (rect scaleBy: 0) top equals: 0.
	self assert: (rect scaleBy: 0) bottom equals: 0! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testCenterEmpty
	| r1 c |
	r1 := 30 @ 10 corner: 10 @ 20.
	"does not create an empty rectangle"
	c := r1 center.
	self assert: (r1 containsPoint: c) description: 'A rectangle contain its center.'.
	self assert: (r1 topLeft distanceTo: c) equals: (r1 bottomRight distanceTo: c).
	self assert: (r1 bottomLeft distanceTo: c) equals: (r1 topRight distanceTo: c).
	self assert: (r1 topLeft distanceTo: c) equals: (r1 bottomLeft distanceTo: c).
	self assert: (r1 translateBy: -20 @ 10) center = (c translateBy: -20 @ 10) description: 'the center is translated with the rectangle'! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testTwoRectanglesWithAnAdjascentCornerDoNotIntersect
  
   | rect1 rect2 |
   rect1 := 0@0 corner: 40@40.
   rect2 := 40@40 corner: 50@50.
   self deny: (rect1 intersects: rect2);
        deny: (rect2 intersects: rect1).! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testARectangleIntersectsWithItself
	self
		assert: (rectangle1 intersects: rectangle1)! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testWithBottomDoesNotProduceInvalidRectangle
	
	| rect1 rect2 |
	rect1 := 0@10 corner: 50@60.
	
	"it is possible to adjust the bottom below the current bottom side"
	rect2 := rect1 withBottom: 100.
	self assert: rect2 bottom equals: 100.

	"it is possible to adjust the bottom above the current bottom side"
	rect2 := rect1 withBottom: 40.
	self assert: rect2 bottom equals: 40.
	
	"it is possible to adjust the bottom above the current bottom side but not above the top"
	rect2 := rect1 withBottom: -10.
	self assert: rect2 bottom equals: 10.
	self assert: rect2 height isZero! !

!RectangleTest methodsFor: 'tests - rectangle functions' stamp: ''!
testPointNearestTo

	| rectangle negativeRectangle |
	rectangle := 10 @ 10 corner: 20 @ 20.
	self assert: 10 @ 10 equals: (rectangle pointNearestTo: 9 @ 9).
	self assert: 20 @ 20 equals: (rectangle pointNearestTo: 21 @ 21).
	self assert: 10 @ 20 equals: (rectangle pointNearestTo: 9 @ 21).
	self assert: 20 @ 10 equals: (rectangle pointNearestTo: 21 @ 10).
	self assert: 10 @ 15 equals: (rectangle pointNearestTo: 11 @ 15).
	self assert: 15 @ 10 equals: (rectangle pointNearestTo: 15 @ 13).
	self assert: 20 @ 15 equals: (rectangle pointNearestTo: 17 @ 15).
	self assert: 15 @ 20 equals: (rectangle pointNearestTo: 15 @ 18).
	negativeRectangle := -10 @ -10 corner: -20 @ -20.
	self assert: -10 @ -10 equals: (negativeRectangle pointNearestTo: 0@0).! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testInsettingSmallerThanRectangleExtentShouldProduceCorrectExtent
	| rec1 rec2 |
	rec1 := 0 @ 0 extent: 100 @ 100.
	rec2 := rec1 insetBy: 40 @ 40.

	self assert: rec2 height equals: 20.
	self assert: rec2 width equals: 20! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testRotateBy
	| rect |
	rect := Rectangle
		left: 0
		right: 6
		top: 4
		bottom: 2.

	self assert: (rect rotateBy: #left centerAt: 0 @ 0) left equals: 2.
	self assert: (rect rotateBy: #left centerAt: 0 @ 0) right equals: 4.
	self assert: (rect rotateBy: #left centerAt: 0 @ 0) top equals: -6.
	self assert: (rect rotateBy: #left centerAt: 0 @ 0) bottom equals: 0.

	self assert: (rect rotateBy: #right centerAt: 0 @ 0) left equals: -4.
	self assert: (rect rotateBy: #right centerAt: 0 @ 0) right equals: -2.
	self assert: (rect rotateBy: #right centerAt: 0 @ 0) top equals: 0.
	self assert: (rect rotateBy: #right centerAt: 0 @ 0) bottom equals: 6.

	self assert: (rect rotateBy: #pi centerAt: 0 @ 0) left equals: -6.
	self assert: (rect rotateBy: #pi centerAt: 0 @ 0) right equals: 0.
	self assert: (rect rotateBy: #pi centerAt: 0 @ 0) top equals: -4.
	self assert: (rect rotateBy: #pi centerAt: 0 @ 0) bottom equals: -2! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testAreasOutside1

    | frame rects visibleArea  |
    frame := 0@0 extent: 300@300.
    rects := OrderedCollection new: 80.
    0 to: 3 do: [:i |
      0 to: 2 do: [:j |
            rects add: (i@j * 20 extent: 10@10)
    ]  ].
  
   visibleArea := Array with: frame.
   rects do: [:aRectangle |  | remnants |
      remnants := OrderedCollection new.
      visibleArea do: [:a | remnants addAll: (a areasOutside: aRectangle)].
      visibleArea := remnants.
  ].
  visibleArea := visibleArea asArray.
  self assert: (visibleArea allSatisfy: [:r | r area ~= 0]).
   1 to: visibleArea size do: [:index |
     index + 1 to: visibleArea size do: [:index2 |
        self deny: ((visibleArea at: index) intersects: (visibleArea at: index2)).
  ]  ].

  1 to: rects size do: [:index |
     1 to: visibleArea size do: [:index2 |
        self deny: ((rects at: index) intersects: (visibleArea at: index2)).
  ]  ]! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testWithLeftDoesNotProduceInvalidRectangle	

	| rect1 rect2 |
	rect1 := 0@10 corner: 50@60.
	
	"it is possible to adjust the left to the left of the current left side"
	rect2 := rect1 withLeft: -10.
	self assert: rect2 left equals: -10.

	"it is possible to adjust the left to the right of the current left side but not over the righ side!!!!!!!!"
	rect2 := rect1 withLeft: 40.
	self assert: rect2 left equals: 40.
	
	"it is possible to adjust the left to be to the right of the current left side but not over the righ side, at the maximum 
	you will a zero width rectangle!!!!!!!!"
	rect2 := rect1 withLeft: 80.
	self assert: rect2 left equals: 50.
	self assert: rect2 width isZero! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testCenterEmpty2
	| r1 c |
	r1 := 0 @ 0 corner: 0 @ 0.
	"does not create an empty rectangle"
	c := r1 center.
	self deny: (r1 containsPoint: c) description: 'An empty rectangle does not contain its center.'.
	self assert: (r1 topLeft distanceTo: c) equals: (r1 bottomRight distanceTo: c).
	self assert: (r1 bottomLeft distanceTo: c) equals: (r1 topRight distanceTo: c).
	self assert: (r1 topLeft distanceTo: c) equals: (r1 bottomLeft distanceTo: c).
	self assert: (r1 translateBy: -20 @ 10) center = (c translateBy: -20 @ 10) description: 'the center is translated with the rectangle'! !

!RectangleTest methodsFor: 'tests - accessing' stamp: ''!
testLeft
	| rect |
	rect := (0 @ 0 corner: 20 @ 20) left: 10.
	self assert: rect left equals: 10! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testMergingNestedRectanglesReturnTheContainer
	| aCollection merge |
	aCollection := OrderedCollection new.
	aCollection
		add:
			(Rectangle
				left: 1
				right: 10
				top: 1
				bottom: 10).
	aCollection
		add:
			(Rectangle
				left: 4
				right: 5
				top: 4
				bottom: 5).
	merge := Rectangle merging: aCollection.
	self assert: merge equals: aCollection first! !

!RectangleTest methodsFor: 'tests - accessing' stamp: ''!
testArea
	self assert: (0 @ 0 corner: 5 @ 5) area equals: 25.
	self assert: (2 @ 3 corner: 10 @ 8) area equals: 40.
	self assert: (5 @ 5 corner: 6 @ 6) area equals: 1.
	self assert: (-1 @ -2 corner: 2 @ 1) area equals: 9! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testCenter
	| r1 c |
	r1 := 0 @ 0 extent: 10 @ 20.
	c := r1 center.
	self assert: (r1 containsPoint: c) description: 'the center is inside the rectangle'.
	self assert: (r1 topLeft distanceTo: c) equals: (r1 bottomRight distanceTo: c).
	self assert: (r1 bottomLeft distanceTo: c) equals: (r1 topRight distanceTo: c).
	self assert: (r1 topLeft distanceTo: c) equals: (r1 bottomLeft distanceTo: c).
	self assert: (r1 translateBy: -20 @ 10) center = (c translateBy: -20 @ 10) description: 'the center is translated with the rectangle'! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testInsettingLargerThanRectangleExtentShouldNotProduceNegativeExtent
	| rec1 rec2 |
	rec1 := 0 @ 0 extent: 100 @ 100.
	rec2 := rec1 insetBy: 200 @ 200.

	self assert: rec2 height >= 0.
	self assert: rec2 width >= 0.

	rec1 := 0 @ 0 extent: 100 @ 100.
	rec2 := rec1 insetBy: 50 @ 50.
	"because insetBy: reduces from both sides"
	self assert: rec2 height equals: 0.
	self assert: rec2 width equals: 0! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testRectanglesWithSameOriginIntersect

    | rect1 rect2 |
   rect1 := 10@10 corner: 20@30.
   rect2 := rect1 corner extent: 20@40.
   self deny: (rect1 intersects: rect2).! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testTwoRectanglesWithAnAdjascentBorderDoNotIntersect
  
   | rect1 rect2 |
   rect1 := 0@0 corner: 40@40.
   rect2 := 40@0 extent:40@40.
   self deny: (rect1 intersects: rect2);
        deny: (rect2 intersects: rect1).! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testCenterEmptyBasedOnPointPoint
	| r1 c |
	r1 := Rectangle point: 30 @ 10 point: 10 @ 20.
	"does not create an empty rectangle"
	c := r1 center.
	self assert: (r1 containsPoint: c) description: 'A rectangle contain its center.'.
	self assert: (r1 topLeft distanceTo: c) equals: (r1 bottomRight distanceTo: c).
	self assert: (r1 bottomLeft distanceTo: c) equals: (r1 topRight distanceTo: c).
	self assert: (r1 topLeft distanceTo: c) equals: (r1 bottomLeft distanceTo: c).
	self assert: (r1 translateBy: -20 @ 10) center = (c translateBy: -20 @ 10) description: 'the center is translated with the rectangle'! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testFlip
	| r1 c r1Horiz r1Vert |
	r1 := 30 @ 10 corner: 10 @ 20.
	c := 5 @ 5.
	r1Horiz := r1 flipBy: #horizontal centerAt: c.
	r1Vert := r1 flipBy: #vertical centerAt: c.

	self assert: r1 area = r1Horiz area description: 'flip preserves area'.
	self assert: r1 area = r1Vert area description: 'flip preserves area'.

	self assert: r1 extent = r1Horiz extent description: 'flip preserves extent'.
	self assert: r1 extent = r1Vert extent description: 'flip preserves extent'.
	self assert: (r1 flipBy: #horizontal centerAt: r1 center) equals: r1.
	self assert: (r1 flipBy: #vertical centerAt: r1 center) equals: r1! !

!RectangleTest methodsFor: 'tests - accessing' stamp: ''!
testBottom
	| rect |
	rect := (0 @ 0 corner: 20 @ 20) bottom: 10.
	self assert: rect bottom equals: 10! !

!RectangleTest methodsFor: 'tests - transforming' stamp: ''!
testFlipByCenterAt

	| rectangle |
	
	rectangle := 10 @ 10 corner: 20 @ 20.
	self assert: (10 @ 0 corner: 20 @ 10) equals: (rectangle flipBy: #vertical centerAt: 10 @ 10).
	self assert: (0 @ 10 corner: 10 @ 20) equals: (rectangle flipBy: #horizontal centerAt: 10 @ 10)! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testFloatCenterExtent
	| r1 c |
	r1 := Rectangle 
		floatCenter: 1.3@1.3
		extent: 4.4 asPoint.
	c := r1 floatCenter.
	self
		assert: (c closeTo: 1.3@1.3);
		assert: (r1 topLeft distanceTo: c) 
			equals: (r1 bottomRight distanceTo: c);
		assert: (r1 bottomLeft distanceTo: c) 
			equals: (r1 topRight distanceTo: c);
		assert: (r1 topLeft distanceTo: c)
			equals: (r1 bottomLeft distanceTo: c);
		assert: ((r1 translateBy: -20@10) floatCenter closeTo: (c translateBy: -20@10))
			description: 'the center is translated with the rectangle'! !

!RectangleTest methodsFor: 'tests - accessing' stamp: ''!
testRight
	| rect |
	rect := (0 @ 0 corner: 20 @ 20) right: 10.
	self assert: rect right equals: 10! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testMergingTwoRectangles
	| coll merge |
	coll := OrderedCollection new.
	coll
		add:
			(Rectangle
				left: 1
				right: 1
				top: 1
				bottom: 1).
	coll
		add:
			(Rectangle
				left: 10
				right: 10
				top: 10
				bottom: 10).

	merge := Rectangle merging: coll.
	self
		assert: merge
		equals:
			(Rectangle
				left: 1
				right: 10
				top: 1
				bottom: 10)! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testAreasOutside2
    | frame rects visibleArea  |
    frame := 0@0 extent: 300@300.
    rects := OrderedCollection new: 80.
    rects add: (50@50 corner: 200 @ 200);
          add: (100@100 corner: 250@250).
  
   visibleArea := Array with: frame.
   rects do: [:rect |  | remnants |
      remnants := OrderedCollection new.
      visibleArea do: [:a | remnants addAll: (a areasOutside: rect)].
      visibleArea := remnants.
  ].
  visibleArea := visibleArea asArray.
  self assert: (visibleArea allSatisfy: [:r | r area ~= 0]).

   1 to: visibleArea size do: [:idx |
     idx + 1 to: visibleArea size do: [:idx2 |
        self deny: ((visibleArea at: idx) intersects: (visibleArea at: idx2)).
  ]  ].

  1 to: rects size do: [:idx |
     1 to: visibleArea size do: [:idx2 |
        self deny: ((rects at: idx) intersects: (visibleArea at: idx2)).
  ]  ].! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testARectangleDoesNotContainItsCorner
	self
		deny: (rectangle1 containsPoint: rectangle1 corner)! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testMergingDisjointRectangles
	| aCollection merge |
	aCollection := OrderedCollection new.
	aCollection
		add:
			(Rectangle
				left: -10
				right: 0
				top: -10
				bottom: 0).
	aCollection
		add:
			(Rectangle
				left: 0
				right: 10
				top: 0
				bottom: 10).
	merge := Rectangle merging: aCollection.
	self
		assert: merge
		equals:
			(Rectangle
				left: -10
				right: 10
				top: -10
				bottom: 10)! !

!RectangleTest methodsFor: 'tests - rectangle functions' stamp: ''!
testWithTop
	| r |
	r := Rectangle new.
	r := 0 @ 0 corner: 5 @ 5.
	self assert: (r withTop: -2) equals: (0 @ -2 corner: 5 @ 5).
	self assert: (r withTop: 3) equals: (0 @ 3 corner: 5 @ 5)! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testAnEmptyRectangleHasNoArea
	self assert: emptyRectangle area equals: 0! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testInsettingByNumberShouldWork
	| rec1 rec2 |
	rec1 := 0 @ 0 extent: 100 @ 200.
	rec2 := rec1 insetBy: 30.

	self assert: rec2 height equals: 140.
	self assert: rec2 width equals: 40.

	rec1 := 0 @ 0 extent: 100 @ 200.
	rec2 := rec1 insetBy: 50.

	self assert: rec2 height equals: 100.
	self assert: rec2 width equals: 0! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testFloatCenter 
	| r1 c |
	r1 := 0@0 extent: 11@21.
	c := r1 floatCenter.
	self assert: (r1 containsPoint: c) description: 'the center is inside the rectangle'.
	self assert: (r1 topLeft distanceTo: c) equals: (r1 bottomRight distanceTo: c).
	self assert: (r1 bottomLeft distanceTo: c) equals: (r1 topRight distanceTo: c).
	self assert: (r1 topLeft distanceTo: c) equals: (r1 bottomLeft distanceTo: c).
	self assert: (r1 translateBy: -20@10) floatCenter = (c translateBy: -20@10) description: 'the center is translated with the rectangle'! !

!RectangleTest methodsFor: 'tests - rectangle functions' stamp: ''!
testSideNearestTo
	"rectangular area of screen implies that negalive coordinates not allowed"
	| rectangle |
	rectangle := 5 @ 5 corner: 45 @ 45.
	self assert: #left equals: (rectangle sideNearestTo: 4 @ 34).
	self assert: #right equals: (rectangle sideNearestTo: 60 @ 21).
	self assert: #top equals: (rectangle sideNearestTo: 25 @ 1).
	self assert: #bottom equals: (rectangle sideNearestTo: 23 @ 65)! !

!RectangleTest methodsFor: 'tests - accessing' stamp: ''!
testTop
	| rect |
	rect := (0 @ 0 corner: 20 @ 20) top: 10.
	self assert: rect top equals: 10! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testCloseToWithPrecision

	| aOrigin aCorner bOrigin bCorner|
	aOrigin := 0.105 @ 0.1051.
	aCorner := 2.105 @ 2.1051.

	bOrigin := 0.11 @ 0.1055.
	bCorner := 2.11 @ 2.1055.

	self assert: (aOrigin x closeTo: 0.1 precision: 0.1).
	self assert: (aOrigin y closeTo: 0.1 precision: 0.1).
	self assert: (aCorner x closeTo: 2.1 precision: 0.1).
	self assert: (aCorner y closeTo: 2.1 precision: 0.1).

	self assert: (bOrigin x closeTo: 0.1 precision: 0.1).
	self assert: (bOrigin y closeTo: 0.1 precision: 0.1).
	self assert: (bCorner x closeTo: 2.1 precision: 0.1).
	self assert: (bCorner y closeTo: 2.1 precision: 0.1).
	
	self assert: ((aOrigin extent: aCorner) closeTo: (bOrigin extent: bCorner) precision: 0.1)! !

!RectangleTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	emptyRectangle := 0 @ 0 corner: 0 @ 0.
	rectangle1 := 10@10 corner:20@20! !

!RectangleTest methodsFor: 'tests - rectangle functions' stamp: ''!
testWithBottom
	| r |
	r := Rectangle new.
	r := 0 @ 0 corner: 5 @ 5.
	self assert: (r withBottom: 7) equals: (0 @ 0 corner: 5 @ 7).
	self assert: (r withBottom: 3) equals: (0 @ 0 corner: 5 @ 3).

	r := Rectangle new.
	r := -5 @ -10 corner: -2 @ -3.
	self assert: (r withBottom: -2) equals: (-5 @ -10 corner: -2 @ -2).
	self assert: (r withBottom: 5) equals: (-5 @ -10 corner: -2 @ 5)! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testMergingOneRectangleReturnsThisRectangle
	| aCollection mergingRectangle |
	aCollection := OrderedCollection new.
	aCollection add: rectangle1.
	mergingRectangle := Rectangle merging: aCollection.
	self assert: mergingRectangle equals: aCollection first! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testTranslateBy
	| rect |
	rect := 2 @ 2 corner: 6 @ 4.

	self assert: (rect translateBy: 2) left equals: 4.
	self assert: (rect translateBy: 2) right equals: 8.
	self assert: (rect translateBy: 2) top equals: 4.
	self assert: (rect translateBy: 2) bottom equals: 6.

	self assert: (rect translateBy: 2 negated) left equals: 0.
	self assert: (rect translateBy: 2 negated) right equals: 4.
	self assert: (rect translateBy: 2 negated) top equals: 0.
	self assert: (rect translateBy: 2 negated) bottom equals: 2! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testSettingLeftDoesNotProduceInvalidRectangle
  
	| rect1 rect2 |
	
	rect1 := 0@0 corner: 40@40.

	"the left side of new rectangle wants to be beyond the right side of it"
	rect2 := rect1 left: 50.
	
	self assert: rect2 left equals: 40.
	self assert: rect2 right equals: 50.! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testPointPointConstructorIsSymmetrical
	| pt1 pt2 rect1 rect2 |

	pt1:= 0@0.
	pt2 := 10@10.
    
	rect1 := Rectangle point: pt1 point: pt2.
	rect2 := Rectangle point: pt2 point: pt1.
	
	self assert: rect1 equals: rect2! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testWithTopDoesNotProduceInvalidRectangle	

	| rect1 rect2 |
	rect1 := 0@10 corner: 50@60.
	
	"it is possible to adjust the top above of the current top side"
	rect2 := rect1 withTop: -10.
	self assert: rect2 top equals: -10.

	"it is possible to adjust the top below of the current top side"
	rect2 := rect1 withTop: 40.
	self assert: rect2 top equals: 40.
	
	"it is possible to adjust the top below of the current top side but not below the bottom"
	rect2 := rect1 withTop: 70.
	self assert: rect2 top equals: 60.
	self assert: rect2 height isZero! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testInsettingByRectangleShouldNotProduceNegativeRectangle
	| rec1 rec2 |
	rec1 := 0 @ 0 extent: 100 @ 200.
	rec2 := rec1 insetBy: (1 @ 2 rectangle: 5 @ 10).

	self assert: rec2 left equals: 1.
	self assert: rec2 right equals: 95.
	self assert: rec2 top equals: 2.
	self assert: rec2 bottom equals: 190.


	rec1 := 0 @ 0 extent: 100 @ 200.
	rec2 := rec1 insetBy: (46 @ 2 rectangle: 55 @ 10).

	self assert: rec2 left equals: 46.
	self assert: rec2 right equals: 46.
	self assert: rec2 top equals: 2.
	self assert: rec2 bottom equals: 190.

	rec1 := 0 @ 0 extent: 100 @ 200.
	rec2 := rec1 insetBy: (46 @ 2 rectangle: 55 @ 10).

	self assert: rec2 left equals: 46.
	self assert: rec2 right equals: 46.
	self assert: rec2 top equals: 2.
	self assert: rec2 bottom equals: 190.

	rec1 := 0 @ 0 extent: 100 @ 200.
	rec2 := rec1 insetBy: (1 @ 102 rectangle: 5 @ 105).

	self assert: rec2 left equals: 1.
	self assert: rec2 right equals: 95.
	self assert: rec2 top equals: 102.
	self assert: rec2 bottom equals: 102! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testStoreOn
	| assoc assoc2 |
	assoc := (0 @ 0 extent: 1 @ 1) -> 0.
	assoc2 := self class compiler evaluate: assoc storeString.
	self assert: assoc key equals: assoc2 key.
	self assert: assoc value equals: assoc2 value! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testMergingOverlappingRects
	| coll merge |
	coll := OrderedCollection new.
	coll
		add:
			(Rectangle
				left: 5
				right: 10
				top: 0
				bottom: 15).
	coll
		add:
			(Rectangle
				left: 0
				right: 15
				top: 5
				bottom: 10).
	merge := Rectangle merging: coll.
	self
		assert: merge
		equals:
			(Rectangle
				left: 0
				right: 15
				top: 0
				bottom: 15)! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testMergingOverlappingRectangles
	| aCollection merge |
	aCollection := OrderedCollection new.
	aCollection
		add:
			(Rectangle
				left: 5
				right: 10
				top: 0
				bottom: 15);
		add:
			(Rectangle
				left: 0
				right: 15
				top: 5
				bottom: 10).
	merge := Rectangle merging: aCollection.
	self
		assert: merge
		equals:
			(Rectangle
				left: 0
				right: 15
				top: 0
				bottom: 15)! !

!RectangleTest methodsFor: 'tests - rectangle functions' stamp: ''!
testWithHeight
	| r |
	r := Rectangle new.
	r := 1 @ 2 corner: 5 @ 5.
	self assert: (r withHeight: 7) equals: (1 @ 2 corner: 5 @ 9).
	self assert: (r withHeight: 3) equals: (1 @ 2 corner: 5 @ 5)! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testWithRightDoesNotProduceInvalidRectangle	

	| rect1 rect2 |
	rect1 := 0@10 corner: 50@60.
	
	"it is possible to adjust the right to the right of the current right side"
	rect2 := rect1 withRight: 100.
	self assert: rect2 right equals: 100.

	"it is possible to adjust the right to the left of the current right side but not over the left side!!!!!!!!"
	rect2 := rect1 withRight: 40.
	self assert: rect2 right equals: 40.
	
	"it is possible to adjust the right to be to the left of the current right side but not over the left side itself, at the maximum 
	you will a zero width rectangle!!!!!!!!"
	rect2 := rect1 withRight: -10.
	self assert: rect2 right equals: 0.
	self assert: rect2 width isZero! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testARectangleContainsItsOrigin
	self
		assert: (rectangle1 containsPoint: rectangle1 origin)! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testCloseTo

	| aOrigin aCorner bOrigin bCorner|
	aOrigin := 0.00001000001 @ 0.00001000011.
	aCorner := 2.00001000001 @ 2.00001000011.

	bOrigin := 0.0000100000001 @ 0.0000100001001.
	bCorner := 2.0000100000001 @ 2.0000100001001.

	self assert: (aOrigin x closeTo: 0.00001).
	self assert: (aOrigin y closeTo: 0.00001).
	self assert: (aCorner x closeTo: 2.00001).
	self assert: (aCorner y closeTo: 2.00001).

	self assert: (bOrigin x closeTo: 0.00001).
	self assert: (bOrigin y closeTo: 0.00001).
	self assert: (bCorner x closeTo: 2.00001).
	self assert: (bCorner y closeTo: 2.00001).
	
	self assert: ((aOrigin extent: aCorner) closeTo: (bOrigin extent: bCorner))! !

!RectangleTest methodsFor: 'tests' stamp: ''!
testRectangleWithNegativeExtentShouldHaveZeroExtent
	self assert: (Rectangle origin: 10 @ 10 extent: -5 @ -5) extent equals: 0 @ 0.
	self assert: (Rectangle origin: 10 @ 10 extent: -5 @ -5) origin equals: 10 @ 10.
	self assert: (Rectangle origin: 10 @ 10 extent: 50 @ 60) extent equals: 50 @ 60! !

!RecursionStopper commentStamp: ''!
The RecursionStopper provides an easy way to check if we are in a recursion and execute code just once in a recursion.

RecursionStopper during:  aBlock.

executes a block just once in a recursion.

A RecursionStopper object contains a collection of active methods which are currently called from within RecrusionStopper>>#during: this means that Recursion stopper can be used multiple places without one blocking the other, but multiple stoppers cannot be nested in the same method.!
!RecursionStopper methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	activeMethods := OrderedCollection new.! !

!RecursionStopper methodsFor: 'operating' stamp: ''!
stopMethod: aMethod during: aBlock

	(activeMethods includes: aMethod) ifTrue: [ ^ self ].
	
	activeMethods add: aMethod.
	
	aBlock ensure: [ activeMethods remove: aMethod ]! !

!RecursionStopper class methodsFor: 'api' stamp: ''!
during: aBlock
	<debuggerCompleteToSender>
	self default 
		stopMethod: thisContext sender compiledCode method
		during: aBlock! !

!RecursionStopper class methodsFor: 'api' stamp: ''!
default

	^ Default ifNil: [ Default := self new ]! !

!RecursionStopperTest commentStamp: ''!
SUnit tests for class  RecursionStopper!
!RecursionStopperTest methodsFor: 'accessing' stamp: ''!
mixedMethod

	RecursionStopper during: [ 
		self assert: value equals: 0.
		value := value + 1.
		RecursionStopper during: [ 
			value := value + 1.
		].
		self assert: value equals: 1.
		self mixedMethod.
		self assert: value equals: 1.		
	].
	
	RecursionStopper during: [ 
		self assert: value equals: 1.
		^ 2
	].

	self assert: value equals: 1.
	^ value! !

!RecursionStopperTest methodsFor: 'accessing' stamp: ''!
recursion
	
	RecursionStopper during: [ self recursion ].! !

!RecursionStopperTest methodsFor: 'running' stamp: ''!
tearDown

	fork ifNotNil: [ fork terminate. fork := nil ].
	super tearDown! !

!RecursionStopperTest methodsFor: 'accessing' stamp: ''!
threadSafe

	| sema |
	
	RecursionStopper during: [ 
		self assert: fork isNil.
		sema := Semaphore new.
		
		fork := [ self threadSafe. sema signal ] fork.	
		
		sema wait.
		self assert: fork isTerminated.
			
		fork := nil.
		
	].! !

!RecursionStopperTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testThreadSafe

	self should: [ self threadSafe ] notTakeMoreThanMilliseconds: 10.
	
	self assert: fork isNil.! !

!RecursionStopperTest methodsFor: 'tests' stamp: ''!
testNoRecursion

	RecursionStopper during: [ value := value + 1 ].

	self assert: value equals: 1! !

!RecursionStopperTest methodsFor: 'tests' stamp: ''!
testWithRecursion

	self recursion! !

!RecursionStopperTest methodsFor: 'tests' stamp: ''!
testMixedMethod

	| result |

	result := self mixedMethod.
	
	self assert: result equals: 2! !

!RecursionStopperTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	value := 0! !

!RecursionStopperTest class methodsFor: 'running' stamp: ''!
defaultTimeLimit
	"Those tests are supposed to be fast. 
	But with broken RecursionStopper they will hang the image.
	Therefore this small allowed time for tests to fail quickly if they are broken"
	^100 milliSeconds! !

!ReduceTest commentStamp: ''!
SUnit tests for reducing collections!
!ReduceTest methodsFor: 'tests' stamp: ''!
testReduceCollection2Arguments
	| block |
	block := [ :a :b | a + b ].
	self collectionClasses
		do: [ :class | 
			self should: [ class new reduce: block ] raise: Error.
			self assert: ((class with: 1) reduce: block) equals: 1.
			self assert: ((class with: 1 with: 2) reduce: block) equals: 3.
			self assert: ((class with: 1 with: 2 with: 3) reduce: block) equals: 6.
			self
				assert:
					((class
						with: 1
						with: 2
						with: 3
						with: 4) reduce: block)
				equals: 10 ]! !

!ReduceTest methodsFor: 'tests' stamp: ''!
testReduceLeftSpecial
	self assert: ((1 to: 100) reduceLeft: [ :a :b | a - b ]) equals: -5048.
	self assert: ('abc' reduceLeft: [ :a :b | Array with: a with: b ]) equals: #(#($a $b) $c)! !

!ReduceTest methodsFor: 'accessing' stamp: ''!
sequenceableClasses
	^ Array with: Array with: OrderedCollection with: SortedCollection! !

!ReduceTest methodsFor: 'accessing' stamp: ''!
collectionClasses
	^ (Array with: Set with: Bag) , (self sequenceableClasses)! !

!ReduceTest methodsFor: 'tests' stamp: ''!
testReduceLeft3Arguments
	| block |
	block := [ :a :b :c | Array with: a with: b with: c ].
	self sequenceableClasses
		do: [ :class | 
			self should: [ class new reduceLeft: block ] raise: Error.
			self assert: ((class with: #a) reduceLeft: block) equals: #a.
			self should: [ (class with: #a with: #b) reduceLeft: block ] raise: Error.
			self assert: ((class with: #a with: #b with: #c) reduceLeft: block) equals: #(a b c).
			self
				should: [ (class
						with: #a
						with: #b
						with: #c
						with: #d) reduceLeft: block ]
				raise: Error.
			self
				assert:
					((class
						with: #a
						with: #b
						with: #c
						with: #d
						with: #e) reduceLeft: block)
				equals: #(#(a b c) d e) ]! !

!ReduceTest methodsFor: 'tests' stamp: ''!
testReduceRightSpecial
	self assert: ((1 to: 100) reduceRight: [ :a :b | a - b ]) equals: -50.
	self assert: ('abc' reduceRight: [ :a :b | Array with: a with: b ]) equals: #($a #($b $c))! !

!ReduceTest methodsFor: 'tests' stamp: ''!
testReduceLeft2Arguments
	| block |
	block := [ :a :b | Array with: a with: b ].
	self sequenceableClasses
		do: [ :class | 
			self should: [ class new reduceLeft: block ] raise: Error.
			self assert: ((class with: #a) reduceLeft: block) equals: #a.
			self assert: ((class with: #a with: #b) reduceLeft: block) equals: #(a b).
			self assert: ((class with: #a with: #b with: #c) reduceLeft: block) equals: #(#(a b) c).
			self
				assert:
					((class
						with: #a
						with: #b
						with: #c
						with: #d) reduceLeft: block)
				equals: #(#(#(a b) c) d).
			self
				assert:
					((class
						with: #a
						with: #b
						with: #c
						with: #d
						with: #e) reduceLeft: block)
				equals: #(#(#(#(a b) c) d) e) ]! !

!ReduceTest methodsFor: 'tests' stamp: ''!
testReduceCollection3Arguments
	| block |
	block := [ :a :b :c | a + b + c ].
	self collectionClasses
		do: [ :class | 
			self should: [ class new reduce: block ] raise: Error.
			self assert: ((class with: 1) reduce: block) equals: 1.
			self should: [ (class with: 1 with: 2) reduce: block ] raise: Error.
			self assert: ((class with: 1 with: 2 with: 3) reduce: block) equals: 6.
			self
				should: [ (class
						with: 1
						with: 2
						with: 3
						with: 4) reduce: block ]
				raise: Error ]! !

!ReduceTest methodsFor: 'tests' stamp: ''!
testReduceRight2Arguments
	| block |
	block := [ :a :b | Array with: a with: b ].
	self sequenceableClasses
		do: [ :class | 
			self should: [ class new reduceRight: block ] raise: Error.
			self assert: ((class with: #a) reduceRight: block) equals: #a.
			self assert: ((class with: #a with: #b) reduceRight: block) equals: #(a b).
			self assert: ((class with: #a with: #b with: #c) reduceRight: block) equals: #(a #(b c)).
			self
				assert:
					((class
						with: #a
						with: #b
						with: #c
						with: #d) reduceRight: block)
				equals: #(a #(b #(c d))).
			self
				assert:
					((class
						with: #a
						with: #b
						with: #c
						with: #d
						with: #e) reduceRight: block)
				equals: #(a #(b #(c #(d e)))) ]! !

!ReduceTest methodsFor: 'tests' stamp: ''!
testReduceRight3Arguments
	| block |
	block := [ :a :b :c | Array with: a with: b with: c ].
	self sequenceableClasses
		do: [ :class | 
			self should: [ class new reduceRight: block ] raise: Error.
			self assert: ((class with: #a) reduceRight: block) equals: #a.
			self should: [ (class with: #a with: #b) reduceRight: block ] raise: Error.
			self assert: ((class with: #a with: #b with: #c) reduceRight: block) equals: #(a b c).
			self
				should: [ (class
						with: #a
						with: #b
						with: #c
						with: #d) reduceRight: block ]
				raise: Error.
			self
				assert:
					((class
						with: #a
						with: #b
						with: #c
						with: #d
						with: #e) reduceRight: block)
				equals: #(a b #(c d e)) ]! !

!RefactoringAborted commentStamp: ''!
I am raised when the user cancels a refactoring.!
!RefactoringHelp commentStamp: ''!
This is a custom help book for the refactoring framework.!
!RefactoringHelp class methodsFor: 'pages' stamp: ''!
coreComponents
	^HelpTopic
		title: 'Core Components'
		contents: 
'
A brief overview of the core components.

RBScanner and RBParser
The Refactoring Framework has its own parser and scanner, creating an abstract syntax tree (AST) from the methods source code.

RBProgramNode and subclasses
These are the base and concrete subclasses for all RB-Nodes representing a syntax node class, like RBMethodNode, RBAssignmentNode, RBBlockNode et cetera.

RBParseTreeSearcher and RBParseTreeRewriter
A refactoring operation uses the tree searcher and rewriter for applying a transformation on the abstract syntax tree.
They implement a program node visitor.

RBClass, RBMetaclass, RBMethod
Class and Method meta-models representing a class or method created, removed or modified during a refactoring
operation.

RBNamespace
A namespace is an environment for resolving class and method entities by name and collects all changes resp. changed entities.

RBRefactoring and subclasses
Abstract base classes and its concrete subclasses for refactoring operations. Every basic refactoring operation is implemented as a subclass of the RBRefactoring class. A refactoring operation checks the precondition that must be fulfilled and implements the actual code transform method.

RBCondition
Instead of implementing conditions and condition checking code into every single refactoring operation, the RBCondition class implements a set
of common tests and can be created and combined to realize a composition of conditions.

RBRefactoryChange
Applying a refactoring within a namespace collects changes without applying the actual change to the system. This changes are represented
by a RBRefactoryChange, its subclass or a composition of refactory changes. 

'! !

!RefactoringHelp class methodsFor: 'accessing' stamp: ''!
bookDescription
	^ self comment! !

!RefactoringHelp class methodsFor: 'pages' stamp: ''!
about
	^HelpTopic
		title: 'About'
		contents: 
'The Refactoring Engine was originally developed by Don Roberts and John Brant for VisualWorks. It was ported to squeak and pharo with extensions by Lukas Renggli and other contributors.

One goal of this framework was to easily include the code refactoring into the standard development work flow. The refactoring operations should help to transform and restructure the source code, without to much manual intervention. And without the need to retest every single change.

Therefore some basic primitive refactoring are provided, in a way that more complex operations can be constructed by compositing the primitive ones. 

A refactoring tool should provide an environment for viewing the code, the refactoring transformation and the result. Originally a standalone tool, later the support for refactoring operations were directly integrated into the standard Smalltalk System Browser.

The Tool, or a browser with refactoring support or the whole framework is often just known as the ''Refactoring Browser''. 

That''s why all of the classes of this framework start with the prefix ''RB''.
'! !

!RefactoringHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#( about overview coreComponents RBBrowserSupportHelp RBRefactoringExamplesHelp RBRefactoringCoreHelp)! !

!RefactoringHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Refactoring Framework'! !

!RefactoringHelp class methodsFor: 'pages' stamp: ''!
overview
	^HelpTopic
		title: 'Overview'
		contents: 
'
The following pages give an overview of the refactoring engine, the collaborating classes and components.

The refactoring support in the System Browser with some explanations of the different refactoring operations.

It follows an explanation with some examples, how to manually construct and execute refactoring operations, usable for those operation that aren''t supported as operations in the System Browser or to help to include them in your own tools.

A more in-deep description of the components shows that the refactoring frameworks is not only useful for code refactoring, but it also provides a powerful general purpose search and rewrite engine. 

This search capability - search for code "patterns" - can be used to detect common program errors or just bad code style. The code structures are defined as a search patterns and build a Lint-rule set for static code analysis.
'! !

!RefactoringSettings class methodsFor: 'adding' stamp: ''!
addScope: aScope
	self scopeList add: aScope! !

!RefactoringSettings class methodsFor: 'accessing' stamp: ''!
availableScopes
	"We don't return the Current image scope"
	^ self scopeList allButFirst! !

!RefactoringSettings class methodsFor: 'adding' stamp: ''!
addScope: aScope withKey: key
	aScope label: key.
	self scopeList add: aScope! !

!RefactoringSettings class methodsFor: 'setting' stamp: ''!
setDescriptionOf: anItem with: aString
	anItem label: aString! !

!RefactoringSettings class methodsFor: 'removing' stamp: ''!
removeScopeNamed: key

	self scopeList removeAllSuchThat: 
		[ :e | e description = key and: 
			[ e description ~= 'Current image'] ]! !

!RefactoringSettings class methodsFor: 'accessing' stamp: ''!
scopeList

	^ ScopeList ifNil: 
		[ ScopeList := OrderedCollection with: 
			(ClyNavigationEnvironment currentImageScope asRBEnvironment label: 'current image') ]! !

!RefactoringSettings class methodsFor: 'accessing' stamp: ''!
scopeList: anObject

	ScopeList := anObject! !

!RefactoringSettings class methodsFor: 'accessing' stamp: ''!
scopeRefactoring

	^ ScopeRefactoring ifNil: [ ScopeRefactoring := self scopeList first ]! !

!RefactoringSettings class methodsFor: 'accessing' stamp: ''!
domainValues

	^ self scopeList collect: [ :each |
		each description asSymbol -> each	
	]! !

!RefactoringSettings class methodsFor: 'accessing' stamp: ''!
invalidNames
	^ self scopeList collect: [ :e | e label ]! !

!RefactoringSettings class methodsFor: 'accessing' stamp: ''!
scopeRefactoring: anObject

	ScopeRefactoring := anObject! !

!RefactoringSettings class methodsFor: 'accessing' stamp: ''!
refactoringSettingsOn: aBuilder

	<systemsettings>
	(aBuilder group: #refactoring)
		label: 'Refactoring Engine';
		description:
			'All refactoring related settings';
		noOrdering;
		with: [ 
			(aBuilder pickOne: #scopeRefactoring)
				order: 0;
				target: self;
				description: 'Selection new default scope for refactorings';
				label: 'Default scope';
				default: self scopeList first;
				domainValues: self domainValues.
			(aBuilder setting: #undoSize)
				target: RBRefactoryChangeManager;
				default: 20;
				label: 'Undo size';
				parentName: #refactoring ]! !

!ReferenceFinder commentStamp: ''!
Finds reference paths between objects to help find memory leaks. It finds the shortest paths between the objects. 

If you want to find a path between the "Smalltalk" global dictionary and some instance of a class, you can use the findPathToInstanceOf: method. For example, "ReferenceFinder findPathToInstanceOf: WriteStream" will find a reference path between Smalltalk and an instance of WriteStream.!
!ReferenceFinder methodsFor: 'private' stamp: ''!
_objectSize: anObject
	"Answer the number of indexable fields in the argument anObject.
	 This value is the same as the largest legal subscript."

	^anObject basicSize! !

!ReferenceFinder methodsFor: 'accessing' stamp: ''!
findPath: aBlock 
	foundBlock := [:path | ^path].
	testBlock := aBlock.
	self find.
	^nil! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
addBacklinkLevel
	backlinks add: self identityDictionaryClass new! !

!ReferenceFinder methodsFor: 'initialization' stamp: ''!
initialize
	self startFrom: Smalltalk! !

!ReferenceFinder methodsFor: 'accessing' stamp: ''!
findAllPaths: aBlock 
	| paths |
	paths := OrderedCollection new.
	foundBlock := [:path | paths add: path].
	testBlock := aBlock.
	self find.
	^paths! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
processLinkTo: newObject from: anObject 
	newObject class instSize + newObject basicSize = 0 
		ifTrue: 
			[^(testBlock value: newObject) 
				ifTrue: 
					[(self computePathFor: anObject)
						add: newObject;
						yourself]
				ifFalse: [nil]].
	(self hasSearched: newObject) 
		ifFalse: 
			[(testBlock value: newObject) 
				ifTrue: 
					[^(self computePathFor: anObject)
						add: newObject;
						yourself].
			objectsLeft add: newObject.
			self addBacklinkFrom: newObject to: anObject].
	^nil! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
searchIndicesIn: anObject
	| class |
	class := self _objectClass: anObject.
	class isBits ifTrue: [^nil].
	class isWeak ifTrue: [^nil].
	1 to: (self _objectSize: anObject) do:
		[:i | | path |
		path := self processLinkTo: (self _object: anObject at: i) from: anObject.
		path notNil ifTrue: [^path]].
	^nil! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
backlinkFor: anObject 
	| toObject |
	backlinks do: 
			[:each | 
			toObject := each at: anObject ifAbsent: [nil].
			toObject notNil ifTrue: [^toObject]].
	^nil! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
identityDictionaryClass
	^IdentityDictionary! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
searchVariablesIn: anObject
	| class |
	class := self _objectClass: anObject.
	1 to: class instSize do:
		[:i | | path |
		path := self processLinkTo: (self _object: anObject instVarAt: i) from: anObject.
		path notNil ifTrue: [^path]].
	^nil! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
_objectClass: anObject
	"Answer the object which is the argument's class."

	^anObject class! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
find
	self searchForObject! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
printToDoNotice
	self
		crTrace:
			'Level ' , backlinks size printString , ' with '
				, objectsLeft size printString , ' objects to search'! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
addBacklinkFrom: newObject to: anObject 
	backlinks last at: newObject put: anObject! !

!ReferenceFinder methodsFor: 'initialization' stamp: ''!
startFrom: anObject 
	backlinks := OrderedCollection new.
	self addBacklinkLevel.
	objectsLeft := OrderedCollection with: anObject.
	backlinks last at: anObject put: nil! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
_object: anObject at: anInteger
	"Answer the value of an indexable field in anObject. Fail if the
	 argument anInteger is not an Integer or is out of bounds."

	^anObject basicAt: anInteger! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
hasSearched: newObject 
	^backlinks anySatisfy: [:each | each includesKey: newObject]! !

!ReferenceFinder methodsFor: 'accessing' stamp: ''!
ignore: anObject 
	self addBacklinkFrom: anObject to: anObject! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
_object: anObject instVarAt: anInteger
	"Answer with a fixed variable in anObject.  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."

	^anObject instVarAt: anInteger! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
computePathFor: anObject 
	| path object |
	path := OrderedCollection new.
	object := anObject.
	[object isNil] whileFalse: 
			[path add: object.
			object := self backlinkFor: object].
	^path reverse! !

!ReferenceFinder methodsFor: 'private' stamp: ''!
searchForObject
	
	[| objects |
	self printToDoNotice.
	objects := objectsLeft.
	objectsLeft := OrderedCollection new.
	self addBacklinkLevel.
	objects do: 
			[:each | 
			| path |
			(path := self searchVariablesIn: each) notNil 
				ifTrue: [foundBlock value: path].
			(path := self searchIndicesIn: each) notNil 
				ifTrue: [foundBlock value: path]].
	objectsLeft isEmpty] 
			whileFalse! !

!ReferenceFinder class methodsFor: 'accessing' stamp: ''!
findAllPathsToInstanceOf: aBehavior from: fromObject 
	"self findAllPathsToInstanceOf: RefactoringBrowser from: ScheduledControllers"

	^(self new)
		startFrom: fromObject;
		findAllPaths: [:each | each class == aBehavior]! !

!ReferenceFinder class methodsFor: 'accessing' stamp: ''!
findPathTo: anObject from: fromObject 
	"self findPathTo: RefactoringManager instance from: Object"

	^(self new)
		startFrom: fromObject;
		findPath: [:each | each == anObject]! !

!ReferenceFinder class methodsFor: 'accessing' stamp: ''!
findAllPathsTo: anObject 
	"self findAllPathsTo: (Object compiledMethodAt: #printString)"

	^self findAllPathsTo: anObject from: Smalltalk! !

!ReferenceFinder class methodsFor: 'accessing' stamp: ''!
findAllPathsToInstanceOf: aBehavior 
	"self findAllPathsToInstanceOf: RefactoringBrowser"

	^self findAllPathsToInstanceOf: aBehavior from: Smalltalk! !

!ReferenceFinder class methodsFor: 'accessing' stamp: ''!
findPathTo: anObject 
	^self findPathTo: anObject from: Smalltalk! !

!ReferenceFinder class methodsFor: 'accessing' stamp: ''!
findAllPathsTo: anObject from: fromObject 
	"self findAllPathsTo: (Object compiledMethodAt: #printString) from: Object"

	^(self new)
		startFrom: fromObject;
		findAllPaths: [:each | each == anObject]! !

!ReferenceFinder class methodsFor: 'accessing' stamp: ''!
findPathToInstanceOf: aBehavior from: fromObject 
	"self findPathToInstanceOf: RefactoringManager from: Object"

	^(self new)
		startFrom: fromObject;
		findPath: [:each | each class == aBehavior]! !

!ReferenceFinder class methodsFor: 'accessing' stamp: ''!
findPathToInstanceOf: aBehavior 
	^self findPathToInstanceOf: aBehavior from: Smalltalk! !

!ReferencedClassesTestClass methodsFor: 'methods' stamp: ''!
methodReferencingInBlock
	^ [ OrderedCollection ]! !

!ReferencedClassesTestClass methodsFor: 'methods' stamp: ''!
methodReferencingInNestedBlock
	^ [[[ Array ]]]! !

!ReferencedClassesTestClass methodsFor: 'methods' stamp: ''!
methodReferencingDirectly 
	^ Object! !

!ReflectiveMethod commentStamp: ''!
I am a method, but not a compiled method storing bytecode, but a high-level model of a method referencing the AST.

to be compatible to CompiledMethod, I forward sends to a compiled method of myself.

When I am installed in a class, #run:with:in: will compile a new compiledMethod and install it. This compiledMethod has a reference to me. We form a "twin" were we reference each other and either can be installed.

call #invalidate to force the installation of the ReflectiveMethod, and therefore code generation on the next execution.!
!ReflectiveMethod methodsFor: 'spotter' stamp: ''!
spotterSelectFor: aStep
	self compiledMethod spotterSelectFor: aStep! !

!ReflectiveMethod methodsFor: 'forwarding' stamp: ''!
doesNotUnderstand: aMessage
	^aMessage sendTo: compiledMethod
! !

!ReflectiveMethod methodsFor: 'forwarding' stamp: ''!
flushCache
	"See MethodDictionary class comment."
	<primitive: 116>! !

!ReflectiveMethod methodsFor: 'inspector extensions' stamp: ''!
gtInspectorPragmasIn: composite
	<gtInspectorPresentationOrder: 30> 
	self compiledMethod gtInspectorPragmasIn: composite! !

!ReflectiveMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterMethodClassFor: aStep
	<stSpotterOrder: 50>
	self compiledMethod spotterMethodClassFor: aStep! !

!ReflectiveMethod methodsFor: 'spotter' stamp: ''!
spotterPreviewIn: aComposite
	<spotterPreview: 10>
	self compiledMethod spotterPreviewIn: aComposite! !

!ReflectiveMethod methodsFor: 'testing' stamp: ''!
hasMetaLinks
	^self linkCount > 0.! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
removeLink: aMetaLink
	(aMetaLink optionCompileOnLinkInstallation or: [ compiledMethod isRealPrimitive ])
		ifTrue: [ self compileAndInstallCompiledMethod ]
		ifFalse: [ compiledMethod invalidate ].
	self decreaseLinkCount.
	self linkCount = 0 ifTrue: [ self destroyTwin ]! !

!ReflectiveMethod methodsFor: 'evaluation' stamp: ''!
generatePrimitiveWrapper
	| wrappedMethod send wrapperMethod assignmentNode |
	OCASTSemanticCleaner clean: ast.
	ast compilationContext 
		semanticAnalyzerClass: RFSemanticAnalyzer;
		astTranslatorClass: RFASTTranslator.
	ast doSemanticAnalysis. "force semantic analysis"
	wrappedMethod := ast generate: compiledMethod trailer.
	
	send := RBMessageNode
		receiver: RBVariableNode selfNode
		selector:  #rFwithArgs:executeMethod:
		arguments: {RBArrayNode statements: ast arguments . (RBLiteralNode value: wrappedMethod)}.
	
	assignmentNode := RBAssignmentNode 
		variable: (RBVariableNode named: #RFReifyValueVar)
		value: send.
		
	wrapperMethod := RBMethodNode
		selector: ast selector
		arguments: ast arguments 
		body: assignmentNode asSequenceNode.
		
	wrapperMethod methodClass: ast methodClass.
	wrapperMethod propertyAt: #wrappedPrimitive put: true.
	ast hasMetalink ifTrue: [wrapperMethod propertyAt: #links put: (ast propertyAt: #links)].
	ast := wrapperMethod.! !

!ReflectiveMethod methodsFor: 'printing' stamp: ''!
printOn: aStream 
	"Overrides method inherited from the byte arrayed collection."

	aStream 
		print: ast methodClass; 
		nextPutAll: '>>'; 
		store: self selector; 
		nextPutAll: ' (ReflectiveMethod)'.! !

!ReflectiveMethod methodsFor: '*Calypso-SystemPlugins-Reflectivity-Queries' stamp: ''!
calypsoEnvironmentType
	^ClyMethod! !

!ReflectiveMethod methodsFor: 'accessing' stamp: ''!
linkCount: aNumber
	linkCount := aNumber! !

!ReflectiveMethod methodsFor: 'spotter' stamp: ''!
spotterItemsFor: aStep
	"do nothing for compiled method"! !

!ReflectiveMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForBytecodesFor: aStep
	<stSpotterOrder: 15>
	compiledMethod spotterForBytecodesFor: aStep! !

!ReflectiveMethod methodsFor: 'accessing' stamp: ''!
reflectiveMethod
	^self! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
installMethod: aMethod
	"add to method dictionary"
	ast methodClass methodDict at: aMethod selector put: aMethod! !

!ReflectiveMethod methodsFor: 'accessing' stamp: ''!
ast
	^ast! !

!ReflectiveMethod methodsFor: 'accessing' stamp: ''!
compiledMethod: aCompiledMethod

	compiledMethod := aCompiledMethod.
	ast := compiledMethod ast! !

!ReflectiveMethod methodsFor: 'inspector extensions' stamp: ''!
gtInspectorSourceIn: composite
	<gtInspectorPresentationOrder: 30> 
	self compiledMethod gtInspectorSourceIn: composite! !

!ReflectiveMethod methodsFor: 'spotter' stamp: ''!
spotterActDefault
	^ self compiledMethod spotterActDefault! !

!ReflectiveMethod methodsFor: 'forwarding' stamp: ''!
selector 
	^compiledMethod selector! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
destroyTwin
	(ast hasProperty: #wrappedPrimitive) ifTrue: [  ast :=  compiledMethod parseTree].
	self recompileAST.
	self installCompiledMethod.
	compiledMethod reflectiveMethod: nil.
	SystemAnnouncer uniqueInstance unsubscribe: self! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
metaLinkOptions
	^{
	#invalidate -> #( + optionCompileOnLinkInstallation).
	#increaseLinkCount -> #( + optionCompileOnLinkInstallation).
	#linkCount: -> #( + optionCompileOnLinkInstallation).
	#methodClass: -> #( + optionCompileOnLinkInstallation).
	#compiledMethod: -> #( + optionCompileOnLinkInstallation).
	#ast -> #( + optionCompileOnLinkInstallation).
	#installCompiledMethod -> #( + optionCompileOnLinkInstallation).
	#installReflectiveMethod -> #( + optionCompileOnLinkInstallation).
	#installMethod:-> #( + optionCompileOnLinkInstallation).
	#installLink: -> #( + optionCompileOnLinkInstallation).
	#removeLink: -> #( + optionCompileOnLinkInstallation).
	#selector: -> #( + optionCompileOnLinkInstallation).
	#run:with:in: -> #( + optionCompileOnLinkInstallation).
	#compiledMethod -> #( + optionCompileOnLinkInstallation).
	#reflectiveMethod -> #( + optionCompileOnLinkInstallation).
	#decreaseLinkCount -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
installLink: aMetaLink
	self increaseLinkCount.
	(self ast hasOption: #optionCompileOnLinkInstallation for: aMetaLink) 
		ifTrue: [ self compileAndInstallCompiledMethod ]! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
installReflectiveMethod
	self installMethod: self! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
increaseLinkCount
	linkCount := self linkCount + 1.! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
decreaseLinkCount
	linkCount := linkCount - 1.! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
installCompiledMethod
	self installMethod: compiledMethod.
	ASTCache default at: compiledMethod put: ast.! !

!ReflectiveMethod methodsFor: 'forwarding' stamp: ''!
methodClass: aClass
	^compiledMethod methodClass: aClass! !

!ReflectiveMethod methodsFor: 'evaluation' stamp: ''!
recompileAST
 
	OCASTSemanticCleaner clean: ast.
	ast compilationContext 
		semanticAnalyzerClass: RFSemanticAnalyzer;
		astTranslatorClass: RFASTTranslator.
	ast doSemanticAnalysis. "force semantic analysis"
	compiledMethod := ast generate: compiledMethod trailer.
	ast compilationContext compiledMethod: compiledMethod.
	compiledMethod reflectiveMethod: self.! !

!ReflectiveMethod methodsFor: 'evaluation' stamp: ''!
run: aSelector with: anArray in: aReceiver	
	"we install the old one as the compiler might need it"
	self installCompiledMethod.
	self compileAndInstallCompiledMethod.
	^aReceiver rFwithArgs: anArray executeMethod: compiledMethod! !

!ReflectiveMethod methodsFor: 'forwarding' stamp: ''!
selector: aSymbol
	^compiledMethod selector: aSymbol! !

!ReflectiveMethod methodsFor: 'evaluation' stamp: ''!
compileAndInstallCompiledMethod
	self wrapperNeeded ifTrue: [ self generatePrimitiveWrapper ].
	self recompileAST.
	self installCompiledMethod. ! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
invalidate
	"nop: I am already installed"! !

!ReflectiveMethod methodsFor: 'accessing' stamp: ''!
linkCount
	^linkCount ifNil: [ linkCount := 0 ]! !

!ReflectiveMethod methodsFor: 'evaluation' stamp: ''!
wrapperNeeded
	ast hasMetalink ifFalse: [ ^false ].
	compiledMethod isRealPrimitive ifTrue: [ ^true ].
	ast hasMetalinkAfter ifTrue: [ ^true ].
	^false.! !

!ReflectiveMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForImplementorsFor: aStep
	<stSpotterOrder: 10>
	self compiledMethod spotterForImplementorsFor: aStep! !

!ReflectiveMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForMessagesFor: aStep
	<stSpotterOrder: 12>
	self compiledMethod spotterForMessagesFor: aStep! !

!ReflectiveMethod methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForSendersFor: aStep
	<stSpotterOrder: 11>
	self compiledMethod spotterForSendersFor: aStep! !

!ReflectiveMethod methodsFor: 'accessing' stamp: ''!
compiledMethod
	^compiledMethod! !

!ReflectiveMethod methodsFor: 'inspector extensions' stamp: ''!
gtInspectorIrIn: composite
	<gtInspectorPresentationOrder: 35> 
	self compiledMethod gtInspectorIrIn: composite! !

!ReflectiveMethod methodsFor: 'invalidate' stamp: ''!
createTwin
	"do nothing"! !

!ReflectiveMethod methodsFor: 'inspector extensions' stamp: ''!
gtInspectorASTIn: composite
	<gtInspectorPresentationOrder: 35> 
	self compiledMethod gtInspectorASTIn: composite! !

!ReflectiveMethod class methodsFor: 'instance creation' stamp: ''!
on: aCompiledMethod 
	^self new
		compiledMethod: aCompiledMethod
! !

!ReflectiveMethodTest methodsFor: 'tests - creation' stamp: ''!
testCreateReflectiveMethod
	| compiledMethod reflectiveMethod |
	compiledMethod := ReflectivityExamples >> #exampleMethod.
	reflectiveMethod := ReflectiveMethod on: compiledMethod.
	self assert: reflectiveMethod class equals: ReflectiveMethod! !

!ReflectiveMethodTest methodsFor: 'tests - variables' stamp: ''!
testSetLinkOnInstanceVariableAndUninstall
	| ivar link |
	selector := #exampleIvarRead.
	link := MetaLink new.
	ivar := ReflectivityExamples slotNamed: #ivar.
	ivar link: link.
	self assert: (ivar links includes: link).
	self assert: (ReflectivityExamples >> #exampleIvarRead) class equals: ReflectiveMethod.
	self assert: (ReflectivityExamples >> #exampleIvarRead) linkCount equals: 1.
	link uninstall.
	self assert: (ReflectivityExamples >> #exampleIvarRead) class equals: CompiledMethod.
	self assertEmpty: ivar links! !

!ReflectiveMethodTest methodsFor: 'tests - links' stamp: ''!
testSetLinkOnPrimitive
	| methodNode link |
	selector := #examplePrimitiveMethod.
	link := MetaLink new.
	methodNode := (ReflectivityExamples>>#examplePrimitiveMethod) ast.
	self assert: (ReflectivityExamples>>#examplePrimitiveMethod) isRealPrimitive.
	methodNode link: link.
	self assert: (methodNode links includes: link).
	self assert: (ReflectivityExamples>>#examplePrimitiveMethod) class equals: CompiledMethod.
	self deny: (ReflectivityExamples>>#examplePrimitiveMethod) isRealPrimitive.
	methodNode removeLink: link.
	(ReflectivityExamples>>#examplePrimitiveMethod) destroyTwin.
	self assert: (ReflectivityExamples>>#examplePrimitiveMethod) class equals: CompiledMethod.
	self assert: (ReflectivityExamples>>#examplePrimitiveMethod) isRealPrimitive.
	self assert: (ReflectivityExamples>>#examplePrimitiveMethod) reflectiveMethod isNil.
	! !

!ReflectiveMethodTest methodsFor: 'running' stamp: ''!
tearDown
	selector ifNotNil: [  
		ReflectivityExamples recompile: selector].
	super tearDown ! !

!ReflectiveMethodTest methodsFor: 'tests - creation' stamp: ''!
testInvalidateNoJit
	(ReflectivityExamples class >> #exampleMethodWithMetaLinkOptionsViaClass) createTwin.
	(ReflectivityExamples class >> #exampleMethodWithMetaLinkOptionsViaClass) invalidate.
	self assert: (ReflectivityExamples class >> #exampleMethodWithMetaLinkOptionsViaClass) class equals: CompiledMethod.
	self assert: ReflectivityExamples exampleMethodWithMetaLinkOptionsViaClass equals: 5.
	self assert: (ReflectivityExamples class >> #exampleMethodWithMetaLinkOptionsViaClass) class equals: CompiledMethod.
	ReflectivityExamples class >> #exampleMethodWithMetaLinkOptionsViaClass reflectiveMethod: nil.
	ReflectivityExamples class recompile: #exampleMethodWithMetaLinkOptionsViaClass! !

!ReflectiveMethodTest methodsFor: 'tests - creation' stamp: ''!
testInvalidate
	selector := #exampleMethod.
	(ReflectivityExamples >> #exampleMethod) createTwin.
	(ReflectivityExamples >> #exampleMethod) invalidate.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod.
	ReflectivityExamples >> #exampleMethod reflectiveMethod: nil! !

!ReflectiveMethodTest methodsFor: 'tests - creation' stamp: ''!
testInvalidateWithLinkCount
	selector := #exampleMethod.
	(ReflectivityExamples >> #exampleMethod) createTwin.
	(ReflectivityExamples >> #exampleMethod) invalidate.
	ReflectivityExamples >> #exampleMethod linkCount: 1.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleMethod) reflectiveMethod isNil.
	ReflectivityExamples >> #exampleMethod reflectiveMethod: nil! !

!ReflectiveMethodTest methodsFor: 'tests - links' stamp: ''!
testSetLink
	| sendNode link |
	selector := #exampleMethod.
	link := MetaLink new.
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	sendNode link: link.
	self assert: (sendNode hasMetalink: link).
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	sendNode removeLink: link.
	(ReflectivityExamples >> #exampleMethod) destroyTwin.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod.
	self assert: (ReflectivityExamples >> #exampleMethod) reflectiveMethod isNil! !

!ReflectiveMethodTest methodsFor: 'tests - links' stamp: ''!
testSetLinkOnDynamicArrayArgument
	
 	| link |
 	link := MetaLink new
 		        metaObject: #node;
 		        selector: #tagExecuted;
 		        yourself.
 	(ReflectivityExamples >> #exampleDynamicArrayArgument)
 		compiledMethod recompile.
 	ReflectivityExamples new exampleDynamicArrayArgument. 
 	(ReflectivityExamples >> #exampleDynamicArrayArgument) ast 
 		nodesDo: [ :n | 
 			n removeProperty: #tagExecuted ifAbsent: [  ].
 			n isDynamicArray ifTrue: [ 
 				n
 					propertyAt: #tagExecuted put: false;
 					link: link ] ].
 	ReflectivityExamples new exampleDynamicArrayArgument.
 	link uninstall.
 	(ReflectivityExamples >> #exampleDynamicArrayArgument) ast 
 		nodesDo: [ :n | 
 			n isDynamicArray ifTrue: [ 
 				self assert: (n propertyAt: #tagExecuted) ]]! !

!ReflectiveMethodTest methodsFor: 'tests - variables' stamp: ''!
testSetLinkOnGlobalVariable
	| globalVar link |
	selector := #exampleGlobalRead.
	link := MetaLink new.
	globalVar := (testingEnvironment at: #GlobalForTesting) binding.
	globalVar link: link. 
	self assert: (globalVar links includes: link).
	self assert: (ReflectivityExamples >> #exampleGlobalRead) class equals: ReflectiveMethod.
	link uninstall.
	globalVar removeProperty: #links.
	! !

!ReflectiveMethodTest methodsFor: 'tests - variables' stamp: ''!
testSetLinkOnClassVariable
	| classVar link |
	selector := #exampleClassVarRead.
	link := MetaLink new.
	classVar := (ReflectivityExamples classVariableNamed: #ClassVar).
	classVar link: link.

	self assert: (classVar links includes: link).
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	classVar removeProperty: #links.! !

!ReflectiveMethodTest methodsFor: 'tests - variables' stamp: ''!
testSetLinkOnGlobalVariableAndUninstall
	| global link |
	selector := #exampleGlobalRead.
	link := MetaLink new.
	global := (testingEnvironment at: #GlobalForTesting) binding.
	global link: link.
	self assert: (global links includes: link). 
	self assert: (ReflectivityExamples >> #exampleGlobalRead) class equals: ReflectiveMethod.
	self assert: (ReflectivityExamples >> #exampleGlobalRead) linkCount equals: 1.
	link uninstall.
	self assert: (ReflectivityExamples >> #exampleGlobalRead) class equals: CompiledMethod.
	global removeProperty: #links.

! !

!ReflectiveMethodTest methodsFor: 'tests - links' stamp: ''!
testSetLinkWithPragmaOptionsPerClass
	| sendNode link |
	link := MetaLink new.
	sendNode := (ReflectivityExamples class >> #exampleMethodWithMetaLinkOptionsViaClass) ast body statements first value.
	sendNode link: link.
	self assert: (sendNode links includes: link).
	self assert: (ReflectivityExamples class >> #exampleMethodWithMetaLinkOptionsViaClass) class equals: CompiledMethod.
	sendNode removeLink: link.
	(ReflectivityExamples class >> #exampleMethodWithMetaLinkOptionsViaClass) destroyTwin.
	self assert: (ReflectivityExamples class >> #exampleMethodWithMetaLinkOptionsViaClass) class equals: CompiledMethod.
	self assert: (ReflectivityExamples class >> #exampleMethodWithMetaLinkOptionsViaClass) reflectiveMethod isNil.
	ReflectivityExamples class recompile: #exampleMethodWithMetaLinkOptionsViaClass ! !

!ReflectiveMethodTest methodsFor: 'tests - links' stamp: ''!
testSetLinkWithPragmaOptions
	| sendNode link |
	selector := #exampleMethodWithMetaLinkOptions.
	link := MetaLink new.
	sendNode := (ReflectivityExamples>>#exampleMethodWithMetaLinkOptions) ast body statements first value.
	sendNode link: link.
	self assert: (sendNode links includes: link).
	self assert: (ReflectivityExamples>>#exampleMethodWithMetaLinkOptions) class equals: CompiledMethod.
	sendNode removeLink: link.
	(ReflectivityExamples>>#exampleMethodWithMetaLinkOptions) destroyTwin.
	self assert: (ReflectivityExamples>>#exampleMethodWithMetaLinkOptions) class equals: CompiledMethod.
	self assert: (ReflectivityExamples>>#exampleMethodWithMetaLinkOptions) reflectiveMethod isNil.
	! !

!ReflectiveMethodTest methodsFor: 'tests - links' stamp: ''!
testSetLinkInPrimitive
	| sendNode link |
	selector := #examplePrimitiveMethod.
	link := MetaLink new.
	sendNode := (ReflectivityExamples >> #examplePrimitiveMethod) ast body statements first value.
	sendNode link: link.
	self assert: (sendNode links includes: link).
	self assert: (ReflectivityExamples >> #examplePrimitiveMethod) class equals: CompiledMethod.
	sendNode removeLink: link.
	(ReflectivityExamples >> #examplePrimitiveMethod) destroyTwin.
	self assert: (ReflectivityExamples >> #examplePrimitiveMethod) class equals: CompiledMethod.
	self assert: (ReflectivityExamples >> #examplePrimitiveMethod) reflectiveMethod isNil.
	(ReflectivityExamples >> #examplePrimitiveMethod) recompile! !

!ReflectiveMethodTest methodsFor: 'tests - variables' stamp: ''!
testSetLinkOnClassVariableAndUninstall
	| classVar link |
	selector := #exampleClassVarRead.
	link := MetaLink new.
	classVar := (ReflectivityExamples classVariableNamed: #ClassVar).
	classVar link: link.

	self assert: (classVar links includes: link).
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) linkCount equals: 1.
	
	link uninstall.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: CompiledMethod.
! !

!ReflectiveMethodTest methodsFor: 'tests - variables' stamp: ''!
testSetLinkOnInstanceVariable
	| ivar link |
	selector := #exampleIvarRead.
	link := MetaLink new.
	ivar := ReflectivityExamples slotNamed: #ivar.
	ivar link: link.
	self assert: (ivar links includes: link).
	self assert: (ReflectivityExamples >> #exampleIvarRead) class equals: ReflectiveMethod.
	link uninstall.! !

!ReflectiveMethodTest methodsFor: 'tests - creation' stamp: ''!
testCreateReflectiveMethodAndInvalidate
	| compiledMethod reflectiveMethod |
	selector := #exampleMethod.
	compiledMethod := ReflectivityExamples >> #exampleMethod.
	reflectiveMethod := ReflectiveMethod on: compiledMethod.
	self assert: reflectiveMethod class equals: ReflectiveMethod.
	compiledMethod reflectiveMethod: reflectiveMethod.
	self assert: compiledMethod reflectiveMethod equals: reflectiveMethod.
	compiledMethod invalidate.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod.
	ReflectivityExamples >> #exampleMethod reflectiveMethod: nil! !

!ReflectiveMethodTest methodsFor: 'tests - links' stamp: ''!
testLinkCountTwoLinks
	| sendNode link1 link2 |
	selector := #exampleMethod.
	link1 := MetaLink new.
	link2 := MetaLink new.
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	sendNode link: link1.
	self assert: (ReflectivityExamples >> #exampleMethod) linkCount equals: 1.
	sendNode link: link2.
	self assert: (ReflectivityExamples >> #exampleMethod) linkCount equals: 2.
	sendNode removeLink: link1.
	self assert: (ReflectivityExamples >> #exampleMethod) linkCount equals: 1.
	sendNode removeLink: link2.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod.
	self assert: (ReflectivityExamples >> #exampleMethod) reflectiveMethod isNil! !

!ReflectivityCodeMorph commentStamp: ''!
I'm a morph that shows the source codes of a compiled method !
!ReflectivityCodeMorph methodsFor: 'accessing' stamp: ''!
addSourceCode: aCompiledMethod
	|editor|
	
	self compiledMethod: aCompiledMethod.
	
	editor := self newScrolledText.
	editor hResizing: #spaceFill; vResizing: #spaceFill.
	
	self textModel setText: aCompiledMethod sourceCode.
	self addMorph: editor.! !

!ReflectivityCodeMorph methodsFor: 'accessing' stamp: ''!
compiledMethod: anObject
	compiledMethod := anObject! !

!ReflectivityCodeMorph methodsFor: 'initialize' stamp: ''!
defaultBounds
"answer the default bounds for the receiver"
	^ 0 @ 0 corner: 200 @ 40! !

!ReflectivityCodeMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	super drawOn: aCanvas.
	self drawTitleOn: aCanvas! !

!ReflectivityCodeMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self
 		layoutPolicy: TableLayout new;
		listDirection: #leftToRight;
		wrapDirection: #topToBottom;
		hResizing: #spaceFill;
		vResizing: #rigid;
		height: 150;
		layoutInset: (Margin top: 30 left: 2 bottom: 2 right: 2); 
		cellInset: 1.
		! !

!ReflectivityCodeMorph methodsFor: 'shout' stamp: ''!
shoutAboutToStyle: aTextView

	aTextView classOrMetaClass: self compiledMethod methodClass.
	^ true! !

!ReflectivityCodeMorph methodsFor: 'accessing' stamp: ''!
textModel
	^ textModel ifNil: [ textModel := RubScrolledTextModel new interactionModel: self ]! !

!ReflectivityCodeMorph methodsFor: 'drawing' stamp: ''!
drawTitleOn: aCanvas
	aCanvas drawString: self compiledMethod methodClass asString 
		in: (self bounds insetBy: (Margin left: 10 top: 10 right: 2 bottom: 10)) 
		font: (LogicalFont familyName: self familyName pointSize: 11)
		color: self theme textColor. ! !

!ReflectivityCodeMorph methodsFor: 'instance creation' stamp: ''!
newScrolledText
	| scrolledText |
	scrolledText := self textModel
		newScrolledText
		beForSmalltalkCode;
		beWrapped;
		beReadOnly;
		yourself.
	^ scrolledText! !

!ReflectivityCodeMorph methodsFor: 'accessing' stamp: ''!
familyName
	^'Source Sans Pro'! !

!ReflectivityCodeMorph methodsFor: 'initialize' stamp: ''!
defaultColor
	^Color veryLightGray! !

!ReflectivityCodeMorph methodsFor: 'accessing' stamp: ''!
compiledMethod
	^ compiledMethod! !

!ReflectivityCodeMorph class methodsFor: 'instance creation' stamp: ''!
compiledMethod: aCompiledMethod

	^self new addSourceCode: aCompiledMethod; yourself.! !

!ReflectivityControlTest commentStamp: ''!
Tests for Reflective method!
!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterCascade
	| cascadeNode |
	cascadeNode := (ReflectivityExamples >> #exampleCascade) ast statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	cascadeNode link: link.
	self assert: cascadeNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleCascade) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleCascade equals: 1.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleCascade) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterLiteralArray
	| literalArray |
	literalArray := (ReflectivityExamples >> #exampleLiteralArray) ast statements first value.
	self assert: literalArray isLiteralArray.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	literalArray link: link.
	self assert: literalArray hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleLiteralArray) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleLiteralArray equals: #(1).
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleLiteralArray) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleLiteralArray) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterMethod
	| methodNode |
	methodNode := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterBlockOptimizedIfTrue
	| blockNode |
	blockNode := (ReflectivityExamples >> #exampleIfTrueIfFalse) ast blockNodes second.
	self assert: blockNode isBlock.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	blockNode link: link.
	self assert: blockNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleIfTrueIfFalse) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleIfTrueIfFalse identicalTo: 5.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleIfTrueIfFalse) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeBlock
	| blockNode |
	blockNode := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver.
	self assert: blockNode isBlock.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	blockNode link: link.
	self assert: blockNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleBlock identicalTo: 5.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - level' stamp: ''!
testConditionMetaLevel
	"check that the condition is evaluated on the same meta level as the link"

	| sendNode |
	sendNode := (ReflectivityExamples >> #exampleMethod) sendNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		condition: [ self assert: Processor activeProcess level identicalTo: 1.
			true ];
		level: 0;
		arguments: #(#node).
	sendNode link: link.
	self assert: sendNode hasMetalinkBefore.
	self assert: tag isNil.
	ReflectivityExamples new exampleMethod.
	self assert: tag class equals: RBMessageNode! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadVariableWrite
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignment) variableWriteNodes first.
	link := MetaLink new
		metaObject: #context;
		selector: #tempNamed:put:;
		control: #instead;
		arguments: #(#name #newValue).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: ReflectiveMethod.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3! !

!ReflectivityControlTest methodsFor: 'tests - options' stamp: ''!
testLinkOneShot
	| sendNode |
	sendNode := (ReflectivityExamples>>#exampleMethod) sendNodes first.
	link := MetaLink new 
		metaObject: self; 
		options: #(+ optionOneShot);
		selector: #tagExec.
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag equals: #yes.
	self deny: sendNode hasMetalink.	
	tag := nil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag isNil
! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadCascade
	| cascadeNode |
	cascadeNode := (ReflectivityExamples >> #exampleCascade) ast statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #instead.
	cascadeNode link: link.
	self assert: cascadeNode hasMetalinkInstead.
	self assert: (ReflectivityExamples >> #exampleCascade) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleCascade equals: self.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleCascade) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadSendMultipleSites
	| sendNodes instance |
	sendNodes := (ReflectivityExamples >> #exampleMethodMultipleSites) sendNodes.
	link := MetaLink new
		metaObject: [ :receiver :selector :arguments | receiver perform: selector withArguments: arguments ];
		selector: #value:value:value:;
		control: #instead;
		arguments: #(#receiver #selector #arguments).
	sendNodes do: [ :sn | sn link: link ].
	self assert: sendNodes anyOne hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethodMultipleSites) class equals: ReflectiveMethod.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethodMultipleSites equals: 5! !

!ReflectivityControlTest methodsFor: 'tests - after - variables' stamp: ''!
testAfterSlot
	| iVar instance |
	iVar := ReflectivityExamples slotNamed: #ivar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(name).
	iVar link: link.
	self assert: iVar hasMetalink.
	self
		assert: (ReflectivityExamples >> #exampleIvarRead) class
		equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: #ivar! !

!ReflectivityControlTest methodsFor: 'tests - conditions' stamp: ''!
testConditionDisableEnableWithArguments
"check that a link is not executed, if the condition is disabled (link>>#disable)."
"and  that it is executed again if the condition is enabled again (link>>#enable"
	| sendNode |
	sendNode := (ReflectivityExamples >> #exampleMethod) sendNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		condition: [ :arg | arg == sendNode ] arguments:#(#node);
		arguments: #(#node).
	sendNode link: link.
	self assert: sendNode hasMetalinkBefore.
	self assert: tag isNil.
	ReflectivityExamples new exampleMethod.
	self assert: tag class equals: RBMessageNode.
	tag := nil.
	link disable.
	ReflectivityExamples new exampleMethod.
	self assert: tag isNil.
	link enable.
	ReflectivityExamples new exampleMethod.
	self assert: tag class equals: RBMessageNode! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadLiteralArray
	| literalArray |
	literalArray := (ReflectivityExamples >> #exampleLiteralArray) ast statements first value.
	self assert: literalArray isLiteralArray.
	link := MetaLink new
		metaObject: self;
		control: #instead;
		selector: #return3.
	literalArray link: link.
	self assert: literalArray hasMetalinkInstead.
	self assert: (ReflectivityExamples >> #exampleLiteralArray) class equals: ReflectiveMethod.
	self assert: ReflectivityExamples new exampleLiteralArray equals: 3.
	self assert: (ReflectivityExamples >> #exampleLiteralArray) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleLiteralArray) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterArray
	| arrayNode |
	arrayNode := (ReflectivityExamples >> #exampleArray) ast statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	arrayNode link: link.
	self assert: arrayNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleArray) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleArray isArray.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleArray) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterBlock
	| blockNode |
	blockNode := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver.
	self assert: blockNode isBlock.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	blockNode link: link.
	self assert: blockNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleBlock identicalTo: 5.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - after - variables' stamp: ''!
testBeforeSlotWrite
	| iVar instance |
	iVar := ReflectivityExamples slotNamed: #ivar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #before;
		arguments: #(name).
	iVar link: link.
	self assert: iVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleAssignmentIvar) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignmentIvar equals: 3.
	self assert: tag equals: #ivar! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadPrimitiveMethod
	| node |
	ReflectivityExamples recompile: #examplePrimitiveMethod.
	node := (ReflectivityExamples >> #examplePrimitiveMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #instead.
	node link: link.
	self assert: node hasMetalink.
	self assert: (ReflectivityExamples >> #examplePrimitiveMethod) class equals: CompiledMethod.
	self assert: tag isNil.
	ReflectivityExamples new examplePrimitiveMethod.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #examplePrimitiveMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterMethodPrimitive
	| methodNode |
	ReflectivityExamples recompile: #examplePrimitiveMethod.
	methodNode := (ReflectivityExamples >> #examplePrimitiveMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	self assert: (ReflectivityExamples>>#examplePrimitiveMethod) isRealPrimitive.
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #examplePrimitiveMethod) class equals: CompiledMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new examplePrimitiveMethod class equals: ByteString.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #examplePrimitiveMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterMethod2
	| methodNode instance |
	methodNode := (ReflectivityExamples >> #exampleMethod2) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod2) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod2 equals: instance.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleMethod2) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - options' stamp: ''!
testLinkOptionDisabledLink
	| sendNode |
	sendNode := (ReflectivityExamples>>#exampleMethod) sendNodes first.
	link := MetaLink new 
		metaObject: self; 
		options: #(+ optionDisabledLink);
		selector: #tagExec.
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples>>#exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag isNil.
	self assert: (ReflectivityExamples>>#exampleMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tagging' stamp: ''!
tagExec: aTag
	tag := aTag! !

!ReflectivityControlTest methodsFor: 'tests - after - variables' stamp: ''!
testInsteadClassVariable
	| classVar |
	self skip.
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #instead.
	classVar link: link.
	self assert: classVar hasMetalinkInstead.
	self assert: tag isNil.
	self
		assert: (ReflectivityExamples >> #exampleClassVarRead) class
		equals: ReflectiveMethod.
	self
		assert: ReflectivityExamples new exampleClassVarRead class equals: self class.
	self assert: tag equals: 'yes'.
	self
		assert: (ReflectivityExamples >> #exampleClassVarRead) class
		equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleClassVarRead) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeMethodPrimitive
	| methodNode |
	methodNode := (ReflectivityExamples >> #examplePrimitiveMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	self assert: (ReflectivityExamples>>#examplePrimitiveMethod) isRealPrimitive.	
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #examplePrimitiveMethod) class equals: CompiledMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new examplePrimitiveMethod class equals: ByteString.
	self deny: (ReflectivityExamples>>#examplePrimitiveMethod) isRealPrimitive.	
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #examplePrimitiveMethod) class equals: CompiledMethod.
	link uninstall.
	self assert: (ReflectivityExamples >> #examplePrimitiveMethod) class equals: CompiledMethod.
	self assert: (ReflectivityExamples>>#examplePrimitiveMethod) isRealPrimitive! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterLiteral
	| literalNode |
	literalNode := (ReflectivityExamples >> #exampleLiteral) ast statements first value.
	self assert: literalNode isLiteralNode.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	literalNode link: link.
	self assert: literalNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleLiteral) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleLiteral identicalTo: 2.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleLiteral) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleLiteral) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - after - variables' stamp: ''!
testAfterClassVariable
	| classVar |
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	classVar link: link.
	self assert: classVar hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleClassVarRead equals: #AClassVar.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleClassVarRead) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterAssignment
	| assignmentNode |
	assignmentNode := (ReflectivityExamples >> #exampleAssignment)
		assignmentNodes first.
	self assert: assignmentNode isAssignment.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	assignmentNode link: link.
	self assert: assignmentNode hasMetalinkAfter.
	self
		assert: (ReflectivityExamples >> #exampleAssignment) class
		equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleAssignment equals: 3.
	self assert: tag equals: 'yes'.
	self
		assert: (ReflectivityExamples >> #exampleAssignment) class
		equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadArray
	| arrayNode |
	arrayNode := (ReflectivityExamples >> #exampleArray) ast statements first value.
	self assert: arrayNode isDynamicArray.
	link := MetaLink new
		metaObject: self;
		control: #instead;
		selector: #return3.
	arrayNode link: link.
	self assert: arrayNode hasMetalinkInstead.
	self assert: (ReflectivityExamples >> #exampleArray) class equals: ReflectiveMethod.
	self assert: ReflectivityExamples new exampleArray equals: 3.
	self assert: (ReflectivityExamples >> #exampleArray) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleArray) isQuick! !

!ReflectivityControlTest methodsFor: 'running' stamp: ''!
tearDown
	link ifNotNil: [ link uninstall ].
	super tearDown ! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterBlockSequence
	| sequence |
	sequence := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver body.
	self assert: sequence isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	sequence link: link.
	self assert: sequence hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleBlock identicalTo: 5.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterVariableNode
	| variableNode |
	variableNode := (ReflectivityExamples >> #exampleGlobalRead) ast statements first value.
	self assert: variableNode isVariable.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	variableNode link: link.
	self assert: variableNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleGlobalRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleGlobalRead equals: GlobalForTesting.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleGlobalRead) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleGlobalRead) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeCascade
	| cascadeNode |
	cascadeNode := (ReflectivityExamples >> #exampleCascade) ast statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	cascadeNode link: link.
	self assert: cascadeNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleCascade) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleCascade equals: 1.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleCascade) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeLiteral
	| literalNode |
	literalNode := (ReflectivityExamples >> #exampleLiteral) ast statements first value.
	self assert: literalNode isLiteralNode.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	literalNode link: link.
	self assert: literalNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleLiteral) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleLiteral identicalTo: 2.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleLiteral) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleLiteral) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeMethod
	| methodNode |
	methodNode := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testFailingDoubleRWInsteadSimplified

	|readLink readMO readNode|

	readNode := ((ReflectivityExamples>>#exampleLazyInit) 
		variableReadNodes select: [ :node | node name = 'singleton' ]) first.

	"default MO for rw -- bug manifests on install"
	readMO := [ :object | object class classVarNamed: 'singleton' ].
		
	readLink := MetaLink new 
		metaObject: readMO; 
		selector: #value:;
		control: #instead;
		options: #(+ optionCompileOnLinkInstallation);
		arguments: #(object).
			
	readNode link: readLink.
	readLink uninstall
! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterMethodWithTemps
	| methodNode |
	ReflectivityExamples recompile: #exampleAssignment.
	methodNode := (ReflectivityExamples >> #exampleAssignment) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleAssignment equals: 3.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testFailingDoubleRWInstead

	|readLink readMO writeLink writeMO readSites writeSites|

	readSites := (ReflectivityExamples>>#exampleLazyInit) 
		variableReadNodes select: [ :node | node name = 'singleton' ].
		
	writeSites :=  (ReflectivityExamples>>#exampleLazyInit) 
		variableWriteNodes select: [ :node | node name = 'singleton' ].
	
	"default MO for rw -- bug manifests on install"
	readMO := [ :object | object class classVarNamed: 'singleton' ].
	writeMO := [ :object :newValue | object class classVarNamed: 'singleton' put: newValue ].
		
	readLink := MetaLink new 
		metaObject: readMO; 
		selector: #value:;
		control: #instead;
		options: #(+ optionCompileOnLinkInstallation);
		arguments: #(object).
		
	writeLink := MetaLink new 
		metaObject: writeMO; 
		selector: #value:value:;
		control: #instead;
		options: #(+ optionCompileOnLinkInstallation);
		arguments: #(newValue object).
	
	readSites do: [ :readNode | readNode link: readLink ].
	writeSites do: [ :writeNode | writeNode link: writeLink ].
	readLink uninstall.
	writeLink uninstall! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeArray
	| arrayNode |
	arrayNode := (ReflectivityExamples >> #exampleArray) ast statements first value.
	self assert: arrayNode isDynamicArray.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	arrayNode link: link.
	self assert: arrayNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleArray) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleArray isArray.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleArray) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - conditions' stamp: ''!
testConditionWithArgument2
	| sendNode |
	sendNode := (ReflectivityExamples >> #exampleMethod) sendNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		condition: [ :arg | arg == sendNode ] arguments: #(node);
		arguments: #(#node).
	sendNode link: link.
	self assert: sendNode hasMetalinkBefore.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag class equals: RBMessageNode.
	link condition: [ :node | node == 5 ].
	tag := nil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag isNil! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadBlockSequence
	| sequence |
	sequence := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver body.
	self assert: sequence isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #instead.
	sequence link: link.
	self assert: sequence hasMetalinkInstead.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: tag isNil.
 	ReflectivityExamples new exampleBlock.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - options' stamp: ''!
testLinkoptionInlineMetaObject
	| sendNode |
	sendNode := (ReflectivityExamples>>#exampleMethod) sendNodes first.
	link := MetaLink new 
		metaObject: self; 
		options: #(- optionInlineMetaObject);
		selector: #tagExec.
	sendNode link: link.
	self assert: sendNode hasMetalink.
		self assert: (ReflectivityExamples>>#exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag equals: #yes.
	"if we now change the meta object, the method should not be invalidated"
	link metaObject: self class new.
	self assert: (ReflectivityExamples>>#exampleMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeBlockSequence
	| sequence |
	sequence := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver body.
	self assert: sequence isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	sequence link: link.
	self assert: sequence hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleBlock identicalTo: 5.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadSequence
	| seqNode |
	seqNode := (ReflectivityExamples >> #exampleAssignment) ast body.
	self assert: seqNode isSequence.
	link := MetaLink new
		metaObject: self;
		control: #instead;
		selector: #tagExec.
	self assert: (seqNode isKindOf: RBSequenceNode).
	seqNode link: link.
	self assert: seqNode hasMetalinkInstead.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: ReflectiveMethod.
	self assert: tag isNil.
	ReflectivityExamples new exampleAssignment.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: CompiledMethod.! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadLiteral
	| literalNode |
	literalNode := (ReflectivityExamples >> #exampleLiteral) ast statements first value.
	self assert: literalNode isLiteralNode.
	link := MetaLink new
		metaObject: self;
		control: #instead;
		selector: #return3.
	literalNode link: link.
	self assert: literalNode hasMetalinkInstead.
	self assert: (ReflectivityExamples >> #exampleLiteral) class equals: ReflectiveMethod.
	self assert: ReflectivityExamples new exampleLiteral identicalTo: 3.
	self assert: (ReflectivityExamples >> #exampleLiteral) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleLiteral) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - level' stamp: ''!
testRecursionStopper
	"check that we can break a loop"
	| methodNode |
	methodNode := (self class >> #tagExec) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		level: 0.
	methodNode link: link.
	self assert: methodNode hasMetalinkBefore.
	self assert: tag isNil.
	self tagExec.
	self assert: tag equals: #yes! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeVariableSelf
	| variableNode |
	variableNode := (ReflectivityExamples >> #exampleSelf) ast statements
		first.
	self assert: variableNode isVariable.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	variableNode link: link.
	self assert: variableNode hasMetalinkBefore.
	self
		assert: (ReflectivityExamples >> #exampleSelf) class
		equals: ReflectiveMethod.
	self assert: tag isNil.
	self
		assert: ReflectivityExamples new exampleSelf class
		equals: ReflectivityExamples.
	self assert: tag equals: 'yes'.
	self
		assert: (ReflectivityExamples >> #exampleSelf) class
		equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleSelf) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadBlock
	| blockNode |
	blockNode := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver.
	self assert: blockNode isBlock.
	link := MetaLink new
		metaObject: self;
		control: #instead;
		selector: #return3.
	self assert: ReflectivityExamples new exampleBlock identicalTo: 5.
	blockNode link: link.
	self assert: blockNode hasMetalinkInstead.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: ReflectivityExamples new exampleBlock identicalTo: 3.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadVariableReadGlobal
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleGlobalRead) variableReadNodes first.
	link := MetaLink new
		metaObject: #class;
		selector: #bindingOf:;
		control: #instead;
		arguments: #(#name).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleGlobalRead) class equals: ReflectiveMethod.
	instance := ReflectivityExamples new.
	self assert: instance exampleGlobalRead value equals: GlobalForTesting! !

!ReflectivityControlTest methodsFor: 'tests - options' stamp: ''!
testLinkoptionInlineCondition
	| sendNode |
	sendNode := (ReflectivityExamples>>#exampleMethod) sendNodes first.
	link := MetaLink new 
		metaObject: self; 
		options: #(- optionInlineCondition);
		condition: [ true ];
		selector: #tagExec.
	sendNode link: link.
	self assert: sendNode hasMetalink.
		self assert: (ReflectivityExamples>>#exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag equals: #yes.
	"if we now change the meta object, the method should not be invalidated"
	link condition: [true].
	self assert: (ReflectivityExamples>>#exampleMethod) class equals: CompiledMethod.
	tag := nil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self deny: tag isNil.
	link condition: [true].
	self assert: (ReflectivityExamples>>#exampleMethod) class equals: CompiledMethod.
	tag := nil.
	link condition: [false].
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag isNil! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeSequence
	| seqNode |
	seqNode := (ReflectivityExamples >> #exampleAssignment) ast body.
	self assert: seqNode isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	seqNode link: link.
	self assert: seqNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleAssignment equals: 3.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeClassVariable

	| classVar |
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	classVar link: link.
	self assert: classVar hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleClassVarRead equals: #AClassVar.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleClassVarRead) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeVariable
	| variableNode |
	variableNode := (ReflectivityExamples >> #exampleGlobalRead) ast statements first value.
	self assert: variableNode isVariable.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	variableNode link: link.
	self assert: variableNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleGlobalRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleGlobalRead equals: GlobalForTesting.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleGlobalRead) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleGlobalRead) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - conditions' stamp: ''!
testConditionWithArgument
	| sendNode |
	sendNode := (ReflectivityExamples >> #exampleMethod) sendNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		condition: [ :node | node == sendNode ] arguments: #(#node);
		arguments: #(#node).
	sendNode link: link.
	self assert: sendNode hasMetalinkBefore.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag class equals: RBMessageNode.
	link condition: [ :node | node == 5 ].
	tag := nil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag isNil! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterBlockOptimizedWhileFalseSend
	| sendNode |
	sendNode := (ReflectivityExamples >> #exampleWhileFalse) ast sendNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	sendNode link: link.
	self assert: sendNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleWhileFalse) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleWhileFalse equals: 11.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleWhileFalse) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tagging' stamp: ''!
tagExec
	tag := #yes! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeSend
	| sendNode |
	sendNode := (ReflectivityExamples >> #exampleMethod) sendNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(#node).
	sendNode link: link.
	self assert: sendNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag class equals: RBMessageNode.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeReturn
	| returnNode |
	returnNode := (ReflectivityExamples >> #exampleLiteral) ast statements first.
	self assert: returnNode isReturn.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	returnNode link: link.
	self assert: returnNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleLiteral) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleLiteral identicalTo: 2.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleLiteral) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleLiteral) isQuick! !

!ReflectivityControlTest methodsFor: 'tagging' stamp: ''!
return3
	^3! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterSendWeak
	| sendNode |
	sendNode := (ReflectivityExamples >> #exampleMethod) sendNodes first.
	self assert: sendNode isMessage.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		option: #(+ optionWeakAfter);
		arguments: #(node).
	sendNode link: link.
	self assert: sendNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag class equals: RBMessageNode.
	self deny: ((ReflectivityExamples >> #exampleMethod) messages includes: #ensure:).
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeBlockSequenceOptimized
	| sequence |
	"we should be able to set a link on the sequence of an optimzied block with escaping vars"
	sequence := (ReflectivityExamples >> #exampleBlockOptimized) ast blockNodes first body.
	self assert: sequence isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	sequence link: link.
	self assert: sequence hasMetalinkBefore.
	self assert: tag isNil.
	ReflectivityExamples new exampleBlockOptimized.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleBlockNoValue) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadMethod
	| node |
	node := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #instead.
	node link: link.
	self assert: node hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	ReflectivityExamples new exampleMethod.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - conditions' stamp: ''!
testConditionDisableEnableNoArguments
"check that a link is not executed, if the condition is disabled (link>>#disable)."
"and  that it is executed again if the condition is enabled again (link>>#enable"
	| sendNode |
	sendNode := (ReflectivityExamples >> #exampleMethod) sendNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		condition: [ true ];
		arguments: #(#node).
	sendNode link: link.
	self assert: sendNode hasMetalinkBefore.
	self assert: tag isNil.
	ReflectivityExamples new exampleMethod.
	self assert: tag class equals: RBMessageNode.
	tag := nil.
	link disable.
	ReflectivityExamples new exampleMethod.
	self assert: tag isNil.
	link enable.
	ReflectivityExamples new exampleMethod.
	self assert: tag class equals: RBMessageNode
! !

!ReflectivityControlTest methodsFor: 'tagging' stamp: ''!
recordLevel
	tag := Processor activeProcess level! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeBlockSequenceNoValue
	| sequence |
	sequence := (ReflectivityExamples >> #exampleBlockNoValue) ast statements first value body.
	self assert: sequence isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	sequence link: link.
	self assert: sequence hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleBlockNoValue) class equals: ReflectiveMethod.
	self assert: tag isNil.
	ReflectivityExamples new exampleBlockNoValue.
	self assert: tag isNil.
	ReflectivityExamples new exampleBlockNoValue value.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleBlockNoValue) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - after - variables' stamp: ''!
testBeforeSlot
	| iVar instance |
	iVar := ReflectivityExamples slotNamed: #ivar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #before;
		arguments: #(name).
	iVar link: link.
	self assert: iVar hasMetalink.
	self
		assert: (ReflectivityExamples >> #exampleIvarRead) class
		equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: #ivar! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterSequence
	| sequence |
	sequence := (ReflectivityExamples >> #exampleMethod) ast body.
	self assert: sequence isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec;
		control: #after.
	sequence link: link.
	self assert: sequence hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadVariableReadTemp
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignment) variableReadNodes first.
	link := MetaLink new
		metaObject: #context;
		selector: #tempNamed:;
		control: #instead;
		arguments: #(#name).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: ReflectiveMethod.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment value equals: 3! !

!ReflectivityControlTest methodsFor: 'tests - after - variables' stamp: ''!
testAfterSlotWrite
	| iVar instance |
	iVar := ReflectivityExamples slotNamed: #ivar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(name).
	iVar link: link.
	self assert: iVar hasMetalink.
	self
		assert: (ReflectivityExamples >> #exampleAssignmentIvar) class
		equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignmentIvar equals: 3.
	self assert: tag equals: #ivar! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadSend
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) sendNodes first.
	link := MetaLink new
		metaObject: #receiver;
		selector: #perform:withArguments:;
		control: #instead;
		arguments: #(#selector #arguments).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadAssign
	| assignmentNode instance |
	assignmentNode := (ReflectivityExamples >> #exampleAssignment) assignmentNodes first.
	self assert: assignmentNode isAssignment.
	link := MetaLink new
		metaObject: #context;
		selector: #tempNamed:put:;
		control: #instead;
		arguments: #(#name #newValue).
	assignmentNode link: link.
	self assert: assignmentNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: ReflectiveMethod.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3! !

!ReflectivityControlTest methodsFor: 'tests - level' stamp: ''!
testAfterMethodLevel
	| methodNode |
	"check that level is correct in #after on methodNode"
	methodNode := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #recordLevel;
		control: #after;
		level: 0.
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag equals: 1.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeAssignment
	| assignmentNode |
	assignmentNode := (ReflectivityExamples >> #exampleAssignment) assignmentNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	assignmentNode link: link.
	self assert: assignmentNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleAssignment equals: 3.
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleAssignment) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeLiteralArray
	| literalArray |
	literalArray := (ReflectivityExamples >> #exampleLiteralArray) ast statements first value.
	self assert: literalArray isLiteralArray.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	literalArray link: link.
	self assert: literalArray hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleLiteralArray) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleLiteralArray equals: #(1).
	self assert: tag equals: 'yes'.
	self assert: (ReflectivityExamples >> #exampleLiteralArray) class equals: CompiledMethod.
	self deny: (ReflectivityExamples >> #exampleLiteralArray) isQuick! !

!ReflectivityControlTest methodsFor: 'tests - after' stamp: ''!
testAfterSend
	| sendNode |
	sendNode := (ReflectivityExamples >> #exampleMethod) sendNodes first.
	self assert: sendNode isMessage.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(#node).
	sendNode link: link.
	self assert: sendNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag class equals: RBMessageNode.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - before' stamp: ''!
testBeforeSendInCascade
	| sendNode |
	sendNode := (ReflectivityExamples >> #exampleCascade) ast statements first value messages first.
	self assert: sendNode isMessage.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec.
	sendNode link: link.
	self assert: sendNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleCascade) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleCascade equals: 1.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleCascade) class equals: CompiledMethod! !

!ReflectivityControlTest methodsFor: 'tests - instead' stamp: ''!
testInsteadVariableReadIvar
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) variableReadNodes first.
	link := MetaLink new
		metaObject: #object;
		selector: #instVarNamed:;
		control: #instead;
		arguments: #(#name).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleIvarRead) class equals: ReflectiveMethod.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead value equals: 33.
	self deny: (ReflectivityExamples >> #exampleIvarRead) isQuick	"yes, we changed the method"! !

!ReflectivityDemos commentStamp: ''!
This class collects simple demos for Reflectivity.

each method contains a small, self-contained demo.!
!ReflectivityDemos methodsFor: 'demos' stamp: ''!
demoSelfSendLogging
	<script: 'self new demoSelfSendLogging'>
	
	"Running this method, Open first a Transcript and then the SpDemoNotebookPresenter.	
		
	Transcript open.
	SpDemoNotebookPresenter example.
	
	To clean up, run the #cleanUp script of this class.
	
	We use option #optionCompileOnLinkInstallation because we analyse the sender context
	and do not want to have the code generation be interering.
	"
	
	| theClass |
	theClass := SpDemoNotebookPresenter.
	CachedLink := MetaLink new
		metaObject: [ :context :object | context sender receiver == object
				ifTrue: [ context crTrace ] ];
		selector: #value:value:;
		option: #(+optionCompileOnLinkInstallation);
		arguments: #(context object);
		control: #before.
		
	theClass methods do: [ :each | each ast link: CachedLink ].
! !

!ReflectivityDemos methodsFor: 'cleanup' stamp: ''!
cleanUp
	<script: 'self new cleanUp'>
	CachedLink ifNotNil: [ :link | link uninstall. CachedLink := nil ]! !

!ReflectivityExamples commentStamp: ''!
Examples for RF!
!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleAssignmentIvar: anObject
	ivar := anObject.
	^ivar! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleBlockOptimized
	"block with temp vector inside a optized block"
	^ 1==1 ifTrue: [ 
		  | var1 var2 |
		
		  #( 1 2 ) collect: [ :each | 
			  var1 := 1.
			  var2 := 1.
			  var1 + var2 ] ] ! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleMethod2

	2 + 3! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleSelf
	self! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleMethodMultipleSites
	self trace: Object new.
	^ 2 + 3! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleWithArg: anArg
	^ 2 + anArg! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleLiteral
	^ 2! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleAssignmentClassVar
	ClassVar := (1 + 2).
	^ClassVar! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleSendNoReturn
	"just an example method that calls a mutation outside of a assignment or return node.
(needed for before link test with receiver reification"

	| collection |
	collection := OrderedCollection newFrom: {3 . 4}.
	collection removeAt:1.! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleSendTwoArgs
	^ Array with: 1 with: 2! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleBlock
	^ [ 2 + 3 ] value ! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleMethod

	^ 2 + 3! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleArray
	^ {3}! !

!ReflectivityExamples methodsFor: 'initialization' stamp: ''!
removeTemporaryMethods
	
	self class removeSelector: #methodToBeRemoved.
	self class removeSelector: #methodToBeModified.
	self class removeSelector: #stubMethod! !

!ReflectivityExamples methodsFor: 'tagging' stamp: ''!
tagExec: anObject
	tag := anObject! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleDynamicArrayArgument

	^ OrderedCollection new , { self }! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleMethodWithMetaLinkOptions
	<metaLinkOptions: #( +optionCompileOnLinkInstallation)>
	^ 2 + 3! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleCascade
	^1 sin; yourself! !

!ReflectivityExamples methodsFor: 'initialization' stamp: ''!
compileTemporaryMethods
	self class compile: 'methodToBeRemoved ^nil'.
	self class compile: 'methodToBeModified ^nil'.
	self class compile: 'stubMethod ^nil'! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleBlockNoValue
	^ [2 + 3]! !

!ReflectivityExamples methodsFor: 'initialization' stamp: ''!
initialize
	ivar := 33.
	ClassVar := #AClassVar! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
examplePrimitiveMethod
	"returns image path"
	<primitive: 121>
	^ 2 + 3! !

!ReflectivityExamples methodsFor: 'examples - optimized' stamp: ''!
exampleWhileFalse
	| t |
	t := 1.
	[ t > 10 ] whileFalse: [ t := t + 1].
	^t! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleGlobalRead
	^GlobalForTesting! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleTwoSends
	3 + 4.
	^ 2 + 3! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleAssignmentIvar
	ivar := (1 + 2).
	^ivar! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleIvarRead
	^ivar! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleAssignment
	| temp |
	temp := (1 + 2).
	^temp! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleLiteralArray
	^ #(1)! !

!ReflectivityExamples methodsFor: 'tagging' stamp: ''!
tag
	^tag! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleMessageSend
	self tagExec: #yes! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleBlockWithArg
	^ [:a | a + 3] value: 2 ! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleClassVarRead
	^ClassVar! !

!ReflectivityExamples methodsFor: 'examples - optimized' stamp: ''!
exampleIfTrueIfFalse

	| t |
	t := false.
	t ifTrue: [ self bar ] ifFalse: [ 'hello' ].
	^ 5 ! !

!ReflectivityExamples methodsFor: 'examples' stamp: ''!
exampleLazyInit
	^ singleton ifNil: [singleton := self new initialize]! !

!ReflectivityExamples class methodsFor: 'options' stamp: ''!
metaLinkOptions
	^{
	#exampleMethodWithMetaLinkOptionsViaClass -> #( + optionCompileOnLinkInstallation)
	}! !

!ReflectivityExamples class methodsFor: 'options' stamp: ''!
exampleMethodWithMetaLinkOptionsViaClass
	<sampleInstance>
	^ 2 + 3! !

!ReflectivityExamples2 commentStamp: ''!
Examples for RF per object.!
!ReflectivityExamples2 methodsFor: 'examples' stamp: ''!
exampleMethod2
	^ (WriteStream on: String new)
		nextPutAll: 'hello world';
		contents! !

!ReflectivityExamples2 methodsFor: 'examples' stamp: ''!
methodWithTempVarAccess
	|temp|
	temp := 5.
	temp := 6.
	temp > 5 ifTrue:[^ temp raisedTo: 2]
	
! !

!ReflectivityExamples2 methodsFor: 'removing' stamp: ''!
removeNewMethodWithInstVarAccess
	self class removeSelector: #newMethodWithInstVarAccess! !

!ReflectivityExamples2 methodsFor: 'generation' stamp: ''!
resetModifiedMethodWithInstVarAccess
	self class
		compile:
			'modifiedMethodWithInstVarAccess
	instVar := 5.
	instVar := 6.
	instVar > 5 ifTrue:[^ instVar raisedTo: 2]'
		classified: 'example'! !

!ReflectivityExamples2 methodsFor: 'generation' stamp: ''!
generateNewMethodWithInstVarAccess
	self class
		compile:
			'newMethodWithInstVarAccess
	instVar := 5.
	instVar := 6.
	instVar > 5 ifTrue:[^ instVar raisedTo: 2]'
		classified: 'example'! !

!ReflectivityExamples2 methodsFor: 'accessing' stamp: ''!
instVar2: anObject

	instVar2 := anObject! !

!ReflectivityExamples2 methodsFor: 'examples' stamp: ''!
exampleMethod
	^ 2 + 3! !

!ReflectivityExamples2 methodsFor: 'examples' stamp: ''!
methodWithOverrides: str1 with: str2
	^str1, str2! !

!ReflectivityExamples2 methodsFor: 'examples' stamp: ''!
methodWithInstVarAccess
	instVar := 5.
	instVar := 6.
	instVar > 5 ifTrue:[^ instVar raisedTo: 2]
	
! !

!ReflectivityExamples2 methodsFor: 'examples' stamp: ''!
methodWithOverrides
	^'top'! !

!ReflectivityExamples2 methodsFor: 'example' stamp: ''!
newMethodWithInstVarAccess
	instVar := 5.
	instVar := 6.
	instVar > 5 ifTrue:[^ instVar raisedTo: 2]! !

!ReflectivityExamples2 methodsFor: 'examples' stamp: ''!
methodWithClassVarAccess
	classVar := 5.
	classVar := 6.
	classVar > 5 ifTrue:[^ classVar raisedTo: 2]
	
! !

!ReflectivityExamples2 methodsFor: 'examples' stamp: ''!
modifyMethodWithInstVarAccess
	self class compile:'modifiedMethodWithInstVarAccess
	instVar > 5 ifTrue:[^ instVar raisedTo: 2]'
	
! !

!ReflectivityExamples2 methodsFor: 'removing' stamp: ''!
removeModifiedMethodWithInstVarAccess
	self class removeSelector: #modifiedMethodWithInstVarAccess! !

!ReflectivityExamples2Subclass commentStamp: ''!
Subclass for testing premalink spanning class hierarchies.!
!ReflectivityExamples2Subclass methodsFor: 'examples' stamp: ''!
methodWithOverrides: str1 with: str2
	^(super methodWithOverrides: str1 with: str2), str1, str2! !

!ReflectivityExamples2Subclass methodsFor: 'examples' stamp: ''!
methodWithOverrides
	^super methodWithOverrides, ' + down'! !

!ReflectivityExamples2Subclass methodsFor: 'examples' stamp: ''!
useInstVarInSubclass
	^instVar2! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyAssignmentSlotOperationInstead
	| varNode instance reachHere |
	varNode := (ReflectivityExamples >> #exampleAssignmentIvar) assignmentNodes first.
	reachHere := false.
	link := MetaLink new
		metaObject: [:operation | reachHere := true. operation value];
		selector: #value:;
		control: #instead;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignmentIvar equals: 3.
	self assert: reachHere.! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testReifyIvarName
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(name).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: 'ivar'! !

!ReflectivityReificationTest methodsFor: 'tests - misc' stamp: ''!
testReifyLiteralArrayOperation
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleLiteralArray) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(operation).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self
		assert: (ReflectivityExamples >> #exampleLiteralArray) class
		equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleLiteralArray equals: #(1).
	self assert: tag value equals: #(1)! !

!ReflectivityReificationTest methodsFor: 'tests - misc' stamp: ''!
testReifyLiteralArrayValue
	| literalArrayNode instance |
	literalArrayNode := (ReflectivityExamples >> #exampleLiteralArray) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(value).
	literalArrayNode link: link.
	self assert: literalArrayNode hasMetalink.
	self
		assert: (ReflectivityExamples >> #exampleLiteralArray) class
		equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleLiteralArray equals: #(1).
	self assert: tag equals: #(1)! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyAssignmentClassVarOperationAfter
	| varNode instance reachHere |
	varNode := (ReflectivityExamples >> #exampleAssignmentClassVar) assignmentNodes first.
	reachHere := false.
	link := MetaLink new
		metaObject: [:operation | reachHere := true. self assert: operation value equals: 3];
		selector: #value:;
		control: #after;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignmentClassVar equals: 3.
	self assert: reachHere.! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyOperationSendAfter
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(operation).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag value equals: 5! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyAssignmentTempOperationBefore
	| varNode instance reachHere |
	varNode := (ReflectivityExamples >> #exampleAssignment) assignmentNodes first.
	reachHere := false.
	link := MetaLink new
		metaObject: [:operation | reachHere := true. self assert: operation value equals: 3];
		selector: #value:;
		control: #before;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: reachHere.
! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testReifyGlobalValue
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleGlobalRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(value).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleGlobalRead equals: GlobalForTesting.
	self assert: tag equals: GlobalForTesting! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendSender
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(sender).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: instance! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifyReceiverOnSendWithArgumentsAfter
	| sendNode instance beforeSize |
	sendNode := (ReflectivityExamples>>#exampleSendNoReturn) ast body statements last.
	beforeSize := 0.
	link := MetaLink new 
		metaObject: [:receiver | beforeSize := receiver size]; 
		selector: #value:;
		control: #after;
		arguments: #(receiver).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples>>#exampleSendNoReturn) class equals: ReflectiveMethod.
	self assert: beforeSize equals: 0.
	instance := ReflectivityExamples new .
	instance exampleSendNoReturn.
	self assert: beforeSize equals: 1.! !

!ReflectivityReificationTest methodsFor: 'tests - blocks - body' stamp: ''!
testBlockSequenceArguments
	| blockNode |
	blockNode := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver body.
	self assert: blockNode isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #before;
		arguments: #(arguments).
	blockNode link: link.
	self assert: blockNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleBlock identicalTo: 5.
	self assert: tag equals: #().
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyTempOperation
	| varNode instance executed |
	varNode := (ReflectivityExamples >> #exampleAssignment) ast body statements last value.
	executed := false.
	link := MetaLink new
		metaObject: [ :operation | 
			executed := true.
			self assert: operation class identicalTo: RFTempRead.
			self assert: operation value equals: 3 ];
		selector: #value:;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: executed! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifyClassVariableValue
	| classVar instance |
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new 
		metaObject: self; 
		selector: #tagExec:;
		arguments: #(value).
	classVar link: link.
	self assert: classVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: (tag isNil).
	instance := ReflectivityExamples new.
	self assert: instance exampleClassVarRead equals: #AClassVar.
	self assert: tag equals: #AClassVar.! !

!ReflectivityReificationTest methodsFor: 'tests - misc' stamp: ''!
testLiteralValueAfter
	| literalNode |
	literalNode := (ReflectivityExamples >> #exampleLiteral) ast statements first value.
	self assert: literalNode isLiteralNode.
	link := MetaLink new
		metaObject: [ :value | self assert: value equals: 2 ];
		selector: #value:;
		arguments: #(value);
		control: #after.
	literalNode link: link.
	self assert: literalNode hasMetalinkAfter.
	self assert: ReflectivityExamples new exampleLiteral identicalTo: 2! !

!ReflectivityReificationTest methodsFor: 'tests - allnodes' stamp: ''!
testReifyMethod
	| varNode instance origMethod |
	origMethod := ReflectivityExamples >> #exampleIvarRead.
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(method).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: ReflectivityExamples >> #exampleIvarRead.
	self deny: tag identicalTo: origMethod! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyTempOperationInstead
	| varNode instance executed |
	self skip. 
	"skip for now as #usingMethods of the variable gets confused with instead"
	varNode := (ReflectivityExamples >> #exampleAssignment) ast body statements last value.
	executed := false.
	link := MetaLink new
		metaObject: [ :operation | 
			executed := true.
			self assert: operation class identicalTo: RFTempRead.
			self assert: operation value equals: 3.
			operation value ];
		selector: #value:;
		control: #instead;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: executed! !

!ReflectivityReificationTest methodsFor: 'tagging' stamp: ''!
tagExec: aTag
	tag := aTag.! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testReifyTempValue
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignment) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(value).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: tag equals: 3! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyOperationSend
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #before;
		arguments: #(operation).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag value equals: 5! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyGlobalOperation
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleGlobalRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleGlobalRead equals: GlobalForTesting.
	self assert: tag class identicalTo: RFGlobalRead.
	self assert: tag value equals: GlobalForTesting! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendArguments
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body
		statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(arguments).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: #(3)! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifyClassVariableClass
	| classVar instance |
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(class).
	classVar link: link.
	self assert: classVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleClassVarRead equals: #AClassVar.
	self assert: tag identicalTo: ReflectivityExamples! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyAssignmentTempOperationInstead
	| varNode instance reachHere |
	varNode := (ReflectivityExamples >> #exampleAssignment) assignmentNodes first.
	reachHere := false.
	link := MetaLink new
		metaObject: [:operation | 	reachHere := true . operation value];
		selector: #value:;
		control: #instead;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: reachHere.! !

!ReflectivityReificationTest methodsFor: 'tests - return' stamp: ''!
testReifyReturnValue
	| returnNode instance |
	returnNode := (ReflectivityExamples >> #exampleAssignment) ast body statements last.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(value).
	returnNode link: link.
	self assert: returnNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: tag equals: 3! !

!ReflectivityReificationTest methodsFor: 'tests - assignment' stamp: ''!
testReifyValueAssignmentAfter
	"#value for Assignemnt is the new value when #after"
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignment) assignmentNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(value).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: tag equals: 3! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testReifyTempName
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignment) ast body statements first variable.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(name).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: tag equals: 'temp'! !

!ReflectivityReificationTest methodsFor: 'tests - allnodes' stamp: ''!
testReifyByInstanceNotKey
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: {RFNodeReification new}.
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: varNode! !

!ReflectivityReificationTest methodsFor: 'tests - allnodes' stamp: ''!
testReifyEntity
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(entity).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: varNode! !

!ReflectivityReificationTest methodsFor: 'tests - assignment' stamp: ''!
testReifyValueAssignmentBefore
	"#value for Assignemnt is the old value, is that what we want?"
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignment) assignmentNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(value).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: tag equals: nil! !

!ReflectivityReificationTest methodsFor: 'tests - misc' stamp: ''!
testLiteralValueBefore
	| literalNode |
	literalNode := (ReflectivityExamples >> #exampleLiteral) ast statements first value.
	self assert: literalNode isLiteralNode.
	link := MetaLink new
		metaObject: [ :value | self assert: value equals: 2 ];
		selector: #value:;
		arguments: #(value);
		control: #before.
	literalNode link: link.
	self assert: literalNode hasMetalinkBefore.
	self assert: ReflectivityExamples new exampleLiteral identicalTo: 2! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyOperationMethodInstead
	| methodNode instance |
	methodNode := (ReflectivityExamples >> #exampleWithArg:) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #instead;
		arguments: #(operation).
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleWithArg:) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: self.
	self assert: tag class identicalTo: RFMethodOperation.
	self assert: tag value equals: 5! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendMethodToExecute
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(methodToExecute).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: (SmallInteger>>#+).! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyTempOperationAfter
	| varNode instance executed |
	varNode := (ReflectivityExamples >> #exampleAssignment) ast body statements last value.
	executed := false.
	link := MetaLink new
		metaObject: [ :operation | 
			executed := true.
			self assert: operation class identicalTo: RFTempRead.
			self assert: operation value equals: 3 ];
		selector: #value:;
		control: #after;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: executed! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendSelector
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(selector).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: #+! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifyClassVariableVariable
	| classVar instance |
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new 
		metaObject: self; 
		selector: #tagExec:;
		arguments: #(variable).
	classVar link: link.
	self assert: classVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: (tag isNil).
	instance := ReflectivityExamples new.
	self assert: instance exampleClassVarRead equals: #AClassVar.
	self assert: tag equals: classVar.! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendArguments2
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleSendTwoArgs) ast body
		statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(arguments).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleSendTwoArgs) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleSendTwoArgs equals: #(1 2).
	self assert: tag equals: #(1 2)! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifyArguments2level
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleSendTwoArgs) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(arguments);
		level: 0.
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleSendTwoArgs) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self deny: (Processor activeProcess isMeta).
	self assert: instance exampleSendTwoArgs equals: #(1 2).
	self deny: (Processor activeProcess isMeta).
	self assert: tag equals: #(1 2)! !

!ReflectivityReificationTest methodsFor: 'tests - method' stamp: ''!
testReifyMethodThisContextAfter
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(context).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag class equals: Context.
	self deny: tag isBlockContext.! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifySlotOperation
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag class identicalTo: RFSlotRead.
	self deny: tag equals: 'ivar'.
	self assert: tag value equals: 33! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifySlotValue
	| iVar instance |
	iVar := ReflectivityExamples slotNamed: #ivar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(value).
	iVar link: link.
	self assert: iVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleIvarRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: 33! !

!ReflectivityReificationTest methodsFor: 'tests - assignment' stamp: ''!
testReifyIndexAssigmentIvar
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignmentIvar)
		assignmentNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(index).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignmentIvar equals: 3.
	self assert: tag equals: 1! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyClassVarOperation
	| node instance |
	node := (ReflectivityExamples >> #exampleClassVarRead) ast variableNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(operation).
	node link: link.
	self assert: node hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleClassVarRead equals: #AClassVar.
	self assert: tag value equals: #AClassVar! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendThisContext
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(context).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag class equals: Context.
	! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendArgumentsLevel
	| sendNode instance|
	sendNode := (ReflectivityExamples>>#exampleMethod) ast body statements first value.
	link := MetaLink new 
		metaObject: self; 
		selector: #tagExec:;
		arguments: #(arguments);
		level: 0.
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples>>#exampleMethod) class equals: ReflectiveMethod.
	self assert: (tag isNil).
	instance := ReflectivityExamples new .
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: #(3).
! !

!ReflectivityReificationTest methodsFor: 'tests - blocks' stamp: ''!
testBlockValueAfter
	| blockNode |
	blockNode := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver.
	self assert: blockNode isBlock.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(value).
	blockNode link: link.
	self assert: blockNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleBlock identicalTo: 5.
	self assert: tag printString equals: [ 2 + 3 ] printString.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tagging' stamp: ''!
tagExec
	tag := #yes! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifyClassVariableObject
	| classVar instance |
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(object).
	classVar link: link.
	self assert: classVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleClassVarRead equals: #AClassVar.
	self assert: tag class identicalTo: ReflectivityExamples! !

!ReflectivityReificationTest methodsFor: 'tests - assignment' stamp: ''!
testReifyNewValueAssignmentAfter
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignment)
		assignmentNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(newValue).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: tag equals: 3! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendArgsAsArray
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(selector context);
		options: #(argsAsArray).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag isArray.
	self assert: tag first identicalTo: #+.
	self assert: tag second class identicalTo: Context! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifyClassVariableName
	| classVar instance |
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new 
		metaObject: self; 
		selector: #tagExec:;
		arguments: #(name).
	classVar link: link.
	self assert: classVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: (tag isNil).
	instance := ReflectivityExamples new.
	self assert: instance exampleClassVarRead equals: #AClassVar.
	self assert: tag equals: #ClassVar.! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendAll
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: #receiver;
		selector: #perform:withArguments:;
		arguments: #(selector arguments).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5! !

!ReflectivityReificationTest methodsFor: 'tests - blocks - body' stamp: ''!
testBlockSequenceArgumentsWithArg
	| blockNode |
	blockNode := (ReflectivityExamples >> #exampleBlockWithArg) ast statements first value receiver body.
	self assert: blockNode isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #before;
		arguments: #(arguments).
	blockNode link: link.
	self assert: blockNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleBlockWithArg) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleBlockWithArg identicalTo: 5.
	self assert: tag equals: #(2).
	self assert: (ReflectivityExamples >> #exampleBlockWithArg) class equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tests - method' stamp: ''!
testReifyMethodThisContext
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(context).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag class equals: Context! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testReifyTempNewValue
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignment) ast body statements first variable.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(newValue).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: tag equals: 3! !

!ReflectivityReificationTest methodsFor: 'tests - blocks' stamp: ''!
testBlockOperationAfter
	| blockNode instance |
	blockNode := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver.
	self assert: blockNode isBlock.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(operation).
	blockNode link: link.
	self assert: blockNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleBlock identicalTo: 5.
	self assert: tag value value equals: 5.
	self assert: tag class equals: RFBlockOperation.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tests - method' stamp: ''!
testReifyMethodValue
	| methodNode instance |
	methodNode := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(value).
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: 5! !

!ReflectivityReificationTest methodsFor: 'tests - method' stamp: ''!
testReifyMethodReceiver
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(receiver).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: instance! !

!ReflectivityReificationTest methodsFor: 'tests - method - body' stamp: ''!
testReifyMethodBodyArgsInstead
	| sequenceNode instance |
	sequenceNode := (ReflectivityExamples >> #exampleWithArg:) ast body.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #instead;
		arguments: #(arguments).
	sequenceNode link: link.
	self assert: sequenceNode isSequence.
	self assert: sequenceNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleWithArg:) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: self.
	self assert: tag equals: #(3)! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyOperationSendInstead
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #instead;
		arguments: #(operation).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: self.
	self assert: tag value equals: 5! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendValue
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(value).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: 5! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifyGlobalVariableValue
	| globalVar instance |
	globalVar := GlobalForTesting binding.
	link := MetaLink new 
		metaObject: self; 
		selector: #tagExec:;
		arguments: #(name).
	globalVar link: link.
	self assert: globalVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleGlobalRead) class equals: ReflectiveMethod.
	self assert: (tag isNil).
	instance := ReflectivityExamples new.
	self assert: instance exampleGlobalRead equals: GlobalForTesting.
	self assert: tag equals: #GlobalForTesting.! !

!ReflectivityReificationTest methodsFor: 'tests - options' stamp: ''!
testReifyOptionArgsAsArray
	" test that we can pass all arguments in an array"

	| methodNode |
	methodNode := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: [ :aReceiver :aSelector :args :mylink | 
			tag := #yes.
			self assert: aReceiver class equals: ReflectivityExamples.
			self assert: aSelector equals: #exampleMethod.
			self assert: args equals: #().
			self assert: link identicalTo: link ];
		selector: #valueWithArguments:;
		option: #(+ argsAsArray);
		arguments: #(object selector arguments link);
		control: #after.
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tests - assignment' stamp: ''!
testReifyNewValueAssignmentBefore
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignment) assignmentNodes first.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(newValue).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: tag equals: 3! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifySlotClass
	| iVar instance |
	iVar := ReflectivityExamples slotNamed: #ivar.
	link := MetaLink new 
		metaObject: self; 
		selector: #tagExec:;
		arguments: #(class).
	iVar link: link.
	self assert: iVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleIvarRead) class equals: ReflectiveMethod.
	self assert: (tag isNil).
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: ReflectivityExamples.! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testReifyGlobalVariable
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleGlobalRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(variable).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleGlobalRead equals: GlobalForTesting.
	self assert: tag class identicalTo: GlobalVariable! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendAfterMany
	"test to reify a lot after"
	| sendNode instance executed |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	executed := false.
		link := MetaLink new
		metaObject: [ :s :r :a :v | self assert: v equals: 5. executed := true ];
		selector: #value:value:value:value:;
		control: #after;
		arguments: #(selector receiver arguments value).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: executed.! !

!ReflectivityReificationTest methodsFor: 'tests - method - body' stamp: ''!
testReifyMethodBodyArgsBefore
	| sequenceNode instance |
	sequenceNode := (ReflectivityExamples >> #exampleWithArg:) ast body.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #before;
		arguments: #(arguments).
	sequenceNode link: link.
	self assert: sequenceNode isSequence.
	self assert: sequenceNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleWithArg:) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: tag equals: #(3)! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendThisContextAfter
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(context).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag class equals: Context.
	self deny: tag isBlockContext.
	! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifyReceiverOnSendWithArguments
	| sendNode instance beforeSize |
	sendNode := (ReflectivityExamples>>#exampleSendNoReturn) ast body statements last.
	beforeSize := 0.
	link := MetaLink new 
		metaObject: [:receiver | beforeSize := receiver size]; 
		selector: #value:;
		control: #before;
		arguments: #(receiver).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples>>#exampleSendNoReturn) class equals: ReflectiveMethod.
	self assert: beforeSize equals: 0.
	instance := ReflectivityExamples new .
	instance exampleSendNoReturn.
	self assert: beforeSize equals: 2.! !

!ReflectivityReificationTest methodsFor: 'tests - method' stamp: ''!
testReifyMethodArgsAfter
	| methodNode instance |
	methodNode := (ReflectivityExamples >> #exampleWithArg:) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(arguments).
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleWithArg:) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: tag equals: #(3)! !

!ReflectivityReificationTest methodsFor: 'tests - allnodes' stamp: ''!
testReifyOrigMethod
	| varNode instance origMethod |
	origMethod := ReflectivityExamples >> #exampleIvarRead.
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(originalmethod).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self deny: tag equals: ReflectivityExamples >> #exampleIvarRead.
	self assert: tag identicalTo: origMethod! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyReturnOperation
	"operation on return makes only sense for #instead (as else the return already was done)"
	"
	| returnNode reachHere instance |
	
	returnNode := (ReflectivityExamples >> #exampleAssignment) ast body statements last.
	reachHere := false.
	link := MetaLink new
		metaObject: [:operation | reachHere := true. operation value];
		selector: #value:;
		control: #instead;
		arguments: #(operation).
	returnNode link: link.
	self assert: returnNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: reachHere."! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifyCascadeValue
	| cascadeNode instance |
	cascadeNode := (ReflectivityExamples >> #exampleCascade) ast statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(value).
	cascadeNode link: link.
	self assert: cascadeNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleCascade) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleCascade equals: 1.
	self assert: tag equals: 1! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifySlotVariable
	| iVar instance |
	iVar := ReflectivityExamples slotNamed: #ivar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(variable).
	iVar link: link.
	self assert: iVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleIvarRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: iVar! !

!ReflectivityReificationTest methodsFor: 'running' stamp: ''!
tearDown
	link ifNotNil: [ link uninstall ].
	super tearDown ! !

!ReflectivityReificationTest methodsFor: 'tests - blocks - body' stamp: ''!
testBlockSequenceArgumentsWithArgAfter
	| blockNode |
	blockNode := (ReflectivityExamples >> #exampleBlockWithArg) ast statements first value receiver body.
	self assert: blockNode isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(arguments).
	blockNode link: link.
	self assert: blockNode hasMetalinkAfter.
	self assert: (ReflectivityExamples >> #exampleBlockWithArg) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleBlockWithArg identicalTo: 5.
	self assert: tag equals: #(2).
	self assert: (ReflectivityExamples >> #exampleBlockWithArg) class equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tests - method' stamp: ''!
testReifyMethodSelector
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(selector).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: #exampleMethod! !

!ReflectivityReificationTest methodsFor: 'tests - allnodes' stamp: ''!
testReifyObject
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(object).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: instance.
	self
		assert: (ReflectivityExamples >> #exampleMethod) class
		equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifySlotName
	| iVar instance |
	iVar := ReflectivityExamples slotNamed: #ivar.
	link := MetaLink new 
		metaObject: self; 
		selector: #tagExec:;
		arguments: #(name).
	iVar link: link.
	self assert: iVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleIvarRead) class equals: ReflectiveMethod.
	self assert: (tag isNil).
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: #ivar.! !

!ReflectivityReificationTest methodsFor: 'tests - method - body' stamp: ''!
testReifyMethodBodyArgsAfter
	| sequenceNode instance |
	sequenceNode := (ReflectivityExamples >> #exampleWithArg:) ast body.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(arguments).
	sequenceNode link: link.
	self assert: sequenceNode isSequence.
	self assert: sequenceNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleWithArg:) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: tag equals: #(3)! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyAssignmentClassVarOperationInstead
	| varNode instance reachHere |
	varNode := (ReflectivityExamples >> #exampleAssignmentClassVar) assignmentNodes first.
	reachHere := false.
	link := MetaLink new
		metaObject: [:operation | reachHere := true. operation value];
		selector: #value:;
		control: #instead;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignmentClassVar equals: 3.
	self assert: reachHere.! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifyClassVariableEntity
	| classVar instance |
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(entity).
	classVar link: link.
	self assert: classVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleClassVarRead identicalTo: #AClassVar.
	self assert: tag equals: classVar! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyAssignmentClassVarOperationBefore
	| varNode instance reachHere |
	varNode := (ReflectivityExamples >> #exampleAssignmentClassVar) assignmentNodes first.
	reachHere := false.
	link := MetaLink new
		metaObject: [:operation | reachHere := true. self assert: operation value equals: 3];
		selector: #value:;
		control: #before;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignmentClassVar equals: 3.
	self assert: reachHere.! !

!ReflectivityReificationTest methodsFor: 'tests - misc' stamp: ''!
testReifyLiteralArrayContext
	| literalArrayNode instance |
	literalArrayNode := (ReflectivityExamples >> #exampleLiteralArray) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #before;
		arguments: #(context).
	literalArrayNode link: link.
	self assert: literalArrayNode hasMetalink.
	self
		assert: (ReflectivityExamples >> #exampleLiteralArray) class
		equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleLiteralArray equals: #(1).
	self assert: tag class identicalTo: Context.! !

!ReflectivityReificationTest methodsFor: 'tests - misc' stamp: ''!
testReifyArrayOperationAfter
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleArray) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(operation).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleArray) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleArray equals: #(3).
	self assert: tag value equals: #(3)! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testReifyIvarVariable
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(variable).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: (tag isKindOf: Slot)! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyAssignmentTempOperationAfter
	| varNode instance reachHere |
	varNode := (ReflectivityExamples >> #exampleAssignment) assignmentNodes first.
	reachHere := false.
	link := MetaLink new
		metaObject: [:operation | reachHere := true. operation value];
		selector: #value:;
		control: #after;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: reachHere.! !

!ReflectivityReificationTest methodsFor: 'tests - misc' stamp: ''!
testReifyArrayOperationInstead
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleArray) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #instead;
		arguments: #(operation).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self
		assert: (ReflectivityExamples >> #exampleArray) class
		equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleArray equals: self.
	self assert: tag value equals: #(3)! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testReifyIvarValue
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(value).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: 33! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyOperationMethod
	| methodNode instance |
	methodNode := (ReflectivityExamples >> #exampleWithArg:) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #before;
		arguments: #(operation).
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleWithArg:) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: tag value equals: 5! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testReifyGlobalName
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleGlobalRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(name).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleGlobalRead equals: GlobalForTesting.
	self assert: tag equals: #GlobalForTesting! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifySlotOperationAfter
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag class identicalTo: RFSlotRead.
	self deny: tag equals: 'ivar'.
	self assert: tag value equals: 33! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyOperationMethodAfter
	| methodNode instance |
	methodNode := (ReflectivityExamples >> #exampleWithArg:) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(operation).
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleWithArg:) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: tag class identicalTo: RFMethodOperation.
	self assert: tag value equals: 5! !

!ReflectivityReificationTest methodsFor: 'tests - method' stamp: ''!
testReifyMethodArgsAfter2
	| methodNode |
	methodNode := (ReflectivityExamples >> #exampleMethod) ast.
	link := MetaLink new
		metaObject: [ :aReceiver :aSelector :args :mylink | 
			tag := #yes.
			self assert: aReceiver class equals: ReflectivityExamples.
			self assert: aSelector equals: #exampleMethod.
			self assert: args equals: #().
			self assert: link identicalTo: link ];
		selector: #value:value:value:value:;
		arguments: #(object selector arguments link);
		control: #after.
	methodNode link: link.
	self assert: methodNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleMethod equals: 5.
	self assert: tag equals: #yes.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tests - blocks' stamp: ''!
testBlockOperationInstead
	| blockNode instance |
	blockNode := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver.
	self assert: blockNode isBlock.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #instead;
		arguments: #(operation).
	blockNode link: link.
	self assert: blockNode hasMetalinkInstead.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleBlock identicalTo: self.
	self assert: tag value value equals: 5.
	self assert: tag class equals: RFBlockOperation.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tests - allnodes' stamp: ''!
testReifyNode
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(node).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: varNode! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifyClassVariableContext
	| classVar instance |
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(context).
	classVar link: link.
	self assert: classVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleClassVarRead equals: #AClassVar.
	self assert: tag class identicalTo: Context! !

!ReflectivityReificationTest methodsFor: 'tests - variables' stamp: ''!
testReifyClassVariableLink
	| classVar instance |
	classVar := ReflectivityExamples classVariableNamed: #ClassVar.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(link).
	classVar link: link.
	self assert: classVar hasMetalink.
	self assert: (ReflectivityExamples >> #exampleClassVarRead) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleClassVarRead equals: #AClassVar.
	self assert: tag identicalTo: link! !

!ReflectivityReificationTest methodsFor: 'tests - method' stamp: ''!
testReifyMethodArgs
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleWithArg:) ast.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(arguments).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleWithArg:) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: tag equals: #(3)! !

!ReflectivityReificationTest methodsFor: 'tests - misc' stamp: ''!
testReifyArrayOperationBefore
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleArray) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #before;
		arguments: #(operation).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleArray) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleArray equals: #(3).
	self assert: tag class equals: Array.
	self assert: tag value equals: #(3)! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testReifyIvarIndex
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(index).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: 33.
	self assert: tag equals: 1! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyAssignmentSlotOperationAfter
	| varNode instance reachHere |
	varNode := (ReflectivityExamples >> #exampleAssignmentIvar) assignmentNodes first.
	reachHere := false.
	link := MetaLink new
		metaObject: [:operation | reachHere := true. self assert: operation value equals: 3];
		selector: #value:;
		control: #after;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignmentIvar equals: 3.
	self assert: reachHere.! !

!ReflectivityReificationTest methodsFor: 'tests - variablenodes' stamp: ''!
testAccessTemp
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleAssignment) ast body statements second.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: {(RBVariableNode named: #temp)}.
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignment equals: 3.
	self assert: tag equals: 3! !

!ReflectivityReificationTest methodsFor: 'tests - blocks' stamp: ''!
testBlockOperationBefore
	| blockNode |
	blockNode := (ReflectivityExamples >> #exampleBlock) ast statements first value receiver.
	self assert: blockNode isBlock.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #before;
		arguments: #(operation).
	blockNode link: link.
	self assert: blockNode hasMetalinkBefore.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleBlock identicalTo: 5.
	self assert: tag class equals: RFBlockOperation.
	self assert: tag value value equals: 5.
	self assert: (ReflectivityExamples >> #exampleBlock) class equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifySlotOperationInstead
	| varNode instance |
	varNode := (ReflectivityExamples >> #exampleIvarRead) ast body statements last value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #instead;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleIvarRead equals: self.
	self assert: tag class identicalTo: RFSlotRead.
	self deny: tag equals: 'ivar'.
	self assert: tag value equals: 33! !

!ReflectivityReificationTest methodsFor: 'tests - operations' stamp: ''!
testReifyAssignmentSlotOperationBefore
	| varNode instance reachHere |
	varNode := (ReflectivityExamples >> #exampleAssignmentIvar) assignmentNodes first.
	reachHere := false.
	link := MetaLink new
		metaObject: [:operation | reachHere := true. self assert: operation value equals: 3];
		selector: #value:;
		control: #before;
		arguments: #(operation).
	varNode link: link.
	self assert: varNode hasMetalink.
	instance := ReflectivityExamples new.
	self assert: instance exampleAssignmentIvar equals: 3.
	self assert: reachHere.! !

!ReflectivityReificationTest methodsFor: 'tests - blocks - body' stamp: ''!
testBlockSequenceArgumentsWithArgAfterInstead
	| blockNode |
	blockNode := (ReflectivityExamples >> #exampleBlockWithArg) ast statements first value receiver body.
	self assert: blockNode isSequence.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #instead;
		arguments: #(arguments).
	blockNode link: link.
	self assert: blockNode hasMetalinkInstead.
	self assert: (ReflectivityExamples >> #exampleBlockWithArg) class equals: ReflectiveMethod.
	self assert: tag isNil.
	self assert: ReflectivityExamples new exampleBlockWithArg identicalTo: self.
	self assert: tag equals: #(2).
	self assert: (ReflectivityExamples >> #exampleBlockWithArg) class equals: CompiledMethod! !

!ReflectivityReificationTest methodsFor: 'tests - sends' stamp: ''!
testReifySendReceiver
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleMethod) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		arguments: #(receiver).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleMethod) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleMethod equals: 5.
	self assert: tag equals: 2! !

!ReflectivityReificationTest methodsFor: 'tests - misc' stamp: ''!
testReifyArrayValue
	| sendNode instance |
	sendNode := (ReflectivityExamples >> #exampleArray) ast body statements first value.
	link := MetaLink new
		metaObject: self;
		selector: #tagExec:;
		control: #after;
		arguments: #(value).
	sendNode link: link.
	self assert: sendNode hasMetalink.
	self assert: (ReflectivityExamples >> #exampleArray) class equals: ReflectiveMethod.
	self assert: tag isNil.
	instance := ReflectivityExamples new.
	self assert: instance exampleArray equals: #(3).
	self assert: tag equals: #(3)! !

!ReflectivityReificationTest methodsFor: 'tests - misc' stamp: ''!
testLiteralOperationAfter
	| literalNode |
	literalNode := (ReflectivityExamples >> #exampleLiteral) ast statements first value.
	self assert: literalNode isLiteralNode.
	link := MetaLink new
		metaObject: [ :value | self assert: value value equals: 2 ];
		selector: #value:;
		arguments: #(operation);
		control: #after.
	literalNode link: link.
	self assert: literalNode hasMetalinkAfter.
	self assert: ReflectivityExamples new exampleLiteral identicalTo: 2! !

!ReflectivitySourceCodeAgroupation commentStamp: ''!
I'm an agroupation of ReflectivityCodeMorph!
!ReflectivitySourceCodeAgroupation methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
 		layoutPolicy: TableLayout new;
		hResizing: #spaceFill; 
		vResizing: #spaceFill;
		cellInset: 10.! !

!ReflectivitySourceCodeAgroupation methodsFor: 'instance creation' stamp: ''!
newSourceCodeFor: aCompiledMethod
	self addMorph: (ReflectivityCodeMorph compiledMethod: aCompiledMethod)! !

!ReflectivitySourceCodeAgroupation methodsFor: 'initialize' stamp: ''!
defaultColor
	^UITheme current class baseColor! !

!ReflectivityTest methodsFor: 'tagging' stamp: ''!
increase
	count := count + 1.! !

!ReflectivityTest methodsFor: 'tests' stamp: ''!
testDisableThenEnableLink
	| node instance |
	node := (ReflectivityExamples >> #exampleWithArg:) ast.
	link := MetaLink new
		metaObject: self;
		selector: #increase.
	node link: link.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 1.
	link disable.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 1.
	link enable.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 2.
	self assert: link condition isNil.
! !

!ReflectivityTest methodsFor: 'running' stamp: ''!
tearDown
	link ifNotNil: [link uninstall].
	link2 ifNotNil: [link2 uninstall].
	tag := nil.
	count := 0.
	(ReflectivityExamples>>#exampleWithArg:) recompile.
	ASTCache default: cache.
	super tearDown ! !

!ReflectivityTest methodsFor: 'tests' stamp: ''!
testTwoLinksUninstallOne
	| node instance |
	node := (ReflectivityExamples >> #exampleWithArg:) ast.
	link := MetaLink new
		metaObject: self;
		selector: #increase.
	link2 := MetaLink new
		metaObject: self;
		selector: #increase.
	node link: link.
	node link: link2.
	self
		assert: (ReflectivityExamples >> #exampleWithArg:) class
		equals: ReflectiveMethod.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 2.
	node removeLink: link2.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 3! !

!ReflectivityTest methodsFor: 'tests' stamp: ''!
testDisableThenCleanASTCacheThenEnableLink
	| node instance |
	node := (ReflectivityExamples >> #exampleWithArg:) ast.
	link := MetaLink new
		metaObject: self;
		selector: #increase.
	node link: link.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 1.
	link disable.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 1.
	"Clean the AST cache"
	ASTCache default reset.
	link enable.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 2.
! !

!ReflectivityTest methodsFor: 'tests' stamp: ''!
testDisableThenEnableLinkWithCondition
	| node instance |
	node := (ReflectivityExamples >> #exampleWithArg:) ast.
	link := MetaLink new
		metaObject: self;
		condition: false;
		selector: #increase.
	node link: link.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 0.
	link disable.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 0.
	link enable.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 0.
	self assert: link condition equals: false
! !

!ReflectivityTest methodsFor: 'tests' stamp: ''!
testDisableLink
	| node instance |
	node := (ReflectivityExamples >> #exampleWithArg:) ast.
	link := MetaLink new
		metaObject: self;
		selector: #increase.
	node link: link.
	instance := ReflectivityExamples new.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 1.
	link disable.
	self assert: (instance exampleWithArg: 3) equals: 5.
	self assert: count equals: 1.! !

!ReflectivityTest methodsFor: 'tagging' stamp: ''!
tagExec
	tag := #yes! !

!ReflectivityTest methodsFor: 'tagging' stamp: ''!
tagExec: aTag
	tag := aTag! !

!ReflectivityTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	count := 0.
	cache := ASTCache default.! !

!RegexAPIDocumentation commentStamp: ''!
This is a custom help book providing the API documentation for the regular expression framework.
!
!RegexAPIDocumentation class methodsFor: 'accessing' stamp: ''!
bookName
	^'API Documentation'! !

!RegexAPIDocumentation class methodsFor: 'accessing' stamp: ''!
helpPackages
	^#('Regex-Core' 'Regex-Core-Tests')! !

!RegexAPIDocumentation class methodsFor: 'defaults' stamp: ''!
builder
	^PackageAPIHelpBuilder! !

!RegexCompilationError commentStamp: ''!
This class represents compilation errors in regular expressions.!
!RegexError commentStamp: ''!
This is a common superclass for errors in regular expressions.!
!RegexHelp commentStamp: ''!
This is a custom help book for the regular expression framework.
!
!RegexHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#(introduction whatsNew syntax usage implementationNotes license)! !

!RegexHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^'Regular expressions framework'! !

!RegexHelp class methodsFor: 'pages' stamp: ''!
implementationNotes
	"This method was automatically generated. Edit it using:"
	"RegexHelp edit: #implementationNotes"
	^HelpTopic
		title: 'Implementation notes'
		contents: 
'Version:		1.1
	Released:		October 1999
	Mail to:		Vassili Bykov <vassili@parcplace.com>, <v_bykov@yahoo.com>
	Flames to:		/dev/null

	WHAT IS ADDED

The matcher includes classes in two categories:
	VB-Regex-Syntax
	VB-Regex-Matcher
and a few CharacterArray methods in `VB-regex'' protocol.  No system
classes or methods are modified.

	WHAT TO LOOK AT FIRST

String>>matchesRegex: -- in 90% cases this method is all you need to
access the package.

RxParser -- accepts a string or a stream of characters with a regular
expression, and produces a syntax tree corresponding to the
expression. The tree is made of instances of Rxs<whatever> classes.

RxMatcher -- accepts a syntax tree of a regular expression built by
the parser and compiles it into a matcher: a structure made of
instances of Rxm<whatever> classes. The RxMatcher instance can test
whether a string or a positionable stream of characters matches the
original regular expression, or search a string or a stream for
substrings matching the expression. After a match is found, the
matcher can report a specific string that matched the whole
expression, or any parenthesized subexpression of it.

All other classes support the above functionality and are used by
RxParser, RxMatcher, or both.

	CAVEATS

The matcher is similar in spirit, but NOT in the design--let alone the
code--to the original Henry Spencer''s regular expression
implementation in C.  The focus is on simplicity, not on efficiency.
I didn''t optimize or profile anything.  I may in future--or I may not:
I do this in my spare time and I don''t promise anything.

The matcher passes H. Spencer''s test suite (see ''test suite''
protocol), with quite a few extra tests added, so chances are good
there are not too many bugs.  But watch out anyway.

	EXTENSIONS, FUTURE, ETC.

With the existing separation between the parser, the syntax tree, and
the matcher, it is easy to extend the system with other matchers based
on other algorithms. In fact, I have a DFA-based matcher right now,
but I don''t feel it is good enough to include it here.  I might add
automata-based matchers later, but again I don''t promise anything.

	HOW TO REACH ME

As of today (December 20, 2000), you can contact me at
<vassili@parcplace.com>. If this doesn''t work, look around
comp.lang.smalltalk or comp.lang.lisp.  !!' readStream nextChunkText! !

!RegexHelp class methodsFor: 'pages' stamp: ''!
introduction
	"This method was automatically generated. Edit it using:"
	"RegexHelp edit: #introduction"
	^HelpTopic
		title: 'Introduction'
		contents: 
'A regular expression is a template specifying a class of strings. A
regular expression matcher is an tool that determines whether a string
belongs to a class specified by a regular expression.  This is a
common task of a user input validation code, and the use of regular
expressions can GREATLY simplify and speed up development of such
code.  As an example, here is how to verify that a string is a valid
hexadecimal number in Smalltalk notation, using this matcher package:

	aString matchesRegex: ''16r[[:xdigit:]]+''

(Coding the same ``the hard way'''' is an exercise to a curious reader).

This matcher is offered to the Smalltalk community in hope it will be
useful. It is free in terms of money, and to a large extent--in terms
of rights of use. Refer to `Boring Stuff'' section for legalese.

The ''What''s new in this release'' section describes the functionality
introduced in 1.1 release.

The `Syntax'' section explains the recognized syntax of regular
expressions.

The `Usage'' section explains matcher capabilities that go beyond what
String>>matchesRegex: method offers.

The `Implementation notes'' sections says a few words about what is
under the hood.

Happy hacking,

--Vassili Bykov 
<vassili@objectpeople.com> <vassili@magma.ca>

August 6, 1996
April 4, 1999!!' readStream nextChunkText! !

!RegexHelp class methodsFor: 'pages' stamp: ''!
license
	"This method was automatically generated. Edit it using:"
	"RegexHelp edit: #license"
	^HelpTopic
		title: 'License'
		contents: 
'The Regular Expression Matcher (``The Software'''') 
is Copyright (C) 1996, 1999 Vassili Bykov.  
It is provided to the Smalltalk community in hope it will be useful.

1. This license applies to the package as a whole, as well as to any
   component of it. By performing any of the activities described
   below, you accept the terms of this agreement.

2. The software is provided free of charge, and ``as is'''', in hope
   that it will be useful, with ABSOLUTELY NO WARRANTY. The entire
   risk and all responsibility for the use of the software is with
   you.  Under no circumstances the author may be held responsible for
   loss of data, loss of profit, or any other damage resulting
   directly or indirectly from the use of the software, even if the
   damage is caused by defects in the software.

3. You may use this software in any applications you build.

4. You may distribute this software provided that the software
   documentation and copyright notices are included and intact.

5. You may create and distribute modified versions of the software,
   such as ports to other Smalltalk dialects or derived work, provided
   that: 

   a. any modified version is expressly marked as such and is not
   misrepresented as the original software; 

   b. credit is given to the original software in the source code and
   documentation of the derived work; 

   c. the copyright notice at the top of this document accompanies
   copyright notices of any modified version.  !!' readStream nextChunkText! !

!RegexHelp class methodsFor: 'pages' stamp: ''!
usage
	"This method was automatically generated. Edit it using:"
	"RegexHelp edit: #usage"
	^HelpTopic
		title: 'Usage'
		contents: 
'The preceding section covered the syntax of regular expressions. It
used the simplest possible interface to the matcher: sending
#matchesRegex: message to the sample string, with regular expression
string as the argument.  This section explains hairier ways of using
the matcher.

	PREFIX MATCHING AND CASE-INSENSITIVE MATCHING

A CharacterArray (an EsString in VA) also understands these messages:

	#prefixMatchesRegex: regexString
	#matchesRegexIgnoringCase: regexString
	#prefixMatchesRegexIgnoringCase: regexString

#prefixMatchesRegex: is just like #matchesRegex, except that the whole
receiver is not expected to match the regular expression passed as the
argument; matching just a prefix of it is enough.  For example:

	''abcde'' matchesRegex: ''(a|b)+''		-- false
	''abcde'' prefixMatchesRegex: ''(a|b)+''	-- true

The last two messages are case-insensitive versions of matching.

	ENUMERATION INTERFACE

An application can be interested in all matches of a certain regular
expression within a String.  The matches are accessible using a
protocol modelled after the familiar Collection-like enumeration
protocol:

	#regex: regexString matchesDo: aBlock

Evaluates a one-argument <aBlock> for every match of the regular
expression within the receiver string.

	#regex: regexString matchesCollect: aBlock

Evaluates a one-argument <aBlock> for every match of the regular
expression within the receiver string. Collects results of evaluations
and anwers them as a SequenceableCollection.

	#allRegexMatches: regexString

Returns a collection of all matches (substrings of the receiver
string) of the regular expression.  It is an equivalent of <aString
regex: regexString matchesCollect: [:each | each]>.

	#allRangesOfRegexMatches: regexString

Returns a collection of all character ranges (startIndex to: stopIndex)
that match the regular expression.

	REPLACEMENT AND TRANSLATION

It is possible to replace all matches of a regular expression with a
certain string using the message:

	#copyWithRegex: regexString matchesReplacedWith: aString

For example:

	''ab cd ab'' copyWithRegex: ''(a|b)+'' matchesReplacedWith: ''foo''

A more general substitution is match translation:

	#copyWithRegex: regexString matchesTranslatedUsing: aBlock

This message evaluates a block passing it each match of the regular
expression in the receiver string and answers a copy of the receiver
with the block results spliced into it in place of the respective
matches.  For example:

	''ab cd ab'' copyWithRegex: ''(a|b)+'' matchesTranslatedUsing: [:each | each asUppercase]

All messages of enumeration and replacement protocols perform a
case-sensitive match.  Case-insensitive versions are not provided as
part of a CharacterArray protocol.  Instead, they are accessible using
the lower-level matching interface.

	LOWER-LEVEL INTERFACE

Internally, #matchesRegex: works as follows:

1. A fresh instance of RxParser is created, and the regular expression
string is passed to it, yielding the expression''s syntax tree.

2. The syntax tree is passed as an initialization parameter to an
instance of RxMatcher. The instance sets up some data structure that
will work as a recognizer for the regular expression described by the
tree.

3. The original string is passed to the matcher, and the matcher
checks for a match.

	THE MATCHER

If you repeatedly match a number of strings against the same regular
expression using one of the messages defined in CharacterArray, the
regular expression string is parsed and a matcher is created anew for
every match.  You can avoid this overhead by building a matcher for
the regular expression, and then reusing the matcher over and over
again. You can, for example, create a matcher at a class or instance
initialization stage, and store it in a variable for future use.

You can create a matcher using one of the following methods:

	- Sending #forString:ignoreCase: message to RxMatcher class, with
the regular expression string and a Boolean indicating whether case is
ignored as arguments.

	- Sending #forString: message.  It is equivalent to <... forString:
regexString ignoreCase: false>.

A more convenient way is using one of the two matcher-created messages
understood by CharacterArray.

	- <regexString asRegex> is equivalent to <RxMatcher forString:
regexString>.

	- <regexString asRegexIgnoringCase> is equivalent to <RxMatcher
forString: regexString ignoreCase: true>.

Here are four examples of creating a matcher:

	hexRecognizer := RxMatcher forString: ''16r[0-9A-Fa-f]+''
	hexRecognizer := RxMatcher forString: ''16r[0-9A-Fa-f]+'' ignoreCase: false
	hexRecognizer := ''16r[0-9A-Fa-f]+'' asRegex
	hexRecognizer := ''16r[0-9A-F]+'' asRegexIgnoringCase

	MATCHING

The matcher understands these messages (all of them return true to
indicate successful match or search, and false otherwise):

matches: aString

	True if the whole target string (aString) matches.

matchesPrefix: aString

	True if some prefix of the string (not necessarily the whole
	string) matches.

search: aString

	Search the string for the first occurrence of a matching
	substring. (Note that the first two methods only try matching from
	the very beginning of the string). Using the above example with a
	matcher for `a+'', this method would answer success given a string
	`baaa'', while the previous two would fail.

matchesStream: aStream
matchesStreamPrefix: aStream
searchStream: aStream

	Respective analogs of the first three methods, taking input from a
	stream instead of a string. The stream must be positionable and
	peekable.

All these methods answer a boolean indicating success. The matcher
also stores the outcome of the last match attempt and can report it:

lastResult

	Answers a Boolean -- the outcome of the most recent match
	attempt. If no matches were attempted, the answer is unspecified.

	SUBEXPRESSION MATCHES

After a successful match attempt, you can query the specifics of which
part of the original string has matched which part of the whole
expression.

A subexpression is a parenthesized part of a regular expression, or
the whole expression. When a regular expression is compiled, its
subexpressions are assigned indices starting from 1, depth-first,
left-to-right. For example, `((ab)+(c|d))?ef'' includes the following
subexpressions with these indices:

	1:	((ab)+(c|d))?ef
	2:	(ab)+(c|d)
	3:	ab
	4:	c|d

After a successful match, the matcher can report what part of the
original string matched what subexpression. It understandards these
messages:

subexpressionCount

	Answers the total number of subexpressions: the highest value that
	can be used as a subexpression index with this matcher. This value
	is available immediately after initialization and never changes.

subexpression: anIndex

	An index must be a valid subexpression index, and this message
	must be sent only after a successful match attempt. The method
	answers a substring of the original string the corresponding
	subexpression has matched to.

subBeginning: anIndex
subEnd: anIndex

	Answer positions within the original string or stream where the
	match of a subexpression with the given index has started and
	ended, respectively.

This facility provides a convenient way of extracting parts of input
strings of complex format. For example, the following piece of code
uses the ''MMM DD, YYYY'' date format recognizer example from the
`Syntax'' section to convert a date to a three-element array with year,
month, and day strings (you can select and evaluate it right here):

	| matcher |
	matcher := RxMatcher forString: ''(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ]+(:isDigit::isDigit:?)[ ]*,[ ]*(19|20)(:isDigit::isDigit:)''.
	(matcher matches: ''Aug 6, 1996'')
		ifTrue: 
			[Array 
				with: (matcher subexpression: 5)
				with: (matcher subexpression: 2)
				with: (matcher subexpression: 3)]
		ifFalse: [''no match'']

(should answer ` #(''96'' ''Aug'' ''6'')'').

	ENUMERATION AND REPLACEMENT

The enumeration and replacement protocols exposed in CharacterArray
are actually implemented by the matcher.  The following messages are
understood:

	#matchesIn: aString
	#matchesIn: aString do: aBlock
	#matchesIn: aString collect: aBlock
	#copy: aString replacingMatchesWith: replacementString
	#copy: aString translatingMatchesUsing: aBlock
	#matchingRangesIn: aString

	#matchesOnStream: aStream
	#matchesOnStream: aStream do: aBlock
	#matchesOnStream: aStream collect: aBlock
	#copy: sourceStream to: targetStream replacingMatchesWith: replacementString
	#copy: sourceStream to: targetStream translatingMatchesWith: aBlock

Note that in those methods that take a block, the block may refer to the rxMatcher itself, 
e.g. to collect information about the position the match occurred at, or the
subexpressions of the match. An example can be seen in #matchingRangesIn:

	ERROR HANDLING

Exception signaling objects (Signals in VisualWorks, Exceptions in VisualAge) are
accessible through RxParser class protocol. To handle possible errors, use
the protocol described below to obtain the exception objects and use the
protocol of the native Smalltalk implementation to handle them.

If a syntax error is detected while parsing expression,
RxParser>>syntaxErrorSignal is raised/signaled.

If an error is detected while building a matcher,
RxParser>>compilationErrorSignal is raised/signaled.

If an error is detected while matching (for example, if a bad selector
was specified using `:<selector>:'' syntax, or because of the matcher''s
internal error), RxParser>>matchErrorSignal is raised

RxParser>>regexErrorSignal is the parent of all three.  Since any of
the three signals can be raised within a call to #matchesRegex:, it is
handy if you want to catch them all.  For example:

VisualWorks:

	RxParser regexErrorSignal
		handle: [:ex | ex returnWith: nil]
		do: [''abc'' matchesRegex: ''))garbage['']

VisualAge:

	[''abc'' matchesRegex: ''))garbage['']
		when: RxParser regexErrorSignal
		do: [:signal | signal exitWith: nil]
!!' readStream nextChunkText! !

!RegexHelp class methodsFor: 'pages' stamp: ''!
whatsNew
	"This method was automatically generated. Edit it using:"
	"RegexHelp edit: #whatsNew"
	^HelpTopic
		title: 'What''s new'
		contents: 
'VERSION 1.3.1 (September 2008)
1. Updated documentation of character classes, making clear the problems of locale - an area for future improvement

VERSION 1.3 (September 2008)
1. \w now matches underscore as well as alphanumerics, in line with most other regex libraries (and our documentation!!!!).  
2. \W rejects underscore as well as alphanumerics
3. added tests for this at end of testSuite
4. updated documentation and added note to old incorrect comments in version 1.1 below

VERSION 1.2.3 (November 2007)

1. Regexs with ^ or $ applied to copy empty strings caused infinite loops, e.g. ('''' copyWithRegex: ''^.*$'' matchesReplacedWith: ''foo''). Applied a similar correction to that from version 1.1c, to #copyStream:to:(replacingMatchesWith:|translatingMatchesUsing:).
2. Extended RxParser testing to run each test for #copy:translatingMatchesUsing: as well as #search:.
3. Corrected #testSuite test that a dot does not match a null, which was passing by luck with Smalltalk code in a literal array.
4. Added test to end of test suite for fix 1 above.

VERSION 1.2.2 (November 2006)

There was no way to specify a backslash in a character set. Now [\\] is accepted.

VERSION 1.2.1	(August 2006)

1. Support for returning all ranges (startIndex to: stopIndex) matching a regex - #allRangesOfRegexMatches:, #matchingRangesIn:
2. Added hint to usage documentation on how to get more information about matches when enumerating
3. Syntax description of dot corrected: matches anything but NUL since 1.1a

VERSION 1.2	(May 2006)

Fixed case-insensitive search for character sets.

VERSION 1.1c	(December 2004)

Fixed the issue with #matchesOnStream:do: which caused infinite loops for matches 
that matched empty strings.

VERSION 1.1b	(November 2001)

Changes valueNowOrOnUnwindDo: to ensure:, plus incorporates some earlier fixes.

VERSION 1.1a	(May 2001)

1. Support for keeping track of multiple subexpressions.
2. Dot (.) matches anything but NUL character, as it should per POSIX spec.
3. Some bug fixes.

VERSION 1.1	(October 1999)

Regular expression syntax corrections and enhancements:

1. Backslash escapes similar to those in Perl are allowed in patterns:

	\w	any word constituent character (equivalent to [a-zA-Z0-9_]) *** underscore only since 1.3 ***
	\W	any character but a word constituent (equivalent to [^a-xA-Z0-9_] *** underscore only since 1.3 ***
	\d	a digit (same as [0-9])
	\D	anything but a digit
	\s 	a whitespace character
	\S	anything but a whitespace character
	\b	an empty string at a word boundary
	\B	an empty string not at a word boundary
	\<	an empty string at the beginning of a word
	\>	an empty string at the end of a word

For example, ''\w+'' is now a valid expression matching any word.

2. The following backslash escapes are also allowed in character sets
(between square brackets):

	\w, \W, \d, \D, \s, and \S.

3. The following grep(1)-compatible named character classes are
recognized in character sets as well:

	[:alnum:]
	[:alpha:]
	[:cntrl:]
	[:digit:]
	[:graph:]
	[:lower:]
	[:print:]
	[:punct:]
	[:space:]
	[:upper:]
	[:xdigit:]

For example, the following patterns are equivalent:

	''[[:alnum:]_]+'' ''\w+''  ''[\w]+'' ''[a-zA-Z0-9_]+'' *** underscore only since 1.3 ***

4. Some non-printable characters can be represented in regular
expressions using a common backslash notation:

	\t	tab (Character tab)
	\n	newline (Character lf)
	\r	carriage return (Character cr)
	\f	form feed (Character newPage)
	\e	escape (Character esc)

5. A dot is corectly interpreted as ''any character but a newline''
instead of ''anything but whitespace''.

6. Case-insensitive matching.  The easiest access to it are new
messages CharacterArray understands: #asRegexIgnoringCase,
#matchesRegexIgnoringCase:, #prefixMatchesRegexIgnoringCase:.

7. The matcher (an instance of RxMatcher, the result of
String>>asRegex) now provides a collection-like interface to matches
in a particular string or on a particular stream, as well as
substitution protocol. The interface includes the following messages:

	matchesIn: aString
	matchesIn: aString collect: aBlock
	matchesIn: aString do: aBlock

	matchesOnStream: aStream
	matchesOnStream: aStream collect: aBlock
	matchesOnStream: aStream do: aBlock

	copy: aString translatingMatchesUsing: aBlock
	copy: aString replacingMatchesWith: replacementString

	copyStream: aStream to: writeStream translatingMatchesUsing: aBlock
	copyStream: aStream to: writeStream replacingMatchesWith: aString

Examples:

	''\w+'' asRegex matchesIn: ''now is the time''

returns an OrderedCollection containing four strings: ''now'', ''is'',
''the'', and ''time''.

	''\<t\w+'' asRegexIgnoringCase
		copy: ''now is the Time''
		translatingMatchesUsing: [:match | match asUppercase]

returns ''now is THE TIME'' (the regular expression matches words
beginning with either an uppercase or a lowercase T).

ACKNOWLEDGEMENTS

Since the first release of the matcher, thanks to the input from
several fellow Smalltalkers, I became convinced a native Smalltalk
regular expression matcher was worth the effort to keep it alive. For
the contributions, suggestions, and bug reports that made this release 
possible, I want to thank:

	Felix Hack
	Peter Hatch
	Alan Knight
	Eliot Miranda
	Thomas Muhr
	Robb Shecter
	David N. Smith
	Francis Wolinski

and anyone whom I haven''t yet met or heard from, but who agrees this
has not been a complete waste of time.

--Vassili Bykov
October 3, 1999!!' readStream nextChunkText! !

!RegexHelp class methodsFor: 'pages' stamp: ''!
syntax
	"This method was automatically generated. Edit it using:"
	"RegexHelp edit: #syntax"
	^HelpTopic
		title: 'Syntax'
		contents: 
'[You can select and "print it'' examples in this method. Just don''t
forget to cancel the changes.]

The simplest regular expression is a single character.  It matches
exactly that character. A sequence of characters matches a string with
exactly the same sequence of characters:

	''a'' matchesRegex: ''a''				-- true
	''foobar'' matchesRegex: ''foobar''		-- true
	''blorple'' matchesRegex: ''foobar''		-- false

The above paragraph introduced a primitive regular expression (a
character), and an operator (sequencing). Operators are applied to
regular expressions to produce more complex regular expressions.
Sequencing (placing expressions one after another) as an operator is,
in a certain sense, `invisible''--yet it is arguably the most common.

A more `visible'' operator is Kleene closure, more often simply
referred to as `a star''.  A regular expression followed by an asterisk
matches any number (including 0) of matches of the original
expression. For example:

	''ab'' matchesRegex: ''a*b''		 		-- true
	''aaaaab'' matchesRegex: ''a*b''	 	-- true
	''b'' matchesRegex: ''a*b''		 		-- true
	''aac'' matchesRegex: ''a*b''	 		-- false: b does not match

A star''s precedence is higher than that of sequencing. A star applies
to the shortest possible subexpression that precedes it. For example,
''ab*'' means `a followed by zero or more occurrences of b'', not `zero
or more occurrences of ab'':

	''abbb'' matchesRegex: ''ab*''	 		-- true
	''abab'' matchesRegex: ''ab*''		 	-- false

To actually make a regex matching `zero or more occurrences of ab'',
`ab'' is enclosed in parentheses:

	''abab'' matchesRegex: ''(ab)*''		 	-- true
	''abcab'' matchesRegex: ''(ab)*''	 	-- false: c spoils the fun

Two other operators similar to `*'' are `+'' and `?''. `+'' (positive
closure, or simply `plus'') matches one or more occurrences of the
original expression. `?'' (`optional'') matches zero or one, but never
more, occurrences.

	''ac'' matchesRegex: ''ab*c''	 		-- true
	''ac'' matchesRegex: ''ab+c''	 		-- false: need at least one b
	''abbc'' matchesRegex: ''ab+c''		 	-- true
	''abbc'' matchesRegex: ''ab?c''		 	-- false: too many b''s

As we have seen, characters `*'', `+'', `?'', `('', and `)'' have special
meaning in regular expressions. If one of them is to be used
literally, it should be quoted: preceded with a backslash. (Thus,
backslash is also special character, and needs to be quoted for a
literal match--as well as any other special character described
further).

	''ab*'' matchesRegex: ''ab*''		 	-- false: star in the right string is special
	''ab*'' matchesRegex: ''ab\*''	 		-- true
	''a\c'' matchesRegex: ''a\\c''		 	-- true

The last operator is `|'' meaning `or''. It is placed between two
regular expressions, and the resulting expression matches if one of
the expressions matches. It has the lowest possible precedence (lower
than sequencing). For example, `ab*|ba*'' means `a followed by any
number of b''s, or b followed by any number of a''s'':

	''abb'' matchesRegex: ''ab*|ba*''	 	-- true
	''baa'' matchesRegex: ''ab*|ba*''	 	-- true
	''baab'' matchesRegex: ''ab*|ba*''	 	-- false

A bit more complex example is the following expression, matching the
name of any of the Lisp-style `car'', `cdr'', `caar'', `cadr'',
... functions:

	c(a|d)+r

It is possible to write an expression matching an empty string, for
example: `a|''.  However, it is an error to apply `*'', `+'', or `?'' to
such expression: `(a|)*'' is an invalid expression.

So far, we have used only characters as the ''smallest'' components of
regular expressions. There are other, more `interesting'', components.

A character set is a string of characters enclosed in square
brackets. It matches any single character if it appears between the
brackets. For example, `[01]'' matches either `0'' or `1'':

	''0'' matchesRegex: ''[01]''		 		-- true
	''3'' matchesRegex: ''[01]''		 		-- false
	''11'' matchesRegex: ''[01]''		 		-- false: a set matches only one character

Using plus operator, we can build the following binary number
recognizer:

	''10010100'' matchesRegex: ''[01]+''	 	-- true
	''10001210'' matchesRegex: ''[01]+''	 	-- false

If the first character after the opening bracket is `^'', the set is
inverted: it matches any single character *not* appearing between the
brackets:

	''0'' matchesRegex: ''[^01]''		  		-- false
	''3'' matchesRegex: ''[^01]''		 		-- true

For convenience, a set may include ranges: pairs of characters
separated with `-''. This is equivalent to listing all characters
between them: `[0-9]'' is the same as `[0123456789]''.

Special characters within a set are `^'', `-'', and `]'' that closes the
set. Below are the examples of how to literally use them in a set:

	[01^]		-- put the caret anywhere except the beginning
	[01-]		-- put the dash as the last character
	[]01]		-- put the closing bracket as the first character 
	[^]01]			(thus, empty and universal sets cannot be specified)

Regular expressions can also include the following backquote escapes
to refer to popular classes of characters:

	\w	any word constituent character (same as [a-zA-Z0-9_])
	\W	any character but a word constituent
	\d	a digit (same as [0-9])
	\D	anything but a digit
	\s 	a whitespace character (same as [:space:] below)
	\S	anything but a whitespace character

These escapes are also allowed in character classes: ''[\w+-]'' means
''any character that is either a word constituent, or a plus, or a
minus''.

Character classes can also include the following grep(1)-compatible
elements to refer to:

	[:alnum:]		any alphanumeric character (same as [a-zA-Z0-9])
	[:alpha:]		any alphabetic character (same as [a-zA-Z])
	[:cntrl:]		any control character. (any character with code < 32)
	[:digit:]		any decimal digit (same as [0-9])
	[:graph:]		any graphical character. (any character with code >= 32).
	[:lower:]		any lowercase character (including non-ASCII lowercase characters)
	[:print:]		any printable character. In this version, this is the same as [:graph:]
	[:punct:]		any punctuation character:  . , !!!! ? ; : '' - ( ) ` and double quotes
	[:space:]		any whitespace character (space, tab, CR, LF, null, form feed, Ctrl-Z, 16r2000-16r200B, 16r3000)
	[:upper:]		any uppercase character (including non-ASCII uppercase characters)
	[:xdigit:]		any hexadecimal character (same as [a-fA-F0-9]).

Note that many of these are only as consistent or inconsistent on issues
of locale as the underlying Smalltalk implementation. Values shown here
are for VisualWorks 7.6.

Note that these elements are components of the character classes,
i.e. they have to be enclosed in an extra set of square brackets to
form a valid regular expression.  For example, a non-empty string of
digits would be represented as ''[[:digit:]]+''.

The above primitive expressions and operators are common to many
implementations of regular expressions. The next primitive expression
is unique to this Smalltalk implementation.

A sequence of characters between colons is treated as a unary selector
which is supposed to be understood by Characters. A character matches
such an expression if it answers true to a message with that
selector. This allows a more readable and efficient way of specifying
character classes. For example, `[0-9]'' is equivalent to `:isDigit:'',
but the latter is more efficient. Analogously to character sets,
character classes can be negated: `:^isDigit:'' matches a Character
that answers false to #isDigit, and is therefore equivalent to
`[^0-9]''.

As an example, so far we have seen the following equivalent ways to
write a regular expression that matches a non-empty string of digits:

	''[0-9]+''
	''\d+''
	''[\d]+''
	''[[:digit:]]+''
	:isDigit:+''

The last group of special primitive expressions includes: 

	.	matching any character except a NULL; 
	^	matching an empty string at the beginning of a line; 
	$	matching an empty string at the end of a line.
	\b	an empty string at a word boundary
	\B	an empty string not at a word boundary
	\<	an empty string at the beginning of a word
	\>	an empty string at the end of a word

	''axyzb'' matchesRegex: ''a.+b''		-- true
	''ax zb'' matchesRegex: ''a.+b''			-- true (space is matched by `.'')
	''ax
zb'' matchesRegex: ''a.+b''				-- true (carriage return is matched by `.'')

Again, the dot ., caret ^ and dollar $ characters are special and should be quoted
to be matched literally.

	EXAMPLES

As the introductions said, a great use for regular expressions is user
input validation. Following are a few examples of regular expressions
that might be handy in checking input entered by the user in an input
field. Try them out by entering something between the quotes and
print-iting. (Also, try to imagine Smalltalk code that each validation
would require if coded by hand).  Most example expressions could have
been written in alternative ways.

Checking if aString may represent a nonnegative integer number:

	'''' matchesRegex: '':isDigit:+''
or
	'''' matchesRegex: ''[0-9]+''
or
	'''' matchesRegex: ''\d+''

Checking if aString may represent an integer number with an optional
sign in front:

	'''' matchesRegex: ''(\+|-)?\d+''

Checking if aString is a fixed-point number, with at least one digit
is required after a dot:

	'''' matchesRegex: ''(\+|-)?\d+(\.\d+)?''

The same, but allow notation like `123.'':

	'''' matchesRegex: ''(\+|-)?\d+(\.\d*)?''

Recognizer for a string that might be a name: one word with first
capital letter, no blanks, no digits.  More traditional:

	'''' matchesRegex: ''[A-Z][A-Za-z]*''

more Smalltalkish:

	'''' matchesRegex: '':isUppercase::isAlphabetic:*''

A date in format MMM DD, YYYY with any number of spaces in between, in
XX century:

	'''' matchesRegex: ''(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ]+(\d\d?)[ ]*,[ ]*19(\d\d)''

Note parentheses around some components of the expression above. As
`Usage'' section shows, they will allow us to obtain the actual strings
that have matched them (i.e. month name, day number, and year number).

For dessert, coming back to numbers: here is a recognizer for a
general number format: anything like 999, or 999.999, or -999.999e+21.

	'''' matchesRegex: ''(\+|-)?\d+(\.\d*)?((e|E)(\+|-)?\d+)?''
!!' readStream nextChunkText! !

!RegexMatchingError commentStamp: ''!
This class represents matching errors in regular expressions.!
!RegexSyntaxError commentStamp: ''!
This class represents syntax errors in regular expressions.!
!RegexSyntaxError methodsFor: 'accessing' stamp: ''!
position
	"return the parsing error location"
	^ position! !

!RegexSyntaxError methodsFor: 'accessing' stamp: ''!
position: anInteger
	position := anInteger.! !

!RegexSyntaxError class methodsFor: 'signaling' stamp: ''!
signal: anErrorMessage at: errorPosition
	^ (self new)
		position: errorPosition;
		signal: anErrorMessage! !

!RegisterableTranslatorMock commentStamp: ''!
I'm a mock object to mock a translator!
!RegisterableTranslatorMock methodsFor: 'initialization' stamp: ''!
initialize
	"Initializes the receiver"
	
	super initialize.
	translations := Dictionary new.
	translations at: #'TestCase' put: 'Testfall'! !

!RegisterableTranslatorMock methodsFor: 'translate' stamp: ''!
translate: aString toLocale: localeID
 
	^self translate: aString! !

!RegisterableTranslatorMock methodsFor: 'translate' stamp: ''!
translate: aString
	"Dispatch to a registered translator to translate the given string or (if there is no translator) return the untranslated string."
	^translations at: aString asSymbol ifAbsent: [ aString ] 
! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testAreCached
	| annotations |
	annotations := ClassAnnotationExample1 registeredInstances.

	self assert: ClassAnnotationExample1 registeredInstances identicalTo: annotations! !

!RegisteredClassAnnotationsTest methodsFor: 'running' stamp: ''!
tearDown
		
	ClassAnnotation resetCache.
	
	super tearDown.! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testIncludeInstancesFromAllAnnotatingMethodsOfAnyClassInSystem

	| annotations |
	annotations := ClassAnnotationExample1 registeredInstances.
	
	self assert: annotations size equals: 2.
	self assert: (annotations collect: #class as: Set) equals: {ClassAnnotationExample1} asSet! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testAreSortedByPriority

	| annotations expected |
	annotations := ClassAnnotationExampleWithPriority registeredInstances.
	
	self assert: annotations size equals: 3.
	
	expected := annotations sorted: #priority descending.
	self assert: annotations asArray equals: expected asArray! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testNotIncludeInstancesAnnotatingForbiddenClasses
	"In that test the annotation define canAnnotateClass: with constant false answer.
	So any annotating methods which define it should never register their instances"
	| annotations |
	annotations := ForbiddenClassAnnotationExample registeredInstances.
	
	self assert: annotations isEmpty! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testIncludeCopiesForEachSubclassOfOriginDeclaration

	| annotations |
	annotations := ClassAnnotationExample3 registeredInstances.
	
	self assert: (annotations anySatisfy: [ :each | each annotatedClass = SubclassWithOnlyInheritedAnnotation ])! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testCanBeEnumerated

	| enumerated |
	enumerated := OrderedCollection new.
	ClassAnnotationExample1 registeredInstancesDo: [:each | enumerated add: each].
	
	self assert: enumerated asArray equals: ClassAnnotationExample1 registeredInstances asArray! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testCanBeQueriedForConcreteClass

	| annotations |
	annotations := ClassAnnotationExample1 registeredInstancesFor: ClassWithThreeAnnotations.
	
	self assert: annotations size equals: 2.
	self assert: (annotations collect: #annotatedClass as: Set) equals: {ClassWithThreeAnnotations} asSet! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testIncludeForbiddenClassesAsSpecialForbiddenAnnotations
	| allForbidden forbidden actualAnnotation |
	
	allForbidden := ForbiddenClassAnnotation registeredInstancesFor: ClassWithForbiddenAnnotationExample.
	forbidden := allForbidden detect: [:each | each declarationSelector = #forbiddenAnnotation].
	actualAnnotation := forbidden actualAnnotation.
	self assert: actualAnnotation class equals: ForbiddenClassAnnotationExample! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testAreDifferentForDifferentAnnotationClasses
	| annotations1 annotations2 |
	annotations1 := ClassAnnotationExample1 registeredInstances.
	annotations2 := ClassAnnotationExample2 registeredInstances.

	self deny: annotations1 equals: annotations2! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testAreEmptyForUnusedAnnotation

	| actual |
	actual := ClassAnnotationUnusedExample registeredInstances.
	
	self assert: actual isEmpty! !

!RegisteredClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testNotIncludeForbiddenClassesAsBrokenAnnotations
	| broken |
	
	broken := BrokenClassAnnotation registeredInstancesFor: ClassWithForbiddenAnnotationExample.
	broken 
		detect: [:each | each declarationSelector = #forbiddenAnnotation]
		ifFound: [ :ann | self assert: false description: 'forbidden annotation should not be broken' ]! !

!RegisteredClassAnnotationsTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	ClassAnnotation resetCache! !

!RelationSet commentStamp: ''!
I'm a Set like collection that is used to hold collections of associated objects. When an object is added to or removed from this collection the inverse side is also updated.!
!RelationSet methodsFor: 'adding' stamp: ''!
add: anObject

	(self includes: anObject)
		ifTrue: [ ^anObject ].
		
	slot add: anObject to: owner.
	^set add: anObject! !

!RelationSet methodsFor: 'private' stamp: ''!
species

	^Set! !

!RelationSet methodsFor: 'copying' stamp: ''!
copy

	^Set new 
		addAll: self;
		yourself! !

!RelationSet methodsFor: 'internal' stamp: ''!
inverseRemove: anObject

	^set remove: anObject! !

!RelationSet methodsFor: 'initialize - release' stamp: ''!
initializeOwner: anObject slot: aToManyAssociation

	owner := anObject.
	slot := aToManyAssociation.
	set := Set new! !

!RelationSet methodsFor: 'accessing' stamp: ''!
size
	^set ifNil: [0] ifNotNil: [ set size ]! !

!RelationSet methodsFor: 'internal' stamp: ''!
inverseAdd: anObject

	^set add: anObject! !

!RelationSet methodsFor: 'enumerating' stamp: ''!
do: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument."

	set do: aBlock! !

!RelationSet methodsFor: 'removing' stamp: ''!
remove: oldObject ifAbsent: aBlock

	(set includes: oldObject)
		ifFalse: [ ^aBlock value ].
		
	slot remove: oldObject from: owner.
	^set remove: oldObject ifAbsent: aBlock! !

!RelationSet class methodsFor: 'instance creation' stamp: ''!
owner: anObject slot: aToManyAssociation

	^self new initializeOwner: anObject slot: aToManyAssociation ! !

!RelationSetTest methodsFor: 'tests' stamp: ''!
testSelect

	| movie result |
	
	movie := SlotExampleMovie named: 'Thelma and Louise'.
	movie
		addActor: (SlotExamplePerson named: 'P1') ;
		addActor: (SlotExamplePerson named: 'P2').

	result := movie actors select: [ :e | e name = 'P1' ].
	self assert: result class equals: Set.
	self assert: result size equals: 1.
	self assert: result anyOne name equals: 'P1'.! !

!RelationSetTest methodsFor: 'tests' stamp: ''!
testCopy
	"A copy of an RelationSet should give us a regular Set."

	| movie |
	movie := SlotExampleMovie new.
	self assert: movie actors isCollection.
	self assert: movie actors copy isCollection.
	self deny: movie actors copy class equals: RelationSet! !

!RelationSlot commentStamp: ''!
I'm a Slot that represents one side of a relationship. If this side of the relationship is updated I take care of keeping the other side up to date.

I'm abstract, use  the ToOne or ToMany  subclass depending on the cardinality.

Instance Variables
	inverseName:		<String>
	inverseSlot:		<RelationSlot>
	targetClass:		<Class> or <Symbol>

inverseName
	- the name  of the slot of the other side of the relationship

inverseSlot
	- the slot of the other side of the relationship

targetClass
	- the class or the name of the class this slot refers to
!
!RelationSlot methodsFor: 'accessing' stamp: ''!
inverseSlot

	^inverseSlot ifNil: [ self linkUp. inverseSlot ]! !

!RelationSlot methodsFor: 'comparing' stamp: ''!
= anObject 

	^super = anObject and: [ 
		self targetClassName = anObject targetClassName and: [ 
			inverseName = anObject inverseName ] ]

	! !

!RelationSlot methodsFor: 'initialization' stamp: ''!
inClass: aTargetClassOrSymbol

	targetClass := aTargetClassOrSymbol! !

!RelationSlot methodsFor: 'comparing' stamp: ''!
hash
	^ ((self species hash bitXor: self name hash) 
			bitXor: (self index ifNil: [ 0 ])) 
				bitXor: self targetClassName hash! !

!RelationSlot methodsFor: 'internal' stamp: ''!
checkValue: aValue

	(aValue isKindOf: self targetClass)
		ifFalse: [ self error: 'Invalid value' ]! !

!RelationSlot methodsFor: 'internal' stamp: ''!
removeAssociationFrom: ownerObject to: otherObject
	"A reference from <ownerObject> to <otherObject> is removed. Here we update the other 
	side of the association. If the other side is a ToOne association set the value to nil,
	for ToMany associations remove <ownerObject> from the collection." 

	self inverseSlot isToOneSlot
		ifTrue: [ inverseSlot writeInverse: nil to: otherObject ]
		ifFalse: [ (inverseSlot read: otherObject) inverseRemove: ownerObject ]! !

!RelationSlot methodsFor: 'accessing' stamp: ''!
targetClassName

	^targetClass isSymbol
		ifTrue: [ targetClass ]
		ifFalse: [ targetClass name ]! !

!RelationSlot methodsFor: 'internal' stamp: ''!
addAssociationFrom: ownerObject to: otherObject
	"A new reference from <ownerObject> to <otherObject> is created. Here we update the other 
	side of the association. If the other side is a ToOne association this means that an other
	association may have to be removed first."

	self inverseSlot isToOneSlot
		ifTrue: [ 
			| oldObject |
			oldObject := inverseSlot read: otherObject.
			oldObject notNil
				ifTrue: [ inverseSlot removeAssociationFrom: otherObject to: oldObject ].
			inverseSlot writeInverse: ownerObject to: otherObject ]
		ifFalse: [ 
			(inverseSlot read: otherObject) inverseAdd: ownerObject ]! !

!RelationSlot methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		store: self name;
		nextPutAll: ' => ';
		nextPutAll: self class name.
	self hasInverse 
		ifTrue: [ 
			aStream
				nextPutAll: ' inverse: ';
				store: inverseName ].
	aStream
		nextPutAll: ' inClass: ';
		store: self targetClassName
! !

!RelationSlot methodsFor: 'accessing' stamp: ''!
targetClass

	targetClass isSymbol
		ifTrue: [ 
			targetClass := Smalltalk globals at: targetClass 
				ifAbsent: [ self error: 'Cannot find class ', targetClass printString ] ].
	
	^targetClass! !

!RelationSlot methodsFor: 'testing' stamp: ''!
isToOneSlot

	^false! !

!RelationSlot methodsFor: 'comparing' stamp: ''!
hasSameDefinitionAs: otherSlot
	"need to implement as superclass implements it"
	^ (super hasSameDefinitionAs: otherSlot) 
		and: [ self targetClassName = otherSlot targetClassName 
		and: [ inverseName = otherSlot inverseName ] ]! !

!RelationSlot methodsFor: 'testing' stamp: ''!
hasInverse

	^inverseName notNil! !

!RelationSlot methodsFor: 'code generation' stamp: ''!
emitStore: aMethodBuilder
	"This bytecode does the following: 
		self updateOld: (self read: anObject) new: newValue in: anObject.
		super write: newValue to: anObject
	"
	| tempName |
	tempName := '0slotTempForStackManipulation'.
	aMethodBuilder
		addTemp: tempName;
		storeTemp: tempName;
		popTop;
 		pushLiteral: self;
		pushInstVar: index;
		pushTemp: tempName;
		pushReceiver;
		send: #updateOld:new:in:;
		storeInstVar: index! !

!RelationSlot methodsFor: 'initialization' stamp: ''!
inverse: anInverseSymbol inClass: aTargetClassOrSymbol
	self inClass: aTargetClassOrSymbol.
	inverseName := anInverseSymbol! !

!RelationSlot methodsFor: 'accessing' stamp: ''!
inverseName

	^inverseName! !

!RelationSlot methodsFor: 'initialization' stamp: ''!
linkUp

	inverseSlot := self targetClass slotNamed: inverseName.
	(inverseSlot isKindOf: RelationSlot)
		ifFalse: [ self error: 'Invalid association: ... ' ].
		
	inverseSlot inverseName = self name
		ifFalse: [ self error: 'Invalid association: inverse names do not match' ].! !

!RelationSlot class methodsFor: 'instance creation' stamp: ''!
named: aSymbol inverse: anInverseSymbol inClass: aTargetClassOrSymbol 

	^(super named: aSymbol) inverse: anInverseSymbol inClass: aTargetClassOrSymbol ! !

!RelationSlotTest methodsFor: 'tests' stamp: ''!
testEquals

	| s1 s2 |
	
	s1 := ToManyRelationSlot named: #slot inverse: #x inClass: #SlotExamplePerson.
	s2 := ToManyRelationSlot named: #slot inverse: #x inClass: #SlotExamplePerson.
	
	self assert: s1 equals: s2.
	self assert: s1 hash equals: s2 hash! !

!RelationSlotTest methodsFor: 'tests' stamp: ''!
testDefinitionWithClass

	| s1 s2 |
	
	s1 := #people => ToManyRelationSlot inverse: #x inClass: #SlotExamplePerson.
	s2 := #people => ToManyRelationSlot inverse: #x inClass: SlotExamplePerson.
	
	self assert: s1 equals: s2.
	self assert: s1 hasInverse 
! !

!RelationSlotTest methodsFor: 'tests' stamp: ''!
testNotEquals
	| s1 s2 |
	s1 := ToManyRelationSlot named: #slot inverse: #x inClass: #SlotExamplePerson.
	s2 := ToManyRelationSlot named: #slot inverse: #y inClass: #SlotExamplePerson.

	self deny: s1 equals: s2! !

!RelationSlotTest methodsFor: 'tests' stamp: ''!
testDefinition

	| s1 s2 |
	
	s1 := ToManyRelationSlot named: #people inverse: #x inClass: #SlotExamplePerson.
	s2 := #people => ToManyRelationSlot inverse: #x inClass: #SlotExamplePerson.
	
	self assert: s1 equals: s2.
	self assert: s1 hasInverse 
! !

!RelationSlotTest methodsFor: 'tests' stamp: ''!
testDefinitionWithoutInverse

	| slot |
	
	slot := #people => ToManyRelationSlot inClass: #SlotExamplePerson.
	self deny: slot hasInverse! !

!RelativePath commentStamp: ''!
I represent a relative path (a position starting from Path workingDirectory)!
!RelativePath methodsFor: 'accessing' stamp: ''!
emptyPathString
	"Answer the string representing an empty (size = 0) instance of the receiver.
	For a relative path, this is the current directory"

	^'.'! !

!RelativePath methodsFor: 'printing' stamp: ''!
printOn: aStream delimiter: aCharacter
	self isWorkingDirectory ifTrue: [aStream nextPut: $.. ^ self].
	super printOn: aStream delimiter: aCharacter! !

!RelativePath methodsFor: '*System-Settings-Core' stamp: ''!
acceptSettings: aVisitor
	^ aVisitor visitRelativePath: self! !

!RelativePath methodsFor: 'testing' stamp: ''!
isRoot
	^ false! !

!RelativePath methodsFor: 'testing' stamp: ''!
isAbsolute
	^ false! !

!RelativePath methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: 'Path '.
	self isWorkingDirectory
		ifTrue: [ aStream nextPutAll: 'workingDirectory' ]
		ifFalse: 
			[ aStream 
				nextPutAll: '* ''';
				nextPutAll: (self at: 1);
				nextPut: $'.
			2 to: self size do:
				[:i |
				aStream
					nextPutAll: ' / ''';
					nextPutAll: (self at: i);
					nextPut: $' ]]! !

!RelativePathStoredSetting commentStamp: ''!
I am responsible for storing information about RelativePath objects.!
!RelativePathStoredSetting methodsFor: 'accessing' stamp: ''!
realValue
	^ (RelativePath withAll: realValue) asFileReference! !

!ReleaseTest commentStamp: ''!
I contain tests that validate the integrity of the system.!
!ReleaseTest methodsFor: 'tests - variables' stamp: ''!
testAllClassPoolBindingAreClassVariables
	| wrong |
	wrong := OrderedCollection new.
	testingEnvironment allClasses do: [ :class | wrong addAll: (class classVariables reject: [ :each | each isKindOf: ClassVariable ]) ].
	self assertEmpty: wrong! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testInstanceSideMethodsWithNilKeyInLastLiteral
	| instanceSideMethodsWithNilKeyInLastLiteral |
	
	instanceSideMethodsWithNilKeyInLastLiteral := SystemNavigation new instanceSideMethodsWithNilKeyInLastLiteral.
	
	self 
		assert: instanceSideMethodsWithNilKeyInLastLiteral isEmpty
		description: [ String streamContents: [ :s|
			s 
				nextPutAll: 'Found methods with nil as last literal: ';
				print: instanceSideMethodsWithNilKeyInLastLiteral ]].
	! !

!ReleaseTest methodsFor: 'helpers' stamp: ''!
hasStartUpOrShutDownMethod: aClass
	| keySelectors |
	keySelectors := #(#startUp #startUp: #shutDown #shutDown:).
	^ (aClass selectors includesAny: keySelectors)
		or: [ aClass class selectors includesAny: keySelectors ]! !

!ReleaseTest methodsFor: 'tests - source' stamp: ''!
testNoPeriodInMethodSignature
	| methods |
	methods := SystemNavigation new allMethods select: [ :method | 
 		method sourceCode lines first trimRight last == $..].
	
	self assert: methods isEmpty description: [ 
		String streamContents: [ :stream | 
			stream
				nextPutAll: 'Found methods with period in signature:';
				print: methods ] ]
	! !

!ReleaseTest methodsFor: 'tests - methods' stamp: ''!
testNoEquivalentSuperclassMethods

	| methods |
	"we do not care about methods that are installed from traits"
	methods := SystemNavigation new allMethods reject: [:method | method isFromTrait].
	
	methods := methods select: [:method |
	method methodClass superclass
		ifNotNil: [ :superclass | (superclass lookupSelector: method selector)
			ifNotNil: [ :overridenMethod | method equivalentTo: overridenMethod ]
			ifNil: [ false ] ]
		ifNil: [ false ]
	].
	self assert: methods size <= 369.


	"there should be no method left"
	"self assert: methods isEmpty description: [ 
		String streamContents: [ :stream | 
			stream
				nextPutAll: 'Found methods that are the same as in a superclass';
				print: methods ] ]"! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testInstalledMethodsWithIncorrectTrailerKind
	| incorrectMethods |
	
	incorrectMethods := SystemNavigation new installedMethodsWithIncorrectTrailerKind.
	
	self 
		assert: incorrectMethods isEmpty
		description: [ String streamContents: [ :s|
			s 
				nextPutAll: 'Found methods with incorrect trailer kind: ';
				print: incorrectMethods ]].
	! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testShouldFileLocatorBeBeforeSystemSettingsPersistenceInStartupList
	"This test documents issue https://pharo.manuscript.com/f/cases/17721"
	
	| startupList settingsIndex |
	startupList := (SessionManager default startupList collect: [:each | each handledId]).
	settingsIndex := startupList indexOf: #SystemSettingsPersistence.
	settingsIndex > 0
		ifTrue: [ self should: [ (startupList indexOf: #FileLocator) < (startupList indexOf: #SystemSettingsPersistence) ] ]! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testManifestNamesAccordingToPackageNames
	"Make sure package name and manifest name are in synch"
	
	|manifestClasses actualManifestNames expectedManifestNames |
	manifestClasses := self class environment allClasses select: [:each | each isManifest ].
	actualManifestNames := (manifestClasses collect: [:each | each name ]) sorted.
	expectedManifestNames := (manifestClasses collect: [:each | TheManifestBuilder manifestClassNameFor: each package name ]) sorted.
	
	self 
		assert: actualManifestNames size 
		equals: expectedManifestNames size.
	
	actualManifestNames do: [:each |
		 self assert: (expectedManifestNames includes: each)] ! !

!ReleaseTest methodsFor: 'tests - source' stamp: ''!
testNoNullCharacter
	"Check that we do not have NULL in sources - see https://github.com/pharo-project/pharo/issues/9631"
	
	| violations |
	violations := SystemNavigation default allMethods select: [ :m | m sourceCode includes: Character null ].
	self assert: violations isEmpty description: 'Source corrupted: Methods with Null character found'! !

!ReleaseTest methodsFor: 'tests - variables' stamp: ''!
testUndeclared
	| undeclaredVariables validExceptions remaining description |
	
	Smalltalk cleanOutUndeclared. 
	undeclaredVariables := Undeclared associations select: [:each |
			each isUndeclaredVariable].
	
	validExceptions := { #undeclaredStubInstVar1 . #undeclaredStubInstVar2 }.
	
	"for now we filter by name, maybe filtering by variable would be better"
	remaining := undeclaredVariables reject: [ :each | validExceptions includes: each name  ].
	
	"we look for one of the using methods of the undeclared var and report that, 
	this should be enough to fix it quickly"							
	description := String streamContents: [ :stream |
			stream nextPutAll: 'Found undeclared Variables: '.
			remaining do: [ :variable  |
				| method |
				method := variable usingMethods first.
				stream 
					cr
					nextPutAll: variable name;
					nextPutAll: ' in: ';
					print: method methodClass;
					nextPutAll: '>>';
					print: method selector]].

	self assert: remaining isEmpty description: description! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testUnknownProcesses
	"Make sure that there are no other processes running except the known processes"
	
	| unknownProcesses |
	unknownProcesses := self actualProcesses difference: self knownProcesses.
	self 
		assert: unknownProcesses isEmpty
		description: (String streamContents: [ :out |
			out << 'Found unknown processes: '.
			unknownProcesses 
				do: [ :each | 
					out 
						print: each name;
						print: ':';
						print: each ] 
				separatedBy: [ out << String crlf ] ])! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testExplicitRequirementMethodsShouldBeImplementedInTheirUsers
	"If a class is using a trait with an explicit requirement method, this class should implement the method"
	
	self assertValidLintRule: ReExplicitRequirementMethodsRule new
	! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testLocalMethodsOfTheClassShouldNotBeRepeatedInItsTraits
	"If a class is using a trait with an explicit requirement method, this class should implement the method"
	
	self assertValidLintRule: ReLocalMethodsSameThanTraitRule new withExceptions: #(RBSmalllintTestLocalMethodsSameThanTraitObject).! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testShouldWorldMorphBeAfterFontClassesInStartupList
	"This test documents issue https://pharo.manuscript.com/f/cases/17834"
	"The Startup of he WorldMorph is now done in the UIManagerHandler"
	| startupList |
	startupList := (SessionManager default startupList collect: [:each | each handledId]).
	#(StrikeFont LogicalFont FreeTypeSettings FreeTypeCache FT2Handle) 
		do: [ :fontClass |
			self should: [ (startupList indexOf: #UIManagerSessionHandler) > (startupList indexOf: #SystemSettingsPersistence) ] ]! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testLayoutIntegrity
	SystemNavigation default allClassesDo: [ :class |
		class instanceSide classLayout checkIntegrity.
		class classSide classLayout checkIntegrity ]! !

!ReleaseTest methodsFor: 'helpers' stamp: ''!
assertValidLintRule: aLintRule withExceptions: someNames
	| runner results |
	runner := ReSmalllintChecker new.
	runner
		rule: {aLintRule};
		environment: RBBrowserEnvironment default;
		run.

	results := (runner criticsOf: aLintRule) reject: [ :critique | someNames includes: critique entity name ].

	self
		assert: results isEmpty
		description: [ String
				streamContents: [ :s | 
					s
						<< aLintRule rationale;
						lf;
						<< 'Violations: ';
						lf.
					results
						do: [ :e | 
							s
								<< '- ';
								print: e entity ]
						separatedBy: [ s lf ] ] ]! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testNoEmptyPackages
	"Test that we have no empty packages left"

	| violating |
	violating := RPackageOrganizer default packages select: #isEmpty.
	self assertEmpty: violating! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testWorldMenuHasHelpForAllEntries
	"In this test we check that at least every terminal menu entry of the world menu has an help."

	| menuElements |
	menuElements := WorldState new menuBuilder itemList.

	"Here we have the roots of the menu. We want the terminal menu entries."
	[ menuElements allSatisfy: [ :each | each itemList isNil ] ]
		whileFalse: [ menuElements := menuElements inject: OrderedCollection new into: [ :coll :each | each itemList ifNil: [ coll add: each ] ifNotNil: [ :items | coll addAll: items ]. coll ] ].
			
	menuElements collect: #spec thenDo: [ :item | self assert: item help isNotNil description: item label , ' menu entry in world menu should have an help.' ]! !

!ReleaseTest methodsFor: 'tests - variables' stamp: ''!
testAllClassPoolBindingHaveDefiningClass
	| wrong |
	wrong := OrderedCollection new.
	testingEnvironment allClasses do: [ :class | wrong addAll: (class classVariables reject: [ :each | each definingClass == class ]) ].
	self assertEmpty: wrong! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testTestCasesEndsWithTestOrTestCase
	self assertValidLintRule: ReTestClassNameShouldEndWithTestRule new
	! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testPharoVersionFileExists

	"Test there is a pharo.version file next to this image containing the short version of this pharo image.
	This file is required by the Pharo launcher to correctly detect the Pharo version we are running on."
	
	| pharoVersionFile |
	pharoVersionFile := FileLocator imageDirectory / 'pharo.version'.
	self assert: pharoVersionFile exists.
	self
		assert: pharoVersionFile readStream contents trimBoth
		equals: SystemVersion current major asString,  SystemVersion current minor asString! !

!ReleaseTest methodsFor: 'tests - rpackage' stamp: ''!
testRPackageOrganizer
	"Ensure other tests temporary created organizers are collected"
	3 timesRepeat: [ Smalltalk garbageCollect ].

	"Now check :)"
	self 
		assert: RPackageOrganizer allInstances size = 1
		description: 'There are multiple (', RPackageOrganizer allInstances size asString, ') instances of RPackageOrganizer'.
		  
	self 
		assert: RPackageOrganizer allInstances first == RPackageOrganizer default 
		description: 'The default package organizer is the not the only instance of RPackageOrganizer'.! !

!ReleaseTest methodsFor: 'tests - rpackage' stamp: ''!
testUnpackagedClasses
	| unpackagedClasses |
	unpackagedClasses := Smalltalk allClassesAndTraits select: [:each | 
		(RPackageOrganizer default packageOf: each) packageName = RPackage defaultPackageName ].
	self 
		assert: unpackagedClasses isEmpty 
		description: (String streamContents: [ :s|
			s nextPutAll: 'Found the following unpackaged classes: '.
			unpackagedClasses
				do: [ :cls| s tab print: cls ]
				separatedBy: [ s cr ]])
! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testNoNilAssignmentInInitializeMethod
	
	self assertValidLintRule: ReNoNilAssignationInInitializeRule new
	! !

!ReleaseTest methodsFor: 'tests - rpackage' stamp: ''!
testThatAllMethodsArePackaged
	| classes instanceMethods classMethods allMethods methodsWithoutPackageInfo |
	classes := Smalltalk allClassesAndTraits.
	instanceMethods := classes flatCollect: #methods.
	classMethods := classes flatCollect: [ :class | class classSide methods ].
	allMethods := instanceMethods , classMethods.
	methodsWithoutPackageInfo := allMethods select: [ :method | method package isNil ].
	self assertEmpty: methodsWithoutPackageInfo! !

!ReleaseTest methodsFor: 'tests - variables' stamp: ''!
testAllGlobalBindingAreGlobalVariables
	| wrong |
	wrong := testingEnvironment associations reject: [ :each | each isKindOf: GlobalVariable ].
	self assertEmpty: wrong! !

!ReleaseTest methodsFor: 'accessing' stamp: ''!
knownProcesses
	"Return a dynamic list of know processes"
	
	"(self actualProcesses difference: self knownProcesses) do: [ :each | each suspend; terminate ]."
	
	^ {
		Processor activeProcess.	
		Processor backgroundProcess.
		WeakArray runningFinalizationProcess.
		SmalltalkImage current lowSpaceWatcherProcess.
		MorphicUIManager uiProcess.
		CurrentExecutionEnvironment value watchDogProcess.
		Delay schedulingProcess.
		TKTWatchDog onDuty pharoProcess.
		OSSDL2Driver eventLoopProcess.
		TFCallbackQueue uniqueInstance callbackProcess } asSet! !

!ReleaseTest methodsFor: 'tests - variables' stamp: ''!
testAllInstanceVariablesStartLowercase
	"Make sure that all class instance variable names start with a lowercase letter"
	| violating |

	violating := Smalltalk globals allBehaviors select: [ :class | 
		class slots anySatisfy: [:var | var name first isUppercase]].

	self 
		assert: violating isEmpty 
		description: 'Instance variable names must start with a lowercase letter: ', violating asArray asString! !

!ReleaseTest methodsFor: 'helpers' stamp: ''!
assertValidLintRule: aLintRule
	self assertValidLintRule: aLintRule withExceptions: {}! !

!ReleaseTest methodsFor: 'tests - packages - manifests' stamp: ''!
testProperManifestClasses

	|manifests|
	manifests := self class environment allClasses select: [:each | each isManifest ].
	self assert: (manifests allSatisfy: [:each | each inheritsFrom: PackageManifest ]).
	self assert: (manifests allSatisfy: [:each | each name beginsWith: 'Manifest' ]).


 ! !

!ReleaseTest methodsFor: 'tests - variables' stamp: ''!
testNoShadowedVariablesInMethods
	"Fail if there are methods who define shadowed temps or args"
	| found validExceptions remaining |
	found := SystemNavigation default allMethodsSelect: [ :m | 
		m ast variableDefinitionNodes anySatisfy: [ :node | node variable isShadowing ] ].
	"Make sure to not waste memory with all the ASTs"
	ASTCache reset.
	"No other exceptions beside the ones mentioned here should be allowed"	
	validExceptions := { 
		RBDummyRefactoryTestDataApp>>#tempVarOverridesInstVar.
		RBRefactoryTestDataApp>>#tempVarOverridesInstVar.
		RBSmalllintTestObject>>#tempVarOverridesInstVar.
		ReTempVarOverridesInstVarRuleTest>>#sampleMethod:}.	
	
	remaining := found asOrderedCollection 
								removeAll: validExceptions;
								yourself.
								
	self 
		assert: remaining isEmpty 
		description: ('the following methods have shadowing variable definitions and should be cleaned: ', remaining asString)! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testObsoleteClasses
	| obsoleteClasses |
	
	Smalltalk fixObsoleteReferences.
	Smalltalk garbageCollect.
	obsoleteClasses := SystemNavigation new obsoleteClasses
		select: [ :each | each isAnonymous not ].
	
	self 
		assert: obsoleteClasses isEmpty
		description: [
			String streamContents: [ :s|
				s 
					nextPutAll: 'Obsolete classes remaining: ';
					print: obsoleteClasses ]]! !

!ReleaseTest methodsFor: 'tests - variables' stamp: ''!
testClassesShadow

	| classes |
	classes := Smalltalk globals allBehaviors select: [ :class | 
		           class definedVariables anySatisfy: [ :var | 
			           var isShadowing ] ].

	self assert: classes isEmpty description: classes asArray asString! !

!ReleaseTest methodsFor: 'tests - rpackage' stamp: ''!
testUnpackagedPackageShouldBeEmpty
	| unpackagePackage |
	unpackagePackage := RPackageOrganizer default packageNamed: RPackage defaultPackageName.
	"The unpackage package should not have any defined class or extended classes"
	self assertEmpty: unpackagePackage classes! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testMethodsContainNoHalt

	| methods |
	methods := SystemNavigation new allMethods select: [ :method | method containsHalt ].
	"these methods are using halt for testing something"
	methods := methods reject: [ :method | 
		           method hasPragmaNamed: #haltOrBreakpointForTesting ].
	"these methods are implementing halt, we are not interested"
	methods := methods reject: [ :method | 
		           method hasPragmaNamed: #debuggerCompleteToSender ].

	"there should be no method left"
	self assert: methods isEmpty description: [ 
		String streamContents: [ :stream | 
			stream
				nextPutAll: 'Found methods with halt';
				print: methods ] ]! !

!ReleaseTest methodsFor: 'tests' stamp: ''!
testKeyClassesArePresentInStartupList
	| keyClasses registeredHandlers |
	keyClasses := #(#Delay #ProcessorScheduler #Stdio #OSPlatform #UUIDGenerator #DiskStore #WeakArray #BasicCommandLineHandler).
	registeredHandlers := SessionManager default startupList
		collect: [:each | each handledId].
	
	keyClasses do:	[ :className |
		self assert: (registeredHandlers includes: className).
		self assert: (self hasStartUpOrShutDownMethod: (testingEnvironment at: className)) ].
	
	self assert: (registeredHandlers includes: #UIManagerSessionHandler).! !

!ReleaseTest methodsFor: 'tests - variables' stamp: ''!
testMethodsWithUnboundGlobals
	| methodsWithUnboundGlobals |
	"Ensure the environment is clean"
	3 timesRepeat: [ Smalltalk garbageCollect ].
	
	Smalltalk cleanOutUndeclared. 
	methodsWithUnboundGlobals := SystemNavigation new methodsWithUnboundGlobals.
	
	self 
		assert: methodsWithUnboundGlobals isEmpty
		description: [ String streamContents: [ :s |
			s 
				nextPutAll: 'Found methods with unbound globals: '; 
				print: methodsWithUnboundGlobals ]]! !

!ReleaseTest methodsFor: 'accessing' stamp: ''!
actualProcesses
	^ self class actualProcesses! !

!ReleaseTest class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit

	^ 2 minutes! !

!ReleaseTest class methodsFor: 'accessing' stamp: ''!
actualProcesses
	^ Process allSubInstances reject: [ :each | each isTerminated ]! !

!RemoteString commentStamp: ''!
My instances provide an external file reference to a piece of text.  It may be the sourceCode of a method, or the class comments of a class.
I can return either a String or a Text.

In a source file (sources, changes, fileouts) we store chunks of code.
It is usually to store the source string of a method for example.

max: aNumber
	^ self > aNumber ifTrue: [self] ifFalse: [aNumber]!!
 
Some chunks are styled (they have parts in bold, or font color...).
When a chunk is styled, it is followed by a second chunk (prefixed with something like ]style[), and specifying the style.
The encoding is as follows:

max: aNumber
	^ self > aNumber ifTrue: [self] ifFalse: [aNumber]!!
]style[(14 50 312)f1,f1b,f1LInteger +;i!!

Allowed TextAttributes are TextFontChange, TextEmphasis, TextColor, TextDoIt, TextKern, TextLink, TextURL. 
TextFontReference and TextAnchor are not supported.

See PositionableStream nextChunkText and RunArray class scanFrom:.!
!RemoteString methodsFor: 'accessing' stamp: ''!
sourceFileArray
	^ sourceFileArray ifNil: [ SourceFiles ]! !

!RemoteString methodsFor: 'accessing' stamp: ''!
position 
	"Answer the location of the string on a file."

	^ filePositionHi ! !

!RemoteString methodsFor: 'private' stamp: ''!
fileNumber: fileNumber position: position 

	sourceFileNumber := fileNumber.
	filePositionHi := position! !

!RemoteString methodsFor: 'accessing' stamp: ''!
sourceFileNumber
	"Answer the index of the file on which the string is stored."

	^ sourceFileNumber! !

!RemoteString methodsFor: 'private' stamp: ''!
string: aString
	"Store this as my string if source files exist."

	self sourceFileArray changesWriteStreamDo: [ :theFile |
		theFile cr.
		self 
			string: aString 
			onFileNumber: 2
			toFile: theFile ]! !

!RemoteString methodsFor: 'accessing' stamp: ''!
last
	^self string ifNotNil: [ :s | s last ] ! !

!RemoteString methodsFor: 'accessing' stamp: ''!
string 
	"Answer the receiver's string if remote files are enabled, or nil."

	^ self sourceFileArray 
		readStreamAtFileIndex: sourceFileNumber 
		atPosition: filePositionHi 
		ifPresent: [ :readStream | (ChunkReadStream on: readStream) next ]
		ifAbsent: [ nil ]! !

!RemoteString methodsFor: 'accessing' stamp: ''!
sourceFileArray: anObject
	sourceFileArray := anObject! !

!RemoteString methodsFor: 'accessing' stamp: ''!
sourcePointer
	sourceFileNumber ifNil: [ ^ 0 ].
	^ SourceFiles sourcePointerFromFileIndex: sourceFileNumber andPosition: filePositionHi! !

!RemoteString methodsFor: 'chunk' stamp: ''!
string: aString onFileNumber: fileNumber toFile: aFileStream 
	"Store this as the receiver's string if source files exist."

	| position |
	position := aFileStream position.
	self fileNumber: fileNumber position: position.
	(ChunkWriteStream on: aFileStream) nextPut: aString.
	^ self ! !

!RemoteString methodsFor: '*Text-Core' stamp: ''!
text
	^ self string asText! !

!RemoteString class methodsFor: 'instance creation' stamp: ''!
newString: aString
	"Answer an instance of me for string, aString, on changes file. 
	Put the string on the file and create the remote reference."

	^self new string: aString! !

!RemoteString class methodsFor: 'instance creation' stamp: ''!
newFileNumber: sourceIndex position: anInteger 
	"Answer an instance of me fora file indexed by sourceIndex, at the 
	position anInteger. Assume that the string is already stored on the file 
	and the instance will be used to access it."

	^self new fileNumber: sourceIndex position: anInteger! !

!RemoteString class methodsFor: 'instance creation' stamp: ''!
newString: aString onFileNumber: sourceIndex toFile: aFileStream
	"Answer an instance of me for string, aString, on file indexed by 
	sourceIndex. Put the string on the file, aFileStream, and create the 
	remote reference. Assume that the index corresponds properly to 
	aFileStream."

	^self new string: aString onFileNumber: sourceIndex toFile: aFileStream! !

!RenrakuBaseTestCase commentStamp: ''!
I provide a testing package which is destroyed later!
!RenrakuBaseTestCase methodsFor: 'running' stamp: ''!
tearDown

	self tearDownscreamerRule.
	testPackage unregister.
	testPackage := nil.	
	super tearDown ! !

!RenrakuBaseTestCase methodsFor: 'running' stamp: ''!
tearDownscreamerRule

	ScreamerRule removeFromSystem.
	ScreamerRule := nil.
	ReRuleManager reset! !

!RenrakuBaseTestCase methodsFor: 'running' stamp: ''!
setupScreamerRule

	ScreamerRule := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: #ReScreamerRuleForTesting;
			superclass: ReAbstractRule;
			package: testPackage name ].

		
	ScreamerRule class
		compile: 'checksMethod ^ true';
		compile: 'checksClass ^ true';
		compile: 'checksPackage ^ true'.
		
	ScreamerRule
		compile: 'name ^ ''A tautological violation for testing''';
		compile: 'check: aNode forCritiquesDo: aBlock
						aBlock cull: (self critiqueFor: aNode)'.
						
	ReRuleManager reset! !

!RenrakuBaseTestCase methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	testPackage := (RPackage named: #'Renraku-Nuclear-Site') register.
	self setupScreamerRule.! !

!RenrakuBaseTestCase class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self = RenrakuBaseTestCase! !

!RenrakuCritiqueDesignHelp commentStamp: ''!
This book contains explanations of the design behind critiques!
!RenrakuCritiqueDesignHelp class methodsFor: 'pages' stamp: ''!
autofix

	^ HelpTopic
		title: 'Automated Fixes'
		contents: 
'A critique has the #providesChange method which returns a boolean value specifying whether the critique can provide a change which will resolve the issue.

The #change method can be used to obtain an object of RBRefactoryChange kind.'! !

!RenrakuCritiqueDesignHelp class methodsFor: 'pages' stamp: ''!
actions

	^ HelpTopic
		title: 'Custom Actions'
		contents: 
'One can override #actions method to return a list of RePropertyAction objects. Tools can use these objects to provide a user with custom actions defined by critiques themselves.'! !

!RenrakuCritiqueDesignHelp class methodsFor: 'accessing' stamp: ''!
bookDescription

	^ 'This book contains explanations of the design behind critiques'! !

!RenrakuCritiqueDesignHelp class methodsFor: 'accessing' stamp: ''!
pages

	^ #( hierarchy rule entity autofix actions actionRef )! !

!RenrakuCritiqueDesignHelp class methodsFor: 'accessing' stamp: ''!
bookName

	^ 'Critique Design'! !

!RenrakuCritiqueDesignHelp class methodsFor: 'pages' stamp: ''!
hierarchy

	^ HelpTopic
		title: 'Class Hierarchy'
		contents: 
'ReAbstractCritique is the root of the critiques hierarchy.

ReAbstractCritique inherits from ReProperty which represents an external property of some entity related to a piece of code. It defines a basic interface of a title an and an icon that can be used to display it in a user interface. It also has a source anchor pointing the piece of code.'! !

!RenrakuCritiqueDesignHelp class methodsFor: 'pages' stamp: ''!
entity

	^ HelpTopic
		title: 'Entity Reference'
		contents: 
'A critique has a reference to the criticized entity.

This link is established through ReSourceAnchor. A source anchor has a reference to the actual class, method, or other entity that is criticized. An anchor also has a #providesInterval method that returns a boolean indicating if the anchor provides a selection interval to the actual source of the critique. The interval can be accessed through the #interval method.

There are two subclasses of ReSourceAnchor.
ReIntervalSourceAnchor stores the actual interval object which is set during initialization.
ReSearchStringSourceAnchor stores a searchString which will be searched for in the entities source code on demand to find an interval of substring'! !

!RenrakuCritiqueDesignHelp class methodsFor: 'pages' stamp: ''!
rule

	^ HelpTopic
		title: 'Rule Reference'
		contents: 
'A critique has a reference to the rule that reported the violation.
The rule''s #name is used as the critique’s #title and the rule''s #rationale is used as the #description of the critique.'! !

!RenrakuCritiqueDesignHelp class methodsFor: 'pages' stamp: ''!
actionRef

	^ self topicForClass: RePropertyAction ! !

!RenrakuCritiqueExamplesHelp commentStamp: ''!
In the topics of this book You will find references to the concrete critiques implementations. For more please browse the subclasses of ReAbstractCritique!
!RenrakuCritiqueExamplesHelp class methodsFor: 'accessing' stamp: ''!
bookDescription

	^ 'In the topics of this book you will find references to the concrete critiques implementations. For more please browse the subclasses of ReAbstractCritique'! !

!RenrakuCritiqueExamplesHelp class methodsFor: 'accessing' stamp: ''!
pages


	^ #(trivial missingMethod transformation replaceNode refactoring)! !

!RenrakuCritiqueExamplesHelp class methodsFor: 'accessing' stamp: ''!
bookName

	^ 'Critique Examples'! !

!RenrakuCritiqueExamplesHelp class methodsFor: 'pages' stamp: ''!
replaceNode

	^ self topicForClass: ReReplaceNodeCritique ! !

!RenrakuCritiqueExamplesHelp class methodsFor: 'pages' stamp: ''!
trivial

	^ self topicForClass: ReTrivialCritique! !

!RenrakuCritiqueExamplesHelp class methodsFor: 'pages' stamp: ''!
transformation

	^ self topicForClass: ReTransformationCritique! !

!RenrakuCritiqueExamplesHelp class methodsFor: 'pages' stamp: ''!
refactoring

	^ self topicForClass: ReRefactoringCritique  ! !

!RenrakuCritiqueExamplesHelp class methodsFor: 'pages' stamp: ''!
missingMethod

	^ self topicForClass: ReMissingMethodCritique! !

!RenrakuCritiqueHelp commentStamp: ''!
Critique is an object that binds an entity with a rule that is violated by that entity. The critique describes a specific violation, and may provide a solutions to fix it.!
!RenrakuCritiqueHelp class methodsFor: 'accessing' stamp: ''!
bookDescription

	^ 'Critique is an object that binds an entity with a rule that is violated by that entity. The critique describes a specific violation, and may provide a solutions to fix it.'! !

!RenrakuCritiqueHelp class methodsFor: 'accessing' stamp: ''!
pages

	^ #( RenrakuCritiqueDesignHelp RenrakuCritiqueExamplesHelp )! !

!RenrakuCritiqueHelp class methodsFor: 'accessing' stamp: ''!
bookName

	^ 'Critiques'! !

!RenrakuExtensionsTest methodsFor: 'tests' stamp: ''!
testBanLevelCandidatesForMethod
	| method candidates |
	method := thisContext  method.
	candidates := method banLevelCandidates.
	self assert: (candidates includes: method).
	self assert: (candidates includes: self class).
	self assert: (candidates includes: self class package).
	self assert: (candidates includes: ReImageRuleBaner).
	self assert: (candidates includes: RePersistentImageRuleBaner).	! !

!RenrakuExtensionsTest methodsFor: 'tests' stamp: ''!
testBanLevelCandidatesForPackage
	| package candidates |
	package := self class package.
	candidates := package banLevelCandidates.
	self assert: (candidates includes: package).
	self assert: (candidates includes: ReImageRuleBaner).
	self assert: (candidates includes: RePersistentImageRuleBaner).	! !

!RenrakuExtensionsTest methodsFor: 'tests' stamp: ''!
testBanLevelCandidatesForClass
	| class candidates |
	class := self class.
	candidates := class banLevelCandidates.
	self assert: (candidates includes: class).
	self assert: (candidates includes: class package).
	self assert: (candidates includes: ReImageRuleBaner).
	self assert: (candidates includes: RePersistentImageRuleBaner).	! !

!RenrakuGlobalBanningTest methodsFor: 'running' stamp: ''!
tearDown
	oldRulesSettings keysAndValuesDo: [ :rule :setting |
		rule enabled: setting ].
	super tearDown! !

!RenrakuGlobalBanningTest methodsFor: 'tests' stamp: ''!
testForcedRuleOnClassWithGlobalBan
	| criticToSkip |
		
	criticToSkip := testClass critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	ReImageRuleBaner ban: criticToSkip.
	
	testPackage packageManifest class compile:
		'forcedRules ^ #(',
		ScreamerRule name,
		')'.
		
	ReRuleManager reset.
	
	self assert: (testClass critiques anySatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!RenrakuGlobalBanningTest methodsFor: 'tests' stamp: ''!
testForcedRuleOnMethodWithPackageBan
	| criticToSkip |
		
	criticToSkip := testMethod critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	testPackage ban: criticToSkip.
	
	testPackage packageManifest class compile:
		'forcedRules ^ #(',
		ScreamerRule name,
		')'.
		
	ReRuleManager reset.
	
	self assert: (testMethod critiques anySatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!RenrakuGlobalBanningTest methodsFor: 'tests' stamp: ''!
testForcedRuleOnClassWithPackageBan
	| criticToSkip |
		
	criticToSkip := testClass critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	testPackage ban: criticToSkip.
	
	testPackage packageManifest class compile:
		'forcedRules ^ #(',
		ScreamerRule name,
		')'.
		
	ReRuleManager reset.
	
	self assert: (testClass critiques anySatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!RenrakuGlobalBanningTest methodsFor: 'tests' stamp: ''!
testGlobalBan
	| criticToSkip |
		
	criticToSkip := testClass critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	ReImageRuleBaner ban: criticToSkip.
	
	self assert: (testClass critiques noneSatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!RenrakuGlobalBanningTest methodsFor: 'tests' stamp: ''!
testForcedRuleOnMethodWithGlobalBan
	| criticToSkip |
		
	criticToSkip := testMethod critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	ReImageRuleBaner ban: criticToSkip.
	
	testPackage packageManifest class compile:
		'forcedRules ^ #(',
		ScreamerRule name,
		')'.
		
	ReRuleManager reset.
	
	self assert: (testMethod critiques anySatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!RenrakuGlobalBanningTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	oldRulesSettings := Dictionary new.

	ReAbstractRule withAllSubclassesDo: [ :rule |
		oldRulesSettings at: rule put: rule enabled ]! !

!RenrakuHelp commentStamp: ''!
Renraku is a framework for defining and processing quality rules. The framework operates with three main concepts: entities, rules and critiques.

!!!! Entities
Entities are not a part of Renraku, but Renraku is validating entities. Theoretically entity can be any object, but in practice we mostly focus on code entities such as methods, classes, packages, AST nodes.

!!!! Rules
Rules are the objects that describe constraints about entities. A rule can check an entity and produce critiques that describe the violations of the entity according to the rule.

!!!! Critiques
Critique is an object that binds an entity with a rule that is violated by that entity. The critique describes a specific violation, and may provide a solutions to fix it.!
!RenrakuHelp class methodsFor: 'private' stamp: ''!
topicForClass: aClass

	^ ClassAPIHelpBuilder new
		  addMethodsWithoutComment: false;
		  rootToBuildFrom: aClass;
		  build;
		  topicToBuild! !

!RenrakuHelp class methodsFor: 'accessing' stamp: ''!
bookDescription

	^ 'Renraku is a framework for defining and processing quality rules. The framework operates with three main concepts: entities, rules and critiques.

!!!! Entities
Entities are not a part of Renraku, but Renraku is validating entities. Theoretically any object can be an entity, but in practice we mostly focus on code entities such as methods, classes, packages, AST nodes.

!!!! Rules
Rules are the objects that describe constraints about entities. A rule can check an entity and produce critiques that describe the violations of the entity according to the rule.

!!!! Critiques
Critique is an object that binds an entity with a rule that is violated by that entity. The critique describes a specific violation, and may provide a solutions to fix it.'! !

!RenrakuHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#(RenrakuRuleHelp)! !

!RenrakuHelp class methodsFor: 'accessing' stamp: ''!
bookName

	^ 'Renraku Quality Rules'! !

!RenrakuHelp class methodsFor: 'utilities' stamp: ''!
readInHelpBrowser
	<script>

	^ HelpBrowser openOn: (
			HelpTopic new
				addSubtopic: self asHelpTopic;
				yourself)! !

!RenrakuMigrationHelp commentStamp: ''!
Lately Pharo tools moved to Renraku framework which requires a slightly different implementation from rules.
	
	While you can achieve much more features by reading the whole documentation and using the complete set of Renraku possibilities, this book contains a few simple steps to help you converting existing rules to work with Renraku model.!
!RenrakuMigrationHelp class methodsFor: 'pages' stamp: ''!
genericRules 

	^ HelpTopic
		title: 'Generic Rules'
		contents: 
'To convert a generic rule (one that simply checks method, class or package) to work with Renraku you have to follow 3 simple steps:

Inheritance:
change superclass to ReAbstractRule.

Interest:
Specify which entities your rules is interested in by overriding a method on the class side to return true. If the rule was checking methods override #checksMethod, for classes override #checksClass, and for packages — #checksPackage.

Checking:
Implement #basicCheck: in a way that it will return true if the argument violated the rule and false otherwise. The quality tools will pass you only the arguments of the type you''ve expressed interest in.'! !

!RenrakuMigrationHelp class methodsFor: 'accessing' stamp: ''!
bookDescription

	^ 'Lately Pharo tools moved to Renraku framework which requires a slightly different implementation from rules.
	
	While you can achieve much more features by reading the whole documentation and using the complete set of Renraku possibilities, this book contains a few simple steps to help you converting existing rules to work with the Renraku model.'! !

!RenrakuMigrationHelp class methodsFor: 'accessing' stamp: ''!
pages

	^ #( genericRules parsetreeRules rewriteRules )! !

!RenrakuMigrationHelp class methodsFor: 'accessing' stamp: ''!
bookName

	^ 'Migrating Rules To Renraku'! !

!RenrakuMigrationHelp class methodsFor: 'pages' stamp: ''!
parsetreeRules 

	^ HelpTopic
		title: 'Parse Tree Rules'
		contents: 
'To convert parse tree rules (subclasses of RBParseTreeLintRule) please change their superclass to ReNodeMatchRule.

Then change the initialization method. Instead of sending match-specifying methods to #matcher, send them to self. The rest of API is similar:
#matches:do: -> #matches:
#matchesMethod:do: -> #addMatchingMethod:
#matchesAnyOf:do: -> #matchesAny:

So the old initialization:
	self matcher 
		matches: ''`var := `var''
		do: [ :node :answer | node ]
		
will become:
	self matches: ''`var := `var''

You might have noticed that new API is missing the "do:" part. First of all almost no rules use this functionality and you can check node in the matching expression with `{:node | "check node" } syntax.

But the new rules also give you a move powerful way of post-checking matched nodes. You can override #afterCheck:mappings: method and return true if node really violates the rule or false otherwise. The first argument passed to the method is the matched node object, while the second argument is a dictionary of bindings for the wildcards in the rule. For example if the pattern ''`var := `var'' will match expression ''a := a'' the matches dictionary will contain one entry where key is RBPatternVariableNode(`var) and value is RBVariableNode(a).
P.S. at the moment of writing the matches dictionary was not used in a real setting, so don''t hesitate to provide a feedback. Maybe instead of node objects the dictionary should contain strings.'! !

!RenrakuMigrationHelp class methodsFor: 'pages' stamp: ''!
rewriteRules 

	^ HelpTopic
		title: 'Rewrite Rules'
		contents: 
'To convert parse tree rules (subclasses of RBTransformationRule) please change their superclass to ReNodeRewriteRule.

Then change the initialization method. Instead of sending transformation-specifying methods to #rewriteRule, send them to self. The rest of API is similar:
#replace:with: -> #replace:with: (noChange)
#replaceMethod:with: -> #addMatchingMethod:rewriteTo:
? -> #replace:by: (second argument is a block which accepts matched node and returns a node that should be used for replacement).

So the old initialization:
	self rewriteRule
		replace: 	''`var := `var'' with: ''''
		
will become:
	self replace: 	''`var := `var'' with: ''''


The new rules also give you a move powerful way of post-checking matched nodes. You can override #afterCheck:mappings: method and return true if node really violates the rule or false otherwise. The first argument passed to the method is the matched node object, while the second argument is a dictionary of bindings for the wildcards in the rule. For example if the pattern ''`var := `var'' will match expression ''a := a'' the matches dictionary will contain one entry where key is RBPatternVariableNode(`var) and value is RBVariableNode(a).
P.S. at the moment of writing the matches dictionary was not used in a real setting, so don''t hesitate to provide a feedback. Maybe instead of node objects the dictionary should contain strings.'! !

!RenrakuRuleCreationHelp commentStamp: ''!
Each rule has a few fundamental features to implement in this book with will walk through all the steps of rule creation!
!RenrakuRuleCreationHelp class methodsFor: 'pages' stamp: ''!
groupSeverity

	^ HelpTopic
		title: 'Group and Severity'
		contents: 
'It''s a good idea to assign your rule to a specific group. For this override the #group method and return string with the name of the group. While you can use any name you want, maybe you would like to put your rule into one of the existing groups: ',
(ReRuleManager availableRuleGroups joinUsing: ', '), '.

You can also specify the severity of your rue by returning one of: #information, #warning, or #error symbols from the #severity method.'! !

!RenrakuRuleCreationHelp class methodsFor: 'accessing' stamp: ''!
bookDescription
	^ 'Each rule has a few fundamental features to implement in this book with will walk through all the steps of rule creation.
	
Make sure to RESET the CACHE after you add a rule. (last chapter)'! !

!RenrakuRuleCreationHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(subclass nameRationale interestInEntities checking advancedChecking testing groupSeverity resetCache)! !

!RenrakuRuleCreationHelp class methodsFor: 'pages' stamp: ''!
advancedChecking

	^ HelpTopic
		title: 'Advanced Checking'
		contents: 
'While there is a default implementation which relies on #basicCheck: and creates an instance of ReTrivialCritique, it is advised to override the #check:forCritiquesDo: method. This method accepts an entity and a block which could be evaluated for each detected critique. This means that one rule can detect multiple critiques about one entity. For example if a rule checks for unused variables it can report all of them with a dedicated critique for each.

The block which should be evaluated for each critique may accept one argument: the critique object, this is why you have to evaluate it with #cull:. You may use the #critiqueFor: method if you don''t feel comfortable with critiques yes. For example:

    self critiqueFor: anEntity

will return ReTrivialCritique about the entity. Later you can update your code to create other kinds of critiques more suitable for your case.'! !

!RenrakuRuleCreationHelp class methodsFor: 'accessing' stamp: ''!
bookName

	^ 'Creating Rules'! !

!RenrakuRuleCreationHelp class methodsFor: 'pages' stamp: ''!
testing

	^ HelpTopic
		title: 'Testing'
		contents: 
'It is fairly easy to run your rule and obtain the results. Just create an instance of it an send it the #check: message with the entity you want to check. The result is a collection of critiques. For example inspecting

	RBExcessiveMethodsRule new check: Object

should give you a collection with one critique (because the Object class always has many methods ;) ). Go on click on the critique item and inspect it. You will see that there is a special "description" tab. This is the power of critique objects, they can present themselves in a different way. Guess what: you can even visualize the critique if needed.'
	! !

!RenrakuRuleCreationHelp class methodsFor: 'pages' stamp: ''!
checking

	^ HelpTopic
		title: 'Checking'
		contents: 
'The easiest way to check an entity is to override the #basicCheck: method. The method accepts an entity as a parameter and returns true if there is a violation and false otherwise.'! !

!RenrakuRuleCreationHelp class methodsFor: 'pages' stamp: ''!
subclass

	^ HelpTopic
		title: 'Subclass'
		contents: 
'Subclass ReAbstractRule or one of the special rule classes that will be discussed. Most of tools rely on the classes hierarchy to select the rules for checking.'! !

!RenrakuRuleCreationHelp class methodsFor: 'pages' stamp: ''!
interestInEntities

	^ HelpTopic
		title: 'Specifying an Interest in Entities'
		contents: 
'The class-side methods #checksMethod, #checksClass, #checksPackage and #checksNode return true is the rule checks methods, classes or traits, packages and AST nodes respectively. Tools will pass entities of the specified type to the rule for checking. A rule may check multiple types of entities but please avoid checks for types inside of rules. E.g. if a rule checks whether an entity is named with a swearing word and does this by obtaining the name of the entity and matching substrings. It is completely fine to specify that the rule checks classes and packages as you don''t have to distinguish which entity was passed to you.'! !

!RenrakuRuleCreationHelp class methodsFor: 'pages' stamp: ''!
nameRationale

	^ HelpTopic
		title: 'Name and Rationale'
		contents: 
'Each rule should provide a short name string returned from the #name method. You also have to override the #rationale method to return a detailed description about the rule. You may also put the rationale in the class comment, as by default #rationale method returns the comment of the rule''s class.'! !

!RenrakuRuleCreationHelp class methodsFor: 'pages' stamp: ''!
resetCache

	^ HelpTopic
		title: '!! Reset Cache'
		contents: 
'To have quality assistant (and maybe other tools) pick up your changes you have to reset the cache. Do this by going to

System > Settings > Code Browsing > QualityAssistant > Renraku > Rule Cache

and pressing the reset button. Or simply executing

ReRuleManager reset


When you load complete rules into the system, the cache will be reset automatically. But as you are creating a new rule and it is in the incomplete state you have to reset the cache once you are ready.'! !

!RenrakuRuleHelp commentStamp: ''!
Rules are constraint descriptions about entities. Think of a rule as a function that consumes an entity and produces a collection of a critiques about it (which can be empty if there are no violations)!
!RenrakuRuleHelp class methodsFor: 'pages' stamp: ''!
runningRules

	^ HelpTopic
		title: 'Running Rules'
		contents: 'Usually you don''t have to run rules yourself, this is done by tools. But it is a good idea to be familiar with the API available in rules for developing your own tools and dubugging unexpected behaviour.
		
First of all tools traverse the hierarchy of rule classes and selects the required ones buy testing them with #checksMethod, #checksClass, etc…

The main method that the rules implement to check entities is #check:forCritiquesDo:. It accepts the entity to be checked as the first argument, and the block to be evaluated for each critique. The block may accept one parameter which is a critique object. For example:

	rule
		check: anEntity
		forCritiquesDo: [ :critique |
			"do something for each critique" ]
		
		
There are also 3 convenience methods:

#check:
Accepts an entity to check and returns the collection of critiques.

#check:ifNoCritiques:
Similarly to previous one checks an entity and returns the collection of critiques. Additionally accepts a block that will be evaluated if no critiques are found.

#check:forCritiquesDo:ifNone:
Similarly to #check:forCritiquesDo: checks an entity and evaluates the block for each detected critique. Additionally accepts a block that will be evaluated if no critiques are found.'! !

!RenrakuRuleHelp class methodsFor: 'accessing' stamp: ''!
bookDescription
	^ 'Rules are constraint descriptions about entities. Think of a rule as a function that consumes an entity and produces a collection of critiques about it (which can be empty if there are no violations)'! !

!RenrakuRuleHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#(RenrakuRuleCreationHelp runningRules)! !

!RenrakuRuleHelp class methodsFor: 'accessing' stamp: ''!
bookName

	^ 'Rules'! !

!RenrakuSpecialRulesHelp commentStamp: ''!
There are certain special rules with predefined functionality that allows to easily perform complex checks. The subsections of this Book contain references to the rules!
!RenrakuSpecialRulesHelp class methodsFor: 'accessing' stamp: ''!
bookDescription
	^ 'There are certain special rules with predefined functionality that allows to easily perform complex checks. The subsections of this Book contain references to the rules'! !

!RenrakuSpecialRulesHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(matchRules rewriteRules)! !

!RenrakuSpecialRulesHelp class methodsFor: 'accessing' stamp: ''!
bookName

	^ 'Special Rules'! !

!RenrakuSpecialRulesHelp class methodsFor: 'pages' stamp: ''!
matchRules

	^ self topicForClass: ReNodeMatchRule! !

!RenrakuSpecialRulesHelp class methodsFor: 'pages' stamp: ''!
rewriteRules

	^ self topicForClass: ReNodeRewriteRule! !

!RenrakuTest methodsFor: 'tests' stamp: ''!
testUnclassifiedMethod

	self assert: (testMethod critiques anySatisfy: [ :critic |
		critic rule class = ReUnclassifiedMethodsRule ]).
	
	testMethod protocol: 'some protocol'.
	
	self assert: (testMethod critiques noneSatisfy: [ :critic |
		critic rule class = ReUnclassifiedMethodsRule ]).! !

!RenrakuTest methodsFor: 'tests' stamp: ''!
testBan
	| criticToSkip |
		
	criticToSkip := testClass critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	testClass ban: criticToSkip.
	
	self assert: (testClass critiques noneSatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!RenrakuTest methodsFor: 'tests' stamp: ''!
testNoClassComment
		
	self assert: (testClass critiques anySatisfy: [ :critic |
		critic rule class = ReNoClassCommentRule ]).
	
	testClass comment: 'Now I have a comment'.
	
	self assert: (testClass critiques noneSatisfy: [ :critic |
		critic rule class = ReNoClassCommentRule ]).! !

!RenrakuTest methodsFor: 'tests' stamp: ''!
testBanForPackage
	| criticToSkip |
		
	criticToSkip := testClass critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	testPackage ban: criticToSkip.
	
	self assert: (testClass2 critiques noneSatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!RenrakuTest methodsFor: 'tests' stamp: ''!
testBan2
	| criticToSkip |
	
		
	criticToSkip := testMethod critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	testClass ban: criticToSkip.
	
	self assert: (testMethod critiques noneSatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!RenrakuTest methodsFor: 'tests' stamp: ''!
testAsClassRuleTransformation
	| asClassMethod critique |
	
	asClassMethod := testClass >> (testClass compile:
		'aMethodWhichSendsAsClass 
			#', self class name, ' asClass').
	
	critique := asClassMethod critiques detect: [ :crit |
		crit rule class = ReAsClassRule ].
	
	self assert: critique change class equals: RBAddMethodChange.
	self assert: (critique change source includesSubstring: 'self class environment at:')
	! !

!RenrakuTest methodsFor: 'tests' stamp: ''!
testBan1
	| criticToSkip |
	
		
	criticToSkip := testMethod critiques detect: [ :critic |
		critic rule class = ScreamerRule ].
	
	testMethod ban: criticToSkip.
	
	self assert: (testMethod critiques noneSatisfy: [ :critic |
		critic rule class = ScreamerRule ]).! !

!ReparseAfterSourceEditing commentStamp: ''!
Notify about the need to reparse after source code was edited!
!ReparseAfterSourceEditing methodsFor: 'accessing' stamp: ''!
newSource: anObject
	
	newSource := anObject! !

!ReparseAfterSourceEditing methodsFor: 'accessing' stamp: ''!
newSource
	
	^ newSource! !

!ReparseAfterSourceEditing class methodsFor: 'signaling' stamp: ''!
signalWithNewSource: aSourceCode

	^ self new
		newSource: aSourceCode;
		signal! !

!ReservedVariable commentStamp: ''!
I model self, thisContext and super!
!ReservedVariable methodsFor: 'debugging' stamp: ''!
write: aValue inContext: aContext
	
	self error: name, ' is reserved word and cant be modified'! !

!ReservedVariable methodsFor: 'converting' stamp: ''!
asString

	^ self name! !

!ReservedVariable methodsFor: 'printing' stamp: ''!
printOn: stream

	stream nextPutAll: self name! !

!ReservedVariable methodsFor: 'initialization' stamp: ''!
initialize
	environment := Smalltalk globals.
	name := self class variableName! !

!ReservedVariable methodsFor: 'testing' stamp: ''!
isReservedVariable
	^true! !

!ReservedVariable methodsFor: 'accessing' stamp: ''!
name: aSymbol
	"names of ReservedVariables are fixed and can not be changed"
	self shouldNotImplement! !

!ReservedVariable methodsFor: 'testing' stamp: ''!
isWritable
	^ false! !

!ReservedVariable methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder

	self shouldNotImplement! !

!ReservedVariable methodsFor: 'accessing' stamp: ''!
scope
	^ environment! !

!ReservedVariable methodsFor: 'queries' stamp: ''!
usingMethods
	"first call is very slow as it creates all ASTs"
	^environment allMethods select: [ : method |
		method ast variableNodes anySatisfy: [ :varNode | varNode variable == self]]! !

!ReservedVariable class methodsFor: 'accessing' stamp: ''!
instance 
	^instance ifNil: [ instance := self new ]! !

!ReservedVariable class methodsFor: 'testing' stamp: ''!
isAbstract 
	^self = ReservedVariable! !

!ReservedVariable class methodsFor: 'compiler' stamp: ''!
lookupDictionary
	"create a loopup table name -> instance for Semantic Analysis"
	^ (self subclasses collect: [ :class | 
		   class instance name -> class instance ]) asDictionary! !

!ReservedVariable class methodsFor: 'accessing' stamp: ''!
variableName
	^self subclassResponsibility! !

!ReservedVariable class methodsFor: 'testing' stamp: ''!
nameIsReserved: aName
	^self subclasses anySatisfy: [ :class | class variableName = aName ]! !

!ReservedVariableTest methodsFor: 'tests' stamp: ''!
testNameIsReserved
 	"we have these reserved vars: self, super, thisContext"
 	self assert: (ReservedVariable nameIsReserved: 'self').
 	self assert: (ReservedVariable nameIsReserved: 'super').
 	self assert: (ReservedVariable nameIsReserved: 'thisContext').

  	"true and false and nil are compiled as literals, not reserved vars"
 	self deny: (ReservedVariable nameIsReserved: 'true').
 	self deny: (ReservedVariable nameIsReserved: 'false').
 	self deny: (ReservedVariable nameIsReserved: 'nil')! !

!ResetWindow commentStamp: ''!
A ResetWindow is simple UI to reset the currently analysed model.!
!ResetWindow methodsFor: 'api' stamp: ''!
initialExtent

	^   450@30! !

!ResetWindow methodsFor: 'initialization' stamp: ''!
initializeWidgets

	resetModel := self newButton.
	currentConfigurationModel := self newButton.

	self setFocusOrder.
	self setResetModel. 
	self setCurrentConfigurationModel
	! !

!ResetWindow methodsFor: 'initialization' stamp: ''!
setResetModel
	resetModel 
		state: false;
		label: 'Reset Current Configurartion';
		action: [ SelectPackageBrowser open. 
				self delete ]! !

!ResetWindow methodsFor: 'initialization' stamp: ''!
setCurrentConfigurationModel
	currentConfigurationModel  
		state: false;
		label: 'Uses Current Configuration';
		action: [ CriticBrowser openOnWorkingConfiguration: CriticWorkingConfiguration current. 
				self delete ]! !

!ResetWindow methodsFor: 'accessing' stamp: ''!
resetModel
	^ resetModel! !

!ResetWindow methodsFor: 'accessing' stamp: ''!
currentConfigurationModel
	^ currentConfigurationModel! !

!ResetWindow methodsFor: 'initialization' stamp: ''!
setFocusOrder

	self focusOrder
		add: resetModel;
		add: currentConfigurationModel! !

!ResetWindow class methodsFor: 'specs' stamp: ''!
defaultSpec
<spec>

	^SpecLayout composed
		newRow: [:r |
			r 
				add: #resetModel;
				add: #currentConfigurationModel
			]  height: 25! !

!ResetWindow class methodsFor: 'specs' stamp: ''!
title
	^ 'Critic Browser' ! !

!ResolutionRequest commentStamp: ''!
I represent a request for user assistance in resolving an origin. I am a resumable exception that gets raised when there is no way of automatically resolving a particular origin. !
!ResolutionRequest methodsFor: 'exceptionDescription' stamp: ''!
defaultAction
	| filedir ref |
	filedir := UIManager default chooseDirectory: 'Where is ', origin asString, '?'.
	ref := filedir ifNotNil: [FileSystem disk referenceTo: filedir fullName].
	self resume: ref! !

!ResolutionRequest methodsFor: 'accessing' stamp: ''!
origin: aSymbol
	origin := aSymbol! !

!ResolutionRequest class methodsFor: 'instance creation' stamp: ''!
for: origin
	^ self new
		origin: origin;
		signal! !

!RestartDebugAction commentStamp: ''!
A RestartDebugAction restarts the execution of the current context.
!
!RestartDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 10! !

!RestartDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Go back the start of the current execution context, resetting all local variables and take debugger control.'! !

!RestartDebugAction methodsFor: 'actions' stamp: ''!
executeAction

	self session restart: self currentContext! !

!RestartDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #restart! !

!RestartDebugAction methodsFor: 'accessing' stamp: ''!
defaultKeymap

	^ PharoShortcuts current restartExecutionShortcut! !

!RestartDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Restart'! !

!RestartDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<debuggingAction>
	<contextMenuDebuggingAction>! !

!RestartTest methodsFor: 'tests' stamp: ''!
stepA2
	| a |
	a := 1.
	1+1.
	2+2.! !

!RestartTest methodsFor: 'tests' stamp: ''!
stepA1
	self stepA2.! !

!RestartTest methodsFor: 'tests' stamp: ''!
testStepRestartAndRestepTopContext
	"Get the execution to a context on method stepA2.
	Step over in it to reach the end (and check that the temporary variable assignement works)
	Restart the context.
	Step over in it a to reach the end a second time (and check that the temporary variable assignement also worked the second time)
	"
	| node |
	self settingUpSessionAndProcessAndContextForBlock: [ self stepA1 ].
	[session interruptedContext method == (self class>>#stepA1)] 
		whileFalse: [ session stepInto ].
	
	session stepInto.

	"Check that the execution is at the 'a:=1' node of method stepA2"
	self assert: session interruptedContext method equals: self class >>#stepA2.
	node := self class >>#stepA2 sourceNodeForPC: session interruptedContext pc.
	self assert: node isAssignment.
	self assert: node variable name equals: #a.
	
	session stepOver.
	session stepOver.
	"Check that the value of the 'a' temporary variable in the stepA2 context is 1"
	self assert: (session interruptedContext tempNamed: #a) equals: 1.
	"Check that the execution is at the '2+2' node of the stepA2 context"
	self assert: session interruptedContext method equals: self class >>#stepA2.
	node := self class >>#stepA2 sourceNodeForPC: session interruptedContext pc.
	self assert: node isMessage.
	self assert: node receiver isLiteralNode.
	self assert: node selector equals: #+.
	
	session restart: session interruptedContext.
	"Check that the execution returned to the 'a:=1' node of method stepA2"
	self assert: session interruptedContext method equals: self class >>#stepA2.
	node := self class >>#stepA2 sourceNodeForPC: session interruptedContext pc.
	self assert: node isAssignment.
	self assert: node variable name equals: #a.
	
	session stepOver.
	session stepOver.
	"Check that the execution has returned to the '2+2' node of the stepA2 context"
	self assert: session interruptedContext method equals: self class >>#stepA2.
	node := self class >>#stepA2 sourceNodeForPC: session interruptedContext pc.
	self assert: node isMessage.
	self assert: node receiver isLiteralNode.
	self assert: node selector equals: #+.
	"Check that the value of the 'a' temporary variable in the stepA2 context is 1 again"
	self assert: (session interruptedContext tempNamed: #a) equals: 1.! !

!RestartTest methodsFor: 'tests' stamp: ''!
testRestartTestShouldKeepTestGreen

	| testCaseForRestart failed finished |
	failed := false.
	finished := Semaphore new.

	testCaseForRestart := DebuggerTestCaseForRestartTest selector: #testPushingValuesOnActivation.
	testCaseForRestart setUp.
	self settingUpSessionAndProcessAndContextForBlock: [ 
		[ [testCaseForRestart testPushingValuesOnActivation]
				on: TestFailure do: [ failed := true ] ]
					ensure: [ finished signal ] ].
	
	[session interruptedContext selector = #testPushingValuesOnActivation]
		whileFalse: [ session stepInto ].
	session restart: session interruptedContext.
	session resume.

	finished wait.	
	self deny: failed! !

!RestartTest methodsFor: 'tests' stamp: ''!
testRestartTestShouldPushNewValuesToTheStack

	| testCaseForRestart |
	testCaseForRestart := DebuggerTestCaseForRestartTest selector: #testPushingValuesOnActivation.
	testCaseForRestart setUp.
	self settingUpSessionAndProcessAndContextForBlock: [ 
		testCaseForRestart testPushingValuesOnActivation ].

	session stepInto.
	session restart: session interruptedContext.

	self assert: session interruptedContext top == testCaseForRestart testedValue.! !

!ResumableTestFailure commentStamp: ''!
A ResumableTestFailure triggers a TestFailure, but lets execution of the TestCase continue. this is useful when iterating through collections, and #assert: ing on each element. in combination with methods like testcase>>#assert:description:, this lets you run through a whole collection and note which tests pass.

here''s an example:

	

	(1 to: 30) do: [ :each |
		self assert: each odd description: each printString, ' is even' resumable: true]

for each element where #odd returns <false>, the element will be printed to the Transcript. !
!ResumableTestFailure methodsFor: 'camp smalltalk' stamp: ''!
sunitExitWith: aValue
	self resume: aValue! !

!ResumableTestFailure methodsFor: 'camp smalltalk' stamp: ''!
isResumable
	"Of course a ResumableTestFailure is resumable ;-)"

	^true! !

!ResumableTestFailureTestCase commentStamp: ''!
SUnit tests for ResumableTestFailure!
!ResumableTestFailureTestCase methodsFor: 'running' stamp: ''!
tearDown
	self deny: 'You should not see me' = duplicateFailureLog last
			description: 'We saw the ''You should not see me'' failure'.
	self deny: 'You should see more than me' = duplicateFailureLog last
			description: 'We did not see more than a ''You should see more than me'' failure'.
	super tearDown ! !

!ResumableTestFailureTestCase methodsFor: 'test data' stamp: ''!
errorTest
	1 zork! !

!ResumableTestFailureTestCase methodsFor: 'test data' stamp: ''!
okTest
	self assert: true! !

!ResumableTestFailureTestCase methodsFor: 'test data' stamp: ''!
regularTestFailureTest
	self assert: false description: 'You should see me'! !

!ResumableTestFailureTestCase methodsFor: 'test data' stamp: ''!
failureTest
	self
		assert: false description: 'You should see me' resumable: true; 
		assert: false description: 'You should see me too' resumable: true; 
		assert: false description: 'You should see me last' resumable: false; 
		assert: false description: 'You should not see me' resumable: true! !

!ResumableTestFailureTestCase methodsFor: 'logging' stamp: ''!
logFailure: aString
	duplicateFailureLog add: aString.
	super logFailure: aString.! !

!ResumableTestFailureTestCase methodsFor: 'test data' stamp: ''!
resumableTestFailureTest
	self
		assert: false description: 'You should see more than me' resumable: true; 
		assert: false description: 'You should see more than me' resumable: true; 
		assert: false description: 'You should see me last' resumable: false; 
		assert: false description: 'You should not see me' resumable: true! !

!ResumableTestFailureTestCase methodsFor: 'tests' stamp: ''!
testResumable
	| result suite |
	suite := self classForTestSuite new.
	suite addTest: (self class selector: #errorTest).
	suite addTest: (self class selector: #regularTestFailureTest).
	suite addTest: (self class selector: #resumableTestFailureTest).
	suite addTest: (self class selector: #okTest).
	result := suite run.
	self
		assert: result failures size equals: 2;
		assert: result errors size equals: 1! !

!ResumableTestFailureTestCase methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	duplicateFailureLog := OrderedCollection with: 'In set up'.! !

!ResumableTestFailureTestCase class methodsFor: 'history' stamp: ''!
lastStoredRun
	^ ((Dictionary new) add: (#passed->((Set new) add: #testResumable; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! !

!ResumeDebugAction commentStamp: ''!
A ResumeDebugAction resumes the execution of the interrupted process and closes the debugger.
!
!ResumeDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 5! !

!ResumeDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Relinquish debugger control and proceed execution from the current point of debugger control.'! !

!ResumeDebugAction methodsFor: 'actions' stamp: ''!
executeAction

	self session 
		resume;
		clear.
	self debugger close.! !

!ResumeDebugAction methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	"No need to update the debgger as it will anyway be closed."
	self needsUpdate: false! !

!ResumeDebugAction methodsFor: 'accessing' stamp: ''!
enabled

	^ self interruptedContextIsPostMortem not! !

!ResumeDebugAction methodsFor: 'private' stamp: ''!
interruptedContextIsPostMortem

	^ (self session isContextPostMortem: self interruptedContext)! !

!ResumeDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #resume! !

!ResumeDebugAction methodsFor: 'accessing' stamp: ''!
defaultKeymap

	^ PharoShortcuts current resumeExecutionShortcut! !

!ResumeDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Proceed'! !

!ResumeDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<debuggingAction>
	<contextMenuDebuggingAction>! !

!ReturnValueDebugAction commentStamp: ''!
A ReturnValueDebugAction forces a return of a given value to the previous context
!
!ReturnValueDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 50! !

!ReturnValueDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Return of a given value to the previous context.'! !

!ReturnValueDebugAction methodsFor: 'actions' stamp: ''!
executeAction
	|expression value|
	
	expression := UIManager default request: 'Enter expression for return value:'.
	value := self class compiler
			source: expression;
			context: self currentContext;
			receiver: self currentContext receiver;
			evaluate.

	self session returnValue: value from: self currentContext! !

!ReturnValueDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #returnValue! !

!ReturnValueDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Return entered value'! !

!ReturnValueDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<contextMenuDebuggingAction>! !

!ReverseAlphabeticSorter commentStamp: ''!
Reverse alphabetic sorting!
!ReverseAlphabeticSorter methodsFor: 'sorting' stamp: ''!
sortCompletionList: anOrderedCollection
	"this is just for testing, reverse sort makes no sense in practice"
	^ anOrderedCollection sort reverse! !

!ReverseAlphabeticSorter class methodsFor: 'description' stamp: ''!
kind

	^ 'reverse'! !

!ReverseSortFunction commentStamp: ''!
A ReverseSortFunction wraps over another SortFunction so as to sort in reverse order.!
!ReverseSortFunction methodsFor: 'converting' stamp: ''!
undefinedFirst
	"apply on the original"
	^baseSortFunction undefinedLast reversed! !

!ReverseSortFunction methodsFor: 'evaluating' stamp: ''!
collate: anObject with: another
	^(baseSortFunction collate: anObject with: another) negated! !

!ReverseSortFunction methodsFor: 'converting' stamp: ''!
undefinedLast
	"apply on the original"
	^baseSortFunction undefinedFirst reversed! !

!ReverseSortFunction methodsFor: 'converting' stamp: ''!
reversed
	^baseSortFunction! !

!RewriteRuleChangesBrowser commentStamp: ''!
A changes browser for the changes generated by the rewrite rule editor!
!RewriteRuleChangesBrowser methodsFor: 'actions' stamp: ''!
cancel
	self window delete! !

!RewriteRuleChangesBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters
	changeTree := self newTreeTable.
	changeTree addColumn: (
		SpCompositeTableColumn new 
			title: 'Changes';
			addColumn: ((SpCheckBoxTableColumn title: ' ' evaluated: [ :change | selectedChanges includes: change ])
				onActivation: [ :change | 
					selectedChanges add: change];
				onDeactivation: [ :change | 
					selectedChanges remove: change];
				width: 20;
				yourself);
			addColumn: (SpStringTableColumn evaluated: #nameToDisplay));
		whenActivatedDo: [ :selection | self buildDiffFor: selection selectedItem  ].
	diffView := self newDiff.
	diffView showOptions: true.
	buttonCancel := self newButton label: 'Cancel'.
	buttonOk := self newButton label: 'Ok'.
	self focusOrder
		add: buttonCancel;
		add: buttonOk! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
buttonOk: anObject
	buttonOk := anObject! !

!RewriteRuleChangesBrowser methodsFor: 'update' stamp: ''!
updateChanges
	| aCompositeChange |
	aCompositeChange := RBRefactoryChangeManager changeFactory
		compositeRefactoryChange.
	changes do: [ :each | aCompositeChange addChange: each ].

	"Later we could filter the shown changes depending on the selected scope"

	changeTree roots: (aCompositeChange whatToDisplayIn: self)! !

!RewriteRuleChangesBrowser methodsFor: 'initialization' stamp: ''!
initialize
	changes := #().
	super initialize! !

!RewriteRuleChangesBrowser methodsFor: 'initialization' stamp: ''!
windowTitle
	
	^ 'Changes Browser'.! !

!RewriteRuleChangesBrowser methodsFor: 'instance creation' stamp: ''!
open
	^ self openWithSpec! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
diffView: anObject
	diffView := anObject! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
buttonCancel
	^ buttonCancel! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
diffView
	^ diffView! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
selectedChanges
	^ selectedChanges! !

!RewriteRuleChangesBrowser methodsFor: 'actions' stamp: ''!
accept
	self okToChange
		ifFalse: [ ^ self ].
	self selectedChanges isEmptyOrNil ifTrue: [ ^self ].	
	[ self selectedChanges do: [ :change | RBRefactoryChangeManager instance performChange: change ] ] asJob
		title: 'Refactoring';
		run.
	self window delete! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
changes
	^ changes! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
changes: anObject
	changes := anObject.
	selectedChanges := OrderedCollection withAll: changes first changes.
	self updateChanges! !

!RewriteRuleChangesBrowser methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	| fontWidth rowHeight |	
	fontWidth := (StandardFonts defaultFont widthOfString: 'M').
	rowHeight := self class inputTextHeight.
	aWindowPresenter
		title: self windowTitle;
		initialExtent: (70@20) * (fontWidth @ rowHeight)! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
selectedChanges: anObject
	selectedChanges := anObject! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
changeTree: anObject
	changeTree := anObject! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
changeTree
	^ changeTree! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
buttonOk
	^ buttonOk! !

!RewriteRuleChangesBrowser methodsFor: 'initialization' stamp: ''!
connectPresenters
	changeTree children: [ :aChange | 
		(aChange isNotNil and: [aChange changesSize > 1]) 
			ifTrue: [ aChange changes ] 
			ifFalse: [#()]].
	buttonCancel action: [ self cancel ].														
	buttonOk action: [ self accept ].! !

!RewriteRuleChangesBrowser methodsFor: 'update' stamp: ''!
buildDiffFor: aChange

	^ aChange
		ifNil: [ '' ]
		ifNotNil: [
			diffView 
				contextClass: aChange changeClass;
				leftText: aChange oldVersionTextToDisplay; 
				rightText: aChange textToDisplay ]! !

!RewriteRuleChangesBrowser methodsFor: 'accessing' stamp: ''!
buttonCancel: anObject
	buttonCancel := anObject! !

!RewriteRuleChangesBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom 
		add: (SpPanedLayout newTopToBottom
			add: #changeTree;
			add: #diffView;
		yourself);
		add: (SpBoxLayout newLeftToRight
			addLast: #buttonCancel expand: false fill: true padding: 2;
			addLast: #buttonOk expand: false fill: false padding: 0;
			yourself) 
		expand: false 
		fill: false 
		padding: 2;
		yourself! !

!RewriteRuleChangesBrowser class methodsFor: 'instance creation' stamp: ''!
changes: aCollection

	^ self new
		changes: aCollection;
		yourself! !

!RewriteRuleEditor commentStamp: ''!
An editor for rewrite rules. !
!RewriteRuleEditor methodsFor: 'actions' stamp: ''!
runReplace
	| env rewriter changes |
	env := RBBrowserEnvironment default forPackages: (RPackageOrganizer default packages ).

	rewriter := RBParseTreeRewriter new.
	rewriter  
		replace: searchPattern text with: replacePattern text.

	changes := Array with: (RBSmalllintChecker runRule: (RBTransformationRule new
		rewriteRule: rewriter;
		yourself)
		onEnvironment:  env  ) builder.

 (RewriteRuleChangesBrowser changes: changes) open.! !

!RewriteRuleEditor methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	| fontWidth rowHeight |	
	fontWidth := (StandardFonts defaultFont widthOfString: 'M').
	rowHeight := self class inputTextHeight.
	aWindowPresenter
		title: self windowTitle;
		initialExtent: (50@18) * (fontWidth @ rowHeight);
		whenOpenedDo: [ helpText color: self theme baseColor]! !

!RewriteRuleEditor methodsFor: 'initialization' stamp: ''!
windowTitle
	
	^ 'Rewrite rule editor'.! !

!RewriteRuleEditor methodsFor: 'initialization' stamp: ''!
initializePresenters
	searchLabel := self newLabel.
	searchLabel label: 'Search for:'.
	searchPattern := self newText 
		autoAccept: true;
		yourself.
	replaceLabel := self newLabel.
	replaceLabel label: 'Replace with:'.
	replacePattern := self newText 
		autoAccept: true;
		yourself.
	helpText := self newText
		text: '` = meta var
@ = list
` = recurse into
. = statement
# = literal';
		enabled: false;
		yourself.
	replaceButton := self newButton label: 'Replace...'.
	self focusOrder
		add: searchPattern;
		add: replacePattern;
		add: replaceButton! !

!RewriteRuleEditor methodsFor: 'initialization' stamp: ''!
connectPresenters
	replaceButton action: [ self runReplace ].! !

!RewriteRuleEditor class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		add: (SpBoxLayout newTopToBottom
			add: #searchLabel expand: false;
			add: #searchPattern expand: true fill: true padding: 0;
			add: #replaceLabel expand: false;
			add: #replacePattern expand: true fill: true padding: 0) 
			expand: true fill: true padding: 5;
		add: (SpBoxLayout newTopToBottom 
			add: #helpText expand: true fill: true padding: 18;
			addLast: #replaceButton)
			expand: false fill: false padding: 0;
		yourself! !

!RewriteRuleEditor class methodsFor: 'examples' stamp: ''!
open
	<example>
	^self new openWithSpec! !

!RewriteRuleEditor class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
    <worldMenu>
    (aBuilder item: #'Rewrite Rule Editor')
                action: [self open];
                parent: #Refactoring;
                help: 'Editor for custom refactoring rewrites';
                order: 10! !

!Ring2ChunkImporterTest commentStamp: ''!
I'm a nice comment!!, treat me well :).!
!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testClassWithUnknownSlotsWithMessages

	| importer class | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'Object subclass: #SlotExampleMovie
	slots: { #name. #year. #director => ToOneRelationSlot inverse: #directedMovies inClass: #SlotExamplePerson. 
				#actors => ToManyRelationSlot inverse: #actedInMovies inClass: #SlotExamplePerson }
	classVariables: {  }
	category: ''Slot-Tests-Associations''!!' readStream.

	class := importer environment ask behaviorNamed: #SlotExampleMovie.
	self assert: class notNil.
	self assert: class instVarNames asArray equals: #(#name #year #director #actors).
	self assert: class classVarNames isEmpty.
	self assert: class category equals: 'Slot-Tests-Associations'.
	self assert: ((class slots last: 2) allSatisfy: [ :each | each isKindOf: RGUnknownSlot  ])
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardTraitWithExclusions

	| importer trait usedTraits | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'Trait named: #TClass
	uses: TClassDescription - {#msg1. #msg2}
	category: ''Traits-Kernel''' readStream.

	trait := importer environment ask behaviorNamed: #TClass.
	self assert: trait notNil.
	self assert: trait traitComposition transformations notEmpty.
	usedTraits := trait traitComposition transformations.
	self assert: usedTraits size equals: 1.
	self assert: usedTraits first subject name equals: 'TClassDescription'.
	self assert: usedTraits first exclusions asArray equals: #(msg1 msg2).
	
	self assert: trait category equals: 'Traits-Kernel'.
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardClass

	| importer class | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'Object subclass: #SomeClass
			instanceVariableNames: ''''
			classVariableNames: ''''
			poolDictionaries: ''''
			category: ''SomePackage''!!' readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class instVarNames isEmpty.
	self assert: (class hasResolved: #layout).
	self assert: (class layout hasResolved: #slots).
	self assert: (class hasResolved: #classVariables).
	self assert: (class classVariables isEmpty).
	self assert: (class hasResolved: #sharedPools).
	self assert: (class sharedPoolNames isEmpty).
	self assert: class category equals: #SomePackage.
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMethodInExistingTrait

	| importer trait method code | 
	
	importer := RGChunkImporter new.

	trait := importer environment ensureTraitNamed: #'SomeTrait'.

	code := '!!SomeTrait methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!someMethod
	^true'.
	
	importer fileInFrom: code readStream.

	method := trait methodNamed: #someMethod.
	
	self assert: (trait isTrait and: [trait isMetaclassTrait not]).
	self assert: method notNil.
	self assert: method isRingResolved.
	self assert: (method hasResolvedAll: #(name sourceCode author time tags)).
	
	self assert: method name equals: #someMethod.
	self assert: method protocol equals: 'some protocol'.
	self assert: method author equals: 'GuillermoPolito'.
	self assert: method time equals: ('5/2/2012 13:35' asDateAndTime).
	self assert: method sourceCode equals: 'someMethod
	^true'.! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardComment

	| importer class comment code | 
	
	importer := RGChunkImporter new.
	
	code := self testingCommentFor: #SomeClass.
	
	importer fileInFrom: code readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	comment := class comment.
	
	self assert: comment notNil.
	self assert: comment isComment.
	self assert: comment isRingResolved.
	self assert: (comment hasResolvedAll: #(content author time)).
	
	self assert: comment content equals: 'I''m a nice comment!!, treat me well :).'.
	self assert: comment author equals: 'GuillermoPolito'.
	self assert: comment time equals: ('5/2/2012 13:35' asDateAndTime).
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testMultipleChunks
	| importer class |
	importer := RGChunkImporter new.

	importer
		fileInFrom:
			'Object subclass: #SomeClass!!
Object subclass: #SomeClass2!!' readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class notNil.
	self assert: class superclass name equals: #Object.

	class := importer environment ask behaviorNamed: #SomeClass2.
	self assert: class notNil.
	self assert: class superclass name equals: #Object! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testMultipleMixedChunksInStrangeOrder
	| importer class method |
	importer := RGChunkImporter new.

	importer
		fileInFrom:
			'!!SomeClass methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!
someMethod
	^true!! !!
Object subclass: #SomeClass!!' readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class notNil.
	self assert: class superclass name equals: #Object.
	method := class methodNamed: #someMethod.
	self assert: method notNil.
	self assert: (method sourceCode endsWith: '^true')! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMetaclassMethod

	| importer class method code | 
	
	importer := RGChunkImporter new.
	
	code := '!!SomeClass class methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!someMethod
	^true'.
	
	importer fileInFrom: code readStream.

	class := importer environment ask behaviorNamed: #'SomeClass class'.
	method := class methodNamed: #someMethod.
	
	self assert: class isMetaclass.
	self assert: method isRingResolved.
	self assert: (method hasResolvedAll: #(name tags sourceCode author time)).
	
	self assert: method name equals: #someMethod.
	self assert: method protocol equals: 'some protocol'.
	self assert: method author equals: 'GuillermoPolito'.
	self assert: method time equals: ('5/2/2012 13:35' asDateAndTime).
	self assert: method sourceCode equals: 'someMethod
	^true'.! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMethodInNewMetaclassTrait

	| importer trait method code | 
	
	" EXPECTED FAILURE "
	"This test currently needs to fail because the CodeImporter gives only original behavior name and #isMata. 
	We do not know that the behavior was supposed to be classTrait."
	
	importer := RGChunkImporter new.
	
	code := '!!SomeTrait classTrait methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!someMethod
	^true'.
	
	importer fileInFrom: code readStream.

	trait := importer environment ask behaviorNamed: #SomeTrait.
	method := trait metaclass methodNamed: #someMethod.
	
	self assert: trait isTrait.
	self assert: trait classTrait isMetaclassTrait.
	self assert: method notNil.
	self assert: method isRingResolved.
	self assert: (method hasResolvedAll: #(name protocol sourceCode author time)).
	
	self assert: method name equals: #someMethod.
	self assert: method protocol name equals: 'some protocol'.
	self assert: method author equals: 'GuillermoPolito'.
	self assert: method time equals: ('5/2/2012 13:35' asDateAndTime).
	self assert: method sourceCode equals: 'someMethod
	^true'.! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMethodInNewMetaclass

	| importer class method code | 
	
	importer := RGChunkImporter new.
	
	code := '!!SomeClass class methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!someMethod
	^true'.
	
	importer fileInFrom: code readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	method := class metaclass methodNamed: #someMethod.
	
	self assert: class isClass.
	self assert: method notNil.
	self assert: method isRingResolved.
	self assert: (method hasResolvedAll: #(name tags sourceCode author time)).
	
	self assert: method name equals: #someMethod.
	self assert: method protocol equals: 'some protocol'.
	self assert: method author equals: 'GuillermoPolito'.
	self assert: method time equals: ('5/2/2012 13:35' asDateAndTime).
	self assert: method sourceCode equals: 'someMethod
	^true'.! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMethodInExistingMetaclassTrait

	| importer trait method code | 
	
	importer := RGChunkImporter new.

	trait := importer environment ensureMetaclassTraitNamed: #'SomeTrait classTrait'.

	code := '!!SomeTrait classTrait methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!someMethod
	^true'.
	
	importer fileInFrom: code readStream.

	method := trait methodNamed: #someMethod.
	
	self assert: (trait isMetaclassTrait).
	self assert: method notNil.
	self assert: method isRingResolved.
	self assert: (method hasResolvedAll: #(name sourceCode author time tags)).
	
	self assert: method name equals: #someMethod.
	self assert: method protocol equals: 'some protocol'.
	self assert: method author equals: 'GuillermoPolito'.
	self assert: method time equals: ('5/2/2012 13:35' asDateAndTime).
	self assert: method sourceCode equals: 'someMethod
	^true'.! !

!Ring2ChunkImporterTest methodsFor: 'private - utilities' stamp: ''!
testingHistoricalCommentFor: aClassName

	| comment commentToWrite|

	comment := 'I''m a nice comment!!, treat me well :).'.
	commentToWrite := 'I''m a nice comment!!!!, treat me well :).' replaceAll: '!!' with: '!!!!'.
	^ ('!!{1} commentStamp: ''<historical>'' prior: 0!!{2}!!' format: { aClassName. commentToWrite }).
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testClassWithUnknownSlots

	| importer class | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'Object subclass: #SlotExampleMovie
	slots: { #name. #year. #director => ToOneRelationSlot. 
				#actors => ToManyRelationSlot }
	classVariables: {  }
	category: ''Slot-Tests-Associations''!!' readStream.

	class := importer environment ask behaviorNamed: #SlotExampleMovie.
	self assert: class notNil.
	self assert: class instVarNames asArray equals: #(#name #year #director #actors).
	self assert: class classVarNames isEmpty.
	self assert: class category equals: 'Slot-Tests-Associations'.
	self assert: ((class slots last: 2) allSatisfy: [ :each | each isKindOf: RGUnknownSlot  ]).
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMetaclassTrait

	| importer trait | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'TBehavior classTrait
	uses: {}' readStream.

	trait := importer environment ask behaviorNamed: #'TBehavior classTrait'.
	self assert: trait notNil.
	self assert: trait isMetaclassTrait.
	self assert: trait traitComposition transformations isEmpty.
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testMetaclassWithTrait

	| importer class | 
	
	importer := RGChunkImporter new.
	importer fileInFrom: 'SomeClass class
	uses: SomeTrait classTrait
	instanceVariableNames: ''''' readStream.
	class := importer environment ask behaviorNamed: 'SomeClass class'.
	self assert: class notNil.
	self assert: class isMetaclass.
	self assert: class instVarNames isEmpty.
	self assert: (importer environment ask behaviorNamed: 'SomeClass') notNil.
	self assert: (importer environment ask behaviorNamed: 'SomeTrait classTrait') notNil.
	self assert: (importer environment ask behaviorNamed: 'SomeTrait') notNil.
	self assert: class traitComposition transformations size equals: 1.
	self assert: class traitComposition transformations first name equals: 'SomeTrait classTrait'.
	self assert: class traitComposition transformations first isTrait.

! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testMultipleMixedChunksInStrangeOrderWithMetaclassTrait

	| importer trait method | 
	
	" EXPECTED FAILURE "
	"This test currently needs to fail because the CodeImporter gives only original behavior name and #isMata. 
	We do not know that the behavior was supposed to be classTrait."	
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: '!!TBehavior classTrait methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!
someMethod
	^true!! !!
Trait named: #TBehavior
	uses: {}
	package: ''Traits-Kernel-Traits''!!' readStream.

	trait := importer environment ask behaviorNamed: #'TBehavior classTrait'.
	self assert: trait notNil.
	self assert: (trait isTrait and: [ trait isMetaclassTrait not ]).
	method := trait methodNamed: #someMethod.
	self assert: method notNil.
	self assert: (method sourceCode endsWith: '^true')

	! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardTraitWithTraits

	| importer trait | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'Trait named: #TBehavior
	uses: {}
	package: ''Traits-Kernel-Traits''' readStream.

	trait := importer environment ask behaviorNamed: #TBehavior.
	self assert: trait notNil.
	self assert: trait traitComposition transformations isEmpty.
	self assert: trait package name equals: 'Traits-Kernel-Traits'.
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testMultipleMixedChunksInStrangeOrderWithTrait

	| importer trait method | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: '!!TBehavior methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!
someMethod
	^true!! !!
Trait named: #TBehavior
	uses: {}
	package: ''Traits-Kernel-Traits''!!' readStream.

	trait := importer environment ask behaviorNamed: #TBehavior.
	self assert: trait notNil.
	self assert: (trait isTrait and: [ trait isMetaclassTrait not ]).
	method := trait methodNamed: #someMethod.
	self assert: method notNil.
	self assert: (method sourceCode endsWith: '^true')

	! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardSubclasses

	| importer class | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'Object subclass: #SomeClass!!' readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class superclass name equals: #Object.
	
! !

!Ring2ChunkImporterTest methodsFor: 'private - utilities' stamp: ''!
testingCommentFor: aClassName

	| comment commentToWrite|

	comment := 'I''m a nice comment!!, treat me well :).'.
	commentToWrite := 'I''m a nice comment!!!!, treat me well :).' replaceAll: '!!' with: '!!!!'.
	^ ('!!{1} commentStamp: ''GuillermoPolito 5/2/2012 13:35'' prior: 0!!{2}!!' format: { aClassName. commentToWrite }).
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardClassWithPackage

	| importer class | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'Object subclass: #SomeClass
			instanceVariableNames: ''''
			classVariableNames: ''''
			poolDictionaries: ''''
			package: ''SomePackage''!!' readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class instVarNames isEmpty.
	self assert: (class hasResolved: #layout).
	self assert: (class layout hasResolved: #slots).
	self assert: (class hasResolved: #classVariables).
	self assert: (class classVariables isEmpty).
	self assert: (class hasResolved: #sharedPools).
	self assert: (class sharedPoolNames isEmpty).
	self assert: class package name equals: #SomePackage.
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMetaclassTraitWithMultipleTraits

	| importer trait usedTraits | 
	importer := RGChunkImporter new.
	importer fileInFrom: 'TClass classTrait
	uses: TClassDescription classTrait + TComposingDescription classTrait + TTransformationCompatibility classTrait' readStream.
	trait := importer environment ask behaviorNamed: #'TClass classTrait'.
	self assert: trait notNil.
	self assert: trait isMetaclassTrait.
	self assert: trait traitComposition transformations notEmpty.
	usedTraits := trait traitComposition transformations.
	self assert: (usedTraits allSatisfy: [:each | each isTrait]).
	self assert: (usedTraits collect: [:each | each name]) asArray equals: #('TClassDescription classTrait' 'TComposingDescription classTrait' 'TTransformationCompatibility classTrait').

	
! !

!Ring2ChunkImporterTest methodsFor: 'expected failures' stamp: ''!
expectedFailures
	^ #(testMultipleMixedChunksInStrangeOrderWithMetaclassTrait testStandardMethodInNewMetaclassTrait)! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardTrait

	| importer trait | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'Trait named: #TBehavior
	uses: {}
	package: ''Traits-Kernel-Traits''' readStream.

	trait := importer environment ask behaviorNamed: #TBehavior.
	self assert: trait notNil.
	self assert: (trait isTrait and: [trait isMetaclassTrait not]).
	self assert: trait traitComposition transformations isEmpty.
	self assert: trait package name equals: 'Traits-Kernel-Traits'.
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testMultipleClassChunksInStrangeOrder
	| importer class class2 |
	importer := RGChunkImporter new.

	importer
		fileInFrom:
			'SomeClass2 subclass: #SomeClass!!
Object subclass: #SomeClass2!!' readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class notNil.
	self assert: class superclass name equals: #SomeClass2.

	class2 := importer environment ask behaviorNamed: #SomeClass2.
	self assert: class2 notNil.
	self assert: class2 superclass name equals: #Object.

	self assert: class superclass identicalTo: class2! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMethod

	| importer class method code | 
	
	importer := RGChunkImporter new.
	
	code := '!!SomeClass methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!someMethod
	^true'.
	
	importer fileInFrom: code readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	method := class methodNamed: #someMethod.
	
	self assert: class isClass.
	self assert: method notNil.
	self assert: method isRingResolved.
	self assert: (method hasResolvedAll: #(name sourceCode author time tags)).
	
	self assert: method name equals: #someMethod.
	self assert: method protocol equals: 'some protocol'.
	self assert: method author equals: 'GuillermoPolito'.
	self assert: method time equals: ('5/2/2012 13:35' asDateAndTime).
	self assert: method sourceCode equals: 'someMethod
	^true'.! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testProtoObject

	| importer class | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'ProtoObject subclass: #ProtoObject
	instanceVariableNames: ''''
	classVariableNames: ''''
	package: ''Kernel-Objects''.
ProtoObject superclass: nil!!' readStream.

	class := importer environment ask behaviorNamed: #ProtoObject.
	self assert: class notNil.
	self assert: class superclass isNil.
	self assert: class instVarNames isEmpty.
	self assert: class classVarNames isEmpty.
	self assert: class package name equals: 'Kernel-Objects'.
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testHistoricalStandardComment

	| importer class comment code | 
	
	importer := RGChunkImporter new.
	
	code := self testingHistoricalCommentFor: #SomeClass.
	
	importer fileInFrom: code readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	comment := class comment.
	
	self assert: comment notNil.
	self assert: comment isComment.
	self assert: comment isRingResolved.
	self assert: (comment hasResolvedAll: #(content author time)).
	
	self assert: comment content equals: 'I''m a nice comment!!, treat me well :).'.
	self assert: comment author equals: '<historical>'.
	self assert: comment time equals: DateAndTime new.
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMetaclassTraitWithSingleTrait
	| importer trait usedTrait |
	importer := RGChunkImporter new.

	importer
		fileInFrom:
			'TClass classTrait
	uses: TBehaviorCategorization classTrait' readStream.

	trait := importer environment ask behaviorNamed: #'TClass classTrait'.
	self assert: trait notNil.
	self assert: trait isMetaclassTrait.
	self assert: trait traitComposition transformations notEmpty.
	usedTrait := trait traitComposition transformations first.
	self assert: usedTrait name equals: #'TBehaviorCategorization classTrait'.
	self assert: (importer environment ask behaviorNamed: #'TBehaviorCategorization classTrait') notNil! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMetaclass

	| importer class | 
	
	importer := RGChunkImporter new.
	importer fileInFrom: 'SomeClass class
	instanceVariableNames: ''''' readStream.
	class := importer environment ask behaviorNamed: 'SomeClass class'.
	self assert: class notNil.
	self assert: class isMetaclass.
	self assert: class instVarNames isEmpty.
	self assert: (importer environment ask behaviorNamed: 'SomeClass') notNil.

	importer := RGChunkImporter new.
	importer fileInFrom: 'SomeClass class
	instanceVariableNames: ''var1 var2 var3''' readStream.
	class := importer environment ask behaviorNamed: 'SomeClass class'.
	self assert: class notNil.
	self assert: class isMetaclass.
	self assert: class instVarNames equals: #(var1 var2 var3).
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardClassWithVariables

	
	| importer class | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'Object subclass: #SomeClass
			instanceVariableNames: ''var1 var2 var3''
			classVariableNames: ''ClassVar1 ClassVar2 ClassVar3''
			poolDictionaries: ''Pool1 Pool2 Pool3''
			category: ''SomePackage''!!' readStream.

	class := importer environment ask behaviorNamed: #SomeClass.

	self assert: (class hasResolved: #layout).
	self assert: class instVarNames equals: #(var1 var2 var3).
	self assert: (class instVarNames allSatisfy: #isSymbol).

	self assert: (class hasResolved: #classVariables).
	self assert: class classVarNames equals: #(ClassVar1 ClassVar2 ClassVar3).
	self assert: (class instVarNames allSatisfy: #isSymbol).

	self assert: (class hasResolved: #sharedPools).
	self assert: class sharedPoolNames equals: #(Pool1 Pool2 Pool3).
	self assert: (class sharedPoolNames allSatisfy: #isSymbol).

	self assert: class category equals: #SomePackage.
	! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardMethodInExistingClass

	| importer class method code | 
	
	importer := RGChunkImporter new.
	class := importer environment ensureClassNamed: #SomeClass.
	
	code := '!!SomeClass methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!someMethod
	^true'.
	
	importer fileInFrom: code readStream.

	method := class methodNamed: #someMethod.
	
	self assert: class isClass.
	self assert: method notNil.
	self assert: method isRingResolved.
	self assert: (method hasResolvedAll: #(name sourceCode author time tags)).
	
	self assert: method name equals: #someMethod.
	self assert: method protocol equals: 'some protocol'.
	self assert: method author equals: 'GuillermoPolito'.
	self assert: method time equals: ('5/2/2012 13:35' asDateAndTime).
	self assert: method sourceCode equals: 'someMethod
	^true'.! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardTraitWithSingleTrait
	| importer trait usedTrait |
	importer := RGChunkImporter new.

	importer
		fileInFrom:
			'Trait named: #TClass
	uses: TBehaviorCategorization
	package: ''Traits-Kernel-Traits''' readStream.

	trait := importer environment ask behaviorNamed: #TClass.
	self assert: trait notNil.
	self assert: trait traitComposition transformations notEmpty.
	usedTrait := trait traitComposition transformations first.
	self assert: usedTrait name equals: #TBehaviorCategorization.
	self assert: (importer environment ask behaviorNamed: #TBehaviorCategorization) notNil.
	self assert: trait category equals: 'Traits-Kernel-Traits'! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testClassWithSimpleSlots

	| importer class | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'Object subclass: #SlotExampleMovie
	slots: { #name. #year. #director. #actors }
	classVariables: {  }
	category: ''Slot-Tests-Associations''!!' readStream.

	class := importer environment ask behaviorNamed: #SlotExampleMovie.
	self assert: class notNil.
	self assert: class instVarNames asArray equals: #(#name #year #director #actors).
	self assert: class classVarNames isEmpty.
	self assert: class category equals: 'Slot-Tests-Associations'.
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testStandardTraitWithMultipleTraits

	| importer trait usedTraits | 	
	importer := RGChunkImporter new.
	importer fileInFrom: 'Trait named: #TClass
	uses: TClassDescription + TComposingDescription + TTransformationCompatibility
	category: ''Traits-Kernel''' readStream.

	trait := importer environment ask behaviorNamed: #TClass.
	self assert: trait notNil.
	self assert: trait traitComposition transformations notEmpty.
	usedTraits := trait traitComposition transformations.
	self assert: (usedTraits allSatisfy: [:each | each isTrait]).
	self assert: (usedTraits collect: [:each | each name]) asArray equals: #(TClassDescription TComposingDescription TTransformationCompatibility).
	self assert: trait category equals: 'Traits-Kernel'.
! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testSpecialSuperclasses

	| importer class | 
	
	importer := RGChunkImporter new.
	importer fileInFrom: 'SomeClass subclass: #SomeClass' readStream.
	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class notNil.
	self assert: class superclass equals: class.

	importer := RGChunkImporter new.
	importer fileInFrom: 'SomeClass subclass: #SomeClass.
	SomeClass superclass: nil.!!' readStream.
	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class notNil.
	self assert: class superclass isNil.

	importer := RGChunkImporter new.
	importer fileInFrom: 'SomeClass subclass: #SomeClass.
	SomeOtherClass superclass: nil.!!' readStream.
	" Only a DoIt, because  we specify different superclass. "
	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class isNil.
	importer doIts notEmpty.

	importer := RGChunkImporter new.
	importer fileInFrom: 'SomeClass subclass: #SomeClass.
	SomeClass superclass: self.!!' readStream.
	" Only a DoIt, because  we do not specify superclass as nil. "
	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class isNil.
	importer doIts notEmpty.

	importer := RGChunkImporter new.
	importer fileInFrom: 'SomeClass subclass: #SomeClass.
	SomeClass yourself.
	SomeClass superclass: nil.!!' readStream.
	" Only a DoIt, because we do not keep expected format "
	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class isNil.
	importer doIts notEmpty.! !

!Ring2ChunkImporterTest methodsFor: 'tests' stamp: ''!
testClassWithNilSuperclass

	| importer class | 
	
	importer := RGChunkImporter new.
	
	importer fileInFrom: 'SomeClass subclass: #SomeClass
	instanceVariableNames: ''''
	classVariableNames: ''''
	package: ''SomePackage''.
SomeClass superclass: nil!!' readStream.

	class := importer environment ask behaviorNamed: #SomeClass.
	self assert: class notNil.
	self assert: class instVarNames isEmpty.
	self assert: class classVarNames isEmpty.
	self assert: class package name equals: 'SomePackage'.
! !

!RingChunkImporter commentStamp: ''!
I'm an object holding the result of loading a file containing Pharo code definitions in chunk format.
I create ring definitions for the elements inside the chunk stream.
Heavily inspired from FilePackage.

see example method class side !
!RingChunkImporter methodsFor: 'accessing' stamp: 'nil'!
classes
	^ package classes values! !

!RingChunkImporter methodsFor: 'visitor' stamp: 'nil'!
visitClassOrganizationChunk: aChunk

	"Do nothing with class organizations for the moment"! !

!RingChunkImporter methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	package := RGPackageDefinition named: 'ChangeSet'.
	doIts := Set new.! !

!RingChunkImporter methodsFor: 'private' stamp: 'nil'!
metaTraitDefinition: string with: chgRec
	| tokens trait |
	
	tokens := self scannedSource: string.
	
	trait := self classNamed: tokens first.
	trait isTrait
		ifFalse:[ trait:= self createTraitNamed: tokens first ].
	
	trait classSide definitionSource: string! !

!RingChunkImporter methodsFor: 'private' stamp: 'nil'!
scannedSource: aString

	^ Smalltalk compiler parseLiterals: aString! !

!RingChunkImporter methodsFor: 'visitor' stamp: 'nil'!
visitDoItChunk: aChunk

	| contents |
	contents := aChunk contents.
	('*ubclass:*instanceVariableNames:*classVariableNames:*poolDictionaries:*category:*'
		match: contents) ifTrue:[^self classDefinition: contents with: aChunk].
	('* class*instanceVariableNames:*'
		match: contents) ifTrue:[^self metaClassDefinition: contents with: aChunk].		
	('Trait*named:*uses:*category:*'
		match: contents) ifTrue:[^self traitDefinition: contents with: aChunk].
	('* classTrait*uses:*'
		match: contents) ifTrue:[^self metaTraitDefinition: contents with: aChunk].	
	('* removeSelector:*'
		match: contents) ifTrue:[^self removedMethod: contents with: aChunk].
	('* comment:*'
		match: contents) ifTrue:[^self msgClassComment: contents with: aChunk].
	('* initialize'
		match: contents) ifTrue:[^self]. "Initialization is done based on class>>initialize"
	doIts add: aChunk.! !

!RingChunkImporter methodsFor: 'reading' stamp: 'nil'!
fromFileNamed: aName
	
	package := RGPackageDefinition named: aName.
	self fileInFrom: aName asFileReference readStream.! !

!RingChunkImporter methodsFor: 'visitor' stamp: 'nil'!
visitStyleChunk: aChunk

	"Do nothing with styles"! !

!RingChunkImporter methodsFor: 'private' stamp: 'nil'!
classNamed: className

	(package includesClassNamed: className) 
		ifTrue:[ ^ package classNamed: className ].
	^ self createClassNamed: className! !

!RingChunkImporter methodsFor: 'reading' stamp: 'nil'!
fileInFrom: aStream

	| changes |
	changes := (CodeImporter readStream: aStream) parseChunks.
	changes do: [ :change | change accept: self ].! !

!RingChunkImporter methodsFor: 'private' stamp: 'nil'!
metaClassDefinition: string with: chgRec
	| tokens theClass |
	
	tokens := self scannedSource: string.
	
	theClass := self classNamed: tokens first.
	theClass classSide definitionSource: string;
			  instanceVariables: (tokens fourth findTokens: ' ')! !

!RingChunkImporter methodsFor: 'private' stamp: 'nil'!
classDefinition: aString with: chgRec
	| tokens theClass |
	
	tokens := self scannedSource: aString.
	theClass := self classNamed: tokens third.
	theClass superclassName: tokens first;
			 definitionSource: aString;
			 category: tokens last.
	
	tokens size = 11
	ifTrue:[ theClass instanceVariables: (tokens fifth findTokens: ' ');
			 	classVariables: (tokens seventh findTokens: ' ');
				 sharedPools: (tokens ninth findTokens: ' ') ].
	
	tokens size = 13
	ifTrue:[ theClass traitCompositionSource: (tokens fifth);  
				instanceVariables: (tokens seventh findTokens: ' ');
			 	classVariables: (tokens ninth findTokens: ' ');
				 sharedPools: ((tokens at: 11) findTokens: ' ') ].! !

!RingChunkImporter methodsFor: 'accessing' stamp: 'nil'!
packages
	
	^ { package }! !

!RingChunkImporter methodsFor: 'accessing' stamp: 'nil'!
doIts
	^ doIts! !

!RingChunkImporter methodsFor: 'visitor' stamp: 'nil'!
visitMethodChunk: aChunk

	| theClass theMethod |
	theClass:= self classNamed: aChunk behaviorName.
	theMethod := (RGMethodDefinition
						class: theClass
						selector: aChunk methodSelector)
							protocol: aChunk category;
							sourceCode: aChunk contents;
							stamp: aChunk stamp.
	aChunk isMeta 
		ifTrue: [ 
			theMethod isMetaSide: true.
			theClass classSide addMethod: theMethod. ] 
		ifFalse:[ theClass addMethod: theMethod ]! !

!RingChunkImporter methodsFor: 'private' stamp: 'nil'!
removedMethod: string with: aChunk
	
	| orClass tokens |
	tokens := self scannedSource: string.
	tokens size >= 3
		ifTrue:[ orClass := self classNamed: tokens first. 
		^ (tokens second == #class
			ifTrue: [ orClass classSide ]
			ifFalse:[ orClass ]) removeSelector: tokens last ].
	doIts add: aChunk! !

!RingChunkImporter methodsFor: 'private' stamp: 'nil'!
traitDefinition: aString with: chgRec

	| tokens trait |
	tokens := self scannedSource: aString.
	trait := self classNamed: tokens third.
	trait isTrait
		ifFalse: [ trait:= self createTraitNamed: tokens third ].
	trait superclassName: tokens first;
			 definitionSource: aString;
			 category: tokens last! !

!RingChunkImporter methodsFor: 'private' stamp: 'nil'!
createClassNamed: className
	| rgClass |
	rgClass := RGClassDefinition named: className.
	rgClass withMetaclass.
	package addClass: rgClass.
	^ rgClass.! !

!RingChunkImporter methodsFor: 'private' stamp: 'nil'!
createTraitNamed: traitName

	| trait |
	trait := RGTraitDefinition named: traitName.
	trait withMetaclass.
	package addTrait: trait.
	^ trait.! !

!RingChunkImporter methodsFor: 'private' stamp: 'nil'!
msgClassComment: string with: chgRec

	| tokens theClass |
	tokens := self scannedSource: string.
	
	(tokens size >= 3
		and:[ tokens last isString ])
	ifTrue:[
		theClass := self classNamed: tokens first.
		((tokens at: (tokens size - 1)) == #class
		ifTrue: [ theClass classSide ]
		ifFalse:[ theClass ]) comment: tokens last asString ]! !

!RingChunkImporter methodsFor: 'visitor' stamp: 'nil'!
visitClassCommentChunk: aChunk

	(self classNamed: aChunk behaviorName)
		comment: aChunk contents;
		stamp: aChunk stamp.! !

!RingChunkImporter class methodsFor: 'instance creation' stamp: 'nil'!
fromStream: aStream

	^ self new fileInFrom: aStream; yourself! !

!RingChunkImporter class methodsFor: 'examples' stamp: 'nil'!
example
	| internalStream |
	internalStream := (String new: 1000) writeStream.
	SystemOrganization
		fileOutCategory: 'Ring-Deprecated-ChunkImporter-Base'
		on: internalStream.
	(RingChunkImporter fromStream: internalStream contents readStream)
		inspect! !

!RingChunkImporter class methodsFor: 'instance creation' stamp: 'nil'!
fromFileNamed: fileName

	^ self new fromFileNamed: fileName; yourself! !

!RoassalSpecTest methodsFor: 'tests' stamp: ''!
testBasic
	| spec value window |
	"comment"
	spec := Smalltalk globals at: #SpRoassalPresenter 
		ifPresent: [:cls | cls new]
		ifAbsent: [^ self ].
	self assert: spec class equals: SpRoassalPresenter.
	window := spec openWithSpec.
	value := 0.
	
	spec script: [ :view | view addShape: RSBox new. value := value + 1 ].
	self assert: value equals: 1.
	spec script: [ :view | view addShape: RSBox new. value := 0 ].
	self assert: value equals: 0.
	window close.! !

!RootClassPoolUser commentStamp: ''!
I'm a class using a single shared pool (which hides a system class). My subclasses should be able to 
access the class variable defined in the pool I use. !
!RootClassPoolUser class methodsFor: 'accessing' stamp: ''!
gloups

	^  Gloups! !

!RootClassPoolUser class methodsFor: 'accessing' stamp: ''!
author

	^  AnAuthor! !

!RoundedBorder commentStamp: ''!
Rounded corner border supporting radii of 1-4 pixels. Slower but more flexible than CornerRounder.
!
!RoundedBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!RoundedBorderStyle commentStamp: ''!
Rounded corner border supporting radii of 1-4 pixels. Slower but more flexible than CornerRounder.!
!RoundedBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle0: aRectangle on: aCanvas
	"Draw the border for a corner radius of 0."

	aCanvas
		frameAndFillRectangle: aRectangle
		fillColor: Color transparent
		borderWidth: self width
		borderColor: self color! !

!RoundedBorderStyle methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		cornerRadius: 0! !

!RoundedBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle2: aRectangle on: aCanvas
	"Draw the border for a corner radius of 2."

	|r|
	r := aRectangle insetBy: self width // 2.	
	self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)].
	aCanvas
		line: r topLeft + (2@0) to: r topRight - (2@0) width: self width color: self color;
		line: r topRight + (-1@1) to: r topRight + (-1@1) width: self width color: self color;
		line: r topRight + (0@2) to: r bottomRight - (0@2) width: self width color: self color;
		line: r bottomRight - (1@1) to: r bottomRight - (1@1) width: self width color: self color;
		line: r bottomRight - (2@0) to: r bottomLeft + (2@0) width: self width color: self color;
		line: r bottomLeft - (-1@1) to: r bottomLeft - (-1@1) width: self width color: self color;
		line: r bottomLeft - (0@2) to: r topLeft + (0@2) width: self width color: self color;
		line: r topLeft + (1@1) to: r topLeft + (1@1) width: self width color: self color! !

!RoundedBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle7: aRectangle on: aCanvas
	"Draw the border for a corner radius of 7."

	|r|
	r := aRectangle insetBy: self width // 2.	
	self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)].
	aCanvas
		line: r topLeft + (7@0) to: r topRight - (7@0) width: self width color: self color;
		line: r topRight + (-6@1) to: r topRight + (-5@1) width: self width color: self color;
		line: r topRight + (-4@2) to: r topRight + (-2@4) width: self width color: self color;
		line: r topRight + (-1@5) to: r topRight + (-1@6) width: self width color: self color;
		line: r topRight + (0@7) to: r bottomRight - (0@7) width: self width color: self color;
		line: r bottomRight - (1@6) to: r bottomRight - (1@5) width: self width color: self color;
		line: r bottomRight - (2@4) to: r bottomRight - (4@2) width: self width color: self color;
		line: r bottomRight - (5@1) to: r bottomRight - (6@1) width: self width color: self color;
		line: r bottomRight - (7@0) to: r bottomLeft + (7@0) width: self width color: self color;
		line: r bottomLeft - (-6@1) to: r bottomLeft - (-5@1) width: self width color: self color;
		line: r bottomLeft - (-4@2) to: r bottomLeft - (-2@4) width: self width color: self color;
		line: r bottomLeft - (-1@5) to: r bottomLeft - (-1@6) width: self width color: self color;
		line: r bottomLeft - (0@7) to: r topLeft + (0@7) width: self width color: self color;
		line: r topLeft + (1@6) to: r topLeft + (1@5) width: self width color: self color;
		line: r topLeft + (2@4) to: r topLeft + (4@2) width: self width color: self color;
		line: r topLeft + (5@1) to: r topLeft + (6@1) width: self width color: self color! !

!RoundedBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle3: aRectangle on: aCanvas
	"Draw the border for a corner radius of 3."

	|r|
	r := aRectangle insetBy: self width // 2.	
	self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)].
	aCanvas
		line: r topLeft + (3@0) to: r topRight - (3@0) width: self width color: self color;
		line: r topRight + (-2@1) to: r topRight + (-1@1) width: self width color: self color;
		line: r topRight + (-1@1) to: r topRight + (-1@2) width: self width color: self color;
		line: r topRight + (0@3) to: r bottomRight - (0@3) width: self width color: self color;
		line: r bottomRight - (1@2) to: r bottomRight - (1@1) width: self width color: self color;
		line: r bottomRight - (1@1) to: r bottomRight - (2@1) width: self width color: self color;
		line: r bottomRight - (3@0) to: r bottomLeft + (3@0) width: self width color: self color;
		line: r bottomLeft - (-2@1) to: r bottomLeft - (-1@1) width: self width color: self color;
		line: r bottomLeft - (-1@1) to: r bottomLeft - (-1@2) width: self width color: self color;
		line: r bottomLeft - (0@3) to: r topLeft + (0@3) width: self width color: self color;
		line: r topLeft + (1@2) to: r topLeft + (1@1) width: self width color: self color;
		line: r topLeft + (1@1) to: r topLeft + (2@1) width: self width color: self color! !

!RoundedBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle8: aRectangle on: aCanvas
	"Draw the border for a corner radius of 8."

	|r|
	r := aRectangle insetBy: self width // 2.	
	self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)].
	aCanvas
		line: r topLeft + (8@0) to: r topRight - (8@0) width: self width color: self color;
		line: r topRight + (-7@1) to: r topRight + (-6@1) width: self width color: self color;
		line: r topRight + (-5@2) to: r topRight + (-2@5) width: self width color: self color;
		line: r topRight + (-1@6) to: r topRight + (-1@7) width: self width color: self color;
		line: r topRight + (0@8) to: r bottomRight - (0@8) width: self width color: self color;
		line: r bottomRight - (1@7) to: r bottomRight - (1@6) width: self width color: self color;
		line: r bottomRight - (2@5) to: r bottomRight - (5@2) width: self width color: self color;
		line: r bottomRight - (6@1) to: r bottomRight - (7@1) width: self width color: self color;
		line: r bottomRight - (8@0) to: r bottomLeft + (8@0) width: self width color: self color;
		line: r bottomLeft - (-7@1) to: r bottomLeft - (-6@1) width: self width color: self color;
		line: r bottomLeft - (-5@2) to: r bottomLeft - (-2@5) width: self width color: self color;
		line: r bottomLeft - (-1@6) to: r bottomLeft - (-1@7) width: self width color: self color;
		line: r bottomLeft - (0@8) to: r topLeft + (0@8) width: self width color: self color;
		line: r topLeft + (1@7) to: r topLeft + (1@6) width: self width color: self color;
		line: r topLeft + (2@5) to: r topLeft + (5@2) width: self width color: self color;
		line: r topLeft + (6@1) to: r topLeft + (7@1) width: self width color: self color! !

!RoundedBorderStyle methodsFor: 'accessing' stamp: ''!
cornerRadius
	"Answer the value of cornerRadius"

	^ cornerRadius! !

!RoundedBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle5: aRectangle on: aCanvas
	"Draw the border for a corner radius of 5."

	|r|
	r := aRectangle insetBy: self width // 2.	
	self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)].
	aCanvas
		line: r topLeft + (5@0) to: r topRight - (5@0) width: self width color: self color;
		line: r topRight + (-4@1) to: r topRight + (-2@2) width: self width color: self color;
		line: r topRight + (-1@3) to: r topRight + (-1@4) width: self width color: self color;
		line: r topRight + (0@5) to: r bottomRight - (0@5) width: self width color: self color;
		line: r bottomRight - (1@4) to: r bottomRight - (2@2) width: self width color: self color;
		line: r bottomRight - (3@1) to: r bottomRight - (4@1) width: self width color: self color;
		line: r bottomRight - (5@0) to: r bottomLeft + (5@0) width: self width color: self color;
		line: r bottomLeft - (-4@1) to: r bottomLeft - (-3@1) width: self width color: self color;
		line: r bottomLeft - (-2@2) to: r bottomLeft - (-1@4) width: self width color: self color;
		line: r bottomLeft - (0@5) to: r topLeft + (0@5) width: self width color: self color;
		line: r topLeft + (1@4) to: r topLeft + (1@3) width: self width color: self color;
		line: r topLeft + (2@2) to: r topLeft + (4@1) width: self width color: self color! !

!RoundedBorderStyle methodsFor: 'accessing' stamp: ''!
cornerRadius: anObject
	"Set the value of cornerRadius"

	cornerRadius := anObject! !

!RoundedBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle4: aRectangle on: aCanvas
	"Draw the border for a corner radius of 4."

	|r|
	r := aRectangle insetBy: self width // 2.	
	self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)].
	aCanvas
		line: r topLeft + (4@0) to: r topRight - (4@0) width: self width color: self color;
		line: r topRight + (-3@1) to: r topRight + (-1@2) width: self width color: self color;
		line: r topRight + (-1@2) to: r topRight + (-1@3) width: self width color: self color;
		line: r topRight + (0@4) to: r bottomRight - (0@4) width: self width color: self color;
		line: r bottomRight - (1@3) to: r bottomRight - (1@2) width: self width color: self color;
		line: r bottomRight - (2@1) to: r bottomRight - (3@1) width: self width color: self color;
		line: r bottomRight - (4@0) to: r bottomLeft + (4@0) width: self width color: self color;
		line: r bottomLeft - (-3@1) to: r bottomLeft - (-2@1) width: self width color: self color;
		line: r bottomLeft - (-1@2) to: r bottomLeft - (-1@3) width: self width color: self color;
		line: r bottomLeft - (0@4) to: r topLeft + (0@4) width: self width color: self color;
		line: r topLeft + (1@3) to: r topLeft + (1@2) width: self width color: self color;
		line: r topLeft + (2@1) to: r topLeft + (3@1) width: self width color: self color! !

!RoundedBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle1: aRectangle on: aCanvas
	"Draw the border for a corner radius of 1."

	|r|
	r := aRectangle insetBy: self width // 2.	
	self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)].
	aCanvas
		line: r topLeft + (1@0) to: r topRight - (1@0) width: self width color: self color;
		line: r topRight + (0@1) to: r bottomRight - (0@1) width: self width color: self color;
		line: r bottomRight - (1@0) to: r bottomLeft + (1@0) width: self width color: self color;
		line: r bottomLeft - (0@1) to: r topLeft + (0@1) width: self width color: self color! !

!RoundedBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle: aRectangle on: aCanvas
	"Draw the border. Radius is the x/y offset not width 'around the corner'."
	
	self cornerRadius = 0 ifTrue: [^self frameRectangle0: aRectangle on: aCanvas].
	self cornerRadius = 1 ifTrue: [^self frameRectangle1: aRectangle on: aCanvas].
	self cornerRadius = 2 ifTrue: [^self frameRectangle2: aRectangle on: aCanvas].
	self cornerRadius = 3 ifTrue: [^self frameRectangle3: aRectangle on: aCanvas].
	self cornerRadius = 4 ifTrue: [^self frameRectangle4: aRectangle on: aCanvas].
	self cornerRadius = 5 ifTrue: [^self frameRectangle5: aRectangle on: aCanvas].
	self cornerRadius = 6 ifTrue: [^self frameRectangle6: aRectangle on: aCanvas].
	self cornerRadius = 7 ifTrue: [^self frameRectangle7: aRectangle on: aCanvas].
	self cornerRadius = 8 ifTrue: [^self frameRectangle8: aRectangle on: aCanvas].
	^super frameRectangle: aRectangle on: aCanvas.! !

!RoundedBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle6: aRectangle on: aCanvas
	"Draw the border for a corner radius of 6."

	|r|
	r := aRectangle insetBy: self width // 2.	
	self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)].
	aCanvas
		line: r topLeft + (6@0) to: r topRight - (6@0) width: self width color: self color;
		line: r topRight + (-5@1) to: r topRight + (-3@2) width: self width color: self color;
		line: r topRight + (-2@3) to: r topRight + (-2@3) width: self width color: self color;
		line: r topRight + (-1@4) to: r topRight + (-1@5) width: self width color: self color;
		line: r topRight + (0@6) to: r bottomRight - (0@6) width: self width color: self color;
		line: r bottomRight - (1@5) to: r bottomRight - (2@3) width: self width color: self color;
		line: r bottomRight - (3@2) to: r bottomRight - (4@1) width: self width color: self color;
		line: r bottomRight - (5@1) to: r bottomRight - (6@0) width: self width color: self color;
		line: r bottomRight - (7@0) to: r bottomLeft + (6@0) width: self width color: self color;
		line: r bottomLeft - (-5@1) to: r bottomLeft - (-4@1) width: self width color: self color;
		line: r bottomLeft - (-3@2) to: r bottomLeft - (-3@2) width: self width color: self color;
		line: r bottomLeft - (-2@3) to: r bottomLeft - (-1@5) width: self width color: self color;
		line: r bottomLeft - (0@6) to: r topLeft + (0@6) width: self width color: self color;
		line: r topLeft + (1@5) to: r topLeft + (1@4) width: self width color: self color;
		line: r topLeft + (2@3) to: r topLeft + (2@3) width: self width color: self color;
		line: r topLeft + (3@2) to: r topLeft + (5@1) width: self width color: self color! !

!RowLayout commentStamp: ''!
A simple row layout.!
!RowLayout methodsFor: 'layout' stamp: ''!
layout: aMorph in: layoutBounds
	"Compute the layout for the given morph based on the new bounds.
	Supports submorph hResizing, vResizing, cellInset, cellPositioning
	(top, *center, bottom*) and listCentering."

	| props spare extra height inset newBounds minExt fillCount x width|
	aMorph submorphs ifEmpty: [^self].
	props := aMorph assureTableProperties.
	minExt := (aMorph minWidth@aMorph minHeight - aMorph extent + aMorph layoutBounds extent) max: 0@0.
	newBounds := layoutBounds origin extent: (layoutBounds extent max: minExt).
	width := 0.
	width := (self minExtentOf: aMorph in: newBounds) x.
	spare := newBounds width - width max: 0.
	fillCount := 0.
	spare > 0
		ifTrue: [fillCount := aMorph submorphs inject: 0 into: [:tot :m |
					tot + (m hResizing == #spaceFill ifTrue: [1] ifFalse: [0])].
				extra := fillCount = 0
					ifTrue: [0]
					ifFalse: [spare // fillCount].
				spare := spare - (fillCount - 1 * extra)]
		ifFalse: [extra := 0].
	x := fillCount > 0
		ifTrue: [newBounds left]
		ifFalse: [props listCentering == #center
					ifTrue: [newBounds center x - (width // 2)]
					ifFalse: [props listCentering == #bottomRight
								ifTrue: [newBounds right - width]
								ifFalse: [newBounds left]]].
	height := newBounds height.
	inset := props cellInset isPoint ifTrue: [props cellInset x] ifFalse: [props cellInset]. 
	aMorph submorphs with: cachedMinExtents do: [:m :ext | | pos vr box cell |
		width := m hResizing == #spaceFill
			ifTrue: [fillCount := fillCount - 1.
					ext x + (fillCount > 0
						ifTrue: [spare]
						ifFalse: [extra])]
			ifFalse: [ext x].
		cell := x@newBounds top extent: width@height.
		((vr := m vResizing) == #shrinkWrap or: [m bounds ~= cell])
			ifTrue: [((vr == #shrinkWrap) not and: [m extent = cell extent])
						ifTrue: [m position: cell origin]
						ifFalse: [box := m bounds.
								m hResizing == #spaceFill 
									ifTrue: [box := cell origin extent: cell width @ box height].
								vr  == #spaceFill
									ifTrue: [box := box origin extent: box width @ cell height].
								vr  == #shrinkWrap
									ifTrue:[box := box origin extent: box width @ ext y].
								pos := props cellPositioning.
								box := box align: (box perform: pos) with: (cell perform: pos).
								m bounds: box]].
		x := x + width + inset]! !

!RowLayout methodsFor: 'layout' stamp: ''!
flushLayoutCache
	"Flush any cached information associated with the receiver."
	
	cachedMinExtent := nil! !

!RowLayout methodsFor: 'layout' stamp: ''!
minExtentOf: aMorph in: newBounds
	"Return the minimal size aMorph's children would require given the new bounds"
	
	| props extent|
	cachedMinExtent ifNotNil: [^cachedMinExtent].
	aMorph submorphs ifEmpty: [^aMorph minWidth @ aMorph minHeight].
	extent := 0@0.
	cachedMinExtents := aMorph submorphs collect: [:m | | min |
		min := m minExtent.
		extent := extent x + min x @ (extent y max: min y).
		min].
	props := aMorph assureTableProperties.
	^cachedMinExtent := extent + (aMorph submorphs size - 1 * 
		(props cellInset isPoint ifTrue: [props cellInset x] ifFalse: [props cellInset]) @ 0)! !

!RubAbstractSmalltalkMode commentStamp: ''!
I am an abstract class to set a mode of editing for smalltalk!
!RubAbstractSmalltalkMode methodsFor: 'testing' stamp: ''!
isForScripting
	"needs to be unified is #isScripting"
	^ self isScripting! !

!RubAbstractSmalltalkMode methodsFor: 'accessing' stamp: ''!
editorClass
	^ RubSmalltalkEditor.
! !

!RubAbstractSmalltalkMode methodsFor: 'testing' stamp: ''!
isCompletionEnabled
	^ true! !

!RubAbstractSmalltalkMode methodsFor: 'parsing' stamp: ''!
parseSource: aString

	self subclassResponsibility! !

!RubAbstractSmalltalkMode methodsFor: 'testing' stamp: ''!
isScripting
	^ false! !

!RubAbstractSmalltalkMode methodsFor: 'parsing' stamp: ''!
parseExpression: aString

	self subclassResponsibility! !

!RubAbstractTextArea commentStamp: ''!
I am a re-implementation of TextMorph. I'm intended as a temporary solution. Soon, I will be replaced by, or integrated with, TxText, a beautiful new text toolkit.

About the contextual menu
By default, the menu is given by the editingMode.
The model can implement a #menu method to impose a specific menu.
To change the way the menu is looked-up, one can also change the getMenuPolicy.
This menu retrieving algorithm is implemented by a dedicated objet, hold by the RubAbstractTextArea>>#getMenuPolicy instance variable. This dedicated object implements a #lookupMenu method for this.
By default, it is the textArea itself (see RubAbstractTextArea>>defaultGetMenuPolicy). 
The policy can be changed with RubAbstractTextArea>>#getMenuPolicy:, by passing whatever object that answer to #lookupMenu.

Instance Variables
	editingMode:		<Object>
	editingState:		<Object>
	editor:		<Object>
	hasFocus:		<Object>
	holder:		<Object>
	margins:		<Object>
	menuAllowed:		<Object>
	model:		<Object>
	paragraph:		<Object>
	readOnly:		<Object>
	scrollPivot:		<Object>
	text:		<Object>
	textColor:		<Object>
	textStyle:		<Object>
	wrapped:		<Object>

editingMode
	- xxxxx

editingState
	- xxxxx

editor
	- xxxxx

hasFocus
	- xxxxx

holder
	- xxxxx

margins
	- xxxxx

menuAllowed
	- xxxxx

model
	- xxxxx

paragraph
	- xxxxx

readOnly
	- xxxxx

scrollPivot
	- xxxxx

text
	- xxxxx

textColor
	- xxxxx

textStyle
	- xxxxx

wrapped
	- xxxxx


!
!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
decoratorNamed: aKey
	^self paragraph decoratorNamed: aKey! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
margins: aMargin
	"Adjust margin to always be able to display a cursor to right of text bounds"
	| m |
	(m := aMargin asMargin) right < self cursorWidth
		ifTrue: [ m
				setTop: m top
				left: m left
				bottom: m bottom
				right: self cursorWidth ].
	margins := m! !

!RubAbstractTextArea methodsFor: 'composing' stamp: ''!
scrollBounds
	^ scrollPane
		ifNil: [ self innerBounds  ]
		ifNotNil: [ :h | scrollPane scrollBounds ]! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
pointBlock
	^ self editingState pointBlock! !

!RubAbstractTextArea methodsFor: 'composing' stamp: ''!
forceCompose

	self prepareParagraphToCompose.
	self paragraph forceCompose ! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
paragraph
	"Paragraph instantiation is lazy -- create it only when needed"

	paragraph
		ifNil: [
			paragraph := self newParagraph.
			self compose.
			self selectAll].
	^ paragraph ! !

!RubAbstractTextArea methodsFor: 'accessing - editing state' stamp: ''!
emphasisHere
	^ self editingState emphasisHere
! !

!RubAbstractTextArea methodsFor: 'multi level undo' stamp: ''!
undoTypeIn: aText interval: anInterval 
	self handleEdit: [self editor undoTypeIn: aText interval: anInterval]! !

!RubAbstractTextArea methodsFor: 'public accessing' stamp: ''!
updateMarginsWith: aMargin
	self handleParagraphChange: [self margins: aMargin ]! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
wouldAcceptKeyboardFocusUponTab
	"Answer whether the receiver might accept keyboard focus if 
	tab were hit in some container playfield"
	^ true! !

!RubAbstractTextArea methodsFor: 'menu' stamp: ''!
defaultGetMenuPolicy
	^ self! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
primarySelection
	^ self submorphThat: [ :sm | sm isKindOf: RubPrimarySelectionMorph ] ifNone:  [ ]
! !

!RubAbstractTextArea methodsFor: 'submorphs - add/remove' stamp: ''!
delete
	self hasFocus
		ifTrue: [ self currentHand newKeyboardFocus: nil ].
	super delete! !

!RubAbstractTextArea methodsFor: 'paragraph feedbacks' stamp: ''!
forceExtentTo: aPoint
	super extent: aPoint! !

!RubAbstractTextArea methodsFor: 'geometry' stamp: ''!
handleBoundsChange: aBlock
	| oldBounds |
	oldBounds := self bounds copy.
	aBlock value.
	oldBounds topLeft ~= self bounds topLeft
		ifTrue: [ self announce: ((RubPositionChanged morph: self) previousBounds: oldBounds)].
	oldBounds extent ~= self bounds extent
		ifTrue: [ 
			self scrollPane ifNotNil: [ :sp | sp textAreaExtentChanged ].
			self announce: ((RubExtentChanged morph: self) previousBounds: oldBounds) ].
! !

!RubAbstractTextArea methodsFor: 'accessing - editing mode' stamp: ''!
editingMode
	^ editingMode
		ifNil: [ 
			self editingMode: RubPlainTextMode new.
			editingMode ]! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
classOfDecoratorNamed: aKey
	^ RubParagraphDecorator classOfDecoratorNamed: aKey! !

!RubAbstractTextArea methodsFor: 'public accessing' stamp: ''!
beReadOnly
	self readOnly
		ifFalse: [ self readOnly: true ]! !

!RubAbstractTextArea methodsFor: 'accessing - editing state' stamp: ''!
editingStateClass
	^ RubEditingState! !

!RubAbstractTextArea methodsFor: 'accessing - editing state' stamp: ''!
newEditingState
	^ self editingStateClass new textArea: self! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^ self innerBounds containsPoint: evt cursorPoint! !

!RubAbstractTextArea methodsFor: 'accessing - editing state' stamp: ''!
hasFocus
	^ ( editingState ifNil: [^ false ] ) hasFocus! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
unselect
	self handleSelectionChange: [ self editingState unselect ]! !

!RubAbstractTextArea methodsFor: 'accessing - segments' stamp: ''!
segments
	^ segments ifNil: [ segments := OrderedCollection new ]
! !

!RubAbstractTextArea methodsFor: 'geometry' stamp: ''!
privateMoveBy: delta
	self
		handleBoundsChange: [ 
			self paragraph moveBy: delta truncated.
			super privateMoveBy: delta truncated ]! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
mouseLeave: evt
	"Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed."
	super mouseLeave: evt.
	self hideOverEditableTextCursor
	! !

!RubAbstractTextArea methodsFor: 'paragraph feedbacks' stamp: ''!
updateExtentFromParagraph
	(paragraph notNil and: [ bounds notNil ])
		ifTrue: [ 
			| newExtent |
			newExtent := self paragraph extent max: self minimumExtent.
			self forceExtentTo: (newExtent x + self margins right) @ newExtent y]! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
selectAll
	self editor selectAll! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
keyDown: anEvent
	"Handle a keystroke event."
	(anEvent key = KeyboardKey enter or: [ anEvent key = KeyboardKey keypadEnter ])
		ifTrue: [ self handleReturnKey
				ifTrue: [ ^ self ] ].

	anEvent hand anyButtonPressed
		ifTrue: [ ^ self ].
	self scrollPane
		ifNotNil: [ :sp | 
			(sp scrollByKeyboard: anEvent)
				ifTrue: [ ^ self ] ].

	self handleEdit: [ self editor keyDown: anEvent ].! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
readOnly
	^readOnly ifNil: [ readOnly := self defaultReadOnly ]! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
getMenu: shiftKeyState
	"Ask the getMenuPolicy to lookup the menu to popup if any"

	^ shiftKeyState
		ifTrue: [ self getMenuPolicy lookupShiftMenu ]
		ifFalse: [ self getMenuPolicy lookupMenu ]! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
text: t textStyle: s color: c textColor: tc
	"Private -- for use only in morphic duplication"	
	self releaseParagraph.
	super text: t textStyle: s color: c textColor: tc.
! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
mouseMove: evt
   self paragraph move: evt for: model controller: self editor.
	evt redButtonPressed
		ifFalse: [ ^ self ].
	evt shiftPressed
		ifTrue: [ self modifySelection: (self paragraph characterBlockAtPoint: evt cursorPoint) ]
		ifFalse: [ mouseDownPoint
				ifNotNil: [ self markBlock: (self paragraph characterBlockAtPoint: mouseDownPoint) pointBlock: (self paragraph characterBlockAtPoint: evt cursorPoint) ]
				ifNil: [ self markBlock: (self paragraph characterBlockAtPoint: evt cursorPoint) ] ].
	self editor storeSelectionInText.
! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
newPrimarySelection
	^ RubPrimarySelectionMorph inTextArea: self from: self markIndex to: self pointIndex.
! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
notificationStrategy: aStrategy
	self editor notificationStrategy: aStrategy! !

!RubAbstractTextArea methodsFor: 'editing' stamp: ''!
privateReplaceFrom: start to: stop with: aText
	self maxLength
		ifNotNil: [ | newSize |
			newSize := self newSizeAfterUpdateFrom: start to: stop with: aText.
			newSize > self maxLength
				ifTrue: [ | t |
					t := self text.
					t replaceFrom: start to: stop with: aText.
					self paragraph
						replaceFrom: 1
						to: self text size
						with: (t copyFrom: 1 to: maxLength).
					^ self ] ].
	self paragraph replaceFrom: start to: stop with: aText! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
textColor: newColor
	textColor := newColor.
	self addAttribute: (TextColor color: newColor).
	self changed.! !

!RubAbstractTextArea methodsFor: 'composing' stamp: ''!
drawEmbeddedMorphs
	"Scan through text to find spans of TextBackgroundColor, and mark them using TextBackgroundColorSegmentMorph."

	"Scan through text to find spans containing submorphs (Background color and TextAnchor)"

	self text runs
		withStartStopAndValueDo: [ :start :stop :value | 
			value do: [ :v | 
					(v isKindOf: TextBackgroundColor)
						ifTrue: [ self addSegment: 
							(RubTextBackgroundColorSegmentMorph
								color: v color
								from: start
								to: stop+1) ].
					((v isKindOf: TextAnchor) and:[v anchoredMorph isMorph ])
						ifTrue: [ self addEmbeddedMorph: v anchoredMorph  ] ] ]! !

!RubAbstractTextArea methodsFor: 'accessing - editor' stamp: ''!
editor
	"Return my current editor, or install a new one."
	^ editor ifNil: [ editor := self newEditor ]! !

!RubAbstractTextArea methodsFor: 'menu' stamp: ''!
wantsYellowButtonMenu
	^ self menuAllowed ! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withoutFindReplaceSelection
	self withoutDecoratorNamed: #findReplaceSelection! !

!RubAbstractTextArea methodsFor: 'embedded morphs' stamp: ''!
drawEmbeddedMorphsOn: aCanvas
	"draw only those embedded morphs which has been placed by RubDisplayScanner>>placeEmbeddedObject:"
	((self embeddedMorphs) 
		select: [ :morph | morph valueOfProperty: #hasBeenPositioned ifAbsent: [false] ])
		do: [ :morph | morph fullDrawOn: aCanvas]! !

!RubAbstractTextArea methodsFor: 'initialization' stamp: ''!
plugFindReplace
	self announcer 
		when:  MorphGotFocus send: #whenTextAreaGotFocus: to: self findReplaceService;
	 	when:  MorphLostFocus send: #whenTextAreaLostFocus: to: self findReplaceService;	
		when:  RubSelectionChanged send: #whenTextAreaSelectionChanged: to: self findReplaceService! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	"Make this TextMorph be the keyboard input focus, if it isn't  
	already, and repond to the text selection gesture.
	Changed to not take keyboard focus if an owner is a
	PluggableTextMorph that doesn't want focus."

	self doAnnounce: (MorphClosePopups morph: self).

	(evt yellowButtonPressed and: [ evt commandKeyPressed not ])
		ifTrue: [ ^ self yellowButtonActivity: evt shiftPressed ].	"First check for option (menu) click"
	(self paragraph click: evt for: self model controller: self)
		ifTrue: [ self click: evt.
			evt hand releaseKeyboardFocus: self.
			^ self ].
	(evt yellowButtonChanged or: [ evt commandKeyPressed ])
		ifTrue: [ (self yellowButtonActivity: evt shiftPressed)
				ifTrue: [ ^ self ] ].
	"no matter what, if shift is pressed extend the selection"
	evt shiftPressed
		ifTrue: [ ^ self mouseMove: evt ].
	mouseDownPoint := evt cursorPoint.
	(self hasFocus or: [ self editor hasSelection not ])
		ifTrue:
			[ | selectors |
			self scrollPivot: evt hand position.
			selectors := Array
				with: #click:
				with: #doubleClick:
				with: nil
				with: nil.
			evt hand
				waitForClicksOrDrag: self
				event: evt
				selectors: selectors
				threshold: 5 ].
	self hasKeyboardFocus
		ifFalse: [ self takeKeyboardFocus ]! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	^true! !

!RubAbstractTextArea methodsFor: 'find-replace' stamp: ''!
hasFindReplaceFocus
	^ self findReplaceService dialogIsActiveFor: self! !

!RubAbstractTextArea methodsFor: 'testing' stamp: ''!
canChangeText
	^ self enabled and: [ self readOnly not ]! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
findReplaceService
	^ findReplaceService ifNil: [
		findReplaceService := self defaultFindReplaceServiceClass newFor: self].! !

!RubAbstractTextArea methodsFor: 'accessing - editor' stamp: ''!
acceptAllowed

	^ editingMode acceptAllowed! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
hasSelection
	^ self editor hasSelection ! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
selectionStop
	^ self editingState selectionStop! !

!RubAbstractTextArea methodsFor: 'accessing - editing state' stamp: ''!
scrollPivot: aPoint
	^self editingState scrollPivot: aPoint! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
keyboardFocusChange: aBoolean
	aBoolean
		ifTrue: [
			self hasFocus: true.
			self showOverEditableTextCursor ]
		ifFalse: [ 
			self hasFocus: false.
			self hideOverEditableTextCursor ].
	super keyboardFocusChange: aBoolean.
	self focusChanged.
! !

!RubAbstractTextArea methodsFor: 'initialization' stamp: ''!
unplugFindReplace
	self announcer unsubscribe: self findReplaceService
! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
readOnly: aBoolean
	 readOnly := aBoolean! !

!RubAbstractTextArea methodsFor: 'editing' stamp: ''!
handleEdit: editBlock
	"Ensure that changed areas get suitably redrawn"

	editBlock value.
	self selectionChanged	"Note new selection"! !

!RubAbstractTextArea methodsFor: 'accessing - cursor' stamp: ''!
cursorClass
	^ RubCursor! !

!RubAbstractTextArea methodsFor: 'accessing - cursor' stamp: ''!
newCursor
	^ self cursorClass new! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
interactive
	^ self editingMode interactive! !

!RubAbstractTextArea methodsFor: 'find-replace' stamp: ''!
findNextString: aSubstring startingAt: searchIdx
	| where |
	self
		handleEdit: [where := self editor findNextString: aSubstring startingAt: searchIdx].
	^ where
! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
startIndex
	^ self selectionStart stringIndex! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withoutDecoratorNamed: aKey
	(self decoratorNamed: aKey)
		ifNotNil: [ :m | self withoutDecorator: m ].
	self changed! !

!RubAbstractTextArea methodsFor: 'defaults' stamp: ''!
defaultMargins

	^ Margin left: 6 right: 6 top: 6 bottom: 6! !

!RubAbstractTextArea methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas
	"Draw the focus here since we are using inset bounds
	for the focus rectangle."
	self resetEmbeddedMorphs.
	super drawSubmorphsOn: aCanvas.
	aCanvas rubParagraph: self paragraph bounds: self drawingBounds color: self textColor.
	(scrollPane isNil and: [ self readOnly not and: [ self hasKeyboardFocus or: [ self hasFindReplaceFocus ] ] ])
		ifTrue: [self drawKeyboardFocusOn: aCanvas ].
	self drawEmbeddedMorphsOn: aCanvas! !

!RubAbstractTextArea methodsFor: 'editing' stamp: ''!
acceptContents
	"The message is sent when the user hits enter or Cmd-S.
	Accept the current contents and endediting"
	self editingMode acceptAllowed ifFalse: [ ^self ].
	self announce: (RubTextAcceptRequest morph: self).
	self changed! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
markBlock: aCharacterBlock
	self handleSelectionChange: [ self editingState markBlock:  aCharacterBlock]! !

!RubAbstractTextArea methodsFor: 'accessing - cursor' stamp: ''!
addCursor
	self cursor ifNil: [ self addMorph: (cursor := self newCursor) ]! !

!RubAbstractTextArea methodsFor: 'accessing - editing state' stamp: ''!
emphasisHere: aListOfAttributes
	self editingState emphasisHere: aListOfAttributes
! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
backgroundColor: newColor
	self color: newColor! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
whenFindTextChanged: anAnnouncement 
	self changed! !

!RubAbstractTextArea methodsFor: 'layout' stamp: ''!
acceptDroppingMorph: aMorph event: evt
	"This message is sent when a morph is dropped onto me."
	self addMorphFront: aMorph fromWorldPosition: aMorph position.
		"Make a TextAnchor and install it in a run."! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
mouseEnter: evt
	"Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed."
	super mouseEnter: evt.
	self showOverEditableTextCursor
	! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
selectionChanged
	"Invalidate all the selection rectangles. 
	Make sure that any drop shadow is accounted for too."
	paragraph ifNil: [ ^ self ].
	self recomputeSelection.
! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
takeKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."
	self takesKeyboardFocus ifFalse: [ ^self ].
	^ super takeKeyboardFocus ! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
selection
	^ self editor selection! !

!RubAbstractTextArea methodsFor: 'accessing - editor' stamp: ''!
closingDelimiters
	^ self editor closingDelimiters
! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
keyStroke: anEvent
	"Handle a keystroke event."
	anEvent hand anyButtonPressed
		ifTrue: [ ^ self ].
	self handleEdit: [ self editor keystroke: anEvent ].
	self scrollSelectionIntoView: nil! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
markBlock: markCharacterBlock pointBlock: pointCharacterBlock
	self handleSelectionChange: [ self editingState markBlock: markCharacterBlock pointBlock: pointCharacterBlock ]! !

!RubAbstractTextArea methodsFor: 'embedded morphs' stamp: ''!
resetEmbeddedMorphs
	"reset the #hasBeenPositioned property to false for all embeddedMorphs. 
	Those to actually be shown will be marked in RubDisplayScanner>>placeEmbeddedObject:"
	self embeddedMorphs do: [ :morph | morph setProperty: #hasBeenPositioned toValue: false ]! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
unplug
	self unplugFindReplace.
	self releaseEditingState.
	self releaseParagraph.
	self releaseEditor.
	super unplug
	! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withoutDecoratorsNamed: aCollection
	aCollection do: [ :m | self withoutDecoratorNamed: m ]! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withoutSecondarySelection
	self withoutDecoratorNamed: #secondarySelection! !

!RubAbstractTextArea methodsFor: 'drawing' stamp: ''!
drawingBounds
	^ (self scrollPane isNil or: [ self wrapped ])
		ifTrue: [self innerBounds]
		ifFalse: [ self innerBounds topLeft extent: self class defaultMaxExtent @ self class defaultMaxExtent ]! !

!RubAbstractTextArea methodsFor: 'defaults' stamp: ''!
defaultColor
	"Answer the default color/fill style for the receiver. If the settings has been used then honor it, else returns the theme color"

  	^ self class backgroundColor
! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
mouseUp: evt
	self scrollPivot: nil.
	(self boundsInWorld containsPoint: self currentHand position)
		ifFalse: [ self hideOverEditableTextCursor ].
	mouseDownPoint := nil! !

!RubAbstractTextArea methodsFor: 'accessing - editor' stamp: ''!
releaseEditor
	"Release the editor for my paragraph."

	editor
		ifNotNil: [ 
			editor unplug.
			editor := nil ]! !

!RubAbstractTextArea methodsFor: 'menu' stamp: ''!
getMenuPolicy
	^ getMenuPolicy ifNil: [ getMenuPolicy := self defaultGetMenuPolicy ]! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
handleKeystroke: anEvent 
	"System level event handling."

	anEvent wasHandled
		ifTrue: [^ self].
	(self handlesKeyStroke: anEvent)
		ifFalse: [^ self].
	self keyStroke: anEvent.
	anEvent wasHandled: true.! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
doubleClick: anEvent
	^ self handleEdit: [ self editor doubleClick: anEvent ]! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ self color! !

!RubAbstractTextArea methodsFor: 'geometry' stamp: ''!
bounds
	^ super bounds ifNil: [ self defaultBounds ]! !

!RubAbstractTextArea methodsFor: 'accessing - segments' stamp: ''!
removeSegment: aRubTextSegmentMorph
	self announcer unsubscribe: aRubTextSegmentMorph.
	self segments remove: aRubTextSegmentMorph ifAbsent: [].
! !

!RubAbstractTextArea methodsFor: 'accessing - segments' stamp: ''!
segmentsAtLine: aLineNumber
	^ self segments select: [ :s | s firstLineIndex = aLineNumber ]! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
addPrimarySelection
	self addMorph: self newPrimarySelection.
! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
tabWidth: anInteger
	self paragraph tabWidth: anInteger! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
select
	self editor select! !

!RubAbstractTextArea methodsFor: 'accessing - editing state' stamp: ''!
hasFocus: aBoolean
	^ self editingState hasFocus: aBoolean ! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
scrollPane: aScrollPane
	scrollPane := aScrollPane.
	self color: Color transparent! !

!RubAbstractTextArea methodsFor: 'accessing - editing mode' stamp: ''!
editingMode: anEditingMode
	editingMode unplug.
	editingMode := anEditingMode.
	editingMode plugin: self.
 ! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withFindReplaceSelection
	self withDecoratorNamed: #findReplaceSelection! !

!RubAbstractTextArea methodsFor: 'defaults' stamp: ''!
defaultMenuAllowed
	^ true! !

!RubAbstractTextArea methodsFor: 'paragraph feedbacks' stamp: ''!
paragraphReplacedTextFrom: start to: stop with: aText
	"A text change has taken place in my paragraph, as a result of editing and I must be updated"
	self
		handleBoundsChange: [ 
			self wrapped
				ifTrue: [ self updateBottomFromParagraph ]
				ifFalse: [ self updateExtentFromParagraph ] ].
	self scrollPane ifNotNil: [ :sp | sp textChanged ].
	self announce: (RubTextChanged from: start to: stop with: aText).
	self drawEmbeddedMorphs.
! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
handleSelectionChange: aBlock
	| prevMarkBlock prevPointBlock |
	self flag: #pharoFixMe. "hack here because text segments are not well designed regarding text editing".
	self primarySelection ifNil: [ self addPrimarySelection  ].
	prevMarkBlock := self markBlock.
	prevPointBlock := self pointBlock.
	aBlock value.

	(prevMarkBlock ~= self markBlock or: [ prevPointBlock ~= self pointBlock ]) ifFalse: [ ^ self ].
	
	"have to invalidate the full surface because of the selection"
	self invalidRect: (self expandFullBoundsForDropShadow: self drawingBounds).
	self scrollPane ifNotNil: [ :sp | sp selectionChanged ].
	self announce: (RubSelectionChanged from: self previousMarkBlock: prevMarkBlock previousPointBlock: prevPointBlock)! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
lineNumbersTextColor
	^ self class lineNumbersTextColor 
! !

!RubAbstractTextArea methodsFor: 'composing' stamp: ''!
offset
	^ scrollPane
		ifNil: [ 0@0 ]
		ifNotNil: [ :h | scrollPane offset ]! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
selectInvisiblyFrom: start to: stop
	self editor selectInvisiblyFrom: start to: stop! !

!RubAbstractTextArea methodsFor: 'completion' stamp: ''!
setCompletionEngine: anEngine

	completionEngine := anEngine! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
newEditor
	"Return my current editor, or install a new one."
	^ self editorClass forTextArea: self! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withOpeningClosingDelimitersHighlight
	self withDecoratorNamed: #openingClosingDelimitersHighlight! !

!RubAbstractTextArea methodsFor: 'caching' stamp: ''!
releaseCachedState
	super releaseCachedState.
	self releaseParagraph! !

!RubAbstractTextArea methodsFor: 'find-replace' stamp: ''!
findText
	^ self editor findText! !

!RubAbstractTextArea methodsFor: 'find-replace' stamp: ''!
replaceSelectionWith: aText
	self
		handleEdit: [self editor replaceSelectionWith: aText]! !

!RubAbstractTextArea methodsFor: 'composing' stamp: ''!
compositionRectangle
	^ scrollPane ifNil: [ self innerBounds ] ifNotNil: [ self innerBounds topLeft extent: scrollPane scrollBounds extent ]! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
cursorWidth
	^ self cursorClass defaultWidth ! !

!RubAbstractTextArea methodsFor: 'public accessing' stamp: ''!
setTextWith: stringOrText
	"Accept new text contents."

	self handleParagraphChange: [ self privateText: (self validateTextFrom: stringOrText) ]! !

!RubAbstractTextArea methodsFor: 'settings' stamp: ''!
caseSensitiveFinds
	^ self class caseSensitiveFinds! !

!RubAbstractTextArea methodsFor: 'embedded morphs' stamp: ''!
addEmbeddedMorph: aMorph
	self embeddedMorphs add: aMorph! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
model: aModel
	model := aModel! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
recomputeSelection
	"The same characters are selected but their coordinates may have changed.
	Redetermine the selection according to the start and stop block indices; 
	do not highlight."

	self markIndex: self markIndex pointIndex: self pointIndex! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
highlightMessageSend
	^ self class highlightMessageSend! !

!RubAbstractTextArea methodsFor: 'accessing - editor' stamp: ''!
openingDelimiters
	^ self editor openingDelimiters
! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
textFont: aFont
	self addAttribute: (TextFontReference toFont: aFont).
	self paragraph compose.
	self recomputeSelection.
	self  announce: (RubTextStyleChanged morph: self).
! !

!RubAbstractTextArea methodsFor: 'find-replace' stamp: ''!
openFindDialog
	self sharesFindReplace 
		ifTrue: [ self announce: RubFindReplaceWindowRequired ]
		ifFalse: [self flash]! !

!RubAbstractTextArea methodsFor: 'testing' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!RubAbstractTextArea methodsFor: 'embedded morphs' stamp: ''!
embeddedMorphs
	"Embedded morphs are kept seperate from other submorphs, to ensure only those placed by
	RubDisplayScanner>>placeEmbeddedObject: are drawn"
	^ embeddedMorphs ifNil: [ embeddedMorphs := OrderedCollection new ]! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
privateSetTextStyle: aTextStyle
	textStyle := aTextStyle! !

!RubAbstractTextArea methodsFor: 'defaults' stamp: ''!
defaultYellowButtonMenuEnabled
	^ self defaultMenuAllowed ! !

!RubAbstractTextArea methodsFor: 'accessing - segments' stamp: ''!
addSegment: aRubTextSegmentMorph
	| seg |
	seg := aRubTextSegmentMorph inTextArea: self.
	self segments add: seg.
	self addMorphBack: seg.
	^ seg
! !

!RubAbstractTextArea methodsFor: 'editing' stamp: ''!
newSizeAfterUpdateFrom: start to: stop with: aText
	" compute and return my text new size avec an insertion/replacement with aText.
	the receiver is not update "

	| replSize |
	" replSize is the additional size"
	replSize := aText size - (stop - start + 1).
	^ self text size + replSize! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
markBlock
	^ self editingState markBlock! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
textStyle: aTextStyle
	self privateTextStyle: aTextStyle.
	self addAttribute: (TextFontChange fontNumber: (textStyle defaultFontIndex)).
	self paragraph compose.
	self recomputeSelection.
	self  announce: (RubTextStyleChanged morph: self).
! !

!RubAbstractTextArea methodsFor: 'interactive error protocol' stamp: ''!
deselect
	self selectFrom: 1 to: 0! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
escapePressed
	"do nothing. do not simulate a right click
	because Esc is too useful as a shortcut for other purposes
	to be used for popping a menu"
	"^ self yellowButtonActivity: false"
! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
menuAllowed: aBoolean
	menuAllowed := aBoolean! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
primarySelectionColor
	^ self primarySelection ifNil: [ Color transparent] ifNotNil: [:ps | ps color ]! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
model 
	^model! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
tabWidth
	^ self paragraph tabWidth! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withoutDecorator: aDecorator
	| n p |
	(self hasDecorator: aDecorator)
		ifFalse: [ ^ self ].
	n := paragraph.
	[ n notNil and: [ n ~= aDecorator ] ]
		whileTrue: [ 
			p := n.
			n := p next ].
	n ifNil: [ ^ self ].
	p ifNil: [ paragraph := aDecorator next ] ifNotNil: [ p next: aDecorator next ].
	aDecorator aboutToBeUnplugged.
	aDecorator next: nil.
	aDecorator unplug.
	self changed! !

!RubAbstractTextArea methodsFor: 'public accessing' stamp: ''!
forbidMenu
	self menuAllowed: false! !

!RubAbstractTextArea methodsFor: 'menu' stamp: ''!
lookupMenu
	"default implementation of the algorithm that lookup the menu"

	^ self model 
		ifNil: [ self editingMode menu ] 
		ifNotNil: [ :m | m menu ifNil: [ self editingMode menu ] ]! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
scrollSelectionIntoView: evt 
	scrollPane ifNotNil: [ scrollPane scrollSelectionIntoView: evt ]	
! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
font: aFont
	| newTextStyle |
	newTextStyle := aFont textStyle copy ifNil: [ TextStyle fontArray: { aFont } ].
	newTextStyle defaultFontIndex: (newTextStyle fontIndexOf: aFont).
	self textStyle: newTextStyle
! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
maxLength
	"Answer the maximum number of characters that may be typed."

	^ maxLength ! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
scrollPane
	^ scrollPane! !

!RubAbstractTextArea methodsFor: 'multi level undo' stamp: ''!
undoRedoExchange: aninterval with: anotherInterval
	self handleEdit: [self editor undoRedoExchange: aninterval with: anotherInterval]! !

!RubAbstractTextArea methodsFor: 'composing' stamp: ''!
prepareParagraphToCompose
	self paragraph container: self compositionRectangle.
! !

!RubAbstractTextArea methodsFor: 'accessing - editor' stamp: ''!
editorClass
	"Answer the class used to create the receiver's editor"

	^ RubTextEditor! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
lineNumbersBackgroundColor
	^ self class lineNumbersBackgroundColor! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
validateTextFrom: aStringOrText
	^ self maxLength
		ifNil: [ aStringOrText ]
		ifNotNil: [ aStringOrText size <= self maxLength
				ifFalse: [ aStringOrText copyFrom: 1 to: self maxLength ]
				ifTrue: [ aStringOrText ] ]! !

!RubAbstractTextArea methodsFor: 'structure' stamp: ''!
topRendererOrSelf

	^ scrollPane 
		ifNil: [ super topRendererOrSelf ]
		ifNotNil: [ scrollPane topRendererOrSelf ]! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withoutAnyDecorator
	[ self paragraph key notNil ] whileTrue: [ self withoutDecorator: paragraph ]! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
setEmphasisHere
	self editor setEmphasisHere! !

!RubAbstractTextArea methodsFor: 'accessing - paragraph' stamp: ''!
lines
	^ self paragraph lines! !

!RubAbstractTextArea methodsFor: 'public accessing' stamp: ''!
allowMenu
	self menuAllowed: true! !

!RubAbstractTextArea methodsFor: 'multi level undo' stamp: ''!
redoTypeIn: aText interval: anInterval 
	self handleEdit: [self editor redoTypeIn: aText interval: anInterval]! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
markIndex: markIndex pointIndex: pointIndex
	self handleSelectionChange: [ self editingState markIndex: markIndex pointIndex: pointIndex ]! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
userString
	"Do I have a text string to be searched on?"

	^ self text string! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
textStyle
	^textStyle ifNil: [ textStyle := self defaultTextStyle  ]! !

!RubAbstractTextArea methodsFor: 'find-replace' stamp: ''!
findAndSelect: aRegex startingAt: anIndex searchBackwards: searchBackwards
	| where |
	self
		handleEdit: [
			where := self editor
				findAndSelect: aRegex
				startingAt: anIndex
				searchBackwards: searchBackwards.
			self scrollSelectionIntoView: nil].
	^ where! !

!RubAbstractTextArea methodsFor: 'accessing - editing state' stamp: ''!
editingState
	^ editingState ifNil: [editingState := self newEditingState]! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
pointBlock: aCharacterBlock
	self handleSelectionChange: [ self editingState pointBlock: aCharacterBlock ]! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
font
	"Answer the probable font"
	^ self textStyle fonts at: self textStyle defaultFontIndex
! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
handleReturnKey
	| answer |
	answer := RubReturnEntered morph: self.
	self announce: answer.
	answer accepted
		ifTrue: [ self editor textWasAccepted ].
	^ answer accepted! !

!RubAbstractTextArea methodsFor: 'editing' stamp: ''!
replaceFrom: start to: stop with: aText
	self
		handleEdit: [ self editor replaceTextFrom: start to: stop with: aText ]
! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
string
	"obtain a string value from the receiver"

	^ self text string! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt 
	"Do I want to receive mouseEnter: and mouseLeave: when the button is up and the hand is empty?"
	^ self enabled! !

!RubAbstractTextArea methodsFor: 'find-replace' stamp: ''!
sharesFindReplace
	^ true! !

!RubAbstractTextArea methodsFor: 'accessing - editing state' stamp: ''!
scrollPivot
	^self editingState scrollPivot! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
modifySelection: aCharacterBlock
	"the aCharacterBlock becomes always the new point block. Whether the old point block or
	the old mark block becomes the new mark block, depends on the distance. If the new character block
	is near the old point block, we leave the old mark block unchaned."

	(self pointBlock distance: aCharacterBlock) < (self markBlock distance: aCharacterBlock)
		ifTrue: [ self pointBlock: aCharacterBlock ]
		ifFalse: [ self markBlock: self pointBlock pointBlock: aCharacterBlock ]! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
maxLength: anInteger
	"Set the maximum number of characters that may be typed."

	maxLength := anInteger max: 0! !

!RubAbstractTextArea methodsFor: 'accessing - cursor' stamp: ''!
removeCursor
	self cursor ifNotNil: [ :c | 
		self cursor aboutToBeRemoved.
		self removeMorph: c ].
	cursor := nil! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
showOverEditableTextCursor

	| o |

	owner ifNil: [ ^ self ].
	o := owner isWorldMorph
		ifTrue: [ self ]
		ifFalse: [ owner ].
	( o boundsInWorld containsPoint: self currentHand position )
		ifTrue: [ self currentHand showTemporaryCursor: ( self theme overTextCursorFor: self ) ]! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
wrapped
	^ false! !

!RubAbstractTextArea methodsFor: 'copying' stamp: ''!
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.
	textStyle := textStyle veryDeepCopyWith: deepCopier.
	paragraph := paragraph veryDeepCopyWith: deepCopier.
	textColor := textColor veryDeepCopyWith: deepCopier.
	editor := editor veryDeepCopyWith: deepCopier.
! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
hideOverEditableTextCursor  
	self currentHand showTemporaryCursor: nil
	! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
editPrimarySelectionSeparately
	| view |
	view := self primarySelection readWriteView.
	(view embeddedInMorphicWindowLabeled: 'Selection editing') openInHand.! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
primarySelectionBounds
	^ self primarySelection bounds! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
privateTextStyle: aTextStyle
	textStyle := aTextStyle! !

!RubAbstractTextArea methodsFor: 'defaults' stamp: ''!
defaultTextStyle
	| ts f |
	f := self class editorFont.
	ts := f textStyle copy ifNil: [ TextStyle fontArray: { f } ].
	ts defaultFontIndex: (ts fontIndexOf: f).
	^ ts! !

!RubAbstractTextArea methodsFor: 'accessing - cursor' stamp: ''!
forceCursorVisibleWhile: aBlock
	self cursor
		ifNotNil: [ :cur | 
			| prev |
			prev := cur stayVisible.
			cur stayVisible: true.
			aBlock
				ensure: [ cur stayVisible: prev ] ]! !

!RubAbstractTextArea methodsFor: 'dropping/grabbing' stamp: ''!
grabbedAllowed
	^ scrollPane isNil! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
menuAllowed
	^ menuAllowed ifNil: [ menuAllowed := self defaultMenuAllowed  ]! !

!RubAbstractTextArea methodsFor: 'completion' stamp: ''!
hasCompletionEngine
	
	^ completionEngine isNil not
	! !

!RubAbstractTextArea methodsFor: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher
	"we delegate the creation of default shortcuts to the editor
	because it is the one that knows more details about the goal of editing"
	super initializeShortcuts: aKMDispatcher.
	self editor initializeShortcuts: aKMDispatcher! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withDecorator: aDecorator
	(self hasDecoratorNamed: aDecorator key)
		ifTrue: [ ^ self ].
	paragraph := aDecorator next: paragraph.
	self compose! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
updateTextWith: aStringOrText
	self
		handleEdit: [ self
				beEditableWhile: [ 
					| s |
					s := self validateTextFrom: aStringOrText.
					s = self text
						ifFalse: [ self selectAll.
							self editor replaceSelectionWith: s.
							self deselect ] ] ]! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
appendText: aStringOrText
	self
		handleEdit:
			[ self
				beEditableWhile:
					[ self selectInvisiblyFrom: self text size + 1 to: self text size.
					self editor replaceSelectionWith: aStringOrText.
					self selectInvisiblyFrom: self text size + 1 to: self text size ] ]! !

!RubAbstractTextArea methodsFor: 'defaults' stamp: ''!
defaultReadOnly

	^ false! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
selectionInterval
	^self editor selectionInterval ! !

!RubAbstractTextArea methodsFor: 'interactive error protocol' stamp: ''!
correctFrom: start to: stop with: aString
	self editor correctFrom: start to: stop with: aString! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
click: anEvent
	self
		handleEdit: [ 
			self editor click: anEvent.
			self scrollSelectionIntoView: nil ]! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
releaseParagraph
	paragraph
		ifNotNil: [ 
			self withoutAnyDecorator.
			paragraph unplug.
			paragraph := nil ].
! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
addAttribute: anAttribute
	self text addAttribute: anAttribute ! !

!RubAbstractTextArea methodsFor: 'paragraph feedbacks' stamp: ''!
paragraphWasComposedFrom: startIndex to: stopIndex
	self
		handleBoundsChange: [ 
			self wrapped
				ifTrue: [ self updateBottomFromParagraph ]
				ifFalse: [ self updateExtentFromParagraph ] ]! !

!RubAbstractTextArea methodsFor: 'geometry' stamp: ''!
minExtent
	| minH |
	minH := scrollPane ifNil: [ 0 ] ifNotNil: [ 60 ].
	^ ((self textStyle defaultFont widthOfString: 'XXX') + self margins left + self margins right)
		@ (self textStyle lineGrid + self margins top + self margins bottom)! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
hasDecoratorNamed: aKey
	^ self paragraph hasDecoratorNamed: aKey
	! !

!RubAbstractTextArea methodsFor: 'interactive error protocol' stamp: ''!
nextTokenFrom: start direction: dir
	^ self editor nextTokenFrom: start direction: dir! !

!RubAbstractTextArea methodsFor: 'public accessing' stamp: ''!
beEditableWhile: aBlock
	| wasEditable |
	wasEditable := self readOnly.
	self readOnly: false.
	aBlock ensure: [ self readOnly:  wasEditable]
! !

!RubAbstractTextArea methodsFor: 'updating' stamp: ''!
themeChanged
	
	(self decoratorNamed: #shoutStyler) ifNotNil: [ :styler | 
		styler refreshStyling 
	].

	super themeChanged! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
announce: anAnnouncement 
	self announcer announce: anAnnouncement ! !

!RubAbstractTextArea methodsFor: 'accessing - editing state' stamp: ''!
releaseEditingState
	editingState ifNotNil: [ 
		editingState unplug.
		editingState := nil]! !

!RubAbstractTextArea methodsFor: 'composing' stamp: ''!
compose

	self prepareParagraphToCompose.
	self paragraph compose.
	self drawEmbeddedMorphs! !

!RubAbstractTextArea methodsFor: 'defaults' stamp: ''!
defaultTextColor
	"answer the default color/fill style for the receiver"
	^ self class textColor! !

!RubAbstractTextArea methodsFor: 'testing' stamp: ''!
isReadOnly
	^ self readOnly! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
newParagraph
	| newParagraph |
	newParagraph := RubOpeningClosingDelimiterDecorator next: RubParagraph new.
	newParagraph textArea: self.
	newParagraph container: self compositionRectangle.
	^ newParagraph! !

!RubAbstractTextArea methodsFor: 'public accessing' stamp: ''!
beEditable
	self readOnly
		ifTrue: [ self readOnly: false ]! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
focusChanged 
	super focusChanged.
	self editor focusChanged.
	self changed.

	
! !

!RubAbstractTextArea methodsFor: 'paragraph feedbacks' stamp: ''!
updateBottomFromParagraph
	paragraph
		ifNotNil: [ 
			| newExtent |
			newExtent := self paragraph extent max: self paragraph minimumExtent.
			self forceExtentTo: self extent x @ newExtent y]! !

!RubAbstractTextArea methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self compose.
	self addCursor.
	self plugFindReplace.
	DefaultTextColor := self theme textColor! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
borderWidth: newWidth
	"No border allowed"
	super borderWidth: 0! !

!RubAbstractTextArea methodsFor: 'completion' stamp: ''!
completionPostAction
	
	self hasCompletionEngine 
		ifTrue: [ completionEngine closeMenu ]
! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
restoreSelectionIndexesAfter: aBlock
	| prevStart prevStop |
	prevStart := self markIndex min: self pointIndex.
	prevStop := self pointIndex max: self markIndex.
	aBlock value.
	self selectFrom: prevStart to: prevStop - 1! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withDecoratorsNamed: aCollection
	aCollection do: [ :m | self withDecoratorNamed: m ]! !

!RubAbstractTextArea methodsFor: 'copying' stamp: ''!
copy
	^ super copy
		text: self text copy
		textStyle: textStyle copy
		color: color
		textColor: textColor ! !

!RubAbstractTextArea methodsFor: 'interactive error protocol' stamp: ''!
notify: aString at: anInteger in: aStream
	^ self editor notify: aString at: anInteger in: aStream! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
yellowButtonActivity: shiftKeyState 
	"Invoke the text-editing menu.
	Check if required first!!"
	self wantsYellowButtonMenu
		ifFalse: [ ^ false ].	
	(self getMenu: shiftKeyState)
		ifNotNil: [ :menu|
			menu privateOwner: self.
			menu setInvokingView: self editor.
			menu invokeModal. 
			self changed.
			^ true].
		
	^ true! !

!RubAbstractTextArea methodsFor: 'find-replace' stamp: ''!
replaceAll: aRegex with: aText startingAt: startIdx
	self
		handleEdit: [self editor replaceAll: aRegex with: aText startingAt: startIdx].
! !

!RubAbstractTextArea methodsFor: 'accessing' stamp: ''!
margins
	^  margins ifNil: [margins := self defaultMargins ]! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
markIndex
	^ self editingState markIndex
! !

!RubAbstractTextArea methodsFor: 'editing' stamp: ''!
cancelEdits
	"The message is sent when the user hits enter or Cmd-L.
	Cancel the current contents and end editing.
	This default implementation does nothing."
	self announce: (RubCancelEditRequested morph: self)
! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
hasDecorator: aDecorator
	^ self paragraph hasDecorator: aDecorator
	! !

!RubAbstractTextArea methodsFor: 'find-replace' stamp: ''!
findRegex
	^ self editor findRegex! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
selectFrom: a to: b
	self editor selectFrom: a to: b! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
privateText: stringOrText
	"Accept new text contents."

	| fontNumber |
	stringOrText isText
		ifTrue: [ self paragraph text: stringOrText ]
		ifFalse: [ 
			fontNumber := self textStyle defaultFontIndex.
			self paragraph text: (Text string: stringOrText asString attributes: {(TextFontChange fontNumber: fontNumber)}) ]! !

!RubAbstractTextArea methodsFor: 'private' stamp: ''!
privateSetParagraph: aParagraph
	paragraph := aParagraph! !

!RubAbstractTextArea methodsFor: 'dropping/grabbing' stamp: ''!
resistsRemoval
	^ self grabbedAllowed not! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
selectionStart
	^ self editingState selectionStart! !

!RubAbstractTextArea methodsFor: 'drawing' stamp: ''!
drawSubmorphsOnAthensCanvas: aCanvas
	"Draw the focus here since we are using inset bounds
	for the focus rectangle."

	super drawSubmorphsOnAthensCanvas: aCanvas.
	self paragraph drawOnAthensCanvas: aCanvas bounds: self drawingBounds color: self textColor.
	(scrollPane isNil and: [ self readOnly not and: [ self hasKeyboardFocus or: [ self hasFindReplaceFocus ] ] ])
		ifTrue: [  self drawKeyboardFocusOnAthensCanvas: aCanvas ]! !

!RubAbstractTextArea methodsFor: 'menu' stamp: ''!
getMenuPolicy: aGetMenuPolicy
	getMenuPolicy := aGetMenuPolicy! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
handleMouseMove: anEvent
	"Re-implemented to allow for mouse-up move events"

	anEvent wasHandled
		ifTrue: [ ^ self ].	"not interested"
	anEvent hand hasSubmorphs
		ifTrue: [ ^ self ].
	anEvent wasHandled: true.
	self mouseMove: anEvent.
	(anEvent anyButtonPressed and: [ anEvent hand mouseFocus == self ])
		ifFalse: [ ^ self ].
	super handleMouseMove: anEvent
	! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
stopIndex
	^ self selectionStop stringIndex! !

!RubAbstractTextArea methodsFor: 'accessing - cursor' stamp: ''!
cursor
	^ cursor
! !

!RubAbstractTextArea methodsFor: 'geometry' stamp: ''!
extent: aPoint
	self
		handleBoundsChange: [ 
			self wrapped
				ifTrue: [ 
					(bounds notNil and: [ bounds width = aPoint x ])
						ifTrue: [ ^ self ].
					super extent: ((self paragraph withoutDecorator extentFromClientBottomRight: aPoint) max: self minimumExtent).
					self recomputeSelection ]
				ifFalse: [ super extent: aPoint ] ]! !

!RubAbstractTextArea methodsFor: 'menu' stamp: ''!
lookupShiftMenu
	"default implementation of the algorithm that lookup the menu"

	| default |
	default := [ self editingMode shiftMenu ].
	^ self model 
		ifNil: [ default value ] 
		ifNotNil: [ :m | m shiftMenu ifNil: [ default value ] ]! !

!RubAbstractTextArea methodsFor: 'defaults' stamp: ''!
defaultBounds 
	^ super defaultBounds topLeft corner: self minimumExtent! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
selectionRects
	^ Array
		streamContents: [ :strm | 
			strm nextPutAll: self paragraph selectionRects.
			self cursor ifNotNil: [ strm nextPut: self cursor bounds ] ]! !

!RubAbstractTextArea methodsFor: 'composing' stamp: ''!
handleParagraphChange: aBlock
	aBlock value.
	self compose.
	self changed! !

!RubAbstractTextArea methodsFor: 'dropping/grabbing' stamp: ''!
aboutToBeGrabbedBy: aHand
	self grabbedAllowed
		ifTrue: [ ^ super aboutToBeGrabbedBy: aHand ].
	^ nil! !

!RubAbstractTextArea methodsFor: 'accessing - decorators' stamp: ''!
withDecoratorNamed: aKey
	(self hasDecoratorNamed: aKey)
		ifTrue: [ ^ self ].
	(self classOfDecoratorNamed: aKey)
		ifNotNil: [ :cls | self withDecorator: cls new ]! !

!RubAbstractTextArea methodsFor: 'geometry' stamp: ''!
minimumExtent
	^ self minExtent! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
textColor
	^ textColor ifNil: [ textColor := self defaultTextColor ]! !

!RubAbstractTextArea methodsFor: 'event handling' stamp: ''!
defaultFindReplaceServiceClass

	^ self class defaultFindReplaceServiceClass! !

!RubAbstractTextArea methodsFor: 'find-replace' stamp: ''!
replaceAll: aRegex with: aText
	self
		handleEdit: [self editor replaceAll: aRegex with: aText].
! !

!RubAbstractTextArea methodsFor: 'completion' stamp: ''!
completionEngine
	
	^ completionEngine 
	! !

!RubAbstractTextArea methodsFor: 'accessing - selection' stamp: ''!
pointIndex
	^ self editingState pointIndex! !

!RubAbstractTextArea methodsFor: 'accessing - text' stamp: ''!
text
	^ self paragraph text! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
defaultMaxExtent

	"Return default large enough size of an infinite area. SmallInteger maxVal on 32-bit systems."
	
	^ 16r3FFFFFFF
! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
backgroundColor
	^ BackgroundColor ifNil: [ self theme backgroundColor ]! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
backgroundColor: aColor
	BackgroundColor := aColor! !

!RubAbstractTextArea class methodsFor: 'shortcut examples' stamp: ''!
examplesOfEditorShortcutsOn: aBuilder
	"No Keymap here, by default, the editor rely on a builtin keymapping engine (see TextEditor and SmallEditor)
	Here are some example on how to declare them if you want to setup different shortcuts
	
	<keymap>

	(aBuilder shortcut: #accept)
		category: #RubTextEditor
		default: $s ctrl win | $s ctrl unix | $s command mac
		do: [ :morph | morph acceptContents ]. 
		
	(aBuilder shortcut: #selectAll) 
		category: #RubTextEditor
		shortcut: $a ctrl win | $a ctrl unix | $a command mac
		do: [ :target | target handleKeymapEdition: [:editor | editor selectAll ] ].

	(aBuilder shortcut: #copySelection) 
		category: #RubTextEditor
		default: $c ctrl win | $c ctrl unix | $c command mac
		do: [ :target | target editor copySelection ].
		
	(aBuilder shortcut: #paste) 
		category: #RubTextEditor
		default: $v ctrl win | $v ctrl unix | $v command mac
		do: [ :target | target handleKeymapEdition: [:editor | editor paste]].
		
	(aBuilder shortcut: #cut) 
		category: #RubTextEditor
		default: $x ctrl win | $x ctrl unix | $x command mac
		do: [ :target :event | target handleKeymapEdition: [:editor | editor cut]  ].
				
	(aBuilder shortcut: #find) 
		category: #RubTextEditor
		default: $f ctrl win | $f ctrl unix | $f command mac
		do: [ :target | target find ].
		
	(aBuilder shortcut: #findAgain) 
		category: #RubTextEditor
		default: $g ctrl win | $g ctrl unix | $g command mac
		do: [ :target | target handleKeymapEdition: [:editor | editor findAgain ] ].
		
	(aBuilder shortcut: #exchange) 
		category: #RubTextEditor
		default: $e ctrl win | $e ctrl unix | $e command mac
		do: [ :target | target handleKeymapEdition: [:editor | editor exchange ] ].
		
	(aBuilder shortcut: #backWord)  
		category: #RubTextEditor
		default: $w ctrl win | $w ctrl unix | $w command mac
		do: [ :target |  target handleKeymapEdition: [:editor | editor backWord ] ].
		
	(aBuilder shortcut: #backWord) 
		category: #RubTextEditor
		default: Character backspace  asShortcut win | Character backspace asShortcut unix | Character backspace asShortcut mac
		do: [ :target :morph :event |  target handleKeymapEdition: [:editor | editor backspace: event ] ].
		
	(aBuilder shortcut: #(swapChars)) 
		category: #RubTextEditor
		default: $y ctrl win | $y ctrl unix | $y command mac
		do: [ :target |  target handleKeymapEdition: [:editor | editor swapChars ] ].

	(aBuilder shortcut: #setSearchString)
		category: #RubTextEditor
		default: $h ctrl win | $h ctrl unix | $h command mac
		do: [ :target | target editor setSearchString ].
		
	(aBuilder shortcut: #cancel) 
		category: #RubTextEditor
		default: $l ctrl win | $l ctrl unix | $l command mac
		do: [ :target | target editor cancel ].
		
	(aBuilder shortcut: #undo) 
		category: #RubTextEditor
		default: $z ctrl win | $z ctrl unix | $z command mac
		do: [ :target | target editor undo ].
		
	(aBuilder shortcut: #redo) 
		category: #RubTextEditor
		default: $j ctrl shift win | $j ctrl shift unix | $j command shift mac
		do: [ :target | target editor redo ].
	
	(aBuilder shortcut: #cursorHome)
		category: #RubTextEditor
		default: Character home ctrl win | Character home ctrl unix | Character home command mac
		do: [ :target :morph :event | target editor cursorHome: event ].
	
	(aBuilder shortcut: #cursorEnd)
		category: #RubTextEditor
		default: Character end ctrl win | Character end ctrl unix | Character end command mac
		do: [ :target :morph :event | target editor cursorEnd: event ].

	(aBuilder shortcut: #cursorHome)
		category: #RubTextEditor
		default: Character home asShortcut win | Character home asShortcut unix | Character home asShortcut mac
		do: [ :target :morph :event | target editor cursorHome: event ].
	
	(aBuilder shortcut: #cursorEnd)
		category: #RubTextEditor
		default: Character end asShortcut win | Character end asShortcut unix | Character end asShortcut mac
		do: [ :target :morph :event | target editor cursorEnd: event ].
	"! !

!RubAbstractTextArea class methodsFor: 'examples' stamp: ''!
embeddedMorphExample
	"This is a simple example of how to embed morphs into a text. It is also a test to quickly see with ones eyes that the morphs are place right and behaves well under resize of window.
The example sits in this class because this class is the one which implements the placement of morphs"
	<example>
	|txt|
	txt := (1 to: 10000 by: 500) 
		inject: '' asText 
		into:[:sofar :elem| 
			sofar, 
			(String loremIpsum), 
			(((String value: 1) asText) addAttribute: (TextAnchor new anchoredMorph: CircleMorph new ))].

	RubScrolledTextMorph new
		extent: 500@321;
		beWrapped;
		updateTextWith: txt;
	 	openInWindow! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
highlightMessageSend: aBoolean
	HighlightMessageSend := aBoolean! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
lineNumbersBackgroundColor: aColor
	 LineNumbersBackgroundColor := aColor! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
lineNumbersFont
	^ LineNumbersFont ifNil: [ LineNumbersFont := TextStyle default fontOfPointSize: 7] ! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
caseSensitiveFinds: aBoolean
	CaseSensitiveFinds := aBoolean! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
lineNumbersTextColor: aColor
	LineNumbersTextColor := aColor! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
textColor
	^ DefaultTextColor ifNil: [ DefaultTextColor := self theme textColor ]  ! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
textColor: aColor
	DefaultTextColor := aColor! !

!RubAbstractTextArea class methodsFor: 'accessing' stamp: ''!
defaultFindReplaceServiceClass: aClass

	^ defaultFindReplaceServiceClass := aClass! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
walkAlongDisplayedLine
	^ WalkAlongDisplayedLine ifNil: [WalkAlongDisplayedLine := true] ! !

!RubAbstractTextArea class methodsFor: 'accessing' stamp: ''!
defaultFindReplaceServiceClass

	^ defaultFindReplaceServiceClass ifNil: [ RubFindReplaceService ]! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
lineNumbersBackgroundColor
	^ LineNumbersBackgroundColor ifNil: [ LineNumbersBackgroundColor := self theme backgroundColor darker] ! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
walkAlongDisplayedLine: aBoolean
	WalkAlongDisplayedLine := aBoolean! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
editorFont
	^ StandardFonts defaultFont! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
caseSensitiveFinds
	^ CaseSensitiveFinds ifNil: [CaseSensitiveFinds := false] ! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
lineNumbersTextColor
	^ LineNumbersTextColor ifNil: [ LineNumbersTextColor := self theme lineNumberColor ]! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
rubricSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #Rubric)
		label: 'Rubric editor';
		parent: #codeEditing;
		with: [ (aBuilder setting: #backgroundColor)
				target: self;
				default: Color white;
				description: 'The default editor background color';
				label: 'Background'.
			(aBuilder setting: #textColor)
				target: self;
				description: 'The default editor text color';
				default: Color black;
				label: 'Text color'.
			(aBuilder group: #LineNumbers)
				target: self;
				label: 'Line numbers';
				description: 'line numbers settings';
				with: [ (aBuilder setting: #lineNumbersFont)
						target: self;
						default: (TextStyle default fontOfPointSize: 7);
						description: 'Font used for line numbers';
						label: 'Line numbers font'.
					(aBuilder setting: #lineNumbersTextColor)
						target: self;
						default: Color veryDarkGray;
						description: 'Color used for line numbers';
						label: 'Line numbers color'.
					(aBuilder setting: #lineNumbersBackgroundColor)
						target: self;
						default: (Color r: 0.9198435972629521 g: 0.9198435972629521 b: 0.9198435972629521 alpha: 1.0);
						description: 'Color used for line numbers background';
						label: 'Line numbers background color' ].
			(aBuilder setting: #highlightMessageSend)
				target: self;
				default: true;
				description: 'In a Smalltalk text editor, highlight message sends on mouse over with shift key pressed.';
				label: 'Highlight Message Send' ]! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
highlightMessageSend
	^ HighlightMessageSend ifNil: [ HighlightMessageSend := false ] ! !

!RubAbstractTextArea class methodsFor: 'shortcut examples' stamp: ''!
examplesOfSmalltalkEditorShortcutsOn: aBuilder
	"No Keymap here, by default, the editor rely on a builtin keymapping engine (see TextEditor and SmallEditor)
	Here are some example on how to declare them if you want to setup different shortcuts

	<keymap>
	(aBuilder shortcut: #browseIt)
		category: #RubSmalltalkEditor
		default: $b command mac | $b ctrl win | $b ctrl unix
		do: [ :morph | morph editor browseIt ].
					
	(aBuilder shortcut: #doIt) 
		category: #RubSmalltalkEditor
		default: $d command mac | $d ctrl win | $d ctrl unix
		do: [ :morph | morph doIt ].
			
	(aBuilder shortcut: #inspectIt) 
		category: #RubSmalltalkEditor
		default: $i command mac | $i ctrl win | $i ctrl unix
		do: [ :morph | morph inspectIt ].
		
	(aBuilder shortcut: #implementorsOfIt) 
		category: #RubSmalltalkEditor
		default: $m command mac | $m ctrl win | $m ctrl unix
		do: [ :morph | morph implementorsOfIt ].
		
	(aBuilder shortcut: #sendersOfIt)
		category: #RubSmalltalkEditor
		default: $n command mac | $n ctrl win | $n ctrl unix
		do: [ :morph | morph sendersOfIt ].
		
	(aBuilder shortcut: #printIt) 
		category: #RubSmalltalkEditor
		default: $p command mac | $p ctrl win | $p ctrl unix
		do: [ :morph | morph printIt ].
		"! !

!RubAbstractTextArea class methodsFor: 'settings' stamp: ''!
lineNumbersFont: aFont
	LineNumbersFont := aFont! !

!RubAbstractTextAreaTest commentStamp: ''!
A RubAbstractTextAreaTest is a test class for testing the behavior of RubAbstractTextArea!
!RubAdornmentDisplayer commentStamp: ''!
RubAdornmentDisplayer adds a simple adornment for text area!
!RubAdornmentDisplayer methodsFor: 'accessing' stamp: ''!
computedWidthFrom: aRectangle
	^  (super computedWidthFrom: aRectangle) min: self computedSize
! !

!RubAdornmentDisplayer methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	| bnds adorncolor size fillStyle |
	super drawOn: aCanvas.
	self paragraphProvider isReadOnly ifTrue: [ ^self ].
	self paragraphProvider hasUnacceptedEdits ifFalse: [ ^self ].
	bnds := self bounds.
	adorncolor := self paragraphProvider adornmentColor.
	size := self width.
	fillStyle := (GradientFillStyle ramp: {
			0.0->(Color white alpha: 0.3).
			0.8->adorncolor.
			1.0->adorncolor})
		origin: bnds topRight - (size@0);
		direction: (size @ size negated) // 4;
		radial: false.
	aCanvas
		drawPolygon:  {bnds topRight. bnds topRight + (0@size). bnds topRight - (size@0)}
		fillStyle: fillStyle! !

!RubAdornmentDisplayer methodsFor: 'accessing' stamp: ''!
level
	^ SmallInteger maxVal ! !

!RubAdornmentDisplayer methodsFor: 'accessing' stamp: ''!
computedHeightFrom: aRectangle

	^ aRectangle height min: self computedSize! !

!RubAdornmentDisplayer methodsFor: 'accessing' stamp: ''!
computedPositionFrom: aRectangle
	^  ((aRectangle right min: self scrollBounds right) - (self computedWidthFrom: aRectangle)) @ aRectangle top
! !

!RubAdornmentDisplayer methodsFor: 'accessing' stamp: ''!
computedSize
	^  25! !

!RubAdornmentDisplayer methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	| bnds adorncolor size fillStyle vertices polygonPath |
	super drawOnAthensCanvas: anAthensCanvas.
	self paragraphProvider hasUnacceptedEdits
		ifFalse: [ ^ self ].
	bnds := self bounds.
	adorncolor := self paragraphProvider adornmentColor.
	size := self width.
	fillStyle := (GradientFillStyle
		ramp:
			{(0.0 -> (Color white alpha: 0.3)).
			(0.8 -> adorncolor).
			(1.0 -> adorncolor)})
		origin: bnds topRight - (size @ 0);
		direction: size @ size negated // 4;
		radial: false.
	vertices := {(bnds topRight).
	(bnds topRight + (0 @ size)).
	(bnds topRight - (size @ 0))}.
	polygonPath := anAthensCanvas
		createPath: [ :builder | 
			builder
				absolute;
				moveTo: vertices first.
			vertices allButFirstDo: [ :pt | builder lineTo: pt ].
			builder close ].
	anAthensCanvas setPaint: fillStyle.
	anAthensCanvas setShape: polygonPath.
	anAthensCanvas draw! !

!RubAdornmentDisplayer class methodsFor: 'querying' stamp: ''!
key
	^ #adornment! !

!RubAnnotationDisplayer commentStamp: ''!
I represent a bar with annotations for the text area, like editing mode, line numbers etc!
!RubAnnotationDisplayer methodsFor: 'geometry' stamp: ''!
manageLayoutInBounds: aRectangle
	| ret |
	ret := super manageLayoutInBounds: aRectangle.
	self updateContents.
	^ ret! !

!RubAnnotationDisplayer methodsFor: 'accessing' stamp: ''!
fontToUse
	^ RubAbstractTextArea lineNumbersFont ! !

!RubAnnotationDisplayer methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ self paragraphProvider backgroundColor darker! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph
	super noteNewOwner: aMorph.
	self color: self backgroundColor.
	lineAnnotation := RubTextFieldArea new.
	lineAnnotation withoutAnyDecorator.
	lineAnnotation backgroundColor: Color transparent.
	lineAnnotation font: self fontToUse.
	lineAnnotation beReadOnly.
	lineAnnotation textColor: self textColor.
	wrappingPolicyMorph := self wrappingPolicyLabelMorph.
	editingModeMorph := self editingModeLabelMorph.
	tabWidthMorph := self tabWidthLabelMorph.
	columnDisplayMorph := self columnDisplayLabelMorph.
	lineNumbersDisplayMorph := self lineNumbersDisplayLabelMorph.
	row := self theme
		newRowIn: self
		for:
			{(self spacer: 2).
			lineAnnotation.
			(self spacer: 2).
			tabWidthMorph.
			(self spacer: 2).
			editingModeMorph.
			(self spacer: 2).
			wrappingPolicyMorph.
			(self spacer: 2).
			lineNumbersDisplayMorph.
			(self spacer: 2).
			columnDisplayMorph.
			(self spacer: 2)}.
	wrappingPolicyMorph on: #mouseDown send: #changeWrappingPolicy to: self.
	tabWidthMorph on: #mouseDown send: #chooseTabWidth: to: self.
	editingModeMorph on: #mouseDown send: #chooseEditingMode: to: self.
	columnDisplayMorph on: #mouseDown send: #changeColumnDisplay to: self.
	lineNumbersDisplayMorph on: #mouseDown send: #changeLineNumbersDisplay to: self.
	row color: Color transparent.
	row hResizing: #spaceFill.
	lineAnnotation hResizing: #spaceFill.
	self addMorph: row! !

!RubAnnotationDisplayer methodsFor: 'managing line numbers' stamp: ''!
lineNumbersDisplayLabelMorph
	^ StringMorph contents: self lineNumbersDisplayLabel font: self fontToUse! !

!RubAnnotationDisplayer methodsFor: 'managing wrapping policy' stamp: ''!
changeWrappingPolicy
	self paragraphProvider wrapped
		ifTrue: [ self paragraphProvider beNotWrapped ]
		ifFalse: [ self paragraphProvider beWrapped ].
	self updateContents.
	self paragraphProvider changed! !

!RubAnnotationDisplayer methodsFor: 'managing line numbers' stamp: ''!
lineNumbersDisplayLabel
	^ self paragraphProvider lineNumbersRuler  
		ifNil: [ '+L' ]
		ifNotNil: [ 'L' ]! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
chooseEditingMode: anEvent
	self modeListMenu invokeAt: anEvent position in: self world.
	self updateContents! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
chosenTabWidth: anInteger
	self paragraph tabWidth: anInteger.
	self updateContents! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
editingModeLabelMorph
	^ StringMorph
		contents: self editingModeLabel
		font: self fontToUse! !

!RubAnnotationDisplayer methodsFor: 'managing wrapping policy' stamp: ''!
wrappingPolicyLabel
	^ self paragraphProvider wrapped
		ifTrue: [ 'W' ]
		ifFalse: [ 'NW' ]! !

!RubAnnotationDisplayer methodsFor: 'accessing' stamp: ''!
level
	^ 1! !

!RubAnnotationDisplayer methodsFor: 'geometry' stamp: ''!
computedHeightFrom: aRectangle
	^ row ifNil: [0] ifNotNil: [row height]! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
tabWidthLabelMorph
	^ StringMorph
		contents: self tabWidthLabel
		font: self fontToUse! !

!RubAnnotationDisplayer methodsFor: 'event handling' stamp: ''!
updateContents
	| t |
	row ifNil: [ ^self ].
	self textArea selectionStart ifNil: [ ^self ].
	self lines ifNil: [ ^self ].
	t := self textOfCharBlock: self textArea selectionStart.
	self textArea selectionStop ~= self textArea selectionStart
		ifTrue: [ t := t , ' -- ' , (self textOfCharBlock: self textArea selectionStop) ].
	lineAnnotation
		beEditableWhile: [ 
			lineAnnotation setTextWith: t.
			self layoutChanged ].
	wrappingPolicyMorph contents: self wrappingPolicyLabel.
	editingModeMorph contents: self editingModeLabel.
	tabWidthMorph contents: self tabWidthLabel.
	columnDisplayMorph contents: self columnDisplayLabel.
	lineNumbersDisplayMorph contents: self lineNumbersDisplayLabel.
	row position: self innerBounds topLeft.
	row width: self innerBounds width! !

!RubAnnotationDisplayer methodsFor: 'managing wrapping policy' stamp: ''!
wrappingPolicyLabelMorph
	^ StringMorph contents: self wrappingPolicyLabel font: self fontToUse! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
columnDisplayLabelMorph
	^ StringMorph
		contents: self columnDisplayLabel
		font: self fontToUse! !

!RubAnnotationDisplayer methodsFor: 'accessing' stamp: ''!
editingModeLabel
	^ self paragraphProvider editingMode label! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
columnDisplayLabel
	^ self paragraphProvider columnRuler 
		ifNil: [ '+C' ]
		ifNotNil: [ 'C' ]! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
chooseTabWidth: anEvent
	self tabWidthMenu invokeAt: anEvent position in: self world! !

!RubAnnotationDisplayer methodsFor: 'accessing' stamp: ''!
tabWidth
	^ self paragraph tabWidth! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
tabWidthLabel
	^ 'Tab width: ', self tabWidth printString! !

!RubAnnotationDisplayer methodsFor: 'accessing' stamp: ''!
tabWidthMenu
	"Answer the menu to be presented to select a tab width"

	^ (PragmaMenuBuilder pragmaKeyword: #RubTabWidthMenu model: self) menu! !

!RubAnnotationDisplayer methodsFor: 'accessing' stamp: ''!
modeListMenu
	"Answer the menu to be presented to select an editing mode"

	^ (PragmaMenuBuilder pragmaKeyword: #RubEditingModeMenu model: self) menu! !

!RubAnnotationDisplayer methodsFor: 'managing line numbers' stamp: ''!
changeLineNumbersDisplay
	self paragraphProvider lineNumbersRuler 
		ifNil: [ self paragraphProvider withLineNumbers ]
		ifNotNil: [ self paragraphProvider withoutLineNumbers ].
	self paragraphProvider manageLayout.
	self updateContents! !

!RubAnnotationDisplayer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self side: #bottom.
! !

!RubAnnotationDisplayer methodsFor: 'event handling' stamp: ''!
selectionChanged
	self updateContents.
	super selectionChanged! !

!RubAnnotationDisplayer methodsFor: 'accessing' stamp: ''!
textColor
	^ self textArea lineNumbersTextColor muchDarker
! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
changeColumnDisplay
	self paragraphProvider columnRuler
		ifNil: [ self paragraphProvider withColumns ]
		ifNotNil: [ self paragraphProvider withoutColumns ].
	self textArea changed.
	self updateContents! !

!RubAnnotationDisplayer methodsFor: 'event handling' stamp: ''!
textOfCharBlock: aCharacterBlock
	| t l c |
	l := aCharacterBlock textLine.
	c := aCharacterBlock stringIndex - l first + 1.
	t := l lineNumber printString , '/' , self lines size printString
		, ' [', c printString.
	self paragraphProvider annotationRuler
		ifNotNil: [ :r | 
			| tabIdx |
			tabIdx := ((aCharacterBlock left + 1) // self paragraph tabWidth) + 1.
			t := t , ':' , tabIdx printString ].
	t := t, ']'.
	^ t! !

!RubAnnotationDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
spacer: anInteger
	^ Morph new
		borderWidth: 0;
		color: Color transparent;
		extent: anInteger@3! !

!RubAnnotationDisplayer class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RubAnnotationDisplayer class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RubAnnotationDisplayer class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RubAnnotationDisplayer class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RubAnnotationDisplayer class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RubAnnotationDisplayer class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RubAnnotationDisplayer class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RubAnnotationDisplayer class methodsFor: 'menus' stamp: ''!
tabWidthMenuOn: aBuilder
	"Specify the menu used to select the tab width"

	<contextMenu>
	<RubTabWidthMenu>
	(6 to: 200 by: 6) do: [ :t | (aBuilder item: t asString asSymbol) action: [ :model | model chosenTabWidth: t ] ] ! !

!RubAnnotationDisplayer class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RubAnnotationDisplayer class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RubAnnotationDisplayer class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RubAnnotationDisplayer class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RubAnnotationDisplayer class methodsFor: 'querying' stamp: ''!
key
	^ #annotation! !

!RubAnnotationDisplayer class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RubAnnotationDisplayer class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RubAnnotationDisplayer class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RubAnnotationDisplayer class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RubAnnotationDisplayer class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RubAnnotationDisplayer class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RubAnnotationDisplayer class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RubAnnotationDisplayer class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RubAnnotationDisplayer class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RubAnnotationDisplayer class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RubAnnotationDisplayer class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RubAnnotationDisplayer class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RubAnnotationDisplayer class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RubAnnotationDisplayer class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RubAnnotationDisplayer class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RubAnnotationDisplayer class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RubAnnotationDisplayer class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RubAnnotationDisplayer class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RubAnnouncement commentStamp: ''!
I am an abstract announcement class. Extend me if you want to use an announcement related to a Rubric action  !
!RubBoundsChanged commentStamp: ''!
I am an abstract announcement relates to text area bounds changing!
!RubBoundsChanged methodsFor: 'accessing' stamp: ''!
previousBounds
	^ previousBounds! !

!RubBoundsChanged methodsFor: 'accessing' stamp: ''!
previousBounds: anObject
	previousBounds := anObject! !

!RubCancelEditRequested commentStamp: ''!
I am raised when edits are cancelled in the text area!
!RubCancelEditRequestedInModel commentStamp: ''!
I am raised when the edits are canceled in the model side!
!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
topRight
	^ surface topRight! !

!RubCharacterBlock methodsFor: 'comparing' stamp: ''!
< aCharacterBlock 
	"Answer whether the string index of the receiver precedes that of 
	aCharacterBlock."

	^stringIndex < aCharacterBlock stringIndex! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
corner
	^ surface corner! !

!RubCharacterBlock methodsFor: 'comparing' stamp: ''!
= aCharacterBlock
	^ self species = aCharacterBlock species
		ifTrue: [ stringIndex = aCharacterBlock stringIndex ]
		ifFalse: [ false ]! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
areasOutside: aRectangle
	^ surface areasOutside: aRectangle! !

!RubCharacterBlock methodsFor: 'private' stamp: ''!
stringIndex: anInteger topLeft: topLeft extent: extent 
	stringIndex := anInteger.
	surface := topLeft extent: extent
! !

!RubCharacterBlock methodsFor: 'private' stamp: ''!
moveBy: aPoint 
	"Change the corner positions of the receiver so that its area translates by 
	the amount defined by the argument, aPoint."
	surface := surface translateBy: aPoint! !

!RubCharacterBlock methodsFor: 'private' stamp: ''!
privateSetOrigin: aPoint
	self surface privateSetOrigin: aPoint! !

!RubCharacterBlock methodsFor: 'private' stamp: ''!
translateBy: aPoint 
	"Change the corner positions of the receiver so that its area translates by 
	the amount defined by the argument, aPoint."
	^ self copy moveBy: aPoint! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
bottomRight
	^ surface bottomRight ! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
area
	^ surface area! !

!RubCharacterBlock methodsFor: 'private' stamp: ''!
insetBy: aPoint 
	"Change the corner positions of the receiver so that its area translates by 
	the amount defined by the argument, aPoint."
	^ self copy surface: (surface insetBy: aPoint)! !

!RubCharacterBlock methodsFor: 'comparing' stamp: ''!
min: aCharacterBlock
	aCharacterBlock ifNil: [ ^ self ].
	^ aCharacterBlock < self
		ifTrue: [ aCharacterBlock ]
		ifFalse: [ self ]! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
origin
	^ surface origin! !

!RubCharacterBlock methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: 'a CharacterBlock with index '.
	stringIndex printOn: aStream.
	aStream nextPutAll: ' and surface '.
	self surface printOn: aStream.
	textLine
		ifNotNil: [ 
			aStream
				cr;
				nextPutAll: ' in '.
			textLine printOn: aStream ]! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
surface
	^ surface! !

!RubCharacterBlock methodsFor: 'comparing' stamp: ''!
> aCharacterBlock 
	"Answer whether the string index of the receiver comes after that of 
	aCharacterBlock."

	^aCharacterBlock < self! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
bottomLeft
	^ surface bottomLeft! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
surface: aRectangle
	surface := aRectangle! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
textLine
	^ textLine! !

!RubCharacterBlock methodsFor: 'comparing' stamp: ''!
max: aCharacterBlock
	aCharacterBlock ifNil: [ ^ self ].
	^ aCharacterBlock > self
		ifTrue: [ aCharacterBlock ]
		ifFalse: [ self ]! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
withRight: anInteger
	^ self copy surface: (surface withRight: anInteger)! !

!RubCharacterBlock methodsFor: 'comparing' stamp: ''!
>= aCharacterBlock 
	"Answer whether the string index of the receiver does not precede that of 
	aCharacterBlock."

	^(self < aCharacterBlock) not! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
bottom
	^ surface bottom! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
right
	^ surface right! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
stringIndex
	"Answer the position of the receiver in the string it indexes."

	^stringIndex! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
width
	^ surface width! !

!RubCharacterBlock methodsFor: 'private' stamp: ''!
privateSetCorner: aPoint
	self surface privateSetCorner: aPoint! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
textLine: aLine 
	textLine := aLine! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
left
	^ surface left! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
distance: aCharacterBlock
	"It returns absolute distance between two CharacterBlocks."
	^ (self stringIndex - aCharacterBlock stringIndex) abs! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
extent
	^ surface extent! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
topLeft
	^ surface topLeft! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
height
	^ surface height! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
top
	^ surface top! !

!RubCharacterBlock methodsFor: 'accessing' stamp: ''!
withLeft: anInteger
	^ self copy surface: (surface withLeft: anInteger)
! !

!RubCharacterBlock methodsFor: 'comparing' stamp: ''!
<= aCharacterBlock 
	"Answer whether the string index of the receiver does not come after that 
	of aCharacterBlock."

	^(self > aCharacterBlock) not! !

!RubCharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
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
! !

!RubCharacterBlockScanner methodsFor: 'private' stamp: ''!
characterPointSetX: xVal
	characterPoint := xVal @ characterPoint y! !

!RubCharacterBlockScanner methodsFor: 'scanning' stamp: ''!
placeEmbeddedObject: anchoredMorph
	"Workaround: The following should really use #textAnchorType"
	anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
	(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
	specialWidth := anchoredMorph width.
	^ true! !

!RubCharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]).
! !

!RubCharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
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]]))
		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! !

!RubCharacterBlockScanner methodsFor: 'scanning' stamp: ''!
indentationLevel: anInteger
	super indentationLevel: anInteger.
	nextLeftMargin := leftMargin.
	indentationLevel timesRepeat: [
		nextLeftMargin := self nextTabXFrom: nextLeftMargin]! !

!RubCharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
tab
	| currentX |
	currentX := (alignment = Justified and: [self leadingTab not])
		ifTrue:		"imbedded tabs in justified text are weird"
			[destX + (self tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse:
			[self nextTabXFrom: destX].
	lastSpaceOrTabExtent := lastCharacterExtent copy.
	self lastSpaceOrTabExtentSetX: (currentX - destX max: 0).
	currentX >= characterPoint x
		ifTrue: 
			[lastCharacterExtent := lastSpaceOrTabExtent copy.
			^ self crossedX].
	destX := currentX.
	lastIndex := lastIndex + 1.
	^false! !

!RubCharacterBlockScanner methodsFor: 'private' stamp: ''!
lastSpaceOrTabExtentSetX: xVal
	lastSpaceOrTabExtent := xVal @ lastSpaceOrTabExtent y! !

!RubCharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
setFont
	specialWidth := nil.
	super setFont! !

!RubCharacterBlockScanner methodsFor: 'private' stamp: ''!
lastCharacterExtentSetX: xVal
	lastCharacterExtent := xVal @ lastCharacterExtent y! !

!RubCharacterBlockScanner methodsFor: 'scanning' stamp: ''!
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: [ ^ (RubCharacterBlock new stringIndex: line first 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"
									^ (RubCharacterBlock new
										stringIndex: lastIndex + 1
										topLeft: characterPoint + (lastCharacterExtent x @ 0) + (font descentKern @ 0)
										extent: 0 @ lastCharacterExtent y) textLine: line ].
							(RubCharacterBlock new stringIndex: lastIndex topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterExtent - (font baseKern @ 0))
								textLine: line ]
						ifNotNil:
							[ "Result for characterBlockForIndex: " (RubCharacterBlock new stringIndex: characterIndex topLeft: characterPoint + ((font descentKern - kern) @ 0) extent: lastCharacterExtent) textLine: line ] ] ]! !

!RubCharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
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: (self nextTabXFrom: currentX) -
						currentX]
		ifFalse:	[self lastCharacterExtentSetX:  (((currentX + (self tabWidth -
						(line justifiedTabDeltaFor: spaceCount))) -
							currentX) max: 0)].
	^ true! !

!RubCharacterBlockScanner methodsFor: 'stop conditions' stamp: ''!
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 notNil
		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 := (lastIndex < text size and: [(text at: lastIndex) = Character cr and: [(text at: lastIndex+1) = Character lf]])
					ifTrue: [ lastIndex + 2 ]
					ifFalse: [ lastIndex + 1 ].
				self lastCharacterExtentSetX: 0.
				^ true].
		lastCharacter := Character cr.
		characterPoint := destX @ destY.
		self lastCharacterExtentSetX: rightMargin - destX.
		^true! !

!RubCharacterScanner commentStamp: ''!
I scan characters!
!RubCharacterScanner methodsFor: 'text constants' stamp: ''!
justified
	^ 3! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
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! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
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! !

!RubCharacterScanner methodsFor: 'private' stamp: ''!
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'.
! !

!RubCharacterScanner methodsFor: 'scanner methods' stamp: ''!
combinableChar: char for: prevEntity

! !

!RubCharacterScanner methodsFor: 'private' stamp: ''!
text: t textStyle: ts 
	text := t.
	textStyle := ts! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
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 |
	<primitive: 103>
	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].
			"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."
			
			(self isBreakableAt: lastIndex in: text) 
				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: char 
				right: nextChar
				into: widthAndKernedWidth.
			nextDestX := floatDestX + (widthAndKernedWidth at: 1).
			"note crossing of right component side, unless we would end up on the first position
			again (endless loop, if line is to narrow to hold this current character)"
			nextDestX > rightX ifTrue: [firstDestX ~= destX 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! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
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! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
plainTab

	"This is the basic method of adjusting destX for a tab."
	destX := (alignment = self justified and: [self leadingTab not])
		ifTrue:		"embedded tabs in justified text are weird"
			[destX + (self tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse: 
			[self nextTabXFrom: destX].
	pendingKernX := 0.
	firstDestX  := destX.! !

!RubCharacterScanner methodsFor: 'private' stamp: ''!
setActualFont: aFont
	"Set the basal font to an isolated font reference."

	font := aFont! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
registerBreakableIndex

	"Record left x and character index of the line-wrappable point. 
	The default implementation here does nothing."

	^ false.
! !

!RubCharacterScanner methodsFor: 'scanner methods' stamp: ''!
isBreakableAt: index in: sourceString 

	| char |
	
	char := sourceString at: index.
	char = Character space ifTrue: [^ true].
	char = Character cr ifTrue: [^ true].

	^ false.
! !

!RubCharacterScanner methodsFor: 'private' stamp: ''!
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: Character space.	"	map := font characterToGlyphMap."
	stopConditions := DefaultStopConditions! !

!RubCharacterScanner methodsFor: 'accessing' stamp: ''!
tabWidth
	^ textStyle rubTabWidth! !

!RubCharacterScanner methodsFor: 'multilingual scanning' stamp: ''!
widthOf: char inFont: aFont

	^ aFont widthOf: char! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	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 ].

	^ self
		scanMultiCharactersFrom: startIndex
		to: stopIndex
		in: sourceString
		rightX: rightX
		stopConditions: stops
		kern: kernDelta.

	
! !

!RubCharacterScanner methodsFor: 'private' stamp: ''!
setAlignment: style
	alignment := style.
	! !

!RubCharacterScanner methodsFor: 'private' stamp: ''!
backgroundColor: ignored
	"Overridden in DisplayScanner"! !

!RubCharacterScanner methodsFor: 'private' stamp: ''!
addKern: kernDelta
	"Set the current kern amount."
	kern := kern + kernDelta! !

!RubCharacterScanner methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	destX := destY := leftMargin := 0.! !

!RubCharacterScanner methodsFor: 'private' stamp: ''!
textColor: ignored
	"Overridden in DisplayScanner"! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| ascii f nextDestX maxAscii floatDestX widthAndKernedWidth nextChar atEndOfRun |
	lastIndex := startIndex.
	lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops endOfRun].
	font ifNil: [font := TextStyle defaultFont fontArray at: 1].
	font isFontSet ifTrue: [
		f := [font fontArray at: 1]
			on: Exception do: [:ex | nil].
		f ifNil: [ f := font fontArray at: 1].
		maxAscii := f maxAscii.
		spaceWidth := f widthOf: Character space.
	] ifFalse: [
		maxAscii := font maxAscii.
	].
	floatDestX := destX.
	widthAndKernedWidth := Array new: 2.
	atEndOfRun := false.
	[lastIndex <= stopIndex] whileTrue: [
		ascii := (sourceString at: lastIndex) charCode.
		ascii > maxAscii ifTrue: [ascii := maxAscii].
		(ascii < stops size and: [(stops at: ascii + 1) ~~ nil])
			ifTrue: [^ stops at: ascii + 1].
		
		(self isBreakableAt: lastIndex in: sourceString) 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! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
handleIndentation
	self indentationLevel timesRepeat: [
		self plainTab]! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
leadingTab
	"return true if only tabs lie to the left"
	line first to: lastIndex do:
		[:i | (text at: i) == Character tab ifFalse: [^ false]].
	^ true! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
indentationLevel: anInteger
	"set the number of tabs to put at the beginning of each line"
	indentationLevel := anInteger! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
indentationLevel
	"return the number of tabs that are currently being placed at the beginning of each line"
	^indentationLevel ifNil:[0]! !

!RubCharacterScanner methodsFor: 'scanning' stamp: ''!
nextTabXFrom: anX
	"Tab stops are distances from the left margin. Set the distance into the 
	argument, anX, normalized for the paragraph's left margin."

	| normalizedX tabX mx |
	mx := 9999.
	normalizedX := anX - leftMargin.
	tabX := self tabWidth.
	[ tabX <= normalizedX and: [ tabX < mx ] ] whileTrue: [ tabX := tabX + self tabWidth ].
	^ tabX < mx
		ifTrue: [ leftMargin + tabX min: rightMargin ]
		ifFalse: [ rightMargin ] ! !

!RubCharacterScanner methodsFor: 'private' stamp: ''!
addEmphasis: code
	"Set the bold-ital-under-strike emphasis."
	emphasisCode := emphasisCode bitOr: code! !

!RubCharacterScanner methodsFor: 'private' stamp: ''!
setFont: fontNumber
	"Set the font by number from the textStyle."

	self setActualFont: (textStyle fontAt: fontNumber)! !

!RubCharacterScanner class methodsFor: 'class initialization' stamp: ''!
initialize
"
	RubCharacterScanner initialize
"
	| a |
	a := RubTextStopConditions new.
	a at: 1 + 1 put: #embeddedObject.
	a at: Character tab asciiValue + 1 put: #tab.
	a at: Character cr asciiValue + 1 put: #cr.
	a at: Character lf asciiValue + 1 put: #cr.
	
	NilCondition := a copy.
	DefaultStopConditions := a copy.

	PaddedSpaceCondition := a copy.
	PaddedSpaceCondition at: Character space asciiValue + 1 put: #paddedSpace.
	
	SpaceCondition := a copy.
	SpaceCondition at: Character space asciiValue + 1 put: #space.
! !

!RubCodeSizeFeedback commentStamp: ''!
I represent the colored feedback to alert a too long method!
!RubCodeSizeFeedback methodsFor: 'accessing' stamp: ''!
computedWidthFrom: aRectangle
	^  (super computedWidthFrom: aRectangle) min: 50.
! !

!RubCodeSizeFeedback methodsFor: 'defaults' stamp: ''!
defaultBackgroundColor
	^ self backgroundColor ! !

!RubCodeSizeFeedback methodsFor: 'accessing' stamp: ''!
backgroundColor
	"Return the current fillStyle of the receiver."

	| basicColor size |
	basicColor := self theme backgroundColor.
	self paragraph ifNil: [ ^Color transparent ].
	size := self textSize.
	size >= self warningLimit
		ifTrue: [ 
			|  overshoot transitionSpan transitionColor |
			transitionSpan := self warningLimit.
			transitionColor := Color yellow mixed: 0.6 with: basicColor.
			size >= self alertLimit
				ifFalse: [ overshoot := size - self warningLimit ]
				ifTrue: [ 
					transitionSpan := self alertLimit - self warningLimit.
					basicColor := transitionColor mixed: 0.5 with: basicColor.
					transitionColor := (Color orange mixed: 0.5 with: Color red) mixed: 0.5 with: basicColor.
					overshoot := size - self alertLimit ].
			^ CompositeFillStyle
				fillStyles:
					{((GradientFillStyle
						ramp:
							{(0 -> transitionColor).
							(1 -> basicColor)})
						origin: (self bounds width / 2) asFloat @ self bounds bottom;
						direction: 0 @ (12 + (2 * self bounds height * overshoot / transitionSpan)) negated asFloat;
						normal: 0 @ 1;
						radial: false;
						yourself).
					((GradientFillStyle
						ramp:
							{(0 -> self theme backgroundColor).
							(0.3 -> (self theme backgroundColor alpha: 0.01))})
						origin: self bounds left @ (self bounds height / 2) asFloat;
						direction: self bounds width @ 0;
						normal: 1 @ 0;
						radial: false;
						yourself)} ].
	^ self normalColor! !

!RubCodeSizeFeedback methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	| font s |
	super drawOn: aCanvas.
	color = self normalColor
		ifTrue: [ ^ self ].
	font := self paragraph textStyle defaultFont.
	s := self textSize asString.
	aCanvas
		drawString: s
		in: (self bounds withTop: self bounds bottom - font height)
		font: font
		color: self stringColor! !

!RubCodeSizeFeedback methodsFor: 'accessing' stamp: ''!
alertLimit

	^ 2 * self warningLimit! !

!RubCodeSizeFeedback methodsFor: 'accessing' stamp: ''!
normalColor
	^ Color transparent! !

!RubCodeSizeFeedback methodsFor: 'private' stamp: ''!
ignoredCharacters

	^ { Character space. Character tab. Character cr. $.. $;. $:. $'. $(. $) }! !

!RubCodeSizeFeedback methodsFor: 'event handling' stamp: ''!
textChanged
	self updateColor.
	super textChanged! !

!RubCodeSizeFeedback methodsFor: 'accessing' stamp: ''!
computedPositionFrom: aRectangle
	^  ((aRectangle right min: self scrollBounds right) - (self computedWidthFrom: aRectangle)) @ aRectangle top
! !

!RubCodeSizeFeedback methodsFor: 'event handling' stamp: ''!
scrollerOffsetChanged
	self updateColor.
	super scrollerOffsetChanged! !

!RubCodeSizeFeedback methodsFor: 'accessing' stamp: ''!
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 ].! !

!RubCodeSizeFeedback methodsFor: 'private' stamp: ''!
updateColor
	self color: self backgroundColor! !

!RubCodeSizeFeedback methodsFor: 'private' stamp: ''!
textSize
	| result count ignoredCharacters |
	result := 0.
	count := true.
	ignoredCharacters := self ignoredCharacters.
	self text string
		do: [ :char | 
			result > (self alertLimit * 3) 
				ifTrue: [ ^result ].
			(#($' $") includes: char)
				ifTrue: [ count := count not ]
				ifFalse: [ 
					((ignoredCharacters includes: char) not and: [ count ])
						ifTrue: [ result := result + 1 ] ] ].
	^ result! !

!RubCodeSizeFeedback methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	| font s bnds |
	super drawOnAthensCanvas: anAthensCanvas.
	color = self normalColor
		ifTrue: [ ^ self ].
	font := self paragraph textStyle defaultFont.
	s := self textSize asString.
	bnds := self bounds withTop: self bounds bottom - font height.
	anAthensCanvas morphicDrawString: s in: bnds font: font color: self stringColor! !

!RubCodeSizeFeedback methodsFor: 'geometry' stamp: ''!
extent: aPoint 
	self updateColor.
	super extent: aPoint! !

!RubCodeSizeFeedback methodsFor: 'accessing' stamp: ''!
warningLimit

	^ 350! !

!RubCodeSizeFeedback class methodsFor: 'querying' stamp: ''!
key
	^ #codeSizeFeedback! !

!RubColumnDisplayer methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	| cwidth col dsh lw cw dc nb bnds gap |
	super drawOn: aCanvas.
	bnds := self bounds.
	cwidth := self width.
	cw := self tabWidth.
	gap := self offset x \\ cw .
	col := cw + self margins left.
	dsh := self tabLineDashes.
	dc := {(self tabLineColor). (Color transparent)}.
	lw := self tabLineWidth.
	nb := cwidth // cw.
	nb timesRepeat: [ 
			| b |
			b :=  (bnds topLeft + (col @ 0) ) corner: (bnds bottomLeft + ((col + lw) @ 0) ).
			b := b translateBy: (((cw - gap) - cw)@ 0).
			aCanvas
				frameRectangle: b
				width: 1
				colors: dc
				dashes: dsh.
			col := col + cw ]! !

!RubColumnDisplayer methodsFor: 'accessing' stamp: ''!
tabLineWidth
	^ tabLineWidth ifNil: [ tabLineWidth := 1 ]! !

!RubColumnDisplayer methodsFor: 'accessing' stamp: ''!
tabWidth: anInteger
	self paragraph tabWidth: anInteger! !

!RubColumnDisplayer methodsFor: 'accessing' stamp: ''!
font
	| textStyle |
	textStyle := self textStyle.
	^ textStyle fontAt: textStyle defaultFontIndex! !

!RubColumnDisplayer methodsFor: 'accessing' stamp: ''!
tabLineColor: aColor
	tabLineColor := aColor! !

!RubColumnDisplayer methodsFor: 'accessing' stamp: ''!
tabLineColor
	^ tabLineColor ifNil: [ tabLineColor := Color lightGray twiceLighter] ! !

!RubColumnDisplayer methodsFor: 'accessing' stamp: ''!
tabLineWidth: anInteger
	tabLineWidth := anInteger! !

!RubColumnDisplayer methodsFor: 'accessing' stamp: ''!
tabLineDashes
	^ tabLineDashes ifNil: [tabLineDashes := {self tabLineWidth. self tabLineWidth*3}].
! !

!RubColumnDisplayer methodsFor: 'accessing' stamp: ''!
tabLineDashes: anArray
	 tabLineDashes := anArray
! !

!RubColumnDisplayer methodsFor: 'accessing' stamp: ''!
tabLineDashesColors 
	^ tabLineDashesColors ifNil: [tabLineDashesColors := {(self tabLineColor). (Color transparent)}].
! !

!RubColumnDisplayer methodsFor: 'accessing' stamp: ''!
tabWidth
	^ self paragraph tabWidth! !

!RubColumnDisplayer methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	| cwidth col dsh lw cw dc nb bnds gap |
	super drawOnAthensCanvas: anAthensCanvas.
	bnds := self bounds.
	cwidth := self width.
	cw := self tabWidth.
	gap := self offset x \\ cw.
	col := cw + self margins left.
	dsh := self tabLineDashes.
	dc := {(self tabLineColor). (Color transparent)}.
	lw := self tabLineWidth.
	nb := cwidth // cw.
	(anAthensCanvas setStrokePaint: self tabLineColor)
		dashes: self tabLineDashes offset: 0;
		width: 1.
	nb
		timesRepeat: [ 
			| b |
			b := bnds topLeft + (col @ 0) corner: bnds bottomLeft + ((col + lw) @ 0).
			b := b translateBy: (cw - gap - cw) @ 0.
			anAthensCanvas setShape: b.
			anAthensCanvas draw.
			col := col + cw ]! !

!RubColumnDisplayer class methodsFor: 'querying' stamp: ''!
key
	^ #column! !

!RubCompositionScanner commentStamp: ''!
I scan a paragraph!
!RubCompositionScanner methodsFor: 'stop conditions' stamp: ''!
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.
	^ true! !

!RubCompositionScanner methodsFor: 'stop conditions' stamp: ''!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont! !

!RubCompositionScanner methodsFor: 'stop conditions' stamp: ''!
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: [ "(text at: lastIndex) charCode = 32 ifTrue: [destX := destX + spaceWidth]."
			runLength := text runLengthFor: (lastIndex := lastIndex + 1).
			runStopIndex := lastIndex + (runLength - 1).
			self setStopConditions.
			false ]! !

!RubCompositionScanner methodsFor: 'scanning' stamp: ''!
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 := (RubTextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
				rectangle: lineRectangle.
	spaceCount := 0.
	self handleIndentation.
	leftMargin := destX.
	line leftMargin: leftMargin.

	[false]
		whileFalse: 
			[stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex
				in: text string rightX: rightMargin stopConditions: stopConditions
				kern: kern.
			"See setStopConditions for stopping conditions for composing."
			line stopCondition: stopCondition.
			(self perform: stopCondition)
				ifTrue: [^ line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading]]! !

!RubCompositionScanner methodsFor: 'accessing' stamp: ''!
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.
! !

!RubCompositionScanner methodsFor: 'stop conditions' stamp: ''!
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 := self nextTabXFrom: destX.
	destX > rightMargin ifTrue:	[^self crossedX].
	lastIndex := lastIndex + 1.
	^false
! !

!RubCompositionScanner methodsFor: 'scanning' stamp: ''!
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]! !

!RubCompositionScanner methodsFor: 'scanning' stamp: ''!
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.
! !

!RubCompositionScanner methodsFor: 'stop conditions' stamp: ''!
setFont
	super setFont.
	breakAtSpace := false! !

!RubCompositionScanner methodsFor: 'stop conditions' stamp: ''!
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.
			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) = Character 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: Character 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
	].

	(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.
	lineHeight := lineHeightAtBreak.
	baseline := baselineAtBreak.
	^ true.
! !

!RubCompositionScanner methodsFor: 'stop conditions' stamp: ''!
cr
	"Answer true. Set up values for the text line interval currently being 
	composed."

	pendingKernX := 0.
	(lastIndex < text size and: [(text at: lastIndex) = Character cr  and: [(text at: lastIndex+1) = Character lf]]) ifTrue: [lastIndex := lastIndex + 1].
	line stop: lastIndex.
	spaceX := destX.
	line paddingWidth: rightMargin - spaceX.
	^true! !

!RubConfigurationChange commentStamp: ''!
I am raised when the configuration of a view changes!
!RubConfigurationChange methodsFor: 'accessing' stamp: ''!
configurationBlock
	^ configurationBlock ifNil: [ configurationBlock := [ :scrolledTextMorph | ] ]! !

!RubConfigurationChange methodsFor: 'accessing' stamp: ''!
configurationBlock: aBlockWithAScrolledTextMorphAsArgument
	configurationBlock := aBlockWithAScrolledTextMorphAsArgument! !

!RubCurrentLineBarDecorator methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
 
	| line bnd |
	
	aCanvas isShadowDrawing ifTrue: [ ^self ].
	
	self selectionStart = self selectionStop ifFalse: [^self].
	
	line := self selectionStart textLine.
	bnd := (line topLeft - (self margins left @ 0)) corner: (line bottomRight + (self margins right @ 0)).
	aCanvas fillRectangle: bnd color: self selectionBarColor! !

!RubCurrentLineBarDecorator methodsFor: 'accessing' stamp: ''!
selectionBarColor
	^ self theme selectionBarColor! !

!RubCurrentLineBarDecorator methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	| line bnd |
	super drawOnAthensCanvas: anAthensCanvas.
	self selectionStart = self selectionStop ifFalse: [^self].
	line := self selectionStart textLine.
	bnd := (line topLeft - (self margins left @ 0)) corner: ((line bottomRight + (self margins right @ 0)) min: anAthensCanvas clipRect bottomRight).
	anAthensCanvas setPaint: self selectionBarColor.
	anAthensCanvas setShape: bnd.
	anAthensCanvas draw 
! !

!RubCurrentLineBarDecorator class methodsFor: 'querying' stamp: ''!
key
	^ #selectionBar! !

!RubCursor commentStamp: ''!
I represent a cursor for the mouse !
!RubCursor methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph 
	super noteNewOwner: aMorph.
	self textArea announcer when: MorphGotFocus send: #whenGotFocus: to: self.
	self textArea announcer when: MorphLostFocus send: #whenLostFocus: to: self.
	self textArea announcer when: RubExtentChanged send: #whenTextAreaExtentChanged: to: self.
	self textArea announcer when: RubSelectionChanged send: #whenTextAreaSelectionChanged: to: self.
	self textArea announcer when: RubTextStyleChanged send: #whenTextAreaTextStyleChanged: to: self.
! !

!RubCursor methodsFor: 'initialization' stamp: ''!
defaultVisibleCursorColor
	^ self theme textColor! !

!RubCursor methodsFor: 'adding' stamp: ''!
addAlarmAt: millisecs
	self removeAlarm.
	(self stayVisible not and: [ self textArea hasFocus ])
		ifFalse: [ ^ self ].
	self world
		ifNotNil: [ :wld | 
			wld
				addAlarm: #hideShow
				withArguments: #()
				for: self
				at: Time millisecondClockValue + millisecs ]! !

!RubCursor methodsFor: 'blinking' stamp: ''!
beVisible
	self color = self invisibleCursorColor
		ifTrue: [ self color: self actualCursorColor ]! !

!RubCursor methodsFor: 'blinking' stamp: ''!
isBlinkingCursor
	^ self period > 0! !

!RubCursor methodsFor: 'event handling' stamp: ''!
whenLostFocus: anAnnouncement
	self stayVisible
		ifFalse: [ 
			self removeAlarm.
			self beNotVisible ]! !

!RubCursor methodsFor: 'adding' stamp: ''!
addAlarm

	self addAlarmAt: self period! !

!RubCursor methodsFor: 'accessing' stamp: ''!
actualCursorColor
	self textArea readOnly ifTrue: [ ^ Color transparent ].
	^ (self textArea hasFocus and: [ self stayVisible not ])
		ifFalse: [ self invisibleCursorColor ]
		ifTrue: [ self visibleCursorColor ]! !

!RubCursor methodsFor: 'accessing' stamp: ''!
period
	^ period ifNil: [ period := self class period ]! !

!RubCursor methodsFor: 'accessing' stamp: ''!
visibleCursorColor: aColor
	visibleCursorColor := aColor! !

!RubCursor methodsFor: 'event handling' stamp: ''!
whenTextAreaSelectionChanged: anAnnouncement
	self updateBounds.
	self updateVisibility ! !

!RubCursor methodsFor: 'accessing' stamp: ''!
invisibleCursorColor
	^ invisibleCursorColor ifNil: [ invisibleCursorColor := Color transparent ]! !

!RubCursor methodsFor: 'blinking' stamp: ''!
beNotVisible
	self color = self invisibleCursorColor
		ifFalse: [ self color: self invisibleCursorColor ]! !

!RubCursor methodsFor: 'private - layout' stamp: ''!
updateBounds
	| x line |
	self textArea ifNil: [ ^self ].
	line := self textArea selectionStop textLine.
	x := self textArea selectionStop left.
	self position: x @ line top.
	self extent: self class defaultWidth @ (line height + 1)! !

!RubCursor methodsFor: 'event handling' stamp: ''!
whenTextAreaExtentChanged: anAnnouncement
	self updateBounds! !

!RubCursor methodsFor: 'initialization' stamp: ''!
defaultBounds
	^ 0 @ 0 corner: 0 @ 0! !

!RubCursor methodsFor: 'blinking' stamp: ''!
startBlinking
	self beVisible.
	self ensureFor: 1000! !

!RubCursor methodsFor: 'event handling' stamp: ''!
updateVisibility
	(self textArea isNil or: [ self textArea canChangeText not ])
		ifTrue: [ ^ self beNotVisible ].
	self beVisible.
	self isBlinkingCursor
		ifTrue: [ self startBlinking ]
		ifFalse: [ self beVisible ].
	self changed! !

!RubCursor methodsFor: 'accessing' stamp: ''!
stayVisible: aBoolean
	stayVisible := aBoolean.
	self color: self visibleCursorColor ! !

!RubCursor methodsFor: 'accessing' stamp: ''!
visibleCursorColor
	self class cursorWithFixedColor 
		ifTrue: [ ^ self class defaultColor ].
	^ visibleCursorColor ifNil: [ self defaultVisibleCursorColor ] ! !

!RubCursor methodsFor: 'private' stamp: ''!
unplug
	self removeAlarm.
	self textArea announcer unsubscribe: self.
	super unplug! !

!RubCursor methodsFor: 'initialization' stamp: ''!
aboutToBeRemoved
	self beNotVisible.
	self removeAlarm.
	self textArea announcer unsubscribe: self! !

!RubCursor methodsFor: 'event handling' stamp: ''!
whenTextAreaTextStyleChanged: anAnnouncement
	self updateBounds.
! !

!RubCursor methodsFor: 'accessing' stamp: ''!
textArea
	^ owner! !

!RubCursor methodsFor: 'blinking' stamp: ''!
switchColor
	self color = self invisibleCursorColor
		ifTrue: [ self color: self actualCursorColor ]
		ifFalse: [ self beNotVisible ].
! !

!RubCursor methodsFor: 'accessing' stamp: ''!
stayVisible
	^ stayVisible ifNil: [ stayVisible := false ]! !

!RubCursor methodsFor: 'structure' stamp: ''!
topRendererOrSelf
	^owner topRendererOrSelf! !

!RubCursor methodsFor: 'blinking' stamp: ''!
hideShow
	self textArea canChangeText 
		ifFalse: [ ^ self beNotVisible ].
	self stayVisible 
		ifTrue: [ ^ self beVisible ].
	self isBlinkingCursor
		ifTrue: [ 
			self switchColor.
			self addAlarm ]
		ifFalse: [ self beVisible ]! !

!RubCursor methodsFor: 'initialization' stamp: ''!
defaultColor 
	^ Color transparent! !

!RubCursor methodsFor: 'blinking' stamp: ''!
removeAlarm
	self world
		ifNotNil: [ :wld | 
			wld removeAlarm: #hideShow for: self ] ! !

!RubCursor methodsFor: 'event handling' stamp: ''!
whenGotFocus: anAnnouncement
	self updateBounds.
	self updateVisibility ! !

!RubCursor methodsFor: 'blinking' stamp: ''!
ensureFor: millisecs
	self removeAlarm.
	self beVisible.
	self textArea canChangeText
		ifTrue: [ self addAlarmAt: millisecs ]! !

!RubCursor class methodsFor: 'accessing' stamp: ''!
defaultWidth: anInteger
	DefaultWidth := anInteger! !

!RubCursor class methodsFor: 'accessing' stamp: ''!
cursorWithFixedColor
	^ FixedColor ifNil: [ FixedColor := false ]! !

!RubCursor class methodsFor: 'accessing' stamp: ''!
period
	^ Period ifNil: [ Period :=  700 ] ! !

!RubCursor class methodsFor: 'accessing' stamp: ''!
defaultWidth
	^ DefaultWidth ifNil: [ DefaultWidth := 2 ]! !

!RubCursor class methodsFor: 'settings' stamp: ''!
rubricSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #'Rubric cursor')
		parent: #Rubric;
		label: 'Cursor';
		with: [ 
					(aBuilder setting: #cursorWithFixedColor)
						target: self;
						default: false;
						label: 'Fixed color';
						with: [ 
									(aBuilder setting: #defaultColor)
										target: self;
										default: Color lightGray;
										description: 'The cursolr color color';
										label: 'Color'  ].
					(aBuilder range: #defaultWidth)
						target: self;
						default: 2;
						label: 'Width';
						description: 'Specify the cursor width';
						range: (1 to: 4).
					(aBuilder range: #period)
						target: self;
						default: 700;
						label: 'Blinking period';
						description:
								'Specify the cursor blinking period in milliseconds. If it is set to zero then the cursor will not blink';
						range: (0 to: 1000) ]! !

!RubCursor class methodsFor: 'accessing' stamp: ''!
cursorWithFixedColor: aBoolean
	FixedColor := aBoolean! !

!RubCursor class methodsFor: 'accessing' stamp: ''!
defaultColor
	^ DefaultColor ifNil: [ DefaultColor := Color lightGray ]! !

!RubCursor class methodsFor: 'accessing' stamp: ''!
defaultColor: aColor
	DefaultColor := aColor! !

!RubCursor class methodsFor: 'accessing' stamp: ''!
period: anInteger
	Period :=  anInteger! !

!RubDisplayScanner methodsFor: 'displaying' stamp: ''!
displayEmbeddedForm: aForm

	aForm 
		displayOn: bitBlt destForm 
		at: destX @ (lineY + line baseline - aForm height)
		clippingBox: bitBlt clipRect
		rule: Form blend
		fillColor: Color white! !

!RubDisplayScanner methodsFor: 'stop conditions' stamp: ''!
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! !

!RubDisplayScanner methodsFor: 'stop conditions' stamp: ''!
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"
! !

!RubDisplayScanner methodsFor: 'private' stamp: ''!
backgroundColor: aColor
	ignoreColorChanges ifTrue: [^ self].
	backgroundColor := aColor! !

!RubDisplayScanner methodsFor: 'displaying' stamp: ''!
displayString: string from: startIndex to: stopIndex at: aPoint
	font displayString: string on: bitBlt 
		from: startIndex 
		to: stopIndex 
		at: aPoint kern: kern! !

!RubDisplayScanner methodsFor: 'private' stamp: ''!
textColor: textColor
	ignoreColorChanges ifTrue: [^ self].
	foregroundColor := textColor! !

!RubDisplayScanner methodsFor: 'displaying' stamp: ''!
fillTextBackground
	fillBlt == nil ifFalse:
		["Not right"
		fillBlt destX: line left destY: lineY
			width: line width left height: line lineHeight; copyBits].! !

!RubDisplayScanner methodsFor: 'scanning' stamp: ''!
placeEmbeddedObject: anchoredMorph
	anchoredMorph relativeTextAnchorPosition ifNotNil:[
		anchoredMorph position: 
			anchoredMorph relativeTextAnchorPosition +
			(anchoredMorph owner bounds origin x @ 0)
			- (0@morphicOffset y) + (0@lineY).
		^true
	].
	(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
	anchoredMorph isMorph ifTrue: [
		anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset.
		anchoredMorph setProperty: #hasBeenPositioned toValue: true
	] 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! !

!RubDisplayScanner methodsFor: 'stop conditions' stamp: ''!
cr
	"When a carriage return is encountered, simply increment the pointer 
	into the paragraph."

	pendingKernX := 0.
	(lastIndex < text size and: [(text at: lastIndex) = Character cr  and: [(text at: lastIndex+1) = Character lf]])
		ifTrue: [lastIndex := lastIndex + 2]
		ifFalse: [lastIndex := lastIndex + 1].
	^false! !

!RubDisplayScanner methodsFor: 'private' stamp: ''!
text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode
	text := t.
	textStyle := ts. 
	foregroundColor := foreColor.
	(backgroundColor := backColor) isTransparent ifFalse:
		[fillBlt := blt.
		fillBlt fillColor: backgroundColor].
	ignoreColorChanges := shadowMode! !

!RubDisplayScanner methodsFor: 'stop conditions' stamp: ''!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (alignment = self justified ifTrue: [#paddedSpace]).

"
	alignment = self justified ifTrue: [
		stopConditions == DefaultStopConditions 
			ifTrue:[stopConditions := stopConditions copy].
		stopConditions at: Character space asciiValue + 1 put: #paddedSpace]
"! !

!RubDisplayScanner methodsFor: 'stop conditions' stamp: ''!
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! !

!RubDisplayScanner methodsFor: 'scanning' stamp: ''!
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 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"! !

!RubDisplayScanner methodsFor: 'stop conditions' stamp: ''!
tab
	self plainTab.
	lastIndex := lastIndex + 1.
	^ false! !

!RubDisplayScanner methodsFor: 'stop conditions' stamp: ''!
plainTab
	| nextDestX |
 	nextDestX := super plainTab.
	fillBlt == nil ifFalse:
		[fillBlt destX: destX destY: destY width: nextDestX - destX height: font height; copyBits].
	^nextDestX! !

!RubDisplayScanner methodsFor: 'private' stamp: ''!
defaultTextColor
	defaultTextColor ifNil: [ defaultTextColor := Smalltalk ui theme textColor ].
	^ defaultTextColor! !

!RubDisplayScanner methodsFor: 'stop conditions' stamp: ''!
setFont 
	foregroundColor := self defaultTextColor.
	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].
! !

!RubDisplayScanner methodsFor: 'multilingual scanning' stamp: ''!
isBreakableAt: index in: sourceString

	^ false.
! !

!RubDisplayScanner methodsFor: 'stop conditions' stamp: ''!
setDestForm: df
	bitBlt setDestForm: df.! !

!RubDisplayScanner methodsFor: 'stop conditions' stamp: ''!
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 ! !

!RubDisplayScanner methodsFor: 'private' stamp: ''!
presentationText: t

	text := t.
! !

!RubDisplayScanner class methodsFor: 'queries' stamp: ''!
defaultFont
	^ TextStyle defaultFont! !

!RubDropListButtonRuler commentStamp: ''!
I'm a side button to be used with a text field to open an entry completion list !
!RubDropListButtonRuler methodsFor: 'geometry' stamp: ''!
computedWidthFrom: aRectangle
	^ downArrowBtn width! !

!RubDropListButtonRuler methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph
	| downArrow |
	super noteNewOwner: aMorph.
	downArrow := (self theme 
		basicCreateArrowOfDirection: #bottom 
		size: (self textArea textStyle defaultFont height)
		color: Color veryLightGray).
	downArrowBtn := IconicButtonMorph new labelGraphic: downArrow.
	downArrowBtn height: self paragraphProvider innerBounds height.
	downArrowBtn borderWidth: 0.
	downArrowBtn color: Color transparent.
	downArrowBtn actionSelector:  #openChooserWithAllOrCloseFrom:.
	downArrowBtn target: self paragraphProvider entryCompletion.
	downArrowBtn arguments: (Array with: self paragraphProvider).
	self addMorph: downArrowBtn! !

!RubDropListButtonRuler methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	side := #right
! !

!RubDropListButtonRuler methodsFor: 'accessing' stamp: ''!
level
	^ 1! !

!RubDropListButtonRuler class methodsFor: 'querying' stamp: ''!
key
	^ #dropListButton! !

!RubEditingArea commentStamp: ''!
I am the common class to use for editing text in an area!
!RubEditingArea methodsFor: 'accessing' stamp: ''!
editorClass: aClass
	editorClass := aClass! !

!RubEditingArea methodsFor: 'error handling' stamp: ''!
doesNotUnderstand: aMessage
	"{aMessage . thisContext sender} inspectOnce."
	^ aMessage sendTo: self editingMode! !

!RubEditingArea methodsFor: 'public accessing' stamp: ''!
beWrapped
	self wrapped
		ifFalse: [ self handleParagraphChange: [ self wrapped: true ] ]! !

!RubEditingArea methodsFor: 'accessing - decorators' stamp: ''!
withSelectionBar
	self withDecoratorNamed: #selectionBar! !

!RubEditingArea methodsFor: 'styler' stamp: ''!
shoutStyler
	^ self decoratorNamed: #shoutStyler! !

!RubEditingArea methodsFor: 'initialization' stamp: ''!
beForSmalltalkComment
	self editingMode: RubSmalltalkCommentMode new! !

!RubEditingArea methodsFor: 'binding' stamp: ''!
bindingOf: aString
	^ self editingMode bindingOf: aString! !

!RubEditingArea methodsFor: 'public accessing' stamp: ''!
beForSmalltalkScriptingWithDefaultFont
	self editingMode: RubSmalltalkScriptingMode new.
	self font: StandardFonts defaultFont! !

!RubEditingArea methodsFor: 'public accessing' stamp: ''!
beForSmalltalkScripting
	self editingMode: RubSmalltalkScriptingMode new! !

!RubEditingArea methodsFor: 'highlighting' stamp: ''!
ensureAndGetNewHighlightSegmentFrom: startIndex to: stopIndex
	
	^ self 
		removeHighlightSegment;
		addSegment: (RubHighlightSegmentMorph from: startIndex to: stopIndex)! !

!RubEditingArea methodsFor: 'initialization' stamp: ''!
beForPlainText
	self editingMode: RubPlainTextMode new! !

!RubEditingArea methodsFor: 'styler' stamp: ''!
withoutShoutStyler
	self withoutDecoratorNamed: #shoutStyler! !

!RubEditingArea methodsFor: 'highlighting' stamp: ''!
getHoverHighlightSegment

	^ self getSegmentOfClass: RubHoverHighlightSegmentMorph! !

!RubEditingArea methodsFor: 'highlighting' stamp: ''!
hasHighlightSegment

	^ self getHighlightSegment notNil! !

!RubEditingArea methodsFor: 'private' stamp: ''!
newParagraph
	^ RubCurrentLineBarDecorator	next: (RubExtraSelectionDecorator next: super newParagraph)! !

!RubEditingArea methodsFor: 'event handling' stamp: ''!
mouseMove: evt
	| editEvt |
	super mouseMove: evt.
	scrollPane ifNil: [ ^ self ].
	self scrollPivot: evt cursorPoint.
	editEvt := evt transformedBy: (self transformedFrom: scrollPane ) inverseTransformation.
	(editEvt position y between: scrollPane top and: scrollPane bottom)
		ifFalse: [
			self
				startStepping: #autoScroll:
				at: Time millisecondClockValue
				arguments: (Array with: evt)
				stepTime: 100	"fast enough" ]
		ifTrue: [ self stopSteppingSelector: #autoScroll: ]! !

!RubEditingArea methodsFor: 'highlighting' stamp: ''!
getSegmentOfClass: aClass

	^ self segments detect: [ :each | each class = aClass ] ifNone: [ nil ]! !

!RubEditingArea methodsFor: 'accessing' stamp: ''!
wrapped
	^ wrapped ifNil: [ wrapped := false ] ! !

!RubEditingArea methodsFor: 'highlighting' stamp: ''!
ensureAndGetNewHoverHighlightSegmentFrom: startIndex to: stopIndex
	
	^ self 
		removeHoverHighlightSegment;
		addSegment: (RubHoverHighlightSegmentMorph from: startIndex to: stopIndex)! !

!RubEditingArea methodsFor: 'highlighting' stamp: ''!
removeHoverHighlightSegment

	(self getHoverHighlightSegment)
		ifNotNil: [ :aSegment | aSegment delete ].! !

!RubEditingArea methodsFor: 'highlighting' stamp: ''!
removeHighlightSegment

	(self getHighlightSegment)
		ifNotNil: [ :aSegment | aSegment delete ].! !

!RubEditingArea methodsFor: 'styler' stamp: ''!
shoutAboutToStyle: myself

	^self editingMode shoutAboutToStyle: myself! !

!RubEditingArea methodsFor: 'settings' stamp: ''!
walkAlongDisplayedLine
	^ self class walkAlongDisplayedLine! !

!RubEditingArea methodsFor: 'accessing' stamp: ''!
wrapped: aBoolean
	wrapped := aBoolean! !

!RubEditingArea methodsFor: 'accessing' stamp: ''!
editorClass
	^ editorClass ifNil: [ editorClass := RubTextEditor ]! !

!RubEditingArea methodsFor: 'accessing - decorators' stamp: ''!
withoutOpeningClosingDelimitersHighlight
	self withoutDecoratorNamed: #openingClosingDelimitersHighlight! !

!RubEditingArea methodsFor: 'highlighting' stamp: ''!
getHighlightSegment

	^ self getSegmentOfClass:  RubHighlightSegmentMorph! !

!RubEditingArea methodsFor: 'styler' stamp: ''!
classOrMetaClass: aBehavior
	"set the classOrMetaClass in the receiver's styler to aBehavior"
	self shoutStyler ifNotNil: [ :styler | styler classOrMetaClass: aBehavior]! !

!RubEditingArea methodsFor: 'styler' stamp: ''!
textArea
	"for #whenTextAreaSelectionChanged:"
	^self! !

!RubEditingArea methodsFor: 'initialization' stamp: ''!
beForSmalltalkCodeInClass: aClass
	self editingMode: (RubSmalltalkCodeMode new
		classOrMetaClass: aClass;
		yourself)! !

!RubEditingArea methodsFor: 'event handling' stamp: ''!
autoScroll: anEvent
	scrollPane ifNil: [ ^self ].
	self scrollPivot  ifNil: [ ^self ].
	scrollPane scrollWhenMouseMove: anEvent pivotPoint: self scrollPivot! !

!RubEditingArea methodsFor: 'initialization' stamp: ''!
beForSmalltalkCodeWithDefaultFont
	self editingMode: RubSmalltalkCodeMode new.
	self font: StandardFonts defaultFont! !

!RubEditingArea methodsFor: 'public accessing' stamp: ''!
beNotWrapped
	self wrapped
		ifTrue: [ self handleParagraphChange: [ self wrapped: false ] ]! !

!RubEditingArea methodsFor: 'accessing - decorators' stamp: ''!
withoutSelectionBar
	self withoutDecoratorNamed: #selectionBar! !

!RubEditingArea methodsFor: 'accessing - decorators' stamp: ''!
withSecondarySelection
	self withDecoratorNamed: #secondarySelection! !

!RubEditingArea methodsFor: 'initialization' stamp: ''!
beForSmalltalkCode
	self editingMode: RubSmalltalkCodeMode new
! !

!RubEditingAreaTest commentStamp: ''!
A RubEditingAreaTest is a test class for testing the behavior of RubEditingArea!
!RubEditingAreaTest methodsFor: 'tests - accessing selection' stamp: ''!
testMarkBlockPointBlock
	self setSelectionFrom: 3 to: 6 text: area text.
	self assert: area pointBlock stringIndex equals: 3.
	self assert: area markBlock stringIndex equals: 6! !

!RubEditingAreaTest methodsFor: 'instance creation' stamp: ''!
newCharacterBlockIndex: anInteger text: aText
	| line |
	line := (RubTextLine start: 1 stop: 33 internalSpaces: 0 paddingWidth: 0) rectangle: (0 @ 0 corner: 0 @ 0).
	^ (CharacterBlock new stringIndex: anInteger text: aText topLeft: 0@0 extent: 0 @ 0)
			textLine: line;
			yourself! !

!RubEditingAreaTest methodsFor: 'running' stamp: ''!
tearDown

	area delete.
	super tearDown! !

!RubEditingAreaTest methodsFor: 'tests - accessing selection' stamp: ''!
testMouseClickShiftClick
	self sendMouseClickAt: 3 withShift: false.
	self sendMouseClickAt: 6 withShift: true.
	self assert: area markBlock stringIndex equals: 3.
	self assert: area pointBlock stringIndex equals: 6! !

!RubEditingAreaTest methodsFor: 'convenience' stamp: ''!
setSelectionFrom: startIndex to: stopIndex text: aText
	area markIndex: stopIndex pointIndex: startIndex! !

!RubEditingAreaTest methodsFor: 'tests - accessing selection' stamp: ''!
testModifySelection
	self testMarkBlockPointBlock.
	area modifySelection: (self newCharacterBlockIndex: 8 text: area text).
	self assert: area markBlock stringIndex equals: 3.
	self assert: area pointBlock stringIndex equals: 8.! !

!RubEditingAreaTest methodsFor: 'tests - accessing selection' stamp: ''!
testMouseMoveAfterDoubleClick
	self sendMouseClickAt: 11 withShift: false.
	self sendDoubleClickAt: 11 withShift: false.
	self sendMouseClickAt: 17 withShift: true.
	self assert: area markBlock stringIndex equals: 9.
	self assert: area pointBlock stringIndex equals: 17.! !

!RubEditingAreaTest methodsFor: 'convenience' stamp: ''!
sendDoubleClickAt: index withShift: aBoolean
	| buttons |
	position := (area paragraph characterBlockForIndex: index) surface leftCenter.
	buttons := (aBoolean ifTrue: [8] ifFalse: [0]).
	buttons := buttons bitOr: MouseButtonEvent redButton.
	event := MouseButtonEvent basicNew 
					setType: #mouseDown
					position: position
					which: MouseButtonEvent redButton
					buttons: buttons
					hand: (HandMorph new mouseFocus: area; yourself)
					stamp: nil.
	^ area doubleClick: event! !

!RubEditingAreaTest methodsFor: 'tests' stamp: ''!
testEmbeddedAnchorInTextAreDrawnAtRightPosition
	| circle longTextWithCircleAtEnd canvas|
	self skip. "The test fails in CI"
	circle := CircleMorphCounter new extent: 50 @ 50;color: Color blue.
	longTextWithCircleAtEnd := ((String loremIpsum: 10000), 
		(String value: 1)) asText 
			addAttribute: (TextAnchor new anchoredMorph: circle).

	self assert: circle owner isNil.
	self assert: circle position equals: 0@0.
	self assert: circle counter equals: 0.
	area updateTextWith: longTextWithCircleAtEnd.
	canvas := FormCanvas extent: 500@500.
	canvas fullDrawMorph: area.

	self assert: circle counter equals: 1.	
	self assert: circle position y > 500
	! !

!RubEditingAreaTest methodsFor: 'tests - accessing selection' stamp: ''!
testEmbeddedAnchorInTextAreDrawn
	| circle text canvas|
	self skip. "Somehow this test fails in the CI"
	circle := CircleMorph new extent: 50 @ 50;color: Color blue.

	self assert: circle owner isNil.
	self assert: circle position equals: 0@0.
	"add the circle to a text string"
	text := ('aaaaa',(String value: 1),'bbbbbbb') asText 
			addAttribute: (TextAnchor new anchoredMorph: circle).
	"render the text in a RubEditingArea to place the circle in a layout"
	area updateTextWith: text.
	canvas := FormCanvas extent: 500@500.
	canvas fullDrawMorph: area.
	self assert: (circle hasProperty: #hasBeenPositioned).
	self deny: circle position equals: 0@0! !

!RubEditingAreaTest methodsFor: 'convenience' stamp: ''!
sendMouseClickAt: index withShift: aBoolean
	| buttons |
	position := (area paragraph characterBlockForIndex: index) surface leftCenter.
	buttons := (aBoolean ifTrue: [8] ifFalse: [0]).
	buttons := buttons bitOr: MouseButtonEvent redButton.
	area simulateClickWith: buttons position: position.
	! !

!RubEditingAreaTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	area := RubEditingArea new.
	area setTextWith: 'one two three four'! !

!RubEditingMode commentStamp: ''!
I am an abstract class to choose the editing mode of the text area !
!RubEditingMode methodsFor: 'initialization' stamp: ''!
updateTextAreaWhenPlugged
	self textArea
		restoreSelectionIndexesAfter: [ 
			| t |
			t := self textArea text copy.
			self textArea updateTextWith: ''.
			self textArea updateTextWith: t ]! !

!RubEditingMode methodsFor: 'initialization' stamp: ''!
plugin: aTextArea 
	textArea := aTextArea.
	previousEditorClass := self textArea editorClass.
	previousEditorClass = self editorClass
		ifFalse: [ 
			self textArea editorClass: self editorClass.
			self textArea releaseEditor].
	self updateTextAreaWhenPlugged! !

!RubEditingMode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	acceptAllowed := true! !

!RubEditingMode methodsFor: 'accessing' stamp: ''!
textArea: aTextArea
	textArea := aTextArea! !

!RubEditingMode methodsFor: 'accessing' stamp: ''!
editor
	^self textArea editor! !

!RubEditingMode methodsFor: 'accessing' stamp: ''!
textStyle
	^ self textArea textStyle! !

!RubEditingMode methodsFor: 'menu' stamp: ''!
shiftMenu 
		"Answer the menu to be presented with the shift key pressed"

	^ self menu! !

!RubEditingMode methodsFor: 'menu' stamp: ''!
menu 
		"Answer the menu to be presented "

	^ (PragmaMenuBuilder pragmaKeyword: self menuKeyword  model: self textArea ) menu! !

!RubEditingMode methodsFor: 'accessing' stamp: ''!
editorClass
	^ RubTextEditor ! !

!RubEditingMode methodsFor: 'initialization' stamp: ''!
unplug
	previousEditorClass = self textArea editor class
		ifFalse: [ 
			self textArea editorClass: previousEditorClass.
			self textArea releaseEditor ].
	self updateTextAreaWhenUnplugged.
	textArea := nil.
! !

!RubEditingMode methodsFor: 'accessing' stamp: ''!
interactive

	"when returning true, it avoids that we can assign to class, i.e., Array := 55."
	
	^ true! !

!RubEditingMode methodsFor: 'initialization' stamp: ''!
updateTextAreaWhenUnplugged
! !

!RubEditingMode methodsFor: 'testing' stamp: ''!
isCompletionEnabled
	^ false! !

!RubEditingMode methodsFor: 'accessing' stamp: ''!
acceptAllowed: anObject
	acceptAllowed := anObject! !

!RubEditingMode methodsFor: 'accessing' stamp: ''!
textArea
	^ textArea! !

!RubEditingMode methodsFor: 'menu' stamp: ''!
menuKeyword
	^ self class menuKeyword! !

!RubEditingMode methodsFor: 'accessing' stamp: ''!
acceptAllowed
	^ acceptAllowed! !

!RubEditingMode methodsFor: 'accessing' stamp: ''!
model
	^ self textArea model! !

!RubEditingMode methodsFor: 'accessing' stamp: ''!
label
	^ self class label! !

!RubEditingMode class methodsFor: 'menu' stamp: ''!
extendedSearchMenuOn: aBuilder
	(aBuilder item: #'extendedSearch' translated)
		label: 'Code search...' translated;
		withSeparatorAfter;
		with: [ 
					(aBuilder item: #'Browse full class' translated)
						keyText: 'b';
						selector: #browseFullClass.
					(aBuilder item: #'Senders of it' translated)
						keyText: 'n';
						selector: #sendersOfIt.
					(aBuilder item: #'Implementors of it' translated)
						keyText: 'm';
						selector: #implementorsOfIt.
					(aBuilder item: #'References to it' translated)
						keyText: 'N';
						selector: #referencesToIt;
						withSeparatorAfter.
					(aBuilder item: #'Selectors containing it' translated)
						keyText: 'W';
						selector: #methodNamesContainingIt.
					(aBuilder item: #'Case insensitive method literal strings with it' translated)
						keyText: 'E';
						selector: #methodStringsContainingit.
					(aBuilder item: #'Case sensitive method literal strings with it' translated)
						keyText: 'E';
						selector: #methodCaseSensitiveStringsContainingit.
					(aBuilder item: #'Method source with it' translated)
						selector: #methodSourceContainingIt;
						withSeparatorAfter.
					(aBuilder item: #'Class names containing it' translated) selector: #classNamesContainingIt.
					(aBuilder item: #'Class comments with it' translated) selector: #classCommentsContainingIt ]! !

!RubEditingMode class methodsFor: 'menu' stamp: ''!
menuKeyword
	"Returns the name of the pragma to use to build the menu"
	^ self subclassResponsibility ! !

!RubEditingMode class methodsFor: 'keymap' stamp: ''!
buildTabKeymapOn: aBuilder
	<keymap>
	! !

!RubEditingState commentStamp: ''!
I represent datas of the current text area to manage undo operations etc!
!RubEditingState methodsFor: 'accessing' stamp: ''!
scrollPivot: aPoint
	scrollPivot := aPoint! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
previousInterval: anInterval

	previousInterval := anInterval.
! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
undoManager

	^ undoManager ifNil: [ undoManager := HistoryIterator new].
! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
selectionStop
	^ self pointBlock ifNotNil: [:pb | pb max: self markBlock]! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
textArea: aTextArea
	textArea := aTextArea.
! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
unselect
	self markBlock: self pointBlock copy! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
pointBlock
	^ pointBlock! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
paragraph
	^ textArea paragraph! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
pointBlock: aCharacterBlock
	pointBlock := aCharacterBlock! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
hasFocus: aBoolean
	hasFocus := aBoolean! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
markBlock
	^ markBlock! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
emphasisHere
	^ emphasisHere! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
selectionStart
	^ self pointBlock ifNotNil: [:pb | pb min: self markBlock]! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
scrollPivot
	^ scrollPivot! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
startOfTyping
	^ startOfTyping! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
previousInterval

	^ previousInterval ifNil: [previousInterval := 1 to: 0]! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
markBlock: aCharacterBlock
	markBlock := aCharacterBlock! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
emphasisHere: aListOfTextAttribute
	emphasisHere := aListOfTextAttribute ifNotNil: [ :l | l reject: [ :a | RubTextSelectionColor = a class ] ]! !

!RubEditingState methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
undoManager: aHistoryIterator

	undoManager := aHistoryIterator! !

!RubEditingState methodsFor: 'undo - redo' stamp: ''!
undo
	^ self undoManager undo ! !

!RubEditingState methodsFor: 'undo - redo' stamp: ''!
undoRedoTransaction: aBlock
	self undoManager openRecordGroup.
	aBlock ensure: [  self undoManager closeRecordGroup ].
! !

!RubEditingState methodsFor: 'undo - redo' stamp: ''!
redoArray: doArray undoArray: undoArray
	self undoManager isPlugged 
		ifTrue: [self undoManager redoArray: doArray undoArray: undoArray]! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
startOfTyping: anIntegerIndex
	startOfTyping := anIntegerIndex! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
markBlock: markCharacterBlock pointBlock: pointCharacterBlock
	markBlock := markCharacterBlock.
	pointBlock := pointCharacterBlock! !

!RubEditingState methodsFor: 'private' stamp: ''!
unplug
	super unplug.
	undoManager
		ifNotNil: [ 
			undoManager reset.
			undoManager := nil ].
	 pointBlock := markBlock := startOfTyping := previousInterval := nil.! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
markIndex
	^ self markBlock ifNotNil: [:m | m stringIndex] ifNil: [ 1 ]
! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
pointIndex
	^ self pointBlock ifNotNil: [:p | p stringIndex ] ifNil: [ 0 ]! !

!RubEditingState methodsFor: 'private - debugging' stamp: ''!
exploreUndoManager: aKeyboardEvent
	self undoManager inspect.
	^ true! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
hasFocus
	^ hasFocus ifNil: [ hasFocus := false ]! !

!RubEditingState methodsFor: 'undo - redo' stamp: ''!
redo
	^ self undoManager redo ! !

!RubEditingState methodsFor: 'undo - redo' stamp: ''!
clearUndoManager: aKeyboardEvent
	self undoManager reset.
	^ true! !

!RubEditingState methodsFor: 'accessing' stamp: ''!
markIndex: markIndex pointIndex: pointIndex
	markBlock := self paragraph characterBlockForIndex: markIndex.
	pointBlock := self paragraph characterBlockForIndex: pointIndex! !

!RubEditsStateChangedInModel commentStamp: ''!
I am raised when the user starts to edit a text area in the model side!
!RubEncryptedDisplayScanner methodsFor: 'scanning' stamp: ''!
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"! !

!RubExtentChanged commentStamp: ''!
I am raised when the right bounds of the text area are changed!
!RubExtraSelectionDecorator methodsFor: 'computation' stamp: ''!
cleanUpText
	self text removeAttribute: RubTextSelectionColor findReplaceSelection.
	self text removeAttribute: RubTextSelectionColor secondarySelection.
! !

!RubExtraSelectionDecorator methodsFor: 'drawing' stamp: ''!
computeSecondarySelectionShapesFrom: topLeft to: bottomRight
	| primary secondarySelRanges otherRanges topLeftBlk |
	primary := self primarySelectionInterval.
	topLeftBlk := self characterBlockAtPoint: topLeft.
	otherRanges := findReplaceRanges ifNil: [ #() ].
	self selection asString trimBoth ifEmpty: [ ^secondarySelectionShapes := #() ].
	(secondarySelRanges := (((self visibleStringFrom: topLeft to: bottomRight) allRangesOfSubstring: self selection asString)
		collect: [ :r | r + topLeftBlk stringIndex - 1 ])
		reject: [ :i | 
			(otherRanges anySatisfy: [ :r | (r rangeIncludes: i first) or: [ r rangeIncludes: i last ] ])
				or: [ i = primary or: [ i first > self text size ] ] ]) collect: [ :i | i first to: (i last min: self text size) ].
	secondarySelRanges
		do: [ :r | self text addAttribute: RubTextSelectionColor secondarySelection from: r first to: r last ].
	^ secondarySelectionShapes := secondarySelRanges
		collect: [ :r | 
			RubSurfaceSelectionShape
				vertices: (self verticesFrom: r first to: r last + 1)
				firstIndex: r first
				lastIndex: r last + 1
				color: (RubTextSelectionColor secondarySelection backgroundColor)
				borderWidth: 0
				borderColor: RubTextSelectionColor secondarySelection backgroundColor muchDarker]! !

!RubExtraSelectionDecorator methodsFor: 'drawing' stamp: ''!
drawAllSelectionShapesOnAthensCanvas: anAthensCanvas
	findReplaceShapes ifNotNil: [ findReplaceShapes do: [ :selblock | self drawSelectionShape: selblock onAthensCanvas: anAthensCanvas ] ].
	secondarySelectionShapes ifNotNil: [ secondarySelectionShapes do: [ :selblock | self drawSelectionShape:  selblock onAthensCanvas: anAthensCanvas] ]! !

!RubExtraSelectionDecorator methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas

	(Display depth < 3 or: [ aCanvas isShadowDrawing ]) ifTrue: [ ^ self ].		
	
	self computeSelectionShapesFor: aCanvas clipRect.
	self cleanUpText.
	self drawAllSelectionShapesOn: aCanvas! !

!RubExtraSelectionDecorator methodsFor: 'drawing' stamp: ''!
drawSelectionShape: aSelBlock on: aCanvas
	"Display a SelectionShape if it does not overlap vith the regular selection"
	
	| startIdx stopIdx  |
	
	startIdx := aSelBlock firstIndex.
	stopIdx := aSelBlock lastIndex.
	(self hasValidSelection) ifTrue: [ 
			| selSartIdx selStopIdx selBlockRange selRange |
			selSartIdx := self paragraph selectionStart stringIndex.
			selStopIdx := self paragraph 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 drawOn: aCanvas ! !

!RubExtraSelectionDecorator methodsFor: 'drawing' stamp: ''!
drawAllSelectionShapesOn: aCanvas

	findReplaceShapes ifNotNil: [ 
		findReplaceShapes do: [ :selblock | 
			self drawSelectionShape: selblock on: aCanvas
		] 
	].

	secondarySelectionShapes ifNotNil: [ 
		secondarySelectionShapes do: [ :selblock | 
				self drawSelectionShape: selblock on: aCanvas 
		] 
	]! !

!RubExtraSelectionDecorator methodsFor: 'drawing' stamp: ''!
drawSelectionShape: aSelBlock onAthensCanvas: anAthensCanvas
	"Display a SelectionShape if it does not overlap vith the regular selection"
	| startIdx stopIdx  |
	startIdx := aSelBlock firstIndex.
	stopIdx := aSelBlock lastIndex.
	self hasValidSelection ifTrue: [ 
		| selSartIdx selStopIdx selBlockRange selRange |
		
		selSartIdx := self selectionStart stringIndex.
		selStopIdx := self 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 drawOnAthensCanvas: anAthensCanvas! !

!RubExtraSelectionDecorator methodsFor: 'accessing' stamp: ''!
primarySelectionInterval
	
	self paragraph ifNotNil: [ :paragraph | 
		paragraph textArea ifNotNil: [ :textArea | 
			(textArea selectionStart isNotNil and: [ 
				textArea selectionStop isNotNil  		
			]) ifTrue: [ 
				^textArea selectionStart stringIndex to: textArea selectionStop stringIndex - 1
			]
		]	
	].

   ^0 to: -1
! !

!RubExtraSelectionDecorator methodsFor: 'drawing' stamp: ''!
computeSelectionShapesFor: aRectangle
	self computeFindReplaceShapesFrom: aRectangle topLeft to: aRectangle bottomRight.
	self computeSecondarySelectionShapesFrom: aRectangle topLeft to: aRectangle bottomRight! !

!RubExtraSelectionDecorator methodsFor: 'computation' stamp: ''!
computeFindReplaceShapesFrom: topLeft to: bottomRight
	| topLeftBlk |
	findReplaceShapes := nil.
	self findRegex ifNil: [ ^self ].
	topLeftBlk := self characterBlockAtPoint: topLeft.
	findReplaceRanges := ((self findRegex matchingRangesIn: (self visibleStringFrom: topLeft to: bottomRight))
		collect: [ :r | r + topLeftBlk stringIndex - 1 ]).
	findReplaceRanges do: [ :r | self text addAttribute: RubTextSelectionColor findReplaceSelection from: r first to: r last ].
	findReplaceShapes := findReplaceRanges
		collect: [ :r | 
			RubSurfaceSelectionShape
				vertices: (self verticesFrom: r first to: r last + 1)
				firstIndex: r first
				lastIndex: r last + 1
				color: (RubTextSelectionColor findReplaceSelection backgroundColor alpha: 0.1)
				borderWidth: 2
				borderColor: RubTextSelectionColor findReplaceSelection backgroundColor muchDarker].
	^ findReplaceShapes! !

!RubExtraSelectionDecorator methodsFor: 'testing' stamp: ''!
hasValidSelection

	| paragraph |
	
	paragraph := self paragraph ifNil: [ ^false ].
	
	^paragraph selectionStart notNil and: [ 
		paragraph selectionStop notNil and: [ 
			paragraph selectionStart ~= paragraph selectionStop 
		] 
	]! !

!RubExtraSelectionDecorator methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	super drawOnAthensCanvas: anAthensCanvas.
	self computeSelectionShapesFor: anAthensCanvas clipRect.
	self cleanUpText.
	self drawAllSelectionShapesOnAthensCanvas: anAthensCanvas! !

!RubExtraSelectionDecorator methodsFor: 'accessing' stamp: ''!
findRegex
	^ self paragraph textArea ifNotNil: [ :textArea | textArea findRegex ]! !

!RubExtraSelectionDecorator class methodsFor: 'querying' stamp: ''!
key
	^ #findReplaceSelection! !

!RubFindReplaceDialogWindow commentStamp: ''!
I am the window to find and replace text in a text area!
!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
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' selector: #showAbout.
	^ aMenu! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
isRegex: aBoolean
	self model isRegex: aBoolean.
! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
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}
		) 

! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
entireWordsOnly
	^ self model ifNil: [false] ifNotNil: [:m | m entireWordsOnly] ! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
entireWordsOnly: aBoolean
	self model entireWordsOnly: aBoolean.
! !

!RubFindReplaceDialogWindow methodsFor: 'action' stamp: ''!
replace
	self newReplacement.
	self model replace.
	self find! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
taskbarButtonFor: aTaskBar
	"No taskbar button because always on top"
	^nil! !

!RubFindReplaceDialogWindow methodsFor: 'updating' stamp: ''!
update: aSymbol
	self textView ifNotNil: [
		aSymbol = #regexError
				ifTrue: [self regexError].
		aSymbol = #newFinding
				ifTrue: [^ self newFinding].
		aSymbol = #findPolicy
			ifTrue: [self findPolicyChanged]].
	super update: aSymbol! !

!RubFindReplaceDialogWindow methodsFor: 'updating' stamp: ''!
findPolicyChanged
	self changed: #findText.
	self changed: #caseSensitive.
	self changed: #isRegex.
	self changed: #entireWordsOnly.
	self changed: #findEnabled.
	self changed: #replaceText.
	self changed: #replaceEnabled.
	self changed: #replaceAllEnabled.
	self findTextFieldMorph textColor: self theme textColor

! !

!RubFindReplaceDialogWindow methodsFor: 'action' stamp: ''!
replaceAll
	self model replaceAll! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
replaceText
	^ self model ifNil: [ '' asText] ifNotNil: [:m | m replaceText]! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
searchBackwards: aBoolean
	self searchBackwards = aBoolean
		ifFalse: [ 
			self model searchBackwards: aBoolean.
			self findPolicyChanged ]! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
textView
	^ self model ifNotNil: [ :m | m textArea ]! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self newFindButton isDefault: true. self newReplaceButton. self newReplaceAllButton. self newCancelButton}! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
newFindButton
	^(self theme
			newButtonIn: self
			for: self
			getState: nil
			action: #find
			arguments: nil
			getEnabled: #findEnabled
			label: 'Find' translated
			help: 'Find the next occurrence' translated)
		hResizing: #rigid;
		vResizing: #rigid! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
prevFinds
	^ self class finds! !

!RubFindReplaceDialogWindow methodsFor: 'updating' stamp: ''!
regexError
	self findTextFieldMorph textColor: Color  red! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
replaceEnabled
	^ self textView notNil
		and: [self findText notEmpty]! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
findTextFieldMorph
	^ findTextField! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
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
! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
caseSensitive: aBoolean
	self model caseSensitive: aBoolean.
! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
newReplaceAllButton
	^ (self theme
		newButtonIn: self
		for: self
		getState: nil
		action: #replaceAll
		arguments: nil
		getEnabled: #replaceAllEnabled
		label: 'Replace all' translated
		help: 'Replace all occurrences' translated) hResizing: #rigid;
		 vResizing: #rigid! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
defaultButton
	"Answer the default button."
	^self
		findDeepSubmorphThat: [:m |
			(m isKindOf: PluggableButtonMorph) and: [m actionSelector = #find]]
		ifAbsent: [] ! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
findText
	^ self model ifNil: ['' asText] ifNotNil: [:m | m findText]! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
extent: anExtent
	^ super extent: anExtent x @ self initialExtent y! !

!RubFindReplaceDialogWindow methodsFor: 'updating' stamp: ''!
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]! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
replaceAllEnabled
	^ self textView notNil
		and: [self findText notEmpty]! !

!RubFindReplaceDialogWindow methodsFor: 'action' stamp: ''!
cancel
	self model findText: ''.
	super cancel ! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
title
	^ 'Find & Replace' translated.
! !

!RubFindReplaceDialogWindow methodsFor: 'action' stamp: ''!
delete
	| m |
	m := model.
	[ super delete ]
		ensure: [ 
			model := m.
			model textArea ifNotNil: [ :ta | ta takeKeyboardFocus ] ]! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
wrapAround
	^ self model ifNil: [true] ifNotNil: [:m | m wrapAround] ! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
initialExtent 
	^ 400 @ super initialExtent y! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
defaultFocusMorph
	^ self findTextFieldMorph textMorph! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
findEnabled
	^ self findString isEmptyOrNil not ! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
findText: aStringOrText
	^ self model findText: aStringOrText.
! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
isResizeable
	"Answer whether we are not we can be resized."

	^true! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
newReplaceButton
	^ (self theme
		newButtonIn: self
		for: self
		getState: nil
		action: #replace 
		arguments: nil
		getEnabled: #replaceEnabled
		label: 'Replace' translated
		help: 'Replace the next occurrence' translated) hResizing: #rigid;
		 vResizing: #rigid! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
replaceText: aStringOrText
	self model replaceText: aStringOrText asString.
	^ true

! !

!RubFindReplaceDialogWindow methodsFor: 'action' stamp: ''!
find
	self newFinding.
	^ self model find! !

!RubFindReplaceDialogWindow methodsFor: 'updating' stamp: ''!
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]! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
maxPreviousListSize
	^ self class maxPreviousListSize! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
prevReplacements
	^ self class replacements! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
caseSensitive
	^ self model ifNil: [false] ifNotNil: [:m | m caseSensitive] ! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
wrapAround: aBoolean
	self model wrapAround: aBoolean.
! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
isRegex
	^ self model ifNil: [false] ifNotNil: [:m | m isRegex] ! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
findString
	^ self model ifNil: ['' asText] ifNotNil: [:m | m findString]! !

!RubFindReplaceDialogWindow methodsFor: 'user-interface' stamp: ''!
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.
	findTextField := pt.
	^ pt
! !

!RubFindReplaceDialogWindow methodsFor: 'accessing' stamp: ''!
searchBackwards
	^ self model ifNil: [false] ifNotNil: [:m | m searchBackwards]! !

!RubFindReplaceDialogWindow class methodsFor: 'accessing' stamp: ''!
finds
	^ Finds ifNil: [Finds := OrderedCollection new]! !

!RubFindReplaceDialogWindow class methodsFor: 'accessing' stamp: ''!
maxPreviousListSize
	^ 15! !

!RubFindReplaceDialogWindow class methodsFor: 'accessing' stamp: ''!
replacements
	^ Replacements ifNil: [Replacements := OrderedCollection new]! !

!RubFindReplaceDialogWindow class methodsFor: 'accessing' stamp: ''!
on: aTextView
	^ self new on: aTextView! !

!RubFindReplaceService commentStamp: ''!
RubFindReplaceService default newDialog openInWorld
RubFindReplaceService !
!RubFindReplaceService methodsFor: 'events handling' stamp: ''!
whenTextAreaLostFocus: anAnnounce
	self dialog isInWorld ifFalse: [ ^self ].
	self textArea whenFindTextChanged: RubFindTextChanged new
! !

!RubFindReplaceService methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	textAreaHolder := WeakArray new: 1 ! !

!RubFindReplaceService methodsFor: 'accessing' stamp: ''!
textArea: aTextArea
	textAreaHolder at: 1 put: aTextArea.
	aTextArea announcer 
		when: RubFindReplaceWindowRequired send: #whenFindReplaceWindowRequired: to: self. 
! !

!RubFindReplaceService methodsFor: 'user-interface' stamp: ''!
whenDialogDeleted
	dialog := nil.
! !

!RubFindReplaceService methodsFor: 'services' stamp: ''!
findNext
	| where  |
	findStartIndex 
		ifNil: [findStartIndex := self textArea editor startIndex].
	findStartIndex > 0 
		ifTrue: [where := self textArea findNextString: self findString startingAt: findStartIndex].
	(where isNil and: [self wrapAround])
		ifTrue: [where := self textArea findNextString: self findString asString startingAt: 1].
	^ where
! !

!RubFindReplaceService methodsFor: 'services' stamp: ''!
replace
	findStartIndex := self searchBackwards 
		ifTrue: [self textArea editor stopIndex] 
		ifFalse: [self textArea editor startIndex].
	(self find)
		ifNotNil: [self textArea replaceSelectionWith: self replaceText]! !

!RubFindReplaceService methodsFor: 'accessing' stamp: ''!
findText: aStringOrText
	super findText: aStringOrText.
	self textArea whenFindTextChanged: RubFindTextChanged new.
	^ true! !

!RubFindReplaceService methodsFor: 'updating' stamp: ''!
findPolicyChanged

	self textArea whenFindTextChanged: RubFindTextChanged new! !

!RubFindReplaceService methodsFor: 'services' stamp: ''!
replaceAll
	| startIdx |
	startIdx := self wrapAround ifTrue: [1] ifFalse: [self textArea editor selectionInterval first].
	self textArea replaceAll: self findRegex with: self replaceText startingAt: startIdx
! !

!RubFindReplaceService methodsFor: 'events handling' stamp: ''!
whenFindReplaceWindowRequired: anAnnouncement
	self findText
		ifEmpty: [ 
			self textArea hasSelection
				ifTrue: [ self findText: self textArea selection ] ].
	self dialog open! !

!RubFindReplaceService methodsFor: 'accessing' stamp: ''!
searchBackwards: aBoolean
	searchBackwards := aBoolean.
	self updateFindStartIndex.
	self findPolicyChanged
! !

!RubFindReplaceService methodsFor: 'services' stamp: ''!
find
	| where |
	self setStartIndex.
	where := self findAndSelectRegex.
	where ifNil: [ self textArea flash ].
	^ where! !

!RubFindReplaceService methodsFor: 'private' stamp: ''!
findAndSelect
	| where |
	findStartIndex > 0
		ifTrue: [ where := self textArea
				findAndSelect: self findRegex
				startingAt: findStartIndex
				searchBackwards: self searchBackwards ].
	(where isNil and: [ self wrapAround ])
		ifTrue: [ | idx |
			idx := self searchBackwards
				ifTrue: [ self textArea editor string size ]
				ifFalse: [ 1 ].
			where := self textArea
				findAndSelect: self findRegex
				startingAt: idx
				searchBackwards: self searchBackwards ].
	^ where! !

!RubFindReplaceService methodsFor: 'user-interface' stamp: ''!
dialog
	^ dialog ifNil: [ 
		dialog := self newDialog ]
	! !

!RubFindReplaceService methodsFor: 'user-interface' stamp: ''!
dialogIsActiveFor: aTextArea

	dialog ifNil: [ ^ false ].

	^ (self textArea = aTextArea) and: [ self dialog world notNil ].
! !

!RubFindReplaceService methodsFor: 'accessing' stamp: ''!
caseSensitive
	^ caseSensitive ifNil: [caseSensitive := RubAbstractTextArea caseSensitiveFinds]! !

!RubFindReplaceService methodsFor: 'accessing' stamp: ''!
findTextSilently: aStringOrText
	findText := aStringOrText asText.
	self findPolicyChanged! !

!RubFindReplaceService methodsFor: 'updating' stamp: ''!
updateFindStartIndex
	| si |
	self textArea 
		ifNil: [ ^self ]
		ifNotNil: [ :aTextArea |
			aTextArea changed.
			self changed: #replaceEnabled.
			si := aTextArea selectionInterval.
			self findStartIndex: (self searchBackwards ifTrue: [si first - 1] ifFalse: [si last + 1]) ]! !

!RubFindReplaceService methodsFor: 'accessing' stamp: ''!
textArea
	^ textAreaHolder at: 1 ! !

!RubFindReplaceService methodsFor: 'events handling' stamp: ''!
whenTextAreaGotFocus: anAnnounce
	self textArea: anAnnounce morph.
	self findText: self findText.
	self changed: #findText.
	self changed: #caseSensitive.
	self changed: #replaceEnabled.
! !

!RubFindReplaceService methodsFor: 'events handling' stamp: ''!
whenTextAreaSelectionChanged: anAnnouncement 
	self updateFindStartIndex! !

!RubFindReplaceService methodsFor: 'user-interface' stamp: ''!
newDialog
	| d |
	d := RubFindReplaceDialogWindow new model: self.
	d findPolicyChanged.
	d announcer when: MorphDeleted send: #whenDialogDeleted to: self.
	^ d
	! !

!RubFindReplaceService methodsFor: 'private' stamp: ''!
setStartIndex
	findStartIndex
		ifNil: [ findStartIndex := self searchBackwards
				ifTrue: [ self textArea editor stopIndex ]
				ifFalse: [ self textArea editor startIndex ] ]! !

!RubFindReplaceService methodsFor: 'private' stamp: ''!
findAndSelectRegex
	^ self findRegex ifNotNil: [ self findAndSelect ]! !

!RubFindReplaceServiceTest methodsFor: 'tests' stamp: ''!
defaultFindReplaceServiceClass

	^ RubFindReplaceService! !

!RubFindReplaceServiceTest methodsFor: 'tests' stamp: ''!
testCaseSensitive 
	
	self deny: ( self defaultFindReplaceServiceClass newFor: self) caseSensitive! !

!RubFindReplaceWindowRequired commentStamp: ''!
I am an announcement to signal there is a need of find and replace window!
!RubFindTextChanged commentStamp: ''!
I am raised when the text to find changed!
!RubFloatingEditorBuilder commentStamp: ''!
I provide the capability to open a floating editor to edit something on the fly.
The user is responsible for deciding on how to open the editor. See #exampleEditableStringMorph class side as an example on how to do it with #on:send:to.

One opened:
- if the escape character is pressed or if the keyboard focus is lost or in case of a mouse down anywhere else than inside the editor then the editing is aborted.
- the Enter key or Cmd+s save the contents in the Morph, then an announcement of class RubMorphEdited is sent so that the user can take desired action (checking the input, definitively accept it or reject it).

see #exampleEditableStringMorph class side 

Internal Representation and Key Implementation Points.

Instance Variables
	announcer:		<Announcer>
	editor:		<RubScrolledTextMorph>
	acceptOnCR:	<Boolean>
	initialContents: <String>
	font: <LogicalFont>
	customizeValuable: <Valuable>

Implementation notes
!
!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
editorDo: aBlock
	editor ifNil: [ ^ self ].
	aBlock cull: editor! !

!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
withEditedContentsDo: aBlock
	self
		announcerDo:
			[ :anncer | 
			anncer
				when: RubMorphEdited
				send: #value:
				to: [ :ann  | aBlock cull: ann morph text cull: ann morph ] ]! !

!RubFloatingEditorBuilder methodsFor: 'announcement handling' stamp: ''!
whenEditorLostFocus: anAnnouncement
	self closeEditor! !

!RubFloatingEditorBuilder methodsFor: 'announcement handling' stamp: ''!
closeEditor
	editor ifNil: [ ^ self ].
	editor delete! !

!RubFloatingEditorBuilder methodsFor: 'events - processing' stamp: ''!
handleListenEvent: anEvent
	anEvent isMouse
		ifFalse: [ ^ self ].
	anEvent isMouseDown
		ifFalse: [ ^ self ].
	editor ifNil: [ ^ self ].
	(editor boundsInWorld containsPoint: anEvent position)
		ifFalse: [ self closeEditor ]! !

!RubFloatingEditorBuilder methodsFor: 'initialization' stamp: ''!
defaultAnnouncer
	^ Announcer new! !

!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
acceptOnCR: aBoolean
	acceptOnCR := aBoolean! !

!RubFloatingEditorBuilder methodsFor: 'public editing' stamp: ''!
openEditor
	self buildEditor.
	editor ifNil: [ ^ self ].
	editor
		openInWorld;
		comeToFront.
	editor textArea takeKeyboardFocus! !

!RubFloatingEditorBuilder methodsFor: 'private' stamp: ''!
customizedEditor
	customizeValuable cull: editor.
	^ editor! !

!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
announcerDo: aBlock
	announcer ifNil: [ ^ self ].
	aBlock cull: announcer! !

!RubFloatingEditorBuilder methodsFor: 'private' stamp: ''!
buildEditor
	editor := RubScrolledTextMorph new forbidMenu.
	editor
		autoAccept: autoAccept;
		setTextWith: self initialContents.
	editor announcer
		when: MorphLostFocus send: #whenEditorLostFocus: to: self;
		when: RubTextAccepted send: #whenTextAccepted: to: self;
		when: RubReturnEntered send: #whenReturnEntered: to: self;
		when: RubKeystroke send: #whenKeystroke: to: self;
		when: MorphDeleted send: #whenEditorDeleted: to: self.
	editor
		beWrapped;
		font: font;
		margins: (Margin left: 2 right: 2 top: 0 bottom: 1);
		selectFrom: initialContents size + 1 to: initialContents size.

	"until we have better a rub text editor for text field like components"
	editor textArea on: PharoShortcuts current findShortcut do:[:x | "nothing, we don't need a search within a floating editor widget"].
	editor textArea withoutSelectionBar.
	^ self customizedEditor! !

!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
autoAccept: aBoolean
	autoAccept := aBoolean! !

!RubFloatingEditorBuilder methodsFor: 'announcement handling' stamp: ''!
whenReturnEntered: anAnnouncement
	acceptOnCR
		ifTrue: [ anAnnouncement accepted: true ].
	autoAccept
		ifTrue:
			[ | ann |
			ann := RubMorphEdited morph: editor.
			ann previousContents: initialContents.
			self announcer announce: ann yourself.
			self closeEditor ]! !

!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
whenEditorEscapedDo: aBlock
	escapeBlock := aBlock! !

!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer! !

!RubFloatingEditorBuilder methodsFor: 'announcement handling' stamp: ''!
whenKeystroke: anAnnouncement
	anAnnouncement event keyCharacter = Character escape
		ifTrue: [ escapeBlock value.
			self closeEditor ]! !

!RubFloatingEditorBuilder methodsFor: 'announcement handling' stamp: ''!
whenTextAccepted: anAnnouncement
	self
		editorDo:
			[ :ed | 
			| ann |
			autoAccept
				ifFalse: [ self closeEditor ].
			ann := RubMorphEdited morph: ed.
			ann previousContents: initialContents.
			self announcer announce: ann ]! !

!RubFloatingEditorBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	announcer := self defaultAnnouncer.
	initialContents := ''.
	acceptOnCR := true.
	autoAccept := false.
	escapeBlock := [  ].
	font := StandardFonts defaultFont.
	customizeValuable := [  ]! !

!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
font: aFont
	font := aFont! !

!RubFloatingEditorBuilder methodsFor: 'announcement handling' stamp: ''!
whenEditorDeleted: anAnnouncement
	anAnnouncement morph announcer unsubscribe: self.
	editor := nil! !

!RubFloatingEditorBuilder methodsFor: 'public editing' stamp: ''!
openEditorWithContents: aText thenDo: aBlock
	self
		initialContents: aText;
		openEditor.
	aBlock cull: editor! !

!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
initialContents
	^ initialContents! !

!RubFloatingEditorBuilder methodsFor: 'public editing' stamp: ''!
openEditorWithContents: aText
	self
		initialContents: aText;
		openEditor! !

!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
initialContents: anObject
	initialContents := anObject asText! !

!RubFloatingEditorBuilder methodsFor: 'accessing' stamp: ''!
customizeEditorWith: aBlock
	customizeValuable := aBlock! !

!RubFloatingEditorBuilder class methodsFor: 'examples' stamp: ''!
exampleEditableStringMorph
	<example>
	| pane stringMorph edBuilder |
	pane := Morph new.
	pane
		color: Color white;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		borderWidth: 5.
	stringMorph := StringMorph
		contents: 'Open the mini editor: [Shift+mouseDown on the string]; Update: [Enter|Cmd+s]; Abort: [Escape]'.
	stringMorph 
		position: 5 asPoint.
		pane addMorph: stringMorph.
	edBuilder := RubFloatingEditorBuilder new.
	edBuilder
		customizeEditorWith: [ :editor | 
			editor	 
				color: Color veryLightGray veryMuchLighter;
				bounds:
					(((stringMorph bounds withRight: pane right) withBottom: stringMorph bottom + 40)
						translateBy: 2 negated asPoint) ];
		withEditedContentsDo:
				[ :editedContents | 
			| newContents |
			newContents := editedContents ifEmpty: [ 'Ahem!! I need something here...' ].
			stringMorph contents: newContents.
			self inform: newContents ].
	stringMorph
		on: #mouseDown
		send: #value:
		to: [ :event | 
			event shiftPressed
				ifTrue: [ edBuilder openEditorWithContents: stringMorph contents ] ].
	(pane embeddedInMorphicWindowLabeled: 'Editable sm example')
		extent: (stringMorph extent translateBy:  30 @ 30);
		openInWorld! !

!RubFloatingEditorBuilder class methodsFor: 'examples' stamp: ''!
exampleCommandLauncher
	<sampleInstance>
	<example>
 	^RubFloatingEditorBuilder new
		acceptOnCR: false;
		customizeEditorWith: [ :editor | 
			editor
				width: 300;
				height: 50;
				center: self currentWorld center ];
		withEditedContentsDo: [ :newContents | self inform: newContents ];
		openEditorWithContents: 'self inspect'! !

!RubGetMenuPolicy commentStamp: ''!
I am an abstract class to get the correct menu of a text area!
!RubGetMenuPolicy methodsFor: 'accessing' stamp: ''!
textArea: aTextArea
	textArea := aTextArea! !

!RubGetMenuPolicy methodsFor: 'accessing - menu' stamp: ''!
lookupMenu 
	^ textArea lookupMenu! !

!RubGetMenuPolicy methodsFor: 'accessing' stamp: ''!
textArea
	^ textArea! !

!RubGetMenuPolicy methodsFor: 'accessing - menu' stamp: ''!
lookupShiftMenu 
	^ textArea lookupShiftMenu! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
computedWidthFrom: aRectangle
	^  self scrollBounds width
! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
handleTextChangeWhile: aBlock 
	aBlock value.
	self showHideGhostText! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
manageLayoutInBounds: aRectangle
	| ret |
	self handleTextChangeWhile: [ ret := super manageLayoutInBounds: aRectangle ].
	^ ret! !

!RubGhostTextDisplayer methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph
	super noteNewOwner: aMorph.
	ghostText := self paragraphProvider defaultGhostTextMorph.
	textColor := self defaultTextColor. 
	self textArea announcer when: MorphGotFocus send: #showHideGhostText to: self.	
	self textArea announcer when: MorphLostFocus send: #showHideGhostText to: self.! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
textColor: aColor
	textColor := aColor.
	self
		handleTextChangeWhile: [ ghostText textColor: aColor ]! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
fontName: aFontName pointSize: anInteger
	self
		handleTextChangeWhile: [ 
			ghostText
				beEditableWhile: [ 
					ghostText fontName: aFontName pointSize: anInteger.
					ghostText compose.
					self changed ] ]! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
bold
	self handleTextChangeWhile: [ghostText selectAll; bold; deselect]
! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
font: aFont
	self handleTextChangeWhile: [ghostText textFont: aFont]! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
setTextWith: aText
	ghostText setTextWith: aText asText.
	ghostText  textColor: self textColor
! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
level
	^ SmallInteger maxVal  - 1! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
textColor
	^ textColor! !

!RubGhostTextDisplayer methodsFor: 'alignment' stamp: ''!
centered
	self handleTextChangeWhile: [ ghostText centered ]
! !

!RubGhostTextDisplayer methodsFor: 'event handling' stamp: ''!
textChanged 
	self showHideGhostText.
	super textChanged
! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
computedPositionFrom: aRectangle
	^ self scrollBounds topLeft
! !

!RubGhostTextDisplayer methodsFor: 'alignment' stamp: ''!
leftFlush
	self handleTextChangeWhile: [ ghostText leftFlush ]
! !

!RubGhostTextDisplayer methodsFor: 'alignment' stamp: ''!
rightFlush
	self
		handleTextChangeWhile: [ ghostText rightFlush ]
! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
fontPointSize: anInteger
	self handleTextChangeWhile: [ghostText fontPointSize: anInteger]! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
updateMarginsWith: aMargin
	self
		handleTextChangeWhile: [ ghostText updateMarginsWith: aMargin]
! !

!RubGhostTextDisplayer methodsFor: 'initialization' stamp: ''!
defaultTextColor
	^ self theme ghostTextColor! !

!RubGhostTextDisplayer methodsFor: 'private' stamp: ''!
showHideGhostText
	self textArea text
		ifNotEmpty: [ self removeAllMorphs ]
		ifEmpty: [ 
			self paragraphProvider configureGhostText: ghostText.
			self addMorph: ghostText ]! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
updateTextWith: aText
	self
		handleTextChangeWhile: [ 
			ghostText updateTextWith: aText asText.
			ghostText textColor: self textColor ]! !

!RubGhostTextDisplayer methodsFor: 'geometry' stamp: ''!
extent: aPoint
	super extent: aPoint.
	self showHideGhostText! !

!RubGhostTextDisplayer methodsFor: 'accessing' stamp: ''!
ghostText 
	"Return the editing area of the ghostText"
	^ ghostText! !

!RubGhostTextDisplayer class methodsFor: 'querying' stamp: ''!
key
	^ #ghostText! !

!RubHighlightSegmentMorph commentStamp: ''!
A RubHighlightSegmentMorph is a volatile segment that deletes itself whenever the user interacts with the editor. It can be used to add selection-like segments.
!
!RubHighlightSegmentMorph methodsFor: 'event handling' stamp: ''!
whenKeyPressed: anEvent

	self delete! !

!RubHighlightSegmentMorph methodsFor: 'event handling' stamp: ''!
registerTextArea
	super registerTextArea.
	
	textArea announcer  
		when: RubKeystroke send: #whenKeyPressed: to: self;
		when: RubMouseClick send: #whenMouseClicked: to: self;
		when: RubSelectionChanged send: #whenSelectionChanged: to: self.
	
	self color: (self theme rubScrolledTextMorphThemer highlightBackgroundColorFor: textArea).
	self borderStyle: (self theme rubScrolledTextMorphThemer highlightBorderStyleFor: textArea).
	self borderWidth: (self textArea hasSelection
		ifTrue: [ 2 * self borderWidth] 
		ifFalse: [ self borderWidth ])! !

!RubHighlightSegmentMorph methodsFor: 'event handling' stamp: ''!
showMouseHasLeaved

! !

!RubHighlightSegmentMorph methodsFor: 'event handling' stamp: ''!
mouseDown: anEvent
	super mouseDown: anEvent.
	self delete! !

!RubHighlightSegmentMorph methodsFor: 'event handling' stamp: ''!
whenSelectionChanged: anAnnouncement 

	self delete
	! !

!RubHighlightSegmentMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt

	^ true! !

!RubHighlightSegmentMorph methodsFor: 'event handling' stamp: ''!
showMouseHasEntered
! !

!RubHighlightSegmentMorph methodsFor: 'event handling' stamp: ''!
whenTextChanged: anAnnouncement 

	self delete! !

!RubHighlightSegmentMorph methodsFor: 'event handling' stamp: ''!
whenMouseClicked: event

	self delete! !

!RubHorizontalScrolled commentStamp: ''!
I am raised when a horizontal scroll is done!
!RubHorizontalScrolled methodsFor: 'accessing' stamp: ''!
scrollValue
	^ scrollValue! !

!RubHorizontalScrolled methodsFor: 'accessing' stamp: ''!
scrollValue: anObject
	scrollValue := anObject! !

!RubHorizontalScrolled class methodsFor: 'instance creation' stamp: ''!
scrollValue: aScrollValue
	^ self new scrollValue: aScrollValue! !

!RubHoverHighlightSegmentMorph commentStamp: ''!
I am a text segment morph used for highlighting a text segment on mouse over. 
My default color are the text secondary (light) color.
And my default behavior is to delete myself when the mouse focus leaves me.!
!RubHoverHighlightSegmentMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self borderWidth: 1.
	self borderColor: self defaultBorderColor! !

!RubHoverHighlightSegmentMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: anEvent
	super mouseLeave: anEvent.
	self delete.! !

!RubHoverHighlightSegmentMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	^ self defaultColor muchDarker
! !

!RubHoverHighlightSegmentMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^ self theme secondarySelectionColor! !

!RubKeystroke commentStamp: ''!
I am raised when a keystroke is done!
!RubKeystroke methodsFor: 'accessing' stamp: ''!
event
	^ event! !

!RubKeystroke methodsFor: 'accessing' stamp: ''!
event: anObject
	event := anObject! !

!RubKeystroke class methodsFor: 'instance creation' stamp: ''!
with: anEvent
	^ self new event: anEvent! !

!RubLineNumberDisplayer commentStamp: ''!
I am the displayer of line numbers in the text area!
!RubLineNumberDisplayer methodsFor: 'geometry' stamp: ''!
computedWidthFrom: aRectangle
	^ (((self fontToUse widthOfString: self paragraph numberOfPhysicalLines asString) + self horizontalGapBefore
		+ self horizontalGapAfter + self verticalSeparatorWidth) max: self minimumWidth) truncated! !

!RubLineNumberDisplayer methodsFor: 'accessing' stamp: ''!
verticalSeparatorWidth
	^ 1! !

!RubLineNumberDisplayer methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	| prev right font lines visibleRectangle tcolor left |
	super drawOn: aCanvas.
	self paragraph selectionStart ifNil: [ ^ self ].
	self paragraph selectionStop ifNil: [ ^ self ].
	self paragraph lines ifNil: [ ^ self ].
	right := self bounds right.
	left := self bounds left.
	font := self fontToUse.
	prev := nil.
	lines := self lines.
	tcolor := self textColor.
	aCanvas
		clipBy: self bounds
		during: [ :clippedCanvas | 
			| backBnd |
			clippedCanvas fillRectangle: self verticalSeparatorBounds color: self verticalSeparatorColor.
			visibleRectangle := clippedCanvas clipRect.
			(self lineIndexForPoint: visibleRectangle topLeft) to: (self lineIndexForPoint: visibleRectangle bottomRight) do: [ :i | 
				| line |
				line := lines at: i.
				(self selectionStart == self selectionStop and: [self selectionStop textLine lineNumber = line lineNumber])
					ifTrue: [ 
						backBnd := self bounds.
						backBnd := (backBnd left) @ line top corner: self verticalSeparatorBounds left @ line bottom.
						backBnd := backBnd translateBy: 0 @ (self offset y negated + self bounds top).
						clippedCanvas fillRectangle: backBnd color: self selectionColorToUse ].
				prev = line lineNumber
					ifFalse: [ 
						| lineMark lineBnd ygap |
						ygap := ((line lineHeight - font height) // 2 - 1) rounded.
						lineMark := line lineNumber asString.
						self side = #left
							ifTrue: [ 
								| width |
								width := (self fontToUse widthOfString: lineMark) + self horizontalGapAfter.
								lineBnd := (right - width) @ (line bottom - font height - ygap) corner: (right + width) @ line bottom ]
							ifFalse: [ lineBnd := (left + self horizontalGapBefore) @ (line bottom - font height - ygap) corner: right @ line bottom ].
						lineBnd := lineBnd translateBy: 0 @ (self offset y negated + self bounds top).
						clippedCanvas
							drawString: lineMark
							in: lineBnd
							font: font
							color: tcolor.
						prev := line lineNumber ] ] ]! !

!RubLineNumberDisplayer methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ self paragraphProvider lineNumbersBackgroundColor ! !

!RubLineNumberDisplayer methodsFor: 'accessing' stamp: ''!
fontToUse
	^ RubAbstractTextArea lineNumbersFont ! !

!RubLineNumberDisplayer methodsFor: 'geometry' stamp: ''!
minimumWidth
	^ (self fontToUse widthOfString: 'MM') + self horizontalGapAfter + self horizontalGapBefore + self  verticalSeparatorWidth 
! !

!RubLineNumberDisplayer methodsFor: 'accessing' stamp: ''!
verticalSeparatorColor
	^ (self textArea backgroundColor contrastingBlackAndWhiteColor ) alpha: 0.3! !

!RubLineNumberDisplayer methodsFor: 'geometry' stamp: ''!
horizontalGapAfter
	^ 3! !

!RubLineNumberDisplayer methodsFor: 'geometry' stamp: ''!
horizontalGapBefore
	^ 3! !

!RubLineNumberDisplayer methodsFor: 'accessing' stamp: ''!
selectionColorToUse
	^ self primarySelectionColor! !

!RubLineNumberDisplayer methodsFor: 'accessing' stamp: ''!
level
	^ 2! !

!RubLineNumberDisplayer methodsFor: 'accessing' stamp: ''!
textColor
	^ self textArea lineNumbersTextColor 
! !

!RubLineNumberDisplayer methodsFor: 'event handling' stamp: ''!
yellowButtonActivity: shiftKeyState 
	"Invoke the text-editing menu.
	Check if required first!!"
	(self getMenu: shiftKeyState)
		ifNotNil: [ :menu|
			menu invokeModal. 
			self changed.
			^ true].
	^ true! !

!RubLineNumberDisplayer methodsFor: 'menus' stamp: ''!
menu
	"Answer the menu to be presented when the yellow button is pressed while the shift key is down"

	^ (PragmaMenuBuilder pragmaKeyword: self menuKeyword  model: self) menu! !

!RubLineNumberDisplayer methodsFor: 'event handling' stamp: ''!
mouseDown: anEvent
	| lineIndex line |
	(anEvent yellowButtonPressed and: [ anEvent commandKeyPressed not ]) "First check for option (menu) click"
		ifTrue: [ ^ (self yellowButtonActivity: anEvent shiftPressed) ].

	lineIndex := self lineIndexForPoint: anEvent position.
	line := self lines at: lineIndex.
	anEvent setPosition: line topLeft.
	self textArea mouseDown: anEvent! !

!RubLineNumberDisplayer methodsFor: 'menus' stamp: ''!
menuKeyword 
	^ #RubLineNumberMenu
	! !

!RubLineNumberDisplayer methodsFor: 'event handling' stamp: ''!
mouseUp: anEvent
	| lineIndex line |
	lineIndex := self lineIndexForPoint: anEvent position.
	line := self lines at: lineIndex.
	anEvent setPosition: line topLeft.
	self textArea mouseUp: anEvent.
! !

!RubLineNumberDisplayer methodsFor: 'menus' stamp: ''!
getMenu: shiftState
	"Answer the menu to be presented when the yellow button is pressed while the shift key is down"

	^ nil "self menu"! !

!RubLineNumberDisplayer methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^ true! !

!RubLineNumberDisplayer methodsFor: 'event handling' stamp: ''!
mouseMove: anEvent
	| lineIndex line |
	lineIndex := self lineIndexForPoint: anEvent position.
	line := self lines at: lineIndex.
	anEvent setPosition: line topLeft.
	self textArea mouseMove: anEvent
! !

!RubLineNumberDisplayer methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: aCanvas
	| prev right font lines visibleRectangle tcolor left |
	super drawOnAthensCanvas: aCanvas.
	self paragraph selectionStart ifNil: [ ^ self ].
	self paragraph selectionStop ifNil: [ ^ self ].
	self paragraph lines ifNil: [ ^ self ].
	right := self bounds right.
	left := self bounds left.
	font := self fontToUse.
	prev := nil.
	lines := self lines.
	tcolor := self textColor.
	aCanvas
		clipBy: self bounds
		during: [ 
			| backBnd |
			aCanvas setShape: self verticalSeparatorBounds.
			aCanvas setPaint: self verticalSeparatorColor.
			aCanvas draw.
			visibleRectangle := aCanvas clipRect.
			(self lineIndexForPoint: visibleRectangle topLeft) to: (self lineIndexForPoint: visibleRectangle bottomRight) do: [ :i | 
				| line |
				line := lines at: i.
				(self selectionStart == self selectionStop and: [self selectionStop textLine lineNumber = line lineNumber])
					ifTrue: [ 
						backBnd := self bounds.
						backBnd := (backBnd left) @ line top corner: self verticalSeparatorBounds left @ line bottom.
						backBnd := backBnd translateBy: 0 @ (self offset y negated + self bounds top).
						aCanvas setShape: backBnd.
						aCanvas setPaint: self selectionColorToUse.
						aCanvas draw ].
				prev = line lineNumber
					ifFalse: [ 
						| lineMark lineBnd ygap |
						ygap := ((line lineHeight - font height) // 2 - 1) rounded.
						lineMark := line lineNumber asString.
						self side = #left
							ifTrue: [ 
								| width |
								width := (self fontToUse widthOfString: lineMark) + self horizontalGapAfter.
								lineBnd := (right - width) @ (line bottom - font height - ygap) corner: (right + width) @ line bottom ]
							ifFalse: [ lineBnd := (left + self horizontalGapBefore) @ (line bottom - font height - ygap) corner: right @ line bottom ].
						lineBnd := lineBnd translateBy: 0 @ (self offset y negated + self bounds top).
						aCanvas morphicDrawString: lineMark in: lineBnd font: font color: tcolor.
						prev := line lineNumber ] ] ]! !

!RubLineNumberDisplayer methodsFor: 'accessing' stamp: ''!
verticalSeparatorBounds
	| bnds  |
	bnds := self bounds.
	^ self side = #left
		ifTrue: [ (bnds topRight -  (self verticalSeparatorWidth @ 0)) corner: bnds bottomRight ]
		ifFalse: [ (bnds topLeft corner: bnds bottomLeft + (self verticalSeparatorWidth @ 0)) ]! !

!RubLineNumberDisplayer class methodsFor: 'querying' stamp: ''!
key
	^ #lineNumbers! !

!RubLineNumberDisplayer class methodsFor: 'menu declaration' stamp: ''!
menuOn: aBuilder
	"Specify the menu used when writing text. Try it with:
	(PragmaMenuBuilder 
		pragmaKeyword: 'RubLineNumberMenu'
		model: nil) menu popUpInWorld"

	<contextMenu>
	<RubLineNumberMenu>
	(aBuilder item: #'Find...' translated)
		keyText: 'f';
		selector: #find;
		iconName: #smallFindIcon
! !

!RubLipsumBasicExample commentStamp: ''!
"When the text is wrapped, it is slower but the text has 1798 lines"
[self openWrapped] timeToRun  
     
"Enjoy the speed when not wrapped!! "
[self openNotWrapped] timeToRun 
 !
!RubLipsumBasicExample methodsFor: 'user interface' stamp: ''!
newScrolledTextNotWrapped
	^ self newScrolledText ! !

!RubLipsumBasicExample methodsFor: 'accessing' stamp: ''!
textModel
	^ textModel ifNil: [textModel := RubScrolledTextModel new text: self loremIpsum ]! !

!RubLipsumBasicExample methodsFor: 'user interface' stamp: ''!
newScrolledText
	| st |
	st := self textModel newScrolledText
		withAdornment;
		withLineNumbers;
		withColumns;
		withGhostText: 'Hello, the text is now empty. Don''t worry, I will disappear if you enter some text.';
		withAnnotation;
		yourself.
	st ghostTextRuler fontName: 'Bitmap DejaVu Sans' pointSize: 18; centered.
	^ st! !

!RubLipsumBasicExample methodsFor: 'user interface' stamp: ''!
newScrolledTextWrapped
	^ self newScrolledText beWrapped! !

!RubLipsumBasicExample methodsFor: 'accessing' stamp: ''!
loremIpsum
	^ String loremIpsum: 81233! !

!RubLipsumBasicExample class methodsFor: 'examples' stamp: ''!
openWrapped
	"self openWrapped"
	self openScrolledText: self new newScrolledTextWrapped.
! !

!RubLipsumBasicExample class methodsFor: 'examples' stamp: ''!
openNotWrapped
	"self openNotWrapped"

	self openScrolledText: self new newScrolledTextNotWrapped.
! !

!RubLipsumBasicExample class methodsFor: 'examples' stamp: ''!
openScrolledText: aScrolledText

	|  window |
	window := StandardWindow new.
	window addMorph: aScrolledText fullFrame: LayoutFrame identity.
	window title: self title.
	window openInWorld! !

!RubLipsumBasicExample class methodsFor: 'examples' stamp: ''!
title
	^ 'Lorem Ipsum example'! !

!RubLipsumWithSegmentsExample commentStamp: ''!
[self openWrapped] timeToRun
     
[self openNotWrapped] timeToRun
 !
!RubLipsumWithSegmentsExample methodsFor: 'user interface' stamp: ''!
newScrolledText
	| st r conf |
	st := super newScrolledText.
	conf := RubConfigurationChange new.
	conf
		configurationBlock: [ :scrolledText | 
			scrolledText withTextSegmentIcons.
			scrolledText addSegment: (r := RubUnderlinedSegmentMorph from: 1 to: 29).
			r icon: (self iconNamed: #smallErrorIcon).
			r label: 'Please review'.
			r iconBlock: [ :seg | seg delete ].
			scrolledText addSegment: (r := RubUnderlinedSegmentMorph from: 35 to: 59).
			r icon: (self iconNamed: #smallErrorIcon).
			r label: 'Remove'.
			r
				iconBlock: [ :seg :event | 
					seg textArea selectFrom: seg firstIndex to: seg lastIndex.
					seg textArea replaceSelectionWith: ''.
					seg delete ].
			scrolledText addSegment: (r := RubUnderlinedSegmentMorph from: 430 to: 740).
			r borderColor: Color lightGray.
			r changeable: false.
			r label: 'Edit separately'.
			r iconBlock: [ :seg :event | (seg readWriteView embeddedInMorphicWindowLabeled: 'Lipsum part view') openInHand ].
			r straight: false.
			r icon: (self iconNamed: #smallWarningIcon).
			scrolledText addSegment: (r := RubUnderlinedSegmentMorph from: 810 to: 1000).
			r color: (Color blue alpha: 0.1).
			r borderColor: Color black.
			r label: 'Explore'.
			r changeable: false.
			r icon: (self iconNamed: #smallHelpIcon).
			r iconBlock: [ :seg :event | seg inspect ].
			scrolledText addSegment: (r := RubPlainSegmentMorph from: 1300 to: 1610).
			r label: 'Remove'.
			r
				iconBlock: [ :seg :event | 
					seg textArea selectFrom: seg firstIndex to: seg lastIndex.
					seg textArea replaceSelectionWith: ''.
					seg delete ].
			r color: (Color green alpha: 0.1).
			r borderColor: Color gray.
			r icon: (self iconNamed: #smallWarningIcon) ].
	self textModel announce: conf.
	^ st! !

!RubLipsumWithSegmentsExample methodsFor: 'accessing' stamp: ''!
loremIpsum
	^ String loremIpsum: 2000! !

!RubMethodEditingExample commentStamp: ''!
self open!
!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
classIsMeta
	^ classIsMeta ifNil: [classIsMeta := false]! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
classIsMeta: aBoolean
	classIsMeta := aBoolean.
	self selector: nil.
	self changed: #selector.
	self changed: #classIsMeta.
	self updateCodeWith: ''
! !

!RubMethodEditingExample methodsFor: 'shout' stamp: ''!
shoutAboutToStyle: ATextView

	ATextView classOrMetaClass: self classToUse.
	^ true! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
selectedClass
	self className ifNil: [ ^ nil ]. 
	^ Smalltalk globals at: self className ifAbsent: []! !

!RubMethodEditingExample methodsFor: 'view' stamp: ''!
open
	| window editor |
	window := (StandardWindow labelled: 'Method editor with shout') model: self.
	editor := self newScrolledText.
	editor hResizing: #spaceFill; vResizing: #spaceFill.
	window addMorph: (window newColumn: { window newRow: { self classSelector. self metaSwitch. self methodSelector}. editor} )
		fullFrame: LayoutFrame identity.
	^ window openInWorld! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass
	^ self classToUse ! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
className: aClassName
	className := aClassName copyWithout: Character cr.
	self selector: nil.
	self updateCodeWith: ''.
	self changed: #selector.
	self changed: #className.
	self selectedClass
		ifNotNil: [ self changed: #haveClassName]! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!RubMethodEditingExample methodsFor: 'view' stamp: ''!
methodSelector
	| entryCompletion applicantsBlock |
	applicantsBlock := [self selectedClass 
						ifNil: [#()] 
						ifNotNil: [:clsn | self classToUse selectors asArray sort ]].
	entryCompletion := EntryCompletion new
				dataSourceBlock: [:currText | applicantsBlock value];
				filterBlock: [:currApplicant :currText | currText size > 0
						and: [currApplicant asUppercase includesSubstring: currText asString asUppercase]].
	^ (UIManager default newAutoAcceptTextEntryFor: self
			get: #selector
			set: #selector:
			class: String 
			getEnabled: #haveClassName
			help: 'Enter a selector' translated
			entryCompletion: entryCompletion) 
				acceptOnCR: false;
				ghostText: 'Selector';
				withDropListButton;
				yourself.
! !

!RubMethodEditingExample methodsFor: 'view' stamp: ''!
metaSwitch
	^ UIManager default
		newCheckboxFor: self
		getSelected: #classIsMeta
		setSelected: #classIsMeta:
		label: 'Class'
		help: 'Class side is used if checked' ! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
selector: aSymbol
	selector := aSymbol ifNotNil: [:sel |( sel copyWithout: Character cr) asSymbol].
	self updateCodeWith: ''.
	self changed: #selector.
	self classToUse 
		ifNotNil: [:cls | (cls selectors includes: selector)
			ifTrue: [self updateCodeWith:  (cls sourceCodeAt: selector)]]! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
textModel
	^ textModel ifNil: [ textModel := RubScrolledTextModel new interactionModel: self ]! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
haveClassName
	^ self selectedClass notNil! !

!RubMethodEditingExample methodsFor: 'updating' stamp: ''!
okToChange
	self textModel canDiscardEdits ifTrue: [ ^ true].
	self promptForCancel ifTrue: [ self textModel clearUserEdits  ].
	^ self textModel canDiscardEdits! !

!RubMethodEditingExample methodsFor: 'view' stamp: ''!
newScrolledText
	| scrolledText |
	scrolledText := self textModel
		newScrolledText
		beForSmalltalkCode;
		withCodeSizeFeedback;
		withGhostText: 'Choose a class and then a method to edit its code';
		yourself.
	scrolledText ghostTextRuler
		centered;
		fontPointSize: 18.
	^ scrolledText! !

!RubMethodEditingExample methodsFor: 'view' stamp: ''!
classSelector
	| applicantsBlock entryCompletion |
	applicantsBlock := [(Array
				streamContents: [:strm | Symbol
						allSymbolTablesDo: [:each | (each notEmpty
									and: [each first canBeGlobalVarInitial
											and: [Smalltalk globals includesKey: each]])
								ifTrue: [strm nextPut: each]]]) sort].
	entryCompletion := EntryCompletion new
				dataSourceBlock: [:currText | applicantsBlock value ];
				filterBlock: [:currApplicant :currText | currText size > 0
						and: [currApplicant asUppercase includesSubstring: currText asString asUppercase]].
	^ (UIManager default newAutoAcceptTextEntryFor: self
			get: #className
			set: #className:
			class: String 
			getEnabled: nil
			help: 'Enter a class name' translated
			entryCompletion: entryCompletion)
				acceptOnCR: false;
				ghostText: 'Class name';
				withDropListButton;
				yourself.
! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
updateCodeWith: someText
	self textModel setText: someText.
! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
classToUse
	^ self selectedClass
		ifNotNil: [self classIsMeta 
				ifTrue: [self selectedClass class]
				ifFalse: [self selectedClass]]! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
promptForCancel
	"Ask if it is OK to cancel changes"
	
	^(self confirm:
'Changes have not been saved.
Is it OK to cancel changes?' translated)
			! !

!RubMethodEditingExample methodsFor: 'accessing' stamp: ''!
className
	^ className ifNotNil: [className asSymbol]! !

!RubMethodEditingExample class methodsFor: 'instance creation' stamp: ''!
open
	self new open! !

!RubMorphAnnouncement commentStamp: ''!
I am an abstract class related to morph announcements!
!RubMorphEdited commentStamp: ''!
I am raised when a morph is edited!
!RubMorphEdited methodsFor: 'accessing' stamp: ''!
previousContents: anObject
	previousContents := anObject! !

!RubMorphEdited methodsFor: 'accessing' stamp: ''!
previousContents
	^ previousContents! !

!RubMouseClick commentStamp: ''!
I am raised when a mouse down is done!
!RubMouseClick methodsFor: 'accessing' stamp: ''!
event
	^ event! !

!RubMouseClick methodsFor: 'accessing' stamp: ''!
event: anObject
	event := anObject! !

!RubMouseClick class methodsFor: 'instance creation' stamp: ''!
with: anEvent
	^ self new event: anEvent! !

!RubNotificationStrategy commentStamp: ''!
I encapsulate the logic that gets executed when, during compilation, a RubSmalltalkEditor receives a notification from the compiler. 

I am an abstract class. My subclasses define the actual behaviour.!
!RubNotificationStrategy methodsFor: 'accessing' stamp: ''!
editor: aSmalltalkEditor
	editor := aSmalltalkEditor ! !

!RubNotificationStrategy methodsFor: 'accessing' stamp: ''!
editor
	^ editor! !

!RubNotificationStrategy methodsFor: 'notifications' stamp: ''!
notify: aString at: anInteger in: aStream 
	self subclassResponsibility ! !

!RubOpeningClosingDelimiterDecorator commentStamp: ''!
I am the decorator for highliting opposite character in a text area (like parenthese or square bracket)!
!RubOpeningClosingDelimiterDecorator methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Send all visible lines to the displayScanner for display"

	| cursorPosition delimiter oppositePos rect previousOppositeBlock |
	cursorPosition := self paragraph pointIndex ifNil: [ ^ self ].
	cursorPosition < 2 ifTrue: [ ^ self ].
	
	(self closingDelimiters includes: (delimiter := self paragraph string at: cursorPosition - 1)) 	ifFalse: [ 
			(self openingDelimiters includes: (delimiter := self paragraph string at: cursorPosition - 1)) 	ifFalse: [ ^ self ] .
	].

	oppositePos := self positionOfOppositeDelimiter: delimiter startingAt: cursorPosition in: aCanvas clipRect.
	oppositePos = 0 ifTrue: [ ^ self ].
	
	previousOppositeBlock := self characterBlockForIndex: oppositePos.
	rect := previousOppositeBlock.
	rect privateSetCorner: rect corner + (1 @ 1).
	rect privateSetOrigin: rect origin + (-1 @ 0).
	aCanvas fillRectangle: rect color: RubTextSelectionColor oppositeDelimiterSelection backgroundColor.
	aCanvas frameRectangle: rect color: RubTextSelectionColor oppositeDelimiterSelection textColor! !

!RubOpeningClosingDelimiterDecorator methodsFor: 'drawing' stamp: ''!
positionOfOppositeDelimiter: aDelimiter startingAt: aPosition in: aRectangle
	| string topLineIndex bottomLineIndex topLineFirst bottomLinelast oppositeDelimiter level here hereChar incr |
	string := self string.
	topLineIndex := self lineIndexForPoint: aRectangle topLeft.
	bottomLineIndex := self lineIndexForPoint: aRectangle bottomRight.
	topLineFirst := (self lines at: topLineIndex) first.
	bottomLinelast := (self lines at: bottomLineIndex) last.
	oppositeDelimiter := self openingDelimiters , self closingDelimiters
		at: (self closingDelimiters , self openingDelimiters indexOf: aDelimiter).
	(self openingDelimiters includes: aDelimiter)
		ifTrue: [ incr := [ :v | v + 1 ] ]
		ifFalse: [ incr := [ :v | v - 1 ] ].
	level := 1.
	here := aPosition - 1.
	[ level > 0 and: [ here > (topLineFirst max: 1) and: [ here <= bottomLinelast ] ] ]
		whileTrue: [ 
			here := incr value: here.
			here > string size
				ifTrue: [ ^ 0 ].
			hereChar := string at: here.
			hereChar = oppositeDelimiter
				ifTrue: [ 
					level := level - 1.
					level = 0
						ifTrue: [ ^ here ] ]
				ifFalse: [ 
					hereChar = aDelimiter
						ifTrue: [ level := level + 1 ] ] ].
	^ 0! !

!RubOpeningClosingDelimiterDecorator methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"Send all visible lines to the displayScanner for display"

	| cursorPosition delimiter oppositePos rect previousOppositeBlock |
	cursorPosition := self paragraph pointIndex.
	cursorPosition ifNil: [ ^ self ].
	cursorPosition < 2
		ifTrue: [ ^ self ].
	(self closingDelimiters includes: (delimiter := self paragraph string at: cursorPosition - 1))
		ifFalse: [ 
			(self openingDelimiters includes: (delimiter := self paragraph string at: cursorPosition - 1))
				ifFalse: [ ^ self ] ].
	oppositePos := self positionOfOppositeDelimiter: delimiter startingAt: cursorPosition in: anAthensCanvas clipRect.
	oppositePos = 0
		ifTrue: [ ^ self ].
	previousOppositeBlock := self characterBlockForIndex: oppositePos.
	rect := previousOppositeBlock.
	rect privateSetCorner: (rect corner min: anAthensCanvas clipRect bottomRight) + (0 @ 1).
	rect privateSetOrigin: rect origin.
	anAthensCanvas setPaint: RubTextSelectionColor oppositeDelimiterSelection backgroundColor.
	anAthensCanvas setShape: rect surface expanded.
	anAthensCanvas draw.
	anAthensCanvas setShape: (rect surface insetBy: 0.5).
	(anAthensCanvas setStrokePaint: Color black)
		width: 1.
	anAthensCanvas draw.
! !

!RubOpeningClosingDelimiterDecorator class methodsFor: 'querying' stamp: ''!
key
	^ #openingClosingDelimitersHighlight! !

!RubParagraph commentStamp: ''!
I represent a paragraph of a text area!
!RubParagraph methodsFor: 'drawing' stamp: ''!
forLinesIn: aVisibleRect do: aBlock
	(self lineIndexForPoint: aVisibleRect topLeft) to: 
	(self lineIndexForPoint: aVisibleRect bottomRight) do: 
		[:i | aBlock value: (self lines at: i) ]! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
selectionStop
	^ textArea selectionStop! !

!RubParagraph methodsFor: 'querying' stamp: ''!
decoratorNamed: aKey
	^ nil! !

!RubParagraph methodsFor: 'editing' stamp: ''!
replaceFrom: start to: stop with: aText displaying: displayBoolean 
	"Edit the text, and then recompose the lines." 
	self composer replaceFrom: start to: stop with: aText.
! !

!RubParagraph methodsFor: 'geometry updating' stamp: ''!
extentFromClientBottomRight: aPoint
	| w newExtent |
	self wrapped
		ifFalse: [ ^ self extent ].
	newExtent := aPoint.
	w := newExtent x max: self minimumExtent x.
	self container: (self container topLeft extent: (w @ newExtent y) truncated).
	self compose.
	^ newExtent x @ self extent y! !

!RubParagraph methodsFor: 'querying' stamp: ''!
lastNonBlankCharacterBlockInLine: aLine
	| idx str blanks |
	idx := aLine last.
	str := self text string.
	blanks := { Character space. Character tab. Character cr. Character lf }.
	[ idx >= aLine first ]
		whileTrue: [ 
			(blanks includes: (str at: idx))
				ifFalse: [ ^ self characterBlockForIndex: idx ].
			idx := idx - 1 ].
	^ self characterBlockForIndex: aLine first ! !

!RubParagraph methodsFor: 'composition' stamp: ''!
forceCompose
	self uptodateComposer prepareToForceComposition.
	self compose! !

!RubParagraph methodsFor: 'drawing' stamp: ''!
displayTextOnAthensCanvas: anAthensCanvas in: aRectangle
	| athensDisplayScanner offset leftInRun |
	anAthensCanvas clipBy: aRectangle during:[
	anAthensCanvas pathTransform
		restoreAfter: [ 
			offset := aRectangle topLeft - self position.
			athensDisplayScanner := AthensDisplayScanner for: self on: anAthensCanvas.
			leftInRun := 0.
			self
				forLinesIn: anAthensCanvas clipRect
				do: [ :line | 
					line first <= line last
						ifTrue: [ leftInRun := athensDisplayScanner displayLine: line offset: offset leftInRun: leftInRun ] ] ] ]! !

!RubParagraph methodsFor: 'geometry updating' stamp: ''!
moveBy: aPoint
	container := container translateBy: aPoint.
	self composer moveBy: aPoint.
	textArea recomputeSelection.
	textArea invalidRect: (self position extent: self extent)
! !

!RubParagraph methodsFor: 'querying' stamp: ''!
hasDecoratorNamed: aKey
	^ false! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
paragraph
	^ self! !

!RubParagraph methodsFor: 'querying' stamp: ''!
totalTextHeight

	^self lines last bottom! !

!RubParagraph methodsFor: 'drawing' stamp: ''!
disableDrawingWhile: aBlock
	self drawingEnabled ifFalse: [ ^ aBlock value ].
	self disableDrawing.
	aBlock
		ensure: [ self enableDrawing ]! !

!RubParagraph methodsFor: 'accessing - composer' stamp: ''!
uptodateComposer
	^ self composer
		text: self text;
		textStyle: self textStyle;
		container: self compositionRectangle;
		emphasisHere: textArea emphasisHere;
		cursorWidth: textArea cursorWidth;
		yourself! !

!RubParagraph methodsFor: 'accessing - composer' stamp: ''!
newComposer
	^ RubTextComposer new ! !

!RubParagraph methodsFor: 'geometry updating' stamp: ''!
updateClientExtent
	textArea updateExtentFromParagraph.
! !

!RubParagraph methodsFor: 'drawing' stamp: ''!
enableDrawing
	drawingEnabled := true! !

!RubParagraph methodsFor: 'private' stamp: ''!
defaultEmptyText
	^ Text string: '' attributes: (Array with: self defaultFontChange)! !

!RubParagraph methodsFor: 'composition' stamp: ''!
compose
	self
		disableDrawingWhile: [ 
			self uptodateComposer 
				composeLinesFrom: 1
				to: self text size
				delta: 0
				into: OrderedCollection new
				priorLines: Array new
				atY: self compositionRectangle top.
			textArea ifNotNil: [ textArea paragraphWasComposedFrom: 1 to: self text size ] ]! !

!RubParagraph methodsFor: 'querying' stamp: ''!
firstLineCharacterIndexFromCharacterIndex: anIndex
	^ (self lines at: (self lineIndexOfCharacterIndex: anIndex)) first! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
tabWidth
	^ self textStyle rubTabWidth! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
model
	^ textArea model! !

!RubParagraph methodsFor: 'private' stamp: ''!
aboutToBeUnplugged! !

!RubParagraph methodsFor: 'querying' stamp: ''!
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."

	^ self composer indentationOfLineIndex: lineIndex ifBlank: aBlock! !

!RubParagraph methodsFor: 'geometry updating' stamp: ''!
adjustRightX
	| shrink |
	shrink := self container right - self maxRightX.
	self lines do: [ :line | line paddingWidth: (line paddingWidth - shrink)].
	self container: (self container withRight: self maxRightX)! !

!RubParagraph methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	drawingEnabled := true.
! !

!RubParagraph methodsFor: 'accessing - composer' stamp: ''!
maxRightX
	^ self composer maxRightX! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
text: aText
	(aText string notEmpty and: [aText runs isEmpty]) 
		ifTrue: [ aText runs: (Array with: self defaultFontChange) ].
	text := aText! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
next 
	^nil! !

!RubParagraph methodsFor: 'querying' stamp: ''!
key
	^self class key! !

!RubParagraph methodsFor: 'accessing - composer' stamp: ''!
numberOfPhysicalLines

	^ self composer numberOfPhysicalLines! !

!RubParagraph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: aCanvas bounds: aRectangle color: aColor
	aCanvas setPaint: aColor.
	self displayTextOnAthensCanvas: aCanvas in: aRectangle! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
scrollPane
	^ textArea scrollPane! !

!RubParagraph methodsFor: 'copying' stamp: ''!
copy

	^ self error: 'A ParagraphHandler should never be copied'.! !

!RubParagraph methodsFor: 'copying' stamp: ''!
deepCopy
	"Don't want to copy the container (etc) or fonts in the TextStyle."

	^ self error: 'A ParagraphHandler should never be deep copied'.! !

!RubParagraph methodsFor: 'geometry' stamp: ''!
extent
	self actualWidth ifNil: [ ^ self minimumExtent ].
	"lines empty check as workaround: lots of crashes on the CI, see github case 3879"
	self lines ifEmpty: [ ^ self minimumExtent ].
	^ (self actualWidth + self margins left + self margins right) @
			(self lines last bottom - self lines first top + self margins top + self margins bottom)! !

!RubParagraph methodsFor: 'editing' stamp: ''!
actionAttributesUnder: aClickPoint event: anEvent do: aBlock
	|startBlock|
	
	startBlock := self characterBlockAtPoint: aClickPoint.
	(self text attributesAt: startBlock stringIndex forStyle: self textStyle) 
		select: [ :attribute| attribute rubMayActOnEvent: anEvent ]
		thenDo: [:attribute | | range boxes| 
			"find the boxes for the current attribute range"
			range := self text rangeOf: attribute startingAt: startBlock stringIndex.
			boxes := self selectionRectsFrom: (self characterBlockForIndex: range first) 
						to: (self characterBlockForIndex: range last+1).
			boxes detect: [:each | each containsPoint: aClickPoint] ifFound: [ aBlock cull: attribute cull: boxes ]]! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
closingDelimiters
	^ textArea closingDelimiters
! !

!RubParagraph methodsFor: 'querying' stamp: ''!
defaultCharacterBlock
	^ (RubCharacterBlock new
		stringIndex: 1
		topLeft: self lines first topLeft
		extent: 0 @ 0) textLine: self lines first! !

!RubParagraph methodsFor: 'mock selection' stamp: ''!
selection
	^ self textArea selection! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
theme
	^ UITheme current! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
margins
	^textArea margins.
! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
textArea
	^ textArea! !

!RubParagraph methodsFor: 'initialization' stamp: ''!
unplug
	self releaseComposer.
	textArea := nil.
	text := nil.
	super unplug! !

!RubParagraph methodsFor: 'geometry' stamp: ''!
width
	^  self wrapped
		ifTrue: [ self container right  -  (self container insetBy: self margins) topLeft x]
		ifFalse: [ RubAbstractTextArea defaultMaxExtent ]! !

!RubParagraph methodsFor: 'drawing' stamp: ''!
drawingEnabled
	^ drawingEnabled ifNil: [ drawingEnabled := true ]! !

!RubParagraph methodsFor: 'accessing - composer' stamp: ''!
lines
	^ self composer lines! !

!RubParagraph methodsFor: 'querying' stamp: ''!
hasDecorator: aDecorator
	^ false! !

!RubParagraph methodsFor: 'drawing' stamp: ''!
disableDrawing
	drawingEnabled := false! !

!RubParagraph methodsFor: 'mock selection' stamp: ''!
findRegex
	^ nil! !

!RubParagraph methodsFor: 'accessing - composer' stamp: ''!
numberOfLines

	^ self lines size! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
position
	^ container topLeft! !

!RubParagraph methodsFor: 'private' stamp: ''!
defaultFontChange
	^ (TextFontChange fontNumber: self textStyle defaultFontIndex)! !

!RubParagraph methodsFor: 'querying' stamp: ''!
lastLineCharacterIndexFromCharacterIndex: anIndex
	| targetLine |
	targetLine := self lines at: (self lineIndexOfCharacterIndex: anIndex).
	^ targetLine = self lines last
		ifTrue: [ targetLine last + 1 ]
		ifFalse: [ targetLine last ]! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
tabWidth: anInteger
	| newTextStyle tabsArray |
	newTextStyle := self textStyle copy.
	tabsArray := (anInteger to: 99999 by: anInteger) asArray.
	newTextStyle privateTabsArray: tabsArray.
	self textArea privateSetTextStyle: newTextStyle.
	self releaseComposer.
	self compose.
	self textArea recomputeSelection; changed! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
textArea: aClient
	"Classically, the client is a Morph which holds the text, the textstyle, the textColor.
	client must never be nil except when I'm released"
	textArea := aClient ! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
textStyle
	^ textArea textStyle! !

!RubParagraph methodsFor: 'accessing - composer' stamp: ''!
actualWidth
	^ self composer actualWidth! !

!RubParagraph methodsFor: 'editing' stamp: ''!
replaceFrom: start to: stop with: aText
	"Edit the text, and then recompose the lines."

	self
		disableDrawingWhile: [ 
			self composer emphasisHere: textArea emphasisHere.
			self composer replaceFrom: start to: stop with: aText.
			self text: self composer text.
			textArea paragraphWasComposedFrom: start to: stop.
			textArea paragraphReplacedTextFrom: start to: stop with: aText ]! !

!RubParagraph methodsFor: 'querying' stamp: ''!
lineIndexOfCharacterIndex: characterIndex 
	"Answer the line index for a given characterIndex."
	"apparently the selector changed with NewParagraph"
	^ self composer lineIndexOfCharacterIndex: characterIndex
! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
string
	^ self text string! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
withoutDecorator
	^ self
! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
selectionStart
	^ textArea selectionStart! !

!RubParagraph methodsFor: 'composition' stamp: ''!
recomposeFrom: start to: stop delta: delta
	self
		disableDrawingWhile: [ 	self composer recomposeFrom: start to: stop delta: delta ]! !

!RubParagraph methodsFor: 'querying' stamp: ''!
characterBlockAtPoint: aPoint 
	"Answer a CharacterBlock for the character in the text at aPoint."
	| line |
	line := self lines at: (self lineIndexForPoint: aPoint).
	^ (RubCharacterBlockScanner new text: self text textStyle: self textStyle)
		characterBlockAtPoint: aPoint index: nil
		in: line! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
container: atextContainerOrRectangle
	container := atextContainerOrRectangle.
! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
selectionRectsFrom: characterBlock1 to: characterBlock2
	"Return an array of rectangles representing the area between the two character blocks given as arguments."

	| line1 line2 cb1 cb2 |
	characterBlock1 = characterBlock2
		ifTrue: [ ^ #() ].
	characterBlock1 <= characterBlock2
		ifTrue: [ 
			cb1 := characterBlock1.
			cb2 := characterBlock2 ]
		ifFalse: [ 
			cb2 := characterBlock1.
			cb1 := characterBlock2 ].
	line1 := self lineIndexOfCharacterIndex: cb1 stringIndex.
	line2 := self lineIndexOfCharacterIndex: cb2 stringIndex.
	line1 = line2
		ifTrue: [ ^ Array with: (cb1 topLeft corner: cb2 bottomRight) ].
	^ Array
		streamContents: [ :strm | 
			| last |
			strm nextPut: (last := cb1 topLeft corner: (self lines at: line1) bottomRight).
			line1 + 1 to: line2 - 1 do: [ :i | 
				| line |
				line := self lines at: i.
				(line left = last left and: [ line right = last right ])
					ifTrue: [ 
						"new line has same margins as old one -- "
						"merge them, so that the caller gets as few rectangles as possible"
						last privateSetCorner: last right @ line bottom ]
					ifFalse: [ 
						"differing margins; cannot merge"
						strm nextPut: (last := line rectangle) ] ].
			strm nextPut: ((self lines at: line2) topLeft corner: cb2 bottomLeft) ]! !

!RubParagraph methodsFor: 'querying' stamp: ''!
lineIndexForPoint: aPoint
	"Answer the index of the line in which to select the character nearest to aPoint."
	^ self composer lineIndexForPoint: aPoint! !

!RubParagraph methodsFor: 'private' stamp: ''!
releaseComposer
	composer
		ifNotNil: [ :c | 
			c unplug.
			composer := nil ]! !

!RubParagraph methodsFor: 'querying' stamp: ''!
characterBlockForIndex: index 
	"Answer a CharacterBlock for the character in text at index."
	| line |
	line := self lines at: (self lineIndexOfCharacterIndex: index).
	^ (RubCharacterBlockScanner new text: self text textStyle: self textStyle)
		characterBlockAtPoint: nil index: ((index max: line first) min: self text size+1)
		in: line! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
selectionRects
	"Return an array of rectangles representing the selection region."

	^ self selectionStart
		ifNil: [ Array new ]
		ifNotNil: [ self selectionRectsFrom: self selectionStart to: self selectionStop ]! !

!RubParagraph methodsFor: 'geometry updating' stamp: ''!
adjustBottomY
	| heights  bottomY verticalSize |
	heights := self lines collect: [ :each | each lineHeight ].
	verticalSize := heights sum.
	bottomY := self container top + verticalSize.
	self container: (self container withBottom: bottomY truncated).! !

!RubParagraph methodsFor: 'composition' stamp: ''!
compositionRectangle
	| e tl |
	e := self compositionExtent.
	tl := (self container insetBy: self margins) topLeft.
	^ tl corner: (tl x + e x - self margins right - (self margins left max: self cursorWidth)) @ e y! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
cursorWidth
	^ textArea cursorWidth
! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
wrapped
	^ textArea wrapped! !

!RubParagraph methodsFor: 'composition' stamp: ''!
compositionExtent
	"Return the bounds for composing this text.  There are two cases:
	1.  wrapped is true -- grow downward as necessary,
	2.  wrapped is false -- grow in 2D as nexessary."

	^ (self wrapped
		ifTrue: [ self container width @ RubAbstractTextArea defaultMaxExtent ]
		ifFalse: [ RubAbstractTextArea defaultMaxExtent @ RubAbstractTextArea defaultMaxExtent ]) max: self minimumCompositionExtent! !

!RubParagraph methodsFor: 'geometry' stamp: ''!
minimumExtent
	^ textArea minimumExtent! !

!RubParagraph methodsFor: 'editing' stamp: ''!
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: [textArea]).
		(attribute actOnMove: anEvent for: target in: self editor: editor) == true 	
			ifTrue: [ ^ true ]].
	
	(action and: [ self currentWorld currentCursor == Cursor webLink]) 
		ifTrue:[ Cursor normal show ].
	
	^ action! !

!RubParagraph methodsFor: 'editing' stamp: ''!
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: [textArea]).
		(attribute rubActOnClick: anEvent for: target in: self editor: editor) == true 	
			ifTrue: [ ^ true ]].
	
	(action and: [ self currentWorld currentCursor == Cursor webLink]) 
		ifTrue:[ Cursor normal show ].
	
	^ action! !

!RubParagraph methodsFor: 'querying' stamp: ''!
verticesFrom: firstIndex to: lastIndex
	| firstCB lastCB firstLineIndex lastLineIndex firstLine lastLine vertices secondLine thirdLine |
	firstCB := self characterBlockForIndex: firstIndex.
	lastCB := self characterBlockForIndex: lastIndex.
	firstLineIndex := self lineIndexOfCharacterIndex: firstIndex.
	lastLineIndex := self lineIndexOfCharacterIndex: lastIndex.
	firstLine := self lines at: firstLineIndex.
	lastLine := self lines at: lastLineIndex.
	vertices := OrderedCollection new.
	firstLine = lastLine
		ifTrue: [ 
			vertices add: firstCB bottomLeft.
			vertices add: firstCB topLeft.
			firstIndex ~= lastIndex
				ifTrue: [ 
					vertices add: lastCB topLeft.
					vertices add: lastCB bottomLeft.
					vertices add: firstCB bottomLeft ] ]
		ifFalse: [ 
			secondLine := self lines at: firstLineIndex + 1.
			thirdLine := self lines at: lastLineIndex - 1.
			vertices add: firstCB bottomLeft - (1@0).
			vertices add: firstCB topLeft - (1@0).
			vertices add: (self textArea right - self margins right) @ firstLine top.
			vertices add: (self textArea right - self margins right) @ thirdLine bottom.
			vertices add: lastCB topLeft.
			vertices add: lastCB bottomLeft.
			vertices add: lastLine bottomLeft - (1@0).
			vertices add: secondLine topLeft - (1@0).
			vertices add: firstCB bottomLeft - (1@0)].
	^ vertices! !

!RubParagraph methodsFor: 'geometry updating' stamp: ''!
extentFromClientWidth: anInteger
	^ self extentFromClientBottomRight: (anInteger @ self extent y)! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
composer
	^ composer ifNil: [ composer := self newComposer ]! !

!RubParagraph methodsFor: 'querying' stamp: ''!
firstNonBlankCharacterBlockInLine: aLine
	| idx str blanks |
	idx := aLine first.
	str := self text string.
	blanks := { Character space. Character tab }.
	[ idx <= aLine last ]
		whileTrue: [ | c |
			c := str at: idx.
			(blanks includes: c)
				ifFalse: [ ^ self characterBlockForIndex: idx ].
			idx := idx + 1 ].
	^ self characterBlockForIndex: aLine last ! !

!RubParagraph methodsFor: 'composition' stamp: ''!
minimumCompositionExtent

	^ self minimumExtent x - self margins left @ self minimumExtent y! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
container
	^ container! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
openingDelimiters
	^ textArea openingDelimiters
! !

!RubParagraph methodsFor: 'accessing - text area' stamp: ''!
pointIndex
	^ textArea pointIndex! !

!RubParagraph methodsFor: 'querying' stamp: ''!
containsPoint: aPoint
	^ (self lines at: (self lineIndexForPoint: aPoint)) rectangle
		containsPoint: aPoint! !

!RubParagraph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas using: aDisplayScanner at: aPosition
	"Send all visible lines to the displayScanner for display"

	| offset leftInRun line visibleRectangle |
	self drawingEnabled
		ifFalse: [ ^ self ].
	visibleRectangle := aCanvas clipRect.
	offset := (aPosition - self position) truncated.
	leftInRun := 0.
	(self lineIndexForPoint: visibleRectangle topLeft) to: (self lineIndexForPoint: visibleRectangle bottomRight) do: [ :i | 
		line := self lines at: i.
		line first <= line last
			ifTrue: [ leftInRun := aDisplayScanner displayLine: line offset: offset leftInRun: leftInRun ] ]! !

!RubParagraph methodsFor: 'accessing' stamp: ''!
text
	^ text ifNil: [ text := self defaultEmptyText ]! !

!RubParagraph class methodsFor: 'querying' stamp: ''!
key
	^ nil! !

!RubParagraphDecorator commentStamp: ''!
I am a decorator for the paragraph of a text area. I can be used to draw something on the paragraph !
!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
text 

	^self paragraph text! !

!RubParagraphDecorator methodsFor: 'querying' stamp: ''!
decoratorNamed: aKey
	^ self key = aKey
		ifTrue: [ self ]
		ifFalse: [ next decoratorNamed: aKey ]! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
paragraph
	^next paragraph ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
moveBy: aPoint

	^self paragraph moveBy: aPoint ! !

!RubParagraphDecorator methodsFor: 'querying' stamp: ''!
hasDecoratorNamed: aKey
	^ self key = aKey or: [ next hasDecoratorNamed: aKey ]! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
disableDrawingWhile: aBlock
	^self paragraph disableDrawingWhile: aBlock! !

!RubParagraphDecorator methodsFor: 'accessing' stamp: ''!
visibleStringFrom: topLeft to: bottomRight
	| topLeftBlk bottomRightBlk startIdx stopIdx string  |
	topLeftBlk := self characterBlockAtPoint: topLeft.
	bottomRightBlk := self characterBlockAtPoint: bottomRight.
	startIdx := topLeftBlk stringIndex.
	stopIdx := bottomRightBlk stringIndex.
	string := self text string.
	^ self text string copyFrom: startIdx to: (stopIdx min: string size)
! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
compose 
	^self paragraph compose ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
model
	^self paragraph model ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
aboutToBeUnplugged 
	^self paragraph aboutToBeUnplugged ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
text: aText

	^self paragraph text: aText! !

!RubParagraphDecorator methodsFor: 'accessing' stamp: ''!
next
	^ next! !

!RubParagraphDecorator methodsFor: 'querying' stamp: ''!
key
	^self class key! !

!RubParagraphDecorator methodsFor: 'drawing' stamp: ''!
canDrawDecoratorsOn: aCanvas

	^self drawingEnabled and: [ 
		self selectionStart isNotNil and: [ 
			self selectionStop isNotNil
		]
	]
	! !

!RubParagraphDecorator methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: aCanvas bounds: aRectangle color: aColor

   (self canDrawDecoratorsOn: aCanvas) ifFalse: [ ^self ].

	self drawOnAthensCanvas: aCanvas.
	next drawOnAthensCanvas: aCanvas bounds: aRectangle color: aColor! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
numberOfPhysicalLines

	^self paragraph numberOfPhysicalLines! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
selection

	^self paragraph selection! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
extent 
	^self paragraph extent ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
closingDelimiters

	^self paragraph closingDelimiters! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
defaultCharacterBlock 
	^self paragraph defaultCharacterBlock ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
theme

	^self paragraph theme! !

!RubParagraphDecorator methodsFor: 'initialization' stamp: ''!
unplug
	next
		ifNotNil: [ 
			next unplug.
			next := nil ].
	super unplug! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
margins

	^self paragraph margins! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
textArea

	^self paragraph textArea! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
drawingEnabled

	^self paragraph drawingEnabled! !

!RubParagraphDecorator methodsFor: 'querying' stamp: ''!
hasDecorator: aDecorator
	^ self = aDecorator or: [ next hasDecorator: aDecorator ]! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
lines 
	^self paragraph lines ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
numberOfLines 
	^self paragraph numberOfLines ! !

!RubParagraphDecorator methodsFor: 'error handling' stamp: ''!
doesNotUnderstand: aMessage
	^ [ aMessage sendTo: next ]
		on: MessageNotUnderstood
		do: [ super doesNotUnderstand: aMessage ]! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
defaultFontChange

	^self paragraph defaultFontChange! !

!RubParagraphDecorator methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	"do nothing"! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
tabWidth: anInteger

	^self paragraph tabWidth: anInteger! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
textArea: aClient

	^self paragraph textArea: aClient! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
textStyle

	^self paragraph textStyle! !

!RubParagraphDecorator methodsFor: 'accessing' stamp: ''!
next: anObject
	next := anObject! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
replaceFrom: start to: stop with: aText
	^self paragraph replaceFrom: start to: stop with: aText ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
lineIndexOfCharacterIndex: characterIndex 
	^self paragraph lineIndexOfCharacterIndex: characterIndex ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
string

	^self paragraph string! !

!RubParagraphDecorator methodsFor: 'accessing' stamp: ''!
withoutDecorator

	"for compatibility with the RubParagraph API"

	^ self paragraph
! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
selectionStart

	^self paragraph selectionStart! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
characterBlockAtPoint: aPoint

	^self paragraph characterBlockAtPoint: aPoint ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
container: atextContainerOrRectangle
	^self paragraph container: atextContainerOrRectangle ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
lineIndexForPoint: aPoint

	^self paragraph lineIndexForPoint: aPoint ! !

!RubParagraphDecorator methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"do nothing by default"! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
characterBlockForIndex: index
	^self paragraph characterBlockForIndex: index! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
selectionRects

	^self paragraph selectionRects! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
verticesFrom: firstIndex to: lastIndex

	^self paragraph verticesFrom: firstIndex to: lastIndex! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
minimumExtent

	^self paragraph minimumExtent! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
move: anEvent for: model controller: editor

	^self paragraph move: anEvent for: model controller: editor! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
click: anEvent for: model controller: editor

	^self paragraph click: anEvent for: model controller: editor! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
container
	^self paragraph container ! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
openingDelimiters

	^self paragraph openingDelimiters! !

!RubParagraphDecorator methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas using: aDisplayScanner at: aPosition

	(self canDrawDecoratorsOn: aCanvas) ifFalse: [ ^self ].
	
	self drawOn: aCanvas.
	next drawOn: aCanvas using: aDisplayScanner at: aPosition! !

!RubParagraphDecorator methodsFor: 'delegating' stamp: ''!
selectionStop

	^self paragraph selectionStop! !

!RubParagraphDecorator class methodsFor: 'querying' stamp: ''!
key
	^ self subclassResponsibility ! !

!RubParagraphDecorator class methodsFor: 'instance creation' stamp: ''!
next: aDecoratorOrAParagraph
	^ self new next: aDecoratorOrAParagraph ! !

!RubParagraphDecorator class methodsFor: 'querying' stamp: ''!
classOfDecoratorNamed: aKey 
	^ self allSubclasses detect: [ :cls | cls key = aKey ] ifNone: [  ]! !

!RubParagraphDecorator class methodsFor: 'testing' stamp: ''!
isUsed
	"all my subclasses might be used via #classOfDecoratorNamed:"
	^self name = 'RubParagraphDecorator'
		ifTrue: [ super isUsed ]
		ifFalse: [ true ]! !

!RubPlainSegmentMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	^ Color yellow
! !

!RubPlainSegmentMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^ Color yellow alpha: 0.5.
! !

!RubPlainTextMode commentStamp: ''!
I represent the mode to use to edit plain text (in menus, help browser etc)!
!RubPlainTextMode methodsFor: 'text area alignment' stamp: ''!
justified 
	self changeAlignment: #justified! !

!RubPlainTextMode methodsFor: 'text area emphasis' stamp: ''!
narrow
	
	self changeEmphasis: #narrow! !

!RubPlainTextMode methodsFor: 'text area attribute' stamp: ''!
changeAttribute: anAttribute
	"Change a TextAttribute  of the receiver. Emphasis, alignment..."

	self textArea
		beEditableWhile: [ 
			self textArea
				restoreSelectionIndexesAfter: [ 
					self textArea selectAll.
					self editor applyAttribute: anAttribute ] ].
	self textArea changed! !

!RubPlainTextMode methodsFor: 'text area emphasis' stamp: ''!
italic
	
	self changeEmphasis: #italic! !

!RubPlainTextMode methodsFor: 'text area alignment' stamp: ''!
changeAlignment: aSymbol
	"Change the alignment of the receiver. Alignment can be #leftFlush #centered #rightFlush #justified "
	self changeAttribute: (TextAlignment perform: aSymbol)! !

!RubPlainTextMode methodsFor: 'text area font' stamp: ''!
fontName: fontName pointSize: pointSize
	| newTextStyle |
	(LogicalFontManager current allFamilies detect: [ :f | f familyName = fontName ] ifNone: [  ])
		ifNotNil: [ :fam | 
			| style font |
			style := fam members detect: [ :m | m styleName = 'Regular' ].
			font := style asLogicalFontOfPointSize: pointSize.
			newTextStyle := font textStyle ]
		ifNil: [ newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy ].
	self textArea privateTextStyle: newTextStyle.
	self textArea addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfPointSize: pointSize))! !

!RubPlainTextMode methodsFor: 'text area font' stamp: ''!
beAllFont: aFont
	self textArea font: aFont! !

!RubPlainTextMode methodsFor: 'text area emphasis' stamp: ''!
bold
	
	self changeEmphasis: #bold! !

!RubPlainTextMode methodsFor: 'text area emphasis' stamp: ''!
struckOut
	
	self changeEmphasis: #struckOut! !

!RubPlainTextMode methodsFor: 'text area font' stamp: ''!
fontName: fontName size: pointSize
	| newTextStyle |
	(LogicalFontManager current allFamilies detect: [ :f | f familyName = fontName ] ifNone: [  ])
		ifNotNil: [ :fam | 
			| style font |
			style := fam members detect: [ :m | m styleName = 'Regular' ].
			font := style asLogicalFontOfPointSize: pointSize.
			newTextStyle := font textStyle ]
		ifNil: [ newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy ].
	self textArea privateTextStyle: newTextStyle.
	self addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfSize: pointSize))! !

!RubPlainTextMode methodsFor: 'text area alignment' stamp: ''!
centered 
	self changeAlignment: #centered! !

!RubPlainTextMode methodsFor: 'text area emphasis' stamp: ''!
normal
	
	self changeEmphasis: #normal! !

!RubPlainTextMode methodsFor: 'text area alignment' stamp: ''!
leftFlush 

	self changeAlignment: #leftFlush
! !

!RubPlainTextMode methodsFor: 'text area alignment' stamp: ''!
rightFlush 
	
	self changeAlignment: #rightFlush
! !

!RubPlainTextMode methodsFor: 'text area font' stamp: ''!
fontPointSize: pointSize
	self textArea addAttribute: (TextFontChange fontNumber: (self textStyle fontIndexOfPointSize: pointSize))! !

!RubPlainTextMode methodsFor: 'text area emphasis' stamp: ''!
changeEmphasis: aSymbol
	"Change the alignment of the receiver. Alignment can be #normal, #bold,  #italic, #narrow, #underlined, or #struckOut"

	self changeAttribute: (TextEmphasis perform: aSymbol)
! !

!RubPlainTextMode methodsFor: 'text area emphasis' stamp: ''!
underlined
	
	self changeEmphasis: #underlined! !

!RubPlainTextMode class methodsFor: 'menu' stamp: ''!
menuOn: aBuilder
	"Specify the menu used when writing text. Try it with:
	(PragmaMenuBuilder 
		pragmaKeyword: 'RubPlainTextMenu'
		model: RubEditingArea new) menu popUpInWorld" 

	<contextMenu>
	<RubPlainTextMenu>
	
	(aBuilder item: #'Find...' translated)
		keyText: 'f';
		selector: #find;
		iconName: #smallFindIcon.
	(aBuilder item: #'Find again' translated)
		keyText: 'g';
		selector: #findAgain;
		iconName: #smallFindIcon.
	(aBuilder item: #'Set search string' translated)
		keyText: 'h';
		selector: #setSearchString.
	aBuilder model canChangeText
		ifTrue: [ 
			(aBuilder item: #Undo translated)
				keyText: 'z';
				selector: #undo;
				iconName: #smallUndoIcon;
				withSeparatorAfter.
			self fontMenuOn: aBuilder ].
	(aBuilder item: #Copy translated)
		keyText: 'c';
		selector: #copySelection;
		iconName: #smallCopyIcon.
	aBuilder model canChangeText
		ifTrue: [ 
			(aBuilder item: #Cut translated)
				keyText: 'x';
				selector: #cut;
				iconName: #smallCutIcon.
			(aBuilder item: #Paste translated)
				keyText: 'v';
				selector: #paste;
				iconName: #smallPasteIcon.
			(aBuilder item: #'Paste Recent' translated)
				selector: #pasteRecent;
				iconName: #smallCopyIcon;
				withSeparatorAfter.
			(aBuilder model model notNil and: [ aBuilder model acceptAllowed ])
				ifTrue: [ 
					(aBuilder item: #Accept translated)
						keyText: 's';
						selector: #accept;
						iconName: #smallOkIcon.
					(aBuilder item: #Cancel translated)
						keyText: 'l';
						selector: #cancel;
						iconName: #smallCancelIcon ] ]! !

!RubPlainTextMode class methodsFor: 'menu' stamp: ''!
editingModeMenuOn: aBuilder
	"Specify the menu used to select an editing mode"

	<contextMenu>
	<RubEditingModeMenu>
	(aBuilder item: self label translated)
		action: [:model | model textArea editingMode: self new ]! !

!RubPlainTextMode class methodsFor: 'menu' stamp: ''!
fontMenuOn: aBuilder
	"Specify the menu used when writing text. Try it with:
	(PragmaMenuBuilder 
		pragmaKeyword: 'RubTextEditorShiftedMenu'
		model: nil) menu popUpInWorld"

	(aBuilder item: #'fontItems')
		label: 'Font...';
		withSeparatorAfter;
		with: [ 
					(aBuilder item: #'Set font...' translated)
						keyText: 'k';
						selector: #offerFontMenu.
					(aBuilder item: #'Set alignment...' translated)
						selector: #chooseAlignment;
						withSeparatorAfter ]! !

!RubPlainTextMode class methodsFor: 'menu' stamp: ''!
menuKeyword
	^ 'RubPlainTextMenu'! !

!RubPlainTextMode class methodsFor: 'accessing' stamp: ''!
label
	^ 'Plain text'! !

!RubPluggableGetMenuPolicy commentStamp: ''!
I am used to get the correct menu of common text areas!
!RubPluggableGetMenuPolicy methodsFor: 'accessing' stamp: ''!
getMenuSelector: aSymbol
	getMenuSelector := aSymbol! !

!RubPluggableGetMenuPolicy methodsFor: 'accessing - menu' stamp: ''!
lookupMenu
	(getMenuSelector isNil or: [ menuProvider isNil ])
		ifTrue: [ ^ super lookupMenu ].
	^ (WeakMessageSend receiver: menuProvider selector: getMenuSelector) cull: MenuMorph new cull: false! !

!RubPluggableGetMenuPolicy methodsFor: 'accessing' stamp: ''!
menuProvider: anObject
	menuProvider := anObject! !

!RubPluggableGetMenuPolicy methodsFor: 'accessing' stamp: ''!
menuProvider
	^ menuProvider! !

!RubPluggableGetMenuPolicy methodsFor: 'accessing' stamp: ''!
getMenuSelector
	^ getMenuSelector! !

!RubPluggableGetMenuPolicy methodsFor: 'accessing - menu' stamp: ''!
lookupShiftMenu
	(getMenuSelector isNil or: [ menuProvider isNil ])
		ifTrue: [ ^ super lookupMenu ].
	^ (WeakMessageSend receiver: menuProvider selector: getMenuSelector) cull: MenuMorph new cull: true! !

!RubPluggableTextFieldMorph commentStamp: ''!
This class was introduced to ease the migration to Rubric.
Thus, I''am a replacement for compatibility with old PluggableTextFieldMorph.
It is still partly based on change/update.
Do not use this class for new developments since it will be deprecated asap.
Use RubTextFieldMorph instead
!
!RubPluggableTextFieldMorph methodsFor: 'model protocol' stamp: ''!
model: anObject
	super model: anObject.
	anObject addDependent: self.
	anObject addDependent: self textArea! !

!RubPluggableTextFieldMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"Eventually draw the helpText"
	super drawOnAthensCanvas: anAthensCanvas.
	entryCompletion 
		ifNotNil: [entryCompletion closeIfNotNeeded: self].! !

!RubPluggableTextFieldMorph methodsFor: 'accessing' stamp: ''!
crAction: aMessageSend
	crAction := aMessageSend! !

!RubPluggableTextFieldMorph methodsFor: 'accessing - text' stamp: ''!
getTextFromModel

	| newObj |

	newObj := self model perform: self getTextSelector withEnoughArguments: {self}.
	( newObj isNil and: [ self converter isNil ] )
		ifTrue: [ ^ Text new ].
	self converter ifNil: [ self convertTo: String ].
	^ ( self converter objectAsString: newObj ) ifNil: [ '' ] ifNotNil: [ :s | s shallowCopy ]! !

!RubPluggableTextFieldMorph methodsFor: 'accessing' stamp: ''!
changedAction: aBlock
	changedAction := aBlock! !

!RubPluggableTextFieldMorph methodsFor: 'updating' stamp: ''!
update: aSymbol
	aSymbol ifNil: [ ^ self ].
	aSymbol == #flash
		ifTrue: [ ^ self flash ].
	(aSymbol == self getColorSelector)
		ifTrue: [^ self backgroundColor: self getBackgroundColorFromModel ].
	aSymbol == self getTextSelector
		ifTrue: [ self updateTextWith: self getTextFromModel.
			^ self setSelection: self getSelectionFromModel ].
	aSymbol == self getSelectionSelector
		ifTrue: [ ^ self setSelection: self getSelectionFromModel ].
	aSymbol == #clearUserEdits
		ifTrue: [ ^ self hasUnacceptedEdits: false ].
	aSymbol == #wantToChange
		ifTrue: [ self canDiscardEdits
				ifFalse: [ ^ self promptForCancel ].
			^ self ].
	aSymbol == #clearText
		ifTrue: [ self textArea handleEdit: [ self updateTextWith: Text new ].
			^ self ].
	aSymbol == #bs
		ifTrue: [ self handleEdit: [ self updateTextWith: (self text copyFrom: 1 to: (self text size - 1 max: 0)) ].
			^ self ].
	aSymbol == #codeChangedElsewhere
		ifTrue: [ self hasEditingConflicts: true.
			^ self ].
	aSymbol == self getEnabledSelector
		ifTrue: [ self updateEnabled ].
	^ self! !

!RubPluggableTextFieldMorph methodsFor: 'model protocol' stamp: ''!
acceptTextInModel
	"Inform the model that the receiver's textArea text should be accepted.
	Answer true if the model accepted ok, false otherwise"
	| objectToAccept text result |
	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]]].
	result := setTextSelector isNil
		or: [setTextSelector numArgs = 2
				ifTrue: [self model
						perform: setTextSelector
						with: objectToAccept
						with: self]
				ifFalse: [self model perform: setTextSelector with: objectToAccept]].
	result == true ifTrue: [ self closeChooser ].
	^ result
! !

!RubPluggableTextFieldMorph methodsFor: 'event handling' stamp: ''!
textChanged
	super textChanged.
	self checkTextWithConverter.
	changedAction ifNotNil: [changedAction value: self getText ].! !

!RubPluggableTextFieldMorph methodsFor: 'set and get' stamp: ''!
setTextAndAccept: aText 
	
	self 
		setText: aText;
		hasUnacceptedEdits: true;
		accept! !

!RubPluggableTextFieldMorph methodsFor: 'updating' stamp: ''!
updateEnabled
	"Update the enablement state."

	self model ifNotNil: [
		self getEnabledSelector ifNotNil: [
			self enabled: (self model perform: self getEnabledSelector)]]! !

!RubPluggableTextFieldMorph methodsFor: 'accessing' stamp: ''!
getColorSelector
	^ self getBackgroundColorSelector ! !

!RubPluggableTextFieldMorph methodsFor: 'accessing' stamp: ''!
converter
	"Answer the value of converter"

	^ converter! !

!RubPluggableTextFieldMorph methodsFor: 'accessing' stamp: ''!
default
	^ default! !

!RubPluggableTextFieldMorph methodsFor: 'accessing' stamp: ''!
getColorSelector: aSymbol
	self getBackgroundColorSelector: aSymbol.
	self update: self getColorSelector.! !

!RubPluggableTextFieldMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector
	"Answer the value of getEnabledSelector"

	^ getEnabledSelector! !

!RubPluggableTextFieldMorph methodsFor: 'model protocol' stamp: ''!
hasValidText
	"Return true if the text is valid with respect to the converter."

	self converter ifNil: [^ super hasValidText].
	self checkTextWithConverter.
	^ super hasValidText! !

!RubPluggableTextFieldMorph methodsFor: 'testing' stamp: ''!
checkTextWithConverter

	|string|
	self converter ifNil: [^ self].
	string := self text asString.
	(string isEmpty and: [self default notNil]) or: [
		hasValidText := self converter isStringValid: string]! !

!RubPluggableTextFieldMorph methodsFor: 'event handling' stamp: ''!
whenReturnEntered: anAnnouncement
	super whenReturnEntered: anAnnouncement.
	crAction ifNotNil: [ crAction cull: nil ]! !

!RubPluggableTextFieldMorph methodsFor: 'accessing' stamp: ''!
converter: anObject
	"Set the value of converter"

	converter := anObject! !

!RubPluggableTextFieldMorph methodsFor: 'accessing' stamp: ''!
default: anObject
	default := anObject! !

!RubPluggableTextFieldMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector: aSymbol
	"Answer the value of getEnabledSelector"

	getEnabledSelector := aSymbol! !

!RubPluggableTextFieldMorph methodsFor: 'model protocol' stamp: ''!
convertTo: aClass

	"Set the converter object class."

	self converter
		ifNil: [ self converter: ( ObjectStringConverter forClass: aClass ) ]
		ifNotNil: [ self converter objectClass: aClass ]! !

!RubPluggableTextFieldWithFloatConverterExample methodsFor: 'user interface' stamp: ''!
readMySelection: aSelection
	^ nil! !

!RubPluggableTextFieldWithFloatConverterExample methodsFor: 'accessing' stamp: ''!
myFloat
	^ myFloat ifNil: [ myFloat := 0.0 ]
! !

!RubPluggableTextFieldWithFloatConverterExample methodsFor: 'user interface' stamp: ''!
newScrolledText
	| st |
	st := (RubPluggableTextFieldMorph new
		on: self
		text: #myFloat
		accept: #myFloat:
		readSelection: #readMySelection:
		menu: #getMyMenu:)
		withGhostText: 'Enter a float number here';
		yourself.
	st convertTo: Float.
	st width: 300.
	^ st! !

!RubPluggableTextFieldWithFloatConverterExample methodsFor: 'menu' stamp: ''!
getMyMenu: aMenu
	^ nil! !

!RubPluggableTextFieldWithFloatConverterExample methodsFor: 'accessing' stamp: ''!
myFloat: aFloat
	myFloat := aFloat.
	aFloat traceCr.
	^true! !

!RubPluggableTextFieldWithFloatConverterExample methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer ifNil: [ announcer := Announcer new ]! !

!RubPluggableTextFieldWithFloatConverterExample class methodsFor: 'examples' stamp: ''!
exampleOpen
	| st |
	st := self new newScrolledText.
 	st openInWorld
! !

!RubPluggableTextMorph commentStamp: ''!
This class was introduced to ease the migration to Rubric.
Thus, I''am a replacement for compatibility with old PluggableTextMorph.
It is still partly based on change/update.
Do not use this class for new developments since it will be deprecated asap.
Use RubScrolledTextMorph instead
!
!RubPluggableTextMorph methodsFor: 'model protocol' stamp: ''!
on: aModel text: aGetTextSelector accept: aSetTextSelector readSelection: aReadSelectionSelector menu: aGetMenuSelector
	self getTextSelector: aGetTextSelector.
	self setTextSelector: aSetTextSelector.
	self getSelectionSelector: aReadSelectionSelector.
	aGetMenuSelector
		ifNil: [ self textArea forbidMenu ]
		ifNotNil: [ self menuProvider: aModel selector: aGetMenuSelector ].
	self on: aModel! !

!RubPluggableTextMorph methodsFor: 'accessing' stamp: ''!
getMenuSelector: aGetMenuSelector
	aGetMenuSelector
		ifNil: [ self textArea forbidMenu ]
		ifNotNil: [ self textArea allowMenu.
			self menuProvider: self model selector: aGetMenuSelector ]! !

!RubPluggableTextMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	hasUnacceptedEdits := false.
	hasEditingConflicts := false.
	askBeforeDiscardingEdits := true! !

!RubPluggableTextMorph methodsFor: 'updating' stamp: ''!
update: aSymbol
	aSymbol ifNil: [ ^ self ].
	aSymbol == #flash
		ifTrue: [ ^ self flash ].
	(aSymbol == self getColorSelector)
		ifTrue: [^ self backgroundColor: self getBackgroundColorFromModel ].
	aSymbol == self getTextSelector
		ifTrue: [ self updateTextWith: self getTextFromModel.
			^ self setSelection: self getSelectionFromModel ].
	aSymbol == self getSelectionSelector
		ifTrue: [ ^ self setSelection: self getSelectionFromModel ].
	aSymbol == #clearUserEdits
		ifTrue: [ ^ self hasUnacceptedEdits: false ].
	aSymbol == #wantToChange
		ifTrue: [ self canDiscardEdits
				ifFalse: [ ^ self promptForCancel ].
			^ self ].
	aSymbol == #appendEntry
		ifTrue:
			[ "Hack to manage the Transcript (Gloups) "
			self textArea
				handleEdit:
					[ "Knock off first half of text"
					self text size > self model characterLimit
						ifTrue: [ self textArea selectInvisiblyFrom: 1 to: self text size // 2.
							self textArea replaceSelectionWith: Text new ].	
					self appendText: self model contents asText ].
			^ self ].
	aSymbol == #clearText
		ifTrue: [ self textArea handleEdit: [ self updateTextWith: Text new ].
			^ self ].
	aSymbol == #bs
		ifTrue: [ self handleEdit: [ self updateTextWith: (self text copyFrom: 1 to: (self text size - 1 max: 0)) ].
			^ self ].
	aSymbol == #codeChangedElsewhere
		ifTrue: [ self hasEditingConflicts: true.
			^ self ].
	aSymbol == self getEnabledSelector
		ifTrue: [ self updateEnabled ].
	^ self! !

!RubPluggableTextMorph methodsFor: 'scrolling' stamp: ''!
disable
	self beReadOnly ! !

!RubPluggableTextMorph methodsFor: 'scrolling' stamp: ''!
enable
	self beEditable ! !

!RubPluggableTextMorph methodsFor: 'accessing' stamp: ''!
hasUnacceptedEdits: aBoolean
	"Set the hasUnacceptedEdits flag to the given value. "

	(self model respondsTo: #hasUnacceptedEdits:)
		ifTrue: [ self model hasUnacceptedEdits: aBoolean ]
		ifFalse: [ 
			super hasUnacceptedEdits: aBoolean.
			self changed ].
	aBoolean
		ifFalse: [ hasEditingConflicts := false ]! !

!RubPluggableTextMorph methodsFor: 'undo - redo' stamp: ''!
clearUndoManager
	self textArea editingState clearUndoManager: nil! !

!RubPluggableTextMorph methodsFor: 'accessing - scrollbars' stamp: ''!
scrollerOffsetChanged
	super scrollerOffsetChanged.
	self announcer
		announce:
			(PaneScrolling new
				step: self scrollPane hScrollbarValue @ self scrollPane vScrollbarValue;
				scrollPane: self scrollPane;
				yourself)! !

!RubPluggableTextMorph methodsFor: 'updating' stamp: ''!
updateEnabled
	"Update the enablement state."

	self model ifNotNil: [
		self getEnabledSelector ifNotNil: [
			self enabled: (self model perform: self getEnabledSelector)]]! !

!RubPluggableTextMorph methodsFor: 'accessing' stamp: ''!
getColorSelector
	^ self getBackgroundColorSelector ! !

!RubPluggableTextMorph methodsFor: 'accessing' stamp: ''!
getColorSelector: aSymbol
	self getBackgroundColorSelector: aSymbol.
	self update: self getColorSelector.! !

!RubPluggableTextMorph methodsFor: 'model protocol' stamp: ''!
model: anObject
	super model: anObject.
	anObject addDependent: self! !

!RubPluggableTextMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector
	"Answer the value of getEnabledSelector"

	^ getEnabledSelector! !

!RubPluggableTextMorph methodsFor: 'accessing - scrollbars' stamp: ''!
registerScrollChanges: aSelector

	self announcer 
		when: PaneScrolling 
		send: aSelector
		to: self model! !

!RubPluggableTextMorph methodsFor: 'accessing' stamp: ''!
promptForCancel
	"Ask for the appropriate action to take when unaccepted contents
	would be overwritten."

	| choice |
	choice := UIManager default
		confirm: 'Contents 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 acceptTextInModel.
					self basicHasUnacceptedEdits: false ]
				ifFalse: [ self model 
						ifNotNil: [ :m | m clearUserEditFlag ] 
						ifNil: [ self basicHasUnacceptedEdits: false ] ] ]! !

!RubPluggableTextMorph methodsFor: 'accessing' stamp: ''!
getEnabledSelector: aSymbol
	"Answer the value of getEnabledSelector"

	getEnabledSelector := aSymbol! !

!RubPluggableTextMorph methodsFor: 'model protocol' stamp: ''!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel setSelection: setSelectionSel
	self
		on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: getSelectionSel
		menu: getMenuSel.
	setSelectionSelector := setSelectionSel.
	self borderWidth: 1.
	self setText: self getTextFromModel.
	self setSelection: self getSelectionFromModel! !

!RubPluggableTextMorph methodsFor: 'scrolling' stamp: ''!
styled: aBoolean
	aBoolean ifTrue: [ ^ self beForSmalltalkCode  ].
	self beForPlainText! !

!RubPluggableTextMorph class methodsFor: 'instance creation' stamp: ''!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel

	^ self new on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: getSelectionSel
		menu: getMenuSel
		setSelection: nil! !

!RubPluggableTextMorph class methodsFor: 'instance creation' stamp: ''!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel setSelection: setSelectionSel

	^ self new on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: getSelectionSel
		menu: getMenuSel
		setSelection: setSelectionSel! !

!RubPluggableTextMorphExample commentStamp: ''!
shows how to use a RubPluggableTextMorph.
see example class side!
!RubPluggableTextMorphExample methodsFor: 'source code area' stamp: ''!
accept: source notifying: aController
	| p result |
	self selectedClass ifNil: [ ^self ].
	p := self selectedClass organization protocolOrganizer protocolsOfSelector: self selector.
	p := p ifEmpty: [ Protocol unclassified ] ifNotEmpty: [p anyOne name].
	result := self selectedClass compile: source classified: p notifying: aController.
	result ifNotNil: [self changed: #clearUserEdits ].
	^ result! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
classIsMeta: aBoolean
	classIsMeta := aBoolean.
	self changed: #classIsMeta
! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
editSourceCode
	self changed: #getText! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
selectedClass
	| cls |
	cls := (Smalltalk globals at: (self selectedClassName getString ifEmpty: [ ^ nil ]) asSymbol ifAbsent: [ ^ nil ])
		instanceSide.
	^ self classIsMeta
		ifTrue: [ cls class ]
		ifFalse: [ cls ]! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
open
	| window editor clsMorph mthMorph |
	window := (StandardWindow labelled: 'Method editor with shout') model: self.
	editor := self newScrolledTextMorph.
	clsMorph := self classSelectorMorph.
	clsMorph announcer when: RubTextChanged send: #whenClassNameChanged: to: self.
	mthMorph := self methodSelectorMorph.
	mthMorph announcer when: RubTextChanged send: #whenMethodNameChanged: to: self.
	editor
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	window
		addMorph:
			(window
				newColumn:
					{(window
						newRow:
							{(clsMorph).
							(self metaSwitchMorph).
							(mthMorph).
							(self editButtonMorph )}).
					editor})
		fullFrame: LayoutFrame identity.
	^ window openInWorld! !

!RubPluggableTextMorphExample methodsFor: 'menu' stamp: ''!
codePaneMenu: aMenu shifted: shifted
	"Note that unless we override perform:orSendTo:, 
	PluggableTextController will respond to all menu items in a 
	text pane"
	"You should not use this way of getting menu. Because when you create a text area, you have a menu"

	| donorMenu |
	donorMenu := (PragmaMenuBuilder pragmaKeyword: RubSmalltalkCodeMode menuKeyword model: self) menu.
	^ aMenu addAllFrom: donorMenu! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
methodSelectorMorph
	^ self selectedMethodName newTextField
		withGhostText: 'Method name';
		autoAccept: true;
		hResizing: #spaceFill;
		yourself! !

!RubPluggableTextMorphExample methodsFor: 'events handling' stamp: ''!
whenMethodNameChanged: anAnnouncement
	self checkMethodName! !

!RubPluggableTextMorphExample methodsFor: 'edits' stamp: ''!
okToChange
	self canDiscardEdits
		ifTrue: [ ^ true ].
	^ self promptForCancel ! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
selectedClassName
	^ selectedClassName ifNil: [ selectedClassName := RubScrolledTextModel new ]! !

!RubPluggableTextMorphExample methodsFor: 'events handling' stamp: ''!
checkMethodName
	| conf |
	conf := RubConfigurationChange new.
	self selectedClass
		ifNil: [ conf configurationBlock: [ :textField | textField textColor: Color red ] ]
		ifNotNil: [ 
			conf
				configurationBlock: [ :textField | 
					(self selectedClass canUnderstand: self selectedMethodName getString asSymbol)
						ifFalse: [ textField textColor: Color red ]
						ifTrue: [ textField textColor: Color black ] ] ].
	self selectedMethodName announce: conf! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
metaSwitchMorph
	^ UIManager default
		newCheckboxFor: self
		getSelected: #classIsMeta
		setSelected: #classIsMeta:
		label: 'Class'
		help: 'Class side is used if checked' ! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
dragEnabled
	^ false! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
dropEnabled
	^ false! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
autoAccept
	"Answer whether the editor accepts its contents on each change."

	^ false! !

!RubPluggableTextMorphExample methodsFor: 'events handling' stamp: ''!
checkClassName
	| conf |
	conf := RubConfigurationChange new.
	self selectedClass
		ifNil: [ conf configurationBlock: [ :textField | textField textColor: Color red ] ]
		ifNotNil: [ conf configurationBlock: [ :textField | textField textColor: Color black ] ].
	self selectedClassName announce: conf! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	enabled = aBoolean ifTrue: [ ^self ].
	enabled := aBoolean.
	self changed: #enabled! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
getText
	^ self method ifNil: [''] ifNotNil: [:m | m sourceCode]! !

!RubPluggableTextMorphExample methodsFor: 'edits' stamp: ''!
promptForCancel
	"Ask for the appropriate action to take when unaccepted contents
	would be overwritten."

	| choice |
	choice := UIManager default
		confirm: 'Contents 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 changed: #getText.
					self changed: #clearUserEdits ]
				ifFalse: [ self changed: #clearUserEdits ] ].
	^ self canDiscardEdits! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
scrollValue: aPoint
	scrollValue := aPoint! !

!RubPluggableTextMorphExample methodsFor: 'edits' stamp: ''!
askBeforeDiscardingEdits
	^ false! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
scrollValueChanged: anAnnouncement 
	scrollValue := anAnnouncement step ! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
selectedMethodName
	^ selectedMethodName ifNil: [ selectedMethodName := RubScrolledTextModel new ]! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
classIsMeta
	^ classIsMeta ifNil: [ classIsMeta := false ]! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
help
	^ nil! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
method
	^ [ self selectedClass >> (self selectedMethodName getString ifEmpty: [ ^nil ]) asSymbol ] on: Error do: [  ]! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
readSelection
	^ selection! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
setSelection: anInterval
	selection := anInterval.
	self changed: #readSelection! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
selector
	^ self selectedMethodName getString asSymbol ! !

!RubPluggableTextMorphExample methodsFor: 'shout' stamp: ''!
shoutAboutToStyle: ARubricMode
	ARubricMode classOrMetaClass: self selectedClass.
	^ true! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
dropEnabled: aBoolean! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
enabled
	^ enabled ifNil: [ enabled := true ]! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
newScrolledTextMorph
	| st |
	st := RubPluggableTextMorph new
		on: self
			text: #getText
			accept: #accept:notifying:
			readSelection: #readSelection
			menu: nil
			setSelection: #setSelection:;
		getEnabledSelector: #enabled;
		askBeforeDiscardingEdits: self askBeforeDiscardingEdits;
		autoAccept: self autoAccept;
		setBalloonText: self help;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		registerScrollChanges: #scrollValueChanged:;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		yourself.
	st
		beWrapped;
		autoAccept: false;
		beForSmalltalkCode;
		withCodeSizeFeedback.
	^ st! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
classSelectorMorph
	^ self selectedClassName newTextField
		withGhostText: 'Class name';
		autoAccept: true;
		hResizing: #spaceFill;
		yourself! !

!RubPluggableTextMorphExample methodsFor: 'events handling' stamp: ''!
whenClassNameChanged: anAnnouncement
	self checkMethodName.
	self checkClassName ! !

!RubPluggableTextMorphExample methodsFor: 'view creation' stamp: ''!
editButtonMorph
	^ UIManager default
		newButtonFor: self
		action: #editSourceCode
		getEnabled: nil
		label: 'Edit'
		help: nil! !

!RubPluggableTextMorphExample methodsFor: 'accessing' stamp: ''!
behavior
	^ self selectedClass ! !

!RubPositionChanged commentStamp: ''!
I am raised when the left bounds of the text area are changed!
!RubPrimarySelectionMorph commentStamp: ''!
I represent the morph which shows the current selection !
!RubPrimarySelectionMorph methodsFor: 'accessing' stamp: ''!
selectionColor
	^ self textArea hasFocus
		ifTrue: [ self theme selectionColor ]
		ifFalse: [ self theme lessConspicuousColorFrom: (self theme unfocusedSelectionColor) ]! !

!RubPrimarySelectionMorph methodsFor: 'protocol - events' stamp: ''!
whenTextAreaLostFocus: anAnnouncement 
	self color: self selectionColor ! !

!RubPrimarySelectionMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self beExtendable! !

!RubPrimarySelectionMorph methodsFor: 'protocol - events' stamp: ''!
whenTextAreaGotFocus: anAnnouncement 
	self color: self selectionColor ! !

!RubPrimarySelectionMorph methodsFor: 'event handling' stamp: ''!
registerTextArea 
	super registerTextArea.
	
	textArea announcer 
	when:  RubSelectionChanged send: #whenTextAreaSelectionChanged: to: self;
	when:  MorphGotFocus send: #whenTextAreaGotFocus: to: self;	
	when:  MorphLostFocus send: #whenTextAreaLostFocus: to: self.	
! !

!RubPrimarySelectionMorph methodsFor: 'protocol - events' stamp: ''!
whenTextAreaSelectionChanged: anAnnouncement 
	firstIndex := self textArea markIndex min: self textArea pointIndex.
	lastIndex := self textArea pointIndex max: self textArea markIndex.
	self computeVertices.
	self announcer announce: RubTextSetInModel.
! !

!RubPrimarySelectionMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	^ Color orange
! !

!RubPrimarySelectionMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^ self theme selectionColor
! !

!RubPrimarySelectionMorph methodsFor: 'ui' stamp: ''!
readWriteView
	| view |
	view  := super readWriteView.
	^ view! !

!RubPrimarySelectionUpdatedInModel commentStamp: ''!
I am raised when the selection changes in the model side!
!RubReturnEntered commentStamp: ''!
I am raised when enter is pressed!
!RubReturnEntered methodsFor: 'accessing' stamp: ''!
accepted: aBoolean
	accepted := aBoolean! !

!RubReturnEntered methodsFor: 'accessing' stamp: ''!
accepted
	^ accepted ifNil: [ accepted := false ]! !

!RubScrollBar commentStamp: ''!
I am a scroll bar!
!RubScrollBar methodsFor: 'style' stamp: ''!
mouseOverThumbButtonFillStyle
	"Return the mouse over thumb fillStyle for the receiver."
	
	^(self theme scrollbarMouseOverThumbButtonFillStyleFor: self) asColor darker! !

!RubScrollBar methodsFor: 'style' stamp: ''!
normalThumbFillStyle
	"Return the normal thumb fillStyle for the receiver."
	
	^(self theme scrollbarNormalThumbFillStyleFor: self) asColor darker! !

!RubScrollBar methodsFor: 'style' stamp: ''!
pressedThumbFillStyle
	"Return the pressed thumb fillStyle for the receiver."
	
	^(self theme scrollbarPressedThumbFillStyleFor: self) asColor darker! !

!RubScrolledTextExtra commentStamp: ''!
RubScrolledTextExtra represents the root of rulers graphical representations (which add specific behavior to the scrolledText on which they are attached).

Subinstances are the graphical representation of the associated decorators defined in the .

 the main methods are 
	- computedExtentFrom:
	- computedHeightFrom: 
	- computedPositionFrom:
	- computedWidthFrom:
	
!
!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
selectionStop
	^ self paragraph selectionStop! !

!RubScrolledTextExtra methodsFor: 'geometry' stamp: ''!
manageLayoutInBounds: aRectangle
! !

!RubScrolledTextExtra methodsFor: 'defaults' stamp: ''!
defaultBackgroundColor 
	^ Color transparent! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
textStyle

	^ self textArea textStyle.
! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
scrollBounds
	^ self paragraphProvider scrollBounds! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
paragraph
	^ self paragraphProvider ifNotNil: [:p | p paragraph]! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
level
	^ 0! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
computedHeightFrom: aRectangle
	^ aRectangle height! !

!RubScrolledTextExtra methodsFor: 'testing' stamp: ''!
isVertical
	^ false! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
paragraphProvider
	
	^ self ownerThatIsA: RubScrolledTextMorph ! !

!RubScrolledTextExtra methodsFor: 'event handling' stamp: ''!
scrollerOffsetChanged
	self changed! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
selectionStart
	^ self paragraph selectionStart! !

!RubScrolledTextExtra methodsFor: 'testing' stamp: ''!
isHorizontal
	^ false! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
offset
	^ self paragraphProvider scrollPane offset! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
primarySelectionColor
	^ self textArea primarySelectionColor! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
lineIndexForPoint: aPoint
	^ self paragraph lineIndexForPoint: aPoint  + (0 @ (self offset y - self bounds top))! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
computedWidthFrom: aRectangle
	^ aRectangle width ! !

!RubScrolledTextExtra methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self clipSubmorphs: true! !

!RubScrolledTextExtra methodsFor: 'event handling' stamp: ''!
textAccepted
	self changed! !

!RubScrolledTextExtra methodsFor: 'event handling' stamp: ''!
selectionChanged
	self changed! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
key
	^self class key! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
scrollPane
	^ self paragraphProvider scrollPane! !

!RubScrolledTextExtra methodsFor: 'event handling' stamp: ''!
textChanged
	self changed! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
computedPositionFrom: aRectangle
	^ aRectangle topLeft! !

!RubScrolledTextExtra methodsFor: 'initialization' stamp: ''!
unplug
	self paragraphProvider
		ifNotNil: [ 
			self scrollPane ifNotNil: [:sp | sp announcer unsubscribe: self].
			self textArea ifNotNil: [:ts | ts announcer unsubscribe: self ] ].
	super unplug ! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
margins
	^ self textArea margins! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
textArea
	^ self paragraph textArea! !

!RubScrolledTextExtra methodsFor: 'structure' stamp: ''!
topRendererOrSelf
	^self paragraphProvider! !

!RubScrolledTextExtra methodsFor: 'testing' stamp: ''!
isSideRuler
	^ false! !

!RubScrolledTextExtra methodsFor: 'defaults' stamp: ''!
defaultColor
	^ self defaultBackgroundColor ! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
lines
	^ self paragraph lines! !

!RubScrolledTextExtra methodsFor: 'testing' stamp: ''!
isOver
	^ false! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
computedExtentFrom: aRectangle
	^ (self computedWidthFrom: aRectangle) @ (self computedHeightFrom: aRectangle)! !

!RubScrolledTextExtra methodsFor: 'accessing' stamp: ''!
text 
	^ self textArea text! !

!RubScrolledTextExtra class methodsFor: 'querying' stamp: ''!
classOfRulerNamed: aKey 
	^ self allSubclasses detect: [ :cls | cls key = aKey ] ifNone: [  ]! !

!RubScrolledTextExtra class methodsFor: 'querying' stamp: ''!
key
	^ nil! !

!RubScrolledTextExtraSurface methodsFor: 'accessing' stamp: ''!
computedWidthFrom: aRectangle
	^  aRectangle width min: self scrollBounds width
! !

!RubScrolledTextExtraSurface methodsFor: 'geometry' stamp: ''!
manageLayoutInBounds: aRectangle
	self position: (self computedPositionFrom: aRectangle).
	self extent: (self computedExtentFrom: aRectangle).
	self changed.
	^ aRectangle ! !

!RubScrolledTextExtraSurface methodsFor: 'accessing' stamp: ''!
computedHeightFrom: aRectangle
	^ aRectangle height min: self scrollBounds height! !

!RubScrolledTextExtraSurface methodsFor: 'testing' stamp: ''!
isOver
	^ true! !

!RubScrolledTextModel commentStamp: ''!
I am the main model of a text area. I should be used to dialog with the container of the text area. I am able to communicate the necessary infos to the morph. !
!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
setText: aText from: aView
	^ self setText: aText! !

!RubScrolledTextModel methodsFor: 'view creating' stamp: ''!
newTextField
	^ (RubTextFieldMorph on: self) getSelectionSelector: #primarySelectionInterval; yourself! !

!RubScrolledTextModel methodsFor: 'view updating' stamp: ''!
formatSourceCodeInView
	self reconfigureViewWith: [ :view | view formatSourceCode ]! !

!RubScrolledTextModel methodsFor: 'accessing' stamp: ''!
defaultAnnouncerClass 
	^Announcer! !

!RubScrolledTextModel methodsFor: 'binding' stamp: ''!
bindingOf: aString 
	^ interactionModel ifNotNil:  [ interactionModel bindingOf: aString  ]! !

!RubScrolledTextModel methodsFor: 'accessing' stamp: ''!
hasUnacceptedEdits
	^ hasUnacceptedEdits ifNil: [ hasUnacceptedEdits := false ]! !

!RubScrolledTextModel methodsFor: 'accessing' stamp: ''!
defaultAnnouncer
	^ self defaultAnnouncerClass new! !

!RubScrolledTextModel methodsFor: 'accessing' stamp: ''!
doItReceiver
	^ interactionModel ifNotNil: [ :im | im doItReceiver ]! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
hasUnacceptedEdits: aBoolean
	hasUnacceptedEdits := aBoolean.
	self announce: RubEditsStateChangedInModel new! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
primarySelectionInterval
	^ primarySelectionInterval ! !

!RubScrolledTextModel methodsFor: 'accessing' stamp: ''!
announce: anAnnouncement 
	self announcer announce: anAnnouncement! !

!RubScrolledTextModel methodsFor: 'view creating' stamp: ''!
newScrolledText
	^ (RubScrolledTextMorph on: self) getSelectionSelector: #primarySelectionInterval; yourself! !

!RubScrolledTextModel methodsFor: 'accessing' stamp: ''!
interactionModel
	^ interactionModel! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
getText
	^ self text! !

!RubScrolledTextModel methodsFor: 'shout' stamp: ''!
bindings
	^ self variableBindings! !

!RubScrolledTextModel methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer ifNil: [ announcer := self defaultAnnouncer ]! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
acceptEditsInView
	self reconfigureViewWith:  [ :view | 
		view textArea announce: (RubTextAcceptRequest morph: view textArea) ]! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
clearUserEdits
	self hasUnacceptedEdits: false! !

!RubScrolledTextModel methodsFor: 'accessing' stamp: ''!
doItContext
	^ interactionModel ifNotNil: [ :im | im doItContext ]! !

!RubScrolledTextModel methodsFor: '*HeuristicCompletion-Morphic' stamp: ''!
variableBindings
	"Required for polymorphism with the Playground"
	^ interactionModel
		ifNil: [ #() asDictionary ]
		ifNotNil: [ interactionModel bindings ]! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
text: atextOrString
	text := atextOrString asText! !

!RubScrolledTextModel methodsFor: 'shout' stamp: ''!
hasBindingOf: aString
	^ interactionModel ifNil: [ false ] ifNotNil: [ interactionModel hasBindingOf: aString ]! !

!RubScrolledTextModel methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass
	^ interactionModel ifNotNil: [ :im | im selectedClassOrMetaClass ]! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
canDiscardEdits
	^ self hasUnacceptedEdits not! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
acceptEdits
	"Accept the current contents and end editing."
	self announce: RubTextAcceptedInModel new.
	self clearUserEdits ! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
setPrimarySelectionInterval: anInterval

	primarySelectionInterval := anInterval.
	self announce: RubPrimarySelectionUpdatedInModel! !

!RubScrolledTextModel methodsFor: 'menu' stamp: ''!
shiftMenu
	^ nil! !

!RubScrolledTextModel methodsFor: 'accessing' stamp: ''!
interactionModel: anObject 	
	interactionModel := anObject! !

!RubScrolledTextModel methodsFor: 'undo - redo' stamp: ''!
clearUndoManager
	self reconfigureViewWith: [ :view | view textArea editingState clearUndoManager: nil ]! !

!RubScrolledTextModel methodsFor: 'menu' stamp: ''!
menu
	^ nil! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
getString
	^ self getText asString! !

!RubScrolledTextModel methodsFor: 'formatting' stamp: ''!
formatSourceCode
	self interactionModel formatSourceCode .! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
cancelEdits
	"Cancel the current contents and end editing."
	self announce: RubCancelEditRequestedInModel new.
	self clearUserEdits  ! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
setInitialText: aText 
	self setText:  aText.
	self clearUserEdits.
	^ true! !

!RubScrolledTextModel methodsFor: 'view updating' stamp: ''!
reconfigureViewWith: aBlockWithAScrolledTextMorphAsArgument
	self announce: (RubConfigurationChange new configurationBlock: aBlockWithAScrolledTextMorphAsArgument)! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
setText: aText 
	self text:  aText.
	self announcer announce: RubTextUpdatedInModel.
	^ true! !

!RubScrolledTextModel methodsFor: 'text managing' stamp: ''!
text

	^ text ifNil: [ text := '' asText ]! !

!RubScrolledTextModel class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RubScrolledTextModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RubScrolledTextModel class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RubScrolledTextModel class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RubScrolledTextModel class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RubScrolledTextModel class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RubScrolledTextModel class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RubScrolledTextModel class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RubScrolledTextModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RubScrolledTextModel class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RubScrolledTextModel class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RubScrolledTextModel class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RubScrolledTextModel class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RubScrolledTextModel class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RubScrolledTextModel class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RubScrolledTextModel class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RubScrolledTextModel class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RubScrolledTextModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RubScrolledTextModel class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RubScrolledTextModel class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RubScrolledTextModel class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RubScrolledTextModel class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RubScrolledTextModel class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RubScrolledTextModel class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RubScrolledTextModel class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RubScrolledTextModel class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RubScrolledTextModel class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RubScrolledTextModel class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RubScrolledTextModel class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RubScrolledTextMorph commentStamp: ''!
I am the common morph to represent a text area. I should be created by my model, a RubScrolledTextModel. The tool should talk to my model and not me directly !
!RubScrolledTextMorph methodsFor: 'initialization' stamp: ''!
beForSmalltalkCode
	self textArea beForSmalltalkCode.
	self withTextSegmentIcons.
	self textArea font: StandardFonts codeFont! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
text
	^ self textArea text! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
classOfRulerNamed: aKey
	^ RubScrolledTextExtra classOfRulerNamed: aKey! !

!RubScrolledTextMorph methodsFor: 'accessing - text area' stamp: ''!
margins: aMargin
	"polymorphism with text area"
	self textArea margins: aMargin! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
removeAllRulers
	[ self rulers notEmpty ] whileTrue: [ self withoutRuler: self rulers first ]! !

!RubScrolledTextMorph methodsFor: 'geometry' stamp: ''!
scrollBounds
	^ self scrollPane scrollBounds! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
rulers
	^ rulers ! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withLineNumbers
	self withRulerNamed: #lineNumbers! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
paragraph
	^ self scrollPane paragraph ! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
hasEditingConflicts: aBoolean
	hasEditingConflicts := aBoolean! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
drawHighlightsOn: aCanvas
	"Draw the highlights."

	| scrollBounds scrollOffset |
	
	scrollBounds := self scrollPane innerBounds.
	scrollOffset := self scrollPane scroller offset.
	
	aCanvas clipBy: self clippingBounds during: [ :canvas | 
		self highlights do: [ :highlight | 
			highlight drawOn: canvas in: scrollBounds offset: scrollOffset 
		] 
	]! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
wrapFlag: aBoolean
	self wrapped: aBoolean! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
withRulerNamed: aKey
	"returns the ruler associated with the aKey. It can be in the receiver or in the extra hierarchy.
	aKey is a symbol i.e., #lineNumbers"
	(self hasRulerNamed: aKey)
		ifTrue: [ ^ self ].
	(self classOfRulerNamed: aKey)
		ifNotNil: [ :cls | self withRuler: cls new ]! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withSourceCodeAnnotation
	self withRulerNamed: #SourceCodeAnnotation! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenReturnEnteredInTextArea: anAnnouncement 
	anAnnouncement morph: self.
	self announcer announce: anAnnouncement! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
moveCursorToIndex: anIndex 
	self selectFrom: anIndex to: anIndex - 1! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
getTextFromModel
	"Retrieve the current model text"

	| newText |
	self getTextSelector ifNil: [^Text new].
	newText := (self model perform: self getTextSelector withEnoughArguments: {self}).
	newText ifNil: [^Text new].
	^newText copy asText! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
askBeforeDiscardingEdits: aBoolean
	"Set the flag that determines whether the user should be asked before discarding unaccepted edits."

	askBeforeDiscardingEdits := aBoolean! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenConfigurationChangedFromModel: anAnnouncement
	self announcer announce: anAnnouncement
! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withoutLineNumbers
	self withoutRulerNamed: #lineNumbers! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
editingMode
	^  self textArea editingMode! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
acceptTextInModel

	self model ifNil: [ ^ true ].
	 ^ self setTextSelector numArgs = 2
		ifTrue: [ self model perform: self setTextSelector with: self text with: self ]
		ifFalse: [ self model perform: self setTextSelector withEnoughArguments: (Array with: self text) ]! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
drawFocusBorder: aBoolean
	self scrollPane drawFocusBorder: aBoolean! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
menuProvider: anObject selector: aSelector
	self textArea
		getMenuPolicy:
			(RubPluggableGetMenuPolicy new
				getMenuSelector: aSelector;
				menuProvider: anObject;
				yourself)! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
beReadOnly
	self textArea beReadOnly ! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withoutGhostText
	self withoutRulerNamed: #ghostText.
! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
classOrMetaClass: aBehavior
	self textArea classOrMetaClass: aBehavior! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
getSelectionSelector: aSelector
	getSelectionSelector := aSelector.
! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenTextSetInModel: anAnnouncement
	self announcer announce: anAnnouncement.
	self scrollPane setTextWith: self getTextFromModel! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withoutAnnotation
	self withoutRulerNamed: #annotation! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
getBackgroundColorSelector 
	^ getBackgroundColorSelector ! !

!RubScrolledTextMorph methodsFor: 'initialization' stamp: ''!
beForSmalltalkCodeWithDefaultFont
	self textArea beForSmalltalkCodeWithDefaultFont.
	self withTextSegmentIcons! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: event
	^ self scrollBounds containsPoint: event cursorPoint! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenGotFocus: anAnnouncement
	self announcer announce: anAnnouncement.
	self changed! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
annotationRuler
	^ self rulerNamed: #annotation! !

!RubScrolledTextMorph methodsFor: 'layout' stamp: ''!
manageLayoutInBounds: aRectangle
	| myBounds |
	myBounds := aRectangle.
	self horizontalRulers do: [ :r | myBounds := r manageLayoutInBounds: myBounds ].
	self verticalRulers do: [ :r | myBounds := r manageLayoutInBounds: myBounds ].
	self overRulers do: [ :r | myBounds := r manageLayoutInBounds: myBounds ].
	self scrollPane
		ifNotNil: [ :scrollpane |
			scrollpane position: myBounds topLeft.
			scrollpane extent: (myBounds extent max: 0@0)].
	^ myBounds! !

!RubScrolledTextMorph methodsFor: 'accessing - segments' stamp: ''!
segments
	^ self textArea segments
! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
mouseWheel: event 
	"Handle a mouseWheel event."
	
	(self scrollPane scrollTarget handlesMouseWheel: event)
		ifTrue: [^self scrollTarget mouseWheel: event]. "pass on"! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
columnRuler
	^ self rulerNamed: #column! !

!RubScrolledTextMorph methodsFor: 'drawing' stamp: ''!
adornmentColor
	"color to Indicate edit status for the given morph."

	self hasEditingConflicts
		ifTrue: [ ^ Color red ].
	self hasUnacceptedEdits
		ifTrue: [ ^ Color orange ].
	^ Color transparent! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
selectAll
	self selectFrom: 1 to: self text size ! !

!RubScrolledTextMorph methodsFor: 'classification' stamp: ''!
isRenderer
	^ true! !

!RubScrolledTextMorph methodsFor: 'initialization' stamp: ''!
beForPlainText
	self textArea beForPlainText! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
getTextSelector: aSymbol 
	getTextSelector  := aSymbol! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
scrollToBeginningOfText
	self scrollPane scrollToBeginningOfText! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
setModelSelection: aSelectionInterval
	"try to set the selection in the model"
	setSelectionSelector
		ifNotNil: [ self model perform: setSelectionSelector with: aSelectionInterval]! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
notificationStrategy: aStrategy
	self textArea notificationStrategy: aStrategy! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
setTextAreaSelection: aSelectionInterval
	aSelectionInterval ifNil: [ ^ self ].
	self textArea selectFrom: aSelectionInterval first to: aSelectionInterval last.
	self scrollPane scrollSelectionIntoView! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withoutTextField
	self withoutRulerNamed: #textField.
! !

!RubScrolledTextMorph methodsFor: 'accessing - scrollbars' stamp: ''!
hScrollbarShowWhenNeeded
	self scrollPane hScrollbarShowWhenNeeded! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
textColor: aColor 
	self textArea textColor: aColor! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenTextUpdatedInModel: anAnnouncement
	self announcer announce: anAnnouncement.
	self updateTextWith: self getTextFromModel
! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
canDiscardEdits
	^ (self hasUnacceptedEdits and: [askBeforeDiscardingEdits]) not
! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
on: aModel 
	self model: aModel.
! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
mouseDown: event
	"If pane is not empty, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"

	(self innerBounds containsPoint: event cursorPoint)
		ifTrue: [ 
			self scrollPane mouseDown: event.
			self eventHandler ifNotNil: [ self eventHandler mouseDown: event fromMorph: self ] ]! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	"Yes for page up/down."
	
	^true! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withoutCodeSizeFeedback
	self withoutRulerNamed: #codeSizeFeedback! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
extraAreas
	^ self rulers select: [ :r | r isOver ]
! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
beNotWrapped
	self scrollPane beNotWrapped ! !

!RubScrolledTextMorph methodsFor: 'accessing - decorators' stamp: ''!
withoutSelectionBar
	self textArea withoutSelectionBar! !

!RubScrolledTextMorph methodsFor: 'private' stamp: ''!
resetState
	hasEditingConflicts := false.
	hasUnacceptedEdits := false.
	self changed! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withGhostText: aText
	aText ifNil: [ ^ self withoutRulerNamed: #ghostText ].
	self withRulerNamed: #ghostText.
	self ghostTextRuler updateTextWith: aText asText.
	self ghostTextRuler comeToFront! !

!RubScrolledTextMorph methodsFor: 'defaults' stamp: ''!
defaultBackgroundColor 
	^ self theme backgroundColor! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
beWrapped
	self scrollPane beWrapped! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
withRulersNamed: aCollection
	"returns a collection of rulers as described by aCollection of keys. It can be in the receiver or in the extra hierarchy"
	aCollection do: [ :m | self withRulerNamed: m ]! !

!RubScrolledTextMorph methodsFor: 'private' stamp: ''!
shoutStyler
	^ self textArea shoutStyler! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenEditsStateChangedInModel: anAnnouncement
	self announcer announce: anAnnouncement.
	self basicHasUnacceptedEdits: self model hasUnacceptedEdits.
	self changed
! !

!RubScrolledTextMorph methodsFor: 'initialization' stamp: ''!
newScrollPane
	| sp |
	sp := RubTextScrollPane new.
	sp scrollTarget: self defaultScrollTarget.
	^ sp! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
beForSmalltalkScriptingWithDefaultFont
    self textArea beForSmalltalkScriptingWithDefaultFont
! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withoutColumns
	self withoutRulerNamed: #column! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withCodeSizeFeedback
	self withRulerNamed: #codeSizeFeedback! !

!RubScrolledTextMorph methodsFor: 'accessing - decorators' stamp: ''!
withoutDecoratorNamed: aSymbol
	self textArea withoutDecoratorNamed: aSymbol! !

!RubScrolledTextMorph methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas
	"Display submorphs back to front"

	| drawBlock subs |
	submorphs isEmpty
		ifTrue: [ ^ self ].
	subs := submorphs copyWithoutAll: self sideRulers.
	drawBlock := [ :canvas | subs reverseDo: [ :m | canvas fullDrawMorph: m ] ].
	self clipSubmorphs
		ifTrue: [ aCanvas clipBy: (aCanvas clipRect intersect: self clippingBounds ifNone: [ ^ self ]) during: drawBlock ]
		ifFalse: [ drawBlock value: aCanvas ].
	subs := self sideRulers.
	drawBlock := [ :canvas | subs reverseDo: [ :m | canvas fullDrawMorph: m ] ].
	self clipSubmorphs
		ifTrue: [ aCanvas clipBy: (aCanvas clipRect intersect: self clippingBounds ifNone: [ ^ self ]) during: drawBlock ]
		ifFalse: [ drawBlock value: aCanvas ]! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
hasKeyboardFocus
	^ (self scrollPane ifNil: [ ^false ]) hasKeyboardFocus! !

!RubScrolledTextMorph methodsFor: 'accessing - scrollbars' stamp: ''!
vScrollbarShowNever
	self scrollPane vScrollbarShowNever! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
getTextFromView
	"Retrieve the current view text, possibly not accepted"

	^ self textArea text! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
acceptContents
	(self autoAccept not and: [ 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 ] ].
	self acceptTextInModel == true
		ifFalse: [ ^ self ].
	self hasUnacceptedEdits: false.
	self rulers do: [ :r | r textAccepted ].
	self announcer announce: (RubTextAccepted morph: self)! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
ghostTextRuler
	^ self rulerNamed: #ghostText! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
withoutRulerNamed: aKey
	(self rulerNamed: aKey)
		ifNotNil: [ :m | self withoutRuler: m ].
	self changed! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenKeystrokeInTextArea: anAnnouncement 
	self announcer announce: (anAnnouncement copy morph: self)! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
backgroundColor: aColor
	self scrollPane color: aColor! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenTextAcceptedInModel: anAnnouncement
	self announcer announce: anAnnouncement.
	self acceptContents
! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
selectionChanged
	self rulers do: [ :r | r selectionChanged ].
	self setModelSelection: self selectionInterval
! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
takeKeyboardFocus
	self textArea takeKeyboardFocus! !

!RubScrolledTextMorph methodsFor: 'testing' stamp: ''!
isForScripting
	^ self textArea isForScripting! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
keyStroke: event
	self scrollPane
		ifNotNil: [ :scrollpane | scrollpane keyStroke: (event transformedBy: (scrollpane transformFrom: self)) ]! !

!RubScrolledTextMorph methodsFor: 'private' stamp: ''!
unplug
	self textArea ifNotNil: [ self textArea announcer unsubscribe: self ].
	self scrollPane
		ifNotNil: [ :scrollpane | 
			scrollpane announcer unsubscribe: self.
			scrollpane unplug ].
	super unplug! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
textArea
	^ self scrollPane ifNotNil: [:sp | sp textArea]! !

!RubScrolledTextMorph methodsFor: 'defaults' stamp: ''!
defaultColor
	^ self defaultBackgroundColor ! !

!RubScrolledTextMorph methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph 
	super noteNewOwner: aMorph.
	self manageLayout ! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
backgroundColor
	^self scrollPane color! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
tabWidth: anInteger
	self textArea tabWidth: anInteger ! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
textFont
	"We should clean"
	
	^ self textArea font! !

!RubScrolledTextMorph methodsFor: 'accessing - segments' stamp: ''!
segmentsAtLine: aLineNumber
	^ self textArea  segmentsAtLine: aLineNumber
! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
withoutRulersNamed: aCollection
	aCollection do: [ :m | self withoutRulerNamed: m ]! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
verticalRulers
	^self rulers select: [ :r | r isVertical ]! !

!RubScrolledTextMorph methodsFor: 'initialization' stamp: ''!
defaultScrollTarget
	| textArea |
	textArea := self textAreaClass new.
	textArea backgroundColor: Color lightGray veryMuchLighter.
	^ textArea! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
ghostText: aText
	self withGhostText: aText! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
withoutFocusBorder
	self scrollPane drawFocusBorder: false! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
editingMode: anEditingMode
	self textArea editingMode: anEditingMode.
! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
textAreaExtentChanged
	self manageLayout
! !

!RubScrolledTextMorph methodsFor: 'accessing - scrollbars' stamp: ''!
scrollerOffsetChanged
	self rulers do: [:r | r scrollerOffsetChanged]! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenTextAcceptRequest: anAnnouncement
	self announcer announce: anAnnouncement.
	self acceptContents! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
getBackgroundColorSelector: aSelector
	getBackgroundColorSelector := aSelector! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
offset
	^ self scrollPane offset! !

!RubScrolledTextMorph methodsFor: 'initialization' stamp: ''!
textAreaClass
	^ RubEditingArea! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withAnnotation
	self withRulerNamed: #annotation! !

!RubScrolledTextMorph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"Indicate unaccepted edits, conflicts etc."

	super drawOnAthensCanvas: anAthensCanvas. 
	self drawHighlightsOn: anAthensCanvas asCanvasWrapper! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
getTextSelector
	^ getTextSelector ifNil: [  getTextSelector := #getText ]! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
sideRulers
	^self rulers select: [ :r | r isSideRuler ]! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
on: aModel text: aGetTextSelector accept: aSetTextSelector readSelection: aReadSelectionSelector menu: aGetMenuSelector
	self getTextSelector: aGetTextSelector.
	self setTextSelector: aSetTextSelector.
	self getSelectionSelector: aReadSelectionSelector.
	self menuProvider: aModel selector: aGetMenuSelector.
	self on: aModel! !

!RubScrolledTextMorph methodsFor: 'configure' stamp: ''!
configureGhostText: aTextArea
	aTextArea width: self scrollBounds width.

	"If the text input is smaller in height than the ghost area 
	we use the center, if it bigger we can use 0.
	Using center will calculate a negative top value, that is 
	required when the ghost is bigger than the input box"	
			
	(aTextArea height < self scrollBounds height)
		ifTrue: [ aTextArea top: self scrollBounds top ]
		ifFalse: [ aTextArea center: self scrollBounds center.
					  aTextArea left: self scrollBounds left ] ! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
setTextWith: stringOrText
	"Accept new text contents with line breaks only as in the text.
	Fit my width and height to the result."
	self scrollPane setTextWith: stringOrText.
	self setSelection: self getSelectionFromModel.
	self resetState! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
lineNumbersRuler
	^ self rulerNamed: #lineNumbers! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
textFont: aFont
	self textArea font: aFont! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
model: aModel
	self textArea model: aModel.
	self setTextWith: self getTextFromModel.
	self setSelection: self getSelectionFromModel.
	aModel announcer when: RubTextAcceptedInModel send: #whenTextAcceptedInModel: to: self.	
	aModel announcer when: RubEditsStateChangedInModel send: #whenEditsStateChangedInModel: to: self.
	aModel announcer when: RubTextSetInModel send: #whenTextSetInModel: to: self.	
	aModel announcer when: RubTextUpdatedInModel send: #whenTextUpdatedInModel: to: self.	
	aModel announcer when: RubPrimarySelectionUpdatedInModel send: #whenPrimarySelectionUpdatedInModel: to: self.
	aModel announcer when: RubCancelEditRequestedInModel send: #whenCancelEditRequestedInModel: to: self.	
	aModel announcer when: RubConfigurationChange send: #whenConfigurationChangedFromModel: to: self.
! !

!RubScrolledTextMorph methodsFor: 'formatting' stamp: ''!
formatSourceCode
	self textArea formatMethodCode! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
setTextSelector
	^ setTextSelector ifNil: [  setTextSelector := #setText:from:]! !

!RubScrolledTextMorph methodsFor: 'layout' stamp: ''!
manageLayout
	| ret |
	self textArea ifNil: [ ^self ].
	ret := self manageLayoutInBounds: self innerBounds.
	self layoutChanged.
	^ret! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
hasRuler: aRuler
	^ self rulers includes: aRuler
	! !

!RubScrolledTextMorph methodsFor: 'geometry' stamp: ''!
position: aPoint
	super position: aPoint.
	self manageLayout

	! !

!RubScrolledTextMorph methodsFor: 'accessing - segments' stamp: ''!
addSegment: aRubTextSegmentMorph
	^ self textArea addSegment: aRubTextSegmentMorph
! !

!RubScrolledTextMorph methodsFor: 'initialization' stamp: ''!
beForSmalltalkComment
	self textArea beForSmalltalkComment! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
scrollToEndOfText
	self scrollPane scrollToEndOfText! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
hasUnacceptedEdits: aBoolean
	"Set the hasUnacceptedEdits flag to the given value. "
	
	(self model respondsTo: #hasUnacceptedEdits:)
		ifTrue: [ self model hasUnacceptedEdits: aBoolean ]
		ifFalse: [ self basicHasUnacceptedEdits: aBoolean ]! !

!RubScrolledTextMorph methodsFor: 'accessing - menu' stamp: ''!
menuAllowed: aBoolean
	self textArea menuAllowed: aBoolean! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
alwaysAccept
	^ alwaysAccept ifNil: [ alwaysAccept := false]! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
setSelection: aSelectionInterval
	aSelectionInterval ifNil: [ ^ self ].
	self setTextAreaSelection: aSelectionInterval.
	self selectionChanged ! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
model 
	^self textArea model! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
tabWidth
	^ self textArea tabWidth! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
textMorph
	^ self textArea! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withoutAdornment
	self withoutRulerNamed: #adornment! !

!RubScrolledTextMorph methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
setSelectionSelector: aSelector
	setSelectionSelector := aSelector! !

!RubScrolledTextMorph methodsFor: 'accessing - menu' stamp: ''!
forbidMenu
	self menuAllowed: false! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withAdornment
	self withRulerNamed: #adornment! !

!RubScrolledTextMorph methodsFor: 'accessing - text area' stamp: ''!
font: aFont
	"polymorphism with text area"
	self textFont: aFont! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
getSelectionFromModel
	"Answer the model's selection interval."

	^ self getSelectionSelector ifNotNil: [ :s | self model perform: s withEnoughArguments: {self} ]! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
maxLength
	^ self textArea maxLength! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
scrollPane
	^ scrollPane! !

!RubScrolledTextMorph methodsFor: 'accessing - scrollbars' stamp: ''!
hScrollbarShowNever
	self scrollPane hScrollbarShowNever! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
horizontalRulers
	^self rulers select: [ :r | r isHorizontal ]! !

!RubScrolledTextMorph methodsFor: 'accessing - decorators' stamp: ''!
withoutAnyDecorator
	self textArea withoutAnyDecorator! !

!RubScrolledTextMorph methodsFor: 'accessing - menu' stamp: ''!
allowMenu
	self menuAllowed: true! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withCommentAnnotation
	self withRulerNamed: #commentAnnotation! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
hasEditingConflicts
	^ hasEditingConflicts! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
scrollerExtentChanged
	self manageLayout
! !

!RubScrolledTextMorph methodsFor: 'accessing - scrollbars' stamp: ''!
currentHScrollBarThickness
	^self scrollPane currentHScrollBarThickness! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
font
	^ self textArea font! !

!RubScrolledTextMorph methodsFor: 'defaults' stamp: ''!
defaultGhostTextMorph
	| gt |
	gt := RubEditingArea new.
	gt withoutAnyDecorator.
	gt backgroundColor: Color transparent.
	gt beReadOnly.
	gt beWrapped.
	^ gt! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
scrollToEndOfLine
	self scrollPane scrollToEndOfLine! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
borderStyleToUse
	"Answer the borderStyle that should be used for the receiver."
	
	^self enabled
		ifTrue: [self theme rubScrolledTextMorphThemer normalBorderStyleFor: self]
		ifFalse: [self theme rubScrolledTextMorphThemer disabledBorderStyleFor: self]! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
beForSmalltalkScripting
    self textArea beForSmalltalkScripting.
    self textArea font: StandardFonts codeFont
! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
drawFocusBorder
	^ self scrollPane drawFocusBorder! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
accept
	self acceptContents.! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
getSelectionSelector
	^ getSelectionSelector! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
getText
	"Retrieve the current view text, possibly not accepted"

	^ self textArea text! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
maxLength: anInteger
	self textArea maxLength: anInteger! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
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! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
withFocusBorder
	self scrollPane drawFocusBorder: true! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
wrapped
	^ self scrollPane wrapped! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenTextChangedInTextArea: anAnnouncement 
	self announcer announce: anAnnouncement! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
editPrimarySelectionSeparately
	self textArea editPrimarySelectionSeparately! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
completionEngine: aCompletionEngine
	
	self textArea editor completionEngine: aCompletionEngine! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
selectionInterval: anInterval
	self setSelection: anInterval! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withoutTextSegmentIcons
	self withoutRulerNamed: #textSegmentIcons
! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
textChanged
	self manageLayout.
	self autoAccept
		ifTrue: [ self acceptContents ]
		ifFalse: [ self hasUnacceptedEdits: true ].
	self rulers do: [ :r | r textChanged ]! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
hasRulerNamed: aKey
	^ self rulers anySatisfy: [ :r | r key = aKey ]
	! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
editingModeClass
	^ self textArea editingMode class! !

!RubScrolledTextMorph methodsFor: 'mock for spec' stamp: ''!
setText: aText
	self updateTextWith: aText! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
appendText: stringOrText
	"Accept new text contents with line breaks only as in the text.
	Fit my width and height to the result."

	self scrollPane appendText: stringOrText.	
	self resetState! !

!RubScrolledTextMorph methodsFor: 'accessing - text' stamp: ''!
updateTextWith: stringOrText
	"Accept new text contents with line breaks only as in the text.
	Fit my width and height to the result."

	self scrollPane updateTextWith: stringOrText.	
	"self setSelection: self getSelection."
	self resetState! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
ghostText
	^ (self rulerNamed: #ghostText) ghostText text! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
selectionInterval
	^ self textArea selectionInterval! !

!RubScrolledTextMorph methodsFor: 'interactive error protocol' stamp: ''!
correctFrom: start to: stop with: aString
	self textArea correctFrom: start to: stop with: aString! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
rulerNamed: aKey
	^self rulers detect: [ :r | r key = aKey ] ifNone: [  ]! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
hasUnacceptedEdits
	^ hasUnacceptedEdits! !

!RubScrolledTextMorph methodsFor: 'defaults' stamp: ''!
defaultBorderWidth
	^ 0! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenLostFocus: anAnnouncement
	self announcer announce: anAnnouncement.
	self changed! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
themeChanged
	
	self color: self defaultColor.
	
	super themeChanged.! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withTextSegmentIcons
	self withRulerNamed: #textSegmentIcons
! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
autoAccept
	"Answer whether the editor accepts its contents on each change."

	^autoAccept ifNil: [autoAccept := false]! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
autoAccept: aBoolean
	"Whether I should accept my contents on each change."
	autoAccept := aBoolean.
	aBoolean
		ifTrue: [ self withoutAdornment]
		ifFalse: [ self withAdornment ]! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
beEditable
	self textArea beEditable ! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
highlights
	^ highlights! !

!RubScrolledTextMorph methodsFor: 'testing' stamp: ''!
isReadOnly
	^ self textArea isReadOnly ! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
withoutRuler: aRuler
	(self hasRuler: aRuler)
		ifFalse: [ ^ self ].
	rulers remove: aRuler.
	self removeMorph: aRuler.
	self manageLayout.
	self changed! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
handlesMouseWheel: evt
	"Do I want to receive mouseWheel events?" 

	^ true! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
wrapped: aBoolean
	self scrollPane wrapped: aBoolean! !

!RubScrolledTextMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self clipSubmorphs: true.
	enabled := true.
	askBeforeDiscardingEdits := true.
	hasEditingConflicts := false.
	hasUnacceptedEdits := false.
	rulers := SortedCollection sortBlock: [ :a :b | b level > a level ].
	self addMorph: (scrollPane := self newScrollPane).
	self announcer when: RubConfigurationChange send: #whenConfigurationChanged: to: self.
	self textArea announcer when: RubCancelEditRequested send: #whenCancelEditRequested: to: self.
	self textArea announcer when: MorphGotFocus send: #whenGotFocus: to: self.
	self textArea announcer when: MorphLostFocus send: #whenLostFocus: to: self.
	self textArea announcer when: RubTextAcceptRequest send: #whenTextAcceptRequest: to: self.
	self textArea announcer when: RubTextChanged send: #whenTextChangedInTextArea: to: self.
	self textArea announcer when: RubReturnEntered send: #whenReturnEnteredInTextArea: to: self.
	self textArea announcer when: RubKeystroke send: #whenKeystrokeInTextArea: to: self.
	self withAdornment.
	self borderStyle: self borderStyleToUse.
	highlights := OrderedCollection new! !

!RubScrolledTextMorph methodsFor: 'accessing - scrollbars' stamp: ''!
borderWidth: anInteger
	super borderWidth: anInteger.
	self extent: self extent.
	self manageLayout ! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
setTextSelector: aSymbol 
	setTextSelector  := aSymbol! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
highlights: anObject
	highlights := anObject! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
overRulers
	^self rulers select: [ :r | r isOver ]! !

!RubScrolledTextMorph methodsFor: 'interactive error protocol' stamp: ''!
notify: message at: location in: code
	^ self textArea notify: message at: location in: code! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenPrimarySelectionUpdatedInModel: anAnnouncement
	self announcer announce: anAnnouncement.
	self setTextAreaSelection: self getSelectionFromModel.

! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
handleMouseDown: event
	^ super handleMouseDown: event! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenCancelEditRequested: anAnnouncement
	self announcer announce: anAnnouncement.
	self cancel
! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
getBackgroundColorFromModel
	"Retrieve the color from the model"

	self getBackgroundColorSelector ifNil: [^ self ].
	^ self model perform: self getBackgroundColorSelector withEnoughArguments: {self}.! !

!RubScrolledTextMorph methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
registerScrollChanges: aSelector
	self scrollPane announcer when: PaneScrolling send: aSelector to: self model! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
adornmentRuler
	^ self rulerNamed: #adornment! !

!RubScrolledTextMorph methodsFor: 'rulers handling' stamp: ''!
withRuler: aRuler
	(self hasRulerNamed: aRuler key)
		ifTrue: [ ^ self ].
	rulers add: aRuler.
	aRuler level >= 0 ifTrue: [self addMorphBack: aRuler].
	"Extra areas must be in the front "
	self extraAreas do: [ :r | self addMorphFront: r ].
	self manageLayout.
	" Finnally, the scrollPane must be in the front of all because text must be drawn last "
	self addMorphFront: self scrollPane.
	aRuler level < 0 ifTrue: [ self addMorphFront: aRuler ]! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
withColumns
	self withRulerNamed: #column! !

!RubScrolledTextMorph methodsFor: 'accessing - scrollbars' stamp: ''!
hScrollbarShowAlways
	self scrollPane hScrollbarShowAlways.
	self extent: self extent.
	self manageLayout ! !

!RubScrolledTextMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	super drawOn: aCanvas.
	self drawHighlightsOn: aCanvas ! !

!RubScrolledTextMorph methodsFor: 'accessing - selection' stamp: ''!
selectFrom: firstIndex to: lastIndex
	self selectionInterval: (firstIndex to: lastIndex)
! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenCancelEditRequestedInModel: anAnnouncement
	self announcer announce: anAnnouncement.
	self cancel
! !

!RubScrolledTextMorph methodsFor: 'drawing' stamp: ''!
drawSubmorphsOnAthensCanvas: anAthensCanvas
	"Display submorphs back to front"

	| drawBlock subs |
	submorphs isEmpty
		ifTrue: [ ^ self ].
	subs := submorphs copyWithoutAll: self sideRulers.
	drawBlock := [ subs reverseDo: [ :m | anAthensCanvas fullDrawMorph: m ] ].
	self clipSubmorphs
		ifTrue: [ anAthensCanvas clipBy: (anAthensCanvas clipRect intersect: self clippingBounds ifNone: [ ^ self ]) during: drawBlock ]
		ifFalse: [ drawBlock value ].
	subs := self sideRulers.
	drawBlock := [ subs reverseDo: [ :m | anAthensCanvas fullDrawMorph: m ] ].
	self clipSubmorphs
		ifTrue: [ anAthensCanvas clipBy: (anAthensCanvas clipRect intersect: self clippingBounds ifNone: [ ^ self ]) during: drawBlock ]
		ifFalse: [ drawBlock value ]! !

!RubScrolledTextMorph methodsFor: 'accessing - menu' stamp: ''!
getMenuPolicy: aGetMenuPolicy
	self textArea getMenuPolicy: aGetMenuPolicy! !

!RubScrolledTextMorph methodsFor: 'mock for spec' stamp: ''!
enabled: aBoolean
	enabled = aBoolean ifTrue: [^self].
	enabled := aBoolean.
	self textArea readOnly: aBoolean not.
	self changed! !

!RubScrolledTextMorph methodsFor: 'accessing - text area' stamp: ''!
cursor
	"polymorphism with text area"
	^ self textArea cursor! !

!RubScrolledTextMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	super extent: aPoint.
	self manageLayout! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
cancel

	self updateTextWith: self getTextFromModel.
	self setSelection: self getSelectionFromModel! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
scrollToBeginningOfLine
	self scrollPane scrollToBeginningOfLine! !

!RubScrolledTextMorph methodsFor: 'event handling' stamp: ''!
whenConfigurationChanged: anAnnouncement
	anAnnouncement configurationBlock value: self
! !

!RubScrolledTextMorph methodsFor: 'model protocol' stamp: ''!
basicHasUnacceptedEdits: aBoolean
	self autoAccept
		ifTrue: [ ^ self ].
	aBoolean = hasUnacceptedEdits 
		ifFalse: [ hasUnacceptedEdits := aBoolean.
			self changed].
	aBoolean 
		ifFalse: [hasEditingConflicts := false]! !

!RubScrolledTextMorph methodsFor: 'accessing - decorators' stamp: ''!
withDecoratorNamed: aSymbol
	self textArea withDecoratorNamed: aSymbol! !

!RubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
textColor
	^ self textArea textColor! !

!RubScrolledTextMorph methodsFor: 'accessing - scrollbars' stamp: ''!
scrollbarsShowNever
	self hScrollbarShowNever.
	self vScrollbarShowNever! !

!RubScrolledTextMorph methodsFor: 'initialization' stamp: ''!
beForSmalltalkCodeInClass: aClass
	self textArea beForSmalltalkCodeInClass: aClass.
	self withTextSegmentIcons.
	self textArea font: StandardFonts codeFont! !

!RubScrolledTextMorph methodsFor: 'accessing - rulers' stamp: ''!
textSegmentIconsRuler
	^ self rulerNamed: #textSegmentIcons! !

!RubScrolledTextMorph class methodsFor: 'instance creation' stamp: ''!
on: aModel 
	^ self new on: aModel! !

!RubScrolledTextMorphTest methodsFor: 'running' stamp: ''!
tearDown

	morph delete.
	super tearDown! !

!RubScrolledTextMorphTest methodsFor: 'tests' stamp: ''!
testEmbeddedAnchorInTextAreDrawnAtRightPosition
	| circle longTextWithCircleAtEnd canvas|
	self skip. "Test fail in CI"
	circle := CircleMorphCounter new extent: 50 @ 50;color: Color blue.
	longTextWithCircleAtEnd := ((String loremIpsum: 10000), 
		(String value: 1)) asText 
			addAttribute: (TextAnchor new anchoredMorph: circle).

	self assert: circle owner isNil.
	self assert: circle position equals: 0@0.
	morph updateTextWith: longTextWithCircleAtEnd.
	canvas := FormCanvas extent: 500@500.
	canvas fullDrawMorph: morph.
	
	self assert: circle owner equals: nil.
	self assert: circle counter equals: 0.
	
	morph scrollToEndOfText.	
	canvas := FormCanvas extent: 500@500.
	canvas fullDrawMorph: morph.
	self assert: circle counter > 0! !

!RubScrolledTextMorphTest methodsFor: 'tests' stamp: ''!
testGhostText
	| scrolledText | 
	scrolledText := RubScrolledTextMorph new 
				ghostText: 'This is a cool ghost text';
				yourself.
	self assert: scrolledText ghostText string equals: 'This is a cool ghost text'! !

!RubScrolledTextMorphTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	morph := RubScrolledTextMorph new.
	morph extent: 400@250.
	morph setTextWith: 'one two three four'! !

!RubScrolledTextMorphThemer methodsFor: 'border-styles' stamp: ''!
normalBorderStyleFor: aTextArea
	^ BorderStyle 
		width: 0
		color: Color transparent! !

!RubScrolledTextMorphThemer methodsFor: 'colors' stamp: ''!
highlightBackgroundColorFor: aTextArea

	^ Color veryLightGray alpha:0.01! !

!RubScrolledTextMorphThemer methodsFor: 'border-styles' stamp: ''!
disabledBorderStyleFor: aTextArea
	^ self normalBorderStyleFor: aTextArea ! !

!RubScrolledTextMorphThemer methodsFor: 'border-styles' stamp: ''!
highlightBorderStyleFor: aTextArea
	^ BorderStyle inset 
		baseColor: Smalltalk ui theme selectionColor;
		width: 2! !

!RubScrolledTextSideRuler commentStamp: ''!
I am an abstract class to add decoration on a text area!
!RubScrolledTextSideRuler methodsFor: 'geometry' stamp: ''!
manageLayoutInBounds: aRectangle
	super manageLayoutInBounds: aRectangle.
	self extent: (self computedExtentFrom: aRectangle).
	self side = #left
		ifTrue: [ 
			self position: aRectangle topLeft.
			^ aRectangle topLeft + ((self computedWidthFrom: aRectangle) @ 0) corner: aRectangle corner ].
	self side = #right
		ifTrue: [ 
			self position: aRectangle topRight - ((self computedWidthFrom: aRectangle) @ 0).
			^ aRectangle topLeft corner: aRectangle corner - ((self computedWidthFrom: aRectangle) @ 0) ].
	self side = #bottom
		ifTrue: [ 
			self position: aRectangle bottomLeft - (0 @ (self computedHeightFrom: aRectangle)).
			^ aRectangle topLeft corner: aRectangle corner - (0 @ (self computedHeightFrom: aRectangle)) ].
	^ self error: 'side must be in #( #left #right #bottom #top #over )'! !

!RubScrolledTextSideRuler methodsFor: 'accessing' stamp: ''!
side
	^side ifNil: [ side := #left ]! !

!RubScrolledTextSideRuler methodsFor: 'testing' stamp: ''!
isVertical
	^ #(#left #right) includes: self side! !

!RubScrolledTextSideRuler methodsFor: 'accessing' stamp: ''!
side: aSide
	side := aSide! !

!RubScrolledTextSideRuler methodsFor: 'testing' stamp: ''!
isHorizontal
	^ #(#top #bottom) includes: self side! !

!RubScrolledTextSideRuler methodsFor: 'testing' stamp: ''!
isSideRuler
	^ true! !

!RubSegmentIconMenuItemMorph methodsFor: 'selecting' stamp: ''!
select: anEvent
	self segment showMouseHasEntered.
	super select: anEvent.
! !

!RubSegmentIconMenuItemMorph methodsFor: 'accessing' stamp: ''!
segment
	
	^ segment! !

!RubSegmentIconMenuItemMorph methodsFor: 'events' stamp: ''!
invokeWithEvent: evt
	super invokeWithEvent: evt.
	self owner defaultTarget changed! !

!RubSegmentIconMenuItemMorph methodsFor: 'selecting' stamp: ''!
deselect: anEvent
	self segment showMouseHasLeaved.
	super deselect: anEvent.
! !

!RubSegmentIconMenuItemMorph methodsFor: 'accessing' stamp: ''!
segment: aSegment
	
	segment := aSegment! !

!RubSegmentIconMenuMorph methodsFor: 'adding item' stamp: ''!
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 := RubSegmentIconMenuItemMorph new
		contents: aString translated;
		target: anObject;
		selector: aSymbol;
		arguments: argList;
		getStateSelector: stateSymbol;
		enablementSelector: enableSymbol.
	^ self addMenuItem: item.
! !

!RubSegmentMorph commentStamp: ''!
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 (???)

!
!RubSegmentMorph methodsFor: 'shaping' stamp: ''!
diamondOval
	"Set my vertices to an array of edge midpoint vertices. Order of vertices is in the tradion of warpblt quads."
	
	| b |
	b := self bounds.
	self setVertices: { b leftCenter. b bottomCenter. b rightCenter. b topCenter }! !

!RubSegmentMorph methodsFor: 'cubic support' stamp: ''!
transform: coefficients toCubicPointPolynomialAt: vIndex 
	"From curve information assemble a 4-array of points representing the coefficents for curve segment between to points. Beginning point is first point in array endpoint is the pointSum of the array. Meant to be sent to newcurves idea of curve coefficents." 
	| transformed |
	transformed := (1 to: 4) collect: [:i | 
			((coefficients at: i) at: vIndex) @ ((coefficients at: 4 + i) at: vIndex)].
	^ Cubic withAll: transformed! !

!RubSegmentMorph methodsFor: 'private' stamp: ''!
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 |
	filledForm ifNotNil: [^ filledForm].
	filledForm := Form extent: bounds extent+2.

	"Draw the border..."
	bb := (BitBlt toForm: filledForm) sourceForm: nil; fillColor: Color black;
			combinationRule: Form over; width: 1; height: 1.
	origin := bounds topLeft asIntegerPoint-1.
	self lineSegmentsDo: [:p1 :p2 | bb drawFrom: p1 asIntegerPoint-origin
										to: p2 asIntegerPoint-origin].

	"Fill it in..."
	filledForm convexShapeFill: Color black.

	(borderColor isColor and: [borderColor isTranslucentButNotTransparent]) ifTrue: 
		["If border is stored as a form, then erase any overlap now."
		filledForm copy: self borderForm boundingBox from: self borderForm
			to: 1@1 rule: Form erase].

	^ filledForm! !

!RubSegmentMorph methodsFor: 'geometry' stamp: ''!
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]! !

!RubSegmentMorph methodsFor: 'accessing' stamp: ''!
borderColor: aColor 

	super borderColor: aColor.
	self releaseCachedState! !

!RubSegmentMorph methodsFor: 'accessing' stamp: ''!
vertices
	^ vertices! !

!RubSegmentMorph methodsFor: 'cubic support' stamp: ''!
segmentedSlopesOf: knots 
	"For a collection of floats. Returns the slopes for straight 
	segments between vertices."
	"last slope closes the polygon. Always return same size as 
	self. "
	^ knots collectWithIndex: [:x :i | (knots atWrap: i + 1) - x]! !

!RubSegmentMorph methodsFor: 'smoothing' stamp: ''!
coefficients
	curveState ifNotNil: [^ curveState at: 1].
	^ self vertices size < 1 
		ifTrue: [ self  ]
		ifFalse: [ self coefficientsForMoreThanThreePoints ].  ! !

!RubSegmentMorph methodsFor: 'cubic support' stamp: ''!
naturalCubicSlopesOf: knots 
	"Sent to knots returns the slopes of a natural cubic curve fit."
	"We solve the equation for knots with end conditions:  
	2*b1+b2 = 3(a1 - a0) 
	bN1+2*bN = 3*(aN-aN1)
	and inbetween:
	b2+4*b3+b4=3*(a4-a2)
	where a2 is (knots atWrap: index + 1) etc.
	and the b's are the slopes .
	N is the last index (knots size)
	N1 is N-1.
	 
	by using row operations to convert the matrix to upper  
	triangular and then back sustitution. The D[i] are the derivatives at the  
	knots."
	
	| x gamma delta D n1 |
	n1 := knots size.
	n1 < 3
		ifTrue: [self error: 'Less than 3 points makes a poor curve'].
	x := knots.
	gamma := Array new: n1.
	delta := Array new: n1.
	
	D := Array new: n1.
	gamma at: 1 put: 1.0 / 2.0.
	2 to: n1 - 1 do: [:i | gamma at: i put: 1.0 / (4.0
						- (gamma at: i - 1))].
	gamma at: n1 put: 1.0 / (2.0
				- (gamma at: n1 - 1)).
	delta at: 1 put: 3.0 * ((x at: 2)
				- (x at: 1))
			* (gamma at: 1).
	2 to: n1 - 1 do: [:i | delta at: i put: 3.0 * ((x at: i + 1)
						- (x at: i - 1))
					- (delta at: i - 1)
					* (gamma at: i)].
	delta at: n1 put: 3.0 * ((x at: n1)
				- (x at: n1 - 1))
			- (delta at: n1 - 1)
			* (gamma at: n1).
	D
		at: n1
		put: (delta at: n1).
	(1 to: n1 - 1)
		reverseDo: [:i | D at: i put: (delta at: i)
					- ((gamma at: i)
							* (D at: i + 1))].
	^ D! !

!RubSegmentMorph methodsFor: 'cubic support' stamp: ''!
changeInSlopes: slopes of: verts 
	"A message to knots of a spline. Returns an array with the 3rd cubic coeff."
	"The last nth item is correct iff this is a closed cubic.
	Presumably that is the only time we care.
	We always return the same sized array as self."
	| n slopeChanges |
	n := verts size.
	n = slopes size ifFalse: [^ self error: 'vertices and slopes differ in number'].
	slopeChanges := Array new: n.
	1 to: n do: [:i | slopeChanges at: i put: (verts atWrap: i + 1)
					- (verts at: i) * 3 - ((slopes at: i) * 2)
					- (slopes atWrap: i + 1)].
	^ slopeChanges! !

!RubSegmentMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	vertices := Array with: 5 @ 0 with: 20 @ 10 with: 0 @ 20.
	smoothCurve := false.
	self computeBounds.
! !

!RubSegmentMorph methodsFor: 'accessing' stamp: ''!
borderWidth: anInteger

	super borderWidth: anInteger.
	self computeBounds! !

!RubSegmentMorph methodsFor: 'drawing' stamp: ''!
drawBorderOnAthensCanvas: aCanvas 
	self
		drawClippedBorderOnAthensCanvas: aCanvas
		usingEnds: (Array with: vertices first with: vertices last)! !

!RubSegmentMorph methodsFor: 'drawing' stamp: ''!
drawClippedBorderOn: aCanvas usingEnds: anArray 
	aCanvas clipBy: self bounds during:[:cc| self drawBorderOn: cc usingEnds: anArray].! !

!RubSegmentMorph methodsFor: 'testing' stamp: ''!
isCurvy
	"Test for significant curves.  
	Small smoothcurves in practice are straight."
	^ smoothCurve and: [vertices size > 2]! !

!RubSegmentMorph methodsFor: 'geometry' stamp: ''!
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! !

!RubSegmentMorph methodsFor: 'smoothing' stamp: ''!
slopes: knots 
	"Choose slopes according to state of polygon"
	self isCurvy ifFalse: [^ self segmentedSlopesOf: knots ].
	^ self closedCubicSlopesOf: knots! !

!RubSegmentMorph methodsFor: 'accessing' stamp: ''!
couldHaveRoundedCorners
	^ false! !

!RubSegmentMorph methodsFor: 'private' stamp: ''!
computeBounds
	vertices ifNil: [^ self].
	self changed.
	self releaseCachedState.
	bounds := self curveBounds expanded.
	self layoutChanged.
	self changed.
! !

!RubSegmentMorph methodsFor: 'initialization' stamp: ''!
beStraightSegments

	smoothCurve == false ifFalse:
		[smoothCurve := false.
		self computeBounds]! !

!RubSegmentMorph methodsFor: 'smoothing' stamp: ''!
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].
			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).
	1 to: cs first size
		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]! !

!RubSegmentMorph methodsFor: 'drawing' stamp: ''!
drawBorderOn: aCanvas usingEnds: anArray
	"Display my border on the canvas."

	| bigClipRect style |
	style := self borderStyle.
	bigClipRect := aCanvas clipRect expandBy: (self borderWidth + 1) // 2.
	self
		lineSegmentsDo: [ :p1 :p2 | 
			| p1i p2i |
			p1i := p1 asIntegerPoint.
			p2i := p2 asIntegerPoint.
			style drawLineFrom: p1i to: p2i on: aCanvas ]! !

!RubSegmentMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color
		r: 0.0
		g: 0.419
		b: 0.935! !

!RubSegmentMorph methodsFor: 'geometry' stamp: ''!
transformedBy: aTransform
	self setVertices: (self vertices collect:[:v| aTransform localPointToGlobal: v])! !

!RubSegmentMorph methodsFor: 'drawing' stamp: ''!
areasRemainingToFill: aRectangle
	"Could be improved by quick check of inner rectangle"

	^ Array with: aRectangle! !

!RubSegmentMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color orange! !

!RubSegmentMorph methodsFor: 'geometry' stamp: ''!
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! !

!RubSegmentMorph methodsFor: 'private' stamp: ''!
setVertices: newVertices
	vertices := newVertices.
	self computeBounds! !

!RubSegmentMorph methodsFor: 'cubic support' stamp: ''!
closedCubicSlopesOf: knots 
	"Sent to knots returns the slopes of a closed cubic spline.
	From the same set of java sources as naturalCubic. This is a smalltalk  
	transliteration of the java code."
	"from java code NatCubicClosed extends NatCubic  
	solves for the set of equations for all knots: 
	b1+4*b2+b3=3*(a3-a1)
	where a1 is (knots atWrap: index + 1) etc.
	and the b's are the slopes .
	by decomposing the matrix into upper triangular and lower matrices  
	and then back sustitution. See Spath 'Spline Algorithms for Curves  
	and Surfaces' pp 19--21. The D[i] are the derivatives at the knots.  
	"
	
	| v w x y z n1  D F G H |
	n1 := knots size.
	n1 < 3
		ifTrue: [self error: 'Less than 3 points makes a poor curve'].
	v := Array new: n1.
	w := Array new: n1.
	y := Array new: n1.
	
	D := Array new: n1.
	x := knots.
	z := 1.0 / 4.0.
	v at: 2 put: z.
	w at: 2 put: z.
	y at: 1 put: z * 3.0 * ((x at: 2) - (x at: n1)).
	H := 4.0.
	F := 3 * ((x at: 1) - (x at: n1 - 1)).
	G := 1.
	2 to: n1 - 1 do: [:k | 
			z := 1.0 / (4.0 - (v at: k)).
			v at: k + 1 put: z.
			w at: k + 1 put: z negated
					* (w at: k).
			y at: k put: z * (3.0 * ((x at: k + 1) - (x at: k - 1)) - (y at: k - 1)).
			H := H - (G * (w at: k)).
			F := F - (G * (y at: k - 1)).
			G := (v at: k) negated * G].
	H := H - (G + 1 * ((v at: n1) + (w at: n1))).
	y at: n1 put: F - (G + 1 * (y at: n1 - 1)).
	D at: n1 put: (y at: n1) / H.
	D at: n1 - 1 put: (y at: n1 - 1) - ((v at: n1) + (w at: n1) * (D at: n1)).
	(1 to: n1 - 2)
		reverseDo: [:k | D at: k put: (y at: k)
					- ((v at: k + 1) * (D at: k + 1)) - ((w at: k + 1) * (D at: n1))].
	^ D 

! !

!RubSegmentMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	"Display the receiver, a spline curve, approximated by straight 
	line segments."
	|  |
	aCanvas drawPolygon: self getVertices fillStyle: self fillStyle.
	self drawBorderOn: aCanvas
! !

!RubSegmentMorph methodsFor: 'accessing' stamp: ''!
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! !

!RubSegmentMorph methodsFor: 'drawing' stamp: ''!
drawBorderOn: aCanvas 
	self
		drawClippedBorderOn: aCanvas
		usingEnds: (Array with: vertices first with: vertices last)! !

!RubSegmentMorph methodsFor: 'private' stamp: ''!
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.
	^ borderForm! !

!RubSegmentMorph methodsFor: 'private' stamp: ''!
getVertices

	smoothCurve ifFalse: [^ vertices].

	"For curves, enumerate the full set of interpolated points"
	^ Array streamContents:
		[:s | self lineSegmentsDo: [:pt1 :pt2 | s nextPut: pt1]]! !

!RubSegmentMorph methodsFor: 'private' stamp: ''!
privateMoveBy: delta
	super privateMoveBy: delta.
	vertices := vertices collect: [:p | p + delta].
	curveState := nil.  "Force recomputation"
	(self valueOfProperty: #referencePosition) ifNotNil:
		[:oldPos | self setProperty: #referencePosition toValue: oldPos + delta]! !

!RubSegmentMorph methodsFor: 'geometry' stamp: ''!
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
! !

!RubSegmentMorph methodsFor: 'private' stamp: ''!
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: self borderWidth * 0.5 ].
	curveState := nil.	"Force recomputation"	"curveBounds := vertices first corner: vertices last."
	pointAfterFirst := nil.
	self
		lineSegmentsDo: [ :p1 :p2 | 
			pointAfterFirst
				ifNil: [ 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: self borderWidth * 0.5! !

!RubSegmentMorph methodsFor: 'smoothing' stamp: ''!
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! !

!RubSegmentMorph methodsFor: 'smoothing' stamp: ''!
coefficientsForMoreThanThreePoints 
	"Less than three points handled as segments by our lineSegmentsDo:"
	| verts coefficients vertXs slopeXs vertYs slopeYs bestSegments |
	verts := self vertices. 
	coefficients := {
		vertXs := verts collect: [:p | p x asFloat].
		slopeXs := self slopes: vertXs. 
		self changeInSlopes: slopeXs of: vertXs .
		self changeOfChangesInSlopes: slopeXs of: vertXs. 
		vertYs := verts collect: [:p | p y asFloat].
		slopeYs := self slopes: vertYs.
		self changeInSlopes: slopeYs of: vertYs.
		self changeOfChangesInSlopes: slopeYs of: vertYs. 
		Array new: verts size withAll: 12}.
		
		
	bestSegments := (1 to: verts size) collect: [:i | (self transform: coefficients toCubicPointPolynomialAt: i) bestSegments].
	coefficients at: 9 put:bestSegments.

	curveState := {coefficients. nil. nil}.
	self computeNextToEndPoints.
	^ coefficients! !

!RubSegmentMorph methodsFor: 'drawing' stamp: ''!
drawBorderOnAthensCanvas: aCanvas usingEnds: anArray
	"Display my border on the canvas."

	| bigClipRect style |
	style := self borderStyle.
	bigClipRect := aCanvas clipRect expandBy: (self borderWidth + 1) // 2.
	self
		lineSegmentsDo: [ :p1 :p2 | 
			| p1i p2i path |
			p1i := p1 asIntegerPoint.
			p2i := p2 asIntegerPoint.
			path := aCanvas
				createPath: [ :builder | 
					builder absolute.
					builder moveTo: p1i.
					builder lineTo: p2i ].
			(aCanvas setStrokePaint: style color) width: style width.
			aCanvas drawShape: path ]! !

!RubSegmentMorph methodsFor: 'caching' stamp: ''!
releaseCachedState

	super releaseCachedState.
	filledForm := nil.
	borderForm := nil.
	curveState := nil.
	(self hasProperty: #flex) ifTrue:
		[self removeProperty: #flex].
! !

!RubSegmentMorph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"Display the receiver, a spline curve, approximated by straight 
	line segments."
	| verts polygonPath |
	verts := self getVertices.
	polygonPath := anAthensCanvas
		createPath: [ :builder | 
			builder
				absolute;
				moveTo: verts first.
			verts allButFirstDo: [ :pt | builder lineTo: pt ].
			"builder close" ].
	anAthensCanvas setPaint: self fillStyle.
	anAthensCanvas setShape: polygonPath.
	anAthensCanvas draw.
	self drawBorderOnAthensCanvas: anAthensCanvas
! !

!RubSegmentMorph methodsFor: 'geometry' stamp: ''!
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 ])! !

!RubSegmentMorph methodsFor: 'cubic support' stamp: ''!
changeOfChangesInSlopes: slopes of: verts
	"A message to knots of a spline. Returns an array with the 4rd 
	cubic coeff."
	"The last nth item is correct iff this is a closed cubic. 
	Presumably that is the only time we care. 
	We always return the same sized array as self."
	| n changes |
	n := verts size.
	n = slopes size ifFalse: [^ self error: 'vertices and slopes differ in number'].
	changes := Array new: n.
	1 to: n do: [:i | changes at: i put: (verts at: i)
					- (verts atWrap: i + 1) * 2
					+ (slopes at: i)
					+ (slopes atWrap: i + 1)].
	^ changes! !

!RubSegmentMorph methodsFor: 'geometry' stamp: ''!
referencePosition 
	"Return the current reference position of the receiver"
	^ self valueOfProperty: #referencePosition ifAbsent: [super referencePosition]
! !

!RubSegmentMorph methodsFor: 'testing' stamp: ''!
isCurve
	^ smoothCurve! !

!RubSegmentMorph methodsFor: 'initialization' stamp: ''!
vertices: verts color: aColor borderWidth: borderWidthInteger borderColor: anotherColor 
	super initialize.
	vertices := verts.
	color := aColor.
	borderWidth := borderWidthInteger. 
	borderColor := anotherColor.
	self computeBounds! !

!RubSegmentMorph methodsFor: 'initialization' stamp: ''!
beSmoothCurve
	smoothCurve == true
		ifFalse: [ 
			smoothCurve := true.
			self computeBounds ]! !

!RubSegmentMorph methodsFor: 'drawing' stamp: ''!
drawClippedBorderOnAthensCanvas: aCanvas usingEnds: anArray
	aCanvas clipBy: self bounds during: [ self drawBorderOnAthensCanvas: aCanvas usingEnds: anArray ]! !

!RubSegmentMorph methodsFor: 'accessing' stamp: ''!
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! !

!RubSegmentMorph methodsFor: 'testing' stamp: ''!
containsPoint: aPoint
	(super containsPoint: aPoint)
		ifFalse: [ ^ false ].
	color isTransparent
		ifFalse: [ ^ (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 ] ].
	^ false ! !

!RubSegmentMorph class methodsFor: 'instance creation' stamp: ''!
vertices: verts color: c borderWidth: bw borderColor: bc
	^ self basicNew beStraightSegments vertices: verts color: c borderWidth: bw borderColor: bc! !

!RubSelectionChanged commentStamp: ''!
I am raised when the current selection is modified !
!RubSelectionChanged methodsFor: 'accessing' stamp: ''!
pointBlock
	^ self textArea pointBlock! !

!RubSelectionChanged methodsFor: 'accessing' stamp: ''!
previousMarkBlock
	^ previousMarkBlock! !

!RubSelectionChanged methodsFor: 'accessing' stamp: ''!
markBlock
	^ self textArea markBlock! !

!RubSelectionChanged methodsFor: 'accessing' stamp: ''!
textArea
	^ morph! !

!RubSelectionChanged methodsFor: 'accessing' stamp: ''!
previousPointBlock
	^ previousPointBlock! !

!RubSelectionChanged methodsFor: 'accessing' stamp: ''!
from: aTextArea previousMarkBlock: prevMarkBlock previousPointBlock: prevPointBlock 
	self morph: aTextArea.
	previousMarkBlock := prevMarkBlock.
	previousPointBlock := prevPointBlock! !

!RubSelectionChanged class methodsFor: 'instance creation' stamp: ''!
from: aTextArea previousMarkBlock: prevMarkBlock previousPointBlock: prevPointBlock 
	^ self new from: aTextArea previousMarkBlock: prevMarkBlock previousPointBlock: prevPointBlock 
! !

!RubSelectionTest methodsFor: 'running' stamp: ''!
testCaretInTheMiddleOfSecondWordHasSecondWordUpToCaret

	"Words are abcde fghi. Put caret after space, just before $i"
	editor selectAt: 1 + 'abcde fgh' size.
	
	self assert: editor wordAtCaret equals: 'fgh'! !

!RubSelectionTest methodsFor: 'running' stamp: ''!
testCaretInTheMiddleOfWordHasWordUpToCaret

	"Word is abcde. Put caret after $c"
	editor selectAt: 1 + 'abc' size.
	
	self assert: editor wordAtCaret equals: 'abc'! !

!RubSelectionTest methodsFor: 'running' stamp: ''!
testCaretAtBeginningHasNoWordAtCaret

	editor selectAt: 1.
	
	self assert: editor wordAtCaret isEmpty! !

!RubSelectionTest methodsFor: 'running' stamp: ''!
testCaretInBetweenTwoWordsHasNoWordAtCaret

	"Words are abcde fghi. Put caret after space, just before $f"
	editor selectAt: 1 + 'abcde ' size.
	
	self assert: editor wordAtCaret isEmpty! !

!RubSelectionTest methodsFor: 'running' stamp: ''!
testCaretInTheEndOfSecondWordHasSecondWordUpToCaret

	"Words are abcde fghi. Put caret after space, just before $i"
	editor selectAt: 1 + 'abcde fghi' size.
	
	self assert: editor wordAtCaret equals: 'fghi'! !

!RubSelectionTest methodsFor: 'running' stamp: ''!
testCaretInTheEndOfWordHasWordUpToCaret

	"Word is abcde. Put caret after $e"
	editor selectAt: 1 + 'abcde' size.
	
	self assert: editor wordAtCaret equals: 'abcde'! !

!RubSelectionTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	editor := RubTextEditor forTextArea: RubTextFieldArea new.
	"Add text with three words"
	editor addString: 'abcde fghi jklm'.! !

!RubShoutStylerDecorator commentStamp: ''!
I am the shout styler decorator for a text area, I highlight the text !
!RubShoutStylerDecorator methodsFor: 'accessing' stamp: ''!
text
	^ next text! !

!RubShoutStylerDecorator methodsFor: 'editing' stamp: ''!
stylerStyled: styledCopyOfText
	next ifNil: [ ^ self ].
	(text notNil and:[text string = styledCopyOfText string])
		ifFalse: [ ^ self ].
	text runs: styledCopyOfText runs.
	"must take care to recompose. If not, the textArea 
	markIndex and pointIndex may be inconsistent"
	self paragraph 
		recomposeFrom: replaceStart 
		to: replaceStart + text size - 1 
		delta: text size - (replaceStop - replaceStart + 1).	
			
	"The selection and then the cursor bounds has to be updated 
	to take possible text attribute changes into account"
	
	self updateTextArea! !

!RubShoutStylerDecorator methodsFor: 'shout' stamp: ''!
shoutAboutToStyle: myself 
	^ self paragraph textArea shoutAboutToStyle: myself! !

!RubShoutStylerDecorator methodsFor: 'shout' stamp: ''!
minTextSizeForStylingInBackground
	^ self class minTextSizeForStylingInBackground! !

!RubShoutStylerDecorator methodsFor: 'accessing' stamp: ''!
text: aText
	self okToStyle
		ifFalse: [ ^ next text: aText ].
	self
		disableDrawingWhile: [
			aText addAttribute: self defaultFontChange.
			next text: (text := (self styler format: aText)).
			replaceStart := 1.
			replaceStop := text size.
			self style: text]! !

!RubShoutStylerDecorator methodsFor: 'accessing' stamp: ''!
next: aDecorator
	super next: aDecorator.
	aDecorator ifNotNil: [ 
		self paragraph textArea announcer
			when: RubTextAcceptRequest
			send: #whenTextAcceptRequest:
			to: self 
	]! !

!RubShoutStylerDecorator methodsFor: 'editing' stamp: ''!
replaceFrom: start to: stop with: aText
	self okToStyle
		ifFalse: [ ^ next replaceFrom: start to: stop with: aText ].
		
	self paragraph disableDrawingWhile: [
		
		aText addAttribute: self paragraph defaultFontChange.
		text ifNil: [ text := self text ].
		text replaceFrom: start to: stop with: (self styler format: aText).
		replaceStart := start.
		replaceStop := stop.
		self style: text.
		next text: text.
		
		self paragraph ifNotNil: [ :paragraph |
			paragraph recomposeFrom: start to: start + aText size - 1 delta: aText size - (stop - start + 1).
			paragraph textArea paragraphWasComposedFrom: start to: start + aText size - 1.
			paragraph textArea paragraphReplacedTextFrom: start to: stop with: aText 
		]
	
	]! !

!RubShoutStylerDecorator methodsFor: 'editing' stamp: ''!
style: aText
	"we can do background styling with (self styler styleInBackgroundProcess: aText), but it is not safe"

	"on error just do nothing. Raising an error during styling may lead to an inconsistent
	state for the RubParagraph and its composer"

	[ ^ self styler style: aText ]
		on: Error
		do: [ :ex | 
			ex traceCr.
			^ aText ]! !

!RubShoutStylerDecorator methodsFor: 'accessing' stamp: ''!
beForSmalltalkScripting
	self styler workspace: self model! !

!RubShoutStylerDecorator methodsFor: 'event handling' stamp: ''!
whenTextAcceptRequest: anAnnouncement

	self refreshStyling! !

!RubShoutStylerDecorator methodsFor: 'accessing' stamp: ''!
classOrMetaClass: aBehavior
	"set the classOrMetaClass in the receiver's styler to aBehavior"
		
	self styler classOrMetaClass: aBehavior! !

!RubShoutStylerDecorator methodsFor: 'editing' stamp: ''!
stylerStyledInBackground: styledCopyOfText
	text ifNil: [ ^self ].
	self stylerStyled: styledCopyOfText.
! !

!RubShoutStylerDecorator methodsFor: 'event handling' stamp: ''!
refreshStyling

	" shout for the whole text "
	(next notNil and: [self okToStyle])
		ifTrue: [ self text: self text ]! !

!RubShoutStylerDecorator methodsFor: 'accessing' stamp: ''!
okToStyle
	^ self shoutEnabled and: [ self shoutAboutToStyle: self ]! !

!RubShoutStylerDecorator methodsFor: 'private' stamp: ''!
shoutEnabled
	^ SHPreferences enabled! !

!RubShoutStylerDecorator methodsFor: 'accessing' stamp: ''!
styler: aTextStyler

	styler := aTextStyler.
	styler view: self.	! !

!RubShoutStylerDecorator methodsFor: 'private' stamp: ''!
updateTextArea

	| textArea |
	
	textArea := self paragraph textArea.
	
	textArea recomputeSelection.
	textArea cursor updateBounds.
	
	(textArea scrollPane ifNil: [ textArea ]) changed! !

!RubShoutStylerDecorator methodsFor: 'accessing' stamp: ''!
styler
	"The styler responsible for highlighting text in the receiver"
	^ styler ifNil: [styler := self defaultStyler]! !

!RubShoutStylerDecorator methodsFor: 'accessing' stamp: ''!
defaultStyler
	^SHRBTextStyler new view: self; yourself! !

!RubShoutStylerDecorator methodsFor: 'private' stamp: ''!
aboutToBeUnplugged

	self paragraph ifNotNil: [ :paragraph |
		paragraph textArea announcer unsubscribe: self 
	]! !

!RubShoutStylerDecorator class methodsFor: 'settings' stamp: ''!
minTextSizeForStylingInBackground
	^ MinTextSizeForStylingInBackground ifNil: [ MinTextSizeForStylingInBackground := 4000 ]! !

!RubShoutStylerDecorator class methodsFor: 'querying' stamp: ''!
key
	^ #shoutStyler! !

!RubShoutStylerDecorator class methodsFor: 'settings' stamp: ''!
rubricSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #minTextSizeForStylingInBackground)
		target: self;
		parent: #Rubric;
		default: 4000;
		description: 'Set the minimum text size imposed to allow background styling';
		label: 'Min text size for background styling'! !

!RubShoutStylerDecorator class methodsFor: 'settings' stamp: ''!
minTextSizeForStylingInBackground: anInteger
	MinTextSizeForStylingInBackground := anInteger! !

!RubSmalltalkCodeMode commentStamp: ''!
I represent the mode to use for editing smalltalk code!
!RubSmalltalkCodeMode methodsFor: 'shout' stamp: ''!
updateStyler

	self textArea ifNil: [ ^ self ].
	self textArea shoutStyler ifNotNil: [ :s | s classOrMetaClass: classOrMetaclass ]! !

!RubSmalltalkCodeMode methodsFor: 'update' stamp: ''!
updateTextAreaWhenPlugged
	self withShoutStyler.
	super updateTextAreaWhenPlugged

! !

!RubSmalltalkCodeMode methodsFor: 'shout' stamp: ''!
shoutAboutToStyle: myShoutStyler
	^ self model isNil
		or: [ 
			(self model interactionModel respondsTo: #shoutAboutToStyle:) not
				or: [ self model interactionModel shoutAboutToStyle: self ] ] ! !

!RubSmalltalkCodeMode methodsFor: 'shout' stamp: ''!
hasBindingOf: aString
	" For the shout styler "
	^ self model notNil and: [ self model hasBindingOf: aString ]! !

!RubSmalltalkCodeMode methodsFor: 'shout' stamp: ''!
shoutStyler
	^ self textArea shoutStyler! !

!RubSmalltalkCodeMode methodsFor: 'shout' stamp: ''!
bindingOf: varName
	^ self model bindingOf: varName! !

!RubSmalltalkCodeMode methodsFor: 'helper' stamp: ''!
formatMethodCode
	| source tree formatted |
	source := self textArea text asString.
	tree := RBParser parseMethod: source onError: [ :msg :pos | ^ self ].
	formatted := tree formattedCode.
	formatted = source
		ifTrue: [ ^ self ].
	self textArea updateTextWith: formatted! !

!RubSmalltalkCodeMode methodsFor: 'update' stamp: ''!
updateTextAreaWhenUnplugged
	self textArea withoutShoutStyler.
	super updateTextAreaWhenUnplugged

! !

!RubSmalltalkCodeMode methodsFor: 'shout' stamp: ''!
withoutShoutStyler
	self textArea withoutDecoratorNamed: #shoutStyler! !

!RubSmalltalkCodeMode methodsFor: 'shout' stamp: ''!
withShoutStyler
	self textArea withDecoratorNamed: #shoutStyler.
	self updateStyler.! !

!RubSmalltalkCodeMode methodsFor: 'shout' stamp: ''!
classOrMetaClass: aBehavior
	"set the classOrMetaClass in the receiver's styler to aBehavior"
	classOrMetaclass := aBehavior.
	self updateStyler! !

!RubSmalltalkCodeMode methodsFor: 'parsing' stamp: ''!
parseSource: aString

	^RBParser parseFaultyMethod: aString! !

!RubSmalltalkCodeMode methodsFor: 'parsing' stamp: ''!
parseExpression: aString

	^RBParser parseFaultyExpression: aString! !

!RubSmalltalkCodeMode methodsFor: 'shout' stamp: ''!
bindings
	^ self model bindings! !

!RubSmalltalkCodeMode class methodsFor: 'menu' stamp: ''!
menuOn: aBuilder
	"Specify the menu used when writing code."

	<contextMenu>
	<RubSmalltalkCodeMenu>
	(aBuilder item: #'Do it' translated)
		order: 1;
		keyText: 'd';
		selector: #doIt;
		help: nil;
		iconName: #smallDoItIcon.
	(aBuilder item: #'Print it' translated)
		keyText: 'p';
		selector: #printIt;
		help: nil;
		iconName: #smallPrintItIcon.
	(aBuilder item: #'Inspect it' translated)
		keyText: 'i';
		selector: #inspectIt;
		help: nil;
		iconName: #smallInspectItIcon.
	(aBuilder item: #'Basic Inspect it' translated)
		keyText: 'I';
		selector: #basicInspectIt;
		help: nil;
		iconName: #smallInspectItIcon.
	(aBuilder item: #'Debug it' translated)
		keyText: 'D';
		selector: #debugIt;
		help: nil;
		iconName: #smallDebugIcon.
	(aBuilder item: #'Profile it' translated)
		selector: #tallyIt;
		iconName: #smallDebugIcon;
		withSeparatorAfter.
	(aBuilder item: #'Find...' translated)
		keyText: 'f';
		selector: #find;
		help: nil;
		iconName: #smallFindIcon.
	(aBuilder item: #'Find again' translated)
		keyText: 'g';
		selector: #findAgain;
		help: nil;
		iconName: #smallFindIcon.
	self extendedSearchMenuOn: aBuilder.
	(aBuilder item: #'Redo' translated)
		keyText: 'Z';
		selector: #redo;
		help: nil;
		iconName: #smallRedoIcon.
	(aBuilder item: #Undo translated)
		keyText: 'z';
		selector: #undo;
		help: nil;
		iconName: #smallUndoIcon;
		withSeparatorAfter.
	(aBuilder item: #Copy translated)
		keyText: 'c';
		selector: #copySelection;
		help: nil;
		iconName: #smallCopyIcon.
	(aBuilder item: #Cut translated)
		keyText: 'x';
		selector: #cut;
		help: nil;
		iconName: #smallCutIcon.
	(aBuilder item: #Paste translated)
		keyText: 'v';
		selector: #paste;
		help: nil;
		iconName: #smallPasteIcon.
	(aBuilder item: #'Paste Recent' translated)
		selector: #pasteRecent;
		help: nil;
		iconName: #smallCopyIcon;
		withSeparatorAfter.
	aBuilder model
		ifNotNil: [ :mod | 
			mod model
				ifNotNil: [ (aBuilder item: #Accept translated)
						keyText: 's';
						selector: #accept;
						iconName: #smallOkIcon.
					(aBuilder item: #Cancel translated)
						keyText: 'l';
						selector: #cancel;
						iconName: #smallCancelIcon ] ]! !

!RubSmalltalkCodeMode class methodsFor: 'menu' stamp: ''!
editingModeMenuOn: aBuilder
	"Specify the menu used to select an editing mode"

	<contextMenu>
	<RubEditingModeMenu>
	(aBuilder item: self label translated)
		action: [:model | model textArea editingMode: self new]! !

!RubSmalltalkCodeMode class methodsFor: 'menu' stamp: ''!
menuKeyword
	^ 'RubSmalltalkCodeMenu'! !

!RubSmalltalkCodeMode class methodsFor: 'accessing' stamp: ''!
label
	^ 'Smalltalk code'! !

!RubSmalltalkCommentMode commentStamp: ''!
I represent the mode to use for editing class comments!
!RubSmalltalkCommentMode methodsFor: 'helper' stamp: ''!
formatMethodCode
	"do nothing for code comments"! !

!RubSmalltalkCommentMode methodsFor: 'testing' stamp: ''!
isCompletionEnabled
	^ false! !

!RubSmalltalkCommentMode methodsFor: 'parsing' stamp: ''!
parseSource: aString 

	^ RBParser parseFaultyExpression: aString! !

!RubSmalltalkCommentMode methodsFor: 'parsing' stamp: ''!
parseExpression: aString 
	
	^ RBParser parseFaultyExpression: aString! !

!RubSmalltalkCommentMode class methodsFor: 'menu' stamp: ''!
menuOn: aBuilder
	"Specify the menu used when writing code. Try it with:
	(PragmaMenuBuilder 
		pragmaKeyword: 'RubSmalltalkCommentMenu'
		model: RubEditingArea new) menu popUpInWorld
	"

	<contextMenu>
	<RubSmalltalkCommentMenu>
	RubSmalltalkCodeMode menuOn: aBuilder ! !

!RubSmalltalkCommentMode class methodsFor: 'menu' stamp: ''!
menuKeyword
	^ 'RubSmalltalkCommentMenu'! !

!RubSmalltalkCommentMode class methodsFor: 'accessing' stamp: ''!
label
	^ 'Smalltalk comment'! !

!RubSmalltalkEditor commentStamp: ''!
I am the editor for smalltalk code, I allow to browse, execute etc!
!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
evaluateSelectionAndDo: aBlock
	"Treat the current selection as an expression; evaluate it and invoke aBlock with the result.
	If no selection is present select the current line."

	self lineSelectAndEmptyCheck: [^ ''].
	^ self 
		evaluate: self selectionForDoitAsStream 
		andDo: aBlock! !

!RubSmalltalkEditor methodsFor: 'private' stamp: ''!
modelCurrentSelectedClass
	" ugly dispatch, but current Browser protocol names aren't really cool "
	" for Nautilus ( and other tools), selectedClass sounds better, but I think it shouldn't be hardcoded "
	" IT'S A TEMP SOLUTION -- BenjaminVanRyseghem 14/04/11"

	" From now, all tools should use #selectedBehavior, waiting for a better solution - Thx Nice "
	(self model interactionModel respondsTo: #selectedBehavior)
		ifTrue: [^ self model interactionModel selectedBehavior ].
	
	" old selectors in order of uses "
	(self model respondsTo: #selectedClass)
		ifTrue: [^ self model selectedClass ].
	(self model respondsTo: #selectedClassOrMetaClass)
		ifTrue: [ ^ self model selectedClassOrMetaClass ].
	
		
	^ nil! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
printIt
	"Treat the current text selection as an expression; evaluate it. Insert the 
	description of the result of evaluation after the selection and then make 
	this description the new text selection."

	| printString |
	self
		evaluateSelectionAndDo: [ :result | 
			printString := [ result printString ]
				on: Error
				do: [ '<error in printString: try ''Inspect it'' to debug>' ].
			self afterSelectionInsertAndSelect: printString ]! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
debug: aStream
	| method receiver context |
	(self model respondsTo: #doItReceiver)
		ifTrue: [ receiver := self model doItReceiver.
			context := self model doItContext ]
		ifFalse: [ receiver := context := nil ].
	method := self compile: aStream for: receiver in: context.
	method ifNil: [ ^self ].
	method isReturnSpecial
		ifTrue: [ self inform: 'Nothing to debug, the expression is optimized'.
			^ self ].
	 self debug: method receiver: receiver in: context! !

!RubSmalltalkEditor methodsFor: 'new selection' stamp: ''!
nextTokenFrom: start direction: dir
	"simple token-finder for compiler automated corrections"
	| loc str |
	loc := start + dir.
	str := self string.
	[(loc between: 1 and: str size) and: [(str at: loc) isSeparator]]
		whileTrue: [loc := loc + dir].
	^ loc! !

!RubSmalltalkEditor methodsFor: 'completion engine' stamp: ''!
atCompletionPosition
	"Return true if the cursor is at a possible completion position"
	| cursorPosition |
	cursorPosition := self startIndex.
	cursorPosition < 2 ifTrue: [ ^ false ].
	^ (self text at: cursorPosition - 1) isCompletionCharacter! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
methodCaseSensitiveStringsContainingit
	"Open a browser on methods which contain the current selection as part of a string constant."

	self lineSelectAndEmptyCheck: [^ self].
	
	self model systemNavigation  browseMethodsWithString: self selection string matchCase: true! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
evaluate: aStream andDo: aBlock
	"Treat the current selection as an expression; evaluate it and invoke aBlock with the result."
	| result rcvr ctxt |
	(self model respondsTo: #doItReceiver) 
		ifTrue: [ rcvr := self model doItReceiver.
				ctxt := self model doItContext]
		ifFalse: [ rcvr := ctxt := nil].
	result := rcvr class compiler
			source: aStream;
			context: ctxt;
			receiver: rcvr;
			requestor: self morph  "don't set it to self.. The receiver can be destroyed as a result of evaluateSelection";
			failBlock:  [self morph flash. ^ nil];
			evaluate.		
			
	^ aBlock value: result! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
classCommentsContainingIt
	"Open a browser class comments which contain the current selection somewhere in them."

	self lineSelectAndEmptyCheck: [^ self].
	self model systemNavigation  browseClassCommentsWithString: self selection string matchCase: false. ! !

!RubSmalltalkEditor methodsFor: 'completion engine' stamp: ''!
isCompletionEnabled
	CompletionEngineClass ifNil: [ ^false ].
	CompletionEngineClass isCompletionEnabled ifFalse: [ ^false ].
	^ self editingMode isCompletionEnabled! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
jumpToNextKeywordOfIt
	"Jump to the next keyword after the cursor - this is for legacy support"

	self jumpToNextKeywordOfIt: true! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
debug: aCompiledMethod receiver: anObject in: evalContext

	| process suspendedContext |
	process := [ 
	           aCompiledMethod
		           valueWithReceiver: anObject
		           arguments:
		           (evalContext
			            ifNil: [ #(  ) ]
			            ifNotNil: [ { evalContext } ]) ] newProcess.
	suspendedContext := process suspendedContext.
	(OupsDebugRequest newForContext: suspendedContext)
		process: process;
		compiledMethod: aCompiledMethod;
		label: 'debug it';
		submit! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
browseClassOfExpression
 	"Launch a browser for the class of the current selection, i.e. if you select 1+2 then you will get a class browser on class Point. Notice that this method handles also when the expression is a class."
	
 	self evaluateSelectionAndDo: [:result | result class instanceSide browse ].
	^ true! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
methodNamesContainingIt: aKeyboardEvent
	"Browse methods whose selectors containing the selection in their names"

	self methodNamesContainingIt.
	^ true! !

!RubSmalltalkEditor methodsFor: 'new selection' stamp: ''!
computeSelectionIntervalForCurrentLine
	| i left right s quoteCounter|
	s := self string.
	i := s encompassParagraph: self selectionInterval.
	left := i first.
	right := i last.
	"we need to skip all text that is inside of quote pairs"
	quoteCounter := 0.
	[ left <= right and: [ (s at: left) = $"
			or: [ quoteCounter % 2 = 1
				or: [(s at: left) isSeparator] ] ] ]
		whileTrue: [ 
			(s at: left) = $" ifTrue: [ quoteCounter := quoteCounter + 1 ].
			left := left + 1 ].
	quoteCounter := 0.
	[ left <= right and: [ ((s at: right) = $"
			"we need to stop if quote is defined as character"
			and: [ right - 1 < 1 or: [ (s at: right - 1) ~= $$ ] ])
				or: [ quoteCounter % 2 = 1 or: [(s at: right) isSeparator] ] ] ]
		whileTrue: [
			(s at: right) = $" ifTrue: [ quoteCounter := quoteCounter + 1 ].
			right := right - 1 ].
	^ left to: right! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
referencesToIt: aKeyboardEvent
	"Triggered by Cmd-N; browse references to the current selection"

	self referencesToIt.
	^ true! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
implementorsOfIt
	"Open an implementors browser on the selected selector"

	| aSelector |
	(aSelector := self selectedSelector) ifNil: [^ textArea flash].
	aSelector isCharacter ifTrue: [^ textArea flash].
	self implementorsOf: aSelector! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
jumpToNextKeywordOfIt: isForwardJump
	"Jump to the next/previous keyword after the cursor"

	self
		findNextKeywordIn: self textArea string
		selection: self textArea selectionInterval
		searchingForward: isForwardJump
		ifFound: [ :foundIndex | self selectFrom: foundIndex + 1 to: foundIndex ]! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
browseClassFrom: aClassString
	"Launch a hierarchy browser for the class indicated by the current selection.  If multiple classes matching the selection exist, let the user choose among them."

	| selectedClass |
	"self lineSelectAndEmptyCheck: [ ^ self ]."
	( aClassString isNil or: [ aClassString isEmpty ] )
		ifTrue: [ textArea flash.
			^ self ].

	selectedClass := self model systemNavigation
		classFromPattern: aClassString
		withCaption: 'choose a class to browse...'.
	selectedClass ifNil: [ ^ self internalCallToImplementorsOf: aClassString ].
	Smalltalk tools browser openOnClass: selectedClass! !

!RubSmalltalkEditor methodsFor: 'typing/selecting keys' stamp: ''!
displayIfTrue: aKeyboardEvent
	"Replace the current text selection with the text 'ifTrue:'--initiated by 
	ctrl-t."

	self addString: 'ifTrue:'.
	^false! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
tallyIt

	^ self tallySelection! !

!RubSmalltalkEditor methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	notificationStrategy := RubTextInsertionStrategy new editor: self! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
methodNamesContainingIt
	"Open a browser on methods names containing the selected string"

	self lineSelectAndEmptyCheck: [ ^ self ].
	Cursor wait
		showWhile: [ self model interactionModel systemNavigation
				browseMethodsWhoseNamesContain: self selection string trimBoth ]! !

!RubSmalltalkEditor methodsFor: 'private' stamp: ''!
editingMode
	^self textArea editingMode! !

!RubSmalltalkEditor methodsFor: 'new selection' stamp: ''!
notify: aString at: anInteger in: aStream 
	^ self notificationStrategy 
		notify: aString 
		at: anInteger 
		in: aStream 
! !

!RubSmalltalkEditor methodsFor: 'private' stamp: ''!
computeSelectionIntervalFromCodeIn: aString at: anInterval
	^ (RBParser parseExpression: (aString copyFrom: anInterval first to: anInterval last)) sourceInterval! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
tallyHighlight
	"Treat the current highlight as an expression; evaluate and tally it."
	
	self highlightAndEmptyCheck: [ ^ self ].
	self tally: self highlightedTextAsStream
	
! !

!RubSmalltalkEditor methodsFor: 'source navigation' stamp: ''!
bestNodeInTextArea
	"Find the best node in the editor text area at the current pointer location"
	
	| node start stop |
	
	start := self textArea startIndex.
	stop := self textArea stopIndex.
	
	[node := RBParser parseMethod: self textArea string onError: [ 
		RBParser parseFaultyExpression: self textArea string]
	] on: Error do: [^nil].
	
	^node bestNodeFor: (start to: stop).
	! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
doIt
	"Set the context to include pool vars of the model.  Then evaluate."
	^ self evaluateSelection! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
sendersOfIt: aKeyboardEvent
	"Triggered by Cmd-n; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw"

	self sendersOfIt.
	^ true! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
internalCallToBrowse: aSelector
	"Launch a browser for the class indicated by the given selector. 
	If multiple classes matching the selection exist, let the user choose among them."
	| aClass |
	aClass := self model systemNavigation 
				classFromPattern: aSelector
				withCaption: 'choose a class to browse...'.
	aClass ifNil: [^ self].
	Smalltalk tools browser openOnClass: aClass! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
debugIt: aKeyboardEvent
	"Evaluate the current selection in the Debugger."

	self debugIt.
	^ true! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
inspectIt: aKeyboardEvent
	"Inspect the selection -- invoked via cmd-i.  If there is no current selection, use the current line.  1/17/96 sw
	 2/29/96 sw: don't call selectLine; it's done by inspectIt now"

	self inspectIt.
	^ true! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
basicInspectIt
	self evaluateSelectionAndDo: [:result | result basicInspect]! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
selectedSelector
	"Try to make a selector out of the current text selection"

	| extractor |
	extractor := CNSelectorExtractor new.
	self hasSelection ifFalse: [ 
		| source ast |

		source := self textArea string.
		ast := self editingMode parseSource: source.

		^ extractor extractSelectorFromAST: ast atPosition: self textArea startIndex
	].

	^ extractor extractSelectorFromSelection: self selection string! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
tallySelection
	"Treat the current selection as an expression; evaluate and tally it."

	self lineSelectAndEmptyCheck: [ ^ self ].
	self lineSelectAndEmptyCheck: [ ^ self ].
	self tally: self selectionAsStream
	
! !

!RubSmalltalkEditor methodsFor: 'completion engine' stamp: ''!
completionAround: aBlock keyStroke: anEvent
	"I'm a editor for Smalltalk, so, do completion around"
	
	self isCompletionEnabled ifFalse: [  ^aBlock value ].
	
	(completionEngine handleKeystrokeBefore: anEvent editor: self) ifTrue:  [^ self ].
	
	aBlock value.	
	completionEngine handleKeystrokeAfter: anEvent editor: self
! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
save: aKeyboardEvent
	"Submit the current text.  Equivalent to 'accept' 1/18/96 sw"

	self closeTypeIn.
	self accept.
	^ true! !

!RubSmalltalkEditor methodsFor: 'completion engine' stamp: ''!
textArea: atextArea

	atextArea setCompletionEngine: self completionEngine.
	super textArea: atextArea.! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
evaluateSelection
	"Treat the current selection as an expression; evaluate it and return the result"
	
	^self evaluateSelectionAndDo: [:result | result]! !

!RubSmalltalkEditor methodsFor: 'typing/selecting keys' stamp: ''!
displayIfFalse: aKeyboardEvent
	"Replace the current text selection with the text 'ifFalse:'--initiated by 
	ctrl-f."

	self addString: 'ifFalse:'.
	^false! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
inspectIt
	self evaluateSelectionAndDo: [:result | result inspect]! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
methodStringsContainingit
	"Open a browser on methods which contain the current selection as part of a string constant."

	self lineSelectAndEmptyCheck: [ ^ self ].
	self model interactionModel systemNavigation
		browseMethodsWithString: self selection string
		matchCase: false! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
classNamesContainingIt
	"Open a browser on classes whose names contain the selected string"

	self lineSelectAndEmptyCheck: [^self].
	self model systemNavigation 
		browseClassesWithNamesContaining: self selection string
		caseSensitive: World currentHand shiftPressed! !

!RubSmalltalkEditor methodsFor: 'binding' stamp: ''!
bindingOf: aString
	^ self textArea bindingOf: aString! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
paste
	"Paste the text from the shared buffer over the current selection and 
	redisplay if necessary.  Undoer & Redoer: undoAndReselect."
	| node character escapedText |
	"This method is specialized for Pharo code.
	If paste happens in the context of a comment or a string, the pasted contents should be properly escaped."
	
	"Get the AST node corresponding to where we are going to paste.
	If there is a selection, cut it off, because pasting it will over-write it, and get the AST node at the cut position.
	This is specially important when the selection spans multiple scopes (e.g., it starts inside a comment and finished in the middle of another)."
	node := self bestNodeInTextAreaWithoutSelection.

	"The pasted text could be inserted in some context requiring escaping, e.g., a comment, a string.
	If so, get the escaping character, and escape the pasted text before pasting it."
	character := self getEscapeCharacterFromAst: node.
	escapedText := (self shouldEscapeCharacter: character)
		  ifTrue: [ self escapeCharacter: character inString: self clipboardText ]
		  ifFalse: [ self clipboardText ].
	
	self replace: self selectionInterval with: escapedText and:
		[self selectAt: self pointIndex]! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
debugIt

	^ self debugSelection! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
methodSourceContainingIt
	"Open a browser on methods which contain the current selection in their source (case-sensitive full-text search of source)."

	self lineSelectAndEmptyCheck: [ ^ self ].
	self model interactionModel systemNavigation
		browseMethodsWithSourceString: self selection string
		matchCase: false! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
debugHighlight
	"Treat the current highlight as an expression; evaluate and debugg it in a new debugger."

	self highlightAndEmptyCheck: [ ^ self ].
	self debug: self highlightedTextAsStream! !

!RubSmalltalkEditor methodsFor: 'private' stamp: ''!
computeSelectionIntervalFromCommentIn: aString at: anInterval
	| comment commentInterval |
	comment := (RBScanner on: (aString copyFrom: anInterval first to: anInterval last) readStream) getComments.
	comment ifNil: [ ^ 0 to: -1 ].
	commentInterval := comment first.
	^ commentInterval first + 1 to: commentInterval last - 1! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
implementorsOf: aSelector
	"Open an implementors browser on the given selector"

	(self model systemNavigation allImplementorsOf: aSelector) isEmpty
		ifTrue: [ self internalCallToBrowse: aSelector ]
		ifFalse: [ self model interactionModel systemNavigation browseAllImplementorsOf: aSelector ]! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
methodStringsContainingIt: aKeyboardEvent
	"Invoked from cmd-E -- open a browser on all methods holding string constants containing it."

	self methodStringsContainingit.
	^ true! !

!RubSmalltalkEditor methodsFor: 'source navigation' stamp: ''!
findNextKeywordIn: sourceCode selection: selectionInterval searchingForward: isFwd ifFound: textSelectionBlock
	"Find the next keyword/useful source location to then apply a @textSelectionBlock to.
	Anser the result of the @textSelectionBlock"
	
	| checkBlock ranges potentialLocation selectionEnd|
	
	"match on typical locations you jump to in source to complete typing. We use regex to more 
	easily cope with broken source code (where its very handy to jump while fixing code) - 
	and get initial location hints which can then use an ast to infer on. It might be possible
	to do this completely with the AST, but this was an easier starting point"
	
	ranges := sourceCode allRangesOfRegexMatches: 
		'\S+\:\s|', "ifTrue1: I...."
		'\:=\s*|', "x := Iself ..."
		'\|\s*|', "[ :var | Iself...]"
		'\:\S+|', "[ :varI :var2I | ..."
		'\;\s+|', " self msg1; Imsg2...." 
		'\,\s*|', " 'string1', I'string 2'...."
		
		'\)|', " 4 + 5)I ifTrue..."
		'\]|', " true and: [ true ]I )..."
		'\^\s*|', "  ^ Iself"
		'self\s+|', "self Imsg"
			
		"Note sure if these ones cause over-jumping, so currently excluded"
		"'\[\s*|'," "[ Iself msg1... ]"
		"'\(\s*|'," "( I5 + 2..."
		
		"Should insist on whitespace after a $. or do we want to jump between {1.2.3}?"
		'\.\s+'.  "self msg1. Iself msg2..."

	selectionEnd := selectionInterval 
		ifEmpty: [selectionInterval first]
		ifNotEmpty: [selectionInterval last].
	
	isFwd
		ifTrue: [ checkBlock := [ :match | match last > selectionEnd ] ]
		ifFalse: [ ranges := ranges reversed.
			checkBlock := [ :match | match last < (selectionEnd - 1) ] ].
		
	ranges
		do: [ :match | 
			(checkBlock value: match)
				ifTrue: [ 
					potentialLocation := match last.
					self
						findValidKeywordIn: sourceCode
						at: potentialLocation
						ifFound: [ 
								^textSelectionBlock value: potentialLocation] ] ].

		
	"If nothing found, then jump to end of any current selection"
	selectionInterval isEmpty 
		ifTrue: [ textSelectionBlock value: 
			(isFwd ifTrue: [sourceCode size] ifFalse: [ 0 ]) ]
		ifFalse: [ textSelectionBlock value: selectionEnd ]! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
doIt: aKeyboardEvent
	"Called when user hits cmd-d.  Select the current line, if relevant, then evaluate and execute.  2/1/96 sw.
	2/29/96 sw: don't call selectLine; it's done by doIt now"
	
	self doIt.
	^ true! !

!RubSmalltalkEditor methodsFor: 'typing support' stamp: ''!
keyDown: aKeyboardEvent

	self completionAround: [super keyDown: aKeyboardEvent ] keyDown: aKeyboardEvent
	! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
selectedSymbol
	"Return the currently selected symbol, or nil if none.  Spaces, tabs and returns are ignored"

	| aString |
	self hasCursor ifTrue: [^self findSelectorFromAST].
	aString := self selection string copyWithoutAll:
		{Character space.  Character cr.  Character tab}.
	aString size = 0 ifTrue: [^ nil].
	Symbol hasInterned: aString ifTrue: [:sym | ^sym].

	^ nil! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
selectionString
	"remove the initial and final quote marks, if present"
	"'''h''' withoutWrappingDoubleQuotes"
	| quote selection  |
	selection :=  self selection string trimBoth .
	selection size < 2 ifTrue: [ ^ selection ].
	quote := selection first.
	^ quote = $"
		ifTrue: [ selection copyFrom: 2 to: selection size - 1 ]
		ifFalse: [ selection ].! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
sendersOfIt
	"Open a senders browser on the selected selector"

	| selectedSelector syst |
	(selectedSelector := self selectedSelector) ifNil: [ ^ textArea flash ].
	syst := self model interactionModel systemNavigation.
	syst browseAllSendersOrUsersOf: selectedSelector! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
tally: aStream
	"Treat the current selection as an expression; evaluate and tally it."
	| receiver context v compiledMethod profiler |
	(self model respondsTo: #doItReceiver) 
		ifTrue: 
			[receiver := self model doItReceiver.
			context := self model doItContext]
		ifFalse:
			[receiver := context := nil].
	compiledMethod := self compile: aStream for: receiver in: context.
	compiledMethod ifNil: [^ self].
	profiler := TimeProfiler spyOn: [ v:= compiledMethod valueWithReceiver: receiver arguments: #()].
	profiler showResult: v.
	
! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
compileSelectionFor: anObject in: evalContext
	^ self compile: self selectionAsStream for: anObject in: evalContext! !

!RubSmalltalkEditor methodsFor: 'source navigation' stamp: ''!
findClassFromAST
	"Try to make a class name out of the current text selection"

	| node fallbackBlock className |		
	"Preserve original behavior - although could consider building AST from selection"
	self hasSelection ifTrue: [ 
		^(self selection string copyWithoutAll: CharacterSet crlf) trimBoth ].
	fallbackBlock := [^nil].
	node := self bestNodeInTextAreaOnError: fallbackBlock.
	[node isVariable] whileFalse: [ 
	 	(node := node parent) ifNil: fallbackBlock ].
	className := node name.
	[ className first isUppercase ] whileFalse: [ 
		(className := className allButFirst) ifEmpty: fallbackBlock  ].
	^className! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
selectionForDoitAsStream
	"Answer a ReadStream on the text in the paragraph that is currently
	selected. "
	^ ReadWriteStream
		on: self string
		from: self startIndex 
		to: self stopIndex - 1! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
copySelection
	"Copy the current selection and store it in the paste buffer, unless a caret.  Undoer & Redoer: undoCutCopy"

	| node escapingCharacter selection |
	"Research of selected node for eventual nesting of comment or string."
	self lineSelectAndEmptyCheck: [^ self].
	node := self bestNodeInTextArea.
	escapingCharacter := self getEscapeCharacterFromAst: node.
	
	selection := (escapingCharacter notNil and: [ 
		"The node, if a comment or a string, should entirely contain the selection.
		We convert the node source interval to an open interval to ignore the node delimiters."
		node sourceInterval asOpenInterval includesAll: self selectionInterval ])
			ifTrue: [ self selection asString unescapeCharacter: escapingCharacter ]
			ifFalse: [ self selection asString ].
	self clipboardTextPut: selection.
	self editingState previousInterval: self selectionInterval.
! !

!RubSmalltalkEditor methodsFor: 'new selection' stamp: ''!
bestNodeInTextAreaWithoutSelection
	"Find the best node in the editor text area trimming the selection to prepare for eventual deletion"
	
	| node start stop intervalTrimmedText |
	
	start := self textArea startIndex.
	stop := self textArea stopIndex.
	intervalTrimmedText := start = stop 
					ifFalse: [ 	| beginning end |
									beginning := end := ''.
									start <= 1 ifFalse: [ beginning := self textArea string copyFrom: 1 to: start - 1 ].
									stop >= self textArea text size ifFalse: [ end :=  self textArea string copyFrom: stop + 1 to: self textArea text size ].
									beginning,end ]
					 ifTrue: [ self textArea string ].
		
	node := self isScripting
		ifTrue: [ RBParser parseFaultyExpression: intervalTrimmedText ]
		ifFalse: [ RBParser parseFaultyMethod: intervalTrimmedText ].

	^node bestNodeFor: (start to: start)! !

!RubSmalltalkEditor methodsFor: 'completion engine' stamp: ''!
completionAround: aBlock keyDown: anEvent
	"I'm a editor for Smalltalk, so, do completion around"
	
	self isCompletionEnabled ifFalse: [  ^aBlock value ].
	
	(completionEngine handleKeyDownBefore: anEvent editor: self) ifTrue:  [^ self ].
	
	aBlock value.
	
	completionEngine handleKeyDownAfter: anEvent editor: self
! !

!RubSmalltalkEditor methodsFor: 'source navigation' stamp: ''!
findValidKeywordIn: sourceCode at: locationIndex ifFound: aBlock
	"find a valid keyword in the source, starting at @locationIndex. If a suitable node is found,
	evaluate the Block"
	
	| node validLocation locationInterval |
	
	validLocation := true.
	locationInterval := locationIndex to: locationIndex.
	
	node := self
		bestNodeInString: sourceCode
		at: locationInterval
		editingMode: self editingMode 
		shouldFavourExpressions: false
		onError: [ nil ].
		
	node
		ifNotNil: [ 
			node isLiteralNode
				ifTrue: [ validLocation := false ].
			node isCommentNode ifTrue: [ validLocation := false ] ].
			
	validLocation ifTrue: aBlock 
			! !

!RubSmalltalkEditor methodsFor: 'accessing' stamp: ''!
notificationStrategy
	^ notificationStrategy! !

!RubSmalltalkEditor methodsFor: 'accessing' stamp: ''!
notificationStrategy: aStrategy
	notificationStrategy := aStrategy.
	aStrategy editor: self! !

!RubSmalltalkEditor methodsFor: 'typing support' stamp: ''!
keystroke: aKeyboardEvent

	self completionAround: [super keystroke: aKeyboardEvent ] keyStroke: aKeyboardEvent
	! !

!RubSmalltalkEditor methodsFor: 'source navigation' stamp: ''!
findSelectorFromAST
	"Try to make a selector out of the current text selection"

	| node fallbackBlock |

	fallbackBlock := [ ^ nil ].
	node := self bestNodeInTextAreaOnError: fallbackBlock.
	
	node isMethod ifFalse: [ 
		(node isValue and: [ node value isSymbol ]) ifTrue: [ ^node value ].
				
		[ node isMessage ] whileFalse: [ 
	 		(node := node parent) ifNil: fallbackBlock ]].
	
	^node selector! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
format
	self model formatSourceCodeInView! !

!RubSmalltalkEditor methodsFor: 'testing' stamp: ''!
isSmalltalkEditor
	^ true ! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
sendersOf: selectedSelector
	" opens a Browser on the given selector"
	self model systemNavigation browseAllSendersOf: selectedSelector! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
compile: aStream for: anObject in: evalContext
	| methodClass |
	methodClass := evalContext
		ifNil: [ anObject class ]
		ifNotNil: [ evalContext methodClass ].
	^self class compiler
		source: aStream;
		class: methodClass;
		context: evalContext;
		requestor: self morph;
		noPattern: true;
		failBlock: [ ^ nil ];
		compile! !

!RubSmalltalkEditor methodsFor: 'new selection' stamp: ''!
selectPrecedingIdentifier
	"Invisibly select the identifier that ends at the end of the selection, if any."

	| string sep stop tok |
	tok := false.
	string := self string.
	stop := self stopIndex - 1.
	[stop > 0 and: [(string at: stop) isSeparator]] whileTrue: [stop := stop - 1].
	sep := stop.
	[sep > 0 and: [(string at: sep) tokenish]] whileTrue: [tok := true. sep := sep - 1].
	tok ifTrue: [self selectInvisiblyFrom: sep + 1 to: stop]! !

!RubSmalltalkEditor methodsFor: 'completion engine' stamp: ''!
completionEngine: aCompletionEngine

	completionEngine := aCompletionEngine.
	self textArea ifNotNil: [:txtArea | txtArea setCompletionEngine: aCompletionEngine] ! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
implementorsOfIt: aKeyboardEvent
	"Triggered by Cmd-m; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw"

	self implementorsOfIt.
	^ true! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
pasteInitials: aKeyboardEvent 
	"Replace the current text selection by an authorship name/date stamp; invoked by cmd-shift-v, easy way to put an authorship stamp in the comments of an editor."

	self closeTypeIn.
	self replace: self selectionInterval with: (Text fromString: Author changeStamp) and: [self selectAt: self stopIndex].
	^ true! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
widenSelectionIn: sourceCode selection: selectionInterval ifFound: selectionBlock
	"Extend the current highlight selection using knowledge of the AST and cursor location"
	| node start stop comments cursorIndex |
	
	node := self 
		bestNodeInString: sourceCode 
		at: selectionInterval 
		editingMode: self editingMode 
		shouldFavourExpressions: true 
		onError: [ ^nil ].
	
	cursorIndex := selectionInterval last.
	selectionInterval
		ifNotEmpty: [ 
			node parent ifNotNil: [ node := node parent ].
			node isSequence ifTrue: [ node := node parent]].
	
	start := node start.
	stop := node stop max: cursorIndex - 1.
	
	comments := OrderedCollection new.
	RBCommentNodeVisitor visit: node do: [ :cmnts | comments add: cmnts ].

	comments 
		detect: [ :c | c start < cursorIndex and: [ c stop >= cursorIndex ] ] 
		ifFound: [ :c | start := c start. stop := c stop ].
	
	"Handle cascaded messages"
	node isMessage ifTrue: [
		(node isCascaded) 
			ifTrue: [ | i cascadeStart|
				(i := node parent messages indexOf: node) > 1 
					ifTrue: [ 
						cascadeStart := (node parent semicolons at: i - 1).
						cascadeStart < cursorIndex ifTrue: [ start := cascadeStart ]]]
			ifFalse: [
				"Try to select the first chained message send - experimental"
				"self hasSelection ifFalse: [ 
					start := node receiver stop + 1.
					node hasParentheses ifTrue: [stop := stop - 1]]"]].
			
	selectionBlock value: (start to: stop)! !

!RubSmalltalkEditor methodsFor: 'source navigation' stamp: ''!
bestNodeInString: source at: selectionInterval editingMode: aRubEdittingMode shouldFavourExpressions: isFavouringExpressions onError: aBlock
	"Find the best node in the source text in the identified selection area"
	
	| ast node start stop |

	source ifEmpty: aBlock.
	start := selectionInterval first min: source size.
	stop := selectionInterval last min: source size.
	
	ast := aRubEdittingMode parseSource: source.
	
	ast ifNotNil: [ 
		"If there is no text selection"
		(selectionInterval isEmpty and: [ isFavouringExpressions and: [ 
			(source at: (stop + 1 min: source size)) isAlphaNumeric not ]]) ifTrue: [ 
				"If there is white space or statement terminator, try to backup to find a better node"		
				[stop > 0 and: [('.;' includes: (source at: stop)) or: [(source at: stop) isSeparator ]]]
					whileTrue: [ start := stop := stop - 1 ].
				start := stop].
		node := ast bestNodeFor: (start to: stop).
		
		node ifNil: [ 
			node := RBParseErrorNodeVisitor
				visit: ast 
				detect: [ :n | n intersectsInterval: (start to: start)]
				ifNone: [ ^aBlock value ]].
		
		node isFaulty ifTrue: [ 
			node allChildren size = 1 ifTrue: [ 
				(aRubEdittingMode parseExpression: (node value padLeftTo: source size)) 
					ifNil: [ ^node ] 
					ifNotNil: [ :newNode |
						ast replaceNode: node withNode: newNode.
						node := newNode ].
				].
			
			node := RBGenericNodeVisitor 
				visit: node 
				detect: [ :n | n intersectsInterval: (start to: start) ] 
				ifNone: [ node ] ] ].
	

	^node
! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
referencesToIt
	"Open a references browser on the selected symbol"

	| aSymbol |
	"self selectLine."
	(aSymbol := self selectedSymbol) ifNil: [^ textArea flash].

	self referencesTo: aSymbol! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
exploreIt: aKeyboardEvent
	"Explore the selection -- invoked via cmd-shift-I.  If there is no current selection, use the current line."
	
	self exploreIt.
	^ true! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
exploreIt
	self evaluateSelectionAndDo: [:result | result inspect]! !

!RubSmalltalkEditor methodsFor: 'completion engine' stamp: ''!
completionEngine

	^ completionEngine ifNil: [
		CompletionEngineClass ifNotNil: [
			self completionEngine: CompletionEngineClass new.
			completionEngine ] ]! !

!RubSmalltalkEditor methodsFor: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher
	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: RubSmalltalkEditor name! !

!RubSmalltalkEditor methodsFor: 'private' stamp: ''!
isWordCharacterAt: index in: aString
	"By default, group alphanumeric and non-alphanumeric separately"
	| character |
	character := aString at: index.
	"In smalltalk code, colons make part of selectors too and are part of a word"
	^ character isAlphaNumeric or: [
		"Check that it is a keyword selector.
		 - followed by a colon
		 - but not by an assignment "
		character = $: and: [ 
			aString size > index
				and: [  (aString at: index + 1) ~= $= ] ] ]! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
debugSelection
	"Treat the current selection as an expression; evaluate and debugg it in a new debugger."
	
	self lineSelectAndEmptyCheck: [^self].
	self debug: self selectionAsStream! !

!RubSmalltalkEditor methodsFor: 'source navigation' stamp: ''!
bestNodeInTextAreaOnError: aBlock
	"Find the best node in the editor text area at the current pointer location"

	| start stop source |
	start := self textArea startIndex.
	stop := self textArea stopIndex.

	source := self textArea string.

	^ self
		bestNodeInString: source
		at: (start to: stop)
		editingMode: self editingMode
		shouldFavourExpressions: true
		onError: aBlock! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
browseFullClass
	"Launch a browser for the class indicated by the current selection. Note that if the selection is a valid expression it will browse the class of the result. If multiple classes matching the selection exist, let the user choose among them."
	

	"previous code was: self browseClassFrom: self findClassFromAST"
	self browseClassOfExpression ! !

!RubSmalltalkEditor methodsFor: 'testing' stamp: ''!
isScripting
	^ self editingMode isScripting! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
referencesTo: aVariableOrClassName
	"Open a references browser on the given symbol"
	| env ref |

	" ugly dispatch, but current Browser protocol names aren't really cool "
	env := self modelCurrentSelectedClass ifNil: [ Smalltalk globals ].

	env isBehavior ifTrue: [
		(env hasSlotNamed: aVariableOrClassName) ifTrue: [
		 ^ self systemNavigation browseAllAccessesTo: aVariableOrClassName from: env]].

	ref:= (env bindingOf: aVariableOrClassName) ifNil: [ ^ self ].
	
	self systemNavigation browseAllSendersOf: ref! !

!RubSmalltalkEditor methodsFor: 'accessing' stamp: ''!
selectionPosition: aString

	| startIndex |
	startIndex := self startIndex.
	^[
		| bottomLeft topLeft index |
		index := startIndex - aString size.
		self selectInvisiblyFrom: index to: index - 1.
		bottomLeft := textArea cursor bottomLeft.
		topLeft := textArea owner positionInWorld.
		topLeft + bottomLeft - textArea offset]
			ensure: [ self selectInvisiblyFrom: startIndex to: startIndex - 1 ]! !

!RubSmalltalkEditor methodsFor: 'editing keys' stamp: ''!
browseFullClassIt: t1 

	self browseFullClass.
	^ true! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
internalCallToImplementorsOf: aSelector
	"Open an implementors browser on the given selector"
	
	 (self model systemNavigation allImplementorsOf: aSelector) isEmpty
				ifFalse: [ self model systemNavigation browseAllImplementorsOf: aSelector]
			
	! !

!RubSmalltalkEditor methodsFor: 'menu messages' stamp: ''!
widenSelectionOfIt
	"Extend the current highlight selection using knowledge of the AST and cursor location"
	self 
		widenSelectionIn: self textArea string
		selection: self selectionInterval
		ifFound: [ :interval | self selectInterval: interval ]! !

!RubSmalltalkEditor methodsFor: 'do-its' stamp: ''!
highlightEvaluateAndDo: aBlock
	"Treat the current selection as an expression; evaluate it and invoke aBlock with the result."
	
	self highlightAndEmptyCheck: [ ^ '' ].
	^ self 
		evaluate: self highlightedTextAsStream
		andDo: [:result | aBlock value: result]! !

!RubSmalltalkEditor class methodsFor: 'completion engine' stamp: ''!
noCompletion

	CompletionEngineClass := nil! !

!RubSmalltalkEditor class methodsFor: 'keymapping' stamp: ''!
buildShortcutsOn: aBuilder
	"We are defining the bindings twice because we want to support 
	both Cmd and meta for Windows and Linux. This should happen at least as long as in the development environment
	both of these are supported.
	
	We list both variations explicitly because we want to be able to see the action code when inspecting the morph.
	"

	<keymap>	
	(aBuilder shortcut: #browseFullClass)
		category: RubSmalltalkEditor name
		default: $b meta
		do: [ :target | target editor browseFullClass ]
		description: 'Browse'.
	
	(aBuilder shortcut: #doIt)
		category: RubSmalltalkEditor name
		default: $d meta
		do: [ :target | target editor doIt: nil ]
		description: 'Do it'.
	
	(aBuilder shortcut: #inspectIt)
		category: RubSmalltalkEditor name
		default: $i meta
		do: [ :target | target editor inspectIt: nil ]
		description: 'Inspect it'.
	
	(aBuilder shortcut: #basicInspectIt)
		category: RubSmalltalkEditor name
		default: $i meta shift
		do: [ :target | target editor basicInspectIt ]
		description: 'Basic Inspect it'.
	
	(aBuilder shortcut: #implementorsOfIt)
		category: RubSmalltalkEditor name
		default: $m meta
		do: [ :target | target editor implementorsOfIt: nil ]
		description: 'Implementors of it'.
	
	(aBuilder shortcut: #senderOfIt)
		category: RubSmalltalkEditor name
		default: $n meta
		do: [ :target | target editor sendersOfIt: nil ]
		description: 'Senders of it'.
	
	(aBuilder shortcut: #printIt)
		category: RubSmalltalkEditor name
		default: $p meta
		do: [ :target | target editor printIt ]
		description: 'Print it'.
	
	(aBuilder shortcut: #debugIt)
		category: RubSmalltalkEditor name
		default: $d meta shift
		do: [ :target | target editor debugIt: nil ]
		description: 'Debug it'.
	
	(aBuilder shortcut: #referencesToIt)
		category: RubSmalltalkEditor name
		default: $n meta shift
		do: [ :target | target editor referencesToIt: nil ]
		description: 'References to it'.
	
	(aBuilder shortcut: #methodStringsContainingIt)
		category: RubSmalltalkEditor name
		default: $e meta shift
		do: [ :target | target editor methodStringsContainingIt: nil ]
		description: 'Method strings containing it'.
	
	(aBuilder shortcut: #format)
		category: RubSmalltalkEditor name
		default: PharoShortcuts current formatCodeShortcut
		do: [ :target | target formatMethodCode ].
		
	
	(aBuilder shortcut: #jumpToNextKeywordOfIt)
		category: RubSmalltalkEditor name
		default: $j meta
		do: [ :target | target editor jumpToNextKeywordOfIt: true ]
		description: 'Jump to next keyword'.
		
	(aBuilder shortcut: #jumpToNextKeywordOfIt)
		category: RubSmalltalkEditor name
		default: $j shift meta
		do: [ :target | target editor jumpToNextKeywordOfIt: false ]
		description: 'Jump to previous keyword'.
		
	(aBuilder shortcut: #widenSelectionOfIt)
		category: RubSmalltalkEditor name
		default: $2 meta
		do: [ :target | target editor widenSelectionOfIt ]
		description: 'Widen selection'.
	! !

!RubSmalltalkEditor class methodsFor: 'completion engine' stamp: ''!
completionEngineClass: anEngine
	
	CompletionEngineClass := anEngine! !

!RubSmalltalkEditor class methodsFor: 'completion engine' stamp: ''!
completionEngineClass
	
	^ CompletionEngineClass! !

!RubSmalltalkEditorTest commentStamp: ''!
A RubSmalltalkEditorTest is a test class for testing the behavior of RubSmalltalkEditor!
!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidCascadeMidStatement

	self source: 'testMethod
	^self
		msg1;
		msg2;
		msg3'.
	
	self 
		positionAfter: 'msg2;';
		assertNodeSelector: #msg2
	
! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertJumpsToPostionAfter: aString direction: isFwd
	self assertJumpsToPostionAfter: aString direction: isFwd playground: false! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenOnErroneousMethod
	"Should be able to intelligently jump on source that doesn't yet compile"
	
	self source: 'testMethod
	
	self msg1.
		
	1 + 300

	(String new: 5)
'.
	
	self 
		positionAfter: '300';
		assertWidensToRegex: '300' playground: false.
		
	self 
		positionSelection: '300';
		assertWidensToRegex: '1 \+ 300' playground: false.
	! !

!RubSmalltalkEditorTest methodsFor: 'helpers' stamp: ''!
positionBefore: aString
	self positionBefore: aString offset: 0
	! !

!RubSmalltalkEditorTest methodsFor: 'helpers' stamp: ''!
positionBefore: aString offset: aNumber
	| pos |
	
	pos := (self source findString: aString) + aNumber.
	self selection: (pos to: pos - 1).
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnErroneousMethod
	"Should be able to intelligently jump on source that doesn't yet compile"
	
	self source: 'testMethod
	
	self msg1.
		
	1 + 300

	(String new: 5)
'.
	
	self 
		positionBefore: 'msg1';
		assertJumpsToPostionBefore: '1 + 300' direction: true.
	self 
		positionBefore: '1 + 300';
		assertJumpsToPostionAfter: 'new: ' direction: true.
		
	self 
		positionBefore: 'new:';
		assertJumpsToPostionBefore: '1 +' direction: false.
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidPostionOnStatementPeriodEnd

	self source: 'testMethod
	2 / 3.
	^5 + 9.'.
	
	self 
		positionAfter: '3.';
		assertNodeValue: 3
	
! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithInvalidMethodIncompleteMidSourceNearPreviousMessage
	
	self source: 'testMethod
	self msg1.
		
	1 + 300
	^self'.
	
	self 
		positionBefore: '1 +' offset: -2;
		assertNodeSelector: #msg1 description: 'should backup to closest node unaffected by error'.
! !

!RubSmalltalkEditorTest methodsFor: 'helpers' stamp: ''!
executeBestPlaygroundNodeFor: aSelector
	^ self executeBestNodeFor: aSelector editingMode: RubSmalltalkScriptingMode new! !

!RubSmalltalkEditorTest methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!RubSmalltalkEditorTest methodsFor: 'helpers' stamp: ''!
widenSelectionWithMode: aRubEditingMode ifFound: aBlock 

	| textArea |
	textArea := RubEditingArea new.
	textArea editingMode: aRubEditingMode.
	
	^ RubSmalltalkEditor new
		textArea: textArea;
		widenSelectionIn: self source
			selection: self selection
			ifFound: aBlock! !

!RubSmalltalkEditorTest methodsFor: 'tests - completion' stamp: ''!
testExplicitCompletionEngineIgnoresAbsenceOfGlobalClass

	| textEditor |
	textEditor := RubSmalltalkEditor new.
	RubSmalltalkEditor noCompletion.
	textEditor completionEngine: 17.
	self assert: textEditor completionEngine equals: 17! !

!RubSmalltalkEditorTest methodsFor: 'helpers' stamp: ''!
executeBestNodeFor: aSelector
	^ self executeBestNodeFor: aSelector editingMode: RubSmalltalkCodeMode new! !

!RubSmalltalkEditorTest methodsFor: 'accessing' stamp: ''!
source: aString
	source := aString! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertNodeSelector: aSelector
	| node |
	
	node := self executeBestNodeFor: aSelector.

	self assert: node selector equals: aSelector! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertNodeSelector: aSelector description: aString
	self assertNodeSelector: aSelector! !

!RubSmalltalkEditorTest methodsFor: 'accessing' stamp: ''!
selection: anInterval
	selection := anInterval! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testPlaygroundJumpOnIfTrueIfFalseAfterCompletion
	"Source jumping should work in bother browser and playground"
	
	self source: 'true ifTrue:  ifFalse: '.

	self 
		positionAfter: 'ifTrue: ';
		assertJumpsToPostionAfter: 'ifFalse: ' direction: true playground: true.

	self 
		positionAfter: 'ifFalse: ';
		assertJumpsToPostionAfter: 'ifTrue: ' direction: false playground: true.
! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidPostionOnReturningMethodEnd

	self source: 'testMethod
	^5 + 9'.
	
	self 
		positionAfter: '9';
		assertNodeValue: 9! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenOnSelf
	"Should widen selection after self to easily select code on a self message send"
	
	self source: 'testMethod
	self 
		msg1;
		msg2
'.
	
	self 
		positionBefore: 'msg1';
		assertWidensToRegex: 'self.+msg1' playground: false.
		
	self 
		positionBefore: 'msg2';
		assertWidensToRegex: ';.*msg2' playground: false
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenOnCascade
	"Should widen on cascaded messages"
	
	self source: 'testMethod
	self 
		msg1;
		msg2;
		msg3
'.
	
	self 
		positionBefore: 'msg2';
		assertWidensToRegex: ';.*msg2' playground: false.
		
	self 
		positionAfter: 'msg3';
		assertWidensToRegex: ';.*msg3' playground: false.
		
	self 
		positionSelection: 'msg2';
		assertWidensToRegex: 'self.*msg3' playground: false.
	! !

!RubSmalltalkEditorTest methodsFor: 'running' stamp: ''!
tearDown

	RubSmalltalkEditor completionEngineClass: currentCompletion.
	super tearDown.! !

!RubSmalltalkEditorTest methodsFor: 'helpers' stamp: ''!
executeBestNodeFor: aSelector editingMode: aRubEdittingMode
	^ RubSmalltalkEditor new
		bestNodeInString: self source
		at: self selection
		editingMode: aRubEdittingMode
		shouldFavourExpressions: true
		onError: [ self assert: false description: 'node not found for: ' , aSelector ]! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithInvalidPlaygroundIncompleteMidSource
	
	self source: '
	self msg1.
		
	1 + 300
	^self'.
	
	self 
		positionAfter: '300';
		assertNodeValue: 300.
! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidPlayground
	self source: '5 + 100'.
	
	self 
		positionAfter: '100';
		assertPlaygroundNodeValue: 100
	
! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnSecondKeyword
	"Should jump between multiple keywords"
	
	self source: 'testMethod
	self multiKeywordMsg: 5 with: 10.
'.
	
	self 
		positionAfter: 'KeywordMsg: ';
		assertJumpsToPostionAfter: 'with: ' direction: true.
		
	"Should also jump if right next to : (and an empty selection)"
	self 
		positionAfter: 'KeywordMsg:';
		assertJumpsToPostionAfter: 'with: ' direction: true.
		
	self 
		positionAfter: 'with: ';
		assertJumpsToPostionAfter: 'KeywordMsg: ' direction: false.
		
	"Should also jump if right next to : (and an empty selection)"
	self 
		positionAfter: 'with:';
		assertJumpsToPostionAfter: 'KeywordMsg: ' direction: false.
! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertWidensToRegex: aString playground: isPlayground
	| text mode |
	
	mode := isPlayground ifTrue: [ RubSmalltalkScriptingMode new  ] ifFalse: [ RubSmalltalkCodeMode new ].
	self
		widenSelectionWithMode: mode ifFound: [ :interval | 
			text := self source copyFrom: interval first to: (interval last min: self source size).
			^ self assert: (text matchesRegex: aString) description: 'The selected text node "', text, '", doesn''t match: "', aString, '"' ].
			
	self assert: false description: 'Did not find a selection node for, "' , aString , '"'! !

!RubSmalltalkEditorTest methodsFor: 'helpers' stamp: ''!
executeFindNextKeywordDirection: isFwd editingMode: aRubEditingMode onFound: aBlock

	| textArea |
	textArea := RubEditingArea new.
	textArea editingMode: aRubEditingMode.
	
	^ RubSmalltalkEditor new
			textArea: textArea;
			findNextKeywordIn: self source 
			selection: self selection 
			searchingForward: isFwd 
			ifFound: aBlock! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertNodeValue: anObject
	| node |
	
	node := self executeBestNodeFor: anObject printString.

	self assert: node value equals: anObject ! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenOnComments
	"Should jump to next postion but ignore any keywords in comments"
	
	self source: 'testMethod
	"some comments with keyword:selector: that should be ignored"
	
	self 
		msg1; "Another comment with ignored:selector: to skip"
		msg2
'.
	
	self 
		positionAfter: 'comments';
		assertWidensToRegex: '"some.*ignored"' playground: false.
		
	self 
		positionSelection: 'keyword:selector:';
		assertWidensToRegex: '"some.*ignored"' playground: false
		
	! !

!RubSmalltalkEditorTest methodsFor: 'accessing' stamp: ''!
selection
	^ selection! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertNodeVariable: anObject
	| node |
	
	node := self executeBestNodeFor: anObject printString.

	self assert: node name equals: anObject ! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithInvalidMethodIncompleteMidSourceNearNextMessage
	
	self source: 'testMethod
	self msg1.
		
	1 + 300
	
	^self'.
	
	self 
		positionBefore: '^self' offset: -1;
		assertNodeValue: 300.
! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertNodeValue: anObject description: aString
	self assertNodeValue: anObject ! !

!RubSmalltalkEditorTest methodsFor: 'helpers' stamp: ''!
positionAfter: aString
	| pos |
	
	pos := (self source findString: aString) + aString size.
	self selection: (pos to: pos - 1).
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testPlaygroundWidenOnCascade
	"Should widen on cascaded messages"
	
	self source: '
	5 + 4.
	self 
		msg1;
		msg2;
		msg3
'.
	
	self 
		positionBefore: 'msg2';
		assertWidensToRegex: ';.*msg2' playground: true.
		
	self 
		positionAfter: 'msg3';
		assertWidensToRegex: ';.*msg3' playground: true.
		
	self 
		positionSelection: 'msg2';
		assertWidensToRegex: 'self.*msg3' playground: true.
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testPlaygroundWidenOnSelf
	"Should widen selection after self to easily select code on a self message send"
	
	self source: 'self 
		msg1;
		msg2
'.
	
	self 
		positionBefore: 'msg1';
		assertWidensToRegex: 'self.+msg1' playground: true.
		
	self 
		positionBefore: 'msg2';
		assertWidensToRegex: ';.*msg2' playground: true
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidPostionOnMethodPeriodEnd

	self source: 'testMethod
	2 / 3.
	^5 + 9.'.
	
	self 
		positionAfter: '9.';
		assertNodeValue: 9
		! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertJumpsToPostionBefore: aString direction: isFwd playground: isPlayground
	| text mode |

	mode := isPlayground ifTrue: [ RubSmalltalkScriptingMode new  ] ifFalse: [ RubSmalltalkCodeMode new ].	
	self
		executeFindNextKeywordDirection: isFwd
		editingMode: mode
		onFound: [ :loc | 
			text := self source first: (self source size min: loc + aString size).
			^ self
				assert: (text endsWith: aString)
				description: 'The source location didnt finish before: ' , aString , ' in ' , text ].
			
	self assert: false description: 'Did not jump to correct location before, [' , aString , ']'! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithInvalidEmptySource
	
	self source: ''.
	
	self 
		positionAfter: '';
		assertNodeError.
! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testPlaygroundJumpOnErroneousSource
	"Should be able to intelligently jump on source that doesn't yet compile"
	
	self source: '	
	self msg1.
		
	1 + 300

	(String new: 5)
'.
	
	self 
		positionBefore: 'msg1';
		assertJumpsToPostionBefore: '1 + 300' direction: true playground: true.
	self 
		positionBefore: '1 + 300';
		assertJumpsToPostionAfter: 'new: ' direction: true playground: true.
		
	self 
		positionBefore: 'new:';
		assertJumpsToPostionBefore: '1 +' direction: false playground: true.
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnNoFurtherStatements
	"Should jump to the very end or beginning when no further matches, so you can easily add more code"
	
	self source: 'testMethod
	self simpleMsg secondMsg'.
	
	self 
		positionAfter: 'self simple';
		assertJumpsToPostionAfter: 'secondMsg' direction: true.
		
	self 
		positionAfter: 'self';
		assertJumpsToPostionBefore: 'testMethod' direction: false.

	
! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenOnKeywordSelector
	"Should jump between multiple keywords"
	
	self source: 'testMethod
	self msg1.
	self multiKeywordMsg: 7 with: 10 + 5.
	self msg2
'.
	
	self 
		positionSelection: '10 + 5';
		assertWidensToRegex: 'self.*5' playground: false.
		
	self 
		positionSelection: '7';
		assertWidensToRegex: 'self.*5' playground: false! !

!RubSmalltalkEditorTest methodsFor: 'helpers' stamp: ''!
positionSelection: aString
	| pos |
	
	pos := (self source findString: aString).
	self selection: (pos to: pos + aString size).
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testPlaygroundWidenOnErroneousSource
	"Should be able to intelligently jump on source that doesn't yet compile"
	
	self source: '
	self msg1.
		
	1 + 300

	(String new: 5)
'.
	
	self 
		positionAfter: '300';
		assertWidensToRegex: '300' playground: true.
		
	self 
		positionSelection: '300';
		assertWidensToRegex: '1 \+ 300' playground: true.
		
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenOnMultipleExpressions
	"Should widen on multiple expressions"
	
	self source: 'testMethod
	x := 1000 + 5.
	^self
'.
	
	self 
		positionBefore: '1000';
		assertWidensToRegex: '1000' playground: false.
		
	self 
		positionSelection: '1000';
		assertWidensToRegex: '1000 \+ 5' playground: false.
		
	self 
		positionSelection: '5';
		assertWidensToRegex: '1000 \+ 5' playground: false.
		! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertJumpsToPostionBefore: aString direction: isFwd
	self assertJumpsToPostionBefore: aString direction: isFwd playground: false! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnAssignment
	"Should position after an asignment giving the possibility to widen selection on the assigned expressions"
	
	self source: 'testMethod
	self simpleMsg.
	x := 1000.
	^self
'.
	
	self 
		positionBefore: 'x :=';
		assertJumpsToPostionAfter: ':= ' direction: true.
		
	self 
		positionAfter: '1000';
		assertJumpsToPostionAfter: ':= ' direction: false.
! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnBlockPipe
	"Should jump after a block variable pipe so its easy to widen selection on the contents"
	
	self source: 'testMethod
	self items inject: OrderedCollection new into: [:item :result | result add: item transformed ].
'.
	
	self 
		positionAfter: ':result';
		assertJumpsToPostionBefore: 'result add:' direction: true.
		
	self 
		positionBefore: 'result add:';
		assertJumpsToPostionAfter: ':result' direction: false.
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithInvalidPlaygroundParsableError
	
	self source: 'fallbackBlock := [^self].
	node := self bestNodeInTextAreaOnError: fallbackBlock.
	
	node isMethod ifFalse: [ 
		node isValue and: [  node isSymbol ]
		[ node isMessage ] whileFalse: [ 
	 		(node := node parent) ifNil: fallbackBlock ]].'.
	
	self 
		positionAfter: 'isSymbol ]';
		assertPlaygroundNodeValue: 'RBBlockNode([ node isSymbol ])'.
! !

!RubSmalltalkEditorTest methodsFor: 'tests - completion' stamp: ''!
testSettingCompletionFromEditorToTextArea

	| textEditor |
	RubSmalltalkEditor completionEngineClass: CompletionEngine.
	textEditor := RubSmalltalkEditor new.
	self assert: textEditor completionEngine class equals: CompletionEngine.
	textEditor textArea: RubEditingArea new. 
	self assert: textEditor textArea completionEngine class equals: CompletionEngine.
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidSimpleMethod

	self source: 'testMethod
	^5 + 100
	'.
	
	self 
		positionAfter: '100';
		assertNodeValue: 100
	
! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnCascade
	"Should be able to jump between cascaded messages"
	
	self source: 'testMethod
	self 
		msg1;
		msg2;
		msg3
'.
	
	self 
		positionBefore: 'msg1';
		assertJumpsToPostionBefore: 'msg2' direction: true.
	self 
		positionBefore: 'msg2';
		assertJumpsToPostionBefore: 'msg3' direction: true.
		
	self 
		positionBefore: 'msg3';
		assertJumpsToPostionBefore: 'msg2' direction: false.
	self 
		positionBefore: 'msg2';
		assertJumpsToPostionBefore: 'msg1' direction: false.
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenOnBrackets
	"Should jump to next postion but ignore any keywords in comments"
	
	self source: 'testMethod
		^5 + ((100 - 70) * 20)
'.
	
	self 
		positionSelection: '70';
		assertWidensToRegex: '\(100 - 70\)' playground: false.
		
	self 
		positionSelection: '(100 - 70)';
		assertWidensToRegex: '\(\(100.*20\)' playground: false.
		
	 self 
		positionSelection: '20';
		assertWidensToRegex: '\(\(100.*20\)' playground: false
		
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - completion' stamp: ''!
testDefaultCompletionEngineUsesGlobalClass

	| textEditor |
	textEditor := RubSmalltalkEditor new.
	self assert: textEditor completionEngine class equals: currentCompletion! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidPlaygroundSimpleMsg
	self source: 'self msg1
	'.
	
	self 
		positionAfter: 'msg1';
		assertPlaygroundNodeSelector: #msg1
	
! !

!RubSmalltalkEditorTest methodsFor: 'tests - completion' stamp: ''!
testExplicitCompletionEngineIgnoresGlobalClass

	| textEditor |
	textEditor := RubSmalltalkEditor new.
	textEditor completionEngine: 17.
	self assert: textEditor completionEngine equals: 17! !

!RubSmalltalkEditorTest methodsFor: 'tests - completion' stamp: ''!
testSettingCompletionFromEditor
	
	RubSmalltalkEditor completionEngineClass: CompletionEngine.
	self assert: RubSmalltalkEditor completionEngineClass equals: CompletionEngine.! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnNoParameterBlock
	"Should jump inside a block [ marker, ready for you to type more expressions into a new block, or easily add a variable into an existing block.
		
	NOTE: This test is currently asserting differently, as empirically it was too fine grained to jump into every block - instead we simply jump to the next valid position inside the block. The implementation regex can be changed if this other behaviour is deemed better"
		
	self source: 'hasBindingThatBeginsWith: aString 
	^ self model notNil and: [ model hasBindingThatBeginsWith: aString ]'.
	
	self 
		positionAfter: ' and: ';
		assertJumpsToPostionBefore: 'aString ]' direction: true.
! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnSelf
	"Should jump after self to easily widen selection on a self message send"
	
	self source: 'testMethod
	self 
		msg1;
		msg2
'.
	
	self 
		positionAfter: 'testMethod';
		assertJumpsToPostionBefore: 'msg1' direction: true.
		
	self 
		positionBefore: 'msg2';
		assertJumpsToPostionBefore: 'msg1' direction: false.
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenInsideBlock
	"Should widen selection inside a block, slowly extending the selection"
	
	self source: 'hasBindingThatBeginsWith: aString 
	^ self model notNil ifTrue: [ true ] ifFalse: [ aString > 10 ]'.
	
	
	self 
		positionSelection: '10';
		assertWidensToRegex: 'aString > 10' playground: false.
		
	self 
		positionSelection: 'aString > 10';
		assertWidensToRegex: '\[ aString > 10 \]' playground: false.
		
	self 
		positionSelection: '[ aString > 10 ]';
		assertWidensToRegex: 'self.*10 \]' playground: false.
		
	
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidValueMidSource

	self source: 'testMethod
	5 + 3.
	7 / 8'.
	
	self 
		positionAfter: '3';
		assertNodeValue: 3
! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidPostionOnMethodEnd
	
	self source: 'testMethod
	5 + 9'.
	
	self 
		positionAfter: '9';
		assertNodeValue: 9
! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidCascadeLastStatement

	self source: 'testMethod
	^self
		msg1;
		msg2;
		msg3'.
	
	self 
		positionAfter: 'msg3';
		assertNodeSelector: #msg3
	
! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidKeywordMessage
	
	self source: 'testMethod
	1 to: 20 do: []'.
	
	self 
		positionAfter: 'to';
		assertNodeSelector: #to:do:
! !

!RubSmalltalkEditorTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	currentCompletion := RubSmalltalkEditor completionEngineClass! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertPlaygroundNodeSelector: aSelector
	| node |
	
	node := self executeBestPlaygroundNodeFor: aSelector.

	self assert: node selector equals: aSelector! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnEndOfBlock
	"Should jump to the end of a block, giving an easy way to extend selection of it"
		
	self source: 'hasBindingThatBeginsWith: aString 
	^ self model notNil ifTrue: [ true ] ifFalse: [ aString > 1 ]'.
	
	self 
		positionAfter: ' true';
		assertJumpsToPostionBefore: ' ifFalse:' direction: true.
! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertJumpsToPostionFor: aString direction: isFwd playground: isPlayground
	| text mode found directionText |
	
	mode := isPlayground
		ifTrue: [ RubSmalltalkScriptingMode new ]
		ifFalse: [ RubSmalltalkCodeMode new ].
		
	self
		executeFindNextKeywordDirection: isFwd
		editingMode: mode
		onFound: [ :loc | 
			isFwd
				ifTrue: [ text := self source first: loc.
					found := text endsWith: aString.
					directionText := 'end with - ' ]
				ifFalse: [ text := self source.
					found := text beginsWith: aString.
					directionText := 'begin with - ' ].
				
			^ self
				assert: found
				description: 'The source location doesn''t ' , directionText , aString , ' in ' , text ].
			
	self assert: false description: 'Did not jump to correct location for, [' , aString , ']'! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertNodeError
	| result |
	result := RubSmalltalkEditor new
		bestNodeInString: self source
		at: self selection
		editingMode: RubSmalltalkCodeMode new
		shouldFavourExpressions: true
		onError: [ ^ true ].

	self
		assert: false
		description: 'Should have got an error not: ' , result printString! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithInvalidPlaygroundIncompleteMidSourceThenBrackets
	
	self source: '
	self msg1.
		
	1 + 300
	(String new)'.
	
	self 
		positionAfter: 'String';
		assertNodeVariable: #String
! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnBlockVariables
	"Should jump after an assignment, so its easy to widen selection on the expression to modify it"
	
	self source: 'testMethod
	self items inject: OrderedCollection new into: [:item :result | result add: item transformed ].
'.
	
	self 
		positionAfter: 'into: ';
		assertJumpsToPostionAfter: ':item' direction: true.
	self 
		positionAfter: ':item';
		assertJumpsToPostionAfter: ':result' direction: true.

	self 
		positionBefore: 'result add:';
		assertJumpsToPostionAfter: ':result' direction: false.
	self 
		positionAfter: ':result';
		assertJumpsToPostionAfter: ':item' direction: false.
! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenOnEndOfBlock
	"Should widen selection at the end of a block to select the whole block"
	
	self source: 'hasBindingThatBeginsWith: aString 
	^ self model notNil ifTrue: [ true ] ifFalse: [ aString > 1 ]'.
	
	
	self 
		positionAfter: 'true ]';
		assertWidensToRegex: '\[ true \]' playground: false.
		
	
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnSimpleKeyword
	
	self source: 'testMethod
self simpleKeywordMsg: 5.
'.
	
	self 
		positionAfter: 'self ';
		assertJumpsToPostionAfter: 'Msg: ' direction: true.
		
	"If we jump when at :, it should jump to the end"
	self 
		positionAfter: 'Msg:';
		assertJumpsToPostionAfter: self source direction: true.
		
	self 
		positionAfter: 'simpleKeywordMsg: ';
		assertJumpsToPostionAfter: 'self ' direction: false.
		
	"If we jump when at :, it should jump to prev"
	self 
		positionAfter: 'simpleKeywordMsg:';
		assertJumpsToPostionAfter: 'self ' direction: false.

! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidBinaryOperation
	
	self source: 'testMethod
	5 + 100'.
	
	self 
		positionAfter: '+';
		assertNodeSelector: #+.
! !

!RubSmalltalkEditorTest methodsFor: 'tests - completion' stamp: ''!
testDefaultCompletionIsNilIfNoGlobalClass

	| textEditor |
	textEditor := RubSmalltalkEditor new.
	RubSmalltalkEditor noCompletion.
	self assert: textEditor completionEngine isNil! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenOnAssignment
	"Should position after an asignment giving the possibility to widen selection on the assigned expressions"
	
	self source: 'testMethod
	self simpleMsg.
	x := 1000.
	^self
'.
	
	self 
		positionAfter: ':=';
		assertWidensToRegex: 'x .*1000' playground: false.
		! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithInvalidMethodIncompleteMidSourceOnMessage
	
	self source: 'testMethod
	self msg1.
		
	1 + 300
	^self'.
	
	self 
		positionAfter: '+';
		assertNodeSelector: #+ description: 'should let you select an operator for implementorsOf etc.'.
! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithInvalidMethodIncompleteMidSourceOnLineEnd
	
	self source: 'testMethod
	self msg1.
		
	1 + 300
	^self'.
	
	self 
		positionAfter: '300';
		assertNodeValue: 300 description: 'should let you select a value you have just typed (e.g. to widen and bracket)'
! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertPlaygroundNodeValue: anObject
	| node |
	
	node := self executeBestPlaygroundNodeFor: anObject printString.

	self assert: node value printString equals: (anObject isString ifTrue: [anObject ] ifFalse: [anObject printString])! !

!RubSmalltalkEditorTest methodsFor: 'tests - bestNodeIn' stamp: ''!
testBestNodeWithValidSelectorMidSource

	self source: 'testMethod
	5 + 3.
	7 / 8'.
	
	self 
		positionAfter: '+';
		assertNodeSelector: #+
		
! !

!RubSmalltalkEditorTest methodsFor: 'assertions' stamp: ''!
assertJumpsToPostionAfter: aString direction: isFwd playground: isPlayground
	| text mode |
	
	mode := isPlayground ifTrue: [ RubSmalltalkScriptingMode new  ] ifFalse: [ RubSmalltalkCodeMode new ].
	self
		executeFindNextKeywordDirection: isFwd
		editingMode: mode
		onFound: [ :loc | 
			text := self source first: loc.
			^ self
				assert: (text endsWith: aString)
				description: 'The source location didnt end with: ' , aString , ' in ' , text ].
			
	self assert: false description: 'Did not jump to correct location after, [' , aString , ']'! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnIfTrueIfFalseAfterCompletion
	"This is the most common jump example, after code completing ifTrue:ifFalse: you want to easily type in an
	expression for each case"
	
	self source: 'testMethod
true ifTrue:  ifFalse: '.

	self 
		positionAfter: 'ifTrue: ';
		assertJumpsToPostionAfter: 'ifFalse: ' direction: true.

	self 
		positionAfter: 'ifFalse: ';
		assertJumpsToPostionAfter: 'ifTrue: ' direction: false.
! !

!RubSmalltalkEditorTest methodsFor: 'tests - widenSelection' stamp: ''!
testWidenOnString
	"Should jump to next postion but ignore any keywords in comments"
	
	self source: 'testMethod
	self 
		msg: ''some string'';
		msg1: ''a string with "a comment text" inside''; "Another comment"
		msg2
'.
	
	self 
		positionAfter: 'some';
		assertWidensToRegex: '\''some string\''' playground: false.
	
	self 
		positionAfter: 'a comment';
		assertWidensToRegex: '\''a string.*inside\''' playground: false.
			
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnComments
	"Should jump to next postion but ignore any keywords in comments"
	
	self source: 'testMethod
	"some comments with keyword:selector: that should be ignored"
	
	self 
		msg1; "Another comment with ignored:selector: to skip"
		msg2
'.
	
	self 
		positionAfter: 'testMethod';
		assertJumpsToPostionBefore: 'msg1' direction: true.
		
	self 
		positionAfter: 'msg1; ';
		assertJumpsToPostionAfter: self source direction: true.
	! !

!RubSmalltalkEditorTest methodsFor: 'tests - copy' stamp: ''!
testCopySelection

	| textArea editor |
	textArea := RubEditingArea new.
	textArea editingMode: RubSmalltalkCodeMode new.

	editor := RubSmalltalkEditor new
		          textArea: textArea;
		          addString: 'aa "asdfasdf"';
		          selectInterval: (5 to: 12). 
	self assert: editor selection equals: 'asdfasdf'.
	self assert: editor selection class equals: Text.
	editor copySelection.! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnEndOfSource
	"Edge case test, ensure it can handle this end of source boundary"
	
	self source: 'testMethod
	self simpleMsg.
	self secondMsg'.
	
	self 
		positionAfter: 'self secondMsg';
		assertJumpsToPostionAfter: 'secondMsg' direction: true.
		
	self 
		positionBefore: 'testMethod';
		assertJumpsToPostionBefore: 'testMethod' direction: false.

! !

!RubSmalltalkEditorTest methodsFor: 'tests - jumpFind' stamp: ''!
testJumpOnReturn
	"Should jump to just after a ^ statement so you can easily widen selection on what will be returned from a method"
	
	self source: 'testMethod
	^ self msg ifTrue: [ 1 ] ifFalse: [myVar refresh. ^nil]
'.
	
	self 
		positionAfter: 'testMethod';
		assertJumpsToPostionBefore: 'self' direction: true.
		
	self 
		positionAfter: '^ self ';
		assertJumpsToPostionBefore: 'self msg' direction: false.
		
	"This one fails as the regex solution has difficulty with single character matches,
		if also trying to account for matching aribtrary keyword: positions. Leaving for now"
	"
	self 
		positionAfter: 'refresh. ';
		assertJumpsToPostionBefore: 'nil' direction: true."
	! !

!RubSmalltalkScriptingMode commentStamp: ''!
I represent the mode to use for editing smalltalk script (class creation script for example)!
!RubSmalltalkScriptingMode methodsFor: 'shout' stamp: ''!
updateStyler
	super updateStyler.
	self textArea shoutStyler beForSmalltalkScripting! !

!RubSmalltalkScriptingMode methodsFor: 'update' stamp: ''!
updateTextAreaWhenPlugged
	super updateTextAreaWhenPlugged.
	self textArea shoutStyler beForSmalltalkScripting! !

!RubSmalltalkScriptingMode methodsFor: 'parsing' stamp: ''!
parseSource: aString

	^RBParser parseFaultyExpression: aString! !

!RubSmalltalkScriptingMode methodsFor: 'testing' stamp: ''!
isScripting
	^ true! !

!RubSmalltalkScriptingMode class methodsFor: 'menu' stamp: ''!
editingModeMenuOn: aBuilder
	"Specify the menu used to select an editing mode"

	<contextMenu>
	<RubEditingModeMenu>
	(aBuilder item: self label translated)
		action: [:model | model textArea editingMode: self new]! !

!RubSmalltalkScriptingMode class methodsFor: 'accessing' stamp: ''!
label
	^ 'Smalltalk script'! !

!RubSurfaceSelectionShape methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	aCanvas drawPolygon: self vertices color: self backgroundColor borderWidth: borderWidth borderColor:  borderColor! !

!RubSurfaceSelectionShape methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ color! !

!RubSurfaceSelectionShape methodsFor: 'drawing' stamp: ''!
bounds
	^ self polygon bounds! !

!RubSurfaceSelectionShape methodsFor: 'accessing' stamp: ''!
firstIndex
	^ firstIndex ! !

!RubSurfaceSelectionShape methodsFor: 'accessing' stamp: ''!
borderWidth
	^ borderWidth! !

!RubSurfaceSelectionShape methodsFor: 'initialization' stamp: ''!
vertices: aCollectionOfPoints firstIndex: firstCharIndex lastIndex: lastCharIndex color: aColor borderWidth: aBorderWidth borderColor: aBorderColor
	firstIndex := firstCharIndex.
	lastIndex := lastCharIndex.
	vertices := aCollectionOfPoints.
	color := aColor.
	borderWidth := aBorderWidth.
	borderColor := aBorderColor! !

!RubSurfaceSelectionShape methodsFor: 'drawing' stamp: ''!
vertices
	^ vertices! !

!RubSurfaceSelectionShape methodsFor: 'accessing' stamp: ''!
lastIndex
	^ lastIndex! !

!RubSurfaceSelectionShape methodsFor: 'drawing' stamp: ''!
polygon
	^ Polygon vertices: self vertices! !

!RubSurfaceSelectionShape methodsFor: 'accessing' stamp: ''!
borderColor
	^ borderColor! !

!RubSurfaceSelectionShape methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: aCanvas
	| path |
	path := aCanvas
		createPath: [ :builder | 
			builder
				absolute;
				moveTo: self vertices first.
			self vertices allButFirstDo: [ :pt | builder lineTo: pt ].
			builder close ].
	aCanvas setShape: path.
	aCanvas setPaint: self backgroundColor.
	aCanvas draw.
	borderWidth > 0
		ifTrue: [ 
			(aCanvas setStrokePaint: borderColor)
				capSquare;
				width: borderWidth.
			aCanvas draw ]! !

!RubSurfaceSelectionShape class methodsFor: 'instance creation' stamp: ''!
vertices: aCollectionOfPoints firstIndex: firstCharBlock lastIndex: lastCharBlock color: aColor borderWidth: aBorderWidth borderColor: aBorderColor
	^ self new
		vertices: aCollectionOfPoints
		firstIndex: firstCharBlock
		lastIndex: lastCharBlock
		color: aColor
		borderWidth: aBorderWidth
		borderColor: aBorderColor
! !

!RubTextAcceptRequest commentStamp: ''!
I am raised when the text is accepted in the view!
!RubTextAccepted commentStamp: ''!
I am raised when the text has been accepted!
!RubTextAccepted methodsFor: 'accessing' stamp: ''!
text 
	^ morph textArea text! !

!RubTextAcceptedInModel commentStamp: ''!
I am raised when the text is accepted in the model side!
!RubTextAreaExamples commentStamp: ''!
RubTextAreaExamples blueTextOnGrayBackgroundNotWrapped.
RubTextAreaExamples blueTextOnGrayBackgroundWrappedTo400.
RubTextAreaExamples blueTextOnGrayBackgroundWrappedTo400Version2.
RubTextAreaExamples profileSourcesFileViewing.
RubTextAreaExamples rightFlushed.
RubTextAreaExamples shoutedScriptingTextArea.
RubTextAreaExamples simplestEmptyNotWrapped.
RubTextAreaExamples simplestEmptyWrappedTo400.
RubTextAreaExamples simplestWrappedTo400.
RubTextAreaExamples smalltalkCodeWrappedTo400.
RubTextAreaExamples sourceCodeTemplateWrappedTo400.
RubTextAreaExamples smalltalkCodeWrappedWithUnderlineSegments.
RubTextAreaExamples textFieldWithCRAction.
RubTextAreaExamples withOnlyThePrimarySelection.
RubTextAreaExamples wrappedTo400WithMarginsOf40.!
!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
autoReactingText
	"self autoReactingText"
	<sampleInstance>
	| area seg blk |
	area := RubEditingArea new
		beWrapped;
		withoutSelectionBar.
	area setTextWith: 'Click or keep the mouse down on [0]'.
	area width: 400.
	seg := RubPlainSegmentMorph inTextArea: area from: 34 to: 35.
	blk := [ seg
		replaceTextWith: (seg getText string asNumber + 1) asString ].
	seg on: #mouseDown send: #value to: blk.
	seg on: #mouseStillDown send: #value to: blk.
	seg beExtendable.
	area addSegment: seg.
	area openInWorld! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
smallLoremIpsumWrappedTo400
	"self smallLoremIpsumWrappedTo400"
<sampleInstance>
	RubEditingArea new
		beWrapped;
		width: 400;
		updateTextWith: self smallLoremIpsum;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
textFieldWithCRAction
	"self textFieldWithCRAction"
<sampleInstance>
	| s |
	s := RubTextFieldArea new
		width: 800;
		setTextWith: 'My contents will be printed in the Transcript when return is entered';
		forbidMenu;
		openInWorld.
	s announcer
		when: RubReturnEntered
		send: #value
		to: [ self trace: s text asString ]! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
blueTextOnGrayBackgroundWrappedTo400Version2
	"self blueTextOnGrayBackgroundWrappedTo400Version2"
	<sampleInstance>
	RubEditingArea new
		beWrapped;
		width: 400;
		updateTextWith:
			((Text fromString: self smallLoremIpsum)
				addAttribute: (TextColor color: Color blue));
		backgroundColor: Color lightGray;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'accessing' stamp: ''!
someSmalltalkCode
	^ self class sourceCodeAt: #show:while:! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
wrappedTo400WithMarginsOf40
	"self wrappedTo400WithMarginsOf40"
<sampleInstance>
	RubEditingArea new
		beWrapped;
		width: 400;
		updateMarginsWith: 40 asMargin;
		updateTextWith: self smallLoremIpsum;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
profileSourcesFileViewing
	"The big test to check that a TextArea is able to compose and ''quickly'' show
	 a big file content "

	<script>
	| contents |
	"Do not profile reading of source file."
	contents := Smalltalk sourcesFile contents.

	TimeProfiler
		spyAllOn: [ RubEditingArea new
				beWrapped;
				width: 600;
				updateTextWith: contents;
				openInWorld ]! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
presentationInput
	<sampleInstance>
	"
	
	self presentationInput.
	
	Thanks to Tudor Girba aka Doru
	Then Shift+Tab makes the editing area appear at the center of the screen.
	Useful to input explanations during a presentation 
	"

	KMRepository reset.
	KMRepository default
		setAsGlobalCategory:
			((KMCategory named: 'Presentation')
				addKeymapEntry:
					(KMKeymap
						shortcut: Character tab shift
						action: [ RubEditingArea new
								beWrapped;
								width: self currentWorld width / 3;
								updateTextWith: '';
								takeKeyboardFocus;
								backgroundColor: Color black;
								cellInset: 50;
								onAnnouncement: MorphLostFocus
									do: [ :ann | ann morph delete ];
								font: (LogicalFont familyName: 'Source Sans Pro' pointSize: 20);
								openCenteredInWorld ]))! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
simplestEmptyNotWrappedWithMaxLength
	"self simplestEmptyNotWrapped"

	<sampleInstance>
	RubEditingArea new
		beNotWrapped;
		maxLength: 10;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
sourceCodeTemplateWrappedTo400
	"self sourceCodeTemplateWrappedTo400"
<sampleInstance>
	ModelForShout := self.
	RubEditingArea new
		model: self;
		beForSmalltalkCode;
		beWrapped;
		width: 400;
		updateTextWith: self sourceCodeTemplate;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'accessing' stamp: ''!
interactionModel
	^ ModelForShout ! !

!RubTextAreaExamples class methodsFor: 'accessing' stamp: ''!
smallLoremIpsum
	^'Lorem ipsum dolor sit amet, consectetur adipiscing elit. Integer nec odio. Praesent libero. Sed cursus ante dapibus diam. Sed nisi. Nulla quis sem at nibh elementum imperdiet. Duis sagittis ipsum. Praesent mauris. Fusce nec tellus sed augue semper porta. Mauris massa. Vestibulum lacinia arcu eget nulla. Class aptent taciti sociosqu ad litora torquent per conubia nostra, per inceptos himenaeos. '! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
someSmallSmalltalkCode
	^ '
WorldState
	addDeferredUIMessage: [ 
		World displayWorldSafely.
		Cursor wait
			showWhile: [ 
				aBlock
					ensure: [ m delete ] ] ]'! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
smalltalkCodeWrappedTo400
	"self smalltalkCodeWrappedTo400"
<sampleInstance>
	| area |
	ModelForShout := self.
	area := RubEditingArea new
		beWrapped;
		model: self;
		width: 400;
		beForSmalltalkCodeWithDefaultFont;
		updateTextWith: self someSmalltalkCode.
	area openInWorld.
	^ area! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
blueTextOnGrayBackgroundWrappedTo400
	"self blueTextOnGrayBackgroundWrappedTo400"
	<sampleInstance>
	RubEditingArea new
		beWrapped;
		width: 400;
		updateTextWith: self smallLoremIpsum;
		backgroundColor: Color lightGray;
		textColor: Color blue;
		font: (LogicalFont familyName: 'Source Sans Pro' pointSize: 20);
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
smalltalkCodeWithStabilo
	"self smalltalkCodeWithStabilo"
<sampleInstance>
	| area seg code |
	area := RubEditingArea new
		beWrapped;
		width: 400;
		updateTextWith: (code := self someSmallSmalltalkCode).
	area
		addSegment: (seg := RubPlainSegmentMorph inTextArea: area from: 3 to: code size).
	seg color: Color yellow.
	seg borderColor: (Color orange alpha: 0.5).
	seg beSmoothCurve.
	area openInWorld! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
simplestEmptyNotWrapped
	"self simplestEmptyNotWrapped"
<sampleInstance>
	RubEditingArea new
		beNotWrapped;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
simplestEmptyTextField
	"self simplestEmptyTextField"
<sampleInstance>
	RubTextFieldArea new
		forbidMenu;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
blueTextOnGrayBackgroundNotWrapped
	"self blueTextOnGrayBackgroundNotWrapped"
	<sampleInstance>
	RubEditingArea new
		backgroundColor: Color lightGray;
		updateTextWith: self smallLoremIpsum;
		textColor: Color blue;
		beNotWrapped;
		width: 400;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'shout' stamp: ''!
shoutAboutToStyle: aStyler
	aStyler classOrMetaClass: ModelForShout.
	^ true! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
shoutedScriptingTextArea
	"self shoutedScriptingTextArea"
	<sampleInstance>
	ModelForShout := nil.
	RubEditingArea new
		beWrapped;
		model: self;
		beForSmalltalkScripting;
		width: 500;
		updateTextWith: self someSmalltalkScript;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'shout' stamp: ''!
hasBindingOf: aString
	^ (self bindingOf: aString) notNil
	! !

!RubTextAreaExamples class methodsFor: 'NOcompletion' stamp: ''!
selectedClassOrMetaClass
	^ ModelForShout class! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
simplestEmptyWrappedTo400
	"self simplestEmptyWrappedTo400"
<sampleInstance>
	RubEditingArea new
		beWrapped;
		width: 400;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'accessing' stamp: ''!
someSmalltalkScript
	^ '" Enter some code here as in a workspace"' , String cr , 'RubTextArea new
		beWrapped;
		smalltalkScriptingModel: self;
		width: 500;
		setTextWith: ''" Enter some code here as in a workspace"'';
		openInWorld'! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
withOnlyThePrimarySelection
	"self withOnlyThePrimarySelection"
<sampleInstance>
	ModelForShout := nil.
	RubEditingArea new
		beWrapped;
		width: 400;
		model: self;
		withoutAnyDecorator;
		updateTextWith: self smallLoremIpsum;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'private' stamp: ''!
show: aMessage while: aBlock
	| m |
	m := RubEditingArea new
		backgroundColor: Color black;
		beReadOnly;
		beWrapped;
		width: 300;
		setTextWith: aMessage;
		font: (LogicalFont familyName: 'Arial' pointSize: 20);
		textColor: Color white;
		openInWorld;
		centered;
		yourself.
	
	[ aBlock ensure: [ m delete ] ] fork.! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
centered

	"self centered"

	<sampleInstance>
	RubEditingArea new
		beWrapped;
		width: 300;
		updateTextWith: 'AAAAAA' , String cr , 'BBBB';
		selectFrom: 5 to: 8;
		centered;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'accessing' stamp: ''!
menu
	^ nil! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
rightFlushed

	"self rightFlushed"

	<sampleInstance>
	^ RubEditingArea new
		  beWrapped;
		  width: 300;
		  updateTextWith: 'AAAAAA' , String cr , 'BBBB';
		  rightFlush;
		  openInWorld;
		  yourself! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
textAreaWithBiggerFont
	" self textAreaWithBiggerFont "

	<sampleInstance>
	RubEditingArea new
		beWrapped;
		width: 400;
		updateTextWith: 'test';
		takeKeyboardFocus;
		font: (LogicalFont familyName: 'Source Sans Pro' pointSize: 20);
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
nicolaiAttributeFix
	<example>
	"self nicolaiAttributeFix"
	| font1 font2 tMorph |
	font1 := TextFontReference toFont: (StrikeFont familyName: 'Bitmap DejaVu Sans' size: 11).
	font2 := TextFontReference toFont: (LogicalFont familyName: 'Source Sans Pro' pointSize: 10).
	{font1.
	font2}
		do: [ :f | 
			| t1 t2 t3 t4 t5 t6 |
			tMorph := RubEditingArea new.
			t1 := 'normal\' withCRs asText addAttribute: f.
			t2 := 'bold\' withCRs asText
				addAttribute: f;
				addAttribute: TextEmphasis bold.
			t3 := 'underline\' withCRs asText
				addAttribute: f;
				addAttribute: TextEmphasis underlined.
			t4 := 'struck out\' withCRs asText
				addAttribute: f;
				addAttribute: TextEmphasis struckOut.
			t5 := 'italic\' withCRs asText
				addAttribute: f;
				addAttribute: TextEmphasis italic.
			t6 := 'narrow\' withCRs asText
				addAttribute: f;
				addAttribute: TextEmphasis narrow.
			tMorph updateTextWith: t1 , t2 , t3 , t4 , t5 , t6.
			tMorph openInWorld ]! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
simplestWrappedTo400
	"self simplestWrappedTo400"
<sampleInstance>
	RubEditingArea new
		beWrapped;
		width: 400;
		updateTextWith: self smallLoremIpsum;
		openInWorld! !

!RubTextAreaExamples class methodsFor: 'examples' stamp: ''!
smalltalkCodeWrappedWithSegments
	"self smalltalkCodeWrappedWithSegments"
<sampleInstance>
	| area s |
	area := self smalltalkCodeWrappedTo400.
	area
		addSegment: (RubUnderlinedSegmentMorph inTextArea: area from: 1 to: 29).
	s := RubUnderlinedSegmentMorph inTextArea: area from: 43 to: 57.
	s straight: false.
	area addSegment: s.
	area
		addSegment: (s := RubUnderlinedSegmentMorph inTextArea: area from: 81 to: 185).
	s color: (Color blue alpha: 0.02).
	s borderColor: Color blue.
	s underlineColor: Color blue.
	area
		addSegment: (s := RubPlainSegmentMorph inTextArea: area from: 300 to: 500).
	s color: Color yellow.
	s borderColor: (Color orange alpha: 0.5).
	s beSmoothCurve.
	s balloonColor: Color yellow.
	s setCenteredBalloonText: 'Please note this deferred execution'.
	area openInWorld! !

!RubTextBackgroundColorSegmentMorph commentStamp: ''!
I am a segmentmorph intended to implement the visual presentation of a TextBackgroundColor for a text.!
!RubTextBackgroundColorSegmentMorph methodsFor: 'accessing' stamp: ''!
color: aColor
	color := aColor! !

!RubTextBackgroundColorSegmentMorph class methodsFor: 'instance creation' stamp: ''!
color: aColor from: start to: stop 
	^ self new
		color: aColor;
		from: start to: stop; 
		yourself! !

!RubTextChanged commentStamp: ''!
I am raised when the text is modified!
!RubTextChanged methodsFor: 'accessing' stamp: ''!
stop
	^ stop! !

!RubTextChanged methodsFor: 'accessing' stamp: ''!
text: aText
	text := aText! !

!RubTextChanged methodsFor: 'accessing' stamp: ''!
stop: anInteger
	stop := anInteger! !

!RubTextChanged methodsFor: 'accessing' stamp: ''!
start
	^ start! !

!RubTextChanged methodsFor: 'accessing' stamp: ''!
start: anInteger
	start := anInteger! !

!RubTextChanged methodsFor: 'accessing' stamp: ''!
from: startIndex to: stopIndex with: aText
	self start: startIndex.
	self stop: stopIndex.
	self text: aText! !

!RubTextChanged methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!RubTextChanged class methodsFor: 'instance creation' stamp: ''!
from: start to: stop with: aText
	^ self new from: start to: stop with: aText! !

!RubTextComposer commentStamp: ''!
I represent the composer of a text, I am used to represent a paragraph!
!RubTextComposer methodsFor: 'private' stamp: ''!
fixupLastLineIfCR
	"This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic."

	(theText size > 0 and: [ CharacterSet crlf includes: theText last ])
		ifFalse: [ ^ self ].
	self addNullLineForIndex: theText size + 1! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
textStyle
	^ theTextStyle ! !

!RubTextComposer methodsFor: 'adding' stamp: ''!
addNullLineWithIndex: index andRectangle: aRectangle
	| nullString nullLine |
	nullString := ' ' asText.
	self emphasisHere do: [ :attr | nullString addAttribute: attr ].
	scanner text: nullString textStyle: theTextStyle.
	nullLine := scanner
		composeFrom: 1
		inRectangle: aRectangle
		firstLine: true
		leftSide: true
		rightSide: false.
	nullLine firstIndex: index lastIndex: index - 1.
	nullLine internalSpaces: 0 paddingWidth: 0.
	nullLine rectangle: ( aRectangle withBottom: nullLine bottom).
	lines addLast: nullLine 
! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
lines: aCollectionOfTextLine
	lines := aCollectionOfTextLine! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
actualWidth
	^ actualWidth! !

!RubTextComposer methodsFor: 'private' stamp: ''!
moveBy: aPoint
	self lines do: [ :line | line moveBy: aPoint ].
	theContainer := theContainer translateBy: aPoint.
	maxRightX := maxRightX + aPoint x! !

!RubTextComposer methodsFor: 'composition' stamp: ''!
replaceFrom: start to: stop with: aText
	"Edit the text, and then recompose the lines."
	self text replaceFrom: start to: stop with: aText.
	self recomposeFrom: start to: start + aText size - 1 delta: aText size - (stop - start + 1).
! !

!RubTextComposer methodsFor: 'private' stamp: ''!
slideOneLineDown

	| priorLine |

	"Having detected the end of rippling recoposition, we are only sliding old lines"
	prevIndex < prevLines size ifFalse: [
		"There are no more prevLines to slide."
		^nowSliding := possibleSlide := false
	].

	"Adjust and re-use previously composed line"
	prevIndex := prevIndex + 1.
	priorLine := (prevLines at: prevIndex) slideIndexBy: deltaCharIndex andMoveTopTo: currentY.
	lines addLast: priorLine.
	currentY := priorLine bottom.
	currCharIndex := priorLine last + 1! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
textStyle: aTextStyle 
	theTextStyle := aTextStyle! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
emphasisHere
	^ emphasisHere ifNil: [ emphasisHere := ' ' asText attributesAt: 1 forStyle: self textStyle ]! !

!RubTextComposer methodsFor: 'querying' stamp: ''!
lineIndexOfCharacterIndex: characterIndex 
	"Answer the line index for a given characterIndex."
	^ (self fastFindFirstLineSuchThat: [:line | line first > characterIndex]) - 1 max: 1! !

!RubTextComposer methodsFor: 'private - composition' stamp: ''!
needComposition
	| ret |
	ret := prevText isNil.
	ret ifFalse: [ret := prevTextStyle ~= theTextStyle].
	ret ifFalse: [ret := prevContainer ~= theContainer].
	ret ifFalse: [ret := prevText string ~= theText string].
	ret ifFalse: [ret := prevText runs ~= theText runs].
	ret ifTrue: [
		prevText := theText copy.
		prevTextStyle := theTextStyle.
		prevContainer := theContainer].
	^ ret! !

!RubTextComposer methodsFor: 'querying' stamp: ''!
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 := self lines size.
	[index := high + low // 2.
	low > high]
		whileFalse: 
			[(lineBlock value: (self lines at: index))
				ifTrue: [high := index - 1]
				ifFalse: [low := index + 1]].
	^ low! !

!RubTextComposer methodsFor: 'private - composition' stamp: ''!
composeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer
	theTextStyle := argTextStyle.
	theText := argText.
	theContainer := argContainer.
	self needComposition
		ifFalse: [ ^ self ].
	lines := argLinesCollection.
	deltaCharIndex := argDelta.
	currCharIndex := startCharIndex := argStart.
	stopCharIndex := argStop.
	prevLines := argPriorLines.
	currentY := argStartY.
	defaultLineHeight := 0. "(theTextStyle fontAt: theTextStyle defaultFontIndex) height" "+ theTextStyle leading".
	maxRightX := theContainer left.
	possibleSlide := stopCharIndex < theText size and: [ theContainer isMemberOf: Rectangle ].
	nowSliding := false.
	prevIndex := 1.
	scanner := RubCompositionScanner new text: theText textStyle: theTextStyle.
	isFirstLine := true.
	self composeAllLines.
	isFirstLine
		ifTrue: [ 
			"No space in container or empty text"
			self addNullLineWithIndex: startCharIndex andRectangle: (theContainer topLeft extent: theContainer width @ defaultLineHeight) ]
		ifFalse: [ self fixupLastLineIfCR ].
	prevLines := #()! !

!RubTextComposer methodsFor: 'private - composition' stamp: ''!
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 |
	self lines isEmptyOrNil ifTrue: [ ^self ].
	startLine := (self lineIndexOfCharacterIndex: start) - 1 max: 1.
	[ startLine > 1 and: [ (self lines at: startLine - 1) top = (self lines at: startLine) top ] ]
		whileTrue: [ startLine := startLine - 1 ].	"Find leftmost of line pieces"
	newLines := OrderedCollection new: self lines size + 1.
	1 to: startLine - 1 do: [ :i | newLines addLast: (self lines at: i) ].
	self
		composeLinesFrom: (self lines at: startLine) first
		to: stop
		delta: delta
		into: newLines
		priorLines: self lines
		atY: (self lines at: startLine) top.
! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
container: aRectangle 
	theContainer := aRectangle! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
tabWidth
	^ self textStyle rubTabWidth! !

!RubTextComposer methodsFor: 'querying' stamp: ''!
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: self lines size.

	"Now find the first line at this x-value"
	[i < self lines size and: [(self lines at: i+1) top = (self lines at: i) top
				and: [aPoint x >= (self lines at: i+1) left]]]
		whileTrue: [i := i + 1].
	^ i! !

!RubTextComposer methodsFor: 'composition' stamp: ''!
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"

	self 
		composeLinesFrom: start
		to: stop
		delta: delta
		into: lineColl
		priorLines: priorLines
		atY: startingY
		textStyle: self textStyle
		text: self text
		container: theContainer.
	self completeComposition! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
startCharIndex: anObject
	^ startCharIndex := anObject! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
emphasisHere: aListOfTextAttribute
	emphasisHere := aListOfTextAttribute ! !

!RubTextComposer methodsFor: 'querying' stamp: ''!
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 := (self lines at: arrayIndex) first.
	 first > 1 and: [crlf includes: (self text string at: first - 1)]] whileTrue: "word wrap"
		[arrayIndex := arrayIndex - 1].
	last := (self lines at: arrayIndex) last.
	
	^(self text string copyFrom: first to: last) indentationIfBlank: aBlock.
! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
cursorWidth
	^ cursorWidth! !

!RubTextComposer methodsFor: 'private - composition' stamp: ''!
completeComposition
	numberOfPhysicalLines := 1.
	actualWidth := 1.
	self lines
		do: [ :line | 
			line lineNumber: numberOfPhysicalLines.
			line stopCondition = #cr
				ifTrue: [ numberOfPhysicalLines := numberOfPhysicalLines + 1 ].
			actualWidth := line actualWidth max: actualWidth ]! !

!RubTextComposer methodsFor: 'private - composition' stamp: ''!
composeOneLine
	| rectangles |
	rectangles := theContainer rectanglesAt: currentY height: defaultLineHeight.
	rectangles notEmpty
		ifTrue: [ (self composeAllRectangles: rectangles) ifNil: [ ^ nil ] ]
		ifFalse: [ currentY := currentY + defaultLineHeight ].
	self checkIfReadyToSlide! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
maxRightX
	^ maxRightX! !

!RubTextComposer methodsFor: 'private - composition' stamp: ''!
composeEachRectangleIn: rectangles

	| myLine lastChar |

	1 to: rectangles size do: [:i | 
		currCharIndex <= theText size ifFalse: [ ^ false ].
		myLine := scanner 
			composeFrom: currCharIndex 
			inRectangle: (rectangles at: i)				
			firstLine: isFirstLine 
			leftSide: i=1 
			rightSide: i=rectangles size.
		myLine actualWidth: scanner rightX - theContainer left.
		
		lines addLast: myLine.
		actualHeight := actualHeight max: myLine lineHeight.  "includes font changes"
		currCharIndex := myLine last + 1.
		
		"This happens if the text is just one line long"
		(myLine last = 0) ifTrue: [ ^ false ].
		
		lastChar := theText at: myLine last.
		(CharacterSet crlf includes: lastChar) ifTrue: [^#cr].
	].
	^false! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
numberOfPhysicalLines
	^ numberOfPhysicalLines ifNil: [ numberOfPhysicalLines := 0 ]! !

!RubTextComposer methodsFor: 'private - composition' stamp: ''!
composeAllLines
	[ currCharIndex <= theText size and: [ currentY + defaultLineHeight <= theContainer bottom ] ]
		whileTrue: [ 
			(nowSliding
				ifTrue: [ self slideOneLineDown ]
				ifFalse: [ self composeOneLine ]) ifNil: [ ^ nil ] ]! !

!RubTextComposer methodsFor: 'composition' stamp: ''!
prepareToForceComposition
	prevText := nil! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
text: aText
	theText := aText
	! !

!RubTextComposer methodsFor: 'adding' stamp: ''!
addNullLineForIndex: index
	"This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic."

	| oldLastLine r |
	oldLastLine := lines last.
	oldLastLine last - oldLastLine first >= 0
		ifFalse: [ ^ self ].
	oldLastLine last = (index - 1)
		ifFalse: [ ^ self ].
	r := oldLastLine left @ oldLastLine bottom extent: oldLastLine right @ (oldLastLine bottom - oldLastLine top).	
	"Even though we may be below the bottom of the container,
	it is still necessary to compose the last line for consistency..."
	self addNullLineWithIndex: index andRectangle: r! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
cursorWidth: anInteger
	cursorWidth := anInteger! !

!RubTextComposer methodsFor: 'private' stamp: ''!
unplug
	theText := '' asText.
	lines := #().
	prevText := prevTextStyle := prevContainer := nil.
	super unplug! !

!RubTextComposer methodsFor: 'testing' stamp: ''!
checkIfReadyToSlide

	"Check whether we are now in sync with previously composed lines"

	(possibleSlide and: [currCharIndex > stopCharIndex]) ifFalse: [^self].

	[prevIndex < prevLines size
		and: [(prevLines at: prevIndex) first < (currCharIndex - deltaCharIndex)]]
			whileTrue: [prevIndex := prevIndex + 1].

	(prevLines at: prevIndex) first = (currCharIndex - deltaCharIndex) ifTrue: [
		"Yes -- next line will have same start as prior line."
		prevIndex := prevIndex - 1.
		possibleSlide := false.
		nowSliding := true
	] ifFalse: [
		prevIndex = prevLines size ifTrue: [
			"Weve reached the end of prevLines, so no use to keep looking for lines to slide."
			possibleSlide := false
		]
	]! !

!RubTextComposer methodsFor: 'private - composition' stamp: ''!
composeAllRectangles: rectangles
	| charIndexBeforeLine numberOfLinesBefore |
	actualHeight := defaultLineHeight.
	charIndexBeforeLine := currCharIndex.
	numberOfLinesBefore := lines size.
	self composeEachRectangleIn: rectangles.
	currentY := currentY + actualHeight.
	currentY > theContainer bottom
		ifTrue: [ 
			"Oops -- the line is really too high to fit -- back out"
			currCharIndex := charIndexBeforeLine.
			lines size - numberOfLinesBefore timesRepeat: [ lines removeLast ].
			^ self ].	"It's OK -- the line still fits."
	maxRightX := maxRightX max: scanner rightX.
	1 to: rectangles size - 1 do: [ :i | 
		"Adjust heights across rectangles if necessary"
		(lines at: lines size - rectangles size + i) lineHeight: lines last lineHeight baseline: lines last baseline ].
	isFirstLine := false.
	currCharIndex > theText size
		ifTrue: [ ^ nil	"we are finished composing" ]! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
container
	^ theContainer! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
lines
	^ lines! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
startCharIndex
	^ startCharIndex! !

!RubTextComposer methodsFor: 'accessing' stamp: ''!
text
	^ theText 
	! !

!RubTextEditor commentStamp: ''!
I represent the editor for plain text, I do the operations related to plain text!
!RubTextEditor methodsFor: 'accessing' stamp: ''!
text
	"Answer the text of the paragraph being edited."

	^ textArea text! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
compareToClipboard: aKeyboardEvent
	"Compare the receiver to the text on the clipboard."

	self compareToClipboard.
	^ true! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
closeTypeIn
	"See comment in openTypeIn. It is important to call
	closeTypeIn before executing any non-typing key, making a new selection, etc. It is
	called automatically for menu commands."
	self startOfTyping 
		ifNotNil: [self addTypeInUndoRecord.
			self doneTyping]! !

!RubTextEditor methodsFor: 'keymapping' stamp: ''!
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"
	9	"tab"
	11	"page up"
	12	"page down"
	13 "cr"
	27	"escape"
	28	"left arrow"
	29	"right arrow"
	30	"up arrow"
	31	"down arrow"
	127	"delete"
	)! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
paste: aKeyboardEvent 
	"Replace the current text selection by the text in the shared buffer."

	self closeTypeIn.
	self paste.
	^true! !

!RubTextEditor methodsFor: 'testing' stamp: ''!
isTextEditor
	^ true ! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
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! !

!RubTextEditor methodsFor: 'private' stamp: ''!
paragraph
	^ textArea paragraph! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
pointBlock
	^ textArea pointBlock! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
selectWord: aKeyboardEvent

	self closeTypeIn.
	self selectWord.
	^ true! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
shiftEnclose: aKeyboardEvent
	"Insert or remove bracket characters around the current selection."

	| char left right startIndex stopIndex oldSelection which text |
	char := aKeyboardEvent keyCharacter.
	char = $9 ifTrue: [ char := $( ].
	char = $, ifTrue: [ char := $< ].
	char asciiValue = 27 ifTrue: [ char := ${ ].	"ctrl-["

	self closeTypeIn.
	startIndex := self startIndex.
	stopIndex := self stopIndex.
	oldSelection := self selection.
	which := '([<{"''' indexOf: char ifAbsent: [1].
	left := '([<{"''' at: which.
	right := ')]>}"''' at: which.
	text := self text.
	((startIndex > 1 and: [stopIndex <= text size])
			and: [ (text at: startIndex-1) = left and: [(text at: stopIndex) = right]])
		ifTrue: [
			"already enclosed; strip off brackets"
			self selectFrom: startIndex-1 to: stopIndex.
			self replaceSelectionWith: oldSelection]
		ifFalse: [
			"not enclosed; enclose by matching brackets"
			self replaceSelectionWith:
				(Text string: (String with: left), oldSelection string, (String with: right) attributes: self emphasisHere).
			self selectFrom: startIndex+1 to: stopIndex].
	^true! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
emphasisHere
	^ textArea emphasisHere! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
selectInvisiblyMark: mark point: point
	"Select the designated characters, inclusive.  Make no visual changes."

	self markIndex: mark pointIndex: point + 1! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
selectAt: characterIndex 
	"Place the caret before the character at characterIndex.
	 Be sure it is in view."

	self selectFrom: characterIndex to: characterIndex - 1! !

!RubTextEditor methodsFor: 'undoers - redoers' stamp: ''!
undoTypeIn: aText interval: anInterval
	self selectInterval: anInterval.
	self replace: anInterval with: aText and:
		[self selectInterval: (anInterval first to: anInterval first - 1)].
! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
setSearchString: aKeyboardEvent
	"Establish the current selection as the current search string."
	^ self setSearchString! !

!RubTextEditor methodsFor: 'private' stamp: ''!
encompassParagraph: anInterval
	"Return an interval that includes anInterval, and that comprises one or several whole paragraphs in the receiver.
	Answer starts at the position following a cr (or eventually 1) and ends at a cr (or eventually at self size)"
	^ self string encompassParagraph: anInterval
! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
computeSelectionIntervalForCurrentLine

	^ self encompassParagraph: self selectionInterval! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
swapChars: aKeyboardEvent
	"Triggered byCmd-Y;.  Swap two characters, either those straddling the insertion point, or the two that comprise the selection.  Suggested by Ted Kaehler.  "

	| currentSelection aString chars |
	(chars := self selection) size = 0
		ifTrue:
			[currentSelection := self pointIndex.
			self selectMark: currentSelection - 1 point: currentSelection]
		ifFalse:
			[chars size = 2
				ifFalse:
					[textArea flash. ^ true]
				ifTrue:
					[currentSelection := self pointIndex - 1]].
	aString := self selection string.
	self replaceSelectionWith: (Text string: aString reversed attributes: self emphasisHere).
	self selectAt: currentSelection + 1.
	^ true! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
changeEmphasis

	|  reply code align menuList startIndex attribute choices |
	choices := self emphasisChoices.
	startIndex := self startIndex.
	align := self text alignmentAt: startIndex ifAbsent: [ 0 ].
	code := self text emphasisAt: startIndex.
	menuList := WriteStream on: Array new.
	menuList nextPut: (code isZero ->  'normal' translated).
	menuList nextPutAll: (choices  collect: [:emph|
							(code anyMask: (TextEmphasis perform: emph) emphasisCode)
								-> emph asString translated ]).
						
	menuList nextPut: ((self text attributesAt: startIndex)
							anySatisfy: [ :attr | attr isKern and: [attr kern < 0 ]]) -> 'narrow' translated.
	reply := UIManager default chooseFrom:  choices values: choices.
	reply notNil 
		ifTrue: [ attribute := TextEmphasis perform: reply.
				self applyAttribute:  attribute].
	^ true! !

!RubTextEditor methodsFor: 'private' stamp: ''!
applyAttribute: aTextAttribute
	"The user selected aTextAttribute via shortcut, menu or other means.
	If there is a selection, apply the attribute to the selection.
	In any case use the attribute for the user input (emphasisHere)"

	self editingState emphasisHere: (Text addAttribute: aTextAttribute toArray: self emphasisHere).
	self selection
		ifNotEmpty: [:s | self replaceSelectionWith: (s addAttribute: aTextAttribute)].
	self compose.
	self recomputeSelection! !

!RubTextEditor methodsFor: 'scrolling' stamp: ''!
scrollBy: ignore 
	"Ignore scroll requests."
! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
insertAndSelect: aString at: anInteger

	self replace: (anInteger to: anInteger - 1)
		with: (Text string: (' ' , aString)
					attributes: self emphasisHere)
		and: [self ]! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
selectInterval: anInterval
	"Select the specified characters inclusive.
	 Be sure the selection is in view."

	self selectFrom: anInterval first to: anInterval last! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findText: aStringOrText
	self findReplaceService findText: aStringOrText ! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
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
! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
chooseColor
	"Make a new Text Color Attribute, let the user pick a color, and return the attribute"

	| attribute |	
	attribute := TextColor color: Color black "default".
	UIManager default chooseColor
		ifNotNil: [:nc | attribute color: nc].
	^ attribute
! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
highlightInterval: anInterval

	self textArea 
		ensureAndGetNewHighlightSegmentFrom: anInterval first 
		to: anInterval last + 1.! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
openTypeIn
	"Set up startOfTyping to keep track of the leftmost backspace.
	 You can't undo typing until after closeTypeIn."

	self startOfTyping 
		ifNil: [self editingState previousInterval: (1 to: 0).
			self startOfTyping: self startIndex]! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
chooseAlignment
	self changeAlignment! !

!RubTextEditor methodsFor: 'keymapping' stamp: ''!
cmdActions
	
	^ self defaultKeymappingIndex at: #command! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findAll: aRegex startingAt: searchIdx 
	| ranges |
	ranges := aRegex matchingRangesIn: (self string copyFrom: searchIdx to: self string size).
	^ ranges collect: [:i | i + searchIdx - 1]
			! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findPrevious: aRegex startingAt: searchIdx 
	| allRanges |
	allRanges := self findAll: aRegex endingAt: searchIdx.
	^ allRanges notEmpty
		ifTrue: [allRanges last].
! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
unselect
	textArea unselect! !

!RubTextEditor methodsFor: 'private' stamp: ''!
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 |
	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].
	self setEmphasisHereFromTextForward: forward! !

!RubTextEditor methodsFor: 'private' stamp: ''!
exchangeWith: prior
	"If the prior selection is non-overlapping and legal, exchange the text of
	 it with the current selection and leave the currently selected text selected
	 in the location of the prior selection (or leave a caret after a non-caret if it was
	 exchanged with a caret).  If both selections are carets, flash & do nothing.
	 Don't affect the paste buffer.  Undoer: itself; Redoer: Undoer."

	| start stop before currSelection priorSelection delta redoArgs altInterval undoArgs |
	start := self startIndex.
	stop := self stopIndex - 1.
	((prior first <= prior last) | (start <= stop) "Something to exchange" and:
			[self isDisjointFrom: prior])
		ifTrue:
			[before := prior last < start.
			currSelection := self selection.
			priorSelection := self text copyFrom: prior first to: prior last.
			delta := before ifTrue: [0] ifFalse: [priorSelection size - currSelection size].
			self zapSelectionWith: priorSelection.
			redoArgs := { prior. start to: stop}.
						
			self selectFrom: prior first + delta to: prior last + delta.
			delta := before ifTrue: [stop - prior last] ifFalse: [start - prior first].
			self zapSelectionWith: currSelection.
			
			altInterval := prior first + delta to: prior last + delta.
			undoArgs := {altInterval. self startIndex to: self stopIndex - 1}.
			"self undoer: #exchangeWith: with: altInterval."
			prior first > prior last ifTrue: [self selectAt: self editingState previousInterval last + 1].
			self 
				redoArray: { textArea. #undoRedoExchange:with:. redoArgs} 
				undoArray: {textArea. #undoRedoExchange:with:. undoArgs}]
		ifFalse:
			[textArea flash]! !

!RubTextEditor methodsFor: 'private' stamp: ''!
isDisjointFrom: anInterval
	"Answer true if anInterval is a caret not touching or within the current
	 interval, or if anInterval is a non-caret that does not overlap the current
	 selection."

	| fudge |
	fudge := anInterval size = 0 ifTrue: [1] ifFalse: [0].
	^(anInterval last + fudge < self startIndex or:
			[anInterval first - fudge >= self stopIndex])
! !

!RubTextEditor methodsFor: 'obsolete - parenblinking' stamp: ''!
blinkParenAt: parenLocation 
	"kept because NECController is sending it to me"! !

!RubTextEditor methodsFor: 'constants' stamp: ''!
alignmentChoices
	"Return the symbols representing the TextAlignment operations to get a text aligned."
	
	^ #(leftFlush centered justified rightFlush)! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
cut: aKeyboardEvent 
	"Cut out the current text selection."

	self cut.
	^true! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
highlightAndEmptyCheck: returnBlock

	| selectionInterval |
	selectionInterval := self getHighlightInterval.
	selectionInterval ifEmpty: [ textArea flash.  ^ returnBlock value ].
	self highlightInterval: selectionInterval! !

!RubTextEditor methodsFor: 'constants' stamp: ''!
emphasisChoices
	"Return the list of emphasis that are possible to apply on the currently edited text morph"
	
	^  #(normal bold italic narrow underlined struckOut).	
	! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
findAgain

	"Find the text-to-find again."

	| where |

	where := self findReplaceService findNext.
	where ifNil: [ self flash ] ifNotNil: [ self selectInterval: where ].
	^ where! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
keyDown: aKeyboardEvent
	textArea announce: ((RubKeystroke with: aKeyboardEvent) morph: self).
	(self dispatch: aKeyboardEvent) ifTrue: [
		self doneTyping.
		self storeSelectionInText.
		textArea scrollSelectionIntoView: nil ]! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
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! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
makeCapitalized: aKeyboardEvent
	"Force the current selection to uppercase.  Triggered by Cmd-z."

	| prev |
	self closeTypeIn.
	prev := $-.  "not a letter"
	self replaceSelectionWith: (Text fromString:
		(self selection string collect:
			[:c | prev := prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]])).
	^ true! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
makeUppercase: aKeyboardEvent
	"Force the current selection to uppercase.  Triggered by Cmd-Y."

	self closeTypeIn.
	self replaceSelectionWith: (Text fromString: (self selection string asUppercase)).
	^ true! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
selectAll

	self selectFrom: 1 to: self string size! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
copySelection
	"Copy the current selection and store it in the paste buffer, unless a caret.  Undoer & Redoer: undoCutCopy"

	self lineSelectAndEmptyCheck: [^ self].
	self clipboardTextPut: self selection.
	self editingState previousInterval: self selectionInterval.
! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
compareToClipboard
	"Check to see if whether the receiver's text is the same as the text currently on the clipboard, and inform the user."
	| s1 s2 |
	s1 := self clipboardText string.
	s2 := self string.
	s1 = s2 ifTrue: [^ self inform: 'Exact match'].
	UIManager default  
		longMessage: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2)
		title: 'Comparison to Clipboard Text'! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
backWord
	"If the selection is not a caret, delete it and leave it in the backspace buffer.
	 Else, delete the word before the caret."
	^ self backWord: nil
! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
undoRedoTransaction: aBlock
	self editingState undoRedoTransaction: aBlock! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
findAgainAndReplace
	"Find the text-to-find again and eventually replace it with the current replace text."

	| where |

	where := self findAgain.
	where
		ifNotNil: [ self findReplaceService replaceText ifNotEmpty: [ :rt | self replaceSelectionWith: rt ] ]! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
raiseContextMenu: aKeyboardEvent

	^ textArea yellowButtonActivity: textArea activeHand lastEvent shiftPressed! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
align
	"Align text according to the next greater alignment value,
	cycling among leftFlush, rightFlush, center, and justified."
	self changeAlignment.
! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
replace: xoldInterval with: newText and: selectingBlock 
	"Replace the text in oldInterval with newText and
	execute selectingBlock to establish the new selection.
	Create an UndoRecord to allow perfect undoing."
	| prevSel currInterval |
	self selectInterval: xoldInterval.
	prevSel := self selection.
	currInterval := self selectionInterval.
	self editingState previousInterval: currInterval.
	self zapSelectionWith: newText.
	selectingBlock value.
	((prevSel isEmpty and: [newText isEmpty]) and: [currInterval size < 1]) 
		ifFalse: [self 
			redoArray: {textArea. #redoTypeIn:interval:. {newText. currInterval}} 
			undoArray: {textArea. #undoTypeIn:interval:. {prevSel. currInterval first to: currInterval first + newText size - 1}}]! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
find
	"Prompt the user for a string to search for, and search the receiver from the current selection onward for it."
	textArea openFindDialog! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
search: aKeyboardEvent
	"Invoked by Ctrl-S.  Same as 'again', but always uses the existing findText
	 from current FindReplaceService"

	self closeTypeIn.
	self findAgain.
	^true! !

!RubTextEditor methodsFor: 'private' stamp: ''!
cut
	"Cut out the current selection and redisplay the paragraph if necessary.  Undoer & Redoer: undoCutCopy:"

	self lineSelectAndEmptyCheck: [^ self].
	self clipboardTextPut: self selection.
	self replaceSelectionWith: self nullText.
	textArea changed
! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
normalCharacter: aKeyboardEvent 
	"A nonspecial character is to be added to the stream of characters."

	self addString: aKeyboardEvent keyCharacter asString.
	^false! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
startOfTyping: anIntegerIndex
	self editingState startOfTyping:  anIntegerIndex! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
setEmphasisHereFromText

	self setEmphasisHereFromTextForward: true! !

!RubTextEditor methodsFor: 'testing' stamp: ''!
canChangeText
	^ textArea canChangeText! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
performCmdActionsWith: aKeyboardEvent shifted: aBoolean return: return
	| key actions action|
	key := aKeyboardEvent key.
	actions := self cmdActions.
	action := (actions at: key ifAbsent: [ ^ false ]).
	return value: (self perform: action with: aKeyboardEvent).! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findReplaceService
	^ self textArea findReplaceService! !

!RubTextEditor methodsFor: 'undo - redo private' stamp: ''!
exploreUndoManager: aKeyboardEvent
	^ self editingState exploreUndoManager: aKeyboardEvent! !

!RubTextEditor methodsFor: 'testing' stamp: ''!
isScripting
	^ false ! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
pasteRecent
	"Paste an item chose from RecentClippings."

	| clipping |
	(clipping := Clipboard chooseRecentClipping) ifNil: [^ self].
	Clipboard clipboardText: clipping.
	^ self paste! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
hasSelection
	^ self pointIndex ~= self markIndex! !

!RubTextEditor methodsFor: 'private' stamp: ''!
resetState
	"Establish the initial conditions for editing the paragraph: place cursor 
	before first character, set the emphasis to that of the first character"

	| b |
	b := self paragraph defaultCharacterBlock.
	textArea markBlock: b pointBlock: b copy.
	self editingState startOfTyping: nil.
	self editingState previousInterval: (1 to: 0).
	self setEmphasisHereFromText! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
selectionStop
	^ textArea selectionStop! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
storeSelectionInText
	self theme currentSettings haveSelectionTextColor 
		ifTrue: [
			self text removeAttribute: RubTextSelectionColor primarySelection.
			self text addAttribute: RubTextSelectionColor primarySelection from: self startIndex to: self stopIndex - 1]! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
dispatchCommandOn: aKeyboardEvent return: return

	^ self performCmdActionsWith: aKeyboardEvent shifted: aKeyboardEvent shiftPressed return: return! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
fontToUse
	^ self text fontAt: self startIndex! !

!RubTextEditor methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
lineIntervalAtCursorPosition
	| string lastEnd index lastStart |
	
	index := self pointIndex.
	string := self text asString ifEmpty: [ ^ nil ].
	string lineIndicesDo: [ :start :endWithoutDelimiters :end | 
		index <= end ifTrue: [ 
			^ start to: endWithoutDelimiters ].
		lastStart := start.
		lastEnd := end ].
	
	"evaluate the case where the cursor is placed at the end of the text (there will not 
	 be delimiter, but there will be a line to answer anyway (maybe empty)"
	^ lastEnd + 1 <= index 
		ifTrue: [ lastStart to: lastEnd ]
		ifFalse: [ nil ]! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
copySelection: aKeyboardEvent
	"Copy the current text selection."
	self copySelection.
	^true! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
duplicate: aKeyboardEvent
	"Paste the current selection over the prior selection, if it is non-overlapping and
	 legal.  Undoer & Redoer: undoAndReselect."

	self closeTypeIn.
	(self hasSelection and: [self isDisjointFrom: self editingState previousInterval])
		ifTrue: "Something to duplicate"
			[self replace: self editingState previousInterval with: self selection and:
				[self selectAt: self pointIndex]]
		ifFalse:
			[textArea flash].
	^true! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
replaceTextFrom: start to: stop with: aText
	self replace: (start to: stop - 1) with: aText and: []
! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
totalTextHeight

	^self paragraph totalTextHeight! !

!RubTextEditor methodsFor: 'testing' stamp: ''!
isCaretBehindChar
	"Return true if the cursor position is after an alphanumeric character, otherwise false."

	| cursorPosition |
	^(cursorPosition := self startIndex) >= 2 and: [
		(self text at: cursorPosition - 1) isAlphaNumeric ]! !

!RubTextEditor methodsFor: 'private' stamp: ''!
findText: aString isRegex: isRegex caseSensitive: caseSensitive entireWordsOnly: entireWordsOnly
	self findReplaceService findText: aString isRegex: isRegex caseSensitive: caseSensitive entireWordsOnly: entireWordsOnly
! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
exchange: aKeyboardEvent
	"Exchange the current and prior selections."

	self closeTypeIn.
	self exchange.
	^true! !

!RubTextEditor methodsFor: 'nesting' stamp: ''!
getEscapeCharacterFromAst: anAST
	"If there is no node (empty textArea) there is no nesting to be had."
	anAST ifNil: [ ^nil ].
	anAST isCommentNode ifTrue: [ ^$" ].
	(anAST isLiteralNode and: [anAST value isString]) ifTrue: [ ^$' ].
	^nil.! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findNextString: aSubstring startingAt: searchIdx 
	| idx |
	idx := self string findString: aSubstring startingAt: searchIdx.
	^ idx isZero ifFalse: [idx to: idx + aSubstring size - 1]
			! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
noop: aKeyboardEvent 
	"Unimplemented keyboard command; just ignore it."

	^ true! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
startIndex
	^ textArea startIndex! !

!RubTextEditor methodsFor: 'undo - redo private' stamp: ''!
addTypeInUndoRecord
	| begin stop undoText redoText |
	begin := self startOfTyping min: self stopIndex. 
	stop := self stopIndex max: self startOfTyping.
	self editingState previousInterval: (begin to: stop - 1). 
	undoText := self nullText.
	redoText := stop > begin
			ifTrue: [self text copyFrom: begin to: stop - 1]
			ifFalse: [self nullText].
	((undoText isEmpty and: [redoText isEmpty]) and: [self editingState previousInterval size < 1])
			ifFalse: [self 
				redoArray: { textArea. #redoTypeIn:interval:.  {redoText. begin to: begin + self selection size - 1} } 
				undoArray: {textArea. #undoTypeIn:interval:.  {undoText. begin to: stop - 1} }].
	
! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
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! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
escape: aKeyboardEvent
	textArea escapePressed.
	^ false  ! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
findAgain: aKeyboardEvent 
	"Find the desired text again."
	self closeTypeIn.
	self findAgain.
	^ true! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
findText: aString isRegex: aBoolean
	self findReplaceService findText: aString isRegex: aBoolean! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
hoverHighlightInterval: anInterval

	self textArea 
		ensureAndGetNewHoverHighlightSegmentFrom: anInterval first 
		to: anInterval last + 1.! !

!RubTextEditor methodsFor: 'undo - redo private' stamp: ''!
redoArray: doArray undoArray: undoArray
	self editingState redoArray: doArray undoArray: undoArray! !

!RubTextEditor methodsFor: 'private' stamp: ''!
textWasAccepted
	self closeTypeIn.
	^ self accept! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
selection
	"Answer the text in the paragraph that is currently selected."
	^self text copyFrom: self startIndex to: self stopIndex - 1 ! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
theme
	^ UITheme current! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
closingDelimiters
	^ ')]}'
! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
nextCharacterIfAbsent: aBlock

	^ self text at: self startIndex ifAbsent: aBlock! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
cursorEnd: aKeyboardEvent
	"Private - Move cursor end of current line."

	| string |
	self closeTypeIn.
	string := self string.
	self
		moveCursor: [ :position | string indexOf: Character cr startingAt: position ifAbsent: [ string size + 1 ] ]
		forward: true
		specialBlock: [ :dummy | string size + 1 ]
		event: aKeyboardEvent.
	^ true! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
outdent: aKeyboardEvent
	"Remove a tab from the front of every line occupied by the selection."

	^ self inOutdent: aKeyboardEvent delta: -1! !

!RubTextEditor methodsFor: 'private' stamp: ''!
unplug
	textArea := nil.
	super unplug! !

!RubTextEditor methodsFor: 'private' stamp: ''!
nextWord: position
	| string index  initialIsAlphaNumeric |
	string := self string.
	index := position.
	position >= string size ifTrue: [ ^ position ].
	initialIsAlphaNumeric := self isWordCharacterAt: index -1 in: string.

	[(index <= string size) 
		and: [ (self isWordCharacterAt: index in: string) = initialIsAlphaNumeric]]
			whileTrue: [index := index + 1].
	^ index! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
textArea
	^ textArea! !

!RubTextEditor methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
lineAtCursorPosition
	| string |
	
	string := self text asString ifEmpty: [ ^ '' ].
	^ self lineIntervalAtCursorPosition
		ifNotNil: [ :anInterval | string copyFrom: anInterval first to: anInterval last ]
		ifNil: [ '' ]! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
indent: aKeyboardEvent
	"Add a tab at the front of every line occupied by the selection."

	^ self inOutdent: aKeyboardEvent delta: 1! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
selectCurrentTypeIn: aKeyboardEvent 
	"Select what would be replaced by an undo (e.g., the last typeIn)."

	self closeTypeIn.
	self selectInterval: self editingState previousInterval.
	^ true! !

!RubTextEditor methodsFor: 'completion engine' stamp: ''!
completionAround: aBlock keyStroke: anEvent
	"No code completion for simple text editor, so nothing special to do here around the block execution"
	
	aBlock value! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
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! !

!RubTextEditor methodsFor: 'events' stamp: ''!
doubleClick: evt
	| here |
	self closeTypeIn.	"no matter what, if shift is pressed extend the selection"
	here := self pointIndex.
	(here between: 2 and: self string size)
		ifFalse: [ 
			"if at beginning or end, select entire string"
			self selectFrom: 1 to: self string size ]
		ifTrue: [ self selectWord ].
	self setEmphasisHereFromText.
	self storeSelectionInText! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
textArea: atextArea
	textArea := atextArea.
	self resetState.! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
undo: aKeyboardEvent 
	"Undo the last edit."

	self undo.
	^true! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
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]! !

!RubTextEditor methodsFor: 'private' stamp: ''!
pageHeight
	| howManyLines visibleHeight totalHeight ratio |
	howManyLines := self paragraph numberOfLines.
	visibleHeight := self visibleHeight.
	totalHeight := self totalTextHeight.
	ratio := visibleHeight / totalHeight.
	^(ratio * howManyLines) rounded - 2! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
select
	"select what and how ?"! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
selectAll: aKeyboardEvent 
	"select everything"

	self closeTypeIn.
	self selectFrom: 1 to: self string size.
	^ true! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
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 selectLine].
	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].
	
	"to avoid selecting boringly the : in block argument: :aSerie will just select aSerie. 
	Such a boost of editing productivity!!!!!!"	
	start ifNotNil: [ (self text at: start) = $: ifTrue: [ start := start + 1 ]].
	
	
	direction > 0
		ifTrue: [self selectFrom: start to: here - 1]
		ifFalse: [self selectFrom: here + 1 to: stop]! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
changeAlignment
	"Interactively change the alignment of the text currently being edited."
	| reply  |
	reply := UIManager default 
				chooseFrom:  self alignmentChoices 
				values:  self alignmentChoices.	
	reply ifNil: [^self].
	self applyAttribute: (TextAlignment perform: reply).
	^ true! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
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! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
selectInvisiblyFrom: start to: stop
	"Select the designated characters, inclusive.  Make no visual changes."

	self markIndex: start pointIndex: stop + 1! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findText
	^ self findReplaceService findText! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
replaceSelectionWith: aText
	self replace: self selectionInterval with: aText and: []
! !

!RubTextEditor methodsFor: 'nesting' stamp: ''!
surroundString: aString withCharacter: aCharacter
	"Returns a new string with contents equals to aString surrounded by aCharacter.
	Escapes all occurrences of aCharacter within aString by doubling them."
	
	"(RubTextEditor new surroundString: 'a' withCharacter: $') >>> '''a'''"
	"(RubTextEditor new surroundString: 'a''b' withCharacter: $') >>> '''a''''b'''"
	
	| result stream |
	result := WriteStream with: ''.
	stream := ReadStream on: aString string.
	result nextPut: aCharacter.
	[ stream atEnd ] whileFalse: 
		[ result nextPutAll: (stream upTo: aCharacter).
		stream peekBack = aCharacter ifTrue: [result nextPut: aCharacter]. 
		result nextPut: aCharacter.].
	stream peekBack = aCharacter ifTrue: [result nextPut: aCharacter].
	^result contents.! !

!RubTextEditor methodsFor: 'nesting' stamp: ''!
unNesting: aString with: aCharacter 
	" To escape them, we double the character every time it's encountered"
	| result stream |
	result := WriteStream with: ''.
	stream := ReadStream on: aString.
	[ stream atEnd ] whileFalse: 
			[ result nextPutAll: (stream upTo: aCharacter).
			  stream peek ifNotNil: [result nextPut: stream next]].
	^result contents.! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
selectionAsStream
	"Answer a ReadStream on the text in the paragraph that is currently 
	selected."

	^ReadStream
		on: (self string copyFrom: self startIndex to: self stopIndex - 1)! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
visibleHeight

	^textArea owner bounds height
! !

!RubTextEditor methodsFor: 'settings' stamp: ''!
caseSensitiveFinds
	^ textArea caseSensitiveFinds! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
changeLfToCr: aKeyboardEvent
	"Replace all LFs by CRs.
	Triggered by Cmd-U -- useful when getting code from FTP sites
	jmv- Modified to als change crlf by cr"
	
	| fixed |
	fixed := self selection string.
	fixed := fixed copyReplaceAll: String crlf with: String cr.
	fixed := fixed copyReplaceAll: String lf with: String cr. 
	self replaceSelectionWith: (Text fromString: fixed).
	^ true! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
recomputeSelection
	"The same characters are selected but their coordinates may have changed.
	Redetermine the selection according to the start and stop block indices; 
	do not highlight."

	textArea recomputeSelection! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
openingDelimiters
	^ '([{'
! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
redo
	"redo previous edit"

	self editingState redo ifFalse: [textArea flash]. 
! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
crlf: aKeyboardEvent
	"Append a line feed character to the stream of characters."

	self addString: String crlf.
	^false! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
oppositeDelimiterSelection
	^ RubTextSelectionColor oppositeDelimiterSelection! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
setSearchString
	"Make the current selection, if any, be the current search string."
	self closeTypeIn.
	self setSearch: self selection string.
	^ true! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
afterSelectionInsertAndSelect: aString

	self insertAndSelect: aString at: self stopIndex ! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
previousCharacterIfAbsent: aBlock

	^ self text at: self startIndex - 1 ifAbsent: aBlock! !

!RubTextEditor methodsFor: 'private' stamp: ''!
nullText

	^Text string: '' attributes: self emphasisHere! !

!RubTextEditor methodsFor: 'keymapping' stamp: ''!
defaultKeymappingIndex
	^defaultKeymappingIndex ifNil: [ defaultKeymappingIndex := self newDefaultKeymappingIndex ]! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
highlightedTextAsStream
	"Answer a ReadStream on the text in the paragraph that is currently highlighted."

	| highlightedInterval |
	highlightedInterval := self getHighlightInterval.
	^ (self string copyFrom: highlightedInterval first to: highlightedInterval last) readStream! !

!RubTextEditor methodsFor: 'private' stamp: ''!
textStyle: aTextStyle
	textArea textStyle: aTextStyle! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
hasCursor
	^self markBlock = self pointBlock! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
markBlock
	^ textArea markBlock! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
deselect
	"If the text selection is visible on the screen, reverse its highlight."
	" ***** screw this logic ***** selectionShowing ifTrue: [self reverseSelection] "! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
forwardDelete: aKeyboardEvent
	"Delete forward over the next character"

	self closeTypeIn.
	self hasSelection
		ifFalse: [ 
			| idx1 idx2 |
			idx1 := self startIndex min: self stopIndex.
			idx2 := self stopIndex max: self startIndex.
			aKeyboardEvent shiftPressed
				ifTrue: [ idx2 := self nextWord: idx1 ]
				ifFalse: [ idx2 := idx2 + 1 ].
			self selectInvisiblyFrom: idx1 to: idx2 - 1 ].
	self addDeleteSelectionUndoRecord.
	self zapSelectionWith: self nullText.
	^ false! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
setSelectorSearch: aStringOrText 
	"Make the current selection as a selector search in current FindReplaceService."
	| regex |
	regex := aStringOrText asString trimBoth.
	regex := regex copyReplaceAll: '#' with: ''.
	regex := regex copyReplaceAll: ' ' with: ''.
	self findText: regex isRegex: false caseSensitive: true entireWordsOnly: false.
	^ true! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
changeEmphasisOrAlignment
	| aList reply  code align menuList startIndex attribute |
	startIndex := self startIndex.
	align := self text alignmentAt: startIndex ifAbsent: [ 0 ].
	code := self text emphasisAt: startIndex.
	menuList := WriteStream on: Array new.
	menuList nextPut: (code isZero -> 'normal' translated).
	menuList nextPutAll: (#(bold italic underlined struckOut) collect: [:emph|
		(code anyMask: (TextEmphasis perform: emph) emphasisCode) -> emph asString translated]).
	
	menuList nextPut: ((self text attributesAt: startIndex)
		anySatisfy: [ :attr | attr isKern and: [attr kern < 0 ]]) -> 'narrow' translated.
		
	self alignmentChoices collectWithIndex: [ :type :i |
		menuList nextPut: (align = (i-1)) -> type asString translated ].
	
	aList := #(normal bold italic underlined struckOut narrow leftFlush centered rightFlush justified).
	reply := UIManager default chooseFrom:  aList values: aList.
	reply notNil ifTrue: [
		(self alignmentChoices includes: reply)
			ifTrue: [ attribute :=TextAlignment perform: reply]
			ifFalse: [ attribute := TextEmphasis perform: reply].
		self applyAttribute:  attribute].
	^ true! !

!RubTextEditor methodsFor: 'private' stamp: ''!
findText: aString isRegex: isRegex entireWordsOnly: entireWordsOnly
	self findReplaceService findText: aString isRegex: isRegex entireWordsOnly: entireWordsOnly
! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
model
	^ textArea model! !

!RubTextEditor methodsFor: 'keymapping' stamp: ''!
defaultCommandKeymapping
	| cmdMap |
		
	cmdMap := Dictionary new.
	{(KeyboardKey home -> #cursorHome:).
	(KeyboardKey end -> #cursorEnd:).
	(KeyboardKey backspace -> #backspace:).
	(KeyboardKey pageUp -> #cursorPageUp:).
	(KeyboardKey pageDown -> #cursorPageDown:).
	(KeyboardKey enter -> #crWithIndent:).
	(KeyboardKey escape -> #escape:).
	(KeyboardKey left -> #cursorLeft:).
	(KeyboardKey right -> #cursorRight:).
	(KeyboardKey up -> #cursorUp:).
	(KeyboardKey down -> #cursorDown:).
	(KeyboardKey keypadLeft -> #cursorLeft:).
	(KeyboardKey keypadRight -> #cursorRight:).
	(KeyboardKey keypadUp -> #cursorUp:).
	(KeyboardKey keypadDown -> #cursorDown:).
	(KeyboardKey keypadEnter -> #crWithIndent:).
	(KeyboardKey tab -> #tab:).
	(KeyboardKey delete -> #forwardDelete:) } do: [ :assoc | 
		cmdMap at: assoc key  put: assoc value ].
	^ cmdMap! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
exchange
	"See comment in exchangeWith:"

	self exchangeWith: self editingState previousInterval! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
getHighlightInterval
	"Answer the interval that is or should be highligted."

	^ self hasSelection 
		ifTrue: [ self selectionInterval ]
		ifFalse: [ self computeSelectionIntervalForCurrentLine ]! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
clipboardTextPut: text

	^ Clipboard clipboardText: text! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
doneTyping
	self startOfTyping: nil! !

!RubTextEditor methodsFor: 'private' stamp: ''!
applyTextFont: aFont
	self applyAttribute: (TextFontReference toFont: aFont).
! !

!RubTextEditor methodsFor: 'private' stamp: ''!
previousWord: position
	| string index  initialIsAlphaNumeric |
	string := self string.
	index := position.
	position <= 1 ifTrue: [ ^ position ].
	initialIsAlphaNumeric := self isWordCharacterAt: index in: string.
	[index := index - 1] doWhileTrue:
		[(index > 0) and: [ (self isWordCharacterAt: index in: string) = initialIsAlphaNumeric]].
	^ index + 1! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
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! !

!RubTextEditor methodsFor: 'undoers - redoers' stamp: ''!
undoRedoExchange: aninterval with: anotherInterval
	self selectInvisiblyFrom: aninterval first to: aninterval last.
	self exchangeWith: anotherInterval
! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
cursorHome: aKeyboardEvent
	"Private - Move cursor from position in current line to beginning of
	current line. If control key is pressed put cursor at beginning of text"

	| string |
	string := self string.
	self
		moveCursor: [ :position | (string lastIndexOf: Character cr startingAt: position - 1 ifAbsent: [ 0 ]) + 1 ]
		forward: false
		specialBlock: [ :dummy | 1 ]
		event: aKeyboardEvent.
	^ true! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
encloseWith: aMatchingPair
	"Insert or remove bracket characters around the current selection."

	| left right startIndex stopIndex oldSelection text newString |
	self closeTypeIn.
	startIndex := self startIndex.
	stopIndex := self stopIndex.
	oldSelection := self selection.
	
	left := aMatchingPair key.
	right := aMatchingPair value.
	text := self text.
	((startIndex > 1 and: [stopIndex <= text size])
			and: [ (text at: startIndex-1) = left and: [(text at: stopIndex) = right]])
		ifTrue: [
			"already enclosed; strip off brackets"
			newString := (self shouldEscapeCharacter: left)
						 ifTrue: [ oldSelection asString unescapeCharacter: left ] 
						 ifFalse: [ oldSelection ].
			self selectFrom: startIndex-1 to: stopIndex.
			self replaceSelectionWith: newString ]
		ifFalse: [
			" Checks if the characters inside the selection need to be escaped or not. "
			newString := (self shouldEscapeCharacter: left)
						 ifTrue: [ self surroundString: oldSelection withCharacter: left ] 
						 ifFalse: [ "not enclosed; enclose by matching brackets"
									  (String with: left), oldSelection string, (String with: right) ].
			self replaceSelectionWith:
				(Text string: newString attributes: self emphasisHere).
			"we add the difference of the newString and the oldSelection, here, to ajust to eventual nesting. The 2 corrsponds to se left and right characters added which are not in oldSelection."
			self selectFrom: startIndex+1 to: stopIndex+(newString size - oldSelection size - 2)].
	^true! !

!RubTextEditor methodsFor: 'private' stamp: ''!
indent: delta fromStream: inStream toStream: outStream
	"Append the contents of inStream to outStream, adding or deleting delta or -delta
	 tabs at the beginning, and after every CR except a final CR.  Do not add tabs
	 to totally empty lines, and be sure nothing but tabs are removed from lines."

	| ch skip cr tab prev atEnd |
	cr := Character cr.
	tab := Character tab.
	delta > 0
		ifTrue: "shift right"
			[prev := cr.
			 [ch := (atEnd := inStream atEnd) ifTrue: [cr] ifFalse: [inStream next].
			  (prev == cr and: [ch ~~ cr]) ifTrue:
				[delta timesRepeat: [outStream nextPut: tab]].
			  atEnd]
				whileFalse:
					[outStream nextPut: ch.
					prev := ch]]
		ifFalse: "shift left"
			[skip := delta. "a negative number"
			 [inStream atEnd] whileFalse:
				[((ch := inStream next) == tab and: [skip < 0]) ifFalse:
					[outStream nextPut: ch].
				skip := ch == cr ifTrue: [delta] ifFalse: [skip + 1]]]! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
saveContentsInFile
	"Save the receiver's contents string to a file, prompting the user for a file-name.  Suggest a reasonable file-name."

	| fileName stringToSave parentWindow labelToUse suggestedName lastIndex |
	stringToSave := self string. 
	stringToSave size = 0 ifTrue: [^self inform: 'nothing to save.'].
	parentWindow := self model dependents 
				detect: [:dep | dep isKindOf: SystemWindow]
				ifNone: [nil].
	labelToUse := parentWindow ifNil: ['Untitled']
				ifNotNil: [parentWindow label].
	suggestedName := nil.
	#(#('Decompressed contents of: ' '.gz')) do: 
			[:leaderTrailer | 
			"can add more here..."

			(labelToUse beginsWith: leaderTrailer first) 
				ifTrue: 
					[suggestedName := labelToUse copyFrom: leaderTrailer first size + 1
								to: labelToUse size.
					(labelToUse endsWith: leaderTrailer last) 
						ifTrue: 
							[suggestedName := suggestedName copyFrom: 1
										to: suggestedName size - leaderTrailer last size]
						ifFalse: 
							[lastIndex := suggestedName lastIndexOf: $. ifAbsent: [0].
							(lastIndex = 0 or: [lastIndex = 1]) 
								ifFalse: [suggestedName := suggestedName copyFrom: 1 to: lastIndex - 1]]]].
	suggestedName ifNil: [suggestedName := labelToUse , '.text'].
	fileName := UIManager default request: 'File name?'
				initialAnswer: suggestedName.
	fileName isEmptyOrNil
		ifFalse: [ fileName asFileReference writeStreamDo: [ :out | out nextPutAll: stringToSave ] ]! !

!RubTextEditor methodsFor: 'private' stamp: ''!
setEmphasisHere
	self editingState
		emphasisHere:
			((self text attributesAt: (self pointIndex - 1 max: 1) forStyle: self textStyle) select: [ :att | att mayBeExtended ])! !

!RubTextEditor methodsFor: 'private' stamp: ''!
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! !

!RubTextEditor methodsFor: 'undoers - redoers' stamp: ''!
redoTypeIn: aText interval: anInterval
	self selectInterval: anInterval.
	self replace: self selectionInterval with: aText and:
		[self selectInterval: (anInterval first to: anInterval first + aText size - 1)].
! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
markIndex: markIndex pointIndex: pointIndex
	textArea markIndex: markIndex pointIndex: pointIndex
! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
textStyle
	^ textArea textStyle! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findAndSelect: aRegex startingAt: anIndex searchBackwards: searchBackwards
	| oldSelectionInterval where |
	self closeTypeIn.
	oldSelectionInterval := self selectionInterval.
	self selectInvisiblyFrom: anIndex to: anIndex - 1.
	where :=  searchBackwards
		ifTrue: [self findAndSelectPreviousOccurrenceOf: aRegex]
		ifFalse: [self findAndSelectNextOccurrenceOf: aRegex].
	where ifNil: [self selectInterval: oldSelectionInterval].
	^ where! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
editingState
	^ textArea editingState! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
string

	^self text string! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findAll: aRegex endingAt: searchIdx 
	| ranges |
	ranges := aRegex matchingRangesIn: (self string copyFrom: 1 to: searchIdx).
	^ ranges 
			! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
setSearch: aString
	"Make the current selection, if any, be the current search string."
	self findText: aString isRegex: false.
	^ true! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
accept
	"Save the current text of the text being edited as the current acceptable version for purposes of canceling.  Allow my morph to take appropriate action"
	self canChangeText 
		ifTrue: [textArea acceptContents]! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
offerFontMenu
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection.  
	Use only names of Fonts of this paragraph  "
	
	^self changeTextFont! !

!RubTextEditor methodsFor: 'undo - redo private' stamp: ''!
addDeleteSelectionUndoRecord
	| undoText redoText |
	undoText := self selection.
	redoText := self nullText.
	self
		redoArray:	{textArea. #undoTypeIn:interval:.	{redoText.	(self selectionInterval)}}
		undoArray:	{textArea. #redoTypeIn:interval:.	{undoText.	(self selectionInterval first to: self selectionInterval first - 1)}}! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
undo
	"Undo  previous edit."
	self closeTypeIn.
	self editingState undo ifFalse: [textArea flash]. 
! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
editPrimarySelectionSeparately
	textArea editPrimarySelectionSeparately! !

!RubTextEditor methodsFor: 'testing' stamp: ''!
isSmalltalkEditor
	^ false ! !

!RubTextEditor methodsFor: 'settings' stamp: ''!
walkAlongDisplayedLine
	^ textArea walkAlongDisplayedLine! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
dispatch: aKeyboardEvent
	"Carry out the action associated with this character, if any.
	Type-ahead is passed so some routines can flush or use it."

	self
		dispatchCommandOn: aKeyboardEvent
		return: [ :val | ^ val ].
	^ false! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
inOutdent: aKeyboardEvent delta: delta
	"Add/remove a tab at the front of every line occupied by the selection. 
	Derived from work by Larry Tesler back in December 1985."

	| cr realStart realStop lines startLine stopLine start stop adjustStart indentation size numLines inStream newString outStream |
	cr := Character cr.

	"Operate on entire lines, but remember the real selection for re-highlighting later"
	realStart := self startIndex.
	realStop := self stopIndex - 1.

	"Special case a caret on a line of its own, including weird case at end of paragraph"
	(realStart > realStop and: [
				realStart < 2 or: [(self string at: realStart - 1) == cr]])
		ifTrue:
			[delta < 0
				ifTrue: [
					textArea flash]
				ifFalse: [
					self replaceSelectionWith: Character tab asSymbol asText.
					self selectAt: realStart + 1].
			^true].

	lines := self paragraph lines.
	startLine := self paragraph lineIndexOfCharacterIndex: realStart.
	stopLine := self paragraph lineIndexOfCharacterIndex: (realStart max: realStop).
	start := (lines at: startLine) first.
	stop := (lines at: stopLine) last.
	
	"Pin the start of highlighting unless the selection starts a line"
	adjustStart := realStart > start.

	"Find the indentation of the least-indented non-blank line; never outdent more"
	indentation := (startLine to: stopLine) inject: 1000 into: [ :previousValue :each |
		previousValue min: (self paragraph indentationOfLineIndex: each ifBlank: [ :tabs | 1000 ])].			

	size :=  stop + 1 - start.
	numLines := stopLine + 1 - startLine.
	inStream := ReadStream on: self string from: start to: stop.

	newString := String new: size + ((numLines * delta) max: 0).
	outStream := ReadWriteStream on: newString.

	"This subroutine does the actual work"
	self indent: delta fromStream: inStream toStream: outStream.

	"Adjust the range that will be highlighted later"
	adjustStart ifTrue: [realStart := (realStart + delta) max: start].
	realStop := realStop + outStream position - size.

	"Prepare for another iteration"
	indentation := indentation + delta.
	size := outStream position.
	inStream := outStream setFrom: 1 to: size.

	outStream == nil
		ifTrue: 	"tried to outdent but some line(s) were already left flush"
			[textArea flash]
		ifFalse:
			[self selectInvisiblyFrom: start to: stop.
			size = newString size ifFalse: [newString := outStream contents].
			self replaceSelectionWith: newString asText].
	self selectFrom: realStart to: realStop. 	"highlight only the original range"
	^ true! !

!RubTextEditor methodsFor: 'nesting' stamp: ''!
shouldEscapeCharacter: aCharacter

	^ #($" $') includes: aCharacter! !

!RubTextEditor methodsFor: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher
	aKMDispatcher attachCategory: RubTextEditor name! !

!RubTextEditor methodsFor: 'private' stamp: ''!
isWordCharacterAt: index in: aString
	"By default, group alphanumeric and non-alphanumeric separately"
	^ (aString at: index) isAlphaNumeric! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
clipboardText

	^ Clipboard clipboardText! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
zapSelectionWith: aText
	| start stop |
	self canChangeText
		ifFalse: [ ^ self ].
	start := self startIndex.
	stop := self stopIndex.
	(aText isEmpty and: [ stop > start ])
		ifTrue:
			[ "If deleting, then set emphasisHere from 1st character of the deletion"
			self editingState
				emphasisHere: ((self text attributesAt: start) select: [ :att | att mayBeExtended ]) ].
	(start = stop and: [ aText isEmpty ]) ifTrue: [ ^self ].
	textArea privateReplaceFrom: start to: stop - 1 with: aText asText.
			"We ask to editingSate directly instead to the morph "
			"to avoid unwanted SelectionChanged announce."
			"It will be send later while unselecting (with #unselect send)"
			self markIndex: start pointIndex: start + aText size.
			self editingState previousInterval: self selectionInterval! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
doAgainMany: aKeyboardEvent 
	"Do the previous thing again repeatedly."

	self closeTypeIn.
	^ true! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
accept: aKeyboardEvent 
	"Save the current text of the text being edited as the current acceptable version for purposes of canceling.  Allow my morph to take appropriate action"
	self accept.
	^ true! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
selectionInterval
	"Answer the interval that is currently selected."

	^self startIndex to: self stopIndex - 1 ! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
lf: aKeyboardEvent 
	"Append a line feed character to the stream of characters."

	self addString: Character lf asString.
	^false! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
correctFrom: start to: stop with: aString
	"Make a correction in the model that the user has authorised from somewhere else in the system (such as from the compilier).  
	The user's selection is not changed, only corrected."
	| userSelection delta |
	
	userSelection := self selectionInterval.
	self selectInvisiblyFrom: start to: stop.
	self replaceSelectionWith: aString asText.
	delta := aString size - (stop - start + 1).
	self selectInvisiblyFrom:
		userSelection first + (userSelection first > start ifFalse: [ 0 ] ifTrue: [ delta ])
		to: userSelection last + (userSelection last > start ifFalse: [ 0 ] ifTrue: [ delta ]).
! !

!RubTextEditor methodsFor: 'events' stamp: ''!
click: event
	| p |
	self closeTypeIn.
	p := self paragraph characterBlockAtPoint: event cursorPoint.
	textArea markBlock: p pointBlock: p.
	self setEmphasisHereFromText.
	self storeSelectionInText.
	textArea announce: (RubMouseClick with: event)! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
wordAtCaret

	^self paragraph text asString wordBefore: self startIndex - 1
! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
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 hasCursor 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! !

!RubTextEditor methodsFor: 'private' stamp: ''!
sameColumn: start newLine: lineBlock forward: isForward
	"Private - Compute the index in my text
	with the line number derived from lineBlock,"
	" a one argument block accepting the old line number.
	The position inside the line will be preserved as good as possible"
	"The boolean isForward is used in the border case to determine if
	we should move to the beginning or the end of the line."
	| column currentLine offsetAtTargetLine targetEOL lines numberOfLines currentLineNumber targetLineNumber |
	self walkAlongDisplayedLine
		ifTrue: [lines := self paragraph lines.
			numberOfLines := self paragraph numberOfLines.
			currentLineNumber := self paragraph lineIndexOfCharacterIndex: start.
			currentLine := lines at: currentLineNumber]
		ifFalse: [lines := self lines.
			numberOfLines := lines size.
			currentLine := lines
				detect:[:lineInterval | lineInterval last >= start]
				ifNone:[lines last].
			currentLineNumber := currentLine second].
	column := start - currentLine first.
	targetLineNumber := ((lineBlock value: currentLineNumber) max: 1) min: numberOfLines.
	offsetAtTargetLine := (lines at: targetLineNumber) first.
	targetEOL := (lines at: targetLineNumber) last + (targetLineNumber = numberOfLines ifTrue:[1]ifFalse:[0]).
	targetLineNumber = currentLineNumber
	"No movement or movement failed. Move to beginning or end of line."
		ifTrue:[^isForward
			ifTrue:[targetEOL]
			ifFalse:[offsetAtTargetLine]].
	^offsetAtTargetLine + column min: targetEOL.! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
backTo: startIndex
	"Backspace typing"
	self stopIndex > startIndex ifTrue: [
		self selectFrom: startIndex to: self stopIndex - 1.
		self addDeleteSelectionUndoRecord.
		self zapSelectionWith: self nullText].
	^ false! !

!RubTextEditor methodsFor: 'obsolete - parenblinking' stamp: ''!
blinkPrevParen: aCharacter
	"kept because NECController is sending it to me"! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
find: aKeyboardEvent
	"Prompt the user for what to find, then find it, searching from the current selection onward."

	self closeTypeIn.
	self find.
	^ true! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
morph
	^ textArea! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
align: aKeyboardEvent
	"Triggered by Cmd-u;  cycle through alignment alternatives."

	self align.
	^ true! !

!RubTextEditor methodsFor: 'private' stamp: ''!
compose
	^textArea compose! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
lastFont	
	"Answer the Font for to be used if positioned at the end of the text"
	| t |	
	t := self text.	
	^ t fontAt: t size + 1! !

!RubTextEditor methodsFor: 'private' stamp: ''!
focusChanged
	"Nothing to do by default"! !

!RubTextEditor methodsFor: 'nesting' stamp: ''!
nestingForPaste: aString with: aCharacter 
	" To escape them, we double the character every time it's encountered"
	| result stream |
	result := WriteStream with: ''.
	stream := ReadStream on: aString string.
	[ stream atEnd ] whileFalse: 
		[ result nextPutAll: (stream upTo: aCharacter).
		stream peekBack = aCharacter ifTrue: [result nextPut: aCharacter]. 
		stream atEnd ifFalse: [ result nextPut: aCharacter ]
						 ifTrue: [ stream peekBack = aCharacter ifTrue: [result nextPut: aCharacter] ].].
	^result contents.! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
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]! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
escape 
	textArea escapePressed .
	! !

!RubTextEditor methodsFor: 'testing' stamp: ''!
hasError
	^ false ! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
setEmphasisHereFromTextForward: lookForward

	| i t forward delta prevIsSeparator nextIsSeparator |
	i := self pointIndex.
	t := self text.
	"Try to set emphasisHere correctly after whitespace.
	Most important after a cr, i.e. at the start of a new line"
	prevIsSeparator :=  i > 1 and: [ (t at: i-1) isSeparator ].
	nextIsSeparator := i <= t size and: [ (t at: i) isSeparator ].
	forward := prevIsSeparator = nextIsSeparator
		ifTrue: [ lookForward ]
		ifFalse: [ nextIsSeparator ].
	delta := forward ifTrue: [ 1 ] ifFalse: [ 0 ].
	self editingState emphasisHere: ((t attributesAt: (i - delta max: 1)) select: [:att | att mayBeExtended]).
	! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
offerFontMenu: aKeyboardEvent 
	"The user typed the command key that requests a font change; Offer the font menu."

	self closeTypeIn.
	self offerFontMenu.
	^ true! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
cancel: aKeyboardEvent
	"Cancel unsubmitted changes."
	self cancel.
	^ true! !

!RubTextEditor methodsFor: 'displaying' stamp: ''!
flash
	^ textArea flash! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
replaceAll: aRegex with: aText startingAt: startIdx
	self
		undoRedoTransaction: [ 
			| selec ranges |
			selec := self selectionInterval.
			ranges := self findAll: aRegex startingAt: startIdx.
			ranges
				reverseDo: [ :r | 
					self selectInvisiblyFrom: r first to: r last.
					self replaceSelectionWith: aText ].
			self selectInterval: selec ]! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
backspace: aKeyboardEvent
	| result startIndex |
	self closeTypeIn.
	result := aKeyboardEvent shiftPressed
		ifTrue: [ self backWord: aKeyboardEvent keyCharacter ]
		ifFalse: [ 
			self hasSelection
				ifTrue: [ 
					self replaceSelectionWith: self nullText. 
					textArea changed]
				ifFalse: [ 
					startIndex := self markIndex
						+
							(self hasCursor
								ifTrue: [ 0 ]
								ifFalse: [ 1 ]).
					startIndex := 1 max: startIndex - 1.
					self backTo: startIndex ].
			false ].
	^ result! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findAndSelectNextOccurrenceOf: aRegex
	| where |
	where := self findNext: aRegex startingAt: self stopIndex.
	where ifNotNil: [self selectInterval: where].
	^ where! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findAndSelectPreviousOccurrenceOf: aRegex

	| where |
	where := self findPrevious: aRegex startingAt: self startIndex.
	where ifNotNil: [ self selectInterval: where ].
	^ where! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
markIndex
	^ textArea markIndex! !

!RubTextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
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! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
findRegex
	^ self findReplaceService findRegex! !

!RubTextEditor methodsFor: 'undo - redo private' stamp: ''!
clearUndoManager: aKeyboardEvent
	^ self editingState clearUndoManager: aKeyboardEvent.
! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
atEndOfLineInsertAndSelect: aString

	self insertAndSelect: aString at: (self encompassParagraph: self selectionInterval) last + 1.! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
selectFrom: start to: stop
	"Select the specified characters inclusive."
	self selectInvisiblyFrom: start to: stop.
	self closeTypeIn.
	self storeSelectionInText.
	"Preserve current emphasis if selection is empty"
	stop > start 
		ifTrue: [self setEmphasisHereFromTextForward: true ]! !

!RubTextEditor methodsFor: 'keymapping' stamp: ''!
newDefaultKeymappingIndex
	defaultKeymappingIndex := IdentityDictionary new.
	defaultKeymappingIndex at: #command put: self defaultCommandKeymapping.
	^ defaultKeymappingIndex ! !

!RubTextEditor methodsFor: 'new selection' stamp: ''!
selectLine
	"Make the receiver's selection, if it currently consists of an insertion point only, encompass the current line."
	self hasSelection ifTrue: [^self].
	self selectInterval: self computeSelectionIntervalForCurrentLine! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
makeLowercase: aKeyboardEvent
	"Force the current selection to lowercase.  Triggered by Cmd-X."

	self closeTypeIn.
	self replaceSelectionWith: (Text fromString: (self selection string asLowercase)).
	^ true! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
crWithIndent: aKeyboardEvent
	"Replace the current text selection with CR followed by as many tabs
	as on the current line (+/- bracket count) -- initiated by Shift-Return."
	| char s i tabCount crChars|
	self closeTypeIn.
	s := self string.
	i := self stopIndex.
	tabCount := 0.
	crChars := Array with: Character cr with: Character lf.
	[(i := i-1) > 0 and: [(crChars includes: (char := s at: i)) not]]
		whileTrue:  "Count tabs and brackets (but not a leading bracket)"
		[(char = Character tab and: [i < s size and: [(s at: i+1) ~= $[ ]]) ifTrue: [tabCount := tabCount + 1].
		char = $[ ifTrue: [tabCount := tabCount + 1].
		char = $] ifTrue: [tabCount := tabCount - 1]].
	 "Now inject CR with tabCount tabs"
	self addString: (String streamContents: [ :strm | strm crtab: tabCount ]).
	self unselect.
	^ false! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
addString: aString
	"Think of a better name"
	self hasSelection 
		ifTrue: [self addDeleteSelectionUndoRecord].
	self openTypeIn.
	self zapSelectionWith: (Text string: aString attributes: self emphasisHere)! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
selectionStart
	^ textArea selectionStart! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
findNext: aRegex startingAt: searchIdx 
	| strm match range |
	strm := (self string copyFrom: searchIdx to: self string size) readStream.
	aRegex searchStream: strm.
	match := aRegex subexpression: 1.
	match ifNotNil: [range := (aRegex position + searchIdx - match size) to: (aRegex position + searchIdx - 1)].
	^ range! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
changeEmphasis: aKeyboardEvent
	"Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change.  Keeps typeahead."

	"control 0..9 -> 0..9"

	| keyCode attribute oldAttributes index thisSel colors |
	keyCode := ('0123456789-=' indexOf: aKeyboardEvent keyCharacter ifAbsent: [1]) - 1.
	oldAttributes := self text attributesAt: self pointIndex.
	thisSel := self selection.

	"Decipher keyCodes for Command 0-9..."
	"
	(keyCode between: 1 and: 5) 
		ifTrue: [attribute := TextFontChange fontNumber: keyCode].
	"
	keyCode = 6 
		ifTrue: [
			colors := #(#black #magenta #red #yellow #green #blue #cyan #white).
			index := UIManager default chooseFrom:  colors title: 'choose color...'.
			index = 0 ifTrue: [^true].
			index <= colors size 
				ifTrue: [attribute := TextColor color: (Color perform: (colors at: index))]
				ifFalse: [
					index := index - colors size - 1.	"Re-number!!!!!!"
					index = 0 ifTrue: [attribute := self chooseColor].
					thisSel ifNil: [^true]	"Could not figure out what to link to"]].
	(keyCode between: 7 and: 11) 
		ifTrue: [
			aKeyboardEvent shiftPressed 
				ifTrue: [
					keyCode = 10 ifTrue: [attribute := TextKern kern: -1].
					keyCode = 11 ifTrue: [attribute := TextKern kern: 1]]
				ifFalse: [
					attribute := TextEmphasis 
								perform: (#(#bold #italic #narrow #underlined #struckOut) at: keyCode - 6).
					oldAttributes 
						do: [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]].
	keyCode = 0 ifTrue: [ attribute := TextEmphasis normal ].
	attribute ifNotNil: [
		self applyAttribute: attribute].
	^true! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
startOfTyping
	^ self editingState startOfTyping  ! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
changeTextFont
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection."

	textArea
		forceCursorVisibleWhile: [ 
			| hadFocus |
			hadFocus := textArea hasFocus.
			(FontChooser
				openWithWindowTitle: 'Choose a Font'
				for: self
				setSelector: #applyTextFont:
				getSelector: self fontToUse) openModal.
			hadFocus
				ifTrue: [ textArea takeKeyboardFocus ] ]! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
stopIndex
	^ textArea stopIndex! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
redo: aKeyboardEvent 
	"Redo the last edit."

	self redo.
	^true! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
cancel
	"Cancel the changes made so far to this text"

	self canChangeText
		ifTrue: [ textArea cancelEdits ]! !

!RubTextEditor methodsFor: 'typing support' stamp: ''!
keystroke: aKeyboardEvent
	textArea announce: ((RubKeystroke with: aKeyboardEvent) morph: self).
	self normalCharacter: aKeyboardEvent.
	"normal character"
	self hasSelection
		ifTrue: [ 
			"save highlighted characters"
			self editingState previousInterval: self selectionInterval].
	"Notice selection changed"
	self unselect.
	self storeSelectionInText! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
caret
	"Return the index position of the caret"
	^ self startIndex ! !

!RubTextEditor methodsFor: 'typing/selecting keys' stamp: ''!
tab: aKeyboardEvent
	"Append a line feed character to the stream of characters."

	self addString: String tab.
	self unselect.
	^false! !

!RubTextEditor methodsFor: 'private' stamp: ''!
setIndices: shiftPressed forward: forward
	"Little helper method that sets the moving and fixed indices according to some flags."

	| indices |
	indices := Dictionary new.
	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! !

!RubTextEditor methodsFor: 'menu messages' stamp: ''!
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: [textArea flash.  ^ returnBlock value]! !

!RubTextEditor methodsFor: 'nesting' stamp: ''!
escapeCharacter: aCharacter inString: aString
	" To escape them, we double the character every time it's encountered"
	| result stream |
	result := WriteStream with: ''.
	stream := ReadStream on: aString string.
	[ stream atEnd ] whileFalse: 
		[ result nextPutAll: (stream upTo: aCharacter).
		stream peekBack = aCharacter ifTrue: [result nextPut: aCharacter]. 
		stream atEnd ifFalse: [ result nextPut: aCharacter ]
						 ifTrue: [ stream peekBack = aCharacter ifTrue: [result nextPut: aCharacter] ].].
	^result contents.! !

!RubTextEditor methodsFor: 'find-select' stamp: ''!
replaceAll: aRegex with: aText
	self
		undoRedoTransaction: [ 
			| selec ranges |
			selec := self selectionInterval.
			ranges := self findAll: aRegex startingAt: selec first.
			ranges
				reverseDo: [ :r | 
					self selectInvisiblyFrom: r first to: r last.
					self replaceSelectionWith: aText ].
			self selectInterval: selec ]! !

!RubTextEditor methodsFor: 'accessing' stamp: ''!
transformFrom: owner
	^textArea transformFrom: owner! !

!RubTextEditor methodsFor: 'editing keys' stamp: ''!
swapChars
	"Triggered byCmd-Y;.  Swap two characters, either those straddling the insertion point, or the two that comprise the selection.  Suggested by Ted Kaehler.  "

	^ self swapChars: nil! !

!RubTextEditor methodsFor: 'accessing - selection' stamp: ''!
pointIndex
	^ textArea pointIndex! !

!RubTextEditor methodsFor: 'events' stamp: ''!
tripleClick: evt
	self closeTypeIn.	"no matter what, if shift is pressed extend the selection"
	self selectLine.
	self setEmphasisHereFromText.
	self storeSelectionInText.! !

!RubTextEditor class methodsFor: 'keymapping' stamp: ''!
buildPatchShortcutsForSelectAllInWindowsOn: aBuilder
	<keymap>
	"this is because for some reason Ctrl+a means Ctrl+home on Windows"
	(aBuilder shortcut: #selectAllPatchForWin) 
		category: RubTextEditor name
		default: Character home ctrl win
		do: [ :target | target editor selectAll: nil ]
		description: 'Select all'
! !

!RubTextEditor class methodsFor: 'keymapping' stamp: ''!
buildShortcutsOn: aBuilder
	"We are defining the bindings twice because we want to support 
	both Cmd and Ctrl for Windows and Linux. This should happen at least as long as in the development environment
	both of these are supported.
	
	We list both variations explicitly because we want to be able to see the action code when inspecting the morph.
	"
	<keymap>
	(aBuilder shortcut: #cancel) 
		category: RubTextEditor name
		default: $l meta
		do: [ :target | target editor cancel ]
		description: 'Cancel unsaved editings'.
		
	(aBuilder shortcut: #accept) 
		category: RubTextEditor name
		default: $s meta
		do: [ :target | target editor accept ]
		description: 'Accept unsaved editings'.
	
	(aBuilder shortcut: #selectAll) 
		category: RubTextEditor name
		default: $a meta
		do: [ :target | target editor selectAll: nil ]
		description: 'Select all'.

	(aBuilder shortcut: #copySelection) 
		category: RubTextEditor name
		default: $c meta
		do: [ :target | target editor copySelection ]
		description: 'Copy selection'.

	(aBuilder shortcut: #paste) 
		category: RubTextEditor name
		default: $v meta
		do: [ :target | target editor paste ]
		description: 'Paste'.

	(aBuilder shortcut: #cut) 
		category: RubTextEditor name
		default: $x meta
		do: [ :target | target editor cut ]
		description: 'Cut selection'.

	(aBuilder shortcut: #undometa) 
		category: RubTextEditor name
		default: $z meta
		do: [ :target | target editor undo ]
		description: 'Undo'.

	(aBuilder shortcut: #redometa) 
		category: RubTextEditor name
		default: $z meta shift
		do: [ :target | target editor redo ]
		description: 'Redo'.

	(aBuilder shortcut: #find) 
		category: RubTextEditor name
		default: $f meta
		do: [ :target | target editor find: nil ]
		description: 'Find text'.

	(aBuilder shortcut: #findAgainmeta) 
		category: RubTextEditor name
		default: $g meta
		do: [ :target | target editor findAgain: nil ]
		description: 'Find text again'.
		
	(aBuilder shortcut: #indent) 
		category: RubTextEditor name
		default: $r meta shift
		do: [ :target | target editor indent: nil ]
		description: 'Indent'.

	(aBuilder shortcut: #outdent) 
		category: RubTextEditor name
		default: $l meta shift
		do: [ :target | target editor outdent: nil ]
		description: 'Outdent'.

	(aBuilder shortcut: #compareToClipboard) 
		category: RubTextEditor name
		default: $c meta shift
		do: [ :target | target editor compareToClipboard: nil ]
		description: 'Compare selection to clipboard'.! !

!RubTextEditor class methodsFor: 'instance creation' stamp: ''!
forTextArea: aMorph
	^ self new textArea: aMorph! !

!RubTextFieldArea commentStamp: ''!
I am a TextArea that only has one line of text.!
!RubTextFieldArea methodsFor: 'private' stamp: ''!
privateReplaceFrom: start to: stop with: aText

	super privateReplaceFrom: start to: stop with: (self sanitize: aText)! !

!RubTextFieldArea methodsFor: 'compatibility-toBeDeprecated' stamp: ''!
wrapped: aBoolean

	" not effect for a text field because such a morph is never wrapped "! !

!RubTextFieldArea methodsFor: 'settings' stamp: ''!
walkAlongDisplayedLine
	^ false! !

!RubTextFieldArea methodsFor: 'private' stamp: ''!
sanitize: aText
	| lineEndings |
	lineEndings := { Character cr. Character lf }.
	"Remove line endings that may have been introduced via copy-paste, but only if we have to because it will remove all text attributes"
	^ (aText includesAnyOf: lineEndings)
		ifTrue: [ aText copyWithoutAll: lineEndings ]
		ifFalse: [ aText ]! !

!RubTextFieldArea methodsFor: 'compatibility-toBeDeprecated' stamp: ''!
wrapFlag: aBoolean
	" not effect for a text field because such a morph is never wrapped "! !

!RubTextFieldArea methodsFor: 'private' stamp: ''!
newParagraph
	^ RubExtraSelectionDecorator next: super newParagraph
! !

!RubTextFieldArea methodsFor: 'defaults' stamp: ''!
defaultMargins

	^ Margin left: 2 right: 2 top: 0 bottom: 1! !

!RubTextFieldAreaTest methodsFor: 'tests' stamp: ''!
testReplacementWithMaxLength
	| m |
	m := RubTextFieldArea new
		width: 300;
		maxLength: 3;
		yourself.
	m setTextWith: 'AAAA'.
	self assert: m string equals: 'AAA'.
	m privateReplaceFrom: 1 to: 3 with: 'BBB'.
	self assert: m string equals: 'BBB'.
	m privateReplaceFrom: 3 to: 3 with: 'CCC'.
	self assert: m string equals: 'BBC'.
	m privateReplaceFrom: 1 to: 3 with: 'XXXXXXXXXXXXXXXXXX'.
	self assert: m string equals: 'XXX'! !

!RubTextFieldAreaTest methodsFor: 'tests' stamp: ''!
testPrivateReplaceFromTo
	| m |
	m := RubTextFieldArea new
		width: 300;
		yourself.
	self assert: m string isEmpty.
	m privateReplaceFrom: 1 to: 0 with: 'AAA'.
	self assert: m string equals: 'AAA'.
	m privateReplaceFrom: 1 to: 3 with: 'BBB'.
	self assert: m string equals: 'BBB'.
	m privateReplaceFrom: 3 to: 3 with: 'CCC'.
	self assert: m string equals: 'BBCCC'.
	m privateReplaceFrom: 3 to: 2 with: 'DDD'.
	self assert: m string equals: 'BBDDDCCC'! !

!RubTextFieldAreaTest methodsFor: 'tests' stamp: ''!
testnewSizeAfterUpdate
	| m |
	" "
	m := RubTextFieldArea new
		width: 300;
		yourself.
	m setTextWith: ''.
	self assert: m text isEmpty.
	"the  receiver text  size after inserting 'BBB' would be 3"
	self
		assert: (m newSizeAfterUpdateFrom: 1 to: 0 with: 'BBB')
		equals: 3.
	m setTextWith: 'AAAA'.
	self assert: m string equals: 'AAAA'.
	"the receiver text  size after the replacement 'BBB' would be 4 "
	self 
		assert: (m newSizeAfterUpdateFrom: 1 to: 3 with: 'BBB')
		equals: 4.
	self
		assert: (m newSizeAfterUpdateFrom: 1 to: 4 with: 'BBB')
		equals: 3.
	"the receiver text  size after inserting 'BBB' at start  would be 7 "
	self
		assert: (m newSizeAfterUpdateFrom: 1 to: 0 with: 'BBB')
		equals: 7! !

!RubTextFieldAreaTest methodsFor: 'tests' stamp: ''!
testKeyStrokeBackSpaceWithMaxLength
	| m |
	m := RubTextFieldArea new
		width: 300;
		maxLength: 2;
		yourself.
	self assert: m string size equals: 0.
	m handleEvent: (self simulatedKeyStrokeFromChar: $a).
	self assert: m string equals: 'a'.
	m handleEvent: (self simulatedKeyStrokeFromChar: $b).
	self assert: m string equals: 'ab'.
	m handleEvent: (self simulatedKeyDownFromChar: Character backspace).
	self assert: m string equals: 'a'.
	m handleEvent: (self simulatedKeyStrokeFromChar: $c).
	self assert: m string equals: 'ac'.
	m handleEvent: (self simulatedKeyStrokeFromChar: $d).
	self assert: m string equals: 'ac'! !

!RubTextFieldAreaTest methodsFor: 'tests' stamp: ''!
testKeyStrokeWithMaxLength
	| m |
	m := RubTextFieldArea new
		width: 300;
		maxLength: 0;
		yourself.
	self assert: m string isEmpty.
	m handleEvent: (self simulatedKeyStrokeFromChar: $a).
	self assert: m string isEmpty.
	m maxLength: 2.
	m keyStroke: (self simulatedKeyStrokeFromChar: $a).
	self assert: m string equals: 'a'.
	m keyStroke: (self simulatedKeyStrokeFromChar: $b).
	self assert: m string equals: 'ab'.
	m keyStroke: (self simulatedKeyStrokeFromChar: $c).
	self assert: m string equals: 'ab'.! !

!RubTextFieldAreaTest methodsFor: 'tests' stamp: ''!
testMaxLengthTruncatesText
	| m |
	m := RubTextFieldArea new
		width: 300;
		maxLength: 15;
		yourself.
	m setTextWith: '01234567890123456'.
	" the text should be truncated "
	self assert: m text size equals: 15.
	
	" the text is different to ensure that the input is validate and update is sent instead of set "
	m updateTextWith: '7890123456789012345'.
	self assert: m text size equals: 15.
	
	" with a text of size less than maxlength  to check that maxLength has no effect "
	m setTextWith: ''.
	self assert: m text size equals: 0.	
	m setTextWith: 'A'.
	self assert: m text size equals: 1.
	m updateTextWith: ''.
	self assert: m text size equals: 0! !

!RubTextFieldAreaTest methodsFor: 'utilities' stamp: ''!
simulatedKeyStrokeFromChar: aCharacter

	^ self simulatedKeyStrokeFromChar: aCharacter alt: false ctrl: false command: false shift: false! !

!RubTextFieldAreaTest methodsFor: 'utilities' stamp: ''!
simulatedKeyDownFromChar: aCharacter

	^ self simulatedKeyDownFromChar: aCharacter alt: false ctrl: false command: false shift: false! !

!RubTextFieldAreaTest methodsFor: 'utilities' stamp: ''!
simulatedKeyStrokeFromChar: aCharacter 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 := aCharacter asInteger.
	event
		setType: #keystroke
		buttons: modifier
		position: 0 @ 0
		keyValue: code
		charCode: code
		hand: self currentWorld currentHand 
		stamp: Time now.
	^ event! !

!RubTextFieldAreaTest methodsFor: 'utilities' stamp: ''!
simulatedKeyDownFromChar: aCharacter 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 := aCharacter asInteger.
	event
		setType: #keyDown
		buttons: modifier
		position: 0 @ 0
		keyValue: code
		charCode: code
		hand: self currentWorld currentHand 
		stamp: Time now.
	event key: (KeyboardKey fromCharacter: aCharacter).
	^ event! !

!RubTextFieldAreaTest methodsFor: 'tests' stamp: ''!
testInsertionWithMaxLength
	| m |
	m := RubTextFieldArea new
		width: 300;
		maxLength: 3;
		yourself.
	self assert: m string isEmpty.
	m privateReplaceFrom: 1 to: 0 with: 'AAA'.
	self assert: m string equals: 'AAA'.
	m privateReplaceFrom: 1 to: 3 with: 'BBB'.
	self assert: m string equals: 'BBB'.
	m privateReplaceFrom: 3 to: 3 with: 'CCC'.
	self assert: m string equals: 'BBC'.
	m privateReplaceFrom: 3 to: 2 with: 'DDD'.
	self assert: m string equals: 'BBD'! !

!RubTextFieldAreaTest methodsFor: 'tests' stamp: ''!
testMaxLengthIsSet
	| m |
	m := RubTextFieldArea new
		width: 300;
		maxLength: 15;
		yourself.
	self assert: m maxLength equals: 15! !

!RubTextFieldAreaTest methodsFor: 'tests' stamp: ''!
testMaxLengthIsNegative
	| m |
	m := RubTextFieldArea new
		width: 300;
		maxLength: -10;
		yourself.
	m setTextWith: '01234567890123456'.
	self assert: m text size equals: 0.
! !

!RubTextFieldAreaTest methodsFor: 'tests' stamp: ''!
testWhenWeHaveTheRubTextFieldAreaInsideOtherMorphHasToHonorTheExtentAssignedToIt

	| dropList widthOfButton |

	"The drop list has two morphs inside, one RubTextFieldArea and a Button.
	The button has a fixed side. 
	The text field takes all the remaining size."	
	dropList := DropListMorph new
		     list: { (String loremIpsum: 100) };
		     enabled: true;
		     listSelectionIndex: 1;
		     yourself.

	dropList extent: 100 @ 18.
	dropList computeBounds. 
	
	self assert: dropList extent x equals: 100.

	widthOfButton := (dropList submorphs at: 2) extent x.
	
	"The text area should take the remaining size without overlapping in the button"	
	self assert: (dropList submorphs at: 1) extent x equals: 74.! !

!RubTextFieldExample commentStamp: ''!
self open.

self openWithScrollbar.

self openWithBorderOfWidth: 1.
self openWithBorderOfWidth: 5.

self openWithScrollbarAndBorderOfWidth: 0.
self openWithScrollbarAndBorderOfWidth: 1.
self openWithScrollbarAndBorderOfWidth: 5.

self openAutoAccept.!
!RubTextFieldExample methodsFor: 'accessing' stamp: ''!
string: aString
	string := aString! !

!RubTextFieldExample methodsFor: 'user interface' stamp: ''!
newScrolledTextAutoAccept
	| st |
	st := (RubTextFieldMorph
		on: self)
		withAdornment;
		withGhostText: 'Input field bla bla bla bla bla bla';
		autoAccept: true;
		yourself.
	st width: 300.
	^st! !

!RubTextFieldExample methodsFor: 'user interface' stamp: ''!
setText: aText from: aView 
	self string: aText string.
	"return true to remove unaccepted edit adornment in tge view"
	^ true! !

!RubTextFieldExample methodsFor: 'user interface' stamp: ''!
newScrolledTextWithScrollbar
	^ self newScrolledText hScrollbarShowAlways! !

!RubTextFieldExample methodsFor: 'menu' stamp: ''!
menu
	^ nil! !

!RubTextFieldExample methodsFor: 'accessing' stamp: ''!
string
	^ string ifNil: [ string := '' ]! !

!RubTextFieldExample methodsFor: 'user interface' stamp: ''!
newScrolledText
	| st |
	st := (RubTextFieldMorph on: self)
		withAdornment;
		withGhostText: 'Input field bla bla bla bla bla bla';
		yourself.
	st width: 300.
	st textArea forbidMenu.
	^ st! !

!RubTextFieldExample methodsFor: 'user interface' stamp: ''!
newScrolledTextWithBorderOfWidth: anInteger
	^ self newScrolledText borderWidth: anInteger.! !

!RubTextFieldExample methodsFor: 'user interface' stamp: ''!
newScrolledTextWithScrollbarAndBorderOfWidth: anInteger
	^ self newScrolledText hScrollbarShowAlways; borderWidth: anInteger! !

!RubTextFieldExample methodsFor: 'user interface' stamp: ''!
getText
	^ self string asText! !

!RubTextFieldExample methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer ifNil: [ announcer := Announcer new ]! !

!RubTextFieldExample class methodsFor: 'examples' stamp: ''!
openAutoAccept
	| st model |
	model := self new.
	st := model newScrolledTextAutoAccept.
	model inspect.
 	st openInWorld
! !

!RubTextFieldExample class methodsFor: 'examples' stamp: ''!
exampleOpen
	| st |
	st := self new newScrolledText.
 	st openInWorld
! !

!RubTextFieldExample class methodsFor: 'examples' stamp: ''!
openWithScrollbarAndBorderOfWidth: anInteger
	| st |
	st := self new newScrolledTextWithScrollbarAndBorderOfWidth: anInteger.
 	st openInWorld
! !

!RubTextFieldExample class methodsFor: 'examples' stamp: ''!
openWithScrollbar
	| st |
	st := self new newScrolledTextWithScrollbar.
 	st openInWorld
! !

!RubTextFieldExample class methodsFor: 'examples' stamp: ''!
openWithBorderOfWidth: anInteger
	| st |
	st := self new newScrolledTextWithBorderOfWidth: anInteger.
 	st openInWorld
! !

!RubTextFieldMorph commentStamp: ''!
I am a morph for a text area which has only one line, like search field!
!RubTextFieldMorph methodsFor: 'defaults' stamp: ''!
manageLayoutInBounds: aRectangle
	super manageLayoutInBounds: aRectangle.
	self closeChooser ! !

!RubTextFieldMorph methodsFor: 'encryption' stamp: ''!
beDecrypted

	encrypted := false.
	self textMorph font: TextStyle defaultFont.! !

!RubTextFieldMorph methodsFor: 'focus' stamp: ''!
keyboardFocusChange: aBoolean
	self closeChooser.
	super keyboardFocusChange: aBoolean.
! !

!RubTextFieldMorph methodsFor: 'testing' stamp: ''!
chooserIsOpened
	^ entryCompletion notNil and: [entryCompletion chooser notNil]! !

!RubTextFieldMorph methodsFor: 'initialization' stamp: ''!
outOfWorld: aWorld
	self closeChooser.
	super outOfWorld: aWorld! !

!RubTextFieldMorph methodsFor: 'event handling' stamp: ''!
updateChooser
	entryCompletion
		ifNotNil: [  self openChooser ] ! !

!RubTextFieldMorph methodsFor: 'defaults' stamp: ''!
defaultGhostTextMorph
	^ super defaultGhostTextMorph beNotWrapped ! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
acceptOnCR: aBoolean
	acceptOnCR := aBoolean! !

!RubTextFieldMorph methodsFor: 'drawing' stamp: ''!
adornmentColor
	"color to Indicate edit status for the given morph."

	self hasValidText
		ifFalse: [ ^ Color red ].
	^ super adornmentColor! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
entryCompletion: anEntryCompletion

	entryCompletion := anEntryCompletion.
	entryCompletion
		ifNil: [ self withoutDropListButton ]
		ifNotNil: [ self withDropListButton.
			entryCompletion chooseBlock
				ifNil: [ entryCompletion
						chooseBlock: [ :v | 
							self setText: v.
							self acceptTextInModel
							]
					]
				ifNotNil: [ | blk |

					blk := entryCompletion chooseBlock.
					entryCompletion
						chooseBlock: [ :v | 
							self setText: v.
							self acceptTextInModel.
							blk value: v
							]
					]
			]! !

!RubTextFieldMorph methodsFor: 'initialization' stamp: ''!
textAreaClass
	^ RubTextFieldArea! !

!RubTextFieldMorph methodsFor: 'testing' stamp: ''!
chooserHasFocus
	^ self chooserIsOpened and: [entryCompletion chooser hasKeyboardFocus]! !

!RubTextFieldMorph methodsFor: 'focus' stamp: ''!
focusChanged
	(self hasFocus or: [self chooserHasFocus])
		ifFalse: [self closeChooser].
	super focusChanged
! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
maxLength: anInteger
	"Sets the max length of the text field.
	0 means unlimited"
	maxLength := anInteger.
	maxLength = 0 ifTrue: [ ^ self ].
	
	"If the contents of this textfield exceed the max length, contents are truncated"
	self getText size > maxLength
		ifTrue: [ self setText: (self getText first: maxLength) ]! !

!RubTextFieldMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	super extent: aPoint x @ self textFieldHeight! !

!RubTextFieldMorph methodsFor: 'event handling' stamp: ''!
whenReturnEntered: anAnnouncement
	self acceptOnCR
		ifTrue: [
			anAnnouncement accepted: true ].
	self changed! !

!RubTextFieldMorph methodsFor: 'model protocol' stamp: ''!
on: aModel text: aGetTextSelector accept: aSetTextSelector readSelection: aReadSelectionSelector menu: aGetMenuSelector
	self getTextSelector: aGetTextSelector.
	self setTextSelector: aSetTextSelector.
	self getSelectionSelector: aReadSelectionSelector.
	aGetMenuSelector
		ifNil: [ self textArea forbidMenu ]
		ifNotNil: [ self menuProvider: aModel selector: aGetMenuSelector ].
	self on: aModel! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
openChooser	
	entryCompletion
		ifNotNil: [
			entryCompletion openChooserWith: self textArea text string from: self]! !

!RubTextFieldMorph methodsFor: 'event handling' stamp: ''!
whenKeystrokeInTextArea: anAnnouncement
	super whenKeystrokeInTextArea: anAnnouncement.
	entryCompletion ifNotNil: [entryCompletion keystroke: anAnnouncement event from: self]! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
configureGhostText: aTextArea

	"Text Input always is in the middle of the text input"

	super configureGhostText: aTextArea.
	aTextArea center: self scrollBounds center.
	aTextArea left: self scrollBounds left ! !

!RubTextFieldMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	hasValidText := true.
	self textArea announcer when: RubReturnEntered  send: #whenReturnEntered: to: self.
	self scrollbarsShowNever.
	self extent: self extent.
	acceptOnCR := true.
	maxLength := 0.
	self beDecrypted! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
closeChooser	
	entryCompletion
		ifNotNil: [entryCompletion closeChooser]! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
encrypted: aBoolean

	aBoolean
		ifTrue: [ self beEncrypted ]
		ifFalse: [ self beDecrypted ]! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
entryCompletion 
	^ entryCompletion ! !

!RubTextFieldMorph methodsFor: 'accessing - text area' stamp: ''!
font: aNewFont
	
	"As the text field is using a font full of * to show the password.
	Changing the font should preserve it"
	encrypted ifTrue: [ 
		^ super font: (StrikeFont passwordFontSize: aNewFont pointSize). ].

	super font: aNewFont! !

!RubTextFieldMorph methodsFor: 'protocol' stamp: ''!
disable
	self beReadOnly ! !

!RubTextFieldMorph methodsFor: 'model protocol' stamp: ''!
hasValidText: aBoolean
	hasValidText := aBoolean! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
maxLength
	
	"Returns the max length of this text field.
	0 meaning unlimited"
	^ maxLength! !

!RubTextFieldMorph methodsFor: 'model protocol' stamp: ''!
acceptTextInModel
	"Inform the model that the receiver's textArea text should be accepted.
	Answer true if the model accepted ok, something else otherwise (sic)"
	| result |
	result := super acceptTextInModel.
	"Yes, we check here with == instead of with #ifTrue:. 
	That's bad but  some models don't return true of false"
	result == true ifTrue: [ self closeChooser ].
	^ result
! !

!RubTextFieldMorph methodsFor: 'geometry' stamp: ''!
textFieldHeight
	| vgap |
	vgap := self currentHScrollBarThickness isZero
		ifTrue: [  0 ]
		ifFalse: [ self currentHScrollBarThickness - 1 ].
	^ self textArea height + 1 + (self borderWidth * 2) + vgap! !

!RubTextFieldMorph methodsFor: 'event handling' stamp: ''!
textChanged
	super textChanged.
	self updateChooser.
! !

!RubTextFieldMorph methodsFor: 'initialization' stamp: ''!
withDropListButton
	self withRulerNamed: #dropListButton! !

!RubTextFieldMorph methodsFor: 'compatibility' stamp: ''!
cursorEnd: aKeyboardEvent 
	^ self textMorph editor cursorEnd: aKeyboardEvent ! !

!RubTextFieldMorph methodsFor: 'encryption' stamp: ''!
beEncrypted
	
	encrypted := true.
	self textMorph font: (StrikeFont passwordFontSize: self theme textFont pointSize).! !

!RubTextFieldMorph methodsFor: 'model protocol' stamp: ''!
hasValidText
	^ hasValidText! !

!RubTextFieldMorph methodsFor: 'model protocol' stamp: ''!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel setSelection: setSelectionSel
	self
		on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: getSelectionSel
		menu: getMenuSel.
	setSelectionSelector := setSelectionSel.
	self borderWidth: 1.
	self setText: self getTextFromModel.
	self setSelection: self getSelectionFromModel! !

!RubTextFieldMorph methodsFor: 'private' stamp: ''!
resetState
	hasValidText := true.
	super resetState! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
acceptOnCR
	^ acceptOnCR ! !

!RubTextFieldMorph methodsFor: 'accessing' stamp: ''!
wantsFrameAdornments: aBoolean
	aBoolean ifTrue: [ self withAdornment  ] ifFalse: [ self withoutAdornment ]! !

!RubTextFieldMorph methodsFor: 'initialization' stamp: ''!
withoutDropListButton
	self withoutRulerNamed: #dropListButton! !

!RubTextFieldWithEntryCompletionExample methodsFor: 'user interface' stamp: ''!
readMySelection: aSelection
	^ 1 to: -1! !

!RubTextFieldWithEntryCompletionExample methodsFor: 'accessing' stamp: ''!
pkgName: aPackageName
	pkgName := aPackageName.
	^ true! !

!RubTextFieldWithEntryCompletionExample methodsFor: 'user interface' stamp: ''!
newScrolledText
	| st |
	st := (RubPluggableTextFieldMorph new
		on: self
		text: #pkgName
		accept: #pkgName:
		readSelection: #readMySelection:
		menu: #getMyMenu:)
		withGhostText: 'Enter an existing package name';
		entryCompletion: self packagesEntryCompletion;
		withDropListButton;
		yourself.
	st width: 300.
	^ st! !

!RubTextFieldWithEntryCompletionExample methodsFor: 'menu' stamp: ''!
getMyMenu: aMenu
	^ nil! !

!RubTextFieldWithEntryCompletionExample methodsFor: 'accessing' stamp: ''!
pkgName
	^ pkgName! !

!RubTextFieldWithEntryCompletionExample methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer ifNil: [ announcer := Announcer new ]! !

!RubTextFieldWithEntryCompletionExample methodsFor: 'accessing' stamp: ''!
packagesEntryCompletion
	| applicants |
	applicants := RPackageOrganizer default packages
		collect: [ :package | package packageName asString ].
	^ EntryCompletion new
		dataSourceBlock: [ :currText | applicants ];
		filterBlock: [ :currApplicant :currText | 
			 currApplicant asUppercase includesSubstring: currText asString asUppercase ]! !

!RubTextFieldWithEntryCompletionExample class methodsFor: 'examples' stamp: ''!
exampleOpen
	| st |
	st := self new newScrolledText.
 	st openInWorld.
	^ st
! !

!RubTextInsertionStrategy commentStamp: ''!
I insert the notification directly in the text at the given position. (I alter the content of the text editor)!
!RubTextInsertionStrategy methodsFor: 'notification' stamp: ''!
notify: aString at: anInteger in: aStream 
	"The compilation of text failed. The syntax error is noted as the argument, 
	aString. Insert it in the text at starting character position anInteger."

	| pos |
	pos := self editor selectionInterval notEmpty
		ifTrue: [self editor startIndex + anInteger - 1 ]
		ifFalse: [anInteger].
	self editor insertAndSelect: aString at: (pos max: 1)! !

!RubTextLine commentStamp: ''!
I represent a line of text!
!RubTextLine methodsFor: 'accessing' stamp: ''!
topRight
	^ right @ top! !

!RubTextLine methodsFor: 'private' stamp: ''!
firstIndex: firstInteger lastIndex: lastInteger
	firstIndex := firstInteger.
	lastIndex := lastInteger! !

!RubTextLine methodsFor: 'comparing' stamp: ''!
= line
	^ self species = line species
		ifTrue: [ ((firstIndex = line first and: [ lastIndex = line last ]) and: [ internalSpaces = line internalSpaces ]) and: [ paddingWidth = line paddingWidth ] ]
		ifFalse: [ false ]! !

!RubTextLine methodsFor: 'comparing' stamp: ''!
hash
	"#hash is re-implemented because #= is re-implemented"
	^firstIndex hash bitXor: lastIndex hash! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
rectangle: lineRectangle
	left := lineRectangle left.
	right := lineRectangle right.
	top := lineRectangle top.
	bottom := lineRectangle bottom! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
actualWidth
	^ actualWidth ifNil: [ 0 ] "self right - self paddingWidth"! !

!RubTextLine methodsFor: 'updating' stamp: ''!
moveBy: delta 
	"Move my rectangle by the given delta"
	left := left + delta x.
	right := right + delta x.
	top := top + delta y.
	bottom := bottom + delta y.
! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
stopCondition
	^ stopCondition! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
bottomRight
	^ right@bottom! !

!RubTextLine methodsFor: 'updating' stamp: ''!
slideIndexBy: delta andMoveTopTo: newTop
	"Relocate my character indices and y-values.
	Used to slide constant text up or down in the wake of a text replacement."

	firstIndex := firstIndex + delta.
	lastIndex := lastIndex + delta.
	bottom := bottom + (newTop - top).
	top := newTop.
! !

!RubTextLine methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream space; print: firstIndex; nextPutAll: ' to: '; print: lastIndex! !

!RubTextLine methodsFor: 'scanning' stamp: ''!
justifiedPadFor: spaceIndex font: aFont
	"Compute the width of pad for a given space in a line of justified text."

	| pad |
	internalSpaces = 0 ifTrue: [^0].
	^(aFont notNil and:[aFont isSubPixelPositioned])
		ifTrue:[paddingWidth * 1.0 / internalSpaces]
		ifFalse:[
			pad := paddingWidth // internalSpaces.
			spaceIndex <= (paddingWidth \\ internalSpaces)
				ifTrue: [pad + 1]
				ifFalse: [pad]]
		! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
internalSpaces
	"Answer the number of spaces in the line."

	^internalSpaces! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
rightMargin
	"This has to get fixed -- store during composition"
	^ self right! !

!RubTextLine methodsFor: 'private' stamp: ''!
internalSpaces: spacesInteger paddingWidth: padWidthInteger

	internalSpaces := spacesInteger asInteger.
	paddingWidth := padWidthInteger asInteger! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
lineNumber
	^ lineNumber! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
first
	^ firstIndex! !

!RubTextLine methodsFor: 'scanning' stamp: ''!
justifiedTabDeltaFor: spaceIndex
	"Compute the delta for a tab in a line of justified text, so tab falls 
	somewhere plausible when line is justified."

	| pad extraPad |
	internalSpaces = 0 ifTrue: [ ^ 0 ].
	pad := paddingWidth // internalSpaces.
	extraPad := paddingWidth \\ internalSpaces.
	^ spaceIndex <= extraPad
		ifTrue: [ spaceIndex * (pad + 1) ]
		ifFalse: [ extraPad * (pad + 1) + ((spaceIndex - extraPad) * pad) ]! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
last
	^ lastIndex! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
leftMargin
	"This has to get fixed -- store during composition"
	^ self left! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
bottomLeft
	^ left@bottom! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
leftMargin: lm
	left := lm! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
leftMarginForAlignment: alignmentCode
	alignmentCode = RightFlush ifTrue: [^ self left + paddingWidth].
	alignmentCode = Centered ifTrue: [^ self left + (paddingWidth//2)].
	^ self left  "leftFlush and justified"! !

!RubTextLine methodsFor: 'scanning' stamp: ''!
justifiedPadFor: spaceIndex
	"Compute the width of pad for a given space in a line of justified text."

	| pad |
	internalSpaces = 0 ifTrue: [ ^ 0 ].
	pad := paddingWidth // internalSpaces.
	^ spaceIndex <= (paddingWidth \\ internalSpaces)
		ifTrue: [ pad + 1 ]
		ifFalse: [ pad ]! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
lineHeight
	^ bottom - top! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
lineNumber: anInteger
	lineNumber := anInteger! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
rectangle
	^ self topLeft corner: self bottomRight! !

!RubTextLine methodsFor: 'updating' stamp: ''!
slide: delta 
	"Change the starting and stopping points of the line by delta."

	firstIndex := firstIndex + delta.
	lastIndex := lastIndex + delta! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
bottom
	^ bottom! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
right
	^ right! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
paddingWidth
	"Answer the amount of space to be added to the font."

	^paddingWidth! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
actualWidth: anObject
	actualWidth := anObject! !

!RubTextLine methodsFor: 'private' stamp: ''!
lineHeight: height baseline: ascent
	bottom := top + height.
	baseline := ascent! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
width
	^ right - left! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
left
	^ left! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
setRight: x
	right := x! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
topLeft
	^ left @ top! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
internalSpaces: spacesInteger 
	"Set the number of spaces in the line to be spacesInteger."

	internalSpaces := spacesInteger! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
height
	^ self bottom - self top! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
paddingWidth: padWidthInteger 
	"Set the amount of space to be added to the font to be padWidthInteger."

	paddingWidth := padWidthInteger asInteger! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
stopCondition: aSymbol
	stopCondition := aSymbol! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
top
	^ top! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
stop: stopInteger 
	"Set the stopping point in the string of the line to be stopInteger."

	lastIndex := stopInteger! !

!RubTextLine methodsFor: 'accessing' stamp: ''!
baseline
	^ baseline! !

!RubTextLine class methodsFor: 'instance creation' stamp: ''!
start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger
	"Answer an instance of me with the arguments as the start, stop points, 
	number of spaces in the line, and width of the padding."
	| line |
	line := self new firstIndex: startInteger lastIndex: stopInteger.
	^ line internalSpaces: spacesInteger paddingWidth: padWidthInteger! !

!RubTextScrollPane commentStamp: ''!
I am a text morph with a scrollbar !
!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
beWrapped
	self handleWrappingPolicyChange: [ self textArea beWrapped ]! !

!RubTextScrollPane methodsFor: 'accessing' stamp: ''!
paragraph
	^ self textArea paragraph ! !

!RubTextScrollPane methodsFor: 'geometry' stamp: ''!
position: aPoint
	"Update the receiver's extent. Hide/show the scrollbars and resize the scroller
	as neccessary."
	| previousBounds |
	previousBounds := self bounds copy.
	previousBounds topLeft = aPoint
		ifTrue: [ ^ self ].
	super position: aPoint! !

!RubTextScrollPane methodsFor: 'initialization' stamp: ''!
registerTextArea
	self hasTextArea
		ifTrue: [
			self textArea scrollPane: self.
			self updateScrollbars ]! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
handleWrappingPolicyChange: aBlock
	aBlock value.
	self wrapped
		ifTrue: [ 
			self fitScrollTargetWidth.
			self updateScrollbars ]! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
scrollToEndOfText
	self vScrollbarValue: 1;
	updateScrollbars! !

!RubTextScrollPane methodsFor: 'geometry' stamp: ''!
fitScrollTargetWidth
	"if the scroller extent is different that the textArea 
	extent, then, if the textArea is wrapped, then resize 
	the textArea width accordingly
	If the textArea is not wrapped, then do nothing
	"
	self scroller width = self textArea width
		ifFalse: [ self textArea width: self scrollBounds width ]! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
vScrollbarValue: scrollValue
	self announcer announce: (RubVerticalScrolled scrollValue: scrollValue).
	self handleScrollerOffsetChange: [ super vScrollbarValue: scrollValue ]! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
hLeftoverScrollRange
	"Return the entire scrolling range minus the currently viewed area."
	^self textArea width  - self scrollBounds width max: 0! !

!RubTextScrollPane methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas 
	"Draw the focus here since we are using inset bounds
	for the focus rectangle."

	super drawSubmorphsOn: aCanvas.
	self textArea readOnly ifTrue: [ ^self ].
	self drawFocusBorder ifFalse: [ ^ self ].
	(self hasKeyboardFocus or: [ self textArea hasFindReplaceFocus ]) 
		ifTrue: [self drawKeyboardFocusOn: aCanvas].
! !

!RubTextScrollPane methodsFor: 'accessing' stamp: ''!
hasKeyboardFocus
	"Answer whether the receiver has keyboard focus."

	^ super hasKeyboardFocus or: [(self textArea ifNil: [^false]) hasKeyboardFocus]! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
handleScrollerOffsetChange: aBlock
	| prevOffset ret |
	prevOffset := self offset.
	ret := aBlock value.
	(self offset ~= prevOffset and: [ self owner notNil ])
		ifTrue: [ self owner scrollerOffsetChanged ].
	^ ret! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
hasTextArea
	^ self scroller submorphs notEmpty! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
wrapped: aBoolean
	self handleWrappingPolicyChange: [ self textArea wrapped: aBoolean ]! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
vScrollbarValueWithoutAnnouncement: scrollValue
	self handleScrollerOffsetChange: [ super vScrollbarValue: scrollValue ]! !

!RubTextScrollPane methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self scroller extent: self textArea extent.
	self wrapped ifTrue: [ self fitScrollTarget  ].
	drawFocusBorder := true! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
scrollBy: delta
	self
		handleScrollerOffsetChange: [ 
			| newYoffset newXoffset |
			"Move the contents in the direction delta."
			newYoffset := scroller offset y - delta y max: 0.
			newXoffset := scroller offset x - delta x max: 0.	"Set the offset on the scroller"
			scroller offset: newXoffset @ newYoffset.
			self updateScrollbars ]! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
scrollSelectionIntoView: event
	"Scroll my text into view if necessary and return true, else return false"

	| selRects delta selRect rectToTest transform cpHere editor bnds |
	editor := self textArea editor.
	selRects := self textArea selectionRects.
	selRects isEmpty
		ifTrue: [ ^ false ].
	rectToTest := selRects first merge: selRects last.
	transform := scroller transformFrom: self.
	(event notNil and: [ event isMouse and: [ event anyButtonPressed ] ])
		ifTrue: [ 
			"Check for autoscroll"
			cpHere := transform localPointToGlobal: event cursorPoint.
			(cpHere y <= self top or: [ cpHere x <= self left ])
				ifTrue: [ rectToTest := selRects first topLeft extent: 2 @ 2 ]
				ifFalse: [ 
					(cpHere y >= self bottom or: [ cpHere x >= self right  ] )
						ifTrue: [ rectToTest := selRects last bottomRight extent: 2 @ 2 ]
						ifFalse: [ ^ false ] ] ].
	selRect := transform localBoundsToGlobal: rectToTest.
	bnds := self scrollBounds insetBy: self textArea margins.
	selRect height > bounds height
		ifTrue: [ 
			editor pointIndex - editor markIndex < 0
				ifTrue: [ self scrollBy: 0 @ (bnds top - selRect top) ]
				ifFalse: [ self scrollBy: 0 @ (bnds bottom - selRect bottom) ].
			^ true ].
	(delta := selRect amountToTranslateWithin: bnds) ~= (0 @ 0)
		ifTrue: [ 
			delta x > 0
				ifTrue: [ 
					scroller offset x - delta x < self scrollBounds width
						ifTrue: [ delta := scroller offset x @ delta y ] ].
			self scrollBy: delta truncated.
			^ true ].
	^ false! !

!RubTextScrollPane methodsFor: 'event handling' stamp: ''!
selectionChanged
	self owner ifNotNil: [ :o | o selectionChanged ]! !

!RubTextScrollPane methodsFor: 'accessing' stamp: ''!
drawFocusBorder: aBoolean
	drawFocusBorder := aBoolean.
	self changed! !

!RubTextScrollPane methodsFor: 'private' stamp: ''!
unplug
	self hasTextArea
		ifTrue: [ self textArea unplug ].
	super unplug! !

!RubTextScrollPane methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Adopt the given pane color."
	
	super adoptPaneColor: paneColor.
	self hScrollbar adoptPaneColor: paneColor darker.
	self vScrollbar adoptPaneColor: paneColor darker! !

!RubTextScrollPane methodsFor: 'accessing' stamp: ''!
textArea
	^ self scrollTarget! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
scrollWhenMouseMove: anEvent pivotPoint: aPivot
	| worldTransform viewBounds gap |
	worldTransform := self transformFrom: self world.
	(self scrollSelectionIntoView: anEvent)
		ifTrue: [ ^ self ].
	self textArea selectionRects
		ifNotEmpty: [ :selRects |
			viewBounds := worldTransform localBoundsToGlobal: self bounds.
			(viewBounds containsPoint: anEvent hand position)
				ifFalse: [ 
					gap := selRects last height.
					aPivot y < anEvent hand position y
						ifTrue: [ 
							gap := gap + (anEvent hand position y - viewBounds bottom).
							anEvent setPosition: anEvent position + (0 @ gap) ]
						ifFalse: [ 
							gap := gap + (viewBounds top - anEvent hand position y).
							anEvent setPosition: anEvent position - (0 @ gap) ].
					self textArea mouseMove: anEvent ] ]! !

!RubTextScrollPane methodsFor: 'structure' stamp: ''!
topRendererOrSelf
	^ owner ifNil: [ super topRendererOrSelf ]! !

!RubTextScrollPane methodsFor: 'initialization' stamp: ''!
unregisterTextArea
	self hasTextArea
		ifTrue: [ 
			self textArea scrollPane: nil.
			self textArea announcer unsubscribe: self.
			self textArea unplug ]! !

!RubTextScrollPane methodsFor: 'geometry' stamp: ''!
currentVScrollBarThickness
	^ self vScrollbarNeeded
		ifTrue: [ self scrollBarThickness ]
		ifFalse: [ 0 ]! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
hideOrShowScrollBar 
	self updateScrollbars! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
fitScrollTarget
	"if the scroller extent is different that the textArea 
	extent, then, if the textArea is wrapped, then resize 
	the textArea width accordingly
	If the textArea is not wrapped, then do nothing
	"
	
	self wrapped
		ifFalse: [ ^ self ].
	self fitScrollTargetWidth ! !

!RubTextScrollPane methodsFor: 'geometry' stamp: ''!
currentHScrollBarThickness
	^ self hScrollbarNeeded
		ifTrue: [ self scrollBarThickness ]
		ifFalse: [ 0 ]! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
scrollByKeyboard: event
	"If event is ctrl+up/down then scroll and answer true"

	| ret sb |
	(event controlKeyPressed or: [ event commandKeyPressed ])
		ifFalse: [ ^ false ].
	sb := event commandKeyPressed
		ifTrue: [ self hScrollbar ]
		ifFalse: [ self vScrollbar ].
	self
		handleScrollerOffsetChange: [ 
			ret := false.
			event key = KeyboardKey up
				ifTrue: [ 
					sb scrollUp: 3.
					ret := true ].
			event key = KeyboardKey down
				ifTrue: [ 
					sb scrollDown: 3.
					ret := true ] ].
	^ ret! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
hScrollbarValue: scrollValue
	self announcer announce: (RubHorizontalScrolled scrollValue: scrollValue).
	self handleScrollerOffsetChange: [ super hScrollbarValue: scrollValue ]! !

!RubTextScrollPane methodsFor: 'initialization' stamp: ''!
defaultScrollTarget
	^ RubEditingArea new! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
scrollSelectionIntoView
	"Scroll my text into view if necessary and return true, else return false"
	self scrollSelectionIntoView: nil.
! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
scrollToEndOfLine
	self hScrollbarValue: 1;
	updateScrollbars! !

!RubTextScrollPane methodsFor: 'accessing' stamp: ''!
drawFocusBorder
	^ drawFocusBorder ifNil: [ drawFocusBorder := true ]! !

!RubTextScrollPane methodsFor: 'event handling' stamp: ''!
textAreaExtentChanged
	self fitScrollTarget.
	self owner ifNotNil: [ :o | o textAreaExtentChanged ]
! !

!RubTextScrollPane methodsFor: 'drawing' stamp: ''!
drawSubmorphsOnAthensCanvas: anAthensCanvas
	"Draw the focus here since we are using inset bounds
	for the focus rectangle."

	super drawSubmorphsOnAthensCanvas: anAthensCanvas.
	self textArea readOnly ifTrue: [ ^self ].
	self drawFocusBorder ifFalse: [ ^self ].
	(self hasKeyboardFocus or: [ self textArea hasFindReplaceFocus ]) 
		ifTrue: [self drawKeyboardFocusOnAthensCanvas: anAthensCanvas].
! !

!RubTextScrollPane methodsFor: 'private' stamp: ''!
offset
	^ scroller offset! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
scrollToBeginningOfText
	self vScrollbarValue: 0;
	updateScrollbars! !

!RubTextScrollPane methodsFor: 'geometry' stamp: ''!
extent: newExtent
	"Update the receiver's extent. Hide/show the scrollbars and resize the scroller
	as necessary."

	"we need to compare against 1 pixel, otherwise may end up in an infinite loop.
	If newExtent, current extent and current position represent a float number
	inner scrollpane rounding gives difference around 0.5 pixel disallowing us
	to use Point>>#closeTo:. It is quite dirty fix, general one would require enormous
	amount of work to improve how morphic works with floats. This issue successfully
	addressed in Bloc"
	(bounds extent - newExtent) abs < (1@1)
		ifTrue: [ ^ self ].
	super extent: newExtent.
	self owner ifNotNil: [ :o | o scrollerExtentChanged ].
	self wrapped
		ifTrue: [ self updateScrollbars ]! !

!RubTextScrollPane methodsFor: 'event handling' stamp: ''!
mouseMove: anEvent 

	scroller hasSubmorphs 
		ifTrue: [ self textArea mouseMove: (anEvent transformedBy: (scroller transformFrom: self)) ].
	self eventHandler
		ifNotNil: [ self eventHandler mouseMove: anEvent fromMorph: self ]! !

!RubTextScrollPane methodsFor: 'accessing' stamp: ''!
scrollTarget: aTextArea
	self unregisterTextArea.
	super scrollTarget: aTextArea.
	self registerTextArea ! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
hScrollbarValueWithoutAnnouncement: scrollValue
	self handleScrollerOffsetChange: [ super hScrollbarValue: scrollValue ]! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
wrapped
	^ self textArea wrapped! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
scrollToBeginningOfLine
	self hScrollbarValue: 0;
	updateScrollbars! !

!RubTextScrollPane methodsFor: 'dropping/grabbing' stamp: ''!
aboutToBeGrabbedBy: aHand
	^ nil! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
setTextWith: stringOrText
	"Set the initial text contents with line breaks only as in the text.
	Fit my width and height to the result."
	self textArea width: self scroller width.
	self textArea setTextWith: stringOrText.
	self updateScrollbars 
! !

!RubTextScrollPane methodsFor: 'event handling' stamp: ''!
textChanged

	self owner ifNotNil: [ :o | o textChanged ]! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
hScrollbarNeeded
	"Return whether the horizontal scrollbar is needed."
	self wrapped ifTrue: [  ^ false ].
	^ super hScrollbarNeeded! !

!RubTextScrollPane methodsFor: 'event handling' stamp: ''!
mouseDown: anEvent 
	scroller hasSubmorphs 
		ifTrue: [ self textArea mouseDown: (anEvent transformedBy: (scroller transformFrom: self)) ].
	self eventHandler
		ifNotNil: [ self eventHandler mouseDown: anEvent fromMorph: self ]! !

!RubTextScrollPane methodsFor: 'accessing' stamp: ''!
newHScrollbar
	"Answer a new horizontal scrollbar."

	^RubScrollBar new
		model: self;
		setValueSelector: #hScrollbarValue:! !

!RubTextScrollPane methodsFor: 'accessing' stamp: ''!
newVScrollbar
	"Answer a new vertical scrollbar."

	^RubScrollBar new
		model: self;
		setValueSelector: #vScrollbarValue:! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
beNotWrapped
	self handleWrappingPolicyChange: [ self textArea beNotWrapped ]! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
appendText: stringOrText
	"Accept new text contents with line breaks only as in the text.
	Fit my width and height to the result."
	self textArea appendText: stringOrText.
	self scrollSelectionIntoView.
! !

!RubTextScrollPane methodsFor: 'text area protocol' stamp: ''!
updateTextWith: stringOrText
	"Accept new text contents with line breaks only as in the text.
	Fit my width and height to the result."
	self textArea width: self scroller width.
	self textArea updateTextWith: stringOrText.
	self updateScrollbars 
! !

!RubTextScrollPane methodsFor: 'scrollbar managing' stamp: ''!
updateScrollbars
	super updateScrollbars.
	self wrapped
		ifTrue: [ self fitScrollTargetWidth ]! !

!RubTextSegmentIconBox methodsFor: 'accessing' stamp: ''!
verticalSeparatorBounds
	| bnds  |
	bnds := self bounds.
	^ self side = #left
		ifTrue: [ (bnds topRight -  (self verticalSeparatorWidth @ 0)) corner: bnds bottomRight ]
		ifFalse: [ (bnds topLeft corner: bnds bottomLeft + (self verticalSeparatorWidth @ 0)) ]! !

!RubTextSegmentIconBox methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ Color orange veryMuchLighter! !

!RubTextSegmentIconBox methodsFor: 'event handling' stamp: ''!
mouseEnter: anEvent
	self color: (Color lightGray alpha: 0.04).
! !

!RubTextSegmentIconBox methodsFor: 'event handling' stamp: ''!
handlesMouseMove: evt
	^ true! !

!RubTextSegmentIconBox methodsFor: 'accessing' stamp: ''!
verticalSeparatorColor
	^ (self textArea backgroundColor contrastingBlackAndWhiteColor ) alpha: 0.3! !

!RubTextSegmentIconBox methodsFor: 'accessing' stamp: ''!
textColor
	^ self textArea lineNumbersTextColor 
! !

!RubTextSegmentIconBox methodsFor: 'event handling' stamp: ''!
mouseEnter: anEvent in: aSegment
	previouslyIn = aSegment
		ifTrue: [ ^ self ].
	previouslyIn := aSegment.
	aSegment showMouseHasEntered ! !

!RubTextSegmentIconBox methodsFor: 'event handling' stamp: ''!
mouseLeave: anEvent
	self color: self defaultBackgroundColor.
	previouslyIn
		ifNotNil: [ 
			previouslyIn showMouseHasLeaved.
			previouslyIn := nil ]! !

!RubTextSegmentIconBox methodsFor: 'accessing' stamp: ''!
verticalSeparatorWidth
	^ 1! !

!RubTextSegmentIconBox class methodsFor: 'querying' stamp: ''!
key
	^ #textSegmentIcons! !

!RubTextSegmentIconDisplayer methodsFor: 'geometry' stamp: ''!
computedWidthFrom: aRectangle
	^  (self horizontalGapBefore + self itemWidth + self horizontalGapAfter + self verticalSeparatorWidth) truncated ! !

!RubTextSegmentIconDisplayer methodsFor: 'accessing' stamp: ''!
verticalSeparatorWidth
	^ 1! !

!RubTextSegmentIconDisplayer methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	| visibleRectangle |
	super drawOn: aCanvas.
	self paragraph selectionStart ifNil: [ ^ self ].
	self paragraph selectionStop ifNil: [ ^ self ].
	self paragraph lines ifNil: [ ^ self ].
	aCanvas
		clipBy: self bounds
		during: [ :clippedCanvas | 
			| tl br |
			clippedCanvas fillRectangle: self verticalSeparatorBounds color: self verticalSeparatorColor.
			visibleRectangle := clippedCanvas clipRect.
			tl := self lineIndexForPoint: visibleRectangle topLeft.
			br := self lineIndexForPoint: visibleRectangle bottomRight.
			tl to: br do: [ :i | 
				((self paragraphProvider segmentsAtLine: i) select: [ :s | s icon notNil ])
					ifNotEmpty: [ :segments | 
						| s pos |
						s := segments first.
						s displayIconAt: (pos := self iconPositionOfSegment: s) on: aCanvas.
						segments size > 1
							ifTrue: [ 
								| r ygap |
								ygap := s icon height + 1.
								r := pos + (0 @ ygap) corner: (pos x + 12) @ (pos y + ygap + 2).
								aCanvas fillRectangle: (r expandBy: 2) color: (Color white alpha: 0.4).
								aCanvas
									frameRectangle: r
									width: 2
									colors: {(Color white). (Color black)}
									dashes: {1. 1} ] ] ] ]! !

!RubTextSegmentIconDisplayer methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ self paragraphProvider lineNumbersBackgroundColor ! !

!RubTextSegmentIconDisplayer methodsFor: 'accessing' stamp: ''!
fontToUse
	^ RubAbstractTextArea lineNumbersFont ! !

!RubTextSegmentIconDisplayer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self clipSubmorphs: false! !

!RubTextSegmentIconDisplayer methodsFor: 'accessing' stamp: ''!
itemWidth 
	^ 16! !

!RubTextSegmentIconDisplayer methodsFor: 'event handling' stamp: ''!
handlesMouseMove: evt
	^ true! !

!RubTextSegmentIconDisplayer methodsFor: 'event handling' stamp: ''!
mouseEnter: anEvent
	super mouseEnter: anEvent! !

!RubTextSegmentIconDisplayer methodsFor: 'accessing' stamp: ''!
verticalSeparatorColor
	^ (self textArea backgroundColor contrastingBlackAndWhiteColor ) alpha: 0.3! !

!RubTextSegmentIconDisplayer methodsFor: 'geometry' stamp: ''!
horizontalGapBefore
	^ 1! !

!RubTextSegmentIconDisplayer methodsFor: 'accessing' stamp: ''!
level
	^ 1! !

!RubTextSegmentIconDisplayer methodsFor: 'event handling' stamp: ''!
handleMouseOver: anEvent
	| lineIndex |
	super handleMouseOver: anEvent.
	lineIndex := self lineIndexForPoint: anEvent position.
	self mouseEnter: anEvent in: ( (self paragraphProvider segmentsAtLine: lineIndex) select: [ :s | s icon notNil ] ).
	previouslyIn ifNotNil: [
		previouslyIn showMouseHasLeaved.
		previouslyIn := nil ].

	
! !

!RubTextSegmentIconDisplayer methodsFor: 'accessing' stamp: ''!
textColor
	^ self textArea lineNumbersTextColor 
! !

!RubTextSegmentIconDisplayer methodsFor: 'drawing' stamp: ''!
iconPositionOfSegment: aSegment
	^ (self left + self horizontalGapBefore) @ aSegment position y
		translateBy: 0 negated @ (self offset y negated + self bounds top)! !

!RubTextSegmentIconDisplayer methodsFor: 'event handling' stamp: ''!
mouseEnter: anEvent in: aSegmentList
	aSegmentList ifEmpty: [ ^self ].
	previouslyIn = aSegmentList first
		ifTrue: [ ^ self ].
	previouslyIn := aSegmentList first.
	self invokeIconMenuOfSegments: aSegmentList event: anEvent.
! !

!RubTextSegmentIconDisplayer methodsFor: 'event handling' stamp: ''!
mouseLeave: anEvent
	previouslyIn
		ifNotNil: [ 
			previouslyIn showMouseHasLeaved.
			previouslyIn := nil ]! !

!RubTextSegmentIconDisplayer methodsFor: 'event handling' stamp: ''!
invokeIconMenuOfSegments: aSegmentList event: anEvent
	| menu |
	aSegmentList ifEmpty: [ ^ self ].
	menu := RubSegmentIconMenuMorph new
		defaultTarget: self;
		yourself.
	aSegmentList
		do: [ :seg | seg addItemToMenu: menu ].
	menu hasItems
		ifFalse: [ ^ self ].
	menu borderWidth: 0.
	menu
		on: #mouseLeave
		send: #value
		to: [ 
			menu delete.
			self changed ].
	menu invokeAt: (self iconPositionOfSegment: aSegmentList first) - (1 @ 4 negated) in: self! !

!RubTextSegmentIconDisplayer methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt

	^ true! !

!RubTextSegmentIconDisplayer methodsFor: 'structure' stamp: ''!
topRendererOrSelf
	^self ! !

!RubTextSegmentIconDisplayer methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^ true! !

!RubTextSegmentIconDisplayer methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	| visibleRectangle |
	super drawOnAthensCanvas: anAthensCanvas.
	self paragraph selectionStart ifNil: [ ^ self ].
	self paragraph selectionStop ifNil: [ ^ self ].
	self paragraph lines ifNil: [ ^ self ].
	anAthensCanvas
		clipBy: self bounds
		during: [ 
			| tl br |
			anAthensCanvas setShape: self verticalSeparatorBounds.
			anAthensCanvas setPaint: self verticalSeparatorColor.
			anAthensCanvas draw.
			visibleRectangle := anAthensCanvas clipRect.
			tl := self lineIndexForPoint: visibleRectangle topLeft.
			br := self lineIndexForPoint: visibleRectangle bottomRight.
			tl to: br do: [ :i | 
				((self paragraphProvider segmentsAtLine: i) select: [ :s | s icon notNil ])
					ifNotEmpty: [ :segments | 
						| s pos |
						s := segments first.
						pos := self iconPositionOfSegment: s.
						s displayIconAt: pos onAthensCanvas: anAthensCanvas.
						segments size > 1
							ifTrue: [ 
								| r ygap path |
								ygap := s icon height + 1.
								r := pos + (0 @ ygap) corner: (pos x + 12) @ (pos y + ygap + 2).
								anAthensCanvas setShape: (r expandBy: 2).
								anAthensCanvas setPaint: (Color white alpha: 0.4).
								anAthensCanvas draw.
								path := anAthensCanvas
									createPath: [ :builder | 
										builder absolute.
										builder moveTo: r topLeft + (2@0).
										builder lineTo: r topRight + (2@0)].
								(anAthensCanvas setStrokePaint: Color black)
									width: 1;
									dashes: {2.4} offset: 0.
								anAthensCanvas drawShape: path ] ] ] ]! !

!RubTextSegmentIconDisplayer methodsFor: 'geometry' stamp: ''!
horizontalGapAfter
	^ 1! !

!RubTextSegmentIconDisplayer methodsFor: 'accessing' stamp: ''!
verticalSeparatorBounds
	| bnds  |
	bnds := self bounds.
	^ self side = #left
		ifTrue: [ (bnds topRight -  (self verticalSeparatorWidth @ 0)) corner: bnds bottomRight ]
		ifFalse: [ (bnds topLeft corner: bnds bottomLeft + (self verticalSeparatorWidth @ 0)) ]! !

!RubTextSegmentIconDisplayer class methodsFor: 'querying' stamp: ''!
key
	^ #textSegmentIcons! !

!RubTextSegmentMorph methodsFor: 'ui' stamp: ''!
addItemToMenu: aMenu

|item|
	item := RubSegmentIconMenuItemMorph new
		contents: self label;
		target: self iconBlock;
		selector: #cull:;
		arguments: {self};
		icon: self icon;
		segment: self.
		
		^ aMenu addMenuItem: item! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
beExtendable
	self changeable: false! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
replaceTextWith: aText
	self textArea replaceFrom: self firstIndex  to: self lastIndex with: aText asText! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
interval
	^ self firstIndex to: self lastIndex! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
firstIndex: anInteger
	firstIndex := anInteger.
	self computeVertices ! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
lastLineIndex
	^ self lineIndexOfCharacterIndex: lastIndex! !

!RubTextSegmentMorph methodsFor: 'event handling' stamp: ''!
registerTextArea 
	textArea announcer  
	when: RubExtentChanged send: #whenExtentChanged: to: self;
	when: RubTextChanged send: #whenTextChanged: to: self! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
mouseDownOnIcon: anEvent
	^ self iconBlock value: anEvent! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
changeable: aBoolean
	changeable := aBoolean! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
lastIndex
	^ lastIndex ! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
beChangeable
	self changeable: true! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
iconBlock
	^ iconBlock ifNil: [ iconBlock := [ :seg :evt | ] ]! !

!RubTextSegmentMorph methodsFor: 'drawing' stamp: ''!
computeVertices
	self isCurve
		ifTrue: [ self computeSmoothVertices ]
		ifFalse: [ self computeStraightVertices ]! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
icon: aForm
	icon := aForm! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
label
	^ label value ifNil: [ label := '']! !

!RubTextSegmentMorph methodsFor: 'ui' stamp: ''!
readWriteView
	^ self readOnlyView on: self! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
lastIndex: anInteger
	lastIndex := anInteger.
	self computeVertices ! !

!RubTextSegmentMorph methodsFor: 'submorphs - add/remove' stamp: ''!
delete
	textArea ifNotNil: [ :ta | ta removeSegment: self ].
	textArea := nil.
	super delete! !

!RubTextSegmentMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self borderWidth: 0.
	self beStraightSegments.
	self clipSubmorphs: false
! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
label: aStringOrBlock
	label := aStringOrBlock! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
iconBlock: aBlock
	iconBlock := aBlock! !

!RubTextSegmentMorph methodsFor: 'event handling' stamp: ''!
mouseEnter: anEvent
	self showMouseHasEntered.
	super mouseEnter: anEvent! !

!RubTextSegmentMorph methodsFor: 'event handling' stamp: ''!
whenExtentChanged: anAnnouncement 
	self computeVertices.
! !

!RubTextSegmentMorph methodsFor: 'drawing' stamp: ''!
displayIconAt: aPosition on: aCanvas
	self icon ifNil: [ ^self ].
	aCanvas translucentImage: self icon at: aPosition! !

!RubTextSegmentMorph methodsFor: 'event handling' stamp: ''!
showMouseHasLeaved
	self borderWidth: 0.
! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
firstLineIndex
	^  self lineIndexOfCharacterIndex: firstIndex! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
inTextArea: aTextArea 
	textArea := aTextArea.
	self computeVertices! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
margins
	^ self textArea margins! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
from: aFirstCharIndex to: aLastCharIndex
	lastIndex := aFirstCharIndex max: aLastCharIndex.
	firstIndex := aFirstCharIndex min: aLastCharIndex! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
textArea
	^ textArea! !

!RubTextSegmentMorph methodsFor: 'structure' stamp: ''!
topRendererOrSelf
	^owner
		ifNotNil: [ owner topRendererOrSelf ]! !

!RubTextSegmentMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^ Color red! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
lines
	^ self textArea paragraph lines! !

!RubTextSegmentMorph methodsFor: 'event handling' stamp: ''!
whenTextChanged: anAnnouncement 
	| beg end delta |
	textArea ifNil: [ ^self ].
	beg := anAnnouncement start.
	end := anAnnouncement stop.
	delta := anAnnouncement text size - (end - beg + 1).
	self textChangedFrom: beg to: end delta: delta.
	textArea ifNil: [ ^self ].
	self computeVertices.
	self changed
! !

!RubTextSegmentMorph methodsFor: 'private' stamp: ''!
computeStraightVertices
	| firstCB lastCB firstLineIndex lastLineIndex firstLine lastLine verts secondLine thirdLine |
	firstCB := self characterBlockForIndex: firstIndex.
	lastCB := self characterBlockForIndex: lastIndex.
	firstLineIndex := self lineIndexOfCharacterIndex: firstIndex.
	lastLineIndex := self lineIndexOfCharacterIndex: lastIndex.
	firstLine := self lines at: firstLineIndex.
	lastLine := self lines at: lastLineIndex.
	verts := OrderedCollection new.
	firstLine = lastLine
		ifTrue: [ 
			verts add: firstCB bottomLeft.
			verts add: firstCB topLeft.
			firstIndex ~= lastIndex
				ifTrue: [ 
					verts add: lastCB topLeft.
					verts add: lastCB bottomLeft.
					verts add: firstCB bottomLeft ] ]
		ifFalse: [ 
			secondLine := self lines at: firstLineIndex + 1.
			thirdLine := self lines at: lastLineIndex - 1.
			verts add: firstCB bottomLeft - (1 @ 0).
			verts add: firstCB topLeft - (1 @ 0).
			verts add: (self textArea right - self margins right) @ firstLine top.
			verts add: (self textArea right - self margins right) @ thirdLine bottom.
			verts add: lastCB topLeft.
			verts add: lastCB bottomLeft.
			verts add: lastLine bottomLeft - (1 @ 0).
			verts add: secondLine topLeft - (1 @ 0).
			verts add: firstCB bottomLeft - (1 @ 0) ].
	self setVertices: verts! !

!RubTextSegmentMorph methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph
	super noteNewOwner: aMorph.
	self registerTextArea! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
setText: aText from: aView
	self replaceTextWith: aText.
	self announcer announce: RubTextUpdatedInModel.
	^ true! !

!RubTextSegmentMorph methodsFor: 'private' stamp: ''!
privateMoveBy: aPoint
	super privateMoveBy: aPoint.
	self computeVertices! !

!RubTextSegmentMorph methodsFor: 'ui' stamp: ''!
readOnlyView
	^ RubScrolledTextMorph new
		setTextWith: self getText;
		wrapped: self textArea wrapped;
		width: 200;
		yourself! !

!RubTextSegmentMorph methodsFor: 'drawing' stamp: ''!
displayIconAt: aPosition onAthensCanvas: aCanvas
	self icon ifNil: [ ^self ].
	aCanvas pathTransform
		restoreAfter: [ 
			aCanvas paintOptions composeOver.
			aCanvas setPaint: self icon.
			aCanvas pathTransform translateBy: aPosition.
			aCanvas drawShape: self icon boundingBox]! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
lineIndexOfCharacterIndex: anIndex
	^ self textArea paragraph lineIndexOfCharacterIndex: anIndex! !

!RubTextSegmentMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: anEvent
	self showMouseHasLeaved.
	super mouseLeave: anEvent! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
icon
	^ icon ! !

!RubTextSegmentMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt
	^ true! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
changeable
	^ changeable ifNil: [ changeable := true ]! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
getText 
	^ self textArea text copyFrom: self firstIndex to: self lastIndex - 1! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
characterBlockForIndex: anIndex
	^ self textArea paragraph characterBlockForIndex: anIndex! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
inTextArea: aTextArea from: aFirstCharIndex to: aLastCharIndex
	self from: aFirstCharIndex to: aLastCharIndex.
	self inTextArea:  aTextArea
! !

!RubTextSegmentMorph methodsFor: 'accessing' stamp: ''!
firstIndex
	^ firstIndex ! !

!RubTextSegmentMorph methodsFor: 'event handling' stamp: ''!
textChangedFrom: begin to: end delta: delta
	| changeInterval |
	self flag: 'Dirty code, that does not work well, to be reviewed'.
	((self interval rangeIncludes: begin) or: [ self interval rangeIncludes: end ]) ifTrue: [ self changeable ifTrue: [ ^ self delete ] ].
	changeInterval := begin to: end.
	((self interval rangeIncludes: end) and: [ delta > 0 ])
		ifTrue: [ self lastIndex: self lastIndex + delta.
			^ self computeVertices ].
	((changeInterval rangeIncludes: begin) and: [ (changeInterval rangeIncludes: end) not ])
		ifTrue: [ self firstIndex: self firstIndex - (self firstIndex - end).
			^ self computeVertices ].
	((changeInterval rangeIncludes: self firstIndex) and: [ changeInterval rangeIncludes: self lastIndex ]) ifTrue: [ ^ self delete ].
	self textArea text size < self firstIndex ifTrue: [ ^ self delete ].
	self textArea text size < self lastIndex
		ifTrue: [ ^ self changeable
				ifTrue: [ self delete ]
				ifFalse: [ self lastIndex: self textArea text size.
					self computeVertices ] ].
	end < self firstIndex
		ifTrue: [ firstIndex := self firstIndex + delta.
			lastIndex := self lastIndex + delta.
			^ self computeVertices ]! !

!RubTextSegmentMorph methodsFor: 'initialization' stamp: ''!
beSmoothCurve
	super beSmoothCurve.
	self textArea ifNotNil: [ self computeVertices ].
! !

!RubTextSegmentMorph methodsFor: 'private' stamp: ''!
computeSmoothVertices
	| firstCB lastCB firstLineIndex lastLineIndex firstLine lastLine verts |
	firstLineIndex := self lineIndexOfCharacterIndex: firstIndex.
	lastLineIndex := self lineIndexOfCharacterIndex: lastIndex.
	firstLine := self lines at: firstLineIndex.
	lastLine := self lines at: lastLineIndex.
	verts := OrderedCollection new.
	firstLine = lastLine
		ifTrue: [ 
			firstCB := self textArea paragraph firstNonBlankCharacterBlockInLine: firstLine.
			verts add: firstCB bottomLeft.
			verts add: firstCB topLeft.
			firstIndex ~= lastIndex
				ifTrue: [ 
					lastCB := self textArea paragraph lastNonBlankCharacterBlockInLine: firstLine.
					verts add: lastCB topLeft.
					verts add: lastCB bottomLeft.
					verts add: firstCB bottomLeft ] ]
		ifFalse: [ 
			| currLine currIdx cb |
			currIdx := firstLineIndex.
			currLine := firstLine.
			[ 
			cb := self textArea paragraph lastNonBlankCharacterBlockInLine: currLine.
			verts add: cb topRight.
			verts add: cb bottomRight.
			currIdx := currIdx + 1.
			currLine := self lines at: currIdx ] doWhileTrue: [ currLine ~~ lastLine ].
			cb := self textArea paragraph lastNonBlankCharacterBlockInLine: currLine.
			verts add: cb topRight.
			verts add: cb bottomRight.
			[ 
			cb := self textArea paragraph firstNonBlankCharacterBlockInLine: currLine.
			verts add: cb bottomLeft - (1 @ 0).
			verts add: cb topLeft - (1 @ 0).
			currIdx := currIdx - 1.
			currLine := self lines at: currIdx ] doWhileTrue: [ currLine ~~ firstLine ].
			cb := self textArea paragraph firstNonBlankCharacterBlockInLine: currLine.
			verts add: cb bottomLeft - (1 @ 0).
			verts add: cb topLeft - (1 @ 0) ].
	self setVertices: verts! !

!RubTextSegmentMorph methodsFor: 'event handling' stamp: ''!
showMouseHasEntered
	self borderWidth: 1.
! !

!RubTextSegmentMorph class methodsFor: 'instance creation' stamp: ''!
inTextArea: aTextArea from: aFirstCharIndex to: aLastCharIndex
	^ self new inTextArea: aTextArea from: aFirstCharIndex to: aLastCharIndex! !

!RubTextSegmentMorph class methodsFor: 'instance creation' stamp: ''!
from: aFirstCharIndex to: aLastCharIndex
	^ self new from: aFirstCharIndex to: aLastCharIndex! !

!RubTextSelectionColor methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ self backgroundColorBlock ifNotNil: [:bcb | bcb value]! !

!RubTextSelectionColor methodsFor: 'accessing' stamp: ''!
colorBlock

	^ colorBlock ifNil: [colorBlock := [self theme currentSettings selectionTextColor]]! !

!RubTextSelectionColor methodsFor: 'accessing' stamp: ''!
emphasisCode: anInteger
	emphasisCode := anInteger! !

!RubTextSelectionColor methodsFor: 'accessing' stamp: ''!
backgroundColorBlock

	^ backgroundColorBlock ! !

!RubTextSelectionColor methodsFor: 'accessing' stamp: ''!
colorBlock: aBlock
	"aBlock value gives the text color"
	colorBlock := aBlock! !

!RubTextSelectionColor methodsFor: 'accessing' stamp: ''!
backgroundColorBlock: aBlock

	 backgroundColorBlock := aBlock ! !

!RubTextSelectionColor methodsFor: 'accessing' stamp: ''!
textColor
	^ self colorBlock value! !

!RubTextSelectionColor methodsFor: 'accessing' stamp: ''!
theme
	^ UITheme current ! !

!RubTextSelectionColor methodsFor: 'styling' stamp: ''!
emphasizeScanner: scanner
	"Set the emphasis for text display"
	"self backgroundColor ifNotNil: [ :bc | scanner backgroundColor: bc ]."
	self textColor ifNotNil: [:c | scanner textColor: c].
	emphasisCode ifNotNil: [ scanner addEmphasis: emphasisCode ]! !

!RubTextSelectionColor methodsFor: 'accessing' stamp: ''!
dominates: other
	"There can be only one..."
	^self class == other class! !

!RubTextSelectionColor methodsFor: 'accessing' stamp: ''!
emphasisCode
	^ emphasisCode ifNil: [ 0 ]! !

!RubTextSelectionColor class methodsFor: 'default accessing' stamp: ''!
findReplaceSelection
	^ FindReplaceSelection
		ifNil: [ 
			FindReplaceSelection := self new
				colorBlock: [ 
							self theme currentSettings haveFindReplaceSelectionTextColor
								ifTrue: [ self theme currentSettings findReplaceSelectionTextColor ]
								ifFalse: [  ] ];
				backgroundColorBlock: [ self theme currentSettings findReplaceSelectionColor ];
				yourself ]! !

!RubTextSelectionColor class methodsFor: 'default accessing' stamp: ''!
theme
	^ UITheme current ! !

!RubTextSelectionColor class methodsFor: 'default accessing' stamp: ''!
secondarySelection
	^ SecondarySelection
		ifNil: [ 
			SecondarySelection := self new
				colorBlock: [ 
							self theme currentSettings haveSecondarySelectionTextColor
								ifTrue: [ self theme currentSettings secondarySelectionTextColor ]
								ifFalse: [  ] ];
				backgroundColorBlock: [ self theme secondarySelectionColor ];
				yourself ]! !

!RubTextSelectionColor class methodsFor: 'default accessing' stamp: ''!
oppositeDelimiterSelection
	^ OppositeDelimiterSelection
		ifNil: [ 
			OppositeDelimiterSelection := self new
				colorBlock: [ self theme currentSettings selectionTextColor ];
				backgroundColorBlock: [ self theme secondarySelectionColor ];
				yourself ]! !

!RubTextSelectionColor class methodsFor: 'cleanup' stamp: ''!
cleanUp

	FindReplaceSelection := nil.
	OppositeDelimiterSelection := nil.
	PrimarySelection := nil.
	SecondarySelection := nil! !

!RubTextSelectionColor class methodsFor: 'default accessing' stamp: ''!
primarySelection
	^ PrimarySelection
		ifNil: [ 
			PrimarySelection := self new
				colorBlock: [ self theme currentSettings selectionTextColor ];
				backgroundColorBlock: [ self theme currentSettings selectionColor ];
				yourself ]! !

!RubTextSetInModel commentStamp: ''!
I am raised when text is set in the model!
!RubTextStopConditions commentStamp: ''!
I represent the conditions to stop the scan!
!RubTextStopConditions methodsFor: 'accessing' stamp: ''!
crossedX: aSymbolOrNil
	crossedX := aSymbolOrNil.
	
	"Backward compatibility with historical EndOfRun TextConstant handling"
	stops size >= 258 ifTrue: [stops at: 258 put: crossedX]! !

!RubTextStopConditions methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the default stop conditions."
	stops := Array new: 258.
	self endOfRun: #endOfRun.
	self crossedX: #crossedX.! !

!RubTextStopConditions methodsFor: 'accessing' stamp: ''!
at: anInteger put: aSymbolOrNil
	"Set the special action associated with a character of code anInteger, or nil if none.
	The character code should be betxween 1 and 256 (presumably codePoint + 1).
	It can eventually be 257 for endOfRun action, or 258 for crossedX action for backward compatibility with historical  versions."
	
	anInteger = 257
		ifTrue: [
			self endOfRun: aSymbolOrNil.
			^aSymbolOrNil].
	anInteger = 258
		ifTrue: [
			self crossedX: aSymbolOrNil.
			^aSymbolOrNil].
	^stops at: anInteger put: aSymbolOrNil! !

!RubTextStopConditions methodsFor: 'copying' stamp: ''!
postCopy
	stops := stops copy! !

!RubTextStopConditions methodsFor: 'accessing' stamp: ''!
endOfRun
	"Answer the special action to be performed et end of text."
	
	^endOfRun! !

!RubTextStopConditions methodsFor: 'accessing' stamp: ''!
endOfRun: aSymbolOrNil
	endOfRun := aSymbolOrNil.
	
	"Backward compatibility with historical EndOfRun TextConstant handling"
	stops size >= 257 ifTrue: [stops at: 257 put: endOfRun]! !

!RubTextStopConditions methodsFor: 'accessing' stamp: ''!
size
	"Return the highest code to which an action can be mapped.
	Do not take into account the two slots for endOfRun and crossedX, since they don't map any character code.
	Warning: this message is used for compatibility with obsolete code."
	
	^256! !

!RubTextStopConditions methodsFor: 'accessing' stamp: ''!
at: anInteger
	"Answer the special action associated with a character of code anInteger, or nil if none.
	The character code should be betxween 1 and 256 (presumably codePoint + 1).
	It can eventually be 257 for endOfRun action, or 258 for crossedX action for backward compatibility with historical  versions."
	
	^stops at: anInteger! !

!RubTextStopConditions methodsFor: 'accessing' stamp: ''!
crossedX
	"Answer the special action to be performed when crossing composition bounds."
	
	^crossedX! !

!RubTextStopConditions methodsFor: 'initialization' stamp: ''!
setStops: stopArray
	stops := stopArray! !

!RubTextStyleChanged commentStamp: ''!
I am raised when the style (font, style...) is changed!
!RubTextUpdatedInModel commentStamp: ''!
I am raised when the model text is changed!
!RubUnderlinedSegmentMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	super drawOn: aCanvas.
	self drawUnderlineOn: aCanvas! !

!RubUnderlinedSegmentMorph methodsFor: 'accessing' stamp: ''!
underlineColor: aColor
	underlineColor := aColor! !

!RubUnderlinedSegmentMorph methodsFor: 'drawing' stamp: ''!
drawUnderlineOnAthensCanvas: aCanvas
	underlineShape
		do: [ :s | 
			| path |
			(1 to: s size - 1 by:
				(self straight
					ifTrue: [ 2 ]
					ifFalse: [ 1 ]))
				do: [ :p | 
					| s1 s2 |
					s1 := s at: p.
					s2 := s at: p + 1.
					path := aCanvas
						createPath: [ :builder | 
							builder absolute.
							builder moveTo: s1.
							builder lineTo: s2 ].
					(aCanvas setStrokePaint: self underlineColor) width: 1.
					aCanvas drawShape: path ] ]! !

!RubUnderlinedSegmentMorph methodsFor: 'accessing' stamp: ''!
underlineColor
	^ underlineColor ifNil: [ underlineColor := self defaultUnderlineColor ]! !

!RubUnderlinedSegmentMorph methodsFor: 'accessing' stamp: ''!
straight
	^ straight ifNil: [ straight := true ]
	! !

!RubUnderlinedSegmentMorph methodsFor: 'drawing' stamp: ''!
tabLineDashes
	^ { 1. 1} ! !

!RubUnderlinedSegmentMorph methodsFor: 'accessing' stamp: ''!
straight: aBoolean
	straight := aBoolean.
	self computeVertices 
	! !

!RubUnderlinedSegmentMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	^ super defaultColor alpha: 0.5.
! !

!RubUnderlinedSegmentMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^ Color white alpha: 0.05
! !

!RubUnderlinedSegmentMorph methodsFor: 'drawing' stamp: ''!
computeVertices
	| lpos rpos fln lln |
	super computeVertices.
	fln := self firstLineIndex.
	lln := self lastLineIndex.
	underlineShape := OrderedCollection new.
	fln to: lln do: [ :idx | 
		| line cidx |
		line := self lines at: idx.
		cidx := idx = fln
			ifTrue: [ firstIndex ]
			ifFalse: [ line first ].
		lpos := (self characterBlockForIndex: cidx) bottomLeft.
		cidx := idx = lln
			ifTrue: [ lastIndex ]
			ifFalse: [ line last ].
		rpos := (self characterBlockForIndex: cidx) bottomLeft.
		underlineShape add: (self underlineShapeFromPosition: lpos toPosition: rpos) ]! !

!RubUnderlinedSegmentMorph methodsFor: 'initialization' stamp: ''!
defaultUnderlineColor
	^ super defaultColor
! !

!RubUnderlinedSegmentMorph methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	super drawOnAthensCanvas: anAthensCanvas.
	self drawUnderlineOnAthensCanvas: anAthensCanvas! !

!RubUnderlinedSegmentMorph methodsFor: 'drawing' stamp: ''!
drawUnderlineOn: aCanvas
	underlineShape
		do: [ :s | 
			(1 to: s size - 1 by:
				(self straight
					ifTrue: [ 2 ]
					ifFalse: [ 1 ]))
				do: [ :p | 
					| s1 s2 |
					s1 := s at: p.
					s2 := s at: p + 1.
					aCanvas
						line: s1
						to: s2
						width: 2
						color: self underlineColor ] ]! !

!RubUnderlinedSegmentMorph methodsFor: 'drawing' stamp: ''!
underlineShapeFromPosition: firstPos toPosition: lastPos
	| shape ygap pos |
	shape := OrderedCollection new.
	ygap := self straight
		ifTrue: [ 0 ]
		ifFalse: [ 1 ].
	shape add: (pos := firstPos x @ (firstPos y + (ygap // 2))).
	[ pos x < (lastPos x min: self right) ]
		whileTrue: [ 
			ygap := ygap negated.
			pos := (pos x + 2 min: self right) @ (pos y + ygap).
			shape add: pos.
			pos := pos + (1 @ 0) ].
	^ shape! !

!RubUnderlinedSegmentMorph class methodsFor: '*NewTools-SpTextPresenterDecorators' stamp: ''!
on: aTextPresenterDecorator
	^ (self
		   from: aTextPresenterDecorator start
		   to: aTextPresenterDecorator stop)
		  color: aTextPresenterDecorator highlightColor;
		  underlineColor: aTextPresenterDecorator underlineColor;
		  icon: aTextPresenterDecorator icon;
		  iconBlock: aTextPresenterDecorator iconBlock;
		  label: aTextPresenterDecorator title;
		  yourself! !

!RubVerticalScrolled commentStamp: ''!
I am raised when a vertical scroll is done!
!RubVerticalScrolled methodsFor: 'accessing' stamp: ''!
scrollValue
	^ scrollValue! !

!RubVerticalScrolled methodsFor: 'accessing' stamp: ''!
scrollValue: anObject
	scrollValue := anObject! !

!RubVerticalScrolled class methodsFor: 'instance creation' stamp: ''!
scrollValue: aScrollValue
	^ self new scrollValue: aScrollValue! !

!RubWorkspaceBarRuler commentStamp: ''!
A bottom bar to change the editing mode, switch with/without line numbers and switch wrapping mode!
!RubWorkspaceBarRuler methodsFor: 'geometry' stamp: ''!
manageLayoutInBounds: aRectangle
	| ret |
	ret := super manageLayoutInBounds: aRectangle.
	self updateContents.
	^ ret! !

!RubWorkspaceBarRuler methodsFor: 'accessing' stamp: ''!
fontToUse
	^ RubAbstractTextArea lineNumbersFont ! !

!RubWorkspaceBarRuler methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ self paragraphProvider backgroundColor darker! !

!RubWorkspaceBarRuler methodsFor: 'managing line numbers' stamp: ''!
changeLineNumbersDisplay
	self paragraphProvider lineNumbersRuler 
		ifNil: [ self paragraphProvider withLineNumbers ]
		ifNotNil: [ self paragraphProvider withoutLineNumbers ].
	self paragraphProvider manageLayout.
	self updateContents! !

!RubWorkspaceBarRuler methodsFor: 'managing line numbers' stamp: ''!
lineNumbersDisplayLabelMorph
	^ StringMorph contents: self lineNumbersDisplayLabel font: self fontToUse! !

!RubWorkspaceBarRuler methodsFor: 'managing wrapping policy' stamp: ''!
changeWrappingPolicy
	self paragraphProvider wrapped
		ifTrue: [ self paragraphProvider beNotWrapped ]
		ifFalse: [ self paragraphProvider beWrapped ].
	self updateContents.
	self paragraphProvider changed! !

!RubWorkspaceBarRuler methodsFor: 'managing line numbers' stamp: ''!
lineNumbersDisplayLabel
	^ self paragraphProvider lineNumbersRuler  
		ifNil: [ '+L' ]
		ifNotNil: [ 'L' ]! !

!RubWorkspaceBarRuler methodsFor: 'managing editing mode' stamp: ''!
chooseEditingMode: anEvent
	self modeListMenu invokeAt: anEvent position in: self world.
	self updateContents! !

!RubWorkspaceBarRuler methodsFor: 'managing editing mode' stamp: ''!
editingModeLabelMorph
	^ StringMorph
		contents: self editingModeLabel
		font: self fontToUse! !

!RubWorkspaceBarRuler methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self side: #bottom! !

!RubWorkspaceBarRuler methodsFor: 'managing wrapping policy' stamp: ''!
wrappingPolicyLabel
	^ self paragraphProvider wrapped
		ifTrue: [ 'W' ]
		ifFalse: [ 'NW' ]! !

!RubWorkspaceBarRuler methodsFor: 'accessing' stamp: ''!
level
	^ 1! !

!RubWorkspaceBarRuler methodsFor: 'geometry' stamp: ''!
computedHeightFrom: aRectangle
	^ row ifNil: [0] ifNotNil: [row height]! !

!RubWorkspaceBarRuler methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph
	super noteNewOwner: aMorph.
	self color: self backgroundColor.
	self paragraphProvider beForSmalltalkScripting.
	wrappingPolicyMorph := self wrappingPolicyLabelMorph.
	editingModeMorph := self editingModeLabelMorph.
	lineNumbersDisplayMorph := self lineNumbersDisplayLabelMorph.
	row := self theme
		newRowIn: self
		for:
			{(self spacer: 2).
			editingModeMorph.
			(self spacer: 2).
			wrappingPolicyMorph.
			(self spacer: 2).
			lineNumbersDisplayMorph.
			(self spacer: 2)}.
	wrappingPolicyMorph on: #mouseDown send: #changeWrappingPolicy to: self.
	editingModeMorph on: #mouseDown send: #chooseEditingMode: to: self.
	lineNumbersDisplayMorph on: #mouseDown send: #changeLineNumbersDisplay to: self.
	row color: Color transparent.
	row hResizing: #spaceFill.
	self addMorph: row! !

!RubWorkspaceBarRuler methodsFor: 'event handling' stamp: ''!
updateContents
	row ifNil: [ ^self ].
	wrappingPolicyMorph contents: self wrappingPolicyLabel.
	editingModeMorph contents: self editingModeLabel.
	lineNumbersDisplayMorph contents: self lineNumbersDisplayLabel.
	row bounds: self innerBounds! !

!RubWorkspaceBarRuler methodsFor: 'managing wrapping policy' stamp: ''!
wrappingPolicyLabelMorph
	^ StringMorph contents: self wrappingPolicyLabel font: self fontToUse! !

!RubWorkspaceBarRuler methodsFor: 'managing editing mode' stamp: ''!
editingModeLabel
	^ self paragraphProvider editingMode label! !

!RubWorkspaceBarRuler methodsFor: 'managing editing mode' stamp: ''!
switchToPlainTextMode
	self paragraphProvider beForPlainText ! !

!RubWorkspaceBarRuler methodsFor: 'managing editing mode' stamp: ''!
switchToSmalltalkScriptingMode
	self paragraphProvider beForSmalltalkScripting ! !

!RubWorkspaceBarRuler methodsFor: 'accessing' stamp: ''!
textColor
	^ self textArea lineNumbersTextColor muchDarker
! !

!RubWorkspaceBarRuler methodsFor: 'private' stamp: ''!
spacer: anInteger
	^ Morph new
		borderWidth: 0;
		color: Color transparent;
		extent: anInteger@3! !

!RubWorkspaceBarRuler methodsFor: 'managing editing mode' stamp: ''!
modeListMenu
	"Answer the menu to be presented to select an editing mode"

	| menu |
	menu := MenuMorph new.
	menu add: 'Plain text' target: self selector: #switchToPlainTextMode.
	menu add: 'Smalltalk scripting' target: self selector: #switchToSmalltalkScriptingMode.
	^ menu! !

!RubWorkspaceBarRuler class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!RubWorkspaceBarRuler class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!RubWorkspaceBarRuler class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!RubWorkspaceBarRuler class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!RubWorkspaceBarRuler class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!RubWorkspaceBarRuler class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!RubWorkspaceBarRuler class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!RubWorkspaceBarRuler class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!RubWorkspaceBarRuler class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RubWorkspaceBarRuler class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!RubWorkspaceBarRuler class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!RubWorkspaceBarRuler class methodsFor: 'querying' stamp: ''!
key
	^ #workspaceBar! !

!RubWorkspaceBarRuler class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!RubWorkspaceBarRuler class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!RubWorkspaceBarRuler class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!RubWorkspaceBarRuler class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!RubWorkspaceBarRuler class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!RubWorkspaceBarRuler class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!RubWorkspaceBarRuler class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!RubWorkspaceBarRuler class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!RubWorkspaceBarRuler class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!RubWorkspaceBarRuler class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!RubWorkspaceBarRuler class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!RubWorkspaceBarRuler class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!RubWorkspaceBarRuler class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!RubWorkspaceBarRuler class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!RubWorkspaceBarRuler class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!RubWorkspaceBarRuler class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!RubWorkspaceBarRuler class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!RubWorkspaceBarRuler class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!RubWorkspaceExample commentStamp: ''!
self open!
!RubWorkspaceExample methodsFor: 'user interface' stamp: ''!
setText: aText from: aView 
	^ self acceptString: aText string! !

!RubWorkspaceExample methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	textModel := RubScrolledTextModel new
		interactionModel: self;
		yourself.
	mustDeclareVariables := false! !

!RubWorkspaceExample methodsFor: 'shout' stamp: ''!
shoutAboutToStyle: ATextView
	^ true! !

!RubWorkspaceExample methodsFor: 'shout' stamp: ''!
hasBindingOf: aString
	^bindings includesKey: aString asSymbol! !

!RubWorkspaceExample methodsFor: 'shout' stamp: ''!
bindingOf: aString

	mustDeclareVariables
		ifTrue: [ ^ nil ].	"I want to have workspace that force the user to declare  
	variables. Still subclasses may want to do something else"
	bindings ifNil: [ self initializeBindings ].
	( bindings includesKey: aString )
		ifFalse: [ bindings at: aString put: nil ].
	^ bindings associationAt: aString! !

!RubWorkspaceExample methodsFor: 'code pane menu' stamp: ''!
codePaneMenu: aMenu shifted: shifted 
	"Note that unless we override perform:orSendTo:, 
	PluggableTextController will respond to all menu items in a 
	text pane"
	"Not tested"! !

!RubWorkspaceExample methodsFor: 'user interface' stamp: ''!
newScrolledText
	| st |
	st := textModel newScrolledText 
		beWrapped;
		autoAccept: true;
		withLineNumbers;
		withGhostText: 'Workspace: a place where you can code and test scripts';
		withAnnotation;
		yourself.
	st ghostTextRuler fontName: 'Bitmap DejaVu Sans' pointSize: 18; textColor: Color gray lighter; centered.
	^st! !

!RubWorkspaceExample methodsFor: 'accessing' stamp: ''!
acceptString: aString
	textModel setText: aString asText.
	 ^ true! !

!RubWorkspaceExample methodsFor: 'user interface' stamp: ''!
getText
	^ textModel getText! !

!RubWorkspaceExample methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer ifNil: [ announcer := Announcer new ]! !

!RubWorkspaceExample class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	(self windowWithScrolledText: (self new newScrolledText)) openInWorld
! !

!RubWorkspaceExample class methodsFor: 'examples' stamp: ''!
exampleWindowWithScrolledText
	<sampleInstance>

	^self open! !

!RubWorkspaceExample class methodsFor: 'private - utilities' stamp: ''!
windowWithScrolledText: aScrolledText 
	| w |
	w := StandardWindow new.
	w title: self title.
	w addMorph: aScrolledText fullFrame: LayoutFrame identity.
	^w! !

!RubWorkspaceExample class methodsFor: 'examples' stamp: ''!
exampleWithCustomShortcut

	 |  window text |
    text := RubScrolledTextMorph new.

    "define a custom shortcut  - notice  the call to textArea"

    text textArea removeKeyCombination: $s meta.
	 text setText: 'Hit cmd $s to revert the text'.
    text textArea on: $s meta do:[
        text setText: text text asString reverse].

    window := StandardWindow new.
    window addMorph: text fullFrame: LayoutFrame identity.
    window title: 'Custom shortcuts example'.
    window openInWorld.! !

!RubWorkspaceExample class methodsFor: 'private - accessing' stamp: ''!
title
	^ 'Rubric workspace example'! !

!RunArray commentStamp: ''!
My instances provide space-efficient storage of data which tends to be constant over long runs of the possible indices. Essentially repeated values are stored singly and then associated with a "run" length that denotes the number of consecutive occurrences of the value.

My two important variables are
	runs	An array of how many elements are in each run
	values	An array of what the value is over those elements

The variables lastIndex, lastRun and lastOffset cache the last access
so that streaming through RunArrays is not an N-squared process.

Many complexities of access can be bypassed by using the method
	RunArray withStartStopAndValueDo:!
!RunArray methodsFor: 'private' stamp: ''!
fillFrom: aCollection with: aBlock
	"Evaluate aBlock with each of aCollection's elements as the argument.
	Collect the resulting values into self. Answer self."

	| newRuns newValues lastLength lastValue |
	newRuns := (Array new: aCollection size) writeStream.
	newValues := (Array new: aCollection size) writeStream.
	lastLength := 0.
	lastValue := Object new.
	aCollection do: [:each | 
		| value |
		value := aBlock value: each.
		lastValue = value
			ifTrue: [lastLength := lastLength + 1]
			ifFalse:
				[lastLength > 0
					ifTrue:
						[newRuns nextPut: lastLength.
						newValues nextPut: lastValue].
				lastLength := 1.
				lastValue := value]].
	lastLength > 0
		ifTrue:
			[newRuns nextPut: lastLength.
			newValues nextPut: lastValue].
	self setRuns: newRuns contents setValues: newValues contents! !

!RunArray methodsFor: 'copying' stamp: ''!
copyUpTo: anElement 
	"Optimized"

	| newValues |
	newValues := values copyUpTo: anElement.
	^ self class
		runs: (runs copyFrom: 1 to: newValues size)
		values: newValues! !

!RunArray methodsFor: 'testing' stamp: ''!
includes: anObject
	"Answer whether anObject is one of the receiver's elements."

	^values includes: anObject! !

!RunArray methodsFor: 'printing' stamp: ''!
writeOn: aStream

	aStream nextWordPut: runs size.
	1 to: runs size do:
		[:x |
		aStream nextWordPut: (runs at: x).
		aStream nextWordPut: (values at: x)]! !

!RunArray methodsFor: 'enumerating' stamp: ''!
runsAndValuesDo: aBlock
	"Evaluate aBlock with run lengths and values from the receiver"
	^runs with: values do: aBlock.! !

!RunArray methodsFor: 'converting' stamp: ''!
asBag
	| aBag |
	aBag := Bag new: values size.
	self runsAndValuesDo: [:run :value |
		aBag add: value withOccurrences: run].
	^aBag! !

!RunArray methodsFor: 'enumerating' stamp: ''!
reverseDo: aBlock
	"This is refined for speed"
	
	| i |
	i := runs size.
	[i > 0]
		whileTrue: 
			[ | r v |
			v := values at: i.
			r := runs at: i.
			i := i - 1.
			[( r := r - 1) >= 0]
				whileTrue: [aBlock value: v]].! !

!RunArray methodsFor: 'testing' stamp: ''!
isSorted
	^values isSorted! !

!RunArray methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating
	^ self class == RunArray and: [values isSelfEvaluating]! !

!RunArray methodsFor: 'adding' stamp: ''!
rangeOf: attr startingAt: startPos
	"Answer an interval that gives the range of attr at index position startPos. An empty interval with start value startPos is returned when the attribute attr is not present at position startPos. self size > 0 is assumed, it is the responsibility of the caller to test for emptiness of self.
Note that an attribute may span several adjancent runs. "

	self at: startPos 
		setRunOffsetAndValue: 
			[:run :offset :value | 
			^(value includes: attr)
				ifFalse: [startPos to: startPos - 1]
				ifTrue:
					[ | firstRelevantPosition lastRelevantPosition idxOfCandidateRun |
					lastRelevantPosition := startPos - offset + (runs at: run) - 1.
					firstRelevantPosition := startPos - offset.
					idxOfCandidateRun := run + 1.
					[idxOfCandidateRun <= runs size 
							 and: [(values at: idxOfCandidateRun) includes: attr]]
						whileTrue:
							[lastRelevantPosition := lastRelevantPosition + (runs at: idxOfCandidateRun).
							idxOfCandidateRun := idxOfCandidateRun + 1]. 
					idxOfCandidateRun := run - 1.
					[idxOfCandidateRun >= 1 
							 and: [(values at: idxOfCandidateRun) includes: attr]]
						whileTrue:
							[firstRelevantPosition := firstRelevantPosition - (runs at: idxOfCandidateRun).
							idxOfCandidateRun := idxOfCandidateRun - 1]. 
 
					firstRelevantPosition to: lastRelevantPosition]]! !

!RunArray methodsFor: 'enumerating' stamp: ''!
do: aBlock
	"This is refined for speed"
	
	1 to: runs size do: [:i |
		| r v |
		v := values at: i.
		r := runs at: i.
		[( r := r - 1) >= 0]
			whileTrue: [aBlock value: v]].! !

!RunArray methodsFor: 'accessing' stamp: ''!
last
	^values at: values size! !

!RunArray methodsFor: 'accessing' stamp: ''!
runLengthAt: index 
	"Answer the length remaining in run beginning at index."

	self at: index 
		setRunOffsetAndValue: [:run :offset :value | ^(runs at: run) - offset]! !

!RunArray methodsFor: 'copying' stamp: ''!
copyUpToLast: anElement
	"Optimized"

	| newValues |
	newValues := values copyUpToLast: anElement.
	^ self class
		runs: (runs copyFrom: 1 to: newValues size)
		values: newValues! !

!RunArray methodsFor: 'enumerating' stamp: ''!
count: aBlock
	"Beware, the block will be evaluated only once per group of values."
	| count |
	count := 0.
	self runsAndValuesDo: [:run :value |
		(aBlock value: value)
			ifTrue:
				[count := count + run]].
	^count! !

!RunArray methodsFor: 'enumerating' stamp: ''!
collect: aBlock
	"Beware, the block will be evaluated only once per group of values."
	^(self class runs: runs copy contents values: (values collect: aBlock)) coalesce! !

!RunArray methodsFor: 'adding' stamp: ''!
add: newObject withOccurrences: anInteger
	"Add value as the last element of the receiver, the given number of times"
	anInteger <= 0 ifTrue: [ ^self ].
	lastIndex := nil. "flush access cache"
	(runs size=0 or: [values last ~= newObject])
		ifTrue:
			[runs := runs copyWith: anInteger.
			values := values copyWith: newObject]
		ifFalse:
			[runs at: runs size put: runs last + anInteger]! !

!RunArray methodsFor: 'adding' stamp: ''!
addLast: value
	"Add value as the last element of the receiver."
	lastIndex := nil. "flush access cache"
	(runs size=0 or: [values last ~= value])
		ifTrue:
			[runs := runs copyWith: 1.
			values := values copyWith: value]
		ifFalse:
			[runs at: runs size put: runs last+1].
	^value! !

!RunArray methodsFor: 'private' stamp: ''!
mapValues: mapBlock
	"NOTE: only meaningful to an entire set of runs"

	values := values collect: mapBlock! !

!RunArray methodsFor: 'adding' stamp: ''!
repeatLast: times ifEmpty: defaultBlock
	"add the last value back again, the given number of times. If we are empty, add (defaultBlock value)"
	times = 0 ifTrue: [^self ].
	lastIndex := nil. "flush access cache"
	(runs size=0)
		ifTrue:
			[runs := runs copyWith: times.
			values := values copyWith: defaultBlock value]
		ifFalse:
			[runs at: runs size put: runs last+times] ! !

!RunArray methodsFor: 'adding' stamp: ''!
addFirst: value
	"Add value as the first element of the receiver."
	lastIndex := nil. "flush access cache"
	(runs size=0 or: [values first ~= value])
		ifTrue:
			[runs := {1}, runs.
			values := {value}, values]
		ifFalse:
			[runs at: 1 put: runs first+1]! !

!RunArray methodsFor: 'accessing' stamp: ''!
at: index put: aValue
	"Set an element of the RunArray"

	| runIndex offsetInRun lastValue runLength runReplacement valueReplacement iStart iStop |
	index isInteger
		ifFalse: [ self errorNonIntegerIndex ].
	(index between: 1 and: self size)
		ifFalse: [ self errorSubscriptBounds: index ].
	self
		at: index
		setRunOffsetAndValue: [ :run :offset :value | 
			runIndex := run.
			offsetInRun := offset.
			lastValue := value ].
	aValue = lastValue
		ifTrue: [ ^ aValue ].
	runLength := runs at: runIndex.
	runReplacement := Array with: offsetInRun with: 1 with: runLength - offsetInRun - 1.
	valueReplacement := Array with: lastValue with: aValue with: lastValue.
	iStart := offsetInRun = 0
		ifTrue: [ 2 ]
		ifFalse: [ 1 ].
	iStop := offsetInRun = (runLength - 1)
		ifTrue: [ 2 ]
		ifFalse: [ 3 ].
	self
		setRuns: (runs copyReplaceFrom: runIndex to: runIndex with: (runReplacement copyFrom: iStart to: iStop))
		setValues: (values copyReplaceFrom: runIndex to: runIndex with: (valueReplacement copyFrom: iStart to: iStop)).
	self coalesce.
	^ aValue! !

!RunArray methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	runs := runs copy.
	values := values copy! !

!RunArray methodsFor: 'enumerating' stamp: ''!
noneSatisfy: aBlock 
	"Only evaluate once per run"

	^values noneSatisfy: aBlock! !

!RunArray methodsFor: 'enumerating' stamp: ''!
anySatisfy: aBlock 
	"Only evaluate once per run"

	^values anySatisfy: aBlock! !

!RunArray methodsFor: 'enumerating' stamp: ''!
detect: aBlock ifNone: exceptionBlock 
	"Only evaluate once per run"

	^values detect: aBlock ifNone: exceptionBlock ! !

!RunArray methodsFor: 'enumerating' stamp: ''!
replace: aBlock
	"Beware, the block will be evaluated only once per group of values."
	values := values replace: aBlock.
	self coalesce! !

!RunArray methodsFor: 'removing' stamp: ''!
removeAll
	runs := Array new.
	values := Array new! !

!RunArray methodsFor: 'enumerating' stamp: ''!
detectMin: aBlock
	"Only evaluate once per run"

	^values detectMin: aBlock! !

!RunArray methodsFor: 'accessing' stamp: ''!
size
	| size |
	size := 0.
	1 to: runs size do: [:i | size := size + (runs at: i)].
	^size! !

!RunArray methodsFor: 'copying' stamp: ''!
copyFrom: start to: stop
	| newRuns run1 run2 offset1 offset2 | 
	stop < start ifTrue: [^RunArray new].
	self at: start setRunOffsetAndValue: [:r :o :value1 | run1 := r. offset1 := o. value1].
	self at: stop setRunOffsetAndValue: [:r :o :value2 | run2 := r. offset2 := o. value2].
	run1 = run2
		ifTrue: 
			[newRuns := Array with: offset2 - offset1 + 1]
		ifFalse: 
			[newRuns := runs copyFrom: run1 to: run2.
			newRuns at: 1 put: (newRuns at: 1) - offset1.
			newRuns at: newRuns size put: offset2 + 1].
	^RunArray runs: newRuns values: (values copyFrom: run1 to: run2)! !

!RunArray methodsFor: 'accessing' stamp: ''!
withStartStopAndValueDo: aBlock
	| start |
	start := 1.
	runs with: values do:
		[:len : val | | stop |
		stop := start + len - 1.
		aBlock value: start value: stop value: val.
		start := stop + 1]
		! !

!RunArray methodsFor: 'enumerating' stamp: ''!
sum: aBlock
	"Only loop on runs"
	| sum |
	sum := 0.
	self runsAndValuesDo: [:run :value | 
		sum := (aBlock value: value) * run + sum].
	^ sum! !

!RunArray methodsFor: 'converting' stamp: ''!
reversed
	^self class runs: runs reversed values: values reversed! !

!RunArray methodsFor: 'enumerating' stamp: ''!
findFirst: aBlock
	| index |
	index := 1.
	self runsAndValuesDo: [ :run :value |
		(aBlock value: value) ifTrue: [^index].
		index := index + run].
	^0! !

!RunArray methodsFor: 'comparing' stamp: ''!
= otherArray 
	"Test if all my elements are equal to those of otherArray"

	self == otherArray ifTrue: [^true].
	self species == otherArray species ifFalse: [^ false].
	(otherArray isMemberOf: RunArray) ifFalse: [^ self hasEqualElements: otherArray].

	"Faster test between two RunArrays"
	^ (runs hasEqualElements: otherArray runs)
		and: [values hasEqualElements: otherArray values]! !

!RunArray methodsFor: 'adding' stamp: ''!
add: newObject 
	"Include newObject as one of the receiver's elements. Answer newObject. 
	ArrayedCollections cannot respond to this message."

	^ self addLast: newObject! !

!RunArray methodsFor: 'adding' stamp: ''!
repeatLastIfEmpty: defaultBlock
	"add the last value back again. If we are empty, add (defaultBlock value)"
	lastIndex := nil. "flush access cache"
	(runs size=0)
		ifTrue:[
			runs := runs copyWith: 1.
			values := values copyWith: defaultBlock value]
		ifFalse:
			[runs at: runs size put: runs last+1]! !

!RunArray methodsFor: 'enumerating' stamp: ''!
select: aBlock
	"Beware, the block will be evaluated only once per group of values."
	| newRuns newValues |
	newRuns := (Array new: runs size) writeStream.
	newValues := (Array new: values size) writeStream.
	self runsAndValuesDo: [:run :value |
		(aBlock value: value)
			ifTrue:
				[newRuns add: run.
				newValues add: value]].
	^(self class runs: newRuns contents values: newValues contents) coalesce! !

!RunArray methodsFor: 'printing' stamp: ''!
printOn: aStream
	self printNameOn: aStream.
	aStream
		nextPutAll: ' runs: ';
		print: runs;
		nextPutAll: ' values: ';
		print: values! !

!RunArray methodsFor: 'accessing' stamp: ''!
at: index

	self at: index setRunOffsetAndValue: [:run :offset :value | ^value]! !

!RunArray methodsFor: 'accessing' stamp: ''!
first
	^values at: 1! !

!RunArray methodsFor: '*STON-Text support' stamp: ''!
stonOn: stonWriter
	"Overwritten to get back the standard object behavior"
	
	stonWriter writeObject: self! !

!RunArray methodsFor: 'enumerating' stamp: ''!
detectMax: aBlock
	"Only evaluate once per run"

	^values detectMax: aBlock! !

!RunArray methodsFor: 'private' stamp: ''!
runs

	^runs! !

!RunArray methodsFor: 'enumerating' stamp: ''!
findLast: aBlock
	| index |
	index := values size + 1.
	[(index := index - 1) >= 1] whileTrue:
		[(aBlock value: (values at: index)) ifTrue: [^(1 to: index) sum: [:i | runs at: i]]].
	^0! !

!RunArray methodsFor: 'copying' stamp: ''!
copyReplaceFrom: start to: stop with: replacement

	^(self copyFrom: 1 to: start - 1)
		, replacement 
		, (self copyFrom: stop + 1 to: self size)! !

!RunArray methodsFor: 'converting' stamp: ''!
asSet
	^values asSet! !

!RunArray methodsFor: 'testing' stamp: ''!
isSortedBy: aBlock
	^values isSortedBy: aBlock! !

!RunArray methodsFor: 'private' stamp: ''!
at: index setRunOffsetAndValue: aBlock 
	"Supply all run information to aBlock."
	"Tolerates index=0 and index=size+1 for copyReplace: "
	| run limit offset |
	limit := runs size.
	(lastIndex == nil or: [index < lastIndex])
		ifTrue: "cache not loaded, or beyond index - start over"
			[run := 1.
			offset := index-1]
		ifFalse: "cache loaded and before index - start at cache"
			[run := lastRun.
			offset := lastOffset + (index-lastIndex)].
	[run <= limit and: [offset >= (runs at: run)]]
		whileTrue: 
			[offset := offset - (runs at: run).
			run := run + 1].
	lastIndex := index. "Load cache for next access"
	lastRun := run.
	lastOffset := offset.
	run > limit
		ifTrue: 
			["adjustment for size+1"
			run := run - 1.
			offset := offset + (runs at: run)].
	^aBlock
		value: run "an index into runs and values"
		value: offset "zero-based offset from beginning of this run"
		value: (values at: run) "value for this run"! !

!RunArray methodsFor: 'adding' stamp: ''!
coalesce
	"Try to combine adjacent runs"
	| ind |
	ind := 2.
	[ind > values size] whileFalse: [
		(values at: ind-1) = (values at: ind) 
			ifFalse: [ind := ind + 1]
			ifTrue: ["two are the same, combine them"
				values := values copyReplaceFrom: ind to: ind with: #().
				runs at: ind-1 put: (runs at: ind-1) + (runs at: ind).
				runs := runs copyReplaceFrom: ind to: ind with: #().
				"self error: 'needed to combine runs' "]].
			! !

!RunArray methodsFor: 'copying' stamp: ''!
copyUpThrough: anElement
	"Optimized"

	| newValues |
	newValues := values copyUpThrough: anElement.
	^ self class
		runs: (runs copyFrom: 1 to: newValues size)
		values: newValues! !

!RunArray methodsFor: 'enumerating' stamp: ''!
runsFrom: start to: stop do: aBlock
	"Evaluate aBlock with all existing runs in the range from start to stop"
	start > stop ifTrue:[^self].
	self at: start setRunOffsetAndValue:[:firstRun :offset :firstValue|
		| run value index |
		run := firstRun.
		value := firstValue.
		index := start + (runs at: run) - offset.
		[aBlock value: value.
		index <= stop] whileTrue:[
			run := run + 1.
			value := values at: run.
			index := index + (runs at: run)]].
! !

!RunArray methodsFor: 'copying' stamp: ''!
, aRunArray 
	"Answer a new RunArray that is a concatenation of the receiver and
	aRunArray."

	| new newRuns |
	(aRunArray isMemberOf: RunArray)
		ifFalse: 
			[new := self copy.
			"attempt to be sociable"
			aRunArray do: [:each | new addLast: each].
			^new].
	runs size = 0 ifTrue: [^aRunArray copy].
	aRunArray runs size = 0 ifTrue: [^self copy].
	(values at: values size) ~= (aRunArray values at: 1)
		ifTrue: [^RunArray
					runs: runs , aRunArray runs
					values: values , aRunArray values].
	newRuns := runs
			copyReplaceFrom: runs size
			to: runs size
			with: aRunArray runs.
	newRuns at: runs size put: (runs at: runs size) + (aRunArray runs at: 1).
	^RunArray
		runs: newRuns
		values: 
			(values
				copyReplaceFrom: values size
				to: values size
				with: aRunArray values)! !

!RunArray methodsFor: 'private' stamp: ''!
values
	"Answer the values in the receiver."

	^values! !

!RunArray methodsFor: '*STON-Text support' stamp: ''!
fromSton: stonReader
	"Overwritten to get back the standard object behavior"
	
	stonReader parseNamedInstVarsFor: self! !

!RunArray methodsFor: 'private' stamp: ''!
setRuns: newRuns setValues: newValues
	lastIndex := nil. "flush access cache"
	runs := newRuns asArray.
	values := newValues asArray.! !

!RunArray methodsFor: 'printing' stamp: ''!
storeOn: aStream

	aStream nextPut: $(.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' runs: '.
	runs storeOn: aStream.
	aStream nextPutAll: ' values: '.
	values storeOn: aStream.
	aStream nextPut: $)! !

!RunArray methodsFor: 'enumerating' stamp: ''!
allSatisfy: aBlock 
	"Only evaluate once per run"

	^values allSatisfy: aBlock! !

!RunArray methodsFor: 'removing' stamp: ''!
remove: anObject ifAbsent: exceptionBlock
	| index mustCoalesce run |
	index := values indexOf: anObject ifAbsent: [^exceptionBlock value].
	(run := runs at: index) > 1
		ifTrue: [runs at: index put: run - 1]
		ifFalse:
			[mustCoalesce := index > 1 and: [index < values size and: [(values at: index - 1) = (values at: index + 1)]].
			runs := runs copyWithoutIndex: index.
			values := values copyWithoutIndex: index.
			mustCoalesce
				ifTrue:
					[runs at: index - 1 put: (runs at: index - 1) + (runs at: index).
					runs := runs copyWithoutIndex: index.
					values := values copyWithoutIndex: index]].
	^anObject! !

!RunArray class methodsFor: 'instance creation' stamp: ''!
new

	^self runs: Array new values: Array new! !

!RunArray class methodsFor: 'instance creation' stamp: ''!
new: size withAll: value 
	"Answer a new instance of me, whose every element is equal to the
	argument, value."

	size = 0 ifTrue: [^self new].
	^self runs: (Array with: size) values: (Array with: value)! !

!RunArray class methodsFor: 'instance creation' stamp: ''!
new: aSize
	^ self new: aSize withAll: nil! !

!RunArray class methodsFor: 'instance creation' stamp: ''!
runs: newRuns values: newValues 
	"Answer an instance of me with runs and values specified by the 
	arguments."

	| instance |
	instance := self basicNew.
	instance setRuns: newRuns setValues: newValues.
	^instance! !

!RunArray class methodsFor: 'instance creation' stamp: ''!
scanFrom: strm
	"Read the style section of a fileOut or sources file.	nextChunk has already been done. We need to return a RunArray of TextAttributes of various kinds. These are written by the implementors of writeScanOn:"
	| runs values attrList char |
	(strm peekFor: $( ) ifFalse: [^ nil].
	runs := OrderedCollection new.
	[strm skipSeparators.
	 strm peekFor: $)] whileFalse: 
		[runs add: (Number readFrom: strm)].
	values := OrderedCollection new. "Value array"
	attrList := OrderedCollection new. "Attributes list"
	[(char := strm next) == nil] whileFalse: [
		char == $, ifTrue: [values add: attrList asArray. attrList := OrderedCollection new].
		char == $a ifTrue: [attrList add: 
			(TextAlignment new alignment: (Integer readFrom: strm ifFail: [0]))].
		char == $f ifTrue: [attrList add: 
			(TextFontChange new fontNumber: (Integer readFrom: strm ifFail: [0]))].
		char == $F ifTrue: [attrList add: (TextFontReference toFont: 
			(self environment at: #StrikeFont ifPresent: [:sf | sf familyName: (strm upTo: $#) size: (Integer readFrom: strm ifFail: [0])]))].
		char == $b ifTrue: [attrList add: (TextEmphasis bold)].
		char == $i ifTrue: [attrList add: (TextEmphasis italic)].
		char == $u ifTrue: [attrList add: (TextEmphasis underlined)].
		char == $= ifTrue: [attrList add: (TextEmphasis struckOut)].
		char == $n ifTrue: [attrList add: (TextEmphasis normal)].
		char == $- ifTrue: [attrList add: (TextKern kern: -1)].
		char == $+ ifTrue: [attrList add: (TextKern kern: 1)].
		char == $c ifTrue: [attrList add: (TextColor scanFrom: strm)]. "color"
		char == $L ifTrue: [attrList add: (TextLink scanFrom: strm)]. "L not look like 1"
		char == $R ifTrue: [attrList add: (TextURL scanFrom: strm)].
				"R capitalized so it can follow a number"
		char == $P ifTrue: [attrList add: (TextPrintIt scanFrom: strm)].
		char == $d ifTrue: [attrList add: (TextDoIt scanFrom: strm)].
		"space, cr do nothing"
		].
	values add: attrList asArray.
	^ self runs: runs asArray values: (values copyFrom: 1 to: runs size) asArray
"
RunArray scanFrom: (ReadStream on: '(14 50 312)f1,f1b,f1LInteger +;i')
"! !

!RunArray class methodsFor: '*STON-Text support' stamp: ''!
fromSton: stonReader
	"Overwritten to get back the standard object behavior"

	^ self new
		fromSton: stonReader;
		yourself! !

!RunArray class methodsFor: 'instance creation' stamp: ''!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	| runs values lastRun lastValue |
	runs := (Array new: aCollection size // 2) writeStream.
	values := (Array new: aCollection size // 2) writeStream.
	lastRun := 0.
	lastValue := Object new.
	aCollection do: [:x | 
		lastValue = x
			ifTrue: [lastRun := lastRun + 1]
			ifFalse:
				[lastRun > 0
					ifTrue:
						[runs nextPut: lastRun.
						values nextPut: lastValue].
				lastRun := 1.
				lastValue := x]].
	lastRun > 0
		ifTrue:
			[runs nextPut: lastRun.
			values nextPut: lastValue].
	^self basicNew setRuns: runs contents setValues: values contents

"	RunArray newFrom: {1. 2. 2. 3}
	{1. $a. $a. 3} as: RunArray
	({1. $a. $a. 3} as: RunArray) values
"! !

!RunArray class methodsFor: 'instance creation' stamp: ''!
readFrom: aStream
	"Answer an instance of me as described on the stream, aStream."

	| size runs values |
	size := aStream nextWord.
	runs := Array new: size.
	values := Array new: size.
	1 to: size do:
		[:x |
		runs at: x put: aStream nextWord.
		values at: x put: aStream nextWord].
	^ self runs: runs values: values! !

!RunArrayTest commentStamp: ''!
SUnit tests for class RunArray!
!RunArrayTest methodsFor: 'tests - instance creation' stamp: ''!
testNewFromString
	
	| array |
	array := RunArray newFrom: 'abbbbcca'.
	self assert: array size equals: 8.
	self assert: array asArray equals: #($a $b $b $b $b $c $c $a)! !

!RunArrayTest methodsFor: 'tests - instance creation' stamp: ''!
testNewFromArray
	
	| array |
	array := RunArray newFrom: #($a $b $b $b $b $c $c $a).
	self assert: array size equals: 8.
	self assert: array asArray equals: #($a $b $b $b $b $c $c $a)! !

!RunArrayTest methodsFor: 'tests - instance creation' stamp: ''!
testNewWithSize
	|array|
	array := RunArray new: 5.
	self assert: array size equals: 5.
	1 to: 5 do: [:index | self assert: (array at: index) isNil]! !

!RunArrayTest methodsFor: 'tests - accessing' stamp: ''!
testFirst
	
	| array |
	array := RunArray new: 5 withAll: 2.
	self assert: array first equals: 2.
	
	array := 'abcd' as: RunArray.
	self assert: array first equals: $a! !

!RunArrayTest methodsFor: 'tests' stamp: ''!
testRunArrayInvariant
	"This verifies that the fundamental invariant of a RunArray is always satisfied.
	 This method is a bit tricky. First, it uses Object>>instVarNamed: to access instance 
	 variables for which no accessors are defined. The same method is used by the debuggers 
	 and by various inspectors. The assertion itself explains the meaning of the cached values."
	
	| runArray |
	runArray := RunArray new.
	runArray 
		add: TextEmphasis normal withOccurrences: 5;
		add: TextEmphasis bold withOccurrences: 5;
		add: TextEmphasis normal withOccurrences: 5.
	self assert:
       ((1 to: runArray size) allSatisfy:
           [:idx |  | lastIndex lastOffset lastRun lengthOfPreviousRuns |
               runArray at: idx.  " updates the cached values "
               lastIndex := runArray instVarNamed: 'lastIndex'.
               lastRun := runArray instVarNamed: 'lastRun'.
               lastOffset := runArray instVarNamed: 'lastOffset'.
               lengthOfPreviousRuns 
                   := (1 to: lastRun - 1)
                      inject: 0
                       into: [:sum :idx2 | sum + (runArray runs at: idx2)].
               lastIndex = (lastOffset + lengthOfPreviousRuns + 1) 
           ]
       )! !

!RunArrayTest methodsFor: 'tests' stamp: ''!
testRunArrayRunsAreNotMerged
	"This demonstrates that different runs are not merged."
	| runArray |
	runArray := RunArray new.
	runArray 
		add: TextEmphasis normal withOccurrences: 5;
		add: TextEmphasis bold withOccurrences: 5;
		add: TextEmphasis normal withOccurrences: 5.
	self assert: runArray runs size equals: 3 ! !

!RunArrayTest methodsFor: 'tests - instance creation' stamp: ''!
testRunsValues
	
	| array |
	array := RunArray runs: #(1 4 2 1) values: #($a $b $c $a).
	self assert: array size equals: 8.
	self assert: array asArray equals: #($a $b $b $b $b $c $c $a)! !

!RunArrayTest methodsFor: 'tests - accessing' stamp: ''!
testAt
	
	| array |
	array := RunArray new: 5 withAll: 2.
	self assert: (array at: 3) equals: 2.
	
	array at: 3 put: 5.
	self assert: (array at: 3) equals: 5
! !

!RunArrayTest methodsFor: 'tests - instance creation' stamp: ''!
testANewRunArrayIsEmpty
	self assertEmpty: RunArray new! !

!RunArrayTest methodsFor: 'tests - accessing' stamp: ''!
testAtPut
	
	| array |
	array := RunArray new: 5 withAll: 2.
	
	array at: 3 put: 5.
	self assert: array asArray equals: #(2 2 5 2 2).
	
	array at: 1 put: 1.
	self assert: array asArray equals: #(1 2 5 2 2)! !

!RunArrayTest methodsFor: 'tests - accessing' stamp: ''!
testLast
	
	| array |
	array := RunArray new: 5 withAll: 2.
	self assert: array last equals: 2.
	
	array := 'abcd' as: RunArray.
	self assert: array last equals: $d! !

!RunArrayTest methodsFor: 'tests - adding' stamp: ''!
testAdd

	| run |
	run := RunArray new. 
	self assert: run size equals: 0.
	
	run add: $A.
	self assert: run size equals: 1.
	run add: $A.
	self assert: run size equals: 2.
	run add: $B.
	self assert: run size equals: 3.! !

!RunArrayTest methodsFor: 'tests' stamp: ''!
testFindLast 

	self assert: ((RunArray newFrom: #(10 20 30 40 50)) findLast: [ :each | each > 10 ]) equals: 5.
	self assert: ((RunArray newFrom: #(10 20 30 40 50)) findLast: [ :each | each > 60 ]) equals: 0.! !

!RunArrayTest methodsFor: 'tests' stamp: ''!
testRunArrayReversal
  	"This tests the reversal of a RunArray."
	| runArray |
	runArray := RunArray new.
	runArray 
		add: TextEmphasis normal withOccurrences: 5;
		add: TextEmphasis bold withOccurrences: 5;
		add: TextEmphasis normal withOccurrences: 5.
	self assert: runArray reversed runs size equals: 3. ! !

!RunArrayTest methodsFor: 'tests - adding' stamp: ''!
testAddAddsAsLastElement

	| run |
	run := RunArray new. 
	self assert: run size equals: 0.
	
	run add: $A.
	run add: $A.
	run add: $B.
	self assert: (run at: 3) equals: $B! !

!RunArrayTest methodsFor: 'tests - instance creation' stamp: ''!
testIsSelfEvaluating
	| array array2 |
	array := RunArray new: 5 withAll: 2.
	self assert: array isSelfEvaluating.
	array2 := RunArray new: 5 withAll: Object new.
	array2 isSelfEvaluating ifTrue: [self
		assert: (self class compiler evaluate: array2 printString) = array2
		description: 'a self evaluating should evaluate as self']! !

!RunArrayTest methodsFor: 'tests' stamp: ''!
testRunArrayRunsSize
 	"This demonstrates that the size of a run array is the sum of the sizes of its runs."
	| runArray |
	runArray := RunArray new.
  	runArray 
		add: TextEmphasis normal withOccurrences: 5;
		add: TextEmphasis bold withOccurrences: 5;
		add: TextEmphasis normal withOccurrences: 5.
	self assert: runArray size equals: 15. ! !

!RunArrayTest methodsFor: 'tests - instance creation' stamp: ''!
testNewWithAll
	
	| array |
	array := RunArray new: 5 withAll: 2.
	self assert: array size equals: 5.
	self assert: array asArray equals: #(2 2 2 2 2)! !

!RunArrayTest methodsFor: 'tests - accessing' stamp: ''!
testAtPut2
	
	| array |
	array := RunArray new: 5 withAll: 2.
	
	self should: [array at: 0 put: 5] raise: Error.
	self should: [array at: 6 put: 5] raise: Error.
	self should: [array at: $b put: 5] raise: Error! !

!RunArrayTest methodsFor: 'tests - accessing' stamp: ''!
testRunLengthAt
	
	| array |
	array := #($a $b $b $c $c $c $d $d) as: RunArray.
	self assert: (array runLengthAt: 1) equals: 1.
	self assert: (array runLengthAt: 2) equals: 2.
	self assert: (array runLengthAt: 3) equals: 1.
	self assert: (array runLengthAt: 4) equals: 3.
	self assert: (array runLengthAt: 5) equals: 2.
	self assert: (array runLengthAt: 6) equals: 1.
	self assert: (array runLengthAt: 7) equals: 2.
	self assert: (array runLengthAt: 8) equals: 1.! !

!RunArrayTest methodsFor: 'tests - instance creation' stamp: ''!
testScanFromANSICompatibility
 
	RunArray scanFrom: '()f1dNumber new;;' readStream.
	RunArray scanFrom: '()a1death;;' readStream.
	RunArray scanFrom: '()F1death;;' readStream! !

!RunArrayTest methodsFor: 'tests' stamp: ''!
testRunArrayAdjacentMerge
	"This demonstrates that adjancent runs with equal attributes are merged."

	| runArray |
	runArray := RunArray new.
	runArray
		add: TextEmphasis normal withOccurrences: 5;
		add: TextEmphasis bold withOccurrences: 5;
		add: TextEmphasis bold withOccurrences: 5.
	self assert: runArray runs size equals: 2! !

!RunArrayTest methodsFor: 'tests - instance creation' stamp: ''!
testNew
	
	| array |
	array := RunArray new.
	self assert: array size equals: 0! !

!RunArrayTest methodsFor: 'tests - accessing' stamp: ''!
testWithStartStopAndValueDo
	
	| array elements startStops |
	array := #($a $b $b $c $c $c $d $d) as: RunArray.
	elements := OrderedCollection new.
	startStops := OrderedCollection new.
	array withStartStopAndValueDo: [:start :stop :value | elements add: value. startStops add: start->stop].
	
	self assert: elements asArray equals: #($a $b  $c  $d).
	self assert: startStops asArray equals: {1->1 . 2->3 . 4->6 . 7->8}! !

!RunToSelectionDebugAction commentStamp: ''!
A RunToSelectionDebugAction resumes the execution until the selected position in the source code is reached.!
!RunToSelectionDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 35! !

!RunToSelectionDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Execute methods up to the text cursor position and return debugger control.'! !

!RunToSelectionDebugAction methodsFor: 'actions' stamp: ''!
executeAction

	self session 
		runToSelection: self debugger code getSelection 
		inContext: self currentContext! !

!RunToSelectionDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #runToHere! !

!RunToSelectionDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Run to here'! !

!RunToSelectionDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<debuggingAction>
	<contextMenuCodeDebuggingAction>! !

!RuntimeSyntaxError commentStamp: ''!
When compiling syntactically incorrect code, we compile raising this exception.

This way the debugger opens and the programmer can easily fix the faulty method!
!RuntimeSyntaxError methodsFor: 'accessing' stamp: ''!
errorNode: aNode
	errorNode := aNode! !

!RuntimeSyntaxError methodsFor: 'accessing' stamp: ''!
errorMessage
	^errorNode errorMessage! !

!RuntimeSyntaxError methodsFor: 'accessing' stamp: ''!
messageText
	^self errorMessage! !

!RuntimeSyntaxError class methodsFor: 'signalling' stamp: ''!
signalSyntaxError: aNode
	"we use signalSyntaxError: instead of signal: so we can quickly check 
	compiledMethods for syntax errors by checking the literals"
	^(self new errorNode: aNode) signal! !

!RuntimeTyperTest commentStamp: ''!
A small demo how to record type information at runtime with reflectivity.

We create this link:

	link := MetaLink new
		metaObject: #node;
		selector: #tagType:;
		arguments: #(value);
		control: #after.
		

this will add a message send to the AST node itself where you install it. It will call tagType: and as an argument hand over the result of the right hand side of the 
assignment. 

tagType: looks like this:

	tagType: anObject 
		variable propertyAt: #types ifAbsentPut: Set new.
		(variable propertyAt: #types) add: anObject class.

it uses the feature that we can annotate all the AST nodes easily with properties.


We can now use this on a simple example:

	examplePlus: arg
		| result |
		result := arg + 1.
		^result.


With this, we can run a test, see #testPlus.

What is not nice here yet is that, as we tag the AST variable node, we just tag the local node in
	result := arg + 1.

So in addition, one would need some AST visitor to gather all these infos (and maybe those of static assignments,
e.g. “a := 1” we know the type of a) and add these annotations to al the vars that are actually the same variable.!
!RuntimeTyperTest methodsFor: 'tests' stamp: ''!
testPlus
	| link variable |
	link := MetaLink new
		metaObject: #node;
		selector: #tagType:;
		arguments: #(value);
		control: #after.

	(self class >> #examplePlus:) ast assignmentNodes do: [ :node | node link: link ].

	self assert: (self examplePlus: 1) equals: 2.
	self assert: (self examplePlus: 1.1) equals: 2.1.

	"link uninstall."

	variable := (self class >> #examplePlus:) ast assignmentNodes first variable.
	self assert: ((variable propertyAt: #types) includes: SmallInteger)! !

!RuntimeTyperTest methodsFor: 'examples' stamp: ''!
examplePlus: arg
	<sampleInstance>
	| result |
	result := arg + 1.
	^result.! !

!RxCharSetParser commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
I am a parser created to parse the insides of a character set ([...]) construct. I create and answer a collection of "elements", each being an instance of one of: RxsCharacter, RxsRange, or RxsPredicate.

Instance Variables:

	source <Stream>	open on whatever is inside the square brackets we have to parse.
	lookahead	<Character>	The current lookahead character
	elements	<Collection of: <RxsCharacter|RxsRange|RxsPredicate>> Parsing result!
!RxCharSetParser methodsFor: 'accessing' stamp: ''!
parse

	lookahead = $- ifTrue:
		[self addChar: $-.
		self match: $-].
	[lookahead isNil] whileFalse: [self parseStep].
	^elements! !

!RxCharSetParser methodsFor: 'parsing' stamp: ''!
parseNamedSet

	| name |
	self match: $[; match: $:.
	name := (String with: lookahead), (source upTo: $:).
	lookahead := source next.
	self match: $].
	elements add: (RxsPredicate forNamedClass: name)! !

!RxCharSetParser methodsFor: 'parsing' stamp: ''!
parseStep
	lookahead = $[
		ifTrue: [ ^ source peek = $:
				ifTrue: [ self parseNamedSet ]
				ifFalse: [ self parseCharOrRange ] ].
	lookahead = $\ ifTrue: [ ^ self parseEscapeChar ].
	lookahead = $- ifTrue: [ RxParser signalSyntaxException: 'invalid range' at: source position ].
	self parseCharOrRange! !

!RxCharSetParser methodsFor: 'parsing' stamp: ''!
parseCharOrRange
	| firstChar |
	firstChar := lookahead.
	self match: firstChar.
	lookahead = $-
		ifTrue: [ self match: $-.
			^ lookahead
				ifNil: [ self
						addChar: firstChar;
						addChar: $- ]
				ifNotNil: [ self addRangeFrom: firstChar to: lookahead.
					self match: lookahead ] ].
	self addChar: firstChar! !

!RxCharSetParser methodsFor: 'parsing' stamp: ''!
addRangeFrom: firstChar to: lastChar

	firstChar asInteger > lastChar asInteger ifTrue:
		[RxParser signalSyntaxException: ' bad character range' at: source position].
	elements add: (RxsRange from: firstChar to: lastChar)! !

!RxCharSetParser methodsFor: 'parsing' stamp: ''!
addChar: aChar

	elements add: (RxsCharacter with: aChar)! !

!RxCharSetParser methodsFor: 'parsing' stamp: ''!
match: aCharacter

	aCharacter = lookahead
		ifFalse: [
			RxParser 
				signalSyntaxException: 'unexpected character: ', (String with: lookahead)
				at: source position].
	^source atEnd
		ifTrue: [lookahead := nil]
		ifFalse: [lookahead := source next]! !

!RxCharSetParser methodsFor: 'parsing' stamp: ''!
parseEscapeChar

	self match: $\.
	$- = lookahead
		ifTrue: [elements add: (RxsCharacter with: $-)]
		ifFalse: [elements add: (RxsPredicate forEscapedLetter: lookahead)].
	self match: lookahead! !

!RxCharSetParser methodsFor: 'initialization' stamp: ''!
initialize: aStream

	source := aStream.
	lookahead := aStream next.
	elements := OrderedCollection new! !

!RxCharSetParser class methodsFor: 'instance creation' stamp: ''!
on: aStream

	^self new initialize: aStream! !

!RxExtensionsTest commentStamp: ''!
Unit tests for extensions done by Regex package!
!RxExtensionsTest methodsFor: 'tests' stamp: ''!
testSplitStringOnRegex
	self assert: ('foobar' splitOn: '[aeiou]+' asRegex)
		equals: #('f' 'b' 'r') asOrderedCollection! !

!RxExtensionsTest methodsFor: 'tests' stamp: ''!
testSplitJoinBoundaryCases
	"Empty splitter, joiner or sequence."
	self assert: ('' join: ('.' asRegex split: '')) equals: ''. "NB: Doesn't work with empty regex"! !

!RxMatchOptimizer commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
A match start optimizer, handy for searching a string. Takes a regex syntax tree and sets itself up so that prefix characters or matcher states that cannot start a match are later recognized with #canStartMatch:in: method.

Used by RxMatcher, but can be used by other matchers (if implemented) as well.!
!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxWordBoundary

	conditions add: #atWordBoundary! !

!RxMatchOptimizer methodsFor: 'accessing' stamp: ''!
conditionTester
	"#any condition is filtered at the higher level;
	it cannot appear among the conditions here."

	| matchCondition |
	conditions isEmpty ifTrue: [^nil].
	conditions size = 1 ifTrue:
		[matchCondition := conditions detect: [:ignored | true].
		"Special case all of the possible conditions."
		#atBeginningOfLine = matchCondition ifTrue: [^[:c :matcher | matcher atBeginningOfLine]].
		#atEndOfLine = matchCondition ifTrue: [^[:c :matcher | matcher atEndOfLine]].
		#atBeginningOfWord = matchCondition ifTrue: [^[:c :matcher | matcher atBeginningOfWord]].
		#atEndOfWord = matchCondition ifTrue: [^[:c :matcher | matcher atEndOfWord]].
		#atWordBoundary = matchCondition ifTrue: [^[:c :matcher | matcher atWordBoundary]].
		#notAtWordBoundary = matchCondition ifTrue: [^[:c :matcher | matcher notAtWordBoundary]].
		RxParser signalCompilationException: 'invalid match condition'].
	"More than one condition. Capture them as an array in scope."
	matchCondition := conditions asArray.
	^[:c :matcher |
		matchCondition contains:
			[:conditionSelector |
			matcher perform: conditionSelector]]! !

!RxMatchOptimizer methodsFor: 'accessing' stamp: ''!
nonMethodPredicateTester
	| p selector |
	nonMethodPredicates isEmpty ifTrue: [^nil].
	p := self optimizeSet: nonMethodPredicates.	"also allows copying closures"
	^p size = 1
		ifTrue: 
			[selector := p first.
			[:char :matcher | 
			RxParser doHandlingMessageNotUnderstood:
				[(char perform: selector) not]]]
		ifFalse: 
			[[:char :m | 
			RxParser doHandlingMessageNotUnderstood:
				[p contains: [:sel | (char perform: sel) not]]]]! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxPiece: pieceNode
	"Pass on to the atom."

	pieceNode atom dispatchTo: self! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxEpsilon
	"Empty string, terminate the recursion (do nothing)."! !

!RxMatchOptimizer methodsFor: 'private' stamp: ''!
nonPrefixTester

	| np nonPrefixChar |
	nonPrefixes isEmpty ifTrue: [^nil].
	np := self optimizeSet: nonPrefixes. "also allows copying closures"
	^np size = 1 "might be be pretty common case"
		ifTrue: 
			[nonPrefixChar := np first.
			[:char :matcher | char ~= nonPrefixChar]]
		ifFalse: [[:char : matcher | (np includes: char) not]]! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxNonWordBoundary

	conditions add: #notAtWordBoundary! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxCharSet: charSetNode 
	"All these (or none of these) characters is the prefix."

	charSetNode isNegated
		ifTrue: [nonPrefixes addAll: (charSetNode enumerableSetIgnoringCase: ignoreCase)]
		ifFalse: [prefixes addAll: (charSetNode enumerableSetIgnoringCase: ignoreCase)].
	charSetNode hasPredicates ifTrue: 
			[charSetNode isNegated
				ifTrue: [nonPredicates addAll: charSetNode predicates]
				ifFalse: [predicates addAll: charSetNode predicates]]! !

!RxMatchOptimizer methodsFor: 'accessing' stamp: ''!
methodPredicateTester
	| p selector |
	methodPredicates isEmpty ifTrue: [^nil].
	p := self optimizeSet: methodPredicates.	"also allows copying closures"
	^p size = 1
		ifTrue: 
			["might be a pretty common case"
			selector := p first.
			[:char :matcher | 
			RxParser doHandlingMessageNotUnderstood:
				[char perform: selector]]]
		ifFalse: 
			[[:char :m | 
			RxParser doHandlingMessageNotUnderstood:
				[p contains: [:sel | char perform: sel]]]]! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxMessagePredicate: messagePredicateNode 
	messagePredicateNode negated
		ifTrue: [nonMethodPredicates add: messagePredicateNode selector]
		ifFalse: [methodPredicates add: messagePredicateNode selector]! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxAny
	"Any special char is among the prefixes."

	conditions add: #any! !

!RxMatchOptimizer methodsFor: 'private' stamp: ''!
nonPredicateTester

	| p pred |
	nonPredicates isEmpty ifTrue: [^nil].
	p := self optimizeSet: nonPredicates.	"also allows copying closures"
	^p size = 1
		ifTrue: 
			[pred := p first.
			[:char :matcher | (pred value: char) not]]
		ifFalse: 
			[[:char :m | p contains: [:some | (some value: char) not]]]! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxBeginningOfLine
	"Beginning of line is among the prefixes."

	conditions add: #atBeginningOfLine! !

!RxMatchOptimizer methodsFor: 'private' stamp: ''!
prefixTester

	| p prefixChar |
	prefixes isEmpty ifTrue: [^nil].
	p := self optimizeSet: prefixes. "also allows copying closures"
	ignoreCase ifTrue: [p := p collect: [:each | each asUppercase]].
	^p size = 1 "might be a pretty common case"
		ifTrue: 
			[prefixChar := p first.
			ignoreCase
				ifTrue: [[:char :matcher | char sameAs: prefixChar]]
				ifFalse: [[:char :matcher | char = prefixChar]]]
		ifFalse:
			[ignoreCase
				ifTrue: [[:char :matcher | p includes: char asUppercase]]
				ifFalse: [[:char :matcher | p includes: char]]]! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxBeginningOfWord
	"Beginning of line is among the prefixes."

	conditions add: #atBeginningOfWord! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxLookaround: lookaroundNode 

	
	lookarounds add: lookaroundNode! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxCharacter: charNode
	"This character is the prefix, of one of them."

	prefixes add: charNode character! !

!RxMatchOptimizer methodsFor: 'private' stamp: ''!
determineTestMethod
	"Answer a block closure that will work as a can-match predicate.
	Answer nil if no viable optimization is possible (too many chars would
	be able to start a match)."

	| testers |
	(conditions includes: #any) ifTrue: [^nil].
	testers := OrderedCollection new: 5.
	#(#prefixTester #nonPrefixTester #conditionTester #methodPredicateTester #nonMethodPredicateTester #predicateTester #nonPredicateTester)
		do: 
			[:selector | 
			| tester |
			tester := self perform: selector.
			tester notNil ifTrue: [testers add: tester]].
	testers isEmpty ifTrue: [^nil].
	testers size = 1 ifTrue: [^testers first].
	testers := testers asArray.
	^[:char :matcher | testers contains: [:t | t value: char value: matcher]]! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxEndOfLine
	"Beginning of line is among the prefixes."

	conditions add: #atEndOfLine! !

!RxMatchOptimizer methodsFor: 'private' stamp: ''!
optimizeSet: aSet
	"If a set is small, convert it to array to speed up lookup
	(Array has no hashing overhead, beats Set on small number
	of elements)."

	^aSet size < 10 ifTrue: [aSet asArray] ifFalse: [aSet]! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxBranch: branchNode
	"If the head piece of the branch is transparent (allows 0 matches),
	we must recurse down the branch. Otherwise, just the head atom
	is important."

	(branchNode piece isNullable and: [branchNode branch notNil])
		ifTrue: [branchNode branch dispatchTo: self].
	branchNode piece dispatchTo: self! !

!RxMatchOptimizer methodsFor: 'initialization' stamp: ''!
initialize: aRegex ignoreCase: aBoolean 
	"Set `testMethod' variable to a can-match predicate block:
	two-argument block which accepts a lookahead character
	and a matcher (presumably built from aRegex) and answers 
	a boolean indicating whether a match could start at the given
	lookahead. "

	ignoreCase := aBoolean.
	prefixes := Set new: 10.
	nonPrefixes := Set new: 10.
	conditions := Set new: 3.
	methodPredicates := Set new: 3.
	nonMethodPredicates := Set new: 3.
	predicates := Set new: 3.
	nonPredicates := Set new: 3.
	lookarounds := Set new: 3.
	aRegex dispatchTo: self.	"If the whole expression is nullable, 
		end-of-line is an implicit can-match condition!!"
	aRegex isNullable ifTrue: [conditions add: #atEndOfLine].
	testBlock := self determineTestMethod! !

!RxMatchOptimizer methodsFor: 'accessing' stamp: ''!
canStartMatch: aCharacter in: aMatcher

	"Answer whether a match could commence at the given lookahead
	character, or in the current state of <aMatcher>. True answered
	by this method does not mean a match will definitly occur, while false
	answered by this method *does* guarantee a match will never occur."

	aCharacter ifNil: [ ^ true ].
	^ testBlock == nil or: [ testBlock value: aCharacter value: aMatcher ]! !

!RxMatchOptimizer methodsFor: 'private' stamp: ''!
predicateTester

	| p pred |
	predicates isEmpty ifTrue: [^nil].
	p := self optimizeSet: predicates.	"also allows copying closures"
	^p size = 1
		ifTrue: [
			pred := p first.
			[:char :matcher | 
				pred value: char ]]
		ifFalse: [
			[:char :matcher | 
				p contains: [:some | some value: char ]]]! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxEndOfWord

	conditions add: #atEndOfWord! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxPredicate: predicateNode 

	predicates add: predicateNode predicate! !

!RxMatchOptimizer methodsFor: 'double dispatch' stamp: ''!
syntaxRegex: regexNode
	"All prefixes of the regex's branches should be combined.
	Therefore, just recurse."

	regexNode branch dispatchTo: self.
	regexNode regex notNil
		ifTrue: [regexNode regex dispatchTo: self]! !

!RxMatcher commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
This is a recursive regex matcher. Not strikingly efficient, but simple. Also, keeps track of matched subexpressions.  The life cycle goes as follows:

1. Initialization. Accepts a syntax tree (presumably produced by RxParser) and compiles it into a matcher built of other classes in this category.

2. Matching. Accepts a stream or a string and returns a boolean indicating whether the whole stream or its prefix -- depending on the message sent -- matches the regex.

3. Subexpression query. After a successful match, and before any other match, the matcher may be queried about the range of specific stream (string) positions that matched to certain parenthesized subexpressions of the original expression.

Any number of queries may follow a successful match, and any number or matches may follow a successful initialization.

Note that `matcher' is actually a sort of a misnomer. The actual matcher is a web of Rxm* instances built by RxMatcher during initialization. RxMatcher is just the interface facade of this network.  It is also a builder of it, and also provides a stream-like protocol to easily access the stream being matched.

Instance variables:
	matcher				<RxmLink> The entry point into the actual matcher.
	stream				<Stream> The stream currently being matched against.
	markerPositions		<Array of: Integer> Positions of markers' matches.
	markerCount		<Integer> Number of markers.
	lastResult 			<Boolean> Whether the latest match attempt succeeded or not.
	lastChar			<Character | nil> character last seen in the matcher stream!
!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxWordBoundary
	"Double dispatch from the syntax tree. 
	Create a matcher for the word boundary condition."

	^RxmSpecial new beWordBoundary! !

!RxMatcher methodsFor: 'privileged' stamp: ''!
currentState
	"Answer an opaque object that can later be used to restore the
	matcher's state (for backtracking)"
	
	| origPosition origMarkerPositions |
	
	origPosition := stream position.
	origMarkerPositions := markerPositions collect: [ :collection | collection copy ].
	^[ stream position: origPosition.
		markerPositions := origMarkerPositions ]! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
subEnd: subIndex

	^markerPositions at: subIndex * 2! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxPiece: pieceNode
	"Double dispatch from the syntax tree. 
	Piece is an atom repeated a few times. Take care of a special
	case when the atom is repeated just once."

	| atom |
	atom := pieceNode atom dispatchTo: self.
	^pieceNode isSingular
		ifTrue: [atom]
		ifFalse: [pieceNode isStar
			ifTrue: [self makeStar: atom]
			ifFalse: [pieceNode isPlus
				ifTrue: [self makePlus: atom]
				ifFalse: [pieceNode isOptional
					ifTrue: [self makeOptional: atom]
					ifFalse: [self makeQuantified: atom min: pieceNode min max: pieceNode max]]]]! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
matchesIn: aString do: aBlock
	"Search aString repeatedly for the matches of the receiver.
	Evaluate aBlock for each match passing the matched substring
	as the argument."

	self
		matchesOnStream: aString readStream
		do: aBlock! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxEpsilon
	"Double dispatch from the syntax tree. Match empty string. This is unlikely
	to happen in sane expressions, so we'll live without special epsilon-nodes."

	^RxmSubstring new
		substring: String new
		ignoreCase: ignoreCase! !

!RxMatcher methodsFor: 'testing' stamp: ''!
atEndOfWord

	^(self isWordChar: self lastChar)
		and: [(self isWordChar: stream peek) not]! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxNonWordBoundary
	"Double dispatch from the syntax tree. 
	Create a matcher for the word boundary condition."

	^RxmSpecial new beNotWordBoundary! !

!RxMatcher methodsFor: 'private' stamp: ''!
isWordChar: aCharacterOrNil
	"Answer whether the argument is a word constituent character:
	alphanumeric or _."

	^aCharacterOrNil ~~ nil
		and: [aCharacterOrNil isAlphaNumeric]! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxCharSet: charSetNode
	"Double dispatch from the syntax tree. 
	A character set is a few characters, and we either match any of them,
	or match any that is not one of them."

	^RxmPredicate with: (charSetNode predicateIgnoringCase: ignoreCase)! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
copy: aString translatingMatchesUsing: aBlock
	"Copy <aString>, except for the matches. For each match, evaluate <aBlock> passing the matched substring as the argument.  Expect the block to answer a String, and replace the match with the answer."

	| answer |
	answer := (String new: 40) writeStream.
	self copyStream: aString readStream to: answer translatingMatchesUsing: aBlock.
	^answer contents! !

!RxMatcher methodsFor: 'testing' stamp: ''!
atBeginningOfWord

	^(self isWordChar: self lastChar) not
		and: [self isWordChar: stream peek]! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
subBeginning: subIndex

	^markerPositions at: subIndex * 2 - 1! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
subexpressions: subIndex
	"Answer an array of all matches of the subexpression at the given index.
	The answer is always an array; it is empty if there are no matches."

	| originalPosition startPositions stopPositions reply |
	originalPosition := stream position.
	startPositions := self subBeginning: subIndex.
	stopPositions := self subEnd: subIndex.
	(startPositions isEmpty or: [stopPositions isEmpty]) ifTrue: [^Array new].
	reply := OrderedCollection new.
	startPositions with: stopPositions do:
		[:start :stop |
		stream position: start.
		reply add: (stream next: stop - start)].
	stream position: originalPosition.
	^reply asArray! !

!RxMatcher methodsFor: 'streaming' stamp: ''!
atEnd

	^stream atEnd! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
matchesIn: aString
	"Search aString repeatedly for the matches of the receiver.  Answer an OrderedCollection of all matches (substrings)."

	| result |
	result := OrderedCollection new.
	self
		matchesOnStream: aString readStream
		do: [:match | result add: match].
	^result! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxBeginningOfLine
	"Double dispatch from the syntax tree. 
	Create a matcher for beginning-of-line condition."

	^RxmSpecial new beBeginningOfLine! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxBeginningOfWord
	"Double dispatch from the syntax tree. 
	Create a matcher for beginning-of-word condition."

	^RxmSpecial new beBeginningOfWord! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
matchesOnStream: aStream do: aBlock
	"Be extra careful about successful matches which consume no input.
	After those, make sure to advance or finish if already at end."

	| position subexpression |
	[
		position := aStream position.
		self searchStream: aStream
	] whileTrue: [
		subexpression := self subexpression: 1.
		aBlock value: subexpression.
		subexpression size = 0 ifTrue: [
			aStream atEnd
				ifTrue: [^self]
				ifFalse: [aStream next]]]! !

!RxMatcher methodsFor: 'testing' stamp: ''!
atWordBoundary

	^(self isWordChar: self lastChar)
		xor: (self isWordChar: stream peek)! !

!RxMatcher methodsFor: 'private' stamp: ''!
makePlus: aMatcher
	"Private - Wrap this matcher so that the result would match 1 and more
	occurrences of the matcher."

	| loopback |
	loopback := (RxmBranch new beLoopback)
		next: aMatcher.
	aMatcher pointTailTo: loopback.
	^aMatcher! !

!RxMatcher methodsFor: 'streaming' stamp: ''!
next
	^ stream next! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
subexpressionCount

	^markerCount // 2! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxBranch: branchNode

	"Double dispatch from the syntax tree. 
	Branch node is a link in a chain of concatenated pieces.
	First build the matcher for the rest of the chain, then make 
	it for the current piece and hook the rest to it."

	| result next rest |

	branchNode branch ifNil: [ ^ branchNode piece dispatchTo: self ].	"Optimization: glue a sequence of individual characters into a single string to match."
	branchNode piece isAtomic
		ifTrue: [ result := ( String new: 40 ) writeStream.
			next := branchNode tryMergingInto: result.
			result := result contents.
			result size > 1
				ifTrue: [ "worth merging"
					rest := next notNil
						ifTrue: [ next dispatchTo: self ]
						ifFalse: [ nil ].
					^ ( RxmSubstring new substring: result ignoreCase: ignoreCase )
						pointTailTo: rest;
						yourself
					]
			].	"No optimization possible or worth it, just concatenate all. "
	^ ( branchNode piece dispatchTo: self )
		pointTailTo: ( branchNode branch dispatchTo: self );
		yourself! !

!RxMatcher methodsFor: 'private' stamp: ''!
hookBranchOf: regexNode onto: endMarker
	"Private - Recurse down the chain of regexes starting at
	regexNode, compiling their branches and hooking their tails 
	to the endMarker node."

	| rest |
	rest := regexNode regex ifNotNil: [ self hookBranchOf: regexNode regex onto: endMarker ].
	^ RxmBranch new
		next:
			((regexNode branch dispatchTo: self)
				pointTailTo: endMarker;
				yourself);
		alternative: rest;
		yourself! !

!RxMatcher methodsFor: 'private' stamp: ''!
makeOptional: aMatcher
	"Private - Wrap this matcher so that the result would match 0 or 1
	occurrences of the matcher."

	| dummy branch |
	dummy := RxmLink new.
	branch := (RxmBranch new beLoopback)
		next: aMatcher;
		alternative: dummy.
	aMatcher pointTailTo: dummy.
	^branch! !

!RxMatcher methodsFor: 'private' stamp: ''!
proceedSearchingStream: aStream

	| position |
	position := aStream position.
	[aStream atEnd] whileFalse:
		[self tryMatch ifTrue: [^true].
		aStream position: position; next.
		position := aStream position].
	"Try match at the very stream end too!!"
	self tryMatch ifTrue: [^true]. 
	^false! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
matches: aString
	"Match against a string. Return true if the complete String matches.
	If you want to search for occurrences anywhere in the String see #search:"

	^self matchesStream: aString readStream! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
matchesPrefix: aString
	"Match against a string. Return true if a prefix matches.
	If you want to match 
		- the full string use #matches:
		- anywhere in the string use #search:"

	^self matchesStreamPrefix: aString readStream! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
subexpression: subIndex
	"Answer a string that matched the subexpression at the given index.
	If there are multiple matches, answer the last one.
	If there are no matches, answer nil. 
	(NB: it used to answer an empty string but I think nil makes more sense)."

	| matches |
	matches := self subexpressions: subIndex.
	^matches isEmpty ifTrue: [nil] ifFalse: [matches last]! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
matchesIn: aString collect: aBlock
	"Search aString repeatedly for the matches of the receiver.  Evaluate aBlock for each match passing the matched substring as the argument, collect evaluation results in an OrderedCollection, and return in. The following example shows how to use this message to split a string into words."
	"'\w+' asRegex matchesIn: 'Now is the Time' collect: [:each | each asLowercase]"

	| result |
	result := OrderedCollection new.
	self
		matchesOnStream: aString readStream
		do: [:match | result add: (aBlock value: match)].
	^result! !

!RxMatcher methodsFor: 'private' stamp: ''!
tryMatch

	"Match thyself against the current stream."

	| oldMarkerPositions |

	oldMarkerPositions := markerPositions.
	markerPositions := Array new: markerCount.
	1 to: markerCount do: [ :i | markerPositions at: i put: OrderedCollection new ].
	lastResult := startOptimizer
		ifNil: [ matcher matchAgainst: self ]
		ifNotNil: [ ( startOptimizer canStartMatch: stream peek in: self ) and: [ matcher matchAgainst: self ] ].	"check for duplicates"
	( lastResult not
		or: [ oldMarkerPositions isNil or: [ oldMarkerPositions size ~= markerPositions size ] ] )
		ifTrue: [ ^ lastResult ].
	oldMarkerPositions
		with: markerPositions
		do: [ :oldPos :newPos | 
			oldPos size = newPos size
				ifFalse: [ ^ lastResult ].
			oldPos
				with: newPos
				do: [ :old :new | 
					old = new
						ifFalse: [ ^ lastResult ]
					]
			].	"this is a duplicate"
	^ lastResult := false! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
copyStream: aStream to: writeStream replacingMatchesWith: aString
	"Copy the contents of <aStream> on the <writeStream>, except for the matches. Replace each match with <aString>."

	| searchStart matchStart matchEnd |
	stream := aStream.
	markerPositions := nil.
	[searchStart := aStream position.
	self proceedSearchingStream: aStream] whileTrue:
		[matchStart := (self subBeginning: 1) first.
		matchEnd := (self subEnd: 1) first.
		aStream position: searchStart.
		searchStart to: matchStart - 1 do:
			[:ignoredPos | writeStream nextPut: aStream next].
		writeStream nextPutAll: aString.
		aStream position: matchEnd.
		"Be extra careful about successful matches which consume no input.
		After those, make sure to advance or finish if already at end."
		matchEnd = searchStart ifTrue: 
			[aStream atEnd
				ifTrue:	[^self "rest after end of whileTrue: block is a no-op if atEnd"]
				ifFalse:	[writeStream nextPut: aStream next]]].
	aStream position: searchStart.
	[aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
copyStream: aStream to: writeStream translatingMatchesUsing: aBlock
	"Copy the contents of <aStream> on the <writeStream>, except for the matches. For each match, evaluate <aBlock> passing the matched substring as the argument.  Expect the block to answer a String, and write the answer to <writeStream> in place of the match."

	| searchStart matchStart matchEnd match |
	stream := aStream.	
	markerPositions := nil.
	[searchStart := aStream position.
	self proceedSearchingStream: aStream] whileTrue:
		[matchStart := (self subBeginning: 1) first.
		matchEnd := (self subEnd: 1) first.
		aStream position: searchStart.
		searchStart to: matchStart - 1 do:
			[:ignoredPos | writeStream nextPut: aStream next].
		match := (String new: matchEnd - matchStart + 1) writeStream.
		matchStart to: matchEnd - 1 do:
			[:ignoredPos | match nextPut: aStream next].
		writeStream nextPutAll: (aBlock value: match contents).
		"Be extra careful about successful matches which consume no input.
		After those, make sure to advance or finish if already at end."
		matchEnd = searchStart ifTrue: 
			[aStream atEnd
				ifTrue:	[^self "rest after end of whileTrue: block is a no-op if atEnd"]
				ifFalse:	[writeStream nextPut: aStream next]]].
	aStream position: searchStart.
	[aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxEndOfWord
	"Double dispatch from the syntax tree. 
	Create a matcher for end-of-word condition."

	^RxmSpecial new beEndOfWord! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
matchingRangesIn: aString
	"Search aString repeatedly for the matches of the receiver.  Answer an OrderedCollection of ranges of each match (index of first character to: index of last character)."

	| result |
	result := OrderedCollection new.
	self
		matchesIn: aString 
		do: [:match | result add: (self position - match size + 1 to: self position)].
	^result! !

!RxMatcher methodsFor: 'testing' stamp: ''!
atEndOfLine

	^self atEnd or: [stream peek = Cr]! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxPredicate: predicateNode
	"Double dispatch from the syntax tree. 
	A character set is a few characters, and we either match any of them,
	or match any that is not one of them."

	^RxmPredicate with: predicateNode predicate! !

!RxMatcher methodsFor: 'streaming' stamp: ''!
position

	^stream position! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxRegex: regexNode
	"Double dispatch from the syntax tree. 
	Regex node is a chain of branches to be tried. Should compile this 
	into a bundle of parallel branches, between two marker nodes." 
	
	| startIndex endIndex endNode alternatives |
	startIndex := self allocateMarker.
	endIndex := self allocateMarker.
	endNode := RxmMarker new index: endIndex.
	alternatives := self hookBranchOf: regexNode onto: endNode.
	^(RxmMarker new index: startIndex)
		pointTailTo: alternatives;
		yourself! !

!RxMatcher methodsFor: 'splitjoin' stamp: ''!
split: aString indicesDo: aBlock
	| lastPosition |

	stream := aString readStream.
	lastPosition := stream position.
	
	[ self searchStream: stream ] whileTrue: [ 
		aBlock value: lastPosition+1 value: (self subBeginning: 1) first.
		[ lastPosition < stream position ] assertWithDescription: 'Regex cannot match null string'.
		lastPosition := stream position ].
	
	aBlock value: lastPosition + 1 value: aString size.! !

!RxMatcher methodsFor: 'testing' stamp: ''!
supportsSubexpressions

	^true! !

!RxMatcher methodsFor: 'private' stamp: ''!
makeStar: aMatcher
	"Private - Wrap this matcher so that the result would match 0 and more
	occurrences of the matcher."

	| dummy detour loopback |
	dummy := RxmLink new.
	detour := RxmBranch new
		next: aMatcher;
		alternative: dummy.
	loopback := (RxmBranch new beLoopback)
		next: aMatcher;
		alternative: dummy.
	aMatcher pointTailTo: loopback.
	^detour! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
matchesStreamPrefix: theStream
	"Match thyself against a positionable stream."

	stream := theStream.
	markerPositions := nil.
	^self tryMatch! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxMessagePredicate: messagePredicateNode
	"Double dispatch from the syntax tree. 
	Special link can handle predicates."

	^messagePredicateNode negated
		ifTrue: [RxmPredicate new bePerformNot: messagePredicateNode selector]
		ifFalse: [RxmPredicate new bePerform: messagePredicateNode selector]! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxAny
	"Double dispatch from the syntax tree. 
	Create a matcher for any non-null character."

	^RxmPredicate new
		predicate: [:char | char asInteger ~= 0]! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
copy: aString replacingMatchesWith: replacementString
	"Copy <aString>, except for the matches. Replace each match with <aString>."

	| answer |
	answer := (String new: 40) writeStream.
	self
		copyStream: aString readStream
		to: answer
		replacingMatchesWith: replacementString.
	^answer contents! !

!RxMatcher methodsFor: 'testing' stamp: ''!
atBeginningOfLine

	^self position = 0 or: [self lastChar = Cr]! !

!RxMatcher methodsFor: 'privileged' stamp: ''!
markerPositionAt: anIndex add: position
	"Remember position of another instance of the given marker."

	(markerPositions at: anIndex) addFirst: position! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
buildFrom: aSyntaxTreeRoot
	"Private - Entry point of matcher build process."

	markerCount := 0.  "must go before #dispatchTo: !!"
	matcher := aSyntaxTreeRoot dispatchTo: self.
	matcher terminateWith: RxmTerminator new! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxLookaround: lookaroundNode
	"Double dispatch from the syntax tree. 
	Special link can handle lookarounds (look ahead, positive and negative)."
	| piece |
	piece := lookaroundNode piece dispatchTo: self.
	^ RxmLookahaed with: piece! !

!RxMatcher methodsFor: 'testing' stamp: ''!
notAtWordBoundary

	^self atWordBoundary not! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxCharacter: charNode
	"Double dispatch from the syntax tree. 
	We get here when no merging characters into strings was possible."

	| wanted |
	wanted := charNode character.
	^RxmPredicate new predicate: 
		(ignoreCase
			ifTrue: [[:char | char sameAs: wanted]]
			ifFalse: [[:char | char = wanted]])! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
matchesOnStream: aStream

	| result |
	result := OrderedCollection new.
	self
		matchesOnStream: aStream
		do: [:match | result add: match].
	^result! !

!RxMatcher methodsFor: 'double dispatch' stamp: ''!
syntaxEndOfLine
	"Double dispatch from the syntax tree. 
	Create a matcher for end-of-line condition."

	^RxmSpecial new beEndOfLine! !

!RxMatcher methodsFor: 'privileged' stamp: ''!
restoreState: aBlock

	aBlock value! !

!RxMatcher methodsFor: 'initialization' stamp: ''!
initialize: syntaxTreeRoot ignoreCase: aBoolean
	"Compile thyself for the regex with the specified syntax tree.
	See comment and `building' protocol in this class and 
	#dispatchTo: methods in syntax tree components for details 
	on double-dispatch building. 
	The argument is supposedly a RxsRegex."

	ignoreCase := aBoolean.
	self buildFrom: syntaxTreeRoot.
	startOptimizer := RxMatchOptimizer new initialize: syntaxTreeRoot ignoreCase: aBoolean! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
search: aString
	"Search anywhere in the String for occurrence of something matching myself.
	If you want to match the full String see #matches:
	Answer a Boolean indicating success."

	^self searchStream: aString readStream! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
searchStream: aStream
	"Search the stream for occurrence of something matching myself.
	After the search has occurred, stop positioned after the end of the
	matched substring. Answer a Boolean indicating success."

	| position |
	stream := aStream.
	position := aStream position.
	markerPositions := nil.
	[aStream atEnd] whileFalse:
		[self tryMatch ifTrue: [^true].
		aStream position: position; next.
		position := aStream position].
	"Try match at the very stream end too!!"
	self tryMatch ifTrue: [^true]. 
	^false! !

!RxMatcher methodsFor: 'private' stamp: ''!
allocateMarker
	"Answer an integer to use as an index of the next marker."

	markerCount := markerCount + 1.
	^markerCount! !

!RxMatcher methodsFor: 'private' stamp: ''!
makeQuantified: anRxmLink min: min max: max 
	"Perform recursive poor-man's transformation of the {<min>,<max>} quantifiers."
	| aMatcher |
	
	"<atom>{,<max>}       ==>  (<atom>{1,<max>})?"
	min = 0 ifTrue: [ 
		^ self makeOptional: (self makeQuantified: anRxmLink min: 1 max: max) ].
	
	"<atom>{<min>,}       ==>  <atom>{<min>-1, <min>-1}<atom>+"
	max ifNil: [
		^ (self makeQuantified: anRxmLink min: 1 max: min-1) pointTailTo: (self makePlus: anRxmLink copy) ].
	
	"<atom>{<max>,<max>}  ==>  <atom><atom> ... <atom>"
	min = max 
		ifTrue: [ 
			aMatcher := anRxmLink copy.
			(min-1) timesRepeat: [ aMatcher pointTailTo: anRxmLink copy ].
			^ aMatcher ].

	"<atom>{<min>,<max>}  ==>  <atom>{<min>,<min>}(<atom>{1,<max>-1})?"
	aMatcher := self makeOptional: anRxmLink copy.
	(max - min - 1) timesRepeat: [ 
		 aMatcher := self makeOptional: (anRxmLink copy pointTailTo: aMatcher) ].
	^ (self makeQuantified: anRxmLink min: min max: min) pointTailTo: aMatcher! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
lastChar
	^ stream position = 0
		ifFalse: [ stream skip: -1; next ]! !

!RxMatcher methodsFor: 'match enumeration' stamp: ''!
matchesOnStream: aStream collect: aBlock

	| result |
	result := OrderedCollection new.
	self
		matchesOnStream: aStream
		do: [:match | result add: (aBlock value: match)].
	^result! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
matchesStream: theStream
	"Match thyself against a positionable stream."

	^(self matchesStreamPrefix: theStream)
		and: [stream atEnd]! !

!RxMatcher methodsFor: 'accessing' stamp: ''!
lastResult

	^lastResult! !

!RxMatcher class methodsFor: 'instance creation' stamp: ''!
for: aRegex ignoreCase: aBoolean
	"Create and answer a matcher that will match a regular expression
	specified by the syntax tree of which `aRegex' is a root."

	^self new
		initialize: aRegex
		ignoreCase: aBoolean! !

!RxMatcher class methodsFor: 'class initialization' stamp: ''!
initialize
	"RxMatcher initialize"
	Cr := Character cr.
	Lf := Character lf.! !

!RxMatcher class methodsFor: 'instance creation' stamp: ''!
for: aRegex
	"Create and answer a matcher that will match a regular expression
	specified by the syntax tree of which `aRegex' is a root."

	^self for: aRegex ignoreCase: false! !

!RxMatcher class methodsFor: 'instance creation' stamp: ''!
forString: aString
	"Create and answer a matcher that will match the regular expression
	`aString'."

	^self for: (RxParser new parse: aString)! !

!RxMatcher class methodsFor: 'instance creation' stamp: ''!
forString: aString ignoreCase: aBoolean
	"Create and answer a matcher that will match the regular expression
	`aString'."

	^self for: (RxParser new parse: aString) ignoreCase: aBoolean! !

!RxMatcherTest commentStamp: ''!
This class provides tests for the regular expression matcher.!
!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry018
	self runRegex: #('a\s*c'
		'a   c' true (1 'a   c')
		'a bc' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry053
	self runRegex: #('[\s]+'
		'2  spaces' true (1 '  '))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry095
	self runRegex: #('[^ab]*'
		'cde' true (1 'cde'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry107
	self runRegex: #('(a|b|c|d|e)f'
		'ef' true (1 'ef' 2 'e'))
	"	((a*|b))*	-	c	-	-"! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringCopyWithRegexMatchesReplacedWith

	self assert: ('aabbcc' copyWithRegex: 'b+' matchesReplacedWith: 'X') equals: 'aaXcc'! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testCopyReplacingMatches
	"See that the match context is preserved while copying stuff between matches:"
	
	| matcher |
	matcher := self matcherClass forString: '\<\d\D+'.
	self 
		assert: (matcher copy: '9aaa1bbb 8ccc' replacingMatchesWith: 'foo') equals: 'foo1bbb foo'! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry040
	self runRegex: #('[k]'
		'ab' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry101
	self runRegex: #('a*'
		'' true '')! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry010
	self runRegex: #('$'
		'abc' true nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry051
	self runRegex: #('[\D]+'
		'123abc45def78' true (1 'abc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry120
	self runRegex: #('a[bcd]*dcdcde' 'adcdcde' true (1 'adcdcde'))
	! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testCaseSensitive
	| matcher |
	matcher := self matcherClass forString: 'the quick brown fox' ignoreCase: false.
	self assert: (matcher search: 'the quick brown fox').
	self deny: (matcher search: 'The quick brown FOX').
	self assert: (matcher search: 'What do you know about the quick brown fox?').
	self deny: (matcher search: 'What do you know about THE QUICK BROWN FOX?')! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry070
	self runRegex: #('()ef'
		'def' true (1 'ef' 2 ''))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry087
	self runRegex: #('a*?' nil)! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testMatchingRangesIn
	| matcher expected |
	matcher := self matcherClass forString: '\w+'.
	expected := #(1 3 5 6 8 10 12 15) asOrderedCollection.
	(matcher matchingRangesIn: 'now is the time')
		do: [ :range | 
			self assert: range first equals: expected removeFirst.
			self assert: range last equals: expected removeFirst ].
	self assertEmpty: expected! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry002
	self runRegex: #('ab*c'
		'abc' true (1 'abc'))! !

!RxMatcherTest methodsFor: 'tests' stamp: ''!
testRegex001
	self runRegex: #('^.*$' 
		'' true (1 '')
		'a' true (1 'a')
		'abc' true (1 'abc'))! !

!RxMatcherTest methodsFor: 'tests - empty' stamp: ''!
testEmptyStringAtBeginningOfLine
	| matcher |
	matcher := self matcherClass forString: '^'.
	self
		assert: (matcher copy: 'foo1 bar1' , String cr , 'foo2 bar2' replacingMatchesWith: '*')
			= ('*foo1 bar1' , String cr , '*foo2 bar2')
		description: 'An empty string at the beginning of a line'! !

!RxMatcherTest methodsFor: 'tests' stamp: ''!
testRegex002
	self runRegex: #('a\w+c'
		' abb_bbc ' true (1 'abb_bbc')
		'abb-bc' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
henryReadme
	self error: 'The tests in this category are based on the ones in Henry Spencer''s regexp.c package.'! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testMatchesOnStreamCollect
	| matcher |
	matcher := self matcherClass forString: '\w+'.
	self assert: (matcher matchesOnStream: 'now is the time' readStream collect: [ :each | each reversed ]) asArray equals: #('won' 'si' 'eht' 'emit')! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry064
	self runRegex: #('[^[:space:]]+'
		'  word12!!@#$  ' true (1 'word12!!@#$'))! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testCopyTranslatingMatches
	| matcher |
	matcher := self matcherClass forString: '\w+'.
	self assert: (matcher copy: 'now is  the   time    ' translatingMatchesUsing: [ :each | each reversed ]) equals: 'won si  eht   emit    '! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry013
	self runRegex: #('.a.*'
		'1234abc' true (1 '4abc')
		'abcd' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry020
	self runRegex: #('a\S*c'
		'aqwertyc' true (1 'aqwertyc')
		'ab c' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry079
	self runRegex: #('a\(*b'
		'ab' true (1 'ab')
		'a((b' true (1 'a((b'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry060
	self runRegex: #('[[:cntrl:]]+'
		' a 1234asdf' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry054
	self runRegex: #('[\S]+'
		'  word12!!@#$  ' true (1 'word12!!@#$'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry091
	self runRegex: #('(a*|b)*' nil)! !

!RxMatcherTest methodsFor: 'utilties' stamp: ''!
runRegex: anArray

	"Run a clause anArray against a set of tests. Each clause is an array with a regex source string followed by sequence of 3-tuples. Each three-element group is one test to try against the regex, and includes: 1) test string; 2) expected result; 3) expected subexpression as an array of (index, substring), or nil."

	| source matcher |

	source := anArray first.
	matcher := self compileRegex: source.
	matcher
		ifNil: [ ( anArray at: 2 )
				ifNotNil: [ self signalFailure: 'Compilation failed, should have succeeded: ' , source printString ]
			]
		ifNotNil: [ ( anArray at: 2 )
				ifNil: [ self signalFailure: 'Compilation succeeded, should have failed: ' , source printString ]
				ifNotNil: [ 2 to: anArray size by: 3 do: [ :index | 
						self
							runMatcher: matcher
							with: ( anArray at: index )
							expect: ( anArray at: index + 1 )
							withSubexpressions: ( anArray at: index + 2 )
						]
					]
			]! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry061
	self runRegex: #('[[:lower:]]+'
		'UPPERlower1234' true (1 'lower')
		'lowerUPPER' true (1 'lower'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry100
	self runRegex: #('abc' '' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry009
	self runRegex: #('^'
		'abc' true nil)! !

!RxMatcherTest methodsFor: 'tests' stamp: ''!
testRegex003
	self runRegex: #('a\W+c'
		' abb_bbc ' false nil
		'abb-bc' false nil
		'a.,:;-&!!"#%/()={[]}+?\~*''c' true (1 'a.,:;-&!!"#%/()={[]}+?\~*''c'))! !

!RxMatcherTest methodsFor: 'tests' stamp: ''!
testRegex004
	self runRegex: #(':isVowel:'
		'aei' true nil
		'xyz' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry033
	self runRegex: #('.+\<foo'
		'foo' false nil
		'ab foo' true (1 'ab foo')
		'abfoo' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry109
	self runRegex: #('ab*' 
		'xabyabbbz' true (1 'ab')
		'xayabbbz' true (1 'a'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry035
	self runRegex: #('a[b-d]e'
		'abd' false nil
		'ace' true (1 'ace'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry008
	self runRegex: #('abc$'
		'aabc' true (1 'abc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry057
	self runRegex: #('[^[:alnum:]]+'
		'fii234!!@#$34f' true (1 '!!@#$'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry081
	self runRegex: #('abc)' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry071
	self runRegex: #('()*' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry126
	self runRegex: #('[ -~ -~ -~]*' 'abc' true (1 'abc'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry088
	self runRegex: #('(a*)*' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry105
	self runRegex: #('([abc])*bcd'
		'abcd' true (1 'abcd' 2 'a'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry038
	self runRegex: #('a[b-]'
		'a-' true (1 'a-'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry129
	self runRegex: #('[ -~ -~ -~ -~ -~ -~]*' 'abc' true (1 'abc'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry131
	self runRegex: #('[a-zA-Z_][a-zA-Z0-9_]*' 'alpha' true (1 'alpha'))
	! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringPrefixMatchesRegex
	self assert: ('aabbcc' prefixMatchesRegex: 'a+').
	self deny: ('aabbcc' prefixMatchesRegex: 'b+')! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testMatchesInDo
	| matcher expected |
	matcher := self matcherClass forString: '\w+'.
	expected := #('now' 'is' 'the' 'time') asOrderedCollection.
	matcher matchesIn: 'now is the time' do: [ :each | self assert: each equals: expected removeFirst ].
	self assertEmpty: expected! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringMatchesRegexIgnoringCase
	self deny: ('AABBCC' matchesRegexIgnoringCase: 'a+').
	self deny: ('AABBCC' matchesRegexIgnoringCase: 'b+c+').
	self assert: ('AABBCC' matchesRegexIgnoringCase: 'a+b+c+')! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry063
	self runRegex: #('[[:space:]]+'
		'2  spaces' true (1 '  '))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry021
	self runRegex: #('\S+'
		'     	asdf		' true (1 'asdf')
		' 	
			' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry075
	self runRegex: #('(*)b' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry032
	self runRegex: #('\<foo.*'
		'foo' true nil
		'foobar' true nil
		'qfoobarq foonix' true (1 'foonix')
		' foo' true nil
		' 12foo' false nil
		'barfoo' false nil)! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringAllRegexMatches
	| result |
	result := 'aabbcc' allRegexMatches: 'b+'.
	self 
		assert: result size equals: 1;
		assert: result first equals: 'bb'! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry110
	self runRegex: #('(ab|cd)e' 'abcde' true (1 'cde' 2 'cd'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry130
	self runRegex: #('[ -~ -~ -~ -~ -~ -~ -~]*' 'abc' true (1 'abc'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry028
	self runRegex: #('(f|o)+\B'
		'quuxfoobar' true (1 'foo')
		'quuxfoo ' true (1 'fo'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry022
	self runRegex: #('a\d+c'
		'a0123456789c' true (1 'a0123456789c')
		'a12b34c' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry069
	self runRegex: #('ab|cd'
		'abc' true (1 'ab')
		'abcd' true (1 'ab'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry112
	self runRegex: #('^(ab|cd)e' 'abcde' false nil)
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry068
	self runRegex: #('[[:xdigit:]]+'
		'  x10FCD  ' true (1 '10FCD')
		' hgfedcba0123456789ABCDEFGH '
			true (1 'fedcba0123456789ABCDEF'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry019
	self runRegex: #('\s+'
		'abc3457 sd' true (1 ' ')
		'1234$^*^&asdfb' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry108
	self runRegex: #('abcd*efg' 
		'abcdefg' true (1 'abcdefg'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry117
	self runRegex: #('a([bc]*)(c*d)' 'abcd' true (1 'abcd' 2 'bc' 3 'd'))
	! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testMatchesStream
	| matcher |
	matcher := self matcherClass forString: '\w+'.
	self assert: (matcher matchesStream: 'now' readStream).
	self deny: (matcher matchesStream: 'now is' readStream)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry055
	self runRegex: #('[\w]+'
		' 	foo123bar	45' true (1 'foo123bar'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry122
	self runRegex: #('(ab|a)b*c' 'abc' true (1 'abc'))
	! !

!RxMatcherTest methodsFor: 'tests' stamp: ''!
testStringGreedyMatchesRegex

	self assert: ('199' matchesRegex: '([0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])').
	self assert: ('25' matchesRegex: '([0-9]|[1-9][0-9])').
	self assert: ('25' matchesRegex: '([1-9][0-9]|[0-9])').
	self assert: ('25' matchesRegex: '(\d\d|\d)').
	self assert: ('25' matchesRegex: '(\d|\d\d)').
	self assert: ('bb' matchesRegex: '([a-z]|[b-z][a-z])').
	self assert: ('b' matchesRegex: '([b-z][a-z]|[a-z])').
	self assert: ('15' matchesRegex: '[1-9]|1[0-9]').
	self assert: ('b' matchesRegex: '(b|bb)').
	self assert: ('b' matchesRegex: '(bb|b)').
	self assert: ('fooABCD' matchesRegex: '.*(ABCD|BC)').
	self assert: ('fooBC' matchesRegex: '.*(ABCD|BC)').
	self assert: ('fooB' matchesRegex: '.*(ABC|B)').
	self assert: ('fooABC' matchesRegex: '.*(ABC|B)').	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry094
	self runRegex: #('(a+|b)?'
		'ab' true (1 'a' 2 'a'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry056
	self runRegex: #('[\W]+'
		'fii234!!@#$34f' true (1 '!!@#$'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry114
	self runRegex: #('(a|b)c*d' 'abcd' true (1 'bcd' 2 'b'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry115
	self runRegex: #('(ab|ab*)bc' 'abc' true (1 'abc' 2 'a'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry006
	self runRegex: #('^abc$'
		'abc' true (1 'abc')
		'abcc' false nil
		'aabc' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry136
	self runRegex: #('(.*)c(.*)' 'abcde' true (1 'abcde' 2 'ab' 3 'de'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry047
	self runRegex: #('a[^-b]c'
		'adc' true (1 'adc')
		'a-c' false nil)! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testSubexpressionCount
	| matcher |
	#(('a' 1) ('a(b)' 2) ('a(b(c))' 3) ('(a)(b)' 3) ('(a(b))*' 3)) do: [ :pair |
		matcher := self matcherClass forString: pair first.
		matcher supportsSubexpressions 
			ifTrue: [ self assert: matcher subexpressionCount equals: pair last ] ]! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry059
	self runRegex: #('[[:alpha:]]+'
		' 123foo3 ' true (1 'foo')
		'123foo' true (1 'foo')
		'foo1b' true (1 'foo'))! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringRegexMatchesCollect
	| result |
	result := 'aabbcc' regex: 'b+' matchesCollect: [ :each | each asUppercase ].
	self 
		assert: result size equals: 1;
		assert: result first equals: 'BB'! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry106
	self runRegex: #('a|b|c|d|e' 'e' true (1 'e'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry029
	self runRegex: #('\Ba\w+' "a word with an A in the middle, match at A and further"
		'land ancient' true (1 'and')
		'antique vase' true (1 'ase')
		'smalltalk shall overcome' true (1 'alltalk')
		'foonix is better' false nil)! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringMatchesRegex
	self deny: ('aabbcc' matchesRegex: 'a+').
	self deny: ('aabbcc' matchesRegex: 'b+c+').
	self assert: ('aabbcc' matchesRegex: 'a+b+c+')! !

!RxMatcherTest methodsFor: 'tests - empty' stamp: ''!
testEmptyStringNotAtWordBoundary
	| matcher |
	matcher := self matcherClass forString: '\B'.
	self
		assert: (matcher copy: 'foo bar' replacingMatchesWith: '*')
			= 'f*o*o b*a*r'
		description: 'An empty string not at a word boundary'! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry001
	self runRegex: #('abc'
		'abc' true (1 'abc')
		'xbc' false nil
		'axc' false nil
		'abx' false nil
		'xabcy' true (1 'abc')
		'ababc' true (1 'abc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry077
	self runRegex: #('a\' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry003
	self runRegex: #('ab*bc'
		'abc' true (1 'abc')
		'abbc' true (1 'abbc')
		'abbbbc' true (1 'abbbbc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry025
	self runRegex: #('\D+'
		'1234 abc 456' true (1 ' abc ')
		'1234567890' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry078
	self runRegex: #('a\(b'
		'a(b' true (1 'a(b'))! !

!RxMatcherTest methodsFor: 'tests - empty' stamp: ''!
testEmptyStringAtBeginningOfWord
	| matcher |
	matcher := self matcherClass forString: '\<'.
	self
		assert: (matcher copy: 'foo bar' replacingMatchesWith: '*')
			= '*foo *bar'
		description: 'An empty string at the beginning of a word'! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry098
	self runRegex: #(')(' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry049
	self runRegex: #('[\de]+'
		'01234' true (1 '01234')
		'0123e456' true (1 '0123e456')
		'0123e45g78' true (1 '0123e45'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry039
	self runRegex: #('a[a-b-c]' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry036
	self runRegex: #('a[b-d]'
		'aac' true (1 'ac'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry080
	self runRegex: #('a\\b'
		'a\b' true (1 'a\b'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry073
	self runRegex: #('^*' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry125
	self runRegex: #('[ -~ -~]*' 'abc' true (1 'abc'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry076
	self runRegex: #('$b'	'b' false nil)! !

!RxMatcherTest methodsFor: 'utilties' stamp: ''!
runMatcher: aMatcher with: aString expect: aBoolean withSubexpressions: anArray
	| copy got |
	copy := aMatcher
		copy: aString
		translatingMatchesUsing: [ :each | each ].
	self 
		assert: copy = aString
		description: 'Copying: expected ' , aString printString , ', but got ' , copy printString.
	got := aMatcher search: aString.
	self
		assert: got = aBoolean 
		description: 'Searching: expected ' , aBoolean printString , ', but got ' , got printString.
	(anArray isNil or: [ aMatcher supportsSubexpressions not ])
		ifTrue: [ ^ self ].
	1 to: anArray size by: 2 do: [ :index |
		| sub subExpect subGot |
		sub := anArray at: index.
		subExpect := anArray at: index + 1.
		subGot := aMatcher subexpression: sub.
		self
			assert: subExpect = subGot
			description: 'Subexpression ' , sub printString , ': expected ' , subExpect printString , ', but got ' , subGot printString ]! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry097
	self runRegex: #('(ab|)*' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry090
	self runRegex: #('(a|)*' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry116
	self runRegex: #('a([bc]*)c*' 'abc' true (1 'abc' 2 'bc'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry099
	self runRegex: #('' 'abc' true (1 ''))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry121
	self runRegex: #('a[bcd]+dcdcde' 'adcdcde' false nil)
	! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringAsRegexIgnoringCase

	self assert: 'b+' asRegexIgnoringCase class equals: RxParser preferredMatcherClass! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringRegexMatchesDo
	| result |
	result := OrderedCollection new.
	'aabbcc' regex: 'b+' matchesDo: [ :each | result add: each ].
	self 
		assert: result size equals: 1;
		assert: result first equals: 'bb'! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry135
	self runRegex: #('multiple words of text' 
		'uh-uh' false nil
		'multiple words of text, yeah' true (1 'multiple words of text'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry062
	self runRegex: #('[[:upper:]]+'
		'UPPERlower1234' true (1 'UPPER')
		'lowerUPPER ' true (1 'UPPER'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry024
	self runRegex: #('a\D+c'
		'aqwertyc' true (1 'aqwertyc')
		'aqw6ertc' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry031
	self runRegex: #('\>.+abc'
		' abcde fg' false nil
		'foo abcde' true (1 ' abc')
		'abcde' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry082
	self runRegex: #('(abc' nil)! !

!RxMatcherTest methodsFor: 'accessing' stamp: ''!
matcherClass
	^ RxMatcher! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry043
	self runRegex: #('a[' nil)! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testMatchesOnStream
	| matcher |
	matcher := self matcherClass forString: '\w+'.
	self assert: (matcher matchesOnStream: 'now is the time' readStream) asArray equals: #('now' 'is' 'the' 'time')! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testMatchesOnStreamDo
	| matcher expected |
	matcher := self matcherClass forString: '\w+'.
	expected := #('now' 'is' 'the' 'time') asOrderedCollection.
	matcher matchesOnStream: 'now is the time' readStream do: [ :each | self assert: each equals: expected removeFirst ].
	self assertEmpty: expected! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringAsRegex
	
	self assert: 'b+' asRegex class equals: RxParser preferredMatcherClass! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry104
	self runRegex: #('([abc])*d'
		'abbbcd' true (1 'abbbcd' 2 'c'))! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringPrefixMatchesRegexIgnoringCase
	self assert: ('AABBCC' prefixMatchesRegexIgnoringCase: 'a+').
	self deny: ('AABBCC' prefixMatchesRegexIgnoringCase: 'b+')! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry037
	self runRegex: #('a[-b]'
		'a-' true (1 'a-'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry074
	self runRegex: #('$*' nil)! !

!RxMatcherTest methodsFor: 'utilties' stamp: ''!
compileRegex: aString

	"Compile the regex and answer the matcher, or answer nil if compilation fails."

	| syntaxTree |

	syntaxTree := RxParser safelyParse: aString.
	^ syntaxTree ifNotNil: [ self matcherClass for: syntaxTree ]! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringAllRangesOfRegexMatches
	| result |
	result := 'aabbcc' allRangesOfRegexMatches: 'b+'.
	self 
		assert: result size equals: 1;
		assert: result first first equals: 3;
		assert: result first last equals: 4
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry127
	self runRegex: #('[ -~ -~ -~ -~]*' 'abc' true (1 'abc'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry085
	self runRegex: #('a+b+c'
		'aabbabc' true (1 'abc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry134
	self runRegex: #('(((((((((a)))))))))' 'a' true (1 'a'))! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testMatchesIn
	| matcher |
	matcher := self matcherClass forString: '\w+'.
	self assert: (matcher matchesIn: 'now is the time') asArray equals: #('now' 'is' 'the' 'time')! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry023
	self runRegex: #('\d+'
		'foo@#$%123ASD #$$%^&' true (1 '123')
		'foo!!@#$asdfl;' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry046
	self runRegex: #('a[^bc]d'
		'aed' true (1 'aed')
		'abd' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry066
	self runRegex: #('[[:print:]]+'
		'abc' true (1 'abc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry133
	self runRegex: #('(bc+d$|ef*g.|h?i(j|k))' 
		'effgz' true (1 'effgz' 2 'effgz' 3 nil)
		'ij' true (1 'ij' 2 'ij' 3 'j')
		'effg' false nil
		'bcdd' false nil
		'reffgz' true (1 'effgz' 2 'effgz' 3 nil))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry048
	self runRegex: #('a[^]b]c'
		'a]c' false nil
		'adc' true (1 'adc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry004
	self runRegex: #('ab+bc'	
		'abbc' true (1 'abbc')
		'abc' false nil
		'abq' false nil
		'abbbbc' true (1 'abbbbc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry083
	self runRegex: #('((a))'
		'abc' true (1 'a' 2 'a' 3 'a'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry044
	self runRegex: #('a]' 
		'a]' true (1 'a]'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry128
	self runRegex: #('[ -~ -~ -~ -~ -~]*' 'abc' true (1 'abc'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry058
	self runRegex: #('[%&[:alnum:]]+'
		'foo%3' true (1 'foo%3')
		'foo34&rt4$57a' true (1 'foo34&rt4')
		'!!@#$' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry084
	self runRegex: #('(a)b(c)'
		'abc' true (1 'abc' 2 'a' 3 'c'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry119
	self runRegex: #('a([bc]*)(c+d)' 'abcd' true (1 'abcd' 2 'b' 3 'cd'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry015
	self runRegex: #('\w+'
		'  	foobar	quux' true (1 'foobar')
		' 	~!!@#$%^&*()-+=\|/?.>,<' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry124
	self runRegex: #('[ -~]*' 'abc' true (1 'abc'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry027
	self runRegex: #('\ba\w+' "a word beginning with an A"
		'land ancient' true (1 'ancient')
		'antique vase' true (1 'antique')
		'goofy foobar' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry118
	self runRegex: #('a([bc]+)(c*d)' 'abcd' true (1 'abcd' 2 'bc' 3 'd'))
	! !

!RxMatcherTest methodsFor: 'tests - empty' stamp: ''!
testEmptyStringAtEndOfLine
	| matcher |
	matcher := self matcherClass forString: '$'.
	self
		assert: (matcher copy: 'foo1 bar1' , String cr , 'foo2 bar2' replacingMatchesWith: '*')
			= ('foo1 bar1*', String cr , 'foo2 bar2*')
		description: 'An empty string at the end of a line'! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry030
	self runRegex: #('fooa\>.*'
		'fooa ' true nil
		'fooa123' false nil
		'fooa bar' true nil
		'fooa' true nil
		'fooargh' false nil)! !

!RxMatcherTest methodsFor: 'tests - extensions' stamp: ''!
testStringCopyWithRegexMatchesTranslatedUsing
	self assert: ('aabbcc' 
		copyWithRegex: 'b+' 
		matchesTranslatedUsing: [ :each | 
			self assert: each equals: 'bb'.
			'X' ]) equals: 'aaXcc'! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry050
	self runRegex: #('[e\d]+' "reversal of the above, should be the same"
		'01234' true (1 '01234')
		'0123e456' true (1 '0123e456')
		'0123e45g78' true (1 '0123e45'))! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testCaseInsensitive
	| matcher |
	matcher := self matcherClass forString: 'the quick brown fox' ignoreCase: true.
	self 
		assert: (matcher search: 'the quick brown fox');
		assert: (matcher search: 'The quick brown FOX');
		assert: (matcher search: 'What do you know about the quick brown fox?');
		assert: (matcher search: 'What do you know about THE QUICK BROWN FOX?')! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry045
	self runRegex: #('a[]]b'
		'a]b' true (1 'a]b'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry072
	self runRegex: #('*a' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry111
	self runRegex: #('[abhgefdc]ij' 'hij' true (1 'hij'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry123
	self runRegex: #('((a)(b)c)(d)' 'abcd' true (1 'abcd' 3 'a' 4 'b' 5 'd'))
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry017
	self runRegex: #('\W+'
		'foo!!@#$bar' true (1 '!!@#$')
		'foobar' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry007
	self runRegex: #('^abc'
		'abcc' true (1 'abc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry042
	self runRegex: #('a[]b' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry093
	self runRegex: #('(a+|b)+'
		'ab' true (1 'ab' 2 'b'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry041
	self runRegex: #('a[b-a]' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry102
	self runRegex: #('abcd'
		'abcd' true (1 'abcd'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry065
	self runRegex: #('[[:graph:]]+'
		'abc' true (1 'abc'))! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testMatches
	| matcher |
	matcher := self matcherClass forString: '\w+'.
	self assert: (matcher matches: 'now').
	self deny: (matcher matches: 'now is')! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry014
	self runRegex: #('a\w+c'
		' abbbbc ' true (1 'abbbbc')
		'abb bc' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry067
	self runRegex: #('[^[:punct:]]+'
		'!!hello,world!!' true (1 'hello'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry034
	self runRegex: #('a[bc]d'
		'abc' false nil
		'abd' true (1 'abd'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry089
	self runRegex: #('(a*)+' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry016
	self runRegex: #('a\W+c'
		'a   c' true (1 'a   c')
		'a bc' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry103
	self runRegex: #('a(bc)d'
		'abcd' true (1 'abcd' 2 'bc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry113
	self runRegex: #('(abc|)def' 'abcdef' true nil)
	! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry137
	self runRegex: #('\((.*), (.*)\)' '(a, b)' true (2 'a' 3 'b'))! !

!RxMatcherTest methodsFor: 'tests - empty' stamp: ''!
testEmptyStringAtWordBoundary
	| matcher |
	matcher := self matcherClass forString: '\b'.
	self
		assert: (matcher copy: 'foo bar' replacingMatchesWith: '*')
			= '*foo* *bar*'
		description: 'An empty string at a word boundary'! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry012
	"Need to get creative to include the null character..."
	self runRegex: #('a.*c'	
		'axyzc' true (1 'axyzc')
		'axy zc' true (1 'axy zc') "testing that a dot matches a space"
		), (Array with: 'axy', (String with: 0 asCharacter), 'zc'), #(false nil "testing that a dot does not match a null"
		'axyzd' false nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry011
	self runRegex: #('a.c'
		'abc' true (1 'abc')
		'axc' true (1 'axc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry096
	self runRegex: #('(^)*' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry026
	self runRegex: #('(f|o)+\b'
		'foo' true (1 'foo')
		' foo ' true (1 'foo'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry052
	self runRegex: #('[[:digit:]e]+'
		'01234' true (1 '01234')
		'0123e456' true (1 '0123e456')
		'0123e45g78' true (1 '0123e45'))! !

!RxMatcherTest methodsFor: 'tests - protocol' stamp: ''!
testMatchesInCollect
	| matcher |
	matcher := self matcherClass forString: '\w+'.
	self assert: (matcher matchesIn: 'now is the time' collect: [ :each | each reversed ]) asArray equals: #('won' 'si' 'eht' 'emit')! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry005
	self runRegex: #('ab?bc'
		'abbc' true (1 'abbc')
		'abc' true (1 'abc')
		'abbbbc' false nil
		'abc' true (1 'abc'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry086
	self runRegex: #('a**' nil)! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry092
	self runRegex: #('(a+|b)*'
		'ab' true (1 'ab' 2 'b'))! !

!RxMatcherTest methodsFor: 'tests - henry' stamp: ''!
testHenry132
	self runRegex: #('^a(bc+|b[eh])g|.h$' 'abh' true (1 'bh' 2 nil))
	! !

!RxMatcherTest methodsFor: 'tests - empty' stamp: ''!
testEmptyStringAtEndOfWord
	| matcher |
	matcher := self matcherClass forString: '\>'.
	self
		assert: (matcher copy: 'foo bar' replacingMatchesWith: '*')
			= 'foo* bar*'
		description: 'An empty string at the end of a word'! !

!RxMatcherTest class methodsFor: 'accessing' stamp: ''!
packageNamesUnderTest
	^ #('VB-Regex')! !

!RxParser commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
The regular expression parser. Translates a regular expression read from a stream into a parse tree. ('accessing' protocol). The tree can later be passed to a matcher initialization method.  All other classes in this category implement the tree. Refer to their comments for any details.

Instance variables:
	input		<Stream> A stream with the regular expression being parsed.
	lookahead	<Character>!
!RxParser methodsFor: 'private' stamp: ''!
inputUpTo: aCharacter nestedOn: anotherCharacter errorMessage: aString 
	"Accumulate input stream until <aCharacter> is encountered
	and answer the accumulated chars as String, not including
	<aCharacter>. Signal error if end of stream is encountered,
	passing <aString> as the error description."

	| accumulator nestLevel |
	accumulator := WriteStream on: (String new: 20).
	nestLevel := 0.
	[lookahead ~= aCharacter or: [nestLevel > 0]] whileTrue: 
			[#epsilon = lookahead ifTrue: [self signalParseError: aString].
			accumulator nextPut: lookahead.
			lookahead = anotherCharacter ifTrue: [nestLevel := nestLevel + 1].
			lookahead = aCharacter ifTrue: [nestLevel := nestLevel - 1].
			self next].
	^accumulator contents! !

!RxParser methodsFor: 'accessing' stamp: ''!
parseStream: aStream
	"Parse an input from a character stream <aStream>.
	On success, answers an RxsRegex -- parse tree root.
	On error, raises `RxParser syntaxErrorSignal' with the current
	input stream position as the parameter."

	| tree |
	input := aStream.
	lookahead := nil.
	self match: nil.
	tree := self regex.
	self match: #epsilon.
	^tree! !

!RxParser methodsFor: 'recursive descent' stamp: ''!
regex
	"<regex> ::= e | <branch> `|' <regex>"

	| branch regex |
	branch := self branch.
	
	(lookahead = #epsilon 
	or: [ lookahead = $) ])
		ifTrue: [ regex := nil ]
		ifFalse: [
			self match: $|.
			regex := self regex ].
		
	^RxsRegex new initializeBranch: branch regex: regex! !

!RxParser methodsFor: 'accessing' stamp: ''!
parse: aString
	"Parse input from a string <aString>.
	On success, answers an RxsRegex -- parse tree root.
	On error, raises `RxParser syntaxErrorSignal' with the current
	input stream position as the parameter."

	^self parseStream: (ReadStream on: aString)! !

!RxParser methodsFor: 'private' stamp: ''!
next
	"Advance the input storing the just read character
	as the lookahead."

	input atEnd
		ifTrue: [lookahead := #epsilon]
		ifFalse: [lookahead := input next]! !

!RxParser methodsFor: 'private' stamp: ''!
characterSetFrom: setSpec
	"<setSpec> is what goes between the brackets in a charset regex
	(a String). Make a string containing all characters the spec specifies.
	Spec is never empty."

	| negated spec |
	spec := ReadStream on: setSpec.
	spec peek = $^
		ifTrue: 	[negated := true.
				spec next]
		ifFalse:	[negated := false].
	^RxsCharSet new
		initializeElements: (RxCharSetParser on: spec) parse
		negated: negated! !

!RxParser methodsFor: 'private' stamp: ''!
signalParseError: aString

	self class signalSyntaxException: aString at: input position! !

!RxParser methodsFor: 'recursive descent' stamp: ''!
piece
	"<piece> ::= <atom> | <atom>* | <atom>+ | <atom>? | <atom>{<number>,<number>}"

	| atom |
	atom := self atom.
	
	lookahead = $*
		ifTrue: [ 
			self next.
			atom isNullable
				ifTrue: [ self signalNullableClosureParserError ].
			^ RxsPiece new initializeStarAtom: atom ].

	lookahead = $+
		ifTrue: [ 
			self next.
			atom isNullable
				ifTrue: [ self signalNullableClosureParserError ].
			^ RxsPiece new initializePlusAtom: atom ].

	lookahead = $?
		ifTrue: [ 
			self next.
			atom isNullable
				ifTrue: [ 
					^ self lookAround ].
			^ RxsPiece new initializeOptionalAtom: atom ].
	
	lookahead = ${
		ifTrue: [
			^ self quantifiedAtom: atom ].
		
	^ RxsPiece new initializeAtom: atom! !

!RxParser methodsFor: 'recursive descent' stamp: ''!
atom
	"An atom is one of a lot of possibilities, see below."

	| atom |
	(lookahead = #epsilon 
	or: [ lookahead = $| 
	or: [ lookahead = $)
	or: [ lookahead = $*
	or: [ lookahead = $+ 
	or: [ lookahead = $? ]]]]])
		ifTrue: [ ^RxsEpsilon new ].
		
	lookahead = $( 
		ifTrue: [
			"<atom> ::= '(' <regex> ')' "
			self match: $(.
			atom := self regex.
			self match: $).
			^atom ].
	
	lookahead = $[
		ifTrue: [
			"<atom> ::= '[' <characterSet> ']' "
			self match: $[.
			atom := self characterSet.
			self match: $].
			^atom ].
	
	lookahead = $: 
		ifTrue: [
			"<atom> ::= ':' <messagePredicate> ':' "
			self match: $:.
			atom := self messagePredicate.
			self match: $:.
			^atom ].
	
	lookahead = $. 
		ifTrue: [
			"any non-whitespace character"
			self next.
			^RxsContextCondition new beAny].
	
	lookahead = $^ 
		ifTrue: [
			"beginning of line condition"
			self next.
			^RxsContextCondition new beBeginningOfLine].
	
	lookahead = $$ 
		ifTrue: [
			"end of line condition"
			self next.
			^RxsContextCondition new beEndOfLine].
		
	lookahead = $\ 
		ifTrue: [
			"<atom> ::= '\' <character>"
			self next.
			lookahead = #epsilon 
				ifTrue: [ self signalParseError: 'bad quotation' ].
			(BackslashConstants includesKey: lookahead)
				ifTrue: [
					atom := RxsCharacter with: (BackslashConstants at: lookahead).
					self next.
					^atom].
			self ifSpecial: lookahead
				then: [:node | self next. ^node]].
		
	"If passed through the above, the following is a regular character."
	atom := RxsCharacter with: lookahead.
	self next.
	^atom! !

!RxParser methodsFor: 'private' stamp: ''!
inputUpToAny: aDelimiterString errorMessage: aString
	"Accumulate input stream until any character from <aDelimiterString> is encountered
	and answer the accumulated chars as String, not including the matched characters from the
	<aDelimiterString>. Signal error if end of stream is encountered,
	passing <aString> as the error description."

	| accumulator |
	accumulator := WriteStream on: (String new: 20).
	[(aDelimiterString includes: lookahead) not and: [lookahead ~= #epsilon]]
		whileTrue: [
			accumulator nextPut: lookahead.
			self next ].
	lookahead = #epsilon
		ifTrue: [ self signalParseError: aString ].
	^accumulator contents! !

!RxParser methodsFor: 'recursive descent' stamp: ''!
messagePredicate
	"Match a message predicate specification: a selector (presumably
	understood by a Character) enclosed in :'s ."

	| spec negated |
	spec := self inputUpTo: $: errorMessage: ' no terminating ":"'.
	negated := false.
	spec first = $^ 
		ifTrue: [
			negated := true.
			spec := spec copyFrom: 2 to: spec size].
	^RxsMessagePredicate new 
		initializeSelector: spec asSymbol
		negated: negated! !

!RxParser methodsFor: 'private' stamp: ''!
signalNullableClosureParserError
	self signalParseError: ' nullable closure'.! !

!RxParser methodsFor: 'recursive descent' stamp: ''!
lookAround
	"Parse a lookaround expression after: (?<lookround>) 
	<lookround> ::= !!<regex> | =<regex>"
	| lookaround |
	(lookahead = $!!
	or: [ lookahead = $=])
		ifFalse: [ ^ self signalParseError: 'Invalid lookaround expression ?', lookahead asString ].
	self next.
	lookaround := RxsLookaround with: self regex.
	lookahead = $!!
		ifTrue: [ lookaround beNegative ].
	^ lookaround
	! !

!RxParser methodsFor: 'recursive descent' stamp: ''!
branch
	"<branch> ::= e | <piece> <branch>"

	| piece branch |
	piece := self piece.
	(lookahead = #epsilon 
	or: [ lookahead = $| 
	or: [ lookahead = $) ]])
		ifTrue: [ branch := nil ]
		ifFalse: [ branch := self branch ].
	^RxsBranch new 
		initializePiece: piece 
		branch: branch! !

!RxParser methodsFor: 'private' stamp: ''!
ifSpecial: aCharacter then: aBlock
	"If the character is such that it defines a special node when follows a $\,
	then create that node and evaluate aBlock with the node as the parameter.
	Otherwise just return."

	| classAndSelector |
	classAndSelector := BackslashSpecials at: aCharacter ifAbsent: [^self].
	^aBlock value: (classAndSelector key new perform: classAndSelector value)! !

!RxParser methodsFor: 'private' stamp: ''!
inputUpTo: aCharacter errorMessage: aString
	"Accumulate input stream until <aCharacter> is encountered
	and answer the accumulated chars as String, not including
	<aCharacter>. Signal error if end of stream is encountered,
	passing <aString> as the error description."

	| accumulator |
	accumulator := WriteStream on: (String new: 20).
	[lookahead ~= aCharacter and: [lookahead ~= #epsilon]]
		whileTrue: [
			accumulator nextPut: lookahead.
			self next].
	lookahead = #epsilon
		ifTrue: [ self signalParseError: aString ].
	^accumulator contents! !

!RxParser methodsFor: 'private' stamp: ''!
match: aCharacter
	"<aCharacter> MUST match the current lookeahead.
	If this is the case, advance the input. Otherwise, blow up."

	aCharacter ~= lookahead 
		ifTrue: [^self signalParseError].	"does not return"
	self next! !

!RxParser methodsFor: 'recursive descent' stamp: ''!
characterSet
	"Match a range of characters: something between `[' and `]'.
	Opening bracked has already been seen, and closing should
	not be consumed as well. Set spec is as usual for
	sets in regexes."

	| spec errorMessage |
	errorMessage := ' no terminating "]"'.
	spec := self inputUpTo: $] nestedOn: $[ errorMessage: errorMessage.
	(spec isEmpty 
	or: [spec = '^']) 
		ifTrue: [
			"This ']' was literal." 
			self next.
			spec := spec, ']', (self inputUpTo: $] nestedOn: $[ errorMessage: errorMessage)].
	^self characterSetFrom: spec! !

!RxParser methodsFor: 'recursive descent' stamp: ''!
quantifiedAtom: atom
	"Parse a quanitifer expression which can have one of the following forms
		{<min>,<max>}    match <min> to <max> occurrences
		{<minmax>}       which is the same as with repeated limits: {<number>,<number>}
		{<min>,}         match at least <min> occurrences
		{,<max>}         match maximally <max> occurrences, which is the same as {0,<max>}"
	| min max |
	self next.
	lookahead = $,
		ifTrue: [ min := 0 ]
		ifFalse: [
			max := min := (self inputUpToAny: ',}' errorMessage: ' no terminating "}"') asUnsignedInteger ].
	lookahead = $,
		ifTrue: [
			self next.
			max := (self inputUpToAny: ',}' errorMessage: ' no terminating "}"') asUnsignedInteger ].	
	self match: $}.
	atom isNullable
		ifTrue: [ self signalNullableClosureParserError ].
	(max isNotNil and: [ max < min ])
		ifTrue: [ self signalParseError: ('wrong quantifier, expected ', min asString, ' <= ', max asString) ].
	^ RxsPiece new 
		initializeAtom: atom
		min: min
		max: max! !

!RxParser methodsFor: 'private' stamp: ''!
signalParseError

	self class 
		signalSyntaxException: 'Regex syntax error' at: input position! !

!RxParser class methodsFor: 'class initialization' stamp: ''!
initialize
	"self initialize"
	self
		initializeBackslashConstants;
		initializeBackslashSpecials! !

!RxParser class methodsFor: 'class initialization' stamp: ''!
initializeBackslashSpecials
	"Keys are characters that normally follow a \, the values are
	associations of classes and initialization selectors on the instance side
	of the classes."
	"self initializeBackslashSpecials"

	(BackslashSpecials := Dictionary new)
		at: $w put: (Association key: RxsPredicate value: #beWordConstituent);
		at: $W put: (Association key: RxsPredicate value: #beNotWordConstituent);
		at: $s put: (Association key: RxsPredicate value: #beSpace);
		at: $S put: (Association key: RxsPredicate value: #beNotSpace);
		at: $d put: (Association key: RxsPredicate value: #beDigit);
		at: $D put: (Association key: RxsPredicate value: #beNotDigit);
		at: $b put: (Association key: RxsContextCondition value: #beWordBoundary);
		at: $B put: (Association key: RxsContextCondition value: #beNonWordBoundary);
		at: $< put: (Association key: RxsContextCondition value: #beBeginningOfWord);
		at: $> put: (Association key: RxsContextCondition value: #beEndOfWord)! !

!RxParser class methodsFor: 'utilities' stamp: ''!
parse: aString
	"Parse the argument and return the result (the parse tree).
	In case of a syntax error, the corresponding exception is signaled."

	^self new parse: aString! !

!RxParser class methodsFor: 'exception signaling' stamp: ''!
signalCompilationException: errorString
	RegexCompilationError new signal: errorString! !

!RxParser class methodsFor: 'exception signaling' stamp: ''!
signalMatchException: errorString
	RegexMatchingError new signal: errorString! !

!RxParser class methodsFor: 'utilities' stamp: ''!
safelyParse: aString
	"Parse the argument and return the result (the parse tree).
	In case of a syntax error, return nil.
	Exception handling here is dialect-dependent."
	^ [self new parse: aString] on: RegexSyntaxError do: [:ex | nil]! !

!RxParser class methodsFor: 'class initialization' stamp: ''!
initializeBackslashConstants
	"self initializeBackslashConstants"

	(BackslashConstants := Dictionary new)
		at: $e put: Character escape;
		at: $n put: Character lf;
		at: $r put: Character cr;
		at: $f put: Character newPage;
		at: $t put: Character tab! !

!RxParser class methodsFor: 'exception signaling' stamp: ''!
doHandlingMessageNotUnderstood: aBlock
	"MNU should be trapped and resignaled as a match error in a few places in the matcher.
	This method factors out this dialect-dependent code to make porting easier."
	^ aBlock
		on: MessageNotUnderstood
		do: [:ex | RxParser signalMatchException: 'invalid predicate selector']! !

!RxParser class methodsFor: 'exception signaling' stamp: ''!
signalSyntaxException: errorString
	RegexSyntaxError new signal: errorString! !

!RxParser class methodsFor: 'preferences' stamp: ''!
preferredMatcherClass
	"The matcher to use. For now just one is available, but in
	principle this determines the matchers built implicitly,
	such as by String>>asRegex, or String>>matchesRegex:.
	This might seem a bit strange place for this preference, but
	Parser is still more or less `central' thing in the whole package."

	^RxMatcher! !

!RxParser class methodsFor: 'exception signaling' stamp: ''!
signalSyntaxException: errorString at: errorPosition
	RegexSyntaxError signal: errorString at: errorPosition! !

!RxParserTest commentStamp: ''!
This class provides tests for the regular expression parser.!
!RxParserTest methodsFor: 'tests' stamp: ''!
testMatchesInwW
	"1. Backslash escapes similar to those in Perl are allowed in patterns:
	\w	any word constituent character (equivalent to [a-zA-Z0-9:=])
	\W	any character but a word constituent (equivalent to [^a-xA-Z0-9:=]"

	self assert: ('\w+' asRegex matchesIn: 'now is the time') asArray equals: #('now' 'is' 'the' 'time').
	self assert: ('\W+' asRegex matchesIn: 'now is the time') asArray equals: #(' ' ' ' ' ').
	
	"why do we get that"
	self assert: ('\w' asRegex matchesIn: 'now') asArray equals: #('n' 'o' 'w')! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testQuantifier
	self deny:   (''     matchesRegex: 'a{2}').
	self deny:   ('a'    matchesRegex: 'a{2}').
	self assert: ('aa'   matchesRegex: 'a{2}').
	self deny:   ('aaa'  matchesRegex: 'a{2}').
	
	self deny:   (''     matchesRegex: 'a{2,3}').
	self deny:   ('a'    matchesRegex: 'a{2,3}').
	self assert: ('aa'   matchesRegex: 'a{2,3}').
	self assert: ('aaa'  matchesRegex: 'a{2,3}').
	self deny:   ('aaaa' matchesRegex: 'a{2,3}').
	
	self deny:   (''     matchesRegex: 'a{2,}').
	self deny:   ('a'    matchesRegex: 'a{2,}').
	self assert: ('aa'   matchesRegex: 'a{2,}').
	self assert: ('aaa'  matchesRegex: 'a{2,}').
	self assert: ('aaaa' matchesRegex: 'a{2,}').
	
	self assert: (''     matchesRegex: 'a{,3}').
	self assert: ('a'    matchesRegex: 'a{,3}').
	self assert: ('aa'   matchesRegex: 'a{,3}').
	self assert: ('aaa'  matchesRegex: 'a{,3}').
	self deny:   ('aaaa' matchesRegex: 'a{,3}')! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testQuantifierSimple
	"Test quantifier expressions that can be expressed with + or *"
	self assert: ('a'  matchesRegex: 'a{1}').
	self deny:   ('aa' matchesRegex: 'a{1}').
	
	self assert: ('a'  matchesRegex: 'a{1,1}').
	self deny:   ('aa' matchesRegex: 'a{1,1}').
	
	self assert: ('ab'   matchesRegex: '(ab){1,}').
	self assert: ('abab' matchesRegex: '(ab){1,}').
	self deny:   (''     matchesRegex: '(ab){1,}').
	
	self assert: ('ab'   matchesRegex: '(ab){,1}').
	self assert: (''     matchesRegex: '(ab){,1}').
	self deny:   ('abab' matchesRegex: '(ab){,1}')! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testCharacterSet		
	"So far, we have used only characters as the 'smallest' components of
regular expressions. There are other, more `interesting', components.
A character set is a string of characters enclosed in square
brackets. It matches any single character if it appears between the
brackets. For example, `[01]' matches either `0' or `1':"

	self assert: ('0' matchesRegex: '[01]').	 	
	self deny: ('3' matchesRegex: '[01]'). 	 
	self deny: ('11' matchesRegex: '[01]').	"-- false: a set matches only one character"
	self deny: ('01' matchesRegex: '[01]').
! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testCharacterSetBinaryNumber	
	"Using plus operator, we can build the following binary number
recognizer:"
	self assert: ('10010100' matchesRegex: '[01]+').	 	
	self deny: ('10001210' matchesRegex: '[01]+')	 ! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testSimpleMatchesRegex
	"The simplest regular expression is a single character.  It matches
exactly that character. A sequence of characters matches a string with
exactly the same sequence of characters:"

	self assert: ('a' matchesRegex: 'a').
	self assert: ('foobar' matchesRegex: 'foobar')	.
	self deny: ('blorple' matchesRegex: 'foobar')! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testCharacterSetInversion	
	"If the first character after the opening bracket is `^', the set is
inverted: it matches any single character *not* appearing between the
brackets:"
	
	self deny: ('0' matchesRegex: '[^01]').		  	
	"0 appears in 01 so there is no match"
	
	self assert: ('3' matchesRegex: '[^01]').
	"3 is not in 01 so it matches"
		
	self deny: ('30' matchesRegex: '[^01]').		
	self deny: ('33333333333333333333333330' matchesRegex: '[^01]').	
	"there is one zero so it does not match"! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testCharacterSetRange
	"For convenience, a set may include ranges: pairs of characters
separated with `-'. This is equivalent to listing all characters
between them: `[0-9]' is the same as `[0123456789]'. "	

	self assert: ('0' matchesRegex: '[0-9]').	
	self assert: ('9' matchesRegex: '[0-9]').	
	self deny: ('a' matchesRegex: '[0-9]').
	self deny: ('01' matchesRegex: '[0-9]').	
	self assert: ('01442128629839374565' matchesRegex: '[0-9]+')
	! !

!RxParserTest methodsFor: 'tests' stamp: ''!
DoesNotWorktestBackQuotesEscape
	
	"Regular expressions can also include the following backquote escapes
to refer to popular classes of characters:
	\w	any word constituent character (same as [a-zA-Z0-9:=])
	\W	any character but a word constituent
	\d	a digit (same as [0-9])
	\D	anything but a digit
	\s 	a whitespace character
	\S	anything but a whitespace character
These escapes are also allowed in character classes: '[\w+-]' means
'any character that is either a word constituent, or a plus, or a
minus'."
	
	self assert: ('one word' matchesRegex: '\w').	
		
	self assert: ('one' matchesRegex: '\w').		  	
	! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testOrOperator
	"The last operator is `|' meaning `or'. It is placed between two
regular expressions, and the resulting expression matches if one of
the expressions matches. It has the lowest possible precedence (lower
than sequencing). For example, `ab*|ba*' means `a followed by any
number of b's, or b followed by any number of a's':"

	self assert: ('abb' matchesRegex: 'ab*|ba*').  	
	self assert: ('baa' matchesRegex: 'ab*|ba*').	 	
	self deny: ('baab' matchesRegex: 'ab*|ba*').
	
	"It is possible to write an expression matching an empty string, for
example: `a|'.  However, it is an error to apply `*', `+', or `?' to
such expression: `(a|)*' is an invalid expression."

	self should: ['(a|)*' asRegex] raise: Error
! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testCadrMatching
	"A bit more complex example is the following expression, matching the
name of any of the Lisp-style `car', `cdr', `caar', `cadr',
... functions:"

	self assert: ( 'car' matchesRegex: 'c(a|d)+r').
	self assert: ( 'cdr' matchesRegex: 'c(a|d)+r').
	self assert: ( 'caar' matchesRegex: 'c(a|d)+r').
	self assert: ( 'cadr' matchesRegex: 'c(a|d)+r').
	self assert: ( 'caddar' matchesRegex: 'c(a|d)+r').! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testStarPlusQuestionMark
	"Two other operators similar to `*' are `+' and `?'. `+' (positive
closure, or simply `plus') matches one or more occurrences of the
original expression. `?' (`optional') matches zero or one, but never
more, occurrences."

	self assert: ('ac' matchesRegex: 'ab*c').  		
	self deny: ('ac' matchesRegex: 'ab+c'). 		"-- false: need at least one b"
	self assert: ('abbc' matchesRegex: 'ab+c').	
	self assert: ('abbbbbbc' matchesRegex: 'ab+c').	
	self deny: ('abbc' matchesRegex: 'ab?c')	 	"-- false: too many b's"! !

!RxParserTest methodsFor: 'tests' stamp: ''!
test

	self assert: ('\<t\w+' asRegexIgnoringCase
		copy: 'now is the Time'
		translatingMatchesUsing: [:match | match asUppercase]) equals: 'now is THE TIME'.

	"the regular expression matches words beginning with either an uppercase or a lowercase T"! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testTranslatingMatchesUsing
	self assert: ('\<t\w+' asRegexIgnoringCase
		copy: 'now is the Time'
		translatingMatchesUsing: [:match | match asUppercase]) equals: 'now is THE TIME'.

	"the regular expression matches words beginning with either an uppercase or a lowercase T"! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testQuotingOperators
	"As we have seen, characters `*', `+', `?', `(', and `)' have special
meaning in regular expressions. If one of them is to be used
literally, it should be quoted: preceded with a backslash. (Thus,
backslash is also special character, and needs to be quoted for a
literal match--as well as any other special character described
further)."

	self deny: ('ab*' matchesRegex: 'ab*'). "	-- false: star in the right string is special"
	self assert: ('ab*' matchesRegex: 'ab\*').	 		
	self assert: ('a\c' matchesRegex: 'a\\c')		 	! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testSpecialCharacterInSetRange
	"Special characters within a set are `^', `-', and `]' that closes the
set. Below are the examples of how to literally use them in a set:
	[01^]		-- put the caret anywhere except the beginning
	[01-]		-- put the dash as the last character
	[]01]		-- put the closing bracket as the first character 
	[^]01]			(thus, empty and universal sets cannot be specified)"

	self assert: ('0' matchesRegex: '[01^]').
	self assert: ('1' matchesRegex: '[01^]').
	self assert: ('^' matchesRegex: '[01^]').
	
	self deny: ('0' matchesRegex: '[^01]').
	self deny: ('1' matchesRegex: '[^01]').
	
	"[^abc] means that everything except abc is matche"
	self assert: ('^' matchesRegex: '[^01]')
	! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testLookaround
	self assert: ('A'   matchesRegex: '(?!!ABC).*').
	self assert: ('AB'  matchesRegex: '(?!!ABC).*').
	self deny:   ('ABC' matchesRegex: '(?!!ABC).*')! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testStarPrecedence
	"A star's precedence is higher than that of sequencing. A star applies
to the shortest possible subexpression that precedes it. For example,
'ab*' means `a followed by zero or more occurrences of b', not `zero
or more occurrences of ab':"

	self assert: ('abbb' matchesRegex: 'ab*'). 
	self deny: ('abab' matchesRegex: 'ab*').	 	
		
	"To actually make a regex matching `zero or more occurrences of ab',
`ab' is enclosed in parentheses:"
	self assert: ('abab' matchesRegex: '(ab)*'). 
	self deny: ('abcab' matchesRegex: '(ab)*')! !

!RxParserTest methodsFor: 'tests' stamp: ''!
testSimpleMatchesRegexWithStar
	"The above paragraph in testSimpleMatchesRegex introduced a primitive regular expression (a
character), and an operator (sequencing). Operators are applied to
regular expressions to produce more complex regular expressions.
Sequencing (placing expressions one after another) as an operator is,
in a certain sense, `invisible'--yet it is arguably the most common.
A more `visible' operator is Kleene closure, more often simply
referred to as `a star'.  A regular expression followed by an asterisk
matches any number (including 0) of matches of the original
expression. For example:"

	self assert: ('ab' matchesRegex: 'a*b').		 		
	self assert: ('aaaaab' matchesRegex: 'a*b').	
	self assert: ('b' matchesRegex: 'a*b').	 	
	self deny: ('aac' matchesRegex: 'a*b')		! !

!RxmBranch commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
This is a branch of a matching process. Either `next' chain should match, or `alternative', if not nil, should match. Since this is also used to build loopbacks to match repetitions, `loopback' variable indicates whether the instance is a loopback: it affects the matcher-building operations (which of the paths through the branch is to consider as the primary when we have to find the "tail" of a matcher construct).

Instance variables
	alternative		<RxmLink> to match if `next' fails to match.
	loopback		<Boolean>!
!RxmBranch methodsFor: 'initialization' stamp: ''!
initialize
	"See class comment for instance variable description."

	super initialize.
	loopback := false! !

!RxmBranch methodsFor: 'initialization' stamp: ''!
beLoopback
	"See class comment for instance variable description."

	loopback := true! !

!RxmBranch methodsFor: 'initialization' stamp: ''!
alternative: aBranch
	"See class comment for instance variable description."

	alternative := aBranch! !

!RxmBranch methodsFor: 'matching' stamp: ''!
matchAgainst: aMatcher
	"Match the longest match of `next' or `alternative'. Fail the alternative if the alternative is nil."

	| original firstMatch firstMatchPos |

	original := aMatcher currentState.
	(next matchAgainst: aMatcher)
		ifFalse: [^alternative notNil and: [alternative matchAgainst: aMatcher]].
	alternative ifNil: [^true].
	firstMatch := aMatcher currentState.
	firstMatchPos := aMatcher position.
	aMatcher restoreState: original.
	(alternative matchAgainst: aMatcher)
		ifFalse: [
			aMatcher restoreState: firstMatch.
			^true].
	firstMatchPos >= aMatcher position
		ifTrue: [
			aMatcher restoreState: firstMatch.
			^true].
	^true			
! !

!RxmBranch methodsFor: 'building' stamp: ''!
pointTailTo: aNode
	"See superclass for explanations."

	loopback
		ifTrue: [
			alternative == nil
				ifTrue: [alternative := aNode]
				ifFalse: [alternative pointTailTo: aNode]]
		ifFalse: [super pointTailTo: aNode]! !

!RxmBranch methodsFor: 'building' stamp: ''!
terminateWith: aNode
	"See superclass for explanations."

	loopback
		ifTrue: [alternative == nil
			ifTrue: [alternative := aNode]
			ifFalse: [alternative terminateWith: aNode]]
		ifFalse: [super terminateWith: aNode]! !

!RxmLink commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
A matcher is built of a number of links interconnected into some intricate structure. Regardless of fancy stuff, any link (except for the terminator) has the next one. Any link can match against a stream of characters, recursively propagating the match to the next link. Any link supports a number of matcher-building messages. This superclass does all of the above. 

The class is not necessarily abstract. It may double as an empty string matcher: it recursively propagates the match to the next link, thus always matching nothing successfully.

Principal method:
	matchAgainst: aMatcher
		Any subclass will reimplement this to test the state of the matcher, most
		probably reading one or more characters from the matcher's stream, and
		either decide it has matched and answer true, leaving matcher stream
		positioned at the end of match, or answer false and restore the matcher
		stream position to whatever it was before the matching attempt.

Instance variables:
	next		<RxmLink | RxmTerminator> The next link in the structure.!
!RxmLink methodsFor: 'accessing' stamp: ''!
next
	
	^next! !

!RxmLink methodsFor: 'accessing' stamp: ''!
next: aLink
	"Set the next link, either an RxmLink or an RxmTerminator."

	next := aLink! !

!RxmLink methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	next := next copy! !

!RxmLink methodsFor: 'matching' stamp: ''!
matchAgainst: aMatcher
	"If a link does not match the contents of the matcher's stream,
	answer false. Otherwise, let the next matcher in the chain match."

	^next matchAgainst: aMatcher! !

!RxmLink methodsFor: 'building' stamp: ''!
pointTailTo: anRxmLink
	"Propagate this message along the chain of links.
	Point `next' reference of the last link to <anRxmLink>.
	If the chain is already terminated, blow up."

	next == nil
		ifTrue: [next := anRxmLink]
		ifFalse: [next pointTailTo: anRxmLink]! !

!RxmLink methodsFor: 'building' stamp: ''!
terminateWith: aTerminator
	"Propagate this message along the chain of links, and
	make aTerminator the `next' link of the last link in the chain.
	If the chain is already reminated with the same terminator, 
	do not blow up."

	next == nil
		ifTrue: [next := aTerminator]
		ifFalse: [next terminateWith: aTerminator]! !

!RxmLookahaed commentStamp: ''!
Instance holds onto a lookead which matches but does not consume anything.

Instance variables:
	predicate		<RxmLink>!
!RxmLookahaed methodsFor: 'accessing' stamp: ''!
lookahead: anRxmLink
	lookahead := anRxmLink! !

!RxmLookahaed methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	positive := true.! !

!RxmLookahaed methodsFor: 'matching' stamp: ''!
matchAgainst: aMatcher
	"Match if the predicate block evaluates to true when given the
	current stream character as the argument."

	| original result |
	original := aMatcher currentState.
	result := lookahead matchAgainst: aMatcher.
	aMatcher restoreState: original.
	^ result not 
		and: [ next matchAgainst: aMatcher ]! !

!RxmLookahaed methodsFor: 'building' stamp: ''!
terminateWith: aNode
	lookahead terminateWith: aNode.
	super terminateWith: aNode.! !

!RxmLookahaed methodsFor: 'accessing' stamp: ''!
lookahead
	^ lookahead! !

!RxmLookahaed class methodsFor: 'instance creation' stamp: ''!
with: aPiece

	^self new lookahead: aPiece! !

!RxmMarker commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
A marker is used to remember positions of match of certain points of a regular expression. The marker receives an identifying key from the Matcher and uses that key to report positions of successful matches to the Matcher.

Instance variables:
	index	<Object> Something that makes sense for the Matcher. Received from the latter during initalization and later passed to it to identify the receiver.!
!RxmMarker methodsFor: 'matching' stamp: ''!
matchAgainst: aMatcher
	"If the rest of the link chain matches successfully, report the
	position of the stream *before* the match started to the matcher."

	| startPosition |
	startPosition := aMatcher position.
	(next matchAgainst: aMatcher)
		ifTrue:
			[aMatcher markerPositionAt: index add: startPosition.
			^true].
	^false! !

!RxmMarker methodsFor: 'initialization' stamp: ''!
index: anIndex
	"An index is a key that makes sense for the matcher.
	This key can be passed to marker position getters and
	setters to access position for this marker in the current
	matching session."

	index := anIndex! !

!RxmPredicate commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
Instance holds onto a one-argument block and matches exactly one character if the block evaluates to true when passed the character as the argument.

Instance variables:
	predicate		<BlockClosure>!
!RxmPredicate methodsFor: 'initialization' stamp: ''!
bePerform: aSelector
	"Match any single character that answers true  to this message."

	self predicate: 
		[:char | 
		RxParser doHandlingMessageNotUnderstood: [char perform: aSelector]]! !

!RxmPredicate methodsFor: 'initialization' stamp: ''!
bePerformNot: aSelector
	"Match any single character that answers false to this message."

	self predicate: 
		[:char | 
		RxParser doHandlingMessageNotUnderstood: [(char perform: aSelector) not]]! !

!RxmPredicate methodsFor: 'matching' stamp: ''!
matchAgainst: aMatcher
	"Match if the predicate block evaluates to true when given the
	current stream character as the argument."

	| original |
	original := aMatcher currentState.
	^ (aMatcher atEnd not and: [ (predicate value: aMatcher next) and: [ next matchAgainst: aMatcher ] ])
		ifTrue: [ true ]
		ifFalse: [ aMatcher restoreState: original.
			false ]! !

!RxmPredicate methodsFor: 'initialization' stamp: ''!
predicate: aBlock
	"This link will match any single character for which <aBlock>
	evaluates to true."

	aBlock numArgs ~= 1 ifTrue: [self error: 'bad predicate block'].
	predicate := aBlock.
	^self! !

!RxmPredicate class methodsFor: 'instance creation' stamp: ''!
with: unaryBlock

	^self new predicate: unaryBlock! !

!RxmSpecial commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
A special node that matches a specific matcher state rather than any input character.
The state is either at-beginning-of-line or at-end-of-line.!
!RxmSpecial methodsFor: 'initialization' stamp: ''!
beBeginningOfWord

	matchSelector := #atBeginningOfWord! !

!RxmSpecial methodsFor: 'initialization' stamp: ''!
beEndOfLine

	matchSelector := #atEndOfLine! !

!RxmSpecial methodsFor: 'matching' stamp: ''!
matchAgainst: aMatcher
	"Match without consuming any input, if the matcher is
	in appropriate state."

	^(aMatcher perform: matchSelector)
		and: [next matchAgainst: aMatcher]! !

!RxmSpecial methodsFor: 'initialize-release' stamp: ''!
beBeginningOfLine

	matchSelector := #atBeginningOfLine! !

!RxmSpecial methodsFor: 'initialization' stamp: ''!
beNotWordBoundary

	matchSelector := #notAtWordBoundary! !

!RxmSpecial methodsFor: 'initialization' stamp: ''!
beWordBoundary

	matchSelector := #atWordBoundary! !

!RxmSpecial methodsFor: 'initialization' stamp: ''!
beEndOfWord

	matchSelector := #atEndOfWord! !

!RxmSubstring commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
Instance holds onto a string and matches exactly this string, and exactly once.

Instance variables:
	string 	<String>!
!RxmSubstring methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self beCaseSensitive! !

!RxmSubstring methodsFor: 'matching' stamp: ''!
matchAgainst: aMatcher
	"Match if my sample stream is exactly the current prefix
	of the matcher stream's contents."

	| originalState sampleStream mismatch |
	originalState := aMatcher currentState.
	sampleStream := self sampleStream.
	mismatch := false.
	[ sampleStream atEnd or: [ aMatcher atEnd or: [ mismatch := (compare value: sampleStream next value: aMatcher next) not ] ] ] whileFalse.
	^ (mismatch not and: [ sampleStream atEnd and: [ next matchAgainst: aMatcher ] ])
		ifTrue: [ true ]
		ifFalse: [ aMatcher restoreState: originalState.
			false ]! !

!RxmSubstring methodsFor: 'initialization' stamp: ''!
beCaseSensitive

	compare := [:char1 :char2 | char1 = char2]! !

!RxmSubstring methodsFor: 'initialization' stamp: ''!
substring: aString ignoreCase: aBoolean
	"Match exactly this string."

	sample := aString.
	aBoolean ifTrue: [self beCaseInsensitive]! !

!RxmSubstring methodsFor: 'private' stamp: ''!
sampleStream

	^sample readStream! !

!RxmSubstring methodsFor: 'initialize-release' stamp: ''!
character: aCharacter ignoreCase: aBoolean
	"Match exactly this character."

	sample := String with: aCharacter.
	aBoolean ifTrue: [self beCaseInsensitive]! !

!RxmSubstring methodsFor: 'initialization' stamp: ''!
beCaseInsensitive

	compare := [:char1 :char2 | char1 sameAs: char2]! !

!RxmTerminator commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
Instances of this class are used to terminate matcher's chains. When a match reaches this (an instance receives #matchAgainst: message), the match is considered to succeed. Instances also support building protocol of RxmLinks, with some restrictions.!
!RxmTerminator methodsFor: 'matching' stamp: ''!
matchAgainst: aStream
	"If got here, the match is successful."

	^true! !

!RxmTerminator methodsFor: 'building' stamp: ''!
pointTailTo: anRxmLink
	"Branch tails are never redirected by the build algorithm.
	Healthy terminators should never receive this."

	RxParser signalCompilationException:
		'internal matcher build error - redirecting terminator tail'! !

!RxmTerminator methodsFor: 'building' stamp: ''!
terminateWith: aTerminator
	"Branch terminators are never supposed to change.
	Make sure this is the case."

	aTerminator ~~ self
		ifTrue: [RxParser signalCompilationException:
				'internal matcher build error - wrong terminator']! !

!RxsBranch commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
A Branch is a Piece followed by a Branch or an empty string.

Instance variables:
	piece		<RxsPiece>
	branch		<RxsBranch|RxsEpsilon>!
!RxsBranch methodsFor: 'testing' stamp: ''!
isNullable

	^piece isNullable and: [branch isNil or: [branch isNullable]]! !

!RxsBranch methodsFor: 'accessing' stamp: ''!
dispatchTo: aMatcher
	"Inform the matcher of the kind of the node, and it
	will do whatever it has to."

	^aMatcher syntaxBranch: self! !

!RxsBranch methodsFor: 'accessing' stamp: ''!
piece

	^piece! !

!RxsBranch methodsFor: 'optimization' stamp: ''!
tryMergingInto: aStream

	"Concatenation of a few simple characters can be optimized
	to be a plain substring match. Answer the node to resume
	syntax tree traversal at. Epsilon node used to terminate the branch
	will implement this to answer nil, thus indicating that the branch
	has ended."

	piece isAtomic
		ifFalse: [ ^ self ].
	aStream nextPut: piece character.
	^ branch ifNil: [ branch ] ifNotNil: [ branch tryMergingInto: aStream ]! !

!RxsBranch methodsFor: 'accessing' stamp: ''!
branch

	^branch! !

!RxsBranch methodsFor: 'initialization' stamp: ''!
initializePiece: aPiece branch: aBranch
	"See class comment for instance variables description."

	piece := aPiece.
	branch := aBranch! !

!RxsCharSet commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
A character set corresponds to a [...] construct in the regular expression.

Instance variables:
	elements	<OrderedCollection> An element can be one of: RxsCharacter, RxsRange, or RxsPredicate.
	negated		<Boolean>!
!RxsCharSet methodsFor: 'privileged' stamp: ''!
enumerablePartPredicateIgnoringCase: aBoolean

	| enumeration |
	enumeration := self optimalSetIgnoringCase: aBoolean.
	^negated
		ifTrue: [[:char | (enumeration includes: char) not]]
		ifFalse: [[:char | enumeration includes: char]]! !

!RxsCharSet methodsFor: 'privileged' stamp: ''!
predicatePartPredicate
	"Answer a predicate that tests all of my elements that cannot be
	enumerated."

	| predicates |
	predicates := elements reject: [:some | some isEnumerable].
	predicates isEmpty
		ifTrue: [^[:char | negated]].
	predicates size = 1
		ifTrue: [^negated
			ifTrue: [predicates first predicateNegation]
			ifFalse: [predicates first predicate]].
	predicates := predicates collect: [:each | each predicate].
	^negated
		ifFalse:
			[[:char | predicates contains: [:some | some value: char]]]
		ifTrue:
			[[:char | (predicates contains: [:some | some value: char]) not]]! !

!RxsCharSet methodsFor: 'accessing' stamp: ''!
hasPredicates

	^elements contains: [:some | some isEnumerable not]! !

!RxsCharSet methodsFor: 'accessing' stamp: ''!
predicateIgnoringCase: aBoolean

	| predicate enumerable |
	enumerable := self enumerablePartPredicateIgnoringCase: aBoolean.
	^self hasPredicates
		ifFalse: [enumerable]
		ifTrue:
			[predicate := self predicatePartPredicate.
			negated
				ifTrue: [[:char | (enumerable value: char) and: [predicate value: char]]]
				ifFalse: [[:char | (enumerable value: char) or: [predicate value: char]]]]! !

!RxsCharSet methodsFor: 'accessing' stamp: ''!
dispatchTo: aMatcher
	"Inform the matcher of the kind of the node, and it
	will do whatever it has to."

	^aMatcher syntaxCharSet: self! !

!RxsCharSet methodsFor: 'privileged' stamp: ''!
optimalSetIgnoringCase: aBoolean
	"Assuming the client with search the `set' using #includes:,
	answer a collection with the contents of `set', of the class
	that will provide the fastest lookup. Strings are faster than
	Sets for short strings."

	| set |
	set := self enumerableSetIgnoringCase: aBoolean.
	^set size < 10
		ifTrue: [set asArray]
		ifFalse: [set]! !

!RxsCharSet methodsFor: 'testing' stamp: ''!
isEnumerable

	^elements anySatisfy: [:some | some isEnumerable ]! !

!RxsCharSet methodsFor: 'privileged' stamp: ''!
enumerableSetIgnoringCase: aBoolean
	"Answer a collection of characters that make up the portion of me
	that can be enumerated."

	| set |
	set := Set new.
	elements do:
		[:each |
		each isEnumerable ifTrue:
			[each enumerateTo: set ignoringCase: aBoolean]].
	^set! !

!RxsCharSet methodsFor: 'accessing' stamp: ''!
predicates

	^(elements reject: [:some | some isEnumerable])
		collect: [:each | each predicate]! !

!RxsCharSet methodsFor: 'testing' stamp: ''!
isNegated

	^negated! !

!RxsCharSet methodsFor: 'initialization' stamp: ''!
initializeElements: aCollection negated: aBoolean
	"See class comment for instance variables description."

	elements := aCollection.
	negated := aBoolean! !

!RxsCharacter commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
A character is a literal character that appears either in the expression itself or in a character set within an expression.

Instance variables:
	character		<Character>!
!RxsCharacter methodsFor: 'accessing' stamp: ''!
character

	^character! !

!RxsCharacter methodsFor: 'testing' stamp: ''!
isAtomic
	"A character is always atomic."

	^true! !

!RxsCharacter methodsFor: 'accessing' stamp: ''!
dispatchTo: aMatcher
	"Inform the matcher of the kind of the node, and it
	will do whatever it has to."

	^aMatcher syntaxCharacter: self! !

!RxsCharacter methodsFor: 'testing' stamp: ''!
isEnumerable

	^true! !

!RxsCharacter methodsFor: 'initialization' stamp: ''!
initializeCharacter: aCharacter
	"See class comment for instance variable description."

	character := aCharacter! !

!RxsCharacter methodsFor: 'accessing' stamp: ''!
enumerateTo: aSet ignoringCase: aBoolean

	aBoolean
		ifTrue: 
			[aSet 
				add: character asUppercase;
				add: character asLowercase]
		ifFalse: [aSet add: character]! !

!RxsCharacter class methodsFor: 'instance creation' stamp: ''!
with: aCharacter

	^self new initializeCharacter: aCharacter! !

!RxsContextCondition commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
One of a few special nodes more often representing special state of the match rather than a predicate on a character.  The ugly exception is the #any condition which *is* a predicate on a character.

Instance variables:
	kind		<Selector>!
!RxsContextCondition methodsFor: 'initialization' stamp: ''!
beBeginningOfWord
	"Matches empty string at the beginning of a word."

	kind := #syntaxBeginningOfWord! !

!RxsContextCondition methodsFor: 'testing' stamp: ''!
isNullable

	^#syntaxAny ~~ kind! !

!RxsContextCondition methodsFor: 'initialization' stamp: ''!
beNonWordBoundary
	"Analog of \B."

	kind := #syntaxNonWordBoundary! !

!RxsContextCondition methodsFor: 'initialization' stamp: ''!
beEndOfLine
	"Matches empty string at the end of a line."

	kind := #syntaxEndOfLine! !

!RxsContextCondition methodsFor: 'accessing' stamp: ''!
dispatchTo: aBuilder

	^aBuilder perform: kind! !

!RxsContextCondition methodsFor: 'initialization' stamp: ''!
beBeginningOfLine
	"Matches empty string at the beginning of a line."

	kind := #syntaxBeginningOfLine! !

!RxsContextCondition methodsFor: 'initialization' stamp: ''!
beWordBoundary
	"Analog of \w (alphanumeric plus _)."

	kind := #syntaxWordBoundary! !

!RxsContextCondition methodsFor: 'initialize-release' stamp: ''!
beAny
	"Matches anything but a newline."

	kind := #syntaxAny! !

!RxsContextCondition methodsFor: 'initialization' stamp: ''!
beEndOfWord
	"Matches empty string at the end of a word."

	kind := #syntaxEndOfWord! !

!RxsEpsilon commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
This is an empty string.  It terminates some of the recursive constructs.!
!RxsEpsilon methodsFor: 'testing' stamp: ''!
isNullable
	"See comment in the superclass."

	^true! !

!RxsEpsilon methodsFor: 'building' stamp: ''!
dispatchTo: aBuilder
	"Inform the matcher of the kind of the node, and it
	will do whatever it has to."

	^aBuilder syntaxEpsilon! !

!RxsLookaround commentStamp: ''!
I lookaround is used for lookaheads and lookbehinds. They are used to check if the input matches a certain subexpression without consuming any characters (e.g. not advancing the match position).

Lookarounds can be positive or negative. If they are positive the condition fails if the subexpression fails, if they are negative it is inverse.!
!RxsLookaround methodsFor: 'initialize - release' stamp: ''!
beNegative
	positive := false! !

!RxsLookaround methodsFor: 'accessing' stamp: ''!
dispatchTo: aBuilder
	"Inform the matcher of the kind of the node, and it
	will do whatever it has to."
	^aBuilder syntaxLookaround: self! !

!RxsLookaround methodsFor: 'accessing' stamp: ''!
piece
	^ piece! !

!RxsLookaround methodsFor: 'initialize - release' stamp: ''!
initializePiece: anRsxPiece
	super initialize.
	piece := anRsxPiece.! !

!RxsLookaround methodsFor: 'initialize - release' stamp: ''!
bePositive
	positive := true! !

!RxsLookaround class methodsFor: 'instance creation' stamp: ''!
with: anRsxPiece
	^ self new
		initializePiece: anRsxPiece! !

!RxsMessagePredicate commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
A message predicate represents a condition on a character that is tested (at the match time) by sending a unary message to the character expecting a Boolean answer.

Instance variables:
	selector		<Symbol>!
!RxsMessagePredicate methodsFor: 'accessing' stamp: ''!
negated

	^negated! !

!RxsMessagePredicate methodsFor: 'accessing' stamp: ''!
selector

	^selector! !

!RxsMessagePredicate methodsFor: 'initialization' stamp: ''!
initializeSelector: aSelector
	"The selector must be a one-argument message understood by Character."

	selector := aSelector! !

!RxsMessagePredicate methodsFor: 'accessing' stamp: ''!
dispatchTo: aBuilder
	"Inform the matcher of the kind of the node, and it
	will do whatever it has to."

	^aBuilder syntaxMessagePredicate: self! !

!RxsMessagePredicate methodsFor: 'initialization' stamp: ''!
initializeSelector: aSelector negated: aBoolean
	"The selector must be a one-argument message understood by Character."

	selector := aSelector.
	negated := aBoolean! !

!RxsNode commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
A generic syntax tree node, provides some common responses to the standard tests, as well as tree structure printing -- handy for debugging.!
!RxsNode methodsFor: 'testing' stamp: ''!
isNullable
	"True if the node can match an empty sequence of characters."

	^false "for most nodes"! !

!RxsNode methodsFor: 'constants' stamp: ''!
indentCharacter
	"Normally, #printOn:withIndent: method in subclasses
	print several characters returned by this method to indicate
	the tree structure."

	^$+! !

!RxsNode methodsFor: 'testing' stamp: ''!
isAtomic
	"Answer whether the node is atomic, i.e. matches exactly one 
	constant predefined normal character.  A matcher may decide to 
	optimize matching of a sequence of atomic nodes by glueing them 
	together in a string."

	^false "tentatively"! !

!RxsPiece commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
A piece is an atom, possibly optional or repeated a number of times.

Instance variables:
	atom	<RxsCharacter|RxsCharSet|RxsPredicate|RxsRegex|RxsSpecial>
	min		<Integer>
	max		<Integer|nil> nil means infinity!
!RxsPiece methodsFor: 'testing' stamp: ''!
isNullable
	"A piece is nullable if it allows 0 matches. 
	This is often handy to know for optimization."

	^min = 0 or: [atom isNullable]! !

!RxsPiece methodsFor: 'testing' stamp: ''!
isSingular
	"A piece with a range is 1 to 1 needs can be compiled
	as a simple match."

	^min = 1 and: [max = 1]! !

!RxsPiece methodsFor: 'accessing' stamp: ''!
character
	"If this node is atomic, answer the character it
	represents. It is the caller's responsibility to make sure this
	node is indeed atomic before using this."

	^atom character! !

!RxsPiece methodsFor: 'initialization' stamp: ''!
initializeAtom: anAtom
	"This piece is exactly one occurrence of the specified RxsAtom."

	self initializeAtom: anAtom min: 1 max: 1! !

!RxsPiece methodsFor: 'accessing' stamp: ''!
max
	"The value answered may be nil, indicating infinity."

	^max! !

!RxsPiece methodsFor: 'initialization' stamp: ''!
initializeAtom: anAtom min: minOccurrences max: maxOccurrences
	"This piece is from <minOccurrences> to <maxOccurrences> 
	occurrences of the specified RxsAtom."

	atom := anAtom.
	min := minOccurrences.
	max := maxOccurrences! !

!RxsPiece methodsFor: 'testing' stamp: ''!
isAtomic
	"A piece is atomic if only it contains exactly one atom
	which is atomic (sic)."

	^self isSingular and: [atom isAtomic]! !

!RxsPiece methodsFor: 'initialization' stamp: ''!
initializeStarAtom: anAtom
	"This piece is any number of occurrences of the atom."

	self initializeAtom: anAtom min: 0 max: nil! !

!RxsPiece methodsFor: 'testing' stamp: ''!
isPlus

	^min = 1 and: [max == nil]! !

!RxsPiece methodsFor: 'testing' stamp: ''!
isStar

	^min = 0 and: [max == nil]! !

!RxsPiece methodsFor: 'accessing' stamp: ''!
dispatchTo: aMatcher
	"Inform the matcher of the kind of the node, and it
	will do whatever it has to."

	^aMatcher syntaxPiece: self! !

!RxsPiece methodsFor: 'accessing' stamp: ''!
atom

	^atom! !

!RxsPiece methodsFor: 'initialization' stamp: ''!
initializeOptionalAtom: anAtom
	"This piece is 0 or 1 occurrences of the specified RxsAtom."

	self initializeAtom: anAtom min: 0 max: 1! !

!RxsPiece methodsFor: 'initialize-release' stamp: ''!
initializePlusAtom: anAtom
	"This piece is one or more occurrences of the specified RxsAtom."

	self initializeAtom: anAtom min: 1 max: nil! !

!RxsPiece methodsFor: 'accessing' stamp: ''!
min

	^min! !

!RxsPiece methodsFor: 'testing' stamp: ''!
isOptional

	^min = 0 and: [max = 1]! !

!RxsPredicate commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
This represents a character that satisfies a certain predicate.

Instance Variables:

	predicate	<BlockClosure>	A one-argument block. If it evaluates to the value defined by <negated> when it is passed a character, the predicate is considered to match.
	negation	<BlockClosure>	A one-argument block that is a negation of <predicate>.!
!RxsPredicate methodsFor: 'accessing' stamp: ''!
predicateNegation

	^negation! !

!RxsPredicate methodsFor: 'initialize-release' stamp: ''!
beAlphaNumeric

	predicate := [:char | char isAlphaNumeric].
	negation := [:char | char isAlphaNumeric not]! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
beUppercase

	predicate := [:char | char isUppercase].
	negation := [:char | char isUppercase not]! !

!RxsPredicate methodsFor: 'private' stamp: ''!
negate

	| tmp |
	tmp := predicate.
	predicate := negation.
	negation := tmp! !

!RxsPredicate methodsFor: 'accessing' stamp: ''!
value: aCharacter

	^predicate value: aCharacter! !

!RxsPredicate methodsFor: 'accessing' stamp: ''!
negated

	^self copy negate! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
beDigit

	predicate := [:char | char isDigit].
	negation := [:char | char isDigit not]! !

!RxsPredicate methodsFor: 'initialize-release' stamp: ''!
beAlphabetic

	predicate := [:char | char isLetter].
	negation := [:char | char isLetter not]! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
beHexDigit

	| hexLetters |
	hexLetters := 'abcdefABCDEF'.
	predicate := [:char | char isDigit or: [hexLetters includes: char]].
	negation := [:char | char isDigit not and: [(hexLetters includes: char) not]]! !

!RxsPredicate methodsFor: 'initialize-release' stamp: ''!
beWordConstituent

	predicate := [:char | char isAlphaNumeric or: [char == $_]].
	negation := [:char | char isAlphaNumeric not and: [char ~~ $_]]! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
bePunctuation

	| punctuationChars |
	punctuationChars := #($. $, $!! $? $; $: $" $' $- $( $) $`).
	predicate := [:char | punctuationChars includes: char].
	negation := [:char | (punctuationChars includes: char) not]! !

!RxsPredicate methodsFor: 'accessing' stamp: ''!
dispatchTo: anObject

	^anObject syntaxPredicate: self! !

!RxsPredicate methodsFor: 'testing' stamp: ''!
isEnumerable

	^false! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
beGraphics

	self
		beControl;
		negate! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
beLowercase

	predicate := [:char | char isLowercase].
	negation := [:char | char isLowercase not]! !

!RxsPredicate methodsFor: 'initialize-release' stamp: ''!
beSpace

	predicate := [:char | char isSeparator].
	negation := [:char | char isSeparator not]! !

!RxsPredicate methodsFor: 'accessing' stamp: ''!
predicate

	^predicate! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
beNotWordConstituent

	self
		beWordConstituent;
		negate! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
beBackslash

	predicate := [:char | char == $\].
	negation := [:char | char ~~ $\]! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
beControl

	predicate := [:char | char asInteger < 32].
	negation := [:char | char asInteger >= 32]! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
bePrintable

	self
		beControl;
		negate! !

!RxsPredicate methodsFor: 'initialization' stamp: ''!
beNotSpace

	self
		beSpace;
		negate! !

!RxsPredicate methodsFor: 'initialize-release' stamp: ''!
beNotDigit

	self
		beDigit;
		negate! !

!RxsPredicate class methodsFor: 'instance creation' stamp: ''!
forEscapedLetter: aCharacter

	^self new perform:
		(EscapedLetterSelectors
			at: aCharacter
			ifAbsent: [RxParser signalSyntaxException: 'bad backslash escape'])! !

!RxsPredicate class methodsFor: 'class initialization' stamp: ''!
initialize
	"self initialize"

	self
		initializeNamedClassSelectors;
		initializeEscapedLetterSelectors! !

!RxsPredicate class methodsFor: 'class initialization' stamp: ''!
initializeNamedClassSelectors
	"self initializeNamedClassSelectors"

	(NamedClassSelectors := Dictionary new)
		at: 'alnum' put: #beAlphaNumeric;
		at: 'alpha' put: #beAlphabetic;
		at: 'cntrl' put: #beControl;
		at: 'digit' put: #beDigit;
		at: 'graph' put: #beGraphics;
		at: 'lower' put: #beLowercase;
		at: 'print' put: #bePrintable;
		at: 'punct' put: #bePunctuation;
		at: 'space' put: #beSpace;
		at: 'upper' put: #beUppercase;
		at: 'xdigit' put: #beHexDigit! !

!RxsPredicate class methodsFor: 'class initialization' stamp: ''!
initializeEscapedLetterSelectors
	"self initializeEscapedLetterSelectors"

	(EscapedLetterSelectors := Dictionary new)
		at: $w put: #beWordConstituent;
		at: $W put: #beNotWordConstituent;
		at: $d put: #beDigit;
		at: $D put: #beNotDigit;
		at: $s put: #beSpace;
		at: $S put: #beNotSpace;
		at: $\ put: #beBackslash! !

!RxsPredicate class methodsFor: 'instance creation' stamp: ''!
forNamedClass: aString

	^self new perform:
		(NamedClassSelectors
			at: aString
			ifAbsent: [RxParser signalSyntaxException: 'bad character class name'])! !

!RxsRange commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
I represent a range of characters as appear in character classes such as

	[a-ZA-Z0-9].

I appear in a syntax tree only as an element of RxsCharSet.

Instance Variables:

	first	<Character>
	last	<Character>!
!RxsRange methodsFor: 'testing' stamp: ''!
isEnumerable

	^true! !

!RxsRange methodsFor: 'initialization' stamp: ''!
initializeFirst: aCharacter last: anotherCharacter

	first := aCharacter.
	last := anotherCharacter! !

!RxsRange methodsFor: 'accessing' stamp: ''!
enumerateTo: aSet ignoringCase: aBoolean
	"Add all of the elements I represent to the collection."

	first asInteger to: last asInteger do:
		[:charCode | | character |
		character := charCode asCharacter.
		aBoolean
		ifTrue: 
			[aSet 
				add: character asUppercase;
				add: character asLowercase]
		ifFalse: [aSet add: character]]! !

!RxsRange class methodsFor: 'instance creation' stamp: ''!
from: aCharacter to: anotherCharacter

	^self new initializeFirst: aCharacter last: anotherCharacter! !

!RxsRegex commentStamp: ''!
-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov
--
The body of a parenthesized thing, or a top-level expression, also an atom.  

Instance variables:
	branch		<RxsBranch>
	regex		<RxsRegex | RxsEpsilon>!
!RxsRegex methodsFor: 'testing' stamp: ''!
isNullable

	^branch isNullable or: [regex notNil and: [regex isNullable]]! !

!RxsRegex methodsFor: 'accessing' stamp: ''!
regex
	^regex! !

!RxsRegex methodsFor: 'initialization' stamp: ''!
initializeBranch: aBranch regex: aRegex
	"See class comment for instance variable description."

	branch := aBranch.
	regex := aRegex! !

!RxsRegex methodsFor: 'accessing' stamp: ''!
dispatchTo: aMatcher
	"Inform the matcher of the kind of the node, and it
	will do whatever it has to."

	^aMatcher syntaxRegex: self! !

!RxsRegex methodsFor: 'accessing' stamp: ''!
branch

	^branch! !

!SDL2 commentStamp: ''!
A bunch of functions in a single class for accessing SDL2 interface!
!SDL2 methodsFor: 'nb-library' stamp: ''!
ffiLibraryName
	^self class ffiLibraryName! !

!SDL2 class methodsFor: 'game controller' stamp: ''!
gameControllerNameForIndex: deviceIndex
	^ self ffiCall: #( SDL_String SDL_GameControllerNameForIndex ( int deviceIndex ) )! !

!SDL2 class methodsFor: 'audio' stamp: ''!
queueAudio: dev data: data len: len
	^ self ffiCall: #( int SDL_QueueAudio(SDL_AudioDeviceID dev, void* data, Uint32 len) )! !

!SDL2 class methodsFor: 'video' stamp: ''!
composeCustomBlendMode_srcColorFactor: srcColorFactor dstColorFactor: dstColorFactor colorOperation: colorOperation srcAlphaFactor: srcAlphaFactor dstAlphaFactor: dstAlphaFactor alphaOperation: alphaOperation
	^ self ffiCall: #(SDL_BlendMode SDL_ComposeCustomBlendMode(SDL_BlendFactor srcColorFactor,
                                                                 SDL_BlendFactor dstColorFactor,
                                                                 SDL_BlendOperation colorOperation,
                                                                 SDL_BlendFactor srcAlphaFactor,
                                                                 SDL_BlendFactor dstAlphaFactor,
                                                                 SDL_BlendOperation alphaOperation))! !

!SDL2 class methodsFor: 'audio' stamp: ''!
getNumAudioDevices: isCapture
	^ self ffiCall: #( int SDL_GetNumAudioDevices(int isCapture) )! !

!SDL2 class methodsFor: 'cairo' stamp: ''!
primCreateRGBSurfaceForCairoWidth: width height: height
	^ self ffiCall: #( SDL_Surface* SDL_CreateRGBSurface 
						( 0 , int width , int height , 32 ,
						  16r00FF0000 , 16r0000FF00 , 16r000000FF , 0 ) )! !

!SDL2 class methodsFor: 'common' stamp: ''!
initEverything
	self initLibrary;
		 initSubSystem: SDL_INIT_EVERYTHING! !

!SDL2 class methodsFor: 'audio' stamp: ''!
pauseAudioDevice: dev pauseOn: pauseOn
	^ self ffiCall: #( void SDL_PauseAudioDevice(SDL_AudioDeviceID dev, int pauseOn) )! !

!SDL2 class methodsFor: 'cursor' stamp: ''!
showCursor: toggle
	^ self ffiCall: #( int SDL_ShowCursor ( int toggle ) )! !

!SDL2 class methodsFor: 'video' stamp: ''!
freeSurface: surface
	^ self ffiCall: #( void SDL_FreeSurface ( SDL_Surface* surface ) )! !

!SDL2 class methodsFor: 'common' stamp: ''!
version
	"Answer the SDL version. For example, a SDL_Version(2.0.7)."

	| version |
	version := SDL_Version new.
	self getVersion: version.
	version autoRelease.
	^ version! !

!SDL2 class methodsFor: 'audio' stamp: ''!
getAudioDeviceName: index isCapture: isCapture
	^ self ffiCall: #( char* SDL_GetAudioDeviceName(int index, int isCapture) ) options: #( optStringEncodingUtf8 ).! !

!SDL2 class methodsFor: 'error handling' stamp: ''!
checkForError
	| msg |
	msg := self getErrorMessage.
	( msg ~= SDL2 and: msg ~= '' ) ifTrue:[SDL2Error signal: msg]! !

!SDL2 class methodsFor: 'cursor' stamp: ''!
createSystemCursor: cursorId
	^ self ffiCall: #( SDL_Cursor SDL_CreateSystemCursor (SDL_SystemCursorType cursorId) )! !

!SDL2 class methodsFor: 'cursor' stamp: ''!
createCursor: data mask: mask w: w h: h hotX: hotX hotY: hotY
	^ self ffiCall: #( SDL_Cursor SDL_CreateCursor ( Uint8* data, Uint8* mask, int w, int h, int hotX, int hotY ) )! !

!SDL2 class methodsFor: 'video' stamp: ''!
createWindow: title x: x y: y width: w height: h flags: flags
	^ self ffiCall: #( SDL_Window SDL_CreateWindow ( String title, int x, int y, int w, int h, Uint32 flags ) )! !

!SDL2 class methodsFor: 'opengl' stamp: ''!
glMakeCurrent: window context: context
	^ self ffiCall: #( int SDL_GL_MakeCurrent ( SDL_Window window , SDL_GLContext context ) )! !

!SDL2 class methodsFor: 'common' stamp: ''!
initGameController
	self initLibrary;
		 initSubSystem: SDL_INIT_GAMECONTROLLER! !

!SDL2 class methodsFor: 'video' stamp: ''!
disableScreenSaver

	^ self ffiCall: #(void SDL_DisableScreenSaver(void))! !

!SDL2 class methodsFor: 'common' stamp: ''!
initLibrary
	Session == Smalltalk session ifTrue: [ ^ 1 ].
	"Configure SDL2 in 'application mode', to let the screen to turn off on inactivity.
	 But we let the user to restore 'game mode' on screen, by using #disableScreenSaver"
	
	self initPlatformSpecific.
	
	self
		setHint: SDL_HINT_VIDEO_ALLOW_SCREENSAVER value: '1';
		setHint: SDL_HINT_NO_SIGNAL_HANDLERS value: '1'.
		
	self init: SDL_INIT_NOPARACHUTE.
	Session := Smalltalk session.! !

!SDL2 class methodsFor: 'clipboard' stamp: ''!
clipboardText: text
	| encoded encoder |
	
	encoded := ByteArray streamContents: [ :stream |
		encoder := ZnUTF8Encoder new.
		encoder 
			next: text size 
			putAll: text asString
			startingAt: 1 
			toStream: stream.
		stream nextPut: 0 ].
	
	encoded pinInMemory.
	self primClipboardText: encoded! !

!SDL2 class methodsFor: 'cairo' stamp: ''!
createRGBSurfaceForCairoWidth: width height: height

	^ (self primCreateRGBSurfaceForCairoWidth: width height: height) initialize.! !

!SDL2 class methodsFor: 'mouse' stamp: ''!
modState
	^ self ffiCall: #( SDL_Keymod SDL_GetModState ( ) )! !

!SDL2 class methodsFor: 'clipboard' stamp: ''!
primClipboardText: text
	"It receives a ByteArray because it can be encoded"

	^ self ffiCall: #( int SDL_SetClipboardText ( ByteArray text ) )! !

!SDL2 class methodsFor: 'common' stamp: ''!
quitSubSystem: flags
	^ self ffiCall: #( void SDL_QuitSubSystem ( Uint32 flags ) )! !

!SDL2 class methodsFor: 'native' stamp: ''!
checkLibraryName: aName
	^ (ExternalAddress loadSymbol: 'SDL_Init' from: aName) notNil! !

!SDL2 class methodsFor: 'common' stamp: ''!
isAvailable
	^ [ (ExternalAddress loadSymbol: 'SDL_Init' from: SDL2 moduleName) notNil ] 	
		onErrorDo: [ false ]! !

!SDL2 class methodsFor: 'audio' stamp: ''!
openAudioDevice: device isCapture: isCapture desired: desired obtained: obtained allowedChanges: allowedChanges
	^ self ffiCall: #( SDL_AudioDeviceID SDL_OpenAudioDevice(void* device, int isCapture, SDL_AudioSpec* desired, SDL_AudioSpec* obtained, int allowedChanges) )! !

!SDL2 class methodsFor: 'audio' stamp: ''!
getQueuedAudioSize: dev
	^ self ffiCall: #( Uint32 SDL_GetQueuedAudioSize(SDL_AudioDeviceID dev) )! !

!SDL2 class methodsFor: 'opengl' stamp: ''!
glSwapWindow: window
	^ self ffiCall: #( void SDL_GL_SwapWindow ( SDL_Window window ) )! !

!SDL2 class methodsFor: 'event' stamp: ''!
pollEvent: event
	^ self ffiCall: #( int SDL_PollEvent ( SDL_Event event ) )! !

!SDL2 class methodsFor: 'common' stamp: ''!
initVideo
	self initLibrary;
		 initSubSystem: SDL_INIT_VIDEO! !

!SDL2 class methodsFor: 'game controller' stamp: ''!
isGameController: deviceIndex
	^ self ffiCall: #( bool SDL_IsGameController ( int deviceIndex ) )! !

!SDL2 class methodsFor: 'mouse' stamp: ''!
mouseState
	^ self ffiCall: #( Uint32 SDL_GetMouseState ( nil , nil ) )! !

!SDL2 class methodsFor: 'opengl' stamp: ''!
glGetProcAddress: procName
	^ self ffiCall: #( void* SDL_GL_GetProcAddress ( String procName ) )! !

!SDL2 class methodsFor: 'native' stamp: ''!
ffiLibraryName
	^ self moduleName! !

!SDL2 class methodsFor: 'opengl' stamp: ''!
glCreateContext: window
	^ self ffiCall: #( SDL_GLContext SDL_GL_CreateContext ( SDL_Window window ) )! !

!SDL2 class methodsFor: 'common' stamp: ''!
initJoystick
	self initLibrary;
		 initSubSystem: SDL_INIT_JOYSTICK! !

!SDL2 class methodsFor: 'common' stamp: ''!
quit
	^ self ffiCall: #( void SDL_Quit ( ) )! !

!SDL2 class methodsFor: 'clipboard' stamp: ''!
primClipboardText
	^ self ffiCall: #(void* SDL_GetClipboardText ( ) )! !

!SDL2 class methodsFor: 'mouse' stamp: ''!
mouseStateX: x y: y
	^ self ffiCall: #( Uint32 SDL_GetMouseState ( int* x , int* y ) )! !

!SDL2 class methodsFor: 'common' stamp: ''!
initSubSystem: flags
	^ self ffiCall: #( int SDL_InitSubSystem ( Uint32 flags ) )! !

!SDL2 class methodsFor: 'video' stamp: ''!
createRGBSurfaceFromPixels: pixels width: width height: height depth: depth pitch: pitch
	rmask: rmask gmask: gmask bmask: bmask amask: amask
	^ self ffiCall: #( SDL_Surface* SDL_CreateRGBSurfaceFrom 
						( void* pixels , int width , int height , int depth , int pitch ,
						  Uint32 rmask , Uint32 gmask , Uint32 bmask , Uint32 amask ) )! !

!SDL2 class methodsFor: 'native' stamp: ''!
findSDL2
	"In Linux, try to use the linked version."
	OSSDL2Driver hasPlugin.
	
	"Look for SDL2 using different names."
	#(0							"Static"
	SDL2
	'libSDL2-2.0.0.dylib'		"Mac"
	'libSDL2-2.0.so.0'			"Linux 1"
	'libSDL2-2.0.so.0.2.1'	"Linux 2"
	'SDL2.dll'					"Windows"
	) do: [ :eachName | 
		[ (self checkLibraryName: eachName) ifTrue: [ ^ eachName ] ] 
		onErrorDo: [nil] ].
	self error: 'Failed to find SDL2 library.'! !

!SDL2 class methodsFor: 'opengl' stamp: ''!
glGetAttribute: attr into: value
	^ self ffiCall: #( int SDL_GL_GetAttribute(SDL_GLattr attr, int *value) )! !

!SDL2 class methodsFor: 'timer' stamp: ''!
ticks
	"Gets the number of milliseconds since the SDL library was initialized"
	^ self ffiCall: #( Uint32 SDL_GetTicks ( ) )! !

!SDL2 class methodsFor: 'audio' stamp: ''!
closeAudioDevice: dev
	^ self ffiCall: #( void SDL_CloseAudioDevice(SDL_AudioDeviceID dev) )! !

!SDL2 class methodsFor: 'opengl' stamp: ''!
glSetAttribute: attr value: value
	^ self ffiCall: #( int SDL_GL_SetAttribute(SDL_GLattr attr, int value) )! !

!SDL2 class methodsFor: 'timer' stamp: ''!
eventType: type state: state

	^ self ffiCall: #( Uint8 SDL_EventState(Uint32 type, int state))! !

!SDL2 class methodsFor: 'opengl' stamp: ''!
glGetAttribute: attr

	^ ExternalAddress allocate: 4 bytesDuring: [ :value | 
		  self glGetAttribute: attr into: value.
		  value unsignedLongAt: 1 ]! !

!SDL2 class methodsFor: 'video' stamp: ''!
setHint: aName value: aValue
	^ self ffiCall: #(int SDL_SetHint(const char* aName, const char* aValue))! !

!SDL2 class methodsFor: 'game controller' stamp: ''!
gameControllerOpen: deviceIndex
	^ self ffiCall: #( SDL_GameController SDL_GameControllerOpen ( int deviceIndex ) )! !

!SDL2 class methodsFor: 'mouse' stamp: ''!
setRelativeMouseMode: enabled
	^ self ffiCall: #( int SDL_SetRelativeMouseMode ( bool enabled ) )! !

!SDL2 class methodsFor: 'video' stamp: ''!
getDisplay: displayIndex ddpi: ddpi hdpi: hdpi vdpi: vdpi
	^ self ffiCall: #( int SDL_GetDisplayDPI(int displayIndex, float* ddpi, float* hdpi, float* vdpi))! !

!SDL2 class methodsFor: 'common' stamp: ''!
initAudio
	self initLibrary;
		 initSubSystem: SDL_INIT_AUDIO! !

!SDL2 class methodsFor: 'common' stamp: ''!
getVersion: ver
	"Get the version of SDL.

	See: https://wiki.libsdl.org/SDL_GetVersion
	"

	^ self ffiCall: #( void SDL_GetVersion(SDL_Version* ver) )! !

!SDL2 class methodsFor: 'timer' stamp: ''!
delay: milliseconds
	^ self ffiCall: #( void SDL_Delay ( Uint32 milliseconds ) )! !

!SDL2 class methodsFor: 'common' stamp: ''!
initPlatformSpecific

	OSPlatform current sdlPlatform initPlatformSpecific.! !

!SDL2 class methodsFor: 'joystick' stamp: ''!
joystickOpen: deviceIndex
	^ self ffiCall: #( SDL_Joystick SDL_JoystickOpen ( int deviceIndex ) )! !

!SDL2 class methodsFor: 'error handling' stamp: ''!
getErrorMessage
	^ self ffiCall: #( String SDL_GetError ( void ) )! !

!SDL2 class methodsFor: 'common' stamp: ''!
init: flags
	^ self ffiCall: #( int SDL_Init ( Uint32 flags ) )! !

!SDL2 class methodsFor: 'clipboard' stamp: ''!
clipboardText
	| text |
	
	text := self primClipboardText.
	^ text readStringUTF8! !

!SDL2 class methodsFor: 'native' stamp: ''!
moduleName
	ModuleSession ~~ Smalltalk session ifTrue: [
		ModuleName := self findSDL2.
		ModuleSession := Smalltalk session
	].
	^ ModuleName! !

!SDL2 class methodsFor: 'common' stamp: ''!
wasInit: flags
	^ self ffiCall: #( int SDL_WasInit ( Uint32 flags ) )! !

!SDL2 class methodsFor: 'joystick' stamp: ''!
joystickEventState: state
	^ self ffiCall: #( SDL_Joystick SDL_JoystickEventState ( int state ) )! !

!SDL2 class methodsFor: 'joystick' stamp: ''!
numberOfJoysticks
	^ self ffiCall: #( int SDL_NumJoysticks() )! !

!SDL2AthensDrawingExample commentStamp: ''!
I am a basic example to show how we can handle an event and draw something with this event.

Left mouse button = draw lines 
Other mouse buttons = clear sketch

To launch the example:
self new open!
!SDL2AthensDrawingExample methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	currentStroke := OrderedCollection new.
	strokes := OrderedCollection new! !

!SDL2AthensDrawingExample methodsFor: 'factory' stamp: ''!
createEventHandler
	^ OSWindowAthensDrawingExampleEventHandler new 
			athensExample: self! !

!SDL2AthensDrawingExample methodsFor: 'updating' stamp: ''!
redraw
	self clearSurface.
	strokes
		do:
			[ :stroke | 
			| path |
			path := renderer athensSurface
				createPath: [ :builder | 
					builder
						absolute;
						moveTo: stroke first.
					stroke do: [ :point | builder lineTo: point ] ].
			renderer drawDuring: [ :canvas | 
					canvas
						setStrokePaint: Color black;
						setShape: path;
						draw ] ]! !

!SDL2AthensDrawingExample methodsFor: 'managing strokes' stamp: ''!
startStrokeAt: aPoint
	currentStroke := OrderedCollection with: aPoint.
	strokes add: currentStroke! !

!SDL2AthensDrawingExample methodsFor: 'drawing' stamp: ''!
clearSurface
	renderer athensSurface
		drawDuring: [ :canvas | 
			canvas
				setPaint: Color white;
				drawShape: (0 @ 0 extent: window extent) ]! !

!SDL2AthensDrawingExample methodsFor: 'managing strokes' stamp: ''!
endStroke
	currentStroke := OrderedCollection new.! !

!SDL2AthensDrawingExample methodsFor: 'managing strokes' stamp: ''!
moveAt: aPoint
	currentStroke add: aPoint! !

!SDL2AthensDrawingExample methodsFor: 'managing strokes' stamp: ''!
clearStrokes
	strokes removeAll! !

!SDL2AthensExample commentStamp: ''!
Superclass to show how to use OSWindow properly with athens!
!SDL2AthensExample methodsFor: 'updating' stamp: ''!
updateSurface
	renderer
		updateAll;
		present! !

!SDL2AthensExample methodsFor: 'factory' stamp: ''!
createEventHandler
	"You should override this method with your own event handler"
	^ OSWindowAthensExampleEventHandler new 
		athensExample: self! !

!SDL2AthensExample methodsFor: 'instance creation' stamp: ''!
open
	| attrs |
	attrs := OSWindowAttributes new.
	attrs 
		extent: self defaultExtent;
		resizable: false;
		position: 100@100.
		
	window := OSWindow createWithAttributes: attrs.
	
	renderer := window newAthensRenderer.

	self initializeFromSurface.

	window eventHandler: (self createEventHandler).
	
	drawingProcess := self createDrawingProcess! !

!SDL2AthensExample methodsFor: 'drawing' stamp: ''!
redraw
	^self subclassResponsibility! !

!SDL2AthensExample methodsFor: 'accessing' stamp: ''!
initializeFromSurface
	"Here we put all the things that needs the surface to be initialized."! !

!SDL2AthensExample methodsFor: 'instance creation' stamp: ''!
maxFPS
	^ 60! !

!SDL2AthensExample methodsFor: 'morphic ui' stamp: ''!
defaultExtent
	^ 500@500! !

!SDL2AthensExample methodsFor: 'updating' stamp: ''!
redrawAndUpdateSurface
	self redraw.
	self updateSurface! !

!SDL2AthensExample methodsFor: 'morphic ui' stamp: ''!
destroy
	"This function must be called when the window is closed"
	drawingProcess terminate! !

!SDL2AthensExample methodsFor: 'instance creation' stamp: ''!
createDrawingProcess
	^ [ 
	[ 
	(Delay forMilliseconds: 1000 / self maxFPS) wait.
	self redrawAndUpdateSurface ] repeat ] fork! !

!SDL2Constants commentStamp: ''!
Pool of various SDL2 library constants!
!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeWindow
	"
	Window related constants.
	"
    SDL_WINDOW_FULLSCREEN := 16r00000001.
    SDL_WINDOW_OPENGL := 16r00000002.
    SDL_WINDOW_SHOWN := 16r00000004.
    SDL_WINDOW_HIDDEN := 16r00000008.
    SDL_WINDOW_BORDERLESS := 16r00000010.
    SDL_WINDOW_RESIZABLE := 16r00000020.
    SDL_WINDOW_MINIMIZED := 16r00000040.
    SDL_WINDOW_MAXIMIZED := 16r00000080.
    SDL_WINDOW_INPUT_GRABBED := 16r00000100.
    SDL_WINDOW_INPUT_FOCUS := 16r00000200.
    SDL_WINDOW_MOUSE_FOCUS := 16r00000400.
    SDL_WINDOW_FULLSCREEN_DESKTOP := ( SDL_WINDOW_FULLSCREEN | 16r00001000 ).
    SDL_WINDOW_FOREIGN := 16r00000800.
    SDL_WINDOW_ALLOW_HIGHDPI := 16r00002000.

    SDL_WINDOWPOS_UNDEFINED_MASK := 16r1FFF0000.
    SDL_WINDOWPOS_UNDEFINED := SDL_WINDOWPOS_UNDEFINED_MASK.
	
    SDL_WINDOWPOS_CENTERED_MASK := 16r2FFF0000.
    SDL_WINDOWPOS_CENTERED := SDL_WINDOWPOS_CENTERED_MASK.

    SDL_WINDOWEVENT_NONE			:= 0.
    SDL_WINDOWEVENT_SHOWN		:= 1.
    SDL_WINDOWEVENT_HIDDEN			:= 2.
    SDL_WINDOWEVENT_EXPOSED		:= 3.
    SDL_WINDOWEVENT_MOVED			:= 4.
    SDL_WINDOWEVENT_RESIZED		:= 5.
    SDL_WINDOWEVENT_SIZE_CHANGED		:= 6.
    SDL_WINDOWEVENT_MINIMIZED		:= 7.
    SDL_WINDOWEVENT_MAXIMIZED		:= 8.
    SDL_WINDOWEVENT_RESTORED		:= 9.
    SDL_WINDOWEVENT_ENTER			:= 10.
    SDL_WINDOWEVENT_LEAVE			:= 11.
    SDL_WINDOWEVENT_FOCUS_GAINED		:= 12.
    SDL_WINDOWEVENT_FOCUS_LOST		:= 13.
    SDL_WINDOWEVENT_CLOSE			:= 14.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initialize
	"
	self initialize
	"
	self
		initializeAudio;
		initializeCommon;
		initializeEvent;
		initializeGameController;
		initializeKeyboard;
		initializeKeycodes;
		initializeKeycodes2;
		initializeKeycodes3;
		initializeMouse;
		initializeOpenGL;
		initializeOpenGLProfile;
		initializePixelFormat;
		initializeRenderer;
		initializeTexture;
		initializeWindow;
		initializeWM.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeKeyboard
    KMOD_NONE := 16r0000.
    KMOD_LSHIFT := 16r0001.
    KMOD_RSHIFT := 16r0002.
    KMOD_LCTRL := 16r0040.
    KMOD_RCTRL := 16r0080.
    KMOD_LALT := 16r0100.
    KMOD_RALT := 16r0200.
    KMOD_LGUI := 16r0400.
    KMOD_RGUI := 16r0800.
    KMOD_NUM := 16r1000.
    KMOD_CAPS := 16r2000.
    KMOD_MODE := 16r4000.
    KMOD_RESERVED := 16r8000.

	KMOD_CTRL  :=  (KMOD_LCTRL | KMOD_RCTRL).
	KMOD_SHIFT :=  (KMOD_LSHIFT | KMOD_RSHIFT).
	KMOD_ALT    := (KMOD_LALT | KMOD_RALT).
	KMOD_GUI    := (KMOD_LGUI | KMOD_RGUI).! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeKeycodes2
	SDLK_CAPSLOCK	:= 16r40000039.
	SDLK_F1	:= 16r4000003A.
	SDLK_F2	:= 16r4000003B.
	SDLK_F3	:= 16r4000003C.
	SDLK_F4	:= 16r4000003D.
	SDLK_F5	:= 16r4000003E.
	SDLK_F6	:= 16r4000003F.
	SDLK_F7	:= 16r40000040.
	SDLK_F8	:= 16r40000041.
	SDLK_F9	:= 16r40000042.
	SDLK_F10	:= 16r40000043.
	SDLK_F11	:= 16r40000044.
	SDLK_F12	:= 16r40000045.
	SDLK_PRINTSCREEN	:= 16r40000046.
	SDLK_SCROLLLOCK	:= 16r40000047.
	SDLK_PAUSE	:= 16r40000048.
	SDLK_INSERT	:= 16r40000049.
	SDLK_HOME	:= 16r4000004A.
	SDLK_PAGEUP	:= 16r4000004B.
	SDLK_DELETE	:= 16r007F.
	SDLK_END	:= 16r4000004D.
	SDLK_PAGEDOWN	:= 16r4000004E.
	SDLK_RIGHT	:= 16r4000004F.
	SDLK_LEFT	:= 16r40000050.
	SDLK_DOWN	:= 16r40000051.
	SDLK_UP	:= 16r40000052.
	SDLK_NUMLOCKCLEAR	:= 16r40000053.
	SDLK_KP_DIVIDE	:= 16r40000054.
	SDLK_KP_MULTIPLY	:= 16r40000055.
	SDLK_KP_MINUS	:= 16r40000056.
	SDLK_KP_PLUS	:= 16r40000057.
	SDLK_KP_ENTER	:= 16r40000058.
	SDLK_KP_1	:= 16r40000059.
	SDLK_KP_2	:= 16r4000005A.
	SDLK_KP_3	:= 16r4000005B.
	SDLK_KP_4	:= 16r4000005C.
	SDLK_KP_5	:= 16r4000005D.
	SDLK_KP_6	:= 16r4000005E.
	SDLK_KP_7	:= 16r4000005F.
	SDLK_KP_8	:= 16r40000060.
	SDLK_KP_9	:= 16r40000061.
	SDLK_KP_0	:= 16r40000062.
	SDLK_KP_PERIOD	:= 16r40000063.
	SDLK_APPLICATION	:= 16r40000065.
	SDLK_POWER	:= 16r40000066.
	SDLK_KP_EQUALS	:= 16r40000067.
	SDLK_F13	:= 16r40000068.
	SDLK_F14	:= 16r40000069.
	SDLK_F15	:= 16r4000006A.
	SDLK_F16	:= 16r4000006B.
	SDLK_F17	:= 16r4000006C.
	SDLK_F18	:= 16r4000006D.
	SDLK_F19	:= 16r4000006E.
	SDLK_F20	:= 16r4000006F.
	SDLK_F21	:= 16r40000070.
	SDLK_F22	:= 16r40000071.
	SDLK_F23	:= 16r40000072.
	SDLK_F24	:= 16r40000073.
	SDLK_EXECUTE	:= 16r40000074.
	SDLK_HELP	:= 16r40000075.
	SDLK_MENU	:= 16r40000076.
	SDLK_SELECT	:= 16r40000077.
	SDLK_STOP	:= 16r40000078.
	SDLK_AGAIN	:= 16r40000079.
	SDLK_UNDO	:= 16r4000007A.
	SDLK_CUT	:= 16r4000007B.
	SDLK_COPY	:= 16r4000007C.
	SDLK_PASTE	:= 16r4000007D.
	SDLK_FIND	:= 16r4000007E.
	SDLK_MUTE	:= 16r4000007F.
	SDLK_VOLUMEUP	:= 16r40000080.
	SDLK_VOLUMEDOWN	:= 16r40000081.
	SDLK_KP_COMMA	:= 16r40000085.
	SDLK_KP_EQUALSAS400	:= 16r40000086.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeOpenGL
    SDL_GL_RED_SIZE	:= 0.
    SDL_GL_GREEN_SIZE	:= 1.
    SDL_GL_BLUE_SIZE	:= 2.
    SDL_GL_ALPHA_SIZE	:= 3.
    SDL_GL_BUFFER_SIZE	:= 4.
    SDL_GL_DOUBLEBUFFER	:= 5.
    SDL_GL_DEPTH_SIZE	:= 6.
    SDL_GL_STENCIL_SIZE	:= 7.
    SDL_GL_ACCUM_RED_SIZE	:= 8.
    SDL_GL_ACCUM_GREEN_SIZE	:= 9.
    SDL_GL_ACCUM_BLUE_SIZE		:= 10.
    SDL_GL_ACCUM_ALPHA_SIZE	:= 11.
    SDL_GL_STEREO		:= 12.
    SDL_GL_MULTISAMPLEBUFFERS	:= 13.
    SDL_GL_MULTISAMPLESAMPLES	:= 14.
    SDL_GL_ACCELERATED_VISUAL	:= 15.
    "SDL_GL_SWAP_CONTROL	:= 16" "API desapear"
	 SDL_GL_RETAINED_BACKING := 16.
    SDL_GL_CONTEXT_MAJOR_VERSION := 17.
    SDL_GL_CONTEXT_MINOR_VERSION := 18.
    SDL_GL_CONTEXT_EGL := 19.
    SDL_GL_CONTEXT_FLAGS := 20.
    SDL_GL_CONTEXT_PROFILE_MASK := 21.
    SDL_GL_SHARE_WITH_CURRENT_CONTEXT := 22.
    SDL_GL_FRAMEBUFFER_SRGB_CAPABLE := 23.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeKeycodes
	SDLK_UNKNOWN	:= 16r0000.
	SDLK_RETURN	:= 16r000D.
	SDLK_ESCAPE	:= 16r001B.
	SDLK_BACKSPACE	:= 16r0008.
	SDLK_TAB	:= 16r0009.
	SDLK_SPACE	:= 16r0020.
	SDLK_EXCLAIM	:= 16r0021.
	SDLK_QUOTEDBL	:= 16r0022.
	SDLK_HASH	:= 16r0023.
	SDLK_PERCENT	:= 16r0025.
	SDLK_DOLLAR	:= 16r0024.
	SDLK_AMPERSAND	:= 16r0026.
	SDLK_QUOTE	:= 16r0027.
	SDLK_LEFTPAREN	:= 16r0028.
	SDLK_RIGHTPAREN	:= 16r0029.
	SDLK_ASTERISK	:= 16r002A.
	SDLK_PLUS	:= 16r002B.
	SDLK_COMMA	:= 16r002C.
	SDLK_MINUS	:= 16r002D.
	SDLK_PERIOD	:= 16r002E.
	SDLK_SLASH	:= 16r002F.
	SDLK_0	:= 16r0030.
	SDLK_1	:= 16r0031.
	SDLK_2	:= 16r0032.
	SDLK_3	:= 16r0033.
	SDLK_4	:= 16r0034.
	SDLK_5	:= 16r0035.
	SDLK_6	:= 16r0036.
	SDLK_7	:= 16r0037.
	SDLK_8	:= 16r0038.
	SDLK_9	:= 16r0039.
	SDLK_COLON	:= 16r003A.
	SDLK_SEMICOLON	:= 16r003B.
	SDLK_LESS	:= 16r003C.
	SDLK_EQUALS	:= 16r003D.
	SDLK_GREATER	:= 16r003E.
	SDLK_QUESTION	:= 16r003F.
	SDLK_AT	:= 16r0040.
	SDLK_LEFTBRACKET	:= 16r005B.
	SDLK_BACKSLASH	:= 16r005C.
	SDLK_RIGHTBRACKET	:= 16r005D.
	SDLK_CARET	:= 16r005E.
	SDLK_UNDERSCORE	:= 16r005F.
	SDLK_BACKQUOTE	:= 16r0060.
	SDLK_a	:= 16r0061.
	SDLK_b	:= 16r0062.
	SDLK_c	:= 16r0063.
	SDLK_d	:= 16r0064.
	SDLK_e	:= 16r0065.
	SDLK_f	:= 16r0066.
	SDLK_g	:= 16r0067.
	SDLK_h	:= 16r0068.
	SDLK_i	:= 16r0069.
	SDLK_j	:= 16r006A.
	SDLK_k	:= 16r006B.
	SDLK_l	:= 16r006C.
	SDLK_m	:= 16r006D.
	SDLK_n	:= 16r006E.
	SDLK_o	:= 16r006F.
	SDLK_p	:= 16r0070.
	SDLK_q	:= 16r0071.
	SDLK_r	:= 16r0072.
	SDLK_s	:= 16r0073.
	SDLK_t	:= 16r0074.
	SDLK_u	:= 16r0075.
	SDLK_v	:= 16r0076.
	SDLK_w	:= 16r0077.
	SDLK_x	:= 16r0078.
	SDLK_y	:= 16r0079.
	SDLK_z	:= 16r007A.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeRenderer
	"
	Renderer related constants.
	"
	SDL_RENDERER_SOFTWARE := 16r00000001.
	SDL_RENDERER_ACCELERATED := 16r00000002.
	SDL_RENDERER_PRESENTVSYNC := 16r00000004.
	SDL_RENDERER_TARGETTEXTURE := 16r00000008.
	
	SDL_BLENDMODE_NONE := 16r00000000.
	SDL_BLENDMODE_BLEND := 16r00000001.
	SDL_BLENDMODE_ADD := 16r00000002.
	SDL_BLENDMODE_MOD := 16r00000004.
	SDL_BLENDMODE_INVALID := 16r7FFFFFFF.

	SDL_BLENDOPERATION_ADD              := 16r1.  "dst + src: supported by all renderers"
	SDL_BLENDOPERATION_SUBTRACT         := 16r2.  "dst - src : supported by D3D9, D3D11, OpenGL, OpenGLES"
	SDL_BLENDOPERATION_REV_SUBTRACT     := 16r3.  "src - dst : supported by D3D9, D3D11, OpenGL, OpenGLES"
	SDL_BLENDOPERATION_MINIMUM          := 16r4.  "min(dst, src) : supported by D3D11"
	SDL_BLENDOPERATION_MAXIMUM          := 16r5.   "max(dst, src) : supported by D3D11"
	
	SDL_BLENDFACTOR_ZERO                := 16r1. "0. 0. 0. 0"
	SDL_BLENDFACTOR_ONE                 := 16r2. "1. 1. 1. 1"
	SDL_BLENDFACTOR_SRC_COLOR           := 16r3. "srcR. srcG. srcB. srcA"
	SDL_BLENDFACTOR_ONE_MINUS_SRC_COLOR := 16r4. "1-srcR. 1-srcG. 1-srcB. 1-srcA"
	SDL_BLENDFACTOR_SRC_ALPHA           := 16r5. "srcA. srcA. srcA. srcA"
	SDL_BLENDFACTOR_ONE_MINUS_SRC_ALPHA := 16r6. "1-srcA. 1-srcA. 1-srcA. 1-srcA"
	SDL_BLENDFACTOR_DST_COLOR           := 16r7. "dstR. dstG. dstB. dstA"
	SDL_BLENDFACTOR_ONE_MINUS_DST_COLOR := 16r8. "1-dstR. 1-dstG. 1-dstB. 1-dstA"
	SDL_BLENDFACTOR_DST_ALPHA           := 16r9. "dstA. dstA. dstA. dstA"
	SDL_BLENDFACTOR_ONE_MINUS_DST_ALPHA := 16rA. "1-dstA. 1-dstA. 1-dstA. 1-dstA"! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeCommon
	SDL_INIT_TIMER := 16r00000001.
	SDL_INIT_AUDIO := 16r00000010.
	SDL_INIT_VIDEO := 16r00000020.
	SDL_INIT_JOYSTICK := 16r00000200.
	SDL_INIT_HAPTIC := 16r00001000.
	SDL_INIT_GAMECONTROLLER := 16r00002000.
	SDL_INIT_EVENTS := 16r00004000.
	SDL_INIT_NOPARACHUTE := 16r00100000.
	SDL_INIT_EVERYTHING := SDL_INIT_TIMER | SDL_INIT_AUDIO | SDL_INIT_VIDEO | SDL_INIT_EVENTS |
                SDL_INIT_JOYSTICK | SDL_INIT_HAPTIC | SDL_INIT_GAMECONTROLLER.
	SDL_DISABLE := 0.
	SDL_ENABLE := 1.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeTexture
	"
	Texture related constants.
	"
      SDL_TEXTUREACCESS_STATIC := 0.
      SDL_TEXTUREACCESS_STREAMING := 1.
      SDL_TEXTUREACCESS_TARGET := 2.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeWM
	"
	Window Manager related constants.
	"
	
	SDL_SYSWM_UNKNOWN := 0.
	SDL_SYSWM_WINDOWS := 1.
	SDL_SYSWM_X11 := 2.
	SDL_SYSWM_DIRECTFB := 3.
	SDL_SYSWM_COCOA := 4.
	SDL_SYSWM_UIKIT := 5.
	SDL_SYSWM_WAYLAND := 6.
	SDL_SYSWM_MIR := 7.
	SDL_SYSWM_WINRT := 8.
	SDL_SYSWM_ANDROID := 9.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializePixelFormat
	"
	Pixel format related constants
	"
  	SDL_PIXELTYPE_UNKNOWN := 0.
    	SDL_PIXELTYPE_INDEX1 := 1.
    	SDL_PIXELTYPE_INDEX4 := 2.
    	SDL_PIXELTYPE_INDEX8 := 3.
    	SDL_PIXELTYPE_PACKED8 := 4.
    	SDL_PIXELTYPE_PACKED16 := 5.
    	SDL_PIXELTYPE_PACKED32 := 6.
    	SDL_PIXELTYPE_ARRAYU8 := 7.
    	SDL_PIXELTYPE_ARRAYU16 := 8.
    	SDL_PIXELTYPE_ARRAYU32 := 9.
    	SDL_PIXELTYPE_ARRAYF16 := 10.
    	SDL_PIXELTYPE_ARRAYF32 := 11.

    	SDL_BITMAPORDER_NONE := 0.
    	SDL_BITMAPORDER_4321 := 1.
    	SDL_BITMAPORDER_1234 := 2.
			
	SDL_PACKEDORDER_NONE := 0.
    	SDL_PACKEDORDER_XRGB := 1.
    	SDL_PACKEDORDER_RGBX := 2.
    	SDL_PACKEDORDER_ARGB := 3.
    	SDL_PACKEDORDER_RGBA := 4.
    	SDL_PACKEDORDER_XBGR := 5.
    	SDL_PACKEDORDER_BGRX := 6.
    	SDL_PACKEDORDER_ABGR := 7.
    	SDL_PACKEDORDER_BGRA := 8.

    	SDL_ARRAYORDER_NONE := 0.
    	SDL_ARRAYORDER_RGB := 1.
    	SDL_ARRAYORDER_RGBA := 2.
    	SDL_ARRAYORDER_ARGB := 3.
    	SDL_ARRAYORDER_BGR := 4.
    	SDL_ARRAYORDER_BGRA := 5.
    	SDL_ARRAYORDER_ABGR := 6.
		
    	SDL_PACKEDLAYOUT_NONE := 6.
    	SDL_PACKEDLAYOUT_332 := 6.
    	SDL_PACKEDLAYOUT_4444 := 6.
    	SDL_PACKEDLAYOUT_1555 := 6.
    	SDL_PACKEDLAYOUT_5551 := 6.
    	SDL_PACKEDLAYOUT_565 := 6.
    	SDL_PACKEDLAYOUT_8888 := 6.
    	SDL_PACKEDLAYOUT_2101010 := 6.
    	SDL_PACKEDLAYOUT_1010102 := 6.
									
	SDL_PIXELFORMAT_RGBX8888 := self definePixelFormat_type: SDL_PIXELTYPE_PACKED32 order: SDL_PACKEDORDER_RGBX layout: SDL_PACKEDLAYOUT_8888 bits: 24 bytes: 4.
	SDL_PIXELFORMAT_XRGB8888 := self definePixelFormat_type: SDL_PIXELTYPE_PACKED32 order: SDL_PACKEDORDER_XRGB layout: SDL_PACKEDLAYOUT_8888 bits: 24 bytes: 4.
	
	SDL_PIXELFORMAT_RGBA8888 := self definePixelFormat_type: SDL_PIXELTYPE_PACKED32 order: SDL_PACKEDORDER_RGBA layout: SDL_PACKEDLAYOUT_8888 bits: 32 bytes: 4.
	SDL_PIXELFORMAT_ARGB8888 := self definePixelFormat_type: SDL_PIXELTYPE_PACKED32 order: SDL_PACKEDORDER_ARGB layout: SDL_PACKEDLAYOUT_8888 bits: 32 bytes: 4.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeKeycodes3
	SDLK_ALTERASE	:= 16r40000099.
	SDLK_SYSREQ	:= 16r4000009A.
	SDLK_CANCEL	:= 16r4000009B.
	SDLK_CLEAR	:= 16r4000009C.
	SDLK_PRIOR	:= 16r4000009D.
	SDLK_RETURN2	:= 16r4000009E.
	SDLK_SEPARATOR	:= 16r4000009F.
	SDLK_OUT	:= 16r400000A0.
	SDLK_OPER	:= 16r400000A1.
	SDLK_CLEARAGAIN	:= 16r400000A2.
	SDLK_CRSEL	:= 16r400000A3.
	SDLK_EXSEL	:= 16r400000A4.
	SDLK_KP_00	:= 16r400000B0.
	SDLK_KP_000	:= 16r400000B1.
	SDLK_THOUSANDSSEPARATOR	:= 16r400000B2.
	SDLK_DECIMALSEPARATOR	:= 16r400000B3.
	SDLK_CURRENCYUNIT	:= 16r400000B4.
	SDLK_CURRENCYSUBUNIT	:= 16r400000B5.
	SDLK_KP_LEFTPAREN	:= 16r400000B6.
	SDLK_KP_RIGHTPAREN	:= 16r400000B7.
	SDLK_KP_LEFTBRACE	:= 16r400000B8.
	SDLK_KP_RIGHTBRACE	:= 16r400000B9.
	SDLK_KP_TAB	:= 16r400000BA.
	SDLK_KP_BACKSPACE	:= 16r400000BB.
	SDLK_KP_A	:= 16r400000BC.
	SDLK_KP_B	:= 16r400000BD.
	SDLK_KP_C	:= 16r400000BE.
	SDLK_KP_D	:= 16r400000BF.
	SDLK_KP_E	:= 16r400000C0.
	SDLK_KP_F	:= 16r400000C1.
	SDLK_KP_XOR	:= 16r400000C2.
	SDLK_KP_POWER	:= 16r400000C3.
	SDLK_KP_PERCENT	:= 16r400000C4.
	SDLK_KP_LESS	:= 16r400000C5.
	SDLK_KP_GREATER	:= 16r400000C6.
	SDLK_KP_AMPERSAND	:= 16r400000C7.
	SDLK_KP_DBLAMPERSAND	:= 16r400000C8.
	SDLK_KP_VERTICALBAR	:= 16r400000C9.
	SDLK_KP_DBLVERTICALBAR	:= 16r400000CA.
	SDLK_KP_COLON	:= 16r400000CB.
	SDLK_KP_HASH	:= 16r400000CC.
	SDLK_KP_SPACE	:= 16r400000CD.
	SDLK_KP_AT	:= 16r400000CE.
	SDLK_KP_EXCLAM	:= 16r400000CF.
	SDLK_KP_MEMSTORE	:= 16r400000D0.
	SDLK_KP_MEMRECALL	:= 16r400000D1.
	SDLK_KP_MEMCLEAR	:= 16r400000D2.
	SDLK_KP_MEMADD	:= 16r400000D3.
	SDLK_KP_MEMSUBTRACT	:= 16r400000D4.
	SDLK_KP_MEMMULTIPLY	:= 16r400000D5.
	SDLK_KP_MEMDIVIDE	:= 16r400000D6.
	SDLK_KP_PLUSMINUS	:= 16r400000D7.
	SDLK_KP_CLEAR	:= 16r400000D8.
	SDLK_KP_CLEARENTRY	:= 16r400000D9.
	SDLK_KP_BINARY	:= 16r400000DA.
	SDLK_KP_OCTAL	:= 16r400000DB.
	SDLK_KP_DECIMAL	:= 16r400000DC.
	SDLK_KP_HEXADECIMAL	:= 16r400000DD.
	SDLK_LCTRL	:= 16r400000E0.
	SDLK_LSHIFT	:= 16r400000E1.
	SDLK_LALT	:= 16r400000E2.
	SDLK_LGUI	:= 16r400000E3.
	SDLK_RCTRL	:= 16r400000E4.
	SDLK_RSHIFT	:= 16r400000E5.
	SDLK_RALT	:= 16r400000E6.
	SDLK_RGUI	:= 16r400000E7.
	SDLK_MODE	:= 16r40000101.
	SDLK_AUDIONEXT	:= 16r40000102.
	SDLK_AUDIOPREV	:= 16r40000103.
	SDLK_AUDIOSTOP	:= 16r40000104.
	SDLK_AUDIOPLAY	:= 16r40000105.
	SDLK_AUDIOMUTE	:= 16r40000106.
	SDLK_MEDIASELECT	:= 16r40000107.
	SDLK_WWW	:= 16r40000108.
	SDLK_MAIL	:= 16r40000109.
	SDLK_CALCULATOR	:= 16r4000010A.
	SDLK_COMPUTER	:= 16r4000010B.
	SDLK_AC_SEARCH	:= 16r4000010C.
	SDLK_AC_HOME	:= 16r4000010D.
	SDLK_AC_BACK	:= 16r4000010E.
	SDLK_AC_FORWARD	:= 16r4000010F.
	SDLK_AC_STOP	:= 16r40000110.
	SDLK_AC_REFRESH	:= 16r40000111.
	SDLK_AC_BOOKMARKS	:= 16r40000112.
	SDLK_BRIGHTNESSDOWN	:= 16r40000113.
	SDLK_BRIGHTNESSUP	:= 16r40000114.
	SDLK_DISPLAYSWITCH	:= 16r40000115.
	SDLK_KBDILLUMTOGGLE	:= 16r40000116.
	SDLK_KBDILLUMDOWN	:= 16r40000117.
	SDLK_KBDILLUMUP	:= 16r40000118.
	SDLK_EJECT	:= 16r40000119.
	SDLK_SLEEP	:= 16r4000011A.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeGameController
	SDL_CONTROLLER_AXIS_INVALID := -1.
	SDL_CONTROLLER_AXIS_LEFTX := 0.
	SDL_CONTROLLER_AXIS_LEFTY := 1.
	SDL_CONTROLLER_AXIS_RIGHTX := 2.
	SDL_CONTROLLER_AXIS_RIGHTY := 3.
	SDL_CONTROLLER_AXIS_TRIGGERLEFT := 4.
	SDL_CONTROLLER_AXIS_TRIGGERRIGHT := 5.
	SDL_CONTROLLER_AXIS_MAX := 6.
	
	SDL_CONTROLLER_BUTTON_INVALID := -1.
	SDL_CONTROLLER_BUTTON_A := 0.
	SDL_CONTROLLER_BUTTON_B := 1.
	SDL_CONTROLLER_BUTTON_X := 2.
	SDL_CONTROLLER_BUTTON_Y := 3.
	SDL_CONTROLLER_BUTTON_BACK := 4.
	SDL_CONTROLLER_BUTTON_GUIDE := 5.
	SDL_CONTROLLER_BUTTON_START := 6.
	SDL_CONTROLLER_BUTTON_LEFTSTICK := 7.
	SDL_CONTROLLER_BUTTON_RIGHTSTICK := 8.
	SDL_CONTROLLER_BUTTON_LEFTSHOULDER := 9.
	SDL_CONTROLLER_BUTTON_RIGHTSHOULDER := 10.
	SDL_CONTROLLER_BUTTON_DPAD_UP := 11.
	SDL_CONTROLLER_BUTTON_DPAD_DOWN := 12.
	SDL_CONTROLLER_BUTTON_DPAD_LEFT := 13.
	SDL_CONTROLLER_BUTTON_DPAD_RIGHT := 14.
	SDL_CONTROLLER_BUTTON_MAX := 15.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeAudio
	SDL_AUDIO_MASK_BITSIZE := 16rFF.

	AUDIO_U8        := 16r0008.
	AUDIO_S8        := 16r8008.
	AUDIO_U16LSB    := 16r0010.
	AUDIO_S16LSB    := 16r8010.
	AUDIO_U16MSB    := 16r1010.
	AUDIO_S16MSB    := 16r9010.
	AUDIO_U16       := AUDIO_U16LSB.
	AUDIO_S16       := AUDIO_S16LSB.

	AUDIO_S32LSB    := 16r8020.
	AUDIO_S32MSB    := 16r9020.
	AUDIO_S32       := AUDIO_S32LSB.

	AUDIO_F32LSB    := 16r8120.
	AUDIO_F32MSB    := 16r9120.
	AUDIO_F32       := AUDIO_F32LSB.

	"Audio allow change flags."
	SDL_AUDIO_ALLOW_FREQUENCY_CHANGE    := 16r00000001.
	SDL_AUDIO_ALLOW_FORMAT_CHANGE       := 16r00000002.
	SDL_AUDIO_ALLOW_CHANNELS_CHANGE     := 16r00000004.
	SDL_AUDIO_ALLOW_SAMPLES_CHANGE      := 16r00000008.
	SDL_AUDIO_ALLOW_ANY_CHANGE         := (SDL_AUDIO_ALLOW_FREQUENCY_CHANGE|SDL_AUDIO_ALLOW_FORMAT_CHANGE|SDL_AUDIO_ALLOW_CHANNELS_CHANGE|SDL_AUDIO_ALLOW_SAMPLES_CHANGE).! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
definePixelFormat_type: type order: order layout: playout bits: bits bytes: bytes
	^ ((1 << 28) | ((type) << 24) | ((order) << 20) | ((playout) << 16) |
     	    ((bits) << 8) | ((bytes) << 0))! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeEvent
    SDL_FIRSTEVENT := 0.
    SDL_QUIT           := 16r100.

    "iOS Events"
    SDL_APP_TERMINATING	:= SDL_QUIT + 1.
    SDL_APP_LOWMEMORY	:= SDL_QUIT + 2.
    SDL_APP_WILLENTERBACKGROUND	:= SDL_QUIT + 3.
    SDL_APP_DIDENTERBACKGROUND	:= SDL_QUIT + 4.
    SDL_APP_WILLENTERFOREGROUND	:= SDL_QUIT + 5.
    SDL_APP_DIDENTERFOREGROUND	:= SDL_QUIT + 6.
						
    "Window events"
    SDL_WINDOWEVENT := 16r200.
    SDL_SYSWMEVENT := SDL_WINDOWEVENT + 1.

    "Keyboard events"
    SDL_KEYDOWN  := 16r300.
    SDL_KEYUP			:= SDL_KEYDOWN + 1.
    SDL_TEXTEDITING	:= SDL_KEYDOWN + 2.
    SDL_TEXTINPUT		:= SDL_KEYDOWN + 3.

    "Mouse events"
    SDL_MOUSEMOTION    := 16r400.
    SDL_MOUSEBUTTONDOWN	:= SDL_MOUSEMOTION + 1.
    SDL_MOUSEBUTTONUP		:= SDL_MOUSEMOTION + 2.
    SDL_MOUSEWHEEL			:= SDL_MOUSEMOTION + 3.

    "Joystick events"
    SDL_JOYAXISMOTION  := 16r600.
    SDL_JOYBALLMOTION	:= SDL_JOYAXISMOTION + 1.
    SDL_JOYHATMOTION	:= SDL_JOYAXISMOTION + 2.
    SDL_JOYBUTTONDOWN	:= SDL_JOYAXISMOTION + 3.
    SDL_JOYBUTTONUP		:= SDL_JOYAXISMOTION + 4.
    SDL_JOYDEVICEADDED	:= SDL_JOYAXISMOTION + 5.
    SDL_JOYDEVICEREMOVED	:= SDL_JOYAXISMOTION + 6.

    "Game controller events"
    SDL_CONTROLLERAXISMOTION  := 16r650.
    SDL_CONTROLLERBUTTONDOWN	:= SDL_CONTROLLERAXISMOTION + 1.
    SDL_CONTROLLERBUTTONUP	 	:= SDL_CONTROLLERAXISMOTION + 2.
    SDL_CONTROLLERDEVICEADDED 	:= SDL_CONTROLLERAXISMOTION + 3.
    SDL_CONTROLLERDEVICEREMOVED	:= SDL_CONTROLLERAXISMOTION + 4.
    SDL_CONTROLLERDEVICEREMAPPED	:= SDL_CONTROLLERAXISMOTION + 5.

    "Touch events"
    SDL_FINGERDOWN	:= 16r700.
    SDL_FINGERUP		:= SDL_FINGERDOWN + 1.
    SDL_FINGERMOTION	:= SDL_FINGERDOWN + 2.

    "Gesture events"
    SDL_DOLLARGESTURE  := 16r800.
    SDL_DOLLARRECORD := SDL_DOLLARGESTURE + 1.
    SDL_MULTIGESTURE := SDL_DOLLARGESTURE + 2.

    "Clipboard events"
    SDL_CLIPBOARDUPDATE := 16r900.

    "Drag and drop events"
    SDL_DROPFILE        := 16r1000.

    "/** Events ::SDL_USEREVENT through ::SDL_LASTEVENT are for your use,
     *  and should be allocated with SDL_RegisterEvents()
     */"
    SDL_USEREVENT    := 16r8000.

    "/**
     *  This last event is only for bounding internal arrays
     */"
    SDL_LASTEVENT    := 16rFFFF! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
SDL_BUTTON: button
	^ (1 << ((button)-1))! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeMouse
	SDL_BUTTON_LEFT 	:= 1.
	SDL_BUTTON_MIDDLE	:=  2.
	SDL_BUTTON_RIGHT	:= 3.
	SDL_BUTTON_X1		:= 4.
	SDL_BUTTON_X2		:= 5.
	SDL_BUTTON_LMASK	:= self SDL_BUTTON: SDL_BUTTON_LEFT.
	SDL_BUTTON_MMASK	:= self SDL_BUTTON: SDL_BUTTON_MIDDLE.
	SDL_BUTTON_RMASK	:= self SDL_BUTTON: SDL_BUTTON_RIGHT.
	SDL_BUTTON_X1MASK	:= self SDL_BUTTON: SDL_BUTTON_X1.
	SDL_BUTTON_X2MASK  := self SDL_BUTTON: SDL_BUTTON_X2.! !

!SDL2Constants class methodsFor: 'class initialization' stamp: ''!
initializeOpenGLProfile
	 SDL_GL_CONTEXT_PROFILE_CORE           := 1.
    SDL_GL_CONTEXT_PROFILE_COMPATIBILITY  := 2.
    SDL_GL_CONTEXT_PROFILE_ES             := 4.! !

!SDL2ConstantsHint commentStamp: ''!
I contain configure HINTS.
All HINTS can be seen here: https://wiki.libsdl.org/CategoryHints!
!SDL2ConstantsHint class methodsFor: 'class initialization' stamp: ''!
initialize
	SDL_HINT_FRAMEBUFFER_ACCELERATION   := 'SDL_FRAMEBUFFER_ACCELERATION'.
	SDL_HINT_RENDER_DRIVER              := 'SDL_RENDER_DRIVER'.
	SDL_HINT_RENDER_OPENGL_SHADERS      := 'SDL_RENDER_OPENGL_SHADERS'.
	SDL_HINT_RENDER_DIRECT3D_THREADSAFE := 'SDL_RENDER_DIRECT3D_THREADSAFE'.
	SDL_HINT_RENDER_DIRECT3D11_DEBUG    := 'SDL_RENDER_DIRECT3D11_DEBUG'.
	SDL_HINT_RENDER_LOGICAL_SIZE_MODE   := 'SDL_RENDER_LOGICAL_SIZE_MODE'.
	SDL_HINT_RENDER_SCALE_QUALITY       := 'SDL_RENDER_SCALE_QUALITY'.
	SDL_HINT_RENDER_VSYNC               := 'SDL_RENDER_VSYNC'.
	SDL_HINT_VIDEO_ALLOW_SCREENSAVER    := 'SDL_VIDEO_ALLOW_SCREENSAVER'.
	SDL_HINT_VIDEO_X11_XVIDMODE         := 'SDL_VIDEO_X11_XVIDMODE'.
	SDL_HINT_VIDEO_X11_XINERAMA         := 'SDL_VIDEO_X11_XINERAMA'.
	SDL_HINT_VIDEO_X11_XRANDR           := 'SDL_VIDEO_X11_XRANDR'.
	SDL_HINT_VIDEO_X11_NET_WM_PING      := 'SDL_VIDEO_X11_NET_WM_PING'.
	SDL_HINT_WINDOW_FRAME_USABLE_WHILE_CURSOR_HIDDEN    := 'SDL_WINDOW_FRAME_USABLE_WHILE_CURSOR_HIDDEN'.
	SDL_HINT_WINDOWS_INTRESOURCE_ICON       := 'SDL_WINDOWS_INTRESOURCE_ICON'.
	SDL_HINT_WINDOWS_INTRESOURCE_ICON_SMALL := 'SDL_WINDOWS_INTRESOURCE_ICON_SMALL'.
	SDL_HINT_WINDOWS_ENABLE_MESSAGELOOP := 'SDL_WINDOWS_ENABLE_MESSAGELOOP'.
	SDL_HINT_GRAB_KEYBOARD              := 'SDL_GRAB_KEYBOARD'.
	SDL_HINT_MOUSE_NORMAL_SPEED_SCALE    := 'SDL_MOUSE_NORMAL_SPEED_SCALE'.
	SDL_HINT_MOUSE_RELATIVE_SPEED_SCALE    := 'SDL_MOUSE_RELATIVE_SPEED_SCALE'.
	SDL_HINT_MOUSE_RELATIVE_MODE_WARP    := 'SDL_MOUSE_RELATIVE_MODE_WARP'.
	SDL_HINT_MOUSE_FOCUS_CLICKTHROUGH := 'SDL_MOUSE_FOCUS_CLICKTHROUGH'.
	SDL_HINT_TOUCH_MOUSE_EVENTS    := 'SDL_TOUCH_MOUSE_EVENTS'.
	SDL_HINT_VIDEO_MINIMIZE_ON_FOCUS_LOSS   := 'SDL_VIDEO_MINIMIZE_ON_FOCUS_LOSS'.
	SDL_HINT_IDLE_TIMER_DISABLED := 'SDL_IOS_IDLE_TIMER_DISABLED'.
	SDL_HINT_ORIENTATIONS := 'SDL_IOS_ORIENTATIONS'.
	SDL_HINT_APPLE_TV_CONTROLLER_UI_EVENTS := 'SDL_APPLE_TV_CONTROLLER_UI_EVENTS'.
	SDL_HINT_APPLE_TV_REMOTE_ALLOW_ROTATION := 'SDL_APPLE_TV_REMOTE_ALLOW_ROTATION'.
	SDL_HINT_ACCELEROMETER_AS_JOYSTICK := 'SDL_ACCELEROMETER_AS_JOYSTICK'.
	SDL_HINT_XINPUT_ENABLED := 'SDL_XINPUT_ENABLED'.
	SDL_HINT_XINPUT_USE_OLD_JOYSTICK_MAPPING := 'SDL_XINPUT_USE_OLD_JOYSTICK_MAPPING'.
	SDL_HINT_GAMECONTROLLERCONFIG := 'SDL_GAMECONTROLLERCONFIG'.
	SDL_HINT_GAMECONTROLLER_IGNORE_DEVICES := 'SDL_GAMECONTROLLER_IGNORE_DEVICES'.
	SDL_HINT_GAMECONTROLLER_IGNORE_DEVICES_EXCEPT := 'SDL_GAMECONTROLLER_IGNORE_DEVICES_EXCEPT'.
	SDL_HINT_JOYSTICK_ALLOW_BACKGROUND_EVENTS := 'SDL_JOYSTICK_ALLOW_BACKGROUND_EVENTS'.
	SDL_HINT_ALLOW_TOPMOST := 'SDL_ALLOW_TOPMOST'.
	SDL_HINT_TIMER_RESOLUTION := 'SDL_TIMER_RESOLUTION'.
	SDL_HINT_QTWAYLAND_CONTENT_ORIENTATION := 'SDL_QTWAYLAND_CONTENT_ORIENTATION'.
	SDL_HINT_QTWAYLAND_WINDOW_FLAGS := 'SDL_QTWAYLAND_WINDOW_FLAGS'.
	SDL_HINT_THREAD_STACK_SIZE              := 'SDL_THREAD_STACK_SIZE'.
	SDL_HINT_VIDEO_HIGHDPI_DISABLED := 'SDL_VIDEO_HIGHDPI_DISABLED'.
	SDL_HINT_MAC_CTRL_CLICK_EMULATE_RIGHT_CLICK := 'SDL_MAC_CTRL_CLICK_EMULATE_RIGHT_CLICK'.
	SDL_HINT_VIDEO_WIN_D3DCOMPILER              := 'SDL_VIDEO_WIN_D3DCOMPILER'.
	SDL_HINT_VIDEO_WINDOW_SHARE_PIXEL_FORMAT    := 'SDL_VIDEO_WINDOW_SHARE_PIXEL_FORMAT'.
	SDL_HINT_WINRT_PRIVACY_POLICY_URL := 'SDL_WINRT_PRIVACY_POLICY_URL'.
	SDL_HINT_WINRT_PRIVACY_POLICY_LABEL := 'SDL_WINRT_PRIVACY_POLICY_LABEL'.
	SDL_HINT_WINRT_HANDLE_BACK_BUTTON := 'SDL_WINRT_HANDLE_BACK_BUTTON'.
	SDL_HINT_VIDEO_MAC_FULLSCREEN_SPACES    := 'SDL_VIDEO_MAC_FULLSCREEN_SPACES'.
	SDL_HINT_MAC_BACKGROUND_APP    := 'SDL_MAC_BACKGROUND_APP'.
	SDL_HINT_ANDROID_APK_EXPANSION_MAIN_FILE_VERSION := 'SDL_ANDROID_APK_EXPANSION_MAIN_FILE_VERSION'.
	SDL_HINT_ANDROID_APK_EXPANSION_PATCH_FILE_VERSION := 'SDL_ANDROID_APK_EXPANSION_PATCH_FILE_VERSION'.
	SDL_HINT_IME_INTERNAL_EDITING := 'SDL_IME_INTERNAL_EDITING'.
	SDL_HINT_ANDROID_SEPARATE_MOUSE_AND_TOUCH := 'SDL_ANDROID_SEPARATE_MOUSE_AND_TOUCH'.
	SDL_HINT_EMSCRIPTEN_KEYBOARD_ELEMENT   := 'SDL_EMSCRIPTEN_KEYBOARD_ELEMENT'.
	SDL_HINT_NO_SIGNAL_HANDLERS   := 'SDL_NO_SIGNAL_HANDLERS'.
	SDL_HINT_WINDOWS_NO_CLOSE_ON_ALT_F4	:= 'SDL_WINDOWS_NO_CLOSE_ON_ALT_F4'.
	SDL_HINT_BMP_SAVE_LEGACY_FORMAT := 'SDL_BMP_SAVE_LEGACY_FORMAT'.
	SDL_HINT_WINDOWS_DISABLE_THREAD_NAMING := 'SDL_WINDOWS_DISABLE_THREAD_NAMING'.
	SDL_HINT_RPI_VIDEO_LAYER           := 'SDL_RPI_VIDEO_LAYER'.
	SDL_HINT_OPENGL_ES_DRIVER   := 'SDL_OPENGL_ES_DRIVER'.
	SDL_HINT_AUDIO_RESAMPLING_MODE   := 'SDL_AUDIO_RESAMPLING_MODE'.
	SDL_HINT_AUDIO_CATEGORY   := 'SDL_AUDIO_CATEGORY'.! !

!SDL2Error commentStamp: ''!
I am the Pharo Local Exception return that something wrong in SDL2!
!SDL2EventHandler commentStamp: ''!
I am an interface (abstract) used for visiting the raw SDL2 events. 
!
!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitJoyButtonUpEvent: windowEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitJoyDeviceRemovedEvent: joyDeviceEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitControllerDeviceRemappedEvent: controllerDeviceEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitWindowEvent: windowEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitControllerDeviceAddedEvent: controllerDeviceEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitJoyButtonDownEvent: windowEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitControllerButtonUpEvent: controllerButtonEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitMouseButtonDownEvent: mouseMotionEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitTextInputEvent: windowEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitControllerButtonDownEvent: controllerButtonEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitControllerDeviceRemovedEvent: controllerDeviceEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitJoyDeviceAddedEvent: joyDeviceEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitKeyUpEvent: windowEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitMouseMotionEvent: mouseMotionEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitSystemWindowEvent: systemWindowEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitControllerAxisEvent: controllerAxisEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitCommonEvent: commonEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitJoyAxisEvent: windowEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitKeyDownEvent: windowEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitMouseWheelEvent: mouseMotionEvent! !

!SDL2EventHandler methodsFor: 'visitor' stamp: ''!
visitMouseButtonUpEvent: mouseMotionEvent! !

!SDL2Example commentStamp: ''!
Couple examples..!
!SDL2Example methodsFor: 'examples' stamp: ''!
osWindow
	"
	self new osWindow
	"
	| attrs window |
	attrs := OSWindowAttributes new.
	attrs preferableDriver: OSSDL2Driver new;
		extent: Display extent.
	window := OSWindow createWithAttributes: attrs.
	window eventHandler: (OSWindowMorphicEventHandler for: self currentWorld).
	window newFormRenderer: Display.
	^window! !

!SDL2Example methodsFor: 'examples' stamp: ''!
simpleWindow
	"
	self new simpleWindow
	"
	| window |
	SDL2 initVideo.
	window := SDL2 createWindow: 'Test Window'
					x: SDL_WINDOWPOS_UNDEFINED
					y: SDL_WINDOWPOS_UNDEFINED
					width: 640
					height: 480
					flags: SDL_WINDOW_SHOWN.
	SDL2 delay: 3000.
	window destroy.! !

!SDL2Example methodsFor: 'examples' stamp: ''!
simpleDrawWindow
	"
	self new simpleDrawWindow
	"
	| window renderer |
	SDL2 initVideo.
	window := SDL2 createWindow: 'Test Window'
					x: SDL_WINDOWPOS_UNDEFINED
					y: SDL_WINDOWPOS_UNDEFINED
					width: 640
					height: 480
					flags: SDL_WINDOW_SHOWN.
	renderer := window createDefaultRenderer.
	SDL2 delay: 1000.
	renderer drawColorR: 0 g: 0 b: 0 a: 0;
			  clear;
			  drawColorR: 0 g: 255 b: 0 a: 255;
			  drawPointX: 50 y: 50;  
			  present.
	SDL2 delay: 1000.
	renderer
			  drawColorR: 255 g: 0 b: 0 a: 255;
			  drawLineX1: 30 y1: 30 x2: 500 y2: 30;
			  present.
	SDL2 delay: 3000.
	renderer destroy.
	window destroy.! !

!SDL2Example methodsFor: 'examples' stamp: ''!
simpleDrawDisplay
	"
	self new simpleDrawDisplay
	"
	| window renderer texture   |
	
	"Create the window and the renderer."
	SDL2 initVideo.
	window := SDL2 createWindow: 'Test Window'
					x: SDL_WINDOWPOS_UNDEFINED
					y: SDL_WINDOWPOS_UNDEFINED
					width: 1024
					height: 480
					flags: SDL_WINDOW_SHOWN.
	renderer := window createDefaultRenderer.
	
	"Create the texture"
	texture := renderer createTextureFormat: SDL_PIXELFORMAT_XRGB8888
						access: SDL_TEXTUREACCESS_STREAMING width: Display width height: Display height.
	texture updateTexturePixels: Display bits pitch: Display width*4.
	
	"Render"
	renderer copy: texture;
			  present.
	SDL2 delay: 3000.
	
	"Quit"
	texture destroy.
	renderer destroy.
	window destroy.! !

!SDL2Example methodsFor: 'examples' stamp: ''!
simpleBlackWindow
	"
	self new simpleBlackWindow
	"
	| window renderer |
	SDL2 initVideo.
	window := SDL2 createWindow: 'Test Window'
					x: SDL_WINDOWPOS_UNDEFINED
					y: SDL_WINDOWPOS_UNDEFINED
					width: 640
					height: 480
					flags: SDL_WINDOW_SHOWN.
	renderer := window createDefaultRenderer.
	renderer drawColorR: 0 g: 0 b: 0 a: 0;
			  clear;
			  present.
	SDL2 delay: 3000.
	renderer destroy.
	window destroy.! !

!SDL2Handle commentStamp: ''!
My subclasses represent various handles coming from SDL2 library!
!SDL2Handle methodsFor: 'nb-library' stamp: ''!
ffiLibraryName
	^self class ffiLibraryName! !

!SDL2Handle class methodsFor: 'accessing' stamp: ''!
ffiLibraryName
	^ SDL2 ffiLibraryName! !

!SDL2MappedEvent commentStamp: ''!
SDL2 library structure!
!SDL2MappedEvent methodsFor: 'accessing' stamp: ''!
windowID
	^ nil! !

!SDL2MappedEvent methodsFor: 'testing' stamp: ''!
isKeyDownEvent

	^ false! !

!SDL2MappedEvent methodsFor: 'testing' stamp: ''!
isUserInterrupt

	^ false! !

!SDL2MappedEvent methodsFor: 'testing' stamp: ''!
isKeyUpEvent

	^ false! !

!SDL2MappedEvent methodsFor: 'testing' stamp: ''!
isClipboardUpdateEvent

	^ false! !

!SDL2MappedEvent methodsFor: 'testing' stamp: ''!
isUserInterruptKillAll

	^ false! !

!SDL2MappedEvent methodsFor: 'event type' stamp: ''!
eventType
	^ nil! !

!SDL2MappedEvent class methodsFor: 'instance creation' stamp: ''!
fromSdlEvent: event
	"SDL event handlers are copied because there are allocated in Pharo memory as a bytearray"
	^  self new setHandle: event getHandle copy! !

!SDL2MappedEvent class methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	self subclassResponsibility! !

!SDL2MappedEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ nil! !

!SDL2ScanCodeConstants class methodsFor: 'class initialization' stamp: ''!
initialize

	self initializeScanCodes! !

!SDL2ScanCodeConstants class methodsFor: 'private - initialization' stamp: ''!
initializeScanCodes

	SDL_SCANCODE_COMMA := 54.
	SDL_SCANCODE_PERIOD := 55.! !

!SDL2SpecialCharacterMapping commentStamp: ''!
This class keeps a maps for key symbols that are represented by Morphic as special characters.!
!SDL2SpecialCharacterMapping class methodsFor: 'class initialization' stamp: ''!
initialize
	"
	self initialize
	"
	Mapping := Dictionary new.
	{
	 SDLK_RETURN . Character cr.
	 SDLK_KP_ENTER. Character cr.
	 SDLK_BACKSPACE . Character backspace.
	 SDLK_TAB . Character tab.
	 SDLK_HOME . Character home.
	 SDLK_LEFT . Character arrowLeft.
	 SDLK_UP . Character arrowUp.
	 SDLK_RIGHT . Character arrowRight.
	 SDLK_DOWN . Character arrowDown.
	 SDLK_END . Character end.
	 SDLK_INSERT . Character insert.
	 SDLK_PAGEUP . Character pageUp.
	 SDLK_PAGEDOWN . Character pageDown.
	 SDLK_DELETE. Character delete.
	} pairsDo: [ :key :val | Mapping at: key put: val ]! !

!SDL2SpecialCharacterMapping class methodsFor: 'symbol mapping' stamp: ''!
mapKeySymbol: keySym ifAbsent: aBlock
	^( Mapping at: keySym ifAbsent: [^ aBlock value ]) asCharacter! !

!SDL2Structure commentStamp: ''!
Common things for all SDL2 structs!
!SDL2Structure methodsFor: 'native' stamp: ''!
ffiLibraryName
	^self class ffiLibraryName! !

!SDL2Structure class methodsFor: 'native' stamp: ''!
ffiLibraryName
	^ SDL2 ffiLibraryName! !

!SDL2TouchExample commentStamp: ''!
Example for multi-touch devices.
!
!SDL2TouchExample methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ Color white! !

!SDL2TouchExample methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	moveToDraw := Dictionary new.! !

!SDL2TouchExample methodsFor: 'factory' stamp: ''!
createEventHandler
	^OSWindowTouchEventHandler new
		touchExample: self;
		yourself! !

!SDL2TouchExample methodsFor: 'drawing' stamp: ''!
redraw
	self clearSurface.
	self drawMoves! !

!SDL2TouchExample methodsFor: 'manage move' stamp: ''!
beginMove: touchId at: position
	moveToDraw at: touchId put: (SDL2TouchStateMachine for: position * self defaultExtent)! !

!SDL2TouchExample methodsFor: 'initialization' stamp: ''!
initializeFromSurface
	circle := renderer athensSurface
		createPath:
			[ :builder | 
			builder
				absolute;
				moveTo: -5 @ 0;
				ccwArcTo: 0 @ 5 angle: 90 degreesToRadians;
				ccwArcTo: 5 @ 0 angle: 90 degreesToRadians;
				ccwArcTo: 0 @ -5 angle: 90 degreesToRadians;
				ccwArcTo: -5 @ 0 angle: 90 degreesToRadians ]! !

!SDL2TouchExample methodsFor: 'drawing' stamp: ''!
clearSurface
	renderer athensSurface
		drawDuring:
			[ :canvas | 
			canvas setPaint: self backgroundColor.
			canvas drawShape: (0 @ 0 extent: self defaultExtent) ]! !

!SDL2TouchExample methodsFor: 'drawing' stamp: ''!
drawMoves
	moveToDraw
		do:
			[ :each | 
			| first last moves color path |
			first := each first.
			last := each finish.
			moves := each move.
			color := each color.
			path := renderer athensSurface
				createPath:
					[ :builder | 
					builder
						absolute;
						moveTo: first.
					moves do: [ :move | builder lineTo: move ] ].
			self drawCircleAt: first color: color.
			renderer athensSurface
				drawDuring: [ :canvas | 
					canvas
						setStrokePaint: color;
						setShape: path;
						draw ].
			last ifNotNil: [ self drawCircleAt: last color: color ] ]! !

!SDL2TouchExample methodsFor: 'manage move' stamp: ''!
move: touchId at: position
	(moveToDraw at: touchId) add: position * self defaultExtent! !

!SDL2TouchExample methodsFor: 'drawing' stamp: ''!
drawCircleAt: point color: color
	renderer athensSurface
		drawDuring: [ :canvas | 
			canvas pathTransform translateBy: point.
			canvas
				setPaint: color;
				setShape: circle;
				draw ]! !

!SDL2TouchExample methodsFor: 'manage move' stamp: ''!
endMove: touchId at: position
	(moveToDraw at: touchId) finish: position * self defaultExtent.
	[ 
	| d |
	d := Delay forMilliseconds: 3000.
	d wait.
	moveToDraw removeKey: touchId ifAbsent: [  ] ] fork! !

!SDL2TouchExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new open! !

!SDL2TouchGestureExample commentStamp: ''!
You can move the circle by scrolling and change his size by pinching!
!SDL2TouchGestureExample methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	circleCenter := (self defaultExtent x / 2) asFloat @ (self defaultExtent y / 2) asFloat.
	circleSize := 10.0! !

!SDL2TouchGestureExample methodsFor: 'manage scrolling' stamp: ''!
beginScroll: anEvent! !

!SDL2TouchGestureExample methodsFor: 'drawing' stamp: ''!
drawCircle
	renderer athensSurface
		drawDuring: [ :canvas | 
			canvas pathTransform translateBy: circleCenter.
			canvas
				setPaint:
						(circleSize positive
								ifTrue: [ Color red ]
								ifFalse: [ Color blue ]);
				setShape: (self generateCircleOfSize: circleSize);
				draw ]! !

!SDL2TouchGestureExample methodsFor: 'factory' stamp: ''!
createEventHandler
	^OSWindowGestureEventHandler new
				touchExample: self;
				registerGesture: OSTouchTwoFingersScrollDetector new;
				registerGesture: OSTouchTwoFingersPinchDetector new;
				yourself! !

!SDL2TouchGestureExample methodsFor: 'drawing' stamp: ''!
redraw
	super redraw.
	self drawCircle! !

!SDL2TouchGestureExample methodsFor: 'manage pinch' stamp: ''!
pinch: anEvent
	circleSize := circleSize + (anEvent dDist * (self defaultExtent distanceTo: 0@0)).! !

!SDL2TouchGestureExample methodsFor: 'drawing' stamp: ''!
generateCircleOfSize: anInteger
	^ renderer athensSurface
		createPath: [ :builder | 
			builder
				absolute;
				moveTo: anInteger negated @ 0;
				ccwArcTo: 0 @ anInteger angle: 90 degreesToRadians;
				ccwArcTo: anInteger @ 0 angle: 90 degreesToRadians;
				ccwArcTo: 0 @ anInteger negated angle: 90 degreesToRadians;
				ccwArcTo: anInteger negated @ 0 angle: 90 degreesToRadians ]! !

!SDL2TouchGestureExample methodsFor: 'manage scrolling' stamp: ''!
scroll: anEvent
	circleCenter := circleCenter
		+ (anEvent direction * (anEvent dDist abs * (self defaultExtent distanceTo: 0 @ 0)))! !

!SDL2TouchGestureExample methodsFor: 'manage scrolling' stamp: ''!
endScroll: anEvent! !

!SDL2TouchGestureExample methodsFor: 'manage pinch' stamp: ''!
endPinch: anEvent! !

!SDL2TouchGestureExample methodsFor: 'manage pinch' stamp: ''!
beginPinch: anEvent! !

!SDL2TouchGestureExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new open! !

!SDL2TouchGestureExample2 commentStamp: ''!
Only one gesture at the time, you can scroll to move the circle, pinch to zoom, rotate to rotate, double tap to change the color of the circle and swipe to have a little surprise!
!SDL2TouchGestureExample2 methodsFor: 'manage swipe' stamp: ''!
endSwipe: anEvent
	blackBackgroundPosition := blackBackgroundPosition abs
		> (window extent x / 2)
		ifTrue: [ 0 ]
		ifFalse: [ window extent x ]! !

!SDL2TouchGestureExample2 methodsFor: 'manage scrolling' stamp: ''!
beginScroll: anEvent! !

!SDL2TouchGestureExample2 methodsFor: 'drawing' stamp: ''!
drawCircle
	renderer athensSurface
		drawDuring: [ :canvas | 
			canvas pathTransform translateBy: circleCenter.
			canvas
				setPaint:
						(circleSize positive
								ifTrue: [ positiveColor ]
								ifFalse: [ negativeColor ]);
				setShape: (self generateCircleOfSize: circleSize);
				draw ]! !

!SDL2TouchGestureExample2 methodsFor: 'manage swipe' stamp: ''!
abortedSwipe
	[ hasAbortedSwipe := true.
	(DelayWaitTimeout forSeconds: 2) wait.
	hasAbortedSwipe := false ] fork! !

!SDL2TouchGestureExample2 methodsFor: 'drawing' stamp: ''!
randomizeCircleColor
	positiveColor := Color random.
	negativeColor := Color random.! !

!SDL2TouchGestureExample2 methodsFor: 'drawing' stamp: ''!
redraw
	discoMode ifTrue: 
		[ self randomizeCircleColor ].
	self clearSurface.
	self drawBlackBackground.
	self drawMoves.
	self drawCircle.
	hasAbortedSwipe
		ifTrue: [ self displayAbortMessage ]! !

!SDL2TouchGestureExample2 methodsFor: 'initialization' stamp: ''!
initializeFromSurface
	super initializeFromSurface.
	blackBackground := renderer athensSurface createSolidColorPaint: Color black! !

!SDL2TouchGestureExample2 methodsFor: 'initialization' stamp: ''!
windowCenter
	^ (self defaultExtent x / 2) asFloat @ (self defaultExtent y / 2) asFloat! !

!SDL2TouchGestureExample2 methodsFor: 'manage swipe' stamp: ''!
swipe: anEvent
	blackBackgroundPosition := blackBackgroundPosition + (anEvent direction x * 1.5)! !

!SDL2TouchGestureExample2 methodsFor: 'drawing' stamp: ''!
drawBlackBackground
	renderer athensSurface
		drawDuring: [ :canvas | 
			canvas setPaint: blackBackground.
			canvas drawShape: (blackBackgroundPosition @ 0 extent: window extent) ]! !

!SDL2TouchGestureExample2 methodsFor: 'drawing' stamp: ''!
changeColors
	positiveColor := Color random.
	negativeColor := Color random! !

!SDL2TouchGestureExample2 methodsFor: 'drawing' stamp: ''!
displayAbortMessage
	renderer athensSurface
		drawDuring: [ :canvas | 
			canvas pathTransform translateBy: self windowCenter x - 30 @ self windowCenter y.
			canvas
				setPaint: Color green;
				setFont: ((LogicalFont familyName: 'Arial' pointSize: 1) emphasis: 1);
				setShape: (renderer athensSurface createPath: [ :builder | builder close ]);
				drawString: 'Swipe Aborted!!';
				draw ]! !

!SDL2TouchGestureExample2 methodsFor: 'manage rotation' stamp: ''!
endRotation: anEvent! !

!SDL2TouchGestureExample2 methodsFor: 'manage rotation' stamp: ''!
beginRotation: anEvent! !

!SDL2TouchGestureExample2 methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	circleCenter := self windowCenter.
	circleSize := 10.
	negativeColor := Color blue.
	positiveColor := Color red.
	hasAbortedSwipe := false.
	blackBackgroundPosition := self defaultExtent x.
	discoMode := false! !

!SDL2TouchGestureExample2 methodsFor: 'manage rotation' stamp: ''!
rotation: anEvent
	circleCenter := circleCenter 
		rotateBy: 2 * anEvent dTheta negated
		about: self windowCenter! !

!SDL2TouchGestureExample2 methodsFor: 'factory' stamp: ''!
createEventHandler
	^ OSWindowGestureEventHandler new
			touchExample: self;
			registerGesture: OSTouchTwoFingersScrollDetector new;
			registerGesture: OSTouchTwoFingersPinchDetector new;
			registerGesture: OSTouchThreeFingersSwipeDetector new;
			registerGesture: OSTouchTwoFingersRotationDetector new;
			registerGesture: OSTouchOneFingerDoubleTapDetector new;
			registerGesture: OSTouchOneFingerHoldDetector new;
			yourself! !

!SDL2TouchGestureExample2 methodsFor: 'manage swipe' stamp: ''!
beginSwipe: anEvent! !

!SDL2TouchGestureExample2 methodsFor: 'manage pinch' stamp: ''!
pinch: anEvent
	circleSize := circleSize + (anEvent dDist * (self defaultExtent distanceTo: 0@0))! !

!SDL2TouchGestureExample2 methodsFor: 'drawing' stamp: ''!
generateCircleOfSize: anInteger
	^ renderer athensSurface
		createPath: [ :builder | 
			builder
				absolute;
				moveTo: anInteger negated @ 0;
				ccwArcTo: 0 @ anInteger angle: 90 degreesToRadians;
				ccwArcTo: anInteger @ 0 angle: 90 degreesToRadians;
				ccwArcTo: 0 @ anInteger negated angle: 90 degreesToRadians;
				ccwArcTo: anInteger negated @ 0 angle: 90 degreesToRadians ]! !

!SDL2TouchGestureExample2 methodsFor: 'manage scrolling' stamp: ''!
scroll: anEvent
	| newCenter |
	newCenter := circleCenter
		+ (anEvent direction abs * (anEvent dDist * (window extent distanceTo: 0 @ 0))).
	(newCenter < window extent and: [ newCenter > (0 @ 0) ])
		ifTrue: [ circleCenter := newCenter ]! !

!SDL2TouchGestureExample2 methodsFor: 'drawing' stamp: ''!
switchDiscoMode
	discoMode := discoMode not! !

!SDL2TouchGestureExample2 methodsFor: 'manage scrolling' stamp: ''!
endScroll: anEvent! !

!SDL2TouchGestureExample2 methodsFor: 'manage pinch' stamp: ''!
endPinch: anEvent! !

!SDL2TouchGestureExample2 methodsFor: 'manage pinch' stamp: ''!
beginPinch: anEvent! !

!SDL2TouchGestureExample2 class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new open! !

!SDL2TouchStateMachine commentStamp: ''!
my role is to record the movements of a finger and associate a color to this movement!
!SDL2TouchStateMachine methodsFor: 'accessing' stamp: ''!
move: anObject
	move := anObject! !

!SDL2TouchStateMachine methodsFor: 'accessing' stamp: ''!
add: aPoint
	move add: aPoint.! !

!SDL2TouchStateMachine methodsFor: 'accessing' stamp: ''!
first: anObject
	first := anObject! !

!SDL2TouchStateMachine methodsFor: 'initialization' stamp: ''!
initialize
	move := OrderedCollection new.
	color := Color random.! !

!SDL2TouchStateMachine methodsFor: 'accessing' stamp: ''!
move
	^ move! !

!SDL2TouchStateMachine methodsFor: 'accessing' stamp: ''!
finish: anObject
	finish := anObject.
	move add: anObject.! !

!SDL2TouchStateMachine methodsFor: 'accessing' stamp: ''!
finish
	^ finish! !

!SDL2TouchStateMachine methodsFor: 'accessing' stamp: ''!
first
	^ first! !

!SDL2TouchStateMachine methodsFor: 'accessing' stamp: ''!
color
	^color! !

!SDL2TouchStateMachine class methodsFor: 'instance creation' stamp: ''!
for:	anPosition
	^self new 
		first: anPosition;
		yourself! !

!SDL2TuioObjectStateMachine methodsFor: 'accessing' stamp: ''!
color: anObject
	color := anObject! !

!SDL2TuioObjectStateMachine methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!SDL2TuioObjectStateMachine methodsFor: 'initialization' stamp: ''!
initialize
	position := 0@0.
	color := Color random.
	angle := 0.! !

!SDL2TuioObjectStateMachine methodsFor: 'accessing' stamp: ''!
objectId
	^ objectId! !

!SDL2TuioObjectStateMachine methodsFor: 'accessing' stamp: ''!
position: anObject
	position := anObject! !

!SDL2TuioObjectStateMachine methodsFor: 'accessing' stamp: ''!
angle
	^ angle! !

!SDL2TuioObjectStateMachine methodsFor: 'accessing' stamp: ''!
objectNumber: anObject
	objectNumber := anObject! !

!SDL2TuioObjectStateMachine methodsFor: 'accessing' stamp: ''!
angle: anObject
	angle := anObject! !

!SDL2TuioObjectStateMachine methodsFor: 'accessing' stamp: ''!
objectNumber
	^ objectNumber! !

!SDL2TuioObjectStateMachine methodsFor: 'accessing' stamp: ''!
objectId: anObject
	objectId := anObject! !

!SDL2TuioObjectStateMachine methodsFor: 'accessing' stamp: ''!
color
	^color! !

!SDL2Types commentStamp: ''!
Various types used by SDL2!
!SDL2Types class methodsFor: 'class initialization' stamp: ''!
initialize
	"
	self initialize
	"
	Uint8 := #uint8.
	Int8 := #int8.
	Sint8 := #int8.
	Uint16 := #uint16.
	Int16 := #int16.
	Sint16 := #int16.
	Uint32 := #uint32.
	Int32 := #int32.
	Sint32 := #int32.
	Uint64 := #uint64.
	Int64 := #int64.
	Sint64 := #int64.
	
	SDL_Keycode := Sint32.
	SDL_Keymod := Uint32.
	SDL_Scancode := Uint32.
	SDL_BlendMode := Uint32.
	SDL_BlendFactor := Uint32.
	SDL_BlendOperation := Uint32.
	
	SDL_GLattr := #int.
	SDL_AudioDeviceID := #uint32.
	SDL_AudioFormat := #uint16.
	SDL_AudioCallback := #'void*'. "FIXME: use the proper type here."! !

!SDL2Union commentStamp: ''!
Common things for all SDL2 unions.!
!SDL2WindowsMessages commentStamp: ''!
I hold the constasts for Windows messages.!
!SDL2WindowsMessages class methodsFor: 'initialization' stamp: ''!
initialize

"Spliting the initialization of constants. 
The Pharo 9 bootstrap is still building the image first in V3 bytecode and the number of literals is limited.
These methods can be inlined when V3 bytecode is left behind in the bootstrap."

	self initializeVariablesSet1.
	self initializeVariablesSet2.
	self initializeVariablesSet3.
	self initializeVariablesSet4.
	self initializeVariablesSet5.
	self initializeVariablesSet6.
	self initializeVariablesSet7! !

!SDL2WindowsMessages class methodsFor: 'initialization' stamp: ''!
initializeVariablesSet4

	WM_CTLCOLORMSGBOX := 306.
	WM_CTLCOLOREDIT := 307.
	WM_CTLCOLORLISTBOX := 308.
	WM_CTLCOLORBTN := 309.
	WM_CTLCOLORDLG := 310.
	WM_CTLCOLORSCROLLBAR := 311.
	WM_CTLCOLORSTATIC := 312.
	MN_GETHMENU := 481.
	WM_MOUSEFIRST := 512.
	WM_MOUSEMOVE := 512.
	WM_LBUTTONDOWN := 513.
	WM_LBUTTONUP := 514.
	WM_LBUTTONDBLCLK := 515.
	WM_RBUTTONDOWN := 516.
	WM_RBUTTONUP := 517.
	WM_RBUTTONDBLCLK := 518.
	WM_MBUTTONDOWN := 519.
	WM_MBUTTONUP := 520.
	WM_MBUTTONDBLCLK := 521.
	WM_MOUSEWHEEL := 522.
	WM_XBUTTONDOWN := 523.
	WM_XBUTTONUP := 524.
	WM_XBUTTONDBLCLK := 525.
	WM_MOUSEHWHEEL := 526.
	WM_MOUSELAST := 526.
	WM_PARENTNOTIFY := 528.
	WM_ENTERMENULOOP := 529.
	WM_EXITMENULOOP := 530.
	WM_NEXTMENU := 531.
	WM_SIZING := 532.
	WM_CAPTURECHANGED := 533.
	WM_MOVING := 534.
	WM_POWERBROADCAST := 536.
	WM_DEVICECHANGE := 537.
	WM_MDICREATE := 544.
	WM_MDIDESTROY := 545.
	WM_MDIACTIVATE := 546.
	WM_MDIRESTORE := 547.
	WM_MDINEXT := 548.
	WM_MDIMAXIMIZE := 549.
	WM_MDITILE := 550.
	WM_MDICASCADE := 551.
	WM_MDIICONARRANGE := 552.
	WM_MDIGETACTIVE := 553.
	WM_MDISETMENU := 560.
	WM_ENTERSIZEMOVE := 561.
	WM_EXITSIZEMOVE := 562.
	WM_DROPFILES := 563.
	WM_MDIREFRESHMENU := 564.
	WM_POINTERDEVICECHANGE := 568.
	WM_POINTERDEVICEINRANGE := 569.
	WM_POINTERDEVICEOUTOFRANGE := 570.
	WM_TOUCH := 576.
	WM_NCPOINTERUPDATE := 577.
	WM_NCPOINTERDOWN := 578.
	WM_NCPOINTERUP := 579.
	WM_POINTERUPDATE := 581.
	WM_POINTERDOWN := 582.
	WM_POINTERUP := 583.
	WM_POINTERENTER := 585.
	WM_POINTERLEAVE := 586.
	WM_POINTERACTIVATE := 587.
	WM_POINTERCAPTURECHANGED := 588.
	WM_TOUCHHITTESTING := 589.
	WM_POINTERWHEEL := 590.
	WM_POINTERHWHEEL := 591.
	DM_POINTERHITTEST := 592! !

!SDL2WindowsMessages class methodsFor: 'initialization' stamp: ''!
initializeVariablesSet3

	WM_INPUT_DEVICE_CHANGE := 254.
	WM_INPUT := 255.
	WM_KEYFIRST := 256.
	WM_KEYDOWN := 256.
	WM_KEYUP := 257.
	WM_CHAR := 258.
	WM_DEADCHAR := 259.
	WM_SYSKEYDOWN := 260.
	WM_SYSKEYUP := 261.
	WM_SYSCHAR := 262.
	WM_SYSDEADCHAR := 263.
	WM_UNICHAR := 265.
	WM_KEYLAST := 265.
	UNICODE_NOCHAR := 65535.

	WM_IME_STARTCOMPOSITION := 269.
	WM_IME_ENDCOMPOSITION := 270.
	WM_IME_COMPOSITION := 271.
	WM_IME_KEYLAST := 271.
	WM_INITDIALOG := 272.
	WM_COMMAND := 273.
	WM_SYSCOMMAND := 274.
	WM_TIMER := 275.
	WM_HSCROLL := 276.
	WM_VSCROLL := 277.
	WM_INITMENU := 278.
	WM_INITMENUPOPUP := 279.
	WM_GESTURE := 281.
	WM_GESTURENOTIFY := 282.
	WM_MENUSELECT := 287.
	WM_MENUCHAR := 288.
	WM_ENTERIDLE := 289.
	WM_MENURBUTTONUP := 290.
	WM_MENUDRAG := 291.
	WM_MENUGETOBJECT := 292.
	WM_UNINITMENUPOPUP := 293.
	WM_MENUCOMMAND := 294.
	WM_CHANGEUISTATE := 295.
	WM_UPDATEUISTATE := 296.
	WM_QUERYUISTATE := 297! !

!SDL2WindowsMessages class methodsFor: 'initialization' stamp: ''!
initializeVariablesSet5

	WM_IME_SETCONTEXT := 641.
	WM_IME_NOTIFY := 642.
	WM_IME_CONTROL := 643.
	WM_IME_COMPOSITIONFULL := 644.
	WM_IME_SELECT := 645.
	WM_IME_CHAR := 646.
	WM_IME_REQUEST := 648.
	WM_IME_KEYDOWN := 656.
	WM_IME_KEYUP := 657.
	WM_MOUSEHOVER := 673.
	WM_MOUSELEAVE := 675.
	WM_NCMOUSEHOVER := 672.
	WM_NCMOUSELEAVE := 674.
	WM_WTSSESSION_CHANGE := 689! !

!SDL2WindowsMessages class methodsFor: 'querying' stamp: ''!
translateId: aNumber

	^ self classPool associations
		  detect: [ :assoc | assoc value = aNumber ]
		  ifFound: [ :assoc | assoc key ]
		  ifNone: [ 'Unknown Message ' , aNumber printString ]! !

!SDL2WindowsMessages class methodsFor: 'initialization' stamp: ''!
initializeVariablesSet6

	WM_TABLET_FIRST := 704.
	WM_TABLET_LAST := 735.
	WM_DPICHANGED := 736.
	WM_CUT := 768.
	WM_COPY := 769.
	WM_PASTE := 770.
	WM_CLEAR := 771.
	WM_UNDO := 772.
	WM_RENDERFORMAT := 773.
	WM_RENDERALLFORMATS := 774.
	WM_DESTROYCLIPBOARD := 775.
	WM_DRAWCLIPBOARD := 776.
	WM_PAINTCLIPBOARD := 777.
	WM_VSCROLLCLIPBOARD := 778.
	WM_SIZECLIPBOARD := 779.
	WM_ASKCBFORMATNAME := 780.
	WM_CHANGECBCHAIN := 781.
	WM_HSCROLLCLIPBOARD := 782.
	WM_QUERYNEWPALETTE := 783.
	WM_PALETTEISCHANGING := 784.
	WM_PALETTECHANGED := 785.
	WM_HOTKEY := 786.
	WM_PRINT := 791.
	WM_PRINTCLIENT := 792.
	WM_APPCOMMAND := 793.
	WM_THEMECHANGED := 794.
	WM_CLIPBOARDUPDATE := 797.
	WM_DWMCOMPOSITIONCHANGED := 798.
	WM_DWMNCRENDERINGCHANGED := 799! !

!SDL2WindowsMessages class methodsFor: 'initialization' stamp: ''!
initializeVariablesSet2

	WM_CONTEXTMENU := 123.
	WM_STYLECHANGING := 124.
	WM_STYLECHANGED := 125.
	WM_DISPLAYCHANGE := 126.
	WM_GETICON := 127.
	WM_SETICON := 128.
	WM_NCCREATE := 129.
	WM_NCDESTROY := 130.
	WM_NCCALCSIZE := 131.
	WM_NCHITTEST := 132.
	WM_NCPAINT := 133.
	WM_NCACTIVATE := 134.
	WM_GETDLGCODE := 135.
	WM_SYNCPAINT := 136.
	WM_NCMOUSEMOVE := 160.
	WM_NCLBUTTONDOWN := 161.
	WM_NCLBUTTONUP := 162.
	WM_NCLBUTTONDBLCLK := 163.
	WM_NCRBUTTONDOWN := 164.
	WM_NCRBUTTONUP := 165.
	WM_NCRBUTTONDBLCLK := 166.
	WM_NCMBUTTONDOWN := 167.
	WM_NCMBUTTONUP := 168.
	WM_NCMBUTTONDBLCLK := 169.
	WM_NCXBUTTONDOWN := 171.
	WM_NCXBUTTONUP := 172.
	WM_NCXBUTTONDBLCLK := 173.! !

!SDL2WindowsMessages class methodsFor: 'initialization' stamp: ''!
initializeVariablesSet1

	WM_NULL := 0.
	WM_CREATE := 1.
	WM_DESTROY := 2.
	WM_MOVE := 3.
	WM_SIZE := 5.
	WM_ACTIVATE := 6.
	WM_SETFOCUS := 7.
	WM_KILLFOCUS := 8.
	WM_ENABLE := 10.
	WM_SETREDRAW := 11.
	WM_SETTEXT := 12.
	WM_GETTEXT := 13.
	WM_GETTEXTLENGTH := 14.
	WM_PAINT := 15.
	WM_CLOSE := 16.
	WM_QUERYENDSESSION := 17.
	WM_QUERYOPEN := 19.
	WM_ENDSESSION := 22.
	WM_QUIT := 18.
	WM_ERASEBKGND := 20.
	WM_SYSCOLORCHANGE := 21.
	WM_SHOWWINDOW := 24.
	WM_WININICHANGE := 26.
	WM_SETTINGCHANGE := 26.
	WM_DEVMODECHANGE := 27.
	WM_ACTIVATEAPP := 28.
	WM_FONTCHANGE := 29.
	WM_TIMECHANGE := 30.
	WM_CANCELMODE := 31.
	WM_SETCURSOR := 32.
	WM_MOUSEACTIVATE := 33.
	WM_CHILDACTIVATE := 34.
	WM_QUEUESYNC := 35.
	WM_GETMINMAXINFO := 36.
	WM_PAINTICON := 38.
	WM_ICONERASEBKGND := 39.
	WM_NEXTDLGCTL := 40.
	WM_SPOOLERSTATUS := 42.
	WM_DRAWITEM := 43.
	WM_MEASUREITEM := 44.
	WM_DELETEITEM := 45.
	WM_VKEYTOITEM := 46.
	WM_CHARTOITEM := 47.
	WM_SETFONT := 48.
	WM_GETFONT := 49.
	WM_SETHOTKEY := 50.
	WM_GETHOTKEY := 51.
	WM_QUERYDRAGICON := 55.
	WM_COMPAREITEM := 57.
	WM_GETOBJECT := 61.
	WM_COMPACTING := 65.
	WM_COMMNOTIFY := 68.
	WM_WINDOWPOSCHANGING := 70.
	WM_WINDOWPOSCHANGED := 71.
	WM_POWER := 72.
	WM_COPYDATA := 74.
	WM_CANCELJOURNAL := 75.
	WM_NOTIFY := 78.
	WM_INPUTLANGCHANGEREQUEST := 80.
	WM_INPUTLANGCHANGE := 81.
	WM_TCARD := 82.
	WM_HELP := 83.
	WM_USERCHANGED := 84.
	WM_NOTIFYFORMAT := 85.! !

!SDL2WindowsMessages class methodsFor: 'initialization' stamp: ''!
initializeVariablesSet7

	WM_DWMCOLORIZATIONCOLORCHANGED := 800.
	WM_DWMWINDOWMAXIMIZEDCHANGE := 801.
	WM_DWMSENDICONICTHUMBNAIL := 803.
	WM_DWMSENDICONICLIVEPREVIEWBITMAP := 806.
	WM_GETTITLEBARINFOEX := 831.
	WM_HANDHELDFIRST := 856.
	WM_HANDHELDLAST := 863.
	WM_AFXFIRST := 864.
	WM_AFXLAST := 895.
	WM_PENWINFIRST := 896.
	WM_PENWINLAST := 911.
	WM_APP := 32768.
	WM_USER := 1024! !

!SDLAbstractPlatform commentStamp: ''!
I am a simple class implementing some features of SDL that are platform specific.
Get the corresponding class to use through

 OSPlatform current sdlPlatform!
!SDLAbstractPlatform methodsFor: 'operations' stamp: ''!
afterMainPharoWindowCreated: aOSSDLWindow

	self subclassResponsibility! !

!SDLAbstractPlatform methodsFor: 'initialization' stamp: ''!
initPlatformSpecific

	self subclassResponsibility! !

!SDLAbstractPlatform methodsFor: 'operations' stamp: ''!
afterSetWindowTitle: aString onWindow: aOSSDLWindow

	self subclassResponsibility! !

!SDLAbstractPlatform methodsFor: 'initialization' stamp: ''!
systemCursorConversionTable

	^ #()! !

!SDLNullPlatform commentStamp: ''!
I am the default platform. All my methods are empty or have a default implementation!
!SDLNullPlatform methodsFor: 'operations' stamp: ''!
afterMainPharoWindowCreated: aOSSDLWindow! !

!SDLNullPlatform methodsFor: 'initialization' stamp: ''!
initPlatformSpecific

	"For windows and Unix, we activate linearization.
	This does not work properly on OSX with retina display, blurrying the rendering"
	
	SDL2 setHint: SDL_HINT_RENDER_SCALE_QUALITY value: '1'! !

!SDLNullPlatform methodsFor: 'operations' stamp: ''!
afterSetWindowTitle: aString onWindow: aOSSDLWindow! !

!SDLOSXPlatform commentStamp: ''!
I execute specific operations on SDL for OSX!
!SDLOSXPlatform methodsFor: 'utilities - objectiveC' stamp: ''!
sendMessage: sel to: rcv with: aParam

	^ self ffiCall: #(void* objc_msgSend(void* rcv, void* sel, void* aParam))! !

!SDLOSXPlatform methodsFor: 'utilities - objectiveC' stamp: ''!
sendMessage: sel to: cls

	^ self ffiCall: #(void* objc_msgSend(void* cls, void* sel))! !

!SDLOSXPlatform methodsFor: 'operations' stamp: ''!
afterMainPharoWindowCreated: aOSSDLWindow! !

!SDLOSXPlatform methodsFor: 'utilities - objectiveC' stamp: ''!
lookupSelector: aString

	^ self ffiCall: #(void* sel_registerName(const char *aString))! !

!SDLOSXPlatform methodsFor: 'initialization' stamp: ''!
initPlatformSpecific 
	| sel cls |

	sel := self lookupSelector: 'sharedApplication'.
	cls := self lookupClass: 'NSApplication'.
	self sendMessage: sel to: cls! !

!SDLOSXPlatform methodsFor: 'operations' stamp: ''!
afterSetWindowTitle: aString onWindow: aOSSDLWindow

	| aParam cocoaWindow wmInfo selector |
	aParam := self nsStringOf: aString.

	wmInfo := aOSSDLWindow backendWindow getWMInfo.
	cocoaWindow := wmInfo info cocoa window.

	selector := self lookupSelector: 'setTitleWithRepresentedFilename:'.

	self sendMessage: selector to: cocoaWindow getHandle with: aParam.
	
	self release: aParam.! !

!SDLOSXPlatform methodsFor: 'ffi-calls' stamp: ''!
ffiLibraryName

	^ 'libobjc.dylib'! !

!SDLOSXPlatform methodsFor: 'utilities - objectiveC' stamp: ''!
lookupClass: aString

	^ self ffiCall: #(void* objc_lookUpClass(char *aString))! !

!SDLOSXPlatform methodsFor: 'utilities - objectiveC' stamp: ''!
nsStringOf: aString 

	| class selector encoded param |
	class := self lookupClass: 'NSString'.
	selector:= self lookupSelector: 'stringWithUTF8String:'.
	
	encoded := aString utf8Encoded.
	param := ByteArray new: encoded size + 1.
	param pinInMemory.
	
	LibC memCopy: encoded to: param size: encoded size.
	param at: encoded size + 1 put: 0.
		
	^ self sendMessage: selector to: class with: param! !

!SDLOSXPlatform methodsFor: 'utilities - objectiveC' stamp: ''!
release: aObjCObject 

	| releaseSelector |
	releaseSelector:= self lookupSelector: 'release'.
	self sendMessage: releaseSelector to: aObjCObject.! !

!SDLWindowsPlatform commentStamp: ''!
Specific SDL initialization for Windows!
!SDLWindowsPlatform methodsFor: 'operations' stamp: ''!
afterMainPharoWindowCreated: aOSSDLWindow

	| sdlWindowInfo handle |
	[	sdlWindowInfo := aOSSDLWindow backendWindow getWMInfo.
		handle := sdlWindowInfo info win window.

		self class enableDebugWindowMenu: handle ] 
	onErrorDo: [ 
		"There was an error installing the support for debug Window, the VM is not new enough." ].

	"I want to receive the System Windows events"
	SDL2 eventType: SDL_SYSWMEVENT state: 1.! !

!SDLWindowsPlatform methodsFor: 'initialization' stamp: ''!
initPlatformSpecific

	"For windows and Unix, we activate linearization.
	This does not work properly on OSX with retina display, blurrying the rendering"
	
	SDL2 setHint: SDL_HINT_RENDER_SCALE_QUALITY value: '1'! !

!SDLWindowsPlatform methodsFor: 'operations' stamp: ''!
afterSetWindowTitle: aString onWindow: aOSSDLWindow! !

!SDLWindowsPlatform methodsFor: 'initialization' stamp: ''!
systemCursorConversionTable

	^ {
		 #normal -> #SDL_SYSTEM_CURSOR_ARROW.
       #overEditableText -> #SDL_SYSTEM_CURSOR_IBEAM.
       #wait -> #SDL_SYSTEM_CURSOR_WAIT.
       #crossHair -> #SDL_SYSTEM_CURSOR_CROSSHAIR.
       "#SDL_SYSTEM_CURSOR_WAITARROW."
        #resizeTopLeft -> #SDL_SYSTEM_CURSOR_SIZENWSE.    
		  #resizeBottomRight -> #SDL_SYSTEM_CURSOR_SIZENWSE.
        #resizeBottomLeft -> #SDL_SYSTEM_CURSOR_SIZENESW.
        #resizeTopRight -> #SDL_SYSTEM_CURSOR_SIZENESW.
        #resizeLeft -> #SDL_SYSTEM_CURSOR_SIZEWE.
        #resizeRight -> #SDL_SYSTEM_CURSOR_SIZEWE.
        #resizeBottom -> #SDL_SYSTEM_CURSOR_SIZENS.
        #resizeTop -> #SDL_SYSTEM_CURSOR_SIZENS.
        #move -> #SDL_SYSTEM_CURSOR_SIZEALL.
       "SDL_SYSTEM_CURSOR_NO."
       #webLink -> #SDL_SYSTEM_CURSOR_HAND.	
		
		}! !

!SDLWindowsPlatform class methodsFor: 'operations' stamp: ''!
enableDebugWindowMenu: hwnd

	self ffiCall: #(int enableDebugWindowMenu(void* hwnd)) module: 'PharoVMCore.dll'! !

!SDL_AudioSpec commentStamp: ''!
I provide a description for opening an audio device.!
!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
callback
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_CALLBACK) type: ExternalType void asPointerType! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
silence
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_SILENCE! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
format
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_FORMAT! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
padding: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PADDING put: anObject! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
userdata
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_USERDATA) type: ExternalType void asPointerType! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
freq
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_FREQ! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
samples
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_SAMPLES! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
size
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_SIZE! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
size: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_SIZE put: anObject! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
freq: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_FREQ put: anObject! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
callback: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_CALLBACK put: anObject getHandle.! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
samples: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_SAMPLES put: anObject! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
channels
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_CHANNELS! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
padding
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PADDING! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
format: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_FORMAT put: anObject! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
silence: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_SILENCE put: anObject! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
channels: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_CHANNELS put: anObject! !

!SDL_AudioSpec methodsFor: 'accessing - structure variables' stamp: ''!
userdata: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_USERDATA put: anObject getHandle.! !

!SDL_AudioSpec class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
	 int freq;
	
	 SDL_AudioFormat format;
	 Uint8 channels;
	 Uint8 silence;

	 Uint16 samples;
	 Uint16 padding;

	 Uint32 size;
	 SDL_AudioCallback callback;
	 void* userdata;
 	)! !

!SDL_ClipboardUpdateEvent commentStamp: ''!
I am an event that is generated when the clipboard has been updated by other application.!
!SDL_ClipboardUpdateEvent methodsFor: 'testing' stamp: ''!
isClipboardUpdateEvent

	^ true! !

!SDL_ClipboardUpdateEvent class methodsFor: 'event type' stamp: ''!
eventType 

	^ SDL_CLIPBOARDUPDATE! !

!SDL_Color commentStamp: ''!
SDL2 library structure!
!SDL_Color methodsFor: 'accessing - structure variables' stamp: ''!
b: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_B put: anObject! !

!SDL_Color methodsFor: 'accessing - structure variables' stamp: ''!
r
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_R! !

!SDL_Color methodsFor: 'accessing - structure variables' stamp: ''!
a
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_A! !

!SDL_Color methodsFor: 'accessing - structure variables' stamp: ''!
a: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_A put: anObject! !

!SDL_Color methodsFor: 'accessing - structure variables' stamp: ''!
g: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_G put: anObject! !

!SDL_Color methodsFor: 'accessing - structure variables' stamp: ''!
r: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_R put: anObject! !

!SDL_Color methodsFor: 'accessing - structure variables' stamp: ''!
b
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_B! !

!SDL_Color methodsFor: 'accessing - structure variables' stamp: ''!
g
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_G! !

!SDL_Color class methodsFor: 'fields descriptions' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^#(
    Uint8 r;
    Uint8 g;
    Uint8 b;
    Uint8 a;
 	)! !

!SDL_CommonEvent commentStamp: ''!
SDL2 library structure!
!SDL_CommonEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_CommonEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_CommonEvent methodsFor: 'accessing - structure variables' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream print: { self timestamp }.! !

!SDL_CommonEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_CommonEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitCommonEvent: self! !

!SDL_CommonEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_CommonEvent class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
    		Uint32 type;
    		Uint32 timestamp;
 	)! !

!SDL_ControllerAxisEvent commentStamp: ''!
SDL2 library structure representing a game controller axis event data.!
!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
value: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_VALUE put: anObject! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding4
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PADDING4! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
axis
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_AXIS! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING3 put: anObject! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding4: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PADDING4 put: anObject! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
value
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_VALUE! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
axis: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_AXIS put: anObject! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING3! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_ControllerAxisEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitControllerAxisEvent: self! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_ControllerAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_ControllerAxisEvent class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Sint32 which;
    Uint8 axis;
    Uint8 padding1;
    Uint8 padding2;
    Uint8 padding3;
    Sint16 value;
    Uint16 padding4;
 	)! !

!SDL_ControllerAxisEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_CONTROLLERAXISMOTION! !

!SDL_ControllerButtonDownEvent commentStamp: ''!
SDL2 library structure representing a game controller button down event data.!
!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
button
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BUTTON! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
button: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BUTTON put: anObject! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_ControllerButtonDownEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitControllerButtonDownEvent: self! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_ControllerButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_ControllerButtonDownEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_CONTROLLERBUTTONDOWN! !

!SDL_ControllerButtonEvent commentStamp: ''!
SDL2 library structure representing a game controller button event data.!
!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
button
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BUTTON! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
button: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BUTTON put: anObject! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_ControllerButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_ControllerButtonEvent class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Sint32 which;
    Uint8 button;
    Uint8 state;
    Uint8 padding1;
    Uint8 padding2;
 	)! !

!SDL_ControllerButtonUpEvent commentStamp: ''!
SDL2 library structure representing a game controller button up event data.!
!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
button
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BUTTON! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
button: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BUTTON put: anObject! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_ControllerButtonUpEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitControllerButtonUpEvent: self! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_ControllerButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_ControllerButtonUpEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_CONTROLLERBUTTONUP! !

!SDL_ControllerDeviceAddedEvent commentStamp: ''!
SDL2 library structure representing a controller device added event data.!
!SDL_ControllerDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_ControllerDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_ControllerDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_ControllerDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_ControllerDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_ControllerDeviceAddedEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitControllerDeviceAddedEvent: self! !

!SDL_ControllerDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_ControllerDeviceAddedEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_CONTROLLERDEVICEADDED! !

!SDL_ControllerDeviceEvent commentStamp: ''!
SDL2 library structure representing a controller device event data.!
!SDL_ControllerDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_ControllerDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_ControllerDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_ControllerDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_ControllerDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_ControllerDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_ControllerDeviceEvent class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Sint32 which;
 	)! !

!SDL_ControllerDeviceRemappedEvent commentStamp: ''!
SDL2 library structure representing a controller device remapped event data.!
!SDL_ControllerDeviceRemappedEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_ControllerDeviceRemappedEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_ControllerDeviceRemappedEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_ControllerDeviceRemappedEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_ControllerDeviceRemappedEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_ControllerDeviceRemappedEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitControllerDeviceRemappedEvent: self! !

!SDL_ControllerDeviceRemappedEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_ControllerDeviceRemappedEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_CONTROLLERDEVICEREMAPPED! !

!SDL_ControllerDeviceRemovedEvent commentStamp: ''!
SDL2 library structure representing a controller device removed data.!
!SDL_ControllerDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_ControllerDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_ControllerDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_ControllerDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_ControllerDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_ControllerDeviceRemovedEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitControllerDeviceRemovedEvent: self! !

!SDL_ControllerDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_ControllerDeviceRemovedEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_CONTROLLERDEVICEREMOVED! !

!SDL_Cursor commentStamp: ''!
I represent  handle of a mouse cursor.!
!SDL_Cursor methodsFor: 'using the cursor' stamp: ''!
setCursor
	^ self ffiCall: #( void SDL_SetCursor ( self ) )! !

!SDL_Cursor methodsFor: 'freeing resources' stamp: ''!
freeCursor
	^ self ffiCall: #( void SDL_FreeCursor ( self ) )! !

!SDL_DropEvent commentStamp: ''!
SDL2 library structure representing a dropped file into the window.!
!SDL_DropEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_DropEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_DropEvent methodsFor: 'accessing - structure variables' stamp: ''!
file: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_FILE put: anObject getHandle.! !

!SDL_DropEvent methodsFor: 'accessing - structure variables' stamp: ''!
file
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_FILE) type: ExternalType char asPointerType! !

!SDL_DropEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_DropEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitDropEvent: self! !

!SDL_DropEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_DropEvent class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    char* file;
 	)! !

!SDL_DropEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_DROPFILE! !

!SDL_Event commentStamp: ''!
This is a raw SDL2 event!
!SDL_Event methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self setHandle: (ByteArray new: 56)! !

!SDL_Event methodsFor: 'accessing' stamp: ''!
unknownEvent
	^ SDL_CommonEvent fromSdlEvent: self! !

!SDL_Event methodsFor: 'accessing' stamp: ''!
type
	^self getHandle unsignedLongAt: 1! !

!SDL_Event methodsFor: 'accessing' stamp: ''!
mapped
	"This method converts a raw event in a mapped event.
	It should always return an event. Nil is not a valid return object"
	^ (EventTypeMap at: self type ifAbsent: [ ^ self unknownEvent ]) fromSdlEvent: self! !

!SDL_Event class methodsFor: 'class initialization' stamp: ''!
eventNameFromType: aType

	^ EventTypeMap at: aType ifPresent: [ :x | x name ] ifAbsent: [ 'Unknown:' , aType printString ].! !

!SDL_Event class methodsFor: 'class initialization' stamp: ''!
initialize
	"self initialize"

	SDL2Types initialize.  "make sure its initialized"
	self initializeEventTypeMap! !

!SDL_Event class methodsFor: 'class initialization' stamp: ''!
initializeEventTypeMap
	"self initializeEventTypeMap"
	EventTypeMap := Dictionary new.
	SDL2MappedEvent  allSubclassesDo: [ :cls |
		| eventType |
		eventType := cls eventType.
		eventType ifNotNil: [ EventTypeMap at: eventType put: cls ] ]! !

!SDL_GLContext commentStamp: ''!
I represent a handle of GL rendering context, coming from SDL2 library!
!SDL_GLContext methodsFor: 'deleting' stamp: ''!
delete
	^ self ffiCall: #( void SDL_GL_DeleteContext ( self ) )! !

!SDL_GameController commentStamp: ''!
I represent a handler for a game controller coming from SDL2. 

A game controller is a joystick with an mapping. According to the SDL2 documentation, if a game es being executed via Steam, the game controller mapping is provided automatically.!
!SDL_GameController methodsFor: 'testing' stamp: ''!
isGameController
	^ true! !

!SDL_GameController methodsFor: 'accessing' stamp: ''!
getAxis: axis
	^ self ffiCall: #( Sint16 SDL_GameControllerGetAxis(self , int axis) )! !

!SDL_GameController methodsFor: 'accessing' stamp: ''!
name
	^ self ffiCall: #( String SDL_GameControllerName(self) )! !

!SDL_GameController methodsFor: 'closing' stamp: ''!
close
	^ self ffiCall: #( void SDL_GameControllerClose(self ) )! !

!SDL_GameController methodsFor: 'accessing' stamp: ''!
getAttached
	^ self ffiCall: #( SDL_bool SDL_GameControllerGetAttached(self) )! !

!SDL_GameController methodsFor: 'accessing' stamp: ''!
getButton: button
	^ self ffiCall: #( Uint8 SDL_GameControllerGetButton(self , int button) )! !

!SDL_JoyAxisEvent commentStamp: ''!
SDL2 library structure representing a joystick axis event data.!
!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
value: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_VALUE put: anObject! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding4
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_PADDING4! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
axis
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_AXIS! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING3 put: anObject! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding4: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_PADDING4 put: anObject! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
value
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_VALUE! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
axis: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_AXIS put: anObject! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING3! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_JoyAxisEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyAxisEvent: self! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_JoyAxisEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_JoyAxisEvent class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Sint32 which;
    Uint8 axis;
    Uint8 padding1;
    Uint8 padding2;
    Uint8 padding3;
    Sint16 value;
    Uint16 padding4;
 	)! !

!SDL_JoyAxisEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_JOYAXISMOTION! !

!SDL_JoyButtonDownEvent commentStamp: ''!
SDL2 library structure representing a joystick button down event data.!
!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
button
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BUTTON! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
button: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BUTTON put: anObject! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_JoyButtonDownEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyButtonDownEvent: self! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_JoyButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_JoyButtonDownEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_JOYBUTTONDOWN! !

!SDL_JoyButtonEvent commentStamp: ''!
SDL2 library structure representing a joystick button event data.!
!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
button
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BUTTON! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
button: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BUTTON put: anObject! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_JoyButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_JoyButtonEvent class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Sint32 which;
    Uint8 button;
    Uint8 state;
    Uint8 padding1;
    Uint8 padding2;
 	)! !

!SDL_JoyButtonUpEvent commentStamp: ''!
SDL2 library structure representing a joystick button up event data.!
!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
button
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BUTTON! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
button: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BUTTON put: anObject! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_JoyButtonUpEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyButtonUpEvent: self! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_JoyButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_JoyButtonUpEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_JOYBUTTONUP! !

!SDL_JoyDeviceAddedEvent commentStamp: ''!
SDL2 library structure representing a joystick device added event data.!
!SDL_JoyDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_JoyDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_JoyDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_JoyDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_JoyDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_JoyDeviceAddedEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyDeviceAddedEvent: self! !

!SDL_JoyDeviceAddedEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_JoyDeviceAddedEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_JOYDEVICEADDED! !

!SDL_JoyDeviceEvent commentStamp: ''!
SDL2 library structure representing a joystick device event data.!
!SDL_JoyDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_JoyDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_JoyDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_JoyDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_JoyDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_JoyDeviceEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_JoyDeviceEvent class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Sint32 which;
 	)! !

!SDL_JoyDeviceRemovedEvent commentStamp: ''!
SDL2 library structure representing a joystick device removed event data.!
!SDL_JoyDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_WHICH! !

!SDL_JoyDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_JoyDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_JoyDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_JoyDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_WHICH put: anObject! !

!SDL_JoyDeviceRemovedEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitJoyDeviceRemovedEvent: self! !

!SDL_JoyDeviceRemovedEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_JoyDeviceRemovedEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_JOYDEVICEREMOVED! !

!SDL_Joystick commentStamp: ''!
I represent a handler for a joystick coming from SDL2.!
!SDL_Joystick methodsFor: 'accessing' stamp: ''!
numberOfAxes
	^ self ffiCall: #( int SDL_JoystickNumAxes(self) )! !

!SDL_Joystick methodsFor: 'accessing' stamp: ''!
numberOfButtons
	^ self ffiCall: #( int SDL_JoystickNumButtons(self) )! !

!SDL_Joystick methodsFor: 'accessing' stamp: ''!
numberOfBalls
	^ self ffiCall: #( int SDL_JoystickNumBalls(self) )! !

!SDL_Joystick methodsFor: 'accessing' stamp: ''!
numberOfHats
	^ self ffiCall: #( int SDL_JoystickNumHats(self) )! !

!SDL_Joystick methodsFor: 'testing' stamp: ''!
isGameController
	^ false! !

!SDL_Joystick methodsFor: 'accessing' stamp: ''!
getAxis: axis
	^ self ffiCall: #( Sint16 SDL_JoystickGetAxis(self , int axis) )! !

!SDL_Joystick methodsFor: 'accessing' stamp: ''!
name
	^ self ffiCall: #( String SDL_JoystickName(self) )! !

!SDL_Joystick methodsFor: 'closing' stamp: ''!
close
	^ self ffiCall: #( void SDL_JoystickClose(self ) )! !

!SDL_Joystick methodsFor: 'accessing' stamp: ''!
getAttached
	^ self ffiCall: #( SDL_bool SDL_JoystickGetAttached(self) )! !

!SDL_Joystick methodsFor: 'accessing' stamp: ''!
getButton: button
	^ self ffiCall: #( Sint16 SDL_JoystickGetButton(self , int button) )! !

!SDL_KeyDownEvent commentStamp: ''!
SDL2 library structure!
!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WINDOWID put: anObject! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WINDOWID! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
keysym: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_KEYSYM put: anObject getHandle length: SDL_Keysym byteSize! !

!SDL_KeyDownEvent methodsFor: 'testing' stamp: ''!
isKeyDownEvent

	^ true! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
keysym
	"This method was automatically generated"
	^ SDL_Keysym fromHandle: (handle referenceStructAt: OFFSET_KEYSYM length: SDL_Keysym byteSize)! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_KeyDownEvent methodsFor: 'testing' stamp: ''!
isUserInterrupt

	^ ((self keysym mod bitAnd: 16r200) = 0) "ignore all if AltGr is pressed" 
		and: [(self keysym mod anyMask: 1344) "This mask is for meta/cmd"
			and: [ self keysym scancode = SDL_SCANCODE_PERIOD ] ] "This is the dot scancode"! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
repeat: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_REPEAT put: anObject! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
repeat
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_REPEAT! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING3 put: anObject! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING3! !

!SDL_KeyDownEvent methodsFor: 'testing' stamp: ''!
isUserInterruptKillAll

	^ ((self keysym mod bitAnd: 16r200) = 0) "ignore all if AltGr is pressed" 
		and: [(self keysym mod anyMask: 1344) 
			and: [ self keysym scancode = SDL_SCANCODE_COMMA ] ]! !

!SDL_KeyDownEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitKeyDownEvent: self! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_KeyDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_KeyDownEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_KEYDOWN! !

!SDL_KeyUpEvent commentStamp: ''!
SDL2 library structure!
!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WINDOWID! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
keysym: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_KEYSYM put: anObject getHandle length: SDL_Keysym byteSize! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
keysym
	"This method was automatically generated"
	^ SDL_Keysym fromHandle: (handle referenceStructAt: OFFSET_KEYSYM length: SDL_Keysym byteSize)! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
repeat: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_REPEAT put: anObject! !

!SDL_KeyUpEvent methodsFor: 'testing' stamp: ''!
isKeyUpEvent

	^ true! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
repeat
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_REPEAT! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING3 put: anObject! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING3! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_KeyUpEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitKeyUpEvent: self! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_KeyUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WINDOWID put: anObject! !

!SDL_KeyUpEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_KEYUP! !

!SDL_KeyboardEvent commentStamp: ''!
SDL2 library structure!
!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WINDOWID! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
keysym: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_KEYSYM put: anObject getHandle length: SDL_Keysym byteSize! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
keysym
	"This method was automatically generated"
	^ SDL_Keysym fromHandle: (handle referenceStructAt: OFFSET_KEYSYM length: SDL_Keysym byteSize)! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
repeat: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_REPEAT put: anObject! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
repeat
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_REPEAT! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING3 put: anObject! !

!SDL_KeyboardEvent methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	
	aStream print: { self timestamp. self keysym. self type. self windowID. self state }.! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING3! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_KeyboardEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WINDOWID put: anObject! !

!SDL_KeyboardEvent class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
	Uint32 type;
	Uint32 timestamp;
	Uint32 windowID;
	Uint8 state;
	Uint8 repeat;
    	Uint8 padding2;
    	Uint8 padding3;
    	SDL_Keysym keysym;
 	)! !

!SDL_Keysym commentStamp: ''!
SDL2 library structure!
!SDL_Keysym methodsFor: 'accessing - structure variables' stamp: ''!
unused: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_UNUSED put: anObject! !

!SDL_Keysym methodsFor: 'accessing - structure variables' stamp: ''!
mod: anObject
	"This method was automatically generated"
	handle unsignedShortAt: OFFSET_MOD put: anObject! !

!SDL_Keysym methodsFor: 'accessing - structure variables' stamp: ''!
scancode
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_SCANCODE! !

!SDL_Keysym methodsFor: 'accessing - structure variables' stamp: ''!
scancode: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_SCANCODE put: anObject! !

!SDL_Keysym methodsFor: 'accessing - structure variables' stamp: ''!
sym
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_SYM! !

!SDL_Keysym methodsFor: 'accessing - structure variables' stamp: ''!
unused
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_UNUSED! !

!SDL_Keysym methodsFor: 'accessing - structure variables' stamp: ''!
mod
	"This method was automatically generated"
	^handle unsignedShortAt: OFFSET_MOD! !

!SDL_Keysym methodsFor: 'accessing - structure variables' stamp: ''!
sym: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_SYM put: anObject! !

!SDL_Keysym methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream print: { self mod. self scancode. self sym }.! !

!SDL_Keysym class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^#(
    SDL_Scancode scancode;
    SDL_Keycode sym;
    Uint16 mod;
    Uint32 unused;
 	)! !

!SDL_MouseButtonDownEvent commentStamp: ''!
SDL2 library structure!
!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WINDOWID put: anObject! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WHICH! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WINDOWID! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Y put: anObject! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_X! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_X put: anObject! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Y! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
button
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BUTTON! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
button: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BUTTON put: anObject! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WHICH put: anObject! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_MouseButtonDownEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitMouseButtonDownEvent: self! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_MouseButtonDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_MouseButtonDownEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_MOUSEBUTTONDOWN! !

!SDL_MouseButtonEvent commentStamp: ''!
SDL2 library structure!
!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WHICH! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WINDOWID! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Y put: anObject! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_X! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_X put: anObject! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Y! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
button
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BUTTON! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
button: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BUTTON put: anObject! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WHICH put: anObject! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_MouseButtonEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WINDOWID put: anObject! !

!SDL_MouseButtonEvent class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Uint32 windowID;
    Uint32 which;
    Uint8 button;
    Uint8 state;
    Uint8 padding1;
    Uint8 padding2;
    Sint32 x;
    Sint32 y;
 	)! !

!SDL_MouseButtonUpEvent commentStamp: ''!
SDL2 library structure!
!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WINDOWID put: anObject! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WHICH! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WINDOWID! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_STATE put: anObject! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Y put: anObject! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_X! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_X put: anObject! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_STATE! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Y! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
button
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BUTTON! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
button: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BUTTON put: anObject! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WHICH put: anObject! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_MouseButtonUpEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitMouseButtonUpEvent: self! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_MouseButtonUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_MouseButtonUpEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_MOUSEBUTTONUP! !

!SDL_MouseMotionEvent commentStamp: ''!
SDL2 library structure!
!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WHICH! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WINDOWID! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
yrel
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_YREL! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
state: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_STATE put: anObject! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Y put: anObject! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_X! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_X put: anObject! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
xrel: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_XREL put: anObject! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
state
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_STATE! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Y! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
yrel: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_YREL put: anObject! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WHICH put: anObject! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WINDOWID put: anObject! !

!SDL_MouseMotionEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitMouseMotionEvent: self! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_MouseMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
xrel
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_XREL! !

!SDL_MouseMotionEvent class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Uint32 windowID; 
    Uint32 which;
    Uint32 state;
    Sint32 x;
    Sint32 y;
    Sint32 xrel;
    Sint32 yrel;
 	)! !

!SDL_MouseMotionEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_MOUSEMOTION! !

!SDL_MouseWheelEvent commentStamp: ''!
SDL2 library structure!
!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
which
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WHICH! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WINDOWID! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Y put: anObject! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_X! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_X put: anObject! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Y! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
which: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WHICH put: anObject! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WINDOWID put: anObject! !

!SDL_MouseWheelEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitMouseWheelEvent: self! !

!SDL_MouseWheelEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_MouseWheelEvent class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Uint32 windowID;
    Uint32 which;
    Sint32 x;
    Sint32 y;
 	)! !

!SDL_MouseWheelEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_MOUSEWHEEL! !

!SDL_Palette commentStamp: ''!
SDL2 library structure!
!SDL_Palette methodsFor: 'accessing - structure variables' stamp: ''!
version: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_VERSION put: anObject! !

!SDL_Palette methodsFor: 'accessing - structure variables' stamp: ''!
ncolors
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_NCOLORS! !

!SDL_Palette methodsFor: 'accessing - structure variables' stamp: ''!
version
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_VERSION! !

!SDL_Palette methodsFor: 'accessing - structure variables' stamp: ''!
refcount
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_REFCOUNT! !

!SDL_Palette methodsFor: 'accessing - structure variables' stamp: ''!
colors: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_COLORS put: anObject getHandle.! !

!SDL_Palette methodsFor: 'accessing - structure variables' stamp: ''!
ncolors: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_NCOLORS put: anObject! !

!SDL_Palette methodsFor: 'accessing - structure variables' stamp: ''!
colors
	"This method was automatically generated"
	^SDL_Color fromHandle: (handle pointerAt: OFFSET_COLORS)! !

!SDL_Palette methodsFor: 'accessing - structure variables' stamp: ''!
refcount: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_REFCOUNT put: anObject! !

!SDL_Palette class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^#(
    int ncolors;
    SDL_Color* colors;
    Uint32 version;
    int refcount;
 	)! !

!SDL_PixelFormat commentStamp: ''!
SDL2 library structure!
!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Rmask
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_RMASK! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
BitsPerPixel
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BITSPERPIXEL! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
BitsPerPixel: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BITSPERPIXEL put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Bshift: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BSHIFT put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Rshift: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_RSHIFT put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
next: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_NEXT put: anObject getHandle.! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Bloss: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BLOSS put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
palette: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PALETTE put: anObject getHandle.! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Amask
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_AMASK! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Ashift: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_ASHIFT put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Ashift
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_ASHIFT! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Rshift
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_RSHIFT! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Gloss
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_GLOSS! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Gmask: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_GMASK put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Aloss: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_ALOSS put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
format: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_FORMAT put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Rloss
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_RLOSS! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
pad2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PAD2 put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
refcount: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_REFCOUNT put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Bmask: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_BMASK put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
format
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_FORMAT! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Gmask
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_GMASK! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Bloss
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BLOSS! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
next
	"This method was automatically generated"
	^SDL_PixelFormat fromHandle: (handle pointerAt: OFFSET_NEXT)! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Gshift
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_GSHIFT! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
pad1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PAD1 put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Amask: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_AMASK put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
pad2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PAD2! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Rloss: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_RLOSS put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
palette
	"This method was automatically generated"
	^SDL_Palette fromHandle: (handle pointerAt: OFFSET_PALETTE)! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
BytesPerPixel
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BYTESPERPIXEL! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Rmask: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_RMASK put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
refcount
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_REFCOUNT! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Gshift: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_GSHIFT put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
BytesPerPixel: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_BYTESPERPIXEL put: anObject! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Bmask
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_BMASK! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Aloss
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_ALOSS! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
pad1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PAD1! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Bshift
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_BSHIFT! !

!SDL_PixelFormat methodsFor: 'accessing - structure variables' stamp: ''!
Gloss: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_GLOSS put: anObject! !

!SDL_PixelFormat class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^#(
    Uint32 format;
    SDL_Palette* palette;
    Uint8 BitsPerPixel;
    Uint8 BytesPerPixel;
    Uint8 pad1;
	 Uint8 pad2;
    Uint32 Rmask;
    Uint32 Gmask;
    Uint32 Bmask;
    Uint32 Amask;
    Uint8 Rloss;
    Uint8 Gloss;
    Uint8 Bloss;
    Uint8 Aloss;
    Uint8 Rshift;
    Uint8 Gshift;
    Uint8 Bshift;
    Uint8 Ashift;
    int refcount;
    SDL_PixelFormat* next;
 	)! !

!SDL_Point commentStamp: ''!
SDL2 library structure!
!SDL_Point methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Y put: anObject! !

!SDL_Point methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_X! !

!SDL_Point methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_X put: anObject! !

!SDL_Point methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Y! !

!SDL_Point class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^#(
		int x;
		int y;
 	)! !

!SDL_QuitEvent commentStamp: ''!
SDL2 library structure!
!SDL_QuitEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_QuitEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_QuitEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_QuitEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitQuitEvent: self! !

!SDL_QuitEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_QuitEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_QUIT! !

!SDL_Rect commentStamp: ''!
SDL2 library structure!
!SDL_Rect methodsFor: 'accessing - structure variables' stamp: ''!
h
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_H! !

!SDL_Rect methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Y put: anObject! !

!SDL_Rect methodsFor: 'accessing - structure variables' stamp: ''!
w: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_W put: anObject! !

!SDL_Rect methodsFor: 'accessing - structure variables' stamp: ''!
w
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_W! !

!SDL_Rect methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_X! !

!SDL_Rect methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_X put: anObject! !

!SDL_Rect methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Y! !

!SDL_Rect methodsFor: 'accessing - structure variables' stamp: ''!
h: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_H put: anObject! !

!SDL_Rect class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^#(
		int x;
		int y;
		int w;
		int h;
 	)! !

!SDL_Rect class methodsFor: 'fields description' stamp: ''!
newX: x y: y w: w h: h
	^ self new x: x; y: y; w: w; h: h; yourself! !

!SDL_Renderer commentStamp: ''!
I represent a handle of SDL rendering context, coming from SDL2 library!
!SDL_Renderer methodsFor: 'rendering' stamp: ''!
copy: texture
	^ self ffiCall: #( int SDL_RenderCopy ( self , SDL_Texture texture , nil, nil ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
drawPointX: x y: y
	^ self ffiCall: #( int SDL_RenderDrawPoint ( self , int x , int y ) )! !

!SDL_Renderer methodsFor: 'initialization' stamp: ''!
primDestroy
	^ self ffiCall: #( void SDL_DestroyRenderer ( self ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
noClipRect
	^ self ffiCall: #( int SDL_RenderSetClipRect ( self , nil ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
present
	^ self ffiCall: #( void SDL_RenderPresent ( self ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
outputExtent

	^ ExternalAddress allocate: 8 bytesDuring: [ :buffer | 
		  self getOutputSizeW: buffer h: buffer + 4.
		  (buffer unsignedLongAt: 1) @ (buffer unsignedLongAt: 5) ]! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
setClipRect: rect
	^ self ffiCall: #( int SDL_RenderSetClipRect ( self , SDL_Rect* rect ) )! !

!SDL_Renderer methodsFor: 'initialization' stamp: ''!
destroy
	handle isNull ifTrue: [ ^ self ].
	self primDestroy.
	handle beNull! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
drawColorR: r g: g b: b a: a
	^ self ffiCall: #( int SDL_SetRenderDrawColor ( self , Uint8 r , Uint8 g , Uint8 b , Uint8 a ) )! !

!SDL_Renderer methodsFor: 'private' stamp: ''!
primGetRendererInfo: info
	^ self ffiCall: #( int SDL_GetRendererInfo (self, SDL_RendererInfo* info) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
drawRect: rect
	^ self ffiCall: #( int SDL_RenderDrawRect ( self , SDL_Rect* rect ) )! !

!SDL_Renderer methodsFor: 'accessing' stamp: ''!
info
	| info |
	
	info := SDL_RendererInfo externalNew autoRelease.
	self primGetRendererInfo: info.
	^ info! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
drawLineX1: x1 y1: y1 x2: x2 y2: y2
	^ self ffiCall: #( int SDL_RenderDrawLine ( self , int x1 , int y1 , int x2 , int y2 ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
fillRect: rect
	^ self ffiCall: #( int SDL_RenderFillRect ( self , SDL_Rect* rect ) )! !

!SDL_Renderer methodsFor: 'initialization' stamp: ''!
initialize
	self autoRelease! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
createTextureFormat: format access: access width: width height: height

	^ self
		  primCreateTextureFormat: format
		  access: access
		  width: width
		  height: height! !

!SDL_Renderer methodsFor: 'private' stamp: ''!
primCreateTextureFormat: format access: access width: width height: height
	^ self ffiCall: #( SDL_Texture SDL_CreateTexture ( self , Uint32 format , int access , int width , int height ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
copy: texture srcRect: srcRect dstRect: dstRect
	^ self ffiCall: #( int SDL_RenderCopy ( self , SDL_Texture texture , SDL_Rect* srcRect , SDL_Rect* dstRect ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
noRenderTarget
	^ self ffiCall: #( int SDL_SetRenderTarget ( self , nil ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
renderTargetSupported
	^ self ffiCall: #( bool SDL_RenderTargetSupported ( self ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
getOutputSizeW: w h: h
	^ self ffiCall: #( int SDL_GetRendererOutputSize ( self , int* w, int* h ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
clear
	^ self ffiCall: #( int SDL_RenderClear ( self ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
drawBlendMode: blendMode
	^ self ffiCall: #( int SDL_SetRenderDrawBlendMode ( self , SDL_BlendMode blendMode ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
getLogicalSizeW: w h: h
	^ self ffiCall: #( int SDL_RenderGetLogicalSize ( self , int* w, int* h ) )! !

!SDL_Renderer methodsFor: 'rendering' stamp: ''!
setRenderTarget: renderTarget
	^ self ffiCall: #( int SDL_SetRenderTarget ( self , SDL_Texture renderTarget ) )! !

!SDL_Renderer class methodsFor: 'finalization' stamp: ''!
destroyRenderer: aHandle
	^ self ffiCall: #( void SDL_DestroyRenderer ( void *aHandle ) )! !

!SDL_Renderer class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: aHandle
	aHandle isNull ifTrue: [ ^ self ].
	self destroyRenderer: aHandle.
	aHandle beNull! !

!SDL_RendererInfo commentStamp: ''!
A structure that contains information on the capabilities of a render driver or the current render context.

https://wiki.libsdl.org/SDL_RendererInfo!
!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
max_texture_height
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_MAX_TEXTURE_HEIGHT! !

!SDL_RendererInfo methodsFor: 'testing' stamp: ''!
isSupportRenderTexture
	^ self flags & SDL_RENDERER_TARGETTEXTURE == SDL_RENDERER_TARGETTEXTURE! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
max_texture_height: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_MAX_TEXTURE_HEIGHT put: anObject! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
max_texture_width: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_MAX_TEXTURE_WIDTH put: anObject! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
texture_formats
	"This method was automatically generated"
	^(FFITypeArray ofType: #FFIUInt32 size: 16) fromHandle: (handle copyFrom: OFFSET_TEXTURE_FORMATS to: OFFSET_TEXTURE_FORMATS + 63)! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
num_texture_formats: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_NUM_TEXTURE_FORMATS put: anObject! !

!SDL_RendererInfo methodsFor: 'testing' stamp: ''!
isSoftware
	^ self flags & SDL_RENDERER_SOFTWARE == SDL_RENDERER_SOFTWARE! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
texture_formats: anObject
	"This method was automatically generated"
	handle replaceFrom: OFFSET_TEXTURE_FORMATS to: OFFSET_TEXTURE_FORMATS + 63 with: anObject getHandle startingAt: 1! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
name
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_NAME) type: ExternalType char asPointerType! !

!SDL_RendererInfo methodsFor: 'testing' stamp: ''!
isSynchronizedWithRefreshRate
	^ self flags & SDL_RENDERER_PRESENTVSYNC == SDL_RENDERER_PRESENTVSYNC! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
max_texture_width
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_MAX_TEXTURE_WIDTH! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
name: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_NAME put: anObject getHandle.! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
num_texture_formats
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_NUM_TEXTURE_FORMATS! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
flags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_FLAGS put: anObject! !

!SDL_RendererInfo methodsFor: 'accessing - structure variables' stamp: ''!
flags
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_FLAGS! !

!SDL_RendererInfo methodsFor: 'testing' stamp: ''!
isAccelerated
	^ self flags & SDL_RENDERER_ACCELERATED == SDL_RENDERER_ACCELERATED! !

!SDL_RendererInfo class methodsFor: 'class initialization' stamp: ''!
initialize
	Uint32_16 := FFITypeArray ofType: Uint32 size: 16! !

!SDL_RendererInfo class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
   	 	char *name;
    	Uint32 flags;
    	Uint32 num_texture_formats;
    	Uint32_16 texture_formats;
    	int max_texture_width;
    	int max_texture_height;
 	)! !

!SDL_Surface commentStamp: ''!
SDL2 library structure!
!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
locked: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_LOCKED put: anObject! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
h
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_H! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
pixels
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_PIXELS) type: ExternalType void asPointerType! !

!SDL_Surface methodsFor: 'pixel accessing' stamp: ''!
unlockSurface
	^ self SDL_UnlockSurface: self! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
userdata
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_USERDATA) type: ExternalType void asPointerType! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
pitch
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_PITCH! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
pixels: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_PIXELS put: anObject getHandle.! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
map: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_MAP put: anObject getHandle.! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
w
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_W! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
clip_rect: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_CLIP_RECT put: anObject getHandle length: SDL_Rect byteSize! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
lock_data
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_LOCK_DATA) type: ExternalType void asPointerType! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
pitch: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_PITCH put: anObject! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
format: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_FORMAT put: anObject getHandle.! !

!SDL_Surface methodsFor: 'finalization' stamp: ''!
freeSurface
	(handle isNull or: [handle isExternalAddress not]) ifTrue: [ ^ self ].
	self primFree: handle.
	handle beNull! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
flags: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_FLAGS put: anObject! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
flags
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_FLAGS! !

!SDL_Surface methodsFor: 'finalization' stamp: ''!
primFree: surfacePointer
	^ self ffiCall: #( void SDL_FreeSurface ( void* surfacePointer) )! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
refcount: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_REFCOUNT put: anObject! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
lock_data: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_LOCK_DATA put: anObject getHandle.! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
locked
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_LOCKED! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
map
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_MAP) type: ExternalType void asPointerType! !

!SDL_Surface methodsFor: 'initialization' stamp: ''!
initialize
	self autoRelease! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
clip_rect
	"This method was automatically generated"
	^ SDL_Rect fromHandle: (handle referenceStructAt: OFFSET_CLIP_RECT length: SDL_Rect byteSize)! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
format
	"This method was automatically generated"
	^SDL_PixelFormat fromHandle: (handle pointerAt: OFFSET_FORMAT)! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
userdata: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_USERDATA put: anObject getHandle.! !

!SDL_Surface methodsFor: 'pixel accessing' stamp: ''!
SDL_LockSurface: aSurface
	^ self ffiCall: #(int SDL_LockSurface( SDL_Surface* aSurface ))! !

!SDL_Surface methodsFor: 'external resource management' stamp: ''!
autoRelease
	"Some SDL2 structures need specialised free functions. Use the same autoRelease functionality
	as FFIExternalReference to achieve this.

	Note, subclasses should implement #resourceData
	and #finalizeResourceData: on class side"
	FFIExternalResourceManager addResource: self! !

!SDL_Surface methodsFor: 'pixel accessing' stamp: ''!
SDL_UnlockSurface: aSurface
	^ self ffiCall: #( int SDL_UnlockSurface( SDL_Surface* aSurface ) )! !

!SDL_Surface methodsFor: 'pixel accessing' stamp: ''!
lockSurface
	^ self SDL_LockSurface: self! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
w: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_W put: anObject! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
refcount
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_REFCOUNT! !

!SDL_Surface methodsFor: 'external resource management' stamp: ''!
resourceData
	^ self getHandle! !

!SDL_Surface methodsFor: 'accessing - structure variables' stamp: ''!
h: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_H put: anObject! !

!SDL_Surface class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^#(
		Uint32 flags;
		SDL_PixelFormat* format;
    		int w;
		int h;
    		int pitch;
    		void* pixels;
		void* userdata;
		int locked;
		void* lock_data;
		SDL_Rect clip_rect;
    		void *map;
    		int refcount;
 	)! !

!SDL_Surface class methodsFor: 'video' stamp: ''!
freeSurface: aHandle
	^ self ffiCall: #( void SDL_FreeSurface ( void *aHandle ) )! !

!SDL_Surface class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: aHandle
	(aHandle isNull or: [aHandle isExternalAddress not]) ifTrue: [ ^ self ].
	self freeSurface: aHandle.
	aHandle beNull! !

!SDL_SysWMEvent commentStamp: ''!
I represent the SDL_SysWMEvent, this event represent a system window event!
!SDL_SysWMEvent methodsFor: 'accessing' stamp: ''!
windowID

	self isWindows 
		ifFalse: [ ^ nil ].
	self windowsMessage isDisplayChanged ifFalse: [ ^ nil ].

	^ windowId ifNil: [ 
		  OSSDL2Driver allWindows
			  detect: [ :w | 
			  w platformSpecificHandle window getHandle = self windowsMessage hwnd getHandle ]
			  ifFound: [ :w | ^ windowId := w windowId ]
			  ifNone: [ ^ nil ] ]! !

!SDL_SysWMEvent methodsFor: 'testing' stamp: ''!
isWindows
	
	^ self msg isWindows! !

!SDL_SysWMEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_SysWMEvent methodsFor: 'accessing - structure variables' stamp: ''!
msg: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_MSG put: anObject getHandle.! !

!SDL_SysWMEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_SysWMEvent methodsFor: 'accessing - structure variables' stamp: ''!
msg
	"This method was automatically generated"
	^SDL_SysWMmsg fromHandle: (handle pointerAt: OFFSET_MSG)! !

!SDL_SysWMEvent methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream 
		nextPut: $:;
		print: self msg.! !

!SDL_SysWMEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_SysWMEvent methodsFor: 'accessing' stamp: ''!
windowsMessage
	
	^ self msg windowsMessage! !

!SDL_SysWMEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor

	self isWindows ifFalse: [ ^ nil ].
	self windowsMessage isDisplayChanged ifFalse: [ ^ nil ].
	
	^ aVisitor visitSystemWindowEvent: self! !

!SDL_SysWMEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_SysWMEvent methodsFor: 'event type' stamp: ''!
eventType

	^ SDL_SYSWMEVENT! !

!SDL_SysWMEvent class methodsFor: 'field description' stamp: ''!
fieldsDesc
	"
		self rebuildFieldAccessors 
	"

	^ #(
    Uint32 type
    Uint32 timestamp
	 SDL_SysWMmsg*  msg
 	)! !

!SDL_SysWMEvent class methodsFor: 'event type' stamp: ''!
eventType

	^ SDL_SYSWMEVENT! !

!SDL_SysWMinfo commentStamp: ''!
A structure that contains system-dependent information about a window. !
!SDL_SysWMinfo methodsFor: 'testing' stamp: ''!
isWindows 

	^ self subsystem = SDL_SYSWM_WINDOWS! !

!SDL_SysWMinfo methodsFor: 'accessing - structure variables' stamp: ''!
version: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_VERSION put: anObject getHandle length: SDL_Version byteSize! !

!SDL_SysWMinfo methodsFor: 'accessing - structure variables' stamp: ''!
subsystem: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_SUBSYSTEM put: anObject! !

!SDL_SysWMinfo methodsFor: 'accessing - structure variables' stamp: ''!
version
	"This method was automatically generated"
	^ SDL_Version fromHandle: (handle referenceStructAt: OFFSET_VERSION length: SDL_Version byteSize)! !

!SDL_SysWMinfo methodsFor: 'accessing - structure variables' stamp: ''!
info: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_INFO put: anObject getHandle length: SDL_SysWMinfo_InfoUnion byteSize! !

!SDL_SysWMinfo methodsFor: 'accessing - structure variables' stamp: ''!
subsystem
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_SUBSYSTEM! !

!SDL_SysWMinfo methodsFor: 'accessing - structure variables' stamp: ''!
info
	"This method was automatically generated"
	^ SDL_SysWMinfo_InfoUnion fromHandle: (handle referenceStructAt: OFFSET_INFO length: SDL_SysWMinfo_InfoUnion byteSize)! !

!SDL_SysWMinfo class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		SDL_Version version;
		int subsystem;
		SDL_SysWMinfo_InfoUnion info;
 	)! !

!SDL_SysWMinfo_AndroidInfo commentStamp: ''!
A structure that contains Android specific information about a window. !
!SDL_SysWMinfo_AndroidInfo methodsFor: 'accessing - structure variables' stamp: ''!
window
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_WINDOW) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_AndroidInfo methodsFor: 'accessing - structure variables' stamp: ''!
surface
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_SURFACE) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_AndroidInfo methodsFor: 'accessing - structure variables' stamp: ''!
surface: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_SURFACE put: anObject getHandle.! !

!SDL_SysWMinfo_AndroidInfo methodsFor: 'converting' stamp: ''!
asPlatformSpecificHandle
	^ OSWindowPlatformSpecificHandle new
		platform: #android;
		window: self window;
		surface: self surface;
		yourself! !

!SDL_SysWMinfo_AndroidInfo methodsFor: 'accessing - structure variables' stamp: ''!
window: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_WINDOW put: anObject getHandle.! !

!SDL_SysWMinfo_AndroidInfo class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		void* window;
		void* surface;
 	)! !

!SDL_SysWMinfo_CocoaInfo commentStamp: ''!
A structure that contains Cocoa specific information about a window. !
!SDL_SysWMinfo_CocoaInfo methodsFor: 'accessing - structure variables' stamp: ''!
window
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_WINDOW) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_CocoaInfo methodsFor: 'converting' stamp: ''!
asPlatformSpecificHandle
	^ OSWindowPlatformSpecificHandle new
		platform: #cocoa;
		window: self window;
		yourself! !

!SDL_SysWMinfo_CocoaInfo methodsFor: 'accessing - structure variables' stamp: ''!
window: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_WINDOW put: anObject getHandle.! !

!SDL_SysWMinfo_CocoaInfo class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		void* window;
 	)! !

!SDL_SysWMinfo_DirectFBInfo commentStamp: ''!
A structure that contains DirectFB specific information about a window. !
!SDL_SysWMinfo_DirectFBInfo methodsFor: 'accessing - structure variables' stamp: ''!
window
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_WINDOW) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_DirectFBInfo methodsFor: 'accessing - structure variables' stamp: ''!
dfb
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_DFB) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_DirectFBInfo methodsFor: 'accessing - structure variables' stamp: ''!
surface
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_SURFACE) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_DirectFBInfo methodsFor: 'accessing - structure variables' stamp: ''!
dfb: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_DFB put: anObject getHandle.! !

!SDL_SysWMinfo_DirectFBInfo methodsFor: 'accessing - structure variables' stamp: ''!
surface: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_SURFACE put: anObject getHandle.! !

!SDL_SysWMinfo_DirectFBInfo methodsFor: 'converting' stamp: ''!
asPlatformSpecificHandle
	^ OSWindowPlatformSpecificHandle new
		platform: #directfb;
		display: self dfb;
		window: self window;
		surface: self surface;
		yourself! !

!SDL_SysWMinfo_DirectFBInfo methodsFor: 'accessing - structure variables' stamp: ''!
window: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_WINDOW put: anObject getHandle.! !

!SDL_SysWMinfo_DirectFBInfo class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		void* dfb;
		void* window;
		void* surface;
 	)! !

!SDL_SysWMinfo_InfoUnion commentStamp: ''!
I am union inside of SDL_SysWMinfo used to hold platform specific information about a window.!
!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
android: anObject
	"This method was automatically generated"
	handle structAt: 1 put: anObject getHandle length: 16.! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
uikit
	"This method was automatically generated"
	^ SDL_SysWMinfo_UIKitInfo fromHandle: (handle referenceStructAt: 1 length: SDL_SysWMinfo_UIKitInfo byteSize)! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
winrt: anObject
	"This method was automatically generated"
	handle structAt: 1 put: anObject getHandle length: 8.! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
wl
	"This method was automatically generated"
	^ SDL_SysWMinfo_WaylandInfo fromHandle: (handle referenceStructAt: 1 length: SDL_SysWMinfo_WaylandInfo byteSize)! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
x11
	"This method was automatically generated"
	^ SDL_SysWMinfo_X11Info fromHandle: (handle referenceStructAt: 1 length: SDL_SysWMinfo_X11Info byteSize)! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
dfb
	"This method was automatically generated"
	^ SDL_SysWMinfo_DirectFBInfo fromHandle: (handle referenceStructAt: 1 length: SDL_SysWMinfo_DirectFBInfo byteSize)! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
mir: anObject
	"This method was automatically generated"
	handle structAt: 1 put: anObject getHandle length: 16.! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
uikit: anObject
	"This method was automatically generated"
	handle structAt: 1 put: anObject getHandle length: 24.! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
mir
	"This method was automatically generated"
	^ SDL_SysWMinfo_MirInfo fromHandle: (handle referenceStructAt: 1 length: SDL_SysWMinfo_MirInfo byteSize)! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
android
	"This method was automatically generated"
	^ SDL_SysWMinfo_AndroidInfo fromHandle: (handle referenceStructAt: 1 length: SDL_SysWMinfo_AndroidInfo byteSize)! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
win
	"This method was automatically generated"
	^ SDL_SysWMinfo_WindowsInfo fromHandle: (handle referenceStructAt: 1 length: SDL_SysWMinfo_WindowsInfo byteSize)! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
winrt
	"This method was automatically generated"
	^ SDL_SysWMinfo_WindowsRTInfo fromHandle: (handle referenceStructAt: 1 length: SDL_SysWMinfo_WindowsRTInfo byteSize)! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
cocoa
	"This method was automatically generated"
	^ SDL_SysWMinfo_CocoaInfo fromHandle: (handle referenceStructAt: 1 length: SDL_SysWMinfo_CocoaInfo byteSize)! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
cocoa: anObject
	"This method was automatically generated"
	handle structAt: 1 put: anObject getHandle length: 8.! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
dfb: anObject
	"This method was automatically generated"
	handle structAt: 1 put: anObject getHandle length: 24.! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
wl: anObject
	"This method was automatically generated"
	handle structAt: 1 put: anObject getHandle length: 24.! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
x11: anObject
	"This method was automatically generated"
	handle structAt: 1 put: anObject getHandle length: 16.! !

!SDL_SysWMinfo_InfoUnion methodsFor: 'accessing - structure variables' stamp: ''!
win: anObject
	"This method was automatically generated"
	handle structAt: 1 put: anObject getHandle length: 16.! !

!SDL_SysWMinfo_InfoUnion class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		SDL_SysWMinfo_WindowsInfo win;
		SDL_SysWMinfo_WindowsRTInfo winrt;
		SDL_SysWMinfo_X11Info x11;
		SDL_SysWMinfo_DirectFBInfo dfb;
		SDL_SysWMinfo_CocoaInfo cocoa;
		SDL_SysWMinfo_UIKitInfo uikit;
		SDL_SysWMinfo_WaylandInfo wl;
		SDL_SysWMinfo_MirInfo mir;
		SDL_SysWMinfo_AndroidInfo android;
 	)! !

!SDL_SysWMinfo_MirInfo commentStamp: ''!
A structure that contains Mir specific information about a window. !
!SDL_SysWMinfo_MirInfo methodsFor: 'accessing - structure variables' stamp: ''!
surface
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_SURFACE) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_MirInfo methodsFor: 'accessing - structure variables' stamp: ''!
connection
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_CONNECTION) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_MirInfo methodsFor: 'accessing - structure variables' stamp: ''!
surface: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_SURFACE put: anObject getHandle.! !

!SDL_SysWMinfo_MirInfo methodsFor: 'converting' stamp: ''!
asPlatformSpecificHandle
	^ OSWindowPlatformSpecificHandle new
		platform: #mir;
		display: self connection;
		surface: self surface;
		yourself! !

!SDL_SysWMinfo_MirInfo methodsFor: 'accessing - structure variables' stamp: ''!
connection: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_CONNECTION put: anObject getHandle.! !

!SDL_SysWMinfo_MirInfo class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		void* connection;
		void* surface;
 	)! !

!SDL_SysWMinfo_UIKitInfo commentStamp: ''!
A structure that contains UIKit specific information about a window. !
!SDL_SysWMinfo_UIKitInfo methodsFor: 'accessing - structure variables' stamp: ''!
resolveFramebuffer
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_RESOLVEFRAMEBUFFER! !

!SDL_SysWMinfo_UIKitInfo methodsFor: 'accessing - structure variables' stamp: ''!
window
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_WINDOW) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_UIKitInfo methodsFor: 'accessing - structure variables' stamp: ''!
colorbuffer
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_COLORBUFFER! !

!SDL_SysWMinfo_UIKitInfo methodsFor: 'accessing - structure variables' stamp: ''!
colorbuffer: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_COLORBUFFER put: anObject! !

!SDL_SysWMinfo_UIKitInfo methodsFor: 'accessing - structure variables' stamp: ''!
framebuffer: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_FRAMEBUFFER put: anObject! !

!SDL_SysWMinfo_UIKitInfo methodsFor: 'accessing - structure variables' stamp: ''!
framebuffer
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_FRAMEBUFFER! !

!SDL_SysWMinfo_UIKitInfo methodsFor: 'accessing - structure variables' stamp: ''!
resolveFramebuffer: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_RESOLVEFRAMEBUFFER put: anObject! !

!SDL_SysWMinfo_UIKitInfo methodsFor: 'converting' stamp: ''!
asPlatformSpecificHandle
	^ OSWindowPlatformSpecificHandle new
		platform: #uikit;
		window: self window;
		surface: self framebuffer;
		yourself! !

!SDL_SysWMinfo_UIKitInfo methodsFor: 'accessing - structure variables' stamp: ''!
window: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_WINDOW put: anObject getHandle.! !

!SDL_SysWMinfo_UIKitInfo class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		void* window;
		uint framebuffer;
		uint colorbuffer;
		uint resolveFramebuffer;
 	)! !

!SDL_SysWMinfo_WaylandInfo commentStamp: ''!
A structure that contains Wayland specific information about a window. !
!SDL_SysWMinfo_WaylandInfo methodsFor: 'accessing - structure variables' stamp: ''!
shell_surface
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_SHELL_SURFACE) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_WaylandInfo methodsFor: 'accessing - structure variables' stamp: ''!
display
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_DISPLAY) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_WaylandInfo methodsFor: 'accessing - structure variables' stamp: ''!
shell_surface: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_SHELL_SURFACE put: anObject getHandle.! !

!SDL_SysWMinfo_WaylandInfo methodsFor: 'accessing - structure variables' stamp: ''!
surface
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_SURFACE) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_WaylandInfo methodsFor: 'accessing - structure variables' stamp: ''!
display: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_DISPLAY put: anObject getHandle.! !

!SDL_SysWMinfo_WaylandInfo methodsFor: 'accessing - structure variables' stamp: ''!
surface: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_SURFACE put: anObject getHandle.! !

!SDL_SysWMinfo_WaylandInfo methodsFor: 'converting' stamp: ''!
asPlatformSpecificHandle
	^ OSWindowPlatformSpecificHandle new
		platform: #wayland;
		display: self display;
		window: self shell_surface;
		surface: self surface;
		yourself! !

!SDL_SysWMinfo_WaylandInfo class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		void* display;
		void* surface;
		void* shell_surface;
 	)! !

!SDL_SysWMinfo_WindowsInfo commentStamp: ''!
A structure that contains Window specific information about a window. !
!SDL_SysWMinfo_WindowsInfo methodsFor: 'accessing - structure variables' stamp: ''!
hdc: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_HDC put: anObject getHandle.! !

!SDL_SysWMinfo_WindowsInfo methodsFor: 'accessing - structure variables' stamp: ''!
window
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_WINDOW) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_WindowsInfo methodsFor: 'accessing - structure variables' stamp: ''!
hdc
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_HDC) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_WindowsInfo methodsFor: 'converting' stamp: ''!
asPlatformSpecificHandle
	^ OSWindowPlatformSpecificHandle new
		platform: #win32;
		window: self window;
		surface: self hdc;
		yourself! !

!SDL_SysWMinfo_WindowsInfo methodsFor: 'accessing - structure variables' stamp: ''!
window: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_WINDOW put: anObject getHandle.! !

!SDL_SysWMinfo_WindowsInfo class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		void* window;
		void* hdc;
 	)! !

!SDL_SysWMinfo_WindowsRTInfo commentStamp: ''!
A structure that contains WindowsRT specific information about a window. !
!SDL_SysWMinfo_WindowsRTInfo methodsFor: 'accessing - structure variables' stamp: ''!
window
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_WINDOW) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_WindowsRTInfo methodsFor: 'converting' stamp: ''!
asPlatformSpecificHandle
	^ OSWindowPlatformSpecificHandle new
		platform: #winrt;
		window: self window;
		yourself! !

!SDL_SysWMinfo_WindowsRTInfo methodsFor: 'accessing - structure variables' stamp: ''!
window: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_WINDOW put: anObject getHandle.! !

!SDL_SysWMinfo_WindowsRTInfo class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		void* window;
 	)! !

!SDL_SysWMinfo_X11Info commentStamp: ''!
A structure that contains X11 specific information about a window. !
!SDL_SysWMinfo_X11Info methodsFor: 'accessing - structure variables' stamp: ''!
window
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_WINDOW) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_X11Info methodsFor: 'accessing - structure variables' stamp: ''!
display
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_DISPLAY) type: ExternalType void asPointerType! !

!SDL_SysWMinfo_X11Info methodsFor: 'accessing - structure variables' stamp: ''!
display: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_DISPLAY put: anObject getHandle.! !

!SDL_SysWMinfo_X11Info methodsFor: 'converting' stamp: ''!
asPlatformSpecificHandle
	^ OSWindowPlatformSpecificHandle new
		platform: #x11;
		display: self display;
		window: self window;
		yourself! !

!SDL_SysWMinfo_X11Info methodsFor: 'accessing - structure variables' stamp: ''!
window: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_WINDOW put: anObject getHandle.! !

!SDL_SysWMinfo_X11Info class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		void* display;
		void* window;
 	)! !

!SDL_SysWMmsg commentStamp: ''!
I represent the payload of the SDL_SysWMEvent event!
!SDL_SysWMmsg methodsFor: 'testing' stamp: ''!
isWindows 

	^ self subsystem = SDL_SYSWM_WINDOWS! !

!SDL_SysWMmsg methodsFor: 'accessing - structure variables' stamp: ''!
msg: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_MSG put: anObject getHandle length: SDL_SysWMmsgUnion byteSize! !

!SDL_SysWMmsg methodsFor: 'accessing - structure variables' stamp: ''!
version: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_VERSION put: anObject getHandle length: SDL_Version byteSize! !

!SDL_SysWMmsg methodsFor: 'accessing - structure variables' stamp: ''!
msg
	"This method was automatically generated"
	^ SDL_SysWMmsgUnion fromHandle: (handle referenceStructAt: OFFSET_MSG length: SDL_SysWMmsgUnion byteSize)! !

!SDL_SysWMmsg methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream 
		nextPut: $(;
		nextPutAll: ' subsystem: ';
		print: self subsystem.
	
	self isWindows ifTrue: [ 
		aStream 
			nextPutAll: ' Windows: ';
			print: self msg win
	].

	aStream nextPut: $)! !

!SDL_SysWMmsg methodsFor: 'accessing - structure variables' stamp: ''!
subsystem: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_SUBSYSTEM put: anObject! !

!SDL_SysWMmsg methodsFor: 'accessing - structure variables' stamp: ''!
version
	"This method was automatically generated"
	^ SDL_Version fromHandle: (handle referenceStructAt: OFFSET_VERSION length: SDL_Version byteSize)! !

!SDL_SysWMmsg methodsFor: 'accessing - structure variables' stamp: ''!
subsystem
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_SUBSYSTEM! !

!SDL_SysWMmsg methodsFor: 'accessing - structure variables' stamp: ''!
windowsMessage

	^ self msg win! !

!SDL_SysWMmsg class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		SDL_Version			version
		int 					subsystem
		SDL_SysWMmsgUnion	msg
 	)! !

!SDL_SysWMmsgUnion commentStamp: ''!
I represent the union that is inside the SDL_SysWMmsg structure.
I have inside different structures depending on the platform executing.!
!SDL_SysWMmsgUnion methodsFor: 'accessing - structure variables' stamp: ''!
win
	"This method was automatically generated"
	^ SDL_SysWMmsg_Windows fromHandle: (handle referenceStructAt: 1 length: SDL_SysWMmsg_Windows byteSize)! !

!SDL_SysWMmsgUnion methodsFor: 'accessing - structure variables' stamp: ''!
win: anObject
	"This method was automatically generated"
	handle structAt: 1 put: anObject getHandle length: 32.! !

!SDL_SysWMmsgUnion class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		SDL_SysWMmsg_Windows win
 	)! !

!SDL_SysWMmsg_Windows commentStamp: ''!
This is the specific message structure used when receiving a SDL_SysWMmsg!
!SDL_SysWMmsg_Windows methodsFor: 'accessing - structure variables' stamp: ''!
hwnd
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_HWND) type: ExternalType void asPointerType! !

!SDL_SysWMmsg_Windows methodsFor: 'accessing - structure variables' stamp: ''!
wParam
	"This method was automatically generated"
	^handle unsignedLongLongAt: OFFSET_WPARAM! !

!SDL_SysWMmsg_Windows methodsFor: 'accessing - structure variables' stamp: ''!
msg: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_MSG put: anObject! !

!SDL_SysWMmsg_Windows methodsFor: 'accessing - structure variables' stamp: ''!
wParam: anObject
	"This method was automatically generated"
	handle unsignedLongLongAt: OFFSET_WPARAM put: anObject! !

!SDL_SysWMmsg_Windows methodsFor: 'accessing - structure variables' stamp: ''!
lParam
	"This method was automatically generated"
	^handle unsignedLongLongAt: OFFSET_LPARAM! !

!SDL_SysWMmsg_Windows methodsFor: 'accessing - structure variables' stamp: ''!
msg
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_MSG! !

!SDL_SysWMmsg_Windows methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	
	aStream 
		nextPutAll: ' msg: ';
		print: (SDL2WindowsMessages translateId: self msg) asString;
		nextPutAll: ' wParam: ';
		print: self wParam;
		nextPutAll: ' lParam: ';
		print: self lParam! !

!SDL_SysWMmsg_Windows methodsFor: 'accessing - structure variables' stamp: ''!
hwnd: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_HWND put: anObject getHandle.! !

!SDL_SysWMmsg_Windows methodsFor: 'testing' stamp: ''!
isDisplayChanged

	^ self msg = WM_DISPLAYCHANGE.! !

!SDL_SysWMmsg_Windows methodsFor: 'accessing - structure variables' stamp: ''!
lParam: anObject
	"This method was automatically generated"
	handle unsignedLongLongAt: OFFSET_LPARAM put: anObject! !

!SDL_SysWMmsg_Windows class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self rebuildFieldAccessors
	"
	^#(
		void* hwnd
		uint32 msg
		uint64 wParam
		uint64 lParam
 	)! !

!SDL_SystemCursorType commentStamp: ''!
I am the FFIEnumeration used to get the system cursors. I am defined as following C Enum

```
typedef enum {
        SDL_SYSTEM_CURSOR_ARROW,     
        SDL_SYSTEM_CURSOR_IBEAM,     
        SDL_SYSTEM_CURSOR_WAIT,      
        SDL_SYSTEM_CURSOR_CROSSHAIR, 
        SDL_SYSTEM_CURSOR_WAITARROW, 
        SDL_SYSTEM_CURSOR_SIZENWSE,  
        SDL_SYSTEM_CURSOR_SIZENESW,  
        SDL_SYSTEM_CURSOR_SIZEWE,    
        SDL_SYSTEM_CURSOR_SIZENS,    
        SDL_SYSTEM_CURSOR_SIZEALL,   
        SDL_SYSTEM_CURSOR_NO,        
        SDL_SYSTEM_CURSOR_HAND,      
        SDL_NUM_SYSTEM_CURSORS
} SDL_SystemCursor; 
```!
!SDL_SystemCursorType methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(;
		 print: self item ;
		 space;
		 print: self value;
		 nextPut: $)! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_SIZENESW
	^ SDL_SYSTEM_CURSOR_SIZENESW! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_SIZENWSE
	^ SDL_SYSTEM_CURSOR_SIZENWSE! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_WAITARROW
	^ SDL_SYSTEM_CURSOR_WAITARROW! !

!SDL_SystemCursorType class methodsFor: 'class initialization' stamp: ''!
initialize
	self initializeEnumeration.
	
	self classPool keysDo: [ :e |
		self class compile: ('{1}
	^ {1}' format: {e asString}) classified: #accessing	]! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_SIZENS
	^ SDL_SYSTEM_CURSOR_SIZENS! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_HAND
	^ SDL_SYSTEM_CURSOR_HAND! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_NO
	^ SDL_SYSTEM_CURSOR_NO! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_SIZEWE
	^ SDL_SYSTEM_CURSOR_SIZEWE! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_IBEAM
	^ SDL_SYSTEM_CURSOR_IBEAM! !

!SDL_SystemCursorType class methodsFor: 'enum declaration' stamp: ''!
enumDecl 

	^ #( SDL_SYSTEM_CURSOR_ARROW 			0     
        SDL_SYSTEM_CURSOR_IBEAM 			1     
        SDL_SYSTEM_CURSOR_WAIT 			2     
        SDL_SYSTEM_CURSOR_CROSSHAIR 		3 
        SDL_SYSTEM_CURSOR_WAITARROW 		4 
        SDL_SYSTEM_CURSOR_SIZENWSE 		5  
        SDL_SYSTEM_CURSOR_SIZENESW 		6  
        SDL_SYSTEM_CURSOR_SIZEWE 			7    
        SDL_SYSTEM_CURSOR_SIZENS 			8    
        SDL_SYSTEM_CURSOR_SIZEALL 		9   
        SDL_SYSTEM_CURSOR_NO 				10        
        SDL_SYSTEM_CURSOR_HAND 			11      
        SDL_NUM_SYSTEM_CURSORS				12)! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_SIZEALL
	^ SDL_SYSTEM_CURSOR_SIZEALL! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_NUM_SYSTEM_CURSORS
	^ SDL_NUM_SYSTEM_CURSORS! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_WAIT
	^ SDL_SYSTEM_CURSOR_WAIT! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_ARROW
	^ SDL_SYSTEM_CURSOR_ARROW! !

!SDL_SystemCursorType class methodsFor: 'accessing' stamp: 'Anonymous 1/5/2022 20:59'!
SDL_SYSTEM_CURSOR_CROSSHAIR
	^ SDL_SYSTEM_CURSOR_CROSSHAIR! !

!SDL_TextInputEvent commentStamp: ''!
SDL2 library structure!
!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text25: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT25 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text22: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT22 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text31: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT31 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text12
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT12! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text18
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT18! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text19: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT19 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text28: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT28 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text15
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT15! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text5: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT5 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text2
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT2! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text26
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT26! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text18: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT18 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text15: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT15 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text13
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT13! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text24: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT24 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text8
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT8! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text14
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT14! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text24
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT24! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text8: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT8 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text6: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT6 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text30
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT30! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WINDOWID! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text11: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT11 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text7: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT7 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text20: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT20 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text12: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT12 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text30: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT30 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text10: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT10 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text10
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT10! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text17: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT17 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text29: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT29 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text27
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT27! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text3: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT3 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text19
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT19! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text13: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT13 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text2: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT2 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text17
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT17! !

!SDL_TextInputEvent methodsFor: 'accessing' stamp: ''!
strlen
	| len |
	len := 0.
	12 to: 12 + 32 - 1 do:
		[ :i | 
		(self getHandle unsignedByteAt: i + 1) = 0
			ifTrue: [ ^ len ].
		len := len + 1 ].
	^ len! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text23: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT23 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text28
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT28! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text1
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT1! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text21: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT21 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text23
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT23! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text29
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT29! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text9
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT9! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WINDOWID put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text5
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT5! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text16: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT16 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text1: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT1 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text25
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT25! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text6
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT6! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text11
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT11! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text14: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT14 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text22
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT22! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text3
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT3! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text4
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT4! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text4: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT4 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text0: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT0 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text20
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT20! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text16
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT16! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text21
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT21! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text0
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT0! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text26: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT26 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text31
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT31! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text7
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_TEXT7! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text27: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT27 put: anObject! !

!SDL_TextInputEvent methodsFor: 'accessing - structure variables' stamp: ''!
text9: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_TEXT9 put: anObject! !

!SDL_TextInputEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitTextInputEvent: self! !

!SDL_TextInputEvent methodsFor: 'accessing' stamp: ''!
text
	| len text |
	len := self strlen.
	text := ByteArray new: len.
	1 to: len do: [ :i |
		text at: i put: (self getHandle unsignedByteAt: 12 + i)
	].
	^ text! !

!SDL_TextInputEvent class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Uint32 windowID;

	"HACK: for char text[32];"
      char text0;
	char text1;
	char text2;
	char text3;
	char text4;
	char text5;
	char text6;
	char text7;
	char text8;
	char text9;
	char text10;
	char text11;
	char text12;
	char text13;
	char text14;
	char text15;
	char text16;
	char text17;
	char text18;
	char text19;
	char text20;
	char text21;
	char text22;
	char text23;
	char text24;
	char text25;
	char text26;
	char text27;
	char text28;
	char text29;
	char text30;
	char text31;
 	)! !

!SDL_TextInputEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_TEXTINPUT! !

!SDL_Texture commentStamp: ''!
I represent a handle of GL texture, coming from SDL2 library!
!SDL_Texture methodsFor: 'private' stamp: ''!
primDestroy
	^ self ffiCall: #( void SDL_DestroyTexture ( self ) )! !

!SDL_Texture methodsFor: 'initialization' stamp: ''!
initialize
	self autoRelease! !

!SDL_Texture methodsFor: 'pixels handling' stamp: ''!
unlock
	^ self ffiCall: #( void SDL_UnlockTexture ( self ) )! !

!SDL_Texture methodsFor: 'rendering' stamp: ''!
blendMode: blendMode
	^ self ffiCall: #( int SDL_SetTextureBlendMode ( self , SDL_BlendMode blendMode ) )! !

!SDL_Texture methodsFor: 'initialization' stamp: ''!
alphaMod: alpha
	^ self ffiCall: #( int SDL_SetTextureAlphaMod ( self , Uint8 alpha ) )! !

!SDL_Texture methodsFor: 'initialization' stamp: ''!
updateTexturePixels: pixels pitch: pitch
	^ self ffiCall: #( int SDL_UpdateTexture ( self , nil , void* pixels , int pitch ) )! !

!SDL_Texture methodsFor: 'initialization' stamp: ''!
updateTextureRect: rect pixels: pixels pitch: pitch
	^ self ffiCall: #( int SDL_UpdateTexture ( self , SDL_Rect* rect , void* pixels , int pitch ) )! !

!SDL_Texture methodsFor: 'initialization' stamp: ''!
colorModR: r g: g b: b
	^ self ffiCall: #( int SDL_SetTextureColorMod ( self , Uint8 r, Uint8 g, Uint8 b ) )! !

!SDL_Texture methodsFor: 'initialization' stamp: ''!
destroy
	handle isNull ifTrue: [ ^ self ].
	self primDestroy.
	handle beNull! !

!SDL_Texture methodsFor: 'pixels handling' stamp: ''!
lockPixels: pixels pitch: pitch
	^ self ffiCall: #( int SDL_LockTexture ( self , nil , void** pixels , int* pitch ) )! !

!SDL_Texture class methodsFor: 'finalization' stamp: ''!
destroyTexture: aHandle
	^ self ffiCall: #( void SDL_DestroyTexture ( void *aHandle ) )! !

!SDL_Texture class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: aHandle
	(aHandle isNil or: [aHandle isNull]) ifTrue: [ ^ self ].
	self destroyTexture: aHandle.
	aHandle beNull! !

!SDL_TouchFingerDownEvent commentStamp: ''!
SDL2 library structure!
!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
dx: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_DX put: anObject! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
dy
	"This method was automatically generated"
	^handle floatAt: OFFSET_DY! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
dx
	"This method was automatically generated"
	^handle floatAt: OFFSET_DX! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_Y put: anObject! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
dy: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_DY put: anObject! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
pressure: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_PRESSURE put: anObject! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
touchId
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_TOUCHID! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle floatAt: OFFSET_X! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_X put: anObject! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle floatAt: OFFSET_Y! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
fingerId
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_FINGERID! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
fingerId: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_FINGERID put: anObject! !

!SDL_TouchFingerDownEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitFingerDownEvent: self! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
pressure
	"This method was automatically generated"
	^handle floatAt: OFFSET_PRESSURE! !

!SDL_TouchFingerDownEvent methodsFor: 'accessing - structure variables' stamp: ''!
touchId: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_TOUCHID put: anObject! !

!SDL_TouchFingerDownEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_FINGERDOWN! !

!SDL_TouchFingerEvent commentStamp: ''!
SDL2 library structure!
!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
dx: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_DX put: anObject! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
dy
	"This method was automatically generated"
	^handle floatAt: OFFSET_DY! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
dx
	"This method was automatically generated"
	^handle floatAt: OFFSET_DX! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_Y put: anObject! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
dy: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_DY put: anObject! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
pressure: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_PRESSURE put: anObject! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
touchId
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_TOUCHID! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle floatAt: OFFSET_X! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_X put: anObject! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle floatAt: OFFSET_Y! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
fingerId
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_FINGERID! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
fingerId: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_FINGERID put: anObject! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
pressure
	"This method was automatically generated"
	^handle floatAt: OFFSET_PRESSURE! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_TouchFingerEvent methodsFor: 'accessing - structure variables' stamp: ''!
touchId: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_TOUCHID put: anObject! !

!SDL_TouchFingerEvent class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Sint64 touchId;
    Sint64 fingerId;
    float x;
    float y;
 	 float dx;
    float dy;
	 float pressure;
 	)! !

!SDL_TouchFingerMotionEvent commentStamp: ''!
SDL2 library structure!
!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
dx: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_DX put: anObject! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
dy
	"This method was automatically generated"
	^handle floatAt: OFFSET_DY! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
dx
	"This method was automatically generated"
	^handle floatAt: OFFSET_DX! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_Y put: anObject! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
dy: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_DY put: anObject! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
pressure: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_PRESSURE put: anObject! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
touchId
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_TOUCHID! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle floatAt: OFFSET_X! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_X put: anObject! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle floatAt: OFFSET_Y! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
fingerId
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_FINGERID! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
fingerId: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_FINGERID put: anObject! !

!SDL_TouchFingerMotionEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitFingerMotionEvent: self! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
pressure
	"This method was automatically generated"
	^handle floatAt: OFFSET_PRESSURE! !

!SDL_TouchFingerMotionEvent methodsFor: 'accessing - structure variables' stamp: ''!
touchId: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_TOUCHID put: anObject! !

!SDL_TouchFingerMotionEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_FINGERMOTION! !

!SDL_TouchFingerUpEvent commentStamp: ''!
SDL2 library structure!
!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
dx: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_DX put: anObject! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
dy
	"This method was automatically generated"
	^handle floatAt: OFFSET_DY! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
dx
	"This method was automatically generated"
	^handle floatAt: OFFSET_DX! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_Y put: anObject! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
dy: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_DY put: anObject! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
pressure: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_PRESSURE put: anObject! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
touchId
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_TOUCHID! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle floatAt: OFFSET_X! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_X put: anObject! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle floatAt: OFFSET_Y! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
fingerId
	"This method was automatically generated"
	^handle signedLongLongAt: OFFSET_FINGERID! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
fingerId: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_FINGERID put: anObject! !

!SDL_TouchFingerUpEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitFingerUpEvent: self! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
pressure
	"This method was automatically generated"
	^handle floatAt: OFFSET_PRESSURE! !

!SDL_TouchFingerUpEvent methodsFor: 'accessing - structure variables' stamp: ''!
touchId: anObject
	"This method was automatically generated"
	handle signedLongLongAt: OFFSET_TOUCHID put: anObject! !

!SDL_TouchFingerUpEvent class methodsFor: 'event type' stamp: ''!
eventType
	^SDL_FINGERUP! !

!SDL_Version commentStamp: ''!
A structure that contains information about the version of SDL in use.

See:
https://wiki.libsdl.org/SDL_version!
!SDL_Version methodsFor: 'accessing - structure variables' stamp: ''!
minor
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_MINOR! !

!SDL_Version methodsFor: 'accessing - structure variables' stamp: ''!
patch: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PATCH put: anObject! !

!SDL_Version methodsFor: 'accessing - structure variables' stamp: ''!
major: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_MAJOR put: anObject! !

!SDL_Version methodsFor: 'accessing - structure variables' stamp: ''!
major
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_MAJOR! !

!SDL_Version methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Append a sequence of characters to aStream that identify the receiver."

	super printOn: aStream.
	aStream nextPut: $(.
	self printAsSemanticVersioningOn: aStream.
	aStream nextPut: $)! !

!SDL_Version methodsFor: 'accessing - structure variables' stamp: ''!
patch
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PATCH! !

!SDL_Version methodsFor: 'printing' stamp: ''!
printAsSemanticVersioningOn: aStream
	"Print in format MAJOR.MINOR.PATCH."

	aStream
		print: self major;
		nextPut: $.;
		print: self minor;
		nextPut: $.;
		print: self patch! !

!SDL_Version methodsFor: 'accessing - structure variables' stamp: ''!
minor: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_MINOR put: anObject! !

!SDL_Version class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^#(
		Uint8 major;
		Uint8 minor;
		Uint8 patch;
 	)! !

!SDL_Version class methodsFor: 'accessing' stamp: ''!
bindingVersion
	^ self new major: 2; minor: 0; patch: 4; yourself! !

!SDL_Window commentStamp: ''!
I represent a handle of SDL2 window, coming from SDL2 library!
!SDL_Window methodsFor: 'window management' stamp: ''!
restore
	^ self ffiCall: #( void SDL_RestoreWindow( self ) )! !

!SDL_Window methodsFor: 'window management' stamp: ''!
getWMInfo: infos
	^ self ffiCall: #( bool SDL_GetWindowWMInfo( self, SDL_SysWMinfo* infos) )! !

!SDL_Window methodsFor: 'private' stamp: ''!
primDestroy
	^ self ffiCall: #( void SDL_DestroyWindow ( self ) )! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
getPositionX: x y: y
	^ self ffiCall: #( void SDL_GetWindowPosition ( self , int* x , int* y ) )! !

!SDL_Window methodsFor: 'text input' stamp: ''!
isTextInputActive
	^ self ffiCall: #(bool SDL_IsTextInputActive(void))! !

!SDL_Window methodsFor: 'window management' stamp: ''!
minimize
	^ self ffiCall: #( void SDL_MinimizeWindow( self ) )! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
setSizeW: w h: h
	^ self ffiCall: #( void SDL_SetWindowSize ( self , int w , int h ) )! !

!SDL_Window methodsFor: 'window management' stamp: ''!
raise

	^ self ffiCall: #( void SDL_RaiseWindow( self ) )! !

!SDL_Window methodsFor: 'surface' stamp: ''!
updateWindowSurface
	^ self ffiCall: #( int SDL_UpdateWindowSurface( self ) )! !

!SDL_Window methodsFor: 'rendering' stamp: ''!
createRenderer: driverIndex flags: flags

	^ (self primCreateRenderer: driverIndex flags: flags) initialize.! !

!SDL_Window methodsFor: 'window management' stamp: ''!
hide
	^ self ffiCall: #( void SDL_HideWindow( self ) )! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
getSizeW: w h: h
	^ self ffiCall: #( void SDL_GetWindowSize ( self , int* w , int* h ) )! !

!SDL_Window methodsFor: 'initialize' stamp: ''!
destroy
	OSSDL2Driver current unregisterWindowWithId: self windowID.
	self primDestroy.
	handle beNull! !

!SDL_Window methodsFor: 'text input' stamp: ''!
stopTextInput
	^ self ffiCall: #(void SDL_StopTextInput(void))! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
icon: surface
	^ self ffiCall: #( void SDL_SetWindowIcon ( self , SDL_Surface* surface ) )! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
title
	^ self ffiCall: #( String SDL_GetWindowTitle ( self ) )! !

!SDL_Window methodsFor: 'surface' stamp: ''!
getWindowSurface
	^ self ffiCall: #( SDL_Surface* SDL_GetWindowSurface( self ) )! !

!SDL_Window methodsFor: 'surface' stamp: ''!
updateWindowSurfaceRects: rects num: numrects
	^ self ffiCall: #( int SDL_UpdateWindowSurfaceRects( self , void* rects , int numrects) )! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
getDisplayIndex
	^ self ffiCall: #( int SDL_GetWindowDisplayIndex ( self ) )! !

!SDL_Window methodsFor: 'private' stamp: ''!
primCreateRenderer: driverIndex flags: flags
	^ self ffiCall: #( SDL_Renderer SDL_CreateRenderer ( self , int driverIndex , Uint32 flags ) )! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
windowID
	^ self ffiCall: #( Uint32 SDL_GetWindowID ( self ) )! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
title: title
	^ self ffiCall: #( void SDL_SetWindowTitle ( self , String title ) )! !

!SDL_Window methodsFor: 'text input' stamp: ''!
startTextInput
	^ self ffiCall: #(void SDL_StartTextInput(void))! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
fullscreen: flags
	^ self ffiCall: #( int SDL_SetWindowFullscreen ( self , Uint32 flags ) )! !

!SDL_Window methodsFor: 'window management' stamp: ''!
show
	^ self ffiCall: #( void SDL_ShowWindow( self ) )! !

!SDL_Window methodsFor: 'window management' stamp: ''!
setHitTest: callback
	^ self ffiCall: #( int SDL_SetWindowHitTest( self , DraggableCallback callback, nil ) )! !

!SDL_Window methodsFor: 'window management' stamp: ''!
toggleBorder: bordered
	^ self ffiCall: #( void SDL_SetWindowBordered( self, bool bordered ) )! !

!SDL_Window methodsFor: 'rendering' stamp: ''!
createDefaultRenderer
	^ self createRenderer: -1 flags: 0! !

!SDL_Window methodsFor: 'rendering' stamp: ''!
createAcceleratedRenderer
	^ self createRenderer: -1 flags: SDL_RENDERER_ACCELERATED! !

!SDL_Window methodsFor: 'external resource management' stamp: ''!
resourceData
	^ {self getHandle. self windowID }! !

!SDL_Window methodsFor: 'surface' stamp: ''!
getFlags
	^ self ffiCall: #( Uint32 SDL_GetWindowFlags ( self ) )! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
setPositionX: x y: y
	^ self ffiCall: #( void SDL_SetWindowPosition ( self , int x , int y ) )! !

!SDL_Window methodsFor: 'accessing' stamp: ''!
glGetDrawableSizeW: w h: h
	^ self ffiCall: #( void SDL_GL_GetDrawableSize ( self , int* w , int* h ) )! !

!SDL_Window methodsFor: 'window management' stamp: ''!
maximize
	^ self ffiCall: #( void SDL_MaximizeWindow( self ) )! !

!SDL_Window class methodsFor: 'finalization' stamp: ''!
destroyWindow: handle
	self ffiCall: #( void SDL_DestroyWindow ( void *handle ) )! !

!SDL_Window class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: aTuple
	| handle windowId |
	
	handle := aTuple first.
	handle isNull ifTrue: [ ^ self ].

	windowId := aTuple second.
	OSSDL2Driver current unregisterWindowWithId: windowId.	
	self destroyWindow: handle.
	handle beNull! !

!SDL_WindowEvent commentStamp: ''!
SDL2 library structure!
!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
type
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TYPE! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
event
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_EVENT! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_WINDOWID put: anObject! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
windowID
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_WINDOWID! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
data2: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_DATA2 put: anObject! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
data1
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_DATA1! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TIMESTAMP put: anObject! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
data1: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_DATA1 put: anObject! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
type: anObject
	"This method was automatically generated"
	handle unsignedLongAt: OFFSET_TYPE put: anObject! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING3 put: anObject! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING2! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
timestamp
	"This method was automatically generated"
	^handle unsignedLongAt: OFFSET_TIMESTAMP! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
data2
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_DATA2! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding3
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING3! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING1 put: anObject! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding2: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_PADDING2 put: anObject! !

!SDL_WindowEvent methodsFor: 'visitor' stamp: ''!
accept: aVisitor
	^ aVisitor visitWindowEvent: self! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
event: anObject
	"This method was automatically generated"
	handle unsignedByteAt: OFFSET_EVENT put: anObject! !

!SDL_WindowEvent methodsFor: 'accessing - structure variables' stamp: ''!
padding1
	"This method was automatically generated"
	^handle unsignedByteAt: OFFSET_PADDING1! !

!SDL_WindowEvent class methodsFor: 'fields description' stamp: ''!
fieldsDesc
	"
	self initializeAccessors
	"
	^ #(
    Uint32 type;
    Uint32 timestamp;
    Uint32 windowID;
    Uint8 event;
    Uint8 padding1;
    Uint8 padding2;
    Uint8 padding3;
    Sint32 data1;
    Sint32 data2;
 	)! !

!SDL_WindowEvent class methodsFor: 'event type' stamp: ''!
eventType
	^ SDL_WINDOWEVENT! !

!SHA1 commentStamp: ''!
This class implements the Secure Hash Algorithm (SHA) described in the U.S. government's Secure Hash Standard (SHS). This standard is described in FIPS PUB 180-1, "SECURE HASH STANDARD", April 17, 1995.

The Secure Hash Algorithm is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Schneier, Wiley, 1996.

See the comment in class DigitalSignatureAlgorithm for details on its use.

Implementation notes:
The secure hash standard was created with 32-bit hardware in mind. All arithmetic in the hash computation must be done modulo 2^32. This implementation uses ThirtyTwoBitRegister objects to simulate hardware registers; this implementation is about six times faster than using LargePositiveIntegers (measured on a Macintosh G3 Powerbook). Implementing a primitive to process each 64-byte buffer would probably speed up the computation by a factor of 20 or more.
!
!SHA1 methodsFor: 'primitives' stamp: ''!
primHashBlock: blockBitmap using: workingTotalsBitmap
	"Hash the given block (a Bitmap) of 80 32-bit words, using the given workingTotals."

	<primitive: 'primitiveHashBlock' module: 'DSAPrims'>
	^ self primitiveFailed
! !

!SHA1 methodsFor: 'primitives' stamp: ''!
primHasSecureHashPrimitive
	"Answer true if this platform has primitive support for the Secure Hash Algorithm."

	<primitive: 'primitiveHasSecureHashPrimitive' module: 'DSAPrims'>
	^ false
! !

!SHA1 methodsFor: 'private' stamp: ''!
initializeTotals
	"Initialize totalA through totalE to their seed values."
	"total registers for use when primitives are absent"
	totalA := ThirtyTwoBitRegister new load: 1732584193.
	totalB := ThirtyTwoBitRegister new load: 4023233417.
	totalC := ThirtyTwoBitRegister new load: 2562383102.
	totalD := ThirtyTwoBitRegister new load: 271733878.
	totalE := ThirtyTwoBitRegister new load: 3285377520.
	self initializeTotalsArray! !

!SHA1 methodsFor: 'public' stamp: ''!
hashStream: aPositionableStream
	"Hash the contents of the given stream from the current position to the end using the Secure Hash Algorithm. The SHA algorithm is defined in FIPS PUB 180-1. It is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Schneier, Wiley, 1996."
	"http://en.wikipedia.org/wiki/Sha1#Example_hashes" 
	"(SHA1 new hashStream: 'The quick brown fox jumps over the lazy dog' readStream) hex."
	
	| startPosition buf bitLength |
	self initializeTotals.
  	
	aPositionableStream atEnd ifTrue: [self processFinalBuffer: #() bitLength: 0].

	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 finalHash asByteArrayOfSize: 20! !

!SHA1 methodsFor: 'private' stamp: ''!
hashFunction: i of: x with: y with: z
	"Compute the hash function for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard."
	"Details: There are four functions, one for each 20 iterations. The second and fourth are the same."

	i <= 20 ifTrue: [^ x copy bitAnd: y; bitOr: (x copy bitInvert; bitAnd: z)].
	i <= 40 ifTrue: [^ x copy bitXor: y; bitXor: z].
	i <= 60 ifTrue: [^ x copy bitAnd: y; bitOr: (x copy bitAnd: z); bitOr: (y copy bitAnd: z)].
	^ x copy bitXor: y; bitXor: z
! !

!SHA1 methodsFor: 'primitives' stamp: ''!
primExpandBlock: aByteArray into: wordBitmap
	"Expand the given 64-byte buffer into the given Bitmap of length 80."

	<primitive: 'primitiveExpandBlock' module: 'DSAPrims'>
	^ self primitiveFailed
! !

!SHA1 methodsFor: 'private' stamp: ''!
finalHash
	"Concatenate the final totals to build the 160-bit integer result."
	"Details: If the primitives are supported, the results are in the totals array. Otherwise, they are in the instance variables totalA through totalE."
	| r |
	totals ifNil: 
		[ "compute final hash when not using primitives"
		^ (totalA asInteger bitShift: 128) + (totalB asInteger bitShift: 96) + (totalC asInteger bitShift: 64) + (totalD asInteger bitShift: 32) + totalE asInteger ].

	"compute final hash when using primitives"
	r := 0.
	1 
		to: 5
		do: [ :i | r := r bitOr: ((totals at: i) bitShift: 32 * (5 - i)) ].
	^ r! !

!SHA1 methodsFor: 'accessing' stamp: ''!
hashInteger: aPositiveInteger seed: seedInteger 
	"Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in the production of random numbers"
	"Initialize totalA through totalE to their seed values."
	| buffer dstIndex |
	totalA := ThirtyTwoBitRegister new load: ((seedInteger bitShift: -128) bitAnd: 4294967295).
	totalB := ThirtyTwoBitRegister new load: ((seedInteger bitShift: -96) bitAnd: 4294967295).
	totalC := ThirtyTwoBitRegister new load: ((seedInteger bitShift: -64) bitAnd: 4294967295).
	totalD := ThirtyTwoBitRegister new load: ((seedInteger bitShift: -32) bitAnd: 4294967295).
	totalE := ThirtyTwoBitRegister new load: (seedInteger bitAnd: 4294967295).
	self initializeTotalsArray.

	"pad integer with zeros"
	buffer := ByteArray new: 64.
	dstIndex := 0.
	aPositiveInteger bytesCount 
		to: 1
		by: -1
		do: 
			[ :i | 
			buffer 
				at: (dstIndex := dstIndex + 1)
				put: (aPositiveInteger byteAt: i) ].

	"process that one block"
	self processBuffer: buffer.
	^ self finalHash! !

!SHA1 methodsFor: 'accessing' stamp: ''!
hashInteger: aPositiveInteger 
	"Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in key generation."
	| buffer dstIndex |
	self initializeTotals.

	"pad integer with zeros"
	aPositiveInteger highBit <= 512 ifFalse: [ self error: 'integer cannot exceed 512 bits' ].
	buffer := ByteArray new: 64.
	dstIndex := 0.
	aPositiveInteger bytesCount 
		to: 1
		by: -1
		do: 
			[ :i | 
			buffer 
				at: (dstIndex := dstIndex + 1)
				put: (aPositiveInteger byteAt: i) ].

	"process that one block"
	self processBuffer: buffer.
	^ self finalHash! !

!SHA1 methodsFor: 'private' stamp: ''!
processBufferUsingPrimitives: aByteArray 
	"Process given 64-byte buffer using the primitives, accumulating the results in totals."
	"expand and process the buffer"
	| w |
	w := WordArray new: 80.
	self 
		primExpandBlock: aByteArray
		into: w.
	self 
		primHashBlock: w
		using: totals! !

!SHA1 methodsFor: 'private' stamp: ''!
constantForStep: i
	"Answer the constant for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard."

	i <= 20 ifTrue: [^ K1].
	i <= 40 ifTrue: [^ K2].
	i <= 60 ifTrue: [^ K3].
	^ K4
! !

!SHA1 methodsFor: 'private' stamp: ''!
expandedBlock: aByteArray 
	"Convert the given 64 byte buffer into 80 32-bit registers and answer the result."
	| out src v |
	out := Array new: 80.
	src := 1.
	1 
		to: 16
		do: 
			[ :i | 
			out 
				at: i
				put: (ThirtyTwoBitRegister new 
						loadFrom: aByteArray
						at: src).
			src := src + 4 ].
	17 
		to: 80
		do: 
			[ :i | 
			v := (out at: i - 3) copy.
			v
				bitXor: (out at: i - 8);
				bitXor: (out at: i - 14);
				bitXor: (out at: i - 16);
				leftRotateBy: 1.
			out 
				at: i
				put: v ].
	^ out! !

!SHA1 methodsFor: 'private' stamp: ''!
processFinalBuffer: buffer bitLength: bitLength 
	"Process given buffer, whose length may be <= 64 bytes, accumulating the results in totalA through totalE. Also process the final padding bits and length."
	| out |
	out := ByteArray new: 64.
	out 
		replaceFrom: 1
		to: buffer size
		with: buffer
		startingAt: 1.
	buffer size < 56 ifTrue: 
		[ "padding and length fit in last data block"
		out 
			at: buffer size + 1
			put: 128.	"trailing one bit"
		self 
			storeLength: bitLength
			in: out.	"end with length"
		self processBuffer: out.
		^ self ].

	"process the final data block"
	buffer size < 64 ifTrue: 
		[ out 
			at: buffer size + 1
			put: 128 ].	"trailing one bit"
	self processBuffer: out.

	"process one additional block of padding ending with the length"
	out := ByteArray new: 64.	"filled with zeros"
	buffer size = 64 ifTrue: 
		[ "add trailing one bit that didn't fit in final data block"
		out 
			at: 1
			put: 128 ].
	self 
		storeLength: bitLength
		in: out.
	self processBuffer: out! !

!SHA1 methodsFor: 'private' stamp: ''!
processBuffer: aByteArray 
	"Process given 64-byte buffer, accumulating the results in totalA through totalE."
	| a b c d e w tmp |
	self primHasSecureHashPrimitive 
		ifTrue: [ ^ self processBufferUsingPrimitives: aByteArray ]
		ifFalse: [ totals := nil ].

	"initialize registers a through e from the current totals"
	a := totalA copy.
	b := totalB copy.
	c := totalC copy.
	d := totalD copy.
	e := totalE copy.

	"expand and process the buffer"
	w := self expandedBlock: aByteArray.
	1 
		to: 80
		do: 
			[ :i | 
			tmp := (a copy leftRotateBy: 5)
				+= (self 
						hashFunction: i
						of: b
						with: c
						with: d);
				+= e;
				+= (w at: i);
				+= (self constantForStep: i).
			e := d.
			d := c.
			c := b copy leftRotateBy: 30.
			b := a.
			a := tmp ].

	"add a through e into total accumulators"
	totalA += a.
	totalB += b.
	totalC += c.
	totalD += d.
	totalE += e! !

!SHA1 methodsFor: 'private' stamp: ''!
initializeTotalsArray
	"Initialize the totals array from the registers for use with the primitives."
	totals := WordArray new: 5.
	totals 
		at: 1
		put: totalA asInteger.
	totals 
		at: 2
		put: totalB asInteger.
	totals 
		at: 3
		put: totalC asInteger.
	totals 
		at: 4
		put: totalD asInteger.
	totals 
		at: 5
		put: totalE asInteger! !

!SHA1 methodsFor: 'private' stamp: ''!
storeLength: bitLength in: aByteArray 
	"Fill in the final 8 bytes of the given ByteArray with a 64-bit big-endian representation of the original message length in bits."
	| n i |
	n := bitLength.
	i := aByteArray size.
	[ n > 0 ] whileTrue: 
		[ aByteArray 
			at: i
			put: (n bitAnd: 255).
		n := n bitShift: -8.
		i := i - 1 ]! !

!SHA1 class methodsFor: 'class initialization' stamp: ''!
initialize
	"SecureHashAlgorithm initialize"
	"For the curious, here's where these constants come from:
	  #(2 3 5 10) collect: [:x | ((x sqrt / 4.0) * (2.0 raisedTo: 32)) truncated hex]"
	K1 := ThirtyTwoBitRegister new load: 1518500249.
	K2 := ThirtyTwoBitRegister new load: 1859775393.
	K3 := ThirtyTwoBitRegister new load: 2400959708.
	K4 := ThirtyTwoBitRegister new load: 3395469782! !

!SHA1 class methodsFor: 'accessing' stamp: ''!
hashSize
	^ 20! !

!SHA1 class methodsFor: 'accessing' stamp: ''!
blockSize
	^ 64! !

!SHA1Test commentStamp: ''!
This is the unit test for the class SecureHashAlgorithm. 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!
!SHA1Test methodsFor: 'testing - examples' stamp: ''!
testEmptyInput

	self assert: ((SHA1 new hashMessage: '') asInteger radix: 16) equals: 'DA39A3EE5E6B4B0D3255BFEF95601890AFD80709'! !

!SHA1Test methodsFor: 'testing - examples' stamp: ''!
testExample1
	"This is the first example from the specification document (FIPS PUB 180-1)"

	hash := SHA1 new hashMessage: 'abc'.
	self assert: hash equals: (ByteArray readHexFrom:  'A9993E364706816ABA3E25717850C26C9CD0D89D').
		! !

!SHA1Test methodsFor: 'testing - examples' stamp: ''!
testExample2
	"This is the second example from the specification document (FIPS PUB 180-1)"

	hash := SHA1 new hashMessage: 'abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'.
	self assert: hash equals: (ByteArray readHexFrom: '84983E441C3BD26EBAAE4AA1F95129E5E54670F1')! !

!SHA1Test methodsFor: 'testing - examples' stamp: ''!
testExample3
	"This is the third example from the specification document (FIPS PUB 180-1). 
	This example may take several minutes."

	hash := SHA1 new hashMessage: (String new: 1000000 withAll: $a).
	self assert: hash asInteger equals: 16r34AA973CD4C4DAA4F61EEB2BDBAD27316534016F.! !

!SHA1Test methodsFor: 'testing' stamp: ''!
testLargeCharacterStream
	"Regression test"

	| string |
	string := String streamContents: [ :out | 10 timesRepeat: [ out << Character alphabet ] ].
	hash := SHA1 hashStream: string readStream.
	self assert: hash hex equals: 'f9d5b271f9126e9051394cffaff0ae3250fd6087'! !

!SHA1Test methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ SHA1 ! !

!SHA256 commentStamp: ''!
I am SHA256, a HashFunction.

I implement the SHA-2 cryptographic hash function with digest size 256.

See also

http://en.wikipedia.org/wiki/Sha256

http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf

Usage

SHA256 hashMessage: 'foo'.

From the older class comments:

Copied from CFSHA256 (Cloudfront)

Please direct questions or comments about this implementation to Ron Teitelbaum: Ron@USMedRec.com

This code was extensively copied from SHA1 by Luciano Notarfrancesco lnotarfrancesco@yahoo.com!
!SHA256 methodsFor: 'private' stamp: ''!
initializeTotals
	"Initialize totalA through totalE to their seed values."

	"total registers for use when primitives are absent"
	totalA := ThirtyTwoBitRegister new load: self class h0.
	totalB := ThirtyTwoBitRegister new load: self class h1.
	totalC := ThirtyTwoBitRegister new load: self class h2.
	totalD := ThirtyTwoBitRegister new load: self class h3.
	totalE := ThirtyTwoBitRegister new load: self class h4.
	totalF := ThirtyTwoBitRegister new load: self class h5.
	totalG := ThirtyTwoBitRegister new load: self class h6.
	totalH := ThirtyTwoBitRegister new load: self class h7.
	self initializeTotalsArray.
! !

!SHA256 methodsFor: 'private' stamp: ''!
expandedBlock: aByteArray
	"Convert the given 64 byte buffer into 80 32-bit registers and answer the result." 
	| out src |
	out := Array new: 64.
	src := 1.
	1 to: 16 do: [:i |
		out at: i put: (ThirtyTwoBitRegister new loadFrom: aByteArray at: src).
		src := src + 4].

	17 to: 64 do: [:i | | s0 s1 wi15 wi2 wi |
		wi15 := (out at: i - 15) copy.
		wi2 := (out at: i-2) copy.
		s0 := wi15 copy.
		s0 leftRotateBy: -7;
			bitXor: (wi15 copy leftRotateBy: -18);
			bitXor: (wi15 copy bitShift: -3).
		s1 := wi2 copy.
		s1 leftRotateBy: -17;
			bitXor: (wi2 copy leftRotateBy: -19);
			bitXor: (wi2 copy bitShift: -10).
		wi := (out at: i-16) copy += s0 += (out at: i-7) copy += s1.
		out at: i put: wi].
	^ out
! !

!SHA256 methodsFor: 'accessing' stamp: ''!
hashStream: aPositionableStream
	"Hash the contents of the given stream from the current position to the end using SHA-256, the 256-bit variant of SHA-2. The SHA-2 family of algorithms are defined in FIPS PUB 180-4."
	"SHA256 new hashStream: (ReadStream on: 'foo')"

	| startPosition buf bitLength |
	self initializeTotals.

	aPositionableStream atEnd ifTrue: [ self processFinalBuffer: #() bitLength: 0 ].

	startPosition := aPositionableStream position.
	[ aPositionableStream atEnd ] whileFalse: [
		buf := aPositionableStream next: 64 into: (ByteArray new: 64).
		(aPositionableStream atEnd not and: [ buf size = 64 ])
			ifTrue: [ self processBuffer: buf ]
			ifFalse: [
				bitLength := (aPositionableStream position - startPosition) * 8.
				self processFinalBuffer: buf bitLength: bitLength ] ].

	^self finalHash asByteArrayOfSize: 32! !

!SHA256 methodsFor: 'private' stamp: ''!
processFinalBuffer: buffer bitLength: bitLength
	"Process given buffer, whose length may be <= 64 bytes, accumulating the results in totalA through totalE. Also process the final padding bits and length."

	| out |
	out := ByteArray new: 64.
	out replaceFrom: 1 to: buffer size with: buffer startingAt: 1.
	buffer size < 56 ifTrue: [  "padding and length fit in last data block"
		out at: buffer size + 1 put: 128.  "trailing one bit"
		self storeLength: bitLength in: out.  "end with length"
		self processBuffer: out.
		^ self].

	"process the final data block"
	buffer size < 64 ifTrue: [
		out at: buffer size + 1 put: 128].  "trailing one bit"
	self processBuffer: out.

	"process one additional block of padding ending with the length"
	out := ByteArray new: 64.  "filled with zeros"
	buffer size = 64 ifTrue: [
		"add trailing one bit that didn't fit in final data block"
		out at: 1 put: 128].
	self storeLength: bitLength in: out.
	self processBuffer: out.
! !

!SHA256 methodsFor: 'accessing' stamp: ''!
finalHash
	"Concatenate the final totals to build the 256-bit integer result."
	"Details: If the primitives are supported, the results are in the totals array. Otherwise, they are in the instance variables totalA through totalE."

		^ (totalA asInteger bitShift: 224) +
		  (totalB asInteger bitShift: 192) +
		  (totalC asInteger bitShift: 160) +	
		  (totalD asInteger bitShift: 128) +
		  (totalE asInteger bitShift:  96) +
		  (totalF asInteger bitShift:  64) +
		  (totalG asInteger bitShift:  32) +
		  (totalH asInteger).! !

!SHA256 methodsFor: 'private' stamp: ''!
processBuffer: aByteArray
	"Process given 64-byte buffer, accumulating the results in totalA through totalE."

	| a b c d e f g h w |
	totals := nil.

	"initialize registers a through e from the current totals" 
	a := totalA copy.
	b := totalB copy.
	c := totalC copy.
	d := totalD copy.
	e := totalE copy.
	f := totalF copy.
	g := totalG copy.
	h := totalH copy.

	"expand and process the buffer"
	w := self expandedBlock: aByteArray.
	1 to: 64 do: [:i | | s0 maj t0 s1 ch t1 |
		s0 := (a copy leftRotateBy: -2).
		s0 bitXor: (a copy leftRotateBy: -13);
			bitXor: (a copy leftRotateBy: -22).
		maj := (a copy bitAnd: b).
		maj bitOr: (b copy bitAnd: c);
			bitOr: (c copy bitAnd: a).
		t0 := s0 copy += maj.
		s1 := (e copy leftRotateBy: -6).
		s1 bitXor: (e copy leftRotateBy: -11);
			bitXor: (e copy leftRotateBy: -25).
		ch := (e copy bitAnd: f).
		ch bitOr: ((e copy bitInvert) bitAnd: g).
		t1 := h copy += s1 += ch += (ThirtyTwoBitRegister new load: (self class roundConstants at: i)) += (w at: i) copy.
		h := g.
		g := f.
		f := e.
		e := d copy += t1.
		d := c.
		c := b.
		b := a.
		a := t0 += t1.
	"Transcript cr; show: i asString, String tab, a asString, String tab, b asString, String tab, c asString, String tab, d asString, String tab, e asString, String tab, f asString, String tab, g asString, String tab, h asString, String tab."
	].

	"add a through e into total accumulators"
	totalA += a.
	totalB += b.
	totalC += c.
	totalD += d.
	totalE += e.
	totalF += f.
	totalG += g.
	totalH += h.
! !

!SHA256 methodsFor: 'private' stamp: ''!
initializeTotalsArray
	"Initialize the totals array from the registers for use with the primitives."

	totals := WordArray new: 8.
	totals at: 1 put: totalA asInteger.
	totals at: 2 put: totalB asInteger.
	totals at: 3 put: totalC asInteger.
	totals at: 4 put: totalD asInteger.
	totals at: 5 put: totalE asInteger.
	totals at: 6 put: totalF asInteger.
	totals at: 7 put: totalG asInteger.
	totals at: 8 put: totalH asInteger.! !

!SHA256 methodsFor: 'private' stamp: ''!
storeLength: bitLength in: aByteArray
	"Fill in the final 8 bytes of the given ByteArray with a 64-bit big-endian representation of the original message length in bits."

	| n i |
	n := bitLength.
	i := aByteArray size.
	[n > 0] whileTrue: [
		aByteArray at: i put: (n bitAnd: 16rFF).
		n := n bitShift: -8.
		i := i - 1].
! !

!SHA256 class methodsFor: 'constants' stamp: ''!
h7
	"2 raisedTo: 32 times the square root of the first 8 primes 2..19"
	"#(2 3 5 7 11 13 17 19) collect: [:x | ((x sqrt) * (2.0 raisedTo: 32)) truncated hex] // 32 bits"
	^16r5BE0CD19! !

!SHA256 class methodsFor: 'constants' stamp: ''!
h0
	"2 raisedTo: 32 times the square root of the first 8 primes 2..19"
	"#(2 3 5 7 11 13 17 19) collect: [:x | ((x sqrt) * (2.0 raisedTo: 32)) truncated hex] // 32 bits"
	^16r6A09E667! !

!SHA256 class methodsFor: 'accessing' stamp: ''!
hashSize
	^ 32! !

!SHA256 class methodsFor: 'constants' stamp: ''!
h3
	"2 raisedTo: 32 times the square root of the first 8 primes 2..19"
	"#(2 3 5 7 11 13 17 19) collect: [:x | ((x sqrt) * (2.0 raisedTo: 32)) truncated hex] // 32 bits"
	^16rA54FF53A! !

!SHA256 class methodsFor: 'accessing' stamp: ''!
blockSize
	^ 64! !

!SHA256 class methodsFor: 'constants' stamp: ''!
h5
	"2 raisedTo: 32 times the square root of the first 8 primes 2..19"
	"#(2 3 5 7 11 13 17 19) collect: [:x | ((x sqrt) * (2.0 raisedTo: 32)) truncated hex] // 32 bits"
	^16r9B05688C! !

!SHA256 class methodsFor: 'constants' stamp: ''!
h6
	"2 raisedTo: 32 times the square root of the first 8 primes 2..19"
	"#(2 3 5 7 11 13 17 19) collect: [:x | ((x sqrt) * (2.0 raisedTo: 32)) truncated hex] // 32 bits"
	^16r1F83D9AB! !

!SHA256 class methodsFor: 'constants' stamp: ''!
h1
	"2 raisedTo: 32 times the square root of the first 8 primes 2..19"
	"#(2 3 5 7 11 13 17 19) collect: [:x | ((x sqrt) * (2.0 raisedTo: 32)) truncated hex] // 32 bits"
	^16rBB67AE85! !

!SHA256 class methodsFor: 'constants' stamp: ''!
h2
	"2 raisedTo: 32 times the square root of the first 8 primes 2..19"
	"#(2 3 5 7 11 13 17 19) collect: [:x | ((x sqrt) * (2.0 raisedTo: 32)) truncated hex] // 32 bits"
	^16r3C6EF372! !

!SHA256 class methodsFor: 'constants' stamp: ''!
roundConstants
	"2 raisedTo: 32 times the cube root of the first 64 primes 2..311"
	"(Integer primesUpTo: 311) collect: [:x | ((x raisedTo: 1/3) * (2.0 raisedTo: 32)) truncated hex] \\ 32 bits" 
	^#(16r428A2F98 16r71374491 16rB5C0FBCF 16rE9B5DBA5 16r3956C25B 16r59F111F1 16r923F82A4 16rAB1C5ED5 16rD807AA98 16r12835B01 16r243185BE 16r550C7DC3 16r72BE5D74 16r80DEB1FE 16r9BDC06A7 16rC19BF174 16rE49B69C1 16rEFBE4786 16r0FC19DC6 16r240CA1CC 16r2DE92C6F 16r4A7484AA 16r5CB0A9DC 16r76F988DA 16r983E5152 16rA831C66D 16rB00327C8 16rBF597FC7 16rC6E00BF3 16rD5A79147 16r06CA6351 16r14292967 16r27B70A85 16r2E1B2138 16r4D2C6DFC 16r53380D13 16r650A7354 16r766A0ABB 16r81C2C92E 16r92722C85 16rA2BFE8A1 16rA81A664B 16rC24B8B70 16rC76C51A3 16rD192E819 16rD6990624 16rF40E3585 16r106AA070 16r19A4C116 16r1E376C08 16r2748774C 16r34B0BCB5 16r391C0CB3 16r4ED8AA4A 16r5B9CCA4F 16r682E6FF3 16r748F82EE 16r78A5636F 16r84C87814 16r8CC70208 16r90BEFFFA 16rA4506CEB 16rBEF9A3F7 16rC67178F2)
	! !

!SHA256 class methodsFor: 'constants' stamp: ''!
h4
	"2 raisedTo: 32 times the square root of the first 8 primes 2..19"
	"#(2 3 5 7 11 13 17 19) collect: [:x | ((x sqrt) * (2.0 raisedTo: 32)) truncated hex] // 32 bits"
	^16r510E527F! !

!SHA256Test commentStamp: ''!
SHA256Tests contains unit tests for SHA256.

Test vectors taken from

http://en.wikipedia.org/wiki/Sha256

http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf
!
!SHA256Test methodsFor: 'testing' stamp: ''!
testFips180Example1
	hash := SHA256 hashMessage: 'abc'.
	self assert: hash hex equals: 'ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad'! !

!SHA256Test methodsFor: 'testing' stamp: ''!
testFips180Example3
	"This test is a bit slow if the implementation is not making use of extra primitives"
	self timeLimit: 10 seconds.
	
	hash := SHA256 hashMessage: (String new: 1e6 withAll: $a).
	self assert: hash hex equals: 'cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0'! !

!SHA256Test methodsFor: 'testing' stamp: ''!
testWikipediaExample1
	hash := SHA256 hashMessage: 'The quick brown fox jumps over the lazy dog'.
	self assert: hash hex equals: 'd7a8fbb307d7809469ca9abcb0082e4f8d5651e46d3cdb762d02d0bf37c9e592'! !

!SHA256Test methodsFor: 'testing' stamp: ''!
testLargeCharacterStream
	"Regression test"

	| string |
	string := String streamContents: [ :out | 10 timesRepeat: [ out << Character alphabet ] ].
	hash := SHA256 hashStream: string readStream.
	self assert: hash hex equals: '6f6a4460cbd9241d7eff776ce2fd0439e0a865fb05b99f2c5f6f527f226e254d'! !

!SHA256Test methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ SHA256 ! !

!SHA256Test methodsFor: 'testing' stamp: ''!
testWikipediaExampleEmpty
	hash := SHA256 hashMessage: ''.
	self assert: hash hex equals: 'e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855'! !

!SHA256Test methodsFor: 'testing' stamp: ''!
testWikipediaExample2
	hash := SHA256 hashMessage: 'The quick brown fox jumps over the lazy dog.'.
	self assert: hash hex equals: 'ef537f25c895bfa782526529a9b63d97aa631564d5d789c2b765448c8635fb6c'! !

!SHA256Test methodsFor: 'testing' stamp: ''!
testFips180Example2
	hash := SHA256 hashMessage: 'abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'.
	self assert: hash hex equals: '248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1'! !

!SHPreferences commentStamp: ''!
Preferences for Shout!
!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
errorStyle: aGroupStyle 
	^ Groups at: #error put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
reservedWordsStyle: aGroupStyle 
	^ Groups at: #reservedWords put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
defaultStyle
	^ Groups at: #default! !

!SHPreferences class methodsFor: 'settings' stamp: ''!
setStyleTableNamed: aString
	self setStyleTable: (((Pragma allNamed: #styleTable: in: SHRBTextStyler class)
		detect: [ :each | (each argumentAt: 1) = aString ])
		method 
			valueWithReceiver: SHRBTextStyler class 
			arguments: #())! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
reservedWordsStyle
	^ Groups at: #reservedWords! !

!SHPreferences class methodsFor: 'private' stamp: ''!
customStyleTable
	^ CustomStyleTable! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
selectorPatternsStyle
	^ Groups at: #selectorPatterns! !

!SHPreferences class methodsFor: 'private' stamp: ''!
customStyleTable: anArray 
	CustomStyleTable := anArray.
	self initializeGroups! !

!SHPreferences class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder 
	<systemsettings>
	(aBuilder setting: #'Syntax Highlighting') 
		target: self;
		dialog: [ self styleTableRow ];
		parentName: #codeBrowsing;
		description: 'Syntax Highlighting As You Type: Enable syntax highlighting in browsers, debuggers and workspaces and set patterns style.';
		selector: #enabled;
		default: true;
		iconName: #smallConfigurationIcon;
		with: [
			(aBuilder setting: #selectorPatternsStyle) 
				label: 'Selector Patterns';
				default: (SHStyleElement emphasis: #bold tokens: #(#patternKeyword #patternBinary #patternUnary));
				description: 'Selector patterns in method pane'.
			(aBuilder setting: #errorStyle)			 
				default: (SHStyleElement color: Color red tokens: #(#invalid #excessCode #undefinedKeyword #undefinedBinary #undefinedUnary #undefinedIdentifier));
				label: 'Syntactic error';
				description: 'Invalid and undefined code' .
			(aBuilder setting: #argsStyle) 
				label: 'Parameters';
				default: (SHStyleElement color: (Color r: 0.0 g: 0.0 b: 0.5004887585532747 alpha: 1.0) tokens: #(#patternArg #methodArg #blockPatternArg #blockArg #argument));
				description: 'Parameters in patterns, message sends, and blocks' .
			(aBuilder setting: #commentStyle) 
				label: 'Comments';
				default: (SHStyleElement color: (Color r: 0.4203323558162268 g: 0.4203323558162268 b: 0.4203323558162268 alpha: 1.0) tokens: #(#comment #unfinishedComment));
				description: 'Comments in code pane' .
			(aBuilder setting: #defaultStyle) 
				label: 'Default' ;
				default: (SHStyleElement color: Color black tokens: #(#default));
				description: 'Default style' .
			(aBuilder setting: #globalVarStyle) 
				label: 'Global variables' ;
				default: (SHStyleElement color: (Color r: 0.0 g: 0.0 b: 0.5004887585532747 alpha: 1.0) tokens: #(#globalVar #poolConstant));
				description: 'References to global variables, including classes' .
			(aBuilder setting: #instanceVarStyle) 
				label: 'Instance/class variables' ;
				default: (SHStyleElement color: (Color r: 0.0 g: 0.0 b: 0.5004887585532747 alpha: 1.0) tokens: #(#instVar #classVar));
				description: 'References to instance and class variables' .
			(aBuilder setting: #messageSendsStyle) 
				default: (SHStyleElement color: Color black tokens: #(#keyword #binary #unary #incompleteKeyword #incompleteBinary #incompleteUnary));
				label: 'Message sends' ;
				description: 'Message sends' .
			(aBuilder setting: #primitiveOrModuleStyle) 
				label: 'Primitive or module' ;
				default: (SHStyleElement color: (Color r: 0.0 g: 0.5004887585532747 b: 0.0 alpha: 1.0) tokens: #(#primitive #externalFunctionCallingConvention #module #externalCallType #externalCallTypePointerIndicator #primitiveOrExternalCallStart #primitiveOrExternalCallEnd));
				description: 'Primitive or module' .
			(aBuilder setting: #primitiveTypesStyle) 
				label: 'Primitive types';
				default: (SHStyleElement color: (Color r: 0.5004887585532747 g: 0.0 b: 0.0 alpha: 1.0) tokens: #(#'$' #character #integer #number #- #symbol #stringSymbol #literalArray #string #unfinishedString));
				description: 'Literal data' .
			(aBuilder setting: #reservedWordsStyle) 
				label: 'Reserved words';
				default: (SHStyleElement color: (Color r: 0.0 g: 0.5004887585532747 b: 0.5004887585532747 alpha: 1.0) tokens: #(#self #super #true #false #nil #thisContext));
				description: 'Reserved words of the Smalltalk language' .
			(aBuilder setting: #syntaxStyle) 
				label: 'Syntax';
				default: (SHStyleElement tokens: #(#assignment #ansiAssignment #literal #return #blockArgColon #leftParenthesis #rightParenthesis #leftParenthesis1 #rightParenthesis1 #leftParenthesis2 #rightParenthesis2 #leftParenthesis3 #rightParenthesis3 #leftParenthesis4 #rightParenthesis4 #leftParenthesis5 #rightParenthesis5 #leftParenthesis6 #rightParenthesis6 #leftParenthesis7 #rightParenthesis7 #blockStart #blockEnd #blockStart1 #blockEnd1 #blockStart2 #blockEnd2 #blockStart3 #blockEnd3 #blockStart4 #blockEnd4 #blockStart5 #blockEnd5 #blockStart6 #blockEnd6 #blockStart7 #blockEnd7 #arrayStart #arrayEnd #arrayStart1 #arrayEnd1 #byteArrayStart #byteArrayEnd #byteArrayStart1 #byteArrayEnd1 #leftBrace #rightBrace #cascadeSeparator #statementSeparator #methodTempBar #blockTempBar #blockArgsBar));
				description: 'Any other syntactic element' .
			(aBuilder setting: #variableStyle) 
				label: 'Variable';
				default: (SHStyleElement color: (Color r: 0.0 g: 0.0 b: 0.5004887585532747 alpha: 1.0) tokens: #(#blockTempVar #blockPatternTempVar #workspaceVar #tempVar #patternTempVar #incompleteIdentifier));
				description: 'Temporary variable'  ]! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
primitiveTypesStyle
	^ Groups at: #primitiveTypes! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
defaultStyle: aGroupStyle 
	^ Groups at: #default put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
instanceVarStyle
	^ Groups at: #instanceVar! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
instanceVarStyle: aGroupStyle 
	^ Groups at: #instanceVar put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing' stamp: ''!
enabled: aBoolean 
	enabled := aBoolean! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
selectorPatternsStyle: aGroupStyle 
	^ Groups at: #selectorPatterns put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
errorStyle
	^ Groups at: #error! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
argsStyle: aGroupStyle 
	^ Groups at: #args put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
messageSendsStyle
	^ Groups at: #messageSends! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
globalVarStyle
	^ Groups at: #globalVar! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
syntaxStyle
	^ Groups at: #syntax! !

!SHPreferences class methodsFor: 'settings' stamp: ''!
styleTableRow
	| allStyles |
	
	allStyles := Pragma  allNamed: #styleTable: in: SHRBTextStyler class.
	^Smalltalk ui theme 
		newRowIn: self 
		for: (
			{ Smalltalk ui theme buttonLabelForText: 'Predefined styles: ' translated }, 
			(allStyles collect: [ :eachPragma | 
				(Smalltalk ui theme 
					newButtonIn: self
					for:  self
					getState: nil 
					action: #setStyleTableNamed:  
					arguments:  { eachPragma argumentAt: 1 }
					getEnabled: nil 
					getLabel: nil
					help: ('Change style table to ', (eachPragma argumentAt: 1)) translated)
						label: (eachPragma argumentAt: 1);
						yourself ] ))! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
primitiveTypesStyle: aGroupStyle 
	^ Groups at: #primitiveTypes put: aGroupStyle! !

!SHPreferences class methodsFor: 'private' stamp: ''!
applyStyle
	| table |
	table := Groups values flatCollect: [:group | group styleForTable].
	SHRBTextStyler styleTable: table.! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
variableStyle: aGroupStyle 
	^ Groups at: #variable put: aGroupStyle! !

!SHPreferences class methodsFor: 'class initialization' stamp: ''!
initialize
	self customStyleTable: SHRBTextStyler defaultStyleTable! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
globalVarStyle: aGroupStyle 
	^ Groups at: #globalVar put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
argsStyle
	^ Groups at: #args! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
messageSendsStyle: aGroupStyle 
	^ Groups at: #messageSends put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
syntaxStyle: aGroupStyle 
	^ Groups at: #syntax put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
primitiveOrModuleStyle: aGroupStyle 
	^ Groups at: #primitiveOrModule put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
commentStyle: aGroupStyle 
	^ Groups at: #comment put: aGroupStyle! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
primitiveOrModuleStyle
	^ Groups at: #primitiveOrModule! !

!SHPreferences class methodsFor: 'accessing' stamp: ''!
enabled
	^ enabled
		ifNil: [enabled := true]! !

!SHPreferences class methodsFor: 'private - initialization' stamp: ''!
initializeGroups
	Groups := Dictionary new.
	#(#default #(#default ) #reservedWords #(#self #super #true #false #nil #thisContext ) #primitiveTypes #(#'$' #character #integer #number #- #symbol #stringSymbol #literalArray #string #unfinishedString ) #selectorPatterns #(#patternKeyword #patternBinary #patternUnary ) #messageSends #(#keyword #binary #unary #incompleteKeyword #incompleteBinary #incompleteUnary ) #primitiveOrModule #(#primitive #externalFunctionCallingConvention #module #externalCallType #externalCallTypePointerIndicator #primitiveOrExternalCallStart #primitiveOrExternalCallEnd ) #args #(#patternArg #methodArg #blockPatternArg #blockArg #argument ) #variable #(#blockTempVar #blockPatternTempVar #workspaceVar #tempVar #patternTempVar #incompleteIdentifier ) #instanceVar #(#instVar #classVar ) #globalVar #(#globalVar #poolConstant ) #comment #(#comment #unfinishedComment ) #error #(#invalid #excessCode #undefinedKeyword #undefinedBinary #undefinedUnary #undefinedIdentifier ) #syntax #(#assignment #ansiAssignment #literal #return #blockArgColon #leftParenthesis #rightParenthesis #leftParenthesis1 #rightParenthesis1 #leftParenthesis2 #rightParenthesis2 #leftParenthesis3 #rightParenthesis3 #leftParenthesis4 #rightParenthesis4 #leftParenthesis5 #rightParenthesis5 #leftParenthesis6 #rightParenthesis6 #leftParenthesis7 #rightParenthesis7 #blockStart #blockEnd #blockStart1 #blockEnd1 #blockStart2 #blockEnd2 #blockStart3 #blockEnd3 #blockStart4 #blockEnd4 #blockStart5 #blockEnd5 #blockStart6 #blockEnd6 #blockStart7 #blockEnd7 #arrayStart #arrayEnd #arrayStart1 #arrayEnd1 #byteArrayStart #byteArrayEnd #byteArrayStart1 #byteArrayEnd1 #leftBrace #rightBrace #cascadeSeparator #statementSeparator #methodTempBar #blockTempBar #blockArgsBar ) )
		pairsDo: [:gname :tokens | Groups
				at: gname
				put: (SHStyleElement withTokens: tokens)]! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
commentStyle
	^ Groups at: #comment! !

!SHPreferences class methodsFor: 'accessing - styles' stamp: ''!
variableStyle
	^ Groups at: #variable! !

!SHPreferences class methodsFor: 'settings' stamp: ''!
setStyleTable: anArray
	SHRBTextStyler styleTable: anArray.! !

!SHRBTextStyler commentStamp: ''!
I'm the one who visits node to coloring the code!
!SHRBTextStyler methodsFor: 'formatting' stamp: ''!
addStyle: styleSymbol from: start to: end
	self addAttributes: (self attributesFor: styleSymbol) from: start to: end.! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
currentOpenedParenthesisStyleName
	parentheseLevel isZero ifTrue: [ ^ #leftParenthesis ].
	^ (#leftParenthesis asString , parentheseLevel asString) asSymbol! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
resolveTextLinkFor: aVariableNode

	aVariableNode binding isGlobalVariable
		ifTrue: [ ^ TextClassLink className: aVariableNode name ].	
	^ TextVariableLink variableName: aVariableNode name! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode
	aBlockNode comments
		do:
			[ :comment | self addStyle: #comment from: comment start to: comment stop ].
	aBlockNode arguments do: [ :argument | self visitNode: argument ].
	aBlockNode bar
		ifNotNil: [ :pos | self addStyle: #blockArgsBar from: pos to: pos ].
	aBlockNode colons
		do: [ :pos | self addStyle: #blockArgColon from: pos to: pos ].
	self styleOpenBracket: aBlockNode.
	self visitNode: aBlockNode body.
	self styleCloseBracket: aBlockNode! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode
	self styleTempBars: aSequenceNode.
	aSequenceNode temporaries do: [ :each | self visitNode: each ].
	aSequenceNode statements do: [ :each | self visitNode: each ].
	aSequenceNode periods
		do: [ :pos | self addStyle: #statementSeparator from: pos to: pos ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitArgumentVariableNode: anArgumentNode

	^ self visitLocalVariableNode: anArgumentNode! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitGlobalNode: aSelfNode
	^ self visitVariableNode: aSelfNode! !

!SHRBTextStyler methodsFor: 'accessing' stamp: ''!
isForWorkspace: aBoolean
	isForWorkspace := aBoolean! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitReturnNode: aReturnNode 
	self 
		addStyle: #return
		from: aReturnNode start
		to: aReturnNode stop.
		
	self visitNode: aReturnNode value! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitClassVariableNode: aNode
	^ self visitLiteralVariableNode: aNode! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: anAssignmentNode
	self visitNode: anAssignmentNode variable.
	self visitNode: anAssignmentNode value.
	anAssignmentNode variable binding isWritable
		ifFalse: [ self addStyle: #invalid forNode: anAssignmentNode ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitLiteralNode: aLiteralNode! !

!SHRBTextStyler methodsFor: 'formatting' stamp: ''!
addStyle: styleSymbol attributes: additionalAttributes forNode: anRBNode
	self 
		addAttributes: (self attributesFor: styleSymbol), additionalAttributes 
		forNode: anRBNode.! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitNode: aNode 
	aNode comments do: [:comment|
		self 
			addStyle: #comment
			from: comment start
			to: comment stop ].

	^aNode acceptVisitor: self! !

!SHRBTextStyler methodsFor: 'formatting' stamp: ''!
literalStyleSymbol: aValue

	aValue isSymbol
		ifTrue: [ ^ #symbol ].
	aValue isString
		ifTrue: [ ^ #string ].
	aValue isCharacter
		ifTrue: [ ^ #character ].
	aValue isNumber
		ifTrue: [ ^ #number ].
	aValue == true
		ifTrue: [ ^ #true ].
	aValue == false
		ifTrue: [ ^ #false ].
	aValue ifNil: [ ^ #nil ].
	^ #default! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitUnreachableStatement: anUnreachableStatement
	
	^ self visitEnglobingErrorNode: anUnreachableStatement! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
attributesFor: aSymbol 
	^ self class attributesFor: aSymbol pixelHeight: self pixelHeight! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitLocalVariableNode: aNode
	"call visitTemporaryNode: for backward compatibility"
	^ self visitTemporaryNode: aNode! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
styleOpenBracket: aBlockNode
	| style |
	style := aBlockNode isFaulty
		ifTrue: [ #invalid ]
		ifFalse: [ self currentOpenedBracketStyleName ].
	self addStyle: style from: aBlockNode left to: aBlockNode left.
	bracketLevel := bracketLevel + 1! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitThisContextNode: aThisContextNode
	self addStyle: #thisContext forNode: aThisContextNode! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitParseErrorNode: anErrorNode
	self 
		addStyle: #invalid
		forNode: anErrorNode! !

!SHRBTextStyler methodsFor: 'styling' stamp: ''!
unstyledTextFrom: aText 
	"return a Text object without all styling attributes"
	| answer |
	answer := super unstyledTextFrom: aText.
	self 
		addAttributesFrom: aText runs 
		satisfying: [ :each| each isKindOf: TextAction ]
		to: answer.
	^ answer! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
pixelHeight
	^ pixelHeight ifNil: [ pixelHeight := (font ifNil: [ TextStyle defaultFont ]) pixelSize ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitPatternWrapperBlockNode: aRBPatternWrapperBlockNode 
	self 
		visitNode: aRBPatternWrapperBlockNode wrappedNode;
		visitArgumentNodes: aRBPatternWrapperBlockNode arguments;
		visitNode: aRBPatternWrapperBlockNode body! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
privateStyle: aText
	| ast |
	aText ifEmpty: [ ^ self ].
	ast := classOrMetaClass compiler
		source: aText asString;
		noPattern: self isForWorkspace ;
		options:  #(+ optionParseErrors + optionSkipSemanticWarnings);
		requestor: workspace;
		parse.				
	^ self style: aText ast: ast! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitTemporaryNode: aTemporaryNode
	| methodOrBlockTempStyle |
	methodOrBlockTempStyle := self methodOrBlockTempStyleFor: aTemporaryNode.
	self addStyle: methodOrBlockTempStyle forNode: aTemporaryNode! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitEnglobingErrorNode: anEnglobingErrorNode

	self addStyle: #invalid from: anEnglobingErrorNode stop to: anEnglobingErrorNode stop + 1.
	anEnglobingErrorNode content do: [:each | self visitNode: each ]! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
currentClosedBracketStyleName
	bracketLevel isZero ifTrue: [ ^ #blockEnd ].
	^ (#blockEnd asString , bracketLevel asString) asSymbol! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aRBLiteralArrayNode
	"In a (valid) byte array all elements are of the same type, style the whole contents
at once, but for ordinary literal arrays, style every node"

	(aRBLiteralArrayNode isForByteArray and: [ 
		aRBLiteralArrayNode isFaulty not and: [ 
			aRBLiteralArrayNode contents isNotEmpty 
		]
	]) ifTrue: [ 
			self addStyle: #number 
				from: aRBLiteralArrayNode start + 2 
				to: aRBLiteralArrayNode stop - 1 ]
		ifFalse: [ aRBLiteralArrayNode contents do: [ :each | self visitNode: each ]]! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
resolveVariableAttributesFor: aVariableNode
	| textLink global |
	textLink := self resolveTextLinkFor: aVariableNode.
	aVariableNode binding isGlobalVariable ifFalse: [ ^{textLink} ].
	
	global :=	 aVariableNode binding value.
	(global isClass and: [ global isDeprecated ]) ifFalse: [ ^{textLink} ].
	
	^{ textLink. TextEmphasis struckOut }! !

!SHRBTextStyler methodsFor: 'accessing' stamp: ''!
font: aFont 
	font := aFont! !

!SHRBTextStyler methodsFor: 'formatting' stamp: ''!
addStyle: styleSymbol attribute: additionalAttribute forNode: anRBNode
	self 
		addStyle:styleSymbol
		attributes: { additionalAttribute }
		forNode: anRBNode.! !

!SHRBTextStyler methodsFor: 'visiting - reflectivity' stamp: ''!
visitStorePopIntoTempNode: aNode
	^ aNode! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
currentClosedParenthesisStyleName
	parentheseLevel isZero ifTrue: [ ^ #rightParenthesis ].
	^ (#rightParenthesis asString , parentheseLevel asString) asSymbol! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
resolveStyleFor: aVariableNode
	aVariableNode binding ifNil: [^#default].
	aVariableNode isArgumentVariable ifTrue: [ ^#methodArg].
	aVariableNode isTempVariable ifTrue: [ ^#tempVar].
	aVariableNode isGlobalVariable ifTrue: [ ^#globalVar].
	"here we should add support for #classVar"
	aVariableNode isClassVariable ifTrue: [ ^#globalVar].
	aVariableNode isInstanceVariable ifTrue: [ ^#instVar]. 
	"for now we use temp variable here, we could now color them with their own color"
	aVariableNode isWorkspaceVariable ifTrue: [ ^#tempVar]. 
	
	(self class formatIncompleteIdentifiers and: [ aVariableNode hasIncompleteIdentifier ]) 
		ifTrue:[ ^#incompleteIdentifier] .
	"Note: if formatIncompleteIdentifiers is true, a non-exisiting variable might be incomplete"
	aVariableNode isUndeclaredVariable ifTrue: [ ^#undefinedIdentifier ].

	^#invalid.! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitArgumentNode: anArgumentNode
	| blockOrMethodArgStyle |
	blockOrMethodArgStyle := self methodOrBlockArgStyleFor: anArgumentNode.
	self addStyle: blockOrMethodArgStyle forNode: anArgumentNode! !

!SHRBTextStyler methodsFor: 'visiting - reflectivity' stamp: ''!
visitStoreIntoTempNode: aNode
	^ aNode! !

!SHRBTextStyler methodsFor: '*PharoDocComment' stamp: ''!
visitMethodComments: comments
	comments do: [ :comment | self addStyle: #comment from: comment start to: comment stop ].
	PharoDocCommentNode docCommentEnabled
		ifTrue: [ comments do: [ :comment | self styleDocComment: comment ] ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitArrayNode: anArrayNode 

	anArrayNode children do: [:each | self visitNode: each]! !

!SHRBTextStyler methodsFor: 'accessing' stamp: ''!
classOrMetaClass: aBehavior 
	classOrMetaClass := aBehavior! !

!SHRBTextStyler methodsFor: 'accessing' stamp: ''!
isForWorkspace
	^ isForWorkspace ifNil: [ workspace notNil ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitMessageNode: aMessageNode
	| style link |
	style := #keyword.
	
	(Symbol findInternedSelector: aMessageNode selector asString)
		ifNil:[ style := self formatIncompleteSelector: aMessageNode ].
		
	link := TextMethodLink sourceNode: aMessageNode.
	self styleOpenParenthese: aMessageNode.
	
	aMessageNode selectorParts
		with: aMessageNode keywordsPositions
		do: [ :keyword :position | 
			self
				addStyle: style
				attribute: link
				from: position
				to: position + keyword size - 1 ].
	
	(aMessageNode isCascaded not or: [ aMessageNode isFirstCascaded ])
		ifTrue: [ self visitNode: aMessageNode receiver ].
	
	aMessageNode arguments do: [ :each | self visitNode: each ].
	self styleCloseParenthese: aMessageNode! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
currentOpenedBracketStyleName
	bracketLevel isZero ifTrue: [ ^ #blockStart ].
	^ (#blockStart asString , bracketLevel asString) asSymbol! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
styleOpenParenthese: aMessageNode
	aMessageNode parentheses
		ifNotEmpty: [ 
			aMessageNode parentheses
				do: [ :interval | 
					| pos |
					pos := interval first.
					self addStyle:  self currentOpenedParenthesisStyleName from: pos to: pos.
					parentheseLevel := parentheseLevel + 1 ]]! !

!SHRBTextStyler methodsFor: 'accessing' stamp: ''!
workspace: aWorkspace 
	workspace := aWorkspace.
	isForWorkspace ifNil: [ isForWorkspace := true ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitInstanceVariableNode: aSelfNode
	^ self visitVariableNode: aSelfNode! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitArgumentNodes: aNodeCollection 
	"Sent *once* when visiting method and block nodes"
	^aNodeCollection do: [ :each | self visitArgumentNode: each ]! !

!SHRBTextStyler methodsFor: '*PharoDocComment' stamp: ''!
styleDocComment: aRBComment
	aRBComment pharoDocCommentNodes
		do: [ :pharoDocComment | 
			self styleDocExpression: pharoDocComment expression in: aRBComment.
			self
				addStyle: #binary
				from: aRBComment start + pharoDocComment expression expressionInterval last
				to: aRBComment start + pharoDocComment result expressionInterval first.
			self styleDocExpression: pharoDocComment result in: aRBComment ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitTemporaryNodes: aNodeCollection
	"This is triggered when defining the temporaries between the pipes"

	^ aNodeCollection
		do: [ :each | self visitTemporaryDeclarationNode: each ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitLiteralValueNode: aLiteralValueNode
	| value link |
	value := aLiteralValueNode value.
	
	
	"We can have 3 different kind of links from a literal: 
	- In case it is a symbol representing a class, we want to return a TextClassLink to browse the class or its references
	- In case it is another symbol, we want to return a TextMethodLink to browser the implementors or senders of this selector
	- In case it is another literal value, we return a TextClassLink to browse the class defining this litera."
	link := value isSymbol
		ifTrue: [
			self class environment
				at: value
				ifPresent: [ :aGlobal | TextClassLink className: value ]
				ifAbsent: [ TextMethodLink selector: value ] ]
		ifFalse: [ TextClassLink class: value class ].
	self addStyle: (self literalStyleSymbol: value) attribute: link forNode: aLiteralValueNode! !

!SHRBTextStyler methodsFor: '*PharoDocComment' stamp: ''!
styleDocExpression: aPharoDocExpression in: aRBComment
	| expressionText expressionNode expressionInterval |
	expressionNode := aPharoDocExpression expressionCode.
	expressionText := expressionNode source asText.
	expressionInterval := aPharoDocExpression expressionInterval.
	self class new style: expressionText ast: expressionNode.
	expressionText
		withIndexDo: [ :char :ij | 
			| index |
			index := ij - 1 + aRBComment start.
			charAttr from: expressionInterval first + index to: expressionInterval first + index put: (expressionText attributesAt: ij) ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitTemporaryVariableNode: aNode
	
	^ self visitLocalVariableNode: aNode! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
methodOrBlockTempStyleFor: aTemporaryNode
	^ aTemporaryNode isDefinedByBlock
		ifTrue: [ #blockTempVar ]
		ifFalse: [ #tempVar ]! !

!SHRBTextStyler methodsFor: 'formatting' stamp: ''!
addAttributes: attributes from: start to: stop
	charAttr
		from: (start max: 1)
		to: (stop min: charAttr size)
		put: attributes ! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitCascadeNode: aCascadeNode
	aCascadeNode messages do: [ :each | self visitNode: each ].
	aCascadeNode semicolons do: [ :pos | self addStyle: #cascadeSeparator from: pos to: pos ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitLiteralVariableNode: aNode
	"to be backward compatible, we visit for Gloabls here (there used to be no difference)"

	^ self visitGlobalNode: aNode! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode
	| link |
	self visitMethodComments: aMethodNode comments.
	aMethodNode arguments do: [ :argument | self addStyle: #patternArg forNode: argument ].
	link := TextMethodLink selector: aMethodNode selector.
	aMethodNode selectorParts
		with: aMethodNode keywordsPositions
		do:
			[ :keyword :position | 
			self
				addStyle: #patternKeyword
				attribute: link
				from: position
				to: position + keyword size - 1 ].
	aMethodNode pragmas do: [ :each | self visitNode: each ].
	self visitNode: aMethodNode body! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
styleTempBars: aSequenceNode
	| tempBarAttribute |
	tempBarAttribute := aSequenceNode scope isMethodScope
		ifTrue: [ #methodTempBar ]
		ifFalse: [ #blockTempBar ].
	aSequenceNode leftBar
		ifNotNil: [ :pos | self addStyle: tempBarAttribute from: pos to: pos ].
	aSequenceNode rightBar
		ifNotNil: [ :pos | self addStyle: tempBarAttribute from: pos to: pos ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitPragmaNode: aPragmaNode
	aPragmaNode selectorParts with: aPragmaNode keywordsPositions do: [ :keyword : position|
	self 
		addStyle: #pragmaKeyword
		from: position
		to: position + keyword size ].
	
	aPragmaNode arguments do: [ :each | self visitNode: each ]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
formatIncompleteSelector: aMessageNode
	^ (self class formatIncompleteIdentifiers
		and: [ (Symbol
						selectorThatStartsCaseSensitive: aMessageNode selector asString
						skipping: nil) isNotNil ])
			ifTrue: [ #incompleteKeyword ]
			ifFalse: [ #undefinedKeyword ]! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
style: aText ast: ast
	aText ifEmpty: [ ^ self ].
	text := aText.	
	charAttr := Array new: aText size withAll: (self attributesFor: #default).
	bracketLevel := 0.
	parentheseLevel:=0.
	self visitNode: ast.
	^aText runs: (RunArray newFrom: charAttr)	
! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitPatternBlockNode: aRBPatternBlockNode 
	self 
		visitArgumentNodes: aRBPatternBlockNode arguments;
		visitNode: aRBPatternBlockNode body! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitGlobalVariableNode: aNode

	^ self visitLiteralVariableNode: aNode! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
styleCloseParenthese: aMessageNode
	aMessageNode parentheses
		ifNotEmpty: [ 
			aMessageNode parentheses
				reverseDo: [:interval | 
					| pos |
					pos := interval last.
					parentheseLevel := parentheseLevel - 1.
					self addStyle: self currentClosedParenthesisStyleName from: pos to: pos ]]! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitTemporaryDeclarationNode: aTemporaryDeclarationNode
	| patternTempStyle |
	patternTempStyle := self
		methodOrBlockTempDeclStyleFor: aTemporaryDeclarationNode parent.
	self addStyle: patternTempStyle forNode: aTemporaryDeclarationNode! !

!SHRBTextStyler methodsFor: 'converting' stamp: ''!
addAttributesFrom: attributeRuns satisfying: aTestBlock to: aText

	attributeRuns withStartStopAndValueDo: [:start :stop :attributes | 
		attributes 
			select: aTestBlock 
			thenDo: [ :selectedAttribute| 
				aText
					addAttribute: selectedAttribute
					from: start
					to: stop ]].
		
	^ aText! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
methodOrBlockArgStyleFor: anArgumentNode
	^ anArgumentNode isDefinedByBlock
		ifTrue: [ anArgumentNode isDefinition 
				ifTrue: [ #blockPatternArg ]
				ifFalse: [ #blockArg ] ]
		ifFalse: [ #methodArg ]! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
methodOrBlockTempDeclStyleFor: aSequenceNode
	^ aSequenceNode scope isBlockScope
		ifTrue: [ #blockPatternTempVar ]
		ifFalse: [ #patternTempVar ]! !

!SHRBTextStyler methodsFor: 'private' stamp: ''!
styleCloseBracket: aBlockNode
	bracketLevel := bracketLevel - 1.
	(aBlockNode right isZero or: [ aBlockNode value isNil ]) ifTrue:[ ^self ].
	self addStyle: self currentClosedBracketStyleName from: aBlockNode right to: aBlockNode right! !

!SHRBTextStyler methodsFor: 'formatting' stamp: ''!
addStyle: styleSymbol forNode: anRBNode
	self addAttributes: (self attributesFor: styleSymbol) forNode: anRBNode.! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitSuperNode: aSuperNode
	self addStyle: #super forNode: aSuperNode! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitSelfNode: aSelfNode
	self 
		addStyle: #self
		forNode: aSelfNode! !

!SHRBTextStyler methodsFor: 'formatting' stamp: ''!
addStyle: styleSymbol attribute: additionalAttribute from: start to: end
	self addAttributes: (self attributesFor: styleSymbol), {additionalAttribute} from: start to: end.! !

!SHRBTextStyler methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode
	self 
		addStyle: (self resolveStyleFor: aVariableNode) 
		attributes: (self resolveVariableAttributesFor: aVariableNode)
		forNode: aVariableNode! !

!SHRBTextStyler methodsFor: 'formatting' stamp: ''!
addAttributes: attributes forNode: anRBNode
	self 
		addAttributes: attributes
		from: anRBNode start
		to: anRBNode stop! !

!SHRBTextStyler class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SHRBTextStyler class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SHRBTextStyler class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SHRBTextStyler class methodsFor: '*Spec2-Code' stamp: ''!
initialTextAttributesForPixelHeight: aNumber styleTable: aStyleTable 
	| d |
	
	d := IdentityDictionary new.
	aStyleTable do: [ :each | 
		| textStyle element emphasis font pixelHeight attrArray color textStyleName |
		element := each first.
		color := each at: 2 ifAbsent: [].
		color := color ifNotNil: [Color colorFrom: color].
		emphasis := each at: 3 ifAbsent: [].
		textStyleName := each at: 4 ifAbsent: [].
		pixelHeight := each at: 5 ifAbsent: [aNumber].
		textStyleName ifNil: [pixelHeight := nil].
		textStyle := TextStyle named: textStyleName.
		font := textStyle ifNotNil: [ pixelHeight ifNotNil: [textStyle fontOfSize: pixelHeight]].
		attrArray := self
			attributeArrayForColor: color
			emphasis: emphasis
			font: font.
		attrArray ifNotEmpty: [ d at: element put: attrArray ] ].

	^ d! !

!SHRBTextStyler class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SHRBTextStyler class methodsFor: 'accessing' stamp: ''!
styleTable: anArray 
	styleTable := anArray.
	textAttributesByPixelHeight := nil! !

!SHRBTextStyler class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SHRBTextStyler class methodsFor: 'styles' stamp: ''!
solarizedStyleTable
	"color can be a valid argument to Color class>>colorFrom: , or nil to
	use the editor text color.
	Multiple emphases can be specified using an array e.g. #(bold italic).
	If emphasis is not specified, #normal will be used.
	if pixel height is not specified , then the editor font size will be used.
	
	This style is based on old theme and other old environments.  
	"
	<styleTable: 'Solarized'>
								
			"(symbol color [emphasisSymbolOrArray [textStyleName [pixelHeight]]])" 
 ^ #(
			(default 								('657A81' muchDarker))
			(invalid 									red)
			(excessCode 							red)
			
			(comment 								'586E75')
			(unfinishedComment 					(red muchDarker))
			
			(#'$' 									('268BD2' lighter))
			(character 								('268BD2' lighter))
			(integer 								('2AA198'))
			(number 								('2AA198'))
			(#- 										('2AA198'))
			(symbol 								('268BD2')) 
			(stringSymbol 							('268BD2')) 
			(literalArray 							black)
			(string 									('268BD2'))
												
			(unfinishedString 						red normal)
			(assignment 							nil bold)
			(ansiAssignment 						nil bold)
										
			(literal 									nil italic)
												
			(keyword 								nil)
			(binary 									nil) 
			(unary 									nil)
										
			(#true 									('CB4B16' darker))
			(#false 									('CB4B16' darker))
			(#nil 									('CB4B16' darker))
													
			(#self 									'B58900')
			(#super								'B58900')
			(#thisContext 							'B58900')
			(#return 								'B58900' bold)
												
			(patternArg 							('D33682')) 
			(methodArg 							('D33682'))
			(blockPatternArg 						('D33682'))
			(blockArg 								('D33682'))
			(argument 								('D33682'))
			(blockTempVar 						('D33682'))
			(blockPatternTempVar 					('D33682'))
								
			(instVar 								('D33682'))
			(workspaceVar 							('D33682') bold)
										
			(tempVar 								('D33682'))
			(patternTempVar 						('D33682'))
										
			(poolConstant 							('D33682') bold)
			(classVar 								('D33682') bold)
			(globalVar 								('268BD2' muchDarker) bold)
												
			(undefinedIdentifier 					red)
			(incompleteIdentifier 					'D33682' italic)
			(incompleteKeyword 					nil  italic)
			(incompleteBinary 						nil  italic) 
			(incompleteUnary 						nil  italic)
			(undefinedKeyword 					red)
			(undefinedBinary 						red) 
			(undefinedUnary 						red) 
			(patternKeyword 						'657A81' bold)
			(patternBinary 							'657A81' bold)
			(patternUnary 							'657A81' bold) 
			(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 bold)
			(statementSeparator 					black bold)
			(methodTempBar 						black)
			(blockTempBar 						black)
			(blockArgsBar 							black)
										
			(externalCallType 						black)
			(externalCallTypePointerIndicator 		black)
			(primitiveOrExternalCallStart 			black bold)
			(primitiveOrExternalCallEnd 			black bold)
			(primitive 								(cyan muchDarker))
			(pragmaKeyword 						(cyan muchDarker))
			(pragmaUnary 							(cyan muchDarker))
			(pragmaBinary 							(cyan muchDarker)) 
			(externalFunctionCallingConvention 	(cyan muchDarker) bold)
			(module 								(cyan muchDarker) bold))! !

!SHRBTextStyler class methodsFor: 'styles' stamp: ''!
settingsOn: aBuilder 
	<systemsettings>
	
	(aBuilder setting: #formatIncompleteIdentifiers) 
		target: self;
		default: true;
		order: 1;
		label: 'Format Incomplete Identifiers';
		parentName: #'Syntax Highlighting';
		description: 'If the code highlighter tryies to format incomplete identifiers and selectors or not. This is not recommended for big images, as it traverse all the image to get the information'
! !

!SHRBTextStyler class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SHRBTextStyler class methodsFor: '*Spec2-Code' stamp: ''!
newAttributesForStyleTable: aTable
	
	^ self 
		initialTextAttributesForPixelHeight: TextStyle defaultFont pixelSize 
		styleTable: aTable! !

!SHRBTextStyler class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SHRBTextStyler class methodsFor: 'styles' stamp: ''!
formatIncompleteIdentifiers: aValue

	formatIncompleteIdentifiers := aValue! !

!SHRBTextStyler class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SHRBTextStyler class methodsFor: 'class initialization' stamp: ''!
initialize

	styleTable := nil.
	textAttributesByPixelHeight := nil! !

!SHRBTextStyler class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SHRBTextStyler class methodsFor: 'styles' stamp: ''!
tangoStyleTable
	"color can be a valid argument to Color class>>colorFrom: , or nil to
	use the editor text color.
	Multiple emphases can be specified using an array e.g. #(bold italic).
	If emphasis is not specified, #normal will be used.
	if pixel height is not specified , then the editor font size will be used.
	
	This is a syntax coloring scheme based on the tango desktop icon scheme:
	http://tango.freedesktop.org/Tango_Icon_Theme_Guidelines
	"
	<styleTable: 'Tango'>
								
			"(symbol color [emphasisSymbolOrArray [textStyleName [pixelHeight]]])" 
 ^ #(
			(default 								black)
			(invalid 									red)
			(excessCode 							red)
			
			(comment 								'888a85')
			(unfinishedComment 					(red muchDarker))
			
			(#'$' 									'ce5c00')
			(character 								'ce5c00')
			(integer 								'8f5902')
			(number 								'8f5902')
			(#- 										'8f5902')
			(symbol 								'c4a000') 
			(stringSymbol 							'c4a000') 
			(literalArray 							black)
			(string 									'ce5c00')
												
			(unfinishedString 						red normal)
			(assignment 							nil)
			(ansiAssignment 						nil)
										
			(literal 									'8F5902')
												
			(keyword 								(black))
			(binary 									(black)) 
			(unary 									(black))
										
			(#true 									'8F5902')
			(#false 									'8F5902')
			(#nil 									'8F5902')
													
			(#self 									'4d9a06')
			(#super 								'4d9a06')
			(#thisContext 							'4d9a06')
			(#return 								black bold)
												
			(patternArg 							'2e3426' italic) 
			(methodArg 							'555753' italic)
			(blockPatternArg 						'888a85' bold)
			(blockArg 								'555753' italic)
			(argument 								'555753' italic)
			(blockTempVar 						'555753' italic)
			(blockPatternTempVar 					'888a85' italic)
								
			(instVar 								'204a87')
			(workspaceVar 							'204a87')
										
			(tempVar 								'555753' italic)
			(patternTempVar 						'888a85' italic)
										
			(poolConstant 							'ad7fa8' bold)
			(classVar 								'ad7fa8' bold)
			(globalVar 								'5c3566' bold)
												
			
			(incompleteIdentifier 					blue italic)
			(incompleteKeyword 					blue italic)
			(incompleteBinary 						blue italic) 
			(incompleteUnary 						blue italic)
									
			(undefinedIdentifier 					red)						
			(undefinedKeyword 					red)
			(undefinedBinary 						red) 
			(undefinedUnary 						red) 
			(patternKeyword 						nil bold)
			(patternBinary 							nil bold)
			(patternUnary 							nil bold) 
			(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)
			(methodTempBar 						black)
			(blockTempBar 						black)
			(blockArgsBar 							black)
										
			(externalCallType 						black)
			(externalCallTypePointerIndicator 		black)
			(primitiveOrExternalCallStart 			black bold)
			(primitiveOrExternalCallEnd 			black bold)
			(primitive 								(green muchDarker))
			(pragmaKeyword 						(green muchDarker))
			(pragmaUnary 							(green muchDarker))
			(pragmaBinary 							(green muchDarker)) 
			(externalFunctionCallingConvention 	(green muchDarker) bold)
			(module 								(green muchDarker) bold))! !

!SHRBTextStyler class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SHRBTextStyler class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SHRBTextStyler class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SHRBTextStyler class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SHRBTextStyler class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SHRBTextStyler class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SHRBTextStyler class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SHRBTextStyler class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SHRBTextStyler class methodsFor: 'styles' stamp: ''!
formatIncompleteIdentifiers

	^ formatIncompleteIdentifiers ifNil: [ formatIncompleteIdentifiers := true ]! !

!SHRBTextStyler class methodsFor: 'attributes' stamp: ''!
textAttributesByPixelHeight
	^ textAttributesByPixelHeight
		ifNil: [textAttributesByPixelHeight := Dictionary new]! !

!SHRBTextStyler class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SHRBTextStyler class methodsFor: 'styles' stamp: ''!
darkStyleTable
	"color can be a valid argument to Color class>>colorFrom: , or nil to
	use the editor text color.
	Multiple emphases can be specified using an array e.g. #(bold italic).
	If emphasis is not specified, #normal will be used.
	if pixel height is not specified , then the editor font size will be used.
	
	This style is inspired on darkula theme from eclipse: http://eclipsecolorthemes.org/?view=theme&id=15515.  
	"
	<styleTable: 'Dark'>

			"(symbol color [emphasisSymbolOrArray [textStyleName [pixelHeight]]])" 
 ^ #(
			(default 								white)
			(invalid 								'FF8A80')
			(excessCode 							'FF8A80')
			
			(comment 								'7D8C93')
			(unfinishedComment 				'FF8A80')
			
			(#'$' 									('E38C1E' lighter))
			(character 							('E38C1E' lighter))
			(integer 								('FFE54B'))
			(number 								('FFE54B'))
			(#- 									('FFE54B'))
			(symbol 								('E38C1E')) 
			(stringSymbol 						('E38C1E')) 
			(literalArray 						white)
			(string 								('E38C1E'))
												
			(unfinishedString 					'FF8A80' normal)
			(assignment 							nil bold)
			(ansiAssignment 					nil bold)
										
			(literal 								nil italic)
												
			(keyword 								white)
			(binary 								white) 
			(unary 								white)
										
			(#true 								('00CC6E' darker))
			(#false 								('00CC6E' darker))
			(#nil 									('00CC6E' darker))
													
			(#self 								'00CC6E')
			(#super								'00CC6E')
			(#thisContext 						'00CC6E')
			(#return 								'00CC6E' bold)
												
			(patternArg 							'A7E2ED') 
			(methodArg 							'A7E2ED')
			(blockPatternArg 					'A7E2ED' italic)
			(blockArg 							'A7E2ED' italic)
			(argument 							'A7E2ED')
			(blockTempVar 						'A7E2ED')
			(blockPatternTempVar 				'A7E2ED')
								
			(instVar 								'A7E2ED')
			(workspaceVar 						'A7E2ED' bold)
										
			(tempVar 								'A7E2ED')
			(patternTempVar 					'A7E2ED')
										
			(poolConstant 						'A7E2ED' bold)
			(classVar 							'A7E2ED' bold)
			(globalVar 							white bold)
												
		
			(incompleteIdentifier 			'E8E2B7' italic)
			(incompleteKeyword 				'E8E2B7' italic)
			(incompleteBinary 					'E8E2B7' italic) 
			(incompleteUnary 					'E8E2B7' italic)
				
			(undefinedIdentifier 				'FF8A80')						
			(undefinedKeyword 					'FF8A80')
			(undefinedBinary 					'FF8A80') 
			(undefinedUnary 					'FF8A80') 
			
			(patternKeyword 					nil bold)
			(patternBinary 						nil bold)
			(patternUnary 						nil bold) 
			(blockArgColon 						white)
			(leftParenthesis 					white)
			(rightParenthesis 					white)
			(leftParenthesis1 					(green muchLighter))
			(rightParenthesis1 				(green muchLighter))
			(leftParenthesis2 					(magenta muchLighter))
			(rightParenthesis2 				(magenta muchLighter))
			(leftParenthesis3 					('FF8A80' muchLighter))
			(rightParenthesis3 				('FF8A80' muchLighter))
			(leftParenthesis4 					(green lighter))
			(rightParenthesis4 				(green lighter))
			(leftParenthesis5 					(orange lighter))
			(rightParenthesis5 				(orange lighter))
			(leftParenthesis6 					(magenta lighter))
			(rightParenthesis6 				(magenta lighter))
			(leftParenthesis7 					blue)
			(rightParenthesis7 				blue)
			(blockStart 							white)
			(blockEnd 							white)
			(blockStart1 						(green muchLighter))
			(blockEnd1 							(green muchLighter))
			(blockStart2 						(magenta muchLighter))
			(blockEnd2 							(magenta muchLighter))
			(blockStart3 						(red muchLighter))
			(blockEnd3 							(red muchLighter))
			(blockStart4 						(green lighter))
			(blockEnd4 							(green lighter))
			(blockStart5 						(orange lighter))
			(blockEnd5 							(orange lighter))
			(blockStart6 						(magenta lighter))
			(blockEnd6 							(magenta lighter))
			(blockStart7 						blue)
			(blockEnd7 							blue) 
			(arrayStart 							white)
			(arrayEnd 							white)
			(arrayStart1 						white)
			(arrayEnd1 							white)
			(leftBrace 							white)
			(rightBrace 							white)
			(cascadeSeparator 					white bold)
			(statementSeparator 				white bold)
			(methodTempBar 						white)
			(blockTempBar 						white)
			(blockArgsBar 						white)
										
			(externalCallType 								white)
			(externalCallTypePointerIndicator 		white)
			(primitiveOrExternalCallStart 				white bold)
			(primitiveOrExternalCallEnd 				white bold)
			(primitive 										'B4DD6E')
			(pragmaKeyword 									'B4DD6E')
			(pragmaUnary 									'B4DD6E')
			(pragmaBinary 									'B4DD6E') 
			(externalFunctionCallingConvention 		'B4DD6E' bold)
			(module 											'B4DD6E' bold))! !

!SHRBTextStyler class methodsFor: 'attributes' stamp: ''!
initialTextAttributesForPixelHeight: aNumber 
	| d |
	d := IdentityDictionary new.
	self styleTable
		do: [:each | 
			| textStyle element emphasis font pixelHeight attrArray color textStyleName |
			element := each first.
			color := each
						at: 2
						ifAbsent: [].
			color := color
						ifNotNil: [Color colorFrom: color].
			emphasis := each
						at: 3
						ifAbsent: [].
			textStyleName := each
						at: 4
						ifAbsent: [].
			pixelHeight := each
						at: 5
						ifAbsent: [aNumber].
			textStyleName
				ifNil: [pixelHeight := nil].
			textStyle := TextStyle named: textStyleName.
			font := textStyle
						ifNotNil: [pixelHeight
								ifNotNil: [textStyle fontOfSize: pixelHeight]].
			attrArray := self
						attributeArrayForColor: color
						emphasis: emphasis
						font: font.
			attrArray notEmpty
				ifTrue: [d at: element put: attrArray]].
	^ d! !

!SHRBTextStyler class methodsFor: 'styles' stamp: ''!
vintageStyleTable
	"color can be a valid argument to Color class>>colorFrom: , or nil to
	use the editor text color.
	Multiple emphases can be specified using an array e.g. #(bold italic).
	If emphasis is not specified, #normal will be used.
	if pixel height is not specified , then the editor font size will be used.
	
	This style is based on old theme and other old environments.  
	"
	<styleTable: 'Vintage'>
								
			"(symbol color [emphasisSymbolOrArray [textStyleName [pixelHeight]]])" 
 ^ #(
			(default 								black)
			(invalid 									red)
			(excessCode 							red)
			
			(comment 								'006400')
			(unfinishedComment 					(red muchDarker))
			
			(#'$' 									('801f91' lighter))
			(character 								('801f91' lighter))
			(integer 								('801f91'))
			(number 								('801f91'))
			(#- 										('801f91'))
			(symbol 								('801f91')) 
			(stringSymbol 							('801f91')) 
			(literalArray 							black)
			(string 									('801f91'))
												
			(unfinishedString 						red normal)
			(assignment 							nil bold)
			(ansiAssignment 						nil bold)
										
			(literal 									nil italic)
												
			(keyword 								black)
			(binary 									black) 
			(unary 									black)
										
			(#true 									('A31515' darker))
			(#false 									('A31515' darker))
			(#nil 									('A31515' darker))
													
			(#self 									'A31515')
			(#super								'A31515')
			(#thisContext 							'A31515')
			(#return 								'A31515' bold)
												
			(patternArg 							(blue muchDarker)) 
			(methodArg 							(blue muchDarker))
			(blockPatternArg 						(blue muchDarker))
			(blockArg 								(blue muchDarker))
			(argument 								(blue muchDarker))
			(blockTempVar 						(blue muchDarker))
			(blockPatternTempVar 					(blue muchDarker))
								
			(instVar 								(blue muchDarker))
			(workspaceVar 							(blue muchDarker) bold)
										
			(tempVar 								(blue muchDarker))
			(patternTempVar 						(blue muchDarker))
										
			(poolConstant 							(blue muchDarker) bold)
			(classVar 								(blue muchDarker) bold)
			(globalVar 								black bold)
												
		
			(incompleteIdentifier 					blue italic)
			(incompleteKeyword 					blue italic)
			(incompleteBinary 						blue italic) 
			(incompleteUnary 						blue italic)
				
			(undefinedIdentifier 					red)						
			(undefinedKeyword 					red)
			(undefinedBinary 						red) 
			(undefinedUnary 						red) 
			
			(patternKeyword 						nil bold)
			(patternBinary 							nil bold)
			(patternUnary 							nil bold) 
			(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 bold)
			(statementSeparator 					black bold)
			(methodTempBar 						black)
			(blockTempBar 						black)
			(blockArgsBar 							black)
										
			(externalCallType 						black)
			(externalCallTypePointerIndicator 		black)
			(primitiveOrExternalCallStart 			black bold)
			(primitiveOrExternalCallEnd 			black bold)
			(primitive 								(cyan muchDarker))
			(pragmaKeyword 						(cyan muchDarker))
			(pragmaUnary 							(cyan muchDarker))
			(pragmaBinary 							(cyan muchDarker)) 
			(externalFunctionCallingConvention 	(cyan muchDarker) bold)
			(module 								(cyan muchDarker) bold))! !

!SHRBTextStyler class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SHRBTextStyler class methodsFor: 'styles' stamp: ''!
defaultStyleTable
	"color can be a valid argument to Color class>>colorFrom: , or nil to
	use the editor text color.
	Multiple emphases can be specified using an array e.g. #(bold italic).
	If emphasis is not specified, #normal will be used.
	if pixel height is not specified , then the editor font size will be used.
	"
								
 	^ self blueStyleTable! !

!SHRBTextStyler class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SHRBTextStyler class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SHRBTextStyler class methodsFor: 'attributes' stamp: ''!
attributesFor: aSymbol pixelHeight: aNumber 
	^ (self textAttributesByPixelHeight
		at: aNumber
		ifAbsentPut: [self initialTextAttributesForPixelHeight: aNumber])
		at: aSymbol
		ifAbsent: [#()]! !

!SHRBTextStyler class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SHRBTextStyler class methodsFor: '*Spec2-Code' stamp: ''!
styleTableNamed: aString
		
	^ (Pragma allNamed: #styleTable: in: SHRBTextStyler class)
		detect: [ :each | (each argumentAt: 1) = aString ]
		ifFound: [ :each | self perform: each methodSelector ]
		ifNone: [ nil ]! !

!SHRBTextStyler class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SHRBTextStyler class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SHRBTextStyler class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SHRBTextStyler class methodsFor: 'accessing' stamp: ''!
styleTable
	^ styleTable
		ifNil: [styleTable := self defaultStyleTable]! !

!SHRBTextStyler class methodsFor: 'styles' stamp: ''!
blueStyleTable
	"color can be a valid argument to Color class>>colorFrom: , or nil to
	use the editor text color.
	Multiple emphases can be specified using an array e.g. #(bold italic).
	If emphasis is not specified, #normal will be used.
	if pixel height is not specified , then the editor font size will be used.
	"
	<styleTable: 'Blue'>
								
			"(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))
										
			(#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))
			(blockTempVar 						(blue muchDarker))
			(blockPatternTempVar 					(blue muchDarker))
			(instVar 								(blue muchDarker))
			(workspaceVar 							(blue muchDarker))
		
			(tempVar 								(blue muchDarker))
			(patternTempVar 						(blue muchDarker))
			(poolConstant 							(blue muchDarker))
			(classVar 								(blue muchDarker))
			(globalVar 								(blue muchDarker))
												
			(incompleteIdentifier 					blue italic)
			(incompleteKeyword 					nil  italic)
			(incompleteBinary 						nil  italic) 
			(incompleteUnary 						nil  italic)					
				
			(undefinedIdentifier 					red)						
			(undefinedKeyword 					red)
			(undefinedBinary 						red) 
			(undefinedUnary 						red) 
	
			(patternKeyword 						nil bold)
			(patternBinary 							nil bold)
			(patternUnary 							nil bold) 
			(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)
			(methodTempBar 						(black))
			(blockTempBar 						(black))
			(blockArgsBar 							(black))
										
			(externalCallType 						black)
			(externalCallTypePointerIndicator 		black)
			(primitiveOrExternalCallStart 			black bold)
			(primitiveOrExternalCallEnd 			black bold)
			(primitive 								(green muchDarker))
			(pragmaKeyword 						(green muchDarker))
			(pragmaUnary 							(green muchDarker))
			(pragmaBinary 							(green muchDarker)) 
			(externalFunctionCallingConvention 	(green muchDarker) bold)
			(module 								(green muchDarker) bold))! !

!SHRBTextStyler class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SHRBTextStyler class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SHRBTextStyler class methodsFor: 'attributes' stamp: ''!
attributeArrayForColor: aColorOrNil emphasis: anEmphasisSymbolOrArrayorNil font: aTextStyleOrFontOrNil 

	| emphArray answer |	
	answer := Array new.
	aColorOrNil ifNotNil: [ answer := answer , {TextColor color: aColorOrNil}].
	
	anEmphasisSymbolOrArrayorNil
		ifNotNil: [
			emphArray := anEmphasisSymbolOrArrayorNil isSymbol
						ifTrue: [{anEmphasisSymbolOrArrayorNil}]
						ifFalse: [anEmphasisSymbolOrArrayorNil].
			emphArray do: [:each | 
				each ~= #normal
					ifTrue: [answer := answer , {TextEmphasis perform: each}]]].
	
	aTextStyleOrFontOrNil
		ifNotNil: [ answer := answer , {TextFontReference toFont: aTextStyleOrFontOrNil}].
		
	^ answer! !

!SHRBTextStyler class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SHRBTextStyler class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SHRBTextStyler class methodsFor: '*Spec2-Code' stamp: ''!
newAttributesForStyleTableNamed: aString
	| table |
	
	table := self styleTableNamed: aString.
	^ self newAttributesForStyleTable: (table ifNil: [ self styleTable ])! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testArgumentStylingExpressionWithComment2
	
	| aText index1 index2 attribute |

	aText := '"comment"3.' asText.
	self styleExpression: aText.
	
	index1 := 5. "inside comment"
	attribute := aText attributesAt: index1.
	self assert: attribute equals: (SHRBTextStyler  attributesFor: #comment pixelHeight: 10).
	
	index2 := 10. "outside the 3"
	attribute := (aText attributesAt: index2) first.
	self assert: attribute equals: (SHRBTextStyler  attributesFor: #integer pixelHeight: 10) first! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testSettingFalseTheIncompleteMessageShouldNotFormatIt
	
	| aText index attributes ast node |

	SHRBTextStyler formatIncompleteIdentifiers: false.

	aText := 'm1
		^ self prin' asText.

	index := aText string indexOfSubCollection: 'prin'.
	
	ast := self style: aText.
	
	attributes := aText attributesAt: index.

	node := ast allChildren detect: [:e | e isMessage ].
	
	self assertCollection: attributes hasSameElements: { 
		TextMethodLink sourceNode: node. 
		TextColor red }.! !

!SHRBTextStylerTest methodsFor: 'running' stamp: ''!
tearDown 

	SHRBTextStyler formatIncompleteIdentifiers: oldSetting.
	super tearDown.
	! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testClassAfterMessageToASymbolLowercaseShouldBeColored
	
	| aText index attributes |

	SHRBTextStyler formatIncompleteIdentifiers: true.

	aText := 'm1
		#world traceCr.
		Object new.' asText.

	index := aText string indexOfSubCollection: 'Object'.
	
	self style: aText.
	
	attributes := aText attributesAt: index.

	self assertCollection: attributes hasSameElements: { 
		TextClassLink className: #Object. 
		TextColor color: SHPreferences globalVarStyle color }! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testSettingTrueTheIncompleteIdentifiersShouldFormatIt
	
	| aText index attributes |

	SHRBTextStyler formatIncompleteIdentifiers: true.

	aText := 'm1
		^ se' asText.

	index := aText string indexOfSubCollection: 'se'.
	
	self style: aText.
	
	attributes := aText attributesAt: index.
	
	self assertCollection: attributes hasSameElements: { TextColor blue. TextEmphasis italic. TextVariableLink variableName: 'se' }! !

!SHRBTextStylerTest methodsFor: 'private - utilities' stamp: ''!
styleExpression: aText

	| ast |
	
	ast := self class compiler
		source: aText asString;
		noPattern: true ;
		options:  #(+ optionParseErrors + optionSkipSemanticWarnings);
		requestor: nil;
		parse.				
	styler style: aText ast: ast.
	
	^ ast! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testArgumentStylingMethod
	
	| aText index1 index2 attribute |

	aText := 'm1: arg self do: [:each | arg ]' asText.
	self style: aText.
	
	index1 := 5. "first each"
	attribute := aText attributesAt: index1.
	self assert: attribute equals: (SHRBTextStyler  attributesFor: #methodArg pixelHeight: 10).
	
	index2 := 27. "second each"
	attribute := aText attributesAt: index2.
	self assert: attribute equals: (SHRBTextStyler  attributesFor: #tempVar pixelHeight: 10)! !

!SHRBTextStylerTest methodsFor: 'private - utilities' stamp: ''!
style: aText

	| ast |
	
	ast := self class compiler
		source: aText asString;
		noPattern: false ;
		options:  #(+ optionParseErrors + optionSkipSemanticWarnings);
		requestor: nil;
		parse.				
	styler style: aText ast: ast.
	
	^ ast! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testSettingFalseTheIncompleteVariableShouldFormatUndefinedIdentifier
	
	| aText ast |

	SHRBTextStyler formatIncompleteIdentifiers: false.
	aText := 'm1
		^ sel' asText.
	
	ast := self style: aText.
	self assert: (styler resolveStyleFor: ast variableNodes first) equals: #undefinedIdentifier! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testArgumentStylingBlock
	
	| aText index1 index2 attribute |

	aText := 'm1 self do: [:each | each ]' asText.
	self style: aText.
	
	index1 := 15. "fixrst each"
	attribute := aText attributesAt: index1.
	self assert: attribute equals: (SHRBTextStyler  attributesFor: #blockPatternArg pixelHeight: 10).
	
	index2 := 22. "second each"
	attribute := aText attributesAt: index2.
	self assert: attribute equals: (SHRBTextStyler  attributesFor: #blockArg pixelHeight: 10)! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testClassAfterMessageToASymbolUppercaseShouldBeColored
	
	| aText index attributes |

	SHRBTextStyler formatIncompleteIdentifiers: true.

	aText := 'm1
		#World traceCr.
		Object new.' asText.

	index := aText string indexOfSubCollection: 'Object'.
	
	self style: aText.
	
	attributes := aText attributesAt: index.

	self assertCollection: attributes hasSameElements: { 
		TextClassLink className: #Object. 
		TextColor color: SHPreferences globalVarStyle color}! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testSettingTrueTheIncompleteMessageShouldFormatIt
	
	| aText index attributes ast node |

	SHRBTextStyler formatIncompleteIdentifiers: true.

	aText := 'm1
		^ self prin' asText.

	index := aText string indexOfSubCollection: 'prin'.
	
	ast := self style: aText.
	
	attributes := aText attributesAt: index.

	node := ast allChildren detect: [:e | e isMessage ].
	
	self assertCollection: attributes hasSameElements: { 
		TextMethodLink sourceNode: node. 
		TextEmphasis italic }.! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testArgumentStylingExpressionWithComment
	
	| aText index1 index2 attribute |

	aText := '"comment"3+4.' asText.
	self styleExpression: aText.
	
	index1 := 5. "inside comment"
	attribute := aText attributesAt: index1.
	self assert: attribute equals: (SHRBTextStyler  attributesFor: #comment pixelHeight: 10).
	
	index2 := 11. "outside the +"
	attribute := (aText attributesAt: index2) first.
	self assert: attribute equals: (SHRBTextStyler  attributesFor: #unary pixelHeight: 10) first! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testSettingFalseTheIncompleteIdentifiersShouldNotFormatIt
	
	| aText index attributes |

	SHRBTextStyler formatIncompleteIdentifiers: false.

	aText := 'm1
		^ se' asText.

	index := aText string indexOfSubCollection: 'se'.
	
	self style: aText.
	
	attributes := aText attributesAt: index.
	
	self assertCollection: attributes hasSameElements: { TextColor red. TextVariableLink variableName: 'se' }! !

!SHRBTextStylerTest methodsFor: 'tests' stamp: ''!
testSettingTrueTheIncompleteVariableShouldFormatUndefinedIdentifier
	
	| aText ast |

	SHRBTextStyler formatIncompleteIdentifiers: true.
	aText := 'm1
		^ sel' asText.
	
	ast := self style: aText.
	"here the identifier is incomplete"
	self assert: (styler resolveStyleFor: ast variableNodes first) equals: #incompleteIdentifier.
	
	aText := 'm1
		^ asdfasf' asText.
	
	ast := self style: aText.
	"But for a name that does not exist at all, it is #undefinedIdentifier"
	self assert: (styler resolveStyleFor: ast variableNodes first) equals: #undefinedIdentifier! !

!SHRBTextStylerTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	styler := SHRBTextStyler new.
	oldSetting := SHRBTextStyler instVarNamed: #formatIncompleteIdentifiers.! !

!SHStyleElement commentStamp: ''!
A Shout style element!
!SHStyleElement methodsFor: 'accessing' stamp: ''!
basicColor: aColor tokens: someTokens emphasis: anEmphasis

	color := aColor.
	tokens := someTokens.
	emphasis := anEmphasis.! !

!SHStyleElement methodsFor: 'accessing' stamp: ''!
color: anObject 
	color := anObject.
	SHPreferences applyStyle! !

!SHStyleElement methodsFor: 'accessing' stamp: ''!
tokens: anObject 
	tokens := anObject! !

!SHStyleElement methodsFor: 'comparing' stamp: ''!
= otherObject

	^ self species = otherObject species
		and: [ tokens = otherObject tokens
				and:
					[ self color = otherObject color and: [ self emphasis = otherObject emphasis ] ] ]! !

!SHStyleElement methodsFor: 'comparing' stamp: ''!
hash 

	^ tokens hash! !

!SHStyleElement methodsFor: 'accessing' stamp: ''!
emphasis
	| style |
	^ emphasis
		ifNil: [style := SHPreferences customStyleTable
						detect: [:e | self tokens first = e first].
			style size > 2
				ifTrue: [emphasis := style third.
					emphasis isSymbol
						ifFalse: [emphasis := ' ' join: emphasis].
					emphasis]
				ifFalse: [#normal]]! !

!SHStyleElement methodsFor: 'accessing' stamp: ''!
emphasis: anObject 
	emphasis := anObject.
	SHPreferences applyStyle! !

!SHStyleElement methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	color
		ifNotNil: [ aStream
				nextPutAll: ' color: ';
				print: color 
			].
	emphasis
		ifNotNil: [ aStream
				nextPutAll: ' emphasis: ';
				print: emphasis 
			].
	tokens
		ifNotNil: [ aStream
				nextPutAll: ' tokens: ';
				print: tokens 
			]! !

!SHStyleElement methodsFor: 'accessing' stamp: ''!
tokens
	^ tokens! !

!SHStyleElement methodsFor: 'styling' stamp: ''!
emphasisAsArray
	^ self emphasis = 'bold italic'
		ifTrue: [#(#bold #italic )]
		ifFalse: [self emphasis]! !

!SHStyleElement methodsFor: 'accessing' stamp: ''!
color
	^ color
		ifNil: [color := Color colorFrom: (SHPreferences customStyleTable
							detect: [:e | self tokens first = e first]) second]! !

!SHStyleElement methodsFor: 'styling' stamp: ''!
styleForTable
	^ self tokens
		collect: [:token | 
			| style |
			style := OrderedCollection with: token.
			style add: self color.
			self emphasis
				ifNotNil: [style add: self emphasisAsArray].
			style asArray]! !

!SHStyleElement class methodsFor: 'instance creation' stamp: ''!
withTokens: aCollection 
	^ self new tokens: aCollection;
		 yourself! !

!SHStyleElement class methodsFor: 'instance creation api' stamp: ''!
color: aColor tokens: tokens 

	^ self new
		basicColor: aColor tokens: tokens emphasis: nil;
		yourself! !

!SHStyleElement class methodsFor: 'instanceCreation' stamp: ''!
emphasis: anEmphasis tokens: someTokens 
	
	^ self new 
		basicColor: nil tokens: someTokens emphasis: anEmphasis;
		yourself! !

!SHStyleElement class methodsFor: 'settings' stamp: ''!
settingInputWidgetForNode: aSettingNode 
	| theme |
	theme := UITheme builder.
	^ theme newRow: {theme
			newColorChooserFor: aSettingNode realValue
			getColor: #color
			setColor: #color:
			help: 'Choose token color'. (theme
			newDropListFor: aSettingNode realValue
			list: #(#bold #italic #normal 'bold italic' )
			getSelected: #emphasis
			setSelected: #emphasis:
			getEnabled: nil
			useIndex: false
			help: 'Choose token emphasis') hResizing: #rigid;
			 width: 100}! !

!SHStyleElement class methodsFor: 'instance creation' stamp: ''!
tokens: aCollection 
	
	^ self new
		basicColor: nil tokens: aCollection  emphasis: nil;
		yourself! !

!SHStyleElementTest commentStamp: ''!
SUnit tests for class SHStyleElement!
!SHStyleElementTest methodsFor: 'tests' stamp: ''!
testStyleForTable
	| table |
	table := element styleForTable.
	self assert: table size equals: 4.
	self assert: (table collect: [:each | each first]) equals: element tokens! !

!SHStyleElementTest methodsFor: 'tests' stamp: ''!
testPrintOn
	self
		assert: element printString
		equals: 'a SHStyleElement tokens: #(#self #super #true #false)'! !

!SHStyleElementTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	element := SHStyleElement withTokens: #(#self #super #true #false).! !

!SHTextStyler commentStamp: ''!
I am an Abstract class.
Subclasses of me can create formatted, coloured, and styled copies of Text that is given to them.
They may perform their styling asynchronously, in a background process which I create and manage.

My public interface is...

	view: aViewOrMorph - set the view that will receive notifications when styling has completed.
	
	format: aText - modifies aText's string

	style: aText - modifies the TextAttributes of aText, but does not change the string, then sends #stylerStyled: to the view.

	styleInBackgroundProcess: aText - performs style: in a background process, then sends #stylerStylednBackground: to the view.

	styledTextFor: aText - answers a formatted and styled copy of aText

	unstyledTextFrom: aText - answers a copy of aText with all TextAttributes removed

Subclasses of me should re-implement...

	privateFormat: aText - answer a formatted version of aText; the String may be changed
	privateStyle: aText - modify the TextAttributes of aText; but do not change the String
	

	
	
!
!SHTextStyler methodsFor: 'private' stamp: ''!
privateStyle: aText 
	self shouldBeImplemented! !

!SHTextStyler methodsFor: 'styling' stamp: ''!
styleInBackgroundProcess: aText
	aText ifEmpty: [ ^ self ].
	self terminateBackgroundStylingProcess.
	stylingEnabled ifFalse: [ ^ self ].
	text := aText copy.
	self monitor critical: [
		backgroundProcess := [ 
			self privateStyle: text.
			view ifNotNil: [
				view stylerStyledInBackground: text ] ] forkAt: Processor userBackgroundPriority ]! !

!SHTextStyler methodsFor: 'initialization' stamp: ''!
initialize
	stylingEnabled := true! !

!SHTextStyler methodsFor: 'private' stamp: ''!
monitor

	^ monitor ifNil: [ monitor := Monitor new ]! !

!SHTextStyler methodsFor: 'accessing' stamp: ''!
view: aViewOrMorph 
	view := aViewOrMorph! !

!SHTextStyler methodsFor: 'private' stamp: ''!
terminateBackgroundStylingProcess
	self monitor critical: [
		backgroundProcess ifNotNil: [
			backgroundProcess terminate.
			backgroundProcess := nil ] ]! !

!SHTextStyler methodsFor: 'styling' stamp: ''!
style: aText
	aText ifEmpty: [ ^ self ].
	self terminateBackgroundStylingProcess.
	stylingEnabled
		ifFalse: [ ^ self ].
	text := aText copy.
	self privateStyle: text.
	view ifNotNil: [ :view2 | view2 stylerStyled: text ]! !

!SHTextStyler methodsFor: 'private' stamp: ''!
stylingEnabled: aBoolean
	stylingEnabled := aBoolean! !

!SHTextStyler methodsFor: 'private' stamp: ''!
stylingEnabled
	^ stylingEnabled! !

!SHTextStyler methodsFor: 'styling' stamp: ''!
unstyledTextFrom: aText 
	^ Text fromString: aText string! !

!SHTextStyler methodsFor: 'styling' stamp: ''!
styledTextFor: aText 
	^self privateStyle: aText! !

!SHTextStyler methodsFor: 'formatting' stamp: ''!
format: aText 
	self terminateBackgroundStylingProcess.
	^ aText! !

!SMTPClient commentStamp: ''!
This class implements the SMTP (mail sending) protocol specified in RFC 821.

HELO <SP> <domain> <CRLF>

MAIL <SP> FROM:<reverse-path> <CRLF>

RCPT <SP> TO:<forward-path> <CRLF>

DATA <CRLF>

RSET <CRLF>

SEND <SP> FROM:<reverse-path> <CRLF>

SOML <SP> FROM:<reverse-path> <CRLF>

SAML <SP> FROM:<reverse-path> <CRLF>

VRFY <SP> <string> <CRLF>

EXPN <SP> <string> <CRLF>

HELP [<SP> <string>] <CRLF>

NOOP <CRLF>

QUIT <CRLF>

TURN <CRLF>

!
!SMTPClient methodsFor: '*Network-Mail' stamp: ''!
mailFrom: fromAddress
	" MAIL <SP> FROM:<reverse-path> <CRLF>"

	| address |
	address := (MailAddressParser addressesIn: fromAddress) first.

	self sendCommand: 'MAIL FROM: <', address, '>'.
	self checkResponse.! !

!SMTPClient methodsFor: 'public protocol' stamp: ''!
localHostName: aString
	"The local host name for purposes of identifying the the server.
 	If nil, NetNameResolver localHostName will be used."
 
 	^self connectionInfo at: #localHostName put: aString! !

!SMTPClient methodsFor: 'private - protocol' stamp: ''!
login
	self initiateSession. "send EHLO first"
	self user ifNil: [^self].
	self sendCommand: 'AUTH LOGIN ' , (self encodeString: self user).
	[self checkResponse]
		on: TelnetProtocolError
		do: [ :ex | ex isCommandUnrecognized ifTrue: [^ self] ifFalse: [ex pass]].
	self sendCommand: (self encodeString: self password).
	self checkResponse! !

!SMTPClient methodsFor: 'private - protocol' stamp: ''!
data: messageData
	"send the data of a message"
	"DATA <CRLF>"

	

	"inform the server we are sending the message data"
	self sendCommand: 'DATA'.
	self checkResponse.

	"process the data one line at a time"
	messageData linesDo:  [ :messageLine | | cookedLine |
		cookedLine := messageLine.
		(cookedLine beginsWith: '.') ifTrue: [ 
			"lines beginning with a dot must have the dot doubled"
			cookedLine := '.', cookedLine ].
		self sendCommand: cookedLine ].

	"inform the server the entire message text has arrived"
	self sendCommand: '.'.
	self checkResponse.! !

!SMTPClient methodsFor: 'public protocol' stamp: ''!
localHostName
	"The local host name for purposes of identifying the the server.
 	If nil, NetNameResolver localHostName will be used."
 
 	^self connectionInfo at: #localHostName ifAbsent: [NetNameResolver localHostName]! !

!SMTPClient methodsFor: 'private - protocol' stamp: ''!
initiateSession
	"EHLO <SP> <domain> <CRLF>"

	self sendCommand: (self useHelo ifTrue:['HELO '] ifFalse: ['EHLO ']) , NetNameResolver localHostName.
	self checkResponse.! !

!SMTPClient methodsFor: 'private - protocol' stamp: ''!
recipient: aRecipient
	"specify a recipient for the message.  aRecipient should be a bare email address"
	"RCPT <SP> TO:<forward-path> <CRLF>"

	self sendCommand: 'RCPT TO: <', aRecipient, '>'.
	self checkResponse.! !

!SMTPClient methodsFor: 'public protocol' stamp: ''!
mailFrom: sender to: recipientList text: messageText
	"deliver this mail to a list of users.  NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff"

	self mailFrom: sender.
	recipientList do: [ :recipient |
		self recipient: recipient ].
	self data: messageText.! !

!SMTPClient methodsFor: 'private - protocol' stamp: ''!
quit
	"send a QUIT command.  This is polite to do, and indeed some servers might drop messages that don't have an associated QUIT"
	"QUIT <CRLF>"

	self sendCommand: 'QUIT'.
	self checkResponse.! !

!SMTPClient methodsFor: 'utilities' stamp: ''!
encodeString: aString 
	^ (aString encodeWith: #null) base64Encoded! !

!SMTPClient methodsFor: 'public protocol' stamp: ''!
useHelo
	"If client use HELO instead of EHLO. HELO is the old protocol and
	an old server may require it instead of EHLO."

	^self connectionInfo at: #useHelo ifAbsent: [false]! !

!SMTPClient methodsFor: 'public protocol' stamp: ''!
useHelo: aBoolean
	"Tell client to use HELO instead of EHLO. HELO is the old protocol and
	an old server may require it instead of EHLO."

	^self connectionInfo at: #useHelo put: aBoolean! !

!SMTPClient class methodsFor: '*Network-Mail' stamp: ''!
deliver: aMailMessage usingServer: aString
	"See comment for #deliverMailFrom:to:text:usingServer:"
	
	self deliverMailFrom: aMailMessage from to: aMailMessage recipientList text: aMailMessage text usingServer: aString.! !

!SMTPClient class methodsFor: 'examples' stamp: ''!
example
	"SMTPClient example"

	self deliverMailFrom: 'm.rueger@acm.org' to: #('m.rueger@acm.org') text:
'From: test
To: "not listed"
Subject: this is a test

Hello from Pharo!!
'	usingServer: 'smtp.concentric.net'! !

!SMTPClient class methodsFor: 'sending mail' stamp: ''!
deliverMailFrom: fromAddress to: recipientList text: messageText usingServer: aString
	"Deliver a single email to a list of users and then close the connection.  For delivering multiple messages, it is best to create a single connection and send all mail over it
	recipientList - a collection of simple internet style addresses -- no '<>' or '()' stuff
	aString - can be
		- server name and port number e.g. mail.mydomain.com:26
		- server name only e.g. mail.mydomain.com, default port is used"

	| smtpClient |
	smtpClient := self openOnHostNamed: aString.
	[smtpClient initiateSession.
	smtpClient mailFrom: fromAddress to: recipientList text: messageText.
	smtpClient quit]
		ensure: [smtpClient close]! !

!SMTPClient class methodsFor: 'accessing' stamp: ''!
defaultPortNumber
	^25! !

!SMTPClient class methodsFor: 'accessing' stamp: ''!
logFlag
	^#smtp! !

!SMTPClient class methodsFor: 'examples' stamp: ''!
example2
	"SMTPClient example2"

	self deliverMailFrom: 'm.rueger@acm.org' to: #('m.rueger@acm.org') text:
'Subject: this is a test

Hello from Pharo!!
'	usingServer: 'smtp.concentric.net'! !

!SMTPClientTest commentStamp: ''!
SUnit tests for SMTP client!
!SMTPClientTest methodsFor: 'testing' stamp: ''!
testMailFrom
	smtp mailFrom: 'frank@angband.za.org'.
	self assert: socket outStream contents equals: 'MAIL FROM: <frank@angband.za.org>', String crlf.
	
	socket resetOutStream.
	smtp mailFrom: '<frank@angband.za.org>'.
	self assert: socket outStream contents equals: 'MAIL FROM: <frank@angband.za.org>', String crlf.
	
	socket resetOutStream.
	smtp mailFrom: 'Frank <frank@angband.za.org>'.
	self assert: socket outStream contents equals: 'MAIL FROM: <frank@angband.za.org>', String crlf! !

!SMTPClientTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	socket := MockSocketStream on: ''.
	smtp := SMTPClient new.
	smtp stream: socket.! !

!SQSurfaceDispatch commentStamp: ''!
A structure from SurfacePlugin.h 
 

typedef struct sqSurfaceDispatch {
	/* Version information. Must be provided by the client
	   so the surface manager can check if certain operations
	   are supported. */
	int majorVersion;
	int minorVersion;

	/* Version 1.0 */
	fn_getSurfaceFormat getSurfaceFormat;
	fn_lockSurface lockSurface;
	fn_unlockSurface unlockSurface;
	fn_showSurface showSurface;
} sqSurfaceDispatch; 
!
!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
getSurfaceFormatFn
	"This method was automatically generated"
	^FFICallback forAddress: ((handle pointerAt: OFFSET_GETSURFACEFORMATFN) asInteger)! !

!SQSurfaceDispatch methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		majorVersion: 1; 
		minorVersion: 0! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
majorVersion
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_MAJORVERSION! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
showSurfaceFn
	"This method was automatically generated"
	^FFICallback forAddress: ((handle pointerAt: OFFSET_SHOWSURFACEFN) asInteger)! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
majorVersion: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_MAJORVERSION put: anObject! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
lockSurfaceFn
	"This method was automatically generated"
	^FFICallback forAddress: ((handle pointerAt: OFFSET_LOCKSURFACEFN) asInteger)! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
showSurfaceFn: aCallbackOrNil
	"This method was automatically generated"
	showSurfaceFn := aCallbackOrNil.
	handle 
		pointerAt: OFFSET_SHOWSURFACEFN 
		put: (aCallbackOrNil 
			ifNotNil: [ aCallbackOrNil thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
getSurfaceFormatFn: aCallback
	"This method was automatically generated"
	getSurfaceFormatFn := aCallback.
	handle 
		pointerAt: OFFSET_GETSURFACEFORMATFN 
		put: aCallback thunk asExternalAddress! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
minorVersion: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_MINORVERSION put: anObject! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
lockSurfaceFn: aCallback
	"This method was automatically generated"
	lockSurfaceFn := aCallback.
	handle 
		pointerAt: OFFSET_LOCKSURFACEFN 
		put: aCallback thunk asExternalAddress! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
unlockSurfaceFn
	"This method was automatically generated"
	^FFICallback forAddress: ((handle pointerAt: OFFSET_UNLOCKSURFACEFN) asInteger)! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
minorVersion
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_MINORVERSION! !

!SQSurfaceDispatch methodsFor: 'accessing - structure variables' stamp: ''!
unlockSurfaceFn: aCallbackOrNil
	"This method was automatically generated"
	unlockSurfaceFn := aCallbackOrNil.
	handle 
		pointerAt: OFFSET_UNLOCKSURFACEFN 
		put: (aCallbackOrNil 
			ifNotNil: [ aCallbackOrNil thunk asExternalAddress ]
			ifNil: [ ExternalAddress null ])! !

!SQSurfaceDispatch class methodsFor: 'field definition' stamp: ''!
fieldsDesc

" self rebuildFieldAccessors

A structure from SurfacePlugin.h 
 

typedef struct sqSurfaceDispatch {
	/* Version information. Must be provided by the client
	   so the surface manager can check if certain operations
	   are supported. */
	int majorVersion;
	int minorVersion;

	/* Version 1.0 */
	fn_getSurfaceFormat getSurfaceFormat;
	fn_lockSurface lockSurface;
	fn_unlockSurface unlockSurface;
	fn_showSurface showSurface;
} sqSurfaceDispatch; 
"
	^ #(
		int majorVersion;
		int minorVersion;
		FFICallback getSurfaceFormatFn;
		FFICallback lockSurfaceFn;
		FFICallback unlockSurfaceFn;
		FFICallback showSurfaceFn
	)! !

!SQSurfaceDispatch class methodsFor: 'private' stamp: ''!
rebuildFieldAccessors
	"Prevent rebuild, because methods are modified to ensure callbacks are not GCed"! !

!STCommandLineHandler commentStamp: ''!
Usage: st [--help] [ --quit ] <FILE>
	--help    list this help message
	--quit    if specified, the image exits without saving after evaluating FILE
	--save    if specified, save the image after evaluating FILE
	--no-source if specified, do not write to the .changes file
	<FILE>    a file containing valid Pharo expressions

Documentation:
The ST command line handler runs Pharo code stored in a file without quiting.

Example:

	pharo Pharo.image st code.st
	
	# By default files ending in .st are recognized and evaluated
	pharo Pharo.image code.st
!
!STCommandLineHandler methodsFor: 'loading' stamp: ''!
loadSourceFiles: anArray
	"Load all the source files in the given array."

	sourceFiles := anArray collect: [ :each | File named: each ].! !

!STCommandLineHandler methodsFor: 'installing' stamp: ''!
skipShebangFrom: readStream
	"Skip the shebang sequnce #!! at the beginning of a bash file"
	
	readStream wrappedStream position = 0
		ifFalse: [  ^ self "#!! can only be skipped at the beginning" ].
	
	(readStream wrappedStream next: 2) = '#!!'
		ifFalse: [ 
			readStream wrappedStream position: 0.
			^ self ].
	
	"here we found the shebang, so skip the first line"
	^ readStream nextLine.! !

!STCommandLineHandler methodsFor: 'activation' stamp: ''!
selectSourceFiles
	self loadSourceFiles: (self commandLine allFilesWithExtension: '.st').! !

!STCommandLineHandler methodsFor: 'private' stamp: ''!
handleError: error	
	
	"for syntax errors we can used the default action"	"otherwise resignal it"
	(error isKindOf: SyntaxErrorNotification)
		ifTrue: [ error defaultAction ]
		ifFalse: [ error pass ]! !

!STCommandLineHandler methodsFor: 'private' stamp: ''!
end
	| quit  |
	
	quit := self commandLine hasOption: 'quit'.
	
	(self commandLine hasOption: 'save') 
		ifTrue: [ Smalltalk snapshot: true andQuit: quit ].
	
	quit
		ifTrue: [ self exitSuccess ].! !

!STCommandLineHandler methodsFor: 'installing' stamp: ''!
handleErrorsDuring: aBlock reference: aReference
	aBlock
		on: Error, OCSemanticWarning, OCSemanticError
		do: [ :e | self handleError: e reference: aReference ]! !

!STCommandLineHandler methodsFor: 'installing' stamp: ''!
installSourceFiles
	"Install the previously loaded source files"

	sourceFiles ifNil: [ ^ self ].
	[ sourceFiles do: [ :reference | 
		self installSourceFile: reference ]
	] ensure: [ sourceFiles := nil ].! !

!STCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self activateHelp
		ifTrue: [  ^ self ].
	
	self selectSourceFiles.
	self installSourceFiles.
	
	self end! !

!STCommandLineHandler methodsFor: 'installing' stamp: ''!
installSourceFile: aReference
	"Install the source file given by aFileReference"
	| codeImporter |

	" parse the code given in the source file"
	aReference readStreamDo: [ :binary | | stream |
		stream := ZnCharacterReadStream on: binary encoding: 'utf8'.
		self 
			handleErrorsDuring: [
				self skipShebangFrom: stream.
				codeImporter := CodeImporter fileStream: stream.
				codeImporter logSource: (self hasOption: 'no-source') not.
				codeImporter parseChunks ]
			reference: aReference ].
	
	"evaluate the declarations in a second step to allow for properly closing the source file stream"
	self 
		handleErrorsDuring: [ codeImporter evaluate ]
		reference: aReference.! !

!STCommandLineHandler methodsFor: 'private' stamp: ''!
handleError: error reference: aReference
	"Print a header before failing on an errro / syntax notification from the the script loaded by the given request"
	
	"We ignore warnings for now"
	(error isKindOf: OCSemanticWarning)
		ifTrue: [ ^ error pass ].
		
	"spit out a warning if in headless mode, otherwise a debugger will popup"
	Smalltalk isHeadless 
		ifTrue: [ self inform: 'Errors in script loaded from ', aReference name ].
															
	"for syntax errors we can use the default action"															
	(error isKindOf: SyntaxErrorNotification)
		ifTrue: [ ^ error defaultAction ].
	
	(error isKindOf: OCSemanticError)
		ifTrue: [ 
			self class printCompilerWarning: error.
			^ error resume: error defaultAction ].
	
	"otherwise resignal it"
	error pass.! !

!STCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'st'! !

!STCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Loads and executes .st source files'! !

!STCommandLineHandler class methodsFor: 'printing' stamp: ''!
printCompilerWarning: aSyntaxErrorNotification
	| stderr position contents errorLine errorMessage maxLineNumberSize lineNumber |
	
	"format the error"
	position := aSyntaxErrorNotification location.
	contents := aSyntaxErrorNotification errorCode.
	errorLine := contents lineNumberCorrespondingToIndex: position.
	stderr := VTermOutputDriver stderr.
		
	"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].
	
	 stderr red;
		nextPutAll: errorMessage; lf;
		nextPutAll: ('' padLeftTo: errorMessage size with: $=); lf;
		clear.
	
	"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.
		lineNumber == errorLine ifTrue: [ stderr errorColor ].
		"0 pad the line numbers to the same size"
		stderr 
			nextPutAll: (lineNumber asString padLeftTo: maxLineNumberSize with: $0);
			nextPutAll: ': ';
			nextPutAll: (contents copyFrom: start to: endWithoutDelimiters);
			lf.
			"print the marker under the error line"
		(lineNumber == errorLine)
			ifTrue: [
					stderr nextPutAll:( '_^_' padLeftTo: position - start + maxLineNumberSize + 4);
							 lf;
							 clear]
	]! !

!STCommandLineHandler class methodsFor: 'handler selection' stamp: ''!
isResponsibleFor: aCommandLine
	"This handler is reponsible only for .st files"
	(aCommandLine hasFileWithExtension: '.st')
		ifTrue: [ ^ true ].
	^ super isResponsibleFor: aCommandLine! !

!STCommandLineHandlerTest methodsFor: 'tests' stamp: ''!
testSelectSourceFiles
	| codeLoader commandLine |

	commandLine := CommandLineArguments withArguments: {'does-not-exist.st'. '--host=localhost'}.	
	codeLoader := STCommandLineHandler new
		commandLine: commandLine;
		yourself.

	"Verify that 'does-not-exist.st' is loaded but not --host=localhost"
	codeLoader selectSourceFiles.

	"Now verify that it doesn't try to load localhost"
	self assert: (codeLoader instVarNamed: 'sourceFiles') notNil.
	self assert: (codeLoader instVarNamed: 'sourceFiles') size equals: 1.
	self assert: (codeLoader instVarNamed: 'sourceFiles') first name equals: 'does-not-exist.st'! !

!STCommandLineHandlerTest methodsFor: 'tests' stamp: ''!
testLoadSourceFiles
	| codeLoader |
	
	codeLoader := STCommandLineHandler new.
	
	codeLoader loadSourceFiles: {
		'/not/existing/codeLoad1.st'. 
		'/not/existing/codeLoad2.st'}.
	
	self assert: (codeLoader instVarNamed: 'sourceFiles') notNil.
	self assert: (codeLoader instVarNamed: 'sourceFiles') size equals: 2.
	self assert: ((codeLoader instVarNamed: 'sourceFiles') allSatisfy: [ :each | each isKindOf: File ])! !

!STCommandLineHandlerTest methodsFor: 'tests' stamp: ''!
testInstallSourceFilesFail
	| codeLoader |
	
	codeLoader := STCommandLineHandler new.
	codeLoader loadSourceFiles: {'codeLoad1.st'}.
	"Ensure file is not there"
	(FileSystem disk workingDirectory / 'codeLoad1.st') asFileReference ensureDelete. 
	"Trying non existing file"
	self should: [ codeLoader installSourceFiles ] raise: Error! !

!STCommandLineHandlerTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ STCommandLineHandler! !

!STCommandLineHandlerTest methodsFor: 'tests' stamp: ''!
testCommandLineHandlerCondition
	| commandLine reference |
	
	commandLine := CommandLineArguments withArguments: {'/non/existing/file.st'}. 
	"the responsibility is transferred to the BasicCodeLoader as soon as there is a .st file in the arguments"
	self assert: (STCommandLineHandler isResponsibleFor: commandLine).
		
	[ reference := FileSystem disk workingDirectory / 'codeLoad1.st'.
	  reference writeStreamDo: [ :stream | stream nextPutAll: '42' ].
	  commandLine := CommandLineArguments withArguments: {reference fullName}. 
	  self assert: (STCommandLineHandler isResponsibleFor: commandLine) ]
	ensure: [ reference delete ]
! !

!STON commentStamp: ''!
STON implements serialization and materialization using the Smalltalk Object Notation format.

I am a class side facade offering a high level API to write and read objects using STON.

U s a g e

Basic operations

  #toString:
  #fromString:

  STON toString: DisplayScreen boundingBox.
  STON fromString:  'Rectangle{#origin:Point[0,0],#corner:Point[1920,1030]}'.

  STON toString: { DateAndTime now. Float pi. 1 to: 10 by: 2. 3 days }.
  STON fromString:  '[DateAndTime[''2016-03-15T13:57:59.462422+01:00''],3.141592653589793,Interval{#start:1,#stop:10,#step:2},Duration{#nanos:0,#seconds:259200}]'

You can also read from or write to streams

  #fromStream:
  #put:onStream:

There is also the option to do pretty printing (indenting, multi line output) 

  #toStringPretty:
  #put:onStreamPretty:

STON is more or less a superset of JSON and is backwards compatible with JSON while parsing, and can be compatible with it while writing. The important differences (and the whole reason why STON exists in the first place) are 

  - class information (except for lists (Array) and maps (Dictionary))
  - proper handling of shared and circular references
  - more Smalltalk like syntax (Symbols with #, single quoted Strings, nil instead of null)
  - more defined special types (Date, Time, DataAndTime, ByteArray, Point)

Parsing JSON is done using #fromString: or #fromStream: with the results being composed of Arrays and Dictionaries.

Writing objects as JSON is done using: 

  #toJsonString[Pretty]:
  #put:asJsonOnStream[Pretty]:

Note that you can only write Arrays and Dictionaries !!

For a much more sophisticated JSON parser/writer implementation, have a look at NeoJSON.

Like JSON, STON does not allow for comments. However, a preprocessor option can skip C style comments before parsing.

I also define some constants used in the implementation: the class used as list, map and association, as well as the optional class name key (used when reading objects using an unknown class).


I m p l e m e n t a t i o n

The 2 key methods are

  #stonOn:
  #fromSton:

which work together with STONWriter and STONReader; read their class comments for all configuration options (you can use the #reader and #writer methods to avoid referring to these classes directly).

Several methods are used to support and/or control the implementation

  #stonName - defines the external name for a class
  #stonAllInstVarNames - defines which instance variable to write
  #stonContainSubObjects - shortcut looking into objects for subobjects
  #stonShouldWriteNilInstVars - option to skip writing nil valued instance variables


S y n t a x

	value
	  primitive-value
	  object-value
	  reference
	  nil
	primitive-value
	  number
	  true
	  false
	  symbol
	  string
	object-value
	  object
	  map
	  list
	object
	  classname map
	  classname list
	reference
	  @ int-index-previous-object-value
	map
	  {}
	  { members }
	members
	  pair
	  pair , members
	pair
	  string : value
	  symbol : value
	  number : value
	list
	  []
	  [ elements ]
	elements
	  value 
	  value , elements
	string
	  ''
	  ' chars '
	chars
	  char
	  char chars
	char
	  any-printable-ASCII-character-
	    except-'-"-or-\
	  \'
	  \"
	  \\
	  \/
	  \b
	  \f
	  \n
	  \r
	  \t
	  \u four-hex-digits
	symbol
	  # chars-limited
	  # ' chars '
	chars-limited
	  char-limited
	  char-limited chars-limited
	char-limited
	  a-z A-Z 0-9 - _ . /
	classname
	  uppercase-alpha-char alphanumeric-char
	number
	  int
	  int denominator
	  int denominator scale
	  int frac
	  int exp
	  int frac exp
	int
	  digit
	  digit1-9 digits 
	  - digit
	  - digit1-9 digits
	denominator
	  / digits
	scale
	  s digits
	frac
	  . digits
	exp
	  e digits
	digits
	  digit
	  digit digits
	e
	  e
	  e+
	  e-
	  E
	  E+
	  E-
!
!STON class methodsFor: 'convencience' stamp: ''!
fromString: string
	^ self fromStream: string readStream! !

!STON class methodsFor: 'convencience' stamp: ''!
toJsonString: object
	^ String streamContents: [ :stream |
		self put: object asJsonOnStream: stream ]! !

!STON class methodsFor: 'convencience' stamp: ''!
fromStream: readStream
	^ (self reader on: readStream) next! !

!STON class methodsFor: 'convencience' stamp: ''!
fromStreamWithComments: readStream
	^ (self reader on: (STONCStyleCommentsSkipStream on: readStream)) next! !

!STON class methodsFor: 'convencience' stamp: ''!
toString: object
	^ String streamContents: [ :stream |
		self put: object onStream: stream ]! !

!STON class methodsFor: 'accessing' stamp: ''!
listClass
	^ Array! !

!STON class methodsFor: 'convencience' stamp: ''!
fromStringWithComments: string
	^ self fromStreamWithComments: string readStream! !

!STON class methodsFor: 'accessing' stamp: ''!
classNameKey
	^ #className! !

!STON class methodsFor: 'accessing' stamp: ''!
jsonWriter
	^ STONWriter new
			jsonMode: true;
			referencePolicy: #error;
			yourself! !

!STON class methodsFor: 'convencience' stamp: ''!
put: object asJsonOnStreamPretty: stream
	(self jsonWriter on: stream)
		prettyPrint: true; 
		nextPut: object! !

!STON class methodsFor: 'convencience' stamp: ''!
toJsonStringPretty: object
	^ String streamContents: [ :stream |
		self put: object asJsonOnStreamPretty: stream ]! !

!STON class methodsFor: 'convencience' stamp: ''!
put: object onStream: stream
	(self writer on: stream) nextPut: object! !

!STON class methodsFor: 'convencience' stamp: ''!
put: object asJsonOnStream: stream
	(self jsonWriter on: stream) nextPut: object! !

!STON class methodsFor: 'convencience' stamp: ''!
toStringPretty: object
	^ String streamContents: [ :stream |
		self put: object onStreamPretty: stream ]! !

!STON class methodsFor: 'accessing' stamp: ''!
associationClass
	^ Association! !

!STON class methodsFor: 'accessing' stamp: ''!
mapClass
	^ Dictionary! !

!STON class methodsFor: 'convencience' stamp: ''!
put: object onStreamPretty: stream
	(self writer on: stream)
		prettyPrint: true; 
		nextPut: object! !

!STON class methodsFor: 'accessing' stamp: ''!
reader
	^ STONReader new! !

!STON class methodsFor: 'accessing' stamp: ''!
writer
	^ STONWriter new! !

!STONAlternativeRepresentationTestObject commentStamp: ''!
I am STONAlternativeRepresentationTestObject.

My properties are
 - id <Integer>
 - time <DateAndTime> in the local time zone
 - gridReference <Point <Float>@<Float>> in kilometer

My STON representation has the properties
 - id <Integer>
 - time <DateAndTime> in UTC
 - grid_reference <Point <Float>@<Float>> in miles

Note the different key, gridReference vs. grid_reference

Upon serialization, the conversions local time to UTC and kilometer to mile is performed.
Upon materialization, the convertions UTC to local tie and miles to kilometers are performed.
 !
!STONAlternativeRepresentationTestObject methodsFor: 'accessing' stamp: ''!
timeUTC
	^ time asUTC! !

!STONAlternativeRepresentationTestObject methodsFor: 'accessing' stamp: ''!
gridReferenceImperial
	^ gridReference / 1.609344! !

!STONAlternativeRepresentationTestObject methodsFor: 'accessing' stamp: ''!
id: anObject
	id := anObject! !

!STONAlternativeRepresentationTestObject methodsFor: 'accessing' stamp: ''!
time
	^ time! !

!STONAlternativeRepresentationTestObject methodsFor: 'accessing' stamp: ''!
gridReference
	^ gridReference! !

!STONAlternativeRepresentationTestObject methodsFor: 'accessing' stamp: ''!
gridReferenceImperial: value
	gridReference := value * 1.609344! !

!STONAlternativeRepresentationTestObject methodsFor: 'accessing' stamp: ''!
timeUTC: value
	time := value offset: TimeZone local offset ! !

!STONAlternativeRepresentationTestObject methodsFor: 'accessing' stamp: ''!
gridReference: value
	gridReference := value! !

!STONAlternativeRepresentationTestObject methodsFor: 'ston persistence' stamp: ''!
fromSton: stonReader
	stonReader parseMapDo: [ :key :value |
		key = #id ifTrue: [ self id: value ].
		key = #time ifTrue: [ self timeUTC: value ].
		key = #grid_reference ifTrue: [ self gridReferenceImperial: value ] ]! !

!STONAlternativeRepresentationTestObject methodsFor: 'ston persistence' stamp: ''!
stonOn: stonWriter	
	stonWriter writeObject: self streamMap: [ :dictionary |
		dictionary
			at: #id put: self id;
			at: #time put: self timeUTC;
			at: #grid_reference put: self gridReferenceImperial ]! !

!STONAlternativeRepresentationTestObject methodsFor: 'accessing' stamp: ''!
time: anObject
	time := anObject! !

!STONAlternativeRepresentationTestObject methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!STONAlternativeRepresentationTestObject class methodsFor: 'example' stamp: ''!
example
	^ self new
		id: 1e9 atRandom; 
		time: DateAndTime now; 
		gridReference: 150.75@250.25; 
		yourself! !

!STONCStyleCommentsSkipStream commentStamp: ''!
I am STONCStyleCommentsSkipStream, a character ReadStream wrapping another character ReadStream. I skip C style comments, much like a classic C preprocessor.

C, C++, Java, JavaScript style comments are either the multiline

	/* a comment */
	
or the single line, up to end of line

	// a comment 
	
I deal with any end of line convention. Multiline comments cannot be nested. 

You create me #on: another character ReadStream. 

Here is an example:

	(STONCStyleCommentsSkipStream on: 'abc/*comment*/def' readStream) upToEnd.
	
Comments inside single and double quote delimited strings are ignored. Backslash escapes for single and double quotes inside strings are honored.
!
!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
position
	^ stream position! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
peek
	^ peekedCharacter
		ifNil: [
			stream atEnd
				ifFalse: [ 
					peekedCharacter := self nextNonCommentChar ] ]
! !

!STONCStyleCommentsSkipStream methodsFor: 'private' stamp: ''!
consumeToCommentEnd
	[ stream atEnd or: [ stream next = $* and: [ stream peekFor: $/ ] ] ] whileFalse! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
next: requestedCount 
	"Read requestedCount elements into new collection and return it,
	 it could be that less elements were available"

	^ self 
		next: requestedCount 
		into: (self collectionSpecies new: requestedCount)! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
upToEnd
	^ self collectionSpecies
		streamContents: [ :collectionStream | 
			[ self atEnd ] whileFalse: [ collectionStream nextPut: self next ] ]! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection startingAt: offset
	"Read requestedCount elements into collection starting at offset,
	returning a copy if less elements are available"
	
	| readCount |
	readCount := self 
		readInto: collection 
		startingAt: offset 
		count: requestedCount.
	^ requestedCount = readCount
		ifTrue: [ collection ]
		ifFalse: [ collection copyFrom: 1 to: offset + readCount - 1 ]! !

!STONCStyleCommentsSkipStream methodsFor: 'testing' stamp: ''!
isBinary
	^ false! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
nextLine
	"Read a CR, LF or CRLF terminated line, returning the contents of the line without the EOL. Return nil when the receiver is #atEnd."
	
	self atEnd ifTrue: [ ^ nil ].
	^ self collectionSpecies streamContents: [ :out | | eol char |
		eol := false.
		[ eol ] whileFalse: [ 
			char := self next.
			(char isNil or: [ char = Character lf ])
				ifTrue: [ eol := true ]
				ifFalse: [ 
					char = Character cr 
						ifTrue: [ eol := true. self peekFor: Character lf ]
						ifFalse: [  out nextPut: char ] ] ] ]! !

!STONCStyleCommentsSkipStream methodsFor: 'initialize-release' stamp: ''!
close
	stream close! !

!STONCStyleCommentsSkipStream methodsFor: 'testing' stamp: ''!
atEnd
	^ self peek isNil! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection
	"Read requestedCount elements into collection,
	returning a copy if less elements are available"
	
	^ self
		next: requestedCount
		into: collection
		startingAt: 1! !

!STONCStyleCommentsSkipStream methodsFor: 'private' stamp: ''!
escape
	"Return true when we previously read a backslash escape inside a string, 
	so that the next string delimiter should be returned as is"
	
	^ escape = true! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
next
	^ peekedCharacter
		ifNil: [ 
			stream atEnd
				ifFalse: [ self nextNonCommentChar ] ]
		ifNotNil: [ | character |
			character := peekedCharacter.
			peekedCharacter := nil.
			character ]! !

!STONCStyleCommentsSkipStream methodsFor: 'initialize-release' stamp: ''!
on: readStream
	stream := readStream! !

!STONCStyleCommentsSkipStream methodsFor: 'private' stamp: ''!
nextNonCommentChar
	| char |
	char := stream next.
	(self insideString and: [ char = $\ ])
		ifTrue: [ 
			escape := true. 
			^ char ].
	(char = $') | (char = $")
		ifTrue: [ 
			^ self handleStringDelimiter: char ].
	escape := false. 
	^ (char = $/ and: [ self insideString not and: [ (stream peek = $/) | (stream peek = $*) ] ])
		ifTrue: [ 
			self consumeComment.
			stream next ]
		ifFalse: [ char ]
! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
collectionSpecies
	^ String! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
skip: count
	count timesRepeat: [ self next ]! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
peekFor: object
	^ self peek = object
		ifTrue: [ 
			self next.
			true ]
		ifFalse: [ false ]! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
upTo: anObject 	
	^ self collectionSpecies 
		streamContents: [ :out | | element |
			[ self atEnd or: [ (element := self next) = anObject ] ] whileFalse: [ 
				out nextPut: element ] ]! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
readInto: collection startingAt: offset count: requestedCount 
	"Read count elements and place them in collection starting at offset.
	Return the number of elements actually read."
	
	^ peekedCharacter 
		ifNil: [
			0 to: requestedCount - 1 do: [ :count | | object |
				(object := self nextNonCommentChar) ifNil: [ ^ count ].  
				collection at: offset + count put: object ].
			^ requestedCount ]
		ifNotNil: [ 
			collection at: offset put: peekedCharacter.
			peekedCharacter := nil.
			(self 
				readInto: collection 
				startingAt: offset + 1
				count: requestedCount - 1) + 1 ]! !

!STONCStyleCommentsSkipStream methodsFor: 'private' stamp: ''!
consumeComment
	stream peek = $/ ifTrue: [ self consumeToEOL ].
	stream peek = $* ifTrue: [ self consumeToCommentEnd ]! !

!STONCStyleCommentsSkipStream methodsFor: 'accessing' stamp: ''!
wrappedStream
	^ stream! !

!STONCStyleCommentsSkipStream methodsFor: 'private' stamp: ''!
consumeToEOL
	| eol char |
	eol := false.
	[ eol ] whileFalse: [ 
		char := stream next.
		(char isNil or: [ char = Character lf ])
			ifTrue: [ eol := true ]
			ifFalse: [ 
				char = Character cr
					ifTrue: [ 
						eol := true.
						stream peekFor: Character lf ] ] ]! !

!STONCStyleCommentsSkipStream methodsFor: 'private' stamp: ''!
insideString
	"Return true when we are currently inside a string where comments should be ignored."
	
	^ (delimiter = $') | (delimiter = $")! !

!STONCStyleCommentsSkipStream methodsFor: 'private' stamp: ''!
handleStringDelimiter: char
	self escape
		ifTrue: [ escape := false ]
		ifFalse: [ 
			self insideString
				ifTrue: [ 
					char = delimiter
						ifTrue: [ delimiter := nil ] ]
				ifFalse: [ delimiter := char ] ].
	^ char! !

!STONCStyleCommentsSkipStream class methodsFor: 'instance creation' stamp: ''!
on: readStream
	^ self new
		on: readStream;
		yourself! !

!STONCStyleCommentsSkipStreamTest methodsFor: 'testing' stamp: ''!
testBlockReading
	| input buffer |
	input := STONCStyleCommentsSkipStream on: 'abc/*comment*/def' readStream.
	buffer := String new: 6.
	self assert: (input readInto: buffer startingAt: 1 count: 4) equals: 4.
	self assert: (buffer copyFrom: 1 to: 4) equals: 'abcd'.
	self assert: (input readInto: buffer startingAt: 5 count: 4) equals: 2.
	self assert: buffer equals: 'abcdef'.
	input := STONCStyleCommentsSkipStream on: 'abc//comment\def' withCRs readStream.
	buffer := String new: 6.
	self assert: (input readInto: buffer startingAt: 1 count: 6) equals: 6.
	self assert: buffer equals: 'abcdef'.
	self assert: input atEnd! !

!STONCStyleCommentsSkipStreamTest methodsFor: 'testing' stamp: ''!
testCommentInString
	self 
		assert: (STONCStyleCommentsSkipStream on: '''/*comment*/''' readStream) upToEnd 
		equals: '''/*comment*/'''.
	self 
		assert: (STONCStyleCommentsSkipStream on: '{''foo'':''/*comment*/bar''}' readStream) upToEnd 
		equals: '{''foo'':''/*comment*/bar''}'.
	self 
		assert: (STONCStyleCommentsSkipStream on: '{''foo'':''//comment\''bar''}' readStream) upToEnd 
		equals: '{''foo'':''//comment\''bar''}'.
	self 
		assert: (STONCStyleCommentsSkipStream on: '{"foo":"/*comment*/bar"}' readStream) upToEnd 
		equals: '{"foo":"/*comment*/bar"}'.
	self 
		assert: (STONCStyleCommentsSkipStream on: '{"foo":"//comment\"bar"}' readStream) upToEnd 
		equals: '{"foo":"//comment\"bar"}'! !

!STONCStyleCommentsSkipStreamTest methodsFor: 'testing' stamp: ''!
testMultiLineComment
	self 
		assert: (STONCStyleCommentsSkipStream on: 'foo\//comment\bar' withCRs readStream) upToEnd 
		equals: 'foo\bar' withCRs.
	self 
		assert: (STONCStyleCommentsSkipStream on: 'foo\//comment\bar' withCRs readStream) nextLine
		equals: 'foo'.
	self 
		assert: ((STONCStyleCommentsSkipStream on: 'foo\//comment\bar' withCRs readStream) nextLine; nextLine) 
		equals: 'bar'.
	self assert: (STONCStyleCommentsSkipStream on: '//comment' readStream) atEnd.! !

!STONCStyleCommentsSkipStreamTest methodsFor: 'testing' stamp: ''!
testNonComment
	self assert: (STONCStyleCommentsSkipStream on: 'foo' readStream) upToEnd equals: 'foo'.
	self assert: (STONCStyleCommentsSkipStream on: 'foo' readStream) nextLine equals: 'foo'.
	self deny: (STONCStyleCommentsSkipStream on: 'foo' readStream) atEnd.
	self assert: (STONCStyleCommentsSkipStream on: '' readStream) atEnd.! !

!STONCStyleCommentsSkipStreamTest methodsFor: 'testing' stamp: ''!
testSTON
	"Comments are processed first and totally removed.
	They are not even whitespace (not that whitespace is relevant in STON)."
	
	self 
		assert: (STON fromStream: (STONCStyleCommentsSkipStream on: '123/*comment*/456' readStream)) 
		equals: 123456.
	self 
		assert: (STON fromStream: (STONCStyleCommentsSkipStream on: '/*comment*/''abcd''' readStream)) 
		equals: 'abcd'.
	self 
		assert: (STON fromStream: (STONCStyleCommentsSkipStream on: '123//456' readStream)) 
		equals: 123.
	self 
		should: [ STON fromStream: (STONCStyleCommentsSkipStream on: '//456' readStream) ] 
		raise: STONReaderError
! !

!STONCStyleCommentsSkipStreamTest methodsFor: 'testing' stamp: ''!
testSingleLineComment
	self assert: (STONCStyleCommentsSkipStream on: 'foo/*comment*/bar' readStream) upToEnd equals: 'foobar'.
	self assert: (STONCStyleCommentsSkipStream on: 'foo/*comment*/bar' readStream) nextLine equals: 'foobar'.
	self deny: (STONCStyleCommentsSkipStream on: 'foo/*comment*/bar' readStream) atEnd.
	self assert: (STONCStyleCommentsSkipStream on: '/*comment*/' readStream) atEnd.! !

!STONFileReference commentStamp: ''!
I am STONFileReference, I am an implementation artifact to help reading objects with class tag equal to my #stonName.

I am a FileReference.!
!STONFileReference class methodsFor: 'ston' stamp: ''!
stonName
	^ #FILE! !

!STONFileReference class methodsFor: 'ston' stamp: ''!
fromSton: stonReader
	^ stonReader parseListSingleton asFileReference.! !

!STONJSON commentStamp: ''!
I am STONJSON, a class side facade to use STON as a simple JSON parser/writer.

STON is more or less a superset of JSON and is backwards compatible with JSON while parsing, and can be compatible with it while writing. The important differences (and the whole reason why STON exists in the first place) are 

  - class information (except for lists (Array) and maps (Dictionary))
  - proper handling of shared and circular references
  - more Smalltalk like syntax (Symbols with #, single quoted Strings, nil instead of null)
  - more defined special types (Date, Time, DataAndTime, ByteArray, Point)

Parsing JSON is done using

  #fromString:
  #fromStream: 

with the results being composed of Arrays and Dictionaries.

Writing objects as JSON is done using

  #toString[Pretty]:
  #put:onStream[Pretty]:

Note that you can only write Arrays and Dictionaries !! Shared and circular references will be noted and signalled using an exception.

E x a m p l e s

  STONJSON toString: { 1. -1. Float pi. true. 'JSON' }.
  STONJSON fromString: '[1,-1,3.141592653589793,true,"JSON"]'.

  STONJSON toStringPretty: { #foo->1. #bar->2 } asDictionary.
  STONJSON fromString: '{"foo":1,"bar":2,"sub":{"a":true,"b":false},"flags":[1,8,32]}'.
 
For a much more sophisticated JSON parser/writer implementation, have a look at NeoJSON.!
!STONJSON class methodsFor: 'convenience' stamp: ''!
fromString: string
	^ STON fromString: string! !

!STONJSON class methodsFor: 'convenience' stamp: ''!
fromStream: stream
	^ STON fromStream: stream! !

!STONJSON class methodsFor: 'convenience' stamp: ''!
toString: object
	^ STON toJsonString: object! !

!STONJSON class methodsFor: 'convenience' stamp: ''!
put: object onStream: stream
	STON put: object asJsonOnStream: stream! !

!STONJSON class methodsFor: 'convenience' stamp: ''!
toStringPretty: object
	^ STON toJsonStringPretty: object! !

!STONJSON class methodsFor: 'convenience' stamp: ''!
put: object onStreamPretty: stream
	STON put: object asJsonOnStreamPretty: stream! !

!STONJSONTest commentStamp: ''!
STONJSONTests contains unit tests for the JSON functionality available in STON.!
!STONJSONTest methodsFor: 'tests' stamp: ''!
testBooleans
	self assert: (STONJSON toString: true) equals: 'true'.
	self assert: (STONJSON toString: false) equals: 'false'.
	self assert: (STONJSON fromString: 'true') equals: true.
	self assert: (STONJSON fromString: 'false') equals: false.! !

!STONJSONTest methodsFor: 'tests' stamp: ''!
testOrderedDictionary
	| odictClass odict json dict |
	odictClass := self environment at: #OrderedDictionary ifAbsent: [ ^ self skip ].

	odict := odictClass newFrom: {('a' -> 42) . ('b' -> 1) . ('aa' -> 4) . ('c' -> 23)}.

	"assert that the order is not equal in the dictionary hash table"
	self
		assertCollection: odict asArray hasSameElements: odict dictionary asArray;
		deny: odict asArray equals: odict dictionary asArray.

	"ordered presevered when encoding:"
	json := STONJSON toString: odict.
	self assert: json equals: '{"a":42,"b":1,"aa":4,"c":23}'.

	"lost when decoding"
	dict := STONJSON fromString: json.

	self
		assertCollection: dict asArray hasSameElements: odict asArray;
		assert: dict equals: odict dictionary;
		deny: dict asArray equals: odict asArray! !

!STONJSONTest methodsFor: 'accessing' stamp: ''!
environment
	^ Smalltalk globals! !

!STONJSONTest methodsFor: 'tests' stamp: ''!
testLists
	self assert: (STONJSON toString: #(1 2 3)) equals: '[1,2,3]'.
	self assert: (STONJSON toString: #(1 -2 true 3 nil)) equals: '[1,-2,true,3,null]'.
	self assert: (STONJSON toString: #(1 (2) 3)) equals: '[1,[2],3]'.
	self assert: (STONJSON toString: #()) equals: '[]'.
	self assert: (STONJSON fromString: '[]') equals: #().
	self assert: (STONJSON fromString: '[1,2,3]') equals: #(1 2 3).
	self assert: (STONJSON fromString: '[1,-2,true,3,null]') equals: #(1 -2 true 3 nil).
	self assert: (STONJSON fromString: '[1,[2],3]') equals: #(1 (2) 3).! !

!STONJSONTest methodsFor: 'tests' stamp: ''!
testStrings
	self assert: (STONJSON toString: 'string') equals: '"string"'.
	self assert: (STONJSON toString: '') equals: '""'.
	self assert: (STONJSON toString: 'élèves français') equals: '"élèves français"'.
	self assert: (STONJSON toString: String crlf) equals: '"\r\n"'.
	self assert: (STONJSON fromString: '"string"') equals: 'string'.
	self assert: (STONJSON fromString: '""') equals: ''.
	self assert: (STONJSON fromString: '"élèves français"') equals: 'élèves français'.
	self 
		assert: (STONJSON fromString: '"\u212B \"Angstrom Symbol\""') 
		equals: 8491 asCharacter asString, ' "Angstrom Symbol"'.! !

!STONJSONTest methodsFor: 'tests' stamp: ''!
testNull
	self assert: (STONJSON toString: nil) equals: 'null'.
	self assert: (STONJSON fromString: 'null') equals: nil.! !

!STONJSONTest methodsFor: 'tests' stamp: ''!
testUnknown
	"Only Array for lists and Dictionary for maps are allowed for JSON encoding,
	any other Smalltalk object cannot be encoded (following the specs).
	Even considering all collections to be lists won't work because the type 
	is then lost when decoding"
	
	self should: [ STONJSON toString: 1@2 ] raise: STONWriterError.
	self should: [ STONJSON toString: #(1 2 3) asOrderedCollection ] raise: STONWriterError.! !

!STONJSONTest methodsFor: 'tests' stamp: ''!
testMaps
	self assert: (STONJSON toString: { 'temperature'->37 } asDictionary) equals: '{"temperature":37}'.
	self assert: (STONJSON toString: Dictionary new) equals: '{}'.
	self assert: (STONJSON fromString: '{"temperature":37}') equals: { 'temperature'->37 } asDictionary.
	self assert: (STONJSON fromString: '{}') equals: Dictionary new.! !

!STONJSONTest methodsFor: 'tests' stamp: ''!
testCircular
	"Circular datastructures cannot be encoded using JSON"
	self
		should: [ | foo |
			foo := { 'foo'->'dummy' } asDictionary.
			foo at: 'bar' put: foo.
			STONJSON toString: foo ]
		raise: STONWriterError! !

!STONJSONTest methodsFor: 'tests' stamp: ''!
testShared
	"Structure sharing cannot be encoded using JSON"
	self
		should: [ | foo |
			foo := { 'foo'->'dummy' } asDictionary.
			STONJSON toString: { foo. foo } ]
		raise: STONWriterError! !

!STONJSONTest methodsFor: 'tests' stamp: ''!
testFloats
	self assert: (STONJSON toString: 1.0) equals: '1.0'.
	self assert: (STONJSON toString: 0.0) equals: '0.0'.
	self assert: (STONJSON toString: -1.0) equals: '-1.0'.
	self assert: (STONJSON toString: -1.23456e-6) equals: '-1.23456e-6'.
	self assert: ((STONJSON fromString: '1.0') closeTo: 1.0).
	self assert: ((STONJSON fromString: '0.0') closeTo: 0.0).
	self assert: ((STONJSON fromString: '-1.0') closeTo: -1.0).
	self assert: ((STONJSON fromString: '-1.23456e-6') closeTo: -1.23456e-6).! !

!STONJSONTest methodsFor: 'tests' stamp: ''!
testIntegers
	self assert: (STONJSON toString: 1) equals: '1'.
	self assert: (STONJSON toString: 0) equals: '0'.
	self assert: (STONJSON toString: -1) equals: '-1'.
	self assert: (STONJSON toString: 1234567890) equals: '1234567890'.
	self assert: (STONJSON fromString: '1') equals: 1.
	self assert: (STONJSON fromString: '0') equals: 0.
	self assert: (STONJSON fromString: '-1') equals: -1.
	self assert: (STONJSON fromString: '1234567890') equals: 1234567890.! !

!STONLargeWriteReadTest commentStamp: ''!
STONLargeWriteReadTests test the optimalizations for large structures.!
!STONLargeWriteReadTest methodsFor: 'private' stamp: ''!
reader: string
	^ (super reader: string) 
		optimizeForLargeStructures; 
		yourself! !

!STONLargeWriteReadTest methodsFor: 'private' stamp: ''!
serialize: anObject
	^ String streamContents: [ :stream |
		STON writer 
			on: stream; 
			optimizeForLargeStructures; 
			nextPut: anObject ]! !

!STONLargeWriteReadTest methodsFor: 'private' stamp: ''!
serializeJson: anObject
	^ String streamContents: [ :stream |
		STON jsonWriter 
			on: stream; 
			prettyPrint: true;
			optimizeForLargeStructures; 
			nextPut: anObject ]! !

!STONLargeWriteReadTest methodsFor: 'private' stamp: ''!
materialize: string
	^ STON reader
		on: string readStream;
		optimizeForLargeStructures;
		next! !

!STONListWriter commentStamp: ''!
STONArrayWriter helps in writing array based STON representations.
!
!STONListWriter methodsFor: 'accessing' stamp: ''!
add: anObject
	first ifTrue: [ first := false ] ifFalse: [ writer listElementSeparator ].
	writer nextPut: anObject! !

!STONMapWriter commentStamp: ''!
STONDictionaryWriter helps in writing dictionary based STON representations.!
!STONMapWriter methodsFor: 'accessing' stamp: ''!
at: key put: value
	first ifTrue: [ first := false ] ifFalse: [ writer mapElementSeparator ].
	writer encodeKey: key value: value! !

!STONReader commentStamp: ''!
STONReader materializes objects using the Smalltalk Object Notation format.

This parser is backwards compatible with standard JSON.

Customization options are:

- acceptUnknownClasses <Boolean> default is false
	if true, unknown class names are allowed, the standard #mapClass (Dictionary) is instanciated and the class name is added under #classNameKey (#className)
	if false, unknown class names result in a NotFound error
- convertNewLines <Boolean> default is false
	if true, any unescaped EOL sequence CR, LF or CRLF inside strings or symbols is read and converted as the chosen EOL sequence
	if false, CR, LF and CRLF are read unmodified
- newLine <String> default is String cr
	sequence to use as EOL!
!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseNumberFraction
	| number power |
	number := 0.
	power := 1.0.
	[ readStream atEnd not and: [ readStream peek isDigit ] ] whileTrue: [
		number := 10 * number + readStream next digitValue.
		power := power * 10.0 ].
	^ number / power! !

!STONReader methodsFor: 'initialize-release' stamp: ''!
newLine: string
	"Set the newline convention to be used when converting newlines, see #convertNewLines"
	
	newLine := string ! !

!STONReader methodsFor: 'private' stamp: ''!
expectChar: character
	"Expect character and consume input and optional whitespace at the end,
	 throw an error otherwise."

	(self matchChar: character)
		ifFalse: [ self error: character asString, ' expected' ]! !

!STONReader methodsFor: 'parsing' stamp: ''!
parseNamedInstVarsFor: anObject
	self parseMapDo: [ :instVarName :value |
		anObject instVarNamed: instVarName asString put: value ]! !

!STONReader methodsFor: 'private' stamp: ''!
parseTrailingSurrogateHexEscape
	(readStream next = $\ and: [ readStream next = $u ])
		ifTrue: [ ^ self parseCharacterHex4Value ]
		ifFalse: [ self error: 'trailing surrogate hex escape expected' ]! !

!STONReader methodsFor: 'private' stamp: ''!
parseCharacterHex4Value
	| value |
	value := self parseCharacterHexDigit.
	3 timesRepeat: [ 
		value := (value << 4) + self parseCharacterHexDigit ].
	^ value! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseString
	^ self parseStringInternal! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseNumberInteger
	| number |
	number := 0.
	[ readStream atEnd not and: [ readStream peek isDigit ] ] whileTrue: [ 
		number := 10 * number + readStream next digitValue ].
	^ number! !

!STONReader methodsFor: 'parsing' stamp: ''!
parseMap
	| map |
	map := STON mapClass new.
	self storeReference: map.
	self parseMapDo: [ :key :value |
		map at: key put: value ].
	^ map! !

!STONReader methodsFor: 'testing' stamp: ''!
atEnd
	^ readStream atEnd! !

!STONReader methodsFor: 'private' stamp: ''!
processSubObjectsOf: object
	| unresolvedReferencesCount |
	unresolvedReferencesCount := unresolvedReferences.
	object stonProcessSubObjects: [ :each | 
		each isStonReference
			ifTrue: [ self resolveReference: each ]
			ifFalse: [ 
				each stonContainSubObjects
					ifTrue: [ self processSubObjectsOf: each ]
					ifFalse: [ each ] ] ].
	unresolvedReferencesCount > unresolvedReferences
		ifTrue: [ object stonPostReferenceResolution ].
	^ object! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseNumber
	| negated number |
	negated := readStream peekFor: $-.
	number := self parseNumberInteger.
	(readStream peekFor: $/)
		ifTrue: [ 
			number := Fraction numerator: number denominator: self parseNumberInteger.
			(readStream peekFor: $s)
				ifTrue: [ number := ScaledDecimal newFromNumber: number scale: self parseNumberInteger ] ]
		ifFalse: [ 
			(readStream peekFor: $.)
				ifTrue: [ number := number + self parseNumberFraction ].
			((readStream peekFor: $e) or: [ readStream peekFor: $E ])
				ifTrue: [ number := number * self parseNumberExponent ] ].
	negated
		ifTrue: [ number := number negated ].
	self consumeWhitespace.
	^ number! !

!STONReader methodsFor: 'parsing' stamp: ''!
parseList
	| reference array |
	reference := self newReference.
	array := STON listClass streamContents: [ :stream |
		self parseListDo: [ :each | stream nextPut: each ] ].
	self setReference: reference to: array.
	^ array! !

!STONReader methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	objects := IdentityDictionary new.
	classes := IdentityDictionary new.
	acceptUnknownClasses := convertNewLines := false.
	newLine := String cr.
	unresolvedReferences := 0! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseSymbol
	| string |
	self expectChar: $#.
	readStream peek = $'
		ifTrue: [ ^ self parseStringInternal asSymbol ].
	string := self stringStreamContents: [ :stream |
		[ readStream atEnd not and: [ self isSimpleSymbolChar: readStream peek ] ] whileTrue: [
			stream nextPut: readStream next ] ].
	string isEmpty
		ifFalse: [ 
			self consumeWhitespace.
			^ string asSymbol ].
	self error: 'unexpected input'! !

!STONReader methodsFor: 'parsing' stamp: ''!
parseSimpleValue
	| char |
	readStream atEnd ifFalse: [ 
		(self isClassStartChar: (char := readStream peek)) 
			ifTrue: [ ^ self parseObject ].
		char = ${
			ifTrue: [ ^ self parseMap ].
		char = $[
			ifTrue: [ ^ self parseList ].
		(char = $' or: [ char = $" ])
			ifTrue: [ ^ self parseString ].
		char = $#
			ifTrue: [ ^ self parseSymbol ].
		char = $@
			ifTrue: [ ^ self parseReference ].
		(char = $- or: [ char isDigit ])
			ifTrue: [ ^ self parseNumber ].
		self parseConstantDo: [ :value | ^ value ] ].
	self error: 'invalid input'! !

!STONReader methodsFor: 'public' stamp: ''!
next
	| object |
	self consumeWhitespace.
	object := self parseValue.
	unresolvedReferences > 0
		ifTrue: [ self processSubObjectsOf: object ].
	unresolvedReferences = 0
		ifFalse: [ self error: 'Inconsistent reference resolution' ].
	^ object! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseCharacterHexDigit
	| digit |
	readStream atEnd ifFalse: [ 
		digit := readStream next asInteger.
		(digit between: "$0" 48 and: "$9" 57)
			ifTrue: [ ^ digit - 48 ].
		(digit between: "$A" 65 and: "$F" 70)
			ifTrue: [ ^ digit - 55 ].
		(digit between: "$a" 97 and: "$f" 102)
			ifTrue: [ ^ digit - 87 ] ].
	self error: 'hex-digit expected'! !

!STONReader methodsFor: 'private' stamp: ''!
stringStreamContents: block
	stringStream ifNil: [ 
		stringStream := (String new: 32) writeStream ].
	stringStream reset.
	block value: stringStream.
	^ stringStream contents! !

!STONReader methodsFor: 'initialize-release' stamp: ''!
acceptUnknownClasses: boolean
	acceptUnknownClasses := boolean! !

!STONReader methodsFor: 'private' stamp: ''!
consumeWhitespace
	"Strip whitespaces from the input stream."

	[ readStream atEnd not and: [ readStream peek isSeparator ] ]
		whileTrue: [ readStream next ]! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseCharacterConvertingNewLinesOn: writeStream
	| char |
	(char := readStream next) = $\
		ifTrue: [ writeStream nextPut: self parseEscapedCharacter ]
		ifFalse: [ 
			char = Character lf 
				ifTrue: [ writeStream nextPutAll: newLine ]
				ifFalse: [ 
					char = Character cr 
						ifTrue: [ 
							readStream peekFor: Character lf.
							writeStream nextPutAll: newLine ]
						ifFalse: [ writeStream nextPut: char ] ] ]! !

!STONReader methodsFor: 'private' stamp: ''!
isClassChar: char
	^ char isAlphaNumeric or: [ char = $_ ]! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseCharacter
	| char |
	^ (char := readStream next) = $\
		ifTrue: [ self parseEscapedCharacter ]
		ifFalse: [ char ]! !

!STONReader methodsFor: 'private' stamp: ''!
setReference: reference to: object
	objects at: reference index put: object! !

!STONReader methodsFor: 'parsing' stamp: ''!
parseObject
	| targetClass reference object |
	[
		reference := self newReference.
		targetClass := self parseClass.
		object := targetClass fromSton: self .
		self setReference: reference to: object ]
		on: NotFound 
		do: [ :notFound |
			acceptUnknownClasses 
				ifTrue: [ 
					object := STON mapClass new.
					self storeReference: object.
					self parseMapDo: [ :key :value |
						object at: key put: value ].
					object at: STON classNameKey put: notFound object ]
				ifFalse: [ self error: 'Cannot resolve class named ', notFound object printString ] ].
	^ object! !

!STONReader methodsFor: 'private' stamp: ''!
matchChar: character
	"Tries to match character, consume input and 
	answer true if successful and consumes whitespace at the end."

	^ (readStream peekFor: character)
		ifTrue: [ 
			self consumeWhitespace.
			true ]
		ifFalse: [ false ]! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseStringInternal
	| result delimiter |
	delimiter := readStream next.
	(delimiter = $' or: [ delimiter = $" ])
		ifFalse: [ self error: ''' or " expected' ].
	result := self
		stringStreamContents: [ :stream | 
			convertNewLines
				ifTrue: [ 
					[ readStream atEnd or: [ readStream peek = delimiter ] ] 
						whileFalse: [ self parseCharacterConvertingNewLinesOn: stream ] ]
				ifFalse: [ 
					[ readStream atEnd or: [ readStream peek = delimiter ] ] 
						whileFalse: [ stream nextPut: self parseCharacter ] ] ].
	self expectChar: delimiter.
	^ result! !

!STONReader methodsFor: 'parsing' stamp: ''!
parseValue
	| value |
	value := self parseSimpleValue.
	^ (self matchChar: $:)
		ifTrue: [ STON associationClass key: value value: self parseValue ]
		ifFalse: [ value ]! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseEscapedCharacter
	| char |
	char := readStream next.
	(#($' $" $/ $\) includes: char)
		ifTrue: [ ^ char ].
	char = $b
		ifTrue: [ ^ Character backspace ].
	char = $f
		ifTrue: [ ^ Character newPage ].
	char = $n
		ifTrue: [ ^ Character lf ].
	char = $r
		ifTrue: [ ^ Character cr ].
	char = $t
		ifTrue: [ ^ Character tab ].
	char = $u
		ifTrue: [ ^ self parseCharacterHex ].
	self error: 'invalid escape character \' , (String with: char).
	^ char! !

!STONReader methodsFor: 'initialize-release' stamp: ''!
optimizeForLargeStructures
	self class environment
		at: #FLLargeIdentityDictionary
		ifPresent: [ :identityDictionaryClass | objects := identityDictionaryClass new ]! !

!STONReader methodsFor: 'parsing' stamp: ''!
parseListDo: block
	| index |
	self expectChar: $[.
	(self matchChar: $]) ifTrue: [ ^ self ]. "short cut for empty lists"
	index := 1.
	[ readStream atEnd ] whileFalse: [
		block cull: self parseValue cull: index.
		(self matchChar: $]) ifTrue: [ ^ self ].
		index := index + 1.
		self expectChar: $, ].
	self error: 'end of list expected'! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseNumberExponent
	| number negated |
	number := 0.
	(negated := readStream peekFor: $-)
		ifFalse: [ readStream peekFor: $+ ].
	[ readStream atEnd not and: [ readStream peek isDigit ] ]
		whileTrue: [ number := 10 * number + readStream next digitValue ].
	negated
		ifTrue: [ number := number negated ].
	^ 10 raisedTo: number! !

!STONReader methodsFor: 'initialize-release' stamp: ''!
convertNewLines: boolean
	"When true, any newline CR, LF or CRLF read unescaped inside strings or symbols 
	will be converted to the newline convention chosen, see #newLine:
	The default is false, not doing any conversions."
	
	convertNewLines := boolean! !

!STONReader methodsFor: 'private' stamp: ''!
lookupClass: name
	"name is a symbol at this point"
	Smalltalk globals 
		at: name 
		ifPresent: [ :class | ^ class ].
	"note that classes is an identity dictionary"
	^ classes 
		at: name 
		ifAbsentPut: [
			Object allSubclasses 
				detect: [ :class | class isMeta not and: [ class stonName = name ]  ]
				ifNone: [ NotFound signalFor: name ] ]
	! !

!STONReader methodsFor: 'parsing' stamp: ''!
parseMapDo: block
	self expectChar: ${.
	(self matchChar: $}) ifTrue: [ ^ self ]. "short cut for empty maps"
	[ readStream atEnd ] whileFalse: [ | name value |
		name := self parseSimpleValue.
		self expectChar: $:.
		value := self parseValue.
		block value: name value: value.
		"The above is a more efficient way to say 'self parseValue' and using the returned association"
		(self matchChar: $}) ifTrue: [ ^ self ].
		self expectChar: $, ].
	self error: 'end of map expected'! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseReference
	| index |
	self expectChar: $@.
	index := self parseNumberInteger.
	self consumeWhitespace.
	unresolvedReferences := unresolvedReferences + 1.
	^ STONReference index: index! !

!STONReader methodsFor: 'private' stamp: ''!
resolveReferenceIndex: index
	^ objects at: index! !

!STONReader methodsFor: 'initialize-release' stamp: ''!
close
	readStream ifNotNil: [
		readStream close.
		readStream := nil ]! !

!STONReader methodsFor: 'private' stamp: ''!
isSimpleSymbolChar: char
	^char isLetter or: ['0123456789-_./' includes: char]! !

!STONReader methodsFor: 'initialize-release' stamp: ''!
allowComplexMapKeys: boolean
	"This is a no-op, this used to be an option, but it is now always enabled"! !

!STONReader methodsFor: 'private' stamp: ''!
parseCharacterHex
	| value codePoint |
	value := self parseCharacterHex4Value.
	(value < 16rD800 or: [ value > 16rDBFF ])
		ifTrue: [ codePoint := value ]
		ifFalse: [ | leadSurrogate trailSurrogate |
			"Characters not in the Basic Multilingual Plane are encoded as a UTF-16 surrogate pair"
			"See https://tools.ietf.org/html/rfc7159#section-7"
			leadSurrogate := value.
			trailSurrogate := self parseTrailingSurrogateHexEscape.
			codePoint := (leadSurrogate - 16rD800) * 16r400 + (trailSurrogate - 16rDC00).
			codePoint := 16r10000 + codePoint ].
	^ Character codePoint: codePoint! !

!STONReader methodsFor: 'initialize-release' stamp: ''!
reset
	unresolvedReferences := 0.
	objects removeAll! !

!STONReader methodsFor: 'parsing' stamp: ''!
parseMapOrListRepresentation
	"Parse either a map or list to be used as a representation, not considering it as a referenceable object"
	readStream atEnd 
		ifFalse: [ 
			readStream peek = ${
				ifTrue: [ | map |
					map := STON mapClass new.
					self parseMapDo: [ :key :value |
						map at: key put: value ].
					^ map ].
			readStream peek = $[
				ifTrue: [ 
					^ STON listClass streamContents: [ :stream |
						self parseListDo: [ :each | stream nextPut: each ] ] ] ].
	self error: 'invalid input'! !

!STONReader methodsFor: 'private' stamp: ''!
isClassStartChar: char
	^ char isLetter and: [ char isUppercase ]! !

!STONReader methodsFor: 'private' stamp: ''!
resolveReference: reference
	unresolvedReferences := unresolvedReferences - 1.
	^ self resolveReferenceIndex: reference index! !

!STONReader methodsFor: 'private' stamp: ''!
storeReference: object
	| index |
	index := objects size + 1.
	objects at: index put: object.
	^ index! !

!STONReader methodsFor: 'private' stamp: ''!
match: string do: block
	"Try to read and consume string and execute block if successful.
	Else do nothing (but do not back up)"

	(string allSatisfy: [ :each | readStream peekFor: each ])
		ifTrue: [ 
			self consumeWhitespace.
			block value ]! !

!STONReader methodsFor: 'error handling' stamp: ''!
error: aString
	| streamPosition |
	"Remain compatible with streams that don't understand #position"
	streamPosition := [ readStream position ]
		on: MessageNotUnderstood do: [ nil ].
	^ STONReaderError signal: aString streamPosition: streamPosition! !

!STONReader methodsFor: 'private' stamp: ''!
newReference
	| index reference |
	index := objects size + 1.
	reference := STONReference index: index.
	objects at: index put: reference.
	^ reference! !

!STONReader methodsFor: 'initialize-release' stamp: ''!
on: aReadStream
	readStream := aReadStream! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseConstantDo: block
	"Parse and consume either true|false|nil|null and execute block 
	or else do nothing (but do not back up).
	Hand written implementation to avoid the use of #position:"
	
	(readStream peek = $t)
		ifTrue: [
			^ self match: 'true' do: [ block value: true ] ].
	(readStream peek = $f)
		ifTrue: [
			^ self match: 'false' do: [ block value: false ] ].
	(readStream peek = $n)
		ifTrue: [
			readStream next.
			(readStream peek = $i)
				ifTrue: [
					self match: 'il' do: [ block value: nil ] ].
			(readStream peek = $u)
				ifTrue: [
					self match: 'ull' do: [ block value: nil ] ] ]		
! !

!STONReader methodsFor: 'parsing-internal' stamp: ''!
parseClass
	| className |
	className := self stringStreamContents: [ :stream |
		[ readStream atEnd not and: [ self isClassChar: readStream peek ] ] whileTrue: [ 
			stream nextPut: readStream next ] ].
	self consumeWhitespace.
	^ self lookupClass: className asSymbol
	! !

!STONReader methodsFor: 'parsing' stamp: ''!
parseListSingleton
	| value |
	value := nil.
	self parseListDo: [ :each :index |
		index = 1 ifTrue: [ value := each ] ].
	^ value! !

!STONReader class methodsFor: 'instance creation' stamp: ''!
on: readStream
	^ self new
		on: readStream;
		yourself! !

!STONReaderError commentStamp: ''!
STONReaderError is the error/exception signalled by STONReader when illegal/incorrect input is seen. 
!
!STONReaderError methodsFor: 'accessing' stamp: ''!
streamPosition
	^ streamPosition! !

!STONReaderError methodsFor: 'accessing' stamp: ''!
streamPosition: aNumber
	streamPosition := aNumber! !

!STONReaderError methodsFor: 'accessing' stamp: ''!
messageText
	^ streamPosition 
		ifNil: [ 
			super messageText ] 
		ifNotNil: [ :pos | 
			'At character <1P>: <2P>' expandMacrosWith: pos with: super messageText ]! !

!STONReaderError class methodsFor: 'instance creation' stamp: ''!
signal: aString streamPosition: streamPosition 
	^ self new
		streamPosition: streamPosition;
		signal: aString;
		yourself! !

!STONReaderTest commentStamp: ''!
STONReaderTests test materialization.
!
!STONReaderTest methodsFor: 'tests' stamp: ''!
testReferenceCycle
	| array |
	array := self materialize: '[1,@1]'.
	self assert: array class equals: STON listClass.
	self assert: array size equals: 2.
	self assert: array first equals: 1.
	self assert: array second identicalTo: array! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testIllegalCharacterEscapes
	self should: [ STON fromString: '''\a''' ] raise: STONReaderError.
	self should: [ STON fromString: '''\u''' ] raise: STONReaderError.
	self should: [ STON fromString: '''\u00''' ] raise: STONReaderError.
	self should: [ STON fromString: '''\u000''' ] raise: STONReaderError.
	self should: [ STON fromString: '''\*''' ] raise: STONReaderError! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testFileReferenceBackwardsCompatibility
	"we now have FILE, make sure that we support the old generic format"
	| fs |
	fs := STON toString: FileSystem disk.
	self 
		assert: (self materialize: 'FileReference{#path:RelativePath[],#filesystem:', fs, '}')
		equals: FileLocator workingDirectory.
	self 
		assert: (self materialize: 'FileReference{#path:RelativePath[],#filesystem:', fs, '}')
		equals: (self materialize: 'FILE[''.'']').
	self 
		assert: (self materialize: 'FileReference{#path:AbsolutePath[''tmp'',''foo.txt''],#filesystem:', fs, '}')
		equals: '/tmp/foo.txt' asFileReference.
	self 
		assert: (self materialize: 'FileReference{#path:AbsolutePath[''tmp'',''foo.txt''],#filesystem:', fs, '}')
		equals: (self materialize: 'FILE[''/tmp/foo.txt'']').! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testDictionaryWithComplexKeys
	| collection reader |
	collection := STON mapClass new
		at: true put: 1;
		at: #(foo) put: 2;
		yourself.
	"allowing complex map keys used to be optional, now it is always the default"
	reader := STONReader on: '{true:1,[#foo]:2}' readStream.
	self assert: reader next equals: collection! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testObject
	self assert: (self materialize: 'Point[1,2]') equals: 1 @ 2.
	self assert: (self materialize: 'Point[1.5,-0.5]') equals: 1.5 @ -0.5! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testScaledDecimal
	self assert: (self materialize: '1/3s2') equals: 1/3s2.
	self assert: (self materialize: '-1/3s2') equals: -1/3s2.
	self assert: (self materialize: '1/3s10') equals: 1/3s10.
	self assert: (self materialize: '-1/3s10') equals: -1/3s10.
! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testUnknownClasses
	| input object |
	input := 'FooBar { #foo : 1, #bar : true }'.
	self should: [ self materialize: input ] raise: STONReaderError.
	object := STON reader 
		acceptUnknownClasses: true; 
		on: input readStream; 
		next.
	self assert: object class equals: STON mapClass.
	self assert: (object at: #foo) equals: 1.
	self assert: (object at: #bar).
	self assert: (object at: STON classNameKey) equals: #FooBar! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testMultiple
	| reader |
	reader := STON reader 
		on: '123 -123 nil #foo true [ 0 ] false { #one : 1 }' readStream.
	self deny: reader atEnd.
	self assert: reader next equals: 123. 
	self assert: reader next equals: -123. 
	self assert: reader next equals: nil. 
	self assert: reader next equals: #foo. 
	self assert: reader next equals: true. 
	self assert: reader next equals: { 0 }. 
	self assert: reader next equals: false. 
	self assert: reader next equals: (Dictionary with: #one -> 1). 
	self assert: reader atEnd.
! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testFraction
	self assert: (self materialize: '1/3') equals: 1/3.
	self assert: (self materialize: '-1/3') equals: -1/3.
	self assert: (self materialize: '100/11') equals: 100/11.
! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testMap
	self
		assert: (self materialize: '{#foo:1}')
		equals:
			(STON mapClass new
				at: #foo put: 1;
				yourself).
	self assert: (self materialize: '{}') equals: STON mapClass new! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testTime
	| time |
	time := Time hour: 6 minute: 30 second: 15.
	self assert: (self materialize: 'Time[''06:30:15'']') equals: time.
	time := Time hour: 6 minute: 30 second: 15 nanoSecond: 123.
	self assert: (self materialize: 'Time[''06:30:15.000000123'']') equals: time.
! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testSetWithIndirectReferenceElements
	| elementsCollection set ston object |
	elementsCollection := OrderedCollection streamContents: [ :out |
		10 timesRepeat: [ out nextPut: UUID new ] ].
	set := Set withAll: (elementsCollection collect: [ :each | Array with: each ]).
	object := Array with: elementsCollection with: set.
	ston := STON toStringPretty: object.
	object := STON fromString: ston readStream.
	object first do: [ :each |
		self assert: (object second includes: (Array with: each)) ].
	self assert: object second isHealthy ! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testDictionaryWithIndirectReferenceKeys
	| keysCollection dictionary ston object |
	keysCollection := OrderedCollection streamContents: [ :out |
		10 timesRepeat: [ out nextPut: UUID new ] ].
	dictionary := Dictionary new.
	keysCollection doWithIndex: [ :each :index | 
		dictionary at: (Array with: each) put: index ].
	object := Array with: keysCollection with: dictionary.
	ston := STON toStringPretty: object.
	object := (STON reader on: ston readStream) next.
	object first doWithIndex: [ :each :index |
		self assert: (object second at: (Array with: each)) equals: index ].
	self assert: object second isHealthy ! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testConvertingNewLines
	| input result output |
	input := '''line ending with CR', String cr, 
		'line ending with LF', String lf, 
		'line ending with CRLF', String crlf, ''''.
	output := 'line ending with CR', String crlf, 
		'line ending with LF', String crlf, 
		'line ending with CRLF', String crlf.
	result := (STON reader on: input readStream) newLine: String crlf; convertNewLines: true; next.
	self assert: result equals: output.
	output := 'line ending with CR', String cr, 
		'line ending with LF', String cr, 
		'line ending with CRLF', String cr.
	result := (STON reader on: input readStream) newLine: String cr; convertNewLines: true; next.
	self assert: result equals: output! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testSymbol
	self assert: (self materialize: '#''foo''') identicalTo: #foo.
	self assert: (self materialize: '#foo') identicalTo: #foo! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testWhitespace
	| whitespace |
	whitespace := {Character space . Character tab . Character cr . Character lf}.
	self assert: (self materialize: whitespace , '123') equals: 123! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testNewSymbol
	| n notASymbol shouldBeSymbol |
	
	"Find a name that has not yet been interned"
	n := 0.
	[ Symbol hasInterned: (notASymbol := 'notASymbol', n printString) ifTrue: [ :symbol | symbol ] ] 
		whileTrue: [ n := n + 1 ].
	"Parsing the new, not yet interned name should create a new Symbol"
	shouldBeSymbol := self materialize: '#', notASymbol.
	self assert: (shouldBeSymbol isSymbol and: [ notASymbol = shouldBeSymbol asString ])
! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testPoint
	self assert: (self materialize: 'Point[1,2]') equals: 1 @ 2! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testUser2
	| user |
	(user := STONTestUser2 new)
		username: 'john@foo.com';
		password: 'secret1'.
	self assert: (self materialize: 'STONTestUser2{#username:''john@foo.com'',#password:''secret1'',#enabled:true}') equals: user! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testColorBackwardsCompatibility
	"ensure the older Color representation still works"
	self 
		assert: (self materialize: 'Color{#rgb:1072693248}')
		equals: Color red.
	self 
		assert: (self materialize: 'Color{#rgb:1072693248}')
		equals: (self materialize: 'Color[#red]').! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testDate
	| date |
	date := (Date year: 2012 month: 1 day: 1) translateToUTC.
	self assert: (self materialize: 'Date[''2012-01-01Z'']') equals: date.
	self assert: (self materialize: 'Date[''2012-01-01+00:00'']') equals: date.
	date := (Date year: 2012 month: 1 day: 1) translateTo: 1 hour.
	self assert: (self materialize: 'Date[''2012-01-01+01:00'']') equals: date.
	"a missing timezone offset results in the local timezone offset being used,
	this is never written by STON, but matches the first implementation for backwards compatibility"
	date := Date year: 2012 month: 1 day: 1.
	self assert: (self materialize: 'Date[''2012-01-01'']') equals: date.! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testColor
	self 
		assert: (self materialize: 'Color[#red]')
		equals: Color red.
	self 
		assert: (self materialize: 'Color{#red:1.0,#green:0.0,#blue:0.0,#alpha:0.4}')
		equals: (Color red copy setAlpha: 0.4).
	self 
		assert: (self materialize: 'Color{#red:1.0,#green:0.061,#blue:0.061,#alpha:1.0}')
		equals: Color red lighter lighter.! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testClass
	self assert: (self materialize: 'Class[#Point]') equals: Point! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testDictionaryWithReferenceKeys
	| keysCollection dictionary ston object |
	keysCollection := OrderedCollection streamContents: [ :out |
		10 timesRepeat: [ out nextPut: UUID new ] ].
	dictionary := Dictionary new.
	keysCollection doWithIndex: [ :each :index | 
		dictionary at: each put: index ].
	object := Array with: keysCollection with: dictionary.
	ston := STON toStringPretty: object.
	object := (STON reader on: ston readStream) next.
	object first doWithIndex: [ :each :index |
		self assert: (object second at: each) equals: index ].
	self assert: object second isHealthy ! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testUser
	| user |
	(user := STONTestUser new)
		username: 'john@foo.com';
		password: 'secret1'.
	self assert: (self materialize: 'STONTestUser{#username:''john@foo.com'',#password:''secret1'',#enabled:true}') equals: user! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testJsonString
	"Allow double quotes for backwards JSON compatibility"

	| string |
	self assert: (self materialize: '"foo"') equals: 'foo'.
	self assert: (self materialize: '"FOO"') equals: 'FOO'.
	self assert: (self materialize: '"\u00E9l\u00E8ve en Fran\u00E7ais"') equals: 'élève en Français'.
	string := String withAll: {$" . $' . $\ . Character tab . Character cr . Character lf . Character newPage . Character backspace}.
	self assert: (self materialize: '"\"\''\\\t\r\n\f\b"') equals: string! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testBoolean
	self assert: (self materialize: 'true') equals: true.
	self assert: (self materialize: 'false') equals: false! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testWideSymbol
	self assert: (self materialize: '#''яблоко''') identicalTo: #яблоко.
	self assert: (self materialize: '#яблоко') identicalTo: #яблоко! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testStreaming
	| reader |
	reader := STON reader 
		on: '1 2 3 4 5 6 7 8 9 10' readStream.
	self 
		assert: (Array streamContents: [ :stream |
			[ reader atEnd] whileFalse: [ 
				stream nextPut: reader next ] ]) sum
		equals: #(1 2 3 4 5 6 7 8 9 10) sum! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testInteger
	self assert: (self materialize: '1') equals: 1.
	self assert: (self materialize: '-1') equals: -1.
	self assert: (self materialize: '0') equals: 0.
	self assert: (self materialize: '1234567890') equals: 1234567890.
	self assert: (self materialize: '-1234567890') equals: -1234567890! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testString
	| string |
	self assert: (self materialize: '''foo''') equals: 'foo'.
	self assert: (self materialize: '''FOO''') equals: 'FOO'.
	self assert: (self materialize: '''\u00E9l\u00E8ve en Fran\u00E7ais''') equals: 'élève en Français'.
	string := String withAll: {$" . $' . $\ . $/ . Character tab . Character cr . Character lf . Character newPage . Character backspace}.
	self assert: (self materialize: '''\"\''\\\/\t\r\n\f\b''') equals: string! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testMimeType
	self 
		assert: (self materialize: 'MimeType[''application/json'']') 
		equals: ZnMimeType applicationJson.
	self 
		assert: (self materialize: 'MimeType[''text/plain;charset=utf-8'']') 
		equals: ZnMimeType textPlain.! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testURL
	self 
		assert: (self materialize: 'URL[''https://pharo.org/files/pharo.png'']') 
		equals: 'https://pharo.org/files/pharo.png' asUrl.
	self 
		assert: (self materialize: 'URL[''mailto:sven@stfx.eu'']') 
		equals: 'mailto:sven@stfx.eu' asUrl.
	self 
		assert: (self materialize: 'URL[''file:///var/log/system.log'']') 
		equals: 'file:///var/log/system.log' asUrl.
	self 
		assert: (self materialize: 'URL[''scheme://user:password@host:123/var/log/system.log?foo=1&bar#frag'']') 
		equals: 'scheme://user:password@host:123/var/log/system.log?foo=1&bar#frag' asUrl.! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testIdentityDictionary
	| collection |
	collection := IdentityDictionary new
		at: 1 put: 1;
		at: 2 put: 2;
		yourself.
	self assert: (self materialize: 'IdentityDictionary{1:1,2:2}') equals: collection.
	self assert: (self materialize: 'IdentityDictionary{}') equals: IdentityDictionary new! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testCharacter
	self assert: (self materialize: 'Character[''A'']') identicalTo: $A! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testZnUrlBackwardsCompatibility
	"We now have URL, make sure we still support the old format"
	self 
		assert: (self materialize: 'ZnUrl{#scheme:#https,#host:''pharo.org'',#segments:OrderedCollection[''files'', ''pharo.png'']}') 
		equals: 'https://pharo.org/files/pharo.png' asUrl.
	self 
		assert: (self materialize: 'ZnUrl{#scheme:#file,#segments:OrderedCollection[''tmp'', ''foo.txt'']}') 
		equals: 'file:///tmp/foo.txt' asUrl.! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testAssociation
	self assert: (self materialize: '''foo'':1') equals: 'foo' -> 1.
	self assert: (self materialize: '#bar:2') equals: #bar -> 2.
	self assert: (self materialize: '''foo bar'':#ok') equals: 'foo bar' -> #ok.
	self assert: (self materialize: '123:456') equals: 123 -> 456.

	self assert: (self materialize: '''foo'' : 1') equals: 'foo' -> 1.
	self assert: (self materialize: '#bar : 2') equals: #bar -> 2.
	self assert: (self materialize: '''foo bar'' : #ok') equals: 'foo bar' -> #ok.
	self assert: (self materialize: '123 : -456') equals: 123 -> -456.

	self assert: (self materialize: '#foo : 1 : 2') equals: #foo -> (1 -> 2)! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testDiskFile
	self assert: (self materialize: 'FILE[''foo.txt'']') equals: 'foo.txt' asFileReference.
	self assert: (self materialize: 'FILE[''/tmp/foo.txt'']') equals: '/tmp/foo.txt' asFileReference.
	self assert: (self materialize: 'FILE[''tmp/foo.txt'']') equals: 'tmp/foo.txt' asFileReference.
	self assert: (self materialize: 'FILE[''/tmp'']') equals: '/tmp' asFileReference.! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testOrderedCollection
	| collection |
	collection := OrderedCollection with: 1 with: 2 with: 3.
	self assert: (self materialize: 'OrderedCollection[1,2,3]') equals: collection.
	self assert: (self materialize: 'OrderedCollection[]') equals: OrderedCollection new! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testByteArray
	self assert: (self materialize: 'ByteArray[''010203'']') equals: #(1 2 3) asByteArray! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testReferenceSharing
	| one array |
	one := {#one}.
	array := self materialize: '[[#one],@2,@2]'.
	self assert: array equals: (STON listClass with: one with: one with: one).
	self assert: array first identicalTo: array second.
	self assert: array first identicalTo: array third! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testError
	#( 'foo' '{foo:}' '{foo,}' '[1,]' '+1' ']' '#' '' '  ' '	' 'nul' 'tru' 'fals' ) do: [ :each |
		self 
			should: [ self materialize: each ] 
			raise: STONReaderError ]
! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testFloat
	self assert: ((self materialize: '1.5') closeTo: 1.5).
	self assert: ((self materialize: '-1.5') closeTo: -1.5).
	self assert: (self materialize: '0.0') isZero.
	self assert: (Float pi closeTo: (self materialize: '3.14149')).
	self assert: (1/3 closeTo: (self materialize: '0.333333')).
	self assert: ((self materialize: '1.0e100') closeTo: (10 raisedTo: 100)).
	self assert: ((self materialize: '1.0e-100') closeTo: (10 raisedTo: -100)).
	self assert: ((self materialize: '-1.0e-100') closeTo: (10 raisedTo: -100) negated)! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testDateAndTime
	| dateAndTime |
	dateAndTime := DateAndTime
		year: 2012
		month: 1
		day: 1
		hour: 6
		minute: 30
		second: 15
		offset: 1 hour.
	self assert: (self materialize: 'DateAndTime[''2012-01-01T06:30:15+01:00'']') equals: dateAndTime! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testDictionary
	| collection |
	collection := STON mapClass new
		at: 1 put: 1;
		at: 2 put: 2;
		yourself.
	self assert: (self materialize: '{1:1,2:2}') equals: collection.
	self assert: (self materialize: '{}') equals: STON mapClass new! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testNonBMPCharacterDecoding
	"Characters not in the Basic Multilingual Plane are encoded as a UTF-16 surrogate pair"

	| string object |
	string := String with: 16r1D11E asCharacter. "MUSICAL SYMBOL G CLEF"
	object := (STON fromString: '''\uD834\uDD1E''').
	self assert: object equals: string! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testList
	self assert: STON listClass equals: Array.
	self assert: (self materialize: '[1,2,3]') equals: (STON listClass with: 1 with: 2 with: 3).
	self assert: (self materialize: '[]') equals: STON listClass new! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testNil
	self assert: (self materialize: 'nil') isNil! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testSetWithReferenceElements
	| elementsCollection set ston object |
	elementsCollection := OrderedCollection streamContents: [ :out |
		10 timesRepeat: [ out nextPut: UUID new ] ].
	set := Set withAll: elementsCollection.
	object := Array with: elementsCollection with: set.
	ston := STON toStringPretty: object.
	object := STON fromString: ston readStream.
	object first do: [ :each |
		self assert: (object second includes: each) ].
	self assert: object second isHealthy ! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testNull
	self assert: (self materialize: 'null') isNil! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testDeepStructure
	| holder deepest structure writer ston reader result |
	"Create a deep nested structure so that the deepest element is a reference back to a top level holder."
	holder := Array with: 42.
	deepest := Array with: holder.
	structure := deepest.
	1 * 1024 timesRepeat: [ structure := Array with: structure ].
	structure := Array with: holder with: structure.
	writer := STON writer optimizeForLargeStructures.
	ston := String streamContents: [ :out | (writer on: out) nextPut: structure ].
	"After reading, the second pass will have to go down the structure to resolve the reference."
	reader := STON reader optimizeForLargeStructures.
	result := (reader on: ston readStream) next.
	self assert: result equals: structure! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testMetaclass
	self assert: (self materialize: 'Metaclass[#Point]') equals: Point class! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testBag
	self 
		assert: (self materialize: 'Bag{#a:2,#b:3}') 
		equals: (Bag withAll: #(a a b b b)).
	self 
		assert: (self materialize: 'Bag{}') 
		equals: Bag new.
! !

!STONReaderTest methodsFor: 'tests' stamp: ''!
testClassWithUnderscore

	| cls data reader |

	cls := Object newAnonymousSubclass.
	cls setName: #A_B_C123AnonClass.

	data := STON toString: cls new.
	reader := STONReader on: data readStream.

	(reader instVarNamed: #classes) 
		at: cls name 
		put: cls.

	self assert: reader next class equals: cls! !

!STONReaderTest methodsFor: 'private' stamp: ''!
materialize: string
	^ STON reader 
		on: string readStream;
		next! !

!STONReference commentStamp: ''!
STONReference holds a forward reference to another object during materialization.
!
!STONReference methodsFor: 'comparing' stamp: ''!
= anObject
	^ self class == anObject class and: [ self index = anObject index ]! !

!STONReference methodsFor: 'comparing' stamp: ''!
hash
	^ index hash! !

!STONReference methodsFor: 'testing' stamp: ''!
isStonReference
	^ true! !

!STONReference methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(; print: index; nextPut: $)! !

!STONReference methodsFor: 'accessing' stamp: ''!
index: integer
	index := integer! !

!STONReference methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!STONReference class methodsFor: 'instance creation' stamp: ''!
index: integer
	^ self new
		index: integer;
		yourself! !

!STONShortListWriter commentStamp: ''!
STONShortArrayWriter helps in writing short array based STON representations.
!
!STONShortListWriter methodsFor: 'accessing' stamp: ''!
add: anObject
	first ifTrue: [ first := false ] ifFalse: [ writer shortListElementSeparator ].
	writer nextPut: anObject! !

!STONStreamWriter commentStamp: ''!
STONStreamWriter helps in streaming writing STON representations.
This is an abstract class.!
!STONStreamWriter methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	first := true! !

!STONStreamWriter methodsFor: 'initialize-release' stamp: ''!
on: stonWriter
	writer := stonWriter! !

!STONStreamWriter class methodsFor: 'instance creation' stamp: ''!
on: stonWriter
	^ self new
		on: stonWriter;
		yourself! !

!STONTest commentStamp: ''!
STONTests tests the API offered by STON.
!
!STONTest methodsFor: 'tests' stamp: ''!
testFromString
	| object |
	object := STON listClass withAll: {1 . 0 . -1 . true . false . nil}.
	self assert: (STON fromString: '[1,0,-1,true,false,nil]') equals: object! !

!STONTest methodsFor: 'tests' stamp: ''!
testFromStringWithComments
	| object |
	object := STON listClass withAll: { 1. 0. -1. true. false. nil }.
	self 
		assert: (STON fromStringWithComments: '// comment\[1, /* comment */ 0, -1, true, false, nil] // comment' withCRs)
		equals: object! !

!STONTest methodsFor: 'tests' stamp: ''!
testToString
	| object |
	object := STON listClass withAll: {1 . 0 . -1 . true . false . nil}.
	self assert: (STON toString: object) equals: '[1,0,-1,true,false,nil]'! !

!STONTest methodsFor: 'tests' stamp: ''!
testPrettyPrinting
	| object |
	object := STONTestUser dummy.
	self assert: (STON fromString: (STON toStringPretty: object)) equals: object.
	object := STONTestDomainObject dummy.
	self assert: (STON fromString: (STON toStringPretty: object)) equals: object! !

!STONTest methodsFor: 'tests' stamp: ''!
testRoomExitCycles
	| model room1 room2 exit1 exit2 ston object |
	(room1 := STONTestMap new) at: #name put: 'Room 1'.
	(room2 := STONTestMap new) at: #name put: 'Room 2'.
	(exit1 := STONTestMap new)
		at: #name put: 'Exit 1';
		at: #origin put: room1;
		at: #destination put: room2.
	(exit2 := STONTestMap new)
		at: #name put: 'Exit 2';
		at: #origin put: room2;
		at: #destination put: room1.
	room1 at: #exit put: exit1.
	room2 at: #exit put: exit2.
	model := Array with: room1 with: room2.
	ston := STON toString: model.
	object := STON fromString: ston.
	"We can't just compare because this is a recursive datastructure"
	self assert: (object first at: #name) equals: 'Room 1'.
	self assert: (object second at: #name) equals: 'Room 2'.
	self assert: ((object first at: #exit) at: #name) equals: 'Exit 1'.
	self assert: ((object second at: #exit) at: #name) equals: 'Exit 2'.
	self assert: ((object first at: #exit) at: #origin) identicalTo: object first.
	self assert: ((object first at: #exit) at: #destination) identicalTo: object second.
	self assert: ((object second at: #exit) at: #origin) identicalTo: object second.
	self assert: ((object second at: #exit) at: #destination) identicalTo: object first.
	"Try writing again the parse model"
	self assert: (STON toString: object) equals: ston! !

!STONTest class methodsFor: 'utilities' stamp: ''!
fastWrite: object toFileNamed: path
	^ path asFileReference
		writeStreamDo: [ :fileStream | 
			ZnBufferedWriteStream
				on: fileStream
				do: [ :stream | 
					STON writer
						on: stream;
						optimizeForLargeStructures;
						nextPut: object ] ]! !

!STONTest class methodsFor: 'utilities' stamp: ''!
readFromFileNamed: path
	^ path asFileReference
		readStreamDo: [ :stream | 
			STON reader
				on: stream;
				next ]! !

!STONTest class methodsFor: 'utilities' stamp: ''!
fastReadFromFileNamed: path
	^ path asFileReference
		readStreamDo: [ :stream | 
			STON reader
				on: (ZnBufferedReadStream on: stream);
				optimizeForLargeStructures;
				next ]! !

!STONTest class methodsFor: 'utilities' stamp: ''!
write: object toFileNamed: path
	^ path asFileReference
		writeStreamDo: [ :stream | 
			STON writer
				on: stream;
				nextPut: object ]! !

!STONTestAssociation commentStamp: ''!
STONTestAssociation is used to support unit tests.
!
!STONTestAssociation methodsFor: 'accessing' stamp: ''!
value: anObject
	super value: anObject.
	timestamp := self now! !

!STONTestAssociation methodsFor: 'accessing' stamp: ''!
key: aKey value: anObject 
	super key: aKey value: anObject.
	timestamp := self now! !

!STONTestAssociation methodsFor: 'accessing' stamp: ''!
now
	^ DateAndTime now! !

!STONTestAssociation methodsFor: 'accessing' stamp: ''!
timestamp
	^ timestamp! !

!STONTestDomainObject commentStamp: ''!
STONTestDomainObject is used to support unit tests.

Instance Variables
	boolean:		<Boolean>
	bytes:			<ByteArray>
	color:			<Symbol>
	created:		<DateAndTime>
	description:	<String>
	float:			<Float>
	integer:		<Integer>
	modified:	<DateAndTime>
	tags:			<Array of: Symbol>!
!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
color: anObject
	color := anObject! !

!STONTestDomainObject methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ color = anObject color
		and: [ 
			modified = anObject modified
				and: [ 
					created = anObject created
						and: [ 
							description = anObject description
								and: [ 
									boolean = anObject boolean
										and: [ 
											(float closeTo: anObject float) 		"Use #closeTo: instead of #= to increase portability"
												and: [ 
													bytes = anObject bytes 
														and: [ 
															integer = anObject integer 
																and: [ tags = anObject tags ] ] ] ] ] ] ] ]
! !

!STONTestDomainObject methodsFor: 'initialize-release' stamp: ''!
initialize
	created := modified := DateAndTime now.! !

!STONTestDomainObject methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ color hash
		bitXor:
			(modified hash
				bitXor:
					(created hash
						bitXor:
							(description hash
								bitXor: (boolean hash bitXor: (float hash bitXor: (bytes hash bitXor: (integer hash bitXor: tags hash)))))))! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
integer: anObject
	integer := anObject! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
description: anObject
	description := anObject! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
boolean
	^ boolean! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
created: anObject
	created := anObject! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
description
	^ description! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
float
	^ float! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
boolean: anObject
	boolean := anObject! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
modified
	^ modified! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
bytes: anObject
	bytes := anObject! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
tags
	^ tags! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
integer
	^ integer! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
tags: anObject
	tags := anObject! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
modified: anObject
	modified := anObject! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
bytes
	^ bytes! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
created
	^ created! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
float: anObject
	float := anObject! !

!STONTestDomainObject methodsFor: 'accessing' stamp: ''!
color
	^ color! !

!STONTestDomainObject class methodsFor: 'ston-core' stamp: ''!
stonName
	^ #TestDomainObject! !

!STONTestDomainObject class methodsFor: 'instance creation' stamp: ''!
dummy
	^ self new
		integer: 999999 atRandom;
		float: 999 atRandom / Float pi;
		boolean: #(true false) atRandom;
		bytes: (ByteArray streamContents: [ :out | 32 timesRepeat: [ out nextPut: 255 atRandom ] ]);
		description: (String streamContents: [ :out | 16 atRandom timesRepeat: [ out nextPutAll: 'Blah' ] ]);
		color: #(#red #green #blue) atRandom;
		tags: (Array 
			with: #(#one #two #three) atRandom
 			with: #(#alpha #beta #gamma) atRandom 
			with: #(#low #medium #high) atRandom);
		yourself
! !

!STONTestKnownObject commentStamp: ''!
I am STONTestKnownObject. I support unit tests.

I have an id and a description.

When I am serialized, only my id is written out.

  STONTestKnownObject['bb71b026-180c-0d00-b40c-38700aee7555']

When I am materialized, the id is used to reconstruct the object, either by retrieving it from a collection of known objects, or it is created (it could also be a retrieval from somewhere else).

I keep a collection of all my known instances, new instances are added to it automatically.

Use my class side's #fromId: to access existing instances!
!STONTestKnownObject methodsFor: 'comparing' stamp: ''!
= object
	self class == object class ifFalse: [ ^ false ].
	^ self id = object id! !

!STONTestKnownObject methodsFor: 'initalize' stamp: ''!
initialize
	super initialize.
	self id: UUID new.
	self class addKnownObject: self! !

!STONTestKnownObject methodsFor: 'comparing' stamp: ''!
hash
	^ self id hash! !

!STONTestKnownObject methodsFor: 'initalize' stamp: ''!
id: uuid
	id := uuid.
	self description: 'I am a complex object known under the ID ', id asString, ' - I was created @ ', DateAndTime now asString! !

!STONTestKnownObject methodsFor: 'initalize' stamp: ''!
description: string
	description := string! !

!STONTestKnownObject methodsFor: 'accessing' stamp: ''!
description
	^ description! !

!STONTestKnownObject methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(; print: id; nextPut: $)! !

!STONTestKnownObject methodsFor: 'ston-core' stamp: ''!
stonOn: stonWriter
	"We only write out our id"
	
	stonWriter writeObject: self listSingleton: self id asString! !

!STONTestKnownObject methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!STONTestKnownObject class methodsFor: 'instance creation' stamp: ''!
fromId: idString
	"Given id, return a matching instance of me, either by returning an existing known instance or by creating a new one (that is automatically added to the known instances)"
	
	| uuid |
	uuid := UUID fromString: idString.
	^ self knownObjects 
		detect: [ :each | each id = uuid ] 
		ifNone: [ self new id: uuid ]! !

!STONTestKnownObject class methodsFor: 'accessing' stamp: ''!
knownObjects
	^ KnownObjects ifNil: [ KnownObjects := OrderedCollection new ]! !

!STONTestKnownObject class methodsFor: 'accessing' stamp: ''!
addKnownObject: object
	^ self knownObjects addIfNotPresent: object! !

!STONTestKnownObject class methodsFor: 'ston-core' stamp: ''!
fromSton: stonReader
	^ self fromId: stonReader parseListSingleton! !

!STONTestKnownObject class methodsFor: 'accessing' stamp: ''!
resetKnownObjects
	KnownObjects ifNotNil: [ :collection | collection removeAll ]! !

!STONTestMap commentStamp: ''!
STONTestMap is used to support unit tests.

I am a Dictionary but I don't print my elements during #printOn: to allow safe inspection of structures containing cycles that would otherwise lead to infinite loops.!
!STONTestMap methodsFor: 'printing' stamp: ''!
printElementsOn: stream
	stream
		nextPut: $(;
		nextPut: $#;
		print: self size;
		nextPut: $)! !

!STONTestMap class methodsFor: 'instance creation' stamp: ''!
classTreeExtended
	^ self classTreeExtended: Object! !

!STONTestMap class methodsFor: 'instance creation' stamp: ''!
classTree
	^ self classTree: Object! !

!STONTestMap class methodsFor: 'ston-core' stamp: ''!
stonName
	^ #TestMap! !

!STONTestMap class methodsFor: 'instance creation' stamp: ''!
classTree: topClass
	| map |
	map := IdentityDictionary new.
	topClass withAllSubclasses do: [ :eachClass | | info |
		(info := self new)
			at: #name put: eachClass name asString;
			at: #comment put: eachClass comment;
			at: #isMeta put: eachClass isMeta;
			at: #methods put: eachClass selectors.		
		map at: eachClass put: info ].
	map keysAndValuesDo: [ :eachClass :eachInfo |
		eachClass == topClass
			ifFalse: [ eachInfo at: #superclass put: (map at: eachClass superclass) ].
		eachInfo at: #subclasses put: (eachClass subclasses collect: [ :subClass | map at: subClass ]) ].
	^ map at: topClass! !

!STONTestMap class methodsFor: 'instance creation' stamp: ''!
classTreeExtended: topClass
	| map |
	map := IdentityDictionary new.
	topClass withAllSubclasses do: [ :eachClass | | info methodsInfo |
		(info := self new)
			at: #name put: eachClass name asString;
			at: #comment put: eachClass comment;
			at: #isMeta put: eachClass isMeta;
			at: #methods put: (methodsInfo := self new).
		eachClass methods do: [ :eachMethod | | methodInfo |
			(methodInfo := self new)
				at: #name put: eachMethod selector;
				at: #numArgs put: eachMethod numArgs;
				at: #class put: info.
			methodsInfo at: eachMethod selector put: methodInfo ].
		map at: eachClass put: info ].
	map keysAndValuesDo: [ :eachClass :eachInfo |
		eachClass == topClass 
			ifFalse: [ eachInfo at: #superclass put: (map at: eachClass superclass) ].
		eachInfo at: #subclasses put: (eachClass subclasses collect: [ :subClass | map at: subClass ]) ].
	^ map at: topClass! !

!STONTestUser commentStamp: ''!
STONTestUser is used to support unit tests.

Instance Variables
	enabled:		<Boolean>
	password:	<String>
	username:	<String>
!
!STONTestUser methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ username = anObject username and: [ password = anObject password and: [ enabled = anObject enabled ] ]! !

!STONTestUser methodsFor: 'initialize-release' stamp: ''!
initialize 
	super initialize.
	enabled := true! !

!STONTestUser methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ username hash bitXor: (password hash bitXor: enabled hash)! !

!STONTestUser methodsFor: 'accessing' stamp: ''!
password: anObject
	password := anObject! !

!STONTestUser methodsFor: 'accessing' stamp: ''!
password
	^ password! !

!STONTestUser methodsFor: 'accessing' stamp: ''!
enabled
	^ enabled! !

!STONTestUser methodsFor: 'accessing' stamp: ''!
username: anObject
	username := anObject! !

!STONTestUser methodsFor: 'accessing' stamp: ''!
enabled: anObject
	enabled := anObject! !

!STONTestUser methodsFor: 'accessing' stamp: ''!
username
	^ username! !

!STONTestUser class methodsFor: 'ston-core' stamp: ''!
stonName
	^ #TestUser! !

!STONTestUser class methodsFor: 'instance creation' stamp: ''!
dummy
	"self dummy"
	
	| username password |
	username := String streamContents: [ :stream |
		stream << 'user'; print: 999 atRandom; << '@company'; print: 99 atRandom; << '.com' ].
	password := String streamContents: [ :stream |
		stream << 'secret'; print: 999 atRandom ].
	^ self new
		username: username;
		password: password;
		yourself! !

!STONTestUser2 commentStamp: ''!
STONTestUser2 extends STONTestUser with explicit implementations of #fromSton: and #stonOn:!
!STONTestUser2 methodsFor: 'ston-core' stamp: ''!
fromSton: stonReader
	stonReader parseMapDo: [ :key :value |
		key = #username ifTrue: [ username := value ].
		key = #password ifTrue: [ password := value ].
		key = #enabled ifTrue: [ enabled := value ] ]
	! !

!STONTestUser2 methodsFor: 'ston-core' stamp: ''!
stonOn: stonWriter	
	stonWriter writeObject: self streamMap: [ :dictionary |
		dictionary
			at: #username put: username;
			at: #password put: password;
			at: #enabled put: enabled ]! !

!STONTestUser2 class methodsFor: 'ston-core' stamp: ''!
stonName
	^ #TestUser2! !

!STONTestUser3 commentStamp: ''!
STONTestUser3 extends STONTestUser but wants nil instance variables to be written!
!STONTestUser3 methodsFor: 'ston-core' stamp: ''!
stonShouldWriteNilInstVars
	^ true! !

!STONTestUser3 class methodsFor: 'ston-core' stamp: ''!
stonName
	^ #TestUser3! !

!STONTestUser3 class methodsFor: 'ston-core' stamp: ''!
stonAllInstVarNames
	^ #(username password enabled)! !

!STONWriteAsciiOnlyReadTest methodsFor: 'private' stamp: ''!
serialize: anObject
	^ String streamContents: [ :stream |
		STON writer 
			on: stream; 
			asciiOnly: true;
			nextPut: anObject ]! !

!STONWriteAsciiOnlyReadTest methodsFor: 'private' stamp: ''!
serializeJson: anObject
	^ String streamContents: [ :stream |
		STON jsonWriter 
			on: stream; 
			asciiOnly: true;
			nextPut: anObject ]! !

!STONWritePrettyPrinterReadTest commentStamp: ''!
STONWritePrettyPrinterReadTests tests pretty printed serialization followed by materialization.!
!STONWritePrettyPrinterReadTest methodsFor: 'private' stamp: ''!
serialize: anObject
	^ String streamContents: [ :stream |
		STON writer 
			on: stream; 
			prettyPrint: true;
			nextPut: anObject ]! !

!STONWritePrettyPrinterReadTest methodsFor: 'private' stamp: ''!
serializeJson: anObject
	^ String streamContents: [ :stream |
		STON jsonWriter 
			on: stream; 
			prettyPrint: true;
			nextPut: anObject ]! !

!STONWriteReadCommentsTest methodsFor: 'private' stamp: ''!
reader: string
	^ STON reader
		on: (STONCStyleCommentsSkipStream on: string readStream);
		yourself! !

!STONWriteReadCommentsTest methodsFor: 'private' stamp: ''!
serialize: anObject
	^ String streamContents: [ :stream |
		stream << '/* initial comment */'.
		STON writer 
			on: stream;
			nextPut: anObject.
		stream << '/* final comment */' ]! !

!STONWriteReadCommentsTest methodsFor: 'private' stamp: ''!
materialize: string
	^ STON reader
		on: (STONCStyleCommentsSkipStream on: string readStream);
		optimizeForLargeStructures;
		next! !

!STONWriteReadTest commentStamp: ''!
STONWriteReadTests test serialization followed by materialization, these tests first write then read STON.!
!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testColors
	| colors |
	colors := STON listClass withAll: { 
		Color red.
		Color red copy setAlpha: 0.4.
		Color red lighter lighter }.
	self serializeAndMaterialize: colors
! !

!STONWriteReadTest methodsFor: 'options' stamp: ''!
reader: string
	^ STON reader on: string readStream! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testDiskFiles
	| diskFiles |
	diskFiles := STON listClass withAll: { 
		FileLocator image asFileReference.
		FileLocator workingDirectory asAbsolute.
		'foo/bar/readme.txt' asFileReference.
		'./readme.txt' asFileReference.
		(FileLocator home / 'foo.txt') asFileReference }.
	self serializeAndMaterialize: diskFiles
! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testTextAndRunArray
	| texts |
	texts := { 
		'Text!!' asText. 
		(Text string: 'I am bold' attribute: TextEmphasis bold), ' and I am normal text'.
		Text new }.
	self serializeAndMaterialize: texts! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testUser
	| user users |
	user := STONTestUser dummy.
	self serializeAndMaterialize: user.
	users := STON listClass streamContents: [ :stream |
		10 timesRepeat: [ stream nextPut: STONTestUser dummy ] ].
	self serializeAndMaterialize: users.
	users := STON mapClass new.
	10 timesRepeat: [ | newUser |
		newUser := STONTestUser dummy.
		users at: newUser username put: newUser ].
	self serializeAndMaterialize: users.! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testFractions
	| fractions |
	fractions := STON listClass withAll: (-2/3 to: 2/3 by: 1/3).
	self serializeAndMaterialize: fractions! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testIdentityCollections
	| collections |
	collections := STON listClass withAll: {
		IdentitySet withAll: #(1 2 3).
		IdentityDictionary new at: 1 put: 1; at: 2 put: 2; yourself.
		IdentityBag withAll: { #A. #B. #A. #B. #A } }.
	self serializeAndMaterialize: collections! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testDomainObject
	| object objects |
	object := STONTestDomainObject dummy.
	self serializeAndMaterialize: object.
	objects := STON listClass streamContents: [ :stream |
		10 timesRepeat: [ stream nextPut: STONTestDomainObject dummy ] ].
	self serializeAndMaterialize: objects.
	objects := STON mapClass new.
	10 timesRepeat: [ | newObject |
		newObject := STONTestDomainObject dummy.
		objects at: newObject integer put: newObject ].
	self serializeAndMaterialize: objects.! !

!STONWriteReadTest methodsFor: 'private' stamp: ''!
environment
	^ Smalltalk globals! !

!STONWriteReadTest methodsFor: 'private' stamp: ''!
serializeAndMaterialize: object
	| serialization materialization |
	serialization := self serialize: object.
	materialization := self materialize: serialization.
	self assert: object equals: materialization
	! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testEmpty
	| empty |
	empty := STON listClass new.
	self serializeAndMaterialize: empty.
	empty := STON mapClass new.
	self serializeAndMaterialize: empty.! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testJsonMode
	| object |
	object := STON listClass withAll: {
		Float pi.
		'Hello World'.
		true.
		nil.
		STON listClass withAll: #( 1 2 3) asByteArray.
		STON mapClass new 
			at: 'x' put: 1; 
			at: 'y' put: 2; 
			yourself 
	}.
	self serializeAndMaterializeJsonMode: object
! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testOrderedDictionary
	"OrderedDictionary is special because it does not inherit from Dictionary.
	It might also not exist in some dialects, where this test could be skipped."
	
	| dictionaries orderedDictionaryClass orderedIdentityDictionaryClass |
	orderedDictionaryClass := self environment at: #OrderedDictionary ifAbsent: [ Dictionary ].
	orderedIdentityDictionaryClass := self environment at: #OrderedIdentityDictionary ifAbsent: [ IdentityDictionary ].
	dictionaries := STON listClass withAll: {
		orderedDictionaryClass new at: 1 put: 1; at: 2 put: 2; yourself.
		orderedDictionaryClass new at: #a put: 1; at: #b put: -2; at: #c put: 0; yourself.
		orderedDictionaryClass new.
		orderedIdentityDictionaryClass new at: 1 put: 1; at: 2 put: 2; yourself.
		orderedIdentityDictionaryClass new at: #a put: 1; at: #b put: -2; at: #c put: 0; yourself.
		orderedIdentityDictionaryClass new }.
	self serializeAndMaterialize: dictionaries! !

!STONWriteReadTest methodsFor: 'private' stamp: ''!
serializeAndMaterializeJsonMode: object
	| serialization materialization |
	serialization := self serializeJson: object.
	materialization := self materialize: serialization.
	self assert: object equals: materialization
! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testDatesAndTimes
	| datesAndTimes |
	datesAndTimes := STON listClass withAll: { 
		Time now. 
		Date today. 
		DateAndTime now }.
	self serializeAndMaterialize: datesAndTimes
! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testStrings
	| strings |
	strings := Collection allSubclasses 
		collect: [ :each | each name asString ].
	self serializeAndMaterialize: strings.
	strings := { 
		'foo'. 'Foo BAR'. ''. '	\\'''. 
		'élève en Français'. 
		String with: (Character codePoint: 12354) "HIRAGANA LETTER A" }.
	self serializeAndMaterialize: strings.! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testSymbols
	| symbols |
	symbols := #( #bytes #'' #Bytes123 ).
	self serializeAndMaterialize: symbols.
	symbols := Collection allSubclasses collect: [ :each | each name ].
	self serializeAndMaterialize: symbols.
	"simple symbols"
	symbols := #( #foo123 #'123foo' #'punctuation-_./' #'_Foo' #'/root' #'---' #'.st' ).
	self serializeAndMaterialize: symbols.
	"non-simple symbols"
	symbols := #( #'les-élèves-français' #'euro-€' #'ångström' ).
	self serializeAndMaterialize: symbols.! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testURLs
	| urls |
	urls := STON listClass withAll: { 
		'https://pharo.org/files/pharo.png' asUrl. 
		'mailto:sven@stfx.eu' asUrl. 
		'file:///var/log/system.log' asUrl.
		'scheme://user:password@host:123/var/log/system.log?foo=1&bar#frag' asUrl }.
	self serializeAndMaterialize: urls
! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testSpecialClassNames
	| specialClass key specialInstance ston reader object |
	specialClass := LookupKey newAnonymousSubclass.
	specialClass setName: #'STONTest_Lärm'.
	key := 999 atRandom asString asSymbol.
	specialInstance := specialClass key: key.
	ston := self serialize: specialInstance.
	reader := self reader: ston.
	(reader instVarNamed: #classes) 
		at: specialClass name 
		put: specialClass.
	object := reader next.
	self assert: object equals: specialInstance.
	self assert: object class equals: specialClass.
	self assert: object key equals: key! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testFileSystemSupport
	| fileReferences fileLocators |
	fileReferences := STON listClass withAll: { 
		FileLocator image asFileReference.
		FileLocator workingDirectory asFileReference.
		(FileLocator home / 'foo.txt') asFileReference }.
	self serializeAndMaterialize: fileReferences.
	fileLocators := STON listClass withAll: { 
		FileLocator image.
		FileLocator workingDirectory.
		FileLocator home / 'foo.txt' }.
	self serializeAndMaterialize: fileLocators.! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testFloats
	| floats serialization materialization |
	floats := STON listClass withAll: ((-10 to: 10) collect: [ :each | each * Float pi ]).
	serialization := self serialize: floats.
	materialization := self materialize: serialization.
	self assert: floats size equals: materialization size.
	floats with: materialization do: [ :float :materializedFloat |
		"Use #closeTo: instead of #= to increase portability"
		self assert: float closeTo: materializedFloat ]! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testCollectionsStructured
	| collections one two |
	one := 1@2.
	two := 2@3.
	collections := STON listClass withAll: {
	 	Bag withAll: { one. two. one. two. one }.
	 	Set withAll: { one. two. one. two. one }.
	 	OrderedCollection withAll: { one. two. one. two. one }.
	}.
	self serializeAndMaterialize: collections! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testCustomAssociations
	| associations |
	associations := OrderedCollection new.
	associations add: #foo->100.
	associations add: (STONTestAssociation key: #foo value:100).
	self serializeAndMaterialize: associations! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testIntervals
	| intervals |
	intervals := STON listClass withAll: { 
		1 to: 10.
		1 to: 10 by: 2.
		100 to: 50 by: -5 }.
	self serializeAndMaterialize: intervals! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testAssociations
	| associations |
	associations := OrderedCollection new.
	1 to: 10 do: [ :each |
		associations add: each -> each printString ].
	self serializeAndMaterialize: associations! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testKnownObjects
	| knownObject ston object |
	knownObject := STONTestKnownObject new.
	"make sure the system of remembering instances works"
	self assert: (STONTestKnownObject fromId: knownObject id asString) equals: knownObject.
	self assert: (STONTestKnownObject fromId: knownObject id asString) identicalTo: knownObject.
	"only the id string is serialized"
	ston := self serialize: knownObject.
	"upon serialization, objects with known id strings come from the remembered instances"
	object := self materialize: ston.
	self assert: object equals: knownObject.
	self assert: object identicalTo: knownObject.
	"not just the id is equal, but the rest of the object too"
	self assert: object description equals: knownObject description.

	STONTestKnownObject resetKnownObjects! !

!STONWriteReadTest methodsFor: 'private' stamp: ''!
serialize: anObject
	^ String streamContents: [ :stream |
		STON writer 
			on: stream;
			nextPut: anObject ]! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testUUIDs
	| uuids |
	uuids := STON listClass withAll: { 
		UUID new.
		UUID new.
		UUID nilUUID }.
	self serializeAndMaterialize: uuids! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testScaledDecimals
	| fractions |
	fractions := STON listClass withAll: (-2/3s2 to: 2/3s2 by: 1/3s2).
	self serializeAndMaterialize: fractions! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testCollections
	| collections |
	collections := STON listClass withAll: {
		#(1 2 3).
		OrderedCollection withAll: #(1 2 3).
		Set withAll: #(1 2 3).
		Bag withAll: #(1 2 2 3).
		Dictionary new at: 1 put: 1; at: 2 put: 2; yourself.
		#[1 2 3].
		#(1 2 3) asIntegerArray.
		#(1 2 3) asFloatArray }.
	self serializeAndMaterialize: collections! !

!STONWriteReadTest methodsFor: 'private' stamp: ''!
serializeJson: anObject
	^ String streamContents: [ :stream |
		STON jsonWriter 
			on: stream;
			nextPut: anObject ]! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testSpecialCharacters
	| primitives |
	primitives := STON listClass withAll: { 
		String withAll: { Character tab. Character lf. Character cr }.
		String withAll: { $'. $". $\. $/ }.
		'élèves français'.
		'Düsseldorf Königsallee'.
		#(1 10 20 30 127 140 150 160 200 255) collect: #asCharacter as: String }.
	self serializeAndMaterialize: primitives! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testAlternativeRepresentation
	| testObject resultObject |
	testObject := STONAlternativeRepresentationTestObject example.
	"See the class comment of STONAlternativeRepresentationTestObject
	for a description of how the internal and external representation differ.
	See also STONAlternativeRepresentationTestObject>>#stonOn:
	and STONAlternativeRepresentationTestObject>>#fromSton:"
	resultObject := self materialize: (self serialize: testObject).
	self assert: resultObject id equals: testObject id.
	self assert: resultObject time equals: testObject time.
	self assert: (resultObject gridReference x closeTo: testObject gridReference x).
	self assert: (resultObject gridReference y closeTo: testObject gridReference y).! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testSortedCollections
	| collections |
	collections := STON listClass withAll: {
		SortedCollection new.
		SortedCollection new: 0.
		#(5 3 7 2 1 4 10 9 8 6) asSortedCollection.
		#(5 3 7 2 1 4 10 9 8 6) asSortedCollection: #yourself ascending.
		#(5 3 7 2 1 4 10 9 8 6) asSortedCollection: #yourself descending.
		#('****' '*' '*****' '**' '***') asSortedCollection: #size ascending.
		#('****' '*' '*****' '**' '***') asSortedCollection: #size descending.
		#(5 3 7 2 1 4 10 nil 9 8 6) asSortedCollection: #yourself ascending undefinedFirst.
		#(5 3 7 2 1 4 10 nil 9 8 6) asSortedCollection: #yourself ascending reversed undefinedLast }.
	self serializeAndMaterialize: collections! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testUser2
	| user users |
	user := STONTestUser2 dummy.
	self serializeAndMaterialize: user.
	users := STON listClass streamContents: [ :stream |
		10 timesRepeat: [ stream nextPut: STONTestUser2 dummy ] ].
	self serializeAndMaterialize: users.
	users := STON mapClass new.
	10 timesRepeat: [ | newUser |
		newUser := STONTestUser2 dummy.
		users at: newUser username put: newUser ].
	self serializeAndMaterialize: users.! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testSmallIntegers
	| integers |
	integers := STON listClass withAll: (-10 to: 10).
	self serializeAndMaterialize: integers! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testCharacters
	| characters |
	characters := STON listClass withAll: ($a to: $z), ($A to: $Z).
	self serializeAndMaterialize: characters! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testClasses
	| classes |
	classes := STON listClass withAll: { Point. Integer. Object }.
	self serializeAndMaterialize: classes.
	classes := STON listClass withAll: { Point class. Integer class. Object class }.
	self serializeAndMaterialize: classes.
	classes := STON listClass withAll: { Class. Metaclass. Class class. Point class class }.
	self serializeAndMaterialize: classes.! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testSmallDictionary
	"SmallDictionary is special because it does not inherit from Dictionary.
	It might also not exist in some dialects, where this test could be skipped."
	
	| dictionaries smallDictionaryClass |
	smallDictionaryClass := self environment at: #SmallDictionary ifAbsent: [ Dictionary ].
	dictionaries := STON listClass withAll: {
		smallDictionaryClass new at: 1 put: 1; at: 2 put: 2; yourself.
		smallDictionaryClass new at: 1 put: 1; at: 2 put: 2; yourself.
		smallDictionaryClass new }.
	self serializeAndMaterialize: dictionaries! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testPrimitives
	| primitives |
	primitives := STON listClass withAll: { true. false. nil }.
	self serializeAndMaterialize: primitives! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testSharedColors
	| color1 color2 colors |
	color1 := Color r: 0.25 g: 0.5 b: 0.75 alpha: 0.4.
	color2 := Color red.
	colors := STON listClass withAll: { color1. color2. color2 }.
	self serializeAndMaterialize: colors
! !

!STONWriteReadTest methodsFor: 'tests' stamp: ''!
testMimeTypes
	| mimeTypes |
	mimeTypes := STON listClass withAll: { 
		ZnMimeType applicationJson.
		ZnMimeType textPlain }.
	self serializeAndMaterialize: mimeTypes
! !

!STONWriteReadTest methodsFor: 'private' stamp: ''!
materialize: string
	^ STON reader 
		on: string readStream;
		next! !

!STONWriter commentStamp: ''!
STONWriter serializes objects using the Smalltalk Object Notation format. 

Customization options are:

- prettyPrint <Boolean> default is false
	if true, produce pretty printed output
- newLine <String> default is String cr
	what sequence to use for EOL
- asciiOnly <Boolean> default is false
   if true, use \u escapes for all non-ASCII characters
   most common control characters are still escaped
- jsonMode <Boolean> default is false
	if true, the follow changes occur
	- strings are delimited with double quotes
	- nil is encoded as null
	- symbols are treated as strings
	- only STON listClass and STON mapClass instances are allowed as composite objects
	it is wise to also use either #error or #ignore as referencePolicy to avoid references
- referencePolicy <#normal|#ignore|#error> default is #normal
	if #normal, track and count object references and use references to implement sharing and break cycles
	if #error, track object references and signal STONWriterError when a shared reference is encountered
	if #ignore, don't track object references which might loop forever on cycles
 - keepNewLines <Boolean> default is false
	if true, any newline sequence CR, LF or CRLF inside strings or symbols will not be escaped 
	but will be written as the newline EOF convention
	
Note that in default STON mode I only use the following named character escapes: \b \t \n \f \' and \\ while in JSON mode \' is replaced by \"
!
!STONWriter methodsFor: 'writing' stamp: ''!
writeBoolean: boolean
	writeStream print: boolean! !

!STONWriter methodsFor: 'initialization' stamp: ''!
newLine: string
	"The sequence to use when ending a line, either CR, LF or CRLF"
	
	newLine := string! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeString: string
	self encodeString: string! !

!STONWriter methodsFor: 'private' stamp: ''!
prettyPrintSpace
	prettyPrint ifTrue: [ writeStream space ]
! !

!STONWriter methodsFor: 'private' stamp: ''!
isSimpleSymbol: symbol
	(symbol isEmpty or: [ symbol isWideString ]) 
		ifTrue: [ ^ false ].
	^ (symbol class 
		findFirstInString: symbol 
		inSet: STONSimpleSymbolCharacters 
		startingAt: 1) = 0
! !

!STONWriter methodsFor: 'private' stamp: ''!
newlineIndent
	prettyPrint ifTrue: [ 
		writeStream nextPutAll: newLine.
		level timesRepeat: [ writeStream tab ] ]! !

!STONWriter methodsFor: 'private' stamp: ''!
writeableStonCharacters
	^ self stonCharacters == STONCharacters
		ifTrue: [ stonCharacters := stonCharacters copy ]
		ifFalse: [ stonCharacters ]! !

!STONWriter methodsFor: 'private' stamp: ''!
encodeString: string
	writeStream nextPut: (jsonMode ifTrue: [ $" ] ifFalse: [ $' ]).
	keepNewLines
		ifTrue: [ 
			self encodeStringKeepingNewLines: string ]
		ifFalse: [ 
			string do: [ :each | self encodeCharacter: each ] ].
	writeStream nextPut: (jsonMode ifTrue: [ $" ] ifFalse: [ $' ])! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeObject: object streamMap: block
	self writeObject: object do: [ | mapWriter |
		mapWriter := STONMapWriter on: self.
		writeStream nextPut: ${.
		self indentedDo: [
			self newlineIndent.
			block value: mapWriter ].
		self newlineIndent.
		writeStream nextPut: $} ]! !

!STONWriter methodsFor: 'private' stamp: ''!
listElementSeparator
	writeStream nextPut: $,.
	self newlineIndent
! !

!STONWriter methodsFor: 'private' stamp: ''!
encodeKey: key value: value
	(jsonMode and: [ key isString not ])
		ifTrue: [ self error: 'JSON key names in objects must be strings' ].
	self nextPut: key.
	self prettyPrintSpace.
	writeStream nextPut: $:.
	self prettyPrintSpace.
	self nextPut: value! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeSymbol: symbol
	jsonMode
		ifTrue: [
			self writeString: symbol ]
		ifFalse: [
			writeStream nextPut: $#.
			(self isSimpleSymbol: symbol)
				ifTrue: [
					writeStream nextPutAll: symbol ]
				ifFalse: [
					self encodeString: symbol ] ]! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeObject: anObject
	| instanceVariableNames |
	(instanceVariableNames := anObject class stonAllInstVarNames) isEmpty
		ifTrue: [ 
			self writeObject: anObject do: [ self encodeMap: #() ] ]
		ifFalse: [ 
			self writeObject: anObject streamMap: [ :dictionary | 
				instanceVariableNames do: [ :each | 
					(anObject instVarNamed: each)
						ifNotNil: [ :value | 
							dictionary at: each asSymbol put: value ]
						ifNil: [ 
							anObject stonShouldWriteNilInstVars 
								ifTrue: [ dictionary at: each asSymbol put: nil ] ] ] ] ]! !

!STONWriter methodsFor: 'initialization' stamp: ''!
referencePolicy: policy
	self assert: ( #(#normal #ignore #error) includes: policy ).
	referencePolicy := policy
! !

!STONWriter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	stonCharacters := STONCharacters.
	prettyPrint := false.
	newLine := String cr.
	level := 0.
	referencePolicy := #normal.
	jsonMode := keepNewLines := asciiOnly := false.
	objects := IdentityDictionary new! !

!STONWriter methodsFor: 'writing' stamp: ''!
encodeMap: pairs
	| first |
	first := true.
	writeStream nextPut: ${.
	pairs isEmpty
		ifTrue: [
			self prettyPrintSpace ]
		ifFalse: [
			self indentedDo: [
				self newlineIndent.
				pairs keysAndValuesDo: [ :key :value |
					first 
						ifTrue: [ first := false ] 
						ifFalse: [ self mapElementSeparator ].
					self encodeKey: key value: value ] ].
			self newlineIndent ].
	writeStream nextPut: $}! !

!STONWriter methodsFor: 'private' stamp: ''!
encodeStringKeepingNewLines: string
	| input char |
	input := string readStream.
	[ input atEnd ]
		whileFalse: [ 
			char := input next.
			char = Character lf
				ifTrue: [ writeStream nextPutAll: newLine ]
				ifFalse: [ 
					char = Character cr
						ifTrue: [ 
							input peekFor: Character lf.
							writeStream nextPutAll: newLine ]
						ifFalse: [ self encodeCharacter: char ] ] ]! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeMap: hashedCollection
	self with: hashedCollection do: [ 
		self encodeMap: hashedCollection ]! !

!STONWriter methodsFor: 'private' stamp: ''!
stonCharacters
	^ stonCharacters ifNil: [ stonCharacters := STONCharacters ]! !

!STONWriter methodsFor: 'private' stamp: ''!
shortListElementSeparator
	writeStream nextPut: $,.
	self prettyPrintSpace
! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeObject: object streamShortList: block
	self writeObject: object do: [ | listWriter |
		listWriter := STONShortListWriter on: self.
		writeStream nextPut: $[.
		self indentedDo: [
			self prettyPrintSpace.
			block value: listWriter ].
		self prettyPrintSpace.
		writeStream nextPut: $] ]! !

!STONWriter methodsFor: 'private' stamp: ''!
with: object do: block
	| index |
	referencePolicy = #ignore 
		ifTrue: [ ^ block value ].
	(index := objects at: object ifAbsent: [ nil ]) notNil
		ifTrue: [
			referencePolicy = #error
				ifTrue: [ ^ self error: 'shared reference detected' ].
			self writeReference: index ]
		ifFalse: [
			index := objects size + 1.
			objects at: object put: index.
			block value ]! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeNull
	jsonMode
		ifTrue: [ writeStream nextPutAll: 'null' ]
		ifFalse: [ writeStream print: nil ]! !

!STONWriter methodsFor: 'initialization' stamp: ''!
asciiOnly: boolean
	asciiOnly := boolean! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeInteger: integer
	writeStream print: integer! !

!STONWriter methodsFor: 'private' stamp: ''!
mapElementSeparator
	writeStream nextPut: $,.
	self newlineIndent
! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeReference: index
	writeStream
		nextPut: $@;
		print: index! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeObject: object named: stonName listSingleton: element
	self writeObject: object named: stonName do: [
		writeStream nextPut: $[.
		self 
			prettyPrintSpace;
			nextPut: element;
			prettyPrintSpace.
		writeStream nextPut: $] ]! !

!STONWriter methodsFor: 'private' stamp: ''!
escapeUnicode4: codePoint
	writeStream nextPutAll: '\u'.
	codePoint printOn: writeStream base: 16 nDigits: 4! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeScaledDecimal: scaledDecimal
	jsonMode
		ifTrue: [ self writeFloat: scaledDecimal asFloat ]
		ifFalse: [ writeStream
				print: scaledDecimal numerator;
				nextPut: $/;
				print: scaledDecimal denominator;
				nextPut: $s;
				print: scaledDecimal scale ]! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeObject: anObject named: stonName do: block
	(jsonMode and: [ anObject class ~= STON listClass and: [ anObject class ~= STON mapClass ] ])
		ifTrue: [ self error: 'wrong object class for JSON mode' ].
	self with: anObject do: [
		writeStream nextPutAll: stonName.
		self prettyPrintSpace.
		block value ]! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeFloat: float
	writeStream print: float! !

!STONWriter methodsFor: 'writing' stamp: ''!
encodeList: elements
	writeStream nextPut: $[.
	elements isEmpty
		ifTrue: [
			self prettyPrintSpace ]
		ifFalse: [
			self indentedDo: [
				self newlineIndent.
				elements 
					do: [ :each | self nextPut: each ]
					separatedBy: [ self listElementSeparator ] ].
			self newlineIndent ].
	writeStream nextPut: $]
! !

!STONWriter methodsFor: 'initialization' stamp: ''!
optimizeForLargeStructures
	self class environment
		at: #FLLargeIdentityDictionary
		ifPresent: [ :identityDictionaryClass | objects := identityDictionaryClass new ].! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeObject: object streamList: block
	self writeObject: object do: [ | listWriter |
		listWriter := STONListWriter on: self.
		writeStream nextPut: $[.
		self indentedDo: [
			self newlineIndent.
			block value: listWriter ].
		self newlineIndent.
		writeStream nextPut: $] ]! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeObject: anObject do: block
	(jsonMode and: [ anObject class ~= STON listClass and: [ anObject class ~= STON mapClass ] ])
		ifTrue: [ self error: 'wrong object class for JSON mode' ].
	self with: anObject do: [
		"although there is no check here, class names are expected to conform
		to first STONReader>>#isClassStartChar: then STONReader>>#isClassChar:"
		writeStream nextPutAll: anObject class stonName.
		self prettyPrintSpace.
		block value ]! !

!STONWriter methodsFor: 'public' stamp: ''!
nextPut: anObject
	anObject stonOn: self! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeObject: object listSingleton: element
	self writeObject: object do: [
		writeStream nextPut: $[.
		self 
			prettyPrintSpace;
			nextPut: element;
			prettyPrintSpace.
		writeStream nextPut: $] ]! !

!STONWriter methodsFor: 'initialization' stamp: ''!
close
	writeStream ifNotNil: [
		writeStream close.
		writeStream := nil ]! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeAssociation: association
	jsonMode
		ifTrue: [ self error: 'wrong object class for JSON mode' ].
	self 
		encodeKey: association key 
		value: association value! !

!STONWriter methodsFor: 'initialization' stamp: ''!
reset
	objects removeAll! !

!STONWriter methodsFor: 'initialization' stamp: ''!
jsonMode: boolean
	(jsonMode := boolean)
		ifTrue: [ 
			self
				escape: $' with: #pass;
				escape: $" with: '\"' ]
		ifFalse: [ 
			self
				escape: $" with: #pass;
				escape: $' with: '\''' ]! !

!STONWriter methodsFor: 'error handling' stamp: ''!
error: aString
	^ STONWriterError signal: aString! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeFraction: fraction
	jsonMode
		ifTrue: [ self writeFloat: fraction asFloat ]
		ifFalse: [ writeStream
				print: fraction numerator;
				nextPut: $/;
				print: fraction denominator ]! !

!STONWriter methodsFor: 'private' stamp: ''!
encodeCharacter: char
	| code encoding |
	"STONCharacters contains for the lower 127 characters (codes 0 to 126) either nil (unknown), 
	#pass (output as is, clean ASCII characters) or a full escape string"
	((code := char codePoint) < 127 and: [ (encoding := self stonCharacters at: code + 1) notNil ])
		ifTrue: [ 
			(encoding = #pass or: [ jsonMode and: [ char = $' ] ])
				ifTrue: [ writeStream nextPut: char ]
				ifFalse: [ writeStream nextPutAll: encoding ] ]
		ifFalse: [
			"always escape Latin1 C1 controls, or when asciiOnly is true" 
			(code > 16r9F and: [ asciiOnly not ])
				ifTrue: [ writeStream nextPut: char ]
				ifFalse: [ self escapeUnicode: code ] ]
! !

!STONWriter methodsFor: 'private' stamp: ''!
escapeUnicode: codePoint
	codePoint <= 16rFFFF
		ifTrue: [ self escapeUnicode4: codePoint ]
		ifFalse: [ 
			codePoint <= 16r10FFFF
				ifTrue: [ | leadSurrogate trailSurrogate shifted |
					"Characters not in the Basic Multilingual Plane are encoded as a UTF-16 surrogate pair"
					"See https://tools.ietf.org/html/rfc7159#section-7"
					shifted := codePoint - 16r10000.
					leadSurrogate := 16rD800 + (shifted // 16r400).
					trailSurrogate := 16rDC00 + (shifted \\ 16r400).
					self escapeUnicode4: leadSurrogate.
					self escapeUnicode4: trailSurrogate ]
				ifFalse: [ self error: 'Character Unicode code point outside encoder range' ] ]! !

!STONWriter methodsFor: 'private - initialization' stamp: ''!
on: aWriteStream
	writeStream := aWriteStream
! !

!STONWriter methodsFor: 'initialization' stamp: ''!
prettyPrint: boolean
	prettyPrint := boolean! !

!STONWriter methodsFor: 'private' stamp: ''!
indentedDo: block
	level := level + 1.
	block value.
	level := level - 1! !

!STONWriter methodsFor: 'private' stamp: ''!
escape: char with: anObject
	"Instruct me to escape char with object, either a replacement string or #pass"
	
	"self escape: $/ with: '\/'."
	
	self assert: (anObject isString | (anObject == #pass)).
	self assert: char isOctetCharacter.
	self writeableStonCharacters at: char codePoint + 1 put: anObject! !

!STONWriter methodsFor: 'accessing' stamp: ''!
jsonMode

	^ jsonMode ! !

!STONWriter methodsFor: 'initialization' stamp: ''!
keepNewLines: boolean
	"If true, any newline CR, LF or CRLF inside strings or symbols will not be escaped
	but will instead be converted to the newline convention chosen, see #newLine:
	The default is false, where CR, LF or CRLF will be enscaped unchanged."
	
	keepNewLines := boolean! !

!STONWriter methodsFor: 'writing' stamp: ''!
writeList: collection
	self with: collection do: [ 
		self encodeList: collection ]! !

!STONWriter class methodsFor: 'class initialization' stamp: ''!
initialize
	"Modification timestamp 20170131"
	
	self initializeSTONCharacters.
	self initializeSTONSimpleSymbolCharacters! !

!STONWriter class methodsFor: 'instance creation' stamp: ''!
on: writeStream
	^ self new
		on: writeStream;
		yourself! !

!STONWriter class methodsFor: 'class initialization' stamp: ''!
initializeSTONCharacters
	| escapes |
	STONCharacters := Array new: 127.
	32 to: 126 do: [ :each | 
		STONCharacters at: each + 1 put: #pass ].
	"This is the minimal STON set of named escapes"
	escapes := #( 8 '\b' 9 '\t' 10 '\n' 12 '\f' 13 '\r' 39 '\''' 92 '\\' ).
	escapes pairsDo: [ :code :escape | 
		STONCharacters at: code + 1 put: escape ]! !

!STONWriter class methodsFor: 'class initialization' stamp: ''!
initializeSTONSimpleSymbolCharacters
	"STONSimpleSymbolCharacters asArray collectWithIndex: [ :each :index |
		each isZero ifTrue: [ (index - 1) asCharacter ] ]."
		
	STONSimpleSymbolCharacters := ByteArray new: 256 withAll: 1.
	1 to: 256 do: [ :each | | char |
		char := (each - 1) asCharacter.
		(self isSimpleSymbolChar: char)
			ifTrue: [ 
				STONSimpleSymbolCharacters at: each put: 0 ] ]! !

!STONWriter class methodsFor: 'private' stamp: ''!
isSimpleSymbolChar: char
	^ 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_./' includes: char! !

!STONWriterError commentStamp: ''!
STONWriterError is the error/exception signalled by STONWriter when illegal/incorrect input is seen. !
!STONWriterTest commentStamp: ''!
STONWriterTests test serialization.!
!STONWriterTest methodsFor: 'tests' stamp: ''!
testReferenceCycle
	| array |
	array := STON listClass with: 1 with: nil.
	array at: 2 put: array.
	self assert: (self serialize: array) equals: '[1,@1]'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testDictionaryWithComplexKeys
	| collection |
	collection := STON mapClass new at: true put: 1; at: #(foo) put: 2; yourself.
	self assert: (#('{true:1,[#foo]:2}' '{[#foo]:2,true:1}') includes: (self serialize: collection))! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testScaledDecimal
	self assert: (self serialize: 1/3s2) equals: '1/3s2'.
	self assert: (self serialize: -1/3s2) equals: '-1/3s2'.
	self assert: (self serialize: 1/3s10) equals: '1/3s10'.
	self assert: (self serialize: -1/3s10) equals: '-1/3s10'.! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testFraction
	self assert: (self serialize: 1/3) equals: '1/3'.
	self assert: (self serialize: -1/3) equals: '-1/3'.
	self assert: (self serialize: 10/100) equals: '1/10'.
	self assert: (self serialize: 100/10) equals: '10'.
	self assert: (self serialize: 123/123) equals: '1'.
	self assert: (self serialize: 100/11) equals: '100/11'.! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testMap
	| map |
	(map := STON mapClass new)
		at: #foo put: 1;
		at: #bar put: 2.
	self assert: (self serialize: map) equals: '{#foo:1,#bar:2}'.
	self assert: (self serialize: STON mapClass new) equals: '{}'.
	map removeAll.
	map at: 'foo bar' put: #ok.
	self assert: (self serialize: map) equals: '{''foo bar'':#ok}'.
	map removeAll.
	map at: 123 put: 456.
	self assert: (self serialize: map) equals: '{123:456}'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testTime
	| time |
	time := Time hour: 6 minute: 30 second: 15.
	self assert: (self serialize: time) equals: 'Time[''06:30:15'']'.
	time := Time hour: 6 minute: 30 second: 15 nanoSecond: 123.
	self assert: (self serialize: time) equals: 'Time[''06:30:15.000000123'']'.
! !

!STONWriterTest methodsFor: 'private' stamp: ''!
serializeAsciiOnly: anObject
	^ String streamContents: [ :stream |
		STON writer 
			on: stream;
			asciiOnly: true;
			nextPut: anObject ]! !

!STONWriterTest methodsFor: 'private' stamp: ''!
serializePretty: anObject
	^ String streamContents: [ :stream |
		STON writer 
			on: stream; 
			prettyPrint: true;
			nextPut: anObject ]! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testUserNil
	| user |
	user := STONTestUser new.
	self assert: (self serialize: user) equals: 'TestUser{#enabled:true}'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testSymbol
	self assert: (self serialize: #foo) equals: '#foo'.
	self assert: (self serialize: #FOO) equals: '#FOO'.
	self assert: (self serialize: #bytes) equals: '#bytes'.
	self assert: (self serialize: #'foo.bar') equals: '#foo.bar'.
	self assert: (self serialize: #'foo-bar') equals: '#foo-bar'.
	self assert: (self serialize: #foo_bar) equals: '#foo_bar'.
	self assert: (self serialize: #'foo/bar') equals: '#foo/bar'.
	self assert: (self serialize: #'foo bar') equals: '#''foo bar'''.
	self assert: (self serialize: #foo123) equals: '#foo123'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testEmptyDictionaryPretty
	self assert: (self serializePretty: STON mapClass new) equals: '{ }' ! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testPoint
	self assert: (self serialize: 1 @ 2) equals: 'Point[1,2]'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testCustomNewline
	| output |
	output := String streamContents: [ :out |
		(STON writer on: out)
			newLine: String lf;
			prettyPrint: true;
			nextPut: #( 1 ) ].
	self 
		assert: output 
		equals: ('[\	1\]' withCRs replaceAll: Character cr with: Character lf)! !

!STONWriterTest methodsFor: 'private' stamp: ''!
serializeJson: anObject
	^ String streamContents: [ :stream |
		STON jsonWriter 
			on: stream; 
			nextPut: anObject ]! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testUser2
	| user |
	(user := STONTestUser2 new)
		username: 'john@foo.com';
		password: 'secret1'.
	self 
		assert: (self serialize: user)
		equals: 'TestUser2{#username:''john@foo.com'',#password:''secret1'',#enabled:true}'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testDate
	| date |
	date := (Date year: 2012 month: 1 day: 1) translateToUTC.
	self assert: (self serialize: date) equals: 'Date[''2012-01-01Z'']'.
	date := (Date year: 2012 month: 1 day: 1) translateTo: 1 hour.
	self assert: (self serialize: date) equals: 'Date[''2012-01-01+01:00'']'.! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testColor
	self 
		assert: (self serialize: Color red) 
		equals: 'Color[#red]'.
	self 
		assert: (self serialize: (Color red copy setAlpha: 0.4)) 
		equals: 'Color{#red:1.0,#green:0.0,#blue:0.0,#alpha:0.4}'.
	self 
		assert: (self serialize: Color red lighter lighter) 
		equals: 'Color{#red:1.0,#green:0.061,#blue:0.061,#alpha:1.0}'.
! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testClass
	self assert: (self serialize: Point) equals: 'Class[#Point]'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testUser3Nil
	| user |
	user := STONTestUser3 new.
	self 
		assert: (self serialize: user) 
		equals: 'TestUser3{#username:nil,#password:nil,#enabled:true}'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testUser
	| user |
	(user := STONTestUser new)
		username: 'john@foo.com';
		password: 'secret1'.
	self 
		assert: (self serialize: user)
		equals: 'TestUser{#username:''john@foo.com'',#password:''secret1'',#enabled:true}'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testKeepingNewLines
	| input result output |
	input := 'line ending with CR', String cr, 
		'line ending with LF', String lf, 
		'line ending with CRLF', String crlf.
	output := '''line ending with CR', String crlf, 
		'line ending with LF', String crlf, 
		'line ending with CRLF', String crlf, ''''.
	result := String streamContents: [ :out |
		(STON writer on: out) newLine: String crlf; keepNewLines: true; nextPut: input ].
	self assert: result equals: output.
	output := '''line ending with CR', String cr, 
		'line ending with LF', String cr, 
		'line ending with CRLF', String cr, ''''.
	result := String streamContents: [ :out |
		(STON writer on: out) newLine: String cr; keepNewLines: true; nextPut: input ].
	self assert: result equals: output! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testBoolean
	self assert: (self serialize: true) equals: 'true'.
	self assert: (self serialize: false) equals: 'false'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testDoubleQuotedString
	| string |
	self assert: (self serializeJson: 'foo') equals: '"foo"'.
	self assert: (self serializeJson: 'FOO') equals: '"FOO"'.
	self assert: (self serializeJson: 'élève en Français') equals: '"élève en Français"'.
	string := String withAll: {$" . $' . $\ . $/ . Character tab . Character cr . Character lf . Character newPage . Character backspace}.
	"Note that in JSON mode, double quotes get escaped, and single quotes not"
	self assert: (self serializeJson: string) equals: '"\"''\\/\t\r\n\f\b"'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testRestrictedClassesInJsonMode
	self should: [ self serializeJson: 1@2 ] raise: STONWriterError.
	self should: [ self serializeJson: #foo->100 ] raise: STONWriterError.
	self should: [ self serializeJson: STONTestUser dummy ] raise: STONWriterError.
! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testInteger
	self assert: (self serialize: 1) equals: '1'.
	self assert: (self serialize: 0) equals: '0'.
	self assert: (self serialize: -1) equals: '-1'.
	self assert: (self serialize: 1234567890) equals: '1234567890'.
	self assert: (self serialize: -1234567890) equals: '-1234567890'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testString
	| string |
	self assert: (self serialize: 'foo') equals: '''foo'''.
	self assert: (self serialize: 'FOO') equals: '''FOO'''.
	self assert: (self serializeAsciiOnly: 'élève en Français') equals: '''\u00E9l\u00E8ve en Fran\u00E7ais'''.
	self assert: (self serialize: 'élève en Français') equals: '''élève en Français'''.
	string := String withAll: {$" . $' . $\ . $/ . Character tab . Character cr . Character lf . Character newPage . Character backspace}.
	self assert: (self serialize: string) equals: '''"\''\\/\t\r\n\f\b'''! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testSymbolAsString
	self assert: (self serializeJson: #foo) equals: '"foo"'.
	self assert: (self serializeJson: #FOO) equals: '"FOO"'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testMimeType
	self
		assert: (self serialize: ZnMimeType applicationJson)
		equals: 'MimeType[''application/json'']'.
	self
		assert: (self serialize: ZnMimeType textPlain)
		equals: 'MimeType[''text/plain;charset=utf-8'']'.! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testURL
	self
		assert: (self serialize: 'https://pharo.org/files/pharo.png' asUrl)
		equals: 'URL[''https://pharo.org/files/pharo.png'']'.
	self
		assert: (self serialize: 'mailto:sven@stfx.eu' asUrl)
		equals: 'URL[''mailto:sven@stfx.eu'']'.
	self
		assert: (self serialize: 'file:///var/log/system.log' asUrl)
		equals: 'URL[''file:///var/log/system.log'']'.
	self
		assert: (self serialize: 'scheme://user:password@host:123/var/log/system.log?foo=1&bar#frag' asUrl)
		equals: 'URL[''scheme://user:password@host:123/var/log/system.log?foo=1&bar#frag'']'.! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testIdentityDictionary
	| collection |
	collection := IdentityDictionary new
		at: 1 put: 1;
		at: 2 put: 2;
		yourself.
	self assert: (self serialize: collection) equals: 'IdentityDictionary{1:1,2:2}'.
	self assert: (self serialize: IdentityDictionary new) equals: 'IdentityDictionary{}'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testAssociation
	self assert: (self serialize: 'foo' -> 1) equals: '''foo'':1'.
	self assert: (self serialize: #bar -> 2) equals: '#bar:2'.
	self assert: (self serialize: 'foo bar' -> #ok) equals: '''foo bar'':#ok'.
	self assert: (self serialize: 123 -> 456) equals: '123:456'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testDiskFile
	self assert: (self serialize: 'foo.txt' asFileReference) equals: 'FILE[''foo.txt'']'.
	self assert: (self serialize: '/tmp/foo.txt' asFileReference) equals: 'FILE[''/tmp/foo.txt'']'.
	self assert: (self serialize: 'tmp/foo.txt' asFileReference) equals: 'FILE[''tmp/foo.txt'']'.
	self assert: (self serialize: '/tmp' asFileReference) equals: 'FILE[''/tmp'']'.
	self assert: (self serialize: '/tmp/' asFileReference) equals: 'FILE[''/tmp'']'.! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testNonBMPCharacterEncoding
	"Characters not in the Basic Multilingual Plane are encoded as a UTF-16 surrogate pair"

	| string json |
	string := String with: 16r1D11E asCharacter. "MUSICAL SYMBOL G CLEF"
	json := String streamContents: [ :out |
		(STON writer on: out) asciiOnly: true; nextPut: string ].
	self assert: json equals: '''\uD834\uDD1E'''! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testReferenceSharingIgnore
	| serializer array one |
	serializer := [ :object | 
	String
		streamContents: [ :stream | 
			STON writer
				on: stream;
				referencePolicy: #ignore;
				nextPut: object ] ].
	one := {#one}.
	array := STON listClass with: one with: one with: one.
	self assert: (serializer value: array) equals: '[[#one],[#one],[#one]]'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testOrderedCollection
	| collection |
	collection := OrderedCollection with: 1 with: 2 with: 3.
	self assert: (self serialize: collection) equals: 'OrderedCollection[1,2,3]'.
	self assert: (self serialize: OrderedCollection new) equals: 'OrderedCollection[]'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testByteArray
	self assert: (self serialize: #(1 2 3) asByteArray) equals: 'ByteArray[''010203'']'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testReferenceSharing
	| array one |
	one := {#one}.
	array := STON listClass with: one with: one with: one.
	self assert: (self serialize: array) equals: '[[#one],@2,@2]'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testFloat
	self assert: (self serialize: 1.5) equals: '1.5'.
	self assert: (self serialize: 0.0) equals: '0.0'.
	self assert: (self serialize: -1.5) equals: '-1.5'.
	self assert: ((self serialize: Float pi) beginsWith: '3.14159').
	self assert: ((self serialize: (1 / 3) asFloat) beginsWith: '0.333').
	self assert: (self serialize: (10 raisedTo: 100) asFloat) equals: '1.0e100'.
	self assert: (self serialize: (10 raisedTo: -50) asFloat) equals: '1.0e-50'.
	self assert: (self serialize: (10 raisedTo: -50) asFloat negated) equals: '-1.0e-50'! !

!STONWriterTest methodsFor: 'private' stamp: ''!
serialize: anObject
	^ String streamContents: [ :stream |
		STON writer 
			on: stream;
			nextPut: anObject ]! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testDateAndTime
	| dateAndTime |
	dateAndTime := DateAndTime
		year: 2012
		month: 1
		day: 1
		hour: 6
		minute: 30
		second: 15
		offset: 1 hour.
	self assert: (self serialize: dateAndTime) equals: 'DateAndTime[''2012-01-01T06:30:15+01:00'']'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testDictionary
	| collection |
	collection := STON mapClass new
		at: 1 put: 1;
		at: 2 put: 2;
		yourself.
	self assert: (self serialize: collection) equals: '{1:1,2:2}'.
	self assert: (self serialize: STON mapClass new) equals: '{}'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testList
	self assert: (self serialize: (STON listClass withAll: #(1 2 3))) equals: '[1,2,3]'.
	self assert: (self serialize: STON listClass new) equals: '[]'.
	self assert: (self serialize: (STON listClass withAll: {1 . -1 . 0 . #foo . 'a b c' . true . false . nil})) equals: '[1,-1,0,#foo,''a b c'',true,false,nil]'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testNil
	self assert: (self serialize: nil) equals: 'nil'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testReferenceSharingError
	| serializer array one |
	serializer := [ :object | 
		String streamContents: [ :stream |
			STON writer 
				on: stream;
				referencePolicy: #error; 
				nextPut: object ] ].
	one := { #one }.
	array := STON listClass with: one with: one with: one.
	self 
		should: [ (serializer value: array) = '[[#one],[#one],[#one]]' ] 
		raise: STONWriterError
! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testEmptyArrayPretty
	self assert: (self serializePretty: STON listClass new) equals: '[ ]' ! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testIsSimpleSymbol
	self assert: (STON writer isSimpleSymbol: #foo).
	self assert: (STON writer isSimpleSymbol: #az).
	self assert: (STON writer isSimpleSymbol: #AZ).
	self assert: (STON writer isSimpleSymbol: #N0123456789).
	self assert: (STON writer isSimpleSymbol: #foo123).
	self assert: (STON writer isSimpleSymbol: #'Foo/Bar').
	self assert: (STON writer isSimpleSymbol: #'Foo.Bar').
	self assert: (STON writer isSimpleSymbol: #'Foo-Bar').
	self assert: (STON writer isSimpleSymbol: #'Foo_Bar').
	self assert: (STON writer isSimpleSymbol: #foo).
	self deny: (STON writer isSimpleSymbol: #'#^&$%')! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testNull
	self assert: (self serializeJson: nil) equals: 'null'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testMetaclass
	self assert: (self serialize: Point class) equals: 'Metaclass[#Point]'! !

!STONWriterTest methodsFor: 'tests' stamp: ''!
testBag
	self 
		assert: (self serialize: (Bag withAll: #(a a)))
		equals: 'Bag{#a:2}'.
	self 
		assert: (self serialize: Bag new)
		equals: 'Bag{}'
! !

!STONZnUrl commentStamp: ''!
I am STONZnUrl, I am an implementation artifact to help reading objects with class tag equal to my #stonName.

I am a ZnUrl.!
!STONZnUrl class methodsFor: 'accessing' stamp: ''!
stonName
	^ #URL! !

!STONZnUrl class methodsFor: 'instance creation' stamp: ''!
fromSton: stonReader
	^ ZnUrl fromString: stonReader parseListSingleton ! !

!SUnitAPIDocumentation commentStamp: ''!
SUnit API documentation for help system!
!SUnitAPIDocumentation class methodsFor: 'accessing' stamp: ''!
bookName
	^'API Documentation'! !

!SUnitAPIDocumentation class methodsFor: 'accessing' stamp: ''!
helpPackages
	^#('SUnit-Core-Announcements' 'SUnit-Core-Extensions' 'SUnit-Core-Kernel' 'SUnit-Core-Kernel' 'SUnit-Core-Utilities' 'SUnit-Tests' 'SUnit-UI')! !

!SUnitAPIDocumentation class methodsFor: 'defaults' stamp: ''!
builder
	^PackageAPIHelpBuilder! !

!SUnitExtensionsTest commentStamp: ''!
SUnit tests for extensions to SUnit!
!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testNoExceptionInShouldRaiseWithExceptionDo
	| testCase testResult |
	testCase := self class selector: #noExceptionInShouldRaiseWithExceptionDoTest.
	testResult := testCase run.

	self assert: (testResult failures includes: testCase).
	self assert: testResult failures size equals: 1.
	self assertEmpty: testResult passed.
	self assertEmpty: testResult errors! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
differentExceptionInShouldRaiseWithExceptionDoTest

	[ self 
		should: [ Error signal ]
		raise: Halt
		withExceptionDo: [ :anException | self assert: false description: 'should:raise:withExceptionDo: handled an exception that should not handle'] ]
	on: Error
	do: [ :anException | anException return: nil ]! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testAutoDenyTrue
	self deny: 1 equals: 2.
	self deny: false! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testDifferentExceptionInShouldRaiseWithExceptionDo
	| testCase testResult |
	testCase := self class selector: #differentExceptionInShouldRaiseWithExceptionDoTest.
	testResult := testCase run.

	self assert: (testResult passed includes: testCase).
	self assertEmpty: testResult errors.
	self assertEmpty: testResult failures.
	self assert: testResult passed size equals: 1! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testShouldFix
	| testCase testResult |
	testCase := self class selector: #shouldFixTest.
	testResult := testCase run.

	self assert: (testResult passed includes: testCase).
	self assert: testResult passed size equals: 1.
	self assertEmpty: testResult failures.
	self assertEmpty: testResult errors! !

!SUnitExtensionsTest methodsFor: 'test support' stamp: ''!
failureLog
	^self stream! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
shouldRaiseWithSignalDoTest
	self should: [ Error signal: '1' ] raise: Error withExceptionDo: [ :anException | self assert: anException messageText equals: '1' ]! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testAssertionFailedInRaiseWithExceptionDo
	| testCase testResult |
	testCase := self class selector: #assertionFailedInRaiseWithExceptionDoTest.
	testResult := testCase run.

	self assert: (testResult failures includes: testCase).
	self assert: testResult failures size equals: 1.
	self assertEmpty: testResult passed.
	self assertEmpty: testResult errors! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testErrorInRaiseWithExceptionDo
	| testCase testResult |
	testCase := self class selector: #errorInRaiseWithExceptionDoTest.
	testResult := testCase run.

	self assert: (testResult errors includes: testCase).
	self assert: testResult errors size equals: 1.
	self assertEmpty: testResult failures.
	self assertEmpty: testResult passed! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
invalidShouldNotTakeMoreThan

	self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan: 50 milliSeconds.! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testInvalidShouldNotTakeMoreThan
	| testCase testResult |
	testCase := self class selector: #invalidShouldNotTakeMoreThan.
	testResult := testCase run.

	self assertEmpty: testResult passed.
	self assert: testResult failures size equals: 1.
	self assert: (testResult failures includes: testCase).
	self assertEmpty: testResult errors! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
invalidShouldNotTakeMoreThanMilliseconds

	self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 50! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testAutoAssertTrue
	self assert: 1 equals: 1.
	self assert: true! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
errorInRaiseWithExceptionDoTest

	self 
		should: [ Error  signal ]
		raise: Error
		withExceptionDo: [ :anException | Error signal: 'A forced error' ]! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testValidShouldNotTakeMoreThan
	| testCase testResult |
	testCase := self class selector: #validShouldNotTakeMoreThan.
	testResult := testCase run.

	self assert: (testResult passed includes: testCase).
	self assert: testResult passed size equals: 1.
	self assertEmpty: testResult failures.
	self assertEmpty: testResult errors! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testValidShouldNotTakeMoreThanMilliseconds
	| testCase testResult |
	testCase := self class selector: #validShouldNotTakeMoreThanMilliseconds.
	testResult := testCase run.

	self assert: (testResult passed includes: testCase).
	self assert: testResult passed size equals: 1.
	self assertEmpty: testResult failures.
	self assertEmpty: testResult errors! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
shouldRaiseWithExceptionDoTest
	self should: [ Error signal: '1' ] raise: Error withExceptionDo: [ :anException | self assert: anException messageText equals: '1' ]! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testInvalidShouldNotTakeMoreThanMilliseconds
	| testCase testResult |
	testCase := self class selector: #invalidShouldNotTakeMoreThanMilliseconds.
	testResult := testCase run.

	self assertEmpty: testResult passed.
	self assert: testResult failures size equals: 1.
	self assert: (testResult failures includes: testCase).
	self assertEmpty: testResult errors! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testAutoDenyFalse
	| booleanCondition |
	self assert: self isLogging.
	self should: [ self deny: 1 = 1 description: 'self deny: 1 = 1'.] raise: self defaultTestFailure.
	booleanCondition := (self stream contents substrings:  {Character cr}) last = 'self deny: 1 = 1'.
	self assert: booleanCondition! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testNoExceptionWithMatchingString
	self 
		shouldnt: [ Object messageNotUnderstoodByObject ]
		raise: MessageNotUnderstood 
		whoseDescriptionIncludes: 'Zero'
		description: 'tested obsoleting Object'! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
shouldFixTest

	self shouldFix: [ Error signal: 'any kind of error' ]
! !

!SUnitExtensionsTest methodsFor: 'testing' stamp: ''!
isLogging
	^true! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
noExceptionInShouldRaiseWithExceptionDoTest

	self 
		should: [  ]
		raise: Error
		withExceptionDo: [ :anException | Error signal: 'Should not get here' ]! !

!SUnitExtensionsTest methodsFor: 'accessing' stamp: ''!
stream
	^stream ifNil: [stream := String new writeStream].! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testExceptionWithMatchingString
	self should: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'NOT obsolete' description: 'tested obsoleting Object'! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testExceptionWithoutMatchingString
	self 
		should: [ Object obsolete ]
		raise: Error
		whoseDescriptionDoesNotInclude: 'Zero'
		description: 'tested obsoleting Object'! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testNoExceptionWithNoMatchingString
	self
		shouldnt: [ Object messageNotUnderstoodByObject ]
		raise: MessageNotUnderstood
		whoseDescriptionDoesNotInclude: 'messageNotUnderstoodByObject'
		description: 'tested obsoleting Object'! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testAutoAssertFalse
	| booleanCondition |
	self assert: self isLogging.
	self should: [ self assert: 1 = 2 description: 'self assert: 1 = 2' ] raise: self defaultTestFailure.
	booleanCondition := (self stream contents substrings: {Character cr}) last = 'self assert: 1 = 2'.
	self assert: booleanCondition! !

!SUnitExtensionsTest methodsFor: 'tests' stamp: ''!
testShouldRaiseWithExceptionDo
	| testCase testResult |
	testCase := self class selector: #shouldRaiseWithExceptionDoTest.
	testResult := testCase run.

	self assert: (testResult passed includes: testCase).
	self assert: testResult passed size equals: 1.
	self assertEmpty: testResult failures.
	self assertEmpty: testResult errors! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
assertionFailedInRaiseWithExceptionDoTest

	self 
		should: [ Error signal ]
		raise: Error
		withExceptionDo: [ :anException | self assert: false ]! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
validShouldNotTakeMoreThan

	self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan:  200 milliSeconds.! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: ''!
validShouldNotTakeMoreThanMilliseconds

	self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 200! !

!SUnitExtensionsTest class methodsFor: 'history' stamp: ''!
lastStoredRun
	^ ((Dictionary new) add: (#passed->((Set new) add: #testNoExceptionWithMatchingString; add: #testNoExceptionWithNoMatchingString; add: #testExceptionWithMatchingString; add: #testExceptionWithoutMatchingString; add: #testValidShouldNotTakeMoreThan; add: #testInvalidShouldNotTakeMoreThanMilliseconds; add: #testDifferentExceptionInShouldRaiseWithExceptionDo; add: #testShouldRaiseWithExceptionDo; add: #testShouldFix; add: #testAssertionFailedInRaiseWithExceptionDo; add: #testAutoDenyFalse; add: #testAutoDenyTrue; add: #testAutoAssertFalse; add: #testAutoAssertTrue; add: #testValidShouldNotTakeMoreThanMilliseconds; add: #testErrorInRaiseWithExceptionDo; add: #testNoExceptionInShouldRaiseWithExceptionDo; add: #testInvalidShouldNotTakeMoreThan; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! !

!SUnitHelp commentStamp: ''!
This is a custom help book for the SUnit framework.
!
!SUnitHelp class methodsFor: 'pages' stamp: ''!
links
	"This method was automatically generated. Edit it using:"
	"SUnitHelp edit: #links"
	^HelpTopic
		title: 'Links'
		contents: 
'Visit the following sites to get more information on SUnit

- http://sunit.sourceforge.net/
- http://www.iam.unibe.ch/~ducasse/Programmez/OnTheWeb/Eng-Art8-SUnit-V1.pdf
- http://en.wikipedia.org/wiki/SUnit!!' readStream nextChunkText! !

!SUnitHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#(introduction running SUnitTutorial SUnitAPIDocumentation links)! !

!SUnitHelp class methodsFor: 'accessing' stamp: ''!
bookName
	^'SUnit framework'! !

!SUnitHelp class methodsFor: 'pages' stamp: ''!
introduction
	"This method was automatically generated. Edit it using:"
	"SUnitHelp edit: #introduction"
	^HelpTopic
		title: 'Introduction'
		contents: 
'SUnit is the mother of all unit testing frameworks, and serves as one of the cornerstones of test-driven development methodologies such as eXtreme Programming. 

The culture of testing has always been part of the philosophy of development in Smalltalk:
You write a method, accept the code and test it by writing a small script in a workspace, in a comment or an example as a class method. But this approach does not allow to automatically repeat the testing or ensure that the code is working. SUnit is a framework you can use to describe and execute unit tests. Unit testing is a method by which individual units of source code are tested to determine if they are fit for use. A unit is the smallest testable part of an application.!!' readStream nextChunkText! !

!SUnitHelp class methodsFor: 'pages' stamp: ''!
running
	"This method was automatically generated. Edit it using:"
	"SUnitHelp edit: #running"
	^HelpTopic
		title: 'Running tests'
		contents: 
'SUnit allows writing tests on Smalltalk source code and checking results. This is usually done in a tool called TestRunner which you can either open from the Pharo world menu or by evaluating:

   TestRunner open

in a Smalltalk workspace.

By writing tests and checking them with the test runner you can ensure the sustainability of your applications.

!!' readStream nextChunkText! !

!SUnitSuiteBuilder commentStamp: ''!
I  am a visitor that builds a TestSuite.!
!SUnitSuiteBuilder methodsFor: 'visiting' stamp: ''!
visitTestSuite: aTestSuite
	^ aTestSuite! !

!SUnitSuiteBuilder methodsFor: 'visiting' stamp: ''!
visitTestCase: aTestCase
	^ aTestCase! !

!SUnitSuiteBuilder methodsFor: 'visiting' stamp: ''!
visitRPackageSet: aRPackageSet
	^ self
		suiteNamed: aRPackageSet packageName
		withTests: (super visitRPackageSet: aRPackageSet)! !

!SUnitSuiteBuilder methodsFor: 'visiting' stamp: ''!
visitRPackage: aRPackage
	^ self
		suiteNamed: aRPackage name
		withTests: (super visitRPackage: aRPackage)! !

!SUnitSuiteBuilder methodsFor: 'visiting' stamp: ''!
suiteNamed: aString withTests: tests
	^ (TestSuite named: aString)
		addTests: tests;
		yourself! !

!SUnitSuiteBuilderTest methodsFor: 'tests' stamp: ''!
testVisitingClassReturnsSuiteWithSameTestsSelectors

	| result |
	result := visitor visit: self class.
	self
		assertCollection: (result tests collect: [:each | each selector])
		hasSameElements: self class testSelectors! !

!SUnitSuiteBuilderTest methodsFor: 'tests' stamp: ''!
testVisitingCaseReturnsSameCase
	| result |
	result := visitor visit: self.

	self assert: result equals: self! !

!SUnitSuiteBuilderTest methodsFor: 'tests' stamp: ''!
testVisitingSuiteReturnsSameSuite
	| suite result |
	suite := self class suite.
	result := visitor visit: suite.

	self assert: result equals: suite! !

!SUnitSuiteBuilderTest methodsFor: 'tests' stamp: ''!
testVisitingPackageReturnsSuiteOfSuites
	| result testClasses |
	result := visitor visit: self class package.
	testClasses := self class package classes select: #isTestCase.
	self
		assert: result name
		equals: self class package name.
	self
		assertCollection: (result tests collect: [:each | each name])
		hasSameElements: (testClasses collect: [:each | each name]).
	self
		assertCollection: (result tests flatCollect: [:each | each tests collect: [:t | t selector]])
		hasSameElements: (testClasses flatCollect: [:each | each testSelectors])! !

!SUnitSuiteBuilderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	visitor := SUnitSuiteBuilder new! !

!SUnitTest commentStamp: ''!
This is both an example of writing tests and a self test for the SUnit. The tests 
here are pretty strange, since you want to make sure things blow up. You should 
not generally have to write tests this complicated in structure, although they 
will be far more complicated in terms of your own objects- more assertions, more 
complicated setup. Kent says: "Never forget, however, that if the tests are hard 
to write, something is probably wrong with the design".!
!SUnitTest methodsFor: 'accessing' stamp: ''!
forkedProcesses
	^forkedProcesses! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testGreenTestThenLongRunningTest

	| case result |
	DefaultExecutionEnvironment beActive.
	case := self newTestCase: #noop.
	result := case run.
	case := self newTestCase: #longRunningTest.
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 0
		errors: 1! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testIgnoreDeprecationWarnings
	| oldRaiseWarning |
	oldRaiseWarning := Deprecation raiseWarning.
	[ Deprecation raiseWarning: false.
	self deprecatedMessage.
	self assert: true ]
		ensure: [ Deprecation raiseWarning: oldRaiseWarning ]! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testFail

	| case result |

	case := self newTestCase: #fail.
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 1
		errors: 0! !

!SUnitTest methodsFor: 'helpers' stamp: ''!
failedChildProcesses
	^forkedProcesses select: [: each | each name beginsWith: 'failed child']! !

!SUnitTest methodsFor: 'accessing' stamp: ''!
hasRun
	^hasRun! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testLongRunningTestThenGreenTest

	| case result |
	DefaultExecutionEnvironment beActive.
	case := self newTestCase: #longRunningTest.
	result := case run.
	case := self newTestCase: #noop.
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 1
		failed: 0
		errors: 0! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testExpectedFailurePass

	| case result |
	case := self newTestCase: #expectedFailurePasses.
	self deny: case shouldPass.
	result := case run.
	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 1
		errors: 0
		expectedFailures: 0.! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testLongRunningTest

	| case result |
	DefaultExecutionEnvironment beActive.
	case := self newTestCase: #longRunningTest.
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 0
		errors: 1! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testRaiseDeprecationWarnings
	| case result |
	case := self newTestCase: #raiseDeprecationWarnings.
	result := case run.
	self assert: result defects asArray equals: (Array with: case).
	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 1
		errors: 0! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testWithExceptionDo

	self
		should: [self error: 'foo']
		raise: self defaultTestError
		withExceptionDo: [:exception |
			self assert: (exception description includesSubstring: 'foo')
		]
			! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testFailedChildProcessTestShouldNotEffectFollowingAnotherTest

	| result case1 case2 |
	DefaultExecutionEnvironment beActive.
	TestExecutionEnvironment new beActiveDuring: [ 
		case1 := self newTestCase: #failedChildProcessTest.	
		result := case1 run.
		
		case2 := self newTestCase: #noop.	
		result := case2 run].

	self
		assertForTestResult: result
		runCount: 1
		passed: 1
		failed: 0
		errors: 0.		
	self assertTerminationOfFailedChildProcesses! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testDefects
	| result suite error failure |
	suite := self classForTestSuite new.
	suite addTest: (error := self newTestCase: #error).
	suite addTest: (failure := self newTestCase: #fail).
	result := suite run.
	self assert: result defects asArray equals: (Array with: error with: failure).
	self
		assertForTestResult: result
		runCount: 2
		passed: 0
		failed: 1
		errors: 1! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testSuite
	| suite result |
	suite := self classForTestSuite new.
	suite
		addTest: (self newTestCase: #noop);
		addTest: (self newTestCase: #fail);
		addTest: (self newTestCase: #error).
	result := suite run.
	self
		assertForTestResult: result
		runCount: 3
		passed: 1
		failed: 1
		errors: 1! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testDialectLocalizedException

	self
		should: [self classForTestResult signalFailureWith: 'Foo']
		raise: self defaultTestFailure.
	self
		should: [self classForTestResult signalErrorWith: 'Foo']
		raise: self defaultTestError.! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testExpectedFailureDetection
	self assert: self expectedFailures size equals: 2.
	self assert: (self expectedFailures includesAll: #(expectedFailureFails expectedFailurePasses))! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testRunningLongTime
	self timeLimit: 3 seconds.
	
	2 seconds wait
			! !

!SUnitTest methodsFor: 'private' stamp: ''!
setRun
	hasRun := true! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testRan

	| case |

	case := self newTestCase: #setRun.
	case resources do: [:each | each availableFor: case].
	[case setUp.
	case performTest] ensure: [
		self assert: case hasSetup.
		self assert: case hasRun.
		case tearDown.
		case cleanUpInstanceVariables].
	self assert: case hasSetup isNil.
	self assert: case hasRun isNil.! !

!SUnitTest methodsFor: 'private' stamp: ''!
error
	3 zork! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testExecutionEnvironmentShouldBeInstalled

	| env |
	env := self executionEnvironment.

	self assert: env class equals: TestExecutionEnvironment.
	self assert: env testCase equals: self! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testException

	self
		should: [self error: 'foo']
		raise: self defaultTestError! !

!SUnitTest methodsFor: 'private' stamp: ''!
longRunningTest

	self timeLimit: 10 milliSeconds.
	20 milliSeconds wait! !

!SUnitTest methodsFor: 'testing' stamp: ''!
errorShouldntRaise
	self someMessageThatIsntUnderstood! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testSelectorWithArg: anObject
	"should not result in error"! !

!SUnitTest methodsFor: 'private' stamp: ''!
expectedFailurePasses
	<expectedFailure>
	self assert: true.! !

!SUnitTest methodsFor: 'private' stamp: ''!
hangedTestDueToFailedChildProcess
	self timeLimit: 10 milliSeconds.
	
	self failedChildProcessTest.
	
	20 milliSeconds wait.

	
	! !

!SUnitTest methodsFor: 'accessing' stamp: ''!
hasSetup
	^hasSetup! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testHangedChildProcessTestWhenItIsAllowedToLeaveProcessesAfterTest

	| case result hangedProcess |
	
	case := self newTestCase: #hangedChildProcessTest.	
	case executionProcessMonitor allowTestToLeaveProcesses.
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 1
		failed: 0
		errors: 0.
		
	hangedProcess := forkedProcesses detect: [: each | each name = #hangedChildProcessTest].
	self assert: hangedProcess isTerminated! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testRanOnlyOnce

	self assert: hasRanOnce ~= true.
	hasRanOnce := true! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testChildProcessShouldNotBeStoredStronglyByTestEnvironment

	| process weak |
	process := [   ] forkNamed: 'child test process'.
	weak := WeakArray with: process.
	process := nil.
	Processor yield.
	Smalltalk garbageCollect.
	
	self assert: weak first equals: nil! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testFailedTestWithFailedChildProcessTestShouldNotEffectFollowingAnotherTest

	| result case1 case2 |
	DefaultExecutionEnvironment beActive.
	TestExecutionEnvironment new beActiveDuring: [ 
		case1 := self newTestCase: #failedTestWithFailedChildProcessTest.	
		result := case1 run.
		
		case2 := self newTestCase: #noop.	
		result := case2 run].

	self
		assertForTestResult: result
		runCount: 1
		passed: 1
		failed: 0
		errors: 0.
	self assertTerminationOfFailedChildProcesses! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testAssert
	self assert: true.
	self deny: false! !

!SUnitTest methodsFor: 'private' stamp: ''!
failedChildProcessTest
	"During this test forked process should signal error.
	It means that after fork we should give the process control"
	
	| process |
	process := [ self error: 'error from child process'] forkNamed: 'failed child for ', testSelector.
	forkedProcesses add: process.
	Processor yield.! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testShouldIgnoreTimeLimitWhenTestProcessIsSuspended
	"If you open debugger on test (by halt or error) and will not close it more then test time limit then following interaction with debugger will fail. 
	As simple fix watch dog should check that test process is not suspended. It of course will open possibility to hang test execution when tested code will suspend active process by incident. But we could live with it and probably it could be addressed too in future"
	| testProcess |
	self timeLimit: 30 milliSeconds.
	testProcess := Processor activeProcess.
	[ 50 milliSeconds wait. testProcess resume ] fork.
	testProcess suspend.
	self assert: true.! !

!SUnitTest methodsFor: 'helpers' stamp: ''!
assertTerminationOfFailedChildProcesses

	| failedProcesses |
	failedProcesses := self failedChildProcesses.
	self assert: failedProcesses notEmpty.
	self assert: (failedProcesses allSatisfy: #isTerminated) ! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testFailedChildProcessTest

	| case result |
	DefaultExecutionEnvironment beActive.
	case := self newTestCase: #failedChildProcessTest.	
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 0
		errors: 1.		
	self assertTerminationOfFailedChildProcesses! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testShould

	self
		should: [true];
		shouldnt: [false]! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testWatchDogProcessShouldNotBeCatchedAsForkedProcess
	| env |
	env := self executionEnvironment.

	self assertEmpty: env forkedProcesses! !

!SUnitTest methodsFor: 'private' stamp: ''!
hangedChildProcessTest

	| process |
	process := [10 seconds wait] forkNamed: #hangedChildProcessTest.
	forkedProcesses add: process! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testExpectedFailure

	| case result |
	case := self newTestCase: #expectedFailureFails.
	self deny: case shouldPass.
	result := case run.
	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 0
		errors: 0
		expectedFailures: 1.! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testErrorShouldResetWatchDog

	| case result |
	
	DefaultExecutionEnvironment beActive.
	TestExecutionEnvironment new beActiveDuring: [ 
		case := self newTestCase: #fail.
		result := case run.
		1 seconds wait]. 

	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 1
		errors: 0! !

!SUnitTest methodsFor: 'accessing' stamp: ''!
forkedProcesses: aCollection
	forkedProcesses := aCollection! !

!SUnitTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	hasSetup := true! !

!SUnitTest methodsFor: 'private' stamp: ''!
failedTestWithFailedChildProcessTest
	"This failing test first launches a subprocess that fails and then fails."
	self failedChildProcessTest.
	Processor yield.
	self error: 'failed test with failed child process'! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testError

	| case result |

	case := self newTestCase: #error.
	result := case run.
	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 0
		errors: 1.

	case := self newTestCase: #errorShouldntRaise.
	result := case run.
	self 
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 0
		errors: 1! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testFileOutResult
	| suite result fileout |
	suite := self classForTestSuite new.
	suite
		addTest: (self newTestCase: #noop);
		addTest: (self newTestCase: #fail);
		addTest: (self newTestCase: #error).
	result := suite run.
	fileout := String streamContents: [ :aStream | result fileOutOn: aStream ].
	self
		assert: fileout
		equals:
			'3 ran, 1 passed, 0 skipped, 0 expected failures, 1 failure, 1 error, 0 passed unexpected
Failures:
SUnitTest(TestAsserter)>>#fail

Errors:
SUnitTest>>#error
'! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testRunning

	10 milliSeconds wait
			! !

!SUnitTest methodsFor: 'testing' stamp: ''!
raiseDeprecationWarnings
	| oldRaiseWarning |
	oldRaiseWarning := Deprecation raiseWarning.
	[ Deprecation raiseWarning: true.
	self deprecatedMessage.
	self fail ]
		ensure: [ Deprecation raiseWarning: oldRaiseWarning ]! !

!SUnitTest methodsFor: 'private' stamp: ''!
expectedFailureFails
	<expectedFailure>
	self assert: false.! !

!SUnitTest methodsFor: 'private' stamp: ''!
assertForTestResult: aResult runCount: aRunCount passed: aPassedCount failed: aFailureCount errors: anErrorCount

	self assert: aResult runCount equals: aRunCount.
	self assert: aResult passedCount equals: aPassedCount.
	self assert: aResult failureCount equals: aFailureCount.
	self assert: aResult errorCount equals: anErrorCount! !

!SUnitTest methodsFor: 'helpers' stamp: ''!
deprecatedMessage
	self deprecated: 'Deprecated method used by #testIgnoreDeprecationWarnings' on: '' in: ''! !

!SUnitTest methodsFor: 'private' stamp: ''!
noop! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testHangedTestDueToFailedChildProcess

	| case result |
	DefaultExecutionEnvironment beActive.
	case := self newTestCase: #hangedTestDueToFailedChildProcess.	
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 0
		errors: 1.
		
	self assertTerminationOfFailedChildProcesses! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testIsNotRerunOnDebug

	| case |

	case := self newTestCase: #testRanOnlyOnce.
	case run.
	case debug! !

!SUnitTest methodsFor: 'helpers' stamp: ''!
newTestCase: myTestSelector 
	| testCase |
	testCase := self class selector: myTestSelector.	
	"During the #run the #tearDown logic resets to nil all inst vars of #testCase instance.
	Here is a hook to collect any required state inside the receiver so that it can be accessed directly from the receiver despite on the reset #testCase.
	#forkedProcesses variable is used to keep all processes forked during the testCase execution"
	forkedProcesses ifNil: [ forkedProcesses := OrderedCollection new ].
	testCase forkedProcesses: forkedProcesses.
	^testCase! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testHangedChildProcessTestWhenLeftProcessIsConsideredAsFailure

	| case result |

	case := self newTestCase: #hangedChildProcessTest.	
	case executionProcessMonitor failTestLeavingProcesses.
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 0
		errors: 1! !

!SUnitTest methodsFor: 'private' stamp: ''!
assertForTestResult: aResult runCount: aRunCount passed: aPassedCount failed: aFailureCount errors: anErrorCount expectedFailures: anExpectedFailureCount
	self assert: aResult runCount equals: aRunCount.
	self assert: aResult expectedPassCount equals: aPassedCount.
	self assert: aResult failureCount equals: aFailureCount.
	self assert: aResult errorCount equals: anErrorCount.
	self assert: aResult expectedDefectCount equals: anExpectedFailureCount! !

!SUnitTest methodsFor: 'testing' stamp: ''!
testResult

	| case result |

	case := self newTestCase: #noop.
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 1
		failed: 0
		errors: 0! !

!SUnitTest class methodsFor: 'history' stamp: ''!
lastStoredRun
	^ ((Dictionary new) add: (#passed->((Set new) add: #testWithExceptionDo; add: #testAssert; add: #testRanOnlyOnce; add: #testDialectLocalizedException; add: #testFail; add: #testDefects; add: #testIsNotRerunOnDebug; add: #testResult; add: #testRunning; add: #testError; add: #testException; add: #testShould; add: #testSuite; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! !

!SUnitTestsCounter commentStamp: ''!
A visitor which count tests in the visitable object provided.!
!SUnitTestsCounter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self count: 0! !

!SUnitTestsCounter methodsFor: 'visiting' stamp: ''!
visitTestCase: aTestCase
	"Defines the behaviour while visiting a TestCase.
	 This method must be overrided by users of this trait.
	"
	self count: self count + 1! !

!SUnitTestsCounter methodsFor: 'accessing' stamp: ''!
count: anObject
	count := anObject! !

!SUnitTestsCounter methodsFor: 'accessing' stamp: ''!
count
	^ count! !

!SUnitTestsCounterTest commentStamp: ''!
A SUnitTestsCounterTest is a test class for testing the behavior of SUnitTestsCounter!
!SUnitTestsCounterTest methodsFor: 'tests' stamp: ''!
testCountTestsInSUnitVisitorTestsPackage
	| visitor |
	visitor := SUnitTestsCounter new.
	
	self assert: visitor count equals: 0.
	
	visitor visit: self class.
	
	self assert: visitor count equals: self class testSelectors size! !

!SUnitTutorial commentStamp: ''!
This is a custom help book providing a tutorial for the SUnit framework.
!
!SUnitTutorial class methodsFor: 'accessing' stamp: ''!
pages
	^#(step1 step2 step3 step4 step5)! !

!SUnitTutorial class methodsFor: 'accessing' stamp: ''!
bookName
	^'Tutorial'! !

!SUnitTutorial class methodsFor: 'pages' stamp: ''!
step5
	"This method was automatically generated. Edit it using:"
	"SUnitTutorial edit: #step5"
	^HelpTopic
		title: 'Step 5 - Getting the test green'
		contents: 
'To get our test green we have to implement the missing methods. First the debugger tells us that the Person class does not understand the message #named: 

We dont have to go back into a standard browser to implement it, we just select ''Create'' in the walkback window. The system now asks us where #named: should be defined in the inheritance hierarchy. We select the Person class and categorize the method in a new method category ''instance creation''.

Finally we have a debugger open where we can implement the code like this:

  named: aString
 	^(self new)
		name: aString;
		yourself
		
Note that after accepting the method in the debugger you can instantly step through it or hit ''Proceed'' to continue execution. The system tell us that there is no setter method #name:, so we implement it too on the instance side:
	
   name: aString
	name := aString

Next the #firstName: message is missing:
	
   firstName: aString
	firstName := aString
	
At any point in time we can control if the test is already green in the TestRunner. Finally when we implement
the missing #fullName method by concatenating first name and surename:

	fullName
		^firstName, '' '', name  
		
Now out test should be green.!!' readStream nextChunkText! !

!SUnitTutorial class methodsFor: 'pages' stamp: ''!
step1
	"This method was automatically generated. Edit it using:"
	"SUnitTutorial edit: #step1"
	^HelpTopic
		title: 'Step 1 - Define a test class'
		contents: 
'To define a series of tests in SUnit one typically creates a subclass of class TestCase. The idea is that the methods of this class will implement several tests, the instance variables represent the objects and / or the context in which these tests will be performed. 

In our example we want to write a test on a simple Person class (which is not yet in our image). If the unit under test is a single class one convention is to name the test like the class but followed with the postfix "Test". 

So to create a test for the Person class we subclass TestCase with a custom "PersonTest" class.

	TestCase subclass: #PersonTest
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''MyApp-Tests-Model''

Note that we have not created the class Person yet - so one idea of ExtremeProgramming (XP) is to write the test first as a way to describe a use case that your application has to cover. After that you write the code and the test will show you if the scenario is fulfilled. You dont have to follow this programming style and can also write tests to cover existing code.
	!!' readStream nextChunkText! !

!SUnitTutorial class methodsFor: 'pages' stamp: ''!
step2
	"This method was automatically generated. Edit it using:"
	"SUnitTutorial edit: #step2"
	^HelpTopic
		title: 'Step 2 - Define a first test method'
		contents: 
'To define a test we create a new instance side method for our first test scenario. By convention any method (in a subclass of TestCase) whose selector starts with ''test'' is supposed to be a test and can be run using the TestRunner tool:

	testInstanceCreation
		|person|
		person := Person named: ''Beck''.
		person firstName: ''Kent''.
		self assert: person fullName = ''Kent Beck''.
		
A good style is to put this method into the method category ''testing''.

When you accept the code the system may ask you about the new class Person. It''s not yet defined - but you can easily create it using the following class definition:

	Object subclass: #Person
		instanceVariableNames: ''name firstName'' 
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''MyApp-Core-Model''!!' readStream nextChunkText! !

!SUnitTutorial class methodsFor: 'pages' stamp: ''!
step3
	"This method was automatically generated. Edit it using:"
	"SUnitTutorial edit: #step3"
	^HelpTopic
		title: 'Step 3 - Running our first test method'
		contents: 
'To run our test case method we can evaluate the following code snippet in a workspace:

	PersonTest run: #testInstanceCreation

If you print the result then the following will appear:

      1 run, 0 passes, 0 skipped, 0 expected failures, 0 failures, 1 errors, 0 unexpected passes

This tells us that one test has been run and one error occurred while testing. Currently we dont have all messages implemented - so the test has to fail. 

If you want to debug the test to see what has happened you can evaluate:

     PersonTest debug: #testInstanceCreation



 
	!!' readStream nextChunkText! !

!SUnitTutorial class methodsFor: 'pages' stamp: ''!
step4
	"This method was automatically generated. Edit it using:"
	"SUnitTutorial edit: #step4"
	^HelpTopic
		title: 'Step 4 - Using the TestRunner'
		contents: 
'Testing by evaluating an expression as we is not very convenient - so it is better to open the TestRunner - a user interface tool displaying all the tests in the system. You can start it either using the world menu or by evaluating 

    TestRunner open

in a workspace.

Scroll down until you find the class category ''MyApp-Tests-Model'' and select the test by clicking on the class PersonTest. It is possible to select more than one test/category. Now click on "Run selected". 

If you run the test in the test runner it will be marked red since it contains errors. The test runner will also show you the result of the test run:

     1 run, 0 passes, 0 skipped, 0 expected failures, 0 failures, 1 errors, 0 unexpected passes

If you click on the failed method in the lower right pane the debugger will open.!!' readStream nextChunkText! !

!SUnitVisitor commentStamp: ''!
I  am an abstract visitor for SUnit.

At my level I  just define the API  a SUnit visitor should implement and some parts of the visit that is likely to be common for my concrete subclasses.

My subclasses should at least override #visitTestCase:. See SunitTestsCounter for a simple concrete example!
!SUnitVisitor methodsFor: 'visiting' stamp: ''!
visitTestSuite: aTestSuite
	"Defines the behaviour while visiting a TestSuite.
	 The default implementation below is to iterate on the objects in #tests and return the results of the visit.
	"
	^ aTestSuite tests collect: [ :test |
		test acceptSUnitVisitor: self ]! !

!SUnitVisitor methodsFor: 'visiting' stamp: ''!
visitTestCase: aTestCase
	"Defines the behaviour while visiting a TestCase.
	 This method must be overriden by concrete subclasses.
	"
	^ self subclassResponsibility! !

!SUnitVisitor methodsFor: 'visiting' stamp: ''!
visitRPackageSet: aRRPackageSet
	"Defines the behaviour while visiting a RPackageSet.
	 The default implementation below is to visit all RPackages contained in the package set.
	"
	^ aRRPackageSet packages
		collect: [ :package | package acceptSUnitVisitor: self ]! !

!SUnitVisitor methodsFor: 'visiting' stamp: ''!
visitRPackage: aRPackage
	"Defines the behaviour while visiting a RPackage.
	 The default implementation below is to visit all TestCase subclasses in the package.
	"
	^ aRPackage definedClasses
		select: [ :class | (class isTestCase) and: [ class isAbstract not ] ]
		thenCollect: [ :class | class acceptSUnitVisitor: self ]! !

!SUnitVisitor methodsFor: 'visiting' stamp: ''!
visitTestCaseClass: aTestCaseClass
	"Defines the behaviour while visiting a TestCase class.
	 The default implementation below is to build the suite from local test selectors and visit the suite built.
	"
	^ aTestCaseClass suite
		acceptSUnitVisitor: self! !

!SUnitVisitor methodsFor: 'visiting' stamp: ''!
visit: anObject
	^ anObject acceptSUnitVisitor: self! !

!SVColorSelectorMorph commentStamp: ''!
A colour selector that displays an area with saturation on the x axis and volume on the y axis. Provides interactive selection of colour by mouse. For the moment it is event rather than model based.
Setting the color will specify the hue and setting the selectedColor will specify the saturation and volume (may have a different hue to that displayed if not in sync).!
!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
color: aColor
	"Set the gradient colors."
	
	self
		basicColor: aColor;
		selectedColor: (Color h: aColor hue s: self selectedColor saturation v: self selectedColor brightness)! !

!SVColorSelectorMorph methodsFor: 'event handling' stamp: ''!
mouseLeaveDragging: evt
	"Make the location morph visible when leaving."
	
	evt hand showTemporaryCursor: nil.
	self showLocation! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
selectedColor
	"Answer the value of selectedColor"

	^selectedColor ifNil: [self color]! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
basicColor: aColor
	"Set the gradient colors."
	
	super color: aColor beOpaque.
	self
		fillStyle: self gradient! !

!SVColorSelectorMorph methodsFor: 'event handling' stamp: ''!
mouseEnterDragging: evt
	"Make the location morph invisible when entering."
	
	self hideLocation.
	evt hand showTemporaryCursor: (Cursor crossHair copy offset: -9 @ -9).! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
blackGradientMorph
	"Answer the black gradient morph."

	^Morph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		fillStyle: self blackGradient! !

!SVColorSelectorMorph methodsFor: 'instance creation' stamp: ''!
newLocationMorph
	"Answer a new morph indicating the location of the selected color."

	^ImageMorph new
		form: Cursor crossHair withMask asCursorForm! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
selectedColor: aColor
	"Set the value of selectedColor."

	selectedColor := aColor.
	self locationMorph visible ifTrue: [self updateSelectedLocation].
	self triggerEvent: #colorSelected with: aColor! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
locationMorph
	"Answer the value of locationMorph"

	^ locationMorph! !

!SVColorSelectorMorph methodsFor: 'visual properties' stamp: ''!
fillStyle: fillStyle
	"If it is a color then override with gradient."
	
	fillStyle isColor
		ifTrue: [self color: fillStyle]
		ifFalse: [super fillStyle: fillStyle]! !

!SVColorSelectorMorph methodsFor: 'geometry' stamp: ''!
extent: p
	"Update the gradient directions."

	super extent: p.
	self updateGradients! !

!SVColorSelectorMorph methodsFor: 'event handling' stamp: ''!
mouseMove: evt 
	"Handle a mouse move event. Select the color at the mouse position."
	
	evt redButtonPressed
		ifFalse: [^super mouseMove: evt].
	self selectColorAt: evt position.
	^super mouseMove: evt! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
gradient
	"Answer the base gradient."

	|b|
	b := self innerBounds.
	^(GradientFillStyle colors: {Color white. self color})
		origin: b topLeft;
		direction: (b width@0)! !

!SVColorSelectorMorph methodsFor: 'displaying' stamp: ''!
showLocation
	"Show the location morph and update the display."
	
	self locationMorph visible: true; changed.! !

!SVColorSelectorMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOverDragging: evt
	"Yes, make the location morph visible when leaving."
	
	^true! !

!SVColorSelectorMorph methodsFor: '*Morphic-Base' stamp: ''!
borderWidth: anInteger
	"Update the gradients after setting."
	
	super borderWidth: anInteger.
	self updateGradients! !

!SVColorSelectorMorph methodsFor: 'displaying' stamp: ''!
hideLocation
	"Hide the location morph and update the display."

	self locationMorph visible: false; changed! !

!SVColorSelectorMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self locationMorph: self newLocationMorph.
	self
		clipSubmorphs: true;
		color: Color blue;
		borderStyle: (BorderStyle inset width: 1);
		addMorphBack: self locationMorph;
		addMorphBack: self blackGradientMorph! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
locationMorph: anObject
	"Set the value of locationMorph"

	locationMorph := anObject! !

!SVColorSelectorMorph methodsFor: 'pixel access' stamp: ''!
colorAt: aPoint
	"Answer the color in the world at the given point."
	
	^self isInWorld
		ifTrue: [(Display colorAt: aPoint) beOpaque ]
		ifFalse: [Color black]! !

!SVColorSelectorMorph methodsFor: 'updating' stamp: ''!
updateGradients
	"Update the gradient directions."

	|bgm b|
	b := self innerBounds.
	bgm := self submorphs last.
	bgm bounds: b.
	bgm fillStyle
		origin: b topLeft;
		direction: 0@b height.
	self fillStyle
		origin: b topLeft;
		direction: (b width@0).
	self updateSelectedLocation! !

!SVColorSelectorMorph methodsFor: 'layout' stamp: ''!
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 updateGradients! !

!SVColorSelectorMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt 
	"Handle a mouse down event. Select the color at the mouse position."
	
	evt redButtonPressed
		ifFalse: [^super mouseDown: evt].
	evt hand showTemporaryCursor: (Cursor crossHair copy offset: -9 @ -9).
	self hideLocation.
	self selectColorAt: evt position.
	^super mouseDown: evt! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Pass on to the border too."
	
	super adoptPaneColor: paneColor.
	self borderStyle baseColor: paneColor twiceDarker! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
blackGradient
	"Answer the black gradient. Top to bottom, transparent to black."

	^(InterpolatedGradientFillStyle colors: {Color black alpha: 0. Color black})
		origin: self innerBounds topLeft;
		direction: 0@self innerBounds height! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
selectedLocation
	"Answer the location within the receiver of the selected colour
	relative to the receiver's top left."

	|b c x y|
	b := self innerBounds.
	c := self selectedColor.
	x := c saturation * (b width - 1).
	y := 1 - c brightness * (b height - 1).
	^(x truncated @ y truncated) + b topLeft! !

!SVColorSelectorMorph methodsFor: 'event handling' stamp: ''!
mouseUp: evt 
	"Handle a up event. Show the location morph again."
	
	evt hand showTemporaryCursor: nil.
	self updateSelectedLocation.
	self locationMorph visible: true! !

!SVColorSelectorMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	"Yes for down and move.." 

	^true! !

!SVColorSelectorMorph methodsFor: 'accessing' stamp: ''!
selectColorAt: aPoint
	"Set the color at the given position."
	
	|b p|
	b := self innerBounds.
	p := (b containsPoint: aPoint)
		ifTrue: [aPoint]
		ifFalse: [b pointNearestTo: aPoint].
	p := p - b topLeft / b extent.
	self selectedColor: (Color
		h: self color hue
		s: p x
		v: 1.0 - p y)! !

!SVColorSelectorMorph methodsFor: 'updating' stamp: ''!
updateSelectedLocation
	"Position the location morph to indicate the selected colour."
	
	self locationMorph
		position: (self selectedLocation - (self locationMorph extent // 2 + (self locationMorph extent \\ 2)))! !

!SaveCommandLineHandler commentStamp: ''!
Usage: save <imageBaseName> [--delete-old]
 	<imageName>     a base name for the image
	--delete-old    remove the old image and changes file
	
Documentation:
Saves the image and changes file under a new name.

Examples:
	# create a 'bar.image' and 'foo.changes'
	pharo Pharo.image save bar
	# create the same file as in the previous example but delete Foo.image and Foo.changes
	pharo Pharo.image save bar --delete-old!
!SaveCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self activateHelp
		ifTrue: [  ^ self ].
	
	((self hasOption: 'delete-old') 
		ifTrue: [ self arguments size = 2 ]
		ifFalse: [ self arguments size = 1])
			ifFalse: [ 
				self printHelp.
				^ self exitFailure: 'Missing Arguments' ].
		
	self saveImage.
		! !

!SaveCommandLineHandler methodsFor: 'actions' stamp: ''!
saveImage
	| imageName oldImageFile oldChangesFile |
	
	imageName := self arguments detect: [ :arg| arg ~= '--delete-old' ].
	oldImageFile := File named: Smalltalk imagePath.
	oldChangesFile := File named: (Smalltalk imagePath copyUpToLast: '.') , '.changes'.
	
	(Smalltalk saveAs: imageName)
		ifTrue: [ 
			"rebooting, when executing this, we are already in the renamed image" 
			^ self ].
	
	"...otherwise continuing"
	(self hasOption: 'delete-old')
		ifFalse: [ ^ self exitSuccess ].
	
	oldImageFile delete.
	oldChangesFile delete.
	
	self exitSuccess.! !

!SaveCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'save'! !

!SaveCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'Rename the image and changes file'! !

!ScaledDecimal commentStamp: ''!
ScaledDecimal implement a special kind of Fraction that prints in decimal notation.
It uses a limited number of digits (scale) after the decimal separation dot and round the result.
Note that a ScaledDecimal does not printOn: exactly, however it will storeOn: exactly because the full precision fraction is kept in memory.

This is mostly usefull with denominators being powers of 10.!
!ScaledDecimal methodsFor: 'comparing' stamp: ''!
< aNumber
	aNumber class = self class ifTrue: [^self asFraction < aNumber asFraction].
	^self asFraction < aNumber! !

!ScaledDecimal methodsFor: '*Math-Operations-Extensions' stamp: ''!
sqrt
	"Answer the square root of the receiver.
	Preserve receiver class and scale if answer is exact.
	Otherwise, answer a Float to denote inexactness."
	| squareRoot |
	squareRoot := self asFraction sqrt.
	^squareRoot isFloat
		ifTrue: [squareRoot]
		ifFalse: [squareRoot asScaledDecimal: scale]! !

!ScaledDecimal methodsFor: 'comparing' stamp: ''!
= aNumber
	aNumber class = self class ifTrue: [^self asFraction = aNumber asFraction].
	^self asFraction = aNumber! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: ''!
* aNumber

	aNumber class = self class ifTrue: [ 
		^ self asFraction * aNumber asFraction asScaledDecimal:
			  scale + aNumber scale ].
	^ self coerce: self asFraction * aNumber! !

!ScaledDecimal methodsFor: 'comparing' stamp: ''!
literalEqual: other
	"Testing equality is not enough.
	It is also necessary to test number of decimal places (scale).
	Otherwise we cannot compile both literals 0.5s1 and 0.50s2 in the same method"
	
	^(super literalEqual: other) and: [self scale = other scale]! !

!ScaledDecimal methodsFor: 'testing' stamp: ''!
isFraction
	"Though kind of Fraction, pretend we are not a Fraction to let coercion works correctly"
	
	^false! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: ''!
/ aNumber
	aNumber class = self class ifTrue: [^self asFraction / aNumber asFraction asScaledDecimal: (scale max: aNumber scale)].
	^self coerce: self asFraction / aNumber! !

!ScaledDecimal methodsFor: 'converting' stamp: ''!
adaptToInteger: rcvr andSend: selector
	"If I am involved in arithmetic with an Integer, convert it to a ScaledDecimal."

	^(rcvr asScaledDecimal: scale) perform: selector with: self! !

!ScaledDecimal methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Append an approximated representation of the receiver on aStream.
	Use prescribed number of digits after decimal point (the scale) using a rounding operation if not exact"
	
	self printOn: aStream showingDecimalPlaces: scale.

	"Append a scale specification so that the number can be recognized as a ScaledDecimal"
	aStream nextPut: $s; print: scale.! !

!ScaledDecimal methodsFor: 'accessing' stamp: ''!
isSelfEvaluating
    "Not all scaled decimal are self evaluating, because they print rounded digits."
    ^self isLiteral! !

!ScaledDecimal methodsFor: 'mathematical functions' stamp: ''!
raisedToInteger: aNumber
	^self class newFromNumber: (super raisedToInteger: aNumber) scale: scale! !

!ScaledDecimal methodsFor: 'comparing' stamp: ''!
> aNumber
	aNumber class = self class ifTrue: [^self asFraction > aNumber asFraction].
	^self asFraction > aNumber! !

!ScaledDecimal methodsFor: 'accessing' stamp: ''!
scale
	^scale! !

!ScaledDecimal methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter writeScaledDecimal: self! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: ''!
squared
	^self class newFromNumber: super squared scale: scale! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: ''!
- aNumber
	aNumber class = self class ifTrue: [^self asFraction - aNumber asFraction asScaledDecimal: (scale max: aNumber scale)].
	^self coerce: self asFraction - aNumber! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: ''!
reciprocal
	^self class newFromNumber: super reciprocal scale: scale! !

!ScaledDecimal methodsFor: 'converting' stamp: ''!
asFraction	
	"Convert the receiver to a Fraction.
	Avoid using numerator / denominator to save a useless and costly gcd: computation"

	^denominator = 1
		ifTrue: [numerator]
		ifFalse: [Fraction numerator: numerator denominator: denominator]! !

!ScaledDecimal methodsFor: 'comparing' stamp: ''!
>= aNumber
	aNumber class = self class ifTrue: [^self asFraction >= aNumber asFraction].
	^self asFraction >= aNumber! !

!ScaledDecimal methodsFor: 'testing' stamp: ''!
isLiteral
	"Answer if this number could be a well behaved literal.
	Well, it would only if evaluating back to self.
	This is not the case of all ScaledDecimals.
	Some have an infinite precision and would need an infinite number of digits to print literally.
	Try for example (3.00s2 reciprocal)."
	
	^denominator = 1 "first test trivial case before engaging arithmetic"
		or: ["Exactly we should test:
				(numerator * (10 raisedTo; scale)) \\ denominator = 0.
				But since we can assume fraction is reduced already this will be simply:"
			(10 raisedTo: scale) \\ denominator = 0]! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: ''!
negated
	^self class newFromNumber: super negated scale: scale! !

!ScaledDecimal methodsFor: 'printing' stamp: ''!
printOn: aStream base: base
	base = 10 ifFalse: [self error: 'ScaledDecimals should be printed only in base 10'].
	self printOn: aStream! !

!ScaledDecimal methodsFor: 'mathematical functions' stamp: ''!
raisedToFraction: aFraction
	| result |
	result := self asFraction raisedToFraction: aFraction.
	^result isFloat
		ifTrue: [result]
		ifFalse: [result asScaledDecimal: scale]! !

!ScaledDecimal methodsFor: '*Math-Operations-Extensions' stamp: ''!
nthRoot: anInteger
	"Answer the nth root of the receiver.
	Preserve receiver class and scale if answer is exact.
	Otherwise, answer a Float to denote inexactness."
	| nthRoot |
	nthRoot := self asFraction nthRoot: anInteger.
	^nthRoot isFloat
		ifTrue: [nthRoot]
		ifFalse: [nthRoot asScaledDecimal: scale]! !

!ScaledDecimal methodsFor: 'private' stamp: ''!
coerce: aNumber
	"Note: this quick hack could be replaced by double dispatching"
	
	aNumber class = self class ifTrue: [^self class newFromNumber: aNumber scale: (scale max: aNumber scale)].
	(aNumber isFraction or: [aNumber isInteger]) ifTrue: [^self class newFromNumber: aNumber scale: scale].
	^aNumber! !

!ScaledDecimal methodsFor: 'mathematical functions' stamp: ''!
raisedTo: aNumber
	^self coerce: (super raisedTo: aNumber)! !

!ScaledDecimal methodsFor: 'private' stamp: ''!
setNumerator: n denominator: d scale: s

	self setNumerator: n denominator: d.
	scale := s! !

!ScaledDecimal methodsFor: '*Math-Operations-Extensions' stamp: ''!
round: numberOfWishedDecimal
	"Round the decimal part of the receiver to be limited to the number of wished decimal. Only leave a fixed amount of decimal."
	
   "(10.156s round: 2) >>> 10.160s3 "
   "(1/3.0s round: 4) >>> 0.3333s4 "

	^(super round: numberOfWishedDecimal) asScaledDecimal: (scale max: numberOfWishedDecimal)! !

!ScaledDecimal methodsFor: 'converting' stamp: ''!
adaptToFraction: rcvr andSend: selector
	"If I am involved in arithmetic with a Fraction, convert it to a ScaledDecimal."

	^(rcvr asScaledDecimal: scale) perform: selector with: self! !

!ScaledDecimal methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	"ScaledDecimal sometimes have more digits than they print (potentially an infinity).
	In this case, do not use printOn: because it would loose some extra digits"
	
	self shouldBePrintedAsLiteral
		ifTrue: [self printOn: aStream]
		ifFalse: [aStream
			nextPut: $(;
		 	store: numerator;
			nextPut: $/;
			store: denominator;
			nextPut: $s;
			store: scale;
			nextPut: $)]! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: ''!
+ aNumber
	aNumber class = self class ifTrue: [^self asFraction + aNumber asFraction asScaledDecimal: (scale max: aNumber scale)].
	^self coerce: self asFraction + aNumber! !

!ScaledDecimal methodsFor: 'comparing' stamp: ''!
<= aNumber
	aNumber class = self class ifTrue: [^self asFraction <= aNumber asFraction].
	^self asFraction <= aNumber! !

!ScaledDecimal class methodsFor: 'instance creation' stamp: ''!
newFromNumber: aNumber scale: anInteger
	| aFraction |
	aFraction := aNumber asFraction.
	^aFraction isFraction
		ifTrue: [self new setNumerator: aFraction numerator denominator: aFraction denominator scale: anInteger]
		ifFalse: [self new setNumerator: aFraction denominator: 1 scale: anInteger]! !

!ScaledDecimal class methodsFor: '*AST-Core-Parser' stamp: ''!
readFrom: stringOrStream 
	"Answer a decimal number as described on stringOrStream.
	The number may not include a leading radix specification, as in 16rFADE,
	nor an exponent like 1.0e-3
	It might have a scale specification at end or not like 10.3s2
	If not, number of digits after decimal point will be used as scale"
	
	^(NumberParser on: stringOrStream) nextScaledDecimal! !

!ScaledDecimalTest commentStamp: ''!
I provide a test suite for ScaledDecimal values. Examine my tests to see how SmallIntegers should behave, and see how to use them.!
!ScaledDecimalTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testExactNthRoot
	| eight thousandth tenth two |
	eight := 8.0s1.
	two := eight raisedTo: 1 / 3.
	self assert: two equals: 2.
	self assert: (two class = eight class and: [ two scale = eight scale ]).
	thousandth := 0.001s3.
	tenth := thousandth raisedTo: 1 / 3.
	self assert: tenth * 10 equals: 1.
	self assert: (tenth class = thousandth class and: [ tenth scale = thousandth scale ])! !

!ScaledDecimalTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testExactSqrt
	| four hundredth tenth two |
	four := 4.0s1.
	two := four sqrt.
	self assert: two equals: 2.
	self assert: (two class = four class and: [ two scale = four scale ]).
	hundredth := 0.01s2.
	tenth := hundredth sqrt.
	self assert: tenth * 10 equals: 1.
	self assert: (tenth class = hundredth class and: [ tenth scale = hundredth scale ])! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testCoercion
	#( #* #+ #- #/) do: [:op |
		self assert: (1.0s1 perform: op with: 2) class equals: ScaledDecimal.
		self assert: (1.0s1 perform: op with: 1/2) class equals: ScaledDecimal.
		self deny: (1.0s1 perform: op with: 1.0) class equals: ScaledDecimal.
		
		self assert: (1 perform: op with: 2.0s1) class equals: ScaledDecimal.
		self assert: (1/2 perform: op with: 2.0s1) class equals: ScaledDecimal.
		self deny: (1.0 perform: op with: 1.0s1) class equals: ScaledDecimal]! !

!ScaledDecimalTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testInexactNthRoot
	| tenth cubicRoot3 fifthRootTenth three |
	three := 3.0s1.
	cubicRoot3 := three raisedTo: 1 / 3.
	self assert: cubicRoot3 isFloat.
	self deny: cubicRoot3 squared equals: 3.
	tenth := 0.10s2.
	fifthRootTenth := tenth raisedTo: 1 / 5.
	self assert: fifthRootTenth isFloat.
	self deny: fifthRootTenth squared equals: tenth! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testAsNumberWithRadix

	| sd |
	sd := '10r-22.2s5' asNumber.
	self assert: ScaledDecimal identicalTo: sd class.
	self assert: sd scale equals: 5.
	self assert: '-22.20000s5' equals: sd printString.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testReadFrom
	"This is related to http://bugs.squeak.org/view.php?id=6779"
	
	self should: [(ScaledDecimal readFrom: '5.3') isKindOf: ScaledDecimal]
		description: 'Reading a ScaledDecimal should answer a ScaledDecimal'.
	self should: [((ScaledDecimal readFrom: '5.3') asScaledDecimal: 1) = (53/10 asScaledDecimal: 1)]
		description: 'ScaledDecimal readFrom: should not use Float intermediate because it would introduce round off errors'.! !

!ScaledDecimalTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testStoreOnRoundTrip
	"this is http://bugs.squeak.org/view.php?id=4378"

	"Both results should be 1.
	ScaledDecimal representations are exact
	(though only scale digits or fractional part are printed)"

	self assert: (self class compiler evaluate: 0.5s1 squared storeString) * 4 equals: 0.5s1 squared * 4.


	"However, exact literals should store literaly
	If not, they would break Decompiler."

	"BUG: i cannot write the test like this:
	self assert:
    		0.5s2 squared storeString = '0.25s2'
	BECAUSE compiler would consider 0.5s2 as = 0.5s1 and would reuse same slot..."

	self assert: 0.25s2 storeString equals: '0.25s2'! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testMultiplicationDoesNotLoosePrecision
	"Check that not only the largest scale is considered but the sum of the two scales. See issue #8668"
	
	self assert: 1.003s3 * 1.006s4 equals: 1.0090180s7! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testRaisedToInteger
	"Raising to integer should preserve class and scale"
	
	self assert: (3.0s1 raisedToInteger: -1) scale equals: 1.
	self assert: (3.0s1 raisedToInteger: -1) equals: (1/3).
	self assert: (3.0s1 raisedToInteger: 0) scale equals: 1.
	self assert: (3.0s1 raisedToInteger: 0) equals: 1.
	self assert: (3.0s1 raisedToInteger: 1) scale equals: 1.
	self assert: (3.0s1 raisedToInteger: 1) equals: 3.
	self assert: (3.0s1 raisedToInteger: 2) scale equals: 1.
	self assert: (3.0s1 raisedToInteger: 2) equals: 9.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testLiteral

	| sd |
	sd := 1.40s2.
	self assert: ScaledDecimal identicalTo: sd class.
	self assert: sd scale equals: 2.
	self assert: '1.40s2' equals: sd printString! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testAsNumberNegatedWithoutDecimalPoint

	| sd |
	sd := '-123s0' asNumber.
	self assert: ScaledDecimal identicalTo: sd class.
	self assert: sd scale equals: 0.
	self assert: '-123s0' equals: sd printString.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testPrintString
	"The printed representation of a ScaledDecimal is rounded.
	Note that old implementation was truncated."

	| sd |
	sd := (13 / 11) asScaledDecimal: 6.
	self assert: '1.181818s6' equals: sd printString.
	sd := (13 / 11) asScaledDecimal: 5.
	self assert: '1.18182s5' equals: sd printString.
	sd := (13 / 11) asScaledDecimal: 5.
	self deny: '1.18181s5' equals: sd printString! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testScaleExtension

	#( #+ #- #/ ) do: [ :op | "The scale is extended to the larger one in case of arithmetic operation"
		self assert: (2.5s1 perform: op with: 1.000s3) scale equals: 3.
		self assert: (3.5000s4 perform: op with: 1.0s1) scale equals: 4 ].
	"The scale for multiplication is the sum of the operand scales"
	self assert: (2.5s1 * 1.000s3) scale equals: 4.
	self assert: (3.5000s4 * 1.0s1) scale equals: 5! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testConvertFromFloat

	| aFloat sd f2 diff |
	aFloat := 11/13 asFloat.
	sd := aFloat asScaledDecimal: 2.
	self assert: 2 equals: sd scale.
	self assert: '0.85s2' equals: sd printString.
	self assert: '-0.85s2' equals: sd negated printString.
	f2 := sd asFloat.
	diff := f2 - aFloat.
	self assert: diff abs < 1.0e-9. "actually, f = f2, but this is not a requirement"! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testConvertFromFraction

	| sd |
	sd := (13 / 11) asScaledDecimal: 6.
	self assert: ScaledDecimal identicalTo: sd class.
	self assert: '1.181818s6' equals: sd printString.
	self assert: 6 equals: sd scale.
	sd := (-13 / 11) asScaledDecimal: 6.
	self assert: ScaledDecimal identicalTo: sd class.
	self assert: '-1.181818s6' equals: sd printString.
	self assert: 6 equals: sd scale! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testAsNumberWithoutDecimalPoint2

	| sd |
	sd := '123s2' asNumber.
	self assert: ScaledDecimal identicalTo: sd class.
	self assert: sd scale equals: 2.
	self assert: '123.00s2' equals: sd printString.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testConvertFromIntegerWithScale
	"Converting an Integer with asScaledDecimal: does now honour the scale passed as message argument."

	| sd |
	sd := 13 asScaledDecimal: 6.
	self assert: 6 equals: sd scale.
	self assert: '13.000000s6' equals: sd printString.
	sd := -13 asScaledDecimal: 4.
	self assert: 4 equals: sd scale.
	self assert: '-13.0000s4' equals: sd printString.
	sd := 130000000013 asScaledDecimal: 3.
	self assert: 3 equals: sd scale.
	self assert: '130000000013.000s3' equals: sd printString.
	sd := -130000000013 asScaledDecimal: 1.
	self assert: 1 equals: sd scale.
	self assert: '-130000000013.0s1' equals: sd printString! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testRounded
	self assert: (1999/1000s2) printString equals: '2.00s2'.
	self assert: (-1999/1000s2) printString equals: '-2.00s2'! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testConvertFromNonDecimalFraction
	"Converting a Fraction with asScaledDecimal use default number of decimals when the series of decimals is infinite."
	| defaultNumberOfDecimals |
	defaultNumberOfDecimals := (1/3) asScaledDecimal scale.
	#(6 7 9 11 12 13 14 17 18 19 21 22 23 24) do: [:den |
		| sd sd2 |
		sd := (1/den) asScaledDecimal.
		self assert: sd scale equals: defaultNumberOfDecimals.
		sd2 := ScaledDecimal readFrom: sd printString.
		self deny: sd equals: sd2
		]! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testIsLiteral
	"This test is related to http://bugs.squeak.org/view.php?id=6796"
	
	self assert: 1.00s2 isLiteral description: 'every literal obviously isLiteral'.
	
	"Note that (1 / 3.00s2) is not a well behaved literal,
	because it does not re-evaluate to self...
	Every literal should be evaluated as self (see isSelfEvaluating).
	There is currently no way to print it as a literal.
	So i propose it shall not answer true."
	self deny: (1/3.00s2) isLiteral description: 'this number cannot represent itself as a literal'.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testOneRaisedToInteger
	"One might be handled specially"
	
	self assert: (1.0s1 raisedToInteger: -1) scale equals: 1.
	self assert: (1.0s1 raisedToInteger: -1) equals: 1.
	self assert: (1.0s1 raisedToInteger: 0) scale equals: 1.
	self assert: (1.0s1 raisedToInteger: 0) equals: 1.
	self assert: (1.0s1 raisedToInteger: 1) scale equals: 1.
	self assert: (1.0s1 raisedToInteger: 1) equals: 1.
	self assert: (1.0s1 raisedToInteger: 2) scale equals: 1.
	self assert: (1.0s1 raisedToInteger: 2) equals: 1.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testAsNumberWithExtendedScale

	| sd |
	sd := '123s2' asNumber.
	self assert: ScaledDecimal identicalTo: sd class.
	self assert: sd scale equals: 2.
	self assert: '123.00s2' equals: sd printString.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testZeroRaisedToInteger
	"Zero might be handle specially"
	
	self should: [0.0s1 raisedToInteger: -1] raise: Error.
	self assert: (0.0s1 raisedToInteger: 0) equals: 1.
	self assert: (0.0s1 raisedToInteger: 0) scale equals: 1.
	self assert: (0.0s1 raisedToInteger: 1) equals: 0.
	self assert: (0.0s1 raisedToInteger: 1) scale equals: 1.
	self assert: (0.0s1 raisedToInteger: 2) equals: 0.
	self assert: (0.0s1 raisedToInteger: 2) scale equals: 1.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testAsNumberWithoutDecimalPoint

	| sd |
	sd := '123s0' asNumber.
	self assert: ScaledDecimal identicalTo: sd class.
	self assert: sd scale equals: 0.
	self assert: '123s0' equals: sd printString.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testAsNumber
	"Ensure no loss of precision"

	| sd |
	sd := '1.40s2' asNumber.
	self assert: ScaledDecimal identicalTo: sd class.
	self assert: sd scale equals: 2.
	self assert: '1.40s2' equals: sd printString.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testAsNumberWithSuperfluousDecimalPoint

	| sd |
	sd := '123.s2' asNumber.
	self deny: ScaledDecimal == sd class description: 'It used to, but this syntax is not valid Smalltalk'.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testAsNumberNegatedWithoutDecimalPoint2

	| sd |
	sd := '-123s2' asNumber.
	self assert: ScaledDecimal identicalTo: sd class.
	self assert: sd scale equals: 2.
	self assert: '-123.00s2' equals: sd printString.! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testConvertFromInteger
	"Converting an Integer with asScaledDecimal use strictly necessary number of decimal places: 0."

	| sd |
	sd := 13 asScaledDecimal.
	self assert: 0 equals: sd scale.
	self assert: '13s0' equals: sd printString.
	sd := -13 asScaledDecimal.
	self assert: 0 equals: sd scale.
	self assert: '-13s0' equals: sd printString.
	sd := 130000000013 asScaledDecimal.
	self assert: 0 equals: sd scale.
	self assert: '130000000013s0' equals: sd printString.
	sd := -130000000013 asScaledDecimal.
	self assert: 0 equals: sd scale.
	self assert: '-130000000013s0' equals: sd printString! !

!ScaledDecimalTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ ScaledDecimal! !

!ScaledDecimalTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testInexactSqrt
	| tenth sqrt3 sqrtTenth three |
	three := 3.0s1.
	sqrt3 := three sqrt.
	self assert: sqrt3 isFloat.
	self deny: sqrt3 squared equals: 3.
	tenth := 0.10s2.
	sqrtTenth := tenth sqrt.
	self assert: sqrtTenth isFloat.
	self deny: sqrtTenth squared equals: tenth! !

!ScaledDecimalTest methodsFor: 'tests' stamp: ''!
testConvertFromDecimalFraction
	"Converting a Fraction with asScaledDecimal use strictly necessary number of decimal places when possible."
	0 to: 11 do: [:pow2 |
		0 to: 11 do: [:pow5 |
			| fraction sd sd2 |
			fraction := 13 / (2 raisedTo: pow2) / (5 raisedTo: pow5).
			sd := fraction asScaledDecimal.
			self assert: sd scale equals: (pow2 max: pow5).
			sd2 := ScaledDecimal readFrom: sd printString.
			self assert: sd equals: sd2]].! !

!Schedule commentStamp: ''!
I represent a powerful class for implementing recurring schedules.!
!Schedule methodsFor: 'testing' stamp: ''!
includes: aDateAndTime

	| dt |
	dt := aDateAndTime asDateAndTime.
	self scheduleDo: [ :e | e = dt ifTrue: [^true] ].
	^ false.! !

!Schedule methodsFor: 'enumerating' stamp: ''!
between: aStart and: anEnd do: aBlock
	"from Cuis 99"
	
	| element end i startDate |
	end := self end min: anEnd.

	element := self start.	
	"Performance optimization. Avoid going through unnecesary days if easy."
	startDate := aStart asDate.
	(startDate > element asDate and: [ self everyDayAtSameTimes ]) ifTrue: [
		element := DateAndTime date: startDate time: element asTime ].

	i := 1.
	[ element < aStart ] whileTrue: [
		element := element + (schedule at: i).
		i := i + 1.
		i > schedule size ifTrue: [i := 1]].

	[ element <= end ] whileTrue: [
		aBlock value: element.
		element := element + (schedule at: i).
		i := i + 1.
		i > schedule size ifTrue: [i := 1]]
.! !

!Schedule methodsFor: 'enumerating' stamp: ''!
schedule: anArrayOfDurations

	schedule := anArrayOfDurations! !

!Schedule methodsFor: 'private' stamp: ''!
scheduleDuration
	^ schedule sum! !

!Schedule methodsFor: 'enumerating' stamp: ''!
dateAndTimes

	| dateAndTimes |
	dateAndTimes := OrderedCollection new.
	self scheduleDo: [ :e | dateAndTimes add: e ].
	^ dateAndTimes asArray.! !

!Schedule methodsFor: 'enumerating' stamp: ''!
schedule
	^ schedule! !

!Schedule methodsFor: 'enumerating' stamp: ''!
scheduleDo: aBlock

	self between: (self start) and: (self end) do: aBlock.! !

!Schedule methodsFor: 'private' stamp: ''!
everyDayAtSameTimes
	"Answer false if unknown"
	
	| count |
	count := (Duration days: 1) / self scheduleDuration.
	^ count >= 1 and: [ count isInteger ]! !

!ScheduleTest commentStamp: ''!
SUnit tests for recurring schedules (class Schedule).!
!ScheduleTest methodsFor: 'tests' stamp: ''!
testIncludes
	self assert: (aSchedule includes: (DateAndTime year: 2003 month: 6 day: 15 hour: 20 minute: 30 second: 0 offset: 0 hours))! !

!ScheduleTest methodsFor: 'running' stamp: ''!
tearDown

	DateAndTime localTimeZone: restoredTimeZone.
	super tearDown! !

!ScheduleTest methodsFor: 'tests' stamp: ''!
testSchedule
	self assert: aSchedule schedule size equals: 2.
	self assert: aSchedule schedule first equals: 1 days.
	self assert: aSchedule schedule second equals: 6 days! !

!ScheduleTest methodsFor: 'tests' stamp: ''!
testDaysOfWeekAreConsistent
	| originalDayOfWeekSet modifiedDayOfWeekSet start end |
	originalDayOfWeekSet := (aSchedule dateAndTimes collect: [ :each | each dayOfWeek ]) asSet.
	start := DateAndTime
		year: 2003
		month: 1
		day: 5
		hour: 20
		minute: 30.
	end := DateAndTime
		year: 2003
		month: 6
		day: 4
		hour: 20
		minute: 30.
	modifiedDayOfWeekSet := OrderedCollection new.
	aSchedule between: start and: end do: [ :eachStart | modifiedDayOfWeekSet add: eachStart dayOfWeek ].
	self assert: originalDayOfWeekSet equals: modifiedDayOfWeekSet asSet! !

!ScheduleTest methodsFor: 'tests' stamp: ''!
testExampleFromSwikiPage
	"It is often neccessary to schedule repeated events, like airline flight schedules, TV programmes, and file backups.
	 Schedule is a Timespan which maintains an array of Durations.
	 The durations specify the offset to the next scheduled DateAndTime. "
	"Consider a TV programme scheduled for 8:30pm every Saturday and Sunday for the current year. "
	"Find the first Saturday and set its time to 20h30"
	| sat shows |
	sat := Year current asMonth dates detect: [ :d | d dayOfWeekName = #Saturday ].
	sat := sat start + (Duration hours: 20.5).
	"Create a schedule" 
	shows := Schedule starting: sat ending: Year current end.
	shows schedule: { Duration days: 1. Duration days: 6 }.
	"To inspect:"
	shows dateAndTimes.
	shows dateAndTimes collect: [ :dt | dt dayOfWeekName ].! !

!ScheduleTest methodsFor: 'tests' stamp: ''!
testDateAndTimes
	| answer |
	self assert: aSchedule dateAndTimes size equals: 104.
	self assert: aSchedule dateAndTimes first equals: firstEvent.
	answer := true.
	aSchedule dateAndTimes do: [ :each | (each dayOfWeekName = 'Saturday' or: [ each dayOfWeekName = 'Sunday' ]) ifFalse: [ ^ false ] ].
	self assert: answer! !

!ScheduleTest methodsFor: 'tests' stamp: ''!
testFromDateAndTime
	| oc1 oc2 |
	oc1 := OrderedCollection new.
	DateAndTime today to: DateAndTime tomorrow by: 10 hours do: [ :dt | oc1 add: dt ].

	oc2 := {DateAndTime today . (DateAndTime today + 10 hours) . (DateAndTime today + 20 hours)}.

	self assert: oc1 asArray equals: oc2! !

!ScheduleTest methodsFor: 'tests' stamp: ''!
testMonotonicity

	| t1 t2 t3 t4 |
	t1 := DateAndTime now.
	t2 := DateAndTime now.
	t3 := DateAndTime now.
	t4 := DateAndTime now.

	self 
		assert: (	t1 <= t2);
		assert: (	t2 <= t3);
		assert: (	t3 <= t4).! !

!ScheduleTest methodsFor: 'coverage' stamp: ''!
selectorsToBeIgnored

	| private | 
	private := #( #printOn: ).

	^ super selectorsToBeIgnored, private! !

!ScheduleTest methodsFor: 'tests' stamp: ''!
testBetweenAndDoIncludedInSchedule
	| count |
	count := 0.
	aSchedule between: (DateAndTime year: 2003 month: 4 day: 1) and: (DateAndTime year: 2003 month: 4 day: 30) do: [ :each | count := count + 1 ].
	self assert: count equals: 8! !

!ScheduleTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ Schedule! !

!ScheduleTest methodsFor: 'tests' stamp: ''!
testBetweenAndDoDisjointWithSchedule
	| count |
	count := 0.
	aSchedule between: (DateAndTime year: 2004 month: 4 day: 1) and: (DateAndTime year: 2004 month: 4 day: 30) do: [ :each | count := count + 1 ].
	self assert: count equals: 0! !

!ScheduleTest methodsFor: 'tests' stamp: ''!
testBetweenAndDoOverlappingSchedule
	| count |
	count := 0.
	aSchedule between: (DateAndTime year: 2002 month: 12 day: 1) and: (DateAndTime year: 2003 month: 1 day: 31) do: [ :each | count := count + 1 ].
	self assert: count equals: 8! !

!ScheduleTest methodsFor: 'running' stamp: ''!
setUp
 	 "Schedule is a type of Timespan representing repeated occurrences of the same event. 
	The beginning of the schedule is the first occurrence of the event.
	A schedule maintains an array of Durations. 
	Each durations specify the offset to the next scheduled each. 
	The duration of each occurrence of the event is not specified. 
	Nor are any other attributes such as name"

	super setUp.
	restoredTimeZone := DateAndTime localTimeZone.
	DateAndTime localTimeZone: (TimeZone timeZones detect: [:tz | tz abbreviation = 'GMT']).

	"Create aSchedule with an event scheduled for 8:30pm every Saturday 
	and Sunday for the year 2003. "
	"Create the first event occurring on the first Saturday at 8:30 pm: 1/4/03"
	firstEvent :=  DateAndTime year: 2003 month: 1 day: 4 hour: 20 minute: 30. 
	
	"Create a schedule for one year starting with the first event" 
	aSchedule := Schedule starting: firstEvent duration: 52 weeks.

	"Schedule the recurring events by scheduling the time in between each one.  
	One day for Sat-Sun. 6 days for Sun-Sat" 
	aSchedule schedule: { Duration days: 1. Duration days: 6 }.! !

!ScrollBar commentStamp: ''!
Inspired by an oiginal design of Hans-Martin Mosner, this ScrollBar is intended to exercise the handling of input events in Morphic.  With sufficient flexibility in this area, all particular behavior can be concentrated in this single class with no need to specialize any other morphs to achieve button, slider and menu-button behavior.

Once we have this working, put in logic for horizontal operation as well.

CachedImages was added to reduce the number of forms created and thrown away. This will be helpful for Nebraska and others as well.!
!ScrollBar class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!ScrollBarMorph commentStamp: ''!
Inspired by an oiginal design of Hans-Martin Mosner, this ScrollBar is intended to exercise the handling of input events in Morphic.  With sufficient flexibility in this area, all particular behavior can be concentrated in this single class with no need to specialize any other morphs to achieve button, slider and menu-button behavior.

Once we have this working, put in logic for horizontal operation as well.

CachedImages was added to reduce the number of forms created and thrown away. This will be helpful for Nebraska and others as well.!
!ScrollBarMorph methodsFor: 'accessing' stamp: ''!
lastPaneColor: anObject
	lastPaneColor := anObject! !

!ScrollBarMorph methodsFor: 'geometry' stamp: ''!
totalSliderArea
	| upperBoundsButton |
	upperBoundsButton := upButton.
	^ bounds isWide
		ifTrue: [ upButton right > upperBoundsButton right ifTrue: [ upperBoundsButton := upButton ].
			upperBoundsButton bounds topRight corner: downButton bounds bottomLeft ]
		ifFalse: [ upButton bottom > upperBoundsButton bottom ifTrue: [ upperBoundsButton := upButton ].
			upperBoundsButton bounds bottomLeft corner: downButton bounds topRight ]! !

!ScrollBarMorph methodsFor: 'scroll timing' stamp: ''!
resetTimer
	timeOfMouseDown := Time millisecondClockValue.
	timeOfLastScroll := timeOfMouseDown - 1000 max: 0.
	nextPageDirection := nil.
	currentScrollDelay := nil! !

!ScrollBarMorph methodsFor: 'scrolling' stamp: ''!
scrollBarAction
	^self valueOfProperty: #scrollBarAction! !

!ScrollBarMorph methodsFor: 'initialize' stamp: ''!
downImage
	"answer a form to be used in the down button"
	^ self class
		arrowOfDirection: (bounds isWide
				ifTrue: [#right]
				ifFalse: [#bottom])
		size: (self buttonExtent x min: self buttonExtent y)
		color: self buttonImageColor! !

!ScrollBarMorph methodsFor: 'initialization' stamp: ''!
initializePagingArea
	"Initialize the receiver's pagingArea."
	
	pagingArea := Morph
				newBounds: self totalSliderArea
				color: (Color
						r: 0.6
						g: 0.6
						b: 0.8).
	pagingArea
		on: #mouseDown
		send: #scrollPageInit:
		to: self.
	pagingArea
		on: #mouseUp
		send: #finishedScrolling
		to: self.
	self addMorph: pagingArea.
	pagingArea cornerStyle: (self theme scrollbarPagingAreaCornerStyleIn: self window).
	pagingArea on: #mouseUp send: #finishedScrolling: to: self.
	self on: #mouseEnter send: #mouseEnterPagingArea: to: self.
	self on: #mouseLeave send: #mouseLeavePagingArea: to: self! !

!ScrollBarMorph methodsFor: '*Morphic-Widgets-FastTable' stamp: ''!
canScrollDown

	^value < 1! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverThumbButtonFillStyle
	"Return the mouse over thumb fillStyle for the receiver."
	
	^self theme scrollbarMouseOverThumbButtonFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
pressedButtonBorderStyle
	"Return the pressed button borderStyle for the receiver."
	
	^self theme scrollbarPressedButtonBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'initialization' stamp: ''!
initializeDownButton
	"initialize the receiver's downButton"

	downButton := self theme newScrollBarDownButtonFor: self.
	
	downButton color: self thumbColor.
	downButton 
		on: #mouseDown
		send: #scrollDownInit
		to: self.
	downButton 
		on: #mouseUp
		send: #finishedScrolling
		to: self.
	self updateDownButtonImage.
	downButton 
		borderWidth: 1;
		borderColor: Color lightGray.
		
	downButton cornerStyle: (self theme scrollbarButtonCornerStyleIn: self window).
	downButton on: #mouseUp send: #finishedScrolling: to: self.
	downButton on: #mouseEnter send: #mouseEnterDownButton: to: self.
	downButton on: #mouseLeave send: #mouseLeaveDownButton: to: self.
	self addMorph: downButton! !

!ScrollBarMorph methodsFor: 'scrolling' stamp: ''!
scrollLeft: count
	self scrollUp: count! !

!ScrollBarMorph methodsFor: 'scrolling' stamp: ''!
scrollRight: count
	self scrollDown: count! !

!ScrollBarMorph methodsFor: 'update' stamp: ''!
themeChanged
	"Update the buttons, slider and paging area."

	self
		removeAllMorphs;
		initializeSlider.
	super themeChanged! !

!ScrollBarMorph methodsFor: 'initialize' stamp: ''!
updateDownButtonImage
	"update the receiver's downButton.  put a new image inside"
	downButton removeAllMorphs.
	downButton
		addMorphCentered: (ImageMorph new form: self downImage)! !

!ScrollBarMorph methodsFor: 'update' stamp: ''!
updateDownButtonBounds
	"update the receiver's downButton bounds"
	
	downButton bounds: (self theme scrollBarDownButtonBoundsFor: self)! !

!ScrollBarMorph methodsFor: 'update' stamp: ''!
updateSliderBounds
	"Initialize the receiver's slider."
	
	self 
		updateUpButtonBounds;
		updateDownButtonBounds;
		updatePagingAreaBounds.
	super updateSliderBounds.! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
finishedScrolling
	"Scrolling has finished (button or paging area)."
	
	|bcu bcd|
	bcu := upButton borderStyle baseColor.
	bcd := downButton borderStyle baseColor.
	self stopStepping.
	self scrollBarAction: nil.
	upButton borderRaised.
	upButton borderStyle baseColor: bcu.
	downButton borderRaised.
	downButton borderStyle baseColor: bcd.
	pagingArea
		fillStyle: self normalFillStyle;
		borderStyle: self normalBorderStyle! !

!ScrollBarMorph methodsFor: '*Morphic-Widgets-FastTable' stamp: ''!
scrollUpByPageDelta
	self scrollUp: self pageDelta! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
normalThumbFillStyle
	"Return the normal thumb fillStyle for the receiver."
	
	^self theme scrollbarNormalThumbFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
normalFillStyle
	"Return the normal fillStyle for the receiver."
	
	^self theme scrollbarNormalFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverButtonFillStyle
	"Return the mouse over button fillStyle for the receiver."
	
	^self theme scrollbarMouseOverButtonFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'scrolling' stamp: ''!
scrollUp: count
	self setValue: (value - (scrollDelta * count) - 0.000001 max: 0.0)! !

!ScrollBarMorph methodsFor: 'mouse' stamp: ''!
mouseLeaveUpButton: event
	"The mouse has left the up button."

	event redButtonPressed
		ifFalse: [ 
			upButton
				fillStyle: self normalButtonFillStyle;
				borderStyle: self normalButtonBorderStyle;
				changed ]! !

!ScrollBarMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	scrollDelta := 0.02.
	pageDelta := 0.2.! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
normalBorderStyle
	"Return the normal borderStyle for the receiver."
	
	^self theme scrollbarNormalBorderStyleFor: self! !

!ScrollBarMorph methodsFor: '*Morphic-Widgets-FastTable' stamp: ''!
pageDelta
	^ pageDelta! !

!ScrollBarMorph methodsFor: 'initialize' stamp: ''!
menuImage
	"answer a form to be used in the menu button"
	^ self class
		boxOfSize: (self buttonExtent x min: self buttonExtent y)
		color: self thumbColor! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverThumbBorderStyle
	"Return the mouse over thumb borderStyle for the receiver."
	
	^self theme scrollbarMouseOverThumbBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
buttonImageColor
	"Answer the color to use for the arrow image of a button."

	^self theme scrollbarImageColorFor: self! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
scrollUpInit
	"Initialize a scroll up (from button) operation.
	Fixed to perform immediately with deferred 
	stepping for subsequent hold of button."

	|bc|
	bc := upButton borderStyle baseColor.
	upButton borderInset.
	upButton borderStyle baseColor: bc.
	self resetTimer.
	self scrollBarAction: #doScrollUp.
	self doScrollUp.
	self
		startStepping: #stepAt:
		at: Time millisecondClockValue + self stepTime
		arguments: nil stepTime: nil.
	upButton fillStyle: self pressedButtonFillStyle.
	upButton borderStyle: self pressedButtonBorderStyle! !

!ScrollBarMorph methodsFor: 'update' stamp: ''!
adoptGradientColor: aColor
	"Adopt the given pane color."

	|c fs bfs bs bbs|
	aColor ifNil:[^self].
	c := aColor.
	fs := self normalThumbFillStyle.
	bfs := self normalButtonFillStyle.
	bs := self normalThumbBorderStyle.
	bbs := self normalButtonBorderStyle.
	sliderColor := c.
	downButton
		fillStyle: bfs;
		borderStyle: bbs.
	upButton
		fillStyle: bfs shallowCopy;
		borderStyle: bbs.
	slider
		fillStyle: fs;
		borderStyle: bs.
	self updateUpButtonImage.
	self updateDownButtonImage! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
slider
	"Answer the slider."

	^slider! !

!ScrollBarMorph methodsFor: 'initialization' stamp: ''!
initializeSlider
	"Initialize the receiver's slider."
	
	self initializeUpButton; initializeDownButton; initializePagingArea.
	super initializeSlider.
	self sliderColor: self sliderColor.
	self slider
		width: self theme scrollbarThickness;
		height: self theme scrollbarThickness.
	slider cornerStyle: (self theme scrollbarThumbCornerStyleIn: self window).
	slider on: #mouseEnter send: #mouseEnterThumb: to: self.
	slider on: #mouseLeave send: #mouseLeaveThumb: to: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverThumbFillStyle
	"Return the mouse over thumb fillStyle for the receiver."
	
	^self theme scrollbarMouseOverThumbFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'mouse' stamp: ''!
mouseEnterPagingArea: event
	"The mouse has entered the paging area."
	
	pagingArea
		fillStyle: self mouseOverFillStyle;
		borderStyle: self mouseOverBorderStyle;
		changed.
	slider
		fillStyle: self mouseOverPagingAreaThumbFillStyle;
		borderStyle: self mouseOverPagingAreaThumbBorderStyle;
		changed.
	upButton
		fillStyle: self mouseOverPagingAreaButtonFillStyle;
		borderStyle: self mouseOverPagingAreaButtonBorderStyle;
		changed.
	downButton
		fillStyle: self mouseOverPagingAreaButtonFillStyle;
		borderStyle: self mouseOverPagingAreaButtonBorderStyle;
		changed! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
adoptPaneColor: aColor
	"Adopt the given pane color"
	aColor ifNil:[^self].
	self sliderColor: aColor.! !

!ScrollBarMorph methodsFor: 'scrolling' stamp: ''!
doScrollUp
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 200 delay2: 40) ifFalse: [^ self].
	self setValue: (value - scrollDelta - 0.000001 max: 0.0)! !

!ScrollBarMorph methodsFor: 'mouse' stamp: ''!
mouseUpInSlider: event
	"The mouse button has been released."
	
	"If it was not dragging, thre's nothing to do."
	self dragging ifFalse:[^self].
	
	sliderShadow hide.
	(slider containsPoint: event position)
		ifTrue: [slider
					fillStyle: self mouseOverThumbFillStyle;
					borderStyle: self mouseOverThumbBorderStyle]
		ifFalse: [self mouseLeaveThumb: event].
	slider changed.
	
	"Not dragging anymore."
	self dragging:false.! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
pagingArea
	^pagingArea! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
thumbColor
	"Problem: Part of the ScrollBar/Slider code uses 'slider' to mean the entire scrollbar/slider widget, and part of it uses 'slider' to mean only the draggable 'thumb'.  This should be cleaned up so that 'thumb' is used instead of 'slider' where appropriate.  For now, the meaning of thumbColor is clear, at least."

	^self class imageColorFor: self! !

!ScrollBarMorph methodsFor: 'stepping' stamp: ''!
wantsSteps
	^self scrollBarAction notNil! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
pressedFillStyle
	"Return the pressed fillStyle for the receiver."
	
	^self theme scrollbarPressedFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
pressedThumbFillStyle
	"Return the pressed thumb fillStyle for the receiver."
	
	^self theme scrollbarPressedThumbFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'scrolling' stamp: ''!
doScrollByPage
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 300 delay2: 100) ifFalse: [^ self].
	nextPageDirection
		ifTrue: [self setValue: (value + pageDelta min: 1.0)]
		ifFalse: [self setValue: (value - pageDelta max: 0.0)]! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverPagingAreaThumbBorderStyle
	"Return the thumb borderStyle for the receiver when the mouse
	is over the paging area."
	
	^self theme scrollbarMouseOverBarThumbBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverBorderStyle
	"Return the mouse over borderStyle for the receiver."
	
	^self theme scrollbarMouseOverBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'mouse' stamp: ''!
mouseLeaveDownButton: event
	"The mouse has left the down button."

	event redButtonPressed
		ifFalse: [ 
			downButton
				fillStyle: self normalButtonFillStyle;
				borderStyle: self normalButtonBorderStyle;
				changed ]! !

!ScrollBarMorph methodsFor: 'scrolling' stamp: ''!
scrollDown: count
	self setValue: (value + (scrollDelta * count) + 0.000001 min: 1.0)! !

!ScrollBarMorph methodsFor: 'stepping' stamp: ''!
step
	| action |
	action := self scrollBarAction.
	action ifNotNil:[self perform: action].! !

!ScrollBarMorph methodsFor: 'update' stamp: ''!
updateUpButtonBounds
	"update the receiver's upButton bounds"

	upButton bounds: (self theme scrollBarUpButtonBoundsFor: self)! !

!ScrollBarMorph methodsFor: 'mouse' stamp: ''!
mouseEnterThumb: event
	"The mouse has entered the thumb."
	
	slider
		fillStyle: self mouseOverThumbFillStyle;
		borderStyle: self mouseOverThumbBorderStyle;
		changed.
	upButton
		fillStyle: self mouseOverThumbButtonFillStyle;
		borderStyle: self mouseOverThumbButtonBorderStyle;
		changed.
	downButton
		fillStyle: self mouseOverThumbButtonFillStyle;
		borderStyle: self mouseOverThumbButtonBorderStyle;
		changed! !

!ScrollBarMorph methodsFor: 'geometry' stamp: ''!
expandSlider
	"Compute the new size of the slider (use the old sliderThickness as a minimum)."
	| r |
	r := self totalSliderArea.
	slider extent: (bounds isWide
		ifTrue: [((r width * interval) asInteger max: self sliderThickness) @ slider height]
		ifFalse: [slider width @ ((r height * interval) asInteger max: self sliderThickness)])! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
finishedScrolling: event
	"Scrolling has finished for a button."
	
	self finishedScrolling.
	(self containsPoint: event position)
		ifTrue: [pagingArea
				fillStyle: self mouseOverFillStyle;
				borderStyle: self mouseOverBorderStyle]
		ifFalse: [pagingArea
				fillStyle: self normalFillStyle;
				borderStyle: self normalBorderStyle].
	(upButton containsPoint: event position)
		ifTrue: [upButton
					fillStyle: self mouseOverButtonFillStyle;
					borderStyle: self mouseOverButtonBorderStyle]
		ifFalse: [(self containsPoint: event position)
					ifTrue: [upButton
							fillStyle: self mouseOverPagingAreaButtonFillStyle;
							borderStyle: self mouseOverPagingAreaButtonBorderStyle]
					ifFalse: [upButton
							fillStyle: self normalButtonFillStyle;
							borderStyle: self normalButtonBorderStyle]].
	(downButton containsPoint: event position)
		ifTrue: [downButton
					fillStyle: self mouseOverButtonFillStyle;
					borderStyle: self mouseOverButtonBorderStyle]
		ifFalse: [(self containsPoint: event position)
					ifTrue: [downButton
							fillStyle: self mouseOverPagingAreaButtonFillStyle;
							borderStyle: self mouseOverPagingAreaButtonBorderStyle]
					ifFalse: [downButton
							fillStyle: self normalButtonFillStyle;
							borderStyle: self normalButtonBorderStyle]]! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
normalThumbBorderStyle
	"Return the normal thumb borderStyle for the receiver."
	
	^self theme scrollbarNormalThumbBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
pressedButtonFillStyle
	"Return the pressed button fillStyle for the receiver."
	
	^self theme scrollbarPressedButtonFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'accessing' stamp: ''!
lastPaneColor
	^ lastPaneColor! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
scrollDownInit
	"Initialize a scroll down (from button) operation.
	Fixed to perform immediately with deferred 
	stepping for subsequent hold of button."

	|bc|
	bc := downButton borderStyle baseColor.
	downButton borderInset.
	downButton borderStyle baseColor: bc.
	self resetTimer.
	self scrollBarAction: #doScrollDown.
	self doScrollDown.
	self
		startStepping: #stepAt:
		at: Time millisecondClockValue + self stepTime
		arguments: nil stepTime: nil.
	downButton fillStyle: self pressedButtonFillStyle.
	downButton borderStyle: self pressedButtonBorderStyle! !

!ScrollBarMorph methodsFor: '*Morphic-Widgets-FastTable' stamp: ''!
scrollRestrictedUp: aValue

	"only scroll if the scrollbar is not at its end yet"

	self canScrollUp ifFalse: [ ^self ].
	
	self scrollUp: aValue! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverPagingAreaButtonBorderStyle
	"Return the button borderStyle for the receiver when the mouse
	is over the paging area."
	
	^self theme scrollbarMouseOverBarButtonBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverThumbButtonBorderStyle
	"Return the button borderStyle for the receiver when the mouse
	is over the thumb."
	
	^self theme scrollbarMouseOverThumbButtonBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'mouse' stamp: ''!
mouseEnterUpButton: event
	"The mouse has entered the up button."
	
	upButton
		fillStyle: self mouseOverButtonFillStyle;
		borderStyle: self mouseOverButtonBorderStyle;
		changed! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
scrollDelta
	^ scrollDelta! !

!ScrollBarMorph methodsFor: 'model access' stamp: ''!
setValue: newValue
	"Using roundTo: instead of truncateTo: ensures that scrollUp will scroll the same distance as scrollDown.
	Fix for >= 1.0 since, when close the roundTo may round down and not allow the value to reach
	the full range."
	
	newValue >= 1.0
		ifTrue: [^super setValue: 1.0].
	^ super setValue: (newValue roundTo: scrollDelta)! !

!ScrollBarMorph methodsFor: 'scroll timing' stamp: ''!
waitForDelay1: delay1 delay2: delay2 
	"Return true if an appropriate delay has passed since the last scroll operation.
	The delay decreases exponentially from delay1 to delay2."

	| now scrollDelay |
	timeOfLastScroll ifNil: [self resetTimer].	"Only needed for old instances"
	now := Time millisecondClockValue.
	(scrollDelay := currentScrollDelay) ifNil: [scrollDelay := delay1	"initial delay"].
	currentScrollDelay := scrollDelay * 9 // 10 max: delay2.	"decrease the delay"
	timeOfLastScroll := now.
	^true! !

!ScrollBarMorph methodsFor: 'initialize' stamp: ''!
updateUpButtonImage
"update the receiver's upButton. put a new image inside"
	upButton removeAllMorphs.
	upButton
		addMorphCentered: (ImageMorph new form: self upImage)! !

!ScrollBarMorph methodsFor: 'geometry' stamp: ''!
extent: p 
	p x > p y
		ifTrue: [super
				extent: (p max: (42 @ 8) scaledByDisplayScaleFactor)]
		ifFalse: [super
				extent: (p max: (8 @ 42) scaledByDisplayScaleFactor)].! !

!ScrollBarMorph methodsFor: 'scrolling' stamp: ''!
setNextDirectionFromEvent: event

	nextPageDirection := bounds isWide ifTrue: [
		event cursorPoint x >= slider center x
	]
	ifFalse: [
		event cursorPoint y >= slider center y
	]! !

!ScrollBarMorph methodsFor: 'geometry' stamp: ''!
buttonExtent
	| size |
	size := self theme scrollbarThickness.
	
	^ bounds isWide
		ifTrue: [ upButton 
			ifNil: [  size@size ] 
			ifNotNil: [ upButton extent ] ]
		ifFalse: [ downButton 
			ifNil: [ size@size ] 
			ifNotNil: [ downButton extent ] ]! !

!ScrollBarMorph methodsFor: 'stepping' stamp: ''!
stepTime
	^ currentScrollDelay ifNil: [300]! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverPagingAreaButtonFillStyle
	"Return the button fillStyle for the receiver when the mouse
	is over the paging area."
	
	^self theme scrollbarMouseOverBarButtonFillStyleFor: self! !

!ScrollBarMorph methodsFor: '*Morphic-Widgets-FastTable' stamp: ''!
canScrollUp

	^value > 0! !

!ScrollBarMorph methodsFor: 'scrolling' stamp: ''!
doScrollDown
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 200 delay2: 40) ifFalse: [^ self].
	self setValue: (value + scrollDelta + 0.000001 min: 1.0)! !

!ScrollBarMorph methodsFor: 'other events' stamp: ''!
mouseDownInSlider: event
	"The mouse has been pressed in the slider area."

	"If its already dragging, there's nothing to do"
	self dragging
		ifTrue: [ ^ self ].
		
	interval = 1
		ifTrue:
			[ "make the entire scrollable area visible if a full scrollbar is clicked on"
			self setValue: 0.
			self model hideOrShowScrollBar ].
	event redButtonPressed
		ifFalse: [ ^ self ].
	slider fillStyle: self pressedThumbFillStyle.
	slider borderStyle: self pressedThumbBorderStyle.
	self theme useScrollbarThumbShadow
		ifTrue: [ sliderShadow
				color: self sliderShadowColor;
				cornerStyle: slider cornerStyle;
				bounds: slider bounds;
				show ].
	"Set dragging to true."
	self dragging: true! !

!ScrollBarMorph methodsFor: 'geometry' stamp: ''!
sliderExtent
	"The sliderExtent is now stored in the slider itself, not hardcoded as it is in the superclass."
	^slider extent! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
pressedBorderStyle
	"Return the pressed borderStyle for the receiver."
	
	^self theme scrollbarPressedBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
scrollDelta: d1 pageDelta: d2
	"Supply optional increments for better scrolling of, eg, text"
	scrollDelta := d1.
	pageDelta := d2.! !

!ScrollBarMorph methodsFor: 'geometry' stamp: ''!
sliderThickness
	"Answer the minimum width/height of the scrollbar thumb. Refer to the theme."
	
	^self theme scrollbarMinimumThumbThickness! !

!ScrollBarMorph methodsFor: 'update' stamp: ''!
updatePagingAreaBounds
	"Initialize the receiver's pagingArea."
	
	pagingArea bounds: self totalSliderArea! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverFillStyle
	"Return the mouse over fillStyle for the receiver."
	
	^self theme scrollbarMouseOverFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverButtonBorderStyle
	"Return the mouse over button borderStyle for the receiver."
	
	^self theme scrollbarMouseOverButtonBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'initialize' stamp: ''!
upImage
	"answer a form to be used in the up button"
	^ self class
		arrowOfDirection: (bounds isWide
				ifTrue: [#left]
				ifFalse: [#top])
		size: (self buttonExtent x min: self buttonExtent y)
		color: self buttonImageColor! !

!ScrollBarMorph methodsFor: 'scrolling' stamp: ''!
scrollBarAction: aSymbol
	self setProperty: #scrollBarAction toValue: aSymbol! !

!ScrollBarMorph methodsFor: 'mouse' stamp: ''!
mouseEnterDownButton: event
	"The mouse has entered the down button."
	
	downButton
		fillStyle: self mouseOverButtonFillStyle;
		borderStyle: self mouseOverButtonBorderStyle;
		changed! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
scrollPageInit: evt
	"Scroll initiated by the paging area."
	
	self resetTimer.
	self setNextDirectionFromEvent: evt.
	self scrollBarAction: #doScrollByPage.
	self doScrollByPage. "do the first one now since morph stepping is rather variable in its timing
		and the user may release before actually actioned...."
	pagingArea
		fillStyle: self pressedFillStyle;
		borderStyle: self pressedBorderStyle.
	self startStepping: #stepAt: at: Time millisecondClockValue + self stepTime arguments: nil stepTime: nil! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
sliderColor: aColor 
	"Change the color of the scrollbar to go with aColor."
	| buttonColor |
	super sliderColor: aColor.
	self lastPaneColor: aColor.
	buttonColor := self thumbColor.
	upButton color: buttonColor.
	downButton color: buttonColor.
	slider color: buttonColor slightlyLighter.	
	pagingArea
		fillStyle: self normalFillStyle;
		borderStyle: self normalBorderStyle.
	(self theme scrollbarPagingAreaCornerStyleIn: self window) = #rounded
		ifTrue: [self fillStyle: self normalButtonFillStyle]
		ifFalse: [self fillStyle: self normalFillStyle].
	self borderWidth: 0.
	^self adoptGradientColor: aColor! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
normalButtonFillStyle
	"Return the normal button fillStyle for the receiver."
	
	^self theme scrollbarNormalButtonFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
mouseOverPagingAreaThumbFillStyle
	"Return the thumb fillStyle for the receiver when the mouse
	is over the paging area."
	
	^self theme scrollbarMouseOverBarThumbFillStyleFor: self! !

!ScrollBarMorph methodsFor: 'private - accessing' stamp: ''!
interval: d
	"Supply an optional floating fraction so slider can expand to indicate range.
	Update the fill style for the tumb (may have extent-based elements)."
	
	|oldExtent|
	oldExtent := slider extent.
	interval := d min: 1.0.
	self expandSlider.
	self computeSlider.
	slider extent = oldExtent
		ifFalse: [slider fillStyle: self normalThumbFillStyle]! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
pressedThumbBorderStyle
	"Return the pressed thumb borderStyle for the receiver."
	
	^self theme scrollbarPressedThumbBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'style' stamp: ''!
normalButtonBorderStyle
	"Return the normal button borderStyle for the receiver."
	
	^self theme scrollbarNormalButtonBorderStyleFor: self! !

!ScrollBarMorph methodsFor: 'mouse' stamp: ''!
mouseLeavePagingArea: event
	"The mouse has left the paging area."
	
	pagingArea
		fillStyle: self normalFillStyle;
		borderStyle: self normalBorderStyle;
		changed.
	slider
		fillStyle: self normalThumbFillStyle;
		borderStyle: self normalThumbBorderStyle;
		changed.
	upButton
		fillStyle: self normalButtonFillStyle;
		borderStyle: self normalButtonBorderStyle;
		changed.
	downButton
		fillStyle: self normalButtonFillStyle;
		borderStyle: self normalButtonBorderStyle;
		changed! !

!ScrollBarMorph methodsFor: '*Morphic-Widgets-FastTable' stamp: ''!
scrollDownByPageDelta
	self scrollDown: self pageDelta! !

!ScrollBarMorph methodsFor: '*Morphic-Widgets-FastTable' stamp: ''!
scrollRestrictedDown: aValue

	"only scroll if the scrollbar is not at its end yet"

	self canScrollDown ifFalse: [ ^self ].
	
	self scrollDown: aValue! !

!ScrollBarMorph methodsFor: 'initialization' stamp: ''!
initializeUpButton
	"initialize the receiver's upButton"
	upButton := self theme newScrollBarUpButtonFor: self.
	upButton color: self thumbColor.
	upButton
		on: #mouseDown
		send: #scrollUpInit
		to: self.
	upButton
		on: #mouseUp
		send: #finishedScrolling
		to: self.
	self updateUpButtonImage.
	upButton 
		borderWidth: 1;
		borderColor: Color lightGray.
		
	upButton cornerStyle: (self theme scrollbarButtonCornerStyleIn: self window).
	upButton on: #mouseUp send: #finishedScrolling: to: self.
	upButton on: #mouseEnter send: #mouseEnterUpButton: to: self.
	upButton on: #mouseLeave send: #mouseLeaveUpButton: to: self.
	self addMorph: upButton! !

!ScrollBarMorph methodsFor: 'mouse' stamp: ''!
mouseLeaveThumb: event
	"The mouse has left the thumb."

	| buttonFillStyle buttonBorderStyle |
	event redButtonPressed
		ifFalse: [ slider
				fillStyle: self normalThumbFillStyle;
				borderStyle: self normalThumbBorderStyle;
				changed ].

	"Update buttons"
	buttonBorderStyle := (self containsPoint: event position)
		ifTrue: [ buttonFillStyle := self mouseOverPagingAreaButtonFillStyle.
			self mouseOverPagingAreaButtonBorderStyle ]
		ifFalse: [ buttonFillStyle := self normalButtonFillStyle.
			self normalButtonBorderStyle ].
	upButton
		fillStyle: buttonFillStyle;
		borderStyle: buttonBorderStyle.
	downButton
		fillStyle: buttonFillStyle;
		borderStyle: buttonBorderStyle! !

!ScrollBarMorph class methodsFor: 'images - samples' stamp: ''!
arrowSamples
	"create a set of arrow with different sizes, colors and directions"
	" 
	ScrollBar arrowSamples.  
	"
	| column |
	column := AlignmentMorph newColumn vResizing: #shrinkWrap;
				 hResizing: #shrinkWrap;
				 layoutInset: 1;
				 borderColor: Color black;
				 borderWidth: 0;
				 wrapCentering: #center;
				 cellPositioning: #center;
				 color: Color white;
				 yourself.
	
	self sampleSizes
		do: [:size | 
			| row | 
			row := AlignmentMorph newRow color: Color transparent;
						 vResizing: #shrinkWrap;
						 cellInset: 2 @ 0 yourself.
			
			self sampleColors
				do: [:color | 
					#(#top #right #bottom #left )
						do: [:direction | 
							row addMorphBack: (ScrollBarMorph
									arrowOfDirection: direction
									size: size
									color: color) asMorph]].
			
			column addMorphBack: row].
	
	column openInHand! !

!ScrollBarMorph class methodsFor: 'images - samples' stamp: ''!
boxSamples
	"create a set of box with different sizes and colors"
	" 
	ScrollBar boxSamples.  
	"
	| column |
	column := AlignmentMorph newColumn vResizing: #shrinkWrap;
				 hResizing: #shrinkWrap;
				 layoutInset: 1;
				 borderColor: Color black;
				 borderWidth: 0;
				 wrapCentering: #center;
				 cellPositioning: #center;
				 color: Color white;
				 yourself.
	""
	self sampleSizes
		do: [:size | 
			| row | 
			row := AlignmentMorph newRow color: Color transparent;
						 vResizing: #shrinkWrap;
						 cellInset: 2 @ 0 yourself.
			""
			self sampleColors
				do: [:color | 
					row addMorphBack: (ScrollBarMorph boxOfSize: size color: color) asMorph].
			""
			column addMorphBack: row].
	""
	""
	column openInHand! !

!ScrollBarMorph class methodsFor: 'class initialization' stamp: ''!
initialize
	
	self initializeImagesCache! !

!ScrollBarMorph class methodsFor: 'images - samples' stamp: ''!
sampleSizes
	
"private"
	^ #(10 12 14 16 18 32 64 )! !

!ScrollBarMorph class methodsFor: 'images' stamp: ''!
boxOfSize: finalSizeInteger color: aColor 
	"answer a form with an box based on the parameters"
	^ BoxesImagesCache at: {finalSizeInteger. aColor}! !

!ScrollBarMorph class methodsFor: 'private - initialization' stamp: ''!
initializeImagesCache
	"initialize the receiver's ImagesCache. 
	 
	normally this method is not evaluated more than in the class 
	initializazion. "

	" 
	ScrollBar initializeImagesCache.
	"

	ArrowImagesCache := self theme createArrowImagesCache.
	BoxesImagesCache := self theme createBoxImagesCache! !

!ScrollBarMorph class methodsFor: 'images - samples' stamp: ''!
sampleColors
	"private"
	^ (Color lightCyan wheel: 5)! !

!ScrollBarMorph class methodsFor: 'images' stamp: ''!
arrowOfDirection: aSymbol size: finalSizeInteger color: aColor 
	"answer a form with an arrow based on the parameters"
	^ ArrowImagesCache at: {aSymbol. finalSizeInteger. aColor}! !

!ScrollBarMorph class methodsFor: '*Polymorph-Widgets' stamp: ''!
imageColorFor: aScrollbar
	"Return the (button) image colour for the given scrollbar."
	
	^self theme scrollbarImageColorFor: aScrollbar! !

!ScrollBarMorph class methodsFor: 'cleanup' stamp: ''!
cleanUp
	"Re-initialize the image cache"

	self initializeImagesCache! !

!ScrollPane commentStamp: ''!
The scroller (a transform) of a scrollPane is driven by the scrollBar.  The scroll values vary from 0.0, meaning zero offset to 1.0 meaning sufficient offset such that the bottom of the scrollable material appears 3/4 of the way down the pane.  The total distance to achieve this range is called the totalScrollRange.

Basic clue about utilization of the ScrollPane class is given in:
	ScrollPane example1.
	ScrollPane example2.!
!ScrollPane methodsFor: 'accessing - options' stamp: ''!
alwaysShowVScrollBar: bool

	self setProperty: #vScrollBarAlways toValue: bool.
	self vHideOrShowScrollBar.! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
borderStyle: aBorderStyle
	"Optimised when no change."
	
	self borderStyle = aBorderStyle ifTrue: [^self].
	super borderStyle: aBorderStyle.
	self setScrollDeltas! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
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"
	^ self findSubmorphFor: ptY.! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
resizeScrollBars
	self vResizeScrollBar; hResizeScrollBar! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
scrollDeltaHeight
	"Return the increment in pixels which this pane should be scrolled (normally a subclass responsibility)."
	^ 10! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
vScrollBarValue: scrollValue
	| systemWindow |
	scroller hasSubmorphs ifFalse: [^ self].
	scroller offset: (scroller offset x @ (self vLeftoverScrollRange * scrollValue) rounded).

	owner ifNil: [ ^ self ].
	systemWindow := self window.
		
	systemWindow ifNotNil:
		[ systemWindow 
			announce: (WindowScrolling new step: 0@scrollValue; window: systemWindow) ].
		
	self announcer announce: (PaneScrolling new 
		step: 0@scrollValue;
		scrollPane: self;
		yourself)! !

!ScrollPane methodsFor: 'geometry testing' stamp: ''!
hIsScrollable

	"If the contents of the pane are too small to scroll, return false."
	^ self hLeftoverScrollRange > 0! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
vUnadjustedScrollRange
	"Return the height extent of the receiver's submorphs."
	| submorphBounds |
	submorphBounds := scroller localSubmorphBounds ifNil: [^ 0].
	^ submorphBounds bottom! !

!ScrollPane methodsFor: 'accessing' stamp: ''!
numSelectionsInView
	"Answer the scroller's height based on the average number of submorphs."
	
	^scroller numberOfItemsPotentiallyInView! !

!ScrollPane methodsFor: 'accessing - options' stamp: ''!
showHScrollBarOnlyWhenNeeded: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self setProperty: #noHScrollBarPlease toValue: bool.
	self setProperty: #hScrollBarAlways toValue: bool.
	
	self hHideOrShowScrollBar.! !

!ScrollPane methodsFor: 'scroll bar events' stamp: ''!
unshiftedYellowButtonActivity
	^ self yellowButtonActivity: false! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
vScrollBarHeight
	| h |

	h := bounds height - (2 * borderWidth).
	self hIsScrollbarNeeded
		ifTrue:[ h := h - self scrollBarThickness. ].
	^h! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
hLeftoverScrollRange
	"Return the entire scrolling range minus the currently viewed area."
	| w |
	scroller hasSubmorphs ifFalse: [^0].
	w :=  bounds width.
	self vIsScrollbarShowing ifTrue:[ w := w - self scrollBarThickness ].
	^ (self hTotalScrollRange - w roundTo: self scrollDeltaHeight) max: 0! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
resizeScroller

	scroller bounds: self innerBounds! !

!ScrollPane methodsFor: 'geometry testing' stamp: ''!
isScrolledFromTop
	"Have the contents of the pane been scrolled, so that the top of the contents are not visible?"
	^scroller offset y > 0! !

!ScrollPane methodsFor: 'scroll bar events' stamp: ''!
hScrollBarMenuButtonPressed: event
	^ self scrollBarMenuButtonPressed: event! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
hIsScrollbarNeeded
"Return whether the horz scrollbar is needed"

	"Don't show it if we were told not to."
	(self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]) ifTrue: [^false].

	"Always show it if we were told to"
	(self valueOfProperty: #hScrollBarAlways ifAbsent: [false]) ifTrue: [^true].

	^self hIsScrollable! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
hSetScrollDelta
	"Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."
	| range delta |

	scroller hasSubmorphs ifFalse:[scrollBar interval: 1.0. ^self].
	
	delta := self scrollDeltaWidth.
	range := self hLeftoverScrollRange.
	range = 0 ifTrue: [ hScrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; setValue: 0. ^self].

	"Set up for one line (for arrow scrolling), or a full pane less one line (for paging)."

	hScrollBar 
			scrollDelta: (delta / range) asFloat 
			pageDelta: ((self innerBounds width - delta) / range) asFloat.
	hScrollBar interval: ((self innerBounds width) / self hTotalScrollRange) asFloat.
	hScrollBar setValue: ((scroller offset x / range) min: 1.0) asFloat.! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
scrollBy: delta
	"Move the contents in the direction delta."

	| newYoffset r newXoffset |
	
	"Set the offset on the scroller"
	newYoffset := scroller offset y - delta y max: 0.
	newXoffset := scroller offset x - delta x max: (self hMargin negated).
	
	scroller offset: newXoffset@ newYoffset.

	"Update the scrollBars"
	(r := self vLeftoverScrollRange) = 0
		ifTrue: [scrollBar value: 0.0]
		ifFalse: [scrollBar value: newYoffset asFloat / r].
	(r := self hLeftoverScrollRange) = 0
		ifTrue: [hScrollBar value: 0.0]
		ifFalse: [hScrollBar value: newXoffset asFloat / r]! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
hScrollValue: scrollValue
	"Set the horizontal scroll value via the scrollbar itself."

	hScrollBar setValue: scrollValue! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
innerBounds
	| inner |
	inner := super innerBounds.
	(submorphs includes: scrollBar) ifTrue: [ inner := inner topLeft corner: (inner right - scrollBar width) @ inner bottom ].
	^ self hIsScrollbarShowing
		ifFalse: [ inner ]
		ifTrue: [ inner topLeft extent: inner extent - (0 @ self scrollBarThickness) ]! !

!ScrollPane methodsFor: 'scroll bar events' stamp: ''!
vScrollBarMenuButtonPressed: event
	^ self scrollBarMenuButtonPressed: event! !

!ScrollPane methodsFor: 'accessing - options' stamp: ''!
showScrollBarsOnlyWhenNeeded: bool

	self showHScrollBarOnlyWhenNeeded: bool.
	self showVScrollBarOnlyWhenNeeded: bool.! !

!ScrollPane methodsFor: 'initialization' stamp: ''!
newTransformMorph
	^TransformMorph new! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
adoptPaneColor: paneColor
	"Match the pane colour."
	
	super adoptPaneColor: paneColor.
	scrollBar adoptPaneColor: paneColor.
	hScrollBar adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	self borderWidth > 0 ifTrue: [
		self borderStyle: self borderStyleToUse]! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
vHideScrollBar
	self vIsScrollbarShowing ifFalse: [^self].
	self removeMorph: scrollBar.
	self resetExtent! !

!ScrollPane methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ self theme darkBaseColor! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^ true! !

!ScrollPane methodsFor: 'accessing' stamp: ''!
hasFocus
	"hasFocus is currently set by mouse enter/leave events.
	This inst var should probably be moved up to a higher superclass."

	^ hasFocus ifNil: [false]! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
showScrollBars
	self  vShowScrollBar; hShowScrollBar! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
hideOrShowScrollBar
	"Hide or show the scrollbar depending on if the pane is scrolled/scrollable."

	"Don't show it if we were told not to."
	(self valueOfProperty: #noScrollBarPlease ifAbsent: [false]) ifTrue: [^self].

	(self vIsScrollbarNeeded not and: [ self isScrolledFromTop not ]) ifTrue: [self vHideScrollBar].
	(self vIsScrollbarNeeded or: [ self isScrolledFromTop ]) ifTrue: [self vShowScrollBar].! !

!ScrollPane methodsFor: 'accessing - options' stamp: ''!
hideVScrollBarIndefinitely: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self setProperty: #noVScrollBarPlease toValue: bool.
	self vHideOrShowScrollBar.! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
getMenuSelector: aSymbol
	"Set the menu selector."

	getMenuSelector := aSymbol! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
hScrollBarWidth
"Return the width of the horizontal scrollbar"


	| w |
	
	w := bounds width - (2 * borderWidth).
	
	self vIsScrollbarNeeded
		ifTrue: [w := w - self scrollBarThickness ].
		
	^w! !

!ScrollPane methodsFor: 'accessing - options' stamp: ''!
hideScrollBarsIndefinitely
	self hideScrollBarsIndefinitely: true! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
borderStyleToUse
	"Answer the borderStyle that should be used for the receiver."
	
	^self enabled
		ifTrue: [self theme scrollPaneNormalBorderStyleFor: self]
		ifFalse: [self theme scrollPaneDisabledBorderStyleFor: self]! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
hHideOrShowScrollBar
	"Hide or show the scrollbar depending on if the pane is scrolled/scrollable."

	self hIsScrollbarNeeded
		ifTrue:[ self hShowScrollBar ]
		ifFalse: [ self hHideScrollBar ].! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
hideOrShowScrollBars

	| wasHShowing wasVShowing |

	wasVShowing := self vIsScrollbarShowing.
	wasHShowing := self hIsScrollbarShowing.

	self 
		vHideOrShowScrollBar; 
		hHideOrShowScrollBar; 
		resizeScrollBars.

	(wasVShowing and: [self vIsScrollbarShowing not]) ifTrue:
		["Make sure the delta is 0"
		(scroller offset y = 0) 
				ifFalse:[ scroller offset: (scroller offset x@0) ]].
			
	(wasHShowing and: [self hIsScrollbarShowing not]) ifTrue:
		[(scroller offset x <= 0)
				ifFalse:[ scroller offset: (self hMargin negated@scroller offset y)]].! !

!ScrollPane methodsFor: 'accessing - options' stamp: ''!
hideScrollBarsIndefinitely: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self hideVScrollBarIndefinitely: bool.
	self hideHScrollBarIndefinitely: bool.! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
mouseLeave: event
	hasFocus := false.! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
mouseWheel: event 
	"Handle a mouseWheel event."
	
	event isUp ifTrue: [ ^ scrollBar scrollUp: 3 ].
	event isDown ifTrue: [ ^ scrollBar scrollDown: 3 ].
	event isLeft  ifTrue: [ ^ hScrollBar scrollLeft: 3 ].
	event isRight  ifTrue: [ ^ hScrollBar scrollRight: 3 ].! !

!ScrollPane methodsFor: 'initialization' stamp: ''!
defaultExtent
	^150@120! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
keyDown: 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].
	scroller submorphs last keyDown: evt! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
vTotalScrollRange
	"Return the entire scrolling range."
	^ self vUnadjustedScrollRange + self vExtraScrollRange! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt
	"Could just ^ true, but this ensures that scroll bars won't flop out
	if you mouse-over appendages such as connecting pins."
	"self flag: #arNote." "I have no idea how the code below could've ever worked. If the receiver does not handle mouse over events then it should not receive any #mouseLeave if the mouse leaves the receiver for real. This is because 'evt cursorPoint' describes the *end* point of the movement and considering that the code would return false if the move ends outside the receiver the scroll bars should never pop back in again. Which is exactly what happens with the new event logic if you don't just ^true. I'm leaving the code in for reference - perhaps somebody can make sense from it; I sure cannot."
	^true
"
	| cp |
	cp := evt cursorPoint.
	(bounds containsPoint: cp)
		ifTrue: [^ true]			
		ifFalse: [self submorphsDo:
					[:m | (m containsPoint: cp) ifTrue:
							[m == scrollBar
								ifTrue: [^ true]
								ifFalse: [^ false]]].
				^ false]
"! !

!ScrollPane methodsFor: 'scroll bar events' stamp: ''!
shiftedYellowButtonActivity
	^ self yellowButtonActivity: true! !

!ScrollPane methodsFor: 'menu' stamp: ''!
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 := getMenuTitleSelector ifNotNil: [self model perform: 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'! !

!ScrollPane methodsFor: 'testing' stamp: ''!
isAutoFit
	^false! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
mouseMove: evt
	"If pane is not empty, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)."
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseMove: (evt transformedBy: (scroller transformFrom: self))]! !

!ScrollPane methodsFor: 'settings' stamp: ''!
alwaysShowHScrollbar
	^ self class alwaysShowHScrollbar! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
hHideScrollBar
	self hIsScrollbarShowing ifFalse: [^scroller offset: (self hMargin negated@scroller offset y)].
	self removeMorph: hScrollBar.
	scroller offset: (self hMargin negated@scroller offset y).
	self resetExtent.! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
minWidth
	"Answer the minimum width."

	|noVPlease noHPlease minW|
	noVPlease := self valueOfProperty: #noVScrollBarPlease ifAbsent: [false]. 
	noHPlease := self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]. 
	minW := noVPlease
		ifTrue: [noHPlease
					ifTrue: [1]
					ifFalse: [self scrollBarThickness * 3]]
		ifFalse: [noHPlease
					ifTrue: [self scrollBarThickness + 20]
					ifFalse: [self scrollBarThickness * 3 + 2]].
	^minW max: super minWidth! !

!ScrollPane methodsFor: 'menu' stamp: ''!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu"
	^ self getMenuSelector notNil! !

!ScrollPane methodsFor: 'layout' stamp: ''!
layoutProportionallyIn: newBounds
	"Layout specific. Apply the given bounds to the receiver."
	self layoutFrame ifNil:[^self].
	"before applying the proportional values make sure the receiver's layout is computed"
	self isAutoFit ifTrue: [self fullBounds].
	^super layoutProportionallyIn: newBounds! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
hShowScrollBar

	self hIsScrollbarShowing ifTrue: [^self].
	self hResizeScrollBar.
	self privateAddMorph: hScrollBar atIndex: 1.
	self resetExtent.! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
scrollBarThickness
	"Includes border"
	^ self theme scrollbarThickness! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
vLeftoverScrollRange
	"Return the entire scrolling range minus the currently viewed area."
	scroller hasSubmorphs ifFalse:[^0].
	^ (self vTotalScrollRange -  self vScrollBarHeight roundTo: self scrollDeltaHeight) max: 0! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	self flag: #todo. "This is a quick fix for ensure cmd+click works. 
	see: http://code.google.com/p/pharo/issues/detail?id=7403
	probably a better fix is just remove it, but I want to prevent any possible side effects and 
	there is no time for study the issue as it would be required"
	(evt yellowButtonPressed and: [ evt commandKeyPressed not ]) "First check for option (menu) click"
		ifTrue: [ (self yellowButtonActivity: evt shiftPressed) 
			ifTrue: [ ^ super mouseDown: evt. ]].
	
	"If pane is not empty, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs 
		ifTrue: [ scroller submorphs last mouseDown: (evt transformedBy: (scroller transformFrom: self)) ].
	
	self eventHandler
		ifNotNil: [ self eventHandler mouseDown: evt fromMorph: self ]! !

!ScrollPane methodsFor: 'initialization' stamp: ''!
initializeShortcuts: aKMDispatcher
	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #ScrollPane! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
minHeight
	"Answer the minimum height."

	| noVPlease noHPlease minH |
	noVPlease := self valueOfProperty: #noVScrollBarPlease ifAbsent: [ false ].
	noHPlease := self valueOfProperty: #noHScrollBarPlease ifAbsent: [ false ].
	minH := noVPlease
		ifTrue: [ 
			noHPlease
				ifTrue: [ 1 ]
				ifFalse: [ self scrollBarThickness ] ]
		ifFalse: [ 
			noHPlease
				ifTrue: [ self scrollBarThickness * 3 ]
				ifFalse: [ self scrollBarThickness * 4 + 2 ] ].
	^ minH max: super minHeight! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
getMenuSelector

	^ getMenuSelector! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
vResizeScrollBar
	| w topLeft  |
	w := self scrollBarThickness.
	topLeft := bounds topRight - ((w + borderWidth - 0) @ (0 - borderWidth)).
	scrollBar bounds: (topLeft extent: w @ self vScrollBarHeight)! !

!ScrollPane methodsFor: 'geometry testing' stamp: ''!
vIsScrolled
	"If the scroller is not set to y = 0, then the pane has been scrolled."
	^scroller offset y > 0! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
hResizeScrollBar

	| topLeft h |

	(self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]) ifTrue: [^self].
	bounds ifNil: [ self fullBounds ].
	
	h := self scrollBarThickness.
	topLeft := bounds bottomLeft + (borderWidth @ (h + borderWidth) negated).
	hScrollBar bounds: (topLeft extent: self hScrollBarWidth@ h)! !

!ScrollPane methodsFor: 'initialization' stamp: ''!
initializeScroller
	scroller := self newTransformMorph color: Color transparent.
	scroller offset: (self hMargin negated) @ 0.
	self addMorph: scroller! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
vScrollValue: scrollValue
	"Set the vertical scroll value via the scrollbar itself."

	scrollBar setValue: scrollValue! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
hideScrollBars
	self
		vHideScrollBar;
		hHideScrollBar! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
themeChanged
	"The current theme has changed.
	Update any dependent visual aspects."

	scrollBar theme: self theme.
	hScrollBar theme: self theme.
	super themeChanged! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
vSetScrollDelta
	"Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."
	| range delta |

	scroller hasSubmorphs ifFalse:[scrollBar interval: 1.0. ^self].
	
	delta := self scrollDeltaHeight.
	range := self vLeftoverScrollRange.
	range = 0 ifTrue: [^ scrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; setValue: 0].

	"Set up for one line (for arrow scrolling), or a full pane less one line (for paging)."
	scrollBar scrollDelta: (delta / range) asFloat 
			pageDelta: ((self innerBounds height - delta) / range) asFloat.
	scrollBar interval: ((self innerBounds height) / self vTotalScrollRange) asFloat.
	scrollBar setValue: (scroller offset y / range min: 1.0) asFloat.! !

!ScrollPane methodsFor: 'accessing - options' stamp: ''!
alwaysShowScrollBars: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self 
		alwaysShowHScrollBar: bool;
		alwaysShowVScrollBar: bool.! !

!ScrollPane methodsFor: 'accessing' stamp: ''!
scrollBar
	^scrollBar! !

!ScrollPane methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas 
	"Draw the focus here since we are using inset bounds
	for the focus rectangle."

	super drawSubmorphsOn: aCanvas.
	self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas].! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
handlesMouseWheel: evt
	"Do I want to receive mouseWheel events?" 

	^self vIsScrollable or: [ self hIsScrollable ]! !

!ScrollPane methodsFor: 'initialization' stamp: ''!
initializeScrollBars
	"initialize the receiver's scrollBar"

	(scrollBar := ScrollBarMorph new model: self; setValueSelector: #vScrollBarValue:)
		borderWidth: 1;
		borderColor: Color black.
	(hScrollBar := ScrollBarMorph new model: self; setValueSelector: #hScrollBarValue:)
		borderWidth: 1;
		borderColor: Color black.
	self initializeScroller.
	self addMorph: scrollBar.
	self addMorph: hScrollBar.
	self alwaysShowVScrollbar
		ifTrue: [ self alwaysShowVScrollBar: true ].
	self alwaysHideHScrollbar
		ifTrue: [ self hideHScrollBarIndefinitely: true ]
		ifFalse: [ 
			self alwaysShowHScrollbar
				ifTrue: [ self alwaysShowHScrollBar: true ] ]! !

!ScrollPane methodsFor: 'initialization' stamp: ''!
initialize
	
	"initialize the state of the receiver"
	super initialize.
	hasFocus := false.
	self initializeScrollBars.
	self extent: self defaultExtent.
	self hideOrShowScrollBars.! !

!ScrollPane methodsFor: 'accessing' stamp: ''!
borderWidth: aNumber 
	super borderWidth: aNumber.
	self setScrollDeltas! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
hUnadjustedScrollRange
	"Return the width extent of the receiver's submorphs."

	| submorphBounds |
	submorphBounds := scroller localSubmorphBounds ifNil: [^ 0].
	^ submorphBounds right! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
mouseEnter: event
	hasFocus := true.! !

!ScrollPane methodsFor: 'geometry testing' stamp: ''!
vIsScrollable
"Return whether the verticle scrollbar is scrollable"

	"If the contents of the pane are too small to scroll, return false."
	^ self vLeftoverScrollRange > 0
		"treat a single line as non-scrollable"
		and: [self vTotalScrollRange > (self scrollDeltaHeight * 3/2)]! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
scrollDeltaWidth
	"Return the increment in pixels which this pane should be scrolled (normally a subclass responsibility)."
	
	^10! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
scrollValue
	"Answer the values of the scrollbars as a point."

	^hScrollBar value @ scrollBar value! !

!ScrollPane methodsFor: 'scroll bar events' stamp: ''!
yellowButtonActivity: shiftKeyState
	
	(self getMenu: shiftKeyState) 
		ifNotNil: [ :menu|
			menu setInvokingView: self.
			menu popUpEvent: self activeHand lastEvent in: self world.
			^ true].
	^ false! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
hScrollBarValue: scrollValue
	| x systemWindow |
	
	self hIsScrollbarShowing ifFalse: 
		[ ^ scroller offset: (0 - self hMargin)@scroller offset y ].
	((x := self hLeftoverScrollRange * scrollValue) <= 0)
		ifTrue:[ x := 0 - self hMargin ].
	scroller offset: (x@scroller offset y).

	owner ifNil: [ ^ self ].
	
	systemWindow := self window.
	systemWindow ifNotNil:
		[ systemWindow 
			announce: (WindowScrolling new step: scrollValue@0; window: systemWindow) ].
		
	self announcer announce: (PaneScrolling new 
		step: scrollValue@0;
		scrollPane: self;
		yourself)! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
keyStroke: evt
	"If pane is not empty, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"

	scroller submorphs last keyStroke: evt! !

!ScrollPane methodsFor: 'accessing - options' stamp: ''!
showVScrollBarOnlyWhenNeeded: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self setProperty: #noVScrollBarPlease toValue: bool.
	self setProperty: #vScrollBarAlways toValue: bool.
	self vHideOrShowScrollBar.! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
scrollToShow: aRectangle
	"scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space"
	| visibleRect dx dy |
	visibleRect := Rectangle origin: scroller offset extent: self innerBounds extent.
	dx := (aRectangle width < visibleRect width)
		ifTrue: [ (visibleRect right - aRectangle right) min: 0 max: (visibleRect left - aRectangle left) ]
		ifFalse: [ (visibleRect left - aRectangle left) min: 0 max: (visibleRect right - aRectangle right) ].
	dy := (aRectangle height < visibleRect height)
		ifTrue: [ (visibleRect bottom - aRectangle bottom) min: 0 max: (visibleRect top - aRectangle top) ]
		ifFalse: [ (visibleRect top - aRectangle top) min: 0 max: (visibleRect bottom - aRectangle bottom) ].
	self scrollBy: dx@dy.! !

!ScrollPane methodsFor: 'geometry testing' stamp: ''!
vIsScrollbarShowing
	"Return true if a retractable scroll bar is currently showing"

	^submorphs includes: scrollBar! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
setScrollDeltas
	"Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."

	scroller hasSubmorphs ifFalse: 
		[scrollBar interval: 1.0. 
		hScrollBar interval: 1.0. 
		^ self].
	
"NOTE: fullbounds commented out now -- trying to find a case where this expensive step is necessary -- perhaps there is a less expensive way to handle that case."
	"scroller fullBounds." "force recompute so that leftoverScrollRange will be up-to-date"
	self hideOrShowScrollBars.
	
	self vIsScrollbarShowing ifTrue:[ self vSetScrollDelta ].
	self hIsScrollbarShowing ifTrue:[ self hSetScrollDelta ].! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
mouseUp: evt
	"If pane is not empty, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseUp: (evt transformedBy: (scroller transformFrom: self))]! !

!ScrollPane methodsFor: 'scroll bar events' stamp: ''!
scrollBarMenuButtonPressed: event
	^ self yellowButtonActivity: event shiftPressed! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
hExtraScrollRange
	"Return the amount of extra blank space to include below the bottom of the scroll content."
	^ self scrollDeltaWidth! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
hTotalScrollRange
	"Return the entire scrolling range."
	^ self hUnadjustedScrollRange + self hExtraScrollRange + self hMargin! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
resetExtent
	"Reset the extent. (may be overridden by subclasses which need to do more than this)"
	self resizeScroller! !

!ScrollPane methodsFor: 'settings' stamp: ''!
alwaysShowVScrollbar
	^ self class alwaysShowVScrollbar! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
findSubmorphFor: ptY
	^ scroller
		findSubmorphBinary: [ :item | 
			(ptY between: item top and: item bottom)
				ifTrue: [ 0 ]
				ifFalse: [ 
					| itemCenter |
					itemCenter := (item top + item bottom) // 2.
					ptY < itemCenter
						ifTrue: [ -1 ]
						ifFalse: [ 1 ]	"found" ] ]! !

!ScrollPane methodsFor: 'event handling' stamp: ''!
scrollByKeyboard: event 
	"If event is ctrl+up/down then scroll and answer true"
	(event controlKeyPressed or:[event commandKeyPressed]) ifFalse: [^ false].
	event keyValue = 30
		ifTrue: 
			[scrollBar scrollUp: 3.
			^ true].
	event keyValue = 31
		ifTrue: 
			[scrollBar scrollDown: 3.
			^ true].
	^ false! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
extraScrollRange
	"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)"
	^ self scrollDeltaHeight! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
vHideOrShowScrollBar

	self vIsScrollbarNeeded
		ifTrue:[ self vShowScrollBar ]
		ifFalse:[ self vHideScrollBar ].! !

!ScrollPane methodsFor: 'scroll bar events' stamp: ''!
shiftedTextPaneMenuRequest
	"The more... button was hit from the text-pane menu"

	^ self yellowButtonActivity: true! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
vIsScrollbarNeeded
"Return whether the verticle scrollbar is needed"
	
	"Don't show it if we were told not to."
	(self valueOfProperty: #noVScrollBarPlease ifAbsent: [false]) ifTrue: [^false].

	"Always show it if we were told to"
	(self valueOfProperty: #vScrollBarAlways ifAbsent: [false]) ifTrue: [^true].
	
	^self vIsScrollable! !

!ScrollPane methodsFor: '*Athens-Morphic' stamp: ''!
drawSubmorphsOnAthensCanvas: anAthensCanvas
	super 	drawSubmorphsOnAthensCanvas: anAthensCanvas.
	self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOnAthensCanvas: anAthensCanvas].! !

!ScrollPane methodsFor: 'accessing' stamp: ''!
hMargin
"pixels of whitespace at to the left of the scroller when the hScrollBar offset is 0"
	^3! !

!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: ''!
scrollValue: aPoint
	self 
		hScrollValue: aPoint x;
		vScrollValue: aPoint y.! !

!ScrollPane methodsFor: 'scrolling' stamp: ''!
vShowScrollBar

	self vIsScrollbarShowing ifTrue: [^ self].
	self vResizeScrollBar.
	self privateAddMorph: scrollBar atIndex: 1.
	self resetExtent! !

!ScrollPane methodsFor: 'geometry testing' stamp: ''!
hIsScrollbarShowing
	"Return true if a horz scroll bar is currently showing"

	^submorphs includes: hScrollBar! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
extent: newExtent
	
	| oldW oldH wasHShowing wasVShowing noVPlease noHPlease minH minW |
	
	oldW := self width.
	oldH := self height.
	wasHShowing := self hIsScrollbarShowing.
	wasVShowing := self vIsScrollbarShowing.

	"Figure out the minimum width and height for this pane so that scrollbars will appear"
	noVPlease := self valueOfProperty: #noVScrollBarPlease ifAbsent: [false]. 
	noHPlease := self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]. 
	minH := self scrollBarThickness + 16.
	minW := self scrollBarThickness + 20.
	noVPlease ifTrue:[ 
		noHPlease
			ifTrue:[minH := 1. minW := 1 ]
			ifFalse:[minH := self scrollBarThickness ].
	] ifFalse:[
		noHPlease
			ifTrue:[minH := self scrollBarThickness + 5].
	].
	super extent: (newExtent max: (minW@minH)).

	"Now reset widget sizes"
	self resizeScrollBars; resizeScroller; hideOrShowScrollBars.
	
	"Now resetScrollDeltas where appropriate, first the vScrollBar..."
	((self height ~~ oldH) or: [ wasHShowing ~~ self hIsScrollbarShowing]) ifTrue:
		[self vIsScrollbarShowing ifTrue: [ self vSetScrollDelta ]].
			
	"...then the hScrollBar"
	((self width ~~ oldW) or: [wasVShowing ~~ self vIsScrollbarShowing]) ifTrue:
		[self hIsScrollbarShowing ifTrue: [ self hSetScrollDelta ]].! !

!ScrollPane methodsFor: 'accessing - options' stamp: ''!
hideHScrollBarIndefinitely: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self setProperty: #noHScrollBarPlease toValue: bool.
	self hHideOrShowScrollBar.! !

!ScrollPane methodsFor: 'accessing' stamp: ''!
scroller: aTransformMorph
	scroller ifNotNil:[scroller delete].
	scroller := aTransformMorph.
	self addMorph: scroller.
	self resizeScroller.! !

!ScrollPane methodsFor: 'accessing - options' stamp: ''!
alwaysShowHScrollBar: bool
	self setProperty: #hScrollBarAlways toValue: bool.
	self hHideOrShowScrollBar.! !

!ScrollPane methodsFor: 'menu' stamp: ''!
menuTitleSelector: aSelector
	getMenuTitleSelector := aSelector! !

!ScrollPane methodsFor: 'geometry' stamp: ''!
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)"
	^ self scrollDeltaHeight! !

!ScrollPane methodsFor: 'geometry testing' stamp: ''!
hIsScrolled
	"If the scroller is not set to x = 0, then the pane has been h-scrolled."
	^scroller offset x > 0! !

!ScrollPane methodsFor: 'accessing' stamp: ''!
scroller
	^ scroller! !

!ScrollPane methodsFor: 'settings' stamp: ''!
alwaysHideHScrollbar
	^ self class alwaysHideHScrollbar! !

!ScrollPane class methodsFor: 'settings' stamp: ''!
alwaysShowVScrollbar
	^ false! !

!ScrollPane class methodsFor: 'examples' stamp: ''!
example1
	| window scrollPane pasteUpMorph |
	window := SystemWindow new.
	scrollPane := ScrollPane new.
	pasteUpMorph := PasteUpMorph new.
	pasteUpMorph extent: 1000@1000.
	scrollPane scroller addMorph: pasteUpMorph.
	window addMorph: scrollPane frame: (0@0 corner: 1@1).
	window openInWorld.! !

!ScrollPane class methodsFor: 'settings' stamp: ''!
alwaysHideHScrollbar
	^ false! !

!ScrollPane class methodsFor: 'shortcuts' stamp: ''!
buildScrollPaneShortcuts: aBuilder
	"Note: the ctrl up and down don't work because they are transformed at the very beginning as mousewheel ctrl up and ctrl down. But why and how ? TG 15/09/2012."

	<keymap>
	(aBuilder shortcut: #scrollUp)
		category: #ScrollPane
		default: Character arrowUp meta
		do: [ :target | target scrollBar scrollUp: 3 ].
	(aBuilder shortcut: #scrollDown)
		category: #ScrollPane
		default: Character arrowDown meta
		do: [ :target | target scrollBar scrollDown: 3 ].! !

!ScrollPane class methodsFor: 'examples' stamp: ''!
example2
	| window scrollPane pasteUpMorph point textMorph |
	window := SystemWindow new.
	scrollPane := ScrollPane new.
	pasteUpMorph := PasteUpMorph new.
	pasteUpMorph extent: 1000@1000.
	scrollPane scroller addMorph: pasteUpMorph.
	window addMorph: scrollPane frame: (0@0 corner: 1@1).
	0 to: 1000 by: 100 do: 
		[:x | 0 to: 1000 by: 100 do:
			[:y |
				point :=  x@y.
				textMorph := TextMorph new contents: point asString.
				textMorph position: point.
				pasteUpMorph addMorph: textMorph
			]
		].
	window openInWorld.! !

!ScrollPane class methodsFor: 'settings' stamp: ''!
alwaysShowHScrollbar
	^ false! !

!ScrollbarTest methodsFor: 'helpers' stamp: ''!
createSlider

	^ ScrollBarMorph new
		extent: 240 @ 8;
		yourself! !

!SearchFacade commentStamp: ''!
SearchFacade is a facade for creating searching dialog window!
!SearchFacade class methodsFor: 'class search' stamp: ''!
superclassSearchFor: aClass

	^ self classSearchIn: aClass allSuperclasses reverse! !

!SearchFacade class methodsFor: 'class search' stamp: ''!
classSearchIn: classes
	^ ListDialogWindow new
		getList: [ :r | classes select: [ :e | r search: e name ] ];
		displayBlock: [ :e | e name ];
		title: 'Class search' translated;
		yourself! !

!SearchFacade class methodsFor: 'package search' stamp: ''!
packageSearch
				
	^ self packageSearchIn: self environment! !

!SearchFacade class methodsFor: 'message search' stamp: ''!
allMessageSearchFor: aClass

	^ self messageSearchIn: aClass allMethods! !

!SearchFacade class methodsFor: 'rpackage search' stamp: ''!
rPackageSearchIn: anOrganizer
	| rawList |
	rawList := anOrganizer packages sorted: [ :a :b | a name <= b name ].
	^ ListDialogWindow new
		getList: [ :r | rawList select: [ :e | r search: e name ] ];
		displayBlock: [ :e | e name ];
		browseBlock: [ :answer | Smalltalk tools browser openOnPackage: answer ];
		title: 'Package search' translated;
		yourself! !

!SearchFacade class methodsFor: 'class search' stamp: ''!
hierarchySearchFor: aClass
	| classes |
	classes := aClass allSuperclasses reverse, (aClass allSubclasses sorted: [ :a :b| a name <= b name ]).
	^ self classSearchIn: classes! !

!SearchFacade class methodsFor: 'package search' stamp: ''!
mcPackageSearchRejectAll: aRejectBlock withInitialFilter: filter
	| workingCopies |
	
	workingCopies := MCWorkingCopy allManagers asSortedCollection: [ :a :b | a packageName <= b packageName].
	workingCopies := workingCopies reject: aRejectBlock.
	
	^ ListDialogWindow new
				getList: [ :regex | workingCopies select: [ :workingCopy | regex search: workingCopy package name] ];
				displayBlock: [ :workingCopy | workingCopy package name ];
				title: 'Monticello packages';
				initialFilter: (filter ifNil: [ '' ] ifNotNil: [ filter]);
				yourself. 
! !

!SearchFacade class methodsFor: 'class search' stamp: ''!
subclassSearchFor: aClass
	| classes |
	classes := aClass allSubclasses sorted: [ :a :b| a name <= b name ].
	^ self classSearchIn: classes! !

!SearchFacade class methodsFor: 'rpackage search' stamp: ''!
rPackageSearch
				
	^ self rPackageSearchIn: RPackageOrganizer default! !

!SearchFacade class methodsFor: 'class search' stamp: ''!
classSearchInEnvironment: anEnvironment
	| classes |
	classes :=  anEnvironment classesAndTraits sorted: [ :a :b| a name <= b name ].
	^ self classSearchIn: classes.! !

!SearchFacade class methodsFor: 'protocol search' stamp: ''!
protocolSearchIn: aCollection
	^ ListDialogWindow new
		getList: [ :r | aCollection sorted select: [ :e | r search: e ] ];
		displayBlock: [ :e | e ];
		title: 'Protocol search' translated;
		yourself! !

!SearchFacade class methodsFor: 'message search' stamp: ''!
messageSearchIn: aCollection
	| rawList |
	rawList := aCollection sorted: [ :a :b | a selector <= b selector ].
	^ ListDialogWindow new
		getList: [ :r | rawList select: [ :e | r search: e selector ] ];
		displayBlock: [ :e | e selector ];
		title: 'Message search' translated;
		yourself! !

!SearchFacade class methodsFor: 'message search' stamp: ''!
messageSearchFor: aClass

	^ self messageSearchIn: aClass methods! !

!SearchFacade class methodsFor: 'package search' stamp: ''!
mcPackageSearchRejectAll: aRejectBlock
	^ self mcPackageSearchRejectAll: aRejectBlock withInitialFilter: nil! !

!SearchFacade class methodsFor: 'package search' stamp: ''!
packageSearchIn: anEnvironment
	| rawList |
	rawList := anEnvironment organization categories sort.
	^ ListDialogWindow new
		getList: [ :r | rawList select: [ :e | r search: e ] ];
		displayBlock: [ :e | e ];
		title: 'Package search' translated;
		yourself! !

!SearchFacade class methodsFor: 'class search' stamp: ''!
classSearch

	^ self classSearchInEnvironment: self environment! !

!SearchFacade class methodsFor: 'package search' stamp: ''!
mcPackageSearch
	^ self mcPackageSearchRejectAll: [ :aPackage | false ] withInitialFilter: nil! !

!SearchMorph commentStamp: ''!
I am a searchfield with a dropdown for the history. It is a minor extension to the EditableDropListMorph managing the search history directly in the morph. 

Typical use-case:

	^ SearchMorph new
		model: self;
		setIndexSelector: #classSearchAccept:; "sends the search result to the model"
		searchList: self class classSearchList; "sent on creation to get the initial search list"
		yourself
	
	!
!SearchMorph methodsFor: 'accessing' stamp: ''!
maxSize: aNumber
	maxSize := aNumber! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
searchList
	^ list ifNil: [ list := OrderedCollection new].! !

!SearchMorph methodsFor: 'drawing' stamp: ''!
newContentMorph
	| editorMorph|
	editorMorph := super newContentMorph.

	editorMorph 
		autoAccept: false;
		withoutAdornment;
		changedAction: [:aString| self contentChanged: aString asString].
	editorMorph announcer when: RubKeystroke send: #whenKeystroke: to: self.
	^ editorMorph! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
acceptSelector
	^ self setIndexSelector! !

!SearchMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self convertTo: String.
	list := OrderedCollection new.
	self useSelectionIndex: false.
	self ghostText: 'Hit return to accept' translated! !

!SearchMorph methodsFor: 'protocol' stamp: ''!
showList
	"trigger a list update so that shared search results are updated properly"
	self changed: #list.
	super showList.! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
updateSelector
	^ updateSelector! !

!SearchMorph methodsFor: 'event handling' stamp: ''!
whenKeystroke: anAnnouncement
	^ self keyStroke: anAnnouncement event fromMorph: anAnnouncement morph! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
content: anObject 
	content := anObject asString trimBoth.
	self addToList: content.
	self listSelectionIndex: (self list indexOf: content).
	self updateList! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
searchList: aCollection
	self list: aCollection! !

!SearchMorph methodsFor: 'protocol' stamp: ''!
takeKeyboardFocus
	contentMorph takeKeyboardFocus.! !

!SearchMorph methodsFor: 'protocol' stamp: ''!
addToList: aString
	aString isEmpty ifTrue: [ ^ self ].
	list ifNil: [
		list := self searchList].
	list remove: aString ifAbsent: [].
	list size = self maxSize
		ifTrue: [ self searchList removeLast].
	list addFirst: aString.
	self changed: #list.! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
updateSelector: aSymbol 
	updateSelector := aSymbol! !

!SearchMorph methodsFor: 'private' stamp: ''!
currentTabCompletion
	self searchList ifEmpty: [ ^ ''].
	
	currentCompletionIndex > self searchList
		ifTrue: [ currentCompletionIndex := 1].
	
	^ self searchList at: currentCompletionIndex! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
maxSize
	^ maxSize! !

!SearchMorph methodsFor: 'private' stamp: ''!
nextCompletion
	currentCompletionIndex := (currentCompletionIndex + 1 \\ self searchList size) + 1.
	^ self currentTabCompletion! !

!SearchMorph methodsFor: 'protocol' stamp: ''!
contentChanged: aString
	content := aString.
	self updateSelector ifNotNil: [ :selector|
		self model perform: selector with: aString ]! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
listSelectionIndex: anInteger
	"Set the list selection."

	self hideList.
	anInteger = 0 
		ifTrue: [
			self model ifNotNil: [:m | 
				self setIndexSelector ifNotNil: [:s |
					self useSelectionIndex 
						ifFalse: [m perform: s with: nil]]]]
		ifFalse: [ ^ super listSelectionIndex: anInteger ].! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
acceptSelector: aSymbol
	self setIndexSelector: aSymbol! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
searchString
	^ content! !

!SearchMorph methodsFor: 'accessing' stamp: ''!
selectionInterval
	^ contentMorph selectionInterval! !

!SearchMorph methodsFor: 'event handling' stamp: ''!
keyStroke: event fromMorph: morph

	^ false! !

!SearchableList commentStamp: ''!
SearchableList 
	new items: #( aaa abc axz bbb bfbg bof c);
	openWithSpec
	
should it be a subclass of ListPresenter?
Because now I will have to delegate a lot? and I cannot plug a IconList

How do I make textModel react to every keystroke without an accept!
!SearchableList methodsFor: 'accessing' stamp: ''!
listPresenter
	^ listPresenter! !

!SearchableList methodsFor: 'initialization' stamp: ''!
initializeWidgets

	listPresenter := self newList.
	searchPresenter := self newTextInput.
		
	searchPresenter 
		autoAccept: true;
		ghostText: 'filter'.! !

!SearchableList methodsFor: 'accessing' stamp: ''!
items: aCollection
	listPresenter items: aCollection! !

!SearchableList methodsFor: 'accessing' stamp: ''!
searchPresenter
	^ searchPresenter! !

!SearchableList methodsFor: 'initialization' stamp: ''!
initializePresenter

	searchPresenter whenTextChanged: [:newText || text |
		text :=  searchPresenter getText asLowercase.
		text isEmpty
			ifTrue: [ listPresenter resetFilteringBlock ]
			ifFalse: [
				listPresenter filteringBlock: [:col | col select: [:e | e asLowercase beginsWith: searchPresenter getText asLowercase ]]]]! !

!SearchableList class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	"self example"

	^ self new
		items: #(#aaa #abc #axz #bbb #bfbg #bof #c); openWithSpec! !

!SearchableList class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpecLayout composed
		newRow: #searchPresenter height: self toolbarHeight;
		add: #listPresenter top: self toolbarHeight;
		yourself! !

!SearchableTree commentStamp: ''!
I am a tree plus an input field to be able to filter the tree elements!
!SearchableTree methodsFor: 'api' stamp: ''!
doubleClick: aBlock

	tree doubleClick: aBlock! !

!SearchableTree methodsFor: 'api' stamp: ''!
highlightedItem: aTreeNodePresenter
	
	tree highlightedItem: aTreeNodePresenter! !

!SearchableTree methodsFor: 'api' stamp: ''!
menu: aBlock
	
	tree menu: aBlock! !

!SearchableTree methodsFor: 'api - compatibility' stamp: ''!
childrenBlock: aBlock
	
	tree childrenBlock: aBlock! !

!SearchableTree methodsFor: 'api' stamp: ''!
columns
	
	^ tree columns! !

!SearchableTree methodsFor: 'initialization' stamp: ''!
initializeWidgets

	tree := self newTree.
	inputField := self newTextInput.
	label := self newLabel.
	button := self newButton.
			
	tree rootNodeHolder: [ :item | 
		(tree defaultNodeFor: item)
			matchTokenFilterBlock: [ :aFilter |
				aFilter token
					ifEmpty: [ true ]
					ifNotEmpty: [ item asString asLowercase includesSubstring: aFilter token asLowercase ] ];
			yourself ].
			
	button 
		label: '';
		icon: (self iconNamed: #smallFindIcon);
		state: false;
		action: [ inputField accept ].
			
	label 
		label: 'Search:';
		color:Color black.
	
	inputField
		ghostText: 'Search';
		entryCompletion: nil;
		acceptOnCR: true.
		
	self focusOrder
		add: tree;
		add: inputField! !

!SearchableTree methodsFor: 'api' stamp: ''!
multiSelection: aBoolean

	tree multiSelection: aBoolean! !

!SearchableTree methodsFor: 'api' stamp: ''!
preferedPaneColor: aColor

	tree preferedPaneColor: aColor! !

!SearchableTree methodsFor: 'updating' stamp: ''!
updateRootFor: aText
	| aFilter |
	
	aFilter := TokenTreeFilter token: aText.
	tree filterWith: aFilter! !

!SearchableTree methodsFor: 'api' stamp: ''!
columnInset: anInteger

	tree columnInset: anInteger! !

!SearchableTree methodsFor: 'api' stamp: ''!
selectedItem: anItem
	
	tree selectedItem: anItem! !

!SearchableTree methodsFor: 'api' stamp: ''!
evenRowColor: aColor

	tree evenRowColor: aColor! !

!SearchableTree methodsFor: 'api' stamp: ''!
rootNodeHolder: aBlock

	tree rootNodeHolder: aBlock! !

!SearchableTree methodsFor: 'accessing' stamp: ''!
inputField
	^ inputField! !

!SearchableTree methodsFor: 'accessing' stamp: ''!
button

	^ button! !

!SearchableTree methodsFor: 'api' stamp: ''!
autoAccept: aBoolean

	inputField autoAccept: aBoolean! !

!SearchableTree methodsFor: 'api' stamp: ''!
resizerWidth: anInteger

	tree resizerWidth: anInteger! !

!SearchableTree methodsFor: 'api' stamp: ''!
roots
	
	^ tree roots! !

!SearchableTree methodsFor: 'api' stamp: ''!
updateTree
	
	tree updateTree! !

!SearchableTree methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!SearchableTree methodsFor: 'api' stamp: ''!
keyStrokeAction: aBlock

	tree keyStrokeAction: aBlock! !

!SearchableTree methodsFor: 'api' stamp: ''!
selectedItems: aCollection
	
	tree selectedItems: aCollection! !

!SearchableTree methodsFor: 'api - compatibility' stamp: ''!
childrenBlock
	
	^ tree childrenBlock! !

!SearchableTree methodsFor: 'api - events' stamp: ''!
whenRootsChanged: aBlock

	roots whenChangedDo: aBlock! !

!SearchableTree methodsFor: 'list api-events' stamp: ''!
whenSelectedItemChanged: aBlock

	tree whenSelectedItemChanged: aBlock! !

!SearchableTree methodsFor: 'api - compatibility' stamp: ''!
displayBlock

	^ tree displayBlock! !

!SearchableTree methodsFor: 'api' stamp: ''!
autoMultiSelection: aBoolean

	tree autoMultiSelection: aBoolean! !

!SearchableTree methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	roots := OrderedCollection new asValueHolder! !

!SearchableTree methodsFor: 'api' stamp: ''!
iconBlock: aBlock
	
	tree iconBlock: aBlock! !

!SearchableTree methodsFor: 'api' stamp: ''!
selectedItem
	
	^ tree selectedItem! !

!SearchableTree methodsFor: 'api - events-compatibility' stamp: ''!
whenChildrenBlockChanged: aBlock
	
	tree whenChildrenBlockChanged: aBlock! !

!SearchableTree methodsFor: 'api' stamp: ''!
rootNodeHolder

	^ tree rootNodeHolder! !

!SearchableTree methodsFor: 'api' stamp: ''!
columns: aCollection
	
	tree columns: aCollection! !

!SearchableTree methodsFor: 'api' stamp: ''!
rowInset: anInteger

	tree rowInset: anInteger! !

!SearchableTree methodsFor: 'accessing' stamp: ''!
tree
	^ tree! !

!SearchableTree methodsFor: 'api' stamp: ''!
resetSelection

	tree resetSelection! !

!SearchableTree methodsFor: 'api - events-compatibility' stamp: ''!
whenDisplayBlockChanged: aBlock
	
	tree whenDisplayBlockChanged: aBlock! !

!SearchableTree methodsFor: 'api' stamp: ''!
menu
	
	^ tree menu! !

!SearchableTree methodsFor: 'api - events' stamp: ''!
whenMenuChanged: aBlock
	
	tree whenMenuChanged: aBlock! !

!SearchableTree methodsFor: 'api' stamp: ''!
isCheckList: aBoolean

	tree isCheckList: aBoolean! !

!SearchableTree methodsFor: 'api' stamp: ''!
selectedItems
	
	^ tree selectedItems! !

!SearchableTree methodsFor: 'api - events' stamp: ''!
whenSelectedItemsChanged: aBlock
	
	tree whenSelectedItemsChanged: aBlock! !

!SearchableTree methodsFor: 'api' stamp: ''!
secondSelection: anItem
	
	tree secondSelection: anItem! !

!SearchableTree methodsFor: 'api - compatibility' stamp: ''!
displayBlock: aBlock
	
	tree displayBlock: aBlock! !

!SearchableTree methodsFor: 'api' stamp: ''!
roots: aCollection

	roots value: aCollection asOrderedCollection.	
	tree roots: aCollection asOrderedCollection! !

!SearchableTree methodsFor: 'initialization' stamp: ''!
initializePresenter

	inputField whenTextChanged: [ :text | self updateRootFor: text ].
		
	tree whenTreeUpdated: [ inputField text: '' ].! !

!SearchableTree class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new
		openWithSpec! !

!SearchableTree class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ SpecLayout composed
		newRow: [:r |
			r
			"add: #label width: 50;"
			add: #inputField;
			add: #button width: 25 ] height: 25;
		newRow: #tree top: 25;
		yourself! !

!SearchableTree class methodsFor: 'specs' stamp: ''!
searchAtBottom
	<spec: #default>
	
	^ SpecLayout composed
		newColumn: [:c |
			c 
				add: #tree;
				newRow: [:r |
					r
					"add: #label width: 50;"
					add: #inputField;
					add: #button width: 25 ] height: 25 ];
		yourself! !

!SelectBrowser commentStamp: ''!
A simple selection browser.!
!SelectBrowser methodsFor: 'accessing' stamp: ''!
addButtonModel
	^ addButtonModel! !

!SelectBrowser methodsFor: 'accessing' stamp: ''!
removeAllButtonModel
	^ removeAllButtonModel! !

!SelectBrowser methodsFor: 'api' stamp: ''!
initialExtent
	^   450@360! !

!SelectBrowser methodsFor: 'initialization' stamp: ''!
initializeWidgets

	addButtonModel := self newButton.
	addAllButtonModel := self newButton. 
	removeButtonModel := self newButton.
	removeAllButtonModel := self newButton.
	nextButtonModel := self newButton.
		
	self setFocusOrder.

	self setAddButtonModel. 
	self setAddAllButtonModel. 
	self setRemoveButtonModel. 
	self setRemoveAllButtonModel. 
	self setNextButtonModel. ! !

!SelectBrowser methodsFor: 'private' stamp: ''!
addAllItems

	self subclassResponsibility ! !

!SelectBrowser methodsFor: 'accessing' stamp: ''!
selectedModel
	^ selectedModel! !

!SelectBrowser methodsFor: 'accessing' stamp: ''!
nextButtonModel
	^ nextButtonModel! !

!SelectBrowser methodsFor: 'initialization' stamp: ''!
setRemoveButtonModel
	
	removeButtonModel
		state: false;
		label: 'Remove';
		action: [ self removeItems ].
	
! !

!SelectBrowser methodsFor: 'initialization' stamp: ''!
setFocusOrder

	self focusOrder
		add: addButtonModel;
		add: addAllButtonModel;
		add: removeButtonModel;
		add: removeAllButtonModel.
		! !

!SelectBrowser methodsFor: 'accessing' stamp: ''!
removeButtonModel
	^ removeButtonModel! !

!SelectBrowser methodsFor: 'api' stamp: ''!
nextAction
	self subclassResponsibility
! !

!SelectBrowser methodsFor: 'private' stamp: ''!
sort: aCollection
	^ aCollection asOrderedCollection sort: [:e1 :e2 | (e1 asString) < (e2 asString)].! !

!SelectBrowser methodsFor: 'initialization' stamp: ''!
setNextButtonModel
	
	nextButtonModel
		state: false;
		label: 'Next';
		action: [ self  nextAction ].
	
! !

!SelectBrowser methodsFor: 'initialization' stamp: ''!
setAddAllButtonModel
	
	addAllButtonModel
		state: false;
		label: 'Add All';
		action: [ self addAllItems]
	
! !

!SelectBrowser methodsFor: 'accessing' stamp: ''!
items: aCollection
	"Set the elements to be analysed"
	
	toSelectModel items: (self sort: aCollection)
! !

!SelectBrowser methodsFor: 'initialization' stamp: ''!
setAddButtonModel
	
	addButtonModel
		state: false;
		label: 'Add';
		action: [ self addItems ].
	
! !

!SelectBrowser methodsFor: 'initialization' stamp: ''!
setRemoveAllButtonModel
	
	removeAllButtonModel
		state: false;
		label: 'Remove All';
		action: [ self  removeAllItems ].
	
! !

!SelectBrowser methodsFor: 'accessing' stamp: ''!
toSelectModel
	^ toSelectModel! !

!SelectBrowser methodsFor: 'accessing' stamp: ''!
addAllButtonModel
	^ addAllButtonModel! !

!SelectBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

		<spec>
	
	^ SpecLayout composed
		newColumn: [:c |
			c
			newRow: [:r |
				r 
					add: #toSelectModel;
					addSplitter;
					add:  #selectedModel];
			newRow: [:r |
				r 
					add:#addButtonModel;
					add:#addAllButtonModel;
					add:#removeButtonModel;
					add:#removeAllButtonModel;
					add: #nextButtonModel ] height: 25]	! !

!SelectEntity commentStamp: ''!
A to-1 relationship field with keyboard selection with entry completion and a separate dialog for detailed searching (and creating new entities).

See my class side for an example

!
!SelectEntity methodsFor: 'initialization' stamp: ''!
initializePresenter
	selectEntity 
		action: [  |select|
			select := self selectDialog value.
			select openDialogWithSpec
				okAction: [  
					self entity: select selectedItem ]]
! !

!SelectEntity methodsFor: 'accessing' stamp: ''!
selectEntity: anObject
	selectEntity := anObject! !

!SelectEntity methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self initializeValueHolders! !

!SelectEntity methodsFor: 'api - events' stamp: ''!
whenDisplaySymbolChanged: aBlock
	displaySymbol whenChangedDo: aBlock! !

!SelectEntity methodsFor: 'accessing' stamp: ''!
entityText
	^ entityText! !

!SelectEntity methodsFor: 'initialization' stamp: ''!
initializeWidgets
	entityText := self newTextInput
		ghostText: self ghostText;
		autoAccept: true;
		entryCompletion: self entitiesEntryCompletion;
		yourself.
	selectEntity := self newButton
		icon: (self iconNamed: #glamorousSearch);
		help: 'Open a selection dialog'.
	self focusOrder
		add: entityText;
		add: selectEntity! !

!SelectEntity methodsFor: 'initialization' stamp: ''!
initializeValueHolders
	displaySymbol := #displayString asValueHolder.
	entity := nil asValueHolder.
	ghostText := 'Choose one' asValueHolder.
	possibleEntities := #() asValueHolder.
	selectDialog := [  ] asValueHolder! !

!SelectEntity methodsFor: 'api - events' stamp: ''!
whenGhostTextChanged: aBlock
	ghostText whenChangedDo: aBlock! !

!SelectEntity methodsFor: 'api - events' stamp: ''!
whenPossibleEntitiesChanged: aBlock
	possibleEntities whenChangedDo: aBlock! !

!SelectEntity methodsFor: 'accessing' stamp: ''!
entityText: anObject
	entityText := anObject! !

!SelectEntity methodsFor: 'api' stamp: ''!
possibleEntities
	^ possibleEntities value
		ifNil: [ #() ]
		ifNotNil: #value! !

!SelectEntity methodsFor: 'api' stamp: ''!
ghostText: aString
	ghostText value: aString.
	entityText ghostText: aString! !

!SelectEntity methodsFor: 'api' stamp: ''!
displaySymbol
	"<api: #inspect>"
	"return the method selector used to get the label of the entity that is for entry completion"
	^ displaySymbol value ifNil: [ #printString ]! !

!SelectEntity methodsFor: 'api' stamp: ''!
possibleEntities: aBlock
	"<api: #block getter: #possibleEntities registration: #whenPossibleEntitiesChanged:>"
	"Set the block used to return a collection of all possible entity choices"
	possibleEntities value: aBlock.
	entityText entryCompletion: self entitiesEntryCompletion.! !

!SelectEntity methodsFor: 'api' stamp: ''!
entity
	
	^ entity value! !

!SelectEntity methodsFor: 'accessing' stamp: ''!
selectEntity
	^ selectEntity! !

!SelectEntity methodsFor: 'api - events' stamp: ''!
whenSelectDialogChanged: aBlock
	selectDialog whenChangedDo: aBlock! !

!SelectEntity methodsFor: 'api' stamp: ''!
selectDialog
	^ selectDialog value! !

!SelectEntity methodsFor: 'entryCompletion' stamp: ''!
entitiesEntryCompletion
	^ EntryCompletion new
				dataSourceBlock: [:currText | self possibleEntities collect: [:each | 
		each perform: self displaySymbol ]];
				chooseBlock: [ :selectedName | 
					self entity: (self possibleEntities detect: [ :each | 
						(each perform: self displaySymbol) = selectedName ])];
				filterBlock: [:currEntity :currText | 
					currEntity asUppercase includesSubstring: currText asString asUppercase].! !

!SelectEntity methodsFor: 'api' stamp: ''!
displaySymbol: anObject
	displaySymbol value: anObject.
	entityText entryCompletion: self entitiesEntryCompletion.! !

!SelectEntity methodsFor: 'api - events' stamp: ''!
whenEntityChanged: aBlock
	entity whenChangedDo: aBlock! !

!SelectEntity methodsFor: 'api' stamp: ''!
selectDialog: anObject
	"<api: #block getter: #selectDialog registration: #whenSelectDialogChanged:>"
	"Set a block that returns an object that will 
	first be sent #openDialogWithSpec
	and then as okAction sent #selectedItem"
	selectDialog value: anObject! !

!SelectEntity methodsFor: 'api' stamp: ''!
ghostText
	^ ghostText value ifNil: [ '' ]! !

!SelectEntity methodsFor: 'api' stamp: ''!
entity: anObject
	entity value: anObject.
	anObject ifNotNil: [  
		self entityText text: (anObject perform: self displaySymbol)] ifNil: [ self entityText text: '' ]! !

!SelectEntity class methodsFor: 'examples' stamp: ''!
example
	self new
		selectDialog: [ FastTablePresenter new items: #(Henrik Peter); yourself];
		displaySymbol: #asString;
		ghostText: 'Names';
		possibleEntities: [#(Diego Stephan Norbert Stephane Marcus Torsten Sven Sean) sorted];
		openDialogWithSpec 
! !

!SelectEntity class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
		
	^SpecLayout composed
		newColumn: [ :col |
				col newRow: [:row |
					row add: #entityText;
						add: #selectEntity width: ComposablePresenter toolbarHeight]
					height: ComposablePresenter toolbarHeight];
		yourself
! !

!SelectPackageBrowser commentStamp: ''!
To select packages.!
!SelectPackageBrowser methodsFor: 'private' stamp: ''!
sort: aCollection withoutAll: anotherCollection
	^ self sort: 
		(aCollection asOrderedCollection 
			removeAll: (anotherCollection);
			yourself)! !

!SelectPackageBrowser methodsFor: 'initialization' stamp: ''!
initialize

	| wrappingBlock |
	super initialize.	
	toSelectModel := self instantiate: ListPresenter.
	selectedModel := self instantiate: ListPresenter.
	selectedModel beMultipleSelection.
	toSelectModel beMultipleSelection.
	testPackage := OrderedCollection new.
	wrappingBlock := [ :package | package packageName ].
	toSelectModel displayBlock: wrappingBlock.
	selectedModel displayBlock: wrappingBlock! !

!SelectPackageBrowser methodsFor: 'initialization' stamp: ''!
initializeWidgets

	super initializeWidgets.	
	addTestCaseClassesModel := self newCheckBox.
	removeTestPackageModel := self newButton.
	self setRemoveTestPackageModel.		
	addTestCaseClassesModel label: 'remove all TestCase Classes'.
	addTestCaseClassesModel state: true! !

!SelectPackageBrowser methodsFor: 'private' stamp: ''!
addAllItems
	| tmp |
	tmp := self 
		sort: selectedModel listItems
		withAll: toSelectModel listItems.
	selectedModel items: tmp.
	toSelectModel items: #().
	toSelectModel updateList.
	selectedModel updateList 	  ! !

!SelectPackageBrowser methodsFor: 'initialization' stamp: ''!
removeTestPackage

	| matchText  |
	testPackage isEmpty
		ifTrue: [
			removeTestPackageModel label: 'Add All Packages Tests'.
			matchText := '*Test*'.
			testPackage :=MCWorkingCopy allManagers select: [ :package | matchText match:  package packageName ].
			selectedModel items: (self sort:(selectedModel listItems \ testPackage)).
			toSelectModel items: (self sort:(toSelectModel  listItems \ testPackage)) ]
		ifFalse: [
			removeTestPackageModel label: 'Remove All Packages Tests'.		
			toSelectModel items: (self sort: (toSelectModel listItems asOrderedCollection addAll: testPackage; yourself)).
			testPackage := OrderedCollection new ]. 
	toSelectModel updateList.
	selectedModel updateList  	! !

!SelectPackageBrowser methodsFor: 'api' stamp: ''!
nextAction

	| env packages |	
		
	packages := selectedModel listItems.
	env := RBPackageEnvironment new packages: packages.
	SelectRuleBrowser openWithEnvironment: env removeTestCase: self addTestCaseClasses state.
	self delete
	
		
! !

!SelectPackageBrowser methodsFor: 'private' stamp: ''!
addItems
	toSelectModel selectedItems
		ifNotNil: [ :items |  
			selectedModel items: (self sort: selectedModel listItems withAll: items).
			toSelectModel items: (self sort: toSelectModel listItems withoutAll: items) ].
	toSelectModel updateList.
	selectedModel updateList  	  ! !

!SelectPackageBrowser methodsFor: 'private' stamp: ''!
removeAllItems
	| tmp |
	tmp := self 
		sort: toSelectModel listItems
		withAll: selectedModel listItems.
	toSelectModel items: tmp.
	selectedModel items: #().
	toSelectModel updateList.
	selectedModel updateList  	  ! !

!SelectPackageBrowser methodsFor: 'initialization' stamp: ''!
removeTestPackageModel

	^ removeTestPackageModel
	
	! !

!SelectPackageBrowser methodsFor: 'private' stamp: ''!
removeItems
	selectedModel selectedItems
		ifNotNil: [:items | 
			toSelectModel items: (self sort: toSelectModel listItems withAll: items).
			selectedModel items: (self sort: selectedModel listItems withoutAll: items) ].
	toSelectModel updateList.
	selectedModel updateList 	  ! !

!SelectPackageBrowser methodsFor: 'initialization' stamp: ''!
setRemoveTestPackageModel

	removeTestPackageModel
		state: false;
		label: 'Remove All Packages Tests';
		action: [ self  removeTestPackage ]
	! !

!SelectPackageBrowser methodsFor: 'private' stamp: ''!
sort: aCollection withAll: anotherCollection
	^ self sort: 
		(aCollection asOrderedCollection 
			addAll: (anotherCollection);
			yourself)! !

!SelectPackageBrowser methodsFor: 'accessing' stamp: ''!
addTestCaseClasses
	^ addTestCaseClassesModel
! !

!SelectPackageBrowser class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	
	self new items: RPackageOrganizer default packages;
		openWithSpec ! !

!SelectPackageBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec

		<spec>
	
	^ SpecLayout composed
		newColumn: [:c |
			c
			newRow: [:r |
				r 
					add: #toSelectModel; 
					addSplitter;
					add:  #selectedModel];
			newRow: [:r |
				r
					add: #removeTestPackageModel; 
					add: #addTestCaseClasses]  height: 25;
			newRow: [:r |
				r 
					add:#addButtonModel;
					add:#addAllButtonModel;
					add:#removeButtonModel;
					add:#removeAllButtonModel;
					add: #nextButtonModel ] height: 25]	! !

!SelectPackageBrowser class methodsFor: 'specs' stamp: ''!
title
	^ 'Select packages'! !

!SelectRuleBrowser commentStamp: ''!
To select rules.!
!SelectRuleBrowser methodsFor: 'accessing' stamp: ''!
environment: aEnv
	environment := aEnv! !

!SelectRuleBrowser methodsFor: 'initialization' stamp: ''!
initialize
	| wrappingBlock selectedRulesChildrenBlock rulesToSelectChildrenBlock |
	super initialize.
	toSelectModel := self instantiate: TreePresenter.
	selectedModel := self instantiate: TreePresenter.
	selectedRules := Set new.
	selectedRulesChildrenBlock := [ :rule | 
		rule isComposite
			ifTrue: [ rule rules
				select: [:r | (self isSelected: r) or: [ r isComposite ]]]
			ifFalse: [ #() ]].
	rulesToSelectChildrenBlock := [ :rule | 
		rule isComposite
			ifTrue: [ rule rules
				select: [:r | (self isSelected: r) not or: [ r isComposite ]]]
			ifFalse: [ #() ]].
	toSelectModel childrenBlock: rulesToSelectChildrenBlock.
	selectedModel childrenBlock: selectedRulesChildrenBlock.
	wrappingBlock := [:rule | rule name ].
	toSelectModel displayBlock: wrappingBlock.
	selectedModel displayBlock: wrappingBlock! !

!SelectRuleBrowser methodsFor: 'private' stamp: ''!
addAllItems
	
	toSelectModel roots do: [ :group | selectedRules addAll: group rules].
	self updateTree  	  ! !

!SelectRuleBrowser methodsFor: 'api' stamp: ''!
nextAction

	self delete.
	
	CriticWorkingConfiguration current
		rule: selectedRules;
		environment: environment;
		removeTestCase: removeTestCase.
	CriticBrowser openOnWorkingConfiguration: CriticWorkingConfiguration current! !

!SelectRuleBrowser methodsFor: 'private' stamp: ''!
isSelected: aRule
	"Check the rule identifier to not run twice the same rule"

	^ selectedRules
		anySatisfy: [ :rule | rule class uniqueIdentifierName = aRule class uniqueIdentifierName ]! !

!SelectRuleBrowser methodsFor: 'private' stamp: ''!
addItems
	toSelectModel selectedItem
		ifNotNil:
			[ :item |
			item content isComposite
				ifFalse: [ selectedRules add: item content ]
				ifTrue: [ selectedRules addAll: item content rules ] ].
	self updateTree! !

!SelectRuleBrowser methodsFor: 'private' stamp: ''!
defaultRulesRootName
	^ 'Selected Rules'! !

!SelectRuleBrowser methodsFor: 'accessing' stamp: ''!
items: aCollection
	
	toSelectModel roots: aCollection.
	selectedModel roots: aCollection
! !

!SelectRuleBrowser methodsFor: 'api' stamp: ''!
removeAllItems
	
	selectedModel roots do: [ :item |  
		selectedRules removeAllFoundIn: item value ].
	self updateTree 	  ! !

!SelectRuleBrowser methodsFor: 'api' stamp: ''!
removeItems
	
	selectedModel selectedItem
		ifNotNil: [ :item | selectedRules removeAllFoundIn: item content leaves ].
	self updateTree  	  ! !

!SelectRuleBrowser methodsFor: 'accessing' stamp: ''!
removeTestCase: aBoolean
	removeTestCase := aBoolean! !

!SelectRuleBrowser methodsFor: 'api' stamp: ''!
updateTree

	toSelectModel updateTree.
	selectedModel updateTree! !

!SelectRuleBrowser class methodsFor: 'instance creation' stamp: ''!
openWithEnvironment: anEnvironment removeTestCase: aBoolean

	self new
		items: self items;
		environment: anEnvironment;
		removeTestCase: aBoolean;
		openWithSpec;
		updateTree! !

!SelectRuleBrowser class methodsFor: 'instance creation' stamp: ''!
items

	| rules rulesByGroup |
	rules := (ReRuleManager visibleRuleClasses collect: [:aClass | aClass new]) sorted: [ :a :b |
		a name < b name ].
	rulesByGroup := ((rules groupedBy: #group) associations collect: [ :as |
		CriticBrowserRulesGroup named: as key rules: as value ]).
	rulesByGroup sort: [ :a :b | a name < b name ].
	^ rulesByGroup! !

!SelectRuleBrowser class methodsFor: 'specs' stamp: ''!
title
	^ 'Select rules'! !

!SelectVisitor commentStamp: ''!
I am a visitor that selects objects from the nodes I visit. I take a block similar to those passed to Collection>>select:. I evaluate the block with DirectoryEntries for the nodes I visit.

I can use any guide, and the objects in the array I produce will reflect the order imposed by the guide.!
!SelectVisitor methodsFor: 'visiting' stamp: ''!
visitReference: anEntry
	(block value: anEntry) 
		ifTrue: [ out nextPut: anEntry ]! !

!SelectVisitor class methodsFor: 'instance creation' stamp: ''!
preorder: aReference
	^ self preorder: aReference select: [:entry | true]! !

!SelectVisitor class methodsFor: 'instance creation' stamp: ''!
select: aBlock
	^ self basicNew initializeWithBlock: aBlock! !

!SelectVisitor class methodsFor: 'instance creation' stamp: ''!
postorder: aReference select: aBlock
	^ (self select: aBlock) postorder: aReference! !

!SelectVisitor class methodsFor: 'instance creation' stamp: ''!
breadthFirst: aReference
	^ self breadthFirst: aReference select: [:entry | true]! !

!SelectVisitor class methodsFor: 'instance creation' stamp: ''!
breadthFirst: aReference select: aBlock
	^ (self select: aBlock) breadthFirst: aReference! !

!SelectVisitor class methodsFor: 'instance creation' stamp: ''!
preorder: aReference select: aBlock
	^ (self select: aBlock) preorder: aReference! !

!SelectVisitor class methodsFor: 'instance creation' stamp: ''!
postorder: aReference
	^ self postorder: aReference select: [:entry | true]! !

!SelectVisitorTest commentStamp: ''!
SUnit tests for class SelectVistor
!
!SelectVisitorTest methodsFor: 'tests' stamp: ''!
testPreorderSelect
	| entries |
	entries := SelectVisitor preorder: self root select: [ :node| node name endsWith: #a].
	self 
		assertEntries: entries
		are: #(
				'/alpha'
				'/alpha/beta'
				'/alpha/beta/delta'
				'/alpha/beta/gamma'
				'/alpha/epsilon/zeta'
			)! !

!SelectVisitorTest methodsFor: 'tests' stamp: ''!
testPreorder
	| entries |
	entries := SelectVisitor preorder: self root.
	self 
		assertEntries: entries
		are: #(
				'/alpha'
				'/alpha/beta'
				'/alpha/beta/delta'
				'/alpha/beta/gamma'
				'/alpha/epsilon'
				'/alpha/epsilon/zeta'
			)! !

!SelectVisitorTest methodsFor: 'tests' stamp: ''!
testPostorder
	| entries |
	entries := SelectVisitor postorder: self root.
	self 
		assertEntries: entries
		are: #(
				'/alpha/beta/delta'
				'/alpha/beta/gamma'
				'/alpha/beta'
				'/alpha/epsilon/zeta'
				'/alpha/epsilon'
				'/alpha'
			)! !

!SelectVisitorTest methodsFor: 'tests' stamp: ''!
testPostorderSelect
	| entries |
	entries := SelectVisitor postorder: self root select: [ :node| node name endsWith: #a].
	self 
		assertEntries: entries
		are: #(
				'/alpha/beta/delta'
				'/alpha/beta/gamma'
				'/alpha/beta'
				'/alpha/epsilon/zeta'
				'/alpha'
			)! !

!SelectVisitorTest methodsFor: 'tests' stamp: ''!
testBreadthFirstSelect
	| entries |
	entries := SelectVisitor breadthFirst: self root select: [ :node| node name endsWith: #a].
	self 
		assertEntries: entries
		are: #(
				'/alpha'
				'/alpha/beta'
				'/alpha/beta/delta'
				'/alpha/beta/gamma'
				'/alpha/epsilon/zeta'
			)! !

!SelectVisitorTest methodsFor: 'tests' stamp: ''!
testBreadthFirst
	| entries |
	entries := SelectVisitor breadthFirst: self root.
	self 
		assertEntries: entries
		are: #(
				'/alpha'
				'/alpha/beta'
				'/alpha/epsilon'
				'/alpha/beta/delta'
				'/alpha/beta/gamma'
				'/alpha/epsilon/zeta'
			)! !

!SelectionMorph commentStamp: ''!
A selectionMorph supports the selection of multiple objects in a morphic world or pasteUp. Using command+shift you get a squared lazzo and you can grab morphs. After you can grab the selection as a morph.

Structure:
	selectedItems	an OrderedCollection of Morphs
					These are the morphs that have been selected
	slippage		a Point
					Keeps track of actual movement between the 
					steps of gridded movement
	dupLoc		a Point
					Notes the position when first duplicate request occurs from halo
	dupDelta	a Point
					Holds the final delta of the first duplicate plus subsequent moves.
!
!SelectionMorph methodsFor: 'initialization' stamp: ''!
extendByHand: aHand
	"Assumes selection has just been created and added to some pasteUp or world"
	| startPoint handle |

	startPoint := self position.

	handle := NewHandleMorph new followHand: aHand
		forEachPointDo: [:newPoint |
					| localPt |
					localPt := (self transformFrom: self world) globalPointToLocal: newPoint.
					self bounds: (startPoint rectangle: localPt)
				]
		lastPointDo: [:newPoint |
					selectedItems isEmpty
						ifTrue: [self delete]
						ifFalse: [
							selectedItems size = 1
								ifTrue:[self delete.  selectedItems anyOne addHalo]
								ifFalse:[self doneExtending]
						]
				].

	aHand attachMorph: handle.
	handle startStepping.! !

!SelectionMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas

	| canvas form1 form2 box |
	super drawOn: aCanvas.
	box := self bounds.
	selectedItems do: [:m | box := box merge: m fullBounds].
	box := box expandBy: 1.
	canvas := Display defaultCanvasClass extent: box extent depth: 8.
	canvas translateBy: box topLeft negated
		during: [:tempCanvas | selectedItems do: [:m | tempCanvas fullDrawMorph: m]].
	form1 := (Form extent: box extent) copyBits: (0@0 extent: box extent) from: canvas form at: 0@0 colorMap: (Color maskingMap: 8).
	form2 := Form extent: box extent.
	(0@0) fourNeighbors do: [:d | form1 displayOn: form2 at: d rule: Form under].
	form1 displayOn: form2 at: 0@0 rule: Form erase.
	aCanvas stencil: form2
		at: box topLeft
		sourceRect: form2 boundingBox
		color: self borderColor! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
organizeIntoColumn
	"Place my objects in a column-enforcing container"

	((AlignmentMorph inAColumn: (selectedItems asSortedCollection: [:x :y | x top < y top])) setNameTo: 'Column'; color: Color orange muchLighter; enableDragNDrop: true; yourself) openInHand! !

!SelectionMorph methodsFor: 'dropping/grabbing' stamp: ''!
justDroppedInto: newOwner event: evt

	selectedItems isEmpty ifTrue:
		["Hand just clicked down to draw out a new selection"
		^ self extendByHand: evt hand].
	dupLoc ifNotNil: [dupDelta := self position - dupLoc].
	selectedItems reverseDo: [:m | 
		self defer:
			[m referencePosition: (newOwner localPointToGlobal: m referencePosition).
			newOwner handleDropMorph:
				(DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]].
	evt wasHandled: true! !

!SelectionMorph methodsFor: 'submorphs - add/remove' stamp: ''!
goBehind
	"selection morph stays on top"! !

!SelectionMorph methodsFor: 'accessing' stamp: ''!
borderColor: aColor

	| bordered |
	bordered := selectedItems.
	undoProperties ifNil: [undoProperties := bordered collect: [:m | m borderColor]].
	bordered do: [:m | m borderColor: aColor]! !

!SelectionMorph methodsFor: 'undo' stamp: ''!
borderWidthForItems: widthCollection

	(selectedItems select: [:m | m isKindOf: BorderedMorph])
		with: widthCollection
		do: [:m :c | m borderWidth: c]! !

!SelectionMorph methodsFor: 'geometry' stamp: ''!
bounds: newBounds
	"Make sure position: gets called before extent:; Andreas' optimization for growing/shrinking in ChangeSet 3119 screwed up selection of morphs from underlying pasteup."

	selectedItems := OrderedCollection new.  "Avoid repostioning items during super position:"
	self position: newBounds topLeft; extent: newBounds extent! !

!SelectionMorph methodsFor: 'halos and balloon help' stamp: ''!
hasHalo: aBool 
	super hasHalo: aBool.
	aBool
		ifFalse: [ (self hasProperty: #deleting) ifFalse: [self delete] ]! !

!SelectionMorph methodsFor: 'menus' stamp: ''!
maybeAddCollapseItemTo: aMenu
	"... don't "! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
alignBottomEdges
	"Make the bottom coordinate of all my elements be the same"

	| maxBottom |
	maxBottom := (selectedItems collect: [:itm | itm bottom]) max.
	selectedItems do:
		[:itm | itm bottom: maxBottom].

	self changed! !

!SelectionMorph methodsFor: 'private' stamp: ''!
privateFullMoveBy: delta
	| deltaSlipped griddingMorph |
	selectedItems isEmpty
		ifTrue: [ ^ super privateFullMoveBy: delta ].
	griddingMorph := self pasteUpMorph.
	griddingMorph ifNil: [ ^ super privateFullMoveBy: delta ].
	deltaSlipped := delta + slippage.
	slippage := 0.
	super privateFullMoveBy: deltaSlipped.
	selectedItems do: [ :m | m position: m position + deltaSlipped ]! !

!SelectionMorph methodsFor: 'private' stamp: ''!
setOtherSelection: otherOrNil

	otherSelection := otherOrNil.
	otherOrNil
		ifNil: [ super borderColor: Color blue ]
		ifNotNil: [ itemsAlreadySelected := otherSelection selectedItems.
			super borderColor: Color green
			]! !

!SelectionMorph methodsFor: 'private' stamp: ''!
setSelectedItems: items

	selectedItems := items.
	self changed! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
alignTopEdges
	"Make the top coordinate of all my elements be the same"

	| minTop |
	minTop := (selectedItems collect: [:itm | itm top]) min.
	selectedItems do:
		[:itm | itm top: minTop].

	self changed! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
alignCentersHorizontally
	"Make every morph in the selection have the same vertical center as the topmost item."

	| minLeft leftMost |
	selectedItems size > 1 ifFalse: [^ self].
	minLeft := (selectedItems collect: [:itm | itm left]) min.
	leftMost := selectedItems detect: [:m | m left = minLeft].
	selectedItems do:
		[:itm | itm center: (itm center x @ leftMost center y)].

	self changed! !

!SelectionMorph methodsFor: 'undo' stamp: ''!
borderColorForItems: colorCollection

	(selectedItems select: [:m | m isKindOf: BorderedMorph])
		with: colorCollection
		do: [:m :c | m borderColor: c]! !

!SelectionMorph methodsFor: 'submorphs - add/remove' stamp: ''!
dismissViaHalo

	super dismissViaHalo.
	selectedItems do: [:m | m dismissViaHalo]! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
doDup: evt fromHalo: halo handle: dupHandle

	selectedItems := selectedItems collect: #duplicate.
	selectedItems do: [ :m | self owner addMorph: m ].
	dupDelta
		ifNil: [ "First duplicate operation -- note starting location"
			dupLoc := self position.
			evt hand grabMorph: self.
			halo removeAllHandlesBut: dupHandle
			]
		ifNotNil: [ "Subsequent duplicate does not grab, but only moves me and my morphs"
			dupLoc := nil.
			self position: self position + dupDelta
			]! !

!SelectionMorph methodsFor: 'geometry' stamp: ''!
extent: newExtent

	super extent: newExtent.
	self selectSubmorphsOf: self pasteUpMorph! !

!SelectionMorph methodsFor: 'visual properties' stamp: ''!
fillStyle: aColor
	undoProperties ifNil: [undoProperties := selectedItems collect: [:m | m fillStyle]].
	selectedItems do: [:m | m fillStyle: aColor]! !

!SelectionMorph methodsFor: 'halos and balloon help' stamp: ''!
addHandlesTo: aHaloMorph box: box
	| onlyThese |
	aHaloMorph haloBox: box.
	onlyThese := #(addDismissHandle: addMenuHandle: addGrabHandle: addDragHandle: addDupHandle: addHelpHandle: addGrowHandle: addFontSizeHandle: addFontStyleHandle: addFontEmphHandle: addRecolorHandle:).
	HaloMorph currentHaloSpecifications do:
		[:aSpec | (onlyThese includes: aSpec addHandleSelector) ifTrue:
				[aHaloMorph perform: aSpec addHandleSelector with: aSpec]].
	aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! !

!SelectionMorph methodsFor: 'submorphs - add/remove' stamp: ''!
delete
	self setProperty: #deleting toValue: true.
	super delete.! !

!SelectionMorph methodsFor: 'halos and balloon help' stamp: ''!
addOptionalHandlesTo: aHalo box: box
	aHalo addHandleAt: box leftCenter color: Color blue icon: nil
		on: #mouseUp send: #addOrRemoveItems: to: self.! !

!SelectionMorph methodsFor: 'accessing' stamp: ''!
borderWidth: aWidth

	| bordered |
	bordered := selectedItems select: [:m | m isKindOf: BorderedMorph].
	undoProperties ifNil: [undoProperties := bordered collect: [:m | m borderWidth]].
	bordered do: [:m | m borderWidth: aWidth]! !

!SelectionMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"
	super initialize.
	
	selectedItems := OrderedCollection new.
	itemsAlreadySelected := OrderedCollection new.
	slippage := 0@0! !

!SelectionMorph methodsFor: 'dropping/grabbing' stamp: ''!
aboutToBeGrabbedBy: aHand
	slippage := 0@0.
	^ super aboutToBeGrabbedBy: aHand! !

!SelectionMorph methodsFor: 'private' stamp: ''!
doneExtending

	otherSelection ifNotNil:
		[selectedItems := otherSelection selectedItems , selectedItems.
		otherSelection delete.
		self setOtherSelection: nil].
	self changed.
	self layoutChanged.
	super privateBounds:
		((Rectangle merging: (selectedItems collect: [:m | m fullBounds]))
			expandBy: 8).
	self changed.
	self addHalo.! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
organizeIntoRow
	"Place my objects in a row-enforcing container"

	((AlignmentMorph inARow: (selectedItems asSortedCollection: [:x :y | x left < y left])) setNameTo: 'Row'; color: Color orange muchLighter; enableDragNDrop: true; yourself) openInHand! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
alignCentersVertically
	"Make every morph in the selection have the same horizontal center as the topmost item."

	| minTop topMost |
	selectedItems size > 1 ifFalse: [^ self].
	minTop := (selectedItems collect: [:itm | itm top]) min.
	topMost := selectedItems detect: [:m | m top = minTop].
	selectedItems do:
		[:itm | itm center: (topMost center x @ itm center y)].

	self changed! !

!SelectionMorph methodsFor: 'private' stamp: ''!
selectSubmorphsOf: aMorph

	| newItems removals |
	newItems := aMorph submorphs select:
		[:m | (bounds containsRect: m fullBounds) 
					and: [m~~self
					and: [(m isKindOf: HaloMorph) not]]].
	otherSelection ifNil: [^ selectedItems := newItems].

	removals := newItems intersection: itemsAlreadySelected.
	otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
	selectedItems := (newItems copyWithoutAll: removals).! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add custom menu items to the menu"

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu addLine.
	aMenu add: 'add or remove items' target: self selector: #addOrRemoveItems: argument: aHandMorph.
	aMenu addList: {
		#-.
		{'Place into a row' . #organizeIntoRow}.
		{'Place into a column' . #organizeIntoColumn}.
		#-.
		{'Align left edges' . #alignLeftEdges}.
		{'Align top edges' . #alignTopEdges}.
		{'Align right edges' . #alignRightEdges}.
		{'Align bottom edges' . #alignBottomEdges}.
		#-.
		{'Align centers vertically' . #alignCentersVertically}.
		{'Align centers horizontally' . #alignCentersHorizontally}.
		}.

	self selectedItems size > 2
		ifTrue: [
			aMenu addList: {
				#-.
				{'Distribute vertically' . #distributeVertically}.
				{'Distribute horizontally' . #distributeHorizontally}.
				}.
		].! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
addOrRemoveItems: handOrEvent 
	"Make a new selection extending the current one."

	| hand |
	hand := (handOrEvent isMorphicEvent) 
				ifFalse: [handOrEvent]
				ifTrue: [handOrEvent hand].
	hand 
		addMorphBack: ((self class 
				newBounds: (hand lastEvent cursorPoint extent: 16 @ 16)) 
					setOtherSelection: self).! !

!SelectionMorph methodsFor: 'accessing' stamp: ''!
wantsToBeTopmost
	"Answer if the receiver want to be one of the topmost objects in 
	its owner"
	^ true! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
alignRightEdges
	"Make the right coordinate of all my elements be the same"

	| maxRight |
	maxRight := (selectedItems collect: [:itm | itm right]) max.
	selectedItems do:
		[:itm | itm right: maxRight].

	self changed! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
duplicate
	"Make a duplicate of the receiver and havbe the hand grab it"

	selectedItems :=  selectedItems collect: [:each | each duplicate].
	selectedItems reverseDo: [:m | (owner ifNil: [self world]) addMorph: m].
	dupLoc := self position.
	self activeHand grabMorph: self.! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
distributeVertically
	"Distribute the empty vertical space in a democratic way."
	| minTop maxBottom totalHeight currentTop space |
	self selectedItems size > 2
		ifFalse: [^ self].

	minTop := self selectedItems anyOne top.
	maxBottom := self selectedItems anyOne bottom.
	totalHeight := 0.
	self selectedItems
		do: [:each | 
			minTop := minTop min: each top.
			maxBottom := maxBottom max: each bottom.
			totalHeight := totalHeight + each height].

	currentTop := minTop.
	space := (maxBottom - minTop - totalHeight / (self selectedItems size - 1)) rounded.
	(self selectedItems asSortedCollection:[:x :y | x top <= y top])
		do: [:each | 
			each top: currentTop.
			currentTop := currentTop + each height + space].

	self changed! !

!SelectionMorph methodsFor: 'viewer' stamp: ''!
externalName
	^ 'Selected {1} objects' translated format:{self selectedItems size}! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
alignLeftEdges
	"Make the left coordinate of all my elements be the same"

	| minLeft |
	minLeft := (selectedItems collect: [:itm | itm left]) min.
	selectedItems do:
		[:itm | itm left: minLeft].

	self changed! !

!SelectionMorph methodsFor: 'halos and balloon help' stamp: ''!
balloonHelpTextForHandle: aHandle
	(aHandle eventHandler mouseSelectorsInclude: #addOrRemoveItems:)
		ifTrue: [^'Add items to, or remove them from, this selection.'].
	^ super balloonHelpTextForHandle: aHandle! !

!SelectionMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ (self defaultColor) twiceDarker alpha: 0.75! !

!SelectionMorph methodsFor: 'private' stamp: ''!
selectedItems

	^ selectedItems! !

!SelectionMorph methodsFor: 'halo commands' stamp: ''!
distributeHorizontally
	"Distribute the empty vertical space in a democratic way."
	| minLeft maxRight totalWidth currentLeft space |

	self selectedItems size > 2
		ifFalse: [^ self].

	minLeft := self selectedItems anyOne left.
	maxRight := self selectedItems anyOne right.
	totalWidth := 0.
	self selectedItems
		do: [:each | 
			minLeft := minLeft min: each left.
			maxRight := maxRight max: each right.
			totalWidth := totalWidth + each width].

	currentLeft := minLeft.
	space := (maxRight - minLeft - totalWidth / (self selectedItems size - 1)) rounded.
	(self selectedItems
		asSortedCollection: [:x :y | x left <= y left])
		do: [:each | 
			each left: currentLeft.
			currentLeft := currentLeft + each width + space].

	self changed! !

!SelectionMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"

	^ self theme menuSelectionColor alpha: 0.08! !

!SelectionMorph methodsFor: 'wiw support' stamp: ''!
morphicLayerNumber
	"helpful for insuring some morphs always appear in front of or  
	behind others. smaller numbers are in front"
	^ 8! !

!SelectionMorph methodsFor: 'undo' stamp: ''!
fillStyleForItems: fillStyleCollection

	selectedItems with: fillStyleCollection do: [:m :c | m fillStyle: c]! !

!SelectionValueHolder commentStamp: ''!
I am especially designed to contain a list selection (an index + an object)!
!SelectionValueHolder methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	index := 0 asValueHolder.
	selection := nil asValueHolder.
	
	index whenChangedSend: #valueChanged to: self.
	selection whenChangedSend: #valueChanged to: self.! !

!SelectionValueHolder methodsFor: 'accessing' stamp: ''!
selection

	^ selection! !

!SelectionValueHolder methodsFor: 'accessing' stamp: ''!
value

	^ {index. selection}! !

!SelectionValueHolder methodsFor: 'accessing' stamp: ''!
index: anIndex

	index := anIndex.
	self valueChanged: index! !

!SelectionValueHolder methodsFor: 'initialization' stamp: ''!
reset

	self index value: 0.
	self selection value: nil.
	self valueChanged! !

!SelectionValueHolder methodsFor: 'accessing' stamp: ''!
selection: aSelection

	selection := aSelection.
	self valueChanged: selection! !

!SelectionValueHolder methodsFor: 'accessing' stamp: ''!
index

	^ index! !

!SelectionValueHolder class methodsFor: 'instance creation' stamp: ''!
index: indexValueHolder selection: selectionValueHolder

	^ self new
		index: indexValueHolder;
		selection: selectionValueHolder;
		yourself! !

!SelectorException commentStamp: ''!
I am SelectorException, an abstract superclass for exceptions related to a selector.!
!SelectorException methodsFor: 'accessing' stamp: ''!
selector: aSelector
	selector := aSelector! !

!SelectorException methodsFor: 'printing' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		stream << 'for '.
		stream print: self selector.
		stream << ' in '.
		stream print: self signaler class]! !

!SelectorException methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!SelectorException methodsFor: 'accessing' stamp: ''!
messageText
	"Overwritten to initialiaze the message text to a standard text if it has not yet been set"
	
	^ messageText ifNil: [ messageText := self standardMessageText ]! !

!SelectorException class methodsFor: 'signaling' stamp: ''!
signalFor: aSelector
	"Create and signal an exception for aSelector in the default receiver."
	
	^ self new
		selector: aSelector;
		signal! !

!SelectorException class methodsFor: 'signaling' stamp: ''!
signalFor: aSelector in: aReceiver
	"Create and signal an exception for aSelector in aReceiver."

	^ self new
		selector: aSelector;
		signaler: aReceiver;
		signal! !

!SelfEvaluatingObjectTest commentStamp: ''!
SUnit tests for self evaluting objects !
!SelfEvaluatingObjectTest methodsFor: 'tests' stamp: ''!
testObjects

	self assert: 10 isSelfEvaluating.
	self assert: $a isSelfEvaluating.
	self assert: 3.14157 isSelfEvaluating.
	self assert: #(1 2 3) isSelfEvaluating.
	self assert: #abc isSelfEvaluating.
	self assert: 'abc' isSelfEvaluating.

	self assert: Object isSelfEvaluating.
	self assert: Object new isSelfEvaluating not.
	
	self assert: {Float infinity . Float nan. Float infinity negated} isSelfEvaluating.

	self assert: (Array with: 10) isSelfEvaluating.
	self assert: (Array with: Object new) isSelfEvaluating not.

	self assert: true isSelfEvaluating.
	self assert: false isSelfEvaluating.

	self assert: nil isSelfEvaluating.

	self assert: (1 to: 10) isSelfEvaluating.
	self assert: (1->2) isSelfEvaluating.
	self assert: Color red isSelfEvaluating.! !

!SelfEvaluatingObjectTest methodsFor: 'utilities' stamp: ''!
assertCode: code print: aString
	self assert: (self class evaluate: code) printString equals: aString! !

!SelfEvaluatingObjectTest methodsFor: 'tests' stamp: ''!
testArray

	self assertCode: '#(1 2 3)' print: '#(1 2 3)'.
	self assertCode: '{1 . 2 . 3}' print: '#(1 2 3)'.
	self assertCode: '{1 + 0 . 2 . 3}' print: '#(1 2 3)'.
	self assertCode: '{1 + 0 . 1 @ 2 . 3}' print: '{1. (1@2). 3}'.
	self assertCode: '{2@3}' print: '{(2@3)}'.
	self assertCode: '{Object new}' print:  'an Array(an Object)'.
	self assertCode: '{Rectangle new . Object new}' print:  'an Array(nil corner: nil an Object)'.
	self assertCode: '{10@10 corner: 20@20 . 100@100 corner: 200@200}' print: '{(10@10) corner: (20@20). (100@100) corner: (200@200)}'! !

!SelfPropagatingLinkDemo commentStamp: ''!
Small Demo of a Link that propages itself at runtime

instance :=SelfPropagatingLinkDemo new.

Now install on #factorial:
instance installOnAllSendsInMethod: (Integer>>#factorial)

if we now execute the code

    10 factorial

inspec the instance of SelfPropagatingLinkDemo to see which methods have been visited by the link!
!SelfPropagatingLinkDemo methodsFor: 'initialization' stamp: ''!
initialize

	methodsvisited := OrderedCollection new! !

!SelfPropagatingLinkDemo methodsFor: 'displaying' stamp: ''!
link
	^link := link ifNil: [MetaLink new
		metaObject: self;
		selector: #installOnAllSendsInMethod:;
		arguments: #(methodToExecute)]! !

!SelfPropagatingLinkDemo methodsFor: 'accessing' stamp: ''!
methodsvisited
	^ methodsvisited! !

!SelfPropagatingLinkDemo methodsFor: 'displaying' stamp: ''!
installOnAllSendsInMethod: aMethod
	methodsvisited add: aMethod.
	aMethod sendNodes do: [ :sendNode | (sendNode hasMetalink: self link) ifFalse: [sendNode link: self link]]! !

!SelfVariable commentStamp: ''!
I model "self" keyword !
!SelfVariable methodsFor: 'testing' stamp: ''!
isSelfVariable
	^true! !

!SelfVariable methodsFor: 'emitting' stamp: ''!
emitValue: methodBuilder

	methodBuilder pushReceiver! !

!SelfVariable methodsFor: 'debugging' stamp: ''!
readInContext: aContext
	^aContext receiver! !

!SelfVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode

	^ aProgramNodeVisitor visitSelfNode: aNode! !

!SelfVariable methodsFor: 'queries' stamp: ''!
usingMethods
	"Super sends are doing a pushSelf, too, we need to still check the AST level sometimes.
	FFI methods after a first call do not have a self send in the bytecode, but one in the code"

	^ environment allMethods select: [ :method | 
		method isFFIMethod or: [  
		  method readsSelf and: [ 
			  method sendsToSuper not or: [ 
				  method ast variableNodes anySatisfy: [ :varNode | 
					  varNode variable == self ] ] ] ] ]! !

!SelfVariable class methodsFor: 'accessing' stamp: ''!
variableName
	^'self'! !

!SelfVariableTest methodsFor: 'tests' stamp: ''!
testUsingMethodsFFI

	|  var |
	var := self class lookupVar: #self.
	
	"We find an ffi method that was run and thus does not contain any push self, yet has self send in the code"
	self assert: (var usingMethods anySatisfy: [:method | method isFFIMethod and: [ method readsSelf not ]])! !

!SelfVariableTest methodsFor: 'tests' stamp: ''!
testUsingMethods

	|  var |
	var := self class lookupVar: #self.
	self assert: (var usingMethods includes: thisContext method)! !

!SelfVariableTest methodsFor: 'tests' stamp: ''!
testUsingMethodsSuper

	|  var |
	"we use super instead of self to check that super sends are not understood as self sends"
	var := super class lookupVar: #self.
	super deny: (var usingMethods includes: thisContext method)! !

!SemanticMessageIconStyler methodsFor: 'hooks' stamp: ''!
segmentMorphClass

	^ RubTextBackgroundColorSegmentMorph! !

!SemanticMessageIconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^(Color lightOrange alpha: 0.2)! !

!SemanticMessageIconStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode
	^ aNode selector value asString, ' is not a recognized method '.! !

!SemanticMessageIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^ aNode isMessage and: [ (Symbol findInternedSelector: aNode selector value asString) isNil ]! !

!SemanticMessageIconStyler methodsFor: 'defaults' stamp: ''!
borderColor 
	^Color red! !

!SemanticMessageIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #smallQuestion! !

!SemanticVariableIconStyler methodsFor: 'hooks' stamp: ''!
segmentMorphClass

	^ RubTextBackgroundColorSegmentMorph! !

!SemanticVariableIconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^(Color red alpha: 0.2)! !

!SemanticVariableIconStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode
	^ aNode name printString, ' is not a known variable '.! !

!SemanticVariableIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^ aNode isVariable and: [ aNode binding isUndeclaredVariable ]! !

!SemanticVariableIconStyler methodsFor: 'defaults' stamp: ''!
borderColor 
	^nil! !

!SemanticVariableIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^ self iconNamed: #warning! !

!SemanticWarningIconStyler commentStamp: ''!
I'm in charge to style an ast when there are semantic warnings!
!SemanticWarningIconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^(Color yellow alpha: 0.3)! !

!SemanticWarningIconStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode
	^'Semantic warning: ', (aNode propertyAt: #semanticWarning) asString! !

!SemanticWarningIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^aNode hasProperty: #semanticWarning! !

!SemanticWarningIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^self iconNamed: #flag.! !

!Semaphore commentStamp: ''!
I'm a traditional semaphore, i.e., an elementary but important abstraction for process synchronisation. Using semaphores, concurrent processes are synchronized using wait and signal messages. If no signal has been sent when a wait message is sent, the sending process is suspended until a signal is sent. The suspended process is added to a semaphore waiting list of processes, and when a signal is received by the semaphore, waiting processes are scheduled. 

From an abstract implementation explanation, I'm basically a queue with an excess signals count, which is a non-negative integer. 
- On instance creation, a new semaphore is empty and has a zero excess signals count.
- When a process waits on a semaphore (result of sending the message wait to the semaphore that is 'busy'), if the semaphore's excess signals count is non-zero, then the excess signal count is decremented, and the process proceeds. If the semaphore has a zero excess signals count then the process is unscheduled and added to the end of the semaphore waiting list, after any other processes that are were already queued on the semaphore.
- When a semaphore is signaled, and if there are waiting processes on the semaphore waiting list, the first process is removed from it and added to the runnable processes in the scheduler. If the semaphore waiting list is empty, its excess signals count is simply incremented (it is often said that the semaphore is prearmed).

A semaphore created for mutual exclusion is empty and has an excess signals count of one.

Implementation note.
While conceptually a semaphore has a list and a counter of excess signals. At the implementation level, the class Semaphore inherits from the class LinkedList, so the waiting process list is 'directly' in the semaphore itself. Since Process inherits from the class Link, elements that can be added to linked list and to the semaphore directly without being wrapped by an linked list element object.
This is a design simplification for the virtual machine.!
!Semaphore methodsFor: 'mutual exclusion' stamp: ''!
critical: mutuallyExcludedBlock ifLocked: alternativeBlock
	"Evaluate mutuallyExcludedBlock only if the receiver is not currently in 
	the process of running the critical: message. If the receiver is, evaluate 
	mutuallyExcludedBlock after the other critical: message is finished."
	
	"Note: The following is tricky and depends on the fact that the VM will not switch between 
processes while executing byte codes (process switches happen only in real sends). The following 
test is written carefully so that it will result in bytecodes only."

	excessSignals == 0 
		ifTrue: 
			[ "If we come here, then the semaphore was locked when the test executed. 
			Evaluate the alternative block and answer its result."
			^alternativeBlock value ].
	^self critical: mutuallyExcludedBlock! !

!Semaphore methodsFor: 'communication' stamp: ''!
wait
	"Primitive. The active Process must receive a signal through the receiver 
	before proceeding. If no signal has been sent, the active Process will be 
	suspended until one is sent. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 86>
	self primitiveFailed

	"excessSignals>0  
		ifTrue: [excessSignals := excessSignals-1]  
		ifFalse: [self addLastLink: Processor activeProcess suspend]"! !

!Semaphore methodsFor: 'mutual exclusion' stamp: ''!
criticalReleasingOnError: mutuallyExcludedBlock
	"This is like #critical: but releasing the lock if there is an exception in the block"	
	| blockValue caught |
	caught := false.
	[
		caught := true.
		self wait.
		blockValue := mutuallyExcludedBlock 
			on: Exception 
			do: [ :e | caught ifTrue: [self signal]. 
				caught := false.
				e pass.].

	] ensure: [caught ifTrue: [self signal]].

	^blockValue! !

!Semaphore methodsFor: 'comparing' stamp: ''!
= anObject
	^ self == anObject! !

!Semaphore methodsFor: 'comparing' stamp: ''!
hash
	^ self identityHash! !

!Semaphore methodsFor: 'initialization' stamp: ''!
initSignals
	"Consume any excess signals the receiver may have accumulated."

	excessSignals := 0.! !

!Semaphore methodsFor: 'testing' stamp: ''!
isSignaled
	"Return true if this semaphore is currently signaled"
	^excessSignals > 0! !

!Semaphore methodsFor: '*ThreadedFFI' stamp: ''!
signalAll
 
	[ self isEmpty ] 
	whileFalse: [ self signal ]! !

!Semaphore methodsFor: 'mutual exclusion' stamp: ''!
critical: mutuallyExcludedBlock ifCurtailed: terminationBlock
	"Evaluate mutuallyExcludedBlock only if the receiver is not currently in 
	the process of running the critical: message. If the receiver is, evaluate 
	mutuallyExcludedBlock after the other critical: message is finished."
	^self critical:[mutuallyExcludedBlock ifCurtailed: terminationBlock]! !

!Semaphore methodsFor: 'initialization' stamp: ''!
consumeAllSignals
	"Consume any excess signals the receiver may have accumulated."

	excessSignals := 0.! !

!Semaphore methodsFor: 'communication' stamp: ''!
waitTimeoutSeconds: anInteger
	"Wait on this semaphore for up to the given number of seconds, then timeout.
	Return true if the deadline expired, false otherwise."
	^self waitTimeoutMSecs: anInteger * 1000.! !

!Semaphore methodsFor: 'mutual exclusion' stamp: ''!
critical: mutuallyExcludedBlock ifError: errorBlock
	"Evaluate mutuallyExcludedBlock only if the receiver is not currently in 
	the process of running the critical: message. If the receiver is, evaluate 
	mutuallyExcludedBlock after the other critical: message is finished."
	| blockValue hasError errObj |
	hasError := false.
	self critical:[
		blockValue := mutuallyExcludedBlock onErrorDo: [ :err |
			hasError := true.
			errObj := err.
		].
	].
	hasError ifTrue: [ ^errorBlock cull: errObj ].
	^blockValue! !

!Semaphore methodsFor: 'process termination handling' stamp: ''!
handleProcessTerminationOfWaitingContext: suspendedContext

	^suspendedContext compiledCode method == (Semaphore compiledMethodAt: #critical:) 
		ifTrue: [ suspendedContext home]
		ifFalse: [ suspendedContext]! !

!Semaphore methodsFor: 'communication' stamp: ''!
waitTimeoutMSecs: anInteger
	"Wait on this semaphore for up to the given number of milliseconds, then timeout. 
	Return true if the deadline expired, false otherwise."
	| d |
	d := DelayWaitTimeout new setDelay: (anInteger max: 0) forSemaphore: self.
	^d wait! !

!Semaphore methodsFor: 'communication' stamp: ''!
signal
	"Primitive. Send a signal through the receiver. If one or more processes 
	have been suspended trying to receive a signal, allow the first one to 
	proceed. If no process is waiting, remember the excess signal. Essential. 
	See Object documentation whatIsAPrimitive."

	<primitive: 85>
	self primitiveFailed

	"self isEmpty    
		ifTrue: [excessSignals := excessSignals+1]    
		ifFalse: [Processor resume: self removeFirstLink]"! !

!Semaphore methodsFor: 'initialize-release' stamp: ''!
terminateProcess
	"Terminate the process waiting on this semaphore, if any."

	self isEmpty ifFalse: [ self removeFirst terminate ].! !

!Semaphore methodsFor: 'mutual exclusion' stamp: ''!
critical: mutuallyExcludedBlock			
	"Evaluate mutuallyExcludedBlock only if the receiver is not currently in
	the process of running the critical: message. If the receiver is, evaluate
	mutuallyExcludedBlock after the other critical: message is finished."
	
	"We need to catch eventual interruptions very carefully.
	The naive approach of just doing, e.g.,:
			self wait.
			aBlock ensure: [self signal].
	will fail if the active process gets terminated while in the wait.
	However, the equally naive:
			[self wait.
			aBlock value] ensure: [self signal].
	will fail too, since the active process may get interrupted while
	entering the ensured block and leave the semaphore signaled twice.
	To avoid both problems we make use of the fact that interrupts only
	occur on sends (or backward jumps) and use an assignment (bytecode)
	right before we go into the wait primitive (which is not a real send and
	therefore not interruptable either)."
	
	| blockValue caught |
	caught := false.
	[
		caught := true.
		self wait.
		blockValue := mutuallyExcludedBlock value
	] ensure: [caught ifTrue: [self signal]].
	^blockValue! !

!Semaphore methodsFor: 'initialization' stamp: ''!
resumeProcess: aProcess
	"Remove the given process from the list of waiting processes (if it's there) and resume it.  This is used when a process asked for its wait to be timed out."

	| process |
	process := self remove: aProcess ifAbsent: [nil].
	process ifNotNil: [process resume].! !

!Semaphore methodsFor: 'communication' stamp: ''!
wait: aDuration onCompletion: completionBlock onTimeout: timeoutBlock
	"Wait on this semaphore for up to the given time duration, then timeout.
	If the deadline expired execute timeoutBlock, otherwise execute completionBlock.
	Return the value returned by the executed block."
	| d |
	d := DelayWaitTimeout new setDelay: aDuration asMilliSeconds forSemaphore: self.
	^d waitOnCompletion: completionBlock onTimeout: timeoutBlock! !

!Semaphore methodsFor: 'communication' stamp: ''!
waitTimeoutSeconds: anInteger onCompletion: completionBlock onTimeout: timeoutBlock
	"Wait on this semaphore for up to the given number of seconds, then timeout.
	If the deadline expired execute timeoutBlock, otherwise execute completionBlock.
	Return the value returned by the executed block."
	| d |
	d := DelayWaitTimeout new setDelay: (anInteger * 1000 max: 0) forSemaphore: self.
	^d waitOnCompletion: completionBlock onTimeout: timeoutBlock! !

!Semaphore methodsFor: 'communication' stamp: ''!
wait: aDuration
	"Wait on this semaphore for up to the given time duration, then timeout. 
	Return true if the deadline expired, false otherwise."
	| d |
	d := DelayWaitTimeout new setDelay: aDuration asMilliSeconds forSemaphore: self.
	^d wait! !

!Semaphore class methodsFor: 'instance creation' stamp: ''!
new
	"Answer a new instance of Semaphore that contains no signals."

	^self basicNew initSignals! !

!Semaphore class methodsFor: 'instance creation' stamp: ''!
forMutualExclusion
	"Answer an instance of me that contains a single signal. This new 
	instance can now be used for mutual exclusion (see the critical: message 
	to Semaphore)."

	^self new signal! !

!SemaphoreTest commentStamp: ''!
A SemaphoreTest is sunit test for simple and multiEx semaphores

Instance Variables none; does not have common test fixture accross all tests (because its testing differenct sorts of semaphores (could refactor into muliple testcases if there were more test conditions.
!
!SemaphoreTest methodsFor: 'tests' stamp: ''!
testCritical
	| lock |
	lock := Semaphore forMutualExclusion.
	[lock critical: [self criticalError]] forkAt: Processor userInterruptPriority.
	self assert: lock isSignaled! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testCriticalIfError
	| lock |
	lock := Semaphore forMutualExclusion.
	[lock critical: [self criticalError onErrorDo:[]]] forkAt: Processor userInterruptPriority.
	self assert: lock isSignaled! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testSimpleCommunication
	"A process waiting on a signal will not proceed until one is sent"

	| semaphore wasBlockStarted wasBlockFinished |
	wasBlockStarted := wasBlockFinished := false.
	semaphore := Semaphore new.
	
	[
		wasBlockStarted := true.
		semaphore wait.
		wasBlockFinished := true ] fork.

	Processor yield.
	
	self assert: wasBlockStarted.
	self deny: wasBlockFinished.
	
	semaphore signal.
	Processor yield.
	
	self assert: wasBlockFinished.! !

!SemaphoreTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testWaitAndWaitTimeoutTogether
	| semaphore value waitProcess waitTimeoutProcess |
	semaphore := Semaphore new.

	waitProcess := [ semaphore wait.
	value := #wait ] fork.

	waitTimeoutProcess := [ semaphore waitTimeoutMSecs: 50.
	value := #waitTimeout ] fork.

	"Wait for the timeout to happen"
	(Delay forMilliseconds: 100) wait.

	"The waitTimeoutProcess should already have timed out.  This should release the waitProcess"
	semaphore signal.

	[ waitProcess isTerminated and: [ waitTimeoutProcess isTerminated ] ] whileFalse: [ (Delay forMilliseconds: 100) wait ].

	self assert: value equals: #wait! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testReturnsAsManyWaitsAsSignalsReceived

	| semaphore semaphoreReturnedOnce semaphoreReturnedTwice |
	semaphoreReturnedOnce := semaphoreReturnedTwice := false.
	semaphore := Semaphore new.
	
	[
		semaphore wait.
		semaphoreReturnedOnce := true.
		semaphore wait.
		semaphoreReturnedTwice := true ] fork.

	Processor yield.
	self deny: semaphoreReturnedOnce.
	
	semaphore signal.
	Processor yield.
	self assert: semaphoreReturnedOnce.
	self deny: semaphoreReturnedTwice.
	
	semaphore signal.
	Processor yield.
	self assert: semaphoreReturnedTwice.! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testWaitTimeDuration
	"Ensure that wait: aDuration behaves properly"

	"Ensure that a timed out wait: aDuration returns true from the wait"

	self assert: (Semaphore new wait: 50 milliSeconds) identicalTo: true.

	"Ensure that a signaled wait: aDuration returns false from the wait"
	self assert: (Semaphore new signal wait: 50 milliSeconds) identicalTo: false! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testWaitTimeoutSecondsOnCompletionOnTimeout
	"Ensure that waitTimeoutSeconds:onCompletion:onTimeout: behaves properly"

	"Ensure that a timed out waitTimeoutSeconds:onCompletion:onTimeout: returns the value of the timeout block"

	self assert: (Semaphore new waitTimeoutSeconds: 0.05 onCompletion: [ #completed ] onTimeout: [ #timeout ]) identicalTo: #timeout.

	"Ensure that a signaled waitTimeoutSeconds:onCompletion:onTimeout: returns the value of the completed block"
	self assert: (Semaphore new signal waitTimeoutSeconds: 0.05 onCompletion: [ #completed ] onTimeout: [ #timeout ]) identicalTo: #completed! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testWaitTimeDurationWithCompletionAndTimeoutBlocks
	"Ensure that wait:onCompletion:onTimeout: behaves properly"

	"Ensure that a timed out wait:onCompletion:onTimeout: returns the value of the timeout block"

	self assert: (Semaphore new wait: 50 milliSeconds onCompletion: [ #completed ] onTimeout: [ #timeout ]) identicalTo: #timeout.

	"Ensure that a signaled wait:onCompletion:onTimeout: returns the value of the completed block"
	self assert: (Semaphore new signal wait: 50 milliSeconds onCompletion: [ #completed ] onTimeout: [ #timeout ]) identicalTo: #completed! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testSchedulesFIFO
	"Based only on wait time, independent of process priority"

	| semaphore waitingLongestResumed higherPriorityResumed |
	waitingLongestResumed := higherPriorityResumed := false.
	semaphore := Semaphore new.
	
	[
		semaphore wait.
		waitingLongestResumed := true ] forkAt: Processor activeProcess priority + 10.
	[
		semaphore wait.
		higherPriorityResumed := true ] forkAt: Processor activeProcess priority + 20.

	self deny: waitingLongestResumed.
	self deny: higherPriorityResumed.

	semaphore signal.
	self assert: waitingLongestResumed.
	
	semaphore signal.
	self assert: higherPriorityResumed.! !

!SemaphoreTest methodsFor: 'private' stamp: ''!
criticalError
	Processor activeProcess terminate! !

!SemaphoreTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Semaphore! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testAfterCriticalWait
	"This tests whether a semaphore that has just left the wait in Semaphore>>critical: leaves it with signaling the associated semaphore."
	
	| s p |
	s := Semaphore new.
	p := [s critical:[]] forkAt: Processor activePriority-1.
	"wait until p entered the critical section"
	[p suspendingList == s] whileFalse:[(Delay forMilliseconds: 10) wait].
	"Now that p entered it, signal the semaphore. p now 'owns' the semaphore
	but since we are running at higher priority than p it will not get to do
	anything."
	s signal.
	p terminate.
	self assert: (s instVarNamed: #excessSignals) equals: 1! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testWaitTimeoutMSecs
	"Ensure that waitTimeoutMSecs behaves properly"

	"Ensure that a timed out waitTimeoutMSecs: returns true from the wait"

	self assert: (Semaphore new waitTimeoutMSecs: 50) identicalTo: true.

	"Ensure that a signaled waitTimeoutMSecs: returns false from the wait"
	self assert: (Semaphore new signal waitTimeoutMSecs: 50) identicalTo: false! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testMutualExclusion

	| lock steps |
	steps := OrderedCollection new.
	lock := Semaphore forMutualExclusion.
	
	[
		steps add: #startProcess1.
		lock critical: [
			steps add: #startCritical1.
			"waiting next process run"
			[steps includes: #startProcess2] whileFalse: [Processor yield].
			steps add: #endCritical1 ] ] fork.
	[
		"Waiting first process run"
		[steps includes: #startProcess1] whileFalse: [Processor yield].
		steps add: #startProcess2.
		lock critical: [ 
			steps add: #startCritical2.
			Processor yield.
			steps add: #endCritical2 ] ] fork.
	
	[ steps size = 6 ] whileFalse: [ Processor yield ].

	self assert: (steps hasEqualElements: #(startProcess1 startCritical1 startProcess2 endCritical1 startCritical2 endCritical2))! !

!SemaphoreTest methodsFor: 'tests' stamp: ''!
testInCriticalWait
	"This tests whether a semaphore that has entered the wait in Semaphore>>critical:
	leaves it without signaling the associated semaphore."

	| s p |
	s := Semaphore new.
	p := [ s critical: [  ] ] fork.
	Processor yield.
	self assert: p suspendingList identicalTo: s.
	p terminate.
	self assert: (s instVarNamed: #excessSignals) equals: 0! !

!SendsDeprecatedMethodToGlobalRule commentStamp: ''!
Checks for sends of deprecated messages that might be removed in upcoming releases of Pharo.!
!SendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: ''!
severity
	^ #error! !

!SendsDeprecatedMethodToGlobalRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	| value |
	aNode isMessage ifFalse: [ ^ false ].
	aNode receiver isLiteralVariable ifFalse: [ ^ false ].
	value := aNode receiver variable value.
	^value class classAndMethodFor: aNode selector
		do: [ :class :method | method isDeprecated ]
		ifAbsent: [ false ]! !

!SendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: ''!
group
	^ 'Design Flaws'! !

!SendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: ''!
name
	^ 'Sends a deprecated message to a known global'! !

!SendsDeprecatedMethodToGlobalRule class methodsFor: 'accessing' stamp: ''!
uniqueIdentifierName
	"This number should be unique and should change only when the rule completely change semantics"
	
	^'SendsDeprecatedMethodToGlobalRule'! !

!SendsDeprecatedMethodToGlobalRuleTest methodsFor: 'properties' stamp: ''!
deprecatedMethodName

	^ 'deprecatedMethod'! !

!SendsDeprecatedMethodToGlobalRuleTest methodsFor: 'running' stamp: ''!
tearDown

	testingEnvironment removeKey: self globalName ifAbsent: [ ].
	globalName := nil.
	testClass := nil.
	super tearDown! !

!SendsDeprecatedMethodToGlobalRuleTest methodsFor: 'tests' stamp: ''!
testBasicCheck1

	| testMethod |
	testMethod := testClass >> (
		testClass compile: 'testMethod ', self globalName, ' ', self nonDeprecatedMethodName).

	self assert: (testMethod critiques noneSatisfy: [ :eprop |
		eprop rule class = SendsDeprecatedMethodToGlobalRule ])! !

!SendsDeprecatedMethodToGlobalRuleTest methodsFor: 'tests' stamp: ''!
testBasicCheck3

	| testMethod |
	
	testClass addClassVarNamed: #TestVar.
	
	testMethod := testClass >> (
		testClass compile: 'testMethod TestVar yourself').

	self assert: (testMethod critiques noneSatisfy: [ :eprop |
		eprop rule class = SendsDeprecatedMethodToGlobalRule ])! !

!SendsDeprecatedMethodToGlobalRuleTest methodsFor: 'properties' stamp: ''!
nonDeprecatedMethodName

	^ 'not', self deprecatedMethodName! !

!SendsDeprecatedMethodToGlobalRuleTest methodsFor: 'properties' stamp: ''!
globalName

	^ globalName ifNil: [ 
		[ globalName :=
			('TestGlobal', 1e10 atRandom asString) asSymbol
		] doWhileTrue: [ 
			"if the name already exists, we generate another one"
			testingEnvironment includesKey: globalName ] ]! !

!SendsDeprecatedMethodToGlobalRuleTest methodsFor: 'tests' stamp: ''!
testBasicCheck

	| testMethod |
	testMethod := testClass >> (
		testClass compile: 'testMethod ', self globalName, ' ', self deprecatedMethodName).

	self assert: (testMethod critiques anySatisfy: [ :eprop |
		eprop rule class = SendsDeprecatedMethodToGlobalRule ])! !

!SendsDeprecatedMethodToGlobalRuleTest methodsFor: 'tests' stamp: ''!
testBasicCheck2

	| testMethod |
	testMethod := testClass >> (
		testClass compile: 'testMethod ').

	self assert: (testMethod critiques noneSatisfy: [ :eprop |
		eprop rule class = SendsDeprecatedMethodToGlobalRule ])! !

!SendsDeprecatedMethodToGlobalRuleTest methodsFor: 'running' stamp: ''!
setUp
	| deprClass |
	super setUp.
	deprClass := Object newAnonymousSubclass. 
	testingEnvironment at: self globalName put: deprClass new.
	
	deprClass compile: self deprecatedMethodName, ' self deprecated: ''this method is deprecated'''.
	deprClass compile: self nonDeprecatedMethodName.
	
	testClass := Object newAnonymousSubclass.! !

!SeparatorMorph commentStamp: ''!
Simple themed separator morph.!
!SeparatorMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Change our fill too."
	
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	self fillStyle: (self theme separatorFillStyleFor: self)! !

!SequenceableCollection commentStamp: ''!
I am an abstract superclass for collections that have a well-defined order associated with their elements. Thus each element is externally-named by integers referred to as indices.!
!SequenceableCollection methodsFor: 'accessing' stamp: ''!
atAll: aCollection put: anObject 
	"Put anObject at every index specified by the elements of aCollection."
	"({#x .#y .#z} atAll: #(1 3) put: #e; yourself) >>> #(e y e)"

	aCollection do: [:index | self at: index put: anObject].
	^ anObject! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
isSequenceable
	^ true! !

!SequenceableCollection methodsFor: 'testing' stamp: ''!
includes: anObject
	"Answer whether anObject is one of the receiver's elements."

	^ (self indexOf: anObject) ~= 0! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
reverseDo: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument, 
	starting with the last element and taking each in sequence up to the 
	first. For SequenceableCollections, this is the reverse of the enumeration 
	for do:."
	
	"(Array streamContents: [:stream | #(1 2 3) reverseDo: [:each | stream nextPut: each + 10]]) >>> #(13 12 11)"

	self size to: 1 by: -1 do: [:index | aBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'private' stamp: ''!
errorOutOfBounds

	SubscriptOutOfBounds signal! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
combinations
	"Return all the combinations of elements of the receiver. Note that combinations does not include the empty element contrary to the mathematical definition of combinations."

	"#(1 2 3 4) combinations >>> #(#(1) #(2) #(3) #(4) #(1 2) #(1 3) #(1 4) #(2 3) #(2 4) #(3 4) #(1 2 3) #(1 2 4) #(1 3 4) #(2 3 4) #(1 2 3 4))"

	^ Array
		streamContents: [ :stream | 
			1 to: self size do:
				[ :take | self combinations: take atATimeDo: [ :combination | stream nextPut: combination copy ] ] ]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
lastIndexOf: anElement startingAt: lastIndex ifAbsent: exceptionBlock
	"Answer the index of the last occurrence of anElement within the  
	receiver. If the receiver does not contain anElement, answer the
	result of evaluating the argument, exceptionBlock."
	"(#(a b a d a) lastIndexOf: #a startingAt: 1 ifAbsent: 7) >>> 1"
	"(#(e b a d e) lastIndexOf: #a startingAt: 4 ifAbsent: 7) >>> 3"

	lastIndex to: 1 by: -1 do:
		[:index |
		(self at: index) = anElement ifTrue: [^ index]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'private' stamp: ''!
permutationsStartingAt: anInteger do: aBlock
	anInteger > self size
		ifTrue: [ ^ self ].
	anInteger = self size
		ifTrue: [ ^ aBlock value: self ].
	anInteger to: self size do: [ :i | 
		self swap: anInteger with: i.
		self permutationsStartingAt: anInteger + 1 do: aBlock.
		self swap: anInteger with: i ]! !

!SequenceableCollection methodsFor: '*Roassal3' stamp: ''!
reverseSortedAs: aSortBlockOrSymbol
	"Answer a SortedCollection whose elements are the elements of the 
	receiver. The sort order is defined by the argument, aSortBlock."

	| aSortedCollection aSortBlock |
	aSortedCollection := SortedCollection new: self size.
	aSortBlock := 
		aSortBlockOrSymbol isSymbol 
			ifTrue: [ [:a :b | |t1 t2|
							t1 := (a perform: aSortBlockOrSymbol).
							t2 := (b perform: aSortBlockOrSymbol).
							((t1 isKindOf: Boolean) and: [t2 isKindOf: Boolean])
								ifTrue: [ t1 ]
								ifFalse: [ t1 > t2 ] ] ]
			ifFalse: [ 
				(aSortBlockOrSymbol numArgs = 1)
					ifTrue: [ [ :v1 :v2 | (aSortBlockOrSymbol value: v1) > (aSortBlockOrSymbol value: v2) ] ]
					ifFalse: [ aSortBlockOrSymbol ] ].
	aSortedCollection sortBlock: aSortBlock.
	aSortedCollection addAll: self.
	^ aSortedCollection! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
do: aBlock 
	"Refer to the comment in Collection|do:."
	1 to: self size do:
		[:index | aBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
last
	"Answer the last element of the receiver"
	"#(a b c d e) last >>> #e"

	^ self at: self size! !

!SequenceableCollection methodsFor: 'private' stamp: ''!
combinationsAt: jj in: aCollection after: nn do: aBlock
	"Choose k of N items and put in aCollection.  jj-1 already chosen.  Indexes of items are in numerical order, to avoid the same combo being used twice.  In this slot, we are allowed to use items in self indexed by nn+1 to self size.  nn is the index used for position jj-1."

	nn + 1 to: self size do: [ :index | 
		aCollection at: jj put: (self at: index).
		jj = aCollection size
			ifTrue: [ aBlock value: aCollection ]
			ifFalse: [ 
				self
					combinationsAt: jj + 1
					in: aCollection
					after: index
					do: aBlock ] ]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
with: otherCollection collect: twoArgBlock 
	"Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection."
	
	"(#(1 2 3) with: #(4 5 6) collect: [:a :b | a + b]) >>> #(5 7 9)"
	
	| result |
	otherCollection size = self size ifFalse: [self errorSizeMismatch].
	result := self species new: self size.
	1 to: self size do:
		[:index | result at: index put:
		(twoArgBlock
			value: (self at: index)
			value: (otherCollection at: index))].
	^ result! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyAfterLast: anElement
	"Answer a copy of the receiver from after the last occurrence
	of anElement up to the end. If no such element exists, answer 
	an empty copy."

	^ self allButFirst: (self lastIndexOf: anElement ifAbsent: [^ self copyEmpty])! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
sixth
	"Answer the sixth element of the receiver.
	Raise an error if there are not enough elements."
	"#(a b c d e f g h i) sixth >>> #f"

	^ self at: 6! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
asDigitsToPower: anInteger do: aBlock
	"Repeatedly value aBlock with a single Array.  Adjust the collection
	so that aBlock is presented all (self size raisedTo: anInteger) possible 
	combinations of the receiver's elements taken as digits of an anInteger long number."

	"(Array streamContents: [:stream | (0 to: 1) asDigitsToPower: 4 do: [:each | stream nextPut: each copy]]) >>> #(#(0 0 0 0) #(0 0 0 1) #(0 0 1 0) #(0 0 1 1) #(0 1 0 0) #(0 1 0 1) #(0 1 1 0) #(0 1 1 1) #(1 0 0 0) #(1 0 0 1) #(1 0 1 0) #(1 0 1 1) #(1 1 0 0) #(1 1 0 1) #(1 1 1 0) #(1 1 1 1))"

	| aCollection |
	aCollection := Array new: anInteger.
	self asDigitsAt: 1 in: aCollection do: aBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
overlappingPairsDo: aBlock 

	"Emit overlapping pairs of my elements into aBlock"
	
	"(Array streamContents: [:stream | #(1 2 3 4) overlappingPairsDo: [:first :second| stream nextPut: (first + second)]]) >>> #(3 5 7)"

	1 to: self size - 1
		do: [:i | aBlock value: (self at: i) value: (self at: i + 1)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
bind: aBlock 

	"Extract items from the receiver and use them as arguments of aBlock. Signal an error
	(ArgumentsCountMismatch) when the arguments count of aBlock does not match the receiver size." 
	
	"(#(1 2 3) bind: [ :first :second :third | first + second + third ]) >>> 6"

	^ aBlock valueWithArguments: self! !

!SequenceableCollection methodsFor: '*Tool-Diff' stamp: ''!
groupByRuns: aBlock
	"Answer a new collection of the same species as the receiver with elements being collections (of the receiver species) containing those elements of the receiver for which the given block consecutively evaluates to the same object."

	"(#(1 2 3 4 4 1 2 3 5 6 ) groupByRuns: [ :each | each = 4]) >>> #(#(1 2 3) #(4 4) #(1 2 3 5 6))"

	"(#(1 2 3 4 1 2 3 4 5 6 ) groupByRuns: [ :each | each = 4]) >>> #(#(1 2 3) #(4) #(1 2 3) #(4) #(5 6))"

	"((1 to: 12) groupByRuns: [ :each | (each \\ 3) = 0]) >>> #(#(1 2) #(3) #(4 5) #(6) #(7 8) #(9) #(10 11) #(12))"

	| str eStr r |
	str := Array new writeStream.
	r := nil.
	eStr := Array new writeStream.
	self
		do: [ :e | 
			| t |
			(t := aBlock value: e) = r
				ifFalse: [ r := t.
					eStr isEmpty
						ifFalse: [ str nextPut: (eStr contents as: self species).
							eStr reset ] ].
			eStr nextPut: e ].
	eStr isEmpty
		ifFalse: [ str nextPut: (eStr contents as: self species) ].
	^ str contents as: self species! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
size
	"#(a b c d e) size >>> 5"
	"#(x y z) size >>> 3"
	
	^ self subclassResponsibility! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
before: target ifAbsent: exceptionBlock
	"Answer the receiver's element immediately before target. Answer
	the result of evaluating the exceptionBlock if target is not an element
	of the receiver, or if there are no elements before it."
	"(#(11 22 33) before: 22 ifAbsent: 55) >>> 11"
	"(#(11 22 33) before: 44 ifAbsent: 55) >>> 55"

	| index |
	index := self indexOf: target.
	^ (index = 0 or: [index = 1])
		ifTrue: [exceptionBlock value]
		ifFalse: [self at: index - 1]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
reject: rejectBlock thenCollect: collectBlock
	"Optimized version of Collection>>#reject:thenCollect:"
	
	"(#(1 2 3 4) reject: [:each | each = 3 ] thenCollect: [:each | each + 10 ]) >>> #(11 12 14)"
	
	| each |

	^ self class new: self size streamContents: [ :stream|
		1 to: self size do: [ :index |
			(rejectBlock value: (each := self at: index))
				ifFalse: [ stream nextPut: (collectBlock value: each) ]]]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
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."

	"(Array streamContents: [:stream | (1 to: 3) permutationsDo: [:each | stream nextPut: each copy]]) >>> #(#(1 2 3) #(1 3 2) #(2 1 3) #(2 3 1) #(3 2 1) #(3 1 2))"

	self shallowCopy permutationsStartingAt: 1 do: aBlock! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
fourth
	"Answer the fourth element of the receiver.
	Raise an error if there are not enough elements."
	"#(a b c d e f g h ) fourth >>> #d"

	^ self at: 4! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
pairsCollect: aBlock
	"Evaluate aBlock with my elements taken two at a time, and return an Array with the results"

	"(#(1 'fred' 2 'charlie' 3 'elmer') pairsCollect: [:a :b | b, ' is number ', a printString]) >>> #('fred is number 1' 'charlie is number 2' 'elmer is number 3')"

	^ (1 to: self size // 2)
		collect: [ :index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index) ]! !

!SequenceableCollection methodsFor: '*Spec2-Code-Diff' stamp: ''!
zAt: index

	^ self at: index + 1! !

!SequenceableCollection methodsFor: 'comparing' stamp: ''!
= otherCollection 
	"Answer true if the receiver is equivalent to the otherCollection.
	First test for identity, then rule out different species and sizes of
	collections. As a last resort, examine each element of the receiver
	and the otherCollection."

	self == otherCollection ifTrue: [^ true].
	self species == otherCollection species ifFalse: [^ false].
	^ self hasEqualElements: otherCollection! !

!SequenceableCollection methodsFor: 'testing' stamp: ''!
endsWithAnyOf: aCollection
	"Return true if the receiver ends with any of the elements in aCollection."
	^aCollection anySatisfy:[:suffix| self endsWith: suffix]! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
reverse
	"Answer a copy of the receiver with element order reversed, as expected by ANSI."

	^ self reversed! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
findBinary: aBlock ifNone: exceptionBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, evaluate exceptionBlock,
	with the 'bounding' elements as optional arguments."
	
	"(#(1 3 5 7 11 15 23) findBinary: [ :arg | 24 - arg ] ifNone: ['Not found']) >>> 'Not found'"
	
	"(#(1 3 5 7 11 15 23) findBinary: [ :arg | 24 - arg ] ifNone: [:a :b | 'over ', a printString]) >>> 'over 23'"
	
	"(#(1 3 5 7 11 15 23) findBinary: [ :arg | 25 - arg ] ifNone: [ :a :b | 'between: ',{a. b} printString ]) >>> 'between: #(23 nil)'"
	
	^ self 
		findBinary: aBlock 
		do: [ :found | found ] 
		ifNone: exceptionBlock! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock
	"Answer the index of the receiver's first element, such that that element 
	equals the first element of sub, and the next elements equal 
	the rest of the elements of sub. Begin the search at element 
	start of the receiver. If no such match is found, answer the result of 
	evaluating argument, exceptionBlock."
	"(#(a b c d e) indexOfSubCollection: #(c d) startingAt: 2 ifAbsent: 7) >>> 3"
	"(#(a b c d e) indexOfSubCollection: #(c d) startingAt: 4 ifAbsent: 7) >>> 7"
	
	| first index |
	sub isEmpty ifTrue: [^ exceptionBlock value].
	first := sub first.
	start to: self size - sub size + 1 do:
		[:startIndex |
		(self at: startIndex) = first ifTrue:
			[index := 1.
			[(self at: startIndex+index-1) = (sub at: index)]
				whileTrue:
				[index = sub size ifTrue: [^startIndex].
				index := index+1]]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
select: aBlock 
	"Optimized version of Collection>>#select:"
	
	"(#(1 2 3 4) select: [:each | each > 2 ]) >>> #(3 4)"
	
	| each |
	^ self species new: self size streamContents: [ :stream|
		1 to: self size do: [ :index |
			(aBlock value: (each := self at: index))
				ifTrue: [ stream nextPut: each ]]]! !

!SequenceableCollection methodsFor: 'splitjoin' stamp: ''!
split: aSequenceableCollection indicesDo: aBlock
	"Perform an action specified as aBlock (with a start and end argument) to each of the indices of aSequenceableCollection that have been identified by taking the receiver as a splitter."
	"('||' split: 'foo||bar||2')>>>#('foo' 'bar' '2') asOrderedCollection"
	"(String streamContents: [:s | '||' split: 'foo||bar||2' indicesDo: [ :start :end | s << 's:' << start asString << ' ' << 'e:' << end asString << ' ' ]]) >>> 's:1 e:3 s:6 e:8 s:11 e:11 '"
	
	| position oldPosition |
	position := 1.
	oldPosition := position.
	position := aSequenceableCollection indexOfSubCollection: self startingAt: position.
	
	[ position > 0 ] whileTrue: [
		aBlock value: oldPosition value: position - 1.
		position := position + self size.
		oldPosition := position.
		position := aSequenceableCollection indexOfSubCollection: self startingAt: position.
	].

	aBlock value: oldPosition value: aSequenceableCollection size.! !

!SequenceableCollection methodsFor: '*Collections-arithmetic' stamp: ''!
runningMax: aSubsetSize
	"Running max. See the comment of self >> #running:of: for more information."
	"(#(1 1 2 2 3 3) runningMax: 3) >>> {2 . 2 . 3 . 3}"

	^ self running: [ :subset | subset max ] of: aSubsetSize! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
detectIndex: aBlock

	"Return index of first element that satisfies aBlock.
	If no matching element is found, raise an error."
	
	"(#(1 5 10) detectIndex: [ :each | each > 3 ]) >>> 2"

	^ self detectIndex: aBlock ifNone: [ self errorNotFound: aBlock ]! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
shuffled
	^ self copy shuffle! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
indexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of the first occurrence of anElement within the  
	receiver. If the receiver does not contain anElement, answer the 
	result of evaluating the argument, exceptionBlock."
	"(#(a b c d e) indexOf: #c ifAbsent: 7) >>> 3"
	"(#(a b c d e) indexOf: #x ifAbsent: 7) >>> 7"

	^ self indexOf: anElement startingAt: 1 ifAbsent: exceptionBlock! !

!SequenceableCollection methodsFor: '*Collections-arithmetic' stamp: ''!
runningMin: aSubsetSize
	"Running min. See the comment of self >> #running:of: for more information."
	"(#(1 1 2 2 3 3) runningMin: 3) >>> {1 . 1 . 2 . 2}"

	^ self running: [ :subset | subset min ] of: aSubsetSize! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
indexOfSubCollection: aSubCollection startingAt: anIndex 
	"Answer the index of the receiver's first element, such that that element 
	equals the first element of aSubCollection, and the next elements equal 
	the rest of the elements of aSubCollection. Begin the search at element 
	anIndex of the receiver. If no such match is found, answer 0."
	"(#(a b c d e) indexOfSubCollection: #(c d) startingAt: 2) >>> 3"
	"(#(a b c d e) indexOfSubCollection: #(c d) startingAt: 4) >>> 0"

	^self
		indexOfSubCollection: aSubCollection
		startingAt: anIndex
		ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'shuffling' stamp: ''!
shuffleBy: aRandom
	"Durstenfeld's version of the Fisher-Yates shuffle"
	"{1. 2. 3. 4. 5} shuffleBy: (Random seed: 42) >>> #(2 5 4 3 1)"

	self size to: 2 by: -1 do: [ :i | 
		self swap: i with: (aRandom nextInteger: i) ]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
polynomialEval: thisX
	"Treat myself as the coeficients of a polynomial in X.  Evaluate it with thisX.  First element is the constant and last is the coeficient for the highest power.
	#(1 2 3) polynomialEval: 2  is 3*X^2 + 2*X + 1 with X = 2"

	"(#(1 2 3) polynomialEval: 2) >>> 17"

	| sum valToPower |
	sum := self first.
	valToPower := thisX.
	2 to: self size do: [ :ind | 
		sum := sum + ((self at: ind) * valToPower).
		valToPower := valToPower * thisX ].
	^ sum! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
eighth
	"Answer the eighth element of the receiver.
	Raise an error if there are not enough elements."
	"#(a b c d e f g h ) eighth  >>> #h"

	^ self at: 8! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyReplaceFrom: start to: stop with: replacementCollection 
	"Answer a copy of the receiver satisfying the following conditions: If 
	stop is less than start, then this is an insertion; stop should be exactly 
	start-1, start = 1 means insert before the first character, start = size+1 
	means append after last character. Otherwise, this is a replacement; start 
	and stop have to be within the receiver's bounds."

	| newSequenceableCollection newSize endReplacement |
	newSize := self size - (stop - start + 1) + replacementCollection size.
	endReplacement := start - 1 + replacementCollection size.
	newSequenceableCollection := self species new: newSize.
	start > 1 ifTrue:[
		newSequenceableCollection
			replaceFrom: 1
			to: start - 1
			with: self
			startingAt: 1].
	start <= endReplacement ifTrue:[
		newSequenceableCollection
			replaceFrom: start
			to: endReplacement
			with: replacementCollection
			startingAt: 1].
	endReplacement < newSize ifTrue:[
		newSequenceableCollection
			replaceFrom: endReplacement + 1
			to: newSize
			with: self
			startingAt: stop + 1].
	^newSequenceableCollection! !

!SequenceableCollection methodsFor: 'splitjoin' stamp: ''!
splitOn: splitter indicesDo: aBlock
	"Perform an action specified as aBlock (with a start and end argument) to each of the indices of the receiver element that have been identified by splitting the receiver using the splitter argument. splitter - can be a subsequence, a Block or a Regex (String receiver only). Any other object used as a splitter is treated as an Array containing that object."
	"(String streamContents: [:s | 'Pharo is cool' splitOn: Character space indicesDo: [ :start :end | s << 's:' << start asString << ' ' << 'e:' << end asString << ' ' ]]) >>> 's:1 e:5 s:7 e:8 s:10 e:13 '"
	
	
	^ splitter split: self indicesDo: aBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
findBinaryIndex: aBlock do: actionBlock ifNone: exceptionBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If found, evaluate actionBlock with the index as argument
	If no matching element is found, evaluate exceptionBlock,
	with the indexes of the 'bounding' elements as arguments.
	Warning: Might give invalid indexes, see examples below"

	"(#(1 3 5 7 11 15 23) findBinaryIndex: [ :arg | 11 - arg ] do: [ :found | found ] ifNone: [ :a :b | 'between: ', {a. b} printString ]) >>> 5"
	"(#(1 3 5 7 11 15 23) findBinaryIndex: [ :arg | 12 - arg ] do: [ :found | found ] ifNone: [ :a :b | 'between: ', {a. b} printString ]) >>> 'between: #(5 6)'"
	"(#(1 3 5 7 11 15 23) findBinaryIndex: [ :arg | 0.5 - arg ] do: [ :found | found ] ifNone: [ :a :b | 'between: ', {a. b} printString ]) >>> 'between: #(0 1)'"
	"(#(1 3 5 7 11 15 23) findBinaryIndex: [ :arg | 25 - arg ] do: [ :found | found ] ifNone: [ :a :b | 'between: ',{a. b} printString ]) >>> 'between: #(7 8)' "
			
	| index low high test |
	low := 1.
	high := self size.
	[ index := high + low // 2.
	  low > high ] whileFalse: [
		test := aBlock value: (self at: index).
		test = 0 
			ifTrue: [ ^ actionBlock value: index ]
			ifFalse: [ test > 0
				ifTrue: [ low := index + 1 ]
				ifFalse: [ high := index - 1 ] ] ].
	^ exceptionBlock cull: high cull: low! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
before: target
	"Answer the receiver's element immediately before target. Raise an
	error if target is not an element of the receiver, or if there are no 
	elements before it (i.e. it is the first element)."
	"(#(11 22 33) before: 22) >>> 11"
	"(#(11 22 33) before: 33) >>> 22"

	^ self before: target ifAbsent: [self errorNotFound: target]! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
, otherCollection 
	"Concatenate two Strings or Collections."
	"#(2 4 6 8) , #(who do we appreciate) >>> #(2 4 6 8 who do we appreciate)"
	"((2989 storeStringBase: 16) copyFrom: 4 to: 6) , ' boy!!' >>> 'BAD boy!!'"
	
	^ self copyReplaceFrom: self size + 1
		  to: self size
		  with: otherCollection! !

!SequenceableCollection methodsFor: '*Roassal3' stamp: ''!
argmax
	"#(1 -3 5 1) argmax >>> 3"
	"#(1 1 1 1) argmax >>> 1"
	^ self indexOf: self max! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
indexOf: anElement startingAt: start
       "Answer the index of the first occurrence of anElement after start within the receiver. If the receiver does not contain anElement, answer 0."
	"(#(a b c d e) indexOf: #c startingAt: 2) >>> 3" 
	"(#(a b c d e) indexOf: #c startingAt: 4) >>> 0"

	^self indexOf: anElement startingAt: start ifAbsent: 0! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
paddedWith: otherCollection do: twoArgBlock 
	"Evaluate twoArgBlock with corresponding elements from this collection and otherCollection.
	Missing elements from either will be passed as nil."
	
	"(Array streamContents: [:stream | #(10 20 30) paddedWith: #(40 50 60) do: [:first :second | stream nextPut: (first + second)]]) >>> #(50 70 90) "
	
	"(Array streamContents: [:stream | #(10 20 30) paddedWith: #(40 50) do: [:a :b | stream nextPut: {a. b} ]]) >>> #(#(10 40) #(20 50) #(30 nil)) "

	"(Array streamContents: [:stream | #(10 20) paddedWith: #(40 50 60) do: [:a :b | stream nextPut: {a. b} ]]) >>> #(#(10 40) #(20 50) #(nil 60))"
		
	1 to: (self size max: otherCollection size) do:
		[:index | twoArgBlock value: (self at: index ifAbsent: [])
				value: (otherCollection at: index ifAbsent: [])]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
anyOne
	"Answer a representative sample of the receiver. It raises an error when the collection is empty. This method can be helpful when needing to preinfer the nature of the contents of semi-homogeneous collections."
	"#(1 2 3) anyOne >>> 1"
	"
	([#() anyOne] on: SubscriptOutOfBounds do: [ :ex | 'whatever' ]) >>> 'whatever'
	"
	^ self first! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
third
	"Answer the third element of the receiver.
	Raise an error if there are not enough elements."
	"#(a b c d e f g h i) third >>> #c"

	^ self at: 3! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
asByteArray
	"Answer a ByteArray whose elements are the elements of the receiver."

	^ ByteArray withAll: self! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
flatCollect: aBlock
	"Evaluate aBlock for each of the receiver's elements and answer the
	list of all resulting values flatten one level. Assumes that aBlock returns some kind
	of collection for each element. optimized version for Sequencable Collection and subclasses
	implementing #writeStream"

	"(#( (2 -3) (4 -5) #(-6)) flatCollect: [ :e | e abs  ]) >>> #(2 3 4 5 6)"

	"(#( (2 -3) #((4 -5)) #(-6)) flatCollect: [ :e | e abs  ]) >>> #(2 3 #(4 5) 6)"

	self isEmpty
		ifTrue: [ ^ self copy ].
	^self species 
		new: 0
		streamContents: [ :stream | self do: [ :each | stream nextPutAll: (aBlock value: each) ] ]! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyUpTo: anElement 
	"Answer all elements up to but not including anObject. If there
	is no such object, answer a copy of the receiver."

	^ self first: (self indexOf: anElement ifAbsent: [^ self copy]) - 1! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
do: elementBlock separatedBy: separatorBlock
	"Evaluate the elementBlock for all elements in the receiver,
	and evaluate the separatorBlock between."
	
	"(Array streamContents: ([:stream | #(1 2 3) do: [:each | stream nextPut: (each + 10)] separatedBy: [ stream nextPut: 0 ]])) >>> #(11 0 12 0 13)"

	1 to: self size do:
		[:index |
		index = 1 ifFalse: [separatorBlock value].
		elementBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
collectWithIndex: elementAndIndexBlock
	"Use the new version with consistent naming"
	^ self withIndexCollect: elementAndIndexBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
reverseWithIndexDo: elementAndIndexBlock 
	"Just like reverseWith:do: except that the iteration index supplies the second argument to the block."
	
	"(Array streamContents: [:stream | #(10 20 30) reverseWithIndexDo: [:each :index | stream nextPut: each + index]]) >>> #(33 22 11)"
	
	self size to: 1 by: -1 do: [:index |
		elementAndIndexBlock
			value: (self at: index)
			value: index]! !

!SequenceableCollection methodsFor: '*Spec2-Code-Diff' stamp: ''!
zCopyFrom: start to: stop

	start >= stop ifTrue: [ ^ self species new: 0 ].
	^ self copyFrom: start + 1 to: stop! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
detectIndex: aBlock ifNone: exceptionBlock

	"Return index of first element that satisfies aBlock.
	If no matching element is found, evaluate exceptionBlock."
	
	"(#(1 5 10) detectIndex: [ :each | each > 3 ] ifNone: ['Not found']) >>> 2"
	"(#(1 5 10) detectIndex: [ :each | each > 15 ] ifNone: ['Not found']) >>> 'Not found'"
	
	self doWithIndex: [:each :index | (aBlock value: each) ifTrue: [^ index]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
keysAndValuesDo: aBlock 
	"Enumerate the receiver with all the keys (aka indices) and values."
	
	"(Array streamContents: [:stream | #(10 20 30) keysAndValuesDo:  [:key :value | stream nextPut: (key * 2 + value)]]) >>> #(12 24 36)"

	1 to: self size do: [:index | aBlock value: index value: (self at: index)]! !

!SequenceableCollection methodsFor: '*Roassal3' stamp: ''!
asGroup
	^ (RSGroup new: self size) addAll: self; yourself! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
atLast: indexFromEnd put: obj
	"Set the element at indexFromEnd from the last position.
	 atLast: 1 put: obj, sets the last element"
	"({#x .#y .#z} atLast: 2 put: #e; yourself) >>> #(x e z)"

	^ self at: self size + 1 - indexFromEnd put: obj! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
from: startIndex to: endIndex put: anObject
	"Put anObject in all indexes between startIndex 
	and endIndex. Very fast. Faster than to:do: for
	more than 26 positions. Answer anObject"
	"({#a. #b. #c. #d. #e} from: 3 to: 4 put: #x; yourself) >>> #(a b x x e)"

	| written toWrite thisWrite |

	startIndex > endIndex ifTrue: [^self].
	self at: startIndex put: anObject.
	written := 1.
	toWrite := endIndex - startIndex + 1.
	[written < toWrite] whileTrue:
		[
			thisWrite := written min: toWrite - written.
			self 
				replaceFrom: startIndex + written
				to: startIndex + written + thisWrite - 1
				with: self startingAt: startIndex.
			written := written + thisWrite
		].
	^anObject! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
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) reduce: [ :a :b | a + b ]) >>> 6" "1 + 2 + 3"
	"(#(1 2 3) reduce: [ :a :b | a + b ]) >>> (1 + 2 + 3)"

	"(#(1 2 3 4 5) reduce: [ :a :b :c | a + b + c ]) >>> 15"
	"(#(1 2 3 4 5) reduce: [ :a :b :c | a + b + c ]) >>> (1 + 2 + 3 + 4 + 5)"

	^ self reduceLeft: aBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
pairsDo: aBlock
	"Evaluate aBlock with my elements taken two at a time.  If there's an odd number of items, ignore the last one.  Allows use of a flattened array for things that naturally group into pairs.  See also pairsCollect:"

	"(#(1 'fred' 2 'charlie' 3 'elmer') pairsDo: [:a :b | Transcript cr; show: b, ' is number ', a printString]) >>> #(1 'fred' 2 'charlie' 3 'elmer')"

	1 to: self size // 2 do: [ :index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index) ]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
combinations: kk atATimeDo: aBlock
	"Take the items in the receiver, kk at a time, and evaluate the block for each combination.  Hand in an array of elements of self as the block argument.  Each combination only occurs once, and order of the elements does not matter.  There are (self size take: kk) combinations."

	"(Array streamContents: [:stream | 'abcde' combinations: 3 atATimeDo: [:each | stream nextPut: each copy]]) >>> #(#($a $b $c) #($a $b $d) #($a $b $e) #($a $c $d) #($a $c $e) #($a $d $e) #($b $c $d) #($b $c $e) #($b $d $e) #($c $d $e))"

	| aCollection |
	aCollection := Array new: kk.
	self
		combinationsAt: 1
		in: aCollection
		after: 0
		do: aBlock! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
indexOfAnyOf: aCollection ifAbsent: exceptionBlock
	"Answer the index of the first occurrence of any element included in aCollection within the receiver.
	If the receiver does not contain anElement, answer the result of evaluating the argument, exceptionBlock."
	"(#(a b c d e) indexOfAnyOf: #(x y c) ifAbsent: 7) >>> 3"
	"(#(a b c d e) indexOfAnyOf: #(x y z) ifAbsent: 7) >>> 7"

	^self indexOfAnyOf: aCollection startingAt: 1 ifAbsent: exceptionBlock! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
ninth
	"Answer the ninth element of the receiver.
	Raise an error if there are not enough elements."
	"#(a b c d e f g h i) ninth >>> #i"

	^ self at: 9! !

!SequenceableCollection methodsFor: 'splitjoin' stamp: ''!
joinUsing: joiner
	"Append the elements of the receiver separating them with the joiner - character, string or sequenceable collection. Return collection of the same collection class as 'joiner', or a String"
	^ joiner join: self! !

!SequenceableCollection methodsFor: 'splitjoin' stamp: ''!
join: aCollection
	"Append the elements of the argument, aSequenceableCollection, separating them by the receiver."
	
	"({Character space. Character space} join: #('Pharo' 'is' 'cool')) >>>  {$P. $h. $a. $r. $o. Character space. Character space. $i. $s. Character space. Character space. $c. $o. $o. $l}"

	"NB: this implementation only works for Array, since WriteStreams only work for Arrays and Strings. (!!) Overridden in OrderedCollection and SortedCollection."
	
	^ self class
		streamContents: [:stream | aCollection
				do: [:each | each joinTo: stream]
				separatedBy: [stream nextPutAll: self]]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
last: n
	"Answer the last n elements of the receiver.  
	Raise an error if there are not enough elements."
	"(#(a b c d e) last: 2) >>> #(d e)"
	"(#(a b c d e) last: 3) >>> #(c d e)"

	| size |
	size := self size.
	^ self copyFrom: size - n + 1 to: size! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
indexOfAnyOf: aCollection
	"Answer the index of the first occurrence of any element included in aCollection within the receiver.
	If the receiver does not contain anElement, answer zero, which is an invalid index."
	"(#(a b c d e) indexOfAnyOf: #(x y c)) >>> 3"
	"(#(a b c d e) indexOfAnyOf: #(x y z)) >>> 0"

	^self indexOfAnyOf: aCollection startingAt: 1 ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'private' stamp: ''!
asDigitsAt: anInteger in: aCollection do: aBlock
	self
		do: [ :each | 
			aCollection at: anInteger put: each.
			anInteger = aCollection size
				ifTrue: [ aBlock value: aCollection ]
				ifFalse: [ self asDigitsAt: anInteger + 1 in: aCollection do: aBlock ] ]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
allButFirst
	"Answer a copy of the receiver containing all but the first
	element. Raise an error if there are not enough elements."	
	"#(a b c) allButFirst >>> #(b c)"

	^ self allButFirst: 1! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
with: otherCollection do: twoArgBlock 
	"Evaluate twoArgBlock with corresponding elements from this collection and otherCollection."
	
	"(Array streamContents: [:stream | #(1 2 3) with: #(4 5 6) do: [:a :b | stream nextPut: (a + b)]]) >>> #(5 7 9)"
	
	otherCollection size = self size ifFalse: [self errorSizeMismatch].
	1 to: self size do:
		[:index |
		twoArgBlock value: (self at: index)
				value: (otherCollection at: index)]! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
grownBy: length
	"Answer a copy of receiver collection with size grown by length"

	| newCollection size |
	size := self size.
	newCollection := self species ofSize: size + length.
	newCollection replaceFrom: 1 to: size with: self startingAt: 1.
	^ newCollection! !

!SequenceableCollection methodsFor: 'splitjoin' stamp: ''!
joinUsing: joiner last: last 
	"Append the elements of the receiver separating them with the joiner argument and handle the last elment separation using the last argument."
	
	"(#(1 2 3 4) joinUsing: ', ' last: ' and ') >>> '1, 2, 3 and 4'"
	
	(self size = 0) ifTrue: [  ^ '' ].
	(self size = 1) ifTrue: [  ^ self first asString ].
	^ last join: (Array
				with: (joiner join: self allButLast)
				with: self last)! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
withIndexDo: elementAndIndexBlock
	"Just like do: except that the iteration index supplies the second argument to the block"

	"(Array streamContents: [:stream| #(11 22 13) withIndexDo: [ :each :i | stream nextPut: (each * each + i)]]) >>> #(122 486 172)"

	1 to: self size do: [ :index | elementAndIndexBlock value: (self at: index) value: index ]! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
reversed
	"Answer a copy of the receiver with element order reversed."
	"Example: 'frog' reversed"

	| n result src |
	n := self size.
	result := self species new: n.
	src := n + 1.
	1 to: n do: [:i | result at: i put: (self at: (src := src - 1))].
	^ result! !

!SequenceableCollection methodsFor: '*NewValueHolder-Core' stamp: ''!
asValueHolder

	^ CollectionValueHolder value: self! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
atAll: indexArray putAll: valueArray
	"Store the elements of valueArray into the slots
	of this collection selected by indexArray."
	"({#x .#y .#z} atAll: #(1 3) putAll: #(a e); yourself) >>> #(a y e)"

	indexArray with: valueArray do: [:index :value | self at: index put: value].
	^ valueArray! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
findBinaryIndex: aBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, raise an error."

	"(#(1 3 5 7 11 15 23) findBinaryIndex: [ :arg | 11 - arg ]) >>> 5"

	^ self
		findBinaryIndex: aBlock
		do: [ :found | found ]
		ifNone: [ self errorNotFound: aBlock ]! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
asArray
	"Answer an Array whose elements are the elements of the receiver."

	^ Array withAll: self! !

!SequenceableCollection methodsFor: 'comparing' stamp: ''!
hasEqualElements: otherCollection
	"Answer whether the receiver's size is the same as otherCollection's
	size, and each of the receiver's elements equal the corresponding 
	element of otherCollection.
	This should probably replace the current definition of #= ."

	| size |
	(otherCollection isKindOf: SequenceableCollection) ifFalse: [^ false].
	(size := self size) = otherCollection size ifFalse: [^ false].
	1 to: size do:
		[:index |
		(self at: index) = (otherCollection at: index) ifFalse: [^ false]].
	^ true! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
indexOf: anElement startingAt: start ifAbsent: exceptionBlock
	"Answer the index of the first occurrence of anElement after start
	within the receiver. If the receiver does not contain anElement, 
	answer the 	result of evaluating the argument, exceptionBlock."
	"(#(a b c d e) indexOf: #c startingAt: 2 ifAbsent: 7) >>> 3" 
	"(#(a b c d e) indexOf: #c startingAt: 4 ifAbsent: 7) >>> 7"

	start to: self size do:
		[:index |
		(self at: index) = anElement ifTrue: [^ index]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
reject: rejectBlock 
	"Optimized version of Collection>>#reject:"
	
	"#(1 2 3 4) reject: [:each | each = 3 ] >>> #(1 2 4)"
	
	| each |
	
	^ self class new: self size streamContents: [ :stream|
		1 to: self size do: [ :index |
			(rejectBlock value: (each := self at: index))
				ifFalse: [ stream nextPut: each ]]]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
nextToLast
	"(#(1 2 3 4) nextToLast) >>> 3"
	^self at: self size - 1! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyWithoutIndex: index
	"Return a copy containing all elements except the index-th."

	| copy |
	copy := self species ofSize: self size - 1.
	copy replaceFrom: 1 to: index-1 with: self startingAt: 1.
	copy replaceFrom: index to: copy size with: self startingAt: index+1.
	^ copy! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
readStream
	^ ReadStream on: self! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
swap: oneIndex with: anotherIndex 
	"Move the element at oneIndex to anotherIndex, and vice-versa."
	"({#a. #b. #c. #d. #e} swap: 5 with: 1) >>> #(e b c d a)"

	| element |
	element := self at: oneIndex.
	self at: oneIndex put: (self at: anotherIndex).
	self at: anotherIndex put: element! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyEmpty
	^ self species new: 0! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
allButFirst: n
	"Answer a copy of the receiver containing all but the first n
	elements. Raise an error if there are not enough elements."
	"(#(a b c d) allButFirst: 2) >>> #(c d)"
	"(#(a b c d) allButFirst: 3) >>> #(d)"
	
	^ self copyFrom: n + 1 to: self size! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyAfter: anElement
	"Answer a copy of the receiver from after the first occurrence
	of anElement up to the end. If no such element exists, answer 
	an empty copy."

	^ self allButFirst: (self indexOf: anElement ifAbsent: [^ self copyEmpty])! !

!SequenceableCollection methodsFor: 'sorting' stamp: ''!
isSortedBy: aBlock
	"Return true if the receiver is sorted by the given criterion."
	"(#(1 2 3) isSortedBy: [:a :b | a <= b ]) >>> true"
	"(#(1 2 3) isSortedBy: [:a :b | a >= b ]) >>> false"
	"(#(xa xc xz xb xy) isSortedBy: #last ascending) >>> false"
	"(#(xa xb xc xy xz) isSortedBy: #last ascending) >>> true"

	| 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! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
withIndexCollect: elementAndIndexBlock 
	"Just like with:collect: except that the iteration index supplies the second argument to the block."
	
	"(#(10 20 30) withIndexCollect: [:each :index | each + (index * 2)]) >>> #(12 24 36)"
	
	| result |
	result := self species new: self size.
	1 to: self size do:
		[:index | result at: index put:
		(elementAndIndexBlock
			value: (self at: index)
			value: index)].
	^ result! !

!SequenceableCollection methodsFor: '*FormCanvas-Core' stamp: ''!
asPointArray
	"Answer an PointArray whose elements are the elements of the receiver, in 
	the same order."

	| pointArray |
	pointArray := PointArray new: self size.
	1 to: self size do:[:i| pointArray at: i put: (self at: i)].
	^pointArray! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
middle
	"Answer the middle element of the receiver."
	"#(a b c d e) middle >>> #c"
	"#(a b c d) middle >>> #c"
	
	^ self at: self size // 2 + 1! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyUpThrough: anElement
    "Answer all elements up to and including anObject. If there
     is no such object, answer a copy of the receiver."

	^self first: (self indexOf: anElement ifAbsent: [^ self copy])! !

!SequenceableCollection methodsFor: 'testing' stamp: ''!
beginsWithAnyOf: aCollection
	"Return true if the receiver starts with any of the elements in aCollection."
	^aCollection anySatisfy:[:prefix| self beginsWith: prefix]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
fifth
	"Answer the fifth element of the receiver.
	Raise an error if there are not enough elements."
	"#(a b c d e f g h ) fifth >>> #e"

	^ self at: 5! !

!SequenceableCollection methodsFor: 'splitjoin' stamp: ''!
splitOn: splitter
	"Split a collection of objects based on a splitter. splitter - can be a subsequence, a Block or a Regex (String receiver only). Any other object used as a splitter is treated as an Array containing that object."

	"(#(1 2 3 3 4 1 2 3 5 4 6) splitOn: 4) >>> #(#(1 2 3 3) #(1 2 3 5) #(6))asOrderedCollection"
	"(#(1 2 3 3 4 1 2 3 3 5 6) splitOn: #(3 3)) >>> #(#(1 2) #(4 1 2) #(5 6)) asOrderedCollection"
	"(#(2 2 3 3 4 1 2 3 3 5) splitOn: [:each | each > 3])>>> #(#(2 2 3 3) #(1 2 3 3) #()) asOrderedCollection"

	^ splitter split: self! !

!SequenceableCollection methodsFor: '*Spec2-Code' stamp: ''!
groupsOf: n
	| groups pos |

	pos := 0.
	groups := OrderedCollection new.
	(n to: self size by: n) do: [ :index | 
			| args |
			args := self copyFrom: index - n + 1 to: index.
			groups add: args.
			pos := pos + n ].
	pos < self size ifTrue: [ 
		groups add: (self copyFrom: pos + 1 to: self size) ].
	^ groups! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
forceTo: length paddingWith: elem
	"Force the length of the collection to length, padding
	if necessary with elem.  Note that this makes a copy."

	| newCollection |
	newCollection := self species new: length withAll: elem.
	newCollection replaceFrom: 1 to: (self size min: length) with: self startingAt: 1.
	^ newCollection! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
difference: aCollection
	"Answer the difference of two sequences preserving order and collection type."
	^ self reject: [:each | aCollection includes: each]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
lastIndexOf: anElement
	"Answer the index of the last occurrence of anElement within the 
	receiver. If the receiver does not contain anElement, answer 0."
	"(#(a b a d a) lastIndexOf: #a) >>> 5"
	"(#(a b a d e) lastIndexOf: #a) >>> 3"

	^ self lastIndexOf: anElement startingAt: self size ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'removing' stamp: ''!
remove: oldObject ifAbsent: anExceptionBlock 
	"SequencableCollections cannot implement removing."

	self shouldNotImplement! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
allButFirstDo: aBlock

	"Executes aBlock on each of the receiver's elements except for the first one"

	"(Array streamContents: [:stream | #(1 2 3) allButFirstDo: [:each | stream nextPut: (each + 10)]]) >>> #(12 13)"

	2 to: self size do:
		[:index | aBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyWithoutFirst
	"Deprecatd. Return a copy of the receiver which doesn't include
	the first element."

	^ self allButFirst! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
allButLast: n
	"Answer a copy of the receiver containing all but the last n
	elements. Raise an error if there are not enough elements."
	"(#(a b c d) allButLast: 2) >>> #(a b)"
	"(#(a b c d) allButLast: 3) >>> #(a)"

	^ self copyFrom: 1 to: self size - n! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
after: target
	"Answer the element after target.  Raise an error if target is not
	in the receiver, or if there are no elements after it."
	"(#(a b c d) after: #b) >>> #c"

	^ self after: target ifAbsent: [self errorNotFound: target]! !

!SequenceableCollection methodsFor: 'sorting' stamp: ''!
isSorted
	"Return true if the receiver is sorted by the given criterion.
	Optimization for isSortedBy: [:a :b | a <= b]."
	"#(1 2 3) isSorted >>> true"
	"#(1 2 3 0) isSorted >>> false"

	| 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! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
overlappingPairsWithIndexDo: aBlock 
	"Emit overlapping pairs of my elements into aBlock, along with an index."
	
	"(Array streamContents: [:stream | #(10 20 30 40) overlappingPairsWithIndexDo: [:first :second :index| stream nextPut: (first + second + index)]]) >>> #(31 52 73)"

	1 to: self size - 1
		do: [:i | aBlock value: (self at: i) value: (self at: i + 1) value: i ]! !

!SequenceableCollection methodsFor: 'splitjoin' stamp: ''!
joinTo: stream
	"double dispatch for join:"
	^ stream nextPutAll: self! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
second
	"Answer the second element of the receiver.
	Raise an error if there are not enough elements."
	"#(a b c d e f g h i) second >>> #b"

	^ self at: 2! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
atLast: indexFromEnd ifAbsent: block
	"Return element at indexFromEnd from the last position.
	 atLast: 1 ifAbsent: [] returns the last element"
	"(#(x y z) atLast: 1 ifAbsent: #a) >>> #z"
	"(#(x y z) atLast: 4 ifAbsent: #a) >>> #a"

	^ self at: self size + 1 - indexFromEnd ifAbsent: block! !

!SequenceableCollection methodsFor: 'sorting' stamp: ''!
mergeSortFrom: startIndex to: stopIndex by: aBlock
	"Sort the given range of indices using the mergesort algorithm.
	Mergesort is a worst-case O(N log N) sorting algorithm that usually
	does only half as many comparisons as heapsort or quicksort."

	"Details: recursively split the range to be sorted into two halves,
	mergesort each half, then merge the two halves together. An extra 
	copy of the data is used as temporary storage and successive merge 
	phases copy data back and forth between the receiver and this copy.
	The recursion is set up so that the final merge is performed into the
	receiver, resulting in the receiver being completely sorted."
	"({#a. #b. #z. #d. #i. #l} mergeSortFrom: 3 to: 5 by: [ :a :b | a<=b ]) >>> #(a b d i z l)"

	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! !

!SequenceableCollection methodsFor: 'streaming' stamp: ''!
readStreamDo: aBlock
	"Evaluates the argument with the read stream of the collection. Answers the result."
	
	"#(3 4 5) readStreamDo: [ :stream | stream contents ] >>> #(3 4 5)"

	^ aBlock value: self readStream! !

!SequenceableCollection methodsFor: '*Roassal3' stamp: ''!
max: aSelectorOrOneArgBlock
	^ (self collect: aSelectorOrOneArgBlock) max! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
indexOf: anElement
	"Answer the index of the first occurrence of anElement within the  
	receiver. If the receiver does not contain anElement, answer 0."
	"(#(a b c d e) indexOf: #c) >>> 3"
	"(#(a b c d e) indexOf: #x) >>> 0"

	^ self indexOf: anElement ifAbsent: 0! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"This destructively replaces elements from start to stop in the receiver 
	starting at index, repStart, in the sequenceable collection, 
	replacementCollection. Answer the receiver. No range checks are 
	performed."

	| index repOff |
	repOff := repStart - start.
	index := start - 1.
	[(index := index + 1) <= stop]
		whileTrue: [self at: index put: (replacement at: repOff + index)]! !

!SequenceableCollection methodsFor: '*Random-Core' stamp: ''!
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."

	^ self at: (aGenerator nextInteger: self size)! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
identityIndexOf: anElement 
	"Answer the index of anElement within the receiver. If the receiver does 
	not contain anElement, answer 0."
	"(#(a b c d e) identityIndexOf: #c) >>> 3"
	"(#(a b c d e) identityIndexOf: #x) >>> 0"

	^self identityIndexOf: anElement ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
asWordArray
	"Answer a WordArray whose elements are the elements of the receiver, in 
	the same order."

	| wordArray |
	wordArray := WordArray new: self size.
	1 to: self size do:[:i| wordArray at: i put: (self at: i)].
	^wordArray! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
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 |
	newSize := stop - start + 1.
	^(self species new: newSize)
		replaceFrom: 1
		to: newSize
		with: self
		startingAt: start! !

!SequenceableCollection methodsFor: '*Graphics-Display Objects' stamp: ''!
asColorArray
	^ColorArray withAll: self! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
at: index incrementBy: value
	"({1 .2 .3 .4} at: 3 incrementBy: 2) >>> 5"
	"({1 .2 .3 .4}  at: 2 incrementBy: 2) >>> 4"
	
	^self at: index put: (self at: index) + value! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
atPin: index 
	"Return the index'th element of me if possible.
	Return the first or last element if index is out of bounds."
	"(#(w x y z) atPin: 2) >>> #x"
	"(#(w x y z) atPin: 4) >>> #z"
	"(#(w x y z) atPin: 8) >>> #z"

	index < 1 ifTrue: [^ self first].
	index > self size ifTrue: [^ self last].
	^ self at: index! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
findFirst: aBlock
	"Return the index of my first element for which aBlock evaluates as true.
	If no matching element is found, return 0"
	
	"(#(1 5 10) findFirst: [ :each | each > 3 ]) >>> 2"
	"(#(1 5 10) findFirst: [ :each | each > 15 ]) >>> 0"

	| index |
	index := 0.
	[(index := index + 1) <= self size] whileTrue:
		[(aBlock value: (self at: index)) ifTrue: [^index]].
	^ 0! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
reject: rejectBlock thenDo: aBlock
	"Refer to the comment in Collection>>#reject:thenDo:"
	
	"(Array streamContents: [:stream | #(1 2 3 4) reject: [:each | each = 3 ] thenDo: [:each | stream nextPut: each + 10]]) >>> #(11 12 14)"
	
	|  each |
	
	1 to: self size do: [ :index |
		(rejectBlock value: (each := self at: index))
			ifFalse: [ aBlock value: each ]].! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
after: target ifAbsent: exceptionBlock
	"Answer the element after target.  Answer the result of evaluation
	the exceptionBlock if target is not in the receiver, or if there are 
	no elements after it."
	"(#(a b c d) after: #b ifAbsent: #z) >>> #c"
	"(#(a b c d) after: #x ifAbsent: #z) >>> #z"

	| index |
	index := self indexOf: target.
	^ (index = 0 or: [index = self size])
		ifTrue: [exceptionBlock value]
		ifFalse: [self at: index + 1]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
atAll: indexArray
	"Answer a new collection like the receiver which contains all elements
	of the receiver at the indices of indexArray."
	"(#('one' 'two' 'three' 'four') atAll: #(3 2 4)) >>> #('three' 'two' 'four')"

	| newCollection |
	newCollection := self species ofSize: indexArray size.
	1 to: indexArray size do:
		[:index |
		newCollection at: index put: (self at: (indexArray at: index))].
	^ newCollection! !

!SequenceableCollection methodsFor: 'splitjoin' stamp: ''!
appendTo: aCollection
	"double dispatch for join:"
	^ aCollection addAllLast: self! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
replaceFrom: start to: stop with: replacement 
	"This destructively replaces elements from start to stop in the receiver. 
	Answer the receiver itself. Use copyReplaceFrom:to:with: for 
	insertion/deletion which may alter the size of the result."
	"({#a. #b. #c. #d. #e} replaceFrom: 3 to: 4 with: #(x y)) >>> #(a b x y e)"

	replacement size = (stop - start + 1)
		ifFalse: [self error: 'Size of replacement doesnt match'].
	^self replaceFrom: start to: stop with: replacement startingAt: 1! !

!SequenceableCollection methodsFor: 'sorting' stamp: ''!
sort: aSortBlock 
	"Sort this array using aSortBlock. The block should take two arguments
	and return true if the first element should preceed the second one."
	"({3. 9. 1} sort: [:a :b | a <= b ]) >>> #(1 3 9)"
	"({3. 9. 1} sort: [:a :b | a >= b ]) >>> #(9 3 1)"
	"({#xa. #xc. #xz. #xb. #xy} sort: #last ascending) >>> #(xa xb xc xy xz)"

	self
		mergeSortFrom: 1
		to: self size
		by: aSortBlock! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
identityIndexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of anElement within the receiver. If the receiver does 
	not contain anElement, answer the result of evaluating the argument, 
	exceptionBlock."
	"(#(a b c d e) identityIndexOf: #c ifAbsent: 7) >>> 3"
	"(#(a b c d e) identityIndexOf: #x ifAbsent: 7) >>> 7"
	
	1 to: self size do:
		[:i | (self at: i) == anElement ifTrue: [^ i]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'sorting' stamp: ''!
sorted
	"Return a new sequenceable collection which contains the same elements as self but its 
elements are sorted in ascending order using the #'<=' operator."
	"#(8 5 3 9) sorted >>> #(3 5 8 9)"
	"#(a b z d) sorted >>> #(a b d z)"
	
	^self sorted: [ :a :b| a <= b ]! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
asFloatArray
	"Answer a FloatArray whose elements are the elements of the receiver, in 
	the same order."

	| floatArray |
	floatArray := FloatArray new: self size.
	1 to: self size do:[:i| floatArray at: i put: (self at: i) asFloat ].
	^floatArray! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
at: index ifAbsent: exceptionBlock 
	"Answer the element at my position index. If I do not contain an element 
	at index, answer the result of evaluating the argument, exceptionBlock."
	"(#(a b c d) at: 3 ifAbsent: #z) >>> #c"
	"(#(a b c d) at: 5 ifAbsent: #z) >>> #z"

	(index between: 1 and: self size) ifTrue: [^ self at: index].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
atAllPut: anObject 
	"Put anObject at every one of the receiver's indices."
	"({#x .#y. #z} atAllPut: #a) >>> #(a a a)"

	| size |
	(size := self size) > 26 "first method faster from 27 accesses and on"
		ifTrue: [self from: 1 to: size put: anObject]
		ifFalse: [1 to: size do: [:index | self at: index put: anObject]]! !

!SequenceableCollection methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"Instances of STON listClass will be encoded directly, without a class tag.
	Other (sub)classes will be encoded with a class tag and will use a list representation. "

	self class == STON listClass
		ifTrue: [ stonWriter writeList: self ]
		ifFalse: [ super stonOn: stonWriter ]! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
@ aCollection 
	^ self with: aCollection collect: [:a :b | a @ b]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
allButLast
	"Answer a copy of the receiver containing all but the last
	element. Raise an error if there are not enough elements."
	"#(a b c d) allButLast >>> #(a b c)"

	^ self allButLast: 1! !

!SequenceableCollection methodsFor: 'streaming' stamp: ''!
writeStreamDo: aBlock
	"Evaluates the argument with the write stream of the collection. Answers the result."
	
	"(#() writeStreamDo: [ :stream | stream nextPut: '4'; space; nextPutAll: '34'. stream contents ]) >>> {'4'. Character space. $3. $4}"

	^ aBlock value: self writeStream! !

!SequenceableCollection methodsFor: '*Roassal3' stamp: ''!
sortedAs: aSortBlockOrSymbol
	"Answer a SortedCollection whose elements are the elements of the 
	receiver. The sort order is defined by the argument, aSortBlock."

	| aSortedCollection aSortBlock |
	aSortedCollection := SortedCollection new: self size.
	aSortBlock := 
		aSortBlockOrSymbol isSymbol 
			ifTrue: [ [:a :b | |t1 t2|
							t1 := (a perform: aSortBlockOrSymbol).
							t2 := (b perform: aSortBlockOrSymbol).
							((t1 isKindOf: Boolean) and: [t2 isKindOf: Boolean])
								ifTrue: [ t1 ]
								ifFalse: [ t1 < t2 ] ] ]
			ifFalse: [ 
				(aSortBlockOrSymbol numArgs = 1)
					ifTrue: [ [ :v1 :v2 | (aSortBlockOrSymbol value: v1) < (aSortBlockOrSymbol value: v2) ] ]
					ifFalse: [ aSortBlockOrSymbol ] ].
	aSortedCollection sortBlock: aSortBlock.
	aSortedCollection addAll: self.
	^ aSortedCollection! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
indexOfAnyOf: aCollection startingAt: start ifAbsent: exceptionBlock
	"Answer the index of the first occurrence of any element included in aCollection after start within the receiver.
	If the receiver does not contain anElement, answer the result of evaluating the argument, exceptionBlock.
	Note: it is user responsibility to provide aCollection that behaves relatevily fast when asked for includes: (like a Set)"
	"(#(a b c d e) indexOfAnyOf: #(x y c) startingAt: 2 ifAbsent: 7) >>> 3"
	"(#(a b c d e) indexOfAnyOf: #(x y c) startingAt: 4 ifAbsent: 7) >>> 7"

	start to: self size do:
		[:index |
		(aCollection includes: (self at: index)) ifTrue: [^ index]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
lastIndexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of the last occurrence of anElement within the  
	receiver. If the receiver does not contain anElement, answer the
	result of evaluating the argument, exceptionBlock."
	"(#(a b a d a) lastIndexOf: #a ifAbsent: 7) >>> 5"
	"(#(a b a d e) lastIndexOf: #c ifAbsent: 7) >>> 7"
	
	^self lastIndexOf: anElement startingAt: self size ifAbsent: exceptionBlock! !

!SequenceableCollection methodsFor: '*Roassal3-Chart' stamp: ''!
rsHistogram
	| c plot |
	c := RSChart new.
	plot := RSHistogramPlot new x: self.
	c addPlot: plot.
	c addDecoration: RSVerticalTick new.
	c addDecoration: RSHorizontalTick new.
	^ c! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyWith: newElement 
	"Answer a copy of the receiver that is 1 bigger than the receiver and has 
	newElement at the last element."

	| newIC |
	newIC := self species new: self size + 1.
	newIC 
		replaceFrom: 1
		to: self size
		with: self
		startingAt: 1.
	newIC at: newIC size put: newElement.
	^newIC! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
do: aBlock without: anItem
	"Enumerate all elements in the receiver.
	Execute aBlock for those elements that are not equal to the given item"
	"Refer to the comment in Collection|do:."
	
	"(Array streamContents: ([:stream | #(1 2 3) do: [:each | stream nextPut: (each + 10)] without: 2])) >>> #(11 13)"
	
	1 to: self size do:
		[:index | anItem = (self at: index) ifFalse:[aBlock value: (self at: index)]]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
groupsOf: n atATimeCollect: aBlock
	"Evaluate aBlock with my elements taken n at a time. Ignore any leftovers at the end. 
	Allows use of a flattened array for things that naturally group into groups of n. 
	If aBlock has a single argument, pass it an array of n items, otherwise, pass the items as separate arguments. See also pairsDo:"

	"(#(16 17 17 16 18 17 18   19 19 19 18 19 19 20   19 20 19 20 20 20 19   20) groupsOf: 7 atATimeCollect: [ :x | x ]) >>> #(#(16 17 17 16 18 17 18) #(19 19 19 18 19 19 20) #(19 20 19 20 20 20 19))"

	"(#(1 1 1 10 10 10 100  100 100) groupsOf: 3 atATimeCollect: [ :x :y :z | x + y + z]) >>> #(3 30 300)"

	"(#(1 1 1 10 10 10 100  100 100) groupsOf: 3 atATimeCollect: [ :x | x ]) >>> #(#(1 1 1) #(10 10 10) #(100 100 100))"

	| passArray |
	passArray := aBlock numArgs <= 1.
	^ (n to: self size by: n)
		collect: [ :index | 
			| args |
			args := (self copyFrom: index - n + 1 to: index) asArray.
			passArray
				ifTrue: [ aBlock value: args ]
				ifFalse: [ aBlock valueWithArguments: args ] ]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
atLast: indexFromEnd
	"Return element at indexFromEnd from the last position.
	 atLast: 1, returns the last element"
	"(#(x y z) atLast: 1) >>> #z"
	"(#(x y z) atLast: 2) >>> #y"

	^ self atLast: indexFromEnd ifAbsent: [self error: 'index out of range']! !

!SequenceableCollection methodsFor: 'splitjoin' stamp: ''!
splitOn: splitter do: aBlock
	"Perform an action specified as aBlock to each of the elements of the receiver that have been split using the splitter argument. splitter - can be a subsequence, a Block or a Regex (String receiver only). Any other object used as a splitter is treated as an Array containing that object."
	"(String streamContents: [:s | 'Pharo is cool' splitOn: Character space do: [:each | s << each ]])>>>'Pharoiscool'"
	
	^ splitter split: self do: aBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
findBinary: aBlock do: actionBlock ifNone: exceptionBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If found, evaluate actionBlock with the found element as argument
	If no matching element is found, evaluate exceptionBlock,
	with the 'bounding' elements or nil as arguments."

	"(#(1 3 5 7 11 15 23) findBinary: [ :arg | 11 - arg ] do: [ :found | found ] ifNone: [ :a :b | 'between: ', {a. b} printString ]) >>> 11"

	"(#(1 3 5 7 11 15 23) findBinary: [ :arg | 12 - arg ] do: [ :found | found ] ifNone: [ :a :b | 'between: ', {a. b} printString ]) >>> 'between: #(11 15)'"

	"(#(1 3 5 7 11 15 23) findBinary: [ :arg | 0.5 - arg ] do: [ :found | found ] ifNone: [ :a :b | 'between: ', {a. b} printString ]) >>> 'between: #(nil 1)'"

	"(#(1 3 5 7 11 15 23) findBinary: [ :arg | 25 - arg ] do: [ :found | found ] ifNone: [ :a :b | 'between: ',{a. b} printString ]) >>> 'between: #(23 nil)'"

	^ self
		findBinaryIndex: aBlock
		do: [ :foundIndex | actionBlock value: (self at: foundIndex) ]
		ifNone: [ :prevIndex :nextIndex | 
			exceptionBlock
				cull:
					(prevIndex > 0
						ifTrue: [ self at: prevIndex ])
				cull:
					(nextIndex <= self size
						ifTrue: [ self at: nextIndex ]) ]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
indexOfAnyOf: aCollection startingAt: start
	"Answer the index of the first occurrence of any element included in aCollection after start within the receiver.
	If the receiver does not contain anElement, answer zero, which is an invalid index."
	"(#(a b c d e) indexOfAnyOf: #(x y c) startingAt: 2) >>> 3"
	"(#(a b c d e) indexOfAnyOf: #(x y c) startingAt: 4) >>> 0"

	^self indexOfAnyOf: aCollection startingAt: start ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
reverseWith: aSequenceableCollection do: aBlock 
	"Evaluate aBlock with each of the receiver's elements, in reverse order, 
	along with the  corresponding element, also in reverse order, from 
	aSequencableCollection. "
	
	"(Array streamContents: [:stream | #(1 2 3) reverseWith: #(4 5 6) do: [:a :b | stream nextPut: (a + b)]]) >>> #(9 7 5)"

	self size ~= aSequenceableCollection size ifTrue: [^ self errorSizeMismatch].
	self size to: 1 by: -1 do: [:index | 
			aBlock 
				value: (self at: index)
				value: (aSequenceableCollection at: index)]! !

!SequenceableCollection methodsFor: 'shuffling' stamp: ''!
shuffle
	"Modify the receiver but with its elements in random positions.
	This method use Random class as random generator"
	
	^ self shuffleBy: Random new! !

!SequenceableCollection methodsFor: '*Collections-arithmetic' stamp: ''!
running: aBlock of: aSubsetSize
	"This is a generalization of a running average (a.k.a. moving average, rolling average) which allows you to apply any given block to the shifting subsets of a given size.
	
	For example, given a collection #(1 2 3 4 5) and a window size 2, we collect subsets of this collection by starting with first 2 elements and shifting the window 1 element to the right: #((1 2)(2 3)(3 4)(4 5)), then we apply aBlock to each subset and collect the results. For example, if aBlock is [ :subset | subset average ], this will give us #(1.5 2.5 3.5 4.5)"
	| result |
	
	aSubsetSize > self size ifTrue: [
		SubscriptOutOfBounds
			signal: 'The subset size can not exceed the size of a collection' ].
		
	aSubsetSize < 0 ifTrue: [
		SubscriptOutOfBounds
			signal: 'The subset size must be positive' ].
	
	result := (1 to: self size - aSubsetSize + 1) collect: [ :i |
		aBlock value: (self copyFrom: i to: i + aSubsetSize - 1) ].
	
	^ self species withAll: result! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
seventh
	"Answer the seventh element of the receiver.
	Raise an error if there are not enough elements."
	"#(a b c d e f g h i) seventh >>> #g"

	^ self at: 7! !

!SequenceableCollection methodsFor: 'comparing' stamp: ''!
hash
	| hash |

	hash := self species hash.
	1 to: self size do: [:i | hash := (hash + (self at: i) hash) hashMultiply].
	^hash! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
collect: collectBlock thenReject: rejectBlock
	"Optimized version of Collection>>#thenReject:"
	
	"(#(1 2 3) collect: [:each | each + 10 ] thenReject: [:each | each even]) >>> #(11 13)"
	
	| each |
	
	^  self class new: self size streamContents: [ :stream |
		1 to: self size do: [:index |
			each := collectBlock value: (self at: index).
			(rejectBlock value: each)
				ifFalse: [ stream nextPut: each ]]]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
select: selectBock thenDo: aBlock
	"Refer to the comment in Collection>>#select:thenDo:"
	
	"(Array streamContents: [:stream | #(1 2 3 4) select: [:each | each > 2 ] thenDo: [:each | stream nextPut: each + 10]]) >>> #(13 14)"
	
	| each |
	1 to: self size do: [ :index |
		(selectBock value: (each := self at: index))
			ifTrue: [ aBlock value: each ]].! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
collect: aBlock from: firstIndex to: lastIndex
	"Refer to the comment in Collection|collect:."
	
	"(#(1 2 3 4) collect: [:each | each  + 10] from: 2 to: 3) >>> #(12 13) "

	| size result j |
	size := lastIndex - firstIndex + 1.
	result := self species new: size.
	j := firstIndex.
	1 to: size do: [:i | result at: i put: (aBlock value: (self at: j)). j := j + 1].
	^ result! !

!SequenceableCollection methodsFor: '*Roassal3' stamp: ''!
min: aSelectorOrOneArgBlock
	^ (self collect: aSelectorOrOneArgBlock) min! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
piecesCutWhere: binaryBlock
	"Answer substrings of the receiver derived from cutting the receiver at points where binaryBlock answers true for adjacent elements."
	"( #(1 2 3 1 6 1 2 3 4) piecesCutWhere: [ :a :b | a = 1 and: [ b = 2]]) asArray >>> #(#(1) #(2 3 1 6 1) #(2 3 4))"
	| 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]]"! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
asStringWithCr
	"Convert to a string with returns between items.  Elements are
usually strings.
	 Useful for labels for PopUpMenus."
	| labelStream |
	labelStream := (String new: 200) writeStream.
	self do: [:each |
		each isString
			ifTrue: [labelStream nextPutAll: each; cr]
			ifFalse: [each printOn: labelStream. labelStream cr]].
	self size > 0 ifTrue: [labelStream skip: -1].
	^ labelStream contents! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
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."
	
	"(Array streamContents: [:stream |  #(1 2 3 1 6 1 2 3 4) piecesCutWhere: [ :a :b | a = 1 and: [ b = 2]] do: [:each | stream nextPut: each size]]) >>> #(1 5 3)"

	| 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)! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyUpToLast: anElement
	"Answer a copy of the receiver from index 1 to the last occurrence of 
	anElement, not including anElement."

	^ self first: (self lastIndexOf: anElement ifAbsent: [^ self copy]) - 1! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
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."
	
	"#(1 2 3) collect: [:each | each  + 10] >>> #(11 12 13) "

	| newCollection |
	newCollection := self species new: self size.
	1 to: self size do:
		[:index |
		newCollection at: index put: (aBlock value: (self at: index))].
	^ newCollection! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
allButLastDo: block

	"Executes aBlock on each of the receiver's elements except for the last one"

	"(Array streamContents: [:stream | #(1 2 3) allButLastDo: [:each | stream nextPut: (each + 10)]]) >>> #(11 12)"

	1 to: self size - 1 do:
		[:index | block value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
select: selectBlock thenCollect: collectBlock
	"Optimized version of Collection>>#select:thenCollect:"
	
	"(#(1 2 3 4)  select: [:each | each > 2 ] thenCollect: [:each | each + 10 ]) >>> #(13 14)"
	
	| each |
	^ self class new: self size streamContents: [ :stream|
		1 to: self size do: [ :index |
			(selectBlock value: (each := self at: index))
				ifTrue: [ stream nextPut: (collectBlock value: each) ]]]! !

!SequenceableCollection methodsFor: 'sorting' stamp: ''!
sorted: aSortBlockOrNil
	"Return a new sequenceable collection which contains the same elements as self but its 
elements are sorted by aSortBlockOrNil. The block should take two arguments and return true if 
the first element should preceed the second one. If aSortBlock is nil then <= is used for 
comparison."
	"(#(3 9 1) sorted: [:a :b | a <= b ]) >>> #(1 3 9)"
	"(#(3 9 1) sorted: [:a :b | a >= b ]) >>> #(9 3 1)"
	"(#(xa xc xz xb xy) sorted: #last ascending) >>> #(xa xb xc xy xz)"
	
	^self copy sort: aSortBlockOrNil! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
overlappingPairsCollect: aBlock 

	"Answer the result of evaluating aBlock with all of the overlapping pairs of my elements."
	
	"(#(1 2 3 4) overlappingPairsCollect: [:first :second| first + second]) >>> #(3 5 7)"
	
	| retval |
	retval := self species ofSize: self size - 1.
	1 to: self size - 1
		do: [:i | retval at: i put: (aBlock value: (self at: i) value: (self at: i + 1)) ].
	^retval! !

!SequenceableCollection methodsFor: 'sorting' stamp: ''!
mergeFirst: first middle: middle last: last into: dst by: aBlock
	"Private. Merge the sorted ranges [first..middle] and [middle+1..last] 
	of the receiver into the range [first..last] of dst."

	| i1 i2 val1 val2 out |
	i1 := first.
	i2 := middle + 1.
	val1 := self at: i1.
	val2 := self at: i2.
	out := first - 1.  "will be pre-incremented"

	"select 'lower' half of the elements based on comparator"
	[(i1 <= middle) and: [i2 <= last]] whileTrue:
		[(aBlock value: val1 value: val2)
			ifTrue: [dst at: (out := out + 1) put: val1.
					val1 := self at: (i1 := i1 + 1)]
			ifFalse: [dst at: (out := out + 1) put: val2.
					i2 := i2 + 1.
					i2 <= last ifTrue: [val2 := self at: i2]]].

	"copy the remaining elements"
	i1 <= middle
		ifTrue: [dst replaceFrom: out + 1 to: last with: self startingAt: i1]
		ifFalse: [dst replaceFrom: out + 1 to: last with: self startingAt: i2]! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
forceTo: length paddingStartWith: elem 
	"Force the length of the collection to length, padding  
	the beginning of the result if necessary with elem.  
	Note that this makes a copy."
	| newCollection padLen |
	newCollection := self species ofSize: length.
	padLen := length - self size max: 0.
	newCollection
		from: 1
		to: padLen
		put: elem.
	newCollection
		replaceFrom: padLen + 1
		to: ((padLen + self size) min: length)
		with: self
		startingAt:  1.
	^ newCollection! !

!SequenceableCollection methodsFor: '*Spec2-Code-Diff' stamp: ''!
zAt: index put: anObject

	^ self at: index + 1 put: anObject! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
writeStream
	^ WriteStream on: self! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
withIndexSelect: elementAndIndexBlock
	"select elements from the receiver that the block evaluates true with the element and its index."

	"(#('We' 'love' 'pharo!!') withIndexSelect: [:value :index | value size - 1 <= index]) >>> #('We')"

	^ self class
		new: self size
		streamContents: [ :stream | 
			1 to: self size do: [ :index | 
				| each |
				(elementAndIndexBlock value: (each := self at: index) value: index)
					ifTrue: [ stream nextPut: each ] ] ]! !

!SequenceableCollection methodsFor: '*Roassal3-Layouts' stamp: ''!
rsSwapElement: u withElement: v
	| index1 index2 |
	index1 := self indexOf: u.
	index2 := self indexOf: v.
	self at: index2 put: u.
	self at: index1 put: v.! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
replace: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Collect the resulting values into self."
	
	"({1. 2. 3. 4} replace: [:each | each + 1 ]) >>> #(2 3 4 5)"

	1 to: self size do: [ :index |
		self at: index put: (aBlock value: (self at: index)) ]! !

!SequenceableCollection methodsFor: '*Collections-arithmetic' stamp: ''!
runningAverage: aSubsetSize
	"Running average (a.k.a. moving average, rolling average). See the comment of self >> #running:of: for more information."
	"(#(1 1 2 2 3 3) runningAverage: 2) >>> {1 . (3/2) . 2 . (5/2) . 3}"

	^ self running: [ :subset | subset average ] of: aSubsetSize! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
atWrap: index

    "Answer the index'th element of the receiver.  If index is out of bounds,
    let it wrap around from the end to the beginning until it is in bounds."
    "(#(11 22 33) asOrderedCollection atWrap: 2) >>> 22"
    "(#(11 22 33) asOrderedCollection atWrap: 4) >>> 11"
    "(#(11 22 33) asOrderedCollection atWrap: 5) >>> 22"
    
    ^ self at: index - 1 \\ self size + 1! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
allPairsDo: aBinaryBlock
	"Iterate over all the pairs of the receiver and apply the binaryBlock
	to each pair. "

	"(Array streamContents: [ :stream | #(0 1 2 3) allPairsDo: [ :first :second | stream nextPut: { first . second } ] ]) >>> #(#(0 0) #(0 1) #(0 2) #(0 3) #(1 0) #(1 1) #(1 2) #(1 3) #(2 0) #(2 1) #(2 2) #(2 3) #(3 0) #(3 1) #(3 2) #(3 3))"

	self do: [ :first | self do: [ :second | aBinaryBlock value: first value: second ] ]! !

!SequenceableCollection methodsFor: 'streaming' stamp: ''!
putOn: aStream
	"Write the receiver onto aStream by iterating over its elements.
	In general we assume aStream accepts the receiver's elements as element type.
	Return self."

	self do: [ :each | each putOn: aStream ]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
first: n
	"Answer the first n elements of the receiver.
	Raise an error if there are not enough elements."
	"(#(a b c d e f g h ) first: 3) >>> #(a b c)"

	^ self copyFrom: 1 to: n! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
lastIndexOfAnyOf: aCollection startingAt: lastIndex ifAbsent: exceptionBlock
	"Answer the index of the last occurrence of anElement within the  
	receiver. If the receiver does not contain anElement, answer the
	result of evaluating the argument, exceptionBlock."
	"(#(a b a d a) lastIndexOfAnyOf: #(a b) startingAt: 1 ifAbsent: 7) >>> 1"

	lastIndex to: 1 by: -1 do:
		[:index |
		(aCollection includes: (self at: index)) ifTrue: [^ index]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
reduceLeft: aBlock
	"Fold the result of the receiver from left to right into aBlock. The argument aBlock must take two or more arguments."

	"(#(1 2 3) reduceLeft: [ :a :b | a - b ])>>> ((1 - 2) - 3)"
	"(#(1 2 3) reduceLeft: [ :a :b | a - b ]) >>> -4"
	"(#(1 + 3 - 5) reduceLeft: [ :a :op :b | a perform: op with: b ]) >>> ((1 + 3) - 5)"
	"(#(1 + 3 - 5) reduceLeft: [ :a :op :b | a perform: op with: b ]) >>> -1"

	| arguments |
	self emptyCheck.
	arguments := Array new: aBlock argumentCount.
	(arguments size = 0 or: [ (self size + 1) \\ (arguments size - 1) > 0 ])
		ifTrue: [ self error: 'Collection size and block argument count do not match.' ].
	arguments at: 1 put: self first.
	2 to: self size by: arguments size - 1 do: [ :index |
		arguments
			replaceFrom: 2 to: arguments size with: self startingAt: index;
			at: 1 put: (aBlock valueWithArguments: arguments) ].
	^ arguments first! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
groupsOf: n atATimeDo: aBlock 
	"Evaluate aBlock with my elements taken n at a time. Ignore any leftovers at the end.
	Allows use of a flattened 
	array for things that naturally group into groups of n.
	If aBlock has a single argument, pass it an array of n items,
	otherwise, pass the items as separate arguments.
	See also pairsDo:"
	
	"(Array streamContents: [:stream | #(10 20 30 40 50) groupsOf: 2 atATimeDo:  [:first :second | stream nextPut: (first + second)]]) >>> #(30 70)"
	
	| passArray |
	passArray := (aBlock numArgs = 1).
	n
		to: self size
		by: n
		do: [:index | | args | 
			args := (self copyFrom: index - n + 1 to: index) asArray.
			passArray ifTrue: [ aBlock value: args ]
				ifFalse: [ aBlock valueWithArguments: args ]].! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
collect: collectBlock thenSelect: selectBlock
	"Optimized version of Collection>>#collect:thenSelect:"
	
	"(#(1 2 3) collect: [:each | each + 10 ] thenSelect: [:each | each even]) >>> #(12)"
	
	| each |
	
	^  self class new: self size streamContents: [ :stream |
		1 to: self size do: [:index |
			each := collectBlock value: (self at: index).
			(selectBlock value: each)
				ifTrue: [ stream nextPut: each ]]]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
atWrap: index put: value
	"Store value into the index'th element of the receiver.  If index is out
	of bounds, let it wrap around from the end to the beginning until it 
	is in bounds. Answer value."
	"(#(11 22 33) asOrderedCollection atWrap: 2 put: 0; yourself) >>> #(11 0 33) asOrderedCollection"
   "(#(11 22 33) asOrderedCollection atWrap: 4 put: 0; yourself) >>> #(0 22 33) asOrderedCollection"
   "(#(11 22 33) asOrderedCollection atWrap: 6 put: 0; yourself) >>> #(11 22 0) asOrderedCollection"

	^ self at: index  - 1 \\ self size + 1 put: value! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
findBinary: aBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, raise an error."

	"(#(1 3 5 7 11 15 23) findBinary: [ :arg | 11 - arg ]) >>> 11 "

	^ self findBinary: aBlock do: [ :found | found ] ifNone: [ self errorNotFound: aBlock ]! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
first
	"Answer the first element of the receiver"
	"#(a b c d e f g h ) first >>> #a"

	^ self at: 1! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyWithFirst: newElement 
	"Answer a copy of the receiver that is 1 bigger than the receiver with newElement as the first element."

	| newIC |
	newIC := self species ofSize: self size + 1.
	newIC 
		replaceFrom: 2
		to: self size + 1
		with: self
		startingAt: 1.
	newIC at: 1 put: newElement.
	^ newIC! !

!SequenceableCollection methodsFor: 'sorting' stamp: ''!
sort
	"Sort this collection into ascending order using the '<=' operator."
	"{8. 5. 3. 9} sort >>> #(3 5 8 9)"
	"{#a. #b. #z. #d} sort >>> #(a b d z)"
	
	self sort: [:a :b | a <= b]! !

!SequenceableCollection methodsFor: 'copying' stamp: ''!
copyReplaceAll: oldSubCollection with: newCollection
	"Answer a copy of the receiver in which all occurrences of
	oldSubCollection have been replaced by newCollection "

	| aString startSearch currentIndex endIndex |
	
	aString := self.
	startSearch := 1.
	[(currentIndex := aString indexOfSubCollection: oldSubCollection startingAt: startSearch) > 0]
		whileTrue: [
			endIndex := currentIndex + oldSubCollection size - 1.
			aString := aString
					copyReplaceFrom: currentIndex
					to: endIndex
					with: newCollection.
				startSearch := currentIndex + newCollection size].

	^ aString! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
from: start to: stop do: aBlock
	"Evaluate aBlock for all elements between start and stop (inclusive)."
	
	"(Array streamContents: [:stream | #(10 20 30 40) from: 2 to: 3 do: [:each | stream nextPut: each]]) >>> #(20 30)"

	start to: stop do: [:index | aBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
findLast: aBlock
	"Return the index of my last element for which aBlock evaluates as true.
	If no matching element is found, return 0"
	
	"(#(10 20 30 40 50) findLast: [ :each | each > 10 ]) >>> 5"
	"(#(10 20 30 40 50) findLast: [ :each | each > 60 ]) >>> 0"
	
	| index |
	index := self size + 1.
	[(index := index - 1) >= 1] whileTrue:
		[(aBlock value: (self at: index)) ifTrue: [^index]].
	^ 0! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
reduceRight: aBlock
	"Fold the result of the receiver from right to left into aBlock. The argument aBlock must take two or more arguments."

	"(#(1 2 3) reduceRight: [ :a :b | a - b ]) >>> (1 - (2 - 3))"
	"(#(1 2 3) reduceRight: [ :a :b | a - b ]) >>> 2"
	"(#(1 + 3 - 5) reduceRight: [ :a :op :b | a perform: op with: b ]) >>> (1 + (3 - 5))"
	"(#(1 + 3 - 5) reduceRight: [ :a :op :b | a perform: op with: b ]) >>> -1"

	| arguments |
	self emptyCheck.
	arguments := Array new: aBlock argumentCount.
	(arguments size = 0 or: [ (self size + 1) \\ (arguments size - 1) > 0 ])
		ifTrue: [ self error: 'Collection size and block argument count do not match.' ].
	arguments at: arguments size put: self last.
	self size - arguments size + 1 to: 1 by: 1 - arguments size do: [ :index |
		arguments
			replaceFrom: 1 to: aBlock argumentCount - 1 with: self startingAt: index;
			at: arguments size put: (aBlock valueWithArguments: arguments) ].
	^ arguments last! !

!SequenceableCollection methodsFor: 'sorting' stamp: ''!
mergeSortFrom: first to: last src: src dst: dst by: aBlock
	"Private. Split the range to be sorted in half, sort each half, and 
	merge the two half-ranges into dst."

	| middle |
	first = last ifTrue: [^ self].
	middle := (first + last) // 2.
	self mergeSortFrom: first to: middle src: dst dst: src by: aBlock.
	self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock.
	src mergeFirst: first middle: middle last: last into: dst by: aBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
combinations: aNumber

	"Take the items in the receiver, aNumber at a time, return all the combinations"

	^ Array streamContents: [ :stream | 
		  self
			  combinations: aNumber
			  atATimeDo: [ :combination | stream nextPut: combination copy ] ]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: ''!
findBinaryIndex: aBlock ifNone: exceptionBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, evaluate exceptionBlock,
	with the 'bounding' elements as optional arguments."
	
	"(#(1 3 5 7 11 15 23) findBinaryIndex: [ :arg | 25 - arg ] ifNone: [ :a :b | 'between: ',{a. b} printString ]) >>> 'between: #(7 8)' "
	
	"(#(1 3 5 7 11 15 23) findBinaryIndex: [ :arg | 25 - arg ] ifNone: [ :a :b | 'over index: ', a printString ]) >>> 'over index: 7' "

	^ self 
		findBinaryIndex: aBlock 
		do: [ :found | found ] 
		ifNone: exceptionBlock! !

!SequenceableCollection methodsFor: 'accessing' stamp: ''!
replaceAll: oldObject with: newObject 
	"Replace all occurrences of oldObject with newObject"
	"({#a. #b. #a. #d. #a} replaceAll: #a with: #e) >>> #(e b e d e)"
	
	| index |
	index := self
				indexOf: oldObject
				startingAt: 1
				ifAbsent: [0].
	[index = 0]
		whileFalse: 
			[self at: index put: newObject.
			index := self
						indexOf: oldObject
						startingAt: index + 1
						ifAbsent: [0]]! !

!SequenceableCollection methodsFor: '*NewTools-Spotter' stamp: ''!
stFasterDifferencePreservingOrder: aCollection
	" this implementation does not preserve the original species of self !! it serves ONE specific use case only "
	| newCollection |
	newCollection := OrderedCollection new: self size.
	self do: [ :each | 
		(aCollection includes: each) 
			ifFalse: [ newCollection add: each ] ].
	^ newCollection! !

!SequenceableCollection methodsFor: 'testing' stamp: ''!
beginsWith: aSequenceableCollection
	"Answer true if the receiver starts with the argument collection"
	
	"#(1 2 3 4 5) beginsWith: #() >>> false"
	"#(1 2 3) beginsWith: #(1 2 3 4 5) >>> false"
	"#(1 2 3 4 5) beginsWith: #(0 1 2) >>> false"
	"#(1 2 3 4 5) beginsWith: #(1 2 3) >>> true"
	
	(aSequenceableCollection isEmpty or: [self size < aSequenceableCollection size]) ifTrue: [^false].
	aSequenceableCollection withIndexDo: [:each :index | (self at: index) ~= each ifTrue: [^false]].
	^true! !

!SequenceableCollection methodsFor: 'converting' stamp: ''!
asIntegerArray
	"Answer an IntegerArray whose elements are the elements of the receiver, in 
	the same order."

	| intArray |
	intArray := IntegerArray new: self size.
	1 to: self size do:[:i| intArray at: i put: (self at: i)].
	^intArray! !

!SequenceableCollection methodsFor: 'testing' stamp: ''!
endsWith: aSequenceableCollection
	"Answer true if the receiver ends with the argument collection"
	
	| start |
	(aSequenceableCollection isEmpty or: [self size < aSequenceableCollection size]) ifTrue: [^false].
	start := self size - aSequenceableCollection size.
	aSequenceableCollection withIndexDo: [:each :index | (self at: start + index) ~= each ifTrue: [^false]].
	^true! !

!SequenceableCollection class methodsFor: 'stream creation' stamp: ''!
streamContents: blockWithArg limitedTo: sizeLimit
	"A variant of #streamContents: with a strict size limit"

	"(String streamContents: [:s | 10 timesRepeat: [s nextPutAll: 'foo']] limitedTo: 9) >>> 'foofoofoo'"

	| stream |
	stream := LimitedWriteStream
		on: (self streamSpecies new: (100 min: sizeLimit))
		limit: sizeLimit
		limitBlock: [ ^ stream contents ].
	blockWithArg value: stream.
	^ stream contents! !

!SequenceableCollection class methodsFor: 'stream creation' stamp: ''!
new: newSize streamContents: blockWithArg
	"A variant of #streamContents: where the initial or even final size is given to optimize memory consumption"
	
	"(Array new: 3 streamContents: [ :out | 3 timesRepeat: [ out nextPut: 42 ] ]) >>> #(42 42 42)"
	
	| stream |
	stream := WriteStream on: (self streamSpecies new: newSize).
	blockWithArg value: stream.
	"If the write position of stream is at the end of the internal buffer of stream (originalContents),
	we can return it directly instead of making a copy as contents would do"
	^ stream position = stream originalContents size
		ifTrue: [ stream originalContents ]
		ifFalse: [ stream contents ]! !

!SequenceableCollection class methodsFor: 'stream creation' stamp: ''!
streamContents: blockWithArg
	"Build an instance of the receiver by writing elements to a stream.
	More specifically: blockWithArg will be given a WriteStream on an instance of the receiver.
	Inside blockWithArg you write elements to the stream to build up the collection.
	At the end, the contents of the stream up to that point will be returned.
	Note that the underlying collection grows as needed."
	
	"(Array streamContents: [ :out | out nextPut: 1; nextPutAll: #(2 3 4); nextPut: 5 ]) >>> #(1 2 3 4 5)"

	^ self new: 100 streamContents: blockWithArg! !

!SequenceableCollection class methodsFor: 'testing' stamp: ''!
isAbstract

	^self name = #SequenceableCollection! !

!SequenceableCollection class methodsFor: 'instance creation' stamp: ''!
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."
	^ self new: n! !

!SequenceableCollection class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Overwritten to use #streamContents: and #nextPut:"
	
	^ self streamContents: [ :stream |
		stonReader parseListDo: [ :each |
			stream nextPut: each ] ]! !

!SequenceableCollection class methodsFor: 'accessing' stamp: ''!
streamSpecies
	"I return the class that is used for streaming. If override consider overriding #new:streamContents:"
	^ self! !

!SerialPort commentStamp: ''!
This class supports a simple interface to the serial ports of the underlying platform, if it supports serial ports. The mapping of port numbers to hardware ports is platform specific, but typically follows platform ordering conventions. For example, on the Macintosh, port 0 is the modem port and port 1 is the printer port, since in the programmers documentation these ports are referred to as ports A and B.
!
!SerialPort methodsFor: 'accessing' stamp: ''!
baudRate: anInteger
	"Set the baud rate for this serial port."

	baudRate := anInteger! !

!SerialPort methodsFor: 'primitives' stamp: ''!
primClosePort: portNumber

	<primitive: 'primitiveSerialPortClose' module: 'SerialPlugin'>
	^ nil  "(DNS)"
	"self primitiveFailed."
! !

!SerialPort methodsFor: 'primitives' stamp: ''!
primWritePort: portNumber from: byteArray startingAt: startIndex count: count

	<primitive: 'primitiveSerialPortWrite' module: 'SerialPlugin'>
	self primitiveFailed.
! !

!SerialPort methodsFor: 'primitives' stamp: ''!
primReadPortByName: portName into: byteArray startingAt: startIndex count: count 
	<primitive: 'primitiveSerialPortReadByName' module:'SerialPlugin'>
	self primitiveFailed! !

!SerialPort methodsFor: 'primitives' stamp: ''!
primClosePortByName: portName
	<primitive: 'primitiveSerialPortCloseByName' module:'SerialPlugin'>
	^ nil"(DNS)"
	"self primitiveFailed."! !

!SerialPort methodsFor: 'accessing' stamp: ''!
baudRate

	^ baudRate
! !

!SerialPort methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: 'SerialPort(';
		nextPutAll:
			(port ifNil: ['closed'] ifNotNil: ['#', port printString]);
		nextPutAll: ', ';
		print: baudRate; nextPutAll: ' baud, ';
		print: dataBits; nextPutAll: ' bits, ';
		nextPutAll: (#('1.5' '1' '2') at: stopBitsType + 1); nextPutAll: ' stopbits, ';
		nextPutAll: (#('no' 'odd' 'even') at: parityType + 1); nextPutAll: ' parity)'
! !

!SerialPort methodsFor: 'primitives' stamp: ''!
primOpenPortByName: portName baudRate: baud stopBitsType: stop parityType: parity dataBits: numDataBits inFlowControlType: inFlowCtrl outFlowControlType: outFlowCtrl xOnByte: xOn xOffByte: xOff 
	<primitive: 'primitiveSerialPortOpenByName' module:'SerialPlugin'>
	^ nil"(DNS)"! !

!SerialPort methodsFor: 'primitives' stamp: ''!
primReadPort: portNumber into: byteArray startingAt: startIndex count: count

	<primitive: 'primitiveSerialPortRead' module: 'SerialPlugin'>
	self primitiveFailed
! !

!SerialPort methodsFor: 'accessing' stamp: ''!
parityType: anInteger
	"Set the parity type for this serial port, where:
		0 - no parity
		1 - odd parity
		2 - even parity"

	parityType := anInteger
! !

!SerialPort methodsFor: 'accessing' stamp: ''!
stopBitsType

	^ stopBitsType
! !

!SerialPort methodsFor: 'accessing' stamp: ''!
xOffByte: anInteger
	"Set the value of the XOff byte to be used if XOn/XOff flow control is enabled."

	xOffByte := anInteger
! !

!SerialPort methodsFor: 'open/close' stamp: ''!
close
	"Close the serial port. Do nothing if the port is not open."
	
	port ifNotNil: [port isString 
					ifTrue: [self primClosePortByName: port]
 					ifFalse: [self primClosePort: port]].
	port := nil! !

!SerialPort methodsFor: 'accessing' stamp: ''!
parityType

	^ parityType
! !

!SerialPort methodsFor: 'accessing' stamp: ''!
inputFlowControlType: anInteger
	"Set the type of input flow control, where:
		0 - none
		1 - XOn/XOff
		2 - hardware handshaking"

	inputFlowControlType := anInteger
! !

!SerialPort methodsFor: 'accessing' stamp: ''!
outputFlowControlType: anInteger
	"Set the type of output flow control, where:
		0 - none
		1 - XOn/XOff
		2 - hardware handshaking"

	outputFlowControlType := anInteger
! !

!SerialPort methodsFor: 'initialization' stamp: ''!
initialize
	"Default port settings."

	super initialize.
	baudRate := 9600.	"9600 baud"
	stopBitsType := 1.	"one stop bit"
	parityType := 0.	"no parity"
	dataBits := 8.	"8 bits"
	outputFlowControlType := 0.	"none"
	inputFlowControlType := 0.	"none"
	xOnByte := 19.	"ctrl-S"
	xOffByte := 24	"ctrl-X"! !

!SerialPort methodsFor: 'accessing' stamp: ''!
outputFlowControlType

	^ outputFlowControlType
! !

!SerialPort methodsFor: 'accessing' stamp: ''!
xOffByte

	^ xOffByte
! !

!SerialPort methodsFor: 'accessing' stamp: ''!
xOnByte

	^ xOnByte
! !

!SerialPort methodsFor: 'accessing' stamp: ''!
inputFlowControlType

	^ inputFlowControlType
! !

!SerialPort methodsFor: 'primitives' stamp: ''!
primWritePortByName: portName from: byteArray startingAt: startIndex count: count 
	<primitive: 'primitiveSerialPortWriteByName' module:'SerialPlugin'>
	self primitiveFailed! !

!SerialPort methodsFor: 'accessing' stamp: ''!
dataBits

	^ dataBits
! !

!SerialPort methodsFor: 'input/output' stamp: ''!
readInto: aStringOrByteArray startingAt: index
	"Read data into the given String or ByteArray object starting at the given index, and answer the number of bytes read. Does not go past the end of the given String or ByteArray."

	^ port isString
		ifTrue: [ self
				primReadPortByName: port
				into: aStringOrByteArray
				startingAt: index
				count: aStringOrByteArray size - index + 1 ]
		ifFalse: [ self
				primReadPort: port
				into: aStringOrByteArray
				startingAt: index
				count: aStringOrByteArray size - index + 1 ]! !

!SerialPort methodsFor: 'input/output' stamp: ''!
readByteArray
	"Answer a ByteArray read from this serial port. Answer an empty ByteArray if no data is available. The port must be open. "
	
	| buf count |
	buf := ByteArray new: 1000.
	count := port isString
				ifTrue: [self
						primReadPortByName: port
						into: buf
						startingAt: 1
						count: buf size]
				ifFalse: [self
						primReadPort: port
						into: buf
						startingAt: 1
						count: buf size].
	^ buf copyFrom: 1 to: count! !

!SerialPort methodsFor: 'accessing' stamp: ''!
dataBits: anInteger
	"Set the number of data bits for this serial port to 5, 6, 7, or 8."

	dataBits := anInteger
! !

!SerialPort methodsFor: 'open/close' stamp: ''!
openPort: portId

	"Open the given serial port, using the settings specified by my
	instance variables."

	| result |

	self close.	"8-10 - wks - this has to tell us if it fails: step 1, save the primitive result"
	result := portId isString
		ifTrue: [ self
				primOpenPortByName: portId
				baudRate: baudRate
				stopBitsType: stopBitsType
				parityType: parityType
				dataBits: dataBits
				inFlowControlType: inputFlowControlType
				outFlowControlType: outputFlowControlType
				xOnByte: xOnByte
				xOffByte: xOffByte
			]
		ifFalse: [ self
				primOpenPort: portId
				baudRate: baudRate
				stopBitsType: stopBitsType
				parityType: parityType
				dataBits: dataBits
				inFlowControlType: inputFlowControlType
				outFlowControlType: outputFlowControlType
				xOnByte: xOnByte
				xOffByte: xOffByte
			].	"wks - raise an error if there was a failure."
	result ifNil: [ self error: 'Cannot open ' , portId printString ].

	port := portId! !

!SerialPort methodsFor: 'accessing' stamp: ''!
xOnByte: anInteger
	"Set the value of the XOn byte to be used if XOn/XOff flow control is enabled."

	xOnByte := anInteger
! !

!SerialPort methodsFor: 'input/output' stamp: ''!
nextPutAll: aStringOrByteArray
	"Send the given bytes out this serial port. The port must be open."

	^ port isString
		ifTrue: [ self
				primWritePortByName: port
				from: aStringOrByteArray
				startingAt: 1
				count: aStringOrByteArray size ]
		ifFalse: [ self
				primWritePort: port
				from: aStringOrByteArray
				startingAt: 1
				count: aStringOrByteArray size ]! !

!SerialPort methodsFor: 'primitives' stamp: ''!
primOpenPort: portNumber baudRate: baud stopBitsType: stop
	parityType: parity dataBits: numDataBits
	inFlowControlType: inFlowCtrl outFlowControlType: outFlowCtrl
	xOnByte: xOn xOffByte: xOff

	<primitive: 'primitiveSerialPortOpen' module: 'SerialPlugin'>
	^ nil  "(DNS)"
! !

!SerialPort methodsFor: 'input/output' stamp: ''!
readString
	"Answer a String read from this serial port. Answer the empty
	String if no data is available. The port must be open."
	| buf count |
	buf := String new: 1000.
	count := port isString 
				ifTrue: [ self
							primReadPortByName: port
							into: buf
							startingAt: 1
							count: buf size.]
				ifFalse: [ self
						 	primReadPort: port
							into: buf
							startingAt: 1
							count: buf size.].
	^ buf copyFrom: 1 to: count! !

!SerialPort methodsFor: 'accessing' stamp: ''!
stopBitsType: anInteger
	"Set the stop bits type for this serial port, where:
		0 - 1.5 stop bits
		1 - one stop bit
		2 - two stop bits"

	stopBitsType := anInteger
! !

!SessionAccessModeResolver commentStamp: ''!
I check the image arguments and resolve if the access mode of the image. I am started very soon in the image start-up process.!
!SessionAccessModeResolver class methodsFor: 'class initialization' stamp: ''!
initialize

	"self initialize"

	SessionManager default
		register: (ClassSessionHandler forClassNamed: self name)
		inCategory: SessionManager default systemCategory  
		atPriority: SessionManager default defaultPriority - 90.! !

!SessionAccessModeResolver class methodsFor: 'class initialization' stamp: ''!
resolve 

	"check if the image was started in the read-only mode"

	| arguments mode | 
	
	arguments := Smalltalk argumentsStartingAtIndex: 0.
			
	mode := #readWrite.

	(Smalltalk argumentsInclude: '--readWriteAccessMode')
		ifTrue: [ mode := #readWrite ].
	(Smalltalk argumentsInclude:  '--readOnlyAccessMode')
		ifTrue: [ mode := #readOnly ].
	(Smalltalk argumentsInclude: '--writeOnlyAccessMode')
		ifTrue: [ mode := #writeOnly ].
	(Smalltalk argumentsInclude: '--disabledAccessMode')
		ifTrue: [ mode := #disabled ].
		
	SessionManager default currentSession accessMode: mode.! !

!SessionAccessModeResolver class methodsFor: 'system startup' stamp: ''!
startUp: resuming

	resuming ifTrue: [
		self resolve ]! !

!SessionCategory commentStamp: ''!
A session category allows to define many categories for a session (eg. System, Network, UI and user categories).
It allows session handlers (e.g. classes or packages handlers) to be registered into a category.
By default, the same default priority is assigned to handlers but a specific priority could be specified so that an handler will be activated before/after others.!
!SessionCategory methodsFor: 'private' stamp: ''!
renamedClass: aClass from: oldName to: newName
	
	priorityLists do: [ :handlers |
		handlers 
			detect: [ :handler | handler handledId = oldName ]
			ifFound: [ :handler | handler registeredClassName: newName ] ]
! !

!SessionCategory methodsFor: 'private' stamp: ''!
listAtPriority: anInteger 
	^ priorityLists
		at: anInteger
		ifAbsentPut: [ OrderedCollection new ]! !

!SessionCategory methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	priorityLists := Dictionary new! !

!SessionCategory methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!SessionCategory methodsFor: 'accessing' stamp: ''!
name: aString 
	name := aString! !

!SessionCategory methodsFor: 'accessing' stamp: ''!
defaultPriority
	"Completely arbitrary by now"
	^ 100! !

!SessionCategory methodsFor: 'registration' stamp: ''!
register: anObject atPriority: anInteger 
	(self listAtPriority: anInteger)
		addLast: anObject! !

!SessionCategory methodsFor: 'registration' stamp: ''!
unregisterHandler: anHandlerId 
	priorityLists valuesDo: [ :handlers |
				handlers 
					detect: [ :handler | handler handledId = anHandlerId ]
					ifFound: [ :handler | handlers remove: handler ] ]! !

!SessionCategory methodsFor: 'accessing' stamp: ''!
prioritizedList
	^ priorityLists keys sorted 
		flatCollect: [ :index | priorityLists at: index ]! !

!SessionCategory methodsFor: 'registration' stamp: ''!
register: anObject 
	self
		register: anObject
		atPriority: self defaultPriority! !

!SessionCategory methodsFor: 'printing' stamp: ''!
printOn: aStream 
	super printOn: aStream.
	aStream nextPut: $(;
		nextPutAll: self name;
		nextPut: $)! !

!SessionCreationTest commentStamp: ''!
SUnit tests for session creation with SessionManager!
!SessionCreationTest methodsFor: 'tests' stamp: ''!
testShutdown
	| manager session executed |
	executed := false.
	manager := SessionManager new.
	
	manager register: (TestSessionHandler onShutdown: [ executed := true ]).
	
	session := manager newSession.
	self deny: executed.
	
	session stop: false.
	self assert: executed.! !

!SessionCreationTest methodsFor: 'tests' stamp: ''!
testStartup
	| manager session executed |
	executed := false.
	manager := SessionManager new.
	
	manager register: (TestSessionHandler onStartup: [ executed := true ]).
	
	session := manager newSession.
	session start: false.
	
	self assert: executed! !

!SessionCreationTest methodsFor: 'tests' stamp: ''!
testNewSession
	| manager session |
	manager := SessionManager new.
	session := manager newSession.
	session stop: false.! !

!SessionErrorHandlingTest commentStamp: ''!
SUnit tests for session error handling!
!SessionErrorHandlingTest methodsFor: 'tests' stamp: ''!
testErrorHandledIfExceptionSignaledAtShutdownWhenStartupUiManagerActive
	<haltOrBreakpointForTesting>
	manager register: (TestSessionHandler onShutdown: [ ZeroDivide signal ]).	
	session errorHandler: 
		(TestStartupUIManager new
			sessionManager: manager;
			yourself).
	
	self 
		shouldnt: [ session stop: false ]
		raise: ZeroDivide.
	self
		assert: (session instVarNamed: 'deferredStartupActions') size 
		equals: 1! !

!SessionErrorHandlingTest methodsFor: 'utilities' stamp: ''!
newTestSessionfor: aManager
	^ TestWorkingSession new
		manager: aManager;
		yourself! !

!SessionErrorHandlingTest methodsFor: 'tests' stamp: ''!
testErrorHandledIfExceptionSignaledAtStartupWhenDefaultUiManagerActive
	<haltOrBreakpointForTesting>
	"session errorHandler will be TestWorkingSession that will register caught errors"

	manager register: (TestSessionHandler onStartup: [ Halt now ]).

	"ensure error handled"
	self shouldnt: [ session start: false ] raise: Halt.
	self assert: session errorHandler errors size equals: 1.

	"ensure no deferred actions"
	self assertEmpty: (session instVarNamed: 'deferredStartupActions')! !

!SessionErrorHandlingTest methodsFor: 'tests' stamp: ''!
testErrorCaughtIfExceptionSignaledAtShutdownWhenDefaultUiManagerActive
	"session errorHandler will be TestWorkingSession that will register caught errors"
	<haltOrBreakpointForTesting>
	manager register: (TestSessionHandler onShutdown: [ Halt now ]).

	"ensure error handled"
	self shouldnt: [ session stop: false ] raise: Halt.
	self assert: session errorHandler errors size equals: 1.

	"ensure no deferred actions"
	self assertEmpty: (session instVarNamed: 'deferredStartupActions')! !

!SessionErrorHandlingTest methodsFor: 'tests' stamp: ''!
testErrorCaughtAndDefferedIfExceptionSignaledAtStartupWhenStartupUiManagerActive
	<haltOrBreakpointForTesting>
	UIManager nonInteractiveDuring: [	manager register: (TestSessionHandler onStartup: [ Halt now ]).	
		session errorHandler: 
			(TestStartupUIManager new
				sessionManager: manager;
				yourself).
		
		self 
			shouldnt: [ session start: false ]
			raise: Halt.
		self
			assert: (session instVarNamed: 'deferredStartupActions') size 
			equals: 1]! !

!SessionErrorHandlingTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	manager := SessionManager new.
	session := self newTestSessionfor: manager.
	manager installSession: session.! !

!SessionManager commentStamp: ''!
I am the object responsible of managing how sessions work in Pharo.
A session defines the boundaries of work in the image.

A new session starts when the image starts.
A session stops when the image quits.
There is only one active session at a single point of time.

The current active session is held by myself, the singleton session manager. It can be accessed by doing:

  SessionManager default currentSession.

The most important responsibility of the session manager is to manage how resources and services in the image are started up and shut down at the beginning and end of a session respectively. For example, when the image starts, several initialization routines should be executed to make sure that the image has access to the graphic drivers, the standard input/output file descriptors and so on.

Such initialization happens in the #snapshot:andQuit: method. #snapshot:andQuit: will:
 - stop current session
 - save current image if requested
 - quit if requested
 - start a new session
 
When a session is started, all elements registered in the startup list are started up.
When a session is stopped, all elements registered in the shutdown list are shut down.

# Managing Startup and Shutdown lists

The startup and shutdown lists can be accessed through the messages:

    SessionManager default startupList.
    SessionManager default shutdownList.

In general terms, the shutdown list is the startup list reversed.

Upon a startup [shutdown], all elements in the startup list are sent the message #startup: [#shutdown:] with a boolean as argument that indicates whether the image is being saved [closed].

Internally, startup and shutdown lists are prioritised. Priorities are managed by startup categories. By default the session manager includes the following categories in decreasing priority order:

- System
- Network
- Graphical User Interface
- Tools
- User

Categories can be accessed as follows:

    SessionManager default categoryNamed: aName.

New categories can be registered in the system using the messages:

    SessionManager default createCategory: aCategoryName.
    SessionManager default createCategory: aCategoryName after: anotherCategoryName.

Finally, to subscribe some resource handler to the startup shutdown lists, we need to subscribe a handler, subclass of AbstractSessionHandler.
The most common handler implementation so far is the ClassSessionHandler, that allows to subscribe a class for startup and shutdown, keeping backwards compatibility to the old startup mechanism.

    ClassSessionHandler forClassNamed: aClassName

We can register a session handler as follows

    SessionManager default
        register: (ClassSessionHandler forClassNamed: self name)
        inCategory: SessionManager default systemCategory.
        
Or alternatively, by talking to the corresponding category:

    SessionManager default systemCategory register: (ClassSessionHandler forClassNamed: self name)

# System Category Priorities

A system category internally prioritizes its elements to provide a fine grained control on the startup and shutdown order.
All methods above have variants that allow developers to specify the priority inside the category:  

    SessionManager default
        register: (ClassSessionHandler forClassNamed: self name)
        inCategory: SessionManager default systemCategory
        atPriority: 100.

    SessionManager default systemCategory
        register: (ClassSessionHandler forClassNamed: self name)
        atPriority: 100
        
By default, if no priority is specified, a default priority is used. Every category answers to the message #defaultPriority.

# How does an image restart from the point it was before

An important point in the image startup is how does it manage to restart from the point where it was executing when it was saved.

When the image is saved, using the snapshot primitive, the entire image is freezed at the point of the snapshot.
More particularly, the process that invoked the snapshot primitive is freezed at the point of the primitive call.
This works as a process fork: the running image will return from the snapshot primitive and the saved file will also start from the freezed point.
To differentiate whether we are executing in the running image or in the freshly-saved image, the snapshot primitive returns a boolean indicating it.

Read the comment of #snapshotPrimitive for more details.!
!SessionManager methodsFor: 'session management' stamp: ''!
uninstallSession: aWorkingSession 
	currentSession := nil! !

!SessionManager methodsFor: 'accessing' stamp: ''!
currentSession
	^ currentSession! !

!SessionManager methodsFor: 'registration' stamp: ''!
registerUserClassNamed: aClassName atPriority: anInteger
	self 
		register: (ClassSessionHandler forClassNamed: aClassName)
		inCategory: self userCategory 
		atPriority: anInteger! !

!SessionManager methodsFor: 'registration' stamp: ''!
registerGuiClassNamed: aClassName atPriority: anInteger
	self 
		register: (ClassSessionHandler forClassNamed: aClassName)
		inCategory: self guiCategory 
		atPriority: anInteger! !

!SessionManager methodsFor: 'registration' stamp: ''!
hasRegistered: handledId
	"handledId, in most cases, will be a class name"
	
	^ self startupList 
			anySatisfy: [ :handler | handler handledId = handledId ]
	! !

!SessionManager methodsFor: 'well-known categories' stamp: ''!
toolsCategory
	^ toolsCategory! !

!SessionManager methodsFor: 'registration' stamp: ''!
registerSystemClassNamed: aClassName
	self 
		register: (ClassSessionHandler forClassNamed: aClassName)
		inCategory: self systemCategory 
		atPriority: self defaultPriority! !

!SessionManager methodsFor: 'registration' stamp: ''!
unregisterClassNamed: aClassName 
	self unregisterHandler: aClassName! !

!SessionManager methodsFor: 'accessing' stamp: ''!
categoryNamed: aString 
	^ categories 
		detect: [ :each | each name = aString ]
		ifNone: [ NotFound signalFor: aString ]! !

!SessionManager methodsFor: 'registration' stamp: ''!
registerToolClassNamed: aClassName
	self 
		register: (ClassSessionHandler forClassNamed: aClassName)
		inCategory: self toolsCategory 
		atPriority: self defaultPriority! !

!SessionManager methodsFor: 'registration' stamp: ''!
registerGuiClassNamed: aClassName
	self 
		register: (ClassSessionHandler forClassNamed: aClassName)
		inCategory: self guiCategory 
		atPriority: self defaultPriority! !

!SessionManager methodsFor: 'category management' stamp: ''!
createCategory: aCategoryName
	| category |
	category := self basicCreateCategory: aCategoryName.
	categories add: category.
	^ category! !

!SessionManager methodsFor: 'accessing' stamp: ''!
startupList
	^ (categories flatCollect: #prioritizedList)
		asArray! !

!SessionManager methodsFor: 'well-known categories' stamp: ''!
networkCategory
	^ networkCategory! !

!SessionManager methodsFor: 'accessing' stamp: ''!
defaultPriority
	"Completely arbitrary by now"
	^ 100! !

!SessionManager methodsFor: 'session management' stamp: ''!
installSession: aWorkingSession 
	currentSession := aWorkingSession! !

!SessionManager methodsFor: 'registration' stamp: ''!
register: aSessionHandler inCategory: aCategory
	aCategory 
		register: aSessionHandler
		atPriority: aCategory defaultPriority! !

!SessionManager methodsFor: 'session management' stamp: ''!
installNewSession
	self installSession: self newSession.! !

!SessionManager methodsFor: 'registration' stamp: ''!
registerSystemClassNamed: aClassName atPriority: anInteger
	self 
		register: (ClassSessionHandler forClassNamed: aClassName)
		inCategory: self systemCategory 
		atPriority: anInteger! !

!SessionManager methodsFor: 'registration' stamp: ''!
unregisterHandler: anHandledId 
	categories do: [ :each | each unregisterHandler: anHandledId ]! !

!SessionManager methodsFor: 'registration' stamp: ''!
register: aSessionHandler
	self
		register: aSessionHandler
		inCategory: self userCategory
		atPriority: self defaultPriority! !

!SessionManager methodsFor: 'registration' stamp: ''!
registerUserClassNamed: aClassName
	self 
		register: (ClassSessionHandler forClassNamed: aClassName)
		inCategory: self userCategory 
		atPriority: self defaultPriority! !

!SessionManager methodsFor: 'category management' stamp: ''!
createCategory: aCategoryName after: anotherCategoryName
	| category |
	category := self basicCreateCategory: aCategoryName.	
	categories 
		add: category
		after: (self categoryNamed: anotherCategoryName).
	^ category! !

!SessionManager methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	categories := OrderedCollection new.
		
	systemCategory := self createCategory: 'System'.
	networkCategory := self createCategory: 'Network'.
	guiCategory := self createCategory: 'Graphical User Interface'.
	toolsCategory := self createCategory: 'Tools'.
	userCategory := self createCategory: 'User'.! !

!SessionManager methodsFor: 'well-known categories' stamp: ''!
guiCategory
	^ guiCategory! !

!SessionManager methodsFor: 'deferred startup actions' stamp: ''!
addDeferredStartupAction: aBlock
	"Add the block to the list of actions that we will be performed immediately after the startup list is executed."
	self currentSession 
		addDeferredStartupAction: aBlock
	! !

!SessionManager methodsFor: 'registration' stamp: ''!
registerNetworkClassNamed: aClassName
	self 
		register: (ClassSessionHandler forClassNamed: aClassName)
		inCategory: self networkCategory 
		atPriority: self defaultPriority! !

!SessionManager methodsFor: 'snapshot and quit' stamp: ''!
snapshot: save andQuit: quit
	| isImageStarting wait |
	"We do the snapshot in a separate process in maximum priority to have always a clean startup.
	This process will be interrupted by the fork, and will be resumed as soon as the snapshot finishes.
	We synchronize these processes in case both are in the same priority.
	When both arguments are false, do nothing and return false."
	(save or: [ quit ])
		ifFalse: [ ^ false ].
	wait := Semaphore new.
	[ isImageStarting := self launchSnapshot: save andQuit: quit.
	  wait signal. ] forkAt: Processor timingPriority - 1.
	wait wait.
	
	"The execution of the deferred startup actions are executed in the caller thread."
	self currentSession executeDeferredStartupActions: isImageStarting.
	
	^ isImageStarting! !

!SessionManager methodsFor: 'category management' stamp: ''!
basicCreateCategory: aString 
	^ SessionCategory new
		name: aString;
		yourself! !

!SessionManager methodsFor: 'session management' stamp: ''!
newSession
	| aWorkingSession |
	aWorkingSession := WorkingSession new.
	aWorkingSession manager: self.
	^ aWorkingSession! !

!SessionManager methodsFor: 'accessing' stamp: ''!
shutdownList
	^ self startupList reversed! !

!SessionManager methodsFor: 'registration' stamp: ''!
register: aSessionHandler inCategory: aCategory atPriority: anInteger 
	self unregisterHandler: aSessionHandler handledId.
	aCategory 
		register: aSessionHandler
		atPriority: anInteger! !

!SessionManager methodsFor: 'registration' stamp: ''!
renamedClass: aClass from: oldName to: newName
	"Inform SessionManager that aClass has been renamed"
	
	categories do: [ :category |
		category renamedClass: aClass from: oldName to: newName ]! !

!SessionManager methodsFor: 'registration' stamp: ''!
registerLast: aSessionHandler inCategory: aCategory
	self 
		register: aSessionHandler
		inCategory: aCategory 
		atPriority: self maxPriority! !

!SessionManager methodsFor: 'well-known categories' stamp: ''!
userCategory
	^ userCategory! !

!SessionManager methodsFor: 'accessing' stamp: ''!
maxPriority
	"Completely arbitrary by now"
	^ 10000! !

!SessionManager methodsFor: 'well-known categories' stamp: ''!
systemCategory
	^ systemCategory! !

!SessionManager methodsFor: 'snapshot and quit' stamp: ''!
launchSnapshot: save andQuit: quit
	| isImageStarting snapshotResult |
	ChangesLog default logSnapshot: save andQuit: quit.
	
	self currentSession stop: quit.	"Image not usable from here until the session is restarted!!"
	save
		ifTrue: [
					snapshotResult := Smalltalk snapshotPrimitive.	"<-- PC frozen here on image file"
					isImageStarting := snapshotResult == true. ]
		ifFalse: [ isImageStarting := false ].
	(quit and: [ isImageStarting not ])
		ifTrue: [ Smalltalk quitPrimitive ].

	"create a new session object if we're booting"
	isImageStarting ifTrue: [ self installNewSession ].

	self currentSession start: isImageStarting.
	snapshotResult 
		ifNil: [ self error: 'Failed to write image file (disk full?)' ]
		ifNotNil: [ 
			SystemAnnouncer uniqueInstance snapshotDone: isImageStarting ].
	
	"We return the resuming state, which may be useful for users to know the state of the image"
	^ isImageStarting! !

!SessionManager class methodsFor: 'accessing' stamp: ''!
default
	^ Default ifNil: [ Default := self new ] ! !

!SessionManager class methodsFor: 'compatibility - startupList' stamp: ''!
initializedSessionManager
	| manager |
	manager := SessionManager new.
	manager
		registerSystemClassNamed: #SmallInteger atPriority: 10; "System - 10"
		registerSystemClassNamed: #Delay atPriority: 20; "System - 20"
		registerSystemClassNamed: #ProcessorScheduler atPriority: 30; "System - 30"
		registerSystemClassNamed: #OSPlatform atPriority: 50; "System - 50"

		registerSystemClassNamed: #ExternalObject atPriority: 60; "System - 60"
		registerSystemClassNamed: #FFIBackend atPriority: 60; "System - 60"
		registerSystemClassNamed: #FFIMethodRegistry atPriority: 60; "System - 60"
		registerSystemClassNamed: #FileLocator atPriority: 90; "System - 90"
		
		registerSystemClassNamed: #Stdio; "System"
		registerSystemClassNamed: #LanguageEnvironment	; "System"
		registerSystemClassNamed: #ShortIntegerArray; "System"
		registerSystemClassNamed: #DiskStore; "System"
		registerSystemClassNamed: #MemoryStore; "System"
		registerSystemClassNamed: #SmalltalkImage; "System"
		registerSystemClassNamed: #WeakFinalizationList; "System"
		registerSystemClassNamed: #Clipboard; "System"
		registerSystemClassNamed: #MCMethodDefinition; "System"
		registerSystemClassNamed: #Symbol; "System"
		registerSystemClassNamed: #Locale; "System"
		registerSystemClassNamed: #WeakArray; "System"
		registerSystemClassNamed: #BasicCommandLineHandler; "System"
		registerSystemClassNamed: #NonInteractiveTranscript; "System"
		registerSystemClassNamed: #ASTCache; "System"
		registerSystemClassNamed: #OSEnvironment; "System"
		registerSystemClassNamed: #EndianDetector; "System"

		registerNetworkClassNamed: #InternetConfiguration; "Network"
		registerNetworkClassNamed: #ZnServer; "Network"
		registerNetworkClassNamed: #MCGitHubRepository; "Network"
		registerNetworkClassNamed: #MCGitBasedNetworkRepository; "Network"
		registerNetworkClassNamed: #ZnLogEvent; "Network"
		registerSystemClassNamed: #UUIDGenerator; "Network"

		registerGuiClassNamed: #DisplayScreen atPriority: 10; "GUI - 10"
		
		registerGuiClassNamed: #Cursor; "GUI"	
		registerGuiClassNamed: #Form; "GUI"
		registerGuiClassNamed: #StrikeFont; "GUI"
		registerGuiClassNamed: #Color; "GUI"
		registerGuiClassNamed: #FreeTypeCache; "GUI"
		registerGuiClassNamed: #LogicalFont; "GUI"
		registerGuiClassNamed: #FT2Handle; "GUI"
		registerGuiClassNamed: #FreeTypeSettings; "GUI"
		registerGuiClassNamed: #WorldMorph atPriority: 110; "GUI"
		"It Should run at the end of everything to correctly handle the errors"
		registerLast: UIManagerSessionHandler uniqueInstance
			inCategory: manager userCategory; 

		registerToolClassNamed: #CPUWatcher; "Tools"
		registerToolClassNamed: #PharoCommonTools; "Tool"
		registerToolClassNamed: #GTPlayBook; "Tools"

		registerLast: (ClassSessionHandler forClassNamed: #SystemSettingsPersistence)
			inCategory: manager userCategory; "Preferences loading may need to have anything else well initialized before."
		
		yourself.
	^ manager! !

!SessionManager class methodsFor: 'accessing' stamp: ''!
default: aSessionManager
	Default := aSessionManager! !

!SessionManagerRegistrationOrderTest commentStamp: ''!
SUnit tests for registration order on the Pharo session manager!
!SessionManagerRegistrationOrderTest methodsFor: 'asserting' stamp: ''!
assertHandledId: aSessionHandlerList equals: aCollection
	self 
		assert: (aSessionHandlerList collect: [:each | each handledId])
		equals: aCollection! !

!SessionManagerRegistrationOrderTest methodsFor: 'tests' stamp: ''!
testRegisterElementByDefault
	manager register: (ClassSessionHandler forClassNamed: 'anObject').

	self 
		assertHandledId: manager startupList
		equals: #( 'anObject' ).! !

!SessionManagerRegistrationOrderTest methodsFor: 'tests' stamp: ''!
testSubscriptionReverseOrder
	manager
		registerSystemClassNamed: 'aFirstSubscription' atPriority: 100;
		register: (ClassSessionHandler forClassNamed: 'anObject').

	self 
		assertHandledId: manager startupList 
		equals: #( 'aFirstSubscription' 'anObject' ).
	self 
		assertHandledId: manager shutdownList 
		equals: #( 'anObject' 'aFirstSubscription' ).! !

!SessionManagerRegistrationOrderTest methodsFor: 'tests' stamp: ''!
testRegisterSystemElement
	manager registerSystemClassNamed: 'anObject' atPriority: 1.

	self 
		assertHandledId: manager startupList
		equals: #( 'anObject' ).! !

!SessionManagerRegistrationOrderTest methodsFor: 'tests' stamp: ''!
testCategoriesPriorityOrder
	manager 
		register: (ClassSessionHandler forClassNamed: 'anObject');
		registerSystemClassNamed: 'aFirstSubscription' atPriority: 100.
	
	self 
		assertHandledId: manager startupList 
		equals: #( 'aFirstSubscription' 'anObject' ).! !

!SessionManagerRegistrationOrderTest methodsFor: 'tests' stamp: ''!
testCreateCategoryFailsIfAfterUnexistentCategory
	| customCategory |
	
	self 
		should: [customCategory := manager createCategory: 'Second' after: 'First']
		raise: NotFound.! !

!SessionManagerRegistrationOrderTest methodsFor: 'tests' stamp: ''!
testCustomCategoryGoesAfterSystemCategoryByDefault
	| customCategory |
	customCategory := manager createCategory: 'Custom'.
	customCategory register: 'aCustomAction'.
	
	manager systemCategory register: 'aSystemAction' atPriority: 10.
	
	self 
		assert: manager startupList
		equals: #( 'aSystemAction' 'aCustomAction' ).! !

!SessionManagerRegistrationOrderTest methodsFor: 'tests' stamp: ''!
testCustomCategoryOrderIsPreserved
	| customCategory |
	customCategory := manager createCategory: 'First'.
	customCategory register: 'first'.	
	
	customCategory := manager createCategory: 'Second' after: 'First'.
	customCategory register: 'second'.
	
	self 
		assert: manager startupList 
		equals: #( 'first' 'second' ).! !

!SessionManagerRegistrationOrderTest methodsFor: 'tests' stamp: ''!
testPriorityOrderInTheSameCategoryIsRespected
	manager
		registerSystemClassNamed: 'aFirstSubscription' atPriority: 100;
		registerSystemClassNamed: 'aSecondSubscription' atPriority: 110;
		registerSystemClassNamed: 'aThirdSubscriptionThatShouldGoFirst' atPriority: 90.
		

	self 
		assertHandledId: manager startupList 
		equals: #( 'aThirdSubscriptionThatShouldGoFirst' 'aFirstSubscription' 'aSecondSubscription' ).! !

!SessionManagerRegistrationOrderTest methodsFor: 'tests' stamp: ''!
register: aString atSystemPriority: anInteger
	manager 
		register: aString
		inCategory: manager systemCategory
		atPriority: anInteger! !

!SessionManagerRegistrationOrderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	manager := SessionManager new! !

!SessionManagerRegistrationTest commentStamp: ''!
SUnit tests for registration on the Pharo session manager!
!SessionManagerRegistrationTest methodsFor: 'tests' stamp: ''!
testGivenUnknonwnHandledIdShouldHasRegisteredReturnsFalse
	self deny: (manager hasRegistered: #Foo)! !

!SessionManagerRegistrationTest methodsFor: 'tests' stamp: ''!
testGivenARegisteredClassHandlerShouldHasRegisteredReturnsTrue
	manager registerSystemClassNamed: #Foo.

	self assert: (manager hasRegistered: #Foo)! !

!SessionManagerRegistrationTest methodsFor: 'tests' stamp: ''!
testGivenManyRegistrationsInDifferentCategoriesShoudlLastClassRegistrationBeTheOnlyOccurrenceInStartupList

	manager registerSystemClassNamed: #Foo.
	manager registerSystemClassNamed: #Bar.
	manager registerGuiClassNamed: #Foo atPriority: 30.
	manager registerGuiClassNamed: #Foo atPriority: 50.
	self 
		assert: (manager startupList collect: [:each | each handledId])
		equals: #( Bar Foo ).! !

!SessionManagerRegistrationTest methodsFor: 'tests' stamp: ''!
testGivenManyRegistrationsInSameCategoryAtDifferentPriorityShoudlAClassBePresentOnlyOnceInStartupList
	manager registerSystemClassNamed: #Foo.
	manager registerSystemClassNamed: #Bar atPriority: 15.
	manager registerSystemClassNamed: #Foo atPriority: 10.
	manager registerSystemClassNamed: #Foo atPriority: 20.
	self 
		assert: (manager startupList collect: [:each | each handledId])
		equals: #( Bar Foo ).! !

!SessionManagerRegistrationTest methodsFor: 'tests' stamp: ''!
testGivenARegisteredClassRenamedThenItsHandlerIsUpdated

	manager registerSystemClassNamed: #Foo.
	manager renamedClass: self from: #Foo to: #Bar.
	self 
		assert: (manager startupList collect: [:each | each handledId])
		equals: #( Bar ).! !

!SessionManagerRegistrationTest methodsFor: 'tests' stamp: ''!
testGivenManyRegistrationsInSameCategoryShoudlAClassBePresentOnlyOnceInStartupList
	manager registerSystemClassNamed: #Foo.
	manager registerSystemClassNamed: #Bar.
	manager registerSystemClassNamed: #Foo.
	manager registerSystemClassNamed: #Foo.
	self 
		assert: (manager startupList collect: [:each | each handledId])
		equals: #( Bar Foo ).! !

!SessionManagerRegistrationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	manager := SessionManager new! !

!SessionManagerUnregistrationTest commentStamp: ''!
SUnit tests for unregistration from the Pharo session manager!
!SessionManagerUnregistrationTest methodsFor: 'tests' stamp: ''!
testCanUnregisterClass

	sessionManager registerSystemClassNamed: #Foo.
	sessionManager registerSystemClassNamed: #Bar.
	sessionManager unregisterClassNamed: #Foo.
	self 
		assert: (sessionManager startupList collect: [:each | each handledId])
		equals: #( Bar ).! !

!SessionManagerUnregistrationTest methodsFor: 'tests' stamp: ''!
testUnregisterUnknownClassDoesNotFail

	sessionManager registerSystemClassNamed: #Foo.
	sessionManager unregisterClassNamed: #Bar.
	self 
		assert: (sessionManager startupList collect: [:each | each handledId])
		equals: #( Foo ).! !

!SessionManagerUnregistrationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	sessionManager := SessionManager new! !

!Set commentStamp: ''!
I represent a set of objects without duplicates.  I can hold anything that responds to
`#hash` and `#=`, except for nil.  My instances will automatically grow, if necessary,
Note that I rely on `#=`, not `#==`.  If you want a set using `#==`, use `IdentitySet`.


The core operation is #find`ElementOrNil:`, which either finds the position where an
object is stored in array, if it is present, or finds a suitable position holding nil, if
its argument is not present in array.

### Instance structure:

- array	An array whose non-nil elements are the elements of the set,
  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 set.  The array size is always greater than this.

!
!Set methodsFor: 'accessing' stamp: ''!
like: anObject
	"Answer an object in the receiver that is equal to anObject,
	nil if no such object is found. Relies heavily on hash properties.
	Note, use #like:ifAbsent: if you need to match against nil as element"

	^ self like: anObject ifAbsent: [ nil ]! !

!Set methodsFor: 'private' stamp: ''!
rehash
	| newSelf |
	newSelf := self species new: self size.
	self do: [:each | newSelf noCheckAdd: each].
	array := newSelf array! !

!Set methodsFor: 'comparing' stamp: ''!
= aSet
	self == aSet ifTrue: [^ true].	"stop recursion"
	(aSet isKindOf: Set) ifFalse: [^ false].
	self size = aSet size ifFalse: [^ false].
	self do: [:each | (aSet includes: each) ifFalse: [^ false]].
	^ true! !

!Set methodsFor: 'adding' stamp: ''!
add: newObject
	"Include newObject as one of the receiver's elements, but only if
	not already present. Answer newObject."

	| index |
	index := self scanFor: newObject.
	(array at: index) ifNil: [self atNewIndex: index put: newObject asCollectionElement].
	^ newObject! !

!Set methodsFor: 'testing' stamp: ''!
includes: anObject 
	^ (array at: (self findElementOrNil: anObject)) ~~ nil! !

!Set methodsFor: 'testing' stamp: ''!
occurrencesOf: anObject 
	^ (self includes: anObject) ifTrue: [1] ifFalse: [0]! !

!Set methodsFor: '*Monticello-Storing' stamp: 'nil'!
comeFullyUpOnReload: smartRefStream
	"Symbols have new hashes in this image."

	^self 
		rehash; 
		yourself
! !

!Set methodsFor: 'removing' stamp: ''!
copyWithout: oldElement 
	"Answer a copy of the receiver that does not contain any
	elements equal to oldElement."

	^ self copy
		remove: oldElement ifAbsent: [];
		yourself! !

!Set methodsFor: 'private' stamp: ''!
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 := anObject hash \\ array size + 1.
	[ 
		| element |
		((element := array at: index) == nil or: [ element enclosedElement = anObject ])
			ifTrue: [ ^index ].
		(index := index \\ array size + 1) = start ] whileFalse.
	self errorNoFreeSpace! !

!Set methodsFor: '*OpalCompiler-Core' stamp: ''!
parseOptions: anArray

	"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.
	anArray do: [:option |
		option == #+ 
			ifTrue: [ include := true ]
			ifFalse: [
				option == #- 
					ifTrue: [ include := false ]
					ifFalse: [ 
						include ifTrue: [ self add: option ] 
						ifFalse: [ self remove: option ifAbsent:[] ]]]
		].! !

!Set methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper
	"Since we have subclasses of Set that behave differently, we cannot use the visitSimpleCollection: for all of them."
	^ ((self class == Set) or: [ self class == IdentitySet ] ) 
		ifTrue: [ aGeneralMapper visitSimpleCollection: self ]
		ifFalse: [ super fuelAccept: aGeneralMapper ] 
	! !

!Set methodsFor: '*Fuel-Core' stamp: ''!
fuelAfterMaterialization

	"Since for Set and IdentitySet we are recreating the collection with #add: (see FLSimpleCollectionCluster) we do not need to rehash"
	^ ((self class == Set) or: [ self class == IdentitySet ] ) 
		ifFalse: [ self rehash ] 
		ifTrue: [ self ]! !

!Set methodsFor: 'private' stamp: ''!
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 enclosedElement] ]! !

!Set methodsFor: 'enumerating' stamp: ''!
do: aBlock 
	tally = 0 ifTrue: [^ self].
	1 to: array size do:
		[:index |
		| each |
		(each := array at: index) ifNotNil: [aBlock value: each enclosedElement]]! !

!Set methodsFor: 'enumerating' stamp: ''!
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."

	| newSet |
	newSet := self species new: self size.
	array do: [:each | each ifNotNil: [newSet add: (aBlock value: each enclosedElement)]].
	^ newSet! !

!Set methodsFor: 'private' stamp: ''!
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: [ :object |
			array
				at: (self scanForEmptySlotFor: object enclosedElement)
				put: object ] ]! !

!Set methodsFor: 'private' stamp: ''!
noCheckAdd: anObject
	"This method should be deprecated"
	array at: (self findElementOrNil: anObject) put: anObject asCollectionElement.
	tally := tally + 1! !

!Set methodsFor: 'enumerating' stamp: ''!
intersection: aCollection
	"Answer the set theoretic intersection of two collections.
	Optimized version for Sets where no intermediate Set is necessary"

	"(#(1 2 3 4) asSet intersection: #(3 4 5) asSet) >>> #(3 4) asSet"

	"(#(1 2 3 4) asSet intersection: #() asSet) >>> Set new"

	"( #() asSet intersection: #(1 2 3 4) asSet) >>> Set new"

	| outputSet |
	outputSet := self class new.
	aCollection do: [ :each | (self includes: each) ifTrue: [ outputSet add: each ] ].
	^ outputSet! !

!Set methodsFor: 'testing' stamp: ''!
isHealthy
	"Test that object hashes match their positions stored in set's array,
	answer true if everything ok, false otherwise
	
	Set allSubInstances select: [:badSet |
		badSet isHealthy not ]
	"
	array withIndexDo: [ :element :index |
		element ifNotNil: [
			(self scanFor: element enclosedElement) == index
				ifFalse: [ ^ false ]]].
	^ true! !

!Set methodsFor: 'comparing' stamp: ''!
max: aBlock
	self ifEmpty: [ ^ nil ].
	^ self inject: 0 into: [ :max :each | (aBlock value: each) max: max ]! !

!Set methodsFor: '*STON-Core' stamp: ''!
stonPostReferenceResolution
	"When references were resolved in me, the hash of my elements might have changed.
	Check if I am still healthy and rehash me if not."
	
	self isHealthy ifFalse: [ self rehash ]! !

!Set methodsFor: 'private' stamp: ''!
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 scanFor: element enclosedElement) = index ifFalse: [
			array swap: index with: newIndex ] ]! !

!Set methodsFor: 'converting' stamp: ''!
asSet
	^self! !

!Set methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	array := array copy! !

!Set methodsFor: '*Random-Core' stamp: ''!
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."
	| index |

	self emptyCheck.
	index := aGenerator nextInteger: array size.
	[ (array at: index) isNil ] whileTrue: [ index := index \\ array size + 1 ].
	^ array at: index.! !

!Set methodsFor: '*Reflectivity' stamp: ''!
metaLinkOptions
	^{
	#parseOptions: -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!Set methodsFor: 'accessing' stamp: ''!
like: anObject ifAbsent: aBlock
	"Answer an object in the receiver that is equal to anObject,
	or evaluate the block if not found. Relies heavily on hash properties"
	| element |
	element := array at: (self scanFor: anObject).
	^ element ifNil: [ aBlock value ] ifNotNil: [ element enclosedElement ]! !

!Set methodsFor: 'private' stamp: ''!
withArray: anArray
	"private -- for use only in copy"
	"I want to get a conflict"
	array := anArray! !

!Set methodsFor: '*Fuel-Core' stamp: ''!
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."

	| index |
	index := self scanFor: anObject.
	(array at: index) 
		ifNil: [self atNewIndex: index put: anObject asCollectionElement]
		ifNotNil: [ aBlock value ].
	^ anObject

	"Sets in Pharo 1.2 can't' contain nil, so this implementation is wrong in that version. This is the right one (in Pharo 1.2):

	| index |
	anObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
	index := self findElementOrNil: anObject.
	(array at: index) 
		ifNil: [ self atNewIndex: index put: anObject ]
		ifNotNil: [ aBlock value ].
	^ anObject"! !

!Set methodsFor: 'enumerating' stamp: ''!
difference: aCollection
	"Answer the set theoretic difference of two collections. Optimized version for Sets where no intermediate Set is necessary"

	"#(a b c d e f) difference:  #(a b z k)
	=> #(#f #d #e #c)
	
	#(a b z k) difference: #(a b c d e f) 
	=> #(#k #z) 
	"

	| set |
	set := self copy.
	aCollection do: [ :each | set remove: each ifAbsent: [  ] ].
	^ set! !

!Set methodsFor: 'removing' stamp: ''!
remove: oldObject ifAbsent: aBlock

	| index |
	index := self findElementOrNil: oldObject.
	(array at: index) == nil ifTrue: [ ^ aBlock value ].
	array at: index put: nil.
	tally := tally - 1.
	self fixCollisionsFrom: index.
	^ oldObject! !

!Set class methodsFor: 'instance creation' stamp: ''!
newFrom: aCollection
	"Answer an instance of me containing the same elements as aCollection."
	"(Set newFrom: {1. 2. 3}) >>> #( 1 2 3) asSet"
	"({1. 2. 3} as: Set) >>> #( 1 2 3) asSet"
	
	| newCollection |
	newCollection := self new: aCollection size.
	newCollection addAll: aCollection.
	^ newCollection! !

!Set class methodsFor: 'instance creation' stamp: ''!
sizeFor: nElements
	"Large enough size to hold nElements with some slop (see fullCheck)"

	^ HashTableSizes atLeast: nElements * 4 // 3! !

!SetTest commentStamp: ''!
This is the unit test for the class Set. 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!
!SetTest methodsFor: 'requirements' stamp: ''!
collection

	^ collectionWith3Elements! !

!SetTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne)! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!SetTest methodsFor: 'tests - size capacity' stamp: ''!
sizeCollection

	^ full! !

!SetTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!SetTest methodsFor: 'tests - adding uniquely' stamp: ''!
testTAddIfNotPresentWithElementAlreadyIn

	| added oldSize |
	oldSize := self collectionWithElement size.
	self assert: (self collectionWithElement includes: self element).

	added := self collectionWithElement addIfNotPresent: self element.
	
	self assert: added = self element.
	self assert: (self collectionWithElement includes: self element).
	self assert: self collectionWithElement size = oldSize.! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAddForUniquenessTest
	self element.
	self collectionWithElement.
	self assert: (self collectionWithElement includes: self element).
	self collectionWithoutElement.
	self assert: (self collectionWithElement includes: self element)! !

!SetTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!SetTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!SetTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!SetTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllSuchThat

	| el aSubCollection |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := self nonEmptyWithoutEqualElements copyWithout: el.
	self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | aSubCollection includes: each ].
	
	self assert: self nonEmptyWithoutEqualElements size equals: 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each equals: el ]! !

!SetTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString tmp |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	tmp := self nonEmpty collect: [:each | each asString].
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	tmp do:[:each |
		self assert: (tmp occurrencesOf: each) = (allElementsAsString occurrencesOf: each)].
	self assert: ((allElementsAsString at: (allElementsAsString size - 1))=('and'))! !

!SetTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testSize2
	self assert: empty size equals: 0.
	self assert: full size equals: 4.
	empty add: 2.
	empty add: 1.
	full add: 2.
	self assert: empty size equals: 2.
	self assert: full size equals: 4.
	empty remove: 2.
	self assert: empty size equals: 1! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!SetTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!SetTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
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! !

!SetTest methodsFor: 'tests - comparing' stamp: ''!
testMax
	| set |
	set := self empty.
	set add: 1; add: 2.
	self assert: (set max: [ :each | each + 1 ]) equals: 3! !

!SetTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!SetTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter
	
	| result allElementsAsString tmp |
	
	result := String streamContents: [ :aStream |
		tmp := OrderedCollection new.
		self nonEmpty do: [:each | tmp add: each asString].
		self nonEmpty printOn: aStream delimiter: ', ' ].
	
	allElementsAsString := (result findBetweenSubstrings: ', ').
	
	1 to: allElementsAsString size do:
		[:i | 
		self assert: (tmp occurrencesOf:(allElementsAsString at:i)) equals: (allElementsAsString  occurrencesOf:(allElementsAsString at:i)) ].! !

!SetTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementReallyRemovesElement

	| size |
	size := self nonEmptyWithoutEqualElements size.
	self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne.
	self assert: size - 1 equals: self nonEmptyWithoutEqualElements size! !

!SetTest methodsFor: 'tests - growable' stamp: ''!
testAddEmptyGrows
	
	| oldSize |
	oldSize := self empty size.
	self empty add: self element.
	self assert: (self empty size) = (oldSize + 1).! !

!SetTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!SetTest methodsFor: 'tests - sunit original tests' stamp: ''!
testGrow
	empty addAll: (1 to: 100).
	self assert: empty size equals: 100! !

!SetTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
	^ self classToBeTested  with: elementNotIn.! !

!SetTest methodsFor: 'tests - adding uniquely' stamp: ''!
testAddAlreadyThereDoesNotCount

	| added oldSize |
	oldSize := self collectionWithElement size.
	self assert: (self collectionWithElement includes: self element).

	added := self collectionWithElement add: self element.
	
	self assert: added = self element.
	self assert: (self collectionWithElement includes: self element).
	self assert: self collectionWithElement size = oldSize.! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!SetTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printElementsOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	1 to: allElementsAsString size do:
		[:i | 
		self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString  occurrencesOf:(allElementsAsString at:i)).
			].! !

!SetTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithDuplicate


| collection1 collection2 result |
collection1 := self firstCollection .
collection2 := self firstCollection  .
result := collection1 , collection2.

collection1 do:[ :each | self assert: (result includes: each)].
self assert: result size = collection1 size.! !

!SetTest methodsFor: 'tests - sunit original tests' stamp: ''!
testAdd 
	empty add: 5.
	self assert: (empty includes: 5).! !

!SetTest methodsFor: '*Random-Tests' stamp: ''!
testAtRandom
	| rand |
	rand := Random new.
	full add: 3.
	full add: 2.
	full add: 4.
	full add: 1.
	self assert: (full includes: (full atRandom: rand)).
	! !

!SetTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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! !

!SetTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty
	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!SetTest methodsFor: 'tests - with nil' stamp: ''!
testAllowInclusionOfNils
	| set |
	set := self classToBeTested new.
	set add: nil.
	self assert: (set includes: nil).
	set remove: nil.
	self deny: (set includes: nil)! !

!SetTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringOne
	
	self nonEmpty1Element do: 
		[:each | 
		self assert: each asString =self nonEmpty1Element  asCommaString.
		self assert: each asString=self nonEmpty1Element  asCommaStringAnd.].! !

!SetTest methodsFor: 'tests - iterating' stamp: ''!
testCollect
	| res element collection |
	collection := self collectionWithoutNilElements.
	element := self element.
	res := collection collect: [ :each | element ].

	self assert: res class identicalTo: self classToBeTested.
	self assert: res size equals: 1.

	res do: [ :each | self assert: each equals: element ]! !

!SetTest methodsFor: 'tests - copying' stamp: ''!
elementToAdd
	^ 42! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testCopyWithout
	| newFull |
	full add: 3.
	full add: 2.
	newFull := full copyWithout: 3.
	self assert: newFull size equals: full size - 1.
	self deny: (newFull includes: 3).
	self assertEmpty: (newFull select: [ :each | (full includes: each) not ]).
	self assert: (full select: [ :each | (newFull includes: each) not ]) equals: (Set with: 3)! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
testCopyNonEmptyWithoutAllNotIncluded! !

!SetTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	^ elementNotIn! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testAsSet
	"could be moved in Array or Collection"

	| newFull |
	newFull := #(1 2 3) asSet.
	newFull add: 4.
	self assert: newFull equals: full! !

!SetTest methodsFor: 'tests - includes' stamp: ''!
anotherElementNotIn
	^ 42! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testRemoveIfAbsent
		
	self assert: (full remove: 8 ifAbsent: [true]).
	self assert: (full remove: 4 ifAbsent: [false]) isNumber.! !

!SetTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!SetTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!SetTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!SetTest methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!SetTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollect
	self assert: (#(1 2) asSet flatCollect: [ :x | 1 to: 2 * x ]) equals: #(1 2 3 4) asSet.
	self assertEmpty: (#() asSet flatCollect: [ :x | 1 to: 4 ])! !

!SetTest methodsFor: 'requirements' stamp: ''!
integerCollectionWithoutEqualElements
" return a collection of integer without equal elements"
	^ withoutEqualElements! !

!SetTest methodsFor: 'coverage' stamp: ''!
collectionClass
	"Return the class to be used to create instances of the class tested"
	
	^ self classToBeTested! !

!SetTest methodsFor: 'requirements' stamp: ''!
collectionWithElement
	^ full! !

!SetTest methodsFor: 'tests - growable' stamp: ''!
testAddNonEmptyGrowsWhenNewElement
	
	| oldSize |
	oldSize := self nonEmpty size.
	self deny: (self nonEmpty includes: self elementNotInForOccurrences).
	self nonEmpty add: self elementNotInForOccurrences.
	self assert: self nonEmpty size > oldSize! !

!SetTest methodsFor: 'tests - creation' stamp: ''!
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 ) equals: (collection occurrencesOf: element1).
	self assert: (aCol occurrencesOf: element2 ) equals: (collection occurrencesOf: element2)! !

!SetTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!SetTest methodsFor: 'tests - size capacity' stamp: ''!
emptyButAllocatedWith20

	^ emptyButAllocatedWith20! !

!SetTest methodsFor: 'tests - iterate' stamp: ''!
testDoWithoutNoDuplicates
	| res |
	res := self speciesClass new.
	self collection do: [ :each | res add: each ] without: -2.
	self assert: res size equals: self doWithoutNumber! !

!SetTest methodsFor: 'tests - includes' stamp: ''!
elementNotInForOccurrences
	^ 666! !

!SetTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRequirementsOfTGrowableTest
	self empty.
	self nonEmpty.
	self element.
	self elementNotIn.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty.
	self assert: (self nonEmpty includes: self element).
	self deny: (self nonEmpty includes: self elementNotIn)! !

!SetTest methodsFor: 'tests - converting' stamp: ''!
testAsByteArray

	| res |
	self integerCollectionWithoutEqualElements.
	self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ].
	res := true.
	self integerCollectionWithoutEqualElements
		detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! !

!SetTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!SetTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	empty := self classToBeTested  new.
	full := self classToBeTested  with: 1 with: 2 with: 3 with: 4.
	collectionIncluded := self classToBeTested  with: 2 with: 3 .
	collectionWith3Elements := self classToBeTested  new.
	collectionWith3Elements add: 1; add: -2; add: 3. 
	collectResult := self classToBeTested  new add: SmallInteger ; yourself.
	emptyButAllocatedWith20 := self classToBeTested  new: 20.
	elementNotIn := 99.
	collectionOfFloat := self classToBeTested  with: 2.5 with: 4.6 with: 4.2.
	collectionOfNonIdentical := self classToBeTested  with: 'a' with: 'b' with: 'c'.
	nonEmpty1element := self classToBeTested  with: 32.
	withoutEqualElements := self classToBeTested  with: 4 with: 5 with: 2.
	collection5Elements := self classToBeTested with: 1 with: 2 with: 3 with: 4 with: 5.! !

!SetTest methodsFor: 'ambiguous' stamp: ''!
elementNotIn
	^elementNotIn! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTRemoveTest
	| duplicate |
	self empty.
	self nonEmptyWithoutEqualElements.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	duplicate := true.
	self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ].
	self deny: duplicate.
	self elementNotIn.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! !

!SetTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringMore

	| result resultAnd allElementsAsString tmp |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
	tmp :=OrderedCollection new. 
	self nonEmpty do: [ :each | tmp add: each asString].

	"verifying result  :"
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString do:
		[:each |
		self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each).
		].
	
	"verifying esultAnd :"
	allElementsAsString:=(resultAnd findBetweenSubstrings: ', ' ).
	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')].
			].! !

!SetTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result := self firstCollection , self empty.
	self assert: result = self firstCollection! !

!SetTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!SetTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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) ]! !

!SetTest methodsFor: 'tests - creation' stamp: ''!
testWithAll

	| aCol collection |
	collection := self collectionMoreThan5Elements asOrderedCollection.
	aCol := self collectionClass withAll: collection.
	
	collection do: [ :each | self assert: (aCol occurrencesOf: each ) equals: ( collection occurrencesOf: each ) ].
	
	self assert: aCol size equals: collection size! !

!SetTest methodsFor: 'tests - creation' stamp: ''!
testWith
	
	| aCol anElement |
	anElement := self collectionMoreThan5Elements anyOne.
	aCol := self collectionClass with: anElement.
	self assert: (aCol includes: anElement).! !

!SetTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation

| collection1 collection2 result |
collection1 := self firstCollection .
collection2 := self secondCollection .
result := collection1 , collection2.

collection1 do:[ :each | self assert: (result includes: each)].
collection2 do:[ :each | self assert: (result includes: each)].! !

!SetTest methodsFor: 'requirements' stamp: ''!
collectionWithCopyNonIdentical
	" return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)"
	^ collectionOfNonIdentical! !

!SetTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result:=''.
	aStream:= ReadWriteStream on: result.
	self nonEmpty printNameOn: aStream.
	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ]
		ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! !

!SetTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
" return a collection elements that can be sorte ( understanding message ' < '  or ' > ')"
	^collectionOfFloat! !

!SetTest methodsFor: 'tests' stamp: ''!
testRemoveAll
	"Allows one to remove all elements of a collection"

	| c1 c2 s2 |
	c1 := full.
	c2 := c1 copy.
	s2 := c2 size.

	c1 removeAll.

	self assert: c1 size equals: 0.
	self assert: c2 size = s2 description: 'the copy has not been modified'! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!SetTest methodsFor: 'requirements' stamp: ''!
collectionInForIncluding
	^ collectionIncluded! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!SetTest methodsFor: 'tests - sunit original tests' stamp: ''!
testOccurrences
	self assert: (empty occurrencesOf: 0) equals: 0.
	self assert: (full occurrencesOf: 4) equals: 1.
	full add: 4.
	self assert: (full occurrencesOf: 4) equals: 1! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!SetTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!SetTest methodsFor: 'requirements' stamp: ''!
firstCollection
" return a collection that will be the first part of the concatenation"
	^ nonEmpty1element! !

!SetTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExists

	| el res |
	el := self nonEmptyWithoutEqualElements anyOne.
	res := self nonEmptyWithoutEqualElements remove: el.
	self assert: res == el! !

!SetTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!SetTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!SetTest methodsFor: 'tests - adding uniquely' stamp: ''!
testTAddIfNotPresentWithNewElement
	| added oldSize |
	oldSize := self collectionWithoutElement size.
	self deny: (self collectionWithoutElement includes: self element).
	added := self collectionWithoutElement addIfNotPresent: self element.
	self assert: added = self element.
	self assert: (self collectionWithoutElement includes: self element).
	self assert: self collectionWithoutElement size = (oldSize + 1)! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
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)]]! !

!SetTest methodsFor: 'tests - integrity' stamp: ''!
testIsHealthy

	"we use associations as keys on purpose, because they changing
	hash depending on the key"

	| a1 a2 set |
	"There is a probability that nil will hash to 0 in some builds,
	so the nil key will still be in the correct position after
	it is changed to 0. The larger the set's capacity, the lower the
	probability of this failure. Also, the default size of a set
	happens to have the same correct position for 3 and 0."
	set := Set new: 50000.
	[ 
	a1 := 3 -> nil.
	a2 := nil -> 3.
	set
		add: a1;
		add: a2.
	self assert: set isHealthy.
	a1 key: 0.
	a2 key: 0.
	self assert: set isHealthy not ] ensure: [ set removeAll ]! !

!SetTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!SetTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
	^ collectionIncluded! !

!SetTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllError
	| el aSubCollection |
	el := self elementNotIn.
	aSubCollection := self nonEmptyWithoutEqualElements copyWith: el.

	self should: [ self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! !

!SetTest methodsFor: 'tests - sunit original tests' stamp: ''!
testRemove
	full remove: 4.
	self assert: (full includes: 3).
	self deny: (full includes: 4).! !

!SetTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan5Elements
" return a collection including at least 5 elements"
	
	^ collection5Elements! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testCopy
	| newFull |
	full add: 3.
	full add: 2.
	newFull := full copy.
	self assert: full size equals: newFull size.
	self assertEmpty: (full select: [ :each | (newFull includes: each) not ]).
	self assertEmpty: (newFull select: [ :each | (full includes: each) not ])! !

!SetTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn
	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	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)).].	
			].! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testIntersection
	| newFull col |
	full
		add: 3;
		add: 2.
	col := full intersection: full.
	self assert: full equals: col.

	newFull := Set with: 8 with: 9 with: #z.
	col := newFull intersection: full.
	self assertEmpty: col.

	newFull
		add: 5;
		add: #abc;
		add: 7.
	col := newFull intersection: full.
	self assert: (full select: [ :each | newFull includes: each ]) equals: col! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testDo2
	| newFull result |
	newFull := Set withAll: (1 to: 5).
	result := 0.
	newFull do: [ :each | result := result + each ].
	self assert: result equals: 15! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeWithIdentityTest

	| anElement |
	self collectionWithCopyNonIdentical.
	anElement := self collectionWithCopyNonIdentical anyOne.
	self deny: anElement == anElement copy! !

!SetTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!SetTest methodsFor: 'tests - iterate' stamp: ''!
selectedNumber

	^ 2! !

!SetTest methodsFor: 'requirements' stamp: ''!
secondCollection
" return a collection that will be the second part of the concatenation"
	^ collectionWith3Elements! !

!SetTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self collection  anyOne! !

!SetTest methodsFor: 'tests - empty' stamp: ''!
nonEmpty
	
	^ full! !

!SetTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	difference := self collectionWithoutEqualElements difference: self empty.
	self assert: difference size = self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each) ]! !

!SetTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithoutEqualElements
" return a collection without equal elements "
	^ withoutEqualElements! !

!SetTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllFoundIn

	| el aSubCollection   |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn.
	self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection.
	
	self assert: self nonEmptyWithoutEqualElements size equals: 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each equals: el ]! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
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 ]! !

!SetTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	^ collectionWith3Elements! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testCollect2
	| newFull result |
	newFull := Set withAll: (1 to: 10).
	result := newFull collect: [ :each | each >= 1 ifTrue: [ each ] ifFalse: [ 'no' ] ].
	self assert: result equals: newFull.
	result := newFull collect: [ :each | each >= 5 ifTrue: [ each ] ifFalse: [ 'no' ] ].
	self
		assert: result
		equals:
			((Set withAll: (5 to: 10))
				add: 'no';
				yourself)! !

!SetTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ' ).
	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))].
			].! !

!SetTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!SetTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''.! !

!SetTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ Set! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testUnion
	| newFull col newCol |
	full add: 3.
	full add: 2.
	col := full union: full.
	self assert: full equals: col.

	newFull := Set with: 8 with: 9 with: #z.
	col := newFull union: full.
	self assert: col size equals: full size + newFull size.
	self assert: (col select: [ :each | (full includes: each) not ]) equals: newFull.
	self assert: (col select: [ :each | (newFull includes: each) not ]) equals: full.

	full add: 9.
	col := newFull union: full.
	newCol := newFull copy.
	newCol remove: 9.
	self assert: col size equals: full size + newFull size - 1.
	self assert: (col select: [ :each | (full includes: each) not ]) equals: newCol.
	newCol := full copy.
	newCol remove: 9.
	self assert: (col select: [ :each | (newFull includes: each) not ]) equals: newCol! !

!SetTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!SetTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result allElementsAsString tmp |
	
	
	delim := ', '.
	result:=''.
	tmp:= self nonEmpty collect:[:each | each asString].
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	allElementsAsString := (result findBetweenSubstrings: delim ).
	tmp do:
		[:each |
		self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each).
		].! !

!SetTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty
	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!SetTest methodsFor: 'tests - adding uniquely' stamp: ''!
testAddNewElementIncrementsSize
	| added oldSize |
	oldSize := self collectionWithoutElement size.
	self deny: (self collectionWithoutElement includes: self element).
	added := self collectionWithoutElement add: self element.
	self assert: added = self element.
	self assert: (self collectionWithoutElement includes: self element).
	self assert: self collectionWithoutElement size = (oldSize + 1)! !

!SetTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!SetTest methodsFor: 'tests - iterate' stamp: ''!
expectedSizeAfterReject
	^1! !

!SetTest methodsFor: 'requirements' stamp: ''!
collectionWithoutElement
	" return a collection that does not include 'element' "
	^ collectionWith3Elements! !

!SetTest methodsFor: 'requirements' stamp: ''!
result

	 ^ collectResult! !

!SetTest methodsFor: 'tests - empty' stamp: ''!
empty
	
	^ empty! !

!SetTest methodsFor: 'requirements' stamp: ''!
element
	^ 4! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!SetTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |
	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream  do:
		[:each1 |
		self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ]
		 ].! !

!SetTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty
	| result |
	result := self empty occurrencesOf: self collectionWithoutEqualElements anyOne.
	self assert: result equals: 0! !

!SetTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	self deny: (self nonEmpty includesAny: self empty).
	self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }).
	self assert: (self nonEmpty includesAny: self nonEmpty)! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testLike
	self assert: (full like: 3) equals: 3.
	self assert: (full like: 8) isNil! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCreationWithTest

	self collectionMoreThan5Elements.
	self assert: self collectionMoreThan5Elements size >= 5! !

!SetTest methodsFor: 'requirements' stamp: ''!
elementInForIncludesTest
" return an element included in nonEmpty "
	^ self nonEmpty anyOne! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConcatenationTest
	self firstCollection.
	self denyEmpty: self firstCollection.
	self firstCollection.
	self denyEmpty: self firstCollection.
	self empty.
	self assertEmpty: self empty! !

!SetTest methodsFor: 'tests - integrity' stamp: ''!
testSetWithNilItemsIsHealthy
	self classToBeTested = Set
		ifFalse: [ ^ self	"only works on Dictionary" ].
	self assert: {nil} asSet isHealthy! !

!SetTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementFromEmpty

	self 
		should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ]
		raise: Error! !

!SetTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
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) ]! !

!SetTest methodsFor: 'tests - sunit original tests' stamp: ''!
testIllegal
	self should: [empty at: 5] raise: self defaultTestError.
	self should: [empty at: 5 put: #abc] raise: self defaultTestError.! !

!SetTest methodsFor: 'tests - comparing' stamp: ''!
testMaxIfNil
	| emptySet |
	emptySet := self empty.
	self assert: (emptySet max: [ :each | each + 1 ]) equals: nil! !

!SetTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!SetTest methodsFor: 'tests - sunit original tests' stamp: ''!
testIncludes
	self assert: (full includes: 4).
	self assert: (full includes: 3).
	self deny: (full includes: 6).! !

!SetTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
" return a collection of size 1 including one element"
	^ nonEmpty1element! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
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) ] ]! !

!SetTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOf
	| collection |
	collection := self collectionWithoutEqualElements .
	
	collection do: [ :each | self assert: (collection occurrencesOf: each) equals: 1 ]! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!SetTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!SetTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!SetTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollectAsSet
	self assert: (#(1 2) asSet flatCollect: [ :x | 1 to: 2 * x ]) equals: #(1 2 3 4) asSet! !

!SetTest methodsFor: 'tests - iterate' stamp: ''!
speciesClass
	
	^ Set! !

!SetTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsNotThere
	
	self deny: (self nonEmpty includes: self elementNotInForOccurrences).
	self assert: (self nonEmpty includes: self nonEmpty anyOne).
	self deny: (self empty includes: self elementNotInForOccurrences)! !

!SetTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludes
	" test the comportement in presence of elements 'includes' but not 'identityIncludes' "

	" can not be used by collections that can't include elements for wich copy doesn't return another instance "

	| collection element |
	self collectionWithCopyNonIdentical.
	collection := self collectionWithCopyNonIdentical.
	element := collection anyOne copy.	"self assert: (collection includes: element)."
	self deny: (collection identityIncludes: element)! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest
	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!SetTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!SetTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	 
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!SetTest methodsFor: 'tests - some' stamp: ''!
testAddWithOccurrences
	empty add: 2 withOccurrences: 3.
	self assert: (empty includes: 2).
	self assert: (empty occurrencesOf: 2) equals: 1! !

!SetTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
" return a collection without equal elements"
	^ withoutEqualElements! !

!SetTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!SetTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |

	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream  do:
		[:each1 |
		self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ]
		 ].! !

!SettingBrowser commentStamp: ''!
<help>

!! The User interface
A SettingBrowser allows the browsing as well as the editing of setting values.
For each setting, a label and an input widget allowing the change of the setting value are shown.

!!!! Browsing standards settings
In order to open a setting browser one can also use the expression below:
--------------------
SettingBrowser open
--------------------
It opens a SettingBrowser for all settings declared with the standard 'systemsettings' pragma keyword. 
To see how these settings are declared in the image, you can browse all senders of #systemsettings:
--------------
SystemNavigation new  browseAllSendersOf: #systemsettings
--------------

!!!! Browsing application specific settings
For specific applications, other pragma keywords can be used. These keywords can be passed as follow:
--------------------
(SettingBrowser forKeywords: #('blob')) open.
--------------------
Then, only settings which are declared with the keyword 'blob' are viewed. 
Here is an example of such a setting declared in the class side of a class BlobSettings 
--------------------
BlobSettings class>>blobSettingOn: aBuilder
	<blob>
	(aBuilder group: #blobEditing) 
		label: 'Editing' translated;
		parent: #blobBrowsing; 
		description: 'All settings concerned with blob editing' translated;
		with: [	
			(aBuilder setting: #color)	...
--------------------
The expression 'SettingBrowser open' is then equivalent to the '(SettingBrowser forKeywords: #('systemsettings')) open' expression.

!!!! Filtering
The SettingBrowser has a filtering functionality to limitate the number of settings. You can enter a token in the input field of the toolbar in order to show only settings that are matching the token.
Two filtering modes are allowed:  with a substring or with a regular expression.
- with a substring: only settings which name, description, pragma class or method selector includes this substring are viewed; 
- with a regular expression: the same as with a substring except that the input is used as a regular expression. This filtering is applied if the Regexp checkbox is checked.

!! How to declare a setting
A setting is declared with a method class side. This kind of method takes a builder as argument and a standard setting is tagged with the <systemsettings> pragma. The builder argument serves as a facade for the declaration.

!!!!A simple boolean setting example

Let's start with a setting declaration example:
CodeHolderSystemSettings class>>caseSensitiveFindsSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #caseSensitiveFinds) 
		label: 'Case sensitive search' translated;
		description: 'If true, then the "find" command in text will always make its searches in a case-sensitive fashion' translated;
		setSelector: #caseSensitiveFinds:;
		getSelector: #caseSensitiveFinds;
		target: TextEditor;
		parent: #codeEditing.

For this setting to be declared, we make the assumption that we have TextEditor class>>caseSensitiveFinds and TextEditor class>>caseSensitiveFinds: methods in order to change the preference value. 
To declare a setting, just send #setting: to the builder with its identifier, a Symbol passed as argument. It creates a setting node. Then you can set the label, the description with #label: and #description sent to the newly created setting node. You also have to set the selectors for setting and getting the preference value as well as the target to which these accessors are sent  (often a class). This is done by sending respectively, #setSelector:, #getSelector: and #target: to the setting node.
Because all settings are organized in trees we need a way to indicate what is the position of the setting node in the overall setting trees list. In fact it can be done two ways. The first way is to use the #parent: message (A second possibility is to declare a subtree in one method, it is explained later in this documentation).The #parent: message is send for non root settings. #parent takes the identifier of the parent setting as argument.

You may notice that in this example,  if we don't take into account the $: at the end of the setting accessor, the getting and the setting accessors are the same. This is often the case. You can simply set the setter and the getter by sending the #selector: message to the setting node. Thus the declaration is simplified as follow:
CodeHolderSystemSettings class>>caseSensitiveFindsSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #caseSensitiveFinds) 
		label: 'Case sensitive search' translated;
		description: 'If true, then the "find" command in text will always make its searches in a case-sensitive fashion' translated;
		selector: #caseSensitiveFinds;
		target: TextEditor;
		parent: #codeEditing.

You may also notice that the identifier of the setting is then the same as the selector. In this case, you can omit to set the selector because by default, the identifier is used as the selector for getting the preference value and the identifier concatenated with a $: at the end is used as the setting selector. Thus the declaration is simplified again as follow:
CodeHolderSystemSettings class>>caseSensitiveFindsSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #caseSensitiveFinds) 
		label: 'Case sensitive search' translated;
		description: 'If true, then the "find" command in text will always make its searches in a case-sensitive fashion' translated;
		target: TextEditor;
		parent: #codeEditing.

Finally, if you decide to declare a setting directly in the class which implements the selector, the target information can be also omitted because the class in which the setting is declared is used by default. Thus the simplest declaration can be:
TextEditor class>>caseSensitiveFindsSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #caseSensitiveFinds) 
		label: 'Case sensitive search' translated;
		description: 'If true, then the "find" command in text will always make its searches in a case-sensitive fashion' translated;
		parent: #codeEditing.

!!!!Declaring a subtree in one single method
Directly declaring a sub-tree of settings in one method is also possible. Then, typically, a root group is declared for the application settings and the children settings themselves are also declared within the same method as in the example below in which #formatCommentWithStatements and #indentString are directly declared as children of the #configurableFormatter setting:

RBConfigurableFormatter class>>settingsOn: aBuilder
	<systemsettings>	
	(aBuilder group: #configurableFormatter)
		target: self;
		parent: #refactoring;
		label: 'Configurable Formatter' translated;
		description: 'Settings related to the formatter' translated;
		with: [
			(aBuilder setting: #formatCommentWithStatements)
				label: 'Format comment with statements' translated.
			(aBuilder setting: #indentString)
				label: 'Indent string' translated]

!!!!Optional setting
Any setting can have children. In the case where a boolean setting is used as a parent, then, its children are chown only if the parent preference value is true.

!!!!Range setting
You send the #range: message to the builder instead of the #setting: message. In addition, you send the #range: message to the setting with an interval as argument in order to indicate the valid range.
screenMarginSettingOn: aBuilder
	<systemsettings>
	(aBuilder range: #fullscreenMargin)
		target: SystemWindow;
		parent: #windows;
		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).

!!!!List setting
For this kind of setting, the SettingBrowser will show a drop list. Here is an example for the window position strategy. Notice that the setting is declared by sending the #pickOne message to the builder. Notice also that the list of valid values are given by sending the #domainValues: message to the setting. The argument is an array of association. Each association key is the label that is shown and the corresponding association value gives the value that will be assigned to the preference.
windowPositionStrategySettingsOn: aBuilder
	<systemsettings>
	(aBuilder pickOne: #usedStrategy) 
		label: 'Window position strategy' translated;
		target: RealEstateAgent;
		domainValues: {
			'Reverse Stagger' translated -> #staggerFor:initialExtent:world:. 
			'Cascade' translated -> #cascadeFor:initialExtent:world:. 
			'Standard' translated -> #standardFor:initialExtent:world:};

!!!!Launcher
A launcher is a particular setting. It allows to launch a script directly from the setting browser. Imagine that you have changed some settings and that you need to evaluate a script in order to update some other objects. It can be used also to configurate globally a package of the entire image.
As an example, in order to use True Type Fonts, the system must be updated by collecting all the available TT fonts. This can be done by evaluating the following expression:
-------------
FreeTypeFontProvider current updateFromSystem
-------------
In order to be able to launch this script from the setting browser, you have to declare a launcher. For example, look-at how the script for the TT fonts is declared in GraphicFontSettings class >> #standardFontsSettingsOn:.

GraphicFontSettings class >> #standardFontsSettingsOn:
	<systemsettings>
	(aBuilder group: #standardFonts)
		...
		(aBuilder launcher: #updateFromSystem)
				order: 1; 
				target: FreeTypeFontProvider;
				targetSelector: #current;
				description: 'Update available fonts by scanning the current system';
				script: #updateFromSystem;
				label: 'Update fonts from system' translated.

Notice that you send #launcher: to the builder in order to create the setting node, then you send #script: to the created node with the selector of the script passed as argument.
</help>

Implementation details
See also SettingNode, SettingTree, SettingNodeBuilder and SettingTreeBuilder classes.

Instance Variables
	roots:		<Collection of SettingTreeNode>
	searchedText:		<String>
	status:		<WriteStream>
	collector:		<SettingCollector>

roots
	- the roots of the viewed setting trees

searchedText
	- the string used as a filter token or regexp in order to select viewed settings

status
	- a WriteStream used in order to store useful information which are shown when no current item is selected

collector
	- The SettingCollector which has the responsibility to collect settings and to build viewed trees
!
!SettingBrowser methodsFor: 'accessing' stamp: ''!
treeHolder
	^ treeHolder
		ifNil: [treeHolder := self newTreeHolder whenChangedSend: #treeChanged: to: self; yourself]! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
searchedText
	^ searchedText ifNil: [searchedText := '']! !

!SettingBrowser methodsFor: 'menu' stamp: ''!
loadSettings
	self treeHolder updateSettingNodes.
	self inform: 'Settings has been updated from the disk.'! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
changePackageSet: aSet
	"
	This method allow for restricting the settings displayed in the browser. 
	Opening a setting browser display all the setting. 
	SettingBrowser new changePackageSet: { (RPackageOrganizer default packageNamed: 'GT-Playground') }; open
	"
	aSet ~= self viewedPackages
		ifTrue: [self viewedPackages: aSet.
			self applyFilters].
	^ true! !

!SettingBrowser methodsFor: 'menu' stamp: ''!
doubleClick
	self selectedNode ifNotNil: [:node | node browseDeclaration]! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
helpMenuIn: aWindow
	| helpMenu |
	helpMenu := aWindow newMenu.
	helpMenu
		addToggle: 'About' translated
		target: self
		selector: #about.
	helpMenu lastItem font: aWindow theme menuFont.
	helpMenu
		addToggle: 'Declaring and managing settings' translated
		target: self
		selector: #helpDeclaringAndManagingSettings.
	helpMenu lastItem font: aWindow theme menuFont.
	^ helpMenu
! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
toolBarIn: aMorph 
	| toolBar |
	toolBar := aMorph newToolbar: {
	aMorph
		newButtonFor: self
		getState: nil
		action: #expandAll
		arguments: nil
		getEnabled: nil
		label: 'Expand all' translated
		help: 'Expand all tree nodes' translated.
	aMorph newToolSpacer.
	aMorph newToolSpacer.
	aMorph newLabel: 'Search for: ' translated.
	(SearchMorph
				on: self
				list: #searchedTextList
				selected: #searchedText
				changeSelected: #changeSearchedText:
				useIndex: false 
				addToList: #addToSearchedTextList:
				class: String
				getEnabled: nil) hResizing: #spaceFill; 
				ghostText: 'Hit return to accept' translated.
	aMorph
			newCheckboxFor: self
			getSelected: #regexpSearch
			setSelected: #regexpSearch:
			getEnabled: nil
			label: 'Regexp' 
			help: 'Filter according to a regular expression' translated.
	aMorph newToolSpacer.	
	aMorph newToolSpacer.
	(aMorph
				newButtonFor: self
				getState: nil
				action: #choosePackagesIn:
				arguments: {aMorph}
				getEnabled: nil
				label: 'Choose packages' translated 
				help: 'Per default, SettingBrowser shows all the setting of the system. You can restrict what is displayed to some packages that contains setting definitions.' translated).
	(aMorph
				newButtonFor: self
				getState: nil
				action: #storeSettings
				arguments: nil
				getEnabled: nil
				label: 'Store Settings' translated 
				help: 'Store the current settings' translated).
	(aMorph
				newButtonFor: self
				getState: nil
				action: #loadSettings
				arguments: nil
				getEnabled: nil
				label: 'Load Settings' translated 
				help: 'Load the current settings from the disk' translated).
	aMorph newToolSpacer}.
	^ toolBar! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
newTreeHolder
	^ SettingTree new  acceptableKeywords: self settingsKeywords! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
getViewedPackageNames
	^ Text
		streamContents: [:s | self viewedPackages
				ifEmpty: [s nextPutAll: 'All packages' translated]
				ifNotEmpty: [:selections | 
					(selections asSet = self allPackagesWithSettings asSet)
						ifTrue: [s nextPutAll: 'All packages']
						ifFalse: [selections
								do: [:package | 
									s nextPutAll: package packageName.
									s nextPut: Character space]]]]! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
applyFilters
	roots := nil.
	self searchedText
		ifNotEmpty: [self updateAccordingTo: self textFilter].
	self viewedPackages
		ifNotEmpty: [ | filter |
			filter := SettingPackageFilter new
			packages: self viewedPackages.
			self updateAccordingTo: filter].
	self updateList
! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
helpDeclaringAndManagingSettings
	"Open up a workspace with explanatory info in it about the Setting Browser"
	UIManager default edit: 'To be documented here later' label: 'Declaring and managing settings' translated. 
	! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
status
	^ status ifNil: [status := String new writeStream]! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
selection: aSelectionHolder
	super selection: aSelectionHolder.
	self setDescription: ''.
	self changed: #getDescription
! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
textFilter
	^ self regexpSearch
		ifFalse: [SettingTokenFilter new token: self searchedText]
		ifTrue: [SettingRegexpFilter new regexp: self searchedText] ! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
acceptableKeywords: aCollectionOfRegExps 
	self treeHolder acceptableKeywords: aCollectionOfRegExps ! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
isRendered
	^ self dependents anySatisfy: [ :dependent | dependent isSystemWindow and: [ dependent owner isNotNil ] ]! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
addToStatus: aText 
	self status nextPutAll: aText.
! !

!SettingBrowser methodsFor: 'menu' stamp: ''!
setAllToDefault
	(self confirm: 'Set all to default value?' translated) ifTrue: [
		self treeHolder nodeList do: [:node | node item hasDefault ifTrue: [node item setToDefault]].
		self updateList]! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
initialExtent
	^ self class initialExtent! !

!SettingBrowser methodsFor: 'export' stamp: ''!
exportSettings: aCollection toFileNamed: filename
	StartupPreferencesLoader default addAtStartupInPreferenceVersionFolder: aCollection named: filename! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
updateStatusWith: aMessage
	self addToStatus: aMessage.
	self addToStatus: Character cr.
! !

!SettingBrowser methodsFor: 'export' stamp: ''!
exportAllSettings: actions by: groupSize withBasename: aString
	"Export all settings in files. No more than groupSize settings will be exported to the same file. If there are more than groupSize settings, settings will be exported in multiple files (named aString%d.st, with %d a number increasing from 1 to (actions size / groupSize)."
	| index |
	index := 1.
	actions
		groupsOf: groupSize
		atATimeDo: [ :setting | 
			self exportSettings: setting toFileNamed: aString , index printString , '.st'.
			index := index + 1 ].
	self
		exportSettings: (actions last: (actions size rem: groupSize))
		toFileNamed: aString , index printString , '.st'! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
settingValueChanged: aSetting 
	aSetting realValue = true
		ifTrue: [self openPathFrom: aSetting].
	aSetting realValue = false
		ifTrue: [self closePathFrom: aSetting].
	aSetting changed: #realValue.
	aSetting changed: #fontButtonLabel.
	aSetting changed: #index.
	aSetting changed: #content ! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
regexpSearch: aBoolean
	self class regexpSearch: aBoolean.
! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
regexpSearch
	^ self class regexpSearch! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
closePathFrom: aSetting
	(self settingNodeOfDeclaration: aSetting)
		ifNotNil: [ :node | self requestView: (MorphTreeChangeRequest collapseNodePath: (node path collect: [ :n | n withoutListWrapper ])) ]! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
buildWindowIn: aWindow 
	| statusView toolBar treeMorph toolBarY gap packageListView statusViewHeight |
	treeMorph := self treeMorphIn: aWindow.
	statusView := self statusViewIn: aWindow.
	statusViewHeight := 100.
	toolBar := self toolBarIn: aWindow.
	gap := 1.
	packageListView := self packageListViewIn: aWindow.
	toolBarY := toolBar minExtent y + gap.
	aWindow 
		addMorph: toolBar
		fullFrame: ((0 @ 0 corner: 1 @ 0) asLayoutFrame 
						topOffset: gap;
						bottomOffset: toolBarY + gap).
	aWindow 
		addMorph: treeMorph
		fullFrame: ((0 @ 0 corner: 1 @ 0.99) asLayoutFrame 
				topOffset: toolBarY + gap + gap;
				bottomOffset: statusViewHeight negated).
	aWindow 
		addMorph: statusView
		fullFrame: ((0 @ 0.99 corner: 0.75 @ 1) asLayoutFrame 
				topOffset: statusViewHeight negated).
	aWindow 
		addMorph: packageListView
		fullFrame: ((0.75 @ 0.99 corner: 1 @ 1) asLayoutFrame 
				topOffset: statusViewHeight negated).
	^ aWindow! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
settingsKeywords 
	^ self class settingsKeywords! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
viewedPackages: aCollectionOfPackagesOrNil
	viewedPackages := aCollectionOfPackagesOrNil! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
open
	
	Cursor wait
		showWhile: [ | window |window := StandardWindow new model: self.
			window title: self windowTitle.
			self buildWindowIn: window.
			window themeChanged.
			window openInWorld.
			(window findDeeplyA: self treeMorphClass)  takeKeyboardFocus. 
			^ window]! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
viewedLabelOfSetting: aSettingDeclaration 
	| node |
	node := self settingNodeOfDeclaration: aSettingDeclaration.
	^ node 
		ifNil: [aSettingDeclaration label]
		ifNotNil: [(node allChildren notEmpty and: [aSettingDeclaration hasValue])
				ifTrue: [aSettingDeclaration label, '...'] 
				ifFalse: [aSettingDeclaration label]]! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
packageListViewIn: aWindow
	^ aWindow
				newTextEditorFor: self
				getText: #getViewedPackageNames
				setText: #setViewedPackageNames:.
! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
changeSearchedText: aString 
	self searchedText: aString.
	self applyFilters.
	^ true ! !

!SettingBrowser methodsFor: 'menu' stamp: ''!
storeSettings
	self treeHolder storeSettingNodes.
	self inform: 'Settings has been stored on the disk.'! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
updateAccordingTo: aFilter
	self selection: nil.
	self setDescription: ''.
	roots := nil.
	self updateList.
	[
	self rootNodes do: [:r | r updateAccordingTo: aFilter].
	self rootNodes removeAllSuchThat: [:n | (aFilter keepSettingTreeNode: n) not and: [n isEmpty]].
	]
		on: RegexSyntaxError
		do: [:ex | 
			self setDescription: 'Regular expression syntax error, see `documentation'' protocol of RxParser class for user''s guide'].
	self expandAll! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
addToSearchedTextList: aString
	(self searchedTextList includes: aString) 
		ifFalse: [self searchedTextList size > 5 ifTrue: [self searchedTextList removeFirst].
		self searchedTextList add: aString]! !

!SettingBrowser methodsFor: 'menu' stamp: ''!
menuSetToDefault: aTreeNode
	| v |
	(v := aTreeNode settingDeclaration) hasDefault
		ifTrue: [(self confirm: 'Set to default value ?' translated)
				ifTrue: [v setToDefault. self updateList]]! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
statusViewIn: aMorph
	| statusView |
	statusView := aMorph
				newTextEditorFor: self
				getText: #getDescription
				setText: #setDescription:.
	^ statusView
 ! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
allPackagesWithSettings
	^( self treeHolder nodeList collect: [:n | n receiverPackage]) asSet! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
viewedPackages
	^ viewedPackages
		ifNil: [viewedPackages := Set new]! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
treeChanged: anAnnounce
	roots := nil.
	self selection: nil.
	self updateList! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
settingNodeOfDeclaration: aSettingDeclaration
	^ self treeHolder deeplyDetect: [:n | n settingDeclaration = aSettingDeclaration]! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
treeMorphIn: aMorph 
	| treeMorph |
	treeMorph := (self treeMorphClass on: self)
		getMenuSelector: #menu:shifted:;
		keyDownActionSelector: #keyDown:from:;
		columns: {
			MorphTreeColumn new startWidth: 300; rowMorphGetSelector: #labelMorphFor:; yourself.
			MorphTreeColumn new rowMorphGetSelector: #inputMorphFor:;yourself
		};
		doubleClickSelector: #doubleClick;
		rowInset: 6;
		columnInset: 6;
		rowColorForEven: self theme lightBackgroundColor;
		yourself.
	^ treeMorph buildContents! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
getDescription
	^ (self selectedNode)
		ifNil: [self status contents ifEmpty: ['Hit return in text fields to accept the input' translated]]
		ifNotNil: [:sel | (Text string: sel item label attribute: TextEmphasis bold), String cr, sel item description]! !

!SettingBrowser methodsFor: 'export' stamp: ''!
exportSettings
	| title nodes actions   |
	
	nodes := self treeHolder nodeList.
	title := 'Exporting settings'.
	title
		displayProgressFrom: 1 
		to: nodes size 
		during: [:bar | actions := nodes collectWithIndex: [:e :i | 
											bar current: i.
											bar label: (String streamContents: [:s | 
															s << title << ' (' << (e item label) << ')']).
											e item exportSettingAction ]].
		
	actions := actions reject: [:e | e isNil ].
	self exportAllSettings: actions by: 50 withBasename: 'exported_settings'.! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
searchedText: aString
	searchedText := aString.
! !

!SettingBrowser methodsFor: 'menu' stamp: ''!
about
	self inform: 'Here you can browse, query and change all system settings' translated! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
setDescription: aText 
	self status reset.
	self addToStatus: aText.
	self changed: #getDescription! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
openPathFrom: aSetting
	(self settingNodeOfDeclaration: aSetting) ifNotNil: [:node |
		self expandNodePath: node path]! !

!SettingBrowser methodsFor: 'menu' stamp: ''!
menu: menu shifted: b 
	"Set up the menu to apply to the receiver's, 
	honoring the #shifted boolean"
	menu
		add: 'Expand all (a)' 
		target: self
		selector: #expandAll. 
	menu
		add: 'Collapse all (A)' 
		target: self 
		selector: #collapseAll.
	self selectedNode
		ifNotNil: [:current | 
			menu
				add: 'Expand all from here' 
				target: self
				selector: #expandAllFromNode:
				argument: current.
			menu addLine.
			current menu: menu shifted: b].
	self selectedNode
		ifNotNil: [:current |
			current settingDeclaration hasDefault
				ifTrue: [
					menu addLine.
					menu
						add: 'Set to default (d)' 
						target: self
						selector: #menuSetToDefault:
						argument: current].
			current settingDeclaration hasEditableList
				ifTrue: [
					current settingDeclaration hasDefault
						ifFalse: [  menu addLine ].
					menu
						add: 'Empty list (e)' 
						target: self
						selector: #menuEmptyList:
						argument: current]].
	^ menu! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
searchedTextList
	^ self class searchedTextList! !

!SettingBrowser methodsFor: 'menu' stamp: ''!
menuEmptyList: aTreeNode
	| v |
	(v := aTreeNode settingDeclaration) hasEditableList 
		ifTrue: [v emptyList. self updateList]! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
pragmaErrorOccured: aPragmaError
	self setDescription: aPragmaError message, String cr! !

!SettingBrowser methodsFor: 'menu' stamp: ''!
keyDown: anEvent from: aTreeMorph
	| c |
	c := anEvent keyCharacter.
	c = $a
		ifTrue: [^ self expandAll].
	c = $A
		ifTrue: [^ self collapseAll]. 
	self selectedNode
		ifNotNil: [:current | current keyDown: anEvent from: aTreeMorph.
			current settingDeclaration hasDefault
				ifTrue: [c = $d
						ifTrue: [^ self menuSetToDefault: current]].
			current settingDeclaration hasEditableList
				ifTrue: [c = $e
						ifTrue: [^ self menuEmptyList: current]]]! !

!SettingBrowser methodsFor: 'initialization' stamp: ''!
release
	treeHolder release.
	treeHolder := nil.
	roots := nil.
	status := nil.
	searchedText := nil.
	viewedPackages := nil.
	super release.! !

!SettingBrowser methodsFor: 'accessing' stamp: ''!
rootNodes
	^ roots ifNil: [roots := self treeHolder settingTreeRoots]
! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
windowTitle
	^ 'Settings Browser'! !

!SettingBrowser methodsFor: 'updating' stamp: ''!
updateList
	self isRendered ifTrue: [
		self treeHolder updateList.
		self changed: #getDescription.
		self changed: #getViewedPackageNames.
		super updateList].	
! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
setViewedPackageNames: aText 
	| allViewed |
	allViewed := Set new.
	aText asString substrings
		do: [:sub | (RPackageOrganizer default
						packageNamed: sub
						ifAbsent: [])
				ifNotNil: [:pkg | allViewed add: pkg]].
	self changePackageSet: allViewed.
	self changed: #getViewedPackageNames
! !

!SettingBrowser methodsFor: 'user interface' stamp: ''!
choosePackagesIn: aWindow 
	"Method called when one presses the 'Choose packages' buttong.
	This button restrict the set of setting to be considered. By selecting one or more packages, only the setting of these packages are displayed."
	| result list |
	list := MorphTreeModel new
				beCheckList;
				autoMultiSelection: true;
				rootItems: (self allPackagesWithSettings asArray sort: [:a :b | a packageName < b packageName]);
				 wrapBlockOrSelector: #packageName.
	result := list openDialogWindowIn: aWindow title: 'Choose packages' selectedtems: self viewedPackages.
	result ifNotNil: [self changePackageSet: result]! !

!SettingBrowser class methodsFor: 'opening' stamp: ''!
browse: aCollectionOfKeywords
	"open a SettingBrowser view which is able to browse all settings 
	that are declared with a pragma keyword which is at least
	one of the string contained in aCollectionOfKeywords
	example:
	(SettingBrowser browse: #('systemsettings'))
	browse all settings which make use of the pragma keyword 'systemsettings'
	
	Note that the default setting pragma keyword is 'systemsettings'
	"
	(self forKeywords: aCollectionOfKeywords) open! !

!SettingBrowser class methodsFor: 'private helpers' stamp: ''!
viewAllSettings
	"self viewAllSettings"
	Smalltalk tools workspace openContents: self allSettingsState label: 'Current Setting assignments' 
! !

!SettingBrowser class methodsFor: 'accessing' stamp: ''!
initialExtent
	"Initial extent of the SettingBrowser window"
	^ 900@600
		! !

!SettingBrowser class methodsFor: 'accessing' stamp: ''!
settingsKeywords 
	^ (Pragma allNamed: #settingPragmaProcessor) collect: [:p | p method selector]
! !

!SettingBrowser class methodsFor: 'private helpers' stamp: ''!
currentTree
	^ SettingTree new acceptableKeywords: self settingsKeywords! !

!SettingBrowser class methodsFor: 'opening' stamp: ''!
open
	"Open a SettingBrowser view"
	^ self new open! !

!SettingBrowser class methodsFor: 'icons' stamp: ''!
taskbarIconName
	^#smallConfigurationIcon! !

!SettingBrowser class methodsFor: 'private helpers' stamp: ''!
currentNodeList
	^ self currentTree nodeList! !

!SettingBrowser class methodsFor: 'accessing' stamp: ''!
searchedTextList
	"Keep a list of previously entered filtering tokens"
	^ searchedTextList ifNil: [searchedTextList := OrderedCollection new]! !

!SettingBrowser class methodsFor: 'accessing' stamp: ''!
regexpSearch: aBoolean
	"Set to true if the regexp filtering is to be used"

	regexpSearch := aBoolean! !

!SettingBrowser class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #Settings)
		parent: #Pharo;
		order: 1;
		iconName: #smallConfigurationIcon;
		action: [ SettingBrowser open ];
		keyText: 'o, s';
		help: 'Opens a SystemSettingBrowser which allows you to alter many system settings.';
		withSeparatorAfter! !

!SettingBrowser class methodsFor: 'accessing' stamp: ''!
regexpSearch
	"Is the regexp filtering used"
	^ regexpSearch ifNil: [regexpSearch := false]! !

!SettingBrowser class methodsFor: 'private helpers' stamp: ''!
allSettingsState
	"
	Workspace openContents: self allSettingsState label: 'Current Setting assignments' 
	"
	| declList |
	declList := (self currentNodeList select: [ :node | node item hasValue])
		collect: [ :node | node item ].
	^ String streamContents: [:s | declList do: [:d | d settingStoreOn: s] ]! !

!SettingBrowser class methodsFor: 'opening' stamp: ''!
forKeywords: aCollectionOfKeywords
	"create a new SettingBrowser initialized with a set of pragma keywords"
	^ self new acceptableKeywords: aCollectionOfKeywords! !

!SettingBrowser class methodsFor: 'updating' stamp: ''!
refreshAllSettingBrowsers
	self allSubInstances do: [:sb | sb updateList]! !

!SettingBrowser class methodsFor: 'help system' stamp: ''!
wikiStyleHelp
	<wikiStyleHelp: #'The setting browser'>
	^ self comment! !

!SettingBrowserTest commentStamp: ''!
A SettingBrowserTest is a test class for testing the behavior of SettingBrowser!
!SettingBrowserTest methodsFor: 'tests' stamp: ''!
testOpening
	"Non-Regression Test related to https://pharo.manuscript.com/f/cases/16138"
	settingBrowser := SettingBrowser open.
	settingBrowser close! !

!SettingBrowserTest methodsFor: 'tests' stamp: ''!
testOpeningOnPackage

	settingBrowser := SettingBrowser new changePackageSet: { (RPackageOrganizer default packageNamed: 'System-Settings-Core') }; open.
	settingBrowser close! !

!SettingDeclaration commentStamp: ''!
A SettingDeclaration is an handler for a writtable setting value. 
Its main responsibility is allow real value changing and to hold descriptive data about the setting. When the real value is changed, all declared listeners are notified. The standard event mechanism is used for that purpose. See #value: method which is call in order to change a setting value. Whatever object can declare its interest in the real value changes by sending #whenChangedSend:to: to a setting. See notification protocol.

For convenience, my olds values are registered in a list. This list is used by the SystemSettingBrowser in order to easily retrieve previous values.

The type instance variable is a Symbol. It is used by the SystemSettingBrowser in order to build the input widget of a setting.
It can be the name of the class or the name of a superclass of the value. In that case, the input widget is built by #settingInputWidgetForNode: implemented by the class which name is the value of the type instance variable. As an example, the input widget for a Boolean is built by Boolean class>>settingInputWidgetForNode:.

Type value is not limited to be a class name. It can also be whatever symbol. In that case, the selector corresponding to the message to send to the setting in order to build the inputWidget is built by SettingDeclaration>>localInputWidgetSelector. If the type instance variable is not set, then it is dynamically set to the class name of the value. 

See SettingManager comment for more explanations.

Instance Variables
	default:		<Object>
	getSelector:		<Object>
	ghostHelp:		<Object>
	setSelector:		<Object>
	type:		<Object>

default
	- xxxxx

getSelector
	- xxxxx

ghostHelp
	- xxxxx

setSelector
	- xxxxx

type
	- xxxxx
!
!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetForPassword
	| widget |
	widget :=  self theme  
				newTextEntryIn: self
				for: self
				get: #realValue
				set: #realValue:
				class: String
				getEnabled: #enabled
				help: nil.
	widget
		wantsFrameAdornments: true;
		hResizing: #rigid;
		width: 450; 
		font: (StrikeFont passwordFontSize:  self theme  textFont pointSize).
	^ widget! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetForColor
	^ (  
	 self theme 
		newColorChooserIn: self
		for: self
		getColor: #realValue
		setColor: #realValue:
		getEnabled: #enabled 
		help: 'Choose a color') minWidth: 150; width: 150; yourself! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
getSelector
	^ getSelector ifNil: [self name]! !

!SettingDeclaration methodsFor: 'comparing' stamp: ''!
hash
	"hash is re-implemented because #= is re-implemented"
	^ self target hash
		bitXor: (self targetSelector hash
				bitXor: (self getSelector hash bitXor: self setSelector hash)) ! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
setSelector: aSymbol
	setSelector := aSymbol! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
defaultValue
	^ default value! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
maxKept
	"maximum number of old values which are kept in
	list instance variable"
	^ 5! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
privateForget: aReceiver selector: aSelector 
	"Private"
	self
		removeActionsSatisfying: [:action | action receiver == aReceiver
				and: [action selector = aSelector]]
		forEvent: self privateChangeEvent! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
hasEditableList
	^ (self realValue isKindOf: Boolean) not! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidget
	"return the default widget for the input a the setting"
	| inputWidget xtraDialogWidget | 
	xtraDialogWidget := super inputWidget.
	inputWidget :=  self localInputWidgetSelector ifNotNil: [:localSel | self perform: localSel].
	(inputWidget isNil and: [self typeClass notNil])
		ifTrue: [inputWidget := (self inputWidgetSelectorInClass: self typeClass)
			ifNotNil: [:selector | self typeClass perform: selector with: self]].
	inputWidget
		ifNotNil: [(inputWidget respondsTo: #model:) 
		  ifTrue: [inputWidget model ifNil: [inputWidget model: self]]].
	xtraDialogWidget 
		ifNotNil: [inputWidget := inputWidget ifNil: [xtraDialogWidget] 
			ifNotNil: [ self theme  newRowIn: self for: {inputWidget. xtraDialogWidget}]].
	^ inputWidget ! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetForBoolean
	^  self theme  
			newCheckboxIn: self
			for: self
			getSelected: #realValue
			setSelected: #realValue:
			getEnabled: #enabled
			label: '' 
			help: nil! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetForFont
	^ (self theme 
		newButtonIn: self
		for: self
		getState: nil 
		action: #getFont
		arguments: {}
		getEnabled: #enabled
		getLabel: #fontButtonLabel
		help: 'Choose a font ...' translated) cornerStyle: #square
! !

!SettingDeclaration methodsFor: 'testing' stamp: ''!
hasDefault
	^ default ~~ UniqueObject! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
listenersForEvent: anEvent
	| listeners actionSequence |	
	listeners := Set new.	
	actionSequence := self actionMap at: anEvent ifAbsent: [].	
	actionSequence ifNotNil: [
		actionSequence isCollection	 
			ifTrue: [actionSequence do: [:oneAction | 
					oneAction receiver ifNotNil: [:r | listeners add: r]]]
			ifFalse: [listeners add: actionSequence receiver]].
	^ listeners! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
setToDefault

	self realValue: self defaultValue.
! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
realValue
	"Answer the value of realValue"

	^ (self settingReceiver perform: self getSelector) 
		ifNil: [self setToDefault. 
			self settingReceiver perform: self getSelector]! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
index: anInteger 
	self realValue: (self list at: anInteger)! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetForLabel
	| widget |
	widget := self theme newLabelIn: self for: self label: '' getEnabled: nil.
	widget getTextSelector: #preferenceValue.
	widget width: 450.
	^ widget! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetForString
	| widget |
	widget := EditableDropListMorph
		on: self
		list: #list
		selected: #index
		changeSelected: #index:
		useIndex: true
		addToList: #addToList:
		class: (Smalltalk globals at: self type)
		getEnabled: #enabled
		default: self defaultValue.
	self ghostHelp ifNotNil: [ :gh | widget ghostText: gh ].
	widget contentMorph wantsFrameAdornments: true.
	widget hResizing: #rigid.
	widget width: 450.
	^ widget! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
preferenceValue
	^ self realValue! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
whenPrivateChangedSend: zeroOrOneArgSelector to: aSubscriber 
	"private, use #whenChangedSend:to: instead"
	self
		when: self privateChangeEvent
		send: zeroOrOneArgSelector
		to: aSubscriber! !

!SettingDeclaration methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	default := UniqueObject! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
ghostHelp: aString
	ghostHelp := aString! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
setSelector
	^ setSelector ifNil: [self getSelector ifNotNil: [:gs | (gs, ':') asSymbol]]! !

!SettingDeclaration methodsFor: 'visitor' stamp: ''!
acceptSettings: aVisitor 
	^ aVisitor visitSettingDeclaration: self! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetSelectorInClass: aClass 
	| selector |
	^ (aClass respondsTo: (selector := #settingInputWidgetForNode:))
		ifTrue: [selector] ! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
privateChangeEvent
	^ #privateSettingValueChanged! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
defaultIcon
	^ (self type = #LogicalFont
		or: [ self realValue isKindOf: AbstractFont ])
		ifTrue: [ self iconNamed: #smallFontsIcon ]
		ifFalse: [ self iconNamed: #smallPaintIcon ]! !

!SettingDeclaration methodsFor: 'export' stamp: ''!
exportSettingAction
	| targetSymbol currentValue |
	
	targetSymbol := self target isSymbol
						ifTrue: [ self target ]
						ifFalse: [ self target name asSymbol ].
						
	currentValue := self targetSelector
						ifNil: [ (Smalltalk at: targetSymbol) perform: self getSelector ]
						ifNotNil: [:s | ((Smalltalk at: targetSymbol) perform: s) perform: self getSelector].
	
	^ (self hasDefault not or: [ (self default = currentValue) not ])
		ifTrue: [ self startupAction ]
		ifFalse: [ "We do nothing" nil ]! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
localInputWidgetSelector
	| imSel |
	^ (self respondsTo: (imSel := ('inputWidgetFor' , self type) asSymbol)) ifTrue: [imSel]! !

!SettingDeclaration methodsFor: 'testing' stamp: ''!
hasDefaultValue
		
	^ self preferenceValue = self defaultValue ! !

!SettingDeclaration methodsFor: 'comparing' stamp: ''!
= other
	self class = other class
		ifFalse: [^ false].
	self target == other target ifFalse: [^ false].
	self targetSelector = other targetSelector ifFalse: [^ false].
	self getSelector = other getSelector ifFalse: [^ false].
	self setSelector = other setSelector ifFalse: [^ false].
	^ true
	
! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
ghostHelp
	^ ghostHelp ! !

!SettingDeclaration methodsFor: 'export' stamp: ''!
isExportable

	^ true! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetForDirectory

	^ self inputWidgetForFileOrDirectoryWithAction: #chooseFileDirectory.! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetForFileOrDirectoryWithAction: aSymbol
	| list button |
	list := EditableDropListMorph
		on: self
		list: #list
		selected: #index
		changeSelected: #index:
		useIndex: true
		addToList: #addToList:
		class: String
		getEnabled: #enabled
		default: self defaultValue.
	list
		ghostText: self ghostHelp;
		hResizing: #rigid;
		width: 450;
		wantsFrameAdornments: true.
	button := self theme
		newButtonIn: self
		for: self
		getState: nil
		action: aSymbol
		arguments: nil
		getEnabled: nil
		label:
			(AlphaImageMorph new
				image: (self iconNamed: #smallOpenIcon))
		help: 'Open directory chooser dialog' translated.
	^ self theme
		newRowIn: self
		for:
			{list.
			button}! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
type: anObject
	"Set the value of type"

	type := anObject! !

!SettingDeclaration methodsFor: 'export' stamp: ''!
startupAction
	"I assume here that the receiver is always a class"

	 | targetSymbol currentValue |
			
	targetSymbol := self target isSymbol
						ifTrue: [ self target ]
						ifFalse: [ self target name asSymbol ].
						
	currentValue := self targetSelector
						ifNil: [ (Smalltalk at: targetSymbol) perform: self getSelector ]
						ifNotNil: [:s | ((Smalltalk at: targetSymbol) perform: s) perform: self getSelector].
	^ StartupAction 
		name: self label 
		code: (String streamContents: [:s |
					self targetSelector ifNotNil: [ s << '(' ].
					s << '(Smalltalk at: '.
					targetSymbol asSymbol printOn: s.
					self targetSelector ifNotNil: [:ts | s << ') perform: '. ts printOn: s ].
					s << ') perform: '.
					self setSelector asSymbol printOn: s.
					s << ' with: ('.
					currentValue settingStoreOn: s.
					s <<')' ])
		runOnce: true! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
typeClass
	^ Smalltalk globals at: self type ifAbsent: [  ]! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
default: anObject 
	"initialize the default value"
	default := anObject.
! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
type
	"Answer the value of type"

	^ type ifNil: [type := self realValue class name]! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
list
	^ self class valueListFor: self! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
index
	^ self list
		indexOf: self realValue
		ifAbsent: [self realValue
				ifNil: [0]
				ifNotNil: [self addToList: self realValue.
					self list size]]! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
emptyList
	self list removeAll.
	self value ifNotNil: [self addToList: self realValue].! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
hasValue
	^ true! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetForNumber
	^ self inputWidgetForString width: 200.
! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputWidgetForPoint
	^ self inputWidgetForString width: 200.
! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
privateForget: aReceiver 
	"do not notify aReceiver anymore"
	self removeActionsWithReceiver: aReceiver forEvent: self privateChangeEvent! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
realValue: anObject
	"Set the value of realValue"
	self settingReceiver perform: self setSelector with: anObject.
	self triggerEvent: self privateChangeEvent with: self.! !

!SettingDeclaration methodsFor: 'export' stamp: ''!
displayExportAction

	Smalltalk tools workspace
		openContents: self startupAction storeString 
		label: self label! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
maxNameWidthForFont: aFont 
	| max |
	max := 0.
	self domainValuesLabels
		do: [:v | max := max max: (aFont widthOfStringOrText: v)].
	^ max ! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
selector: aSymbol
	self getSelector: aSymbol.
	self setSelector: (aSymbol, ':') asSymbol.! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
addToList: anItem
	(self list includes: anItem)
		ifFalse: [self list size > self maxKept
				ifTrue: [self list removeFirst].
			self list add: anItem.
			self changed: #list]! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
getSelector: aSymbol
	getSelector := aSymbol! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
privateListeners
	^ self listenersForEvent: self privateChangeEvent! !

!SettingDeclaration methodsFor: 'accessing' stamp: ''!
default
	^ default ! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
settingStoreOn: aStream
	aStream tab;
		nextPutAll: (self target isSymbol
				ifTrue: [self target]
				ifFalse: [self target name]);
		nextPutAll: (self targetSelector
				ifNil: ['']
				ifNotNil: [' ' , self targetSelector]);
		 nextPutAll: ' ' , self setSelector , ' '.
	self preferenceValue settingStoreOn: aStream.
	aStream nextPut: $.;
		 cr! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
inputMorphFor: aContainer
	^ (super inputMorphFor: aContainer)
		ifNotNil: [:im |			
				self whenPrivateChangedSend: #settingValueChanged: to: aContainer model.
				self whenPrivateChangedSend: #innerWidgetChanged to: aContainer.
				im]! !

!SettingDeclaration methodsFor: 'user interface' stamp: ''!
hasPrivateListener
	^ self hasActionForEvent: self privateChangeEvent! !

!SettingDeclaration class methodsFor: 'class initialization' stamp: ''!
initialize

	UniqueObject := Object new! !

!SettingDeclaration class methodsFor: 'cache accessing' stamp: ''!
valueListFor: aSettingValue
	| targetEntry |
	targetEntry := self valueListCache at: aSettingValue settingReceiver ifAbsentPut: [IdentityDictionary new].
	^ targetEntry at: aSettingValue getSelector ifAbsentPut: [OrderedCollection new].! !

!SettingDeclaration class methodsFor: 'icon accessing' stamp: ''!
nullifyForm
	^ (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 463732736 4285815129 4285815129 4285815129 4285815129 4285815129 2292449280 463732736 0 0 0 0 0 0 0 1688469504 4285815129 4278190080 4278190080 4278190080 4278190080 4278190080 4280091395 4285815129 1688469504 0 0 0 0 0 1688469504 4285815129 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4285815129 1688469504 0 0 0 463732736 4285815129 4278190080 4294967295 4294967295 4278190080 4278190080 4278190080 4278190080 4294967295 4294967295 4278190080 4285815129 463732736 0 0 4285815129 4278190080 4278190080 4294967295 4294967295 4294967295 4278190080 4278190080 4294967295 4294967295 4294967295 4278190080 4285815129 4285815129 0 0 4285815129 4278190080 4278190080 4278190080 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4278190080 4278190080 4278190080 4285815129 0 0 4285815129 4278190080 4278190080 4278190080 4278190080 4294967295 4294967295 4294967295 4294967295 4278190080 4278190080 4278190080 4278190080 4285815129 0 0 4285815129 4278190080 4278190080 4278190080 4278190080 4294967295 4294967295 4294967295 4294967295 4278190080 4278190080 4278190080 4278190080 4285815129 0 0 4285815129 4278190080 4278190080 4278190080 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4278190080 4278190080 4278190080 4285815129 0 0 2292449280 4281927174 4280025345 4294967295 4294967295 4294967295 4278190080 4278190080 4294967295 4294967295 4294967295 4278190080 4283696903 4285815129 0 0 463732736 4285815129 4278190080 4294967295 4294967295 4278190080 4278190080 4278190080 4278190080 4294967295 4294967295 4278190080 4285815129 463732736 0 0 0 1688469504 4285815129 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4285815129 1688469504 0 0 0 0 0 1688469504 4285815129 4285815129 4278190080 4278190080 4278190080 4278190080 4283696646 4285815129 1688469504 0 0 0 0 0 0 0 463732736 2292449280 4285815129 4285815129 4285815129 4285815129 2292449280 463732736 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
	offset: 0@0)! !

!SettingDeclaration class methodsFor: 'cache accessing' stamp: ''!
valueListCache
	^ ValueListCache ifNil: [ValueListCache := WeakKeyDictionary new]! !

!SettingDeclaration class methodsFor: 'icon accessing' stamp: ''!
smallCautionForm
	^ (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 463732736 2292449280 3517186048 4154720256 4154720256 3517186048 2292449280 463732736 0 0 0 0 0 0 0 1688469504 4137943040 4292614939 4293600292 4293534756 4293534499 4293402913 4292483352 4137943040 1688469504 0 0 0 0 0 1688469504 4290185224 4293600292 4292284175 4291428866 4291166208 4291100672 4291297794 4292087053 4293271070 4290184967 1688469504 0 0 0 463732736 4137943040 4293534756 4291823367 4291231744 4291166208 4294967295 4294967295 4290969600 4290969600 4291429637 4293073948 4137943040 463732736 0 0 2292449280 4292614682 4292284175 4291231744 4291035136 4291035136 4294967295 4294967295 4291035136 4291035136 4290838528 4291824395 4292351253 2292449280 0 0 3517186048 4293468963 4291363330 4291166208 4291035136 4291035136 4294967295 4294967295 4291035136 4291035136 4290707456 4290838785 4292942105 3517186048 0 0 4154720256 4293534242 4291166208 4291100672 4291035136 4291035136 4294967295 4294967295 4291035136 4290707456 4290641920 4290641920 4292942104 4154720256 0 0 4154720256 4293468449 4291035136 4291035136 4291035136 4291035136 4291100672 4291100672 4291035136 4290641920 4290576384 4290510848 4292876056 4154720256 0 0 3517186048 4293271328 4291166722 4290969600 4291035136 4291035136 4291035136 4291035136 4291035136 4291035136 4290510848 4290576641 4292744726 3517186048 0 0 2292449280 4292417303 4291955981 4290838528 4291035136 4291035136 4294967295 4294967295 4291035136 4291035136 4290445312 4291430665 4292088338 2292449280 0 0 463732736 4137943040 4293139484 4291298565 4290707456 4290641920 4294967295 4294967295 4290510848 4290379776 4290905092 4292678933 4137943040 463732736 0 0 0 1688469504 4290184967 4293007898 4291693323 4290707713 4290510848 4290445312 4290511105 4291365129 4292678932 4290053638 1688469504 0 0 0 0 0 1688469504 4137943040 4292219924 4292876311 4292876055 4292810518 4292744726 4292088081 4137943040 1688469504 0 0 0 0 0 0 0 463732736 2292449280 3517186048 4154720256 4154720256 3517186048 2292449280 463732736 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
	offset: 0@0)! !

!SettingDontTranslateDescriptionRule commentStamp: ''!
When defining a description of a setting, you don't need to translate it. It will be done by the setting itself.!
!SettingDontTranslateDescriptionRule methodsFor: 'helpers' stamp: ''!
checkPreconditionOn: aMethodNode

	^ aMethodNode pragmas anySatisfy: [ :p |
		p selector = #systemsettings ]! !

!SettingDontTranslateDescriptionRule methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	self
		replace: '`@recv description: `#str translated'
		with: '`@recv description: `#str'! !

!SettingDontTranslateDescriptionRule methodsFor: 'running' stamp: ''!
basicCheck: aNode
	^ aNode methodNode ifNil: [ false ] ifNotNil: [ :methNode | self checkPreconditionOn: methNode ]! !

!SettingDontTranslateDescriptionRule methodsFor: 'accessing' stamp: ''!
group

	^ 'API Hints'! !

!SettingDontTranslateDescriptionRule methodsFor: 'accessing' stamp: ''!
name

	^ 'Do not use #translated for setting''s description'! !

!SettingFilter commentStamp: ''!
A SettingFilter is a filter which is used by a SettingBrowser in order to select which nodes of the setting trees are to be shown. A SettingFilter subclass must redefine the #keepHandler: method which return true if the argument handler is to be kept.

Instance Variables
!
!SettingFilter methodsFor: 'filtering' stamp: ''!
keepSettingTreeNode: aSettingNode 
	^ false! !

!SettingNode commentStamp: ''!
A SettingTreeNode is used by a SettingCollector as a node for setting trees. Built trees can be viewed by a SettingBrowser

Instance Variables
	contents:		<Collection of SettingTreeNode>
	parentNode:		<SettingTreeNode or nil>

contents
	- the children

parentNode
	- the parent or nil if the node is a root
!
!SettingNode methodsFor: 'accessing' stamp: ''!
labelMorphFor: aContainer
	^ self settingDeclaration 
		ifNotNil: [:v | v labelMorphFor: aContainer]! !

!SettingNode methodsFor: 'testing' stamp: ''!
isEmpty
	^ self contents isEmpty! !

!SettingNode methodsFor: 'accessing' stamp: ''!
methodClass
	^ self pragma ifNotNil: [self pragma methodClass instanceSide]! !

!SettingNode methodsFor: 'accessing' stamp: ''!
settingDeclaration
	^ self item! !

!SettingNode methodsFor: 'accessing' stamp: ''!
inputMorphFor: aContainer
	^ self settingDeclaration
		ifNotNil: [:v | 
			(v inputMorphFor: aContainer) ifNil: [ '' ]]! !

!SettingNode methodsFor: 'accessing' stamp: ''!
parentName
	^ parentName
	! !

!SettingNode methodsFor: 'menu' stamp: ''!
deeplyDetect: aBlock 
	(aBlock value: self) ifTrue: [^ self].
	self contents do: [:sub | (sub deeplyDetect: aBlock) ifNotNil: [:found | ^ found]].
	^ nil! !

!SettingNode methodsFor: 'menu' stamp: ''!
menuBrowse
	self browseDeclaration! !

!SettingNode methodsFor: 'accessing' stamp: ''!
description
	^ self settingDeclaration description! !

!SettingNode methodsFor: 'accessing' stamp: ''!
receiverPackage
	^ self settingReceiver
		ifNotNil: [self settingReceiver class package] ! !

!SettingNode methodsFor: 'updating' stamp: ''!
updateAccordingTo: aFilter 
	(aFilter keepSettingTreeNode: self) 
		ifFalse: [
			self contents do: [ :n | n updateAccordingTo: aFilter].
			self contents removeAllSuchThat: [ :n | (aFilter keepSettingTreeNode: n) not  and: [n isEmpty]]]
		! !

!SettingNode methodsFor: 'accessing' stamp: ''!
parent: aSymbol
	self parentName: aSymbol! !

!SettingNode methodsFor: 'printing' stamp: ''!
settingNodeIdentifier
	^ String streamContents: [ :aStream |
			self settingNodeIdentifierOn: aStream ]! !

!SettingNode methodsFor: 'accessing' stamp: ''!
helpText
	^ self item description ifEmpty: [ nil ]! !

!SettingNode methodsFor: 'accessing' stamp: ''!
icon
	^ self settingDeclaration ifNotNil: [:d | d icon ] ! !

!SettingNode methodsFor: 'menu' stamp: ''!
deeplySelect: aBlock in: aCollection
	(aBlock value: self) ifTrue: [aCollection add: self].
	self contents do: [:sub | sub deeplySelect: aBlock in: aCollection].
	^ aCollection! !

!SettingNode methodsFor: 'testing' stamp: ''!
isAnotherValueStored
	"Return true if the another setting value is stored."
	| storedValue |
	storedValue := self storedValue.
	^ storedValue notNil and: [ storedValue ~= self settingValue ]! !

!SettingNode methodsFor: 'accessing' stamp: ''!
contents
	^ (self settingDeclaration hasValue and: [ self settingValue = false ])
		ifTrue: [ OrderedCollection new ]
		ifFalse: [ contents
				ifNil: [ contents := self allChildren.
					self settingDeclaration ordering ifTrue: [ contents := contents asArray sort: self model sortBlock ].
					contents := self model retainedNodesFromList: contents asOrderedCollection ] ]! !

!SettingNode methodsFor: 'accessing' stamp: ''!
parentName: aSymbol
	parentName := aSymbol
	! !

!SettingNode methodsFor: 'accessing' stamp: ''!
realValue
	^ self settingDeclaration realValue! !

!SettingNode methodsFor: 'accessing' stamp: ''!
allChildren
	^ self model childrenOf: self
! !

!SettingNode methodsFor: 'accessing' stamp: ''!
settingValue
	^ self settingDeclaration realValue
! !

!SettingNode methodsFor: 'accessing' stamp: ''!
settingReceiver
	^ item settingReceiver! !

!SettingNode methodsFor: 'menu' stamp: ''!
inspectItem
	self settingDeclaration inspect! !

!SettingNode methodsFor: 'printing' stamp: ''!
settingNodeIdentifierOn: aWriteStream 
	parentNode 
		ifNotNil: [ parentName settingNodeIdentifierOn: aWriteStream ]
		ifNil: [ parentName ifNotNil: [ aWriteStream print: parentName ] ].
	aWriteStream print: self settingDeclaration name! !

!SettingNode methodsFor: 'menu' stamp: ''!
browseDeclaration
	"open a browser on the method which defines myself"
	Smalltalk tools browser
		openOnClass: self methodClass class selector: self selector! !

!SettingNode methodsFor: 'menu' stamp: ''!
exploreItem
	self settingDeclaration inspect! !

!SettingNode methodsFor: 'menu' stamp: ''!
loadFromDisk
	self persistence updateSettingNode: self! !

!SettingNode methodsFor: 'accessing' stamp: ''!
storedValue
	"It returns a stored value for the setting node.
	It returns nil value when there is no stored value."	
	^ self persistence storedValueForSettingNode: self! !

!SettingNode methodsFor: 'accessing' stamp: ''!
order: anInteger
	item order: anInteger! !

!SettingNode methodsFor: 'accessing' stamp: ''!
order
	^ item order! !

!SettingNode methodsFor: 'accessing' stamp: ''!
persistence
	^ self model persistence! !

!SettingNode methodsFor: 'checking' stamp: ''!
checkForUnknownTarget
	self parentNode ifNotNil: [:p | item target ifNil: [item target: p item target].
		item targetSelector ifNil: [item targetSelector: p item targetSelector]].
	self allChildren do: [:c | c checkForUnknownTarget]! !

!SettingNode methodsFor: 'accessing' stamp: ''!
realValue: anObject
	self settingDeclaration realValue: anObject! !

!SettingNode methodsFor: 'accessing' stamp: ''!
selector
	^ self pragma ifNil: [ '' ] ifNotNil: [ :p | p methodSelector ]! !

!SettingNode methodsFor: 'menu' stamp: ''!
menu: menu shifted: b 
	menu
		add: 'Browse (b)'
		target: self
		selector: #browseDeclaration.		
	self item isExportable ifFalse: [ ^self ].
	(menu
		add: 'Save to disk'
		target: self
		selector: #saveToDisk)
			enablementSelector: #isNotCurrentValueStored.
	(menu
		add: 'Load from disk'
		target: self
		selector: #loadFromDisk)
			enablementSelector: #isAnotherValueStored.
	(menu
		add: 'Delete stored value'
		target: self
		selector: #deleteStoredValue)
			enablementSelector: #isStored.! !

!SettingNode methodsFor: 'testing' stamp: ''!
isStored
	"Return true if this setting node has stored value. 
	The stored value can differ from the current value."
	^ self storedValue notNil! !

!SettingNode methodsFor: 'menu' stamp: ''!
keyDown: anEvent from: aTreeMorph
	| c |
	c := anEvent keyCharacter.
	c = $b
		ifTrue: [self menuBrowse. ^ true].
	c = $i
		ifTrue: [self inspectItem. ^ true].
	c = $I
		ifTrue: [self exploreItem. ^ true].
	^ false
! !

!SettingNode methodsFor: 'menu' stamp: ''!
deleteStoredValue
	self persistence deleteSettingNode: self! !

!SettingNode methodsFor: 'testing' stamp: ''!
isCurrentValueStored
	"Return true if the current setting value is stored."
	^ self storedValue = self settingValue! !

!SettingNode methodsFor: 'accessing' stamp: ''!
pragma: aPragma
	pragma := aPragma! !

!SettingNode methodsFor: 'testing' stamp: ''!
isNotCurrentValueStored
	"Return false if the current setting value is stored."
	^ self isCurrentValueStored not
! !

!SettingNode methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForSettingsFor: aStep
	<stSpotterOrder: 0>
	self allChildren isEmpty ifTrue: [ ^ self ].
	aStep listProcessor
		title: 'Children';
		allCandidates: [ self allChildren ];
		itemName: [ :each | each spotterLabel ];
		filter: StFilterSubstring! !

!SettingNode methodsFor: 'accessing' stamp: ''!
parentNode
	^ self model nodeNamed: self parentName! !

!SettingNode methodsFor: 'menu' stamp: ''!
saveToDisk
	self persistence storeSettingNode: self! !

!SettingNode methodsFor: 'comparing' stamp: ''!
<= other
	^ self asString <= other asString! !

!SettingNode methodsFor: 'accessing' stamp: ''!
pragma
	^ pragma! !

!SettingNodeBuilder commentStamp: ''!
Used to build nodes from the settings framework!
!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
dialog: aSymbol
	node item dialog: aSymbol
! !

!SettingNodeBuilder methodsFor: 'accessing' stamp: ''!
node: aSettingTreeNode
	node := aSettingTreeNode! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
targetSelector: aSelector
	node item targetSelector: aSelector
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
setSelector: aSymbol
	node item setSelector: aSymbol
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
iconName: aSymbol
	self icon: (self iconNamed: aSymbol)! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
parentName
	^ node parentName
	! !

!SettingNodeBuilder methodsFor: 'accessing' stamp: ''!
node
	^ node! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
range: anInterval
	node item range: anInterval
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
type: anObject
	node item type: anObject
! !

!SettingNodeBuilder methodsFor: '*Keymapping-Settings' stamp: ''!
category: aByteSymbol 
	node item categoryName: aByteSymbol! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
parent: aSymbol
	node parentName: aSymbol! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
name: aString
	node item name: aString
! !

!SettingNodeBuilder methodsFor: '*Keymapping-Settings' stamp: ''!
do: aBlockClosure 
	node item action: aBlockClosure! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
script: aSymbol
	node item script: aSymbol
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
parentName: aSymbol
	node parentName: aSymbol.
	! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
default: anObject
	node item  default: anObject
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
icon: aForm
	node item icon: aForm! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
noOrdering
	node item noOrdering
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
target: anObject
	node item target: anObject
! !

!SettingNodeBuilder methodsFor: 'private - tree building' stamp: ''!
asParentWhile: aBlock
	builder parent: self while: aBlock
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
label: aString
	node item label: aString
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
notInStyle
	node item notInStyle! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
order: aNumber
	node item order: aNumber
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
ghostHelp: aString
	node item ghostHelp: aString
! !

!SettingNodeBuilder methodsFor: 'accessing' stamp: ''!
builder: aTreeBuilder
	builder := aTreeBuilder! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
description: aText
	node item description: aText! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
selector: aSymbol
	node item selector: aSymbol
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
domainValues: aCollection 
	node item domainValues: aCollection 
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
getSelector: aSymbol
	node item getSelector: aSymbol
! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
name
	^ node item name
! !

!SettingNodeBuilder methodsFor: 'tree building' stamp: ''!
with: aBlock
	self asParentWhile: aBlock! !

!SettingNodeBuilder methodsFor: 'declaration accessing' stamp: ''!
precondition: aValuable
	node item precondition: aValuable
! !

!SettingNodeBuilder methodsFor: '*Keymapping-Settings' stamp: ''!
shortcutName: aShortcutName
	node item shortcutName: aShortcutName! !

!SettingPackageFilter commentStamp: ''!
A SettingPackageFilter is a SettingFilter used to select settings from a given list of packages: a setting is kept only if the package in which it is defined is present in the given package list

Instance Variables
	packages:		<Collection>

packages
	- The collection of PackageInfo the filter is currently using!
!SettingPackageFilter methodsFor: 'filtering' stamp: ''!
keepSettingTreeNode: aSettingNode 
	| rp |
	^ (rp := aSettingNode receiverPackage) notNil and: [self packages includes: rp]! !

!SettingPackageFilter methodsFor: 'accessing' stamp: ''!
packages
	"Answer the value of packages"

	^ packages! !

!SettingPackageFilter methodsFor: 'accessing' stamp: ''!
packages: aCollectionOfPackageInfo
	"Set the value of packages"

	packages := aCollectionOfPackageInfo
! !

!SettingRegexpFilter commentStamp: ''!
A SettingRegexpFilter is SettingFilter which makes use of a regular expression in order to keep or not a SettingHandler.

Instance Variables
	regexp:		<String>

regexp
	- a regular expression string
!
!SettingRegexpFilter methodsFor: 'filtering' stamp: ''!
keepSettingTreeNode: aSettingNode 
	^ (({aSettingNode methodClass name. aSettingNode selector}
			collect: [:e | e ifNil: ['']])
			anySatisfy: [:token | token substrings anySatisfy: [:sub | sub matchesRegexIgnoringCase: self regexp]])
		or: [self keepSettingDeclaration: aSettingNode settingDeclaration] ! !

!SettingRegexpFilter methodsFor: 'filtering' stamp: ''!
keepSettingDeclaration: aSettingDeclaration
	^ ({aSettingDeclaration name. aSettingDeclaration label. aSettingDeclaration description}
				collect: [:e | e ifNil: ['']])
				anySatisfy: [:token | token  matchesRegexIgnoringCase: self regexp]
! !

!SettingRegexpFilter methodsFor: 'accessing' stamp: ''!
regexp
	"Answer the value of regexp"

	^ regexp! !

!SettingRegexpFilter methodsFor: 'accessing' stamp: ''!
regexp: anObject
	"Set the value of regexp"

	regexp := anObject! !

!SettingTokenFilter commentStamp: ''!
A SettingTokenFilter is SettingFilter which makes use of a token (substring) in order to keep or not a SettingHandler.


Instance Variables
	token:		<String>

!
!SettingTokenFilter methodsFor: 'filtering' stamp: ''!
keepSettingTreeNode: aSettingNode 
	^ (({aSettingNode methodClass name asUppercase. aSettingNode selector asUppercase}
			collect: [:e | e ifNil: ['']])
			includesSubstringAnywhere: self token asUppercase)
		or: [self keepSettingDeclaration: aSettingNode settingDeclaration]! !

!SettingTokenFilter methodsFor: 'filtering' stamp: ''!
keepSettingDeclaration: aSettingDeclaration
	| selector |
	selector := (aSettingDeclaration respondsTo: #getSelector) 
		ifTrue: [aSettingDeclaration getSelector] ifFalse: [''].
	^ (({aSettingDeclaration name.  
		aSettingDeclaration label. 
		selector asUppercase. 
		aSettingDeclaration description}
				collect: [:e | (e ifNil: ['']) asUppercase])
				includesSubstringAnywhere: self token asUppercase)
! !

!SettingTokenFilter methodsFor: 'accessing' stamp: ''!
token
	"Answer the value of token"

	^ token! !

!SettingTokenFilter methodsFor: 'accessing' stamp: ''!
token: aString
	"Set the value of token"

	token := aString! !

!SettingTree commentStamp: ''!
A SettingTree is responsible for the building of system setting trees from a collection of pragma.
Built tree nodes are instances of SettingNode. Built trees are suitable for tree browsing with the help of a MorphTreeMorph (see SettingBrowser>>treeMorphIn: and SettingBrowser>>roots to know how a SettingBrowser is initializing its MorphTreeMorph with the help of a SettingTree). 

Below, two examples of tree building with a SettingCollector are shown.
---------------
(SettingTree acceptableKeywords: #(#'systemsettings')) settingTreeRoots. "get system setting trees"
---------------

Instance Variables
	collector		<PragmaCollector>
	nodeList		<A list of SettingNode>
!
!SettingTree methodsFor: 'querying' stamp: ''!
retainedNodesFromList: aListOfNodes
	| retained |
	retained := OrderedCollection new.
	aListOfNodes do: [:n | [n item precondition value ifTrue: [retained add: n]] on: Error do: [retained add: n]].
	^ retained! !

!SettingTree methodsFor: 'updating' stamp: ''!
whenChangedSend: aSelector to: aTarget
	self collector whenChangedSend: aSelector to: aTarget.
	self collector whenResetSend: aSelector to: aTarget.! !

!SettingTree methodsFor: 'accessing' stamp: ''!
collector
	^ collector ifNil: [collector := PragmaCollector new]! !

!SettingTree methodsFor: 'querying' stamp: ''!
childrenOf: aNode
	| children idx order |
	"Get aNode children. Assign children order if one child has an order which is not nil"
	children := self nodeList select: [ :p | p parentName = aNode settingDeclaration name ].
	children
		detect: [ :n | n order notNil ]
		ifFound: [ :firstWithOrder | 
			idx := children indexOf: firstWithOrder.
			order := firstWithOrder order.
			idx > 1
				ifTrue: [ 
					idx - 1 to: 1 do: [ :pos | 
						(children at: pos) order: order - 1.
						order := order - 1 ] ].
			order := firstWithOrder order.
			idx + 1 to: children size do: [ :pos | 
				(children at: pos) order ifNil: [ (children at: pos) order: order + 1 ] ifNotNil: [ order := (children at: pos) order ].
				order := order + 1 ] ].
	^ children! !

!SettingTree methodsFor: 'checking' stamp: ''!
checkForUnknownParent
	self unclassified
		ifNotEmpty: [ :nodesWithUnknownParent | 
			| builder g |
			builder := SettingTreeBuilder new.
			g := (builder group: #nodesWithUnknownParent) node.
			self nodeList addFirst: g.
			g model: self.
			g item label: '*** Unclassified ***'.
			g item icon: (self iconNamed: #smallDebugIcon).
			g item order: 0.0.
			nodesWithUnknownParent
				do: [ :node | node parentName: #nodesWithUnknownParent ] ]! !

!SettingTree methodsFor: 'checking' stamp: ''!
checkForUnknownTarget
	"check only root because other nodes with unknown target inherits it from its parent"
	self settingTreeRoots do: [:node | node item target ifNil: [node item target: (node pragma ifNotNil: [:prg | prg methodClass instanceSide])]].
	self settingTreeRoots do: [:node | node checkForUnknownTarget].
! !

!SettingTree methodsFor: 'querying' stamp: ''!
deeplyDetect: aBlock 
	self settingTreeRoots
		do: [:sub | (sub deeplyDetect: aBlock)
				ifNotNil: [:found | ^ found]].
	^ nil ! !

!SettingTree methodsFor: 'querying' stamp: ''!
deeplySelect: aBlock
	^ self deeplySelect: aBlock in: OrderedCollection new
! !

!SettingTree methodsFor: 'accessing' stamp: ''!
nodeList
	| builder |
	^ nodeList 
		ifNil: [
			builder := SettingTreeBuilder new.
			self pragmasDo: [:p | builder buildPragma: p].
			nodeList := builder nodeList.
			nodeList do: [:n | n model: self].
			self checkForUnknownParent.
			self checkForUnknownTarget.
			self nodeList]! !

!SettingTree methodsFor: 'accessing' stamp: ''!
persistence
	^ persistence ifNil: [ persistence := SystemSettingsPersistence settingTree: self ]! !

!SettingTree methodsFor: 'querying' stamp: ''!
pragmasDo: aBlock
	^  self collector do: aBlock! !

!SettingTree methodsFor: 'private - tree building' stamp: ''!
nodeNamed: aSymbol
	^ self nodeNamed: aSymbol ifAbsent: []
! !

!SettingTree methodsFor: 'querying' stamp: ''!
settingTreeRoots
	^ self retainedNodesFromList: ((self nodeList select: [:n | n parentName isNil]) asArray sort: self sortBlock) asOrderedCollection.
! !

!SettingTree methodsFor: 'accessing' stamp: ''!
itemSortBlock
	^ [: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: [a label < b label]
				ifFalse: [a order ifNil: [false] ifNotNil: [true]]]]! !

!SettingTree methodsFor: 'private - tree building' stamp: ''!
nodeNamed: aSymbol ifAbsent: aBlock
	^ self nodeList detect: [:d | d settingDeclaration name = aSymbol] ifNone: aBlock! !

!SettingTree methodsFor: 'persistence' stamp: ''!
storeSettingNodes
	self persistence storeSettingNodes! !

!SettingTree methodsFor: 'querying' stamp: ''!
deeplySelect: aBlock in: aCollection 
	self settingTreeRoots
		do: [:aRoot | aRoot deeplySelect: aBlock in: aCollection]. 
	^ aCollection! !

!SettingTree methodsFor: 'accessing' stamp: ''!
sortBlock
	^ [:a :b | self itemSortBlock value: a settingDeclaration value: b settingDeclaration]! !

!SettingTree methodsFor: 'querying' stamp: ''!
unclassified
	^ self nodeList select: [:node | node parentName notNil and: [node parentNode isNil]].! !

!SettingTree methodsFor: 'persistence' stamp: ''!
updateSettingNodes
	self persistence updateSettingNodes! !

!SettingTree methodsFor: 'accessing' stamp: ''!
updateList
	nodeList := nil.
! !

!SettingTree methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterForSettingsFor: aStep
	<stSpotterOrder: 0>
	aStep listProcessor
		title: 'Settings';
		allCandidates: [ self nodeList ];
		itemName: [ :each | each spotterLabel ];
		filter: StFilterSubstring! !

!SettingTree methodsFor: 'private - tree building' stamp: ''!
emptyNodeNamed: aSymbol
	(self nodeNamed: aSymbol)
! !

!SettingTree methodsFor: 'accessing' stamp: ''!
acceptableKeywords: keywords
	self collector 
		selectors: keywords;
		filter: [:prg | prg methodClass isMeta].
	nodeList := nil.
	self collector reset! !

!SettingTree class methodsFor: 'instance creation' stamp: ''!
acceptableKeywords: aCollectionOfStrings
	^ self new acceptableKeywords: aCollectionOfStrings 
! !

!SettingTreeBuilder commentStamp: ''!
A builder for the settings tree!
!SettingTreeBuilder methodsFor: '*Keymapping-Settings' stamp: ''!
shortcut: aShortcutNameSymbol
	^ self nodeClass: KMShortcutDeclaration name: aShortcutNameSymbol! !

!SettingTreeBuilder methodsFor: 'pragmas' stamp: ''!
systemsettings
	"Process a <systemsettings> pragma"

	<settingPragmaProcessor>
	currentPragma methodClass instanceSide
		perform: currentPragma methodSelector
		with: self! !

!SettingTreeBuilder methodsFor: 'accessing' stamp: ''!
nodeClass
	^ SettingNode! !

!SettingTreeBuilder methodsFor: 'accessing' stamp: ''!
buildPragma: aPragma
	currentPragma := aPragma.
	self perform: aPragma selector withArguments: aPragma arguments.
	^ nodeList! !

!SettingTreeBuilder methodsFor: 'tree building' stamp: ''!
pickOne: aSymbol
	^ self nodeClass: PickOneSettingDeclaration name: aSymbol
! !

!SettingTreeBuilder methodsFor: 'private - tree building' stamp: ''!
nodeClass: aClass name: aSymbol
	| node |
	node := self nodeClass with: aClass new.
	node item name: aSymbol.
	node pragma: currentPragma.
	node parentName: (currentParent ifNotNil: [currentParent name]).
	self nodeList add: node.
	^ (SettingNodeBuilder new) node: node; builder: self; yourself! !

!SettingTreeBuilder methodsFor: 'accessing' stamp: ''!
nodeList
	^ nodeList ifNil: [nodeList := OrderedCollection new]
! !

!SettingTreeBuilder methodsFor: 'tree building' stamp: ''!
range: aSymbol
	^ self nodeClass: RangeSettingDeclaration name: aSymbol
! !

!SettingTreeBuilder methodsFor: 'tree building' stamp: ''!
setting: aSymbol
	^ self nodeClass: SettingDeclaration name: aSymbol
! !

!SettingTreeBuilder methodsFor: 'private - tree building' stamp: ''!
parent: aNode while: aBlock
	| oldParent |
	oldParent := currentParent.
	currentParent := aNode.
	aBlock value.
	currentParent := oldParent! !

!SettingTreeBuilder methodsFor: 'tree building' stamp: ''!
launcher: aSymbol
	^ self nodeClass: SystemSettingLauncher name: aSymbol
! !

!SettingTreeBuilder methodsFor: '*System-Settings-Tests' stamp: ''!
mocksystemsettings
	currentPragma methodClass instanceSide perform: currentPragma methodSelector with: self.! !

!SettingTreeBuilder methodsFor: 'tree building' stamp: ''!
group: aSymbol
	^ self nodeClass: PragmaSetting name: aSymbol
! !

!SettingTreeBuilder methodsFor: '*Keymapping-Settings' stamp: ''!
attachShortcutCategory: aByteSymbol to: aClass
	KMFactory keymapContainer attachCategoryName: aByteSymbol to: aClass.! !

!SettingTreeBuilder class methodsFor: 'instance creation' stamp: ''!
acceptableKeywords: aCollectionOfRegExps 
	^ self new acceptableKeywords: aCollectionOfRegExps 
! !

!SettingsStonReader commentStamp: ''!
I am a reader of system settings from a file (stream). I know how to load the settings and I return those stored settings.

Collaborators: SystemSettingsPersistence

Public API and Key Messages

- stream:   
- secureLoad 
- load

Internal Representation and Key Implementation Points.

    Instance Variables
	storedSettings:		<Array>
	stream:				<ReadStream>
!
!SettingsStonReader methodsFor: 'accessing' stamp: ''!
storedSettings
	^ storedSettings! !

!SettingsStonReader methodsFor: 'loading' stamp: ''!
load
	"It loads all instances of StoredSetting from a stream."
	stream ifNil: [ ^ #() ].
	stream atEnd ifTrue: [ ^ #() ].
	[ | reader | 
		reader := STON reader on: stream; yourself.
		storedSettings := reader next.
	] ensure: [ stream close ].
	^ storedSettings! !

!SettingsStonReader methodsFor: 'loading' stamp: ''!
secureLoad
	[ self load ] on: STONReaderError do: [ :ex | "ignore" ].
	^ self storedSettings ifNil: [ #() ].! !

!SettingsStonReader methodsFor: 'accessing' stamp: ''!
stream: anObject
	stream := anObject! !

!SettingsStonReader methodsFor: 'accessing' stamp: ''!
stream
	^ stream! !

!SettingsStonReaderTest commentStamp: ''!
A SettingsStonReaderTest is a test class for testing the behavior of SettingsStonReader!
!SettingsStonReaderTest methodsFor: 'tests' stamp: ''!
testLoad
	reader stream: MockSettings oneStoredSettingSTONString readStream.
	reader load.
	self assert: reader storedSettings notNil.
	self assert: reader storedSettings size equals: 1.
	self assert: reader storedSettings first realValue equals: true.! !

!SettingsStonReaderTest methodsFor: 'tests' stamp: ''!
testLoadNotExistingClassNameForRealValue
	reader stream: MockSettings notExistingClassStoredSettingSTONString readStream.
	reader load.
	self assert: reader storedSettings notNil.
	self assert: reader storedSettings size equals: 1.
	self should: [  reader storedSettings first realValue ] raise: NotFound.
	reader storedSettings first updateSettingNode: nil.! !

!SettingsStonReaderTest methodsFor: 'tests' stamp: ''!
testBasic
	"Checking that no error occur"
	SettingsStonReader new load! !

!SettingsStonReaderTest methodsFor: 'tests' stamp: ''!
testNonExistingStoredSettingVariable
	<expectedFailure>
	reader stream: MockSettings changedClassStoredSettingVariable readStream.
	reader load.
	self assert: SettingsStonReader new storedSettings isNil! !

!SettingsStonReaderTest methodsFor: 'tests' stamp: ''!
testStoredSettingsIsNil
	self assert: SettingsStonReader new storedSettings isNil! !

!SettingsStonReaderTest methodsFor: 'tests' stamp: ''!
testEmptyStream
	self assertEmpty: reader stream contents! !

!SettingsStonReaderTest methodsFor: 'tests' stamp: ''!
testLoadTwoObjects
	reader stream: MockSettings twoStoredSettingsSTONString readStream.
	reader load.
	self assert: reader storedSettings notNil.
	self assert: reader storedSettings size equals: 2.
	self assert: reader storedSettings first realValue equals: false.
	self assert: reader storedSettings second realValue equals: 55.! !

!SettingsStonReaderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	reader := SettingsStonReader new.
	reader stream: (ReadStream on: String new)
! !

!SettingsStonWriter commentStamp: ''!
I am a writer of system settings to a file (stream). I know how to write the settings into a stream.

Collaborators: SystemSettingsPersistence

Public API and Key Messages

- stream:
- store 

Internal Representation and Key Implementation Points.

    Instance Variables
	storedSettings:		<Array>
	stream:				<WriteStream>
!
!SettingsStonWriter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	storedSettings := OrderedCollection new.! !

!SettingsStonWriter methodsFor: 'adding' stamp: ''!
addSettings: aCollectionOfStoredSettings
	storedSettings addAll: aCollectionOfStoredSettings! !

!SettingsStonWriter methodsFor: 'adding' stamp: ''!
addSetting: aStoredSetting
	storedSettings add: aStoredSetting! !

!SettingsStonWriter methodsFor: 'actions' stamp: ''!
store
	"Write the stored setting in the stream"

	| filteredStoredSettings |
	stream ifNil: [ ^ self ].
	
	"The settings with default values are not stored"
	filteredStoredSettings := storedSettings reject: [ :aStoredSetting | aStoredSetting hasDefaultValue ]. 

	STON writer
		on: stream;
		prettyPrint: true;
		asciiOnly: true;
		nextPut: filteredStoredSettings asArray! !

!SettingsStonWriter methodsFor: 'accessing' stamp: ''!
stream: aWriteStream 
	stream := aWriteStream! !

!SettingsStonWriter methodsFor: 'accessing' stamp: ''!
stream
	"Return the stream on which storedSettings are written in. 
	This method is useful for testing"
	^ stream! !

!SettingsStonWriterTest commentStamp: ''!
A SettingsStonWriterTest is a test class for testing the behavior of SettingsStonWriter!
!SettingsStonWriterTest methodsFor: 'tests' stamp: ''!
testStoreShouldNotCloseBackingStream
	| settingNode |
	settingNode := MockSettings booleanSettingNode.
	writer addSetting: (StoredSettingsFactory new from: settingNode).
	writer store.
	self deny: fileStream closed.
	fileStream flush.
	self assert: fileReference contents equals: MockSettings oneStoredSettingSTONString! !

!SettingsStonWriterTest methodsFor: 'tests' stamp: ''!
testStore
	| settingNode |
	settingNode := MockSettings booleanSettingNode.
	writer addSetting: (StoredSettingsFactory new from: settingNode).
	writer store.
	fileStream flush.
	self assert: fileReference contents equals: MockSettings oneStoredSettingSTONString! !

!SettingsStonWriterTest methodsFor: 'running' stamp: ''!
tearDown
	fileStream close.
	super tearDown! !

!SettingsStonWriterTest methodsFor: 'tests' stamp: ''!
testBasic
	"Checking that no error occur"

	SettingsStonWriter new store! !

!SettingsStonWriterTest methodsFor: 'tests' stamp: ''!
testEmptyStream
	fileStream flush.
	self assertEmpty: fileReference contents! !

!SettingsStonWriterTest methodsFor: 'tests' stamp: ''!
testStoreTwoObjects
	| settingNode1 settingNode2 |
	settingNode1 := MockSettings booleanSettingNode.
	settingNode2 := MockSettings rangeSettingNode.
	writer
		addSetting:
			((StoredSettingsFactory new from: settingNode1)
				realValue: false;
				yourself).
	writer
		addSetting:
			((StoredSettingsFactory new from: settingNode2)
				realValue: 55;
				yourself).
	writer store.
	fileStream flush.
	self assert: fileReference contents equals: MockSettings twoStoredSettingsSTONString! !

!SettingsStonWriterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	fileReference := (FileSystem memory root / 'preferences.ston.txt') asFileReference.
	writer := SettingsStonWriter new.
	fileStream := fileReference writeStream.
	writer stream: fileStream! !

!ShAbstractChange commentStamp: ''!
I represent a change in a class detected when compared with the old version of the class.

In the changes could be only one instance of each change. So the equals and hashcode is implemented in that way.
This is because, many different change detectors can detect the same change, but I only care once. 

My  subclasses should know:

- To announce the changes if they have to.
- If they represent a change in the instance shape, requiring a  migration of instances.
- If the change affect the subclasses.!
!ShAbstractChange methodsFor: 'comparing' stamp: ''!
= another
	^ self species = another species and: [ builder = another builder ]! !

!ShAbstractChange methodsFor: 'accessing' stamp: ''!
oldClass
	^ oldClass! !

!ShAbstractChange methodsFor: 'announcing' stamp: ''!
announceChanges
	! !

!ShAbstractChange methodsFor: 'accessing' stamp: ''!
builder
	^ builder! !

!ShAbstractChange methodsFor: 'comparing' stamp: ''!
hash
	^ builder hash.! !

!ShAbstractChange methodsFor: 'testing' stamp: ''!
hasChangeClassSideShape
	^ false.! !

!ShAbstractChange methodsFor: 'propagating' stamp: ''!
propagateToSubclasses: aBuilder! !

!ShAbstractChange methodsFor: 'accessing' stamp: ''!
builder: anObject
	builder := anObject.
! !

!ShAbstractChange methodsFor: 'testing' stamp: ''!
hasToMigrateInstances
	^ false.! !

!ShAbstractChange methodsFor: 'accessing' stamp: ''!
oldClass: anObject
	oldClass := anObject! !

!ShAbstractChange methodsFor: 'testing' stamp: ''!
hasChangeInstanceSideShape
	^ false.! !

!ShAbstractChange class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == ShAbstractChange! !

!ShAbstractChangeDetector commentStamp: ''!
I detect the changes to a given Class.
My subclasses implements 

#compareClass: oldClass with: aBuilder to calculate the changes performed to the class.

I am responsible of adding the changes to the builder..

Check the initialization of the builder in the ShiftClassBuilder and in the ShDefaultBuilderEnhancer to see when the comparers are registered in the Shift class builder.!
!ShAbstractChangeDetector methodsFor: 'accessing' stamp: ''!
builder
	^ builder! !

!ShAbstractChangeDetector methodsFor: 'accessing' stamp: ''!
builder: anObject
	builder := anObject! !

!ShAbstractChangeDetector methodsFor: 'comparing' stamp: ''!
compareClass
	^ self subclassResponsibility ! !

!ShAbstractChangeDetector class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == ShAbstractChangeDetector ! !

!ShAbstractChangeDetector class methodsFor: 'comparing' stamp: ''!
compareClass: oldClass with: aBuilder
	| aComparer changes |
	aComparer := self new.
	aComparer builder: aBuilder.
	
	changes := aComparer compareClass.
	
	changes do:[:e | aBuilder addChange: e].! !

!ShAbstractClassBuilderTest commentStamp: ''!
Abstract Test class for the Shift Class Builder tests!
!ShAbstractClassBuilderTest methodsFor: 'validation' stamp: ''!
doValidateMethods: selectors on: class
	| association |
	class methods
		ifNotEmpty: [ association := class methods anyOne classBinding.
			class methods do: [ :method | method classBinding == association ] ].

	selectors
		do: [ :selector | 
			self assert: (class canUnderstand: selector).
			self assert: (class >> selector) classBinding value identicalTo: class ]! !

!ShAbstractClassBuilderTest methodsFor: 'validation' stamp: ''!
validateSharedVariables: allVariables
	| resultVariables classVar |
	resultVariables  := result classVarNames.

	self assertCollection: resultVariables equals: allVariables.
	allVariables do: [ :each | 
		classVar := result classVariableNamed: each.
		self assert: classVar definingClass equals: result  ]! !

!ShAbstractClassBuilderTest methodsFor: 'validation' stamp: ''!
validateClassSlots: addedSlots superclass: aSuperClass
	| resultSlots allSlots |
	resultSlots := result class allSlots.
	allSlots := aSuperClass class allSlots , addedSlots.

	self
		assert: resultSlots size = allSlots size
		description: (self comparingCollectionBetween: resultSlots and: allSlots).

	allSlots
		with: resultSlots
		do: [ :a :b | 
			self assert: a name equals: b name.
			self assert: a class equals: b class ]! !

!ShAbstractClassBuilderTest methodsFor: 'private - validating' stamp: ''!
validateSuperclass: aSuperclass
	self assert: result superclass identicalTo: aSuperclass! !

!ShAbstractClassBuilderTest methodsFor: 'validation' stamp: ''!
validateResult
	| obj |
	self assert: result isClass.
	self assert: result class isMeta.

	obj := result new.
	self assert: obj isNotNil.
	self assert: obj class identicalTo: result! !

!ShAbstractClassBuilderTest methodsFor: 'validation' stamp: ''!
validateSlots: allSlots
	| resultSlots |
	resultSlots := result allSlots.

	self
		assert: resultSlots size = allSlots size
		description: (self comparingCollectionBetween: resultSlots and: allSlots).

	allSlots
		with: resultSlots
		do: [ :a :b | 
			self assert: a name equals: b name.
			self assert: a class equals: b class ]! !

!ShAbstractClassBuilderTest methodsFor: 'validation' stamp: ''!
validateSharedPools: pools
	self assertCollection: result sharedPools equals: pools asOrderedCollection! !

!ShAbstractClassBuilderTest methodsFor: 'validation' stamp: ''!
validateClassSideMethods: selectors
	self doValidateMethods: selectors on: result class! !

!ShAbstractClassBuilderTest methodsFor: 'validation' stamp: ''!
validateMethods: selectors
	self doValidateMethods: selectors on: result! !

!ShAbstractClassBuilderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	builder := ShiftClassBuilder new.
	builder buildEnvironment: ShSmalltalkGlobalsEnvironment new! !

!ShAbstractClassBuilderTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ self == ShAbstractClassBuilderTest ! !

!ShAbstractClassChangeDetector commentStamp: ''!
I can detect changes in the class structure.
My subclasses provides three blocks:

builderAccessor: a block to access the fill in the builder. 
classAccessor : a block to access in the old class.
comparer: (optional) to compare both values.

By default I have a  comparer. This is a block to compare the values from the old class and the builder.
The subclasses can provide another comparer if they need to. !
!ShAbstractClassChangeDetector methodsFor: 'comparing' stamp: ''!
compareClass
	oldValue := classAccessor value: builder oldClass.
	newValue := builderAccessor value: builder.
	
	^ (comparer value: oldValue value: newValue)
		ifTrue: [ #() ]
		ifFalse: [ self newChanges ]! !

!ShAbstractClassChangeDetector methodsFor: 'changes' stamp: ''!
newChanges
	^ {ShClassChanged new
		builder: builder;
		yourself}.! !

!ShAbstractClassChangeDetector methodsFor: 'changes' stamp: ''!
compareSlotCollection: a with: b
	
	(a size = b size) ifFalse: [ ^ false].

	a with: b do: [ :aSlot :bSlot | 
			(aSlot hasSameDefinitionAs: bSlot) ifFalse: [ ^ false ] ].

	^ true! !

!ShAbstractClassChangeDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	comparer := [:a :b | a = b ].! !

!ShAbstractClassChangeDetector class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == ShAbstractClassChangeDetector! !

!ShAbstractInstanceSideClassChangeDetector commentStamp: ''!
I am an special Class change detector, used when we have to include the change in the instance structure.!
!ShAbstractInstanceSideClassChangeDetector methodsFor: 'changes' stamp: ''!
newChanges
	^ {ShClassChanged new
		builder: builder;
		yourself.
		
		ShInstanceShapeChanged new
		builder: builder;
		yourself.
		} .! !

!ShAbstractInstanceSideClassChangeDetector class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == ShAbstractInstanceSideClassChangeDetector! !

!ShAnonymousClassInstallerTest methodsFor: 'tests' stamp: ''!
testSubclasses
	| aSubClass |
	aSubClass := Smalltalk anonymousClassInstaller make: [ :builder |
		builder superclass: Point.
		builder name: #AnotherPoint.
	].

	self deny: (Point subclasses includes: aSubClass).
	self assert: aSubClass superclass equals: Point.
	self deny: (Smalltalk hasClassNamed: #AnotherPoint).
	
	self assert: (RPackageOrganizer default packageOfClassNamed: #AnotherPoint) equals: nil! !

!ShBitLayoutChangeDetector commentStamp: ''!
I can compare an old class and a builder to detect if the layout kind changed and if there is need to propagate it.!
!ShBitLayoutChangeDetector methodsFor: 'comparing' stamp: ''!
compareClass
	| oldLayout newLayout bitLayoutNames |
	oldLayout := builder oldClass classLayout class name.
	newLayout := builder layoutDefinition layoutClass name.

	oldLayout = newLayout ifTrue: [ ^ #() ].
	bitLayoutNames := BitsLayout allSubclasses collect: [ :e | e name ].

	(bitLayoutNames includes: newLayout)
		ifTrue: [ ^ {(ShBitLayoutChanged new
				builder: builder;
				yourself)} ].

	(bitLayoutNames includes: oldLayout) ifFalse: [ ^ #() ].

	builder layoutDefinition slots size ~= builder oldClass slots size
		ifTrue: [ ^ {(ShBitLayoutChanged new
				builder: builder;
				yourself)} ].
	^ builder oldClass superclass allSlots isNotEmpty
		ifTrue: [ {(ShBitLayoutChanged new
				builder: builder;
				yourself)} ]
		ifFalse: [ #() ]! !

!ShBitLayoutChanged commentStamp: ''!
I detect if there is a change in the layout. 
Specially if there is a change from PointerLayout to BitLayout and if there is need to propagate to the subclasses.!
!ShBitLayoutChanged methodsFor: 'propagating' stamp: ''!
propagateToSubclasses: anotherBuilder
	anotherBuilder layoutDefinition layoutClass: builder layoutDefinition layoutClass ! !

!ShBitLayoutChanged methodsFor: 'propagating' stamp: ''!
hasChangeInstanceSideShape
	^ true.! !

!ShCBClassWithInstanceVariables commentStamp: ''!
I am a test class.!
!ShCBClassWithInstanceVariables methodsFor: 'accessing' stamp: ''!
inheritedSlot

	^ inheritedSlot! !

!ShCBEmptyClass commentStamp: ''!
I am a test class.!
!ShCBEmptyClassWithMethods commentStamp: ''!
I am a test class.!
!ShCBEmptyClassWithMethods methodsFor: 'test methods' stamp: ''!
aMethod
	^ 42! !

!ShCBEmptyClassWithMethods methodsFor: 'test methods' stamp: ''!
anotherMethod: aValue
	^ aValue! !

!ShClassChanged commentStamp: ''!
When there is a change in the class structure I announce that change.
I announce with a copy of the old class and the new class.!
!ShClassChanged methodsFor: 'announcing' stamp: ''!
announceChanges
	SystemAnnouncer uniqueInstance classDefinitionChangedFrom: oldClass to: builder newClass.
	SystemAnnouncer uniqueInstance classModificationAppliedTo: builder newClass! !

!ShClassChanged methodsFor: 'announcing' stamp: ''!
builder: anObject
	builder := anObject.
	oldClass := builder oldClass copyForAnnouncement.! !

!ShClassChanged methodsFor: 'propagating' stamp: ''!
propagateToSubclasses: anotherBuilder

	anotherBuilder changes add: (ShSuperclassChanged new
		builder: builder;
		oldClass: oldClass;
		yourself
	).! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testChangingASharedPoolUpdatesCorrectlyUsers
	
	newClass := ShiftClassInstaller
		make: [ :builder | 
			builder
				name: #ShCITestSharedPool;
				superclass: SharedPool;
				sharedVariables: #(A B C);
				category: 'Shift-ClassInstaller-Tests' ].
			
	newClass2 := ShiftClassInstaller
		make: [ :builder | 
			builder
				name: #ShCITestClass;
				sharedPools: 'ShCITestSharedPool';
				category: 'Shift-ClassInstaller-Tests' ].
	
	newClass2 compile: 'a ^A'.
	
	self assert: ((newClass2 >> #a) literals at: 1) identicalTo: (newClass classVariableNamed: #A).
	
	newClass := ShiftClassInstaller
		make: [ :builder | 
			builder
				name: #ShCITestSharedPool;
				superclass: SharedPool;
				sharedVariables: #(A B C D);
				category: 'Shift-ClassInstaller-Tests' ].

	self assert: ((newClass2 >> #a) literals at: 1) identicalTo: (newClass classVariableNamed: #A)! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testClassWithSlotCallsInitializeSlotOnInstanceCreation

	| className someInstance |
	className := #ShClassWithNormalSlots.
	newClass := self newClass: className slots: { #someSlot => ShTestSlot }.

	someInstance := newClass	new.
	
	"The slot should have initialized the value"
	self assert: (someInstance readSlotNamed: #someSlot) equals: 'initialized'! !

!ShClassInstallerTest methodsFor: 'instance creation' stamp: ''!
newClass: className slots: slots
	^ self newClass: className superclass: Object slots: slots! !

!ShClassInstallerTest methodsFor: 'instance creation' stamp: ''!
newClass: className superclass: aSuperclass slots: slots metaclassSlots: metaclassSlots
	^ ShiftClassInstaller
		make: [ :builder | 
			builder
				name: className;
				superclass: aSuperclass;
				slots: slots;
				classSlots: metaclassSlots;
				sharedVariables: '';
				sharedPools: '';
				category: 'Shift-ClassInstaller-Tests' ]! !

!ShClassInstallerTest methodsFor: 'instance creation' stamp: ''!
newClass: className slots: slots metaclassSlots: metaclassSlots
	
	^ self newClass: className superclass: Object  slots: slots metaclassSlots: metaclassSlots! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testDuplicatedInstanceVariableInSuperclass
	
	superClass := self newClass: #ShCITestClass1 slots: #().
	newClass := self newClass: #ShCITestClass2 superclass: superClass slots: #(aSlot).

	[ superClass := self newClass: #ShCITestClass1 slots: #(aSlot).
	self fail ]
		on: DuplicatedSlotName
		do: [ :ex | self deny: ex isResumable ].		
	self deny: ((superClass slots collect: [:e | e name]) includes: 'aSlot')! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testDuplicateClassPreserveMethods
	
	newClass := self newClass: #ShCITestClass slots: {#anInstanceVariable => BooleanSlot}.
	newClass compile: 'm1 ^ 42'.
	newClass class compile: 'm2 ^ 42'.
	
	newClass2 := newClass duplicateClassWithNewName: #ShCITestClass2.
	
	self assert: (newClass2 includesSelector: #m1).
	self assert: (newClass2 class includesSelector: #m2)	! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testModifyingSuperclassInOtherOrder
	| obj |
	superClass := self newClass:#ShCITestClass slots:#(anInstanceVariable).
	subClass := self newClass:#ShCISubTestClass superclass: superClass slots:#(anSubInstanceVariable).
	newClass := self newClass: #ShCITestSubClass superclass: subClass slots: #().
	
	superClass new instVarNamed: #anInstanceVariable.
	newClass new instVarNamed: #anInstanceVariable.	

	obj := newClass new.	
	obj instVarNamed: #anInstanceVariable put: 7.
	obj instVarNamed: #anSubInstanceVariable put: 17.
			
	superClass := self newClass:#ShCITestClass slots:#(otherVariable anInstanceVariable).

	self assert: (obj instVarNamed: #anInstanceVariable) equals: 7.
	self assert: (obj instVarNamed: #anSubInstanceVariable) equals: 17
! !

!ShClassInstallerTest methodsFor: 'instance creation' stamp: ''!
newClass: className superclass: aSuperclass slots: slots
	
	^ self newClass: className superclass: aSuperclass  slots: slots metaclassSlots: #()! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testDuplicatedInstanceVariableInSuperclassMetaclass
	
	superClass := self newClass: #ShCITestClass1 slots: #() metaclassSlots: #().
	newClass := self 
		newClass: #ShCITestClass2 superclass: superClass 
		slots: #() metaclassSlots: #(aSlot).

	[ superClass := self newClass: #ShCITestClass1 slots: #() metaclassSlots: #(aSlot).
	self fail ]
		on: DuplicatedSlotName
		do: [ :ex | self deny: ex isResumable ].		
	self deny: ((superClass class slots collect: [:e | e name]) includes: 'aSlot')! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testModifyingClassSideInstances
	superClass := self newClass:#ShCITestClass slots:#(anInstanceVariable).
	newClass := self newClass: #ShCITestSubClass superclass: superClass slots: #().
	
	superClass class addInstVarNamed: #aVariable.

	self assert: (superClass class hasSlotNamed: #aVariable).
	self assert: (newClass class hasSlotNamed: #aVariable)! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testDuplicateClassPreserveClassSlots
	
	newClass := ShiftClassInstaller
		make: [ :builder | 
			builder
				name: #ShCITestClass;
				superclass: Object;
				classSlots: {#aClassInstanceVariable => InstanceVariableSlot};
				category: 'Shift-ClassInstaller-Tests' ].
	
	newClass2 := newClass duplicateClassWithNewName: #ShCITestClass2.
	
	self assert: (newClass2 class hasSlotNamed: #aClassInstanceVariable).
	self assert: (newClass2 class slotNamed: #aClassInstanceVariable) class equals: InstanceVariableSlot
	! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testTryingToModifyReadOnlyInstances
	| obj obj2 |
	newClass := self newClass: #ShCITestClass slots: #(anInstanceVariable).
	
	obj := newClass new.	
	obj instVarNamed: #anInstanceVariable put: 7.
	obj beReadOnlyObject.
			
	obj2 := newClass new.	
	obj2 instVarNamed: #anInstanceVariable put: 17.

	self newClass:#ShCITestClass slots:#(otherVariable anInstanceVariable).

	self assert: obj isReadOnlyObject	
! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testChangingSuperclassToOther
	superClass := self newClass: #ShCITestClass slots: #(var1).
	superClass2 := self newClass: #ShCITestClass2 slots: #().
	subClass := self newClass: #ShCISubTestClass superclass: superClass2 slots: #().

	subClass := self newClass: #ShCISubTestClass superclass: superClass slots: #().

	superClass2 := self newClass: #ShCITestClass2 superclass: superClass slots: #().

	self denyEmpty: superClass subclasses.
	self assertEmpty: superClass2 subclasses.
	self assertCollection: superClass subclasses equals: {subClass . superClass2}.
	self assert: subClass superclass equals: superClass.
	self assert: superClass2 superclass equals: superClass! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testModifyingClassKeepsOrganizationOfMethods
	newClass := self newClass: #ShCITestClass superclass: subClass slots: #().

	newClass compile: 'aMethod ^ 42' classified: #'useful-message' notifying: nil.
	newClass class compile: 'aClassMethod ^ 21' classified: #'useful-message' notifying: nil.

	self assert: (newClass >> #aMethod) protocol equals: #'useful-message'.
	self assert: (newClass class >> #aClassMethod) protocol equals: #'useful-message'.	
	
	newClass := self newClass: #ShCITestClass superclass: subClass slots: #(aSlot).

	self assert: (newClass >> #aMethod) protocol equals: #'useful-message'.
	self assert: (newClass class >> #aClassMethod) protocol equals: #'useful-message'
! !

!ShClassInstallerTest methodsFor: 'running' stamp: ''!
tearDown
	newClass ifNotNil: #removeFromSystem.
	newClass2 ifNotNil: #removeFromSystem.

	subClass ifNotNil: #removeFromSystem.
	superClass ifNotNil: #removeFromSystem.
	superClass2 ifNotNil: #removeFromSystem.
	
	super tearDown! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testTryingToModifyReadOnlySubInstances
	| obj obj2 |
	superClass := self newClass: #ShCITestSuperClass slots: #(aSuperVariable).
	newClass := self newClass: #ShCITestClass superclass: superClass slots: #(anInstanceVariable).
	
	obj := newClass new.	
	obj instVarNamed: #aSuperVariable put: 1.
	obj instVarNamed: #anInstanceVariable put: 7.
	obj beReadOnlyObject.
			
	obj2 := newClass new.	
	obj2 instVarNamed: #aSuperVariable put: 11.
	obj2 instVarNamed: #anInstanceVariable put: 17.

	self newClass:#ShCITestClass slots:#(otherVariable anInstanceVariable).
	
	self assert: obj isReadOnlyObject	
! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testDuplicatedInstanceVariable
	superClass := self newClass: #ShCITestClass1 slots: #(aSlot).
	newClass := self newClass: #ShCITestClass2 superclass: superClass slots: #().

	"The DuplicatedSlotName should not be resumable. If it is resume, the process will generate
   duplicated instance variables. The shadowing of IV is not possible in Pharo."
	[ newClass := self newClass: #ShCITestClass2 superclass: superClass slots: #(aSlot).
	self fail ]
		on: DuplicatedSlotName
		do: [ :ex | self deny: ex isResumable ]! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testClassWithSlotHasInitializeMethodWithInitializeSlots

	| className |
	className := #ShClassWithNormalSlots.
	newClass := self newClass: className slots: { #someSlot => ShTestSlot }.
	
	self assert: ((newClass >> #initialize) ast statements
		includes: (RBParser parseExpression: 'self class initializeSlots: self'))! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testDuplicateClassPreserveSlots
	
	newClass := self newClass: #ShCITestClass slots: {#anInstanceVariable => BooleanSlot}.
	newClass2 := newClass duplicateClassWithNewName: #ShCITestClass2.
	
	self assert: (newClass2 hasSlotNamed: #anInstanceVariable).
	self assert: (newClass2 slotNamed: #anInstanceVariable) class equals: BooleanSlot
	! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testChangingSuperclassInTheHierarchy

	superClass := self newClass:#ShCITestClass slots:#(var1 var2).
	superClass2 := self newClass:#ShCITestClass2 slots:#().
	subClass := self newClass:#ShCISubTestClass superclass: superClass2 slots:#().

   superClass2 := self newClass:#ShCITestClass2 superclass: superClass slots:#().

	self deny: superClass subclasses isEmpty.
	self assertCollection: superClass2 subclasses equals: { subClass }. 
	self assertCollection: superClass subclasses equals: { superClass2 }. 
	self assert: subClass superclass equals: superClass2.
	self assert: superClass2 superclass equals: superClass
! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testModifyingSuperclass
	superClass := self newClass:#ShCITestClass slots:#(anInstanceVariable).
	newClass := self newClass: #ShCITestSubClass superclass: superClass slots: #().
	
	superClass new instVarNamed: #anInstanceVariable.
	newClass new instVarNamed: #anInstanceVariable.	
	
	superClass := self newClass:#ShCITestClass slots: #(anInstanceVariable otherVariable).

	superClass new instVarNamed: #anInstanceVariable.
	newClass new instVarNamed: #anInstanceVariable.	
	superClass new instVarNamed: #otherVariable.
	newClass new instVarNamed: #otherVariable
! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testClassWithComment
	newClass := ShiftClassInstaller
		make: [ :builder | 
			builder
				name: #SHClassWithComment;
				superclass: Object;
				slots: #();
				sharedVariables: '';
				sharedPools: '';
				category: 'Shift-ClassInstaller-Tests';
				comment: 'I have a comment'; 
				commentStamp: 'anStamp' ].
	
	self assert: newClass comment equals: 'I have a comment'.
	self assert: newClass organization commentStamp equals: 'anStamp'! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testChangingSlotCallsInitializeSlotOnInstanceMigration

	| className someInstance |
	className := #ShClassWithNormalSlots.
	newClass := self newClass: className slots:#( someSlot ).
	someInstance := newClass	new.

	"Migrate the class changing the slot definition"
	self newClass: className slots: { #someSlot => ShTestSlot }.
	
	"The slot should have initialized the value"
	self assert: (someInstance readSlotNamed: #someSlot) equals: 'initialized'! !

!ShClassInstallerTest methodsFor: 'tests' stamp: ''!
testChangingHierarchy
	"Testing that the changes in the superclasses are propagated to the subclasses"

	superClass := self newClass:#ShCITestClass1 slots:#().
	newClass := self newClass:#ShCITestClass2 superclass: superClass slots:#(aSlot).
	self assert: newClass classLayout slotScope parentScope equals: superClass classLayout slotScope.

	superClass2 := self newClass:#ShCITestClass0 slots:#(anotherSlot).
	superClass := self newClass:#ShCITestClass1 superclass: superClass2 slots:#().
	
	self assert: newClass classLayout slotScope parentScope equals: superClass classLayout slotScope.
	self assert: superClass classLayout slotScope parentScope equals: superClass2 classLayout slotScope.	
	self assertCollection: (newClass allSlots collect: [:each | each name]) hasSameElements: #(aSlot anotherSlot)
! !

!ShClassSlotChangeDetector commentStamp: ''!
I know how to detect a change in the collection of slots of the metaclass.!
!ShClassSlotChangeDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	builderAccessor := [ :e | e layoutDefinition classSlots ].
	classAccessor := [ :e | e class slots ].
	comparer := [ :a :b |  self compareSlotCollection: a with: b ]	! !

!ShClassSlotChangeDetector methodsFor: 'changes' stamp: ''!
newChanges
	^ {(ShMetaclassChanged new
		builder: builder;
		yourself)}! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testSharedVariablesWithSlot
	builder name: #SHClassWithSharedVariable.
	self should: [ builder sharedVariablesFromString: {#aSharedVariable asSlot} ] raise: Error! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testSharedVariablesAsString
	builder name: #SHClassWithSharedVariable.
	result := builder
		sharedVariablesFromString: 'aSharedVariable';
		build.

	self validateResult.
	self validateSuperclass: Object.
	self validateSharedVariables: #(aSharedVariable)! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testWordLayout
	builder name: #SHClassWithWordLayout.
	result := builder
		layoutClass: WordLayout;
		build.

	self validateResult.
	self validateSuperclass: Object.
	self validateSlots: #().

	self assert: result classLayout class equals: WordLayout! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testSharedPool
	builder name: #SHClassWithSharedPool.
	result := builder
		sharedPools: 'ShTestSharedPool';
		build.

	self validateResult.
	self validateSuperclass: Object.
	self validateSharedPools: {ShTestSharedPool}! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testEmptyClass
	builder name: #SHTestEmptyClass.
	result := builder build.
	
	self validateResult.
	self validateSuperclass: Object
! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testSharedVariablesAsArray
	builder name: #SHClassWithSharedVariable.
	result := builder
		sharedVariablesFromString: #(aSharedVariable);
		build.

	self validateResult.
	self validateSuperclass: Object.
	self validateSharedVariables: #(aSharedVariable)! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testClassWithClassSlots
	builder
		name: #SHTestClassWithClassSlots;
		slots: #(anSlot);
		classSlots: #(aClassSlot).

	result := builder build.

	self validateResult.
	self validateSuperclass: Object.
	self
		validateSlots:
			{#anSlot => InstanceVariableSlot}.
			
	self
		validateClassSlots:
			{#aClassSlot => InstanceVariableSlot.}
		superclass: Object! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testSharedVariables
	builder name: #SHClassWithSharedVariable.
	result := builder
		sharedVariables: {(#aSharedVariable => ClassVariable)};
		build.

	self validateResult.
	self validateSuperclass: Object.
	self validateSharedVariables: #(aSharedVariable)! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testClassWithSlots
	builder
		name: #SHTestClassWithSlots;
		slots: #(anSlot anotherSlot).

	result := builder build.

	self validateResult.
	self validateSuperclass: Object.
	self
		validateSlots:
			{(#anSlot => InstanceVariableSlot).
			(#anotherSlot => InstanceVariableSlot)}! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testVariableLayout
	builder name: #SHClassWithVariableLayout.
	result := builder
		slots: #(anSlot);
		layoutClass: VariableLayout ;
		build.

	self validateResult.
	self validateSuperclass: Object.
	self validateSlots: {#anSlot => InstanceVariableSlot}.

	self assert: result classLayout class equals: VariableLayout! !

!ShCreateClassTest methodsFor: 'tests' stamp: ''!
testClassWithInheritedSlots
	builder
		name: #SHTestClassWithInheritedSlots;
		superclassName: #ShCBClassWithInstanceVariables;
		slots: #(anSlot anotherSlot).

	result := builder build.

	self validateResult.
	self validateSuperclass: ShCBClassWithInstanceVariables.
	self
		validateSlots:
			{#inheritedSlot => InstanceVariableSlot.
			#anSlot => InstanceVariableSlot.
			#anotherSlot => InstanceVariableSlot}! !

!ShDefaultBuilderEnhancer commentStamp: ''!
I am notified of all the events and modifications performed by the ShiftClassBuilder.

I am the point of extension to add new features to it in a modular way.
Also I can configure the builder to add more comparers or do additional things.!
!ShDefaultBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
configureMetaclass: newMetaclass superclass: superclass withLayoutType: aLayoutType slots: classSlots
	newMetaclass superclass: superclass withLayoutType: aLayoutType slots: classSlots! !

!ShDefaultBuilderEnhancer methodsFor: 'migrating' stamp: ''!
hasToSkipSlot: aSlot
	^ Class hasSlotNamed: aSlot name! !

!ShDefaultBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
newMetaclass: builder
	^ builder metaclassClass new! !

!ShDefaultBuilderEnhancer methodsFor: 'migrating' stamp: ''!
beforeMigratingClass: aBuilder installer: anInstaller
! !

!ShDefaultBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
propagateChangesToRelatedClasses: newClass installer: installer
	
	newClass subclasses do: [ :e | installer remake: e ]
! !

!ShDefaultBuilderEnhancer methodsFor: 'initialization' stamp: ''!
initializeBuilder: aBuilder

	aBuilder addChangeComparer: ShSharedPoolChangeDetector.
	aBuilder addChangeComparer: ShSharedVariablesChangeDetector.
	aBuilder addChangeComparer: ShSlotChangeDetector.
	aBuilder addChangeComparer: ShLayoutChangeDetector.
	aBuilder addChangeComparer: ShBitLayoutChangeDetector.
	aBuilder addChangeComparer: ShClassSlotChangeDetector.
	aBuilder addChangeComparer: ShSuperclassChangedDetector.
	aBuilder addChangeComparer: ShMetaclassChangeDetector
! !

!ShDefaultBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
compileMethodsFor: aBuilder
	aBuilder compileMethods ! !

!ShDefaultBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
on: newClass declareClassVariables: sharedVariables sharing: sharedPoolsString
	newClass
		declareClassVariables: sharedVariables;
		sharing: sharedPoolsString! !

!ShDefaultBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
validateRedefinition: anOldClass
	"Subclasses can validate that the new definition is coherent with the old class"! !

!ShDefaultBuilderEnhancer methodsFor: 'events' stamp: ''!
migrateInstancesTo: aClass installer: aShiftClassInstaller 

	aShiftClassInstaller migrateInstancesTo: aClass! !

!ShDefaultBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
configureClass: newClass superclass: superclass withLayoutType: layoutType slots: slots
	newClass superclass: superclass withLayoutType: layoutType slots: slots! !

!ShDefaultBuilderEnhancer methodsFor: 'events' stamp: ''!
metaclassCreated: builder! !

!ShDefaultBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
afterMethodsCompiled: builder! !

!ShDefaultBuilderEnhancer methodsFor: 'migrating' stamp: ''!
afterMigratingClass: aBuilder installer: anInstaller
! !

!ShDefaultBuilderEnhancer methodsFor: 'initialization' stamp: ''!
fillBuilder: aBuilder from: aClass ! !

!ShDefaultBuilderEnhancer methodsFor: 'events' stamp: ''!
migrateToClass: aClass installer: aShiftClassInstaller 

	aShiftClassInstaller migrateClassTo: aClass! !

!ShDefaultBuilderEnhancer methodsFor: 'events' stamp: ''!
classCreated: builder! !

!ShDefaultBuilderEnhancer class methodsFor: 'testing' stamp: ''!
isApplicableFor: aBuilder
	^ false! !

!ShGlobalsEnvironment commentStamp: ''!
I wrap an environment used by the ShiftClassBuilder. 
In this way the environment can be anything in the system. !
!ShGlobalsEnvironment methodsFor: 'accessing' stamp: ''!
bindingAt: aString 
	
	^ environment bindingOf: aString! !

!ShGlobalsEnvironment methodsFor: 'accessing' stamp: ''!
environment: anObject
	environment := anObject! !

!ShGlobalsEnvironment methodsFor: 'testing' stamp: ''!
hasClassNamed: aName
	^ environment hasClassNamed: aName! !

!ShGlobalsEnvironment methodsFor: 'accessing' stamp: ''!
classNamed: aString ifAbsent: aBlockClosure 
	
	^ environment at: aString ifAbsent: aBlockClosure! !

!ShGlobalsEnvironment methodsFor: 'installation' stamp: ''!
installClass: aClass withName: aString 
	
	environment at: aString put: aClass! !

!ShGlobalsEnvironment methodsFor: 'accessing' stamp: ''!
organization
	
	^ environment organization! !

!ShGlobalsEnvironment methodsFor: 'accessing' stamp: ''!
environment
	^ environment! !

!ShGlobalsEnvironment methodsFor: 'accessing' stamp: ''!
classNamed: aName
	^ environment classNamed:aName! !

!ShInstanceShapeChanged commentStamp: ''!
I signal when there is need to migrate the instances. 
Of course if I migrate the instances, this change is propagated to the subclasses.
I propagate the changes adding a change like me in the subclasses.!
!ShInstanceShapeChanged methodsFor: 'testing' stamp: ''!
hasChangeInstanceSideShape
	^ true.! !

!ShInstanceShapeChanged methodsFor: 'testing' stamp: ''!
propagateToSubclasses: anotherBuilder
	anotherBuilder changes add: self.! !

!ShInstanceShapeChanged methodsFor: 'testing' stamp: ''!
hasToMigrateInstances
	^ true.! !

!ShLayoutChangeDetector commentStamp: ''!
I know how to detect a change in the layout of a class.!
!ShLayoutChangeDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	builderAccessor := [ :e | e layoutDefinition layoutClass ].
	classAccessor := [ :e | e classLayout class ]! !

!ShLayoutDefinition commentStamp: ''!
I am an internal object used by the ShiftClassBuilder to represent the layout of a class.!
!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
sharedVariables: anObject
	sharedVariables := anObject! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
copy: slotCollection ifUsedIn: aClass
	"I only copy the slot if it is not virtual and it is the same in the oldClass. 
	 They are copied as they have the index as instance variable, the index can change in the new class."
	
	aClass slots isEmpty ifTrue: [ ^ slotCollection ].
	
	^ slotCollection
		collect: [ :aSlot | 
			aClass
				slotNamed: aSlot name
				ifFound: [ :oldSlot | 
					(oldSlot == aSlot and: [ aSlot isVirtual not ])
						ifTrue: [ aSlot copy ]
						ifFalse: [ aSlot ] ]
				ifNone: [ aSlot ] ]! !

!ShLayoutDefinition methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	slots := #().
	sharedPools := #().
	sharedVariables := #()
! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
slots
	^ slots! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
sharedPools: anObject
	sharedPools := anObject! !

!ShLayoutDefinition methodsFor: 'printing' stamp: ''!
sharedPoolsString
	^ self sharedPools joinUsing: Character space! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
builder: anObject
	builder := anObject! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
sharedVariables
	^ sharedVariables! !

!ShLayoutDefinition methodsFor: 'validating' stamp: ''!
validate
	
	| slotNames classSlotNames |
	builder oldClass ifNil: [ ^ self ].

	slotNames := slots collect: [ :e | e name ].
	classSlotNames := classSlots collect: [ :e | e name ].

	builder oldClass subclassesDo: [ :aSubclass | 
		aSubclass slots do: [ :anotherSlot | 
			(slotNames includes: anotherSlot name) ifTrue: [ 
				DuplicatedSlotName new
						oldSlot: anotherSlot;
						newSlot: nil;
						host: aSubclass;
						signal 
			] ]	 ].
	
	builder oldClass subclassesDo: [ :aSubclass | 
		aSubclass class slots do: [ :anotherSlot | 
			(classSlotNames includes: anotherSlot name) ifTrue: [ 
				DuplicatedSlotName new
						oldSlot: anotherSlot;
						newSlot: nil;
						host: aSubclass class;
						signal 
			] ]	 ]! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
sharedVariablesString
	^ (sharedVariables collect:[:e | e key]) joinUsing: ' '! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
copySlotsIfUsedIn: oldClass
	"I copy the slots if they are used in oldClass. As the slots has state (usually the index) they cannot be shared between the old and the new class."

	oldClass ifNil: [ ^ self ].
	
	slots := self copy: slots ifUsedIn: oldClass.
	classSlots := self copy: self classSlots ifUsedIn: oldClass class
! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
allSlots
	| superclass | 
	superclass := builder superclass.
	^ (superclass ifNil: [ #() ] ifNotNil: [ superclass allSlots ]) , slots! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
classSlots: anObject
	classSlots := anObject collect: [ :e | e asSlot ]! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
layoutClass
	^ layoutClass ifNil: [ builder classNamed: #FixedLayout ]! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
classSlots
	^ classSlots ifNil: [ #() ]! !

!ShLayoutDefinition methodsFor: 'copying' stamp: ''!
copyClassSlotsIfNeeded: oldSlots 

	classSlots ifNotNil: [ ^ self ].

	classSlots := oldSlots 
		select: [:each | each isDefinedByOwningClass ] 
		thenCollect: [ :each | each copy index: nil; yourself ]! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
layoutClass: anObject
	layoutClass := anObject! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
slots: anObject
	slots := anObject collect: [ :e | e asSlot ]! !

!ShLayoutDefinition methodsFor: 'accessing' stamp: ''!
sharedPools
	^ sharedPools! !

!ShLayoutDefinition methodsFor: 'testing' stamp: ''!
isBits
	^ self layoutClass new isBits! !

!ShMetaclassChangeDetector commentStamp: ''!
I am responsible of detecting when a class changes its metaclass.!
!ShMetaclassChangeDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	builderAccessor := [ :e | e metaclassClass ].
	classAccessor := [ :e | e class class ].
	comparer := [ :a :b |  a name = b name ]	! !

!ShMetaclassChangeDetector methodsFor: 'changes' stamp: ''!
newChanges

	^ {(ShInstanceShapeChanged new
		builder: builder;
		yourself)}! !

!ShMetaclassChanged commentStamp: ''!
When there is a change in the metaclass structure I announce that change.
I announce with a copy of the old class and the new class.!
!ShMetaclassChanged methodsFor: 'propagating' stamp: ''!
hasChangeClassSideShape
	^ true.! !

!ShMetaclassChanged methodsFor: 'propagating' stamp: ''!
propagateToSubclasses: anotherBuilder
	anotherBuilder changes add: self! !

!ShMetaclassChanged methodsFor: 'accessing' stamp: ''!
builder: anObject
	super builder: anObject.
	oldClass := builder oldClass copyForAnnouncement.! !

!ShMetaclassChanged methodsFor: 'announcing' stamp: ''!
announceChanges
	SystemAnnouncer uniqueInstance classDefinitionChangedFrom: oldClass class to: builder newMetaclass.
	SystemAnnouncer uniqueInstance classModificationAppliedTo: builder newMetaclass! !

!ShModifyClassTest methodsFor: 'tests' stamp: ''!
testEmptyClass
	builder name: #ShCBEmptyClass.
	result := builder build.
	
	self validateResult.
	self validateSuperclass: Object.
	self validateMethods: #()
! !

!ShModifyClassTest methodsFor: 'tests' stamp: ''!
testEmptyClassWithMethods
	builder name: #ShCBEmptyClassWithMethods.
	result := builder build.
	
	self validateResult.
	self validateSuperclass: Object.
	self validateMethods: #(aMethod anotherMethod:)
! !

!ShNoChangesInClass commentStamp: ''!
This notification is raised if there is no changes in a class when invoked the class builder.!
!ShSharedPoolChangeDetector commentStamp: ''!
I know how to detect a change in the shared pools.!
!ShSharedPoolChangeDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	builderAccessor := [ :e | e layoutDefinition sharedPools asArray ].
	classAccessor := [ :e | (e sharedPools collect:[:x | x name]) asArray ]! !

!ShSharedVariablesChangeDetector commentStamp: ''!
I know how to detect a change in the collection of the shared variables (class variables).!
!ShSharedVariablesChangeDetector methodsFor: 'initialization' stamp: ''!
compareFrom: a to: b	
	^ a asDictionary = b asDictionary.! !

!ShSharedVariablesChangeDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	builderAccessor := [ :e | e layoutDefinition sharedVariables collect:[ :x | x key -> x class ] as: Array ].
	classAccessor := [ :e | e classVariables collect: [ :x | x key -> x class ] as: Array ].
	comparer := [ :a :b | self compareFrom: a to: b ]! !

!ShSlotChangeDetector commentStamp: ''!
I know how to detect a change in the collection of slots.!
!ShSlotChangeDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	builderAccessor := [ :e | e layoutDefinition allSlots asArray ].
	classAccessor := [ :e | e allSlots asArray].
	comparer := [ :a :b |  self compareSlotCollection: a with: b ]! !

!ShSmalltalkGlobalsEnvironment commentStamp: ''!
I represent the Smalltalk globals environment. 
I am used to generate the classes by the ShiftClassBuilder when it is using directly the Smalltalk environment.!
!ShSmalltalkGlobalsEnvironment methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self environment: Smalltalk globals! !

!ShSmalltalkGlobalsEnvironment methodsFor: 'accessing' stamp: ''!
classNamed: aName
	^ environment at: aName asSymbol ifAbsent: [ nil ]! !

!ShSuperclassChanged commentStamp: ''!
I model the change in a superclass that should be propagated to the subclasses.!
!ShSuperclassChanged methodsFor: 'testing' stamp: ''!
propagateToSubclasses: anotherBuilder
	anotherBuilder changes add: self! !

!ShSuperclassChanged methodsFor: 'testing' stamp: ''!
hasToMigrateInstances
	^ true.! !

!ShSuperclassChangedDetector commentStamp: ''!
I detect if there is a change in the superclass!
!ShSuperclassChangedDetector methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	builderAccessor := [ :e | e superclass ].
	classAccessor := [ :e | e superclass ]! !

!ShTestSharedPool commentStamp: ''!
I am a test class.!
!ShTestSlot commentStamp: ''!
A test slot used in ShClassInstallerTest!
!ShTestSlot methodsFor: 'initialization' stamp: ''!
wantsInitialization

	^ true! !

!ShTestSlot methodsFor: 'initialization' stamp: ''!
write: aValue to: anObject

	^(self read: anObject)
		ifNil: [ super write: aValue to: anObject ]! !

!ShTestSlot methodsFor: 'initialization' stamp: ''!
initialize: anObject

	super write: 'initialized' to: anObject! !

!ShadowDrawingCanvas commentStamp: ''!
see ColorMappingCanvas comment.!
!ShadowDrawingCanvas methodsFor: 'testing' stamp: ''!
isShadowDrawing
	^true! !

!ShadowDrawingCanvas methodsFor: 'initialization' stamp: ''!
on: aCanvas
	myCanvas := aCanvas.
	shadowColor := Color black.! !

!ShadowDrawingCanvas methodsFor: 'accessing' stamp: ''!
shadowColor: aColor
	shadowColor := aColor! !

!ShadowDrawingCanvas methodsFor: 'private' stamp: ''!
mapColor: aColor
	aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..."
	^aColor isTransparent
		ifTrue:[aColor]
		ifFalse:[shadowColor]! !

!ShadowDrawingCanvas methodsFor: 'accessing' stamp: ''!
shadowColor
	^shadowColor! !

!ShadowDrawingCanvas methodsFor: 'private' stamp: ''!
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."

	^ rule = Form paint
		ifTrue: [ myCanvas
				stencil: aForm
				at: aPoint
				sourceRect: sourceRect
				color: shadowColor ]
		ifFalse: [ myCanvas fillRectangle: (sourceRect translateBy: aPoint) color: shadowColor ]! !

!Shape commentStamp: ''!
I am an abstract class that knows my bounds and if a point is contained in me.!
!Shape methodsFor: 'accessing' stamp: ''!
bounds
	"Answer a rectangle that encloses the receiver."

	self subclassResponsibility! !

!Shape methodsFor: 'testing' stamp: ''!
basicContainsPoint: aPoint
	"Answer whether the receiver contains the given point."

	^self bounds containsPoint: aPoint! !

!Shape methodsFor: 'testing' stamp: ''!
containsPoint: aPoint
	"Answer whether the receiver contains the given point."

	^self basicContainsPoint: aPoint! !

!SharedPool commentStamp: ''!
A shared pool represents a set of bindings which are accessible to all classes which import the pool in its 'pool dictionaries'. SharedPool is NOT a dictionary but rather a name space. Bindings are represented by 'class variables' - as long as we have no better way to represent them at least.!
!SharedPool class methodsFor: 'queries' stamp: ''!
methodsAccessingPoolVariables
	"Answer all methods that use one of the variables defined by the shared pool"
	^ self classVariables flatCollect: [ :variable | variable usingMethods ]! !

!SharedPool class methodsFor: 'queries' stamp: ''!
poolUsers
	"Answer all classes that uses the shared pool"

	^self environment allClasses select:  [:class | class includesSharedPoolNamed: self name]! !

!SharedPool class methodsFor: 'testing' stamp: ''!
isPool
	^true! !

!SharedPool class methodsFor: 'name lookup' stamp: ''!
bindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver"

	^ (self localBindingOf: varName) ifNil: [ self superclass bindingOf: varName ]! !

!SharedPool class methodsFor: 'testing' stamp: ''!
isUsed
	^super isUsed or: [self poolUsers isNotEmpty]! !

!SharedPool class methodsFor: 'name lookup' stamp: ''!
bindingsDo: aBlock
	^self classPool bindingsDo: aBlock! !

!SharedPool class methodsFor: 'name lookup' stamp: ''!
localBindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver without accessing the superclass"
	| aSymbol binding |
	aSymbol := varName asSymbol.

	"First look in classVar dictionary."
	binding := self classPool bindingOf: aSymbol.
	binding ifNotNil:[^binding].

	"Next look in shared pools."
	self sharedPools do:[:pool | 
		binding := pool bindingOf: aSymbol.
		binding ifNotNil:[^binding].
	].

	"subclassing and environment are not preserved"
	^nil! !

!SharedPool class methodsFor: 'name lookup' stamp: ''!
classBindingOf: varName
	"For initialization messages grant the regular scope"
	^super bindingOf: varName! !

!SharedPool class methodsFor: 'testing' stamp: ''!
includesKey: aName
	"does this pool include aName"
	^(self localBindingOf: aName) notNil! !

!SharedPool class methodsFor: 'queries' stamp: ''!
usingMethods
	"Answer all methods that reference the Pool the variables defined by the shared pool"
	^super usingMethods, self methodsAccessingPoolVariables! !

!SharedPoolTest commentStamp: ''!
Tests related to SharedPool!
!SharedPoolTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testusingMethods
	| result |
	result := ChronologyConstants usingMethods.
	"we find accesses to the vars of the shared pool"
	self assert: (result includes: Duration>>#asNanoSeconds).
	"and we find references to the pool itself"
	self assert: (result includes: ClassTest>>#testSharedPoolOfVarNamed)! !

!SharedPoolTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testmethodsAccessingPoolVariables
	| result |
	result := ChronologyConstants methodsAccessingPoolVariables.
	"we find accesses to the vars of the shared pool"
	self assert: (result includes: Duration>>#asNanoSeconds).
	"but we do not include references to the pool itself"
	self deny: (result includes: ClassTest>>#testSharedPoolOfVarNamed)! !

!SharedPoolTest methodsFor: 'tests' stamp: ''!
testIncludesKey

	self assert: (ChronologyConstants includesKey: #DayNames).
	self deny: (ChronologyConstants includesKey: #DependentsFields)! !

!SharedPoolTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testPoolUsers
	| result |
	result := ChronologyConstants poolUsers.
	self assert: result asSet equals: {Date. DateAndTime. Duration. Month. Time. TimeZone. Week. LocalTimeZone . AbstractTimeZone. ExampleForTestWithSharedPool } asSet.! !

!SharedQueue commentStamp: ''!
An implementation of a shared queue based on class Monitor.  Clients may may place items on the queue using nextPut: or remove them using methods like next or nextOrNil.  Items are removed in first-in first-out (FIFO) order.  It is safe for multiple threads to access the same shared queue, which is why this is a "shared" queue.

[monitor] is used to synchronize access from multiple threads.

[items] is an ordered collection holding the items that are in the queue.  New items are added  at the end, and old items are removed from the beginning.

All methods must hold the monitor while they run.
!
!SharedQueue methodsFor: 'accessing' stamp: 'nil'!
findFirst: aBlock
	"Answer the next object that satisfies aBlock, skipping any intermediate objects.
	If no such object has been queued, answer <nil> and leave me intact."

	
	^monitor critical: [ | index |
		index := items findFirst: aBlock.
		index = 0 ifTrue: [
			nil ]
		ifFalse: [
			items removeAt: index ] ].! !

!SharedQueue methodsFor: 'size' stamp: 'nil'!
isEmpty
	^monitor critical: [ items isEmpty ]! !

!SharedQueue methodsFor: '*TaskIt' stamp: ''!
fixedSize: aSize nextPut: anObject
	monitor
		critical:
			[ [ aSize - items size < 1 ] whileTrue: [ items removeFirst ].
			items addLast: anObject.
			monitor signal ].
	^ anObject! !

!SharedQueue methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	monitor := Monitor new.
	items := OrderedCollection new.! !

!SharedQueue methodsFor: 'accessing' stamp: 'nil'!
peek
	"Answer the object that was sent through the receiver first and has not 
	yet been received by anyone but do not remove it from the receiver. If 
	no object has been sent, return nil"
	^monitor critical: [
		items isEmpty ifTrue: [ nil ] ifFalse: [ items first ] ]! !

!SharedQueue methodsFor: 'accessing' stamp: 'nil'!
next
	^monitor critical: [
		monitor waitWhile: [ items isEmpty ].
		items removeFirst ]! !

!SharedQueue methodsFor: 'copying' stamp: 'nil'!
postCopy
	super postCopy.
	monitor critical:
		[items := items copy.
		monitor := Monitor new]! !

!SharedQueue methodsFor: 'accessing' stamp: 'nil'!
nextOrNil
	^monitor critical: [
		items isEmpty ifTrue: [ nil ] ifFalse: [ items removeFirst ] ]! !

!SharedQueue methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	aStream 
		nextPutAll: self class name;
		nextPutAll: ' with ';
		print: items size;
	 	nextPutAll: ' items'.! !

!SharedQueue methodsFor: 'accessing' stamp: 'nil'!
removeAll
       monitor critical: [
		items removeAll ].! !

!SharedQueue methodsFor: 'accessing' stamp: 'nil'!
size
	^monitor critical: [ items size ]! !

!SharedQueue methodsFor: 'accessing' stamp: 'nil'!
nextPut: anObject
	monitor critical: [
		items addLast: anObject.
		monitor signal].
	^ anObject! !

!SharedQueue methodsFor: 'accessing' stamp: 'nil'!
contents
	" To be compliant with stream API but is really needed? "
	^ monitor critical:
		[ items copy ]! !

!SharedQueue methodsFor: 'flushing' stamp: 'nil'!
flush
	"Remove from the queue all objects"
	monitor critical: [
		items := items removeAll].! !

!SharedQueue methodsFor: 'testing' stamp: 'nil'!
atEnd
	^ self isEmpty! !

!SharedQueue methodsFor: 'flushing' stamp: 'nil'!
flushAllSuchThat: aBlock
	"Remove from the queue all objects that satisfy aBlock."
	monitor critical: [
		items := items reject: aBlock].! !

!SharedQueue methodsFor: 'accessing' stamp: 'nil'!
nextOrNilSuchThat: aBlock
	"Answer the next object that satisfies aBlock, skipping any intermediate objects.
	If no object has been sent, answer <nil> and leave me intact.
	NOTA BENE:  aBlock MUST NOT contain a non-local return (^)."

	^monitor critical: [
		| index |
		index := items findFirst: aBlock.
		index = 0
			ifTrue: [nil]
			ifFalse: [items removeAt: index]
	]! !

!SharedQueue class methodsFor: 'instance creation' stamp: 'nil'!
new
	^self basicNew initialize! !

!SharedQueueTest commentStamp: ''!
SUnit tests for shared queues!
!SharedQueueTest methodsFor: 'tests' stamp: ''!
testBasics
	| q |
	q := SharedQueue new.
	self should: [ q nextOrNil isNil ].
	self assert: q atEnd.
	q nextPut: 5.
	self assertCollection: q contents hasSameElements: #(5).
	self should: [ q nextOrNil = 5 ].
	self should: [ q nextOrNil isNil ].
	self assert: q atEnd.! !

!SharedQueueTest methodsFor: 'tests' stamp: ''!
testContention1

	| q r1 r2 |
	q := SharedQueue 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 isNil ]! !

!SharedQueueTest methodsFor: 'tests' stamp: ''!
testNextOrNilSuchThat
	| q item |
	q := SharedQueue new.
	q nextPut: 5.
	q nextPut: 6.
	item := q findFirst: [ :x | x even ].
	self should: [ item = 6 ].
	self should: [ q nextOrNil = 5 ].
	self should: [ q nextOrNil isNil ]! !

!SharedRandom commentStamp: ''!
I represent a Random number generator that can be shaded between different code.

I wrap the access to my parent's functionality (#next, #nextInt: and #next:into:)  through a mutex making me safe for multi threaded use.

To access the default shared random number generator, do:

	SharedRandom globalGenerator.
	
In principle it is better to use a shared generator since multiple users will create a more random pattern.!
!SharedRandom methodsFor: 'accessing' stamp: ''!
next: anInteger into: anArray
    ^ mutex critical: [ super next: anInteger into: anArray ].! !

!SharedRandom methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	mutex := Semaphore forMutualExclusion.! !

!SharedRandom methodsFor: 'accessing' stamp: ''!
nextInteger: anInteger
    ^ mutex critical: [ super nextInteger: anInteger ].! !

!SharedRandom methodsFor: 'accessing' stamp: ''!
next
	^ 	mutex critical: [ super privateNextValue ].! !

!SharedRandom class methodsFor: 'accessing' stamp: ''!
globalGenerator
	^ global! !

!SharedRandom class methodsFor: 'class initialization' stamp: ''!
initialize

	global := self new! !

!ShiftAnonymousClassInstaller commentStamp: ''!
I can generate classes without registering in the environment.
I should not be accessed directly, but by the accessor in Smalltalk or in  the classes.

I have exactly the same interface than the main class installer.!
!ShiftAnonymousClassInstaller methodsFor: 'building' stamp: ''!
installInEnvironment: newClass
	^ self! !

!ShiftAnonymousClassInstaller methodsFor: 'building' stamp: ''!
lookupOldClass
	^ self! !

!ShiftAnonymousClassInstaller methodsFor: 'notifications' stamp: ''!
notifyChanges
	! !

!ShiftAnonymousClassInstaller methodsFor: 'accessing' stamp: ''!
comment: newClass
! !

!ShiftAnonymousClassInstaller methodsFor: 'notifications' stamp: ''!
recategorize: newClass to: category
! !

!ShiftAnonymousClassInstaller methodsFor: 'building' stamp: ''!
installSubclassInSuperclass: newClass! !

!ShiftClassBuilder commentStamp: ''!
I know how to create classes in the system.
The classes are nor installed or modifies other objects. That is part of the job of the ShiftClassInstaller.

I can be extended by using a different builder enhancer. 
See ShDefaultBuilderEnhancer for a default implementation. 

I can be used directly to create anonymous classes, but it is better if you use the anonymous class installer.

I also can compare the old class with the configured new class to calculate the required changes.!
!ShiftClassBuilder methodsFor: 'changes' stamp: ''!
propagateChangesTo: anotherBuilder
	changes do: [ :e | e propagateToSubclasses: anotherBuilder ]! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
propertyAt: aKey 
	^ extensibleProperties at: aKey.! !

!ShiftClassBuilder methodsFor: 'building' stamp: ''!
createSharedVariables
	self builderEnhancer 
		on: newClass
		declareClassVariables: self layoutDefinition sharedVariables
		sharing: self layoutDefinition sharedPoolsString.
	! !

!ShiftClassBuilder methodsFor: 'compiling' stamp: ''!
compileMethods
	| toRemove |
	newClass compileAllFrom: self oldClass.

	toRemove := newClass organization allMethodSelectors reject: [ :aSelector | newClass includesSelector: aSelector ].
	toRemove do: [ :aSelector | newClass organization removeElement: aSelector  ]
! !

!ShiftClassBuilder methodsFor: 'building' stamp: ''!
createMetaclass
	newMetaclass := self builderEnhancer newMetaclass: self.
	
	self builderEnhancer 
		configureMetaclass: newMetaclass 	
		superclass: self metaSuperclass
		withLayoutType: FixedLayout
		slots: self layoutDefinition classSlots.
		
	self builderEnhancer metaclassCreated: self.! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
environment
	^ buildEnvironment environment! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
classNamed: aName
	^ self buildEnvironment classNamed:aName.! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
sharedVariables
	^ self layoutDefinition sharedVariables! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
propertyAt: aKey put: aValue
	extensibleProperties at: aKey put: aValue.! !

!ShiftClassBuilder methodsFor: '*TraitsV2' stamp: ''!
beTrait

	self 
		superclass: nil;
		metaSuperclass: Trait;
		metaclassClass: MetaclassForTraits
! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
layoutDefinition
	^ layoutDefinition! !

!ShiftClassBuilder methodsFor: 'changes' stamp: ''!
compareWithOldClass
	oldClass ifNil: [ ^ self ].
	changeComparers do: [ :e | e compareClass: oldClass with: self ].
	
	changes ifEmpty: [ ShNoChangesInClass signal. ].! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
superclassName: anObject
	superclassName := anObject! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
layoutClass: aLayoutClass
	self layoutDefinition layoutClass: aLayoutClass.! !

!ShiftClassBuilder methodsFor: 'building' stamp: ''!
tryToFillOldClass
	oldClass ifNotNil: [ ^self ].
	name ifNil: [ ^self ].
	self oldClass: (self buildEnvironment classNamed: self name)! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
package: anObject
	
	self category: anObject! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
classTraitComposition
	^ extensibleProperties at: #classTraitComposition ifAbsent: {}! !

!ShiftClassBuilder methodsFor: 'changes' stamp: ''!
notifyChanges
	changes do: #announceChanges! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
superclass: aSuperclass
	aSuperclass ifNil: [ superclassName := nil ].
	superclass := aSuperclass! !

!ShiftClassBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	self useStrictSuperclass.
	superclassName := #Object.

	layoutDefinition := ShLayoutDefinition new.
	layoutDefinition builder: self.

	extensibleProperties := Dictionary new.
	
	changeComparers := OrderedCollection new.
	changes := Set new.
	
	category := 'Unclassified'.
	inRemake := false.! !

!ShiftClassBuilder methodsFor: 'building' stamp: ''!
useStrictSuperclass
	"default behavior"
	"If I am use, the superResolver will resolve unknown superclass by raising an error"
	self superclassResolver: ClassResolverStrictResolve new.! !

!ShiftClassBuilder methodsFor: 'building' stamp: ''!
copyOrganization
	newClass organization copyFrom: oldClass organization.
	newClass class organization copyFrom: oldClass class organization.! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
metaclassClass
	^ metaclassClass ifNil: [ Metaclass ]! !

!ShiftClassBuilder methodsFor: 'testing' stamp: ''!
hasToMigrateInstances
	^ self changes anySatisfy: [ :e | e hasToMigrateInstances ]! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
superclassResolver: asuperclassResolver
	superclassResolver:= asuperclassResolver! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
superclass
	^ superclass ifNil: [ superclassName ifNotNil: [buildEnvironment classNamed: (self superclassName) ]]! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
comment: anObject
	comment := anObject! !

!ShiftClassBuilder methodsFor: 'accessing - comment' stamp: ''!
comment:aComment stamp: anStamp
	self comment: aComment.
	self commentStamp: anStamp.! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
metaSuperclass

	^ metaSuperclass ifNil:[ (superclass ifNil: [ Class ] ifNotNil: [ superclass class ]) ]! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
metaSuperclass: aClass
	
	metaSuperclass := aClass! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
buildEnvironment
	^ buildEnvironment! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
metaclassClass: anObject
	metaclassClass := anObject! !

!ShiftClassBuilder methodsFor: 'initialization' stamp: ''!
detectBuilderEnhancer
	
	| builderEnhancerClass |
	
	builderEnhancerClass := ShDefaultBuilderEnhancer allSubclasses detect: [ :e | e isApplicableFor: self ] ifNone: [ self class defaultBuildEnhancer ].
	builderEnhancer := builderEnhancerClass new.
	
	builderEnhancer initializeBuilder: self.
	^ builderEnhancer! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
isInRemake
	
	"If the builder is in remake (when propagating changes to subclasses)"
	
	^ inRemake ! !

!ShiftClassBuilder methodsFor: '*TraitsV2' stamp: ''!
traitComposition: aValue
	
	| aTraitComposition |
	aTraitComposition := aValue asTraitComposition.
	
	self classTraitComposition: aTraitComposition classComposition.
	^ extensibleProperties at: #traitComposition put: aTraitComposition! !

!ShiftClassBuilder methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	| selector variable setter|
		
	selector := aMessage selector.

	(selector isUnary or:[ selector isKeyword and:[ selector keywords size = 1] ]) 
		ifFalse:[ ^ super doesNotUnderstand: aMessage].

	setter := selector isKeyword.
	variable := setter ifTrue:[(selector allButLast: 1) asSymbol] ifFalse:[selector]. 
	
	(extensibleProperties includesKey: variable) 
		ifFalse: [ ^ super doesNotUnderstand: aMessage ].
	
	setter 
		ifTrue:[ extensibleProperties at: variable put: aMessage argument] 
		ifFalse:[ ^ extensibleProperties at: variable].
	! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
environment: anEnvironment
	^ buildEnvironment environment: anEnvironment! !

!ShiftClassBuilder methodsFor: 'building' stamp: ''!
installSlotsAndVariables
	"notify all the variables so they can react to being installed in a class"
	newClass classLayout slots do: [ :each | each installingIn: newClass ].
	newClass class classLayout slots do: [ :each | each installingIn: newClass class ].
	newClass classVariables do: [ :each | each installingIn: newClass ].
! !

!ShiftClassBuilder methodsFor: '*TraitsV2' stamp: ''!
isTrait 
	^ self metaSuperclass isKindOf: Trait class ! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
sharedPools: aString
	self layoutDefinition sharedPools: ((aString substrings: ' ') collect: [:e | e asSymbol])! !

!ShiftClassBuilder methodsFor: 'initialization' stamp: ''!
fillFor: aClass
	self
		superclass: aClass superclass;
		name: aClass getName;
		layoutClass: aClass classLayout class;
		slots: aClass localSlots;
		classSlots: aClass class localSlots;
		sharedVariablesFromString: aClass classVariablesString;
		sharedPools: aClass sharedPoolsString;
		category: aClass category;
		environment: aClass environment;
		oldClass: aClass.
		
	self builderEnhancer fillBuilder: self from: aClass.
! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
category: anObject
	category := anObject! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
newClass
	^ newClass! !

!ShiftClassBuilder methodsFor: 'private - validating' stamp: ''!
validateSuperclass
	self superclass ifNil: [ ^self ].
	oldClass ifNil: [ ^ self ].	
	
	self superclass withAllSuperclassesDo: [ :aSuperclass |
		aSuperclass = oldClass ifTrue:[
			CircularHierarchyError signalFor: oldClass ]]
! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
builderEnhancer: anObject
	builderEnhancer := anObject.
	
	builderEnhancer initializeBuilder: self! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
changeComparers
	^ changeComparers! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject.
	self validateClassName.! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
changes
	^ changes! !

!ShiftClassBuilder methodsFor: 'building' stamp: ''!
build	
	self tryToFillOldClass.
	self detectBuilderEnhancer.
	self builderEnhancer validateRedefinition: self oldClass. 
	
	self validateSuperclass.
	self compareWithOldClass.

	self layoutDefinition copySlotsIfUsedIn: oldClass.

	"If this is the first build, when building a class. 
	We need to check if there is no conflicts with existing subclasses. 
	If we are in a remake, it have been done when building the superclass modified before."
		
	self isInRemake 
		ifFalse: [ self layoutDefinition validate ].

	self createMetaclass.
	self createClass.

	self createSharedVariables.

	self installSlotsAndVariables.

	self oldClass ifNotNil: [ 
			self newClass basicCategory: self oldClass basicCategory.
			self copyOrganization.
			self builderEnhancer compileMethodsFor: self. ].

	self builderEnhancer afterMethodsCompiled: self.
	
	
	
	^ newClass! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
sharedPoolsCollectionOfSymbols: aCol
	self layoutDefinition sharedPools: aCol! !

!ShiftClassBuilder methodsFor: '*TraitsV2' stamp: ''!
traitComposition
	^ extensibleProperties at: #traitComposition ifAbsent: {}! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
slots: aCollection
	self layoutDefinition slots: aCollection! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
oldClass: anObject
	oldClass := anObject.
	oldClass ifNotNil: [oldMetaclass := oldClass class].! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
builderEnhancer
	^ builderEnhancer ifNil: [ self detectBuilderEnhancer ]! !

!ShiftClassBuilder methodsFor: 'changes' stamp: ''!
addChange: aChange
	changes add: aChange.! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
markIsInRemake
	
	inRemake := true! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
oldClass
	^ oldClass! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
sharedVariablesFromString: aStringOrArray
	layoutDefinition sharedVariables: (aStringOrArray isString
        ifTrue: [ (aStringOrArray substrings: ' ') collect: [ :x | x asSymbol => ClassVariable ] ]
        ifFalse: [ aStringOrArray collect: [ :x | 
                x isSymbol
                    ifTrue: [ x => ClassVariable ]
                    ifFalse: [ self error: 'Shared variables can only be String or an array of Symbols' ] ] ])! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
classTraitComposition: aValue
	^ extensibleProperties at: #classTraitComposition put: aValue.! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
commentStamp
	^ commentStamp! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
slots
	^ self layoutDefinition slots! !

!ShiftClassBuilder methodsFor: 'changes' stamp: ''!
addChangeComparer: aChangeComparer
	changeComparers add: aChangeComparer.! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
commentStamp: anObject
	commentStamp := anObject! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
category
	^ category! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
newMetaclass
	^ newMetaclass! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
superclassName
	^ superclassName! !

!ShiftClassBuilder methodsFor: 'installing' stamp: ''!
createClass
	newClass := newMetaclass new.
	newClass setName: self name.

	self builderEnhancer 
		configureClass: newClass
		superclass: self superclass
		withLayoutType: self layoutDefinition layoutClass
		slots: self layoutDefinition slots.

	newClass environment: self buildEnvironment environment.
	
	self builderEnhancer classCreated: self.! !

!ShiftClassBuilder methodsFor: 'private - validating' stamp: ''!
validateClassName
	name ifNil: [ ^self ].
	
	"I try to convert to symbol, if there is an error the next guard will catch it"
	[ name := name asSymbol ] on: Error do: [  ].
	
	name isSymbol ifFalse:[InvalidGlobalName 
				signal: 'Global names should be symbols' 
				for: name].

	name isValidGlobalName ifFalse: [ 
		InvalidGlobalName signal: 'Class name is not a valid global name. It must start with uppercase letter and continue with alphanumeric characters or underscore. Default names used in class or trait templates are not allowed.' for: name ].
		
	DangerousClassNotifier check: name ! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
comment
	^ comment! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
oldMetaclass
	^ oldMetaclass! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
classSlots: aSlotCollection
	self layoutDefinition classSlots: aSlotCollection.! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
sharedPools
	^ self layoutDefinition sharedPools! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
sharedVariables: aCollection
	self layoutDefinition sharedVariables: (aCollection collect:[:e | e asClassVariable]).! !

!ShiftClassBuilder methodsFor: 'accessing' stamp: ''!
buildEnvironment: anObject
	buildEnvironment := anObject! !

!ShiftClassBuilder methodsFor: '*ClassParser' stamp: ''!
buildFromAST: aCDClassDefinitionNode

	| package |

	self name: aCDClassDefinitionNode className.
	
	aCDClassDefinitionNode superclassName = #nil
		ifFalse: [ self
				superclass:
					(superclassResolver
						resolve: aCDClassDefinitionNode superclassName
						inEnv: buildEnvironment) ]
		ifTrue: [ self superclass: nil ].
		
	self layoutClass: aCDClassDefinitionNode layoutClass.
		
	self slots: (aCDClassDefinitionNode slots collect: [ :e | e asSlot ]).
	
	self sharedVariables: (aCDClassDefinitionNode sharedSlots collect: [ :e | e ]).
	
	aCDClassDefinitionNode packageName
		ifNotNil: [ :cat | package := cat ]
		ifNil: [ package := 'Unclassified' ].
	self category: package.
	
	self layoutDefinition sharedPools: (aCDClassDefinitionNode sharedPools collect: [ :e | e name ]).
	
	aCDClassDefinitionNode traitDefinition
		ifNotNil: [ :traitDef | 
			traitDef originalNode formattedCode.
			self
				traitComposition:
					(self class compiler
						source: traitDef originalNode formattedCode;
							evaluate) ]! !

!ShiftClassBuilder methodsFor: '*UndefinedClasses' stamp: ''!
useUndefinedClass
	"If i am use, the superResolver will resolve unknown superclass by creating an UndefinedClass with the expected superclassName"

	self superclassResolver: UndefinedClassClassResolver new! !

!ShiftClassBuilder class methodsFor: 'accessing' stamp: ''!
setDefaultBuilderEnhancer: aClass 
	BuilderEnhancer := aClass! !

!ShiftClassBuilder class methodsFor: 'defaults' stamp: ''!
defaultBuildEnhancer
	^ BuilderEnhancer ifNil: [ ShDefaultBuilderEnhancer ]! !

!ShiftClassInstaller commentStamp: ''!
I am the responsible of installing a class in the system.

I interact with the ShiftClassBuilder to generate the classes.
You can use me as in:

Smalltalk classInstaller make: [ :aBuilder |
		aBuilder
			superclass: Object;
			name: #MyClass;
			slots: #(varA varB);
			category: 'My-Category' ].
		
See that I should never be referenced directly, only through the accessor 
in Smalltalk or in any class in the system. 

The block passed is used to configure the builder. Check ShiftClassBuilder to see the available messages.

I have a subclass to anonymous generate classes, without registering in the environment. !
!ShiftClassInstaller methodsFor: 'building' stamp: ''!
copyClassSlotsFromExistingClass
	self builder layoutDefinition copyClassSlotsIfNeeded: oldClass class slots! !

!ShiftClassInstaller methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	builder := ShiftClassBuilder new.
	builder buildEnvironment: ShSmalltalkGlobalsEnvironment new	
	
	! !

!ShiftClassInstaller methodsFor: 'copying' stamp: ''!
copyObject: oldObject to: newClass
	| newObject hiddenSlots |
	
	newObject := (newClass isVariable and: [oldClass isVariable])
		ifTrue: [ newClass basicNew: oldObject size ]
		ifFalse: [ newClass basicNew ].

	"first initialize all hidden slots"
	hiddenSlots := newClass classLayout allSlots reject: [:each | each isVisible].
	hiddenSlots do: [ :newSlot | 
			newSlot initialize: newObject.
			oldObject class slotNamed: newSlot name ifFound: [ :oldSlot | 
				newSlot write: (oldSlot read: oldObject) to: newObject ]  ].

	"the initialize all visible slots"
	newClass allSlots do: [ :newSlot | oldObject class slotNamed: newSlot name ifFound: [ :oldSlot | 
			newSlot initialize: newObject.
		   newSlot write: (oldSlot read: oldObject) to: newObject ] ].

	newClass isVariable
		ifTrue: [ 1 to: oldObject basicSize do: [ :offset | newObject basicAt: offset put: (oldObject basicAt: offset) ] ].

	"Clearing the readonly-ness in the old objects so the become is able to work"
	oldObject setIsReadOnlyObject: false.

	^ newObject! !

!ShiftClassInstaller methodsFor: 'building' stamp: ''!
fixSlotScope: newClass
	newClass superclass ifNil: [ ^ self ].
	(newClass classLayout slotScope isKindOf: LayoutEmptyScope) ifTrue: [ ^ self ].

	newClass superclass classLayout slotScope == newClass classLayout slotScope parentScope
		ifFalse: [ newClass classLayout slotScope parentScope: newClass superclass classLayout slotScope ].
		
	self assert: newClass superclass classLayout slotScope == newClass classLayout slotScope parentScope.
! !

!ShiftClassInstaller methodsFor: 'building' stamp: ''!
installSubclassInSuperclass: newClass

	"I only install if there is a name / non anonymous"
	builder name ifNil: [ ^ self ].

	newClass superclass addSubclass: newClass! !

!ShiftClassInstaller methodsFor: 'accessing' stamp: ''!
oldClass
	^ oldClass! !

!ShiftClassInstaller methodsFor: 'notifications' stamp: ''!
recategorize: aClass to: newCategory
	| oldCategory |
	oldCategory := oldClass ifNotNil:[oldClass basicCategory].
	oldCategory == newCategory asSymbol
		ifTrue: [ ^ self ].

	self installingEnvironment organization
		ifNotNil: [ :e | e classify: aClass name under: newCategory ].

	(oldCategory isNil or:[ oldCategory = #Unclassified])
		ifTrue: [ SystemAnnouncer uniqueInstance classAdded: aClass inCategory: newCategory ]
		ifFalse: [ SystemAnnouncer uniqueInstance class: aClass recategorizedFrom: oldCategory to: newCategory ]! !

!ShiftClassInstaller methodsFor: 'migrating' stamp: ''!
migrateClassTo: newClass
	| slotsToMigrate oldClassVariables newClassVariables|

	oldClass ifNil:[^ self].
	self assert: newClass isNotNil.
		
	oldClass 	superclass removeSubclass: oldClass.

	newClass subclasses: oldClass subclasses.

	slotsToMigrate := newClass class allSlots reject:[:e | builder builderEnhancer hasToSkipSlot: e ].
	slotsToMigrate do: [ :newSlot | oldClass class slotNamed: newSlot name ifFound: [ :oldSlot | newSlot write: (oldSlot read: oldClass) to: newClass ] ].
	
	oldClassVariables := OrderedCollection new.
	newClassVariables := OrderedCollection new.
	
	oldClass classVariables do: [ :oldVar | | newVar |
		(newClass hasClassVarNamed: oldVar key)
			ifTrue: [ 
				newVar := newClass classVariableNamed: oldVar key.
				newVar write: oldVar read.
				newClassVariables add: newVar.
				oldClassVariables add: oldVar. ]].
	
	[ 	
		(self builder hasToMigrateInstances) 
			ifTrue: [ builder builderEnhancer migrateInstancesTo: newClass installer: self ].

		{ oldClass. builder oldMetaclass } , oldClassVariables asArray
			elementsForwardIdentityTo: { newClass. builder newMetaclass }, newClassVariables asArray.	

		newClass classPool rehash.
	] valueUninterruptably
! !

!ShiftClassInstaller methodsFor: 'building' stamp: ''!
updateBindings: aBinding of: newClass
	newClass methods do: [ :e | e classBinding: aBinding ]! !

!ShiftClassInstaller methodsFor: 'building' stamp: ''!
installInEnvironment: newClass

	"I only install if there is a name / non anonymous"
	builder name ifNil: [ ^ self ].

	"I only install in the environment if there is not oldClass installed."
	(self installingEnvironment hasClassNamed: builder name) ifFalse:[
		self installingEnvironment installClass: newClass withName: builder name ].

	self
		updateBindings: (self installingEnvironment bindingAt: builder name)
		of: newClass! !

!ShiftClassInstaller methodsFor: 'building' stamp: ''!
remake: aClass

	self class new
		oldClass: aClass;
		installingEnvironment: self installingEnvironment;
		make: [ :anotherBuilder | 
			anotherBuilder fillFor: aClass.
			anotherBuilder buildEnvironment: builder buildEnvironment.
			anotherBuilder markIsInRemake.
			builder propagateChangesTo: anotherBuilder ]! !

!ShiftClassInstaller methodsFor: 'building' stamp: ''!
lookupOldClass
	oldClass
		ifNil: [ oldClass := self installingEnvironment classNamed: builder name ifAbsent: [ nil ] ]! !

!ShiftClassInstaller methodsFor: 'to sort' stamp: ''!
makeWithBuilder: aBuilder
	
	builder := aBuilder.
	^ self make! !

!ShiftClassInstaller methodsFor: 'accessing' stamp: ''!
builder
	^ builder! !

!ShiftClassInstaller methodsFor: 'accessing' stamp: ''!
comment: newClass
	builder comment ifNotNil: [ newClass classComment: builder comment stamp: builder commentStamp ]! !

!ShiftClassInstaller methodsFor: 'building' stamp: ''!
installingEnvironment: anEnvironment

	installingEnvironment := anEnvironment! !

!ShiftClassInstaller methodsFor: 'migrating' stamp: ''!
migrateInstancesTo: newClass
	| oldObjects newObjects readOnlyOldObjectsFlags |
	oldObjects := oldClass allInstances.
	oldObjects ifEmpty: [ ^ self ].
	
	readOnlyOldObjectsFlags := OrderedCollection new: oldObjects size.

	newObjects := oldObjects collect: [ :e | 
		(readOnlyOldObjectsFlags add: e isReadOnlyObject).
		self copyObject: e to: newClass ].

	oldObjects elementsForwardIdentityTo: newObjects copyHash: true.
	
	newObjects with: readOnlyOldObjectsFlags do: [ :anObject :aFlag | anObject setIsReadOnlyObject: aFlag ] ! !

!ShiftClassInstaller methodsFor: 'building' stamp: ''!
installingEnvironment

	^ installingEnvironment ifNil: [ builder buildEnvironment ]! !

!ShiftClassInstaller methodsFor: 'building' stamp: ''!
make: aBlock
	
	aBlock value: builder.

	^self make! !

!ShiftClassInstaller methodsFor: 'notifications' stamp: ''!
notifyChanges
	builder notifyChanges! !

!ShiftClassInstaller methodsFor: 'accessing' stamp: ''!
oldClass: anObject
	oldClass := anObject! !

!ShiftClassInstaller methodsFor: 'building' stamp: ''!
make
	| newClass |

	self lookupOldClass.

	[	
		builder oldClass: oldClass.
		self copyClassSlotsFromExistingClass.
		newClass := builder build.

		self installInEnvironment: newClass.

		self installSubclassInSuperclass: newClass.
	
		builder builderEnhancer beforeMigratingClass: builder installer: self.

		builder builderEnhancer migrateToClass: newClass installer: self.

		builder builderEnhancer afterMigratingClass: builder installer: self.	

		builder builderEnhancer propagateChangesToRelatedClasses: newClass installer: self.
	] on: ShNoChangesInClass do:[
		"If there are no changes in the building, I am not building or replacing nothing"
		newClass := oldClass.
	].

	self fixSlotScope: newClass.
	self fixSlotScope: newClass class.

	self recategorize: newClass to: builder category.
	self comment: newClass.

	self notifyChanges.

	^ newClass! !

!ShiftClassInstaller class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ Smalltalk classInstaller make: [ :aSlotClassBuilder |
		aSlotClassBuilder
			superclass: Object;
			name: #MyClass;
			slots: #(varA varB);
			category: 'My-Category' ].! !

!ShiftClassInstaller class methodsFor: 'building' stamp: ''!
update: oldClass to: aBlock
	^ self new 
		oldClass: oldClass;
		make:aBlock! !

!ShiftClassInstaller class methodsFor: 'validating' stamp: ''!
validateClassName: aString 
	ShiftClassBuilder new name: aString.! !

!ShiftClassInstaller class methodsFor: 'building' stamp: ''!
make: aBlock
	^ self new make:aBlock! !

!ShortIntegerArray commentStamp: ''!
ShortIntegerArray is an array for efficiently representing integers in the 16bit range.!
!ShortIntegerArray methodsFor: 'objects from disk' stamp: ''!
write: shortInteger littleEndianOn: aStream

	#(2 1 4 3) do: [:digitIndex| aStream nextPut: (shortInteger byteAt: digitIndex) ]! !

!ShortIntegerArray methodsFor: 'objects from disk' stamp: ''!
writeOn: aStream
	aStream nextInt32Put: self basicSize.
	1 to: self basicSize do: [ :i | 
		self write: (self basicAt: i) on: aStream ]! !

!ShortIntegerArray methodsFor: 'accessing' stamp: ''!
at: index put: value
	"Store the given 16-bit integer at the given index in the receiver."

	<primitive: 144>
	index isInteger
		ifTrue: [ 
			(index between: 1 and: self size)
				ifTrue: [ self errorImproperStore ]
				ifFalse: [ self errorSubscriptBounds: index ] ].
	self errorNonIntegerIndex! !

!ShortIntegerArray methodsFor: 'objects from disk' stamp: ''!
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."

	EndianDetector isLittleEndian
		ifTrue: [ self swapBytePairsHacky ]! !

!ShortIntegerArray methodsFor: 'private' stamp: ''!
swapShortObjects
	"Private -- swap all the short quantities in the receiver"
	| tmp |
	1 to: self basicSize do:[:i|
		tmp := (self pvtAt: i * 2).
		self pvtAt: i * 2 put: (self pvtAt: i * 2 - 1).
		self pvtAt: i * 2 - 1 put: tmp.
	]! !

!ShortIntegerArray methodsFor: 'accessing' stamp: ''!
defaultElement
	^0! !

!ShortIntegerArray methodsFor: 'private' stamp: ''!
pvtAt: index put: value
	"Private -- for swapping only"

	<primitive: 144>
	index isInteger
		ifTrue: [ 
			(index between: 1 and: self size)
				ifTrue: [ self errorImproperStore ]
				ifFalse: [ self errorSubscriptBounds: index ] ].
	self errorNonIntegerIndex! !

!ShortIntegerArray methodsFor: 'accessing' stamp: ''!
size
	^super size * 2! !

!ShortIntegerArray methodsFor: 'accessing' stamp: ''!
at: index
	"Return the 16-bit integer value at the given index of the receiver."

	<primitive: 143>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	self errorNonIntegerIndex.! !

!ShortIntegerArray methodsFor: 'objects from disk' stamp: ''!
swapBytePairsHacky

	"The implementation is a hack, but fast for large ranges"
			"XOR"
			"Exchange bytes 0 and 1"
			"Exchange bytes 2 and 3"
	| hack blt |
	hack := Form new hackBits: self.	"The implementation is a hack, but fast for large ranges"
	blt := (BitBlt toForm: hack) sourceForm: hack.
	blt combinationRule: Form reverse.	"XOR"
		
	blt
		sourceY: 0;
		destY: 0;
		height: hack height;
		width: 1.
	#((0 1) (1 0) (0 1) (2 3)(3 2)(2 3))
		do: [:array | [:a :b| blt sourceX: a; destX: b; copyBits ] valueWithArguments: array ].! !

!ShortIntegerArray methodsFor: 'objects from disk' stamp: ''!
write: shortInteger on: aStream
	^ EndianDetector isLittleEndian
		ifFalse: [ self write: shortInteger bigEndianOn: aStream ]
		ifTrue: [ self write: shortInteger littleEndianOn: aStream ]! !

!ShortIntegerArray methodsFor: 'private' stamp: ''!
pvtAt: index
	"Private -- for swapping only"
	<primitive: 143>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	self errorNonIntegerIndex.! !

!ShortIntegerArray methodsFor: 'objects from disk' stamp: ''!
write: shortInteger bigEndianOn: aStream
	^ aStream nextNumber: 4 put: shortInteger! !

!ShortIntegerArray class methodsFor: 'startup - shutdown' stamp: ''!
startUp
	"Check if the word order has changed from the last save"
	((LastSaveOrder at: 1) = 42 and:[(LastSaveOrder at: 2) = 13]) 
		ifTrue:[^self]. "Okay"
	((LastSaveOrder at: 2) = 42 and:[(LastSaveOrder at: 1) = 13]) 
		ifTrue:[^self swapShortObjects]. "Reverse guys"
	^self error:'This must never happen'! !

!ShortIntegerArray class methodsFor: 'class initialization' stamp: ''!
initialize
	LastSaveOrder := self new: 2.
	LastSaveOrder at: 1 put: 42.
	LastSaveOrder at: 2 put: 13.
	
	SessionManager default
		registerSystemClassNamed: self name! !

!ShortIntegerArray class methodsFor: 'instance creation' stamp: ''!
new: n
	^super new: n + 1 // 2! !

!ShortIntegerArray class methodsFor: 'private' stamp: ''!
swapShortObjects
	self allSubInstancesDo:[:inst| inst swapShortObjects]! !

!ShortIntegerArrayTest commentStamp: ''!
SUnit Test for ShortIntegerArray!
!ShortIntegerArrayTest methodsFor: 'tests' stamp: ''!
testSwapBytePairs

	shortIntegerArray swapBytePairsHacky.
	self assert: 4*256 equals: (shortIntegerArray at:1). 
	self assert: 4*256 + 1 equals: (shortIntegerArray at:2).
	self assert: 2*256 equals: (shortIntegerArray at:3).
	self assert: 1*256 + 10 equals: (shortIntegerArray at:4).! !

!ShortIntegerArrayTest methodsFor: 'tests' stamp: ''!
testAt

	self assert: 2 equals: (shortIntegerArray at: 3)! !

!ShortIntegerArrayTest methodsFor: 'tests' stamp: ''!
testSetUp

	self assert: 4 equals: (shortIntegerArray at:1) . 
	self assert: 4+256 equals: (shortIntegerArray at:2).
	self assert: 2 equals: (shortIntegerArray at:3).
	self assert: 1+(256*10) equals: (shortIntegerArray at:4).! !

!ShortIntegerArrayTest methodsFor: 'tests' stamp: ''!
testAtPut

	shortIntegerArray at: 3 put: 100.
	self assert: 100 equals: (shortIntegerArray at: 3)! !

!ShortIntegerArrayTest methodsFor: 'tests' stamp: ''!
testWriteLittleEndianOn

	|stream|
	stream := WriteStream on: Array new.
	shortIntegerArray write: (12 bitShift: 24) + (34 bitShift: 16) + (56 bitShift: 8) + 78 littleEndianOn: stream.
	self assert: #(56 78 12 34) equals: stream contents! !

!ShortIntegerArrayTest methodsFor: 'tests' stamp: ''!
testWriteBigEndianOn

	|stream|
	stream := WriteStream on: Array new.
	shortIntegerArray write: (12 bitShift: 24) + (34 bitShift: 16) + (56 bitShift: 8) + 78 bigEndianOn: stream.
	self assert: #(12 34 56 78) equals: stream contents! !

!ShortIntegerArrayTest methodsFor: 'running' stamp: ''!
setUp 

	super setUp.
	shortIntegerArray := ShortIntegerArray with: 4 with: 4+256 with: 2 with: 1+(256*10).! !

!ShortcutReminder commentStamp: ''!
ShortcutReminder is an object used to bring up a notification whenever a menu entry that has a keyboard shortcut is clicked on instead of using the keyboard.

It is configurable from the settings browser, where one can choose the location and size of the notification Morph. The notification also holds a count of how many times a specific menu entry has been reminded for, and will only notify up to that limit. It is possible to set this limit to -1 such that it will always notify.
!
!ShortcutReminder methodsFor: 'accessing' stamp: ''!
position

	^position! !

!ShortcutReminder methodsFor: 'defaults' stamp: ''!
defaultBackgroundColor

	^Color gray! !

!ShortcutReminder methodsFor: 'accessing' stamp: ''!
backgroundColor

	^backgroundColor! !

!ShortcutReminder methodsFor: 'settings' stamp: ''!
createResetCountButtonMorph

	^SimpleButtonMorph new
		target: self;
		label: 'Reset notification counts';
		actionSelector: #resetCount;
		themeChanged;
		yourself! !

!ShortcutReminder methodsFor: 'accessing' stamp: ''!
textSize: aSymbol

	(self sizes includes: aSymbol) ifFalse: [ self error ].
	
	size := aSymbol! !

!ShortcutReminder methodsFor: 'private' stamp: ''!
small

	^15! !

!ShortcutReminder methodsFor: 'accessing' stamp: ''!
position: aSymbol

	(self positions includes: aSymbol) ifFalse: [ self error ].
	
	position := aSymbol! !

!ShortcutReminder methodsFor: 'private' stamp: ''!
large

	^55! !

!ShortcutReminder methodsFor: 'settings' stamp: ''!
resetCount

	countDict := Dictionary new.! !

!ShortcutReminder methodsFor: 'queries' stamp: ''!
wantsToShow: aHashValue
	
	^limit < 0 or: [ 
		(countDict at: aHashValue ifAbsent: [ 0 ]) < limit
	]! !

!ShortcutReminder methodsFor: 'shortcut creation' stamp: ''!
positionShortcut: aMorph
	
	| area |
	
	area := self currentWorld clearArea insetBy: 3. 
	
	aMorph 
	cellPositioning: position;
	fullBounds. 
	"the layout has to be computed before changing the position."
	
	aMorph perform: (position , ':') asSymbol with: (position value: area).! !

!ShortcutReminder methodsFor: 'accessing' stamp: ''!
limit: aNumber

	limit := aNumber! !

!ShortcutReminder methodsFor: 'shortcut creation' stamp: ''!
show: aMenuItem

	| shortcutMorph |
	
	shortcutMorph := self createShortcutMorphFor: aMenuItem.
	
	self positionShortcut: shortcutMorph.
	
	shortcutMorph openInWorld.! !

!ShortcutReminder methodsFor: 'defaults' stamp: ''!
defaultTextColor

	^Color black! !

!ShortcutReminder methodsFor: 'private' stamp: ''!
medium

	 ^27! !

!ShortcutReminder methodsFor: 'private' stamp: ''!
positions

	^#(#topLeft #topRight #center #bottomLeft #bottomRight)! !

!ShortcutReminder methodsFor: 'private - utilities' stamp: ''!
fontSized: aPointSize

	^LogicalFont familyName: self defaultFontFamiliyName pointSize: aPointSize! !

!ShortcutReminder methodsFor: 'private' stamp: ''!
labelFont

	^self fontSized: self pointSize! !

!ShortcutReminder methodsFor: 'shortcut creation' stamp: ''!
createShortcutMorphFor: aMenuItem 

	^FadingMorph new
		addMorphBack: (self createLabelMorph: aMenuItem contents);
		addMorphBack: (self createKeyTextMorph: aMenuItem keyText);
		color: backgroundColor;
		yourself! !

!ShortcutReminder methodsFor: 'accessing' stamp: ''!
backgroundColor: aColor

	backgroundColor := aColor! !

!ShortcutReminder methodsFor: 'initialization' stamp: ''!
initialize

	countDict := Dictionary new.
	limit := self defaultLimit.
	size := #small.
	position := #bottomLeft.
	backgroundColor := self defaultBackgroundColor.
	textColor := self defaultTextColor.! !

!ShortcutReminder methodsFor: 'accessing' stamp: ''!
textColor: aColor

	textColor := aColor! !

!ShortcutReminder methodsFor: 'accessing' stamp: ''!
limit
	
	^limit! !

!ShortcutReminder methodsFor: 'private' stamp: ''!
sizes 

	^#(#small #medium #large)! !

!ShortcutReminder methodsFor: 'private - utilities' stamp: ''!
fixKeyText: aString

	^ (ToggleMenuItemShortcut owner: nil keyText: aString) text! !

!ShortcutReminder methodsFor: 'accessing' stamp: ''!
textColor

	^textColor! !

!ShortcutReminder methodsFor: 'private - utilities' stamp: ''!
createKeyTextMorph: aString

	| font |
	font := ToggleWithSymbolMenuItemShortcut canBeUsed
		ifTrue: [ LogicalFont 
						familyName: 'Lucida Grande' 
						pointSize: self pointSize * 2 ]
		ifFalse: [ self keyTextFont ].

	^(self fixKeyText: aString) asStringMorph 
		font: font emphasis: 2;
		color: textColor;
		yourself.! !

!ShortcutReminder methodsFor: 'private' stamp: ''!
keyTextFont

	^self fontSized: self pointSize * 2! !

!ShortcutReminder methodsFor: 'defaults' stamp: ''!
defaultLimit

	^5! !

!ShortcutReminder methodsFor: 'private - utilities' stamp: ''!
createLabelMorph: aString

	^aString asStringMorph 
		font: self labelFont emphasis: 0;
		color: textColor;
		yourself.! !

!ShortcutReminder methodsFor: 'private' stamp: ''!
pointSize

	^size value: self! !

!ShortcutReminder methodsFor: 'shortcut creation' stamp: ''!
remind: aMenuItem 

	| itemHash |
	
	itemHash := (aMenuItem contents hash + aMenuItem keyText hash) hashMultiply.
	
	(self wantsToShow: itemHash) ifFalse: [ ^self ].
	
	self 
	show: aMenuItem;
	updateCount: itemHash.! !

!ShortcutReminder methodsFor: 'private' stamp: ''!
updateCount: aHashValue
	
	| value |
	
	value := countDict at: aHashValue ifAbsent: [ 0 ].
	
	countDict at: aHashValue put: value + 1.! !

!ShortcutReminder methodsFor: 'accessing' stamp: ''!
textSize

	^size! !

!ShortcutReminder methodsFor: 'defaults' stamp: ''!
defaultFontFamiliyName

	^'Source Sans Pro'! !

!ShortcutReminder methodsFor: 'settings' stamp: ''!
customSettingsOn: aBuilder

	(aBuilder pickOne: #position)
		order: 1;
		target: self;
		label: 'Position in World';
		description: 'Select one of the positons available to specify where the shortcut notification morph will be shown';
		default: #bottomLeft;
		domainValues: self positions.
		
	(aBuilder pickOne: #textSize) 
		order: 2;
		target: self;
		label: 'Size of the reminder';
		description: 'Set the size (small medium or large) of the reminder morph shown';
		domainValues: self sizes.
		
	(aBuilder setting: #textColor)
		order: 3;
		target: self;
		label: 'Text color';
		default: self defaultTextColor.
		
	(aBuilder setting: #backgroundColor)
		target: self;
		label: 'Background color';
		default: self defaultBackgroundColor.
		
	(aBuilder range: #limit) 
		order: 6;
		target: self; 
      label: 'Notification limit' ;
		description: 'Set the limit of how many notifications per menu entry one should be reminded about. Setting the value to -1 means that it will allways remind you' ;
		default: self defaultLimit;
		range: (-1 to: 100).
		
	(aBuilder group: #'Reset count')
		order: 7;
		target: self;
		label: 'Reset the reminder count';
		dialog: [ self createResetCountButtonMorph ].! !

!ShortcutReminder class methodsFor: 'defaults' stamp: ''!
defaultReminder

	^DefaultReminder ifNil: [ DefaultReminder := self new ]! !

!ShortcutReminder class methodsFor: 'settings' stamp: ''!
enabled

	^Enabled ifNil: [ Enabled := false ]! !

!ShortcutReminder class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder 
	<systemsettings>
	(aBuilder setting: #'Shortcut Reminder') 
		target: self;
		parent: #appearance;
		default: true;
		description: 'Shortcut reminder is a reminding tool which pops up when a menu entry which includes a keyboard shortcut is invoked by the mouse instead';
		selector: #enabled;
		iconName: #smallConfigurationIcon;
		with: [ self defaultReminder customSettingsOn: aBuilder ]! !

!ShortcutReminder class methodsFor: 'display' stamp: ''!
showShortcut: aShortcut
	
	(aShortcut keyText isNil or: [ self enabled not ]) ifTrue: [ ^self ].
	
	self defaultReminder remind: aShortcut.! !

!ShortcutReminder class methodsFor: 'settings' stamp: ''!
enabled: aBoolean

	Enabled := aBoolean! !

!ShouldBeImplemented commentStamp: ''!
I am ShouldBeImplemented, an exception signaled when some method should have been implemented but was not.

This is more like a placeholder during development.!
!ShouldBeImplemented methodsFor: 'printing' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		stream print: self selector.
		stream << ' should have been implemented in '.
		stream print: self signaler class]! !

!ShouldNotImplement commentStamp: ''!
I am ShouldNotImplement, an exception signaled when a method was implemented but should not have been.

This can happen when an implementation is inherited.!
!ShouldNotImplement methodsFor: 'printing' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		stream print: self selector.
		stream << ' should not have been implemented in '.
		stream print: self signaler class]! !

!SignalLogger commentStamp: ''!
It represents the abstract class of a `SignalLogger` that takes the signals going through the `Beacon` and actually does something useful.

The subclasses provide concrete implementations. Each of these sublasses can be used both by directly instantiating the class, or by using the `instance` class variable which holds a global instance of that class.
The global instance of a signal logger is useful to provide a simple means to start and stop without worrying about the instance.

For example, consider:

```
   TranscriptLogger start.
   StringSignal emit: 'test'.
   ...
   TranscriptLogger stop.
```	
Passing stop, unsubscribes the global instance of `TranscriptLogger` from the central `Beacon` instance without having to remember the `TranscriptLogger` object.

One can get signals go to a given logger during the execution of a block with:

```
   (MemoryLogger named: 'loggerA')
       runDuring: [ 
         'Hello' asBeaconSignal emit.
         42 asBeaconSignal emit.
         ContextStackSignal emit.
         ];
       recordings.
```		
This can be done for a specific set of signals with:

```
   (MemoryLogger named: 'loggerA')
      runFor: StringSignal, WrapperSignal 
      during: [ 
         'Hello' asBeaconSignal emit.
         42 asBeaconSignal emit.
         StringSignal emit: 'let me pass'
         ];
      recordings.
```
		
It is possible to have signals go to several loggers by nesting `#runDuring:` blocks.
Now this is not replacing a composite logger.
!
!SignalLogger methodsFor: 'registration' stamp: ''!
runDuring: aBlock
	"Make all BeaconSignals go to me during aBlock"
	
	self start.
	[ aBlock value ]
		ensure: [ self stop ]
! !

!SignalLogger methodsFor: 'registration' stamp: ''!
runFor: anAnnouncementOrASetOfAnnouncements during: aBlock
	"Makes all provided BeaconSignals got to me during aBlock.
	
	logger runFor: StringSignal during: [ ... ]"

	self startFor: anAnnouncementOrASetOfAnnouncements.
	[ aBlock value ] ensure: [ self stop ]! !

!SignalLogger methodsFor: 'registration' stamp: ''!
stop

	self beacon unsubscribe: self! !

!SignalLogger methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	"by default we hook to the central ==Beacon== instance"
	beacon := Beacon instance.
	name := 'unnamed'! !

!SignalLogger methodsFor: 'registration' stamp: ''!
startFor: anAnnouncementOrASetOfAnnouncements
	"Make sure that when anAnnouncementOrASetOfAnnouncements is signaled, I receive them as argument of nextPut:."

	self isRunning ifTrue: [ self stop ].
	self beacon
		when: anAnnouncementOrASetOfAnnouncements
		send: #nextPut:
		to: self! !

!SignalLogger methodsFor: 'accessing' stamp: ''!
beacon: anAnnouncer

	beacon := anAnnouncer! !

!SignalLogger methodsFor: 'testing' stamp: ''!
isRunning
	Beacon instance announcer subscriptions 
		subscriptionsOf: self do: [ :x | ^ true ].
	^ false! !

!SignalLogger methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream 
		nextPutAll: ' named: ';
		nextPutAll: name asString! !

!SignalLogger methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!SignalLogger methodsFor: 'accessing' stamp: ''!
name: aString

	name := aString! !

!SignalLogger methodsFor: 'accessing' stamp: ''!
beacon

	^ beacon! !

!SignalLogger methodsFor: 'utilities' stamp: ''!
nextPut: aSignal
	"Gets a BeaconSignal into the logger"
	
	self subclassResponsibility ! !

!SignalLogger methodsFor: 'registration' stamp: ''!
start

	self startFor: BeaconSignal ! !

!SignalLogger methodsFor: 'utilities' stamp: ''!
nextPutAll: aCollection

	aCollection do: [ :each | self nextPut: each ]! !

!SignalLogger class methodsFor: 'registration' stamp: ''!
runDuring: aBlock

	^ self instance runDuring: aBlock! !

!SignalLogger class methodsFor: 'registration' stamp: ''!
stop
	<script>
	
	^ self instance stop! !

!SignalLogger class methodsFor: 'registration' stamp: ''!
stopAll
	<script>
	
	self withAllSubclassesDo: #stop! !

!SignalLogger class methodsFor: 'instance creation' stamp: ''!
for: aBeacon

	^ self new 
		beacon: aBeacon;
		yourself! !

!SignalLogger class methodsFor: 'registration' stamp: ''!
startFor: anAnnouncementOrASetOfAnnouncements
	"Start listening to announcements. 
	
		logger startFor: StringSignal 
	
	to scope the listening consider using
	 
		logger runFor: StringSignal during: [ ... ]"
	
	^ self instance startFor: anAnnouncementOrASetOfAnnouncements 
! !

!SignalLogger class methodsFor: 'accessing' stamp: ''!
instance

	^ instance ifNil: [ instance := self new ]! !

!SignalLogger class methodsFor: 'class initialization' stamp: ''!
resetAllInstances
	<script>

	self withAllSubclassesDo: [ :each | each resetInstance ]! !

!SignalLogger class methodsFor: 'accessing' stamp: ''!
named: aString

	^ (Beacon loggersOf: self)
		  detect: [ :each | each name = aString ]
		  ifNone: [ self new name: aString ]! !

!SignalLogger class methodsFor: 'convenience' stamp: ''!
startSingleGlobalLogger
	"Stop any other loggers and start a global instances of the receiver"
	<script>
	
	SignalLogger 
		stopAll;
		resetAllInstances.
	self start.! !

!SignalLogger class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == SignalLogger! !

!SignalLogger class methodsFor: 'class initialization' stamp: ''!
resetInstance
	<script>
	
	instance := nil! !

!SignalLogger class methodsFor: 'registration' stamp: ''!
start
	<script>
	
	^ self instance start! !

!SignalLoggerTest methodsFor: 'tests' stamp: ''!
testStartingTwiceDoesNotRegisterTwice
	| initialNumberOfSubscriptions |
	initialNumberOfSubscriptions := Beacon instance announcer numberOfSubscriptions.
	SignalLogger resetInstance.
	SignalLogger start.
	SignalLogger start.
	self 
		assert: Beacon instance announcer numberOfSubscriptions 
		equals: initialNumberOfSubscriptions + 1.
	SignalLogger stop.
	self 
		assert: Beacon instance announcer numberOfSubscriptions 
		equals: initialNumberOfSubscriptions! !

!SignalTest methodsFor: 'tests' stamp: ''!
testTimestampByDefault
	| before signal after |
	before := DateAndTime now.
	signal := BeaconSignal new.
	after := DateAndTime now.
	self assert: before <= signal timestamp.
	self assert: after >= signal timestamp.
	! !

!SignalTest methodsFor: 'tests' stamp: ''!
testPrintOneLineString
	| signal |
	signal := BeaconSignal new.
	self assert: (' ' split: signal printOneLineString) second equals: 'BeaconSignal'
 ! !

!Silder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!SimpleAnnotationContext commentStamp: ''!
I represent any annotation user from particular class hierarchy.

I am hidden from programmers. They just specify the class of annotation user when they create annotations:
	MyClassAnnotation for: MyUserClass
Internally given class is converted to my instance:
	MyUserClass asAnnotationContext

When annotations are queried for particular user instance the result will include all annotations defined for given user class and its subclasses.	
I provide little hook to redefine this rule by annotation user. Instead of simple isKindOf check:
	anAnnotationUser isKindOf: annotationUserClass 
I ask given user if it represents simple annotation user:
	anAnnotationUser representsSimpleAnnotationUser: annotationUserClass
And by default objects just performs isKindOf: check to implement it.

To create my instance manually use:
	SimpleAnnotationContext of: MyUserClass

I define comparison methods in the way that two contexts with same user class will be equal.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	annotationUserClass:		<Class>!
!SimpleAnnotationContext methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ annotationUserClass = anObject annotationUserClass! !

!SimpleAnnotationContext methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ annotationUserClass hash! !

!SimpleAnnotationContext methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream 
		nextPut: $(;
		nextPutAll: annotationUserClass name;
		nextPut: $)! !

!SimpleAnnotationContext methodsFor: 'testing' stamp: ''!
describes: anAnnotationUser
	"Following indirection provides extra flexibility for the users 
	to define special kind of simple application contexts
	and in same time to be able use simple classes to declare annotations.
	By default objects just performs isKindOf: check with my annotationUserClass"
	
	^anAnnotationUser representsSimpleAnnotationUser: annotationUserClass! !

!SimpleAnnotationContext methodsFor: 'accessing' stamp: ''!
annotationUserClass: aClass
	annotationUserClass := aClass! !

!SimpleAnnotationContext methodsFor: 'accessing' stamp: ''!
annotationUserClass
	^ annotationUserClass! !

!SimpleAnnotationContext class methodsFor: 'instance creation' stamp: ''!
of: anAnnotationUserClass
	^self new 
		annotationUserClass: anAnnotationUserClass! !

!SimpleAnnotationContext class methodsFor: 'instance creation' stamp: ''!
annotationUserClass: aClass
	^self new 
		annotationUserClass: aClass! !

!SimpleAnnotationContextTest methodsFor: 'tests' stamp: ''!
testComparison
	self assert: Object asAnnotationContext equals: Object asAnnotationContext.
	self assert: Object asAnnotationContext hash equals: Object asAnnotationContext hash.

	self deny: Object asAnnotationContext equals: Array asAnnotationContext! !

!SimpleBalloonMorph commentStamp: ''!
A simple ballon morph with straight segments!
!SimpleBalloonMorph methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	self beStraightSegments! !

!SimpleBalloonMorph class methodsFor: 'private' stamp: ''!
getVertices: bounds
	"Construct vertices for a balloon up and to left of anchor."

	^(bounds expandBy: 3) corners atAll: #(1 4 3 2)! !

!SimpleBorder commentStamp: ''!
see BorderedMorph!
!SimpleBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!SimpleBorderStyle commentStamp: ''!
see BorderedMorph!
!SimpleBorderStyle methodsFor: 'accessing' stamp: ''!
color: aColor
	color = aColor ifTrue:[^self].
	color := aColor.
	self releaseCachedState.! !

!SimpleBorderStyle methodsFor: 'accessing' stamp: ''!
width: aNumber
	width = aNumber ifTrue:[^self].
	width := aNumber truncated max: (width isPoint ifTrue:[0@0] ifFalse:[0]).
	self releaseCachedState.! !

!SimpleBorderStyle methodsFor: 'accessing' stamp: ''!
width
	^width! !

!SimpleBorderStyle methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	width := 1.
	color := Color transparent! !

!SimpleBorderStyle methodsFor: 'drawing' stamp: ''!
drawLineFrom: startPoint to: stopPoint on: aCanvas 
	| lineColor |
	lineColor := (stopPoint truncated quadrantOf: startPoint truncated) > 2 
				ifTrue: [self topLeftColor]
				ifFalse: [self bottomRightColor].
	aCanvas 
		line: startPoint
		to: stopPoint 
		width: self width
		color: lineColor! !

!SimpleBorderStyle methodsFor: 'accessing' stamp: ''!
style
	^#simple! !

!SimpleBorderStyle methodsFor: '*Athens-Morphic' stamp: ''!
asAthensPaintOn: anAthensCanvas
	^ self topLeftColor = self bottomRightColor
		ifTrue: [ super asAthensPaintOn: anAthensCanvas ]
		ifFalse: [ self asTwoColorStrokePaintOn: anAthensCanvas ]! !

!SimpleBorderStyle methodsFor: 'accessing' stamp: ''!
baseColor
	^baseColor ifNil:[Color transparent]! !

!SimpleBorderStyle methodsFor: 'accessing' stamp: ''!
topLeftColor
	"Changed from direct access to color since, if nil,
	self color is transparent."

	^self color! !

!SimpleBorderStyle methodsFor: '*Athens-Morphic' stamp: ''!
asTwoColorStrokePaintOn: anAthensCanvas
	^ AthensBorderStrokePaint
		topLeftColor: self topLeftColor
		bottomRightColor: self bottomRightColor
		width: self width
		on: anAthensCanvas! !

!SimpleBorderStyle methodsFor: 'accessing' stamp: ''!
baseColor: aColor
	| cc |
	cc := aColor isTransparent ifTrue:[nil] ifFalse:[aColor].
	baseColor = cc ifTrue:[^self].
	baseColor := cc.
	self releaseCachedState.
	self color: cc.! !

!SimpleBorderStyle methodsFor: 'accessing' stamp: ''!
bottomRightColor
	"Changed from direct access to color since, if nil,
	self color is transparent."

	^self color! !

!SimpleBorderStyle methodsFor: 'drawing' stamp: ''!
frameRectangle: aRectangle on: aCanvas
	aCanvas frameAndFillRectangle: aRectangle
		fillColor: Color transparent
		borderWidth: self width
		topLeftColor: self topLeftColor
		bottomRightColor: self bottomRightColor.! !

!SimpleBorderStyle methodsFor: 'accessing' stamp: ''!
color
	^color ifNil:[Color transparent]! !

!SimpleButtonMorph commentStamp: ''!
I am labeled, rectangular morph which allows the user to click me. I can be configured to send my "target" the message "actionSelector" with "arguments" when I am clicked. I may have a label, implemented as a StringMorph.

Example:

	SimpleButtonMorph new
		target: Beeper;
		label: 'Beep!!';
		actionSelector: #beep; 
		openInWorld

Structure:
instance var 	Type		Description 
target 			Object 		The Object to notify upon a click 
actionSelector 	Symbol 		The message to send to Target (#messageName) 
arguments 		Array 		Arguments to send with #actionSelection (optional) 
actWhen 		Symbol 		When to take action: may be #buttonUp (default), #buttonDown,
								#whilePressed, or #startDrag 
oldColor 		Color 		Used to restore color after click 

Another example: a button which quits the image without saving it.

	SimpleButtonMorph new
		target: Smalltalk;
		label: 'quit';
		actionSelector: #snapshot:andQuit:;
		arguments: (Array with: false with: true); 
		openInWorld

!
!SimpleButtonMorph methodsFor: 'visual properties' stamp: ''!
updateVisualState: evt
	
	oldColor ifNotNil: [
		 self color: 
			((self containsPoint: evt cursorPoint)
				ifTrue: [oldColor mixed: 0.5 with: Color white]
				ifFalse: [oldColor])]! !

!SimpleButtonMorph methodsFor: 'menu' stamp: ''!
setTarget: evt 
	| rootMorphs |
	rootMorphs := self world rootMorphsAt: evt hand targetPoint.
	target := rootMorphs size > 1
				ifTrue: [rootMorphs second]! !

!SimpleButtonMorph methodsFor: 'theme' stamp: ''!
themeChanged

	self
	layoutInset: (self theme buttonLabelInsetFor: self);
	cornerStyle: (self theme buttonCornerStyleIn: self window);
	fillStyle: self themedFillStyle.
	
	label ifNotNil: [ label color: self fillStyle asColor contrastingBlackAndWhiteColor ].

	super themeChanged! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: ''!
mouseStillDown: evt
	actWhen == #whilePressed ifFalse:[^self].
	(self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].! !

!SimpleButtonMorph methodsFor: 'copying' stamp: ''!
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 := arguments collect: [:each |
		deepCopier references at: each ifAbsent: [each]].! !

!SimpleButtonMorph methodsFor: 'testing' stamp: ''!
isDefault
	^ self extension isDefault! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
label
	^ label contents! !

!SimpleButtonMorph methodsFor: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
target: anObject

	target := anObject! !

!SimpleButtonMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!SimpleButtonMorph methodsFor: 'submorphs - add/remove' stamp: ''!
actWhen
	"acceptable symbols:  #buttonDown, #buttonUp, and #whilePressed"

	^ actWhen! !

!SimpleButtonMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	self borderWidth: 1.
	self color: (Color r: 0.4 g: 0.8 b: 0.6).
	self borderColor: self color darker.
	self borderStyle: BorderStyle thinGray.
	actionSelector := #flash.
	arguments := EmptyArray.
	actWhen := #buttonUp.
	self setDefaultLabel! !

!SimpleButtonMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
arguments

	^ arguments! !

!SimpleButtonMorph methodsFor: 'button' stamp: ''!
doButtonAction
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	(target notNil and: [actionSelector notNil]) 
		ifTrue: 
			[Cursor normal 
				showWhile: [target perform: actionSelector withArguments: arguments]].
	actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: ''!
handlesMouseStillDown: evt
	^actWhen == #whilePressed! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
label: aString
	self label: aString font: StandardFonts buttonFont! !

!SimpleButtonMorph methodsFor: 'menu' stamp: ''!
setLabel

	| newLabel |
	newLabel := UIManager default
		request: 'Please enter a new label for this button' translated
		initialAnswer: self label.
	newLabel isEmptyOrNil ifFalse: [self labelString: newLabel].! !

!SimpleButtonMorph methodsFor: 'menu' stamp: ''!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	self addLabelItemsTo: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'change action selector' selector: #setActionSelector.
	aCustomMenu add: 'change arguments' selector: #setArguments.
	aCustomMenu add: 'change when to act' selector: #setActWhen.
	self addTargetingMenuItems: aCustomMenu hand: aHandMorph.! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
fitContents
	| aMorph aCenter |
	aCenter := self center.
	submorphs isEmpty ifTrue: [^self].
	aMorph := submorphs first.
	self extent: aMorph extent + (borderWidth + 6).
	self center: aCenter.
	aMorph position: aCenter - (aMorph extent // 2)! !

!SimpleButtonMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!SimpleButtonMorph methodsFor: 'events-processing' stamp: ''!
mouseStillDownStepRate
	"Answer how often I want the #handleMouseStillDown: stepped"
	^200! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^  true! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: ''!
mouseUp: evt
	super mouseUp: evt.
	oldColor ifNotNil:
		["if oldColor nil, it signals that mouse had not gone DOWN
		inside me, e.g. because of a cmd-drag; in this case we want
		to avoid triggering the action!!"
		self color: oldColor.
		oldColor := nil.
		(self containsPoint: evt cursorPoint) 
				ifTrue: [ actWhen == #buttonUp 
							ifTrue: [self doButtonAction]  ]
				ifFalse: [ self mouseLeave: evt "This is a balk. Note that we have left." ]]! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
target

	^ target! !

!SimpleButtonMorph methodsFor: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!SimpleButtonMorph methodsFor: 'menu' stamp: ''!
setArguments
	| newArgs newArgsArray |
	newArgs := UIManager default
		request:
			'Please type the arguments to be sent to the target
when this button is pressed separated by periods' translated
		initialAnswer: (String streamContents: [ :str | arguments do: [ :arg | arg printOn: str. str nextPutAll: '. ' ] ]).
	newArgs isEmptyOrNil ifFalse: [ 
			newArgsArray := self class compiler
				source: '{' , newArgs , '}';
				receiver: self;
				evaluate.
			self arguments: newArgsArray ]! !

!SimpleButtonMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
arguments: aCollection

	arguments := aCollection asArray copy.! !

!SimpleButtonMorph methodsFor: 'menu' stamp: ''!
setActionSelector

	| newSel |
	newSel := UIManager default
		request:
'Please type the selector to be sent to
the target when this button is pressed' translated
		initialAnswer: actionSelector.
	newSel isEmptyOrNil ifFalse: [self actionSelector: newSel].! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector := nil].

	actionSelector := aSymbolOrString asSymbol.! !

!SimpleButtonMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!SimpleButtonMorph methodsFor: 'theme' stamp: ''!
themedFillStyle

	^self theme buttonNormalFillStyleFor: self! !

!SimpleButtonMorph methodsFor: 'balloon' stamp: ''!
helpText

	^ self balloonText! !

!SimpleButtonMorph methodsFor: 'menu' stamp: ''!
addLabelItemsTo: aCustomMenu hand: aHandMorph 
	aCustomMenu add: 'change label' selector: #setLabel! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
labelString: aString

	label ifNil: [self label: aString]
		ifNotNil:
			[label contents: aString.
			self fitContents]! !

!SimpleButtonMorph methodsFor: 'geometry' stamp: ''!
extent: newExtent

	super extent: newExtent.
	label ifNotNil: [label position: self center - (label extent // 2)].! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: ''!
mouseMove: evt
	actWhen == #buttonDown ifTrue: [^ self].
	self updateVisualState: evt.! !

!SimpleButtonMorph methodsFor: 'initialization' stamp: ''!
defaultLabel
	^ 'Flash'.! !

!SimpleButtonMorph methodsFor: 'initialization' stamp: ''!
setDefaultLabel
	self label: self defaultLabel! !

!SimpleButtonMorph methodsFor: 'copying' stamp: ''!
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"
"actionSelector := actionSelector.		a Symbol"
"arguments := arguments.		All weakly copied"
actWhen := actWhen veryDeepCopyWith: deepCopier.
oldColor := oldColor veryDeepCopyWith: deepCopier.
label := label veryDeepCopyWith: deepCopier.! !

!SimpleButtonMorph methodsFor: 'menu' stamp: ''!
setActWhen
	| selections |
	selections := #(#buttonDown #buttonUp #whilePressed #startDrag ).
	actWhen := UIManager default
				chooseFrom: (selections collect: [:t | t translated])
				values: selections
				title: 'Choose one of the following conditions' translated! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
actionSelector

	^ actionSelector! !

!SimpleButtonMorph methodsFor: 'balloon' stamp: ''!
helpText: aString

	self setBalloonText: aString! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt

	super mouseDown: evt.
	evt yellowButtonPressed ifTrue: [ ^self ] .
	oldColor := self fillStyle. 
	actWhen == #buttonDown
		ifTrue: [ self doButtonAction]
		ifFalse: [ self updateVisualState: evt ].
	self mouseStillDown: evt.! !

!SimpleButtonMorph methodsFor: 'menu' stamp: ''!
clearTarget

	target := nil.! !

!SimpleButtonMorph methodsFor: 'submorphs - add/remove' stamp: ''!
actWhen: condition
	"Accepts symbols:  #buttonDown, #buttonUp, and #whilePressed, #startDrag"
	actWhen := condition.
	actWhen == #startDrag
		ifFalse: [self on: #startDrag send: nil to: nil ]
		ifTrue:[self on: #startDrag send: #doButtonAction to: self].! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: ''!
label: aString font: aFont

	label ifNotNil: [label delete].
	label := StringMorph contents: aString font: (aFont ifNil: [StandardFonts buttonFont]).
	self extent: (label width + 6) @ (label height + 6).
	label position: self center - (label extent // 2).
	self addMorph: label.
	label lock! !

!SimpleButtonMorph methodsFor: 'menu' stamp: ''!
addTargetingMenuItems: aCustomMenu hand: aHandMorph 
	"Add targeting menu items"
	aCustomMenu addLine.
	aCustomMenu add: 'set target' selector: #targetWith:.
	target
		ifNotNil: [aCustomMenu add: 'clear target' translated selector: #clearTarget]! !

!SimpleButtonMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SimpleButtonMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SimpleButtonMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SimpleButtonMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SimpleButtonMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SimpleButtonMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SimpleButtonMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SimpleButtonMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SimpleButtonMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SimpleButtonMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SimpleButtonMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SimpleButtonMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SimpleButtonMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SimpleButtonMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SimpleButtonMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SimpleButtonMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SimpleButtonMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SimpleButtonMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SimpleButtonMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SimpleButtonMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SimpleButtonMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SimpleButtonMorph class methodsFor: 'instance creation' stamp: ''!
newWithLabel: labelString

	^(self new) 
		label: labelString;
		yourself! !

!SimpleButtonMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SimpleButtonMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SimpleButtonMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SimpleButtonMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SimpleButtonMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SimpleButtonMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SimpleButtonMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SimpleButtonMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SimpleGridExample commentStamp: ''!
SimpleGridExample new open!
!SimpleGridExample methodsFor: 'instance creation' stamp: ''!
open
	(self treeMorph buildContents;
		embeddedInMorphicWindowLabeled: 'Simple grid example') openInWorld! !

!SimpleGridExample methodsFor: 'user interface' stamp: ''!
treeMorph
	| treeMorph |
	treeMorph := (self treeMorphClass on: self)
		beCheckList;
		beMultiple;
		columns: {MorphTreeColumn new startWidth: 100;
						rowMorphGetSelector: #firstNameMorph;
						headerButtonLabel: 'First name' font:  nil.
					MorphTreeColumn new startWidth: 150;
						rowMorphGetSelector: #secondNameMorph;
						headerButtonLabel: 'Second name' font:  nil.
					MorphTreeColumn new startWidth: 50;
						rowMorphGetSelector: #ageMorph;
						headerButtonLabel: 'Age' font:  nil.
					MorphTreeColumn new startWidth: 50;
						rowMorphGetSelector: #marriedMorph;
					 	headerButtonLabel: 'Married' font: nil};
		columnInset: 3;
		rowInset: 1;
		preferedPaneColor: Color white;
		rowColorForEven:  Color veryLightGray muchLighter odd: Color white .
	^ treeMorph! !

!SimpleGridExample methodsFor: 'accessing' stamp: ''!
rootNodeClassFromItem: anItem
	^ SimpleGridNodeExample! !

!SimpleGridExample methodsFor: 'accessing' stamp: ''!
rootItems
	^ rootItems ifNil: [rootItems := (1 to: 1000)
		collect: [:i | PersonDataExample
				firstName: 'Person' , i asString
				secondName: 'Person' , i asString , ' second name'
				age: i
				married: false] ]! !

!SimpleGridExample class methodsFor: 'examples' stamp: ''!
example

	SimpleGridExample new open! !

!SimpleGridNodeExample commentStamp: ''!
Example for a simple grid node!
!SimpleGridNodeExample methodsFor: 'accessing' stamp: ''!
married: aBoolean
	self item married: aBoolean.
	self changed: #married! !

!SimpleGridNodeExample methodsFor: 'accessing' stamp: ''!
age: anInteger
	self item age: anInteger.
	self changed: #age! !

!SimpleGridNodeExample methodsFor: 'accessing' stamp: ''!
secondName: aString
	self item secondName: aString.
	self changed: #secondName! !

!SimpleGridNodeExample methodsFor: 'accessing' stamp: ''!
firstName
	^ self item firstName! !

!SimpleGridNodeExample methodsFor: 'accessing - morphs' stamp: ''!
marriedMorph
	^ ( self theme  
			newCheckboxIn: self
			for: self 
			getSelected: #married
			setSelected: #married:
			getEnabled: nil
			label: '' 
			help: nil) color: Color transparent! !

!SimpleGridNodeExample methodsFor: 'accessing - morphs' stamp: ''!
firstNameMorph
	^ (self theme  
		newTextEntryIn: self
		for: self 
		get: #firstName
		set: #firstName:
		class: String
		getEnabled: nil
		help: nil) color: Color transparent! !

!SimpleGridNodeExample methodsFor: 'accessing' stamp: ''!
married
	^ self item married! !

!SimpleGridNodeExample methodsFor: 'accessing' stamp: ''!
age
	^ self item age! !

!SimpleGridNodeExample methodsFor: 'accessing' stamp: ''!
secondName
	^ self item secondName! !

!SimpleGridNodeExample methodsFor: 'accessing - morphs' stamp: ''!
secondNameMorph
	^ (self theme  
		newTextEntryIn: self
		for: self 
		get: #secondName
		set: #secondName:
		class: String
		getEnabled: nil
		help: nil) color: Color transparent! !

!SimpleGridNodeExample methodsFor: 'accessing' stamp: ''!
firstName: aString
	self item firstName: aString.
	self changed: #firstName! !

!SimpleGridNodeExample methodsFor: 'accessing - morphs' stamp: ''!
ageMorph
	^ (self theme  
		newTextEntryIn: self
		for: self 
		get: #age
		set: #age:
		class: Integer
		getEnabled: nil
		help: nil) color: Color transparent! !

!SimpleHierarchicalListMorph commentStamp: ''!
Display a hierarchical list of items.  Each item should be wrapped with a ListItemWrapper.

For a simple example, look at submorphsExample.  For beefier examples, look at ObjectExplorer or FileList.!
!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
lineColor: aColor
	^lineColor := aColor! !

!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: ''!
getSelectionIndex
	^scroller submorphs indexOf: selectedMorph! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: ''!
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"! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
columns

	^columns! !

!SimpleHierarchicalListMorph methodsFor: 'updating' stamp: ''!
keyboardFocusChange: aBoolean
	"The message is sent to a morph when its keyboard focus changes.
	Update for focus feedback."
	super keyboardFocusChange: aBoolean.
	self focusChanged! !

!SimpleHierarchicalListMorph methodsFor: 'geometry' stamp: ''!
scrollDeltaHeight
	^ scroller firstSubmorph height! !

!SimpleHierarchicalListMorph methodsFor: 'private' stamp: ''!
addMorphsTo: morphList from: aCollection allowSorting: sortBoolean withExpandedItems: expandedItems atLevel: newIndent

	| priorMorph newCollection firstAddition |
	priorMorph := nil.
	newCollection := (sortBoolean and: [sortingSelector notNil]) ifTrue: [
		(aCollection asSortedCollection: [ :a :b | 
			(a perform: sortingSelector) <= (b perform: sortingSelector)]) asOrderedCollection
	] ifFalse: [
		aCollection
	].
	firstAddition := nil.
	newCollection do: [:item | 
		priorMorph := self indentingItemClass basicNew 
			initWithContents: item 
			prior: priorMorph 
			forList: self
			indentLevel: newIndent.
		firstAddition ifNil: [firstAddition := priorMorph].
		morphList add: priorMorph.
		((item hasEquivalentIn: expandedItems) or: [priorMorph isExpanded]) ifTrue: [
			priorMorph isExpanded: true.
			priorMorph 
				addChildrenForList: self 
				addingTo: morphList
				withExpandedItems: expandedItems.
		].
	].
	^firstAddition! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: ''!
selectionIndex: idx
	"Called internally to select the index-th item."
	| theMorph range index |
	idx ifNil: [^ self].
	index := idx min: scroller submorphs size max: 0.
	(theMorph := index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: index])
		ifNotNil:
		[((theMorph bounds top - scroller offset y) >= 0
			and: [(theMorph bounds bottom - scroller offset y) <= self innerBounds height]) ifFalse:
			["Scroll into view -- should be elsewhere"
			range := self vTotalScrollRange.
			scrollBar value: (range > 0
				ifTrue: [((index-1 * theMorph height) / self vTotalScrollRange)
									truncateTo: scrollBar scrollDelta]
				ifFalse: [0]).
			scroller offset: -3 @ (range * scrollBar value)]].
	self selectedMorph: theMorph! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: ''!
potentialDropMorph
	^potentialDropMorph! !

!SimpleHierarchicalListMorph methodsFor: 'private' stamp: ''!
insertNewMorphs: morphList

	scroller addAllMorphs: morphList.
	self adjustSubmorphPositions.
	self selection: self getCurrentSelectionItem.
	self setScrollDeltas.! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
notExpandedForm
	"Answer the form to use for unexpanded items."
	
	^self theme treeUnexpandedForm! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
searchedElement

	^ searchedElement! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: ''!
drawLinesOn: aCanvas
	"Draw the lines for the submorphs.
	Modified for performance."
	
	| lColor|
	lColor := self lineColor.
	aCanvas 
		transformBy: scroller transform
		clippingTo: scroller innerBounds
		during: [:clippedCanvas |
			scroller submorphs do: [ :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 lineColor: lColor]]]
		smoothing: scroller smoothing! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: ''!
setSelectedMorph: aMorph

	model 
		perform: (setSelectionSelector ifNil: [^self]) 
		with: aMorph complexContents	"leave last wrapper in place"! !

!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
themeChanged
	"Update the selection colour."

	self selectionColor: self theme selectionColor.
	self color: self defaultColor.
	super themeChanged! !

!SimpleHierarchicalListMorph methodsFor: 'scrolling' stamp: ''!
vUnadjustedScrollRange
"Return the width of the widest item in the list"

	(scroller submorphs size > 0) ifFalse:[ ^0 ].
	^scroller submorphs last fullBounds bottom! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
indentingItemClass
	
	^IndentingListItemMorph! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
roots
	"Answer the receiver's roots"
	^ scroller submorphs
		select: [:each | each indentLevel isZero]! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: ''!
selection: item
	"Called from outside to request setting a new selection.
	Assumes scroller submorphs is exactly our list.
	Note: MAY NOT work right if list includes repeated items"

	| i |
	item ifNil: [^self selectionIndex: 0].
	i := scroller submorphs findFirst: [:m | m complexContents == item].
	i > 0 ifTrue: [^self selectionIndex: i].
	i := scroller submorphs findFirst: [:m | m withoutListWrapper = item withoutListWrapper].
	self selectionIndex: i! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: ''!
selectedMorph: aMorph

	self unhighlightSelection.
	selectedMorph := aMorph.
	self highlightSelection! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
allItems

	^ (submorphs detect:[:each | each class = TransformMorph ]) submorphs! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
collapseAll: aMorph
	| allChildren |
	aMorph toggleExpandedState.
	allChildren := OrderedCollection new: 10.
	aMorph recursiveAddTo: allChildren.
	allChildren do: [:each | 
		each isExpanded
			ifTrue: [self collapseAll: each]].! !

!SimpleHierarchicalListMorph methodsFor: 'actions' stamp: ''!
expandAll
	"Expand all of the roots!!"
	
	self roots do: [:m |
		self expandAll: m].
	self adjustSubmorphPositions! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"
	super initialize.
	self initForKeystrokes.
	self
		on: #mouseMove
		send: #mouseStillDown:onItem:
		to: self! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: ''!
acceptDroppingMorph: aMorph event: evt

	self model
		acceptDroppingMorph: aMorph
		event: evt
		inMorph: self.
	self resetPotentialDropMorph.
	evt hand releaseMouseFocus: self.
	Cursor normal show.! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: ''!
expandAll: aMorph
	| allChildren |
	aMorph toggleExpandedState.
	allChildren := OrderedCollection new: 10.
	aMorph recursiveAddTo: allChildren.
	allChildren do: [:each | 
		(each canExpand and: [each isExpanded not])
			ifTrue: [self expandAll: each]].! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: ''!
mouseEnter: event
	"Changed to take keyboardFocusOnMouseDown into account."
	
	super mouseEnter: event.
	self wantsKeyboardFocus ifFalse: [^self].
	self keyboardFocusOnMouseDown
		ifFalse: [self takeKeyboardFocus]! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: ''!
selectedMorph
	^selectedMorph! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
columns: anArray

	columns := anArray! !

!SimpleHierarchicalListMorph methodsFor: 'geometry' stamp: ''!
scrollDeltaWidth
"A guess -- assume that the width of a char is approx 1/2 the height of the font"
	^ self scrollDeltaHeight // 2! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
selectionColor: aColor
	"Set the colour for selected items."

	| window |
	aColor
		ifNil: [ self removeProperty: #selectionColor ]
		ifNotNil: [ self setProperty: #selectionColor toValue: aColor ].
		
	window := self ownerThatIsA: SystemWindow.
	
	self selectionColorToUse: ((self theme fadedBackgroundWindows not or: [ window isNil or: [ window isActive ] ])
		ifTrue: [ aColor ]
		ifFalse: [ self theme unfocusedSelectionColor ])! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
listItemHeight
	"This should be cleaned up.  The list should get spaced by this parameter."
	^ 12! !

!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: ''!
toggleExpandedState: aMorph
	aMorph toggleExpandedState.
	self adjustSubmorphPositions.! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: ''!
expandRoots
	"Expand all the receiver's roots"
	self roots
		do: [:each |
			(each canExpand and: [each isExpanded not])
				ifTrue: [each toggleExpandedState]].
	self adjustSubmorphPositions! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: ''!
keyStroke: event

	"Process potential command keys that are not handled by keymappings yet"
	| aCharacter |

	aCharacter := event keyValue asCharacter.
	event anyModifierKeyPressed
		ifFalse: [ self basicKeyPressed: aCharacter.
			^ false
			].
	( self scrollByKeyboard: event )
		ifTrue: [ ^ true ].
	^ false! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: ''!
resetPotentialDropMorph
	potentialDropMorph ifNotNil: [
		potentialDropMorph resetHighlightForDrop.
		potentialDropMorph := nil]! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
sortingSelector: s

	sortingSelector := s! !

!SimpleHierarchicalListMorph methodsFor: 'actions' stamp: ''!
adoptPaneColor: paneColor
	"Pass on to the border too."
	
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	self selectionColor: self selectionColor.
	self borderStyle baseColor: paneColor twiceDarker! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: ''!
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 dragPassengerFor: itemMorph inMorph: self.
	passenger
		ifNotNil: [
			aTransferMorph := self model transferFor: passenger from: self.
			aTransferMorph align: aTransferMorph draggedMorph center with: anEvent position.
			aTransferMorph
				dragTransferType: (self model dragTransferTypeForMorph: self).
			anEvent hand grabMorph: aTransferMorph].
	anEvent hand releaseMouseFocus: self! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
getListSelector
	"Answer for compatibility with PluggableListMorph."
	
	^ getListSelector! !

!SimpleHierarchicalListMorph methodsFor: 'updating' stamp: ''!
selectionFrameChanged
	"Invalidate frame of the current selection if any."
	
	selectedMorph ifNil: [ ^self ].
	self invalidRect: self selectionFrame! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: ''!
mouseUp: event 
	"Fixed up highlight problems."
	
	| aMorph wasHigh|
	aMorph := self itemFromPoint: event position.
	wasHigh := aMorph notNil ifTrue: [aMorph highlightedForMouseDown] ifFalse: [false].
	scroller submorphsDo: [:m |
		m highlightedForMouseDown ifTrue: [m highlightForMouseDown: false]].
	aMorph ifNil: [^self].
	wasHigh ifFalse: [^self].
	model okToChange ifFalse: [^self].
	"No change if model is locked"
	((autoDeselect == true) and: [aMorph == selectedMorph]) 
		ifTrue: [self setSelectedMorph: nil]
		ifFalse: [self setSelectedMorph: aMorph].
	Cursor normal show! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	^ self theme backgroundColor! !

!SimpleHierarchicalListMorph methodsFor: 'scrolling' stamp: ''!
hExtraScrollRange
	"Return the amount of extra blank space to include below the bottom of the scroll content."
	^5! !

!SimpleHierarchicalListMorph methodsFor: 'actions' stamp: ''!
adjustSubmorphPositions
	"Fixed to not require setting item widths to 9999."
	
	| p |
	p := 0@0.
	scroller submorphsDo: [ :each | | h |
		h := each height.
		each privateBounds: (p extent: each width@h).
		p := p + (0@h)
	].
	self 
		changed;
		layoutChanged;
		setScrollDeltas.! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
searchedElement: anElement

	searchedElement := anElement.! !

!SimpleHierarchicalListMorph methodsFor: 'search' stamp: ''!
searchedFrame
	"Answer the frame of the selected morph in the receiver or nil if none."
	
	^searchedElement
		ifNotNil: [:elt | elt bounds: elt selectionFrame in: self]! !

!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: ''!
setSelectionIndex: idx
	"Called internally to select the index-th item."
	| theMorph index |
	idx ifNil: [^ self].
	index := idx min: scroller submorphs size max: 0.
	theMorph := index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: index].
	self setSelectedMorph: theMorph.! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Draw the selection and lines."
	
	super drawOn: aCanvas.
	searchedElement ifNotNil:
		[aCanvas clipBy: self innerBounds during: [:c |
			c
				fillRectangle: self searchedFrame
				color: (self secondarySelectionColor ifNil: [self theme secondarySelectionColor])]].
	selectedMorph ifNotNil:
		[aCanvas clipBy: self innerBounds during: [:c |
			c
				fillRectangle: self selectionFrame
				color: (self selectionColorToUse ifNil: [ self theme selectionColor ]) ] ].
	self drawLinesOn: aCanvas! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
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."

	|c colored |
	c := self lineColor.
	c isTransparent ifFalse: [^c].
	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]! !

!SimpleHierarchicalListMorph methodsFor: 'search' stamp: ''!
basicKeyPressed: aChar
	| nextSelection milliSeconds slowKeyStroke oldSelection list |
	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"	"No change if model is locked"
	model okToChange
		ifFalse: [ ^ self ].
	list := self allItems.
	list
		detect: [ :a | a searchingString trimBoth asLowercase beginsWith: lastKeystrokes ]
		ifFound: [ :nextSelectionNode | 
			nextSelection := list indexOf: nextSelectionNode ifAbsent: [ 0 ].	"The following line is a workaround around the behaviour of OBColumn>>selection:,
	 which deselects when called twice with the same argument."
			self searchedElement: nextSelectionNode.
			lastSelection := nextSelection.	"change scrollbarvalue"
			^ self vScrollValue: (nextSelection - 1) / list size ]! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: ''!
getCurrentSelectionItem

	^model perform: (getSelectionSelector ifNil: [^nil])! !

!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: ''!
arrowKey: aChar
	"Handle a keyboard navigation character. Answer true if handled, false if not."

	| keyEvent |
	keyEvent := aChar asciiValue.
	keyEvent = 31
		ifTrue: [ 
			"down"
			self setSelectionIndex: self getSelectionIndex + 1.
			^ true ].
	keyEvent = 30
		ifTrue: [ 
			"up"
			self setSelectionIndex: (self getSelectionIndex - 1 max: 1).
			^ true ].
	keyEvent = 1
		ifTrue: [ 
			"home"
			self setSelectionIndex: 1.
			^ true ].
	keyEvent = 4
		ifTrue: [ 
			"end"
			self setSelectionIndex: scroller submorphs size.
			^ true ].
	keyEvent = 11
		ifTrue: [ 
			"page up"
			self setSelectionIndex: (self getSelectionIndex - self numSelectionsInView max: 1).
			^ true ].
	keyEvent = 12
		ifTrue: [ 
			"page down"
			self setSelectionIndex: self getSelectionIndex + self numSelectionsInView.
			^ true ].
	keyEvent = 29
		ifTrue: [ 
			"right"
			selectedMorph
				ifNotNil: [ 
					selectedMorph canExpand
						ifTrue: [ 
							selectedMorph isExpanded not
								ifTrue: [ self toggleExpandedState: selectedMorph ]
								ifFalse: [ self setSelectionIndex: self getSelectionIndex + 1 ] ] ].
			^ true ].
	keyEvent = 28
		ifTrue: [ 
			"left"
			selectedMorph
				ifNotNil: [ 
					selectedMorph isExpanded
						ifTrue: [ self toggleExpandedState: selectedMorph ]
						ifFalse: [ 
							| i |
							"Search parent."
							selectedMorph indentLevel > 0
								ifTrue: [ 
									i := self getSelectionIndex max: 1.
									[ i > 1 and: [ (scroller submorphs at: i) indentLevel >= selectedMorph indentLevel ] ]
										whileTrue: [ i := i - 1 max: 1 ].
									self setSelectionIndex: i ] ] ].
			^ true ].
	^ false! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: ''!
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]].! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
expandedForm
	"Answer the form to use for expanded items."
	
	^self theme treeExpandedForm! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: ''!
mouseEnterDragging: evt
	| aMorph |
	(evt hand hasSubmorphs and:[self dropEnabled]) ifFalse: ["no d&d"
		^super mouseEnterDragging: evt].
	(self wantsDroppedMorph: evt hand firstSubmorph event: evt )
		ifTrue:[
			aMorph := self itemFromPoint: evt position.
			aMorph ifNotNil:[self potentialDropMorph: aMorph].
			evt hand newMouseFocus: self.
			"above is ugly but necessary for now"
		].! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
selectionColorToUse
	"Answer the colour to use for selected items."

	^self 
		valueOfProperty: #selectionColorToUse 
		ifAbsent: [ self theme selectionColor ]! !

!SimpleHierarchicalListMorph methodsFor: 'updating' stamp: ''!
update: aSymbol 
	aSymbol == getSelectionSelector 
		ifTrue: 
			[self selection: self getCurrentSelectionItem.
			^self].
	aSymbol == getListSelector 
		ifTrue: 
			[self list: self getList.
			^self].
	((aSymbol isKindOf: Array) 
		and: [aSymbol size > 1 and: [aSymbol first == getListSelector and: [
					aSymbol second == #openPath]]]) "allow directed path opening where multiple trees exist"
			ifTrue: 
				[^(scroller submorphs at: 1 ifAbsent: [^self]) 
					openPath: (aSymbol allButFirst: 2)].
	((aSymbol isKindOf: Array) 
		and: [aSymbol size > 1 and: [aSymbol first == getListSelector and: [
					aSymbol second == #openItemPath]]]) "allow directed path opening where multiple trees exist"
			ifTrue: 
				[^(scroller submorphs at: 1 ifAbsent: [^self]) 
					openItemPath: (aSymbol allButFirst: 2)].
	((aSymbol isKindOf: Array) 
		and: [aSymbol notEmpty and: [aSymbol first == #openPath]]) 
			ifTrue: 
				[^(scroller submorphs at: 1 ifAbsent: [^self]) 
					openPath: aSymbol allButFirst].
	((aSymbol isKindOf: Array) 
		and: [aSymbol size  = 2 and: [aSymbol first = getListSelector and: [
					aSymbol second == #expandRoots]]]) 
			ifTrue: 
				[^self expandRoots].
	((aSymbol isKindOf: Array) 
		and: [aSymbol notEmpty and: [aSymbol first = getListSelector and: [
					aSymbol second == #expandAll]]]) 
			ifTrue: 
				[^self expandAll]! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: ''!
potentialDropMorph: aMorph
	potentialDropMorph := aMorph.
	aMorph highlightForDrop! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: ''!
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]].! !

!SimpleHierarchicalListMorph methodsFor: 'events-processing' stamp: ''!
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].! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
getList 
	"Answer the list to be displayed."

	^(model perform: (getListSelector ifNil: [^#()])) ifNil: [#()]! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: ''!
minimumSelection
	^ 1! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
collapseAll
	"Expand all of the roots!!"
	
	self roots do: [:m |
		self collapseAll: m].
	self adjustSubmorphPositions! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
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."

	| colored |
	lineColor ifNotNil: [^lineColor ].
	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]! !

!SimpleHierarchicalListMorph methodsFor: 'private' stamp: ''!
addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean

	| priorMorph morphList newCollection |
	priorMorph := nil.
	newCollection := (sortBoolean and: [sortingSelector notNil]) ifTrue: [
		(aCollection asSortedCollection: [ :a :b | 
			(a perform: sortingSelector) <= (b perform: sortingSelector)]) asOrderedCollection
	] ifFalse: [
		aCollection
	].
	morphList := OrderedCollection new.
	newCollection do: [:item | 
		priorMorph := self indentingItemClass basicNew 
			initWithContents: item 
			prior: priorMorph 
			forList: self
			indentLevel: parentMorph indentLevel + 1.
		morphList add: priorMorph.
	].
	scroller addAllMorphs: morphList after: parentMorph.
	^morphList! !

!SimpleHierarchicalListMorph methodsFor: 'geometry' stamp: ''!
extent: newExtent
	bounds extent = newExtent ifTrue: [^ self].
	super extent: newExtent.
	self setScrollDeltas! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: ''!
maximumSelection

	^ scroller submorphs size! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: ''!
mouseMove: evt

	|aMorph|
	aMorph := self itemFromPoint: evt position.
	evt hand hasSubmorphs ifFalse: [
		(aMorph isNil or: [aMorph highlightedForMouseDown not])
			ifTrue: [scroller submorphsDo: [:m |
					m highlightedForMouseDown ifTrue: [m highlightForMouseDown: false]].
					aMorph ifNotNil: [aMorph highlightForMouseDown]]].
	(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].! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
initForKeystrokes
	lastKeystrokeTime := 0.
	lastKeystrokes := ''.
	lastSelection := 0! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
notExpandedFormForMorph: aMorph
	^ (self selectedMorph = aMorph and: [self theme selectionColor luminance < 0.6])
		ifTrue: [self theme whiteTreeUnexpandedForm]
		ifFalse: [self theme treeUnexpandedForm]! !

!SimpleHierarchicalListMorph methodsFor: 'private' stamp: ''!
noteRemovalOfAll: aCollection

	scroller removeAllMorphsIn: aCollection.
	(aCollection includes: selectedMorph) ifTrue: [self setSelectedMorph: nil].! !

!SimpleHierarchicalListMorph methodsFor: 'search' stamp: ''!
secondarySelectionColor
	^ self theme secondarySelectionColor! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOverDragging: evt
	^self dropEnabled! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
selectionColor
	"Answer the colour to use for selected items."

	^self valueOfProperty: #selectionColor ifAbsent: []! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
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 selectionFrameChanged! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: ''!
selectionFrame
	"Answer the frame of the selected morph in the receiver or nil if none."
	
	^selectedMorph
		ifNotNil: [selectedMorph bounds:  selectedMorph selectionFrame in: self]! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: ''!
selectionOneOf: aListOfItems
	"Set the selection to the first item in the list which is represented by one of my submorphs"

	
	aListOfItems do: [ :item | | index |
		index := scroller submorphs findFirst: [:m | 
			m withoutListWrapper = item withoutListWrapper
		].
		index > 0 ifTrue: [^self selectionIndex: index].
	].
	self selectionIndex: 0.! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: ''!
unhighlightSelection
	selectedMorph ifNotNil: [selectedMorph unhighlight]! !

!SimpleHierarchicalListMorph methodsFor: 'actions' stamp: ''!
expandedFormForMorph: aMorph
	"Answer the form to use for expanded items."
	
	^ (self selectedMorph = aMorph and: [self theme selectionColor luminance < 0.6])
		ifTrue: [self theme whiteTreeExpandedForm]
		ifFalse: [self theme treeExpandedForm]! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
autoDeselect: trueOrFalse
	"Enable/disable autoDeselect (see class comment)"
	autoDeselect := trueOrFalse.! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel

	self model: anObject.
	getListSelector := getListSel.
	getSelectionSelector := getSelectionSel.
	setSelectionSelector := setSelectionSel.
	getMenuSelector := getMenuSel.
	autoDeselect := true.
	self borderWidth: 1.
	self list: self getList.! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	"Changed to take keybaord focus."
	
	| aMorph selectors |
	self wantsKeyboardFocus
		ifTrue: [self takeKeyboardFocus].
	aMorph := self itemFromPoint: evt position.
	(aMorph notNil and:[aMorph inToggleArea: (aMorph point: evt position from: self)])
		ifTrue:[^self toggleExpandedState: aMorph event: evt]. 
	
	evt yellowButtonPressed  "First check for option (menu) click"
		ifTrue: [ 
			(self yellowButtonActivity: evt shiftPressed) 
				ifTrue: [ ^ self ]].
		
	aMorph ifNil:[^super mouseDown: evt].
	aMorph highlightForMouseDown.
	selectors := Array 
		with: #click:
		with: nil
		with: nil
		with: (self dragEnabled ifTrue:[#startDrag:] ifFalse:[nil]).
	evt hand waitForClicksOrDrag: self event: evt selectors: selectors threshold: 10 "pixels".! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	^true! !

!SimpleHierarchicalListMorph methodsFor: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher

	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #SimpleHierarchicalList.
	aKMDispatcher attachCategory: #MorphFocusNavigation! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
currentlyExpanded

	^(scroller submorphs select: [ :each | each isExpanded]) collect: [ :each | each complexContents]! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel

	self model: anObject.
	getListSelector := getListSel.
	getSelectionSelector := getSelectionSel.
	setSelectionSelector := setSelectionSel.
	getMenuSelector := getMenuSel.
	autoDeselect := true.
	self borderWidth: 1.
	self list: self getList.! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: ''!
highlightSelection

	selectedMorph ifNotNil: [selectedMorph highlight]! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: ''!
wantsDroppedMorph: aMorph event: anEvent 
	^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: ''!
toggleExpandedState: aMorph event: event
	| oldState |
	"self setSelectedMorph: aMorph."
	event yellowButtonPressed ifTrue: [
		oldState := aMorph isExpanded.
		scroller submorphs copy do: [ :each |
			(each canExpand and: [each isExpanded = oldState]) ifTrue: [
				each toggleExpandedState.
			].
		].
	] ifFalse: [
		aMorph toggleExpandedState.
	].
	self adjustSubmorphPositions.! !

!SimpleHierarchicalListMorph methodsFor: 'testing' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: ''!
list: aCollection

	| wereExpanded morphList |
	wereExpanded := self currentlyExpanded.
	scroller removeAllMorphs.
	(aCollection isNil or: [aCollection isEmpty]) ifTrue: [^ self selectedMorph: nil].
	morphList := OrderedCollection new.
	self 
		addMorphsTo: morphList
		from: aCollection 
		allowSorting: false
		withExpandedItems: wereExpanded
		atLevel: 0.
	self insertNewMorphs: morphList.! !

!SimpleHierarchicalListMorph class methodsFor: 'shortcuts' stamp: ''!
buildSimpleHierarchicalListShortcuts: aBuilder
	<keymap>
	(aBuilder shortcut: #cursorUp)
		category: #SimpleHierarchicalList
		default: Character arrowUp asKeyCombination
		do: [ :target | target setSelectionIndex: (target getSelectionIndex - 1 max: 1) ].
	(aBuilder shortcut: #cursorDown)
		category: #SimpleHierarchicalList
		default: Character arrowDown asKeyCombination
		do: [ :target | target setSelectionIndex: target getSelectionIndex + 1 ].
	(aBuilder shortcut: #cursorHome)
		category: #SimpleHierarchicalList
		default: Character home asKeyCombination
		do: [ :target | target setSelectionIndex: 1 ].
	(aBuilder shortcut: #cursorEnd)
		category: #SimpleHierarchicalList
		default: Character end asKeyCombination
		do: [ :target | target setSelectionIndex: target scroller submorphs size ].
	(aBuilder shortcut: #cursorPageUp)
		category: #SimpleHierarchicalList
		default: Character pageUp asKeyCombination
		do: [ :target | target setSelectionIndex: (target getSelectionIndex - target numSelectionsInView max: 1) ].
	(aBuilder shortcut: #cursorPageDown)
		category: #SimpleHierarchicalList
		default: Character pageDown asKeyCombination
		do: [ :target | target setSelectionIndex: target getSelectionIndex + target numSelectionsInView ].
	(aBuilder shortcut: #cursorRight)
		category: #SimpleHierarchicalList
		default: Character arrowRight asKeyCombination
		do: [ :target | 
			target selectedMorph
				ifNotNil: [ 
					target selectedMorph canExpand
						ifTrue: [ 
							target selectedMorph isExpanded not
								ifTrue: [ target toggleExpandedState: target selectedMorph ]
								ifFalse: [ target setSelectionIndex: target getSelectionIndex + 1 ] ] ] ].
	(aBuilder shortcut: #cursorLeft)
		category: #SimpleHierarchicalList
		default: Character arrowLeft asKeyCombination
		do: [ :target | 
			| selectedMorph |
			(selectedMorph := target selectedMorph)
				ifNotNil: [ 
					selectedMorph isExpanded
						ifTrue: [ target toggleExpandedState: selectedMorph ]
						ifFalse: [ 
							| i |
							"Search parent."
							selectedMorph indentLevel > 0
								ifTrue: [ 
									i := target getSelectionIndex max: 1.
									[ i > 1 and: [ (target scroller submorphs at: i) indentLevel >= selectedMorph indentLevel ] ]
										whileTrue: [ i := i - 1 max: 1 ].
									target setSelectionIndex: i ] ] ] ]! !

!SimpleHierarchicalListMorph class methodsFor: 'examples' stamp: ''!
exampleSubmorphs
	"display a hierarchical list of the World plus its submorphs plus its submorphs' submorphs etc."
	"[SimpleHierarchicalListMorph exampleSubmorphs]"
	| morph |
	morph :=
		SimpleHierarchicalListMorph
			on: [ Array with:  (MorphWithSubmorphsWrapper with: self currentWorld)  ]
			list: #value
			selected: nil
			changeSelected: nil
			menu: nil.

	morph openInWindow! !

!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: ''!
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! !

!SimpleServiceEntry commentStamp: ''!
I represent a service

provider : the service provider
label : to be display in a menu
selector : to do the service
useLineAfter
stateSelector : a secondary selector (to be able to query state of the provider for example)
description : a description for balloon for example
argumentGetter : a selector to get additional arguments with (if selector requires them)
buttonLabel : a short label

The entire client interface (provided by FileList and other users of the registry)
is this (browse #getArgumentsFrom: and the 
senders of #argumentGetter:):

fullName (returns a String with the full filename)
dirAndFileName (returns {directory. fileName})
readOnlyStream (returns an open read-only stream)
!
!SimpleServiceEntry methodsFor: 'services menu' stamp: ''!
useLineAfter

	self usingLineAfter: true! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
extraSelector
	"normally should not be used directly"

	^stateSelector! !

!SimpleServiceEntry methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	self useLineAfter! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
argumentGetter: aBlock

	argumentGetter := aBlock! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
selector
	"normally should not be used directly"

	^selector! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
description: aString
	"may be used for balloon or other"

	description := aString
! !

!SimpleServiceEntry methodsFor: 'extra' stamp: ''!
performExtraFor: anObject
	"carry out the extra service I provide"
	"the stateSelector can be used to ask state of the provider to be reflected in button or other"

	^stateSelector numArgs = 0
		ifTrue: [provider perform: stateSelector]
		ifFalse: [provider perform: stateSelector with: (self getArgumentsFrom: anObject) ]
! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
description
	"may be used for balloon or other"

	^ description
! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
provider

	^ provider! !

!SimpleServiceEntry methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: self class name; nextPutAll: ': ('.
	self provider notNil
		ifTrue: [ aStream print: provider ].
	aStream nextPutAll: ' --- '. 
	self selector notNil
		ifTrue: [ aStream print: selector ].
	aStream nextPut: $)

! !

!SimpleServiceEntry methodsFor: 'extra' stamp: ''!
requestExtraSelector
	"send me this message to ask me to perform secondary service"

	^#performExtraFor:
! !

!SimpleServiceEntry methodsFor: 'performing service' stamp: ''!
provider: anObject label: aString selector: aSymbol description: anotherString 
	"basic initialization message"
	self
		provider: anObject
		label: aString
		selector: aSymbol.
	stateSelector := #none.
	description := anotherString! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
usingLineAfter: aBoolean

	usingLineAfter := aBoolean! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
extraSelector: aSymbol

	stateSelector := aSymbol! !

!SimpleServiceEntry methodsFor: '*Morphic-Widgets-Basic' stamp: ''!
buttonToTriggerIn: aFileList
	"Answer a button that will trigger the receiver service in a file list"

	| aButton |
	aButton :=  PluggableButtonMorph
					on: self
					getState: nil
					action: #performServiceFor:.
	aButton 
		arguments: { aFileList }.

	aButton
		color: Color transparent;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: self buttonLabel;
		askBeforeChanging: true;
		onColor: Color white offColor: Color white.
		aButton setBalloonText: self description.

	^ aButton! !

!SimpleServiceEntry methodsFor: '*Tool-FileList' stamp: ''!
addServiceFor: served toMenu: aMenu
	aMenu 
		add: self label 
		target: self 
		selector: #performServiceFor: 
		argument: served.
	self usingLineAfter ifTrue: [ aMenu addLine ].! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
provider: anObject label: aString selector: aSymbol 
	"basic initialization message"
	provider := anObject.
	label := aString.
	selector := aSymbol.
	stateSelector := #none.
	description := ''! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
buttonLabel: aString 
	"Set the receiver's buttonLabel, to be used on a button in a 
	tool-pane; this is split out so that a more abbreviated wording 
	can be deployed if desired"
	buttonLabel := aString! !

!SimpleServiceEntry methodsFor: 'services menu' stamp: ''!
doNotUseLineAfter

	self usingLineAfter: false! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
usingLineAfter

	^ usingLineAfter! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
buttonLabel
	"Answer the label to be emblazoned on a button representing the service in a file list, for example"

	^ buttonLabel ifNil: [label]! !

!SimpleServiceEntry methodsFor: 'performing service' stamp: ''!
getArgumentsFrom: aProvider

	argumentGetter ifNil: [^aProvider fullName].
	^argumentGetter value: aProvider! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: ''!
label
	^label! !

!SimpleServiceEntry methodsFor: 'performing service' stamp: ''!
performServiceFor: anObject
	"carry out the service I provide"

	^selector numArgs = 0
		ifTrue: [provider perform: selector]
		ifFalse: [
			selector numArgs = 1
				ifTrue: [ provider perform: selector with: (self getArgumentsFrom: anObject) ]
				ifFalse: [ provider perform: selector withArguments: (self getArgumentsFrom: anObject) ]]! !

!SimpleServiceEntry class methodsFor: 'instance creation' stamp: ''!
provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel
	"Answer a new service object with the given initializations.  This variant allows a custom button label to be provided, in order to preserve precious horizontal real-estate in the button pane, while still allowing more descriptive wordings in the popup menu"

	^ self new provider: anObject label: aString selector: aSymbol description: anotherString; buttonLabel: aLabel; yourself! !

!SimpleServiceEntry class methodsFor: 'instance creation' stamp: ''!
provider: anObject label: aString selector: aSymbol description: anotherString

	^self new provider: anObject label: aString selector: aSymbol description: anotherString! !

!SimpleServiceEntry class methodsFor: 'instance creation' stamp: ''!
provider: anObject label: aString selector: aSymbol

	^self provider: anObject label: aString selector: aSymbol description: ''.
! !

!SimpleSwitchMorph commentStamp: ''!
I represent a switch that can be either on or off.  I chnage my state in response to a mouse click.  When clicked, I also send my actionSelector to my target, just like a SimpleButtonMorph.

	SimpleSwitchMorph new openInWorld!
!SimpleSwitchMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self borderWidth: 3.
	self extent: self extent + 2.
	onColor := Color r: 1.0 g: 0.6 b: 0.6.
	offColor := Color lightGray.
	color := offColor! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: ''!
setSwitchState: aBoolean

	aBoolean
		ifTrue: [self turnOn]
		ifFalse: [self turnOff].! !

!SimpleSwitchMorph methodsFor: 'button' stamp: ''!
doButtonAction
	"Perform the action of this button. The last argument of the message sent to the target is the new state of this switch."

	| newState |
	(target notNil and: [actionSelector notNil]) 
		ifTrue: 
			[newState := color = onColor.
			target perform: actionSelector
				withArguments: (arguments copyWith: newState)]! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: ''!
toggleState
	self isOn
		ifTrue: [self turnOff]
		ifFalse: [self turnOn]! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: ''!
onColor: aColor

	onColor := aColor.! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: ''!
turnOn
	self borderColor: #inset.
	self color: onColor! !

!SimpleSwitchMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt

	oldColor := self fillStyle.! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: ''!
offColor: aColor

	offColor := aColor.! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: ''!
isOn
	^ color = onColor! !

!SimpleSwitchMorph methodsFor: 'event handling' stamp: ''!
mouseUp: evt

	(self containsPoint: evt cursorPoint)
		ifTrue: [  "toggle and do action"
			self setSwitchState: (oldColor = offColor).
			self doButtonAction]
		ifFalse: [  "restore old appearance"
			self setSwitchState: (oldColor = onColor)].! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: ''!
turnOff
	self borderColor: #raised.
	self color: offColor! !

!SimpleSwitchMorph methodsFor: 'event handling' stamp: ''!
mouseMove: evt

	(self containsPoint: evt cursorPoint)
		ifTrue: [self setSwitchState: (oldColor = offColor)]
		ifFalse: [self setSwitchState: (oldColor = onColor)].! !

!SimpleTestResource commentStamp: ''!
I'm a simple test resource for test purposes!
!SimpleTestResource methodsFor: 'accessing' stamp: ''!
runningState: aSymbol

	runningState := aSymbol! !

!SimpleTestResource methodsFor: 'running' stamp: ''!
tearDown

	self runningState: self stoppedStateSymbol! !

!SimpleTestResource methodsFor: 'running' stamp: ''!
setRun
	hasRun := true! !

!SimpleTestResource methodsFor: 'testing' stamp: ''!
hasRun
	^hasRun! !

!SimpleTestResource methodsFor: 'running' stamp: ''!
startedStateSymbol

	^#started! !

!SimpleTestResource methodsFor: 'accessing' stamp: ''!
runningState

	^runningState! !

!SimpleTestResource methodsFor: 'testing' stamp: ''!
isAvailable
	^self class allowAvailability
		and: [self runningState == self startedStateSymbol]! !

!SimpleTestResource methodsFor: 'running' stamp: ''!
stoppedStateSymbol

	^#stopped! !

!SimpleTestResource methodsFor: 'testing' stamp: ''!
hasSetup
	^hasSetup! !

!SimpleTestResource methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self runningState: self startedStateSymbol.
	hasSetup := true! !

!SimpleTestResource class methodsFor: 'accessing' stamp: ''!
allowAvailability
	^preventAvailability isNil! !

!SimpleTestResource class methodsFor: 'accessing' stamp: ''!
rawCurrentForTest
	^current! !

!SimpleTestResource class methodsFor: 'utilties' stamp: ''!
preventAvailabilityDuring: aBlock
	"Only setter of preventAvailability."
	
	preventAvailability := false.
	^aBlock ensure: [preventAvailability := nil]! !

!SimpleTestResourceA commentStamp: ''!
I'm a simple test resource for test purposes!
!SimpleTestResourceA class methodsFor: 'accessing' stamp: ''!
resources
	^Array with: SimpleTestResourceA1 with: SimpleTestResourceA2! !

!SimpleTestResourceA1 commentStamp: ''!
I'm a simple test resource for test purposes!
!SimpleTestResourceA2 commentStamp: ''!
I'm a simple test resource for test purposes!
!SimpleTestResourceB commentStamp: ''!
I'm a simple test resource for test purposes!
!SimpleTestResourceB class methodsFor: 'accessing' stamp: ''!
resources
	^Array with: SimpleTestResourceA1 with: SimpleTestResourceB1! !

!SimpleTestResourceB1 commentStamp: ''!
I'm a simple test resource for test purposes!
!SimpleTestResourceCircular commentStamp: ''!
I'm a simple test resource for test purposes!
!SimpleTestResourceCircular class methodsFor: 'accessing' stamp: ''!
resources

	^ preventAvailability
		ifNil: [ super resources , ( Array with: SimpleTestResourceA1 ) ]
		ifNotNil: [ super resources , ( Array with: SimpleTestResourceA1 with: SimpleTestResourceCircular1 ) ]! !

!SimpleTestResourceCircular1 commentStamp: ''!
I'm a simple test resource for test purposes!
!SimpleTestResourceCircular1 class methodsFor: 'accessing' stamp: ''!
resources
	"Circular prereq:  C wants C1 which wants C."
	
	^Array with: SimpleTestResourceCircular! !

!SimpleTestResourceTestCase commentStamp: ''!
SUnit tests for simple test resources!
!SimpleTestResourceTestCase methodsFor: 'tests' stamp: ''!
testResourceCollection
	self assert: self class buildSuiteFromSelectors resources size = self resources size
		description: 'The suite should have the same number of resources as its test'.
	self class buildSuiteFromSelectors resources do:
		[:each |
		self assert: (self resources includes: each)
			description: each name , ':  I have this resource but my suite does not'].! !

!SimpleTestResourceTestCase methodsFor: 'tests' stamp: ''!
testDebugTestWithResource
	"The debug will raise an error if the resource is not set up properly."
	
	self clearOuterResourceStateDuring: [(self class selector: #setRun) debug]! !

!SimpleTestResourceTestCase methodsFor: 'private' stamp: ''!
setRun
	resource setRun! !

!SimpleTestResourceTestCase methodsFor: 'private' stamp: ''!
error
	'foo' odd! !

!SimpleTestResourceTestCase methodsFor: 'utilities' stamp: ''!
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: SimpleTestResource isAlreadyAvailable
		description: 'The resource was not set up for the test'.
	SimpleTestResource reset.
	self
		deny: SimpleTestResource isAlreadyAvailable
		description: 'The resource was still set up before we began the run'.
	^aBlock
		ensure:
			[self
				deny: SimpleTestResource isAlreadyAvailable
				description: 'The resource was still set up after we finished the run'.
			SimpleTestResource isAvailable.
			self
				assert: SimpleTestResource isAlreadyAvailable
				description: 'The resource was not set up again after the test']! !

!SimpleTestResourceTestCase methodsFor: 'private' stamp: ''!
dummy
	self assert: resource hasSetup
		description: 'This test uses a resource but it was not set up'.
	self setRun.
	self assert: resource hasRun
		description: 'This test uses a resource but we could not interact with it'.! !

!SimpleTestResourceTestCase methodsFor: 'tests' stamp: ''!
testResourceInitRelease
	| suite error failure |
	suite := self classForTestSuite new.
	suite addTest: (error := self class selector: #error).
	suite addTest: (failure := self class selector: #fail).
	suite addTest: (self class selector: #dummy).
	suite run.
	self assert: resource hasSetup! !

!SimpleTestResourceTestCase methodsFor: 'tests' stamp: ''!
testRunSuiteWithResource
	| suite |
	suite :=  self classForTestSuite new.
	suite addTest: (SimpleTestResourceTestCase selector: #error).
	suite addTest: (SimpleTestResourceTestCase selector: #fail).
	suite addTest: (self class selector: #dummy).
	self clearOuterResourceStateDuring:
		[self
			assert: suite run printString = '3 ran, 1 passed, 0 skipped, 0 expected failures, 1 failure, 1 error, 0 passed unexpected'
			description: 'A suite of tests needing SimpleTestResource did not run as expected'].! !

!SimpleTestResourceTestCase methodsFor: 'tests' stamp: ''!
testRunTestWithResource
	self clearOuterResourceStateDuring:
		[self
			assert: (self class selector: #dummy) run printString =
							'1 ran, 1 passed, 0 skipped, 0 expected failures, 0 failures, 0 errors, 0 passed unexpected'
			description: 'A dummy test that needed a resource did not pass']! !

!SimpleTestResourceTestCase methodsFor: 'running' stamp: ''!
setUp
	"Ensure that we error, not just fail, if resource is nil so that #should:raise: checks cannot mistake such an error for what they are trapping."
	super setUp.
	resource := SimpleTestResource rawCurrentForTest.
	self
		deny: resource isNil
		description: 'SimpleTestResource has no current value in test'.
	self
		assert: resource class == SimpleTestResource
		description: 'SimpleTestResource current is not an instance of itself'.
	self
		assert: resource hasSetup
		description: 'This test uses a resource but it was not set up'! !

!SimpleTestResourceTestCase class methodsFor: 'history' stamp: ''!
lastStoredRun
	^ ((Dictionary new) add: (#passed->((Set new) add: #testResourceInitRelease; add: #testResourcesCollection; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! !

!SimpleTestResourceTestCase class methodsFor: 'accessing' stamp: ''!
resources
	^Array with: SimpleTestResource! !

!SimpleTextGlyphInfo commentStamp: ''!
Simple glyph infos!
!SimpleTextGlyphInfo methodsFor: 'accessing' stamp: ''!
face
	^ face! !

!SimpleTextGlyphInfo methodsFor: 'initialization' stamp: ''!
loadFrom: anFT2Face
	"Same as in superclass, but avoid converting coordinates to not waste CPU cycles"
	
	face := anFT2Face.
	anFT2Face fillGlyph: self.
	format := (EndianDetector isLittleEndian ifTrue: [ format reversed ] ifFalse: [ format ]) asString.! !

!SimpleTextGlyphInfo class methodsFor: 'instance creation' stamp: ''!
fromFace: anFT2Face
	^(self new)
		loadFrom: anFT2Face;
		yourself.! !

!SimplestClassListExample commentStamp: ''!
SimplestClassListExample new openOn: Object!
!SimplestClassListExample methodsFor: 'examples' stamp: ''!
plugOne
	| l |
	rootClass := Object.
	l := PluggableListMorph
		on: self 
		list: #rootItems
		selected: #selected
		changeSelected: #selected:.
	(l embeddedInMorphicWindowLabeled: 'test') openInWorld! !

!SimplestClassListExample methodsFor: 'view' stamp: ''!
defaultTreeMorph
	^ super defaultTreeMorph
		"beCheckList;"
		"autoDeselection: true;"
		multiSelection: true;
		autoMultiSelection: true;
		yourself! !

!SimplestClassListExample methodsFor: 'instance creation' stamp: ''!
openOn: aClass 
	rootClass := aClass.
	(self defaultTreeMorph buildContents embeddedInMorphicWindowLabeled: 'test') openInWorld
	"(self dialogWindowIn: World title: 'All Object subclasses') openInWorld"! !

!SimplestClassListExample methodsFor: 'accessing' stamp: ''!
selected: x
	selected := x.
	self changed: #selected! !

!SimplestClassListExample methodsFor: 'accessing' stamp: ''!
rootItemsOrig
	^ rootClass allSubclasses asArray sort: [:a :b | a name < b name]! !

!SimplestClassListExample methodsFor: 'accessing' stamp: ''!
selected
	^ selected ifNil: [selected := 1]! !

!SimplestClassListExample methodsFor: 'view' stamp: ''!
openDialogOn: aClass 
	rootClass := aClass.
	^ self openDialogWindowIn: self currentWorld title: 'All Object subclasses'! !

!SimplestClassListExample methodsFor: 'accessing' stamp: ''!
rootItems
	^ rootClass allSubclasses asArray sort: [:a :b | a name < b name]! !

!SimplestClassListExample methodsFor: 'accessing' stamp: ''!
rootItemsTest
	^ (rootClass allSubclasses asArray sort: [:a :b | a name < b name])! !

!SimplestClassListExample class methodsFor: 'examples' stamp: ''!
example

	SimplestClassListExample new openOn: Object! !

!SimplestClassListWithChunkExample commentStamp: ''!
SimplestClassListWithChunkExample new openOn: Object!
!SimplestClassListWithChunkExample methodsFor: 'defaults' stamp: ''!
defaultTreeMorph
	^ super defaultTreeMorph chunkSize: 100; yourself! !

!SimplestClassListWithChunkExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>

	^SimplestClassListWithChunkExample new openOn: Object! !

!SimplestClassListWithPagerExample commentStamp: ''!
SimplestClassListWithPagerExample new openOn: Object!
!SimplestClassListWithPagerExample methodsFor: 'defaults' stamp: ''!
defaultTreeMorph
	^ super defaultTreeMorph pageSize: 100; yourself! !

!SimplestClassListWithPagerExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>

	^SimplestClassListWithPagerExample new openOn: Object! !

!SimplestPaginatedClassListExample commentStamp: ''!
Example for a paginated class list!
!SimplestPaginatedClassListExample methodsFor: 'view' stamp: ''!
defaultTreeMorph
	^ super defaultTreeMorph
		multiSelection: true;
		autoMultiSelection: true;
		yourself! !

!SimplestPaginatedClassListExample methodsFor: 'instance creation' stamp: ''!
openOn: aClass 
	rootClass := aClass.
	(self dialogWindowIn: self currentWorld title: 'All Object subclasses') openInWorld! !

!SimplestPaginatedClassListExample methodsFor: 'view' stamp: ''!
openDialogOn: aClass 
	rootClass := aClass.
	^ self openDialogWindowIn: self currentWorld title: 'All Object subclasses'! !

!SimplestPaginatedClassListExample methodsFor: 'accessing' stamp: ''!
rootItems
	^ self itemsForTest asArray sort: [:a :b | a name < b name]! !

!SimplestPaginatedClassListExample methodsFor: 'accessing' stamp: ''!
itemsForTest
	^ rootClass allSubclasses! !

!SimplestPaginatedClassListExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>

	^SimplestPaginatedClassListExample new openOn: Object! !

!SimulateKeystrokesTest commentStamp: ''!
SUnit tests to simulate and test key strokes!
!SimulateKeystrokesTest methodsFor: 'tests' stamp: ''!
testSimulateCmdKeystroke

	| ws |
	ws := Smalltalk tools workspace open.
	self simulateKeyStrokes: 'var := 3.' inWorld: ws world.
	self simulateKeyStroke: $s meta inWorld: ws world.
	self assert: ws hasUnacceptedEdits equals:false.
	ws delete.! !

!SimulateKeystrokesTest methodsFor: 'tests' stamp: ''!
testSimulateKeystrokes

	| textMorph |
	textMorph := TextMorph new contents: ''; openInWorld.
	self assert: textMorph canChangeText.
	textMorph takeKeyboardFocus.
	self simulateKeyStrokes: 'hello' inWorld: textMorph world.
	self assert: textMorph contents asString equals: 'hello'.
	textMorph delete.! !

!SimulateKeystrokesTest methodsFor: 'tests' stamp: ''!
testSimulateKeystroke

	| textMorph |
	textMorph := TextMorph new contents: ''; openInWorld.
	self assert: textMorph canChangeText.
	textMorph takeKeyboardFocus.
	self simulateKeyStroke: $s inWorld: textMorph world.
	self assert: textMorph contents asString equals: 's'.
	textMorph delete.! !

!SimulateMouseTest commentStamp: ''!
SUnit tests to simulate and test mouse behavior!
!SimulateMouseTest methodsFor: 'running' stamp: ''!
tearDown

	morph delete.
	super tearDown ! !

!SimulateMouseTest methodsFor: 'helpers' stamp: ''!
timeoutAfter: aDuration ifNot: aBlock

	| timer |
	timer := Stopwatch new activate.
	[ timer duration < aDuration and: [ aBlock value not ] ] whileTrue.! !

!SimulateMouseTest methodsFor: 'tests' stamp: ''!
testSimulateMiddleClick
	
	morph := MorphHandlingMiddleButton new openInWorld.
	morph simulateMiddleClick.
	self assert: morph wasClickedWithMiddleButton.
! !

!SimulateMouseTest methodsFor: 'helpers' stamp: ''!
waitForMorphThat: aBlock

	self timeoutAfter: 2 seconds ifNot: [
		morph := self currentWorld submorphThat: aBlock ifNone: [ nil ].
		(Delay forMilliseconds: 100) wait.
		morph isNil].
	^ morph.! !

!SimulateMouseTest methodsFor: 'helpers' stamp: ''!
menuOpenedDuring: aBlock

	| jailor |
	jailor := MenuCapturingMorph new openInWorld.
	aBlock value.
	^ jailor menu.! !

!SimulateMouseTest methodsFor: 'tests' stamp: ''!
testSimulateRightClick
	
	| menu |
	morph := Smalltalk tools workspace open.
	menu := self menuOpenedDuring: [ morph simulateRightClick ].
	self assert: menu isNil not.! !

!SimulateMouseTest methodsFor: 'tests' stamp: ''!
testSimulateClick

	morph := TextMorph new contents: ''; openInWorld.	
	morph simulateClick.
	self assert: morph hasKeyboardFocus.! !

!SimulationExceptionWrapper commentStamp: ''!
Notify about an exception while simulating an execution!
!SimulationExceptionWrapper methodsFor: 'accessing' stamp: ''!
exception

	^ exception! !

!SimulationExceptionWrapper methodsFor: 'accessing' stamp: ''!
exception: anObject

	exception := anObject! !

!SimulationExceptionWrapper class methodsFor: 'signalling' stamp: ''!
signalForException: anError

	^ self new
		exception: anError! !

!SimulationMock commentStamp: ''!
I am used to test the behavior of Context>>jump in MethodContextTest. My example methods includes instance variable stores. When my instance is read-only or writeable, the example method uses or not the write barrier call-back. The copy of the context answered can be used to ensure the stack state is correct.
!
!SimulationMock methodsFor: 'examples' stamp: ''!
exampleStore
	<sampleInstance>
	"This is a pathological case where the method has no arguments, no temporaries, and the instance variable store is followed by the creation of a closure with no copied values."
	instVar1 := 1.
	instVar1 := 2.
	^ thisContext copy! !

!SimulationMock methodsFor: 'examples' stamp: ''!
exampleClosure
	<sampleInstance>
	"This is a pathological case where the method has no arguments, no temporaries, and the instance variable store is followed by the creation of a closure with no copied values."
	instVar1 := 1.
	[ 2 ] value.
	^ thisContext copy! !

!SimulationMock methodsFor: 'examples' stamp: ''!
exampleSelfReturnCall

	"A simple case where a yourself message is sent to an object"

	<sampleInstance>
	self yourself! !

!SimulationMock methodsFor: 'examples' stamp: ''!
exampleSend
	<sampleInstance>
	"This is a pathological case where the method has no arguments, no temporaries, and the instance variable store is followed by the creation of a closure with no copied values."
	instVar1 := 1.
	self yourself.
	^ thisContext copy! !

!SindarinCommand methodsFor: 'accessing' stamp: ''!
debuggerPresenter
	^self context! !

!SindarinCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == SindarinCommand! !

!SindarinCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName
	^self subclassResponsibility ! !

!SindarinCommand class methodsFor: 'instance creation' stamp: ''!
forSpecContext: anObject
	self flag: 'Why is this class needed besides this helper?'.
	^ (self forSpecWithIconNamed: self defaultIconName)
		context: anObject;
		yourself! !

!SindarinCommandsTest methodsFor: 'tests - step to instance creation' stamp: ''!
testNoNextInstanceCreationBeforeContextReturn

	| command |
	debugger := SindarinTestCommandDebugger new.
	debugger session: (StTestDebuggerProvider new debuggerWithContext:
			 [ object doNotAcceptVisitor: nil ] asContext) session.

	command := SindarinStepToNextInstanceCreation forContext: debugger.
	command maxDepth: 2.
	command execute.
	self
		assert: command errorString
		equals: command notFoundErrorString! !

!SindarinCommandsTest methodsFor: 'running' stamp: ''!
tearDown

	debugger ifNotNil: [ 
		debugger session ifNotNil: [ :s | s clear ].
		debugger session: nil.
		debugger := nil ].
	super tearDown! !

!SindarinCommandsTest methodsFor: 'tests - step to next call' stamp: ''!
testStepToNextCallInClassWithError

	| command |
	debugger := SindarinTestCommandDebugger new.
	debugger session: (StTestDebuggerProvider new debuggerWithContext:
			 [ visitor visitWithError: object ] asContext) session.

	debugger session stepIntoUntil: [ :currentContext | 
		currentContext method == (visitor class >> #visitWithError:) ].
	command := SindarinStepToNextCallInClassCommand forContext: debugger.
	self
		assert: debugger session context method
		identicalTo: visitor class >> #visitWithError:.
	command execute.
	self
		assert: debugger session context method selector
		equals: #doesNotUnderstand:! !

!SindarinCommandsTest methodsFor: 'tests - step to next call' stamp: ''!
testStepToNextCallInClassNeverFinishes

	| command |
	debugger := SindarinTestCommandDebugger new.
	debugger session: (StTestDebuggerProvider new debuggerWithContext:
			 [ visitor visitNeverFinish: object ] asContext) session.

	debugger session stepIntoUntil: [ :currentContext | 
		currentContext method == (visitor class >> #visitNeverFinish:) ].
	command := SindarinStepToNextCallInClassCommand forContext: debugger.
	self
		assert: debugger session context method
		identicalTo: visitor class >> #visitNeverFinish:.
	command execute.
	
	"We're stuck in a loop so the debugger interrupted..."
	self
		assert: debugger session context method selector
		equals: #timesRepeat:.
	self assert: debugger session context receiver equals: 10000! !

!SindarinCommandsTest methodsFor: 'tests - step to next call' stamp: ''!
testStepToNextCallInObject

	| command originalReceiver |
	debugger := SindarinTestCommandDebugger new.
	debugger session: 
	(StTestDebuggerProvider new debuggerWithContext:
		            [ visitor visitMultipleObjects: object ] asContext) session.

	debugger session stepIntoUntil: [ :currentContext | 
		currentContext method == (visitor class >> #visitMultipleObjects:) ].
	command := SindarinStepToNextCallInObjectCommand forContext: debugger.
	self
		assert: debugger session context method
		identicalTo: visitor class >> #visitMultipleObjects:.
	originalReceiver := debugger session context receiver.
	command execute.
	self
		assert: debugger session context method
		identicalTo: visitor class >> #visitTestObject:.
	self assert: debugger session context receiver identicalTo: originalReceiver! !

!SindarinCommandsTest methodsFor: 'tests - step to instance creation' stamp: ''!
testDebuggerOnNextInstanceCreation

	| command |
	debugger := SindarinTestCommandDebugger new.
	debugger session: (StTestDebuggerProvider new debuggerWithContext:
			 [ Object new ] asContext) session.

	command := SindarinStepToNextInstanceCreation forContext: debugger.
	command execute.
	self
		assert: debugger session context method
		identicalTo: (Object class lookupSelector: #new).
	self
		assert: debugger session context receiver
		identicalTo: Object! !

!SindarinCommandsTest methodsFor: 'tests - step to instance creation' stamp: ''!
testStepToNextInstanceCreation

	| command |
	debugger := SindarinTestCommandDebugger new.
	debugger session: (StTestDebuggerProvider new debuggerWithContext:
			 [ object createInstanceWithNew ] asContext) session.

	command := SindarinStepToNextInstanceCreation forContext: debugger.
	command execute.
	self
		assert: debugger session context method
		identicalTo: (object class class lookupSelector: #new).
	self assert: debugger session context receiver identicalTo: object class! !

!SindarinCommandsTest methodsFor: 'tests - step to next call' stamp: ''!
testStepToNextCallInClassFailure

	| command |
	debugger := SindarinTestCommandDebugger new.
	debugger session: 
	(StTestDebuggerProvider new debuggerWithContext:
		            [ visitor doNotVisit: object ] asContext) session.

	debugger session stepIntoUntil: [ :currentContext | 
		currentContext method == (visitor class >> #doNotVisit:) ].
	command := SindarinStepToNextCallInClassCommand forContext: debugger.
	self
		assert: debugger session context method
		identicalTo: visitor class >> #doNotVisit:.
	command execute.
	self
		assert: debugger session context method
		identicalTo: visitor class >> #doNotVisit:! !

!SindarinCommandsTest methodsFor: 'tests - step to next call' stamp: ''!
testStepToNextCallInClass

	| command |
	debugger := SindarinTestCommandDebugger new.
	debugger session: 
	(StTestDebuggerProvider new debuggerWithContext:
		            [ visitor visit: object ] asContext) session.

	debugger session stepIntoUntil: [ :currentContext | 
		currentContext method == (visitor class >> #visit:) ].
	command := SindarinStepToNextCallInClassCommand forContext: debugger.
	self
		assert: debugger session context method
		identicalTo: visitor class >> #visit:.
	command execute.
	self
		assert: debugger session context method
		identicalTo: visitor class >> #visitTestObject:! !

!SindarinCommandsTest methodsFor: 'tests - step to instance creation' stamp: ''!
testNoNextInstanceCreationAfterMaxSearchDepth

	| command |
	debugger := SindarinTestCommandDebugger new.
	debugger session: (StTestDebuggerProvider new debuggerWithContext:
			 [ object acceptVisitor: visitor ] asContext) session.
			
	debugger session stepIntoUntil: [ :currentContext | 
		currentContext method == (object class >> #acceptVisitor:) ].

	command := SindarinStepToNextInstanceCreation forContext: debugger.
	command execute.
	self
		assert: command errorString
		equals: command notFoundInCurrentContextString! !

!SindarinCommandsTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	visitor := SindarinTestVisitor new.
	object := SindarinTestObjectToVisit new! !

!SindarinCreateCommandFromScriptCommand commentStamp: ''!
Creates an anonymous command class with a debugging script. 
The created command class can be instantiated by the debugger as a custom debugging action.
The created command class has a pragma that identifies itself as a custom debugging action.!
!SindarinCreateCommandFromScriptCommand methodsFor: 'executing' stamp: ''!
execute
	self context createCommandFromScript! !

!SindarinCreateCommandFromScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^#smallAdd ! !

!SindarinCreateCommandFromScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^'Create a command from the current debugging script'! !

!SindarinCreateCommandFromScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^'Create new command from script'! !

!SindarinDebugSession commentStamp: ''!
stepRecord: StepRecord

StepRecords: LinkedList[StepRecord]!
!SindarinDebugSession methodsFor: 'debugging actions' stamp: ''!
stepOver: aContext
	"Should not step more a process that is terminating, otherwise the image will get locked."
	self flag: 'Why the image gets locked? Please investigate.'.
	
	self debugSession interruptedProcess isTerminating
		ifTrue: [ SteppingATerminatingProcess signal ].
	^ self debugSession stepOver: aContext! !

!SindarinDebugSession methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	triggerEventOn := true.
	canBeTerminated := true! !

!SindarinDebugSession methodsFor: 'initialization' stamp: ''!
refreshAttachedDebugger
	"The following lines are to force possible debuggers observing the same debug session to update themselves based"

	self debugSession triggerEvent: #contextChanged! !

!SindarinDebugSession methodsFor: 'debugging actions' stamp: ''!
resumeAndClear

	self debugSession
		resume;
		clear! !

!SindarinDebugSession methodsFor: 'accessing' stamp: ''!
debugSession: anObject

	debugSession := anObject! !

!SindarinDebugSession methodsFor: 'debugging actions' stamp: ''!
triggerEvent: anEventSelector

	triggerEventOn ifTrue: [ 
		^ self debugSession triggerEvent: anEventSelector ]! !

!SindarinDebugSession methodsFor: 'initialization' stamp: ''!
activateEventTriggering
	triggerEventOn := true.
	self flag: 'Why not refreshing?'.
	"self refreshAttachedDebugger."! !

!SindarinDebugSession methodsFor: 'initialization' stamp: ''!
deactivateEventTriggering

	triggerEventOn := false! !

!SindarinDebugSession methodsFor: 'accessing' stamp: ''!
debugSession

	^ debugSession! !

!SindarinDebugSession methodsFor: 'accessing' stamp: ''!
canBeTerminated: anObject

	canBeTerminated := anObject! !

!SindarinDebugSession methodsFor: 'accessing' stamp: ''!
canBeTerminated

	^ canBeTerminated! !

!SindarinDebugSession methodsFor: 'converting' stamp: ''!
asSindarinDebugSession

	^ self! !

!SindarinDebugSession methodsFor: 'debugging actions' stamp: ''!
stepInto: aContext
	"Should not step more a process that is terminating, otherwise the image will get locked."
	self flag: 'Why the image gets locked? Please investigate.'.

	self debugSession interruptedProcess isTerminating
		ifTrue: [ SteppingATerminatingProcess signal ].
	^ self debugSession stepInto: aContext! !

!SindarinDebugSession methodsFor: 'debugging actions' stamp: ''!
terminate

	canBeTerminated ifTrue: [ ^ self debugSession terminate ]! !

!SindarinDebugSession class methodsFor: 'instance creation' stamp: ''!
newWithName: aString forProcess: aProcess

	^ DebugSession new
		  name: aString;
		  process: aProcess context: aProcess suspendedContext;
		  asSindarinDebugSession! !

!SindarinDebugSessionMock commentStamp: ''!
I mock sindarin debug sessions to control it finely during tests!
!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
isMessage: anObject

	isMessage := anObject! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
context
	 ^self! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
method
	 ^self! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
selector
	^selector ! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
receiver
	 ^receiver! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
debugSession
	 ^self! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
selector: anObject

	selector := anObject! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
pc
	 ^self! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
sourceNodeExecuted
	 ^self! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
sourceNodeForPC: pc
	 ^self! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
receiver: anObject

	receiver := anObject! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
interruptedContext
	 ^self! !

!SindarinDebugSessionMock methodsFor: 'accessing' stamp: ''!
isMessage
	 ^isMessage ifNil:[false]! !

!SindarinDebugSessionTest methodsFor: 'tests' stamp: ''!
testSindarinSessionInstantiation

	| sessionName process |
	sessionName := 'TestSDS'.
	process := [  ] newProcess.
	sindarinSession := SindarinDebugSession
		                   newWithName: sessionName
		                   forProcess: process.
	self assert: sindarinSession debugSession notNil.
	self assert: sindarinSession debugSession name equals: sessionName.
	self
		assert: sindarinSession debugSession process
		identicalTo: process! !

!SindarinDebugSessionTest methodsFor: 'tests' stamp: ''!
testSindarinSessionAsSindarinDebugSession

	self
		assert: sindarinSession asSindarinDebugSession
		identicalTo: sindarinSession! !

!SindarinDebugSessionTest methodsFor: 'tests' stamp: ''!
testDebugSessionAsSindarinDebugSession

	self assert: sindarinSession debugSession identicalTo: debugSession! !

!SindarinDebugSessionTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
	
	super setUp.
	debugSession := DebugSession new.
	sindarinSession := debugSession asSindarinDebugSession! !

!SindarinDebugger commentStamp: ''!
# Start
Get a ScriptableDebugger instance by doing: `ScriptableDebugger debug: [ <your execution> ]`.
Alternatively, you can get a ScriptableDebugger instance attached on an already existing DebugSession by doing: `ScriptableDebugger attach: aDebugSession` 

# Breakpoints
ScriptableDebugger uses the VirtualBreakpoints class for its breakpoints. 
The breakpoints set by ScriptableDebugger are "virtual", in the sense that they do not modify any bytecode (as common breakpoints do) and do not show up in the rest of the IDE. They are simply markers indicating that the scritpable debugger should stop the debugged execution if it reaches an ast node or method on which a virtual breakpoint has been set. A virtual breakpoint set by a scriptable debugger instance is "visible" by all other scriptable debugger instances.

Virtual breakpoints were introduced because due to technical limitations, normal breakpoints cannot be set in methods that are already in the stack of the debugged execution.

# Instance Variables:
- process: the (suspended) Process in which the debugged execution takes place
- debugSession: the DebugSession monitoring the debugged execution.
- stepHooks: OrderedCollection<Block>. A list of blocks to be evaluated after each step of the debugged execution!
!SindarinDebugger methodsFor: 'private' stamp: ''!
isAboutToSignalException
	"OLD METHOD. SEE #hasSignalledUnhandledException"
	"Returns whether the debugged execution is about to signal an exception"
	^ (self node isMessage
		and: [ self messageSelector = #unhandledErrorDefaultAction:
				and: [ self messageReceiver isKindOf: UIManager ] ])! !

!SindarinDebugger methodsFor: 'stepping - steps' stamp: ''!
stepOver: anInt
	"Call the #stepOver method @anInt times"

	anInt timesRepeat: [ self stepOver ]! !

!SindarinDebugger methodsFor: 'execution predicates' stamp: ''!
isAboutToInstantiateClass

	| methodAboutToExecute |
	self node isMessage ifFalse: [ ^ false ].
	methodAboutToExecute := self receiver class lookupSelector:
		                        self node selector.
	^ methodAboutToExecute notNil and: [ 
		  self instanceCreationPrimitives includes:
			  methodAboutToExecute primitive ]! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
receiver
	"Returns the receiver of the current stack-frame."

	^ self context receiver! !

!SindarinDebugger methodsFor: 'start' stamp: ''!
debug: aBlock
	blockToDebug := aBlock.
	process := aBlock newProcess name: 'ExecutionDebuggedByScriptableDebugger'.
	sindarinSession := SindarinDebugSession
		newWithName: 'ScriptableDebuggerDebugSession'
		forProcess: process.
	sindarinSession deactivateEventTriggering.
	"Step the process until it enters the block for which a process was created"
	[ self context closure == blockToDebug ] whileFalse: [ self step ]! !

!SindarinDebugger methodsFor: 'accessing' stamp: ''!
debugSession
	"Returns the DebugSession representing the execution this ScriptableDebugger is debugging"

	^ sindarinSession debugSession! !

!SindarinDebugger methodsFor: 'stackAccess' stamp: ''!
stack
	"Returns a list of context objects representing the current call stack."

	^ self debugSession stack! !

!SindarinDebugger methodsFor: 'stepping -  auto' stamp: ''!
resume

	sindarinSession resumeAndClear! !

!SindarinDebugger methodsFor: 'stepping -  auto' stamp: ''!
proceed
	"alias of #continue"

	^ self continue! !

!SindarinDebugger methodsFor: 'stepping -  skip' stamp: ''!
skip
	"If it is a message send or assignment, skips the execution of the current instruction, and puts nil on the execution stack."

	self skipWith: nil! !

!SindarinDebugger methodsFor: 'stepping -  skip' stamp: ''!
skipToPC: aPC
	"Skips execution until program counter reaches aPC."
	[ self pc >= aPC ] whileFalse: [ self skip ]! !

!SindarinDebugger methodsFor: 'stepping - steps' stamp: ''!
stepThrough
	"Hacked for demonstration purposes to have a stepThrough"

	self signalExceptionIfDebuggedExecutionHasSignalledUnhandledException.
	self debugSession stepThrough.
	stepHooks do: [ :aBlock | aBlock value ]! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
temporaryNamed: aSymbol
	^self context tempNamed: aSymbol! !

!SindarinDebugger methodsFor: 'accessing' stamp: ''!
currentBytecode
	^ self context method symbolicBytecodes! !

!SindarinDebugger methodsFor: 'initialization' stamp: ''!
initialize
	stepHooks := OrderedCollection new! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
message: aSelector
	"Returns whether the execution is about to send a message of selector @aSelector to any object"

	| node |
	node := self node.
	node isMessage
		ifFalse: [ ^ false ].
	node selector = aSelector
		ifFalse: [ ^ false ].
	^ true! !

!SindarinDebugger methodsFor: 'graphical debugger' stamp: ''!
openInGraphicalDebugger
	sindarinSession canBeTerminated: false.	"Prevents the graphical debugger from terminating the debug session when it's closed."
	self
		flag:
			'Should be an extension of DebuggerSelector and handled by its sole instance'! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
arguments
	"Returns the arguments of the current stack-frame."

	^ self context arguments! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
selector
	"Returns the selector of the current stack-frame."

	^ self context selector! !

!SindarinDebugger methodsFor: 'breakpoints' stamp: ''!
setBreakpoint
	"Sets a breakpoint on the current node, returns an object reifying the breakpoint."

	^ self setBreakpointOn: self node! !

!SindarinDebugger methodsFor: 'private' stamp: ''!
signalExceptionIfDebuggedExecutionHasSignalledUnhandledException
	| unhandledException |
	(self hasSignalledUnhandledException)
		ifTrue: [ 
			unhandledException := self receiver.
			UnhandledExceptionSignalledByADebuggedExecution
				signalWithException: unhandledException.
		]
	
		"ifTrue:
			[" "The debugged execution signalled an exception, this exception was not handled and is about to cause a debugger to open."
			"Signalling an exception **in the scriptable debugger's process** to inform the user of this"
			"unhandledException := self messageArguments at: 1.
			UnhandledExceptionSignalledByADebuggedExecution
				signalWithException: unhandledException ]"! !

!SindarinDebugger methodsFor: 'private' stamp: ''!
instanceCreationPrimitives
	"* 70 */ primitiveNew,
	/* 71 */ primitiveNewWithArg,
	/* 79 */ primitiveNewMethod,
	/* 148 */ primitiveClone,
	/* 160 */ primitiveAdoptInstance"
	^#(70 71 79 148 160)! !

!SindarinDebugger methodsFor: 'private' stamp: ''!
hasSignalledUnhandledException
	"Returns true if the debugged execution has signalled an exception that has not been handled by any on:do: (i.e. the #defaultAction of the exception is about to be executed. This default action typically leads to opening a debugger on the process that signalled the exception)"
	^ (self selector = #defaultAction ) and: [ self receiver isKindOf: Exception ]! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
topStack
	^self context top! !

!SindarinDebugger methodsFor: 'graphical debugger' stamp: ''!
activateAutoRefreshOfAttachedGraphicalDebugger
	sindarinSession activateEventTriggering.
	self refreshAttachedGraphicalDebugger! !

!SindarinDebugger methodsFor: 'private' stamp: ''!
contextIsAboutToSignalException: aContext
	"Returns whether aContext is about to execute a message-send of selector #signal to an instance of the Exception class (or one of its subclasses)"

	| node |
	node := aContext method methodNode bcToASTCache nodeForPC: aContext pc.
	node isMessage
		ifFalse: [ ^ false ].
	node selector = #signal
		ifFalse: [ ^ false ].
	aContext basicSize >= 1
		ifFalse: [ ^ false ].
	(Exception allSubclasses includes: (aContext at: aContext basicSize))
		ifTrue: [ ^ true ].	"#signal sent to a subclass of Exception"
	(Exception allSubclasses
		includes: (aContext at: aContext basicSize) class)
		ifTrue: [ ^ true ].	"#signal sent to an instance of a subclass of Exception"
	^ false! !

!SindarinDebugger methodsFor: 'stepping - steps' stamp: ''!
stepBytecode
	"Executes the next bytecode"

	self flag: 'Needs to be tested'.
	self signalExceptionIfDebuggedExecutionHasSignalledUnhandledException.
	process completeStep: self debugSession context.
	self debugSession updateContextTo: process suspendedContext! !

!SindarinDebugger methodsFor: 'stackAccess' stamp: ''!
restart
	"Resets this debugger on a new execution of the block passed as argument to the initial call to #debug:"
	self initialize.
	self debug: blockToDebug.! !

!SindarinDebugger methodsFor: 'graphical debugger' stamp: ''!
refreshAttachedGraphicalDebugger
	sindarinSession refreshAttachedDebugger! !

!SindarinDebugger methodsFor: 'scripts' stamp: ''!
run: aSindarinScript
	aSindarinScript executeWith: self! !

!SindarinDebugger methodsFor: 'astAndAstMapping' stamp: ''!
nodeForContext: aContext
	"Returns the AST node about to be executed by the top context of the execution"

	^ aContext method sourceNodeForPC: aContext pc! !

!SindarinDebugger methodsFor: 'step hook' stamp: ''!
addStepHook: aBlock
	"Adds aBlock to the list of step hooks. Step hooks are executed after each step of the execution"

	stepHooks add: aBlock! !

!SindarinDebugger methodsFor: 'stackAccess' stamp: ''!
context
	"Returns a reification of the current stack-frame."

	^ self debugSession interruptedContext! !

!SindarinDebugger methodsFor: 'private' stamp: ''!
currentContextStackSize
	^ self context basicSize! !

!SindarinDebugger methodsFor: 'stepping -  skip' stamp: ''!
skipThroughNode: aProgramNode
	"Skips execution until program counter reaches aProgramNode.
	Also skip the target node."

	self skipUpToNode: aProgramNode skipTargetNode: true! !

!SindarinDebugger methodsFor: 'stepping - steps' stamp: ''!
step
	"Executes the next instruction. If the instruction is a message-send, step inside it."

	self signalExceptionIfDebuggedExecutionHasSignalledUnhandledException.
	self signalExceptionIfDebuggedExecutionIsFinished.
	self debugSession stepInto.
	stepHooks do: [ :aBlock | aBlock value ]! !

!SindarinDebugger methodsFor: 'stepping - steps' stamp: ''!
stepToReturn

	[ 
	self context willReturn or: [ self hasSignalledUnhandledException ] ] 
		whileFalse: [ self debugSession stepOver ]! !

!SindarinDebugger methodsFor: '*NewTools-Sindarin-Tools' stamp: ''!
debuggerExtensionKey
	^self class debuggerExtensionKey! !

!SindarinDebugger methodsFor: 'stepping -  skip' stamp: ''!
skipUpToNode: aProgramNode skipTargetNode: skipTargetNode
	"Skips execution until program counter reaches aProgramNode."

	[ self node == aProgramNode ] whileFalse: [ self skip ].
	aProgramNode isReturn	ifTrue: [ ^ self ].
	skipTargetNode ifTrue: [ self skip ]! !

!SindarinDebugger methodsFor: 'astAndAstMapping' stamp: ''!
node
	"Returns the AST node about to be executed by the top context of the execution"

	^ self context method sourceNodeForPC: self context pc! !

!SindarinDebugger methodsFor: 'stepping - echo' stamp: ''!
stepBatchAndReturnNodeHashAndStackSize
	"For EchoDebugger"
	| nodesHashAndStackSize count |
	count := 0.
	nodesHashAndStackSize := OrderedCollection new.
	[ [ count <= 1000] whileTrue: [ count := count + 1. nodesHashAndStackSize add: {self node dictionaryRepresentation hash. self stack size}. self step ]] on: DebuggedExecutionException do: [ "when debugged execution is over or signals exception, stop and return the result data" ^ nodesHashAndStackSize ].
	^ nodesHashAndStackSize
	! !

!SindarinDebugger methodsFor: '*NewTools-Sindarin-Tools' stamp: ''!
inspectionSindarinDebugger
	<inspectorPresentationOrder: -10 title: 'Sindarin'>

	^ StSindarinDebuggerPresenter on: self! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
message: aSelector to: anObject
	"Returns whether the execution is about to send a message of selector @aSelector to @anObject"

	| node |
	node := self node.
	node isMessage
		ifFalse: [ ^ false ].
	node selector = aSelector
		ifFalse: [ ^ false ].
	self messageReceiver == anObject
		ifFalse: [ ^ false ].
	^ true! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
messageSelector
	"Returns the selector of the message about to be sent, if the current node is a message node."

	self node isMessage
		ifFalse: [ Error signal: 'Not about to send a message' ].
	^ self node selector! !

!SindarinDebugger methodsFor: '*NewTools-Sindarin-Tools' stamp: ''!
open
	"Open this debugger and the execution it is debugging in a graphical window"
	"<inspectorPresentationOrder: -10 title: 'Sindarin'>"

	| a |
	a := (StSindarinDebuggerPresenter on: self) openWithSpec.
	a window extent: 550@350.! !

!SindarinDebugger methodsFor: 'stepping -  auto' stamp: ''!
continue
	"Steps the execution until it:
	- is about to signal a Halt exception. In this case return #halt.
	- is about to signal a Break exception. In this case return #breakpoint.
	- has reached a virtual breakpoint. In this case return the virtual breakpoint.
	- has finished. In this case return nil."

	| signalMessageNode exceptionClassBeingSignalled stepHook |
	self flag: 'Sorry, this is shit :)'.
	stepHook := [ VirtualBreakpoint all
		detect: [ :vbrkpt | vbrkpt hitTest: self node ]
		ifFound: [ :vbrkpt | 
			self removeStepHook: stepHook.
			^ vbrkpt ] ].
	self addStepHook: stepHook.
	[ self isExecutionFinished
		or: [ self contextIsAboutToSignalException: self context ] ]
		whileFalse: [ self step ].
	self isExecutionFinished
		ifTrue: [ ^ nil ].
	signalMessageNode := self node.
	exceptionClassBeingSignalled := self context
		at: self context size - signalMessageNode arguments size.
	exceptionClassBeingSignalled == Halt
		ifTrue: [ "Encountered a Halt (typically signalled by a 'self halt')"
			self skip.
			self removeStepHook: stepHook.
			^ #halt ].
	exceptionClassBeingSignalled == Break
		ifTrue: [ "Encountered a Break (i.e. a breakpoint)"
			self skip.
			self removeStepHook: stepHook.
			^ #breakpoint ]! !

!SindarinDebugger methodsFor: 'accessing' stamp: ''!
sindarinSession: aSindarinDebugSession

	sindarinSession := aSindarinDebugSession! !

!SindarinDebugger methodsFor: 'stepping -  skip' stamp: ''!
skipMessageNodeWith: replacementValue
	self node arguments do: [ :arg | self context pop ].	"Pop the arguments of the message send from the context's value stack"
	"Pop the receiver from the context's value stack"
	self context pop.
	"Push the replacement value on the context's value stack, to simulate that the message send happened and returned nil"
	self context push: replacementValue.
	"Increase the pc to go over the message send"
	self context pc: self context pc + 1.
	"Execute bytecodes the debugger usually executes without stopping the execution (for example popping the return value of the just executed message send if it is not used afterwards)"
	self debugSession
		stepToFirstInterestingBytecodeIn: self debugSession interruptedProcess! !

!SindarinDebugger methodsFor: 'astAndAstMapping' stamp: ''!
bestNodeFor: anInterval
	^self node methodNode bestNodeFor: anInterval! !

!SindarinDebugger methodsFor: 'graphical debugger' stamp: ''!
deactivateAutoRefreshOfAttachedGraphicalDebugger
	sindarinSession deactivateEventTriggering! !

!SindarinDebugger methodsFor: 'breakpoints' stamp: ''!
setBreakpointOn: target
	"Sets a breakpoint on target (a node or a compiled method), returns an object reifying the breakpoint."

	| astTarget |
	astTarget := target.
	(target isKindOf: CompiledMethod)
		ifTrue: [ astTarget := target ast ].
	^ VirtualBreakpoint newOnNode: astTarget setBy: self! !

!SindarinDebugger methodsFor: 'process' stamp: ''!
terminate
	sindarinSession terminate! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
method
	"Returns the method of the current stack-frame."

	^ self context method! !

!SindarinDebugger methodsFor: 'stepping -  skip' stamp: ''!
skipUpToNode: aProgramNode
	"Skips execution until program counter reaches aProgramNode.
	Does not skip the target node."

	self skipUpToNode: aProgramNode skipTargetNode: false! !

!SindarinDebugger methodsFor: 'step hook' stamp: ''!
removeStepHook: aBlock
	"Remove aBlock from the list of step hooks"

	stepHooks remove: aBlock! !

!SindarinDebugger methodsFor: 'process' stamp: ''!
currentProcess
	^process! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
message: aSelector toInstanceOf: aClass
	"Returns whether the execution is about to send a message of selector @aSelector to an instance of class @aClass"

	| node |
	node := self node.
	node isMessage
		ifFalse: [ ^ false ].
	node selector = aSelector
		ifFalse: [ ^ false ].
	(self messageReceiver isKindOf: aClass)
		ifFalse: [ ^ false ].
	^ true! !

!SindarinDebugger methodsFor: 'stepping - steps' stamp: ''!
stepToMethodEntry
	self stepUntil: [ self context willSend ].
	process step: self context.
	self debugSession updateContextTo: process suspendedContext! !

!SindarinDebugger methodsFor: 'stepping - steps' stamp: ''!
stepUntil: aBlock
	"Steps the execution until aBlock evaluates to true"

	aBlock whileFalse: [ self step ]! !

!SindarinDebugger methodsFor: 'stepping -  skip' stamp: ''!
skipWith: replacementValue
	"If it is a message-send or assignment, skips the execution of the current instruction, and puts the replacementValue on the execution stack."

	"If the current node is a message send or assignment"

	(self node isMessage not
		and: [ self node isAssignment not ])
		ifTrue: [ ^ self ].
	self node isMessage
		ifTrue: [ ^ self skipMessageNodeWith: replacementValue ].
	self node isAssignment
		ifTrue: [ ^	self skipAssignmentNodeWith: replacementValue ]! !

!SindarinDebugger methodsFor: 'accessing' stamp: ''!
pc
	^ self context pc! !

!SindarinDebugger methodsFor: 'stackAccess' stamp: ''!
isExecutionFinished
	"Returns whether the debugged execution is finished"

	^ process isTerminating! !

!SindarinDebugger methodsFor: 'stepping -  skip' stamp: ''!
skipAssignmentNodeWith: replacementValue
	self context pop.
	"Pop the value to be assigned"
	"Push the replacement value on the context's value stack, to simulate that the assignment happened and had value nil"
	self context push: replacementValue.
	"Increase the pc to go over the assignment"
	self context pc: self context pc + 2.
	"Execute bytecodes the debugger usually executes without stopping the execution (for example popping the return value of the just executed message send if it is not used afterwards)"
	self debugSession
		stepToFirstInterestingBytecodeIn: self debugSession interruptedProcess! !

!SindarinDebugger methodsFor: 'start' stamp: ''!
attachTo: aDebugSession
	"Attaches this scriptable debugger to an already existing instance of DebugSession or SindarinDebugSession"

	sindarinSession := aDebugSession asSindarinDebugSession.
	process := aDebugSession interruptedProcess.
	sindarinSession deactivateEventTriggering! !

!SindarinDebugger methodsFor: 'stepping - steps' stamp: ''!
step: anInt
	"Call the #step method @anInt times"

	anInt timesRepeat: [ self step ]! !

!SindarinDebugger methodsFor: 'private' stamp: ''!
signalExceptionIfDebuggedExecutionIsFinished
	"Signals an DebuggedExecutionIsFinished exception if the debugged execution is finished"
	(self isExecutionFinished) ifTrue: [ 
		DebuggedExecutionIsFinished signal.
	].! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
messageReceiver
	"Returns the receiver of the message about to be sent, if the current node is a message node."

	self node isMessage
		ifFalse: [ Error signal: 'Not about to send a message' ].
	^ self context
		at: self currentContextStackSize - self node arguments size! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
assignmentVariableName
	"Returns the variable name about to be assigned to, if the current node is an assignment node. Otherwise, returns nil"

	self node isAssignment
		ifFalse: [ ^ nil	"Error signal: 'Not about to perform a assignment'" ].
	^ self node variable name! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
messageArguments
	"Returns the arguments of the message about to be sent, if the current node is a message node."

	| argumentNumber arguments i |
	self node isMessage
		ifFalse: [ Error signal: 'Not about to send a message' ].
	argumentNumber := self node arguments size.
	arguments := OrderedCollection new.
	i := 0.
	[ i = argumentNumber ]
		whileFalse: [ arguments
				add:
					(self context
						at: self currentContextStackSize - argumentNumber + i + 1).
			i := i + 1 ].
	^ arguments! !

!SindarinDebugger methodsFor: 'stepping - steps' stamp: ''!
stepOver
	| startContext |
	startContext := self context.
	self step.
	[ self context == startContext
		or: [ (startContext isDead or: [ self context isDead ])
				or: [ startContext hasSender: self context ]]]
		whileFalse: [ self step ]! !

!SindarinDebugger methodsFor: 'stackAccessHelpers' stamp: ''!
assignmentValue
	"Returns the value about to be assigned, if the current node is an assignment node. Otherwise, returns nil"

	self node isAssignment
		ifFalse: [ ^ nil	"Error signal: 'Not about to perform a assignment'" ].
	^ self context at: self currentContextStackSize! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SindarinDebugger class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SindarinDebugger class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SindarinDebugger class methodsFor: 'instance creation' stamp: ''!
debugSession: aDebugSession

	| debugger exception sindarinPointCutExceptionClass |
	debugger := self attachTo: aDebugSession.
	
	exception := aDebugSession exception.
	sindarinPointCutExceptionClass := Smalltalk at: #SindarinPointcutException ifAbsent:[nil].
	exception class == sindarinPointCutExceptionClass ifFalse: [ 
		aDebugSession resume; clear.
		^ self ].
	
	"Stepping to return to the context requesting the execution of a Sindarin script"
	debugger step.
	debugger step.
	exception script executeWith: debugger.
	aDebugSession resume; clear; terminate
	! !

!SindarinDebugger class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SindarinDebugger class methodsFor: 'start' stamp: ''!
debug: aBlock
	"Creates an execution of aBlock and returns an instance of ScriptableDebugger attached to this execution"

	^ self new debug: aBlock! !

!SindarinDebugger class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SindarinDebugger class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SindarinDebugger class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SindarinDebugger class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SindarinDebugger class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SindarinDebugger class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SindarinDebugger class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SindarinDebugger class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SindarinDebugger class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
rank
	^rank ifNil:[rank := self defaultDebuggerRank]! !

!SindarinDebugger class methodsFor: '*NewTools-Sindarin-Tools' stamp: ''!
debuggerExtensionKey
	^ #sindarin! !

!SindarinDebugger class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SindarinDebugger class methodsFor: 'actions' stamp: ''!
closeAllDebuggers
	<script>
	
	self allInstances do: [ :dbg | dbg terminate ]! !

!SindarinDebugger class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SindarinDebugger class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
availableAutomatically: anObject
	availableAutomatically := anObject! !

!SindarinDebugger class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SindarinDebugger class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
defaultDebuggerRank

	^ DebuggerSettings defaultDebuggerRank! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SindarinDebugger class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
availableAutomatically
	^ availableAutomatically ifNil: [ 
		  availableAutomatically := DebuggerSettings defaultAvailability ]! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SindarinDebugger class methodsFor: 'debugging' stamp: ''!
handlesContext: aContext
	^true! !

!SindarinDebugger class methodsFor: 'start' stamp: ''!
attachTo: aDebugSession
	"Returns a new instance of ScriptableDebugger attached to aDebugSession"

	^ self new attachTo: aDebugSession! !

!SindarinDebugger class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SindarinDebugger class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SindarinDebugger class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SindarinDebugger class methodsFor: 'accessing' stamp: ''!
rank: anInteger
	rank := anInteger! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod11

	| a |
	a := 5.
	self helperMethod12.
	self helperMethod12.
	^ 3! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod24

	| p |
	p := Point new.
	p sign! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod3

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testContinue
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod19 ].
	scdbg
		step;
		step.
	self assert: scdbg node isMessage.
	self assert: scdbg node selector equals: #asInteger.
	scdbg setBreakpoint.
	scdbg := SindarinDebugger debug: [ self helperMethod19 ].
	scdbg continue.
	self assert: scdbg node isMessage.
	self assert: scdbg node selector equals: #asInteger! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testAddStepHook
	| stepCounter stepHook scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod11 ].
	stepCounter := 0.
	stepHook := [ stepCounter := stepCounter + 1 ].
	scdbg addStepHook: stepHook.
	scdbg step.
	self assert: stepCounter equals: 1.
	scdbg step; stepOver.
	self assert: stepCounter equals: 21.
	scdbg removeStepHook: stepHook.
	scdbg stepOver.
	self assert: stepCounter equals: 21! !

!SindarinDebuggerTest methodsFor: 'running' stamp: ''!
runCaseManaged
	^ self runCase! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod13

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod5

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testContext
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod15 ].
	self assert: scdbg context equals: scdbg debugSession interruptedContext.
	scdbg step.
	self assert: scdbg context equals: scdbg debugSession interruptedContext! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testIsExecutionFinished
	"Test shows that the debugger is actually not correctly working and therefore it is disabled.
	The fix requires the changes in #isExecutionFinished and on the Pharo side (PR#8567)
	Once integrated there will be another PR here. 
	Projects are managed in different repos and therfore such complex integration"
	| scdbg |
	self skipOnPharoCITestingEnvironment.
	scdbg := SindarinDebugger debug: [ self helperMethod16 ].
	self deny: scdbg isExecutionFinished.
	
	[ scdbg isExecutionFinished ] whileFalse: [ scdbg stepOver ].

	self assert: scdbg currentProcess isTerminated! !

!SindarinDebuggerTest methodsFor: 'tests - skipping' stamp: ''!
testSkipToPC
	| dbg realExecPC realValueOfA realExecNode realExecTopStack |
	self skipOnPharoCITestingEnvironment.
	dbg := SindarinDebugger
		debug: [ self helperMethod1  ].
	dbg step; stepOver; stepOver.
	realExecPC := dbg pc.
	realExecNode := dbg node.
	realValueOfA := (dbg temporaryNamed: #a).
	realExecTopStack := dbg topStack.

	dbg := SindarinDebugger
		debug: [ self helperMethod1  ].

	dbg step; stepOver; skipToPC: realExecPC. 
	self assert: dbg pc equals: realExecPC.
	self assert: dbg node equals: realExecNode.
	self assert: realValueOfA equals: 5.
	self assert: (dbg temporaryNamed: #a) equals: 1.
	self assert: dbg topStack equals: realExecTopStack! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod20

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testStepUntil
	| i scdbg |
	i := 20.
	scdbg := SindarinDebugger
		debug: [ [ i = 0 ] whileFalse: [ i := i - 1 ] ].
	scdbg stepUntil: [ i = 12 ].
	self assert: i equals: 12! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod23

	testObjectPoint sign.
	testObjectPoint extent: (Point x: 3 y: 4).
	Point new! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod18: anArg with: anotherArg

	Point x: 5 y: 7! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testSetBreakpoint
	self flag: 'What is this test?'.
	self testContinue! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethodReturn: bool

	| a |
	a := bool.
	a ifTrue: [ ^ 1 ].
	^ 2! !

!SindarinDebuggerTest methodsFor: 'tests - skipping' stamp: ''!
testSkipWith
	| a p scdbg |
	self skipOnPharoCITestingEnvironment.
	a := 1.
	scdbg := SindarinDebugger
		debug: [ a := 2.
			p := Point x: 2 y: 3 ].
	scdbg skipWith: 3.
	self assert: a equals: 1.
	scdbg skipWith: 5.
	scdbg step.
	self assert: p equals: 5! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testTerminate
	| dbg |
	dbg := SindarinDebugger debug: [ self helperMethod13 ].
	self assert: dbg debugSession interruptedContext notNil.
	self assert: dbg debugSession interruptedProcess notNil.
	dbg terminate.
	self assert: dbg debugSession interruptedContext isNil.
	self assert: dbg debugSession interruptedProcess isNil.! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod7

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod21

	self helperMethod22! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testMessageSelector
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod6 ].
	self assert: scdbg messageSelector equals: #helperMethod6.
	scdbg step; step.
	self assert: scdbg messageSelector equals: #asInteger.
	scdbg stepOver.
	self assert: scdbg messageSelector equals: #x:y:! !

!SindarinDebuggerTest methodsFor: 'running' stamp: ''!
tearDown

	VirtualBreakpoint all removeAll.
	breakpointsBeforeTest do: [ :breakPoint | VirtualBreakpoint all add: breakPoint ].
	super tearDown! !

!SindarinDebuggerTest methodsFor: 'tests - skipping' stamp: ''!
testSkip
	| a p scdbg |
	a := 1.
	scdbg := SindarinDebugger
		debug: [ a := 2.
			p := Point x: 2 y: 3 ].
	scdbg skip.
	self assert: a equals: 1.
	scdbg skip.
	scdbg step.
	self assert: p equals: nil! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod4

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod1

	| a |
	a := 1.
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testPc
	| dbg |
	dbg := SindarinDebugger
		debug: [ | a p |
			a := 2.
			p := Point x: 2 y: 3 ].
	dbg step; step; step.
	self assert: dbg pc equals: dbg context pc! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testStepOverReturnNode
	|scdbg|
	scdbg := SindarinDebugger debug: [ self helperMethod21 ].
	scdbg step; step.
	scdbg stepOver.
	self shouldnt: [scdbg stepOver] raise: SteppingATerminatingProcess.
	self assert: scdbg selector equals: #helperMethod21.
	self assert: scdbg node isMethod.
	self flag: 'Why is the following commented? Should it be tested somehow?'
"	self assert: scdbg node isBlock."! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testStep
	| node scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod13 ].
	scdbg step.
	node := scdbg node.
	self assert: node isAssignment.
	self assert: node variable name equals: #a.
	scdbg step.
	node := scdbg node.
	self assert: node isMessage.
	self assert: node selector equals: #asInteger! !

!SindarinDebuggerTest methodsFor: 'tests - skipping' stamp: ''!
testSkipUpToNode
	| dbg realExecPC realValueOfA realExecNode realExecTopStack |
	self skipOnPharoCITestingEnvironment.
	dbg := SindarinDebugger
		debug: [ self helperMethod1  ].
	dbg step; stepOver; stepOver.
	realExecPC := dbg pc.
	realExecNode := dbg node.
	realValueOfA := (dbg temporaryNamed: #a).
	realExecTopStack := dbg topStack.
	
	dbg := SindarinDebugger
		debug: [ self helperMethod1  ].
	
	dbg step; stepOver; skipUpToNode: realExecNode. 
	self assert: dbg pc equals: realExecPC.
	self assert: dbg node identicalTo: realExecNode.
	self assert: realValueOfA equals: 5.
	self assert: (dbg temporaryNamed: #a) equals: 1.
	self assert: dbg topStack equals: realExecTopStack! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testNode
	| node scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod1 ].
	node := scdbg node.
	self assert: node isMessage.
	self assert: node selector equals: #helperMethod1.
	scdbg step.
	node := scdbg node.
	self assert: node isAssignment.
	self assert: node variable name equals: #a.
	scdbg stepOver.
	scdbg stepOver.
	node := scdbg node.
	self assert: node isMessage.
	self assert: node selector equals: #asInteger! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testArguments
	| p scdbg |
	p := Point new.
	scdbg := SindarinDebugger debug: [ self helperMethod18: 1 with: p ].
	scdbg step.
	self assert: scdbg arguments size equals: 2.
	self assert: (scdbg arguments at: 1) equals: 1.
	self assert: (scdbg arguments at: 2) equals: p
	! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethodReturnWithHalt
	<haltOrBreakpointForTesting>

	| a |
	a := 0.
	self halt.
	^ a + 1! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testMessageToInstanceOf
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod24 ].
	scdbg step; stepOver: 2. "Step to <p sign> call"
	self assert: (scdbg message: #sign toInstanceOf: Point).
	self assert: (scdbg message: #sign toInstanceOf: Object).
	self deny: (scdbg message: #sign toInstanceOf: Rectangle).
	self deny: (scdbg message: #bogus toInstanceOf: Point)! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod6

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod19

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testReceiver
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod8 ].
	self assert: scdbg receiver equals: self.
	scdbg step.
	self assert: scdbg receiver equals: self.
	scdbg step; step.
	self assert: scdbg receiver equals: '3'! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testMessageReceiver
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod5 ].
	self assert: scdbg messageReceiver equals: self.
	scdbg step; step.
	self assert: scdbg messageReceiver equals: '3'! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod8

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'tests - step return' stamp: ''!
testStepToMethodEntry
	| dbg |
	self skipOnPharoCITestingEnvironment.
	dbg := SindarinDebugger debug: [ self helperMethodReturn: true ].
	dbg stepToMethodEntry.
		
	self assert: dbg pc equals: dbg method initialPC.
	self assert: dbg method identicalTo: (self class >> #helperMethodReturn:).	
	
	! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testTemporaryNamed
	| dbg |
	dbg := SindarinDebugger debug: [ self helperMethod10 ].
	dbg step.
	self assert: (dbg temporaryNamed: #a) equals: nil.
	dbg step.
	self assert: (dbg temporaryNamed: #a) equals: 5! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testStack
	| context1 context2 storeContextBlock scdbg |
	storeContextBlock := [ :thisCtx | context2 := thisCtx ].
	scdbg := SindarinDebugger
		debug: [ context1 := thisContext.
			self helperMethod17: storeContextBlock ].
	scdbg step.
	self assert: scdbg stack first equals: context1.
	scdbg
		step;
		stepOver.
	self assert: scdbg stack first equals: context2.
	self assert: (scdbg stack at: 2) equals: context1! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod9

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod16

	^ 1 + 1! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testOnceBreakpoint
	| breakpoint scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod19 ].
	scdbg step; step.
	self assert: scdbg node isMessage.
	self assert: scdbg node selector equals: #asInteger.
	breakpoint := scdbg setBreakpoint.
	breakpoint once.
	scdbg := SindarinDebugger debug: [ self helperMethod19 ].
	scdbg continue.
	scdbg := SindarinDebugger debug: [ self helperMethod19 ].
	scdbg continue.
	self assert: scdbg isExecutionFinished! !

!SindarinDebuggerTest methodsFor: 'tests - execution predicates' stamp: ''!
testIsAboutToInstantiateClass

	|debugger session|
	debugger := SindarinDebugger new.
	session := SindarinDebugSessionMock new.
	debugger sindarinSession: session.
	
	session isMessage: false.	
	self deny: debugger isAboutToInstantiateClass.
	
	session isMessage: true.
	session receiver: Object new.
	session selector: #yourself.
	self deny: debugger isAboutToInstantiateClass.
	
	session receiver: Object new.
	session selector: #toto.
	self deny: debugger isAboutToInstantiateClass.
	
	session receiver: Behavior new.
	session selector: #basicNew. "Primitive 70"
	self assert: debugger isAboutToInstantiateClass.
	
	session selector: #basicNew:. "Primitive 71"
	self assert: debugger isAboutToInstantiateClass.
	
	session selector: #adoptInstance:. "Primitive 160"
	self assert: debugger isAboutToInstantiateClass.
	
	session receiver: Object new.
	session selector: #clone. "Primitive 148"
	self assert: debugger isAboutToInstantiateClass.
		
	session receiver: CompiledCode.
	session selector: #newMethod:header:. "Primitive 79"
	self assert: debugger isAboutToInstantiateClass
	! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testStepOver
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod14 ].
	scdbg step. "Enters the call of helperMethod14. Current node should be: a:=5"
	scdbg stepOver. "After this, current node should be: '3' asInteger"
	scdbg stepOver. "After this, current node should be: Point x:5 y:'3' asInteger"
	self assert: scdbg node isMessage.
	self assert: scdbg node selector equals: #x:y:! !

!SindarinDebuggerTest methodsFor: 'tests - skipping' stamp: ''!
testskipUpToNodeSkipTargetNode
	"The tested method takes two params: 
		- the node up to which we want to skip execution
		- a boolean telling if we want to skip through the node or give back control to users before that node.
	Variations of these two params are tested by testSkipUpToNode and testSkipThroughNode.
	The following just test the remaining aspect of that API, that is we do not skip through a return node."
	| dbg returnNode |	
	self skipOnPharoCITestingEnvironment.
	dbg := SindarinDebugger
		debug: [ self helperMethod1  ].
		
	returnNode := (self class >> #helperMethod1) ast statements last.
	dbg step; skipThroughNode: returnNode.
	self assert: dbg node equals: returnNode.
	self assert: dbg topStack equals: nil! !

!SindarinDebuggerTest methodsFor: 'tests - skipping' stamp: ''!
testSkipThroughNode
	| dbg realExecPC realValueOfA targetExecNode realExecTopStack nodeAfterSkipThrough |
	self skipOnPharoCITestingEnvironment.
	dbg := SindarinDebugger
		debug: [ self helperMethod1  ].
	dbg step; stepOver; stepOver.	
	targetExecNode := dbg node.
	realValueOfA := (dbg temporaryNamed: #a).	
	dbg stepOver.
	nodeAfterSkipThrough := dbg node.
	realExecTopStack := dbg topStack.
	realExecPC := dbg pc.
	
	dbg := SindarinDebugger
		debug: [ self helperMethod1  ].
	
	dbg step; stepOver; skipThroughNode: targetExecNode.
		
	self assert: dbg pc equals: realExecPC.
	self assert: dbg node identicalTo: nodeAfterSkipThrough.
	self assert: realValueOfA equals: 5.
	self assert: (dbg temporaryNamed: #a) equals: 1.
	self assert: realExecTopStack equals: 3.
	self assert: dbg topStack equals: nil! !

!SindarinDebuggerTest methodsFor: 'tests - step return' stamp: ''!
testStepToReturnWithHalt
	| dbg |
	self skipOnPharoCITestingEnvironment.
	"First return node"
	dbg := SindarinDebugger debug: [ self helperMethodReturnWithHalt ].
	dbg stepToMethodEntry.
	dbg stepToReturn.
	
	self assert: dbg context willReturn.
	self assert: dbg node isReturn.
	self assert: dbg topStack equals: 1! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testWhenHitBreakpoint
	| breakpoint toggle scdbg |
	toggle := false.
	scdbg := SindarinDebugger debug: [ self helperMethod19 ].
	scdbg step; step.
	self assert: scdbg node isMessage.
	self assert: scdbg node selector equals: #asInteger.
	breakpoint := scdbg setBreakpoint.
	breakpoint whenHit: [ toggle := true ].
	scdbg := SindarinDebugger debug: [ self helperMethod19 ].
	scdbg continue.
	self assert: toggle! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod22

	^ Point new! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testMethod
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod7 ].	
	self assert: scdbg method equals: [ self helperMethod7 ] method.
	scdbg step.
	self assert: scdbg method equals: SindarinDebuggerTest>>#helperMethod7.
	scdbg step; step.
	self assert: scdbg method equals: String>>#asInteger! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod2

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'tests - step return' stamp: ''!
testStepToReturn
	| dbg |
	self skipOnPharoCITestingEnvironment.
	"First return node"
	dbg := SindarinDebugger debug: [ self helperMethodReturn: true ].
	dbg stepToMethodEntry.
	dbg stepToReturn.
	
	self assert: dbg node isReturn.
	self assert: dbg topStack equals: 1.
	
	"Second return node"
	dbg := SindarinDebugger debug: [ self helperMethodReturn: false ].
	dbg stepToMethodEntry.
	dbg stepToReturn.
	
	self assert: dbg node isReturn.
	self assert: dbg topStack equals: 2
	! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod17: storeContextBlock

	storeContextBlock value: thisContext.
	Point x: 5 y: 7! !

!SindarinDebuggerTest methodsFor: 'tests - step return' stamp: ''!
testStepToNonLocalReturn
	| dbg |
	self skipOnPharoCITestingEnvironment.	
	dbg := SindarinDebugger debug: [ self helperMethodNonLocalReturn ].
	dbg stepToMethodEntry.
	dbg stepToReturn.
	
	self assert: dbg node isReturn.
	self assert: dbg topStack equals: 42
	
	

	! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testAssignmentValue
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod2 ].
	scdbg step.
	self assert: scdbg assignmentValue equals: 5! !

!SindarinDebuggerTest methodsFor: 'tests - step return' stamp: ''!
testStepToReturnWithException
	| dbg |
	self skipOnPharoCITestingEnvironment.
	"First return node"
	dbg := SindarinDebugger debug: [ self helperMethodReturnWithException ].
	dbg stepToMethodEntry.
	dbg stepToReturn.
	
	self assert: dbg receiver class identicalTo: ZeroDivide.
	self assert: dbg method equals: (Exception >> #signal)! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testTopStack
	| a dbg |
	a := 1.
	dbg := SindarinDebugger debug: [ a := 2 ].
	dbg step.
	self assert: dbg topStack equals: 2! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testAssignmentVariableName
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod3 ].
	scdbg step.
	self assert: scdbg assignmentVariableName equals: #a! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod15

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
	
	super setUp.
	breakpointsBeforeTest := VirtualBreakpoint all.
	VirtualBreakpoint all removeAll.
	testObjectPoint := Point x: 1 y: 2.! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testRemoveBreakpoint
	| breakpoint scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod19 ].
	scdbg step; step.
	self assert: scdbg node isMessage.
	self assert: scdbg node selector equals: #asInteger.
	breakpoint := scdbg setBreakpoint.
	breakpoint remove.
	scdbg := SindarinDebugger debug: [ self helperMethod19 ].
	scdbg continue.
	self assert: scdbg isExecutionFinished! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod10

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'tests - step return' stamp: ''!
testStepToImplicitReturn
	| dbg |
	self skipOnPharoCITestingEnvironment.
	dbg := SindarinDebugger debug: [ self helperMethod23 ].
	dbg stepToMethodEntry.
	dbg stepToReturn.
	
	self assert: dbg node isMethod.
	dbg step.		
	self assert: dbg topStack equals: self.
	
	

	! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testContinueUntilTheEnd
	"Test the #continue method when no breakpoint/halt is set. It should step the execution until the end and NOT freeze the image"

	| scdbg semaphore |
	self flag: 'What is "setup code for the timeout?'.
	"VVV Setup code for the timeout"
	semaphore := Semaphore new.
	[ "^^^ Setup code for the timeout"
	scdbg := SindarinDebugger debug: [ self helperMethod20 ].
	scdbg continue.
	self assert: scdbg isExecutionFinished.

	"VVV Code for the timeout"
	semaphore signal ] fork.
	semaphore
		wait: 5 seconds
		onCompletion: [ 'success' ]
		onTimeout: [ "^^^ Setup code for the timeout" self assert: false description: 'Test timed out' ]! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testSelector
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod9 ].
	self assert: scdbg selector equals: #testSelector.
	scdbg step.
	self assert: scdbg selector equals: #helperMethod9.
	scdbg step; step.
	self assert: scdbg selector equals: #asInteger! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod14

	| a |
	a := 5.
	^ Point x: 5 y: '3' asInteger! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethod12

	| i |
	i := 5.
	[ i = 0 ] whileFalse: [ i := i - 1 ]! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethodReturnWithException

	| a |
	a := 0.
	1 / 0.
	^ a + 1! !

!SindarinDebuggerTest methodsFor: 'helpers' stamp: ''!
helperMethodNonLocalReturn
	| block |
	block := [ ^ 42 ].
	block value.
	^ 43! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testMessageArguments
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod4 ].
	scdbg step; step.
	self assert: scdbg messageArguments isEmpty.
	scdbg stepOver.
	self assert: (scdbg messageArguments at: 1) equals: 5.
	self assert: (scdbg messageArguments at: 2) equals: 3! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testSteppingAnExecutionSignalingExceptions
	| scdbg |
	scdbg := SindarinDebugger
		debug: [ 1 / 0.
			2 / 0.
			3 / 0 ].
	self
		should: [ scdbg
				stepOver;
				stepOver;
				stepOver ]
		raise: UnhandledExceptionSignalledByADebuggedExecution! !

!SindarinDebuggerTest methodsFor: 'tests' stamp: ''!
testMessageTo
	| scdbg |
	scdbg := SindarinDebugger debug: [ self helperMethod23 ].
	scdbg step.	"Step to <testObjectPoint sign.> call"
	self assert: (scdbg message: #sign to: testObjectPoint).
	scdbg
		stepOver;
		stepOver.	"Step to <testObjectPoint extent: ...> call"
	self assert: (scdbg message: #extent: to: testObjectPoint).
	
	"Should return false with wrong selector but correct receiver"
	self deny: (scdbg message: #bogus to: testObjectPoint).
	
	"Should return false with correct selector but wrong receiver"
	self deny: (scdbg message: #extent: to: Point new)	! !

!SindarinLoadScriptCommand commentStamp: ''!
Loads a debugging script that has been saved in a Sindarin script class.!
!SindarinLoadScriptCommand methodsFor: 'executing' stamp: ''!
execute
	self context loadScript! !

!SindarinLoadScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^#smallLoadProject! !

!SindarinLoadScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^'Load a debugging script'! !

!SindarinLoadScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^'Load script'! !

!SindarinRefreshCommand methodsFor: 'hooks' stamp: ''!
execute
	self context refresh! !

!SindarinRefreshCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^#refresh ! !

!SindarinRefreshCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Refresh the UI. Necessary after manual control of Sindarin.'! !

!SindarinRefreshCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'Refresh'! !

!SindarinRemoveCommandCommand commentStamp: ''!
Remove the command corresponding to a given script from the list of custom extension commands for the debugger.!
!SindarinRemoveCommandCommand methodsFor: 'executing' stamp: ''!
execute
	self context removeScriptCommand! !

!SindarinRemoveCommandCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^#smallCancel! !

!SindarinRemoveCommandCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^'Remove the command corresponding to the current debugging script'! !

!SindarinRemoveCommandCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^'Remove command'! !

!SindarinRunScriptCommand commentStamp: ''!
Run a given Sindarin script.
Behavior delegated to an instance of Sindarin debugger.!
!SindarinRunScriptCommand methodsFor: 'executing' stamp: ''!
execute
	self context executeScript! !

!SindarinRunScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^#smallDoIt! !

!SindarinRunScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^'Run the current debugging script'! !

!SindarinRunScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^'Run script'! !

!SindarinSaveScriptCommand commentStamp: ''!
Saves a given debugging script to a Sindarin script class.!
!SindarinSaveScriptCommand methodsFor: 'executing' stamp: ''!
execute
	self context saveScript! !

!SindarinSaveScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^#smallSave! !

!SindarinSaveScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^'Save the current debugging script'! !

!SindarinSaveScriptCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^'Save script'! !

!SindarinSkipAllToSelectionCommand class methodsFor: 'accesing - defaults' stamp: ''!
defaultIconName
	^ #glamorousRightSide! !

!SindarinSkipAllToSelectionCommand class methodsFor: 'accessing' stamp: ''!
debuggerExtensionGroup
	"Pragma to find the method. This method should build and return a customize command groups for the debugger"
! !

!SindarinSkipThroughSelectionCommand methodsFor: 'hooks' stamp: ''!
execute
	| targetNode |
	self
		flag: 'Context should actually be a debugger or a sindarin debugger'.
	self flag: 'Suspicious call to internal debugger UI state'.
	targetNode := self context sindarinDebugger
		bestNodeFor: self context code nonEmptySelectionInterval.
	self context sindarinDebugger skipThroughNode: targetNode.
	self context forceSessionUpdate! !

!SindarinSkipThroughSelectionCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Skips execution and stops after the selected instruction (or the instruction preceding the cursor), then returns debugger control.'! !

!SindarinSkipThroughSelectionCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	"<toolbarExtensionDebugCommand: 50>
	<codeExtensionDebugCommand: 50>"
	"^ 'Skip through instruction (will stop after)'"
	^ '[Exp.] Skip through (stop after)'! !

!SindarinSkipUpToSelectionCommand methodsFor: 'hooks' stamp: ''!
execute
	| targetNode |
	
	self flag: 'Context should actually be a debugger or a sindarin debugger'.
	self flag: 'Suspicious call to internal debugger UI state'.
	targetNode := self context sindarinDebugger
		bestNodeFor: self context code nonEmptySelectionInterval.
	self context sindarinDebugger skipUpToNode: targetNode.
	self context forceSessionUpdate! !

!SindarinSkipUpToSelectionCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Skips execution and stops before the selected instruction (or the instruction preceding the cursor), then returns debugger control.'! !

!SindarinSkipUpToSelectionCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	"<toolbarExtensionDebugCommand: 50>
	<codeExtensionDebugCommand: 50>"
	^ '[Exp.] Skip up to (stop before)'! !

!SindarinStepBytecodeCommand methodsFor: 'hooks' stamp: ''!
execute
	self context stepBytecode! !

!SindarinStepBytecodeCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^#glamorousInto ! !

!SindarinStepBytecodeCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Step a single bytecode'! !

!SindarinStepBytecodeCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'Step Bytecode'! !

!SindarinStepCommand methodsFor: 'hooks' stamp: ''!
execute
	self context model step.
	self context refresh.! !

!SindarinStepCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^#glamorousInto! !

!SindarinStepCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Step in'! !

!SindarinStepCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'Step'! !

!SindarinStepOverCommand methodsFor: 'hooks' stamp: ''!
execute
	self context model stepOver.
	self context refresh.! !

!SindarinStepOverCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^#glamorousOver! !

!SindarinStepOverCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Step over'! !

!SindarinStepOverCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	^ 'Step Over'! !

!SindarinStepToMethodEntryCommand methodsFor: 'executing' stamp: ''!
execute 	
	self flag: 'Not nice to always force update of debugger -> use observer?'.
	self context sindarinDebugger stepToMethodEntry.
	self context forceSessionUpdate! !

!SindarinStepToMethodEntryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^ #glamorousInto ! !

!SindarinStepToMethodEntryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Step to the beginning of the next method, then returns debugger control.'! !

!SindarinStepToMethodEntryCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	<toolbarExtensionDebugCommand: 50>
	<codeExtensionDebugCommand: 50>
	^ 'To method entry'! !

!SindarinStepToNextCallCommand methodsFor: 'hooks' stamp: ''!
execute

	| callingMethod maxDepth depth |
	self context removeSessionHolderSubscriptions.
	debugger := self context sindarinDebugger.
	self setConditionValue.
	callingMethod := debugger method.
	debugger step.

	maxDepth := 1000.
	depth := 0.
	[ 
	debugger method ~= callingMethod and: [ 
		depth < maxDepth and: [ self targetCondition ] ] ] 
		whileTrue: [ 
			debugger step.
			depth := depth + 1.
			debugger hasSignalledUnhandledException ifTrue: [ depth := 1000 ] ].

	self context
		setSessionHolderSubscriptions;
		forceSessionUpdate! !

!SindarinStepToNextCallCommand methodsFor: 'hooks' stamp: ''!
setConditionValue

	^ self subclassResponsibility! !

!SindarinStepToNextCallCommand methodsFor: 'hooks' stamp: ''!
targetCondition

	^ self subclassResponsibility! !

!SindarinStepToNextCallCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^ #glamorousInto! !

!SindarinStepToNextCallInClassCommand commentStamp: ''!
I will step the execution from a context until the next call to the same class as that context's receiver's class.!
!SindarinStepToNextCallInClassCommand methodsFor: 'predicates' stamp: ''!
setConditionValue

	conditionValue := debugger receiver class! !

!SindarinStepToNextCallInClassCommand methodsFor: 'predicates' stamp: ''!
targetCondition 
	^debugger receiver class ~= conditionValue! !

!SindarinStepToNextCallInClassCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Steps execution until the next call in the current class, then returns debugger control.'! !

!SindarinStepToNextCallInClassCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	<toolbarExtensionDebugCommand: 50>
	<codeExtensionDebugCommand: 50>
	^ 'Next call in class'! !

!SindarinStepToNextCallInObjectCommand commentStamp: ''!
I will step the execution from a context until the next call to the same object as that context's receiver.!
!SindarinStepToNextCallInObjectCommand methodsFor: 'predicates' stamp: ''!
setConditionValue

	conditionValue := debugger receiver! !

!SindarinStepToNextCallInObjectCommand methodsFor: 'predicates' stamp: ''!
targetCondition 
	^debugger receiver ~= conditionValue! !

!SindarinStepToNextCallInObjectCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Steps execution until the next call in the current receiver, then returns debugger control.'! !

!SindarinStepToNextCallInObjectCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	<toolbarExtensionDebugCommand: 50>
	<codeExtensionDebugCommand: 50>
	^ 'Next call in receiver'! !

!SindarinStepToNextInstanceCreation commentStamp: ''!
I will step the execution until a class is instantiated!
!SindarinStepToNextInstanceCreation methodsFor: 'accessing' stamp: ''!
notFoundInCurrentContextString

	^ 'No instance creation found in this context.'! !

!SindarinStepToNextInstanceCreation methodsFor: 'accessing' stamp: ''!
notFoundErrorString

	^ 'No instance creation found in 1000 debugger steps: try again to continue your search.'! !

!SindarinStepToNextInstanceCreation methodsFor: 'executing' stamp: ''!
execute

	| debugger sender depth |
	debugger := self debuggerPresenter sindarinDebugger.
	self debuggerPresenter removeSessionHolderSubscriptions.
	sender := debugger context sender.

	depth := 0.
	errorString := nil.
	debugger step.
	[ debugger isAboutToInstantiateClass or: [ errorString notNil ] ] 
		whileFalse: [ 
			debugger step.
			depth := depth + 1.
			depth = self maxDepth ifTrue: [ errorString := self notFoundErrorString ].
			debugger context == sender ifTrue: [ 
				errorString := self notFoundInCurrentContextString ].
			debugger hasSignalledUnhandledException ifTrue: [ 
				errorString := self errorDuringSearchString ] ].

	self debuggerPresenter
		setSessionHolderSubscriptions;
		forceSessionUpdate.

	errorString ifNotNil: [ 
		self debuggerPresenter
			warning: errorString
			for: self debuggerPresenter toolbar ]! !

!SindarinStepToNextInstanceCreation methodsFor: 'accessing' stamp: ''!
maxDepth

	^ maxDepth ifNil: [ maxDepth := self class defaultMaxDepth ]! !

!SindarinStepToNextInstanceCreation methodsFor: 'accessing' stamp: ''!
errorDuringSearchString

	^ 'Search interrupted due to exception.'! !

!SindarinStepToNextInstanceCreation methodsFor: 'accessing' stamp: ''!
errorString
	^errorString! !

!SindarinStepToNextInstanceCreation methodsFor: 'accessing' stamp: ''!
maxDepth: anObject

	maxDepth := anObject! !

!SindarinStepToNextInstanceCreation class methodsFor: 'accessing - defaults' stamp: ''!
defaultMaxDepth
	^1000! !

!SindarinStepToNextInstanceCreation class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^ #smallNew! !

!SindarinStepToNextInstanceCreation class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	<toolbarExtensionDebugCommand: 50>
	<codeExtensionDebugCommand: 50>
	^ 'Next instance creation'! !

!SindarinStepToReturnCommand methodsFor: 'executing' stamp: ''!
execute 	
	self flag: 'Not nice to always force update of debugger -> use observer?'.
	self context sindarinDebugger stepToReturn.
	self context forceSessionUpdate! !

!SindarinStepToReturnCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultIconName
	^ #glamorousRightSide! !

!SindarinStepToReturnCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription
	^ 'Steps execution until a new instance is created'! !

!SindarinStepToReturnCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName
	<toolbarExtensionDebugCommand: 50>
	<codeExtensionDebugCommand: 50>
	^ 'To return'! !

!SindarinTestCommandDebugger commentStamp: ''!
I am a fake debugger to allow the testing of Sindarin debugger commands without side effects on a StDebugger instance. !
!SindarinTestCommandDebugger methodsFor: 'removing' stamp: ''!
sindarinDebugger
	^ SindarinDebugger attachTo: session! !

!SindarinTestCommandDebugger methodsFor: 'gui' stamp: ''!
warning: aString for: aSindarinTestCommandDebugger

	^ self! !

!SindarinTestCommandDebugger methodsFor: 'accessing' stamp: ''!
session

	^ session! !

!SindarinTestCommandDebugger methodsFor: 'removing' stamp: ''!
toolbar

	^ self! !

!SindarinTestCommandDebugger methodsFor: 'removing' stamp: ''!
forceSessionUpdate 
	tag := #forceSessionUpdate! !

!SindarinTestCommandDebugger methodsFor: 'removing' stamp: ''!
setSessionHolderSubscriptions 
	tag := #setSessionHolderSubscriptions! !

!SindarinTestCommandDebugger methodsFor: 'accessing' stamp: ''!
session: anObject

	session := anObject! !

!SindarinTestCommandDebugger methodsFor: 'removing' stamp: ''!
removeSessionHolderSubscriptions 
	tag := #removeSessionHolderSubscriptions! !

!SindarinTestObjectToVisit commentStamp: ''!
I am a dumb object that accept visitors, to test Sindarin commands.!
!SindarinTestObjectToVisit methodsFor: 'visitors' stamp: ''!
acceptVisitorMultipleObjects: aVisitor

	self class new acceptVisitor: aVisitor.
	aVisitor visitTestObject: self! !

!SindarinTestObjectToVisit methodsFor: 'visitors' stamp: ''!
acceptVisitor: aVisitor

	aVisitor visitTestObject: self! !

!SindarinTestObjectToVisit methodsFor: 'instance creation' stamp: ''!
createInstanceWithNew
	^self class newInstantiation ! !

!SindarinTestObjectToVisit methodsFor: 'visitors' stamp: ''!
acceptVisitorNeverFinishes: aVisitor

	10000 timesRepeat: [ self doStuff ]! !

!SindarinTestObjectToVisit methodsFor: 'instance creation' stamp: ''!
createInstanceWithBasicNew
	^self class basicNewInstantiation ! !

!SindarinTestObjectToVisit methodsFor: 'visitors' stamp: ''!
doNotAcceptVisitor: aVisitor

	10 timesRepeat: [ self doStuff ]! !

!SindarinTestObjectToVisit methodsFor: 'visitors' stamp: ''!
doStuff

	^ self! !

!SindarinTestObjectToVisit methodsFor: 'visitors' stamp: ''!
acceptVisitorWithError: visitor

	visitor dnu
  ! !

!SindarinTestObjectToVisit class methodsFor: 'lessons' stamp: ''!
newInstantiation
	^self new! !

!SindarinTestObjectToVisit class methodsFor: 'lessons' stamp: ''!
basicNewInstantiation
	^self basicNew! !

!SindarinTestVisitor commentStamp: ''!
I am a dumb visitor for sindarin command tests!
!SindarinTestVisitor methodsFor: 'visiting' stamp: ''!
visitWithError: anObject
	anObject acceptVisitorWithError: self! !

!SindarinTestVisitor methodsFor: 'visiting' stamp: ''!
visitNeverFinish: anObject
	anObject acceptVisitorNeverFinishes: self! !

!SindarinTestVisitor methodsFor: 'visiting' stamp: ''!
visitMultipleObjects: anObject
	
	anObject acceptVisitorMultipleObjects: self! !

!SindarinTestVisitor methodsFor: 'visiting' stamp: ''!
visitTestObject: anObject

	^self! !

!SindarinTestVisitor methodsFor: 'visiting' stamp: ''!
doNotVisit: anObject
	anObject doNotAcceptVisitor: self! !

!SindarinTestVisitor methodsFor: 'visiting' stamp: ''!
visit: anObject
	anObject acceptVisitor: self! !

!SindarinUILessDebugger class methodsFor: 'debugger declaration' stamp: ''!
rankDebugSession: aDebugSession
	"Returns an integer representing how much this debugger is suitable to debug @aDebugSession. The higher the integer returned, the more suitable this debugger is. Signal the DebugSessionCannotBeOpenedByThisDebugger exception if this debugger absolutely cannot debug @aDebugSession (for example if this debugger can only handle debug sessions from test executions, and @aDebugSession does not come from a test execution)"
	
	^ 25! !

!SindarinUILessDebugger class methodsFor: 'debugger declaration' stamp: ''!
openOn: aDebugSession withFullView: aBool andNotification: aString
	"This method will be called to open this debugger on a given debug session (i.e. execution to debug). If this debugger wants to keep the debug session (and its process) alive (for example because it is a graphical debugger that would break if the debug session is terminated while its window is open), it should call #keepAlive: on @aDebugSession, passing itself as argument.
	The contract is that if a debugger calls #keepAlive:, it should also call #stopKeepingAlive: on @aDebugSession when it closes (passing itself as argument again).
	The debug session will automatically not be kept alive by this debugger anymore if this debugger gets garbage collected (and DebugSession will only hold a weak reference to this debugger, so it will not prevent its garbage collection)"
	aDebugSession keepAlive: self.
	Smalltalk tools inspector openOn: (SindarinDebugger attachTo: aDebugSession).
	"BAD: this debugger should call #stopKeepingAlive: on aDebugSession when it is close. Unfortunately, since it's just an inspector, I do not know how to make something happen when the inspector window closes"! !

!SingleCodeCriticResultList commentStamp: ''!
I am a browser for the SmallLint Critics of a rule.!
!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
rule: aRule

	rule := aRule.
	(rule isNil or: [ rule isComposite ]) 
		ifTrue: [ ^ self ].	
	self criticsOf:  aRule.
	toolbarModel rule: rule.! !

!SingleCodeCriticResultList methodsFor: 'smartSuggestions - support' stamp: ''!
selectedMessage
	^ nil! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
removeCriticToToDo

	criticsModel selectedItems
		ifNotNil: [:items | items do: [ :item |
			cache removeToDo: item forRule: rule ]].
	
	! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
setTextModelForNil

	| text |
	text := rule rationale isEmpty 
		ifTrue: [ rule name ]
		ifFalse: [ rule rationale ]. 
	sourceCodeModel aboutToStyle: false.
	sourceCodeModel text: text.
	sourceCodeModel behavior: nil.
	toolbarModel critic: nil 
	
	
					! !

!SingleCodeCriticResultList methodsFor: 'accessing' stamp: ''!
textInputFieldModel
	^ textInputFieldModel! !

!SingleCodeCriticResultList methodsFor: 'thread' stamp: ''!
updateList

	self criticsOf: rule.
	thread ifNotNil: [ thread terminate ].
	thread := [ UIManager default defer:  [ criticsModel updateList ]] fork.! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
initializeWidgets
	criticsModel := self newIconList.
	sourceCodeModel := self newCode.
	toolbarModel := self instantiate: CriticToolbar.
	textInputFieldModel := self newTextInput.

	criticsModel beMultipleSelection.
	self initializeTextInputFieldModel.
	self initializeToolBar.
	self initializeActionToPerformOnTextModel.
	criticsModel displayBlock: [:selec |
		self initializeDisplayCritic: selec forRule: rule]. 
	
	criticsModel menu: [ :a :b | self menu: a shifted: b ].
	criticsModel icons: [ :item | self iconFor: item ].
	
	self focusOrder
		add: criticsModel;
		add: toolbarModel;
		add: sourceCodeModel.
! !

!SingleCodeCriticResultList methodsFor: 'private' stamp: ''!
falsePositiveColor
	^ Color darkGray! !

!SingleCodeCriticResultList methodsFor: 'accessing' stamp: ''!
textModel
	^ sourceCodeModel! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
addMarkingMenuItemsTo: aMenu
	(criticsModel selectedItems anySatisfy: [ :critic | cache isFalsePositive: critic forRule: rule ]) 
		ifTrue: [ aMenu add: 'Unmark as wrong' target: self selector: #removeCriticToFalsePositive ].
	(criticsModel selectedItems anySatisfy: [ :critic | (cache isFalsePositive: critic forRule: rule) not ]) 
		ifTrue: [ aMenu add: 'Mark as wrong' target: self selector: #addCriticToFalsePositive ].
	(criticsModel selectedItems anySatisfy: [ :critic | cache isToDo: critic forRule: rule ]) 
		ifTrue: [ aMenu add: 'Unmark as TODO' target: self selector: #removeCriticToToDo ].
	(criticsModel selectedItems anySatisfy: [ :critic | (cache isToDo: critic forRule: rule) not ]) 
		ifTrue: [ aMenu add: 'Mark as TODO' target: self selector: #addCriticToToDo ].
	! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
browseCritic
	criticsModel selectedItem
		ifNotNil: [ :element |
			| entity |
			entity := element sourceAnchor entity.
			entity isBehavior 
				ifTrue: [ entity instanceSide browse ]
				ifFalse: [ entity browse ] ] ! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
browseDependencies
	criticsModel selectedItems ifNotNil: [ :packages |
		(DAPackageAnalyzerPackageDependenciesWindow onPackagesNamed: (packages collect: [:aPackage | aPackage packageName])) open ]! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
initializeActionToPerformOnTextModel
	
	| selectedItem |
	sourceCodeModel acceptBlock:  [ :text | 	
		selectedItem := criticsModel selectedItem sourceAnchor entity.
		(selectedItem isCompiledMethod and: [ rule isTransformationRule not ])
			ifTrue: [ selectedItem methodClass compile: text ] 
			ifFalse: [ Smalltalk compiler evaluate:  text ]]
	
! !

!SingleCodeCriticResultList methodsFor: 'private' stamp: ''!
criticsOf: aRule
	cache ifNil: [^ {}].
	criticsModel items: ((cache criticsOf: aRule)
				sorted: [ :a :b | 
					a printString < b printString ]).! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
removeRuleToFalsePositive

	criticsModel selectedItems ifNotNil: [ :criticss |
		criticss do: [ :critic |
			cache removeFalsePositiveRule: rule forPackage: critic sourceAnchor entity mcWorkingCopy]].! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
sendersOfCritic
	criticsModel selectedItem
		ifNotNil: [ :elem | 
			elem isBehavior
				ifTrue: [ self systemNavigation browseAllCallsOnClass: elem ]
				ifFalse: [ self systemNavigation browseAllSendersOf: elem selector ] ]! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
initializeTextInputFieldModel

	|critics|
	textInputFieldModel 
		autoAccept: true;
		ghostText: 'Search field';
		text: ' ';
		removeEntryCompletion.	
	textInputFieldModel acceptBlock: [ :text | |matchText|
		critics :=cache criticsOf: rule.
		matchText := '*', text, '*'.
		criticsModel items: (text isEmpty 
			ifTrue: [ critics ]
			ifFalse: [ critics select: [ :critic |
				matchText match: (self formatCritic: critic)]]).
		criticsModel updateList ]
! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
addCriticToFalsePositive
	
	criticsModel selectedItems
		ifNotNil: [ :items | items do: [ :item |
			cache
				addFalsePositive: item
				forRule: rule ]].
	
	! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
implementorsOfCritic
	criticsModel selectedItem ifNotNil: [ :item | item browse] 
! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
transformCritic
	
	criticsModel selectedItems ifNotNil: [ :items |
		items do: [:critic | critic change execute ]  displayingProgress: [:critic|]]! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
addNavigationMenuItemsTo: aMenu

	criticsModel selectedItem ifNotNil: [ :critique |
		critique sourceAnchor entity populateCBMenu: aMenu ]! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
setTextModelForTransformationRule: selection
	
	sourceCodeModel behavior: nil.
	sourceCodeModel text: (
		self diffTextForChange: selection change).
	sourceCodeModel aboutToStyle: false.

									
					! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self initializeShortcuts! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
initializeDisplayCritic: aCritic forRule: aRule
	
	| criticRepresentation | 
	criticRepresentation := (self formatCritic: aCritic) asMorph.
	^ (cache isFalsePositive: aCritic forRule: aRule) 
			ifTrue: [ criticRepresentation color: self falsePositiveColor ]
			ifFalse: [ (cache isToDo: aCritic forRule: aRule)
						ifTrue: [ criticRepresentation color: self toDoColor ]
						ifFalse: [ criticRepresentation color: self defaultColor ]]! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
addRuleToFalsePositive

	criticsModel selectedItems ifNotNil: [ :criticss |
		criticss do: [ :critic |
			cache addFalsePositiveRule: rule forPackage: critic mcWorkingCopy]].! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
setTextModelForClassOrMethod: aCritique

	| entity |
	entity := aCritique sourceAnchor entity.
	self flag:
		'Another hack. We need a better way to display entities (because now we may get not only classes and methods. Maybe something like GTInspector presentations could work)'.
	sourceCodeModel text: ((entity respondsTo: #definition)
			 ifTrue: [ entity definitionString ]
			 ifFalse: [ entity asString ]).
	sourceCodeModel aboutToStyle: true.
	sourceCodeModel behavior: (entity isCompiledMethod
			 ifTrue: [ entity methodClass ]
			 ifFalse: [ nil ]).
	aCritique sourceAnchor providesInterval ifTrue: [ 
		sourceCodeModel setSelection: aCritique sourceAnchor interval ]! !

!SingleCodeCriticResultList methodsFor: 'private' stamp: ''!
toDoColor
	^ Color orange! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
whenSelectedItemChangesOnListModel

	criticsModel whenSelectedItemChanged: [ :critique |
		sourceCodeModel setSelection: (0 to: 0). 	
		rule ifNotNil: [
			critique
				ifNil: [ self setTextModelForNil ]
				ifNotNil: [  
					toolbarModel critic: critique.
					critique providesChange 
					ifTrue: [ self setTextModelForTransformationRule: critique ]
					ifFalse: [ self setTextModelForClassOrMethod: critique ] ] ] ]		! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
removeCriticToFalsePositive
	
	criticsModel selectedItems
		ifNotNil: [ :items | items do: [ :item |
			cache removeFalsePositive: item forRule: rule ]].
	! !

!SingleCodeCriticResultList methodsFor: 'api' stamp: ''!
resetSelection
	self criticsModel resetSelection! !

!SingleCodeCriticResultList methodsFor: 'accessing' stamp: ''!
toolbarModel
	^ toolbarModel! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
addCriticToToDo

	criticsModel selectedItems
		ifNotNil: [ :items | items do: [ :item |
			cache
				addToDo: item
				forRule: rule ]].
		
! !

!SingleCodeCriticResultList methodsFor: 'private' stamp: ''!
criticsModelContains: aCritic

	^ criticsModel listItems anySatisfy: [ :each |
			 each sourceAnchor entity name = aCritic name]! !

!SingleCodeCriticResultList methodsFor: 'menu' stamp: ''!
menu: aMenu shifted: aBoolean
	(rule notNil and: [ criticsModel selectedItems notEmpty ])
		ifFalse: [ ^ aMenu ]. 
		
	self addNavigationMenuItemsTo: aMenu.
	aMenu addLine.
	self addMarkingMenuItemsTo: aMenu.
			
	criticsModel selectedItem
		ifNotNil: [ :critique |
		critique actions ifNotEmpty: [ :actions |
			aMenu addLine.
			actions do: [ :action |
				aMenu
					add: action description
					target: action
					selector: #actOnCritic:ofEntity:
					argumentList: {
						critique .
						critique sourceAnchor entity } ] ] ].
			
	^ aMenu! !

!SingleCodeCriticResultList methodsFor: 'private' stamp: ''!
selectionIntervalFor: aString
	^ rule result selectionIntervalFor: aString! !

!SingleCodeCriticResultList methodsFor: 'accessing' stamp: ''!
criticsModel
	^ criticsModel! !

!SingleCodeCriticResultList methodsFor: 'private' stamp: ''!
formatCritic: aCritic
	
	^  String streamContents: [:s | aCritic sourceAnchor entity criticNameOn: s ]
! !

!SingleCodeCriticResultList methodsFor: 'accessing' stamp: ''!
rule
	^ rule! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
initializeToolBar
	
	self toolbarModel whenFalsePositiveClickedDo: [ self addCriticToFalsePositive ].

! !

!SingleCodeCriticResultList methodsFor: 'accessing' stamp: ''!
cache:  acache 
	cache := acache! !

!SingleCodeCriticResultList methodsFor: 'private' stamp: ''!
defaultColor
	^ Color red! !

!SingleCodeCriticResultList methodsFor: 'private' stamp: ''!
diffSeparator

	^ '——————————————————
	
'! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
initializeShortcuts
	criticsModel bindKeyCombination: PharoShortcuts current browseShortcut toAction: [ self browseCritic ]! !

!SingleCodeCriticResultList methodsFor: 'private' stamp: ''!
diffTextForChange: aRefactoryChange
	| text builder |

	text := Text new.
	builder := PrettyTextDiffBuilder new.
	aRefactoryChange changes
		do: [ :chng |
			builder
				from: chng oldVersionTextToDisplay
				to: chng textToDisplay.
			text append: builder buildDisplayPatch ]
		separatedBy: [ text append: self diffSeparator ].
	
	^ text! !

!SingleCodeCriticResultList methodsFor: 'private' stamp: ''!
iconFor: anItem
	
	^  (cache isFalsePositive: anItem forRule: rule) 
			ifFalse: [(cache isToDo: anItem forRule: rule)
				ifTrue: [ self class wrenchOrangeIcon ]
				ifFalse: [ self class exclamationIcon ] ]! !

!SingleCodeCriticResultList methodsFor: 'initialization' stamp: ''!
initializePresenter

	self whenSelectedItemChangesOnListModel.
	

! !

!SingleCodeCriticResultList class methodsFor: 'class initialization' stamp: ''!
initialize
	
	icons := IdentityDictionary new! !

!SingleCodeCriticResultList class methodsFor: 'icons' stamp: ''!
exclamationIconContents
	"Private - Method generated"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAAK/INwWK6QAAABl0
RVh0U29mdHdhcmUAQWRvYmUgSW1hZ2VSZWFkeXHJZTwAAAJPSURBVDjLpZPLS5RhFMYfv9QJ
lelTQZwRb2OKlKuINuHGLlBEBEOLxAu46oL0F0QQFdWizUCrWnjBaDHgThCMoiKkhUONTqmj
mDp2GZ0UnWbmfc/ztrC+GbM2dXbv4ZzfeQ7vefKMMfifyP89IbevNNCYdkN2kawkCZKfSPZT
OGTf6Y/m1uflKlC3LvsNTWArr9BT2LAf+W73dn5jHclIBFZyfYWU3or7T4K7AJmbl/yG7EtX
1BQXNTVCYgtgbAEAYHlqYHlrsTEVQWr63RZFuqsfDAcdQPrGRR/JF5nKGm9xUxMyr0YBAEXX
HgIANq/3ADQobD2J9fAkNiMTMSFb9z8ambMAQER3JC1XttkYGGZXoyZEGyTHRuBuPgBTUu7V
SnUAgAUAWutOV2MjZGkehgYUA6O5A0AlkAyRnotiX3MLlFKduYCqAtuGXpyH0XQmOj+TIURt
51OzURTYZdBKV2UBSsOIcRp/TVTT4ewK6idECAihtUKOArWcjq/B8tQ6UkUR31+OYXP4sTOd
isivrkMyHodWejlXwcC38Fvs8dY5xaIId89VlJy7ACpCNCFCuOp8+BJ6A631gANQSg1mVmOx
xGQYRW2nHMha4B5WA3chsv22T5/B13AIicWZmNZ6cMchTXUe81Okzz54pLi0uQWp+TmkZqMw
xsBV74Or3od4OISPr0e3SHa3PX0f3HXKofNH/UIG9pZ5PeUth+CyS2EMkEqs4fPEOBJLsysk
e48/+xD8oxcAYPzs4QaS7RR2kbLTTOTQieczfzfTv8QPldGvTGoF6/8AAAAASUVORK5CYII='! !

!SingleCodeCriticResultList class methodsFor: 'icons' stamp: ''!
exclamationIcon 

	^  icons
			at: #'exclamationIcon'
			ifAbsentPut:[ Form fromBinaryStream: self exclamationIconContents base64Decoded readStream ].
! !

!SingleCodeCriticResultList class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ SpecLayout composed
		newColumn: [:c |
			c 
				add: #criticsModel;
				add: #toolbarModel height: 25;
				addSplitter;
				add: #textModel ]! !

!SingleCodeCriticResultList class methodsFor: 'icons' stamp: ''!
wrenchOrangeIcon

	^  icons
			at: #'wrenchOrangeIcon'
			ifAbsentPut:[ Form fromBinaryStream: self wrenchOrangeIconContents base64Decoded readStream ].
! !

!SingleCodeCriticResultList class methodsFor: 'specs' stamp: ''!
title

	^ 'Critic Browser'! !

!SingleCodeCriticResultList class methodsFor: 'icons' stamp: ''!
wrenchOrangeIconContents
	"Private - Method generated"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAAK/INwWK6QAAABl0
RVh0U29mdHdhcmUAQWRvYmUgSW1hZ2VSZWFkeXHJZTwAAAHaSURBVDjLlZO7a1NRHMfzfzhI
KQ5OHR1ddRRBLA6lg4iTd5PSas37YR56Y2JiHgg21uoFxSatCVFjbl5iNBBiMmUJgWwZhCB4
pR9/V4QKfSQdDufF5/v7nu85xwJYprV0Oq0kk8luIpEw4vG48f/eVDiVSikCTobDIePxmGg0
yokEBO4OBgNGoxH5fJ5wOHwygVgsZpjVW60WqqqWzbVgMIjf78fn8xlTBcTy736/T7VaJRQK
fQoEArqmafR6Pdxu9/ECkUjkglje63Q6NBoNisUihUKBcrlMpVLB6XR2D4df3VQnmRstsWzU
63WazSZmX6vV0HWdUqmEw+GY2Gw25SC8dV1l1wrZNX5s3qLdbpPL5fB6vXumZalq2O32rtVq
VQ6GuGnCd+HbFnx9AZrC+MkSHo/np8vlmj/M7f4ks6yysyawgB8fwPv70HgKG8v8cp/7fFRO
/+AllewqNJ/DhyBsi9A7J1QTkF4E69mXRws8u6ayvSJwRqoG4K2Md+ygxyF5FdbPaMfdlIXU
ZfiyAUWx/OY25O4JHBP4CtyZ16a9EwuRi1CXs+5K1ew6lB9DXERX517P8tEsPDzfNIP6C5Ye
QewSrJyeCd4P0bnwXYISy3MCn5oZNtsf3pH46e7XBJcAAAAASUVORK5CYII='! !

!SingleTreeTest commentStamp: ''!
SUnit tests for a single file system tree (depth one)!
!SingleTreeTest methodsFor: 'running' stamp: ''!
createFile: aString 
	filesystem store createFile: (filesystem pathFromString: aString)! !

!SingleTreeTest methodsFor: 'running' stamp: ''!
createDirectory: aString 
	filesystem createDirectory: (filesystem pathFromString: aString)! !

!SingleTreeTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	filesystem := FileSystem memory! !

!SingleTreeTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #SingleTreeTest! !

!SizeInMemoryTest commentStamp: ''!
SUnit tests for the size of objects in memory!
!SizeInMemoryTest methodsFor: 'tests' stamp: ''!
testSizeInMemoryLargeInstances
	"64 bits for the object header + a world per instance variable"

	self
		assert: Smalltalk allClasses sizeInMemory equals: (self align64Bits: self headerSize + (3 * Smalltalk wordSize));
		assert: Smalltalk allClasses asArray sizeInMemory
			equals: (self align64Bits: self headerSize + (Smalltalk allClasses asArray size * Smalltalk wordSize) + self headerSize)! !

!SizeInMemoryTest methodsFor: 'tests' stamp: ''!
testSizeInMemoryOfCharacters
	self assert: 0 asCharacter sizeInMemory isZero.
	self assert: 255 asCharacter sizeInMemory isZero.
	self assert: 256 asCharacter sizeInMemory isZero.
	self assert: 16r10FFFF asCharacter sizeInMemory isZero! !

!SizeInMemoryTest methodsFor: 'tests' stamp: ''!
testSizeInMemoryCompactClasses
	self skip.
	"One word for the header + one word per instance variable"
	self assert: (Association key: 'aKey' value: 23) sizeInMemory equals: 12.

	"One word for the header + one word per instance variable"
	self assert: Rectangle new sizeInMemory equals: 12! !

!SizeInMemoryTest methodsFor: 'tests' stamp: ''!
testSizeInMemoryNormalClasses
	"Two word for the header + one word per instance variable"

	self assert: Date today sizeInMemory equals: (self align64Bits: 2 * Smalltalk wordSize + self headerSize).

	"Two word for the header + one word per instance variable"
	self assert: TestCase new sizeInMemory equals: (self align64Bits: 2 * Smalltalk wordSize + self headerSize)! !

!SizeInMemoryTest methodsFor: 'tests' stamp: ''!
testSizeInMemoryOfByteObjects
	"Byte objects should be padded to words"
	self assert: 'a' sizeInMemory equals: (self paddedByteStringSize: 1).
	self assert: 'abcd' sizeInMemory equals: (self paddedByteStringSize: 4).
	self assert: '' sizeInMemory equals: (self paddedByteStringSize: 0).
	self assert: 'abcde' sizeInMemory equals: (self paddedByteStringSize: 5).
	self assert: 'abcdefghi' sizeInMemory equals: (self paddedByteStringSize: 9).! !

!SizeInMemoryTest methodsFor: 'tests' stamp: ''!
testSizeInMemorySmallIntegers
	self assert: SmallInteger minVal sizeInMemory isZero.
	self assert: 0 sizeInMemory isZero.
	self assert: SmallInteger maxVal sizeInMemory isZero.
	self assert: (SmallInteger minVal - 1) sizeInMemory > 0.
	self assert: (SmallInteger maxVal + 1) sizeInMemory > 0! !

!SizeInMemoryTest methodsFor: 'utilities' stamp: ''!
headerSize
	" The header is 64 bits"
	^ 8! !

!SizeInMemoryTest methodsFor: 'utilities' stamp: ''!
align64Bits: size
	size % 8 = 0
		ifTrue: [ ^ size ]
		ifFalse:[ ^ size + 8 - (size % 8) ].! !

!SizeInMemoryTest methodsFor: 'utilities' stamp: ''!
paddedByteStringSize: numberOfChars 
	"64 bits for the header"
	| originalSize  |
	originalSize := self headerSize + (numberOfChars = 0 ifTrue:[1] ifFalse:[numberOfChars]).
		
	^ self align64Bits: originalSize.! !

!SizeMismatch commentStamp: ''!
I am SizeMismatch, an exception indicating that an operation was attempted
on two or more collections that don't match in size. !
!SizeMismatch methodsFor: 'printing' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ 'Collections sizes do not match'! !

!SizeMismatch methodsFor: 'accessing' stamp: ''!
messageText
	"Overwritten to initialiaze the message text to a standard text if it has not yet been set"
	
	^ messageText ifNil: [ messageText := self standardMessageText ]! !

!SliderInput commentStamp: ''!
I am an elementary Spec Widget managing a slider and an input.

Self example

Between the bounds min and max of the slider, I ensure that the value of the input on the accept and the value of the slider are the same.

Note
====
- min and max must be set before use me.
- if autoAccept is true, the character '-' could create problems!
!SliderInput methodsFor: 'accessing' stamp: ''!
max: aNumber
	slider max: aNumber! !

!SliderInput methodsFor: 'accessing' stamp: ''!
value: aNumber
	slider value: aNumber ! !

!SliderInput methodsFor: 'accessing' stamp: ''!
input
	^ input! !

!SliderInput methodsFor: 'accessing' stamp: ''!
label: aString
	slider label: aString! !

!SliderInput methodsFor: 'initialization' stamp: ''!
initializeWidgets
	slider := self instantiate: SliderPresenter.
	input := self instantiate: TextInputFieldPresenter.
	self focusOrder add: input! !

!SliderInput methodsFor: 'api - events' stamp: ''!
whenValueChangedDo: aBlock
	slider whenValueChangedDo: aBlock! !

!SliderInput methodsFor: 'accessing' stamp: ''!
slider
	^ slider! !

!SliderInput methodsFor: 'accessing' stamp: ''!
min: aNumber
	slider min: aNumber.
	input text: aNumber asString ! !

!SliderInput methodsFor: 'accessing' stamp: ''!
value
	^ slider value! !

!SliderInput methodsFor: 'accessing' stamp: ''!
autoAccept
	^ input autoAccept! !

!SliderInput methodsFor: 'accessing' stamp: ''!
autoAccept: aBoolean
	
	input autoAccept: aBoolean! !

!SliderInput methodsFor: 'accessing' stamp: ''!
label
	^ slider label! !

!SliderInput methodsFor: 'initialization' stamp: ''!
initializePresenter
	slider
		whenValueChangedDo: [ :sliderValue | 
			| inputValue |
			inputValue := input text
				ifEmpty: [ 0 ]
				ifNotEmpty: [ :text | text asNumber ].
			sliderValue == inputValue
				ifFalse: [ input text: sliderValue asFloat asString ] ].
	input
		whenTextChanged: [ :text | 
			| inputValue |
			inputValue := text asNumber.
			slider value == inputValue
				ifFalse: [ slider value: inputValue ] ]! !

!SliderInput class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self new
		min: 0;
		max: 250;
		autoAccept: true;
		value: 120;
		extent: 400 @ 50;
		title: 'SliderInput example';
		openWithSpec.
	^ example! !

!SliderInput class methodsFor: 'specs' stamp: ''!
sliderLeft
	<spec: #default>
	^ SpecLayout composed
		newRow: [ :row | 
			row
				add: #slider origin: 0 @ 0 corner: 0.85 @ 1;
				add: #input origin: 0.85 @ 0 corner: 1 @ 1 ];
		yourself! !

!SliderInput class methodsFor: 'specs' stamp: ''!
sliderTop
	<spec>
	^ SpecLayout composed
		newColumn: [ :column | 
			column
				add: #slider origin: 0 @ 0 corner: 1 @ 0.85;
				add: #input origin: 0 @ 0.85 corner: 1 @ 1 ];
		yourself! !

!SliderInput class methodsFor: 'specs' stamp: ''!
sliderBottom
	<spec>
	^ SpecLayout composed
		newColumn: [ :column | 
			column
				add: #input origin: 0 @ 0 corner: 1 @ 0.15;
				add: #slider origin: 0 @ 0.15 corner: 1 @ 1 ];
		yourself! !

!SliderInput class methodsFor: 'specs' stamp: ''!
sliderRight
	<spec>
	^ SpecLayout composed
		newRow: [ :row | 
			row
				add: #input origin: 0 @ 0 corner: 0.15 @ 1;
				add: #slider origin: 0.15 @ 0 corner: 1 @ 1 ];
		yourself! !

!SliderMorph methodsFor: 'model access' stamp: ''!
value: newValue
	"Drive the slider position externally..."
	value := newValue min: 1.0 max: 0.0.
	self computeSlider! !

!SliderMorph methodsFor: 'geometry' stamp: ''!
totalSliderArea
	^ self innerBounds! !

!SliderMorph methodsFor: 'event testing' stamp: ''!
simulateSliderMouseUp
	"Simulate mouse button up with the left button (red button for left, blue for middle, yellow for right) into the Slider"

	slider simulateMouseUpWith: MouseEvent redButton! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
sliderShadowColor
	^ self sliderColor alphaMixed: 0.2 with: self pagingArea color! !

!SliderMorph methodsFor: 'geometry' stamp: ''!
roomToMove
	^ self totalSliderArea insetBy: (0@0 extent: self sliderExtent)! !

!SliderMorph methodsFor: 'event testing' stamp: ''!
simulateSliderMouseDown
	"Simulate mouse button down with the left button (red button for left, blue for middle, yellow for right) into the Slider"

	slider simulateMouseDownWith: MouseEvent redButton! !

!SliderMorph methodsFor: 'initialization' stamp: ''!
setSlider: aMorph withShadow: anotherMorph
	

	slider ifNotNil: [ self removeMorph: slider ].
	sliderShadow ifNotNil: [ self pagingArea removeMorph: sliderShadow ].

	slider := aMorph.
	sliderShadow := anotherMorph.
	slider on: #mouseMove send: #scrollAbsolute: to: self.
	slider on: #mouseDown send: #mouseDownInSlider: to: self.
	slider on: #mouseUp send: #mouseUpInSlider: to: self.

	"(the shadow must have the pagingArea as its owner to highlight properly)"
	self pagingArea addMorph: sliderShadow.
	sliderShadow hide.
	self addMorph: slider.
	self computeSlider.! !

!SliderMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!SliderMorph methodsFor: 'event testing' stamp: ''!
simulateSliderRightMouseDown
	"Simulate mouse button down with the left button (red button for left, blue for middle, yellow for right) into the Slider"

	slider simulateMouseDownWith: MouseEvent yellowButton! !

!SliderMorph methodsFor: 'update' stamp: ''!
updateSliderBounds
	slider bounds: self totalSliderArea.
	sliderShadow bounds: self totalSliderArea.
	
	self computeSlider.! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
descending
	"It may happen that an instance variable is nil, for example, if an instance is in the image when the instance is introduced. This test should probably be removed."
	^ descending == true! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
dragging: aBoolean
	dragging := aBoolean.! !

!SliderMorph methodsFor: 'scrolling' stamp: ''!
scrollAbsolute: event
	| r p |
	"If I'm not dragging I will do nothing."
	self dragging ifFalse: [ ^ self ].

	r := self roomToMove.
	bounds isWide
		ifTrue: [ r width = 0
				ifTrue: [ ^ self ] ]
		ifFalse: [ r height = 0
				ifTrue: [ ^ self ] ].
	p := event targetPoint 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 ]) ]! !

!SliderMorph methodsFor: 'event testing' stamp: ''!
simulateSliderMiddleMouseDown
	"Simulate mouse button down with the left button (red button for left, blue for middle, yellow for right) into the Slider"

	slider simulateMouseDownWith: MouseEvent blueButton! !

!SliderMorph methodsFor: 'model access' stamp: ''!
setValue: newValue
	"Called internally for propagation to model"
	self value: newValue.
	setValueSelector ifNotNil: [
		^model perform: setValueSelector with: value
		].! !

!SliderMorph methodsFor: 'event testing' stamp: ''!
simulateSliderRightMouseUp
	"Simulate mouse button up with the left button (red button for left, blue for middle, yellow for right) into the Slider"

	slider simulateMouseUpWith: MouseEvent yellowButton! !

!SliderMorph methodsFor: 'geometry' stamp: ''!
extent: newExtent
	newExtent = bounds extent ifTrue: [^ self].
	bounds isWide
		ifTrue: [super extent: (newExtent x max: self sliderThickness * 2) @ newExtent y]
		ifFalse: [super extent: newExtent x @ (newExtent y max: self sliderThickness * 2)].
	self removeAllMorphs; initializeSlider! !

!SliderMorph methodsFor: 'initialization' stamp: ''!
defaultBounds
"answer the default bounds for the receiver"
	^ 0 @ 0 corner: 16 @ 100! !

!SliderMorph methodsFor: 'event testing' stamp: ''!
simulateSliderMiddleMouseUp
	"Simulate mouse button up with the left button (red button for left, blue for middle, yellow for right) into the Slider"

	slider simulateMouseUpWith: MouseEvent blueButton! !

!SliderMorph methodsFor: 'other events' stamp: ''!
mouseDownInSlider: event
	"When mouse down I start dragging, and change the border colors and show a shadow
	on the original position."
	
	"If already dragging don't update."
	"Be aware that this situation is difficult to reproduce, but you can if start dragging
	and the use a key combination to change the selected OS Windows (not morphic) without
	releasing the mouse and finally make a mousedown in the slider again."
	dragging ifTrue:[^self].
	
	slider borderColor: #inset.
	
	sliderShadow color: self sliderShadowColor.
	sliderShadow cornerStyle: slider cornerStyle.
	sliderShadow bounds: slider bounds.
	sliderShadow show.
	
	self dragging: true! !

!SliderMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"
	
	super initialize.
	value := 0.0.
	descending := false.
	dragging := false.
	self initializeSlider! !

!SliderMorph methodsFor: 'geometry' stamp: ''!
sliderExtent
	^ bounds isWide
		ifTrue: [self sliderThickness @ self innerBounds height]
		ifFalse: [self innerBounds width @ self sliderThickness]! !

!SliderMorph methodsFor: 'geometry' stamp: ''!
sliderThickness
	^ 7! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
setValueSelector: aSymbol
	"Directly set the selector to make more flexible."
	
	setValueSelector := aSymbol! !

!SliderMorph methodsFor: 'event testing' stamp: ''!
simulateScrollAbsolute: aPointStart to: aPointEnd
	"Simulates a mouse moving from a given point to a destinationpoint"
	| event |
	event := MouseMoveEvent  new 
		setType: #mouseMove  
		startPoint: aPointStart 
		endPoint: aPointEnd 
		trail: nil
		buttons: 0
		hand: self currentHand
		stamp: 0.
	self scrollAbsolute:  event! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
sliderColor: newColor

	sliderColor := newColor.
	slider ifNotNil: [slider color: sliderColor]! !

!SliderMorph methodsFor: 'initialization' stamp: ''!
initializeSlider
	slider := BorderedMorph newBounds: self totalSliderArea color: self theme baseColor.
	sliderShadow := BorderedMorph newBounds: self totalSliderArea
						color: self pagingArea color.
	slider on: #mouseMove send: #scrollAbsolute: to: self.
	slider on: #mouseDown send: #mouseDownInSlider: to: self.
	slider on: #mouseUp send: #mouseUpInSlider: to: self.
	slider 
		borderWidth: 1;
		borderColor: self theme baseColor.

	sliderShadow 
		borderWidth: 1;
		borderColor: #inset.
	"(the shadow must have the pagingArea as its owner to highlight properly)"
	self pagingArea addMorph: sliderShadow.
	sliderShadow hide.
	self addMorph: slider.
	self computeSlider.! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
pagingArea
	^self! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
thumbColor
	"Color of the draggable 'thumb'"
	^ self sliderColor! !

!SliderMorph methodsFor: 'other events' stamp: ''!
mouseUpInSlider: event
	"When mouse up, the dragging ends and the color is reseted to it's orignal
	value and the shadow of original position is hidden."
	
	"If it's not dragging, there's nothing to do."
	"To reproduce this, press mouse down outside the slider, then move to
	the slider and release the mouse."
	
	dragging ifFalse:[^self].

	slider borderColor: #raised.
				
	sliderShadow hide.
	
	self dragging: false.! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!SliderMorph methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ #inset! !

!SliderMorph methodsFor: 'geometry' stamp: ''!
computeSlider
	| r |
	r := self roomToMove.
	self descending
		ifFalse:
			[slider position: (bounds isWide
				ifTrue: [r topLeft + ((r width * value) asInteger @ 0)]
				ifFalse: [r topLeft + (0 @ (r height * value)  asInteger)])]
		ifTrue:
			[slider position: (bounds isWide
				ifTrue:	[r bottomRight - ((r width * value) asInteger @ 0)]
				ifFalse:	[r bottomRight - ((0 @ (r height * value) asInteger))])].
	slider extent: self sliderExtent! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
descending: aBoolean
	descending := aBoolean.
	self value: value! !

!SliderMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGray! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
dragging
	^ dragging.! !

!SliderMorph methodsFor: 'accessing' stamp: ''!
sliderColor
	"color scheme for the whole slider widget"
	sliderColor ifNil: [^ (color alphaMixed: 0.7 with: Color white) slightlyLighter].
	^ sliderColor! !

!SliderPresenter commentStamp: ''!
A SliderPresenter is a spec presenter for a slider.
See AbstractWidgetPresenter

self example

I provide the following variables and their accessors
- max is the maximum of the slide.
- min is the minimum of the slide.
- value is the value of the slide, it is between the maximum and the minimum
- absoluteValue is the value of the slide in a percent of the maximum.
- label is the label in the background.

I provide the following methods
- color: to set the background color, it must be called after have displayed the widget.

todo
- quantum
!
!SliderPresenter methodsFor: 'api' stamp: ''!
color: aColor

	"Hack because during the interpretation, the state is slightly inconistent"
	self widget ifNotNil: [:w | w == self ifFalse: [ super color: aColor ]]! !

!SliderPresenter methodsFor: 'api' stamp: ''!
absoluteValue: aFloat
	"<api: #float min: 0 max: 1 getter:#absoluteValue registration: #whenAbsoluteValueChanged:>"
	"Set the position of the slider in a scale between 0 and 1 despite of the min and max value"

	absoluteValue value: aFloat! !

!SliderPresenter methodsFor: 'api' stamp: ''!
max: anObject
	"<api: #integer min: 1 max: 100 getter:#max registration: #whenMaxChanged:>"
	"Set the maximum value"

	max value: anObject! !

!SliderPresenter methodsFor: 'api' stamp: ''!
absoluteValue
	"<api: #inspect>"
	"Return the position of the slider in a scale between 0 and 1 despite of the min and max value"
	^ absoluteValue value! !

!SliderPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	max := 100 asValueHolder.
	min := 0 asValueHolder.
	quantum := 1 asValueHolder.
	value := 0 asValueHolder.
	absoluteValue := 0 asValueHolder.
	labelHolder := '' asValueHolder.
	isChanging := false.
	
	max whenChangedDo: [:m | self changed: { #max: . m } ].
	min whenChangedDo: [:m | self changed: { #min: . m } ].
	quantum whenChangedDo: [:m | self changed: { #quantum: . m } ].
	
	value whenChangedDo: [:v |
		isChanging ifFalse: [
			isChanging := true.
			self absoluteValue: ((v-self min)/(self max-self min)).
			self changed: { #scaledValue: . v }.
			isChanging := false ].
		self changed: #value.].
	
	absoluteValue whenChangedDo: [:v | 
		isChanging ifFalse: [
			isChanging := true.
			self value: (self min+(v*(self max-self min)) roundTo: self quantum).
			self changed: { #value: . v }.
			isChanging := false ]].
	
	labelHolder whenChangedDo: [:v | self changed: #label ].! !

!SliderPresenter methodsFor: 'api' stamp: ''!
label: aString
	"<api: #string getter: #label registration: #whenLabelChanged:>"
	"Set the label of the slider"
	
	labelHolder value: aString! !

!SliderPresenter methodsFor: 'api' stamp: ''!
value: aNumber
	"<api: #integer min: #min max: #max getter:#value registration: #whenValueChanged:>"
	"Set the value in a range between min and max"
	
	value value == aNumber ifTrue: [ ^ self ].
	value value: aNumber.! !

!SliderPresenter methodsFor: 'api - events' stamp: ''!
whenAbsoluteValueChangedDo: aBlock
	"Block performed when the absolute value changed"

	absoluteValue whenChangedDo: aBlock! !

!SliderPresenter methodsFor: 'api - events' stamp: ''!
whenMaxChangedDo: aBlock 
	"Block performed when the maximum value changed"

	max whenChangedDo: aBlock! !

!SliderPresenter methodsFor: 'api - events' stamp: ''!
whenMinChangedDo: aBlock 
	"Block performed when the minimum value changed"

	min whenChangedDo: aBlock! !

!SliderPresenter methodsFor: 'api - events' stamp: ''!
whenValueChangedDo: aBlock 
	"Block performed when the value changed"

	value whenChangedDo: aBlock! !

!SliderPresenter methodsFor: 'api' stamp: ''!
min
	"<api: #inspect>"
	"Return the minimum value"
	
	^ min value! !

!SliderPresenter methodsFor: 'api' stamp: ''!
min: anObject
	"<api: #integer min: 0 max: 99 getter:#min registration: #whenMinChanged:>"
	"Set the minimum value"
	
	min value: anObject! !

!SliderPresenter methodsFor: 'api' stamp: ''!
value
	"<api: #inspect>"
	"Return the current value in a range between min and max"

	^ value value! !

!SliderPresenter methodsFor: 'api' stamp: ''!
quantum
	"<api: #inspect>"
	"Return the quantum between values"

	^ quantum value! !

!SliderPresenter methodsFor: 'api - events' stamp: ''!
whenQuantumChangedDo: aBlock 
	"Block performed when the quantum value changed"

	quantum whenChangedDo: aBlock! !

!SliderPresenter methodsFor: 'api' stamp: ''!
reset
	"<api:#do>"
	"Reset the cursor to the minimum value"
	
	self value: self min! !

!SliderPresenter methodsFor: 'api' stamp: ''!
quantum: aNumber
	"<api: #integer min: #min max: #max getter:#quantum registration: #whenQuantumChanged:>"
	"Set the quantum between values"

	quantum value: aNumber! !

!SliderPresenter methodsFor: 'api' stamp: ''!
label
	"<api: #inspect>"
	"Return the label of the slider"

	^ labelHolder value! !

!SliderPresenter methodsFor: 'api - events' stamp: ''!
whenLabelChangedDo: aBlock
	"Block performed when the label changed"

	labelHolder whenChangedDo: aBlock! !

!SliderPresenter methodsFor: 'api' stamp: ''!
max
	"<api: #inspect>"
	"Return the maximum value"
	
	^ max value! !

!SliderPresenter class methodsFor: 'specs' stamp: ''!
example
	<sampleInstance>
	| slider |
	slider := self new.
	slider
		min: 0;
		max: 100;
		whenValueChangedDo: [ :value | slider label: value asString ].
	slider openWithSpec.
	^ slider ! !

!SliderPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(SliderAdapter
		adapt: #(model))! !

!SliderPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #SliderAdapter! !

!SliderTest methodsFor: 'tests' stamp: ''!
testDraggingModifiesValue

	aSlider simulateSliderMouseDown.
	aSlider
		simulateScrollAbsolute: aSlider bounds origin
		to: aSlider bounds corner.

	self assert: aSlider value equals: 1! !

!SliderTest methodsFor: 'running' stamp: ''!
tearDown

	window close.
	super tearDown.! !

!SliderTest methodsFor: 'tests' stamp: ''!
testMouseMoveWithoutDraggingDoesNotModifyValue

	self assertSameValueAfter: [
		aSlider
			simulateScrollAbsolute: aSlider bounds origin
			to: aSlider bounds corner ]! !

!SliderTest methodsFor: 'tests' stamp: ''!
testMouseMoveWithoutDraggingDoesNotStartDrag

	aSlider
		simulateScrollAbsolute: aSlider bounds origin
		to: aSlider bounds corner.

	"Verify that is not dragging"
	self deny: aSlider dragging! !

!SliderTest methodsFor: 'helpers' stamp: ''!
createSlider

	^ SliderMorph new
		extent: 240 @ 16;
		yourself! !

!SliderTest methodsFor: 'tests' stamp: ''!
testNewSliderValueIsZero

	self assert: aSlider value equals: 0! !

!SliderTest methodsFor: 'helpers' stamp: ''!
assertSameValueAfter: aBlock
	"I get the value on the slider, execute a block and then assert the value of the slider remains the same"

	| oldValue |
	oldValue := aSlider value.
	aBlock value.
	self assert: aSlider value equals: oldValue! !

!SliderTest methodsFor: 'tests' stamp: ''!
testSliderMouseDownMakesItDrag

	aSlider simulateSliderMouseDown.
	self assert: aSlider dragging! !

!SliderTest methodsFor: 'tests' stamp: ''!
testSliderMouseUpReleaseDrag

	self assertSameValueAfter: [ 
		aSlider simulateSliderMouseDown.
		aSlider simulateSliderMouseUp.
	]! !

!SliderTest methodsFor: 'tests' stamp: ''!
testNewSliderIsNotDragging

	self deny: aSlider dragging! !

!SliderTest methodsFor: 'tests' stamp: ''!
testSliderMouseDownDoesNotModifyValue

	self assertSameValueAfter: [ aSlider simulateSliderMouseDown ]! !

!SliderTest methodsFor: 'tests' stamp: ''!
testDraggingSeveralTimesModifiesValueSeveralTimes

	aSlider simulateSliderMouseDown.
	aSlider
		simulateScrollAbsolute: aSlider bounds origin
		to: aSlider bounds corner.
	aSlider
		simulateScrollAbsolute: aSlider bounds corner
		to: aSlider bounds origin.

	self assert: aSlider value equals: 0! !

!SliderTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	aSlider := self createSlider.
	window := aSlider openInWindow.! !

!Slot commentStamp: ''!
I'm a meta-object for accessing a slot in an Object. 

I define a reflective protocol to read (#read:) and to write (#write:to:) values. 

	For efficiency, subclasses (e.g. InstanceVariableSlot) override #emitStore: and #emitValue: to not call #read: and/or write:to:

For customizing a subclass can override the meta-object-protocol methods. See subclasses for examples. If your subclass holds state, the following must be overridden:
- Printing: #printOn: must print the source code string to reconstruct an instance. This will be displayed in the class definition. 
- Equality: #= and #hash must be customized taking account of additional state.


Vocabulary:
- Field: space occupied in an object, used to hold values accessed via Slots
- Slot: class-side meta-object, implements reading and writing.

My state:
name: I have a name (a symbol).
owningClass: the class (or Trait) I am installed in
definingClass: When I get installed via a Trait, owningClass will be the class and
the Trait I am coming from (that defined me) is stored here.

!
!Slot methodsFor: '*SystemCommands-VariableCommands' stamp: ''!
createRefactoring: variableRefactoringClass for: declarationClass in: aModel
	^variableRefactoringClass 
			model: aModel
			variable: self name
			class: declarationClass! !

!Slot methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
asCalypsoVariableOf: declarationClass

	^ClyInstanceVariable on: self definedIn: self definingClass! !

!Slot methodsFor: 'accessing' stamp: ''!
scope: aScope
	"ignored, subclasses can override to analyze the scope they are to be installed in"! !

!Slot methodsFor: 'testing' stamp: ''!
isReadIn: aCompiledCode
	^aCompiledCode ast instanceVariableReadNodes
		 anySatisfy: [ :node | node binding == self ]! !

!Slot methodsFor: 'accessing' stamp: ''!
baseSlot
	^self! !

!Slot methodsFor: 'class building' stamp: ''!
asClassVariable
	self
		error:
			'Slots can not be used to define Class Variables, you need to create a LiteralVariable subclass instead'! !

!Slot methodsFor: 'private' stamp: ''!
ensureSlotInitializationFor: aClass
	| source |
	(self sendsInitializeSlots: aClass) ifTrue: [ ^ self ].

	self ensureInitalizeMethodExists: aClass.

	source := (aClass >> #initialize) sourceCode allButFirst: 10.
	source := 'initialize
	
	self class initializeSlots: self.' , source.

	Author useAuthor: 'Generated' during: [ aClass compile: source classified: 'initialization' ]! !

!Slot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	^ self subclassResponsibility! !

!Slot methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Every subclass that adds state must redefine either this method or #definitionString"
	aStream 
		store: self name;
		nextPutAll: ' => ';
		nextPutAll: self class name! !

!Slot methodsFor: 'testing' stamp: ''!
isSelfEvaluating
	^true! !

!Slot methodsFor: 'accessing' stamp: ''!
named: aSymbol
	"to be polymorhic with slot class"
	self name: aSymbol! !

!Slot methodsFor: 'debugging' stamp: ''!
write: aValue inContext: aContext
	^self write: aValue to: aContext receiver! !

!Slot methodsFor: 'accessing' stamp: ''!
definingClass: aClass
	definingClass := aClass! !

!Slot methodsFor: 'testing' stamp: ''!
isAccessedIn: aCompiledCode
	^aCompiledCode ast instanceVariableNodes
		anySatisfy: [ :node | node binding == self ]! !

!Slot methodsFor: 'private' stamp: ''!
ensureInitalizeMethodExists: aClass
	(aClass includesSelector: #initialize) ifTrue: [ ^ self ].

	Author
		useAuthor: 'Generated'
		during: [ aClass
				compile:
					'initialize
	super initialize.'
				classified: 'initialization' ]! !

!Slot methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ self asRingMinimalDefinitionIn: anRGEnvironment parent: (self definingClass classLayout asRingMinimalDefinitionIn: anRGEnvironment)! !

!Slot methodsFor: 'testing' stamp: ''!
isVisible
	^ true! !

!Slot methodsFor: 'initialization' stamp: ''!
initialize: instance
	"nothing to do for the default slot"! !

!Slot methodsFor: 'testing' stamp: ''!
isReferenced
	^ self owningClass 
		ifNil: [ false ] 
		ifNotNil: [ :class | 
		  class withAllSubclasses anySatisfy: [ :subclass | subclass hasMethodAccessingVariable: self ] ]! !

!Slot methodsFor: 'printing' stamp: ''!
definitionString
	"Every subclass that adds state must redefine either this method or #printOn:"
	^ String streamContents: [:s | self definitionOn: s]! !

!Slot methodsFor: 'queries' stamp: ''!
usingMethods
	"All methods that read or write the slot"
	^self owningClass 
		ifNil: [ #() ]
		ifNotNil: [:class | class allMethodsAccessingSlot: self].! !

!Slot methodsFor: 'accessing' stamp: ''!
owningClass: aClass
	owningClass := aClass! !

!Slot methodsFor: '*Spec2-ObservableSlot' stamp: ''!
isObservableSlot
	
	^ false! !

!Slot methodsFor: 'accessing' stamp: ''!
definingClass
	"if a Slot from a Trait is installed in a class, we store the orginal class of the trait here"
	^ definingClass ifNil: [ self owningClass ]! !

!Slot methodsFor: 'printing' stamp: ''!
definitionOn: aStream
	"Every subclass that adds state must redefine either this method or #printOn:"
	^ self printOn: aStream! !

!Slot methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
spotterAccessesFor: aStep
	<stSpotterOrder: 10>
	(aStep hasPreviousStep and: [
		(aStep previousStep origin isKindOf: Class) or: [
			aStep origin isKindOf: Class]]) ifTrue: [
		aStep listProcessor
				title: 'Accesses';
				allCandidates: [  
						(aStep previousStep origin slotNamed: self name) usingMethods ];
				itemName: [:each | each asString];
				filter: StFilterSubstring ]! !

!Slot methodsFor: 'converting' stamp: ''!
asSlot
	^ self! !

!Slot methodsFor: 'testing' stamp: ''!
isDefinedByOwningClass

	^ self owningClass = self definingClass! !

!Slot methodsFor: 'testing' stamp: ''!
isWrittenIn: aCompiledCode
	^aCompiledCode ast instanceVariableWriteNodes
		anySatisfy: [ :node | node binding == self ]! !

!Slot methodsFor: 'meta-object-protocol' stamp: ''!
wantsInitialization
	"if a slot wants to enable instance initalization, return true here"
	^false! !

!Slot methodsFor: '*SystemCommands-VariableCommands' stamp: ''!
createRefactoring: variableRefactoringClass for: declarationClass
	^variableRefactoringClass 
			variable: self name
			class: declarationClass! !

!Slot methodsFor: 'debugging' stamp: ''!
readInContext: aContext
	^self read: aContext receiver! !

!Slot methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitInstanceVariableNode: aNode! !

!Slot methodsFor: 'private' stamp: ''!
sendsInitializeSlots: aClass
	(aClass isTrait or: [ aClass includesSelector: #initialize ])
		ifFalse: [ ^ self sendsInitializeSlots: aClass superclass ].

	"verify implemented here"
	aClass
		compiledMethodAt: #initialize
		ifPresent: [ :method | (method hasLiteral: #initializeSlots:) ifTrue: [ ^ true ] ].

	"if it calls superclass, verify there"
	(aClass isTrait not and: [ aClass >> #initialize hasLiteral: #initialize ])
		ifTrue: [ ^ self sendsInitializeSlots: aClass superclass ].

	"is not implemented"
	^ false! !

!Slot methodsFor: 'accessing' stamp: ''!
size
	"normally a slot takes one ivar. Virtual slots do not take space. 
	 We could even have Slots that map to multiple ivars"
	^self isVirtual ifTrue: [0] ifFalse: [1]! !

!Slot methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment parent: anRGLayout

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		| def |
		def := RGUnknownSlot named: self name asSymbol parent: anRGLayout.
		def ].! !

!Slot methodsFor: 'testing' stamp: ''!
isVirtual
	"virtual slots do not take up space in the object and have size = 0"
	^true! !

!Slot methodsFor: 'class building' stamp: ''!
installingIn: aClass
	"I am called by the class builder. This way a Slot can change the class it is installed in"
	self wantsInitialization ifTrue: [ self ensureSlotInitializationFor: aClass ].! !

!Slot methodsFor: 'comparing' stamp: ''!
hasSameDefinitionAs: otherSlot

	"equal definition. Slots an have additional state that is not part of the definitoon
	(e.g. the index in IndexSlot).
	This method then is overriden to not take that state into account"
	^self = otherSlot! !

!Slot methodsFor: 'testing' stamp: ''!
isInstanceVariable
	^ true! !

!Slot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
	^self subclassResponsibility! !

!Slot methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	aMethodBuilder
		pushLiteral: self;
		pushReceiver;
		send: #read:! !

!Slot methodsFor: 'code generation' stamp: ''!
emitStore: aMethodBuilder
	"generate bytecode to call the reflective write method of the Slot"
	| tempName |
	tempName := '0slotTempForStackManipulation'.  
	aMethodBuilder
		addTemp: tempName;
		storeTemp: tempName;
		popTop;
		pushReceiver;
		pushLiteral: self;
		pushTemp: tempName;
		send: #writeSlot:value:! !

!Slot methodsFor: 'accessing' stamp: ''!
owningClass
	"the class that the slot is installed in"
	^owningClass! !

!Slot methodsFor: 'accessing' stamp: ''!
scope
	^ self owningClass! !

!Slot methodsFor: 'printing' stamp: ''!
storeOn: aStream
	^self printOn: aStream! !

!Slot class methodsFor: 'testing' stamp: ''!
slotUsers
	"all classes or traits that have slots of this kind"
	^self environment allBehaviors 
		select:  [ :class | class slots anySatisfy: [ :slot | slot class == self ] ]! !

!Slot class methodsFor: 'instance creation' stamp: ''!
asSlot
	^ self new! !

!Slot class methodsFor: 'testing' stamp: ''!
isUsed
	^super isUsed or: [self slotUsers isNotEmpty ]! !

!Slot class methodsFor: 'validating' stamp: ''!
checkValidName: aSymbol

	aSymbol startsWithDigit ifTrue: [ 
		^ InvalidSlotName signalFor: aSymbol ].

	(self isPseudovariableName: aSymbol) ifTrue: [ 
		^ InvalidSlotName signalFor: aSymbol ].
	

	(aSymbol allSatisfy: [ :aCharacter | aCharacter isAlphaNumeric or: [ aCharacter = $_ ] ]) ifFalse: [ 
		^ InvalidSlotName signalFor: aSymbol ]! !

!Slot class methodsFor: 'testing' stamp: ''!
isPseudovariableName: aSymbol
	^ #('self' 'true' 'false' 'nil' 'thisContext' 'super') includes: aSymbol! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: ''!
testChangeInSharedVariablesAndSharedPoolsShouldAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.
	
	"Create a class"
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName ].

	self assert: self collectedAnnouncements size equals: 0.
	
	"Modify the class"
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			sharedPools: 'TestSharedPool';
			sharedVariablesFromString: 'A B' ].

	self assert: self collectedAnnouncements size equals: 1.
	self assert: self collectedAnnouncements first newClassDefinition equals: aClass! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
createClassWithTraitComposition: aTraitComposition
		
	^ self createClassWithLayout: FixedLayout traitComposition: aTraitComposition! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testVariableClassWithTraitCreatedShouldntAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.	

	"Create a class with a trait composition"
	aClass := self createClassWithLayout: VariableLayout traitComposition: TOne.

	self assertEmpty: self collectedAnnouncements.
	self assert: aClass classLayout isVariable.
	self deny: aClass classLayout isBits .
	self assert: (aClass traitComposition syntacticallyEquals: TOne asTraitComposition)! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testVariableWordClassWhenTraitCompositionChangedShouldAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.	

	"Create a class without trait composition"
	self createClassWithLayout: WordLayout.

	self assertEmpty: self collectedAnnouncements.
	
	"Set a new trait composition"
	self createClassWithLayout: WordLayout traitComposition: TOne.
	
	self assert: self collectedAnnouncements size equals: 1.
	announcement := self collectedAnnouncements first.
	self assert: (announcement oldClassDefinition traitComposition syntacticallyEquals: {} asTraitComposition).	
	self assert: (announcement newClassDefinition traitComposition syntacticallyEquals: TOne asTraitComposition)! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: ''!
testChangeInSharedPoolShouldAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.
	
	"Create a class"
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName ].

	self assert: self collectedAnnouncements size equals: 0.
	
	"Modify the class"
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			sharedPools: 'TestSharedPool' ].

	self assert: self collectedAnnouncements size equals: 1.
	self assert: self collectedAnnouncements first newClassDefinition equals: aClass! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testWeakClassWhenTraitCompositionChangedShouldAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.	

	"Create a class without trait composition"
	self createClassWithLayout: WeakLayout.

	self assertEmpty: self collectedAnnouncements.
	
	self createClassWithLayout: WeakLayout traitComposition: TOne.
	
	self assert: self collectedAnnouncements size equals: 1.
	announcement := self collectedAnnouncements first.
	self assert: (announcement oldClassDefinition traitComposition syntacticallyEquals: {} asTraitComposition).	
	self assert: (announcement newClassDefinition traitComposition syntacticallyEquals: TOne asTraitComposition)! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: ''!
testSlotAdditionShouldAnnounceClassModified

	| classAdded classModified addedInstanceNames |
	self subscribeOn: ClassModifiedClassDefinition.
	
	"Create a class"
	classAdded := self makeWithLayout: FixedLayout.
	addedInstanceNames := classAdded allInstVarNames.
	
	"now we extend it with slots.  The class definition should've changed"
	classModified := self makeWithLayout: FixedLayout andSlots: { #aSlot }.

	self assert: self collectedAnnouncements size equals: 1.
	announcement := self collectedAnnouncements first.	
	self assert: announcement newClassDefinition equals: classModified.
	self assert: announcement oldClassDefinition allInstVarNames equals: addedInstanceNames! !

!SlotAnnouncementsTest methodsFor: 'helpers' stamp: ''!
collectedAnnouncements
	^ collectedAnnouncements! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: ''!
testChangeInSuperclassShouldNotAnnounceSubclassModified

	self subscribeOn: ClassModifiedClassDefinition.
	
	"Create a class and a subclass"
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			slots: #() ].

	anotherClass := self make: [ :builder | 
		builder 
			name: self anotherClassName;
			superclass: aClass ].

	self assert: self collectedAnnouncements size equals: 0.
	
	"Modify the superclass"
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			slots: #(a b c) ].

	self assert: self collectedAnnouncements size equals: 2.
	self assert: self collectedAnnouncements second newClassDefinition equals: aClass.
	self assert: self collectedAnnouncements first newClassDefinition equals: anotherClass.	! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testVariableByteClassWhenTraitCompositionChangedShouldAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.	

	self createClassWithLayout: ByteLayout.

	self assertEmpty: self collectedAnnouncements.
	
	self createClassWithLayout: ByteLayout traitComposition: TOne.
	
	self assert: self collectedAnnouncements size equals: 1.
	announcement := self collectedAnnouncements first.
	self assert: (announcement oldClassDefinition traitComposition syntacticallyEquals: {} asTraitComposition).	
	self assert: (announcement newClassDefinition traitComposition syntacticallyEquals: TOne asTraitComposition)! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: ''!
testLayoutChangeShouldAnnounceClassModified

	| classAdded classModified addedFormat |
	self subscribeOn: ClassModifiedClassDefinition.
	
	"Create a class"
	classAdded := self makeWithLayout: FixedLayout.
	addedFormat := classAdded format.
	
	"Modify its format"
	classModified := self makeWithLayout: WeakLayout.

	self assert: self collectedAnnouncements size equals: 1.
	announcement := self collectedAnnouncements first.
	self assert: announcement newClassDefinition equals: classModified.
	self assert: announcement oldClassDefinition format equals: addedFormat.
	self assert: announcement newClassDefinition format equals: classModified format! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
createClassWithLayout: aLayoutClass
		
	^ self createClassWithLayout: aLayoutClass traitComposition: #()! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: ''!
testChangeInSharedVariablesShouldAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.
	
	"Create a class"
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName ].

	self assert: self collectedAnnouncements size equals: 0.
	
	"Modify the class"
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			sharedVariablesFromString: 'A B C' ].

	self assert: self collectedAnnouncements size equals: 1.
	self assert: self collectedAnnouncements first newClassDefinition equals: aClass! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testFixedClassWhenTraitCompositionChangedShouldAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.	

	self createClassWithTraitComposition: {}.

	self assertEmpty: self collectedAnnouncements.

	self createClassWithTraitComposition: TOne.
		
	self assert: self collectedAnnouncements size equals: 1.
	announcement := self collectedAnnouncements first.
	self assert: (announcement oldClassDefinition traitComposition syntacticallyEquals: {} asTraitComposition).	
	self assert: (announcement newClassDefinition traitComposition syntacticallyEquals: TOne asTraitComposition).! !

!SlotAnnouncementsTest methodsFor: 'helpers' stamp: ''!
subscribeOn: anAnnouncement

	SystemAnnouncer uniqueInstance weak 
		when: anAnnouncement
		send: #add: 
		to: collectedAnnouncements! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testVariableWordClassWithTraitCreatedShouldntAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.	

	"Create a class with a trait composition"
	aClass := self createClassWithLayout: WordLayout traitComposition: TOne.

	self assertEmpty: self collectedAnnouncements.
	self assert: aClass classLayout isVariable.
	self assert: aClass classLayout isBits.
	self assert: aClass classLayout isWords.
	self assert: (aClass traitComposition syntacticallyEquals: TOne asTraitComposition)! !

!SlotAnnouncementsTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	collectedAnnouncements := OrderedCollection new! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testFixedClassWithTraitCreatedShouldntAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.	

	"Create a class with a trait composition"
	aClass := self createClassWithTraitComposition: TOne.

	self assertEmpty: self collectedAnnouncements.
	self deny: aClass classLayout isVariable.
	self assert: (aClass traitComposition syntacticallyEquals: TOne asTraitComposition)! !

!SlotAnnouncementsTest methodsFor: 'running' stamp: ''!
tearDown 

	SystemAnnouncer uniqueInstance unsubscribe: collectedAnnouncements.
	super tearDown! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: ''!
testClassCreationShouldAnnounceClassAdded

	self subscribeOn: ClassAdded.
	
	"Create a class"
	aClass := self makeWithLayout: FixedLayout.
	
	self assert: self collectedAnnouncements size equals: 1. 
	self assert: self collectedAnnouncements first classAdded equals: aClass! !

!SlotAnnouncementsTest methodsFor: 'tests - comments' stamp: ''!
testCreateAndChangeWithCommentDoesAnnounceBoth

	| classCommented |
	self subscribeOn: ClassCommented.
	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			comment: 'A class Comment' ].
	
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			comment: 'Another class Comment' ].

	self assert: self collectedAnnouncements size equals: 2.
	
	classCommented := self collectedAnnouncements first.
	self assert: classCommented classCommented equals: aClass.
	self assert: classCommented oldComment equals: ''.
	self assert: classCommented newComment equals: 'A class Comment'.
	self assert: classCommented oldStamp equals: ''.
	self assert: classCommented newStamp equals: nil. "why nil?"
	
	classCommented := self collectedAnnouncements second.
	self assert: classCommented classCommented equals: aClass.
	self assert: classCommented oldComment equals: 'A class Comment'.
	self assert: classCommented newComment equals: 'Another class Comment'.
	self assert: classCommented oldStamp equals: nil. "why nil?" 
	self assert: classCommented newStamp equals: nil "why nil?"! !

!SlotAnnouncementsTest methodsFor: 'tests - comments' stamp: ''!
testSameCommentDoesNotAnnounce

	self subscribeOn: ClassCommented.
	
	self make: [ :builder |
		builder 
			name: self aClassName;
			comment: 'A class Comment' ].

	self make: [ :builder |
		builder 
			name: self aClassName;
			comment: 'A class Comment' ].
	
	self assert: self collectedAnnouncements size equals: 1! !

!SlotAnnouncementsTest methodsFor: 'tests - comments' stamp: ''!
testEmptyCommentDoesNotAnnounce
	self subscribeOn: ClassCommented.

	self
		make: [ :builder | 
			builder
				name: self aClassName;
				comment: '' ].

	self
		make: [ :builder | 
			builder
				name: self aClassName;
				comment: '';
				sharedPools: 'TestSharedPool' ].

	self assertEmpty: self collectedAnnouncements! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
createClass
		
	^ self createClassWithLayout: FixedLayout! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
createClassWithLayout: aLayoutClass traitComposition: aTraitComposition
		
	^ self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: self aClassName;
			layoutClass: aLayoutClass;
			traitComposition: aTraitComposition asTraitComposition;
			package: self aCategory ].! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testVariableClassWhenTraitCompositionChangedShouldAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.	

	"Create a class without trait composition"
	self createClassWithLayout: VariableLayout.

	self assertEmpty: self collectedAnnouncements.
	
	"Set a new trait composition"
	self createClassWithLayout: VariableLayout traitComposition: TOne.
	
	self assert: self collectedAnnouncements size equals: 1.
	announcement := self collectedAnnouncements first.
	self assert: (announcement oldClassDefinition traitComposition syntacticallyEquals: {} asTraitComposition).	
	self assert: (announcement newClassDefinition traitComposition syntacticallyEquals: TOne asTraitComposition)! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testClassAddedToNewCategoryShouldAnnounceCategoryAdded

	self subscribeOn: CategoryAdded.	

	self deny: (self class environment organization includesCategory: self aCategory).

	self createClass.

	self assert: (self class environment organization includesCategory: self aCategory).

	self assert: self collectedAnnouncements size equals: 1! !

!SlotAnnouncementsTest methodsFor: 'helpers' stamp: ''!
collectedAnnouncementClasses
	^ collectedAnnouncements collect: [:each | each class]! !

!SlotAnnouncementsTest methodsFor: 'tests - comments' stamp: ''!
testCreateAndChangeWithoutCommentDoesNotAnnounce
	self subscribeOn: ClassCommented.

	self make: [ :builder | builder name: self aClassName ].

	self
		make: [ :builder | 
			builder
				name: self aClassName;
				sharedPools: 'TestSharedPool' ].

	self assertEmpty: self collectedAnnouncements! !

!SlotAnnouncementsTest methodsFor: 'tests - comments' stamp: ''!
testCreateWithCommentDoesAnnounce

	| classCommented |
	self subscribeOn: ClassCommented.
	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			comment: 'A class Comment' ].
	
	self assert: self collectedAnnouncements size equals: 1.
	
	classCommented := self collectedAnnouncements anyOne.
	
	self assert: classCommented classCommented equals: aClass.
	self assert: classCommented oldComment equals: ''.
	self assert: classCommented newComment equals: 'A class Comment'.
	self assert: classCommented oldStamp equals: ''.
	self assert: classCommented newStamp equals: nil  "why nil?"! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: ''!
testClassRecategorizationShouldAnnounceClassModified
	self subscribeOn: ClassRecategorized.

	aClass := self make: [ :builder | builder category: self aCategory ].
	anotherClass := self make: [ :builder | builder category: self anotherCategory ].

	self assert: self collectedAnnouncements size equals: 1.
	announcement := self collectedAnnouncements first.
	self assert: announcement oldCategory equals: self aCategory.
	self assert: announcement newCategory equals: self anotherCategory.
	self assert: announcement classRecategorized identicalTo: anotherClass! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testWeakClassWithTraitCreatedShouldntAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.	

	"Create a class with a trait composition"
	aClass := self createClassWithLayout: WeakLayout traitComposition: TOne.

	self assertEmpty: self collectedAnnouncements.
	self assert: aClass classLayout isVariable.
	self assert: aClass classLayout isWeak.
	self assert: (aClass traitComposition syntacticallyEquals: TOne asTraitComposition)! !

!SlotAnnouncementsTest methodsFor: 'tests - integration' stamp: ''!
testVariableByteClassWithTraitCreatedShouldntAnnounceClassModified

	self subscribeOn: ClassModifiedClassDefinition.	

	"Create a class with a trait composition"
	aClass := self createClassWithLayout: ByteLayout traitComposition: TOne.

	self assertEmpty: self collectedAnnouncements.
	self assert: aClass classLayout isVariable.
	self assert: aClass classLayout isBits.
	self assert: aClass classLayout isBytes.
	self assert: (aClass traitComposition syntacticallyEquals: TOne asTraitComposition)! !

!SlotBasicTest methodsFor: 'tests - basic' stamp: ''!
testNewVariableWordClass

	aClass := self makeWithLayout: WordLayout.
	self deny: aClass isPointers.
	self deny: aClass isFixed.
	self assert: aClass isWords.
	self assert: aClass isVariable! !

!SlotBasicTest methodsFor: 'tests - basic' stamp: ''!
testNewVariableByteClass

	aClass := self makeWithLayout: ByteLayout.
	self deny: aClass isPointers.
	self deny: aClass isFixed.
	self assert: aClass isBytes.
	self assert: aClass isVariable! !

!SlotBasicTest methodsFor: 'tests - class slots' stamp: ''!
testAddClassSlotAndMigrate

	| classAdded classModified |
	classAdded := 
		self make: [ :builder | 
			builder classSlots: #(a) ].

	classAdded instVarNamed: #a put: $A.
	
	classModified := 
		self make: [ :builder | 
			builder classSlots: #(a b) ].
	
	self assert: (classModified instVarNamed: #a) equals: $A.
	self assert: (classModified instVarNamed: #b) isNil! !

!SlotBasicTest methodsFor: 'tests - basic' stamp: ''!
testNewCompiledMethodClass

	aClass := self makeWithLayout: CompiledMethodLayout.
	self deny: aClass isPointers.
	self deny: aClass isFixed.
	self assert: aClass isBytes.
	self deny: aClass isWeak! !

!SlotBasicTest methodsFor: 'tests - shared variables' stamp: ''!
testWithoutSharedVariables
	aClass := self make: [ :builder | builder sharedVariablesFromString: '' ].

	self assertEmpty: aClass classVarNames! !

!SlotBasicTest methodsFor: 'tests - comments' stamp: ''!
testClassWithCommentAndStamp

	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			comment: 'A class Comment' stamp: (Object>>#halt) stamp ].
	
	self assert: aClass name equals: self aClassName.
	self assert: aClass comment equals: 'A class Comment'.
	self assert: aClass organization commentStamp equals: (Object>>#halt) stamp
	
! !

!SlotBasicTest methodsFor: 'tests - shared variables' stamp: ''!
testRemoveSharedVariable
	self make: [ :builder | builder sharedVariablesFromString: 'Var' ].

	aClass := self make: [ :builder | builder sharedVariablesFromString: '' ].

	self assertEmpty: aClass classVarNames! !

!SlotBasicTest methodsFor: 'tests - class slots' stamp: ''!
testSwitchClassSlotAndMigrate

	| classAdded classModified |	
	classAdded := 
		self make: [ :builder | 
			builder classSlots: #(a b) ].

	"Add methods"	
	classAdded class 
		compile: 'a ^a';
		compile: 'b ^b'.

	"Put values"
	classAdded instVarNamed: #a put: $A.
	classAdded instVarNamed: #b put: $B.

	"Modify the class"	
	classModified := 
		self make: [ :builder | 
			builder classSlots: #(b a) ].
	
	"The instance was migrated"
	self assert: (classModified instVarNamed: #a) equals: $A.
	self assert: (classModified instVarNamed: #b) equals: $B.
	
	"The methods were migrated"
	self assert: classModified a equals: $A.
	self assert: classModified b equals: $B
! !

!SlotBasicTest methodsFor: 'tests - basic' stamp: ''!
testBasicClassBuilding
	aClass := self make: [ :builder | builder name: self aClassName ].

	self deny: aClass classLayout isNil.
	self assert: aClass name equals: self aClassName.
	self assert: (self class environment at: self aClassName) identicalTo: aClass! !

!SlotBasicTest methodsFor: 'tests - shared pools' stamp: ''!
testAddSharedPool

	self make: [ :builder | 
		builder sharedPools: '' ].

	aClass := self make: [ :builder | 
		builder sharedPools: 'TestSharedPool' ].
	
	self assert: (aClass sharedPools includes: TestSharedPool)
! !

!SlotBasicTest methodsFor: 'tests - class slots' stamp: ''!
testRemoveClassSlotAndMigrate

	| classAdded classModified |
	classAdded := 
		self make: [ :builder | 
			builder classSlots: #(a b) ].

	classAdded instVarNamed: #a put: $A.
	
	classModified := 
		self make: [ :builder | 
			builder classSlots: #(a) ].
	
	self assert: (classModified instVarNamed: #a) equals: $A.
	self should: [ classModified instVarNamed: #b ] raise: Error
! !

!SlotBasicTest methodsFor: 'tests - shared variables' stamp: ''!
testAddSharedVariable

	self make: [ :builder | 
		builder sharedVariablesFromString: '' ].

	aClass := self make: [ :builder | 
		builder sharedVariablesFromString: 'Var' ].
	
	self assert: aClass classVarNames equals: #(Var)
! !

!SlotBasicTest methodsFor: 'tests - shared pools' stamp: ''!
testRemoveSharedPool
	self make: [ :builder | builder sharedPools: 'TestSharedPool' ].

	aClass := self make: [ :builder | builder sharedPools: '' ].

	self assertEmpty: aClass sharedPools! !

!SlotBasicTest methodsFor: 'tests - shared pools' stamp: ''!
testWithSharedPool

	aClass := self make: [ :builder | 
		builder sharedPools: 'TestSharedPool' ].
	aClass class compile: 'one ^One'.
	
	self assert: (aClass sharedPools includes: TestSharedPool).
	self assert: aClass one equals: 1! !

!SlotBasicTest methodsFor: 'tests - comments' stamp: ''!
testClassWithComment

	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			comment: 'A class Comment' ].
	
	self assert: aClass name equals: self aClassName.
	self assert: aClass comment equals: 'A class Comment'
	
! !

!SlotBasicTest methodsFor: 'tests - basic' stamp: ''!
testNewWeakClass

	aClass := self makeWithLayout: WeakLayout.
	self assert: aClass isPointers.
	self deny: aClass isFixed.
	self assert: aClass isWords.
	self assert: aClass isWeak! !

!SlotBasicTest methodsFor: 'tests - shared pools' stamp: ''!
testWithoutSharedPools
	aClass := self make: [ :builder | builder sharedPools: '' ].

	self assertEmpty: aClass sharedPools! !

!SlotBasicTest methodsFor: 'tests - shared variables' stamp: ''!
testWithSharedVariable

	aClass := self make: [ :builder | 
		builder sharedVariablesFromString: 'Var' ].
	aClass class 
		compile: 'var:x  Var:=x';
		compile: 'var  ^Var'.
	
	aClass var: true.
	
	self assert: aClass classVarNames equals: #(Var).
	self assert: aClass var! !

!SlotBasicTest methodsFor: 'tests - class slots' stamp: ''!
testWithoutClassSlots
	aClass := self make: [ :builder | builder classSlots: #() ].

	self assertEmpty: aClass classVarNames! !

!SlotBasicTest methodsFor: 'tests - basic' stamp: ''!
testNewPointerClassWithSlots

	aClass := self 
		makeWithLayout: FixedLayout
		andSlots: { #id. #name }.
	
	self assert: (aClass instVarNames includes: 'id').
	self assert: (aClass instVarNames includes: 'name')! !

!SlotBasicTest methodsFor: 'tests - class slots' stamp: ''!
testWithClassSlots

	aClass := self make: [ :builder | 
		builder classSlots: #(a) ].
	
	self assert: aClass class instVarNames equals: #(a).	
	aClass instVarNamed: #a put: $A.
	self assert: (aClass instVarNamed: #a) equals: $A! !

!SlotBasicTest methodsFor: 'tests - basic' stamp: ''!
testNewPointerClass
	aClass := self makeWithLayout: FixedLayout.
	self assert: aClass isPointers.
	self assert: aClass isFixed.
	self assertEmpty: aClass instVarNames! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: ''!
layoutClasses
	^ { ByteLayout. WordLayout. FixedLayout. VariableLayout. WeakLayout }! !

!SlotClassBuilderTest methodsFor: 'running' stamp: ''!
tearDown
	"We remove the classes that could have been created during test run"

	SystemAnnouncer uniqueInstance suspendAllWhile: [
		{ self aClassName. self anotherClassName. self yetAnotherClassName. self yetYetAnotherClassName } do: [ :each | 
			testingEnvironment
				at: each 
				ifPresent: [ :class | class removeFromSystem ]]].

	SystemAnnouncer uniqueInstance unsubscribe: self.
	
	self 
		cleanUpTrait: TOne;
		cleanUpTrait: TTwo.
		
	Smalltalk organization removeCategory: self aCategory.
	(RPackageOrganizer default 
		packageNamed: self aCategory
		ifAbsent: [ ^ self ]) 
		unregister.
		
	super tearDown! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: ''!
anotherCategory
	^ 'SlotTestsTmp-Another'! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: ''!
yetYetAnotherClassName
	^ #SlotTestsClassD! !

!SlotClassBuilderTest methodsFor: 'helpers-building' stamp: ''!
makeWithLayout: aClassLayout
	^self makeWithLayout: aClassLayout andSlots: {}! !

!SlotClassBuilderTest methodsFor: 'running' stamp: ''!
cleanUpTrait: trait
	"During development some tests might invalidate the trait internal state.
	To avoid follow-up failures we reset the trait state here as good as possible."
	
	trait traitUsers removeAll.
	trait classTrait traitUsers removeAll! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: ''!
aClassName
	^ #SlotTestsClassA! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: ''!
layoutClassesWithSlots
	^ { FixedLayout. VariableLayout. WeakLayout }! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: ''!
aCategory
	^ 'SlotTestsTmp'! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: ''!
anotherClassName
	^ #SlotTestsClassB! !

!SlotClassBuilderTest methodsFor: 'helpers-building' stamp: ''!
makeWithLayout: aClassLayout andSlots: someSlots
	"
	I create a class using the Slot class builder given a class layout and a collection of slots.
	"

	^self make: [:builder|
		builder
			layoutClass: aClassLayout;
			slots: someSlots
		]! !

!SlotClassBuilderTest methodsFor: 'helpers-building' stamp: ''!
make: anUnaryBlock
	"I build a class for testing, providing basic default values, but eventually customized by the received unary block."

	^Smalltalk classInstaller make: [:builder|
		builder
			superclass: Object;
			name: self aClassName;
			layoutClass: FixedLayout;
			category: self aCategory.
		anUnaryBlock value: builder
		]! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: ''!
yetAnotherClassName
	^ #SlotTestsClassC! !

!SlotClassBuilderTest methodsFor: 'running' stamp: ''!
assertTraitIntegrity
	self assert: TOne traitUsers isHealthy.
	self assert: TOne classTrait traitUsers isHealthy.
	self assert: TTwo traitUsers isHealthy.
	self assert: TTwo classTrait traitUsers isHealthy! !

!SlotClassVariableTest methodsFor: 'tests' stamp: ''!
testClassVariableDoesNotDuplicatesSubclassesOfSuperclass
	"Issue: 13028"
	| class1 class2 |	
	
	class1 := self make: [ :builder | 
		builder
			name: self aClassName;
			superclass: Object ].
	
	class2 := self make: [ :builder | 
		builder
			name: self anotherClassName;
			superclass: class1 ].
	
	self assert: class1 subclasses equals: { class2 }.
	class2 := self make: [ :builder | 
		builder
			name: self anotherClassName;
			superclass: class1;
			sharedVariablesFromString: 'ASharedVariable' ].
	self assert: class1 subclasses equals: { class2 }
! !

!SlotClassVariableTest methodsFor: 'tests' stamp: ''!
testSlotIsPersistedAfterRebuildOfClass
	| class1 |	
	
	class1 := self make: [ :builder | 
		builder
			name: self aClassName;
			superclass: Object ].
		
	class1 class addSlot: (AccessorInstanceVariableSlot named: #Foo).

	self assert: class1 class slots size equals: 1.
	self assert: (class1 class slots at:1) name equals: #Foo.
	self assert: (class1 class slots at:1) class equals: AccessorInstanceVariableSlot.
	
	class1 := self make: [ :builder | 
		builder
			name: self aClassName;
			superclass: Object ].

	self assert: class1 class slots size equals: 1.
	self assert: (class1 class slots at:1) name equals: #Foo.
	self assert: (class1 class slots at:1) class equals: AccessorInstanceVariableSlot
! !

!SlotClassVariableTest methodsFor: 'tests' stamp: ''!
testWantsInitializationAddsInitializeSlot
	| class1 |	
	
	class1 := self make: [ :builder | 
		builder
			name: self aClassName;
			superclass: Object ].
		
	class1 addSlot: WriteOnceSlot new.

	self assert: class1 slots size equals: 1.

	self assert: ((class1 >> #initialize) hasLiteral: #initializeSlots:).
	"validate 'self class initializeSlots: self' is the first message sent"
	self assert: (class1 >> #initialize) literals first equals: #class.
	self assert: (class1 >> #initialize) literals second equals: #initializeSlots:
! !

!SlotClassVariableTest methodsFor: 'tests' stamp: ''!
testWantsInitializationSkipInitializeSlotIfAlreadyInHierarchy
	| class1 class2 |	
	
	class1 := self make: [ :builder | 
		builder
			name: self aClassName;
			superclass: Object;
			slots: {
				WriteOnceSlot new
					name: #foo;
					yourself } ].

	self assert: class1 slots size equals: 1.
	self assert: ((class1 >> #initialize) hasLiteral: #initializeSlots:).

	class2 := self make: [ :builder | 
		builder
			name: self anotherClassName;
			superclass: class1;
			slots: { 
				WriteOnceSlot new
					name: #bar;
					yourself } ].

	self assert: class2 slots size equals: 1.
	class2
		compiledMethodAt: #initialize
		ifPresent: [ self fail: 'In case the super method already call #initializeSlots:, we don''t want to generate an initialize method' ]! !

!SlotClassVariableTest methodsFor: 'tests' stamp: ''!
testAccessorInstanceVariableSlotGeneratesAccessors
	| class1 |	
	
	class1 := self make: [ :builder | 
		builder
			name: self aClassName;
			superclass: Object ].
		
	class1 class addSlot: (AccessorInstanceVariableSlot named: #foo).

	self assert: (class1 class canUnderstand: #foo).
	self assert: (class1 class canUnderstand: #foo:)! !

!SlotDeprecation commentStamp: ''!
This exception is raised when accessing deprecated slots!
!SlotDeprecation methodsFor: 'accessing' stamp: ''!
explanationString
	^explanationString ifNil: [ '' ]! !

!SlotDeprecation methodsFor: 'accessing' stamp: ''!
messageText
	^ String
		streamContents: [ :str | 
			str
				nextPutAll: 'The instance variable ';
				nextPutAll: context receiver name;
				nextPutAll: ' accessed in ';
				nextPutAll: context sender method name;
				nextPutAll: ' has been deprecated. ';
				nextPutAll: self explanationString ]! !

!SlotEnvironmentTest methodsFor: 'tests' stamp: ''!
testBasicEnvironment
	| environment |
	environment := SystemDictionary new.

	aClass := self make: [ :builder | builder environment: environment ].

	self assert: aClass environment identicalTo: environment.
	self assert: (environment includesKey: aClass name).
	self assert: (environment at: aClass name) identicalTo: aClass.

	self deny: (testingEnvironment includesKey: aClass name)! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testClassNameWithInvalidCharacter

	self assertInvalidClassName: #'Invalid-ClassName'! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testDangerousClassesConditions

	| specialObjectsArrayItem |
	
	specialObjectsArrayItem := (Smalltalk specialObjectsArray select: [ :x | x isClass ]) anyOne name.

	self assert: (DangerousClassNotifier shouldNotBeRedefined: #ProtoObject).
	self assert: (DangerousClassNotifier shouldNotBeRedefined: specialObjectsArrayItem)! !

!SlotErrorsTest methodsFor: 'helpers' stamp: ''!
assertInvalidClassName: aName

	self should: [
		self make: [ :builder | 
			builder name: aName ] ]
		raise: InvalidGlobalName.
	self flag: 'should remove class if not raised'.
		
	self should: [
		Smalltalk classInstaller 
			validateClassName: aName ]
		raise: InvalidGlobalName! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testIndirectCircularHierarchyError
	"Tests an error is raised when trying to create a hierarchy A<-B<-A"
	
	| classA classB |
	classA := self make: [ :builder |
			builder 
				superclass: Object;
				name: self aClassName ].

	classB := self make: [ :builder |
			builder 
				superclass: classA;
				name: self anotherClassName ].

	self should: [ 
		self make: [ :builder | 
			builder 
				superclass: classB;
				name: self aClassName ] ]
		raise: CircularHierarchyError ! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testUndeclareSlotFixWhenSlotIsLoaded
	| slot instance mySlot |

	aClass := self make: [ :builder | 
		builder slots: { UndefinedSlot named: #a ast: ((RBParser parseExpression: '#a => ', self anotherClassName) doSemanticAnalysis;yourself) } ].

	slot := aClass slotNamed: #a.

	self assert: slot class equals: UndefinedSlot.
	self assert: slot name equals: #a.
	self assert: slot slotClassName equals: self anotherClassName.
	
	instance := aClass new.
	
	self assert: (slot read: instance) equals: nil.
	slot write: 1 to: instance.
	self assert: (slot read: instance) equals: nil.

	self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: self anotherClassName;
			superclass: PropertySlot;
			package: self aCategory ].
	
	self assert: (slot read: instance) equals: nil.
	
	mySlot := aClass slotNamed: #a.
	
	self assert: mySlot name equals: #a.
	
	self assert: (mySlot read: instance) equals: nil.
	mySlot write: 1 to: instance.
	self assert: (mySlot read: instance) equals: 1.! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testClassSlotWithReservedName

	#(#self #super #thisContext #true #false #nil) do: [:reservedName |
		self should: [ 
			self make: [ :builder | 
				builder classSlots: { reservedName } ] ]
			raise: InvalidSlotName ]! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testSlotWithReservedName

	#(#self #super #thisContext #true #false #nil) do: [:reservedName |
		self should: [ 
			self make: [ :builder | 
				builder slots: { reservedName } ] ]
			raise: InvalidSlotName ]! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testDirectCircularHierarchyError
	"Tests an error is raised when trying to create a hierarchy A<-A"
	
	| classA |
	classA := self make: [ :builder |
			builder 
				superclass: Object;
				name: self aClassName ].

	self should: [ 
		self make: [ :builder | 
			builder 
				superclass: classA;
				name: self aClassName ] ]
		raise: CircularHierarchyError ! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testSlotDuplicationConflict

	aClass := self make: [ :builder | 
		builder slots: { #a } ].

	self should: [ 
		self make: [ :builder | 
			builder 
				superclass: aClass;
				name: self anotherClassName;
				slots: { #a } ] ]
		raise: DuplicatedSlotName ! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testClassSlotDuplicationConflict

	aClass := self make: [ :builder | 
		builder classSlots: { #a } ].

	self should: [ 
		self make: [ :builder | 
			builder 
				superclass: aClass;
				name: self anotherClassName;
				classSlots: { #a } ] ]
		raise: DuplicatedSlotName ! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testClassNameMustBeSymbol

	self assertInvalidClassName: 1! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testDangerousClassesEnabling

	| savedExistingSystemSetting myExpectedError |

	savedExistingSystemSetting := DangerousClassNotifier enabled.

	DangerousClassNotifier disable.
	self assert: DangerousClassNotifier enabled not.
	DangerousClassNotifier disableDuring: [
      self assert: DangerousClassNotifier enabled not].
	self assert: DangerousClassNotifier enabled not.

	DangerousClassNotifier enable.
	self assert: DangerousClassNotifier enabled.	
	DangerousClassNotifier disableDuring: [
      self assert: DangerousClassNotifier enabled not].
	self assert: DangerousClassNotifier enabled.

	DangerousClassNotifier enable.
	DangerousClassNotifier disableDuring: [
		self deny: (DangerousClassNotifier check: #CompiledMethod)].
	myExpectedError := false.
	[ DangerousClassNotifier check: #CompiledMethod ] on: Warning do: [ myExpectedError := true  ].
	self assert: myExpectedError.

	savedExistingSystemSetting 
		ifTrue: [ DangerousClassNotifier enable ]
		ifFalse: [ DangerousClassNotifier disable ].
	self assert: DangerousClassNotifier enabled equals: savedExistingSystemSetting! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testUndeclareSlot
	| slot instance |

	aClass := self make: [ :builder | 
		builder slots: { UndefinedSlot named: #a ast: ((RBParser parseExpression: '#a => MySlot') doSemanticAnalysis;yourself) } ].

	slot := aClass slotNamed: #a.

	self assert: slot class equals: UndefinedSlot.
	self assert: slot name equals: #a.
	self assert: slot slotClassName equals: #MySlot.
	
	instance := aClass new.
	
	self assert: (slot read: instance) equals: nil.
	slot write: 1 to: instance.
	self assert: (slot read: instance) equals: nil.
! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testCannotBeRecompiled
	| superclass |
	<expectedFailure>
	superclass := self make: [ :builder | 
		builder 
			superclass: Object;
			name: self aClassName ].

	self make: [ :builder | 
		builder 
			superclass: superclass;
			name: self anotherClassName ].

	self 
		should: [ 
			self make: [ :builder | 
				builder 
					layoutClass: VariableLayout;
					name: self aClassName ] ]
		raise: Error
		description: 'Old class builder raises: X cannot be recompiled'
! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testClassNameMustBeCapitalized

	self assertInvalidClassName: #aNotCapitalizedClassName! !

!SlotErrorsTest methodsFor: 'tests' stamp: ''!
testValidateClassName		
		
	Smalltalk classInstaller 
		validateClassName: #GoodClassNameThatShouldNotExist! !

!SlotExampleMovie commentStamp: ''!
A SlotExampleMovie is an example class to demonstrate the workings of relation slots.!
!SlotExampleMovie methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self class initializeSlots: self! !

!SlotExampleMovie methodsFor: 'accessing' stamp: ''!
actors: anObject
	actors := anObject! !

!SlotExampleMovie methodsFor: 'adding/removing' stamp: ''!
removeActor: aPerson

	^actors remove: aPerson! !

!SlotExampleMovie methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!SlotExampleMovie methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!SlotExampleMovie methodsFor: 'accessing' stamp: ''!
director
	^ director! !

!SlotExampleMovie methodsFor: 'accessing' stamp: ''!
director: aPerson

	director := aPerson! !

!SlotExampleMovie methodsFor: 'adding/removing' stamp: ''!
addActor: aPerson

	^actors add: aPerson! !

!SlotExampleMovie methodsFor: 'accessing' stamp: ''!
actors
	^ actors! !

!SlotExampleMovie class methodsFor: 'instance creation' stamp: ''!
named: aString
	^ self new
		name: aString;
		yourself! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testNewPerson
	| person |
	person := SlotExamplePerson new.
	self assert: person name isNil.
	self assert: person directedMovies isCollection.
	self assertEmpty: person directedMovies! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testAddAndRemoveActors
	| m1 m2 p1 p2 |
	m1 := SlotExampleMovie named: 'M1'.
	m2 := SlotExampleMovie named: 'M2'.
	p1 := SlotExamplePerson named: 'P1'.
	p2 := SlotExamplePerson named: 'P2'.

	m1
		addActor: p1;
		addActor: p2.
	m2 addActor: p2.

	m1 removeActor: p2.
	self assert: p2 actedInMovies size equals: 1.
	m2 removeActor: p2.
	self assertEmpty: p2 actedInMovies.

	self should: [ m2 removeActor: p2 ] raise: Error! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testAddMovieDirector

	| movie person |
	
	movie := SlotExampleMovie named: 'Jaws'.
	person := SlotExamplePerson named: 'Peter'.
	
	person directedMovies add: movie.
	self assert: movie director equals: person.
	self assert: person directedMovies size equals: 1.
	self assert: person directedMovies anyOne equals: movie.! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testSetMovieDirector

	| movie person |
	
	movie := SlotExampleMovie named: 'Jaws'.
	person := SlotExamplePerson named: 'Peter'.
	
	movie director: person.
	self assert: movie director equals: person.
	self assert: person directedMovies size equals: 1.
	self assert: person directedMovies anyOne equals: movie! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testSetMovieDirectorInvalid

	| movie |
	
	movie := SlotExampleMovie named: 'Jaws'.
	
	self should: [ movie director: 'not-a-person' ] raise: Error.
	self assert: movie director isNil! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testAddMovieDirectorTwice

	| movie person |
	
	movie := SlotExampleMovie named: 'Jaws'.
	person := SlotExamplePerson named: 'Peter'.
	
	person directedMovies add: movie; add: movie.
	self assert: movie director equals: person.
	self assert: person directedMovies size equals: 1.
	self assert: person directedMovies anyOne equals: movie! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testSetMovieDirectorTwice

	| movie person |
	
	movie := SlotExampleMovie named: 'Jaws'.
	person := SlotExamplePerson named: 'Peter'.
	
	movie director: person; director: person.
	self assert: movie director equals: person.
	self assert: person directedMovies size equals: 1.
	self assert: person directedMovies anyOne equals: movie! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testNewMovie
	| movie |
	movie := SlotExampleMovie new.
	self assert: movie name isNil.
	self assert: movie director isNil.
	self assert: movie actors isCollection.
	self assertEmpty: movie actors! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testSetAndRemoveMovieDirector
	| movie person |
	movie := SlotExampleMovie named: 'Jaws'.
	person := SlotExamplePerson named: 'Peter'.

	movie director: person.
	self assert: movie director equals: person.
	self assert: person directedMovies anyOne equals: movie.

	person directedMovies remove: movie.
	self assert: movie director isNil.
	self assertEmpty: person directedMovies! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testSetAndUnsetMovieDirector
	| movie person |
	movie := SlotExampleMovie named: 'Jaws'.
	person := SlotExamplePerson named: 'Peter'.

	movie director: person.
	self assert: movie director equals: person.
	self assert: person directedMovies anyOne equals: movie.

	movie director: nil.
	self assert: movie director isNil.
	self assertEmpty: person directedMovies! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testAddMovieDirectorInvalid

	| person |
	
	person := SlotExamplePerson named: 'Peter'.
	
	self should: [ person directedMovies add: 'not-a-movie' ] raise: Error! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testChangeMovieDirector
	| movie p1 p2 |
	movie := SlotExampleMovie named: 'Jaws'.
	p1 := SlotExamplePerson named: 'P1'.
	p2 := SlotExamplePerson named: 'P2'.

	movie director: p1.
	self assert: movie director equals: p1.
	self assert: p1 directedMovies anyOne equals: movie.
	self assertEmpty: p2 directedMovies.

	movie director: p2.
	self assert: movie director equals: p2.
	self assertEmpty: p1 directedMovies.
	self assert: p2 directedMovies anyOne equals: movie! !

!SlotExampleMovieAndPersonTest methodsFor: 'tests' stamp: ''!
testAddActors

	| m1 m2 p1 p2 |
	
	m1 := SlotExampleMovie named: 'M1'.
	m2 := SlotExampleMovie named: 'M2'.
	p1 := SlotExamplePerson named: 'P1'.
	p2 := SlotExamplePerson named: 'P2'.
	
	m1 addActor: p1; addActor: p2.
	self assert: m1 actors size equals: 2.
	self assert: p1 actedInMovies size equals: 1.
	self assert: p1 actedInMovies anyOne equals: m1.
	self assert: p2 actedInMovies anyOne equals: m1.
	
	m2 addActor: p2.
	self assert: p2 actedInMovies size equals: 2
! !

!SlotExamplePerson commentStamp: ''!
A SlotExamplePerson is an example class to demonstrate the workings of relation slots.!
!SlotExamplePerson methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self class initializeSlots: self! !

!SlotExamplePerson methodsFor: 'accessing' stamp: ''!
actedInMovies
	^ actedInMovies! !

!SlotExamplePerson methodsFor: 'accessing' stamp: ''!
name
	
	^name! !

!SlotExamplePerson methodsFor: 'accessing' stamp: ''!
directedMovies
	^ directedMovies! !

!SlotExamplePerson methodsFor: 'accessing' stamp: ''!
actedInMovies: anObject
	actedInMovies := anObject! !

!SlotExamplePerson methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!SlotExamplePerson methodsFor: 'accessing' stamp: ''!
directedMovies: anObject
	directedMovies := anObject! !

!SlotExamplePerson class methodsFor: 'instance creation' stamp: ''!
named: aString
	^ self new
		name: aString;
		yourself! !

!SlotIntegrationTest commentStamp: ''!
I'm a test case of SlotClassBuilder integration in the system. Typically, my tests assert over Class API.!
!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testAddAndAddInstVarNamedWithTrait2
	"Add instance variables using the builder interface"
	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			traitComposition: TOne;
			slots: #( x )
		].

	self assertTraitIntegrity.
	self assert: aClass instVarNames equals: #(x).
	
	self assert: TOne traitUsers asArray equals: { aClass }.
	
	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1.

	aClass addInstVarNamed: #y.
	self assertTraitIntegrity.
	aClass addInstVarNamed: #z.
	
	self assert: aClass instVarNames equals: #(x y z).
	
	self assert: TOne traitUsers asArray equals: { aClass }.
	
	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testReshapeClassWithClassSlot
					
	aClass := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: self aClassName;
			package: self aCategory ].		
				
	aClass class 
		instanceVariableNames: #x.
	
	self assert: aClass class instVarNames equals: #(x).
	
	aClass := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: self aClassName;
			slots: 'x' asSlotCollection;
			package: self aCategory ].	
			
	self assert: aClass class instVarNames equals: #(x).! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testAddAndRemoveInstVarNamedWithTrait2
	"Add instance variables using the builder interface"
	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			traitComposition: TOne;
			slots: #( x )
		].
	
	self assertTraitIntegrity.
	self assert: aClass instVarNames equals: #(x).
	
	self assert: TOne traitUsers asArray equals: { aClass }.
	
	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1.

	aClass addInstVarNamed: #y.
	self assertTraitIntegrity.
	aClass	removeInstVarNamed: #x.
	
	self assert: aClass instVarNames equals: #(y).
	
	self assert: TOne traitUsers asArray equals: { aClass }.
	
	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testSlotScopeParallelism
	"Proposed by Camille Teruel"

	| classesAndMetaclasses candidates classWithWrongSlotScope |
	classesAndMetaclasses := Smalltalk allClasses flatCollect: [ :each | { each. each class } ].

	candidates := classesAndMetaclasses reject: [ :each | 
		each superclass isNil or: [ 
			each classLayout slotScope isKindOf: LayoutEmptyScope ] ].

	classWithWrongSlotScope := candidates reject: [ :each | 
		each superclass classLayout slotScope == each classLayout slotScope parentScope ].

	self assert: classWithWrongSlotScope asArray equals: #()! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testSlotsAreInitializedWithDefiningAnonimousClass
	"All slots should include reference to defining class"
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			slots: #(x)
		].
	self assert: aClass slots first owningClass equals: aClass.
	
	aClass addInstVarNamed: 'y'.
	self assert: aClass slots size equals: 2.
	self assert: (aClass slots collect: #owningClass as: Set) equals: {aClass} asSet! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testRemoveInstVarNamedWithTrait2
	"Add instance variables using the builder interface"

	aClass := self
		make: [ :builder | 
			builder
				name: self aClassName;
				traitComposition: TOne;
				slots: #(x) ].

	self assert: aClass instVarNames equals: #(x).

	self assert: TOne traitUsers asArray equals: {aClass}.

	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1.

	aClass removeInstVarNamed: #x.

	self assertEmpty: aClass instVarNames.

	self assert: TOne traitUsers asArray equals: {aClass}.

	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testReshapeClassPropagatesToDeepHierarchyClassInterface
	"Test reshaping a class which is head of a hierarchy of 4 levels"

	"level 1"

	aClass := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: self aClassName;
			package: self aCategory ].

	self assertEmpty: aClass subclasses.
	aClass classLayout checkIntegrity.

	anotherClass := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: self anotherClassName;
			superclass: aClass;
			package: self aCategory ].

	self assert: aClass subclasses equals: {anotherClass}.
	self assertEmpty: anotherClass subclasses.
	aClass classLayout checkIntegrity.
	anotherClass classLayout checkIntegrity.

	yetAnotherClass := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: self yetAnotherClassName;
			superclass: anotherClass;
			package: self aCategory ].


	self assert: aClass subclasses equals: {anotherClass}.
	self assert: anotherClass subclasses equals: {yetAnotherClass}.
	self assertEmpty: yetAnotherClass subclasses.
	aClass classLayout checkIntegrity.
	anotherClass classLayout checkIntegrity.
	yetAnotherClass classLayout checkIntegrity.

	"level 4"
	yetYetAnotherClass := yetAnotherClass
		subclass: self yetYetAnotherClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: self aCategory.

	self assert: aClass subclasses equals: {anotherClass}.
	self assert: anotherClass subclasses equals: {yetAnotherClass}.
	self assert: yetAnotherClass subclasses equals: {yetYetAnotherClass}.
	self assertEmpty: yetYetAnotherClass subclasses.
	aClass classLayout checkIntegrity.
	anotherClass classLayout checkIntegrity.
	yetAnotherClass classLayout checkIntegrity.
	yetYetAnotherClass classLayout checkIntegrity.

	"reshape level 1"
	aClass := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: self aClassName;
			slots: 'x' asSlotCollection;
			package: self aCategory ].

	self assert: aClass instVarNames equals: #(x).
	aClass classLayout checkIntegrity.
	anotherClass classLayout checkIntegrity.
	yetAnotherClass classLayout checkIntegrity.
	yetYetAnotherClass classLayout checkIntegrity! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testAddInstVarNamedWithTrait
	"Add instance variables using the builder interface"

	aClass := self
		make: [ :builder | 
			builder
				name: self aClassName;
				traitComposition: TOne;
				slots: #(x) ].
	self assertTraitIntegrity.
	self assert: aClass instVarNames equals: #(x).

	self assert: TOne traitUsers asArray equals: {aClass}.

	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1.

	aClass := self
		make: [ :builder | 
			builder
				name: self aClassName;
				traitComposition: TOne;
				slots: #(x y) ].

	self assertTraitIntegrity.
	self assert: aClass instVarNames equals: #(x y).

	self assert: TOne traitUsers asArray equals: {aClass}.

	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testSmallIntegerLayout
	self assert: (SmallInteger classLayout isKindOf: ImmediateLayout)! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testRemoveInstVarNamedClassInterface

	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			slots: #(x y z) 
		].
	aClass removeInstVarNamed: #y.

	self assert: aClass instVarNames equals: #(x z).! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testAddInstVarNamed
	"Add instance variables using the builder interface"
	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			slots: #( x )
		].

	self assert: aClass instVarNames equals: #(x).	


	anotherClass := self make: [ :builder |
		builder 
			superclass: aClass;
			name: self anotherClassName;
			slots: #( y )
		].
	
	self assert: anotherClass instVarNames equals: #(y).! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testCompiledMethodLayout
	self assert: (CompiledMethod classLayout isKindOf: CompiledMethodLayout)! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testAddInstVarNamedClassInterface

	"Add instance variables using the class interface"
	
	aClass := self make: [ :builder |
		builder name: self aClassName 
		].
	aClass addInstVarNamed: 'x'.

	self assert: aClass instVarNames equals: #(x).	


	anotherClass := self make: [ :builder |
		builder 
			superclass: aClass;
			name: self anotherClassName.
		].
	anotherClass addInstVarNamed: 'y'.
	
	self assert: anotherClass instVarNames equals: #(y)! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testRemoveInstVarNamed

	| answer |

	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			slots: #(a) 
		].

	answer := 
		aClass 
			slotNamed: 'a' 
			ifFound: [ #found ] 
			ifNone: [ #none ].
	self assert: answer equals: #found.

	answer := 
		aClass 
			slotNamed: 'b' 
			ifFound: [ #found ] 
			ifNone: [ #none ].
	self assert: answer equals: #none
! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testAddInstVarNamedWithTrait2
	"Add instance variables using the builder interface"
	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			traitComposition: TOne;
			slots: #( x )
		].

	self assertTraitIntegrity.
	self assert: aClass instVarNames equals: #(x).
	
	self assert: TOne traitUsers asArray equals: { aClass }.
	
	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1.

	aClass addInstVarNamed: #y.
	
	self assertTraitIntegrity.
	self assert: aClass instVarNames equals: #(x y).
	
	self assert: TOne traitUsers asArray equals: { aClass }.
	
	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testSlotNamedIfFoundIfNone

	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			slots: #(a) 
		].

	self 
		assert: (aClass slotNamed: 'a' ifFound: [ #found ] ifNone: [ #none ])
		equals: #found.

	self 
		assert: (aClass slotNamed: 'b' ifFound: [ #found ] ifNone: [ #none ])
		equals: #none
! !

!SlotIntegrationTest methodsFor: 'tests' stamp: ''!
testAnonymousSubclass
	aClass := self
		make: [ :builder | 
			builder
				name: self aClassName;
				slots: #(x) ].

	anotherClass := aClass newAnonymousSubclass.
	self deny: anotherClass identicalTo: aClass.
	self assert: anotherClass isBehavior.
	self assert: anotherClass superclass identicalTo: aClass.
	self deny: anotherClass name equals: aClass name.
	self assert: anotherClass allInstVarNames equals: #(x)! !

!SlotLayoutEqualityTest methodsFor: 'helpers' stamp: ''!
assertClassBuiltWith: blockToBuildAClass isNotEqualToClassBuiltWith: blockToBuildAnotherClass
		
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			in: blockToBuildAClass ].
		
	anotherClass := self make: [ :builder | 
		builder 
			name: self anotherClassName;
			in: blockToBuildAnotherClass ].
	
	self assert: aClass classLayout ~= anotherClass classLayout.
	self assert: aClass classLayout hash ~= anotherClass classLayout hash! !

!SlotLayoutEqualityTest methodsFor: 'tests' stamp: ''!
testLayoutNotEquals
 
	self layoutClasses do: [:aLayoutClass |
		(self layoutClasses copyWithout: aLayoutClass) do: [:anotherLayoutClass |
			self 
				assertClassBuiltWith: [:builder | builder layoutClass: aLayoutClass ] 
				isNotEqualToClassBuiltWith: [:builder | builder layoutClass: anotherLayoutClass ]]]! !

!SlotLayoutEqualityTest methodsFor: 'tests' stamp: ''!
testLayoutEquals

	self layoutClasses do: [:aLayoutClass |
		self 
			assertClassBuiltWith: [:builder | builder layoutClass: aLayoutClass ] 
			isEqualToClassBuiltWith: [:builder | builder layoutClass: aLayoutClass ] ]! !

!SlotLayoutEqualityTest methodsFor: 'tests' stamp: ''!
testLayoutWithSlotsEquals

	self layoutClassesWithSlots do: [:aLayoutClass |
		self 
			assertClassBuiltWith: [:builder | 
				builder 
					layoutClass: aLayoutClass;
					slots: { #field1}  ]
			isEqualToClassBuiltWith: [:builder | 
				builder 
					layoutClass: aLayoutClass;
					slots: { #field1}  ]]! !

!SlotLayoutEqualityTest methodsFor: 'tests' stamp: ''!
testLayoutWithSlotsNotEquals

	self layoutClassesWithSlots do: [:aLayoutClass |
		self 
			assertClassBuiltWith: [:builder | 
				builder 
					layoutClass: aLayoutClass;
					slots: { #field1}  ]
			isNotEqualToClassBuiltWith: [:builder | 
				builder 
					layoutClass: aLayoutClass;
					slots: { #field2}  ]]! !

!SlotLayoutEqualityTest methodsFor: 'helpers' stamp: ''!
assertClassBuiltWith: blockToBuildAClass isEqualToClassBuiltWith: blockToBuildAnotherClass
	
	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			in: blockToBuildAClass ].
		
	anotherClass := self make: [ :builder | 
		builder 
			name: self anotherClassName;
			in: blockToBuildAnotherClass ].
	
	self assert: aClass classLayout equals: aClass classLayout.	
	self assert: aClass classLayout equals: anotherClass classLayout.
	self assert: aClass classLayout hash equals: anotherClass classLayout hash! !

!SlotLayoutExtensionTest methodsFor: 'tests - valid extensions' stamp: ''!
testPointerWithVariableExtensionIsNowVariable
	"This test case reproduces a real bug."

	| superclass subclass |
	superclass := self make: [ :builder | 
		builder 
			superclass: Object;
			name: self aClassName ].

	subclass := self make: [ :builder | 
		builder 
			superclass: superclass;
			layoutClass: VariableLayout;
			name: self anotherClassName ].

	superclass := self make: [ :builder | 
		builder layoutClass: VariableLayout ].

	self assert: superclass isVariable.
	self assert: subclass isVariable.! !

!SlotLayoutExtensionTest methodsFor: 'tests - invalid extensions' stamp: ''!
testByteCannotExtendPointerWithFields

	self shouldnt: [ :builder | 
			builder 
				layoutClass: FixedLayout;
				slots: { #a }. ]
		extendWith: [ :builder | 
			builder layoutClass: ByteLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - invalid extensions' stamp: ''!
testVariableCannotExtendByte

	self shouldnt: [ :builder | 
			builder layoutClass: ByteLayout ]
		extendWith: [ :builder | 
			builder layoutClass: VariableLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - valid extensions' stamp: ''!
testVariableCanExtendPointer

	self should: [ :builder | 
			builder layoutClass: FixedLayout ]
		extendWith: [ :builder | 
			builder layoutClass: VariableLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - valid extensions' stamp: ''!
testByteCanExtendByte

	self should: [ :builder | 
			builder layoutClass: ByteLayout ]
		extendWith: [ :builder | 
			builder layoutClass: ByteLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'helpers' stamp: ''!
shouldnt: superclassBlock extendWith: subclassBlock

	| superclass |
	superclass := self make: superclassBlock.

	self should: [
		self make: [ :builder | 
			builder 
				superclass: superclass;
				name: self anotherClassName;
				in: subclassBlock ] ]
		raise: IncompatibleLayoutConflict! !

!SlotLayoutExtensionTest methodsFor: 'tests - valid extensions' stamp: ''!
testPointerCanExtendPointer

	self should: [ :builder | 
			builder layoutClass: FixedLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'helpers' stamp: ''!
should: superclassBlock extendWith: subclassBlock

	| superclass |
	superclass := self make: superclassBlock.

	self make: [ :builder | 
		builder 
			superclass: superclass;
			name: self anotherClassName;
			in: subclassBlock ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - invalid extensions' stamp: ''!
testVariableCannotExtendWord

	self shouldnt: [ :builder | 
			builder layoutClass: WordLayout ]
		extendWith: [ :builder | 
			builder layoutClass: VariableLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - valid extensions' stamp: ''!
testVariableCanExtendVariable

	self should: [ :builder | 
			builder layoutClass: VariableLayout ]
		extendWith: [ :builder | 
			builder layoutClass: VariableLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - invalid extensions' stamp: ''!
testWordCannotExtendPointerWithFields

	self shouldnt: [ :builder | 
			builder 
				layoutClass: FixedLayout;
				slots: { #a } ]
		extendWith: [ :builder | 
			builder layoutClass: WordLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - valid extensions' stamp: ''!
testCompiledMethodCanBeExtended

	self should: [ :builder | 
			builder layoutClass: CompiledMethodLayout ]
		extendWith: [ :builder | 
			builder layoutClass: CompiledMethodLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - valid extensions' stamp: ''!
testWordCanExtendWord

	self should: [ :builder | 
			builder layoutClass: WordLayout ]
		extendWith: [ :builder | 
			builder layoutClass: WordLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - invalid extensions' stamp: ''!
testInstanceVariableNamesMetaclassInterface
	"Add instance variables using the Metaclass interface"
	
	aClass := self make: [ :builder |
		builder name: self aClassName ].
	aClass class instanceVariableNames: 'x'.

	self assert: aClass class instVarNames equals: #(x).	

	anotherClass := self make: [ :builder |
		builder 
			superclass: aClass;
			name: self anotherClassName ].
	anotherClass class instanceVariableNames: 'y'.
	
	self assert: anotherClass class instVarNames equals: #(y).	
	self assert: (anotherClass class allInstVarNames includesAll: #(x y)).! !

!SlotLayoutExtensionTest methodsFor: 'tests - invalid extensions' stamp: ''!
testWordCannotExtendByte

	self shouldnt: [ :builder | 
			builder layoutClass: ByteLayout ]
		extendWith: [ :builder | 
			builder layoutClass: WordLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - invalid extensions' stamp: ''!
testByteCannotExtendWord

	self shouldnt: [ :builder | 
			builder layoutClass: WordLayout ]
		extendWith: [ :builder | 
			builder layoutClass: ByteLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - invalid extensions' stamp: ''!
testPointerCannotExtendByte

	self shouldnt: [ :builder | 
			builder layoutClass: ByteLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - invalid extensions' stamp: ''!
testPointerCannotExtendWord

	self shouldnt: [ :builder | 
			builder layoutClass: WordLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests - valid extensions' stamp: ''!
testPointerCanExtendVariable

	self should: [ :builder | 
			builder layoutClass: VariableLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotMethodRecompilationTest methodsFor: 'accessing' stamp: ''!
method
	^ class >> #m1! !

!SlotMethodRecompilationTest methodsFor: 'tests' stamp: ''!
reshapeClass
	^ class := self
		make: [ :builder | 
			builder fillFor: class.
			builder slots: #(#iv) ]! !

!SlotMethodRecompilationTest methodsFor: 'tests' stamp: ''!
testClassReshapeShouldKeepClassBindingForTraitMethods
	"A method should have the same binding than its class even if it come from a trait"

	self reshapeClass.
	self assert: self traitMethodBinding identicalTo: class binding! !

!SlotMethodRecompilationTest methodsFor: 'accessing' stamp: ''!
methodBinding
	^ self method classBinding! !

!SlotMethodRecompilationTest methodsFor: 'accessing' stamp: ''!
traitMethod
	^ class >> #one! !

!SlotMethodRecompilationTest methodsFor: 'tests' stamp: ''!
testClassReshapeShouldKeepClassBinding
	"Check that when a class is reshaped, the recompilation of the methods gives correct class bindings (in the literal array of the methods)"

	self reshapeClass.
	self assert: self methodBinding identicalTo: class binding! !

!SlotMethodRecompilationTest methodsFor: 'accessing' stamp: ''!
traitMethodBinding
	^ self traitMethod classBinding! !

!SlotMethodRecompilationTest methodsFor: 'tests' stamp: ''!
testTraitMethodClassBindingShouldBeClassBinding
	"A method should have the same binding than its class even if it come from a trait"

	self assert: self traitMethodBinding identicalTo: class binding! !

!SlotMethodRecompilationTest methodsFor: 'tests' stamp: ''!
testMethodClassBindingShouldBeClassBinding
	"A method should have the same binding than its class"

	self assert: self methodBinding identicalTo: class binding! !

!SlotMethodRecompilationTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	class := self make: [ :builder |
		builder traitComposition: TOne ].
	class compile: 'm1'
	! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testAddSharedVariableKeepSubclasses
	"Reproduces fogbugz case 13028"

	"Define original hierarchy"

	aClass := self
		make: [ :builder | 
			builder
				name: self aClassName;
				superclass: Object ].

	anotherClass := self
		make: [ :builder | 
			builder
				name: self anotherClassName;
				superclass: aClass ].

	self assert: aClass subclasses size equals: 1.
	self assert: aClass subclasses anyOne identicalTo: anotherClass.

	"Add a shared variable"
	aClass := self
		make: [ :builder | 
			builder
				name: self aClassName;
				superclass: Object;
				sharedVariablesFromString: 'Var' ].

	self assert: aClass subclasses size equals: 1.
	self assert: aClass subclasses anyOne identicalTo: anotherClass! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testAddSlotAndMigrate
	"We create a class without slots and create an instance; then we add a slot and check the instance can hold a value."
	aClass := self makeWithLayout: FixedLayout.
	
	instance := aClass new.
	
	"now we extend it with slots.  The class definition should've changed"
	self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	
	"it should have an instance variable"
	instance instVarAt: 1 put: 125.
	aClass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testAddTestSlot
	"We create a class without slots and create an instance; then we add a slot and check the instance can hold a value."
	aClass := self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	
	instance := aClass new.
	instance instVarAt: 1 put: 125.
	"now we extend it with a test slots.  The class definition should've changed"
	self makeWithLayout: FixedLayout andSlots: {#anotherSlot => ExampleSlotWithState. #aSlot. }.
	
	"It should not have move the first instance as TestSlot size = 0"
	self assert: (instance instVarAt: 1) equals: 125.
	aClass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testRedefineSuperclass
	"This case reproduces a MNU found loading Moose."

	| superclass class |
	superclass := self makeWithLayout: FixedLayout.
	class := self make: [ :builder |
		builder 
			superclass: superclass;
			layoutClass: ByteLayout;
			name: self anotherClassName.
		 ].

	self makeWithLayout: FixedLayout.

	superclass classLayout checkIntegrity.
	class classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testChangeLayoutTypeFromByte

	aClass := self makeWithLayout: ByteLayout.
	"Change the layout of the class from bytes to pointer"
	aClass := self 
		makeWithLayout: FixedLayout 
		andSlots: { #id. #name }.
	
	aClass classLayout checkIntegrity.
	
	self deny: aClass classLayout isBits.
	self assert: aClass instVarNames equals: { #id. #name }! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testRemoveTestSlot
	aClass := self makeWithLayout: FixedLayout andSlots: {#anotherSlot => ExampleSlotWithState. #aSlot }.
	
	instance := aClass new.
	instance instVarAt: 1 put: 125.
	"now we remove the TestSlot from the class definition. As testSlot has a size of 0, the object should not change."
	self makeWithLayout: FixedLayout andSlots: {#aSlot. }.
	

	self assert: (instance instVarAt: 1) equals: 125.
	aClass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testMigrateTestSlot
	"We create a class with a Test slot, so its  value is shared between instances"
	| instance2 |
	aClass := self makeWithLayout: FixedLayout andSlots: { #aSlot => ExampleSlotWithState. }.
	
	instance := aClass new.
	instance2 := aClass new.
	(aClass slotNamed: #aSlot) write: 125 to: instance2.
	"now we change the TestSlot with a InstanceVariableSlot. Both instances should both shared the same value in this slot."
	self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	
	self assert: ((aClass slotNamed: #aSlot) read: instance) equals: 125.
	self assert: ((aClass slotNamed: #aSlot) read: instance2) equals: 125.
	aClass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testReshapeSuperSuperClass
	| supersuperclass superclass subclass |
	supersuperclass := self
		make: [ :builder | 
			builder
				superclass: Object;
				name: self aClassName;
				slots: #(a b) ].

	self assertEmpty: supersuperclass subclasses.
	supersuperclass classLayout checkIntegrity.

	superclass := self
		make: [ :builder | 
			builder
				superclass: supersuperclass;
				name: self anotherClassName ].

	self assert: supersuperclass subclasses equals: {superclass}.
	self assertEmpty: superclass subclasses.
	superclass classLayout checkIntegrity.
	supersuperclass classLayout checkIntegrity.

	subclass := self
		make: [ :builder | 
			builder
				superclass: superclass;
				name: self yetAnotherClassName;
				slots: #(c d) ].

	self assert: supersuperclass subclasses equals: {superclass}.
	self assert: superclass subclasses equals: {subclass}.
	self assertEmpty: subclass subclasses.
	subclass classLayout checkIntegrity.
	superclass classLayout checkIntegrity.
	supersuperclass classLayout checkIntegrity.

	"reshape the super super class"
	supersuperclass := self
		make: [ :builder | 
			builder
				superclass: Object;
				name: self aClassName;
				slots: #(a b a2) ].

	self assert: supersuperclass subclasses equals: {superclass}.
	self assert: superclass subclasses equals: {subclass}.
	self assertEmpty: subclass subclasses.
	subclass classLayout checkIntegrity.
	superclass classLayout checkIntegrity.
	supersuperclass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testShiftSlotAndMigrate

	aClass := self makeWithLayout: FixedLayout andSlots: { #a. #c }.
	aClass compile: 'a ^a'.
	aClass compile: 'c ^c'.
	
	instance := aClass new.
	instance instVarNamed: #a put: 1.
	instance instVarNamed: #c put: 3.

	"now we extend it with slots.  The class definition should've changed"
	self makeWithLayout: FixedLayout andSlots: { #a. #b. #c }.

	"it should have added an instance variable with nil in the middle"
	self assert: (instance instVarAt: 1) equals: 1.
	self assert: (instance instVarAt: 2) equals: nil.
	self assert: (instance instVarAt: 3) equals: 3.
	
	self assert: (instance instVarNamed: #a) equals: 1.
	self assert: (instance instVarNamed: #b) equals: nil.
	self assert: (instance instVarNamed: #c) equals: 3.
	
	"it should have migrated methods"
	self assert: instance a equals: 1.
	self assert: instance c equals: 3.
	aClass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testReshapeClassPropagatesToDeepHierarchy
	"Test reshaping a class which is head of a hierarchy of 4 levels"

	"level 1"

	aClass := self make: [ :builder | builder name: self aClassName ].

	self assertEmpty: aClass subclasses.
	aClass classLayout checkIntegrity.

	"level 2"
	anotherClass := self
		make: [ :builder | 
			builder
				superclass: aClass;
				name: self anotherClassName ].

	self assert: aClass subclasses equals: {anotherClass}.
	self assertEmpty: anotherClass subclasses.
	aClass classLayout checkIntegrity.
	anotherClass classLayout checkIntegrity.

	"level 3"
	yetAnotherClass := self
		make: [ :builder | 
			builder
				superclass: anotherClass;
				name: self yetAnotherClassName ].

	self assert: aClass subclasses equals: {anotherClass}.
	self assert: anotherClass subclasses equals: {yetAnotherClass}.
	self assertEmpty: yetAnotherClass subclasses.
	aClass classLayout checkIntegrity.
	anotherClass classLayout checkIntegrity.
	yetAnotherClass classLayout checkIntegrity.

	"level 4"
	yetYetAnotherClass := self
		make: [ :builder | 
			builder
				superclass: yetAnotherClass;
				name: self yetYetAnotherClassName ].


	self assert: aClass subclasses equals: {anotherClass}.
	self assert: anotherClass subclasses equals: {yetAnotherClass}.
	self assert: yetAnotherClass subclasses equals: {yetYetAnotherClass}.
	self assertEmpty: yetYetAnotherClass subclasses.
	aClass classLayout checkIntegrity.
	anotherClass classLayout checkIntegrity.
	yetAnotherClass classLayout checkIntegrity.
	yetYetAnotherClass classLayout checkIntegrity.

	"reshape level 1"
	aClass := self
		make: [ :builder | 
			builder
				name: self aClassName;
				slots: #(x) ].

	aClass classLayout checkIntegrity.
	anotherClass classLayout checkIntegrity.
	yetAnotherClass classLayout checkIntegrity.
	yetYetAnotherClass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testSuperclassChangeLayoutType
	"This case reproduces a MNU found loading Moose."

	| superclass class |
	superclass := self makeWithLayout: ByteLayout.
	class := self make: [ :builder |
		builder 
			superclass: superclass;
			layoutClass: ByteLayout;
			name: self anotherClassName.
		 ].
	"Change the layout of the superclass from bytes to pointer"
	self makeWithLayout: FixedLayout.

	superclass classLayout checkIntegrity.
	class classLayout checkIntegrity.
	
	self deny: superclass classLayout isBits.
	self assert: class classLayout isBits! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testSwitchSlotsAndMigrate

	aClass := self makeWithLayout: FixedLayout andSlots: { #a. #b }.
	aClass 
		compile: 'a ^a';
		compile: 'b ^b'.

	instance := aClass new.
	instance instVarNamed: #a put: $A.
	instance instVarNamed: #b put: $B.

	"now we switch the slots. The class definition should've changed"
	self makeWithLayout: FixedLayout andSlots: { #b. #a }.

	self assert: (instance instVarAt: 1) equals: $B.
	self assert: (instance instVarAt: 2) equals: $A.
	
	self assert: (instance instVarNamed: #a) equals: $A.
	self assert: (instance instVarNamed: #b) equals: $B.

	"it should have migrated methods"
	self assert: instance a equals: $A.
	self assert: instance b equals: $B.
	aClass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testRemoveSlotAndMigrate
	"We create a class with a slot and create an instance; then we remove the slot and check the instance doesn't hold the value."
	aClass := self makeWithLayout: FixedLayout andSlots: { #aSlot }.

	instance := aClass new.
	"it should have an instance variable"
	instance instVarAt: 1 put: 125.
	
	"now we extend it with slots.  The class definition should've changed"
	self makeWithLayout: FixedLayout.
	
	self should: [ instance instVarAt: 1 ] raise: Error.
	aClass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testAddSlotPropagateAndMigrate
	"We create a class without slots and a subclass, and create an instance of the latter; then we add a slot to superclass and check the instance can hold a value."

	| superclass subclass |
	superclass := self makeWithLayout: FixedLayout.
	subclass := self make: [ :builder |
		builder 
			superclass: superclass;
			name: self anotherClassName.
		 ].
	
	superclass classLayout checkIntegrity.
	subclass classLayout checkIntegrity.
	
	instance := subclass new.
	
	"now we extend it with slots.  The class definition should've changed"
	superclass := self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	
	"it should have an instance variable"
	instance instVarNamed: 'aSlot' put: 42.
	self assert: (instance instVarNamed: 'aSlot') equals: 42.
	superclass classLayout checkIntegrity.
	subclass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testChangeSuperclass
	"Define original hierarchy"

	aClass := self
		make: [ :builder | 
			builder
				name: self aClassName;
				superclass: Object ].

	anotherClass := self
		make: [ :builder | 
			builder
				name: self anotherClassName;
				superclass: aClass ].

	self assert: aClass subclasses size equals: 1.
	self assert: aClass subclasses anyOne identicalTo: anotherClass.
	self assert: anotherClass superclass identicalTo: aClass.

	"Change to a new superclass"
	yetAnotherClass := self
		make: [ :builder | 
			builder
				name: self yetAnotherClassName;
				superclass: Object ].

	anotherClass := self
		make: [ :builder | 
			builder
				name: self anotherClassName;
				superclass: yetAnotherClass ].

	self assertEmpty: aClass subclasses.
	self assert: yetAnotherClass subclasses size equals: 1.
	self assert: yetAnotherClass subclasses anyOne identicalTo: anotherClass.
	self assert: anotherClass superclass identicalTo: yetAnotherClass! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testReshapePointerToByteVariablePropagatesToDeepHierarchy

	"create the original hierarchy"
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: FixedLayout ]. 

	anotherClass := self make: [ :builder |
		builder 
			name:self anotherClassName;
			superclass: aClass;
			layoutClass: FixedLayout ].

	yetAnotherClass := self make: [ :builder |
		builder 
			name:self yetAnotherClassName;
			superclass: anotherClass;
			layoutClass: FixedLayout ].

	yetYetAnotherClass := self make: [ :builder |
		builder 
			name:self yetYetAnotherClassName;
			superclass: yetAnotherClass;
			layoutClass: FixedLayout ].

	"all the classes in the hierarchy should be of type fixed pointers"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each classLayout checkIntegrity.
		self assert: each isFixed.
		self assert: each isPointers. ].
	
	"change the top superclass"	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: ByteLayout ]. 

	"all the classes in the hierarchy should be reshaped as fixed"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each classLayout checkIntegrity.
		self assert: each isVariable description: each name, ' was not reshaped.'.
		self assert: each isBytes description: each name, ' was not reshaped.' ]! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testChangingFormatKeepsMethod

	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			layoutClass: FixedLayout ].

	aClass compile: 'a ^self'.
	self assert: (aClass methodDictionary includesKey: #a).
	
	anotherClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			layoutClass: VariableLayout .
			].

	self assert: (anotherClass methodDictionary includesKey: #a).
	aClass classLayout checkIntegrity.
	anotherClass classLayout checkIntegrity! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testChangeLayoutTypeToByte
	aClass := self makeWithLayout: FixedLayout andSlots: {#id . #name}.
	"Change the layout of the class from pointer to bytes"
	aClass := self makeWithLayout: ByteLayout.

	aClass classLayout checkIntegrity.

	self assert: aClass classLayout isBits.
	self assertEmpty: aClass instVarNames! !

!SlotMigrationTest methodsFor: 'tests' stamp: ''!
testReshapeByteVariableToPointerPropagatesToDeepHierarchy

	"create the original hierarchy"
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: ByteLayout ]. 

	anotherClass := self make: [ :builder |
		builder 
			name:self anotherClassName;
			superclass: aClass;
			layoutClass: ByteLayout ].

	yetAnotherClass := self make: [ :builder |
		builder 
			name:self yetAnotherClassName;
			superclass: anotherClass;
			layoutClass: ByteLayout ].

	yetYetAnotherClass := self make: [ :builder |
		builder 
			name:self yetYetAnotherClassName;
			superclass: yetAnotherClass;
			layoutClass: ByteLayout ].

	"all the classes in the hierarchy should be of type variable byte"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each classLayout checkIntegrity.
		self assert: each isVariable.
		self assert: each isBytes. ].
	
	"change the top superclass"	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: FixedLayout;
			slots: { #x } ]. 

	"all the classes in the hierarchy should be reshaped as fixed"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each classLayout checkIntegrity.
		self assert: each isFixed description: each name, ' was not reshaped.'.
		self assert: each isPointers description: each name, ' was not reshaped.' ]! !

!SlotNotFound commentStamp: ''!
I am an exception to indicate that a slot is found in a layout or in the image.!
!SlotNotFound methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!SlotNotFound methodsFor: 'accessing' stamp: ''!
messageText
	^ 'Could not build slot named ''' , name asString , ''' because the assignated slot was not found in the image.'! !

!SlotNotFound methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!SlotNotFound class methodsFor: 'signalling' stamp: ''!
signalForName: aSymbol
	self new
		name: aSymbol;
		signal! !

!SlotSilentTest commentStamp: ''!
I am an abstract class to silence certain parts of the system while running tests in my subclasses.

Currently this class silences the SystemAnnouncer and sets the Author to the class name when a test is run. 
!
!SlotSilentTest methodsFor: 'compiling' stamp: ''!
compileAccessorsFor: aSlot
	| readerString writerString |
	readerString := String streamContents: [ :str |
		str 
			nextPutAll: aSlot name;
			cr;tab;
			nextPutAll: ' ^';
			nextPutAll: aSlot name.
		 ].
	writerString := String streamContents: [ :str |
		str 
			nextPutAll: aSlot name;
			nextPutAll: ': anObject';
			cr;tab;
			nextPutAll: aSlot name;
			nextPutAll: ':= anObject.'.
		].
	aClass compile: readerString classified: 'accessing'.
	aClass compile: writerString classified: 'accessing'! !

!SlotSilentTest methodsFor: 'running' stamp: ''!
runCase

	SystemAnnouncer uniqueInstance suspendAllWhile: [ 
		Author useAuthor: self class name asString during: [ super runCase ]
	]
! !

!SlotTest commentStamp: ''!
tests for Slots !
!SlotTest methodsFor: 'tests - properties' stamp: ''!
testPropertyAtPut

	| testValue ivar |
	
	testValue := Date today.
	ivar := self class slotNamed: #ivarForTesting.
	
	ivar propertyAt: #testKeySelector put: testValue.
	self
		assert: (ivar propertyAt: #testKeySelector)
		equals: testValue.
	ivar removeProperty: #testKeySelector.
	self assert: ivar properties isNil! !

!SlotTest methodsFor: 'tests - misc' stamp: ''!
testScope
	| variable |
	variable := self class slotNamed: #ivarForTesting.
	self assert: variable scope equals: self class.
	
	self assert: (variable scope lookupVar: variable name) equals: variable! !

!SlotTest methodsFor: 'tests - read/write' stamp: ''!
testWriteToContext 
	
	| slot |
	slot := self class slotNamed: #ivarForTesting.
	slot write: #testValue inContext: thisContext.
	
	self assert: ivarForTesting equals: #testValue! !

!SlotTest methodsFor: 'tests - misc' stamp: ''!
testSlotUsers
	self assert: (ToOneRelationSlot slotUsers includes: SlotExampleMovie).
	self deny: (ToOneRelationSlot slotUsers includes: SlotExamplePerson)! !

!SlotTest methodsFor: 'tests - read/write' stamp: ''!
testIsReadInMethod
	
	ivarForTesting printString.
	self assert: ((self class slotNamed: #ivarForTesting) isReadIn: self class >> testSelector)! !

!SlotTest methodsFor: 'tests - read/write' stamp: ''!
testReadFromContext 
	
	| slot |
	ivarForTesting := #testValue.
	slot := self class slotNamed: #ivarForTesting.
	
	self assert: (slot readInContext: thisContext) equals: #testValue! !

!SlotTest methodsFor: 'tests - misc' stamp: ''!
testisUsed
	self assert: InstanceVariableSlot isUsed.
	self assert: IndexedSlot isUsed. "subclasses are users"
	self assert: ProcessLocalSlot isUsed. "references count as uses, too"! !

!SlotTest methodsFor: 'tests - properties' stamp: ''!
testRemoveProperty
	| ivar | 
	ivar := self class slotNamed: #ivarForTesting.
	
	ivar propertyAt: #testKeySelector put: 1.
		
	ivar removeProperty: #testKeySelector.
	self
		assert: (ivar propertyAt: #testKeySelector)
		equals: nil.
		
	self assert: ivar properties isNil! !

!SlotTest methodsFor: 'tests - read/write' stamp: ''!
testNotReadInMethod
	
	self deny: ((self class slotNamed: #ivarForTesting) isReadIn: self class >> testSelector)! !

!SlotTest methodsFor: 'tests - misc' stamp: ''!
testAsSlotCollection
	
 	self assert: 'a b' asSlotCollection equals: {#a => InstanceVariableSlot. #b => InstanceVariableSlot}.
	self assert: ('a _a a_a b b_' asSlotCollection collect: [ :i | i name ]) equals: #(#a #_a #a_a #b #b_) .
	self should: ['1' asSlotCollection] raise: Error.
	self should: ['ivarA ivarB i%varD iv2arF' asSlotCollection] raise: Error.
	self should: ['iva|rG' asSlotCollection] raise: Error




! !

!SlotTest methodsFor: 'tests - read/write' stamp: ''!
testIsWrittenInMethod
	
	ivarForTesting := #test.
	self assert: ((self class slotNamed: #ivarForTesting) isWrittenIn: self class >> testSelector)! !

!SlotTest methodsFor: 'tests - read/write' stamp: ''!
testNotWrittenInMethodWhenItIsOnlyRead
	
	ivarForTesting printString.
	self deny: ((self class slotNamed: #ivarForTesting) isWrittenIn: self class >> testSelector)! !

!SlotTest methodsFor: 'tests - testing' stamp: ''!
testIsReferenced
	self assert: (Point slotNamed: #x) isReferenced! !

!SlotTraitsTest methodsFor: 'tests' stamp: ''!
testRemoveClassTrait
	"Tests that when removing a trait from class-side, its methods are removed from the method dictionary."

	aClass := self make: [ :builder | builder classTraitComposition: TOne ].

	aClass := self make: [ :builder | builder classTraitComposition: {} ].

	self deny: (aClass class canUnderstand: #one).
	self assertEmpty: TOne traitUsers.
	self assertEmpty: TOne classTrait traitUsers! !

!SlotTraitsTest methodsFor: 'tests' stamp: ''!
testTraitUsersAfterMetaclassReshape

	aClass := self make: [ :builder | 
		builder
			name: self aClassName ].

	anotherClass := self make: [ :builder | 
		builder
			name: self anotherClassName;
			superclass: aClass;
			traitComposition: TOne;
			classTraitComposition: TOne classTrait + TTwo ].
	
	
	self assert: TOne traitUsers asArray            equals: { anotherClass }.
	self assert: TOne classTrait traitUsers asArray equals: { anotherClass class }.
	self assert: TTwo traitUsers asArray            equals: { anotherClass class }.
	self assert: TTwo classTrait traitUsers asArray equals: { }.
	
	self deny: (aClass canUnderstand: #one).
	self assert: (anotherClass canUnderstand: #one).
	self deny: (aClass class canUnderstand: #two).
	self assert: (anotherClass class canUnderstand: #two).
		
	aClass := self make: [ :builder | 
		builder
			name: self aClassName;
			slots: #( x y z ) ].	
	
	self assert: TOne traitUsers asArray            equals: { anotherClass }.
	self assert: TOne classTrait traitUsers asArray equals: { anotherClass class }.
	self assert: TTwo traitUsers asArray            equals: { anotherClass class }.
	self assert: TTwo classTrait traitUsers asArray equals: { }.
	
	self deny: (aClass canUnderstand: #one).
	self assert: (anotherClass canUnderstand: #one).
	self deny: (aClass class canUnderstand: #two).
	self assert: (anotherClass class canUnderstand: #two)

! !

!SlotTraitsTest methodsFor: 'tests' stamp: ''!
testRemoveTrait
	"Tests that when removing a trait from a class, its methods are removed from the method dictionary."

	self make: [ :builder | builder traitComposition: TOne ].

	aClass := self make: [ :builder | builder traitComposition: {} ].

	self assertEmpty: TOne traitUsers.
	self assertEmpty: TOne classTrait traitUsers.
	self deny: (aClass canUnderstand: #one)! !

!SlotTraitsTest methodsFor: 'tests' stamp: ''!
testModifyClassTraitComposition
	"Tests that when modifying the trait composition on class-side, the old methods are removed from the method dictionary, and the new ones are added."

	self make: [ :builder | builder classTraitComposition: TOne ].

	aClass := self make: [ :builder | builder classTraitComposition: TTwo ].

	self assertEmpty: TOne traitUsers.
	self assertEmpty: TOne classTrait traitUsers.
	self assert: TTwo traitUsers asArray equals: {aClass class}.
	self assertEmpty: TTwo classTrait traitUsers.

	self deny: (aClass class canUnderstand: #one).
	self deny: (aClass class canUnderstand: #classOne).
	self assert: (aClass class canUnderstand: #two).
	aClass classLayout checkIntegrity.

	aClass := self make: [ :builder | builder classTraitComposition: {} ].

	self assertEmpty: TOne traitUsers.
	self assertEmpty: TOne classTrait traitUsers.
	self assertEmpty: TTwo traitUsers.
	self assertEmpty: TTwo classTrait traitUsers.
	aClass classLayout checkIntegrity.

	self deny: (aClass canUnderstand: #one).
	self deny: (aClass class canUnderstand: #classOne).
	self deny: (aClass canUnderstand: #two)! !

!SlotTraitsTest methodsFor: 'tests' stamp: ''!
testModifyTraitComposition
	"Tests that when modifying the trait composition, the old methods are removed from the method dictionary, and the new ones are added."

	self make: [ :builder | builder traitComposition: TOne ].

	aClass := self make: [ :builder | builder traitComposition: TTwo ].

	self assertEmpty: TOne traitUsers.
	self assertEmpty: TOne classTrait traitUsers.
	self assert: TTwo traitUsers asArray equals: {aClass}.
	"self assertEmpty: TTwo classTrait traitUsers."
	aClass classLayout checkIntegrity.

	self deny: (aClass canUnderstand: #one).
	self deny: (aClass class canUnderstand: #classOne).
	self assert: (aClass canUnderstand: #two).

	aClass := self make: [ :builder | builder traitComposition: {} ].

	self assertEmpty: TOne traitUsers.
	self assertEmpty: TOne classTrait traitUsers.
	self assertEmpty: TTwo traitUsers.
	self assertEmpty: TTwo classTrait traitUsers.
	aClass classLayout checkIntegrity.

	self deny: (aClass canUnderstand: #one).
	self deny: (aClass class canUnderstand: #classOne).
	self deny: (aClass canUnderstand: #two)! !

!SlotTraitsTest methodsFor: 'tests' stamp: ''!
testClassWithClassTrait
	self assertEmpty: TOne traitUsers.
	self assertEmpty: TOne classTrait traitUsers.

	aClass := self make: [ :builder |  ].
	aClass class setTraitComposition: TOne.

	self assert: TOne traitUsers asArray equals: {aClass class}.
	self assertEmpty: TOne classTrait traitUsers.

	self assert: (aClass class canUnderstand: #one).
	self assert: aClass one equals: 1! !

!SlotTraitsTest methodsFor: 'tests' stamp: ''!
testClassWithTrait
	self assertEmpty: TOne traitUsers.
	self assertEmpty: TOne classTrait traitUsers.

	aClass := self make: [ :builder |  ].
	aClass setTraitComposition: TOne.

	self assert: TOne traitUsers asArray equals: {aClass}.
	self assert: TOne classTrait traitUsers asArray equals: {aClass class}.

	self assert: (aClass canUnderstand: #one).
	self assert: aClass new one equals: 1! !

!SlotTraitsTest methodsFor: 'tests' stamp: ''!
testTraitUsersAfterClassReshape

	aClass := self make: [ :builder | 
		builder
			name: self aClassName ].

	anotherClass := self make: [ :builder | 
		builder
			name: self anotherClassName;
			superclass: aClass;
			traitComposition: TOne;
			classTraitComposition: TOne classTrait + TTwo ].
	
	self assert: TOne traitUsers asArray equals: { anotherClass }.
	self assert: TOne classTrait traitUsers asArray equals: { anotherClass class }.
	self assert: TTwo traitUsers asArray equals: { anotherClass class }.
	self assert: TTwo classTrait traitUsers asArray equals: { }.
	
	self deny: (aClass canUnderstand: #one).
	self assert: (anotherClass canUnderstand: #one).
	self deny: (aClass class canUnderstand: #two).
	self assert: (anotherClass class canUnderstand: #two).
	
	
	"reshape the super class"
	aClass := self make: [ :builder | 
		builder
			name: self aClassName;
			slots: #( x y z )].

			
	self assert: TOne traitUsers asArray equals: { anotherClass }.
	self assert: TOne classTrait traitUsers asArray equals: { anotherClass class }.
	self assert: TTwo traitUsers asArray equals: { anotherClass class }.
	self assert: TTwo classTrait traitUsers asArray equals: { }.
	
	self deny: (aClass canUnderstand: #one).
	self assert: (anotherClass canUnderstand: #one).
	self deny: (aClass class canUnderstand: #two).
	self assert: (anotherClass class canUnderstand: #two).

! !

!SmallDictionary commentStamp: ''!
`SmallDictionary` 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`. Be careful, I cannot have *nil* as key. 

### Public API and Key Messages

- #at: aKey put: aValue / #at: aKey ifAbsentPut: aValue 		allow to add an element.  
- #at: aKey / #at: aKey ifAbsent: aBlock / #at: aKey ifPresent: aBlock ifAbsent: aBlock 		allow to access my values.
- #keysDo: aBlock / #valuesDo: aBlock / #associationsDo: 		allow to iterate on me effectively

### Examples 


To create a dictiony with indexes as key: 

```
SmallDictionary withAll: #(7 3 1 3)   		
">>>  a SmallDictionaryDictionary(1->7 2->3 3->1 4->3 "
```
To use Objects as key (here symbols): 

```
	colors := SmallDictionary new 
				at: #yellow put: Color yellow; 
				at: #blue put: Color blue;
				at: #red put: Color red;
				yourself.
				
	colors at: #yellow. 	"returns:  Color yellow"
	colors keys          		"returns: a Set(#blue #yellow #red)"
	colors values     		"returns:  {Color blue. Color yellow. Color red}"

	colors empty 	"a SmallDictionary()"
```

### Internal Representation and Key Implementation Points.
Instance Variables
- keys:		<Array>		Array of keys (we don't use Associations for our key value pairs)
- size:			<Integer>	Size of the dictionary
- values:		<Array>		Array of our values


    Implementation Points!
!SmallDictionary methodsFor: 'removing' stamp: ''!
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 keysAndValuesDo:
		[:key :value | (keyValueBlock value:  key value:  value)
			ifTrue: [removals add:  key]].
 	removals do:
		[:aKey | self removeKey: aKey]! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
associationAt: key ifPresent: aBlock
	"Answer the value of evaluating aBlock optionally with an association
	for the given key.
	If the key is not found, return nil.

	Modifying the association won't affect the receiver because it
	isn't implemented with associations like Dictionary."

	| index |
	(index := keys indexOf: key) = 0
		ifTrue: [ ^ nil ].
	^ aBlock cull: key -> (values at: index)! !

!SmallDictionary methodsFor: 'testing' stamp: ''!
includes: aValue
	self do: [:each | aValue = each ifTrue: [^true]].
	^false! !

!SmallDictionary methodsFor: 'testing' stamp: ''!
includesAssociation: anAssociation
  ^ (self   
      associationAt: anAssociation key
      ifAbsent: [ ^ false ]) value = anAssociation value! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
at: key ifPresent: aBlock
	"Lookup the given key in the receiver. If it is present, answer the
	value of evaluating the given block optionally with the value associated
	with the key.
	Otherwise, answer nil."

	| v |
	v := self at: key ifAbsent: [^ nil].
	^ aBlock cull: v! !

!SmallDictionary methodsFor: 'testing' stamp: ''!
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! !

!SmallDictionary methodsFor: 'testing' stamp: ''!
isDictionary
	^true! !

!SmallDictionary methodsFor: 'adding' stamp: ''!
declare: key from: aDictionary 
	"Add key to the receiver. If key already exists, do nothing. If aDictionary 
	includes key, then remove it from aDictionary and use its association as 
	the element of the receiver."

	(self includesKey: key) ifTrue: [^ self].
	(aDictionary includesKey: key)
		ifTrue: 
			[self add: (aDictionary associationAt: key).
			aDictionary removeKey: key]
		ifFalse: 
			[self add: key -> nil]! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
associationAt: key 
	"Returns an association for the given key.

	Modifying the association won't affect the receiver because it
	isn't implemented with associations like Dictionary."

	^ self associationAt: key ifAbsent: [self errorKeyNotFound: key]! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
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."
	
	| index |
	index := (values indexOf: value).
	index = 0 
		ifTrue: [ ^ exceptionBlock value].
		
	^ keys at: index.! !

!SmallDictionary methodsFor: 'enumerating' stamp: ''!
do: aBlock

	^ self valuesDo: aBlock.! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
at: key ifAbsentPut: aBlock
	"Return the value at the given key.
	If the key is not included in the receiver store and return the result 
	of evaluating aBlock as the new value."
	
	| index |
	index := self findIndexForKey:  key.
	^ index = 0 
		ifFalse: [values at: index]
		ifTrue: [self privateAt: key put: aBlock value]! !

!SmallDictionary methodsFor: 'enumerating' stamp: ''!
keysAndValuesDo: aBlock
	1 to: size do: [:i | aBlock value: (keys at: i) value: (values at: i)]! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
at: key update: updateBlock initial: initBlocktOrValue
	"I am used to update the value at a given key. The updateBlock is passed 
	the existing value, and the result of the block is stored back.
	If the key does not exist, store the value of the initBlocktOrValue.
	initBlocktOrValue can be a block in case the initial value is expencive to compute.
	I use findElementOrNil: to avoid looking up the key twice."
	| index |
	index := self findIndexForKey: key.
	(index = 0)
		ifTrue:  [ self at: key put: initBlocktOrValue value]
		ifFalse: [ (values at: index) in: [ :val | values at: index put: (updateBlock value: val) ] ]! !

!SmallDictionary methodsFor: 'enumerating' stamp: ''!
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! !

!SmallDictionary methodsFor: 'removing' stamp: ''!
removeKey: key ifAbsent: aBlock 
	"Remove key (and its associated value) from the receiver. If key is not in 
	the receiver, answer the result of evaluating aBlock. Otherwise, answer 
	the value externally named by key."

	| index value |
	index := self findIndexForKey:  key.
	index = 0 ifTrue: [^aBlock value].
	
	value := values at: index.
	index to: size - 1
		do: 
			[:i | 
			keys at: i put: (keys at: i + 1).
			values at: i put: (values at: i + 1)].
	keys at: size put: nil.
	values at: size put: nil.
	size := size - 1.
	^value! !

!SmallDictionary methodsFor: 'private' stamp: ''!
setClass
	^ Set! !

!SmallDictionary methodsFor: 'testing' stamp: ''!
isHealthy
	"Since this dictionary does no hashing, we consider it healthy
	if it contains no duplicate keys."

	| uniqueKeys |
	uniqueKeys := self setClass new: self size.
	keys
		do: [ :each | 
			each
				ifNotNil: [
					(uniqueKeys includes: each)
						ifTrue: [ ^ false ].
					uniqueKeys add: each ] ].
	^ true! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
associationAt: key ifAbsent: aBlock 
	"Answer an association for the given key.
	If the key is not found, return the result of evaluating aBlock.

	Modifying the association won't affect the receiver because it
	isn't implemented with associations like Dictionary."

	| index value |
	index := keys indexOf: key.
	index = 0 ifTrue: [ ^ aBlock value].
	
	value := values at: index.
	^ key->value.! !

!SmallDictionary methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionItems: aBuilder
	<inspectorPresentationOrder: 0 title: 'Items'> 
	
	^ aBuilder newTable 
		addColumn: (SpStringTableColumn 
			title: 'Key'
			evaluated: [ :each | StObjectPrinter asTruncatedTextFrom: each key ])
			beSortable;
		addColumn: (SpStringTableColumn 
			title: 'Value' 
			evaluated: [ :each | StObjectPrinter asTruncatedTextFrom: each value ])
			beSortable;
		items: (self associations collect: [:e | StInspectorAssociationNode hostObject: e ]);
		yourself! !

!SmallDictionary methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	keys := Array new: 2.
	values := Array new: 2.
	size := 0! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
associationAt: key ifPresent: aPresentBlock ifAbsent: anAbsentBlock
	"Lookup the given key in the receiver. If it is present, answer the
	value of evaluating the first block optionally with the association for the key.
	Otherwise answer the value of the second block."

	self associationAt: key ifPresent: [:assoc | ^ aPresentBlock cull: assoc].
	^ anAbsentBlock value! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
keyAtValue: value 
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer nil."

	^self keyAtValue: value ifAbsent: [self errorValueNotFound: value]! !

!SmallDictionary methodsFor: 'putting' stamp: ''!
at: key put: value 
	"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 |
	index := self findIndexForKey:  key.
	^ index = 0
		ifFalse: [values at: index put: value]
		ifTrue: [self privateAt: key put: value]! !

!SmallDictionary methodsFor: 'copying' stamp: ''!
postCopy
	keys := keys copy.
	values := values copy! !

!SmallDictionary methodsFor: 'enumerating' stamp: ''!
valuesDo: aBlock 
	"Evaluate aBlock for each of the receiver's values."

1 to: size do: [:i | aBlock value: (values at: i)]! !

!SmallDictionary methodsFor: 'nested dictionaries' stamp: ''!
at: firstKey at: secondKey put: aValue
	"Set a value at secondKey in the dictionary returned by firstKey."
	
	| subDictionary |
	subDictionary := self at: firstKey ifAbsentPut: [ self species new ].
	^ subDictionary at: secondKey put: aValue! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
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."
 	
	| index |
	index := (values identityIndexOf: value).
	index = 0 
		ifTrue: [ ^ exceptionBlock value].
	^ keys at: index.! !

!SmallDictionary methodsFor: 'removing' stamp: ''!
removeAll
	self initialize.! !

!SmallDictionary methodsFor: 'removing' stamp: ''!
removeKey: key 
	"Remove key from the receiver.
	If key is not in the receiver, notify an error."

	^ self removeKey: key ifAbsent: [self errorKeyNotFound: key]! !

!SmallDictionary methodsFor: 'private' stamp: ''!
errorValueNotFound: value

	ValueNotFound signalFor: value! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
size
	^size! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
at: key ifPresent: aPresentBlock ifAbsent: anAbsentBlock
	"Lookup the given key in the receiver. If it is present, answer the
	value of evaluating the first block optionally with the value associated
	with the key.
	Otherwise answer the value of the second block."

	self at: key ifPresent: [ :v | ^ aPresentBlock cull: v ].
	^ anAbsentBlock value! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
keyForIdentity: aValue
	"If aValue 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 keysAndValuesDo: [:key :value |  value == aValue ifTrue: [^  key]].
	^ nil! !

!SmallDictionary methodsFor: 'testing' stamp: ''!
includesKey: key
	"Answer whether the receiver has a key equal to the argument, key."

	^ (self findIndexForKey: key) ~= 0! !

!SmallDictionary methodsFor: 'nested dictionaries' stamp: ''!
at: firstKey at: secondKey ifAbsentPut: aZeroArgBlock
	"Return the object stored in the second dictionary at secondKey. The second dictionary is accessed via the key firstKey. If firstKey is not defined, set a new dictionary for the second key and set the value of aZeroArgBlock execution. If firstKey is defined and not second key set the value of aZeroArgBlock execution. See NestedDictionaryTest for examples."

	| subDictionary |
	subDictionary := self at: firstKey ifAbsentPut: [ self species new ].
	^ subDictionary at: secondKey ifAbsentPut: aZeroArgBlock! !

!SmallDictionary methodsFor: 'nested dictionaries' stamp: ''!
at: firstKey at: secondKey
	"Return the object stored in the second dictionary at secondKey. The second dictionary is accessed via the key firstKey."

	"
	(Dictionary new
		at: #top at: #below1 put: 1;
		at: #top at: #below1 put: 2;
		at: #top at: #below1)
	>>>
	2"

	^ self at: firstKey at: secondKey ifAbsent: [ self errorKeyNotFound: secondKey ]! !

!SmallDictionary methodsFor: 'private' stamp: ''!
privateAt: key put: value 
	size == keys size ifTrue: [self growKeysAndValues].
	size := size + 1.
	keys at: size put: key.
	^values at: size put: value! !

!SmallDictionary methodsFor: 'enumerating' stamp: ''!
associationsDo: aBlock 
	"Evaluate aBlock for each association for the receiver.

	Modifying the associations won't affect the receiver because it
	isn't implemented with associations like Dictionary."
	
	self keysAndValuesDo: [:key :value | aBlock value: key -> value]! !

!SmallDictionary methodsFor: 'comparing' stamp: ''!
= 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.
	See issue 16760 before changing"

	self == aDictionary ifTrue: [^true].
	self species == aDictionary species ifFalse: [^false].
	self size = aDictionary size ifFalse: [^false].
	self associationsDo: [:assoc|
		(aDictionary at: assoc key ifAbsent: [^false]) = assoc value
			ifFalse: [^false]].
	^true! !

!SmallDictionary methodsFor: 'adding' stamp: ''!
add: anAssociation 
	self at: anAssociation key put: anAssociation value.
	^anAssociation! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
associations
	"Answer a collection containing associations for the receiver.
	Suggested by l. Uzonyi

	Modifying the associations won't affect the receiver because it
	isn't implemented with associations like Dictionary."
	
	^Array new: self size streamContents: [ :stream |
 		self associationsDo: [ :each | stream nextPut: each ] ]! !

!SmallDictionary methodsFor: 'private' stamp: ''!
errorKeyNotFound: aKey

	KeyNotFound signalFor: aKey! !

!SmallDictionary methodsFor: 'private' stamp: ''!
growTo: aSize 
	| newKeys newValues |
	newKeys := Array new: aSize.
	newValues := Array new: aSize.
	1 to: size
		do: 
			[:i | 
			newKeys at: i put: (keys at: i).
			newValues at: i put: (values at: i)].
	keys := newKeys.
	values := newValues! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
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]! !

!SmallDictionary methodsFor: 'private' stamp: ''!
findIndexForKey: aKey 
	^ keys indexOf: aKey.! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
empty
	1 to: size do: [ :index |
		keys at: index put: nil.
		values at: index put: nil ].
	size := 0! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
bindingOf: varName
	^self associationAt: varName ifAbsent:[nil]! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
keys
	"Answer an Array containing the receiver's keys."
	
	^ keys copyFrom: 1 to: size! !

!SmallDictionary methodsFor: 'enumerating' stamp: ''!
keysDo: aBlock 
	1 to: size do: [:i | aBlock value: (keys at: i)]! !

!SmallDictionary methodsFor: 'enumerating' stamp: ''!
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]].
	^newCollection! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
at: key 
	"Answer the value associated with the key."

	^ self at: key ifAbsent: [self errorKeyNotFound: key]! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
at: key ifPresent: aPresentBlock ifAbsentPut: anAbsentBlock
	"Lookup the given key in the receiver. If it is present, answer the
	value of evaluating the first block optionally with the value associated
	with the key.
	Otherwise store and return the result of evaluating the second block as the
	new value of the key."

	^ self
		at: key
		ifPresent: aPresentBlock
		ifAbsent: [ self at: key put: anAbsentBlock value ]! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
at: key ifAbsent: aBlock 
	"Answer the value associated with the key or, if key isn't found,
	answer the result of evaluating aBlock."

	| index |
	index := self findIndexForKey:  key.
	index = 0 ifTrue: [^ aBlock value].
	
	^ values at: index.

	"| assoc |
	assoc := array at: (self findElementOrNil: key).
	assoc ifNil: [^ aBlock value].
	^ assoc value"! !

!SmallDictionary methodsFor: 'removing' stamp: ''!
remove:anAssociation

	self removeKey:anAssociation key.! !

!SmallDictionary methodsFor: 'nested dictionaries' stamp: ''!
at: firstKey at: secondKey ifAbsent: aZeroArgBlock
		"Return the object stored in the second dictionary at secondKey. The second dictionary is accessed via the key firstKey. Execute aZeroArgBlock in case one of the key is wrong."
		
	| subDictionary |
	subDictionary := self at: firstKey ifAbsent: [ ^ aZeroArgBlock value ].
	^ subDictionary at: secondKey ifAbsent: aZeroArgBlock! !

!SmallDictionary methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"I store my instances as maps"
	
	stonWriter 
		writeObject: self 
		do: [ stonWriter encodeMap: self ]! !

!SmallDictionary methodsFor: 'enumerating' stamp: ''!
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! !

!SmallDictionary methodsFor: 'testing' stamp: ''!
includesIdentity: aValue
	"Answer whether aValue 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 | aValue == each ifTrue: [^ true]].
	^ false! !

!SmallDictionary methodsFor: 'printing' stamp: ''!
printElementsOn: aStream
	| noneYet |
	aStream nextPut: $(.
	noneYet := true.
	self associationsDo: [ :each | 
			noneYet
				ifTrue: [ noneYet := false ]
				ifFalse: [ aStream space ].
			aStream print: each].
	aStream nextPut: $)! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
at: key update: updateBlock 
	"I am used to update the value at a given key, or if the key does not exist, to throw an error"
	self at: key update: updateBlock initial: [ self errorKeyNotFound: key ].! !

!SmallDictionary methodsFor: 'enumerating' stamp: ''!
bindingsDo: aBlock
	self associationsDo: aBlock! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
capacity
	^keys size! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
values
	"Answer a Collection containing the receiver's values."
	^Array 
		new: self size 
		streamContents: [ :out | self valuesDo: [:value | out nextPut: value]]! !

!SmallDictionary methodsFor: 'private' stamp: ''!
growKeysAndValues
	self growTo: size * 2! !

!SmallDictionary methodsFor: 'adding' stamp: ''!
addAll: aKeyedCollection
	aKeyedCollection == self 
		ifFalse: [
			aKeyedCollection keysAndValuesDo: [:key :value | self at: key put: value]].
	^aKeyedCollection! !

!SmallDictionary methodsFor: 'accessing' stamp: ''!
keysSortedSafely
	"Answer a SortedCollection containing the receiver's keys."
	| sortedKeys |
	sortedKeys := SortedCollection new: self size.
	sortedKeys sortBlock:
		[:x :y |  "Should really be use <obj, string, num> 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]]].
	self keysDo: [:each | sortedKeys addLast: each].
	^ sortedKeys reSort! !

!SmallDictionary methodsFor: 'enumerating' stamp: ''!
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! !

!SmallDictionary methodsFor: 'printing' stamp: ''!
storeOn: aStream
	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new)'.
	noneYet := true.
	self associationsDo: [ :each | 
			noneYet
				ifTrue: [ noneYet := false ]
				ifFalse: [ aStream nextPut: $; ].
			aStream nextPutAll: ' add: '.
			aStream store: each].
	noneYet ifFalse: [ aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !

!SmallDictionary methodsFor: 'removing' stamp: ''!
remove: oldObject ifAbsent: anExceptionBlock 
	self removeKey: oldObject key ifAbsent: anExceptionBlock.
	^oldObject! !

!SmallDictionary class methodsFor: 'instance creation' stamp: ''!
new: aSize 
	"Ignore the size"

	^self basicNew initialize! !

!SmallDictionary class methodsFor: 'instance creation' stamp: ''!
newFromKeys: keys andValues: values
	"Create a dictionary from the keys and values arguments which should have the same length."
	
	"(SmallDictionary newFromKeys: #(#x #y) andValues: #(3 6)) >>> (SmallDictionary new at: #x put: 3; at: #y put: 6 ;yourself)"
	
	| dict |
	dict := self new.
	keys with: values do: [ :k :v | dict at: k put: v ].
	^ dict! !

!SmallDictionary class methodsFor: 'instance creation' stamp: ''!
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! !

!SmallDictionary class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"My instances are stored as maps."
	
	| dictionary |
	dictionary := self new.
	stonReader parseMapDo: [ :key :value |
		dictionary at: key put: value ].
	^ dictionary! !

!SmallDictionary class methodsFor: 'instance creation' stamp: ''!
newFrom: aDict 
	"Answer an instance of me containing the same associations as aDict.
	 Error if any key appears twice."
	| newDictionary |
	newDictionary := self new: aDict size.
	aDict associationsDo:
		[:x |
		(newDictionary includesKey: x key)
			ifTrue: [self error: 'Duplicate key: ', x key printString]
			ifFalse: [newDictionary add: x]].
	^ newDictionary! !

!SmallDictionaryTest commentStamp: ''!
SUnit tests for small dictionaries!
!SmallDictionaryTest methodsFor: 'tests' stamp: ''!
testAtUpdateInitial
	| dict |
	dict := SmallDictionary newFrom: {2->10. 100->5} .
	dict at: 5 update: [ :v | v+1 ] initial: 17.
	dict at: 2 update: [ :v | v+10 ] initial: [0].
	self assert: (dict at: 5) equals: 17.
	self assert: (dict at: 2) equals: 20! !

!SmallDictionaryTest methodsFor: 'tests - printing' stamp: ''!
testStoreOn
	self
		assert: self nonEmptyDict storeString
		equals: '((' , self nonEmptyDict class printString , ' new) add: (#a->1); add: (#b->30); add: (#c->1); add: (#d-> -2); yourself)'! !

!SmallDictionaryTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testStoreOnRoundTrip
	| dictionary storeString evalutated |
	dictionary := self classToBeTested new.
	dictionary
		add: #a -> 1;
		add: #b -> 30;
		add: #c -> 1;
		add: #d -> -2.
	storeString := String streamContents: [ :s | dictionary storeOn: s ].
	evalutated := Smalltalk compiler evaluate: storeString.
	self assert: dictionary equals: evalutated! !

!SmallDictionaryTest methodsFor: 'tests' stamp: ''!
testAtUpdate
	| dict |
	dict := SmallDictionary newFrom: {2->10. 100->5} .
	
	dict at: 2 update: [ :v | v+10 ].
	self assert: (dict at: 2) equals: 20.
	self should: [ dict at: 5 update: [ :v | v+1 ] ] raise: KeyNotFound .! !

!SmallDictionaryTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ SmallDictionary! !

!SmallDictionaryTest class methodsFor: 'building suites' stamp: ''!
shouldInheritSelectors

^true! !

!SmallFloat64 commentStamp: ''!
My instances represent 64-bit Floats whose exponent fits in 8 bits as immediate objects.  This representation is only available on 64-bit systems, not 32-bit systems.!
!SmallFloat64 methodsFor: 'comparing' stamp: ''!
~= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is not equal to the argument. Otherwise return false.
	Fail if the argument is not a Float. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 548>
	^super ~= aNumber! !

!SmallFloat64 methodsFor: 'comparing' stamp: ''!
< 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."

	<primitive: 543>
	^ aNumber adaptToFloat: self andCompare: #<! !

!SmallFloat64 methodsFor: '*Math-Operations-Extensions' stamp: ''!
sqrt
	"Answer the square root of the receiver. 
	 Optional. See Object documentation whatIsAPrimitive."

	<primitive: 555>
	| exp guess eps delta |
	self <= 0.0
		ifTrue: [ ^ self = 0.0
				ifTrue: [ 0.0 ]
				ifFalse: [ "v Chg" DomainError signal: 'sqrt undefined for number less than zero.' ] ].
	"Newton-Raphson"
	"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! !

!SmallFloat64 methodsFor: 'comparing' stamp: ''!
= 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."

	<primitive: 547>
	aNumber isNumber ifFalse: [^ false].
	^ aNumber adaptToFloat: self andCompare: #=! !

!SmallFloat64 methodsFor: 'arithmetic' stamp: ''!
* aNumber 
	"Primitive. Answer the result of multiplying the receiver by aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 549>
	^ aNumber adaptToFloat: self andSend: #*! !

!SmallFloat64 methodsFor: 'arithmetic' stamp: ''!
/ aNumber 
	"Primitive. Answer the result of dividing receiver by aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 550>
	aNumber = 0.0 ifTrue: [ ^ ZeroDivide signalWithDividend: self].
	^aNumber adaptToFloat: self andSend: #/! !

!SmallFloat64 methodsFor: 'copying' stamp: ''!
shallowCopy
	"Answer the receiver, because SmallFloat64s are unique."
	^self! !

!SmallFloat64 methodsFor: '*Math-Operations-Extensions' stamp: ''!
sin
	"Answer the sine of the receiver taken as an angle in radians.
	 Optional. See Object documentation whatIsAPrimitive."

	| sum delta self2 i |
	<primitive: 556>

	"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! !

!SmallFloat64 methodsFor: 'comparing' stamp: ''!
basicIdentityHash
	"Answer an integer unique to the receiver."
	"primitive 171 is the primitiveImmediateAsInteger primitive that converts SmallIntegers to themselves, Characters to their integer codes, and SmallFloat64 to an integer representing their bits.  e.g.

#(-0.0 0.0 -1.0 1.0) collect: [:n| n -> n identityHash hex -> (n identityHash bitAnd: 2 << 64 - 1) hex]
{-0.0->'-16r1000000000000000'->'16r1F000000000000000' .
  0.0->'16r0'->'16r0' .
 -1.0->'-16r810000000000000'->'16r1F7F0000000000000' .
  1.0->'16r7F0000000000000'->'16r7F0000000000000'}"

	<primitive: 171>
	^self primitiveFailed! !

!SmallFloat64 methodsFor: 'comparing' stamp: ''!
> 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."

	<primitive: 544>
	^ aNumber adaptToFloat: self andCompare: #>! !

!SmallFloat64 methodsFor: '*Math-Operations-Extensions' stamp: ''!
arcTan
	"Answer the angle in radians.
	 Optional. See Object documentation whatIsAPrimitive."

	| theta eps step sinTheta cosTheta |
	<primitive: 557>

	"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! !

!SmallFloat64 methodsFor: 'arithmetic' stamp: ''!
- aNumber 
	"Primitive. Answer the difference between the receiver and aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 542>
	^ aNumber adaptToFloat: self andSend: #-! !

!SmallFloat64 methodsFor: 'memory scanning' stamp: ''!
nextObject
	"SmallFloat64 are immediate objects, and, as such, do not have successors in object memory."

	self shouldNotImplement! !

!SmallFloat64 methodsFor: 'comparing' stamp: ''!
>= 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. "

	<primitive: 546>
	^ aNumber adaptToFloat: self andCompare: #>=! !

!SmallFloat64 methodsFor: 'testing' stamp: ''!
isImmediateObject
	"This is needed for the bootstrap"
	^ true! !

!SmallFloat64 methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Answer the receiver, because SmallFloat64s are unique."
	^self! !

!SmallFloat64 methodsFor: 'comparing' stamp: ''!
identityHash
	"We need the override since basicIdentityHash is already in SmallInteger range,
	 the bitShift: 8 of the super implementation would lead to a LargeInteger"
	^ self basicIdentityHash! !

!SmallFloat64 methodsFor: 'truncation and round off' stamp: ''!
fractionPart
	"Primitive. Answer a Float whose value is the difference between the 
	receiver and the receiver's asInteger value. Optional. See Object 
	documentation whatIsAPrimitive."

	<primitive: 552>
	^self - self truncated asFloat! !

!SmallFloat64 methodsFor: 'copying' stamp: ''!
copy
	"Answer the receiver, because SmallFloat64s are unique."
	^self! !

!SmallFloat64 methodsFor: 'copying' stamp: ''!
deepCopy
	"Answer the receiver, because SmallFloat64s are unique."
	^self! !

!SmallFloat64 methodsFor: 'mathematical functions' stamp: ''!
timesTwoPower: anInteger 
	"Primitive. Answer with the receiver multiplied by 2.0 raised
	to the power of the argument.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 554>

	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)! !

!SmallFloat64 methodsFor: 'copying' stamp: ''!
clone
	"Answer the receiver, because SmallFloat64s are unique."
	^self! !

!SmallFloat64 methodsFor: 'truncation and round off' stamp: ''!
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. "

	<primitive: 551>
	(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"]! !

!SmallFloat64 methodsFor: 'mathematical functions' stamp: ''!
exp
	"Answer E raised to the receiver power.
	 Optional. See Object documentation whatIsAPrimitive." 

	| base fract correction delta div |
	<primitive: 559>

	"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! !

!SmallFloat64 methodsFor: 'mathematical functions' stamp: ''!
exponent
	"Primitive. Consider the receiver to be represented as a power of two
	multiplied by a mantissa (between one and two). Answer with the
	SmallInteger to whose power two is raised. Optional. See Object
	documentation whatIsAPrimitive."

	| positive |
	<primitive: 553>
	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! !

!SmallFloat64 methodsFor: 'mathematical functions' stamp: ''!
ln
	"Answer the natural logarithm of the receiver.
	 Optional. See Object documentation whatIsAPrimitive."

	| expt n mant x div pow delta sum eps |
	<primitive: 558>

	"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"! !

!SmallFloat64 methodsFor: 'arithmetic' stamp: ''!
+ aNumber 
	"Primitive. Answer the sum of the receiver and aNumber. Essential.
	Fail if the argument is not a Float. See Object documentation
	whatIsAPrimitive."

	<primitive: 541>
	^ aNumber adaptToFloat: self andSend: #+! !

!SmallFloat64 methodsFor: 'comparing' stamp: ''!
<= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is less than or equal to the argument. Otherwise return
	false. Fail if the argument is not a Float. Optional. See Object
	documentation whatIsAPrimitive."

	<primitive: 545>
	^ aNumber adaptToFloat: self andCompare: #<=! !

!SmallFloat64 class methodsFor: 'instance creation' stamp: ''!
basicNew
	self error: 'SmallFloat64s can only be created by performing arithmetic'! !

!SmallFloat64 class methodsFor: 'instance creation' stamp: ''!
basicNew: anInteger
	^self basicNew! !

!SmallIdentityDictionary commentStamp: ''!
I'm a SmallDictionary (this means faster than default one when dealing with limited number of items)
but I check my key based on identity.!
!SmallIdentityDictionary methodsFor: 'private' stamp: ''!
setClass
	^ IdentitySet! !

!SmallIdentityDictionary methodsFor: 'private' stamp: ''!
findIndexForKey: aKey 
	^ keys identityIndexOf: aKey! !

!SmallIdentityDictionaryTest commentStamp: ''!
SUnit tests for small identity dictionaries!
!SmallIdentityDictionaryTest methodsFor: 'coverage' stamp: ''!
classToBeTested
 
	^ SmallIdentityDictionary! !

!SmallIdentityDictionaryTest methodsFor: 'requirements' stamp: ''!
canBeUnhealthy
	^ false! !

!SmallInteger commentStamp: ''!
My instances are 31-bit numbers or 63-bit numbers depending on the image architecture, stored in twos complement form. The allowable range is approximately +- 1 billion (31 bits), 1 quintillion (63 bits)  (see SmallInteger minVal, maxVal).!
!SmallInteger methodsFor: 'comparing' stamp: ''!
< aNumber 
	"Primitive. Compare the receiver with the argument and answer with
	true if the receiver is less than the argument. Otherwise answer false.
	Fail if the argument is not a SmallInteger. Essential. No Lookup. See
	Object documentation whatIsAPrimitive."

	<primitive: 3>
	^super < aNumber! !

!SmallInteger methodsFor: 'bit manipulation' stamp: ''!
bitAnd: arg 
	"Primitive. Answer an Integer whose bits are the logical AND of the
	receiver's bits and those of the argument, arg.
	Numbers are interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 14>
	self >= 0 ifTrue: [^ arg bitAnd: self].
	^ (self bitInvert bitOr: arg bitInvert) bitInvert.! !

!SmallInteger methodsFor: 'pointers' stamp: ''!
pointsTo: anObject
	"Answers true if I hold a reference to anObject, or false otherwise. But since SmallIntegers do not have pointers, it always answers false"
	^false! !

!SmallInteger methodsFor: '*Math-Operations-Extensions' stamp: ''!
sqrt
	self negative ifTrue: [
		^ DomainError signal: 'sqrt undefined for number less than zero.' ].
	^super sqrt! !

!SmallInteger methodsFor: 'comparing' stamp: ''!
hash

    "Spread consecutive integers or integers related by some other pattern
    throughout the hash table, reducing the length of scans required."
    
    ^ self hashMultiply! !

!SmallInteger methodsFor: 'arithmetic' stamp: ''!
/ aNumber 
	"Primitive. This primitive (for /) divides the receiver by the argument
	and returns the result if the division is exact. Fail if the result is not a
	whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional.
	No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 10>
	aNumber = 0 ifTrue: [^(ZeroDivide dividend: self) signal].

	"This ugly type checking is needed because the implementation in the superclass assumes that the argument is a LargeInteger.
	So, it is using a primitive message that is only in LargeInteger. 
	Using the implementation in the superclass when we have a SmallInteger will fail the primitive and use the slow code.
	At the end it is creating the same Fraction that is done here.
	These duplication has to be avoided by correctly implementing the decision by using double dispatch."

	^(aNumber isMemberOf: SmallInteger)
		ifTrue: [(Fraction numerator: self denominator: aNumber) reduced]
		ifFalse: [super / aNumber]! !

!SmallInteger methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitSmallInteger: self! !

!SmallInteger methodsFor: 'system primitives' stamp: ''!
basicIdentityHash
	"The value answered is signed, within the full 
	 SmallInteger range, on the contrary to normal objects."
	^self! !

!SmallInteger methodsFor: '*Reflectivity' stamp: ''!
rfMinus: aNumber 
	"Primitive. Subtract the argument from the receiver and answer with the
	result if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger. Essential. No Lookup. See Object documentation
	whatIsAPrimitive."
	<metaLinkOptions: #( + optionDisabledLink)>
	<primitive: 2>
	^super - aNumber! !

!SmallInteger methodsFor: 'testing' stamp: ''!
even
	" 0 even >>> true"
	" 2 even >>> true"
	"-2 even >>> true"
	" 3 even >>> false"
	"-3 even >>> false"
	
	^(self bitAnd: 1) = 0! !

!SmallInteger methodsFor: 'private' stamp: ''!
highBitOfPositiveReceiver
	| shifted bitNo |
	"Answer the index of the high order bit of the receiver, or zero if the 
	receiver is zero. Receiver has to be positive!!"
	shifted := self.
	bitNo := 0.
	[shifted < 65536]
		whileFalse: 
			[shifted := shifted bitShift: -16.
			bitNo := bitNo + 16].
	shifted < 256
		ifFalse: 
			[shifted := shifted bitShift: -8.
			bitNo := bitNo + 8].
		
	"The high bits table can be obtained with:
	(1 to: 8) inject: #[0] into: [:highBits :rank | highBits , (highBits collect: [:e | rank])]."
	^bitNo + ( #[0 1 2 2 3 3 3 3 4 4 4 4 4 4 4 4 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8] at: shifted + 1)! !

!SmallInteger methodsFor: 'arithmetic' stamp: ''!
- aNumber 
	"Primitive. Subtract the argument from the receiver and answer with the
	result if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger. Essential. No Lookup. See Object documentation
	whatIsAPrimitive."

	<primitive: 2>
	^super - aNumber! !

!SmallInteger methodsFor: 'system primitives' stamp: ''!
nextObject
	"SmallIntegers are immediate objects, and, as such, do not have successors in object memory."

	self shouldNotImplement! !

!SmallInteger methodsFor: 'comparing' stamp: ''!
>= aNumber 
	"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. Optional. No Lookup.
	See Object documentation whatIsAPrimitive."

	<primitive: 6>
	^super >= aNumber! !

!SmallInteger methodsFor: 'system primitives' stamp: ''!
bytesCount
	"Answer the number of indexable fields in the receiver. This value is the 
	 same as the largest legal subscript. Included so that a SmallInteger can 
	 behave like a LargePositiveInteger or LargeNegativeInteger."
	
	"32768 == (1 bitShift: 15)"
	"32768 bytesCount >>> 2"
	
	"65536 == (1 bitShift: 16)"
	"65536 bytesCount >>> 3"
	
	| value length |
	length := 1.
	value := self.
	value >= 0
		ifTrue:
			[[value > 255] whileTrue:
				[value := value bitShift: -8.
				 length := length + 1]]
		ifFalse:
			[[value < -255] whileTrue:
				[value := value bitShift: -8.
				 length := length + 1]].
	^length! !

!SmallInteger methodsFor: 'printing' stamp: ''!
printOn: stream base: base 
	"Append a representation of this number in base b on aStream."

	self printOn: stream base: base length: 0 padded: false! !

!SmallInteger methodsFor: 'testing' stamp: ''!
isImmediateObject
	"This is needed for the bootstrap"
	^ true! !

!SmallInteger methodsFor: 'comparing' stamp: ''!
identityHash
	"Answer a SmallInteger whose value is related to the receiver's identity.
	 Specific override here to decrease the number of conflicts"
	^ self hashMultiply! !

!SmallInteger methodsFor: 'copying' stamp: ''!
deepCopy! !

!SmallInteger methodsFor: 'system primitives' stamp: ''!
nextInstance
	"SmallIntegers can't be enumerated this way.  There are a finite number of them from from (SmallInteger minVal) to (SmallInteger maxVal), but you'll have to enumerate them yourself with:
	(SmallInteger minVal) to: (SmallInteger maxVal) do: [:integer | <your code here>].
	"

	self shouldNotImplement! !

!SmallInteger methodsFor: 'bit manipulation' stamp: ''!
highBitOfMagnitude
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. This method is used for negative SmallIntegers as well,  
	since Pharo's LargeIntegers are sign/magnitude."
	
	self < 0 ifTrue: [
		"Beware: do not use highBitOfPositiveReceiver
		because self negated is not necessarily a SmallInteger
		(see SmallInteger minVal)"
		^self negated highBitOfMagnitude].
	
	"Implementation note: this method could be as well inlined here."
	^self highBitOfPositiveReceiver! !

!SmallInteger methodsFor: 'testing' stamp: ''!
isLarge
	^false! !

!SmallInteger methodsFor: '*Fuel-Core-Collections' stamp: ''!
largeIdentityHash
	"Return an integer between 0 and 4095 based on all of my bits. Make sure that for nearby receivers the result will not be nearby with high probability."

	| remainder hash |
	self >= 0 
		ifTrue: [
			remainder := self.
			hash := 0 ]
		ifFalse: [
			remainder := 0 - self.
			hash := 4095 ].
	[ 
		hash := hash bitXor: (remainder bitAnd: 4095).
		(remainder := remainder bitShift: -12) = 0 ] whileFalse.
	^FLLargeIdentityHashedCollection permuteHash: hash + 1! !

!SmallInteger methodsFor: 'printing' stamp: ''!
printString
	"Highly optimized version for base 10
	and that we know it is a SmallInteger.
	Don't follow this example. It breaks the
	rule that printOn: is where strings are usually built."
	
	| integer next result len |
	self = 0 ifTrue: [^'0'].
	self < 0 ifTrue: [^'-', self negated printString].
	len := self decimalDigitLength.
	result := String new: len.
	integer := self.
	len to: 1 by: -1 do: [:i |
		next := integer // 10.
		result byteAt: i put: 48 + (integer - (next * 10)).
		integer := next].
	^result! !

!SmallInteger methodsFor: '*UnifiedFFI' stamp: ''!
unpackFromArity: arity
	"FFI can arrive here if the assigned pointer is NULL (in which case plugin will answer not an 
	 address but a plain 0... Take this as an example: 

	void function(char **errorMessage) {
		&x = NULL; //This will mean no errorMessage
	}
	
	then the corresponding Pharo method 
	
	errorMessage := ExternalAddress new. 
	self function: errorMessage.

	It will try to unpack a 0 (NULL)... and it should answer still NULL. 
	This is the only case where is valid."
	self = 0 ifFalse: [ self error: 'Should not arrive here. FFI bad code.' ].
	^ self! !

!SmallInteger methodsFor: 'testing' stamp: ''!
odd
	" 0 odd >>> false"
	" 2 odd >>> false"
	"-2 odd >>> false"
	" 3 odd >>> true"
	"-3 odd >>> true"
	^(self bitAnd: 1) = 1! !

!SmallInteger methodsFor: 'converting' stamp: ''!
asFloat
	"Primitive. Answer a Float that represents the value of the receiver.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 40>
	self primitiveFailed! !

!SmallInteger methodsFor: 'bit manipulation' stamp: ''!
bitStringLength
      "Always use as many bits as the native format to represent a SmallInteger"

      ^self class maxVal highBit + 1! !

!SmallInteger methodsFor: 'system primitives' stamp: ''!
byteAt: n
	"Answer the value of an apparent byte-indexable field in the receiver,
	 analogous to the large integers, which are organized as bytes."

	n = 1
		ifTrue: [ 
			"Negate carefully in case the receiver is SmallInteger minVal"
			^ self < 0
				ifTrue: [ -256 - self bitAnd: 255 ]
				ifFalse: [ self bitAnd: 255 ] ].
	^ self < 0
		ifTrue: [ (-256 - self bitShift: -8) + 1 byteAt: n - 1 ]
		ifFalse: [ (self bitShift: 8 - (n bitShift: 3)) bitAnd: 255 ]! !

!SmallInteger methodsFor: 'comparing' stamp: ''!
= aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is equal to the argument. Otherwise answer false. Fail if the
	argument is not a SmallInteger. Essential. No Lookup. See Object
	documentation whatIsAPrimitive. "

	<primitive: 7>
	^super = aNumber! !

!SmallInteger methodsFor: 'arithmetic' stamp: ''!
* aNumber 
	"Primitive. Multiply the receiver by the argument and answer with the
	result if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 9>
	^ super * aNumber! !

!SmallInteger methodsFor: 'bit manipulation' stamp: ''!
hashMultiply
	"This is a multiplication of hashes by 1664525 mod 2^28 written to avoid overflowing into large integers.
	 The primitive is able to perform the operation with modulo arihmetic.
	
	Example of usage:
	  hash
	    ^ (super hash + variableName hash) hashMultiply 	
	"
	
	
	<primitive: 159>
	| low |
	low := self bitAnd: 16383.
	^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384))
			bitAnd: 16r0FFFFFFF! !

!SmallInteger methodsFor: 'printing' stamp: ''!
printStringBase: b 
	"Return a String representation of this number in base b.
	For SmallIntegers, it is more efficient to print directly in a String,
	rather than using a Stream like super."
	
	"(10 printStringBase: 10) >>> '10'"
	"(-10 printStringBase: 10) >>> '-10'"
	"(10 printStringBase: 2) >>> '1010'"
	"(10 printStringBase: 16) >>> 'A'"
	
	self < 0
		ifTrue: [^ '-'
				, (self negated printStringBase: b)].
	self < b
		ifTrue: [^ String
				with: (Character digitValue: self)].
	^ self printStringBase: b nDigits: (self numberOfDigitsInBase: b)! !

!SmallInteger methodsFor: 'comparing' stamp: ''!
~= aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is not equal to the argument. Otherwise answer false. Fail if
	the argument is not a SmallInteger. Essential. No Lookup. See Object
	documentation whatIsAPrimitive."

	<primitive: 8>
	^super ~= aNumber! !

!SmallInteger methodsFor: 'copying' stamp: ''!
shallowCopy! !

!SmallInteger methodsFor: 'printing' stamp: ''!
numberOfDigitsInBase: b 
	"Return how many digits are necessary to print this number in base b.
	Mostly same as super but an optimized version for base 10 case"
	
	b = 10 ifFalse: [^super numberOfDigitsInBase: b].
	self < 0 ifTrue: [^self negated numberOfDigitsInBase: b].
	^self decimalDigitLength! !

!SmallInteger methodsFor: '*Math-Operations-Extensions' stamp: ''!
threeDigitName

	| units answer |

	self = 0 ifTrue: [^''].
	units := #('one' 'two' 'three' 'four' 'five' 'six' 'seven' 'eight' 'nine' 'ten' 
		'eleven' 'twelve' 'thirteen' 'fourteen' 'fifteen' 'sixteen' 'seventeen' 
		'eighteen' 'nineteen').
	self > 99 ifTrue: [
		answer := (units at: self // 100),' hundred'.
		(self \\ 100) = 0 ifFalse: [
			answer := answer,' ',(self \\ 100) threeDigitName
		].
		^answer
	].
	self < 20 ifTrue: [
		^units at: self
	].
	answer := #('twenty' 'thirty' 'forty' 'fifty' 'sixty' 'seventy' 'eighty' 'ninety')
			at: self // 10 - 1.
	(self \\ 10) = 0 ifFalse: [
		answer := answer,'-',(units at: self \\ 10)
	].
	^answer! !

!SmallInteger methodsFor: 'printing' stamp: ''!
printOn: aStream base: b nDigits: n 
	"Append a representation of this number in base b on aStream using nDigits.
	self must be positive."

	self printOn: aStream base: b length: n padded: true! !

!SmallInteger methodsFor: 'comparing' stamp: ''!
> aNumber 
	"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. Essential. No Lookup. See Object
	documentation whatIsAPrimitive."

	<primitive: 4>
	^super > aNumber! !

!SmallInteger methodsFor: 'arithmetic' stamp: ''!
\\ aNumber 
	"Primitive. Take the receiver modulo the argument. The result is the
	remainder rounded towards negative infinity, of the receiver divided by
	the argument Fail if the argument is 0 or is not a SmallInteger. Optional.
	No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 11>
	^ super \\ aNumber 	"will use // to compute it if primitive fails"! !

!SmallInteger methodsFor: 'printing' stamp: ''!
decimalDigitLength
	"Answer the number of digits printed out in base 10.
	 Note that this only works for positive SmallIntegers up to 64-bits."
	"1 decimalDigitLength >>> 1"
	"100000000 decimalDigitLength >>> 9"
	"SmallInteger maxVal decimalDigitLength >>> 19"
	
	^self < 10000
		ifTrue:
			[self < 100
				ifTrue:
					[self < 10 ifTrue: [1] ifFalse: [2]]
				ifFalse:
					[self < 1000 ifTrue: [3] ifFalse: [4]]]
		ifFalse:
			[self < 100000000
				ifTrue:
					[self < 1000000
						ifTrue: [self < 100000 ifTrue: [5] ifFalse: [6]]
						ifFalse: [self < 10000000 ifTrue: [7] ifFalse: [8]]]
				ifFalse:
					[self < 1000000000000
						ifTrue:
							[self < 10000000000
								ifTrue: [self < 1000000000 ifTrue: [9] ifFalse: [10]]
								ifFalse: [self < 100000000000 ifTrue: [11] ifFalse: [12]]]
						ifFalse:
							[self < 10000000000000000
								ifTrue:
									[self < 100000000000000
										ifTrue: [self < 10000000000000 ifTrue: [13] ifFalse: [14]]
										ifFalse: [self < 1000000000000000 ifTrue: [15] ifFalse: [16]]]
								ifFalse:
									[self < 1000000000000000000
										ifTrue: [self < 100000000000000000 ifTrue: [17] ifFalse: [18]]
										ifFalse: [self < 10000000000000000000 ifTrue: [19] ifFalse: [20]]]]]]! !

!SmallInteger methodsFor: 'bit manipulation' stamp: ''!
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."
	"2r00101000 highBit >>> 6"
	"0 highBit >>> 0"
	
	self < 0 ifTrue: [^ self error: 'highBit is not defined for negative integers'].
	^ self highBitOfPositiveReceiver! !

!SmallInteger methodsFor: '*Reflectivity' stamp: ''!
rfPlus: aNumber 
	"Primitive. Add the receiver to the argument and answer with the result
	if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger  Essential  No Lookup. See Object documentation whatIsAPrimitive."
	<metaLinkOptions: #( + optionDisabledLink)>
	<primitive: 1>
	^ super + aNumber! !

!SmallInteger methodsFor: 'system primitives' stamp: ''!
byteAt: n put: value 
	"Fails. The digits of a small integer can not be modified."

	self error: 'You can''t store in a SmallInteger'! !

!SmallInteger methodsFor: 'bit manipulation' stamp: ''!
bitXor: arg 
	"Primitive. Answer an Integer whose bits are the logical XOR of the
	receiver's bits and those of the argument, arg.
	Numbers are interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 16>
	self >= 0 ifTrue: [^ arg bitXor: self].
	^ arg < 0
		ifTrue: [self bitInvert bitXor: arg bitInvert]
		ifFalse: [(self bitInvert bitXor: arg) bitInvert].! !

!SmallInteger methodsFor: 'printing' stamp: ''!
printOn: stream base: base length: minimumLength padded: padWithZeroes
	"Return a String representation of this number in base b with a minimum length and padded by 0 if zeroFlag is set"
	
	"(String streamContents: [ :s | 10 printOn: s base: 10 length: 4 padded: true] ) >>> '0010'"
	"(String streamContents: [ :s | -10 printOn: s base: 10 length: 4 padded: true] ) >>> '-010'"

	| n numberOfDigits totalLength divisor |
	self < 0
		ifTrue: [
			n := self negated.
			totalLength := 1 ]
		ifFalse: [
			n := self.
			totalLength := 0 ].
	numberOfDigits := n numberOfDigitsInBase: base.
	totalLength := totalLength + numberOfDigits.
	padWithZeroes ifFalse: [
		[ totalLength < minimumLength ] whileTrue: [
			stream space.
			totalLength := totalLength + 1 ] ].
	n = self ifFalse: [ stream nextPut: $- ].
	padWithZeroes ifTrue: [
		[ totalLength < minimumLength ] whileTrue: [
			stream nextPut: $0.
			totalLength := totalLength + 1 ] ].
	divisor := (base raisedToInteger: numberOfDigits - 1).
	[ divisor > 0 ] whileTrue: [
		| digit |
		digit := n // divisor.
		stream nextPut: ('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ' at: digit + 1).
		n := n - (digit * divisor).
		divisor := divisor // base ]! !

!SmallInteger methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !

!SmallInteger methodsFor: 'bit manipulation' stamp: ''!
bitOr: arg 
	"Primitive. Answer an Integer whose bits are the logical OR of the
	receiver's bits and those of the argument, arg.
	Numbers are interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 15>
	self >= 0 ifTrue: [^ arg bitOr: self].
	^ arg < 0
		ifTrue: [(self bitInvert bitAnd: arg bitInvert) bitInvert]
		ifFalse: [(self bitInvert bitClear: arg) bitInvert]! !

!SmallInteger methodsFor: 'arithmetic' stamp: ''!
quo: aNumber 
	"Primitive. Divide the receiver by the argument and answer with the 
	result. Round the result down towards zero to make it a whole integer. 
	Fail if the argument is 0 or is not a SmallInteger. Optional. See Object 
	documentation whatIsAPrimitive."
	
	<primitive: 13>
	aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal].
	(aNumber isMemberOf: SmallInteger)
		ifFalse: [^ super quo: aNumber].
	(aNumber = -1 and: [self = self class minVal])
		ifTrue: ["result is aLargeInteger" ^ self negated].
	self primitiveFailed! !

!SmallInteger methodsFor: 'printing' stamp: ''!
printStringBase: b nDigits: n
	"Return a string representation of this number in base b with n digits (left padded with 0).
	Should be invoked with: 0 <= self < (b raisedToInteger: n)."
	
	| integer next result |
	result := String new: n.
	integer := self.
	n to: 1 by: -1 do: [:i |
		next := integer // b.
		result byteAt: i put: (Character digitValue: (integer - (next * b))).
		integer := next].
	^result! !

!SmallInteger methodsFor: 'arithmetic' stamp: ''!
// aNumber 
	"Primitive. Divide the receiver by the argument and answer with the
	result. Round the result down towards negative infinity to make it a
	whole integer. Fail if the argument is 0 or is not a SmallInteger.
	Essential. No Lookup. See Object documentation whatIsAPrimitive. "

	<primitive: 12>
	^ super // aNumber 	"Do with quo: if primitive fails"! !

!SmallInteger methodsFor: 'bit manipulation' stamp: ''!
lowBit
	" Answer the index of the low order one bit.
	  First we skip bits in groups of 8, then do a lookup in a table.
	  While not optimal, this is a good tradeoff; long
	  integer #lowBit always invokes us with bytes."
	"2r00101000 lowBit >>> 4"
	"2r-00101000 lowBit >>> 4"
	| n result lastByte |
	n := self.
	n = 0 ifTrue: [ ^ 0 ].
	result := 0.
	[(lastByte := n bitAnd: 16rFF) = 0]
		whileTrue: [
			result := result + 8.
			n := n bitShift: -8 ].

	"The low bits table can be obtained with:
	((1 to: 8) inject: #[1] into: [:lowBits :rank | (lowBits copy at: 1 put: lowBits first + 1; yourself) , lowBits]) allButFirst."
	^result + ( #[1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 7 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 8 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 7 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1] at: lastByte)! !

!SmallInteger methodsFor: 'converting' stamp: ''!
asCharacter
	<primitive: 170>
	^self primitiveFailed! !

!SmallInteger methodsFor: 'mathematical functions' stamp: ''!
gcd: anInteger 
	"See SmallInteger (Integer) | gcd:"
	| n m |
	n := self.
	m := anInteger.
	[n = 0]
		whileFalse: 
			[n := m \\ (m := n)].
	^ m abs! !

!SmallInteger methodsFor: 'bit manipulation' stamp: ''!
bitShift: arg 
	"Primitive. Answer an Integer whose value is the receiver's value shifted
	left by the number of bits indicated by the argument. Negative arguments
	shift right. The receiver is interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 17>
	self >= 0 ifTrue: [^ super bitShift: arg].
	^ arg >= 0
		ifTrue: [(self negated bitShift: arg) negated]
		ifFalse: [(self bitInvert bitShift: arg) bitInvert].! !

!SmallInteger methodsFor: 'arithmetic' stamp: ''!
+ aNumber 
	"Primitive. Add the receiver to the argument and answer with the result
	if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger  Essential  No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 1>
	^ super + aNumber! !

!SmallInteger methodsFor: 'comparing' stamp: ''!
<= aNumber 
	"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. Optional. No Lookup.
	See Object documentation whatIsAPrimitive. "

	<primitive: 5>
	^super <= aNumber! !

!SmallInteger class methodsFor: 'instance creation' stamp: ''!
new

	self basicNew	"generates an error"! !

!SmallInteger class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default
		registerSystemClassNamed: self name
		atPriority: 10.
	self startUp: true! !

!SmallInteger class methodsFor: 'instance creation' stamp: ''!
basicNew

	self error: 'SmallIntegers can only be created by performing arithmetic'! !

!SmallInteger class methodsFor: 'documentation' stamp: ''!
guideToDivision
	"Handy guide to the kinds of Integer division: 
	/  exact division, returns a fraction if result is not a whole integer. 
	//  returns an Integer, rounded towards negative infinity. 
	\\ is modulo rounded towards negative infinity. 
	quo:  truncated division, rounded towards zero."! !

!SmallInteger class methodsFor: 'constants' stamp: ''!
minVal
	"Answer the minimum value for a SmallInteger."
	^ minVal! !

!SmallInteger class methodsFor: 'constants' stamp: ''!
maxVal
	"Answer the maximum value for a SmallInteger."
	^ maxVal! !

!SmallInteger class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting
	"The image is either being newly started (isImageStarting is true), or it's just been snapshotted.
	 If this has just been a snapshot, skip all the startup stuff."
	| next val |
	isImageStarting ifFalse: [^self].
	val := -32768. "Assume at least 16 bits"
	[next := val + val.
	next class == self] whileTrue:
		[val := next].
	minVal := val.
	maxVal := -1 - val! !

!SmallIntegerTest commentStamp: ''!
I provide a test suite for SmallInteger values. Examine my tests to see how SmallIntegers should behave, and see how to use them.!
!SmallIntegerTest methodsFor: 'tests - operations' stamp: ''!
testBitOr
	| onezero zeroone ones |
	onezero := 2r1010101.
	zeroone := 2r0101010.
	ones    := 2r1111111.
	
	self assert: (onezero bitOr: ones)    equals: ones.
	self assert: (onezero bitOr: zeroone) equals: ones.
	self assert: (onezero bitOr: onezero) equals: onezero.
	self assert: (onezero bitOr: 0)       equals: onezero.! !

!SmallIntegerTest methodsFor: 'tests - operations' stamp: ''!
testGcd
	
	"trick case: a = b"
 	self assert: (13 gcd: 13) equals: 13.
	"receiver is a prime"
	self assert: (37 gcd: 600) equals: 1.
	"one is multiplum of other"
	self assert: (20 gcd: 100) equals: 20. 
	"straight case"
   self assert: (624129 gcd: 2061517) equals: 18913! !

!SmallIntegerTest methodsFor: 'tests' stamp: ''!
testQuo
	self should: [ 1 quo: 0] raise: ZeroDivide.
	self assert: ( 1 quo: 2) equals:  0.
	self assert: ( 4 quo: 2) equals:  2.
	self assert: (-4 quo: 2) equals: -2.
	self assert: (-5 quo: 2) equals: -2.
	self assert: ( 5 quo: 2) equals:  2! !

!SmallIntegerTest methodsFor: 'tests - other' stamp: ''!
testIsNotAbstract

	self deny: SmallInteger isAbstract! !

!SmallIntegerTest methodsFor: 'tests - Class Methods' stamp: ''!
testBasicNew

	self should: [SmallInteger basicNew] raise: self defaultTestError.! !

!SmallIntegerTest methodsFor: 'tests - arithmetic' stamp: ''!
testDivide
	self assert: 2 / 1 equals: 2.
	self assert: (3 / 2) isFraction.
	self assert: 4 / 2 equals: 2.
	self should: [ 1 / 0 ] raise: ZeroDivide! !

!SmallIntegerTest methodsFor: 'tests - operations' stamp: ''!
testBitShift
	 
	self assert: (2r11 bitShift: 1) equals: 2r110.
	self assert: (2r11 bitShift: -1) equals: 2r1.
	self assert: (2r1011 bitShift: 2) equals: 2r101100.
	self assert: (2r1011 bitShift: -2) equals: 2r10.
	self assert: (2r11 bitShift: -2) equals: 0! !

!SmallIntegerTest methodsFor: 'tests - printing' stamp: ''!
testPrintPaddedWith
	self assert: (123 printPaddedWith: $0 to: 10 base: 2) equals: '0001111011'.
	self assert: (123 printPaddedWith: $0 to: 10 base: 8) equals: '0000000173'.
	self assert: (123 printPaddedWith: $0 to: 10 base: 10) equals: '0000000123'.
	self assert: (123 printPaddedWith: $0 to: 10 base: 16) equals: '000000007B'! !

!SmallIntegerTest methodsFor: 'tests - Class Methods' stamp: ''!
testMaxVal
	Smalltalk vm wordSize = 4 ifTrue: [ self assert: SmallInteger maxVal equals: 16r3FFFFFFF ].
	Smalltalk vm wordSize = 8 ifTrue: [ self assert: SmallInteger maxVal equals: 16rFFFFFFFFFFFFFFF ]! !

!SmallIntegerTest methodsFor: 'tests - Class Methods' stamp: ''!
testMinVal
	Smalltalk vm wordSize = 4 ifTrue: [ self assert: SmallInteger minVal equals: -16r40000000 ].
	Smalltalk vm wordSize = 8 ifTrue: [ self assert: SmallInteger minVal equals: -16r1000000000000000 ]! !

!SmallIntegerTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ SmallInteger! !

!SmallIntegerTest methodsFor: 'tests - Class Methods' stamp: ''!
testByteAt

	| number |
	number := 16rABCDEF.
	self assert: (number byteAt: 1) equals: 16rEF.
	self assert: (number byteAt: 2) equals: 16rCD.
	self assert: (number byteAt: 3) equals: 16rAB.! !

!SmallIntegerTest methodsFor: 'tests - operations' stamp: ''!
testBitAnd
	| onezero zeroone ones |
	onezero := 2r1010101.
	zeroone := 2r0101010.
	ones    := 2r1111111.
	 
	self assert: (onezero bitAnd: ones)    equals: onezero.
	self assert: (onezero bitAnd: zeroone) equals: 0.
	self assert: (onezero bitAnd: onezero) equals: onezero.
	self assert: (onezero bitAnd: 0)       equals: 0.! !

!SmallIntegerTest methodsFor: 'tests - operations' stamp: ''!
testCeiling
	self assert: 2 ceiling equals: 2.
	self assert: -2 ceiling equals: -2.
	self assert: 2.1 ceiling equals: 3.
	self assert: -2.1 ceiling equals: -2! !

!SmallIntegerTest methodsFor: 'tests - Class Methods' stamp: ''!
testNew

	self should: [SmallInteger new] raise: self defaultTestError.! !

!SmallIntegerTest methodsFor: 'tests - printing' stamp: ''!
testPrintString
	self assert: 1 printString equals: '1'.
	self assert: -1 printString equals: '-1'.
	Smalltalk vm wordSize = 4
		ifTrue: [ 
			self assert: SmallInteger minVal printString equals: '-1073741824'.
			self assert: SmallInteger maxVal printString equals: '1073741823' ].
	Smalltalk vm wordSize = 8
		ifTrue: [ 
			self assert: SmallInteger minVal printString equals: '-1152921504606846976'.
			self assert: SmallInteger maxVal printString equals: '1152921504606846975' ].
	self assert: 12345 printString equals: '12345'.
	self assert: -54321 printString equals: '-54321'.
	
	self assert: 0 decimalDigitLength equals: 1.
	self assert: 4 decimalDigitLength equals: 1.
	self assert: 12 decimalDigitLength equals: 2.
	self assert: 123 decimalDigitLength equals: 3.
	self assert: 1234 decimalDigitLength equals: 4.
	self assert: 56789 decimalDigitLength equals: 5.
	self assert: 657483 decimalDigitLength equals: 6.
	self assert: 6571483 decimalDigitLength equals: 7.
	self assert: 65174383 decimalDigitLength equals: 8.
	self assert: 625744831 decimalDigitLength equals: 9.
	self assert: 1000001111 decimalDigitLength equals: 10.
	Smalltalk vm wordSize = 4
		ifTrue: [ self assert: SmallInteger maxVal decimalDigitLength equals: 10 ].
	Smalltalk vm wordSize = 8
		ifTrue: [ self assert: SmallInteger maxVal decimalDigitLength equals: 19 ].! !

!SmallIntegerTest methodsFor: 'tests - operations' stamp: ''!
testBitXOr
	| onezero zeroone ones |
	onezero := 2r1010101.
	zeroone := 2r0101010.
	ones    := 2r1111111.
	self assert: (onezero bitXor: ones)    equals: zeroone.
	self assert: (onezero bitXor: zeroone) equals: ones.
	self assert: (onezero bitXor: onezero) equals: 0.
	self assert: (onezero bitXor: 0)       equals: onezero.! !

!SmalllintManifestChecker commentStamp: ''!
SmalllintManifestChecker is responsible for running a set of rules on a given subsystem.

| rules checker | 
rules := RBCompositeLintRule allGoodRules resetResult.

"the resetResult is necessary because it will build a knid of cache of the result
and this cannot be done automatically (for example you may want to run several rules without invalidating the results). "

checker := SmalllintManifestChecker new
	runRules: rules onPackage: (RPackageOrganizer default packageNamed: #'Manifest-Core').!
!SmalllintManifestChecker methodsFor: 'accessing' stamp: ''!
builderManifestClass
	^ TheManifestBuilder! !

!SmalllintManifestChecker methodsFor: 'accessing' stamp: ''!
manifestBuilderOfPackage: aPackage
	| key |
	key := aPackage packageName.
	^ manifestClassCache
		at: key
		ifAbsentPut: [ 
			(self builderManifestClass hasPackageNamed: key)
				ifTrue: [ self builderManifestClass ofPackageNamed: key ]
				ifFalse: [ nil ] ]! !

!SmalllintManifestChecker methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	manifestClassCache := Dictionary new.! !

!SmalllintManifestChecker methodsFor: 'manifest' stamp: ''!
isFalsePositive: aCritic forRuleId: ruleId versionId: versionId

	| mb |

	mb := self manifestBuilderOf: aCritic.
	^ mb ifNil: [ false ] ifNotNil: [ mb isFalsePositive: aCritic onRule: ruleId version: versionId ]! !

!SmalllintManifestChecker methodsFor: 'accessing' stamp: ''!
manifestBuilderOfClass: aClass
	| key |
	key := aClass instanceSide category.
	^ manifestClassCache
		at: key
		ifAbsentPut: [ 
			(self builderManifestClass hasManifestFor: aClass)
				ifTrue: [ self builderManifestClass of: aClass ]
				ifFalse: [ nil ] ]! !

!SmalllintManifestChecker methodsFor: 'accessing' stamp: ''!
manifestBuilderOfMethod: aMethod
	| key cl |
	cl := aMethod methodClass.
	key := cl name , aMethod category asString.
	^ manifestClassCache
		at: key
		ifAbsentPut: [ 
			(self builderManifestClass hasManifestFor: aMethod)
				ifTrue: [ self builderManifestClass of: aMethod ]
				ifFalse: [ nil ] ]! !

!SmalllintManifestChecker methodsFor: 'actions' stamp: ''!
runRules: aCompositeRule onPackage: aPackage withoutTestCase: avoidTestCases
	rule := aCompositeRule.
	environment := RBPackageEnvironment package: aPackage.
	
	environment := environment withoutClasses: (environment classes select: #isManifest).
	avoidTestCases 
		ifTrue: [ environment := environment withoutClasses: (environment classes select: #isTestCase) ].
	self run! !

!SmalllintManifestChecker methodsFor: 'manifest' stamp: ''!
isToDo: aCritic forRuleId: ruleId versionId: versionId

	| mb |

	mb := self manifestBuilderOf: aCritic.
	^ mb ifNil: [ false ] ifNotNil: [ mb containsToDo: aCritic onRule: ruleId version: versionId ]! !

!SmalllintManifestChecker methodsFor: 'manifest' stamp: ''!
rejectRulesOf: aPackage

	| mb |

	mb := self manifestBuilderOf: aPackage.
	^ mb ifNil: [ {} ] ifNotNil: [ mb rejectRules ]! !

!SmalllintManifestChecker methodsFor: 'actions' stamp: ''!
runRules: aCompositeRule onPackage: aPackage

	rule := aCompositeRule.
	environment := RBPackageEnvironment package: aPackage.
	self run.! !

!SmalllintManifestChecker methodsFor: 'accessing' stamp: ''!
criticsOf: aRule

	^ rule leaves
		detect: [ :r | r class = aRule class ]
		ifFound: [ :rules | rules critics ]
		ifNone: [ #() ]! !

!SmalllintManifestChecker methodsFor: 'manifest' stamp: ''!
falsePositiveOf: aRule

	| critics rId rV mb |

	critics := self criticsOf: aRule.
	rId := aRule class uniqueIdentifierName.
	rV := aRule class identifierMinorVersionNumber.
	^ critics
		select: [ :critic | 
			mb := self manifestBuilderOf: critic.
			mb ifNil: [ false ] ifNotNil: [ mb isFalsePositive: critic onRule: rId version: rV ]
			]! !

!SmalllintManifestChecker methodsFor: 'accessing' stamp: ''!
rule
	^ rule! !

!SmalllintManifestChecker methodsFor: 'manifest' stamp: ''!
rejectClassesOf: aPackage

	| mb |

	mb := self manifestBuilderOf: aPackage.
	^ mb ifNil: [ {} ] ifNotNil: [ mb rejectClasses ]! !

!SmalllintManifestChecker methodsFor: 'manifest' stamp: ''!
cleanAllManifest
	| manifests |
	manifests := environment packages collect: [ :cl | self builderManifestClass of: cl ] as: Set.
	manifests do: [ :each | each cleanUp ]! !

!SmalllintManifestChecker methodsFor: 'manifest' stamp: ''!
isTruePositive: aCritic forRuleId: ruleId versionId: versionId 
	
	^ (self manifestBuilderOf: aCritic)
			containsTruePositive: aCritic onRule:  ruleId version: versionId! !

!SmalllintManifestChecker methodsFor: 'accessing' stamp: ''!
manifestBuilderOf: aPackage

	^ aPackage manifestBuilderForRuleChecker: self! !

!SmalllintManifestChecker methodsFor: 'manifest' stamp: ''!
toDoOf: aRule

	| critics rId rV mb |

	critics := self criticsOf: aRule.
	rId := aRule class uniqueIdentifierName.
	rV := aRule class identifierMinorVersionNumber.
	^ critics
		select: [ :critic | 
			mb := self manifestBuilderOf: critic.
			mb ifNil: [ false ] ifNotNil: [ mb containsToDo: critic onRule: rId version: rV ]
			]! !

!SmalllintManifestCheckerTest commentStamp: ''!
SUnit tests for SmalllintManifestChecker!
!SmalllintManifestCheckerTest methodsFor: 'tests' stamp: ''!
testCriticsOf

	| rule critiques |
	rule := ReRuleManager visibleRuleClasses collect: [:cl | cl new].
	checker
		rule: rule;
		environment: self package asEnvironment;
		run.
	critiques := checker criticsOf: ReTemporaryNeitherReadNorWrittenRule new.
	self assert: critiques size equals: 3.
	self assert: (critiques anySatisfy: [ :each | each sourceAnchor entity = (MFClassB >> #method3) ]).
	self assert: (critiques anySatisfy: [ :each | each sourceAnchor entity = (MFClassA >> #method) ])! !

!SmalllintManifestCheckerTest methodsFor: 'tests' stamp: ''!
testIsFalsePositive 

	| rule |
	rule  := ReRuleManager visibleRuleClasses collect: [:cl | cl new].
	checker
		rule: rule;
		environment: self package asEnvironment;
		run.  	
	self assert: (checker isFalsePositive:  (MFClassB>>#method3) forRuleId: (ReCodeCruftLeftInMethodsRule uniqueIdentifierName) versionId:  1).
	self deny: (checker isFalsePositive:  (MFClassA>>#method) forRuleId: (ReCodeCruftLeftInMethodsRule uniqueIdentifierName) versionId:  1).! !

!SmalllintManifestCheckerTest methodsFor: 'running' stamp: ''!
tearDown
	
	self cleaningResources.
	super tearDown! !

!SmalllintManifestCheckerTest methodsFor: 'running' stamp: ''!
cleaningResources
	testingEnvironment
		at: #ManifestManifestResourcesTests
		ifPresent: [ :cl | 
			cl
				removeFromChanges;
				removeFromSystem ]! !

!SmalllintManifestCheckerTest methodsFor: 'tests' stamp: ''!
testIsToDo

	| rule |
	rule  := ReRuleManager visibleRuleClasses collect: [ :each | each new ].
	checker
		rule: rule;
		environment: self package asEnvironment;
		run.
	
	self assert: (checker isToDo:  (MFClassB>>#method3) forRuleId: (ReTemporaryNeitherReadNorWrittenRule uniqueIdentifierName) versionId:  1).
	self deny: (checker isToDo:  (MFClassB>>#method2) forRuleId: (ReTemporaryNeitherReadNorWrittenRule uniqueIdentifierName) versionId:  1).! !

!SmalllintManifestCheckerTest methodsFor: 'tests' stamp: ''!
testToDoOf

	| rule |
	rule := ReRuleManager visibleRuleClasses collect: [:cl | cl new].
	checker
		rule: rule;
		environment: self package asEnvironment;
		run.
		
	self assert: (( checker toDoOf: ReTemporaryNeitherReadNorWrittenRule new) anySatisfy: [:each|
		each sourceAnchor entity = (MFClassB>>#method3)]).
	self deny: (( checker toDoOf: ReTemporaryNeitherReadNorWrittenRule new) anySatisfy: [:each|
		each  sourceAnchor entity = (MFClassB>>#method2)]).! !

!SmalllintManifestCheckerTest methodsFor: 'private' stamp: ''!
package 
	MCWorkingCopy managersForClass: MFClassA  do: [:p | ^ p packageSet packages first].
	" should be equivalent to RPackageOrganizer default packageNamed: #'Manifest-Resources-Tests' "! !

!SmalllintManifestCheckerTest methodsFor: 'running' stamp: ''!
setUp
	| bm |
	super setUp.
	self cleaningResources.
	bm := TheManifestBuilder of: MFClassA.
	bm installFalsePositiveOf: ReCodeCruftLeftInMethodsRule uniqueIdentifierName version: 1.
	bm addFalsePositive: MFClassB >> #method3 of: ReCodeCruftLeftInMethodsRule uniqueIdentifierName version: 1.
	bm installToDoOf: ReTemporaryNeitherReadNorWrittenRule uniqueIdentifierName version: 1.
	bm
		addAllToDo:
			{(MFClassB >> #method3).
			(MFClassA >> #method)}
		of: ReTemporaryNeitherReadNorWrittenRule uniqueIdentifierName
		version: 1.
	checker := ReSmalllintChecker new! !

!SmalltalkImage commentStamp: ''!
My singleton is a central entry point to the system.

It has many roles and responsibilities (to be documented)
- startup/shutdown image
- source management
- namespace access
- tool access
- platform access
- VM information and parameters	

###Startup

At startup and shutdown the image execute the methods startUp: and shutdown: of registered classes (registered using addToStartUpList:, addToShutDownList:, ... methods and friends).
	
Startup phases
During the first stage of start up the UI manager, the default uimanager is switched to a specific non interactive ui manager (`StartupUIManager`). Note that this specific non interactive UIManager kills the system on any attempt to open windows and interaction. So be warned, don't use interaction in the first phase. 
Then all registered classes execute their start up procedures (which should not imply interactive behavior). 
After startup list is finished, any deferred startup actions are executed, which you can add using the method
`addDeferredStartupAction:` method.  
!
!SmalltalkImage methodsFor: '*Tool-Profilers' stamp: ''!
profileStart: counter
	"Primitive. Begin profiling execution every by using the interrupt check-counter instead of a time-based process (which is limited to timing resolution and triggers off the same signal that many of the processes being profiled trigger off leading to consistently wrong results).
	The argument is the number of interrupt checks (method activations) to let go by before taking a sample. The sample is being stored in the profileSample iVar which can be retrieved by executing primitiveProfileSample. When a sample is taken, it signals the semaphore specified in primitiveProfileSemaphore.
	If the argument is less or equal to zero, it disables profiling."
	<primitive: 'primitiveProfileStart'>
	^self primitiveFailed! !

!SmalltalkImage methodsFor: 'system attribute' stamp: ''!
optionAt: i
	"Answer the i-th option of the command line, or nil if not so many options."
	
	^self  vm optionAt: i! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
allClasses  
	"Return all the class defines in the SmalltalkImage"
	"Smalltalk allClasses"
	"May be we could discard this one in the future"
	^ globals allClasses! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
version
	"Answer the version of this release."

	^SystemVersion current version! !

!SmalltalkImage methodsFor: 'miscellaneous' stamp: ''!
logError: errMsg inContext: aContext

	" we should think about integrating a toothpick here someday"
	self logStdErrorDuring: [ :stderr|
		"install the line end conversion and force initialize the converter"
		stderr
			nextPutAll: errMsg; cr;
			"reset the color"
			nextPut: Character escape; nextPutAll: '[0m'.
		aContext shortDebugStackOn: stderr.].
				
	self logDuring: [:logger | 
		logger	
			nextPutAll: 'THERE_BE_DRAGONS_HERE'; cr; 
		  	nextPutAll: errMsg; cr.
			"just print the error message if no context is given"
			aContext ifNotNil: [
				aContext errorReportOn: logger ].
		" write some type of separator"
		logger nextPutAll: (String new: 79 withAll: $- ); cr; cr]! !

!SmalltalkImage methodsFor: 'primitives' stamp: ''!
primImagePath
	"Answer the full path name for the current image."
	"Smalltalk imageName"

	<primitive: 121>
	self primitiveFailed! !

!SmalltalkImage methodsFor: 'housekeeping' stamp: ''!
fixObsoleteSharedPools
	self cleanOutUndeclared.
	self allClasses
		select: [ :class |
			class sharedPools isEmptyOrNil not and: [ 
				class sharedPools contains: #isObsolete ] ]
		thenDo: [ :class |
			| obsolete |
			obsolete := class sharedPools select: #isObsolete.
			class sharedPools removeAll: obsolete ].
		
	"#sharedPools is a lazy initializer and most classes don't have a shared pool.
	Resetting the shared pools to nil should therefore save a bit of space."
	self allClasses
		select: [ :class | class sharedPools isEmpty ]
		thenDo: [ :class | class sharedPools: nil ]! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
lastUpdateString
	"SmalltalkImage current lastUpdateString"
	
	^'Build information: ', SystemVersion current asString
! !

!SmalltalkImage methodsFor: 'testing' stamp: ''!
isHeadless
	"Check if vm were run with headless parameter.
	Different VMs for different platform have different multiple way(s) to indicate that"
	
	-1000 to: 1000 do: [ :n | 
		(#('display=none' '-headless' '-vm-display-null' '-nodisplay' '--headless' '--vm-display-null' '--nodisplay') 
			includes: (self vm getSystemAttribute: n)) 
				ifTrue: [ ^ true ]].
	^ false
	
	
! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: ''!
getFileNameFromUser

	| givenName strippedName imageFile changesFile |
	givenName := UIManager default
		request: 'New File Name?'
		initialAnswer: (self imageFile basename copyUpToLast:  Path extensionDelimiter).
	strippedName := self stripImageExtensionFrom: givenName.
	strippedName isEmptyOrNil ifTrue: [^nil].
	imageFile := self fileForImageNamed: strippedName.
	changesFile := self fileForChangesNamed: strippedName.
	((imageFile exists or: [changesFile exists]) and:
		[(self confirm: ('{1} already exists. Overwrite?' format: {strippedName})) not])
			ifTrue: [^nil].
	^strippedName! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
installLowSpaceWatcher
	"Start a process to watch for low-space conditions."

	"Smalltalk installLowSpaceWatcher"

	self primSignalAtBytesLeft: 0.	"disable low-space interrupts"
	LowSpaceProcess ifNotNil: [ LowSpaceProcess terminate ].
	LowSpaceProcess := [ self lowSpaceWatcher ] newProcess.
	LowSpaceProcess name: 'Low Space Watcher'.
	LowSpaceProcess priority: Processor lowIOPriority.
	LowSpaceProcess resume! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
at: aKey put: anObject 
	"Set the global at key to be anObject.  If key is not found, create a
	new entry for key and set is value to anObject. Answer anObject."

	^globals at: aKey put: anObject! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
unregisterExternalObject: anObject
	"Unregister the given object in the external objects array. Do nothing if it isn't registered."

	ExternalSemaphoreTable unregisterExternalObject: anObject! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
primLowSpaceSemaphore: aSemaphore
	"Primitive. Register the given Semaphore to be signalled when the
	number of free bytes drops below some threshold. Disable low-space
	interrupts if the argument is nil."

	<primitive: 124>
	self primitiveFailed! !

!SmalltalkImage methodsFor: 'cleanup' stamp: ''!
cleanUp: aggressive
	"Clean up. When aggressive is true, this will destroy change sets, etc."
	"Smalltalk cleanUp: false"
	"Smalltalk cleanUp: true"

	^self cleanUp: aggressive except: #()! !

!SmalltalkImage methodsFor: 'miscellaneous' stamp: ''!
logStdOutDuring: aBlock
	| stderr |
	"install the line end conversion and force initialize the converter"
	stderr := ZnNewLineWriterStream
		on: (ZnCharacterWriteStream on: Stdio stdout encoding: 'utf8').
	
	[aBlock value: stderr.] 
		on: Error do: [ "If the block fails we don't do nothing. This can lead to recursive errors" ].

	stderr flush.! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
timeStamp: aStream
	"Writes system version and current time on stream aStream."

	| dateTime |
	dateTime := DateAndTime now.
	aStream
		nextPutAll: 'From ' , self datedVersion , ' [' , self lastUpdateString , '] on ' , dateTime asDate printString;
		nextPutAll: ' at ';
		nextPutAll: dateTime asTime printString! !

!SmalltalkImage methodsFor: 'compiler' stamp: ''!
hasCompiler

	^ self compilerClass isNotNil! !

!SmalltalkImage methodsFor: 'system attribute' stamp: ''!
extractParameters

	| pName value index dict |
	dict := Dictionary new.
	index := 3. "Muss bei 3 starten, da 2 documentName ist"
	[pName := self vm getSystemAttribute: index.
	pName isEmptyOrNil] whileFalse:[
		index := index + 1.
		value := self vm getSystemAttribute: index.
		value ifNil: [value := ''].
 		dict at: pName asUppercase put: value.
		index := index + 1].
	^dict! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
imagePath: newPath
	"Set the the full path name for the current image.  All further snapshots will use this."

	self primImagePath: newPath utf8Encoded asString! !

!SmalltalkImage methodsFor: 'log' stamp: ''!
logFileName: newName

	LogFileName := newName! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
datedVersion
	"Answer the version of this release."

	^SystemVersion current datedVersion! !

!SmalltalkImage methodsFor: '*RPackage-Core' stamp: ''!
packages

	^ RPackageOrganizer default packages! !

!SmalltalkImage methodsFor: 'accessing' stamp: ''!
compilerClass
	^ self class compilerClass! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
garbageCollect
	"Primitive. Reclaims all garbage and answers the number of bytes of available space."
	Object flushDependents.
	^self primitiveGarbageCollect! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
bytesLeft: aBool
	"Return the amount of available space. If aBool is true, include possibly available swap space. If aBool is false, include possibly available physical memory. For a report on the largest free block currently available within Pharo memory but not counting extra memory use #primBytesLeft."
	<primitive: 112>
	^self primBytesLeft! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
primitiveGetSpecialObjectsArray
	<primitive: 129>
	^ self primitiveFailed! !

!SmalltalkImage methodsFor: 'system attributes' stamp: ''!
supportsQueueingFinalization: aBoolean
	"Determine whether the VM queues individual weak arrays for finalization, instead
	 of signalling the finalization semaphore once for all arrays and having the
	 WeakRegistry mechanism finalize all weak arrays, whether they need to or not.
	 This flag persists across snapshots, stored in the image header."
	"SmalltalkImage current supportsQueueingFinalization: true"

	self vm parameterAt: 48 put: ((self vm parameterAt: 48) bitClear: 16) + (aBoolean ifTrue: [16] ifFalse: [0])! !

!SmalltalkImage methodsFor: 'private' stamp: ''!
argumentsStartingAtIndex: anIndex
	"Answer an array with all the command line arguments"

	^ Array
		streamContents: [ :str | 
			| arg i |
			i := anIndex.
			[ i > 998 or: [ (arg := self argumentAt: i) isNil ] ]
				whileFalse: [ 
					str nextPut: arg.
					i := i + 1 ] ]! !

!SmalltalkImage methodsFor: 'housekeeping' stamp: ''!
fixObsoleteReferences
	"SmalltalkImage current fixObsoleteReferences.
	SystemNavigation new obsoleteBehaviors size > 0
		ifTrue: [ SystemNavigation new obsoleteBehaviors inspect.
			self error:'Still have obsolete behaviors. See inspector']"
		
	self
		garbageCollect;
		fixObsoleteBindings;
		fixObsoleteSharedPools.
	Behavior flushObsoleteSubclasses! !

!SmalltalkImage methodsFor: 'private' stamp: ''!
privSaveImageWithCleanup

	"Do not use this method for common image saving. This method is designated for saving the image during the shrinking process in headless images."

	20 timesRepeat: [
		(Delay forMilliseconds: 50) wait.
		Processor yield.
		Smalltalk garbageCollect. ].
 
	[
		self snapshot: true andQuit: true.
	] onErrorDo: [:e |
		'PharoDebug.log' asFileReference ensureDelete; writeStreamDo: [ :rep |
			rep nextPutAll: 'Error:'; cr.
			rep nextPutAll: e asString; cr.
	  		rep nextPutAll: thisContext stack size asString.
	 	  	thisContext stack copy withIndexDo: [:stck :i |
				[ rep nextPutAll: i asString; space; nextPutAll: stck asString; cr] onErrorDo: []]]. 
		Smalltalk exitFailure ]! !

!SmalltalkImage methodsFor: '*Tool-Profilers' stamp: ''!
profileSemaphore: aSemaphore
	"Primitive. Install the semaphore to be used for profiling, 
	or nil if no semaphore should be used.
	See also primitiveProfileStart."
	<primitive: 'primitiveProfileSemaphore'>
	^self primitiveFailed! !

!SmalltalkImage methodsFor: '*Tool-Profilers' stamp: ''!
highResClock	"Smalltalk highResClock"
	"Primitive. Answer the value of the high resolution clock if this computer has one.
	Usually, this should be the highest resolution value available, for example on Intel
	it will be the value of the time stamp counter register."
	<primitive: 'primitiveHighResClock'>
	^0! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
traitNames
	"Answer a SortedCollection of all traits (not including class-traits) names."
	
	^ globals traitNames! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
imageSuffix
	^ 'image'! !

!SmalltalkImage methodsFor: 'saving' stamp: ''!
backupImageInFileNamed: aFileReference
	"Save the  the image under the given file. 
	Unlike #saveImageInFileNamed: this method continues evaluation in the original image after saving a backup copy.
	Note: This method does not save the .changes file, use #saveAs:"
	
	| imageFile previousFullImageName isNewSession |
	
	imageFile := aFileReference asFileReference.
	imageFile parent ensureCreateDirectory.
	previousFullImageName := self imagePath.
	isNewSession := false.
	
	[
		"change to the new image name "
		self
			changeImagePathTo: imageFile fullName;
			closeSourceFiles;
			openSourceFiles.  "so SNAPSHOT appears in new changes file"
		
		isNewSession := self snapshot: true andQuit: false.
	] ensure: [
		isNewSession ifFalse: [
			"unlike #saveImageInFileNamed: we do NOT continue in the new image"
			"switch back to the old image"
			self 
				changeImagePathTo: previousFullImageName;
				closeSourceFiles;
				openSourceFiles ]].
		
	^ isNewSession.! !

!SmalltalkImage methodsFor: 'startup - shutdown' stamp: ''!
addToShutDownList: aClass
	"Startup and Shutdown are the responsibility of the SessionManager.
	If you need to register in a specific category, 
	Please use registration methods provided in SessionManager / registration category."
		
	SessionManager default registerUserClassNamed: aClass name.! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
compactClassesArray
	"Backward-compatibility support.  Spur does not have compact classes."
	^{}! !

!SmalltalkImage methodsFor: 'cleanup' stamp: ''!
cleanUp: aggressive except: exclusions confirming: aBool
	"Clean up. When aggressive is true, this will destroy resources, change sets, etc.
	Leave out any classes specifically listed in exclusions."

	"Smalltalk cleanUp: true except: {Point . ChangeSet} 
		- will ask for confirmation"
	"SmalltalkImage current cleanUp: true except: {} confirming: false 
		- will not ask for confirmation"

	| classes |
	aBool ifTrue:[
		"Give the user a chance to bail"
		(self confirm: 'Cleanup will destroy change sets and more.
Are you sure you want to proceed?') ifFalse: [^self]].

	"Find all classes implementing #cleanUp or cleanUp:"
	classes := Smalltalk allClasses select: [:aClass| 
		(aClass class includesSelector: #cleanUp) 
			or: [aClass class includesSelector: #cleanUp:]].

	"Leave out the classes in the exclusion set"
	classes := classes reject: [:aClass| exclusions includes: aClass].

	"Arrange classes in superclass order, superclasses before subclasses.
	This will ensure that specific cleanup (like MethodDictionary compaction)
	will run after generic superclass cleanup (HashedCollection rehashing).
	Otherwise generic superclass cleanup might undo specific one (in this
	case rehashing will undo a good bit of MD compaction)."
	classes := Class superclassOrder: classes.

	"Run the cleanup code"
	classes 
		do:[:aClass| aClass cleanUp: aggressive]
		displayingProgress: [:aClass| 'Cleaning up in ', aClass name].! !

!SmalltalkImage methodsFor: 'log' stamp: ''!
defaultLogFileName
 
	^ 'PharoDebug.log'! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
okayToProceedEvenIfSpaceIsLow
	"Return true if either there is enough memory to do so safely or if the user gives permission after being given fair warning."

	self garbageCollectMost > self lowSpaceThreshold ifTrue: [^ true].  "quick"
	self garbageCollect > self lowSpaceThreshold ifTrue: [^ true].  "work harder"

	^ self confirm:
'WARNING: There is not enough space to start the low space watcher.
If you proceed, you will not be warned again, and the system may
run out of memory and crash. If you do proceed, you can start the
low space notifier when more space becomes available simply by
opening and then closing a debugger (e.g., by hitting Cmd-period.)
Do you want to proceed?'
! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
shortImageName
	"Answer the current image name but only that name and not the full path as with imageName."
	"SmalltalkImage current shortImageName"

	^ self imageFile basename! !

!SmalltalkImage methodsFor: '*Renraku' stamp: ''!
reBanName
	^ 'The whole image'! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
imageDirectory
	"Answer the directory containing the current image."

	^ self imagePath asFileReference parent! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
renameClass: aClass as: newName 
	"Rename the class, aClass, to have the title newName."

	^globals renameClass: aClass as: newName! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
changeImagePathTo: aString
	
	self imagePath: aString.
	LastImagePath := self imagePath! !

!SmalltalkImage methodsFor: 'compiler' stamp: ''!
recompile
	Smalltalk globals allClassesAndTraits 
		do: [:classOrTrait | classOrTrait recompile] 
		displayingProgress: 'Recompiling all classes and traits'. ! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
closeSourceFiles
	"Shut down the source files if appropriate."

	SourceFiles close! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
classNamed: className
	^ globals classOrTraitNamed: className! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
allClassesAndTraits
	"Return all the classes and traits defined in the Smalltalk SmalltalkImage"

	^ globals allClassesAndTraits! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
licenseString
	^ self licenseStringTemplate format: (Array with: Date today year asString)! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
at: aKey ifAbsentPut: aBlock 
	"Return the global at the given key. 
	If key is not included in the receiver store the result 
	of evaluating aBlock as new value."

	^globals at: aKey ifAbsentPut: aBlock! !

!SmalltalkImage methodsFor: '*Polymorph-Widgets' stamp: ''!
ui 
	^ UIThemeRegistry! !

!SmalltalkImage methodsFor: 'image' stamp: ''!
wordSize
	"Answer the size in bytes of an object pointer or word in the object memory.
	The value does not change for a given image, but may be modified by a SystemTracer
	when converting the image to another format. The value is cached in WordSize to
	avoid the performance overhead of repeatedly consulting the VM."

	"this method is deprecated" 
	^ self vm wordSize! !

!SmalltalkImage methodsFor: '*Shift-ClassInstaller' stamp: ''!
classInstaller
	"Answer the class responsible of creating classes in the system."
	
	^ ShiftClassInstaller! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
newSpecialObjectsArray
	"Smalltalk recreateSpecialObjectsArray"
	
	"To external package developers:
	**** DO NOT OVERRIDE THIS METHOD.  *****
	If you are writing a plugin and need additional special object(s) for your own use, 
	use addGCRoot() function and use own, separate special objects registry "
	
	"The Special Objects Array is an array of objects used by the virtual machine.
	 Its contents are critical and accesses to it by the VM are unchecked, so don't even
	 think of playing here unless you know what you are doing."
	| newArray |
	newArray := Array new: 60.
	"Nil false and true get used throughout the interpreter"
	newArray at: 1 put: nil.
	newArray at: 2 put: false.
	newArray at: 3 put: true.
	"This association holds the active process (a ProcessScheduler)"
	newArray at: 4 put: (self globals associationAt: #Processor).
	"Numerous classes below used for type checking and instantiation"
	newArray at: 5 put: (self globals at: #Bitmap ifAbsent: [nil]).
	newArray at: 6 put: SmallInteger.
	newArray at: 7 put: ByteString.
	newArray at: 8 put: Array.
	newArray at: 9 put: Smalltalk.
	newArray at: 10 put: BoxedFloat64.
	newArray at: 11 put: (self globals at: #MethodContext ifAbsent: [self globals at: #Context]).
	newArray at: 12 put: nil. "was BlockContext."
	newArray at: 13 put: Point.
	newArray at: 14 put: LargePositiveInteger.
	newArray at: 15 put: (self globals at: #Display ifAbsent: [nil]).
	newArray at: 16 put: Message.
	newArray at: 17 put: CompiledMethod.
	newArray at: 18 put: ((self primitiveGetSpecialObjectsArray at: 18) ifNil: [Semaphore new]). "low space Semaphore"
	newArray at: 19 put: Semaphore.
	newArray at: 20 put: Character.
	newArray at: 21 put: #doesNotUnderstand:.
	newArray at: 22 put: #cannotReturn:.
	newArray at: 23 put: nil. "This is the process signalling low space."
	"An array of the 32 selectors that are compiled as special bytecodes,
	 paired alternately with the number of arguments each takes."
	newArray at: 24 put: #(	#+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1
							#* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1
							#at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0
							#'~~' 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ).
	"An array of the 255 Characters in ascii order.
	 Cog inlines table into machine code at: prim so do not regenerate it.
	 This is nil in Spur, which has immediate Characters."
	newArray at: 25 put: (self primitiveGetSpecialObjectsArray at: 25).
	newArray at: 26 put: #mustBeBoolean.
	newArray at: 27 put: ByteArray.
	newArray at: 28 put: Process.
	"An array of up to 31 classes whose instances will have compact headers; an empty array in Spur"
	newArray at: 29 put: {}.
	newArray at: 30 put: ((self primitiveGetSpecialObjectsArray at: 30) ifNil: [Semaphore new]). "delay Semaphore"
	newArray at: 31 put: ((self primitiveGetSpecialObjectsArray at: 31) ifNil: [Semaphore new]). "user interrupt Semaphore"
	"Entries 32 - 34 unreferenced. Previously these contained prototype instances to be copied for fast initialization"
	newArray at: 32 put: nil. "was the prototype Float"
	newArray at: 33 put: nil. "was the prototype 4-byte LargePositiveInteger"
	newArray at: 34 put: nil. "was the prototype Point"
	newArray at: 35 put: #cannotInterpret:.
	newArray at: 36 put: nil. "was the prototype MethodContext"
	newArray at: 37 put: BlockClosure.
	newArray at: 38 put: nil. "was the prototype BlockContext"
	"array of objects referred to by external code"
	newArray at: 39 put: (self primitiveGetSpecialObjectsArray at: 39).	"external semaphores"
	newArray at: 40 put: nil. "Reserved for Mutex in Cog VMs"
	newArray at: 41 put: ((self primitiveGetSpecialObjectsArray at: 41) ifNil: [ProcessList new]). "Reserved for a ProcessList instance for overlapped calls in CogMT"
	newArray at: 42 put: ((self primitiveGetSpecialObjectsArray at: 42) ifNil: [Semaphore new]). "finalization Semaphore"
	newArray at: 43 put: LargeNegativeInteger.
	"External objects for callout.
	 Note: Written so that one can actually completely remove the FFI."
	newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []).
	newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []).
	newArray at: 46 put: (self at: #ExternalData ifAbsent: []).
	newArray at: 47 put: nil.
	newArray at: 48 put: nil.
	newArray at: 49 put: #aboutToReturn:through:.
	newArray at: 50 put: #run:with:in:.
	"51 reserved for immutability message"
	newArray at: 51 put: #attemptToAssign:withIndex:.
	newArray at: 52 put: #(nil "nil => generic error" #'bad receiver'
							#'bad argument' #'bad index'
							#'bad number of arguments'
							#'inappropriate operation'  #'unsupported operation'
							#'no modification' #'insufficient object memory'
							#'insufficient C memory' #'not found' #'bad method'
							#'internal error in named primitive machinery'
							#'object may move' #'resource limit exceeded'
							#'object is pinned' #'primitive write beyond end of object'
							#'object moved' #'object not pinned' #'callback error'),
							{PrimitiveError new errorName: #'operating system error'; yourself}.

	newArray at: 53 put: nil.
	newArray at: 54 put: nil.
	newArray at: 55 put: nil.

	"Used to be WeakFinalizationList for WeakFinalizationList hasNewFinalization, obsoleted by ephemeron support."
	newArray at: 56 put: nil.

	"reserved for foreign callback process"
	newArray at: 57 put: (self primitiveGetSpecialObjectsArray at: 57 ifAbsent: []).

	newArray at: 58 put: #unusedBytecode.
	"59 reserved for Sista counter tripped message"
	newArray at: 59 put: #conditionalBranchCounterTrippedOn:.
	"60 reserved for Sista class trap message"
	newArray at: 60 put: #classTrapFor:.

	^newArray! !

!SmalltalkImage methodsFor: 'startup - shutdown' stamp: ''!
addToStartUpList: aClass
	"Startup and Shutdown are the responsibility of the SessionManager.
	If you need to register in a specific category, 
	Please use registration methods provided in SessionManager / registration category."

	SessionManager default registerUserClassNamed: aClass name.! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: ''!
exitFailure
	"Quit the VM with a failing signal.
	Will lose all current changes."
	self exit: 1! !

!SmalltalkImage methodsFor: 'saving' stamp: ''!
saveChangesInFileNamed: aString
	| changesFile |
	changesFile := aString asFileReference.
	changesFile parent ensureCreateDirectory.
	"Ensure that the destination file is not the same as the original one"
	(Smalltalk changesFile absolutePath = changesFile absolutePath)
		ifFalse: [ 
			changesFile deleteIfAbsent: [  ].
			Smalltalk changesFile copyTo: changesFile ].! !

!SmalltalkImage methodsFor: '*System-Platforms' stamp: 'nil'!
platform
	"Answer the object to query about os."
	
	^ self os! !

!SmalltalkImage methodsFor: '*Morphic-Base' stamp: ''!
aboutThisSystem
	"Identify software version"

	AboutDialogWindow openForPharo! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
clearExternalObjects
	"Clear the array of objects that have been registered for use in non-Smalltalk code."
	"Smalltalk clearExternalObjects"

	ExternalSemaphoreTable clearExternalObjects
! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
lastQuitLogPosition: aNumber
	"should be only use to ensure the transition from SystemDictionary to SmalltalkImage, then  	be removed"
		
	LastQuitLogPosition := aNumber! !

!SmalltalkImage methodsFor: 'housekeeping' stamp: ''!
removeAllLineFeedsQuietlyCalling: aBlock
	"Smalltalk removeAllLineFeedsQuietly"
	"Scan all methods for source code with lineFeeds.
	Replaces all occurrences of <CR><LF> or <LF> by <CR>.
	Answer a Dictionary keyed by author name containing sets of affected method names,
	as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters.
	Evaluate aBlock for each method so that status can be updated."
	| authors |
	authors := Dictionary new.
	authors at: 'OK' put: Set new.
	self systemNavigation
		allBehaviorsDo: [:cls | cls selectorsAndMethodsDo: [:selector :method |
					| oldStamp newCodeString oldCodeString oldCategory nameString | 
					aBlock cull: cls cull: selector.
					oldCodeString := cls sourceCodeAt: selector.
					(oldCodeString includes: Character lf)
						ifTrue: [
							newCodeString := oldCodeString withInternalLineEndings.
							nameString := cls name , '>>' , selector.
							((cls compiledMethodAt: selector) hasLiteralSuchThat: [ :lit | lit asString includes: Character lf ])
								ifTrue: [(authors at: 'OK')
										add: nameString]
								ifFalse: [oldStamp := (method timeStamp)
												copy replaceAll: Character cr
												with: Character space.
									(authors
										at: (oldStamp copyFrom: 1 to: (oldStamp findFirst: [ :c | c isAlphaNumeric not ]))
										ifAbsentPut: [Set new])
										add: nameString.
									oldCategory := cls whichCategoryIncludesSelector: selector.
									cls
										compile: newCodeString
										classified: oldCategory
										withStamp: oldStamp
										notifying: nil ]]]].
	^ authors! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
lowSpaceWatcher
	"Wait until the low space semaphore is signalled, then take appropriate
	actions. "
	| free preemptedProcess |
	self garbageCollectMost <= self lowSpaceThreshold
		ifTrue: [self garbageCollect <= self lowSpaceThreshold
				ifTrue: ["free space must be above threshold before
					starting low space watcher"
					^ self inform: 'Not enough memory to launch the lowSpaceWatcher.']].
	self specialObjectsArray at: 23 put: nil.
	"process causing low space will be saved here"
	LowSpaceSemaphore := Semaphore new.
	self primLowSpaceSemaphore: LowSpaceSemaphore.
	self primSignalAtBytesLeft: self lowSpaceThreshold.
	"enable low space interrupts"
	LowSpaceSemaphore wait.
	"wait for a low space condition..."
	self primSignalAtBytesLeft: 0.
	"disable low space interrupts"
	self primLowSpaceSemaphore: nil.
	LowSpaceProcess := nil.
	"The process that was active at the time of the low space interrupt."
	preemptedProcess := Smalltalk specialObjectsArray at: 23.
	Smalltalk specialObjectsArray at: 23 put: nil.
	"Note: user now unprotected until the low space watcher is re-installed"
	self memoryHogs isEmpty
		ifFalse: [free := self bytesLeft.
			self bytesLeft > free
				ifTrue: [^ self installLowSpaceWatcher]].
			
	UIManager default lowSpaceWatcherDefaultAction: preemptedProcess.
	"We need to reinstall the lowSpaceWatcher"	
	Smalltalk installLowSpaceWatcher.
! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
createStackOverflow
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; createStackOverflow"

	self createStackOverflow.  "infinite recursion"! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: ''!
snapshotPrimitive
	"Primitive. Write the current state of the object memory on a file in the
	same format as the Smalltalk-80 release. The file can later be resumed,
	returning you to this exact state. Return normally after writing the file.
	Essential. See Object documentation whatIsAPrimitive."
	
	"I will return 
		true if the image is starting or
		false if the image is just resuming"

	<primitive: 97>
	^nil "indicates error writing image file"! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
vmDirectory
	^ self vm directory! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
lowSpaceThreshold 
	"Return the low space threshold. When the amount of free memory (after garbage collection) falls below this limit, the system is in serious danger of completely exhausting memory and crashing. This limit should be made high enough to allow the user open a debugger to diagnose a problem or to save the image."

	^ 400000  "Enough for JIT compiler"! !

!SmalltalkImage methodsFor: 'private' stamp: ''!
sourceFileVersionString: aString

	SourceFileVersionString := aString! !

!SmalltalkImage methodsFor: 'saving' stamp: ''!
saveSession
	"Save the current image without quitting and return it resuming status (whether it was restarted or in the same flow)."
	
	^ self snapshot: true andQuit: false! !

!SmalltalkImage methodsFor: 'printing' stamp: ''!
printOn: aStream
	self == Smalltalk ifFalse: [^super printOn: aStream].
	aStream nextPutAll: 'Smalltalk'! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
recreateSpecialObjectsArray
	"Smalltalk recreateSpecialObjectsArray"
	
	"To external package developers:
	**** DO NOT OVERRIDE THIS METHOD.  *****
	If you are writing a plugin and need additional special object(s) for your own use, 
	use addGCRoot() function and use own, separate special objects registry "
	
	"The Special Objects Array is an array of objects used by the virtual machine.
	 Its contents are critical and accesses to it by the VM are unchecked, so don't even
	 think of playing here unless you know what you are doing."
	
	"Replace the interpreter's reference in one atomic operation"
	self specialObjectsArray becomeForward: self newSpecialObjectsArray.
	! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
sourcesName
	"Answer the full path to the version-stable source code"
	^ self sourcesFile fullName! !

!SmalltalkImage methodsFor: 'accessing' stamp: ''!
globals
	"Answer the global SystemDictionary"
	^globals! !

!SmalltalkImage methodsFor: 'saving' stamp: ''!
saveImageInFileNamed: aFile
	"Save the image in the given file.
	Unlike #backupImageInFileNamed: this method continues evaluation in the new image after saving.
	Note: This method does not save the .changes file, use #saveAs:"
	
	| imageFile |
	
	imageFile := aFile  asFileReference.
	imageFile parent ensureCreateDirectory.
	
	^self
		changeImagePathTo: imageFile fullName;
		closeSourceFiles;
		openSourceFiles;  "so SNAPSHOT appears in new changes file"
		snapshot: true andQuit: false! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: ''!
exitSuccess
	"Quit the VM with a success signal.
	Will lose all current changes."
	self exit: 0! !

!SmalltalkImage methodsFor: 'cleanup' stamp: ''!
restartMethods

	"Clean up. Long running loops or stored closures can lead to methods that are out if sync with the recompiled code"

	| classes |
	"Find all classes implementing #restartMethods"
	classes := self allClasses select: [ :aClass | 
		           aClass class includesSelector: #restartMethods ].
	"Arrange classes in superclass order, superclasses before subclasses"
	classes := Class superclassOrder: classes.
	"Run the cleanup code"
	classes do: [ :aClass | aClass restartMethods ]! !

!SmalltalkImage methodsFor: '*UnifiedFFI' stamp: ''!
getSystemAttribute: aNumber
	^ self vm getSystemAttribute: aNumber! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
classNames
	^globals classNames! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: ''!
exit: exitStatus
	"Primitive. Exit to another operating system on the host machine, if one
	exists. All state changes in the object space since the last snapshot are lost.
	Essential. See Object documentation whatIsAPrimitive.
	
	Possible values for exitStatus:
	0:   success
	> 1: error"

	<primitive: 113>
	self primitiveFailed! !

!SmalltalkImage methodsFor: '*Tool-Profilers' stamp: ''!
profileSample
	"Primitive. Answer the last sample taken by the profiler, or nil if the profiler isn't active.
	See also primitiveProfileStart."
	<primitive: 'primitiveProfileSample'>
	^self primitiveFailed! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
spaceLeftAfterGarbageCollection
	"Return a string describing the amount of memory available"
	| availInternal availPhysical availTotal |
	self garbageCollect.
	availInternal := self primBytesLeft.
	availPhysical := self bytesLeft: false.
	availTotal := self bytesLeft: true.
	(availTotal > (availInternal + 10000)) "compensate for mini allocations inbetween"
		ifFalse:[^availInternal asStringWithCommas, ' bytes available'].
	^String streamContents:[:s|
		availInternal printWithCommasOn: s.
		s nextPutAll: ' bytes (internal) '; cr.
		 availPhysical printWithCommasOn: s.
		s nextPutAll: ' bytes (physical) '; cr.
		availTotal printWithCommasOn: s.
		s nextPutAll: ' bytes (total)     '].! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
registerExternalObject: anObject
	"Register the given object in the external objects array and return its index. If it is already there, just return its index."

	^ExternalSemaphoreTable registerExternalObject: anObject! !

!SmalltalkImage methodsFor: 'accessing' stamp: ''!
compilerClass: aClass

	self class compilerClass: aClass! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
specialObjectsArray: anArray
	specialObjectsArray := anArray! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
changesName
	"Answer the name for the changes file corresponding to the image file name."
	"Smalltalk changesName"

	^ self changesFile fullName ! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
externalObjects
	"Return an array of objects that have been registered for use in non-Smalltalk code. Smalltalk objects should be referenced by external code only via indirection through this array, thus allowing the objects to move during compaction. This array can be cleared when the VM re-starts, since variables in external code do not survive snapshots. Note that external code should not attempt to access a Smalltalk object, even via this mechanism, while garbage collection is in progress."
	"Smalltalk externalObjects"

	^ ExternalSemaphoreTable externalObjects
! !

!SmalltalkImage methodsFor: 'system attribute' stamp: ''!
options
	"Answer an array with all the command line options."

	"Smalltalk commandLine options"

	^ Array
		streamContents: [ :str | 
			| arg i |
			i := 1.
			[ i > 1000 or: [ (arg := self optionAt: i) isNil ] ]
				whileFalse: [ 
					str nextPut: arg.
					i := i + 1 ] ]! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
lowSpaceWatcherProcess
	^LowSpaceProcess! !

!SmalltalkImage methodsFor: 'system attributes' stamp: ''!
maxIdentityHash
	"Answer the maximum identityHash value supported by the VM."
	<primitive: 176>
	^self primitiveFailed! !

!SmalltalkImage methodsFor: 'saving' stamp: ''!
backupTo: newNameWithoutSuffix
	"Create a new backup of this image. 
	Unlike #saveAs:, I do not transfer the default execution to the new image. 
	Results:
		true  when continuing in the new session
		false for the current session"
	(SourceFiles changesFileStream isNil or: [ SourceFiles changesFileStream closed ])
    ifFalse: [
		self 
			closeSourceFiles; "so copying the changes file will always work"
			saveChangesInFileNamed: (self fullNameForChangesNamed: newNameWithoutSuffix)].
	
	^self backupImageInFileNamed: (self fullNameForImageNamed: newNameWithoutSuffix)! !

!SmalltalkImage methodsFor: 'system attribute' stamp: ''!
maxFilenameLength

	^self vm maxFilenameLength! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
specialSelectorSize
	"Answer the number of special selectors in the system."

	^ (self specialObjectsArray at: 24) size // 2! !

!SmalltalkImage methodsFor: '*Tool-Base' stamp: ''!
resetTools

	Tools := nil! !

!SmalltalkImage methodsFor: '*FileSystem-Core' stamp: ''!
imageFile

	^ FileLocator image! !

!SmalltalkImage methodsFor: 'printing' stamp: ''!
isSelfEvaluating
	self == Smalltalk ifTrue: [^true].
	^super isSelfEvaluating! !

!SmalltalkImage methodsFor: 'housekeeping' stamp: ''!
cleanOutUndeclared 
	Undeclared removeUnreferencedKeys! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
licenseStringTemplate
	^ 'LICENSE
	
Licensed under the MIT License with parts under the Apache License.

Copyright (c) 2008-{1} The Pharo Project, and Contributors
Copyright (c) 2008-{1} Inria
Copyright (c) 1996-2008 Viewpoints Research Institute, and Contributors 
Copyright (c) 1996 Apple Computer, Inc.

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.

You may obtain a copy of the Apache License at
http://www.apache.org/licenses/LICENSE-2.0

Pharo uses icons by Mark James (http://www.famfamfam.com) under 
Creative Commons Attribution 2.5 License.

Pharo uses icons by Eclipse under 
Eclipse Public License - v 1.0
http://www.eclipse.org/legal/epl-v10.html

Pharo uses Source Code Pro Fonts by Adobe under 
SIL Open Font License, v 1.1
http://scripts.sil.org/OFL

Pharo uses Open Sans by Steve Matteson under 
Apache License, 2.0
http://www.apache.org/licenses/LICENSE-2.0.html

Pharo uses  Bitstream Vera Fonts
http://dejavu-fonts.org/wiki/index.php?title=License

Copyright (c) 2003 by Bitstream, Inc. All Rights Reserved. 
Bitstream Vera is a trademark of Bitstream, Inc.
Permission is hereby granted, free of charge, to any person obtaining a copy of the fonts 
accompanying this license ("Fonts") and associated documentation files (the "Font Software"), 
to reproduce and distribute the Font Software, including without limitation the rights to use, copy,
merge, publish, distribute, and/or sell copies of the Font Software, and to permit persons to whom 
the Font Software is furnished to do so, subject to the following conditions:
The above copyright and trademark notices and this permission notice shall be included in all 
copies of one or more of the Font Software typefaces.
The Font Software may be modified, altered, or added to, and in particular the designs of glyphs 
or characters in the Fonts may be modified and additional glyphs or characters may be added to
the Fonts, only if the fonts are renamed to names not containing either the words "Bitstream" 
or the word "Vera".
This License becomes null and void to the extent applicable to Fonts or Font Software that 
has been modified and is distributed under the "Bitstream Vera" names.
The Font Software may be sold as part of a larger software package but no copy of one or more
of the Font Software typefaces may be sold by itself.
THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, 
INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 
PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT 
SHALL BITSTREAM OR THE GNOME FOUNDATION BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 
INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN 
ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE 
FONT SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE.
Except as contained in this notice, the names of Gnome, the Gnome Foundation, 
and Bitstream Inc., shall not be used in advertising or otherwise to promote the sale,
use or other dealings in this Font Software without prior written authorization from 
the Gnome Foundation or Bitstream Inc., respectively. 
For further information, contact: fonts at gnome dot org.'! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
bytesLeft
	"Answer the number of bytes of space available. Does a full garbage collection."

	^ self garbageCollect
! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
renameClassNamed: oldName as: newName
	"Invoked from fileouts:  if there is currently a class in the system named oldName, then rename it to newName.  If anything untoward happens, report it in the Transcript.  "

	^ globals renameClassNamed: oldName as: newName! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
renameClass: aClass from: oldName
	"Rename the class, aClass, to have the title newName."

	^globals renameClass: aClass from: oldName! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
specialSelectors
	"Used by SystemTracer only."

	^SpecialSelectors! !

!SmalltalkImage methodsFor: 'shrinking' stamp: ''!
removeSelector: descriptor 
	"Safely remove a selector from a class (or metaclass). If the
	class or the method doesn't exist anymore, never mind and
	answer nil.
	This method should be used instead of 'Class removeSelector:
	#method' to omit global class references."
	| class sel |
	class := self
				at: descriptor first
				ifAbsent: [^ nil].
	(descriptor size > 2 and: [descriptor second == #class])
		ifTrue: 
			[class := class class.
			sel := descriptor third]
		ifFalse: 
			[sel := descriptor second].
	^ class removeSelector: sel! !

!SmalltalkImage methodsFor: 'primitives' stamp: ''!
primImagePath: newName
	"Set the the full path name for the current image.  All further snapshots will use this."

	<primitive: 121>
	^ self primitiveFailed! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
allClassesDo: aBlock
	"Evaluate the argument, aBlock, for each class in the system."

	globals allClassesDo: aBlock! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
fileForChangesNamed: aString

	^(self imageDirectory resolve: aString), self changesSuffix! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
signalLowSpace
	"Signal the low-space semaphore to alert the user that space is running low."

	LowSpaceSemaphore signal.! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
growMemoryByAtLeast: numBytes
	"Grow memory by at least the requested number of bytes.
	 Primitive.  Essential. Fail if no memory is available."
	<primitive: 180>
	(numBytes isInteger and: [numBytes > 0]) ifTrue:
		[OutOfMemory signal].
	^self primitiveFailed! !

!SmalltalkImage methodsFor: '*Tool-Profilers' stamp: ''!
profilePrimitive
	"Primitive. Answer the primitive sample by the profiler, or nil if the profiler isn't active.
	See also primitiveProfileStart."
	<primitive: 'primitiveProfilePrimitive'>
	^self primitiveFailed! !

!SmalltalkImage methodsFor: '*Reflectivity' stamp: ''!
metaLinkOptions
	^{
	#vm -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!SmalltalkImage methodsFor: 'image' stamp: ''!
image
	"Answer the object to query about the current object memory and execution environment."
	
	^self! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
garbageCollectMost
	"Primitive. Reclaims recently created garbage (which is usually most of it) fairly quickly and answers the number of bytes of available space."

	<primitive: 131>
	^ self primBytesLeft! !

!SmalltalkImage methodsFor: '*System-Platforms' stamp: 'nil'!
os
	"Answer the object to query about os."
	
	^ OSPlatform current! !

!SmalltalkImage methodsFor: 'accessing' stamp: ''!
vm
	"Answer the object to query about virtual machine."
	
	^ vm ifNil: [vm := VirtualMachine new]! !

!SmalltalkImage methodsFor: 'saving' stamp: ''!
stripImageExtensionFrom: aString

	| answer imageExtension delimitedImageExtension |
	answer := aString.
	imageExtension := Path extensionDelimiter asString, self imageSuffix.
	delimitedImageExtension := imageExtension copyWith: Path extensionDelimiter.
	[answer isNil not and: [(answer endsWith: imageExtension) or: [answer endsWith: delimitedImageExtension]]]
		whileTrue: [answer := answer copyUpToLast: Path extensionDelimiter].
	^answer! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
fullNameForImageNamed: aString

	^(self fileForImageNamed: aString) fullName! !

!SmalltalkImage methodsFor: 'miscellaneous' stamp: ''!
logDuring: aMonadicBlock
	" for safe use, if stream is a file, it needs to be closed after use " 
	| logStream |	

	[
		logStream := self openLog.
		aMonadicBlock value: logStream.
	] ensure: [ self closeLog: logStream ].

! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
primBytesLeft
	"Primitive. Answer the number of free bytes available in old space.
	 Not accurate unless preceded by
		Smalltalk garbageCollectMost (for reasonable accuracy), or
		Smalltalk garbageCollect (for real accuracy).
	 See Object documentation whatIsAPrimitive."

	<primitive: 112>
	^0! !

!SmalltalkImage methodsFor: 'system attribute' stamp: ''!
commandLine
	"Answer the object to query about command line."
	
	^self! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
fullNameForChangesNamed: aString

	^(self fileForChangesNamed: aString) fullName! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
at: key ifAbsent: aBlock
	"Answer the global associated with the key or, if key isn't found,
	answer the result of evaluating aBlock."

	^globals at: key ifAbsent: aBlock! !

!SmalltalkImage methodsFor: 'housekeeping' stamp: ''!
informSpaceLeftAfterGarbageCollection
	"Do a garbage collection, and report results to the user."

	"SmalltalkImage current informSpaceLeftAfterGarbageCollection"

	self inform: self spaceLeftAfterGarbageCollection! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
changesSuffix
	^ 'changes'! !

!SmalltalkImage methodsFor: 'system attributes' stamp: ''!
supportsQueueingFinalization
	"Determine whether the VM queues individual weak arrays for finalization, instead
	 of signalling the finalization semaphore once for all arrays and having the
	 WeakRegistry mechanism finalize all weak arrays, whether they need to or not.
	 This flag persists across snapshots, stored in the image header."
	"SmalltalkImage current supportsQueueingFinalization"

	^ ((self vm parameterAt: 48) bitAnd: 16) = 16! !

!SmalltalkImage methodsFor: '*FileSystem-Core' stamp: ''!
changesFile
	"Answer the file containing the current changes."

	^ FileLocator changes! !

!SmalltalkImage methodsFor: 'housekeeping' stamp: ''!
removeAllLineFeedsQuietly
	"Smalltalk removeAllLineFeedsQuietly"
	"Scan all methods for source code with lineFeeds.
	Replaces all occurrences of <CR><LF> or <LF> by <CR>.
	Answer a Dictionary keyed by author name containing sets of affected method names,
	as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters."
	^self removeAllLineFeedsQuietlyCalling: [].! !

!SmalltalkImage methodsFor: 'system attribute' stamp: ''!
extractMinusParametersFrom: arguments
	| dict previous previousWithMinus args |
	dict := Dictionary new.
	arguments isEmptyOrNil
		ifTrue: [ ^ dict ].
	args := OrderedCollection withAll: arguments.
	previous := previousWithMinus := args detect: [ :each | each first = $- ] ifNone: [ String space ].
	[ args isEmpty or: [ args first = previous ] ]
		whileFalse: [ 
			dict at: #* put: (dict at: #* ifAbsent: [ #() ]) , (Array with: args first).
			args removeFirst ].
	args
		do: [ :each | 
			each first = $-
				ifTrue: [ 
					previous first = $-
						ifTrue: [ dict at: previous allButFirst put: #() ].
					previousWithMinus := each ]
				ifFalse: [ 
					dict
						at: previousWithMinus allButFirst
						put: (dict at: previousWithMinus allButFirst ifAbsent: [ #() ]) , (Array with: each) ].
			previous := each ].
	previous first = $-
		ifTrue: [ dict at: previous allButFirst put: #() ].
	^ dict! !

!SmalltalkImage methodsFor: '*System-Platforms' stamp: 'nil'!
platformName
	^ self os platformName! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: ''!
snapshot: save andQuit: quit
	DefaultExecutionEnvironment beActiveDuring: 
		 [^SessionManager default snapshot: save andQuit: quit]! !

!SmalltalkImage methodsFor: 'miscellaneous' stamp: ''!
logStdErrorDuring: aBlock
	| stderr |
	[
		"install the line end conversion and force initialize the converter"
		stderr := ZnNewLineWriterStream on: (ZnCharacterWriteStream
			on: Stdio stderr
			encoding: 'utf8').
		
		"log in red"
		stderr nextPut: Character escape; nextPutAll: '[31m'.
		"rund the loggin block"
		aBlock value: stderr.
		"reset the coloring"
		stderr nextPut: Character escape; nextPutAll: '[0m'.
	] on: Error do: [ :e| "we don't care if the logging to stdout fails..." ].! !

!SmalltalkImage methodsFor: '*Shift-ClassInstaller' stamp: ''!
anonymousClassInstaller
	"Answer the class responsible of creating classes in the system."
	
	^ ShiftAnonymousClassInstaller! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
allClassesAndTraitsDo: aBlock
	^globals allClassesAndTraitsDo: aBlock! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: ''!
shutDown
	^ self closeSourceFiles! !

!SmalltalkImage methodsFor: 'miscellaneous' stamp: ''!
exitToDebugger
	"Primitive. Enter the machine language debugger, if one exists. Essential.
	See Object documentation whatIsAPrimitive."

	<primitive: 114>
	self primitiveFailed! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
fileForImageNamed: aString

	^(self imageDirectory resolve: aString), self imageSuffix! !

!SmalltalkImage methodsFor: 'saving' stamp: ''!
saveAs: newNameWithoutSuffix
	"Results:
		true  when continuing in the new session
		false for the current session "

	newNameWithoutSuffix ifNil: [ ^ self ].
  (SourceFiles changesFileStream isNil or: [ SourceFiles changesFileStream closed ])
    ifFalse: [ 
		self closeSourceFiles.
		self saveChangesInFileNamed: (self fullNameForChangesNamed: newNameWithoutSuffix)	
		"so copying the changes file will always work" ].

	^ self saveImageInFileNamed: (self fullNameForImageNamed: newNameWithoutSuffix)! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
systemInformationString
	^ String cr, 'Pharo ', SystemVersion current dottedMajorMinorPatch,  String cr, self lastUpdateString, String cr, String cr, String cr, self licenseString! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
sourcesSuffix
	^ 'sources'! !

!SmalltalkImage methodsFor: 'accessing' stamp: ''!
session
	^ SessionManager default currentSession! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
specialSelectorAt: anInteger 
	"Answer the special message selector from the interleaved specialSelectors array."

	^ (self specialObjectsArray at: 24) at: anInteger * 2 - 1! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
at: key ifPresent: aBlock
	"Lookup the given key in the globals. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil."

	^globals at: key ifPresent: aBlock! !

!SmalltalkImage methodsFor: 'accessing' stamp: ''!
environment
	"For conversion from Smalltalk to SystemDictionary"

	^globals! !

!SmalltalkImage methodsFor: '*Shift-ClassInstaller' stamp: ''!
classBuilder
	"Answer the object responsible of creating subclasses of myself in the system."
	
	^ self classInstaller new builder! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
imagePath
	"Answer the full path name for the current image."

	"SmalltalkImage current imagePath"

	^ self primImagePath asByteArray utf8Decoded ! !

!SmalltalkImage methodsFor: 'saving' stamp: ''!
saveAsNewVersion
	"Save the image/changes using the next available version number."

	"SmalltalkImage current saveAsNewVersion"

	| newImageFile strippedName |
	newImageFile := self imageFile nextVersion.
	(newImageFile withExtension: self changesSuffix)
		ifExists: [ :newChangesFile | 
			^ self
				inform:
					'There is already .changes file of the desired name,
' , newChangesFile fullName , '
curiously already present, even though there is
no corresponding .' , self imageSuffix , ' file.   Please remedy
manually and then repeat your request.' ].

	strippedName := self stripImageExtensionFrom: newImageFile fullName.
	^ self saveAs: strippedName! !

!SmalltalkImage methodsFor: 'testing' stamp: ''!
isInteractiveGraphic
	"Check if vm were run headless and with interactive (graphics) parameter.
	 Using the headless VM, the need of a GUI environment is indicated by sending --interactive 
	 parameter to the image."
	
	"non-headless mode is always interactive"
	self isHeadless ifFalse: [ ^ true ].

	-1000 to: 1000 do: [ :n | 
		(#('--interactive') includes: (self vm getSystemAttribute: n)) 
			ifTrue: [ ^ true ]].

	^ false! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
sourceFileVersionString

	^ SourceFileVersionString! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
allTraits
	"Return all traits defined in the Smalltalk SmalltalkImage"

	^globals allTraits! !

!SmalltalkImage methodsFor: 'private' stamp: ''!
argumentsInclude: aString

	^ (self argumentsStartingAtIndex: 0) includes: aString! !

!SmalltalkImage methodsFor: 'system attribute' stamp: ''!
arguments
	"Answer an array with all the command line arguments.
	This does not include imagePath, documentPath nor any option."

	"Smalltalk commandLine arguments"

	^ self argumentsStartingAtIndex: 1! !

!SmalltalkImage methodsFor: 'testing' stamp: ''!
isInteractive
	"Check if vm were run with headless parameter.
	Different VMs for different platform have different multiple way(s) to indicate that"
	
	"non-headless mode is always interactive"
	self isHeadless ifFalse: [ ^ true ].
	
	-1000 to: 1000 do: [ :n | 
		(#('-interactive') includes: (self vm getSystemAttribute: n)) 
			ifTrue: [ ^ true ]].
	
	^ false! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: ''!
quitPrimitive
	"Primitive. Exit to another operating system on the host machine, if one
	exists. All state changes in the object space since the last snapshot are lost.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 113>
	self primitiveFailed! !

!SmalltalkImage methodsFor: 'compiler' stamp: ''!
compiler
	^self compilerClass new
		environment: self globals! !

!SmalltalkImage methodsFor: 'saving' stamp: ''!
saveImageInNewContext

	" This method is used for saving the Smalltalk image in a new process so the current process with all stack information may be forgotten.
	
	Do not use this method for common image saving. This method is designated for saving the image during the shrinking process in headless images. "

	[ self privSaveImageWithCleanup ] forkAt: 40.! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
hasClassNamed: aString
	"Answer whether there is a class of the given name, but don't intern aString if it's not already interned."

	^ globals hasClassNamed: aString! !

!SmalltalkImage methodsFor: 'external' stamp: ''!
unbindExternalPrimitives
	"Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found."
	<primitive: 570>
	"Do nothing if the primitive fails for compatibility with older VMs"
! !

!SmalltalkImage methodsFor: 'housekeeping' stamp: ''!
fixObsoleteBindings
	CompiledMethod allInstances do: [ :method |
		| obsoleteBindings |
		
		"Added to check because sometimes the bootstrap fails to generate some methods."
		self assert: (method header isKindOf: SmallInteger) description: (method name , ' has an invalid header:' , method header asString).
		
		obsoleteBindings := method literals select: [ :literal |
				literal isVariableBinding and: [
					literal value isBehavior and: [ 
						literal value isObsolete ] ] ].
		obsoleteBindings do: [ :binding |
			| obsName realName realClass |
			obsName := binding value name.
			self 
				trace: 'Binding: ';
				traceCr: obsName.
			realName := obsName copyReplaceAll: 'AnObsolete' with: ''.
			realClass := Smalltalk globals at: realName asSymbol ifAbsent: [ UndefinedObject ].
			binding key: binding key value: realClass ].
		"do not forget to flush the JIT cache"
		obsoleteBindings ifNotEmpty: [ method flushCache ] ]! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
removeClassNamed: aName
	"Invoked from fileouts:  if there is currently a class in the system named aName, then remove it.  If anything untoward happens, report it in the Transcript.  "

	globals removeClassNamed: aName! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
at: key ifPresent: aBlock ifAbsent: anotherBlock
	"Lookup the given key in the globals. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise answer the value of the second block."

	^ globals at: key ifPresent: aBlock ifAbsent: anotherBlock! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
includesKey: key
	"Answer whether the receiver has a key equal to the argument, key."

	^globals includesKey: key! !

!SmalltalkImage methodsFor: 'system attribute' stamp: ''!
extractMinusParameters
	"Returns a dictionary matching parameters beginning by a minus character and the list of the next parameters.
	Here is an example: 
		I suppose I run pharo with: `pharo myImage.image 1 2 3 woah -minus1 'Hello' -minus2 -minus3 'Hello' 'World'`.
		This message will return a dictionary with: 
			* --> #(1 2 3 'woah')
			minus1 --> #('Hello')
			minus2 --> #()
			minus3 --> #('Hello' 'World')"
			
	| args str index |
	
	args := OrderedCollection new.

	str := self getSystemAttribute: (index := 2).
	[ str isNil ] whileFalse: [ args add: str. str := self getSystemAttribute: (index := index + 1) ].

	^ self extractMinusParametersFrom: args! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
specialSelectorIndexOrNil: selector
	1 to: Smalltalk specialSelectorSize do:
		[:index | 
		(Smalltalk specialSelectorAt: index) == selector
			ifTrue: [^index ]].	
	^ nil! !

!SmalltalkImage methodsFor: '*Tool-Profilers' stamp: ''!
reportCPUandRAM
	"Write several text files with useful analysis for profiling purposes.
	Overwrites any existing report.
	SmalltalkImage current reportCPUandRAM
	"	

	"VM statistics (Memory use and GC, mainly)"
	'Log-MemoryStats.txt' asFileReference writeStreamDo: [ :aStream | 
		aStream nextPutAll: self vm statisticsReport ].
	
	"Process list"
	'Log-ProcessList.txt' asFileReference writeStreamDo: [ :aStream |
		self tools processBrowser new processNameList do: [ :each | 
			aStream nextPutAll: each; cr ] ].

"Fork all these, so they run in sequence, as the system is back running"
[
	"Process taking most CPU"
	'Log-ThePig.txt' asFileReference writeStreamDo: [ :aStream |
		self tools processBrowser dumpPigStackOn: aStream ].
	
	"Tally of all processes"
	'Log-FullTally.txt' asFileReference writeStreamDo: [ :aStream |
		| tally |
		tally := MessageTally new.
		tally reportOtherProcesses: true.
		tally spyAllEvery: 1 on: [ (Delay forMilliseconds: 1000) wait ].
		tally report: aStream ].

	"Memory Analysis"
	'Log-MemoryAnalysis.txt' asFileReference writeStreamDo: [ :aStream |
		SpaceTally printSpaceAnalysis: 1 on: aStream ]

] forkNamed: 'CPU usage analysis'! !

!SmalltalkImage methodsFor: 'miscellaneous' stamp: ''!
closeLog: logger
	"This is a _private_ method,
	Because it really belongs to logging facility,
	we should delegate to it at some point "
	
	logger ifNotNil: [ logger close ]
! !

!SmalltalkImage methodsFor: 'private' stamp: ''!
globals: aSystemDictionary
	"Sets the system-wide globals"
	
	globals ifNotNil: [self error: 'Cannot overwrite existing globals'].
	globals := aSystemDictionary! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
bindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver"

	^globals bindingOf: varName! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
classOrTraitNamed: aString
	"aString is either a class or trait name or a class or trait name followed by ' class' or 'classTrait' respectively. Answer the class or metaclass it names."

	^ globals classOrTraitNamed: aString! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
at: aKey
	"Answer the global associated with the key."

	^globals at: aKey! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
specialObjectsArray
	^specialObjectsArray ifNil: [ specialObjectsArray := self primitiveGetSpecialObjectsArray ].! !

!SmalltalkImage methodsFor: 'miscellaneous' stamp: ''!
metacelloPlatformAttributes
    "Returns the tags for the conditional platform loading in Metacello. Pay attention the order is important: from most  to least general." 
 
   ^ #(#squeakCommon #pharo #'pharo9.x' #'pharo9.0.x' #'pharo10.x'  #'pharo10.0.x')! !

!SmalltalkImage methodsFor: 'log' stamp: ''!
logFileName

	^ LogFileName ifNil: [ self defaultLogFileName ] ! !

!SmalltalkImage methodsFor: 'accessing' stamp: ''!
lastImagePath
	^ LastImagePath! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
primSignalAtBytesLeft: numBytes
	"Tell the interpreter the low-space threshold in bytes. When the free
	space falls below this threshold, the interpreter will signal the low-space
	semaphore, if one has been registered.  Disable low-space interrupts if the
	argument is zero.  Fail if numBytes is not an Integer."

	<primitive: 125>
	self primitiveFailed! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: ''!
recordStartupStamp
	
	ChangesLog default recordStartupStamp! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
sourcesFile
	"Answer the full path to the version-stable source code"
	^ self imageDirectory / (SourceFileVersionString , '.', self sourcesSuffix)! !

!SmalltalkImage methodsFor: 'cleanup' stamp: ''!
cleanUp: aggressive except: exclusions
	"Clean up. When aggressive is true, this will destroy resources, change sets, etc.
	Leave out any classes specifically listed in exclusions."

	"Smalltalk cleanUp: true except: {Point . ChangeSet}"

	^self cleanUp: aggressive except: exclusions confirming: aggressive! !

!SmalltalkImage methodsFor: 'image' stamp: ''!
imageFormatVersion
	"Answer an integer identifying the type of image. The image version number may
	identify the format of the image (e.g. 32 or 64-bit word size) or specific requirements
	of the image (e.g. block closure support required). This invokes an optional primitive
	that may not be available on all virtual machines."

	"Smalltalk image imageFormatVersion"

	<primitive: 'primitiveImageFormatVersion'>
	self notify: 'This virtual machine does not support the optional primitive #primitiveImageFormatVersion'.
	^''! !

!SmalltalkImage methodsFor: 'housekeeping' stamp: ''!
removeEmptyMessageCategories
	"Smalltalk removeEmptyMessageCategories"
	self garbageCollect.
	ClassOrganization allInstancesDo: [ :org | org removeEmptyCategories ].
	SystemOrganization removeEmptyCategories.! !

!SmalltalkImage methodsFor: 'special objects' stamp: ''!
specialNargsAt: anInteger 
	"Answer the number of arguments for the special selector at: anInteger."

	^ (self specialObjectsArray at: 24) at: anInteger * 2! !

!SmalltalkImage methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !

!SmalltalkImage methodsFor: 'class and trait names' stamp: ''!
organization
	"Return the organizer for the receiver"
	^globals organization! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
openSourceFiles

	self imagePath = LastImagePath 
		ifFalse: ["Reset the author full name to blank when the image gets moved"
			LastImagePath := self imagePath.
			Author reset].

	SourceFiles ensureOpen.! !

!SmalltalkImage methodsFor: 'image, changes name' stamp: ''!
vmBinary
	^ self vm binary! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
primitiveGarbageCollect
	"Primitive. Reclaims all garbage and answers the size of the largest free chunk in old space.."

	<primitive: 130>
	^self primitiveFailed! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
argumentAt: i
	"Answer the i-th argument of the command line, or nil if not so many argument."
	
	^self vm getSystemAttribute: 2 + i! !

!SmalltalkImage methodsFor: 'to clean later' stamp: ''!
flushClassNameCache
	"Smalltalk flushClassNameCache"
	"Force recomputation of the cached list of class names."

	globals flushClassNameCache.! !

!SmalltalkImage methodsFor: 'miscellaneous' stamp: ''!
openLog
	"This is a _private_ method,
	Because it really belongs to logging facility,
	we should delegate to it at some point "

	^ [ZnNewLineWriterStream on: (ZnCharacterWriteStream
		on:
			((File named: Smalltalk logFileName) writeStream
				setToEnd;
				yourself)
		encoding: 'utf8')] on: FileException do: [ NullStream new ]! !

!SmalltalkImage methodsFor: '*Tool-Registry' stamp: ''!
tools

	^ Tools ifNil: [
		Tools := PharoCommonTools new ]! !

!SmalltalkImage methodsFor: 'sources, change log' stamp: ''!
lastQuitLogPosition
	^ LastQuitLogPosition! !

!SmalltalkImage methodsFor: 'cleanup' stamp: ''!
cleanUp	
	"Smalltalk cleanUp"
	"Gently clean up"
	
	^self cleanUp: false! !

!SmalltalkImage methodsFor: 'memory space' stamp: ''!
memoryHogs
	"Answer the list of objects to notify with #freeSomeSpace if memory gets full."

	^ MemoryHogs ifNil: [MemoryHogs := OrderedCollection new]! !

!SmalltalkImage methodsFor: 'saving' stamp: ''!
saveAs
	"Put up the 'saveAs' prompt, obtain a name, and save the image  under that new name."

	self saveAs: self getFileNameFromUser! !

!SmalltalkImage class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Use current'.! !

!SmalltalkImage class methodsFor: 'system startup' stamp: ''!
shutDown: isImageClosing

	isImageClosing ifTrue: [ SourceFiles close ].! !

!SmalltalkImage class methodsFor: 'instance creation' stamp: ''!
current
	^Smalltalk! !

!SmalltalkImage class methodsFor: 'settings' stamp: ''!
compilerClass

	^CompilerClass ifNil: [ 
		"use OpalCompiler as the fallback compiler if installed"
		self class environment at: #OpalCompiler ifAbsent: [ nil ] ]! !

!SmalltalkImage class methodsFor: 'settings' stamp: ''!
compilerClass: aClass
	CompilerClass := aClass! !

!SmalltalkImage class methodsFor: 'system startup' stamp: ''!
startUp: isImageStarting
	
	ChangesLog default! !

!SmalltalkImage class methodsFor: 'image' stamp: ''!
wordSize
	^ Smalltalk vm wordSize! !

!SmalltalkImage class methodsFor: 'cleanup' stamp: ''!
cleanUp
	"Flush caches"
	
	"should probably distribute cleaning to systemDictionary"
	
	Smalltalk globals flushClassNameCache.
	Undeclared removeUnreferencedKeys! !

!SmalltalkImageTest commentStamp: ''!
Tests for SmalltalkImage!
!SmalltalkImageTest methodsFor: 'tests' stamp: ''!
testOpenLog
	"It must be possible to write to the log even when the log file can''t be created."

	"Standard case where a file can be created with this name."
	self writeToLogWithFileNamed: 'file.log'.

	"Other cases where a file with the given name can not be created."
	self 
		writeToLogWithFileNamed: '';
		writeToLogWithFileNamed: '.'.
		
	"clean the created log file"	
	'file.log' asFileReference ensureDelete
! !

!SmalltalkImageTest methodsFor: 'tests - arguments' stamp: ''!
testExtractTwoArgsWithAndWithoutMinus

	| args extract keys |
	args := #('ArgWithoutMinus' '-ArgWithMinus').
	extract := SmalltalkImage current extractMinusParametersFrom: args.
	keys := extract keys sort.
	self assert: extract isDictionary.
	self assert: extract size equals: 2.
	self assert: (keys at: 1) equals: #*.
	self assert: (keys at: 2) equals: #ArgWithMinus.
	self assert: (extract at: #*) equals: (Array with: 'ArgWithoutMinus').
	self assertEmpty: (extract at: #ArgWithMinus)! !

!SmalltalkImageTest methodsFor: 'tests - arguments' stamp: ''!
testExtractAllKinds

	| args extract keys |
	args := #('ArgWithoutMinus1' '-ArgWithMinus1' 'ArgWithoutMinus2' 'ArgWithoutMinus3' '-ArgWithMinus2').
	extract := SmalltalkImage current extractMinusParametersFrom: args.
	keys := extract keys sort.
	self assert: extract isDictionary.
	self assert: extract size equals: 3.
	self assert: (keys at: 1) equals: #*.
	self assert: (keys at: 2) equals: #ArgWithMinus1.
	self assert: (keys at: 3) equals: #ArgWithMinus2.
	self assert: (extract at: #*) equals: (Array with: 'ArgWithoutMinus1').
	self assert: (extract at: #ArgWithMinus1) equals: #('ArgWithoutMinus2' 'ArgWithoutMinus3').
	self assertEmpty: (extract at: #ArgWithMinus2)! !

!SmalltalkImageTest methodsFor: 'tests - arguments' stamp: ''!
testExtractOneArgWithMinusThenArgsWithout

	| args extract |
	args := #('-ArgWithMinus' 'ArgWithoutMinus1' 'ArgWithoutMinus2').
	extract := SmalltalkImage current extractMinusParametersFrom: args.
	self assert: extract isDictionary.
	self assert: extract size equals: 1.
	self assert: (extract keys at: 1) equals: #ArgWithMinus.
	self assert: (extract at: #ArgWithMinus) equals: #('ArgWithoutMinus1' 'ArgWithoutMinus2')! !

!SmalltalkImageTest methodsFor: 'tests - arguments' stamp: ''!
testExtractNil

	| args extract |
	args := nil.
	extract := SmalltalkImage current extractMinusParametersFrom: args.
	self assert: extract class equals: Dictionary.
	self assertEmpty: extract! !

!SmalltalkImageTest methodsFor: 'tests - arguments' stamp: ''!
testExtractEmpty

	| args extract |
	args := #().
	extract := SmalltalkImage current extractMinusParametersFrom: args.
	self assert: extract class equals: Dictionary.
	self assertEmpty: extract! !

!SmalltalkImageTest methodsFor: 'utilities' stamp: ''!
writeToLogWithFileNamed: filename
	| oldLogFileName |
	oldLogFileName := Smalltalk logFileName.
	Smalltalk logFileName: filename.
	[ 
	| stream |
	stream := Smalltalk image openLog.
	stream nextPutAll: 'foobar'."We just make sure we can write something. I don't know any reliable way to check if it has really been written"
	Smalltalk closeLog: stream ]
		ensure: [ Smalltalk logFileName: oldLogFileName ]! !

!SmalltalkImageTest methodsFor: 'tests - arguments' stamp: ''!
testAtIfPresentIfAbsent

	| image |
	image := SmalltalkImage current.
	self assert: (image at: self class name asSymbol ifPresent: [ :c | true ] ifAbsent: [ false ]).
	self deny: (image at: #ImprobableClassNameForTest124029 ifPresent: [ :c | true ] ifAbsent: [ false ])! !

!SmalltalkImageTest methodsFor: 'tests - arguments' stamp: ''!
testExtractOneArgWithMinus

	| args extract |
	args := #('-ArgWithMinus').
	extract := SmalltalkImage current extractMinusParametersFrom: args.
	self assert: extract isDictionary.
	self assert: extract size equals: 1.
	self assert: (extract keys at: 1) equals: #ArgWithMinus.
	self assertEmpty: (extract at: #ArgWithMinus)! !

!SmalltalkImageTest methodsFor: 'tests - arguments' stamp: ''!
testExtractOneArgNoMinus

	| args extract |
	args := #('ArgNoMinus').
	extract := SmalltalkImage current extractMinusParametersFrom: args.
	self assert: extract isDictionary.
	self assert: extract size equals: 1.
	self assert: (extract keys at: 1) equals: #*.
	self assert: (extract at: #*) equals: args! !

!SnapshotDone commentStamp: ''!
I am announced when the image has been saved. 

Note that the announcement is done *after* the execution was frozen. So you can send me #isNewImage to know if the current image instance is the same that started the save action.!
!SnapshotDone methodsFor: 'accessing' stamp: ''!
isNewImage: anObject
	isNewImage := anObject! !

!SnapshotDone methodsFor: '*Calypso-SystemQueries' stamp: ''!
shouldBeConsideredByCalypsoEnvironment
	^false! !

!SnapshotDone methodsFor: 'accessing' stamp: ''!
isNewImage
	^ isNewImage! !

!SnapshotDone class methodsFor: 'instance creation' stamp: ''!
isNewImage: aBoolean
	 ^ self new isNewImage: aBoolean.! !

!Socket commentStamp: ''!
A Socket represents a network connection point. Current sockets are designed to support the TCP/IP and UDP protocols. Sockets are the lowest level of networking object in Pharo and are not normally used directly. SocketStream is a higher level object wrapping a Socket in a stream like protocol.

ProtocolClient and subclasses are in turn wrappers around a SocketStream to provide support for specific network protocols such as POP, NNTP, HTTP, and FTP.!
!Socket methodsFor: 'sending' stamp: ''!
sendData: buffer count: n
	"Send the amount of data from the given buffer"
	| sent |
	sent := 0.
	[sent < n] whileTrue:[
		sent := sent + (self sendSomeData: buffer startIndex: sent+1 count: (n-sent))].! !

!Socket methodsFor: 'primitives' stamp: ''!
primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex
	"Create and return a new socket handle based on accepting the connection from the given listening socket"

	<primitive: 'primitiveSocketAccept' module: 'SocketPlugin'>

	^ self primitiveFailed! !

!Socket methodsFor: 'primitives - ipv6' stamp: ''!
primSocket: socketID localAddressResult: socketAddress

	<primitive: 'primitiveSocketLocalAddressResult' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'accessing' stamp: ''!
socketHandle
	^socketHandle! !

!Socket methodsFor: 'waiting' stamp: ''!
waitForAcceptFor: timeout
	"Wait and accept an incoming connection. Return nil if it fails"
	^ self waitForAcceptFor: timeout ifTimedOut: [nil].! !

!Socket methodsFor: 'sending' stamp: ''!
sendStreamContents: stream
	"Send the data in the stream. Close the stream.
	Usefull for directly sending contents of a file without reading into memory first."

	self sendStreamContents: stream checkBlock: [true]! !

!Socket methodsFor: 'accessing' stamp: ''!
localAddress
	"If in the process of connecting, wait for connection to be established and binding to address completed before resolving."

	^ [ self primSocketLocalAddress: socketHandle ]
		on: Error
		do: [ :e | 
			self isWaitingForConnection
				ifTrue: [ self waitForConnectionFor: Socket standardTimeout ifTimedOut: nil.
					self primSocketLocalAddress: socketHandle ]
				ifFalse: [ e pass ] ]! !

!Socket methodsFor: 'datagrams' stamp: ''!
receiveUDPDataInto: aStringOrByteArray
	"Receive UDP data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data. What is returned is an array, the first element is the bytes read, the second the sending bytearray address, the third the senders port, the fourth, true if more of the datagram awaits reading"

	^ self primSocket: socketHandle
		receiveUDPDataInto: aStringOrByteArray
		startingAt: 1
		count: aStringOrByteArray size! !

!Socket methodsFor: 'accessing' stamp: ''!
port
	"Shortcut"
	^self localPort! !

!Socket methodsFor: 'queries' stamp: ''!
isConnected
	"Return true if this socket is connected."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == Connected! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketDestroy: socketID
	"Release the resources associated with this socket. If a connection is open, it is aborted."

	<primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'waiting' stamp: ''!
waitForDataFor: timeout
	"Wait for the given nr of seconds for data to arrive.
	Signal a time out or connection close exception if either happens before data becomes available."

	^self
		waitForDataFor: timeout
		ifClosed: [ConnectionClosed signal: 'Connection closed while waiting for data.']
		ifTimedOut: [ConnectionTimedOut signal: 'Data receive timed out.']! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex
	"Return a new socket handle for a socket of the given type and buffer sizes. Return nil if socket creation fails.
	The netType parameter is platform dependent and can be used to encode both the protocol type (IP, Xerox XNS, etc.) and/or the physical network interface to use if this host is connected to multiple networks. A zero netType means to use IP protocols and the primary (or only) network interface.
	The socketType parameter specifies:
		0	reliable stream socket (TCP if the protocol is IP)
		1	unreliable datagram socket (UDP if the protocol is IP)
	The buffer size parameters allow performance to be tuned to the application. For example, a larger receive buffer should be used when the application expects to be receiving large amounts of data, especially from a host that is far away. These values are considered requests only; the underlying implementation will ensure that the buffer sizes actually used are within allowable bounds. Note that memory may be limited, so an application that keeps many sockets open should use smaller buffer sizes. Note the macintosh implementation ignores this buffer size. Also see setOption to get/set socket buffer sizes which allows you to set/get the current buffer sizes for reading and writing.
 	If semaIndex is > 0, it is taken to be the index of a Semaphore in the external objects array to be associated with this socket. This semaphore will be signalled when the socket status changes, such as when data arrives or a send completes. All processes waiting on the semaphore will be awoken for each such event; each process must then query the socket state to figure out if the conditions they are waiting for have been met. For example, a process waiting to send some data can see if the last send has completed."

	<primitive: 'primitiveSocketCreate' module: 'SocketPlugin'>
	^ nil  "socket creation failed"! !

!Socket methodsFor: 'initialize - destroy' stamp: ''!
initializeNetwork
	self class initializeNetwork! !

!Socket methodsFor: 'initialization' stamp: ''!
initialize: socketType
	"Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil."

	| semaIndex readSemaIndex writeSemaIndex |
	socketHandle ifNotNil: [^Error signal: 'The socket is already bound'].
	semaphore := Semaphore new.
	readSemaphore := Semaphore new.
	writeSemaphore := Semaphore new.
	semaIndex := Smalltalk registerExternalObject: semaphore.
	readSemaIndex := Smalltalk registerExternalObject: readSemaphore.
	writeSemaIndex := Smalltalk registerExternalObject: writeSemaphore.
	socketHandle := self
		primSocketCreateNetwork: 0
		type: socketType
		receiveBufferSize: 8000
		sendBufSize: 8000
		semaIndex: semaIndex
		readSemaIndex: readSemaIndex
		writeSemaIndex: writeSemaIndex.
	socketHandle 
		ifNil: [ 
			"socket creation failed"
			Smalltalk unregisterExternalObject: semaphore.
			Smalltalk unregisterExternalObject: readSemaphore.
			Smalltalk unregisterExternalObject: writeSemaphore.
			readSemaphore := writeSemaphore := semaphore := nil ]
		ifNotNil: [ self register ]! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveAvailableDataIntoBuffer: buffer
	"Receive all available data (if any). Do not wait."
 
	| bytesRead |
	bytesRead := self receiveAvailableDataInto: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'waiting' stamp: ''!
waitForDataIfClosed: closedBlock
	"Wait indefinitely for data to arrive.  This method will block until
	data is available or the socket is closed."

	[true]
		whileTrue: [
			self dataAvailable
				ifTrue: [^self].
			self isConnected
				ifFalse: [^closedBlock value].
			self readSemaphore wait].! !

!Socket methodsFor: 'queries' stamp: ''!
isWaitingForConnection
	"Return true if this socket is waiting for a connection."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == WaitingForConnection! !

!Socket methodsFor: 'accessing' stamp: ''!
writeSemaphore
	^ writeSemaphore! !

!Socket methodsFor: 'waiting' stamp: ''!
waitForDisconnectionFor: timeout
	"Wait for the given nr of seconds for the connection to be broken.
	Return true if it is broken by the deadline, false if not.
	The client should know the connection is really going to be closed
	(e.g., because he has called 'close' to send a close request to the other end)
	before calling this method."

	| startTime msecsDelta status |
	startTime := Time millisecondClockValue.
	msecsDelta := (timeout * 1000) truncated.
	status := self primSocketConnectionStatus: socketHandle.
	[((status == Connected) or: [(status == ThisEndClosed)]) and:
	 [(Time millisecondsSince: startTime) < msecsDelta]] whileTrue: [
		self discardReceivedData.
		self readSemaphore waitTimeoutMSecs: 
			(msecsDelta - (Time millisecondsSince: startTime) max: 0).
		status := self primSocketConnectionStatus: socketHandle].
	^ status ~= Connected! !

!Socket methodsFor: 'accessing' stamp: ''!
remotePort
	"If in the process of connecting, wait for connection to be established and binding to address completed before resolving."

	^ [ self primSocketRemotePort: socketHandle ]
		on: Error
		do: [ :e | 
			self isWaitingForConnection
				ifTrue: [ self waitForConnectionFor: Socket standardTimeout ifTimedOut: nil.
					self primSocketRemotePort: socketHandle ]
				ifFalse: [ e pass ] ]! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveSomeDataInto: aStringOrByteArray
	"Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	^self receiveSomeDataInto: aStringOrByteArray startingAt: 1! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketLocalPort: socketID
	"Return the local port for this socket, or zero if no port has yet been assigned."

	<primitive: 'primitiveSocketLocalPort' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'primitives - ipv6' stamp: ''!
primSocket: socketID connectTo: socketAddress

	<primitive: 'primitiveSocketConnectTo' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'connection open/close' stamp: ''!
connectToHostNamed: hostName port: portNumber
	| serverIP |
	serverIP := NetNameResolver addressForName: hostName timeout: 20.
	^self connectTo: serverIP port: portNumber! !

!Socket methodsFor: 'queries' stamp: ''!
isBroadcastAddress: anAddress
	"Only IPv4 has broadcast, in IPv6 all nodes are required to support multicast, and that is used instead."

	^ anAddress size = 4 and: [ anAddress last = 255 ]! !

!Socket methodsFor: 'connection open/close' stamp: ''!
disconnect
	"Break this connection, no matter what state it is in. Data that has been sent but not received will be lost."

	self primSocketAbortConnection: socketHandle.! !

!Socket methodsFor: 'waiting' stamp: ''!
waitForConnectionFor: timeout ifTimedOut: timeoutBlock
	"Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not."

	| startTime msecsDelta msecsEllapsed status |
	startTime := Time millisecondClockValue.
	msecsDelta := (timeout * 1000) truncated.
	status := self primSocketConnectionStatus: socketHandle.
	[(status = WaitingForConnection) and: [(msecsEllapsed := Time millisecondsSince: startTime) < msecsDelta]]
		whileTrue: [
			semaphore waitTimeoutMSecs: msecsDelta - msecsEllapsed.
			status := self primSocketConnectionStatus: socketHandle].

	status = Connected ifFalse: [^timeoutBlock value].
	^ true! !

!Socket methodsFor: 'accessing' stamp: ''!
peerName
	"Return the name of the host I'm connected to, or nil if its name isn't known to the domain name server or the request times out."
	"Note: Slow. Calls the domain name server, taking up to 20 seconds to time out. Even when sucessful, delays of up to 13 seconds have been observed during periods of high network load." 

	^ NetNameResolver
		nameForAddress: self remoteAddress
		timeout: 20! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: socketID connectTo: hostAddress port: port
	"Attempt to establish a connection to the given port of the given host. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed."

	<primitive: 'primitiveSocketConnectToPort' module: 'SocketPlugin'>
	
	self primitiveFailed! !

!Socket methodsFor: 'finalization' stamp: ''!
finalize
	self primSocketDestroyGently: socketHandle.
	Smalltalk unregisterExternalObject: semaphore.
	Smalltalk unregisterExternalObject: readSemaphore.
	Smalltalk unregisterExternalObject: writeSemaphore.! !

!Socket methodsFor: 'waiting' stamp: ''!
waitForDataFor: timeout ifClosed: closedBlock ifTimedOut: timedOutBlock
	"Wait for the given nr of seconds for data to arrive."

	| startTime msecsDelta |
	startTime := Time millisecondClockValue.
	msecsDelta := (timeout * 1000) truncated.
	[ (Time millisecondsSince: startTime) < msecsDelta ]
		whileTrue: [ self dataAvailable ifTrue: [ ^ self ].
			self isConnected ifFalse: [ ^ closedBlock value ].
			self readSemaphore waitTimeoutMSecs: (msecsDelta - (Time millisecondsSince: startTime) max: 0) ].

	self dataAvailable
		ifFalse: [ ^ (self isConnected
				ifTrue: [ timedOutBlock ]
				ifFalse: [ closedBlock ]) value ]! !

!Socket methodsFor: 'connection open/close' stamp: ''!
connectTo: hostAddress port: port
	"Initiate a connection to the given port at the given host address.
	Waits until the connection is established or time outs."

	self connectTo: hostAddress port: port waitForConnectionFor: Socket standardTimeout! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema
	"See comment in primSocketCreateNetwork: with one semaIndex. However you should know that some implementations
	ignore the buffer size and this interface supports three semaphores,  one for open/close/listen and the other two for
	reading and writing"

	<primitive: 'primitiveSocketCreate3Semaphores' module: 'SocketPlugin'>
	^ self primitiveFailed! !

!Socket methodsFor: 'connection open/close' stamp: ''!
listenOn: portNumber backlogSize: backlog
	"Listen for a connection on the given port.
	If this method succeeds, #accept may be used to establish a new connection"
	| status |
	status := self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection'].
	self primSocket: socketHandle listenOn: portNumber backlogSize: backlog.! !

!Socket methodsFor: 'accessing' stamp: ''!
remoteAddress
	"If in the process of connecting, wait for connection to be established and binding to address completed before resolving."

	^ [ self primSocketRemoteAddress: socketHandle ]
		on: Error
		do: [ :e | 
			self isWaitingForConnection
				ifTrue: [ self waitForConnectionFor: Socket standardTimeout ifTimedOut: nil.
					self primSocketRemoteAddress: socketHandle ]
				ifFalse: [ e pass ] ]! !

!Socket methodsFor: 'sending' stamp: ''!
sendSomeData: aStringOrByteArray startIndex: startIndex count: count for: aTimeoutInSeconds
	"Send up to count bytes of the given data starting at the given index. Answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	| bytesSent |
	(self waitForSendDoneFor: aTimeoutInSeconds)
		ifTrue: [
			bytesSent := self primSocket: socketHandle
				sendData: aStringOrByteArray
				startIndex: startIndex
				count: count ]
		ifFalse: [ ConnectionTimedOut signal: 'send data timeout; data not sent' ].
	^ bytesSent! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: socketID receiveUDPDataInto: aStringOrByteArray startingAt: startIndex count: count
	"Receive data from the given socket into the given array starting at the given index. 
	Return an Array containing the amount read, the host address byte array, the host port, and the more flag"

	<primitive: 'primitiveSocketReceiveUDPDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'queries' stamp: ''!
isUnconnected
	"Return true if this socket's state is Unconnected."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == Unconnected! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketRemoteAddress: socketID
	"Return the remote host address for this socket, or zero if no connection has been made."

	<primitive: 'primitiveSocketRemoteAddress' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'connection open/close' stamp: ''!
accept
	"Accept a connection from the receiver socket.
	Return a new socket that is connected to the client"
	^Socket acceptFrom: self.! !

!Socket methodsFor: 'registry' stamp: ''!
unregister
	^self class unregister: self! !

!Socket methodsFor: 'initialize - destroy' stamp: ''!
destroy
	"Destroy this socket. Its connection, if any, is aborted and its resources are freed. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	socketHandle 
		ifNotNil: [ 
			self isValid
				ifTrue: [ self primSocketDestroy: socketHandle ].
			Smalltalk unregisterExternalObject: semaphore.
			Smalltalk unregisterExternalObject: readSemaphore.
			Smalltalk unregisterExternalObject: writeSemaphore.
			socketHandle := nil.
			readSemaphore := writeSemaphore := semaphore := nil.
			self unregister ]! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: socketID sendData: aStringOrByteArray startIndex: startIndex count: count
	"Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed."

	"Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created."

	<primitive: 'primitiveSocketSendDataBufCount' module: 'SocketPlugin'>
	^ self
		errorSending: aStringOrByteArray
		startingAt: startIndex
		count: count
		toHost: self remoteAddress
		port: self remotePort! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketCloseConnection: socketID
	"Close the connection on the given port. The remote end is informed that this end has closed and will do no further sends. This is an asynchronous call; query the socket status to discover if and when the connection is actually closed."

	<primitive: 'primitiveSocketCloseConnection' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveAvailableDataInto: buffer startingAt: startIndex
	"Receive all available data into the given buffer and return the number of bytes received.
	Note the given buffer may be only partially filled by the received data.
	Do not wait for data."

	| bufferPos bytesRead |
	bufferPos := startIndex.
	[self dataAvailable
		and: [bufferPos-1 < buffer size]] 
		whileTrue: [
			bytesRead := self receiveSomeDataInto: buffer startingAt: bufferPos.
			bufferPos := bufferPos + bytesRead].
	^bufferPos - startIndex! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveAvailableData
	"Receive all available data (if any). Do not wait."
 
	| buffer bytesRead |
	buffer := String new: 2000.
	bytesRead := self receiveAvailableDataInto: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'queries' stamp: ''!
socketError
	^self primSocketError: socketHandle! !

!Socket methodsFor: 'connection open/close' stamp: ''!
connectNonBlockingTo: hostAddress port: port
	"Initiate a connection to the given port at the given host address. This operation will return immediately; follow it with waitForConnectionUntil: to wait until the connection is established."

	| status |
	self initializeNetwork.
	status := self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before opening a new connection'].

	self primSocket: socketHandle connectTo: hostAddress port: port! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketRemotePort: socketID
	"Return the remote port for this socket, or zero if no connection has been made."

	<primitive: 'primitiveSocketRemotePort' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'datagrams' stamp: ''!
receiveDataInto: aStringOrByteArray fromHost: hostAddress port: portNumber
	"Receive a UDP packet from the given hostAddress/portNumber, storing the data in the given buffer, and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	[ | datagram |
	datagram := self receiveUDPDataInto: aStringOrByteArray.
	^ ((datagram at: 2) = hostAddress and: [ (datagram at: 3) = portNumber ])
		ifTrue: [ datagram at: 1 ]
		ifFalse: [ 0 ] ] repeat! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketReceiveDataAvailable: socketID
	"Return true if data may be available for reading from the current socket.
	This primitive should not be called directly.
	We should use #dataAvailable because it checks if the handler is nil.
	The primitive fails with a primitive failure if the handler is nil.
	Pay attention that if we are using the primitive directly, 
	the image can be saved in the middle of the method niling the value in the socket. 
	This can produce a primitiveFailed error while it should be a ConnectionClosedError 
	or something like that."

	<primitive: 'primitiveSocketReceiveDataAvailable' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'sending' stamp: ''!
sendCommand: commandString
	"Send the given command as a single line followed by a <CR><LF> terminator."

	self sendData: commandString, String crlf.! !

!Socket methodsFor: 'receiving' stamp: ''!
discardReceivedData
	"Discard any data received up until now, and return the number of bytes discarded."

	| buf totalBytesDiscarded |
	buf := String new: 10000.
	totalBytesDiscarded := 0.
	[self isConnected] whileTrue: [
		totalBytesDiscarded :=
			totalBytesDiscarded + (self receiveDataInto: buf)].
	^ totalBytesDiscarded! !

!Socket methodsFor: 'queries' stamp: ''!
statusString
	"Return a string describing the status of this socket."

	| status |
	socketHandle == nil ifTrue: [^ 'destroyed'].
	status := self primSocketConnectionStatus: socketHandle.
	status = InvalidSocket ifTrue: [^ 'invalidSocketHandle'].
	status = Unconnected ifTrue: [^ 'unconnected'].
	status = WaitingForConnection ifTrue: [^ 'waitingForConnection'].
	status = Connected ifTrue: [^ 'connected'].
	status = OtherEndClosed ifTrue: [^ 'otherEndClosedButNotThisEnd'].
	status = ThisEndClosed ifTrue: [^ 'thisEndClosedButNotOtherEnd'].
	^ 'unknown socket status'! !

!Socket methodsFor: 'connection open/close' stamp: ''!
listenOn: portNumber backlogSize: backlog interface: ifAddr
	"Listen for a connection on the given port.
	If this method succeeds, #accept may be used to establish a new connection"
	| status |
	status := self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection'].
	self primSocket: socketHandle listenOn: portNumber backlogSize: backlog interface: ifAddr.! !

!Socket methodsFor: 'other' stamp: ''!
getOption: aName 
	"Get options on this socket, see Unix man pages for values for 
	sockets, IP, TCP, UDP. IE SO_KEEPALIVE
	returns an array, element one is an status number (0 ok, -1 read only option)
	element two is the resulting of the requested option"

	(socketHandle == nil or: [self isValid not])
		ifTrue: [InvalidSocketStatusException signal: 'Socket status must valid before getting an option'].
	^self primSocket: socketHandle getOption: aName

"| foo options |
Socket initializeNetwork.
foo := Socket newTCP.
foo connectTo: (NetNameResolver addressFromString: '192.168.1.1') port: 80.
foo waitForConnectionUntil: (Socket standardDeadline).

options := {
'SO_DEBUG'. 'SO_REUSEADDR'. 'SO_REUSEPORT'. 'SO_DONTROUTE'.
'SO_BROADCAST'. 'SO_SNDBUF'. 'SO_RCVBUF'. 'SO_KEEPALIVE'.
'SO_OOBINLINE'. 'SO_PRIORITY'. 'SO_LINGER'. 'SO_RCVLOWAT'.
'SO_SNDLOWAT'. 'IP_TTL'. 'IP_HDRINCL'. 'IP_RCVOPTS'.
'IP_RCVDSTADDR'. 'IP_MULTICAST_IF'. 'IP_MULTICAST_TTL'.
'IP_MULTICAST_LOOP'. 'UDP_CHECKSUM'. 'TCP_MAXSEG'.
'TCP_NODELAY'. 'TCP_ABORT_THRESHOLD'. 'TCP_CONN_NOTIFY_THRESHOLD'. 
'TCP_CONN_ABORT_THRESHOLD'. 'TCP_NOTIFY_THRESHOLD'.
'TCP_URGENT_PTR_TYPE'}.

1 to: options size do: [:i | | fum |
	fum :=foo getOption: (options at: i).
	Transcript show: (options at: i),fum printString;cr].

foo := Socket newUDP.
foo setPeer: (NetNameResolver addressFromString: '192.168.1.9') port: 7.
foo waitForConnectionUntil: (Socket standardDeadline).

1 to: options size do: [:i | | fum |
	fum :=foo getOption: (options at: i).
	Transcript show: (options at: i),fum printString;cr].
"! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketSendDone: socketID
	"Return true if there is no send in progress on the current socket."

	<primitive: 'primitiveSocketSendDone' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveData
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once.
	Either returns data or signals a time out or connection close."

	| buffer bytesRead |
	buffer := String new: 2000.
	bytesRead := self receiveDataInto: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: socketID getOption: aString 
	"Get some option information on this socket. Refer to the UNIX 
	man pages for valid SO, TCP, IP, UDP options. In case of doubt
	refer to the source code.
	TCP:=NODELAY, SO:=KEEPALIVE are valid options for example
	returns an array containing the error code and the option value"

	<primitive: 'primitiveSocketGetOptions' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveDataTimeout: timeout into: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Wait for data once for the specified nr of seconds.  The answer may be 
	zero (indicating that there was no data available within the given timeout)."

	self waitForDataFor: timeout ifClosed: [] ifTimedOut: [].
	^self primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: aNumber
		count: aStringOrByteArray size-aNumber+1! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: socketID setOption: aString value: aStringValue
	"Set some option information on this socket. Refer to the UNIX 
	man pages for valid SO, TCP, IP, UDP options. In case of doubt
	refer to the source code.
	TCP:=NODELAY, SO:=KEEPALIVE are valid options for example
	returns an array containing the error code and the negotiated value"

	<primitive: 'primitiveSocketSetOptions' module: 'SocketPlugin'>
	^nil! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveDataInto: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once.  The answer may be zero (indicating that no data was 
	available before the socket closed)."

	| bytesRead closed |
	bytesRead := 0.
	closed := false.
	[closed not and: [bytesRead = 0]]
		whileTrue: [
			self waitForDataIfClosed: [closed := true].
			bytesRead := self primSocket: socketHandle
				receiveDataInto: aStringOrByteArray
				startingAt: aNumber
				count: aStringOrByteArray size-aNumber+1].
	^bytesRead! !

!Socket methodsFor: 'initialize - destroy' stamp: ''!
acceptFrom: aSocket
	"Initialize a new socket handle from an accept call"

	| semaIndex readSemaIndex writeSemaIndex |
	socketHandle ifNotNil: [^Error signal: 'The socket is already bound'].
	semaphore := Semaphore new.
	readSemaphore := Semaphore new.
	writeSemaphore := Semaphore new.
	semaIndex := Smalltalk registerExternalObject: semaphore.
	readSemaIndex := Smalltalk registerExternalObject: readSemaphore.
	writeSemaIndex := Smalltalk registerExternalObject: writeSemaphore.
	socketHandle := self
		primAcceptFrom: aSocket socketHandle
		receiveBufferSize: 8000
		sendBufSize: 8000
		semaIndex: semaIndex
		readSemaIndex: readSemaIndex
		writeSemaIndex: writeSemaIndex.
	socketHandle 
		ifNil: [ 
			"socket creation failed"
			Smalltalk unregisterExternalObject: semaphore.
			Smalltalk unregisterExternalObject: readSemaphore.
			Smalltalk unregisterExternalObject: writeSemaphore.
			readSemaphore := writeSemaphore := semaphore := nil ]
		ifNotNil: [ self register ]! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveDataTimeout: timeout
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once."

	| buffer bytesRead |
	buffer := String new: 2000.
	bytesRead := self receiveDataTimeout: timeout into: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'queries' stamp: ''!
isOtherEndClosed
	"Return true if this socket had the other end closed."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == OtherEndClosed! !

!Socket methodsFor: 'waiting' stamp: ''!
waitForConnectionFor: timeout
	"Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not."

	^self 
		waitForConnectionFor: timeout 
		ifTimedOut: [ConnectionTimedOut signal: 'Failed to connect in ', timeout asString, ' seconds']! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveDataSignallingClosedInto: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data until something is read or the socket is closed, upon which
	we signal."

	| bytesRead |
	bytesRead := 0.
	[bytesRead = 0]
		whileTrue: [
			self waitForData.
			bytesRead := self primSocket: socketHandle
				receiveDataInto: aStringOrByteArray
				startingAt: aNumber
				count: aStringOrByteArray size-aNumber+1].
	^bytesRead! !

!Socket methodsFor: 'primitives - ipv6' stamp: ''!
primSocket: socketID remoteAddressResult: socketAddress

	<primitive: 'primitiveSocketRemoteAddressResult' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveDataWithTimeoutInto: aStringOrByteArray
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once.
	Either returns data or signals a time out or connection close."

	^self receiveDataWithTimeoutInto: aStringOrByteArray startingAt: 1! !

!Socket methodsFor: 'connection open/close' stamp: ''!
connectTo: hostAddress port: port waitForConnectionFor: timeout 
	"Initiate a connection to the given port at the given host 
	address. Waits until the connection is established or time outs."
	self connectNonBlockingTo: hostAddress port: port.
	self
		waitForConnectionFor: timeout
		ifTimedOut: [ConnectionTimedOut signal: 'Cannot connect to '
					, (NetNameResolver stringFromAddress: hostAddress) , ':' , port asString]! !

!Socket methodsFor: 'datagrams' stamp: ''!
setPort: port
	"Associate a local port number with a UDP socket.  Not applicable to TCP sockets."

	self primSocket: socketHandle setPort: port.! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketDestroyGently: socketID
	"Release the resources associated with this socket. If a connection is open, it is aborted.
	Do not fail if the receiver is already closed."

	<primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'>! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveDataTimeout: timeout into: aStringOrByteArray 
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once."

	^self receiveDataTimeout: timeout into: aStringOrByteArray startingAt: 1! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveSomeDataInto: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	^ self primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: aNumber
		count: aStringOrByteArray size-aNumber+1! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketError: socketID
	"Return an integer encoding the most recent error on this socket. Zero means no error."

	<primitive: 'primitiveSocketError' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveSomeData
	"Receive currently available data (if any). Do not wait."
 
	| buffer bytesRead |
	buffer := String new: 2000.
	bytesRead := self receiveSomeDataInto: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'primitives - ipv6' stamp: ''!
primSocketRemoteAddressSize: handle

	<primitive: 'primitiveSocketRemoteAddressSize' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'connection open/close' stamp: ''!
listenOn: port
	"Listen for a connection on the given port. This operation will return immediately; follow it with waitForConnectionUntil: to wait until a connection is established."

	| status |
	status := self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection'].

	self primSocket: socketHandle listenOn: port.! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketConnectionStatus: socketID
	"Return an integer reflecting the connection status of this socket. For a list of possible values, see the comment in the 'initialize' method of this class. If the primitive fails, return a status indicating that the socket handle is no longer valid, perhaps because the Pharo image was saved and restored since the socket was created. (Sockets do not survive snapshots.)"

	<primitive: 'primitiveSocketConnectionStatus' module: 'SocketPlugin'>
	^ InvalidSocket! !

!Socket methodsFor: 'accessing' stamp: ''!
semaphore
	^ semaphore! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveDataSignallingTimeout: timeout into: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Wait for data once for the specified nr of seconds.  This method will
	throw exceptions on timeout or the socket closing."

	self waitForDataFor: timeout.
	^self primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: aNumber
		count: aStringOrByteArray size-aNumber+1! !

!Socket methodsFor: 'accessing' stamp: ''!
localPort
	"If in the process of connecting, wait for connection to be established and binding to address completed before resolving."

	^ [ self primSocketLocalPort: socketHandle ]
		on: Error
		do: [ :e | 
			self isWaitingForConnection
				ifTrue: [ self waitForConnectionFor: Socket standardTimeout ifTimedOut: nil.
					self primSocketLocalPort: socketHandle ]
				ifFalse: [ e pass ] ]! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveDataInto: aStringOrByteArray
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once.
	Either returns data or signals a time out or connection close."

	^self receiveDataInto: aStringOrByteArray startingAt: 1! !

!Socket methodsFor: 'other' stamp: ''!
setOption: aName value: aValue 
	| value |
	"setup options on this socket, see Unix man pages for values for 
	sockets, IP, TCP, UDP. IE SO_KEEPALIVE
	returns an array, element one is the error number
	element two is the resulting of the negotiated value.
	See getOption for list of keys"

	(socketHandle == nil or: [self isValid not])
		ifTrue: [InvalidSocketStatusException signal: 'Socket status must valid before setting an option'].
	value := aValue asString.
	aValue == true ifTrue: [value := '1'].
	aValue == false ifTrue: [value := '0'].
	^ self primSocket: socketHandle setOption: aName value: value! !

!Socket methodsFor: 'primitives - ipv6' stamp: ''!
primSocketLocalAddressSize: handle

	<primitive: 'primitiveSocketLocalAddressSize' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'queries' stamp: ''!
sendDone
	"Return true if the most recent send operation on this socket has completed."

	socketHandle == nil ifTrue: [^ false].
	^ self primSocketSendDone: socketHandle! !

!Socket methodsFor: 'queries' stamp: ''!
isUnconnectedOrInvalid
	"Return true if this socket is completely disconnected or is invalid."

	| status |
	socketHandle == nil ifTrue: [^ true].
	status := self primSocketConnectionStatus: socketHandle.
	^ (status = Unconnected) | (status = InvalidSocket)! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: socketID bindTo: anAddress port: aPort 
	"Bind socket to provided IPv4 address and port"
	<primitive: 'primitiveSocketBindToPort' module: 'SocketPlugin'>
	^self primitiveFailed! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: socketID listenOn: port
	"Listen for a connection on the given port. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed."

	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveDataWithTimeoutInto: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once."

	^self receiveDataTimeout: Socket standardTimeout into: aStringOrByteArray startingAt: aNumber! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: aHandle listenOn: portNumber backlogSize: backlog
	"Primitive. Set up the socket to listen on the given port.
	Will be used in conjunction with #accept only."
	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self destroy. "Accept not supported so clean up"! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: socketID receiveDataInto: aStringOrByteArray startingAt: startIndex count: count
	"Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available."

	<primitive: 'primitiveSocketReceiveDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'primitives - ipv6' stamp: ''!
primSocket: socketID bindTo: socketAddress

	<primitive: 'primitiveSocketBindTo' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '[', self statusString, ']'.! !

!Socket methodsFor: 'sending' stamp: ''!
sendSomeData: aStringOrByteArray startIndex: startIndex count: count
	"Send up to count bytes of the given data starting at the given index. Answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	^ self 
		sendSomeData: aStringOrByteArray 
		startIndex: startIndex 
		count: count 
		for: Socket standardTimeout! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketAbortConnection: socketID
	"Terminate the connection on the given port immediately without going through the normal close sequence. This is an asynchronous call; query the socket status to discover if and when the connection is actually terminated."

	<primitive: 'primitiveSocketAbortConnection' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'initialize - destroy' stamp: ''!
bindTo: anAddress port: aPort
	^self primSocket: socketHandle bindTo: anAddress port: aPort! !

!Socket methodsFor: 'accessing' stamp: ''!
address
	"Shortcut"
	^self localAddress! !

!Socket methodsFor: 'waiting' stamp: ''!
waitForData
	"Wait for data to arrive.  This method will block until
	data is available or the socket is closed.  If the socket is closed
	a ConnectionClosed exception will be signaled."

	^self waitForDataIfClosed:
		[ConnectionClosed signal: 'Connection close while waiting for data.']! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: socketID setPort: port
	"Set the local port associated with a UDP socket.
	Note: this primitive is overloaded.  The primitive will not fail on a TCP socket, but
	the effects will not be what was desired.  Best solution would be to split Socket into
	two subclasses, TCPSocket and UDPSocket."

	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'connection open/close' stamp: ''!
close
	"Close this connection gracefully. For TCP, this sends a close request, but the stream remains open until the other side also closes it."

	self primSocketCloseConnection: socketHandle.  "close this end"! !

!Socket methodsFor: 'queries' stamp: ''!
dataAvailable
	"Return true if this socket has unread received data."

	socketHandle ifNil: [^ false].
	^ self primSocketReceiveDataAvailable: socketHandle! !

!Socket methodsFor: 'accessing' stamp: ''!
readSemaphore
	^ readSemaphore! !

!Socket methodsFor: 'queries' stamp: ''!
isThisEndClosed
	"Return true if this socket had the this end closed."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == ThisEndClosed! !

!Socket methodsFor: 'datagrams' stamp: ''!
sendData: aStringOrByteArray toHost: hostAddress port: portNumber
	"Send a UDP packet containing the given data to the specified host/port."

	^ self sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber! !

!Socket methodsFor: 'sending' stamp: ''!
sendData: aStringOrByteArray
	"Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent."

	"An experimental version use on slow lines: Longer timeout and smaller writes to try to avoid spurious timeouts."

	| bytesSent bytesToSend count |
	bytesToSend := aStringOrByteArray size.
	bytesSent := 0.
	[bytesSent < bytesToSend] whileTrue: [
		(self waitForSendDoneFor: 60)
			ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent'].
		count := self primSocket: socketHandle
			sendData: aStringOrByteArray
			startIndex: bytesSent + 1
			count: (bytesToSend - bytesSent min: 5000).
		bytesSent := bytesSent + count].

	^ bytesSent! !

!Socket methodsFor: 'connection open/close' stamp: ''!
closeAndDestroy
	"First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	self closeAndDestroy: 20.! !

!Socket methodsFor: 'private - errors' stamp: ''!
broadcastError: hostAddress
	^ (NoBroadcastAllowed new
		messageText: 'Sending to ' , hostAddress printString , ' without SO_BROADCAST set')
		signal! !

!Socket methodsFor: 'sending' stamp: ''!
sendSomeData: aStringOrByteArray startIndex: startIndex
	"Send as much of the given data as possible starting at the given index. Answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	^ self
		sendSomeData: aStringOrByteArray
		startIndex: startIndex
		count: (aStringOrByteArray size - startIndex + 1)! !

!Socket methodsFor: 'private - errors' stamp: ''!
errorSending: data startingAt: startIndex count: aCount toHost: hostAddress port: portNumber
	"If there are known primitive failure reasons when sending that can be specified using more exact errors, discern them here"
"Only applicable to UDP sockets, TCP does not have broadcast"
	(self broadcastMisconfiguredForSendingTo: hostAddress)
		ifTrue: [ ^ self broadcastError: hostAddress ].	
	^ self primitiveFailed: thisContext sender selector! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: aHandle listenOn: portNumber backlogSize: backlog interface: ifAddr
	"Primitive. Set up the socket to listen on the given port.
	Will be used in conjunction with #accept only."
	<primitive: 'primitiveSocketListenOnPortBacklogInterface' module: 'SocketPlugin'>
	self destroy. "Accept not supported so clean up"! !

!Socket methodsFor: 'sending' stamp: ''!
sendStreamContents: stream checkBlock: checkBlock
	"Send the data in the stream. Close the stream after you are done. After each block of data evaluate checkBlock and abort if it returns false.
	Usefull for directly sending contents of a file without reading into memory first."

	| chunkSize buffer |
	chunkSize := 5000.
	buffer := ByteArray new: chunkSize.
	stream binary.
	[[stream atEnd and: [checkBlock value]]
		whileFalse: [
			buffer := stream next: chunkSize into: buffer.
			self sendData: buffer]]
		ensure: [stream close]! !

!Socket methodsFor: 'connection open/close' stamp: ''!
closeAndDestroy: timeoutSeconds
	"First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	socketHandle ifNotNil: [
			self isConnected ifTrue: [
				self close.  "close this end"
				(self waitForDisconnectionFor: timeoutSeconds) ifFalse: [
						"The other end didn't close so we just abort the connection"
						self primSocketAbortConnection: socketHandle]].
			self destroy].! !

!Socket methodsFor: 'datagrams' stamp: ''!
sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber
	"Send a UDP packet containing the given data to the specified host/port."
	| bytesToSend bytesSent count |

	bytesToSend := aStringOrByteArray size.
	bytesSent := 0.
	[
		(self waitForSendDoneFor: 20)
			ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent'].
		count := self primSocket: socketHandle
			sendUDPData: aStringOrByteArray
			toHost: hostAddress
			port: portNumber
			startIndex: bytesSent + 1
			count: bytesToSend - bytesSent.
		count = 0 ifTrue: 
			["Usually broadcast fails in primitive without the proper option set, 
			but some platforms simply return count=0"
			(self broadcastMisconfiguredForSendingTo: hostAddress)
				ifTrue: [ ^ self broadcastError: hostAddress ].
			bytesToSend ~= count 
				ifTrue: [ ^NetworkError signal: 'failed to send data']].
		bytesSent := bytesSent + count.
		bytesSent < bytesToSend] whileTrue.

	^ bytesSent! !

!Socket methodsFor: 'waiting' stamp: ''!
waitForSendDoneFor: timeout
	"Wait up until the given deadline for the current send operation to complete. Return true if it completes by the deadline, false if not."

	| startTime msecsDelta msecsEllapsed sendDone |
	startTime := Time millisecondClockValue.
	msecsDelta := (timeout * 1000) truncated.
	[(sendDone := self primSocketSendDone: socketHandle) not and: [ self isConnected
			"Connection end and final data can happen fast, so test in this order"
		and: [(msecsEllapsed := Time millisecondsSince: startTime) < msecsDelta]]] whileTrue: [
			self writeSemaphore waitTimeoutMSecs: msecsDelta - msecsEllapsed].

	^ sendDone! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocketLocalAddress: socketID
	"Return the local host address for this socket."

	<primitive: 'primitiveSocketLocalAddress' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'private - errors' stamp: ''!
broadcastMisconfiguredForSendingTo: hostAddress
	^ (self isBroadcastAddress: hostAddress)
		and: [ ((self getOption: 'SO_BROADCAST') last = 0) ]! !

!Socket methodsFor: 'registry' stamp: ''!
register
	^self class register: self! !

!Socket methodsFor: 'primitives - ipv6' stamp: ''!
primSocket: socketID listenWithBacklog: backlogSize

	<primitive: 'primitiveSocketListenWithBacklog' module: 'SocketPlugin'>
	self primitiveFailed! !

!Socket methodsFor: 'datagrams' stamp: ''!
setPeer: hostAddress port: port
	"Set the default send/recv address."

	self primSocket: socketHandle connectTo: hostAddress port: port.! !

!Socket methodsFor: 'sending' stamp: ''!
sendSomeData: aStringOrByteArray
	"Send as much of the given data as possible and answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	^ self
		sendSomeData: aStringOrByteArray
		startIndex: 1
		count: aStringOrByteArray size! !

!Socket methodsFor: 'queries' stamp: ''!
isValid
	"Return true if this socket contains a valid, non-nil socket handle."

	| status |
	socketHandle == nil ifTrue: [^ false].
	status := self primSocketConnectionStatus: socketHandle.
	^ status ~= InvalidSocket! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveAvailableDataInto: buffer
	"Receive all available data into the given buffer and return the number of bytes received.
	Note the given buffer may be only partially filled by the received data.
	Do not wait for data."

	^self receiveAvailableDataInto: buffer startingAt: 1! !

!Socket methodsFor: 'primitives' stamp: ''!
primSocket: socketID sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber startIndex: startIndex count: count
	"Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed."

	"Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created."

	<primitive: 'primitiveSocketSendUDPDataBufCount' module: 'SocketPlugin'>
	^ self
		errorSending: aStringOrByteArray
		startingAt: startIndex
		count: count
		toHost: hostAddress
		port: portNumber! !

!Socket methodsFor: 'primitives' stamp: ''!
primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema
	"Create and return a new socket handle based on accepting the connection from the given listening socket"
	
	<primitive: 'primitiveSocketAccept3Semaphores' module: 'SocketPlugin'>
	
	^ self primitiveFailed! !

!Socket methodsFor: 'receiving' stamp: ''!
receiveDataWithTimeout
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once.
	Either returns data or signals a time out or connection close."

	| buffer bytesRead |
	buffer := String new: 2000.
	bytesRead := self receiveDataWithTimeoutInto: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'waiting' stamp: ''!
waitForAcceptFor: timeout ifTimedOut: timeoutBlock
	"Wait and accept an incoming connection"
	self waitForConnectionFor: timeout ifTimedOut: [^timeoutBlock value].
	^self accept! !

!Socket class methodsFor: 'instance creation' stamp: ''!
new
	"Return a new, unconnected Socket. Note that since socket creation may fail, it is safer to use the method createIfFail: to handle such failures gracefully; this method is primarily for backward compatibility and may be disallowed in a future release."
	"Note: The default creates a TCP socket - this is also backward compatibility."
	^self newTCP! !

!Socket class methodsFor: 'registry' stamp: ''!
registry
	^Registry ifNil: [Registry := WeakRegistry new]! !

!Socket class methodsFor: 'utilities' stamp: ''!
nameForWellKnownTCPPort: portNum
	"Answer the name for the given well-known TCP port number. Answer a string containing the port number if it isn't well-known."

	| portList |
	portList := #(#(7 'echo') #(9 'discard') #(13 'time') #(19 'characterGenerator') #(21 'ftp') #(23 'telnet') #(25 'smtp') #(80 'http') #(110 'pop3') #(119 'nntp')).
	^ portList
		detect: [ :pair | pair first = portNum ]
		ifFound: [ :pair | pair last ]
		ifNone: [ 'port-' , portNum printString ]! !

!Socket class methodsFor: 'registry' stamp: ''!
registryThreshold: aNumber
	"Return the registry threshold above which socket creation may fail due to too many already open sockets. If the threshold is reached, a full GC will be issued if the creation of a socket fails."
	RegistryThreshold := aNumber! !

!Socket class methodsFor: 'utilities' stamp: ''!
wildcardAddress
	"Answer a don't-care address for use with UDP sockets."

	^ByteArray new: 4		"0.0.0.0"! !

!Socket class methodsFor: 'instance creation' stamp: ''!
newUDP
	"Create a socket and initialize it for UDP"

	self initializeNetwork.
	^ [ super new initialize: UDPSocketType ] repeatWithGCIf: [ :socket | 
		  socket isValid not ]! !

!Socket class methodsFor: 'instance creation' stamp: ''!
acceptFrom: aSocket
	^[ super new acceptFrom: aSocket ]
		repeatWithGCIf: [ :sock | sock isValid not ]! !

!Socket class methodsFor: 'registry' stamp: ''!
registryThreshold
	"Return the registry threshold above which socket creation may fail due to too many already open sockets. If the threshold is reached, a full GC will be issued if the creation of a socket fails."
	^RegistryThreshold! !

!Socket class methodsFor: 'registry' stamp: ''!
register: anObject
	^self registry add: anObject! !

!Socket class methodsFor: 'registry' stamp: ''!
unregister: anObject
	^self registry remove: anObject ifAbsent:[]! !

!Socket class methodsFor: 'utilities' stamp: ''!
deadServer

	^ DeadServer! !

!Socket class methodsFor: 'network initialization' stamp: ''!
initializeNetwork
	"Initialize the network drivers and the NetNameResolver. Do nothing if the network is already initialized."
	"Note: The network must be re-initialized every time Pharo starts up, so applications that persist across snapshots should be prepared to re-initialize the network as needed. Such applications should call 'Socket initializeNetwork' before every network transaction. "

	NetNameResolver initializeNetwork! !

!Socket class methodsFor: 'class initialization' stamp: ''!
initialize
	"Socket initialize"

	"Socket Types"
	TCPSocketType := 0.
	UDPSocketType := 1.

	"Socket Status Values"
	InvalidSocket := -1.
	Unconnected := 0.
	WaitingForConnection := 1.
	Connected := 2.
	OtherEndClosed := 3.
	ThisEndClosed := 4.

	RegistryThreshold := 100. "# of sockets"! !

!Socket class methodsFor: 'utilities' stamp: ''!
ping: hostName
	"Ping the given host. Useful for checking network connectivity. The host must be running a TCP echo server."

	"Socket ping: 'pharo-project.org'"

	| tcpPort sock serverAddr startTime echoTime |
	tcpPort := 7.	"7 = echo port, 13 = time port, 19 = character generator port"
	serverAddr := NetNameResolver addressForName: hostName timeout: 10.
	serverAddr 
		ifNil: [ ^ self inform: 'Could not find an address for ' , hostName ].
	sock := Socket new.
	sock connectNonBlockingTo: serverAddr port: tcpPort.
	[ sock waitForConnectionFor: 10 ]
		on: ConnectionTimedOut
		do: [ :ex | 
			(self confirm: 'Continue to wait for connection to ' , hostName , '?')
				ifTrue: [ ex retry ]
				ifFalse: [ 
					sock destroy.
					^ self ] ].
	sock sendData: 'echo!!'.
	startTime := Time millisecondClockValue.
	[ sock waitForDataFor: 15 ]
		on: ConnectionTimedOut
		do: [ :ex | 
			(self confirm: 'Packet sent but no echo yet; keep waiting?')
				ifTrue: [ ex retry ] ].
	echoTime := Time millisecondsSince: startTime.
	sock destroy.
	self inform: hostName , ' responded in ' , echoTime printString , ' milliseconds'! !

!Socket class methodsFor: 'tests' stamp: ''!
sendTest
	"Send data to the 'discard' socket of the given host.
	Tests the speed of one-way data transfers across the
	network to the given host. Note that most hosts
	do not run a discard server."

	"Socket sendTest"

	| sock bytesToSend sendBuf bytesSent t serverName serverAddr |
	Transcript
		cr;
		show: 'starting send test';
		cr.
	self initializeNetwork.
	serverName := UIManager default request: 'What is the destination server?' initialAnswer: 'create.ucsb.edu'.
	serverAddr := NetNameResolver addressForName: serverName timeout: 10.
	serverAddr 
		ifNil: [ ^ self inform: 'Could not find an address for ' , serverName ].
	sock := self new.
	Transcript
		show: '---------- Connecting ----------';
		cr.
	sock connectTo: serverAddr port: 9.
	sock isConnected
		ifFalse: [ 
			sock destroy.
			^ self inform: 'could not connect' ].
	Transcript
		show: 'connection established; sending data';
		cr.
	bytesToSend := 1000000.
	sendBuf := String new: 64 * 1024 withAll: $x.
	bytesSent := 0.
	t := Time
		millisecondsToRun: [ 
			[ bytesSent < bytesToSend ]
				whileTrue: [ 
					sock sendDone
						ifTrue: [ bytesSent := bytesSent + (sock sendSomeData: sendBuf) ] ] ].
	sock waitForSendDoneFor: self standardTimeout.
	sock destroy.
	Transcript
		show: '---------- Connection Closed ----------';
		cr;
		show: 'send test done; time = ' , t printString;
		cr;
		show: (bytesToSend asFloat / t roundTo: 0.01) printString , ' * 1000 bytes/sec';
		cr;
		endEntry! !

!Socket class methodsFor: 'instance creation' stamp: ''!
newTCP
	"Create a socket and initialize it for TCP"

	self initializeNetwork.
	^ [ super new initialize: TCPSocketType ] repeatWithGCIf: [ :socket | 
		  socket isValid not ]! !

!Socket class methodsFor: 'instance creation' stamp: ''!
tcpCreateIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."

	| sock |
	self initializeNetwork.
	sock := self newTCP.
	sock isValid ifFalse: [^ failBlock value].
	^ sock! !

!Socket class methodsFor: 'tests' stamp: ''!
loopbackTest
	"Send data from one socket to another on the local machine.
	Tests most of the socket primitives."

	"100 timesRepeat: [Socket loopbackTest]"

	| sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived t extraBytes packetsSent packetsRead |
	Transcript
		cr;
		show: 'starting loopback test';
		cr.
	Transcript
		show: '---------- Connecting ----------';
		cr.
	self initializeNetwork.
	sock1 := self new.
	sock2 := self new.
	sock1 listenOn: 54321.
	sock2 connectTo: NetNameResolver localHostAddress port: 54321.
	sock1 waitForConnectionFor: self standardTimeout.
	sock2 waitForConnectionFor: self standardTimeout.
	sock1 isConnected ifFalse: [self error: 'sock1 not connected'].
	sock2 isConnected ifFalse: [self error: 'sock2 not connected'].
	Transcript
		show: 'connection established';
		cr.
	bytesToSend := 5000000.
	sendBuf := String new: 5000 withAll: $x.
	receiveBuf := String new: 50000.
	done := false.
	packetsSent := packetsRead := bytesSent := bytesReceived := 0.
	t := Time millisecondsToRun: 
					[[done] whileFalse: 
							[(sock1 sendDone and: [bytesSent < bytesToSend]) 
								ifTrue: 
									[packetsSent := packetsSent + 1.
									bytesSent := bytesSent + (sock1 sendSomeData: sendBuf)].
							sock2 dataAvailable 
								ifTrue: 
									[packetsRead := packetsRead + 1.
									bytesReceived := bytesReceived + (sock2 receiveDataInto: receiveBuf)].
							done := bytesSent >= bytesToSend and: [bytesReceived = bytesSent]]].
	Transcript
		show: 'closing connection';
		cr.
	sock1 waitForSendDoneFor: self standardTimeout.
	sock1 close.
	sock2 waitForDisconnectionFor: self standardTimeout.
	extraBytes := sock2 discardReceivedData.
	extraBytes > 0 
		ifTrue: 
			[Transcript
				show: ' *** received ' , extraBytes size printString , ' extra bytes ***';
				cr].
	sock2 close.
	sock1 waitForDisconnectionFor: self standardTimeout.
	sock1 isUnconnectedOrInvalid ifFalse: [self error: 'sock1 not closed'].
	sock2 isUnconnectedOrInvalid ifFalse: [self error: 'sock2 not closed'].
	Transcript
		show: '---------- Connection Closed ----------';
		cr.
	sock1 destroy.
	sock2 destroy.
	Transcript
		show: 'loopback test done; time = ' , t printString;
		cr.
	Transcript
		show: (bytesToSend asFloat / t roundTo: 0.01) printString 
					, '* 1000 bytes/sec';
		cr.
	Transcript endEntry! !

!Socket class methodsFor: 'instance creation' stamp: ''!
udpCreateIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."

	| sock |
	self initializeNetwork.
	sock := self newUDP.
	sock isValid ifFalse: [^ failBlock value].
	^ sock! !

!Socket class methodsFor: 'utilities' stamp: ''!
pingPorts: portList on: hostName timeOutSecs: timeOutSecs
	"Attempt to connect to each of the given sockets on the given host. Wait at most timeOutSecs for the connections to be established. Answer an array of strings indicating the available ports."

	"Socket pingPorts: #(7 13 19 21 23 25 80 110 119) on: 'pharo-project.org' timeOutSecs: 15"

	| serverAddr sockets startTime timeoutMsecs done result unconnectedCount connectedCount waitingCount |
	serverAddr := NetNameResolver addressForName: hostName timeout: 10.
	serverAddr 
		ifNil: [ 
			self inform: 'Could not find an address for ' , hostName.
			^ #() ].
	sockets := portList
		collect: [ :portNum | 
			| sock |
			sock := Socket new.
			sock connectTo: serverAddr port: portNum ].
	startTime := Time millisecondClockValue.
	timeoutMsecs := (1000 * timeOutSecs) truncated.
	done := false.
	[ done ]
		whileFalse: [ 
			unconnectedCount := 0.
			connectedCount := 0.
			waitingCount := 0.
			sockets
				do: [ :s | 
					s isUnconnectedOrInvalid
						ifTrue: [ unconnectedCount := unconnectedCount + 1 ]
						ifFalse: [ 
							s isConnected
								ifTrue: [ connectedCount := connectedCount + 1 ].
							s isWaitingForConnection
								ifTrue: [ waitingCount := waitingCount + 1 ] ] ].
			waitingCount = 0
				ifTrue: [ done := true ].
			connectedCount = sockets size
				ifTrue: [ done := true ].
			(Time millisecondsSince: startTime) >= timeoutMsecs
				ifTrue: [ done := true ] ].
	result := (sockets select: [ :s | s isConnected ]) collect: [ :s | self nameForWellKnownTCPPort: s remotePort ].
	sockets do: [ :s | s destroy ].
	^ result! !

!Socket class methodsFor: 'instance creation' stamp: ''!
createIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."
	"Note: The default creates a TCP socket"
	^self tcpCreateIfFail: failBlock! !

!Socket class methodsFor: 'utilities' stamp: ''!
standardTimeout

	^45! !

!Socket class methodsFor: 'tests' stamp: ''!
newAcceptCheck
	"Check if the platform has support for the BSD style accept()."

	"Socket newAcceptCheck"
	
	| socket |
	self initializeNetwork.
	socket := self newTCP.
	socket listenOn: 44444 backlogSize: 4.
	socket isValid ifTrue: [
		self inform: 'Everything looks OK for the BSD style accept()'
	] ifFalse: [
		self inform: 'It appears that you DO NOT have support for the BSD style accept()'].
	socket destroy! !

!Socket class methodsFor: 'utilities' stamp: ''!
pingPortsOn: hostName
	"Attempt to connect to a set of well-known sockets on the given host, and answer the names of the available ports."
	"Socket pingPortsOn: 'pharo.org'"

	^ Socket
		pingPorts: #(7 13 19 21 23 25 80 110 119)
		on: hostName
		timeOutSecs: 20! !

!Socket class methodsFor: 'utilities' stamp: ''!
wildcardPort
	"Answer a don't-care port for use with UDP sockets.  (The system will allocate an
	unused port number to the socket.)"

	^0! !

!Socket class methodsFor: 'utilities' stamp: ''!
deadServer: aStringOrNil
	"Keep the machine name of the most recently encoutered non-responding machine.  Next time the user can move it to the last in a list of servers to try."

	DeadServer := aStringOrNil! !

!SocketAddress commentStamp: ''!
I represent an IPv4 socket or network address .
I am a ByteArray.

A standard IPv4 address consists of 4 bytes and is usually shown in its human readeable dotted format (four decimal integers between 0 and 255 separated by dots).

Examples:

	SocketAddress fromDottedString: '192.168.1.10'.
	
	#[ 192 168 1 10 ] asSocketAddress.
	
	NetNameResolver localHostAddress.

	NetNameResolver addressForName: NetNameResolver localHostName.
	
Reference

	https://en.wikipedia.org/wiki/IP_address!
!SocketAddress methodsFor: 'testing' stamp: ''!
isPrivateAddress
	^ self first = 10
		or: [ (self first = 172 and: [ self second between: 16 and: 31 ])
				or: [ self first = 192 and: [ self second = 168 ] ] ]! !

!SocketAddress methodsFor: 'printing' stamp: ''!
displayStringOn: stream
	"Overwrite to get standard object behaviour"
	
	^ self printOn: stream! !

!SocketAddress methodsFor: 'printing' stamp: ''!
printOn: stream
	self 
		do: [ :each | each printOn: stream ] 
		separatedBy: [ stream nextPut: $. ]! !

!SocketAddress methodsFor: 'converting' stamp: ''!
asSocketAddress! !

!SocketAddress class methodsFor: 'instance creation' stamp: ''!
fromDottedString: string
	"Create a SocketAddress from its dotted notation"

	"self fromDottedString: '192.168.1.1'"

	| integers |
	integers := ($. split: string) collect: [ :each | Integer readFrom: each ].
	integers size = 4 ifFalse: [ SizeMismatch signal ].
	integers do: [ :each | 
		(each between: 0 and: 255)
			ifFalse: [ DomainError signalFrom: 0 to: 255 ] ].
	^ self newFrom: integers! !

!SocketAddress class methodsFor: 'instance creation' stamp: ''!
fromOldByteAddress: byteArray
	"Create a SocketAddress from byteArray, enforcing the correc length, 4"
	
	byteArray size = 4 ifFalse: [ SizeMismatch signal ].
	^ self newFrom: byteArray! !

!SocketAddress class methodsFor: 'instance creation' stamp: ''!
zero
	"Return the zero SocketAddress, 0.0.0.0"
	
	^ self basicNew: 4! !

!SocketAddressTest commentStamp: ''!
Unit test for SocketAddress!
!SocketAddressTest methodsFor: 'testing' stamp: ''!
testZero
	| address |
	address := SocketAddress zero.
	self assert: address size equals: 4.
	address do: [ :each | self assert: each isZero ].
	self assert: address equals: (SocketAddress fromDottedString: '0.0.0.0').
	self assert: address equals: (#[0 0 0 0] asSocketAddress).
	self assert: address printString equals: '0.0.0.0'! !

!SocketAddressTest methodsFor: 'testing' stamp: ''!
testDottedRepresentation
	| address |
	address := SocketAddress fromDottedString: '104.28.27.35'.
	self assert: address equals: #[ 104 28 27 35 ] asSocketAddress.
	self assert: address printString equals: '104.28.27.35'! !

!SocketAddressTest methodsFor: 'testing' stamp: ''!
testIsPrivateAddress
	#('10.0.0.1' '172.20.1.1' '192.168.10.12') do: [ :each | 
		self assert: (SocketAddress fromDottedString: each) isPrivateAddress ].
	#('127.0.0.1' '172.33.1.1' '104.28.27.35' '0.0.0.0') do: [ :each | 
		self deny: (SocketAddress fromDottedString: each) isPrivateAddress ]! !

!SocketAddressTest methodsFor: 'testing' stamp: ''!
testDottedRepresentationErrors
	self should: [ SocketAddress fromDottedString: '' ] raise: Error.
	self should: [ SocketAddress fromDottedString: '1' ] raise: Error.
	self should: [ SocketAddress fromDottedString: '1.2' ] raise: Error.
	self should: [ SocketAddress fromDottedString: '1.2.3' ] raise: Error.
	self should: [ SocketAddress fromDottedString: '1.2.3.4.5' ] raise: Error.
	self should: [ SocketAddress fromDottedString: '1.2.3.300' ] raise: Error.
	self should: [ SocketAddress fromDottedString: '1 . 2 . 3 . 200' ] raise: Error! !

!SocketAddressTest methodsFor: 'testing' stamp: ''!
testByteArrayConversionErrors
	self should: [ #[ ] asSocketAddress ] raise: Error.
	self should: [ #[ 1 ] asSocketAddress ] raise: Error.
	self should: [ #[ 1 2 ] asSocketAddress ] raise: Error.
	self should: [ #[ 1 2 3 ] asSocketAddress ] raise: Error.
	self should: [ #[ 1 2 3 4 5] asSocketAddress ] raise: Error! !

!SocketPrimitiveFailed commentStamp: ''!
Notify that a socket primitive failed!
!SocketStream commentStamp: ''!
SocketStream is a wrapper for class Socket making it easy to write networking code by giving the programmer a stream-like protocol. A Socket is a two way communication link with two logically separate channels - input and output. The Socket class is the lowest level in Pharo for network communication and using it directly can be difficult and bug prone.

A SocketStream can be in binary or ascii mode, ascii is the default which means you are transmitting and receiving Strings. Most Internet protocols are in clear text ascii, like for example HTTP. Another setting is what timeout you want to use - default is the standardTimeout from Socket. More settings can be found in the method category 'configuration'.

Simplest example of connecting, sending/receiving and closing:

| stream result |
stream := SocketStream openConnectionToHostNamed: 'www.pharo-project.org' port: 80.
[[stream nextPutAll: 'GET / HTTP/1.0'; crlf; crlf; flush.
result := stream upToEnd. "Give us all data until the socket is closed."
Transcript show: result; cr.]
	ensure: [stream close]]
		on: ConnectionTimedOut
		do: [:ex | Transcript show: ex asString;cr. ex resume]

There are two important things to note above:
	- The methods in category "stream in" can signal two exceptions (unless turned off with #shouldSignal:):
		ConnectionClosed and ConnectionTimedOut
	- We close the stream using #ensure:, that is to make sure it isn't left opened.
	- We use #on:do: to catch any signal. In this case we do not need to catch ConnectionClosed since #upToEnd does that for us intrinsically.

----------------
SocketStream (below called SS) is a reimplementation of 'Old'-SocketStream (below called OSS) - the class that originates from the original Comanche implementation but now is included in standard Squeak. SS has the same protocol as OSS and is meant to replace it. SS is faster, more flexible, is better documented and adds a few features:

1. #shouldSignal:, which decides if SS should signal low level Socket exceptions (true) or if it should swallow them like original OSS did. Default is true. The only reason I added this is for backwards compatibility - not signalling causes problems - see bug 4 below.

2. #nextAllInBuffer, #nextInBuffer:, #skip:, #receiveData:, #nextPutAllFlush: and #recentlyRead are new additions to the public protocol.


It also fixes various bugs:

1. #isDataAvailable could theoretically answer false, when there actually is some in the buffer in OSS. If #receiveDataIfAvailable reads the last byte then the following "socket dataAvailable" would answer false. So the last byte would be sitting in the inStream missed.

2. #upToAll: in OSS has several problems, for example - #positionOfSubCollection:ifAbsent: which was introduced answers one position too low. This was compensated in upToAll:, but only in the pushBack: call, not the actual result being returned which was cut short 1 byte. Amusingly this makes KomHttpServer not use "Keep-Alive" since the last $e in 'Alive' was cut short. :)

3. SS doesn't inherit from PositionableStream since that just breaks various inherited messages, like for example #skip:. OSS should IMHO be changed to inherit from Object - or of course, replaced in full with SS. :)

4. Since SocketStream by default signals closes and timeouts the SocketStreamTest now passes. The reason for SocketStream to fail is that while it does timeout on a low level (#SocketStream>>receiveData doesn't hang forever) - the callers of #receiveData sometimes loop - like in #next:, and thus eliminates the timeout. SS warns about some methods (in their method comments) not honouring timeouts if shouldSignal is false, I really don't know what they should do in that case:
	#next:, #upTo:, #upToAll: and #upToEnd (and #receiveData:)


The primary reason for the SS implementation is optimal performance. The main differences in implementation with the old OSS are:

1. SS uses two buffers directly (inBuffer and outBuffer) with pointers marking start and stop within the buffer. OSS instead uses two regular streams, a ReadStream and a WriteStream. Using internal buffers makes it possible to avoid copying and reallocation in various ways, it also makes SS be able to have specialized growing/buffer moving behaviour.

2. #upTo:, #upToAll: and #peekForAll: uses selectged String messages that in turn uses fast primitives for searching. OSS used other messages that fell back on byte per byte reading.

3. #receiveData in OSS creates a temporary buffer stream for each call!! During a long read operation, like say #upToAll: (which for example is used when uploading files using HTTP POST forms), this is devastating - especially since the default size is only 2000 bytes - and leads to a very high number of low level read operations on the Socket, typically 100 times more calls than with OSS. The buffer in OSS is held in an instvar (not recreated for each call), is larger from the start and above all - grows dynamically by doubling. OSS can also avoid a grow/reallocation by doing a "move down" if data has been read from the SS as it comes in and through that making room in the lower part of the inBuffer. The net result is that upToAll: for large files is about 10 times faster.

4. The implementation of upTo: and upToAll: tries to avoid doing unnecessary find operations in the buffer and is greedy by default, which means it favors reading more data - if available - before searching for the stop sequence. If we had #findString:startingAt:stoppingAt: this wouldn't have to be greedy and we wouldn't be needlessly scanning dead buffer area. VM hackers? Also, while you are at it - make it work for ByteArrays too. :)


SS can not be run unbuffered, since that seems unneeded. The option to autoFlush is still available, with it set to true SocketStream (just like OSS) will flush on its own on each nextPut:/nextPutAll:, otherwise flushing it will have to be done manually but is done on close.

The first performance tests shows that, as noted above, receiving large amounts of data using #upToAll: is greatly improved - factor of 10. Serving HTTP with small payloads seemed at first not be faster at all - but this is due to the high overhead of Socket connect/close and other things. Increasing payloads show a difference and especially with keep alive on - where the new SS roughly doubles the throughput!!!
!SocketStream methodsFor: 'private' stamp: ''!
moveInBufferDown
	"Move down contents of inBuffer to the start.
	Return distance moved."

	| sz distanceMoved |
	sz := inNextToWrite - lastRead - 1.
	inBuffer replaceFrom: 1 to: sz with: inBuffer startingAt: lastRead + 1.
	distanceMoved := lastRead.
	lastRead := 0.
	inNextToWrite := sz + 1.
	^distanceMoved! !

!SocketStream methodsFor: 'stream in' stamp: ''!
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.! !

!SocketStream methodsFor: 'configuration' stamp: ''!
outBufferSize
	"Answers the current size of data in the outBuffer."

	^outNextToWrite - 1! !

!SocketStream methodsFor: 'stream in' stamp: ''!
upToAll: aStringOrByteArray
	"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."

	"Note: The 100k limit below is compatible with the previous version though arguably incorrect. If you need unbounded behavior either up the argument or provide nil in which case we'll read until we get it or run out of memory"

	^self upToAll: aStringOrByteArray limit: 100000! !

!SocketStream methodsFor: 'configuration' stamp: ''!
shouldSignal: aBoolean
	"If shouldSignal is enabled the Socket Exceptions
	ConnectionClosed and ConnectionTimedOut will not be swallowed.
	Default is true. And please - don't set it to false - it is better to
	use an exception handler (see below)  and several methods
	in this class will not honour timeouts (says so in their method comments).
	Also, it is quite hard to understand what for example #upToEnd
	should return to indicate a timeout.
	
	Wrap your use of SocketStream with a handler like:
	
	[stuff := mySocketStream next: 10]
		on: ConnectionClosed, ConnectionTimedOut
		do: [:ex |
			Transcript show: 'Oops!! Did not get my ten bytes!!;cr]
	"

	shouldSignal := aBoolean! !

!SocketStream methodsFor: 'stream in' stamp: ''!
nextAllInBuffer
	"Return all data currently in the inBuffer,"

	^self nextInBuffer: inNextToWrite - lastRead - 1! !

!SocketStream methodsFor: 'stream in' stamp: ''!
peek
	"Return next byte, if inBuffer is empty
	we recieve some more data and try again.
	Do not consume the byte."

	self atEnd ifTrue: [^nil].
	self isInBufferEmpty ifTrue:
		[self receiveData.
		self atEnd ifTrue: [^nil]].
	^inBuffer at: lastRead+1! !

!SocketStream methodsFor: 'private' stamp: ''!
streamBuffer: size
	"Create a buffer of the correct class and given size."

	^(self isBinary
		ifTrue: [ByteArray]
		ifFalse: [String]) new: size! !

!SocketStream methodsFor: 'stream in' stamp: ''!
nextLine
	^self nextLineCrLf! !

!SocketStream methodsFor: 'stream out' stamp: ''!
next: n putAll: aCollection startingAt: startIndex
	"Put a String or a ByteArray onto the stream.
	Currently a large collection will allocate a large buffer.
	Warning: this does not work with WideString: they have to be converted first."

	self adjustOutBuffer: n.
	outBuffer replaceFrom: outNextToWrite to: outNextToWrite + n - 1 with: aCollection startingAt: startIndex.
	outNextToWrite := outNextToWrite + n.
	self checkFlush.
	^aCollection! !

!SocketStream methodsFor: 'control' stamp: ''!
receiveData: nBytes
	"Keep reading the socket until we have nBytes
	in the inBuffer or we reach the end. This method
	does not return data, but can be used to make sure
	data has been read into the buffer from the Socket
	before actually reading it from the FastSocketStream.
	Mainly used internally. We could also adjust the buffer
	to the expected amount of data and avoiding several
	incremental grow operations.

	NOTE: This method doesn't honor timeouts if shouldSignal
	is false!! And frankly, I am not sure how to handle that
	case or if I care - I think we should always signal."

	[self isConnected and: [nBytes > self inBufferSize]]
		whileTrue: [self receiveData]! !

!SocketStream methodsFor: 'private' stamp: ''!
resizeInBuffer: newSize
	"Resize the inBuffer by recreating it.
	This also has the effect of getting rid of
	dead data above inNextToWrite.
	<newSize> must >= inBuffer size!!"

	inBuffer := (self streamBuffer: newSize)
					replaceFrom: 1 to: inNextToWrite - 1 with: inBuffer startingAt: 1! !

!SocketStream methodsFor: 'testing' stamp: ''!
isConnected
	"The stream is connected if the socket is."

	^socket isConnected! !

!SocketStream methodsFor: 'configuration' stamp: ''!
ascii
	"Tell the SocketStream to send data
	as Strings instead of ByteArrays.
	This is default."

	binary := false.
	inBuffer
		ifNil: [self resetBuffers]
		ifNotNil:
			[inBuffer := inBuffer asString.
			outBuffer := outBuffer asString]! !

!SocketStream methodsFor: 'testing' stamp: ''!
atEnd
	"There is nothing more to read when
	there is no more data in our inBuffer, the socket
	is disconnected and there is none available on the socket.
	Note that we need to check isConnected before isDataAvailable,
	otherwise data may sneak in in the meantime. But we check the
	buffer first, because it is faster."

	self isInBufferEmpty ifFalse: [^false].
	^self isConnected not
		and: [self isDataAvailable not]! !

!SocketStream methodsFor: 'configuration' stamp: ''!
bufferSize: anInt
	"Default buffer size is 4kb.
	increased from earlier 2000 bytes."

	bufferSize := anInt! !

!SocketStream methodsFor: 'stream in' stamp: ''!
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! !

!SocketStream methodsFor: 'stream in' stamp: ''!
nextLineLf
	| nextLine |
	nextLine := self upToAll: String lf.
	^nextLine! !

!SocketStream methodsFor: 'stream in' stamp: ''!
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.! !

!SocketStream methodsFor: 'configuration' stamp: ''!
timeout: seconds
	timeout := seconds! !

!SocketStream methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	autoFlush := true.
	shouldSignal := true.
	recentlyRead := 0.
	bufferSize := 4096.
	self ascii! !

!SocketStream methodsFor: 'configuration' stamp: ''!
binary
	"Tell the SocketStream to send data
	as ByteArrays instead of Strings.
	Default is ascii."

	binary := true.
	inBuffer
		ifNil: [self resetBuffers]
		ifNotNil:
			[inBuffer := inBuffer asByteArray.
			outBuffer := outBuffer asByteArray]! !

!SocketStream methodsFor: 'stream in' stamp: ''!
next
	"Return next byte, if inBuffer is empty
	we recieve some more data and try again."

	self atEnd ifTrue: [^nil].
	self isInBufferEmpty ifTrue:
		[self receiveData.
		self atEnd ifTrue: [^nil]].
	lastRead := lastRead + 1.
	^inBuffer at: lastRead! !

!SocketStream methodsFor: 'configuration' stamp: ''!
noTimeout
	"Do not use timeout."

	timeout := 0! !

!SocketStream methodsFor: 'private' stamp: ''!
adjustOutBuffer: bytesToWrite
	"Possibly grow outBuffer to accommodate the new data.
	Currently grows through doubling when less
	than 1024 bytes are left. If bytesToWrite is even
	larger we double that instead. Never shrinks."

	(outBuffer size - outNextToWrite - bytesToWrite) < 1024 ifTrue: [
		outBuffer := (self streamBuffer: ((outBuffer size max: bytesToWrite) * 2))
						replaceFrom: 1 to: outBuffer size with: outBuffer startingAt: 1]! !

!SocketStream methodsFor: 'configuration' stamp: ''!
autoFlush
	"If autoFlush is enabled data will be sent through
	the socket (flushed) when the bufferSize is reached
	or the SocketStream is closed. Otherwise the user
	will have to send #flush manually.
	Close will always flush. Default is false."

	^autoFlush! !

!SocketStream methodsFor: 'testing' stamp: ''!
isDataAvailable
	"It the inbuffer is empty, we check the socket for data.
	If it claims to have data available to read, we try to read
	some once and recursively call this method again.
	If something really was available it is now in the inBuffer.
	This is because there has been spurious
	dataAvailable when there really is no data to get."
 
	self isInBufferEmpty ifFalse: [^true].
	^socket dataAvailable
		ifFalse: [false]
		ifTrue: [self receiveDataIfAvailable; isDataAvailable]! !

!SocketStream methodsFor: 'configuration' stamp: ''!
socket: aSocket
	socket := aSocket! !

!SocketStream methodsFor: 'printing' stamp: ''!
debug
	"Display debug info."

	| data |
	data := self inBufferSize.
	^String streamContents: [:s |
		s
			nextPutAll: 'Buffer size: ', inBuffer size asString;cr;
			nextPutAll: 'InBuffer data size: ', data asString; cr;
			nextPutAll: 'In data (20):', (inBuffer copyFrom: lastRead + 1 to: lastRead + (data min: 20)); cr;
			nextPutAll: 'OutBuffer data size: ', (outNextToWrite - 1) asString; cr;
			nextPutAll: 'Out data (20):', (outBuffer copyFrom: 1 to: ((outNextToWrite - 1) min: 20)); cr]! !

!SocketStream methodsFor: 'stream in' stamp: ''!
peekFor: aCharacterOrByte
	"Read and return next character or byte
	if it is equal to the argument.
	Otherwise return false."

	| nextObject |
	self atEnd ifTrue: [^false].
	self isInBufferEmpty ifTrue: 
		[self receiveData.
		self atEnd ifTrue: [^false]].
	nextObject := inBuffer at: lastRead + 1.
	nextObject = aCharacterOrByte ifTrue: [
		lastRead := lastRead + 1.
		^true].
	^false! !

!SocketStream methodsFor: 'stream out' stamp: ''!
nextPutAllFlush: aCollection
	"Put a String or a ByteArray onto the stream.
	You can use this if you have very large data - it avoids
	copying into the buffer (and avoids buffer growing)
	and also flushes any other pending data first."

	| toPut |
	toPut := binary ifTrue: [aCollection asByteArray] ifFalse: [aCollection asString].
	self flush. "first flush pending stuff, then directly send"
	socket isOtherEndClosed ifFalse: [
		[socket sendData: toPut count: toPut size]
			on: ConnectionTimedOut
			do: [:ex | shouldSignal ifFalse: ["swallow"]]]! !

!SocketStream methodsFor: 'stream in' stamp: ''!
readInto: aCollection startingAt: startIndex count: anInteger
	"Read n objects into the given collection starting at startIndex. 
	Return number of elements that have been read."

	"Implementation note: This method DOES signal timeout if not 
	enough elements are received. It does NOT signal
	ConnectionClosed as closing the connection is the only way by
	which partial data can be read."

	| start amount |

	[self receiveData: anInteger] on: ConnectionClosed do:[:ex| ex return].

	"Inlined version of nextInBuffer: to avoid copying the contents"
	amount := anInteger min: (inNextToWrite - lastRead - 1).
	start := lastRead + 1.
	lastRead := lastRead + amount.
	aCollection 
		replaceFrom: startIndex 
		to: startIndex + amount-1 
		with: inBuffer 
		startingAt: start.
	^amount! !

!SocketStream methodsFor: 'private - socket' stamp: ''!
receiveDataIfAvailable
	"Only used to check that there really is data to read
	from the socket after it signals dataAvailable.
	It has been known to signal true and then still
	not have anything to read. See also isDataAvailable.
	Return the position in the buffer where the
	new data starts, regardless if anything
	was read, see #adjustInBuffer."

	recentlyRead := socket receiveSomeDataInto: inBuffer startingAt: inNextToWrite.
	^self adjustInBuffer: recentlyRead! !

!SocketStream methodsFor: 'stream in' stamp: ''!
upTo: aCharacterOrByte
	"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."

	"Note: The 100k limit below is compatible with the previous version though arguably incorrect. If you need unbounded behavior either up the argument or provide nil in which case we'll read until we get it or run out of memory"

	^ binary 
		ifTrue: [self upTo: aCharacterOrByte asInteger limit: 100000]
		ifFalse: [ self upTo: aCharacterOrByte asCharacter limit: 100000]! !

!SocketStream methodsFor: '*Fuel-Core' stamp: ''!
nextBytesPutAll: aCollection
	"Append the bytes of aCollection to the sequence of bytes accessible 
	by the receiver. Answer aCollection."

	^ self nextPutAll: aCollection! !

!SocketStream methodsFor: 'stream in' stamp: ''!
peekForAll: aString
	"Answer whether or not the next string of characters in the receiver
	matches aString. If a match is made, advance over that string in the receiver and
	answer true. If no match, then leave the receiver alone and answer false.
	We use findString:startingAt: to avoid copying.

	NOTE: This method doesn't honor timeouts if shouldSignal is false!!"

	| sz start |
	sz := aString size.
	self receiveData: sz.
	(inNextToWrite - lastRead - 1) < sz ifTrue: [^false].
	start := lastRead + 1.
	(inBuffer findString: aString startingAt: start) = start
		ifFalse: [^false].
	lastRead := lastRead + sz.
	^true! !

!SocketStream methodsFor: 'printing' stamp: ''!
print: anObject
	anObject printOn: self! !

!SocketStream methodsFor: 'testing' stamp: ''!
isEmpty
	"Test if there are more data to read."

	^self isInBufferEmpty and: [self isDataAvailable not]! !

!SocketStream methodsFor: 'testing' stamp: ''!
ifStale: aBlock
	self isConnected
		ifFalse: aBlock! !

!SocketStream methodsFor: 'private' stamp: ''!
position
	^lastRead! !

!SocketStream methodsFor: 'testing' stamp: ''!
isOtherEndConnected
	^socket isOtherEndClosed not! !

!SocketStream methodsFor: 'stream in' stamp: ''!
next: anInteger
	"Read count elements and return them in a collection.
	If the receiver is #atEnd before count elements were read, 
	return a smaller collection and don't signal ConnectionClosed."

	^ self nextInto: (self streamBuffer: anInteger)! !

!SocketStream methodsFor: 'stream in' stamp: ''!
upToEnd
	"Answer all data coming in on the socket until the socket
	is closed by the other end, or we get a timeout.
	This means this method catches ConnectionClosed by itself.
	
	NOTE: Does not honour timeouts if shouldSignal is false!!"

	[[self isConnected] whileTrue: [self receiveData]]
		on: ConnectionClosed
		do: [:ex | "swallow it"]. 
	^self nextAllInBuffer! !

!SocketStream methodsFor: 'stream in' stamp: ''!
next: requestedCount into: collection startingAt: startIndex
	"Read requestedCount objects into the given collection. 
	Return collection or a partial copy if less elements have been read."

	| readCount |
	readCount := self readInto: collection startingAt: startIndex count: requestedCount.
	^ readCount = requestedCount
		ifTrue: [ collection ]
		ifFalse: [ collection copyFrom: 1 to: startIndex + readCount - 1 ]! !

!SocketStream methodsFor: 'testing' stamp: ''!
isBinary
	^binary! !

!SocketStream methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Display buffer sizes."

	aStream nextPutAll: self class name.
	inBuffer ifNotNil: [
		aStream 
			nextPutAll: '[inbuf:';
			print: (inBuffer size / 1024) rounded;
			nextPutAll: 'kb/outbuf:';
		 	print: (outBuffer size / 1024) rounded;
			nextPutAll: 'kb]']! !

!SocketStream methodsFor: 'stream in' stamp: ''!
nextAvailable
	"Answer all the data currently available,
	in buffer or in socket."

	self isInBufferEmpty ifFalse: [^self nextAllInBuffer].
	self isDataAvailable ifTrue: [self receiveData].
	^self nextAllInBuffer! !

!SocketStream methodsFor: 'configuration' stamp: ''!
autoFlush: aBoolean
	"If autoFlush is enabled data will be sent through
	the socket (flushed) when the bufferSize is reached
	or the SocketStream is closed. Otherwise the user
	will have to send #flush manually.
	Close will always flush. Default is false."

	autoFlush := aBoolean! !

!SocketStream methodsFor: 'control' stamp: ''!
recentlyRead
	"Return the number of bytes read
	during the last socket operation."
	
	^recentlyRead! !

!SocketStream methodsFor: 'stream out' stamp: ''!
nextPut: char
	"Put a single Character or byte onto the stream."

	| toPut |
	toPut := binary ifTrue: [char asInteger] ifFalse: [char asCharacter].
	self adjustOutBuffer: 1.
	outBuffer at: outNextToWrite put: toPut.
	outNextToWrite := outNextToWrite + 1.
	self checkFlush.
	"return the argument - added by kwl"
	^ char! !

!SocketStream methodsFor: 'private' stamp: ''!
growInBuffer
	"Grows through doubling."

	self resizeInBuffer: inBuffer size * 2! !

!SocketStream methodsFor: 'private' stamp: ''!
resetBuffers
	"Recreate the buffers with default start sizes."

	inBuffer := self streamBuffer: bufferSize.
	lastRead := 0.
	inNextToWrite := 1.
	outBuffer := self streamBuffer: bufferSize.
	outNextToWrite := 1! !

!SocketStream methodsFor: 'testing' stamp: ''!
shouldTimeout
	^self timeout > 0! !

!SocketStream methodsFor: 'control' stamp: ''!
close
	"Flush any data still not sent
	and take care of the socket."

	self flush.
	socket closeAndDestroy: 30! !

!SocketStream methodsFor: 'configuration' stamp: ''!
timeout
	"Lazily initialized unless it has been set explicitly."

	timeout ifNil: [timeout := Socket standardTimeout].
	^timeout! !

!SocketStream methodsFor: 'control' stamp: ''!
destroy
	"Destroy the receiver and its underlying socket. Does not attempt to flush the output buffers. For a graceful close use SocketStream>>close instead."
	socket ifNotNil: [socket destroy]! !

!SocketStream methodsFor: 'control' stamp: ''!
flush
	"If the other end is connected and we have something
	to send, then we send it and reset the outBuffer."

	((outNextToWrite > 1) and: [socket isOtherEndClosed not])
		ifTrue: [
			[socket sendData: outBuffer count: outNextToWrite - 1]
				on: ConnectionTimedOut
				do: [:ex | shouldSignal ifFalse: ["swallow"]].
			outNextToWrite := 1]! !

!SocketStream methodsFor: 'configuration' stamp: ''!
bufferSize
	"Default buffer size is 4kb.
	increased from earlier 2000 bytes."
	
	^bufferSize! !

!SocketStream methodsFor: 'private' stamp: ''!
adjustInBuffer: bytesRead
	"Adjust markers and possibly grow inBuffer or move data down.
	Currently grows through doubling when less than 1024 bytes are left.
	Never shrinks. Returns the position in the buffer where any new
	data can be found."

	| old |
	bytesRead = 0 ifTrue: [^inNextToWrite].
	old := inNextToWrite.
	inNextToWrite := inNextToWrite + bytesRead.
	(inBuffer size - inNextToWrite) < 1024
		ifTrue: [
			"Hit the roof, move data down (if enough has been read) or do we grow?"
			(lastRead > 512)
				ifTrue: [^old - self moveInBufferDown]
				ifFalse: [self growInBuffer]].
	^old! !

!SocketStream methodsFor: 'testing' stamp: ''!
isStream
	^true! !

!SocketStream methodsFor: 'configuration' stamp: ''!
socket
	^socket! !

!SocketStream methodsFor: 'private - socket' stamp: ''!
receiveAvailableData
	"Receive available data (as much as fits in the inBuffer)
	but not waiting for more to arrive.
	Return the position in the buffer where the
	new data starts, regardless if anything
	was read, see #adjustInBuffer."
	
	recentlyRead := socket receiveAvailableDataInto: inBuffer startingAt: inNextToWrite.
	^self adjustInBuffer: recentlyRead! !

!SocketStream methodsFor: 'stream in' stamp: ''!
upToAll: aStringOrByteArray limit: nBytes
	"Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aStringOrByteArray. If aCollection is not in the stream, or not found within nBytes answer the available contents of the stream"

	| index sz result searchedSoFar |
	sz := aStringOrByteArray size.
	"Look in the current inBuffer first"
	index := inBuffer indexOfSubCollection: aStringOrByteArray
						startingAt: lastRead - sz + 2.
	(index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it"
		result := self nextInBuffer: index - lastRead - 1.
		self skip: sz.
		^ result
	].

	[searchedSoFar :=  self inBufferSize.
	"Receive more data"
	self receiveData.
	recentlyRead > 0] whileTrue:[

		"Data begins at lastRead + 1, we add searchedSoFar as offset and 
		backs up sz - 1 so that we can catch any borderline hits."

		index := inBuffer indexOfSubCollection: aStringOrByteArray
						startingAt: (lastRead + searchedSoFar - sz + 2 max: 1).
		(index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it"
			result := self nextInBuffer: index - lastRead - 1.
			self skip: sz.
			^ result
		].
		"Check if we've exceeded the max. amount"
		(nBytes notNil and:[inNextToWrite - lastRead > nBytes]) 
			ifTrue:[^self nextAllInBuffer].
	].

	"Windows doesn't raise an Exception when connection is closed at first, so we check here the status of the connection"
	self shouldSignal ifTrue: [
		self isOtherEndConnected ifFalse: [ConnectionClosed signal: 'Connection closed while waiting for data.'].
	].

	"not found and (non-signaling) connection was closed"
	^self nextAllInBuffer! !

!SocketStream methodsFor: 'stream in' stamp: ''!
nextAvailable: howMany
	"Answer all the data currently available,
	in buffer or in socket - but limited to <howMany>."

	self isInBufferEmpty ifFalse: [^self nextInBuffer: howMany].
	self isDataAvailable ifTrue: [self receiveData].
	^self nextInBuffer: howMany! !

!SocketStream methodsFor: 'stream in' stamp: ''!
peek: anInteger
	"Answer anInteger bytes of data.
	Do not consume data.

	NOTE: This method doesn't honor timeouts if shouldSignal is false!!"

	| start |
	self receiveData: anInteger.
	start := lastRead + 1.
	^inBuffer copyFrom: start to: ((lastRead + anInteger) min: inNextToWrite - 1).! !

!SocketStream methodsFor: 'stream out' stamp: ''!
space
	self nextPut: Character space! !

!SocketStream methodsFor: 'configuration' stamp: ''!
inBufferSize
	"Answers the current size of data in the inBuffer."

	^inNextToWrite - lastRead - 1! !

!SocketStream methodsFor: 'private' stamp: ''!
<< anObject
	"Write anObject to the receiver, dispatching using #putOn:
	This is a shortcut for both nextPut: and nextPutAll: since anObject can be both
	the element type of the receiver as well as a collection of those elements.
	No further conversions of anObject are applied.
	Return self to accomodate chaining."

 	anObject putOn: self! !

!SocketStream methodsFor: 'stream out' stamp: ''!
sendCommand: aString
	"Sends a String ending it with CR LF and then flush
	causing it to block until sent."

	self nextPutAll: aString, String crlf; flush! !

!SocketStream methodsFor: 'testing' stamp: ''!
isInBufferEmpty
	"Any data in the buffer?"
 
	^lastRead + 1 = inNextToWrite! !

!SocketStream methodsFor: 'stream in' stamp: ''!
skip: anInteger
	"Skip a number of bytes.
	This is faster than #next: since it does not
	have to copy and return a new String or ByteArray.

	NOTE: This method doesn't honor timeouts if shouldSignal is false!!"

	self receiveData: anInteger.
	lastRead := (lastRead + anInteger) min: inNextToWrite - 1! !

!SocketStream methodsFor: 'stream in' stamp: ''!
nextLineCrLf
	^self upToAll: String crlf! !

!SocketStream methodsFor: 'private' stamp: ''!
checkFlush
	"If autoFlush is true we flush if
	we have reached the bufferSize
	of data in the outBuffer."

	(autoFlush and: [outNextToWrite > bufferSize])
		ifTrue: [self flush]! !

!SocketStream methodsFor: 'stream in' stamp: ''!
nextInBuffer: anInteger
	"Answer anInteger bytes of data at most,
	but only from the inBuffer."

	| start amount |
	amount := anInteger min: (inNextToWrite - lastRead - 1).
	start := lastRead + 1.
	lastRead := lastRead + amount.
	^inBuffer copyFrom: start to: lastRead! !

!SocketStream methodsFor: 'configuration' stamp: ''!
shouldSignal
	"If shouldSignal is enabled the Socket Exceptions
	ConnectionClosed and ConnectionTimedOut
	will not be swallowed. Default is true.
	For more info, see #shouldSignal:"

	^shouldSignal! !

!SocketStream methodsFor: 'stream in' stamp: ''!
upTo: aCharacterOrByte limit: nBytes
	"Return data up to, but not including given character or byte. If the character is not in the stream, or not found within nBytes answer the available contents of the stream"

	| index result searchedSoFar |
	"Look in the current inBuffer first"
	index := inBuffer indexOf: aCharacterOrByte startingAt: lastRead + 1.

	(index > 0 and: [(index + 1) <= inNextToWrite]) ifTrue: ["found it"
		result := self nextInBuffer: index - lastRead - 1.
		self skip: 1.
		^ result
	].

	[searchedSoFar :=  self inBufferSize.
	"Receive more data"
	self receiveData.
	"We only get recentlyRead = 0 in the case of a non-signaling socket close."
	recentlyRead > 0] whileTrue:[
		"Data begins at lastRead + 1, we add searchedSoFar as offset."

		index := inBuffer indexOf: aCharacterOrByte
						startingAt: (lastRead + searchedSoFar + 1).
		(index > 0 and: [(index + 1) <= inNextToWrite]) ifTrue: ["found it"
			result := self nextInBuffer: index - lastRead - 1.
			self skip: 1.
			^ result
		].

		"Check if we've exceeded the max. amount"
		(nBytes notNil and:[inNextToWrite - lastRead > nBytes]) 
			ifTrue:[^self nextAllInBuffer].
	].

	"Windows doesn't raise an Exception when connection is closed at first, so we check here the status of the connection"
	self shouldSignal ifTrue: [
		self isOtherEndConnected ifFalse: [ConnectionClosed signal: 'Connection closed while waiting for data.'].
	].

	"not found and (non-signaling) connection was closed"
	^self nextAllInBuffer! !

!SocketStream methodsFor: 'stream out' stamp: ''!
crlf
	self nextPutAll: String crlf! !

!SocketStream methodsFor: 'stream out' stamp: ''!
nextPutAll: aCollection
	"Put a String or a ByteArray onto the stream.
	Currently a large collection will allocate a large buffer."

	| toPut |
	toPut := binary ifTrue: [aCollection asByteArray] ifFalse: [aCollection asString].
	self adjustOutBuffer: toPut size.
	outBuffer replaceFrom: outNextToWrite to: outNextToWrite + toPut size - 1 with: toPut startingAt: 1.
	outNextToWrite := outNextToWrite + toPut size.
	self checkFlush.
	^aCollection! !

!SocketStream methodsFor: 'private - socket' stamp: ''!
receiveData
	"Receive data with timeout if it has been set.
	If shouldSignal is false we use the Socket methods
	that swallow those Exceptions, if it is true the
	caller will have to handle those Exceptions.
	Return the position in the buffer where the
	new data starts, regardless if anything
	was read, see #adjustInBuffer."
	
	recentlyRead := shouldSignal ifTrue: [
		self shouldTimeout ifTrue: [
				socket receiveDataSignallingTimeout: timeout
					into: inBuffer startingAt: inNextToWrite]
			ifFalse: [
				socket receiveDataSignallingClosedInto: inBuffer
					startingAt: inNextToWrite]]
				ifFalse: [
		self shouldTimeout ifTrue: [
			"This case is tricky, if it times out and is swallowed
			how does other methods calling this method repeatedly
			get to know that? And what should they do?"
				socket receiveDataTimeout: timeout
					into: inBuffer startingAt: inNextToWrite]
			ifFalse: [
				socket receiveDataInto: inBuffer
					startingAt: inNextToWrite]].
	^self adjustInBuffer: recentlyRead! !

!SocketStream methodsFor: 'stream out' stamp: ''!
cr
	self nextPutAll: String cr! !

!SocketStream class methodsFor: 'instance creation' stamp: ''!
openConnectionToHost: hostIP port: portNumber timeout: timeout
	| socket |
	socket := Socket new.
	socket connectTo: hostIP port: portNumber waitForConnectionFor: timeout.
	^self on: socket! !

!SocketStream class methodsFor: 'instance creation' stamp: ''!
on: socket
	"Create a socket stream on a connected server socket."

	^self basicNew initialize socket: socket! !

!SocketStream class methodsFor: 'examples' stamp: ''!
finger: userName
	"SocketStream finger: 'stp'"

	| addr s |
	addr := NetNameResolver promptUserForHostAddress.
	s := SocketStream openConnectionToHost: addr port: 79.	"finger port number"
	self traceCr: '---------- Connecting ----------'.
	s sendCommand: userName.
	self trace: s nextLineCrLf.
	s close.
	self traceCr: '---------- Connection Closed ----------'! !

!SocketStream class methodsFor: 'instance creation' stamp: ''!
openConnectionToHostNamed: hostName port: portNumber
	| hostIP |
	hostIP := NetNameResolver addressForName: hostName timeout: 20.
	^self openConnectionToHost: hostIP port: portNumber! !

!SocketStream class methodsFor: 'instance creation' stamp: ''!
openConnectionToHost: hostIP port: portNumber
	^ self openConnectionToHost: hostIP port: portNumber timeout: Socket standardTimeout! !

!SocketStreamTest commentStamp: ''!
SUnit tests for socket streams!
!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testNextIntoClose
	"Ensure that #next:into: will function properly when the connection is closed"

	clientStream nextPutAll:'A line of text'; flush.
	[(Delay forMilliseconds: 100) wait.
	clientStream close] fork.
	self assert: (serverStream next: 100 into: (String new: 100) startingAt: 1) 
		equals: 'A line of text'! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToAfterCloseSignaling
	"Tests correct behavior of #upToAll"

	clientStream nextPutAll:'A line of text'.
	clientStream close.
	self should: [serverStream upTo: Character cr] raise: ConnectionClosed! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToEndCloseNonSignaling
	"Ensure that #upToEnd will function properly when the connection is closed"

	serverStream shouldSignal: false.
	clientStream nextPutAll:'A line of text'; flush.
	[(Delay forMilliseconds: 100) wait.
	clientStream close] fork.
	self assert: (serverStream upToEnd)
		equals: 'A line of text'! !

!SocketStreamTest methodsFor: 'running' stamp: ''!
tearDown
	clientStream ifNotNil:[clientStream destroy].
	serverStream ifNotNil:[serverStream destroy].
	super tearDown! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToAllAfterCloseNonSignaling
	"Tests correct behavior of #upToAll"

	| resp |
	clientStream nextPutAll: 'A line of text'.
	clientStream close.
	serverStream shouldSignal: false.
	resp := serverStream upToAll: String crlf.
	self assert: resp equals: 'A line of text'! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToAfterCloseNonSignaling
	"Tests correct behavior of #upToAll"

	| resp |
	clientStream nextPutAll: 'A line of text'.
	clientStream close.
	serverStream shouldSignal: false.
	resp := serverStream upTo: Character cr.
	self assert: resp equals: 'A line of text'! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToAllTimeout
	"Tests correct behavior of #upToAll"

	clientStream nextPutAll: 'A line of text'.
	serverStream timeout: 1.
	self should: [ serverStream upToAll: String crlf ] raise: ConnectionTimedOut! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToMax
	"Tests correct behavior of #upToAll:max:"

	clientStream nextPutAll:'A line of text'; flush.
	self assert: (serverStream upTo: Character cr limit: 5) equals: 'A line of text'! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToTimeout
	"Tests correct behavior of #upToAll"

	clientStream nextPutAll: 'A line of text'.
	serverStream timeout: 1.
	self should: [serverStream upTo: Character cr] raise: ConnectionTimedOut! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToWithByteArray
	"Tests correct behavior of #upTo:"

	|byteArray|
	
	byteArray := ('A line of text', String cr, 'with more text') asByteArray.
	clientStream binary.
	serverStream binary.
	clientStream nextPutAll: byteArray; flush.
	self assert: (serverStream upTo: Character cr) asString equals: 'A line of text'.
	[(Delay forSeconds: 1) wait.
	clientStream nextPut: Character cr; flush] fork.
	self assert: (serverStream upTo: Character cr) asString equals: 'with more text'! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToAll
	"Tests correct behavior of #upToAll"

	clientStream nextPutAll: 'A line of text', String crlf, 'with more text'; flush.
	self assert: (serverStream upToAll: String crlf) equals: 'A line of text'.
	[(Delay forSeconds: 1) wait.
	clientStream nextPutAll: String crlf; flush] fork.
	self assert: (serverStream upToAll: String crlf) equals: 'with more text'! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testNextIntoCloseNonSignaling
	"Ensure that #next:into: will function properly when the connection is closed"

	serverStream shouldSignal: false.
	clientStream nextPutAll:'A line of text'; flush.
	[(Delay forMilliseconds: 100) wait.
	clientStream close] fork.
	self assert: (serverStream next: 100 into: (String new: 100) startingAt: 1)
		equals: 'A line of text'! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToAllAfterCloseSignaling
	"Tests correct behavior of #upToAll"

	clientStream nextPutAll:'A line of text'.
	clientStream close.
	self should: [serverStream upToAll: String crlf] raise: ConnectionClosed! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToAllLimit
	"Tests correct behavior of #upToAll:limit:"

	clientStream nextPutAll:'A line of text'; flush.
	self assert: (serverStream upToAll: String crlf limit: 5) equals: 'A line of text'! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpTo
	"Tests correct behavior of #upTo:"

	clientStream nextPutAll: 'A line of text', String cr, 'with more text'; flush.
	self assert: (serverStream upTo: Character cr) equals: 'A line of text'.
	[(Delay forSeconds: 1) wait.
	clientStream nextPutAll: String cr; flush] fork.
	self assert: (serverStream upTo: Character cr) equals: 'with more text'! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToEndClose
	"Ensure that #upToEnd will function properly when the connection is closed"

	clientStream nextPutAll:'A line of text'; flush.
	[(Delay forMilliseconds: 100) wait.
	clientStream close] fork.
	self assert: (serverStream upToEnd) 
		equals: 'A line of text'! !

!SocketStreamTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ SocketStream! !

!SocketStreamTest methodsFor: 'stream protocol' stamp: ''!
testUpToSmallInteger
	"Tests correct behavior of #upTo:"

	clientStream nextPutAll: 'A line of text', String cr, 'with more text'; flush.
	self assert: (serverStream upTo: Character cr) equals: 'A line of text'.
	[(Delay forSeconds: 1) wait.
	clientStream nextPutAll: String cr; flush] fork.
	self assert: (serverStream upTo: 13) equals: 'with more text'! !

!SocketStreamTest methodsFor: 'running' stamp: ''!
setUp
	| listener clientSocket serverSocket |
	super setUp.
	listener := Socket newTCP.
	[listener listenOn: 0 backlogSize: 4.

	clientSocket := Socket newTCP.
	clientSocket connectTo: #[127 0 0 1] port: listener localPort.
	clientSocket waitForConnectionFor: 1.
	self assert: clientSocket isConnected.

	serverSocket := listener waitForAcceptFor: 1.
	self assert: serverSocket isConnected.
	] ensure:[listener destroy].

	clientStream := SocketStream on: clientSocket.
	serverStream := SocketStream on: serverSocket.! !

!SolidFillStyle commentStamp: ''!
SolidFillStyle is a fill which represents a color for the BalloonEngine.

Instance variables:
	color	<Color>	The color to use.
	pixelValue32 <Integer>	The cached pixel value to use.!
!SolidFillStyle methodsFor: 'accessing' stamp: ''!
color: aColor
	color := aColor.
	pixelValue32 := aColor scaledPixelValue32! !

!SolidFillStyle methodsFor: 'comparing' stamp: ''!
= aFillStyle

	^ aFillStyle species = self species
		and: [ self asColor = aFillStyle asColor ]! !

!SolidFillStyle methodsFor: 'testing' stamp: ''!
isTranslucent
	^color isTranslucent! !

!SolidFillStyle methodsFor: 'comparing' stamp: ''!
hash

	^ color hash! !

!SolidFillStyle methodsFor: '*Athens-Balloon' stamp: ''!
asAthensPaintOn: anAthensCanvas 

	^ anAthensCanvas surface createSolidColorPaint: color! !

!SolidFillStyle methodsFor: 'converting' stamp: ''!
asColor
	^color! !

!SolidFillStyle methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(; print: color; nextPut:$).! !

!SolidFillStyle methodsFor: 'accessing' stamp: ''!
scaledPixelValue32
	"Return the alpha scaled pixel value for depth 32"
	^pixelValue32! !

!SolidFillStyle methodsFor: '*Morphic-Base' stamp: ''!
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: #color: originalColor: self asColor hand: evt hand! !

!SolidFillStyle methodsFor: '*Morphic-Base' stamp: ''!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	aMenu add: 'change color...' target: self selector: #changeColorIn:event: argument: aMorph! !

!SolidFillStyle methodsFor: 'testing' stamp: ''!
isTransparent
	^color isTransparent! !

!SolidFillStyle methodsFor: 'testing' stamp: ''!
isSolidFill
	^true! !

!SolidFillStyle class methodsFor: 'instance creation' stamp: ''!
color: aColor
	^self new color: aColor! !

!SortFunction commentStamp: ''!
I am intended to be used in place of two arg sort blocks.

Usage

In the following example, an ascending SortFunction is created based on the result of the #first message send to each object.
#(#(1 2) #(2 3) #(0 0)) sorted: #first ascending.

To sort by the #last element, but descending, the following would be used:
#(#(1 2) #(2 3) #(0 0)) sorted: #last descending.

One can use blocks as well. The following sorts in descending order, the sub elements based on the sum of their values.
| sumBlock |
sumBlock := [:sequence | sequence inject: 0 into: [:sum :each | sum + each]].
#(#(1 2) #(2 3) #(0 0)) sorted: sumBlock descending.

One can even use 2 arg blocks, for those cases where the function isn't expressible with objects that respond to < and =. The only catch, is that such a function has to return not true and false, but instead a collation order, values of -1 (for before), 0 (the same) or 1 (to follow). For example:

| oddBlock |
oddBlock :=
		[:a :b |
		a odd = b odd ifTrue: [0] ifFalse: [a odd ifTrue: [-1] ifFalse: [1]]].
#(1 5 1 3 2 7 9 4 6) asSortedCollection: oddBlock descending

Using #undefinedFirst and #undefinedLast it is possible to deal with nil values, moving them first or last. For Example:

#(a nil z b) sorted: #value ascending undefinedFirst.
#(a nil z b) sorted: #value ascending undefinedLast.

Different scenarios are implemented by my different subclasses:
- SortByPropertyFunction implement property comparison by selector or block
- CollatorBlockFunction represent two args collator block
- and ChainedSortFunction implements composition of collators created by comma message

Applications can implement their own domain sort functions defining the method:
	collate: anObject1 with: anObject2
!
!SortFunction methodsFor: 'converting' stamp: ''!
undefinedFirst
	"Return a new SortFunction that sort all the nil first, an non nil with myself."
	^(UndefinedSortFunction on: self) undefinedFirst! !

!SortFunction methodsFor: 'converting' stamp: ''!
asSortFunction

	^self! !

!SortFunction methodsFor: 'evaluating' stamp: ''!
collate: anObject1 with: anObject2
	"Do a three-way comparison between the anObject1 and anObject2, returning
	-1 if anObject1 < anObject2
	0 if anObject1 = anObject2
	1 if anObject1 > anObject2
	This assumes a total order in accordance with the mathematical law of trichotomy.
	See also:  http://en.wikipedia.org/wiki/Three-way_comparison"
	self subclassResponsibility ! !

!SortFunction methodsFor: 'converting' stamp: ''!
undefinedLast
	"Return a new SortFunction that sort all the nil last, an non nil with myself."
	^(UndefinedSortFunction on: self) undefinedLast! !

!SortFunction methodsFor: 'evaluating' stamp: ''!
value: anObject1 value: anObject2
	"Masquerade as a two argument block, used by many of the sorting APIs, 
	by returning whether anObject1 should be placed before anObject2 or not"

	| result |
	result := self collate: anObject1 with: anObject2.
	^result <= 0! !

!SortFunction methodsFor: 'converting' stamp: ''!
, aSortFunction
	"Return a new SortFunction which is the concatenation of aSortFunction to me, I will be the primary sort, but if I compare equal, I will defer to the argument."

	^ChainedSortFunction startWith: self then: aSortFunction asSortFunction! !

!SortFunction methodsFor: 'converting' stamp: ''!
reversed
	"Return new sort function with reverse sort order."

	^ReverseSortFunction on: self! !

!SortFunction class methodsFor: 'accessing' stamp: ''!
default
	^Default! !

!SortFunctionTest commentStamp: ''!
Unit test for sort functions!
!SortFunctionTest methodsFor: 'tests - sorting' stamp: ''!
testSorting
	| data sorted |
	data := { 2@10. 5@5. 10@4. 3@8. 1@1. 11@11 }.
	sorted := data sorted: #x ascending.
	self assert: sorted equals: { 1@1. 2@10. 3@8. 5@5. 10@4. 11@11 }.
	self assert: (sorted isSortedBy: #x ascending).
	sorted := data sorted: #x descending.
	self assert: sorted equals: { 11@11. 10@4. 5@5. 3@8. 2@10. 1@1 }.
	self assert: (sorted isSortedBy: #x descending).
	sorted := data sorted: [ :each | each y printStringLength: 2 ] ascending.
	self assert: sorted equals: { 1@1. 10@4. 5@5. 3@8. 2@10. 11@11 }.
	sorted := data sorted: [ :each | each y * 100.0 ] descending.
	self assert: sorted equals: { 11@11. 2@10. 3@8. 5@5. 10@4. 1@1 }.! !

!SortFunctionTest methodsFor: 'tests' stamp: ''!
testSortUsingBooleans
	| datas |
	datas := #(1 2 3 4 5).
	self assert: (datas sorted: #odd ascending) equals: #(2 4 1 3 5)! !

!SortFunctionTest methodsFor: 'tests' stamp: ''!
testUnarySymbol

	| function |
	function := #x ascending.
	self assert: (function value: 0 @ 2 value: 1 @ 1).
	self assert: (function value: 1 @ 2 value: 1 @ 1).
	self deny: (function value: 2 @ 2 value: 1 @ 1).
	function := #x descending.
	self deny: (function value: 1 @ 2 value: 2 @ 1).
	self assert: (function value: 1 @ 2 value: 1 @ 1).
	self assert: (function value: 2 @ 2 value: 1 @ 1)! !

!SortFunctionTest methodsFor: 'tests' stamp: ''!
testUndefinedFirstUnary

	| function |
	function := #y ascending undefinedFirst.
	self assert: (function value: 0 @ nil value: 1 @ 1).
	self assert: (function value: 1 @ 2 value: 1 @ 2).
	self deny: (function value: 2 @ 2 value: 1 @ 1).
	function := #y descending undefinedFirst.
	self assert: (function value: 1 @ nil value: 2 @ 1).
	self deny: (function value: 1 @ 2 value: 1 @ 3).
	self deny: (function value: 2 @ 2 value: 1 @ 3)! !

!SortFunctionTest methodsFor: 'tests' stamp: ''!
testComparisonOfFunctionsDefinedBySymbol

	self assert: #name ascending equals: #name ascending.
	self assert: #name ascending hash equals: #name ascending hash.
	
	self deny: #name ascending equals: #name descending.
	self deny: #name ascending equals: #name2 ascending.
	self deny: #name ascending undefinedFirst equals: #name ascending undefinedLast! !

!SortFunctionTest methodsFor: 'tests' stamp: ''!
testTwoArgBlock

	| function block |
	block :=
			[:a :b |
			a odd = b odd ifTrue: [0] ifFalse: [a odd ifTrue: [-1] ifFalse: [1]]].
	function := block ascending.
	self assert: (function value: 2 value: 4).
	self assert: (function value: 1 value: 3).
	self assert: (function value: 1 value: 4).
	self deny: (function value: -2 value: 1).
	function := block descending.
	self assert: (function value: 2 value: 4).
	self assert: (function value: 1 value: 3).
	self deny: (function value: 1 value: 4).
	self assert: (function value: -2 value: 1)! !

!SortFunctionTest methodsFor: 'tests - sorting' stamp: ''!
testSortingChained
	| data sorted |
	data := { 1@10. 5@5. 10@4. 3@8. 1@1. 10@10 }.
	sorted := data sorted: #x ascending , #y ascending.
	self assert: sorted equals: { 1@1. 1@10. 3@8. 5@5. 10@4. 10@10 }.
	self assert: (sorted isSortedBy: #x ascending , #y ascending).
	sorted := data sorted: #x ascending , #y descending.
	self assert: sorted equals: { 1@10. 1@1. 3@8. 5@5. 10@10. 10@4 }.
	self assert: (sorted isSortedBy: #x ascending , #y descending).
! !

!SortFunctionTest methodsFor: 'tests - sorting' stamp: ''!
testSortingChainedWithUndefined
	| data sorted |
	data := { 1@10. 5@5. 10@4. 10@nil. 3@8. 1@1. 10@10 }.
	sorted := data sorted: #x ascending , #y ascending undefinedFirst.
	self assert: sorted equals: { 1@1. 1@10. 3@8. 5@5. 10@nil. 10@4. 10@10 }.
	self assert: (sorted isSortedBy: #x ascending , #y ascending undefinedFirst).
	sorted := data sorted: #x ascending , #y descending undefinedLast.
	self assert: sorted equals: { 1@10. 1@1. 3@8. 5@5. 10@10. 10@4. 10@nil }.
	self assert: (sorted isSortedBy: #x ascending , #y descending undefinedLast).
! !

!SortFunctionTest methodsFor: 'tests' stamp: ''!
testSingleArgBlock

	| function block |
	block := [:point | point x / point y].
	function := block ascending.
	self assert: (function value: 0 @ 2 value: 1 @ 1).
	self assert: (function value: 1 @ 2 value: 2 @ 4).
	self deny: (function value: 2 @ 2 value: 1 @ 2).
	function := block descending.
	self deny: (function value: 1 @ 2 value: 2 @ 1).
	self assert: (function value: 2 @ 2 value: 1 @ 1).
	self assert: (function value: 3 @ 2 value: 1 @ 1)! !

!SortFunctionTest methodsFor: 'tests' stamp: ''!
testUndefinedLastUnary

	| function |
	function := #y ascending undefinedLast.
	self assert: (function value: 0 @ 2 value: 1 @ nil).
	self assert: (function value: 1 @ 2 value: 1 @ 2).
	self deny: (function value: 2 @ 2 value: 1 @ 1).
	function := #y descending undefinedLast.
	self assert: (function value: 1 @ 2 value: 2 @ nil).
	self deny: (function value: 1 @ 2 value: 1 @ 3).
	self deny: (function value: 2 @ 2 value: 1 @ 3)! !

!SortFunctionTest methodsFor: 'tests' stamp: ''!
testComparisonOfFunctionsDefinedByBlock
	| collatorBlock |
	collatorBlock := [ :a :b | 1 ].
	
	self assert: collatorBlock ascending equals: collatorBlock ascending.
	self assert: collatorBlock ascending hash equals: collatorBlock ascending hash.
	
	self deny: collatorBlock ascending equals: collatorBlock descending.
	self deny: collatorBlock ascending equals: [ :a :b | -1 ] ascending! !

!SortFunctionTest methodsFor: 'tests - sorting' stamp: ''!
testPropertyWithOddCollator

	| oddFirst function data sorted |
	oddFirst := [:a :b | (b bitAnd: 1) - (a bitAnd: 1)].
	function := (#y collatedBy: oddFirst) , #y , #x.
	data := { 1@10. 5@5. 10@4. 3@8. 1@1. 10@10 }.
	sorted := data sorted: function.
	self assert: sorted equals: { 1@1. 5@5. 10@4. 3@8. 1@10. 10@10 }.
! !

!SortFunctionTest methodsFor: 'tests - sorting' stamp: ''!
testSortingWithUndefined
	| data sorted |
	data := { 2@10. 5@5. 10@4. Point new. 3@8. 1@1. 11@11 }.
	sorted := data sorted: #x ascending undefinedFirst.
	self assert: sorted equals: { Point new. 1@1. 2@10. 3@8. 5@5. 10@4. 11@11 }.
	sorted := data sorted: #x descending undefinedLast.
	self assert: sorted equals: { 11@11. 10@4. 5@5. 3@8. 2@10. 1@1. Point new }.
	sorted := data sorted: #y ascending undefinedLast.
	self assert: sorted equals: { 1@1. 10@4. 5@5. 3@8. 2@10. 11@11. Point new }.
	sorted := data sorted: #y descending undefinedFirst.
	self assert: sorted equals: { Point new. 11@11. 2@10. 3@8. 5@5. 10@4. 1@1 }.! !

!SortFunctionTest methodsFor: 'tests' stamp: ''!
testInversion

	| function |
	function := #x ascending.
	self assert: (function value: 0 @ 2 value: 1 @ 1).
	self assert: (function value: 1 @ 2 value: 1 @ 1).
	self deny: (function value: 2 @ 2 value: 1 @ 1).
	function := function reversed.
	self deny: (function value: 1 @ 2 value: 2 @ 1).
	self assert: (function value: 1 @ 2 value: 1 @ 1).
	self assert: (function value: 2 @ 2 value: 1 @ 1).
	function := function reversed.
	self assert: (function value: 0 @ 2 value: 1 @ 1).
	self assert: (function value: 1 @ 2 value: 1 @ 1).
	self deny: (function value: 2 @ 2 value: 1 @ 1)! !

!SortFunctionTest methodsFor: 'tests' stamp: ''!
testAsSortFunction

	| function |
	function := #name ascending.
	self assert: function equals: function asSortFunction.
	function := #name asSortFunction.
	self assert: function equals: function asSortFunction.
	function := [ :each | each name ] ascending.
	self assert: function equals: function asSortFunction.
	function := [ :x :y | x threeWayCompareTo: y ] asSortFunction.
	self assert: function equals: function asSortFunction.! !

!SortedCollection commentStamp: ''!
I am a collection close to an OrderedCollection at the exception that I keep my elements sorted by using a Block.
Like my superclass, I am a collection that can grow in size but I keep my elements sorted.
Because of that you cannot add elements at a fix index (with #at:put: or #insert:before: methods for example).

The sort block I use should return a boolean. It takes 2 elements and return true if the first parameter should be before the second, else false.

I should be used only if you really need to keep the elements sorted all the time (but there are some exceptions, see at the end). If you do not need it, use OrderedCollection (and possibly his #sort: method).

### Public API and Key Messages

- class method: #sortUsing:  aBlockOrSortFunction is a contructor. 		
- #sort: aBlock is a function to change the way I am sorted. I will also update the index of my elements with the new block.

### Example

```
	sortColl := SortedCollection sortUsing: [ :elem1 :elem2 | elem1 < elem2 ].
	sortColl
		add: 4;
		add: 2;
		add: 1;
		add: 2.
	sortColl. 		"result: a SortedCollection(1 2 2 4)"
	
	"But you can also add a collection."
	
	sortColl addAll: #(3 5 0 6).
	sortColl. 		"result: a SortedCollection(0 1 2 2 3 4 5 6)"
			
	"You can charge the block, imagine you have a collection with number and you want at the beginning the odd elements sorted by value then the even elements sorted by value."
	
	sortColl 
		sort:
			[ :int1 :int2 | 
				((int1 even and: [ int2 even ]) or: [ int1 odd and: [ int2 odd ] ])
					ifTrue: [ int1 < int2 ]
					ifFalse: [ int1 odd ] 
			].
	sortColl 		"result: a SortedCollection(1 3 5 0 2 2 4 6)"
```
 
### Internal Representation and Key Implementation Points.
Instance Variables
-	sortBlock:		<Block> 		This is  a sort block used to keep me sorted. I can take 2 parameters that are two values and I return true if the first parameter should be before the second.

I refuse the methods that add elements at a fix index.

When the user is adding an element, I use some methods like #reSort or #indexForInserting: to add an element at the right position.

### Discussion

- (1) sort: and sortBlock: can be used to set an order to my elements but uses different implementation of the sort algorithm... See  https://pharo.fogbugz.com/f/cases/17925/Why-SortedCollection-sort-and-sortBlock-do-not-uses-the-same-method-to-sort.
- (2) DO NOT USE ADDLAST:!!!!!!!! 
https://pharo.fogbugz.com/f/cases/14812/addLast-should-not-work-in-SortedCollection

```
x := SortedCollection with: 4 with: 3 with: 2 with: 1 with: 7.
y:=x addLast: 6; yourself.
y isSorted 
>>> false
```!
!SortedCollection methodsFor: 'enumerating' stamp: 'nil'!
flatCollect: aBlock 
	"Evaluate aBlock for each of the receiver's elements and answer the
	list of all resulting values flatten one level. Assumes that aBlock returns some kind
	of collection for each element. Equivalent to the lisp's mapcan"
	
	^ self flatCollect: aBlock as: OrderedCollection! !

!SortedCollection methodsFor: 'comparing' stamp: 'nil'!
= aSortedCollection
	"Answer true if my and aSortedCollection's species are the same,
	and if our blocks are the same, and if our elements are the same."

	self species = aSortedCollection species ifFalse: [ ^ false ].
	^ sortBlock = aSortedCollection sortBlock
		ifTrue: [ super = aSortedCollection ]
		ifFalse: [ false ]! !

!SortedCollection methodsFor: 'adding' stamp: 'nil'!
add: newObject
	^ super insert: newObject before: (self indexForInserting: newObject)! !

!SortedCollection methodsFor: 'adding' stamp: 'nil'!
addFirst: newObject
	self shouldNotImplement! !

!SortedCollection methodsFor: 'copying' stamp: 'nil'!
copyEmpty
	"Answer a copy of the receiver without any of the receiver's elements."

	^self species sortBlock: sortBlock! !

!SortedCollection methodsFor: 'private' stamp: 'nil'!
defaultSort: i to: j 
	"Sort elements i through j of self to be nondescending according to
	sortBlock."	"Assume the default sort block ([:x :y | x <= y])."

	| di dij dj tt ij k l n |
	"The prefix d means the data at that index."
	(n := j + 1  - i) <= 1 ifTrue: [^self].	"Nothing to sort." 
	 "Sort di,dj."
	di := array at: i.
	dj := array at: j.
	(di <= dj) "i.e., should di precede dj?"
		ifFalse: 
			[array swap: i with: j.
			 tt := di.
			 di := dj.
			 dj := tt].
	n > 2
		ifTrue:  "More than two elements."
			[ij := (i + j) // 2.  "ij is the midpoint of i and j."
			 dij := array at: ij.  "Sort di,dij,dj.  Make dij be their median."
			 (di <= dij) "i.e. should di precede dij?"
			   ifTrue: 
				[(dij <= dj) "i.e., should dij precede dj?"
				  ifFalse: 
					[array swap: j with: ij.
					 dij := dj]]
			   ifFalse:  "i.e. di should come after dij"
				[array swap: i with: ij.
				 dij := di].
			n > 3
			  ifTrue:  "More than three elements."
				["Find k>i and l<j such that dk,dij,dl are in reverse order.
				Swap k and l.  Repeat this procedure until k and l pass each other."
				 k := i.
				 l := j.
				 [[l := l - 1.  k <= l and: [dij <= (array at: l)]]
				   whileTrue.  "i.e. while dl succeeds dij"
				  [k := k + 1.  k < j and: [(array at: k) <= dij]]
				   whileTrue.  "i.e. while dij succeeds dk"
				  k <= l]
				   whileTrue:
					[array swap: k with: l]. 
	"Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
	through dj.  Sort those two segments."
				self defaultSort: i to: l.
				self defaultSort: k to: j]]! !

!SortedCollection methodsFor: 'accessing' stamp: 'nil'!
at: anInteger put: anObject
	self shouldNotImplement! !

!SortedCollection methodsFor: 'enumerating' stamp: 'nil'!
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 := OrderedDictionary new.
	self do: [ :each |
		(groups at: (aBlock value: each) ifAbsentPut: [ OrderedCollection new ]) add: each ].
	groups associationsDo: [ :association |
			"need to make sure to create the collection with the same sortblock"
			association value: (self copyEmpty addAll: association value ; yourself) ].
	^ groups! !

!SortedCollection methodsFor: 'splitjoin' stamp: 'nil'!
join: aCollection 
	"Append the elements of the argument, aSequenceableCollection, separating them by the receiver."
	"Curiously addAllLast: does not trigger a reSort, so we must do it here."
	^ (super join: aCollection) reSort; yourself! !

!SortedCollection methodsFor: 'private' stamp: 'nil'!
sort: i to: j 
	"Sort elements i through j of self to be nondescending according to
	sortBlock."

	| di dij dj tt ij k l n |
	sortBlock ifNil: [^self defaultSort: i to: j].
	"The prefix d means the data at that index."
	(n := j + 1  - i) <= 1 ifTrue: [^self].	"Nothing to sort." 
	 "Sort di,dj."
	di := array at: i.
	dj := array at: j.
	(sortBlock value: di value: dj) "i.e., should di precede dj?"
		ifFalse: 
			[array swap: i with: j.
			 tt := di.
			 di := dj.
			 dj := tt].
	n > 2
		ifTrue:  "More than two elements."
			[ij := (i + j) // 2.  "ij is the midpoint of i and j."
			 dij := array at: ij.  "Sort di,dij,dj.  Make dij be their median."
			 (sortBlock value: di value: dij) "i.e. should di precede dij?"
			   ifTrue: 
				[(sortBlock value: dij value: dj) "i.e., should dij precede dj?"
				  ifFalse: 
					[array swap: j with: ij.
					 dij := dj]]
			   ifFalse:  "i.e. di should come after dij"
				[array swap: i with: ij.
				 dij := di].
			n > 3
			  ifTrue:  "More than three elements."
				["Find k>i and l<j such that dk,dij,dl are in reverse order.
				Swap k and l.  Repeat this procedure until k and l pass each other."
				 k := i.
				 l := j.
				 [[l := l - 1.  k <= l and: [sortBlock value: dij value: (array at: l)]]
				   whileTrue.  "i.e. while dl succeeds dij"
				  [k := k + 1.  k < j and: [sortBlock value: (array at: k) value: dij]]
				   whileTrue.  "i.e. while dij succeeds dk"
				  k <= l]
				   whileTrue:
					[array swap: k with: l]. 
	"Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
	through dj.  Sort those two segments."
				self sort: i to: l.
				self sort: k to: j]]! !

!SortedCollection methodsFor: 'sorting' stamp: 'nil'!
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."
 
 	super sort: aSortBlock.
 	sortBlock := aSortBlock! !

!SortedCollection methodsFor: 'math functions' stamp: 'nil'!
median
	"Return the middle element, or as close as we can get."
	"{1 . 2 . 3 . 4 . 5} asSortedCollection  median >>> 3"
	
	| size middle |
 	size := self size.
 	middle := (size + 1) // 2.
 	^ size even
			ifTrue: [ ((self at: middle) + (self at: middle + 1)) / 2 ]
			ifFalse: [ self at: middle ]! !

!SortedCollection methodsFor: 'private' stamp: 'nil'!
insert: anObject before: spot
	self shouldNotImplement! !

!SortedCollection methodsFor: 'accessing' stamp: 'nil'!
sortBlock: aBlock 
	"Make the argument, aBlock, be the criterion for ordering elements of the 
	receiver."

	sortBlock := aBlock.
	"sortBlocks with side effects may not work right"
	self size > 0 ifTrue: [self reSort]! !

!SortedCollection methodsFor: 'private' stamp: 'nil'!
reSort
	self sort: firstIndex to: lastIndex! !

!SortedCollection methodsFor: 'copying' stamp: 'nil'!
, otherCollection
	| newSortedCollection |
	newSortedCollection := super , otherCollection.
	newSortedCollection sortBlock: self sortBlock .
	^newSortedCollection! !

!SortedCollection methodsFor: 'adding' stamp: 'nil'!
addAll: aCollection
	aCollection size > (self size // 3)
		ifTrue:
			[aCollection do: [:each | self addLast: each].
			self reSort]
		ifFalse: [aCollection do: [:each | self add: each]].
	^ aCollection! !

!SortedCollection methodsFor: 'accessing' stamp: 'nil'!
sortBlock
	"Answer the blockContext which is the criterion for sorting elements of 
	the receiver."

	^sortBlock! !

!SortedCollection methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Overwritten to get back the standard object behavior"
	
	stonReader parseNamedInstVarsFor: self! !

!SortedCollection methodsFor: 'enumerating' stamp: 'nil'!
collect: aBlock 
	"Evaluate aBlock with each of my elements as the argument. Collect the 
	resulting values into an OrderedCollection. Answer the new collection.
	We cannot assume that the result is sorted, because aBlock can transform the 
	elements in arbitrary ways.  Thus, we must override the superclass in order
	to produce an OrderedCollection instead of a SortedCollection."

	| newCollection | 
	newCollection := OrderedCollection new: self size.
	self do: [:each | newCollection addLast: (aBlock value: each)].
	^ newCollection! !

!SortedCollection methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"Overwritten to get back the standard object behavior"

	stonWriter writeObject: self! !

!SortedCollection methodsFor: 'enumerating' stamp: 'nil'!
intersection: aCollection
	^ (self class sortBlock: sortBlock)
		addAll: (self asSet intersection: aCollection);
		yourself.! !

!SortedCollection methodsFor: 'private' stamp: 'nil'!
indexForInserting: newObject

	| index low high |
	low := firstIndex.
	high := lastIndex.
	sortBlock 
		ifNil: [[index := high + low // 2.  low > high]
			whileFalse: 
				[((array at: index) <= newObject)
					ifTrue: [low := index + 1]
					ifFalse: [high := index - 1]]]
		ifNotNil: [[index := high + low // 2.  low > high]
			whileFalse: 
				[(sortBlock value: (array at: index) value: newObject)
					ifTrue: [low := index + 1]
					ifFalse: [high := index - 1]]].
	^low! !

!SortedCollection class methodsFor: 'instance creation' stamp: 'nil'!
sortUsing: aBlockOrSortFunction
	"Answer an instance of me such that its elements are sorted according to the criterion specified by the block or sort function."

	^ self new sortBlock: aBlockOrSortFunction! !

!SortedCollection class methodsFor: 'instance creation' stamp: 'nil'!
sortBlock: aBlock 
	"Answer an instance of me such that its elements are sorted according to the criterion specified in aBlock."

	^ self sortUsing: aBlock! !

!SortedCollection class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	"Overwritten to get back the standard object behavior"
	
	^ self new
		fromSton: stonReader;
		yourself! !

!SortedCollectionTest commentStamp: ''!
SUnit tests for sorted collections!
!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collection

	^ collectionWith4Elements! !

!SortedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne)! !

!SortedCollectionTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutFirst

	| result |
	result := self nonEmpty copyWithoutFirst.
	
	self assert: result size equals: (self nonEmpty size - 1).
	
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (self nonEmpty at: (i + 1))]! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
sizeCollection

	^ collectionWith4Elements! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
oldSubCollection
	"Return a subCollection included in collectionWith1TimeSubcollection.
	 Example:   subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)"

	^ oldSubcollection! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementInForElementAccessing
	"Return an element inculded in 'accessCollection '"
	
	^ self accessCollection anyOne! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSubcollectionAccessTest

	self moreThan3Elements.
	self assert: self moreThan3Elements size > 2! !

!SortedCollectionTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirstNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!SortedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithElementAlreadyIn

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	oldSize := collection size.
	anElement := self element.
	self assert: (collection includes: anElement).
	
	added := collection addIfNotPresent: anElement.
	
	self assert: added == anElement .	"test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: oldSize! !

!SortedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessFotMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!SortedCollectionTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveFirstNotPresent

	self should: [self empty removeFirst] raise: Error! !

!SortedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllSuchThat

	| el aSubCollection |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := self nonEmptyWithoutEqualElements copyWithout: el.
	self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | aSubCollection includes: each ].
	
	self assert: self nonEmptyWithoutEqualElements size equals: 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each equals: el ]! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index between bounds of 'nonEmpty'"

	^ 2! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
moreThan3Elements
	"Return a collection including atLeast 3 elements."
	
	^ accessCollection! !

!SortedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAt
	 
	| subcollection index collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 1.
	self assert: index equals: 1.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 2.
	self assert: index equals: 0! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testSort
	| s |
 	s := SortedCollection withAll: #(3 2 1).
 	self assert: s asArray equals: #(1 2 3).
 	s sort: [:a :b | a >=b]. 
 	self assert: s asArray equals: #(3 2 1).
 	s add: 4.
 	self assert: s asArray equals: #(4 3 2 1).
 	s := SortedCollection new 
 		sortBlock: [:a :b | a >=b];
 		addAll: #(1 2 3);
 		yourself.
 	self assert: s asArray equals: #(3 2 1).
 	s sort.
 	self assert: s asArray equals: #(1 2 3).
 	s add: 0.
 	self assert: s asArray equals: #(0 1 2 3)! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDoEmpty
	| result |
	result := OrderedCollection new.
	self empty reverseDo: [ :each | result add: each ].

	self assertEmpty: result! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollect
	
	| result firstCollection secondCollection index  |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	result := firstCollection  with: secondCollection collect:
		[:a :b |
		( index := index + 1).
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals:  b.
		b].
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (secondCollection  at: i)].
	self assert: result size = secondCollection size! !

!SortedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementsCopyNonIdenticalWithoutEqualElements
	"Return a collection that does niot incllude equal elements ( classic equality )"
	
	^ collectionOfString! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
moreThan4Elements
	"Return a collection including at leat 4 elements"
	
	^ accessCollection! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLastNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!SortedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAddWithOccurrences
	| 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 equals: (oldSize + 5)! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!SortedCollectionTest methodsFor: 'tests - as identity set' stamp: ''!
testAsIdentitySetWithoutIdentityEqualsElements

	| result collection |
	collection := self collectionWithCopy.
	result := collection asIdentitySet.
	" no elements should have been removed as no elements are equels with Identity equality"
	self assert: result size = collection size.
	collection do: 
		[ :each | 
		(collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ].
	self assert: result class = IdentitySet! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
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)"

	^ stringCollectionSameEndAndBegining! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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! !

!SortedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!SortedCollectionTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', '.
	
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString withIndexDo: 
		[:el :i |  self assert: el equals: ((self nonEmpty at:i)asString)]! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsCollect
	| index result |
	index := 0.

	result := self nonEmptyMoreThan1Element
		pairsCollect: [ :each1 :each2 | 
			self assert: (self nonEmptyMoreThan1Element indexOf: each2) equals: (index := index + 2).
			(self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1) ].

	result do: [ :each | self assert: each ]! !

!SortedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAddAll

	| added collection toBeAdded |
	collection := self collectionWithElement.
	toBeAdded := self otherCollection.
	added := collection addAll: toBeAdded.
	self assert: added == toBeAdded .	"test for identiy because #addAll: has not reason to copy its parameter."
	self assert: (collection includesAll: toBeAdded )! !

!SortedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOf
	
	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element) equals: (collection indexOf: element)! !

!SortedCollectionTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printElementsOn: aStream.
	allElementsAsString:=(result findBetweenSubstrings: ' ').
	allElementsAsString withIndexDo: 
		[:el :i | self assert: el equals: ((self nonEmpty at: i)asString) ]! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
nonEmptyMoreThan1Element
	"Return a collection of integer with more than one element"
	
	^withoutEqualElements! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtRandom

	| result |
	result := self nonEmpty atRandom.
	self assert: (self nonEmpty includes: result)! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!SortedCollectionTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!SortedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringOne
	
	"self assert: self oneItemCol asCommaString = '1'.
	self assert: self oneItemCol asCommaStringAnd = '1'."

	self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString).
	self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString)! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testCollect
	
	|result aSortedCollection|
	aSortedCollection := SortedCollection new.
	result := OrderedCollection new.
	result 
		add: true; 
		add: true; 
		add: true;
		add: false; 
		add: false.
	
	aSortedCollection := (1 to: 5) asSortedCollection.
	self assert: result equals: (aSortedCollection collect: [:each | each < 4])! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	"Return an element (or an association for Dictionary )not present  in 'collection' "

	^ elementNoteIn! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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) ]! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRequirementsOfTAddTest

	self collectionWithElement.
	self otherCollection.
	self element.
	self assert: (self collectionWithElement includes: self element).
	self deny: (self otherCollection includes: self element)! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
anotherElementNotIn
	"Return an element different of 'elementNotIn'  not included in 'nonEmpty' "
	
	^666! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testAddAll

	| sorted2 sorted|
	sorted2 := SortedCollection new.
	sorted2 
		add: 'brochet'; 
		add: 'truitelle'.
	sorted := SortedCollection new.
	sorted addAll: sorted2.
	self assert: (sorted hasEqualElements: sorted2)! !

!SortedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveIfAbsent
 
	| el res |
	el := self elementNotIn.
	res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ].
	self assert: res equals: 33! !

!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfIfAbsentDuplicate

	| 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 ]) equals: 1! !

!SortedCollectionTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testFirstSecondThird

	self assert: self moreThan4Elements first equals: (self moreThan4Elements at: 1).
	self assert: self moreThan4Elements second equals: (self moreThan4Elements at: 2).
	self assert: self moreThan4Elements third equals: (self moreThan4Elements at: 3).
	self assert: self moreThan4Elements fourth equals: (self moreThan4Elements at: 4)! !

!SortedCollectionTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWith5Elements
	"Return a collection of size 5 including 5 elements"
	
	^ accessCollection! !

!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfIfAbsentDuplicate

	| 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 ]) equals: collection size! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterEmpty
	| result |
	result := self empty copyAfter: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionClass
	"Return the class to be used to create instances of the class tested"
	
	^ SortedCollection! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureBeginsEndsWithTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self assert: self nonEmpty size > 1.
	self empty.
	self assertEmpty: self empty! !

!SortedCollectionTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveLast

	| collection element result oldSize |
	collection := self collectionWith5Elements .
	element := collection last.
	oldSize := collection size.

	result := collection removeLast.
	self assert: result equals: element .
	self assert: collection size equals: (oldSize - 1)! !

!SortedCollectionTest methodsFor: 'tests - copying with replacement for sorted' stamp: ''!
testCopyFromToWithForSorted
	| collection result |
	collection := self collectionOfSize5.

	"Testing that elements to be replaced are removed from the copy :"
	result := collection copyReplaceFrom: 1 to: collection size with: self empty.
	self assertEmpty: result.

	"Testing that replacement elements  are all put into the copy :"
	result := collection copyReplaceFrom: 1 to: collection size with: self replacementCollection.
	self replacementCollection do: [ :each | self assert: (result occurrencesOf: each) equals: (self replacementCollection occurrencesOf: each) ].

	self assert: result size equals: self replacementCollection size! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!SortedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAdd
	| added collection |
	collection := self otherCollection.
	added := collection add: self element.
	
	self assert: added == self element.	"test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection includes: self element)	.
	self assert: (self collectionWithElement includes: self element).! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
accessCollection
	"Return a collection of size 5"
	
	^accessCollection! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtIfAbsent

	| 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! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterLastWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the last occurrence of element :"
	result := collection copyAfterLast: element.

	"Verify content"
	self assertEmpty: result! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementInCollectionOfFloat
	"Return an element included in 'collectionOfFloat'"
	
	^ collectionOfFloat anyOne! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
integerCollection
	"Return a collection only including SmallInteger elements."
	
	^ accessCollection! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testMiddle

	self assert: self moreThan4Elements middle equals: (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! !

!SortedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testAddAll2
	
	| sorted2 sorted|
	sorted2 := SortedCollection new.
	sorted2 add: 'brochet'; add:'truitelle'.
	sorted := SortedCollection new.
	sorted add: 'perche'.
	sorted addAll: sorted2.
	self assert: sorted size equals: (sorted2 size + 1).
	sorted2 do: [ :each | self assert: (sorted includes: each)]! !

!SortedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsByteArray

	| res |
	self integerCollectionWithoutEqualElements.
	self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ].
	res := true.
	self integerCollectionWithoutEqualElements
		detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementNotIn
	"Return an element not included in 'nonEmpty' "

	^ elementNoteIn! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTRemoveTest
	| duplicate |
	self empty.
	self nonEmptyWithoutEqualElements.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	duplicate := true.
	self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ].
	self deny: duplicate.
	self elementNotIn.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! !

!SortedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''!
testReverse

	| result |
	result := self nonEmpty reversed.	
	"verify content of 'result: '"
	1 to: result size do:
		[:i | self assert: ((result at: i) 
			= (self nonEmpty at: (self nonEmpty size - i + 1)))].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testBeforeIfAbsent

	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)! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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) ]! !

!SortedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
testLastNElements

	| result |
	result := self moreThan3Elements last: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i + 1) ].
	self assert: result size equals: (self moreThan3Elements size - 1).
	self 
		should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ]
		raise: Error! !

!SortedCollectionTest methodsFor: 'tests - creation' stamp: ''!
testWithAll

	| aCol collection |
	collection := self collectionMoreThan5Elements asOrderedCollection.
	aCol := self collectionClass withAll: collection.
	
	collection do: [ :each | self assert: (aCol occurrencesOf: each ) equals: ( collection occurrencesOf: each ) ].
	
	self assert: aCol size equals: collection size! !

!SortedCollectionTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printNameOn: aStream.

	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents equals: ('an ',self nonEmpty class name ) ]
		ifFalse:[ self assert: aStream contents equals: ('a ',self nonEmpty class name)].! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithCopyNonIdentical
	"Return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)"
	
	^ collectionOfString! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
	"Return a collection elements that can be sorted ( understanding message ' < '  or ' > ')"
	
	^ collectionOfString! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testRemoveAll
	"Allows one to remove all elements of a collection" 
	
	| c1 c2 s2 |
	c1 := #(10 9 8 7 5 4 4 2) asSortedCollection: [:a :b | a >= b].
	c2 := c1 copy.
	s2 := c2 size.
	
	c1 removeAll.
	
	self assert: c1 size equals: 0.
	self assert: c2 size = s2 description: 'the copy has not been modified'.
	
	c1 add: 13; add: 14.
	self assert: (c1 first = 14 and: [c1 second = 13]) description: 'the sortBlock has been preserved'! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButFirstDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButFirstDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i +1))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element size-1)! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLastEmpty
	| result |
	result := self empty copyUpToLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!SortedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testHasEqualElementsOfIdenticalCollectionObjects
	
	self assert: (self empty hasEqualElements: self empty). 
	self assert: (self nonEmpty hasEqualElements: self nonEmpty)! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIdentityIndexOfDuplicate

	| collection element |
	"testing fixture here as this method may not be used by some collections testClass"
	self collectionWithNonIdentitySameAtEndAndBegining.
	collection := self collectionWithNonIdentitySameAtEndAndBegining.
	self assert: collection first equals: collection last.
	self deny: collection first == collection last.
	collection withIndexDo: [:el :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) equals: collection size! !

!SortedCollectionTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!SortedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOf
	
	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection lastIndexOf: element) equals: 1.
	self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) equals: 0! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDoError
	
	self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error! !

!SortedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignForSequenceableCollections

	self deny: (self nonEmpty = self nonEmpty asSet). 
	self deny: (self nonEmpty reversed = self nonEmpty).
	self deny: (self nonEmpty = self nonEmpty reversed)! !

!SortedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForEmptyButNonIdenticalCollections
	
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy! !

!SortedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithNewElement

	| added oldSize collection elem |
	collection := self otherCollection.
	oldSize := collection size.
	elem := self element.
	self deny: (collection includes: elem ).
	
	added := collection  addIfNotPresent: elem .
	self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: (oldSize + 1).! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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)]]! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDoEmpty
	| result |
	result := OrderedCollection new.

	self empty keysAndValuesDo: [ :i :value | result add: value + i ].

	self assertEmpty: result! !

!SortedCollectionTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithSequenceable

	| result index element |
	index := self indexInNonEmpty.
	element := self nonEmpty at: index.
	result := self nonEmpty copyWith: (element ).
	
	self assert: result size equals: (self nonEmpty size + 1).
	self assert: result last equals: element.
	
	1 to: (result size - 1) do:
		[ :i | self assert: (result at: i) equals: ( self nonEmpty at: i)]! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexCollect
	
	| result index collection |
	index := 0.
	collection := self nonEmptyMoreThan1Element .
	result := collection  withIndexCollect: [:each :i | 
		self assert: i equals: (index := index + 1).	
		self assert: i equals: (collection  indexOf: each).
		each ]. 
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (collection at: i)].
	self assert: result size equals: collection size! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementInForIndexAccessing
	"Return an element included in 'accessCollection' "
	
	^ self collectionMoreThan1NoDuplicates  anyOne! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDetectSequenced
	"Testing that detect keep the first element returning true for sequenceable collections"

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element  detect: [:each | each notNil ].
	self assert: result equals: element! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SortedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection last.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: 99! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan5Elements
	"Return a collection including at least 5 elements"
	
	^ nonEmpty5Elements! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testCopy
		
	|aSortedCollection copySorted|
	aSortedCollection := SortedCollection new.
	aSortedCollection sortBlock: [:a :b | a < b].
	aSortedCollection 
		add: 'truite'; 
		add: 'brochet'.
	self assert: aSortedCollection first equals: 'brochet'.
	
	copySorted := aSortedCollection copy.
	
	self assert: (copySorted  hasEqualElements: aSortedCollection).
	self assert: copySorted species equals: aSortedCollection species.
	self assert: copySorted sortBlock equals: aSortedCollection sortBlock.
	self assert: copySorted first equals: 'brochet'! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersection
	| sortedCollection anotherCollection intersection |
	sortedCollection := { Number . Object . Collection } asSortedCollection: [ :a :b | a name > b name ].
	anotherCollection := { Number . Object }.

	intersection := sortedCollection intersection: anotherCollection.
	
	self assert: (intersection isKindOf: SortedCollection).
	self deny: intersection sortBlock isNil.
	self assert: intersection asArray equals: { Object . Number }.! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopySameContentsTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWith2TimeSubcollection
	"Return a collection including 'oldSubCollection' two or many time."
	
	^ (SortedCollection  new add: elementNoteIn ; yourself) , self oldSubCollection , self oldSubCollection! !

!SortedCollectionTest methodsFor: 'tests - iterate' stamp: ''!
testDo2

	| res |
	res := self speciesClass sortBlock: [:a :b | a name < b name]..  
	self collection do: [:each | res add: each class].
	self assert: res asArray equals: self result asArray! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLast

	| index |
	self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last.

	index := self moreThan4Elements indexOf: self elementInForElementAccessing.
	self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! !

!SortedCollectionTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	"Return an element (or an association for Dictionary ) present  in 'collection' "

	^ self collection anyOne! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	
	^ nonEmpty! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementNotInForIndexAccessing
	"Return an element not included in 'accessCollection' "
	
	^ elementNoteIn! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithoutEqualElements
	"Return a collection without equal elements."
	
	^ withoutEqualElements! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testCollectFromTo
	
	| result |
	result:=self nonEmptyMoreThan1Element 
		collect: [ :each | each ]
		from: 1
		to: (self nonEmptyMoreThan1Element size - 1).
		
	1 to: result size
		do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ].
	self assert: result size = (self nonEmptyMoreThan1Element size - 1)! !

!SortedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllFoundIn

	| el aSubCollection   |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn.
	self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection.
	
	self assert: self nonEmptyWithoutEqualElements size equals: 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each equals: el ]! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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 ]! !

!SortedCollectionTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveLastNElementsNElements

	self should: [self empty removeLast: 2] raise: Error! !

!SortedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfIfAbsent
	
	| collection |
	collection := self collectionMoreThan1NoDuplicates.
	self assert: (collection 
			indexOf: collection first
			ifAbsent: [ 33 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 33 ]) equals: 33! !

!SortedCollectionTest methodsFor: 'tests - adding' stamp: ''!
testTAddTwice

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	anElement := self element.
	oldSize := collection size.
	added := collection 
		add: anElement;
		add: anElement.
	self assert: added == anElement.	"test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection includes: anElement).
	self assert: collection size equals: (oldSize + 2)! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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.! !

!SortedCollectionTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ SortedCollection! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfForMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFromToDo
	
	| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each].
	
	1 to: (self nonEmptyMoreThan1Element  size -1) do:
		[:i | self assert: (self nonEmptyMoreThan1Element at:i) = (result at:i) ].

	self assert: result size = (self nonEmptyMoreThan1Element size - 1).! !

!SortedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''!
testReversed

	| result |
	result := self nonEmpty reversed.
	
	"Verify content"
	result withIndexDo:
		[:el :i | self assert: el equals: (self nonEmpty at: (self nonEmpty size - i + 1))].

	"Verify size"
	self assert: result size=self nonEmpty size.! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
expectedSizeAfterReject

	^ 1! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
result

	 ^ collectResult! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
empty
	
	^ empty! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDo
	| result |
	result := OrderedCollection new.
	self nonEmpty reverseDo: [: each | result add: each].
	
	1 to: result size do:
		[:i|
		self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))]! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
element
	"Returns an object that can be added to the collection returned by #collection."
	
	^ 88! !

!SortedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0TSequencedStructuralEqualityTest

	self nonEmpty at: 1	"Ensures #nonEmpty is sequenceable"! !

!SortedCollectionTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty

	| result |
	result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne).
	self assert: result equals: 0! !

!SortedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	self deny: (self nonEmpty includesAny: self empty).
	self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }).
	self assert: (self nonEmpty includesAny: self nonEmpty)! !

!SortedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWith
	
	self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst).
	self assert: (self nonEmpty endsWith: self nonEmpty).
	self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCreationWithTest

	self collectionMoreThan5Elements.
	self assert: self collectionMoreThan5Elements size >= 5! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWith1TimeSubcollection
	"Return a collection including 'oldSubCollection' only one time."
	
	^ (SortedCollection new add: elementNoteIn ; yourself) , self oldSubCollection! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementInForIncludesTest
	"Return an element included in nonEmpty."
	
	^ nonEmpty anyOne! !

!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfStartingAtDuplicate

	| 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 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 55 ]) equals: 1! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
withEqualElements
	"Return a collection of float including equal elements (classic equality)."
	
	^ collectionOfFloatWithDuplicate! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLastEmpty
	| result |
	result := self empty copyAfterLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan1NoDuplicates
	"Return a collection of size 5 without equal elements"
	
	^ withoutEqualElements! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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) ]! !

!SortedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButFirstNElements

	| allButFirst collection |
	collection := self moreThan3Elements.
	allButFirst := collection allButFirst: 2.
	allButFirst withIndexDo: 
		 [:el :i | self assert: el equals: (collection at: i + 2) ].
	self assert: allButFirst size + 2 equals: collection size! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithSameAtEndAndBegining
	"Return a collection with elements at end and begining equals (others elements of the collection are not equal to those elements)"
	
	^ stringCollectionSameEndAndBegining! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
	"Return a collection of size 1 including one element."
	
	^ nonEmpty1Element! !

!SortedCollectionTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveLastNotPresent

	self should: [self empty removeLast] raise: Error! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithIdentical
	"Return a collection of type: 'self collectionWIithoutEqualsElements class containing two elements equals (with identity equality)."

	| result collection anElement |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := collection first.
	collection add: anElement.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!SortedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWith
	
	self assert: (self nonEmpty beginsWith: (self nonEmpty copyUpTo: self nonEmpty last)).
	self assert: (self nonEmpty beginsWith: self nonEmpty).
	self deny: (self nonEmpty beginsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesForMultiplinessTest
	| cpt |
	self collectionWithEqualElements.
	self collectionWithEqualElements.
	self elementTwiceInForOccurrences.
	self elementTwiceInForOccurrences.
	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! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIdentityIndexOfIAbsentDuplicate

	| collection element elementCopy |
	collection := self collectionWithNonIdentitySameAtEndAndBegining.
	element := collection last.
	elementCopy := element copy.
	self deny: element == elementCopy.
	self assert: (collection 
			identityIndexOf: element
			ifAbsent: [ 0 ]) equals: collection size.
	self assert: (collection 
			identityIndexOf: elementCopy
			ifAbsent: [ 55 ]) equals: 55! !

!SortedCollectionTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveAtNotPresent

	self should: [self empty removeAt: 2] raise: Error! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest

	self nonEmpty! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
indexInForCollectionWithoutDuplicates
	"Return an index between 'collectionWithoutEqualsElements' bounds."
	
	^ 2! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsDo

	| index |
	index:=1.
	
	self nonEmptyMoreThan1Element  pairsDo: 
		[:each1 :each2 | 
		self assert: (self nonEmptyMoreThan1Element at:index) equals: each1.
		self assert: (self nonEmptyMoreThan1Element at:(index+1)) equals: each2.
		index := index + 2 ].
	
	self nonEmptyMoreThan1Element size odd
		ifTrue:[ self assert: index equals: self nonEmptyMoreThan1Element size ]
		ifFalse:[ self assert: index equals: (self nonEmptyMoreThan1Element size+1) ]! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtWrap
	"
	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)! !

!SortedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopy

	| result |
	result := self nonEmpty shallowCopy.
	
	"Verfy content"
	self nonEmpty withIndexDo:
		[:el :i | self assert: (result at:i) equals: (self nonEmpty at:i)].
	
	"Verify size"
	self assert: result size equals: self nonEmpty size.! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!SortedCollectionTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveFirstNElementsNotPresent

	self should: [self empty removeFirst: 2] raise: Error! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!SortedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLast

	| abf col |
	col := self moreThan3Elements.
	abf := col allButLast.
	self deny: abf last = col last.
	self assert: abf size + 1 equals: col size! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexDo

	|  indexes elements |
	indexes:= OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:value :i  |
			indexes  add: (i).
			elements add: value ].
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:el :i |
			self assert: (indexes at: i) equals: i.
			self assert: (elements at: i) equals: el ].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testCreation
		
	| collection |
	collection := #(10 9 3 6 1 8 7 5 4 2) asSortedCollection.
	self assert: collection equals: (1 to: 10) asSortedCollection! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastIfAbsent

	self assert: (self moreThan4Elements 
			atLast: 1
			ifAbsent: [ nil ]) = self moreThan4Elements last.
	self assert: (self moreThan4Elements 
			atLast: self moreThan4Elements size + 1
			ifAbsent: [ 222 ]) = 222! !

!SortedCollectionTest methodsFor: 'tests - as identity set' stamp: ''!
testAsIdentitySetWithIdentityEqualsElements

	| result |
	result := self collectionWithIdentical asIdentitySet.
	" Only one element should have been removed as two elements are equals with Identity equality"
	self assert: result size = (self collectionWithIdentical size - 1).
	self collectionWithIdentical do: 
		[ :each | 
		(self collectionWithIdentical occurrencesOf: each) > 1 
			ifTrue: 
				[ "the two elements equals only with classic equality shouldn't 'have been removed"
				self assert: (result asOrderedCollection occurrencesOf: each) = 1
				" the other elements are still here" ]
			ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ].
	self assert: result class = IdentitySet! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRemoveByIndexTest

	self collectionWith5Elements.
	self assert: self collectionWith5Elements size = 5! !

!SortedCollectionTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!SortedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!SortedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLastNElements

	| allButLast collection |
	collection := self moreThan3Elements.
	allButLast := collection allButLast: 2.
	allButLast withIndexDo: [:el :i | self assert: el equals: (collection at: i) ].
	self assert: allButLast size + 2 equals: collection size! !

!SortedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	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)]]! !

!SortedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWithEmpty
	
	self deny: (self nonEmpty beginsWith:(self empty)).
	self deny: (self empty beginsWith:(self nonEmpty))! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithOrWithoutSpecificElementsTest

	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self indexInNonEmpty.
	self assert: self indexInNonEmpty > 0.
	self assert: self indexInNonEmpty <= self nonEmpty size! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionOfSize5
	"Return a collection of size 5"
	
	^ accessCollection! !

!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfDuplicate

	| 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) equals: collection size! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpTo

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection   copyUpTo: (collection  at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at:i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLast

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection copyUpToLast: (collection at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at: i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
otherCollection
	"Returns a collection that does not include what is returned by #element."
	
	 ^ SortedCollection new 
			add: 7; 
			add: 5; 
			add: 2; 
			yourself! !

!SortedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementReallyRemovesElement

	| size |
	size := self nonEmptyWithoutEqualElements size.
	self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne.
	self assert: size - 1 equals: self nonEmptyWithoutEqualElements size! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testEquals
		
	|aSortedCollection|
	aSortedCollection := SortedCollection new.
	aSortedCollection 
		add: 'truite'; 
		add: 'brochet'.
	self assert: aSortedCollection copy equals: aSortedCollection! !

!SortedCollectionTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToLastWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyUpToLast:' should copy until the last occurrence :"
	result := collection copyUpToLast: (element ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (collection at: i) ].
	
	self assert: result size equals: (collection size - 1)! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
	"Return a collection for wich each element is not included in 'nonEmpty' "
	
	^ collectionNotIncluded! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testAdd
		
	| collection |
	collection := #(10 9 8 7 5 4 4 2) asSortedCollection.
	self assert: collection first equals: 2.
	self assert: collection last equals: 10.
	self assert: collection size equals: 8.
	collection add:1.
	self assert: collection size equals: 9.
	collection add: 6.
	self assert: (collection at: 5) equals: 5.
	self assert: collection size equals: 10.
	collection add: 3! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithReplacementForSorted
	self collectionOfSize5.
	self assert: self collectionOfSize5 size = 5.
	self replacementCollection.
	self denyEmpty: self replacementCollection.
	self empty.
	self assertEmpty: self empty! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	firstCollection  with: secondCollection do:
		[:a :b |
		index := index + 1.
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals: b ]! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testGroupsOfAtATimeCollect
	| groupsOf2 |
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: [ :x | x ]).
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: #yourself).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 2 atATimeCollect: [ :x | x ].
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 2.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 2 ]).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 3 atATimeCollect: #yourself.
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 3.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 3 ]).! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testSpeciesLooseSortBlock
	"This is a non regression test for http://bugs.squeak.org/view.php?id=6535"

	| numbers reverseOrder firstThree |
	numbers := #(1 2 3 4 5).
	reverseOrder := SortedCollection sortBlock: [:x :y | x > y].
	reverseOrder addAll: numbers.

	"The elements are inverted"
	self assert: reverseOrder asArray equals: #(5 4 3 2 1).

	"Copy the first 3 elements"
	firstThree := reverseOrder copyFrom: 1 to: 3.

	"It appears to work"
	self assert: firstThree asArray equals: #(5 4 3).

	"but we have lost the sort block"
	firstThree add: 1.

	" firstThree is now #(1 5 4 3)!! "
	self assert: firstThree asArray equals: #(5 4 3 1) "fails"! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementToAdd
	"Return an element of type 'nonEmpy' elements'type'"
	
	^ 5! !

!SortedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAtIfAbsent
	 
	| absent subcollection collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	absent := false.
	collection 
		indexOfSubCollection: subcollection
		startingAt: 1
		ifAbsent: [ absent := true ].
	self assert: absent equals: false.
	absent := false.
	collection 
		indexOfSubCollection: subcollection
		startingAt: 2
		ifAbsent: [ absent := true ].
	self assert: absent equals: true! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SortedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsSet
 	"Test with a collection without equal elements"
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testSortBlock
		
	|aSortedCollection|
	aSortedCollection := SortedCollection new.
	aSortedCollection sortBlock: [:a :b | a < b].
	aSortedCollection 
		add: 'truite'; 
		add: 'brochet'; 
		add: 'tortue'.
	self assert: aSortedCollection first equals: 'brochet'.
	
	aSortedCollection := SortedCollection new.
	aSortedCollection sortBlock: [:a :b | a >b].
	aSortedCollection 
		add: 'truite'; 
		add: 'brochet';
		add: 'tortue'.
	self assert: aSortedCollection first equals: 'truite'.! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testMedianWithNumbers

	| aSortedCollection |
	aSortedCollection := (1 to: 10) asSortedCollection.
 	self assert: aSortedCollection median equals: 5.5! !

!SortedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWithEmpty
	
	self deny: (self nonEmpty endsWith: self empty).
	self deny: (self empty endsWith: self nonEmpty)! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLast

	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection copyAfterLast: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!SortedCollectionTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''!
testOccurrencesOfForMultipliness

	| collection elem |
	collection := self collectionWithEqualElements.
	elem := self elementTwiceInForOccurrences.

	self assert: (collection occurrencesOf: elem ) equals: 2.! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!SortedCollectionTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!SortedCollectionTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollect

	self assert: (#(1 2) asSortedCollection flatCollect: [ :x | { x } ]) equals: #(1 2) asOrderedCollection! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testMedianForOddSizeCollection
	
	|aSortedCollection|
	aSortedCollection := {1 .2 . 3 . 4 . 5 . 6 .7} asSortedCollection.
	self assert: aSortedCollection median equals: 4.
	
	aSortedCollection := SortedCollection new.
	aSortedCollection 
		add: 'truite'; 
		add: 'porcinet'; 
		add: 'carpe'.

	self assert: aSortedCollection median equals: 'porcinet'! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
integerCollectionWithoutEqualElements
	"Return a collection of integer without equal elements."
	
	^ withoutEqualElements! !

!SortedCollectionTest methodsFor: 'tests - copying with replacement for sorted' stamp: ''!
testCopyReplaceAllWithForSorted
	| collection result |
	collection := self collectionOfSize5.

	"Testing that elements to be replaced are removed from the copy :"
	result := collection copyReplaceAll: collection with: self empty.
	self assertEmpty: result.

	"Testing that replacement elements  are all put into the copy :"
	result := collection copyReplaceAll: collection with: self replacementCollection.
	self replacementCollection do: [ :each | self assert: (result occurrencesOf: each) equals: (self replacementCollection occurrencesOf: each) ].

	self assert: result size equals: self replacementCollection size! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithElement
	"Returns a collection that already includes what is returned by #element."
	
	^ SortedCollection new add: self element ; add: 5 ; add: 2; yourself.! !

!SortedCollectionTest methodsFor: 'tests - creation' stamp: ''!
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 ) equals: (collection occurrencesOf: element1).
	self assert: (aCol occurrencesOf: element2 ) equals: (collection occurrencesOf: element2)! !

!SortedCollectionTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveFirstNElements

	| collection elements result oldSize |
	collection := self collectionWith5Elements .
	elements := { collection first. collection at:2 }.
	oldSize := collection size.

	result := collection removeFirst: 2.
	self assert: result equals: elements .
	self assert: collection size equals: (oldSize - 2)! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementNotInForOccurrences

	^ 666! !

!SortedCollectionTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	nonEmpty := SortedCollection new.
	elementExistsTwice := 12332312321.
	nonEmpty add: 2.
	nonEmpty add: elementExistsTwice.
	nonEmpty add: elementExistsTwice.
	collectionIncluded := SortedCollection new add: 2; add: elementExistsTwice ;yourself.
	collectionNotIncluded := SortedCollection new add: 312; add: 313 ;yourself.
	empty := SortedCollection  new. 
	collectionWith4Elements := SortedCollection new.
	collectionWith4Elements add: 1.
	collectionWith4Elements add: -2.
	collectionWith4Elements add: 3.
	collectionWith4Elements add: 1.
	collectionWithoutNil := SortedCollection new add: 1;add: 2 ;add:4 ;add:5;yourself.
	collectResult := OrderedCollection new. "SortedCollection sortBlock: [:a :b | a name < b name]."
	collectResult add: SmallInteger.
	collectResult add: SmallInteger.
	collectResult add: SmallInteger.
	collectResult add: SmallInteger.
	nonEmpty1Element := SortedCollection new add:5; yourself.
	collectionOfFloat := SortedCollection new add:1.2 ; add: 5.6 ; add:4.4 ; add: 1.9 ; yourself.
	collectionOfString := SortedCollection new add: 'a' ; add: 'b' ; add: 'c' ; add: 'd' ; yourself.
	duplicateFloat := 1.2.
	collectionOfFloatWithDuplicate := SortedCollection new add: duplicateFloat  ; add: 5.6 ; add:4.4 ; add: duplicateFloat  ; yourself.
	accessCollection := SortedCollection new add:1 ; add: 5 ; add:4 ; add: 2 ; add:7 ; yourself.
	elementNoteIn := 999.
	oldSubcollection := SortedCollection new add: 2 ; add: 2 ; add: 2 ; yourself.
	stringCollectionSameEndAndBegining := SortedCollection new add: 'a' ; add: 'a' copy ; yourself.
	withoutEqualElements := SortedCollection new add: 1 ; add: 8 copy ; add: 4;yourself.
	nonEmpty5Elements := SortedCollection new add: 1 ; add: 8 copy ; add: 4; add: 4; add: 4;yourself.! !

!SortedCollectionTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!SortedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringMore

	"self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'.
	self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3'"

	| result resultAnd index allElementsAsString |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
 
	index := 1.
	(result findBetweenSubstrings: ',' )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 findBetweenSubstrings: ',' ).
	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 )]
				].
		
		
			].! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testLast

	self assert: self moreThan4Elements last equals: (self moreThan4Elements at: self moreThan4Elements size)! !

!SortedCollectionTest methodsFor: 'tests - creation' stamp: ''!
testWith
	
	| aCol anElement |
	anElement := self collectionMoreThan5Elements anyOne.
	aCol := self collectionClass with: anElement.
	self assert: (aCol includes: anElement).! !

!SortedCollectionTest methodsFor: 'tests - creation' stamp: ''!
testOfSize
	
	| aCol |
	aCol := self collectionClass ofSize: 3.
	self assert: aCol size equals: 3.! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
replacementCollection
	"Return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' "
	 
	^ collectionWith4Elements! !

!SortedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopyEmpty
	| result |
	result := self empty shallowCopy.
	self assertEmpty: result! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertAsSetForMultiplinessTest
	"A collection ofFloat with equal elements:"

	| res |
	self withEqualElements.
	self withEqualElements do: [ :each | self assert: each isFloat ].
	res := true.
	self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res.	"a collection of Float without equal elements:"
	res := true.
	self elementsCopyNonIdenticalWithoutEqualElements
		detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res equals: false! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateSequencedReadableTest
	| res |
	self nonEmptyMoreThan1Element.
	self assert: self nonEmptyMoreThan1Element size > 1.

	self empty.
	self assertEmpty: self empty.

	res := true.
	self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!SortedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExists

	| el res |
	el := self nonEmptyWithoutEqualElements anyOne.
	res := self nonEmptyWithoutEqualElements remove: el.
	self assert: res == el! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDo! !

!SortedCollectionTest methodsFor: 'tests - as set tests' stamp: ''!
testAsIdentitySetWithEqualsElements

	| result collection |
	collection := self withEqualElements .
	result := collection asIdentitySet.
	collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = IdentitySet! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!SortedCollectionTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveAt

	| collection element result oldSize |
	collection := self collectionWith5Elements .
	element := collection at: 3.
	oldSize := collection size.

	result := collection removeAt: 3.
	self assert: result equals: element.
	self assert: collection size equals: (oldSize - 1).! !

!SortedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!SortedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
	"Return a collection of elements included in 'nonEmpty'."

	^ collectionIncluded! !

!SortedCollectionTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveLastNElements

	| collection result oldSize elements |
	collection := self collectionWith5Elements .
	elements := { collection at: 4. collection last }.
	oldSize := collection size.

	result := (collection removeLast: 2).
	self assert: result equals: elements.
	self assert: collection size equals: (oldSize - 2)! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SortedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllError
	| el aSubCollection |
	el := self elementNotIn.
	aSubCollection := self nonEmptyWithoutEqualElements copyWith: el.

	self should: [ self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! !

!SortedCollectionTest methodsFor: 'tests' stamp: ''!
testGroupedBySortedCollection
	| collection grouped |
	collection := Object methods asSortedCollection: #selector ascending.
	
	grouped := collection groupedBy: #methodClass.
	
	"do we retain the sortblock?"
	self assert: grouped values first class equals: SortedCollection.
	self assert: collection sortBlock equals: grouped values first sortBlock.! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyFromTo
	| result  index collection |
	collection := self collectionWithoutEqualElements .
	index :=self indexInForCollectionWithoutDuplicates .
	result := collection   copyFrom: index  to: collection  size .
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at:i) equals: (collection  at: (i + index - 1))].
	
	"Verify size"
	self assert: result size equals: (collection  size - index + 1)! !

!SortedCollectionTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	allElementsAsString withIndexDo: 
		[:el :i | 
		i=1
			ifTrue:[
				self accessCollection class name first isVowel 
					ifTrue:[self assert: el equals: 'an' ]
					ifFalse:[self assert: el equals: 'a'].].
		i=2
			ifTrue:[self assert: el equals: self accessCollection class name].
		i>2
			ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]]! !

!SortedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
testFirstNElements

	| result |
	result := self moreThan3Elements first: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i) ].
	
	self assert: result size equals: (self moreThan3Elements size - 1).
	self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: SubscriptOutOfBounds! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeWithIdentityTest

	| anElement |
	self collectionWithCopyNonIdentical.
	anElement := self collectionWithCopyNonIdentical anyOne.
	self deny: anElement == anElement copy! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the first occurrence:"
	result := collection   copyAfter: (element ).
	
	"Verifying content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + 1 )) equals: (result at: (i)) ].

	"Verify size"
	self assert: result size equals: (collection size - 1).! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementNotInForElementAccessing
	"Return an element not included in 'accessCollection' "
	
	^ elementNoteIn! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	difference := self collectionWithoutEqualElements difference: self empty.
	self assert: difference size = self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each) ]! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDo
	"| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		result add: (value+i)].
	
	1 to: result size do:
		[:i|
		self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]"
	|  indexes elements |
	indexes := OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		indexes  add: (i).
		elements add: value].
	
	(1 to: self nonEmptyMoreThan1Element size )do:
		[ :i |
		self assert: (indexes at: i) equals: i.
		self assert: (elements at: i) equals: (self nonEmptyMoreThan1Element at: i).	
		].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
	"Return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	
	^ collectionWithoutNil! !

!SortedCollectionTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString |
	result:=''.
	aStream:= ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ').
	allElementsAsString withIndexDo: 
		[:el :i | 
		i<(allElementsAsString size-1 )
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:i)asString)].
		i=(allElementsAsString size-1)
			ifTrue:[ self deny: (allElementsAsString at:i) equals: ('and')asString].
		i=(allElementsAsString size)
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:(i-1))asString)]]! !

!SortedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAt
	 
	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!SortedCollectionTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!SortedCollectionTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''! !

!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfStartingAtDuplicate

	| 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 ]) equals: 1.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 55 ]) equals: collection size! !

!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfDuplicate

	| 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) equals: 1! !

!SortedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result index |
	delim := ', '.
	result := ''.
	multiItemStream := ReadWriteStream on: result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	index:=1.
	(result findBetweenSubstrings: delim)do:
		[:each |
			self assert: each= ((self nonEmpty at:index) asString).
			index:=index+1 ]! !

!SortedCollectionTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!SortedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsSetForIdentityMultiplinessTest
	"A collection (of elements for which copy is not identical ) without equal elements:"

	| anElement res |
	self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := self elementsCopyNonIdenticalWithoutEqualElements anyOne.
	self deny: anElement copy == anElement.
	res := true.
	self elementsCopyNonIdenticalWithoutEqualElements
		detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!SortedCollectionTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveFirst

	| collection element result oldSize |
	collection := self collectionWith5Elements.
	element := collection first.
	oldSize := collection size.

	result := collection removeFirst.
	self assert: result equals: element .
	self assert: collection size equals: (oldSize - 1)! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
subCollectionNotIn
	"Return a collection for which at least one element is not included in 'accessCollection'."
	
	^ SortedCollection new add: elementNoteIn ; add: elementNoteIn ; yourself.! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfSequenceableTest
	self collectionWithoutEqualElements.
	self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ].
	self indexInForCollectionWithoutDuplicates.
	self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size.
	self empty.
	self assertEmpty: self empty! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedElementAccessTest

	self moreThan4Elements.
	self assert: self moreThan4Elements size >= 4.
	self subCollectionNotIn.
	self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ].
	self elementNotInForElementAccessing.
	self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing).
	self elementInForElementAccessing.
	self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! !

!SortedCollectionTest methodsFor: 'tests - equality' stamp: ''!
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)! !

!SortedCollectionTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOfIAbsent

	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			identityIndexOf: element
			ifAbsent: [ 0 ]) equals: 1.
	self assert: (collection 
			identityIndexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 55 ]) equals: 55! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastError

	self 
		should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ]
		raise: Error! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLast

	| element result |
	element := self nonEmptyMoreThan1Element at: self nonEmptyMoreThan1Element size.
	result := self nonEmptyMoreThan1Element findLast: [:each | each =element].
	
	self assert: result equals: self nonEmptyMoreThan1Element size! !

!SortedCollectionTest methodsFor: 'tests' stamp: ''!
testComma
	| sortBlock collOne collTwo combined |
	sortBlock := [ :a :b | a > b ].
	collOne := (1 to: 5) asSortedCollection: sortBlock.
	collTwo := (6 to: 10) asSortedCollection: sortBlock.
	combined := collOne , collTwo.
	self assert: combined sortBlock equals: sortBlock.
	self assert: combined asArray equals: (1 to: 10) asArray reverse! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToEmpty
	| result |
	result := self empty copyUpTo: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testSortUsing
	| aSortedCollection |
	aSortedCollection := (SortedCollection sortUsing: #yourself ascending)
		addAll: #(2 6 3 8 4 3 7 6);
		yourself.
	self assert: aSortedCollection asArray equals: #(2 3 3 4 6 6 7 8)! !

!SortedCollectionTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementFromEmpty

	self 
		should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ]
		raise: Error! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButLastDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButLastDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i ))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element  size-1)! !

!SortedCollectionTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithEqualElements
	"Return a collection including atLeast two elements equal."

	^ collectionOfFloatWithDuplicate! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
elementTwiceInForOccurrences
	"Return an element included exactly two time in # collectionWithEqualElements."
	
	^ duplicateFloat! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollectError

	self should: [ self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := firstCollection size.
	
	firstCollection  reverseWith: secondCollection do:
		[:a :b |
	
		self assert: (firstCollection at: index) equals: a. 
		self assert: (secondCollection at: index) equals: b.
			(index := index - 1)]! !

!SortedCollectionTest methodsFor: 'tests - basic' stamp: ''!
testMedianForEvenSizeCollection
	
	|aSortedCollection|
	aSortedCollection := {1 .2 . 3 . 4 . 5 . 6 } asSortedCollection.
	self assert: aSortedCollection median equals: 3.5! !

!SortedCollectionTest methodsFor: 'tests - element accessing' stamp: ''!
testAtOutOfBounds

	self 
		should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ]
		raise: Error.
	self 
		should: [ self moreThan4Elements at: -1 ]
		raise: Error! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!SortedCollectionTest methodsFor: 'tests - copy' stamp: ''!
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) ] ]! !

!SortedCollectionTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOf
	| collection |
	collection := self collectionWithoutEqualElements .
	
	collection do: [ :each | self assert: (collection occurrencesOf: each) equals: 1 ]! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyEmptyMethod
	| result |
	result := self collectionWithoutEqualElements copyEmpty.
	self assertEmpty: result.
	self assert: result class equals: self nonEmpty class! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfter
	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection   copyAfter: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!SortedCollectionTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!SortedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
speciesClass
	
	^ SortedCollection! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithCopy
	"Return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals (with identity equality)
	but 2 elements only equals with classic equality"
	
	| result collection |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	collection add: collection first copy.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!SortedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsNotThere
	
	self deny: (self nonEmpty includes: self elementNotIn).
	self assert: (self nonEmpty includes: self nonEmpty anyOne).
	self deny: (self empty includes: self elementNotIn)! !

!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
 	 'copyUpTo:' should copy until the first occurrence"
	result := collection copyUpTo: element.

	"Verify content"
	self assertEmpty: result! !

!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirst

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element findFirst: [:each | each = element].
	
	self assert: result equals: 1! !

!SortedCollectionTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludes
	"Test the comportement in presence of elements 'includes' but not 'identityIncludes'."

	"Can not be used by collections that can't include elements for wich copy doesn't return another instance "

	| collection element |
	self collectionWithCopyNonIdentical.
	collection := self collectionWithCopyNonIdentical.
	element := collection anyOne copy.	"self assert: (collection includes: element)."
	self deny: (collection identityIncludes: element)! !

!SortedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButFirst

	| abf col |
	col := self moreThan3Elements.
	abf := col allButFirst.
	self deny: abf first = col first.
	self assert: abf size + 1 = col size! !

!SortedCollectionTest methodsFor: 'tests - as set tests' stamp: ''!
testAsSetWithEqualsElements

	| result |
	result := self withEqualElements asSet.
	self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = Set! !

!SortedCollectionTest methodsFor: 'tests - equality' stamp: ''!
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)! !

!SortedCollectionTest methodsFor: 'tests - index access' stamp: ''!
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) equals: index! !

!SortedCollectionTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
	"Return a collection not including equal elements."
	
	^withoutEqualElements! !

!SortedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |
	delim := ', '.
	result := ''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!SortedCollectionTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!SoundSystem commentStamp: ''!
This is the base class for a sound system. A sound system offers a small protocol for playing sounds and making beeps. 

While SoundSystem is an abstract class, it acts as a facade to 
the actual SoundSystem.

When the SoundPackage is not loaded, SoundSystem current refers to DummySoundSystem. 

SoundSystem current gives access to the currently installed SoundSystem.

When no SoundSystem is available, a dummy one is installed as current.  
    
SoundSystem soundEnabled: true.
SoundSystem current beep


SoundSystem current: BaseSoundSystem new


!
!SoundSystem methodsFor: 'activation hooks' stamp: ''!
deactivate
	"Hook for possible specialization when activating a sound system"! !

!SoundSystem methodsFor: 'sounds' stamp: ''!
playSoundNamed: soundName ifAbsentReadFrom: aifFileName

	self subclassResponsibility! !

!SoundSystem methodsFor: 'accessing' stamp: ''!
soundEnabled

	^ self class soundEnabled! !

!SoundSystem methodsFor: 'sounds' stamp: ''!
playSoundNamed: soundName

	self subclassResponsibility! !

!SoundSystem methodsFor: 'to deprecate' stamp: ''!
sampledSoundChoices

	self subclassResponsibility! !

!SoundSystem methodsFor: 'beep' stamp: ''!
beep
	"Make a primitive beep."

	self subclassResponsibility! !

!SoundSystem methodsFor: 'sounds' stamp: ''!
playSampledSound: samples rate: rate

	self subclassResponsibility! !

!SoundSystem methodsFor: 'to deprecate' stamp: ''!
randomBitsFromSoundInput: bitCount

	self subclassResponsibility! !

!SoundSystem methodsFor: 'activation hooks' stamp: ''!
shutDown
	"by default do nothing"! !

!SoundSystem methodsFor: 'accessing' stamp: ''!
soundEnabled: aBoolean

	^ self class soundEnabled: aBoolean! !

!SoundSystem methodsFor: 'sounds' stamp: ''!
playSoundNamedOrBeep: soundName

	self subclassResponsibility! !

!SoundSystem methodsFor: 'activation hooks' stamp: ''!
activate
	"Hook for possible specialization when activating a sound system"! !

!SoundSystem methodsFor: 'query' stamp: ''!
soundNamed: soundName

	self subclassResponsibility! !

!SoundSystem class methodsFor: 'setting' stamp: ''!
soundEnabled
	^ SoundEnabled ifNil: [SoundEnabled := false]! !

!SoundSystem class methodsFor: 'current' stamp: ''!
current

	^ Current ifNil: [ Current := DummySoundSystem new ]! !

!SoundSystem class methodsFor: 'current' stamp: ''!
current: aSoundSystem

	Current ifNotNil: [Current deactivate].
	Current := aSoundSystem.
	Current activate.! !

!SoundSystem class methodsFor: 'setting' stamp: ''!
soundQuickStart
	^ SoundQuickStart ifNil: [SoundQuickStart := false]! !

!SoundSystem class methodsFor: 'setting' stamp: ''!
soundQuickStart: aBoolean
	SoundQuickStart := aBoolean! !

!SoundSystem class methodsFor: 'setting' stamp: ''!
soundEnabled: aBoolean
	SoundEnabled := aBoolean! !

!SoundSystem class methodsFor: 'current' stamp: ''!
resetSoundSystem
	Current := nil! !

!SoundTheme commentStamp: ''!
Groups a set of sounds to use with a UITheme.
Note that, although instances may have their sounds changed the settings will still indicate the class of theme that is current.!
!SoundTheme methodsFor: 'initialize-release' stamp: ''!
defaultDenySound
	"Answer the default deny sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
defaultSound
	"Answer the default sound."

	^self sounds at: #default ifAbsent: [self defaultDefaultSound]! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
defaultAbortSound
	"Answer the default abort sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
messageSound
	"Answer the message sound."

	^self sounds at: #message ifAbsent: [self defaultSound]! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
defaultWindowMinimizeSound
	"Answer the default window minimize sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
defaultWindowRestoreDownSound
	"Answer the default window restore down sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
windowRestoreUpSound
	"Answer the window restore up sound."

	^self sounds at: #windowRestoreUp ifAbsent: [self defaultSound]! !

!SoundTheme methodsFor: 'accessing' stamp: ''!
sounds
	"Answer the value of sounds"

	^ sounds! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
initializeSounds
	"Initialize the receiver's event sounds."

	self sounds: Dictionary new.
	self sounds
		at: #default put: self defaultDefaultSound;
		at: #abort put: self defaultAbortSound;
		at: #alert put: self defaultAlertSound;
		at: #deny put: self defaultDenySound;
		at: #message put: self defaultMessageSound;
		at: #question put: self defaultQuestionSound;
		at: #windowMinimize put: self defaultWindowMinimizeSound;
		at: #windowMaximize put: self defaultWindowMaximizeSound;
		at: #windowRestoreUp put: self defaultWindowRestoreUpSound;
		at: #windowRestoreDown put: self defaultWindowRestoreDownSound;
		at: #windowClose put: self defaultWindowCloseSound! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
windowCloseSound
	"Answer the window close sound."

	^self sounds at: #windowClose ifAbsent: [self defaultSound]! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
windowMaximizeSound
	"Answer the window maximize sound."

	^self sounds at: #windowMaximize ifAbsent: [self defaultSound]! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
defaultWindowRestoreUpSound
	"Answer the default window restore up sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
defaultMessageSound
	"Answer the default message sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
defaultWindowMaximizeSound
	"Answer the default window maximize sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
windowRestoreDownSound
	"Answer the window restore down sound."

	^self sounds at: #windowRestoreDown ifAbsent: [self defaultSound]! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self initializeSounds! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
defaultQuestionSound
	"Answer the default question sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
windowOpenSound
	"Answer the window open sound."

	^self sounds at: #windowOpen ifAbsent: [self defaultSound]! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
abortSound
	"Answer the abort sound."

	^self sounds at: #abort ifAbsent: [self defaultSound]! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
questionSound
	"Answer the question sound."

	^self sounds at: #question ifAbsent: [self defaultSound]! !

!SoundTheme methodsFor: 'accessing' stamp: ''!
sounds: anObject
	"Set the value of sounds"

	sounds := anObject! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
defaultDefaultSound
	"Answer the default default sound!!"

	^Beeper default! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
denySound
	"Answer the deny sound."

	^self sounds at: #deny ifAbsent: [self defaultSound]! !

!SoundTheme methodsFor: 'initialization' stamp: ''!
defaultWindowCloseSound
	"Answer the default window close sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'initialize-release' stamp: ''!
defaultWindowOpenSound
	"Answer the default window open sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
windowMinimizeSound
	"Answer the window minimize sound."

	^self sounds at: #windowMinimize ifAbsent: [self defaultSound]! !

!SoundTheme methodsFor: 'initialize-release' stamp: ''!
defaultAlertSound
	"Answer the default alert sound."

	^self defaultSound! !

!SoundTheme methodsFor: 'sounds' stamp: ''!
alertSound
	"Answer the alert sound."

	^self sounds at: #alert ifAbsent: [self defaultSound]! !

!SoundTheme class methodsFor: 'settings' stamp: ''!
useThemeSounds: aBoolean
	UseThemeSounds := aBoolean! !

!SoundTheme class methodsFor: 'accessing' stamp: ''!
beCurrent
	"Make a new instance of the receiver be the current theme."

	self isAbstract ifTrue: [^self error: self name, ' is abstract, send #beCurrent to a subclass.'].
	self current: self newDefault! !

!SoundTheme class methodsFor: 'defaults' stamp: ''!
themeName
	"Answer the friendly name of the theme."

	^'Beeper sounds'! !

!SoundTheme class methodsFor: 'accessing' stamp: ''!
current
	"Answer the current ui theme."

	^Current ifNil: [Current := NullSoundTheme newDefault. Current]! !

!SoundTheme class methodsFor: 'accessing' stamp: ''!
current: aSoundTheme
	"Set the current sound theme."

	Current := aSoundTheme! !

!SoundTheme class methodsFor: 'instance creation' stamp: ''!
newDefault
	"Answer a new instance of the sound theme with
	its default sounds."

	^self new! !

!SoundTheme class methodsFor: 'testing' stamp: ''!
isCurrent
	"Answer whether an instance of the receiver is the current theme."

	^self current class == self! !

!SoundTheme class methodsFor: 'settings' stamp: ''!
useThemeSounds
	 ^ UseThemeSounds ifNil: [UseThemeSounds := true]! !

!SoundTheme class methodsFor: 'testing' stamp: ''!
isAbstract
	"Answer whether the receiver is considered to be abstract."

	^false! !

!SoundTheme class methodsFor: 'accessing' stamp: ''!
allThemeClasses
	"Answer the subclasses of the receiver that are considered to be
	concrete (useable as a theme)."

	^self withAllSubclasses reject: [:c | c isAbstract]! !

!SourceChunkWriteStream commentStamp: ''!
I am a special ChunkWriteStream used to write on the streams without the flushing part.
If the flushing part can be changed in my super class then my existence must be terminated.!
!SourceChunkWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: aString
	"Append the argument, aString, to the receiver, doubling embedded !! terminators and adding a extra one"

	| string start bangIndex |
	string := aString asString.
	start := 1.
	[ 
	(bangIndex := string indexOf: self terminatorMark startingAt: start)
	= 0 ] whileFalse: [ 
		decoratedStream
			next: bangIndex - start + 1
			putAll: string
			startingAt: start.
		self bang. "double it"
		start := bangIndex + 1 ].
	decoratedStream
		next: string size - start + 1
		putAll: string
		startingAt: start.
	self bang. "one extra"
	decoratedStream setToEnd! !

!SourceCodeFonts commentStamp: ''!
I'm a font setting for Source Code Pro fonts.!
!SourceCodeFonts methodsFor: 'notes' stamp: ''!
seeClassSide! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
sizeSuperTiny

	<styleName: #superTiny>
	^ 5! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
sizeMedium 

	<styleName: #medium>
	^ 13! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
sizeVeryLarge

	<styleName: #veryLarge>
	^ 18! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
useSourceCode! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
sizeLarge

	<styleName: #large>
	^ 16! !

!SourceCodeFonts class methodsFor: 'font registration' stamp: ''!
registerFonts: freeTypeFontManager
	{ SourceSansProRegular. SourceCodeProRegular } do: [ :each |
		| font |
		font := each new.
		freeTypeFontManager 
			addFromFileContents: font fontContents 
			baseName: font originalFileName ]! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
defaultFontName
	^ 'Source Sans Pro'! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
setSourceCodeFonts: pointSize
	StandardFonts
		setAllStandardFontsTo: (LogicalFont familyName: self defaultFontName pointSize: pointSize);
		haloFont: (LogicalFont familyName: self defaultFontName pointSize: pointSize - 1);
		balloonFont: (LogicalFont familyName: self defaultFontName pointSize: pointSize - 1);
		windowTitleFont: (LogicalFont familyName: self defaultFontName pointSize: pointSize + 1);
		listFont: (LogicalFont familyName: self defaultFontName pointSize: pointSize);
		menuFont: (LogicalFont familyName: self defaultFontName pointSize: pointSize);
		codeFont: (LogicalFont familyName: self fontName pointSize: pointSize)! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
fontName
	^ 'Source Code Pro'! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
codeFontName 
	^ 'Source Code Pro'! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
sizeHuge

	<styleName: #huge>
	^ 22! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
sizeSmall 

	<styleName: #small>
	^ 10! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
fontButton: aString size: size 
	^ (Smalltalk ui theme 
		newButtonIn: self
			for: self
			getState: nil 
			action: #setSourceCodeFonts:	
			arguments: { size }
			getEnabled: nil
			getLabel: nil
			help: 'Change font style to Source Code Pro' translated)
		label: aString;
		yourself! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
sizeTiny

	<styleName: #tiny>
	^ 8! !

!SourceCodeFonts class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #useSourceCode)
		parent: #appearance;
		order: 4;
		target: self;
		iconName: #smallConfigurationIcon;
		label: 'Source Code Fonts';
		description: 'Use Source Code Pro Fonts';
		default: SourceCodeFonts;
		precondition: [ FT2Library current isAvailable not ];
		dialog: [ self fontSourceCodeRow ]! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
useSourceCode: aBoolean! !

!SourceCodeFonts class methodsFor: 'settings' stamp: ''!
fontSourceCodeRow
	| theme |
	
	theme := Smalltalk ui theme.
	^ theme newRowIn: self for: {
		theme buttonLabelForText: 'Predefined styles: ' translated.
		self fontButton: 'Small' size: self sizeSmall.
		self fontButton: 'Medium' size: self sizeMedium.
		self fontButton: 'Large' size: self sizeLarge.
		self fontButton: 'Very Large' size: self sizeVeryLarge.
		self fontButton: 'Huge' size: self sizeHuge	}! !

!SourceCodeFonts class methodsFor: 'settings' stamp: ''!
setFontsToStyleNamed: aSymbol

	(Pragma allNamed: #styleName: in: SourceCodeFonts class)
		detect: [ :each | each arguments first = aSymbol ]
		ifFound: [ :pragma | self setSourceCodeFonts: (self perform: pragma method selector) ]! !

!SourceCodeFonts class methodsFor: 'accessing' stamp: ''!
setSourceCodeFontsDefault
	self setSourceCodeFonts: self sizeSmall! !

!SourceCodeProRegular commentStamp: ''!
http://sourceforge.net/projects/sourcecodepro.adobe/

Copyright 2010, 2012 Adobe Systems Incorporated (http://www.adobe.com/), with Reserved Font Name 'Source'. All Rights Reserved. Source is a trademark of Adobe Systems Incorporated in the United States and/or other countries.

This Font Software is licensed under the SIL Open Font License, Version 1.1.

This license is copied below, and is also available with a FAQ at: http://scripts.sil.org/OFL


-----------------------------------------------------------
SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
-----------------------------------------------------------

PREAMBLE
The goals of the Open Font License (OFL) are to stimulate worldwide
development of collaborative font projects, to support the font creation
efforts of academic and linguistic communities, and to provide a free and
open framework in which fonts may be shared and improved in partnership
with others.

The OFL allows the licensed fonts to be used, studied, modified and
redistributed freely as long as they are not sold by themselves. The
fonts, including any derivative works, can be bundled, embedded, 
redistributed and/or sold with any software provided that any reserved
names are not used by derivative works. The fonts and derivatives,
however, cannot be released under any other type of license. The
requirement for fonts to remain under this license does not apply
to any document created using the fonts or their derivatives.

DEFINITIONS
"Font Software" refers to the set of files released by the Copyright
Holder(s) under this license and clearly marked as such. This may
include source files, build scripts and documentation.

"Reserved Font Name" refers to any names specified as such after the
copyright statement(s).

"Original Version" refers to the collection of Font Software components as
distributed by the Copyright Holder(s).

"Modified Version" refers to any derivative made by adding to, deleting,
or substituting -- in part or in whole -- any of the components of the
Original Version, by changing formats or by porting the Font Software to a
new environment.

"Author" refers to any designer, engineer, programmer, technical
writer or other person who contributed to the Font Software.

PERMISSION & CONDITIONS
Permission is hereby granted, free of charge, to any person obtaining
a copy of the Font Software, to use, study, copy, merge, embed, modify,
redistribute, and sell modified and unmodified copies of the Font
Software, subject to the following conditions:

1) Neither the Font Software nor any of its individual components,
in Original or Modified Versions, may be sold by itself.

2) Original or Modified Versions of the Font Software may be bundled,
redistributed and/or sold with any software, provided that each copy
contains the above copyright notice and this license. These can be
included either as stand-alone text files, human-readable headers or
in the appropriate machine-readable metadata fields within text or
binary files as long as those fields can be easily viewed by the user.

3) No Modified Version of the Font Software may use the Reserved Font
Name(s) unless explicit written permission is granted by the corresponding
Copyright Holder. This restriction only applies to the primary font name as
presented to the users.

4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
Software shall not be used to promote, endorse or advertise any
Modified Version, except to acknowledge the contribution(s) of the
Copyright Holder(s) and the Author(s) or with their explicit written
permission.

5) The Font Software, modified or unmodified, in part or in whole,
must be distributed entirely under this license, and must not be
distributed under any other license. The requirement for fonts to
remain under this license does not apply to any document created
using the Font Software.

TERMINATION
This license becomes null and void if any of the above conditions are
not met.

DISCLAIMER
THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE
COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
OTHER DEALINGS IN THE FONT SOFTWARE.
!
!SourceCodeProRegular class methodsFor: 'accessing' stamp: ''!
fontContents
	^ #[0 1 0 0 0 20 1 0 0 4 0 64 66 65 83 69 101 30 93 189 0 2 159 20 0 0 0 70 68 83 73 71 108 218 201 187 0 2 235 40 0 0 24 228 71 68 69 70 210 234 213 190 0 2 159 92 0 0 2 126 71 80 79 83 255 137 6 167 0 2 161 220 0 0 19 88 71 83 85 66 136 35 73 227 0 2 181 52 0 0 25 148 79 83 47 50 149 188 215 242 0 0 1 200 0 0 0 96 83 86 71 32 212 242 251 247 0 2 206 200 0 0 28 96 99 109 97 112 106 192 103 190 0 0 26 100 0 0 53 44 99 118 116 32 0 191 11 113 0 0 81 72 0 0 0 34 102 112 103 109 6 89 156 55 0 0 79 144 0 0 1 115 103 97 115 112 255 255 0 3 0 2 159 12 0 0 0 8 103 108 121 102 139 211 105 217 0 0 93 140 0 1 241 188 104 101 97 100 4 250 55 14 0 0 1 76 0 0 0 54 104 104 101 97 6 51 6 150 0 0 1 132 0 0 0 36 104 109 116 120 49 61 19 242 0 0 2 40 0 0 24 60 108 111 99 97 128 17 247 196 0 0 81 108 0 0 12 32 109 97 120 112 8 52 2 119 0 0 1 168 0 0 0 32 110 97 109 101 131 164 187 159 0 2 79 72 0 0 23 116 112 111 115 116 26 22 230 75 0 2 102 188 0 0 56 78 112 114 101 112 250 54 192 196 0 0 81 4 0 0 0 66 0 1 0 0 0 2 2 143 112 199 44 240 95 15 60 245 0 9 3 232 0 0 0 0 209 193 199 74 0 0 0 0 209 194 41 187 255 63 254 112 3 25 4 36 0 0 0 9 0 2 0 0 0 0 0 0 0 1 0 0 3 216 254 239 0 0 2 88 255 63 255 63 3 25 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 15 0 1 0 0 6 15 0 143 0 16 0 114 0 6 0 1 0 0 0 0 0 10 0 0 2 0 1 115 0 4 0 2 0 3 2 88 1 144 0 5 0 0 2 138 2 88 0 0 0 75 2 138 2 88 0 0 1 94 0 50 1 32 0 0 2 11 5 9 3 4 3 2 2 4 32 0 2 247 2 0 56 3 0 0 0 0 0 0 0 0 65 68 66 79 0 64 0 0 255 255 2 238 255 6 0 0 3 216 1 17 96 0 1 159 0 0 0 0 1 224 2 148 0 0 0 32 0 3 2 88 0 62 0 0 0 0 2 88 0 0 2 88 0 0 2 88 0 32 2 88 0 99 2 88 0 65 2 88 0 87 2 88 0 114 2 88 0 133 2 88 0 53 2 88 0 79 2 88 0 95 2 88 0 81 2 88 0 98 2 88 0 134 2 88 0 72 2 88 0 82 2 88 0 48 2 88 0 102 2 88 0 50 2 88 0 100 2 88 0 67 2 88 0 42 2 88 0 79 2 88 0 43 2 88 0 10 2 88 0 54 2 88 0 38 2 88 0 65 2 88 0 81 2 88 0 93 2 88 0 80 2 88 0 60 2 88 0 68 2 88 0 103 2 88 0 72 2 88 0 93 2 88 0 90 2 88 0 55 2 88 0 106 2 88 0 81 2 88 0 58 2 88 0 93 2 88 0 60 2 88 0 93 2 88 0 60 2 88 0 146 2 88 0 71 2 88 0 69 2 88 0 77 2 88 0 51 2 88 0 8 2 88 0 64 2 88 0 49 2 88 0 71 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 0 32 2 88 255 255 2 88 255 255 2 88 255 255 2 88 0 26 2 88 0 99 2 88 0 65 2 88 0 65 2 88 0 65 2 88 0 65 2 88 0 65 2 88 0 87 2 88 0 87 2 88 0 87 2 88 0 87 2 88 0 12 2 88 0 20 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 115 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 114 2 88 0 53 2 88 0 53 2 88 0 53 2 88 0 53 2 88 0 53 2 88 0 53 2 88 0 53 2 88 0 53 2 88 0 53 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 28 2 88 0 79 2 88 0 10 2 88 0 95 2 88 0 95 2 88 0 95 2 88 0 95 2 88 0 95 2 88 0 95 2 88 0 95 2 88 0 95 2 88 0 95 2 88 0 95 2 88 0 95 2 88 0 95 2 88 0 81 2 88 0 98 2 88 0 98 2 88 0 98 2 88 0 125 2 88 0 134 2 88 0 134 2 88 0 134 2 88 0 56 2 88 0 134 2 88 0 10 2 88 0 134 2 88 0 72 2 88 0 72 2 88 0 72 2 88 0 82 2 88 0 82 2 88 0 82 2 88 0 82 2 88 0 82 2 88 0 82 2 88 0 82 2 88 0 82 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 48 2 88 0 36 2 88 0 36 2 88 0 33 2 88 0 100 2 88 0 100 2 88 0 100 2 88 0 100 2 88 0 100 2 88 0 100 2 88 0 100 2 88 0 67 2 88 0 67 2 88 0 67 2 88 0 67 2 88 0 67 2 88 0 67 2 88 0 67 2 88 0 67 2 88 0 78 2 88 0 42 2 88 0 42 2 88 0 42 2 88 0 42 2 88 0 42 2 88 0 42 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 79 2 88 0 43 2 88 0 10 2 88 0 10 2 88 0 10 2 88 0 10 2 88 0 38 2 88 0 38 2 88 0 38 2 88 0 38 2 88 0 38 2 88 0 38 2 88 0 38 2 88 0 38 2 88 0 65 2 88 0 65 2 88 0 65 2 88 0 65 2 88 0 65 2 88 0 65 2 88 0 12 2 88 0 101 2 88 0 59 2 88 0 85 2 88 0 112 2 88 0 68 2 88 0 90 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 73 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 17 2 88 0 17 2 88 0 17 2 88 0 20 2 88 0 93 2 88 0 80 2 88 0 80 2 88 0 80 2 88 0 80 2 88 0 80 2 88 0 54 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 68 2 88 0 72 2 88 0 72 2 88 0 72 2 88 0 72 2 88 0 72 2 88 0 72 2 88 0 72 2 88 0 72 2 88 255 240 2 88 255 246 2 88 0 93 2 88 0 93 2 88 0 40 2 88 0 93 2 88 0 20 2 88 0 90 2 88 0 90 2 88 0 90 2 88 0 90 2 88 0 90 2 88 0 90 2 88 0 90 2 88 0 90 2 88 0 90 2 88 0 90 2 88 0 90 2 88 0 90 2 88 0 55 2 88 0 106 2 88 0 106 2 88 0 106 2 88 0 106 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 81 2 88 0 43 2 88 0 58 2 88 0 58 2 88 0 58 2 88 0 93 2 88 0 93 2 88 0 93 2 88 0 93 2 88 0 93 2 88 0 93 2 88 0 93 2 88 0 93 2 88 255 234 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 53 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 11 2 88 0 146 2 88 0 103 2 88 0 146 2 88 0 146 2 88 0 132 2 88 0 132 2 88 0 65 2 88 0 71 2 88 0 71 2 88 0 71 2 88 0 71 2 88 0 71 2 88 0 71 2 88 0 71 2 88 0 71 2 88 0 88 2 88 0 103 2 88 0 69 2 88 0 69 2 88 0 69 2 88 0 69 2 88 0 69 2 88 0 69 2 88 0 69 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 77 2 88 0 51 2 88 0 8 2 88 0 8 2 88 0 8 2 88 0 8 2 88 0 49 2 88 0 49 2 88 0 49 2 88 0 49 2 88 0 49 2 88 0 49 2 88 0 49 2 88 0 49 2 88 0 71 2 88 0 71 2 88 0 71 2 88 0 71 2 88 0 71 2 88 0 71 2 88 0 60 2 88 0 93 2 88 0 93 2 88 0 55 2 88 0 93 2 88 255 248 2 88 0 80 2 88 0 94 2 88 0 93 2 88 0 93 2 88 0 61 2 88 0 80 2 88 0 60 2 88 0 60 2 88 0 63 2 88 0 60 2 88 0 115 2 88 0 69 2 88 0 22 2 88 0 91 2 88 0 62 2 88 0 61 2 88 0 55 2 88 0 60 2 88 0 60 2 88 0 78 2 88 0 51 2 88 0 60 2 88 0 77 2 88 0 93 2 88 0 93 2 88 0 93 2 88 0 90 2 88 0 86 2 88 0 56 2 88 0 28 2 88 0 81 2 88 0 76 2 88 0 81 2 88 0 79 2 88 0 148 2 88 0 42 2 88 0 42 2 88 0 58 2 88 255 251 2 88 0 93 2 88 0 96 2 88 0 60 2 88 0 33 2 88 0 44 2 88 0 63 2 88 0 63 2 88 0 63 2 88 0 146 2 88 0 146 2 88 0 99 2 88 0 55 2 88 0 71 2 88 0 56 2 88 0 56 2 88 0 54 2 88 0 69 2 88 0 2 2 88 0 50 2 88 0 77 2 88 0 51 2 88 0 8 2 88 0 49 2 88 0 57 2 88 0 71 2 88 0 71 2 88 0 59 2 88 0 0 2 88 0 25 2 88 0 48 2 88 0 71 2 88 0 89 2 88 0 71 2 88 0 82 2 88 0 84 2 88 0 60 2 88 0 82 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 57 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 60 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 99 2 88 0 90 2 88 0 99 2 88 0 90 2 88 0 99 2 88 0 56 2 88 0 32 2 88 0 99 2 88 0 135 2 88 0 43 2 88 0 114 2 88 0 65 2 88 0 79 2 88 0 48 2 88 0 95 2 88 0 98 2 88 0 43 2 88 0 72 2 88 0 82 2 88 0 70 2 88 0 48 2 88 0 79 2 88 0 102 2 88 0 75 2 88 0 42 2 88 0 38 2 88 0 26 2 88 0 54 2 88 0 44 2 88 0 38 2 88 0 36 2 88 0 24 2 88 0 24 2 88 0 24 2 88 0 95 2 88 0 24 2 88 0 40 2 88 0 38 2 88 0 24 2 88 0 57 2 88 0 93 2 88 0 48 2 88 0 65 2 88 0 91 2 88 0 116 2 88 0 93 2 88 0 72 2 88 0 81 2 88 0 100 2 88 0 56 2 88 0 84 2 88 0 47 2 88 0 92 2 88 0 64 2 88 0 27 2 88 0 93 2 88 0 60 2 88 0 66 2 88 0 79 2 88 0 44 2 88 0 56 2 88 0 53 2 88 0 34 2 88 0 90 2 88 0 93 2 88 0 79 2 88 0 37 2 88 0 57 2 88 0 91 2 88 0 93 2 88 0 81 2 88 0 81 2 88 0 64 2 88 0 79 2 88 0 79 2 88 0 34 2 88 0 81 2 88 0 79 2 88 0 100 2 88 0 62 2 88 0 91 2 88 0 146 2 88 0 68 2 88 0 197 2 88 0 219 2 88 0 219 2 88 1 1 2 88 0 240 2 88 1 9 2 88 0 240 2 88 0 139 2 88 1 11 2 88 0 251 2 88 0 232 2 88 0 232 2 88 0 220 2 88 0 209 2 88 1 9 2 88 0 144 2 88 0 138 2 88 0 144 2 88 0 148 2 88 0 159 2 88 0 159 2 88 0 127 2 88 0 145 2 88 0 139 2 88 0 147 2 88 0 229 2 88 0 228 2 88 0 246 2 88 0 240 2 88 0 170 2 88 0 170 2 88 0 170 2 88 0 172 2 88 0 182 2 88 0 182 2 88 0 32 2 88 0 99 2 88 0 99 2 88 0 135 2 88 0 22 2 88 0 114 2 88 0 1 2 88 0 62 2 88 0 78 2 88 0 78 2 88 0 102 2 88 0 2 2 88 0 72 2 88 0 79 2 88 0 48 2 88 0 79 2 88 0 102 2 88 0 65 2 88 0 42 2 88 0 47 2 88 0 26 2 88 0 54 2 88 0 79 2 88 0 65 2 88 0 40 2 88 0 38 2 88 0 19 2 88 0 55 2 88 0 98 2 88 0 46 2 88 0 44 2 88 0 30 2 88 0 114 2 88 0 114 2 88 0 5 2 88 0 135 2 88 0 66 2 88 0 67 2 88 0 95 2 88 0 95 2 88 0 81 2 88 255 248 2 88 0 39 2 88 0 5 2 88 0 102 2 88 0 78 2 88 0 47 2 88 0 75 2 88 0 24 2 88 0 48 2 88 0 38 2 88 0 135 2 88 0 60 2 88 0 1 2 88 0 62 2 88 0 102 2 88 0 19 2 88 0 79 2 88 0 65 2 88 0 38 2 88 0 38 2 88 0 54 2 88 0 65 2 88 0 91 2 88 0 95 2 88 0 1 2 88 0 32 2 88 255 255 2 88 0 114 2 88 0 59 2 88 0 78 2 88 0 48 2 88 0 48 2 88 0 47 2 88 0 47 2 88 0 81 2 88 0 75 2 88 0 104 2 88 0 146 2 88 0 42 2 88 0 68 2 88 0 6 2 88 0 62 2 88 0 100 2 88 0 100 2 88 0 110 2 88 0 29 2 88 0 64 2 88 0 93 2 88 0 60 2 88 0 93 2 88 0 93 2 88 0 80 2 88 0 66 2 88 0 49 2 88 0 32 2 88 0 64 2 88 0 94 2 88 0 88 2 88 0 58 2 88 0 58 2 88 0 35 2 88 0 70 2 88 0 125 2 88 0 61 2 88 0 44 2 88 0 55 2 88 0 68 2 88 0 68 2 88 0 20 2 88 0 146 2 88 0 80 2 88 0 71 2 88 0 90 2 88 0 90 2 88 0 55 2 88 255 249 2 88 0 58 2 88 0 20 2 88 0 110 2 88 0 100 2 88 0 49 2 88 0 103 2 88 0 41 2 88 0 60 2 88 0 70 2 88 0 162 2 88 0 72 2 88 0 6 2 88 0 62 2 88 0 110 2 88 0 33 2 88 0 93 2 88 0 80 2 88 0 51 2 88 0 51 2 88 0 64 2 88 0 88 2 88 0 93 2 88 0 6 2 88 0 81 2 88 0 81 2 88 0 17 2 88 0 68 2 88 0 69 2 88 0 100 2 88 0 60 2 88 0 60 2 88 0 49 2 88 0 49 2 88 0 60 2 88 0 60 2 88 0 85 2 88 0 99 2 88 0 99 2 88 0 2 2 88 0 42 2 88 0 71 2 88 0 99 2 88 0 69 2 88 0 57 2 88 0 39 2 88 0 56 2 88 0 77 2 88 0 70 2 88 0 68 2 88 0 67 2 88 0 71 2 88 0 71 2 88 0 99 2 88 0 69 2 88 0 57 2 88 0 39 2 88 0 56 2 88 0 78 2 88 0 70 2 88 0 68 2 88 0 67 2 88 0 71 2 88 0 71 2 88 0 99 2 88 0 69 2 88 0 57 2 88 0 39 2 88 0 56 2 88 0 77 2 88 0 70 2 88 0 68 2 88 0 67 2 88 0 71 2 88 0 219 2 88 0 197 2 88 0 219 2 88 0 197 2 88 0 32 2 88 0 227 2 88 0 227 2 88 0 109 2 88 0 121 2 88 0 245 2 88 0 131 2 88 0 209 2 88 0 217 2 88 0 95 2 88 0 103 2 88 0 217 2 88 0 103 2 88 0 212 2 88 0 197 2 88 0 211 2 88 0 83 2 88 0 97 2 88 0 85 2 88 0 85 2 88 0 85 2 88 0 80 2 88 0 0 2 88 0 80 2 88 0 0 2 88 0 219 2 88 0 151 2 88 0 139 2 88 0 166 2 88 0 154 2 88 0 139 2 88 0 117 2 88 0 166 2 88 0 154 2 88 0 139 2 88 0 117 2 88 0 138 2 88 0 117 2 88 0 152 2 88 0 0 2 88 0 60 2 88 0 60 2 88 0 62 2 88 255 102 2 88 0 208 2 88 0 122 2 88 0 225 2 88 0 98 2 88 0 120 2 88 0 99 2 88 0 99 2 88 1 7 2 88 0 99 2 88 1 7 2 88 0 84 2 88 0 127 2 88 0 127 2 88 0 91 2 88 0 72 2 88 0 157 2 88 0 94 2 88 0 14 2 88 0 87 2 88 0 14 2 88 0 94 2 88 0 116 2 88 0 225 2 88 0 98 2 88 0 225 2 88 0 98 2 88 0 186 2 88 0 98 2 88 0 226 2 88 0 98 2 88 0 225 2 88 0 98 2 88 0 30 2 88 0 30 2 88 0 112 2 88 255 251 2 88 0 15 2 88 0 49 2 88 0 49 2 88 0 87 2 88 0 104 2 88 0 134 2 88 0 134 2 88 0 134 2 88 0 85 2 88 0 141 2 88 0 175 2 88 0 146 2 88 0 142 2 88 0 148 2 88 0 142 2 88 0 151 2 88 0 156 2 88 0 151 2 88 0 145 2 88 0 236 2 88 0 211 2 88 0 251 2 88 0 244 2 88 0 141 2 88 0 175 2 88 0 146 2 88 0 142 2 88 0 148 2 88 0 142 2 88 0 151 2 88 0 156 2 88 0 151 2 88 0 145 2 88 0 236 2 88 0 211 2 88 0 251 2 88 0 244 2 88 0 161 2 88 0 208 2 88 0 173 2 88 0 172 2 88 0 172 2 88 0 172 2 88 0 176 2 88 0 183 2 88 0 175 2 88 0 173 2 88 0 236 2 88 0 213 2 88 0 251 2 88 0 244 2 88 0 161 2 88 0 208 2 88 0 173 2 88 0 172 2 88 0 172 2 88 0 172 2 88 0 176 2 88 0 183 2 88 0 175 2 88 0 173 2 88 0 236 2 88 0 213 2 88 0 251 2 88 0 244 2 88 0 163 2 88 0 137 2 88 0 142 2 88 0 163 2 88 0 172 2 88 0 181 2 88 0 137 2 88 0 145 2 88 0 198 2 88 0 149 2 88 0 175 2 88 0 175 2 88 0 140 2 88 0 189 2 88 0 196 2 88 0 70 2 88 0 175 2 88 0 142 2 88 0 172 2 88 0 137 2 88 0 243 2 88 0 162 2 88 0 164 2 88 0 159 2 88 0 139 2 88 0 52 2 88 0 159 2 88 0 140 2 88 0 146 2 88 0 145 2 88 0 145 2 88 0 145 2 88 0 142 2 88 0 175 2 88 0 146 2 88 0 160 2 88 0 137 2 88 0 137 2 88 0 173 2 88 0 251 2 88 0 222 2 88 0 165 2 88 0 61 2 88 0 58 2 88 0 85 2 88 0 77 2 88 0 53 2 88 0 58 2 88 0 113 2 88 0 49 2 88 0 96 2 88 0 78 2 88 0 46 2 88 0 42 2 88 0 28 2 88 0 109 2 88 0 42 2 88 0 84 2 88 0 61 2 88 0 96 2 88 0 108 2 88 0 45 2 88 0 55 2 88 0 55 2 88 0 42 2 88 0 69 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 48 2 88 0 28 2 88 0 28 2 88 0 32 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 28 2 88 0 83 2 88 0 28 2 88 0 85 2 88 0 85 2 88 0 102 2 88 0 85 2 88 0 216 2 88 0 85 2 88 0 85 2 88 0 120 2 88 0 107 2 88 0 85 2 88 0 85 2 88 0 85 2 88 0 111 2 88 0 85 2 88 0 76 2 88 0 76 2 88 0 85 2 88 0 85 2 88 0 96 2 88 0 85 2 88 255 252 2 88 0 175 2 88 1 1 2 88 0 170 2 88 0 240 2 88 0 84 2 88 0 76 2 88 0 186 2 88 1 9 2 88 0 153 2 88 0 62 2 88 0 43 2 88 0 38 2 88 0 32 2 88 0 70 2 88 0 80 2 88 0 70 2 88 0 52 2 88 0 27 2 88 0 116 2 88 0 26 2 88 0 17 2 88 0 33 2 88 0 29 2 88 0 33 2 88 0 96 2 88 0 81 2 88 0 86 2 88 0 103 2 88 0 17 2 88 0 33 2 88 0 29 2 88 0 33 2 88 255 244 2 88 0 85 2 88 0 60 2 88 0 74 2 88 0 62 2 88 0 87 2 88 0 73 2 88 0 73 2 88 0 33 2 88 0 62 2 88 0 62 2 88 0 62 2 88 0 62 2 88 0 62 2 88 0 62 2 88 0 42 2 88 0 42 2 88 0 21 2 88 255 231 2 88 0 68 2 88 0 51 2 88 255 231 2 88 255 231 2 88 255 250 2 88 0 77 2 88 0 4 2 88 0 9 2 88 0 9 2 88 0 5 2 88 0 9 2 88 0 9 2 88 0 29 2 88 255 185 2 88 255 224 2 88 255 252 2 88 255 230 2 88 0 45 2 88 0 60 2 88 255 244 2 88 255 253 2 88 0 96 2 88 0 49 2 88 1 1 2 88 0 209 2 88 0 217 2 88 0 226 2 88 0 190 2 88 0 160 2 88 0 202 2 88 0 202 2 88 0 128 2 88 0 164 2 88 0 236 2 88 0 145 2 88 0 145 2 88 0 249 2 88 0 167 2 88 0 236 2 88 0 164 2 88 0 249 2 88 0 127 2 88 0 148 2 88 0 167 2 88 0 144 2 88 0 190 2 88 0 197 2 88 0 234 2 88 0 205 2 88 0 210 2 88 0 53 2 88 0 164 2 88 0 177 2 88 0 209 2 88 0 236 2 88 0 235 2 88 1 9 2 88 0 145 2 88 0 152 2 88 0 127 2 88 0 123 2 88 0 167 2 88 0 166 2 88 0 167 2 88 0 166 2 88 0 144 2 88 0 143 2 88 0 154 2 88 0 149 2 88 0 234 2 88 0 241 2 88 0 148 2 88 0 158 2 88 0 232 2 88 0 232 2 88 0 139 2 88 0 147 2 88 0 190 2 88 0 203 2 88 0 197 2 88 0 185 2 88 0 145 2 88 0 152 2 88 0 255 2 88 0 107 2 88 0 106 2 88 0 144 2 88 0 154 2 88 0 245 2 88 0 220 2 88 0 247 2 88 0 232 2 88 0 224 2 88 0 208 2 88 0 224 2 88 1 35 2 88 0 224 2 88 0 184 2 88 0 184 2 88 0 184 2 88 0 184 2 88 0 234 2 88 0 148 2 88 0 190 2 88 0 205 2 88 0 222 2 88 0 205 2 88 0 205 2 88 0 210 2 88 0 211 2 88 1 9 2 88 0 177 2 88 0 145 2 88 0 144 2 88 0 144 2 88 0 127 2 88 0 167 2 88 0 111 2 88 0 238 2 88 0 177 2 88 0 177 2 88 0 129 2 88 0 206 2 88 0 127 2 88 0 123 2 88 1 11 2 88 255 63 2 88 255 102 2 88 0 158 2 88 0 152 2 88 0 139 2 88 0 158 2 88 0 152 2 88 0 145 2 88 0 147 2 88 0 158 2 88 0 152 2 88 0 158 2 88 0 152 2 88 0 166 2 88 0 171 2 88 0 53 2 88 0 89 2 88 0 166 2 88 0 171 2 88 0 163 2 88 0 155 2 88 0 144 2 88 0 154 2 88 0 144 2 88 0 154 2 88 0 144 2 88 0 154 2 88 0 156 2 88 0 155 2 88 0 171 2 88 0 163 2 88 0 167 2 88 0 166 2 88 0 145 2 88 0 149 2 88 0 148 2 88 0 138 2 88 0 159 2 88 0 144 2 88 0 144 2 88 0 159 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 255 217 2 88 255 217 2 88 1 5 2 88 0 222 2 88 0 33 2 88 0 33 2 88 1 5 2 88 0 222 2 88 0 18 2 88 0 18 2 88 1 5 2 88 0 222 2 88 1 5 2 88 1 5 2 88 0 222 2 88 0 222 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 1 5 2 88 1 5 2 88 0 222 2 88 0 222 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 1 5 2 88 1 5 2 88 0 222 2 88 0 222 2 88 0 222 2 88 0 222 2 88 0 222 2 88 0 222 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 0 75 2 88 0 75 2 88 1 5 2 88 0 222 2 88 255 217 2 88 0 183 2 88 1 5 2 88 0 183 2 88 0 183 2 88 255 217 2 88 255 217 2 88 255 217 2 88 1 5 2 88 0 183 2 88 0 183 2 88 255 217 2 88 255 217 2 88 255 217 2 88 1 5 2 88 0 183 2 88 0 183 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 1 5 2 88 255 217 2 88 255 217 2 88 1 5 2 88 255 217 2 88 255 217 2 88 255 217 2 88 255 217 2 88 1 5 2 88 1 5 2 88 1 5 2 88 255 217 2 88 0 222 2 88 1 5 2 88 0 222 2 88 255 217 2 88 0 222 2 88 255 217 2 88 0 222 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 1 44 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 2 13 2 88 0 0 2 88 1 44 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 1 44 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 0 2 88 0 52 2 88 0 57 2 88 0 99 2 88 0 83 2 88 0 45 2 88 0 0 2 88 255 249 2 88 0 0 2 88 255 245 0 0 0 5 0 0 0 3 0 0 2 36 0 0 0 4 0 0 16 212 0 1 0 0 0 0 0 44 0 3 0 1 0 0 2 36 0 3 0 10 0 0 16 212 0 6 1 248 0 0 0 9 0 247 0 3 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 3 135 3 140 3 217 4 67 4 92 3 96 3 139 3 178 3 179 3 188 4 113 3 131 3 152 3 130 3 184 3 97 3 98 3 99 3 100 3 101 3 102 3 103 3 104 3 105 3 106 3 132 3 133 4 120 4 118 4 121 3 137 3 215 0 4 0 5 0 6 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 15 0 16 0 17 0 18 0 19 0 20 0 21 0 22 0 23 0 24 0 25 0 26 0 27 0 28 0 29 3 180 3 186 3 181 4 125 3 174 4 217 0 30 0 31 0 32 0 33 0 34 0 35 0 36 0 37 0 38 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 47 0 48 0 49 0 50 0 51 0 52 0 53 0 54 0 55 3 182 3 185 3 183 4 127 0 0 0 60 0 63 0 84 0 96 0 158 0 167 0 216 1 6 1 5 1 7 1 9 1 8 1 12 1 33 1 44 1 43 1 45 1 47 1 77 1 76 1 78 1 80 1 107 1 114 1 113 1 115 1 117 1 116 1 165 1 164 1 166 1 168 3 189 4 134 4 71 4 68 3 191 3 160 3 192 1 155 3 212 3 210 3 213 4 218 4 227 4 126 0 79 0 187 4 133 4 124 4 122 4 123 4 69 4 138 4 139 4 149 4 150 2 132 4 140 4 23 4 25 2 107 1 28 1 137 3 138 3 136 4 129 4 143 4 72 4 128 4 144 3 150 3 151 3 134 5 96 0 56 0 59 0 166 0 189 1 139 3 155 3 156 3 143 3 144 3 141 3 142 4 116 4 206 1 195 0 243 4 89 4 70 3 148 3 149 6 6 6 7 3 190 3 159 3 145 3 146 4 93 0 58 0 97 0 57 0 99 0 95 0 129 0 130 0 132 0 128 0 164 0 165 0 0 0 163 0 213 0 214 0 212 1 87 4 219 4 226 4 228 4 229 4 232 4 230 4 233 4 231 4 234 4 220 0 4 14 176 0 0 1 184 1 0 0 7 0 184 0 0 0 13 0 47 0 64 0 96 0 126 0 191 0 209 0 223 0 241 1 128 1 138 1 143 1 147 1 161 1 176 1 194 1 220 1 227 1 231 1 235 1 245 1 255 2 27 2 55 2 67 2 81 2 88 2 92 2 104 2 106 2 110 2 118 2 123 2 126 2 132 2 146 2 149 2 153 2 159 2 162 2 164 2 167 2 176 2 179 2 185 2 188 2 191 2 193 2 204 2 209 2 222 2 228 3 12 3 19 3 32 3 42 3 44 3 49 3 52 3 61 3 66 3 69 3 95 3 97 3 117 3 122 3 126 3 138 3 140 3 144 3 161 3 171 3 176 3 194 3 206 3 209 3 213 3 215 3 217 3 219 3 221 3 225 4 15 4 47 4 95 4 99 4 117 4 147 4 155 4 163 4 171 4 179 4 183 4 187 4 194 4 209 4 217 4 227 4 233 4 239 4 243 29 67 29 73 29 77 29 80 29 82 29 88 29 91 29 156 29 160 29 187 30 7 30 17 30 23 30 33 30 43 30 59 30 73 30 83 30 99 30 111 30 133 30 151 30 158 30 249 31 193 31 207 31 223 31 239 31 254 32 7 32 16 32 30 32 34 32 38 32 48 32 51 32 53 32 58 32 63 32 68 32 73 32 113 32 121 32 127 32 137 32 142 32 148 32 161 32 164 32 167 32 169 32 172 32 174 32 178 32 181 32 186 32 189 33 5 33 19 33 23 33 32 33 34 33 38 33 46 33 82 33 90 33 94 33 137 33 149 33 153 33 168 33 211 34 0 34 3 34 6 34 15 34 18 34 21 34 26 34 31 34 41 34 43 34 55 34 72 34 97 34 101 35 2 35 16 35 33 37 161 37 172 37 186 37 196 37 198 37 204 37 207 37 217 37 230 38 17 38 21 38 60 38 64 38 66 38 96 38 99 38 102 38 107 39 19 39 82 39 100 39 231 46 24 46 37 224 162 224 179 251 2 254 255 255 255 0 0 0 0 0 13 0 32 0 48 0 65 0 97 0 160 0 192 0 210 0 224 0 242 1 138 1 143 1 146 1 160 1 175 1 194 1 205 1 226 1 230 1 234 1 244 1 248 2 24 2 55 2 67 2 80 2 82 2 89 2 94 2 106 2 107 2 111 2 120 2 125 2 128 2 135 2 148 2 152 2 156 2 161 2 164 2 166 2 176 2 178 2 183 2 187 2 190 2 193 2 198 2 208 2 216 2 224 3 0 3 15 3 24 3 35 3 44 3 46 3 52 3 57 3 66 3 69 3 95 3 97 3 116 3 122 3 126 3 132 3 140 3 142 3 145 3 163 3 172 3 177 3 195 3 208 3 213 3 215 3 217 3 219 3 221 3 225 4 0 4 16 4 48 4 98 4 114 4 144 4 150 4 160 4 170 4 174 4 182 4 186 4 192 4 207 4 212 4 226 4 230 4 238 4 242 29 67 29 71 29 77 29 79 29 82 29 86 29 91 29 156 29 160 29 187 30 6 30 12 30 22 30 32 30 36 30 50 30 62 30 82 30 88 30 108 30 126 30 142 30 158 30 160 31 189 31 205 31 221 31 237 31 253 32 7 32 16 32 18 32 32 32 38 32 47 32 50 32 53 32 57 32 60 32 68 32 71 32 112 32 116 32 125 32 128 32 141 32 148 32 161 32 163 32 166 32 169 32 171 32 174 32 177 32 180 32 184 32 189 33 5 33 19 33 22 33 32 33 34 33 38 33 46 33 80 33 83 33 91 33 137 33 144 33 150 33 168 33 208 34 0 34 2 34 6 34 15 34 17 34 21 34 25 34 30 34 41 34 43 34 55 34 72 34 96 34 100 35 2 35 16 35 28 37 0 37 170 37 178 37 188 37 198 37 201 37 207 37 216 37 230 38 16 38 21 38 58 38 64 38 66 38 96 38 99 38 101 38 106 39 19 39 82 39 100 39 230 46 24 46 34 224 160 224 176 251 1 254 255 255 255 0 1 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 254 212 255 113 0 0 0 0 0 0 0 91 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 154 254 15 0 0 255 132 255 134 0 0 255 133 255 135 255 136 255 135 255 134 255 133 255 131 255 133 0 0 0 0 255 122 255 114 255 113 1 113 0 0 0 0 2 22 2 21 2 20 2 21 2 6 0 0 0 0 0 0 0 0 1 253 0 0 1 253 1 252 1 250 1 246 1 242 1 241 1 216 1 215 255 48 255 47 255 35 0 0 254 229 0 0 254 195 0 0 0 0 0 0 0 0 254 190 254 187 254 197 254 196 254 195 254 194 254 191 254 228 254 180 254 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 230 215 0 0 230 211 0 0 230 214 0 0 230 212 230 128 230 127 230 120 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 226 47 0 0 0 0 0 0 0 0 0 0 0 0 229 90 227 138 0 0 0 0 227 96 0 0 228 85 228 84 227 91 0 0 228 21 0 0 0 0 227 111 0 0 227 109 227 106 227 163 227 168 0 0 227 165 227 164 0 0 227 167 227 158 227 157 0 0 227 154 227 146 227 133 0 0 226 182 226 179 227 107 227 107 0 0 227 14 227 15 226 231 0 0 227 8 227 0 226 210 226 146 0 0 226 138 226 135 0 0 226 69 0 0 0 0 226 90 226 97 226 93 226 56 0 0 226 22 225 205 225 114 0 0 0 0 0 0 0 0 0 0 222 232 0 0 222 218 0 0 221 187 222 171 222 178 0 0 222 139 222 138 222 99 222 94 0 0 222 84 221 170 221 91 221 98 219 230 213 175 213 172 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 180 1 210 1 242 2 48 2 106 2 168 2 202 2 228 3 6 0 0 0 0 4 30 4 32 4 34 0 0 4 34 4 64 4 66 4 68 4 70 4 72 4 86 0 0 0 0 4 88 0 0 0 0 4 86 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 90 4 92 0 0 0 0 0 0 0 0 4 90 4 92 0 0 0 0 0 0 0 0 0 0 4 86 4 98 4 106 4 130 0 0 4 136 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 128 0 0 4 138 0 0 4 140 4 156 4 164 4 198 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 200 4 202 4 208 4 214 4 224 4 230 4 232 4 242 4 244 4 246 4 250 4 254 5 8 5 10 5 16 5 18 0 0 5 18 0 0 5 20 0 0 5 20 0 0 0 0 0 0 0 0 5 16 5 18 5 28 5 30 5 32 5 46 5 64 5 86 5 88 5 110 5 116 5 130 0 0 5 146 6 68 6 76 6 80 6 84 6 88 0 0 0 0 6 86 6 110 0 0 6 112 0 0 0 0 0 0 6 108 0 0 6 112 6 116 0 0 6 116 0 0 0 0 0 0 0 0 6 112 0 0 0 0 6 110 0 0 0 0 0 0 6 106 0 0 0 0 0 0 6 104 0 0 0 0 0 0 0 0 6 98 0 0 0 0 0 0 6 96 0 0 0 0 0 0 0 0 6 98 0 0 0 0 6 96 0 0 6 96 6 98 0 0 0 0 0 0 0 0 6 92 0 0 0 0 0 0 6 88 6 98 7 164 7 168 7 184 0 0 7 198 0 0 7 202 0 0 0 0 0 0 7 198 0 0 0 0 0 0 0 0 7 194 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 182 7 186 7 192 7 194 0 0 0 3 3 135 3 140 3 217 4 67 4 92 3 96 3 139 3 178 3 179 3 188 4 113 3 131 3 152 3 130 3 184 3 97 3 98 3 99 3 100 3 101 3 102 3 103 3 104 3 105 3 106 3 132 3 133 4 120 4 118 4 121 3 137 3 215 0 4 0 5 0 6 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 15 0 16 0 17 0 18 0 19 0 20 0 21 0 22 0 23 0 24 0 25 0 26 0 27 0 28 0 29 3 180 3 186 3 181 4 125 3 174 4 217 0 30 0 31 0 32 0 33 0 34 0 35 0 36 0 37 0 38 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 47 0 48 0 49 0 50 0 51 0 52 0 53 0 54 0 55 3 182 3 185 3 183 4 127 5 96 3 136 4 71 4 68 4 66 4 69 3 187 3 191 4 227 3 210 4 23 3 150 4 129 3 153 3 212 4 228 4 134 4 124 3 225 3 226 4 218 4 138 3 192 3 159 4 233 3 224 4 25 3 151 4 94 4 95 4 96 3 138 0 56 0 57 0 58 0 59 0 60 0 63 0 79 0 84 0 95 0 96 0 97 0 99 0 128 0 129 0 130 0 132 0 254 0 158 0 163 0 164 0 165 0 166 0 167 4 115 0 187 0 212 0 213 0 214 0 216 0 241 0 255 1 155 1 5 1 6 1 7 1 8 1 9 1 12 1 28 1 33 1 43 1 44 1 45 1 47 1 76 1 77 1 78 1 80 1 206 1 107 1 113 1 114 1 115 1 116 1 117 4 116 1 137 1 164 1 165 1 166 1 168 1 193 1 207 1 195 0 61 1 10 0 62 1 11 0 66 1 15 0 85 1 34 0 86 1 35 0 88 1 37 0 87 1 36 0 89 1 38 0 93 1 42 0 100 1 48 0 101 1 49 0 102 1 51 0 103 1 50 0 98 1 46 0 114 1 62 0 115 1 63 0 116 1 64 0 117 1 65 0 122 1 69 0 127 1 75 0 131 1 79 0 133 1 81 0 139 1 86 0 136 1 83 0 134 1 87 1 2 1 210 0 140 1 88 0 141 1 89 1 92 0 144 1 93 0 146 1 95 0 145 1 94 0 151 1 100 0 150 1 99 0 155 1 104 0 159 1 108 0 157 1 106 1 112 1 1 1 208 0 168 1 118 0 170 1 129 0 169 1 119 0 189 1 139 0 190 1 140 0 193 1 141 0 191 1 142 0 197 1 147 0 198 1 148 0 201 1 151 0 199 1 149 0 207 1 158 0 206 1 157 0 211 1 163 0 215 1 167 0 217 1 169 0 218 1 170 0 219 1 171 0 220 1 172 0 222 1 174 0 238 1 190 0 242 1 194 0 243 0 248 1 200 0 250 1 202 0 249 1 201 1 156 1 31 4 72 0 121 0 180 1 131 0 229 1 181 0 65 1 14 0 135 1 82 0 171 1 120 0 221 1 173 0 223 1 175 0 224 1 176 0 225 1 177 0 226 1 178 0 81 1 30 0 118 1 66 0 172 1 121 0 113 1 61 0 156 1 105 0 64 1 13 0 80 1 29 0 188 1 138 0 202 1 152 0 208 1 159 1 213 1 221 1 227 1 228 1 229 1 230 1 231 1 232 1 233 1 234 1 235 1 236 1 238 2 30 1 222 1 237 1 240 1 241 1 246 4 35 4 43 4 48 4 50 4 208 4 229 4 232 4 230 4 234 4 226 4 231 4 216 4 57 4 37 4 44 4 49 4 58 4 236 4 239 4 242 4 244 4 246 4 248 4 250 4 254 5 0 5 2 5 6 5 8 5 10 5 13 5 4 5 15 5 17 5 19 5 30 5 31 5 32 5 33 5 35 5 37 5 39 5 40 2 166 2 168 2 108 2 162 2 109 2 110 2 111 2 114 2 116 2 154 2 101 2 102 2 103 2 104 2 105 2 106 2 107 2 112 2 115 2 145 2 146 2 147 2 148 2 155 2 117 2 118 2 119 2 120 2 121 2 122 2 123 2 124 2 125 2 126 2 127 2 128 2 129 2 130 2 131 2 132 2 133 2 141 2 134 2 135 2 136 2 137 2 138 2 139 2 140 2 149 2 152 2 150 2 151 2 153 2 244 3 63 2 245 3 64 2 246 3 65 2 247 3 66 2 248 3 67 2 249 3 68 2 250 3 69 2 251 3 70 2 252 3 71 2 253 3 72 2 254 3 73 2 255 3 74 3 0 3 75 3 1 3 76 3 2 3 77 3 3 3 78 3 4 3 5 3 79 3 80 3 6 3 81 3 7 3 82 3 8 3 83 3 9 3 84 3 10 3 85 3 11 3 86 3 12 3 87 3 13 3 88 3 14 3 89 4 27 4 29 4 30 4 36 4 38 4 41 4 45 4 46 0 83 1 32 0 90 1 39 0 91 1 40 0 92 1 41 0 112 1 60 0 119 1 67 0 124 1 71 0 123 1 70 0 125 1 73 0 126 1 74 0 142 1 90 0 143 1 91 0 147 1 96 0 148 1 97 0 149 1 98 0 152 1 101 0 153 1 102 0 154 1 103 0 160 1 109 0 161 1 110 0 162 1 111 0 186 1 130 0 192 1 143 0 194 1 144 0 195 1 145 0 196 1 146 0 203 1 153 0 204 1 154 0 209 1 160 0 210 1 161 0 235 1 187 0 236 1 188 0 237 1 189 0 239 1 191 0 244 1 196 0 251 1 203 0 252 1 204 0 253 1 205 1 72 1 162 0 67 1 16 0 68 1 17 0 69 1 18 0 70 1 19 0 71 1 20 0 72 1 21 0 73 1 22 0 74 1 23 0 75 1 24 0 76 1 25 0 77 1 26 0 78 1 27 0 104 1 52 0 105 1 53 0 106 1 54 0 107 1 55 0 108 1 56 0 109 1 57 0 110 1 58 0 111 1 59 0 137 1 84 0 138 1 85 0 173 1 122 0 174 1 123 0 175 1 124 0 176 1 125 0 177 1 126 0 178 1 127 0 179 1 128 0 181 1 132 0 182 1 133 0 183 1 134 0 184 1 135 0 185 1 136 0 227 1 179 0 228 1 180 0 230 1 182 0 231 1 183 0 232 1 184 0 233 1 185 0 234 1 186 0 240 1 192 0 245 1 197 0 246 1 198 0 247 1 199 2 171 2 170 2 172 2 182 2 185 2 176 2 178 2 180 2 177 2 179 2 181 2 183 2 184 2 174 2 175 2 173 3 157 3 155 3 156 3 158 3 193 3 175 3 141 3 142 3 145 3 147 3 143 3 144 3 146 3 189 3 190 3 160 6 4 4 93 3 194 3 198 3 176 3 177 3 195 3 197 3 196 3 223 4 34 3 233 3 234 4 39 4 88 4 74 4 78 4 70 4 86 4 83 4 84 3 95 3 211 4 105 4 110 4 111 4 154 4 155 4 156 4 157 4 166 4 167 4 139 4 147 4 149 4 114 4 117 4 143 4 133 4 132 4 126 4 119 3 200 3 201 3 202 3 203 4 141 4 142 5 100 5 101 5 102 5 103 5 104 5 105 5 106 5 107 5 108 5 109 5 110 5 111 5 112 5 113 5 114 5 115 5 116 5 117 5 118 5 119 5 120 5 121 5 122 5 123 5 124 5 125 5 126 5 127 5 128 5 129 5 130 5 131 5 132 5 133 5 134 5 135 5 136 5 137 5 138 5 139 5 140 5 141 5 142 5 143 5 144 5 145 5 146 5 147 5 148 5 149 5 150 5 151 5 152 5 153 5 154 5 155 5 156 5 157 5 158 5 159 5 160 5 161 5 162 5 163 5 164 5 165 5 166 5 167 5 168 5 169 5 170 5 171 5 172 5 173 5 174 5 175 5 176 5 177 5 178 5 179 5 180 5 181 5 182 5 183 5 184 5 185 5 186 5 187 5 188 5 189 5 190 5 191 5 192 5 193 5 194 5 195 5 196 5 197 5 198 5 199 5 200 5 201 5 202 5 203 5 204 5 205 5 206 5 207 5 208 5 209 5 210 5 211 5 212 5 213 5 214 5 215 5 216 5 217 5 218 5 219 5 220 5 221 5 222 5 223 5 224 5 225 5 226 5 227 5 228 5 229 5 230 5 231 5 232 5 233 5 234 5 235 5 236 5 237 5 238 5 239 5 240 5 241 5 242 5 243 5 244 5 245 5 246 5 247 5 248 5 249 5 250 5 251 5 252 5 253 5 254 5 255 6 0 6 1 6 2 6 3 4 171 4 172 3 162 3 163 3 173 4 175 4 176 3 164 3 165 4 177 4 178 3 166 3 167 4 183 4 179 4 180 3 168 3 169 4 181 4 182 3 170 3 171 4 184 4 186 4 206 4 170 4 235 3 172 4 185 4 196 4 197 4 205 4 192 4 194 6 8 6 9 6 10 6 11 6 12 6 13 6 14 6 6 6 7 6 5 0 12 0 0 0 0 36 88 0 0 0 0 0 0 3 6 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 13 0 0 0 13 0 0 0 2 0 0 0 32 0 0 0 32 0 0 0 3 0 0 0 33 0 0 0 33 0 0 3 135 0 0 0 34 0 0 0 34 0 0 3 140 0 0 0 35 0 0 0 35 0 0 3 217 0 0 0 36 0 0 0 36 0 0 4 67 0 0 0 37 0 0 0 37 0 0 4 92 0 0 0 38 0 0 0 38 0 0 3 96 0 0 0 39 0 0 0 39 0 0 3 139 0 0 0 40 0 0 0 41 0 0 3 178 0 0 0 42 0 0 0 42 0 0 3 188 0 0 0 43 0 0 0 43 0 0 4 113 0 0 0 44 0 0 0 44 0 0 3 131 0 0 0 45 0 0 0 45 0 0 3 152 0 0 0 46 0 0 0 46 0 0 3 130 0 0 0 47 0 0 0 47 0 0 3 184 0 0 0 48 0 0 0 57 0 0 3 97 0 0 0 58 0 0 0 59 0 0 3 132 0 0 0 60 0 0 0 60 0 0 4 120 0 0 0 61 0 0 0 61 0 0 4 118 0 0 0 62 0 0 0 62 0 0 4 121 0 0 0 63 0 0 0 63 0 0 3 137 0 0 0 64 0 0 0 64 0 0 3 215 0 0 0 65 0 0 0 90 0 0 0 4 0 0 0 91 0 0 0 91 0 0 3 180 0 0 0 92 0 0 0 92 0 0 3 186 0 0 0 93 0 0 0 93 0 0 3 181 0 0 0 94 0 0 0 94 0 0 4 125 0 0 0 95 0 0 0 95 0 0 3 174 0 0 0 96 0 0 0 96 0 0 4 217 0 0 0 97 0 0 0 122 0 0 0 30 0 0 0 123 0 0 0 123 0 0 3 182 0 0 0 124 0 0 0 124 0 0 3 185 0 0 0 125 0 0 0 125 0 0 3 183 0 0 0 126 0 0 0 126 0 0 4 127 0 0 0 160 0 0 0 160 0 0 5 96 0 0 0 161 0 0 0 161 0 0 3 136 0 0 0 162 0 0 0 162 0 0 4 71 0 0 0 163 0 0 0 163 0 0 4 68 0 0 0 164 0 0 0 164 0 0 4 66 0 0 0 165 0 0 0 165 0 0 4 69 0 0 0 166 0 0 0 166 0 0 3 187 0 0 0 167 0 0 0 167 0 0 3 191 0 0 0 168 0 0 0 168 0 0 4 227 0 0 0 169 0 0 0 169 0 0 3 210 0 0 0 170 0 0 0 170 0 0 4 23 0 0 0 171 0 0 0 171 0 0 3 150 0 0 0 172 0 0 0 172 0 0 4 129 0 0 0 173 0 0 0 173 0 0 3 153 0 0 0 174 0 0 0 174 0 0 3 212 0 0 0 175 0 0 0 175 0 0 4 228 0 0 0 176 0 0 0 176 0 0 4 134 0 0 0 177 0 0 0 177 0 0 4 124 0 0 0 178 0 0 0 179 0 0 3 225 0 0 0 180 0 0 0 180 0 0 4 218 0 0 0 181 0 0 0 181 0 0 4 138 0 0 0 182 0 0 0 182 0 0 3 192 0 0 0 183 0 0 0 183 0 0 3 159 0 0 0 184 0 0 0 184 0 0 4 233 0 0 0 185 0 0 0 185 0 0 3 224 0 0 0 186 0 0 0 186 0 0 4 25 0 0 0 187 0 0 0 187 0 0 3 151 0 0 0 188 0 0 0 190 0 0 4 94 0 0 0 191 0 0 0 191 0 0 3 138 0 0 0 192 0 0 0 196 0 0 0 56 0 0 0 197 0 0 0 197 0 0 0 63 0 0 0 198 0 0 0 198 0 0 0 79 0 0 0 199 0 0 0 199 0 0 0 84 0 0 0 200 0 0 0 202 0 0 0 95 0 0 0 203 0 0 0 203 0 0 0 99 0 0 0 204 0 0 0 206 0 0 0 128 0 0 0 207 0 0 0 207 0 0 0 132 0 0 0 208 0 0 0 208 0 0 0 254 0 0 0 209 0 0 0 209 0 0 0 158 0 0 0 210 0 0 0 214 0 0 0 163 0 0 0 215 0 0 0 215 0 0 4 115 0 0 0 216 0 0 0 216 0 0 0 187 0 0 0 217 0 0 0 219 0 0 0 212 0 0 0 220 0 0 0 220 0 0 0 216 0 0 0 221 0 0 0 221 0 0 0 241 0 0 0 222 0 0 0 222 0 0 0 255 0 0 0 223 0 0 0 223 0 0 1 155 0 0 0 224 0 0 0 228 0 0 1 5 0 0 0 229 0 0 0 229 0 0 1 12 0 0 0 230 0 0 0 230 0 0 1 28 0 0 0 231 0 0 0 231 0 0 1 33 0 0 0 232 0 0 0 234 0 0 1 43 0 0 0 235 0 0 0 235 0 0 1 47 0 0 0 236 0 0 0 238 0 0 1 76 0 0 0 239 0 0 0 239 0 0 1 80 0 0 0 240 0 0 0 240 0 0 1 206 0 0 0 241 0 0 0 241 0 0 1 107 0 0 0 242 0 0 0 246 0 0 1 113 0 0 0 247 0 0 0 247 0 0 4 116 0 0 0 248 0 0 0 248 0 0 1 137 0 0 0 249 0 0 0 251 0 0 1 164 0 0 0 252 0 0 0 252 0 0 1 168 0 0 0 253 0 0 0 253 0 0 1 193 0 0 0 254 0 0 0 254 0 0 1 207 0 0 0 255 0 0 0 255 0 0 1 195 0 0 1 0 0 0 1 0 0 0 0 61 0 0 1 1 0 0 1 1 0 0 1 10 0 0 1 2 0 0 1 2 0 0 0 62 0 0 1 3 0 0 1 3 0 0 1 11 0 0 1 4 0 0 1 4 0 0 0 66 0 0 1 5 0 0 1 5 0 0 1 15 0 0 1 6 0 0 1 6 0 0 0 85 0 0 1 7 0 0 1 7 0 0 1 34 0 0 1 8 0 0 1 8 0 0 0 86 0 0 1 9 0 0 1 9 0 0 1 35 0 0 1 10 0 0 1 10 0 0 0 88 0 0 1 11 0 0 1 11 0 0 1 37 0 0 1 12 0 0 1 12 0 0 0 87 0 0 1 13 0 0 1 13 0 0 1 36 0 0 1 14 0 0 1 14 0 0 0 89 0 0 1 15 0 0 1 15 0 0 1 38 0 0 1 16 0 0 1 16 0 0 0 93 0 0 1 17 0 0 1 17 0 0 1 42 0 0 1 18 0 0 1 18 0 0 0 100 0 0 1 19 0 0 1 19 0 0 1 48 0 0 1 20 0 0 1 20 0 0 0 101 0 0 1 21 0 0 1 21 0 0 1 49 0 0 1 22 0 0 1 22 0 0 0 102 0 0 1 23 0 0 1 23 0 0 1 51 0 0 1 24 0 0 1 24 0 0 0 103 0 0 1 25 0 0 1 25 0 0 1 50 0 0 1 26 0 0 1 26 0 0 0 98 0 0 1 27 0 0 1 27 0 0 1 46 0 0 1 28 0 0 1 28 0 0 0 114 0 0 1 29 0 0 1 29 0 0 1 62 0 0 1 30 0 0 1 30 0 0 0 115 0 0 1 31 0 0 1 31 0 0 1 63 0 0 1 32 0 0 1 32 0 0 0 116 0 0 1 33 0 0 1 33 0 0 1 64 0 0 1 34 0 0 1 34 0 0 0 117 0 0 1 35 0 0 1 35 0 0 1 65 0 0 1 36 0 0 1 36 0 0 0 122 0 0 1 37 0 0 1 37 0 0 1 69 0 0 1 38 0 0 1 38 0 0 0 127 0 0 1 39 0 0 1 39 0 0 1 75 0 0 1 40 0 0 1 40 0 0 0 131 0 0 1 41 0 0 1 41 0 0 1 79 0 0 1 42 0 0 1 42 0 0 0 133 0 0 1 43 0 0 1 43 0 0 1 81 0 0 1 44 0 0 1 44 0 0 0 139 0 0 1 45 0 0 1 45 0 0 1 86 0 0 1 46 0 0 1 46 0 0 0 136 0 0 1 47 0 0 1 47 0 0 1 83 0 0 1 48 0 0 1 48 0 0 0 134 0 0 1 49 0 0 1 49 0 0 1 87 0 0 1 50 0 0 1 50 0 0 1 2 0 0 1 51 0 0 1 51 0 0 1 210 0 0 1 52 0 0 1 52 0 0 0 140 0 0 1 53 0 0 1 53 0 0 1 88 0 0 1 54 0 0 1 54 0 0 0 141 0 0 1 55 0 0 1 55 0 0 1 89 0 0 1 56 0 0 1 56 0 0 1 92 0 0 1 57 0 0 1 57 0 0 0 144 0 0 1 58 0 0 1 58 0 0 1 93 0 0 1 59 0 0 1 59 0 0 0 146 0 0 1 60 0 0 1 60 0 0 1 95 0 0 1 61 0 0 1 61 0 0 0 145 0 0 1 62 0 0 1 62 0 0 1 94 0 0 1 63 0 0 1 63 0 0 0 151 0 0 1 64 0 0 1 64 0 0 1 100 0 0 1 65 0 0 1 65 0 0 0 150 0 0 1 66 0 0 1 66 0 0 1 99 0 0 1 67 0 0 1 67 0 0 0 155 0 0 1 68 0 0 1 68 0 0 1 104 0 0 1 69 0 0 1 69 0 0 0 159 0 0 1 70 0 0 1 70 0 0 1 108 0 0 1 71 0 0 1 71 0 0 0 157 0 0 1 72 0 0 1 72 0 0 1 106 0 0 1 73 0 0 1 73 0 0 1 112 0 0 1 74 0 0 1 74 0 0 1 1 0 0 1 75 0 0 1 75 0 0 1 208 0 0 1 76 0 0 1 76 0 0 0 168 0 0 1 77 0 0 1 77 0 0 1 118 0 0 1 78 0 0 1 78 0 0 0 170 0 0 1 79 0 0 1 79 0 0 1 129 0 0 1 80 0 0 1 80 0 0 0 169 0 0 1 81 0 0 1 81 0 0 1 119 0 0 1 82 0 0 1 82 0 0 0 189 0 0 1 83 0 0 1 83 0 0 1 139 0 0 1 84 0 0 1 84 0 0 0 190 0 0 1 85 0 0 1 85 0 0 1 140 0 0 1 86 0 0 1 86 0 0 0 193 0 0 1 87 0 0 1 87 0 0 1 141 0 0 1 88 0 0 1 88 0 0 0 191 0 0 1 89 0 0 1 89 0 0 1 142 0 0 1 90 0 0 1 90 0 0 0 197 0 0 1 91 0 0 1 91 0 0 1 147 0 0 1 92 0 0 1 92 0 0 0 198 0 0 1 93 0 0 1 93 0 0 1 148 0 0 1 94 0 0 1 94 0 0 0 201 0 0 1 95 0 0 1 95 0 0 1 151 0 0 1 96 0 0 1 96 0 0 0 199 0 0 1 97 0 0 1 97 0 0 1 149 0 0 1 98 0 0 1 98 0 0 0 207 0 0 1 99 0 0 1 99 0 0 1 158 0 0 1 100 0 0 1 100 0 0 0 206 0 0 1 101 0 0 1 101 0 0 1 157 0 0 1 102 0 0 1 102 0 0 0 211 0 0 1 103 0 0 1 103 0 0 1 163 0 0 1 104 0 0 1 104 0 0 0 215 0 0 1 105 0 0 1 105 0 0 1 167 0 0 1 106 0 0 1 106 0 0 0 217 0 0 1 107 0 0 1 107 0 0 1 169 0 0 1 108 0 0 1 108 0 0 0 218 0 0 1 109 0 0 1 109 0 0 1 170 0 0 1 110 0 0 1 110 0 0 0 219 0 0 1 111 0 0 1 111 0 0 1 171 0 0 1 112 0 0 1 112 0 0 0 220 0 0 1 113 0 0 1 113 0 0 1 172 0 0 1 114 0 0 1 114 0 0 0 222 0 0 1 115 0 0 1 115 0 0 1 174 0 0 1 116 0 0 1 116 0 0 0 238 0 0 1 117 0 0 1 117 0 0 1 190 0 0 1 118 0 0 1 118 0 0 0 242 0 0 1 119 0 0 1 119 0 0 1 194 0 0 1 120 0 0 1 120 0 0 0 243 0 0 1 121 0 0 1 121 0 0 0 248 0 0 1 122 0 0 1 122 0 0 1 200 0 0 1 123 0 0 1 123 0 0 0 250 0 0 1 124 0 0 1 124 0 0 1 202 0 0 1 125 0 0 1 125 0 0 0 249 0 0 1 126 0 0 1 126 0 0 1 201 0 0 1 127 0 0 1 127 0 0 1 156 0 0 1 128 0 0 1 128 0 0 1 31 0 0 1 138 0 0 1 138 0 0 0 94 0 0 1 143 0 0 1 143 0 0 1 0 0 0 1 146 0 0 1 146 0 0 4 72 0 0 1 147 0 0 1 147 0 0 0 121 0 0 1 160 0 0 1 160 0 0 0 180 0 0 1 161 0 0 1 161 0 0 1 131 0 0 1 175 0 0 1 175 0 0 0 229 0 0 1 176 0 0 1 176 0 0 1 181 0 0 1 194 0 0 1 194 0 0 2 29 0 0 1 205 0 0 1 205 0 0 0 65 0 0 1 206 0 0 1 206 0 0 1 14 0 0 1 207 0 0 1 207 0 0 0 135 0 0 1 208 0 0 1 208 0 0 1 82 0 0 1 209 0 0 1 209 0 0 0 171 0 0 1 210 0 0 1 210 0 0 1 120 0 0 1 211 0 0 1 211 0 0 0 221 0 0 1 212 0 0 1 212 0 0 1 173 0 0 1 213 0 0 1 213 0 0 0 223 0 0 1 214 0 0 1 214 0 0 1 175 0 0 1 215 0 0 1 215 0 0 0 224 0 0 1 216 0 0 1 216 0 0 1 176 0 0 1 217 0 0 1 217 0 0 0 225 0 0 1 218 0 0 1 218 0 0 1 177 0 0 1 219 0 0 1 219 0 0 0 226 0 0 1 220 0 0 1 220 0 0 1 178 0 0 1 226 0 0 1 226 0 0 0 81 0 0 1 227 0 0 1 227 0 0 1 30 0 0 1 230 0 0 1 230 0 0 0 118 0 0 1 231 0 0 1 231 0 0 1 66 0 0 1 234 0 0 1 234 0 0 0 172 0 0 1 235 0 0 1 235 0 0 1 121 0 0 1 244 0 0 1 244 0 0 0 113 0 0 1 245 0 0 1 245 0 0 1 61 0 0 1 248 0 0 1 248 0 0 0 156 0 0 1 249 0 0 1 249 0 0 1 105 0 0 1 250 0 0 1 250 0 0 0 64 0 0 1 251 0 0 1 251 0 0 1 13 0 0 1 252 0 0 1 252 0 0 0 80 0 0 1 253 0 0 1 253 0 0 1 29 0 0 1 254 0 0 1 254 0 0 0 188 0 0 1 255 0 0 1 255 0 0 1 138 0 0 2 24 0 0 2 24 0 0 0 202 0 0 2 25 0 0 2 25 0 0 1 152 0 0 2 26 0 0 2 26 0 0 0 208 0 0 2 27 0 0 2 27 0 0 1 159 0 0 2 55 0 0 2 55 0 0 1 209 0 0 2 67 0 0 2 67 0 0 0 82 0 0 2 80 0 0 2 80 0 0 1 213 0 0 2 81 0 0 2 81 0 0 1 221 0 0 2 82 0 0 2 88 0 0 1 214 0 0 2 89 0 0 2 92 0 0 1 223 0 0 2 94 0 0 2 103 0 0 1 227 0 0 2 104 0 0 2 104 0 0 1 238 0 0 2 106 0 0 2 106 0 0 1 239 0 0 2 107 0 0 2 110 0 0 1 242 0 0 2 111 0 0 2 118 0 0 1 247 0 0 2 120 0 0 2 123 0 0 1 255 0 0 2 125 0 0 2 126 0 0 2 3 0 0 2 128 0 0 2 132 0 0 2 5 0 0 2 135 0 0 2 146 0 0 2 10 0 0 2 148 0 0 2 149 0 0 2 25 0 0 2 152 0 0 2 152 0 0 2 30 0 0 2 153 0 0 2 153 0 0 1 222 0 0 2 156 0 0 2 156 0 0 1 237 0 0 2 157 0 0 2 158 0 0 1 240 0 0 2 159 0 0 2 159 0 0 1 246 0 0 2 161 0 0 2 162 0 0 2 27 0 0 2 164 0 0 2 164 0 0 2 22 0 0 2 166 0 0 2 167 0 0 2 23 0 0 2 176 0 0 2 176 0 0 4 33 0 0 2 178 0 0 2 178 0 0 4 35 0 0 2 179 0 0 2 179 0 0 4 43 0 0 2 183 0 0 2 183 0 0 4 48 0 0 2 184 0 0 2 184 0 0 4 50 0 0 2 185 0 0 2 185 0 0 4 208 0 0 2 187 0 0 2 188 0 0 4 209 0 0 2 190 0 0 2 191 0 0 4 211 0 0 2 193 0 0 2 193 0 0 4 213 0 0 2 198 0 0 2 204 0 0 4 219 0 0 2 208 0 0 2 209 0 0 4 214 0 0 2 216 0 0 2 216 0 0 4 229 0 0 2 217 0 0 2 217 0 0 4 232 0 0 2 218 0 0 2 218 0 0 4 230 0 0 2 219 0 0 2 219 0 0 4 234 0 0 2 220 0 0 2 220 0 0 4 226 0 0 2 221 0 0 2 221 0 0 4 231 0 0 2 222 0 0 2 222 0 0 4 216 0 0 2 224 0 0 2 224 0 0 4 57 0 0 2 225 0 0 2 225 0 0 4 37 0 0 2 226 0 0 2 226 0 0 4 44 0 0 2 227 0 0 2 227 0 0 4 49 0 0 2 228 0 0 2 228 0 0 4 58 0 0 3 0 0 0 3 0 0 0 4 236 0 0 3 1 0 0 3 1 0 0 4 239 0 0 3 2 0 0 3 2 0 0 4 242 0 0 3 3 0 0 3 3 0 0 4 244 0 0 3 4 0 0 3 4 0 0 4 246 0 0 3 5 0 0 3 5 0 0 4 248 0 0 3 6 0 0 3 6 0 0 4 250 0 0 3 7 0 0 3 7 0 0 4 254 0 0 3 8 0 0 3 8 0 0 5 0 0 0 3 9 0 0 3 9 0 0 5 2 0 0 3 10 0 0 3 10 0 0 5 6 0 0 3 11 0 0 3 11 0 0 5 8 0 0 3 12 0 0 3 12 0 0 5 10 0 0 3 15 0 0 3 15 0 0 5 13 0 0 3 16 0 0 3 16 0 0 5 4 0 0 3 17 0 0 3 17 0 0 5 15 0 0 3 18 0 0 3 18 0 0 5 17 0 0 3 19 0 0 3 19 0 0 5 19 0 0 3 24 0 0 3 32 0 0 5 21 0 0 3 35 0 0 3 38 0 0 5 30 0 0 3 39 0 0 3 39 0 0 5 35 0 0 3 40 0 0 3 40 0 0 5 37 0 0 3 41 0 0 3 42 0 0 5 39 0 0 3 44 0 0 3 44 0 0 5 41 0 0 3 46 0 0 3 49 0 0 5 42 0 0 3 52 0 0 3 52 0 0 5 46 0 0 3 57 0 0 3 61 0 0 5 47 0 0 3 66 0 0 3 66 0 0 5 52 0 0 3 69 0 0 3 69 0 0 5 54 0 0 3 95 0 0 3 95 0 0 5 55 0 0 3 97 0 0 3 97 0 0 5 56 0 0 3 116 0 0 3 117 0 0 2 164 0 0 3 122 0 0 3 122 0 0 2 169 0 0 3 126 0 0 3 126 0 0 2 161 0 0 3 132 0 0 3 132 0 0 2 166 0 0 3 133 0 0 3 133 0 0 2 168 0 0 3 134 0 0 3 134 0 0 2 108 0 0 3 135 0 0 3 135 0 0 2 162 0 0 3 136 0 0 3 138 0 0 2 109 0 0 3 140 0 0 3 140 0 0 2 113 0 0 3 142 0 0 3 142 0 0 2 114 0 0 3 143 0 0 3 143 0 0 2 116 0 0 3 144 0 0 3 144 0 0 2 154 0 0 3 145 0 0 3 161 0 0 2 84 0 0 3 163 0 0 3 169 0 0 2 101 0 0 3 170 0 0 3 170 0 0 2 112 0 0 3 171 0 0 3 171 0 0 2 115 0 0 3 172 0 0 3 175 0 0 2 145 0 0 3 176 0 0 3 176 0 0 2 155 0 0 3 177 0 0 3 193 0 0 2 117 0 0 3 194 0 0 3 194 0 0 2 141 0 0 3 195 0 0 3 201 0 0 2 134 0 0 3 202 0 0 3 202 0 0 2 149 0 0 3 203 0 0 3 203 0 0 2 152 0 0 3 204 0 0 3 205 0 0 2 150 0 0 3 206 0 0 3 206 0 0 2 153 0 0 3 208 0 0 3 209 0 0 2 142 0 0 3 213 0 0 3 213 0 0 2 144 0 0 3 215 0 0 3 215 0 0 2 156 0 0 3 217 0 0 3 217 0 0 2 157 0 0 3 219 0 0 3 219 0 0 2 158 0 0 3 221 0 0 3 221 0 0 2 159 0 0 3 225 0 0 3 225 0 0 2 160 0 0 4 0 0 0 4 15 0 0 2 228 0 0 4 16 0 0 4 47 0 0 2 196 0 0 4 48 0 0 4 95 0 0 3 15 0 0 4 98 0 0 4 98 0 0 2 244 0 0 4 99 0 0 4 99 0 0 3 63 0 0 4 114 0 0 4 114 0 0 2 245 0 0 4 115 0 0 4 115 0 0 3 64 0 0 4 116 0 0 4 116 0 0 2 246 0 0 4 117 0 0 4 117 0 0 3 65 0 0 4 144 0 0 4 144 0 0 2 247 0 0 4 145 0 0 4 145 0 0 3 66 0 0 4 146 0 0 4 146 0 0 2 248 0 0 4 147 0 0 4 147 0 0 3 67 0 0 4 150 0 0 4 150 0 0 2 249 0 0 4 151 0 0 4 151 0 0 3 68 0 0 4 152 0 0 4 152 0 0 2 250 0 0 4 153 0 0 4 153 0 0 3 69 0 0 4 154 0 0 4 154 0 0 2 251 0 0 4 155 0 0 4 155 0 0 3 70 0 0 4 160 0 0 4 160 0 0 2 252 0 0 4 161 0 0 4 161 0 0 3 71 0 0 4 162 0 0 4 162 0 0 2 253 0 0 4 163 0 0 4 163 0 0 3 72 0 0 4 170 0 0 4 170 0 0 2 254 0 0 4 171 0 0 4 171 0 0 3 73 0 0 4 174 0 0 4 174 0 0 2 255 0 0 4 175 0 0 4 175 0 0 3 74 0 0 4 176 0 0 4 176 0 0 3 0 0 0 4 177 0 0 4 177 0 0 3 75 0 0 4 178 0 0 4 178 0 0 3 1 0 0 4 179 0 0 4 179 0 0 3 76 0 0 4 182 0 0 4 182 0 0 3 2 0 0 4 183 0 0 4 183 0 0 3 77 0 0 4 186 0 0 4 186 0 0 3 3 0 0 4 187 0 0 4 187 0 0 3 78 0 0 4 192 0 0 4 193 0 0 3 4 0 0 4 194 0 0 4 194 0 0 3 79 0 0 4 207 0 0 4 207 0 0 3 80 0 0 4 208 0 0 4 208 0 0 3 6 0 0 4 209 0 0 4 209 0 0 3 81 0 0 4 212 0 0 4 212 0 0 3 7 0 0 4 213 0 0 4 213 0 0 3 82 0 0 4 214 0 0 4 214 0 0 3 8 0 0 4 215 0 0 4 215 0 0 3 83 0 0 4 216 0 0 4 216 0 0 3 9 0 0 4 217 0 0 4 217 0 0 3 84 0 0 4 226 0 0 4 226 0 0 3 10 0 0 4 227 0 0 4 227 0 0 3 85 0 0 4 230 0 0 4 230 0 0 3 11 0 0 4 231 0 0 4 231 0 0 3 86 0 0 4 232 0 0 4 232 0 0 3 12 0 0 4 233 0 0 4 233 0 0 3 87 0 0 4 238 0 0 4 238 0 0 3 13 0 0 4 239 0 0 4 239 0 0 3 88 0 0 4 242 0 0 4 242 0 0 3 14 0 0 4 243 0 0 4 243 0 0 3 89 0 0 29 67 0 0 29 67 0 0 4 26 0 0 29 71 0 0 29 71 0 0 4 27 0 0 29 72 0 0 29 73 0 0 4 29 0 0 29 77 0 0 29 77 0 0 4 32 0 0 29 79 0 0 29 79 0 0 4 36 0 0 29 80 0 0 29 80 0 0 4 38 0 0 29 82 0 0 29 82 0 0 4 40 0 0 29 86 0 0 29 86 0 0 4 41 0 0 29 87 0 0 29 88 0 0 4 45 0 0 29 91 0 0 29 91 0 0 4 47 0 0 29 156 0 0 29 156 0 0 4 28 0 0 29 160 0 0 29 160 0 0 4 31 0 0 29 187 0 0 29 187 0 0 4 51 0 0 30 6 0 0 30 6 0 0 0 83 0 0 30 7 0 0 30 7 0 0 1 32 0 0 30 12 0 0 30 12 0 0 0 90 0 0 30 13 0 0 30 13 0 0 1 39 0 0 30 14 0 0 30 14 0 0 0 91 0 0 30 15 0 0 30 15 0 0 1 40 0 0 30 16 0 0 30 16 0 0 0 92 0 0 30 17 0 0 30 17 0 0 1 41 0 0 30 22 0 0 30 22 0 0 0 112 0 0 30 23 0 0 30 23 0 0 1 60 0 0 30 32 0 0 30 32 0 0 0 119 0 0 30 33 0 0 30 33 0 0 1 67 0 0 30 36 0 0 30 36 0 0 0 124 0 0 30 37 0 0 30 37 0 0 1 71 0 0 30 38 0 0 30 38 0 0 0 123 0 0 30 39 0 0 30 39 0 0 1 70 0 0 30 40 0 0 30 40 0 0 0 125 0 0 30 41 0 0 30 41 0 0 1 73 0 0 30 42 0 0 30 42 0 0 0 126 0 0 30 43 0 0 30 43 0 0 1 74 0 0 30 50 0 0 30 50 0 0 0 142 0 0 30 51 0 0 30 51 0 0 1 90 0 0 30 52 0 0 30 52 0 0 0 143 0 0 30 53 0 0 30 53 0 0 1 91 0 0 30 54 0 0 30 54 0 0 0 147 0 0 30 55 0 0 30 55 0 0 1 96 0 0 30 56 0 0 30 56 0 0 0 148 0 0 30 57 0 0 30 57 0 0 1 97 0 0 30 58 0 0 30 58 0 0 0 149 0 0 30 59 0 0 30 59 0 0 1 98 0 0 30 62 0 0 30 62 0 0 0 152 0 0 30 63 0 0 30 63 0 0 1 101 0 0 30 64 0 0 30 64 0 0 0 153 0 0 30 65 0 0 30 65 0 0 1 102 0 0 30 66 0 0 30 66 0 0 0 154 0 0 30 67 0 0 30 67 0 0 1 103 0 0 30 68 0 0 30 68 0 0 0 160 0 0 30 69 0 0 30 69 0 0 1 109 0 0 30 70 0 0 30 70 0 0 0 161 0 0 30 71 0 0 30 71 0 0 1 110 0 0 30 72 0 0 30 72 0 0 0 162 0 0 30 73 0 0 30 73 0 0 1 111 0 0 30 82 0 0 30 82 0 0 0 186 0 0 30 83 0 0 30 83 0 0 1 130 0 0 30 88 0 0 30 88 0 0 0 192 0 0 30 89 0 0 30 89 0 0 1 143 0 0 30 90 0 0 30 90 0 0 0 194 0 0 30 91 0 0 30 91 0 0 1 144 0 0 30 92 0 0 30 92 0 0 0 195 0 0 30 93 0 0 30 93 0 0 1 145 0 0 30 94 0 0 30 94 0 0 0 196 0 0 30 95 0 0 30 95 0 0 1 146 0 0 30 96 0 0 30 96 0 0 0 203 0 0 30 97 0 0 30 97 0 0 1 153 0 0 30 98 0 0 30 98 0 0 0 204 0 0 30 99 0 0 30 99 0 0 1 154 0 0 30 108 0 0 30 108 0 0 0 209 0 0 30 109 0 0 30 109 0 0 1 160 0 0 30 110 0 0 30 110 0 0 0 210 0 0 30 111 0 0 30 111 0 0 1 161 0 0 30 126 0 0 30 126 0 0 0 235 0 0 30 127 0 0 30 127 0 0 1 187 0 0 30 128 0 0 30 128 0 0 0 236 0 0 30 129 0 0 30 129 0 0 1 188 0 0 30 130 0 0 30 130 0 0 0 237 0 0 30 131 0 0 30 131 0 0 1 189 0 0 30 132 0 0 30 132 0 0 0 239 0 0 30 133 0 0 30 133 0 0 1 191 0 0 30 142 0 0 30 142 0 0 0 244 0 0 30 143 0 0 30 143 0 0 1 196 0 0 30 144 0 0 30 144 0 0 0 251 0 0 30 145 0 0 30 145 0 0 1 203 0 0 30 146 0 0 30 146 0 0 0 252 0 0 30 147 0 0 30 147 0 0 1 204 0 0 30 148 0 0 30 148 0 0 0 253 0 0 30 149 0 0 30 149 0 0 1 205 0 0 30 150 0 0 30 150 0 0 1 72 0 0 30 151 0 0 30 151 0 0 1 162 0 0 30 158 0 0 30 158 0 0 0 205 0 0 30 160 0 0 30 160 0 0 0 67 0 0 30 161 0 0 30 161 0 0 1 16 0 0 30 162 0 0 30 162 0 0 0 68 0 0 30 163 0 0 30 163 0 0 1 17 0 0 30 164 0 0 30 164 0 0 0 69 0 0 30 165 0 0 30 165 0 0 1 18 0 0 30 166 0 0 30 166 0 0 0 70 0 0 30 167 0 0 30 167 0 0 1 19 0 0 30 168 0 0 30 168 0 0 0 71 0 0 30 169 0 0 30 169 0 0 1 20 0 0 30 170 0 0 30 170 0 0 0 72 0 0 30 171 0 0 30 171 0 0 1 21 0 0 30 172 0 0 30 172 0 0 0 73 0 0 30 173 0 0 30 173 0 0 1 22 0 0 30 174 0 0 30 174 0 0 0 74 0 0 30 175 0 0 30 175 0 0 1 23 0 0 30 176 0 0 30 176 0 0 0 75 0 0 30 177 0 0 30 177 0 0 1 24 0 0 30 178 0 0 30 178 0 0 0 76 0 0 30 179 0 0 30 179 0 0 1 25 0 0 30 180 0 0 30 180 0 0 0 77 0 0 30 181 0 0 30 181 0 0 1 26 0 0 30 182 0 0 30 182 0 0 0 78 0 0 30 183 0 0 30 183 0 0 1 27 0 0 30 184 0 0 30 184 0 0 0 104 0 0 30 185 0 0 30 185 0 0 1 52 0 0 30 186 0 0 30 186 0 0 0 105 0 0 30 187 0 0 30 187 0 0 1 53 0 0 30 188 0 0 30 188 0 0 0 106 0 0 30 189 0 0 30 189 0 0 1 54 0 0 30 190 0 0 30 190 0 0 0 107 0 0 30 191 0 0 30 191 0 0 1 55 0 0 30 192 0 0 30 192 0 0 0 108 0 0 30 193 0 0 30 193 0 0 1 56 0 0 30 194 0 0 30 194 0 0 0 109 0 0 30 195 0 0 30 195 0 0 1 57 0 0 30 196 0 0 30 196 0 0 0 110 0 0 30 197 0 0 30 197 0 0 1 58 0 0 30 198 0 0 30 198 0 0 0 111 0 0 30 199 0 0 30 199 0 0 1 59 0 0 30 200 0 0 30 200 0 0 0 137 0 0 30 201 0 0 30 201 0 0 1 84 0 0 30 202 0 0 30 202 0 0 0 138 0 0 30 203 0 0 30 203 0 0 1 85 0 0 30 204 0 0 30 204 0 0 0 173 0 0 30 205 0 0 30 205 0 0 1 122 0 0 30 206 0 0 30 206 0 0 0 174 0 0 30 207 0 0 30 207 0 0 1 123 0 0 30 208 0 0 30 208 0 0 0 175 0 0 30 209 0 0 30 209 0 0 1 124 0 0 30 210 0 0 30 210 0 0 0 176 0 0 30 211 0 0 30 211 0 0 1 125 0 0 30 212 0 0 30 212 0 0 0 177 0 0 30 213 0 0 30 213 0 0 1 126 0 0 30 214 0 0 30 214 0 0 0 178 0 0 30 215 0 0 30 215 0 0 1 127 0 0 30 216 0 0 30 216 0 0 0 179 0 0 30 217 0 0 30 217 0 0 1 128 0 0 30 218 0 0 30 218 0 0 0 181 0 0 30 219 0 0 30 219 0 0 1 132 0 0 30 220 0 0 30 220 0 0 0 182 0 0 30 221 0 0 30 221 0 0 1 133 0 0 30 222 0 0 30 222 0 0 0 183 0 0 30 223 0 0 30 223 0 0 1 134 0 0 30 224 0 0 30 224 0 0 0 184 0 0 30 225 0 0 30 225 0 0 1 135 0 0 30 226 0 0 30 226 0 0 0 185 0 0 30 227 0 0 30 227 0 0 1 136 0 0 30 228 0 0 30 228 0 0 0 227 0 0 30 229 0 0 30 229 0 0 1 179 0 0 30 230 0 0 30 230 0 0 0 228 0 0 30 231 0 0 30 231 0 0 1 180 0 0 30 232 0 0 30 232 0 0 0 230 0 0 30 233 0 0 30 233 0 0 1 182 0 0 30 234 0 0 30 234 0 0 0 231 0 0 30 235 0 0 30 235 0 0 1 183 0 0 30 236 0 0 30 236 0 0 0 232 0 0 30 237 0 0 30 237 0 0 1 184 0 0 30 238 0 0 30 238 0 0 0 233 0 0 30 239 0 0 30 239 0 0 1 185 0 0 30 240 0 0 30 240 0 0 0 234 0 0 30 241 0 0 30 241 0 0 1 186 0 0 30 242 0 0 30 242 0 0 0 240 0 0 30 243 0 0 30 243 0 0 1 192 0 0 30 244 0 0 30 244 0 0 0 245 0 0 30 245 0 0 30 245 0 0 1 197 0 0 30 246 0 0 30 246 0 0 0 246 0 0 30 247 0 0 30 247 0 0 1 198 0 0 30 248 0 0 30 248 0 0 0 247 0 0 30 249 0 0 30 249 0 0 1 199 0 0 31 189 0 0 31 189 0 0 2 171 0 0 31 190 0 0 31 190 0 0 2 170 0 0 31 191 0 0 31 191 0 0 2 172 0 0 31 192 0 0 31 192 0 0 2 182 0 0 31 193 0 0 31 193 0 0 2 185 0 0 31 205 0 0 31 205 0 0 2 176 0 0 31 206 0 0 31 206 0 0 2 178 0 0 31 207 0 0 31 207 0 0 2 180 0 0 31 221 0 0 31 221 0 0 2 177 0 0 31 222 0 0 31 222 0 0 2 179 0 0 31 223 0 0 31 223 0 0 2 181 0 0 31 237 0 0 31 238 0 0 2 183 0 0 31 239 0 0 31 239 0 0 2 174 0 0 31 253 0 0 31 253 0 0 2 175 0 0 31 254 0 0 31 254 0 0 2 173 0 0 32 7 0 0 32 7 0 0 5 97 0 0 32 16 0 0 32 16 0 0 3 154 0 0 32 18 0 0 32 18 0 0 3 157 0 0 32 19 0 0 32 20 0 0 3 155 0 0 32 21 0 0 32 21 0 0 3 158 0 0 32 22 0 0 32 22 0 0 3 193 0 0 32 23 0 0 32 23 0 0 3 175 0 0 32 24 0 0 32 25 0 0 3 141 0 0 32 26 0 0 32 26 0 0 3 145 0 0 32 27 0 0 32 27 0 0 3 147 0 0 32 28 0 0 32 29 0 0 3 143 0 0 32 30 0 0 32 30 0 0 3 146 0 0 32 32 0 0 32 33 0 0 3 189 0 0 32 34 0 0 32 34 0 0 3 160 0 0 32 38 0 0 32 38 0 0 3 134 0 0 32 47 0 0 32 47 0 0 6 4 0 0 32 48 0 0 32 48 0 0 4 93 0 0 32 50 0 0 32 51 0 0 4 135 0 0 32 53 0 0 32 53 0 0 4 137 0 0 32 57 0 0 32 58 0 0 3 148 0 0 32 60 0 0 32 60 0 0 3 194 0 0 32 61 0 0 32 61 0 0 3 198 0 0 32 62 0 0 32 63 0 0 3 176 0 0 32 68 0 0 32 68 0 0 4 89 0 0 32 71 0 0 32 71 0 0 3 195 0 0 32 72 0 0 32 72 0 0 3 197 0 0 32 73 0 0 32 73 0 0 3 196 0 0 32 112 0 0 32 112 0 0 3 223 0 0 32 113 0 0 32 113 0 0 4 34 0 0 32 116 0 0 32 121 0 0 3 227 0 0 32 125 0 0 32 126 0 0 3 233 0 0 32 127 0 0 32 127 0 0 4 39 0 0 32 128 0 0 32 137 0 0 3 237 0 0 32 141 0 0 32 142 0 0 3 247 0 0 32 148 0 0 32 148 0 0 4 55 0 0 32 161 0 0 32 161 0 0 4 73 0 0 32 163 0 0 32 163 0 0 4 88 0 0 32 164 0 0 32 164 0 0 4 74 0 0 32 166 0 0 32 167 0 0 4 75 0 0 32 169 0 0 32 169 0 0 4 77 0 0 32 171 0 0 32 171 0 0 4 78 0 0 32 172 0 0 32 172 0 0 4 70 0 0 32 174 0 0 32 174 0 0 4 85 0 0 32 177 0 0 32 178 0 0 4 79 0 0 32 180 0 0 32 181 0 0 4 81 0 0 32 184 0 0 32 184 0 0 4 86 0 0 32 185 0 0 32 186 0 0 4 83 0 0 32 189 0 0 32 189 0 0 4 87 0 0 33 5 0 0 33 5 0 0 4 151 0 0 33 19 0 0 33 19 0 0 4 152 0 0 33 22 0 0 33 22 0 0 3 95 0 0 33 23 0 0 33 23 0 0 3 211 0 0 33 32 0 0 33 32 0 0 3 214 0 0 33 34 0 0 33 34 0 0 3 213 0 0 33 38 0 0 33 38 0 0 4 145 0 0 33 46 0 0 33 46 0 0 4 153 0 0 33 80 0 0 33 80 0 0 4 105 0 0 33 81 0 0 33 82 0 0 4 110 0 0 33 83 0 0 33 90 0 0 4 97 0 0 33 91 0 0 33 94 0 0 4 106 0 0 33 137 0 0 33 137 0 0 4 112 0 0 33 144 0 0 33 147 0 0 4 154 0 0 33 148 0 0 33 149 0 0 4 166 0 0 33 150 0 0 33 153 0 0 4 158 0 0 33 168 0 0 33 168 0 0 4 168 0 0 33 208 0 0 33 211 0 0 4 162 0 0 34 0 0 0 34 0 0 0 4 146 0 0 34 2 0 0 34 2 0 0 4 139 0 0 34 3 0 0 34 3 0 0 4 147 0 0 34 6 0 0 34 6 0 0 4 144 0 0 34 15 0 0 34 15 0 0 4 150 0 0 34 17 0 0 34 17 0 0 4 149 0 0 34 18 0 0 34 18 0 0 4 114 0 0 34 21 0 0 34 21 0 0 4 90 0 0 34 25 0 0 34 25 0 0 4 117 0 0 34 26 0 0 34 26 0 0 4 143 0 0 34 30 0 0 34 30 0 0 4 133 0 0 34 31 0 0 34 31 0 0 4 132 0 0 34 41 0 0 34 41 0 0 4 131 0 0 34 43 0 0 34 43 0 0 4 140 0 0 34 55 0 0 34 55 0 0 4 148 0 0 34 72 0 0 34 72 0 0 4 128 0 0 34 96 0 0 34 96 0 0 4 126 0 0 34 97 0 0 34 97 0 0 4 119 0 0 34 100 0 0 34 101 0 0 4 122 0 0 35 2 0 0 35 2 0 0 4 207 0 0 35 16 0 0 35 16 0 0 4 130 0 0 35 28 0 0 35 31 0 0 3 200 0 0 35 32 0 0 35 33 0 0 4 141 0 0 37 0 0 0 37 159 0 0 5 100 0 0 37 160 0 0 37 161 0 0 4 171 0 0 37 170 0 0 37 171 0 0 3 162 0 0 37 172 0 0 37 172 0 0 3 173 0 0 37 178 0 0 37 179 0 0 4 175 0 0 37 180 0 0 37 181 0 0 3 164 0 0 37 182 0 0 37 183 0 0 4 177 0 0 37 184 0 0 37 185 0 0 3 166 0 0 37 186 0 0 37 186 0 0 4 183 0 0 37 188 0 0 37 189 0 0 4 179 0 0 37 190 0 0 37 191 0 0 3 168 0 0 37 192 0 0 37 193 0 0 4 181 0 0 37 194 0 0 37 195 0 0 3 170 0 0 37 196 0 0 37 196 0 0 4 184 0 0 37 198 0 0 37 198 0 0 4 174 0 0 37 201 0 0 37 201 0 0 4 186 0 0 37 202 0 0 37 202 0 0 4 206 0 0 37 203 0 0 37 203 0 0 4 170 0 0 37 204 0 0 37 204 0 0 4 235 0 0 37 207 0 0 37 207 0 0 4 169 0 0 37 216 0 0 37 216 0 0 3 172 0 0 37 217 0 0 37 217 0 0 4 185 0 0 37 230 0 0 37 230 0 0 3 161 0 0 38 16 0 0 38 17 0 0 4 187 0 0 38 21 0 0 38 21 0 0 4 199 0 0 38 58 0 0 38 59 0 0 4 196 0 0 38 60 0 0 38 60 0 0 4 205 0 0 38 64 0 0 38 64 0 0 4 203 0 0 38 66 0 0 38 66 0 0 4 204 0 0 38 96 0 0 38 96 0 0 4 195 0 0 38 99 0 0 38 99 0 0 4 193 0 0 38 101 0 0 38 101 0 0 4 192 0 0 38 102 0 0 38 102 0 0 4 194 0 0 38 106 0 0 38 107 0 0 4 190 0 0 39 19 0 0 39 19 0 0 4 189 0 0 39 82 0 0 39 82 0 0 4 173 0 0 39 100 0 0 39 100 0 0 4 198 0 0 39 230 0 0 39 231 0 0 3 204 0 0 46 24 0 0 46 24 0 0 3 199 0 0 46 34 0 0 46 37 0 0 3 206 0 0 224 160 0 0 224 162 0 0 6 8 0 0 224 176 0 0 224 179 0 0 6 11 0 0 251 1 0 0 251 2 0 0 6 6 0 0 254 255 0 0 254 255 0 0 6 5 0 1 244 169 0 1 244 169 0 0 4 200 0 1 245 18 0 1 245 18 0 0 4 202 0 1 249 22 0 1 249 22 0 0 4 201 184 0 0 44 75 184 0 9 80 88 177 1 1 142 89 184 1 255 133 184 0 68 29 185 0 9 0 3 95 94 45 184 0 1 44 32 32 69 105 68 176 1 96 45 184 0 2 44 184 0 1 42 33 45 184 0 3 44 32 70 176 3 37 70 82 88 35 89 32 138 32 138 73 100 138 32 70 32 104 97 100 176 4 37 70 32 104 97 100 82 88 35 101 138 89 47 32 176 0 83 88 105 32 176 0 84 88 33 176 64 89 27 105 32 176 0 84 88 33 176 64 101 89 89 58 45 184 0 4 44 32 70 176 4 37 70 82 88 35 138 89 32 70 32 106 97 100 176 4 37 70 32 106 97 100 82 88 35 138 89 47 253 45 184 0 5 44 75 32 176 3 38 80 88 81 88 176 128 68 27 176 64 68 89 27 33 33 32 69 176 192 80 88 176 192 68 27 33 89 89 45 184 0 6 44 32 32 69 105 68 176 1 96 32 32 69 125 105 24 68 176 1 96 45 184 0 7 44 184 0 6 42 45 184 0 8 44 75 32 176 3 38 83 88 176 64 27 176 0 89 138 138 32 176 3 38 83 88 35 33 176 128 138 138 27 138 35 89 32 176 3 38 83 88 35 33 184 0 192 138 138 27 138 35 89 32 176 3 38 83 88 35 33 184 1 0 138 138 27 138 35 89 32 176 3 38 83 88 35 33 184 1 64 138 138 27 138 35 89 32 184 0 3 38 83 88 176 3 37 69 184 1 128 80 88 35 33 184 1 128 35 33 27 176 3 37 69 35 33 35 33 89 27 33 89 68 45 184 0 9 44 75 83 88 69 68 27 33 33 89 45 0 176 0 43 0 178 1 1 2 43 1 178 2 1 2 43 1 183 2 64 54 42 33 20 0 8 43 0 183 1 77 64 50 36 23 0 8 43 0 178 3 7 7 43 176 0 32 69 125 105 24 68 75 184 0 96 82 88 176 1 27 176 0 89 176 1 142 0 0 0 20 0 68 0 86 0 0 0 12 255 51 0 12 1 230 0 12 2 62 0 12 2 126 0 12 2 144 0 12 2 200 0 12 0 0 0 0 0 74 0 74 0 74 0 74 0 148 0 248 1 72 1 128 1 190 1 244 2 84 2 144 2 198 3 4 3 72 3 108 3 202 4 18 4 102 4 172 5 20 5 102 5 214 6 2 6 68 6 128 6 240 7 76 7 134 7 186 8 50 8 172 8 252 9 114 9 214 10 38 10 218 11 44 11 56 11 68 11 138 11 196 12 52 12 140 12 224 13 90 13 210 14 28 14 132 14 214 15 34 15 90 15 190 16 24 16 108 16 160 16 172 16 184 16 196 16 208 16 220 16 232 16 244 17 0 17 72 17 84 17 194 17 206 17 218 17 230 17 242 17 254 18 10 18 26 18 38 18 50 18 62 18 74 18 90 18 188 18 200 18 212 19 68 19 80 19 92 19 104 19 116 19 128 19 140 19 152 19 164 19 176 19 188 19 196 20 18 20 30 20 42 20 54 20 66 20 78 20 90 20 102 20 114 20 214 20 226 20 238 20 250 21 6 21 18 21 30 21 42 21 58 21 70 21 82 21 94 21 106 21 118 21 130 21 142 21 154 21 166 22 32 22 44 22 56 22 68 22 80 22 92 22 186 22 198 22 210 22 222 22 234 22 246 23 2 23 14 23 26 23 118 23 130 23 142 23 154 23 166 23 178 23 190 23 202 23 214 23 226 23 238 23 250 24 10 24 22 24 70 24 82 24 94 24 106 24 118 24 130 24 142 24 154 24 166 24 178 24 190 24 202 24 214 24 226 24 238 24 250 25 6 25 18 25 30 25 42 25 54 25 66 25 180 25 192 25 204 25 216 25 228 25 240 25 252 26 12 26 124 26 136 26 148 26 160 26 172 26 184 26 196 27 82 27 94 27 180 27 192 27 204 27 216 27 228 27 240 28 0 28 12 28 24 28 36 28 48 28 60 28 72 28 84 28 96 28 108 28 222 28 234 28 246 29 2 29 14 29 26 29 96 29 108 29 120 29 132 29 144 29 156 29 168 29 180 29 192 29 204 29 216 30 60 30 72 30 84 30 96 30 108 30 120 30 132 30 222 30 234 30 246 31 2 31 14 31 26 31 38 31 50 31 62 31 74 31 86 31 98 31 110 31 122 31 134 31 146 31 158 31 170 31 182 31 194 31 206 31 218 31 230 31 242 31 254 32 82 32 148 32 242 33 86 33 148 33 228 33 244 34 0 34 12 34 24 34 36 34 48 34 60 34 72 34 84 34 190 34 202 35 98 35 110 35 122 35 134 35 146 35 158 35 170 35 186 35 198 35 210 35 222 35 234 35 250 36 168 36 180 36 192 37 72 37 84 37 96 37 108 37 120 37 132 37 144 38 20 38 32 38 44 38 56 38 182 38 194 38 206 38 218 38 230 38 242 38 254 39 10 39 142 39 154 39 166 39 178 39 190 39 202 39 214 39 226 39 238 39 254 40 10 40 22 40 34 40 46 40 58 40 70 40 82 40 94 40 106 40 118 40 130 40 142 40 154 40 166 40 178 41 12 41 24 41 36 41 48 41 60 41 72 41 84 41 96 41 108 41 120 41 136 41 148 41 188 41 200 41 212 41 224 41 236 42 48 42 60 42 72 42 84 42 96 42 112 42 124 42 192 42 204 42 216 42 228 42 240 42 252 43 8 43 20 43 32 43 44 43 56 43 68 43 80 43 186 43 198 43 210 43 222 43 234 43 246 44 2 44 14 44 26 44 148 44 160 44 172 44 184 44 196 44 208 44 220 44 236 44 248 45 4 45 120 45 132 45 144 45 156 45 168 45 180 46 66 46 78 46 224 46 236 46 248 47 4 47 16 47 28 47 44 47 56 47 68 47 80 47 92 47 104 47 116 47 128 47 140 47 152 48 18 48 86 48 98 48 110 48 122 48 134 48 146 48 158 49 4 49 16 49 28 49 40 49 52 49 64 49 76 49 88 49 100 49 112 49 124 49 236 49 248 50 4 50 16 50 28 50 40 50 52 50 158 50 170 50 182 50 194 50 206 50 218 50 230 50 242 50 254 51 10 51 22 51 34 51 46 51 58 51 70 51 82 51 94 51 106 51 118 51 130 51 142 51 154 51 166 51 178 51 190 52 58 52 180 53 28 53 90 53 206 54 70 54 168 55 38 55 154 56 40 56 118 57 2 57 144 58 26 58 124 58 240 58 248 59 90 59 238 60 90 60 98 60 210 61 40 61 190 62 70 62 158 63 16 63 134 63 218 64 68 64 196 64 204 64 216 65 14 65 26 65 98 65 110 65 218 66 22 66 138 66 174 67 32 67 150 68 32 68 136 68 240 69 60 69 154 70 18 70 140 70 212 71 26 71 122 71 220 72 18 72 98 72 180 73 62 73 138 73 230 74 50 74 134 74 236 75 84 75 172 75 228 76 74 76 160 76 218 77 50 77 154 78 2 78 198 79 70 79 210 80 22 80 92 80 178 81 8 81 86 81 196 82 34 82 42 82 54 82 66 82 78 82 90 82 102 82 114 82 126 82 138 82 230 82 242 82 254 83 10 83 22 83 34 83 46 83 58 83 74 83 86 83 98 83 110 83 122 83 138 84 32 84 40 84 52 84 64 84 76 84 88 84 100 84 112 84 124 84 136 84 148 84 198 84 210 84 222 84 234 84 246 85 2 85 14 85 26 85 38 85 50 85 66 85 78 85 90 85 166 85 252 86 58 86 132 86 248 87 0 87 8 87 48 87 106 87 114 87 122 87 130 87 230 87 238 87 246 88 44 88 52 88 60 88 122 88 130 88 174 88 182 88 248 89 0 89 8 89 118 89 126 89 204 90 56 90 142 90 214 91 30 91 98 91 110 91 198 92 12 92 24 92 136 93 24 93 172 93 254 94 122 94 234 95 84 95 178 96 20 96 84 96 186 97 8 97 128 97 196 98 92 98 176 99 16 99 124 99 216 100 28 100 114 100 230 101 44 101 154 102 12 102 104 102 236 103 98 103 218 103 230 103 242 103 254 104 10 104 22 104 34 104 46 104 58 104 70 104 82 104 94 104 210 105 50 105 136 105 188 105 240 105 252 106 6 106 16 106 38 106 58 106 66 106 86 106 94 106 102 106 148 106 156 106 164 106 172 106 180 106 188 106 196 106 204 106 212 106 220 106 228 106 236 106 244 106 252 107 4 107 12 107 54 107 96 107 116 107 124 107 178 107 232 108 30 108 82 108 174 109 10 109 18 109 94 109 102 109 110 109 206 109 214 110 110 110 220 111 36 111 48 111 142 111 220 111 228 111 236 111 244 111 252 112 4 112 12 112 20 112 96 112 194 112 202 113 8 113 76 113 132 113 206 114 28 114 106 114 176 115 8 115 118 115 200 115 212 115 224 116 72 116 84 116 174 116 182 116 190 116 202 116 210 117 70 117 168 117 244 118 0 118 12 118 24 118 84 118 166 119 4 119 86 119 132 119 196 120 110 120 236 121 94 121 192 122 14 122 110 122 118 122 200 123 54 123 140 123 210 123 218 123 230 123 242 123 250 124 6 124 14 124 26 124 38 124 46 124 58 124 70 124 78 124 204 125 48 125 88 125 176 125 184 126 62 126 168 126 244 127 0 127 92 127 164 128 12 128 70 128 78 128 122 128 130 128 138 128 182 128 190 129 128 129 136 129 198 130 10 130 66 130 140 130 210 131 32 131 100 131 188 132 36 132 118 132 130 132 142 133 0 133 12 133 102 133 110 133 122 133 134 133 146 133 254 134 86 134 94 134 106 134 118 134 130 134 186 135 24 135 32 135 112 135 158 135 220 136 118 136 238 137 92 137 186 138 4 138 102 138 162 138 248 139 100 139 186 139 194 139 206 139 214 139 226 139 234 139 246 139 254 140 10 140 22 140 30 140 42 140 54 140 62 140 74 140 204 140 216 140 228 141 156 142 72 142 166 142 218 143 42 143 156 143 236 144 84 144 200 144 252 145 132 145 248 146 96 146 190 146 242 147 64 147 168 147 236 148 76 148 84 148 128 148 136 148 244 149 90 149 190 149 242 150 62 150 176 150 252 151 94 151 206 152 2 152 142 152 254 153 100 153 134 153 172 153 184 153 196 153 248 154 48 154 106 154 188 155 24 155 42 155 54 155 92 155 128 155 140 155 152 155 162 155 176 155 214 155 232 155 250 156 6 156 18 156 26 156 34 156 42 156 54 156 66 156 78 156 86 156 96 156 128 156 176 156 190 156 210 156 226 156 248 157 8 157 30 157 48 157 70 157 88 157 110 157 150 157 162 157 182 157 202 157 216 157 244 158 20 158 52 158 82 158 112 158 210 159 52 159 80 159 100 159 128 159 154 159 208 159 252 160 70 160 204 160 236 160 248 161 4 161 166 162 40 162 164 163 6 163 106 163 128 163 150 163 172 163 194 163 230 164 10 164 32 164 56 164 78 164 100 164 240 165 116 165 234 166 64 166 202 167 76 167 222 168 60 168 122 168 142 168 150 168 158 169 52 169 62 169 72 169 82 169 92 169 102 169 112 169 122 169 132 169 142 169 152 169 162 169 172 169 182 169 192 169 242 170 24 170 82 170 164 170 212 171 24 171 106 171 142 171 244 172 70 172 102 172 134 172 164 172 210 173 12 173 46 173 106 173 190 173 244 174 68 174 160 174 204 175 60 175 152 175 180 175 208 175 238 176 34 176 44 176 54 176 64 176 74 176 84 176 94 176 104 176 114 176 124 176 134 176 144 176 154 176 164 176 174 176 182 176 190 176 198 176 254 177 50 177 98 177 150 177 202 177 238 178 88 178 122 178 154 178 204 178 230 179 4 179 54 179 88 179 136 179 186 179 238 180 14 180 82 180 120 180 154 180 184 180 222 181 10 181 58 181 78 181 138 181 198 182 20 182 74 182 122 182 180 182 222 183 18 183 84 183 120 183 134 183 154 183 174 183 194 184 28 184 134 184 238 185 76 185 202 186 50 186 144 187 38 187 170 188 62 188 162 189 58 189 174 190 58 190 170 191 60 191 172 192 12 192 130 192 194 192 252 193 100 193 174 193 194 193 202 193 210 193 226 194 80 194 96 194 112 194 128 194 144 194 160 194 176 194 192 194 208 194 224 194 240 195 0 195 16 195 32 195 48 195 64 195 80 195 96 195 166 195 182 195 218 195 238 196 28 196 92 196 102 196 114 196 130 196 180 196 228 197 40 197 106 197 166 197 208 198 18 198 80 198 92 198 114 198 130 198 164 198 180 199 56 199 116 199 132 199 144 199 160 199 168 200 28 200 84 200 116 200 144 200 178 200 186 200 194 201 12 201 72 201 94 201 158 201 194 202 30 202 144 202 250 203 18 203 42 203 66 203 90 203 118 203 144 203 172 203 198 203 230 204 6 204 38 204 70 204 102 204 134 204 170 204 202 205 4 205 18 205 40 205 64 205 80 205 96 205 118 205 134 205 158 205 176 205 200 205 218 205 242 206 2 206 20 206 84 206 168 206 192 207 30 207 66 207 132 207 204 207 246 208 84 208 106 208 160 209 32 209 146 209 192 210 72 210 184 211 62 211 154 211 224 212 42 212 134 212 168 212 198 212 206 212 214 212 222 212 248 213 18 213 60 213 80 213 94 213 126 213 134 213 142 213 150 213 158 213 174 213 182 213 190 213 198 213 212 213 220 213 228 213 236 213 244 213 252 214 4 214 12 214 20 214 28 214 222 214 242 215 6 215 26 215 46 215 66 215 86 215 120 215 154 215 218 216 20 216 38 216 56 216 64 216 72 216 120 216 168 216 212 217 2 217 30 217 58 217 110 217 162 217 202 217 242 218 54 218 118 218 168 218 218 218 252 219 30 219 64 219 98 219 120 219 154 219 188 219 236 220 24 220 66 220 106 220 146 220 154 220 170 220 186 220 202 220 236 221 6 221 22 221 38 221 58 221 70 221 80 221 90 221 100 221 126 221 154 221 202 221 250 222 44 222 94 222 108 222 124 222 134 222 144 222 154 222 164 222 174 222 238 223 8 223 24 223 42 223 88 223 114 223 122 223 130 223 160 223 180 223 220 224 26 224 88 224 150 224 212 225 18 225 80 225 180 225 244 226 52 226 128 226 204 226 248 227 36 227 80 227 124 227 190 227 254 228 82 228 166 228 228 229 30 229 92 229 150 229 232 230 52 230 146 230 240 231 34 231 84 231 116 231 148 231 184 231 220 232 16 232 70 232 158 232 212 233 10 233 100 233 100 233 100 233 100 233 100 233 114 233 126 233 140 233 154 233 176 233 198 233 222 233 246 234 18 234 46 234 76 234 104 234 122 234 140 234 156 234 172 234 188 234 204 234 220 234 236 234 252 235 12 235 28 235 44 235 60 235 76 235 92 235 108 235 128 235 148 235 170 235 192 235 212 235 234 236 0 236 20 236 38 236 56 236 78 236 100 236 118 236 138 236 158 236 176 236 194 236 214 236 236 236 254 237 16 237 36 237 58 237 76 237 94 237 114 237 136 237 154 237 172 237 192 237 214 237 232 238 0 238 24 238 48 238 72 238 96 238 120 238 144 238 170 238 196 238 222 238 248 239 16 239 40 239 64 239 88 239 112 239 130 239 148 239 166 239 184 239 216 239 236 240 2 240 24 240 50 240 72 240 94 240 120 240 142 240 162 240 186 240 208 240 228 240 252 241 20 241 44 241 76 241 100 241 126 241 158 241 182 241 206 241 238 242 8 242 30 242 60 242 94 242 126 242 170 242 198 242 226 242 254 243 26 243 44 243 62 243 98 243 112 243 126 243 140 243 154 243 166 243 180 243 194 243 208 243 226 243 244 244 6 244 24 244 44 244 62 244 80 244 98 244 116 244 134 244 152 244 170 244 188 244 206 244 224 244 242 245 4 245 22 245 40 245 58 245 78 245 114 245 178 246 44 246 64 246 84 246 102 246 122 246 142 246 164 246 190 246 212 246 234 246 254 247 24 247 46 247 46 247 46 247 168 248 32 248 78 248 144 248 152 248 166 248 186 248 200 248 222 0 5 0 62 0 0 2 26 2 148 0 3 0 9 0 12 0 18 0 21 0 61 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 3 62 89 185 0 5 0 1 244 184 0 7 220 184 0 1 16 185 0 16 0 1 244 184 0 14 220 48 49 51 17 33 17 37 33 47 1 35 15 1 55 39 23 51 63 1 35 31 2 17 62 1 220 254 144 1 1 73 52 4 54 117 128 128 171 4 49 66 235 66 97 127 2 148 253 108 58 132 103 103 80 230 232 185 94 119 119 141 230 1 206 0 0 0 0 2 0 32 0 0 2 56 2 144 0 9 0 17 0 79 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 13 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 3 62 89 186 0 2 0 11 0 10 17 18 57 184 0 2 47 186 0 7 0 11 0 10 17 18 57 184 0 10 16 184 0 14 208 184 0 2 16 185 0 16 0 1 244 48 49 19 7 51 39 46 1 39 35 14 1 3 19 51 19 35 39 35 7 232 31 196 31 17 33 15 4 16 32 217 221 94 221 88 62 238 63 1 111 100 100 55 109 57 57 109 254 90 2 144 253 112 200 200 0 3 0 99 0 0 2 35 2 144 0 19 0 28 0 37 0 87 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 36 0 1 0 0 17 18 57 184 0 36 47 185 0 20 0 1 244 186 0 10 0 20 0 36 17 18 57 184 0 1 16 185 0 27 0 1 244 184 0 0 16 185 0 30 0 1 244 48 49 51 17 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 35 3 51 50 54 53 52 38 43 1 17 51 50 54 53 52 38 43 1 99 186 50 83 59 33 56 59 72 80 36 65 91 55 118 89 84 73 77 76 93 106 85 92 90 87 106 2 144 18 38 61 43 49 79 15 4 11 78 68 48 72 48 24 1 124 54 55 54 43 253 252 59 67 61 53 0 0 0 0 1 0 65 255 244 2 42 2 156 0 33 0 57 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 17 0 1 244 184 0 0 16 185 0 27 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 23 14 1 1 95 61 104 77 44 44 78 108 64 59 91 29 47 26 64 42 47 77 54 30 30 54 77 47 45 71 32 47 39 98 12 46 87 127 80 79 126 88 47 48 32 53 27 33 37 69 98 61 62 99 70 38 38 35 51 45 50 0 0 2 0 87 0 0 2 41 2 144 0 8 0 17 0 53 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 10 0 1 244 184 0 1 16 185 0 16 0 1 244 48 49 51 17 51 50 22 21 20 6 35 39 51 50 54 53 52 38 43 1 87 162 149 155 155 145 83 73 113 111 111 113 73 2 144 168 157 157 174 68 138 125 125 132 0 0 1 0 114 0 0 2 18 2 144 0 11 0 77 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 1 16 185 0 3 0 1 244 186 0 7 0 1 0 0 17 18 57 184 0 7 47 185 0 5 0 1 244 184 0 0 16 185 0 10 0 1 244 48 49 51 17 33 21 33 21 33 21 33 21 33 21 114 1 150 254 190 1 16 254 240 1 76 2 144 70 206 71 238 71 0 0 0 0 1 0 133 0 0 2 24 2 144 0 9 0 67 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 1 16 185 0 3 0 1 244 186 0 7 0 1 0 0 17 18 57 184 0 7 47 185 0 5 0 1 244 48 49 51 17 33 21 33 21 33 21 33 17 133 1 147 254 193 1 14 254 242 2 144 70 222 70 254 218 0 0 1 0 53 255 244 2 21 2 156 0 39 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 19 0 1 244 184 0 0 16 185 0 29 0 1 244 186 0 34 0 0 0 10 17 18 57 184 0 34 47 185 0 35 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 53 35 53 51 17 14 1 1 81 62 104 76 42 43 77 107 64 33 54 45 35 14 47 24 62 48 46 75 54 29 27 51 76 48 35 60 19 131 208 31 101 12 46 87 127 80 79 127 87 47 14 23 28 15 53 26 34 37 69 98 61 62 99 70 38 21 18 171 69 254 236 32 44 0 1 0 79 0 0 2 9 2 144 0 11 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 10 0 0 0 1 17 18 57 184 0 10 47 185 0 3 0 1 244 184 0 1 16 184 0 5 208 184 0 0 16 184 0 8 208 48 49 51 17 51 17 33 17 51 17 35 17 33 17 79 84 1 18 84 84 254 238 2 144 254 237 1 19 253 112 1 53 254 203 0 0 1 0 95 0 0 1 249 2 144 0 11 0 65 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 1 0 1 244 184 0 5 16 185 0 4 0 1 244 184 0 7 208 184 0 1 16 184 0 10 208 48 49 51 53 51 17 35 53 33 21 35 17 51 21 95 163 163 1 154 163 163 71 2 3 70 70 253 253 71 0 0 0 1 0 81 255 244 1 237 2 145 0 19 0 53 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 184 0 13 16 185 0 11 0 1 244 48 49 5 34 38 39 55 30 1 51 50 54 53 17 33 53 33 17 20 14 2 1 20 55 106 34 52 28 75 38 71 65 254 237 1 102 22 51 83 12 52 57 51 45 42 75 81 1 114 70 254 65 46 81 60 35 0 0 0 0 1 0 98 0 0 2 68 2 144 0 12 0 83 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 3 0 1 0 0 17 18 57 184 0 1 16 184 0 6 208 186 0 7 0 1 0 0 17 18 57 184 0 0 16 184 0 8 208 186 0 10 0 0 0 1 17 18 57 48 49 51 17 51 17 51 1 51 7 19 35 3 7 21 98 84 3 1 20 95 208 232 94 191 113 2 144 254 183 1 73 249 254 105 1 88 135 209 0 0 0 1 0 134 0 0 2 29 2 144 0 5 0 43 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 3 0 1 244 48 49 51 17 51 17 33 21 134 82 1 69 2 144 253 183 71 0 1 0 72 0 0 2 16 2 144 0 29 0 93 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 5 0 0 0 1 17 18 57 184 0 1 16 184 0 7 208 184 0 0 16 184 0 10 208 186 0 16 0 0 0 1 17 18 57 186 0 20 0 1 0 0 17 18 57 186 0 23 0 1 0 0 17 18 57 48 49 51 17 51 19 23 51 55 19 51 17 35 17 52 62 2 55 35 7 3 35 3 39 35 30 3 21 17 72 102 92 32 4 31 93 102 80 3 5 4 2 3 37 94 60 92 38 2 2 5 4 3 2 144 254 232 106 106 1 24 253 112 1 72 24 63 64 60 21 128 254 254 1 2 128 21 60 64 63 24 254 184 0 1 0 82 0 0 2 6 2 144 0 19 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 5 0 0 0 1 17 18 57 184 0 1 16 184 0 9 208 184 0 0 16 184 0 12 208 186 0 15 0 1 0 0 17 18 57 48 49 51 17 51 19 23 51 46 1 53 17 51 17 35 3 39 35 30 1 21 17 82 92 210 63 2 2 9 80 92 210 63 2 2 9 2 144 254 100 136 49 107 52 1 84 253 112 1 156 136 51 103 51 254 169 0 0 0 0 2 0 48 255 244 2 40 2 156 0 19 0 39 0 53 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 20 0 1 244 184 0 10 16 185 0 30 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 44 56 92 67 37 37 67 92 56 55 93 67 37 37 67 93 55 37 62 43 24 24 43 62 37 38 61 43 24 24 43 61 12 47 88 127 81 79 126 86 46 46 86 126 79 81 127 88 47 73 37 70 100 63 62 98 68 36 36 68 98 62 63 100 70 37 0 2 0 102 0 0 2 31 2 144 0 14 0 23 0 67 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 13 0 0 0 1 17 18 57 184 0 13 47 185 0 15 0 1 244 184 0 1 16 185 0 23 0 1 244 48 49 51 17 51 50 30 2 21 20 14 2 43 1 25 1 51 50 54 53 52 38 43 1 102 198 54 90 64 35 35 65 89 54 115 105 87 82 84 85 105 2 144 20 45 74 54 52 76 50 25 254 252 1 72 65 70 71 55 0 2 0 50 255 93 2 43 2 157 0 11 0 44 0 75 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 13 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 3 62 89 187 0 38 0 1 0 12 0 4 43 184 0 15 16 185 0 0 0 1 244 184 0 25 16 185 0 6 0 1 244 184 0 15 16 184 0 35 208 48 49 37 50 54 53 52 38 35 34 6 21 20 22 5 34 38 39 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 30 1 51 50 54 55 23 14 1 1 44 76 89 89 76 76 89 89 1 1 87 110 24 48 77 55 30 36 66 92 56 56 92 66 36 29 53 74 46 17 74 51 15 25 9 16 17 36 57 144 130 124 142 142 124 130 144 220 88 66 8 54 87 118 73 79 126 87 46 46 87 126 79 71 117 86 55 9 43 42 6 4 67 6 8 0 0 2 0 100 0 0 2 41 2 144 0 15 0 24 0 85 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 14 0 0 0 1 17 18 57 184 0 14 47 185 0 16 0 1 244 186 0 10 0 14 0 16 17 18 57 184 0 0 16 184 0 12 208 184 0 1 16 185 0 24 0 1 244 48 49 51 17 51 50 30 2 21 20 6 7 19 35 3 35 25 1 51 50 54 53 52 38 43 1 100 204 50 84 61 34 80 67 167 95 158 117 109 77 81 81 77 109 2 144 19 44 70 51 77 92 17 254 226 1 21 254 235 1 89 63 64 65 52 0 1 0 67 255 244 2 25 2 156 0 51 0 73 0 184 0 0 69 88 184 0 26 47 27 185 0 26 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 15 0 26 0 0 17 18 57 184 0 26 16 185 0 33 0 1 244 186 0 41 0 0 0 26 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 46 2 47 1 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 30 2 31 1 30 3 21 20 14 2 1 49 72 121 45 50 37 98 57 68 75 18 32 43 25 94 25 50 41 26 32 57 79 47 62 104 36 44 32 78 51 57 70 21 33 42 21 92 30 53 39 23 32 60 86 12 52 45 58 37 45 58 46 26 36 26 20 11 41 10 28 40 55 36 37 64 47 26 45 36 54 29 33 51 45 24 33 25 18 9 40 12 31 41 55 36 39 68 51 29 0 0 0 0 1 0 42 0 0 2 46 2 144 0 7 0 51 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 3 16 185 0 2 0 1 244 184 0 6 208 48 49 33 17 35 53 33 21 35 17 1 2 216 2 4 216 2 74 70 70 253 182 0 0 0 0 1 0 79 255 244 2 9 2 144 0 25 0 51 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 13 0 1 244 184 0 6 16 184 0 19 208 48 49 5 34 46 2 53 17 51 17 20 30 2 51 50 62 2 53 17 51 17 20 14 2 1 45 48 82 59 33 84 21 37 50 30 30 50 38 21 81 33 58 81 12 28 63 98 71 1 152 254 102 51 71 43 20 20 43 71 51 1 154 254 104 71 98 63 28 0 0 1 0 43 0 0 2 45 2 144 0 15 0 59 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 6 0 0 0 1 17 18 57 184 0 6 47 184 0 1 16 184 0 13 208 48 49 51 3 51 19 30 1 23 51 62 3 55 19 51 3 252 209 88 106 17 28 18 4 9 16 15 15 8 105 85 208 2 144 254 158 59 100 58 29 53 52 54 29 1 98 253 112 0 0 1 0 10 0 0 2 78 2 145 0 41 0 93 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 8 0 1 0 0 17 18 57 186 0 16 0 1 0 0 17 18 57 186 0 22 0 0 0 1 17 18 57 184 0 1 16 184 0 29 208 184 0 0 16 184 0 32 208 186 0 37 0 0 0 1 17 18 57 48 49 51 3 51 19 30 3 23 51 62 3 63 1 51 23 30 3 23 51 62 3 55 19 51 3 35 3 46 1 39 35 14 1 7 3 110 100 94 48 2 4 3 3 1 3 4 8 7 8 5 64 80 62 5 8 7 7 5 4 1 3 3 3 2 46 90 96 104 64 8 11 5 3 5 10 8 64 2 145 254 100 21 34 35 38 24 24 38 35 34 20 244 244 20 34 35 38 24 24 38 35 34 20 1 157 253 111 1 8 30 58 30 30 58 30 254 248 0 0 1 0 54 0 0 2 34 2 144 0 25 0 93 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 13 62 89 184 0 0 69 88 184 0 25 47 27 185 0 25 0 3 62 89 186 0 1 0 25 0 3 17 18 57 186 0 7 0 25 0 3 17 18 57 184 0 3 16 184 0 12 208 186 0 14 0 25 0 3 17 18 57 184 0 25 16 184 0 16 208 186 0 21 0 25 0 3 17 18 57 48 49 51 19 3 51 23 30 1 23 51 62 1 63 1 51 3 19 35 39 46 1 39 35 14 1 15 1 54 196 183 92 92 13 24 16 4 14 21 12 90 88 183 196 92 99 14 27 17 4 14 26 13 98 1 83 1 61 168 23 43 29 29 43 23 168 254 191 254 177 177 24 51 30 30 51 24 177 0 0 1 0 38 0 0 2 50 2 144 0 15 0 55 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 13 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 3 62 89 186 0 8 0 15 0 2 17 18 57 184 0 2 16 184 0 12 208 48 49 33 53 3 51 23 30 1 23 51 62 1 63 1 51 3 21 1 2 220 88 99 19 36 20 4 20 38 19 95 86 220 234 1 166 195 38 75 40 40 76 38 194 254 90 234 0 0 0 1 0 65 0 0 2 27 2 145 0 9 0 61 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 13 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 3 62 89 185 0 7 0 1 244 184 0 1 208 184 0 4 16 185 0 2 0 1 244 184 0 6 208 48 49 51 53 1 33 53 33 21 1 33 21 65 1 110 254 178 1 181 254 145 1 116 50 2 25 70 50 253 232 71 0 2 0 81 255 244 2 3 1 242 0 33 0 47 0 103 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 10 0 24 0 0 17 18 57 184 0 10 47 184 0 24 16 185 0 15 0 1 244 184 0 0 16 184 0 29 208 184 0 29 47 186 0 30 0 0 0 24 17 18 57 184 0 0 16 185 0 34 0 1 244 184 0 10 16 185 0 38 0 1 244 48 49 23 34 46 2 53 52 62 2 55 46 3 35 34 6 7 39 62 3 51 50 22 21 17 35 39 35 14 1 39 50 54 55 53 14 3 21 20 30 2 246 34 60 45 26 39 85 134 94 1 14 30 49 35 48 88 34 32 18 49 55 62 32 100 97 67 7 3 41 99 30 42 81 42 78 105 63 26 18 29 39 12 19 35 51 33 41 61 44 28 8 25 44 33 20 37 21 56 12 25 20 13 109 91 254 214 66 32 46 66 37 35 128 6 22 31 39 24 21 29 19 9 0 2 0 93 255 244 2 28 2 200 0 23 0 40 0 122 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 7 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 4 0 0 0 14 17 18 57 184 0 6 208 184 0 6 47 186 0 10 0 14 0 0 17 18 57 184 0 0 16 185 0 24 0 1 244 184 0 14 16 185 0 34 0 1 244 184 0 10 16 185 0 37 0 1 244 184 0 4 16 185 0 38 0 1 244 48 49 5 34 38 39 35 7 35 17 51 21 7 51 62 1 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 6 7 21 30 1 1 64 35 81 35 3 7 66 82 3 3 33 87 43 49 76 51 26 36 61 80 56 32 54 40 22 16 33 52 36 32 73 38 35 71 12 35 31 54 2 200 194 94 34 40 35 65 91 56 62 98 68 35 69 27 49 72 45 40 66 47 26 35 38 242 31 26 0 0 0 1 0 80 255 244 2 27 1 242 0 33 0 57 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 17 0 1 244 184 0 0 16 185 0 27 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 23 14 1 1 90 57 97 72 40 43 74 99 55 60 87 30 41 30 65 38 42 70 49 28 27 49 69 42 45 75 30 37 41 98 12 34 65 95 60 61 95 66 34 42 29 53 26 30 27 50 69 42 42 68 49 27 35 26 53 36 40 0 0 2 0 60 255 244 1 251 2 200 0 23 0 37 0 122 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 13 0 10 0 0 17 18 57 184 0 19 208 184 0 19 47 186 0 21 0 0 0 10 17 18 57 184 0 0 16 185 0 24 0 1 244 184 0 21 16 185 0 26 0 1 244 184 0 13 16 185 0 27 0 1 244 184 0 10 16 185 0 30 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 51 39 53 51 17 35 39 35 14 1 39 50 55 53 46 1 35 34 14 2 21 20 22 1 15 48 77 56 30 37 61 80 43 44 69 32 3 4 82 68 7 3 30 83 28 72 65 33 63 32 32 55 41 24 75 12 34 65 94 61 59 95 66 36 33 30 90 187 253 56 64 31 45 69 73 242 31 26 27 49 68 42 88 98 0 0 0 2 0 68 255 244 2 26 1 242 0 28 0 37 0 81 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 19 0 10 0 0 17 18 57 184 0 19 47 184 0 0 16 185 0 22 0 1 244 184 0 10 16 185 0 29 0 1 244 184 0 19 16 185 0 35 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 6 7 33 30 1 51 50 54 55 23 14 1 3 34 14 2 7 33 46 1 1 74 55 95 71 41 41 69 89 49 52 83 57 30 2 2 254 129 8 105 76 44 71 33 30 36 93 71 30 55 44 30 6 1 54 5 77 12 34 66 95 61 59 94 66 35 33 60 84 51 14 26 10 83 83 25 21 54 24 34 1 189 20 37 56 36 75 74 0 0 1 0 103 0 0 2 66 2 212 0 22 0 90 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 15 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 4 16 185 0 1 0 1 244 184 0 8 16 185 0 14 0 1 244 184 0 4 16 184 0 18 208 184 0 1 16 184 0 21 208 48 49 51 17 35 53 55 53 52 54 51 50 23 7 46 1 35 34 6 29 1 51 21 35 17 242 139 139 95 101 72 68 19 30 51 32 66 57 204 204 1 163 62 5 41 89 108 28 62 14 9 67 60 44 67 254 93 0 0 3 0 72 255 32 2 54 1 242 0 51 0 67 0 85 0 124 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 77 47 27 185 0 77 0 3 62 89 184 0 22 16 184 0 25 208 184 0 25 47 184 0 22 16 185 0 60 0 1 244 184 0 26 208 184 0 26 47 186 0 35 0 22 0 0 17 18 57 184 0 77 16 185 0 44 0 1 244 184 0 35 16 185 0 52 0 1 244 184 0 0 16 185 0 68 0 1 244 48 49 5 34 38 53 52 54 55 53 46 1 53 52 54 55 53 46 1 53 52 62 2 51 50 23 51 21 35 30 1 21 20 14 2 35 34 38 39 6 21 20 22 59 1 50 22 21 20 14 2 3 50 54 53 52 46 2 35 34 14 2 21 20 22 19 50 62 2 53 52 38 43 1 34 38 39 14 1 21 20 22 1 40 107 117 41 39 20 30 30 28 25 35 31 52 69 39 40 32 201 126 17 24 29 51 69 39 19 43 20 38 53 48 109 94 91 38 70 100 67 47 65 18 30 41 23 23 41 30 18 66 57 42 68 48 25 55 56 95 21 37 16 35 27 81 224 70 65 29 56 23 4 11 38 31 23 49 19 4 19 63 44 40 64 45 25 12 67 17 52 29 39 62 43 23 9 9 24 32 29 27 52 62 34 62 46 28 1 177 62 53 25 42 30 17 17 30 42 25 53 62 254 139 16 27 35 19 35 24 3 5 19 41 21 38 45 0 0 0 0 1 0 93 0 0 2 11 2 200 0 23 0 88 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 15 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 4 0 8 0 0 17 18 57 184 0 13 208 184 0 8 16 185 0 17 0 1 244 184 0 4 16 185 0 22 0 1 244 48 49 51 17 51 21 7 51 62 1 51 50 22 21 17 35 17 52 38 35 34 14 2 7 17 93 82 5 3 38 87 57 87 81 82 52 60 22 37 36 38 21 2 200 194 115 41 54 99 97 254 210 1 35 69 67 11 22 33 22 254 173 0 0 255 255 0 90 0 0 1 158 2 204 2 38 1 87 0 0 0 6 4 254 48 0 0 0 255 255 0 55 255 39 1 158 2 204 2 38 1 209 0 0 0 6 4 254 48 0 0 0 0 1 0 106 0 0 2 62 2 200 0 12 0 88 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 7 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 3 0 1 0 0 17 18 57 186 0 7 0 1 0 0 17 18 57 184 0 8 208 186 0 10 0 1 0 0 17 18 57 48 49 51 17 51 17 51 1 51 7 19 35 39 7 21 106 82 4 1 6 94 194 220 92 179 115 2 200 254 30 1 0 191 254 217 245 113 132 0 0 0 1 0 81 255 244 2 25 2 200 0 16 0 57 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 6 16 185 0 5 0 1 244 184 0 0 16 185 0 11 0 1 244 48 49 5 34 38 53 17 35 53 51 17 20 22 51 50 55 23 14 1 1 151 78 82 166 248 52 44 43 48 21 34 56 12 88 87 1 226 67 253 213 54 47 22 61 14 15 0 0 1 0 58 0 0 2 46 1 242 0 33 0 123 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 7 16 184 0 2 208 184 0 2 47 186 0 3 0 7 0 0 17 18 57 186 0 9 0 0 0 7 17 18 57 184 0 7 16 184 0 12 208 184 0 0 16 184 0 24 208 184 0 16 208 184 0 7 16 185 0 29 0 1 244 184 0 20 208 184 0 9 16 185 0 23 0 1 244 184 0 3 16 185 0 32 0 1 244 48 49 51 17 51 23 51 62 1 51 50 23 62 1 51 50 22 21 17 35 17 52 35 34 6 7 17 35 17 52 38 35 34 6 7 17 58 66 7 2 19 50 42 71 21 21 51 42 51 57 82 52 26 32 20 76 23 27 26 36 18 1 230 64 34 42 84 39 45 77 73 254 164 1 86 85 37 38 254 160 1 86 42 43 37 38 254 160 0 0 1 0 93 0 0 2 11 1 242 0 22 0 101 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 7 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 3 62 89 186 0 3 0 7 0 0 17 18 57 184 0 7 16 185 0 16 0 1 244 184 0 3 16 185 0 21 0 1 244 48 49 51 17 51 23 51 62 1 51 50 22 21 17 35 17 52 38 35 34 14 2 7 17 93 68 7 4 38 88 57 87 81 82 52 60 22 37 36 38 21 1 230 83 41 54 99 97 254 210 1 35 69 67 11 22 33 22 254 173 0 0 0 0 2 0 60 255 244 2 28 1 242 0 19 0 39 0 53 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 20 0 1 244 184 0 10 16 185 0 30 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 44 48 87 66 39 39 66 87 48 48 87 66 39 39 66 87 48 35 57 41 22 22 41 57 35 35 57 41 22 22 41 57 12 34 65 95 60 61 95 66 34 34 66 95 61 60 95 65 34 68 27 49 68 42 42 69 50 27 27 50 69 42 42 68 49 27 0 2 0 93 255 51 2 28 1 242 0 23 0 38 0 126 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 7 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 7 16 184 0 2 208 184 0 2 47 186 0 3 0 7 0 17 17 18 57 186 0 21 0 7 0 17 17 18 57 184 0 17 16 185 0 24 0 1 244 184 0 7 16 185 0 32 0 1 244 184 0 3 16 185 0 35 0 1 244 184 0 21 16 185 0 36 0 1 244 48 49 23 17 51 23 51 62 1 51 50 30 2 21 20 14 2 35 34 38 39 35 23 21 19 50 54 53 52 46 2 35 34 6 7 21 30 1 93 68 7 3 34 89 45 49 75 51 26 36 61 80 44 34 79 32 3 4 130 66 84 16 33 52 36 32 73 38 35 70 205 2 179 62 32 42 35 65 91 57 62 97 68 35 33 30 92 164 1 6 102 91 40 66 47 26 35 38 242 31 26 0 0 0 0 2 0 60 255 51 1 251 1 242 0 23 0 37 0 126 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 3 62 89 186 0 2 0 6 0 16 17 18 57 186 0 19 0 16 0 6 17 18 57 184 0 16 16 184 0 21 208 184 0 21 47 184 0 6 16 185 0 24 0 1 244 184 0 2 16 185 0 26 0 1 244 184 0 19 16 185 0 27 0 1 244 184 0 16 16 185 0 30 0 1 244 48 49 5 53 55 35 14 1 35 34 46 2 53 52 62 2 51 50 22 23 51 55 51 17 3 50 55 53 46 1 35 34 14 2 21 20 22 1 169 4 3 30 81 45 47 78 55 30 37 61 80 43 45 70 35 3 7 66 219 72 65 33 63 32 32 55 41 24 75 205 177 90 31 43 34 65 94 61 59 95 66 36 34 32 54 253 77 1 6 73 242 31 26 27 49 68 42 88 98 0 0 1 0 146 0 0 2 25 1 242 0 18 0 84 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 7 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 3 62 89 186 0 3 0 18 0 1 17 18 57 184 0 7 16 185 0 14 0 1 244 184 0 3 16 185 0 17 0 1 244 48 49 51 17 51 23 51 62 1 51 50 22 23 7 46 1 35 34 6 7 17 146 68 7 3 38 111 68 27 46 23 19 26 35 29 55 101 44 1 230 115 59 68 9 11 71 9 8 63 76 254 227 0 1 0 71 255 244 2 14 1 242 0 45 0 73 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 15 0 0 0 23 17 18 57 184 0 23 16 185 0 30 0 1 244 186 0 36 0 23 0 0 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 46 2 39 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 23 30 3 21 20 14 2 1 54 72 122 45 38 42 101 68 62 61 10 33 60 49 95 95 26 51 75 50 56 104 36 40 34 82 47 62 50 66 75 61 78 45 17 28 55 81 12 45 31 54 30 36 45 31 14 24 22 20 10 20 67 55 29 51 37 21 37 25 53 23 28 42 28 32 33 16 13 29 36 44 28 30 52 40 23 0 0 0 1 0 69 255 244 2 34 2 130 0 27 0 81 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 9 16 185 0 6 0 1 244 184 0 9 16 184 0 11 220 184 0 9 16 184 0 13 208 184 0 6 16 184 0 14 208 184 0 0 16 185 0 21 0 1 244 48 49 5 34 46 2 61 1 35 53 63 1 51 21 51 21 35 21 20 30 2 51 50 54 55 23 14 1 1 138 53 72 44 19 137 140 11 68 239 239 12 28 48 35 35 56 26 18 33 73 12 29 53 74 45 230 62 5 156 156 67 231 33 49 34 17 12 10 60 12 17 0 1 0 77 255 244 1 249 1 230 0 20 0 83 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 9 0 1 244 186 0 17 0 4 0 0 17 18 57 184 0 17 16 185 0 12 0 1 244 184 0 4 16 184 0 14 208 184 0 0 16 184 0 16 208 184 0 16 47 48 49 23 34 38 53 17 51 17 20 22 51 50 54 55 17 51 17 35 39 35 14 1 246 88 81 83 51 61 42 68 41 82 67 7 4 37 87 12 99 97 1 46 254 221 69 67 43 47 1 81 254 26 85 43 54 0 0 1 0 51 0 0 2 37 1 230 0 13 0 55 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 6 0 1 0 0 17 18 57 184 0 1 16 184 0 12 208 48 49 33 3 51 19 30 1 23 51 62 1 55 19 51 3 1 0 205 83 112 15 27 13 4 13 25 15 112 79 201 1 230 254 236 37 71 35 35 71 37 1 20 254 26 0 1 0 8 0 0 2 80 1 230 0 31 0 93 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 6 0 1 0 0 17 18 57 186 0 12 0 1 0 0 17 18 57 186 0 16 0 0 0 1 17 18 57 184 0 1 16 184 0 22 208 184 0 0 16 184 0 23 208 186 0 28 0 0 0 1 17 18 57 48 49 51 3 51 19 30 1 23 51 62 1 63 1 51 23 30 1 23 51 62 1 55 19 51 3 35 39 38 39 35 6 15 1 114 106 82 58 7 10 5 4 5 15 8 60 82 58 8 17 5 4 6 9 7 58 76 104 106 56 12 12 4 12 12 54 1 230 254 230 35 64 35 35 65 34 252 252 35 64 35 35 64 35 1 26 254 26 232 51 93 93 51 232 0 0 1 0 64 0 0 2 23 1 230 0 25 0 93 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 7 0 2 0 0 17 18 57 186 0 20 0 0 0 2 17 18 57 186 0 1 0 7 0 20 17 18 57 184 0 2 16 184 0 13 208 186 0 14 0 20 0 7 17 18 57 184 0 0 16 184 0 15 208 48 49 51 55 39 51 23 30 1 23 51 62 1 63 1 51 7 23 35 39 46 1 39 35 14 1 15 1 64 185 171 91 77 13 29 15 4 14 28 13 73 87 173 186 90 85 15 33 16 4 15 30 15 80 252 234 107 20 42 20 20 44 20 105 241 245 112 21 46 21 22 43 23 112 0 0 1 0 49 255 47 2 39 1 230 0 27 0 71 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 6 0 1 244 186 0 17 0 11 0 0 17 18 57 184 0 17 16 185 0 10 0 1 244 184 0 11 16 184 0 22 208 48 49 23 34 39 55 30 1 51 50 54 63 1 3 51 19 30 1 23 51 62 1 55 19 51 3 14 3 131 36 28 17 10 23 11 51 64 18 15 227 83 119 14 31 15 4 13 27 12 106 78 214 14 36 50 65 209 10 65 3 4 59 45 36 1 231 254 243 32 74 35 35 73 33 1 13 253 242 36 62 45 26 0 0 0 0 1 0 71 0 0 2 19 1 230 0 9 0 61 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 184 0 1 208 184 0 4 16 185 0 3 0 1 244 184 0 6 208 48 49 51 53 1 33 53 33 21 1 33 21 71 1 77 254 216 1 158 254 178 1 87 44 1 119 67 44 254 137 67 255 255 0 32 0 0 2 56 3 99 2 38 0 4 0 0 0 6 4 237 0 0 0 0 255 255 0 32 0 0 2 56 3 99 2 38 0 4 0 0 0 6 4 240 0 0 0 0 255 255 0 32 0 0 2 56 3 70 2 38 0 4 0 0 0 6 4 243 0 0 0 0 255 255 0 32 0 0 2 56 3 73 2 38 0 4 0 0 0 6 4 245 0 0 0 0 255 255 0 32 0 0 2 56 3 48 2 38 0 4 0 0 0 6 5 1 0 0 0 0 255 255 0 32 0 0 2 56 3 24 2 38 0 4 0 0 0 6 4 247 0 0 0 0 255 255 0 32 0 0 2 56 3 74 2 38 0 4 0 0 0 6 4 252 0 0 0 0 255 255 0 32 0 0 2 56 3 112 2 38 0 4 0 0 0 6 5 7 0 0 0 0 0 4 0 32 0 0 2 56 3 200 0 9 0 17 0 32 0 44 0 0 19 7 51 39 46 1 39 35 14 1 3 19 51 19 35 39 35 7 19 34 38 53 52 54 63 1 23 7 30 1 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 232 31 196 31 17 33 15 4 16 32 217 221 94 221 88 62 238 63 183 42 55 20 17 132 37 79 30 37 55 42 20 31 31 20 22 30 30 1 111 100 100 55 109 57 57 109 254 90 2 144 253 112 200 200 2 187 49 41 24 38 12 105 50 42 8 46 33 41 49 36 28 26 26 28 28 26 26 28 0 255 255 0 32 0 0 2 56 3 77 2 38 0 4 0 0 0 6 5 11 0 0 0 0 0 2 0 32 255 31 2 95 2 144 0 28 0 38 0 93 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 13 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 3 62 89 187 0 22 0 1 0 0 0 4 43 184 0 13 16 184 0 9 208 186 0 31 0 13 0 14 17 18 57 184 0 31 47 185 0 11 0 1 244 184 0 9 16 184 0 16 208 186 0 36 0 14 0 13 17 18 57 48 49 5 34 38 53 52 62 2 55 35 39 35 7 35 19 51 19 14 1 21 20 22 51 50 54 55 23 14 1 1 7 51 39 46 1 39 35 14 1 2 3 44 59 16 25 31 15 19 62 238 63 85 221 94 221 38 53 32 22 17 24 9 26 17 46 254 200 31 196 31 17 33 15 4 16 32 225 45 46 23 41 33 27 10 200 200 2 144 253 112 17 62 37 26 25 13 8 43 15 21 2 80 100 100 55 109 57 57 109 0 0 0 255 255 0 32 255 42 2 56 2 144 2 38 0 4 0 0 0 7 4 254 0 0 252 222 255 255 0 32 0 0 2 56 3 104 2 38 0 4 0 0 0 6 5 3 0 0 0 0 255 255 0 32 0 0 2 56 3 120 2 38 0 4 0 0 0 6 5 69 0 0 0 0 255 255 0 32 0 0 2 56 3 120 2 38 0 4 0 0 0 6 5 71 0 0 0 0 255 255 0 32 0 0 2 56 3 138 2 38 0 4 0 0 0 6 5 73 0 0 0 0 255 255 0 32 0 0 2 56 3 171 2 38 0 4 0 0 0 6 5 75 0 0 0 0 255 255 0 32 255 42 2 56 3 70 2 38 0 4 0 0 0 38 4 243 0 0 0 7 4 254 0 0 252 222 0 0 255 255 0 32 0 0 2 56 3 180 2 38 0 4 0 0 0 6 5 77 0 0 0 0 255 255 0 32 0 0 2 56 3 180 2 38 0 4 0 0 0 6 5 79 0 0 0 0 255 255 0 32 0 0 2 56 3 184 2 38 0 4 0 0 0 6 5 81 0 0 0 0 255 255 0 32 0 0 2 56 3 175 2 38 0 4 0 0 0 6 5 83 0 0 0 0 255 255 0 32 255 42 2 56 3 74 2 38 0 4 0 0 0 38 4 252 0 0 0 7 4 254 0 0 252 222 0 0 0 2 255 255 0 0 2 79 2 144 0 6 0 22 0 119 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 13 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 3 62 89 186 0 2 0 8 0 7 17 18 57 184 0 2 47 186 0 4 0 8 0 7 17 18 57 184 0 8 16 185 0 10 0 1 244 184 0 7 16 184 0 19 208 186 0 14 0 8 0 19 17 18 57 184 0 14 47 185 0 13 0 1 244 184 0 19 16 185 0 17 0 1 244 184 0 2 16 185 0 21 0 1 244 48 49 19 7 51 17 35 14 1 3 1 33 21 35 21 51 21 35 21 51 21 33 53 35 7 231 46 132 3 20 43 252 1 8 1 63 189 147 147 198 254 238 158 73 1 121 119 1 76 54 105 254 81 2 144 70 205 71 239 71 191 191 0 255 255 255 255 0 0 2 79 3 99 2 38 0 79 0 0 0 6 4 240 120 0 0 0 255 255 255 255 0 0 2 79 3 24 2 38 0 79 0 0 0 6 4 247 120 0 0 0 0 3 0 26 0 0 2 41 2 144 0 23 0 36 0 45 0 99 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 25 0 1 244 184 0 1 220 185 0 4 0 1 244 184 0 32 220 185 0 37 0 1 244 186 0 15 0 37 0 32 17 18 57 184 0 4 16 184 0 34 208 184 0 1 16 184 0 35 208 184 0 5 16 185 0 44 0 1 244 48 49 51 53 35 53 55 17 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 35 39 51 50 54 53 52 38 43 1 21 51 21 35 53 51 50 54 53 52 38 43 1 105 79 79 186 50 83 59 33 56 59 72 80 36 65 91 55 118 106 85 92 90 87 106 142 142 89 84 73 77 76 93 162 56 6 1 176 18 38 61 43 49 79 15 4 11 78 68 48 72 48 24 70 59 67 61 53 86 62 218 54 55 54 43 255 255 0 99 255 87 2 35 2 144 2 38 0 5 0 0 0 7 4 246 0 7 252 254 255 255 0 65 255 30 2 42 2 156 2 38 0 6 0 0 0 6 5 36 50 0 0 0 255 255 0 65 255 244 2 42 3 99 2 38 0 6 0 0 0 6 4 240 46 0 0 0 255 255 0 65 255 244 2 42 3 70 2 38 0 6 0 0 0 6 4 243 46 0 0 0 255 255 0 65 255 244 2 42 3 77 2 38 0 6 0 0 0 6 5 11 46 0 0 0 255 255 0 65 255 244 2 42 3 59 2 38 0 6 0 0 0 6 4 255 46 0 0 0 255 255 0 87 0 0 2 41 3 77 2 38 0 7 0 0 0 6 5 11 0 0 0 0 255 255 0 87 255 42 2 41 2 144 2 38 0 7 0 0 0 7 4 254 255 251 252 222 255 255 0 87 255 87 2 41 2 144 2 38 0 7 0 0 0 7 4 246 255 251 252 254 255 255 0 87 255 30 2 41 2 144 2 38 0 7 0 0 0 6 5 36 243 0 0 0 255 255 0 12 0 0 2 41 2 144 2 6 0 254 0 0 0 2 0 20 0 0 2 55 2 156 0 22 0 30 0 61 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 16 16 185 0 30 0 1 244 184 0 1 208 184 0 0 16 185 0 23 0 1 244 48 49 51 17 14 1 21 20 22 23 7 46 1 53 52 62 2 51 50 22 21 20 6 35 39 51 50 54 53 52 38 39 209 57 58 38 38 40 51 59 31 63 93 62 151 147 137 122 16 21 82 86 89 100 2 83 11 80 55 48 58 23 58 26 88 69 48 82 60 33 172 158 162 176 68 141 129 122 134 5 0 255 255 0 114 0 0 2 18 3 99 2 38 0 8 0 0 0 6 4 237 31 0 0 0 255 255 0 114 0 0 2 18 3 99 2 38 0 8 0 0 0 6 4 240 31 0 0 0 255 255 0 114 0 0 2 18 3 70 2 38 0 8 0 0 0 6 4 243 31 0 0 0 255 255 0 114 0 0 2 18 3 77 2 38 0 8 0 0 0 6 5 11 31 0 0 0 255 255 0 114 0 0 2 18 3 48 2 38 0 8 0 0 0 6 5 1 31 0 0 0 255 255 0 114 0 0 2 18 3 24 2 38 0 8 0 0 0 6 4 247 31 0 0 0 255 255 0 114 0 0 2 18 3 74 2 38 0 8 0 0 0 6 4 252 31 0 0 0 255 255 0 114 0 0 2 18 3 59 2 38 0 8 0 0 0 6 4 255 31 0 0 0 0 1 0 115 255 31 2 41 2 144 0 33 0 95 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 13 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 3 62 89 187 0 27 0 1 0 0 0 4 43 184 0 8 16 185 0 10 0 1 244 186 0 14 0 8 0 7 17 18 57 184 0 14 47 185 0 13 0 1 244 184 0 7 16 185 0 16 0 1 244 184 0 7 16 184 0 18 208 48 49 5 34 38 53 52 54 55 33 17 33 21 33 21 33 21 33 21 33 21 35 14 3 21 20 22 51 50 54 55 23 14 1 1 206 45 58 53 33 254 182 1 149 254 191 1 15 254 241 1 75 4 19 37 29 18 34 21 16 24 10 25 17 45 225 45 46 45 69 20 2 144 70 206 71 238 71 3 22 32 39 20 26 25 13 8 43 15 21 0 0 0 255 255 0 114 255 42 2 18 2 144 2 38 0 8 0 0 0 7 4 254 0 33 252 222 255 255 0 114 0 0 2 18 3 104 2 38 0 8 0 0 0 6 5 3 31 0 0 0 255 255 0 114 0 0 2 18 3 73 2 38 0 8 0 0 0 6 4 245 31 0 0 0 255 255 0 114 0 0 2 42 3 120 2 38 0 8 0 0 0 6 5 69 31 0 0 0 255 255 0 114 0 0 2 18 3 120 2 38 0 8 0 0 0 6 5 71 31 0 0 0 255 255 0 114 0 0 2 26 3 138 2 38 0 8 0 0 0 6 5 73 31 0 0 0 255 255 0 114 0 0 2 18 3 171 2 38 0 8 0 0 0 6 5 75 31 0 0 0 255 255 0 114 255 42 2 18 3 70 2 38 0 8 0 0 0 38 4 243 31 0 0 7 4 254 0 33 252 222 0 0 255 255 0 114 0 0 2 18 3 200 2 38 0 8 0 0 0 6 5 87 31 0 0 0 255 255 0 53 255 244 2 21 3 99 2 38 0 10 0 0 0 6 4 240 30 0 0 0 255 255 0 53 255 244 2 21 3 70 2 38 0 10 0 0 0 6 4 243 30 0 0 0 255 255 0 53 255 244 2 21 3 74 2 38 0 10 0 0 0 6 4 252 30 0 0 0 255 255 0 53 255 244 2 21 3 59 2 38 0 10 0 0 0 6 4 255 30 0 0 0 255 255 0 53 255 30 2 21 2 156 2 38 0 10 0 0 0 6 5 33 30 0 0 0 255 255 0 53 255 244 2 21 3 77 2 38 0 10 0 0 0 6 5 11 30 0 0 0 255 255 0 53 255 244 2 21 3 24 2 38 0 10 0 0 0 6 4 247 30 0 0 0 255 255 0 53 255 244 2 21 3 73 2 38 0 10 0 0 0 6 4 245 30 0 0 0 0 1 0 53 255 244 2 77 3 36 0 55 0 87 0 184 0 0 69 88 184 0 35 47 27 185 0 35 0 13 62 89 184 0 0 69 88 184 0 25 47 27 185 0 25 0 3 62 89 187 0 50 0 1 0 43 0 4 43 184 0 35 16 185 0 4 0 1 244 184 0 25 16 185 0 14 0 1 244 186 0 19 0 35 0 25 17 18 57 184 0 19 47 185 0 21 0 1 244 48 49 1 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 53 35 53 51 17 14 1 35 34 46 2 53 52 62 2 51 50 22 23 38 53 52 54 51 50 22 23 7 46 1 35 34 6 21 20 22 2 13 47 24 62 48 46 75 54 29 27 51 76 48 35 60 19 131 208 31 101 64 62 104 76 42 43 77 107 64 22 39 17 7 61 50 20 31 12 16 8 15 11 26 28 20 2 76 53 26 34 37 69 98 61 62 99 70 38 21 18 171 69 254 236 32 44 46 87 127 80 79 127 87 47 7 5 20 23 47 58 8 5 63 3 6 31 23 27 39 0 255 255 0 79 0 0 2 9 3 70 2 38 0 11 0 0 0 6 4 243 0 0 0 0 255 255 0 79 0 0 2 9 3 48 2 38 0 11 0 0 0 6 5 1 0 0 0 0 255 255 0 79 255 42 2 9 2 144 2 38 0 11 0 0 0 7 4 254 0 0 252 222 255 255 0 28 255 30 2 9 2 144 2 38 0 11 0 0 0 7 5 36 255 79 0 0 255 255 0 79 255 26 2 9 2 144 2 38 0 11 0 0 0 7 4 250 0 0 252 223 0 2 0 10 0 0 2 78 2 144 0 19 0 23 0 111 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 13 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 3 62 89 187 0 19 0 1 0 2 0 4 43 184 0 2 16 184 0 6 208 184 0 3 16 184 0 8 208 184 0 6 16 184 0 10 208 184 0 19 16 184 0 22 208 184 0 11 208 184 0 18 16 184 0 13 208 186 0 15 0 3 0 18 17 18 57 184 0 15 47 185 0 20 0 1 244 48 49 19 53 55 53 51 21 33 53 51 21 51 21 35 17 35 17 33 17 35 17 23 33 53 33 10 69 84 1 18 84 69 69 84 254 238 84 84 1 18 254 238 1 228 56 6 110 110 110 110 62 254 28 1 53 254 203 1 228 103 103 0 255 255 0 95 0 0 1 249 3 99 2 38 0 12 0 0 0 6 4 237 0 0 0 0 255 255 0 95 0 0 1 249 3 99 2 38 0 12 0 0 0 6 4 240 0 0 0 0 255 255 0 95 0 0 1 249 3 70 2 38 0 12 0 0 0 6 4 243 0 0 0 0 255 255 0 95 0 0 1 249 3 73 2 38 0 12 0 0 0 6 4 245 0 0 0 0 255 255 0 95 0 0 1 249 3 48 2 38 0 12 0 0 0 6 5 1 0 0 0 0 255 255 0 95 0 0 1 249 3 24 2 38 0 12 0 0 0 6 4 247 0 0 0 0 255 255 0 95 0 0 1 249 3 59 2 38 0 12 0 0 0 6 4 255 0 0 0 0 255 255 0 95 0 0 1 249 3 77 2 38 0 12 0 0 0 6 5 11 0 0 0 0 0 1 0 95 255 31 1 249 2 144 0 31 0 87 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 13 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 3 62 89 187 0 25 0 1 0 0 0 4 43 184 0 7 16 185 0 8 0 1 244 184 0 12 16 185 0 11 0 1 244 184 0 14 208 184 0 8 16 184 0 17 208 184 0 7 16 184 0 18 208 48 49 5 34 38 53 52 54 55 35 53 51 17 35 53 33 21 35 17 51 21 35 14 1 21 20 22 51 50 54 55 23 14 1 1 55 44 59 46 25 184 163 163 1 154 163 163 158 38 36 34 20 17 24 9 25 17 45 225 45 46 42 68 24 71 2 3 70 70 253 253 71 29 59 28 26 25 13 8 43 15 21 0 0 0 255 255 0 95 0 0 1 249 3 104 2 38 0 12 0 0 0 6 5 3 0 0 0 0 255 255 0 95 255 42 1 249 2 144 2 38 0 12 0 0 0 7 4 254 0 0 252 222 255 255 0 95 0 0 1 249 3 74 2 38 0 12 0 0 0 6 4 252 0 0 0 0 255 255 0 81 255 244 1 237 3 70 2 38 0 13 0 0 0 6 4 243 24 0 0 0 255 255 0 98 255 30 2 68 2 144 2 38 0 14 0 0 0 6 5 33 38 0 0 0 255 255 0 98 255 42 2 68 2 144 2 38 0 14 0 0 0 7 4 254 0 38 252 222 255 255 0 98 255 87 2 68 2 144 2 38 0 14 0 0 0 7 4 246 0 38 252 254 255 255 0 125 0 0 2 29 3 99 2 38 0 15 0 0 0 6 4 240 146 0 0 0 255 255 0 134 0 0 2 29 3 15 2 38 0 15 0 0 0 6 5 12 124 223 0 0 255 255 0 134 255 30 2 29 2 144 2 38 0 15 0 0 0 6 5 33 49 0 0 0 255 255 0 134 255 42 2 29 2 144 2 38 0 15 0 0 0 7 4 254 0 49 252 222 255 255 0 56 255 42 2 29 3 24 2 38 0 15 0 0 0 38 4 247 146 0 0 7 4 254 0 49 252 222 0 0 255 255 0 134 255 87 2 29 2 144 2 38 0 15 0 0 0 7 4 246 0 49 252 254 0 1 0 10 0 0 2 29 2 144 0 13 0 43 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 13 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 3 62 89 185 0 10 0 1 244 48 49 55 39 55 17 51 17 55 23 7 21 33 21 33 53 39 29 124 82 211 29 240 1 69 254 105 181 53 66 1 100 254 193 113 53 128 198 71 233 0 255 255 0 134 0 0 2 29 2 144 2 38 0 15 0 0 0 7 4 254 0 167 254 211 255 255 0 72 0 0 2 16 3 99 2 38 0 16 0 0 0 6 4 240 0 0 0 0 255 255 0 72 0 0 2 16 3 59 2 38 0 16 0 0 0 6 4 255 0 0 0 0 255 255 0 72 255 42 2 16 2 144 2 38 0 16 0 0 0 7 4 254 0 0 252 222 255 255 0 82 0 0 2 6 3 99 2 38 0 17 0 0 0 6 4 240 10 0 0 0 255 255 0 82 0 0 2 6 3 99 2 38 0 17 0 0 0 6 4 237 10 0 0 0 255 255 0 82 0 0 2 6 3 77 2 38 0 17 0 0 0 6 5 11 10 0 0 0 255 255 0 82 0 0 2 6 3 73 2 38 0 17 0 0 0 6 4 245 10 0 0 0 255 255 0 82 255 30 2 6 2 144 2 38 0 17 0 0 0 6 5 33 0 0 0 0 255 255 0 82 0 0 2 6 3 59 2 38 0 17 0 0 0 6 4 255 10 0 0 0 255 255 0 82 255 42 2 6 2 144 2 38 0 17 0 0 0 7 4 254 0 0 252 222 255 255 0 82 255 87 2 6 2 144 2 38 0 17 0 0 0 7 4 246 0 0 252 254 255 255 0 48 255 244 2 40 3 99 2 38 0 18 0 0 0 6 4 237 0 0 0 0 255 255 0 48 255 244 2 40 3 99 2 38 0 18 0 0 0 6 4 240 0 0 0 0 255 255 0 48 255 244 2 40 3 70 2 38 0 18 0 0 0 6 4 243 0 0 0 0 255 255 0 48 255 244 2 40 3 73 2 38 0 18 0 0 0 6 4 245 0 0 0 0 255 255 0 48 255 244 2 40 3 48 2 38 0 18 0 0 0 6 5 1 0 0 0 0 255 255 0 48 255 244 2 40 3 24 2 38 0 18 0 0 0 6 4 247 0 0 0 0 255 255 0 48 255 244 2 40 3 108 2 38 0 18 0 0 0 6 5 9 0 0 0 0 255 255 0 48 255 244 2 40 3 74 2 38 0 18 0 0 0 6 4 252 0 0 0 0 255 255 0 48 255 244 2 40 3 77 2 38 0 18 0 0 0 6 5 11 0 0 0 0 0 2 0 48 255 31 2 40 2 156 0 36 0 52 0 75 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 13 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 3 62 89 187 0 30 0 1 0 0 0 4 43 184 0 6 16 184 0 24 208 184 0 6 16 185 0 37 0 1 244 184 0 16 16 185 0 45 0 1 244 48 49 5 34 38 53 52 54 55 46 3 53 52 62 2 51 50 30 2 21 20 6 7 14 1 21 20 22 51 50 54 55 23 14 1 3 50 54 53 52 46 2 35 34 14 2 21 20 22 1 62 45 58 43 28 58 89 60 31 37 67 92 56 55 93 67 37 93 88 46 46 34 21 16 24 10 25 17 45 47 75 91 24 43 62 37 38 61 43 24 91 225 45 46 40 60 23 4 56 90 121 71 79 125 87 46 47 87 125 78 132 164 37 20 63 31 26 25 13 8 43 15 21 1 29 142 129 62 98 68 36 36 68 98 62 129 142 0 0 255 255 0 48 255 42 2 40 2 156 2 38 0 18 0 0 0 7 4 254 0 0 252 222 255 255 0 48 255 244 2 40 3 104 2 38 0 18 0 0 0 6 5 3 0 0 0 0 255 255 0 48 255 244 2 40 3 120 2 38 0 18 0 0 0 6 5 69 0 0 0 0 255 255 0 48 255 244 2 40 3 120 2 38 0 18 0 0 0 6 5 71 0 0 0 0 255 255 0 48 255 244 2 40 3 138 2 38 0 18 0 0 0 6 5 73 0 0 0 0 255 255 0 48 255 244 2 40 3 171 2 38 0 18 0 0 0 6 5 75 0 0 0 0 255 255 0 48 255 42 2 40 3 70 2 38 0 18 0 0 0 38 4 243 0 0 0 7 4 254 0 0 252 222 0 0 0 2 0 48 255 244 2 50 3 45 0 31 0 51 0 75 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 184 0 18 220 184 0 10 16 185 0 42 0 1 244 186 0 24 0 10 0 42 17 18 57 184 0 0 16 185 0 32 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 23 54 53 52 38 39 55 30 1 21 20 6 7 30 1 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 44 56 92 67 37 37 67 92 56 62 49 78 8 7 65 11 12 56 48 45 49 37 67 93 55 37 62 43 24 24 43 62 37 38 61 43 24 24 43 61 12 47 88 127 81 79 126 86 46 28 16 70 15 31 12 29 17 41 23 51 63 12 43 138 94 81 127 88 47 73 37 70 100 63 62 98 68 36 36 68 98 62 63 100 70 37 0 255 255 0 48 255 244 2 50 3 99 2 38 0 180 0 0 0 6 4 240 0 0 0 0 255 255 0 48 255 244 2 50 3 99 2 38 0 180 0 0 0 6 4 237 0 0 0 0 255 255 0 48 255 244 2 50 3 104 2 38 0 180 0 0 0 6 5 3 0 0 0 0 255 255 0 48 255 244 2 50 3 73 2 38 0 180 0 0 0 6 4 245 237 0 0 0 255 255 0 48 255 42 2 50 3 45 2 38 0 180 0 0 0 7 4 254 0 0 252 222 255 255 0 48 255 244 2 40 3 200 2 38 0 18 0 0 0 6 5 87 0 0 0 0 0 3 0 36 255 224 2 48 2 176 0 25 0 35 0 45 0 137 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 28 0 13 0 0 17 18 57 186 0 2 0 0 0 28 17 18 57 186 0 5 0 28 0 0 17 18 57 186 0 43 0 0 0 13 17 18 57 186 0 15 0 43 0 13 17 18 57 186 0 18 0 13 0 43 17 18 57 186 0 29 0 0 0 13 17 18 57 184 0 13 16 185 0 31 0 1 244 184 0 0 16 185 0 36 0 1 244 186 0 44 0 13 0 0 17 18 57 48 49 5 34 39 7 39 55 46 1 53 52 62 2 51 50 23 55 23 7 30 1 21 20 14 2 3 20 23 19 38 35 34 14 2 19 50 62 2 53 52 39 3 22 1 44 89 65 54 56 67 26 29 37 67 92 56 87 65 52 56 64 27 29 37 67 93 221 23 249 44 62 38 61 43 24 166 37 62 43 24 24 250 43 12 60 80 36 98 43 115 71 79 126 86 46 57 77 36 94 42 114 71 81 127 88 47 1 87 87 63 1 108 50 36 68 98 254 180 37 70 100 63 89 60 254 147 54 0 0 0 255 255 0 36 255 224 2 48 3 99 2 38 0 187 0 0 0 6 4 240 0 0 0 0 0 2 0 33 0 0 2 79 2 145 0 16 0 25 0 93 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 6 16 185 0 19 0 1 244 184 0 8 208 184 0 8 47 186 0 12 0 6 0 0 17 18 57 184 0 12 47 185 0 11 0 1 244 184 0 0 16 185 0 18 0 1 244 184 0 15 208 184 0 15 47 48 49 33 34 38 53 52 54 51 33 21 35 21 51 21 35 21 51 21 37 51 17 35 34 6 21 20 22 1 40 125 138 141 125 1 26 194 148 148 204 254 210 22 22 86 84 84 173 158 157 169 70 207 71 238 71 68 2 8 132 125 126 137 0 0 255 255 0 100 0 0 2 41 3 99 2 38 0 21 0 0 0 6 4 240 4 0 0 0 255 255 0 100 0 0 2 41 3 77 2 38 0 21 0 0 0 6 5 11 4 0 0 0 255 255 0 100 0 0 2 41 3 59 2 38 0 21 0 0 0 6 4 255 4 0 0 0 255 255 0 100 255 30 2 41 2 144 2 38 0 21 0 0 0 6 5 33 20 0 0 0 255 255 0 100 255 42 2 41 2 144 2 38 0 21 0 0 0 7 4 254 0 20 252 222 255 255 0 100 255 42 2 41 3 24 2 38 0 21 0 0 0 38 4 247 4 0 0 7 4 254 0 20 252 222 0 0 255 255 0 100 255 87 2 41 2 144 2 38 0 21 0 0 0 7 4 246 0 20 252 254 255 255 0 67 255 244 2 25 3 99 2 38 0 22 0 0 0 6 4 240 16 0 0 0 255 255 0 67 255 244 2 25 3 70 2 38 0 22 0 0 0 6 4 243 16 0 0 0 255 255 0 67 255 244 2 25 3 77 2 38 0 22 0 0 0 6 5 11 16 0 0 0 255 255 0 67 255 244 2 25 3 157 2 38 0 22 0 0 0 6 5 89 16 0 0 0 255 255 0 67 255 30 2 25 2 156 2 38 0 22 0 0 0 6 5 36 19 0 0 0 255 255 0 67 255 30 2 25 2 156 2 38 0 22 0 0 0 6 5 33 13 0 0 0 255 255 0 67 255 244 2 25 3 59 2 38 0 22 0 0 0 6 4 255 16 0 0 0 255 255 0 67 255 42 2 25 2 156 2 38 0 22 0 0 0 7 4 254 0 13 252 222 0 1 0 78 255 244 2 57 2 156 0 44 0 95 0 184 0 0 69 88 184 0 31 47 27 185 0 31 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 15 0 31 0 0 17 18 57 184 0 15 16 185 0 16 0 1 244 184 0 31 16 185 0 20 0 1 244 184 0 0 16 184 0 25 208 184 0 25 47 186 0 35 0 16 0 15 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 46 2 47 1 55 46 1 35 34 6 21 17 35 17 52 62 2 51 50 22 23 7 30 3 21 20 14 2 1 134 49 84 28 40 25 54 35 46 53 15 39 67 51 6 124 17 63 43 65 78 84 32 58 84 53 84 102 24 121 49 68 40 18 24 47 66 12 38 35 53 29 27 61 48 24 43 37 29 10 54 154 42 39 90 96 254 99 1 172 55 89 62 34 84 70 151 15 39 49 59 34 38 66 48 27 0 0 255 255 0 42 0 0 2 46 3 77 2 38 0 23 0 0 0 6 5 11 0 0 0 0 255 255 0 42 255 30 2 46 2 144 2 38 0 23 0 0 0 6 5 36 0 0 0 0 255 255 0 42 255 30 2 46 2 144 2 38 0 23 0 0 0 6 5 33 0 0 0 0 255 255 0 42 255 42 2 46 2 144 2 38 0 23 0 0 0 7 4 254 0 0 252 222 255 255 0 42 255 87 2 46 2 144 2 38 0 23 0 0 0 7 4 246 0 0 252 254 0 1 0 42 0 0 2 46 2 144 0 16 0 83 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 13 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 3 62 89 186 0 12 0 6 0 15 17 18 57 184 0 12 47 184 0 0 208 184 0 12 16 185 0 11 0 1 244 184 0 3 208 184 0 6 16 185 0 4 0 1 244 184 0 8 208 48 49 19 53 55 51 53 35 53 33 21 35 21 51 21 35 17 35 17 116 90 52 216 2 4 216 142 142 84 1 50 58 4 218 70 70 218 62 254 206 1 50 0 0 0 255 255 0 79 255 244 2 9 3 99 2 38 0 24 0 0 0 6 4 237 0 0 0 0 255 255 0 79 255 244 2 9 3 99 2 38 0 24 0 0 0 6 4 240 0 0 0 0 255 255 0 79 255 244 2 9 3 70 2 38 0 24 0 0 0 6 4 243 0 0 0 0 255 255 0 79 255 244 2 9 3 73 2 38 0 24 0 0 0 6 4 245 0 0 0 0 255 255 0 79 255 244 2 9 3 48 2 38 0 24 0 0 0 6 5 1 0 0 0 0 255 255 0 79 255 244 2 9 3 24 2 38 0 24 0 0 0 6 4 247 0 0 0 0 255 255 0 79 255 244 2 9 3 74 2 38 0 24 0 0 0 6 4 252 0 0 0 0 255 255 0 79 255 244 2 9 3 112 2 38 0 24 0 0 0 6 5 7 0 0 0 0 255 255 0 79 255 244 2 9 3 108 2 38 0 24 0 0 0 6 5 9 0 0 0 0 255 255 0 79 255 244 2 9 3 77 2 38 0 24 0 0 0 6 5 11 0 0 0 0 0 1 0 79 255 31 2 9 2 144 0 42 0 73 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 13 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 3 62 89 187 0 36 0 1 0 0 0 4 43 184 0 8 16 185 0 19 0 1 244 184 0 12 16 184 0 26 208 184 0 8 16 184 0 30 208 48 49 5 34 38 53 52 62 2 55 46 1 53 17 51 17 20 30 2 51 50 62 2 53 17 51 17 20 6 7 14 1 21 20 22 51 50 54 55 23 14 1 1 62 45 58 13 20 24 10 93 110 84 21 36 50 30 30 51 37 22 81 70 68 59 45 34 21 16 24 10 25 17 45 225 45 46 21 37 31 25 9 5 126 128 1 152 254 102 51 71 43 20 20 43 71 51 1 154 254 104 106 115 27 24 62 30 26 25 13 8 43 15 21 0 255 255 0 79 255 244 2 9 3 139 2 38 0 24 0 0 0 6 5 65 0 0 0 0 255 255 0 79 255 244 2 9 3 200 2 38 0 24 0 0 0 6 5 58 0 0 0 0 255 255 0 79 255 244 2 9 3 194 2 38 0 24 0 0 0 6 5 67 0 0 0 0 255 255 0 79 255 244 2 9 3 200 2 38 0 24 0 0 0 6 5 61 0 0 0 0 255 255 0 79 255 42 2 9 2 144 2 38 0 24 0 0 0 7 4 254 0 0 252 222 255 255 0 79 255 244 2 9 3 104 2 38 0 24 0 0 0 6 5 3 0 0 0 0 0 1 0 79 255 244 2 118 3 57 0 38 0 63 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 13 0 1 244 184 0 6 16 184 0 20 208 184 0 27 220 184 0 20 16 184 0 33 220 48 49 5 34 46 2 53 17 51 17 20 30 2 51 50 62 2 53 17 51 62 1 53 52 38 39 55 30 1 21 20 6 7 17 20 14 2 1 45 48 82 59 33 84 21 37 50 30 30 50 38 21 33 41 43 8 7 65 11 12 63 46 33 58 81 12 28 63 98 71 1 152 254 102 51 71 43 20 20 43 71 51 1 154 5 36 42 15 31 12 28 17 40 23 58 56 11 254 140 71 98 63 28 0 0 255 255 0 79 255 244 2 118 3 99 2 38 0 229 0 0 0 6 4 240 0 0 0 0 255 255 0 79 255 244 2 118 3 99 2 38 0 229 0 0 0 6 4 237 0 0 0 0 255 255 0 79 255 244 2 118 3 104 2 38 0 229 0 0 0 6 5 3 0 0 0 0 255 255 0 79 255 244 2 118 3 73 2 38 0 229 0 0 0 6 4 245 0 0 0 0 255 255 0 79 255 42 2 118 3 57 2 38 0 229 0 0 0 7 4 254 0 0 252 222 255 255 0 43 255 42 2 45 2 144 2 38 0 25 0 0 0 7 4 254 0 2 252 222 255 255 0 10 0 0 2 78 3 99 2 38 0 26 0 0 0 6 4 237 0 0 0 0 255 255 0 10 0 0 2 78 3 99 2 38 0 26 0 0 0 6 4 240 0 0 0 0 255 255 0 10 0 0 2 78 3 70 2 38 0 26 0 0 0 6 4 243 0 0 0 0 255 255 0 10 0 0 2 78 3 48 2 38 0 26 0 0 0 6 5 1 0 0 0 0 255 255 0 38 0 0 2 50 3 99 2 38 0 28 0 0 0 6 4 237 0 0 0 0 255 255 0 38 0 0 2 50 3 99 2 38 0 28 0 0 0 6 4 240 0 0 0 0 255 255 0 38 0 0 2 50 3 70 2 38 0 28 0 0 0 6 4 243 0 0 0 0 255 255 0 38 0 0 2 50 3 48 2 38 0 28 0 0 0 6 5 1 0 0 0 0 255 255 0 38 0 0 2 50 3 59 2 38 0 28 0 0 0 6 4 255 0 0 0 0 255 255 0 38 255 42 2 50 2 144 2 38 0 28 0 0 0 7 4 254 0 0 252 222 255 255 0 38 0 0 2 50 3 104 2 38 0 28 0 0 0 6 5 3 0 0 0 0 255 255 0 38 0 0 2 50 3 73 2 38 0 28 0 0 0 6 4 245 0 0 0 0 255 255 0 65 0 0 2 27 3 99 2 38 0 29 0 0 0 6 4 240 17 0 0 0 255 255 0 65 0 0 2 27 3 77 2 38 0 29 0 0 0 6 5 11 17 0 0 0 255 255 0 65 0 0 2 27 3 59 2 38 0 29 0 0 0 6 4 255 17 0 0 0 255 255 0 65 0 0 2 27 3 70 2 38 0 29 0 0 0 6 4 243 17 0 0 0 255 255 0 65 255 42 2 27 2 145 2 38 0 29 0 0 0 7 4 254 0 10 252 222 255 255 0 65 255 87 2 27 2 145 2 38 0 29 0 0 0 7 4 246 0 10 252 254 0 2 0 12 0 0 2 41 2 144 0 12 0 25 0 89 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 24 0 5 0 0 17 18 57 184 0 24 47 184 0 2 208 184 0 24 16 185 0 23 0 1 244 184 0 4 208 184 0 0 16 185 0 14 0 1 244 184 0 5 16 185 0 20 0 1 244 48 49 51 17 35 53 55 17 51 50 22 21 20 6 35 39 51 50 54 53 52 38 43 1 21 51 21 35 87 75 75 162 149 155 155 145 83 73 112 111 111 112 73 144 144 1 58 56 6 1 24 168 157 157 174 68 138 125 125 132 212 62 0 0 0 0 2 0 101 0 0 2 33 2 144 0 16 0 25 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 3 62 89 187 0 18 0 1 0 14 0 4 43 187 0 4 0 1 0 24 0 4 43 48 49 51 17 51 21 51 50 30 2 21 20 14 2 43 1 21 53 51 50 54 53 52 38 43 1 101 84 118 54 90 63 35 35 64 89 54 118 107 87 83 85 85 107 2 144 110 20 46 73 54 52 77 50 24 150 218 64 71 71 54 0 2 0 59 255 244 2 38 2 156 0 28 0 35 0 77 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 33 0 19 0 0 17 18 57 184 0 33 47 185 0 9 0 1 244 184 0 19 16 185 0 12 0 1 244 184 0 0 16 185 0 29 0 1 244 48 49 5 34 46 2 53 60 1 55 33 46 1 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 39 50 54 55 33 30 1 1 44 55 89 63 34 1 1 151 4 86 80 41 66 25 40 31 87 58 58 92 65 34 37 66 92 55 69 89 8 254 187 8 82 12 49 88 125 77 6 11 6 118 128 32 26 57 32 41 47 87 125 79 79 126 89 48 72 114 112 114 112 0 1 0 85 255 244 2 37 2 156 0 37 0 87 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 184 0 28 16 185 0 17 0 1 244 184 0 0 16 184 0 22 208 184 0 22 47 184 0 28 16 184 0 23 208 184 0 23 47 186 0 25 0 28 0 22 17 18 57 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 46 2 35 34 6 7 17 35 17 51 21 62 1 51 50 30 2 21 20 14 2 1 122 19 42 14 21 9 22 14 20 35 25 14 21 39 55 33 37 82 28 83 81 32 87 48 46 80 57 33 23 44 64 12 7 7 75 5 5 25 62 103 78 74 100 60 26 54 40 254 11 2 144 77 37 52 35 79 127 92 95 132 82 38 0 0 0 2 0 112 255 91 1 232 2 144 0 3 0 19 0 55 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 11 0 1 0 4 0 4 43 184 0 1 16 184 0 15 208 48 49 51 17 51 17 23 34 38 39 55 30 1 51 50 54 53 17 51 17 20 6 112 83 156 23 37 14 16 11 25 13 38 25 83 63 2 144 253 112 165 8 5 66 4 6 51 45 2 144 253 109 74 88 0 0 3 0 68 0 0 2 42 2 144 0 5 0 17 0 23 0 79 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 12 0 6 0 3 43 184 0 0 16 185 0 4 0 1 244 184 0 0 16 184 0 18 208 184 0 1 16 184 0 19 208 184 0 4 16 184 0 22 208 48 49 51 17 51 17 51 21 3 34 38 53 52 54 51 50 22 21 20 6 19 17 51 17 51 21 68 76 131 29 33 45 45 33 33 47 47 69 76 130 2 144 253 183 71 1 16 45 39 39 43 43 39 39 45 254 240 2 144 253 183 71 0 0 0 255 255 0 90 255 91 2 57 3 99 2 38 1 2 0 0 0 39 4 240 255 111 0 0 0 7 4 240 0 146 0 0 255 255 0 81 255 244 2 3 3 9 2 38 0 30 0 0 0 6 4 236 20 0 0 0 255 255 0 81 255 244 2 3 3 9 2 38 0 30 0 0 0 6 4 239 20 0 0 0 255 255 0 81 255 244 2 3 2 228 2 38 0 30 0 0 0 6 4 242 20 0 0 0 255 255 0 81 255 244 2 3 2 209 2 38 0 30 0 0 0 6 4 244 20 0 0 0 255 255 0 81 255 244 2 3 2 188 2 38 0 30 0 0 0 6 5 0 20 0 0 0 255 255 0 81 255 244 2 3 2 146 2 38 0 30 0 0 0 6 4 246 20 0 0 0 255 255 0 81 255 244 2 3 2 218 2 38 0 30 0 0 0 6 4 250 20 0 0 0 255 255 0 81 255 244 2 3 2 249 2 38 0 30 0 0 0 6 5 6 20 0 0 0 0 4 0 81 255 244 2 3 3 75 0 33 0 47 0 62 0 74 0 0 23 34 46 2 53 52 62 2 55 46 3 35 34 6 7 39 62 3 51 50 22 21 17 35 39 35 14 1 39 50 54 55 53 14 3 21 20 30 2 19 34 38 53 52 54 63 1 23 7 30 1 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 246 34 60 45 26 39 85 134 94 1 14 30 49 35 48 88 34 32 18 49 55 62 32 100 97 67 7 3 41 99 30 42 81 42 78 105 63 26 18 29 39 73 52 58 24 23 133 35 73 37 41 58 52 24 33 33 24 24 33 33 12 19 35 51 33 41 61 44 28 8 25 44 33 20 37 21 56 12 25 20 13 109 91 254 214 66 32 46 66 37 35 128 6 22 31 39 24 21 29 19 9 2 3 55 41 26 42 13 97 50 35 8 51 34 41 55 37 34 25 26 33 33 26 25 34 0 255 255 0 81 255 244 2 3 2 234 2 38 0 30 0 0 0 6 5 10 20 0 0 0 0 2 0 81 255 31 2 37 1 242 0 51 0 65 0 115 0 184 0 0 69 88 184 0 35 47 27 185 0 35 0 7 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 3 62 89 187 0 45 0 1 0 0 0 4 43 184 0 11 16 184 0 6 208 184 0 6 47 186 0 21 0 35 0 11 17 18 57 184 0 21 47 184 0 35 16 185 0 26 0 1 244 184 0 6 16 184 0 39 208 184 0 39 47 184 0 11 16 185 0 52 0 1 244 184 0 21 16 185 0 56 0 1 244 48 49 5 34 38 53 52 54 55 39 35 14 1 35 34 46 2 53 52 62 2 55 46 3 35 34 6 7 39 62 3 51 50 22 21 17 14 1 21 20 22 51 50 54 55 23 14 1 3 50 54 55 53 14 3 21 20 30 2 1 200 44 59 56 39 7 3 41 99 52 34 60 45 26 39 85 134 94 1 14 30 49 35 48 88 34 32 18 49 55 62 32 100 97 54 47 36 23 17 26 9 24 17 47 217 42 81 42 78 105 63 26 18 29 39 225 45 48 45 68 24 61 32 46 19 35 51 33 41 61 44 28 8 25 44 33 20 37 21 56 12 25 20 13 109 91 254 214 24 61 31 29 26 12 9 39 17 19 1 23 37 35 128 6 22 31 39 24 21 29 19 9 0 0 0 255 255 0 81 255 42 2 3 1 242 2 38 0 30 0 0 0 7 4 254 0 0 252 222 255 255 0 81 255 244 2 3 2 248 2 38 0 30 0 0 0 6 5 2 20 0 0 0 255 255 0 81 255 244 2 43 3 17 2 38 0 30 0 0 0 6 5 68 20 0 0 0 255 255 0 73 255 244 2 3 3 17 2 38 0 30 0 0 0 6 5 70 20 0 0 0 255 255 0 81 255 244 2 17 3 23 2 38 0 30 0 0 0 6 5 72 20 0 0 0 255 255 0 81 255 244 2 3 3 35 2 38 0 30 0 0 0 6 5 74 20 0 0 0 255 255 0 81 255 42 2 3 2 228 2 38 0 30 0 0 0 38 4 242 20 0 0 7 4 254 0 0 252 222 0 0 255 255 0 81 255 244 2 3 3 64 2 38 0 30 0 0 0 6 5 76 20 0 0 0 255 255 0 81 255 244 2 3 3 64 2 38 0 30 0 0 0 6 5 78 20 0 0 0 255 255 0 81 255 244 2 3 3 80 2 38 0 30 0 0 0 6 5 80 20 0 0 0 255 255 0 81 255 244 2 3 3 34 2 38 0 30 0 0 0 6 5 82 20 0 0 0 255 255 0 81 255 42 2 3 2 218 2 38 0 30 0 0 0 38 4 250 20 0 0 7 4 254 0 0 252 222 0 0 0 3 0 17 255 244 2 85 1 242 0 46 0 60 0 66 0 149 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 53 0 16 0 0 17 18 57 184 0 53 47 185 0 6 0 1 244 184 0 16 16 185 0 9 0 1 244 186 0 19 0 16 0 0 17 18 57 184 0 16 16 184 0 22 208 186 0 30 0 16 0 0 17 18 57 184 0 30 47 184 0 0 16 185 0 47 0 1 244 184 0 34 208 184 0 0 16 184 0 41 208 186 0 44 0 0 0 16 17 18 57 184 0 9 16 184 0 61 208 184 0 30 16 185 0 64 0 1 244 48 49 23 34 38 53 52 54 55 46 1 35 34 6 7 39 62 1 51 50 22 23 62 1 51 50 30 2 21 20 6 7 33 30 1 51 50 54 55 23 14 1 35 34 38 39 14 1 39 50 54 55 38 61 1 14 3 21 20 22 1 34 6 7 51 38 145 56 72 117 132 2 48 38 30 61 23 31 30 79 43 44 62 17 25 74 41 38 56 37 18 2 2 254 251 4 64 57 28 47 20 30 25 65 38 51 75 24 35 79 23 28 62 26 17 51 66 40 16 41 1 53 38 64 8 197 4 12 70 62 74 91 17 71 57 24 16 56 20 32 46 54 54 46 36 61 80 45 14 29 13 77 88 18 14 56 18 25 45 42 42 45 66 35 34 54 65 7 8 23 30 38 22 35 39 1 123 68 81 149 0 0 0 255 255 0 17 255 244 2 85 3 9 2 38 1 28 0 0 0 6 4 239 16 0 0 0 255 255 0 17 255 244 2 85 2 146 2 38 1 28 0 0 0 6 4 246 16 0 0 0 0 2 0 20 255 244 2 28 2 200 0 31 0 44 0 143 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 11 16 184 0 13 220 185 0 16 0 1 244 184 0 22 220 186 0 3 0 0 0 22 17 18 57 184 0 0 16 184 0 6 208 184 0 6 47 184 0 16 16 184 0 7 208 184 0 13 16 184 0 10 208 186 0 18 0 22 0 0 17 18 57 184 0 0 16 185 0 32 0 1 244 184 0 22 16 185 0 38 0 1 244 184 0 18 16 185 0 41 0 1 244 184 0 3 16 185 0 42 0 1 244 48 49 5 34 38 39 35 7 35 17 35 53 55 53 51 21 51 21 35 21 7 51 62 1 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 7 21 30 1 1 64 35 81 35 3 7 66 73 73 82 213 213 3 3 33 87 43 49 76 51 26 36 61 80 56 64 84 64 73 32 73 38 35 71 12 35 31 54 2 50 59 5 86 86 64 67 91 34 40 34 61 88 54 60 94 65 34 69 97 86 76 93 35 38 222 31 26 0 0 255 255 0 93 255 87 2 28 2 200 2 38 0 31 0 0 0 7 4 246 0 10 252 254 255 255 0 80 255 30 2 27 1 242 2 38 0 32 0 0 0 6 5 35 46 0 0 0 255 255 0 80 255 244 2 27 3 9 2 38 0 32 0 0 0 6 4 239 46 0 0 0 255 255 0 80 255 244 2 27 2 228 2 38 0 32 0 0 0 6 4 242 46 0 0 0 255 255 0 80 255 244 2 27 2 234 2 38 0 32 0 0 0 6 5 10 46 0 0 0 255 255 0 80 255 244 2 27 2 204 2 38 0 32 0 0 0 6 4 254 46 0 0 0 0 3 0 54 255 244 2 107 3 48 0 23 0 37 0 42 0 134 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 40 0 38 0 3 43 186 0 13 0 10 0 0 17 18 57 184 0 0 16 184 0 18 208 184 0 18 47 186 0 20 0 0 0 10 17 18 57 184 0 0 16 185 0 24 0 1 244 184 0 20 16 185 0 26 0 1 244 184 0 13 16 185 0 27 0 1 244 184 0 10 16 185 0 30 0 1 244 48 49 23 34 46 2 53 52 62 2 51 50 22 23 51 39 53 51 17 35 39 35 14 1 39 50 55 53 46 1 35 34 14 2 21 20 22 1 3 51 21 7 254 45 74 52 29 35 58 76 41 42 64 32 3 5 79 64 7 3 29 78 27 65 64 32 58 30 30 53 39 23 72 1 85 3 74 14 12 34 65 94 61 59 95 66 36 34 29 90 187 253 56 64 30 46 69 73 242 30 27 27 49 68 42 88 98 1 235 1 12 81 187 0 255 255 0 60 255 42 1 251 2 200 2 38 0 33 0 0 0 7 4 254 0 4 252 222 255 255 0 60 255 87 1 251 2 200 2 38 0 33 0 0 0 7 4 246 0 4 252 254 255 255 0 60 255 30 1 251 2 200 2 38 0 33 0 0 0 6 5 35 252 0 0 0 0 2 0 60 255 244 2 68 2 200 0 31 0 45 0 123 0 184 0 0 69 88 184 0 20 47 27 185 0 20 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 20 16 184 0 19 220 185 0 16 0 1 244 184 0 10 220 184 0 19 16 184 0 22 208 184 0 16 16 184 0 25 208 184 0 0 16 184 0 27 208 184 0 27 47 186 0 28 0 0 0 10 17 18 57 184 0 0 16 185 0 32 0 1 244 184 0 28 16 185 0 34 0 1 244 184 0 10 16 185 0 38 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 51 39 53 35 53 51 53 51 21 51 21 7 17 35 39 35 14 1 39 50 55 53 46 1 35 34 14 2 21 20 22 1 15 48 77 56 30 37 61 80 43 45 68 32 3 4 175 175 82 73 73 68 7 3 30 83 28 72 65 33 63 31 32 56 41 24 75 12 32 63 90 59 57 91 64 34 34 29 90 57 64 86 86 58 6 253 206 64 31 45 69 73 222 31 26 26 46 65 39 83 93 255 255 0 68 255 244 2 26 3 9 2 38 0 34 0 0 0 6 4 236 16 0 0 0 255 255 0 68 255 244 2 26 3 9 2 38 0 34 0 0 0 6 4 239 16 0 0 0 255 255 0 68 255 244 2 26 2 228 2 38 0 34 0 0 0 6 4 242 16 0 0 0 255 255 0 68 255 244 2 26 2 234 2 38 0 34 0 0 0 6 5 10 16 0 0 0 255 255 0 68 255 244 2 26 2 188 2 38 0 34 0 0 0 6 5 0 16 0 0 0 255 255 0 68 255 244 2 26 2 146 2 38 0 34 0 0 0 6 4 246 16 0 0 0 255 255 0 68 255 244 2 26 2 218 2 38 0 34 0 0 0 6 4 250 16 0 0 0 0 2 0 68 255 31 2 26 1 242 0 49 0 58 0 91 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 7 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 3 62 89 187 0 43 0 1 0 0 0 4 43 186 0 27 0 19 0 9 17 18 57 184 0 27 47 184 0 9 16 185 0 31 0 1 244 184 0 19 16 185 0 50 0 1 244 184 0 27 16 185 0 55 0 1 244 48 49 5 34 38 53 52 54 55 14 1 35 34 46 2 53 52 62 2 51 50 30 2 21 20 6 7 33 30 1 51 50 54 55 23 14 3 21 20 22 51 50 54 55 23 14 1 3 34 14 2 7 33 46 1 1 166 45 58 43 33 26 31 8 55 95 71 41 41 69 89 49 52 83 57 30 2 2 254 129 8 105 76 44 71 33 30 38 53 33 14 36 23 17 26 10 24 18 47 133 30 55 44 30 6 1 54 5 77 225 45 48 40 62 29 9 2 34 66 94 60 60 95 66 35 33 60 84 51 14 26 10 83 83 25 21 54 27 43 37 36 19 28 27 12 9 39 17 19 2 146 20 37 56 36 75 74 0 0 255 255 0 68 255 244 2 26 2 204 2 38 0 34 0 0 0 6 4 254 16 0 0 0 255 255 0 68 255 42 2 26 1 242 2 38 0 34 0 0 0 7 4 254 0 16 252 222 255 255 0 68 255 244 2 26 2 248 2 38 0 34 0 0 0 6 5 2 16 0 0 0 255 255 0 68 255 244 2 26 2 209 2 38 0 34 0 0 0 6 4 244 16 0 0 0 255 255 0 68 255 244 2 39 3 17 2 38 0 34 0 0 0 6 5 68 16 0 0 0 255 255 0 68 255 244 2 26 3 17 2 38 0 34 0 0 0 6 5 70 16 0 0 0 255 255 0 68 255 244 2 26 3 23 2 38 0 34 0 0 0 6 5 72 16 0 0 0 255 255 0 68 255 244 2 26 3 35 2 38 0 34 0 0 0 6 5 74 16 0 0 0 255 255 0 68 255 42 2 26 2 228 2 38 0 34 0 0 0 38 4 242 16 0 0 7 4 254 0 16 252 222 0 0 255 255 0 68 255 244 2 26 3 75 2 38 0 34 0 0 0 6 5 86 16 0 0 0 255 255 0 72 255 32 2 54 3 9 2 38 0 36 0 0 0 6 4 239 7 0 0 0 255 255 0 72 255 32 2 54 2 228 2 38 0 36 0 0 0 6 4 242 7 0 0 0 255 255 0 72 255 32 2 54 2 218 2 38 0 36 0 0 0 6 4 250 7 0 0 0 255 255 0 72 255 32 2 54 2 204 2 38 0 36 0 0 0 6 4 254 7 0 0 0 255 255 0 72 255 32 2 54 2 232 2 38 0 36 0 0 0 6 5 34 7 0 0 0 255 255 0 72 255 32 2 54 2 234 2 38 0 36 0 0 0 6 5 10 7 0 0 0 255 255 0 72 255 32 2 54 2 146 2 38 0 36 0 0 0 6 4 246 7 0 0 0 255 255 0 72 255 32 2 54 2 209 2 38 0 36 0 0 0 6 4 244 7 0 0 0 255 255 255 240 0 0 2 11 3 130 2 38 0 37 0 0 0 7 4 243 255 88 0 60 255 255 255 246 0 0 2 11 3 108 2 38 0 37 0 0 0 7 5 1 255 88 0 60 255 255 0 93 255 42 2 11 2 200 2 38 0 37 0 0 0 7 4 254 0 14 252 222 255 255 0 93 255 87 2 11 2 200 2 38 0 37 0 0 0 7 4 246 0 14 252 254 255 255 0 40 255 30 2 11 2 200 2 38 0 37 0 0 0 7 5 35 255 91 0 0 255 255 0 93 255 26 2 11 2 200 2 38 0 37 0 0 0 7 4 250 0 14 252 223 0 1 0 20 0 0 2 11 2 200 0 31 0 89 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 5 16 184 0 7 220 185 0 10 0 1 244 184 0 1 208 184 0 7 16 184 0 4 208 184 0 10 16 184 0 16 220 184 0 0 16 184 0 20 208 184 0 16 16 185 0 25 0 1 244 48 49 51 17 35 53 55 53 51 21 51 21 35 21 7 51 62 1 51 50 22 21 17 35 17 52 38 35 34 14 2 7 17 93 73 73 82 213 213 5 3 38 87 57 87 81 82 52 60 22 37 36 38 21 2 50 58 6 86 86 64 64 115 41 54 99 97 254 230 1 15 69 67 11 22 33 22 254 193 255 255 0 90 0 0 1 156 3 9 2 38 1 87 0 0 0 6 4 236 48 0 0 0 255 255 0 90 0 0 1 228 3 9 2 38 1 87 0 0 0 6 4 239 48 0 0 0 255 255 0 90 0 0 1 247 2 228 2 38 1 87 0 0 0 6 4 242 48 0 0 0 255 255 0 90 0 0 2 9 2 209 2 38 1 87 0 0 0 6 4 244 48 0 0 0 255 255 0 90 0 0 1 244 2 188 2 38 1 87 0 0 0 6 5 0 48 0 0 0 255 255 0 90 0 0 1 225 2 146 2 38 1 87 0 0 0 6 4 246 48 0 0 0 255 255 0 90 0 0 1 247 2 234 2 38 1 87 0 0 0 6 5 10 48 0 0 0 255 255 0 90 255 31 1 190 2 204 2 38 2 79 0 0 0 6 4 254 48 0 0 0 255 255 0 90 0 0 1 172 2 248 2 38 1 87 0 0 0 6 5 2 48 0 0 0 255 255 0 90 255 42 1 158 2 204 2 38 1 87 0 0 0 38 4 254 48 0 0 7 4 254 0 48 252 222 0 0 255 255 0 90 0 0 1 248 2 218 2 38 1 87 0 0 0 6 4 250 48 0 0 0 0 1 0 90 0 0 1 142 1 230 0 5 0 47 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 3 16 185 0 1 0 1 244 48 49 33 17 35 53 33 17 1 60 226 1 52 1 163 67 254 26 0 0 0 255 255 0 55 255 39 1 247 2 228 2 38 1 209 0 0 0 6 4 242 48 0 0 0 255 255 0 106 255 30 2 62 2 200 2 38 0 40 0 0 0 6 5 33 35 0 0 0 255 255 0 106 255 42 2 62 2 200 2 38 0 40 0 0 0 7 4 254 0 35 252 222 255 255 0 106 255 87 2 62 2 200 2 38 0 40 0 0 0 7 4 246 0 35 252 254 0 1 0 106 0 0 2 62 1 230 0 12 0 83 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 3 0 1 0 0 17 18 57 184 0 1 16 184 0 6 208 186 0 7 0 0 0 1 17 18 57 184 0 0 16 184 0 8 208 186 0 10 0 1 0 0 17 18 57 48 49 51 17 51 17 55 37 51 7 19 35 39 7 21 106 82 3 1 7 94 194 220 92 179 115 1 230 255 0 1 255 193 254 219 240 110 130 0 0 0 255 255 0 81 255 244 2 25 3 159 2 38 0 41 0 0 0 6 4 240 242 60 0 0 255 255 0 81 255 244 2 25 3 48 2 38 0 41 0 0 0 7 5 12 0 146 0 0 255 255 0 81 255 30 2 25 2 200 2 38 0 41 0 0 0 6 5 33 85 0 0 0 255 255 0 81 255 42 2 25 2 200 2 38 0 41 0 0 0 7 4 254 0 85 252 222 255 255 0 81 255 42 2 25 3 84 2 38 0 41 0 0 0 38 4 247 242 60 0 7 4 254 0 85 252 222 0 0 255 255 0 81 255 87 2 25 2 200 2 38 0 41 0 0 0 7 4 246 0 85 252 254 0 1 0 81 255 244 2 25 2 200 0 24 0 57 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 8 0 1 244 184 0 0 16 185 0 19 0 1 244 48 49 5 34 38 61 1 7 39 55 53 35 53 51 17 55 23 7 21 20 22 51 50 55 23 14 1 1 151 78 82 108 29 137 166 248 148 28 176 52 44 43 48 21 34 56 12 88 87 171 64 54 80 241 67 254 243 84 54 100 216 54 47 22 61 14 15 255 255 0 43 255 244 2 123 2 200 2 38 0 41 218 0 0 7 4 254 1 13 254 210 255 255 0 58 0 0 2 46 3 9 2 38 0 42 0 0 0 6 4 239 15 0 0 0 255 255 0 58 0 0 2 46 2 204 2 38 0 42 0 0 0 6 4 254 15 0 0 0 255 255 0 58 255 42 2 46 1 242 2 38 0 42 0 0 0 7 4 254 0 8 252 222 255 255 0 93 0 0 2 11 3 9 2 38 0 43 0 0 0 6 4 239 18 0 0 0 255 255 0 93 0 0 2 11 3 9 2 38 0 43 0 0 0 6 4 236 18 0 0 0 255 255 0 93 0 0 2 11 2 234 2 38 0 43 0 0 0 6 5 10 18 0 0 0 255 255 0 93 0 0 2 11 2 209 2 38 0 43 0 0 0 6 4 244 18 0 0 0 255 255 0 93 255 30 2 11 1 242 2 38 0 43 0 0 0 6 5 33 13 0 0 0 255 255 0 93 0 0 2 11 2 204 2 38 0 43 0 0 0 6 4 254 18 0 0 0 255 255 0 93 255 42 2 11 1 242 2 38 0 43 0 0 0 7 4 254 0 13 252 222 255 255 0 93 255 87 2 11 1 242 2 38 0 43 0 0 0 7 4 246 0 13 252 254 0 2 255 234 0 0 2 86 2 187 0 20 0 38 0 95 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 33 0 27 0 3 43 184 0 7 16 184 0 2 208 184 0 2 47 186 0 3 0 7 0 0 17 18 57 184 0 0 16 184 0 11 208 184 0 7 16 185 0 16 0 1 244 184 0 3 16 185 0 19 0 1 244 48 49 51 17 51 23 51 62 1 51 50 22 21 17 35 17 52 38 35 34 6 7 17 1 39 62 1 55 6 35 34 38 53 52 54 51 50 22 21 20 6 196 68 7 4 35 80 53 79 76 83 46 52 39 61 39 254 240 28 47 54 3 12 14 32 39 42 32 40 50 76 1 230 76 37 51 96 94 254 204 1 41 66 64 41 40 254 166 1 94 48 26 79 53 6 39 32 35 43 64 57 75 118 255 255 0 60 255 244 2 28 3 9 2 38 0 44 0 0 0 6 4 236 0 0 0 0 255 255 0 60 255 244 2 28 3 9 2 38 0 44 0 0 0 6 4 239 0 0 0 0 255 255 0 60 255 244 2 28 2 228 2 38 0 44 0 0 0 6 4 242 0 0 0 0 255 255 0 60 255 244 2 28 2 209 2 38 0 44 0 0 0 6 4 244 0 0 0 0 255 255 0 60 255 244 2 28 2 188 2 38 0 44 0 0 0 6 5 0 0 0 0 0 255 255 0 60 255 244 2 28 2 146 2 38 0 44 0 0 0 6 4 246 0 0 0 0 255 255 0 60 255 244 2 28 2 249 2 38 0 44 0 0 0 6 5 8 0 0 0 0 255 255 0 60 255 244 2 28 2 234 2 38 0 44 0 0 0 6 5 10 0 0 0 0 0 2 0 60 255 31 2 28 1 242 0 38 0 58 0 75 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 7 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 3 62 89 187 0 32 0 1 0 0 0 4 43 184 0 6 16 184 0 26 208 184 0 6 16 185 0 39 0 1 244 184 0 16 16 185 0 49 0 1 244 48 49 5 34 38 53 52 54 55 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 14 1 21 20 22 51 50 54 55 23 14 1 3 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 68 43 58 42 26 50 85 61 35 39 66 87 48 48 87 66 39 24 45 63 39 41 44 36 21 19 26 9 24 17 47 55 35 57 41 22 22 41 57 35 35 57 41 22 22 41 57 225 45 48 39 61 21 2 38 65 92 56 61 95 66 34 34 66 95 61 51 76 58 43 17 18 64 31 29 26 13 8 39 16 20 1 24 27 49 69 42 42 69 50 27 27 50 69 42 42 69 49 27 0 0 0 255 255 0 60 255 42 2 28 1 242 2 38 0 44 0 0 0 7 4 254 0 0 252 222 255 255 0 60 255 244 2 28 2 248 2 38 0 44 0 0 0 6 5 2 0 0 0 0 255 255 0 60 255 244 2 28 3 17 2 38 0 44 0 0 0 6 5 68 0 0 0 0 255 255 0 53 255 244 2 28 3 17 2 38 0 44 0 0 0 6 5 70 0 0 0 0 255 255 0 60 255 244 2 28 3 23 2 38 0 44 0 0 0 6 5 72 0 0 0 0 255 255 0 60 255 244 2 28 3 35 2 38 0 44 0 0 0 6 5 74 0 0 0 0 255 255 0 60 255 42 2 28 2 228 2 38 0 44 0 0 0 38 4 242 0 0 0 7 4 254 0 0 252 222 0 0 255 255 0 60 255 244 2 28 2 218 2 38 0 44 0 0 0 6 4 250 0 0 0 0 255 255 0 60 255 244 2 28 3 75 2 38 0 44 0 0 0 6 5 86 0 0 0 0 0 2 0 60 255 244 2 47 2 152 0 34 0 54 0 75 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 184 0 19 220 184 0 10 16 185 0 45 0 1 244 186 0 27 0 10 0 45 17 18 57 184 0 0 16 185 0 35 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 23 62 1 53 52 38 39 55 30 1 21 20 14 2 7 30 1 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 44 48 87 66 39 39 66 87 48 54 47 42 44 7 8 64 11 12 17 29 39 22 40 48 39 66 87 48 35 57 41 22 22 41 57 35 35 57 41 22 22 41 57 12 34 65 95 60 61 95 66 34 21 9 47 43 15 31 12 30 17 42 23 29 45 33 23 7 32 102 69 60 95 65 34 68 27 49 68 42 42 69 50 27 27 50 69 42 42 68 49 27 0 255 255 0 60 255 244 2 47 3 9 2 38 1 131 0 0 0 6 4 239 0 0 0 0 255 255 0 60 255 244 2 47 3 9 2 38 1 131 0 0 0 6 4 236 0 0 0 0 255 255 0 60 255 244 2 47 2 248 2 38 1 131 0 0 0 6 5 2 0 0 0 0 255 255 0 60 255 244 2 47 2 209 2 38 1 131 0 0 0 6 4 244 237 0 0 0 255 255 0 60 255 42 2 47 2 152 2 38 1 131 0 0 0 7 4 254 0 0 252 222 0 3 0 60 255 226 2 28 2 4 0 25 0 35 0 46 0 137 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 28 0 13 0 0 17 18 57 186 0 2 0 0 0 28 17 18 57 186 0 5 0 28 0 0 17 18 57 186 0 43 0 0 0 13 17 18 57 186 0 15 0 43 0 13 17 18 57 186 0 18 0 13 0 43 17 18 57 186 0 29 0 13 0 0 17 18 57 184 0 13 16 185 0 31 0 1 244 184 0 0 16 185 0 36 0 1 244 186 0 44 0 13 0 0 17 18 57 48 49 5 34 39 7 39 55 46 1 53 52 62 2 51 50 23 55 23 7 30 1 21 20 14 2 39 20 23 19 38 35 34 14 2 23 50 62 2 53 52 39 3 30 1 1 44 79 61 52 46 53 26 29 39 66 87 48 79 61 52 46 53 26 29 39 66 87 203 23 224 38 54 35 57 41 22 155 35 57 41 22 23 225 19 47 12 43 61 42 62 32 84 52 61 95 66 34 43 61 42 62 32 85 53 60 95 65 34 254 60 46 1 7 33 28 50 70 230 28 49 69 42 63 44 254 249 15 17 0 0 255 255 0 60 255 226 2 28 3 9 2 38 1 137 0 0 0 6 4 239 0 0 0 0 0 3 0 11 255 244 2 85 1 242 0 15 0 56 0 62 0 109 0 184 0 0 69 88 184 0 26 47 27 185 0 26 0 7 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 3 62 89 185 0 0 0 1 244 184 0 26 16 185 0 10 0 1 244 184 0 26 16 184 0 32 208 186 0 40 0 26 0 16 17 18 57 184 0 40 47 184 0 0 16 184 0 44 208 184 0 16 16 184 0 51 208 184 0 10 16 184 0 57 208 184 0 40 16 185 0 60 0 1 244 48 49 55 50 62 2 53 52 46 2 35 34 6 21 20 22 23 34 46 2 53 52 62 2 51 50 22 23 62 1 51 50 30 2 21 20 6 7 35 30 1 51 50 54 55 23 14 1 35 34 38 39 14 1 19 34 6 7 51 38 188 22 35 25 14 14 25 35 22 49 51 51 44 37 63 46 26 26 47 63 37 46 65 20 20 71 47 36 54 36 18 2 2 246 5 65 49 26 40 20 30 23 61 35 49 78 20 21 66 217 39 54 5 182 4 56 27 50 68 42 42 68 50 27 103 85 84 102 68 34 65 95 60 61 95 66 34 58 62 62 58 36 60 81 45 14 29 13 84 81 18 14 56 18 25 56 61 61 56 1 189 74 75 149 0 0 0 255 255 0 146 0 0 2 25 3 9 2 38 0 47 0 0 0 6 4 239 46 0 0 0 255 255 0 103 255 30 2 25 1 242 2 38 0 47 0 0 0 6 5 33 154 0 0 0 255 255 0 146 0 0 2 25 2 234 2 38 0 47 0 0 0 6 5 10 46 0 0 0 255 255 0 146 0 0 2 25 2 204 2 38 0 47 0 0 0 6 4 254 46 0 0 0 255 255 0 132 255 42 2 25 1 242 2 38 0 47 0 0 0 7 4 254 255 154 252 222 255 255 0 132 255 42 2 25 2 146 2 38 0 47 0 0 0 38 4 246 46 0 0 7 4 254 255 154 252 222 0 0 255 255 0 65 255 87 2 25 1 242 2 38 0 47 0 0 0 7 4 246 255 154 252 254 255 255 0 71 255 244 2 14 3 9 2 38 0 48 0 0 0 6 4 239 3 0 0 0 255 255 0 71 255 244 2 14 2 228 2 38 0 48 0 0 0 6 4 242 3 0 0 0 255 255 0 71 255 244 2 14 2 234 2 38 0 48 0 0 0 6 5 10 3 0 0 0 255 255 0 71 255 244 2 14 3 45 2 38 0 48 0 0 0 6 5 88 3 0 0 0 255 255 0 71 255 30 2 14 1 242 2 38 0 48 0 0 0 6 5 35 14 0 0 0 255 255 0 71 255 30 2 14 1 242 2 38 0 48 0 0 0 6 5 33 9 0 0 0 255 255 0 71 255 244 2 14 2 204 2 38 0 48 0 0 0 6 4 254 3 0 0 0 255 255 0 71 255 42 2 14 1 242 2 38 0 48 0 0 0 7 4 254 0 9 252 222 0 1 0 88 255 244 2 52 2 212 0 57 0 85 0 184 0 0 69 88 184 0 36 47 27 185 0 36 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 184 0 36 16 185 0 25 0 1 244 186 0 10 0 0 0 25 17 18 57 184 0 0 16 184 0 30 208 184 0 30 47 186 0 46 0 36 0 7 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 46 4 53 52 62 2 53 52 38 35 34 6 21 17 35 17 52 62 2 51 50 30 2 21 20 14 2 21 20 30 4 21 20 14 2 1 145 42 70 32 33 28 52 29 42 45 30 45 52 45 30 28 34 28 44 42 55 63 82 28 52 74 47 40 61 42 21 28 34 28 30 44 53 44 30 23 43 60 12 24 21 58 20 19 47 31 29 38 29 25 33 45 35 34 49 45 47 32 37 49 75 75 254 5 2 7 46 76 54 29 24 41 53 30 38 53 44 41 26 24 32 27 26 36 53 39 32 54 40 23 0 0 0 0 1 0 103 0 0 2 66 2 212 0 18 0 74 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 7 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 4 16 185 0 1 0 1 244 184 0 8 16 185 0 14 0 1 244 48 49 51 17 35 53 55 53 52 54 51 50 23 7 46 1 35 34 6 21 17 242 139 139 95 101 72 68 19 30 51 32 66 57 1 163 62 5 41 89 108 28 62 14 9 67 60 253 238 0 255 255 0 69 255 244 2 34 3 48 2 38 0 49 0 0 0 7 5 12 0 141 0 0 255 255 0 69 255 30 2 34 2 130 2 38 0 49 0 0 0 6 5 35 89 0 0 0 255 255 0 69 255 30 2 34 2 130 2 38 0 49 0 0 0 6 5 33 79 0 0 0 255 255 0 69 255 42 2 34 2 130 2 38 0 49 0 0 0 7 4 254 0 79 252 222 255 255 0 69 255 87 2 34 2 130 2 38 0 49 0 0 0 7 4 246 0 79 252 254 255 255 0 69 255 244 2 34 3 67 2 38 0 49 0 0 0 7 5 0 255 219 0 135 0 1 0 69 255 244 2 34 2 130 0 35 0 105 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 7 62 89 184 0 0 69 88 184 0 29 47 27 185 0 29 0 3 62 89 186 0 15 0 6 0 29 17 18 57 184 0 15 47 184 0 0 208 184 0 15 16 185 0 14 0 1 244 184 0 2 208 184 0 6 16 185 0 3 0 1 244 184 0 6 16 184 0 10 208 184 0 3 16 184 0 11 208 184 0 29 16 185 0 22 0 1 244 48 49 55 53 55 53 35 53 63 1 51 21 51 21 35 21 51 21 35 21 20 30 2 51 50 54 55 23 14 1 35 34 46 2 61 1 70 136 137 140 11 68 239 239 220 220 12 28 48 35 35 56 26 18 33 73 46 53 72 44 19 220 58 6 135 62 5 156 156 67 135 64 32 33 49 34 17 12 10 60 12 17 29 53 74 45 31 255 255 0 77 255 244 1 249 3 9 2 38 0 50 0 0 0 6 4 236 252 0 0 0 255 255 0 77 255 244 1 249 3 9 2 38 0 50 0 0 0 6 4 239 252 0 0 0 255 255 0 77 255 244 1 249 2 228 2 38 0 50 0 0 0 6 4 242 252 0 0 0 255 255 0 77 255 244 1 249 2 209 2 38 0 50 0 0 0 6 4 244 252 0 0 0 255 255 0 77 255 244 1 249 2 188 2 38 0 50 0 0 0 6 5 0 252 0 0 0 255 255 0 77 255 244 1 249 2 146 2 38 0 50 0 0 0 6 4 246 252 0 0 0 255 255 0 77 255 244 1 249 2 218 2 38 0 50 0 0 0 6 4 250 252 0 0 0 255 255 0 77 255 244 1 249 2 249 2 38 0 50 0 0 0 6 5 6 252 0 0 0 255 255 0 77 255 244 1 249 2 249 2 38 0 50 0 0 0 6 5 8 252 0 0 0 255 255 0 77 255 244 1 249 2 234 2 38 0 50 0 0 0 6 5 10 252 0 0 0 0 1 0 77 255 31 2 27 1 230 0 38 0 105 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 7 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 3 62 89 187 0 32 0 1 0 0 0 4 43 184 0 11 16 184 0 6 208 184 0 6 47 186 0 8 0 15 0 11 17 18 57 184 0 11 16 185 0 20 0 1 244 184 0 8 16 185 0 23 0 1 244 184 0 15 16 184 0 25 208 184 0 6 16 184 0 26 208 48 49 5 34 38 53 52 54 55 39 35 14 1 35 34 38 53 17 51 17 20 22 51 50 54 55 17 51 17 14 1 21 20 22 51 50 54 55 23 14 1 1 190 44 59 56 39 7 4 37 87 57 88 81 83 51 61 42 68 41 82 54 47 36 23 17 26 9 24 17 47 225 45 48 43 65 24 85 43 54 99 97 1 46 254 221 69 67 43 47 1 81 254 21 24 58 29 28 27 12 9 39 17 19 0 0 0 255 255 0 77 255 244 1 249 3 29 2 38 0 50 0 0 0 6 5 64 252 0 0 0 255 255 0 77 255 244 1 249 3 76 2 38 0 50 0 0 0 6 5 57 252 0 0 0 255 255 0 77 255 244 1 249 3 72 2 38 0 50 0 0 0 6 5 66 252 0 0 0 255 255 0 77 255 244 1 249 3 76 2 38 0 50 0 0 0 6 5 60 252 0 0 0 255 255 0 77 255 42 1 249 1 230 2 38 0 50 0 0 0 7 4 254 0 7 252 222 255 255 0 77 255 244 1 249 2 248 2 38 0 50 0 0 0 6 5 2 252 0 0 0 0 1 0 77 255 244 2 86 2 158 0 37 0 99 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 9 0 1 244 184 0 4 16 184 0 13 208 186 0 34 0 0 0 13 17 18 57 184 0 34 16 185 0 12 0 1 244 184 0 13 16 184 0 23 220 184 0 13 16 184 0 31 220 184 0 0 16 184 0 33 208 184 0 33 47 48 49 23 34 38 53 17 51 17 20 22 51 50 54 55 17 51 62 3 53 52 38 39 55 30 1 21 20 14 2 7 17 35 39 35 14 1 246 88 81 83 51 61 42 68 41 16 18 31 24 13 6 8 64 11 12 16 26 33 18 67 7 4 37 87 12 99 97 1 46 254 221 69 67 43 47 1 81 3 12 22 34 25 15 31 12 30 17 42 23 29 43 31 21 7 254 55 85 43 54 0 255 255 0 77 255 244 2 86 3 9 2 38 1 181 0 0 0 6 4 239 252 0 0 0 255 255 0 77 255 244 2 86 3 9 2 38 1 181 0 0 0 6 4 236 252 0 0 0 255 255 0 77 255 244 2 86 2 248 2 38 1 181 0 0 0 6 5 2 252 0 0 0 255 255 0 77 255 244 2 86 2 209 2 38 1 181 0 0 0 6 4 244 244 0 0 0 255 255 0 77 255 42 2 86 2 158 2 38 1 181 0 0 0 7 4 254 0 7 252 222 255 255 0 51 255 42 2 37 1 230 2 38 0 51 0 0 0 7 4 254 0 0 252 222 255 255 0 8 0 0 2 80 3 9 2 38 0 52 0 0 0 6 4 236 0 0 0 0 255 255 0 8 0 0 2 80 3 9 2 38 0 52 0 0 0 6 4 239 0 0 0 0 255 255 0 8 0 0 2 80 2 228 2 38 0 52 0 0 0 6 4 242 0 0 0 0 255 255 0 8 0 0 2 80 2 188 2 38 0 52 0 0 0 6 5 0 0 0 0 0 255 255 0 49 255 47 2 39 3 9 2 38 0 54 0 0 0 6 4 236 4 0 0 0 255 255 0 49 255 47 2 39 3 9 2 38 0 54 0 0 0 6 4 239 4 0 0 0 255 255 0 49 255 47 2 39 2 228 2 38 0 54 0 0 0 6 4 242 4 0 0 0 255 255 0 49 255 47 2 39 2 188 2 38 0 54 0 0 0 6 5 0 4 0 0 0 255 255 0 49 255 47 2 39 2 204 2 38 0 54 0 0 0 6 4 254 4 0 0 0 255 255 0 49 255 46 2 39 1 230 2 38 0 54 0 0 0 7 4 254 0 158 252 226 255 255 0 49 255 47 2 39 2 248 2 38 0 54 0 0 0 6 5 2 4 0 0 0 255 255 0 49 255 47 2 39 2 209 2 38 0 54 0 0 0 6 4 244 4 0 0 0 255 255 0 71 0 0 2 19 3 9 2 38 0 55 0 0 0 6 4 239 22 0 0 0 255 255 0 71 0 0 2 19 2 234 2 38 0 55 0 0 0 6 5 10 22 0 0 0 255 255 0 71 0 0 2 19 2 204 2 38 0 55 0 0 0 6 4 254 22 0 0 0 255 255 0 71 0 0 2 19 2 228 2 38 0 55 0 0 0 6 4 242 22 0 0 0 255 255 0 71 255 42 2 19 1 230 2 38 0 55 0 0 0 7 4 254 0 14 252 222 255 255 0 71 255 87 2 19 1 230 2 38 0 55 0 0 0 7 4 246 0 14 252 254 0 2 0 60 255 244 2 24 2 218 0 36 0 57 0 77 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 10 0 1 0 48 0 4 43 186 0 13 0 23 0 0 17 18 57 184 0 0 16 185 0 37 0 1 244 184 0 13 16 185 0 45 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 46 1 39 7 39 55 46 1 39 55 30 1 23 55 23 7 30 1 21 20 14 2 39 50 62 2 53 60 1 39 46 1 35 34 14 2 21 20 30 2 1 42 47 86 66 39 34 61 83 50 47 84 28 14 57 44 152 30 130 26 57 32 38 38 73 33 137 30 118 63 77 33 62 88 53 40 59 39 19 1 35 82 39 40 61 41 21 26 44 60 12 32 61 87 54 51 83 59 32 42 38 66 100 39 78 52 66 18 32 16 52 18 41 25 70 50 61 61 168 119 60 99 71 39 68 29 53 72 44 11 22 11 47 38 24 44 59 34 38 61 43 24 0 0 2 0 93 255 51 2 28 2 200 0 24 0 39 0 127 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 15 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 3 62 89 186 0 4 0 8 0 18 17 18 57 186 0 21 0 18 0 8 17 18 57 185 0 25 0 1 244 184 0 8 16 185 0 33 0 1 244 184 0 4 16 185 0 36 0 1 244 184 0 21 16 185 0 37 0 1 244 48 49 23 17 51 21 7 51 62 1 51 50 30 2 21 20 14 2 35 34 38 39 35 23 21 19 50 62 2 53 52 38 35 34 6 7 21 30 1 93 82 3 3 34 85 43 49 76 51 27 37 61 80 43 36 76 32 3 3 130 32 55 40 23 65 73 32 72 38 35 69 205 3 149 201 87 34 40 35 65 91 57 62 97 68 35 34 29 92 164 1 6 27 49 72 45 80 99 35 38 242 31 26 0 1 0 93 255 73 2 11 1 242 0 34 0 102 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 7 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 184 0 28 16 185 0 14 0 1 244 186 0 24 0 28 0 21 17 18 57 184 0 24 16 185 0 19 0 1 244 184 0 28 16 184 0 22 208 184 0 22 47 48 49 5 34 38 39 55 30 1 51 50 54 53 17 52 38 35 34 14 2 7 17 35 17 51 23 51 62 1 51 50 22 21 17 20 6 1 131 23 39 14 16 11 26 14 38 25 52 60 22 37 36 38 21 82 68 7 4 38 88 57 87 81 63 183 9 5 63 4 6 54 48 1 49 69 67 11 22 33 22 254 173 1 230 83 41 54 99 97 254 196 78 91 0 0 1 0 55 255 39 1 142 1 230 0 21 0 53 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 184 0 15 16 185 0 13 0 1 244 48 49 23 34 38 39 55 30 1 51 50 62 2 53 17 35 53 33 17 20 14 2 194 38 72 29 27 26 57 28 36 48 28 11 226 1 52 20 47 78 217 19 14 61 13 14 18 34 49 31 1 181 67 254 14 45 75 55 30 0 4 0 93 255 39 2 12 2 190 0 3 0 15 0 31 0 43 0 96 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 5 62 89 186 0 10 0 4 0 3 43 184 0 16 16 185 0 23 0 1 244 184 0 1 16 184 0 27 208 184 0 4 16 184 0 32 208 184 0 10 16 184 0 38 208 48 49 51 17 51 17 3 34 38 53 52 54 51 50 22 21 20 6 19 34 38 39 55 30 1 51 50 54 53 17 51 17 20 6 19 34 38 53 52 54 51 50 22 21 20 6 112 82 40 26 35 35 26 26 34 34 191 23 35 13 16 10 23 13 37 23 82 60 20 26 35 35 26 26 34 34 1 230 254 26 2 74 32 26 26 32 32 26 26 32 252 221 8 5 62 3 5 50 45 2 29 253 227 74 88 3 35 32 26 26 32 32 26 26 32 0 0 0 0 3 255 248 255 244 2 108 2 200 0 17 0 29 0 47 0 97 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 24 0 18 0 3 43 184 0 6 16 185 0 4 0 1 244 184 0 0 16 185 0 11 0 1 244 184 0 0 16 184 0 30 208 184 0 4 16 184 0 34 208 184 0 6 16 184 0 36 208 184 0 11 16 184 0 41 208 48 49 23 34 38 53 17 35 53 51 17 20 22 51 50 54 55 23 14 1 19 34 38 53 52 54 51 50 22 21 20 6 19 34 38 53 17 35 53 51 17 20 22 51 50 54 55 23 14 1 230 64 67 107 182 36 30 11 22 15 21 20 35 40 33 45 45 33 33 47 47 213 63 67 108 183 36 30 11 22 15 21 20 35 12 88 87 1 226 67 253 213 54 47 8 7 62 8 13 1 28 45 39 39 43 43 39 39 45 254 228 88 87 1 226 67 253 213 54 47 8 7 62 8 13 0 0 0 4 0 80 255 39 2 78 3 9 0 3 0 19 0 23 0 27 0 96 0 184 0 20 47 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 5 62 89 185 0 11 0 1 244 184 0 1 16 184 0 15 208 184 0 20 16 184 0 22 220 184 0 20 16 184 0 24 208 184 0 22 16 184 0 26 208 48 49 51 17 51 17 23 34 38 39 55 30 1 51 50 54 53 17 51 17 20 6 1 39 55 31 1 39 55 23 112 82 177 23 35 13 16 10 23 13 37 23 82 60 254 191 43 142 58 153 43 142 58 1 230 254 26 217 8 5 62 3 5 50 45 2 29 253 227 74 88 3 17 41 168 56 153 41 168 56 0 0 0 2 0 94 255 244 2 17 1 242 0 33 0 47 0 113 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 184 0 5 208 184 0 5 47 186 0 6 0 10 0 0 17 18 57 186 0 20 0 10 0 0 17 18 57 184 0 20 47 184 0 0 16 185 0 25 0 1 244 184 0 20 16 185 0 34 0 1 244 184 0 10 16 185 0 44 0 1 244 184 0 6 16 185 0 47 0 1 244 48 49 5 34 38 53 17 51 23 51 62 1 51 50 30 2 21 20 14 2 7 30 3 51 50 54 55 23 14 3 39 62 3 53 52 46 2 35 34 6 7 1 36 100 98 68 7 3 40 100 51 34 61 45 26 40 85 133 94 1 14 30 48 35 48 89 34 32 18 49 55 62 147 78 104 63 27 18 29 39 21 42 81 42 12 109 91 1 42 66 32 46 18 36 51 33 41 61 44 28 7 25 45 33 20 37 21 56 12 25 20 13 244 6 22 31 39 24 21 29 19 9 37 35 0 0 2 0 93 255 244 2 28 1 242 0 22 0 37 0 117 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 4 0 0 0 13 17 18 57 184 0 5 208 184 0 5 47 184 0 13 16 184 0 8 208 184 0 8 47 186 0 9 0 13 0 0 17 18 57 184 0 0 16 185 0 23 0 1 244 184 0 13 16 185 0 31 0 1 244 184 0 9 16 185 0 34 0 1 244 184 0 4 16 185 0 35 0 1 244 48 49 5 34 38 39 35 7 35 17 51 23 51 62 1 51 50 30 2 21 20 14 2 39 50 62 2 53 52 38 35 34 6 7 21 30 1 1 64 36 80 35 3 7 66 68 7 3 29 90 49 49 75 51 26 36 61 80 57 32 54 40 23 65 73 36 74 32 35 69 12 35 31 54 1 230 64 31 45 35 65 91 56 62 98 68 35 69 26 50 70 44 83 99 37 36 242 32 25 0 0 0 2 0 93 255 244 2 28 2 212 0 36 0 51 0 132 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 15 62 89 184 0 0 69 88 184 0 27 47 27 185 0 27 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 4 0 0 0 27 17 18 57 184 0 6 208 184 0 6 47 184 0 12 16 185 0 19 0 1 244 186 0 24 0 27 0 0 17 18 57 184 0 0 16 185 0 37 0 1 244 184 0 27 16 185 0 45 0 1 244 184 0 24 16 185 0 48 0 1 244 184 0 4 16 185 0 49 0 1 244 48 49 5 34 38 39 35 7 35 17 52 62 2 51 50 22 23 7 46 1 35 34 6 15 1 51 62 1 51 50 30 2 21 20 14 2 39 50 62 2 53 52 38 35 34 6 7 21 30 1 1 65 36 81 35 3 7 66 22 45 68 45 26 48 19 19 17 34 15 54 50 2 4 4 33 87 43 49 76 51 26 36 61 79 57 31 55 39 23 65 72 32 74 37 35 71 12 34 32 54 2 25 42 68 50 27 11 8 63 8 7 62 56 122 34 40 35 63 91 55 62 96 66 35 69 26 49 70 44 79 97 35 38 235 32 25 0 0 0 1 0 61 255 244 2 8 1 242 0 33 0 53 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 184 0 24 16 185 0 17 0 1 244 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 46 2 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 1 1 57 100 39 37 29 77 45 42 68 49 27 26 47 65 39 44 70 31 42 31 95 66 52 93 71 41 41 70 97 12 40 36 53 26 35 27 49 68 42 42 69 50 27 30 26 53 29 42 34 66 95 61 60 95 65 34 0 0 2 0 80 255 154 2 25 1 242 0 10 0 51 0 125 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 7 62 89 184 0 0 69 88 184 0 47 47 27 185 0 47 0 3 62 89 185 0 0 0 1 244 186 0 6 0 23 0 47 17 18 57 184 0 6 47 186 0 9 0 47 0 6 17 18 57 184 0 47 16 184 0 11 220 184 0 6 16 185 0 41 0 1 244 186 0 15 0 41 0 47 17 18 57 184 0 23 16 185 0 30 0 1 244 186 0 38 0 41 0 47 17 18 57 186 0 49 0 47 0 41 17 18 57 48 49 37 50 54 53 52 38 35 34 6 7 22 7 39 62 1 55 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 22 23 62 1 51 50 22 21 20 6 35 34 39 14 1 1 105 55 56 28 32 29 72 34 37 129 67 12 29 17 45 51 43 73 96 53 63 88 32 40 29 69 42 40 68 50 29 31 28 47 102 48 58 62 89 89 67 58 15 25 54 32 25 18 23 44 39 15 156 28 32 59 26 32 101 66 61 95 66 34 40 31 51 27 30 28 50 70 43 45 70 24 52 56 54 45 52 72 23 26 56 0 0 0 0 2 0 60 255 80 2 95 2 200 0 35 0 49 0 137 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 7 62 89 184 0 0 69 88 184 0 24 47 27 185 0 24 0 15 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 4 0 8 0 18 17 18 57 186 0 22 0 18 0 8 17 18 57 185 0 29 0 1 244 184 0 8 16 185 0 36 0 1 244 184 0 4 16 185 0 38 0 1 244 184 0 22 16 185 0 39 0 1 244 184 0 18 16 185 0 42 0 1 244 48 49 5 34 38 53 55 35 14 1 35 34 46 2 53 52 62 2 51 50 22 23 51 39 53 51 17 20 22 51 50 54 55 23 14 1 37 50 55 53 46 1 35 34 14 2 21 20 22 2 34 63 58 2 3 29 81 45 47 77 55 30 37 61 79 43 44 68 32 3 5 83 21 29 10 18 8 16 11 31 254 235 70 64 33 64 31 31 54 41 23 76 176 73 64 100 30 43 34 65 94 61 59 95 66 36 34 29 90 187 253 35 42 46 6 3 63 5 8 233 73 242 31 26 27 49 68 42 88 98 0 0 0 0 2 0 60 255 244 2 98 2 214 0 33 0 47 0 136 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 15 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 12 0 8 0 0 17 18 57 184 0 17 16 185 0 24 0 1 244 184 0 0 16 184 0 29 208 184 0 29 47 186 0 30 0 0 0 8 17 18 57 184 0 0 16 185 0 34 0 1 244 184 0 30 16 185 0 36 0 1 244 184 0 12 16 185 0 37 0 1 244 184 0 8 16 185 0 40 0 1 244 48 49 5 34 38 53 52 62 2 51 50 22 23 51 39 53 52 54 51 50 22 23 7 46 1 35 34 6 21 17 35 39 35 14 1 39 50 55 53 46 1 35 34 14 2 21 20 22 1 13 95 114 36 61 79 43 43 69 32 3 2 64 66 17 28 11 16 7 15 9 33 26 68 7 3 29 83 27 70 65 33 64 32 30 54 41 23 75 12 132 122 59 95 66 36 33 30 90 56 68 77 5 5 63 2 4 50 42 253 201 64 31 45 69 73 242 31 26 27 49 68 42 88 98 0 0 0 2 0 63 255 244 2 19 1 242 0 6 0 37 0 77 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 7 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 3 62 89 184 0 28 16 185 0 0 0 1 244 186 0 20 0 28 0 7 17 18 57 184 0 20 47 185 0 4 0 1 244 184 0 7 16 185 0 14 0 1 244 48 49 1 34 6 7 33 46 1 3 34 38 39 55 30 1 51 50 62 2 55 33 46 1 53 52 62 2 51 50 30 2 21 20 14 2 1 34 63 84 6 1 54 11 86 80 59 92 36 29 34 71 44 37 66 50 31 4 254 129 2 1 33 61 86 52 48 86 64 38 41 71 95 1 177 74 75 72 77 254 67 34 23 54 21 24 21 42 62 41 9 28 13 51 84 60 33 35 66 95 60 60 94 65 35 0 2 0 60 255 244 1 251 1 242 0 22 0 36 0 121 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 13 0 10 0 0 17 18 57 184 0 10 16 184 0 16 208 184 0 16 47 184 0 0 16 184 0 17 208 184 0 17 47 186 0 19 0 0 0 10 17 18 57 184 0 0 16 185 0 23 0 1 244 184 0 19 16 185 0 25 0 1 244 184 0 13 16 185 0 26 0 1 244 184 0 10 16 185 0 29 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 51 55 51 17 35 39 35 14 1 39 50 55 53 46 1 35 34 14 2 21 20 22 1 14 47 77 56 30 36 62 80 44 43 72 34 3 7 66 68 7 3 29 84 28 72 65 33 63 32 32 55 41 24 75 12 34 65 94 61 59 95 66 36 34 32 54 254 26 64 31 45 69 73 242 31 26 27 49 68 42 88 98 0 255 255 0 115 0 0 2 38 1 230 2 6 3 17 11 0 0 2 0 69 255 244 2 25 1 242 0 28 0 35 0 81 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 9 0 19 0 0 17 18 57 184 0 9 47 184 0 19 16 185 0 12 0 1 244 184 0 0 16 185 0 29 0 1 244 184 0 9 16 185 0 33 0 1 244 48 49 5 34 46 2 53 52 54 55 33 46 1 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 39 50 54 55 33 30 1 1 41 55 85 58 30 2 2 1 125 8 92 75 44 72 33 30 37 92 59 55 92 66 36 37 65 88 52 66 85 8 254 201 5 79 12 35 62 87 52 13 28 9 79 80 25 21 54 23 34 35 65 94 60 61 95 66 34 66 78 78 78 78 0 0 0 0 2 0 22 255 244 2 109 1 242 0 44 0 56 0 127 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 26 0 1 0 33 0 4 43 186 0 5 0 16 0 0 17 18 57 186 0 6 0 0 0 16 17 18 57 184 0 16 16 185 0 9 0 1 244 186 0 19 0 16 0 0 17 18 57 186 0 37 0 0 0 16 17 18 57 184 0 0 16 185 0 45 0 1 244 186 0 53 0 16 0 0 17 18 57 186 0 54 0 0 0 16 17 18 57 48 49 23 34 46 2 39 37 46 1 35 34 6 7 39 62 1 51 50 22 23 55 23 30 3 51 50 54 55 23 14 1 35 34 38 39 7 30 1 21 20 14 2 39 50 62 2 53 52 38 39 7 30 1 217 46 70 48 27 4 1 49 17 67 43 38 56 26 29 32 75 49 68 100 25 73 43 2 8 12 16 11 10 18 6 22 11 31 20 29 53 10 53 2 3 29 53 74 47 28 47 32 18 1 1 245 14 63 12 33 56 76 44 131 56 49 23 18 56 23 27 70 69 32 17 29 35 20 7 10 5 43 9 16 40 54 22 16 33 17 54 91 66 37 65 24 44 62 37 14 24 12 104 60 53 0 1 0 91 255 244 2 23 1 242 0 44 0 87 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 31 0 17 0 0 17 18 57 184 0 31 47 185 0 30 0 1 244 186 0 8 0 30 0 31 17 18 57 184 0 17 16 185 0 24 0 1 244 184 0 0 16 185 0 38 0 1 244 48 49 5 34 46 2 53 52 54 55 53 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 59 1 21 35 34 6 21 20 22 51 50 54 55 23 14 1 1 62 51 83 60 33 66 48 42 47 31 56 77 46 61 97 39 33 35 75 50 64 68 147 53 67 77 81 82 76 49 83 36 36 46 105 12 19 38 55 35 52 56 13 4 16 56 36 33 49 32 16 34 28 54 24 27 37 38 74 64 36 42 43 45 27 32 54 40 31 0 0 255 255 0 62 255 244 2 1 1 242 2 6 3 22 0 0 0 2 0 61 255 244 2 25 1 242 0 26 0 49 0 87 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 34 0 10 0 0 17 18 57 184 0 34 47 185 0 35 0 1 244 186 0 19 0 35 0 34 17 18 57 184 0 0 16 185 0 27 0 1 244 184 0 10 16 185 0 42 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 6 7 21 30 3 21 20 6 39 50 54 53 52 38 43 1 53 51 50 54 53 52 38 35 34 14 2 21 20 22 1 71 57 97 72 40 43 72 94 51 40 70 52 29 42 42 22 40 30 17 113 96 61 66 71 54 35 27 52 58 59 49 38 66 48 28 99 12 32 64 95 62 63 97 64 33 16 32 50 33 36 58 14 4 5 20 30 40 26 70 76 66 45 42 40 39 64 40 34 38 37 26 49 72 45 93 94 0 1 0 55 255 39 2 52 1 230 0 29 0 83 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 13 0 1 0 16 0 4 43 184 0 0 16 185 0 7 0 1 244 184 0 19 16 185 0 17 0 1 244 184 0 16 16 184 0 22 208 184 0 13 16 184 0 23 208 48 49 23 34 38 39 55 30 1 51 50 62 2 61 1 35 53 55 53 35 53 33 21 51 21 35 21 20 14 2 194 38 72 29 27 26 57 28 36 48 28 11 194 194 226 1 52 166 166 20 47 78 217 19 14 61 13 14 18 34 49 31 224 60 6 147 67 214 66 218 45 75 55 30 0 0 0 0 2 0 60 255 40 2 99 2 117 0 45 0 59 0 127 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 39 0 1 0 33 0 4 43 184 0 0 16 185 0 7 0 1 244 186 0 15 0 25 0 0 17 18 57 186 0 11 0 15 0 25 17 18 57 186 0 29 0 25 0 15 17 18 57 184 0 15 16 185 0 46 0 1 244 184 0 11 16 185 0 48 0 1 244 184 0 29 16 185 0 49 0 1 244 184 0 25 16 185 0 52 0 1 244 48 49 5 34 38 39 55 30 1 51 50 54 63 1 35 14 1 35 34 46 2 53 52 62 2 51 50 22 23 51 39 52 54 51 50 22 23 7 38 35 34 6 21 17 20 6 3 50 55 53 46 1 35 34 14 2 21 20 22 1 23 48 95 41 31 37 79 37 70 72 1 4 3 28 81 45 47 77 55 30 37 61 80 43 43 70 29 3 2 63 68 17 28 11 16 14 17 33 26 120 97 69 65 33 64 31 31 54 41 23 76 216 27 26 58 24 21 69 59 97 29 41 34 63 91 57 57 92 64 35 34 29 48 66 80 5 5 63 6 50 42 254 18 91 101 1 33 73 226 32 25 26 48 65 39 82 96 0 0 0 2 0 60 255 39 1 251 1 242 0 34 0 48 0 129 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 186 0 15 0 25 0 0 17 18 57 184 0 15 47 186 0 11 0 15 0 25 17 18 57 186 0 29 0 25 0 15 17 18 57 184 0 25 16 184 0 31 208 184 0 31 47 184 0 15 16 185 0 35 0 1 244 184 0 11 16 185 0 37 0 1 244 184 0 29 16 185 0 38 0 1 244 184 0 25 16 185 0 41 0 1 244 48 49 5 34 38 39 55 30 1 51 50 54 63 1 35 14 1 35 34 46 2 53 52 62 2 51 50 22 23 51 55 51 17 20 6 3 50 55 53 46 1 35 34 14 2 21 20 22 1 24 48 97 40 30 38 80 37 70 75 2 2 3 29 82 45 47 77 56 30 36 61 81 44 43 74 32 3 7 66 118 101 70 67 33 64 32 31 55 42 24 77 217 26 26 59 24 21 70 59 97 29 41 34 63 91 57 57 92 64 35 35 31 54 254 7 92 106 1 34 73 226 31 26 26 48 65 39 82 96 0 1 0 78 255 244 2 14 1 242 0 37 0 67 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 33 0 1 0 32 0 4 43 184 0 10 16 185 0 17 0 1 244 184 0 0 16 185 0 27 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 53 35 53 51 21 14 1 1 83 54 95 71 41 43 73 96 54 65 85 30 41 26 61 48 38 67 51 30 27 49 66 39 33 57 21 134 206 31 96 12 33 65 95 62 60 94 66 35 42 28 52 23 34 25 49 71 45 44 70 49 26 20 17 112 59 205 29 40 0 2 0 51 255 32 2 37 1 230 0 28 0 41 0 95 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 14 0 9 0 0 17 18 57 184 0 9 16 184 0 20 208 186 0 35 0 0 0 20 17 18 57 186 0 8 0 14 0 35 17 18 57 186 0 21 0 35 0 14 17 18 57 184 0 0 16 185 0 29 0 1 244 48 49 5 34 38 53 52 62 2 55 3 51 19 30 1 23 51 62 1 55 19 51 3 30 3 21 20 6 39 50 54 53 52 38 39 35 14 1 21 20 22 1 46 56 60 9 17 22 14 197 84 113 14 23 15 4 15 24 14 112 80 193 13 23 17 9 60 56 23 22 24 19 5 18 24 22 224 65 53 18 34 37 43 26 1 178 254 246 35 54 34 34 54 35 1 10 254 78 26 43 37 34 18 53 65 57 34 25 26 59 34 34 61 24 25 34 0 0 0 0 2 0 60 255 244 2 28 1 242 0 35 0 47 0 93 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 15 16 185 0 9 0 1 244 186 0 18 0 15 0 0 17 18 57 184 0 15 16 184 0 21 208 184 0 9 16 184 0 27 208 184 0 0 16 185 0 36 0 1 244 186 0 42 0 0 0 15 17 18 57 48 49 5 34 38 53 52 54 55 46 1 35 34 7 39 62 1 51 50 22 23 62 1 51 50 22 23 7 38 35 34 6 7 30 1 21 20 6 39 50 54 53 52 38 39 14 1 21 20 22 1 44 86 100 72 57 31 50 28 28 20 26 16 45 23 41 75 40 39 76 41 23 45 16 26 20 28 29 49 31 57 72 100 86 50 57 60 47 47 60 57 12 90 79 56 102 48 34 33 14 60 11 11 45 42 42 45 11 11 60 14 33 34 48 102 56 79 90 68 58 45 44 81 40 40 81 44 45 58 0 1 0 77 255 51 1 251 1 230 0 22 0 92 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 7 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 2 0 9 0 5 17 18 57 184 0 5 16 185 0 14 0 1 244 184 0 2 16 185 0 19 0 1 244 184 0 9 16 184 0 21 208 48 49 5 53 55 14 1 35 34 38 53 17 51 17 20 22 51 50 62 2 55 17 51 17 1 169 4 39 88 57 87 81 82 52 60 22 37 36 38 21 82 205 174 114 40 55 99 97 1 46 254 221 69 67 11 22 33 22 1 83 253 77 0 0 0 1 0 93 0 0 2 11 2 212 0 36 0 102 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 15 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 6 16 185 0 13 0 1 244 186 0 17 0 21 0 0 17 18 57 184 0 0 16 184 0 26 208 184 0 21 16 185 0 30 0 1 244 184 0 17 16 185 0 35 0 1 244 48 49 51 17 52 62 2 51 50 22 23 7 46 1 35 34 6 15 1 51 62 1 51 50 22 21 17 35 17 52 38 35 34 14 2 7 17 93 22 45 68 45 26 48 19 19 17 34 15 54 50 2 6 4 38 87 57 87 81 82 52 60 22 37 36 38 21 2 25 42 68 50 27 11 8 63 8 7 62 56 143 40 55 100 97 254 218 1 28 69 66 11 22 32 22 254 180 0 0 1 0 93 255 73 2 11 2 212 0 47 0 117 0 184 0 0 69 88 184 0 27 47 27 185 0 27 0 15 62 89 184 0 0 69 88 184 0 41 47 27 185 0 41 0 7 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 184 0 41 16 185 0 14 0 1 244 186 0 37 0 41 0 21 17 18 57 184 0 37 16 185 0 19 0 1 244 184 0 27 16 185 0 33 0 1 244 48 49 5 34 38 39 55 30 1 51 50 54 53 17 52 38 35 34 14 2 7 17 35 17 52 62 2 51 50 22 23 7 38 35 34 6 15 1 51 62 1 51 50 22 21 17 20 6 1 128 24 40 14 16 11 27 15 40 26 52 60 22 37 36 38 21 82 22 45 68 45 26 47 20 19 35 31 54 50 2 6 4 38 87 57 87 81 63 183 9 5 63 4 6 54 48 1 42 69 66 11 22 32 22 254 180 2 25 42 68 50 27 11 8 63 15 62 56 143 40 55 100 97 254 204 78 91 255 255 0 93 0 0 1 251 1 230 2 6 3 28 0 0 255 255 0 90 0 0 2 52 2 204 2 38 2 81 0 0 0 6 4 254 48 0 0 0 0 1 0 86 0 0 2 2 1 230 0 11 0 65 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 1 0 1 244 184 0 5 16 185 0 4 0 1 244 184 0 7 208 184 0 1 16 184 0 10 208 48 49 51 53 51 17 35 53 33 21 35 17 51 21 86 172 172 1 172 174 174 67 1 96 67 67 254 160 67 0 0 255 255 0 56 255 6 1 226 2 204 2 38 2 83 0 0 0 6 4 254 48 0 0 0 0 1 0 28 255 51 1 238 1 230 0 12 0 92 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 7 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 3 62 89 186 0 1 0 6 0 3 17 18 57 186 0 5 0 6 0 3 17 18 57 186 0 8 0 3 0 6 17 18 57 184 0 6 16 184 0 11 208 48 49 5 17 35 1 35 55 3 51 23 55 53 51 17 1 156 4 254 231 99 218 192 85 159 114 82 205 1 205 255 0 201 1 29 237 105 132 253 77 255 255 0 81 255 244 2 25 2 200 2 38 0 41 0 0 0 7 5 46 255 245 0 142 0 2 0 76 255 244 2 25 2 200 0 31 0 41 0 99 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 15 62 89 184 0 0 69 88 184 0 27 47 27 185 0 27 0 3 62 89 186 0 16 0 12 0 27 17 18 57 184 0 16 47 184 0 0 208 184 0 16 16 185 0 15 0 1 244 184 0 32 208 184 0 37 220 185 0 6 0 1 244 184 0 12 16 185 0 10 0 1 244 184 0 27 16 185 0 21 0 1 244 48 49 19 34 38 53 52 54 51 50 22 23 53 35 53 51 17 51 21 35 21 20 22 51 50 55 23 14 1 35 34 38 61 1 39 51 53 52 38 35 34 6 21 20 232 84 72 51 39 28 39 14 166 248 140 140 52 44 43 48 21 34 56 40 78 82 33 33 35 38 14 18 1 46 59 47 38 48 19 15 185 67 254 166 64 145 54 47 22 61 14 15 88 87 139 64 6 23 41 17 15 38 0 0 1 0 81 255 73 2 25 2 200 0 17 0 57 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 6 16 185 0 4 0 1 244 184 0 0 16 185 0 11 0 1 244 48 49 5 34 38 53 17 35 53 51 17 20 22 51 50 54 55 23 14 1 1 150 78 81 166 248 51 44 21 44 27 21 33 58 183 88 87 2 141 67 253 42 54 46 10 12 62 12 17 0 0 0 1 0 79 255 39 2 59 2 200 0 38 0 115 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 15 62 89 184 0 0 69 88 184 0 26 47 27 185 0 26 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 3 62 89 184 0 0 16 185 0 7 0 1 244 186 0 15 0 26 0 0 17 18 57 184 0 15 47 184 0 26 16 185 0 20 0 1 244 184 0 15 16 185 0 29 0 1 244 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 39 19 33 17 35 17 51 21 33 21 7 54 30 2 21 20 14 2 1 102 75 97 31 41 26 73 56 28 50 37 21 70 62 26 27 17 34 195 254 227 82 82 1 132 191 52 79 54 28 36 59 77 217 48 30 52 25 37 21 39 55 34 62 70 7 8 44 1 2 254 93 2 200 226 44 252 4 27 52 72 41 53 81 56 29 0 1 0 148 0 0 2 20 1 230 0 5 0 43 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 4 0 1 244 48 49 51 17 51 17 33 21 148 82 1 46 1 230 254 93 67 0 1 0 42 255 244 2 30 1 230 0 33 0 123 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 7 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 3 62 89 184 0 16 16 184 0 25 208 184 0 0 208 184 0 12 16 184 0 7 208 184 0 2 208 184 0 2 47 186 0 4 0 12 0 16 17 18 57 186 0 9 0 16 0 12 17 18 57 184 0 12 16 185 0 20 0 1 244 184 0 9 16 185 0 23 0 1 244 184 0 20 16 184 0 29 208 184 0 4 16 185 0 32 0 1 244 48 49 1 17 35 39 35 14 1 35 34 39 14 1 35 34 38 53 17 51 17 20 51 50 54 55 17 51 17 20 22 51 50 54 55 17 2 30 66 7 2 19 50 42 71 21 21 51 42 51 57 82 52 26 32 20 76 23 27 26 36 18 1 230 254 26 64 34 42 84 39 45 77 73 1 92 254 170 85 37 38 1 96 254 170 42 43 37 38 1 96 0 0 0 1 0 42 255 51 2 30 1 230 0 34 0 132 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 7 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 15 16 184 0 23 208 184 0 32 208 186 0 2 0 0 0 32 17 18 57 184 0 11 16 184 0 6 208 186 0 8 0 32 0 0 17 18 57 184 0 11 16 185 0 19 0 1 244 184 0 8 16 185 0 22 0 1 244 184 0 19 16 184 0 28 208 184 0 2 16 185 0 31 0 1 244 48 49 5 53 55 35 14 1 35 34 39 14 1 35 34 38 53 17 51 17 20 51 50 54 55 17 51 17 20 22 51 50 54 55 17 51 17 1 208 6 4 20 48 42 71 21 21 51 42 51 57 82 52 26 32 20 76 23 27 26 36 18 82 205 172 100 37 42 84 39 45 77 73 1 92 254 170 85 37 38 1 96 254 170 42 43 37 38 1 96 253 77 0 1 0 58 255 73 2 46 1 242 0 45 0 142 0 184 0 0 69 88 184 0 34 47 27 185 0 34 0 7 62 89 184 0 0 69 88 184 0 27 47 27 185 0 27 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 184 0 34 16 185 0 22 0 1 244 184 0 13 208 186 0 36 0 34 0 27 17 18 57 184 0 36 16 185 0 16 0 1 244 184 0 27 16 184 0 18 208 186 0 30 0 34 0 27 17 18 57 184 0 30 16 185 0 25 0 1 244 184 0 34 16 184 0 28 208 184 0 28 47 184 0 34 16 184 0 39 208 48 49 5 34 38 39 55 30 1 51 50 54 53 17 52 35 34 6 7 17 35 17 52 38 35 34 6 7 17 35 17 51 23 51 62 1 51 50 23 62 1 51 50 22 21 17 20 6 1 179 20 34 12 16 8 22 11 32 18 52 26 32 20 76 23 27 26 36 18 82 66 7 2 19 50 42 71 21 21 51 42 51 57 57 183 7 5 63 3 5 48 40 1 114 85 37 38 254 160 1 86 42 43 37 38 254 160 1 230 64 34 42 84 39 45 77 73 254 132 71 80 0 0 1 255 251 255 73 2 11 1 242 0 34 0 102 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 7 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 184 0 17 16 184 0 11 208 184 0 11 47 186 0 13 0 17 0 22 17 18 57 184 0 17 16 185 0 26 0 1 244 184 0 13 16 185 0 31 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 53 17 51 23 51 62 1 51 50 22 21 17 35 17 52 38 35 34 14 2 7 17 20 6 56 19 31 11 16 8 18 10 29 21 68 7 4 38 86 56 86 81 82 52 57 22 37 36 36 21 56 183 8 5 63 3 6 46 42 2 2 83 41 54 99 97 254 210 1 35 72 64 11 22 33 22 254 145 72 83 0 0 0 1 0 93 255 73 2 109 1 242 0 32 0 106 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 7 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 19 16 185 0 7 0 1 244 186 0 15 0 19 0 12 17 18 57 184 0 15 16 185 0 10 0 1 244 184 0 19 16 184 0 13 208 184 0 13 47 184 0 0 16 185 0 26 0 1 244 48 49 5 34 38 53 17 52 38 35 34 6 7 17 35 17 51 23 51 62 1 51 50 22 21 17 20 22 51 50 54 55 23 14 1 2 48 68 55 52 58 43 66 43 82 68 7 4 38 85 56 87 81 21 29 10 18 8 16 11 31 183 83 72 1 63 72 64 44 44 254 173 1 230 83 41 54 99 97 254 182 42 46 6 3 63 5 8 0 0 0 1 0 96 0 0 1 248 1 230 0 23 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 7 0 0 0 1 17 18 57 184 0 1 16 184 0 12 208 184 0 0 16 184 0 13 208 186 0 19 0 1 0 0 17 18 57 48 49 51 17 51 19 30 1 23 51 46 1 61 1 51 17 35 3 46 1 39 35 30 1 29 1 96 79 188 15 36 16 4 3 5 78 79 188 15 37 15 4 3 5 1 230 254 237 23 58 23 48 90 39 202 254 26 1 19 23 58 23 48 90 39 202 0 0 3 0 60 255 244 2 28 1 242 0 19 0 26 0 33 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 20 0 1 244 186 0 30 0 10 0 0 17 18 57 184 0 30 47 185 0 23 0 1 244 184 0 0 16 185 0 27 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 3 34 6 7 33 46 1 3 50 54 55 33 30 1 1 44 48 87 66 39 39 66 87 48 48 87 66 39 39 66 87 48 63 85 11 1 62 11 85 63 68 87 6 254 190 6 87 12 32 64 95 63 63 96 65 32 32 65 96 63 63 95 64 32 1 190 78 72 72 78 254 131 87 80 80 87 0 0 2 0 33 255 244 2 75 1 242 0 26 0 43 0 117 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 184 0 14 208 184 0 14 47 185 0 16 0 1 244 184 0 0 16 184 0 23 208 184 0 23 47 186 0 20 0 14 0 23 17 18 57 184 0 20 47 185 0 18 0 1 244 184 0 23 16 185 0 21 0 1 244 184 0 0 16 185 0 27 0 1 244 184 0 10 16 185 0 34 0 1 244 48 49 23 34 46 2 53 52 62 2 51 50 22 23 51 21 35 21 51 21 35 21 51 21 35 14 1 39 50 54 55 17 46 1 35 34 14 2 21 20 30 2 238 42 75 55 33 33 55 75 42 24 45 29 241 190 153 153 200 251 28 46 17 15 35 16 15 35 16 27 46 34 20 20 34 46 12 33 64 95 63 63 95 64 33 4 8 68 134 64 152 68 7 5 67 7 5 1 95 5 7 23 47 70 47 48 71 47 22 0 3 0 44 255 51 2 44 2 200 0 6 0 13 0 39 0 119 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 7 62 89 184 0 0 69 88 184 0 26 47 27 185 0 26 0 15 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 3 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 184 0 15 16 185 0 3 0 1 244 184 0 25 16 185 0 4 0 1 244 184 0 10 208 184 0 3 16 184 0 11 208 184 0 25 16 184 0 28 208 184 0 15 16 184 0 38 208 48 49 55 20 22 23 17 14 1 5 52 38 39 17 62 1 3 53 46 3 53 52 62 2 55 53 51 21 30 3 21 20 14 2 7 21 128 75 57 57 75 1 88 75 57 57 75 212 44 78 59 35 35 59 78 44 80 43 79 59 35 35 59 79 43 244 85 97 5 1 116 5 95 85 85 95 5 254 140 5 97 254 148 196 3 35 64 92 59 58 92 63 35 3 217 217 3 35 63 92 58 59 92 64 35 3 196 0 0 0 1 0 63 255 244 1 198 1 230 0 18 0 75 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 7 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 3 62 89 184 0 2 208 184 0 2 47 186 0 4 0 7 0 18 17 18 57 184 0 7 16 185 0 14 0 1 244 184 0 4 16 185 0 17 0 1 244 48 49 1 17 35 39 35 14 1 35 34 38 39 55 30 1 51 50 54 55 17 1 198 68 7 3 38 111 68 27 46 23 19 26 35 29 55 101 44 1 230 254 26 115 59 68 9 11 71 9 8 63 76 1 29 0 0 0 1 0 63 255 244 1 198 2 200 0 18 0 75 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 16 0 11 0 0 17 18 57 184 0 16 16 185 0 10 0 1 244 184 0 0 16 184 0 14 208 184 0 14 47 48 49 23 34 38 39 55 30 1 51 50 54 55 17 51 17 35 39 35 14 1 159 27 46 23 19 26 35 29 55 101 44 82 68 7 3 38 111 12 9 11 71 9 8 63 76 1 255 253 56 115 59 68 0 1 0 63 255 73 2 8 1 230 0 30 0 94 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 7 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 4 0 19 0 8 17 18 57 184 0 8 16 185 0 15 0 1 244 184 0 4 16 185 0 18 0 1 244 184 0 0 16 185 0 24 0 1 244 48 49 5 34 38 61 1 35 14 1 35 34 38 39 55 30 1 51 50 54 55 17 51 17 20 22 51 50 54 55 23 14 1 1 180 74 60 3 25 75 49 21 43 23 19 22 31 24 37 73 26 82 30 38 14 31 12 18 15 46 183 83 75 117 48 56 9 11 71 9 8 53 66 1 49 254 11 54 47 9 5 62 8 11 0 0 0 1 0 146 255 73 2 25 1 242 0 34 0 89 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 12 16 184 0 6 208 184 0 6 47 186 0 8 0 12 0 0 17 18 57 184 0 12 16 185 0 19 0 1 244 184 0 8 16 185 0 22 0 1 244 184 0 0 16 185 0 28 0 1 244 48 49 5 34 46 2 53 17 51 23 51 62 1 51 50 22 23 7 46 1 35 34 6 7 17 20 30 2 51 50 54 55 23 14 1 1 77 53 72 43 19 68 7 3 38 111 68 27 46 23 19 26 35 29 55 101 44 12 28 48 35 35 56 26 17 33 71 183 29 53 74 45 1 212 115 59 68 9 11 71 9 8 63 76 254 244 33 49 34 17 12 10 60 12 17 0 1 0 146 0 0 2 25 1 242 0 18 0 47 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 6 16 185 0 12 0 1 244 48 49 51 53 52 62 2 51 50 23 7 46 1 35 34 14 2 29 1 146 36 66 94 59 81 55 19 31 48 29 36 66 50 30 249 60 93 63 33 20 71 11 7 22 47 73 51 232 0 0 2 0 99 0 0 2 33 1 230 0 15 0 24 0 85 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 13 0 1 0 0 17 18 57 184 0 13 47 185 0 16 0 1 244 186 0 10 0 16 0 13 17 18 57 184 0 0 16 184 0 11 208 184 0 1 16 185 0 23 0 1 244 48 49 51 17 51 50 30 2 21 20 6 7 23 35 39 35 21 53 51 50 54 53 52 38 43 1 99 240 39 68 49 28 72 51 145 93 137 133 143 55 61 61 55 143 1 230 15 34 55 40 63 71 12 196 190 190 254 43 43 44 36 0 2 0 55 0 0 1 245 1 230 0 15 0 24 0 85 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 7 62 89 184 0 0 69 88 184 0 2 47 27 185 0 2 0 3 62 89 184 0 11 16 184 0 0 208 186 0 16 0 11 0 2 17 18 57 184 0 16 47 185 0 14 0 1 244 186 0 10 0 14 0 16 17 18 57 184 0 2 16 185 0 24 0 1 244 48 49 1 17 35 34 46 2 53 52 54 55 39 51 23 51 53 21 35 34 6 21 20 22 59 1 1 245 240 39 68 49 28 72 51 145 93 137 133 143 55 61 61 55 143 1 230 254 26 15 34 55 40 63 71 12 196 190 190 254 43 43 44 36 0 0 1 0 71 255 73 2 14 1 242 0 60 0 104 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 7 62 89 184 0 0 69 88 184 0 47 47 27 185 0 47 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 47 16 185 0 8 0 1 244 186 0 16 0 47 0 24 17 18 57 184 0 24 16 185 0 31 0 1 244 186 0 37 0 24 0 47 17 18 57 184 0 0 16 185 0 54 0 1 244 48 49 23 34 38 61 1 55 30 1 51 50 54 53 52 46 2 39 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 23 30 3 21 20 14 2 35 34 38 39 21 20 22 51 50 54 55 23 14 1 197 67 59 38 42 101 68 62 61 10 33 60 49 95 95 26 51 75 50 56 104 36 40 34 82 47 62 50 66 75 61 78 45 17 28 55 81 52 45 84 36 25 36 13 24 9 16 12 36 183 82 80 85 54 30 36 45 31 14 24 22 20 10 20 67 55 29 51 37 21 37 25 53 23 28 42 28 32 33 16 13 29 36 44 28 30 52 40 23 19 16 53 39 48 5 3 61 5 8 0 0 0 0 1 0 56 255 39 2 29 2 214 0 31 0 53 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 184 0 16 16 185 0 23 0 1 244 48 49 23 34 38 39 55 30 1 51 50 62 2 53 17 52 54 51 50 22 23 7 46 1 35 34 14 2 21 17 20 6 187 40 62 29 26 23 46 26 25 33 18 7 76 90 36 52 27 23 22 38 23 28 36 21 8 70 217 18 14 61 11 15 17 32 45 27 2 55 88 100 17 14 61 11 14 17 32 45 27 253 200 88 99 0 0 0 1 0 56 255 39 2 29 2 214 0 39 0 70 0 184 0 20 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 16 0 1 0 13 0 4 43 184 0 0 16 185 0 7 0 1 244 184 0 20 16 185 0 27 0 1 244 184 0 16 16 184 0 34 208 184 0 13 16 184 0 35 208 48 49 23 34 38 39 55 30 1 51 50 62 2 61 1 35 53 55 53 52 54 51 50 22 23 7 46 1 35 34 14 2 29 1 51 21 35 21 20 6 187 40 62 29 26 23 46 26 25 33 18 7 176 176 76 90 36 52 27 23 22 38 23 28 36 21 8 174 174 70 217 18 14 61 11 15 17 32 45 27 251 58 6 252 88 100 17 14 61 11 14 17 32 45 27 252 64 252 88 99 0 0 0 1 0 54 255 100 2 19 1 242 0 25 0 73 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 3 62 89 185 0 14 0 1 244 184 0 6 208 184 0 13 16 184 0 9 208 184 0 13 16 184 0 10 220 184 0 0 16 185 0 19 0 1 244 48 49 19 50 30 2 29 1 51 21 15 1 35 53 35 53 51 53 52 38 35 34 6 7 39 62 1 206 53 72 44 19 137 140 11 68 239 239 53 70 35 56 26 18 33 73 1 242 29 53 74 45 230 62 5 156 156 67 231 65 68 12 10 60 12 17 0 0 1 0 69 255 73 2 34 2 130 0 27 0 81 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 9 16 185 0 6 0 1 244 184 0 9 16 184 0 11 220 184 0 9 16 184 0 13 208 184 0 6 16 184 0 14 208 184 0 0 16 185 0 21 0 1 244 48 49 5 34 46 2 53 17 35 53 63 1 51 21 51 21 35 17 20 30 2 51 50 54 55 23 14 1 1 137 53 72 43 19 137 140 11 68 239 239 12 28 48 35 35 56 26 18 33 80 183 29 53 74 45 1 145 62 5 156 156 67 254 110 33 49 34 17 12 10 60 12 17 0 0 0 2 0 2 255 244 2 74 1 230 0 8 0 32 0 111 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 7 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 3 62 89 185 0 0 0 1 244 186 0 13 0 17 0 9 17 18 57 184 0 13 47 184 0 4 208 184 0 13 16 185 0 16 0 1 244 184 0 20 208 184 0 17 16 184 0 22 208 184 0 20 16 184 0 24 208 184 0 4 16 184 0 25 208 184 0 9 16 184 0 28 208 184 0 28 47 48 49 37 50 54 55 53 35 21 20 22 23 34 38 61 1 35 53 55 53 51 21 51 53 51 21 51 21 35 21 35 39 35 14 1 1 16 38 57 35 222 44 22 77 71 96 96 82 222 82 102 102 68 6 2 35 76 60 38 44 112 66 68 60 72 96 94 76 58 6 168 168 168 168 64 254 76 41 47 0 1 0 50 255 244 2 38 1 230 0 45 0 81 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 13 16 185 0 12 0 1 244 184 0 15 208 184 0 0 16 185 0 23 0 1 244 184 0 12 16 184 0 34 208 184 0 31 208 184 0 13 16 184 0 33 208 48 49 5 34 46 2 53 52 62 2 55 53 35 53 51 21 14 1 21 20 30 2 51 50 62 2 53 52 38 39 53 51 21 35 21 30 3 21 20 14 2 1 44 57 88 61 32 17 27 33 17 106 195 43 56 19 39 58 38 38 58 39 19 56 43 195 106 16 34 27 17 32 61 88 12 37 62 80 42 37 63 51 41 16 2 67 53 36 98 73 34 62 46 28 28 46 62 34 73 98 36 53 67 2 16 41 51 63 37 42 80 62 37 0 0 0 1 0 77 255 244 2 28 1 242 0 35 0 69 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 28 16 184 0 6 208 184 0 6 47 184 0 0 16 185 0 13 0 1 244 184 0 28 16 185 0 21 0 1 244 48 49 5 34 46 2 53 17 51 17 20 30 2 51 50 62 2 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 14 2 1 41 47 81 59 33 83 22 38 51 29 37 58 40 20 43 45 14 11 10 13 14 27 24 71 85 31 61 91 12 26 55 85 58 1 18 254 245 44 62 39 18 34 61 82 48 74 77 3 3 64 4 4 100 105 66 112 81 46 0 0 0 1 0 51 0 0 2 37 1 230 0 13 0 51 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 7 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 3 62 89 184 0 1 208 186 0 7 0 13 0 12 17 18 57 48 49 1 19 35 3 46 1 39 35 14 1 7 3 35 19 1 88 205 83 112 15 27 13 4 13 25 15 112 79 201 1 230 254 26 1 20 37 71 35 35 71 37 254 236 1 230 0 0 0 1 0 8 0 0 2 80 1 230 0 31 0 93 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 7 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 3 62 89 184 0 23 16 184 0 0 208 184 0 22 16 184 0 1 208 186 0 6 0 22 0 23 17 18 57 186 0 12 0 22 0 23 17 18 57 186 0 17 0 23 0 22 17 18 57 186 0 27 0 23 0 22 17 18 57 48 49 1 19 35 3 46 1 39 35 14 1 15 1 35 39 46 1 39 35 14 1 7 3 35 19 51 23 22 23 51 54 63 1 1 230 106 82 58 7 10 5 4 5 15 8 60 82 58 8 17 5 4 6 9 7 58 76 104 106 56 12 12 4 12 12 54 1 230 254 26 1 26 35 64 35 35 65 34 252 252 35 64 35 35 64 35 254 230 1 230 232 51 93 93 51 232 0 0 0 1 0 49 0 0 2 39 2 212 0 28 0 75 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 6 16 185 0 13 0 1 244 186 0 24 0 6 0 0 17 18 57 184 0 24 16 185 0 17 0 1 244 184 0 0 16 184 0 18 208 48 49 51 19 62 3 51 50 22 23 7 46 1 35 34 6 15 1 19 35 3 46 1 39 35 14 1 7 3 49 226 13 36 48 62 39 17 33 14 18 9 21 12 48 61 17 27 227 83 119 14 31 15 4 13 27 12 106 2 42 36 62 46 26 5 5 65 3 4 60 46 63 254 25 1 13 32 74 35 35 73 33 254 243 0 0 1 0 57 0 0 2 33 1 230 0 15 0 55 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 7 0 2 0 0 17 18 57 184 0 2 16 184 0 13 208 48 49 33 53 3 51 23 30 1 23 51 62 1 63 1 51 3 21 1 4 203 89 85 17 35 17 4 17 32 20 84 88 203 164 1 66 138 32 57 33 33 57 32 138 254 190 164 0 0 0 1 0 71 255 73 2 108 1 230 0 23 0 92 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 7 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 5 16 185 0 13 0 1 244 184 0 6 208 184 0 9 16 185 0 8 0 1 244 184 0 11 208 184 0 0 16 185 0 17 0 1 244 48 49 5 34 38 61 1 33 53 1 33 53 33 21 1 33 21 20 22 51 50 54 55 23 14 1 2 47 68 56 254 148 1 70 254 223 1 151 254 185 1 73 22 29 10 18 8 16 11 31 183 81 66 36 44 1 119 67 44 254 137 95 42 46 6 3 63 5 8 0 0 0 0 2 0 71 255 140 2 70 1 230 0 26 0 36 0 91 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 7 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 3 62 89 184 0 23 208 185 0 27 0 1 244 184 0 12 208 184 0 12 47 184 0 6 208 184 0 9 16 185 0 8 0 1 244 184 0 11 208 184 0 11 47 184 0 27 16 184 0 33 220 185 0 17 0 1 244 48 49 5 39 62 1 55 35 53 1 33 53 33 21 1 30 1 51 54 51 50 22 21 20 6 43 1 14 1 55 50 54 53 52 38 35 34 6 7 1 102 62 5 11 7 248 1 68 254 225 1 139 254 189 45 77 37 57 96 39 51 78 78 45 6 12 82 37 38 19 15 21 43 20 116 10 29 53 24 44 1 119 67 44 254 137 1 1 151 49 41 54 72 25 57 146 35 23 17 17 42 50 0 0 1 0 59 255 39 2 15 1 230 0 42 0 81 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 11 0 1 244 186 0 19 0 28 0 0 17 18 57 184 0 19 47 185 0 33 0 1 244 184 0 25 208 184 0 28 16 185 0 26 0 1 244 184 0 30 208 48 49 5 34 46 2 39 55 30 3 51 50 62 2 53 52 38 35 34 14 2 7 39 19 33 53 33 21 7 54 51 50 30 2 21 20 14 2 1 32 42 68 56 44 19 40 16 37 44 53 32 33 60 44 26 86 81 16 24 21 21 14 33 251 254 212 1 151 238 24 19 51 80 55 30 40 66 87 217 16 27 33 18 53 15 29 22 13 22 40 56 35 65 73 3 6 10 6 46 1 0 67 44 248 6 28 51 72 43 54 83 57 29 0 0 0 2 0 0 255 39 2 106 2 200 0 14 0 73 0 187 0 184 0 0 69 88 184 0 51 47 27 185 0 51 0 7 62 89 184 0 0 69 88 184 0 57 47 27 185 0 57 0 15 62 89 184 0 0 69 88 184 0 41 47 27 185 0 41 0 3 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 5 62 89 184 0 41 16 185 0 0 0 1 244 184 0 51 16 185 0 7 0 1 244 184 0 15 16 185 0 22 0 1 244 184 0 51 16 184 0 59 208 184 0 59 47 186 0 28 0 59 0 15 17 18 57 184 0 28 47 185 0 64 0 1 244 184 0 32 208 184 0 59 16 185 0 33 0 1 244 184 0 41 16 184 0 35 208 184 0 35 47 186 0 37 0 41 0 51 17 18 57 186 0 54 0 51 0 41 17 18 57 184 0 33 16 184 0 61 208 48 49 55 50 54 55 53 46 1 35 34 14 2 21 20 22 1 34 38 39 55 30 1 51 50 54 53 52 38 35 34 6 7 39 55 35 17 35 39 35 14 1 35 34 46 2 53 52 62 2 51 50 22 23 51 39 53 51 21 33 21 7 54 51 50 30 2 21 20 14 2 172 26 39 15 17 33 24 21 36 25 14 45 1 67 50 66 26 39 20 45 32 41 51 45 44 16 20 14 33 146 182 59 7 3 16 53 35 34 57 41 23 27 45 59 33 30 45 15 2 4 76 1 13 141 4 8 36 55 39 20 26 45 62 57 42 33 240 27 30 27 49 69 41 87 99 254 238 33 26 52 20 23 74 75 63 69 7 8 52 250 254 93 58 27 43 34 66 94 60 58 95 67 36 30 26 93 177 226 44 247 1 31 53 72 40 52 81 55 29 0 0 2 0 25 255 244 2 58 2 130 0 36 0 55 0 103 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 9 16 185 0 6 0 1 244 184 0 9 16 184 0 15 208 184 0 15 47 185 0 22 0 1 244 186 0 25 0 15 0 0 17 18 57 184 0 0 16 185 0 37 0 1 244 186 0 40 0 0 0 15 17 18 57 184 0 6 16 184 0 49 208 48 49 5 34 46 2 61 1 35 53 63 1 51 21 51 54 51 50 22 23 7 46 1 35 34 6 21 20 30 4 21 20 14 2 39 50 54 53 52 46 4 53 52 55 35 21 20 30 2 1 72 65 88 54 23 73 76 10 69 188 30 38 37 65 26 32 22 42 26 29 35 28 43 50 43 28 26 57 92 63 92 71 29 43 51 43 29 5 125 15 36 58 12 25 48 70 45 243 62 5 156 156 12 25 23 48 17 18 30 28 23 31 26 28 40 56 42 34 54 37 20 64 44 38 31 42 31 28 34 46 35 20 18 244 33 46 30 14 0 0 1 0 48 255 39 2 91 2 214 0 53 0 127 0 184 0 0 69 88 184 0 40 47 27 185 0 40 0 15 62 89 184 0 0 69 88 184 0 32 47 27 185 0 32 0 7 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 184 0 32 16 185 0 29 0 1 244 184 0 11 208 184 0 23 16 185 0 16 0 1 244 184 0 32 16 184 0 34 220 184 0 32 16 184 0 36 208 184 0 40 16 185 0 47 0 1 244 48 49 5 34 38 39 55 30 1 51 50 54 53 17 35 17 20 22 51 50 54 55 23 14 1 35 34 46 2 53 17 35 53 63 1 51 21 51 53 52 54 51 50 22 23 7 46 1 35 34 6 21 17 20 6 1 97 22 35 13 17 9 24 13 34 22 199 30 39 14 30 14 15 20 45 23 38 53 32 14 72 75 11 69 199 65 76 19 30 11 16 8 18 10 41 26 61 217 8 5 62 3 5 50 45 1 218 254 242 45 49 8 5 62 7 11 24 42 60 36 1 13 62 5 156 156 80 73 87 8 5 63 3 6 51 45 253 150 74 88 0 0 1 0 71 0 0 1 254 2 212 0 29 0 47 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 18 16 185 0 9 0 1 244 48 49 51 17 62 3 53 52 38 35 34 6 7 39 62 3 51 50 30 2 21 20 14 2 7 17 239 49 71 45 22 77 72 57 79 26 44 16 42 52 64 38 47 83 61 36 28 50 70 41 1 55 28 48 50 53 33 61 72 49 32 53 18 35 27 16 25 51 75 49 44 68 59 51 27 254 237 0 1 0 89 0 0 2 15 2 212 0 29 0 47 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 11 16 185 0 20 0 1 244 48 49 33 17 46 3 53 52 62 2 51 50 30 2 23 7 46 1 35 34 6 21 20 30 2 23 17 1 22 42 69 50 28 35 62 82 47 39 63 53 41 16 43 27 79 57 71 78 22 46 71 49 1 19 27 51 59 68 44 49 75 51 25 16 27 35 18 53 32 49 72 61 33 53 50 48 28 254 201 0 0 0 1 0 71 0 0 2 6 2 212 0 34 0 73 0 184 0 0 69 88 184 0 20 47 27 185 0 20 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 4 0 1 0 1 0 4 43 184 0 20 16 185 0 11 0 1 244 184 0 4 16 184 0 31 208 184 0 1 16 184 0 32 208 48 49 51 53 35 53 55 51 62 1 53 52 38 35 34 6 7 39 62 3 51 50 30 2 21 20 14 2 7 51 21 35 21 239 165 76 102 83 91 75 70 58 80 28 44 16 43 53 65 39 46 82 60 35 24 39 53 28 152 197 251 58 5 48 101 60 61 72 50 31 53 18 34 27 17 25 51 75 49 36 60 51 44 19 63 251 0 0 1 0 82 0 0 2 17 2 212 0 34 0 73 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 5 0 1 0 1 0 4 43 184 0 15 16 185 0 24 0 1 244 184 0 5 16 184 0 31 208 184 0 1 16 184 0 32 208 48 49 33 53 35 53 55 51 46 3 53 52 62 2 51 50 30 2 23 7 46 1 35 34 6 21 20 22 23 51 21 35 21 1 23 197 76 76 29 52 39 24 35 60 81 47 39 65 53 42 17 44 28 80 58 70 76 92 82 179 165 251 58 5 19 44 51 60 36 49 75 51 25 17 27 34 18 53 31 50 72 61 60 101 48 63 251 0 1 0 84 255 51 2 4 2 200 0 19 0 93 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 5 0 1 0 8 0 4 43 184 0 5 16 184 0 4 220 185 0 1 0 1 244 184 0 8 16 184 0 12 208 184 0 5 16 184 0 13 208 184 0 4 16 184 0 16 208 184 0 1 16 184 0 17 208 48 49 5 17 35 53 55 53 35 53 55 17 51 17 51 21 35 21 51 21 35 17 1 4 176 176 176 176 80 176 176 176 176 205 1 103 58 4 108 58 4 1 70 254 186 62 108 62 254 153 0 0 3 0 60 255 244 2 29 2 212 0 19 0 39 0 51 0 71 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 20 0 1 244 184 0 10 16 185 0 30 0 1 244 186 0 40 0 10 0 0 17 18 57 184 0 40 16 184 0 46 208 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 55 34 38 53 52 54 51 50 22 21 20 6 1 44 55 88 63 34 34 63 88 55 55 89 63 34 34 63 89 55 34 60 43 25 25 43 60 34 35 59 43 25 25 43 59 35 25 37 37 25 25 37 37 12 44 91 140 96 89 137 92 47 47 92 137 89 96 140 91 44 68 32 72 115 84 76 112 74 35 35 74 112 76 84 115 72 32 240 36 27 29 35 35 29 27 36 0 0 0 0 1 0 82 255 91 2 6 2 144 0 32 0 83 0 184 0 0 69 88 184 0 20 47 27 185 0 20 0 13 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 3 62 89 187 0 7 0 1 0 0 0 4 43 184 0 19 16 184 0 10 208 186 0 14 0 20 0 19 17 18 57 186 0 23 0 19 0 20 17 18 57 184 0 20 16 184 0 29 208 48 49 5 34 38 39 55 30 1 51 50 54 53 35 3 39 35 30 1 21 17 35 17 51 19 23 51 46 1 53 17 51 17 20 6 1 141 22 35 12 16 9 22 11 32 20 12 210 63 2 2 9 80 92 210 63 2 2 9 80 57 165 7 5 66 3 6 52 44 1 156 136 51 103 51 254 169 2 144 254 100 136 49 107 52 1 84 253 109 75 87 0 0 255 255 0 60 255 244 1 251 1 242 2 6 1 221 0 0 255 255 0 60 255 244 1 251 3 9 2 38 1 221 0 0 0 6 4 236 4 0 0 0 255 255 0 60 255 244 1 251 3 9 2 38 1 221 0 0 0 6 4 239 4 0 0 0 255 255 0 60 255 244 1 251 2 228 2 38 1 221 0 0 0 6 4 242 4 0 0 0 255 255 0 60 255 244 1 251 2 209 2 38 1 221 0 0 0 6 4 244 4 0 0 0 255 255 0 60 255 244 1 251 2 188 2 38 1 221 0 0 0 6 5 0 4 0 0 0 255 255 0 60 255 244 1 251 2 146 2 38 1 221 0 0 0 6 4 246 4 0 0 0 255 255 0 60 255 244 1 251 2 218 2 38 1 221 0 0 0 6 4 250 4 0 0 0 255 255 0 60 255 244 1 251 2 249 2 38 1 221 0 0 0 6 5 6 4 0 0 0 0 4 0 60 255 244 1 251 3 75 0 22 0 36 0 51 0 63 0 0 5 34 46 2 53 52 62 2 51 50 22 23 51 55 51 17 35 39 35 14 1 39 50 55 53 46 1 35 34 14 2 21 20 22 19 34 38 53 52 54 63 1 23 7 30 1 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 1 14 47 77 56 30 36 62 80 44 43 72 34 3 7 66 68 7 3 29 84 28 72 65 33 63 32 32 55 41 24 75 84 52 58 20 20 139 36 74 38 41 58 52 24 33 33 24 24 33 33 12 34 65 94 61 59 95 66 36 34 32 54 254 26 64 31 45 69 73 242 31 26 27 49 68 42 88 98 2 0 55 41 24 40 13 101 50 35 8 51 34 41 55 37 34 25 26 33 33 26 25 34 255 255 0 60 255 244 1 251 2 234 2 38 1 221 0 0 0 6 5 10 4 0 0 0 255 255 0 60 255 42 1 251 1 242 2 38 1 221 0 0 0 7 4 254 0 4 252 222 255 255 0 60 255 244 1 251 2 248 2 38 1 221 0 0 0 6 5 2 4 0 0 0 255 255 0 60 255 244 2 27 3 17 2 38 1 221 0 0 0 6 5 68 4 0 0 0 255 255 0 57 255 244 1 251 3 17 2 38 1 221 0 0 0 6 5 70 4 0 0 0 255 255 0 60 255 244 2 1 3 23 2 38 1 221 0 0 0 6 5 72 4 0 0 0 255 255 0 60 255 244 1 251 3 35 2 38 1 221 0 0 0 6 5 74 4 0 0 0 255 255 0 60 255 42 1 251 2 228 2 38 1 221 0 0 0 38 4 242 4 0 0 7 4 254 0 4 252 222 0 0 255 255 0 60 255 244 1 251 3 64 2 38 1 221 0 0 0 6 5 76 4 0 0 0 255 255 0 60 255 244 1 251 3 64 2 38 1 221 0 0 0 6 5 78 4 0 0 0 255 255 0 60 255 244 1 251 3 80 2 38 1 221 0 0 0 6 5 80 4 0 0 0 255 255 0 60 255 244 1 251 3 34 2 38 1 221 0 0 0 6 5 82 4 0 0 0 255 255 0 60 255 42 1 251 2 218 2 38 1 221 0 0 0 38 4 250 4 0 0 7 4 254 0 4 252 222 0 0 0 2 0 60 255 31 2 29 1 242 0 40 0 54 0 139 0 184 0 0 69 88 184 0 21 47 27 185 0 21 0 7 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 3 62 89 187 0 34 0 1 0 0 0 4 43 184 0 11 16 184 0 6 208 184 0 6 47 186 0 8 0 11 0 21 17 18 57 186 0 24 0 21 0 11 17 18 57 184 0 21 16 184 0 27 208 184 0 27 47 184 0 6 16 184 0 28 208 184 0 11 16 185 0 41 0 1 244 184 0 8 16 185 0 43 0 1 244 184 0 24 16 185 0 44 0 1 244 184 0 21 16 185 0 47 0 1 244 48 49 5 34 38 53 52 54 55 39 35 14 1 35 34 46 2 53 52 62 2 51 50 22 23 51 55 51 17 14 1 21 20 22 51 50 54 55 23 14 1 3 50 55 53 46 1 35 34 14 2 21 20 22 1 195 42 57 52 36 8 3 29 84 46 47 77 56 30 36 62 80 44 43 72 34 3 7 66 52 42 33 22 16 24 9 24 17 45 191 72 65 33 63 32 32 55 41 24 75 225 45 48 43 66 23 64 31 45 34 65 94 61 59 95 66 36 34 32 54 254 21 23 59 29 28 27 13 8 39 16 20 1 26 73 242 31 26 27 49 68 42 88 98 0 0 0 255 255 0 60 255 39 1 251 1 242 2 6 1 230 0 0 255 255 0 60 255 39 1 251 3 9 2 38 1 230 0 0 0 6 4 239 10 0 0 0 255 255 0 60 255 39 1 251 2 228 2 38 1 230 0 0 0 6 4 242 10 0 0 0 255 255 0 60 255 39 1 251 2 218 2 38 1 230 0 0 0 6 4 250 10 0 0 0 255 255 0 60 255 39 1 251 2 204 2 38 1 230 0 0 0 6 4 254 10 0 0 0 255 255 0 60 255 39 1 251 2 232 2 38 1 230 0 0 0 6 5 34 10 0 0 0 255 255 0 60 255 39 1 251 2 234 2 38 1 230 0 0 0 6 5 10 10 0 0 0 255 255 0 60 255 39 1 251 2 146 2 38 1 230 0 0 0 6 4 246 10 0 0 0 255 255 0 60 255 39 1 251 2 209 2 38 1 230 0 0 0 6 4 244 10 0 0 0 255 255 0 99 0 0 2 52 2 204 2 38 2 66 0 0 0 6 4 254 28 0 0 0 0 1 0 99 0 0 2 52 1 230 0 9 0 61 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 1 0 1 244 184 0 5 16 185 0 3 0 1 244 184 0 1 16 184 0 8 208 48 49 51 53 51 17 35 53 51 17 51 21 99 197 173 255 186 67 1 96 67 254 93 67 0 0 0 255 255 0 99 0 0 2 52 3 9 2 38 2 66 0 0 0 6 4 236 24 0 0 0 255 255 0 99 0 0 2 52 3 9 2 38 2 66 0 0 0 6 4 239 24 0 0 0 255 255 0 99 0 0 2 52 2 228 2 38 2 66 0 0 0 6 4 242 24 0 0 0 255 255 0 99 0 0 2 52 2 209 2 38 2 66 0 0 0 6 4 244 24 0 0 0 255 255 0 99 0 0 2 52 2 188 2 38 2 66 0 0 0 6 5 0 24 0 0 0 255 255 0 99 0 0 2 52 2 146 2 38 2 66 0 0 0 6 4 246 24 0 0 0 255 255 0 99 0 0 2 52 2 234 2 38 2 66 0 0 0 6 5 10 24 0 0 0 255 255 0 99 255 31 2 52 2 204 2 38 2 80 0 0 0 6 4 254 24 0 0 0 255 255 0 99 0 0 2 52 2 248 2 38 2 66 0 0 0 6 5 2 24 0 0 0 255 255 0 99 255 42 2 52 2 204 2 38 2 66 0 0 0 38 4 254 28 0 0 7 4 254 0 24 252 222 0 0 255 255 0 99 0 0 2 52 2 218 2 38 2 66 0 0 0 6 4 250 24 0 0 0 255 255 0 99 0 0 2 52 2 204 2 38 2 82 0 0 0 6 4 254 28 0 0 0 0 1 0 90 255 31 1 190 1 230 0 24 0 69 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 3 62 89 187 0 18 0 1 0 0 0 4 43 184 0 10 16 185 0 8 0 1 244 184 0 7 16 184 0 12 208 184 0 12 47 48 49 5 34 38 53 52 54 55 35 17 35 53 33 17 14 1 21 20 22 51 50 54 55 23 14 1 1 97 45 59 51 35 19 226 1 52 45 43 36 24 16 25 11 24 18 47 225 45 48 42 66 24 1 163 67 254 21 22 59 30 28 27 12 9 39 17 19 0 0 0 0 1 0 99 255 31 2 52 1 230 0 29 0 83 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 7 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 3 62 89 187 0 23 0 1 0 0 0 4 43 184 0 7 16 185 0 8 0 1 244 184 0 12 16 185 0 10 0 1 244 184 0 8 16 184 0 15 208 184 0 7 16 184 0 16 208 48 49 5 34 38 53 52 54 55 35 53 51 17 35 53 51 17 51 21 35 14 1 21 20 22 51 50 54 55 23 14 1 1 89 44 59 46 29 218 197 173 255 186 181 42 38 36 23 17 25 11 24 18 47 225 45 48 41 66 25 67 1 96 67 254 93 67 29 60 27 28 27 12 9 39 17 19 0 1 0 90 0 0 2 52 1 230 0 13 0 79 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 7 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 3 62 89 186 0 9 0 5 0 12 17 18 57 184 0 9 47 184 0 0 208 184 0 9 16 185 0 8 0 1 244 184 0 2 208 184 0 5 16 185 0 3 0 1 244 48 49 55 53 55 53 35 53 33 21 51 21 35 21 35 53 132 184 226 1 52 166 166 82 210 56 6 147 67 214 62 210 210 0 1 0 99 0 0 2 52 1 230 0 17 0 93 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 7 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 3 62 89 186 0 9 0 5 0 14 17 18 57 184 0 9 47 184 0 0 208 184 0 9 16 185 0 8 0 1 244 184 0 2 208 184 0 5 16 185 0 3 0 1 244 184 0 14 16 185 0 15 0 1 244 184 0 12 208 48 49 55 53 55 53 35 53 51 21 51 21 35 21 51 21 33 53 51 53 116 180 173 255 170 170 186 254 47 197 220 58 6 135 67 202 64 153 67 67 153 0 0 0 2 0 56 255 6 1 226 1 230 0 26 0 38 0 111 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 7 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 184 0 0 220 184 0 6 16 185 0 27 0 1 244 184 0 33 220 185 0 12 0 1 244 186 0 3 0 6 0 12 17 18 57 186 0 15 0 12 0 6 17 18 57 184 0 19 16 185 0 17 0 1 244 186 0 23 0 3 0 15 17 18 57 186 0 30 0 15 0 3 17 18 57 48 49 5 46 1 39 14 1 35 34 38 53 52 54 51 50 22 23 53 17 35 53 33 17 20 7 30 1 23 37 50 54 55 46 1 35 34 6 21 20 22 1 162 15 31 17 24 76 54 70 75 66 63 32 66 33 226 1 52 10 26 47 21 254 230 40 48 12 29 58 29 32 30 40 250 29 46 20 29 33 66 45 45 55 16 17 2 1 200 67 254 6 41 31 24 63 41 68 27 21 21 18 23 17 20 27 0 255 255 0 32 0 0 2 56 2 144 2 6 0 4 0 0 255 255 0 99 0 0 2 35 2 144 2 6 0 5 0 0 0 1 0 135 0 0 2 23 2 144 0 5 0 47 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 1 16 185 0 3 0 1 244 48 49 51 17 33 21 33 17 135 1 144 254 195 2 144 70 253 182 0 0 0 0 2 0 43 0 0 2 45 2 144 0 5 0 15 0 53 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 12 0 2 0 0 17 18 57 48 49 51 53 19 51 19 21 37 33 3 46 1 39 35 14 1 7 43 209 96 209 254 89 1 75 97 17 33 17 4 17 33 17 50 2 94 253 162 50 71 1 37 54 110 57 57 110 54 255 255 0 114 0 0 2 18 2 144 2 6 0 8 0 0 255 255 0 65 0 0 2 27 2 145 2 6 0 29 0 0 255 255 0 79 0 0 2 9 2 144 2 6 0 11 0 0 0 3 0 48 255 244 2 40 2 156 0 19 0 39 0 43 0 73 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 20 0 1 244 184 0 10 16 185 0 30 0 1 244 186 0 43 0 10 0 0 17 18 57 184 0 43 47 185 0 41 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 39 53 51 21 1 44 56 92 67 37 37 67 92 56 55 93 67 37 37 67 93 55 37 62 43 24 24 43 62 37 38 61 43 24 24 43 61 61 198 12 48 89 127 79 79 125 87 46 47 87 125 78 79 127 89 48 73 38 71 99 62 61 98 68 37 37 68 98 61 62 99 71 38 248 72 72 0 255 255 0 95 0 0 1 249 2 144 2 6 0 12 0 0 255 255 0 98 0 0 2 68 2 144 2 6 0 14 0 0 0 1 0 43 0 0 2 45 2 144 0 13 0 51 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 3 208 186 0 9 0 1 0 0 17 18 57 48 49 51 19 51 19 35 3 46 1 39 35 14 1 7 3 43 208 97 209 88 106 17 28 18 4 18 28 17 105 2 144 253 112 1 99 58 101 58 58 101 58 254 157 0 255 255 0 72 0 0 2 16 2 144 2 6 0 16 0 0 255 255 0 82 0 0 2 6 2 144 2 6 0 17 0 0 0 3 0 70 0 0 2 18 2 144 0 3 0 7 0 11 0 73 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 2 0 1 244 186 0 7 0 9 0 0 17 18 57 184 0 7 47 185 0 5 0 1 244 184 0 9 16 185 0 11 0 1 244 48 49 51 53 33 21 1 53 33 21 1 53 33 21 70 1 204 254 127 1 54 254 137 1 184 71 71 1 53 71 71 1 21 70 70 255 255 0 48 255 244 2 40 2 156 2 6 0 18 0 0 0 1 0 79 0 0 2 9 2 144 0 7 0 51 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 4 208 184 0 1 16 185 0 5 0 1 244 48 49 51 17 33 17 35 17 33 17 79 1 186 84 254 238 2 144 253 112 2 74 253 182 0 255 255 0 102 0 0 2 31 2 144 2 6 0 19 0 0 0 1 0 75 0 0 2 20 2 144 0 11 0 81 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 10 0 1 244 184 0 1 208 186 0 2 0 0 0 4 17 18 57 184 0 4 16 185 0 6 0 1 244 184 0 3 208 186 0 8 0 4 0 0 17 18 57 48 49 51 53 19 3 53 33 21 33 23 3 33 21 75 226 222 1 167 254 195 201 205 1 95 50 1 27 1 18 49 70 251 254 248 71 0 0 0 255 255 0 42 0 0 2 46 2 144 2 6 0 23 0 0 255 255 0 38 0 0 2 50 2 144 2 6 0 28 0 0 0 3 0 26 255 234 2 62 2 166 0 6 0 15 0 41 0 89 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 13 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 3 62 89 184 0 17 220 185 0 3 0 1 244 184 0 28 16 184 0 27 220 185 0 4 0 1 244 184 0 10 208 184 0 3 16 184 0 11 208 184 0 27 16 184 0 30 208 184 0 17 16 184 0 40 208 48 49 19 20 22 23 17 14 1 5 52 38 39 17 62 3 3 53 46 3 53 52 62 2 55 53 51 21 30 3 21 20 14 2 7 21 106 83 73 73 83 1 132 84 72 36 58 40 22 232 54 87 61 34 34 61 87 54 76 54 87 61 34 34 61 87 54 1 76 87 108 6 1 139 6 103 85 85 103 6 254 117 3 31 53 71 254 201 88 3 40 68 95 60 58 94 66 38 3 87 87 3 38 66 94 58 60 95 68 40 3 88 0 0 0 255 255 0 54 0 0 2 34 2 144 2 6 0 27 0 0 0 1 0 44 0 0 2 44 2 144 0 21 0 89 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 9 0 5 0 0 17 18 57 184 0 9 47 185 0 1 0 1 244 184 0 5 16 184 0 11 208 184 0 9 16 184 0 12 208 184 0 11 16 184 0 16 208 184 0 1 16 184 0 20 208 48 49 33 53 46 1 61 1 51 21 20 23 17 51 17 54 61 1 51 21 20 6 7 21 1 2 100 114 80 134 84 134 80 114 100 243 5 116 116 176 172 164 10 1 90 254 166 10 164 172 176 116 116 5 243 0 1 0 38 0 0 2 50 2 156 0 49 0 81 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 1 0 1 244 184 0 25 208 184 0 0 16 184 0 26 208 184 0 25 16 184 0 28 208 184 0 13 16 185 0 38 0 1 244 184 0 1 16 184 0 48 208 48 49 51 53 51 53 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 21 51 21 35 53 62 3 53 52 46 2 35 34 14 2 21 20 30 2 23 21 38 121 21 39 32 19 35 66 93 58 58 93 66 35 19 32 39 21 121 210 24 42 31 17 22 42 62 40 40 62 42 22 17 31 42 24 68 4 20 55 70 84 50 69 116 85 47 47 85 116 69 50 84 70 55 20 4 68 61 24 56 69 84 52 53 91 67 38 38 67 91 53 52 84 69 56 24 61 0 0 0 0 3 0 36 0 0 2 56 2 178 0 9 0 17 0 21 0 87 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 13 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 3 62 89 186 0 20 0 18 0 3 43 186 0 2 0 11 0 10 17 18 57 184 0 2 47 186 0 7 0 11 0 10 17 18 57 184 0 10 16 184 0 13 208 184 0 2 16 185 0 16 0 1 244 48 49 19 7 51 39 46 1 39 35 14 1 3 19 51 19 35 39 35 7 3 39 19 23 248 30 183 29 16 29 15 4 16 28 210 210 94 210 88 59 223 59 46 57 36 79 1 111 100 100 55 99 59 59 99 254 90 2 144 253 112 200 200 1 133 10 1 35 10 0 2 0 24 0 0 2 18 2 178 0 11 0 15 0 85 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 14 0 12 0 3 43 184 0 1 16 185 0 3 0 1 244 186 0 7 0 1 0 0 17 18 57 184 0 7 47 185 0 6 0 1 244 184 0 0 16 185 0 10 0 1 244 48 49 51 17 33 21 35 21 51 21 35 21 51 21 1 39 19 23 200 1 64 244 194 194 254 254 63 57 36 79 2 144 70 206 71 238 71 1 133 10 1 35 10 0 0 0 2 0 24 0 0 2 16 2 178 0 11 0 15 0 81 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 14 0 12 0 3 43 186 0 9 0 1 0 0 17 18 57 184 0 9 47 185 0 3 0 1 244 184 0 1 16 184 0 6 208 184 0 0 16 184 0 7 208 48 49 51 17 51 17 51 17 51 17 35 17 35 17 3 39 19 23 194 76 182 76 76 182 189 57 36 79 2 144 254 237 1 19 253 112 1 53 254 203 1 133 10 1 35 10 0 0 0 0 2 0 24 0 0 1 249 2 178 0 11 0 15 0 77 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 14 0 12 0 3 43 184 0 0 16 185 0 1 0 1 244 184 0 5 16 185 0 4 0 1 244 184 0 7 208 184 0 1 16 184 0 10 208 48 49 51 53 51 17 35 53 33 21 35 17 51 21 1 39 19 23 185 118 118 1 64 119 119 254 88 57 36 79 71 2 3 70 70 253 253 71 1 133 10 1 35 10 0 255 255 0 95 0 0 1 249 3 48 2 38 0 12 0 0 0 6 5 1 0 0 0 0 0 3 0 24 255 244 2 40 2 178 0 19 0 31 0 35 0 65 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 34 0 32 0 3 43 184 0 0 16 185 0 20 0 1 244 184 0 10 16 185 0 26 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 3 39 19 23 1 92 45 74 54 30 30 54 74 45 45 75 54 30 30 54 75 45 56 67 68 55 55 67 67 212 57 36 79 12 46 88 128 81 82 126 86 43 43 86 126 82 83 128 87 45 73 133 137 135 129 128 136 137 133 1 72 10 1 35 10 0 2 0 40 0 0 2 90 2 178 0 15 0 19 0 63 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 18 0 16 0 3 43 186 0 7 0 2 0 0 17 18 57 184 0 2 16 184 0 13 208 48 49 33 53 3 51 23 30 1 23 51 62 1 63 1 51 3 21 1 39 19 23 1 101 169 77 73 15 27 14 4 14 27 14 75 74 169 254 176 57 36 79 234 1 166 195 42 73 38 38 76 39 195 254 90 234 1 133 10 1 35 10 0 255 255 0 38 0 0 2 50 3 48 2 38 0 28 0 0 0 6 5 1 0 0 0 0 0 2 0 24 0 0 2 48 2 178 0 41 0 45 0 93 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 44 0 42 0 3 43 184 0 0 16 185 0 1 0 1 244 184 0 21 208 184 0 0 16 184 0 22 208 184 0 21 16 184 0 24 208 184 0 11 16 185 0 32 0 1 244 184 0 1 16 184 0 40 208 48 49 51 53 51 53 46 1 53 52 62 2 51 50 30 2 21 20 6 7 21 51 21 35 53 62 1 53 52 46 2 35 34 14 2 21 20 22 23 21 3 39 19 23 134 99 42 46 29 52 75 46 46 75 53 28 46 42 99 172 39 41 16 31 45 29 29 45 31 16 41 39 225 57 36 79 68 4 60 139 94 66 111 81 45 45 81 111 66 94 139 60 4 68 61 59 137 95 55 89 64 35 35 64 89 55 95 137 59 61 1 133 10 1 35 10 0 0 2 0 57 255 244 2 63 1 242 0 39 0 58 0 121 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 15 0 10 0 0 17 18 57 184 0 10 16 184 0 18 208 184 0 18 47 184 0 0 16 185 0 40 0 1 244 184 0 26 208 184 0 0 16 184 0 33 208 186 0 36 0 0 0 10 17 18 57 184 0 36 16 185 0 45 0 1 244 184 0 15 16 185 0 46 0 1 244 184 0 10 16 185 0 51 0 1 244 48 49 23 34 46 2 53 52 62 2 51 50 30 2 23 51 55 51 14 3 21 20 22 51 50 54 55 23 14 1 35 34 38 53 35 14 1 39 50 62 2 63 1 46 3 35 34 14 2 21 20 22 253 44 72 51 29 36 60 79 43 25 49 43 34 11 3 20 82 10 21 18 12 28 20 8 18 8 12 11 31 22 43 52 3 32 78 33 25 49 39 25 3 7 10 30 36 38 16 28 52 41 25 68 12 32 63 91 60 63 98 67 36 13 30 49 35 115 48 105 102 91 33 25 26 5 3 63 5 8 48 51 51 48 69 24 41 55 31 91 40 51 28 11 25 48 73 48 85 93 0 0 0 0 2 0 93 255 77 2 32 2 212 0 29 0 59 0 124 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 3 62 89 186 0 38 0 6 0 23 17 18 57 184 0 38 47 185 0 41 0 1 244 186 0 15 0 41 0 38 17 18 57 186 0 26 0 15 0 23 17 18 57 184 0 23 16 185 0 30 0 1 244 184 0 6 16 185 0 51 0 1 244 184 0 26 16 185 0 57 0 1 244 48 49 23 17 52 62 2 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 35 34 38 39 30 1 23 55 50 62 2 53 52 38 35 34 7 39 62 3 53 52 46 2 35 34 6 7 14 1 21 30 1 93 25 50 76 51 37 68 53 32 54 52 75 90 33 55 71 38 47 92 38 2 3 1 151 28 49 37 21 70 71 26 24 13 40 55 35 16 17 30 39 22 57 65 1 1 1 35 83 179 2 162 49 84 61 35 21 43 65 44 54 82 30 4 11 100 77 49 76 53 27 32 42 62 117 62 236 19 36 53 33 58 78 6 63 8 32 42 48 24 28 42 28 14 88 89 88 171 88 46 30 0 0 0 0 1 0 48 255 77 2 26 1 242 0 29 0 69 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 16 0 10 0 0 17 18 57 184 0 10 16 184 0 20 208 184 0 20 47 184 0 16 16 185 0 26 0 1 244 48 49 23 62 2 52 53 52 46 2 39 55 30 3 23 51 62 1 55 51 14 3 7 30 1 21 255 1 2 1 36 58 77 40 82 26 52 47 39 13 4 54 77 14 82 12 32 48 69 48 6 4 179 16 27 27 31 20 58 144 147 136 50 21 33 90 105 116 57 95 192 102 62 110 112 122 75 44 98 42 0 0 0 0 2 0 65 255 244 2 23 2 212 0 44 0 60 0 77 0 184 0 0 69 88 184 0 20 47 27 185 0 20 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 53 0 20 0 0 17 18 57 186 0 10 0 20 0 53 17 18 57 184 0 20 16 185 0 27 0 1 244 184 0 0 16 185 0 45 0 1 244 48 49 5 34 46 2 53 52 62 2 55 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 30 2 23 30 3 21 20 14 2 39 50 54 53 52 46 2 39 14 1 21 20 30 2 1 44 45 85 66 39 31 53 71 41 30 53 39 22 20 41 62 43 53 117 71 20 74 106 42 45 39 24 43 60 37 36 64 46 27 32 60 88 53 75 77 20 35 47 27 85 95 26 43 57 12 30 57 82 52 44 73 58 42 14 19 38 42 48 28 22 39 30 18 20 24 65 26 19 30 20 20 35 34 38 23 23 48 57 69 44 52 85 61 33 68 89 73 31 52 43 38 17 19 97 72 36 57 40 22 0 1 0 91 255 244 2 22 1 242 0 47 0 87 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 34 0 15 0 0 17 18 57 184 0 34 47 185 0 27 0 1 244 186 0 6 0 27 0 34 17 18 57 184 0 15 16 185 0 21 0 1 244 184 0 0 16 185 0 39 0 1 244 48 49 5 34 38 53 52 54 55 53 46 1 53 52 62 2 51 50 22 23 7 38 35 34 6 21 20 22 51 50 54 55 21 38 34 35 34 21 20 22 51 50 54 55 23 14 3 1 64 107 122 65 46 43 44 31 56 77 46 54 97 42 33 73 85 61 69 67 74 14 29 18 21 37 18 150 77 79 45 81 44 35 27 50 52 54 12 77 69 52 56 13 4 16 58 34 33 50 32 16 32 30 55 52 38 38 33 40 1 2 68 2 80 41 46 23 35 55 20 27 16 6 0 0 0 0 1 0 116 255 72 2 12 2 200 0 45 0 78 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 15 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 25 16 185 0 19 0 1 244 184 0 27 208 184 0 9 16 185 0 38 0 1 244 48 49 5 39 62 1 53 52 46 2 39 46 3 53 52 62 2 55 42 1 14 1 7 53 33 21 35 14 3 21 20 30 2 23 30 3 21 20 6 1 211 66 26 23 12 30 51 39 40 73 56 33 54 89 111 57 25 73 78 77 28 1 121 5 59 114 89 55 23 43 61 39 40 59 39 19 27 184 27 32 36 20 11 16 14 12 8 8 29 52 81 60 60 121 112 98 37 2 2 1 67 67 35 99 112 119 54 43 58 38 22 7 8 17 24 34 25 23 69 0 0 0 0 1 0 93 255 77 2 2 1 242 0 29 0 96 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 3 62 89 184 0 25 16 185 0 8 0 1 244 186 0 21 0 25 0 15 17 18 57 184 0 21 16 185 0 13 0 1 244 184 0 25 16 184 0 19 208 184 0 19 47 48 49 5 62 3 53 52 38 35 34 14 2 7 17 35 17 52 38 39 51 23 51 62 1 51 50 22 21 17 1 175 1 2 2 1 43 51 23 39 37 40 22 82 2 5 75 7 3 41 89 59 78 69 179 60 124 122 117 53 69 61 9 24 40 30 254 188 1 97 29 66 38 95 56 51 96 94 254 25 0 0 3 0 72 255 244 2 16 2 212 0 15 0 26 0 37 0 77 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 8 16 185 0 16 0 1 244 186 0 32 0 8 0 0 17 18 57 184 0 32 47 185 0 21 0 1 244 184 0 0 16 185 0 27 0 1 244 48 49 5 34 46 2 53 52 54 51 50 22 21 20 14 2 3 34 14 2 7 33 46 3 3 50 62 2 55 33 30 3 1 44 53 84 59 32 122 106 106 122 32 59 84 53 30 52 39 24 2 1 38 2 24 39 52 30 30 52 39 24 2 254 218 2 23 39 53 12 44 91 140 96 180 185 185 180 96 140 91 44 2 156 30 64 101 71 71 101 64 30 253 168 28 65 105 77 77 105 65 28 0 0 1 0 81 255 244 2 13 1 230 0 21 0 57 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 6 16 185 0 4 0 1 244 184 0 0 16 185 0 15 0 1 244 48 49 5 34 38 53 17 35 53 51 14 3 21 20 22 51 50 54 55 23 14 1 1 144 81 72 166 249 1 2 2 1 47 47 19 44 23 21 26 59 12 88 87 1 0 67 41 86 85 81 36 53 48 9 11 61 12 15 0 0 1 0 100 255 248 2 65 1 242 0 35 0 93 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 7 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 3 62 89 186 0 5 0 11 0 15 17 18 57 186 0 20 0 15 0 11 17 18 57 184 0 15 16 184 0 26 208 184 0 26 47 185 0 27 0 1 244 186 0 30 0 15 0 11 17 18 57 184 0 11 16 184 0 35 208 48 49 5 46 3 39 6 7 6 29 1 35 17 52 38 39 51 30 1 29 1 51 62 3 55 23 14 1 7 30 3 23 1 228 22 51 51 49 19 35 33 37 77 3 7 82 5 4 4 30 78 89 94 47 9 48 98 49 20 55 61 64 30 8 25 62 68 72 36 38 45 54 93 25 1 97 29 72 32 20 61 32 152 52 91 72 50 12 78 14 55 42 38 82 80 76 33 0 0 0 1 0 56 255 248 2 41 2 212 0 22 0 75 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 15 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 3 62 89 186 0 2 0 13 0 1 17 18 57 184 0 13 16 185 0 6 0 1 244 184 0 1 16 184 0 19 208 186 0 22 0 1 0 13 17 18 57 48 49 23 39 19 39 46 1 35 34 6 7 39 62 1 51 50 30 2 23 19 35 3 35 145 89 224 8 24 57 45 20 29 13 21 17 43 32 38 58 47 38 19 198 89 145 4 8 8 1 241 23 71 63 10 6 68 8 10 24 51 77 53 253 249 1 147 0 0 0 1 0 84 255 69 2 39 1 230 0 40 0 118 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 32 47 27 185 0 32 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 32 16 185 0 6 0 1 244 184 0 1 16 184 0 13 208 186 0 28 0 32 0 13 17 18 57 184 0 28 16 185 0 11 0 1 244 184 0 6 16 184 0 19 208 184 0 32 16 184 0 25 208 186 0 35 0 1 0 32 17 18 57 48 49 23 17 51 17 20 22 51 50 62 2 55 17 51 14 1 21 20 22 51 58 1 55 23 6 35 34 38 39 35 14 1 35 34 38 39 20 30 2 23 84 82 49 54 19 36 37 37 19 83 2 4 16 12 4 7 7 11 18 29 38 39 3 2 30 79 45 33 55 20 1 1 3 2 187 2 161 254 221 67 69 8 22 42 33 1 66 99 207 88 20 16 2 62 8 45 59 52 50 21 32 38 59 52 51 30 0 0 0 0 1 0 47 0 0 2 28 1 242 0 23 0 59 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 11 0 5 0 0 17 18 57 184 0 5 16 184 0 18 208 184 0 18 47 48 49 33 46 3 39 55 30 3 23 51 62 3 55 51 14 3 7 1 1 14 43 56 64 33 82 28 56 48 38 10 4 25 48 40 27 4 83 10 36 51 65 40 72 132 120 106 47 21 39 99 108 113 54 47 100 102 103 49 63 119 119 120 65 0 0 1 0 92 255 72 2 15 2 200 0 69 0 112 0 184 0 0 69 88 184 0 32 47 27 185 0 32 0 15 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 52 0 32 0 9 17 18 57 184 0 52 47 185 0 45 0 1 244 186 0 19 0 45 0 52 17 18 57 184 0 32 16 185 0 26 0 1 244 184 0 34 208 184 0 34 47 184 0 9 16 185 0 62 0 1 244 48 49 5 39 62 1 53 52 46 2 39 46 3 53 52 62 2 55 53 46 1 53 52 54 55 42 1 14 1 7 53 33 21 35 34 14 2 21 20 30 2 51 50 54 55 21 46 1 35 34 14 2 21 20 30 2 23 30 3 21 20 6 1 214 66 26 22 11 30 51 39 42 76 57 34 26 43 58 32 48 63 41 37 21 33 33 36 23 1 175 144 27 50 37 22 24 39 50 25 23 32 23 23 37 23 34 65 50 30 27 47 64 38 41 59 37 17 26 184 27 32 36 20 11 16 14 12 8 9 26 44 66 48 36 63 50 36 9 4 20 71 53 42 62 19 2 2 1 67 67 16 30 45 29 26 44 32 18 1 4 72 4 1 20 37 55 35 36 47 30 18 7 8 17 24 34 25 23 69 0 0 2 0 64 255 244 2 24 1 242 0 19 0 39 0 53 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 20 0 1 244 184 0 10 16 185 0 30 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 44 48 86 64 38 38 64 86 48 48 86 64 38 38 64 86 48 35 56 39 21 21 39 56 35 35 56 39 21 21 39 56 12 34 65 95 60 61 95 66 34 34 66 95 61 60 95 65 34 68 27 49 68 42 42 69 50 27 27 50 69 42 42 68 49 27 0 1 0 27 255 244 2 61 1 230 0 36 0 81 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 19 16 185 0 16 0 1 244 184 0 8 208 184 0 0 16 184 0 13 208 184 0 13 47 184 0 8 16 184 0 21 208 184 0 0 16 185 0 30 0 1 244 48 49 5 34 38 53 52 62 2 53 35 20 6 7 39 62 1 53 35 53 55 33 21 35 14 2 20 21 20 22 51 50 54 55 23 14 1 1 247 58 48 1 2 2 197 7 8 82 12 8 101 69 1 221 92 2 3 2 22 23 5 12 10 12 11 26 12 62 60 19 71 86 92 40 103 213 107 5 108 211 99 63 5 68 41 95 89 71 18 26 22 3 3 63 5 6 0 0 0 0 2 0 93 255 77 2 28 1 242 0 22 0 43 0 90 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 3 62 89 186 0 17 0 6 0 14 17 18 57 185 0 23 0 1 244 184 0 6 16 185 0 33 0 1 244 184 0 17 16 185 0 39 0 1 244 48 49 23 17 52 62 2 51 50 22 21 20 14 2 35 34 38 39 30 3 21 55 50 62 2 53 52 46 2 35 34 14 2 29 1 30 3 93 36 61 82 47 108 113 36 59 77 40 42 81 35 1 2 1 2 138 29 52 38 22 16 34 52 37 29 52 40 23 18 35 36 36 179 1 171 63 94 62 31 132 116 62 97 68 35 28 41 33 57 56 58 32 236 27 49 72 45 40 66 47 26 23 45 68 46 124 21 26 14 5 0 0 0 2 0 60 255 244 2 60 1 230 0 23 0 41 0 61 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 34 0 1 244 184 0 12 208 184 0 0 16 185 0 24 0 1 244 48 49 5 34 46 2 53 52 62 2 51 33 21 46 1 39 21 30 1 21 20 14 2 39 50 62 2 53 52 46 2 35 34 6 21 20 30 2 1 34 47 83 63 37 39 65 84 46 1 22 43 73 42 48 52 35 60 82 47 31 53 38 21 18 36 53 34 63 84 22 39 53 12 33 63 94 60 64 93 61 30 70 3 4 1 4 26 98 69 57 88 62 32 68 25 46 66 41 36 67 51 30 89 91 42 67 48 25 0 0 1 0 66 255 244 2 22 1 230 0 22 0 61 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 7 16 185 0 4 0 1 244 184 0 9 208 184 0 0 16 185 0 16 0 1 244 48 49 5 34 38 53 17 35 53 55 33 21 35 14 1 21 20 22 51 50 54 55 23 14 1 1 120 65 52 193 70 1 142 194 2 2 29 29 15 29 17 11 17 47 12 71 68 1 36 62 5 67 78 151 69 35 30 6 5 64 6 9 0 0 1 0 79 255 244 2 15 1 242 0 39 0 55 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 23 0 1 244 184 0 9 16 184 0 32 208 184 0 32 47 48 49 5 34 38 53 52 54 53 52 38 39 51 30 1 21 20 14 2 21 20 30 2 51 50 62 2 53 52 38 39 55 30 1 21 20 14 2 1 38 99 112 4 3 5 80 5 2 2 2 2 22 37 49 27 32 54 40 22 18 22 80 20 24 34 62 86 12 103 106 39 78 39 29 66 38 26 55 32 19 46 48 47 21 37 52 32 15 24 49 76 52 51 108 63 19 60 118 61 66 101 69 35 0 0 0 3 0 44 255 77 2 44 2 110 0 6 0 13 0 39 0 106 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 7 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 3 62 89 185 0 3 0 1 244 184 0 25 16 185 0 4 0 1 244 184 0 10 208 184 0 3 16 184 0 11 208 184 0 25 16 184 0 27 220 184 0 25 16 184 0 28 208 184 0 15 16 184 0 38 208 48 49 55 20 22 23 17 14 1 5 52 38 39 17 62 1 3 53 46 3 53 52 62 2 55 53 51 21 30 3 21 20 14 2 7 21 128 75 57 57 75 1 88 75 57 57 75 212 44 78 59 35 35 59 78 44 80 43 79 59 35 35 59 79 43 244 85 97 5 1 116 5 95 85 85 95 5 254 140 5 97 254 174 170 3 35 64 92 59 58 92 63 35 3 127 127 3 35 63 92 58 59 92 64 35 3 170 0 0 0 0 1 0 56 255 65 2 48 1 242 0 13 0 81 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 7 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 186 0 2 0 5 0 12 17 18 57 184 0 3 16 184 0 8 208 184 0 8 47 186 0 9 0 12 0 5 17 18 57 184 0 1 16 184 0 10 208 184 0 10 47 48 49 23 39 19 3 55 19 51 55 51 3 19 7 3 35 139 83 206 203 82 160 4 137 87 185 216 80 175 4 191 12 1 86 1 58 21 254 250 250 254 190 254 178 21 1 31 0 1 0 53 255 77 2 41 2 110 0 41 0 96 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 3 62 89 185 0 22 0 1 244 184 0 10 16 184 0 23 220 184 0 22 16 184 0 25 208 184 0 10 16 184 0 34 208 184 0 34 47 184 0 1 16 184 0 40 208 48 49 5 53 46 3 61 1 52 38 39 51 30 1 21 20 6 20 6 21 20 22 51 17 51 17 62 1 53 52 46 2 39 55 30 1 21 20 6 7 21 1 6 52 76 50 24 2 5 80 4 2 1 1 60 65 80 63 69 4 9 15 12 76 23 20 111 100 179 167 1 34 60 82 50 138 29 66 38 26 55 32 21 47 44 38 12 72 84 2 55 253 202 5 98 97 28 52 53 57 33 19 63 111 66 125 139 5 168 0 0 0 0 1 0 34 255 244 2 54 1 242 0 55 0 73 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 17 0 1 244 184 0 32 208 184 0 8 16 184 0 41 208 184 0 0 16 184 0 49 208 186 0 53 0 8 0 0 17 18 57 48 49 23 34 46 2 53 52 54 55 23 14 3 21 20 22 51 50 54 53 52 38 39 51 14 1 21 20 30 2 51 50 54 53 52 46 2 39 55 30 3 21 20 6 35 34 38 39 35 14 1 190 33 57 42 24 53 38 72 21 31 21 10 46 35 28 41 4 4 85 4 3 11 18 25 14 36 44 9 18 29 20 73 19 32 23 13 85 69 35 59 17 4 17 55 12 30 60 91 60 78 134 57 33 30 58 60 65 38 76 82 54 68 30 61 39 39 61 30 35 47 28 12 83 88 37 61 56 55 31 31 29 58 65 72 42 123 121 39 42 42 39 0 0 1 0 90 255 76 2 12 1 242 0 43 0 57 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 36 0 1 0 9 0 4 43 184 0 19 16 185 0 26 0 1 244 48 49 5 39 62 1 53 52 46 2 39 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 23 30 3 21 20 6 1 182 66 26 27 8 23 43 35 43 82 63 38 42 71 93 51 61 84 32 42 30 60 41 38 64 47 27 27 48 65 38 43 57 33 13 30 180 26 33 44 22 12 19 17 14 7 9 33 55 83 60 58 91 63 32 39 29 53 27 26 25 46 65 40 43 59 39 24 8 9 20 27 37 25 26 75 0 3 0 93 255 244 2 32 2 212 0 29 0 43 0 62 0 85 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 11 16 185 0 41 0 1 244 186 0 54 0 11 0 0 17 18 57 184 0 54 47 186 0 20 0 41 0 54 17 18 57 184 0 33 208 184 0 0 16 185 0 44 0 1 244 48 49 5 34 46 2 53 17 52 62 2 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 3 20 6 21 62 3 53 52 38 35 34 6 19 50 62 2 53 52 46 2 35 34 6 7 21 20 30 2 1 73 41 83 69 43 25 51 77 52 35 67 53 32 59 54 40 63 45 24 33 59 78 201 1 64 89 55 24 64 42 60 63 151 30 50 36 20 17 35 53 36 15 72 63 32 48 54 12 25 55 90 66 1 15 49 84 62 34 21 43 65 44 54 84 28 4 4 32 50 67 39 47 74 52 28 1 236 33 54 24 12 34 44 54 32 56 56 89 254 4 20 36 49 29 30 51 37 22 11 17 69 54 68 40 15 0 0 0 0 2 0 79 255 244 2 16 2 212 0 12 0 50 0 87 0 184 0 0 69 88 184 0 43 47 27 185 0 43 0 15 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 3 62 89 186 0 33 0 43 0 13 17 18 57 184 0 33 47 185 0 5 0 1 244 184 0 43 16 185 0 10 0 1 244 186 0 19 0 33 0 13 17 18 57 184 0 13 16 185 0 28 0 1 244 48 49 19 20 30 2 55 46 3 35 34 6 19 34 38 53 52 38 39 51 30 1 21 20 30 2 51 50 62 2 55 6 46 2 53 52 62 2 51 50 22 21 20 14 2 158 25 65 112 86 2 26 43 59 36 54 68 139 93 103 3 5 77 6 2 19 34 44 26 30 52 39 23 2 107 142 84 35 31 54 72 41 125 126 33 61 85 2 29 32 62 45 18 12 70 100 62 28 62 253 162 98 96 39 47 23 14 51 34 37 52 32 15 25 65 110 85 15 31 63 84 38 41 67 48 26 185 177 103 143 88 40 0 0 0 0 2 0 37 255 77 2 51 1 246 0 33 0 45 0 102 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 3 62 89 184 0 22 16 184 0 9 208 184 0 9 47 184 0 1 16 185 0 18 0 1 244 184 0 1 16 184 0 30 208 184 0 18 16 184 0 37 208 184 0 22 16 185 0 43 0 1 244 48 49 5 53 46 3 53 52 54 55 23 14 3 21 20 22 23 53 52 54 51 50 22 21 20 14 2 7 30 1 23 3 20 22 23 62 1 53 52 38 35 34 6 1 4 44 81 61 37 61 46 64 22 33 23 12 79 63 83 64 75 81 36 61 81 44 1 2 1 6 1 1 62 78 39 38 30 35 179 170 3 33 63 92 61 75 130 54 48 26 50 52 58 34 81 92 6 241 106 96 130 114 60 95 67 37 3 44 85 42 1 222 61 121 62 6 101 88 83 96 58 0 0 0 255 255 0 57 255 244 2 63 3 31 2 38 2 117 0 0 0 6 4 241 24 0 0 0 255 255 0 91 255 244 2 22 3 31 2 38 2 121 0 0 0 6 4 241 36 0 0 0 255 255 0 93 255 77 2 2 3 31 2 38 2 123 0 0 0 6 4 241 26 0 0 0 255 255 0 81 255 244 2 13 3 31 2 38 2 125 0 0 0 6 4 241 239 0 0 0 255 255 0 81 255 244 2 13 2 188 2 38 2 125 0 0 0 6 5 0 239 0 0 0 255 255 0 64 255 244 2 24 3 31 2 38 2 131 0 0 0 6 4 241 0 0 0 0 255 255 0 79 255 244 2 15 3 31 2 38 2 136 0 0 0 6 4 241 253 0 0 0 255 255 0 79 255 244 2 15 2 188 2 38 2 136 0 0 0 6 5 0 253 0 0 0 255 255 0 34 255 244 2 54 3 31 2 38 2 140 0 0 0 6 4 241 0 0 0 0 255 255 0 81 255 244 2 13 3 31 2 38 2 125 0 0 0 6 5 59 239 0 0 0 255 255 0 79 255 244 2 15 3 31 2 38 2 136 0 0 0 6 5 59 253 0 0 0 0 1 0 100 255 69 2 65 1 242 0 41 0 105 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 7 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 3 62 89 184 0 4 208 184 0 4 47 184 0 0 220 186 0 9 0 15 0 19 17 18 57 186 0 24 0 19 0 15 17 18 57 184 0 19 16 184 0 30 208 184 0 30 47 185 0 31 0 1 244 186 0 34 0 19 0 15 17 18 57 184 0 4 16 184 0 39 208 48 49 5 39 62 1 55 46 3 39 6 7 6 29 1 35 17 52 38 39 51 30 1 29 1 51 62 3 55 23 14 1 7 30 3 23 14 1 1 185 95 39 70 28 22 51 51 48 19 35 33 37 77 3 7 82 5 4 4 30 78 89 94 47 9 48 98 49 20 55 61 64 30 33 73 187 8 41 88 43 25 62 67 72 36 38 45 54 93 25 1 97 29 72 32 20 61 32 152 52 91 72 50 12 78 14 55 42 38 82 80 76 33 53 99 0 2 0 62 255 77 2 26 1 242 0 11 0 38 0 78 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 7 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 3 62 89 185 0 0 0 1 244 184 0 23 16 185 0 6 0 1 244 184 0 13 16 184 0 33 208 48 49 37 50 54 53 52 38 35 34 6 21 20 22 23 53 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 30 3 23 1 44 72 81 81 72 72 81 81 35 42 74 54 31 38 65 86 49 49 86 65 38 30 53 72 42 1 1 1 1 1 54 102 86 85 103 103 85 86 102 233 170 6 38 64 88 55 61 96 65 34 34 65 96 61 54 87 64 39 7 23 39 39 43 26 0 0 1 0 91 255 76 2 1 1 230 0 39 0 57 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 32 0 1 0 9 0 4 43 184 0 19 16 185 0 24 0 1 244 48 49 5 39 62 1 53 52 46 2 39 46 3 53 52 62 2 59 1 21 38 34 35 34 6 21 20 30 2 23 30 3 21 20 6 1 182 65 26 26 7 22 43 37 44 81 63 37 41 72 97 56 156 31 78 42 85 101 26 46 66 39 43 57 33 13 30 180 26 33 44 20 12 19 17 15 8 10 33 54 78 56 62 91 59 29 70 2 85 88 39 54 38 25 8 9 21 27 36 25 26 75 0 0 1 0 146 255 77 2 11 1 230 0 11 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 1 16 185 0 3 0 1 244 184 0 7 16 185 0 6 0 1 244 48 49 23 17 33 21 33 23 33 21 33 20 22 23 146 1 121 254 211 2 1 10 254 247 2 2 179 2 153 67 217 59 81 153 88 0 1 0 68 255 77 2 13 2 178 0 29 0 0 5 39 62 1 53 52 39 14 1 7 39 37 38 39 14 1 7 39 37 46 1 39 55 30 3 21 20 6 1 251 80 10 8 10 63 121 69 34 1 16 15 27 69 132 75 34 1 22 42 116 75 51 87 135 91 48 8 179 10 48 92 46 67 59 29 57 35 69 122 63 56 31 62 38 69 125 72 118 44 61 53 146 174 197 104 51 95 0 0 0 255 255 0 197 255 43 1 140 2 3 2 39 3 130 0 0 1 102 0 6 3 131 0 0 255 255 0 219 1 84 1 125 1 253 2 7 3 130 0 0 1 96 0 0 255 255 0 219 2 11 1 125 2 180 2 7 3 130 0 0 2 23 0 0 0 1 1 1 1 193 1 104 2 178 0 4 0 11 0 186 0 2 0 0 0 3 43 48 49 1 55 51 15 1 1 1 22 81 14 35 1 193 241 92 149 0 0 0 0 1 0 240 0 0 1 87 0 242 0 4 0 11 0 186 0 2 0 4 0 3 43 48 49 51 63 1 51 7 240 14 35 54 22 92 150 242 0 0 255 255 1 9 2 47 1 141 3 31 2 6 4 241 0 0 0 1 0 240 1 133 1 99 2 178 0 3 0 11 0 186 0 2 0 0 0 3 43 48 49 1 39 19 23 1 41 57 36 79 1 133 10 1 35 10 255 255 0 139 2 52 1 205 3 31 2 6 5 59 0 0 255 255 1 11 255 55 1 134 255 194 2 6 5 54 0 0 0 1 0 251 255 244 1 148 1 150 0 16 0 30 0 184 0 4 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 11 0 1 244 48 49 5 34 38 53 17 51 14 1 21 20 22 51 50 55 23 14 1 1 90 51 44 83 2 3 19 16 12 17 11 11 27 12 59 54 1 49 81 158 72 20 19 6 62 5 7 0 0 0 255 255 0 232 2 60 1 124 2 248 2 6 5 2 0 0 255 255 0 232 2 60 1 124 2 248 2 6 5 2 0 0 255 255 0 220 2 62 1 112 2 248 2 6 5 18 0 0 255 255 0 209 2 46 1 77 3 2 2 6 4 238 0 0 255 255 1 9 2 47 1 141 3 31 2 6 4 241 0 0 255 255 0 144 2 47 1 159 3 2 2 6 5 94 0 0 255 255 0 138 2 47 1 152 3 2 2 6 5 91 0 0 255 255 0 144 2 47 1 172 3 2 2 6 5 93 0 0 255 255 0 148 2 47 1 166 3 2 2 6 5 90 0 0 255 255 0 159 2 50 1 185 3 39 2 6 5 95 0 0 255 255 0 159 2 50 1 185 3 39 2 6 5 92 0 0 255 255 0 127 2 65 1 217 2 209 2 6 4 244 0 0 255 255 0 145 2 51 1 199 3 6 2 6 5 62 0 0 255 255 0 139 2 52 1 205 3 31 2 6 5 59 0 0 255 255 0 147 2 76 1 197 3 38 2 6 5 63 0 0 0 1 0 229 1 205 1 120 2 153 0 15 0 23 0 186 0 1 0 0 0 3 43 184 0 1 16 184 0 7 220 184 0 8 220 48 49 1 39 62 1 53 52 38 39 55 30 1 21 20 14 2 1 9 10 24 33 41 42 8 66 73 18 31 40 1 205 38 9 30 27 23 28 2 47 2 45 44 27 38 26 17 0 0 0 1 0 228 1 205 1 119 2 153 0 15 0 23 0 186 0 15 0 0 0 3 43 184 0 15 16 184 0 9 220 184 0 8 220 48 49 1 46 3 53 52 54 55 23 14 1 21 20 22 23 1 83 22 40 31 18 72 66 9 42 41 33 23 1 205 5 17 26 38 27 44 45 2 47 2 28 23 27 30 9 0 0 0 0 1 0 246 1 208 1 95 2 158 0 3 0 11 0 186 0 2 0 0 0 3 43 48 49 1 39 55 23 1 40 50 76 29 1 208 195 11 195 0 255 255 0 240 1 133 1 99 2 178 2 6 2 167 0 0 0 2 0 170 1 208 1 182 2 158 0 14 0 18 0 39 0 186 0 1 0 0 0 3 43 184 0 1 16 184 0 6 220 184 0 7 220 184 0 0 16 184 0 15 208 184 0 7 16 184 0 17 208 48 49 19 39 62 1 53 52 39 55 30 1 21 20 14 2 23 39 55 23 206 12 17 25 66 8 54 64 16 25 33 161 50 75 30 1 208 38 11 30 21 52 5 47 2 47 46 22 35 27 19 6 195 11 195 0 2 0 170 1 208 1 180 2 158 0 14 0 18 0 39 0 186 0 14 0 0 0 3 43 184 0 14 16 184 0 9 220 184 0 8 220 184 0 0 16 184 0 15 208 184 0 8 16 184 0 17 208 48 49 1 46 3 53 52 54 55 23 6 21 20 22 31 1 39 55 23 1 5 17 33 25 16 64 54 9 67 25 18 108 50 75 30 1 208 6 19 27 35 22 46 47 2 47 4 53 21 30 11 38 195 11 195 0 2 0 170 1 208 1 181 2 158 0 14 0 18 0 39 0 186 0 1 0 0 0 3 43 184 0 1 16 184 0 6 220 184 0 7 220 184 0 0 16 184 0 15 208 184 0 7 16 184 0 17 208 48 49 19 39 62 1 53 52 39 55 30 1 21 20 14 2 23 39 55 23 206 12 17 25 66 8 54 64 16 25 33 165 55 29 76 1 208 38 11 30 21 52 5 47 2 47 46 22 35 27 19 6 11 195 11 0 2 0 172 1 208 1 181 2 158 0 14 0 18 0 35 0 186 0 14 0 0 0 3 43 184 0 14 16 184 0 9 220 184 0 8 220 184 0 16 208 184 0 0 16 184 0 18 208 48 49 1 46 3 53 52 54 55 23 6 21 20 22 31 1 55 23 7 1 7 17 33 25 16 64 54 9 67 25 18 57 29 76 50 1 208 6 19 27 35 22 46 47 2 47 4 53 21 30 11 27 195 11 195 0 2 0 182 1 183 1 162 2 160 0 23 0 39 0 59 0 186 0 25 0 24 0 3 43 186 0 17 0 0 0 3 43 184 0 17 16 184 0 5 208 184 0 0 16 184 0 8 208 184 0 5 16 184 0 12 220 184 0 20 208 184 0 25 16 184 0 31 220 184 0 32 220 48 49 1 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 54 55 23 14 1 7 39 62 1 53 52 38 39 55 30 1 21 20 14 2 1 93 18 25 21 19 12 12 16 2 42 4 32 33 18 25 21 19 12 12 16 2 42 4 32 109 8 18 24 32 37 7 59 63 16 26 34 2 80 11 13 11 12 19 6 35 35 11 13 11 12 19 6 35 35 153 33 5 14 10 14 16 2 39 2 29 31 15 24 17 12 0 0 2 0 182 1 183 1 162 2 160 0 15 0 39 0 59 0 186 0 15 0 0 0 3 43 186 0 33 0 16 0 3 43 184 0 15 16 184 0 9 220 184 0 8 220 184 0 33 16 184 0 21 208 184 0 16 16 184 0 24 208 184 0 21 16 184 0 28 220 184 0 36 208 48 49 1 46 3 53 52 54 55 23 14 1 21 20 22 23 55 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 54 55 23 14 1 1 71 18 34 26 16 63 59 7 37 32 24 18 14 18 25 21 19 12 12 16 2 42 4 32 33 18 25 21 19 12 12 16 2 42 4 32 1 183 3 12 17 24 15 31 29 2 39 2 16 14 10 14 5 120 11 13 11 12 19 6 35 35 11 13 11 12 19 6 35 35 0 0 255 255 0 32 0 0 2 56 2 144 2 6 0 4 0 0 0 2 0 99 0 0 2 35 2 144 0 14 0 23 0 77 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 1 16 185 0 3 0 1 244 186 0 22 0 1 0 0 17 18 57 184 0 22 47 185 0 5 0 1 244 184 0 0 16 185 0 16 0 1 244 48 49 51 17 33 21 33 21 51 50 30 2 21 20 6 35 39 51 50 54 53 52 38 43 1 99 1 149 254 190 126 52 88 63 36 127 108 130 116 85 82 84 85 114 2 144 70 206 20 43 69 49 103 96 70 56 68 63 53 0 0 255 255 0 99 0 0 2 35 2 144 2 6 0 5 0 0 255 255 0 135 0 0 2 23 2 144 2 6 2 86 0 0 0 2 0 22 255 68 2 66 2 144 0 22 0 33 0 86 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 3 62 89 185 0 2 0 1 244 184 0 27 208 184 0 16 208 184 0 0 16 184 0 19 208 184 0 13 16 185 0 28 0 1 244 48 49 23 39 53 51 62 3 55 62 3 55 33 17 51 21 7 35 53 33 21 19 14 1 7 33 17 35 14 3 31 9 30 9 20 21 22 11 9 14 13 13 8 1 57 73 9 73 254 120 106 14 34 20 1 24 165 7 11 10 12 188 209 50 4 25 54 88 65 49 82 80 85 53 253 183 50 209 188 188 1 225 85 106 31 2 3 42 71 67 71 0 255 255 0 114 0 0 2 18 2 144 2 6 0 8 0 0 0 1 0 1 0 0 2 87 2 156 0 53 0 143 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 51 0 14 0 0 17 18 57 184 0 51 47 185 0 21 0 1 244 186 0 1 0 21 0 51 17 18 57 184 0 14 16 185 0 7 0 1 244 184 0 14 16 184 0 22 208 184 0 22 47 184 0 21 16 184 0 25 208 184 0 14 16 184 0 31 208 184 0 7 16 184 0 38 208 184 0 51 16 184 0 47 208 186 0 44 0 25 0 47 17 18 57 184 0 0 16 184 0 50 208 184 0 46 208 48 49 51 19 39 46 3 35 34 6 7 39 62 1 51 50 30 2 31 1 51 17 51 17 51 55 62 3 51 50 22 23 7 46 1 35 34 14 2 15 1 19 35 3 35 17 35 17 35 3 2 139 43 8 16 15 16 8 5 11 5 13 7 24 9 19 34 30 27 11 47 53 76 53 47 11 25 29 33 19 9 28 7 13 5 11 5 8 16 15 16 8 43 139 90 110 60 76 60 110 1 95 158 26 31 16 5 2 2 80 2 3 9 25 47 39 168 1 20 254 236 168 39 47 25 9 3 2 80 2 2 5 16 31 26 158 254 161 1 53 254 203 1 53 254 203 0 0 0 0 1 0 62 255 244 2 28 2 156 0 47 0 83 0 184 0 0 69 88 184 0 31 47 27 185 0 31 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 16 0 31 0 0 17 18 57 184 0 16 47 185 0 17 0 1 244 184 0 31 16 185 0 24 0 1 244 186 0 40 0 17 0 16 17 18 57 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 38 43 1 53 51 50 54 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 1 45 72 116 51 47 44 89 58 33 57 43 25 94 86 74 54 88 78 74 57 47 79 31 45 36 107 61 47 78 55 31 50 48 57 75 37 65 87 12 46 51 57 44 37 17 33 48 31 63 60 64 57 56 52 53 34 29 56 35 45 23 43 63 39 52 79 17 4 11 83 68 47 74 51 26 0 0 0 1 0 78 0 0 2 10 2 144 0 19 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 6 0 1 0 0 17 18 57 184 0 1 16 184 0 9 208 184 0 0 16 184 0 12 208 186 0 17 0 0 0 1 17 18 57 48 49 51 17 51 17 20 6 7 51 55 19 51 17 35 17 52 54 55 35 7 3 78 80 9 2 2 63 218 92 80 9 2 2 63 218 2 144 254 172 52 107 49 136 1 156 253 112 1 87 51 103 51 136 254 100 0 0 0 255 255 0 78 0 0 2 10 3 69 2 38 2 204 0 0 0 6 4 253 4 0 0 0 0 1 0 102 0 0 2 68 2 156 0 28 0 97 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 184 0 1 208 184 0 1 47 186 0 27 0 10 0 0 17 18 57 184 0 27 47 185 0 4 0 1 244 184 0 10 16 185 0 17 0 1 244 186 0 23 0 4 0 27 17 18 57 184 0 0 16 184 0 25 208 48 49 51 17 51 17 51 55 62 3 51 50 22 23 7 46 1 35 34 14 2 15 1 19 35 3 35 17 102 83 107 88 19 35 34 37 23 9 19 8 15 6 12 5 11 19 19 23 14 81 221 92 196 107 2 144 254 236 166 37 48 27 10 3 3 78 2 2 6 17 33 27 153 254 160 1 53 254 203 0 1 0 2 255 244 2 9 2 144 0 28 0 65 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 6 0 1 244 184 0 0 16 184 0 19 208 184 0 19 47 184 0 16 16 185 0 20 0 1 244 48 49 23 34 38 39 55 22 51 50 62 2 55 62 3 55 33 17 35 17 35 14 1 7 14 3 58 16 26 14 17 15 13 12 22 20 20 12 10 19 18 17 10 1 58 84 165 16 27 17 15 30 36 45 12 4 5 77 6 11 37 69 59 53 100 101 103 55 253 112 2 74 91 169 91 75 96 55 21 255 255 0 72 0 0 2 16 2 144 2 6 0 16 0 0 255 255 0 79 0 0 2 9 2 144 2 6 0 11 0 0 255 255 0 48 255 244 2 40 2 156 2 6 0 18 0 0 255 255 0 79 0 0 2 9 2 144 2 6 2 99 0 0 255 255 0 102 0 0 2 31 2 144 2 6 0 19 0 0 255 255 0 65 255 244 2 42 2 156 2 6 0 6 0 0 255 255 0 42 0 0 2 46 2 144 2 6 0 23 0 0 0 1 0 47 255 244 2 44 2 144 0 22 0 71 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 11 0 0 0 12 17 18 57 186 0 15 0 12 0 0 17 18 57 184 0 12 16 184 0 18 208 48 49 23 34 38 39 55 30 1 51 50 54 63 1 3 51 19 23 51 55 19 51 3 14 1 178 22 29 14 18 8 19 15 32 38 14 14 224 89 122 50 4 47 112 85 215 25 75 12 5 5 75 3 4 25 28 35 1 246 254 220 129 129 1 36 253 231 61 70 0 3 0 26 255 244 2 62 2 156 0 6 0 13 0 31 0 89 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 13 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 3 62 89 184 0 15 220 185 0 3 0 1 244 184 0 22 16 184 0 21 220 185 0 4 0 1 244 184 0 10 208 184 0 3 16 184 0 11 208 184 0 21 16 184 0 24 208 184 0 15 16 184 0 30 208 48 49 19 20 22 23 17 14 1 5 52 38 39 17 62 1 3 53 46 1 53 52 54 55 53 51 21 30 1 21 20 6 7 21 106 77 79 79 77 1 132 77 79 79 77 232 113 123 123 113 76 113 123 123 113 1 76 82 96 7 1 108 6 92 81 81 92 6 254 148 7 96 254 250 95 8 127 114 112 123 8 93 93 8 123 112 114 127 8 95 0 255 255 0 54 0 0 2 34 2 144 2 6 0 27 0 0 0 1 0 79 255 68 2 77 2 144 0 12 0 76 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 4 0 1 244 184 0 1 16 184 0 5 208 184 0 4 16 184 0 8 208 48 49 51 17 51 17 33 17 51 17 51 21 7 35 53 79 83 1 17 83 71 9 68 2 144 253 183 2 73 253 183 50 209 188 0 0 0 1 0 65 0 0 2 4 2 144 0 21 0 65 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 4 0 10 0 0 17 18 57 184 0 4 47 185 0 15 0 1 244 184 0 10 16 184 0 19 208 48 49 33 17 14 1 35 34 46 2 61 1 51 21 20 22 51 50 54 55 17 51 17 1 176 25 60 40 56 90 63 33 82 87 80 39 58 21 84 1 38 5 5 22 51 83 60 156 156 83 64 5 5 1 37 253 112 0 0 0 1 0 40 0 0 2 48 2 144 0 11 0 67 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 4 0 1 244 184 0 1 16 184 0 6 208 184 0 4 16 184 0 8 208 184 0 6 16 184 0 10 208 48 49 51 17 51 17 51 17 51 17 51 17 51 17 40 76 146 76 146 76 2 144 253 183 2 73 253 183 2 73 253 112 0 0 1 0 38 255 68 2 80 2 144 0 16 0 92 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 4 0 1 244 184 0 1 16 184 0 6 208 184 0 4 16 184 0 8 208 184 0 6 16 184 0 10 208 184 0 8 16 184 0 12 208 48 49 51 17 51 17 51 17 51 17 51 17 51 17 51 21 7 35 53 38 74 134 74 134 74 64 9 66 2 144 253 183 2 73 253 183 2 73 253 183 50 209 188 0 0 2 0 19 0 0 2 61 2 144 0 16 0 25 0 77 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 3 16 185 0 1 0 1 244 186 0 24 0 3 0 0 17 18 57 184 0 24 47 185 0 6 0 1 244 184 0 0 16 185 0 18 0 1 244 48 49 51 17 35 53 33 17 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 201 182 1 10 55 50 86 62 35 32 59 83 52 62 51 78 79 83 81 44 2 74 70 254 243 22 45 70 48 53 76 49 24 68 62 70 60 60 0 0 3 0 55 0 0 2 33 2 144 0 12 0 21 0 25 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 20 0 1 0 0 17 18 57 184 0 20 47 185 0 3 0 1 244 184 0 1 16 184 0 24 208 184 0 0 16 184 0 25 208 48 49 51 17 51 17 51 50 30 2 21 20 6 35 39 51 50 54 53 52 38 43 1 1 17 51 17 55 76 36 49 81 57 32 118 100 37 30 75 77 77 77 28 1 82 76 2 144 254 243 21 45 70 49 105 97 68 62 70 63 57 254 192 2 144 253 112 0 2 0 98 0 0 2 33 2 144 0 14 0 23 0 67 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 22 0 1 0 0 17 18 57 184 0 22 47 185 0 3 0 1 244 184 0 0 16 185 0 16 0 1 244 48 49 51 17 51 17 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 98 84 121 54 89 64 35 34 63 89 55 122 111 84 86 86 86 109 2 144 254 243 21 45 70 49 53 76 49 24 68 62 70 63 57 0 1 0 46 255 244 2 22 2 156 0 32 0 73 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 11 0 23 0 0 17 18 57 184 0 11 47 185 0 12 0 1 244 184 0 23 16 185 0 16 0 1 244 48 49 5 34 38 39 55 30 1 51 50 54 55 33 53 33 46 1 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 1 2 67 103 42 46 34 79 51 86 103 5 254 237 1 18 9 100 86 43 75 28 46 31 103 62 62 102 72 40 41 74 101 12 50 45 52 35 39 123 125 71 105 110 33 29 54 32 49 44 86 127 83 84 127 85 44 0 0 2 0 44 255 244 2 52 2 156 0 18 0 38 0 105 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 4 0 13 0 0 17 18 57 184 0 4 47 184 0 0 16 184 0 6 208 184 0 6 47 184 0 13 16 184 0 7 208 184 0 7 47 184 0 4 16 185 0 10 0 1 244 184 0 0 16 185 0 19 0 1 244 184 0 13 16 185 0 29 0 1 244 48 49 5 34 38 39 35 17 35 17 51 17 51 62 1 51 50 22 21 20 6 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 124 80 94 4 74 84 84 75 7 93 77 84 100 100 84 24 36 25 13 13 25 36 24 23 36 25 14 14 25 36 12 157 164 254 203 2 144 254 237 149 138 162 174 176 168 73 30 65 103 73 72 100 63 28 28 63 100 72 73 103 65 30 0 0 2 0 30 0 0 1 245 2 144 0 15 0 24 0 81 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 13 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 3 62 89 184 0 0 208 186 0 2 0 14 0 4 17 18 57 184 0 2 47 185 0 17 0 1 244 186 0 5 0 17 0 2 17 18 57 184 0 14 16 185 0 19 0 1 244 48 49 33 17 35 3 35 19 46 1 53 52 62 2 59 1 17 3 51 53 35 34 6 21 20 22 1 161 121 170 96 184 66 83 34 61 85 50 206 194 110 110 77 81 81 1 21 254 235 1 30 16 91 79 51 70 44 19 253 112 1 89 244 52 65 64 63 0 0 255 255 0 114 0 0 2 18 3 99 2 38 0 8 0 0 0 6 4 237 31 0 0 0 255 255 0 114 0 0 2 18 3 48 2 38 0 8 0 0 0 6 5 1 31 0 0 0 0 1 0 5 255 244 2 64 2 144 0 39 0 93 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 184 0 0 16 184 0 20 208 184 0 20 47 186 0 15 0 23 0 20 17 18 57 184 0 15 47 184 0 23 16 185 0 21 0 1 244 184 0 25 208 184 0 15 16 185 0 30 0 1 244 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 17 35 17 35 53 33 21 35 21 62 1 51 50 30 2 21 20 14 2 1 155 17 36 11 15 7 21 10 16 33 28 18 77 69 24 49 19 84 168 1 206 210 22 55 27 46 79 58 32 28 47 59 12 6 4 67 3 5 12 31 52 39 74 67 5 5 254 190 2 74 70 70 195 4 6 24 50 80 55 59 78 47 20 255 255 0 135 0 0 2 23 3 99 2 38 2 86 0 0 0 6 4 240 0 0 0 0 0 1 0 66 255 244 2 42 2 156 0 32 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 17 0 1 244 186 0 22 0 0 0 10 17 18 57 184 0 22 47 185 0 21 0 1 244 184 0 0 16 185 0 26 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 7 33 21 33 30 1 51 50 54 55 23 14 1 1 96 63 105 76 42 43 77 107 63 60 93 29 46 26 66 42 88 108 11 1 18 254 237 5 107 94 47 73 32 46 39 99 12 44 85 127 84 83 127 86 44 49 32 54 28 34 110 105 71 125 123 39 35 52 45 50 0 255 255 0 67 255 244 2 25 2 156 2 6 0 22 0 0 255 255 0 95 0 0 1 249 2 144 2 6 0 12 0 0 255 255 0 95 0 0 1 249 3 48 2 38 0 12 0 0 0 6 5 1 0 0 0 0 255 255 0 81 255 244 1 237 2 145 2 6 0 13 0 0 0 2 255 248 255 244 2 62 2 144 0 36 0 45 0 95 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 44 0 15 0 0 17 18 57 184 0 44 47 185 0 17 0 1 244 184 0 0 16 184 0 27 208 184 0 27 47 184 0 15 16 185 0 28 0 1 244 184 0 27 16 185 0 38 0 1 244 48 49 23 34 38 39 55 30 1 51 50 62 2 55 62 1 55 51 17 51 50 30 2 21 20 6 43 1 17 35 14 1 7 14 3 37 51 50 54 53 52 38 43 1 35 11 20 12 17 5 8 5 9 16 15 14 7 14 14 3 237 22 43 73 51 29 108 91 95 92 3 14 11 8 22 30 40 1 40 16 65 63 64 67 13 12 2 5 77 2 2 10 34 65 55 109 209 106 254 243 21 45 70 49 105 97 2 74 90 176 105 69 88 51 19 80 62 70 63 57 0 0 0 0 2 0 39 0 0 2 61 2 144 0 22 0 31 0 103 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 30 0 1 0 0 17 18 57 184 0 30 47 185 0 8 0 1 244 184 0 4 208 184 0 4 47 184 0 1 16 184 0 6 208 184 0 0 16 184 0 19 208 184 0 30 16 184 0 20 208 184 0 20 47 184 0 19 16 185 0 24 0 1 244 48 49 51 17 51 17 51 17 51 17 51 50 30 2 21 20 14 2 43 1 17 35 17 55 51 50 54 53 52 38 43 1 39 76 152 76 35 43 72 52 28 27 51 72 44 112 152 228 29 63 64 64 66 26 2 144 254 237 1 19 254 243 21 45 70 49 53 76 49 24 1 53 254 203 68 60 72 64 56 0 1 0 5 0 0 2 55 2 144 0 23 0 79 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 3 16 185 0 1 0 1 244 184 0 5 208 186 0 19 0 3 0 0 17 18 57 184 0 19 47 185 0 10 0 1 244 184 0 0 16 184 0 15 208 48 49 51 17 35 53 33 21 35 21 62 1 51 50 22 29 1 35 53 52 38 35 34 6 7 17 173 168 1 205 210 23 55 26 97 110 82 68 69 23 50 19 2 74 70 70 195 4 6 90 102 209 209 67 56 5 5 254 190 0 0 255 255 0 102 0 0 2 68 3 99 2 38 2 206 0 0 0 6 4 240 17 0 0 0 255 255 0 78 0 0 2 10 3 99 2 38 2 204 0 0 0 6 4 237 4 0 0 0 255 255 0 47 255 244 2 44 3 69 2 38 2 215 0 0 0 6 4 253 4 0 0 0 0 1 0 75 255 68 2 13 2 144 0 11 0 76 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 3 0 1 244 184 0 1 16 184 0 6 208 184 0 0 16 184 0 8 208 48 49 51 17 51 17 33 17 51 17 35 7 35 53 75 84 1 26 84 182 8 69 2 144 253 183 2 73 253 112 188 188 0 2 0 24 0 0 2 39 2 188 0 22 0 31 0 74 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 11 0 1 0 31 0 4 43 187 0 3 0 1 0 2 0 4 43 184 0 3 16 184 0 6 220 184 0 3 16 184 0 8 208 184 0 2 16 184 0 9 208 184 0 0 16 185 0 24 0 1 244 48 49 51 17 35 53 51 53 51 21 51 21 35 21 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 160 136 136 83 222 222 66 54 89 64 35 33 61 87 55 72 62 83 81 83 88 55 1 251 68 125 125 68 136 19 41 66 47 53 75 48 22 66 59 69 62 53 0 0 0 3 0 48 255 244 2 40 2 156 0 19 0 26 0 33 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 20 0 1 244 186 0 30 0 0 0 10 17 18 57 184 0 30 47 185 0 23 0 1 244 184 0 0 16 185 0 27 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 3 34 6 7 33 46 1 3 50 54 55 33 30 1 1 44 56 93 66 37 37 66 93 56 56 93 66 37 37 66 93 56 70 89 8 1 78 8 89 70 74 90 5 254 174 5 90 12 46 87 128 82 82 125 86 44 44 86 126 81 82 128 87 46 2 98 113 106 106 113 253 228 130 123 123 130 0 0 1 0 38 0 0 2 87 2 156 0 27 0 69 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 16 16 184 0 1 208 184 0 1 47 186 0 6 0 0 0 16 17 18 57 184 0 16 16 185 0 23 0 1 244 48 49 51 3 51 19 30 1 23 51 62 3 63 1 62 1 51 50 22 23 7 46 1 35 34 6 7 3 248 210 89 106 16 28 19 4 8 13 14 14 8 64 20 57 53 15 21 12 17 5 13 8 22 25 11 148 2 144 254 158 59 100 58 29 53 52 54 29 227 73 66 4 5 77 2 4 37 37 253 254 0 0 0 0 1 0 135 0 0 2 22 3 60 0 7 0 55 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 1 16 184 0 4 220 184 0 1 16 185 0 5 0 1 244 48 49 51 17 33 55 51 7 33 17 135 1 57 16 70 9 254 205 2 144 172 242 253 182 0 0 1 0 60 0 0 2 14 2 144 0 13 0 79 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 11 0 5 0 0 17 18 57 184 0 11 47 184 0 2 208 184 0 11 16 185 0 10 0 1 244 184 0 4 208 184 0 5 16 185 0 7 0 1 244 48 49 51 17 35 53 55 17 33 21 33 21 51 21 35 17 140 80 80 1 130 254 210 168 168 1 44 58 4 1 38 70 224 62 254 212 0 0 1 0 1 255 68 2 103 2 156 0 58 0 166 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 3 62 89 184 0 5 208 184 0 1 208 186 0 7 0 24 0 10 17 18 57 184 0 7 47 184 0 3 208 184 0 7 16 185 0 31 0 1 244 186 0 11 0 31 0 7 17 18 57 184 0 24 16 185 0 17 0 1 244 184 0 24 16 184 0 32 208 184 0 32 47 184 0 31 16 184 0 35 208 184 0 24 16 184 0 41 208 184 0 17 16 184 0 48 208 186 0 54 0 35 0 3 17 18 57 184 0 1 16 185 0 56 0 1 244 48 49 5 53 35 3 35 17 35 17 35 3 35 19 39 46 3 35 34 6 7 39 62 1 51 50 30 2 31 1 51 17 51 17 51 55 62 3 51 50 22 23 7 46 1 35 34 14 2 15 1 19 51 21 7 2 35 39 110 60 76 60 110 90 139 43 8 16 15 16 8 5 11 5 13 7 24 9 19 34 30 27 11 47 53 76 53 47 11 25 29 33 19 9 28 7 13 5 11 5 8 16 15 16 8 43 111 45 9 188 188 1 53 254 203 1 53 254 203 1 95 158 26 31 16 5 2 2 80 2 3 9 25 47 39 168 1 20 254 236 168 39 47 25 9 3 2 80 2 2 5 16 31 26 158 254 232 50 209 0 0 0 0 1 0 62 255 68 2 28 2 155 0 50 0 108 0 184 0 0 69 88 184 0 32 47 27 185 0 32 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 3 62 89 185 0 8 0 1 244 186 0 17 0 32 0 1 17 18 57 184 0 17 47 185 0 18 0 1 244 184 0 32 16 185 0 25 0 1 244 186 0 41 0 18 0 17 17 18 57 184 0 1 16 184 0 49 208 48 49 5 53 46 1 39 55 30 1 51 50 62 2 53 52 38 43 1 53 51 50 54 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 15 1 1 8 60 98 44 47 44 89 58 33 57 43 25 94 86 74 54 88 78 74 57 47 79 31 45 36 107 61 47 78 55 31 50 48 57 75 29 53 71 42 8 188 177 5 45 45 57 44 37 17 33 48 31 63 60 64 57 56 52 53 34 29 56 35 45 23 43 63 39 52 79 17 4 11 83 68 42 68 49 31 5 178 0 1 0 102 255 68 2 76 2 156 0 33 0 124 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 3 62 89 184 0 1 208 186 0 4 0 16 0 6 17 18 57 184 0 4 47 184 0 16 16 184 0 7 208 184 0 7 47 184 0 4 16 185 0 10 0 1 244 184 0 16 16 185 0 23 0 1 244 186 0 29 0 10 0 4 17 18 57 184 0 1 16 185 0 31 0 1 244 48 49 5 53 35 3 35 17 35 17 51 17 51 55 62 3 51 50 22 23 7 46 1 35 34 14 2 15 1 19 51 21 7 2 1 25 196 107 83 83 107 88 19 35 34 37 23 9 19 8 15 6 12 5 11 19 19 23 14 81 176 53 9 188 188 1 53 254 203 2 144 254 236 166 37 48 27 10 3 3 78 2 2 6 17 33 27 153 254 231 50 209 0 1 0 19 0 0 2 88 2 156 0 28 0 103 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 12 16 184 0 4 208 184 0 4 47 185 0 2 0 1 244 186 0 27 0 12 0 0 17 18 57 184 0 27 47 185 0 6 0 1 244 184 0 12 16 185 0 17 0 1 244 186 0 23 0 6 0 26 17 18 57 184 0 0 16 184 0 25 208 48 49 51 17 35 53 33 17 51 55 62 3 51 50 23 7 38 35 34 14 2 15 1 19 35 3 35 17 205 186 1 6 66 75 18 30 31 33 20 19 14 14 9 11 8 15 17 21 13 73 194 81 174 64 2 74 70 254 236 166 39 47 27 9 6 77 3 5 18 33 27 154 254 161 1 53 254 203 0 0 0 0 1 0 79 255 68 2 77 2 144 0 16 0 96 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 14 0 1 0 0 17 18 57 184 0 14 47 185 0 3 0 1 244 184 0 1 16 184 0 6 208 184 0 0 16 184 0 12 208 185 0 8 0 1 244 48 49 51 17 51 17 33 17 51 17 51 21 7 35 53 35 17 33 17 79 84 1 16 83 71 9 64 81 254 240 2 144 254 237 1 19 253 183 50 209 188 1 53 254 203 0 0 0 0 1 0 65 255 68 2 42 2 156 0 36 0 82 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 3 62 89 184 0 11 16 185 0 18 0 1 244 184 0 1 16 185 0 28 0 1 244 184 0 1 16 184 0 35 208 48 49 5 53 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 23 14 1 15 1 1 57 54 91 66 37 44 78 108 64 59 91 29 47 26 64 42 47 77 54 30 30 54 77 47 45 71 32 47 32 78 50 8 188 178 7 52 86 119 74 79 126 88 47 48 32 53 27 33 37 69 98 61 62 99 70 38 38 35 51 38 46 8 179 255 255 0 38 0 0 2 50 2 144 2 6 0 28 0 0 0 1 0 38 0 0 2 50 2 144 0 22 0 87 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 13 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 3 62 89 184 0 4 16 184 0 15 208 186 0 18 0 21 0 15 17 18 57 184 0 18 47 184 0 0 208 184 0 18 16 185 0 17 0 1 244 184 0 2 208 186 0 9 0 4 0 21 17 18 57 48 49 55 53 55 51 3 51 23 30 1 23 51 62 1 63 1 51 3 51 21 35 21 35 53 106 89 38 195 88 99 19 36 20 4 20 38 19 95 86 195 127 152 84 220 58 4 1 118 195 38 75 40 40 76 38 194 254 138 62 220 220 0 0 0 0 1 0 54 255 68 2 52 2 144 0 30 0 116 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 3 62 89 184 0 1 208 186 0 7 0 12 0 14 17 18 57 186 0 19 0 14 0 12 17 18 57 186 0 13 0 19 0 6 17 18 57 184 0 14 16 184 0 25 208 186 0 26 0 6 0 19 17 18 57 184 0 1 16 185 0 28 0 1 244 48 49 5 53 35 39 46 1 39 35 14 1 15 1 35 19 3 51 23 30 1 23 51 62 1 63 1 51 3 19 51 21 7 1 235 37 99 14 27 17 4 14 26 13 98 88 196 183 92 92 13 24 16 4 14 21 12 90 88 183 154 60 8 188 188 177 24 51 30 30 51 24 177 1 83 1 61 168 23 43 29 29 43 23 168 254 191 254 248 50 209 0 0 1 0 65 255 68 2 70 2 144 0 26 0 92 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 25 47 27 185 0 25 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 4 0 10 0 0 17 18 57 184 0 4 47 185 0 15 0 1 244 184 0 10 16 184 0 20 208 184 0 0 16 185 0 22 0 1 244 48 49 33 17 14 1 35 34 46 2 61 1 51 21 20 22 51 50 54 55 17 51 17 51 21 7 35 53 1 171 24 59 40 56 89 61 33 82 85 80 38 56 21 84 71 9 70 1 38 5 5 22 51 83 60 156 156 83 64 5 5 1 37 253 183 50 209 188 0 1 0 91 0 0 2 20 2 144 0 23 0 65 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 19 0 1 0 0 17 18 57 184 0 19 47 185 0 6 0 1 244 184 0 0 16 184 0 12 208 48 49 51 17 51 17 62 1 51 50 30 2 29 1 35 53 52 46 2 35 34 6 7 17 91 83 24 57 38 56 89 61 33 82 21 42 61 40 37 55 20 2 144 254 254 4 6 22 51 82 59 194 194 41 56 34 14 6 4 254 183 0 0 255 255 0 95 0 0 1 249 2 144 2 6 0 12 0 0 255 255 0 1 0 0 2 87 3 69 2 38 2 202 0 0 0 6 4 253 0 0 0 0 255 255 0 32 0 0 2 56 3 69 2 38 0 4 0 0 0 6 4 253 0 0 0 0 255 255 255 255 0 0 2 79 2 144 2 6 0 79 0 0 255 255 0 114 0 0 2 18 3 69 2 38 0 8 0 0 0 6 4 253 31 0 0 0 255 255 0 59 255 244 2 38 2 156 2 6 1 0 0 0 255 255 0 78 0 0 2 10 3 24 2 38 2 204 0 0 0 6 4 247 4 0 0 0 255 255 0 48 255 244 2 40 3 48 2 38 0 18 0 0 0 6 5 1 0 0 0 0 255 255 0 48 255 244 2 40 2 156 2 6 2 245 0 0 255 255 0 47 255 244 2 44 3 24 2 38 2 215 0 0 0 6 4 247 4 0 0 0 255 255 0 47 255 244 2 44 3 108 2 38 2 215 0 0 0 6 5 9 4 0 0 0 255 255 0 81 255 244 2 3 1 242 2 6 0 30 0 0 0 2 0 75 255 244 2 19 2 218 0 36 0 51 0 101 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 15 16 185 0 16 0 1 244 186 0 27 0 15 0 0 17 18 57 184 0 27 47 186 0 24 0 27 0 0 17 18 57 184 0 0 16 185 0 37 0 1 244 184 0 27 16 185 0 43 0 1 244 184 0 24 16 185 0 46 0 1 244 48 49 5 34 46 2 53 52 62 2 55 62 3 55 23 14 1 7 14 3 7 62 1 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 7 21 20 30 2 1 55 56 88 60 32 44 81 115 71 22 30 24 19 12 17 20 54 33 59 87 59 33 6 33 89 48 45 74 53 30 33 59 81 48 65 71 71 66 38 79 37 19 39 58 12 42 80 114 71 121 149 87 40 11 3 5 6 7 6 75 13 13 5 9 21 48 86 73 40 41 31 59 84 53 58 94 66 35 68 102 83 75 89 37 51 38 50 83 58 32 0 0 3 0 104 0 0 2 27 1 230 0 21 0 30 0 38 0 87 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 37 0 1 0 0 17 18 57 184 0 37 47 185 0 22 0 1 244 186 0 10 0 22 0 37 17 18 57 184 0 1 16 185 0 29 0 1 244 184 0 0 16 185 0 32 0 1 244 48 49 51 17 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 35 3 51 50 54 53 52 38 43 1 17 51 50 54 53 52 43 1 104 225 42 70 49 28 46 39 21 39 29 17 30 54 74 44 152 130 66 57 55 62 136 143 66 63 134 138 1 230 14 29 47 33 41 51 12 3 5 18 29 39 26 36 52 35 16 1 28 37 34 34 31 254 158 37 41 76 0 0 0 1 0 146 0 0 2 11 1 230 0 5 0 47 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 1 16 185 0 3 0 1 244 48 49 51 17 33 21 33 17 146 1 121 254 217 1 230 67 254 93 0 0 0 0 2 0 42 255 84 2 45 1 230 0 6 0 25 0 90 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 7 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 184 0 0 69 88 184 0 24 47 27 185 0 24 0 3 62 89 185 0 9 0 1 244 184 0 4 208 184 0 16 16 185 0 5 0 1 244 184 0 4 16 184 0 19 208 184 0 7 16 184 0 21 208 48 49 55 14 1 7 51 17 35 3 39 53 51 62 3 63 1 33 17 51 21 7 35 53 33 21 206 8 27 18 251 179 174 9 24 10 19 16 16 7 26 1 70 71 9 71 254 156 255 72 90 26 1 96 253 177 187 52 6 21 44 74 59 215 254 93 52 187 172 172 0 0 255 255 0 68 255 244 2 26 1 242 2 6 0 34 0 0 0 1 0 6 0 0 2 82 1 242 0 44 0 139 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 39 0 12 0 0 17 18 57 184 0 39 47 185 0 20 0 1 244 184 0 16 208 184 0 39 16 184 0 43 208 186 0 1 0 16 0 43 17 18 57 184 0 12 16 185 0 5 0 1 244 184 0 12 16 184 0 18 208 184 0 18 47 184 0 12 16 184 0 25 208 184 0 5 16 184 0 31 208 186 0 35 0 20 0 39 17 18 57 184 0 0 16 184 0 41 208 184 0 36 208 48 49 51 19 39 46 1 35 42 1 7 39 62 1 51 50 22 31 1 51 53 51 21 51 55 62 1 51 50 23 7 38 34 35 34 6 15 1 19 35 39 35 21 35 53 35 7 6 132 34 15 32 16 5 7 5 12 5 16 9 39 59 23 42 55 80 55 42 23 59 39 18 12 12 5 7 5 17 31 15 34 132 86 105 63 80 63 105 1 6 93 40 23 2 77 3 2 42 60 112 202 202 112 60 42 5 77 2 23 40 93 254 250 220 220 220 220 0 1 0 62 255 244 2 1 1 242 0 44 0 83 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 14 0 28 0 0 17 18 57 184 0 14 47 185 0 15 0 1 244 184 0 28 16 185 0 21 0 1 244 186 0 37 0 15 0 14 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 38 43 1 53 51 50 54 53 52 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 1 24 60 106 52 36 42 88 45 76 82 77 73 84 72 70 69 134 53 75 38 34 42 99 64 46 77 56 31 43 44 50 61 34 61 86 12 31 42 54 35 26 45 42 42 37 64 39 36 74 27 28 55 31 34 16 32 50 33 36 55 17 4 13 55 53 35 54 38 19 0 0 0 1 0 100 0 0 1 244 1 230 0 23 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 6 0 1 0 0 17 18 57 184 0 1 16 184 0 12 208 184 0 0 16 184 0 13 208 186 0 18 0 0 0 1 17 18 57 48 49 51 17 51 21 20 6 7 51 62 1 55 19 51 17 35 53 52 54 55 35 14 1 7 3 100 80 6 2 4 14 36 14 184 76 80 6 2 4 14 36 14 184 1 230 202 39 93 47 23 58 23 1 21 254 26 202 39 93 48 23 59 22 254 234 0 255 255 0 100 0 0 1 244 2 213 2 38 3 23 0 0 0 6 4 251 11 0 0 0 0 1 0 110 0 0 2 48 1 242 0 27 0 97 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 184 0 1 208 184 0 1 47 186 0 26 0 10 0 0 17 18 57 184 0 26 47 185 0 4 0 1 244 184 0 10 16 185 0 16 0 1 244 186 0 22 0 4 0 25 17 18 57 184 0 0 16 184 0 23 208 48 49 51 17 51 21 51 55 62 3 51 50 23 7 46 1 35 34 14 2 15 1 23 35 39 35 21 110 82 128 59 16 30 30 33 20 20 12 14 5 9 6 9 16 16 18 11 53 177 91 149 128 1 230 200 108 31 40 24 9 6 77 2 1 5 15 25 21 97 255 219 219 0 0 0 0 1 0 29 255 244 1 240 1 230 0 22 0 65 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 184 0 0 16 184 0 15 208 184 0 15 47 184 0 13 16 185 0 17 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 55 62 1 55 33 17 35 17 35 14 1 7 6 74 14 20 11 16 5 10 7 26 32 7 10 18 9 1 71 83 179 8 16 8 21 12 4 4 76 2 2 49 54 79 157 79 254 26 1 163 67 135 67 162 0 0 1 0 64 0 0 2 24 1 230 0 37 0 93 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 6 0 1 0 0 17 18 57 184 0 1 16 184 0 12 208 184 0 0 16 184 0 13 208 186 0 21 0 0 0 1 17 18 57 186 0 26 0 0 0 1 17 18 57 186 0 31 0 1 0 0 17 18 57 48 49 51 17 51 23 30 1 23 51 62 1 63 1 51 17 35 53 52 62 2 55 35 14 1 15 1 35 39 46 1 39 35 30 3 29 1 64 100 92 11 22 10 4 11 22 10 90 100 78 2 3 3 2 4 11 22 11 88 62 92 11 20 11 4 1 4 3 2 1 230 228 30 58 30 30 58 30 228 254 26 218 16 43 45 45 19 29 60 27 224 224 27 60 29 19 45 45 43 16 218 0 0 0 1 0 93 0 0 1 251 1 230 0 11 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 9 0 1 0 0 17 18 57 184 0 9 47 185 0 3 0 1 244 184 0 1 16 184 0 6 208 184 0 0 16 184 0 7 208 48 49 51 17 51 21 51 53 51 17 35 53 35 21 93 82 250 82 82 250 1 230 197 197 254 26 216 216 0 0 0 255 255 0 60 255 244 2 28 1 242 2 6 0 44 0 0 0 1 0 93 0 0 1 251 1 230 0 7 0 51 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 3 208 184 0 1 16 185 0 5 0 1 244 48 49 51 17 33 17 35 17 35 17 93 1 158 82 250 1 230 254 26 1 163 254 93 0 0 255 255 0 93 255 51 2 28 1 242 2 6 0 45 0 0 255 255 0 80 255 244 2 27 1 242 2 6 0 32 0 0 0 1 0 66 0 0 2 22 1 230 0 7 0 51 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 3 16 185 0 2 0 1 244 184 0 5 208 48 49 33 17 35 53 33 21 35 17 1 3 193 1 212 193 1 163 67 67 254 93 0 0 0 255 255 0 49 255 47 2 39 1 230 2 6 0 54 0 0 0 3 0 32 255 51 2 56 2 200 0 39 0 50 0 64 0 203 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 7 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 15 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 2 0 0 0 18 17 18 57 186 0 16 0 18 0 0 17 18 57 186 0 21 0 18 0 0 17 18 57 184 0 13 16 184 0 24 208 184 0 5 16 184 0 34 208 186 0 37 0 0 0 18 17 18 57 184 0 5 16 185 0 40 0 1 244 184 0 2 16 185 0 42 0 1 244 184 0 16 16 185 0 43 0 1 244 184 0 13 16 185 0 45 0 1 244 184 0 40 16 184 0 51 208 184 0 45 16 184 0 59 208 184 0 21 16 185 0 61 0 1 244 184 0 37 16 185 0 62 0 1 244 48 49 5 53 55 14 1 35 34 38 53 52 62 2 51 50 22 23 39 53 51 21 7 62 1 51 50 30 2 21 20 14 2 35 34 38 39 23 21 3 50 55 17 38 35 34 6 21 20 22 51 50 54 53 52 46 2 35 34 7 17 30 1 1 4 2 17 38 25 68 82 25 41 54 30 25 38 17 2 80 2 18 46 24 34 53 36 19 25 41 55 30 20 41 18 2 139 32 29 30 35 38 45 42 245 41 44 8 19 32 23 33 33 17 33 205 155 74 14 22 132 122 59 95 66 36 21 15 74 176 176 76 17 21 35 65 91 57 62 97 68 35 21 15 74 155 1 6 35 1 48 33 103 84 87 98 102 91 40 66 47 26 34 254 207 18 15 0 0 255 255 0 64 0 0 2 23 1 230 2 6 0 53 0 0 0 1 0 94 255 84 2 56 1 230 0 12 0 76 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 4 0 1 244 184 0 1 16 184 0 6 208 184 0 4 16 184 0 8 208 48 49 51 17 51 17 51 17 51 17 51 21 7 35 53 94 82 239 82 71 8 71 1 230 254 93 1 163 254 93 52 187 172 0 0 0 0 1 0 88 0 0 1 234 1 230 0 23 0 65 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 6 0 12 0 0 17 18 57 184 0 6 47 185 0 17 0 1 244 184 0 12 16 184 0 22 208 48 49 33 53 14 3 35 34 46 2 61 1 51 21 20 22 51 50 54 55 53 51 17 1 152 15 25 24 28 19 50 78 53 28 82 69 75 26 42 26 82 196 3 5 3 1 20 43 68 49 122 122 61 52 6 6 223 254 26 0 1 0 58 0 0 2 30 1 230 0 11 0 67 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 4 0 1 244 184 0 1 16 184 0 6 208 184 0 4 16 184 0 8 208 184 0 6 16 184 0 10 208 48 49 51 17 51 17 51 17 51 17 51 17 51 17 58 82 122 76 122 82 1 230 254 93 1 163 254 93 1 163 254 26 0 0 1 0 58 255 84 2 82 1 230 0 16 0 92 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 4 0 1 244 184 0 1 16 184 0 6 208 184 0 4 16 184 0 8 208 184 0 6 16 184 0 10 208 184 0 8 16 184 0 12 208 48 49 51 17 51 17 51 17 51 17 51 17 51 17 51 21 7 35 53 58 82 118 76 118 82 60 8 65 1 230 254 93 1 163 254 93 1 163 254 93 52 187 172 0 0 2 0 35 0 0 2 39 1 230 0 12 0 20 0 77 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 3 16 185 0 1 0 1 244 186 0 19 0 3 0 0 17 18 57 184 0 19 47 185 0 5 0 1 244 184 0 0 16 185 0 14 0 1 244 48 49 51 17 35 53 51 21 51 50 22 21 20 6 35 39 51 50 53 52 38 43 1 201 166 248 74 87 107 107 87 74 66 121 59 62 66 1 163 67 179 73 79 81 74 66 89 46 42 0 3 0 70 0 0 2 18 1 230 0 10 0 18 0 22 0 83 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 17 0 1 0 0 17 18 57 184 0 17 47 185 0 3 0 1 244 184 0 0 16 185 0 12 0 1 244 184 0 1 16 184 0 21 208 184 0 0 16 184 0 22 208 48 49 51 17 51 21 51 50 22 21 20 6 35 39 51 50 53 52 38 43 1 5 17 51 17 70 75 68 81 98 98 81 68 60 114 56 58 60 1 54 75 1 230 179 72 80 81 74 66 89 46 42 243 1 230 254 26 0 2 0 125 0 0 2 6 1 230 0 14 0 22 0 67 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 21 0 1 0 0 17 18 57 184 0 21 47 185 0 3 0 1 244 184 0 0 16 185 0 16 0 1 244 48 49 51 17 51 21 51 50 30 2 21 20 14 2 35 39 51 50 53 52 38 43 1 125 83 113 44 73 52 28 28 52 73 44 113 104 125 61 64 104 1 230 179 18 37 57 40 41 58 38 18 66 89 46 42 0 1 0 61 255 244 2 8 1 242 0 32 0 73 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 11 0 23 0 0 17 18 57 184 0 11 47 185 0 13 0 1 244 184 0 23 16 185 0 16 0 1 244 48 49 5 34 38 39 55 30 1 51 50 54 55 35 53 51 46 1 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 1 0 57 100 38 35 28 78 46 84 102 6 251 249 11 99 72 48 70 28 39 32 92 66 53 94 71 41 40 70 97 12 37 35 51 26 31 82 84 64 75 74 30 24 50 29 40 31 63 97 65 64 95 63 32 0 0 0 0 2 0 44 255 244 2 52 1 242 0 22 0 34 0 105 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 4 0 13 0 0 17 18 57 184 0 4 47 184 0 0 16 184 0 6 208 184 0 6 47 184 0 13 16 184 0 7 208 184 0 7 47 184 0 4 16 185 0 10 0 1 244 184 0 0 16 185 0 23 0 1 244 184 0 13 16 185 0 29 0 1 244 48 49 5 34 38 39 35 21 35 17 51 21 51 62 1 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 1 128 72 99 6 81 82 82 82 9 97 70 39 66 48 27 27 48 66 41 45 53 53 45 47 55 55 12 112 113 213 1 230 200 107 105 31 64 96 65 64 96 63 31 68 91 95 96 92 92 96 95 91 0 0 2 0 55 0 0 1 245 1 230 0 15 0 24 0 85 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 7 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 3 62 89 186 0 1 0 14 0 4 17 18 57 184 0 1 47 185 0 17 0 1 244 186 0 5 0 17 0 1 17 18 57 184 0 4 16 184 0 15 208 184 0 14 16 185 0 18 0 1 244 48 49 33 53 35 7 35 55 46 1 53 52 62 2 59 1 17 39 51 53 35 34 6 21 20 22 1 162 132 138 93 145 51 72 28 49 68 39 240 226 143 143 55 61 61 190 190 196 12 71 63 40 55 34 15 254 26 254 166 36 44 43 43 0 0 255 255 0 68 255 244 2 26 3 9 2 38 0 34 0 0 0 6 4 236 16 0 0 0 255 255 0 68 255 244 2 26 2 188 2 38 0 34 0 0 0 6 5 0 16 0 0 0 0 1 0 20 255 39 2 26 2 200 0 43 0 104 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 20 47 27 185 0 20 0 3 62 89 184 0 0 16 185 0 7 0 1 244 184 0 25 16 184 0 27 220 185 0 30 0 1 244 184 0 36 220 185 0 15 0 1 244 184 0 30 16 184 0 21 208 184 0 27 16 184 0 24 208 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 17 35 17 35 53 55 53 51 21 51 21 35 21 7 51 62 1 51 50 22 21 20 14 2 1 78 19 31 11 16 8 21 11 26 46 33 19 68 67 38 63 42 82 73 73 82 213 213 5 3 36 82 53 94 100 28 53 76 217 8 5 62 3 5 28 70 121 93 132 113 43 45 254 193 2 52 57 5 86 86 62 66 114 40 54 153 154 113 149 89 37 0 255 255 0 146 0 0 2 11 3 9 2 38 3 18 0 0 0 6 4 239 49 0 0 0 0 1 0 80 255 244 2 27 1 242 0 32 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 17 0 1 244 186 0 22 0 10 0 0 17 18 57 184 0 22 47 185 0 20 0 1 244 184 0 0 16 185 0 26 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 7 33 21 33 30 1 51 50 54 55 23 14 1 1 90 57 98 71 40 43 74 99 55 60 86 32 39 29 68 42 75 102 12 1 7 254 247 6 102 85 46 77 29 34 40 99 12 32 63 95 64 64 97 63 32 38 29 52 25 29 75 74 64 83 83 33 25 52 35 37 0 255 255 0 71 255 244 2 14 1 242 2 6 0 48 0 0 255 255 0 90 0 0 1 158 2 204 2 38 1 87 0 0 0 6 4 254 48 0 0 0 255 255 0 90 0 0 1 244 2 188 2 38 1 87 0 0 0 6 5 0 48 0 0 0 255 255 0 55 255 39 1 158 2 204 2 38 1 209 0 0 0 6 4 254 48 0 0 0 0 2 255 249 255 244 2 44 1 230 0 30 0 39 0 95 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 38 0 13 0 0 17 18 57 184 0 38 47 185 0 15 0 1 244 184 0 0 16 184 0 22 208 184 0 22 47 184 0 13 16 185 0 24 0 1 244 184 0 22 16 185 0 31 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 55 62 1 55 51 21 51 50 22 21 20 6 43 1 17 35 14 1 7 14 1 37 51 50 54 53 52 38 43 1 37 14 19 11 15 5 9 6 20 32 8 11 11 4 246 15 81 100 100 81 95 96 4 10 10 11 66 1 21 6 61 55 55 61 6 12 4 4 76 2 2 47 56 78 154 83 179 73 79 81 74 1 163 67 142 72 77 73 78 43 46 46 42 0 0 0 2 0 58 0 0 2 40 1 230 0 18 0 27 0 95 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 26 0 1 0 0 17 18 57 184 0 26 47 185 0 7 0 1 244 184 0 4 208 184 0 1 16 184 0 6 208 184 0 0 16 184 0 14 208 184 0 26 16 184 0 16 208 184 0 14 16 185 0 19 0 1 244 48 49 51 17 51 21 51 53 51 21 51 50 22 21 20 6 43 1 53 35 21 55 51 50 54 53 52 38 43 1 58 80 128 80 27 83 96 96 83 107 128 208 18 59 55 55 59 18 1 230 197 197 179 72 80 81 74 216 216 66 42 47 47 41 0 0 0 255 255 0 20 0 0 2 11 2 200 2 6 1 75 0 0 255 255 0 110 0 0 2 48 3 9 2 38 3 25 0 0 0 6 4 239 20 0 0 0 255 255 0 100 0 0 1 244 3 9 2 38 3 23 0 0 0 6 4 236 11 0 0 0 255 255 0 49 255 47 2 39 2 213 2 38 0 54 0 0 0 6 4 251 4 0 0 0 0 1 0 103 255 84 1 241 1 230 0 11 0 68 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 4 0 1 244 184 0 1 16 184 0 6 208 48 49 51 17 51 17 51 17 51 17 35 7 35 39 103 82 230 82 154 9 70 3 1 230 254 93 1 163 254 26 172 172 0 2 0 41 0 0 2 33 2 110 0 22 0 30 0 101 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 3 16 185 0 2 0 1 244 184 0 3 16 184 0 6 220 184 0 3 16 184 0 8 208 184 0 2 16 184 0 9 208 186 0 29 0 3 0 0 17 18 57 184 0 29 47 185 0 11 0 1 244 184 0 0 16 185 0 24 0 1 244 48 49 51 17 35 53 51 53 51 21 51 21 35 21 51 50 30 2 21 20 14 2 35 39 51 50 53 52 38 43 1 194 153 153 82 183 183 76 43 71 51 28 28 51 71 43 76 67 122 60 62 67 1 183 67 116 116 67 132 18 37 57 40 41 58 38 18 66 89 46 42 0 0 255 255 0 60 255 244 2 28 1 242 2 6 1 253 0 0 0 1 0 70 0 0 2 48 1 242 0 26 0 69 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 16 16 184 0 1 208 184 0 1 47 186 0 6 0 16 0 0 17 18 57 184 0 16 16 185 0 22 0 1 244 48 49 51 3 51 19 30 1 23 51 62 1 63 1 62 3 51 50 22 23 7 38 35 34 6 7 3 249 179 84 97 11 24 11 4 9 21 11 48 10 22 29 36 25 15 21 12 17 9 15 21 24 12 112 1 230 254 236 35 73 35 35 72 36 148 36 53 34 17 4 5 74 6 36 37 254 164 0 0 0 1 0 162 0 0 1 247 2 146 0 7 0 55 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 1 16 184 0 4 220 184 0 1 16 185 0 5 0 1 244 48 49 51 17 33 55 51 7 35 17 162 1 3 16 66 8 251 1 230 172 239 254 93 0 0 0 1 0 72 0 0 2 11 1 230 0 13 0 79 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 10 0 5 0 0 17 18 57 184 0 10 47 185 0 11 0 1 244 184 0 1 208 184 0 10 16 184 0 4 208 184 0 5 16 185 0 7 0 1 244 48 49 51 53 35 53 55 53 33 21 33 21 51 21 35 21 146 74 74 1 121 254 217 172 172 206 56 6 218 67 151 62 206 0 1 0 6 255 84 2 95 1 242 0 49 0 166 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 3 62 89 184 0 5 208 184 0 1 208 186 0 7 0 22 0 10 17 18 57 184 0 7 47 184 0 3 208 184 0 7 16 185 0 27 0 1 244 186 0 11 0 27 0 7 17 18 57 184 0 22 16 185 0 15 0 1 244 184 0 22 16 184 0 28 208 184 0 28 47 184 0 27 16 184 0 31 208 184 0 22 16 184 0 35 208 184 0 15 16 184 0 41 208 186 0 45 0 31 0 3 17 18 57 184 0 1 16 185 0 47 0 1 244 48 49 5 53 35 39 35 21 35 53 35 7 35 19 39 46 1 35 42 1 7 39 62 1 51 50 22 31 1 51 53 51 21 51 55 62 1 51 50 23 7 38 34 35 34 6 15 1 23 51 21 7 2 29 33 105 63 80 63 105 86 132 34 15 32 16 5 7 5 12 5 16 9 39 59 23 42 55 80 55 42 23 59 39 18 12 12 5 7 5 17 31 15 34 98 47 8 172 172 220 220 220 220 1 6 93 40 23 2 77 3 2 42 60 112 202 202 112 60 42 5 77 2 23 40 93 195 52 187 0 0 1 0 62 255 84 2 1 1 242 0 45 0 108 0 184 0 0 69 88 184 0 29 47 27 185 0 29 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 3 62 89 185 0 8 0 1 244 186 0 15 0 29 0 1 17 18 57 184 0 15 47 185 0 17 0 1 244 184 0 29 16 185 0 22 0 1 244 186 0 38 0 17 0 15 17 18 57 184 0 1 16 184 0 44 208 48 49 23 39 46 1 39 55 30 1 51 50 54 53 52 38 43 1 53 51 50 54 53 52 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 1 21 20 6 15 1 250 4 49 90 45 36 42 88 45 76 82 77 73 84 72 70 69 134 53 75 38 34 42 99 64 46 77 56 31 43 44 50 61 100 85 9 172 161 4 32 36 54 35 26 45 42 42 37 64 39 36 74 27 28 55 31 34 16 32 50 33 36 55 17 4 13 55 53 62 74 8 162 0 0 1 0 110 255 84 2 61 1 242 0 32 0 120 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 3 62 89 184 0 1 208 186 0 4 0 16 0 6 17 18 57 184 0 16 16 184 0 7 208 184 0 7 47 184 0 4 16 185 0 10 0 1 244 184 0 16 16 185 0 22 0 1 244 186 0 28 0 4 0 10 17 18 57 184 0 1 16 185 0 30 0 1 244 48 49 5 53 35 39 35 21 35 17 51 21 51 55 62 3 51 50 23 7 46 1 35 34 14 2 15 1 23 51 21 7 1 246 33 149 128 82 82 128 59 16 30 30 33 20 20 12 14 5 9 6 9 16 16 18 11 53 130 60 8 172 172 219 219 1 230 200 108 31 40 24 9 6 77 2 1 5 15 25 21 97 188 52 187 0 0 0 0 1 0 33 0 0 2 70 1 242 0 27 0 103 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 12 16 184 0 4 208 184 0 4 47 185 0 2 0 1 244 186 0 26 0 12 0 0 17 18 57 184 0 26 47 185 0 6 0 1 244 184 0 12 16 185 0 18 0 1 244 186 0 22 0 26 0 6 17 18 57 184 0 0 16 184 0 23 208 48 49 51 17 35 53 51 21 51 55 62 3 51 50 23 7 38 34 35 34 6 15 1 23 35 39 35 21 202 169 244 95 42 12 27 30 33 18 16 13 15 5 6 5 17 29 17 39 152 79 131 95 1 163 67 200 108 32 41 23 8 5 77 2 23 43 101 251 219 219 0 0 0 0 1 0 93 255 84 2 56 1 230 0 16 0 96 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 7 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 14 0 1 0 0 17 18 57 184 0 14 47 185 0 3 0 1 244 184 0 1 16 184 0 6 208 184 0 0 16 184 0 12 208 185 0 8 0 1 244 48 49 51 17 51 21 51 53 51 17 51 21 7 35 53 35 53 35 21 93 82 240 82 71 8 71 74 240 1 230 197 197 254 93 52 187 172 216 216 0 0 1 0 80 255 84 2 27 1 242 0 36 0 82 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 3 62 89 184 0 11 16 185 0 18 0 1 244 184 0 1 16 185 0 28 0 1 244 184 0 1 16 184 0 35 208 48 49 5 39 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 23 14 1 15 1 1 47 3 48 81 58 33 43 74 99 55 60 87 30 41 30 65 38 42 70 49 28 27 49 69 42 45 75 30 37 34 79 45 9 172 163 6 40 64 87 54 61 95 66 34 42 29 53 26 30 27 50 69 42 42 68 49 27 35 26 53 30 38 6 162 0 0 0 0 1 0 51 255 51 2 37 1 230 0 15 0 55 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 7 0 2 0 0 17 18 57 184 0 2 16 184 0 13 208 48 49 5 53 3 51 19 30 1 23 51 62 1 55 19 51 3 21 1 6 211 84 110 15 28 13 4 13 26 15 110 80 205 205 199 1 236 254 243 37 74 34 34 74 37 1 13 254 20 199 0 0 0 0 1 0 51 255 51 2 37 1 230 0 22 0 94 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 7 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 3 0 1 244 186 0 9 0 4 0 21 17 18 57 184 0 4 16 184 0 15 208 184 0 3 16 184 0 17 208 184 0 0 16 184 0 18 208 48 49 51 53 55 51 3 51 19 30 1 23 51 62 1 55 19 51 3 51 21 35 21 35 53 100 78 57 184 84 110 15 28 13 4 13 26 15 110 80 179 130 156 82 56 6 1 168 254 243 37 74 34 34 74 37 1 13 254 88 62 205 205 0 0 0 0 1 0 64 255 84 2 48 1 230 0 30 0 116 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 3 62 89 184 0 1 208 186 0 6 0 12 0 14 17 18 57 186 0 19 0 14 0 12 17 18 57 186 0 13 0 19 0 6 17 18 57 184 0 14 16 184 0 25 208 186 0 26 0 6 0 19 17 18 57 184 0 1 16 185 0 28 0 1 244 48 49 5 53 35 39 46 1 39 35 14 1 15 1 35 55 39 51 23 30 1 23 51 62 1 63 1 51 7 23 51 21 7 1 225 36 85 15 33 16 4 15 30 15 80 88 185 171 91 77 13 29 15 4 14 28 13 73 87 173 135 76 8 172 172 112 21 46 21 22 43 23 112 252 234 107 20 42 20 20 44 20 105 241 178 52 187 0 0 1 0 88 255 84 2 43 1 230 0 26 0 92 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 7 62 89 184 0 0 69 88 184 0 25 47 27 185 0 25 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 6 0 10 0 0 17 18 57 184 0 6 47 185 0 15 0 1 244 184 0 10 16 184 0 20 208 184 0 0 16 185 0 22 0 1 244 48 49 33 53 14 3 35 34 38 61 1 51 21 20 22 51 50 54 55 53 51 17 51 21 7 35 53 1 146 15 23 24 27 19 98 108 82 67 74 25 41 25 82 71 8 71 196 3 5 3 1 81 95 126 126 58 51 6 6 223 254 93 52 187 172 0 0 0 255 255 0 93 0 0 2 11 2 200 2 6 0 37 0 0 255 255 0 6 0 0 2 82 2 213 2 38 3 21 0 0 0 6 4 251 0 0 0 0 255 255 0 81 255 244 2 25 2 200 2 6 0 41 0 0 255 255 0 81 255 244 2 3 2 213 2 38 0 30 0 0 0 6 4 251 20 0 0 0 255 255 0 17 255 244 2 85 1 242 2 6 1 28 0 0 255 255 0 68 255 244 2 26 2 213 2 38 0 34 0 0 0 6 4 251 16 0 0 0 255 255 0 69 255 244 2 25 1 242 2 6 1 223 0 0 255 255 0 100 0 0 1 244 2 146 2 38 3 23 0 0 0 6 4 246 11 0 0 0 255 255 0 60 255 244 2 28 2 188 2 38 0 44 0 0 0 6 5 0 0 0 0 0 255 255 0 60 255 244 2 28 1 242 2 6 1 253 0 0 255 255 0 49 255 47 2 39 2 146 2 38 0 54 0 0 0 6 4 246 4 0 0 0 255 255 0 49 255 47 2 39 2 249 2 38 0 54 0 0 0 6 5 8 4 0 0 0 255 255 0 60 255 244 1 251 1 242 2 6 1 221 0 0 255 255 0 60 255 244 1 251 2 213 2 38 1 221 0 0 0 6 4 251 4 0 0 0 0 2 0 85 255 244 2 7 2 218 0 46 0 64 0 77 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 8 0 0 0 23 17 18 57 184 0 23 16 185 0 24 0 1 244 184 0 0 16 185 0 47 0 1 244 186 0 57 0 23 0 0 17 18 57 48 49 5 34 46 2 53 52 54 55 46 3 53 52 62 2 55 62 3 55 23 14 1 7 14 3 21 20 30 2 23 30 3 21 20 14 2 39 50 62 2 53 52 46 2 39 14 1 21 20 30 2 1 39 41 76 58 35 105 87 26 49 38 24 32 61 87 54 30 39 28 20 11 17 21 54 31 53 72 46 20 23 39 51 27 34 56 41 23 31 57 82 49 33 52 36 19 16 29 39 23 78 90 22 38 49 12 30 55 80 50 92 110 27 18 34 35 38 21 37 44 25 13 7 3 4 6 8 5 75 11 13 4 6 7 11 18 17 13 22 24 29 19 24 48 56 68 44 51 86 62 34 68 25 44 61 36 30 48 41 36 17 20 96 72 34 55 39 22 255 255 0 99 0 0 2 52 2 204 2 38 2 66 0 0 0 6 4 254 28 0 0 0 255 255 0 99 0 0 2 52 2 188 2 38 2 66 0 0 0 6 5 0 24 0 0 0 0 4 0 2 255 244 2 94 2 138 0 57 0 73 0 81 0 85 0 135 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 83 0 1 0 82 0 4 43 187 0 78 0 1 0 68 0 4 43 184 0 0 16 185 0 4 0 1 244 184 0 28 16 184 0 8 208 184 0 8 47 184 0 0 16 184 0 36 208 184 0 36 47 186 0 20 0 36 0 28 17 18 57 184 0 28 16 185 0 32 0 1 244 186 0 50 0 8 0 0 17 18 57 184 0 83 16 184 0 58 220 185 0 74 0 1 244 48 49 23 34 38 47 1 50 54 53 17 51 30 5 23 30 1 23 51 46 3 61 1 52 51 50 22 31 1 34 6 21 17 35 46 5 39 46 3 39 35 30 3 29 1 20 1 34 46 2 53 52 62 2 51 50 22 21 20 6 39 50 53 52 35 34 21 20 7 53 51 21 35 5 16 6 6 15 15 86 3 19 25 27 24 17 3 9 20 8 4 3 7 6 3 68 5 16 7 5 14 15 88 3 18 24 27 24 18 3 4 10 10 9 4 4 4 7 6 3 1 134 23 41 32 18 18 32 41 23 46 66 66 46 50 50 52 34 172 12 1 2 65 17 25 2 28 11 62 82 91 82 62 12 29 80 29 47 79 71 67 36 153 99 1 2 65 17 25 253 228 11 62 82 92 82 62 12 14 36 38 35 14 47 79 71 67 36 154 98 1 32 19 40 61 42 41 61 39 19 78 82 83 79 55 107 106 106 107 163 54 54 0 0 0 0 3 0 42 255 244 2 65 2 156 0 43 0 57 0 71 0 131 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 47 0 18 0 0 17 18 57 184 0 47 16 184 0 10 208 184 0 47 16 185 0 26 0 1 244 186 0 61 0 0 0 18 17 18 57 184 0 61 16 184 0 41 208 184 0 36 208 184 0 29 208 184 0 0 16 184 0 39 208 184 0 38 208 184 0 18 16 185 0 55 0 1 244 184 0 0 16 185 0 58 0 1 244 184 0 10 16 184 0 64 208 48 49 23 34 46 2 53 52 62 2 55 46 1 53 52 62 2 51 50 22 21 20 14 2 7 30 1 23 62 1 55 51 14 1 7 22 23 7 38 39 14 1 3 20 22 23 62 3 53 52 38 35 34 6 19 50 54 55 46 1 39 14 1 21 20 30 2 238 44 72 51 29 20 35 44 24 21 23 21 37 53 33 61 66 25 40 50 26 32 83 45 28 41 14 76 18 52 36 60 53 23 65 72 36 87 102 16 14 21 37 29 16 27 33 35 38 56 31 58 26 48 85 34 32 42 20 34 46 12 27 48 67 40 32 54 45 39 18 41 79 35 33 56 42 24 72 58 32 52 47 41 20 51 94 39 40 95 57 65 118 52 46 17 68 20 55 35 40 2 14 27 58 30 15 31 33 37 22 29 43 54 254 11 28 24 42 100 54 28 61 38 27 45 32 17 0 0 0 3 0 71 255 244 2 17 2 138 0 11 0 27 0 39 0 71 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 12 0 1 244 184 0 6 16 185 0 20 0 1 244 186 0 28 0 12 0 20 17 18 57 184 0 28 47 184 0 34 208 48 49 5 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 46 2 35 34 14 2 21 20 22 55 34 38 53 52 54 51 50 22 21 20 6 1 44 107 122 122 107 107 122 122 107 67 85 22 41 56 33 33 56 41 22 85 67 25 37 37 25 25 37 37 12 173 160 161 168 168 161 160 173 66 130 137 69 99 65 30 30 65 99 69 137 130 207 35 32 31 35 35 31 32 35 0 0 1 0 99 0 0 2 15 2 126 0 12 0 59 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 1 0 1 244 184 0 8 16 184 0 3 208 184 0 1 16 184 0 11 208 48 49 51 53 51 17 35 53 62 1 55 51 17 51 21 99 180 137 51 77 30 61 166 68 1 214 53 8 23 16 253 198 68 0 1 0 69 0 0 2 10 2 138 0 31 0 67 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 11 62 89 184 0 0 69 88 184 0 31 47 27 185 0 31 0 3 62 89 185 0 29 0 1 244 184 0 1 208 186 0 6 0 16 0 31 17 18 57 184 0 16 16 185 0 9 0 1 244 48 49 51 53 62 3 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 7 62 1 59 1 21 73 81 125 85 44 68 71 45 77 31 47 43 99 68 48 77 54 29 43 78 108 65 30 60 29 210 49 72 116 97 84 40 55 70 45 32 47 44 53 27 49 70 42 45 91 97 105 59 2 4 71 0 1 0 57 255 244 2 6 2 138 0 51 0 83 0 184 0 0 69 88 184 0 33 47 27 185 0 33 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 17 0 33 0 0 17 18 57 184 0 17 47 185 0 18 0 1 244 184 0 33 16 185 0 26 0 1 244 186 0 42 0 17 0 18 17 18 57 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 46 2 35 53 50 62 2 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 1 31 83 112 35 42 32 89 62 33 56 41 23 25 56 88 63 57 79 50 23 71 59 45 80 32 44 40 102 62 45 77 57 32 76 60 32 57 44 25 36 63 84 12 55 35 54 30 46 17 30 43 27 28 47 34 18 63 18 32 44 25 47 54 36 29 52 35 45 22 41 60 39 58 74 20 4 7 27 41 54 33 42 68 47 25 0 2 0 39 0 0 2 33 2 126 0 10 0 20 0 85 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 1 0 1 0 12 0 4 43 184 0 12 16 184 0 11 208 184 0 3 208 184 0 12 16 184 0 6 208 184 0 1 16 184 0 9 208 184 0 4 16 185 0 16 0 1 244 48 49 33 53 33 53 1 51 17 51 21 35 21 37 51 53 62 1 55 35 14 1 7 1 112 254 183 1 63 88 99 99 254 196 238 1 2 2 5 15 34 16 176 55 1 151 254 116 66 176 242 198 26 61 26 23 47 23 0 0 0 0 1 0 56 255 244 2 10 2 126 0 40 0 85 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 31 0 1 0 19 0 4 43 184 0 0 16 185 0 11 0 1 244 186 0 28 0 0 0 24 17 18 57 184 0 28 16 184 0 23 208 184 0 24 16 185 0 26 0 1 244 48 49 5 34 46 2 39 55 30 3 51 50 62 2 53 52 38 35 34 6 7 39 19 33 21 33 7 62 1 51 50 30 2 21 20 14 2 1 30 43 69 55 45 18 41 16 36 43 53 32 34 59 44 25 85 72 40 56 34 44 21 1 105 254 224 17 28 53 37 46 80 59 34 39 66 85 12 15 24 31 17 54 14 27 20 12 21 38 54 33 66 74 20 19 28 1 51 71 189 12 14 24 49 75 52 52 80 55 29 0 0 0 2 0 77 255 244 2 22 2 138 0 34 0 48 0 87 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 43 0 1 0 25 0 4 43 184 0 10 16 185 0 17 0 1 244 186 0 22 0 0 0 10 17 18 57 184 0 0 16 185 0 35 0 1 244 184 0 22 16 185 0 46 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 7 62 1 51 50 30 2 21 20 14 2 39 50 62 2 53 52 38 35 34 6 7 30 1 1 65 52 89 66 37 44 74 97 52 59 87 32 46 25 66 36 38 70 53 33 1 39 94 48 44 73 53 29 35 58 77 43 28 50 36 21 70 66 38 87 38 9 85 12 38 77 115 77 96 135 85 39 39 29 51 23 27 28 64 105 77 38 45 25 49 74 49 46 75 54 30 65 20 37 51 32 66 69 40 46 93 96 0 0 0 0 1 0 70 0 0 2 20 2 126 0 14 0 51 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 7 16 185 0 5 0 1 244 184 0 9 208 48 49 51 62 3 55 33 53 33 21 14 3 7 226 4 26 50 77 55 254 144 1 206 63 82 50 22 3 91 149 134 126 67 71 51 72 132 137 152 94 0 0 3 0 68 255 244 2 19 2 138 0 37 0 50 0 64 0 87 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 51 0 1 244 184 0 19 16 185 0 43 0 1 244 186 0 59 0 51 0 43 17 18 57 184 0 59 47 184 0 10 220 184 0 59 16 184 0 27 208 184 0 27 47 184 0 38 220 48 49 5 34 46 2 53 52 62 2 55 53 46 1 53 52 62 2 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 3 54 53 52 38 35 34 6 21 20 30 2 3 50 54 53 52 46 2 39 14 1 21 20 22 1 46 54 87 60 33 24 38 49 26 40 57 29 53 72 43 47 73 51 27 57 40 26 46 34 19 31 58 85 5 80 66 63 54 66 26 46 61 12 72 76 31 54 73 42 47 62 87 12 26 47 64 38 33 52 42 31 12 4 25 73 51 37 60 43 24 25 45 63 37 45 79 28 4 13 30 38 51 34 36 62 46 26 1 104 58 70 48 65 56 47 29 41 32 25 254 202 62 50 33 45 32 25 14 26 65 48 54 68 0 0 0 2 0 67 255 244 2 12 2 138 0 13 0 48 0 87 0 184 0 0 69 88 184 0 39 47 27 185 0 39 0 11 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 3 62 89 187 0 0 0 1 0 29 0 4 43 186 0 26 0 14 0 39 17 18 57 184 0 26 16 185 0 3 0 1 244 184 0 39 16 185 0 6 0 1 244 184 0 14 16 185 0 21 0 1 244 48 49 1 50 54 55 46 1 35 34 14 2 21 20 22 19 34 38 39 55 30 1 51 50 62 2 55 14 1 35 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 1 25 38 86 39 10 83 71 29 49 36 21 69 43 59 87 32 46 24 66 37 38 69 53 32 2 39 93 49 44 73 52 29 34 59 77 42 52 90 66 37 45 74 96 1 54 40 45 94 96 20 37 52 31 66 69 254 190 38 29 52 23 28 28 65 104 77 38 44 25 49 74 49 46 75 54 30 38 77 115 77 96 135 85 39 0 0 3 0 71 255 244 2 17 2 138 0 11 0 20 0 32 0 97 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 6 16 185 0 12 0 1 244 186 0 14 0 6 0 0 17 18 57 186 0 15 0 0 0 6 17 18 57 184 0 0 16 185 0 21 0 1 244 186 0 24 0 0 0 6 17 18 57 186 0 25 0 6 0 0 17 18 57 48 49 5 34 38 53 52 54 51 50 22 21 20 6 3 34 7 19 62 1 53 52 38 3 50 54 55 3 14 1 21 20 30 2 1 44 107 122 122 107 107 122 122 107 67 40 243 8 8 85 67 32 55 20 243 8 8 22 41 56 12 173 160 161 168 168 161 160 173 2 87 59 254 166 29 68 42 139 127 253 232 30 32 1 91 28 69 42 70 102 66 32 0 0 0 0 3 0 71 255 244 2 17 2 74 0 11 0 27 0 39 0 71 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 12 0 1 244 184 0 6 16 185 0 20 0 1 244 186 0 28 0 12 0 20 17 18 57 184 0 28 47 184 0 34 208 48 49 5 34 38 53 52 54 51 50 22 21 20 6 39 50 62 2 53 52 38 35 34 6 21 20 30 2 55 34 38 53 52 54 51 50 22 21 20 6 1 44 107 122 122 107 107 122 122 107 33 56 41 22 85 67 67 85 22 41 56 33 25 37 37 25 25 37 37 12 156 146 144 152 152 144 146 156 66 28 58 89 61 118 111 111 118 61 89 58 28 176 35 32 31 35 35 31 32 35 0 0 1 0 99 0 0 2 15 2 62 0 12 0 59 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 1 0 1 244 184 0 8 16 184 0 3 208 184 0 1 16 184 0 11 208 48 49 51 53 51 17 35 53 62 1 55 51 17 51 21 99 180 137 51 77 30 61 166 68 1 150 53 8 23 16 254 6 68 0 1 0 69 0 0 2 10 2 74 0 29 0 65 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 9 62 89 184 0 0 69 88 184 0 29 47 27 185 0 29 0 3 62 89 185 0 24 0 1 244 184 0 1 208 184 0 14 16 185 0 7 0 1 244 184 0 24 16 184 0 27 208 48 49 51 53 62 1 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 7 62 1 59 1 21 73 165 170 68 71 45 77 31 47 43 99 68 48 77 54 29 39 72 103 64 29 61 29 194 49 110 166 64 58 72 45 32 47 44 53 27 51 71 44 38 78 81 85 46 2 4 71 0 0 0 1 0 57 255 170 2 6 2 74 0 51 0 60 0 184 0 0 69 88 184 0 33 47 27 185 0 33 0 9 62 89 187 0 7 0 1 0 0 0 4 43 187 0 18 0 1 0 17 0 4 43 184 0 33 16 185 0 26 0 1 244 186 0 42 0 17 0 18 17 18 57 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 46 2 35 53 50 62 2 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 1 31 83 112 35 42 32 89 62 33 56 41 23 25 56 88 63 57 79 50 23 71 59 45 80 32 44 40 102 62 45 77 57 32 76 60 32 57 44 25 36 63 84 86 55 35 54 30 45 17 31 44 28 29 48 33 18 64 18 33 44 26 47 56 36 29 52 35 45 22 42 61 39 59 75 20 4 7 28 41 54 34 44 69 48 25 0 0 0 0 2 0 39 255 182 2 33 2 62 0 10 0 20 0 60 0 184 0 0 47 184 0 0 69 88 184 0 4 47 27 185 0 4 0 9 62 89 187 0 7 0 1 0 8 0 4 43 184 0 8 16 184 0 1 208 184 0 7 16 184 0 12 208 186 0 16 0 4 0 0 17 18 57 48 49 5 53 33 53 1 51 17 51 21 35 21 37 51 53 62 1 55 35 14 1 7 1 112 254 183 1 63 88 99 99 254 195 239 1 2 2 5 15 33 16 74 168 55 1 169 254 99 67 168 235 215 26 61 26 25 49 23 0 0 0 0 1 0 56 255 170 2 10 2 62 0 40 0 68 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 9 62 89 187 0 11 0 1 0 0 0 4 43 187 0 31 0 1 0 19 0 4 43 186 0 28 0 0 0 24 17 18 57 184 0 28 16 184 0 23 208 184 0 24 16 185 0 26 0 1 244 48 49 5 34 46 2 39 55 30 3 51 50 62 2 53 52 38 35 34 6 7 39 19 33 21 33 7 62 1 51 50 30 2 21 20 14 2 1 30 43 69 55 45 18 41 16 36 43 53 32 34 59 44 25 85 72 40 56 34 44 21 1 105 254 224 17 28 53 37 46 80 59 34 39 66 85 86 15 24 32 17 53 14 26 20 12 21 38 55 35 68 74 20 19 28 1 55 71 193 13 13 23 50 76 53 53 81 57 29 0 0 0 255 255 0 78 255 244 2 23 2 138 2 6 3 103 1 0 0 1 0 70 255 182 2 20 2 62 0 14 0 34 0 184 0 0 47 184 0 0 69 88 184 0 7 47 27 185 0 7 0 9 62 89 185 0 5 0 1 244 184 0 9 208 48 49 23 62 3 55 33 53 33 21 14 3 7 226 4 26 50 77 55 254 144 1 206 63 82 49 22 4 74 92 152 137 128 68 71 51 73 133 140 155 96 0 255 255 0 68 255 244 2 19 2 138 2 6 3 105 0 0 0 2 0 67 255 170 2 12 2 74 0 13 0 48 0 70 0 184 0 0 69 88 184 0 39 47 27 185 0 39 0 9 62 89 187 0 21 0 1 0 14 0 4 43 187 0 0 0 1 0 29 0 4 43 186 0 26 0 14 0 39 17 18 57 184 0 26 16 185 0 3 0 1 244 184 0 39 16 185 0 6 0 1 244 48 49 37 50 54 55 46 1 35 34 14 2 21 20 22 19 34 38 39 55 30 1 51 50 62 2 55 14 1 35 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 1 25 38 86 39 8 84 72 29 49 36 21 69 43 59 87 32 46 24 66 37 37 68 53 34 2 39 93 49 44 73 52 29 34 59 77 42 52 90 66 37 45 74 96 237 40 46 97 101 20 38 52 33 68 73 254 189 39 29 51 23 27 28 64 105 77 38 44 26 51 76 50 46 77 55 30 38 77 115 77 99 139 87 40 0 0 0 0 3 0 71 255 244 2 17 2 74 0 11 0 22 0 32 0 97 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 6 16 185 0 12 0 1 244 186 0 15 0 6 0 0 17 18 57 186 0 16 0 0 0 6 17 18 57 184 0 0 16 185 0 23 0 1 244 186 0 25 0 0 0 6 17 18 57 186 0 26 0 6 0 0 17 18 57 48 49 5 34 38 53 52 54 51 50 22 21 20 6 3 34 6 7 19 54 53 52 46 2 3 50 55 3 6 21 20 30 2 1 44 107 122 122 107 107 122 122 107 29 49 20 230 20 22 41 56 33 59 39 229 21 22 41 56 12 156 146 144 152 152 144 146 156 2 23 20 21 254 182 55 83 60 88 57 28 254 40 43 1 75 53 82 62 90 59 28 0 3 0 71 255 244 2 17 2 156 0 11 0 31 0 43 0 71 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 12 0 1 244 184 0 6 16 185 0 22 0 1 244 186 0 32 0 6 0 0 17 18 57 184 0 32 16 184 0 38 208 48 49 5 34 38 53 52 54 51 50 22 21 20 6 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 55 34 38 53 52 54 51 50 22 21 20 6 1 44 107 122 122 107 107 122 122 107 33 56 41 22 22 41 56 33 33 56 41 22 22 41 56 33 25 37 37 25 25 37 37 12 178 165 166 171 171 166 165 178 66 33 68 105 71 71 102 66 32 32 66 102 71 71 105 68 33 217 34 32 32 34 34 32 32 34 0 0 0 0 1 0 99 0 0 2 15 2 144 0 12 0 59 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 1 0 1 244 184 0 9 16 184 0 4 208 184 0 1 16 184 0 11 208 48 49 51 53 51 17 35 53 62 1 55 51 17 51 21 99 180 137 51 77 30 61 166 68 1 233 52 8 23 16 253 180 68 0 1 0 69 0 0 2 10 2 156 0 31 0 57 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 29 0 1 244 184 0 1 208 184 0 16 16 185 0 9 0 1 244 48 49 51 53 62 3 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 7 62 1 59 1 21 73 81 125 85 44 68 71 45 77 31 47 43 99 68 48 77 54 29 43 78 108 65 29 61 29 210 49 72 116 99 85 40 62 78 44 32 46 45 52 29 54 75 46 45 91 98 105 60 2 4 71 0 0 0 1 0 57 255 244 2 6 2 156 0 51 0 83 0 184 0 0 69 88 184 0 33 47 27 185 0 33 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 7 0 1 244 186 0 17 0 33 0 0 17 18 57 184 0 17 47 185 0 18 0 1 244 184 0 33 16 185 0 26 0 1 244 186 0 42 0 18 0 17 17 18 57 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 46 2 35 53 50 62 2 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 1 31 83 112 35 42 32 89 62 33 56 41 23 25 56 88 63 57 79 50 23 71 59 45 80 32 44 40 102 62 45 77 57 32 76 60 32 57 44 25 36 63 84 12 55 35 54 30 46 17 32 45 29 29 48 34 19 63 19 33 46 26 49 56 36 28 52 35 44 22 42 62 40 60 77 19 4 7 29 42 55 34 44 69 48 26 0 2 0 39 0 0 2 33 2 144 0 10 0 20 0 77 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 1 220 185 0 12 0 1 244 184 0 3 208 184 0 12 16 184 0 7 208 184 0 1 16 184 0 8 208 186 0 16 0 4 0 0 17 18 57 48 49 33 53 33 53 1 51 17 51 21 35 21 37 51 53 62 1 55 35 14 1 7 1 112 254 183 1 63 88 99 99 254 195 239 1 2 2 3 15 35 17 180 55 1 165 254 102 66 180 246 209 28 62 27 25 48 24 0 0 0 0 1 0 56 255 244 2 10 2 144 0 40 0 73 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 11 0 1 244 186 0 19 0 24 0 0 17 18 57 184 0 24 16 185 0 26 0 1 244 184 0 19 16 185 0 31 0 1 244 48 49 5 34 46 2 39 55 30 3 51 50 62 2 53 52 38 35 34 6 7 39 19 33 21 33 7 62 1 51 50 30 2 21 20 14 2 1 30 43 69 55 45 18 41 16 36 44 52 32 34 59 44 25 85 72 40 56 34 44 21 1 105 254 224 17 28 53 37 46 80 59 34 39 66 85 12 15 24 31 17 57 14 28 21 13 21 39 56 35 68 76 19 20 28 1 60 70 199 12 14 24 50 77 52 53 83 57 29 0 0 0 2 0 77 255 244 2 22 2 156 0 34 0 48 0 81 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 17 0 1 244 186 0 25 0 10 0 0 17 18 57 184 0 25 47 184 0 0 16 185 0 35 0 1 244 184 0 25 16 185 0 43 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 7 62 1 51 50 30 2 21 20 14 2 39 50 62 2 53 52 38 35 34 6 7 30 1 1 65 52 89 66 37 44 74 97 52 59 87 32 46 25 66 36 38 70 53 33 1 38 95 48 44 73 53 29 35 58 77 43 28 50 36 21 70 66 38 87 39 10 84 12 39 79 119 79 99 138 87 40 38 29 51 23 27 29 67 109 79 39 44 25 51 75 50 47 77 56 30 65 21 38 53 33 68 71 40 46 97 101 0 0 1 0 70 0 0 2 20 2 144 0 14 0 51 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 7 16 185 0 5 0 1 244 184 0 9 208 48 49 51 62 3 55 33 53 33 21 14 3 7 226 4 25 50 77 56 254 144 1 206 65 82 48 21 4 94 155 138 130 69 70 50 74 135 142 158 97 0 0 3 0 68 255 244 2 19 2 156 0 37 0 50 0 64 0 97 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 59 0 19 0 0 17 18 57 184 0 59 16 185 0 38 0 1 244 186 0 11 0 38 0 59 17 18 57 186 0 28 0 59 0 38 17 18 57 184 0 19 16 185 0 43 0 1 244 184 0 0 16 185 0 51 0 1 244 48 49 5 34 46 2 53 52 62 2 55 53 46 1 53 52 62 2 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 3 54 53 52 38 35 34 6 21 20 30 2 3 50 54 53 52 46 2 39 14 1 21 20 22 1 46 54 87 60 33 24 38 49 26 40 57 29 53 72 43 47 73 51 27 56 41 26 46 34 19 31 58 85 5 80 66 63 54 66 26 46 61 12 72 76 31 54 73 42 48 61 87 12 27 48 67 39 33 54 43 32 12 4 25 76 53 37 62 44 24 26 46 63 38 48 82 28 4 13 30 39 52 35 37 64 48 27 1 113 60 73 50 67 58 48 30 44 33 26 254 193 65 52 34 46 33 26 14 25 68 50 55 72 0 2 0 67 255 244 2 12 2 156 0 13 0 48 0 77 0 184 0 0 69 88 184 0 39 47 27 185 0 39 0 13 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 3 62 89 186 0 29 0 39 0 14 17 18 57 184 0 29 47 185 0 0 0 1 244 184 0 39 16 185 0 6 0 1 244 184 0 14 16 185 0 21 0 1 244 48 49 1 50 54 55 46 1 35 34 14 2 21 20 22 19 34 38 39 55 30 1 51 50 62 2 55 14 1 35 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 1 25 38 86 39 9 84 71 29 49 36 21 69 43 59 87 32 46 24 66 37 38 69 53 32 2 39 93 49 44 73 52 29 34 59 77 42 52 90 66 37 45 74 96 1 63 40 45 98 102 21 38 54 33 68 71 254 181 38 29 52 23 28 29 67 108 79 38 44 25 51 75 50 47 78 55 30 39 79 119 79 98 139 87 40 0 0 0 0 3 0 71 255 244 2 17 2 156 0 11 0 21 0 32 0 97 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 6 16 185 0 12 0 1 244 186 0 14 0 6 0 0 17 18 57 186 0 15 0 0 0 6 17 18 57 184 0 0 16 185 0 22 0 1 244 186 0 25 0 0 0 6 17 18 57 186 0 26 0 6 0 0 17 18 57 48 49 5 34 38 53 52 54 51 50 22 21 20 6 3 34 7 19 54 53 52 46 2 3 50 54 55 3 6 21 20 30 2 1 44 107 122 122 107 107 122 122 107 68 40 243 17 22 41 56 33 33 55 20 243 17 22 41 56 12 178 165 166 171 171 166 165 178 2 106 63 254 152 60 88 72 104 67 32 253 213 32 34 1 105 60 87 72 106 69 33 0 1 0 219 255 244 1 125 0 157 0 11 0 24 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 6 220 48 49 5 34 38 53 52 54 51 50 22 21 20 6 1 44 34 47 47 34 34 47 47 12 46 38 38 47 47 38 38 46 0 1 0 197 255 43 1 140 0 155 0 18 0 11 0 186 0 13 0 7 0 3 43 48 49 23 39 62 1 55 6 34 35 34 38 53 52 54 51 50 22 21 20 6 220 23 62 62 2 5 9 5 32 46 48 32 45 45 93 213 52 28 79 60 2 37 38 37 39 69 59 88 121 0 0 0 255 255 0 219 255 244 1 125 2 3 2 39 3 130 0 0 1 102 0 6 3 130 0 0 255 255 0 197 255 43 1 140 2 3 2 39 3 130 0 0 1 102 0 6 3 131 0 0 0 3 0 32 255 244 2 56 0 138 0 11 0 23 0 35 0 0 23 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 102 29 41 41 29 29 40 40 169 29 41 41 29 29 41 41 169 29 40 40 29 29 41 41 12 42 33 34 41 41 34 33 42 42 33 34 41 41 34 33 42 42 33 34 41 41 34 33 42 0 0 2 0 227 255 244 1 117 2 158 0 5 0 17 0 45 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 13 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 3 62 89 184 0 12 220 184 0 0 220 48 49 37 3 39 51 7 3 7 34 38 53 52 54 51 50 22 21 20 6 1 16 10 2 80 2 10 28 30 43 43 30 30 43 43 232 1 88 94 94 254 168 244 42 36 35 41 41 35 36 42 0 0 0 2 0 227 255 72 1 117 1 242 0 5 0 17 0 49 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 12 16 184 0 6 220 184 0 2 220 48 49 5 55 19 51 19 23 3 34 38 53 52 54 51 50 22 21 20 6 1 4 2 10 56 10 2 40 30 43 43 30 30 43 43 184 94 1 88 254 168 94 2 16 41 36 35 42 42 35 36 41 0 0 2 0 109 255 244 1 223 2 170 0 29 0 41 0 42 0 184 0 0 69 88 184 0 30 47 27 185 0 30 0 3 62 89 187 0 17 0 1 0 10 0 4 43 184 0 30 16 184 0 36 220 184 0 0 220 48 49 55 38 62 4 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 4 23 7 34 38 53 52 54 51 50 22 21 20 6 242 6 18 35 44 39 26 55 55 38 65 27 49 34 92 58 42 68 49 27 27 39 45 37 21 5 29 30 43 43 30 30 43 43 232 36 56 46 40 39 42 26 42 55 31 27 45 35 46 22 41 57 36 34 52 44 39 43 50 32 244 42 36 35 41 41 35 36 42 0 0 0 2 0 121 255 60 1 235 1 242 0 29 0 41 0 59 0 184 0 0 69 88 184 0 36 47 27 185 0 36 0 7 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 36 16 184 0 30 220 184 0 12 220 184 0 0 16 185 0 23 0 1 244 48 49 5 34 46 2 53 52 62 4 39 51 22 14 4 21 20 22 51 50 54 55 23 14 1 3 34 38 53 52 54 51 50 22 21 20 6 1 51 42 68 49 27 27 39 45 37 20 4 73 6 18 35 44 39 26 55 55 38 65 27 49 34 92 51 30 43 43 30 30 43 43 196 22 41 57 36 34 52 44 39 43 49 33 36 56 46 40 39 43 25 42 54 30 27 45 35 46 2 28 41 36 35 42 42 35 36 41 0 0 0 0 1 0 245 1 96 1 99 2 175 0 5 0 0 1 47 1 51 15 1 1 16 25 2 110 2 25 1 96 225 110 110 225 0 0 0 255 255 0 131 1 96 1 214 2 175 2 38 3 139 142 0 0 6 3 139 115 0 0 0 0 1 0 209 1 94 1 124 2 187 0 17 0 11 0 186 0 12 0 0 0 3 43 48 49 1 34 38 53 52 54 55 23 14 1 7 54 51 50 22 21 20 6 1 43 39 51 76 68 27 46 54 3 12 14 31 39 42 1 94 63 57 75 119 35 48 27 79 52 6 40 32 35 42 0 0 0 1 0 217 1 94 1 132 2 187 0 17 0 11 0 186 0 6 0 12 0 3 43 48 49 19 39 62 1 55 6 35 34 38 53 52 54 51 50 22 21 20 6 245 28 47 54 3 12 14 32 39 42 32 40 50 76 1 94 48 26 79 53 6 39 32 35 43 64 57 75 118 255 255 0 95 1 94 1 239 2 187 2 38 3 141 142 0 0 6 3 141 115 0 0 0 255 255 0 103 1 94 1 247 2 187 2 38 3 142 142 0 0 6 3 142 115 0 0 0 255 255 0 217 255 31 1 132 0 124 2 7 3 142 0 0 253 193 0 0 255 255 0 103 255 31 1 247 0 124 2 39 3 142 255 142 253 193 0 7 3 142 0 115 253 193 0 0 0 1 0 212 1 94 1 127 2 187 0 17 0 11 0 186 0 6 0 12 0 3 43 48 49 1 46 1 53 52 54 51 50 22 21 20 6 35 34 39 30 1 23 1 99 67 76 50 40 32 42 39 32 14 12 3 54 47 1 94 35 118 75 57 64 43 35 32 39 6 53 79 26 0 0 0 0 1 0 197 0 52 1 133 1 196 0 6 0 0 37 39 53 55 23 7 23 1 94 153 153 39 127 127 52 160 80 160 35 165 166 0 0 1 0 211 0 52 1 147 1 196 0 6 0 0 55 39 55 39 55 23 21 250 39 127 127 39 153 52 34 166 165 35 160 80 0 0 255 255 0 83 0 52 1 248 1 196 2 38 3 148 142 0 0 6 3 148 115 0 0 0 255 255 0 97 0 52 2 6 1 196 2 38 3 149 142 0 0 6 3 149 115 0 0 0 255 255 0 85 1 43 2 3 1 105 2 6 4 114 0 0 255 255 0 85 1 43 2 3 1 105 2 6 3 152 0 0 255 255 0 85 1 43 2 3 1 105 2 6 4 114 0 0 0 1 0 80 0 216 2 8 1 32 0 3 0 0 55 53 33 21 80 1 184 216 72 72 0 1 0 0 0 216 2 88 1 32 0 3 0 0 61 1 33 21 2 88 216 72 72 0 0 1 0 80 0 216 2 8 1 32 0 3 0 0 55 53 33 21 80 1 184 216 72 72 255 255 0 0 0 216 2 88 1 32 2 6 3 156 0 0 255 255 0 219 1 7 1 125 1 176 2 7 3 130 0 0 1 19 0 0 0 1 0 151 0 115 1 193 1 153 0 19 0 0 37 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 1 44 30 54 41 24 24 41 54 30 30 54 41 24 24 41 54 115 21 39 54 33 33 54 39 21 21 39 54 33 33 54 39 21 0 2 0 139 0 103 1 205 1 165 0 19 0 31 0 0 37 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 1 44 35 59 43 24 24 43 59 35 35 59 43 24 24 43 59 35 47 59 59 47 47 59 59 103 24 43 58 34 34 58 43 24 24 43 58 34 34 58 43 24 48 62 49 49 62 62 49 49 62 0 0 1 0 166 0 129 1 178 1 139 0 3 0 0 55 17 33 17 166 1 12 129 1 10 254 246 0 0 0 2 0 154 0 117 1 190 1 151 0 3 0 7 0 0 55 17 33 17 39 51 53 35 154 1 36 243 194 194 117 1 34 254 222 45 200 0 0 0 0 1 0 139 0 129 1 205 1 169 0 5 0 0 55 53 19 51 19 21 139 160 2 160 129 3 1 37 254 219 3 0 0 2 0 117 0 117 1 227 1 190 0 5 0 8 0 0 55 53 19 51 19 21 37 51 39 117 182 2 182 254 220 218 109 117 3 1 70 254 186 3 43 202 0 0 0 1 0 166 0 101 1 206 1 169 0 5 0 0 55 17 51 5 21 5 166 3 1 37 254 219 101 1 68 161 3 160 0 2 0 154 0 79 1 227 1 190 0 5 0 8 0 0 55 17 51 5 21 5 63 1 39 154 2 1 71 254 185 41 201 201 79 1 111 182 3 182 75 109 108 0 0 1 0 139 0 99 1 205 1 139 0 5 0 0 37 3 53 33 21 3 1 43 160 1 66 160 99 1 37 3 3 254 219 0 0 0 0 2 0 117 0 78 1 227 1 151 0 5 0 8 0 0 37 3 53 33 21 3 39 55 35 1 43 182 1 110 182 1 109 218 78 1 70 3 3 254 186 84 202 0 0 1 0 138 0 101 1 178 1 169 0 5 0 0 45 1 53 37 51 17 1 175 254 219 1 37 3 101 160 3 161 254 188 0 0 0 0 2 0 117 0 79 1 190 1 190 0 5 0 8 0 0 45 1 53 37 51 17 39 53 7 1 188 254 185 1 71 2 43 201 79 182 3 182 254 145 75 217 108 0 0 2 0 152 0 115 1 192 1 153 0 3 0 23 0 0 55 17 33 17 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 152 1 40 148 29 50 36 21 21 36 50 29 29 50 36 21 21 36 50 115 1 38 254 218 12 20 36 50 29 29 50 36 20 20 36 50 29 29 50 36 20 0 0 0 0 1 0 0 0 196 2 88 1 52 0 3 0 0 61 1 33 21 2 88 196 112 112 0 0 1 0 60 255 116 2 28 255 187 0 3 0 13 0 187 0 2 0 1 0 3 0 4 43 48 49 23 53 33 21 60 1 224 140 71 71 0 0 0 0 2 0 60 255 3 2 28 255 187 0 3 0 7 0 0 23 53 33 21 5 53 33 21 60 1 224 254 32 1 224 131 62 62 122 61 61 0 0 0 0 1 0 62 2 65 2 26 2 119 0 3 0 0 19 53 33 21 62 1 220 2 65 54 54 0 0 0 0 1 255 102 255 23 2 242 255 192 0 13 0 0 5 34 38 39 55 30 1 51 50 54 55 23 14 1 1 44 128 225 101 24 96 225 109 109 225 96 24 101 225 233 65 63 41 58 53 53 58 41 63 65 0 0 0 1 0 208 255 80 1 222 2 220 0 13 0 11 0 186 0 6 0 0 0 3 43 48 49 5 46 1 53 52 54 55 23 14 1 21 20 22 23 1 177 104 121 121 104 45 101 95 95 101 176 81 228 145 145 228 81 42 85 200 127 127 200 85 0 1 0 122 255 80 1 136 2 220 0 13 0 11 0 186 0 8 0 0 0 3 43 48 49 23 39 62 1 53 52 38 39 55 30 1 21 20 6 167 45 101 95 95 101 45 104 121 121 176 42 85 200 127 127 200 85 42 81 228 145 145 228 0 0 1 0 225 255 104 1 246 2 196 0 7 0 23 0 187 0 6 0 1 0 7 0 4 43 187 0 2 0 1 0 3 0 4 43 48 49 23 17 33 21 35 17 51 21 225 1 21 211 211 152 3 92 47 253 2 47 0 0 0 0 1 0 98 255 104 1 119 2 196 0 7 0 23 0 187 0 1 0 1 0 0 0 4 43 187 0 5 0 1 0 4 0 4 43 48 49 23 53 51 17 35 53 33 17 98 211 211 1 21 152 47 2 254 47 252 164 0 0 0 0 1 0 120 255 104 1 246 2 196 0 57 0 43 0 187 0 16 0 1 0 15 0 4 43 187 0 56 0 1 0 57 0 4 43 187 0 30 0 1 0 31 0 4 43 186 0 44 0 15 0 16 17 18 57 48 49 5 34 46 2 53 52 62 2 53 52 46 2 35 53 50 62 2 53 52 38 53 52 62 2 59 1 21 35 34 14 2 21 20 22 21 20 6 7 21 30 1 21 20 6 21 20 30 2 59 1 21 1 185 47 70 46 22 3 3 3 12 32 57 44 44 57 32 12 9 22 46 70 47 61 52 38 49 27 10 6 39 52 52 39 6 10 27 49 38 52 152 13 30 51 39 27 49 46 46 25 15 27 22 14 52 14 22 27 15 48 93 52 39 51 30 13 47 10 22 35 24 43 91 47 49 51 9 4 9 51 49 51 84 46 24 35 22 10 47 0 1 0 99 255 104 1 224 2 196 0 57 0 43 0 187 0 41 0 1 0 42 0 4 43 187 0 1 0 1 0 0 0 4 43 187 0 27 0 1 0 26 0 4 43 186 0 14 0 42 0 41 17 18 57 48 49 23 53 51 50 62 2 53 52 38 53 52 54 55 53 46 1 53 52 54 53 52 46 2 43 1 53 51 50 30 2 21 20 6 21 20 30 2 51 21 34 14 2 21 20 30 2 21 20 14 2 35 99 51 38 49 28 10 6 38 52 52 38 6 10 28 49 38 51 61 47 69 46 22 9 12 32 57 44 44 57 32 12 3 3 3 22 46 69 47 152 47 10 22 35 24 46 84 51 49 51 9 4 9 51 49 47 91 43 24 35 22 10 47 13 30 51 39 52 93 48 15 27 22 14 52 14 22 27 15 25 46 46 49 27 39 51 30 13 0 0 1 0 99 255 96 1 245 2 198 0 3 0 24 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 15 62 89 184 0 3 220 48 49 23 1 51 1 99 1 72 74 254 184 160 3 102 252 154 0 0 0 0 1 1 7 255 6 1 81 2 238 0 3 0 11 0 186 0 2 0 3 0 3 43 48 49 5 17 51 17 1 7 74 250 3 232 252 24 0 0 0 0 1 0 99 255 96 1 245 2 198 0 3 0 24 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 15 62 89 184 0 3 220 48 49 5 1 51 1 1 171 254 184 74 1 72 160 3 102 252 154 0 0 0 2 1 7 255 6 1 81 2 238 0 3 0 7 0 11 0 186 0 6 0 3 0 3 43 48 49 5 17 51 17 3 17 51 17 1 7 74 74 74 250 1 184 254 72 2 48 1 184 254 72 0 0 1 0 84 0 111 2 4 2 44 0 14 0 47 0 184 0 0 47 186 0 2 0 0 0 6 17 18 57 184 0 2 16 185 0 5 0 1 244 184 0 8 208 184 0 2 16 184 0 11 208 184 0 0 16 184 0 13 208 48 49 55 39 55 39 55 23 55 51 23 55 23 7 23 7 39 180 42 108 162 16 167 9 48 9 167 16 162 108 42 120 111 30 165 70 46 55 189 189 55 46 70 165 30 159 0 0 0 0 1 0 127 255 176 1 217 2 200 0 11 0 37 0 187 0 4 0 1 0 1 0 4 43 184 0 4 16 184 0 6 220 184 0 4 16 184 0 7 208 184 0 1 16 184 0 10 208 48 49 5 19 7 53 23 39 51 7 55 21 39 19 1 9 5 143 143 5 70 5 143 143 5 80 2 59 5 71 5 160 160 5 71 5 253 197 0 0 1 0 127 255 176 1 217 2 200 0 21 0 71 0 187 0 9 0 1 0 6 0 4 43 187 0 4 0 1 0 1 0 4 43 184 0 9 16 184 0 11 220 184 0 9 16 184 0 12 208 184 0 6 16 184 0 15 208 184 0 4 16 184 0 17 208 184 0 1 16 184 0 20 208 184 0 1 16 184 0 21 220 48 49 5 55 7 53 23 39 55 7 53 23 39 51 7 55 21 39 23 7 55 21 39 23 1 9 5 143 143 5 5 143 143 5 70 5 143 143 5 5 143 143 5 80 160 5 71 7 177 177 7 71 5 160 160 5 71 7 177 177 7 71 5 160 0 0 2 0 91 255 192 1 253 2 172 0 55 0 71 0 63 0 187 0 7 0 1 0 0 0 4 43 187 0 28 0 1 0 35 0 4 43 186 0 69 0 28 0 0 17 18 57 186 0 20 0 38 0 69 17 18 57 186 0 61 0 0 0 28 17 18 57 186 0 48 0 61 0 10 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 46 4 53 52 54 55 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 30 4 21 20 6 7 30 1 21 20 14 2 3 20 30 2 23 62 1 53 52 46 2 39 14 1 1 31 55 92 32 50 26 61 42 41 45 42 62 74 62 42 51 40 14 17 19 38 56 38 50 81 30 40 26 56 35 42 38 42 63 73 63 42 49 42 14 16 24 42 59 161 41 63 73 32 32 35 41 62 73 32 31 37 64 38 33 45 24 28 40 29 28 38 30 29 42 61 46 45 64 21 16 39 26 26 47 36 21 34 23 53 20 26 37 26 27 36 30 30 43 61 46 48 60 22 16 39 26 30 50 36 21 1 156 33 43 33 28 19 14 38 34 34 44 33 29 18 16 41 0 0 0 0 2 0 72 255 176 1 229 2 144 0 12 0 16 0 0 37 34 46 2 53 52 62 2 59 1 17 19 17 51 17 1 62 53 90 66 37 36 63 86 50 43 54 81 226 25 53 82 57 59 81 51 22 254 82 254 206 2 224 253 32 0 0 0 255 255 0 157 255 6 1 188 2 238 2 38 3 185 150 0 0 6 3 185 107 0 0 0 255 255 0 94 255 244 1 238 2 158 2 39 3 135 255 123 0 0 0 6 3 135 121 0 0 4 0 14 255 244 2 59 2 170 0 29 0 41 0 71 0 83 0 95 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 13 62 89 184 0 0 69 88 184 0 30 47 27 185 0 30 0 3 62 89 184 0 36 220 184 0 0 220 184 0 17 16 185 0 10 0 1 244 184 0 0 16 184 0 42 208 184 0 10 16 184 0 52 208 184 0 17 16 184 0 59 208 184 0 30 16 184 0 72 208 184 0 36 16 184 0 78 208 48 49 55 38 62 4 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 4 23 7 34 38 53 52 54 51 50 22 21 20 6 55 38 62 4 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 4 23 7 34 38 53 52 54 51 50 22 21 20 6 102 6 11 25 31 29 19 36 37 24 39 20 41 29 68 42 31 51 36 20 20 30 34 27 14 5 25 30 43 43 30 30 43 43 206 6 11 25 31 29 19 36 37 24 39 20 41 29 68 42 31 51 36 20 20 30 34 27 14 5 25 30 43 43 30 30 43 43 232 35 57 50 43 44 47 27 33 46 22 26 49 33 34 20 35 49 28 35 57 48 45 47 53 33 244 42 36 35 41 41 35 36 42 244 35 57 50 43 44 47 27 33 46 22 26 49 33 34 20 35 49 28 35 57 48 45 47 53 33 244 42 36 35 41 41 35 36 42 0 0 4 0 87 255 244 2 59 2 170 0 29 0 41 0 47 0 59 0 83 0 184 0 0 69 88 184 0 44 47 27 185 0 44 0 13 62 89 184 0 0 69 88 184 0 48 47 27 185 0 48 0 3 62 89 184 0 54 220 184 0 42 220 184 0 0 208 184 0 44 16 184 0 17 208 184 0 17 47 185 0 10 0 1 244 184 0 48 16 184 0 30 208 184 0 54 16 184 0 36 208 48 49 37 38 62 4 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 4 23 7 34 38 53 52 54 51 50 22 21 20 6 37 3 39 51 7 3 7 34 38 53 52 54 51 50 22 21 20 6 1 126 6 11 25 31 29 19 36 37 24 39 20 41 29 68 42 31 51 36 20 20 30 34 27 14 5 25 30 43 43 30 30 43 43 254 188 10 2 80 2 10 28 30 43 43 30 30 43 43 232 35 57 50 43 44 47 27 33 46 22 26 49 33 34 20 35 49 28 35 57 48 45 47 53 33 244 42 36 35 41 41 35 36 42 244 1 88 94 94 254 168 244 42 36 35 41 41 35 36 42 0 0 0 0 4 0 14 255 244 2 1 2 170 0 29 0 41 0 47 0 59 0 74 0 184 0 44 47 184 0 0 69 88 184 0 30 47 27 185 0 30 0 3 62 89 184 0 36 220 184 0 0 220 184 0 44 16 184 0 17 208 184 0 17 47 185 0 10 0 1 244 184 0 0 16 184 0 42 208 184 0 30 16 184 0 48 208 184 0 36 16 184 0 54 208 48 49 55 38 62 4 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 4 23 7 34 38 53 52 54 51 50 22 21 20 6 55 3 39 51 7 3 7 34 38 53 52 54 51 50 22 21 20 6 102 6 11 25 31 29 19 36 37 24 39 20 41 29 68 42 31 51 36 20 20 30 34 27 14 5 25 30 43 43 30 30 43 43 236 10 2 80 2 10 28 30 43 43 30 30 43 43 232 35 57 50 43 44 47 27 33 46 22 26 49 33 34 20 35 49 28 35 57 48 45 47 53 33 244 42 36 35 41 41 35 36 42 244 1 88 94 94 254 168 244 42 36 35 41 41 35 36 42 0 0 0 2 0 94 255 244 1 228 2 170 0 31 0 43 0 69 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 13 62 89 184 0 0 69 88 184 0 32 47 27 185 0 32 0 3 62 89 184 0 38 220 184 0 0 220 184 0 19 16 185 0 13 0 1 244 184 0 2 220 186 0 5 0 19 0 0 17 18 57 48 49 55 47 1 51 15 1 62 3 53 52 38 35 34 7 39 62 1 51 50 30 2 21 20 14 4 23 7 34 38 53 52 54 51 50 22 21 20 6 254 11 4 70 1 3 15 36 30 21 63 61 80 61 48 35 101 59 44 72 51 28 27 40 46 38 24 3 30 28 41 41 28 29 41 41 232 224 76 76 107 19 34 37 44 29 45 60 63 44 38 46 23 42 58 34 40 57 45 37 39 45 30 244 41 34 34 41 41 34 34 41 0 0 2 0 116 255 60 1 250 1 242 0 31 0 43 0 73 0 184 0 0 69 88 184 0 32 47 27 185 0 32 0 7 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 184 0 32 16 184 0 38 220 184 0 0 220 184 0 19 16 185 0 13 0 1 244 184 0 2 220 186 0 5 0 0 0 19 17 18 57 48 49 37 31 1 35 63 1 14 3 21 20 22 51 50 55 23 14 1 35 34 46 2 53 52 62 4 39 55 50 22 21 20 6 35 34 38 53 52 54 1 90 11 4 70 1 3 15 36 30 21 63 61 80 61 48 35 101 59 44 72 51 28 27 40 46 38 24 3 30 28 41 41 28 29 41 41 254 224 76 76 107 19 34 37 44 29 45 60 63 44 38 46 23 42 58 34 39 58 45 37 39 45 30 244 41 34 34 41 41 34 34 41 0 1 0 225 0 0 1 246 2 183 0 5 0 13 0 187 0 3 0 1 0 2 0 4 43 48 49 51 17 33 21 35 17 225 1 21 211 2 183 47 253 120 0 0 0 1 0 98 0 0 1 119 2 183 0 5 0 13 0 187 0 2 0 1 0 3 0 4 43 48 49 33 17 35 53 33 17 1 53 211 1 21 2 136 47 253 73 0 0 1 0 225 255 170 1 246 2 126 0 5 0 13 0 187 0 5 0 1 0 4 0 4 43 48 49 23 17 51 17 51 21 225 66 211 86 2 212 253 91 47 0 0 0 1 0 98 255 170 1 119 2 126 0 5 0 13 0 187 0 0 0 1 0 1 0 4 43 48 49 23 53 51 17 51 17 98 211 66 86 47 2 165 253 44 0 0 0 2 0 186 255 104 1 246 2 196 0 7 0 11 0 23 0 187 0 3 0 1 0 2 0 4 43 187 0 7 0 1 0 6 0 4 43 48 49 23 17 33 21 35 17 51 21 37 51 17 35 186 1 60 172 172 254 248 43 43 152 3 92 47 253 2 47 47 2 254 0 0 0 2 0 98 255 104 1 158 2 196 0 7 0 11 0 23 0 187 0 4 0 1 0 5 0 4 43 187 0 0 0 1 0 1 0 4 43 48 49 23 53 51 17 35 53 33 17 39 51 17 35 98 172 172 1 60 95 43 43 152 47 2 254 47 252 164 47 2 254 0 0 0 0 1 0 226 1 22 1 246 2 196 0 5 0 13 0 187 0 3 0 1 0 2 0 4 43 48 49 19 17 33 21 35 17 226 1 20 211 1 22 1 174 47 254 129 0 1 0 98 1 22 1 119 2 183 0 5 0 13 0 187 0 2 0 1 0 3 0 4 43 48 49 1 17 35 53 33 17 1 53 211 1 21 1 22 1 114 47 254 95 0 0 0 0 1 0 225 255 104 1 246 1 22 0 5 0 13 0 187 0 5 0 1 0 4 0 4 43 48 49 23 17 51 17 51 21 225 66 211 152 1 174 254 129 47 0 0 0 1 0 98 255 104 1 119 1 22 0 5 0 13 0 187 0 0 0 1 0 1 0 4 43 48 49 23 53 51 17 51 17 98 211 66 152 47 1 127 254 82 0 0 0 3 0 30 255 245 2 58 2 141 0 19 0 39 0 69 0 85 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 20 0 1 244 184 0 10 16 185 0 30 0 1 244 184 0 20 16 184 0 40 208 184 0 30 16 184 0 50 208 185 0 57 0 1 244 184 0 40 16 185 0 63 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 55 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 23 14 1 1 44 57 99 73 41 41 73 99 57 57 99 73 41 41 73 99 57 50 83 59 32 32 59 83 50 50 83 59 32 32 59 83 58 34 59 44 25 27 46 59 33 35 49 20 34 16 31 20 46 56 53 45 26 38 17 30 23 52 11 47 87 123 77 76 123 85 46 46 85 123 76 77 123 87 47 42 42 77 107 66 66 106 76 41 41 76 106 66 66 107 77 42 94 27 51 73 47 43 70 50 26 27 20 39 14 17 75 59 66 77 20 14 42 20 27 0 0 4 0 30 255 245 2 58 2 141 0 19 0 39 0 54 0 63 0 89 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 56 0 1 0 52 0 4 43 184 0 0 16 185 0 20 0 1 244 184 0 10 16 185 0 30 0 1 244 184 0 42 208 184 0 20 16 184 0 54 208 184 0 42 16 185 0 62 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 39 17 51 50 30 2 21 20 14 2 43 1 21 53 51 50 54 53 52 38 43 1 1 44 57 99 73 41 41 73 99 57 57 99 73 41 41 73 99 57 50 83 59 32 32 59 83 50 50 83 59 32 32 59 83 57 114 28 50 37 21 21 37 50 28 49 39 39 42 43 38 39 11 47 87 123 77 76 123 85 46 46 85 123 76 77 123 87 47 42 42 77 107 66 66 106 76 41 41 76 106 66 66 107 77 42 106 1 107 14 28 45 30 33 49 33 16 115 165 37 42 36 32 0 4 0 112 1 63 1 232 2 201 0 19 0 39 0 53 0 62 0 61 0 187 0 20 0 1 0 0 0 4 43 187 0 10 0 1 0 30 0 4 43 187 0 55 0 1 0 51 0 4 43 184 0 30 16 184 0 42 208 184 0 51 16 184 0 48 208 184 0 20 16 184 0 53 208 184 0 50 208 48 49 1 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 39 53 51 50 22 21 20 6 7 23 35 39 35 21 53 51 50 54 53 52 38 43 1 1 44 39 69 51 29 29 51 69 39 39 68 51 30 30 51 68 39 31 55 39 23 23 39 55 31 32 54 40 23 23 40 54 41 76 32 47 21 17 46 46 35 41 26 20 24 19 23 28 1 63 29 52 72 44 44 72 52 29 29 52 72 44 44 72 52 29 37 23 42 59 36 35 59 43 24 24 43 59 35 36 59 42 23 61 203 29 36 18 31 6 83 70 70 102 17 17 15 18 0 0 2 255 251 1 110 2 68 2 164 0 7 0 27 0 85 0 184 0 7 47 187 0 3 0 1 0 2 0 4 43 187 0 13 0 1 0 22 0 4 43 184 0 2 16 184 0 5 208 184 0 7 16 184 0 8 208 184 0 3 16 184 0 9 208 184 0 3 16 184 0 15 208 184 0 10 208 184 0 8 16 184 0 18 208 184 0 15 16 185 0 21 0 1 244 184 0 24 208 48 49 19 17 35 53 51 21 35 17 51 17 51 31 1 51 63 1 51 17 35 53 55 35 7 35 39 35 23 21 91 96 252 96 141 71 45 27 4 26 44 71 55 7 4 71 42 72 4 7 1 110 1 0 54 54 255 0 1 54 114 80 80 114 254 202 137 105 187 187 105 137 0 0 2 0 15 1 98 2 68 2 171 0 41 0 61 0 95 0 184 0 0 47 187 0 20 0 1 0 27 0 4 43 187 0 47 0 1 0 56 0 4 43 184 0 0 16 185 0 7 0 1 244 184 0 0 16 184 0 42 208 184 0 20 16 184 0 43 208 184 0 43 47 184 0 20 16 184 0 49 208 184 0 49 47 184 0 44 208 184 0 42 16 184 0 52 208 184 0 49 16 185 0 55 0 1 244 184 0 58 208 48 49 19 34 38 39 55 30 1 51 50 54 53 52 38 47 1 46 1 53 52 54 51 50 22 23 7 46 1 35 34 6 21 20 22 31 1 30 1 21 20 14 2 55 17 51 31 1 51 63 1 51 17 35 53 55 35 7 35 39 35 23 21 125 33 54 23 33 19 37 25 23 26 19 23 46 22 37 56 48 28 50 17 30 15 35 17 23 24 21 20 46 29 32 15 28 41 142 71 45 27 4 26 44 71 55 7 4 71 42 72 4 7 1 98 25 23 37 17 21 21 18 20 15 11 24 11 39 35 39 49 22 16 39 12 18 23 15 15 19 9 23 14 38 35 18 32 26 15 12 1 54 114 80 80 114 254 202 137 105 187 187 105 137 0 0 0 0 2 0 49 255 112 2 34 2 123 0 52 0 61 0 85 0 187 0 46 0 1 0 0 0 4 43 187 0 10 0 1 0 36 0 4 43 187 0 53 0 1 0 22 0 4 43 184 0 22 16 184 0 17 208 184 0 17 47 186 0 18 0 22 0 10 17 18 57 186 0 56 0 10 0 22 17 18 57 184 0 56 16 185 0 30 0 1 244 184 0 18 16 185 0 55 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 17 35 39 35 14 1 35 34 46 2 53 52 54 55 53 52 46 2 35 34 14 2 21 20 30 2 51 50 54 55 23 14 1 3 50 55 53 14 1 21 20 22 1 85 59 106 80 47 45 80 107 62 52 76 50 25 50 7 4 22 71 39 27 47 35 20 136 128 17 36 57 39 45 82 63 37 36 62 84 49 45 67 29 28 39 82 21 56 56 104 88 43 144 51 99 148 96 96 144 96 49 36 64 87 51 254 215 58 28 42 18 34 49 30 77 78 16 14 36 64 48 28 42 83 125 83 80 125 86 45 23 22 45 27 28 1 34 64 126 14 55 46 35 40 0 0 0 2 0 49 255 238 2 34 2 156 0 52 0 61 0 119 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 53 0 1 0 22 0 4 43 184 0 22 16 184 0 17 208 184 0 17 47 186 0 18 0 22 0 10 17 18 57 186 0 56 0 10 0 22 17 18 57 184 0 56 16 185 0 30 0 1 244 184 0 10 16 185 0 36 0 1 244 184 0 0 16 185 0 46 0 1 244 184 0 18 16 185 0 55 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 17 35 39 35 14 1 35 34 46 2 53 52 54 55 53 52 46 2 35 34 14 2 21 20 30 2 51 50 54 55 23 14 1 39 50 55 53 14 1 21 20 22 1 85 59 106 80 47 46 80 109 62 51 75 50 24 50 7 4 22 71 39 27 47 35 20 136 128 17 36 55 38 45 84 63 38 36 62 84 49 45 67 29 28 39 82 21 56 56 104 88 43 18 44 86 127 84 86 129 87 43 32 56 75 42 254 222 58 29 41 18 34 49 30 76 79 16 10 28 51 38 23 37 73 110 73 68 105 72 38 23 22 45 26 29 237 64 126 15 54 47 35 39 0 0 2 0 87 0 0 2 7 2 138 0 27 0 31 0 91 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 11 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 11 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 3 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 7 0 1 0 6 0 4 43 187 0 11 0 1 0 10 0 4 43 48 49 33 55 35 7 35 55 35 53 51 55 35 53 51 55 51 7 51 55 51 7 51 21 35 7 51 21 35 7 3 55 35 7 1 72 25 132 25 54 25 80 87 18 85 92 23 53 22 132 23 53 22 80 87 18 85 92 25 22 18 132 18 204 204 204 57 148 58 183 183 183 183 58 148 57 204 1 5 148 148 0 0 0 1 0 104 1 60 1 240 2 200 0 14 0 62 0 184 0 0 47 184 0 0 69 88 184 0 6 47 27 185 0 6 0 15 62 89 186 0 2 0 6 0 0 17 18 57 184 0 2 16 184 0 5 220 184 0 8 208 184 0 0 16 184 0 13 208 184 0 2 16 184 0 14 220 48 49 19 39 55 39 55 23 55 51 23 55 23 7 23 7 39 197 42 92 143 16 147 9 48 9 147 16 143 92 42 103 1 60 29 147 57 46 44 161 159 42 46 57 147 29 140 0 0 0 0 1 0 134 0 216 1 210 1 32 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 55 53 33 21 134 1 76 216 72 72 0 0 0 255 255 0 134 0 216 1 210 1 32 2 6 3 219 0 0 255 255 0 134 0 216 1 210 1 32 2 6 3 219 0 0 0 3 0 85 255 143 2 3 2 239 0 9 0 19 0 67 0 97 0 187 0 10 0 1 0 20 0 4 43 187 0 58 0 1 0 16 0 4 43 187 0 7 0 1 0 44 0 4 43 184 0 58 16 184 0 3 208 184 0 20 16 184 0 25 220 184 0 20 16 184 0 26 208 184 0 10 16 184 0 33 208 184 0 16 16 184 0 34 208 184 0 44 16 184 0 49 220 184 0 44 16 184 0 50 208 184 0 7 16 184 0 57 208 48 49 19 20 22 23 55 38 34 35 34 6 19 50 54 53 52 38 39 7 22 50 7 42 1 39 7 39 55 46 1 39 55 30 1 23 55 46 3 53 52 62 2 51 58 1 23 55 23 7 30 1 23 7 46 1 39 7 30 3 21 20 14 2 190 56 42 31 5 9 5 51 59 124 59 62 63 45 34 5 11 5 6 12 6 27 56 28 42 72 26 39 25 57 32 36 31 59 46 28 29 52 72 43 7 12 6 25 56 25 33 52 23 44 20 37 20 33 32 62 50 30 31 55 78 1 211 30 38 16 166 1 45 254 109 49 38 36 44 18 184 1 68 1 148 6 151 11 36 22 57 17 31 9 195 12 28 36 48 33 35 57 40 21 1 134 7 137 10 34 22 48 15 23 7 175 12 29 39 52 36 36 59 43 23 0 0 255 255 0 141 1 127 1 203 3 29 2 7 3 237 0 0 2 60 0 0 255 255 0 175 1 139 1 220 3 17 2 7 3 238 0 0 2 60 0 0 255 255 0 146 1 139 1 190 3 29 2 7 3 239 0 0 2 60 0 0 255 255 0 142 1 127 1 189 3 29 2 7 3 240 0 0 2 60 0 0 255 255 0 148 1 139 1 206 3 29 2 7 3 241 0 0 2 60 0 0 255 255 0 142 1 127 1 193 3 17 2 7 3 242 0 0 2 60 0 0 255 255 0 151 1 127 1 196 3 29 2 7 3 243 0 0 2 60 0 0 255 255 0 156 1 139 1 193 3 17 2 7 3 244 0 0 2 60 0 0 255 255 0 151 1 127 1 190 3 29 2 7 3 245 0 0 2 60 0 0 255 255 0 145 1 127 1 191 3 29 2 7 3 246 0 0 2 60 0 0 255 255 0 236 1 60 1 133 3 94 2 7 3 247 0 0 2 60 0 0 255 255 0 211 1 60 1 108 3 94 2 7 3 248 0 0 2 60 0 0 255 255 0 251 1 128 1 93 1 228 2 7 3 249 0 0 2 60 0 0 255 255 0 244 1 22 1 103 1 228 2 7 3 250 0 0 2 60 0 0 0 2 0 141 255 67 1 203 0 225 0 11 0 23 0 23 0 187 0 18 0 1 0 6 0 4 43 187 0 0 0 1 0 12 0 4 43 48 49 5 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 1 44 72 87 87 72 72 87 87 72 43 54 54 43 43 54 54 189 108 100 99 107 107 99 100 108 51 78 79 78 77 77 78 79 78 0 0 0 1 0 175 255 79 1 220 0 213 0 12 0 31 0 187 0 1 0 1 0 0 0 4 43 187 0 4 0 1 0 9 0 4 43 184 0 1 16 184 0 11 208 48 49 23 53 51 53 35 53 62 1 55 51 17 51 21 175 123 105 41 53 23 52 114 177 54 254 41 6 18 17 254 176 54 0 1 0 146 255 79 1 190 0 225 0 26 0 31 0 187 0 25 0 1 0 0 0 4 43 187 0 9 0 1 0 16 0 4 43 184 0 25 16 184 0 1 208 48 49 23 39 62 3 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 14 2 7 51 21 162 4 50 77 52 26 46 39 28 49 17 38 23 75 43 63 77 25 44 60 36 184 177 37 43 65 54 45 22 38 44 32 25 35 35 41 64 63 28 51 52 56 34 54 0 0 0 0 1 0 142 255 67 1 189 0 225 0 41 0 43 0 187 0 7 0 1 0 0 0 4 43 187 0 19 0 1 0 26 0 4 43 187 0 12 0 1 0 13 0 4 43 186 0 34 0 13 0 12 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 35 53 50 54 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 30 1 21 20 14 2 1 41 51 81 23 42 19 57 33 36 52 131 60 56 43 37 25 48 17 38 26 67 44 27 49 37 22 39 40 43 51 23 41 54 189 42 34 33 29 29 36 33 70 40 41 30 28 34 26 22 34 31 34 15 27 39 24 35 46 15 8 50 38 27 43 31 16 0 1 0 148 255 79 1 206 0 225 0 14 0 45 0 184 0 0 47 184 0 4 47 187 0 7 0 1 0 1 0 4 43 184 0 7 16 184 0 3 208 184 0 7 16 184 0 11 208 184 0 1 16 184 0 12 208 48 49 5 53 35 53 19 23 7 51 53 51 21 51 21 35 21 1 90 198 154 47 132 129 58 58 58 177 104 33 1 9 25 227 116 116 46 104 0 0 1 0 142 255 67 1 193 0 213 0 33 0 33 0 187 0 6 0 1 0 0 0 4 43 187 0 24 0 1 0 12 0 4 43 187 0 17 0 1 0 19 0 4 43 48 49 5 34 38 39 55 22 51 50 54 53 52 38 35 34 6 7 39 55 51 21 35 7 62 1 51 50 30 2 21 20 14 2 1 43 55 78 24 42 40 71 39 51 54 42 25 37 17 32 19 232 180 10 16 37 19 28 51 37 22 23 40 55 189 42 34 33 58 48 38 40 46 18 14 22 189 56 96 8 7 17 33 49 32 30 49 36 19 0 0 0 2 0 151 255 67 1 196 0 225 0 27 0 39 0 43 0 187 0 28 0 1 0 0 0 4 43 187 0 8 0 1 0 15 0 4 43 186 0 20 0 8 0 0 17 18 57 184 0 20 16 185 0 34 0 1 244 48 49 5 34 38 53 52 62 2 51 50 22 23 7 46 1 35 34 6 7 54 51 50 22 21 20 14 2 39 50 54 53 52 38 35 34 6 7 30 1 1 57 75 87 28 48 66 38 38 48 20 27 16 37 24 48 68 5 44 64 64 68 21 38 50 31 35 46 43 42 25 47 24 5 53 189 104 92 55 82 54 27 17 14 44 11 13 72 75 41 69 56 28 48 36 20 51 44 36 35 44 18 26 57 58 0 0 0 1 0 156 255 79 1 193 0 213 0 14 0 17 0 184 0 0 47 187 0 5 0 1 0 7 0 4 43 48 49 23 62 3 55 35 53 33 21 14 3 7 247 3 19 31 46 31 221 1 37 37 49 30 15 3 177 51 85 80 77 42 55 36 47 84 84 88 51 0 0 0 0 3 0 151 255 67 1 190 0 225 0 25 0 37 0 51 0 53 0 187 0 38 0 1 0 0 0 4 43 187 0 32 0 1 0 13 0 4 43 187 0 46 0 1 0 26 0 4 43 186 0 6 0 26 0 46 17 18 57 186 0 20 0 46 0 26 17 18 57 48 49 5 34 38 53 52 54 55 53 46 1 53 52 54 51 50 22 21 20 6 7 21 30 1 21 20 6 39 62 1 53 52 38 35 34 6 21 20 22 23 50 54 53 52 46 2 39 14 1 21 20 22 1 43 72 76 45 39 33 35 72 60 62 72 40 29 42 40 78 46 31 21 41 35 34 38 54 19 42 45 18 31 40 22 35 29 43 189 62 45 38 55 17 4 20 38 32 46 57 55 48 35 44 15 4 19 48 37 47 62 234 20 34 20 26 31 31 25 29 32 202 39 27 18 24 18 15 9 18 41 25 26 40 0 0 2 0 145 255 67 1 191 0 225 0 11 0 39 0 43 0 187 0 19 0 1 0 12 0 4 43 187 0 32 0 1 0 6 0 4 43 186 0 24 0 32 0 12 17 18 57 184 0 24 16 185 0 0 0 1 244 48 49 37 50 54 55 46 1 35 34 6 21 20 22 23 34 38 39 55 30 1 51 50 54 55 6 35 34 38 53 52 62 2 51 50 22 21 20 14 2 1 34 25 46 24 5 53 41 35 46 43 19 38 50 18 26 16 38 24 48 67 5 44 64 63 69 21 38 51 30 74 88 28 48 66 14 18 25 58 59 45 35 35 45 203 17 13 45 11 13 71 75 40 69 55 28 49 36 20 104 93 55 82 54 26 0 0 0 1 0 236 255 0 1 133 1 34 0 17 0 0 1 46 3 53 52 62 2 55 23 14 1 21 20 22 23 1 88 29 41 26 12 12 26 41 29 45 53 38 38 53 255 0 33 61 65 72 42 42 71 65 62 33 26 62 119 66 66 118 63 0 0 1 0 211 255 0 1 108 1 34 0 17 0 0 1 39 62 1 53 52 38 39 55 30 3 21 20 14 2 1 1 46 53 38 38 53 46 28 41 26 12 12 26 41 255 0 26 63 118 66 66 119 62 26 33 62 65 71 42 42 72 65 61 0 0 1 0 251 255 68 1 93 255 168 0 11 0 13 0 187 0 6 0 1 0 0 0 4 43 48 49 5 34 38 53 52 54 51 50 22 21 20 6 1 44 20 29 29 20 20 29 29 188 27 23 23 27 27 23 23 27 0 0 0 0 1 0 244 254 218 1 103 255 168 0 17 0 27 0 187 0 12 0 1 0 6 0 4 43 184 0 6 16 184 0 1 220 185 0 0 0 1 244 48 49 1 39 62 1 39 6 35 34 38 53 52 54 51 50 22 21 20 6 1 6 18 30 35 1 2 5 19 29 29 20 26 31 52 254 218 39 11 38 27 1 21 23 23 25 38 37 45 69 0 0 0 0 2 0 161 255 244 1 183 1 61 0 11 0 23 0 40 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 6 0 1 0 18 0 4 43 184 0 0 16 185 0 12 0 1 244 48 49 5 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 1 44 61 78 78 61 61 78 78 61 32 46 46 32 32 46 46 12 88 78 78 85 85 78 78 88 50 57 59 60 54 54 60 59 57 0 0 1 0 208 0 0 1 97 1 49 0 8 0 30 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 6 0 1 0 1 0 4 43 48 49 33 53 35 53 62 1 55 51 17 1 34 82 33 41 21 50 230 42 5 16 12 254 207 0 0 1 0 173 0 0 1 166 1 61 0 24 0 44 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 3 62 89 187 0 14 0 1 0 7 0 4 43 184 0 24 16 185 0 22 0 1 244 184 0 1 208 48 49 51 53 62 1 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 14 2 7 51 21 183 78 83 31 29 20 38 14 39 23 59 36 54 62 19 33 44 25 136 36 59 78 33 27 32 23 19 33 26 35 53 50 20 39 39 41 22 53 0 1 0 172 255 244 1 164 1 61 0 36 0 60 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 13 0 1 0 12 0 4 43 187 0 26 0 1 0 19 0 4 43 184 0 0 16 185 0 7 0 1 244 186 0 31 0 13 0 12 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 35 53 50 54 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 7 30 1 21 20 6 1 43 35 67 25 32 15 49 27 27 35 96 42 39 26 29 18 40 15 30 19 61 35 47 59 56 32 39 70 12 28 26 39 18 25 22 25 51 38 28 23 20 23 19 15 38 20 25 44 40 55 20 8 38 31 45 48 0 1 0 172 0 0 1 185 1 61 0 14 0 58 0 184 0 4 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 7 0 1 0 1 0 4 43 184 0 7 16 184 0 3 208 184 0 7 16 184 0 11 208 184 0 1 16 184 0 12 208 48 49 33 53 35 53 55 23 7 51 53 51 21 51 21 35 21 1 78 162 113 46 97 100 57 50 50 74 31 212 20 181 97 97 42 74 0 0 0 1 0 172 255 244 1 169 1 49 0 29 0 68 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 19 0 1 0 20 0 4 43 187 0 24 0 1 0 13 0 4 43 184 0 0 16 185 0 7 0 1 244 186 0 22 0 13 0 24 17 18 57 184 0 22 16 184 0 17 208 48 49 5 34 38 39 55 30 1 51 50 54 53 52 38 35 34 6 7 39 55 51 21 35 7 54 51 50 22 21 20 6 1 45 42 60 27 32 17 45 30 29 37 36 31 20 29 15 31 17 189 139 10 24 32 50 62 70 12 28 26 39 18 25 30 27 29 29 12 11 20 155 54 70 12 51 48 48 58 0 0 2 0 176 255 244 1 173 1 61 0 26 0 37 0 70 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 6 0 1 0 13 0 4 43 187 0 19 0 1 0 33 0 4 43 186 0 16 0 0 0 6 17 18 57 184 0 0 16 185 0 27 0 1 244 184 0 16 16 185 0 35 0 1 244 48 49 5 34 38 53 52 54 51 50 22 23 7 46 1 35 34 6 7 62 1 51 50 22 21 20 14 2 39 50 54 53 52 38 35 34 7 30 1 1 57 59 78 85 69 30 44 19 26 14 30 20 43 51 4 19 45 27 51 52 17 31 43 26 28 30 28 31 40 35 6 44 12 81 71 86 91 18 14 41 11 13 59 57 17 18 53 42 21 38 29 16 50 29 25 23 30 35 38 34 0 1 0 183 0 0 1 170 1 49 0 14 0 38 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 8 0 1 0 5 0 4 43 184 0 5 16 184 0 9 208 48 49 51 62 3 55 35 53 51 21 14 3 7 253 2 13 24 36 24 169 243 32 40 24 10 2 39 65 59 58 31 53 36 35 63 63 68 40 0 3 0 175 255 244 1 169 1 61 0 31 0 43 0 56 0 60 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 17 0 1 0 38 0 4 43 184 0 0 16 185 0 44 0 1 244 186 0 41 0 17 0 44 17 18 57 186 0 47 0 0 0 38 17 18 57 48 49 5 34 46 2 53 52 54 55 53 46 1 53 52 62 2 51 50 22 21 20 6 7 21 30 1 21 20 14 2 39 62 1 53 52 38 35 34 6 21 20 22 23 50 54 53 52 46 2 39 6 21 20 22 1 44 28 46 33 18 39 26 23 31 18 31 42 23 50 65 33 20 26 37 19 34 45 7 20 16 29 27 25 30 44 11 26 41 15 24 31 17 47 39 12 14 24 32 18 32 37 12 4 14 31 27 18 31 23 12 47 37 28 33 11 4 11 37 33 18 32 24 14 189 12 26 15 18 24 23 17 22 24 153 25 20 14 19 13 10 5 22 37 20 27 0 0 0 2 0 173 255 244 1 169 1 61 0 11 0 36 0 70 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 3 62 89 187 0 31 0 1 0 6 0 4 43 187 0 0 0 1 0 25 0 4 43 186 0 22 0 31 0 12 17 18 57 184 0 22 16 185 0 3 0 1 244 184 0 12 16 185 0 19 0 1 244 48 49 37 50 54 55 46 1 35 34 6 21 20 22 23 34 38 39 55 30 1 51 50 54 55 14 1 35 34 38 53 52 54 51 50 22 21 20 6 1 34 20 35 19 5 44 26 27 31 28 12 29 45 19 26 14 31 20 42 50 4 19 45 26 51 51 64 51 59 78 85 161 15 18 39 35 30 25 23 29 173 19 14 40 11 12 57 57 16 18 53 42 44 60 81 71 86 91 0 0 0 1 0 236 255 180 1 131 1 139 0 13 0 0 5 46 1 53 52 54 55 23 14 1 21 20 22 23 1 85 50 55 55 50 46 45 40 40 45 76 49 111 75 75 111 50 33 45 99 59 59 99 45 0 0 0 0 1 0 213 255 180 1 108 1 139 0 13 0 0 5 39 62 1 53 52 38 39 55 30 1 21 20 6 1 3 46 45 40 40 45 46 50 55 55 76 32 45 99 59 59 99 45 33 50 111 75 75 111 0 0 0 0 1 0 251 255 245 1 93 0 90 0 11 0 13 0 187 0 6 0 1 0 0 0 4 43 48 49 5 34 38 53 52 54 51 50 22 21 20 6 1 44 20 29 29 20 20 29 29 11 27 23 23 28 28 23 23 27 0 0 0 0 1 0 244 255 139 1 103 0 90 0 17 0 40 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 3 62 89 184 0 1 220 185 0 0 0 1 244 184 0 6 16 185 0 12 0 1 244 48 49 5 39 62 1 39 6 35 34 38 53 52 54 51 50 22 21 20 6 1 6 18 30 35 1 2 5 19 29 29 20 26 31 52 117 39 11 38 27 1 21 23 23 26 38 38 45 69 0 0 0 255 255 0 161 1 20 1 183 2 93 2 7 3 251 0 0 1 32 0 0 255 255 0 208 1 32 1 97 2 81 2 7 3 252 0 0 1 32 0 0 255 255 0 173 1 32 1 166 2 93 2 7 3 253 0 0 1 32 0 0 255 255 0 172 1 20 1 164 2 93 2 7 3 254 0 0 1 32 0 0 255 255 0 172 1 32 1 185 2 93 2 7 3 255 0 0 1 32 0 0 255 255 0 172 1 20 1 169 2 81 2 7 4 0 0 0 1 32 0 0 255 255 0 176 1 20 1 173 2 93 2 7 4 1 0 0 1 32 0 0 255 255 0 183 1 32 1 170 2 81 2 7 4 2 0 0 1 32 0 0 255 255 0 175 1 20 1 169 2 93 2 7 4 3 0 0 1 32 0 0 255 255 0 173 1 20 1 169 2 93 2 7 4 4 0 0 1 32 0 0 255 255 0 236 0 212 1 131 2 171 2 7 4 5 0 0 1 32 0 0 255 255 0 213 0 212 1 108 2 171 2 7 4 6 0 0 1 32 0 0 255 255 0 251 1 21 1 93 1 122 2 7 4 7 0 0 1 32 0 0 255 255 0 244 0 171 1 103 1 122 2 7 4 8 0 0 1 32 0 0 255 255 0 163 1 131 1 190 2 212 2 6 4 26 0 0 255 255 0 137 1 131 1 182 2 212 2 6 4 59 0 0 255 255 0 142 1 131 1 202 2 212 2 6 4 40 0 0 0 2 0 163 1 131 1 190 2 212 0 25 0 35 0 0 1 34 38 53 52 54 55 46 1 35 34 6 7 39 62 1 51 50 22 29 1 35 39 35 14 1 39 50 54 55 53 14 1 21 20 22 1 13 45 61 106 113 2 32 41 29 54 23 25 26 75 41 65 63 53 4 2 25 60 17 26 47 24 86 71 36 1 131 49 43 53 57 9 31 44 20 14 43 16 26 71 63 195 38 20 26 49 21 19 83 8 37 29 26 23 0 0 2 0 172 1 131 1 216 3 98 0 20 0 32 0 0 1 34 38 39 35 7 35 17 51 21 7 62 1 51 50 22 21 20 14 2 39 50 54 53 52 38 35 34 7 21 30 1 1 71 24 50 23 1 7 50 64 2 23 53 28 66 68 24 40 53 41 40 52 39 46 39 46 21 40 1 131 21 19 32 1 215 129 56 19 24 89 75 41 64 45 23 53 62 58 51 60 40 161 17 13 0 0 0 0 1 0 181 1 131 1 205 2 212 0 29 0 0 1 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 23 14 1 1 90 35 61 44 25 28 47 61 34 35 50 18 32 15 33 20 48 60 58 48 25 40 17 27 24 59 1 131 23 43 62 40 40 63 44 22 22 16 41 12 15 64 53 52 64 18 12 41 20 21 0 0 0 0 2 0 137 1 131 1 182 3 98 0 20 0 32 0 0 1 34 38 53 52 62 2 51 50 22 23 39 53 51 17 35 39 35 14 1 39 50 55 53 46 1 35 34 6 21 20 22 1 20 63 76 24 40 53 29 29 43 21 2 64 53 5 2 20 53 14 44 39 21 38 20 39 53 46 1 131 87 81 39 63 44 23 20 17 55 124 254 41 36 18 26 53 40 160 17 14 61 54 56 60 0 0 0 0 2 0 145 1 131 1 202 2 212 0 25 0 32 0 0 1 34 46 2 53 52 62 2 51 50 22 21 20 6 7 35 30 1 51 50 54 55 23 6 3 34 6 7 51 46 1 1 64 36 64 48 27 27 46 59 32 72 77 2 1 250 6 69 47 27 47 21 22 54 78 36 61 8 196 5 49 1 131 23 43 62 40 39 63 43 24 82 69 11 17 7 51 51 13 12 40 34 1 31 43 45 48 40 0 1 0 198 1 139 1 247 3 105 0 21 0 0 1 17 35 53 55 53 52 54 51 50 23 7 38 35 34 6 29 1 51 21 35 17 1 21 79 79 65 69 47 45 14 33 38 42 36 128 128 1 139 1 15 48 2 27 59 71 17 47 13 42 35 29 50 254 241 0 0 0 0 3 0 149 0 249 1 226 2 212 0 49 0 61 0 77 0 0 37 34 38 53 52 55 53 46 1 53 52 54 55 53 46 1 53 52 62 2 51 50 22 23 51 21 35 30 1 21 20 14 2 35 34 39 6 21 20 59 1 50 22 21 20 14 2 3 50 54 53 52 38 35 34 6 21 20 22 23 50 54 53 52 38 43 1 34 38 39 14 1 21 20 22 1 42 70 79 53 13 20 21 18 17 24 21 35 47 27 14 24 11 134 82 11 14 19 34 46 27 23 30 22 63 71 64 62 26 48 68 43 29 40 40 29 29 40 40 36 54 63 37 35 59 15 23 11 21 17 51 249 44 43 40 30 2 8 26 20 16 32 12 3 13 41 29 27 43 30 16 3 5 48 11 31 19 27 41 28 15 11 14 20 34 36 41 24 41 30 18 1 33 37 33 32 40 40 32 33 37 247 37 23 21 15 2 3 11 25 13 23 29 0 0 1 0 175 1 139 1 204 3 98 0 20 0 0 19 17 51 21 7 62 1 51 50 22 29 1 35 53 52 38 35 34 6 7 21 175 64 4 24 56 36 57 52 64 31 36 26 39 25 1 139 1 215 129 69 23 33 65 62 202 194 42 39 25 24 226 0 0 0 2 0 175 1 139 1 136 3 103 0 5 0 17 0 0 1 17 35 53 51 17 3 34 38 53 52 54 51 50 22 21 20 6 1 60 141 205 37 21 27 27 21 21 28 28 1 139 1 15 50 254 191 1 128 25 20 21 26 26 21 20 25 0 0 2 0 140 0 254 1 124 3 103 0 19 0 31 0 0 55 34 38 39 55 30 1 51 50 54 53 17 35 53 51 17 20 14 2 19 34 38 53 52 54 51 50 22 21 20 6 229 26 45 18 20 17 34 15 47 32 142 206 13 33 54 63 21 28 28 21 21 27 27 254 13 9 47 9 9 43 40 1 22 50 254 188 30 50 37 21 2 13 25 20 21 26 26 21 20 25 0 0 0 0 1 0 189 1 139 1 245 3 98 0 12 0 0 19 17 51 17 51 55 51 7 23 35 39 7 21 189 64 2 159 72 125 140 71 107 70 1 139 1 215 254 202 160 128 193 151 67 84 0 0 0 0 1 0 196 1 131 1 202 3 98 0 16 0 0 1 34 38 53 17 35 53 51 17 20 22 51 50 55 23 14 1 1 125 54 50 81 145 29 26 20 30 12 20 34 1 131 59 57 1 56 51 254 145 32 28 10 49 5 8 0 0 1 0 70 1 139 2 17 2 212 0 34 0 0 19 17 51 23 51 62 1 51 50 23 62 1 51 50 22 29 1 35 53 52 38 35 34 6 7 21 35 53 52 38 35 34 6 7 21 70 50 6 3 20 49 32 69 21 23 53 33 53 47 62 24 35 17 37 23 62 24 35 18 37 23 1 139 1 65 45 22 31 60 24 36 70 56 203 194 38 44 22 25 229 194 38 44 22 25 229 0 1 0 175 1 139 1 204 2 212 0 20 0 0 19 17 51 23 51 62 1 51 50 22 29 1 35 53 52 38 35 34 6 7 21 175 53 5 3 23 55 37 56 53 64 31 36 26 39 25 1 139 1 65 48 23 33 65 62 202 194 42 39 25 24 226 0 0 0 2 0 142 1 131 1 202 2 212 0 19 0 31 0 0 1 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 1 44 32 57 43 26 26 43 57 32 32 57 44 25 25 44 57 32 43 49 49 43 43 49 49 1 131 23 43 62 40 40 63 44 22 22 44 63 40 40 62 43 23 52 64 52 53 64 64 53 52 64 0 2 0 172 1 6 1 216 2 212 0 19 0 32 0 0 19 17 51 23 51 62 1 51 50 22 21 20 14 2 35 34 39 23 21 55 50 54 53 52 38 35 34 6 7 21 30 1 172 52 5 3 23 54 30 65 68 24 40 53 28 46 47 2 78 40 52 39 46 20 42 23 21 40 1 6 1 198 36 18 26 89 75 41 64 45 23 36 55 106 178 62 58 51 60 20 20 161 17 13 0 2 0 137 1 6 1 182 2 212 0 20 0 32 0 0 1 53 55 14 1 35 34 38 53 52 62 2 51 50 22 23 51 55 51 17 39 50 55 53 46 1 35 34 6 21 20 22 1 118 3 20 52 29 63 76 24 40 53 29 29 44 23 2 5 52 147 44 39 21 38 20 39 53 46 1 6 111 56 18 24 87 81 39 63 44 23 19 20 31 254 58 178 40 160 17 14 61 54 56 60 0 0 0 0 1 0 243 1 139 1 240 2 212 0 17 0 0 19 17 51 23 51 62 1 51 50 23 7 46 1 35 34 6 7 21 243 54 5 2 23 66 39 35 29 13 17 25 18 31 61 24 1 139 1 65 75 39 44 13 54 5 5 40 50 182 0 0 0 1 0 162 1 131 1 195 2 212 0 45 0 0 1 34 38 39 55 30 1 51 50 54 53 52 46 2 39 46 3 53 52 54 51 50 22 23 7 46 1 35 34 6 21 20 30 2 23 30 3 21 20 6 1 52 43 76 27 30 26 55 37 40 38 15 25 32 16 21 43 34 22 71 64 36 63 23 30 20 45 27 38 33 14 24 30 16 22 44 35 22 73 1 131 26 19 41 18 20 26 19 12 17 13 10 5 7 16 21 30 20 40 53 22 15 40 13 16 25 17 10 15 12 10 5 7 15 22 31 23 40 57 0 0 0 0 1 0 164 1 131 1 207 3 48 0 23 0 0 1 34 38 61 1 35 53 63 1 51 21 51 21 35 21 20 22 51 50 54 55 23 14 1 1 113 72 56 77 80 8 53 145 145 34 45 20 31 15 13 20 48 1 131 74 61 144 48 2 100 100 50 145 42 42 8 7 47 8 10 0 0 0 1 0 159 1 131 1 187 2 204 0 20 0 0 1 34 38 61 1 51 21 20 22 51 50 54 55 53 51 17 35 39 35 14 1 1 10 55 52 64 30 35 26 41 24 64 52 6 2 23 57 1 131 65 61 203 195 41 38 23 27 224 254 191 50 26 32 0 0 1 0 139 1 139 1 198 2 204 0 13 0 0 1 3 51 23 30 1 23 51 62 1 63 1 51 3 1 5 122 66 62 8 15 8 2 8 14 8 62 62 119 1 139 1 65 176 24 48 23 23 48 24 176 254 191 0 0 0 0 1 0 52 1 139 1 251 2 204 0 21 0 0 19 3 51 31 1 51 63 1 51 31 1 51 63 1 51 3 35 47 1 35 15 1 141 89 64 44 20 3 22 48 56 50 21 4 21 43 59 87 75 42 22 2 20 44 1 139 1 65 179 91 91 179 179 91 91 179 254 191 163 91 91 163 0 1 0 159 1 139 1 203 2 204 0 25 0 0 19 55 39 51 23 30 1 23 51 62 1 63 1 51 7 23 35 39 46 1 39 35 14 1 15 1 159 111 102 68 43 8 17 8 3 8 15 8 38 68 104 111 69 47 8 20 10 2 8 17 9 43 1 139 168 153 66 14 26 14 14 26 14 66 160 161 69 15 29 14 14 29 15 69 0 1 0 140 1 2 1 204 2 204 0 28 0 0 19 34 38 39 55 30 1 51 50 54 63 1 3 51 23 30 1 23 51 62 1 63 1 51 3 14 3 198 13 21 9 13 5 14 7 29 37 11 7 138 64 69 8 17 9 2 8 13 8 60 62 130 9 24 32 41 1 2 4 3 50 2 3 36 27 23 1 64 169 21 47 23 22 47 22 169 254 169 25 42 31 17 0 1 0 146 1 139 1 200 2 204 0 9 0 0 19 53 55 35 53 33 21 7 51 21 146 213 189 1 23 212 219 1 139 33 238 50 33 238 50 0 0 3 0 145 1 131 1 202 3 149 0 3 0 29 0 36 0 0 1 39 55 23 3 34 46 2 53 52 62 2 51 50 22 21 20 6 7 35 30 1 51 50 54 55 23 6 3 34 6 7 51 46 1 1 73 112 45 102 44 36 64 48 27 27 46 59 32 72 77 2 1 250 6 69 47 27 47 21 22 54 78 36 61 8 196 5 49 2 254 110 41 120 254 102 23 43 62 40 39 63 43 24 82 69 11 17 7 51 51 13 12 40 34 1 31 43 45 48 40 0 0 3 0 145 1 131 1 202 3 149 0 3 0 29 0 36 0 0 1 39 55 23 3 34 46 2 53 52 62 2 51 50 22 21 20 6 7 35 30 1 51 50 54 55 23 6 3 34 6 7 51 46 1 1 39 34 102 45 88 36 64 48 27 27 46 59 32 72 77 2 1 250 6 69 47 27 47 21 22 54 78 36 61 8 196 5 49 2 254 31 120 41 254 23 23 43 62 40 39 63 43 24 82 69 11 17 7 51 51 13 12 40 34 1 31 43 45 48 40 0 0 2 0 145 0 244 1 202 2 212 0 45 0 52 0 0 37 34 38 53 52 54 55 14 1 35 34 46 2 53 52 62 2 51 50 22 21 20 6 7 35 30 1 51 50 54 55 23 14 1 21 20 22 51 50 54 55 23 14 1 3 34 6 7 51 46 1 1 130 29 41 25 22 13 22 8 36 64 48 27 27 46 59 32 72 77 2 1 250 6 69 47 27 47 21 22 47 36 23 13 12 17 6 18 12 32 94 36 61 8 196 5 49 244 30 33 24 42 18 3 1 23 43 62 40 39 63 43 24 82 69 11 17 7 51 51 13 12 40 32 46 25 18 15 9 6 30 11 15 1 174 43 45 48 40 0 0 2 0 142 1 131 1 199 2 214 0 27 0 34 0 0 1 34 46 2 53 52 54 55 51 46 1 35 34 7 39 62 1 51 50 30 2 21 20 14 2 39 50 54 55 35 30 1 1 42 36 58 41 21 2 1 250 6 63 45 50 44 22 26 62 36 35 61 45 25 26 43 57 33 36 55 7 197 4 55 1 131 23 42 57 34 11 18 6 49 49 25 40 17 18 23 44 62 40 39 63 44 24 50 45 48 50 43 0 1 0 175 1 139 1 204 3 103 0 31 0 0 19 17 52 54 51 50 22 23 7 46 1 35 34 6 15 1 62 1 51 50 22 29 1 35 53 52 38 35 34 6 7 21 175 59 63 20 35 17 14 14 23 14 35 30 1 3 24 56 36 57 52 64 31 36 26 39 25 1 139 1 90 60 70 8 7 48 6 6 42 35 81 23 33 65 62 196 188 42 39 25 24 220 0 2 0 146 0 249 1 198 2 205 0 24 0 36 0 0 37 34 38 53 52 54 55 3 51 23 30 1 23 51 62 1 63 1 51 3 30 1 21 20 6 39 50 54 53 52 39 35 14 1 21 20 22 1 45 39 42 21 19 114 65 59 8 14 7 3 8 14 8 59 63 113 19 21 41 39 14 13 26 3 12 14 14 249 43 36 23 47 35 1 28 166 23 37 22 22 37 23 166 254 229 35 48 23 36 43 42 18 14 34 47 23 42 16 14 18 0 1 0 160 1 139 1 196 3 103 0 25 0 0 1 53 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 23 21 1 26 25 45 33 19 25 43 56 31 48 67 22 34 19 47 32 43 53 60 61 1 139 179 16 35 40 47 29 31 49 33 17 36 23 40 19 27 42 37 42 65 32 205 0 0 0 0 2 0 137 1 131 1 182 2 212 0 20 0 32 0 0 1 34 38 53 52 62 2 51 50 22 23 51 55 51 17 35 39 35 14 1 39 50 55 53 46 1 35 34 6 21 20 22 1 20 63 76 24 40 53 29 28 45 23 2 5 52 53 5 2 20 53 14 46 37 20 40 20 38 53 46 1 131 87 81 39 63 44 23 19 20 31 254 191 36 18 26 53 40 160 17 14 61 54 56 60 0 0 0 0 2 0 137 0 255 1 182 2 212 0 31 0 43 0 0 37 34 38 39 55 30 1 51 50 54 63 1 14 1 35 34 38 53 52 62 2 51 50 22 23 51 55 51 17 20 6 39 50 55 53 46 1 35 34 6 21 20 22 1 27 31 65 27 23 25 52 23 45 45 1 1 19 51 29 63 76 25 40 53 28 28 45 22 1 6 53 81 66 44 39 20 40 20 38 54 47 255 18 17 44 15 14 43 36 56 17 24 86 75 38 61 42 23 19 19 30 254 179 61 67 196 42 147 17 14 60 50 51 59 0 0 0 2 0 173 1 139 1 235 3 103 0 11 0 21 0 0 1 34 38 53 52 54 51 50 22 21 20 6 3 53 51 53 35 53 51 17 51 21 1 74 21 27 27 21 21 27 27 178 130 114 178 124 3 11 25 20 21 26 26 21 20 25 254 128 50 221 50 254 241 50 0 0 255 255 0 251 1 128 1 93 2 197 2 39 3 249 0 0 2 60 0 7 3 249 0 0 3 29 0 0 0 1 0 222 2 24 1 122 2 71 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 19 53 51 21 222 156 2 24 47 47 0 0 0 0 1 0 165 2 27 1 179 2 69 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 19 53 33 21 165 1 14 2 27 42 42 0 0 0 1 0 61 2 27 2 27 2 69 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 19 53 33 21 61 1 222 2 27 42 42 0 0 0 2 0 58 0 83 2 30 2 65 0 32 0 52 0 23 0 187 0 33 0 1 0 30 0 4 43 187 0 13 0 1 0 43 0 4 43 48 49 55 39 55 46 1 53 52 54 55 39 55 23 54 51 50 23 55 23 7 30 1 21 20 6 7 23 7 39 14 1 35 34 39 55 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 102 44 84 17 19 18 17 83 44 87 48 63 62 49 87 44 84 17 19 19 17 84 44 88 23 57 30 62 49 111 24 43 32 19 19 32 43 24 24 43 32 19 19 32 43 83 45 85 23 58 35 35 59 23 86 45 90 37 37 90 45 86 23 59 35 35 58 23 85 45 89 19 19 38 23 19 36 49 30 30 49 36 19 19 36 49 30 30 49 36 19 0 0 1 0 85 255 146 2 0 2 236 0 49 0 75 0 187 0 29 0 1 0 17 0 4 43 187 0 47 0 1 0 4 0 4 43 186 0 7 0 17 0 47 17 18 57 184 0 17 16 184 0 19 220 184 0 17 16 184 0 20 208 186 0 32 0 47 0 17 17 18 57 184 0 47 16 184 0 44 208 184 0 47 16 184 0 45 220 48 49 63 1 30 1 51 50 54 53 52 46 4 53 52 54 55 53 51 21 30 1 23 7 46 3 35 34 6 21 20 30 4 21 20 14 2 7 21 35 53 46 1 85 39 38 91 57 60 61 47 70 83 70 47 89 73 60 55 74 30 44 17 31 34 40 25 51 59 47 71 82 71 47 25 47 65 39 60 56 100 113 57 27 41 49 38 31 41 32 30 41 57 44 63 80 8 132 131 5 42 29 48 13 21 15 8 45 38 28 36 30 30 42 60 46 32 55 41 27 4 146 145 5 44 0 1 0 77 0 0 2 19 2 138 0 41 0 87 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 11 62 89 184 0 0 69 88 184 0 41 47 27 185 0 41 0 3 62 89 187 0 6 0 1 0 9 0 4 43 184 0 41 16 185 0 40 0 1 244 184 0 1 208 184 0 17 16 185 0 24 0 1 244 184 0 9 16 184 0 30 208 184 0 6 16 184 0 33 208 48 49 51 53 62 1 53 52 39 35 53 55 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 23 51 21 35 22 21 20 6 7 21 33 21 78 63 61 8 117 99 11 21 30 55 77 48 62 85 29 48 23 59 42 66 69 19 11 189 173 6 36 36 1 72 50 28 95 57 26 29 52 4 32 61 32 42 68 48 26 43 32 47 23 30 65 52 32 59 32 56 27 29 53 70 31 4 71 0 0 0 0 1 0 53 0 0 2 35 2 126 0 29 0 99 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 11 62 89 184 0 0 69 88 184 0 29 47 27 185 0 29 0 3 62 89 186 0 15 0 29 0 19 17 18 57 184 0 15 16 184 0 21 208 185 0 24 0 1 244 184 0 5 208 184 0 4 220 184 0 25 208 185 0 28 0 1 244 184 0 1 208 184 0 21 16 184 0 8 208 184 0 9 16 184 0 20 208 48 49 33 53 35 53 51 53 35 53 51 3 51 23 30 1 23 51 62 1 63 1 51 3 51 21 35 21 51 21 35 21 1 2 181 181 181 161 185 85 92 17 33 19 4 18 34 18 92 82 186 162 183 183 183 158 48 65 47 1 64 171 33 67 35 35 67 33 171 254 192 47 65 48 158 0 0 0 1 0 58 255 244 2 54 2 138 0 49 0 109 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 37 0 31 0 3 43 184 0 37 16 185 0 40 0 1 244 184 0 3 208 184 0 37 16 184 0 6 208 184 0 31 16 184 0 12 208 184 0 31 16 185 0 28 0 1 244 184 0 15 208 184 0 18 16 185 0 25 0 1 244 184 0 0 16 185 0 43 0 1 244 48 49 5 34 38 39 35 53 55 38 52 53 60 1 55 35 53 55 62 1 51 50 22 23 7 46 1 35 34 6 7 33 21 33 6 20 21 28 1 23 33 21 35 30 1 51 50 54 55 23 14 1 1 118 99 134 19 64 59 1 1 59 64 19 141 106 51 88 30 49 26 59 38 73 91 14 1 38 254 213 1 1 1 3 253 14 88 69 43 65 30 49 38 92 12 130 118 44 4 8 18 8 8 17 8 44 5 118 132 45 33 47 26 33 97 87 49 8 14 8 9 18 9 49 86 96 36 35 44 44 49 0 2 0 113 255 223 1 250 2 141 0 6 0 37 0 87 0 187 0 29 0 1 0 36 0 4 43 187 0 21 0 1 0 28 0 4 43 184 0 29 16 184 0 3 208 184 0 3 47 184 0 28 16 184 0 4 208 184 0 4 47 184 0 36 16 184 0 7 220 184 0 36 16 184 0 8 208 184 0 8 47 184 0 21 16 184 0 18 208 184 0 18 47 184 0 21 16 184 0 19 220 48 49 19 20 22 23 17 14 1 19 53 46 3 53 52 62 2 55 53 51 21 30 1 23 7 46 1 39 17 62 1 55 23 14 1 7 21 194 63 57 56 64 120 45 74 53 29 31 54 74 42 51 44 64 23 40 20 45 26 32 52 21 36 30 72 39 1 54 67 88 13 1 79 13 88 254 103 104 5 36 61 84 53 52 83 60 36 6 106 103 2 34 22 52 18 22 2 254 168 2 27 18 52 26 34 3 103 0 1 0 49 255 159 2 24 2 156 0 40 0 66 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 13 62 89 187 0 7 0 1 0 0 0 4 43 187 0 33 0 1 0 34 0 4 43 184 0 34 16 184 0 11 208 184 0 33 16 184 0 15 208 184 0 19 16 185 0 26 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 63 1 35 53 55 51 55 62 1 51 50 22 23 7 46 1 35 34 14 2 15 1 51 21 35 7 14 3 132 26 42 15 16 14 29 16 52 45 10 24 104 70 41 6 13 80 84 26 48 17 20 14 31 22 25 35 24 14 3 7 142 149 27 6 23 40 62 97 11 7 62 5 8 79 77 219 59 4 56 100 104 12 8 62 7 8 22 36 47 25 63 63 237 46 75 54 30 0 0 3 0 96 255 146 2 34 2 238 0 8 0 14 0 51 0 125 0 184 0 0 69 88 184 0 26 47 27 185 0 26 0 11 62 89 184 0 0 69 88 184 0 48 47 27 185 0 48 0 3 62 89 184 0 26 16 185 0 0 0 1 244 184 0 48 16 185 0 6 0 1 244 184 0 48 16 184 0 46 220 184 0 26 16 184 0 23 220 186 0 11 0 46 0 23 17 18 57 186 0 12 0 23 0 46 17 18 57 184 0 30 208 186 0 37 0 23 0 46 17 18 57 186 0 38 0 46 0 23 17 18 57 184 0 46 16 184 0 51 208 48 49 1 42 1 7 3 22 23 19 38 3 20 23 19 14 1 19 55 46 1 53 52 54 63 1 23 7 51 50 22 23 55 23 7 22 23 7 38 39 3 62 1 55 23 14 1 15 1 39 55 38 39 7 1 109 5 10 5 60 28 31 62 20 205 60 54 56 58 35 14 62 72 111 96 13 48 11 17 11 22 11 12 48 13 43 33 49 15 21 58 30 50 23 49 32 78 50 12 48 11 30 30 13 2 72 1 254 1 16 1 2 11 6 254 249 141 72 1 206 26 128 253 250 123 37 151 109 134 168 23 107 8 92 3 2 105 8 113 21 36 47 17 14 254 13 7 34 27 44 38 47 6 100 8 91 1 10 110 0 1 0 78 0 0 2 19 2 138 0 52 0 117 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 11 62 89 184 0 0 69 88 184 0 52 47 27 185 0 52 0 3 62 89 186 0 12 0 9 0 3 43 184 0 52 16 185 0 51 0 1 244 184 0 1 208 184 0 9 16 184 0 5 220 184 0 12 16 184 0 15 220 184 0 23 16 185 0 30 0 1 244 184 0 15 16 184 0 37 208 184 0 12 16 184 0 38 208 184 0 9 16 184 0 43 208 184 0 5 16 184 0 44 208 48 49 51 53 62 1 61 1 35 53 55 51 46 1 39 35 53 55 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 23 51 21 35 30 1 23 51 21 35 21 20 6 7 21 33 21 78 63 61 124 87 29 4 12 6 94 77 5 6 30 55 77 48 62 85 29 48 23 59 42 66 69 5 5 209 193 5 11 4 173 167 36 36 1 72 50 28 95 57 6 44 5 17 32 17 46 3 17 32 17 42 68 48 26 43 32 47 23 30 65 52 17 31 16 49 16 33 17 49 7 53 70 31 4 71 0 0 0 5 0 46 0 0 2 40 2 126 0 3 0 7 0 35 0 39 0 43 0 165 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 11 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 3 62 89 186 0 13 0 12 0 3 43 186 0 0 0 17 0 8 17 18 57 184 0 13 16 184 0 16 220 184 0 2 208 186 0 4 0 8 0 17 17 18 57 184 0 12 16 184 0 9 220 184 0 33 208 184 0 6 208 184 0 2 16 184 0 20 208 184 0 17 16 184 0 22 208 184 0 20 16 184 0 24 208 184 0 13 16 184 0 41 208 184 0 37 208 184 0 25 208 184 0 12 16 184 0 40 208 184 0 36 208 184 0 28 208 184 0 6 16 184 0 29 208 184 0 8 16 184 0 31 208 48 49 19 23 51 39 19 51 39 35 7 53 35 53 55 53 35 53 55 53 51 23 51 53 51 21 51 21 35 21 51 21 35 21 35 39 35 21 19 39 35 23 35 39 35 23 170 9 59 64 252 4 9 58 242 75 75 75 75 84 94 115 65 73 73 73 73 84 93 116 233 4 97 27 62 26 76 4 2 51 163 163 254 23 162 236 236 43 5 68 43 5 238 238 238 238 48 68 48 236 236 236 1 28 68 68 68 68 0 0 0 0 3 0 42 0 0 2 71 2 126 0 21 0 27 0 33 0 99 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 5 16 185 0 27 0 1 244 184 0 23 220 185 0 33 0 1 244 184 0 1 208 184 0 23 16 184 0 4 208 184 0 23 16 184 0 12 208 184 0 33 16 184 0 13 208 184 0 33 16 184 0 28 220 185 0 19 0 1 244 48 49 51 17 35 53 55 53 51 50 30 2 23 51 21 35 14 3 43 1 21 17 21 51 46 1 35 3 51 50 54 55 35 135 93 93 148 45 78 59 37 5 76 76 5 38 59 77 45 70 214 8 78 69 59 59 69 78 8 214 1 161 51 5 165 18 39 63 45 56 44 65 42 21 245 2 69 108 59 49 254 233 58 57 0 0 4 0 28 0 0 2 58 2 126 0 3 0 9 0 33 0 39 0 167 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 11 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 3 62 89 186 0 0 0 10 0 15 17 18 57 186 0 38 0 15 0 10 17 18 57 184 0 38 47 184 0 17 220 184 0 2 208 186 0 4 0 15 0 10 17 18 57 184 0 38 16 184 0 31 208 184 0 7 208 184 0 38 16 184 0 11 208 184 0 17 16 184 0 14 208 186 0 19 0 15 0 10 17 18 57 184 0 2 16 184 0 22 208 184 0 15 16 184 0 24 208 184 0 22 16 184 0 26 208 184 0 7 16 184 0 27 208 184 0 10 16 184 0 29 208 186 0 34 0 15 0 10 17 18 57 48 49 1 7 51 39 19 51 63 1 35 23 5 3 35 53 55 3 51 19 51 55 51 23 51 19 51 3 51 21 35 3 35 3 35 3 39 51 63 1 35 23 1 42 14 32 14 106 4 12 10 49 11 255 0 36 76 69 34 76 29 59 27 98 27 60 28 71 31 63 70 32 112 34 44 32 52 4 12 11 47 10 2 16 174 174 254 52 130 98 98 198 1 40 52 6 1 28 254 228 244 244 1 28 254 228 58 254 216 1 40 254 216 68 130 98 98 0 0 0 3 0 109 0 0 2 34 2 153 0 29 0 44 0 48 0 90 0 184 0 0 69 88 184 0 48 47 27 185 0 48 0 3 62 89 187 0 8 0 1 0 37 0 4 43 184 0 48 16 185 0 46 0 1 244 185 0 0 0 1 244 184 0 8 16 184 0 23 220 184 0 14 208 184 0 23 16 185 0 20 0 1 244 184 0 16 208 184 0 20 16 184 0 19 220 184 0 0 16 185 0 30 0 1 244 48 49 37 34 38 53 52 62 2 51 50 22 23 51 39 53 35 53 51 53 51 21 51 21 7 17 35 39 35 14 1 39 50 54 55 53 46 1 35 34 14 2 21 20 22 7 53 33 21 1 20 76 91 29 49 63 33 39 53 24 3 5 155 155 71 78 78 58 6 3 24 62 24 28 52 26 27 45 30 23 41 31 18 57 118 1 122 110 97 92 41 66 47 25 24 22 83 34 49 67 67 44 5 254 83 46 25 31 59 25 28 155 22 19 18 32 43 25 62 69 169 49 49 0 0 0 0 4 0 42 0 0 2 72 2 126 0 30 0 36 0 45 0 50 0 137 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 9 16 185 0 36 0 1 244 184 0 32 220 184 0 41 208 184 0 42 220 184 0 50 220 184 0 1 208 184 0 42 16 184 0 4 208 184 0 41 16 184 0 5 208 184 0 32 16 184 0 8 208 184 0 32 16 184 0 14 208 184 0 41 16 184 0 15 208 184 0 42 16 184 0 23 208 184 0 50 16 184 0 24 208 184 0 50 16 184 0 46 220 185 0 29 0 1 244 48 49 51 17 35 53 55 53 35 53 55 53 51 50 22 23 51 21 35 30 1 21 28 1 7 51 21 35 14 1 43 1 21 17 21 51 46 1 35 23 52 38 39 35 21 51 62 1 7 51 50 55 35 135 93 93 93 93 148 77 113 23 88 78 1 1 1 77 87 21 115 78 70 199 18 71 51 157 1 1 214 214 1 1 216 59 107 35 201 1 116 40 6 58 40 6 116 53 63 46 8 16 8 7 13 6 46 65 62 245 2 69 59 32 27 137 9 15 8 58 6 13 135 70 0 0 1 0 84 255 146 2 14 2 236 0 42 0 99 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 11 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 3 62 89 187 0 37 0 1 0 36 0 4 43 184 0 11 16 184 0 13 220 184 0 11 16 184 0 14 208 184 0 11 16 185 0 21 0 1 244 184 0 1 16 185 0 31 0 1 244 184 0 1 16 184 0 41 208 184 0 1 16 184 0 42 220 48 49 5 53 46 3 53 52 62 2 55 53 51 21 30 1 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 53 35 53 51 17 6 7 21 1 55 50 84 60 33 32 59 84 52 60 46 79 27 49 26 59 38 44 67 47 24 24 45 65 42 32 58 16 116 191 67 88 110 100 6 50 84 116 72 70 115 85 51 8 101 99 4 44 31 46 27 33 37 68 98 60 62 98 68 37 22 15 169 69 254 242 62 9 100 0 0 0 0 1 0 61 255 244 2 25 2 138 0 60 0 119 0 184 0 0 69 88 184 0 31 47 27 185 0 31 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 11 0 31 0 0 17 18 57 184 0 11 47 184 0 7 220 184 0 11 16 184 0 14 220 184 0 18 220 184 0 31 16 185 0 24 0 1 244 184 0 18 16 184 0 40 208 184 0 14 16 184 0 41 208 184 0 11 16 184 0 46 208 184 0 7 16 184 0 47 208 184 0 0 16 185 0 54 0 1 244 48 49 5 34 46 2 53 52 55 35 53 55 51 62 1 55 35 53 55 51 62 1 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 51 21 35 14 1 7 51 21 33 14 1 21 20 22 51 50 54 55 23 14 1 1 67 45 74 53 29 19 80 69 46 18 44 23 200 70 202 26 33 55 48 41 54 30 44 33 78 61 40 66 48 26 17 15 97 147 23 50 23 243 254 212 16 19 61 60 45 73 33 38 36 99 12 23 43 62 39 44 36 43 5 20 32 15 44 5 20 46 29 38 52 31 33 47 37 46 23 42 58 35 28 45 20 49 18 32 17 48 18 41 25 43 54 41 32 55 38 46 0 0 0 0 2 0 96 255 146 2 34 2 233 0 6 0 37 0 101 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 11 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 3 62 89 185 0 3 0 1 244 184 0 18 16 185 0 4 0 1 244 184 0 18 16 184 0 20 220 184 0 18 16 184 0 21 208 184 0 4 16 184 0 28 208 184 0 3 16 184 0 29 208 184 0 8 16 184 0 36 208 184 0 8 16 184 0 37 220 48 49 19 20 22 23 17 14 1 19 53 46 3 53 52 62 2 55 53 51 21 30 1 23 7 46 1 39 17 62 1 55 23 14 1 7 21 181 77 72 72 77 149 52 86 62 34 33 61 87 53 53 47 79 28 49 23 50 32 34 54 26 49 33 79 51 1 65 112 140 13 2 13 14 138 253 229 99 5 49 84 118 73 71 116 84 52 7 97 96 3 43 31 47 23 31 4 253 241 5 35 29 44 38 48 5 100 0 0 0 1 0 108 0 0 2 13 2 126 0 29 0 99 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 11 62 89 184 0 0 69 88 184 0 28 47 27 185 0 28 0 3 62 89 186 0 0 0 14 0 28 17 18 57 184 0 0 47 185 0 2 0 1 244 184 0 14 16 184 0 21 220 184 0 9 208 185 0 22 0 1 244 184 0 5 208 184 0 14 16 185 0 13 0 1 244 184 0 14 16 185 0 16 0 1 244 48 49 55 53 51 50 54 55 33 53 55 51 46 1 43 1 53 33 21 35 30 1 23 51 21 35 14 1 7 19 35 39 108 79 83 96 5 254 249 76 184 12 93 76 79 1 161 157 33 43 7 74 72 5 92 74 208 93 200 252 67 58 60 44 5 46 38 68 49 15 53 35 49 77 87 14 254 253 252 0 0 0 1 0 45 255 242 2 24 2 126 0 35 0 125 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 15 0 0 0 9 17 18 57 184 0 15 16 184 0 18 208 184 0 1 208 184 0 15 16 184 0 4 208 184 0 2 208 184 0 4 16 184 0 14 208 184 0 5 208 184 0 14 16 184 0 11 208 184 0 8 208 184 0 6 208 184 0 14 16 184 0 12 208 184 0 18 16 184 0 16 208 184 0 0 16 185 0 19 0 1 244 48 49 23 17 7 39 55 53 7 39 55 53 51 21 55 23 7 21 55 23 7 21 62 3 53 52 38 39 55 30 1 21 20 14 2 160 93 22 115 93 22 115 84 171 23 194 171 23 194 37 78 65 41 1 5 69 5 3 58 102 137 12 1 17 43 43 53 72 43 42 54 199 158 81 43 91 72 81 43 91 236 1 22 41 61 39 8 21 14 18 17 27 13 63 94 62 29 0 0 0 1 0 55 0 0 2 33 2 126 0 23 0 51 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 11 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 3 62 89 184 0 5 16 185 0 4 0 1 244 184 0 7 208 48 49 55 39 55 53 35 53 33 21 35 21 55 23 7 21 55 23 7 21 35 53 7 39 55 53 120 22 160 203 1 234 203 138 22 160 138 22 160 84 138 22 160 255 43 75 201 64 64 166 64 40 77 72 64 40 76 231 195 65 43 75 72 0 0 0 2 0 55 0 0 2 33 2 126 0 8 0 12 0 63 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 184 0 10 16 185 0 12 0 1 244 185 0 4 0 1 244 185 0 6 0 1 244 184 0 1 208 48 49 33 17 35 53 55 33 21 35 17 1 53 33 21 1 2 203 82 1 152 203 254 225 1 234 1 218 44 4 48 254 38 2 77 49 49 0 0 0 2 0 42 0 0 2 49 2 126 0 26 0 35 0 105 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 20 0 9 0 0 17 18 57 184 0 20 47 184 0 22 220 185 0 25 0 1 244 184 0 1 208 184 0 22 16 184 0 4 208 184 0 20 16 184 0 5 208 184 0 20 16 185 0 27 0 1 244 184 0 8 208 184 0 9 16 185 0 34 0 1 244 48 49 51 53 35 53 55 53 35 53 55 17 51 50 30 2 21 20 14 2 43 1 21 33 21 33 21 17 51 50 54 53 52 38 43 1 158 116 116 116 116 173 49 85 61 35 35 62 84 49 94 1 2 254 254 84 78 83 83 78 84 164 44 5 67 44 4 1 54 20 43 67 46 48 69 44 21 67 49 164 1 72 65 66 67 55 0 0 0 0 1 0 69 0 0 2 21 2 126 0 17 0 93 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 11 0 5 0 0 17 18 57 184 0 11 47 184 0 13 220 185 0 16 0 1 244 184 0 1 208 184 0 13 16 184 0 4 208 184 0 5 16 185 0 8 0 1 244 184 0 11 16 185 0 10 0 1 244 48 49 51 53 35 53 55 17 33 21 33 21 51 21 35 21 51 21 35 21 148 79 79 1 129 254 210 253 253 160 160 124 52 4 1 202 71 197 70 120 56 124 0 0 2 0 28 0 32 2 60 2 112 0 3 0 7 0 0 55 39 55 23 55 39 55 23 77 49 183 33 145 33 167 49 32 45 188 30 156 30 203 45 255 255 0 28 0 32 2 60 2 112 2 6 4 89 0 0 255 255 0 28 0 32 2 60 2 112 2 6 4 89 0 0 255 255 0 28 255 244 2 61 2 138 2 39 3 251 255 123 1 77 0 38 4 89 0 0 0 7 3 251 0 134 0 0 0 7 0 48 255 244 2 63 2 138 0 11 0 23 0 27 0 39 0 51 0 63 0 75 0 0 19 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 7 39 37 23 1 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 5 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 165 52 65 65 52 52 65 65 52 27 35 35 27 27 36 36 19 14 1 190 24 254 102 52 65 65 52 52 65 65 52 27 35 35 27 27 36 36 1 42 52 65 65 52 52 65 65 52 27 35 35 27 27 36 36 1 133 69 63 61 68 68 61 63 69 42 43 47 45 42 42 45 47 43 153 31 201 58 254 48 69 63 61 68 68 61 63 69 42 43 47 45 41 41 45 47 43 42 69 63 61 68 68 61 63 69 42 43 47 45 41 41 45 47 43 0 0 0 255 255 0 28 0 0 2 63 2 126 2 39 3 252 255 116 1 77 0 38 4 89 0 0 0 7 3 255 0 134 0 0 255 255 0 28 0 0 2 60 2 126 2 39 3 252 255 116 1 77 0 38 4 89 0 0 0 7 3 253 0 141 0 0 255 255 0 32 0 0 2 85 2 138 2 39 3 254 255 116 1 77 0 38 4 89 25 0 0 7 3 255 0 134 0 0 255 255 0 28 255 244 2 60 2 126 2 39 3 252 255 116 1 77 0 38 4 89 0 0 0 7 3 254 0 141 0 0 255 255 0 28 255 244 2 60 2 138 2 39 3 253 255 116 1 77 0 38 4 89 0 0 0 7 3 254 0 141 0 0 255 255 0 28 255 244 2 60 2 126 2 39 3 252 255 116 1 77 0 38 4 89 0 0 0 7 4 0 0 141 0 0 255 255 0 28 255 244 2 60 2 138 2 39 3 253 255 116 1 77 0 38 4 89 0 0 0 7 4 0 0 141 0 0 255 255 0 28 255 244 2 60 2 138 2 39 3 254 255 116 1 77 0 38 4 89 0 0 0 7 4 0 0 141 0 0 255 255 0 28 255 244 2 60 2 138 2 39 3 255 255 116 1 77 0 38 4 89 0 0 0 7 4 0 0 141 0 0 255 255 0 28 255 244 2 60 2 126 2 39 3 252 255 116 1 77 0 38 4 89 0 0 0 7 4 1 0 141 0 0 255 255 0 28 255 244 2 60 2 126 2 39 4 0 255 116 1 77 0 38 4 89 0 0 0 7 4 1 0 141 0 0 255 255 0 28 0 0 2 60 2 126 2 39 3 252 255 116 1 77 0 38 4 89 0 0 0 7 4 2 0 141 0 0 255 255 0 28 255 244 2 60 2 126 2 39 3 252 255 116 1 77 0 38 4 89 0 0 0 7 4 3 0 141 0 0 255 255 0 28 255 244 2 60 2 138 2 39 3 254 255 116 1 77 0 38 4 89 0 0 0 7 4 3 0 141 0 0 255 255 0 28 255 244 2 60 2 126 2 39 4 0 255 116 1 77 0 38 4 89 0 0 0 7 4 3 0 141 0 0 255 255 0 28 255 244 2 60 2 126 2 39 4 2 255 116 1 77 0 38 4 89 0 0 0 7 4 3 0 141 0 0 255 255 0 28 255 244 2 60 2 126 2 39 3 252 255 116 1 77 0 38 4 89 0 0 0 7 4 4 0 141 0 0 0 5 0 83 255 244 2 63 2 126 0 8 0 12 0 21 0 33 0 45 0 0 19 53 35 53 62 1 55 51 21 7 39 37 23 1 53 35 53 62 1 55 51 21 23 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 165 82 33 41 21 50 109 14 1 190 24 254 102 82 33 41 21 50 208 52 65 65 52 52 65 65 52 27 35 35 27 27 36 36 1 145 162 42 5 15 13 237 123 31 201 58 254 60 162 42 5 15 13 237 12 69 63 61 68 68 61 63 69 42 43 47 45 41 41 45 47 43 255 255 0 28 255 244 2 60 2 138 2 39 3 251 255 123 1 77 0 38 4 89 0 0 0 7 3 254 0 141 0 0 0 1 0 85 0 104 2 3 2 44 0 11 0 29 0 187 0 3 0 1 0 2 0 4 43 184 0 3 16 184 0 7 208 184 0 2 16 184 0 10 208 48 49 37 53 35 53 51 53 51 21 51 21 35 21 1 11 182 182 66 182 182 104 195 62 195 195 62 195 0 0 0 0 1 0 85 1 43 2 3 1 105 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 19 53 33 21 85 1 174 1 43 62 62 0 0 0 1 0 102 0 126 1 242 2 21 0 11 0 41 0 186 0 6 0 10 0 3 43 186 0 11 0 10 0 6 17 18 57 184 0 11 16 184 0 2 208 184 0 11 16 184 0 8 208 184 0 5 208 48 49 55 39 55 39 55 23 55 23 7 23 7 39 146 44 154 154 44 154 154 44 154 154 44 154 126 45 159 158 45 159 159 45 158 159 45 160 0 0 3 0 85 0 96 2 3 2 51 0 11 0 23 0 27 0 37 0 187 0 26 0 1 0 27 0 4 43 184 0 26 16 184 0 0 220 184 0 6 220 184 0 27 16 184 0 18 220 184 0 12 220 48 49 1 34 38 53 52 54 51 50 22 21 20 6 3 34 38 53 52 54 51 50 22 21 20 6 39 53 33 21 1 44 23 31 31 23 23 31 31 23 23 31 31 23 23 31 31 238 1 174 1 200 30 24 23 30 30 23 24 30 254 152 30 24 23 30 30 23 24 30 203 62 62 0 0 255 255 0 216 1 7 1 122 1 176 2 7 3 130 255 253 1 19 0 0 255 255 0 85 0 193 2 3 1 212 2 38 4 114 0 107 0 6 4 114 0 150 0 0 255 255 0 85 0 85 2 3 2 64 2 39 4 114 0 0 0 215 0 38 4 114 0 0 0 7 4 114 0 0 255 42 0 1 0 120 0 48 1 237 2 104 0 7 0 59 0 187 0 2 0 1 0 1 0 4 43 184 0 1 16 184 0 7 208 184 0 7 47 185 0 0 0 1 244 184 0 2 16 184 0 4 208 184 0 4 47 185 0 3 0 1 244 186 0 6 0 2 0 1 17 18 57 48 49 45 1 53 37 21 5 21 5 1 237 254 139 1 117 254 211 1 45 48 253 62 253 79 203 4 203 0 0 1 0 107 0 48 1 224 2 104 0 7 0 59 0 187 0 6 0 1 0 7 0 4 43 184 0 7 16 184 0 1 208 184 0 1 47 185 0 0 0 1 244 186 0 3 0 6 0 7 17 18 57 184 0 6 16 184 0 4 208 184 0 4 47 185 0 5 0 1 244 48 49 55 53 37 53 37 53 5 21 107 1 45 254 211 1 117 48 79 203 4 203 79 253 62 0 2 0 85 0 0 2 3 2 21 0 3 0 13 0 82 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 3 62 89 187 0 6 0 1 0 5 0 4 43 184 0 3 16 185 0 1 0 1 244 186 0 11 0 6 0 5 17 18 57 184 0 11 16 184 0 4 208 184 0 11 16 184 0 7 208 185 0 8 0 1 244 184 0 4 16 185 0 13 0 1 244 48 49 51 53 33 21 53 37 53 37 21 15 1 21 31 1 85 1 174 254 82 1 174 210 135 135 210 62 62 153 153 74 153 71 73 44 4 44 73 0 0 2 0 85 0 0 2 3 2 21 0 3 0 13 0 78 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 3 62 89 187 0 12 0 1 0 13 0 4 43 184 0 3 16 185 0 1 0 1 244 186 0 7 0 12 0 13 17 18 57 184 0 7 16 184 0 4 208 185 0 5 0 1 244 184 0 7 16 184 0 11 208 185 0 10 0 1 244 48 49 51 53 33 21 37 53 63 1 53 47 1 53 5 21 85 1 174 254 82 210 135 135 210 1 174 62 62 153 71 73 44 4 44 73 71 153 74 0 0 2 0 85 0 0 2 3 2 44 0 11 0 15 0 68 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 3 62 89 187 0 4 0 1 0 1 0 4 43 184 0 15 16 185 0 13 0 1 244 184 0 0 220 184 0 4 16 184 0 5 220 184 0 4 16 184 0 7 208 184 0 1 16 184 0 9 208 48 49 37 53 35 53 51 53 51 21 51 21 35 21 7 53 33 21 1 11 182 182 66 182 182 248 1 174 127 177 62 190 190 62 177 127 62 62 0 1 0 111 1 28 1 233 2 158 0 9 0 38 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 13 62 89 184 0 3 220 184 0 0 208 186 0 6 0 1 0 3 17 18 57 48 49 27 1 51 19 35 47 1 35 15 1 111 153 72 153 72 66 49 4 49 66 1 28 1 130 254 126 176 133 133 176 0 0 0 1 0 85 0 65 2 3 2 83 0 19 0 67 0 187 0 8 0 1 0 14 0 4 43 184 0 14 16 184 0 15 220 185 0 18 0 1 244 184 0 1 208 184 0 0 220 184 0 15 16 184 0 4 208 184 0 14 16 184 0 5 208 184 0 8 16 184 0 9 220 184 0 8 16 184 0 11 208 48 49 63 1 35 53 51 55 35 53 33 55 51 7 51 21 35 7 51 21 33 7 112 76 103 139 91 230 1 10 76 61 76 103 139 91 230 254 246 76 65 127 62 152 62 127 127 62 152 62 127 0 0 0 1 0 76 0 255 2 12 1 149 0 25 0 39 0 187 0 12 0 1 0 5 0 4 43 187 0 0 0 1 0 17 0 4 43 184 0 0 16 184 0 8 208 184 0 12 16 184 0 22 208 48 49 1 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 62 2 55 23 14 1 1 132 30 47 41 39 21 23 41 17 53 26 72 38 30 47 41 39 21 12 21 21 18 9 53 26 72 1 1 26 32 26 34 52 23 70 55 26 32 26 7 19 34 26 24 70 54 0 255 255 0 76 0 149 2 12 2 0 2 38 4 127 0 107 0 6 4 127 0 150 0 0 0 1 0 85 0 104 2 3 1 105 0 5 0 13 0 187 0 3 0 1 0 2 0 4 43 48 49 37 53 33 53 33 17 1 193 254 148 1 174 104 195 62 254 255 0 1 0 85 0 104 2 3 1 105 0 5 0 0 55 17 33 21 33 21 85 1 174 254 148 104 1 1 62 195 0 0 0 1 0 96 0 104 1 248 2 58 0 21 0 0 55 53 52 62 2 51 50 30 2 29 1 35 53 52 38 35 34 6 29 1 96 31 54 75 44 44 75 54 31 65 76 63 63 76 104 251 49 79 56 31 31 56 79 49 251 239 78 83 83 78 239 0 0 0 0 1 0 85 0 104 2 3 2 44 0 5 0 0 55 17 51 17 33 21 85 66 1 108 104 1 196 254 122 62 0 0 0 3 255 252 0 150 2 92 1 251 0 37 0 48 0 60 0 90 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 7 62 89 187 0 49 0 1 0 0 0 4 43 187 0 38 0 1 0 9 0 4 43 187 0 19 0 1 0 43 0 4 43 186 0 3 0 0 0 28 17 18 57 184 0 3 16 184 0 58 208 184 0 24 208 184 0 3 16 184 0 40 208 184 0 28 16 185 0 55 0 1 244 48 49 37 34 38 39 35 14 3 35 34 46 2 53 52 62 2 51 50 30 2 23 51 62 1 51 50 30 2 21 20 14 2 37 50 55 46 1 35 34 6 21 20 22 5 50 54 53 52 38 35 34 6 7 30 1 1 193 55 79 38 4 11 28 35 43 26 27 49 37 21 23 39 53 31 25 41 35 28 11 4 31 79 54 33 57 41 23 23 41 57 254 171 64 40 25 52 29 36 43 47 1 82 45 48 52 48 35 61 30 33 62 150 57 62 18 35 29 17 24 42 56 32 39 62 43 23 16 28 36 21 53 64 25 46 63 37 42 69 48 27 83 88 49 43 45 41 41 53 4 61 43 48 63 49 55 62 49 0 2 0 175 1 173 1 170 2 173 0 19 0 31 0 23 0 187 0 10 0 1 0 26 0 4 43 187 0 20 0 1 0 0 0 4 43 48 49 1 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 1 44 25 45 35 20 20 35 45 25 25 46 34 21 21 34 46 25 34 42 42 34 33 42 42 1 173 18 33 47 29 30 47 34 18 18 34 47 30 29 47 33 18 46 46 35 37 46 46 37 35 46 0 0 1 1 1 1 178 1 104 2 178 0 4 0 0 1 19 51 15 1 1 1 22 81 15 34 1 178 1 0 100 156 0 255 255 0 170 1 178 1 192 2 178 2 38 4 135 169 0 0 6 4 135 88 0 0 0 0 1 0 240 1 178 1 87 2 178 0 4 0 0 1 47 1 51 19 1 33 34 15 81 22 1 178 156 100 255 0 0 255 255 0 84 255 69 2 39 1 230 2 6 2 128 0 0 0 2 0 76 255 244 2 11 2 160 0 33 0 49 0 87 0 184 0 0 69 88 184 0 26 47 27 185 0 26 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 10 0 1 0 40 0 4 43 186 0 13 0 0 0 10 17 18 57 184 0 26 16 185 0 19 0 1 244 184 0 0 16 185 0 34 0 1 244 184 0 13 16 185 0 37 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 54 52 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 14 2 39 50 54 55 46 1 35 34 14 2 21 20 30 2 1 2 36 66 50 30 30 56 80 51 41 79 29 1 76 64 32 56 24 38 32 79 47 97 115 38 70 98 51 65 89 16 33 70 33 37 55 36 18 18 31 40 12 27 49 71 45 49 83 60 34 38 34 8 17 8 125 112 27 24 52 32 35 152 155 84 139 99 55 68 108 100 42 34 24 41 57 33 30 47 34 18 0 0 0 1 0 186 255 98 1 185 3 21 0 37 0 0 23 34 39 55 22 51 50 54 53 52 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 30 2 21 20 14 2 233 31 16 9 12 23 42 25 13 15 13 11 30 54 43 15 26 6 10 7 17 11 41 25 13 16 13 11 31 54 158 7 62 4 82 78 55 126 130 127 56 48 84 61 35 4 2 62 2 2 85 77 54 126 130 127 55 49 84 61 35 0 0 0 0 1 1 9 254 112 1 194 3 21 0 17 0 0 1 35 17 52 62 2 51 50 22 23 7 46 1 35 34 6 21 1 84 75 11 31 54 43 14 26 6 9 7 17 11 41 25 254 112 3 193 48 84 61 35 4 2 62 2 2 85 77 0 0 0 1 0 153 255 98 1 84 3 232 0 15 0 0 23 34 39 55 22 51 50 54 53 17 51 17 20 14 2 201 31 17 10 12 23 42 25 75 11 31 54 158 7 62 4 82 78 3 165 252 95 49 84 61 35 0 0 1 0 62 255 161 2 71 3 52 0 15 0 0 5 3 7 39 55 19 30 1 23 51 62 1 55 19 51 3 1 47 150 71 20 134 116 5 8 4 4 3 5 4 178 60 218 95 1 172 32 45 59 254 166 16 32 16 16 32 16 2 249 252 109 0 0 0 255 255 0 43 0 0 2 45 2 144 2 6 2 87 0 0 255 255 0 38 0 0 2 50 2 156 2 6 2 107 0 0 0 2 0 32 0 0 2 56 2 144 0 7 0 17 0 75 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 13 62 89 184 0 0 69 88 184 0 2 47 27 185 0 2 0 3 62 89 186 0 13 0 3 0 2 17 18 57 184 0 13 16 185 0 5 0 1 244 184 0 3 16 184 0 7 208 186 0 9 0 2 0 3 17 18 57 48 49 1 3 35 3 51 23 51 55 3 51 62 1 63 1 35 23 30 1 2 56 221 94 221 88 62 238 63 184 4 16 32 17 31 196 31 17 33 2 144 253 112 2 144 200 200 253 180 57 109 55 100 100 55 109 0 0 0 0 1 0 70 0 0 1 230 2 144 0 11 0 73 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 185 0 2 0 1 244 186 0 3 0 9 0 0 17 18 57 184 0 3 47 185 0 5 0 1 244 184 0 9 16 185 0 7 0 1 244 48 49 51 53 33 53 33 53 33 53 33 53 33 17 70 1 76 254 240 1 16 254 190 1 150 71 238 71 206 70 253 112 0 0 0 255 255 0 80 0 67 2 9 2 82 2 39 3 130 255 117 1 181 0 39 3 130 255 117 0 79 0 39 3 130 0 140 1 181 0 7 3 130 0 140 0 79 0 0 0 1 0 70 255 136 2 37 2 126 0 13 0 74 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 11 62 89 187 0 12 0 1 0 13 0 4 43 184 0 12 16 184 0 1 208 184 0 4 16 185 0 6 0 1 244 186 0 9 0 12 0 6 17 18 57 184 0 9 16 184 0 2 208 184 0 6 16 184 0 3 208 48 49 23 53 19 3 53 33 21 33 21 19 3 21 33 21 70 238 227 1 184 254 175 212 222 1 119 120 53 1 70 1 70 53 71 4 254 209 254 207 4 71 0 1 0 52 255 136 2 36 2 126 0 7 0 34 0 184 0 7 47 184 0 4 47 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 185 0 5 0 1 244 48 49 23 17 33 17 35 17 33 17 52 1 240 85 254 184 120 2 246 253 10 2 173 253 83 0 0 5 0 27 255 244 2 61 2 138 0 29 0 33 0 37 0 49 0 61 0 0 19 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 23 14 1 3 39 55 23 55 39 55 23 3 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 166 30 50 38 21 24 40 52 28 32 46 17 32 14 28 18 36 49 46 37 23 36 14 28 23 54 118 49 183 33 145 33 167 49 139 61 78 78 61 61 78 78 61 32 46 46 32 32 46 46 1 65 22 42 61 39 39 61 43 22 24 15 39 12 16 64 51 51 63 19 12 39 20 22 254 223 45 188 30 156 30 203 45 253 177 88 78 78 85 85 78 78 88 50 57 59 60 54 54 60 59 57 0 2 0 116 255 244 1 241 2 208 0 35 0 45 0 89 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 186 0 37 0 17 0 0 17 18 57 184 0 37 16 185 0 23 0 1 244 184 0 5 220 184 0 37 16 184 0 11 220 184 0 0 16 185 0 29 0 1 244 184 0 17 16 185 0 43 0 1 244 48 49 5 34 46 2 39 6 7 39 62 1 55 17 52 62 2 51 50 22 21 20 6 7 21 20 30 2 51 50 54 55 23 14 1 3 21 62 1 53 52 38 35 34 6 1 105 30 54 42 28 4 26 28 33 23 43 20 22 39 54 31 57 73 104 92 14 25 33 18 31 43 18 33 26 66 123 59 67 33 25 27 41 12 19 41 65 46 18 18 52 15 30 16 1 11 58 82 53 24 80 75 94 173 78 25 39 52 32 14 27 17 51 23 40 2 17 211 60 128 71 50 42 67 0 0 2 0 26 255 244 2 62 2 148 0 32 0 50 0 67 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 3 62 89 187 0 33 0 1 0 17 0 4 43 184 0 0 16 185 0 26 0 1 244 184 0 10 16 185 0 42 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 29 1 33 34 29 1 20 22 23 30 1 51 50 54 55 51 14 1 3 33 50 61 1 52 39 46 1 35 34 6 7 14 1 29 1 20 1 44 57 99 75 43 43 75 99 57 57 99 75 43 254 98 4 5 3 26 71 41 53 94 35 38 41 113 208 1 24 6 10 26 70 38 41 71 26 3 5 12 53 91 122 70 70 122 91 53 53 91 122 70 8 4 224 6 9 5 29 31 61 51 60 72 1 90 6 224 12 10 26 28 31 27 5 12 5 220 6 0 1 0 17 255 241 2 57 2 7 0 9 0 0 5 1 53 1 23 7 33 21 33 23 1 33 254 240 1 16 43 201 1 182 254 74 201 15 1 9 4 1 9 46 187 68 187 0 0 1 0 33 255 231 2 55 2 15 0 9 0 0 5 17 7 39 1 51 1 7 39 17 1 10 187 46 1 9 4 1 9 46 187 25 1 183 201 42 1 16 254 240 42 201 254 73 0 1 0 29 255 241 2 70 2 7 0 9 0 0 5 39 55 33 53 33 39 55 1 21 1 53 42 201 254 73 1 183 201 42 1 17 15 46 187 68 187 46 254 247 4 0 0 0 0 1 0 33 255 231 2 55 2 15 0 9 0 0 5 1 55 23 17 51 17 55 23 1 1 42 254 247 46 187 68 187 46 254 247 25 1 17 42 201 1 182 254 74 201 42 254 239 0 1 0 96 0 33 2 0 1 193 0 9 0 0 37 1 19 7 3 55 5 7 37 1 1 209 254 201 10 63 5 3 1 124 2 254 237 1 54 33 1 54 254 238 3 1 124 3 5 63 10 254 202 0 0 0 0 1 0 81 0 32 1 241 1 192 0 9 0 0 55 39 1 5 39 37 23 3 39 19 129 48 1 54 254 238 3 1 124 3 5 63 10 32 48 1 54 9 62 5 3 254 132 3 1 18 0 0 0 1 0 86 0 55 1 246 1 215 0 9 0 0 45 1 55 5 1 55 1 3 55 19 1 243 254 132 3 1 18 254 202 48 1 54 9 62 5 55 5 63 10 1 54 48 254 202 1 18 3 254 132 0 0 0 0 1 0 103 0 55 2 7 1 214 0 9 0 0 55 39 19 23 3 1 23 1 37 23 106 3 5 63 10 1 54 48 254 202 1 18 3 55 3 1 124 3 254 237 1 54 47 254 201 10 63 0 0 1 0 17 255 241 2 57 2 7 0 15 0 0 5 1 53 1 23 7 33 21 33 7 21 23 33 21 33 23 1 33 254 240 1 16 43 112 1 93 254 104 67 67 1 152 254 163 112 15 1 9 4 1 9 46 103 54 62 4 62 54 103 0 0 1 0 33 255 231 2 55 2 15 0 15 0 0 55 39 1 51 1 7 39 17 35 17 39 35 7 17 35 17 79 46 1 9 4 1 9 46 103 54 62 4 62 54 213 42 1 16 254 240 42 111 254 163 1 152 67 67 254 104 1 93 0 0 0 1 0 29 255 241 2 70 2 7 0 15 0 0 5 39 55 33 53 33 55 53 39 33 53 33 39 55 1 21 1 53 42 111 254 163 1 152 67 67 254 104 1 93 111 42 1 17 15 46 103 54 62 4 62 54 103 46 254 247 4 0 0 0 0 1 0 33 255 231 2 55 2 15 0 15 0 0 5 1 55 23 17 51 17 23 51 55 17 51 17 55 23 1 1 42 254 247 46 103 54 62 4 62 54 103 46 254 247 25 1 17 42 111 1 92 254 105 67 67 1 151 254 164 111 42 254 239 0 1 255 244 0 37 2 100 1 211 0 15 0 0 37 21 7 39 55 33 23 7 39 53 55 23 7 33 39 55 2 100 179 45 126 254 84 126 45 179 179 45 126 1 172 126 45 254 4 213 38 143 143 38 213 4 213 38 143 143 38 0 0 0 0 1 0 85 255 199 2 3 2 48 0 15 0 0 5 35 39 55 23 17 7 39 55 51 23 7 39 17 55 23 1 46 4 213 38 143 143 38 213 4 213 38 143 143 38 57 178 46 126 1 165 126 45 179 179 45 126 254 91 126 46 0 0 0 0 2 0 60 255 118 2 28 2 48 0 3 0 19 0 0 23 53 33 21 39 35 39 55 23 17 7 39 55 51 23 7 39 17 55 23 60 1 224 238 4 213 38 143 143 38 213 4 213 38 143 143 38 138 64 64 81 178 46 126 1 165 126 45 179 179 45 126 254 91 126 46 0 1 0 74 0 105 2 14 2 43 0 19 0 0 37 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 1 44 49 83 60 34 34 60 83 49 49 83 60 34 34 60 83 105 34 60 83 48 48 83 60 34 34 60 83 48 48 83 60 34 0 2 0 62 0 94 2 26 2 54 0 19 0 39 0 0 37 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 44 52 87 63 36 36 63 87 52 52 87 63 36 36 63 87 52 39 66 49 27 27 49 66 39 39 66 49 27 27 49 66 94 36 63 87 50 50 87 63 36 36 63 87 50 50 87 63 36 50 28 49 68 41 40 69 49 28 28 49 69 40 41 68 49 28 0 0 1 0 87 0 117 2 1 2 31 0 3 0 0 55 17 33 17 87 1 170 117 1 170 254 86 0 0 0 2 0 73 0 103 2 15 2 45 0 3 0 7 0 0 55 17 33 17 37 33 17 33 73 1 198 254 111 1 92 254 164 103 1 198 254 58 49 1 100 0 0 0 0 2 0 73 0 103 2 15 2 45 0 5 0 9 0 0 55 17 55 33 17 7 37 33 17 33 73 59 1 139 51 254 151 1 88 254 168 103 1 149 49 254 113 55 40 1 93 0 0 1 0 33 0 75 2 55 2 98 0 3 0 0 37 9 2 1 44 254 245 1 11 1 11 75 1 12 1 11 254 245 0 1 0 62 0 105 2 26 2 88 0 5 0 0 55 53 19 51 19 21 62 237 2 237 105 3 1 236 254 20 3 0 0 2 0 62 0 105 2 26 2 88 0 5 0 8 0 0 55 53 19 51 19 21 37 33 3 62 237 2 237 254 111 1 70 163 105 3 1 236 254 20 3 44 1 91 0 1 0 62 0 109 2 46 2 72 0 5 0 0 55 17 51 5 21 5 62 3 1 237 254 19 109 1 219 236 3 236 0 2 0 62 0 109 2 46 2 72 0 5 0 8 0 0 55 17 51 5 21 5 55 45 1 62 3 1 237 254 19 44 1 89 254 167 109 1 219 236 3 236 77 160 161 0 0 0 0 1 0 62 0 85 2 26 2 68 0 5 0 0 37 3 53 33 21 3 1 43 237 1 220 237 85 1 236 3 3 254 20 0 0 0 0 2 0 62 0 85 2 26 2 68 0 5 0 8 0 0 37 3 53 33 21 3 39 19 33 1 43 237 1 220 237 1 163 254 186 85 1 236 3 3 254 20 104 1 91 0 0 0 0 1 0 42 0 109 2 26 2 72 0 5 0 0 45 1 53 37 51 17 2 23 254 19 1 237 3 109 236 3 236 254 37 0 0 0 0 2 0 42 0 109 2 26 2 72 0 5 0 8 0 0 45 1 53 37 51 17 39 17 5 2 23 254 19 1 237 3 47 254 168 109 236 3 236 254 37 77 1 65 161 0 0 0 0 1 0 21 0 109 2 113 2 72 0 5 0 0 55 17 51 5 21 5 21 3 2 89 253 167 109 1 219 236 3 236 0 1 255 231 0 109 2 67 2 72 0 5 0 0 45 1 53 37 51 17 2 64 253 167 2 89 3 109 236 3 236 254 37 0 0 0 0 3 0 68 0 100 2 20 2 48 0 3 0 23 0 43 0 0 55 17 33 17 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 55 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 68 1 208 232 50 84 60 34 34 60 84 50 50 84 60 34 34 60 84 50 37 63 45 26 26 45 63 37 37 63 45 26 26 45 63 100 1 204 254 52 4 34 61 83 48 48 83 61 34 34 61 83 48 48 83 61 34 49 26 47 65 39 39 65 47 26 26 47 65 39 39 65 47 26 0 3 0 51 0 91 2 37 2 82 0 19 0 39 0 59 0 0 37 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 55 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 1 44 51 91 67 40 40 67 91 51 51 91 67 40 40 67 91 51 39 71 54 33 33 54 71 39 39 71 54 33 33 54 71 39 28 50 39 23 23 39 50 28 28 50 39 23 23 39 50 91 35 65 93 59 58 93 65 35 35 65 93 58 59 93 65 35 50 27 52 75 48 48 75 52 27 27 52 75 48 48 75 52 27 58 20 38 53 33 32 53 37 21 21 37 53 32 33 53 38 20 0 0 0 2 255 231 255 246 2 113 2 159 0 5 0 9 0 0 7 17 55 33 17 7 37 33 17 33 25 61 2 77 52 253 213 2 20 253 236 10 2 118 51 253 148 61 43 2 52 0 0 2 255 231 255 246 2 194 3 27 0 18 0 30 0 78 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 13 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 13 62 89 184 0 0 69 88 184 0 30 47 27 185 0 30 0 3 62 89 187 0 8 0 1 0 18 0 4 43 184 0 28 16 185 0 11 0 1 244 184 0 15 208 48 49 55 46 1 39 55 30 1 23 51 62 1 55 33 17 33 17 14 1 7 5 17 55 33 54 55 23 14 1 7 17 7 250 28 69 43 56 37 61 20 4 32 105 66 254 39 2 20 68 111 35 254 151 61 1 252 51 57 54 20 41 20 52 104 77 136 64 38 58 126 63 110 218 97 253 204 2 20 95 227 129 124 2 118 51 67 57 50 20 41 23 253 158 61 0 0 1 255 250 255 236 2 98 2 172 0 19 0 0 23 46 1 39 55 30 1 23 51 62 3 55 23 14 3 7 145 30 73 48 56 42 67 23 4 27 78 96 110 59 54 59 112 98 82 28 20 83 143 69 38 63 135 67 89 178 165 146 58 50 55 139 164 185 101 0 0 0 0 1 0 77 255 232 2 17 2 182 0 38 0 15 0 184 0 12 47 186 0 8 0 0 0 3 43 48 49 23 34 38 53 52 62 2 51 50 22 23 17 51 30 3 23 30 3 21 20 6 7 39 62 1 53 52 38 39 17 20 14 2 178 41 60 23 41 58 35 20 34 7 50 4 8 15 24 19 34 44 26 10 21 11 35 8 5 65 60 28 47 63 24 38 38 23 42 33 19 7 5 2 25 10 15 15 19 13 24 46 47 51 28 39 69 23 13 24 41 27 48 83 19 254 105 41 63 42 21 0 0 0 0 1 0 4 255 232 2 81 2 222 0 37 0 31 0 186 0 8 0 0 0 3 43 186 0 13 0 32 0 3 43 184 0 0 16 184 0 19 220 184 0 27 220 48 49 23 34 38 53 52 62 2 51 50 22 23 17 37 17 20 14 2 35 34 38 53 52 62 2 51 50 22 23 17 5 17 20 14 2 104 40 60 22 39 56 33 20 34 7 1 122 27 46 61 33 40 59 22 39 55 33 20 34 7 254 245 27 46 60 24 38 38 23 42 33 19 7 5 2 5 60 253 229 41 62 42 21 38 38 23 42 33 19 7 5 1 107 42 254 124 41 63 42 21 0 1 0 9 255 244 2 79 2 201 0 27 0 0 5 35 46 3 53 52 62 2 51 50 22 23 51 62 1 51 50 30 2 21 20 14 2 1 46 4 90 113 63 23 22 39 53 31 49 74 21 4 21 75 48 31 53 39 22 23 63 113 12 97 148 123 105 54 49 74 50 25 53 67 67 53 25 50 74 49 54 105 123 148 0 1 0 9 0 0 2 79 2 201 0 68 0 0 51 53 62 3 55 35 14 1 35 34 38 53 52 62 2 51 50 22 23 55 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 23 62 1 51 50 30 2 21 20 14 2 35 34 46 2 39 35 30 3 23 21 105 33 56 44 31 9 7 21 71 37 60 73 22 38 52 29 17 34 23 4 25 30 15 5 23 40 53 31 31 53 40 23 5 15 30 25 4 23 34 17 29 52 38 22 19 35 49 30 19 37 34 29 10 7 9 31 44 56 33 40 5 24 47 76 56 50 37 84 68 35 53 35 18 9 11 4 22 43 39 33 13 27 46 33 19 19 33 46 27 13 33 39 43 22 4 11 9 18 35 53 35 34 56 40 22 9 20 33 25 56 76 47 24 5 40 0 0 0 0 1 0 5 255 244 2 83 2 212 0 7 0 0 5 35 1 53 1 51 1 21 1 46 4 254 219 1 37 4 1 37 12 1 111 4 1 109 254 147 4 0 0 0 0 1 0 9 0 0 2 79 2 212 0 37 0 0 51 53 62 3 55 35 14 1 35 34 38 53 52 62 2 55 51 30 3 21 20 6 35 34 38 39 35 30 3 23 21 105 33 56 44 31 9 7 23 68 42 56 73 26 66 111 86 4 85 112 66 26 73 56 42 68 23 7 9 31 44 56 33 40 5 24 47 76 56 52 38 66 70 45 80 95 122 88 88 122 95 80 45 70 66 38 52 56 76 47 24 5 40 0 0 7 0 9 0 39 2 79 2 109 0 19 0 39 0 51 0 63 0 77 0 85 0 93 0 0 37 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 3 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 7 34 38 39 55 30 1 51 50 54 55 23 14 1 39 50 53 52 35 34 21 20 51 50 53 52 35 34 21 20 1 44 64 107 77 43 43 77 107 64 64 107 77 43 43 77 107 64 53 89 63 35 35 63 89 53 53 89 63 35 35 63 89 26 23 25 25 23 23 26 26 135 23 26 26 23 23 25 25 102 66 81 8 34 14 62 45 45 62 14 34 8 81 130 13 13 13 170 13 13 12 39 43 78 107 63 63 107 78 43 43 78 107 63 63 107 78 43 45 36 65 90 55 55 90 65 36 36 65 90 55 55 90 65 36 1 0 35 29 29 35 35 29 29 35 35 29 29 35 35 29 29 35 188 69 61 13 39 36 36 39 13 61 69 245 15 15 15 15 15 15 15 15 0 0 6 0 29 0 59 2 59 2 89 0 19 0 31 0 43 0 57 0 69 0 81 0 0 37 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 3 50 54 53 52 38 35 34 6 21 20 22 51 50 54 53 52 38 35 34 6 21 20 22 7 50 54 55 39 14 1 35 34 38 39 7 30 1 39 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 1 44 60 100 72 39 39 72 100 60 60 100 72 39 39 72 100 140 23 24 24 23 23 25 25 183 23 25 25 23 23 24 24 57 68 80 11 34 15 64 46 46 64 15 34 11 80 24 7 10 10 7 6 10 10 154 7 10 10 7 7 10 10 59 41 72 99 59 59 99 72 41 41 72 99 59 59 99 72 41 1 30 36 27 26 36 36 26 27 36 36 27 26 36 36 26 27 36 196 66 63 13 39 38 38 39 13 63 66 245 9 9 9 10 10 9 9 9 9 9 9 10 10 9 9 9 0 1 255 185 0 9 2 159 2 145 0 31 0 0 37 35 46 5 53 52 62 2 51 50 22 23 51 62 1 51 50 30 2 21 20 14 4 1 46 4 24 73 82 82 67 41 29 53 72 43 66 87 19 4 19 87 66 43 72 53 29 41 67 82 82 73 9 47 63 52 50 68 96 71 49 75 51 26 59 74 74 59 26 51 75 49 71 96 68 50 52 63 0 6 255 224 0 39 2 136 2 109 0 21 0 43 0 57 0 66 0 84 0 96 0 0 55 34 46 2 53 52 54 51 50 22 23 30 1 21 20 14 2 35 14 1 39 50 54 55 50 62 2 53 52 38 35 52 38 35 34 6 21 20 30 2 55 34 38 39 62 1 51 50 22 23 14 3 23 62 1 55 50 22 21 20 6 39 46 1 35 34 6 21 20 22 23 14 1 21 20 22 51 50 54 55 30 1 51 50 54 53 52 38 35 34 6 248 64 103 73 40 148 132 121 138 14 58 69 30 51 68 38 35 112 66 61 99 27 42 62 41 20 58 59 121 114 113 121 34 62 86 52 93 99 24 15 113 88 88 114 15 12 36 52 70 163 10 9 2 29 28 46 180 43 60 28 25 26 13 18 18 13 26 25 28 60 47 23 34 9 11 15 15 11 9 34 39 46 96 147 100 94 99 79 75 11 67 69 38 62 45 24 58 54 41 49 57 22 36 49 27 46 64 72 80 87 75 90 128 83 39 246 44 40 47 55 56 46 20 31 22 11 76 28 56 28 20 28 32 32 169 29 21 16 11 8 11 4 5 10 8 11 17 22 29 14 9 12 11 11 11 8 0 0 4 255 252 0 14 2 92 2 150 0 40 0 47 0 61 0 75 0 0 37 34 46 2 53 52 55 46 1 53 52 54 55 46 1 53 52 62 4 55 22 21 20 6 7 30 1 21 20 6 7 22 21 20 14 2 39 50 54 55 33 30 1 39 23 62 1 51 50 22 23 55 46 1 35 34 6 31 1 62 1 51 50 22 23 55 46 1 35 34 6 1 44 80 114 75 35 91 18 18 61 48 9 12 19 30 39 40 38 14 142 10 11 48 61 18 18 91 35 75 115 79 63 74 6 254 226 6 74 89 28 2 17 18 18 18 2 28 1 33 32 32 32 172 28 2 18 18 18 17 2 28 1 32 32 32 33 14 12 33 56 45 95 23 14 43 33 54 59 9 9 22 21 25 29 16 9 10 15 16 39 79 20 23 11 9 59 54 33 43 14 23 95 45 56 33 12 95 56 59 59 56 203 2 35 31 31 35 2 65 55 55 65 2 35 31 31 35 2 65 55 55 0 0 0 6 255 230 0 39 2 114 2 109 0 21 0 41 0 53 0 67 0 81 0 93 0 0 37 34 38 39 38 53 52 54 55 62 1 51 50 22 23 30 1 21 20 7 14 1 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 55 34 38 53 52 54 51 50 22 21 20 6 39 23 62 1 51 50 22 23 55 46 1 35 34 6 31 1 62 1 51 50 22 23 55 46 1 35 34 6 7 34 38 53 52 54 51 50 22 21 20 6 1 44 90 139 34 63 21 25 22 148 110 110 148 22 25 21 63 34 139 90 51 88 64 37 33 63 89 55 56 88 63 33 37 64 88 51 98 95 103 90 90 103 95 251 32 2 16 18 18 16 2 32 2 34 32 32 34 168 32 2 16 18 18 16 2 32 2 34 32 32 34 19 15 22 14 23 23 14 22 39 85 84 12 128 38 37 5 98 95 95 98 5 37 38 128 12 84 85 45 32 65 100 69 61 86 54 25 25 54 86 61 69 100 65 32 174 42 54 83 77 77 83 54 42 74 2 33 29 29 33 2 65 55 55 65 2 33 29 29 33 2 65 55 55 248 11 13 9 6 6 9 13 11 0 0 3 0 45 255 186 2 43 3 88 0 16 0 33 0 42 0 53 0 184 0 0 47 187 0 39 0 1 0 8 0 4 43 186 0 27 0 33 0 3 43 184 0 27 16 184 0 34 220 184 0 4 208 184 0 34 16 184 0 12 208 184 0 0 16 184 0 19 220 48 49 23 39 17 55 51 53 52 54 51 50 22 29 1 51 23 17 7 37 23 51 55 39 62 1 53 52 38 35 34 6 21 20 22 23 3 51 53 52 38 35 34 6 21 85 40 40 46 88 81 81 88 46 40 40 254 243 44 20 44 26 29 27 49 35 35 49 27 29 73 202 50 51 51 50 70 36 2 6 36 153 88 95 95 88 153 36 253 250 36 129 20 20 169 11 41 27 35 48 48 35 27 41 11 1 36 145 60 66 66 60 0 0 0 0 2 0 60 255 210 2 28 2 195 0 19 0 50 0 0 1 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 19 53 35 53 51 53 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 21 51 21 35 21 1 44 37 63 46 26 26 46 63 37 37 63 47 26 26 47 63 4 142 142 45 76 55 31 36 64 88 52 52 88 64 36 31 55 76 45 142 142 1 43 26 47 64 39 39 64 46 26 26 46 64 39 39 64 47 26 254 167 128 62 101 6 39 61 79 45 49 85 63 35 35 63 85 49 45 79 61 39 6 101 62 128 0 2 255 244 0 9 2 101 2 136 0 29 0 49 0 0 55 34 46 2 53 52 62 2 51 50 22 23 55 7 53 37 23 3 35 55 7 30 1 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 228 52 88 64 36 36 64 88 52 37 65 27 158 176 1 15 3 2 59 7 150 28 30 36 64 88 51 37 63 46 27 27 46 63 37 37 63 47 26 26 47 63 9 35 63 85 50 49 85 62 36 18 17 155 7 58 3 3 254 240 177 154 30 79 45 50 85 63 35 57 26 46 65 39 38 64 47 26 26 47 64 38 39 65 46 26 0 0 0 0 2 255 253 0 23 2 91 2 125 0 19 0 62 0 0 37 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 23 39 6 7 21 35 53 46 1 39 7 39 55 38 39 35 53 51 62 1 55 39 55 23 62 1 55 53 51 21 22 23 55 23 7 22 23 51 21 35 6 7 23 1 44 30 50 36 20 20 36 50 30 30 50 36 20 20 36 50 234 88 37 47 64 23 41 18 90 43 88 29 7 108 108 3 18 13 86 43 87 18 43 24 64 45 38 89 43 88 28 8 108 108 7 28 87 192 20 37 51 30 30 51 37 20 20 37 51 30 30 51 37 20 109 90 28 6 116 116 3 17 12 88 44 87 38 47 62 23 41 18 88 44 88 13 18 3 116 116 6 27 87 44 86 36 48 62 46 37 89 0 0 2 0 96 255 246 1 248 2 155 0 5 0 15 0 0 5 3 19 51 19 3 39 51 63 1 47 1 35 15 1 23 1 6 166 166 76 166 166 40 4 64 65 65 64 4 64 65 65 10 1 83 1 82 254 174 254 173 69 133 137 135 134 134 135 137 0 0 0 2 0 49 0 0 2 39 2 155 0 5 0 13 0 0 51 17 19 51 19 17 37 33 17 47 1 35 15 1 49 215 72 215 254 80 1 106 97 82 4 82 97 1 104 1 51 254 205 254 152 60 1 22 143 125 125 143 0 0 255 255 1 1 1 178 1 104 2 178 2 6 4 135 0 0 255 255 0 209 1 94 1 124 2 187 2 6 3 141 0 0 255 255 0 217 1 94 1 132 2 187 2 6 3 142 0 0 0 1 0 226 2 23 1 154 3 61 0 13 0 0 19 53 50 54 53 52 38 35 53 54 22 21 20 6 226 58 60 60 58 91 93 93 2 26 50 49 45 45 50 49 3 78 69 69 78 0 0 0 0 1 0 190 2 23 1 118 3 61 0 13 0 0 1 6 38 53 52 54 23 21 34 6 21 20 22 51 1 118 91 93 93 91 58 60 60 58 2 26 3 78 69 69 78 3 49 50 45 45 49 0 0 1 0 160 1 182 1 196 3 59 0 25 0 0 1 53 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 23 21 1 26 25 45 33 19 25 43 56 31 48 67 22 34 19 47 32 43 53 60 61 1 182 91 16 35 40 47 29 32 49 33 17 36 23 40 19 27 42 37 42 65 32 118 0 0 0 0 2 0 202 0 0 1 142 1 247 0 3 0 7 0 0 51 55 51 23 3 39 51 7 202 93 10 93 103 93 196 93 162 162 1 87 160 160 0 0 0 1 0 202 1 87 1 142 1 247 0 3 0 0 1 39 51 7 1 39 93 196 93 1 87 160 160 0 0 1 0 128 0 230 1 139 1 150 0 17 0 0 37 34 38 39 7 53 55 30 3 51 50 54 55 23 14 1 1 73 32 50 14 105 146 5 13 15 18 10 12 18 8 22 12 32 230 42 54 43 63 60 38 49 27 10 9 6 43 9 15 0 255 255 0 164 2 56 1 108 3 9 2 6 4 236 0 0 255 255 0 236 2 56 1 180 3 9 2 6 4 239 0 0 255 255 0 145 2 56 1 199 2 228 2 6 4 242 0 0 255 255 0 145 2 62 1 199 2 234 2 6 5 10 0 0 0 1 0 249 1 141 1 95 2 204 0 3 0 0 1 3 51 3 1 16 23 102 23 1 141 1 63 254 193 0 0 0 255 255 0 167 2 89 1 177 2 146 2 6 4 246 0 0 255 255 0 236 2 56 1 180 3 9 2 6 4 239 0 0 255 255 0 164 2 56 1 108 3 9 2 6 4 236 0 0 0 1 0 249 255 2 1 95 0 66 0 3 0 0 23 19 51 19 249 23 56 23 254 1 64 254 192 0 255 255 0 127 2 65 1 217 2 209 2 6 4 244 0 0 255 255 0 148 2 76 1 196 2 188 2 6 5 0 0 0 255 255 0 167 2 89 1 177 2 146 2 6 4 246 0 0 255 255 0 144 2 59 1 200 2 218 2 6 4 250 0 0 255 255 0 190 2 57 1 154 2 249 2 6 5 6 0 0 255 255 0 197 2 56 1 237 2 249 2 6 5 8 0 0 255 255 0 234 2 76 1 110 2 204 2 6 4 254 0 0 255 255 0 205 255 30 1 122 0 8 2 6 5 35 0 0 255 255 0 210 255 31 1 151 0 3 2 6 5 37 0 0 0 12 0 53 255 244 2 35 1 242 0 11 0 23 0 35 0 47 0 59 0 71 0 83 0 95 0 106 0 118 0 130 0 142 0 0 5 34 38 53 52 54 51 50 22 21 20 6 39 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 37 34 38 53 52 54 51 50 22 21 20 6 33 34 38 53 52 54 51 50 22 21 20 6 37 34 38 53 52 54 51 50 22 21 20 6 33 34 38 53 52 54 51 50 22 21 20 6 37 34 38 53 52 54 51 50 22 21 20 6 33 34 38 53 52 54 51 50 22 21 20 37 34 38 53 52 54 51 50 22 21 20 6 23 34 38 53 52 54 51 50 22 21 20 6 39 34 38 53 52 54 51 50 22 21 20 6 1 43 14 20 20 14 16 20 20 122 14 21 21 14 15 21 20 196 14 20 20 14 15 21 19 254 205 14 20 20 14 16 20 19 1 96 14 21 21 14 15 20 18 254 98 14 20 20 14 16 21 20 1 151 15 20 20 15 14 22 20 254 100 14 20 20 14 16 20 19 1 96 14 21 21 14 15 20 254 186 14 21 21 14 15 21 20 196 14 20 20 14 15 21 19 123 14 20 20 14 16 20 20 12 19 18 17 19 19 17 18 19 27 19 19 17 18 18 17 19 19 19 19 17 18 18 17 19 19 82 19 17 18 20 20 18 17 19 19 17 18 20 20 18 17 19 109 20 17 18 18 18 18 17 20 20 17 18 18 18 18 17 20 110 20 18 18 18 18 18 18 20 19 18 17 19 19 17 37 82 19 17 19 18 18 19 17 19 1 20 17 18 19 19 18 17 20 27 20 18 17 19 19 17 18 20 0 0 0 0 1 0 164 2 56 1 108 3 9 0 3 0 11 0 186 0 2 0 0 0 3 43 48 49 1 39 55 23 1 65 157 58 142 2 56 153 56 168 0 0 1 0 177 2 185 1 109 3 99 0 3 0 11 0 186 0 2 0 0 0 3 43 48 49 1 39 55 23 1 73 152 47 141 2 185 115 55 128 0 0 1 0 209 2 46 1 77 3 2 0 3 0 11 0 186 0 2 0 0 0 3 43 48 49 1 39 55 23 1 20 67 85 39 2 46 197 15 201 0 0 1 0 236 2 56 1 180 3 9 0 3 0 11 0 186 0 2 0 0 0 3 43 48 49 1 39 55 23 1 23 43 142 58 2 56 41 168 56 0 0 1 0 235 2 185 1 167 3 99 0 3 0 11 0 186 0 2 0 0 0 3 43 48 49 1 39 55 23 1 15 36 141 47 2 185 42 128 55 0 0 1 1 9 2 47 1 141 3 31 0 3 0 11 0 186 0 2 0 0 0 3 43 48 49 1 39 55 23 1 66 57 47 85 2 47 10 230 15 0 0 1 0 145 2 56 1 199 2 228 0 7 0 29 0 186 0 2 0 0 0 3 43 184 0 0 16 184 0 5 208 186 0 7 0 2 0 0 17 18 57 48 49 19 39 55 51 23 7 39 35 180 35 114 82 114 35 118 4 2 56 32 140 140 32 113 0 0 0 1 0 152 2 187 1 192 3 70 0 7 0 29 0 186 0 2 0 0 0 3 43 184 0 0 16 184 0 5 208 186 0 7 0 2 0 0 17 18 57 48 49 19 39 55 51 23 7 39 35 188 36 105 86 105 36 110 4 2 187 26 113 113 26 93 0 0 0 1 0 127 2 65 1 217 2 209 0 27 0 39 0 186 0 19 0 0 0 3 43 184 0 19 16 184 0 5 208 184 0 0 16 184 0 9 208 184 0 5 16 184 0 14 220 184 0 23 208 48 49 1 34 46 2 35 34 6 7 39 62 3 51 50 30 2 51 50 54 55 23 14 3 1 116 27 38 32 29 17 23 22 2 55 1 13 24 37 26 27 38 32 29 18 22 22 2 55 1 13 24 37 2 65 26 32 26 44 35 3 29 50 36 21 26 32 26 44 35 4 29 49 36 21 0 0 0 1 0 123 2 197 1 221 3 73 0 22 0 39 0 186 0 17 0 0 0 3 43 184 0 0 16 184 0 5 220 184 0 0 16 184 0 8 208 184 0 5 16 184 0 12 220 184 0 20 208 48 49 1 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 55 23 14 1 1 119 28 40 33 29 18 19 26 3 56 3 54 45 28 40 33 29 18 40 8 56 3 54 2 197 22 27 22 34 32 4 57 66 22 27 22 66 4 58 65 0 0 1 0 167 2 89 1 177 2 146 0 3 0 11 0 186 0 1 0 0 0 3 43 48 49 19 53 33 21 167 1 10 2 89 57 57 0 1 0 166 2 223 1 178 3 24 0 3 0 11 0 186 0 1 0 0 0 3 43 48 49 19 53 33 21 166 1 12 2 223 57 57 255 255 0 167 2 89 1 177 2 146 2 6 4 246 0 0 255 255 0 166 2 223 1 178 3 24 2 6 4 247 0 0 0 1 0 144 2 59 1 200 2 218 0 21 0 23 0 186 0 11 0 0 0 3 43 184 0 11 16 184 0 5 220 184 0 17 208 48 49 1 34 46 2 39 55 30 3 51 50 62 2 55 23 14 3 1 44 40 58 37 19 2 51 3 15 26 37 24 24 37 26 15 3 51 2 19 38 57 2 59 26 43 54 28 8 19 37 30 18 18 30 37 19 8 28 54 43 26 0 1 0 143 2 60 1 201 2 213 0 21 0 23 0 186 0 11 0 0 0 3 43 184 0 11 16 184 0 5 220 184 0 17 208 48 49 1 34 46 2 39 55 30 3 51 50 62 2 55 23 14 3 1 44 42 58 38 18 1 68 1 9 21 33 25 25 33 21 9 1 68 2 17 38 58 2 60 25 41 54 29 4 21 39 28 17 17 28 39 21 4 29 54 41 25 0 1 0 154 2 193 1 190 3 74 0 17 0 23 0 186 0 9 0 0 0 3 43 184 0 9 16 184 0 6 220 184 0 12 208 48 49 1 34 46 2 39 55 30 1 51 50 54 55 23 14 3 1 44 35 52 36 20 3 50 6 47 43 43 47 6 50 3 20 36 52 2 193 21 35 47 26 8 35 49 49 35 8 26 47 35 21 0 0 1 0 149 2 193 1 195 3 69 0 19 0 23 0 186 0 9 0 0 0 3 43 184 0 9 16 184 0 5 220 184 0 15 208 48 49 1 34 46 2 39 55 30 1 51 50 62 2 55 23 14 3 1 44 42 56 35 17 1 72 1 36 42 21 29 19 9 1 72 2 16 35 56 2 193 21 36 46 25 4 35 51 14 23 31 18 4 25 46 36 21 0 1 0 234 2 76 1 110 2 204 0 11 0 11 0 186 0 6 0 0 0 3 43 48 49 1 34 38 53 52 54 51 50 22 21 20 6 1 44 28 38 38 28 28 38 38 2 76 35 29 29 35 35 29 29 35 0 1 0 241 2 202 1 103 3 59 0 11 0 11 0 186 0 6 0 0 0 3 43 48 49 1 34 38 53 52 54 51 50 22 21 20 6 1 44 25 34 34 25 25 34 34 2 202 31 26 25 31 31 25 26 31 0 2 0 148 2 76 1 196 2 188 0 11 0 23 0 27 0 186 0 0 0 6 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 203 24 31 31 24 24 31 31 170 24 31 31 24 24 31 31 2 76 32 24 23 33 33 23 24 32 32 24 23 33 33 23 24 32 0 0 0 0 2 0 158 2 203 1 186 3 48 0 11 0 23 0 27 0 186 0 6 0 0 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 209 22 29 29 22 22 28 28 160 22 28 28 22 22 29 29 2 203 28 23 23 27 27 23 23 28 28 23 23 27 27 23 23 28 0 0 0 0 1 0 232 2 60 1 124 2 248 0 14 0 23 0 186 0 1 0 0 0 3 43 184 0 1 16 184 0 6 220 184 0 7 220 48 49 1 39 62 1 53 52 39 55 30 1 21 20 14 2 1 12 9 24 32 83 5 69 74 19 31 40 2 60 40 6 21 20 43 4 54 2 47 45 22 31 23 14 0 0 1 0 232 2 186 1 123 3 104 0 14 0 23 0 186 0 1 0 0 0 3 43 184 0 1 16 184 0 6 220 184 0 7 220 48 49 1 39 62 1 53 52 39 55 30 1 21 20 14 2 1 12 9 24 32 83 9 66 72 18 31 40 2 186 38 7 20 19 39 3 48 2 41 38 22 31 23 13 0 0 2 0 139 2 59 1 205 3 45 0 21 0 33 0 31 0 186 0 11 0 0 0 3 43 184 0 11 16 184 0 5 220 184 0 17 208 184 0 22 208 184 0 28 220 48 49 1 34 46 2 39 55 30 3 51 50 62 2 55 23 14 3 39 34 38 53 52 54 51 50 22 21 20 6 1 44 41 59 39 20 2 48 3 16 28 40 26 25 40 29 16 3 48 2 20 39 59 41 24 32 32 24 24 32 32 2 59 26 43 54 28 8 20 39 30 19 19 30 39 20 8 28 54 43 26 130 30 26 26 30 30 26 26 30 0 0 2 0 147 2 193 1 197 3 157 0 17 0 29 0 31 0 186 0 9 0 0 0 3 43 184 0 9 16 184 0 5 220 184 0 13 208 184 0 18 208 184 0 24 220 48 49 1 34 46 2 39 55 30 1 51 50 54 55 23 14 3 39 34 38 53 52 54 51 50 22 21 20 6 1 44 36 54 38 22 3 46 8 53 46 46 53 8 46 3 22 37 55 36 22 30 30 22 22 30 30 2 193 21 35 47 26 8 38 50 50 38 8 26 47 35 21 116 29 23 23 29 29 23 23 29 0 0 0 2 0 190 2 57 1 154 2 249 0 11 0 23 0 23 0 186 0 12 0 0 0 3 43 184 0 12 16 184 0 18 220 184 0 6 220 48 49 1 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 1 44 52 58 58 52 52 58 58 52 24 33 33 24 24 33 33 2 57 55 41 41 55 55 41 41 55 37 34 25 26 33 33 26 25 34 0 0 2 0 203 2 187 1 141 3 112 0 11 0 23 0 23 0 186 0 12 0 0 0 3 43 184 0 12 16 184 0 18 220 184 0 6 220 48 49 1 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 1 44 42 55 55 42 42 55 55 42 20 31 31 20 22 30 30 2 187 49 41 42 49 49 42 41 49 36 28 26 26 28 28 26 26 28 0 0 2 0 197 2 56 1 237 2 249 0 3 0 7 0 27 0 186 0 0 0 2 0 3 43 184 0 0 16 184 0 4 208 184 0 2 16 184 0 6 208 48 49 19 39 55 31 1 39 55 23 243 46 87 58 52 46 87 58 2 56 21 172 28 165 21 172 28 0 2 0 185 2 191 1 238 3 108 0 3 0 7 0 27 0 186 0 2 0 0 0 3 43 184 0 0 16 184 0 4 208 184 0 2 16 184 0 6 208 48 49 19 39 55 31 1 39 55 23 228 43 92 57 54 43 93 56 2 191 21 152 32 141 21 152 32 0 1 0 145 2 62 1 199 2 234 0 7 0 29 0 186 0 2 0 0 0 3 43 186 0 3 0 2 0 0 17 18 57 184 0 2 16 184 0 5 208 48 49 1 39 55 23 51 55 23 7 1 3 114 35 118 4 118 35 114 2 62 140 32 113 113 32 140 0 1 0 152 2 194 1 192 3 77 0 7 0 29 0 186 0 2 0 0 0 3 43 186 0 3 0 2 0 0 17 18 57 184 0 2 16 184 0 5 208 48 49 1 39 55 23 51 55 23 7 1 1 105 36 110 4 110 36 105 2 194 113 26 92 92 26 113 0 1 0 255 2 36 1 73 3 48 0 4 0 11 0 186 0 2 0 0 0 3 43 48 49 1 3 51 21 7 1 2 3 74 14 2 36 1 12 81 187 0 0 0 0 2 0 107 2 56 1 147 2 249 0 3 0 7 0 27 0 186 0 2 0 0 0 3 43 184 0 0 16 184 0 4 208 184 0 2 16 184 0 6 208 48 49 19 39 55 31 1 39 55 23 206 99 58 87 105 99 58 87 2 56 165 28 172 21 165 28 172 0 2 0 106 2 191 1 159 3 108 0 3 0 7 0 27 0 186 0 2 0 0 0 3 43 184 0 0 16 184 0 4 208 184 0 2 16 184 0 6 208 48 49 19 39 55 31 1 39 55 23 212 106 56 93 117 106 57 92 2 191 141 32 152 21 141 32 152 0 1 0 144 2 56 1 200 2 215 0 21 0 23 0 186 0 17 0 6 0 3 43 184 0 17 16 184 0 1 220 184 0 11 208 48 49 19 39 62 3 51 50 30 2 23 7 46 3 35 34 14 2 195 51 2 19 37 58 40 40 57 38 19 2 51 3 15 26 37 24 24 37 26 15 2 56 8 28 54 43 26 26 43 54 28 8 19 37 30 18 18 30 37 0 0 0 1 0 154 2 192 1 190 3 73 0 17 0 23 0 186 0 15 0 6 0 3 43 184 0 15 16 184 0 1 220 184 0 11 208 48 49 19 39 62 3 51 50 30 2 23 7 46 1 35 34 6 204 50 3 20 36 52 35 35 52 36 20 3 50 6 47 43 43 47 2 192 8 26 47 35 21 21 35 47 26 8 35 49 49 0 0 0 0 1 0 245 2 41 1 97 2 235 0 17 0 19 0 186 0 12 0 0 0 3 43 184 0 12 16 184 0 6 220 48 49 1 34 38 53 52 54 55 23 14 1 21 54 51 50 22 21 20 6 1 47 26 32 42 48 18 32 30 8 5 17 28 26 2 41 39 36 37 63 19 34 14 36 20 2 21 23 23 25 0 0 0 0 1 0 220 2 62 1 112 2 248 0 14 0 23 0 186 0 14 0 0 0 3 43 184 0 14 16 184 0 9 220 184 0 8 220 48 49 1 46 3 53 52 54 55 23 6 21 20 22 23 1 76 22 40 31 19 74 69 5 83 32 24 2 62 4 13 22 31 22 45 47 2 54 4 43 20 21 6 0 0 0 1 0 247 2 41 1 99 2 235 0 17 0 19 0 186 0 6 0 12 0 3 43 184 0 6 16 184 0 0 220 48 49 1 39 62 1 53 6 35 34 38 53 52 54 51 50 22 21 20 6 1 9 18 32 30 8 5 17 28 26 20 26 32 42 2 41 34 14 36 20 2 21 23 23 25 39 36 37 63 255 255 0 232 2 60 1 124 2 248 2 6 5 2 0 0 0 1 0 224 255 7 1 136 255 198 0 7 0 0 5 53 35 53 51 53 51 21 1 83 115 115 53 249 72 47 72 191 0 1 0 208 255 7 1 120 255 198 0 7 0 0 23 53 51 21 51 21 35 21 208 53 115 115 249 191 72 47 72 0 0 1 0 224 2 61 1 129 2 202 0 5 0 0 1 53 35 53 51 21 1 79 111 161 2 61 94 47 141 0 0 0 0 1 1 35 1 178 1 192 2 138 0 14 0 11 0 186 0 7 0 0 0 3 43 48 49 1 39 54 53 52 38 39 55 30 1 21 20 14 2 1 43 8 84 8 6 64 10 13 24 40 54 1 178 41 13 77 15 26 14 30 18 38 23 32 47 34 20 0 0 1 0 224 254 253 1 106 255 192 0 13 0 0 1 6 38 53 52 54 23 21 34 6 21 20 22 51 1 106 69 69 69 69 38 39 39 38 254 255 2 52 45 46 52 2 36 32 28 27 32 0 0 1 0 184 255 45 1 160 255 198 0 7 0 0 23 53 51 53 51 21 51 21 184 89 54 89 211 47 106 106 47 0 0 1 0 184 255 7 1 160 255 160 0 7 0 0 5 53 35 53 51 21 35 21 1 17 89 232 89 249 106 47 47 106 0 1 0 184 255 7 1 160 255 198 0 11 0 0 5 53 35 53 51 53 51 21 51 21 35 21 1 17 89 89 54 89 89 249 72 47 72 72 47 72 0 1 0 184 255 106 1 160 255 153 0 3 0 0 23 53 51 21 184 232 150 47 47 0 255 255 0 234 255 42 1 110 255 170 2 7 4 254 0 0 252 222 0 0 255 255 0 148 255 49 1 196 255 161 2 7 5 0 0 0 252 229 0 0 255 255 0 190 255 13 1 154 255 205 2 7 5 6 0 0 252 212 0 0 0 1 0 205 255 30 1 122 255 198 0 13 0 0 23 39 62 1 53 52 38 39 55 30 1 21 20 6 213 8 63 46 36 35 18 65 52 85 226 40 5 23 20 20 19 3 38 8 35 34 44 43 0 1 0 222 2 63 1 139 2 232 0 13 0 0 1 46 1 53 52 54 55 23 14 1 21 20 22 23 1 83 65 52 85 80 8 63 46 36 35 2 63 7 36 34 44 43 5 41 4 23 21 20 19 3 0 0 0 1 0 205 255 30 1 122 0 8 0 15 0 36 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 3 62 89 184 0 10 220 184 0 7 220 184 0 1 220 184 0 0 220 48 49 23 39 62 1 53 52 38 39 55 51 7 30 1 21 20 6 213 8 63 46 34 43 40 54 26 35 38 85 226 40 5 23 22 20 22 6 96 72 8 32 31 44 43 0 0 0 0 1 0 205 255 30 1 122 0 8 0 15 0 36 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 3 62 89 184 0 10 220 184 0 7 220 184 0 1 220 184 0 0 220 48 49 23 39 62 1 53 52 38 39 55 51 7 30 1 21 20 6 213 8 63 46 34 43 40 54 26 35 38 85 226 40 5 23 22 20 22 6 96 72 8 32 31 44 43 0 0 0 0 1 0 210 255 31 1 151 0 3 0 21 0 28 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 3 62 89 186 0 15 0 0 0 3 43 48 49 5 34 38 53 52 62 2 55 51 14 1 21 20 22 51 50 54 55 23 14 1 1 56 44 58 16 25 30 14 58 38 44 36 22 18 27 9 24 17 48 225 45 48 23 40 34 27 11 27 59 33 29 26 13 8 39 16 20 0 1 0 211 255 31 1 149 0 3 0 21 0 28 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 3 62 89 186 0 15 0 0 0 3 43 48 49 5 34 38 53 52 62 2 55 51 14 1 21 20 22 51 50 54 55 23 14 1 1 58 45 58 16 25 30 14 61 37 44 34 21 16 24 9 25 17 45 225 45 46 23 41 34 28 11 26 60 33 26 25 13 8 43 15 21 0 1 1 9 254 246 1 79 255 185 0 3 0 0 1 55 51 23 1 9 6 58 6 254 246 195 195 0 0 1 0 177 255 30 1 167 255 174 0 7 0 0 23 53 51 21 35 53 35 21 177 246 48 150 226 144 144 97 97 0 255 255 0 145 255 33 1 199 255 205 2 7 5 10 0 0 252 227 0 0 255 255 0 144 255 26 1 200 255 185 2 7 4 250 0 0 252 223 0 0 255 255 0 144 255 20 1 200 255 179 2 7 5 15 0 0 252 220 0 0 255 255 0 127 255 34 1 217 255 178 2 7 4 244 0 0 252 225 0 0 255 255 0 167 255 87 1 177 255 144 2 7 4 246 0 0 252 254 0 0 0 1 0 111 0 173 1 233 1 61 0 27 0 39 0 186 0 19 0 0 0 3 43 184 0 19 16 184 0 5 208 184 0 0 16 184 0 8 208 184 0 5 16 184 0 14 220 184 0 23 208 48 49 37 34 46 2 35 34 6 7 39 62 3 51 50 30 2 51 50 54 55 23 14 3 1 138 33 48 41 38 22 22 22 2 55 1 12 23 35 24 33 49 41 37 22 22 22 2 55 2 11 23 35 173 26 32 26 43 35 10 27 47 34 20 26 32 26 43 34 9 27 47 34 20 0 0 0 0 1 0 238 254 253 1 120 255 192 0 13 0 0 19 53 50 54 53 52 38 35 53 54 22 21 20 6 238 38 39 39 38 69 69 69 254 255 36 32 27 28 32 36 2 52 46 45 52 0 0 0 0 1 0 177 255 31 1 167 255 174 0 7 0 0 23 53 51 21 51 53 51 21 177 48 150 48 225 143 96 96 143 0 0 2 0 177 255 16 1 167 255 179 0 3 0 7 0 0 23 53 51 21 39 51 53 35 177 246 198 150 150 240 163 163 40 84 0 0 0 1 0 129 255 22 1 215 255 176 0 29 0 0 23 39 38 54 51 50 22 23 51 62 1 51 50 22 15 1 52 38 35 34 6 29 1 35 53 52 38 35 34 6 182 52 1 50 48 26 38 8 2 8 39 25 48 50 1 52 26 23 23 22 48 23 23 23 25 234 6 78 70 26 32 32 26 70 78 6 60 40 42 38 19 19 38 42 40 0 0 0 0 1 0 206 2 53 1 138 2 227 0 11 0 0 19 39 55 39 55 23 55 23 7 23 7 39 238 32 61 61 32 62 62 32 61 61 32 62 2 53 30 57 57 30 58 58 30 57 57 30 58 0 255 255 0 127 2 65 1 217 2 209 2 6 4 244 0 0 255 255 0 123 2 197 1 221 3 73 2 6 4 245 0 0 0 1 1 11 255 55 1 134 255 194 0 16 0 0 5 34 61 1 51 6 20 21 20 22 51 50 54 55 23 14 1 1 88 77 64 2 18 12 4 8 10 9 10 19 201 92 47 13 29 11 17 14 1 2 49 4 5 0 0 0 0 1 255 63 255 85 3 25 255 143 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 7 53 33 21 193 3 218 171 58 58 0 0 0 0 1 255 102 2 38 2 242 2 207 0 13 0 25 0 187 0 4 0 1 0 11 0 4 43 184 0 11 16 184 0 0 220 184 0 8 208 48 49 3 39 62 1 51 50 22 23 7 46 1 35 34 6 130 24 101 225 128 128 225 101 24 96 225 109 109 225 2 38 42 62 65 65 62 42 58 53 53 0 0 0 3 0 158 2 76 1 186 3 76 0 11 0 23 0 27 0 35 0 186 0 6 0 0 0 3 43 186 0 26 0 24 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 47 1 55 23 204 20 26 26 20 20 25 25 172 20 25 25 20 20 26 26 123 35 82 49 2 76 26 19 20 26 26 20 19 26 26 19 20 26 26 20 19 26 117 24 115 34 0 0 3 0 152 2 203 1 192 3 200 0 11 0 23 0 27 0 35 0 186 0 6 0 0 0 3 43 186 0 26 0 24 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 47 1 55 23 197 20 25 25 20 20 26 26 186 20 26 26 20 20 25 25 124 37 95 53 2 203 26 20 20 25 25 20 20 26 26 20 20 25 25 20 20 26 108 26 119 36 0 0 3 0 139 2 52 1 205 3 31 0 11 0 15 0 27 0 35 0 186 0 6 0 0 0 3 43 186 0 13 0 15 0 3 43 184 0 0 16 184 0 16 208 184 0 6 16 184 0 22 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 23 55 23 7 55 34 38 53 52 54 51 50 22 21 20 6 185 20 26 26 20 20 26 26 53 49 68 75 115 20 26 26 20 20 26 26 2 83 23 20 21 25 25 21 20 23 22 226 13 222 31 23 20 21 25 25 21 20 23 0 3 0 158 2 76 1 186 3 76 0 11 0 23 0 27 0 35 0 186 0 6 0 0 0 3 43 186 0 26 0 24 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 47 1 55 23 204 20 26 26 20 20 25 25 172 20 25 25 20 20 26 26 109 96 49 82 2 76 26 19 20 26 26 20 19 26 26 19 20 26 26 20 19 26 117 105 34 115 0 0 3 0 152 2 203 1 192 3 200 0 11 0 23 0 27 0 35 0 186 0 6 0 0 0 3 43 186 0 26 0 24 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 47 1 55 23 197 20 25 25 20 20 26 26 186 20 26 26 20 20 25 25 122 111 53 95 2 203 26 20 20 25 25 20 20 26 26 20 20 25 25 20 20 26 108 109 36 119 0 0 3 0 145 2 51 1 199 3 6 0 11 0 15 0 27 0 35 0 186 0 6 0 0 0 3 43 186 0 14 0 12 0 3 43 184 0 0 16 184 0 16 208 184 0 6 16 184 0 22 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 23 39 55 23 55 34 38 53 52 54 51 50 22 21 20 6 187 18 24 24 18 17 24 24 93 64 66 41 73 17 24 24 17 18 24 24 2 83 23 19 19 23 23 19 19 23 32 197 14 201 22 23 19 19 23 23 19 19 23 0 3 0 147 2 76 1 197 3 38 0 11 0 23 0 47 0 59 0 186 0 6 0 0 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 184 0 6 16 184 0 32 220 184 0 29 220 184 0 41 208 184 0 24 220 184 0 29 16 184 0 36 220 184 0 44 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 39 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 54 55 23 14 1 204 20 26 26 20 20 25 25 172 20 25 25 20 20 26 26 45 26 36 30 28 18 17 24 3 42 2 42 38 26 36 30 28 18 17 24 3 42 2 42 2 76 26 19 20 26 26 20 19 26 26 19 20 26 26 20 19 26 119 15 19 15 23 23 4 39 53 15 19 15 23 23 4 39 53 0 0 0 3 0 158 2 76 1 186 3 29 0 11 0 23 0 27 0 39 0 186 0 6 0 0 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 184 0 6 16 184 0 24 220 184 0 25 220 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 39 53 33 21 204 20 26 26 20 20 25 25 172 20 25 25 20 20 26 26 250 1 11 2 76 26 19 20 26 26 20 19 26 26 19 20 26 26 20 19 26 162 47 47 0 0 0 0 3 0 152 2 203 1 192 3 139 0 11 0 23 0 27 0 39 0 186 0 6 0 0 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 184 0 6 16 184 0 24 220 184 0 25 220 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 37 53 33 21 197 20 25 25 20 20 26 26 186 20 26 26 20 20 25 25 254 255 1 12 2 203 26 20 20 25 25 20 20 26 26 20 20 25 25 20 20 26 146 46 46 0 0 0 3 0 158 2 76 1 186 3 72 0 11 0 23 0 31 0 53 0 186 0 6 0 0 0 3 43 186 0 26 0 24 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 186 0 27 0 26 0 24 17 18 57 184 0 26 16 184 0 29 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 47 1 55 23 51 55 23 7 204 20 26 26 20 20 25 25 172 20 25 25 20 20 26 26 150 94 30 96 4 96 30 94 2 76 26 19 20 26 26 20 19 26 26 19 20 26 26 20 19 26 132 92 28 73 73 28 92 0 3 0 152 2 203 1 192 3 194 0 11 0 23 0 31 0 53 0 186 0 6 0 0 0 3 43 186 0 26 0 24 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 186 0 27 0 26 0 24 17 18 57 184 0 26 16 184 0 29 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 47 1 55 23 51 55 23 7 197 20 25 25 20 20 26 26 186 20 26 26 20 20 25 25 159 99 33 100 4 100 33 99 2 203 26 20 20 25 25 20 20 26 26 20 20 25 25 20 20 26 124 96 27 75 75 27 96 0 2 0 166 2 58 2 23 3 17 0 7 0 11 0 37 0 186 0 3 0 0 0 3 43 186 0 10 0 8 0 3 43 184 0 0 16 184 0 5 208 186 0 6 0 3 0 5 17 18 57 48 49 19 39 55 51 23 7 39 35 23 39 55 23 195 29 100 68 100 29 103 4 136 35 87 49 2 58 34 92 92 34 72 5 28 120 34 0 2 0 171 2 187 2 11 3 120 0 7 0 11 0 37 0 186 0 3 0 0 0 3 43 186 0 10 0 8 0 3 43 184 0 0 16 184 0 5 208 186 0 6 0 3 0 5 17 18 57 48 49 19 39 55 51 23 7 39 35 23 39 55 23 205 34 93 72 93 34 93 4 123 30 97 35 2 187 26 90 90 26 69 5 32 93 39 0 2 0 53 2 58 1 178 3 17 0 7 0 11 0 37 0 186 0 3 0 0 0 3 43 186 0 10 0 8 0 3 43 184 0 0 16 184 0 5 208 186 0 6 0 3 0 5 17 18 57 48 49 19 39 55 51 23 7 39 35 7 39 55 23 195 29 100 68 100 29 103 4 132 113 48 100 2 58 34 92 92 34 72 5 112 36 117 0 2 0 89 2 187 1 173 3 120 0 7 0 11 0 37 0 186 0 3 0 0 0 3 43 186 0 10 0 8 0 3 43 184 0 0 16 184 0 5 208 186 0 6 0 3 0 5 17 18 57 48 49 19 39 55 51 23 7 39 35 7 39 55 23 205 34 93 72 93 34 93 4 119 90 35 85 2 187 26 90 90 26 69 5 88 37 95 0 2 0 166 2 58 1 253 3 23 0 7 0 23 0 49 0 186 0 3 0 0 0 3 43 186 0 9 0 8 0 3 43 184 0 0 16 184 0 5 208 186 0 6 0 3 0 5 17 18 57 184 0 9 16 184 0 15 220 184 0 16 220 48 49 19 39 55 51 23 7 39 35 23 39 62 1 53 52 38 39 55 30 1 21 20 14 2 195 29 100 68 100 29 103 4 118 9 19 23 32 37 7 59 63 16 26 33 2 58 34 92 92 34 72 7 35 5 18 16 20 19 2 41 2 36 35 20 28 19 12 0 0 2 0 171 2 187 1 251 3 138 0 7 0 21 0 49 0 186 0 3 0 0 0 3 43 186 0 9 0 8 0 3 43 184 0 0 16 184 0 5 208 186 0 6 0 3 0 5 17 18 57 184 0 9 16 184 0 15 220 184 0 16 220 48 49 19 39 55 51 23 7 39 35 23 39 62 1 53 52 38 39 55 30 1 21 20 6 205 34 93 72 93 34 93 4 117 11 19 26 33 38 9 59 61 56 2 187 26 90 90 26 69 14 35 5 15 16 20 17 2 42 2 36 35 38 35 0 0 0 2 0 163 2 58 1 181 3 35 0 7 0 31 0 65 0 186 0 3 0 0 0 3 43 186 0 25 0 8 0 3 43 184 0 0 16 184 0 5 208 186 0 7 0 3 0 5 17 18 57 184 0 25 16 184 0 13 208 184 0 8 16 184 0 16 208 184 0 13 16 184 0 20 220 184 0 28 208 48 49 19 39 55 51 23 7 39 35 55 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 54 55 23 14 1 195 29 100 68 100 29 103 4 67 22 34 29 27 14 15 14 4 43 4 33 35 22 34 29 27 14 15 14 4 43 4 33 2 58 34 88 88 34 69 71 13 16 13 20 22 4 39 50 13 16 13 20 22 4 38 51 0 0 2 0 155 2 187 1 189 3 171 0 7 0 31 0 65 0 186 0 3 0 0 0 3 43 186 0 25 0 8 0 3 43 184 0 0 16 184 0 5 208 186 0 7 0 3 0 5 17 18 57 184 0 25 16 184 0 13 208 184 0 8 16 184 0 16 208 184 0 13 16 184 0 20 220 184 0 28 208 48 49 19 39 55 51 23 7 39 35 55 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 54 55 23 14 1 205 34 93 72 93 34 93 4 68 24 34 29 26 15 18 17 3 45 2 36 41 24 34 29 26 15 18 17 3 45 2 36 2 187 26 87 87 26 66 74 16 18 16 24 22 5 38 53 15 19 15 24 22 5 39 53 0 0 2 0 144 2 59 1 200 3 64 0 21 0 25 0 35 0 186 0 11 0 0 0 3 43 184 0 11 16 184 0 5 220 184 0 17 208 184 0 11 16 184 0 22 220 184 0 24 220 48 49 1 34 46 2 39 55 30 3 51 50 62 2 55 23 14 3 47 1 55 23 1 44 40 58 37 19 2 48 3 15 27 38 25 25 38 27 15 3 48 2 19 38 57 45 39 88 52 2 59 26 43 54 28 8 20 39 30 19 19 30 39 20 8 28 54 43 26 108 29 124 40 0 0 0 2 0 154 2 193 1 190 3 180 0 17 0 21 0 35 0 186 0 9 0 0 0 3 43 184 0 9 16 184 0 5 220 184 0 13 208 184 0 9 16 184 0 18 220 184 0 20 220 48 49 1 34 46 2 39 55 30 1 51 50 54 55 23 14 3 47 1 55 23 1 44 35 52 36 20 3 47 6 48 45 45 48 6 47 3 20 36 52 32 41 95 53 2 193 21 35 47 26 8 37 51 51 37 8 26 47 35 21 98 29 116 36 0 0 0 0 2 0 144 2 59 1 200 3 64 0 21 0 25 0 35 0 186 0 11 0 0 0 3 43 184 0 11 16 184 0 5 220 184 0 17 208 184 0 11 16 184 0 22 220 184 0 24 220 48 49 1 34 46 2 39 55 30 3 51 50 62 2 55 23 14 3 47 1 55 23 1 44 40 58 37 19 2 48 3 15 27 38 25 25 38 27 15 3 48 2 19 38 57 35 101 52 88 2 59 26 43 54 28 8 20 39 30 19 19 30 39 20 8 28 54 43 26 108 113 40 124 0 0 0 2 0 154 2 193 1 190 3 180 0 17 0 21 0 35 0 186 0 9 0 0 0 3 43 184 0 9 16 184 0 5 220 184 0 13 208 184 0 9 16 184 0 18 220 184 0 20 220 48 49 1 34 46 2 39 55 30 1 51 50 54 55 23 14 3 47 1 55 23 1 44 35 52 36 20 3 47 6 48 45 45 48 6 47 3 20 36 52 38 107 53 95 2 193 21 35 47 26 8 37 51 51 37 8 26 47 35 21 98 109 36 116 0 0 0 0 2 0 144 2 59 1 200 3 80 0 21 0 37 0 43 0 186 0 11 0 0 0 3 43 184 0 11 16 184 0 5 220 184 0 17 208 184 0 11 16 184 0 22 220 184 0 23 220 184 0 29 220 184 0 30 220 48 49 1 34 46 2 39 55 30 3 51 50 62 2 55 23 14 3 47 1 62 1 53 52 38 39 55 30 1 21 20 14 2 1 44 40 58 37 19 2 48 3 15 27 38 25 25 38 27 15 3 48 2 19 38 57 67 8 21 27 35 41 7 61 68 17 28 36 2 59 26 43 54 28 8 20 39 30 19 19 30 39 20 8 28 54 43 26 111 36 5 18 16 20 19 2 50 2 40 40 20 29 20 12 0 0 0 0 2 0 154 2 193 1 190 3 184 0 17 0 33 0 43 0 186 0 9 0 0 0 3 43 184 0 9 16 184 0 5 220 184 0 13 208 184 0 9 16 184 0 18 220 184 0 19 220 184 0 25 220 184 0 26 220 48 49 1 34 46 2 39 55 30 1 51 50 54 55 23 14 3 47 1 62 1 53 52 38 39 55 30 1 21 20 14 2 1 44 35 52 36 20 3 47 6 48 45 45 48 6 47 3 20 36 52 58 10 18 26 33 37 8 59 62 16 25 34 2 193 21 35 47 26 8 37 51 51 37 8 26 47 35 21 95 35 5 15 16 20 17 2 42 2 36 35 19 27 19 11 0 2 0 156 2 59 1 188 3 34 0 17 0 41 0 59 0 186 0 9 0 0 0 3 43 186 0 35 0 18 0 3 43 184 0 9 16 184 0 5 220 184 0 13 208 184 0 35 16 184 0 23 208 184 0 18 16 184 0 26 208 184 0 23 16 184 0 30 220 184 0 38 208 48 49 1 34 46 2 39 55 30 1 51 50 54 55 23 14 3 55 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 54 55 23 14 1 1 44 37 52 35 18 2 47 4 46 47 47 46 4 47 2 18 35 52 28 22 34 29 27 14 15 14 4 47 4 35 37 22 34 29 27 14 15 14 4 47 4 35 2 59 19 31 38 19 8 25 43 43 25 8 19 38 31 19 139 13 16 13 21 22 5 38 50 13 16 13 21 21 4 38 50 0 2 0 155 2 196 1 189 3 175 0 17 0 41 0 59 0 186 0 9 0 0 0 3 43 186 0 35 0 18 0 3 43 184 0 9 16 184 0 5 220 184 0 13 208 184 0 35 16 184 0 23 208 184 0 18 16 184 0 26 208 184 0 23 16 184 0 30 220 184 0 38 208 48 49 1 34 46 2 39 55 30 1 51 50 54 55 23 14 3 55 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 54 55 23 14 1 1 44 35 51 35 19 3 46 5 46 46 46 46 5 46 3 19 35 51 31 24 34 29 26 15 18 17 3 45 2 36 41 24 34 29 26 15 18 17 3 45 2 36 2 196 17 30 38 21 8 27 42 42 27 8 21 38 30 17 135 16 18 16 24 23 5 39 53 16 18 16 24 22 5 38 53 0 2 0 171 2 58 1 173 3 36 0 7 0 25 0 13 0 184 0 8 16 185 0 17 0 1 244 48 49 19 39 55 51 23 7 39 35 55 34 46 2 39 55 30 1 51 50 54 55 23 14 3 202 31 95 68 95 31 96 4 2 31 45 31 16 3 38 6 40 42 42 40 6 38 3 16 31 45 2 58 24 83 83 24 62 73 15 26 31 17 10 22 32 32 22 10 17 31 26 15 0 2 0 163 2 187 1 181 3 175 0 7 0 21 0 21 0 187 0 3 0 1 0 6 0 4 43 184 0 3 16 184 0 8 220 48 49 19 39 55 51 23 7 39 35 55 34 38 39 55 30 1 51 50 54 55 23 14 1 205 33 92 72 92 33 93 4 2 66 66 5 46 5 42 44 44 42 5 46 5 66 2 187 26 87 87 26 69 73 56 38 8 23 33 33 23 8 38 56 0 0 2 0 167 2 89 1 177 3 75 0 3 0 7 0 23 0 186 0 1 0 0 0 3 43 184 0 1 16 184 0 4 220 184 0 6 220 48 49 19 53 33 21 47 1 55 23 167 1 10 167 32 135 38 2 89 57 57 104 39 99 49 0 0 0 2 0 166 2 223 1 178 3 200 0 3 0 7 0 23 0 186 0 1 0 0 0 3 43 184 0 1 16 184 0 4 220 184 0 6 220 48 49 19 53 33 21 47 1 55 23 166 1 12 152 31 121 39 2 223 57 57 92 38 103 48 0 0 0 2 0 145 2 62 1 199 3 45 0 11 0 19 0 0 1 34 38 53 52 54 51 50 22 21 20 6 7 39 55 23 51 55 23 7 1 44 24 32 32 24 24 32 32 65 114 31 122 4 122 31 114 2 189 30 26 26 30 30 26 26 30 127 140 28 115 115 28 140 0 0 0 2 0 149 2 194 1 195 3 157 0 11 0 19 0 0 1 34 38 53 52 54 51 50 22 21 20 6 7 39 55 23 51 55 23 7 1 44 22 30 30 22 22 30 30 65 108 28 121 4 121 28 108 3 53 29 23 23 29 29 23 23 29 115 109 30 92 92 30 109 0 0 0 2 0 148 2 47 1 166 3 2 0 14 0 18 0 35 0 186 0 14 0 0 0 3 43 184 0 14 16 184 0 9 220 184 0 8 220 184 0 16 208 184 0 0 16 184 0 18 208 48 49 19 46 3 53 52 54 55 23 6 21 20 22 31 1 55 23 7 245 18 35 27 17 70 59 4 73 26 20 51 43 74 67 2 65 4 14 22 32 22 41 42 2 51 4 39 20 22 5 46 201 14 197 0 0 2 0 138 2 47 1 152 3 2 0 14 0 18 0 39 0 186 0 14 0 0 0 3 43 184 0 14 16 184 0 9 220 184 0 8 220 184 0 0 16 184 0 15 208 184 0 8 16 184 0 17 208 48 49 19 46 3 53 52 54 55 23 6 21 20 22 31 1 39 55 23 235 18 35 27 17 70 59 4 73 26 20 115 64 75 38 2 65 4 14 22 32 22 41 42 2 51 4 39 20 22 5 56 197 14 201 0 0 2 0 159 2 50 1 185 3 39 0 13 0 37 0 55 0 186 0 13 0 0 0 3 43 186 0 22 0 29 0 3 43 184 0 13 16 184 0 7 220 184 0 6 220 184 0 22 16 184 0 34 208 184 0 17 220 184 0 25 208 184 0 29 16 184 0 37 208 48 49 1 46 1 53 52 54 55 23 14 1 21 20 22 23 39 62 1 51 50 30 2 51 50 54 55 23 14 1 35 34 46 2 35 34 6 7 1 71 36 58 63 59 7 37 32 24 18 176 4 35 37 22 34 29 27 14 15 14 4 47 4 35 37 22 34 29 27 14 15 14 4 2 50 7 34 31 30 29 2 39 2 15 14 11 14 5 124 38 50 13 16 13 21 21 4 38 50 13 16 13 21 21 0 0 0 0 2 0 144 2 47 1 172 3 2 0 14 0 18 0 39 0 186 0 1 0 0 0 3 43 184 0 1 16 184 0 6 220 184 0 7 220 184 0 0 16 184 0 15 208 184 0 7 16 184 0 17 208 48 49 19 39 62 1 53 52 39 55 30 1 21 20 14 2 23 39 55 23 180 10 20 27 73 4 59 70 17 27 35 164 50 42 74 2 65 38 5 22 20 39 4 51 2 42 41 22 32 22 14 22 10 201 14 0 2 0 144 2 47 1 159 3 2 0 14 0 18 0 39 0 186 0 1 0 0 0 3 43 184 0 1 16 184 0 6 220 184 0 7 220 184 0 0 16 184 0 15 208 184 0 7 16 184 0 17 208 48 49 19 39 62 1 53 52 39 55 30 1 21 20 14 2 23 39 55 23 180 10 20 27 73 4 59 70 17 27 35 167 63 74 39 2 65 38 5 22 20 39 4 51 2 42 41 22 32 22 14 22 197 14 201 0 2 0 159 2 50 1 185 3 39 0 23 0 37 0 59 0 186 0 25 0 24 0 3 43 186 0 17 0 0 0 3 43 184 0 17 16 184 0 5 208 184 0 0 16 184 0 8 208 184 0 5 16 184 0 12 220 184 0 20 208 184 0 25 16 184 0 31 220 184 0 32 220 48 49 1 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 54 55 23 14 1 7 39 62 1 53 52 38 39 55 30 1 21 20 6 1 109 22 34 29 27 14 15 14 4 47 4 35 37 22 34 29 27 14 15 14 4 47 4 35 129 8 18 24 32 37 7 59 63 58 2 203 13 16 13 21 21 4 38 50 13 16 13 21 21 4 38 50 153 33 5 14 11 14 15 2 39 2 29 30 31 34 0 0 0 1 255 217 1 5 2 127 1 83 0 3 0 0 3 53 33 21 39 2 166 1 5 78 78 0 0 0 0 1 255 217 0 222 2 127 1 122 0 3 0 0 39 53 33 21 39 2 166 222 156 156 0 1 1 5 254 112 1 83 3 232 0 3 0 0 1 17 51 17 1 5 78 254 112 5 120 250 136 0 0 1 0 222 254 112 1 122 3 232 0 3 0 0 19 17 51 17 222 156 254 112 5 120 250 136 0 0 0 3 0 33 1 5 2 55 1 83 0 3 0 7 0 11 0 0 19 53 51 21 51 53 51 21 51 53 51 21 33 134 66 134 66 134 1 5 78 78 78 78 78 78 0 3 0 33 0 222 2 55 1 122 0 3 0 7 0 11 0 0 55 53 51 21 51 53 51 21 51 53 51 21 33 134 66 134 66 134 222 156 156 156 156 156 156 0 0 3 1 5 255 111 1 83 2 231 0 3 0 7 0 11 0 0 5 53 51 21 3 53 51 21 3 53 51 21 1 5 78 78 78 78 78 145 222 222 1 77 222 222 1 77 222 222 0 3 0 222 255 111 1 122 2 231 0 3 0 7 0 11 0 0 23 53 51 21 3 53 51 21 3 53 51 21 222 156 156 156 156 156 145 222 222 1 77 222 222 1 77 222 222 0 0 4 0 18 1 5 2 69 1 83 0 3 0 7 0 11 0 15 0 0 19 53 51 21 51 53 51 21 51 53 51 21 51 53 51 21 18 113 37 113 37 113 37 113 1 5 78 78 78 78 78 78 78 78 0 0 0 4 0 18 0 222 2 69 1 122 0 3 0 7 0 11 0 15 0 0 55 53 51 21 51 53 51 21 51 53 51 21 51 53 51 21 18 113 37 113 37 113 37 113 222 156 156 156 156 156 156 156 156 0 0 0 0 4 1 5 255 87 1 83 3 1 0 3 0 7 0 11 0 15 0 0 5 53 51 21 39 53 51 21 39 53 51 21 39 53 51 21 1 5 78 78 78 78 78 78 78 169 188 188 250 188 188 250 188 188 250 188 188 0 0 0 0 4 0 222 255 87 1 122 3 1 0 3 0 7 0 11 0 15 0 0 23 53 51 21 39 53 51 21 39 53 51 21 39 53 51 21 222 156 156 156 156 156 156 156 169 188 188 250 188 188 250 188 188 250 188 188 0 1 1 5 254 112 2 127 1 83 0 5 0 0 1 17 33 21 33 17 1 5 1 122 254 212 254 112 2 227 78 253 107 0 0 0 0 1 1 5 254 112 2 127 1 122 0 5 0 0 1 17 33 21 33 17 1 5 1 122 254 212 254 112 3 10 156 253 146 0 0 0 0 1 0 222 254 112 2 127 1 83 0 5 0 0 19 17 33 21 33 17 222 1 161 254 251 254 112 2 227 78 253 107 0 1 0 222 254 112 2 127 1 122 0 5 0 0 19 17 33 21 33 17 222 1 161 254 251 254 112 3 10 156 253 146 0 1 255 217 254 112 1 83 1 83 0 5 0 0 3 53 33 17 35 17 39 1 122 78 1 5 78 253 29 2 149 0 0 1 255 217 254 112 1 83 1 122 0 5 0 0 39 53 33 17 35 17 39 1 122 78 222 156 252 246 2 110 0 0 0 1 255 217 254 112 1 122 1 83 0 5 0 0 3 53 33 17 35 17 39 1 161 156 1 5 78 253 29 2 149 0 0 1 255 217 254 112 1 122 1 122 0 5 0 0 39 53 33 17 35 17 39 1 161 156 222 156 252 246 2 110 0 0 0 1 1 5 1 5 2 127 3 232 0 5 0 0 1 17 51 17 33 21 1 5 78 1 44 1 5 2 227 253 107 78 0 1 1 5 0 222 2 127 3 232 0 5 0 0 37 17 51 17 33 21 1 5 78 1 44 222 3 10 253 146 156 0 0 1 0 222 1 5 2 127 3 232 0 5 0 0 19 17 51 17 33 21 222 156 1 5 1 5 2 227 253 107 78 0 0 1 0 222 0 222 2 127 3 232 0 5 0 0 55 17 51 17 33 21 222 156 1 5 222 3 10 253 146 156 0 0 0 1 255 217 1 5 1 83 3 232 0 5 0 0 3 53 33 17 51 17 39 1 44 78 1 5 78 2 149 253 29 0 0 1 255 217 0 222 1 83 3 232 0 5 0 0 39 53 33 17 51 17 39 1 44 78 222 156 2 110 252 246 0 0 0 1 255 217 1 5 1 122 3 232 0 5 0 0 3 53 33 17 51 17 39 1 5 156 1 5 78 2 149 253 29 0 0 1 255 217 0 222 1 122 3 232 0 5 0 0 39 53 33 17 51 17 39 1 5 156 222 156 2 110 252 246 0 0 0 1 1 5 254 112 2 127 3 232 0 7 0 0 1 17 51 17 33 21 33 17 1 5 78 1 44 254 212 254 112 5 120 253 107 78 253 107 0 0 0 1 1 5 254 112 2 127 3 232 0 7 0 0 1 17 51 17 33 21 33 17 1 5 78 1 44 254 212 254 112 5 120 253 146 156 253 146 0 0 0 1 0 222 254 112 2 127 3 232 0 9 0 0 19 17 51 17 33 21 33 17 35 17 222 156 1 5 254 212 78 1 5 2 227 253 107 78 253 107 2 149 0 0 0 1 0 222 254 112 2 127 3 232 0 9 0 0 19 17 51 17 51 17 33 21 33 17 222 39 78 1 44 254 251 254 112 2 227 2 149 253 107 78 253 107 0 0 0 1 0 222 254 112 2 127 3 232 0 7 0 0 19 17 51 17 33 21 33 17 222 156 1 5 254 251 254 112 5 120 253 107 78 253 107 0 0 0 0 1 0 222 254 112 2 127 3 232 0 9 0 0 55 17 51 17 33 21 33 17 35 17 222 156 1 5 254 212 78 222 3 10 253 146 156 253 146 2 110 0 0 0 0 1 0 222 254 112 2 127 3 232 0 9 0 0 19 17 51 17 51 17 33 21 33 17 222 39 78 1 44 254 251 254 112 3 10 2 110 253 146 156 253 146 0 0 0 1 0 222 254 112 2 127 3 232 0 7 0 0 19 17 51 17 33 21 33 17 222 156 1 5 254 251 254 112 5 120 253 146 156 253 146 0 0 0 0 1 255 217 254 112 1 83 3 232 0 7 0 0 3 53 33 17 51 17 35 17 39 1 44 78 78 1 5 78 2 149 250 136 2 149 0 1 255 217 254 112 1 83 3 232 0 7 0 0 39 53 33 17 51 17 35 17 39 1 44 78 78 222 156 2 110 250 136 2 110 0 0 1 255 217 254 112 1 122 3 232 0 9 0 0 3 53 33 17 51 17 35 17 35 17 39 1 5 156 39 78 1 5 78 2 149 253 29 253 107 2 149 0 0 0 0 1 255 217 254 112 1 122 3 232 0 9 0 0 3 53 33 17 51 17 51 17 35 17 39 1 44 78 39 156 1 5 78 2 149 253 107 253 29 2 149 0 0 0 0 1 255 217 254 112 1 122 3 232 0 7 0 0 3 53 33 17 51 17 35 17 39 1 5 156 156 1 5 78 2 149 250 136 2 149 0 1 255 217 254 112 1 122 3 232 0 9 0 0 39 53 33 17 51 17 35 17 35 17 39 1 5 156 39 78 222 156 2 110 252 246 253 146 2 110 0 1 255 217 254 112 1 122 3 232 0 9 0 0 39 53 33 17 51 17 51 17 35 17 39 1 44 78 39 156 222 156 2 110 253 146 252 246 2 110 0 1 255 217 254 112 1 122 3 232 0 7 0 0 39 53 33 17 51 17 35 17 39 1 5 156 156 222 156 2 110 250 136 2 110 0 0 1 255 217 254 112 2 127 1 83 0 7 0 0 3 53 33 21 33 17 35 17 39 2 166 254 212 78 1 5 78 78 253 107 2 149 0 1 255 217 254 112 2 127 1 122 0 9 0 0 39 53 33 21 33 21 33 17 35 17 39 1 122 1 44 254 212 78 222 156 39 78 253 107 2 110 0 1 255 217 254 112 2 127 1 122 0 9 0 0 3 53 33 53 33 21 33 17 35 17 39 1 44 1 122 254 212 78 1 5 78 39 156 253 146 2 149 0 0 0 0 1 255 217 254 112 2 127 1 122 0 7 0 0 39 53 33 21 33 17 35 17 39 2 166 254 212 78 222 156 156 253 146 2 110 0 0 1 255 217 254 112 2 127 1 83 0 7 0 0 3 53 33 21 33 17 35 17 39 2 166 254 251 156 1 5 78 78 253 107 2 149 0 1 255 217 254 112 2 127 1 122 0 9 0 0 39 53 33 21 33 21 33 17 35 17 39 1 161 1 5 254 251 156 222 156 39 78 253 107 2 110 0 1 255 217 254 112 2 127 1 122 0 9 0 0 3 53 33 53 33 21 33 17 35 17 39 1 5 1 161 254 251 156 1 5 78 39 156 253 146 2 149 0 0 0 0 1 255 217 254 112 2 127 1 122 0 7 0 0 39 53 33 21 33 17 35 17 39 2 166 254 251 156 222 156 156 253 146 2 110 0 0 1 255 217 1 5 2 127 3 232 0 7 0 0 3 53 33 17 51 17 33 21 39 1 44 78 1 44 1 5 78 2 149 253 107 78 0 1 255 217 0 222 2 127 3 232 0 9 0 0 39 53 33 17 51 17 33 21 33 21 39 1 44 78 1 44 254 212 222 156 2 110 253 107 78 39 0 1 255 217 0 222 2 127 3 232 0 9 0 0 3 53 33 17 51 17 33 21 33 53 39 1 44 78 1 44 254 134 1 5 78 2 149 253 146 156 39 0 0 0 0 1 255 217 0 222 2 127 3 232 0 7 0 0 39 53 33 17 51 17 33 21 39 1 44 78 1 44 222 156 2 110 253 146 156 0 0 1 255 217 1 5 2 127 3 232 0 7 0 0 3 53 33 17 51 17 33 21 39 1 5 156 1 5 1 5 78 2 149 253 107 78 0 1 255 217 0 222 2 127 3 232 0 9 0 0 39 53 33 17 51 17 33 21 33 21 39 1 5 156 1 5 254 251 222 156 2 110 253 107 78 39 0 1 255 217 0 222 2 127 3 232 0 9 0 0 3 53 33 17 51 17 33 21 33 53 39 1 5 156 1 5 254 95 1 5 78 2 149 253 146 156 39 0 0 0 0 1 255 217 0 222 2 127 3 232 0 7 0 0 39 53 33 17 51 17 33 21 39 1 5 156 1 5 222 156 2 110 253 146 156 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 3 53 33 17 51 17 33 21 33 17 35 17 39 1 44 78 1 44 254 212 78 1 5 78 2 149 253 107 78 253 107 2 149 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 39 53 33 17 51 17 33 21 33 17 35 17 39 1 44 78 1 44 254 212 78 222 156 2 110 253 107 78 253 107 2 110 0 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 3 53 33 17 51 17 33 21 33 17 35 17 39 1 44 78 1 44 254 212 78 1 5 78 2 149 253 146 156 253 146 2 149 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 39 53 33 17 51 17 33 21 33 17 35 17 39 1 44 78 1 44 254 212 78 222 156 2 110 253 146 156 253 146 2 110 0 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 3 53 33 17 51 17 33 21 33 17 35 17 39 1 5 156 1 5 254 212 78 1 5 78 2 149 253 107 78 253 107 2 149 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 3 53 33 17 51 17 33 21 33 17 35 17 39 1 44 78 1 44 254 251 156 1 5 78 2 149 253 107 78 253 107 2 149 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 3 53 33 17 51 17 33 21 33 17 35 17 39 1 5 156 1 5 254 251 156 1 5 78 2 149 253 107 78 253 107 2 149 0 0 1 255 217 254 112 2 127 3 232 0 13 0 0 39 53 33 17 51 17 33 21 33 21 35 17 35 17 39 1 5 156 1 5 254 251 39 78 222 156 2 110 253 107 78 39 253 146 2 110 0 0 0 1 255 217 254 112 2 127 3 232 0 13 0 0 3 53 33 17 51 17 33 21 33 17 35 17 35 53 39 1 5 156 1 5 254 212 78 39 1 5 78 2 149 253 146 156 253 146 2 110 39 0 0 1 255 217 254 112 2 127 3 232 0 13 0 0 39 53 33 17 51 17 51 21 33 21 33 17 35 17 39 1 44 78 39 1 5 254 251 156 222 156 2 110 253 146 39 78 253 107 2 110 0 0 0 1 255 217 254 112 2 127 3 232 0 13 0 0 3 53 33 53 51 17 51 17 33 21 33 17 35 17 39 1 5 39 78 1 44 254 251 156 1 5 78 39 2 110 253 146 156 253 146 2 149 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 39 53 33 17 51 17 33 21 33 17 35 17 39 1 5 156 1 5 254 212 78 222 156 2 110 253 146 156 253 146 2 110 0 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 39 53 33 17 51 17 33 21 33 17 35 17 39 1 44 78 1 44 254 251 156 222 156 2 110 253 146 156 253 146 2 110 0 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 39 53 33 17 51 17 33 21 33 17 35 17 39 1 5 156 1 5 254 251 156 222 156 2 110 253 107 78 253 107 2 110 0 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 3 53 33 17 51 17 33 21 33 17 35 17 39 1 5 156 1 5 254 251 156 1 5 78 2 149 253 146 156 253 146 2 149 0 0 1 255 217 254 112 2 127 3 232 0 11 0 0 39 53 33 17 51 17 33 21 33 17 35 17 39 1 5 156 1 5 254 251 156 222 156 2 110 253 146 156 253 146 2 110 0 0 0 2 0 75 1 5 2 13 1 83 0 3 0 7 0 0 19 53 51 21 51 53 51 21 75 150 150 150 1 5 78 78 78 78 0 0 0 2 0 75 0 222 2 13 1 122 0 3 0 7 0 0 55 53 51 21 51 53 51 21 75 150 150 150 222 156 156 156 156 0 0 0 0 2 1 5 255 181 1 83 2 163 0 3 0 7 0 0 5 53 51 21 3 53 51 21 1 5 78 78 78 75 250 250 1 244 250 250 0 2 0 222 255 181 1 122 2 163 0 3 0 7 0 0 23 53 51 21 3 53 51 21 222 156 156 156 75 250 250 1 244 250 250 0 0 2 255 217 0 183 2 127 1 161 0 3 0 7 0 23 0 187 0 6 0 1 0 7 0 4 43 187 0 2 0 1 0 3 0 4 43 48 49 3 53 33 21 5 53 33 21 39 2 166 253 90 2 166 1 83 78 78 156 78 78 0 0 0 0 2 0 183 254 112 1 161 3 232 0 3 0 7 0 0 19 17 51 17 51 17 51 17 183 78 78 78 254 112 5 120 250 136 5 120 250 136 0 0 0 1 1 5 254 112 2 127 1 161 0 9 0 0 1 17 33 21 33 21 33 21 33 17 1 5 1 122 254 212 1 44 254 212 254 112 3 49 78 78 78 253 185 0 0 1 0 183 254 112 2 127 1 83 0 9 0 0 19 17 33 21 35 17 35 17 35 17 183 1 200 222 78 78 254 112 2 227 78 253 107 2 149 253 107 0 0 0 0 2 0 183 254 112 2 127 1 161 0 5 0 11 0 0 19 17 33 21 33 17 51 17 33 21 35 17 183 1 200 254 134 78 1 44 222 254 112 3 49 78 253 29 2 149 78 253 185 0 0 0 0 1 255 217 254 112 1 83 1 161 0 9 0 0 3 53 33 17 35 17 33 53 33 53 39 1 122 78 254 212 1 44 1 83 78 252 207 2 71 78 78 0 0 0 0 1 255 217 254 112 1 161 1 83 0 9 0 0 1 17 35 17 35 17 35 53 33 17 1 83 78 78 222 1 200 254 112 2 149 253 107 2 149 78 253 29 0 0 0 2 255 217 254 112 1 161 1 161 0 5 0 11 0 0 3 53 33 17 35 17 5 53 33 17 35 17 39 1 200 78 254 134 1 44 78 1 83 78 252 207 2 227 156 78 253 107 2 71 0 0 0 1 1 5 0 183 2 127 3 232 0 9 0 0 37 17 51 17 33 21 33 21 33 21 1 5 78 1 44 254 212 1 44 183 3 49 253 185 78 78 78 0 0 0 0 1 0 183 1 5 2 127 3 232 0 9 0 0 19 17 51 17 51 17 51 17 51 21 183 78 78 78 222 1 5 2 227 253 107 2 149 253 107 78 0 2 0 183 0 183 2 127 3 232 0 5 0 11 0 0 55 17 51 17 33 21 37 17 51 17 51 21 183 78 1 122 254 212 78 222 183 3 49 253 29 78 156 2 149 253 185 78 0 1 255 217 0 183 1 83 3 232 0 9 0 0 3 53 33 17 51 17 33 53 33 53 39 1 44 78 254 134 1 44 1 83 78 2 71 252 207 78 78 0 0 0 0 1 255 217 1 5 1 161 3 232 0 9 0 0 3 53 51 17 51 17 51 17 51 17 39 222 78 78 78 1 5 78 2 149 253 107 2 149 253 29 0 2 255 217 0 183 1 161 3 232 0 5 0 11 0 0 39 53 33 17 51 17 37 53 51 17 51 17 39 1 122 78 254 56 222 78 183 78 2 227 252 207 156 78 2 71 253 107 0 1 1 5 254 112 2 127 3 232 0 11 0 0 1 17 51 17 33 21 33 21 33 21 33 17 1 5 78 1 44 254 212 1 44 254 212 254 112 5 120 253 185 78 78 78 253 185 0 2 0 183 254 112 2 127 3 232 0 7 0 11 0 0 1 17 51 17 51 21 35 17 35 17 51 17 1 83 78 222 222 234 78 254 112 5 120 253 107 78 253 107 5 120 250 136 0 3 0 183 254 112 2 127 3 232 0 3 0 9 0 15 0 0 19 17 51 17 19 17 51 17 51 21 1 17 33 21 35 17 183 78 78 78 222 254 212 1 44 222 254 112 5 120 250 136 2 227 2 149 253 185 78 253 29 2 149 78 253 185 0 1 255 217 254 112 1 83 3 232 0 11 0 0 3 53 33 17 51 17 35 17 33 53 33 53 39 1 44 78 78 254 212 1 44 1 83 78 2 71 250 136 2 71 78 78 0 0 0 2 255 217 254 112 1 161 3 232 0 7 0 11 0 0 3 53 51 17 51 17 35 17 19 17 51 17 39 222 78 78 156 78 1 5 78 2 149 250 136 2 149 253 107 5 120 250 136 0 0 0 0 3 255 217 254 112 1 161 3 232 0 3 0 9 0 15 0 0 1 17 51 17 1 53 33 17 35 17 39 53 51 17 51 17 1 83 78 254 56 1 44 78 222 222 78 254 112 5 120 250 136 2 71 78 253 107 2 71 156 78 2 71 253 107 0 2 255 217 254 112 2 127 1 161 0 7 0 11 0 0 39 53 33 21 33 17 35 17 37 53 33 21 39 2 166 254 212 78 254 212 2 166 183 78 78 253 185 2 71 156 78 78 0 1 255 217 254 112 2 127 1 83 0 11 0 0 3 53 33 21 35 17 35 17 35 17 35 17 39 2 166 222 78 78 78 1 5 78 78 253 107 2 149 253 107 2 149 0 0 0 0 3 255 217 254 112 2 127 1 161 0 5 0 11 0 15 0 0 39 53 33 17 35 17 19 17 33 21 35 17 1 53 33 21 39 1 44 78 156 1 44 222 254 56 2 166 183 78 253 107 2 71 253 185 2 149 78 253 185 2 227 78 78 0 0 2 255 217 0 183 2 127 3 232 0 7 0 11 0 0 3 53 33 17 51 17 33 21 5 53 33 21 39 1 44 78 1 44 253 90 2 166 1 83 78 2 71 253 185 78 156 78 78 0 0 0 0 1 255 217 1 5 2 127 3 232 0 11 0 0 3 53 51 17 51 17 51 17 51 17 51 21 39 222 78 78 78 222 1 5 78 2 149 253 107 2 149 253 107 78 0 3 255 217 0 183 2 127 3 232 0 5 0 11 0 15 0 0 3 53 51 17 51 17 51 17 51 17 51 21 5 53 33 21 39 222 78 78 78 222 253 90 2 166 1 83 78 2 71 253 107 2 149 253 185 78 156 78 78 0 0 1 255 217 254 112 2 127 3 232 0 19 0 0 3 53 33 17 51 17 33 21 33 21 33 21 33 17 35 17 33 53 33 53 39 1 44 78 1 44 254 212 1 44 254 212 78 254 212 1 44 1 83 78 2 71 253 185 78 78 78 253 185 2 71 78 78 0 0 1 255 217 254 112 2 127 3 232 0 19 0 0 3 53 51 17 51 17 51 17 51 17 51 21 35 17 35 17 35 17 35 17 39 222 78 78 78 222 222 78 78 78 1 5 78 2 149 253 107 2 149 253 107 78 253 107 2 149 253 107 2 149 0 4 255 217 254 112 2 127 3 232 0 5 0 11 0 17 0 23 0 0 3 53 51 17 51 17 5 53 33 17 35 17 55 17 51 17 51 21 1 17 33 21 35 17 39 222 78 254 212 1 44 78 156 78 222 254 212 1 44 222 1 83 78 2 71 253 107 156 78 253 107 2 71 156 2 149 253 185 78 253 29 2 149 78 253 185 0 0 0 1 1 5 254 112 2 127 1 83 0 15 0 0 1 17 52 62 2 59 1 21 35 34 14 2 21 17 1 5 53 92 124 70 39 39 54 95 71 41 254 112 1 144 70 124 92 53 78 41 71 95 54 254 112 0 0 1 255 217 254 112 1 83 1 83 0 15 0 0 33 17 35 17 52 46 2 43 1 53 51 50 30 2 1 83 78 41 71 95 54 39 39 70 124 92 53 254 112 1 144 54 95 71 41 78 53 92 124 0 0 0 0 1 255 217 1 5 1 83 3 232 0 15 0 0 1 17 20 14 2 43 1 53 51 50 62 2 53 17 1 83 53 92 124 70 39 39 54 95 71 41 3 232 254 112 70 124 92 53 78 41 71 95 54 1 144 0 0 1 1 5 1 5 2 127 3 232 0 15 0 0 1 17 51 17 20 30 2 59 1 21 35 34 46 2 1 5 78 41 71 95 54 39 39 70 124 92 53 2 88 1 144 254 112 54 95 71 41 78 53 92 124 0 0 1 255 217 255 17 2 127 3 71 0 5 0 0 7 1 51 21 1 35 39 2 88 78 253 168 78 161 3 232 78 252 24 0 0 0 0 1 255 217 255 17 2 127 3 71 0 5 0 0 19 1 21 35 1 53 39 2 88 78 253 168 3 71 252 24 78 3 232 78 0 0 0 1 255 217 255 17 2 127 3 71 0 15 0 0 19 9 1 51 21 9 1 21 35 9 1 35 53 9 1 53 39 1 5 1 5 78 254 235 1 21 78 254 251 254 251 78 1 21 254 235 3 71 254 77 1 179 78 254 51 254 51 78 1 179 254 77 78 1 205 1 205 78 0 1 255 217 1 5 1 83 1 83 0 3 0 0 3 53 33 21 39 1 122 1 5 78 78 0 0 0 0 1 1 5 1 5 1 83 3 232 0 3 0 0 1 17 51 17 1 5 78 1 5 2 227 253 29 0 0 1 1 5 1 5 2 127 1 83 0 3 0 0 1 53 33 21 1 5 1 122 1 5 78 78 0 0 0 1 1 5 254 112 1 83 1 83 0 3 0 0 1 17 51 17 1 5 78 254 112 2 227 253 29 0 0 1 255 217 0 222 1 83 1 122 0 3 0 0 39 53 33 21 39 1 122 222 156 156 0 1 0 222 1 5 1 122 3 232 0 3 0 0 19 17 51 17 222 156 1 5 2 227 253 29 0 0 0 1 1 5 0 222 2 127 1 122 0 3 0 0 37 53 33 21 1 5 1 122 222 156 156 0 0 0 0 1 0 222 254 112 1 122 1 83 0 3 0 0 19 17 51 17 222 156 254 112 2 227 253 29 0 0 0 1 255 217 0 222 2 127 1 122 0 7 0 0 3 53 33 53 33 21 33 53 39 1 44 1 122 254 134 1 5 78 39 156 39 0 0 1 0 222 254 112 1 122 3 232 0 7 0 0 19 17 51 17 51 17 51 17 222 39 78 39 254 112 2 227 2 149 253 107 253 29 0 1 255 217 0 222 2 127 1 122 0 7 0 0 39 53 33 21 33 21 33 21 39 1 122 1 44 254 212 222 156 39 78 39 0 0 0 1 0 222 254 112 1 122 3 232 0 7 0 0 19 17 51 17 35 17 35 17 222 156 39 78 1 5 2 227 253 29 253 107 2 149 0 1 0 0 1 44 2 88 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 25 1 33 17 2 88 1 44 1 244 254 12 0 0 0 0 1 0 0 255 56 2 88 255 181 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 53 33 21 2 88 200 125 125 0 0 0 1 0 0 255 56 2 88 0 50 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 53 33 21 2 88 200 250 250 0 0 0 1 0 0 255 56 2 88 0 175 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 2 88 200 1 119 254 137 0 1 0 0 255 56 2 88 1 44 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 2 88 200 1 244 254 12 0 1 0 0 255 56 2 88 1 169 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 2 88 200 2 113 253 143 0 1 0 0 255 56 2 88 2 38 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 2 88 200 2 238 253 18 0 1 0 0 255 56 2 88 2 163 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 2 88 200 3 107 252 149 0 1 0 0 255 56 2 88 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 2 88 200 3 232 252 24 0 1 0 0 255 56 2 13 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 2 13 200 3 232 252 24 0 1 0 0 255 56 1 194 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 1 194 200 3 232 252 24 0 1 0 0 255 56 1 119 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 1 119 200 3 232 252 24 0 1 0 0 255 56 1 44 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 1 44 200 3 232 252 24 0 1 0 0 255 56 0 225 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 51 17 225 200 3 232 252 24 0 0 1 0 0 255 56 0 150 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 51 17 150 200 3 232 252 24 0 0 1 0 0 255 56 0 75 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 51 17 75 200 3 232 252 24 0 0 1 1 44 255 56 2 88 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 5 17 33 17 1 44 1 44 200 3 232 252 24 0 0 0 4 0 0 255 56 2 88 3 32 0 2 0 6 0 10 0 14 0 0 21 53 23 33 1 53 1 33 1 51 1 17 1 51 1 30 1 14 254 212 1 74 1 14 253 168 30 2 58 254 212 30 1 14 200 50 50 1 244 50 253 218 3 232 252 74 1 194 1 244 254 62 0 8 0 0 255 56 2 88 3 32 0 2 0 6 0 10 0 14 0 18 0 22 0 26 0 30 0 0 21 53 23 51 39 53 19 51 1 53 1 51 1 53 1 51 1 51 1 53 1 51 1 53 1 51 1 53 39 51 23 30 120 150 180 120 254 212 1 74 120 254 62 1 224 120 253 168 30 2 58 254 62 30 1 164 254 212 30 1 14 150 30 120 200 50 50 250 50 254 212 1 244 50 253 218 2 238 50 252 224 3 232 252 74 200 2 238 253 68 200 1 244 254 62 200 250 200 0 0 0 16 0 0 255 56 2 88 3 32 0 2 0 6 0 10 0 14 0 18 0 22 0 26 0 30 0 34 0 38 0 42 0 46 0 50 0 54 0 58 0 62 0 0 21 53 23 51 39 53 23 51 39 53 19 51 3 53 19 51 1 53 1 51 1 53 1 51 1 53 1 51 1 53 1 51 1 51 1 53 1 51 1 53 1 51 1 53 1 51 1 53 1 51 1 53 3 51 19 53 39 51 23 53 39 51 23 30 45 75 105 45 150 180 45 225 255 45 254 212 1 74 45 254 137 1 149 45 254 62 1 224 45 253 243 2 43 45 253 168 30 2 58 253 243 30 1 239 254 62 30 1 164 254 137 30 1 89 254 212 30 1 14 225 30 195 150 30 120 75 30 45 200 50 50 125 50 175 250 50 254 212 1 119 50 254 87 1 244 50 253 218 2 113 50 253 93 2 238 50 252 224 3 107 50 252 99 3 232 252 74 75 3 107 252 199 75 2 238 253 68 75 2 113 253 193 75 1 244 254 62 75 1 119 254 187 75 250 200 75 125 75 0 0 0 1 0 0 2 163 2 88 3 32 0 3 0 13 0 184 0 3 47 185 0 2 0 1 244 48 49 17 53 33 21 2 88 2 163 125 125 0 0 0 0 1 2 13 255 56 2 88 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 5 17 51 17 2 13 75 200 3 232 252 24 0 0 0 0 1 0 0 255 56 1 44 1 44 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 21 17 33 17 1 44 200 1 244 254 12 0 1 1 44 255 56 2 88 1 44 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 5 17 33 17 1 44 1 44 200 1 244 254 12 0 0 0 1 0 0 1 44 1 44 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 25 1 33 17 1 44 1 44 1 244 254 12 0 0 0 0 1 0 0 255 56 2 88 3 32 0 5 0 11 0 184 0 0 47 184 0 1 220 48 49 21 17 33 17 33 17 1 44 1 44 200 3 232 254 12 254 12 0 0 0 1 0 0 255 56 2 88 3 32 0 7 0 11 0 184 0 6 47 184 0 2 220 48 49 25 1 33 17 33 17 33 17 1 44 1 44 254 212 1 44 1 244 254 12 254 12 1 244 0 0 0 0 1 0 0 255 56 2 88 3 32 0 5 0 11 0 184 0 0 47 184 0 1 220 48 49 21 17 33 17 33 17 2 88 254 212 200 3 232 254 12 254 12 0 0 0 1 0 0 255 56 2 88 3 32 0 5 0 11 0 184 0 3 47 184 0 2 220 48 49 25 1 33 17 33 17 2 88 254 212 1 44 1 244 252 24 1 244 0 0 1 1 44 1 44 2 88 3 32 0 3 0 11 0 184 0 3 47 184 0 2 220 48 49 1 17 33 17 1 44 1 44 1 44 1 244 254 12 0 0 2 0 0 255 56 2 88 3 32 0 3 0 7 0 11 0 184 0 3 47 184 0 5 220 48 49 21 17 33 25 2 33 17 1 44 1 44 200 1 244 254 12 1 244 1 244 254 12 0 0 0 0 1 0 0 255 56 2 88 3 32 0 5 0 11 0 184 0 5 47 184 0 4 220 48 49 21 17 33 17 33 17 1 44 1 44 200 1 244 1 244 252 24 0 0 0 3 0 52 0 0 2 10 2 212 0 21 0 25 0 37 0 132 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 15 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 7 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 7 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 3 62 89 184 0 0 69 88 184 0 25 47 27 185 0 25 0 3 62 89 184 0 17 16 185 0 20 0 1 244 184 0 1 208 184 0 17 16 184 0 4 208 184 0 8 16 185 0 14 0 1 244 184 0 23 16 184 0 26 220 184 0 32 220 48 49 51 17 35 53 55 53 52 54 51 50 22 23 7 38 35 34 29 1 51 21 35 17 51 17 51 17 3 34 38 53 52 54 51 50 22 21 20 6 118 66 66 69 73 23 41 17 17 29 26 69 103 103 214 82 40 28 38 38 28 28 38 38 1 163 62 5 77 75 86 9 7 63 12 94 77 67 254 93 1 230 254 26 2 76 35 29 29 35 35 29 29 35 0 0 0 2 0 57 255 244 2 23 2 212 0 21 0 37 0 130 0 184 0 0 69 88 184 0 26 47 27 185 0 26 0 15 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 15 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 7 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 3 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 3 62 89 184 0 17 16 185 0 20 0 1 244 184 0 1 208 184 0 17 16 184 0 4 208 184 0 8 16 185 0 14 0 1 244 184 0 22 16 185 0 31 0 1 244 48 49 51 17 35 53 55 53 52 54 51 50 22 23 7 38 35 34 29 1 51 21 35 17 5 34 38 53 17 51 17 20 22 51 58 1 55 23 14 1 123 66 66 69 73 23 41 17 18 27 28 68 103 103 1 27 47 40 82 14 9 4 7 7 11 9 22 1 163 62 5 77 75 86 9 7 63 12 94 77 67 254 93 12 56 54 2 102 253 148 20 16 2 62 4 4 0 2 0 99 254 232 2 100 4 36 0 26 0 30 0 0 19 35 17 52 62 6 61 1 35 55 23 35 21 20 14 6 21 17 7 17 51 180 81 27 44 57 59 57 44 27 116 158 156 117 27 44 57 59 57 44 27 81 81 254 232 1 25 59 82 59 41 36 38 52 72 53 225 197 197 243 60 83 59 41 36 38 51 72 52 1 145 51 2 215 0 0 0 2 0 83 255 90 2 5 3 152 0 5 0 19 0 61 0 184 0 1 47 184 0 6 47 184 0 7 47 187 0 4 0 1 0 0 0 4 43 186 0 9 0 6 0 7 17 18 57 184 0 7 16 184 0 12 208 184 0 6 16 184 0 15 208 186 0 17 0 7 0 6 17 18 57 48 49 19 17 51 17 51 21 3 17 51 19 51 39 53 51 17 35 3 35 23 21 83 74 224 186 82 180 4 18 74 84 179 4 19 1 184 1 224 254 94 62 253 162 1 222 254 121 215 176 254 34 1 131 199 188 0 255 255 0 45 255 186 2 43 3 88 2 6 4 202 0 0 0 1 0 0 254 232 2 88 4 16 0 2 0 0 25 1 1 2 88 254 232 5 40 253 108 0 0 0 0 1 255 249 255 31 2 99 3 217 0 5 0 0 23 39 9 1 55 1 42 49 2 17 253 239 49 2 57 225 48 2 45 2 45 48 253 163 0 0 0 1 0 0 254 232 2 101 4 16 0 2 0 0 9 2 2 101 253 155 2 101 254 232 2 148 2 148 0 1 255 245 255 31 2 95 3 217 0 5 0 0 5 9 1 23 9 1 2 46 253 199 2 57 49 253 239 2 17 225 2 93 2 93 48 253 211 253 211 0 0 0 0 0 0 121 5 178 0 1 0 0 0 0 0 0 0 106 0 0 0 1 0 0 0 0 0 1 0 15 0 106 0 1 0 0 0 0 0 2 0 7 0 121 0 1 0 0 0 0 0 3 0 38 0 128 0 1 0 0 0 0 0 4 0 15 0 106 0 1 0 0 0 0 0 5 0 58 0 166 0 1 0 0 0 0 0 6 0 21 0 224 0 1 0 0 0 0 0 7 0 96 0 245 0 1 0 0 0 0 0 8 0 26 1 85 0 1 0 0 0 0 0 9 0 26 1 111 0 1 0 0 0 0 0 11 0 25 1 137 0 1 0 0 0 0 0 13 1 144 1 162 0 1 0 0 0 0 0 14 0 36 3 50 0 1 0 0 0 0 1 0 0 8 3 86 0 1 0 0 0 0 1 1 0 8 3 94 0 1 0 0 0 0 1 2 0 9 3 102 0 1 0 0 0 0 1 3 0 8 3 111 0 1 0 0 0 0 1 4 0 12 3 119 0 1 0 0 0 0 1 5 0 13 3 131 0 1 0 0 0 0 1 6 0 11 3 144 0 1 0 0 0 0 1 7 0 10 3 155 0 1 0 0 0 0 1 8 0 14 3 165 0 1 0 0 0 0 1 9 0 16 3 179 0 1 0 0 0 0 1 10 0 22 3 195 0 1 0 0 0 0 1 11 0 24 3 217 0 1 0 0 0 0 1 12 0 23 3 241 0 1 0 0 0 0 1 13 0 28 4 8 0 1 0 0 0 0 1 14 0 22 4 36 0 1 0 0 0 0 1 15 0 35 4 58 0 1 0 0 0 0 1 16 0 9 3 102 0 1 0 0 0 0 1 17 0 21 4 93 0 1 0 0 0 0 1 18 0 23 3 241 0 3 0 1 4 8 1 0 0 12 4 114 0 3 0 1 4 8 1 1 0 12 4 126 0 3 0 1 4 8 1 2 0 28 4 138 0 3 0 1 4 8 1 3 0 12 4 166 0 3 0 1 4 8 1 4 0 12 4 178 0 3 0 1 4 8 1 5 0 12 4 190 0 3 0 1 4 8 1 6 0 12 4 202 0 3 0 1 4 8 1 7 0 18 4 214 0 3 0 1 4 8 1 8 0 38 4 232 0 3 0 1 4 8 1 9 0 38 5 14 0 3 0 1 4 8 1 10 0 42 5 52 0 3 0 1 4 8 1 11 0 54 5 94 0 3 0 1 4 8 1 12 0 68 5 148 0 3 0 1 4 8 1 13 0 58 5 216 0 3 0 1 4 8 1 14 0 28 6 18 0 3 0 1 4 8 1 15 0 50 6 46 0 3 0 1 4 8 1 16 0 28 4 138 0 3 0 1 4 8 1 17 0 28 6 96 0 3 0 1 4 8 1 18 0 68 5 148 0 3 0 1 4 9 0 0 0 212 6 124 0 3 0 1 4 9 0 1 0 30 7 80 0 3 0 1 4 9 0 2 0 14 7 110 0 3 0 1 4 9 0 3 0 76 7 124 0 3 0 1 4 9 0 4 0 30 7 80 0 3 0 1 4 9 0 5 0 116 7 200 0 3 0 1 4 9 0 6 0 42 8 60 0 3 0 1 4 9 0 7 0 192 8 102 0 3 0 1 4 9 0 8 0 52 9 38 0 3 0 1 4 9 0 9 0 52 9 90 0 3 0 1 4 9 0 11 0 50 9 142 0 3 0 1 4 9 0 13 3 32 9 192 0 3 0 1 4 9 0 14 0 72 12 224 0 3 0 1 4 9 1 0 0 16 13 40 0 3 0 1 4 9 1 1 0 16 13 56 0 3 0 1 4 9 1 2 0 18 13 72 0 3 0 1 4 9 1 3 0 12 13 90 0 3 0 1 4 9 1 4 0 18 13 102 0 3 0 1 4 9 1 5 0 18 13 120 0 3 0 1 4 9 1 6 0 18 13 138 0 3 0 1 4 9 1 7 0 18 13 156 0 3 0 1 4 9 1 8 0 36 13 174 0 3 0 1 4 9 1 9 0 32 13 210 0 3 0 1 4 9 1 10 0 44 13 242 0 3 0 1 4 9 1 11 0 48 14 30 0 3 0 1 4 9 1 12 0 46 14 78 0 3 0 1 4 9 1 13 0 56 14 124 0 3 0 1 4 9 1 14 0 38 14 180 0 3 0 1 4 9 1 15 0 60 14 218 0 3 0 1 4 9 1 16 0 18 13 72 0 3 0 1 4 9 1 17 0 34 15 22 0 3 0 1 4 9 1 18 0 46 14 78 0 3 0 1 4 25 1 0 0 18 15 56 0 3 0 1 4 25 1 1 0 18 15 74 0 3 0 1 4 25 1 2 0 26 15 92 0 3 0 1 4 25 1 3 0 20 15 118 0 3 0 1 4 25 1 4 0 26 15 138 0 3 0 1 4 25 1 5 0 26 15 164 0 3 0 1 4 25 1 6 0 26 15 190 0 3 0 1 4 25 1 7 0 20 15 216 0 3 0 1 4 25 1 8 0 48 15 236 0 3 0 1 4 25 1 9 0 40 16 28 0 3 0 1 4 25 1 10 0 44 16 68 0 3 0 1 4 25 1 11 0 52 16 112 0 3 0 1 4 25 1 12 0 56 16 164 0 3 0 1 4 25 1 13 0 60 16 220 0 3 0 1 4 25 1 14 0 48 17 24 0 3 0 1 4 25 1 15 0 72 17 72 0 3 0 1 4 25 1 16 0 26 15 92 0 3 0 1 4 25 1 17 0 50 17 144 0 3 0 1 4 25 1 18 0 56 16 164 0 3 0 1 8 9 1 0 0 16 13 40 0 3 0 1 8 9 1 1 0 16 13 56 0 3 0 1 8 9 1 2 0 18 13 72 0 3 0 1 8 9 1 3 0 12 13 90 0 3 0 1 8 9 1 4 0 18 13 102 0 3 0 1 8 9 1 5 0 18 13 120 0 3 0 1 8 9 1 6 0 18 13 138 0 3 0 1 8 9 1 7 0 18 13 156 0 3 0 1 8 9 1 8 0 36 13 174 0 3 0 1 8 9 1 9 0 32 13 210 0 3 0 1 8 9 1 10 0 44 13 242 0 3 0 1 8 9 1 11 0 48 14 30 0 3 0 1 8 9 1 12 0 46 14 78 0 3 0 1 8 9 1 13 0 56 14 124 0 3 0 1 8 9 1 14 0 38 14 180 0 3 0 1 8 9 1 15 0 60 14 218 0 3 0 1 8 9 1 16 0 18 13 72 0 3 0 1 8 9 1 17 0 34 15 22 0 3 0 1 8 9 1 18 0 46 14 78 67 111 112 121 114 105 103 104 116 32 50 48 49 48 44 32 50 48 49 50 32 65 100 111 98 101 32 83 121 115 116 101 109 115 32 73 110 99 111 114 112 111 114 97 116 101 100 32 40 104 116 116 112 58 47 47 119 119 119 46 97 100 111 98 101 46 99 111 109 47 41 44 32 119 105 116 104 32 82 101 115 101 114 118 101 100 32 70 111 110 116 32 78 97 109 101 32 212 83 111 117 114 99 101 213 46 83 111 117 114 99 101 32 67 111 100 101 32 80 114 111 82 101 103 117 108 97 114 50 46 48 49 48 59 65 68 66 79 59 83 111 117 114 99 101 67 111 100 101 80 114 111 45 82 101 103 117 108 97 114 59 65 68 79 66 69 86 101 114 115 105 111 110 32 50 46 48 49 48 59 80 83 32 49 46 48 48 48 59 104 111 116 99 111 110 118 32 49 46 48 46 56 52 59 109 97 107 101 111 116 102 46 108 105 98 50 46 53 46 54 51 52 48 54 83 111 117 114 99 101 67 111 100 101 80 114 111 45 82 101 103 117 108 97 114 83 111 117 114 99 101 32 105 115 32 97 32 116 114 97 100 101 109 97 114 107 32 111 102 32 65 100 111 98 101 32 83 121 115 116 101 109 115 32 73 110 99 111 114 112 111 114 97 116 101 100 32 105 110 32 116 104 101 32 85 110 105 116 101 100 32 83 116 97 116 101 115 32 97 110 100 47 111 114 32 111 116 104 101 114 32 99 111 117 110 116 114 105 101 115 46 65 100 111 98 101 32 83 121 115 116 101 109 115 32 73 110 99 111 114 112 111 114 97 116 101 100 80 97 117 108 32 68 46 32 72 117 110 116 44 32 84 101 111 32 84 117 111 109 105 110 101 110 104 116 116 112 58 47 47 119 119 119 46 97 100 111 98 101 46 99 111 109 47 116 121 112 101 84 104 105 115 32 70 111 110 116 32 83 111 102 116 119 97 114 101 32 105 115 32 108 105 99 101 110 115 101 100 32 117 110 100 101 114 32 116 104 101 32 83 73 76 32 79 112 101 110 32 70 111 110 116 32 76 105 99 101 110 115 101 44 32 86 101 114 115 105 111 110 32 49 46 49 46 32 84 104 105 115 32 108 105 99 101 110 115 101 32 105 115 32 97 118 97 105 108 97 98 108 101 32 119 105 116 104 32 97 32 70 65 81 32 97 116 58 32 104 116 116 112 58 47 47 115 99 114 105 112 116 115 46 115 105 108 46 111 114 103 47 79 70 76 46 32 84 104 105 115 32 70 111 110 116 32 83 111 102 116 119 97 114 101 32 105 115 32 100 105 115 116 114 105 98 117 116 101 100 32 111 110 32 97 110 32 212 65 83 32 73 83 213 32 66 65 83 73 83 44 32 87 73 84 72 79 85 84 32 87 65 82 82 65 78 84 73 69 83 32 79 82 32 67 79 78 68 73 84 73 79 78 83 32 79 70 32 65 78 89 32 75 73 78 68 44 32 101 105 116 104 101 114 32 101 120 112 114 101 115 115 32 111 114 32 105 109 112 108 105 101 100 46 32 83 101 101 32 116 104 101 32 83 73 76 32 79 112 101 110 32 70 111 110 116 32 76 105 99 101 110 115 101 32 102 111 114 32 116 104 101 32 115 112 101 99 105 102 105 99 32 108 97 110 103 117 97 103 101 44 32 112 101 114 109 105 115 115 105 111 110 115 32 97 110 100 32 108 105 109 105 116 97 116 105 111 110 115 32 103 111 118 101 114 110 105 110 103 32 121 111 117 114 32 117 115 101 32 111 102 32 116 104 105 115 32 70 111 110 116 32 83 111 102 116 119 97 114 101 46 104 116 116 112 58 47 47 119 119 119 46 97 100 111 98 101 46 99 111 109 47 116 121 112 101 47 108 101 103 97 108 46 104 116 109 108 115 105 109 112 108 101 32 97 115 105 109 112 108 101 32 103 115 101 114 105 102 101 100 32 105 83 97 109 105 32 69 110 103 99 117 114 115 105 118 101 32 98 101 116 97 99 117 114 115 105 118 101 32 116 104 101 116 97 99 117 114 115 105 118 101 32 112 104 105 83 101 114 98 105 97 110 32 98 101 67 121 114 105 108 108 105 99 32 98 114 101 118 101 115 108 97 115 104 101 100 32 122 101 114 111 32 91 48 93 116 121 112 111 103 114 97 112 104 105 99 32 104 121 112 104 101 110 32 91 45 93 116 121 112 111 103 114 97 112 104 105 99 32 97 115 116 101 114 105 115 107 32 91 42 93 115 108 97 115 104 101 100 32 100 111 108 108 97 114 32 115 105 103 110 32 91 36 93 116 121 112 111 103 114 97 112 104 105 99 32 97 108 116 101 114 110 97 116 101 115 32 91 45 44 42 93 115 105 109 112 108 101 32 97 44 32 99 117 114 115 105 118 101 32 98 101 116 97 115 105 109 112 108 101 32 103 44 32 99 117 114 115 105 118 101 32 116 104 101 116 97 44 32 83 101 114 98 105 97 110 32 98 101 83 97 109 105 32 69 110 103 44 32 99 117 114 115 105 118 101 32 112 104 105 3 177 3 192 3 187 3 204 0 32 0 97 3 177 3 192 3 187 3 204 0 32 0 103 0 105 0 32 3 188 3 181 0 32 3 177 3 186 3 193 3 181 3 188 3 204 3 189 3 181 3 194 3 163 3 172 3 188 3 183 0 32 1 74 3 193 3 173 3 201 3 189 0 32 3 178 3 193 3 173 3 201 3 189 0 32 3 184 3 193 3 173 3 201 3 189 0 32 3 198 3 163 3 173 3 193 3 178 3 185 3 186 3 191 0 32 4 49 3 186 3 197 3 193 3 185 3 187 3 187 3 185 3 186 3 204 0 32 3 178 3 193 3 177 3 199 3 205 0 32 0 91 2 216 0 93 3 188 3 183 3 180 3 173 3 189 0 32 3 188 3 181 0 32 3 186 3 172 3 184 3 181 3 196 3 191 0 32 0 91 0 48 0 93 3 196 3 197 3 192 3 191 3 179 3 193 3 177 3 198 3 185 3 186 3 174 0 32 3 192 3 177 3 205 3 187 3 177 0 32 0 91 0 45 0 93 3 196 3 197 3 192 3 191 3 179 3 193 3 177 3 198 3 185 3 186 3 191 3 194 0 32 3 177 3 195 3 196 3 181 3 193 3 175 3 195 3 186 3 191 3 194 0 32 0 91 0 42 0 93 3 195 3 205 3 188 3 178 3 191 3 187 3 191 0 32 3 196 3 191 3 197 0 32 3 180 3 191 3 187 3 177 3 193 3 175 3 191 3 197 0 32 3 188 3 181 0 32 3 186 3 172 3 184 3 181 3 196 3 191 0 32 0 91 0 36 0 93 3 196 3 197 3 192 3 191 3 179 3 193 3 177 3 198 3 185 3 186 3 172 0 32 3 181 3 189 3 177 3 187 3 187 3 177 3 186 3 196 3 185 3 186 3 172 0 32 0 91 0 45 0 44 0 42 0 93 3 193 3 173 3 201 3 189 0 32 3 178 0 44 0 32 3 177 3 192 3 187 3 204 0 32 0 97 3 193 3 173 3 201 3 189 0 32 3 184 0 44 0 32 3 177 3 192 3 187 3 204 0 32 0 103 0 44 0 32 3 163 3 173 3 193 3 178 3 185 3 186 3 191 0 32 4 49 3 193 3 173 3 201 3 189 0 32 3 198 0 44 0 32 3 163 3 172 3 188 3 183 0 32 1 74 0 67 0 111 0 112 0 121 0 114 0 105 0 103 0 104 0 116 0 32 0 50 0 48 0 49 0 48 0 44 0 32 0 50 0 48 0 49 0 50 0 32 0 65 0 100 0 111 0 98 0 101 0 32 0 83 0 121 0 115 0 116 0 101 0 109 0 115 0 32 0 73 0 110 0 99 0 111 0 114 0 112 0 111 0 114 0 97 0 116 0 101 0 100 0 32 0 40 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 119 0 119 0 119 0 46 0 97 0 100 0 111 0 98 0 101 0 46 0 99 0 111 0 109 0 47 0 41 0 44 0 32 0 119 0 105 0 116 0 104 0 32 0 82 0 101 0 115 0 101 0 114 0 118 0 101 0 100 0 32 0 70 0 111 0 110 0 116 0 32 0 78 0 97 0 109 0 101 0 32 32 24 0 83 0 111 0 117 0 114 0 99 0 101 32 25 0 46 0 83 0 111 0 117 0 114 0 99 0 101 0 32 0 67 0 111 0 100 0 101 0 32 0 80 0 114 0 111 0 82 0 101 0 103 0 117 0 108 0 97 0 114 0 50 0 46 0 48 0 49 0 48 0 59 0 65 0 68 0 66 0 79 0 59 0 83 0 111 0 117 0 114 0 99 0 101 0 67 0 111 0 100 0 101 0 80 0 114 0 111 0 45 0 82 0 101 0 103 0 117 0 108 0 97 0 114 0 59 0 65 0 68 0 79 0 66 0 69 0 86 0 101 0 114 0 115 0 105 0 111 0 110 0 32 0 50 0 46 0 48 0 49 0 48 0 59 0 80 0 83 0 32 0 49 0 46 0 48 0 48 0 48 0 59 0 104 0 111 0 116 0 99 0 111 0 110 0 118 0 32 0 49 0 46 0 48 0 46 0 56 0 52 0 59 0 109 0 97 0 107 0 101 0 111 0 116 0 102 0 46 0 108 0 105 0 98 0 50 0 46 0 53 0 46 0 54 0 51 0 52 0 48 0 54 0 83 0 111 0 117 0 114 0 99 0 101 0 67 0 111 0 100 0 101 0 80 0 114 0 111 0 45 0 82 0 101 0 103 0 117 0 108 0 97 0 114 0 83 0 111 0 117 0 114 0 99 0 101 0 32 0 105 0 115 0 32 0 97 0 32 0 116 0 114 0 97 0 100 0 101 0 109 0 97 0 114 0 107 0 32 0 111 0 102 0 32 0 65 0 100 0 111 0 98 0 101 0 32 0 83 0 121 0 115 0 116 0 101 0 109 0 115 0 32 0 73 0 110 0 99 0 111 0 114 0 112 0 111 0 114 0 97 0 116 0 101 0 100 0 32 0 105 0 110 0 32 0 116 0 104 0 101 0 32 0 85 0 110 0 105 0 116 0 101 0 100 0 32 0 83 0 116 0 97 0 116 0 101 0 115 0 32 0 97 0 110 0 100 0 47 0 111 0 114 0 32 0 111 0 116 0 104 0 101 0 114 0 32 0 99 0 111 0 117 0 110 0 116 0 114 0 105 0 101 0 115 0 46 0 65 0 100 0 111 0 98 0 101 0 32 0 83 0 121 0 115 0 116 0 101 0 109 0 115 0 32 0 73 0 110 0 99 0 111 0 114 0 112 0 111 0 114 0 97 0 116 0 101 0 100 0 80 0 97 0 117 0 108 0 32 0 68 0 46 0 32 0 72 0 117 0 110 0 116 0 44 0 32 0 84 0 101 0 111 0 32 0 84 0 117 0 111 0 109 0 105 0 110 0 101 0 110 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 119 0 119 0 119 0 46 0 97 0 100 0 111 0 98 0 101 0 46 0 99 0 111 0 109 0 47 0 116 0 121 0 112 0 101 0 84 0 104 0 105 0 115 0 32 0 70 0 111 0 110 0 116 0 32 0 83 0 111 0 102 0 116 0 119 0 97 0 114 0 101 0 32 0 105 0 115 0 32 0 108 0 105 0 99 0 101 0 110 0 115 0 101 0 100 0 32 0 117 0 110 0 100 0 101 0 114 0 32 0 116 0 104 0 101 0 32 0 83 0 73 0 76 0 32 0 79 0 112 0 101 0 110 0 32 0 70 0 111 0 110 0 116 0 32 0 76 0 105 0 99 0 101 0 110 0 115 0 101 0 44 0 32 0 86 0 101 0 114 0 115 0 105 0 111 0 110 0 32 0 49 0 46 0 49 0 46 0 32 0 84 0 104 0 105 0 115 0 32 0 108 0 105 0 99 0 101 0 110 0 115 0 101 0 32 0 105 0 115 0 32 0 97 0 118 0 97 0 105 0 108 0 97 0 98 0 108 0 101 0 32 0 119 0 105 0 116 0 104 0 32 0 97 0 32 0 70 0 65 0 81 0 32 0 97 0 116 0 58 0 32 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 115 0 99 0 114 0 105 0 112 0 116 0 115 0 46 0 115 0 105 0 108 0 46 0 111 0 114 0 103 0 47 0 79 0 70 0 76 0 46 0 32 0 84 0 104 0 105 0 115 0 32 0 70 0 111 0 110 0 116 0 32 0 83 0 111 0 102 0 116 0 119 0 97 0 114 0 101 0 32 0 105 0 115 0 32 0 100 0 105 0 115 0 116 0 114 0 105 0 98 0 117 0 116 0 101 0 100 0 32 0 111 0 110 0 32 0 97 0 110 0 32 32 24 0 65 0 83 0 32 0 73 0 83 32 25 0 32 0 66 0 65 0 83 0 73 0 83 0 44 0 32 0 87 0 73 0 84 0 72 0 79 0 85 0 84 0 32 0 87 0 65 0 82 0 82 0 65 0 78 0 84 0 73 0 69 0 83 0 32 0 79 0 82 0 32 0 67 0 79 0 78 0 68 0 73 0 84 0 73 0 79 0 78 0 83 0 32 0 79 0 70 0 32 0 65 0 78 0 89 0 32 0 75 0 73 0 78 0 68 0 44 0 32 0 101 0 105 0 116 0 104 0 101 0 114 0 32 0 101 0 120 0 112 0 114 0 101 0 115 0 115 0 32 0 111 0 114 0 32 0 105 0 109 0 112 0 108 0 105 0 101 0 100 0 46 0 32 0 83 0 101 0 101 0 32 0 116 0 104 0 101 0 32 0 83 0 73 0 76 0 32 0 79 0 112 0 101 0 110 0 32 0 70 0 111 0 110 0 116 0 32 0 76 0 105 0 99 0 101 0 110 0 115 0 101 0 32 0 102 0 111 0 114 0 32 0 116 0 104 0 101 0 32 0 115 0 112 0 101 0 99 0 105 0 102 0 105 0 99 0 32 0 108 0 97 0 110 0 103 0 117 0 97 0 103 0 101 0 44 0 32 0 112 0 101 0 114 0 109 0 105 0 115 0 115 0 105 0 111 0 110 0 115 0 32 0 97 0 110 0 100 0 32 0 108 0 105 0 109 0 105 0 116 0 97 0 116 0 105 0 111 0 110 0 115 0 32 0 103 0 111 0 118 0 101 0 114 0 110 0 105 0 110 0 103 0 32 0 121 0 111 0 117 0 114 0 32 0 117 0 115 0 101 0 32 0 111 0 102 0 32 0 116 0 104 0 105 0 115 0 32 0 70 0 111 0 110 0 116 0 32 0 83 0 111 0 102 0 116 0 119 0 97 0 114 0 101 0 46 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 119 0 119 0 119 0 46 0 97 0 100 0 111 0 98 0 101 0 46 0 99 0 111 0 109 0 47 0 116 0 121 0 112 0 101 0 47 0 108 0 101 0 103 0 97 0 108 0 46 0 104 0 116 0 109 0 108 0 115 0 105 0 109 0 112 0 108 0 101 0 32 0 97 0 115 0 105 0 109 0 112 0 108 0 101 0 32 0 103 0 115 0 101 0 114 0 105 0 102 0 101 0 100 0 32 0 105 0 83 0 97 0 109 0 105 0 32 1 74 0 99 0 117 0 114 0 115 0 105 0 118 0 101 0 32 3 178 0 99 0 117 0 114 0 115 0 105 0 118 0 101 0 32 3 184 0 99 0 117 0 114 0 115 0 105 0 118 0 101 0 32 3 198 0 83 0 101 0 114 0 98 0 105 0 97 0 110 0 32 3 198 0 67 0 121 0 114 0 105 0 108 0 108 0 105 0 99 0 32 0 98 0 114 0 101 0 118 0 101 0 32 0 91 2 216 0 93 0 115 0 108 0 97 0 115 0 104 0 101 0 100 0 32 0 122 0 101 0 114 0 111 0 32 0 91 0 48 0 93 0 116 0 121 0 112 0 111 0 103 0 114 0 97 0 112 0 104 0 105 0 99 0 32 0 104 0 121 0 112 0 104 0 101 0 110 0 32 0 91 0 45 0 93 0 116 0 121 0 112 0 111 0 103 0 114 0 97 0 112 0 104 0 105 0 99 0 32 0 97 0 115 0 116 0 101 0 114 0 105 0 115 0 107 0 32 0 91 0 42 0 93 0 115 0 108 0 97 0 115 0 104 0 101 0 100 0 32 0 100 0 111 0 108 0 108 0 97 0 114 0 32 0 115 0 105 0 103 0 110 0 32 0 91 0 36 0 93 0 116 0 121 0 112 0 111 0 103 0 114 0 97 0 112 0 104 0 105 0 99 0 32 0 97 0 108 0 116 0 101 0 114 0 110 0 97 0 116 0 101 0 115 0 32 0 91 0 45 0 44 0 42 0 93 0 115 0 105 0 109 0 112 0 108 0 101 0 32 0 97 0 44 0 32 0 99 0 117 0 114 0 115 0 105 0 118 0 101 0 32 3 178 0 115 0 105 0 109 0 112 0 108 0 101 0 32 0 103 0 44 0 32 0 99 0 117 0 114 0 115 0 105 0 118 0 101 0 32 3 184 0 44 0 32 0 83 0 101 0 114 0 98 0 105 0 97 0 110 0 32 4 49 0 83 0 97 0 109 0 105 0 32 1 74 0 44 0 32 0 99 0 117 0 114 0 115 0 105 0 118 0 101 0 32 3 198 4 63 4 64 4 62 4 65 4 66 4 62 4 57 0 32 4 48 4 63 4 64 4 62 4 65 4 66 4 62 4 57 0 32 0 103 4 86 0 32 4 65 0 32 4 55 4 48 4 65 4 53 4 71 4 58 4 48 4 60 4 56 4 65 4 48 4 48 4 60 4 65 4 58 4 56 4 57 0 32 1 74 4 65 4 58 4 62 4 64 4 62 4 63 4 56 4 65 4 61 4 75 4 57 0 32 3 178 4 65 4 58 4 62 4 64 4 62 4 63 4 56 4 65 4 61 4 75 4 57 0 32 3 184 4 65 4 58 4 62 4 64 4 62 4 63 4 56 4 65 4 61 4 75 4 57 0 32 3 198 4 65 4 53 4 64 4 49 4 65 4 58 4 56 4 57 0 32 4 49 4 58 4 56 4 64 4 56 4 59 4 59 4 56 4 71 4 53 4 65 4 58 4 48 4 79 0 32 4 58 4 64 4 48 4 66 4 58 4 48 0 32 0 91 2 216 0 93 4 55 4 48 4 71 4 53 4 64 4 58 4 61 4 67 4 66 4 75 4 57 0 32 4 61 4 62 4 59 4 76 0 32 0 91 0 48 0 93 4 66 4 56 4 63 4 62 4 51 4 64 4 48 4 68 4 65 4 58 4 56 4 57 0 32 4 52 4 53 4 68 4 56 4 65 0 32 0 91 0 45 0 93 4 66 4 56 4 63 4 62 4 51 4 64 4 48 4 68 4 65 4 58 4 48 4 79 0 32 4 55 4 50 4 53 4 55 4 52 4 62 4 71 4 58 4 48 0 32 0 91 0 42 0 93 4 55 4 48 4 71 4 53 4 64 4 58 4 61 4 67 4 66 4 75 4 57 0 32 4 55 4 61 4 48 4 58 0 32 4 52 4 62 4 59 4 59 4 48 4 64 4 48 0 32 0 91 0 36 0 93 4 66 4 56 4 63 4 62 4 51 4 64 4 48 4 68 4 65 4 58 4 56 4 53 0 32 4 55 4 48 4 60 4 53 4 65 4 66 4 56 4 66 4 53 4 59 4 56 0 32 0 91 0 45 0 44 0 42 0 93 4 63 4 64 4 62 4 65 4 66 4 62 4 57 0 32 4 48 0 44 0 32 4 65 4 58 4 62 4 64 4 62 4 63 4 56 4 65 4 61 4 75 4 57 0 32 3 178 4 65 4 53 4 64 4 49 4 65 4 58 4 56 4 57 0 32 4 49 0 44 0 32 4 63 4 64 4 62 4 65 4 66 4 62 4 57 0 32 0 103 0 44 0 32 4 65 4 58 4 62 4 64 4 62 4 63 4 56 4 65 4 61 4 75 4 57 0 32 3 184 4 65 4 48 4 48 4 60 4 65 4 58 4 56 4 57 0 32 1 74 0 44 0 32 4 65 4 58 4 62 4 64 4 62 4 63 4 56 4 65 4 61 4 75 4 57 0 32 3 198 0 2 0 0 0 0 0 0 255 181 0 50 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 15 0 0 1 2 1 3 0 3 0 36 0 37 0 38 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 47 0 48 0 49 0 50 0 51 0 52 0 53 0 54 0 55 0 56 0 57 0 58 0 59 0 60 0 61 0 68 0 69 0 70 0 71 0 72 0 73 0 74 0 75 0 76 0 77 0 78 0 79 0 80 0 81 0 82 0 83 0 84 0 85 0 86 0 87 0 88 0 89 0 90 0 91 0 92 0 93 0 173 0 201 0 199 0 174 0 98 1 4 1 5 0 99 1 6 1 7 1 8 1 9 1 10 1 11 1 12 1 13 1 14 1 15 1 16 1 17 1 18 1 19 1 20 0 144 1 21 1 22 1 23 1 24 0 100 0 253 1 25 0 255 1 26 1 27 1 28 1 29 1 30 1 31 1 32 0 203 0 101 0 200 1 33 0 202 1 34 1 35 1 36 1 37 1 38 1 39 1 40 1 41 1 42 1 43 1 44 1 45 1 46 1 47 1 48 0 248 1 49 1 50 1 51 1 52 1 53 1 54 1 55 1 56 1 57 1 58 1 59 1 60 0 207 0 204 0 205 1 61 0 206 1 62 0 250 1 63 1 64 1 65 1 66 1 67 1 68 1 69 1 70 1 71 1 72 1 73 1 74 1 75 1 76 1 77 0 226 1 78 1 79 1 80 1 81 1 82 1 83 1 84 0 102 1 85 1 86 1 87 1 88 0 211 0 208 0 209 0 175 0 103 1 89 1 90 1 91 1 92 1 93 1 94 1 95 1 96 1 97 1 98 1 99 1 100 1 101 1 102 1 103 1 104 1 105 1 106 1 107 0 145 1 108 0 176 1 109 1 110 1 111 1 112 1 113 1 114 1 115 1 116 1 117 0 228 1 118 1 119 1 120 1 121 1 122 1 123 1 124 1 125 1 126 1 127 1 128 1 129 0 214 0 212 0 213 1 130 0 104 1 131 1 132 1 133 1 134 1 135 1 136 1 137 1 138 1 139 1 140 1 141 1 142 1 143 1 144 1 145 1 146 1 147 1 148 1 149 1 150 1 151 1 152 1 153 1 154 0 235 1 155 0 187 1 156 1 157 1 158 1 159 1 160 0 230 1 161 1 162 1 163 1 164 0 233 0 237 1 165 1 166 1 167 1 168 1 169 0 106 0 105 0 107 0 109 0 108 1 170 1 171 0 110 1 172 1 173 1 174 1 175 1 176 1 177 1 178 1 179 1 180 1 181 1 182 1 183 1 184 1 185 1 186 0 160 1 187 1 188 1 189 1 190 0 111 0 254 1 191 1 0 1 192 1 193 1 194 1 195 1 196 1 1 0 113 0 112 0 114 1 197 0 115 1 198 1 199 1 200 1 201 1 202 1 203 1 204 1 205 1 206 1 207 1 208 1 209 1 210 1 211 1 212 0 249 1 213 1 214 1 215 1 216 1 217 1 218 1 219 1 220 1 221 1 222 1 223 1 224 0 117 0 116 0 118 1 225 0 119 1 226 1 227 1 228 1 229 1 230 1 231 0 215 1 232 1 233 1 234 1 235 1 236 1 237 1 238 1 239 1 240 1 241 1 242 0 227 1 243 1 244 1 245 1 246 1 247 1 248 1 249 0 120 1 250 1 251 1 252 1 253 1 254 0 122 0 121 0 123 0 125 0 124 1 255 2 0 2 1 2 2 2 3 2 4 2 5 2 6 2 7 2 8 2 9 2 10 2 11 2 12 2 13 2 14 2 15 2 16 2 17 0 161 2 18 0 177 2 19 2 20 2 21 2 22 2 23 2 24 2 25 2 26 2 27 0 229 2 28 2 29 2 30 2 31 2 32 0 137 2 33 2 34 2 35 2 36 2 37 2 38 2 39 2 40 0 127 0 126 0 128 2 41 0 129 2 42 2 43 2 44 2 45 2 46 2 47 2 48 2 49 2 50 2 51 2 52 2 53 2 54 2 55 2 56 2 57 2 58 2 59 2 60 2 61 2 62 2 63 2 64 2 65 0 236 2 66 0 186 2 67 2 68 2 69 2 70 2 71 0 231 2 72 2 73 2 74 2 75 0 234 0 238 2 76 2 77 2 78 2 79 2 80 2 81 2 82 2 83 2 84 2 85 2 86 2 87 2 88 2 89 2 90 2 91 2 92 2 93 2 94 2 95 2 96 2 97 2 98 2 99 2 100 2 101 2 102 2 103 2 104 2 105 2 106 2 107 2 108 2 109 2 110 2 111 2 112 2 113 2 114 2 115 2 116 2 117 2 118 2 119 2 120 2 121 2 122 2 123 2 124 2 125 2 126 2 127 2 128 2 129 2 130 2 131 2 132 2 133 2 134 2 135 2 136 2 137 2 138 2 139 2 140 2 141 2 142 2 143 2 144 2 145 2 146 2 147 2 148 2 149 2 150 2 151 2 152 2 153 2 154 2 155 2 156 2 157 2 158 2 159 2 160 2 161 2 162 2 163 2 164 2 165 2 166 2 167 2 168 2 169 2 170 2 171 2 172 2 173 2 174 2 175 2 176 2 177 2 178 2 179 2 180 2 181 2 182 2 183 2 184 2 185 2 186 2 187 2 188 2 189 2 190 2 191 2 192 2 193 2 194 2 195 2 196 2 197 2 198 2 199 2 200 2 201 2 202 2 203 2 204 2 205 2 206 2 207 2 208 2 209 2 210 2 211 2 212 2 213 2 214 2 215 2 216 2 217 2 218 2 219 2 220 2 221 2 222 2 223 2 224 2 225 2 226 2 227 2 228 2 229 2 230 2 231 2 232 2 233 2 234 2 235 2 236 2 237 2 238 2 239 2 240 2 241 2 242 2 243 2 244 2 245 2 246 2 247 2 248 2 249 2 250 2 251 2 252 2 253 2 254 2 255 0 155 3 0 3 1 3 2 3 3 3 4 3 5 3 6 3 7 3 8 3 9 3 10 3 11 3 12 3 13 3 14 3 15 3 16 3 17 3 18 3 19 3 20 3 21 3 22 3 23 3 24 3 25 3 26 3 27 3 28 3 29 3 30 3 31 3 32 3 33 3 34 3 35 3 36 3 37 3 38 3 39 3 40 3 41 3 42 3 43 3 44 3 45 3 46 3 47 3 48 3 49 3 50 3 51 3 52 3 53 3 54 3 55 3 56 3 57 3 58 3 59 3 60 3 61 3 62 3 63 3 64 3 65 3 66 3 67 3 68 3 69 3 70 3 71 3 72 3 73 3 74 3 75 3 76 3 77 3 78 3 79 3 80 3 81 3 82 3 83 3 84 3 85 3 86 3 87 3 88 3 89 3 90 3 91 3 92 3 93 3 94 3 95 3 96 3 97 3 98 3 99 3 100 3 101 3 102 3 103 3 104 3 105 3 106 3 107 3 108 3 109 3 110 3 111 3 112 3 113 3 114 3 115 3 116 3 117 3 118 3 119 3 120 3 121 3 122 3 123 3 124 3 125 3 126 3 127 3 128 3 129 3 130 3 131 3 132 3 133 3 134 3 135 3 136 3 137 3 138 3 139 3 140 3 141 3 142 3 143 3 144 3 145 3 146 3 147 3 148 3 149 3 150 3 151 3 152 3 153 3 154 3 155 3 156 3 157 3 158 3 159 3 160 3 161 3 162 3 163 3 164 3 165 3 166 3 167 3 168 3 169 3 170 3 171 3 172 3 173 3 174 3 175 3 176 3 177 3 178 3 179 3 180 3 181 3 182 3 183 3 184 3 185 3 186 3 187 3 188 3 189 3 190 3 191 3 192 3 193 3 194 3 195 3 196 3 197 3 198 3 199 3 200 3 201 3 202 3 203 3 204 3 205 3 206 3 207 3 208 3 209 3 210 3 211 3 212 3 213 3 214 3 215 3 216 3 217 3 218 0 9 0 19 0 20 0 21 0 22 0 23 0 24 0 25 0 26 0 27 0 28 3 219 3 220 3 221 3 222 3 223 3 224 3 225 3 226 3 227 3 228 3 229 3 230 3 231 3 232 3 233 3 234 3 235 3 236 3 237 3 238 3 239 3 240 3 241 0 17 0 15 0 29 0 30 0 171 0 4 0 163 0 34 0 162 0 10 0 5 0 182 0 183 0 180 0 181 0 196 0 197 3 242 0 190 0 191 0 169 0 170 0 16 3 243 3 244 0 178 0 179 3 245 3 246 0 195 0 135 3 247 3 248 3 249 3 250 3 251 3 252 3 253 3 254 3 255 4 0 4 1 4 2 4 3 0 66 4 4 4 5 4 6 0 11 0 12 0 62 0 64 0 94 0 96 0 18 0 95 0 63 0 232 0 13 0 130 0 194 0 134 0 136 4 7 4 8 4 9 4 10 4 11 4 12 4 13 4 14 4 15 4 16 4 17 4 18 4 19 4 20 4 21 4 22 4 23 0 139 4 24 0 138 0 140 4 25 0 35 4 26 0 6 4 27 4 28 4 29 4 30 4 31 4 32 4 33 4 34 4 35 4 36 4 37 4 38 4 39 4 40 4 41 4 42 4 43 4 44 4 45 4 46 4 47 4 48 4 49 4 50 4 51 4 52 4 53 4 54 4 55 4 56 4 57 4 58 4 59 4 60 4 61 4 62 4 63 4 64 4 65 4 66 4 67 4 68 4 69 4 70 4 71 4 72 4 73 4 74 4 75 4 76 4 77 4 78 4 79 4 80 4 81 4 82 4 83 4 84 4 85 4 86 4 87 0 157 4 88 0 158 4 89 4 90 4 91 4 92 4 93 4 94 4 95 4 96 4 97 4 98 4 99 4 100 4 101 4 102 4 103 4 104 4 105 4 106 4 107 4 108 4 109 4 110 4 111 4 112 4 113 4 114 4 115 4 116 4 117 4 118 4 119 4 120 4 121 4 122 4 123 4 124 4 125 4 126 4 127 4 128 0 189 0 7 0 133 0 150 4 129 0 132 4 130 4 131 4 132 4 133 4 134 4 135 4 136 4 137 4 138 4 139 4 140 4 141 4 142 4 143 4 144 4 145 0 247 0 188 4 146 4 147 0 8 0 198 0 245 0 244 0 246 4 148 4 149 4 150 4 151 4 152 4 153 4 154 4 155 4 156 4 157 4 158 4 159 4 160 4 161 4 162 4 163 0 14 0 239 0 240 0 184 4 164 0 32 4 165 0 31 0 33 0 148 0 149 0 147 0 65 0 143 0 97 0 167 0 164 4 166 4 167 4 168 0 146 0 131 4 169 4 170 4 171 4 172 0 152 0 156 4 173 4 174 0 165 4 175 4 176 4 177 4 178 4 179 0 153 0 154 4 180 4 181 4 182 4 183 4 184 4 185 4 186 4 187 4 188 4 189 4 190 4 191 4 192 4 193 4 194 4 195 4 196 4 197 4 198 4 199 4 200 4 201 4 202 4 203 4 204 4 205 4 206 4 207 4 208 4 209 4 210 4 211 4 212 4 213 4 214 4 215 4 216 4 217 4 218 4 219 4 220 4 221 4 222 4 223 4 224 4 225 4 226 4 227 4 228 4 229 4 230 4 231 4 232 4 233 4 234 0 185 4 235 4 236 4 237 4 238 4 239 4 240 4 241 4 242 4 243 4 244 0 67 0 141 0 216 0 225 4 245 4 246 4 247 4 248 4 249 0 217 0 142 0 218 0 219 0 221 0 223 0 220 0 222 0 224 4 250 4 251 4 252 4 253 4 254 4 255 5 0 5 1 5 2 5 3 5 4 5 5 5 6 5 7 5 8 5 9 5 10 5 11 5 12 5 13 5 14 5 15 5 16 5 17 5 18 5 19 5 20 5 21 5 22 5 23 5 24 5 25 5 26 5 27 5 28 5 29 5 30 5 31 5 32 5 33 5 34 5 35 5 36 5 37 5 38 5 39 5 40 5 41 5 42 5 43 5 44 5 45 5 46 5 47 5 48 5 49 5 50 5 51 5 52 5 53 5 54 5 55 5 56 5 57 5 58 5 59 5 60 5 61 5 62 5 63 5 64 5 65 5 66 5 67 5 68 5 69 5 70 5 71 5 72 5 73 5 74 5 75 5 76 5 77 5 78 5 79 5 80 5 81 5 82 5 83 5 84 5 85 5 86 5 87 5 88 5 89 5 90 5 91 5 92 5 93 5 94 5 95 5 96 5 97 5 98 5 99 5 100 5 101 5 102 5 103 5 104 5 105 5 106 5 107 5 108 5 109 5 110 5 111 5 112 5 113 5 114 5 115 5 116 5 117 5 118 5 119 5 120 5 121 5 122 5 123 5 124 5 125 5 126 5 127 5 128 5 129 5 130 5 131 5 132 5 133 5 134 5 135 5 136 5 137 5 138 5 139 5 140 5 141 5 142 5 143 5 144 5 145 5 146 5 147 5 148 5 149 5 150 5 151 5 152 5 153 5 154 5 155 5 156 5 157 5 158 5 159 5 160 5 161 5 162 5 163 5 164 5 165 5 166 5 167 5 168 5 169 5 170 5 171 5 172 5 173 5 174 5 175 5 176 5 177 5 178 5 179 5 180 5 181 5 182 5 183 5 184 5 185 5 186 5 187 5 188 5 189 5 190 5 191 5 192 5 193 5 194 5 195 5 196 5 197 5 198 5 199 5 200 5 201 5 202 5 203 5 204 5 205 5 206 5 207 5 208 5 209 5 210 5 211 5 212 5 213 5 214 5 215 5 216 5 217 5 218 5 219 5 220 5 221 5 222 5 223 5 224 5 225 5 226 5 227 5 228 5 229 5 230 5 231 5 232 5 233 5 234 5 235 5 236 5 237 5 238 5 239 5 240 5 241 5 242 5 243 5 244 5 245 5 246 5 247 5 248 5 249 5 250 5 251 5 252 5 253 5 254 5 255 6 0 6 1 6 2 6 3 6 4 6 5 6 6 6 7 6 8 6 9 6 10 6 11 6 12 6 13 6 14 6 15 6 16 6 17 6 18 6 19 6 20 0 192 0 193 6 21 6 22 6 23 6 24 6 25 6 26 6 27 4 78 85 76 76 2 67 82 7 65 109 97 99 114 111 110 6 65 98 114 101 118 101 10 65 114 105 110 103 97 99 117 116 101 7 117 110 105 48 49 67 68 7 65 111 103 111 110 101 107 7 117 110 105 49 69 65 48 7 117 110 105 49 69 65 50 7 117 110 105 49 69 65 52 7 117 110 105 49 69 65 54 7 117 110 105 49 69 65 56 7 117 110 105 49 69 65 65 7 117 110 105 49 69 65 67 7 117 110 105 49 69 65 69 7 117 110 105 49 69 66 48 7 117 110 105 49 69 66 50 7 117 110 105 49 69 66 52 7 117 110 105 49 69 66 54 7 65 69 97 99 117 116 101 7 117 110 105 48 49 69 50 7 117 110 105 48 50 52 51 7 117 110 105 49 69 48 54 11 67 99 105 114 99 117 109 102 108 101 120 10 67 100 111 116 97 99 99 101 110 116 6 68 99 97 114 111 110 7 117 110 105 49 69 48 67 7 117 110 105 49 69 48 69 7 117 110 105 49 69 49 48 6 68 99 114 111 97 116 7 117 110 105 48 49 56 65 6 69 99 97 114 111 110 7 69 109 97 99 114 111 110 6 69 98 114 101 118 101 10 69 100 111 116 97 99 99 101 110 116 7 69 111 103 111 110 101 107 7 117 110 105 49 69 66 56 7 117 110 105 49 69 66 65 7 117 110 105 49 69 66 67 7 117 110 105 49 69 66 69 7 117 110 105 49 69 67 48 7 117 110 105 49 69 67 50 7 117 110 105 49 69 67 52 7 117 110 105 49 69 67 54 7 117 110 105 49 69 49 54 7 117 110 105 48 49 70 52 11 71 99 105 114 99 117 109 102 108 101 120 10 71 100 111 116 97 99 99 101 110 116 7 117 110 105 48 49 50 50 6 71 99 97 114 111 110 7 117 110 105 49 69 50 48 11 117 110 105 48 48 52 55 48 51 48 51 7 117 110 105 48 49 57 51 11 72 99 105 114 99 117 109 102 108 101 120 7 117 110 105 49 69 50 54 7 117 110 105 49 69 50 52 7 117 110 105 49 69 50 56 7 117 110 105 49 69 50 65 4 72 98 97 114 6 73 116 105 108 100 101 7 73 109 97 99 114 111 110 7 117 110 105 48 49 67 70 7 73 111 103 111 110 101 107 7 117 110 105 49 69 67 56 7 117 110 105 49 69 67 65 6 73 98 114 101 118 101 11 74 99 105 114 99 117 109 102 108 101 120 7 117 110 105 48 49 51 54 7 117 110 105 49 69 51 50 7 117 110 105 49 69 51 52 6 76 97 99 117 116 101 6 76 99 97 114 111 110 7 117 110 105 48 49 51 66 7 117 110 105 49 69 51 54 7 117 110 105 49 69 51 56 7 117 110 105 49 69 51 65 4 76 100 111 116 7 117 110 105 49 69 51 69 7 117 110 105 49 69 52 48 7 117 110 105 49 69 52 50 6 78 97 99 117 116 101 7 117 110 105 48 49 70 56 6 78 99 97 114 111 110 7 117 110 105 48 49 52 53 7 117 110 105 49 69 52 52 7 117 110 105 49 69 52 54 7 117 110 105 49 69 52 56 7 79 109 97 99 114 111 110 13 79 104 117 110 103 97 114 117 109 108 97 117 116 6 79 98 114 101 118 101 7 117 110 105 48 49 68 49 7 117 110 105 48 49 69 65 7 117 110 105 49 69 67 67 7 117 110 105 49 69 67 69 7 117 110 105 49 69 68 48 7 117 110 105 49 69 68 50 7 117 110 105 49 69 68 52 7 117 110 105 49 69 68 54 7 117 110 105 49 69 68 56 5 79 104 111 114 110 7 117 110 105 49 69 68 65 7 117 110 105 49 69 68 67 7 117 110 105 49 69 68 69 7 117 110 105 49 69 69 48 7 117 110 105 49 69 69 50 7 117 110 105 49 69 53 50 11 79 115 108 97 115 104 97 99 117 116 101 6 82 97 99 117 116 101 6 82 99 97 114 111 110 7 117 110 105 49 69 53 56 7 117 110 105 48 49 53 54 7 117 110 105 49 69 53 65 7 117 110 105 49 69 53 67 7 117 110 105 49 69 53 69 6 83 97 99 117 116 101 11 83 99 105 114 99 117 109 102 108 101 120 9 83 99 97 114 111 110 100 111 116 7 117 110 105 48 49 53 69 7 117 110 105 48 50 49 56 7 117 110 105 49 69 54 48 7 117 110 105 49 69 54 50 7 117 110 105 49 69 57 69 6 84 99 97 114 111 110 7 117 110 105 48 49 54 50 7 117 110 105 48 50 49 65 7 117 110 105 49 69 54 67 7 117 110 105 49 69 54 69 4 84 98 97 114 6 85 116 105 108 100 101 7 85 109 97 99 114 111 110 6 85 98 114 101 118 101 5 85 114 105 110 103 13 85 104 117 110 103 97 114 117 109 108 97 117 116 7 117 110 105 48 49 68 51 7 85 111 103 111 110 101 107 7 117 110 105 48 49 68 53 7 117 110 105 48 49 68 55 7 117 110 105 48 49 68 57 7 117 110 105 48 49 68 66 7 117 110 105 49 69 69 52 7 117 110 105 49 69 69 54 5 85 104 111 114 110 7 117 110 105 49 69 69 56 7 117 110 105 49 69 69 65 7 117 110 105 49 69 69 67 7 117 110 105 49 69 69 69 7 117 110 105 49 69 70 48 7 117 110 105 49 69 55 69 6 87 103 114 97 118 101 6 87 97 99 117 116 101 11 87 99 105 114 99 117 109 102 108 101 120 9 87 100 105 101 114 101 115 105 115 6 89 103 114 97 118 101 11 89 99 105 114 99 117 109 102 108 101 120 7 117 110 105 49 69 56 69 7 117 110 105 49 69 70 52 7 117 110 105 49 69 70 54 7 117 110 105 49 69 70 56 6 90 97 99 117 116 101 10 90 100 111 116 97 99 99 101 110 116 7 117 110 105 49 69 57 48 7 117 110 105 49 69 57 50 7 117 110 105 49 69 57 52 7 117 110 105 48 49 56 70 3 69 110 103 2 73 74 15 117 110 105 48 48 52 67 48 48 66 55 48 48 52 67 11 117 110 105 48 49 51 50 48 51 48 49 7 97 109 97 99 114 111 110 6 97 98 114 101 118 101 10 97 114 105 110 103 97 99 117 116 101 7 117 110 105 48 49 67 69 7 97 111 103 111 110 101 107 7 117 110 105 49 69 65 49 7 117 110 105 49 69 65 51 7 117 110 105 49 69 65 53 7 117 110 105 49 69 65 55 7 117 110 105 49 69 65 57 7 117 110 105 49 69 65 66 7 117 110 105 49 69 65 68 7 117 110 105 49 69 65 70 7 117 110 105 49 69 66 49 7 117 110 105 49 69 66 51 7 117 110 105 49 69 66 53 7 117 110 105 49 69 66 55 7 97 101 97 99 117 116 101 7 117 110 105 48 49 69 51 7 117 110 105 48 49 56 48 7 117 110 105 49 69 48 55 11 99 99 105 114 99 117 109 102 108 101 120 10 99 100 111 116 97 99 99 101 110 116 6 100 99 97 114 111 110 7 117 110 105 49 69 48 68 7 117 110 105 49 69 48 70 7 117 110 105 49 69 49 49 6 101 99 97 114 111 110 7 101 109 97 99 114 111 110 6 101 98 114 101 118 101 7 101 111 103 111 110 101 107 10 101 100 111 116 97 99 99 101 110 116 7 117 110 105 49 69 66 57 7 117 110 105 49 69 66 66 7 117 110 105 49 69 66 68 7 117 110 105 49 69 66 70 7 117 110 105 49 69 67 49 7 117 110 105 49 69 67 51 7 117 110 105 49 69 67 53 7 117 110 105 49 69 67 55 7 117 110 105 49 69 49 55 7 117 110 105 48 49 70 53 11 103 99 105 114 99 117 109 102 108 101 120 10 103 100 111 116 97 99 99 101 110 116 7 117 110 105 48 49 50 51 6 103 99 97 114 111 110 7 117 110 105 49 69 50 49 11 117 110 105 48 48 54 55 48 51 48 51 11 104 99 105 114 99 117 109 102 108 101 120 7 117 110 105 49 69 50 55 7 117 110 105 49 69 50 53 7 117 110 105 49 69 57 54 7 117 110 105 49 69 50 57 7 117 110 105 49 69 50 66 4 104 98 97 114 6 105 116 105 108 100 101 7 105 109 97 99 114 111 110 7 117 110 105 48 49 68 48 7 105 111 103 111 110 101 107 7 117 110 105 49 69 67 57 7 117 110 105 49 69 67 66 6 105 98 114 101 118 101 11 106 99 105 114 99 117 109 102 108 101 120 7 117 110 105 48 49 51 55 7 117 110 105 49 69 51 51 7 117 110 105 49 69 51 53 12 107 103 114 101 101 110 108 97 110 100 105 99 6 108 97 99 117 116 101 6 108 99 97 114 111 110 7 117 110 105 48 49 51 67 7 117 110 105 49 69 51 55 7 117 110 105 49 69 51 57 7 117 110 105 49 69 51 66 4 108 100 111 116 7 117 110 105 49 69 51 70 7 117 110 105 49 69 52 49 7 117 110 105 49 69 52 51 6 110 97 99 117 116 101 7 117 110 105 48 49 70 57 6 110 99 97 114 111 110 7 117 110 105 48 49 52 54 7 117 110 105 49 69 52 53 7 117 110 105 49 69 52 55 7 117 110 105 49 69 52 57 11 110 97 112 111 115 116 114 111 112 104 101 7 111 109 97 99 114 111 110 13 111 104 117 110 103 97 114 117 109 108 97 117 116 7 117 110 105 48 49 68 50 7 117 110 105 48 49 69 66 7 117 110 105 49 69 67 68 7 117 110 105 49 69 67 70 7 117 110 105 49 69 68 49 7 117 110 105 49 69 68 51 7 117 110 105 49 69 68 53 7 117 110 105 49 69 68 55 7 117 110 105 49 69 68 57 6 111 98 114 101 118 101 7 117 110 105 49 69 53 51 5 111 104 111 114 110 7 117 110 105 49 69 68 66 7 117 110 105 49 69 68 68 7 117 110 105 49 69 68 70 7 117 110 105 49 69 69 49 7 117 110 105 49 69 69 51 11 111 115 108 97 115 104 97 99 117 116 101 6 114 97 99 117 116 101 7 117 110 105 48 49 53 55 6 114 99 97 114 111 110 7 117 110 105 49 69 53 57 7 117 110 105 49 69 53 66 7 117 110 105 49 69 53 68 7 117 110 105 49 69 53 70 6 115 97 99 117 116 101 11 115 99 105 114 99 117 109 102 108 101 120 9 115 99 97 114 111 110 100 111 116 7 117 110 105 48 49 53 70 7 117 110 105 48 50 49 57 7 117 110 105 49 69 54 49 7 117 110 105 49 69 54 51 5 108 111 110 103 115 6 116 99 97 114 111 110 7 117 110 105 48 49 54 51 7 117 110 105 48 50 49 66 7 117 110 105 49 69 54 68 7 117 110 105 49 69 54 70 7 117 110 105 49 69 57 55 4 116 98 97 114 6 117 116 105 108 100 101 7 117 109 97 99 114 111 110 6 117 98 114 101 118 101 5 117 114 105 110 103 13 117 104 117 110 103 97 114 117 109 108 97 117 116 7 117 110 105 48 49 68 52 7 117 111 103 111 110 101 107 7 117 110 105 48 49 68 54 7 117 110 105 48 49 68 56 7 117 110 105 48 49 68 65 7 117 110 105 48 49 68 67 7 117 110 105 49 69 69 53 7 117 110 105 49 69 69 55 5 117 104 111 114 110 7 117 110 105 49 69 69 57 7 117 110 105 49 69 69 66 7 117 110 105 49 69 69 68 7 117 110 105 49 69 69 70 7 117 110 105 49 69 70 49 7 117 110 105 49 69 55 70 6 119 103 114 97 118 101 6 119 97 99 117 116 101 11 119 99 105 114 99 117 109 102 108 101 120 9 119 100 105 101 114 101 115 105 115 6 121 103 114 97 118 101 11 121 99 105 114 99 117 109 102 108 101 120 7 117 110 105 49 69 56 70 7 117 110 105 49 69 70 53 7 117 110 105 49 69 70 55 7 117 110 105 49 69 70 57 6 122 97 99 117 116 101 10 122 100 111 116 97 99 99 101 110 116 7 117 110 105 49 69 57 49 7 117 110 105 49 69 57 51 7 117 110 105 49 69 57 53 3 101 110 103 7 117 110 105 48 50 51 55 2 105 106 15 117 110 105 48 48 54 67 48 48 66 55 48 48 54 67 11 117 110 105 48 49 51 51 48 51 48 49 7 117 110 105 48 50 53 48 7 117 110 105 48 50 53 50 7 117 110 105 48 50 53 51 7 117 110 105 48 50 53 52 7 117 110 105 48 50 53 53 7 117 110 105 48 50 53 54 7 117 110 105 48 50 53 55 7 117 110 105 48 50 53 56 7 117 110 105 48 50 53 49 7 117 110 105 48 50 57 57 7 117 110 105 48 50 53 57 7 117 110 105 48 50 53 65 7 117 110 105 48 50 53 66 7 117 110 105 48 50 53 67 7 117 110 105 48 50 53 69 7 117 110 105 48 50 53 70 7 117 110 105 48 50 54 48 7 117 110 105 48 50 54 49 7 117 110 105 48 50 54 50 7 117 110 105 48 50 54 51 7 117 110 105 48 50 54 52 7 117 110 105 48 50 54 53 7 117 110 105 48 50 54 54 7 117 110 105 48 50 54 55 7 117 110 105 48 50 57 67 7 117 110 105 48 50 54 56 7 117 110 105 48 50 54 65 7 117 110 105 48 50 57 68 7 117 110 105 48 50 57 69 7 117 110 105 48 50 54 66 7 117 110 105 48 50 54 67 7 117 110 105 48 50 54 68 7 117 110 105 48 50 54 69 7 117 110 105 48 50 57 70 7 117 110 105 48 50 54 70 7 117 110 105 48 50 55 48 7 117 110 105 48 50 55 49 7 117 110 105 48 50 55 50 7 117 110 105 48 50 55 51 7 117 110 105 48 50 55 52 7 117 110 105 48 50 55 53 7 117 110 105 48 50 55 54 7 117 110 105 48 50 55 56 7 117 110 105 48 50 55 57 7 117 110 105 48 50 55 65 7 117 110 105 48 50 55 66 7 117 110 105 48 50 55 68 7 117 110 105 48 50 55 69 7 117 110 105 48 50 56 48 7 117 110 105 48 50 56 49 7 117 110 105 48 50 56 50 7 117 110 105 48 50 56 51 7 117 110 105 48 50 56 52 7 117 110 105 48 50 56 55 7 117 110 105 48 50 56 56 7 117 110 105 48 50 56 57 7 117 110 105 48 50 56 65 7 117 110 105 48 50 56 66 7 117 110 105 48 50 56 67 7 117 110 105 48 50 56 68 7 117 110 105 48 50 56 69 7 117 110 105 48 50 56 70 7 117 110 105 48 50 57 48 7 117 110 105 48 50 57 49 7 117 110 105 48 50 57 50 7 117 110 105 48 50 65 52 7 117 110 105 48 50 65 54 7 117 110 105 48 50 65 55 7 117 110 105 48 50 57 52 7 117 110 105 48 50 57 53 7 117 110 105 48 50 65 49 7 117 110 105 48 50 65 50 7 117 110 105 48 49 67 50 7 117 110 105 48 50 57 56 9 117 110 105 48 49 52 65 46 97 3 97 46 97 8 97 103 114 97 118 101 46 97 8 97 97 99 117 116 101 46 97 13 97 99 105 114 99 117 109 102 108 101 120 46 97 8 97 116 105 108 100 101 46 97 11 97 100 105 101 114 101 115 105 115 46 97 9 97 109 97 99 114 111 110 46 97 8 97 98 114 101 118 101 46 97 7 97 114 105 110 103 46 97 12 97 114 105 110 103 97 99 117 116 101 46 97 9 117 110 105 48 49 67 69 46 97 9 117 110 105 49 69 65 49 46 97 9 117 110 105 49 69 65 51 46 97 9 117 110 105 49 69 65 53 46 97 9 117 110 105 49 69 65 55 46 97 9 117 110 105 49 69 65 57 46 97 9 117 110 105 49 69 65 66 46 97 9 117 110 105 49 69 65 68 46 97 9 117 110 105 49 69 65 70 46 97 9 117 110 105 49 69 66 49 46 97 9 117 110 105 49 69 66 51 46 97 9 117 110 105 49 69 66 53 46 97 9 117 110 105 49 69 66 55 46 97 9 97 111 103 111 110 101 107 46 97 3 103 46 97 9 117 110 105 48 49 70 53 46 97 13 103 99 105 114 99 117 109 102 108 101 120 46 97 8 103 98 114 101 118 101 46 97 12 103 100 111 116 97 99 99 101 110 116 46 97 9 117 110 105 48 49 50 51 46 97 8 103 99 97 114 111 110 46 97 9 117 110 105 49 69 50 49 46 97 13 117 110 105 48 48 54 55 48 51 48 51 46 97 3 105 46 97 10 100 111 116 108 101 115 115 105 46 97 8 105 103 114 97 118 101 46 97 8 105 97 99 117 116 101 46 97 13 105 99 105 114 99 117 109 102 108 101 120 46 97 8 105 116 105 108 100 101 46 97 11 105 100 105 101 114 101 115 105 115 46 97 9 105 109 97 99 114 111 110 46 97 9 117 110 105 48 49 68 48 46 97 9 105 111 103 111 110 101 107 46 97 9 117 110 105 49 69 67 57 46 97 9 117 110 105 49 69 67 66 46 97 9 117 110 105 48 49 50 68 46 97 9 117 110 105 48 50 54 56 46 97 9 105 111 103 111 110 101 107 46 100 10 105 111 103 111 110 101 107 46 100 97 9 117 110 105 48 50 54 56 46 100 10 117 110 105 48 50 54 56 46 100 97 9 117 110 105 48 50 57 68 46 100 5 65 108 112 104 97 4 66 101 116 97 5 71 97 109 109 97 7 117 110 105 48 51 57 52 7 69 112 115 105 108 111 110 4 90 101 116 97 3 69 116 97 5 84 104 101 116 97 4 73 111 116 97 5 75 97 112 112 97 6 76 97 109 98 100 97 2 77 117 2 78 117 2 88 105 7 79 109 105 99 114 111 110 2 80 105 3 82 104 111 5 83 105 103 109 97 3 84 97 117 7 85 112 115 105 108 111 110 3 80 104 105 3 67 104 105 3 80 115 105 7 117 110 105 48 51 65 57 10 65 108 112 104 97 116 111 110 111 115 12 69 112 115 105 108 111 110 116 111 110 111 115 8 69 116 97 116 111 110 111 115 9 73 111 116 97 116 111 110 111 115 12 73 111 116 97 100 105 101 114 101 115 105 115 12 79 109 105 99 114 111 110 116 111 110 111 115 12 85 112 115 105 108 111 110 116 111 110 111 115 15 85 112 115 105 108 111 110 100 105 101 114 101 115 105 115 10 79 109 101 103 97 116 111 110 111 115 5 97 108 112 104 97 4 98 101 116 97 5 103 97 109 109 97 5 100 101 108 116 97 7 101 112 115 105 108 111 110 4 122 101 116 97 3 101 116 97 5 116 104 101 116 97 4 105 111 116 97 5 107 97 112 112 97 6 108 97 109 98 100 97 7 117 110 105 48 51 66 67 2 110 117 2 120 105 7 111 109 105 99 114 111 110 3 114 104 111 5 115 105 103 109 97 3 116 97 117 7 117 112 115 105 108 111 110 3 112 104 105 3 99 104 105 3 112 115 105 5 111 109 101 103 97 7 117 110 105 48 51 67 50 7 117 110 105 48 51 68 48 7 117 110 105 48 51 68 49 7 117 110 105 48 51 68 53 10 97 108 112 104 97 116 111 110 111 115 12 101 112 115 105 108 111 110 116 111 110 111 115 8 101 116 97 116 111 110 111 115 9 105 111 116 97 116 111 110 111 115 12 105 111 116 97 100 105 101 114 101 115 105 115 12 111 109 105 99 114 111 110 116 111 110 111 115 12 117 112 115 105 108 111 110 116 111 110 111 115 15 117 112 115 105 108 111 110 100 105 101 114 101 115 105 115 10 111 109 101 103 97 116 111 110 111 115 17 105 111 116 97 100 105 101 114 101 115 105 115 116 111 110 111 115 20 117 112 115 105 108 111 110 100 105 101 114 101 115 105 115 116 111 110 111 115 7 117 110 105 48 51 68 55 7 117 110 105 48 51 68 57 7 117 110 105 48 51 68 66 7 117 110 105 48 51 68 68 7 117 110 105 48 51 69 49 7 117 110 105 48 51 55 69 9 97 110 111 116 101 108 101 105 97 13 97 110 111 116 101 108 101 105 97 46 99 97 112 7 117 110 105 48 51 55 52 7 117 110 105 48 51 55 53 5 116 111 110 111 115 9 116 111 110 111 115 46 99 97 112 13 100 105 101 114 101 115 105 115 116 111 110 111 115 7 117 110 105 48 51 55 65 7 117 110 105 49 70 66 69 7 117 110 105 49 70 66 68 7 117 110 105 49 70 66 70 7 117 110 105 49 70 70 69 7 117 110 105 49 70 69 70 7 117 110 105 49 70 70 68 7 117 110 105 49 70 67 68 7 117 110 105 49 70 68 68 7 117 110 105 49 70 67 69 7 117 110 105 49 70 68 69 7 117 110 105 49 70 67 70 7 117 110 105 49 70 68 70 7 117 110 105 49 70 67 48 7 117 110 105 49 70 69 68 7 117 110 105 49 70 69 69 7 117 110 105 49 70 67 49 11 117 110 105 49 70 66 68 46 99 97 112 11 117 110 105 49 70 70 69 46 99 97 112 11 117 110 105 49 70 69 70 46 99 97 112 11 117 110 105 49 70 70 68 46 99 97 112 11 117 110 105 49 70 67 68 46 99 97 112 11 117 110 105 49 70 68 68 46 99 97 112 11 117 110 105 49 70 67 69 46 99 97 112 11 117 110 105 49 70 68 69 46 99 97 112 11 117 110 105 49 70 67 70 46 99 97 112 11 117 110 105 49 70 68 70 46 99 97 112 7 117 110 105 48 52 49 48 7 117 110 105 48 52 49 49 7 117 110 105 48 52 49 50 7 117 110 105 48 52 49 51 7 117 110 105 48 52 49 52 7 117 110 105 48 52 49 53 7 117 110 105 48 52 49 54 7 117 110 105 48 52 49 55 7 117 110 105 48 52 49 56 7 117 110 105 48 52 49 57 7 117 110 105 48 52 49 65 7 117 110 105 48 52 49 66 7 117 110 105 48 52 49 67 7 117 110 105 48 52 49 68 7 117 110 105 48 52 49 69 7 117 110 105 48 52 49 70 7 117 110 105 48 52 50 48 7 117 110 105 48 52 50 49 7 117 110 105 48 52 50 50 7 117 110 105 48 52 50 51 7 117 110 105 48 52 50 52 7 117 110 105 48 52 50 53 7 117 110 105 48 52 50 54 7 117 110 105 48 52 50 55 7 117 110 105 48 52 50 56 7 117 110 105 48 52 50 57 7 117 110 105 48 52 50 65 7 117 110 105 48 52 50 66 7 117 110 105 48 52 50 67 7 117 110 105 48 52 50 68 7 117 110 105 48 52 50 69 7 117 110 105 48 52 50 70 7 117 110 105 48 52 48 48 7 117 110 105 48 52 48 49 7 117 110 105 48 52 48 50 7 117 110 105 48 52 48 51 7 117 110 105 48 52 48 52 7 117 110 105 48 52 48 53 7 117 110 105 48 52 48 54 7 117 110 105 48 52 48 55 7 117 110 105 48 52 48 56 7 117 110 105 48 52 48 57 7 117 110 105 48 52 48 65 7 117 110 105 48 52 48 66 7 117 110 105 48 52 48 67 7 117 110 105 48 52 48 68 7 117 110 105 48 52 48 69 7 117 110 105 48 52 48 70 7 117 110 105 48 52 54 50 7 117 110 105 48 52 55 50 7 117 110 105 48 52 55 52 7 117 110 105 48 52 57 48 7 117 110 105 48 52 57 50 7 117 110 105 48 52 57 54 7 117 110 105 48 52 57 56 7 117 110 105 48 52 57 65 7 117 110 105 48 52 65 48 7 117 110 105 48 52 65 50 7 117 110 105 48 52 65 65 7 117 110 105 48 52 65 69 7 117 110 105 48 52 66 48 7 117 110 105 48 52 66 50 7 117 110 105 48 52 66 54 7 117 110 105 48 52 66 65 7 117 110 105 48 52 67 48 7 117 110 105 48 52 67 49 7 117 110 105 48 52 68 48 7 117 110 105 48 52 68 52 7 117 110 105 48 52 68 54 7 117 110 105 48 52 68 56 7 117 110 105 48 52 69 50 7 117 110 105 48 52 69 54 7 117 110 105 48 52 69 56 7 117 110 105 48 52 69 69 7 117 110 105 48 52 70 50 7 117 110 105 48 52 51 48 7 117 110 105 48 52 51 49 7 117 110 105 48 52 51 50 7 117 110 105 48 52 51 51 7 117 110 105 48 52 51 52 7 117 110 105 48 52 51 53 7 117 110 105 48 52 51 54 7 117 110 105 48 52 51 55 7 117 110 105 48 52 51 56 7 117 110 105 48 52 51 57 7 117 110 105 48 52 51 65 7 117 110 105 48 52 51 66 7 117 110 105 48 52 51 67 7 117 110 105 48 52 51 68 7 117 110 105 48 52 51 69 7 117 110 105 48 52 51 70 7 117 110 105 48 52 52 48 7 117 110 105 48 52 52 49 7 117 110 105 48 52 52 50 7 117 110 105 48 52 52 51 7 117 110 105 48 52 52 52 7 117 110 105 48 52 52 53 7 117 110 105 48 52 52 54 7 117 110 105 48 52 52 55 7 117 110 105 48 52 52 56 7 117 110 105 48 52 52 57 7 117 110 105 48 52 52 65 7 117 110 105 48 52 52 66 7 117 110 105 48 52 52 67 7 117 110 105 48 52 52 68 7 117 110 105 48 52 52 69 7 117 110 105 48 52 52 70 7 117 110 105 48 52 53 48 7 117 110 105 48 52 53 49 7 117 110 105 48 52 53 50 7 117 110 105 48 52 53 51 7 117 110 105 48 52 53 52 7 117 110 105 48 52 53 53 7 117 110 105 48 52 53 54 7 117 110 105 48 52 53 55 7 117 110 105 48 52 53 56 7 117 110 105 48 52 53 57 7 117 110 105 48 52 53 65 7 117 110 105 48 52 53 66 7 117 110 105 48 52 53 67 7 117 110 105 48 52 53 68 7 117 110 105 48 52 53 69 7 117 110 105 48 52 53 70 7 117 110 105 48 52 54 51 7 117 110 105 48 52 55 51 7 117 110 105 48 52 55 53 7 117 110 105 48 52 57 49 7 117 110 105 48 52 57 51 7 117 110 105 48 52 57 55 7 117 110 105 48 52 57 57 7 117 110 105 48 52 57 66 7 117 110 105 48 52 65 49 7 117 110 105 48 52 65 51 7 117 110 105 48 52 65 66 7 117 110 105 48 52 65 70 7 117 110 105 48 52 66 49 7 117 110 105 48 52 66 51 7 117 110 105 48 52 66 55 7 117 110 105 48 52 66 66 7 117 110 105 48 52 67 50 7 117 110 105 48 52 67 70 7 117 110 105 48 52 68 49 7 117 110 105 48 52 68 53 7 117 110 105 48 52 68 55 7 117 110 105 48 52 68 57 7 117 110 105 48 52 69 51 7 117 110 105 48 52 69 55 7 117 110 105 48 52 69 57 7 117 110 105 48 52 69 70 7 117 110 105 48 52 70 51 9 117 110 105 48 52 51 48 46 97 9 117 110 105 48 52 68 49 46 97 11 117 110 105 48 52 51 49 46 115 114 98 9 117 110 105 48 52 53 54 46 97 9 117 110 105 48 52 53 55 46 97 7 117 110 105 50 49 49 54 6 122 101 114 111 46 97 9 122 101 114 111 46 111 110 117 109 8 111 110 101 46 111 110 117 109 8 116 119 111 46 111 110 117 109 10 116 104 114 101 101 46 111 110 117 109 9 102 111 117 114 46 111 110 117 109 9 102 105 118 101 46 111 110 117 109 8 115 105 120 46 111 110 117 109 10 115 101 118 101 110 46 111 110 117 109 10 101 105 103 104 116 46 111 110 117 109 9 110 105 110 101 46 111 110 117 109 6 122 101 114 111 46 98 8 122 101 114 111 46 99 97 112 7 111 110 101 46 99 97 112 7 116 119 111 46 99 97 112 9 116 104 114 101 101 46 99 97 112 8 102 111 117 114 46 99 97 112 8 102 105 118 101 46 99 97 112 7 115 105 120 46 99 97 112 9 115 101 118 101 110 46 99 97 112 9 101 105 103 104 116 46 99 97 112 8 110 105 110 101 46 99 97 112 6 122 101 114 111 46 99 13 113 117 111 116 101 114 101 118 101 114 115 101 100 7 117 110 105 48 48 65 68 7 117 110 105 50 48 49 48 10 102 105 103 117 114 101 100 97 115 104 7 117 110 105 50 48 49 53 7 117 110 105 50 53 69 54 7 117 110 105 50 53 65 65 7 117 110 105 50 53 65 66 7 117 110 105 50 53 66 52 7 117 110 105 50 53 66 53 7 117 110 105 50 53 66 56 7 117 110 105 50 53 66 57 7 117 110 105 50 53 66 69 7 117 110 105 50 53 66 70 7 117 110 105 50 53 67 50 7 117 110 105 50 53 67 51 9 105 110 118 98 117 108 108 101 116 10 102 105 108 108 101 100 114 101 99 116 13 117 110 100 101 114 115 99 111 114 101 100 98 108 7 117 110 105 50 48 51 69 7 117 110 105 50 48 51 70 7 117 110 105 50 48 49 54 9 101 120 99 108 97 109 100 98 108 7 117 110 105 50 48 52 55 7 117 110 105 50 48 52 57 7 117 110 105 50 48 52 56 7 117 110 105 50 48 51 68 7 117 110 105 50 69 49 56 7 117 110 105 50 51 49 67 7 117 110 105 50 51 49 68 7 117 110 105 50 51 49 69 7 117 110 105 50 51 49 70 7 117 110 105 50 55 69 54 7 117 110 105 50 55 69 55 7 117 110 105 50 69 50 50 7 117 110 105 50 69 50 51 7 117 110 105 50 69 50 52 7 117 110 105 50 69 50 53 7 117 110 105 50 49 49 55 7 117 110 105 50 49 50 48 7 97 116 46 99 97 115 101 10 97 115 116 101 114 105 115 107 46 97 8 104 121 112 104 101 110 46 97 9 117 110 105 48 48 65 68 46 97 9 117 110 105 50 48 49 48 46 97 8 100 111 108 108 97 114 46 97 9 122 101 114 111 46 115 117 112 115 8 111 110 101 46 115 117 112 115 8 116 119 111 46 115 117 112 115 10 116 104 114 101 101 46 115 117 112 115 9 102 111 117 114 46 115 117 112 115 9 102 105 118 101 46 115 117 112 115 8 115 105 120 46 115 117 112 115 10 115 101 118 101 110 46 115 117 112 115 10 101 105 103 104 116 46 115 117 112 115 9 110 105 110 101 46 115 117 112 115 14 112 97 114 101 110 108 101 102 116 46 115 117 112 115 15 112 97 114 101 110 114 105 103 104 116 46 115 117 112 115 11 112 101 114 105 111 100 46 115 117 112 115 10 99 111 109 109 97 46 115 117 112 115 9 122 101 114 111 46 115 117 98 115 8 111 110 101 46 115 117 98 115 8 116 119 111 46 115 117 98 115 10 116 104 114 101 101 46 115 117 98 115 9 102 111 117 114 46 115 117 98 115 9 102 105 118 101 46 115 117 98 115 8 115 105 120 46 115 117 98 115 10 115 101 118 101 110 46 115 117 98 115 10 101 105 103 104 116 46 115 117 98 115 9 110 105 110 101 46 115 117 98 115 14 112 97 114 101 110 108 101 102 116 46 115 117 98 115 15 112 97 114 101 110 114 105 103 104 116 46 115 117 98 115 11 112 101 114 105 111 100 46 115 117 98 115 10 99 111 109 109 97 46 115 117 98 115 9 122 101 114 111 46 100 110 111 109 8 111 110 101 46 100 110 111 109 8 116 119 111 46 100 110 111 109 10 116 104 114 101 101 46 100 110 111 109 9 102 111 117 114 46 100 110 111 109 9 102 105 118 101 46 100 110 111 109 8 115 105 120 46 100 110 111 109 10 115 101 118 101 110 46 100 110 111 109 10 101 105 103 104 116 46 100 110 111 109 9 110 105 110 101 46 100 110 111 109 14 112 97 114 101 110 108 101 102 116 46 100 110 111 109 15 112 97 114 101 110 114 105 103 104 116 46 100 110 111 109 11 112 101 114 105 111 100 46 100 110 111 109 10 99 111 109 109 97 46 100 110 111 109 9 122 101 114 111 46 110 117 109 114 8 111 110 101 46 110 117 109 114 8 116 119 111 46 110 117 109 114 10 116 104 114 101 101 46 110 117 109 114 9 102 111 117 114 46 110 117 109 114 9 102 105 118 101 46 110 117 109 114 8 115 105 120 46 110 117 109 114 10 115 101 118 101 110 46 110 117 109 114 10 101 105 103 104 116 46 110 117 109 114 9 110 105 110 101 46 110 117 109 114 14 112 97 114 101 110 108 101 102 116 46 110 117 109 114 15 112 97 114 101 110 114 105 103 104 116 46 110 117 109 114 11 112 101 114 105 111 100 46 110 117 109 114 10 99 111 109 109 97 46 110 117 109 114 13 111 114 100 102 101 109 105 110 105 110 101 46 97 6 97 46 115 117 112 115 6 98 46 115 117 112 115 6 99 46 115 117 112 115 6 100 46 115 117 112 115 6 101 46 115 117 112 115 6 102 46 115 117 112 115 6 103 46 115 117 112 115 6 104 46 115 117 112 115 6 105 46 115 117 112 115 6 106 46 115 117 112 115 6 107 46 115 117 112 115 6 108 46 115 117 112 115 6 109 46 115 117 112 115 6 110 46 115 117 112 115 6 111 46 115 117 112 115 6 112 46 115 117 112 115 6 113 46 115 117 112 115 6 114 46 115 117 112 115 6 115 46 115 117 112 115 6 116 46 115 117 112 115 6 117 46 115 117 112 115 6 118 46 115 117 112 115 6 119 46 115 117 112 115 6 120 46 115 117 112 115 6 121 46 115 117 112 115 6 122 46 115 117 112 115 11 101 103 114 97 118 101 46 115 117 112 115 11 101 97 99 117 116 101 46 115 117 112 115 12 101 111 103 111 110 101 107 46 115 117 112 115 12 117 110 105 48 50 53 57 46 115 117 112 115 12 117 110 105 48 50 54 54 46 115 117 112 115 7 117 110 105 48 50 69 48 7 117 110 105 48 50 69 52 6 97 46 115 117 112 97 6 103 46 115 117 112 97 6 105 46 115 117 112 97 10 99 111 108 111 110 46 115 117 112 115 11 104 121 112 104 101 110 46 115 117 112 115 11 101 110 100 97 115 104 46 115 117 112 115 11 101 109 100 97 115 104 46 115 117 112 115 4 69 117 114 111 7 117 110 105 48 49 57 50 13 99 111 108 111 110 109 111 110 101 116 97 114 121 4 108 105 114 97 7 117 110 105 50 48 65 54 6 112 101 115 101 116 97 7 117 110 105 50 48 65 57 4 100 111 110 103 7 117 110 105 50 48 66 49 7 117 110 105 50 48 66 50 7 117 110 105 50 48 66 52 7 117 110 105 50 48 66 53 7 117 110 105 50 48 66 57 7 117 110 105 50 48 66 65 7 117 110 105 50 48 65 69 7 117 110 105 50 48 66 56 7 117 110 105 50 48 66 68 7 117 110 105 50 50 49 53 10 115 108 97 115 104 46 102 114 97 99 8 111 110 101 116 104 105 114 100 9 116 119 111 116 104 105 114 100 115 7 117 110 105 50 49 53 53 7 117 110 105 50 49 53 54 7 117 110 105 50 49 53 55 7 117 110 105 50 49 53 56 7 117 110 105 50 49 53 57 7 117 110 105 50 49 53 65 7 117 110 105 50 49 53 48 9 111 110 101 101 105 103 104 116 104 12 116 104 114 101 101 101 105 103 104 116 104 115 11 102 105 118 101 101 105 103 104 116 104 115 12 115 101 118 101 110 101 105 103 104 116 104 115 7 117 110 105 50 49 53 49 7 117 110 105 50 49 53 50 7 117 110 105 50 49 56 57 7 117 110 105 50 50 49 57 11 101 113 117 105 118 97 108 101 110 99 101 13 114 101 118 108 111 103 105 99 97 108 110 111 116 12 105 110 116 101 114 115 101 99 116 105 111 110 10 111 114 116 104 111 103 111 110 97 108 7 117 110 105 50 48 51 50 7 117 110 105 50 48 51 51 7 117 110 105 50 48 51 53 7 117 110 105 48 48 66 53 10 105 110 116 101 103 114 97 108 116 112 10 105 110 116 101 103 114 97 108 98 116 7 117 110 105 50 50 48 54 7 117 110 105 50 49 50 54 7 117 110 105 50 50 48 48 7 117 110 105 50 50 48 51 7 117 110 105 50 50 51 55 7 117 110 105 50 49 48 53 7 117 110 105 50 49 49 51 9 101 115 116 105 109 97 116 101 100 7 117 110 105 50 49 57 48 7 97 114 114 111 119 117 112 7 117 110 105 50 49 57 50 9 97 114 114 111 119 100 111 119 110 7 117 110 105 50 49 57 54 7 117 110 105 50 49 57 55 7 117 110 105 50 49 57 56 7 117 110 105 50 49 57 57 7 117 110 105 50 49 68 48 7 117 110 105 50 49 68 49 7 117 110 105 50 49 68 50 7 117 110 105 50 49 68 51 9 97 114 114 111 119 98 111 116 104 9 97 114 114 111 119 117 112 100 110 12 97 114 114 111 119 117 112 100 110 98 115 101 7 117 110 105 50 53 67 70 7 117 110 105 50 53 67 66 7 117 110 105 50 53 65 48 7 117 110 105 50 53 65 49 7 117 110 105 50 55 53 50 7 117 110 105 50 53 67 54 7 116 114 105 97 103 117 112 7 117 110 105 50 53 66 51 7 117 110 105 50 53 66 54 7 117 110 105 50 53 66 55 7 116 114 105 97 103 100 110 7 117 110 105 50 53 66 68 7 117 110 105 50 53 67 48 7 117 110 105 50 53 67 49 7 116 114 105 97 103 114 116 7 116 114 105 97 103 108 102 9 105 110 118 99 105 114 99 108 101 7 117 110 105 50 53 67 57 7 117 110 105 50 54 49 48 7 117 110 105 50 54 49 49 7 117 110 105 50 55 49 51 11 109 117 115 105 99 97 108 110 111 116 101 14 109 117 115 105 99 97 108 110 111 116 101 100 98 108 5 104 101 97 114 116 4 99 108 117 98 7 100 105 97 109 111 110 100 5 115 112 97 100 101 9 115 109 105 108 101 102 97 99 101 12 105 110 118 115 109 105 108 101 102 97 99 101 7 117 110 105 50 55 54 52 7 117 110 105 50 54 49 53 6 117 49 70 52 65 57 6 117 49 70 57 49 54 6 117 49 70 53 49 50 6 102 101 109 97 108 101 4 109 97 108 101 3 115 117 110 5 104 111 117 115 101 7 117 110 105 48 50 66 57 7 117 110 105 48 50 66 66 7 117 110 105 48 50 66 67 7 117 110 105 48 50 66 69 7 117 110 105 48 50 66 70 7 117 110 105 48 50 67 49 7 117 110 105 48 50 68 48 7 117 110 105 48 50 68 49 7 117 110 105 48 50 68 69 7 117 110 105 48 50 67 56 7 117 110 105 48 50 67 57 7 117 110 105 48 50 67 65 7 117 110 105 48 50 67 66 7 117 110 105 48 50 67 67 7 117 110 105 50 53 67 67 7 117 110 105 48 51 48 48 11 117 110 105 48 51 48 48 46 99 97 112 9 117 110 105 48 51 48 48 46 103 7 117 110 105 48 51 48 49 11 117 110 105 48 51 48 49 46 99 97 112 9 117 110 105 48 51 48 49 46 103 7 117 110 105 48 51 48 50 11 117 110 105 48 51 48 50 46 99 97 112 7 117 110 105 48 51 48 51 11 117 110 105 48 51 48 51 46 99 97 112 7 117 110 105 48 51 48 52 11 117 110 105 48 51 48 52 46 99 97 112 7 117 110 105 48 51 48 53 11 117 110 105 48 51 48 53 46 99 97 112 7 117 110 105 48 51 48 54 9 117 110 105 48 51 48 54 46 99 11 117 110 105 48 51 48 54 46 99 97 112 12 117 110 105 48 51 48 54 46 99 99 97 112 7 117 110 105 48 51 48 55 11 117 110 105 48 51 48 55 46 99 97 112 7 117 110 105 48 51 48 56 11 117 110 105 48 51 48 56 46 99 97 112 7 117 110 105 48 51 48 57 11 117 110 105 48 51 48 57 46 99 97 112 7 117 110 105 48 51 49 48 11 117 110 105 48 51 49 48 46 99 97 112 7 117 110 105 48 51 48 65 11 117 110 105 48 51 48 65 46 99 97 112 7 117 110 105 48 51 48 66 11 117 110 105 48 51 48 66 46 99 97 112 7 117 110 105 48 51 48 67 11 117 110 105 48 51 48 67 46 99 97 112 9 117 110 105 48 51 48 67 46 97 7 117 110 105 48 51 48 70 11 117 110 105 48 51 48 70 46 99 97 112 7 117 110 105 48 51 49 49 11 117 110 105 48 51 49 49 46 99 97 112 7 117 110 105 48 51 49 50 9 117 110 105 48 51 49 50 46 103 7 117 110 105 48 51 49 51 9 117 110 105 48 51 49 51 46 103 7 117 110 105 48 51 49 56 7 117 110 105 48 51 49 57 7 117 110 105 48 51 49 65 7 117 110 105 48 51 49 66 7 117 110 105 48 51 49 67 7 117 110 105 48 51 49 68 7 117 110 105 48 51 49 69 7 117 110 105 48 51 49 70 7 117 110 105 48 51 50 48 7 117 110 105 48 51 50 51 7 117 110 105 48 51 50 52 7 117 110 105 48 51 50 53 7 117 110 105 48 51 50 54 9 117 110 105 48 51 50 54 46 97 7 117 110 105 48 51 50 55 11 117 110 105 48 51 50 55 46 99 97 112 7 117 110 105 48 51 50 56 11 117 110 105 48 51 50 56 46 99 97 112 7 117 110 105 48 51 50 57 7 117 110 105 48 51 50 65 7 117 110 105 48 51 50 67 7 117 110 105 48 51 50 69 7 117 110 105 48 51 50 70 7 117 110 105 48 51 51 48 7 117 110 105 48 51 51 49 7 117 110 105 48 51 51 52 7 117 110 105 48 51 51 57 7 117 110 105 48 51 51 65 7 117 110 105 48 51 51 66 7 117 110 105 48 51 51 67 7 117 110 105 48 51 51 68 7 117 110 105 48 51 52 50 11 117 110 105 48 51 52 50 46 99 97 112 7 117 110 105 48 51 52 53 7 117 110 105 48 51 53 70 7 117 110 105 48 51 54 49 11 117 110 105 48 51 48 56 48 51 48 49 15 117 110 105 48 51 48 56 48 51 48 49 46 99 97 112 13 117 110 105 48 51 48 56 48 51 48 49 46 103 11 117 110 105 48 51 48 56 48 51 48 48 15 117 110 105 48 51 48 56 48 51 48 48 46 99 97 112 13 117 110 105 48 51 48 56 48 51 48 48 46 103 11 117 110 105 48 51 48 56 48 51 48 51 11 117 110 105 48 51 48 56 48 51 48 52 15 117 110 105 48 51 48 56 48 51 48 52 46 99 97 112 11 117 110 105 48 51 48 56 48 51 48 67 15 117 110 105 48 51 48 56 48 51 48 67 46 99 97 112 11 117 110 105 48 51 48 50 48 51 48 49 15 117 110 105 48 51 48 50 48 51 48 49 46 99 97 112 11 117 110 105 48 51 48 50 48 51 48 48 15 117 110 105 48 51 48 50 48 51 48 48 46 99 97 112 11 117 110 105 48 51 48 50 48 51 48 57 15 117 110 105 48 51 48 50 48 51 48 57 46 99 97 112 11 117 110 105 48 51 48 50 48 51 48 51 15 117 110 105 48 51 48 50 48 51 48 51 46 99 97 112 11 117 110 105 48 51 48 54 48 51 48 49 15 117 110 105 48 51 48 54 48 51 48 49 46 99 97 112 11 117 110 105 48 51 48 54 48 51 48 48 15 117 110 105 48 51 48 54 48 51 48 48 46 99 97 112 11 117 110 105 48 51 48 54 48 51 48 57 15 117 110 105 48 51 48 54 48 51 48 57 46 99 97 112 11 117 110 105 48 51 48 54 48 51 48 51 15 117 110 105 48 51 48 54 48 51 48 51 46 99 97 112 11 117 110 105 48 51 48 50 48 51 48 54 15 117 110 105 48 51 48 50 48 51 48 54 46 99 97 112 11 117 110 105 48 51 48 52 48 51 48 49 15 117 110 105 48 51 48 52 48 51 48 49 46 99 97 112 11 117 110 105 48 51 48 67 48 51 48 55 15 117 110 105 48 51 48 67 48 51 48 55 46 99 97 112 11 117 110 105 48 51 49 50 48 51 48 49 11 117 110 105 48 51 49 50 48 51 48 48 11 117 110 105 48 51 49 50 48 51 48 51 11 117 110 105 48 51 49 51 48 51 48 49 11 117 110 105 48 51 49 51 48 51 48 48 11 117 110 105 48 51 49 51 48 51 48 51 7 117 110 105 48 48 65 48 7 117 110 105 50 48 48 55 10 115 112 97 99 101 46 102 114 97 99 12 110 98 115 112 97 99 101 46 102 114 97 99 7 117 110 105 50 53 48 48 7 117 110 105 50 53 48 49 7 117 110 105 50 53 48 50 7 117 110 105 50 53 48 51 7 117 110 105 50 53 48 52 7 117 110 105 50 53 48 53 7 117 110 105 50 53 48 54 7 117 110 105 50 53 48 55 7 117 110 105 50 53 48 56 7 117 110 105 50 53 48 57 7 117 110 105 50 53 48 65 7 117 110 105 50 53 48 66 7 117 110 105 50 53 48 67 7 117 110 105 50 53 48 68 7 117 110 105 50 53 48 69 7 117 110 105 50 53 48 70 7 117 110 105 50 53 49 48 7 117 110 105 50 53 49 49 7 117 110 105 50 53 49 50 7 117 110 105 50 53 49 51 7 117 110 105 50 53 49 52 7 117 110 105 50 53 49 53 7 117 110 105 50 53 49 54 7 117 110 105 50 53 49 55 7 117 110 105 50 53 49 56 7 117 110 105 50 53 49 57 7 117 110 105 50 53 49 65 7 117 110 105 50 53 49 66 7 117 110 105 50 53 49 67 7 117 110 105 50 53 49 68 7 117 110 105 50 53 49 69 7 117 110 105 50 53 49 70 7 117 110 105 50 53 50 48 7 117 110 105 50 53 50 49 7 117 110 105 50 53 50 50 7 117 110 105 50 53 50 51 7 117 110 105 50 53 50 52 7 117 110 105 50 53 50 53 7 117 110 105 50 53 50 54 7 117 110 105 50 53 50 55 7 117 110 105 50 53 50 56 7 117 110 105 50 53 50 57 7 117 110 105 50 53 50 65 7 117 110 105 50 53 50 66 7 117 110 105 50 53 50 67 7 117 110 105 50 53 50 68 7 117 110 105 50 53 50 69 7 117 110 105 50 53 50 70 7 117 110 105 50 53 51 48 7 117 110 105 50 53 51 49 7 117 110 105 50 53 51 50 7 117 110 105 50 53 51 51 7 117 110 105 50 53 51 52 7 117 110 105 50 53 51 53 7 117 110 105 50 53 51 54 7 117 110 105 50 53 51 55 7 117 110 105 50 53 51 56 7 117 110 105 50 53 51 57 7 117 110 105 50 53 51 65 7 117 110 105 50 53 51 66 7 117 110 105 50 53 51 67 7 117 110 105 50 53 51 68 7 117 110 105 50 53 51 69 7 117 110 105 50 53 51 70 7 117 110 105 50 53 52 48 7 117 110 105 50 53 52 49 7 117 110 105 50 53 52 50 7 117 110 105 50 53 52 51 7 117 110 105 50 53 52 52 7 117 110 105 50 53 52 53 7 117 110 105 50 53 52 54 7 117 110 105 50 53 52 55 7 117 110 105 50 53 52 56 7 117 110 105 50 53 52 57 7 117 110 105 50 53 52 65 7 117 110 105 50 53 52 66 7 117 110 105 50 53 52 67 7 117 110 105 50 53 52 68 7 117 110 105 50 53 52 69 7 117 110 105 50 53 52 70 7 117 110 105 50 53 53 48 7 117 110 105 50 53 53 49 7 117 110 105 50 53 53 50 7 117 110 105 50 53 53 51 7 117 110 105 50 53 53 52 7 117 110 105 50 53 53 53 7 117 110 105 50 53 53 54 7 117 110 105 50 53 53 55 7 117 110 105 50 53 53 56 7 117 110 105 50 53 53 57 7 117 110 105 50 53 53 65 7 117 110 105 50 53 53 66 7 117 110 105 50 53 53 67 7 117 110 105 50 53 53 68 7 117 110 105 50 53 53 69 7 117 110 105 50 53 53 70 7 117 110 105 50 53 54 48 7 117 110 105 50 53 54 49 7 117 110 105 50 53 54 50 7 117 110 105 50 53 54 51 7 117 110 105 50 53 54 52 7 117 110 105 50 53 54 53 7 117 110 105 50 53 54 54 7 117 110 105 50 53 54 55 7 117 110 105 50 53 54 56 7 117 110 105 50 53 54 57 7 117 110 105 50 53 54 65 7 117 110 105 50 53 54 66 7 117 110 105 50 53 54 67 7 117 110 105 50 53 54 68 7 117 110 105 50 53 54 69 7 117 110 105 50 53 54 70 7 117 110 105 50 53 55 48 7 117 110 105 50 53 55 49 7 117 110 105 50 53 55 50 7 117 110 105 50 53 55 51 7 117 110 105 50 53 55 52 7 117 110 105 50 53 55 53 7 117 110 105 50 53 55 54 7 117 110 105 50 53 55 55 7 117 110 105 50 53 55 56 7 117 110 105 50 53 55 57 7 117 110 105 50 53 55 65 7 117 110 105 50 53 55 66 7 117 110 105 50 53 55 67 7 117 110 105 50 53 55 68 7 117 110 105 50 53 55 69 7 117 110 105 50 53 55 70 7 117 110 105 50 53 56 48 7 117 110 105 50 53 56 49 7 117 110 105 50 53 56 50 7 117 110 105 50 53 56 51 7 117 110 105 50 53 56 52 7 117 110 105 50 53 56 53 7 117 110 105 50 53 56 54 7 117 110 105 50 53 56 55 7 117 110 105 50 53 56 56 7 117 110 105 50 53 56 57 7 117 110 105 50 53 56 65 7 117 110 105 50 53 56 66 7 117 110 105 50 53 56 67 7 117 110 105 50 53 56 68 7 117 110 105 50 53 56 69 7 117 110 105 50 53 56 70 7 117 110 105 50 53 57 48 7 117 110 105 50 53 57 49 7 117 110 105 50 53 57 50 7 117 110 105 50 53 57 51 7 117 110 105 50 53 57 52 7 117 110 105 50 53 57 53 7 117 110 105 50 53 57 54 7 117 110 105 50 53 57 55 7 117 110 105 50 53 57 56 7 117 110 105 50 53 57 57 7 117 110 105 50 53 57 65 7 117 110 105 50 53 57 66 7 117 110 105 50 53 57 67 7 117 110 105 50 53 57 68 7 117 110 105 50 53 57 69 7 117 110 105 50 53 57 70 7 117 110 105 50 48 50 70 7 117 110 105 70 69 70 70 7 117 110 105 69 48 65 48 7 117 110 105 69 48 65 49 7 117 110 105 69 48 65 50 7 117 110 105 69 48 66 48 7 117 110 105 69 48 66 49 7 117 110 105 69 48 66 50 7 117 110 105 69 48 66 51 0 0 0 0 0 1 255 255 0 2 0 1 0 0 0 8 0 0 0 4 0 14 0 2 105 100 101 111 114 111 109 110 0 4 68 70 76 84 0 26 99 121 114 108 0 26 103 114 101 107 0 26 108 97 116 110 0 26 0 6 0 0 0 0 0 1 0 2 0 8 0 12 0 1 255 86 0 1 0 0 0 0 0 1 0 0 0 12 0 0 0 0 2 92 0 2 0 98 0 4 0 55 0 1 0 57 0 57 0 1 0 60 0 60 0 1 0 63 0 63 0 1 0 66 0 66 0 1 0 79 0 79 0 1 0 93 0 93 0 1 0 96 0 96 0 1 0 103 0 103 0 1 0 120 0 120 0 2 0 136 0 136 0 1 0 150 0 150 0 1 0 167 0 167 0 1 0 172 0 172 0 1 0 180 0 180 0 1 0 187 0 187 0 1 0 189 0 189 0 1 0 211 0 211 0 1 0 222 0 222 0 1 0 229 0 229 0 1 0 254 0 254 0 1 1 0 1 1 0 1 1 2 1 2 0 4 1 3 1 4 0 2 1 6 1 6 0 1 1 9 1 9 0 1 1 12 1 12 0 1 1 15 1 15 0 1 1 28 1 28 0 1 1 38 1 38 0 2 1 42 1 42 0 1 1 44 1 44 0 1 1 50 1 50 0 1 1 65 1 65 0 2 1 68 1 68 0 2 1 83 1 83 0 1 1 87 1 87 0 1 1 94 1 94 0 2 1 99 1 99 0 1 1 117 1 117 0 1 1 121 1 121 0 1 1 131 1 131 0 1 1 137 1 137 0 1 1 139 1 139 0 1 1 157 1 157 0 2 1 163 1 163 0 1 1 174 1 174 0 1 1 181 1 181 0 1 1 206 1 209 0 1 1 210 1 210 0 4 1 211 1 212 0 2 1 213 2 28 0 1 2 31 2 32 0 1 2 34 2 34 0 1 2 37 2 37 0 1 2 40 2 40 0 1 2 55 2 56 0 1 2 61 2 61 0 2 2 65 2 66 0 1 2 74 2 74 0 1 2 78 2 84 0 1 2 88 2 88 0 1 2 90 2 90 0 1 2 92 2 92 0 1 2 98 2 98 0 1 2 100 2 100 0 1 2 103 2 103 0 1 2 107 2 107 0 1 2 117 2 117 0 1 2 121 2 121 0 1 2 123 2 123 0 1 2 125 2 125 0 1 2 131 2 131 0 1 2 133 2 133 0 1 2 136 2 136 0 1 2 140 2 140 0 1 2 196 2 196 0 1 2 201 2 204 0 1 2 206 2 206 0 1 2 210 2 210 0 1 2 215 2 215 0 1 2 223 2 223 0 1 2 225 2 227 0 1 2 245 2 246 0 1 2 255 3 0 0 1 3 7 3 7 0 1 3 12 3 12 0 1 3 15 3 15 0 1 3 17 3 23 0 1 3 25 3 34 0 1 3 37 3 46 0 1 3 64 3 65 0 1 3 90 3 90 0 1 3 159 3 159 0 4 4 235 4 235 0 1 4 236 5 11 0 3 5 13 5 54 0 3 5 57 5 95 0 3 0 2 0 5 4 236 5 11 0 1 5 13 5 20 0 1 5 34 5 34 0 1 5 51 5 53 0 1 5 57 5 95 0 1 0 0 0 1 0 0 0 10 0 154 1 236 0 4 68 70 76 84 0 26 99 121 114 108 0 42 103 114 101 107 0 76 108 97 116 110 0 92 0 4 0 0 0 0 255 255 0 3 0 0 0 7 0 14 0 10 0 1 83 82 66 32 0 22 0 0 255 255 0 3 0 1 0 8 0 15 0 0 255 255 0 3 0 2 0 9 0 16 0 4 0 0 0 0 255 255 0 3 0 3 0 10 0 17 0 16 0 2 78 83 77 32 0 28 83 75 83 32 0 40 0 0 255 255 0 3 0 4 0 11 0 18 0 0 255 255 0 3 0 5 0 12 0 19 0 0 255 255 0 3 0 6 0 13 0 20 0 21 109 97 114 107 0 128 109 97 114 107 0 148 109 97 114 107 0 168 109 97 114 107 0 188 109 97 114 107 0 208 109 97 114 107 0 228 109 97 114 107 0 248 109 107 109 107 1 12 109 107 109 107 1 18 109 107 109 107 1 24 109 107 109 107 1 30 109 107 109 107 1 36 109 107 109 107 1 42 109 107 109 107 1 48 115 105 122 101 1 54 115 105 122 101 1 58 115 105 122 101 1 62 115 105 122 101 1 66 115 105 122 101 1 70 115 105 122 101 1 74 115 105 122 101 1 78 0 0 0 8 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 0 0 8 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 0 0 8 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 0 0 8 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 0 0 8 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 0 0 8 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 0 0 8 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 0 0 1 0 8 0 0 0 1 0 8 0 0 0 1 0 8 0 0 0 1 0 8 0 0 0 1 0 8 0 0 0 1 0 8 0 0 0 1 0 8 0 122 0 0 0 118 0 0 0 114 0 0 0 110 0 0 0 106 0 0 0 102 0 0 0 98 0 0 0 9 0 20 0 30 0 38 0 46 0 54 0 62 0 70 0 78 0 86 0 1 0 0 0 2 0 84 0 94 0 4 0 0 0 1 0 92 0 4 0 0 0 1 5 194 0 4 0 0 0 1 5 220 0 4 0 0 0 1 7 46 0 4 0 0 0 1 10 126 0 4 0 0 0 1 10 162 0 4 0 0 0 1 10 212 0 6 1 0 0 1 11 108 0 100 0 0 0 0 0 0 0 0 0 1 13 10 0 5 254 212 253 168 0 1 13 10 0 4 253 168 0 1 13 42 13 76 0 1 0 12 1 90 0 83 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 40 0 0 3 46 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 40 0 0 3 40 0 0 3 40 0 0 3 40 0 0 3 40 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 40 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 46 0 0 3 40 0 0 3 40 0 0 3 40 0 0 3 40 0 0 3 40 0 0 3 40 0 236 1 224 1 230 1 236 1 224 1 242 1 248 1 254 1 224 1 224 2 4 2 10 2 16 1 224 2 22 1 224 2 28 2 34 2 40 2 46 1 224 1 224 1 224 1 224 1 224 1 224 2 52 2 58 2 64 2 70 2 76 2 82 2 88 2 94 2 100 2 106 2 106 2 112 2 118 2 124 2 130 1 218 2 136 2 142 2 148 2 154 2 160 2 166 1 218 1 218 1 218 2 142 2 172 1 224 2 178 2 184 1 242 1 224 2 16 1 224 1 224 1 224 2 190 1 224 1 224 1 224 2 184 2 52 2 196 2 58 2 82 2 76 2 202 2 106 2 208 2 118 1 218 1 218 1 218 2 130 2 160 2 166 2 166 2 214 2 64 2 130 2 208 2 220 2 226 2 232 2 238 2 244 2 250 3 0 2 94 2 142 2 58 3 6 3 12 3 18 3 24 2 58 2 208 2 142 3 6 3 30 1 218 1 218 3 36 3 42 3 42 1 218 2 106 1 218 3 48 2 118 2 118 2 118 3 54 3 60 3 66 1 218 2 142 3 72 2 220 3 78 1 218 3 84 3 90 3 96 3 102 3 108 2 148 2 148 2 82 2 238 2 154 3 114 3 114 3 120 3 126 2 166 1 218 2 154 1 218 1 218 3 132 1 218 2 58 3 138 2 142 3 144 3 150 3 156 3 90 3 162 3 90 3 162 2 22 2 142 3 168 3 6 3 174 3 180 3 174 3 174 2 208 3 186 2 208 3 180 2 208 1 224 1 242 1 224 1 224 1 224 2 28 1 224 1 224 2 220 3 192 3 108 3 198 1 218 3 192 3 204 1 218 1 224 1 242 1 224 3 210 2 40 2 52 1 224 2 40 1 224 3 216 3 222 3 210 1 224 2 40 1 224 1 224 2 178 1 224 2 58 2 58 3 228 3 234 2 82 1 218 3 24 3 138 2 58 3 240 1 218 1 218 1 218 1 218 2 136 2 70 1 218 2 142 2 154 2 142 1 218 1 218 3 246 1 218 3 252 4 2 4 8 4 14 1 218 3 6 2 142 1 218 0 1 1 44 1 251 0 1 1 44 2 164 0 1 1 45 2 164 0 1 1 90 2 164 0 1 1 75 2 164 0 1 1 86 2 164 0 1 1 74 2 164 0 1 1 68 2 164 0 1 1 70 2 164 0 1 0 189 2 164 0 1 1 54 2 164 0 1 1 64 2 164 0 1 1 46 2 173 0 1 1 48 2 164 0 1 1 60 2 164 0 1 1 61 2 164 0 1 1 64 1 251 0 1 0 137 2 224 0 1 1 90 1 251 0 1 1 203 2 224 0 1 1 60 1 251 0 1 1 164 2 224 0 1 1 51 1 251 0 1 0 131 2 224 0 1 1 92 2 226 0 1 0 178 2 224 0 1 1 29 2 224 0 1 1 59 1 252 0 1 1 62 1 251 0 1 1 65 1 251 0 1 1 48 1 251 0 1 1 100 1 251 0 1 1 47 1 251 0 1 1 0 2 131 0 1 1 39 1 251 0 1 1 66 1 251 0 1 1 164 2 164 0 1 1 43 2 164 0 1 1 127 2 164 0 1 1 66 2 164 0 1 1 58 1 251 0 1 1 92 1 251 0 1 1 74 2 224 0 1 1 68 1 251 0 1 1 63 1 251 0 1 1 37 2 224 0 1 1 34 1 251 0 1 1 84 1 251 0 1 1 96 2 224 0 1 1 110 2 224 0 1 1 54 1 251 0 1 0 229 1 251 0 1 1 74 1 251 0 1 1 45 1 251 0 1 1 78 1 251 0 1 1 35 1 251 0 1 1 15 2 224 0 1 1 28 1 251 0 1 0 123 2 224 0 1 0 191 1 251 0 1 1 38 1 252 0 1 1 71 1 251 0 1 1 53 1 251 0 1 1 98 1 251 0 1 1 44 2 224 0 1 1 154 1 251 0 1 1 154 2 224 0 1 1 70 1 251 0 1 1 106 2 224 0 1 0 235 1 251 0 1 0 253 2 131 0 1 1 141 2 224 0 1 1 55 1 251 0 1 1 24 2 218 0 1 1 74 2 131 0 1 1 37 2 218 0 1 1 50 2 224 0 1 1 50 1 251 0 1 1 72 2 226 0 1 1 72 1 251 0 1 1 72 2 8 0 1 1 80 1 251 0 1 1 26 1 251 0 1 1 40 1 251 0 1 1 58 2 164 0 1 1 27 2 164 0 1 1 39 2 164 0 1 1 93 1 251 0 1 1 77 1 251 0 1 1 88 1 251 0 1 0 240 1 251 0 1 0 169 1 251 0 1 1 38 1 251 0 1 1 31 1 251 0 1 1 61 1 251 0 1 9 140 9 146 0 1 0 12 0 18 0 1 0 0 0 10 0 1 0 10 0 1 1 44 1 251 0 1 1 223 1 251 0 1 9 118 9 126 0 1 0 12 0 22 0 2 0 0 0 118 0 0 0 118 0 53 0 114 0 120 0 126 0 132 0 138 0 144 0 108 0 150 0 156 0 162 0 108 0 168 0 174 0 108 0 108 0 180 0 186 0 162 0 192 0 198 0 204 0 210 0 216 0 222 0 228 0 234 0 240 0 108 0 246 0 252 1 2 1 8 0 240 0 186 1 8 0 108 1 14 1 20 1 26 0 222 0 108 1 32 1 38 1 44 1 50 0 204 0 222 1 56 1 44 1 62 1 62 1 62 0 108 0 1 1 44 0 0 0 1 2 8 0 0 0 1 1 94 0 0 0 1 1 30 0 0 0 1 1 70 0 0 0 1 0 170 0 0 0 1 0 122 0 0 0 1 1 93 0 0 0 1 1 230 0 0 0 1 1 217 0 0 0 1 0 137 0 0 0 1 1 63 0 0 0 1 1 239 0 0 0 1 1 64 0 0 0 1 1 90 0 0 0 1 1 39 0 0 0 1 1 60 0 0 0 1 1 42 0 0 0 1 0 134 0 0 0 1 1 98 0 0 0 1 1 107 0 0 0 1 2 2 0 0 0 1 1 224 0 0 0 1 0 183 0 0 0 1 1 58 0 0 0 1 1 133 0 0 0 1 1 208 0 0 0 1 1 196 0 0 0 1 1 54 0 0 0 1 1 193 0 0 0 1 1 199 0 0 0 1 1 24 0 0 0 1 1 209 0 0 0 1 1 40 0 0 0 1 1 187 0 0 0 1 1 78 0 0 0 1 8 146 8 180 0 1 0 12 0 106 0 23 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 0 1 156 0 158 1 62 1 68 1 74 1 80 1 86 1 92 1 98 1 62 1 62 1 62 1 104 1 110 1 62 1 62 1 62 1 116 1 122 1 128 1 62 1 62 1 134 1 140 1 62 1 62 1 146 1 62 1 152 1 158 1 164 1 146 1 170 1 176 1 182 1 188 1 194 1 200 1 206 1 212 1 128 1 62 1 218 1 224 1 230 1 236 1 242 1 62 1 62 1 62 1 62 1 248 1 182 1 254 2 4 1 110 1 62 1 62 1 62 2 4 1 164 2 10 1 236 1 164 1 188 1 206 1 62 1 62 1 236 1 242 1 62 2 10 1 218 2 16 1 194 2 10 1 146 1 146 2 22 2 28 2 34 1 62 1 80 1 164 1 122 2 40 2 46 1 146 2 52 2 58 1 194 2 64 2 64 2 70 2 76 1 62 2 82 1 146 2 16 1 62 1 188 1 62 2 88 2 94 1 206 1 206 2 100 2 106 2 112 1 80 2 118 2 124 2 130 2 136 1 134 1 62 2 142 2 148 2 154 2 154 2 124 2 160 1 230 1 146 1 164 2 166 2 172 2 172 2 178 2 184 1 62 1 62 1 140 1 62 1 62 2 10 1 62 2 190 2 196 2 202 2 208 2 214 1 122 2 214 1 122 1 164 2 64 2 220 2 220 2 220 1 188 2 220 2 88 1 62 1 62 1 62 2 226 2 232 1 62 1 62 0 1 1 44 255 236 0 1 1 51 255 236 0 1 1 88 255 236 0 1 1 38 255 236 0 1 1 77 255 236 0 1 0 181 255 236 0 1 1 74 255 236 0 1 1 82 255 236 0 1 1 93 255 236 0 1 0 140 255 236 0 1 1 64 255 236 0 1 1 57 255 236 0 1 1 46 255 236 0 1 1 47 255 236 0 1 1 60 255 236 0 1 1 54 255 236 0 1 1 84 255 236 0 1 1 48 255 236 0 1 1 35 255 236 0 1 1 52 255 37 0 1 1 58 255 236 0 1 1 92 255 236 0 1 0 237 255 37 0 1 1 79 255 236 0 1 1 129 255 236 0 1 1 52 255 236 0 1 0 137 255 37 0 1 1 205 255 37 0 1 0 191 255 236 0 1 1 53 255 236 0 1 1 124 255 236 0 1 1 11 255 37 0 1 1 80 255 236 0 1 1 34 255 236 0 1 1 50 255 236 0 1 1 105 255 37 0 1 1 24 255 236 0 1 1 104 255 236 0 1 1 51 255 37 0 1 1 40 255 236 0 1 0 225 255 236 0 1 1 31 255 236 0 1 1 45 255 236 0 1 1 38 255 37 0 1 1 70 255 236 0 1 1 44 255 30 0 1 1 97 255 163 0 1 0 223 255 37 0 1 1 194 255 37 0 1 1 129 255 37 0 1 1 101 255 37 0 1 1 87 255 236 0 1 1 240 255 30 0 1 1 48 255 37 0 1 0 174 255 37 0 1 1 174 255 37 0 1 1 94 255 236 0 1 1 44 255 37 0 1 1 15 255 236 0 1 1 72 255 37 0 1 1 54 255 37 0 1 1 0 255 37 0 1 1 96 255 184 0 1 1 124 255 37 0 1 1 30 255 30 0 1 1 74 255 37 0 1 1 78 255 236 0 1 1 75 255 37 0 1 1 23 255 236 0 1 1 72 255 236 0 1 1 22 255 236 0 1 0 135 255 236 0 1 6 38 6 44 0 1 0 12 0 18 0 1 0 0 0 14 0 3 0 14 0 20 0 8 0 1 1 44 0 244 0 1 0 176 1 81 0 1 1 32 1 129 0 1 6 10 6 16 0 1 0 12 0 18 0 1 0 0 0 16 0 4 0 16 0 22 0 28 0 34 0 1 1 44 1 230 0 1 1 164 2 134 0 1 1 247 2 154 0 1 1 155 1 230 0 1 1 159 1 230 0 1 5 226 5 234 0 1 0 12 0 22 0 2 0 0 0 76 0 0 0 76 0 32 0 72 0 78 0 66 0 66 0 66 0 66 0 84 0 90 0 96 0 66 0 102 0 108 0 72 0 72 0 72 0 78 0 66 0 114 0 84 0 84 0 84 0 90 0 96 0 66 0 120 0 126 0 126 0 126 0 126 0 132 0 132 0 66 0 1 1 44 0 0 0 1 1 248 0 0 0 1 1 173 0 0 0 1 1 180 0 0 0 1 1 148 0 0 0 1 1 100 0 0 0 1 1 170 0 0 0 1 1 6 255 151 0 1 1 54 0 0 0 1 1 40 0 0 0 1 1 174 0 0 0 1 1 80 0 0 0 1 1 226 5 142 0 1 0 12 1 90 0 83 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 104 0 0 1 110 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 104 0 0 1 104 0 0 1 104 0 0 1 104 0 0 1 104 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 104 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 110 0 0 1 104 0 0 1 104 0 0 1 104 0 0 1 104 0 0 1 104 0 0 1 104 0 12 0 38 0 38 0 44 0 50 0 56 0 56 0 50 0 50 0 62 0 68 0 74 0 80 0 1 1 44 1 251 0 1 1 44 2 164 0 1 1 44 2 106 0 1 1 44 2 220 0 1 1 44 2 76 0 1 1 44 2 62 0 1 1 44 2 197 0 1 1 44 2 105 0 1 1 44 2 91 0 1 1 44 2 84 0 2 0 1 4 89 4 91 0 0 0 2 0 6 4 236 5 11 0 0 5 13 5 56 0 32 5 59 5 59 0 76 5 62 5 62 0 77 5 90 5 95 0 78 6 5 6 5 0 84 0 2 0 5 4 236 5 11 0 0 5 13 5 20 0 32 5 34 5 34 0 40 5 51 5 53 0 41 5 57 5 95 0 44 0 2 0 71 0 4 0 55 0 0 0 66 0 66 0 52 0 79 0 79 0 53 0 93 0 93 0 54 0 103 0 103 0 55 0 136 0 136 0 56 0 150 0 150 0 57 0 172 0 172 0 58 0 180 0 180 0 59 0 187 0 187 0 60 0 189 0 189 0 61 0 211 0 211 0 62 0 222 0 222 0 63 0 229 0 229 0 64 0 254 0 254 0 65 1 0 1 1 0 66 1 15 1 15 0 68 1 28 1 28 0 69 1 42 1 42 0 70 1 50 1 50 0 71 1 83 1 83 0 72 1 87 1 87 0 73 1 99 1 99 0 74 1 121 1 121 0 75 1 131 1 131 0 76 1 137 1 137 0 77 1 139 1 139 0 78 1 163 1 163 0 79 1 174 1 174 0 80 1 181 1 181 0 81 1 206 1 209 0 82 1 213 1 239 0 86 1 241 2 28 0 113 2 31 2 32 0 157 2 55 2 56 0 159 2 65 2 66 0 161 2 74 2 74 0 163 2 78 2 84 0 164 2 88 2 88 0 171 2 90 2 90 0 172 2 92 2 92 0 173 2 98 2 98 0 174 2 100 2 100 0 175 2 103 2 103 0 176 2 107 2 107 0 177 2 117 2 117 0 178 2 121 2 121 0 179 2 123 2 123 0 180 2 125 2 125 0 181 2 131 2 131 0 182 2 133 2 133 0 183 2 136 2 136 0 184 2 140 2 140 0 185 2 196 2 196 0 186 2 201 2 204 0 187 2 206 2 206 0 191 2 210 2 210 0 192 2 215 2 215 0 193 2 223 2 223 0 194 2 225 2 227 0 195 2 245 2 246 0 198 2 255 3 0 0 200 3 7 3 7 0 202 3 12 3 12 0 203 3 15 3 15 0 204 3 17 3 23 0 205 3 25 3 34 0 212 3 37 3 46 0 222 3 64 3 65 0 232 3 90 3 90 0 234 4 235 4 235 0 235 0 1 0 1 5 23 0 1 0 1 4 235 0 1 0 2 5 35 5 36 0 1 0 53 0 4 0 6 0 7 0 8 0 9 0 11 0 12 0 15 0 16 0 17 0 18 0 21 0 22 0 23 0 24 0 27 0 29 0 30 0 32 0 33 0 34 0 35 0 37 0 38 0 41 0 42 0 43 0 44 0 47 0 48 0 49 0 50 0 53 0 55 0 79 0 187 0 189 1 0 1 28 1 87 1 137 1 139 1 216 1 221 1 223 1 225 1 238 2 12 2 32 2 65 2 66 2 78 4 235 0 2 0 5 5 21 5 22 0 0 5 25 5 33 0 2 5 39 5 45 0 11 5 47 5 50 0 18 5 54 5 54 0 22 0 2 0 33 0 4 0 19 0 0 0 21 0 55 0 16 0 79 0 79 0 51 0 93 0 93 0 52 0 150 0 150 0 53 0 180 0 180 0 54 0 211 0 211 0 55 0 229 0 229 0 56 0 254 0 254 0 57 1 0 1 1 0 58 1 28 1 28 0 60 1 42 1 42 0 61 1 87 1 87 0 62 1 99 1 99 0 63 1 131 1 131 0 64 1 137 1 137 0 65 1 139 1 139 0 66 1 163 1 163 0 67 1 181 1 181 0 68 1 206 1 209 0 69 1 213 2 18 0 73 2 21 2 28 0 135 2 32 2 32 0 143 2 56 2 56 0 144 2 65 2 66 0 145 2 78 2 78 0 147 2 81 2 84 0 148 2 90 2 90 0 152 2 107 2 107 0 153 2 117 2 117 0 154 2 123 2 123 0 155 2 140 2 140 0 156 4 235 4 235 0 157 0 1 0 1 5 46 0 1 0 3 0 15 0 41 4 235 0 1 0 1 5 24 0 1 0 4 0 18 0 24 0 44 4 235 0 1 0 2 5 37 5 38 0 1 0 32 0 4 0 8 0 12 0 18 0 24 0 28 0 30 0 34 0 38 0 44 0 50 0 54 0 57 0 60 0 63 0 96 0 167 1 0 1 6 1 9 1 12 1 44 1 87 1 117 1 223 2 32 2 34 2 37 2 40 2 65 2 66 4 235 0 1 0 12 4 236 4 239 4 242 4 244 4 246 4 248 4 250 4 251 4 254 5 0 5 2 5 6 0 1 0 0 0 10 2 44 13 218 0 4 68 70 76 84 0 26 99 121 114 108 0 98 103 114 101 107 0 248 108 97 116 110 1 66 0 4 0 0 0 0 255 255 0 31 0 0 0 7 0 14 0 21 0 28 0 35 0 42 0 49 0 56 0 63 0 70 0 77 0 84 0 91 0 98 0 105 0 112 0 124 0 131 0 138 0 145 0 152 0 159 0 166 0 173 0 180 0 187 0 194 0 201 0 208 0 215 0 10 0 1 83 82 66 32 0 80 0 0 255 255 0 32 0 1 0 8 0 15 0 22 0 29 0 36 0 43 0 50 0 57 0 64 0 71 0 78 0 85 0 92 0 99 0 106 0 113 0 119 0 125 0 132 0 139 0 146 0 153 0 160 0 167 0 174 0 181 0 188 0 195 0 202 0 209 0 216 0 0 255 255 0 32 0 2 0 9 0 16 0 23 0 30 0 37 0 44 0 51 0 58 0 65 0 72 0 79 0 86 0 93 0 100 0 107 0 114 0 120 0 126 0 133 0 140 0 147 0 154 0 161 0 168 0 175 0 182 0 189 0 196 0 203 0 210 0 217 0 4 0 0 0 0 255 255 0 32 0 3 0 10 0 17 0 24 0 31 0 38 0 45 0 52 0 59 0 66 0 73 0 80 0 87 0 94 0 101 0 108 0 115 0 121 0 127 0 134 0 141 0 148 0 155 0 162 0 169 0 176 0 183 0 190 0 197 0 204 0 211 0 218 0 16 0 2 78 83 77 32 0 84 83 75 83 32 0 154 0 0 255 255 0 31 0 4 0 11 0 18 0 25 0 32 0 39 0 46 0 53 0 60 0 67 0 74 0 81 0 88 0 95 0 102 0 109 0 116 0 128 0 135 0 142 0 149 0 156 0 163 0 170 0 177 0 184 0 191 0 198 0 205 0 212 0 219 0 0 255 255 0 32 0 5 0 12 0 19 0 26 0 33 0 40 0 47 0 54 0 61 0 68 0 75 0 82 0 89 0 96 0 103 0 110 0 117 0 122 0 129 0 136 0 143 0 150 0 157 0 164 0 171 0 178 0 185 0 192 0 199 0 206 0 213 0 220 0 0 255 255 0 32 0 6 0 13 0 20 0 27 0 34 0 41 0 48 0 55 0 62 0 69 0 76 0 83 0 90 0 97 0 104 0 111 0 118 0 123 0 130 0 137 0 144 0 151 0 158 0 165 0 172 0 179 0 186 0 193 0 200 0 207 0 214 0 221 0 222 99 97 115 101 5 54 99 97 115 101 5 60 99 97 115 101 5 66 99 97 115 101 5 72 99 97 115 101 5 78 99 97 115 101 5 84 99 97 115 101 5 90 99 99 109 112 5 96 99 99 109 112 5 110 99 99 109 112 5 124 99 99 109 112 5 138 99 99 109 112 5 152 99 99 109 112 5 166 99 99 109 112 5 180 99 118 48 49 5 194 99 118 48 49 5 200 99 118 48 49 5 206 99 118 48 49 5 212 99 118 48 49 5 218 99 118 48 49 5 224 99 118 48 49 5 230 99 118 48 50 5 236 99 118 48 50 5 242 99 118 48 50 5 248 99 118 48 50 5 254 99 118 48 50 6 4 99 118 48 50 6 10 99 118 48 50 6 16 99 118 48 52 6 22 99 118 48 52 6 28 99 118 48 52 6 34 99 118 48 52 6 40 99 118 48 52 6 46 99 118 48 52 6 52 99 118 48 52 6 58 99 118 48 54 6 64 99 118 48 54 6 70 99 118 48 54 6 76 99 118 48 54 6 82 99 118 48 54 6 88 99 118 48 54 6 94 99 118 48 54 6 100 99 118 48 55 6 106 99 118 48 55 6 112 99 118 48 55 6 118 99 118 48 55 6 124 99 118 48 55 6 130 99 118 48 55 6 136 99 118 48 55 6 142 99 118 48 56 6 148 99 118 48 56 6 154 99 118 48 56 6 160 99 118 48 56 6 166 99 118 48 56 6 172 99 118 48 56 6 178 99 118 48 56 6 184 99 118 48 57 6 190 99 118 48 57 6 196 99 118 48 57 6 202 99 118 48 57 6 208 99 118 48 57 6 214 99 118 48 57 6 220 99 118 48 57 6 226 99 118 49 48 6 232 99 118 49 48 6 238 99 118 49 48 6 244 99 118 49 48 6 250 99 118 49 48 7 0 99 118 49 48 7 6 99 118 49 48 7 12 99 118 49 49 7 18 99 118 49 49 7 24 99 118 49 49 7 30 99 118 49 49 7 36 99 118 49 49 7 42 99 118 49 49 7 48 99 118 49 49 7 54 99 118 49 50 7 60 99 118 49 50 7 66 99 118 49 50 7 72 99 118 49 50 7 78 99 118 49 50 7 84 99 118 49 50 7 90 99 118 49 50 7 96 99 118 49 52 7 102 99 118 49 52 7 108 99 118 49 52 7 114 99 118 49 52 7 120 99 118 49 52 7 126 99 118 49 52 7 132 99 118 49 52 7 138 99 118 49 53 7 144 99 118 49 53 7 150 99 118 49 53 7 156 99 118 49 53 7 162 99 118 49 53 7 168 99 118 49 53 7 174 99 118 49 53 7 180 99 118 49 54 7 186 99 118 49 54 7 192 99 118 49 54 7 198 99 118 49 54 7 204 99 118 49 54 7 210 99 118 49 54 7 216 99 118 49 54 7 222 100 110 111 109 7 228 100 110 111 109 7 234 100 110 111 109 7 240 100 110 111 109 7 246 100 110 111 109 7 252 100 110 111 109 8 2 100 110 111 109 8 8 102 114 97 99 8 14 102 114 97 99 8 24 102 114 97 99 8 34 102 114 97 99 8 44 102 114 97 99 8 54 102 114 97 99 8 64 102 114 97 99 8 74 108 111 99 108 8 84 108 111 99 108 8 90 108 111 99 108 8 98 108 111 99 108 8 104 108 111 99 108 8 110 110 117 109 114 8 116 110 117 109 114 8 122 110 117 109 114 8 128 110 117 109 114 8 134 110 117 109 114 8 140 110 117 109 114 8 146 110 117 109 114 8 152 111 110 117 109 8 158 111 110 117 109 8 164 111 110 117 109 8 170 111 110 117 109 8 176 111 110 117 109 8 182 111 110 117 109 8 188 111 110 117 109 8 194 111 114 100 110 8 200 111 114 100 110 8 206 111 114 100 110 8 212 111 114 100 110 8 218 111 114 100 110 8 224 111 114 100 110 8 230 111 114 100 110 8 236 115 97 108 116 8 242 115 97 108 116 9 12 115 97 108 116 9 38 115 97 108 116 9 64 115 97 108 116 9 90 115 97 108 116 9 116 115 97 108 116 9 142 115 105 110 102 9 168 115 105 110 102 9 174 115 105 110 102 9 180 115 105 110 102 9 186 115 105 110 102 9 192 115 105 110 102 9 198 115 105 110 102 9 204 115 115 48 49 9 210 115 115 48 49 9 218 115 115 48 49 9 226 115 115 48 49 9 234 115 115 48 49 9 242 115 115 48 49 9 250 115 115 48 49 10 2 115 115 48 50 10 10 115 115 48 50 10 18 115 115 48 50 10 26 115 115 48 50 10 34 115 115 48 50 10 42 115 115 48 50 10 50 115 115 48 50 10 58 115 115 48 51 10 66 115 115 48 51 10 76 115 115 48 51 10 86 115 115 48 51 10 96 115 115 48 51 10 106 115 115 48 51 10 116 115 115 48 51 10 126 115 115 48 52 10 136 115 115 48 52 10 142 115 115 48 52 10 148 115 115 48 52 10 154 115 115 48 52 10 160 115 115 48 52 10 166 115 115 48 52 10 172 115 115 48 53 10 178 115 115 48 53 10 186 115 115 48 53 10 194 115 115 48 53 10 202 115 115 48 53 10 210 115 115 48 53 10 218 115 115 48 53 10 226 115 115 48 54 10 234 115 115 48 54 10 240 115 115 48 54 10 246 115 115 48 54 10 252 115 115 48 54 11 2 115 115 48 54 11 8 115 115 48 54 11 14 115 117 98 115 11 20 115 117 98 115 11 26 115 117 98 115 11 32 115 117 98 115 11 38 115 117 98 115 11 44 115 117 98 115 11 50 115 117 98 115 11 56 115 117 112 115 11 62 115 117 112 115 11 72 115 117 112 115 11 82 115 117 112 115 11 92 115 117 112 115 11 102 115 117 112 115 11 112 115 117 112 115 11 122 122 101 114 111 11 132 122 101 114 111 11 138 122 101 114 111 11 144 122 101 114 111 11 150 122 101 114 111 11 156 122 101 114 111 11 162 122 101 114 111 11 168 0 0 0 1 0 29 0 0 0 1 0 29 0 0 0 1 0 29 0 0 0 1 0 29 0 0 0 1 0 29 0 0 0 1 0 29 0 0 0 1 0 29 0 0 0 5 0 15 0 16 0 17 0 18 0 19 0 0 0 5 0 15 0 16 0 17 0 18 0 19 0 0 0 5 0 15 0 16 0 17 0 18 0 19 0 0 0 5 0 15 0 16 0 17 0 18 0 19 0 0 0 5 0 15 0 16 0 17 0 18 0 19 0 0 0 5 0 15 0 16 0 17 0 18 0 19 0 0 0 5 0 15 0 16 0 17 0 18 0 19 10 250 0 1 0 0 10 244 0 1 0 0 10 238 0 1 0 0 10 232 0 1 0 0 10 226 0 1 0 0 10 220 0 1 0 0 10 214 0 1 0 0 10 222 0 1 0 1 10 216 0 1 0 1 10 210 0 1 0 1 10 204 0 1 0 1 10 198 0 1 0 1 10 192 0 1 0 1 10 186 0 1 0 1 10 194 0 1 0 2 10 188 0 1 0 2 10 182 0 1 0 2 10 176 0 1 0 2 10 170 0 1 0 2 10 164 0 1 0 2 10 158 0 1 0 2 10 166 0 1 0 3 10 160 0 1 0 3 10 154 0 1 0 3 10 148 0 1 0 3 10 142 0 1 0 3 10 136 0 1 0 3 10 130 0 1 0 3 10 138 0 1 0 4 10 132 0 1 0 4 10 126 0 1 0 4 10 120 0 1 0 4 10 114 0 1 0 4 10 108 0 1 0 4 10 102 0 1 0 4 10 110 0 1 0 5 10 104 0 1 0 5 10 98 0 1 0 5 10 92 0 1 0 5 10 86 0 1 0 5 10 80 0 1 0 5 10 74 0 1 0 5 10 82 0 1 0 6 10 76 0 1 0 6 10 70 0 1 0 6 10 64 0 1 0 6 10 58 0 1 0 6 10 52 0 1 0 6 10 46 0 1 0 6 10 54 0 1 0 8 10 48 0 1 0 8 10 42 0 1 0 8 10 36 0 1 0 8 10 30 0 1 0 8 10 24 0 1 0 8 10 18 0 1 0 8 10 26 0 1 0 7 10 20 0 1 0 7 10 14 0 1 0 7 10 8 0 1 0 7 10 2 0 1 0 7 9 252 0 1 0 7 9 246 0 1 0 7 9 254 0 1 0 9 9 248 0 1 0 9 9 242 0 1 0 9 9 236 0 1 0 9 9 230 0 1 0 9 9 224 0 1 0 9 9 218 0 1 0 9 9 226 0 1 0 10 9 220 0 1 0 10 9 214 0 1 0 10 9 208 0 1 0 10 9 202 0 1 0 10 9 196 0 1 0 10 9 190 0 1 0 10 9 198 0 1 0 11 9 192 0 1 0 11 9 186 0 1 0 11 9 180 0 1 0 11 9 174 0 1 0 11 9 168 0 1 0 11 9 162 0 1 0 11 9 170 0 1 0 12 9 164 0 1 0 12 9 158 0 1 0 12 9 152 0 1 0 12 9 146 0 1 0 12 9 140 0 1 0 12 9 134 0 1 0 12 0 0 0 1 0 21 0 0 0 1 0 21 0 0 0 1 0 21 0 0 0 1 0 21 0 0 0 1 0 21 0 0 0 1 0 21 0 0 0 1 0 21 0 0 0 3 0 20 0 22 0 23 0 0 0 3 0 20 0 22 0 23 0 0 0 3 0 20 0 22 0 23 0 0 0 3 0 20 0 22 0 23 0 0 0 3 0 20 0 22 0 23 0 0 0 3 0 20 0 22 0 23 0 0 0 3 0 20 0 22 0 23 0 0 0 1 0 7 0 0 0 2 0 7 0 8 0 0 0 1 0 13 0 0 0 1 0 3 0 0 0 1 0 3 0 0 0 1 0 20 0 0 0 1 0 20 0 0 0 1 0 20 0 0 0 1 0 20 0 0 0 1 0 20 0 0 0 1 0 20 0 0 0 1 0 20 0 0 0 1 0 28 0 0 0 1 0 28 0 0 0 1 0 28 0 0 0 1 0 28 0 0 0 1 0 28 0 0 0 1 0 28 0 0 0 1 0 28 0 0 0 1 0 24 0 0 0 1 0 24 0 0 0 1 0 24 0 0 0 1 0 24 0 0 0 1 0 24 0 0 0 1 0 24 0 0 0 1 0 24 0 0 0 11 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 9 0 10 0 11 0 12 0 0 0 11 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 9 0 10 0 11 0 12 0 0 0 11 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 9 0 10 0 11 0 12 0 0 0 11 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 9 0 10 0 11 0 12 0 0 0 11 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 9 0 10 0 11 0 12 0 0 0 11 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 9 0 10 0 11 0 12 0 0 0 11 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 9 0 10 0 11 0 12 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 1 0 27 9 28 0 2 0 10 0 11 9 20 0 2 0 10 0 11 9 12 0 2 0 10 0 11 9 4 0 2 0 10 0 11 8 252 0 2 0 10 0 11 8 244 0 2 0 10 0 11 8 236 0 2 0 10 0 11 8 232 0 2 0 0 0 4 8 224 0 2 0 0 0 4 8 216 0 2 0 0 0 4 8 208 0 2 0 0 0 4 8 200 0 2 0 0 0 4 8 192 0 2 0 0 0 4 8 184 0 2 0 0 0 4 8 180 0 3 0 1 0 5 0 8 8 170 0 3 0 1 0 5 0 8 8 160 0 3 0 1 0 5 0 8 8 150 0 3 0 1 0 5 0 8 8 140 0 3 0 1 0 5 0 8 8 130 0 3 0 1 0 5 0 8 8 120 0 3 0 1 0 5 0 8 8 114 0 1 0 2 8 108 0 1 0 2 8 102 0 1 0 2 8 96 0 1 0 2 8 90 0 1 0 2 8 84 0 1 0 2 8 78 0 1 0 2 8 76 0 2 0 3 0 6 8 68 0 2 0 3 0 6 8 60 0 2 0 3 0 6 8 52 0 2 0 3 0 6 8 44 0 2 0 3 0 6 8 36 0 2 0 3 0 6 8 28 0 2 0 3 0 6 8 24 0 1 0 12 8 18 0 1 0 12 8 12 0 1 0 12 8 6 0 1 0 12 8 0 0 1 0 12 7 250 0 1 0 12 7 244 0 1 0 12 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 1 0 27 0 0 0 3 0 24 0 25 0 26 0 0 0 3 0 24 0 25 0 26 0 0 0 3 0 24 0 25 0 26 0 0 0 3 0 24 0 25 0 26 0 0 0 3 0 24 0 25 0 26 0 0 0 3 0 24 0 25 0 26 0 0 0 3 0 24 0 25 0 26 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 32 0 66 0 74 0 82 0 90 0 98 0 106 0 114 0 122 0 130 0 138 0 146 0 154 0 162 0 170 0 178 0 186 0 198 0 210 0 218 0 226 0 236 0 244 0 252 1 4 1 16 1 24 1 32 1 40 1 48 1 56 1 64 1 72 0 1 0 0 0 1 1 14 0 1 0 0 0 1 1 68 0 1 0 0 0 1 1 86 0 1 0 0 0 1 1 120 0 1 0 0 0 1 1 118 0 1 0 0 0 1 1 116 0 1 0 0 0 1 1 114 0 1 0 0 0 1 1 112 0 1 0 0 0 1 1 110 0 1 0 0 0 1 1 108 0 1 0 0 0 1 1 106 0 1 0 0 0 1 1 104 0 1 0 0 0 1 1 102 0 1 0 0 0 1 1 100 0 2 0 0 0 1 1 106 0 6 0 0 0 3 1 184 1 202 1 220 0 6 0 0 0 3 1 226 1 246 2 10 0 4 0 0 0 1 2 16 0 4 0 0 0 1 3 18 0 6 0 0 0 2 4 8 4 26 0 1 0 0 0 1 4 216 0 1 0 0 0 1 4 242 0 1 0 0 0 1 5 12 0 6 0 0 0 3 5 10 5 28 5 46 0 1 0 0 0 1 5 54 0 1 0 0 0 1 5 110 0 1 0 0 0 1 5 136 0 1 0 0 0 1 5 142 0 1 0 0 0 1 5 168 0 1 0 0 0 1 5 166 0 4 0 0 0 1 6 24 0 1 0 0 0 1 6 46 0 2 6 154 0 28 2 32 2 33 2 34 2 35 2 36 2 37 2 38 2 39 2 40 2 41 2 42 2 55 2 43 2 44 2 45 2 46 2 47 2 48 2 49 2 50 2 51 2 52 2 53 2 54 3 90 3 91 4 24 4 59 0 2 6 132 0 10 2 56 2 57 2 58 2 59 2 60 2 61 2 62 2 63 2 64 4 60 0 2 6 128 0 18 2 65 2 67 2 68 2 69 2 70 2 71 2 72 2 73 2 74 2 75 2 76 2 77 2 66 2 78 2 80 2 82 3 93 4 61 0 1 6 126 1 30 0 1 6 126 0 24 0 1 6 126 0 19 0 1 6 126 0 7 0 1 6 126 0 1 0 1 6 128 0 76 0 1 6 128 0 10 0 1 6 132 0 67 0 1 6 136 0 30 0 1 6 136 255 155 0 2 6 136 0 4 4 238 4 241 5 18 5 20 0 1 6 134 0 10 0 26 0 32 0 38 0 44 0 50 0 56 0 62 0 68 0 74 0 80 0 2 0 8 4 242 0 2 0 8 4 246 0 2 0 18 4 242 0 2 0 18 4 246 0 2 0 34 4 242 0 2 0 34 4 246 0 2 0 44 4 242 0 2 0 44 4 246 0 2 0 12 5 0 0 2 1 87 5 0 0 3 0 0 0 1 6 72 0 1 6 84 0 1 0 0 0 14 0 3 0 0 0 1 6 72 0 1 6 84 0 1 0 0 0 14 0 3 0 0 0 1 6 72 0 1 6 66 0 1 0 0 0 14 0 3 0 0 0 2 6 62 6 68 0 1 6 74 0 1 0 0 0 30 0 3 0 0 0 2 6 120 6 48 0 1 6 54 0 1 0 0 0 30 0 3 0 0 0 1 6 106 0 1 6 34 0 1 0 0 0 31 0 1 6 104 0 5 0 16 0 58 0 100 0 166 0 216 0 5 0 12 0 18 0 24 0 30 0 36 5 70 0 2 4 236 5 68 0 2 4 239 5 74 0 2 4 244 5 84 0 2 4 250 5 72 0 2 5 2 0 5 0 12 0 18 0 24 0 30 0 36 5 78 0 2 4 236 5 76 0 2 4 239 5 82 0 2 4 244 5 80 0 2 5 2 5 82 0 2 5 52 0 8 0 18 0 24 0 30 0 36 0 42 0 48 0 54 0 60 5 60 0 2 4 236 5 62 0 2 4 238 5 57 0 2 4 239 5 59 0 2 4 241 5 63 0 2 4 244 5 64 0 2 4 246 5 66 0 2 5 10 5 63 0 2 5 52 0 6 0 14 0 20 0 26 0 32 0 38 0 44 5 91 0 2 4 236 5 91 0 2 4 238 5 90 0 2 4 239 5 90 0 2 4 241 5 92 0 2 4 244 5 92 0 2 5 52 0 6 0 14 0 20 0 26 0 32 0 38 0 44 5 94 0 2 4 236 5 94 0 2 4 238 5 93 0 2 4 239 5 93 0 2 4 241 5 95 0 2 4 244 5 95 0 2 5 52 0 1 5 108 0 19 0 44 0 54 0 64 0 74 0 84 0 96 0 106 0 116 0 126 0 136 0 146 0 164 0 174 0 194 0 204 0 214 0 224 0 234 0 244 0 1 0 4 0 66 0 2 5 37 0 1 0 4 0 103 0 2 5 37 0 1 0 4 0 120 0 2 4 244 0 1 0 4 0 136 0 2 5 37 0 1 0 4 1 3 0 3 3 159 0 15 0 1 0 4 0 172 0 2 5 37 0 1 0 4 0 222 0 2 5 37 0 1 0 4 1 15 0 2 5 37 0 1 0 4 1 38 0 2 5 10 0 1 0 4 1 50 0 2 5 37 0 2 0 6 0 12 1 68 0 2 4 244 1 65 0 2 5 35 0 1 0 4 1 83 0 2 5 37 0 2 0 6 0 14 1 211 0 3 3 159 0 41 1 94 0 2 5 10 0 1 0 4 1 121 0 2 5 37 0 1 0 4 1 157 0 2 5 10 0 1 0 4 1 174 0 2 5 37 0 1 0 4 1 4 0 2 4 239 0 1 0 4 1 212 0 2 4 239 0 1 0 4 2 61 0 2 5 35 0 3 0 1 4 152 0 1 4 228 0 0 0 1 0 0 0 31 0 3 0 1 5 24 0 1 4 210 0 0 0 1 0 0 0 31 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 2 0 0 0 0 0 0 0 0 0 0 0 0 1 3 0 0 0 0 0 0 0 0 0 0 0 0 1 4 0 0 0 0 0 0 0 0 0 0 0 0 1 5 0 0 0 0 0 0 0 0 0 0 0 0 1 6 0 0 0 0 0 0 0 0 0 0 0 0 1 7 0 0 0 0 0 0 0 0 0 0 0 0 1 8 0 0 0 0 0 0 0 0 0 0 0 0 1 9 0 0 0 0 0 0 0 0 0 0 0 0 1 10 0 0 0 0 0 0 0 0 0 0 0 0 1 11 0 0 0 0 0 0 0 0 0 0 0 0 1 12 0 0 0 0 0 0 0 0 0 0 0 2 4 150 0 14 4 9 4 10 4 11 4 12 4 13 4 14 4 15 4 16 4 17 4 18 4 21 4 22 4 19 4 20 0 2 4 116 0 14 3 251 3 252 3 253 3 254 3 255 4 0 4 1 4 2 4 3 4 4 4 7 4 8 4 5 4 6 0 1 4 104 0 163 0 3 0 1 4 104 0 1 4 114 0 0 0 1 0 0 0 31 0 3 0 1 4 104 0 1 4 120 0 0 0 1 0 0 0 31 0 3 0 2 4 122 4 112 0 1 4 102 0 0 0 1 0 0 0 31 0 2 4 110 0 29 4 26 4 27 4 28 4 29 4 30 4 31 4 32 4 33 4 34 4 35 4 36 4 37 4 38 4 39 4 40 4 41 4 42 4 43 4 44 4 45 4 46 4 47 4 48 4 49 4 50 4 51 4 52 4 53 4 55 0 2 3 212 0 14 3 223 3 224 3 225 3 226 3 227 3 228 3 229 3 230 3 231 3 232 3 235 3 236 3 233 3 234 0 2 4 34 0 4 4 62 4 63 4 64 4 65 0 2 3 164 0 14 3 237 3 238 3 239 3 240 3 241 3 242 3 243 3 244 3 245 3 246 3 249 3 250 3 247 3 248 0 1 3 254 0 11 0 2 4 2 0 46 1 4 2 163 3 119 3 120 3 121 3 122 3 123 3 124 3 125 3 126 3 127 3 128 3 216 4 237 4 240 4 243 4 245 4 247 4 249 4 252 4 253 4 255 5 1 5 3 5 7 5 9 5 11 5 14 5 16 5 36 5 38 5 52 5 58 5 61 5 65 5 67 5 69 5 71 5 73 5 75 5 77 5 79 5 81 5 83 5 85 5 87 0 0 1 13 0 0 1 14 0 0 1 15 0 0 1 16 0 0 1 17 0 0 1 18 0 1 3 232 0 2 0 10 0 20 0 1 0 4 2 79 0 2 5 37 0 1 0 4 2 80 0 2 5 37 0 2 3 210 0 55 5 98 1 87 1 209 2 79 2 81 2 83 2 80 3 251 3 252 3 253 3 254 3 255 4 0 4 1 4 2 4 3 4 4 4 5 4 6 4 7 4 8 4 237 4 240 4 243 4 245 4 247 4 249 4 252 4 253 4 255 5 1 5 3 5 7 5 9 5 11 5 14 5 16 5 36 5 38 5 52 5 58 5 61 5 65 5 67 5 69 5 71 5 73 5 75 5 77 5 79 5 81 5 83 5 85 5 87 5 99 0 2 0 6 0 30 0 30 0 0 1 5 1 27 0 1 3 15 3 15 0 24 3 81 3 81 0 25 4 23 4 23 0 26 4 26 4 26 0 27 0 2 0 3 0 36 0 36 0 0 1 61 1 68 0 1 4 32 4 32 0 9 0 1 0 18 0 38 1 76 1 77 1 78 1 79 1 80 1 81 1 82 1 83 1 84 1 85 1 86 1 87 1 238 2 79 2 81 3 53 4 34 0 1 0 1 1 1 0 1 0 1 2 118 0 1 0 1 2 124 0 1 0 1 2 137 0 1 0 2 4 250 4 252 0 1 0 1 3 16 0 1 0 3 3 97 3 108 3 119 0 2 0 1 3 152 3 154 0 0 0 1 0 1 3 188 0 1 0 1 4 67 0 1 0 4 4 236 4 239 5 17 5 19 0 1 0 10 0 97 0 100 0 165 0 168 1 45 1 48 1 115 1 118 2 235 3 54 0 1 0 4 0 97 0 165 1 45 1 115 0 1 0 1 4 250 0 1 0 4 0 100 0 168 1 48 1 118 0 1 0 1 4 239 0 1 0 2 2 235 3 54 0 1 0 1 0 38 0 1 0 1 5 37 0 1 0 31 4 236 4 239 4 242 4 244 4 246 4 248 4 250 4 251 4 254 5 0 5 2 5 6 5 8 5 10 5 13 5 15 5 52 5 57 5 60 5 64 5 66 5 68 5 70 5 72 5 74 5 76 5 78 5 80 5 82 5 84 5 86 0 1 0 1 2 65 0 1 0 6 0 38 0 39 1 83 1 238 1 240 2 74 0 1 0 5 4 242 4 250 5 0 5 18 5 20 0 1 0 19 0 4 0 8 0 10 0 12 0 15 0 18 0 24 0 30 0 33 0 34 0 36 0 38 0 41 0 44 0 49 0 50 1 2 1 210 2 56 0 2 0 12 0 4 0 29 0 0 0 56 0 91 0 26 0 93 0 93 0 62 0 95 0 122 0 63 0 124 0 124 0 91 0 126 0 199 0 92 0 201 0 204 0 166 0 206 0 234 0 170 0 236 0 250 0 199 0 252 1 2 0 214 2 84 2 116 0 221 2 196 3 14 0 254 0 1 0 33 4 236 4 239 4 242 4 244 4 246 4 248 4 250 4 251 4 254 5 0 5 2 5 6 5 8 5 10 5 13 5 15 5 35 5 37 5 52 5 57 5 60 5 64 5 66 5 68 5 70 5 72 5 74 5 76 5 78 5 80 5 82 5 84 5 86 0 1 0 33 4 237 4 240 4 243 4 245 4 247 4 249 4 252 4 253 4 255 5 1 5 3 5 7 5 9 5 11 5 14 5 16 5 36 5 38 5 52 5 58 5 61 5 65 5 67 5 69 5 71 5 73 5 75 5 77 5 79 5 81 5 83 5 85 5 87 0 2 0 3 3 97 3 106 0 0 3 130 3 131 0 10 3 178 3 179 0 12 0 1 0 1 3 184 0 2 0 1 4 9 4 18 0 0 0 1 0 2 0 3 5 96 0 2 0 2 3 251 4 8 0 0 4 89 4 91 0 14 0 2 0 1 4 9 4 22 0 0 0 2 0 1 3 251 4 4 0 0 0 1 0 2 5 98 5 99 0 2 0 3 0 30 0 55 0 0 1 43 1 44 0 26 1 223 1 223 0 28 0 1 0 4 3 132 3 152 3 155 3 156 0 2 0 1 3 97 3 106 0 0 0 1 0 46 1 212 2 162 3 108 3 109 3 110 3 111 3 112 3 113 3 114 3 115 3 116 3 117 3 215 4 236 4 239 4 242 4 244 4 246 4 248 4 250 4 251 4 254 5 0 5 2 5 6 5 8 5 10 5 13 5 15 5 35 5 37 5 52 5 57 5 60 5 64 5 66 5 68 5 70 5 72 5 74 5 76 5 78 5 80 5 82 5 84 5 86 0 1 0 2 0 38 2 65 0 1 0 55 0 3 0 38 0 39 1 83 1 238 1 240 2 74 4 9 4 10 4 11 4 12 4 13 4 14 4 15 4 16 4 17 4 18 4 19 4 20 4 21 4 22 4 236 4 239 4 242 4 244 4 246 4 248 4 250 4 251 4 254 5 0 5 2 5 6 5 8 5 10 5 13 5 15 5 35 5 37 5 52 5 57 5 60 5 64 5 66 5 68 5 70 5 72 5 74 5 76 5 78 5 80 5 82 5 84 5 86 5 96 0 0 0 0 0 10 0 0 0 0 0 13 4 188 4 188 0 0 0 158 0 0 1 123 4 189 4 189 0 0 2 25 0 0 1 28 4 190 4 190 0 0 3 53 0 0 1 99 4 191 4 191 0 0 4 152 0 0 1 100 4 192 4 192 0 0 5 252 0 0 1 44 4 194 4 194 0 0 7 40 0 0 0 213 4 196 4 196 0 0 7 253 0 0 3 237 4 197 4 197 0 0 11 234 0 0 3 235 4 198 4 198 0 0 15 213 0 0 1 47 4 199 4 199 0 0 17 4 0 0 2 198 4 200 4 200 0 0 19 202 0 0 3 145 4 201 4 201 0 0 23 91 0 0 3 73 4 202 4 202 0 0 26 164 0 0 1 178 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 49 50 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 100 61 34 109 45 50 53 32 49 48 49 48 104 53 57 56 108 53 50 45 54 49 118 45 54 50 48 104 45 53 56 57 108 45 54 49 32 53 49 122 34 47 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 102 102 102 34 32 100 61 34 109 49 56 32 52 48 51 104 53 51 50 118 53 54 52 104 45 53 51 50 122 34 47 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 101 100 49 99 50 52 34 32 100 61 34 109 50 53 48 32 56 57 54 108 56 54 45 49 48 99 55 51 45 50 54 52 32 50 49 54 45 52 56 55 32 51 55 48 45 54 51 49 108 45 53 52 45 53 48 99 45 49 53 50 32 49 53 49 45 50 57 54 32 51 57 50 45 51 54 52 32 54 50 51 104 45 52 99 45 50 55 45 56 52 45 54 57 45 49 55 48 45 49 49 56 45 50 52 55 108 45 53 54 32 51 56 99 53 55 32 56 53 32 49 48 51 32 49 55 53 32 49 52 48 32 50 55 55 34 47 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 49 51 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 101 100 49 99 50 52 34 32 100 61 34 109 49 52 53 32 49 48 49 57 46 53 108 56 54 45 49 48 99 55 54 45 50 55 48 32 50 50 49 45 52 57 55 32 51 55 57 45 54 52 52 108 45 53 52 45 53 48 99 45 49 53 54 32 49 53 52 45 50 57 57 32 51 57 57 45 51 55 48 32 54 51 54 104 45 52 99 45 51 49 45 56 57 45 55 55 45 49 56 50 45 49 51 50 45 50 54 53 108 45 53 54 32 51 56 99 54 51 32 57 49 32 49 49 49 32 49 56 53 32 49 53 49 32 50 57 53 34 47 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 49 52 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 50 57 97 98 101 50 34 32 100 61 34 109 49 55 56 32 49 48 50 52 99 57 50 32 48 32 49 55 50 45 53 55 32 49 55 50 45 49 54 55 118 45 52 48 55 99 56 48 32 50 53 32 49 50 53 32 56 55 32 49 50 53 32 49 53 48 32 48 32 51 54 45 51 32 54 48 45 49 51 32 57 50 108 51 53 32 49 51 99 49 53 45 51 49 32 51 50 45 55 57 32 51 50 45 49 51 49 32 48 45 55 54 45 50 52 45 49 51 50 45 49 49 52 45 49 57 54 45 53 48 45 51 54 45 54 48 45 52 53 45 55 48 45 55 50 104 45 53 48 118 53 51 55 99 45 57 45 54 45 51 53 45 49 50 45 54 49 45 49 50 45 57 51 32 48 45 49 53 55 32 53 54 45 49 53 55 32 49 49 55 32 48 32 53 48 32 52 55 32 55 54 32 49 48 49 32 55 54 34 47 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 49 53 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 50 57 97 98 101 50 34 32 100 61 34 109 50 49 53 32 51 50 53 46 53 118 53 49 55 99 45 57 45 54 45 51 53 45 49 50 45 54 49 45 49 50 45 56 57 32 48 45 49 53 48 32 53 54 45 49 53 48 32 49 49 55 32 48 32 53 48 32 52 55 32 55 54 32 49 48 48 32 55 54 32 56 56 32 48 32 49 54 54 45 53 55 32 49 54 54 45 49 54 55 118 45 51 56 55 46 55 108 50 54 55 45 52 50 46 52 118 51 54 51 46 49 99 45 57 45 54 45 51 53 45 49 50 45 54 49 45 49 50 45 56 57 32 48 45 49 52 57 32 53 54 45 49 52 57 32 49 49 55 32 48 32 53 48 32 52 54 32 55 54 32 57 57 32 55 54 32 56 57 32 48 32 49 54 55 45 53 54 32 49 54 55 45 49 54 54 118 45 53 51 57 108 45 51 55 56 32 54 48 34 47 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 49 54 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 101 100 49 99 50 52 34 32 100 61 34 109 51 48 50 32 49 48 49 50 99 50 52 49 45 50 53 56 32 50 56 57 45 51 56 52 32 50 56 57 45 53 50 55 32 48 45 49 51 48 45 54 51 45 49 57 56 45 49 52 53 45 49 57 56 45 54 52 32 48 45 49 49 54 32 51 49 45 49 52 52 32 49 50 48 104 45 52 99 45 50 56 45 56 57 45 55 57 45 49 50 48 45 49 52 52 45 49 50 48 45 56 50 32 48 45 49 52 53 32 54 56 45 49 52 53 32 49 57 56 32 48 32 49 52 51 32 52 56 32 50 54 57 32 50 56 57 32 53 50 55 104 52 34 47 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 49 56 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 101 100 49 99 50 52 34 32 100 61 34 109 51 48 49 46 53 32 49 48 49 50 108 50 57 51 45 51 54 55 118 45 52 108 45 50 57 51 45 51 54 53 104 45 52 108 45 50 57 51 32 51 54 53 118 52 108 50 57 51 32 51 54 55 104 52 34 47 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 50 48 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 102 99 101 101 50 49 34 32 100 61 34 109 50 57 57 46 53 32 52 48 56 46 53 99 45 49 55 48 32 48 45 50 57 49 32 49 50 50 45 50 57 49 32 50 57 49 115 49 50 49 32 50 57 49 32 50 57 49 32 50 57 49 32 50 57 49 45 49 50 50 32 50 57 49 45 50 57 49 45 49 50 49 45 50 57 49 45 50 57 49 45 50 57 49 34 47 62 10 9 60 103 32 102 105 108 108 61 34 35 102 48 52 56 54 55 34 62 10 9 9 60 112 97 116 104 32 100 61 34 109 49 51 57 46 53 32 54 51 54 46 56 99 45 52 50 46 53 32 48 45 55 50 46 56 32 51 48 46 53 45 55 50 46 56 32 55 50 46 55 32 48 32 52 50 46 51 32 51 48 46 51 32 55 50 46 56 32 55 50 46 56 32 55 50 46 56 32 52 50 46 53 32 48 32 55 50 46 55 45 51 48 46 53 32 55 50 46 55 45 55 50 46 56 32 48 45 52 50 46 51 45 51 48 46 50 45 55 50 46 55 45 55 50 46 55 45 55 50 46 55 34 47 62 10 9 9 60 112 97 116 104 32 100 61 34 109 52 53 57 46 53 32 54 51 54 46 56 99 45 52 50 46 53 32 48 45 55 50 46 56 32 51 48 46 53 45 55 50 46 56 32 55 50 46 55 32 48 32 52 50 46 51 32 51 48 46 51 32 55 50 46 56 32 55 50 46 56 32 55 50 46 56 32 52 50 46 53 32 48 32 55 50 46 55 45 51 48 46 53 32 55 50 46 55 45 55 50 46 56 32 48 45 52 50 46 51 45 51 48 46 50 45 55 50 46 55 45 55 50 46 55 45 55 50 46 55 34 47 62 10 9 60 47 103 62 10 9 60 112 97 116 104 32 100 61 34 109 50 50 48 46 53 32 54 56 57 46 53 99 51 48 32 48 32 52 57 45 50 54 32 52 57 45 54 52 115 45 49 57 45 54 52 45 52 57 45 54 52 45 52 56 32 50 54 45 52 56 32 54 52 32 49 56 32 54 52 32 52 56 32 54 52 34 47 62 10 9 60 112 97 116 104 32 100 61 34 109 51 55 56 46 53 32 54 56 57 46 53 99 51 48 32 48 32 52 56 45 50 54 32 52 56 45 54 52 115 45 49 56 45 54 52 45 52 56 45 54 52 45 52 57 32 50 54 45 52 57 32 54 52 32 49 57 32 54 52 32 52 57 32 54 52 34 47 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 52 50 50 49 48 98 34 32 100 61 34 109 50 57 57 46 53 32 56 55 55 46 53 99 56 56 32 48 32 49 52 53 45 52 57 32 49 53 53 45 49 51 48 108 45 51 52 45 49 51 99 45 49 56 32 53 50 45 54 50 32 55 53 45 49 50 49 32 55 53 115 45 49 48 51 45 50 51 45 49 50 49 45 55 53 108 45 51 52 32 49 51 99 49 48 32 56 49 32 54 55 32 49 51 48 32 49 53 53 32 49 51 48 34 47 62 10 9 60 103 32 102 105 108 108 61 34 35 102 102 102 34 62 10 9 9 60 112 97 116 104 32 100 61 34 109 50 51 53 46 53 32 54 51 50 46 53 99 45 56 32 48 45 49 51 45 54 45 49 51 45 49 53 115 53 45 49 53 32 49 51 45 49 53 32 49 51 32 54 32 49 51 32 49 53 45 53 32 49 53 45 49 51 32 49 53 34 47 62 10 9 9 60 112 97 116 104 32 100 61 34 109 51 57 50 46 53 32 54 51 50 46 53 99 45 56 32 48 45 49 50 45 54 45 49 50 45 49 53 115 52 45 49 53 32 49 50 45 49 53 32 49 51 32 54 32 49 51 32 49 53 45 53 32 49 53 45 49 51 32 49 53 34 47 62 10 9 60 47 103 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 50 49 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 50 57 97 98 101 50 34 32 100 61 34 109 50 57 57 46 53 32 52 48 56 46 53 99 45 49 55 48 32 48 45 50 57 49 32 49 50 50 45 50 57 49 32 50 57 49 115 49 50 49 32 50 57 49 32 50 57 49 32 50 57 49 32 50 57 49 45 49 50 50 32 50 57 49 45 50 57 49 45 49 50 49 45 50 57 49 45 50 57 49 45 50 57 49 34 47 62 10 9 60 103 32 102 105 108 108 61 34 35 99 54 51 97 56 101 34 62 10 9 9 60 112 97 116 104 32 100 61 34 109 49 51 57 46 53 32 54 51 54 46 56 99 45 52 50 46 53 32 48 45 55 50 46 56 32 51 48 46 53 45 55 50 46 56 32 55 50 46 55 32 48 32 52 50 46 51 32 51 48 46 51 32 55 50 46 56 32 55 50 46 56 32 55 50 46 56 32 52 50 46 53 32 48 32 55 50 46 55 45 51 48 46 53 32 55 50 46 55 45 55 50 46 56 32 48 45 52 50 46 51 45 51 48 46 50 45 55 50 46 55 45 55 50 46 55 45 55 50 46 55 34 47 62 10 9 9 60 112 97 116 104 32 100 61 34 109 52 53 57 46 53 32 54 51 54 46 56 99 45 52 50 46 53 32 48 45 55 50 46 56 32 51 48 46 53 45 55 50 46 56 32 55 50 46 55 32 48 32 52 50 46 51 32 51 48 46 51 32 55 50 46 56 32 55 50 46 56 32 55 50 46 56 32 52 50 46 53 32 48 32 55 50 46 55 45 51 48 46 53 32 55 50 46 55 45 55 50 46 56 32 48 45 52 50 46 51 45 51 48 46 50 45 55 50 46 55 45 55 50 46 55 45 55 50 46 55 34 47 62 10 9 60 47 103 62 10 9 60 112 97 116 104 32 100 61 34 109 50 54 57 46 53 32 54 50 53 46 53 99 48 45 51 56 45 49 56 45 54 52 45 52 56 45 54 52 115 45 52 57 32 50 54 45 52 57 32 54 52 32 49 57 32 54 52 32 52 57 32 54 52 32 52 56 45 50 54 32 52 56 45 54 52 34 47 62 10 9 60 112 97 116 104 32 100 61 34 109 52 50 54 46 53 32 54 50 53 46 53 99 48 45 51 56 45 49 57 45 54 52 45 52 57 45 54 52 115 45 52 56 32 50 54 45 52 56 32 54 52 32 49 56 32 54 52 32 52 56 32 54 52 32 52 57 45 50 54 32 52 57 45 54 52 34 47 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 52 50 50 49 48 98 34 32 100 61 34 109 50 57 57 46 53 32 56 55 55 46 53 99 56 56 32 48 32 49 52 53 45 52 57 32 49 53 53 45 49 51 48 108 45 51 52 45 49 51 99 45 49 56 32 53 50 45 54 50 32 55 53 45 49 50 49 32 55 53 115 45 49 48 51 45 50 51 45 49 50 49 45 55 53 108 45 51 52 32 49 51 99 49 48 32 56 49 32 54 55 32 49 51 48 32 49 53 53 32 49 51 48 34 47 62 10 9 60 103 32 102 105 108 108 61 34 35 102 102 102 34 62 10 9 9 60 112 97 116 104 32 100 61 34 109 49 57 51 46 53 32 54 49 55 46 53 99 48 45 57 32 53 45 49 53 32 49 51 45 49 53 115 49 51 32 54 32 49 51 32 49 53 45 53 32 49 53 45 49 51 32 49 53 45 49 51 45 54 45 49 51 45 49 53 34 47 62 10 9 9 60 112 97 116 104 32 100 61 34 109 51 53 48 46 53 32 54 49 55 46 53 99 48 45 57 32 53 45 49 53 32 49 51 45 49 53 115 49 50 32 54 32 49 50 32 49 53 45 52 32 49 53 45 49 50 32 49 53 45 49 51 45 54 45 49 51 45 49 53 34 47 62 10 9 60 47 103 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 50 50 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 57 101 48 48 53 100 34 32 100 61 34 109 51 48 50 32 49 48 48 57 46 53 99 57 53 45 49 56 55 32 51 54 57 45 49 53 50 32 51 54 57 45 52 52 55 32 48 45 49 51 48 45 56 50 45 50 48 49 45 49 57 55 45 50 48 49 45 56 56 32 48 45 49 52 55 32 51 53 45 49 55 50 32 49 51 51 104 45 52 99 45 50 53 45 57 56 45 56 52 45 49 51 51 45 49 55 50 45 49 51 51 45 49 49 53 32 48 45 49 57 55 32 55 49 45 49 57 55 32 50 48 49 32 48 32 50 57 53 32 50 55 52 32 50 54 48 32 51 54 57 32 52 52 55 104 52 34 47 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 50 51 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 102 50 101 100 101 55 34 32 100 61 34 109 52 55 56 32 55 53 52 99 49 52 45 52 48 32 50 48 45 56 48 32 50 50 45 49 50 48 32 52 51 32 48 32 54 50 32 49 50 32 54 50 32 53 50 32 48 32 52 52 45 51 56 32 54 56 45 56 52 32 54 56 109 45 50 50 54 45 51 52 48 99 45 49 54 48 32 48 45 50 53 48 32 54 51 45 50 53 48 32 49 54 54 32 48 32 50 52 51 32 49 48 49 32 51 52 54 32 50 53 48 32 51 52 54 32 56 55 32 48 32 49 54 52 45 51 50 32 50 48 50 45 49 49 50 32 49 49 53 32 48 32 49 55 48 45 54 50 32 49 55 48 45 49 51 52 32 48 45 54 48 45 52 49 45 49 49 48 45 49 50 50 45 49 49 48 32 48 45 57 56 45 56 57 45 49 53 54 45 50 53 48 45 49 53 54 34 47 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 52 50 50 49 48 98 34 32 100 61 34 109 50 53 50 32 54 55 56 99 49 51 51 32 48 32 49 57 57 45 51 50 32 50 51 50 45 56 56 45 50 48 45 54 49 45 49 48 55 45 49 48 54 45 50 51 50 45 49 48 54 115 45 50 49 50 32 52 52 45 50 51 50 32 49 48 54 99 51 51 32 53 54 32 57 57 32 56 56 32 50 51 50 32 56 56 34 47 62 10 9 60 103 32 102 105 108 108 61 34 35 99 55 98 50 57 57 34 62 10 9 9 60 112 97 116 104 32 100 61 34 109 51 50 49 32 53 56 50 99 45 54 49 32 52 52 45 49 48 54 32 53 56 45 49 52 56 32 53 56 45 51 55 32 48 45 53 55 45 49 54 45 53 55 45 51 50 32 48 45 49 50 32 56 45 50 48 32 51 53 45 50 54 45 50 55 45 54 45 51 53 45 49 52 45 51 53 45 50 54 32 48 45 49 54 32 50 48 45 51 50 32 53 55 45 51 50 32 52 50 32 48 32 56 55 32 49 52 32 49 52 56 32 53 56 34 47 62 10 9 9 60 112 97 116 104 32 100 61 34 109 51 50 54 32 53 56 50 99 51 52 45 50 48 32 54 48 45 50 54 32 55 52 45 50 54 32 49 54 32 48 32 51 48 32 49 48 32 51 48 32 50 54 115 45 49 52 32 50 54 45 51 48 32 50 54 99 45 49 52 32 48 45 52 48 45 54 45 55 52 45 50 54 34 47 62 10 9 60 47 103 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 50 52 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 56 99 54 50 51 57 34 32 100 61 34 109 50 57 57 46 53 32 57 56 54 46 53 99 50 49 50 32 48 32 51 48 52 45 50 55 32 51 48 52 45 49 52 54 32 48 45 54 52 45 50 57 45 49 48 50 45 57 49 45 49 49 56 32 50 52 45 49 56 32 51 54 45 52 54 32 51 54 45 57 48 32 48 45 55 50 45 52 54 45 49 49 48 45 49 48 57 45 49 50 50 32 49 52 45 49 52 32 50 49 45 50 56 32 50 49 45 53 52 32 48 45 53 52 45 52 55 45 57 50 45 49 52 50 45 49 49 56 45 53 55 32 54 50 45 49 56 48 32 50 48 45 49 56 48 32 49 50 48 32 48 32 50 56 32 57 32 52 48 32 50 49 32 53 50 45 54 51 32 49 50 45 49 48 57 32 53 48 45 49 48 57 32 49 50 50 32 48 32 52 52 32 49 50 32 55 50 32 51 54 32 57 48 45 54 50 32 49 54 45 57 49 32 53 52 45 57 49 32 49 49 56 32 48 32 49 49 57 32 57 50 32 49 52 54 32 51 48 52 32 49 52 54 34 47 62 10 9 60 112 97 116 104 32 100 61 34 109 49 52 55 46 53 32 54 56 56 46 53 99 49 45 56 54 32 50 51 45 49 50 48 32 54 53 45 49 50 48 115 54 53 32 51 52 32 54 54 32 49 50 48 108 45 50 56 32 50 99 45 50 45 52 55 45 49 52 45 54 54 45 51 56 45 54 54 115 45 51 53 32 49 57 45 51 55 32 54 54 108 45 50 56 45 50 34 47 62 10 9 60 112 97 116 104 32 100 61 34 109 51 50 48 46 53 32 54 56 56 46 53 99 49 45 56 54 32 50 52 45 49 50 48 32 54 54 45 49 50 48 115 54 52 32 51 52 32 54 53 32 49 50 48 108 45 50 56 32 50 99 45 50 45 52 55 45 49 51 45 54 54 45 51 55 45 54 54 115 45 51 54 32 49 57 45 51 56 32 54 54 108 45 50 56 45 50 34 47 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 52 50 50 49 48 98 34 32 100 61 34 109 50 57 57 46 53 32 55 57 54 46 53 99 53 51 46 55 32 48 32 57 52 46 52 32 49 53 46 55 32 49 49 56 46 54 32 52 55 46 56 32 49 51 46 50 45 49 55 46 53 32 50 49 46 54 45 52 48 46 50 32 50 52 46 52 45 54 55 46 50 104 45 50 56 54 99 50 46 56 32 50 55 32 49 49 46 50 32 52 57 46 55 32 50 52 46 52 32 54 55 46 50 32 50 52 46 50 45 51 50 46 49 32 54 52 46 57 45 52 55 46 56 32 49 49 56 46 54 45 52 55 46 56 34 47 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 101 100 49 101 55 57 34 32 100 61 34 109 50 57 57 46 53 32 56 57 49 46 53 99 53 51 46 55 32 48 32 57 52 46 52 45 49 53 46 53 32 49 49 56 46 54 45 52 55 46 53 45 50 52 46 50 45 51 50 45 54 52 46 57 45 52 55 46 53 45 49 49 56 46 54 45 52 55 46 53 115 45 57 52 46 52 32 49 53 46 53 45 49 49 56 46 54 32 52 55 46 53 99 50 52 46 50 32 51 50 32 54 52 46 57 32 52 55 46 53 32 49 49 56 46 54 32 52 55 46 53 34 47 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 50 53 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 103 32 102 105 108 108 61 34 35 54 54 54 34 62 10 9 9 60 112 97 116 104 32 100 61 34 109 55 48 32 55 57 51 108 45 49 50 45 50 50 52 99 45 53 53 32 48 45 55 54 32 50 48 45 55 54 32 56 51 32 48 32 57 55 32 50 56 46 50 32 49 52 49 32 56 56 32 49 52 49 34 47 62 10 9 9 60 112 97 116 104 32 100 61 34 109 53 51 48 32 55 57 51 99 53 57 46 56 32 48 32 56 56 45 52 52 32 56 56 45 49 52 49 32 48 45 54 51 45 50 49 45 56 51 45 55 54 45 56 51 108 45 49 50 32 50 50 52 34 47 62 10 9 60 47 103 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 99 99 99 34 32 100 61 34 109 51 48 48 32 57 52 54 99 45 49 53 51 32 48 45 50 55 48 45 57 50 46 52 45 50 55 48 45 50 57 54 32 48 45 49 56 51 46 53 32 49 48 52 45 50 53 54 32 50 55 48 45 50 53 54 32 49 54 55 32 48 32 50 55 48 32 55 50 46 53 32 50 55 48 32 50 53 54 32 48 32 50 48 51 46 54 45 49 49 55 32 50 57 54 45 50 55 48 32 50 57 54 34 47 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 51 51 51 34 32 100 61 34 109 51 48 48 32 55 52 50 99 49 51 48 32 48 32 49 57 51 45 50 52 32 49 57 51 45 57 54 32 48 45 49 49 48 45 55 52 45 49 54 48 45 49 57 51 45 49 54 48 115 45 49 57 51 32 53 48 45 49 57 51 32 49 54 48 99 48 32 55 50 32 54 51 32 57 54 32 49 57 51 32 57 54 34 47 62 10 9 60 103 32 102 105 108 108 61 34 35 48 102 102 34 62 10 9 9 60 112 97 116 104 32 100 61 34 109 49 52 55 32 54 54 56 99 50 45 56 54 32 50 54 45 49 50 48 32 54 56 45 49 50 48 115 54 54 32 51 52 32 54 56 32 49 50 48 108 45 51 50 32 50 99 45 50 45 52 52 45 49 50 45 54 50 45 51 54 45 54 50 115 45 51 52 32 49 56 45 51 54 32 54 50 108 45 51 50 45 50 34 47 62 10 9 9 60 112 97 116 104 32 100 61 34 109 51 49 55 32 54 54 56 99 50 45 56 54 32 50 54 45 49 50 48 32 54 56 45 49 50 48 115 54 54 32 51 52 32 54 56 32 49 50 48 108 45 51 50 32 50 99 45 50 45 52 52 45 49 50 45 54 50 45 51 54 45 54 50 115 45 51 52 32 49 56 45 51 54 32 54 50 108 45 51 50 45 50 34 47 62 10 9 60 47 103 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 51 51 51 34 32 100 61 34 109 51 48 48 32 56 54 49 99 50 48 32 48 32 51 55 45 55 32 51 55 45 50 52 32 48 45 49 50 45 55 45 49 53 45 51 55 45 49 53 115 45 51 55 32 51 45 51 55 32 49 53 99 48 32 49 55 32 49 55 32 50 52 32 51 55 32 50 52 34 47 62 10 60 47 115 118 103 62 10 60 63 120 109 108 32 118 101 114 115 105 111 110 61 34 49 46 48 34 32 101 110 99 111 100 105 110 103 61 34 117 116 102 45 56 34 63 62 10 60 115 118 103 32 105 100 61 34 103 108 121 112 104 49 50 50 54 34 32 120 109 108 110 115 61 34 104 116 116 112 58 47 47 119 119 119 46 119 51 46 111 114 103 47 50 48 48 48 47 115 118 103 34 32 118 105 101 119 66 111 120 61 34 48 32 49 48 48 48 32 49 48 48 48 32 49 48 48 48 34 62 10 9 60 112 97 116 104 32 102 105 108 108 61 34 35 102 98 98 48 51 98 34 32 100 61 34 109 56 53 32 49 48 55 48 104 52 51 48 108 52 48 45 51 54 118 45 53 49 56 108 45 52 48 45 51 54 104 45 52 54 118 45 49 53 51 99 48 45 49 49 54 45 54 50 45 49 56 51 45 49 54 57 45 49 56 51 115 45 49 54 57 32 54 55 45 49 54 57 32 49 56 51 118 49 53 51 104 45 52 54 108 45 52 48 32 51 54 118 53 49 56 108 52 48 32 51 54 109 49 49 52 45 53 57 48 118 45 49 52 53 99 48 45 55 57 32 51 51 45 49 50 54 32 49 48 49 45 49 50 54 115 49 48 49 32 52 55 32 49 48 49 32 49 50 54 118 49 52 53 104 45 50 48 50 34 47 62 10 9 60 112 97 116 104 32 100 61 34 109 50 52 54 32 57 52 49 108 50 54 45 49 54 57 99 45 51 57 45 49 53 45 53 54 45 52 51 45 53 54 45 55 57 32 48 45 52 55 32 51 55 45 56 51 32 56 52 45 56 51 115 56 52 32 51 54 32 56 52 32 56 51 99 48 32 51 54 45 49 55 32 54 52 45 53 54 32 55 57 108 50 54 32 49 54 57 45 52 52 32 50 48 104 45 50 48 108 45 52 52 45 50 48 34 47 62 10 60 47 115 118 103 62 10 0 0 0 1 0 1 0 1 0 0 0 1 0 0 24 205 0 0 0 20 0 0 0 0 0 0 24 197 48 130 24 193 6 9 42 134 72 134 247 13 1 7 2 160 130 24 178 48 130 24 174 2 1 1 49 11 48 9 6 5 43 14 3 2 26 5 0 48 97 6 10 43 6 1 4 1 130 55 2 1 4 160 83 48 81 48 44 6 10 43 6 1 4 1 130 55 2 1 28 162 30 128 28 0 60 0 60 0 60 0 79 0 98 0 115 0 111 0 108 0 101 0 116 0 101 0 62 0 62 0 62 48 33 48 9 6 5 43 14 3 2 26 5 0 4 20 139 175 151 63 139 77 122 176 17 57 170 191 230 209 98 35 39 234 191 176 160 130 19 148 48 130 3 238 48 130 3 87 160 3 2 1 2 2 16 126 147 235 251 124 198 78 89 234 75 154 119 212 6 252 59 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 129 139 49 11 48 9 6 3 85 4 6 19 2 90 65 49 21 48 19 6 3 85 4 8 19 12 87 101 115 116 101 114 110 32 67 97 112 101 49 20 48 18 6 3 85 4 7 19 11 68 117 114 98 97 110 118 105 108 108 101 49 15 48 13 6 3 85 4 10 19 6 84 104 97 119 116 101 49 29 48 27 6 3 85 4 11 19 20 84 104 97 119 116 101 32 67 101 114 116 105 102 105 99 97 116 105 111 110 49 31 48 29 6 3 85 4 3 19 22 84 104 97 119 116 101 32 84 105 109 101 115 116 97 109 112 105 110 103 32 67 65 48 30 23 13 49 50 49 50 50 49 48 48 48 48 48 48 90 23 13 50 48 49 50 51 48 50 51 53 57 53 57 90 48 94 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 48 48 46 6 3 85 4 3 19 39 83 121 109 97 110 116 101 99 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 67 65 32 45 32 71 50 48 130 1 34 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 130 1 15 0 48 130 1 10 2 130 1 1 0 177 172 179 73 84 75 151 28 18 10 216 37 121 145 34 87 42 111 220 184 38 196 67 115 107 194 191 46 80 90 251 20 194 118 142 67 1 37 67 180 161 226 69 244 232 183 123 195 116 204 34 215 180 148 0 2 247 77 237 191 180 183 68 36 107 205 95 69 59 209 68 206 67 18 115 23 130 139 105 180 43 203 153 30 172 114 27 38 77 113 31 177 49 221 251 81 97 2 83 166 170 245 73 44 5 120 69 165 47 137 206 231 153 231 254 140 226 87 63 61 198 146 220 74 248 123 51 228 121 10 251 240 117 136 65 156 255 197 3 81 153 170 215 108 159 147 105 135 101 41 131 133 194 96 20 196 200 201 59 20 218 192 129 240 31 13 116 222 146 34 171 202 247 251 116 124 39 230 247 74 27 127 167 195 158 45 174 138 234 166 230 170 39 22 125 97 247 152 113 17 188 226 80 161 75 229 93 250 229 14 167 44 159 170 101 32 211 216 150 232 200 124 165 78 72 68 255 25 226 68 7 146 11 215 104 132 128 93 106 120 100 69 205 96 70 126 84 193 19 124 197 121 241 201 193 113 2 3 1 0 1 163 129 250 48 129 247 48 29 6 3 85 29 14 4 22 4 20 95 154 245 110 92 204 204 116 154 212 221 125 239 63 219 236 76 128 46 221 48 50 6 8 43 6 1 5 5 7 1 1 4 38 48 36 48 34 6 8 43 6 1 5 5 7 48 1 134 22 104 116 116 112 58 47 47 111 99 115 112 46 116 104 97 119 116 101 46 99 111 109 48 18 6 3 85 29 19 1 1 255 4 8 48 6 1 1 255 2 1 0 48 63 6 3 85 29 31 4 56 48 54 48 52 160 50 160 48 134 46 104 116 116 112 58 47 47 99 114 108 46 116 104 97 119 116 101 46 99 111 109 47 84 104 97 119 116 101 84 105 109 101 115 116 97 109 112 105 110 103 67 65 46 99 114 108 48 19 6 3 85 29 37 4 12 48 10 6 8 43 6 1 5 5 7 3 8 48 14 6 3 85 29 15 1 1 255 4 4 3 2 1 6 48 40 6 3 85 29 17 4 33 48 31 164 29 48 27 49 25 48 23 6 3 85 4 3 19 16 84 105 109 101 83 116 97 109 112 45 50 48 52 56 45 49 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 129 129 0 3 9 155 143 121 239 127 89 48 170 239 104 181 250 227 9 29 187 79 130 6 93 55 95 166 82 159 22 141 234 28 146 9 68 110 245 109 235 88 124 48 232 249 105 141 35 115 11 18 111 71 169 174 57 17 248 42 177 155 176 26 195 142 235 89 150 0 173 206 12 77 178 208 49 166 8 92 42 122 252 226 122 29 87 76 168 101 24 233 121 64 98 37 150 110 199 199 55 106 131 33 8 142 65 234 221 217 87 63 29 119 73 135 42 22 6 94 166 56 106 34 18 163 81 25 131 126 182 48 130 4 163 48 130 3 139 160 3 2 1 2 2 16 14 207 244 56 200 254 191 53 110 4 216 106 152 27 26 80 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 94 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 48 48 46 6 3 85 4 3 19 39 83 121 109 97 110 116 101 99 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 67 65 32 45 32 71 50 48 30 23 13 49 50 49 48 49 56 48 48 48 48 48 48 90 23 13 50 48 49 50 50 57 50 51 53 57 53 57 90 48 98 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 52 48 50 6 3 85 4 3 19 43 83 121 109 97 110 116 101 99 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 83 105 103 110 101 114 32 45 32 71 52 48 130 1 34 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 130 1 15 0 48 130 1 10 2 130 1 1 0 162 99 11 57 68 184 187 35 167 68 73 187 14 255 161 240 97 10 83 147 176 152 219 173 44 15 74 197 110 255 134 60 83 85 15 21 206 4 63 43 253 169 150 150 217 190 97 121 11 91 201 76 134 118 229 224 67 75 34 149 238 194 43 67 193 159 216 104 180 142 64 79 238 133 56 185 17 197 35 242 100 88 240 21 50 111 78 87 161 174 136 164 2 215 42 30 205 75 225 221 99 213 23 137 50 91 176 94 153 90 168 157 40 80 14 23 238 150 219 97 59 69 81 29 207 18 86 11 146 71 252 171 174 246 102 61 71 172 112 114 231 146 231 95 205 16 185 196 131 100 148 25 189 37 128 225 232 210 34 165 208 186 2 122 161 119 147 91 101 195 238 23 116 188 65 134 42 220 8 76 140 146 140 145 45 158 119 68 31 104 214 168 116 119 219 14 91 50 139 86 139 51 189 217 99 200 73 157 58 197 197 234 51 11 210 241 163 27 244 139 190 217 179 87 139 59 222 4 167 122 34 178 36 174 46 199 112 197 190 78 131 38 8 251 11 189 169 79 153 8 225 16 40 114 170 205 2 3 1 0 1 163 130 1 87 48 130 1 83 48 12 6 3 85 29 19 1 1 255 4 2 48 0 48 22 6 3 85 29 37 1 1 255 4 12 48 10 6 8 43 6 1 5 5 7 3 8 48 14 6 3 85 29 15 1 1 255 4 4 3 2 7 128 48 115 6 8 43 6 1 5 5 7 1 1 4 103 48 101 48 42 6 8 43 6 1 5 5 7 48 1 134 30 104 116 116 112 58 47 47 116 115 45 111 99 115 112 46 119 115 46 115 121 109 97 110 116 101 99 46 99 111 109 48 55 6 8 43 6 1 5 5 7 48 2 134 43 104 116 116 112 58 47 47 116 115 45 97 105 97 46 119 115 46 115 121 109 97 110 116 101 99 46 99 111 109 47 116 115 115 45 99 97 45 103 50 46 99 101 114 48 60 6 3 85 29 31 4 53 48 51 48 49 160 47 160 45 134 43 104 116 116 112 58 47 47 116 115 45 99 114 108 46 119 115 46 115 121 109 97 110 116 101 99 46 99 111 109 47 116 115 115 45 99 97 45 103 50 46 99 114 108 48 40 6 3 85 29 17 4 33 48 31 164 29 48 27 49 25 48 23 6 3 85 4 3 19 16 84 105 109 101 83 116 97 109 112 45 50 48 52 56 45 50 48 29 6 3 85 29 14 4 22 4 20 70 198 105 163 14 74 20 30 213 76 218 82 99 23 63 94 54 188 13 230 48 31 6 3 85 29 35 4 24 48 22 128 20 95 154 245 110 92 204 204 116 154 212 221 125 239 63 219 236 76 128 46 221 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 130 1 1 0 120 59 180 145 42 0 76 240 143 98 48 55 120 163 132 39 7 111 24 178 222 37 220 160 212 148 3 170 134 78 37 159 154 64 3 28 221 206 227 121 203 33 104 6 218 182 50 180 109 191 244 44 38 99 51 228 73 100 109 13 230 195 103 14 247 5 164 53 108 124 137 22 198 233 178 223 178 233 221 32 198 113 15 205 149 116 220 182 92 222 189 55 31 67 120 230 120 181 205 40 4 32 163 170 241 75 196 136 41 145 14 128 209 17 252 221 92 118 110 79 94 14 69 70 65 110 13 176 234 56 154 177 58 218 9 113 16 252 28 121 180 128 123 172 105 244 253 156 182 12 22 43 241 127 91 9 61 155 91 226 22 202 19 129 109 0 46 56 13 168 41 143 44 225 178 244 90 169 1 175 21 156 44 47 73 27 219 34 187 195 254 120 148 81 195 134 177 130 136 93 240 61 180 81 161 121 51 43 46 123 185 220 32 9 19 113 235 106 25 91 207 232 165 48 87 44 137 73 63 185 207 127 201 191 62 34 104 99 83 154 189 105 116 172 197 29 60 127 146 224 195 188 28 216 4 117 48 130 5 106 48 130 4 82 160 3 2 1 2 2 16 108 89 239 169 225 0 225 14 227 6 186 143 224 41 37 89 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 129 202 49 11 48 9 6 3 85 4 6 19 2 85 83 49 23 48 21 6 3 85 4 10 19 14 86 101 114 105 83 105 103 110 44 32 73 110 99 46 49 31 48 29 6 3 85 4 11 19 22 86 101 114 105 83 105 103 110 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 58 48 56 6 3 85 4 11 19 49 40 99 41 32 50 48 48 54 32 86 101 114 105 83 105 103 110 44 32 73 110 99 46 32 45 32 70 111 114 32 97 117 116 104 111 114 105 122 101 100 32 117 115 101 32 111 110 108 121 49 69 48 67 6 3 85 4 3 19 60 86 101 114 105 83 105 103 110 32 67 108 97 115 115 32 51 32 80 117 98 108 105 99 32 80 114 105 109 97 114 121 32 67 101 114 116 105 102 105 99 97 116 105 111 110 32 65 117 116 104 111 114 105 116 121 32 45 32 71 53 48 30 23 13 49 50 48 54 48 55 48 48 48 48 48 48 90 23 13 50 50 48 54 48 54 50 51 53 57 53 57 90 48 129 140 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 31 48 29 6 3 85 4 11 19 22 83 121 109 97 110 116 101 99 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 61 48 59 6 3 85 4 3 19 52 83 121 109 97 110 116 101 99 32 67 108 97 115 115 32 51 32 69 120 116 101 110 100 101 100 32 86 97 108 105 100 97 116 105 111 110 32 67 111 100 101 32 83 105 103 110 105 110 103 32 67 65 48 130 1 34 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 130 1 15 0 48 130 1 10 2 130 1 1 0 139 67 175 161 196 168 77 205 208 238 199 54 192 160 138 121 115 40 216 119 229 192 84 199 53 247 187 237 27 159 234 87 112 211 85 27 39 25 169 203 224 1 5 174 5 242 173 231 6 29 209 6 168 173 135 185 24 132 47 30 29 9 98 211 221 13 245 23 180 48 111 94 82 118 22 140 86 123 197 144 58 130 125 181 173 88 230 0 231 24 5 54 237 48 32 161 240 236 195 98 244 153 16 26 148 246 240 87 104 201 114 54 189 124 144 168 22 22 32 165 73 1 81 50 160 150 243 138 48 56 171 134 161 21 163 242 28 32 87 80 75 184 100 210 177 108 230 228 60 182 8 33 196 75 64 150 23 179 203 103 219 134 65 217 91 254 152 29 68 36 58 232 105 161 26 36 107 179 72 20 243 244 14 131 197 77 49 251 189 175 174 33 60 98 235 234 218 216 157 215 236 145 30 179 195 68 30 84 29 130 155 237 89 19 238 48 112 227 108 148 225 44 7 211 143 140 234 97 201 92 171 75 152 42 135 185 218 62 55 131 10 48 186 181 68 152 253 239 189 170 128 53 177 92 173 247 2 3 1 0 1 163 130 1 134 48 130 1 130 48 52 6 8 43 6 1 5 5 7 1 1 4 40 48 38 48 36 6 8 43 6 1 5 5 7 48 1 134 24 104 116 116 112 58 47 47 111 99 115 112 46 118 101 114 105 115 105 103 110 46 99 111 109 48 18 6 3 85 29 19 1 1 255 4 8 48 6 1 1 255 2 1 0 48 101 6 3 85 29 32 4 94 48 92 48 90 6 4 85 29 32 0 48 82 48 38 6 8 43 6 1 5 5 7 2 1 22 26 104 116 116 112 58 47 47 119 119 119 46 115 121 109 97 117 116 104 46 99 111 109 47 99 112 115 48 40 6 8 43 6 1 5 5 7 2 2 48 28 26 26 104 116 116 112 58 47 47 119 119 119 46 115 121 109 97 117 116 104 46 99 111 109 47 114 112 97 48 52 6 3 85 29 31 4 45 48 43 48 41 160 39 160 37 134 35 104 116 116 112 58 47 47 99 114 108 46 118 101 114 105 115 105 103 110 46 99 111 109 47 112 99 97 51 45 103 53 46 99 114 108 48 29 6 3 85 29 37 4 22 48 20 6 8 43 6 1 5 5 7 3 2 6 8 43 6 1 5 5 7 3 3 48 14 6 3 85 29 15 1 1 255 4 4 3 2 1 6 48 42 6 3 85 29 17 4 35 48 33 164 31 48 29 49 27 48 25 6 3 85 4 3 19 18 86 101 114 105 83 105 103 110 77 80 75 73 45 50 45 50 49 52 48 29 6 3 85 29 14 4 22 4 20 163 142 207 25 66 61 49 225 171 33 137 132 109 203 217 121 162 178 178 90 48 31 6 3 85 29 35 4 24 48 22 128 20 127 211 101 167 194 221 236 187 240 48 9 243 67 57 250 2 175 51 49 51 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 130 1 1 0 106 243 29 188 95 77 222 3 249 73 73 29 173 61 118 28 150 186 27 67 230 244 134 2 66 117 120 199 12 194 229 157 196 52 79 14 169 233 74 180 190 65 132 135 234 244 135 180 76 219 16 73 59 247 223 21 144 186 132 248 183 71 235 91 101 80 243 163 74 113 16 22 123 28 225 245 214 237 191 80 86 111 248 153 179 169 81 182 70 174 198 151 224 231 155 12 21 62 187 40 123 49 163 0 243 46 139 135 72 18 137 130 239 9 95 73 12 144 158 200 246 150 163 123 154 117 19 200 71 240 62 63 111 11 80 41 108 43 120 76 48 252 228 96 12 19 64 214 56 117 169 7 121 100 253 202 60 228 239 72 147 11 224 10 72 255 7 107 59 2 131 209 102 213 185 225 152 244 14 159 105 196 46 85 46 1 150 125 126 132 12 128 118 117 54 203 253 70 97 244 105 204 26 157 100 43 186 4 110 233 17 82 218 18 153 161 90 176 131 196 188 71 128 166 39 77 0 122 54 3 60 190 97 152 99 203 159 5 238 128 133 238 221 149 146 247 238 80 212 99 220 143 164 36 121 191 48 130 5 137 48 130 4 113 160 3 2 1 2 2 16 2 142 167 160 17 88 230 113 250 131 157 77 24 211 39 195 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 129 140 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 31 48 29 6 3 85 4 11 19 22 83 121 109 97 110 116 101 99 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 61 48 59 6 3 85 4 3 19 52 83 121 109 97 110 116 101 99 32 67 108 97 115 115 32 51 32 69 120 116 101 110 100 101 100 32 86 97 108 105 100 97 116 105 111 110 32 67 111 100 101 32 83 105 103 110 105 110 103 32 67 65 48 30 23 13 49 51 48 55 51 48 48 48 48 48 48 48 90 23 13 49 53 48 55 50 53 50 51 53 57 53 57 90 48 129 244 49 19 48 17 6 11 43 6 1 4 1 130 55 60 2 1 3 19 2 85 83 49 25 48 23 6 11 43 6 1 4 1 130 55 60 2 1 2 20 8 68 101 108 97 119 97 114 101 49 29 48 27 6 3 85 4 15 19 20 80 114 105 118 97 116 101 32 79 114 103 97 110 105 122 97 116 105 111 110 49 16 48 14 6 3 85 4 5 19 7 50 55 52 56 49 50 57 49 11 48 9 6 3 85 4 6 19 2 85 83 49 19 48 17 6 3 85 4 8 12 10 67 97 108 105 102 111 114 110 105 97 49 17 48 15 6 3 85 4 7 12 8 83 97 110 32 74 111 115 101 49 35 48 33 6 3 85 4 10 12 26 65 100 111 98 101 32 83 121 115 116 101 109 115 32 73 110 99 111 114 112 111 114 97 116 101 100 49 18 48 16 6 3 85 4 11 12 9 84 121 112 101 32 70 111 110 116 49 35 48 33 6 3 85 4 3 20 26 65 100 111 98 101 32 83 121 115 116 101 109 115 32 73 110 99 111 114 112 111 114 97 116 101 100 48 130 1 34 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 130 1 15 0 48 130 1 10 2 130 1 1 0 223 54 155 241 225 31 63 249 26 70 250 224 219 170 247 44 11 202 111 89 161 66 239 227 126 109 201 152 186 203 20 135 246 84 157 90 241 229 172 179 45 149 245 76 9 153 24 11 87 224 49 70 227 82 19 152 25 80 59 31 6 227 171 98 140 200 177 217 205 77 186 36 172 10 29 239 207 81 185 183 255 86 30 167 18 223 39 117 75 82 222 232 24 72 121 124 81 15 47 5 40 210 22 101 77 50 243 218 18 53 18 103 38 185 96 111 245 99 101 139 60 55 98 241 187 245 71 204 57 34 64 167 212 10 222 86 176 249 14 138 22 132 90 41 214 99 7 111 78 136 85 246 65 171 118 27 203 136 37 244 204 155 181 237 77 107 229 212 148 189 216 203 238 188 140 226 41 90 233 2 232 215 222 9 43 128 105 66 137 192 251 147 148 59 144 94 68 148 85 45 94 130 212 22 243 144 181 198 161 131 158 250 138 19 57 7 40 6 98 78 153 182 155 57 57 21 37 148 255 164 244 63 119 197 141 230 239 182 133 153 248 52 215 89 75 156 86 11 106 125 132 191 107 150 7 229 2 3 1 0 1 163 130 1 123 48 130 1 119 48 46 6 3 85 29 17 4 39 48 37 160 35 6 8 43 6 1 5 5 7 8 3 160 23 48 21 12 19 85 83 45 68 101 108 97 119 97 114 101 45 50 55 52 56 49 50 57 48 9 6 3 85 29 19 4 2 48 0 48 66 6 3 85 29 32 4 59 48 57 48 55 6 11 96 134 72 1 134 248 69 1 7 23 6 48 40 48 38 6 8 43 6 1 5 5 7 2 1 22 26 104 116 116 112 58 47 47 119 119 119 46 115 121 109 97 117 116 104 46 99 111 109 47 99 112 115 48 57 6 3 85 29 31 4 50 48 48 48 46 160 44 160 42 134 40 104 116 116 112 58 47 47 101 118 99 115 45 99 114 108 46 119 115 46 115 121 109 97 110 116 101 99 46 99 111 109 47 101 118 99 115 46 99 114 108 48 22 6 3 85 29 37 1 1 255 4 12 48 10 6 8 43 6 1 5 5 7 3 3 48 14 6 3 85 29 15 1 1 255 4 4 3 2 7 128 48 114 6 8 43 6 1 5 5 7 1 1 4 102 48 100 48 44 6 8 43 6 1 5 5 7 48 1 134 32 104 116 116 112 58 47 47 101 118 99 115 45 111 99 115 112 46 119 115 46 115 121 109 97 110 116 101 99 46 99 111 109 48 52 6 8 43 6 1 5 5 7 48 2 134 40 104 116 116 112 58 47 47 101 118 99 115 45 97 105 97 46 119 115 46 115 121 109 97 110 116 101 99 46 99 111 109 47 101 118 99 115 46 99 101 114 48 31 6 3 85 29 35 4 24 48 22 128 20 163 142 207 25 66 61 49 225 171 33 137 132 109 203 217 121 162 178 178 90 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 130 1 1 0 119 42 188 45 111 254 135 24 174 251 54 127 68 190 100 72 197 193 109 132 176 75 98 131 18 84 215 59 202 42 90 95 37 197 24 185 221 60 88 250 214 86 216 145 212 98 224 244 220 119 137 168 197 229 108 128 53 93 28 224 116 13 100 129 67 82 86 47 21 87 86 224 2 59 152 68 120 168 40 105 202 225 212 72 215 241 171 112 166 9 100 54 209 69 3 222 100 244 242 53 47 159 152 245 114 158 172 114 132 150 213 6 216 122 131 246 204 99 207 28 239 100 143 140 2 225 138 53 122 9 154 214 207 192 81 1 70 78 150 42 40 190 133 65 245 222 240 223 121 156 83 121 95 6 223 146 178 81 247 213 151 41 38 42 110 65 234 17 129 136 136 64 71 174 44 137 124 99 92 203 73 190 234 67 81 213 131 133 244 104 179 239 65 148 145 223 32 177 189 102 116 247 176 28 7 221 21 61 180 225 202 169 97 179 116 82 78 39 243 15 182 121 78 7 87 226 23 34 189 29 251 224 30 125 252 212 150 156 136 101 251 193 70 218 93 198 147 226 36 227 162 7 193 88 49 117 49 130 4 159 48 130 4 155 2 1 1 48 129 161 48 129 140 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 31 48 29 6 3 85 4 11 19 22 83 121 109 97 110 116 101 99 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 61 48 59 6 3 85 4 3 19 52 83 121 109 97 110 116 101 99 32 67 108 97 115 115 32 51 32 69 120 116 101 110 100 101 100 32 86 97 108 105 100 97 116 105 111 110 32 67 111 100 101 32 83 105 103 110 105 110 103 32 67 65 2 16 2 142 167 160 17 88 230 113 250 131 157 77 24 211 39 195 48 9 6 5 43 14 3 2 26 5 0 160 129 196 48 25 6 9 42 134 72 134 247 13 1 9 3 49 12 6 10 43 6 1 4 1 130 55 2 1 4 48 28 6 10 43 6 1 4 1 130 55 2 1 11 49 14 48 12 6 10 43 6 1 4 1 130 55 2 1 21 48 35 6 9 42 134 72 134 247 13 1 9 4 49 22 4 20 43 255 231 99 138 34 163 71 144 59 26 229 27 85 125 138 127 191 12 98 48 100 6 10 43 6 1 4 1 130 55 2 1 12 49 86 48 84 160 82 128 80 0 83 0 111 0 117 0 114 0 99 0 101 0 32 0 67 0 111 0 100 0 101 0 32 0 80 0 114 0 111 0 32 0 102 0 111 0 110 0 116 0 32 0 102 0 97 0 109 0 105 0 108 0 121 0 32 0 119 0 105 0 116 0 104 0 32 0 73 0 116 0 97 0 108 0 105 0 99 0 115 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 4 130 1 0 165 97 6 101 16 44 225 36 59 148 192 73 146 227 89 152 41 147 242 3 238 100 249 57 159 215 115 94 105 12 255 107 201 16 2 231 237 219 99 124 255 40 176 234 24 109 116 202 50 53 233 170 44 161 169 7 71 0 207 41 81 229 101 128 131 206 175 65 183 135 7 39 42 133 50 147 16 229 109 98 30 136 220 171 43 113 13 222 99 232 160 133 122 253 99 227 253 174 171 10 73 242 173 69 40 61 43 224 128 89 64 90 122 151 129 108 222 86 139 58 233 3 1 248 111 81 3 19 5 150 111 117 110 242 185 122 168 91 111 190 56 214 76 41 166 234 39 201 57 139 19 55 205 201 152 177 101 212 243 48 160 129 161 130 222 113 49 5 38 170 153 225 129 117 52 146 142 56 4 174 87 174 116 128 51 243 160 114 41 89 124 185 227 179 208 73 231 50 109 218 255 1 103 87 78 71 208 235 207 174 218 152 164 224 114 218 142 23 164 16 101 89 41 43 228 103 147 224 131 190 48 2 167 65 186 124 207 132 33 214 45 8 32 41 191 58 198 114 121 148 75 110 155 34 25 149 161 130 2 11 48 130 2 7 6 9 42 134 72 134 247 13 1 9 6 49 130 1 248 48 130 1 244 2 1 1 48 114 48 94 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 48 48 46 6 3 85 4 3 19 39 83 121 109 97 110 116 101 99 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 67 65 32 45 32 71 50 2 16 14 207 244 56 200 254 191 53 110 4 216 106 152 27 26 80 48 9 6 5 43 14 3 2 26 5 0 160 93 48 24 6 9 42 134 72 134 247 13 1 9 3 49 11 6 9 42 134 72 134 247 13 1 7 1 48 28 6 9 42 134 72 134 247 13 1 9 5 49 15 23 13 49 53 48 55 49 51 50 50 50 51 50 55 90 48 35 6 9 42 134 72 134 247 13 1 9 4 49 22 4 20 218 172 236 64 213 181 176 13 106 177 249 56 116 112 238 146 42 240 49 253 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 4 130 1 0 9 61 35 76 180 120 80 216 77 206 156 209 201 169 19 236 102 35 162 121 160 177 38 25 84 253 18 201 55 27 227 216 137 210 131 80 226 160 191 19 226 20 38 117 79 8 229 80 250 52 250 64 243 69 240 10 37 132 228 250 97 132 52 132 178 83 11 180 213 40 66 169 238 20 97 171 178 118 86 173 109 42 52 32 105 89 132 25 126 121 157 252 110 85 176 249 198 181 62 188 140 210 118 153 34 250 247 163 177 224 161 95 230 252 191 64 205 214 178 39 70 63 107 161 12 165 41 184 105 29 171 10 110 87 89 6 215 60 162 3 214 132 47 84 163 80 11 133 243 244 87 158 212 248 180 102 108 155 206 35 2 85 132 203 60 9 81 166 136 228 120 253 205 231 36 182 67 151 191 51 20 185 133 87 41 123 100 85 176 60 94 94 235 213 111 97 205 80 246 96 43 122 75 179 237 244 227 137 71 71 51 139 213 13 186 187 5 119 76 91 158 199 18 222 10 158 237 145 76 65 189 8 141 35 72 230 0 240 17 166 214 151 144 106 13 64 33 212 225 101 4 115 138 203 81 49 0 0 0]! !

!SourceCodeProRegular class methodsFor: 'class initialization' stamp: ''!
initialize 
	EmbeddedFreeTypeFontInstaller registerFont: self! !

!SourceCodeProRegular class methodsFor: 'accessing' stamp: ''!
originalFileName
	^ 'SourceCodePro-Regular.ttf'! !

!SourceFile commentStamp: ''!
asdasd!
!SourceFile methodsFor: 'stop conditions' stamp: ''!
cr

	stream cr! !

!SourceFile methodsFor: 'accessing' stamp: ''!
position

	^ stream position! !

!SourceFile methodsFor: 'accessing' stamp: ''!
getPreambleAt: startingPosition
	"Search backwards from byte startingPosition in my stream for a method preamble and return it.
	A method preamble looks like: MyClass methodsFor: 'test' stamp: 'author 1/27/2019 12:27'
	but with exclamation marks ($!!) around it (the contents excluding the $!!'s is returned).
	startingPosition should be set one position before the closing $!!"
	
	| characterReadStream binaryStream encoder position |
	"I hold either a ZnCharacterReadStream or a ZnCharacterReadWriteStream (see #tryOpenReadOnly:)
	Use #isReadOnly and #readOnlyCopy to access the ZnCharacterReadStream in both cases"
	characterReadStream := self isReadOnly ifTrue: [ stream ] ifFalse: [ stream readOnlyCopy ].
	"Access the binary read stream wrapped by the character read stream"
	binaryStream := characterReadStream wrappedStream.
	"Access the encoder held by the character read stream"
	encoder := characterReadStream encoder.
	"Search backwards for the previous occurrence of $!!
	Although the underlying encoding is UTF-8 we can still operate/move at the byte level
	since $!! code 33 cannot occur in code points encoded using 2, 3 or 4 bytes"
	position := startingPosition.
	[ position >= 0 
		and: [ 
			binaryStream position: position. 
			binaryStream next ~= 33 "$!!" ] ] 
		whileTrue: [ position := position - 1 ].
	"Now that we found the byte range, extract and decode it"
	^ encoder decodeBytes: (binaryStream next: startingPosition - position)! !

!SourceFile methodsFor: 'opening' stamp: ''!
tryOpen

	self tryOpenReadOnly: false! !

!SourceFile methodsFor: 'accessing' stamp: ''!
peek
	
	^ stream peek! !

!SourceFile methodsFor: 'accessing' stamp: ''!
next: anInteger

	^ stream next: anInteger! !

!SourceFile methodsFor: 'accessing' stamp: ''!
position: anInteger

	stream position: anInteger! !

!SourceFile methodsFor: 'file in/out' stamp: ''!
nextChunk

	^ (ChunkReadStream on: stream) next! !

!SourceFile methodsFor: 'accessing' stamp: ''!
upToEnd
	
	^ stream upToEnd! !

!SourceFile methodsFor: 'opening' stamp: ''!
tryOpenReadOnly: readOnly
	| basename |
	basename := path asFileReference basename.

	"Open a read write stream only if read only access was not requested.
	We need to create the encoding and buffering streams manually because we need a read write stream."
	readOnly ifFalse: [
		potentialLocations
			do: [ :each | 
				[ stream := SourceFileCharacterReadWriteStream
					on: (SourceFileBufferedReadWriteStream on:(each asFileReference / basename) unbufferedBinaryWriteStream)
					encoding: 'utf8'.
				^ self ] on: Error do: [  ] ] ].

	potentialLocations do: [ :each | 
			[ stream := ZnCharacterReadStream
					on: (each asFileReference / basename) binaryReadStream
					encoding: 'utf8'.
				^ self ] on: Error do: [  ] ]! !

!SourceFile methodsFor: 'accessing' stamp: ''!
path: aPath
	path := aPath! !

!SourceFile methodsFor: 'accessing' stamp: ''!
next: anInteger putAll: aString startingAt: startIndex

	stream next: anInteger putAll: aString startingAt: startIndex
! !

!SourceFile methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: self class name;
		nextPut: $(;
		nextPutAll: self fullName;
		nextPut: $)! !

!SourceFile methodsFor: 'accessing' stamp: ''!
potentialLocations

	^ potentialLocations! !

!SourceFile methodsFor: 'accessing' stamp: ''!
nextPut: aCharacter

	stream nextPut: aCharacter! !

!SourceFile methodsFor: 'initialization' stamp: ''!
close

	stream ifNil: [ ^ self ].
	stream closed ifTrue: [ 
		stream := nil.
		^ self ].
	stream close.
	stream := nil.! !

!SourceFile methodsFor: 'testing' stamp: ''!
isOpen

	^ stream notNil and: [ stream closed not ]! !

!SourceFile methodsFor: 'accessing' stamp: ''!
flush

	(stream isNil or: [ stream isReadOnly ])
		ifTrue: [ ^ self ].
	
	stream flush! !

!SourceFile methodsFor: 'testing' stamp: ''!
atEnd
	
	^ stream atEnd! !

!SourceFile methodsFor: 'accessing' stamp: ''!
fullName

	^ path asString! !

!SourceFile methodsFor: 'testing' stamp: ''!
isReadOnly

	^ stream isReadOnly! !

!SourceFile methodsFor: 'accessing' stamp: ''!
path
	^ path! !

!SourceFile methodsFor: 'buffering' stamp: ''!
discardBuffer

	stream wrappedStream discardBuffer! !

!SourceFile methodsFor: 'accessing' stamp: ''!
potentialLocations: aCollection

	potentialLocations := aCollection! !

!SourceFile methodsFor: 'accessing' stamp: ''!
next

	^ stream next! !

!SourceFile methodsFor: 'accessing' stamp: ''!
closed
	^ stream isNil or: [ stream closed ]! !

!SourceFile methodsFor: 'streaming' stamp: ''!
space

	stream space! !

!SourceFile methodsFor: 'accessing' stamp: ''!
size

	^ stream size! !

!SourceFile methodsFor: 'accessing' stamp: ''!
stream: aStream

	stream := aStream! !

!SourceFile methodsFor: 'accessing' stamp: ''!
skip: anInteger

	stream skip: anInteger! !

!SourceFile methodsFor: 'accessing' stamp: ''!
ensureWrittenPosition: aPosition

	self isReadOnly ifTrue: [ ^ false ].
	
	^ stream ensureWrittenPosition: aPosition! !

!SourceFile methodsFor: 'accessing' stamp: ''!
readOnlyCopy

	^ (self species on: path potentialLocations: potentialLocations)
		tryOpenReadOnly: true;
		yourself! !

!SourceFile methodsFor: 'accessing' stamp: ''!
nextPutAll: aString

	stream nextPutAll: aString! !

!SourceFile methodsFor: 'file in/out' stamp: ''!
nextChunkPut: aChunk

	^ (ChunkWriteStream on: stream) nextPut: aChunk! !

!SourceFile methodsFor: 'initialization' stamp: ''!
setToEnd

	stream setToEnd! !

!SourceFile class methodsFor: 'instance creation' stamp: ''!
on: aPath potentialLocations: locations

	^ self new
		path: aPath;
		potentialLocations: locations;
		yourself! !

!SourceFileArray commentStamp: ''!
This is a variation on StandardSourceFileArray that provides a larger maximum changes file size.

The available address space for source pointers in a traditional CompiledMethod is 16r1000000 through 16r4FFFFFF. StandardSourceFileArray maps positions in the sources file to address range 16r1000000 through 16r1FFFFFF and 16r3000000 through 16r3FFFFFF, and positions in the changes file to address range 16r2000000 through 16r2FFFFFF and 16r4000000 through 16r4FFFFFF. This permits a maximum file size of 16r2000000 (32MB) for both the sources file and the changes file.

This implementation extends the source pointer address space using bit 25 of the source pointer to identify the external sources and changes files, with the remaining high order bits treated as address extension. This limits the number of external file references to two (the traditional sources and changes files). If additional external file references are needed in the future, some higher order bits in the source pointer address space should be allocated for that purpose.

The use of bit 25 of the source pointer for file references permits backward compatibility with StandardSourceFileArray, with essentially unlimited address space expansion for the sources and changes files.
!
!SourceFileArray methodsFor: 'private' stamp: ''!
createReadOnlyFiles
	| readOnly |
	readOnly := {
		self sourcesFileStream ifNotNil: [self sourcesFileStream readOnlyCopy].
		self sourcesFileStream ifNotNil: [self changesFileStream readOnlyCopy] }.
	^ (readOnly anySatisfy: [ :any | any isNil or: [any closed] ])
			ifTrue: [ self closeFileArray: readOnly ]
			ifFalse: [ readOnly ]! !

!SourceFileArray methodsFor: '*System-Changes' stamp: 'nil'!
changeRecordsFor: aMethodDefinition do: aUnaryBlock
	"Evaluate aUnaryBlock with each of the ChangeRecords of aMethodDefinition. Most recent changes are evaluated first."

	^ self 
		changeRecordsFrom: aMethodDefinition sourcePointer
		className: aMethodDefinition instanceSideParentName
		isMeta: aMethodDefinition isMetaSide
		do: aUnaryBlock! !

!SourceFileArray methodsFor: 'public - file system operations' stamp: ''!
emptyReadStreamsQueue
		
	| oldQueue | 
	oldQueue := readOnlyQueue.
	readOnlyQueue := SharedQueue new.
	oldQueue flushAllSuchThat: [ :each | self closeFileArray: each. true]! !

!SourceFileArray methodsFor: 'public - string writing' stamp: ''!
changesWriteStreamDo: aBlock

	| changesFile |
	changesFile := self changesFileStream.
	changesFile ifNil: [ ^ self ].
	changesFile closed ifTrue: [ ^ self ].
	changesFile isReadOnly ifTrue: [ ^ self ].
	changesFile setToEnd.
	
	^ aBlock value: changesFile! !

!SourceFileArray methodsFor: 'private - accessing file streams' stamp: ''!
readStreamAt: sourcePointer ifPresent: presentBlock ifAbsent: absentBlock

	| index position |
	sourcePointer ifNil: [ ^ absentBlock value ].
	
	index := self fileIndexFromSourcePointer: sourcePointer.
	index = 0 ifTrue: [ ^ absentBlock value ].	"no source pointer for this element"

	position := self filePositionFromSourcePointer: sourcePointer.
	position = 0 ifTrue: [ ^ absentBlock value ].

	^ self 
		readStreamAtFileIndex: index 
		atPosition: position 
		ifPresent: presentBlock 
		ifAbsent: absentBlock! !

!SourceFileArray methodsFor: 'public - string reading' stamp: ''!
sourceCodeAt: sourcePointer 
	"Retrieves the source code for the pointer received as argument"
	
	^ self
		readStreamAt: sourcePointer 
		ifPresent: [ :stream | (ChunkReadStream on: stream) next ]
		ifAbsent: [ '' ]! !

!SourceFileArray methodsFor: 'public - string reading' stamp: ''!
sourcedDataAt: sourcePointer

	^ self 
		readStreamAt: sourcePointer 
		ifPresent: [ :file | 
			| position |
			position := self filePositionFromSourcePointer: sourcePointer.
			self getPreambleFrom: file at: (0 max: position - 3) ]
		ifAbsent: [ '' ]! !

!SourceFileArray methodsFor: '*System-Changes' stamp: 'nil'!
changeRecordsFrom: initialSourcePointer className: theNonMetaClassName isMeta: classIsMeta do: aUnaryBlock
	"Evaluate aUnaryBlock with each of the ChangeRecords of a method or class comment, starting from the initialSourcePointer. 
	Most recent changes are evaluated first."

	| filePosition fileIndex |
	fileIndex := self fileIndexFromSourcePointer: initialSourcePointer.
	filePosition := self filePositionFromSourcePointer: initialSourcePointer.	

	self readOnlyDo: [ :sourceFilesCopy | 
		| file previousFilePosition previousFileIndex preamble stamp protocol preambleTokens |
		file := sourceFilesCopy fileAt: fileIndex ifAbsent: [ ^ self ].
		
		[ filePosition notNil & file notNil ]
			whileTrue: [ 
				file position: (0 max: filePosition - 150).	"Skip back to before the preamble"
				[ file position < (filePosition - 1) ] whileTrue: [ 
					preamble := (ChunkReadStream on: file) next ].	"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"

				previousFilePosition := nil.
				stamp := ''.
				"method records"
				(preamble includesSubstring: 'methodsFor:')
					ifTrue: [ preambleTokens := preamble parseLiterals ]
					ifFalse: [ preambleTokens := Array new	"ie cant be back ref" ].
				((preambleTokens size between: 7 and: 8) and: [ (preambleTokens at: preambleTokens size - 5) = #methodsFor: ])
					ifTrue: [ 
						(preambleTokens at: preambleTokens size - 3) = #stamp:
							ifTrue: [ 
								"New format gives change stamp and unified prior pointer"
								stamp := preambleTokens at: preambleTokens size - 2.
								previousFilePosition := preambleTokens last.
								previousFileIndex := self fileIndexFromSourcePointer: previousFilePosition.
								previousFilePosition := self filePositionFromSourcePointer: previousFilePosition ]
							ifFalse: [ 
								"Old format gives no stamp; prior pointer in two parts"
								previousFilePosition := preambleTokens at: preambleTokens size - 2.
								previousFileIndex := preambleTokens last ].
						(previousFilePosition = 0 or: [ previousFileIndex = 0 ])
							ifTrue: [ previousFilePosition := nil ] ].

				((preambleTokens size between: 5 and: 6) and: [ (preambleTokens at: preambleTokens size - 3) = #methodsFor: ])
					ifTrue: [ 
						(preambleTokens at: preambleTokens size - 1) = #stamp:
							ifTrue: [ 
								"New format gives change stamp and unified prior pointer"
								stamp := preambleTokens at: preambleTokens size ] ].
				"class comment records"
				(preamble includesSubstring: 'commentStamp:')
					ifTrue: [ preambleTokens := preamble parseLiterals ].
				((preambleTokens size = 5 or: [ preambleTokens size = 3 ]) and: [ (preambleTokens at: 2) = #commentStamp: ])
					ifTrue: [ 
						stamp := preambleTokens at: 3.
						preambleTokens size > 3
							ifTrue: [ 
								previousFilePosition := preambleTokens last.
								previousFileIndex := self fileIndexFromSourcePointer: previousFilePosition.
								previousFilePosition := self filePositionFromSourcePointer: previousFilePosition ].
						aUnaryBlock
							value:
								(ChangeRecord new
									file: file
									position: filePosition
									type: #classComment
									class: theNonMetaClassName
									category: nil
									meta: classIsMeta
									stamp: stamp) ]
					ifFalse: [ 
						protocol := preambleTokens after: #methodsFor: ifAbsent: [ Protocol unclassified ].
						aUnaryBlock
							value:
								(ChangeRecord new
									file: file
									position: filePosition
									type: #method
									class: theNonMetaClassName
									category: protocol
									meta: classIsMeta
									stamp: stamp) ].
									
				filePosition := previousFilePosition.
				previousFilePosition ifNotNil: [ 
					file := sourceFilesCopy 
						fileAt: previousFileIndex
						ifAbsent: [ ^ self ] ] ] ]! !

!SourceFileArray methodsFor: '*System-Changes' stamp: 'nil'!
changeRecordsFor: aMethodDefinition

	^ self 
		changeRecordsFrom: aMethodDefinition sourcePointer 
		className: aMethodDefinition methodClass instanceSide name
		isMeta: aMethodDefinition methodClass isMeta! !

!SourceFileArray methodsFor: 'private' stamp: ''!
closeFileArray: anArray

	anArray 
		reject: [ :file | file isNil ] 
		thenDo: [ :file | file close ].
		
	^ anArray! !

!SourceFileArray methodsFor: 'public - file system operations' stamp: ''!
flushChangesFile
	
	flushChanges ifFalse: [ ^ self ].
	self changesFileStream ifNotNil: [:stream | stream flush].! !

!SourceFileArray methodsFor: 'private - sourcepointer conversion' stamp: ''!
sourcePointerFromFileIndex: index andPosition: position
	"Return a sourcePointer encoding the given file index and position"

	| hi lo |
	(index = 1 or: [index = 2])
		ifFalse: [self error: 'invalid source file index'].
	position < 0 ifTrue: [self error: 'invalid source code pointer'].
	hi := position // 16r1000000 *2 + index.
	lo := position \\ 16r1000000.
	^ hi * 16r1000000 + lo
! !

!SourceFileArray methodsFor: 'accessing' stamp: ''!
changesFileStream
	"Answer the master .changes FileStream, with writing permissions."

	^ files at: 2! !

!SourceFileArray methodsFor: 'public - string reading' stamp: ''!
protocolAt: sourcePointer
	"Answer the protocol for a given method, retrieved from the sources or changes file. Answer unfound protocol if no protocol is available"
				
	^ self protocolAt: sourcePointer for: self sourceDataPointers! !

!SourceFileArray methodsFor: 'private' stamp: ''!
readOnlyQueueLimit

	"maximum number of read only file arrays to be held by the readOnlyQueue(SharedQueue)"

	^ 7! !

!SourceFileArray methodsFor: 'public - file system operations' stamp: ''!
close
		
	| oldFiles |
	oldFiles := files.
	files := Array new: 2.
	self closeFileArray: oldFiles.
	self emptyReadStreamsQueue! !

!SourceFileArray methodsFor: 'private - sourcepointer conversion' stamp: ''!
filePositionFromSourcePointer: anInteger
	"Return the position of the source chunk addressed by anInteger"

	| hi lo |
	hi := anInteger // 33554432.
	lo := anInteger \\ 16777216.
	^ ((anInteger bitAnd: 16777216) ~= 0 or: [ anInteger < 16777216	"compatibility with StandardSourceFileArray" ])
		ifTrue: [ hi * 16777216 + lo	"sources file" ]
		ifFalse: [ (hi - 1) * 16777216 + lo	"changes file" ]! !

!SourceFileArray methodsFor: 'accessing' stamp: ''!
sourcesFileStream: aStream

	^ files at: 1 put: aStream! !

!SourceFileArray methodsFor: 'private - sourcepointer conversion' stamp: ''!
fileIndexFromSourcePointer: anInteger
	"Return the index of the source file which contains the source chunk addressed by anInteger"

	^ (anInteger bitAnd: 16r1000000) ~= 0
		ifTrue: [ 1	"sources file" ]
		ifFalse: [ anInteger >= 16r1000000
				ifTrue: [ 2	"changes file" ]
				ifFalse: [ 0	"compatibility with StandardSourceFileArray" ] ]! !

!SourceFileArray methodsFor: 'public - string reading' stamp: ''!
timeStampAt: sourcePointer for: sourceDataPointers
	"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."

	| preamble stamp tokens stampPosition |
	stamp := ''.
	flushChanges ifFalse: [ ^ stamp ].
	preamble := self sourcedDataAt: sourcePointer.
	(preamble includesSubstring: sourceDataPointers key)
		ifTrue: [ 
			tokens := preamble parseLiterals.
			stampPosition := tokens indexOf: sourceDataPointers value.
			stampPosition = 0
				ifFalse: [ 
					"New format gives change stamp and unified prior pointer"
					stamp := tokens at: stampPosition + 1 ] ].
	^ stamp! !

!SourceFileArray methodsFor: 'public - string writing' stamp: ''!
deferFlushDuring: aBlock

	"defer flushing the filestream until a block has been executed"
	
	flushChanges ifFalse: [ ^ aBlock value ].
	
	flushChanges := false.
	
	^ [ aBlock value ] ensure: [
		flushChanges := true.
		self flushChangesFile ]! !

!SourceFileArray methodsFor: 'public - string reading' stamp: ''!
getPreambleFrom: aSourceFileStream at: position
	^ aSourceFileStream getPreambleAt: position ! !

!SourceFileArray methodsFor: 'initialization' stamp: ''!
initialize

	files := Array new: 2.
	
	readOnlyQueue := SharedQueue new.
	flushChanges := true! !

!SourceFileArray methodsFor: 'public - file system operations' stamp: ''!
ensureOpen
	"Ensure that the source and changes files are opened.
	Close them before re-opening them."
	
	| aSourcesFile aChangesFile |

	self close.

	aSourcesFile := PharoFilesOpener default sourcesFileOrNil.
	aChangesFile := PharoFilesOpener default changesFileOrNil.
	
	aChangesFile ifNil: [ 
		aChangesFile := PharoFilesOpener default changesFileOrNilReadOnly: true silent: false ].

	files := Array
		with: aSourcesFile
		with: aChangesFile.
			
	readOnlyQueue := SharedQueue new.! !

!SourceFileArray methodsFor: 'private - copying' stamp: ''!
readOnlyDo: aBlock
	"Value a block with a read only copy of self."

	| copy |
	copy := self readOnlyCopy.

	^ [ aBlock value: copy ] ensure: [ copy close ]! !

!SourceFileArray methodsFor: 'private' stamp: ''!
sourceDataPointers
	"Retrieves the combination key to look for information of the receiver in the source file"

	"'Point methodsFor: ''point functions'' stamp: ''lr 7/4/2009 10:42'''."

	^ 'methodsFor:' -> #stamp:! !

!SourceFileArray methodsFor: 'private - accessing file streams' stamp: ''!
readStreamAtFileIndex: index atPosition: position ifPresent: presentBlock ifAbsent: absentBlock
 
   | queue stream rofa result file |
   
	"This method is really ugly. 
	It uses different readers over the same file that is beeing writing. 
	This can lead to buffer problems. 
	This should be rethougth to a better way.
	
	Maybe an unification of all the accesses using the same buffer could be nice."
    
  	queue := readOnlyQueue.
  	rofa := queue nextOrNil ifNil: [ self createReadOnlyFiles ].
       
   rofa ifNil: [ ^ absentBlock value ].  

   stream := rofa at: index.
	stream ifNil: [ ^ absentBlock value ].
	
	file := files at: index.
	
   position > file size ifTrue: [ 
		self finishedReading: rofa from: queue. 
		^ absentBlock value 
	].

	"If the file has been flushed, I am discarding the readonly stream's buffer.
	This is to avoid a problem where the readOnly buffer is missing data that was in 
	the writer buffer."	
	file ensureWrittenPosition: position.

	"I am discarding the buffer of the readonly stream, because if not is out-of-sync."
	stream discardBuffer.
	
   stream position: position.
   result := presentBlock value: stream.
       
	self finishedReading: rofa from: queue. 
                      
    ^ result
! !

!SourceFileArray methodsFor: 'public - string reading' stamp: ''!
timeStampAt: sourcePointer
	"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."

	^ self timeStampAt: sourcePointer for: self sourceDataPointers! !

!SourceFileArray methodsFor: 'public - string writing' stamp: ''!
writeSource: aString preamble: preamble onSuccess: successBlock onFail: failBlock

	| file position |
	file := self changesFileStream.
	(file isNil or: [file closed or: [ file isReadOnly ] ]) ifTrue: [ ^ failBlock value ].

	ChangesLog default assureStartupStampLogged.
	
	file setToEnd.
	file nextPutAll: preamble.
	position := file position.
	(SourceChunkWriteStream on: file) nextChunkPut: aString.

	successBlock cull: (self sourcePointerFromFileIndex: 2 andPosition: position) cull: file.

	self flushChangesFile.
! !

!SourceFileArray methodsFor: 'private' stamp: ''!
commentDataPointers
	"Retrieves the combination key to look for comments in the source file"
	^'commentStamp:' -> #commentStamp:! !

!SourceFileArray methodsFor: '*System-Changes' stamp: 'nil'!
changeRecordsFrom: initialSourcePointer className: theNonMetaClassName isMeta: classIsMeta
	"Answer the ChangeRecords of a method or class comment, starting from the initialSourcePointer. 
	Most recent changes go first."
	
	| changeRecords |
	changeRecords := OrderedCollection new.

	self
		changeRecordsFrom: initialSourcePointer
		className: theNonMetaClassName
		isMeta: classIsMeta
		do: [ :changeRecord | changeRecords add: changeRecord ].
	
	^ changeRecords! !

!SourceFileArray methodsFor: 'public - string writing' stamp: ''!
remoteStringForNewString: aString

	^ RemoteString new
		sourceFileArray: self;
		string: aString;
		yourself! !

!SourceFileArray methodsFor: 'public - string reading' stamp: ''!
protocolAt: sourcePointer for: sourceDataPointers
	"Answer the protocol for a given method, retrieved from the sources or changes file. Answer unfound protocol if no protocol is available."

	| preamble protocol tokens protocolPosition |
	protocol := 'unfound protocol'.	"this is to indicate that the tagging in the source does not use the correct format.
	We will have to fix that. For example some traits methods are wrongly tagged.
	see http://code.google.com/p/pharo/issues/detail?id=4581"
	preamble := self sourcedDataAt: sourcePointer.
	preamble = 'Trait method' ifTrue: [ ^ nil ].
	(preamble includesSubstring: sourceDataPointers key) ifTrue: [ 
		tokens := preamble parseLiterals.
		protocolPosition := tokens indexOf: sourceDataPointers key.
		protocolPosition = 0
			ifFalse: [ 
				"New format gives change protocol and unified prior pointer"
				protocol := tokens at: protocolPosition + 1 ] ].
	^ protocol! !

!SourceFileArray methodsFor: 'public - string reading' stamp: ''!
commentTimeStampAt: sourcePointer
	^self timeStampAt: sourcePointer for: self commentDataPointers! !

!SourceFileArray methodsFor: '*System-Changes' stamp: 'nil'!
changeRecordsFor: aMethodDefinition detect: aUnaryBlock
	"Try to detect the most recent ChangeRecord that satisfies aUnaryBlock. Answer nil if none satisfies."

	self
		changeRecordsFor: aMethodDefinition
		do: [ :changeRecord | 
			(aUnaryBlock value: changeRecord category) 
				ifTrue: [ ^ changeRecord ] ].
	^ nil! !

!SourceFileArray methodsFor: 'accessing' stamp: ''!
sourcesFileStream
	"Answer the master .sources FileStream, with writing permissions."

	^ files at: 1! !

!SourceFileArray methodsFor: 'private' stamp: ''!
finishedReading: aReadOnlyFileArray from: aQueue

	(aQueue == readOnlyQueue and: [ aQueue size < self readOnlyQueueLimit ]) 
		ifTrue: [ aQueue nextPut: aReadOnlyFileArray ]
		ifFalse: [ self closeFileArray: aReadOnlyFileArray ]! !

!SourceFileArray methodsFor: 'private - copying' stamp: ''!
readOnlyCopy
	"Answer a read only copy of self. The caller is responsible of closing it."

	^ self species new
		sourcesFileStream: self sourcesFileStream readOnlyCopy;
		changesFileStream: self changesFileStream readOnlyCopy;
		yourself! !

!SourceFileArray methodsFor: 'private - accessing file streams' stamp: ''!
fileAt: index ifAbsent: aBlock
	^ files at: index ifAbsent: aBlock! !

!SourceFileArray methodsFor: 'accessing' stamp: ''!
changesFileStream: aStream

	^ files at: 2 put: aStream! !

!SourceFileArray methodsFor: 'private - accessing file streams' stamp: ''!
fileAt: index
	^ files at: index! !

!SourceFileArray methodsFor: 'public - file system operations' stamp: ''!
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 := self changesFileStream.
	changesFile isReadOnly ifFalse: [ 
		changesFile flush ].
	changesFile close.
	changesFile tryOpen.
	changesFile setToEnd! !

!SourceFileArray methodsFor: 'public - string reading' stamp: ''!
remoteStringAt: sourcePointer

	| filePosition fileIndex |
	fileIndex := self fileIndexFromSourcePointer: sourcePointer.
	filePosition := self filePositionFromSourcePointer: sourcePointer.	

	^ RemoteString newFileNumber: fileIndex position: filePosition! !

!SourceFileArray methodsFor: 'printing' stamp: ''!
reportString

	^ String streamContents: [ :aStream | 
		{ self sourcesFileStream. self changesFileStream } 
			do: [:each | each ifNotNil: [
				aStream nextPutAll: each printString; cr ] ] ]! !

!SourceFileArray class methodsFor: 'class initialization' stamp: ''!
initialize

	SessionManager default registerSystemClassNamed: self name.! !

!SourceFileArray class methodsFor: 'system startup' stamp: ''!
startUp: resuming

	resuming ifTrue: [ Smalltalk openSourceFiles ]! !

!SourceFileArrayTest commentStamp: ''!
This test documents the source pointer address conversion methods for ExpandedSourceFileArray.

The available address space for source pointers in a traditional CompiledMethod is 16r1000000 through 16r4FFFFFF. StandardSourceFileArray maps positions in the sources file to address range 16r1000000 through 16r1FFFFFF and 16r3000000 through 16r3FFFFFF, and positions in the changes file to address range 16r2000000 through 16r2FFFFFF and 16r4000000 through 16r4FFFFFF. This permits a maximum file size of 16r2000000 (32MB) for both the sources file and the changes file. 

ExpandedSourceFileArray extends the source pointer address space using bit 25 of the source pointer to identify the external sources and changes files, with the remaining high order bits treated as address extension. This limits the number of external file references to two (the traditional sources and changes files). If additional external file references are needed in the future, some higher order bits in the source pointer address space should be allocated for that purpose.

The use of bit 25 of the source pointer for file references permits backward compatibility with StandardSourceFileArray, with essentially unlimited address space expansion for the sources and changes files.
!
!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testForkedWrite

	| originalString remoteString readSemaphore readString testSemaphore |
	originalString := '"test"'.
	remoteString := nil.
	readSemaphore := Semaphore new.
	testSemaphore := Semaphore new.
	
	self ensureChangesFileOpenedInProcess.

	[	self ensureChangesFileOpenedInProcess.
		
		readSemaphore wait.

		"Write the string, that will be read in other process."
		remoteString := SourceFiles remoteStringForNewString: originalString.

		testSemaphore signal 
		] fork.

	readSemaphore signal.
	testSemaphore wait.

	"Read the string that was written in other process."
	readString := remoteString string.
	
	self assert: readString equals: originalString.! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testAddressRange
	"Test source pointer to file position address translation across a wide address range"

	| sf i p a |
	sf := SourceFileArray new.
	16r1000000 to: 16r10000000 by: 4093 do: [ :e | 
		i := sf fileIndexFromSourcePointer: e.
		p := sf filePositionFromSourcePointer: e.
		a := sf sourcePointerFromFileIndex: i andPosition: p.
		self assert: a equals: e ]! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testFileIndexFromSourcePointer
	"Test derivation of file index for sources or changes file from source pointers"

	| sf |
	sf := SourceFileArray new.
	"sources file mapping"
	self assert: 1 equals: (sf fileIndexFromSourcePointer: 16r1000000).
	self assert: 1 equals: (sf fileIndexFromSourcePointer: 16r1000013).
	self assert: 1 equals: (sf fileIndexFromSourcePointer: 16r1FFFFFF).
	self assert: 1 equals: (sf fileIndexFromSourcePointer: 16r3000000).
	self assert: 1 equals: (sf fileIndexFromSourcePointer: 16r3000013).
	self assert: 1 equals: (sf fileIndexFromSourcePointer: 16r3FFFFFF).

	self assert: 1 equals: (sf fileIndexFromSourcePointer: 16r5000000).
	self assert: 1 equals: (sf fileIndexFromSourcePointer: 16r5000013).
	self assert: 1 equals: (sf fileIndexFromSourcePointer: 16r5FFFFFF).

	(16r1000000 to: 16r1FFFFFF by: 811) do: [ :e | self assert: 1 equals: (sf fileIndexFromSourcePointer: e) ].
	(16r3000000 to: 16r3FFFFFF by: 811) do: [ :e | self assert: 1 equals: (sf fileIndexFromSourcePointer: e) ].
	"changes file mapping"
	self assert: 2 equals: (sf fileIndexFromSourcePointer: 16r2000000).
	self assert: 2 equals: (sf fileIndexFromSourcePointer: 16r2000013).
	self assert: 2 equals: (sf fileIndexFromSourcePointer: 16r2FFFFFF).
	self assert: 2 equals: (sf fileIndexFromSourcePointer: 16r4000000).
	self assert: 2 equals: (sf fileIndexFromSourcePointer: 16r4000013).
	self assert: 2 equals: (sf fileIndexFromSourcePointer: 16r4FFFFFF).

	self assert: 2 equals: (sf fileIndexFromSourcePointer: 16r6000000).
	self assert: 2 equals: (sf fileIndexFromSourcePointer: 16r6000013).
	self assert: 2 equals: (sf fileIndexFromSourcePointer: 16r6FFFFFF).

	(16r2000000 to: 16r2FFFFFF by: 811) do: [ :e | self assert: 2 equals: (sf fileIndexFromSourcePointer: e) ].
	(16r4000000 to: 16r4FFFFFF by: 811) do: [ :e | self assert: 2 equals: (sf fileIndexFromSourcePointer: e) ].

	"the following numeric ranges are unused but currently produces results as follows"
	self assert: 0 equals: (sf fileIndexFromSourcePointer: 16r0000000).
	self assert: 0 equals: (sf fileIndexFromSourcePointer: 16r0000013).
	self assert: 0 equals: (sf fileIndexFromSourcePointer: 16r0FFFFFF)! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testWriteToBufferedStream
	| fs array |
	fs := FileSystem memory.
	array := SourceFileArray new.
	
	array changesFileStream: 
		(SourceFileCharacterReadWriteStream on: (SourceFileBufferedReadWriteStream on: (fs binaryWriteStreamOn: (fs / 'changes.chunk') path)) encoding: #utf8).
	
	array sourcesFileStream: 
		(SourceFileCharacterReadWriteStream on: (SourceFileBufferedReadWriteStream on: (fs binaryWriteStreamOn: (fs / 'sources.chunk') path)) encoding: #utf8).

	array
		writeSource: 'some source'
		preamble: 'some preamble'
		onSuccess: [ :sourcePointer | "continue with assertions" ]
		onFail: [ "fail the test" self fail ].
	self assert: (fs / 'changes.chunk') contents equals: 'some preamblesome source!!'! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testWriteSourceWritesInGivenSourceFileArrayWithFlushDefering
	| fs array |
	fs := FileSystem memory.
	array := SourceFileArray new.
	array
		changesFileStream:
			(SourceFile on: 'changes.chunk' potentialLocations: { fs root })
				tryOpen;
		sourcesFileStream:
			(SourceFile on: 'sources.chunk' potentialLocations: { fs root })
				tryOpen;
		deferFlushDuring: [ 
			array
				writeSource: 'some source'
				preamble: 'some preamble'
				onSuccess: [ :arg1 |  ]
				onFail: [ self fail ] ].
	self
		assert: (fs / 'changes.chunk') contents
		equals: 'some preamblesome source!!'! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testFilePositionFromSourcePointer
	"Test derivation of file position for sources or changes file from source pointers"

	| sf |
	sf := SourceFileArray new.
	"sources file"
	self assert: 0 equals: (sf filePositionFromSourcePointer: 16r1000000).
	self assert: 16r13 equals: (sf filePositionFromSourcePointer: 16r1000013).
	self assert: 16rFFFFFF equals: (sf filePositionFromSourcePointer: 16r1FFFFFF).
	self assert: 16r1000000 equals: (sf filePositionFromSourcePointer: 16r3000000).
	self assert: 16r1000013 equals: (sf filePositionFromSourcePointer: 16r3000013).
	self assert: 16r1FFFFFF equals: (sf filePositionFromSourcePointer: 16r3FFFFFF).
	"changes file"
	self assert: 0 equals: (sf filePositionFromSourcePointer: 16r2000000).
	self assert: 16r13 equals: (sf filePositionFromSourcePointer: 16r2000013).
	self assert: 16rFFFFFF equals: (sf filePositionFromSourcePointer: 16r2FFFFFF).
	self assert: 16r1000000 equals: (sf filePositionFromSourcePointer: 16r4000000).
	self assert: 16r1000013 equals: (sf filePositionFromSourcePointer: 16r4000013).
	self assert: 16r1FFFFFF equals: (sf filePositionFromSourcePointer: 16r4FFFFFF).
	"the following numeric ranges are unused but currently produces results as follows"
	self assert: 0 equals: (sf filePositionFromSourcePointer: 16r0000000).
	self assert: 16r13 equals: (sf filePositionFromSourcePointer: 16r0000013).
	self assert: 16rFFFFFF equals: (sf filePositionFromSourcePointer: 16r0FFFFFF)! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testWriteSourceWritesInGivenSourceFileArray
	| fs array |
	fs := FileSystem memory.
	array := SourceFileArray new.
	array
		changesFileStream: (SourceFile on: 'changes.chunk' potentialLocations: {fs root}) tryOpen.
	array
		sourcesFileStream: (SourceFile on: 'sources.chunk' potentialLocations: {fs root}) tryOpen.
	array
		writeSource: 'some source'
		preamble: 'some preamble'
		onSuccess: [ :sourcePointer | "continue with assertions" ]
		onFail: [ "fail the test" self fail ].
	self assert: (fs / 'changes.chunk') contents equals: 'some preamblesome source!!'! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testWriteToChangesFileInGivenSourceFileArray
	| fs array |
	fs := FileSystem memory.
	array := SourceFileArray new.
	array
		changesFileStream: (SourceFile on: 'changes.chunk' potentialLocations: {fs root}) tryOpen.
	array
		sourcesFileStream: (SourceFile on: 'sources.chunk' potentialLocations: {fs root}) tryOpen.
	array
		changesWriteStreamDo: [ :changesFile | 
			changesFile
				cr;
				cr;
				nextChunkPut: 'test';
				cr ].
	self
		assert: (fs / 'changes.chunk') contents
		equals:
			'

test!!'! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testChangesFileStream

	self assert: SourceFiles changesFileStream isNotNil! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testSourcePointerFromFileIndexAndPosition
	"Test valid input ranges"

	| sf |
	sf := SourceFileArray new.
	self should: [ sf sourcePointerFromFileIndex: 0 andPosition: 0 ] raise: Error.
	sf sourcePointerFromFileIndex: 1 andPosition: 0.
	sf sourcePointerFromFileIndex: 2 andPosition: 0.
	self should: [ sf sourcePointerFromFileIndex: 0 andPosition: 3 ] raise: Error.
	self should: [ sf sourcePointerFromFileIndex: 1 andPosition: -1 ] raise: Error.
	sf sourcePointerFromFileIndex: 1 andPosition: 16r1FFFFFF.
	sf sourcePointerFromFileIndex: 1 andPosition: 16r2000000.
	self should: [ sf sourcePointerFromFileIndex: 3 andPosition: 0 ] raise: Error.
	self should: [ sf sourcePointerFromFileIndex: 4 andPosition: 0 ] raise: Error.
	self assert: 16r1000000 equals: (sf sourcePointerFromFileIndex: 1 andPosition: 0).
	self assert: 16r1000013 equals: (sf sourcePointerFromFileIndex: 1 andPosition: 16r13).
	self assert: 16r1FFFFFF equals: (sf sourcePointerFromFileIndex: 1 andPosition: 16rFFFFFF).
	self assert: 16r2000000 equals: (sf sourcePointerFromFileIndex: 2 andPosition: 0).
	self assert: 16r2000013 equals: (sf sourcePointerFromFileIndex: 2 andPosition: 16r13).
	self assert: 16r2FFFFFF equals: (sf sourcePointerFromFileIndex: 2 andPosition: 16rFFFFFF).
	self assert: 16r3000000 equals: (sf sourcePointerFromFileIndex: 1 andPosition: 16r1000000).
	self assert: 16r3000013 equals: (sf sourcePointerFromFileIndex: 1 andPosition: 16r1000013).
	self assert: 16r3FFFFFF equals: (sf sourcePointerFromFileIndex: 1 andPosition: 16r1FFFFFF).
	self assert: 16r4000000 equals: (sf sourcePointerFromFileIndex: 2 andPosition: 16r1000000).
	self assert: 16r4000013 equals: (sf sourcePointerFromFileIndex: 2 andPosition: 16r1000013).
	self assert: 16r4FFFFFF equals: (sf sourcePointerFromFileIndex: 2 andPosition: 16r1FFFFFF)! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testSourcesFileStream

	self assert: SourceFiles sourcesFileStream isNotNil! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testRemoteStringReadsInGivenSourceFileArray
	| fs array remoteString readStream |
	fs := FileSystem memory.
	array := SourceFileArray new.
	array changesFileStream: (SourceFile on: 'changes.chunk' potentialLocations: {fs root}) tryOpen.
	array sourcesFileStream: (SourceFile on: 'sources.chunk' potentialLocations: {fs root}) tryOpen.
	remoteString := array remoteStringForNewString: 'test'.
	self assert: remoteString string equals: 'test'.
	self assert: (array fileAt: remoteString sourceFileNumber) equals: array changesFileStream.
	readStream := (fs / 'changes.chunk') readStream.
	readStream position: remoteString position.
	self assert: (ChunkReadStream on: readStream) next equals: 'test'! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testProtocol
	"Test that we can access protocol correctly"

	| okCm notOkCm |
	okCm := Point >> #dotProduct:.
	self assert: ((SourceFiles sourcedDataAt: okCm sourcePointer) beginsWith: 'Point methodsFor: ''point functions''').
	self assert: (SourceFiles protocolAt: okCm sourcePointer) equals: 'point functions'.

	notOkCm := Behavior >> #superclass.
	self assert: (SourceFiles protocolAt: notOkCm sourcePointer) equals: 'accessing - class hierarchy'! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testRemoteStringWritesInGivenSourceFileArray
	| fs array |
	fs := FileSystem memory.
	array := SourceFileArray new.
	array
		changesFileStream: (SourceFile on: 'changes.chunk' potentialLocations: {fs root}) tryOpen.
	array
		sourcesFileStream: (SourceFile on: 'sources.chunk' potentialLocations: {fs root}) tryOpen.
	array remoteStringForNewString: 'test'.
	self
		assert: (fs / 'changes.chunk') contents
		equals:
			'
test!!'! !

!SourceFileArrayTest methodsFor: 'running' stamp: ''!
ensureChangesFileOpenedInProcess
	"Ensure the changes file is open"

	| remoteString |
	remoteString := SourceFiles remoteStringAt: thisContext method sourcePointer.

	self deny: remoteString string isNil.
	"self deny: ProcessAndSessionLocalSourcesFileArray value isNil."! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testSourcesFileAddressRange
	"Test file position to source pointer address translation for the sources file"

	| sf i p a a2 |
	sf := SourceFileArray new.
	0 to: 16r1FFFFFFF by: 4093 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 1 andPosition: e.
		i := sf fileIndexFromSourcePointer: a.
		self assert: i equals: 1.
		p := sf filePositionFromSourcePointer: a.
		self assert: p equals: e.
		a2 := sf sourcePointerFromFileIndex: 1 andPosition: p.
		self assert: a2 equals: a ].
	0 to: 16rFFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 1 andPosition: e.
		self assert: (a between: 16r1000000 and: 16r1FFFFFF) ].
	16r1000000 to: 16r1FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 1 andPosition: e.
		self assert: (a between: 16r3000000 and: 16r3FFFFFF) ].

	16r2000000 to: 16r2FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 1 andPosition: e.
		self assert: (a between: 16r5000000 and: 16r5FFFFFF) ].
	16r3000000 to: 16r3FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 1 andPosition: e.
		self assert: (a between: 16r7000000 and: 16r7FFFFFF) ].
	16r4000000 to: 16r4FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 1 andPosition: e.
		self assert: (a between: 16r9000000 and: 16r9FFFFFF) ].
	16r5000000 to: 16r5FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 1 andPosition: e.
		self assert: (a between: 16rB000000 and: 16rBFFFFFF) ].
	16r6000000 to: 16r6FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 1 andPosition: e.
		self assert: (a between: 16rD000000 and: 16rDFFFFFF) ].
	16r7000000 to: 16r7FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 1 andPosition: e.
		self assert: (a between: 16rF000000 and: 16rFFFFFFF) ]! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testChangesFileAddressRange
	"Test file position to source pointer address translation for the changes file"

	| sf i p a a2 |
	sf := SourceFileArray new.
	0 to: 16r1FFFFFFF by: 4093 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 2 andPosition: e.
		i := sf fileIndexFromSourcePointer: a.
		self assert: i equals: 2.
		p := sf filePositionFromSourcePointer: a.
		self assert: p equals: e.
		a2 := sf sourcePointerFromFileIndex: 2 andPosition: p.
		self assert: a2 equals: a ].
	0 to: 16rFFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 2 andPosition: e.
		self assert: (a between: 16r2000000 and: 16r2FFFFFF) ].
	16r1000000 to: 16r1FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 2 andPosition: e.
		self assert: (a between: 16r4000000 and: 16r4FFFFFF) ].
	16r2000000 to: 16r2FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 2 andPosition: e.
		self assert: (a between: 16r6000000 and: 16r6FFFFFF) ].
	16r3000000 to: 16r3FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 2 andPosition: e.
		self assert: (a between: 16r8000000 and: 16r8FFFFFF) ].
	16r4000000 to: 16r4FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 2 andPosition: e.
		self assert: (a between: 16rA000000 and: 16rAFFFFFF) ].
	16r5000000 to: 16r5FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 2 andPosition: e.
		self assert: (a between: 16rC000000 and: 16rCFFFFFF) ].
	16r6000000 to: 16r6FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 2 andPosition: e.
		self assert: (a between: 16rE000000 and: 16rEFFFFFF) ].
	16r7000000 to: 16r7FFFFFF by: 811 do: [ :e | 
		a := sf sourcePointerFromFileIndex: 2 andPosition: e.
		self assert: (a between: 16r10000000 and: 16r10FFFFFF) ]! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testForkedRead

	| originalString remoteString readSemaphore readString testSemaphore |
	originalString := '"test"'.
	remoteString := nil.
	readSemaphore := Semaphore new.
	testSemaphore := Semaphore new.

	self ensureChangesFileOpenedInProcess.
	
	[	self ensureChangesFileOpenedInProcess.

		readSemaphore wait.

		"Read the string that was written in other process."
		readString := remoteString string.
		testSemaphore signal 
		] fork.

	"Write the string, that will be read in other process."
	remoteString := SourceFiles remoteStringForNewString: originalString.

	readSemaphore signal.
	testSemaphore wait.
	
	self assert: readString equals: originalString.! !

!SourceFileArrayTest methodsFor: 'tests' stamp: ''!
testTimeStamp
	"Test that we can access timeStamp correctly"

	| okCm |
	okCm := Point>>#dotProduct: .
	self assert: (((SourceFiles sourcedDataAt: okCm sourcePointer)) beginsWith:   
 'Point methodsFor: ''point functions'' stamp: ''''').
	! !

!SourceFileBufferedReadWriteStream commentStamp: ''!
I am Buffered Read Write Stream.
I should only be used in the SourceFile implementation!
!SourceFileBufferedReadWriteStream methodsFor: 'querying' stamp: ''!
position

	^ nextPosition - 1 
! !

!SourceFileBufferedReadWriteStream methodsFor: 'reading' stamp: ''!
peek
	
	| value |
	value := self next.
	"If I have read correctly I reset the position"
	value ifNotNil: [ nextPosition := nextPosition - 1  ].
	
	^ value
	! !

!SourceFileBufferedReadWriteStream methodsFor: 'reading' stamp: ''!
next: aQuantity

	| read collection |

	collection := self collectionSpecies new: aQuantity.	

	read := self 
		readInto: collection 
		startingAt: 1 
		count: aQuantity.

	^ read = aQuantity 
		ifTrue: [ collection ]
		ifFalse: [ collection copyFrom: 1 to: read - 1 ]     ! !

!SourceFileBufferedReadWriteStream methodsFor: 'querying' stamp: ''!
position: aNewPosition

	^ nextPosition := aNewPosition + 1
! !

!SourceFileBufferedReadWriteStream methodsFor: 'reading' stamp: ''!
upToEnd
	"Read elements until the stream is atEnd and return them as a collection."

	| toRead |

	toRead := (streamSize - (nextPosition - 1)) max: 0.
	^ self next: toRead.! !

!SourceFileBufferedReadWriteStream methodsFor: 'testing' stamp: ''!
isBinary
	
	^ innerStream isBinary ! !

!SourceFileBufferedReadWriteStream methodsFor: 'writing' stamp: ''!
next: aQuantity putAll: aCollection startingAt: startingAt

	aCollection readStreamDo: [ :s | 
		s skip: startingAt - 1.
		self nextPutAll:  (s next: aQuantity)].! !

!SourceFileBufferedReadWriteStream methodsFor: 'private' stamp: ''!
isPositionInBuffer: aPosition

	^ aPosition between: bufferOffset and: bufferOffset + bufferLength! !

!SourceFileBufferedReadWriteStream methodsFor: 'private' stamp: ''!
refreshBufferFrom: aPosition

	| nextBufferPosition |

	nextBufferPosition := (((aPosition - 1) max:0) // buffer size) * buffer size.
	bufferOffset = nextBufferPosition ifTrue: [ ^ self ].

	self flush.

	"If the position is outside the real stream I will only flush the buffer if I have to empty it."
	(nextBufferPosition >= streamSize) 
		ifTrue: [
			bufferOffset := nextBufferPosition.
			bufferLength := 0.	
			^ self	].
		 
	(nextBufferPosition = (bufferOffset + bufferLength)) 
		ifFalse: [ innerStream position: nextBufferPosition ].

	bufferLength := innerStream readInto: buffer startingAt: 1 count: buffer size.
	bufferOffset := nextBufferPosition.! !

!SourceFileBufferedReadWriteStream methodsFor: 'writing' stamp: ''!
nextPut: anElement 
	
	self checkBufferFor: nextPosition.
		
	self bufferAt: nextPosition put: anElement.
	
	isDirty := true.
	nextPosition := nextPosition + 1! !

!SourceFileBufferedReadWriteStream methodsFor: 'initialize-release' stamp: ''!
sizeBuffer: size

	bufferLength > 0 ifTrue: [ self flush ].
	bufferLength := 0.

	buffer := self collectionSpecies new: size! !

!SourceFileBufferedReadWriteStream methodsFor: 'private' stamp: ''!
bufferAt: aPosition

	^ buffer at:  (aPosition - bufferOffset)
	
	! !

!SourceFileBufferedReadWriteStream methodsFor: 'closing' stamp: ''!
close
	
	self flush.
	innerStream close! !

!SourceFileBufferedReadWriteStream methodsFor: 'testing' stamp: ''!
isReadOnly
	
	^ false! !

!SourceFileBufferedReadWriteStream methodsFor: 'writing' stamp: ''!
flush
	
	isDirty ifFalse: [ ^ self ]. 
		
	innerStream position: bufferOffset.
	innerStream next: bufferLength putAll: buffer startingAt: 1.
	
	innerStream flush.
	
	streamSize := innerStream size.
	
	isDirty := false! !

!SourceFileBufferedReadWriteStream methodsFor: 'testing' stamp: ''!
atEnd
	
	^ self atEnd: nextPosition! !

!SourceFileBufferedReadWriteStream methodsFor: 'testing' stamp: ''!
isStream

	^ true! !

!SourceFileBufferedReadWriteStream methodsFor: 'initialization' stamp: ''!
defaultBufferSize
	
	^ 2 raisedToInteger: 16! !

!SourceFileBufferedReadWriteStream methodsFor: 'reading' stamp: ''!
next 
	| value |

	self atEnd 
		ifTrue: [^ nil].	
		
	self checkBufferFor:nextPosition.
		
	value := self bufferAt: nextPosition.
	
	nextPosition := nextPosition + 1.

	^ value! !

!SourceFileBufferedReadWriteStream methodsFor: 'testing' stamp: ''!
closed

	^ innerStream closed! !

!SourceFileBufferedReadWriteStream methodsFor: 'instance creation' stamp: ''!
on: aStream

	innerStream := aStream.
	nextPosition := aStream position + 1.
	streamSize := aStream size.
	
	bufferOffset := -1.
	bufferLength := 0.
	isDirty := false.
	
	self sizeBuffer: self defaultBufferSize.
	
! !

!SourceFileBufferedReadWriteStream methodsFor: 'initialize-release' stamp: ''!
collectionSpecies
	^ innerStream isBinary
		ifTrue: [ ByteArray ]
		ifFalse: [ String ]! !

!SourceFileBufferedReadWriteStream methodsFor: 'querying' stamp: ''!
size 

	^ streamSize max: (bufferOffset + bufferLength)! !

!SourceFileBufferedReadWriteStream methodsFor: 'reading' stamp: ''!
skip: aQuantity

	nextPosition := nextPosition + aQuantity! !

!SourceFileBufferedReadWriteStream methodsFor: 'private' stamp: ''!
atEnd: anInteger 
	
	anInteger < streamSize ifTrue: [ ^ false ].
	anInteger <= (bufferOffset + bufferLength)  ifTrue: [ ^ false ].
	
	^ true! !

!SourceFileBufferedReadWriteStream methodsFor: 'writing' stamp: ''!
ensureWrittenPosition: aPosition
	isDirty ifFalse: [ ^ false ].

	((self isPositionInBuffer: aPosition) or: [
		"The position has been written to disk but
		the buffer is dirty, so there is potentially
		data in the buffer that we need."
		aPosition <= bufferOffset ]) ifTrue: [
			self flush.
			^ true ].

	^ false! !

!SourceFileBufferedReadWriteStream methodsFor: 'reading' stamp: ''!
readInto: aBuffer startingAt: startingAt count: count

	| remainingCount maxPositionInBuffer read countToRead |

	remainingCount := count.
	read := 0.
	
	[ remainingCount > 0  and: [ self atEnd not ]]
		whileTrue: [  
			self checkBufferFor: nextPosition.
			
			maxPositionInBuffer := bufferOffset + bufferLength.
			countToRead := ( maxPositionInBuffer - (nextPosition - 1) ) min: remainingCount. 
			aBuffer
				replaceFrom: startingAt + read
				to: startingAt + read + countToRead - 1
				with: buffer
				startingAt: (nextPosition - bufferOffset).
				
			nextPosition := nextPosition + countToRead.
			remainingCount := remainingCount - countToRead.
			read := read + countToRead
		].
	
	^ read.! !

!SourceFileBufferedReadWriteStream methodsFor: 'reading' stamp: ''!
upTo: value 
	"Read upto but not including value and return them as a collection.
	If value is not found, return the entire contents of the stream.
	This could be further optimzed."
	
	^ self collectionSpecies 
		streamContents: [ :writeStream | | element |
			[ self atEnd or: [ (element := self next) = value ] ] whileFalse: [ 
				writeStream nextPut: element ] ]! !

!SourceFileBufferedReadWriteStream methodsFor: 'private' stamp: ''!
checkBufferFor: aPosition

	(self isPositionInBuffer: aPosition)
		ifFalse: [ self refreshBufferFrom: aPosition ]! !

!SourceFileBufferedReadWriteStream methodsFor: 'private' stamp: ''!
bufferAt: aPosition put: anElement

	self checkBufferFor: nextPosition.

	bufferLength := (aPosition - bufferOffset) max: bufferLength.
	buffer at: (aPosition - bufferOffset) put: anElement
	! !

!SourceFileBufferedReadWriteStream methodsFor: 'writing' stamp: ''!
nextPutAll: aCollection
	
	aCollection do: [ :each | self nextPut: each ]! !

!SourceFileBufferedReadWriteStream methodsFor: 'reading' stamp: ''!
setToEnd

	nextPosition := (streamSize max: (bufferOffset + bufferLength)) + 1! !

!SourceFileBufferedReadWriteStream class methodsFor: 'convenience' stamp: ''!
on: readStream do: block
	"Execute block with as argument a ZnBufferedReadStream on readStream.
	Return the value of block."

	| stream |

	stream := self on: readStream.

	^ [block value: stream ] ensure: [ stream flush ]! !

!SourceFileBufferedReadWriteStream class methodsFor: 'instance creation' stamp: ''!
on: writeStream
	^ self basicNew
		on: writeStream;
		yourself! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testEnsureWrittenPositionFlushesCompleteChunkDuringCompilation
	"This test covers https://github.com/pharo-project/pharo/issues/6063.
	When flushing is deferred but the internal write buffer overlows during
	compilation, part of a chunk may have been written to disk while the rest
	of the chunk is still in the buffer only. #ensureWrittenPosition used to
	check only whether the start position of the chunk had been written and
	a read stream would then read the complete chunk from disk. That chunk would
	then be incomplete of course."
	| trait |
	trait := classFactory newTrait.
	"force recompilation"
	trait addInstVarNamed: 'var'.
	classFactory
		newSubclassOf: classFactory defaultSuperclass
		using: trait.
 
	"Need to know the length of the author name"
	Author
		useAuthor: 'a'
		during: [
			| preambleLength |
			"<cr>
			!!TraitForTestToBeDeleted1 methodsFor: 'a' stamp: 'a 6/5/2020 14:47'!!
			<cr>"
			preambleLength := 2 + trait name size + 13 + 3 + 9 + Author changeStamp size + 3.
			
			SourceFiles changesWriteStreamDo: [ :sourceFile |
				| stream |
				[ "We want the internal buffer to be flushed after
				writing the first two characters of the method selector"
				stream := ((sourceFile instVarNamed: 'stream') instVarNamed: 'writeStream') wrappedStream.
				stream sizeBuffer: preambleLength + 2.
				
				"This happens in MCPackageLoader>>basicLoad:"
				SourceFiles deferFlushDuring: [
					"Compiling a method in a trait with users will lead to
					the source of the compiled method being read again for
					compilation in the using class which would read an incomplete
					chunk and lead to an error."
					
					"It's difficult to align the buffer properly to the file size, as
					we'd need to set the new buffer size first and then check whether
					the buffer is aligned and then adjust the buffer size again. Instead,
					we just compile enough methods so that we know we'll eventually end up
					in a situation were the buffer is flushed and we end up with a partial
					chunk in memory"
					1
						to: 10
						do: [ :index |
							"Need to know the length of the category name"
							trait
								compile: 'aMethod', index asString
								classified: 'a' ] ] ] ensure: [
									stream sizeBuffer: stream defaultBufferSize ] ] ]! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testReadInto
	| stream buffer count |
	stream := SourceFileBufferedReadWriteStream on: '0123456789' readStream.
	stream sizeBuffer: 8.
	buffer := String new: 6 withAll: Character space.
	stream skip: 1.
	stream readInto: buffer startingAt: 4 count: 3.
	self assert: buffer equals: '   123'.
	stream readInto: buffer startingAt: 1 count: 3.
	self assert: buffer equals: '456123'.
	count := stream readInto: buffer startingAt: 1 count: 100.
	self assert: count equals: 3.
	self assert: buffer equals: '789123'	 ! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'running' stamp: ''!
tearDown
	classFactory cleanUp.
	
	super tearDown! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testEnsureWrittenPositionFlushesCompleteChunk
	"This test covers https://github.com/pharo-project/pharo/issues/6063.
	When flushing is deferred but the internal write buffer overlows during
	compilation, part of a chunk may have been written to disk while the rest
	of the chunk is still in the buffer only. #ensureWrittenPosition used to
	check only whether the start position of the chunk had been written and
	a read stream would then read the complete chunk from disk. That chunk would
	then be incomplete of course.
	
	See #testEnsureWrittenPositionFlushesCompleteChunkDuringCompilation for a complete
	example of what happens when loading code."
	
	| stringStream stream |
	stringStream := ReadWriteStream with: ''.
	stream := SourceFileBufferedReadWriteStream on: stringStream.
	stream sizeBuffer: 15.
	
	stream nextPutAll: 'before flush - after flush'.
	self assert: stringStream contents equals: 'before flush - '.
	
	"this must force a flush to ensure that we can read a complete chunk"
	stream ensureWrittenPosition: 10.
	self assert: stringStream contents equals: 'before flush - after flush'! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testNextPutAllStartingAt
	| stringStream |

	stringStream := ReadWriteStream with: String new.
	
	SourceFileBufferedReadWriteStream on: stringStream do: [ : bufferedStream |
		bufferedStream sizeBuffer: 8.
		bufferedStream next: 5 putAll: '--012345--' startingAt: 3.
		bufferedStream next: 5 putAll: '0123456789XX' startingAt: 6. 
		bufferedStream next: 5 putAll: '--012345--' startingAt: 3.
		bufferedStream next: 5 putAll: '0123456789XX' startingAt: 6.] .
	
	self assert: stringStream contents equals: '01234567890123456789'! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testReadUpTo
	| stream |
	stream := SourceFileBufferedReadWriteStream on: '0123456789' readStream.
	stream sizeBuffer: 8.
	self assert: (stream upTo: $5) equals: '01234'.
	self assert: stream upToEnd equals: '6789'.
	self assert: stream atEnd! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testReadUpToEnd
	| stream |
	stream := SourceFileBufferedReadWriteStream on: '0123456789' readStream.
	stream sizeBuffer: 4.
	stream next: 2.
	self assert: stream upToEnd equals: '23456789'.
	self assert: stream atEnd! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testPeek
	| stream |
	stream := SourceFileBufferedReadWriteStream on: '0123456789' readStream.
	stream sizeBuffer: 8.
	'0123456789' do: [ :each |
		self deny: stream atEnd.
		self assert: stream peek equals: each.
		self assert: stream next equals: each ].
	self assert: stream atEnd.
	self assert: stream peek isNil.
	self assert: stream next isNil! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testReadIntoLarger
	| stream buffer count |
	stream := SourceFileBufferedReadWriteStream on: '0123456789' readStream.
	stream sizeBuffer: 4.
	buffer := String new: 10.
	count := stream readInto: buffer startingAt: 1 count: 10.
	self assert: count equals: 10.
	self assert: buffer equals: '0123456789'	 ! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testWritingOverflow
	| stringStream bufferedStream |
	
	stringStream := ReadWriteStream with: String new.
	bufferedStream := SourceFileBufferedReadWriteStream on: stringStream.
	bufferedStream sizeBuffer: 8.
	0 to: 9 do: [ :each | bufferedStream nextPut: (Character digitValue: each) ].
	bufferedStream nextPutAll: '0123'; nextPutAll: '4567'; nextPutAll: '89'.
	bufferedStream nextPutAll: '0123456789'; nextPutAll: '0123456789'.
	bufferedStream flush.
		
	self assert: stringStream contents equals: '0123456789012345678901234567890123456789'! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testReadThenWrite
	| stream stringStream |
	
	((SystemVersion current major < 7) or: [ SystemVersion current build < 690 ])
		ifTrue: [ ^ self skip ].

	stringStream := ReadWriteStream with: '0123456789' copy.
	stringStream reset.
	stream := SourceFileBufferedReadWriteStream on: stringStream.
	stream sizeBuffer: 8.
	
	stream next: 4.
	self assert: stream position equals: 4.
	
	stream nextPutAll: 'ABCD'.
	self assert: stream position equals: 8.
		
	self assert: stream peek equals: $8. 
	self assert: stream upToEnd equals: '89'.
	self assert: stream atEnd.
	
	self assert: stringStream contents equals: '0123ABCD89'! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testBuffering
	| stream |
	stream := SourceFileBufferedReadWriteStream on: '01234567890123456789' readStream.
	stream sizeBuffer: 8.
	self deny: stream atEnd.
	self assert: (stream next: 10) equals: '0123456789'.
	self deny: stream atEnd.
	self assert: (stream next: 10) equals: '0123456789'.
	self assert: stream atEnd	! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testSetAtEnd

	| stream originalStream|

	stream := SourceFileBufferedReadWriteStream on: (originalStream := ReadWriteStream with: '0123456789' copy).
	originalStream reset.
	
	stream setToEnd.
	
	stream nextPut: $A.
	stream flush.

	self assert: originalStream contents equals: '0123456789A'.
! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testWriteThenRead
	| stream stringStream |
	
	((SystemVersion current major < 7) or: [ SystemVersion current build < 690 ])
		ifTrue: [ ^ self skip ].

	stringStream := ReadWriteStream with: '0123456789' copy.
	stringStream reset.
	stream := SourceFileBufferedReadWriteStream on: stringStream.
	stream sizeBuffer: 8.
	
	stream nextPutAll: 'ABCD'.
	
	self assert: stream peek equals: $4. 
	self assert: stream position equals: 4.
	self assert: stream upToEnd equals: '456789'.
	self assert: stream position equals: 10.
	self assert: stream atEnd.
	
	self assert: stringStream contents equals: 'ABCD456789'! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'tests' stamp: ''!
testWriting
	| stringStream bufferedStream |
	stringStream := ReadWriteStream with: String new.

	bufferedStream := SourceFileBufferedReadWriteStream on: stringStream.
	0 to: 9 do: [ :each | bufferedStream nextPut: (Character digitValue: each) ].
	bufferedStream flush.

	self assert: stringStream contents equals: '0123456789'! !

!SourceFileBufferedReadWriteStreamTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	classFactory := ClassFactoryForTestCase new! !

!SourceFileCharacterReadWriteStream commentStamp: ''!
I am a read-write character stream. I am mainly used to open the Pharo source and changes files.!
!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
cr
	
	writeStream cr! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
position

	^ readStream position! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
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."
	
	^ self collectionSpecies streamContents: [ :out |
		| partialMatch pattern matched |
		partialMatch := (self collectionSpecies new: aCollection size) writeStream.
		pattern := aCollection readStream.
		matched := false.
		([ matched or: [ self atEnd or: [ pattern atEnd ] ] ]) whileFalse: [
			| ch |
			(ch := self next) = pattern next
				ifTrue: [
					pattern atEnd
						ifTrue: [ matched := true ]
						ifFalse: [ partialMatch nextPut: ch ] ]
				ifFalse: [
					pattern reset.
					out nextPutAll: partialMatch contents.
					partialMatch reset.
					out nextPut: ch ] ].
		matched ifFalse: [ out nextPutAll: partialMatch contents ] ]! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
peek
	
	^ readStream peek! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
next: anInteger 
	
	^ readStream next: anInteger! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
position: anInteger 
	
	readStream position: anInteger! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
upToEnd
	
	^ readStream upToEnd! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
next: anInteger putAll: aString startingAt: startIndex

	^ writeStream next: anInteger putAll: aString startingAt: startIndex! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
tab
	
	writeStream tab! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: aCharacter

	^ writeStream nextPut: aCharacter! !

!SourceFileCharacterReadWriteStream methodsFor: 'instance creation' stamp: ''!
on: aStream encoding: encoding
	| encoder |
	encoder := encoding asZnCharacterEncoder.
	readStream := ZnCharacterReadStream on: aStream encoding: encoder.
	writeStream := ZnCharacterWriteStream on: aStream encoding: encoder! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
close
	
	writeStream close! !

!SourceFileCharacterReadWriteStream methodsFor: 'testing' stamp: ''!
isReadOnly
	
	^ false! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
flush

	writeStream flush! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
atEnd
	
	^ readStream atEnd! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
next
	
	^ readStream next! !

!SourceFileCharacterReadWriteStream methodsFor: 'testing' stamp: ''!
closed
	^ writeStream closed! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
collectionSpecies
	^ String! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
space
	
	writeStream space! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
size

	^ readStream size! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
skip: anInteger 
	
	readStream skip: anInteger! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
ensureWrittenPosition: aPosition
	^ writeStream wrappedStream ensureWrittenPosition: aPosition! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
readOnlyCopy

	^ readStream! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
nextPutAll: aString

	^ writeStream nextPutAll: aString! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
print: object
	writeStream print: object! !

!SourceFileCharacterReadWriteStream methodsFor: 'accessing' stamp: ''!
setToEnd

	writeStream setToEnd! !

!SourceFileCharacterReadWriteStream class methodsFor: 'instance creation' stamp: ''!
on: wrappedStream encoding: encoding

	^ self new
		on: wrappedStream encoding: encoding;
		yourself! !

!SourceMethodConverter commentStamp: ''!
A SourceMessageConverter is a wrapper wich display the source code of the provided message!
!SourceMethodConverter methodsFor: 'private' stamp: ''!
internalGetText

	^ method sourceCode! !

!SourceMethodConverter methodsFor: 'initialization' stamp: ''!
shouldShout

	^ true.! !

!SourceSansProRegular commentStamp: ''!
http://sourceforge.net/projects/sourcesans.adobe/

Copyright 2010, 2012 Adobe Systems Incorporated (http://www.adobe.com/), with Reserved Font Name 'Source'. All Rights Reserved. Source is a trademark of Adobe Systems Incorporated in the United States and/or other countries.

This Font Software is licensed under the SIL Open Font License, Version 1.1.

This license is copied below, and is also available with a FAQ at: http://scripts.sil.org/OFL


-----------------------------------------------------------
SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
-----------------------------------------------------------

PREAMBLE
The goals of the Open Font License (OFL) are to stimulate worldwide
development of collaborative font projects, to support the font creation
efforts of academic and linguistic communities, and to provide a free and
open framework in which fonts may be shared and improved in partnership
with others.

The OFL allows the licensed fonts to be used, studied, modified and
redistributed freely as long as they are not sold by themselves. The
fonts, including any derivative works, can be bundled, embedded, 
redistributed and/or sold with any software provided that any reserved
names are not used by derivative works. The fonts and derivatives,
however, cannot be released under any other type of license. The
requirement for fonts to remain under this license does not apply
to any document created using the fonts or their derivatives.

DEFINITIONS
"Font Software" refers to the set of files released by the Copyright
Holder(s) under this license and clearly marked as such. This may
include source files, build scripts and documentation.

"Reserved Font Name" refers to any names specified as such after the
copyright statement(s).

"Original Version" refers to the collection of Font Software components as
distributed by the Copyright Holder(s).

"Modified Version" refers to any derivative made by adding to, deleting,
or substituting -- in part or in whole -- any of the components of the
Original Version, by changing formats or by porting the Font Software to a
new environment.

"Author" refers to any designer, engineer, programmer, technical
writer or other person who contributed to the Font Software.

PERMISSION & CONDITIONS
Permission is hereby granted, free of charge, to any person obtaining
a copy of the Font Software, to use, study, copy, merge, embed, modify,
redistribute, and sell modified and unmodified copies of the Font
Software, subject to the following conditions:

1) Neither the Font Software nor any of its individual components,
in Original or Modified Versions, may be sold by itself.

2) Original or Modified Versions of the Font Software may be bundled,
redistributed and/or sold with any software, provided that each copy
contains the above copyright notice and this license. These can be
included either as stand-alone text files, human-readable headers or
in the appropriate machine-readable metadata fields within text or
binary files as long as those fields can be easily viewed by the user.

3) No Modified Version of the Font Software may use the Reserved Font
Name(s) unless explicit written permission is granted by the corresponding
Copyright Holder. This restriction only applies to the primary font name as
presented to the users.

4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
Software shall not be used to promote, endorse or advertise any
Modified Version, except to acknowledge the contribution(s) of the
Copyright Holder(s) and the Author(s) or with their explicit written
permission.

5) The Font Software, modified or unmodified, in part or in whole,
must be distributed entirely under this license, and must not be
distributed under any other license. The requirement for fonts to
remain under this license does not apply to any document created
using the Font Software.

TERMINATION
This license becomes null and void if any of the above conditions are
not met.

DISCLAIMER
THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE
COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
OTHER DEALINGS IN THE FONT SOFTWARE.
!
!SourceSansProRegular methodsFor: 'accessing' stamp: ''!
fontContents
	self shouldBeImplemented.! !

!SourceSansProRegular class methodsFor: 'accessing' stamp: ''!
fontContents
	^ #[0 1 0 0 0 19 1 0 0 4 0 48 66 65 83 69 101 30 93 189 0 4 98 228 0 0 0 70 68 83 73 71 157 151 62 152 0 4 99 44 0 0 25 24 71 68 69 70 129 234 134 122 0 3 32 172 0 0 3 194 71 80 79 83 245 44 36 167 0 3 36 112 0 1 2 22 71 83 85 66 131 250 143 43 0 4 38 136 0 0 60 90 79 83 47 50 93 221 215 164 0 0 1 184 0 0 0 96 99 109 97 112 140 60 236 53 0 0 32 112 0 0 54 94 99 118 116 32 1 34 13 202 0 0 88 156 0 0 0 42 102 112 103 109 6 89 156 55 0 0 86 208 0 0 1 115 103 97 115 112 255 255 0 3 0 3 32 164 0 0 0 8 103 108 121 102 183 60 48 0 0 0 119 36 0 2 82 92 104 101 97 100 9 219 221 14 0 0 1 60 0 0 0 54 104 104 101 97 10 132 13 88 0 0 1 116 0 0 0 36 104 109 116 120 155 102 14 92 0 0 2 24 0 0 30 88 108 111 99 97 8 103 68 36 0 0 88 200 0 0 30 92 109 97 120 112 9 181 2 122 0 0 1 152 0 0 0 32 110 97 109 101 12 24 50 166 0 2 201 128 0 0 12 33 112 111 115 116 162 247 72 114 0 2 213 164 0 0 75 0 112 114 101 112 154 99 253 135 0 0 88 68 0 0 0 86 0 1 0 0 0 2 5 30 67 88 172 57 95 15 60 245 0 9 3 232 0 0 0 0 210 10 24 250 0 0 0 0 210 10 123 107 254 58 254 220 8 111 3 200 0 0 0 9 0 2 0 1 0 0 0 0 0 1 0 0 3 216 254 239 0 0 8 152 254 58 254 58 8 111 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 150 0 1 0 0 7 150 0 143 0 12 0 118 0 5 0 1 0 0 0 0 0 10 0 0 2 0 1 115 0 3 0 1 0 3 2 10 1 144 0 5 0 0 2 138 2 88 0 0 0 75 2 138 2 88 0 0 1 94 0 50 1 35 0 0 2 11 5 3 3 4 3 2 2 4 96 0 2 247 2 0 0 1 0 0 0 0 0 0 0 0 65 68 66 79 0 64 0 32 255 255 2 238 255 6 0 0 3 216 1 17 32 0 1 159 0 0 0 0 1 230 2 148 0 0 0 32 0 3 2 141 0 89 0 200 0 0 2 32 0 3 2 76 0 90 2 59 0 52 2 103 0 90 2 15 0 90 1 238 0 90 2 105 0 52 2 140 0 90 1 7 0 90 1 224 0 31 2 67 0 90 1 230 0 90 2 215 0 90 2 135 0 90 2 152 0 52 2 54 0 90 2 152 0 52 2 57 0 90 2 22 0 42 2 24 0 28 2 133 0 87 2 3 0 0 3 18 0 23 2 1 0 15 1 220 255 255 2 27 0 45 1 248 0 52 2 41 0 82 1 200 0 46 2 43 0 47 1 240 0 46 1 36 0 30 1 248 0 45 2 32 0 82 0 246 0 67 0 247 255 216 1 239 0 82 0 255 0 82 3 61 0 82 2 35 0 82 2 30 0 46 2 43 0 82 2 43 0 47 1 91 0 82 1 163 0 28 1 82 0 24 2 32 0 75 1 211 0 12 2 206 0 24 1 190 0 14 1 211 0 12 1 169 0 31 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 2 32 0 3 3 54 0 8 3 54 0 8 3 54 0 8 2 91 0 30 2 76 0 90 2 59 0 52 2 59 0 52 2 59 0 52 2 59 0 52 2 59 0 52 2 103 0 90 2 103 0 90 2 103 0 90 2 126 0 33 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 73 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 15 0 90 2 105 0 52 2 105 0 52 2 105 0 52 2 105 0 52 2 105 0 52 2 105 0 52 2 105 0 52 2 105 0 52 2 105 0 52 2 140 0 90 2 140 0 90 2 140 0 90 2 175 0 32 1 7 255 252 1 7 0 77 1 7 255 239 1 7 255 210 1 7 255 235 1 7 255 253 1 7 0 74 1 7 255 239 1 7 0 63 1 7 0 78 1 7 0 43 1 7 255 241 1 224 0 31 2 67 0 90 2 67 0 90 2 67 0 90 1 230 0 80 1 230 0 90 1 230 0 90 1 230 0 90 1 230 0 90 1 230 0 0 1 230 0 90 1 233 255 250 2 215 0 90 2 215 0 90 2 215 0 90 2 135 0 90 2 135 0 90 2 135 0 90 2 135 0 90 2 135 0 90 2 135 0 90 2 135 0 90 2 135 0 90 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 52 2 152 0 50 3 79 0 52 2 152 0 55 2 152 0 55 2 152 0 55 2 152 0 55 2 152 0 55 2 152 0 55 2 152 0 52 2 57 0 90 2 57 0 90 2 57 0 90 2 57 0 90 2 57 0 90 2 57 0 90 2 57 0 90 2 22 0 42 2 22 0 42 2 22 0 42 2 22 0 42 2 22 0 42 2 22 0 42 2 22 0 42 2 155 0 91 2 24 0 28 2 24 0 28 2 24 0 28 2 24 0 28 2 24 0 28 2 24 0 28 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 133 0 87 2 147 0 87 2 147 0 87 2 147 0 87 2 147 0 87 2 147 0 87 2 147 0 87 3 18 0 23 3 18 0 23 3 18 0 23 3 18 0 23 1 220 255 255 1 220 255 255 1 220 255 255 1 220 255 255 1 220 255 255 1 220 255 255 1 220 255 255 1 220 255 255 2 27 0 45 2 27 0 45 2 27 0 45 2 27 0 45 2 27 0 45 2 126 0 33 2 71 0 90 2 146 0 58 2 123 0 90 2 14 0 90 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 15 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 1 248 0 52 3 17 0 58 3 17 0 58 3 17 0 58 2 32 0 8 2 41 0 82 1 200 0 46 1 200 0 46 1 200 0 46 1 200 0 46 1 200 0 46 2 61 0 47 2 43 0 47 2 43 0 47 2 43 0 47 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 18 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 240 0 46 1 248 0 45 1 248 0 45 1 248 0 45 1 248 0 45 1 248 0 45 1 248 0 45 1 248 0 45 1 248 0 45 2 32 255 232 2 32 0 82 2 32 0 82 2 32 0 82 2 32 0 8 0 246 255 236 0 246 0 67 0 246 255 224 0 246 255 206 0 246 255 233 0 246 255 246 0 246 255 224 0 246 0 55 0 246 0 67 0 246 0 38 0 246 0 38 0 246 255 224 0 246 0 82 0 247 255 216 1 239 0 82 1 239 0 82 1 239 0 82 1 239 0 82 0 255 0 65 1 14 0 82 1 106 0 82 0 255 0 62 0 255 0 82 0 255 255 245 0 255 0 24 1 6 255 255 3 61 0 82 3 61 0 82 3 61 0 82 2 35 0 82 2 35 0 82 2 35 0 82 2 35 0 82 2 35 0 82 2 35 0 82 2 35 0 82 2 35 0 82 3 7 0 63 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 24 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 3 71 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 2 30 0 46 1 91 0 82 1 91 0 26 1 91 0 62 1 91 0 82 1 91 0 67 1 91 0 67 1 91 255 244 1 163 0 28 1 163 0 28 1 163 0 28 1 163 0 28 1 163 0 28 1 163 0 28 1 163 0 28 2 64 0 82 1 82 0 24 1 82 0 24 1 82 0 24 1 82 0 24 1 82 0 24 1 82 255 254 1 82 0 24 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 32 0 75 2 206 0 24 2 206 0 24 2 206 0 24 2 206 0 24 1 211 0 12 1 211 0 12 1 211 0 12 1 211 0 12 1 211 0 12 1 211 0 12 1 211 0 12 1 211 0 12 1 169 0 31 1 169 0 31 1 169 0 31 1 169 0 31 1 169 0 31 2 33 0 53 2 43 0 82 2 35 0 82 0 247 255 216 1 237 0 67 2 0 0 75 2 43 0 82 2 43 0 82 1 200 0 25 1 200 0 46 2 43 0 47 2 43 0 47 1 240 0 37 2 43 0 47 1 252 0 82 1 240 0 37 2 136 0 37 1 184 0 50 1 200 0 37 2 34 0 50 1 14 255 227 2 47 0 50 2 47 0 50 1 241 0 46 1 211 0 12 1 255 0 16 2 35 0 75 2 32 0 82 2 32 0 82 2 50 0 83 1 14 0 8 1 85 0 46 1 28 255 172 1 46 255 250 0 255 0 82 2 65 0 82 1 155 0 82 3 61 0 77 3 61 0 77 3 61 0 82 2 35 255 236 2 35 0 82 2 31 0 82 2 30 0 46 2 187 0 46 2 168 0 46 1 91 255 253 1 91 255 253 1 91 255 253 1 91 0 82 1 78 0 82 1 239 0 82 1 239 0 32 1 163 0 28 0 247 255 216 1 14 255 227 1 82 0 24 2 63 0 8 2 29 0 37 2 18 0 75 1 211 0 12 2 206 0 24 1 211 0 12 1 159 255 255 1 169 0 31 1 193 0 31 1 169 0 3 1 161 255 254 1 187 0 31 1 185 0 7 1 185 0 19 1 32 0 6 2 13 0 59 2 65 0 30 3 55 0 30 3 64 0 30 2 82 0 30 3 111 0 30 1 87 0 46 1 87 0 37 1 87 0 46 1 87 0 24 1 87 255 251 1 87 0 20 1 87 0 38 1 87 0 46 1 87 0 24 1 87 0 46 1 87 0 46 1 87 0 46 1 87 0 26 2 135 0 90 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 35 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 43 0 47 2 47 0 50 2 47 0 50 2 47 0 50 2 47 0 50 2 47 0 50 2 47 0 50 2 47 0 50 2 47 0 50 2 47 0 50 0 246 0 82 0 246 0 66 1 9 0 82 1 106 0 82 0 246 0 28 0 246 0 69 0 246 255 246 0 246 255 246 1 1 255 255 2 44 0 30 2 32 0 3 2 76 0 90 1 242 0 90 2 76 0 30 2 15 0 90 2 27 0 45 2 140 0 90 2 152 0 52 1 7 0 90 2 67 0 90 2 3 0 0 2 215 0 90 2 135 0 90 2 21 0 49 2 152 0 52 2 133 0 90 2 54 0 90 2 26 0 44 2 24 0 28 1 220 255 255 2 207 0 48 2 1 0 15 2 187 0 63 2 166 0 45 2 54 0 6 2 79 255 237 2 204 255 237 1 71 255 237 1 7 255 235 2 199 255 237 2 88 255 237 1 220 255 255 2 211 255 234 2 48 0 46 2 53 0 79 1 228 0 6 2 19 0 52 1 192 0 46 1 168 0 48 2 29 0 75 2 10 0 59 1 6 0 82 1 238 0 73 1 238 0 16 2 50 0 82 1 218 0 6 1 175 0 28 2 23 0 46 2 74 0 22 2 37 0 78 2 34 0 46 1 204 0 26 1 254 0 60 2 168 0 46 1 225 0 9 2 177 0 61 2 189 0 51 1 176 0 46 2 48 0 78 2 10 0 66 2 168 0 46 2 48 0 46 1 192 0 46 2 29 0 75 1 6 0 82 1 6 255 234 2 23 0 46 1 254 0 60 1 254 0 60 2 189 0 51 1 6 255 225 1 254 0 60 2 68 255 250 2 61 255 243 2 54 0 3 2 54 0 6 2 202 255 244 2 198 255 243 2 197 255 244 2 193 255 243 2 101 255 232 2 101 255 232 2 32 0 3 2 32 0 3 2 133 255 244 2 133 255 243 2 79 255 234 2 79 255 237 2 252 255 244 2 249 255 243 2 248 255 244 2 244 255 243 3 2 255 244 3 2 255 243 2 204 255 234 2 204 255 237 3 121 255 244 3 117 255 243 3 117 255 244 3 113 255 243 3 72 255 232 3 72 255 232 1 125 255 244 1 125 255 243 1 71 255 234 1 71 255 237 1 244 255 244 1 241 255 243 1 240 255 244 1 236 255 243 1 195 255 232 1 195 255 232 1 7 255 241 1 7 255 253 2 249 255 244 2 235 255 243 2 205 255 234 2 199 255 237 3 116 255 244 3 118 255 243 3 112 255 244 3 108 255 243 2 172 255 243 2 133 255 243 2 88 255 234 2 88 255 237 3 1 255 243 2 253 255 243 2 206 255 232 1 220 255 255 1 220 255 255 3 5 255 244 2 247 255 243 2 214 255 235 2 211 255 234 3 132 255 244 3 128 255 243 3 127 255 244 3 123 255 243 3 49 255 232 3 49 255 232 3 34 0 3 3 71 255 250 3 64 255 243 3 204 255 244 3 200 255 243 3 200 255 244 3 196 255 243 3 104 255 232 3 104 255 232 3 142 0 90 4 4 255 244 4 4 255 243 4 124 255 244 4 120 255 243 4 119 255 244 4 116 255 243 4 74 255 232 4 74 255 232 3 167 0 45 4 7 255 244 3 250 255 243 4 134 255 244 4 131 255 243 4 130 255 244 4 126 255 243 4 54 255 232 4 54 255 232 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 1 192 0 46 1 192 0 46 1 192 0 46 1 192 0 46 1 192 0 46 1 192 0 46 1 192 0 46 1 192 0 46 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 1 6 0 56 1 6 0 44 1 6 255 237 1 6 0 68 1 6 255 224 1 6 255 218 1 6 255 224 1 6 255 228 1 6 255 239 1 6 255 239 1 6 255 224 1 6 255 247 1 6 255 207 1 6 255 225 1 6 255 225 1 6 255 227 2 23 0 46 2 23 0 46 2 23 0 46 2 23 0 46 2 23 0 46 2 23 0 46 2 23 0 46 2 23 0 46 2 37 0 78 2 37 0 78 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 1 254 0 60 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 48 0 46 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 29 0 75 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 2 189 0 51 1 238 0 73 2 23 0 46 1 210 0 46 1 157 0 82 1 242 0 17 0 249 0 47 0 249 0 65 0 249 0 65 0 249 0 82 0 249 0 64 2 30 0 238 0 64 255 237 2 30 0 122 2 30 0 244 1 6 0 82 2 30 0 203 2 30 0 203 2 30 0 191 2 30 0 180 2 30 0 238 2 30 0 115 2 30 0 109 2 30 0 115 2 30 0 119 2 30 0 130 2 30 0 130 2 30 0 98 2 30 0 116 2 30 0 116 2 30 0 118 0 119 255 244 0 117 255 243 0 64 255 234 0 64 255 237 0 237 255 244 0 234 255 243 0 237 255 244 0 230 255 243 0 188 255 232 0 188 255 232 2 32 0 3 2 68 0 90 2 76 0 90 1 242 0 90 2 126 0 26 2 15 0 90 3 37 0 6 3 37 255 246 3 35 0 10 2 42 0 42 2 144 0 90 2 144 0 90 2 68 0 90 2 68 0 90 2 65 0 90 2 118 0 0 2 215 0 90 2 140 0 90 2 152 0 52 2 133 0 90 2 54 0 90 2 59 0 52 2 24 0 28 2 2 0 5 2 220 0 47 2 1 0 15 2 130 0 90 2 86 0 67 3 97 0 90 3 106 0 90 2 208 0 28 3 30 0 90 2 68 0 90 2 59 0 32 3 140 0 90 2 70 0 22 2 15 0 90 2 15 0 90 2 175 0 28 1 242 0 90 2 59 0 52 2 22 0 42 1 7 0 90 1 7 255 235 1 7 0 18 1 224 0 31 3 135 0 6 3 161 0 90 2 184 0 28 2 68 0 90 2 65 0 90 2 65 0 90 2 144 0 90 2 2 0 5 2 133 0 90 2 102 0 28 2 152 0 52 2 17 0 0 1 242 0 90 2 9 0 33 3 79 0 6 3 84 255 250 3 84 0 14 2 42 0 42 2 116 0 90 2 113 0 90 2 113 0 90 2 204 0 28 2 208 0 28 2 208 0 28 2 149 0 90 2 59 0 52 1 220 255 255 1 220 255 255 2 39 0 15 2 95 0 67 2 86 0 90 1 7 0 90 3 37 0 6 3 35 255 246 3 35 0 10 2 32 0 3 3 54 0 8 2 15 0 90 2 146 0 58 2 144 0 90 2 152 0 52 2 152 0 52 2 2 0 5 2 2 0 5 1 248 0 52 2 32 0 53 1 252 0 82 1 155 0 82 2 20 0 19 1 240 0 46 2 169 0 13 2 169 0 1 2 170 0 13 1 200 0 37 2 53 0 82 2 53 0 82 1 242 0 82 1 242 0 82 1 242 0 82 2 19 0 10 2 121 0 82 2 50 0 82 2 30 0 46 2 41 0 82 2 43 0 82 1 200 0 46 1 204 0 26 1 211 0 12 2 222 0 47 1 190 0 14 2 42 0 82 2 0 0 59 2 237 0 82 2 245 0 82 2 84 0 26 2 162 0 82 1 235 0 82 1 200 0 24 2 226 0 82 2 2 0 32 1 240 0 46 1 240 0 46 2 36 0 8 1 155 0 82 1 200 0 46 1 163 0 28 0 246 0 67 0 246 255 233 1 1 0 17 0 247 255 216 2 223 0 12 2 246 0 82 2 32 0 8 1 242 0 82 1 242 0 82 1 242 0 82 2 53 0 82 1 211 0 12 2 46 0 82 2 64 0 26 2 30 0 46 1 221 0 12 1 160 0 82 1 168 0 30 2 206 0 13 2 206 0 1 2 206 0 13 1 200 0 37 2 24 0 82 2 24 0 82 2 24 0 82 2 102 0 26 2 102 0 26 2 102 0 26 2 58 0 83 1 200 0 46 1 211 0 12 1 211 0 12 1 226 0 14 2 8 0 59 2 32 0 82 2 169 0 13 2 170 0 1 2 170 0 13 0 255 0 82 1 248 0 52 3 17 0 58 1 240 0 46 1 240 0 37 2 53 0 82 2 30 0 46 2 30 0 46 1 211 0 12 1 211 0 12 2 14 0 47 3 125 0 59 2 97 0 32 1 241 0 44 1 241 0 79 1 241 0 36 1 241 0 26 1 241 0 17 1 241 0 25 1 241 0 48 1 241 0 44 1 241 0 41 1 241 0 40 1 241 0 44 1 241 0 44 2 26 0 55 1 113 0 50 1 245 0 37 1 241 0 26 2 7 0 34 1 241 0 25 2 13 0 61 1 235 0 44 2 13 0 55 2 13 0 52 2 26 0 55 2 26 0 55 1 241 0 44 1 241 0 79 1 241 0 36 1 241 0 26 1 241 0 17 1 241 0 25 1 241 0 49 1 241 0 44 1 241 0 41 1 241 0 30 2 6 0 52 1 113 0 50 1 241 0 41 1 241 0 26 2 6 0 25 1 241 0 25 2 6 0 57 1 233 0 44 2 7 0 49 2 6 0 38 1 241 0 44 1 241 0 79 1 241 0 36 1 241 0 26 1 241 0 17 1 241 0 25 1 241 0 49 1 241 0 44 1 241 0 41 1 241 0 40 0 249 0 65 0 249 0 47 0 249 0 65 0 249 0 47 3 180 0 94 1 33 0 85 1 33 0 85 1 169 0 38 1 169 0 48 0 249 0 80 1 169 0 80 0 249 0 57 0 249 0 63 1 169 0 57 1 169 0 63 0 249 0 63 1 169 0 63 1 15 0 45 1 15 0 54 1 173 0 45 1 173 0 54 1 55 0 41 1 55 0 41 1 224 0 41 3 32 0 41 5 220 0 41 8 152 0 41 1 241 0 41 3 32 0 41 0 249 0 65 1 48 0 40 1 244 0 12 1 244 0 12 0 0 254 58 1 47 0 82 1 47 0 38 1 47 0 94 1 47 0 31 1 47 0 34 1 47 0 31 1 94 0 10 0 241 0 92 1 94 0 14 0 241 0 92 1 162 0 58 1 198 0 54 1 198 0 54 1 241 0 45 2 48 0 41 1 134 0 92 2 37 0 85 3 47 0 38 2 167 0 85 2 167 0 38 1 176 0 27 1 47 0 94 1 47 0 31 1 47 0 94 1 47 0 31 1 122 0 94 1 122 0 31 1 47 0 94 1 47 0 31 1 47 0 94 1 47 0 31 2 232 0 49 2 231 0 49 1 167 0 23 2 125 0 3 2 125 0 27 2 125 0 28 2 141 0 28 3 79 0 51 3 14 0 51 1 241 0 35 0 246 0 67 1 214 0 3 2 14 0 90 1 247 0 52 2 43 0 90 1 219 0 90 1 187 0 90 2 37 0 52 2 82 0 90 1 7 0 90 1 182 0 31 2 2 0 90 1 181 0 90 2 135 0 90 2 73 0 90 2 77 0 52 2 6 0 90 2 77 0 51 2 11 0 90 1 218 0 42 1 211 0 28 2 71 0 87 1 191 0 0 2 172 0 23 1 197 0 15 1 159 255 255 1 219 0 45 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 1 214 0 3 2 200 0 8 2 200 0 8 2 200 0 8 2 33 0 33 2 14 0 90 1 247 0 52 1 247 0 52 1 247 0 52 1 247 0 52 1 247 0 52 2 43 0 90 2 43 0 90 2 43 0 90 2 62 0 33 1 219 0 90 1 219 0 90 1 219 0 90 1 219 0 90 1 219 0 90 1 219 0 90 1 219 0 90 1 219 0 90 1 219 0 90 1 219 0 90 1 219 0 87 1 219 0 90 1 219 0 53 1 219 0 90 1 219 0 90 1 219 0 90 1 219 0 90 1 219 0 90 2 37 0 52 2 37 0 52 2 37 0 52 2 37 0 52 2 37 0 52 2 37 0 52 2 37 0 52 2 37 0 52 2 37 0 52 2 82 0 90 2 82 0 90 2 82 0 90 2 118 0 32 1 7 255 252 1 7 0 77 1 7 255 239 1 7 255 210 1 7 255 235 1 7 255 253 1 7 0 74 1 7 255 239 1 7 0 63 1 7 0 77 1 7 0 43 1 7 255 241 1 182 0 31 2 2 0 90 2 2 0 90 2 2 0 90 1 181 0 83 1 181 0 90 1 181 0 90 1 181 0 90 1 181 0 90 1 181 0 3 1 181 0 90 1 181 255 250 2 135 0 90 2 135 0 90 2 135 0 90 2 73 0 90 2 73 0 90 2 73 0 90 2 73 0 90 2 73 0 90 2 73 0 90 2 73 0 90 2 73 0 90 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 47 2 223 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 77 0 52 2 11 0 90 2 11 0 90 2 11 0 90 2 11 0 90 2 11 0 90 2 11 0 90 2 11 0 90 1 218 0 42 1 218 0 42 1 218 0 42 1 218 0 42 1 218 0 42 1 218 0 42 1 218 0 42 3 170 0 42 2 82 0 91 1 211 0 28 1 211 0 28 1 211 0 28 1 211 0 28 1 211 0 28 1 211 0 28 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 71 0 87 2 85 0 87 2 85 0 87 2 85 0 87 2 85 0 87 2 85 0 87 2 85 0 87 2 172 0 23 2 172 0 23 2 172 0 23 2 172 0 23 1 159 255 255 1 159 255 255 1 159 255 255 1 159 255 255 1 159 255 255 1 159 255 255 1 159 255 255 1 159 255 255 1 219 0 45 1 219 0 45 1 219 0 45 1 219 0 45 1 219 0 45 2 62 0 33 2 13 0 90 2 70 0 58 2 56 0 90 2 14 0 90 2 73 0 90 1 214 0 3 2 14 0 90 1 192 0 90 2 2 0 30 1 219 0 90 1 219 0 45 2 82 0 90 2 77 0 52 1 7 0 90 2 2 0 90 1 189 0 0 2 135 0 90 2 73 0 90 1 215 0 49 2 77 0 52 2 76 0 90 2 6 0 90 1 215 0 44 1 211 0 28 1 159 255 255 2 143 0 48 1 197 0 15 2 113 0 63 2 80 0 44 1 7 255 235 1 159 255 255 2 221 0 3 3 89 0 90 3 87 0 44 1 214 0 3 2 7 0 90 2 14 0 90 1 192 0 90 2 50 0 26 1 219 0 90 2 185 0 6 1 230 0 43 2 73 0 90 2 73 0 90 2 7 0 90 2 46 0 0 2 135 0 90 2 82 0 90 2 77 0 52 2 76 0 90 2 6 0 90 1 247 0 52 1 211 0 28 1 189 0 5 2 128 0 47 1 197 0 15 2 67 0 90 2 29 0 67 3 4 0 90 3 11 0 90 2 110 0 28 2 208 0 90 2 8 0 90 1 246 0 32 3 33 0 90 2 10 0 22 1 219 0 90 1 219 0 90 2 85 0 28 1 192 0 90 1 245 0 52 1 218 0 42 1 7 0 90 1 7 255 235 1 7 0 18 1 182 0 31 2 253 0 0 3 40 0 90 2 99 0 28 2 7 0 90 2 73 0 90 1 189 0 5 2 69 0 90 2 30 0 28 2 77 0 52 1 200 0 0 1 192 0 90 1 214 0 33 2 231 0 6 1 230 0 43 2 55 0 90 2 125 0 28 2 89 0 90 1 247 0 52 1 159 255 255 1 159 255 255 1 235 0 15 2 35 0 67 2 29 0 90 1 7 0 90 2 185 0 6 1 214 0 3 2 200 0 8 1 219 0 90 2 70 0 58 2 73 0 90 2 77 0 52 2 77 0 52 1 189 0 5 1 189 0 5 2 22 0 32 1 249 0 55 1 102 0 50 1 197 0 34 1 203 0 23 1 225 0 36 1 209 0 31 1 232 0 62 1 175 0 33 1 233 0 54 1 227 0 49 1 33 0 85 1 33 0 85 1 169 0 48 1 169 0 58 0 249 0 80 1 169 0 80 0 249 0 57 0 249 0 63 1 140 0 57 1 140 0 63 1 55 0 41 1 158 0 41 2 175 0 41 1 47 0 82 1 47 0 38 1 47 0 94 1 47 0 31 1 47 0 34 1 47 0 31 1 111 0 35 1 111 0 87 1 111 0 40 1 111 0 35 1 111 0 42 1 111 0 35 1 111 0 45 1 111 0 50 1 111 0 45 1 111 0 39 0 237 0 65 0 237 0 39 0 177 0 43 0 177 0 33 1 111 0 35 1 111 0 87 1 111 0 40 1 111 0 35 1 111 0 42 1 111 0 35 1 111 0 45 1 111 0 50 1 111 0 45 1 111 0 39 0 237 0 65 0 237 0 39 0 177 0 43 0 177 0 33 1 111 0 35 1 111 0 87 1 111 0 40 1 111 0 35 1 111 0 42 1 111 0 35 1 111 0 45 1 111 0 50 1 111 0 45 1 111 0 39 0 237 0 65 0 237 0 39 0 177 0 43 0 177 0 33 1 111 0 35 1 111 0 87 1 111 0 40 1 111 0 35 1 111 0 42 1 111 0 35 1 111 0 45 1 111 0 50 1 111 0 45 1 111 0 39 0 237 0 65 0 237 0 39 0 177 0 43 0 177 0 33 1 89 0 37 1 118 0 33 1 109 0 30 1 107 255 255 1 136 0 57 1 123 0 32 1 155 0 57 1 95 0 57 1 74 0 57 1 155 0 32 1 178 0 57 0 176 0 57 1 65 0 18 1 131 0 57 1 69 0 57 1 230 0 57 1 175 0 57 1 187 0 32 1 129 0 57 1 187 0 31 1 133 0 57 1 100 0 26 1 100 0 17 1 175 0 56 1 90 255 254 2 14 0 13 1 90 0 8 1 64 255 253 1 102 0 27 1 89 0 37 1 118 0 52 1 50 0 30 1 118 0 33 1 80 0 28 0 201 0 19 1 87 0 30 1 110 0 52 0 166 0 42 0 169 255 230 1 81 0 52 0 174 0 52 2 47 0 52 1 113 0 52 1 109 0 30 1 118 0 52 1 118 0 33 0 240 0 52 1 27 0 19 0 232 0 16 1 114 0 50 1 65 0 8 1 231 0 16 1 51 0 8 1 63 0 8 1 34 0 21 1 46 0 22 0 249 0 50 0 249 0 50 0 151 255 159 1 62 0 8 1 80 0 28 1 80 0 28 1 80 0 25 1 118 0 33 1 121 0 34 0 166 0 52 0 177 0 43 0 236 0 41 1 92 0 41 2 50 0 41 1 75 0 41 1 241 0 26 1 241 0 52 1 241 0 53 1 241 0 23 1 241 0 23 1 241 0 23 1 241 0 61 1 241 0 18 1 241 0 61 1 241 0 53 1 241 0 11 1 241 0 10 1 241 255 241 1 241 0 68 1 241 0 10 1 241 0 47 1 241 0 23 1 241 0 61 1 241 0 72 1 241 0 23 1 241 0 33 1 241 0 33 1 241 0 10 0 86 255 89 0 86 255 89 0 86 255 89 3 56 0 35 4 170 0 35 3 13 0 64 3 40 0 64 3 28 0 35 3 36 0 64 3 53 0 41 3 36 0 64 3 53 0 41 3 53 0 35 3 78 0 42 3 36 0 64 3 53 0 35 3 36 0 64 3 36 0 64 3 53 0 35 3 53 0 35 3 33 0 31 3 36 0 64 4 68 0 63 3 53 0 35 1 241 0 34 1 241 0 34 1 241 0 50 1 241 0 34 1 246 0 188 1 241 0 34 1 241 0 34 1 241 0 34 1 241 0 34 1 241 0 34 1 241 0 34 1 241 0 60 1 241 0 34 1 241 0 36 1 241 0 36 1 241 0 34 3 14 0 40 2 50 0 82 2 16 0 40 1 76 0 52 2 45 0 41 2 76 0 30 2 166 0 45 1 248 0 22 2 161 0 89 1 153 0 21 3 32 0 46 2 107 0 26 2 107 0 42 2 107 0 39 2 107 0 42 3 127 0 45 3 127 0 25 3 127 0 33 3 127 0 45 3 127 0 51 3 127 0 51 3 127 0 45 3 127 0 45 3 127 0 51 3 127 0 51 3 127 0 25 3 127 0 25 3 31 0 74 3 31 0 74 2 100 0 0 1 247 0 29 2 5 0 56 0 249 0 82 1 170 0 82 0 249 0 64 0 249 0 82 0 249 0 57 0 249 0 63 0 166 0 30 0 166 0 15 2 30 0 128 2 30 0 215 2 30 0 116 2 30 0 116 0 114 0 22 1 21 0 6 0 225 0 55 0 225 255 224 0 114 0 22 2 30 0 98 2 30 0 125 2 30 0 138 2 30 0 115 2 30 0 161 2 30 0 175 2 30 0 217 2 30 0 182 2 30 0 205 2 73 0 46 0 0 255 113 0 0 255 121 0 0 255 165 0 0 255 200 0 0 255 202 0 0 255 223 0 0 255 101 0 0 255 108 0 0 255 83 0 0 255 79 0 0 255 123 0 0 255 122 0 0 255 123 0 0 255 122 0 0 255 100 0 0 255 99 0 0 255 110 0 0 255 105 0 0 255 202 0 0 255 199 0 0 255 110 0 0 255 104 0 0 255 188 0 0 255 188 0 0 255 146 0 0 255 159 0 0 255 160 0 0 255 154 0 0 255 101 0 0 255 108 0 18 255 227 0 0 255 57 0 0 255 50 0 0 255 100 0 0 255 110 0 0 255 203 0 0 255 176 0 0 255 209 0 0 255 188 0 0 255 180 0 0 255 171 0 0 255 180 0 0 255 247 0 0 255 190 0 0 255 160 0 0 255 160 0 0 255 160 0 0 255 160 0 0 255 202 0 0 255 110 0 0 255 146 0 0 255 161 0 0 255 178 0 0 255 161 0 0 255 161 0 0 255 190 0 0 255 190 0 0 255 221 0 0 255 135 0 0 255 101 0 0 255 100 0 0 255 100 0 0 255 83 0 0 255 123 0 0 255 83 0 0 255 201 0 0 255 135 0 0 255 135 0 0 255 88 0 0 255 172 0 0 255 83 0 0 255 79 0 0 255 223 0 0 254 58 0 0 255 114 0 0 255 108 0 0 255 101 0 0 255 114 0 0 255 108 0 0 255 101 0 0 255 103 0 0 255 114 0 0 255 108 0 0 255 114 0 0 255 108 0 0 255 122 0 0 255 127 0 0 255 9 0 0 255 45 0 0 255 122 0 0 255 127 0 0 255 119 0 0 255 111 0 0 255 100 0 0 255 110 0 0 255 100 0 0 255 110 0 0 255 100 0 0 255 110 0 0 255 112 0 0 255 111 0 0 255 127 0 0 255 119 0 0 255 123 0 0 255 122 0 0 255 104 0 0 255 94 0 0 255 115 0 0 255 100 0 0 255 100 0 0 255 115 0 202 0 0 1 241 0 0 0 135 0 0 0 135 0 0 0 125 0 0 0 0 0 0 2 44 0 30 2 35 0 30 0 0 0 5 0 0 0 3 0 0 2 36 0 0 0 4 0 0 16 218 0 1 0 0 0 0 0 44 0 3 0 1 0 0 2 36 0 3 0 10 0 0 16 218 0 6 1 248 0 0 0 9 0 247 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 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 4 122 4 127 4 191 6 166 6 191 4 62 4 126 4 151 4 152 4 161 6 212 4 118 4 138 4 117 4 157 4 63 4 64 4 65 4 66 4 67 4 68 4 69 4 70 4 71 4 72 4 119 4 120 6 218 6 217 6 219 4 124 4 189 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 15 0 16 0 17 0 18 0 19 0 20 0 21 0 22 0 23 0 24 0 25 0 26 0 27 4 153 4 159 4 154 6 223 4 148 7 12 0 28 0 29 0 30 0 31 0 32 0 33 0 34 0 35 0 36 0 37 0 38 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 47 0 48 0 49 0 50 0 51 0 52 0 53 4 155 4 158 4 156 6 225 0 0 0 58 0 61 0 81 0 91 0 151 0 160 0 207 0 249 0 248 0 250 0 252 0 251 0 255 1 19 1 29 1 28 1 30 1 32 1 60 1 59 1 61 1 63 1 91 1 98 1 97 1 99 1 101 1 100 1 146 1 145 1 147 1 149 4 162 6 164 6 171 6 167 4 164 4 147 4 165 1 137 4 184 4 182 4 185 7 13 7 22 6 224 0 76 0 173 6 228 6 222 6 220 6 221 6 168 6 229 6 230 6 235 6 236 2 111 6 231 6 94 6 96 2 86 1 14 1 114 4 125 4 123 6 227 6 232 6 172 6 226 6 233 4 136 4 137 4 121 7 142 0 54 0 57 0 159 0 174 1 115 4 140 4 141 4 130 4 131 4 128 4 129 6 215 7 3 1 175 0 233 6 188 6 170 4 134 4 135 7 148 7 149 4 163 4 146 4 132 4 133 6 192 0 56 0 92 0 55 0 94 0 90 0 122 0 123 0 125 0 121 0 157 0 158 0 0 0 156 0 204 0 205 0 203 1 71 7 14 7 21 7 23 7 24 7 27 7 25 7 28 7 26 7 29 7 15 0 4 14 182 0 0 1 224 1 0 0 7 0 224 0 47 0 64 0 96 0 126 0 191 0 209 0 223 0 241 1 126 1 128 1 143 1 147 1 161 1 176 1 194 1 220 1 227 1 231 1 235 1 245 1 249 1 253 2 27 2 55 2 67 2 81 2 88 2 92 2 104 2 106 2 110 2 118 2 123 2 126 2 132 2 146 2 149 2 153 2 157 2 159 2 162 2 176 2 179 2 185 2 188 2 191 2 193 2 204 2 209 2 222 2 227 3 12 3 15 3 19 3 32 3 42 3 44 3 49 3 52 3 61 3 66 3 69 3 97 3 117 3 122 3 126 3 138 3 140 3 144 3 161 3 171 3 176 3 194 3 206 3 209 3 213 3 215 3 217 3 219 3 221 3 225 4 7 4 12 4 15 4 22 4 26 4 47 4 54 4 58 4 87 4 92 4 95 4 99 4 117 4 147 4 155 4 163 4 171 4 179 4 183 4 187 4 194 4 209 4 217 4 227 4 233 4 239 4 243 29 67 29 73 29 77 29 80 29 82 29 88 29 91 29 156 29 160 29 187 30 7 30 15 30 23 30 33 30 37 30 43 30 59 30 73 30 83 30 99 30 111 30 133 30 143 30 151 30 158 30 249 31 1 31 9 31 17 31 21 31 25 31 29 31 33 31 41 31 49 31 57 31 65 31 69 31 73 31 77 31 81 31 87 31 89 31 91 31 93 31 97 31 105 31 125 31 129 31 135 31 145 31 151 31 161 31 167 31 180 31 196 31 211 31 219 31 223 31 239 31 244 31 254 32 7 32 22 32 26 32 30 32 34 32 38 32 48 32 51 32 53 32 58 32 63 32 68 32 73 32 113 32 121 32 127 32 137 32 142 32 148 32 161 32 164 32 167 32 169 32 172 32 174 32 178 32 181 32 186 32 189 33 19 33 23 33 32 33 34 33 38 33 46 33 82 33 90 33 94 33 137 33 147 34 2 34 6 34 15 34 18 34 21 34 26 34 30 34 43 34 72 34 96 34 101 35 31 37 160 37 179 37 183 37 189 37 193 37 198 37 202 37 204 38 17 38 106 39 19 39 82 39 231 46 37 46 59 251 4 254 255 255 255 0 0 0 32 0 48 0 65 0 97 0 160 0 192 0 210 0 224 0 242 1 128 1 143 1 146 1 160 1 175 1 194 1 205 1 226 1 230 1 234 1 244 1 248 1 252 2 24 2 55 2 67 2 80 2 82 2 89 2 94 2 106 2 108 2 111 2 120 2 125 2 128 2 136 2 148 2 152 2 156 2 159 2 161 2 176 2 178 2 183 2 187 2 190 2 193 2 198 2 208 2 216 2 224 3 0 3 15 3 17 3 24 3 35 3 44 3 46 3 52 3 57 3 66 3 69 3 97 3 116 3 122 3 126 3 132 3 140 3 142 3 145 3 163 3 172 3 177 3 195 3 208 3 213 3 215 3 217 3 219 3 221 3 225 4 0 4 8 4 13 4 16 4 23 4 27 4 48 4 55 4 59 4 88 4 93 4 98 4 114 4 144 4 150 4 160 4 170 4 174 4 182 4 186 4 192 4 207 4 212 4 226 4 230 4 238 4 242 29 67 29 71 29 77 29 79 29 82 29 86 29 91 29 156 29 160 29 187 30 6 30 12 30 22 30 32 30 36 30 42 30 50 30 62 30 82 30 88 30 108 30 128 30 142 30 146 30 158 30 160 31 0 31 2 31 10 31 18 31 24 31 26 31 32 31 34 31 42 31 50 31 58 31 66 31 72 31 74 31 80 31 82 31 89 31 91 31 93 31 95 31 98 31 106 31 128 31 130 31 136 31 146 31 152 31 162 31 168 31 182 31 198 31 214 31 221 31 224 31 242 31 246 32 7 32 18 32 24 32 28 32 32 32 38 32 47 32 50 32 53 32 57 32 60 32 68 32 71 32 112 32 116 32 125 32 128 32 141 32 148 32 161 32 164 32 166 32 169 32 171 32 174 32 177 32 180 32 184 32 189 33 19 33 22 33 32 33 34 33 38 33 46 33 80 33 83 33 91 33 137 33 144 34 2 34 6 34 15 34 17 34 21 34 25 34 30 34 43 34 72 34 96 34 100 35 28 37 160 37 178 37 182 37 188 37 192 37 198 37 201 37 204 38 16 38 106 39 19 39 82 39 230 46 34 46 58 251 0 254 255 255 255 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 145 255 102 0 0 0 0 0 0 0 62 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 133 254 12 0 0 255 109 255 111 0 0 255 110 255 110 255 111 255 110 255 109 255 108 255 105 255 104 0 0 0 0 255 62 255 93 3 210 0 0 0 0 4 77 4 76 3 212 4 72 3 198 0 0 0 0 0 0 4 47 0 0 4 46 0 0 4 46 4 45 4 43 4 39 4 35 4 34 4 7 255 244 255 243 255 231 0 0 254 208 0 0 254 174 0 0 0 0 0 0 0 0 254 169 254 166 255 137 255 136 255 135 255 134 255 131 255 172 255 173 255 175 255 120 255 122 255 124 255 178 255 180 255 182 255 183 255 185 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 233 56 0 0 233 52 0 0 233 55 0 0 233 53 232 225 232 224 232 217 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 226 38 0 0 227 231 0 0 0 0 227 230 227 123 227 125 227 220 0 0 0 0 0 0 0 0 227 217 227 105 227 107 227 209 227 211 227 97 227 98 227 97 0 0 0 0 0 0 227 189 227 191 0 0 227 187 0 0 227 183 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 231 136 0 0 0 0 0 0 0 0 228 83 0 0 230 210 230 209 228 77 0 0 230 120 0 0 0 0 229 182 0 0 229 180 229 177 230 8 230 12 230 10 230 9 230 8 0 0 230 11 230 2 230 1 0 0 229 254 229 218 0 0 227 154 227 151 229 196 229 192 0 0 229 113 229 114 229 74 229 95 228 228 228 227 228 221 0 0 228 168 0 0 228 198 228 188 228 154 228 128 228 120 225 144 225 83 225 69 225 67 225 63 225 61 225 46 0 0 225 82 224 239 224 152 223 238 223 164 220 202 214 144 214 84 0 0 0 0 0 1 1 224 1 254 2 30 2 92 2 150 2 212 2 246 3 16 3 50 0 0 0 0 4 70 4 72 4 74 0 0 4 74 4 104 4 106 4 108 4 110 4 112 4 114 4 116 0 0 0 0 4 118 0 0 0 0 4 116 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 120 4 122 0 0 0 0 0 0 4 118 4 120 0 0 0 0 0 0 0 0 0 0 4 114 4 126 4 132 0 0 4 154 0 0 4 156 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 150 0 0 4 160 0 0 4 162 4 178 4 186 4 220 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 206 4 208 4 214 4 220 4 230 4 236 4 238 4 248 4 250 4 252 5 0 5 4 5 14 5 16 5 22 5 24 0 0 5 24 0 0 5 26 0 0 5 26 0 0 0 0 0 0 0 0 5 22 5 24 5 30 5 32 5 34 5 36 5 38 5 56 5 78 5 80 5 102 5 108 5 118 5 120 0 0 5 128 0 0 6 48 6 62 0 0 0 0 0 0 0 0 6 68 6 82 6 96 6 110 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 108 6 112 6 126 0 0 0 0 6 160 0 0 6 176 0 0 6 192 6 216 6 244 7 14 7 24 7 28 7 58 7 62 0 0 7 76 7 84 7 88 7 92 0 0 7 94 0 0 0 0 0 0 7 90 0 0 7 94 7 98 0 0 7 98 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 88 0 0 0 0 0 0 7 84 0 0 0 0 7 84 0 0 0 0 0 0 0 0 7 78 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 68 0 0 7 68 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 46 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 32 7 40 0 0 0 1 4 122 4 127 4 191 6 166 6 191 4 62 4 126 4 151 4 152 4 161 6 212 4 118 4 138 4 117 4 157 4 63 4 64 4 65 4 66 4 67 4 68 4 69 4 70 4 71 4 72 4 119 4 120 6 218 6 217 6 219 4 124 4 189 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 15 0 16 0 17 0 18 0 19 0 20 0 21 0 22 0 23 0 24 0 25 0 26 0 27 4 153 4 159 4 154 6 223 4 148 7 12 0 28 0 29 0 30 0 31 0 32 0 33 0 34 0 35 0 36 0 37 0 38 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 47 0 48 0 49 0 50 0 51 0 52 0 53 4 155 4 158 4 156 6 225 7 142 4 123 6 171 6 167 6 165 6 168 4 160 4 164 7 22 4 182 6 94 4 136 6 227 4 139 4 184 7 23 6 164 6 222 6 40 6 41 7 13 6 229 4 165 4 146 7 28 6 39 6 96 4 137 6 193 6 194 6 195 4 125 0 54 0 55 0 56 0 57 0 58 0 61 0 76 0 81 0 90 0 91 0 92 0 94 0 121 0 122 0 123 0 125 0 243 0 151 0 156 0 157 0 158 0 159 0 160 6 214 0 173 0 203 0 204 0 205 0 207 0 231 0 244 1 137 0 248 0 249 0 250 0 251 0 252 0 255 1 14 1 19 1 28 1 29 1 30 1 32 1 59 1 60 1 61 1 63 1 185 1 91 1 97 1 98 1 99 1 100 1 101 6 215 1 114 1 145 1 146 1 147 1 149 1 173 1 186 1 175 0 59 0 253 0 60 0 254 0 75 1 13 0 82 1 20 0 83 1 21 0 85 1 23 0 84 1 22 0 86 1 24 0 89 1 27 0 95 1 33 0 96 1 34 0 97 1 35 0 106 1 44 0 93 1 31 0 109 1 47 0 110 1 48 0 111 1 49 0 112 1 50 0 117 1 54 0 120 1 58 0 124 1 62 0 126 1 64 0 132 1 70 0 131 1 68 0 127 1 71 0 247 1 189 0 133 1 72 0 134 1 73 1 76 0 137 1 77 0 139 1 80 0 138 1 78 0 140 1 79 0 144 1 84 0 148 1 88 0 152 1 92 0 150 1 90 1 96 0 246 1 187 0 161 1 102 0 171 1 112 0 162 1 103 0 174 1 115 0 182 1 123 0 185 1 124 0 183 1 125 0 189 1 130 0 190 1 131 0 192 1 133 0 191 1 132 0 198 1 139 0 197 1 138 0 202 1 144 0 206 1 148 0 208 1 150 0 209 1 151 0 210 1 152 0 211 1 153 0 219 1 161 0 228 1 170 0 232 1 174 0 233 0 238 1 180 0 240 1 182 0 239 1 181 6 172 0 116 0 175 1 116 0 220 1 162 0 62 1 0 0 128 1 65 0 163 1 104 0 212 1 154 0 213 1 155 0 214 1 156 0 215 1 157 0 216 1 158 0 78 1 16 0 113 1 51 0 181 1 122 0 108 1 46 0 149 1 89 0 77 1 15 0 193 1 134 0 199 1 140 1 190 1 198 1 204 1 205 1 206 1 207 1 208 1 209 1 210 1 211 1 212 1 213 1 215 2 1 1 199 1 214 1 217 6 132 6 140 6 145 6 147 7 7 7 24 7 27 7 25 7 29 7 21 7 26 6 152 6 153 6 134 6 141 6 146 7 31 7 34 7 37 7 39 7 41 7 43 7 45 7 49 7 51 7 53 7 55 7 57 7 59 7 64 7 66 7 68 7 79 7 80 7 81 7 82 7 84 7 86 7 88 7 89 3 106 3 108 2 87 3 102 2 88 2 89 2 90 2 93 2 95 2 133 2 80 2 81 2 82 2 83 2 84 2 85 2 86 2 91 2 94 2 124 2 125 2 126 2 127 2 134 2 96 2 97 2 98 2 99 2 100 2 101 2 102 2 103 2 104 2 105 2 106 2 107 2 108 2 109 2 110 2 111 2 112 2 120 2 113 2 114 2 115 2 116 2 117 2 118 2 119 2 128 2 131 2 129 2 130 2 132 3 191 4 25 3 192 4 26 3 193 4 27 3 194 4 28 3 195 4 29 3 196 4 30 3 199 4 33 3 200 4 34 3 203 4 37 3 206 4 40 3 207 4 41 3 208 4 42 3 209 4 43 3 210 4 44 3 211 4 45 3 212 4 46 3 213 3 214 4 47 4 50 3 217 4 51 3 218 4 52 3 219 4 53 3 220 4 54 3 221 4 55 3 222 4 56 3 223 4 57 3 224 4 58 3 225 4 59 6 124 6 126 6 127 6 133 6 135 6 138 6 142 6 143 0 80 1 18 0 87 1 25 0 88 1 26 0 107 1 45 0 114 1 52 0 118 1 55 0 119 1 57 0 135 1 74 0 136 1 75 0 141 1 81 0 142 1 82 0 143 1 83 0 145 1 85 0 146 1 86 0 147 1 87 0 153 1 93 0 154 1 94 0 155 1 95 0 172 1 113 0 184 1 126 0 186 1 127 0 187 1 128 0 188 1 129 0 194 1 135 0 195 1 136 0 200 1 141 0 201 1 142 0 226 1 168 0 227 1 169 0 229 1 171 0 234 1 176 0 241 1 183 0 242 1 184 1 56 1 143 0 63 1 1 0 64 1 2 0 65 1 3 0 66 1 4 0 67 1 5 0 68 1 6 0 69 1 7 0 70 1 8 0 71 1 9 0 72 1 10 0 73 1 11 0 74 1 12 0 98 1 36 0 99 1 37 0 100 1 38 0 101 1 39 0 102 1 40 0 103 1 41 0 104 1 42 0 105 1 43 0 129 1 66 0 130 1 67 0 164 1 105 0 165 1 106 0 166 1 107 0 167 1 108 0 168 1 109 0 169 1 110 0 170 1 111 0 176 1 117 0 177 1 118 0 178 1 119 0 179 1 120 0 180 1 121 0 217 1 159 0 218 1 160 0 221 1 163 0 222 1 164 0 223 1 165 0 224 1 166 0 225 1 167 0 230 1 172 0 235 1 177 0 236 1 178 0 237 1 179 2 235 2 236 2 237 2 238 2 239 2 240 2 135 2 136 2 139 2 140 2 141 2 142 2 143 2 144 2 244 2 245 3 0 3 1 3 2 3 3 3 4 3 5 2 155 2 156 2 159 2 160 2 161 2 162 2 163 2 164 3 7 3 8 3 11 3 12 3 13 3 14 3 15 3 16 2 165 2 166 2 169 2 170 2 171 2 172 2 173 2 174 3 23 3 24 2 191 3 49 3 50 3 53 3 54 3 55 3 56 3 57 3 58 2 194 2 195 2 198 2 199 2 200 2 201 2 202 2 203 2 233 2 234 2 246 2 247 2 254 2 255 3 9 3 10 3 25 3 26 3 35 3 36 3 51 3 52 2 205 2 206 2 207 2 208 2 209 2 210 2 211 2 212 3 73 3 74 2 214 2 215 2 216 2 217 2 218 2 219 2 220 2 221 3 85 3 86 2 223 2 224 2 225 2 226 2 227 2 228 2 229 2 230 2 241 2 242 3 63 3 60 3 64 2 243 3 71 2 145 2 146 2 137 2 138 2 204 3 111 3 110 3 112 3 122 3 125 3 75 3 72 3 76 3 6 3 83 2 149 2 150 2 157 2 158 2 213 3 116 3 118 3 120 3 17 3 18 3 20 3 21 3 19 3 22 2 175 2 176 2 167 2 168 3 117 3 119 3 121 3 44 3 45 3 46 3 47 3 31 3 32 3 43 3 48 2 192 2 193 2 187 2 188 2 185 3 123 3 124 3 114 3 87 3 84 3 88 3 59 3 95 2 179 2 180 2 196 2 197 2 222 3 115 3 113 4 144 4 140 4 141 4 145 4 166 4 128 4 129 4 132 4 130 4 131 4 133 4 162 4 163 4 147 7 146 6 192 4 167 4 171 4 149 4 150 4 168 4 170 4 169 6 38 6 131 6 48 6 49 6 136 6 178 6 170 6 186 6 183 6 184 4 61 4 183 6 204 6 209 6 210 6 235 6 213 6 216 6 232 6 245 7 3 2 2 7 148 7 149 2 3 2 4 7 147 0 12 0 0 0 0 37 132 0 0 0 0 0 0 3 31 0 0 0 32 0 0 0 32 0 0 0 1 0 0 0 33 0 0 0 33 0 0 4 122 0 0 0 34 0 0 0 34 0 0 4 127 0 0 0 35 0 0 0 35 0 0 4 191 0 0 0 36 0 0 0 36 0 0 6 166 0 0 0 37 0 0 0 37 0 0 6 191 0 0 0 38 0 0 0 38 0 0 4 62 0 0 0 39 0 0 0 39 0 0 4 126 0 0 0 40 0 0 0 41 0 0 4 151 0 0 0 42 0 0 0 42 0 0 4 161 0 0 0 43 0 0 0 43 0 0 6 212 0 0 0 44 0 0 0 44 0 0 4 118 0 0 0 45 0 0 0 45 0 0 4 138 0 0 0 46 0 0 0 46 0 0 4 117 0 0 0 47 0 0 0 47 0 0 4 157 0 0 0 48 0 0 0 57 0 0 4 63 0 0 0 58 0 0 0 59 0 0 4 119 0 0 0 60 0 0 0 60 0 0 6 218 0 0 0 61 0 0 0 61 0 0 6 217 0 0 0 62 0 0 0 62 0 0 6 219 0 0 0 63 0 0 0 63 0 0 4 124 0 0 0 64 0 0 0 64 0 0 4 189 0 0 0 65 0 0 0 90 0 0 0 2 0 0 0 91 0 0 0 91 0 0 4 153 0 0 0 92 0 0 0 92 0 0 4 159 0 0 0 93 0 0 0 93 0 0 4 154 0 0 0 94 0 0 0 94 0 0 6 223 0 0 0 95 0 0 0 95 0 0 4 148 0 0 0 96 0 0 0 96 0 0 7 12 0 0 0 97 0 0 0 122 0 0 0 28 0 0 0 123 0 0 0 123 0 0 4 155 0 0 0 124 0 0 0 124 0 0 4 158 0 0 0 125 0 0 0 125 0 0 4 156 0 0 0 126 0 0 0 126 0 0 6 225 0 0 0 160 0 0 0 160 0 0 7 142 0 0 0 161 0 0 0 161 0 0 4 123 0 0 0 162 0 0 0 162 0 0 6 171 0 0 0 163 0 0 0 163 0 0 6 167 0 0 0 164 0 0 0 164 0 0 6 165 0 0 0 165 0 0 0 165 0 0 6 168 0 0 0 166 0 0 0 166 0 0 4 160 0 0 0 167 0 0 0 167 0 0 4 164 0 0 0 168 0 0 0 168 0 0 7 22 0 0 0 169 0 0 0 169 0 0 4 182 0 0 0 170 0 0 0 170 0 0 6 94 0 0 0 171 0 0 0 171 0 0 4 136 0 0 0 172 0 0 0 172 0 0 6 227 0 0 0 173 0 0 0 173 0 0 4 139 0 0 0 174 0 0 0 174 0 0 4 184 0 0 0 175 0 0 0 175 0 0 7 23 0 0 0 176 0 0 0 176 0 0 6 164 0 0 0 177 0 0 0 177 0 0 6 222 0 0 0 178 0 0 0 179 0 0 6 40 0 0 0 180 0 0 0 180 0 0 7 13 0 0 0 181 0 0 0 181 0 0 6 229 0 0 0 182 0 0 0 182 0 0 4 165 0 0 0 183 0 0 0 183 0 0 4 146 0 0 0 184 0 0 0 184 0 0 7 28 0 0 0 185 0 0 0 185 0 0 6 39 0 0 0 186 0 0 0 186 0 0 6 96 0 0 0 187 0 0 0 187 0 0 4 137 0 0 0 188 0 0 0 190 0 0 6 193 0 0 0 191 0 0 0 191 0 0 4 125 0 0 0 192 0 0 0 196 0 0 0 54 0 0 0 197 0 0 0 197 0 0 0 61 0 0 0 198 0 0 0 198 0 0 0 76 0 0 0 199 0 0 0 199 0 0 0 81 0 0 0 200 0 0 0 202 0 0 0 90 0 0 0 203 0 0 0 203 0 0 0 94 0 0 0 204 0 0 0 206 0 0 0 121 0 0 0 207 0 0 0 207 0 0 0 125 0 0 0 208 0 0 0 208 0 0 0 243 0 0 0 209 0 0 0 209 0 0 0 151 0 0 0 210 0 0 0 214 0 0 0 156 0 0 0 215 0 0 0 215 0 0 6 214 0 0 0 216 0 0 0 216 0 0 0 173 0 0 0 217 0 0 0 219 0 0 0 203 0 0 0 220 0 0 0 220 0 0 0 207 0 0 0 221 0 0 0 221 0 0 0 231 0 0 0 222 0 0 0 222 0 0 0 244 0 0 0 223 0 0 0 223 0 0 1 137 0 0 0 224 0 0 0 228 0 0 0 248 0 0 0 229 0 0 0 229 0 0 0 255 0 0 0 230 0 0 0 230 0 0 1 14 0 0 0 231 0 0 0 231 0 0 1 19 0 0 0 232 0 0 0 234 0 0 1 28 0 0 0 235 0 0 0 235 0 0 1 32 0 0 0 236 0 0 0 238 0 0 1 59 0 0 0 239 0 0 0 239 0 0 1 63 0 0 0 240 0 0 0 240 0 0 1 185 0 0 0 241 0 0 0 241 0 0 1 91 0 0 0 242 0 0 0 246 0 0 1 97 0 0 0 247 0 0 0 247 0 0 6 215 0 0 0 248 0 0 0 248 0 0 1 114 0 0 0 249 0 0 0 251 0 0 1 145 0 0 0 252 0 0 0 252 0 0 1 149 0 0 0 253 0 0 0 253 0 0 1 173 0 0 0 254 0 0 0 254 0 0 1 186 0 0 0 255 0 0 0 255 0 0 1 175 0 0 1 0 0 0 1 0 0 0 0 59 0 0 1 1 0 0 1 1 0 0 0 253 0 0 1 2 0 0 1 2 0 0 0 60 0 0 1 3 0 0 1 3 0 0 0 254 0 0 1 4 0 0 1 4 0 0 0 75 0 0 1 5 0 0 1 5 0 0 1 13 0 0 1 6 0 0 1 6 0 0 0 82 0 0 1 7 0 0 1 7 0 0 1 20 0 0 1 8 0 0 1 8 0 0 0 83 0 0 1 9 0 0 1 9 0 0 1 21 0 0 1 10 0 0 1 10 0 0 0 85 0 0 1 11 0 0 1 11 0 0 1 23 0 0 1 12 0 0 1 12 0 0 0 84 0 0 1 13 0 0 1 13 0 0 1 22 0 0 1 14 0 0 1 14 0 0 0 86 0 0 1 15 0 0 1 15 0 0 1 24 0 0 1 16 0 0 1 16 0 0 0 89 0 0 1 17 0 0 1 17 0 0 1 27 0 0 1 18 0 0 1 18 0 0 0 95 0 0 1 19 0 0 1 19 0 0 1 33 0 0 1 20 0 0 1 20 0 0 0 96 0 0 1 21 0 0 1 21 0 0 1 34 0 0 1 22 0 0 1 22 0 0 0 97 0 0 1 23 0 0 1 23 0 0 1 35 0 0 1 24 0 0 1 24 0 0 0 106 0 0 1 25 0 0 1 25 0 0 1 44 0 0 1 26 0 0 1 26 0 0 0 93 0 0 1 27 0 0 1 27 0 0 1 31 0 0 1 28 0 0 1 28 0 0 0 109 0 0 1 29 0 0 1 29 0 0 1 47 0 0 1 30 0 0 1 30 0 0 0 110 0 0 1 31 0 0 1 31 0 0 1 48 0 0 1 32 0 0 1 32 0 0 0 111 0 0 1 33 0 0 1 33 0 0 1 49 0 0 1 34 0 0 1 34 0 0 0 112 0 0 1 35 0 0 1 35 0 0 1 50 0 0 1 36 0 0 1 36 0 0 0 117 0 0 1 37 0 0 1 37 0 0 1 54 0 0 1 38 0 0 1 38 0 0 0 120 0 0 1 39 0 0 1 39 0 0 1 58 0 0 1 40 0 0 1 40 0 0 0 124 0 0 1 41 0 0 1 41 0 0 1 62 0 0 1 42 0 0 1 42 0 0 0 126 0 0 1 43 0 0 1 43 0 0 1 64 0 0 1 44 0 0 1 44 0 0 0 132 0 0 1 45 0 0 1 45 0 0 1 70 0 0 1 46 0 0 1 46 0 0 0 131 0 0 1 47 0 0 1 47 0 0 1 68 0 0 1 48 0 0 1 48 0 0 0 127 0 0 1 49 0 0 1 49 0 0 1 71 0 0 1 50 0 0 1 50 0 0 0 247 0 0 1 51 0 0 1 51 0 0 1 189 0 0 1 52 0 0 1 52 0 0 0 133 0 0 1 53 0 0 1 53 0 0 1 72 0 0 1 54 0 0 1 54 0 0 0 134 0 0 1 55 0 0 1 55 0 0 1 73 0 0 1 56 0 0 1 56 0 0 1 76 0 0 1 57 0 0 1 57 0 0 0 137 0 0 1 58 0 0 1 58 0 0 1 77 0 0 1 59 0 0 1 59 0 0 0 139 0 0 1 60 0 0 1 60 0 0 1 80 0 0 1 61 0 0 1 61 0 0 0 138 0 0 1 62 0 0 1 62 0 0 1 78 0 0 1 63 0 0 1 63 0 0 0 140 0 0 1 64 0 0 1 64 0 0 1 79 0 0 1 65 0 0 1 65 0 0 0 144 0 0 1 66 0 0 1 66 0 0 1 84 0 0 1 67 0 0 1 67 0 0 0 148 0 0 1 68 0 0 1 68 0 0 1 88 0 0 1 69 0 0 1 69 0 0 0 152 0 0 1 70 0 0 1 70 0 0 1 92 0 0 1 71 0 0 1 71 0 0 0 150 0 0 1 72 0 0 1 72 0 0 1 90 0 0 1 73 0 0 1 73 0 0 1 96 0 0 1 74 0 0 1 74 0 0 0 246 0 0 1 75 0 0 1 75 0 0 1 187 0 0 1 76 0 0 1 76 0 0 0 161 0 0 1 77 0 0 1 77 0 0 1 102 0 0 1 78 0 0 1 78 0 0 0 171 0 0 1 79 0 0 1 79 0 0 1 112 0 0 1 80 0 0 1 80 0 0 0 162 0 0 1 81 0 0 1 81 0 0 1 103 0 0 1 82 0 0 1 82 0 0 0 174 0 0 1 83 0 0 1 83 0 0 1 115 0 0 1 84 0 0 1 84 0 0 0 182 0 0 1 85 0 0 1 85 0 0 1 123 0 0 1 86 0 0 1 86 0 0 0 185 0 0 1 87 0 0 1 87 0 0 1 124 0 0 1 88 0 0 1 88 0 0 0 183 0 0 1 89 0 0 1 89 0 0 1 125 0 0 1 90 0 0 1 90 0 0 0 189 0 0 1 91 0 0 1 91 0 0 1 130 0 0 1 92 0 0 1 92 0 0 0 190 0 0 1 93 0 0 1 93 0 0 1 131 0 0 1 94 0 0 1 94 0 0 0 192 0 0 1 95 0 0 1 95 0 0 1 133 0 0 1 96 0 0 1 96 0 0 0 191 0 0 1 97 0 0 1 97 0 0 1 132 0 0 1 98 0 0 1 98 0 0 0 198 0 0 1 99 0 0 1 99 0 0 1 139 0 0 1 100 0 0 1 100 0 0 0 197 0 0 1 101 0 0 1 101 0 0 1 138 0 0 1 102 0 0 1 102 0 0 0 202 0 0 1 103 0 0 1 103 0 0 1 144 0 0 1 104 0 0 1 104 0 0 0 206 0 0 1 105 0 0 1 105 0 0 1 148 0 0 1 106 0 0 1 106 0 0 0 208 0 0 1 107 0 0 1 107 0 0 1 150 0 0 1 108 0 0 1 108 0 0 0 209 0 0 1 109 0 0 1 109 0 0 1 151 0 0 1 110 0 0 1 110 0 0 0 210 0 0 1 111 0 0 1 111 0 0 1 152 0 0 1 112 0 0 1 112 0 0 0 211 0 0 1 113 0 0 1 113 0 0 1 153 0 0 1 114 0 0 1 114 0 0 0 219 0 0 1 115 0 0 1 115 0 0 1 161 0 0 1 116 0 0 1 116 0 0 0 228 0 0 1 117 0 0 1 117 0 0 1 170 0 0 1 118 0 0 1 118 0 0 0 232 0 0 1 119 0 0 1 119 0 0 1 174 0 0 1 120 0 0 1 120 0 0 0 233 0 0 1 121 0 0 1 121 0 0 0 238 0 0 1 122 0 0 1 122 0 0 1 180 0 0 1 123 0 0 1 123 0 0 0 240 0 0 1 124 0 0 1 124 0 0 1 182 0 0 1 125 0 0 1 125 0 0 0 239 0 0 1 126 0 0 1 126 0 0 1 181 0 0 1 128 0 0 1 128 0 0 1 17 0 0 1 143 0 0 1 143 0 0 0 245 0 0 1 146 0 0 1 146 0 0 6 172 0 0 1 147 0 0 1 147 0 0 0 116 0 0 1 160 0 0 1 160 0 0 0 175 0 0 1 161 0 0 1 161 0 0 1 116 0 0 1 175 0 0 1 175 0 0 0 220 0 0 1 176 0 0 1 176 0 0 1 162 0 0 1 194 0 0 1 194 0 0 2 0 0 0 1 205 0 0 1 205 0 0 0 62 0 0 1 206 0 0 1 206 0 0 1 0 0 0 1 207 0 0 1 207 0 0 0 128 0 0 1 208 0 0 1 208 0 0 1 65 0 0 1 209 0 0 1 209 0 0 0 163 0 0 1 210 0 0 1 210 0 0 1 104 0 0 1 211 0 0 1 211 0 0 0 212 0 0 1 212 0 0 1 212 0 0 1 154 0 0 1 213 0 0 1 213 0 0 0 213 0 0 1 214 0 0 1 214 0 0 1 155 0 0 1 215 0 0 1 215 0 0 0 214 0 0 1 216 0 0 1 216 0 0 1 156 0 0 1 217 0 0 1 217 0 0 0 215 0 0 1 218 0 0 1 218 0 0 1 157 0 0 1 219 0 0 1 219 0 0 0 216 0 0 1 220 0 0 1 220 0 0 1 158 0 0 1 226 0 0 1 226 0 0 0 78 0 0 1 227 0 0 1 227 0 0 1 16 0 0 1 230 0 0 1 230 0 0 0 113 0 0 1 231 0 0 1 231 0 0 1 51 0 0 1 234 0 0 1 234 0 0 0 181 0 0 1 235 0 0 1 235 0 0 1 122 0 0 1 244 0 0 1 244 0 0 0 108 0 0 1 245 0 0 1 245 0 0 1 46 0 0 1 248 0 0 1 248 0 0 0 149 0 0 1 249 0 0 1 249 0 0 1 89 0 0 1 252 0 0 1 252 0 0 0 77 0 0 1 253 0 0 1 253 0 0 1 15 0 0 2 24 0 0 2 24 0 0 0 193 0 0 2 25 0 0 2 25 0 0 1 134 0 0 2 26 0 0 2 26 0 0 0 199 0 0 2 27 0 0 2 27 0 0 1 140 0 0 2 55 0 0 2 55 0 0 1 188 0 0 2 67 0 0 2 67 0 0 0 79 0 0 2 80 0 0 2 80 0 0 1 190 0 0 2 81 0 0 2 81 0 0 1 198 0 0 2 82 0 0 2 88 0 0 1 191 0 0 2 89 0 0 2 92 0 0 1 200 0 0 2 94 0 0 2 103 0 0 1 204 0 0 2 104 0 0 2 104 0 0 1 215 0 0 2 106 0 0 2 106 0 0 1 216 0 0 2 108 0 0 2 110 0 0 1 218 0 0 2 111 0 0 2 118 0 0 1 222 0 0 2 120 0 0 2 123 0 0 1 230 0 0 2 125 0 0 2 126 0 0 1 234 0 0 2 128 0 0 2 132 0 0 1 236 0 0 2 136 0 0 2 146 0 0 1 241 0 0 2 148 0 0 2 149 0 0 1 252 0 0 2 152 0 0 2 152 0 0 2 1 0 0 2 153 0 0 2 153 0 0 1 199 0 0 2 156 0 0 2 156 0 0 1 214 0 0 2 157 0 0 2 157 0 0 1 217 0 0 2 159 0 0 2 159 0 0 1 221 0 0 2 161 0 0 2 162 0 0 1 254 0 0 2 176 0 0 2 176 0 0 6 130 0 0 2 178 0 0 2 178 0 0 6 132 0 0 2 179 0 0 2 179 0 0 6 140 0 0 2 183 0 0 2 183 0 0 6 145 0 0 2 184 0 0 2 184 0 0 6 147 0 0 2 185 0 0 2 185 0 0 7 7 0 0 2 187 0 0 2 188 0 0 7 8 0 0 2 190 0 0 2 191 0 0 7 10 0 0 2 193 0 0 2 193 0 0 6 149 0 0 2 198 0 0 2 204 0 0 7 14 0 0 2 208 0 0 2 209 0 0 6 150 0 0 2 216 0 0 2 216 0 0 7 24 0 0 2 217 0 0 2 217 0 0 7 27 0 0 2 218 0 0 2 218 0 0 7 25 0 0 2 219 0 0 2 219 0 0 7 29 0 0 2 220 0 0 2 220 0 0 7 21 0 0 2 221 0 0 2 221 0 0 7 26 0 0 2 222 0 0 2 222 0 0 6 152 0 0 2 224 0 0 2 224 0 0 6 153 0 0 2 225 0 0 2 225 0 0 6 134 0 0 2 226 0 0 2 226 0 0 6 141 0 0 2 227 0 0 2 227 0 0 6 146 0 0 3 0 0 0 3 0 0 0 7 31 0 0 3 1 0 0 3 1 0 0 7 34 0 0 3 2 0 0 3 2 0 0 7 37 0 0 3 3 0 0 3 3 0 0 7 39 0 0 3 4 0 0 3 4 0 0 7 41 0 0 3 5 0 0 3 5 0 0 7 43 0 0 3 6 0 0 3 6 0 0 7 45 0 0 3 7 0 0 3 7 0 0 7 49 0 0 3 8 0 0 3 8 0 0 7 51 0 0 3 9 0 0 3 9 0 0 7 53 0 0 3 10 0 0 3 10 0 0 7 55 0 0 3 11 0 0 3 11 0 0 7 57 0 0 3 12 0 0 3 12 0 0 7 59 0 0 3 15 0 0 3 15 0 0 7 62 0 0 3 17 0 0 3 17 0 0 7 64 0 0 3 18 0 0 3 18 0 0 7 66 0 0 3 19 0 0 3 19 0 0 7 68 0 0 3 24 0 0 3 32 0 0 7 70 0 0 3 35 0 0 3 38 0 0 7 79 0 0 3 39 0 0 3 39 0 0 7 84 0 0 3 40 0 0 3 40 0 0 7 86 0 0 3 41 0 0 3 42 0 0 7 88 0 0 3 44 0 0 3 44 0 0 7 90 0 0 3 46 0 0 3 49 0 0 7 91 0 0 3 52 0 0 3 52 0 0 7 95 0 0 3 57 0 0 3 61 0 0 7 96 0 0 3 66 0 0 3 66 0 0 7 101 0 0 3 69 0 0 3 69 0 0 7 103 0 0 3 97 0 0 3 97 0 0 7 104 0 0 3 116 0 0 3 117 0 0 3 104 0 0 3 122 0 0 3 122 0 0 3 109 0 0 3 126 0 0 3 126 0 0 3 101 0 0 3 132 0 0 3 132 0 0 3 106 0 0 3 133 0 0 3 133 0 0 3 108 0 0 3 134 0 0 3 134 0 0 2 87 0 0 3 135 0 0 3 135 0 0 3 102 0 0 3 136 0 0 3 138 0 0 2 88 0 0 3 140 0 0 3 140 0 0 2 92 0 0 3 142 0 0 3 142 0 0 2 93 0 0 3 143 0 0 3 143 0 0 2 95 0 0 3 144 0 0 3 144 0 0 2 133 0 0 3 145 0 0 3 161 0 0 2 63 0 0 3 163 0 0 3 169 0 0 2 80 0 0 3 170 0 0 3 170 0 0 2 91 0 0 3 171 0 0 3 171 0 0 2 94 0 0 3 172 0 0 3 175 0 0 2 124 0 0 3 176 0 0 3 176 0 0 2 134 0 0 3 177 0 0 3 193 0 0 2 96 0 0 3 194 0 0 3 194 0 0 2 120 0 0 3 195 0 0 3 201 0 0 2 113 0 0 3 202 0 0 3 202 0 0 2 128 0 0 3 203 0 0 3 203 0 0 2 131 0 0 3 204 0 0 3 205 0 0 2 129 0 0 3 206 0 0 3 206 0 0 2 132 0 0 3 208 0 0 3 209 0 0 2 121 0 0 3 213 0 0 3 213 0 0 2 123 0 0 3 215 0 0 3 215 0 0 3 96 0 0 3 217 0 0 3 217 0 0 3 97 0 0 3 219 0 0 3 219 0 0 3 98 0 0 3 221 0 0 3 221 0 0 3 99 0 0 3 225 0 0 3 225 0 0 3 100 0 0 4 0 0 0 4 7 0 0 3 172 0 0 4 8 0 0 4 12 0 0 3 181 0 0 4 13 0 0 4 15 0 0 3 188 0 0 4 16 0 0 4 22 0 0 3 136 0 0 4 23 0 0 4 26 0 0 3 145 0 0 4 27 0 0 4 47 0 0 3 151 0 0 4 48 0 0 4 54 0 0 3 226 0 0 4 55 0 0 4 58 0 0 3 235 0 0 4 59 0 0 4 87 0 0 3 241 0 0 4 88 0 0 4 92 0 0 4 15 0 0 4 93 0 0 4 95 0 0 4 22 0 0 4 98 0 0 4 98 0 0 3 191 0 0 4 99 0 0 4 99 0 0 4 25 0 0 4 114 0 0 4 114 0 0 3 192 0 0 4 115 0 0 4 115 0 0 4 26 0 0 4 116 0 0 4 116 0 0 3 193 0 0 4 117 0 0 4 117 0 0 4 27 0 0 4 144 0 0 4 144 0 0 3 194 0 0 4 145 0 0 4 145 0 0 4 28 0 0 4 146 0 0 4 146 0 0 3 195 0 0 4 147 0 0 4 147 0 0 4 29 0 0 4 150 0 0 4 150 0 0 3 196 0 0 4 151 0 0 4 151 0 0 4 30 0 0 4 152 0 0 4 152 0 0 3 199 0 0 4 153 0 0 4 153 0 0 4 33 0 0 4 154 0 0 4 154 0 0 3 200 0 0 4 155 0 0 4 155 0 0 4 34 0 0 4 160 0 0 4 160 0 0 3 203 0 0 4 161 0 0 4 161 0 0 4 37 0 0 4 162 0 0 4 162 0 0 3 206 0 0 4 163 0 0 4 163 0 0 4 40 0 0 4 170 0 0 4 170 0 0 3 207 0 0 4 171 0 0 4 171 0 0 4 41 0 0 4 174 0 0 4 174 0 0 3 208 0 0 4 175 0 0 4 175 0 0 4 42 0 0 4 176 0 0 4 176 0 0 3 209 0 0 4 177 0 0 4 177 0 0 4 43 0 0 4 178 0 0 4 178 0 0 3 210 0 0 4 179 0 0 4 179 0 0 4 44 0 0 4 182 0 0 4 182 0 0 3 211 0 0 4 183 0 0 4 183 0 0 4 45 0 0 4 186 0 0 4 186 0 0 3 212 0 0 4 187 0 0 4 187 0 0 4 46 0 0 4 192 0 0 4 193 0 0 3 213 0 0 4 194 0 0 4 194 0 0 4 47 0 0 4 207 0 0 4 207 0 0 4 50 0 0 4 208 0 0 4 208 0 0 3 217 0 0 4 209 0 0 4 209 0 0 4 51 0 0 4 212 0 0 4 212 0 0 3 218 0 0 4 213 0 0 4 213 0 0 4 52 0 0 4 214 0 0 4 214 0 0 3 219 0 0 4 215 0 0 4 215 0 0 4 53 0 0 4 216 0 0 4 216 0 0 3 220 0 0 4 217 0 0 4 217 0 0 4 54 0 0 4 226 0 0 4 226 0 0 3 221 0 0 4 227 0 0 4 227 0 0 4 55 0 0 4 230 0 0 4 230 0 0 3 222 0 0 4 231 0 0 4 231 0 0 4 56 0 0 4 232 0 0 4 232 0 0 3 223 0 0 4 233 0 0 4 233 0 0 4 57 0 0 4 238 0 0 4 238 0 0 3 224 0 0 4 239 0 0 4 239 0 0 4 58 0 0 4 242 0 0 4 242 0 0 3 225 0 0 4 243 0 0 4 243 0 0 4 59 0 0 29 67 0 0 29 67 0 0 6 123 0 0 29 71 0 0 29 71 0 0 6 124 0 0 29 72 0 0 29 73 0 0 6 126 0 0 29 77 0 0 29 77 0 0 6 129 0 0 29 79 0 0 29 79 0 0 6 133 0 0 29 80 0 0 29 80 0 0 6 135 0 0 29 82 0 0 29 82 0 0 6 137 0 0 29 86 0 0 29 86 0 0 6 138 0 0 29 87 0 0 29 88 0 0 6 142 0 0 29 91 0 0 29 91 0 0 6 144 0 0 29 156 0 0 29 156 0 0 6 125 0 0 29 160 0 0 29 160 0 0 6 128 0 0 29 187 0 0 29 187 0 0 6 148 0 0 30 6 0 0 30 6 0 0 0 80 0 0 30 7 0 0 30 7 0 0 1 18 0 0 30 12 0 0 30 12 0 0 0 87 0 0 30 13 0 0 30 13 0 0 1 25 0 0 30 14 0 0 30 14 0 0 0 88 0 0 30 15 0 0 30 15 0 0 1 26 0 0 30 22 0 0 30 22 0 0 0 107 0 0 30 23 0 0 30 23 0 0 1 45 0 0 30 32 0 0 30 32 0 0 0 114 0 0 30 33 0 0 30 33 0 0 1 52 0 0 30 36 0 0 30 36 0 0 0 118 0 0 30 37 0 0 30 37 0 0 1 55 0 0 30 42 0 0 30 42 0 0 0 119 0 0 30 43 0 0 30 43 0 0 1 57 0 0 30 50 0 0 30 50 0 0 0 135 0 0 30 51 0 0 30 51 0 0 1 74 0 0 30 52 0 0 30 52 0 0 0 136 0 0 30 53 0 0 30 53 0 0 1 75 0 0 30 54 0 0 30 54 0 0 0 141 0 0 30 55 0 0 30 55 0 0 1 81 0 0 30 56 0 0 30 56 0 0 0 142 0 0 30 57 0 0 30 57 0 0 1 82 0 0 30 58 0 0 30 58 0 0 0 143 0 0 30 59 0 0 30 59 0 0 1 83 0 0 30 62 0 0 30 62 0 0 0 145 0 0 30 63 0 0 30 63 0 0 1 85 0 0 30 64 0 0 30 64 0 0 0 146 0 0 30 65 0 0 30 65 0 0 1 86 0 0 30 66 0 0 30 66 0 0 0 147 0 0 30 67 0 0 30 67 0 0 1 87 0 0 30 68 0 0 30 68 0 0 0 153 0 0 30 69 0 0 30 69 0 0 1 93 0 0 30 70 0 0 30 70 0 0 0 154 0 0 30 71 0 0 30 71 0 0 1 94 0 0 30 72 0 0 30 72 0 0 0 155 0 0 30 73 0 0 30 73 0 0 1 95 0 0 30 82 0 0 30 82 0 0 0 172 0 0 30 83 0 0 30 83 0 0 1 113 0 0 30 88 0 0 30 88 0 0 0 184 0 0 30 89 0 0 30 89 0 0 1 126 0 0 30 90 0 0 30 90 0 0 0 186 0 0 30 91 0 0 30 91 0 0 1 127 0 0 30 92 0 0 30 92 0 0 0 187 0 0 30 93 0 0 30 93 0 0 1 128 0 0 30 94 0 0 30 94 0 0 0 188 0 0 30 95 0 0 30 95 0 0 1 129 0 0 30 96 0 0 30 96 0 0 0 194 0 0 30 97 0 0 30 97 0 0 1 135 0 0 30 98 0 0 30 98 0 0 0 195 0 0 30 99 0 0 30 99 0 0 1 136 0 0 30 108 0 0 30 108 0 0 0 200 0 0 30 109 0 0 30 109 0 0 1 141 0 0 30 110 0 0 30 110 0 0 0 201 0 0 30 111 0 0 30 111 0 0 1 142 0 0 30 128 0 0 30 128 0 0 0 226 0 0 30 129 0 0 30 129 0 0 1 168 0 0 30 130 0 0 30 130 0 0 0 227 0 0 30 131 0 0 30 131 0 0 1 169 0 0 30 132 0 0 30 132 0 0 0 229 0 0 30 133 0 0 30 133 0 0 1 171 0 0 30 142 0 0 30 142 0 0 0 234 0 0 30 143 0 0 30 143 0 0 1 176 0 0 30 146 0 0 30 146 0 0 0 241 0 0 30 147 0 0 30 147 0 0 1 183 0 0 30 148 0 0 30 148 0 0 0 242 0 0 30 149 0 0 30 149 0 0 1 184 0 0 30 150 0 0 30 150 0 0 1 56 0 0 30 151 0 0 30 151 0 0 1 143 0 0 30 158 0 0 30 158 0 0 0 196 0 0 30 160 0 0 30 160 0 0 0 63 0 0 30 161 0 0 30 161 0 0 1 1 0 0 30 162 0 0 30 162 0 0 0 64 0 0 30 163 0 0 30 163 0 0 1 2 0 0 30 164 0 0 30 164 0 0 0 65 0 0 30 165 0 0 30 165 0 0 1 3 0 0 30 166 0 0 30 166 0 0 0 66 0 0 30 167 0 0 30 167 0 0 1 4 0 0 30 168 0 0 30 168 0 0 0 67 0 0 30 169 0 0 30 169 0 0 1 5 0 0 30 170 0 0 30 170 0 0 0 68 0 0 30 171 0 0 30 171 0 0 1 6 0 0 30 172 0 0 30 172 0 0 0 69 0 0 30 173 0 0 30 173 0 0 1 7 0 0 30 174 0 0 30 174 0 0 0 70 0 0 30 175 0 0 30 175 0 0 1 8 0 0 30 176 0 0 30 176 0 0 0 71 0 0 30 177 0 0 30 177 0 0 1 9 0 0 30 178 0 0 30 178 0 0 0 72 0 0 30 179 0 0 30 179 0 0 1 10 0 0 30 180 0 0 30 180 0 0 0 73 0 0 30 181 0 0 30 181 0 0 1 11 0 0 30 182 0 0 30 182 0 0 0 74 0 0 30 183 0 0 30 183 0 0 1 12 0 0 30 184 0 0 30 184 0 0 0 98 0 0 30 185 0 0 30 185 0 0 1 36 0 0 30 186 0 0 30 186 0 0 0 99 0 0 30 187 0 0 30 187 0 0 1 37 0 0 30 188 0 0 30 188 0 0 0 100 0 0 30 189 0 0 30 189 0 0 1 38 0 0 30 190 0 0 30 190 0 0 0 101 0 0 30 191 0 0 30 191 0 0 1 39 0 0 30 192 0 0 30 192 0 0 0 102 0 0 30 193 0 0 30 193 0 0 1 40 0 0 30 194 0 0 30 194 0 0 0 103 0 0 30 195 0 0 30 195 0 0 1 41 0 0 30 196 0 0 30 196 0 0 0 104 0 0 30 197 0 0 30 197 0 0 1 42 0 0 30 198 0 0 30 198 0 0 0 105 0 0 30 199 0 0 30 199 0 0 1 43 0 0 30 200 0 0 30 200 0 0 0 129 0 0 30 201 0 0 30 201 0 0 1 66 0 0 30 202 0 0 30 202 0 0 0 130 0 0 30 203 0 0 30 203 0 0 1 67 0 0 30 204 0 0 30 204 0 0 0 164 0 0 30 205 0 0 30 205 0 0 1 105 0 0 30 206 0 0 30 206 0 0 0 165 0 0 30 207 0 0 30 207 0 0 1 106 0 0 30 208 0 0 30 208 0 0 0 166 0 0 30 209 0 0 30 209 0 0 1 107 0 0 30 210 0 0 30 210 0 0 0 167 0 0 30 211 0 0 30 211 0 0 1 108 0 0 30 212 0 0 30 212 0 0 0 168 0 0 30 213 0 0 30 213 0 0 1 109 0 0 30 214 0 0 30 214 0 0 0 169 0 0 30 215 0 0 30 215 0 0 1 110 0 0 30 216 0 0 30 216 0 0 0 170 0 0 30 217 0 0 30 217 0 0 1 111 0 0 30 218 0 0 30 218 0 0 0 176 0 0 30 219 0 0 30 219 0 0 1 117 0 0 30 220 0 0 30 220 0 0 0 177 0 0 30 221 0 0 30 221 0 0 1 118 0 0 30 222 0 0 30 222 0 0 0 178 0 0 30 223 0 0 30 223 0 0 1 119 0 0 30 224 0 0 30 224 0 0 0 179 0 0 30 225 0 0 30 225 0 0 1 120 0 0 30 226 0 0 30 226 0 0 0 180 0 0 30 227 0 0 30 227 0 0 1 121 0 0 30 228 0 0 30 228 0 0 0 217 0 0 30 229 0 0 30 229 0 0 1 159 0 0 30 230 0 0 30 230 0 0 0 218 0 0 30 231 0 0 30 231 0 0 1 160 0 0 30 232 0 0 30 232 0 0 0 221 0 0 30 233 0 0 30 233 0 0 1 163 0 0 30 234 0 0 30 234 0 0 0 222 0 0 30 235 0 0 30 235 0 0 1 164 0 0 30 236 0 0 30 236 0 0 0 223 0 0 30 237 0 0 30 237 0 0 1 165 0 0 30 238 0 0 30 238 0 0 0 224 0 0 30 239 0 0 30 239 0 0 1 166 0 0 30 240 0 0 30 240 0 0 0 225 0 0 30 241 0 0 30 241 0 0 1 167 0 0 30 242 0 0 30 242 0 0 0 230 0 0 30 243 0 0 30 243 0 0 1 172 0 0 30 244 0 0 30 244 0 0 0 235 0 0 30 245 0 0 30 245 0 0 1 177 0 0 30 246 0 0 30 246 0 0 0 236 0 0 30 247 0 0 30 247 0 0 1 178 0 0 30 248 0 0 30 248 0 0 0 237 0 0 30 249 0 0 30 249 0 0 1 179 0 0 31 0 0 0 31 1 0 0 2 231 0 0 31 2 0 0 31 7 0 0 2 235 0 0 31 8 0 0 31 9 0 0 2 135 0 0 31 10 0 0 31 15 0 0 2 139 0 0 31 16 0 0 31 17 0 0 2 244 0 0 31 18 0 0 31 21 0 0 2 248 0 0 31 24 0 0 31 25 0 0 2 147 0 0 31 26 0 0 31 29 0 0 2 151 0 0 31 32 0 0 31 33 0 0 2 252 0 0 31 34 0 0 31 39 0 0 3 0 0 0 31 40 0 0 31 41 0 0 2 155 0 0 31 42 0 0 31 47 0 0 2 159 0 0 31 48 0 0 31 49 0 0 3 7 0 0 31 50 0 0 31 55 0 0 3 11 0 0 31 56 0 0 31 57 0 0 2 165 0 0 31 58 0 0 31 63 0 0 2 169 0 0 31 64 0 0 31 65 0 0 3 23 0 0 31 66 0 0 31 69 0 0 3 27 0 0 31 72 0 0 31 73 0 0 2 177 0 0 31 74 0 0 31 77 0 0 2 181 0 0 31 80 0 0 31 81 0 0 3 33 0 0 31 82 0 0 31 87 0 0 3 37 0 0 31 89 0 0 31 89 0 0 2 186 0 0 31 91 0 0 31 91 0 0 2 189 0 0 31 93 0 0 31 93 0 0 2 190 0 0 31 95 0 0 31 95 0 0 2 191 0 0 31 96 0 0 31 97 0 0 3 49 0 0 31 98 0 0 31 103 0 0 3 53 0 0 31 104 0 0 31 105 0 0 2 194 0 0 31 106 0 0 31 111 0 0 2 198 0 0 31 112 0 0 31 113 0 0 2 233 0 0 31 114 0 0 31 115 0 0 2 246 0 0 31 116 0 0 31 117 0 0 2 254 0 0 31 118 0 0 31 119 0 0 3 9 0 0 31 120 0 0 31 121 0 0 3 25 0 0 31 122 0 0 31 123 0 0 3 35 0 0 31 124 0 0 31 125 0 0 3 51 0 0 31 128 0 0 31 129 0 0 3 61 0 0 31 130 0 0 31 135 0 0 3 65 0 0 31 136 0 0 31 143 0 0 2 205 0 0 31 144 0 0 31 145 0 0 3 73 0 0 31 146 0 0 31 151 0 0 3 77 0 0 31 152 0 0 31 159 0 0 2 214 0 0 31 160 0 0 31 161 0 0 3 85 0 0 31 162 0 0 31 167 0 0 3 89 0 0 31 168 0 0 31 175 0 0 2 223 0 0 31 176 0 0 31 177 0 0 2 241 0 0 31 178 0 0 31 178 0 0 3 63 0 0 31 179 0 0 31 179 0 0 3 60 0 0 31 180 0 0 31 180 0 0 3 64 0 0 31 182 0 0 31 182 0 0 2 243 0 0 31 183 0 0 31 183 0 0 3 71 0 0 31 184 0 0 31 185 0 0 2 145 0 0 31 186 0 0 31 187 0 0 2 137 0 0 31 188 0 0 31 188 0 0 2 204 0 0 31 189 0 0 31 189 0 0 3 111 0 0 31 190 0 0 31 190 0 0 3 110 0 0 31 191 0 0 31 191 0 0 3 112 0 0 31 192 0 0 31 192 0 0 3 122 0 0 31 193 0 0 31 193 0 0 3 125 0 0 31 194 0 0 31 194 0 0 3 75 0 0 31 195 0 0 31 195 0 0 3 72 0 0 31 196 0 0 31 196 0 0 3 76 0 0 31 198 0 0 31 198 0 0 3 6 0 0 31 199 0 0 31 199 0 0 3 83 0 0 31 200 0 0 31 201 0 0 2 149 0 0 31 202 0 0 31 203 0 0 2 157 0 0 31 204 0 0 31 204 0 0 2 213 0 0 31 205 0 0 31 205 0 0 3 116 0 0 31 206 0 0 31 206 0 0 3 118 0 0 31 207 0 0 31 207 0 0 3 120 0 0 31 208 0 0 31 209 0 0 3 17 0 0 31 210 0 0 31 211 0 0 3 20 0 0 31 214 0 0 31 214 0 0 3 19 0 0 31 215 0 0 31 215 0 0 3 22 0 0 31 216 0 0 31 217 0 0 2 175 0 0 31 218 0 0 31 219 0 0 2 167 0 0 31 221 0 0 31 221 0 0 3 117 0 0 31 222 0 0 31 222 0 0 3 119 0 0 31 223 0 0 31 223 0 0 3 121 0 0 31 224 0 0 31 227 0 0 3 44 0 0 31 228 0 0 31 229 0 0 3 31 0 0 31 230 0 0 31 230 0 0 3 43 0 0 31 231 0 0 31 231 0 0 3 48 0 0 31 232 0 0 31 233 0 0 2 192 0 0 31 234 0 0 31 235 0 0 2 187 0 0 31 236 0 0 31 236 0 0 2 185 0 0 31 237 0 0 31 238 0 0 3 123 0 0 31 239 0 0 31 239 0 0 3 114 0 0 31 242 0 0 31 242 0 0 3 87 0 0 31 243 0 0 31 243 0 0 3 84 0 0 31 244 0 0 31 244 0 0 3 88 0 0 31 246 0 0 31 246 0 0 3 59 0 0 31 247 0 0 31 247 0 0 3 95 0 0 31 248 0 0 31 249 0 0 2 179 0 0 31 250 0 0 31 251 0 0 2 196 0 0 31 252 0 0 31 252 0 0 2 222 0 0 31 253 0 0 31 253 0 0 3 115 0 0 31 254 0 0 31 254 0 0 3 113 0 0 32 7 0 0 32 7 0 0 7 143 0 0 32 18 0 0 32 18 0 0 4 144 0 0 32 19 0 0 32 20 0 0 4 140 0 0 32 21 0 0 32 21 0 0 4 145 0 0 32 22 0 0 32 22 0 0 4 166 0 0 32 24 0 0 32 25 0 0 4 128 0 0 32 26 0 0 32 26 0 0 4 132 0 0 32 28 0 0 32 29 0 0 4 130 0 0 32 30 0 0 32 30 0 0 4 133 0 0 32 32 0 0 32 33 0 0 4 162 0 0 32 34 0 0 32 34 0 0 4 147 0 0 32 38 0 0 32 38 0 0 4 121 0 0 32 47 0 0 32 47 0 0 7 146 0 0 32 48 0 0 32 48 0 0 6 192 0 0 32 50 0 0 32 51 0 0 7 4 0 0 32 53 0 0 32 53 0 0 7 6 0 0 32 57 0 0 32 58 0 0 4 134 0 0 32 60 0 0 32 60 0 0 4 167 0 0 32 61 0 0 32 61 0 0 4 171 0 0 32 62 0 0 32 63 0 0 4 149 0 0 32 68 0 0 32 68 0 0 6 188 0 0 32 71 0 0 32 71 0 0 4 168 0 0 32 72 0 0 32 72 0 0 4 170 0 0 32 73 0 0 32 73 0 0 4 169 0 0 32 112 0 0 32 112 0 0 6 38 0 0 32 113 0 0 32 113 0 0 6 131 0 0 32 116 0 0 32 121 0 0 6 42 0 0 32 125 0 0 32 126 0 0 6 48 0 0 32 127 0 0 32 127 0 0 6 136 0 0 32 128 0 0 32 137 0 0 6 52 0 0 32 141 0 0 32 142 0 0 6 62 0 0 32 148 0 0 32 148 0 0 6 156 0 0 32 161 0 0 32 161 0 0 6 173 0 0 32 164 0 0 32 164 0 0 6 174 0 0 32 166 0 0 32 167 0 0 6 175 0 0 32 169 0 0 32 169 0 0 6 177 0 0 32 171 0 0 32 171 0 0 6 178 0 0 32 172 0 0 32 172 0 0 6 170 0 0 32 174 0 0 32 174 0 0 6 185 0 0 32 177 0 0 32 178 0 0 6 179 0 0 32 180 0 0 32 181 0 0 6 181 0 0 32 184 0 0 32 184 0 0 6 186 0 0 32 185 0 0 32 186 0 0 6 183 0 0 32 189 0 0 32 189 0 0 6 187 0 0 33 19 0 0 33 19 0 0 6 237 0 0 33 22 0 0 33 22 0 0 4 61 0 0 33 23 0 0 33 23 0 0 4 183 0 0 33 32 0 0 33 32 0 0 4 186 0 0 33 34 0 0 33 34 0 0 4 185 0 0 33 38 0 0 33 38 0 0 6 234 0 0 33 46 0 0 33 46 0 0 6 238 0 0 33 80 0 0 33 80 0 0 6 204 0 0 33 81 0 0 33 82 0 0 6 209 0 0 33 83 0 0 33 90 0 0 6 196 0 0 33 91 0 0 33 94 0 0 6 205 0 0 33 137 0 0 33 137 0 0 6 211 0 0 33 144 0 0 33 147 0 0 6 239 0 0 34 2 0 0 34 2 0 0 6 230 0 0 34 6 0 0 34 6 0 0 6 233 0 0 34 15 0 0 34 15 0 0 6 236 0 0 34 17 0 0 34 17 0 0 6 235 0 0 34 18 0 0 34 18 0 0 6 213 0 0 34 21 0 0 34 21 0 0 6 189 0 0 34 25 0 0 34 25 0 0 6 216 0 0 34 26 0 0 34 26 0 0 6 232 0 0 34 30 0 0 34 30 0 0 6 228 0 0 34 43 0 0 34 43 0 0 6 231 0 0 34 72 0 0 34 72 0 0 6 226 0 0 34 96 0 0 34 96 0 0 6 224 0 0 34 100 0 0 34 101 0 0 6 220 0 0 35 28 0 0 35 31 0 0 4 172 0 0 37 160 0 0 37 160 0 0 6 243 0 0 37 178 0 0 37 179 0 0 6 247 0 0 37 182 0 0 37 183 0 0 6 249 0 0 37 188 0 0 37 189 0 0 6 251 0 0 37 192 0 0 37 193 0 0 6 253 0 0 37 198 0 0 37 198 0 0 6 244 0 0 37 201 0 0 37 201 0 0 6 245 0 0 37 202 0 0 37 202 0 0 7 3 0 0 37 204 0 0 37 204 0 0 7 30 0 0 38 16 0 0 38 17 0 0 6 255 0 0 38 106 0 0 38 106 0 0 7 2 0 0 39 19 0 0 39 19 0 0 7 1 0 0 39 82 0 0 39 82 0 0 6 246 0 0 39 230 0 0 39 231 0 0 4 176 0 0 46 34 0 0 46 37 0 0 4 178 0 0 46 58 0 0 46 59 0 0 4 142 0 0 251 0 0 0 251 0 0 0 2 2 0 0 251 1 0 0 251 2 0 0 7 148 0 0 251 3 0 0 251 4 0 0 2 3 0 0 254 255 0 0 254 255 0 0 7 147 0 1 241 106 0 1 241 107 0 0 4 187 0 0 184 0 0 44 75 184 0 9 80 88 177 1 1 142 89 184 1 255 133 184 0 68 29 185 0 9 0 3 95 94 45 184 0 1 44 32 32 69 105 68 176 1 96 45 184 0 2 44 184 0 1 42 33 45 184 0 3 44 32 70 176 3 37 70 82 88 35 89 32 138 32 138 73 100 138 32 70 32 104 97 100 176 4 37 70 32 104 97 100 82 88 35 101 138 89 47 32 176 0 83 88 105 32 176 0 84 88 33 176 64 89 27 105 32 176 0 84 88 33 176 64 101 89 89 58 45 184 0 4 44 32 70 176 4 37 70 82 88 35 138 89 32 70 32 106 97 100 176 4 37 70 32 106 97 100 82 88 35 138 89 47 253 45 184 0 5 44 75 32 176 3 38 80 88 81 88 176 128 68 27 176 64 68 89 27 33 33 32 69 176 192 80 88 176 192 68 27 33 89 89 45 184 0 6 44 32 32 69 105 68 176 1 96 32 32 69 125 105 24 68 176 1 96 45 184 0 7 44 184 0 6 42 45 184 0 8 44 75 32 176 3 38 83 88 176 64 27 176 0 89 138 138 32 176 3 38 83 88 35 33 176 128 138 138 27 138 35 89 32 176 3 38 83 88 35 33 184 0 192 138 138 27 138 35 89 32 176 3 38 83 88 35 33 184 1 0 138 138 27 138 35 89 32 176 3 38 83 88 35 33 184 1 64 138 138 27 138 35 89 32 184 0 3 38 83 88 176 3 37 69 184 1 128 80 88 35 33 184 1 128 35 33 27 176 3 37 69 35 33 35 33 89 27 33 89 68 45 184 0 9 44 75 83 88 69 68 27 33 33 89 45 0 176 0 43 0 178 1 2 2 43 1 178 3 2 2 43 1 183 3 68 54 42 33 20 0 8 43 183 4 64 54 42 33 20 0 8 43 0 183 1 96 72 60 38 22 0 8 43 183 2 72 60 44 36 22 0 8 43 0 178 5 8 7 43 176 0 32 69 125 105 24 68 75 184 0 96 82 88 176 1 27 176 0 89 176 1 142 0 0 0 20 0 67 0 78 0 84 0 95 0 0 0 12 255 51 0 12 1 230 0 12 2 6 0 12 2 62 0 12 2 126 0 12 2 144 0 12 2 200 0 12 0 0 0 0 0 0 0 0 0 204 0 0 0 204 0 0 1 104 0 0 2 48 0 0 2 208 0 0 3 68 0 0 3 188 0 0 4 40 0 0 4 232 0 0 5 96 0 0 5 160 0 0 6 8 0 0 6 160 0 0 6 232 0 0 7 168 0 0 8 72 0 0 8 240 0 0 9 124 0 0 10 100 0 0 11 16 0 0 11 240 0 0 12 68 0 0 12 200 0 0 13 64 0 0 14 44 0 0 14 228 0 0 15 96 0 0 15 208 0 0 16 184 0 0 17 168 0 0 18 72 0 0 19 48 0 0 19 248 0 0 20 144 0 0 22 12 0 0 22 168 0 0 23 24 0 0 23 172 0 0 24 68 0 0 24 168 0 0 25 152 0 0 26 56 0 0 26 224 0 0 27 212 0 0 28 192 0 0 29 72 0 0 30 32 0 0 30 192 0 0 31 88 0 0 31 208 0 0 32 160 0 0 33 64 0 0 33 232 0 0 34 88 0 0 34 112 0 0 34 136 0 0 34 160 0 0 34 184 0 0 34 208 0 0 34 232 0 0 35 0 0 0 35 24 0 0 35 48 0 0 35 72 0 0 35 96 0 0 35 120 0 0 35 144 0 0 35 168 0 0 35 192 0 0 35 224 0 0 35 248 0 0 36 16 0 0 36 40 0 0 36 64 0 0 36 96 0 0 37 56 0 0 38 4 0 0 38 28 0 0 38 52 0 0 39 20 0 0 39 44 0 0 39 68 0 0 39 92 0 0 39 116 0 0 39 140 0 0 39 164 0 0 39 188 0 0 39 212 0 0 39 236 0 0 39 252 0 0 40 20 0 0 40 44 0 0 40 68 0 0 40 92 0 0 40 116 0 0 40 140 0 0 40 164 0 0 40 188 0 0 40 212 0 0 40 236 0 0 41 4 0 0 41 28 0 0 41 52 0 0 41 76 0 0 41 100 0 0 41 132 0 0 42 68 0 0 42 92 0 0 42 116 0 0 42 140 0 0 42 164 0 0 42 188 0 0 42 212 0 0 42 236 0 0 43 4 0 0 43 28 0 0 44 16 0 0 44 40 0 0 44 64 0 0 44 88 0 0 45 24 0 0 45 48 0 0 45 72 0 0 45 96 0 0 45 120 0 0 45 144 0 0 45 168 0 0 45 192 0 0 45 216 0 0 45 240 0 0 46 8 0 0 46 132 0 0 46 156 0 0 46 180 0 0 46 204 0 0 46 228 0 0 46 252 0 0 47 20 0 0 47 44 0 0 47 68 0 0 47 92 0 0 47 116 0 0 47 148 0 0 47 172 0 0 48 48 0 0 48 72 0 0 48 96 0 0 48 120 0 0 48 144 0 0 48 168 0 0 48 192 0 0 48 216 0 0 48 240 0 0 49 8 0 0 49 32 0 0 49 56 0 0 49 80 0 0 49 104 0 0 49 128 0 0 49 152 0 0 49 176 0 0 49 200 0 0 49 224 0 0 49 248 0 0 50 16 0 0 50 40 0 0 50 64 0 0 50 88 0 0 50 112 0 0 50 136 0 0 50 168 0 0 50 192 0 0 50 216 0 0 51 240 0 0 52 156 0 0 53 128 0 0 53 152 0 0 53 176 0 0 53 200 0 0 53 224 0 0 53 248 0 0 54 232 0 0 55 0 0 0 55 24 0 0 55 48 0 0 55 72 0 0 55 96 0 0 55 128 0 0 55 152 0 0 55 176 0 0 55 200 0 0 55 224 0 0 55 248 0 0 56 16 0 0 56 40 0 0 56 64 0 0 57 16 0 0 57 40 0 0 57 64 0 0 57 88 0 0 57 112 0 0 57 136 0 0 58 8 0 0 58 32 0 0 58 56 0 0 58 80 0 0 58 104 0 0 58 128 0 0 58 152 0 0 58 176 0 0 58 200 0 0 58 224 0 0 58 248 0 0 59 16 0 0 59 40 0 0 59 64 0 0 59 88 0 0 59 112 0 0 59 136 0 0 60 84 0 0 61 4 0 0 61 28 0 0 61 52 0 0 61 76 0 0 61 100 0 0 61 124 0 0 61 148 0 0 61 172 0 0 61 196 0 0 61 220 0 0 61 244 0 0 62 12 0 0 62 36 0 0 62 60 0 0 62 84 0 0 62 108 0 0 62 132 0 0 62 156 0 0 62 180 0 0 62 204 0 0 62 228 0 0 62 252 0 0 63 20 0 0 63 192 0 0 64 68 0 0 65 0 0 0 65 204 0 0 66 80 0 0 66 104 0 0 66 128 0 0 66 152 0 0 66 176 0 0 66 200 0 0 66 224 0 0 66 248 0 0 67 16 0 0 67 40 0 0 67 64 0 0 67 88 0 0 67 112 0 0 67 136 0 0 67 160 0 0 67 184 0 0 67 216 0 0 67 240 0 0 68 8 0 0 68 32 0 0 68 56 0 0 68 88 0 0 69 128 0 0 70 232 0 0 71 0 0 0 71 24 0 0 72 44 0 0 72 68 0 0 72 92 0 0 72 116 0 0 72 140 0 0 72 164 0 0 72 188 0 0 72 212 0 0 72 236 0 0 73 4 0 0 74 16 0 0 74 40 0 0 74 64 0 0 74 88 0 0 74 112 0 0 74 136 0 0 74 160 0 0 74 184 0 0 74 208 0 0 74 232 0 0 75 0 0 0 75 24 0 0 75 48 0 0 75 72 0 0 75 96 0 0 75 120 0 0 75 152 0 0 76 160 0 0 76 184 0 0 76 208 0 0 76 232 0 0 77 0 0 0 77 24 0 0 77 48 0 0 77 72 0 0 77 96 0 0 77 120 0 0 77 144 0 0 77 168 0 0 77 192 0 0 77 216 0 0 78 156 0 0 78 180 0 0 78 204 0 0 78 228 0 0 78 252 0 0 79 20 0 0 79 44 0 0 79 68 0 0 79 92 0 0 79 116 0 0 80 32 0 0 80 160 0 0 80 184 0 0 80 248 0 0 81 16 0 0 81 40 0 0 81 64 0 0 81 88 0 0 81 220 0 0 81 244 0 0 82 12 0 0 82 36 0 0 82 60 0 0 82 84 0 0 82 116 0 0 82 140 0 0 83 36 0 0 83 60 0 0 83 84 0 0 83 108 0 0 83 132 0 0 83 156 0 0 83 180 0 0 83 204 0 0 83 228 0 0 83 252 0 0 84 20 0 0 84 44 0 0 84 68 0 0 84 92 0 0 84 116 0 0 84 140 0 0 84 164 0 0 84 188 0 0 84 212 0 0 84 236 0 0 85 4 0 0 85 28 0 0 85 52 0 0 85 76 0 0 85 100 0 0 85 124 0 0 85 148 0 0 85 180 0 0 85 204 0 0 85 228 0 0 86 252 0 0 88 36 0 0 89 4 0 0 89 28 0 0 89 52 0 0 89 76 0 0 89 100 0 0 89 124 0 0 90 112 0 0 90 136 0 0 90 160 0 0 90 184 0 0 90 208 0 0 90 232 0 0 91 8 0 0 91 32 0 0 91 56 0 0 91 80 0 0 91 104 0 0 91 128 0 0 91 152 0 0 91 176 0 0 91 200 0 0 92 200 0 0 92 224 0 0 92 248 0 0 93 16 0 0 93 40 0 0 93 64 0 0 93 88 0 0 94 32 0 0 94 56 0 0 94 80 0 0 94 104 0 0 94 128 0 0 94 152 0 0 94 176 0 0 94 200 0 0 94 224 0 0 94 248 0 0 95 16 0 0 95 40 0 0 95 64 0 0 95 88 0 0 95 112 0 0 95 136 0 0 95 160 0 0 96 124 0 0 97 72 0 0 97 96 0 0 97 120 0 0 97 144 0 0 97 168 0 0 97 192 0 0 97 216 0 0 97 240 0 0 98 8 0 0 98 32 0 0 98 56 0 0 98 80 0 0 98 104 0 0 98 128 0 0 98 152 0 0 98 176 0 0 98 200 0 0 98 224 0 0 98 248 0 0 99 16 0 0 99 40 0 0 99 64 0 0 99 88 0 0 100 96 0 0 101 88 0 0 102 24 0 0 102 124 0 0 103 100 0 0 104 80 0 0 105 56 0 0 106 80 0 0 106 236 0 0 107 240 0 0 108 248 0 0 110 8 0 0 110 192 0 0 111 164 0 0 111 180 0 0 112 116 0 0 113 124 0 0 114 80 0 0 115 36 0 0 115 252 0 0 116 148 0 0 117 180 0 0 118 188 0 0 119 116 0 0 120 80 0 0 121 80 0 0 121 244 0 0 122 192 0 0 123 172 0 0 124 20 0 0 124 168 0 0 125 20 0 0 126 8 0 0 126 212 0 0 127 44 0 0 128 24 0 0 128 96 0 0 129 68 0 0 130 52 0 0 131 60 0 0 131 248 0 0 132 184 0 0 133 80 0 0 134 12 0 0 134 232 0 0 135 232 0 0 136 116 0 0 137 0 0 0 137 172 0 0 138 84 0 0 138 188 0 0 139 84 0 0 139 236 0 0 140 244 0 0 141 128 0 0 142 64 0 0 142 200 0 0 143 164 0 0 144 124 0 0 145 36 0 0 145 144 0 0 146 88 0 0 147 4 0 0 147 120 0 0 148 20 0 0 148 228 0 0 149 156 0 0 150 32 0 0 150 164 0 0 151 76 0 0 151 248 0 0 152 116 0 0 153 64 0 0 154 52 0 0 154 76 0 0 154 100 0 0 155 88 0 0 156 212 0 0 157 60 0 0 157 84 0 0 157 108 0 0 157 132 0 0 157 156 0 0 157 180 0 0 157 204 0 0 157 228 0 0 157 252 0 0 158 20 0 0 158 44 0 0 158 224 0 0 158 248 0 0 159 180 0 0 159 196 0 0 159 220 0 0 159 244 0 0 160 12 0 0 160 36 0 0 160 60 0 0 160 84 0 0 160 108 0 0 160 132 0 0 160 156 0 0 160 180 0 0 160 204 0 0 160 228 0 0 160 252 0 0 161 20 0 0 161 44 0 0 161 76 0 0 161 100 0 0 161 124 0 0 161 148 0 0 161 172 0 0 161 204 0 0 162 244 0 0 163 4 0 0 163 28 0 0 163 52 0 0 163 76 0 0 163 100 0 0 163 124 0 0 163 148 0 0 163 172 0 0 163 196 0 0 164 4 0 0 164 28 0 0 164 52 0 0 164 76 0 0 164 100 0 0 164 124 0 0 164 156 0 0 164 180 0 0 165 36 0 0 165 60 0 0 165 76 0 0 165 92 0 0 165 172 0 0 166 20 0 0 166 36 0 0 166 52 0 0 166 68 0 0 167 8 0 0 167 24 0 0 167 40 0 0 167 148 0 0 167 164 0 0 167 180 0 0 168 44 0 0 168 60 0 0 168 160 0 0 168 176 0 0 169 28 0 0 169 44 0 0 169 60 0 0 170 4 0 0 170 20 0 0 170 188 0 0 171 152 0 0 171 176 0 0 171 200 0 0 171 224 0 0 171 248 0 0 172 16 0 0 172 40 0 0 172 64 0 0 172 88 0 0 172 112 0 0 173 140 0 0 174 168 0 0 175 84 0 0 176 84 0 0 177 68 0 0 178 16 0 0 178 188 0 0 179 116 0 0 179 216 0 0 180 192 0 0 181 104 0 0 182 64 0 0 182 216 0 0 184 24 0 0 184 172 0 0 185 112 0 0 186 56 0 0 186 252 0 0 187 132 0 0 188 64 0 0 189 40 0 0 189 232 0 0 190 200 0 0 191 180 0 0 192 92 0 0 193 92 0 0 194 60 0 0 195 48 0 0 195 72 0 0 195 96 0 0 195 120 0 0 195 144 0 0 195 168 0 0 195 192 0 0 195 216 0 0 195 240 0 0 196 8 0 0 196 32 0 0 196 56 0 0 196 80 0 0 196 104 0 0 196 128 0 0 196 152 0 0 196 176 0 0 196 200 0 0 196 224 0 0 196 248 0 0 197 16 0 0 197 40 0 0 197 64 0 0 197 88 0 0 197 112 0 0 197 136 0 0 197 160 0 0 197 184 0 0 197 208 0 0 197 232 0 0 198 0 0 0 198 24 0 0 198 48 0 0 198 72 0 0 198 96 0 0 198 120 0 0 198 144 0 0 198 168 0 0 198 192 0 0 198 216 0 0 198 240 0 0 199 8 0 0 199 32 0 0 199 56 0 0 199 80 0 0 199 104 0 0 199 128 0 0 199 152 0 0 199 176 0 0 199 200 0 0 199 224 0 0 199 248 0 0 200 16 0 0 200 40 0 0 200 64 0 0 200 88 0 0 200 112 0 0 200 136 0 0 200 160 0 0 200 184 0 0 200 208 0 0 200 232 0 0 201 0 0 0 201 24 0 0 201 48 0 0 201 72 0 0 201 96 0 0 201 120 0 0 201 144 0 0 201 168 0 0 201 192 0 0 201 216 0 0 201 240 0 0 202 8 0 0 202 32 0 0 202 56 0 0 202 80 0 0 202 104 0 0 202 128 0 0 202 152 0 0 202 176 0 0 202 200 0 0 202 232 0 0 203 8 0 0 203 40 0 0 203 72 0 0 203 104 0 0 203 136 0 0 203 168 0 0 203 200 0 0 203 224 0 0 204 0 0 0 204 32 0 0 204 64 0 0 204 96 0 0 204 128 0 0 204 160 0 0 204 192 0 0 204 224 0 0 204 248 0 0 205 24 0 0 205 56 0 0 205 88 0 0 205 120 0 0 205 152 0 0 205 184 0 0 205 216 0 0 205 248 0 0 206 16 0 0 206 40 0 0 206 64 0 0 206 88 0 0 206 112 0 0 206 136 0 0 206 160 0 0 206 184 0 0 206 208 0 0 206 232 0 0 207 0 0 0 207 24 0 0 207 48 0 0 207 72 0 0 207 96 0 0 207 120 0 0 207 144 0 0 207 168 0 0 207 192 0 0 207 216 0 0 207 240 0 0 208 8 0 0 208 32 0 0 208 56 0 0 208 80 0 0 208 104 0 0 208 128 0 0 208 152 0 0 208 176 0 0 208 200 0 0 208 224 0 0 208 248 0 0 209 16 0 0 209 40 0 0 209 64 0 0 209 88 0 0 209 112 0 0 209 136 0 0 209 160 0 0 209 184 0 0 209 208 0 0 209 232 0 0 210 0 0 0 210 24 0 0 210 48 0 0 210 72 0 0 210 96 0 0 210 120 0 0 210 144 0 0 210 168 0 0 210 192 0 0 210 216 0 0 210 240 0 0 211 8 0 0 211 32 0 0 211 56 0 0 211 80 0 0 211 104 0 0 211 128 0 0 211 152 0 0 211 176 0 0 211 200 0 0 211 224 0 0 211 248 0 0 212 16 0 0 212 40 0 0 212 64 0 0 212 88 0 0 212 112 0 0 212 136 0 0 212 160 0 0 212 184 0 0 212 208 0 0 212 232 0 0 213 0 0 0 213 24 0 0 213 48 0 0 213 72 0 0 213 96 0 0 213 120 0 0 213 144 0 0 213 168 0 0 213 192 0 0 213 216 0 0 213 240 0 0 214 8 0 0 214 40 0 0 214 72 0 0 214 104 0 0 214 136 0 0 214 168 0 0 214 200 0 0 214 232 0 0 215 8 0 0 215 40 0 0 215 72 0 0 215 104 0 0 215 128 0 0 215 160 0 0 215 192 0 0 215 224 0 0 216 0 0 0 216 32 0 0 216 64 0 0 216 96 0 0 216 128 0 0 216 160 0 0 216 192 0 0 216 224 0 0 216 248 0 0 217 24 0 0 217 56 0 0 217 88 0 0 217 120 0 0 217 152 0 0 217 184 0 0 217 216 0 0 217 248 0 0 218 24 0 0 218 56 0 0 218 88 0 0 219 68 0 0 219 248 0 0 220 172 0 0 221 8 0 0 221 132 0 0 221 156 0 0 221 176 0 0 221 196 0 0 221 236 0 0 222 32 0 0 222 52 0 0 222 100 0 0 222 120 0 0 222 140 0 0 222 228 0 0 222 248 0 0 223 12 0 0 223 32 0 0 223 52 0 0 223 72 0 0 223 92 0 0 223 112 0 0 223 132 0 0 223 152 0 0 223 172 0 0 223 192 0 0 223 212 0 0 223 232 0 0 223 252 0 0 224 16 0 0 224 100 0 0 224 184 0 0 224 236 0 0 224 252 0 0 225 108 0 0 225 220 0 0 226 76 0 0 226 188 0 0 227 136 0 0 228 88 0 0 228 104 0 0 229 0 0 0 229 16 0 0 229 32 0 0 229 212 0 0 229 228 0 0 231 8 0 0 232 184 0 0 233 36 0 0 233 248 0 0 234 136 0 0 234 160 0 0 235 84 0 0 236 56 0 0 236 120 0 0 237 16 0 0 237 32 0 0 237 48 0 0 237 64 0 0 237 80 0 0 237 96 0 0 237 112 0 0 237 128 0 0 238 24 0 0 238 220 0 0 238 236 0 0 239 92 0 0 239 224 0 0 240 84 0 0 240 224 0 0 241 116 0 0 242 24 0 0 242 156 0 0 243 76 0 0 244 56 0 0 244 224 0 0 244 248 0 0 245 16 0 0 245 216 0 0 245 240 0 0 246 164 0 0 246 180 0 0 246 196 0 0 246 220 0 0 247 120 0 0 247 136 0 0 248 108 0 0 249 52 0 0 249 200 0 0 249 224 0 0 250 212 0 0 251 36 0 0 251 60 0 0 251 84 0 0 251 196 0 0 252 96 0 0 253 20 0 0 253 184 0 0 254 20 0 0 254 156 0 0 255 220 0 1 1 204 0 1 2 132 0 1 3 112 0 1 4 64 0 1 5 8 0 1 5 132 0 1 6 84 0 1 7 88 0 1 7 208 0 1 8 96 0 1 9 24 0 1 9 40 0 1 9 208 0 1 10 160 0 1 11 64 0 1 11 192 0 1 11 208 0 1 11 232 0 1 13 216 0 1 14 132 0 1 14 156 0 1 14 172 0 1 14 196 0 1 14 212 0 1 14 236 0 1 15 4 0 1 15 20 0 1 15 44 0 1 15 68 0 1 15 84 0 1 16 64 0 1 17 0 0 1 17 76 0 1 17 232 0 1 17 248 0 1 18 248 0 1 20 148 0 1 20 248 0 1 21 204 0 1 22 100 0 1 22 124 0 1 23 36 0 1 23 248 0 1 24 52 0 1 24 192 0 1 25 144 0 1 25 248 0 1 26 8 0 1 26 96 0 1 26 112 0 1 26 128 0 1 26 212 0 1 26 228 0 1 28 120 0 1 28 136 0 1 28 248 0 1 29 116 0 1 29 228 0 1 30 112 0 1 30 244 0 1 31 144 0 1 32 16 0 1 32 184 0 1 33 156 0 1 34 56 0 1 34 80 0 1 34 104 0 1 35 92 0 1 35 116 0 1 36 28 0 1 36 44 0 1 36 60 0 1 36 84 0 1 36 240 0 1 37 0 0 1 37 216 0 1 38 116 0 1 38 132 0 1 38 156 0 1 39 128 0 1 39 204 0 1 39 228 0 1 39 252 0 1 40 108 0 1 40 252 0 1 41 12 0 1 41 168 0 1 41 252 0 1 42 116 0 1 43 148 0 1 45 84 0 1 46 0 0 1 46 228 0 1 47 188 0 1 48 140 0 1 49 0 0 1 49 180 0 1 50 168 0 1 51 24 0 1 51 156 0 1 52 80 0 1 52 224 0 1 53 136 0 1 54 84 0 1 54 232 0 1 54 248 0 1 55 16 0 1 56 240 0 1 57 152 0 1 57 168 0 1 57 192 0 1 57 208 0 1 57 232 0 1 57 248 0 1 58 16 0 1 58 40 0 1 58 56 0 1 58 80 0 1 58 104 0 1 59 116 0 1 60 224 0 1 62 72 0 1 62 216 0 1 63 72 0 1 63 228 0 1 64 200 0 1 65 104 0 1 66 40 0 1 66 244 0 1 67 96 0 1 68 132 0 1 69 84 0 1 70 4 0 1 70 212 0 1 71 96 0 1 71 188 0 1 72 88 0 1 72 104 0 1 72 120 0 1 72 136 0 1 72 152 0 1 73 4 0 1 73 20 0 1 73 36 0 1 73 224 0 1 74 180 0 1 75 52 0 1 75 164 0 1 76 64 0 1 77 24 0 1 77 164 0 1 78 84 0 1 78 100 0 1 78 188 0 1 78 204 0 1 79 132 0 1 79 148 0 1 79 240 0 1 80 144 0 1 80 160 0 1 80 176 0 1 80 192 0 1 80 208 0 1 81 40 0 1 81 56 0 1 81 72 0 1 81 216 0 1 82 72 0 1 82 224 0 1 83 200 0 1 84 100 0 1 85 32 0 1 85 236 0 1 86 88 0 1 87 124 0 1 88 76 0 1 88 144 0 1 88 228 0 1 88 252 0 1 89 20 0 1 89 52 0 1 89 144 0 1 89 240 0 1 90 144 0 1 91 48 0 1 91 92 0 1 91 116 0 1 91 192 0 1 92 12 0 1 92 36 0 1 92 60 0 1 92 80 0 1 92 108 0 1 92 156 0 1 92 204 0 1 92 228 0 1 92 252 0 1 93 32 0 1 93 48 0 1 93 88 0 1 93 128 0 1 93 168 0 1 93 208 0 1 93 248 0 1 94 8 0 1 94 28 0 1 94 104 0 1 94 144 0 1 94 184 0 1 94 252 0 1 95 60 0 1 95 124 0 1 95 180 0 1 95 236 0 1 96 156 0 1 97 84 0 1 97 140 0 1 97 176 0 1 97 232 0 1 98 28 0 1 98 108 0 1 98 212 0 1 99 120 0 1 100 92 0 1 100 192 0 1 101 0 0 1 101 24 0 1 101 48 0 1 101 72 0 1 101 96 0 1 102 28 0 1 102 72 0 1 102 116 0 1 102 160 0 1 102 204 0 1 103 32 0 1 103 116 0 1 103 160 0 1 103 204 0 1 103 248 0 1 104 36 0 1 105 44 0 1 106 24 0 1 107 28 0 1 107 208 0 1 109 0 0 1 109 224 0 1 110 172 0 1 111 248 0 1 113 80 0 1 114 72 0 1 114 88 0 1 114 244 0 1 115 188 0 1 116 84 0 1 116 196 0 1 117 60 0 1 117 156 0 1 118 80 0 1 118 204 0 1 119 12 0 1 119 112 0 1 120 8 0 1 120 80 0 1 121 28 0 1 121 188 0 1 122 80 0 1 122 212 0 1 123 164 0 1 124 68 0 1 125 28 0 1 125 112 0 1 125 244 0 1 126 100 0 1 127 44 0 1 127 244 0 1 128 104 0 1 128 216 0 1 128 240 0 1 129 8 0 1 129 32 0 1 129 56 0 1 129 80 0 1 129 104 0 1 129 128 0 1 129 152 0 1 129 176 0 1 129 200 0 1 129 224 0 1 129 248 0 1 130 16 0 1 130 40 0 1 130 64 0 1 130 96 0 1 130 120 0 1 130 144 0 1 130 168 0 1 130 192 0 1 130 224 0 1 131 184 0 1 132 120 0 1 132 144 0 1 132 168 0 1 133 144 0 1 133 168 0 1 133 192 0 1 133 216 0 1 133 240 0 1 134 8 0 1 134 32 0 1 134 56 0 1 134 80 0 1 134 104 0 1 134 120 0 1 134 144 0 1 134 168 0 1 134 192 0 1 134 216 0 1 134 240 0 1 135 8 0 1 135 32 0 1 135 56 0 1 135 80 0 1 135 104 0 1 135 128 0 1 135 152 0 1 135 176 0 1 135 200 0 1 135 224 0 1 136 0 0 1 136 192 0 1 136 216 0 1 136 240 0 1 137 8 0 1 137 32 0 1 137 56 0 1 137 80 0 1 137 104 0 1 137 128 0 1 137 152 0 1 138 124 0 1 138 148 0 1 138 172 0 1 138 196 0 1 139 116 0 1 139 140 0 1 139 164 0 1 139 188 0 1 139 212 0 1 139 236 0 1 140 4 0 1 140 28 0 1 140 52 0 1 140 76 0 1 140 100 0 1 140 224 0 1 140 248 0 1 141 16 0 1 141 40 0 1 141 64 0 1 141 88 0 1 141 112 0 1 141 136 0 1 141 160 0 1 141 184 0 1 141 208 0 1 141 240 0 1 142 8 0 1 142 152 0 1 142 176 0 1 142 200 0 1 142 224 0 1 142 248 0 1 143 16 0 1 143 40 0 1 143 64 0 1 143 88 0 1 143 112 0 1 143 136 0 1 143 160 0 1 143 184 0 1 143 208 0 1 143 232 0 1 144 0 0 1 144 24 0 1 144 48 0 1 144 72 0 1 144 96 0 1 144 120 0 1 144 144 0 1 144 168 0 1 144 192 0 1 144 216 0 1 144 240 0 1 145 16 0 1 146 36 0 1 146 200 0 1 147 148 0 1 147 172 0 1 147 196 0 1 147 220 0 1 147 244 0 1 148 12 0 1 148 228 0 1 148 252 0 1 149 20 0 1 149 44 0 1 149 68 0 1 149 92 0 1 149 116 0 1 149 140 0 1 149 172 0 1 149 196 0 1 149 220 0 1 149 244 0 1 150 12 0 1 150 36 0 1 150 60 0 1 150 84 0 1 150 108 0 1 150 132 0 1 151 96 0 1 151 120 0 1 151 144 0 1 151 168 0 1 151 192 0 1 151 216 0 1 152 96 0 1 152 120 0 1 152 144 0 1 152 168 0 1 152 192 0 1 152 216 0 1 152 240 0 1 153 8 0 1 153 32 0 1 153 56 0 1 153 80 0 1 153 104 0 1 153 128 0 1 153 152 0 1 153 176 0 1 153 200 0 1 153 224 0 1 154 160 0 1 155 76 0 1 155 100 0 1 155 124 0 1 155 148 0 1 155 172 0 1 155 196 0 1 155 220 0 1 155 244 0 1 156 12 0 1 156 36 0 1 156 60 0 1 156 84 0 1 156 108 0 1 156 132 0 1 156 156 0 1 156 180 0 1 156 204 0 1 156 228 0 1 156 252 0 1 157 20 0 1 157 44 0 1 157 68 0 1 157 92 0 1 158 0 0 1 158 132 0 1 159 72 0 1 160 24 0 1 160 148 0 1 161 76 0 1 161 92 0 1 161 108 0 1 161 184 0 1 162 32 0 1 162 48 0 1 162 64 0 1 162 80 0 1 162 252 0 1 163 12 0 1 163 28 0 1 163 136 0 1 163 152 0 1 163 168 0 1 164 28 0 1 164 44 0 1 164 132 0 1 164 148 0 1 165 8 0 1 165 24 0 1 165 40 0 1 165 236 0 1 165 252 0 1 166 144 0 1 167 100 0 1 167 124 0 1 167 148 0 1 168 60 0 1 168 196 0 1 169 180 0 1 169 196 0 1 170 92 0 1 170 108 0 1 170 124 0 1 171 44 0 1 171 60 0 1 172 68 0 1 173 12 0 1 173 152 0 1 173 176 0 1 174 92 0 1 174 248 0 1 175 8 0 1 175 24 0 1 175 40 0 1 175 56 0 1 175 72 0 1 175 88 0 1 175 104 0 1 175 248 0 1 176 188 0 1 176 204 0 1 177 60 0 1 177 184 0 1 178 40 0 1 178 180 0 1 179 68 0 1 179 228 0 1 180 104 0 1 181 24 0 1 181 228 0 1 182 132 0 1 182 156 0 1 182 180 0 1 183 124 0 1 183 148 0 1 184 72 0 1 184 88 0 1 184 104 0 1 184 128 0 1 185 24 0 1 185 40 0 1 186 12 0 1 186 204 0 1 187 96 0 1 187 120 0 1 187 144 0 1 187 168 0 1 188 16 0 1 188 176 0 1 189 108 0 1 190 12 0 1 190 100 0 1 190 228 0 1 192 4 0 1 192 232 0 1 193 176 0 1 194 128 0 1 195 12 0 1 195 180 0 1 195 196 0 1 196 100 0 1 197 52 0 1 197 204 0 1 198 72 0 1 198 88 0 1 198 112 0 1 198 136 0 1 198 152 0 1 198 176 0 1 198 192 0 1 198 216 0 1 198 240 0 1 199 0 0 1 199 24 0 1 199 48 0 1 200 144 0 1 201 28 0 1 201 116 0 1 202 16 0 1 202 228 0 1 203 124 0 1 204 56 0 1 205 12 0 1 205 116 0 1 206 132 0 1 207 84 0 1 207 192 0 1 208 48 0 1 208 204 0 1 209 104 0 1 209 120 0 1 209 144 0 1 209 160 0 1 209 176 0 1 209 200 0 1 209 224 0 1 209 240 0 1 210 24 0 1 210 64 0 1 210 128 0 1 210 192 0 1 210 248 0 1 211 48 0 1 211 220 0 1 212 132 0 1 212 152 0 1 212 172 0 1 212 192 0 1 212 212 0 1 212 232 0 1 212 252 0 1 213 16 0 1 213 36 0 1 213 56 0 1 213 76 0 1 213 96 0 1 213 116 0 1 213 136 0 1 213 156 0 1 213 176 0 1 213 196 0 1 213 216 0 1 213 236 0 1 214 0 0 1 214 20 0 1 214 40 0 1 214 60 0 1 214 80 0 1 214 100 0 1 214 120 0 1 214 140 0 1 214 160 0 1 214 180 0 1 215 36 0 1 215 108 0 1 215 232 0 1 216 160 0 1 217 32 0 1 217 184 0 1 218 96 0 1 218 188 0 1 219 168 0 1 220 80 0 1 220 144 0 1 220 208 0 1 221 24 0 1 221 128 0 1 221 148 0 1 221 168 0 1 221 188 0 1 221 208 0 1 221 228 0 1 221 248 0 1 222 12 0 1 222 32 0 1 222 52 0 1 222 72 0 1 222 92 0 1 222 112 0 1 222 132 0 1 222 152 0 1 222 168 0 1 222 184 0 1 222 200 0 1 223 56 0 1 223 224 0 1 224 88 0 1 224 172 0 1 224 252 0 1 225 64 0 1 225 200 0 1 226 16 0 1 226 56 0 1 226 136 0 1 226 236 0 1 227 28 0 1 227 172 0 1 228 24 0 1 228 144 0 1 228 236 0 1 229 152 0 1 230 12 0 1 230 192 0 1 230 248 0 1 231 92 0 1 231 176 0 1 232 96 0 1 232 244 0 1 233 80 0 1 233 160 0 1 234 64 0 1 234 240 0 1 235 100 0 1 236 8 0 1 236 172 0 1 237 28 0 1 238 76 0 1 238 168 0 1 238 248 0 1 239 112 0 1 239 212 0 1 240 28 0 1 240 196 0 1 241 48 0 1 241 168 0 1 242 84 0 1 242 244 0 1 243 84 0 1 244 16 0 1 244 144 0 1 245 16 0 1 245 100 0 1 245 248 0 1 246 136 0 1 247 28 0 1 247 108 0 1 247 200 0 1 248 24 0 1 248 64 0 1 248 140 0 1 249 76 0 1 250 8 0 1 250 196 0 1 251 96 0 1 252 24 0 1 252 236 0 1 253 20 0 1 253 116 0 1 253 152 0 1 253 192 0 1 253 232 0 1 254 96 0 1 255 40 0 2 0 44 0 2 1 8 0 2 1 204 0 2 2 100 0 2 3 108 0 2 4 28 0 2 4 196 0 2 6 28 0 2 7 28 0 2 8 76 0 2 9 28 0 2 10 64 0 2 11 24 0 2 12 36 0 2 13 12 0 2 14 40 0 2 14 248 0 2 15 188 0 2 16 136 0 2 17 60 0 2 17 168 0 2 18 116 0 2 18 172 0 2 18 188 0 2 18 204 0 2 18 240 0 2 20 100 0 2 20 136 0 2 20 172 0 2 20 208 0 2 20 244 0 2 21 24 0 2 21 60 0 2 21 96 0 2 21 132 0 2 21 168 0 2 21 204 0 2 21 240 0 2 22 20 0 2 22 56 0 2 22 92 0 2 22 128 0 2 22 164 0 2 22 200 0 2 23 196 0 2 23 232 0 2 24 44 0 2 24 84 0 2 24 148 0 2 25 16 0 2 25 36 0 2 25 60 0 2 25 128 0 2 25 192 0 2 26 20 0 2 26 104 0 2 26 212 0 2 27 28 0 2 27 148 0 2 28 16 0 2 28 40 0 2 28 84 0 2 29 100 0 2 29 116 0 2 30 76 0 2 30 208 0 2 31 32 0 2 31 48 0 2 31 64 0 2 31 160 0 2 31 224 0 2 32 172 0 2 33 136 0 2 33 196 0 2 34 24 0 2 34 84 0 2 34 168 0 2 34 208 0 2 34 252 0 2 35 188 0 2 36 4 0 2 36 48 0 2 36 108 0 2 36 164 0 2 37 8 0 2 37 56 0 2 37 120 0 2 37 180 0 2 38 28 0 2 38 116 0 2 39 12 0 2 39 84 0 2 39 220 0 2 40 84 0 2 40 128 0 2 40 152 0 2 40 196 0 2 40 212 0 2 40 228 0 2 40 244 0 2 41 8 0 2 41 28 0 2 41 48 0 2 41 68 0 2 41 88 0 2 41 108 0 2 41 148 0 2 41 168 0 2 41 184 0 2 41 200 0 2 41 216 0 2 41 236 0 2 42 0 0 2 42 20 0 2 42 40 0 2 42 60 0 2 42 80 0 2 42 100 0 2 42 120 0 2 42 140 0 2 44 212 0 2 45 8 0 2 45 60 0 2 45 100 0 2 45 152 0 2 45 204 0 2 45 244 0 2 46 68 0 2 46 148 0 2 47 28 0 2 47 152 0 2 47 188 0 2 47 240 0 2 48 0 0 2 48 16 0 2 48 120 0 2 48 224 0 2 49 64 0 2 49 164 0 2 49 220 0 2 50 32 0 2 50 136 0 2 50 252 0 2 51 84 0 2 51 172 0 2 52 12 0 2 52 108 0 2 52 160 0 2 52 240 0 2 53 60 0 2 53 136 0 2 53 176 0 2 53 244 0 2 54 72 0 2 54 168 0 2 55 12 0 2 55 84 0 2 55 152 0 2 55 220 0 2 55 236 0 2 56 24 0 2 56 68 0 2 56 124 0 2 56 192 0 2 57 12 0 2 57 80 0 2 57 132 0 2 57 200 0 2 57 236 0 2 58 0 0 2 58 20 0 2 58 40 0 2 58 116 0 2 58 192 0 2 59 16 0 2 59 96 0 2 59 172 0 2 60 0 0 2 60 40 0 2 60 84 0 2 60 104 0 2 60 124 0 2 60 144 0 2 60 164 0 2 60 184 0 2 60 204 0 2 61 20 0 2 61 64 0 2 61 124 0 2 62 28 0 2 62 116 0 2 62 132 0 2 62 148 0 2 62 220 0 2 63 32 0 2 63 160 0 2 64 48 0 2 64 176 0 2 65 44 0 2 65 184 0 2 66 56 0 2 66 252 0 2 67 124 0 2 68 4 0 2 68 156 0 2 69 64 0 2 69 148 0 2 69 244 0 2 70 72 0 2 70 172 0 2 71 40 0 2 71 172 0 2 72 72 0 2 72 244 0 2 73 112 0 2 73 236 0 2 74 104 0 2 74 228 0 2 75 132 0 2 76 36 0 2 76 216 0 2 77 136 0 2 78 12 0 2 78 148 0 2 78 212 0 2 79 28 0 2 79 140 0 2 79 252 0 2 80 160 0 2 81 20 0 2 81 136 0 2 82 44 0 2 82 44 0 2 82 44 0 2 82 44 0 2 82 44 0 2 82 44 0 2 82 44 0 2 82 68 0 2 82 92 0 5 0 89 0 0 2 53 2 148 0 3 0 9 0 15 0 18 0 21 0 113 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 4 0 1 244 186 0 8 0 0 0 1 17 18 57 186 0 11 0 0 0 1 17 18 57 184 0 1 16 185 0 13 0 1 244 186 0 16 0 0 0 1 17 18 57 186 0 18 0 0 0 1 17 18 57 186 0 19 0 0 0 1 17 18 57 186 0 20 0 0 0 1 17 18 57 48 49 51 17 33 17 37 33 47 1 35 7 55 51 63 1 35 23 3 55 39 1 17 7 89 1 220 254 144 1 1 73 52 4 54 54 4 49 66 235 66 121 127 127 1 88 126 2 148 253 108 58 132 103 103 197 94 119 119 254 141 230 232 254 50 1 206 232 0 0 0 0 2 0 3 0 0 2 29 2 144 0 9 0 17 0 84 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 17 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 5 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 186 0 16 0 17 0 11 17 18 57 184 0 16 47 185 0 1 0 1 244 186 0 7 0 17 0 11 17 18 57 48 49 19 7 51 39 46 1 39 35 14 1 3 19 51 19 35 39 35 7 203 31 197 31 18 32 16 4 15 32 218 222 94 222 89 62 239 63 1 111 100 100 55 109 57 57 109 254 90 2 144 253 112 200 200 0 0 0 0 3 0 90 0 0 2 36 2 144 0 19 0 28 0 37 0 87 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 36 0 1 0 0 17 18 57 184 0 36 47 186 0 11 0 36 0 21 17 18 57 185 0 20 0 1 244 184 0 1 16 185 0 28 0 2 244 184 0 0 16 185 0 29 0 2 244 48 49 51 17 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 35 3 51 50 54 53 52 38 43 1 17 51 50 54 53 52 38 43 1 90 195 50 83 59 33 49 47 60 74 36 66 92 55 126 97 84 74 77 77 101 114 85 94 92 87 114 2 144 18 38 61 43 49 79 15 4 11 78 68 48 72 48 24 1 121 58 50 57 48 253 244 63 66 61 57 0 0 0 0 1 0 52 255 244 2 27 2 156 0 33 0 57 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 17 0 2 244 184 0 0 16 185 0 27 0 2 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 23 14 1 1 82 62 104 77 43 44 78 106 63 60 91 29 45 26 66 42 47 76 54 29 29 52 75 47 48 72 32 46 39 98 12 46 87 127 80 79 126 88 47 49 32 54 28 34 37 69 98 61 62 99 70 38 39 35 52 45 50 0 0 2 0 90 0 0 2 52 2 144 0 10 0 19 0 53 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 12 0 2 244 184 0 1 16 185 0 18 0 2 244 48 49 51 17 51 50 22 21 20 14 2 35 39 51 50 54 53 52 38 43 1 90 164 152 158 40 78 114 74 85 75 115 115 115 115 75 2 144 168 157 78 123 85 45 68 138 125 125 132 0 1 0 90 0 0 1 222 2 144 0 11 0 77 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 1 16 185 0 4 0 2 244 186 0 8 0 1 0 0 17 18 57 184 0 8 47 185 0 6 0 1 244 184 0 0 16 185 0 9 0 2 244 48 49 51 17 33 21 33 21 51 21 35 21 33 21 90 1 122 254 217 249 249 1 49 2 144 70 206 71 238 71 0 0 1 0 90 0 0 1 212 2 144 0 9 0 67 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 1 16 185 0 4 0 2 244 186 0 8 0 1 0 0 17 18 57 184 0 8 47 185 0 6 0 1 244 48 49 51 17 33 21 33 21 51 21 35 17 90 1 122 254 217 250 250 2 144 70 222 70 254 218 0 0 0 0 1 0 52 255 244 2 38 2 156 0 39 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 19 0 2 244 184 0 0 16 185 0 29 0 2 244 186 0 34 0 10 0 0 17 18 57 184 0 34 47 185 0 36 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 53 35 53 51 17 14 1 1 92 65 109 78 44 45 80 111 65 34 57 47 37 14 46 25 66 50 50 80 56 31 29 55 81 53 35 63 20 139 215 32 104 12 46 87 127 80 79 126 88 47 14 23 29 15 54 26 36 37 69 98 61 62 99 70 38 21 18 171 69 254 236 33 43 0 1 0 90 0 0 2 50 2 144 0 11 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 10 0 1 0 0 17 18 57 184 0 10 47 185 0 4 0 1 244 184 0 1 16 184 0 5 208 184 0 0 16 184 0 8 208 48 49 51 17 51 17 33 17 51 17 35 17 33 17 90 83 1 49 84 84 254 207 2 144 254 237 1 19 253 112 1 53 254 203 0 0 1 0 90 0 0 0 173 2 144 0 3 0 37 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 48 49 51 17 51 17 90 83 2 144 253 112 0 0 0 0 1 0 31 255 244 1 137 2 144 0 16 0 43 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 6 0 2 244 48 49 23 34 39 55 30 1 51 50 54 53 17 51 17 20 14 2 212 123 58 60 22 56 35 53 52 84 21 43 69 12 105 42 39 35 65 75 1 199 254 49 42 75 56 32 0 0 0 0 1 0 90 0 0 2 63 2 144 0 12 0 101 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 186 0 3 0 1 0 0 17 18 57 186 0 7 0 5 0 9 17 18 57 186 0 10 0 5 0 9 17 18 57 48 49 51 17 51 17 51 1 51 7 19 35 3 7 21 90 83 3 1 17 94 205 237 93 196 113 2 144 254 183 1 73 250 254 106 1 85 133 208 0 1 0 90 0 0 1 204 2 144 0 5 0 43 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 3 0 2 244 48 49 51 17 51 17 33 21 90 83 1 31 2 144 253 183 71 0 1 0 90 0 0 2 125 2 144 0 29 0 93 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 7 0 13 0 18 17 18 57 186 0 7 0 12 0 13 17 18 57 184 0 1 16 184 0 11 208 184 0 0 16 184 0 14 208 186 0 22 0 0 0 1 17 18 57 186 0 25 0 1 0 0 17 18 57 48 49 51 17 51 19 30 1 23 51 62 1 55 19 51 17 35 17 52 54 55 35 7 3 35 3 39 35 30 1 21 17 90 100 126 12 23 12 4 12 21 12 124 101 78 8 3 4 52 124 55 124 52 4 3 7 2 144 254 162 34 69 34 34 69 34 1 94 253 112 1 105 44 106 44 149 254 172 1 84 149 44 106 44 254 151 0 0 1 0 90 0 0 2 45 2 144 0 19 0 91 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 186 0 5 0 12 0 9 17 18 57 186 0 15 0 1 0 0 17 18 57 48 49 51 17 51 19 23 51 46 1 53 17 51 17 35 3 39 35 30 1 21 17 90 86 237 71 4 3 7 79 86 238 71 4 4 7 2 144 254 100 136 50 107 52 1 83 253 112 1 157 135 50 103 52 254 169 0 0 2 0 52 255 244 2 101 2 156 0 19 0 39 0 53 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 20 0 2 244 184 0 10 16 185 0 30 0 2 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 76 62 103 74 41 41 74 103 62 62 103 75 41 41 75 103 62 44 71 51 28 28 51 71 44 44 71 51 28 28 51 71 12 48 89 127 79 79 125 87 46 47 87 125 78 79 127 89 48 73 38 71 99 62 61 98 68 37 37 68 98 61 62 99 71 38 0 2 0 90 0 0 2 11 2 144 0 14 0 23 0 67 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 13 0 1 0 0 17 18 57 184 0 13 47 185 0 16 0 1 244 184 0 1 16 185 0 23 0 2 244 48 49 51 17 51 50 30 2 21 20 14 2 43 1 25 1 51 50 54 53 52 38 43 1 90 187 55 91 64 36 35 64 89 54 108 98 86 83 87 86 94 2 144 20 45 74 54 52 76 50 25 254 252 1 72 65 70 71 55 0 2 0 52 255 91 2 115 2 156 0 19 0 54 0 75 0 184 0 0 69 88 184 0 35 47 27 185 0 35 0 17 62 89 184 0 0 69 88 184 0 25 47 27 185 0 25 0 5 62 89 187 0 48 0 2 0 20 0 4 43 184 0 25 16 185 0 0 0 2 244 184 0 35 16 185 0 10 0 2 244 184 0 25 16 184 0 45 208 48 49 37 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 23 34 46 2 39 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 30 1 51 50 54 55 23 14 1 1 76 44 71 51 28 28 51 71 44 44 71 51 28 28 51 71 245 45 77 61 45 14 54 88 63 34 41 74 103 62 62 103 75 41 33 61 86 52 23 84 54 22 33 14 16 15 50 57 38 72 101 63 61 98 68 37 37 68 98 61 63 101 72 38 222 23 42 57 34 7 54 88 119 72 79 125 87 46 47 87 125 78 71 117 87 55 9 44 43 5 4 64 6 9 0 0 2 0 90 0 0 2 32 2 144 0 15 0 24 0 92 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 5 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 186 0 17 0 1 0 15 17 18 57 184 0 17 47 186 0 10 0 17 0 13 17 18 57 184 0 14 220 184 0 1 16 185 0 24 0 2 244 48 49 51 17 51 50 30 2 21 20 6 7 19 35 3 35 25 1 51 50 54 53 52 38 43 1 90 205 50 85 61 34 80 68 167 94 158 119 110 77 82 82 77 110 2 144 19 44 70 51 77 92 17 254 226 1 21 254 235 1 89 63 64 65 52 0 0 1 0 42 255 244 1 239 2 156 0 51 0 73 0 184 0 0 69 88 184 0 26 47 27 185 0 26 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 2 244 186 0 15 0 0 0 26 17 18 57 184 0 26 16 185 0 33 0 2 244 186 0 41 0 26 0 0 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 46 2 47 1 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 30 2 31 1 30 3 21 20 14 2 1 16 69 118 43 50 35 95 51 65 72 17 29 40 23 94 23 48 38 24 31 55 75 45 59 100 35 45 30 73 46 55 67 19 32 38 20 93 28 50 36 21 31 58 82 12 52 45 58 37 45 59 48 25 35 25 20 11 41 10 28 40 55 36 37 64 47 26 45 36 54 29 33 51 45 24 33 25 19 8 40 12 31 41 55 36 39 68 51 29 0 0 0 0 1 0 28 0 0 1 252 2 144 0 7 0 51 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 3 16 185 0 1 0 2 244 184 0 6 208 48 49 51 17 35 53 33 21 35 17 226 198 1 224 198 2 74 70 70 253 182 0 1 0 87 255 244 2 46 2 144 0 25 0 51 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 13 0 2 244 184 0 6 16 184 0 19 208 48 49 5 34 46 2 53 17 51 17 20 30 2 51 50 62 2 53 17 51 17 20 14 2 1 67 50 87 63 36 83 24 41 56 32 33 56 42 24 80 36 63 86 12 29 67 108 79 1 129 254 125 59 80 48 21 21 48 80 59 1 131 254 127 79 108 67 29 0 0 1 0 0 0 0 2 3 2 144 0 13 0 64 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 6 0 1 0 0 17 18 57 48 49 51 3 51 19 30 1 23 51 62 1 55 19 51 3 210 210 89 105 18 27 19 4 18 28 17 105 85 208 2 144 254 158 59 100 58 58 100 59 1 98 253 112 0 1 0 23 0 0 2 250 2 144 0 33 0 118 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 17 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 24 47 27 185 0 24 0 5 62 89 186 0 6 0 1 0 0 17 18 57 186 0 16 0 21 0 24 17 18 57 186 0 29 0 0 0 11 17 18 57 48 49 51 3 51 19 30 1 23 51 62 1 55 19 51 19 30 1 23 51 62 1 55 19 51 3 35 3 46 1 39 35 14 1 7 3 162 139 86 69 9 20 9 4 11 24 11 91 76 91 12 24 12 4 9 18 10 69 80 136 100 99 9 15 8 4 8 17 8 97 2 144 254 155 54 104 54 54 105 53 1 101 254 155 52 106 54 54 105 53 1 101 253 112 1 139 38 73 38 38 73 38 254 117 0 0 0 1 0 15 0 0 1 242 2 144 0 25 0 91 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 17 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 5 62 89 186 0 7 0 2 0 0 17 18 57 186 0 20 0 16 0 12 17 18 57 48 49 51 19 3 51 23 30 1 23 51 62 1 63 1 51 3 19 35 39 46 1 39 35 14 1 15 1 15 191 178 92 89 13 23 15 4 14 21 12 87 88 179 191 92 96 13 27 16 4 14 26 12 95 1 83 1 61 168 23 43 29 29 43 23 168 254 191 254 177 177 24 51 30 30 51 24 177 0 0 0 0 1 255 255 0 0 1 221 2 144 0 15 0 64 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 17 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 7 0 2 0 0 17 18 57 48 49 51 53 3 51 23 30 1 23 51 62 1 63 1 51 3 21 196 197 89 85 16 30 17 4 17 34 15 84 87 197 254 1 146 185 36 70 37 37 70 36 185 254 110 254 0 0 0 1 0 45 0 0 1 241 2 144 0 9 0 69 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 17 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 185 0 7 0 2 244 184 0 1 208 184 0 1 47 184 0 4 16 185 0 2 0 2 244 184 0 6 208 184 0 6 47 48 49 51 53 1 33 53 33 21 1 33 21 45 1 89 254 198 1 162 254 166 1 93 50 2 24 70 49 253 232 71 0 2 0 52 255 244 1 177 1 242 0 27 0 39 0 113 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 6 0 18 0 0 17 18 57 184 0 6 47 184 0 18 16 185 0 11 0 1 244 184 0 0 16 184 0 23 208 184 0 23 47 186 0 24 0 0 0 18 17 18 57 184 0 0 16 185 0 28 0 1 244 184 0 24 16 185 0 31 0 1 244 184 0 6 16 185 0 32 0 1 244 48 49 23 34 38 53 52 54 55 52 46 2 35 34 6 7 39 62 1 51 50 22 21 17 35 39 35 14 1 39 50 54 55 53 14 3 21 20 22 194 61 81 142 156 9 22 39 30 42 74 29 32 34 98 59 89 80 68 7 3 35 80 22 35 62 35 61 83 51 23 50 12 72 66 80 85 17 23 44 34 21 32 20 57 22 41 109 91 254 214 58 29 41 66 33 32 135 8 22 30 39 23 42 36 0 0 2 0 82 255 244 1 251 2 200 0 22 0 38 0 122 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 9 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 4 0 0 0 13 17 18 57 184 0 5 208 184 0 5 47 186 0 10 0 13 0 0 17 18 57 184 0 0 16 185 0 23 0 1 244 184 0 13 16 185 0 33 0 1 244 184 0 10 16 185 0 35 0 1 244 184 0 4 16 185 0 36 0 1 244 48 49 5 34 38 39 35 7 35 17 51 21 7 62 1 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 7 21 30 1 1 41 34 73 32 3 7 66 82 2 33 78 41 47 72 49 25 34 58 76 56 30 51 37 21 14 31 49 34 59 71 32 63 12 33 29 50 2 200 194 88 29 39 35 65 91 56 62 98 68 35 69 27 49 72 45 40 66 47 26 66 255 28 23 0 0 0 0 1 0 46 255 244 1 175 1 242 0 33 0 57 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 17 0 1 244 184 0 0 16 185 0 27 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 23 14 1 1 18 48 84 61 35 38 64 85 47 48 68 26 42 21 47 29 33 56 40 23 22 39 56 33 34 57 23 36 33 80 12 34 65 95 60 61 95 66 34 34 23 54 19 24 27 50 69 42 42 68 49 27 29 20 55 29 33 0 0 2 0 47 255 244 1 217 2 200 0 20 0 35 0 122 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 9 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 11 0 8 0 0 17 18 57 184 0 16 208 184 0 16 47 186 0 17 0 0 0 8 17 18 57 184 0 0 16 185 0 21 0 1 244 184 0 17 16 185 0 24 0 1 244 184 0 11 16 185 0 25 0 1 244 184 0 8 16 185 0 28 0 1 244 48 49 23 34 38 53 52 62 2 51 50 22 23 39 53 51 17 35 39 35 14 1 39 50 54 55 53 46 1 35 34 14 2 21 20 22 248 92 109 35 58 76 42 42 62 32 4 83 68 7 3 29 75 25 34 60 30 31 57 30 29 51 38 22 70 12 132 122 59 95 66 36 30 26 83 187 253 56 57 28 41 69 33 34 254 28 23 27 49 68 42 88 98 0 0 0 0 2 0 46 255 244 1 202 1 242 0 28 0 37 0 81 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 19 0 10 0 0 17 18 57 184 0 19 47 184 0 0 16 185 0 22 0 1 244 184 0 19 16 185 0 30 0 1 244 184 0 10 16 185 0 33 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 6 7 33 30 1 51 50 54 55 23 14 1 3 33 52 38 35 34 14 2 1 23 49 85 63 36 37 61 78 42 46 73 49 26 1 2 254 184 5 87 70 35 59 27 29 32 78 203 1 4 63 57 26 47 38 25 12 35 65 94 60 60 95 66 35 32 60 84 52 13 25 9 78 91 21 17 54 20 30 1 38 74 77 20 39 56 0 0 0 0 1 0 30 0 0 1 63 2 212 0 21 0 86 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 9 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 19 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 5 62 89 184 0 17 16 185 0 20 0 1 244 184 0 1 208 184 0 17 16 184 0 4 208 184 0 8 16 185 0 14 0 1 244 48 49 51 17 35 53 55 53 52 54 51 50 22 23 7 38 35 34 29 1 51 21 35 17 96 66 66 69 73 23 41 17 18 27 28 68 103 103 1 163 62 5 77 75 86 9 7 63 12 94 77 67 254 93 0 3 0 45 255 32 1 236 1 242 0 55 0 71 0 89 0 135 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 186 0 47 0 0 0 24 17 18 57 184 0 47 47 185 0 80 0 1 244 186 0 9 0 47 0 80 17 18 57 186 0 38 0 24 0 0 17 18 57 184 0 38 47 185 0 56 0 1 244 186 0 16 0 56 0 38 17 18 57 184 0 24 16 184 0 28 208 184 0 28 47 185 0 29 0 1 244 184 0 24 16 185 0 64 0 1 244 184 0 0 16 185 0 72 0 1 244 48 49 23 34 46 2 53 52 54 55 53 46 1 53 52 54 55 53 46 1 53 52 62 2 51 50 22 23 51 21 35 30 1 21 20 14 2 35 34 38 39 14 1 21 20 22 59 1 50 22 21 20 14 2 3 50 62 2 53 52 38 35 34 6 21 20 30 2 19 50 62 2 53 52 38 43 1 34 38 39 14 1 21 20 22 246 45 74 53 29 38 33 18 25 34 19 24 39 29 50 67 37 20 35 14 169 100 17 23 28 48 65 37 18 38 17 13 18 36 50 94 85 85 34 64 91 57 21 37 29 16 60 43 43 60 16 29 37 33 35 57 40 22 50 48 84 14 33 16 26 24 75 224 17 34 48 32 31 56 23 4 11 39 29 31 46 13 4 20 67 44 40 64 45 24 7 5 63 17 52 31 39 63 43 24 9 8 11 27 20 23 30 55 61 34 61 46 27 1 177 16 30 43 27 54 59 59 54 27 43 30 16 254 136 17 27 36 19 34 26 3 5 19 42 21 39 46 0 0 0 1 0 82 0 0 1 215 2 200 0 20 0 88 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 9 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 4 0 7 0 0 17 18 57 184 0 12 208 184 0 7 16 185 0 16 0 1 244 184 0 4 16 185 0 19 0 1 244 48 49 51 17 51 21 7 62 1 51 50 22 21 17 35 17 52 38 35 34 6 7 17 82 82 3 35 76 51 77 71 82 44 48 38 58 37 2 200 194 100 33 47 96 94 254 204 1 41 69 61 38 37 254 160 0 0 2 0 67 0 0 0 181 2 180 0 3 0 15 0 53 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 1 16 184 0 4 208 184 0 4 47 184 0 10 208 48 49 51 17 51 17 3 34 38 53 52 54 51 50 22 21 20 6 82 82 40 24 33 33 24 24 33 33 1 230 254 26 2 74 30 23 24 29 29 24 23 30 0 0 0 0 2 255 216 255 39 0 181 2 180 0 15 0 27 0 59 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 185 0 7 0 1 244 184 0 11 16 184 0 16 208 184 0 16 47 184 0 22 208 48 49 23 34 38 39 55 30 1 51 50 54 53 17 51 17 20 6 19 34 38 53 52 54 51 50 22 21 20 6 32 23 36 13 17 9 24 13 36 24 82 60 20 24 33 33 24 23 33 33 217 8 5 62 3 5 50 45 2 29 253 227 74 88 3 35 30 23 24 29 29 24 23 30 0 0 1 0 82 0 0 1 230 2 200 0 12 0 101 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 9 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 186 0 3 0 1 0 0 17 18 57 186 0 7 0 5 0 9 17 18 57 186 0 10 0 1 0 9 17 18 57 48 49 51 17 51 17 51 19 51 7 19 35 39 7 21 82 81 3 207 91 163 185 90 142 91 2 200 254 30 1 0 195 254 221 234 106 128 0 0 0 1 0 82 255 244 0 216 2 200 0 15 0 43 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 9 0 1 244 48 49 23 34 38 53 17 51 17 20 22 51 58 1 55 23 14 1 169 47 40 82 14 9 4 7 7 11 8 22 12 56 54 2 102 253 148 20 16 2 62 4 4 0 0 0 1 0 82 0 0 2 241 1 242 0 33 0 137 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 3 0 1 0 0 17 18 57 184 0 1 16 184 0 7 208 184 0 7 47 186 0 10 0 1 0 0 17 18 57 184 0 13 208 184 0 13 47 184 0 0 16 184 0 26 208 184 0 26 47 184 0 18 208 184 0 18 47 184 0 13 16 185 0 22 0 1 244 184 0 10 16 185 0 24 0 1 244 184 0 7 16 185 0 30 0 1 244 184 0 3 16 185 0 32 0 1 244 48 49 51 17 51 23 51 62 1 51 50 22 23 62 1 51 50 22 21 17 35 17 52 38 35 34 7 17 35 17 52 38 35 34 7 17 82 68 7 3 32 75 44 56 63 15 38 77 45 75 73 82 44 46 55 67 82 44 47 55 67 1 230 70 35 47 49 44 42 51 96 94 254 204 1 41 69 61 75 254 160 1 41 69 61 75 254 160 0 0 0 0 1 0 82 0 0 1 215 1 242 0 20 0 91 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 3 0 1 0 0 17 18 57 184 0 1 16 184 0 7 208 184 0 7 47 184 0 0 16 184 0 12 208 184 0 12 47 184 0 7 16 185 0 16 0 1 244 184 0 3 16 185 0 19 0 1 244 48 49 51 17 51 23 51 62 1 51 50 22 21 17 35 17 52 38 35 34 6 7 17 82 68 7 3 35 77 51 77 71 82 44 48 38 58 37 1 230 70 35 47 96 94 254 204 1 41 69 61 38 37 254 160 0 0 0 2 0 46 255 244 1 240 1 242 0 19 0 39 0 53 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 20 0 1 244 184 0 10 16 185 0 30 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 15 45 81 62 37 37 62 81 45 45 81 62 37 37 62 81 45 31 52 37 20 20 37 52 31 31 52 37 20 20 37 52 12 34 65 95 60 61 95 66 34 34 66 95 61 60 95 65 34 68 27 49 68 42 42 69 50 27 27 50 69 42 42 68 49 27 0 2 0 82 255 51 1 251 1 242 0 22 0 39 0 126 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 9 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 184 0 7 16 184 0 1 208 184 0 1 47 186 0 3 0 7 0 17 17 18 57 186 0 20 0 17 0 7 17 18 57 184 0 17 16 185 0 23 0 1 244 184 0 7 16 185 0 33 0 1 244 184 0 3 16 185 0 36 0 1 244 184 0 20 16 185 0 37 0 1 244 48 49 23 17 51 23 51 62 1 51 50 30 2 21 20 14 2 35 34 38 39 23 21 19 50 62 2 53 52 46 2 35 34 6 7 21 30 1 82 68 7 3 33 79 43 47 72 48 25 34 58 76 42 34 67 34 2 119 30 51 37 21 14 31 49 34 31 63 36 33 62 205 2 179 56 28 40 35 65 91 57 62 97 68 35 30 26 85 164 1 6 27 49 72 45 40 66 47 26 34 32 255 28 23 0 2 0 47 255 51 1 217 1 242 0 20 0 35 0 126 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 9 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 186 0 2 0 5 0 13 17 18 57 186 0 16 0 13 0 5 17 18 57 184 0 13 16 184 0 19 208 184 0 19 47 184 0 5 16 185 0 21 0 1 244 184 0 2 16 185 0 24 0 1 244 184 0 16 16 185 0 25 0 1 244 184 0 13 16 185 0 28 0 1 244 48 49 5 53 55 14 1 35 34 38 53 52 62 2 51 50 22 23 51 55 51 17 3 50 54 55 53 46 1 35 34 14 2 21 20 22 1 134 4 29 75 42 92 109 35 58 76 42 42 64 33 2 8 66 207 34 60 30 31 57 30 29 51 38 22 70 205 173 88 29 39 132 122 59 95 66 36 29 29 46 253 77 1 6 33 34 254 28 23 27 49 68 42 88 98 0 0 1 0 82 0 0 1 94 1 242 0 17 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 3 0 1 0 0 17 18 57 184 0 1 16 184 0 7 208 184 0 7 47 184 0 13 220 184 0 3 16 185 0 16 0 1 244 48 49 51 17 51 23 51 62 1 51 50 23 7 46 1 35 34 6 7 17 82 68 7 3 25 71 42 29 23 16 12 20 15 31 67 25 1 230 88 46 54 10 72 4 4 50 62 254 200 0 0 0 1 0 28 255 244 1 131 1 242 0 49 0 73 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 186 0 15 0 0 0 25 17 18 57 184 0 25 16 185 0 32 0 1 244 186 0 40 0 25 0 0 17 18 57 48 49 23 34 38 39 55 30 1 51 50 54 53 52 46 2 39 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 30 2 23 30 3 21 20 14 2 209 52 94 35 41 32 67 44 48 48 20 31 40 20 26 52 41 26 23 43 62 39 46 77 28 39 25 54 32 46 43 18 30 39 21 26 53 42 27 23 45 67 12 38 29 55 26 32 44 32 19 28 21 16 8 9 23 33 44 31 29 51 37 21 32 23 52 19 24 42 28 17 25 19 15 8 10 22 33 48 34 30 52 40 23 0 0 0 1 0 24 255 244 1 69 2 110 0 25 0 79 0 124 184 0 11 47 24 184 0 0 69 88 184 0 9 47 27 185 0 9 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 9 16 185 0 6 0 1 244 184 0 9 16 184 0 13 208 184 0 6 16 184 0 14 208 184 0 0 16 185 0 19 0 1 244 48 49 23 34 46 2 53 17 35 53 63 1 51 21 51 21 35 17 20 22 51 50 54 55 23 14 1 235 39 53 33 14 72 76 10 69 131 131 33 42 13 30 12 16 20 47 12 24 42 60 36 1 13 62 5 136 136 67 254 242 45 49 8 5 62 7 11 0 0 0 1 0 75 255 244 1 206 1 230 0 20 0 83 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 9 0 1 244 186 0 17 0 4 0 0 17 18 57 184 0 17 16 185 0 12 0 1 244 184 0 4 16 184 0 13 208 184 0 0 16 184 0 15 208 184 0 15 47 48 49 23 34 38 53 17 51 17 20 22 51 50 54 55 17 51 17 35 39 35 14 1 224 78 71 83 43 48 38 58 35 82 68 7 3 34 75 12 96 94 1 52 254 215 69 61 39 43 1 89 254 26 76 40 48 0 0 1 0 12 0 0 1 199 1 230 0 13 0 64 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 6 0 1 0 0 17 18 57 48 49 51 3 51 19 30 1 23 51 62 1 55 19 51 3 187 175 85 92 11 23 11 4 11 22 11 92 81 172 1 230 254 236 36 72 35 35 72 36 1 20 254 26 0 1 0 24 0 0 2 182 1 230 0 33 0 91 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 6 0 0 0 1 17 18 57 184 0 1 16 184 0 11 208 184 0 0 16 184 0 24 208 184 0 11 16 184 0 21 208 186 0 16 0 24 0 21 17 18 57 186 0 29 0 1 0 33 17 18 57 48 49 51 3 51 19 30 1 23 51 62 1 55 19 51 19 30 1 23 51 62 1 55 19 51 3 35 3 46 1 39 35 14 1 7 3 159 135 84 72 8 14 7 4 8 16 9 75 80 76 9 17 8 4 8 14 8 71 78 130 100 70 9 15 9 4 8 16 10 68 1 230 254 231 35 66 34 34 67 34 1 25 254 231 35 66 34 34 66 35 1 25 254 26 1 5 35 68 37 37 69 35 254 252 0 0 1 0 14 0 0 1 176 1 230 0 25 0 73 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 2 16 184 0 12 208 184 0 0 16 184 0 16 208 186 0 7 0 12 0 16 17 18 57 186 0 21 0 2 0 0 17 18 57 48 49 51 55 39 51 23 30 1 23 51 62 1 63 1 51 7 23 35 39 46 1 39 35 14 1 15 1 14 159 147 89 65 11 24 13 4 11 22 11 59 86 147 158 89 71 13 26 14 4 13 24 12 66 254 232 107 20 41 20 20 41 20 107 241 245 113 22 44 21 21 43 23 113 0 0 1 0 12 255 47 1 199 1 230 0 28 0 71 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 185 0 7 0 1 244 186 0 11 0 0 0 12 17 18 57 186 0 17 0 12 0 0 17 18 57 184 0 12 16 184 0 22 208 48 49 23 34 38 39 55 30 1 51 50 54 63 1 3 51 19 30 1 23 51 62 1 55 19 51 3 14 3 90 17 28 12 16 8 20 9 42 53 15 11 195 85 99 11 25 11 4 11 20 10 87 80 183 13 32 44 56 209 5 5 65 2 5 59 45 36 1 231 254 243 32 71 34 33 72 32 1 13 253 242 36 62 45 26 0 1 0 31 0 0 1 143 1 230 0 9 0 69 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 9 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 185 0 7 0 1 244 184 0 1 208 184 0 1 47 184 0 4 16 185 0 2 0 1 244 184 0 6 208 184 0 6 47 48 49 51 53 1 35 53 33 21 1 33 21 31 1 0 228 1 76 255 0 1 8 44 1 119 67 44 254 137 67 0 255 255 0 3 0 0 2 29 3 99 2 38 0 2 0 0 0 7 7 32 1 15 0 0 255 255 0 3 0 0 2 29 3 99 2 38 0 2 0 0 0 7 7 35 1 15 0 0 255 255 0 3 0 0 2 29 3 70 2 38 0 2 0 0 0 7 7 38 1 15 0 0 255 255 0 3 0 0 2 29 3 73 2 38 0 2 0 0 0 7 7 40 1 15 0 0 255 255 0 3 0 0 2 29 3 45 2 38 0 2 0 0 0 7 7 52 1 15 0 0 255 255 0 3 0 0 2 29 3 24 2 38 0 2 0 0 0 7 7 42 1 15 0 0 255 255 0 3 0 0 2 29 3 74 2 38 0 2 0 0 0 7 7 47 1 15 0 0 255 255 0 3 0 0 2 29 3 112 2 38 0 2 0 0 0 7 7 56 1 15 0 0 255 255 0 3 0 0 2 29 3 77 2 38 0 2 0 0 0 7 7 60 1 15 0 0 255 255 0 3 255 51 2 29 2 144 2 38 0 2 0 0 0 7 7 49 1 15 252 233 255 255 0 3 0 0 2 29 3 104 2 38 0 2 0 0 0 7 7 54 1 15 0 0 255 255 0 3 0 0 2 29 3 120 2 38 0 2 0 0 0 7 7 117 1 15 0 0 255 255 0 3 0 0 2 29 3 120 2 38 0 2 0 0 0 7 7 119 1 15 0 0 255 255 0 3 0 0 2 29 3 138 2 38 0 2 0 0 0 7 7 121 1 15 0 0 255 255 0 3 0 0 2 29 3 171 2 38 0 2 0 0 0 7 7 123 1 15 0 0 255 255 0 3 255 51 2 29 3 70 2 38 0 2 0 0 0 39 7 38 1 15 0 0 0 7 7 49 1 15 252 233 255 255 0 3 0 0 2 29 3 180 2 38 0 2 0 0 0 7 7 125 1 15 0 0 255 255 0 3 0 0 2 29 3 180 2 38 0 2 0 0 0 7 7 127 1 15 0 0 255 255 0 3 0 0 2 29 3 184 2 38 0 2 0 0 0 7 7 129 1 15 0 0 255 255 0 3 0 0 2 29 3 175 2 38 0 2 0 0 0 7 7 131 1 15 0 0 255 255 0 3 255 51 2 29 3 74 2 38 0 2 0 0 0 39 7 47 1 15 0 0 0 7 7 49 1 15 252 233 0 2 0 3 255 44 2 60 2 144 0 27 0 37 0 95 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 17 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 186 0 22 0 0 0 3 43 184 0 12 16 184 0 9 208 186 0 11 0 12 0 14 17 18 57 184 0 11 47 184 0 9 16 184 0 16 208 184 0 11 16 185 0 29 0 1 244 186 0 35 0 12 0 14 17 18 57 48 49 5 34 38 53 52 62 2 55 35 39 35 7 35 19 51 19 14 1 21 20 22 51 50 55 23 14 1 1 7 51 39 46 1 39 35 14 1 1 236 40 56 14 22 26 13 19 62 239 63 85 222 94 222 35 45 28 18 23 19 23 15 45 254 203 31 197 31 18 32 16 4 15 32 212 44 43 20 38 32 26 9 200 200 2 144 253 112 14 62 31 23 23 14 45 11 17 2 67 100 100 55 109 57 57 109 0 2 0 8 0 0 3 5 2 144 0 5 0 21 0 124 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 17 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 5 62 89 186 0 19 0 7 0 6 17 18 57 184 0 19 47 185 0 1 0 1 244 186 0 4 0 7 0 6 17 18 57 184 0 7 16 185 0 9 0 2 244 186 0 14 0 7 0 18 17 18 57 184 0 14 47 185 0 12 0 1 244 184 0 18 16 185 0 16 0 2 244 48 49 1 7 51 17 35 6 9 1 33 21 33 21 51 21 35 21 33 21 33 53 35 7 1 34 61 172 4 53 254 176 1 88 1 155 254 234 232 232 1 32 254 140 206 99 1 120 118 1 76 107 254 29 2 144 70 206 71 238 71 191 191 0 0 0 255 255 0 8 0 0 3 5 3 107 2 38 0 76 0 0 0 7 7 35 2 52 0 8 255 255 0 8 0 0 3 5 3 32 2 38 0 76 0 0 0 7 7 42 2 52 0 8 0 3 0 30 0 0 2 53 2 144 0 23 0 32 0 45 0 95 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 17 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 5 62 89 185 0 34 0 1 244 184 0 44 208 184 0 1 208 184 0 44 16 184 0 43 208 184 0 4 208 184 0 43 16 184 0 40 208 184 0 25 208 186 0 15 0 25 0 40 17 18 57 184 0 5 16 185 0 31 0 1 244 48 49 51 53 35 53 55 17 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 35 3 51 50 54 53 52 38 43 1 17 51 50 54 53 52 38 43 1 21 51 21 35 107 77 77 195 50 83 59 33 56 58 72 80 36 66 91 55 127 98 84 75 79 77 101 115 85 94 93 86 115 152 152 177 43 4 1 176 18 38 60 42 48 75 15 4 11 80 69 50 73 49 24 1 124 57 55 54 48 253 237 67 70 65 60 101 47 0 0 255 255 0 90 255 87 2 36 2 144 2 38 0 3 0 0 0 7 7 41 1 44 252 254 255 255 0 52 255 30 2 27 2 156 2 38 0 4 0 0 0 7 7 85 1 87 0 0 255 255 0 52 255 244 2 27 3 99 2 38 0 4 0 0 0 7 7 35 1 74 0 0 255 255 0 52 255 244 2 27 3 70 2 38 0 4 0 0 0 7 7 38 1 74 0 0 255 255 0 52 255 244 2 27 3 77 2 38 0 4 0 0 0 7 7 60 1 74 0 0 255 255 0 52 255 244 2 27 3 53 2 38 0 4 0 0 0 7 7 50 1 74 0 0 255 255 0 90 0 0 2 52 3 77 2 38 0 5 0 0 0 7 7 60 1 51 0 0 255 255 0 90 255 51 2 52 2 144 2 38 0 5 0 0 0 7 7 49 1 48 252 233 255 255 0 90 255 87 2 52 2 144 2 38 0 5 0 0 0 7 7 41 1 48 252 254 255 255 0 33 0 0 2 74 2 144 2 6 0 243 0 0 255 255 0 90 0 0 1 222 3 99 2 38 0 6 0 0 0 7 7 32 1 28 0 0 255 255 0 90 0 0 1 222 3 99 2 38 0 6 0 0 0 7 7 35 1 28 0 0 255 255 0 90 0 0 1 222 3 70 2 38 0 6 0 0 0 7 7 38 1 28 0 0 255 255 0 90 0 0 1 222 3 77 2 38 0 6 0 0 0 7 7 60 1 28 0 0 255 255 0 90 0 0 1 222 3 45 2 38 0 6 0 0 0 7 7 52 1 28 0 0 255 255 0 90 0 0 1 222 3 24 2 38 0 6 0 0 0 7 7 42 1 28 0 0 255 255 0 90 0 0 1 222 3 74 2 38 0 6 0 0 0 7 7 47 1 28 0 0 255 255 0 90 0 0 1 222 3 53 2 38 0 6 0 0 0 7 7 50 1 28 0 0 255 255 0 90 255 51 1 222 2 144 2 38 0 6 0 0 0 7 7 49 1 39 252 233 255 255 0 90 0 0 1 222 3 104 2 38 0 6 0 0 0 7 7 54 1 28 0 0 255 255 0 90 0 0 1 222 3 73 2 38 0 6 0 0 0 7 7 40 1 28 0 0 255 255 0 90 0 0 1 251 3 120 2 38 0 6 0 0 0 7 7 117 1 28 0 0 255 255 0 73 0 0 1 222 3 120 2 38 0 6 0 0 0 7 7 119 1 28 0 0 255 255 0 90 0 0 1 235 3 138 2 38 0 6 0 0 0 7 7 121 1 28 0 0 255 255 0 90 0 0 1 222 3 171 2 38 0 6 0 0 0 7 7 123 1 28 0 0 255 255 0 90 255 51 1 222 3 70 2 38 0 6 0 0 0 39 7 38 1 28 0 0 0 7 7 49 1 39 252 233 0 1 0 90 255 44 1 238 2 144 0 32 0 93 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 17 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 186 0 27 0 0 0 3 43 184 0 8 16 185 0 10 0 2 244 186 0 15 0 8 0 7 17 18 57 184 0 15 47 185 0 13 0 1 244 184 0 7 16 185 0 17 0 2 244 184 0 7 16 184 0 18 208 48 49 5 34 38 53 52 54 55 33 17 33 21 33 21 51 21 35 21 33 21 35 14 3 21 20 22 51 50 55 23 14 1 1 158 40 56 47 28 254 209 1 122 254 217 249 249 1 49 3 17 33 26 16 30 18 21 19 23 14 46 212 44 43 42 65 18 2 144 70 206 71 238 71 2 19 29 37 20 23 23 14 45 11 17 0 0 255 255 0 90 0 0 1 222 3 200 2 38 0 6 0 0 0 7 7 135 1 26 0 0 255 255 0 52 255 244 2 38 3 99 2 38 0 8 0 0 0 7 7 35 1 97 0 0 255 255 0 52 255 244 2 38 3 70 2 38 0 8 0 0 0 7 7 38 1 97 0 0 255 255 0 52 255 244 2 38 3 74 2 38 0 8 0 0 0 7 7 47 1 97 0 0 255 255 0 52 255 244 2 38 3 53 2 38 0 8 0 0 0 7 7 50 1 97 0 0 255 255 0 52 255 30 2 38 2 156 2 38 0 8 0 0 0 7 7 82 1 92 0 0 255 255 0 52 255 244 2 38 3 77 2 38 0 8 0 0 0 7 7 60 1 97 0 0 255 255 0 52 255 244 2 38 3 24 2 38 0 8 0 0 0 7 7 42 1 97 0 0 255 255 0 52 255 244 2 38 3 73 2 38 0 8 0 0 0 7 7 40 1 97 0 0 0 1 0 52 255 244 2 101 3 36 0 55 0 87 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 18 0 1 0 25 0 4 43 184 0 10 16 185 0 35 0 2 244 184 0 0 16 185 0 45 0 2 244 186 0 50 0 10 0 0 17 18 57 184 0 50 47 185 0 52 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 38 53 52 54 51 50 22 23 7 46 1 35 34 6 21 20 22 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 53 35 53 51 17 14 1 1 92 65 109 78 44 45 80 111 65 26 45 20 6 62 51 20 30 12 16 8 15 11 26 27 15 17 46 25 66 50 50 80 56 31 29 55 81 53 35 63 20 139 215 32 104 12 46 87 127 80 79 126 88 47 7 6 19 21 48 61 8 5 63 3 6 31 23 23 33 23 55 19 27 37 69 98 61 62 99 70 38 21 18 171 69 254 236 33 43 0 255 255 0 90 0 0 2 50 3 70 2 38 0 9 0 0 0 7 7 38 1 70 0 0 255 255 0 90 255 51 2 50 2 144 2 38 0 9 0 0 0 7 7 49 1 70 252 233 255 255 0 90 255 26 2 50 2 144 2 38 0 9 0 0 0 7 7 45 1 70 252 223 0 2 0 32 0 0 2 142 2 144 0 19 0 23 0 115 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 17 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 5 62 89 186 0 20 0 4 0 17 17 18 57 184 0 20 47 184 0 23 220 185 0 5 0 1 244 184 0 2 208 184 0 4 16 184 0 8 208 184 0 5 16 184 0 9 208 184 0 23 16 184 0 12 208 184 0 17 16 184 0 13 208 184 0 20 16 185 0 16 0 1 244 184 0 23 16 184 0 19 208 48 49 19 53 55 53 51 21 33 53 51 21 51 21 35 17 35 17 33 17 35 17 23 33 53 33 32 78 83 1 49 84 72 72 84 254 207 83 83 1 49 254 207 1 236 42 5 117 117 117 117 47 254 20 1 53 254 203 1 236 111 111 0 255 255 255 252 0 0 0 185 3 99 2 38 0 10 0 0 0 7 7 32 0 131 0 0 255 255 0 77 0 0 1 10 3 99 2 38 0 10 0 0 0 7 7 35 0 131 0 0 255 255 255 239 0 0 1 23 3 70 2 38 0 10 0 0 0 7 7 38 0 131 0 0 255 255 255 210 0 0 1 52 3 73 2 38 0 10 0 0 0 7 7 40 0 131 0 0 255 255 255 235 0 0 1 27 3 45 2 38 0 10 0 0 0 7 7 52 0 131 0 0 255 255 255 253 0 0 1 9 3 24 2 38 0 10 0 0 0 7 7 42 0 131 0 0 255 255 0 74 0 0 0 188 3 53 2 38 0 10 0 0 0 7 7 50 0 131 0 0 255 255 255 239 0 0 1 23 3 77 2 38 0 10 0 0 0 7 7 60 0 131 0 0 255 255 0 63 0 0 0 210 3 104 2 38 0 10 0 0 0 7 7 54 0 131 0 0 255 255 0 78 255 51 0 186 2 144 2 38 0 10 0 0 0 7 7 49 0 132 252 233 0 1 0 43 255 44 0 219 2 144 0 21 0 53 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 17 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 186 0 16 0 0 0 3 43 184 0 7 16 184 0 10 208 48 49 23 34 38 53 52 54 55 35 17 51 17 14 1 21 20 22 51 50 55 23 14 1 139 40 56 43 24 20 83 31 34 30 17 22 19 23 15 45 212 44 43 43 60 22 2 144 253 112 24 52 31 23 23 14 45 11 17 255 255 255 241 0 0 1 21 3 74 2 38 0 10 0 0 0 7 7 47 0 131 0 0 255 255 0 31 255 244 1 240 3 70 2 38 0 11 0 0 0 7 7 38 1 92 0 0 255 255 0 90 255 30 2 63 2 144 2 38 0 12 0 0 0 7 7 82 1 69 0 0 255 255 0 90 255 51 2 63 2 144 2 38 0 12 0 0 0 7 7 49 1 71 252 233 255 255 0 90 255 87 2 63 2 144 2 38 0 12 0 0 0 7 7 41 1 69 252 254 255 255 0 80 0 0 1 204 3 99 2 38 0 13 0 0 0 7 7 35 0 134 0 0 255 255 0 90 0 0 1 204 2 215 2 38 0 13 0 0 0 7 7 61 1 103 255 223 255 255 0 90 255 30 1 204 2 144 2 38 0 13 0 0 0 7 7 82 1 32 0 0 255 255 0 90 0 0 1 204 2 144 2 38 0 13 0 0 0 7 4 117 0 252 1 19 255 255 0 90 255 51 1 204 2 144 2 38 0 13 0 0 0 7 7 49 1 32 252 233 255 255 0 0 255 51 1 204 3 24 2 38 0 13 0 0 0 39 7 42 0 134 0 0 0 7 7 49 1 32 252 233 255 255 0 90 255 87 1 204 2 144 2 38 0 13 0 0 0 7 7 41 1 32 252 254 0 1 255 250 0 0 1 209 2 144 0 13 0 77 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 17 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 186 0 13 0 12 0 4 17 18 57 184 0 13 47 184 0 2 220 184 0 5 208 184 0 13 16 184 0 8 208 184 0 12 16 185 0 9 0 2 244 48 49 55 39 55 17 51 17 55 23 7 21 33 21 33 53 24 30 101 83 176 30 206 1 31 254 142 200 53 55 1 92 254 201 95 53 110 206 71 240 0 0 0 255 255 0 90 0 0 2 125 3 99 2 38 0 14 0 0 0 7 7 35 1 106 0 0 255 255 0 90 0 0 2 125 3 53 2 38 0 14 0 0 0 7 7 50 1 106 0 0 255 255 0 90 255 51 2 125 2 144 2 38 0 14 0 0 0 7 7 49 1 108 252 233 255 255 0 90 0 0 2 45 3 99 2 38 0 15 0 0 0 7 7 35 1 71 0 0 255 255 0 90 0 0 2 45 3 99 2 38 0 15 0 0 0 7 7 32 1 71 0 0 255 255 0 90 0 0 2 45 3 77 2 38 0 15 0 0 0 7 7 60 1 70 0 0 255 255 0 90 0 0 2 45 3 73 2 38 0 15 0 0 0 7 7 40 1 70 0 0 255 255 0 90 255 30 2 45 2 144 2 38 0 15 0 0 0 7 7 82 1 72 0 0 255 255 0 90 0 0 2 45 3 53 2 38 0 15 0 0 0 7 7 50 1 70 0 0 255 255 0 90 255 51 2 45 2 144 2 38 0 15 0 0 0 7 7 49 1 72 252 233 255 255 0 90 255 87 2 45 2 144 2 38 0 15 0 0 0 7 7 41 1 72 252 254 255 255 0 52 255 244 2 101 3 99 2 38 0 16 0 0 0 7 7 32 1 76 0 0 255 255 0 52 255 244 2 101 3 99 2 38 0 16 0 0 0 7 7 35 1 76 0 0 255 255 0 52 255 244 2 101 3 70 2 38 0 16 0 0 0 7 7 38 1 76 0 0 255 255 0 52 255 244 2 101 3 73 2 38 0 16 0 0 0 7 7 40 1 76 0 0 255 255 0 52 255 244 2 101 3 45 2 38 0 16 0 0 0 7 7 52 1 76 0 0 255 255 0 52 255 244 2 101 3 24 2 38 0 16 0 0 0 7 7 42 1 76 0 0 255 255 0 52 255 244 2 101 3 108 2 38 0 16 0 0 0 7 7 58 1 76 0 0 255 255 0 52 255 244 2 101 3 77 2 38 0 16 0 0 0 7 7 60 1 76 0 0 255 255 0 52 255 51 2 101 2 156 2 38 0 16 0 0 0 7 7 49 1 76 252 233 255 255 0 52 255 244 2 101 3 104 2 38 0 16 0 0 0 7 7 54 1 76 0 0 255 255 0 52 255 244 2 101 3 120 2 38 0 16 0 0 0 7 7 117 1 76 0 0 255 255 0 52 255 244 2 101 3 120 2 38 0 16 0 0 0 7 7 119 1 76 0 0 255 255 0 52 255 244 2 101 3 138 2 38 0 16 0 0 0 7 7 121 1 76 0 0 255 255 0 52 255 244 2 101 3 171 2 38 0 16 0 0 0 7 7 123 1 76 0 0 255 255 0 52 255 51 2 101 3 70 2 38 0 16 0 0 0 39 7 38 1 76 0 0 0 7 7 49 1 76 252 233 255 255 0 52 255 244 2 101 3 74 2 38 0 16 0 0 0 7 7 47 1 76 0 0 255 255 0 52 255 244 2 101 3 200 2 38 0 16 0 0 0 7 7 135 1 76 0 0 0 3 0 50 255 226 2 107 2 174 0 25 0 36 0 47 0 125 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 2 0 13 0 0 17 18 57 184 0 2 16 184 0 5 220 186 0 15 0 13 0 0 17 18 57 184 0 15 16 184 0 18 220 184 0 5 16 184 0 29 220 184 0 15 16 184 0 30 220 184 0 13 16 185 0 32 0 2 244 184 0 0 16 185 0 37 0 2 244 184 0 18 16 184 0 45 220 184 0 2 16 184 0 46 220 48 49 5 34 39 7 39 55 46 1 53 52 62 2 51 50 23 55 23 7 30 1 21 20 14 2 1 20 22 23 1 38 35 34 14 2 19 50 62 2 53 52 38 39 1 22 1 79 104 71 64 46 70 31 34 41 74 103 62 104 72 62 46 69 32 34 41 75 103 255 0 17 16 1 32 51 76 44 71 51 28 194 44 71 51 28 17 16 254 225 50 12 65 83 36 91 45 117 72 79 125 87 46 63 81 35 89 44 115 72 79 127 89 48 1 87 48 83 32 1 117 54 37 68 98 254 181 38 71 99 62 48 80 32 254 138 56 0 0 0 2 0 52 0 0 3 30 2 144 0 18 0 27 0 85 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 8 16 185 0 22 0 2 244 184 0 10 208 186 0 15 0 8 0 0 17 18 57 184 0 15 47 185 0 13 0 1 244 184 0 0 16 185 0 19 0 2 244 184 0 17 208 48 49 33 34 46 2 53 52 54 51 33 21 33 21 51 21 35 21 33 21 37 51 17 35 34 6 21 20 22 1 113 75 117 82 43 168 153 1 159 254 234 232 232 1 32 254 93 48 48 119 122 122 45 85 123 78 157 168 70 206 71 238 71 68 2 8 132 125 126 137 0 0 0 0 2 0 55 255 244 2 108 3 37 0 32 0 52 0 75 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 43 0 2 244 186 0 25 0 10 0 43 17 18 57 184 0 25 16 184 0 12 208 184 0 0 16 185 0 33 0 2 244 48 49 5 34 46 2 53 52 62 2 51 50 23 62 1 53 52 38 39 55 30 1 21 20 6 7 30 1 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 79 62 103 74 41 41 74 103 62 71 59 42 39 8 6 65 10 13 57 50 48 55 41 75 103 62 44 71 51 28 28 51 71 44 44 71 51 28 28 51 71 12 48 89 127 79 79 125 87 46 31 8 39 35 15 31 12 28 17 40 23 51 58 13 44 137 91 79 127 89 48 73 38 71 99 62 61 98 68 37 37 68 98 61 62 99 71 38 0 0 255 255 0 55 255 244 2 108 3 99 2 38 0 175 0 0 0 7 7 35 1 76 0 0 255 255 0 55 255 244 2 108 3 99 2 38 0 175 0 0 0 7 7 32 1 76 0 0 255 255 0 55 255 244 2 108 3 104 2 38 0 175 0 0 0 7 7 54 1 76 0 0 255 255 0 55 255 244 2 108 3 73 2 38 0 175 0 0 0 7 7 40 1 69 0 0 255 255 0 55 255 51 2 108 3 37 2 38 0 175 0 0 0 7 7 49 1 76 252 233 0 2 0 52 255 44 2 101 2 156 0 38 0 58 0 73 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 17 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 186 0 32 0 0 0 3 43 184 0 6 16 184 0 26 208 184 0 6 16 185 0 39 0 2 244 184 0 16 16 185 0 49 0 2 244 48 49 5 34 38 53 52 54 55 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 14 1 21 20 22 51 50 54 55 23 14 1 3 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 105 40 55 35 26 63 102 72 38 41 74 103 62 62 103 75 41 27 53 76 49 41 37 30 18 12 19 9 23 14 46 49 44 71 51 28 28 51 71 44 44 71 51 28 28 51 71 212 44 43 33 59 22 1 50 89 125 77 79 125 87 46 47 87 125 78 67 106 82 61 22 18 56 26 23 23 7 7 45 11 17 1 17 38 71 99 62 61 98 68 37 37 68 98 61 62 99 71 38 0 255 255 0 90 0 0 2 32 3 99 2 38 0 19 0 0 0 7 7 35 1 32 0 0 255 255 0 90 0 0 2 32 3 77 2 38 0 19 0 0 0 7 7 60 1 32 0 0 255 255 0 90 0 0 2 32 3 53 2 38 0 19 0 0 0 7 7 50 1 32 0 0 255 255 0 90 255 30 2 32 2 144 2 38 0 19 0 0 0 7 7 82 1 47 0 0 255 255 0 90 255 51 2 32 2 144 2 38 0 19 0 0 0 7 7 49 1 47 252 233 255 255 0 90 255 51 2 32 3 24 2 38 0 19 0 0 0 39 7 42 1 32 0 0 0 7 7 49 1 47 252 233 255 255 0 90 255 87 2 32 2 144 2 38 0 19 0 0 0 7 7 41 1 47 252 254 255 255 0 42 255 244 1 239 3 99 2 38 0 20 0 0 0 7 7 35 1 23 0 0 255 255 0 42 255 244 1 239 3 70 2 38 0 20 0 0 0 7 7 38 1 23 0 0 255 255 0 42 255 244 1 239 3 77 2 38 0 20 0 0 0 7 7 60 1 23 0 0 255 255 0 42 255 30 1 239 2 156 2 38 0 20 0 0 0 7 7 85 1 17 0 0 255 255 0 42 255 30 1 239 2 156 2 38 0 20 0 0 0 7 7 82 1 17 0 0 255 255 0 42 255 244 1 239 3 53 2 38 0 20 0 0 0 7 7 50 1 23 0 0 255 255 0 42 255 51 1 239 2 156 2 38 0 20 0 0 0 7 7 49 1 17 252 233 0 1 0 91 255 244 2 112 2 156 0 40 0 85 0 184 0 0 69 88 184 0 29 47 27 185 0 29 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 2 244 186 0 15 0 29 0 0 17 18 57 184 0 29 16 185 0 20 0 2 244 184 0 0 16 184 0 25 208 184 0 25 47 186 0 33 0 15 0 16 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 46 2 47 1 55 46 1 35 34 6 21 17 35 17 52 54 51 50 22 23 7 30 1 21 20 14 2 1 178 58 92 31 48 29 60 37 53 58 17 44 75 57 5 137 17 65 51 80 89 84 134 122 84 106 27 138 105 93 27 50 70 12 42 34 54 32 28 63 50 23 42 36 28 10 54 153 34 48 95 102 254 110 1 161 118 133 84 70 152 21 98 72 39 67 49 28 0 255 255 0 28 0 0 1 252 3 77 2 38 0 21 0 0 0 7 7 60 1 11 0 0 255 255 0 28 255 30 1 252 2 144 2 38 0 21 0 0 0 7 7 85 1 8 0 0 255 255 0 28 255 30 1 252 2 144 2 38 0 21 0 0 0 7 7 82 1 13 0 0 255 255 0 28 255 51 1 252 2 144 2 38 0 21 0 0 0 7 7 49 1 13 252 233 255 255 0 28 255 87 1 252 2 144 2 38 0 21 0 0 0 7 7 41 1 13 252 254 0 1 0 28 0 0 1 252 2 144 0 16 0 73 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 5 0 1 0 2 0 4 43 184 0 8 16 185 0 10 0 2 244 184 0 5 16 184 0 13 208 184 0 2 16 184 0 14 208 48 49 51 17 35 53 55 51 53 35 53 33 21 35 21 51 21 35 17 226 123 88 35 198 1 224 198 123 123 1 57 44 3 226 70 70 226 47 254 199 0 0 0 255 255 0 87 255 244 2 46 3 99 2 38 0 22 0 0 0 7 7 32 1 66 0 0 255 255 0 87 255 244 2 46 3 99 2 38 0 22 0 0 0 7 7 35 1 66 0 0 255 255 0 87 255 244 2 46 3 70 2 38 0 22 0 0 0 7 7 38 1 66 0 0 255 255 0 87 255 244 2 46 3 73 2 38 0 22 0 0 0 7 7 40 1 66 0 0 255 255 0 87 255 244 2 46 3 45 2 38 0 22 0 0 0 7 7 52 1 66 0 0 255 255 0 87 255 244 2 46 3 24 2 38 0 22 0 0 0 7 7 42 1 66 0 0 255 255 0 87 255 244 2 46 3 74 2 38 0 22 0 0 0 7 7 47 1 66 0 0 255 255 0 87 255 244 2 46 3 112 2 38 0 22 0 0 0 7 7 56 1 66 0 0 255 255 0 87 255 244 2 46 3 108 2 38 0 22 0 0 0 7 7 58 1 66 0 0 255 255 0 87 255 244 2 46 3 77 2 38 0 22 0 0 0 7 7 60 1 66 0 0 255 255 0 87 255 244 2 46 3 139 2 38 0 22 0 0 0 7 7 113 1 66 0 0 255 255 0 87 255 244 2 46 3 200 2 38 0 22 0 0 0 7 7 106 1 66 0 0 255 255 0 87 255 244 2 46 3 194 2 38 0 22 0 0 0 7 7 115 1 66 0 0 255 255 0 87 255 244 2 46 3 200 2 38 0 22 0 0 0 7 7 109 1 66 0 0 255 255 0 87 255 51 2 46 2 144 2 38 0 22 0 0 0 7 7 49 1 66 252 233 255 255 0 87 255 244 2 46 3 104 2 38 0 22 0 0 0 7 7 54 1 66 0 0 0 1 0 87 255 44 2 46 2 144 0 45 0 71 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 17 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 186 0 40 0 0 0 3 43 184 0 8 16 185 0 21 0 2 244 184 0 14 16 184 0 27 208 184 0 8 16 184 0 34 208 48 49 5 34 38 53 52 62 2 55 46 3 53 17 51 17 20 30 2 51 50 62 2 53 17 51 17 20 14 2 7 14 1 21 20 22 51 50 55 23 14 1 1 94 40 56 13 19 23 9 51 85 61 34 83 24 41 56 32 33 56 42 24 80 23 42 59 36 39 40 30 18 21 19 23 14 46 212 44 43 21 33 28 23 9 1 32 67 106 76 1 129 254 125 59 80 48 21 21 48 80 59 1 131 254 127 66 91 63 41 17 19 56 25 23 23 14 45 11 17 0 0 1 0 87 255 244 2 162 3 57 0 40 0 55 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 13 0 2 244 184 0 6 16 184 0 19 208 184 0 35 220 48 49 5 34 46 2 53 17 51 17 20 30 2 51 50 62 2 53 17 51 62 1 53 52 38 39 55 30 1 21 20 14 2 7 17 20 14 2 1 67 50 87 63 36 83 24 41 56 32 33 56 42 24 33 42 48 8 7 65 11 12 18 31 43 24 36 63 86 12 29 67 108 79 1 129 254 125 59 80 48 21 21 48 80 59 1 131 5 36 42 15 31 12 28 17 40 23 29 42 30 18 6 254 163 79 108 67 29 0 255 255 0 87 255 244 2 162 3 99 2 38 0 220 0 0 0 7 7 35 1 66 0 0 255 255 0 87 255 244 2 162 3 99 2 38 0 220 0 0 0 7 7 32 1 66 0 0 255 255 0 87 255 244 2 162 3 104 2 38 0 220 0 0 0 7 7 54 1 66 0 0 255 255 0 87 255 244 2 162 3 73 2 38 0 220 0 0 0 7 7 40 1 66 0 0 255 255 0 87 255 51 2 162 3 57 2 38 0 220 0 0 0 7 7 49 1 66 252 233 255 255 0 23 0 0 2 250 3 99 2 38 0 24 0 0 0 7 7 32 1 137 0 0 255 255 0 23 0 0 2 250 3 99 2 38 0 24 0 0 0 7 7 35 1 137 0 0 255 255 0 23 0 0 2 250 3 70 2 38 0 24 0 0 0 7 7 38 1 137 0 0 255 255 0 23 0 0 2 250 3 45 2 38 0 24 0 0 0 7 7 52 1 137 0 0 255 255 255 255 0 0 1 221 3 99 2 38 0 26 0 0 0 7 7 32 0 238 0 0 255 255 255 255 0 0 1 221 3 99 2 38 0 26 0 0 0 7 7 35 0 238 0 0 255 255 255 255 0 0 1 221 3 70 2 38 0 26 0 0 0 7 7 38 0 238 0 0 255 255 255 255 0 0 1 221 3 45 2 38 0 26 0 0 0 7 7 52 0 238 0 0 255 255 255 255 0 0 1 221 3 53 2 38 0 26 0 0 0 7 7 50 0 238 0 0 255 255 255 255 255 51 1 221 2 144 2 38 0 26 0 0 0 7 7 49 0 240 252 233 255 255 255 255 0 0 1 221 3 104 2 38 0 26 0 0 0 7 7 54 0 238 0 0 255 255 255 255 0 0 1 221 3 73 2 38 0 26 0 0 0 7 7 40 0 238 0 0 255 255 0 45 0 0 1 241 3 99 2 38 0 27 0 0 0 7 7 35 1 24 0 0 255 255 0 45 0 0 1 241 3 77 2 38 0 27 0 0 0 7 7 60 1 24 0 0 255 255 0 45 0 0 1 241 3 53 2 38 0 27 0 0 0 7 7 50 1 24 0 0 255 255 0 45 255 51 1 241 2 144 2 38 0 27 0 0 0 7 7 49 1 25 252 233 255 255 0 45 255 87 1 241 2 144 2 38 0 27 0 0 0 7 7 41 1 25 252 254 0 2 0 33 0 0 2 74 2 144 0 14 0 27 0 89 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 17 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 5 62 89 186 0 26 0 3 0 13 17 18 57 184 0 26 47 184 0 0 208 184 0 26 16 185 0 25 0 1 244 184 0 1 208 184 0 13 16 185 0 16 0 2 244 184 0 3 16 185 0 22 0 2 244 48 49 19 53 55 17 51 50 22 21 20 14 2 43 1 17 23 51 50 54 53 52 38 43 1 21 51 21 35 33 79 164 152 158 40 78 114 74 168 83 75 115 115 115 115 75 149 149 1 65 43 4 1 32 168 157 78 123 85 45 1 65 253 138 125 125 132 220 47 0 2 0 90 0 0 2 21 2 144 0 16 0 25 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 17 0 2 0 15 0 4 43 187 0 3 0 2 0 25 0 4 43 48 49 51 17 51 21 51 50 30 2 21 20 14 2 43 1 21 53 51 50 54 53 52 38 43 1 90 83 118 54 90 63 35 35 64 89 54 118 108 86 83 84 85 108 2 144 110 20 46 73 54 52 77 50 24 150 218 64 71 71 54 0 2 0 58 255 244 2 94 2 156 0 26 0 33 0 81 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 9 0 19 0 0 17 18 57 184 0 9 47 184 0 19 16 185 0 12 0 2 244 184 0 0 16 185 0 27 0 2 244 184 0 9 16 185 0 31 0 1 244 48 49 5 34 46 2 53 52 54 55 33 46 1 35 34 6 7 39 62 1 51 50 22 21 20 14 2 39 50 54 55 33 30 1 1 71 63 100 69 37 1 1 1 208 5 100 94 50 81 29 41 35 105 67 129 146 39 73 103 64 84 103 8 254 133 5 99 12 47 88 125 77 5 13 7 121 128 36 29 57 34 43 173 165 82 127 87 46 69 117 112 109 120 0 1 0 90 255 244 2 71 2 156 0 39 0 85 0 184 0 0 69 88 184 0 30 47 27 185 0 30 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 2 244 184 0 30 16 185 0 17 0 2 244 186 0 27 0 0 0 30 17 18 57 184 0 27 16 185 0 22 0 2 244 184 0 30 16 184 0 25 208 184 0 25 47 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 46 2 35 34 14 2 7 17 35 17 51 21 62 1 51 50 30 2 21 20 14 2 1 150 20 44 14 20 11 23 16 20 36 27 16 23 43 60 36 20 44 43 40 15 83 81 35 98 52 49 83 61 34 25 47 65 12 7 8 75 5 6 25 62 103 78 74 100 60 26 15 26 36 21 254 15 2 144 81 40 53 35 79 127 92 95 132 82 38 0 0 0 0 2 0 90 255 91 1 180 2 144 0 3 0 19 0 64 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 17 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 187 0 11 0 1 0 4 0 4 43 48 49 51 17 51 17 23 34 38 39 55 30 1 51 50 54 53 17 51 17 20 6 90 83 129 23 36 13 16 10 23 13 37 24 83 62 2 144 253 112 165 7 5 66 3 6 51 45 2 144 253 109 75 87 255 255 0 52 255 244 1 177 3 13 2 38 0 28 0 0 0 7 7 31 1 6 0 0 255 255 0 52 255 244 1 177 3 13 2 38 0 28 0 0 0 7 7 34 1 6 0 0 255 255 0 52 255 244 1 177 2 228 2 38 0 28 0 0 0 7 7 37 1 6 0 0 255 255 0 52 255 244 1 179 2 209 2 38 0 28 0 0 0 7 7 39 1 6 0 0 255 255 0 52 255 244 1 177 2 175 2 38 0 28 0 0 0 7 7 51 1 6 0 0 255 255 0 52 255 244 1 177 2 146 2 38 0 28 0 0 0 7 7 41 1 6 0 0 255 255 0 52 255 244 1 177 2 218 2 38 0 28 0 0 0 7 7 45 1 6 0 0 255 255 0 52 255 244 1 177 2 239 2 38 0 28 0 0 0 7 7 55 1 6 0 0 255 255 0 52 255 244 1 177 2 234 2 38 0 28 0 0 0 7 7 59 1 6 0 0 255 255 0 52 255 51 1 177 1 242 2 38 0 28 0 0 0 7 7 49 0 246 252 233 255 255 0 52 255 244 1 177 2 248 2 38 0 28 0 0 0 7 7 53 1 6 0 0 255 255 0 52 255 244 1 241 3 17 2 38 0 28 0 0 0 7 7 116 1 6 0 0 255 255 0 15 255 244 1 177 3 17 2 38 0 28 0 0 0 7 7 118 1 6 0 0 255 255 0 52 255 244 1 215 3 23 2 38 0 28 0 0 0 7 7 120 1 6 0 0 255 255 0 52 255 244 1 177 3 35 2 38 0 28 0 0 0 7 7 122 1 6 0 0 255 255 0 52 255 51 1 177 2 228 2 38 0 28 0 0 0 39 7 37 1 6 0 0 0 7 7 49 0 246 252 233 255 255 0 52 255 244 1 177 3 64 2 38 0 28 0 0 0 7 7 124 1 6 0 0 255 255 0 52 255 244 1 177 3 64 2 38 0 28 0 0 0 7 7 126 1 6 0 0 255 255 0 52 255 244 1 177 3 80 2 38 0 28 0 0 0 7 7 128 1 6 0 0 255 255 0 52 255 244 1 177 3 34 2 38 0 28 0 0 0 7 7 130 1 6 0 0 255 255 0 52 255 51 1 177 2 218 2 38 0 28 0 0 0 39 7 45 1 6 0 0 0 7 7 49 0 246 252 233 0 2 0 52 255 50 1 198 1 242 0 47 0 59 0 121 0 184 0 0 69 88 184 0 31 47 27 185 0 31 0 9 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 5 62 89 186 0 41 0 0 0 3 43 184 0 13 16 184 0 35 208 184 0 35 47 184 0 8 208 186 0 9 0 31 0 13 17 18 57 186 0 19 0 31 0 13 17 18 57 184 0 31 16 185 0 24 0 1 244 184 0 13 16 185 0 48 0 1 244 184 0 9 16 185 0 51 0 1 244 184 0 19 16 185 0 52 0 1 244 48 49 5 34 38 53 52 62 2 55 39 35 14 1 35 34 38 53 52 54 55 52 46 2 35 34 6 7 39 62 1 51 50 22 21 17 14 1 21 20 22 51 50 54 55 23 14 1 3 50 54 55 53 14 3 21 20 22 1 120 38 53 14 23 29 14 7 3 35 80 46 61 81 142 156 9 22 39 30 42 74 29 32 34 98 59 89 80 42 45 28 18 12 20 9 21 14 45 177 35 62 35 61 83 51 23 50 206 43 42 20 37 32 27 9 54 29 41 72 66 80 85 17 23 44 34 21 32 20 57 22 41 109 91 254 214 17 59 29 23 23 7 6 41 11 16 1 4 33 32 135 8 22 30 39 23 42 36 0 0 0 0 3 0 58 255 244 2 235 1 242 0 49 0 64 0 71 0 155 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 6 0 18 0 0 17 18 57 184 0 18 16 185 0 11 0 1 244 184 0 0 16 184 0 44 208 186 0 21 0 18 0 44 17 18 57 184 0 18 16 184 0 24 208 186 0 32 0 24 0 44 17 18 57 184 0 0 16 185 0 50 0 1 244 184 0 37 208 186 0 47 0 0 0 24 17 18 57 184 0 47 16 185 0 53 0 1 244 184 0 6 16 185 0 57 0 1 244 184 0 32 16 185 0 66 0 1 244 184 0 11 16 184 0 69 208 48 49 23 34 38 53 52 54 55 52 46 2 35 34 6 7 39 62 1 51 50 22 23 62 1 51 50 30 2 21 20 7 33 30 3 51 50 54 55 23 14 1 35 34 38 39 14 1 39 50 54 55 46 1 39 53 14 3 21 20 22 55 51 52 38 35 34 6 201 62 81 142 152 8 23 38 30 40 72 29 33 34 96 54 54 70 15 29 81 50 45 69 47 24 3 254 197 1 25 40 54 31 35 56 27 30 32 76 50 61 82 28 50 101 24 34 80 33 8 10 1 58 81 51 23 49 241 246 59 56 51 73 12 72 66 80 85 17 23 44 34 21 32 20 57 22 41 55 48 48 55 32 60 85 52 28 18 38 62 44 24 23 17 57 20 30 55 36 45 46 66 39 36 19 53 28 25 8 22 30 39 23 42 36 224 75 80 83 0 255 255 0 58 255 244 2 235 3 13 2 38 1 14 0 0 0 7 7 34 1 156 0 0 255 255 0 58 255 244 2 235 2 146 2 38 1 14 0 0 0 7 7 41 1 156 0 0 0 2 0 8 255 244 1 251 2 200 0 30 0 46 0 141 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 11 16 184 0 10 220 184 0 7 220 184 0 21 220 186 0 4 0 0 0 21 17 18 57 184 0 0 16 184 0 6 208 184 0 6 47 184 0 10 16 184 0 14 208 184 0 7 16 184 0 15 208 186 0 18 0 21 0 0 17 18 57 184 0 0 16 185 0 31 0 1 244 184 0 21 16 185 0 41 0 1 244 184 0 18 16 185 0 43 0 1 244 184 0 4 16 185 0 44 0 1 244 48 49 5 34 38 39 35 7 35 17 35 53 55 53 51 21 51 21 35 21 7 62 1 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 7 21 30 1 1 41 34 73 32 3 7 66 74 74 82 182 182 2 33 78 41 47 72 49 25 34 58 76 56 30 51 37 21 14 31 49 34 60 70 32 63 12 33 29 50 2 59 43 5 93 93 48 93 87 29 39 33 59 84 51 57 91 63 33 69 25 45 65 39 34 59 42 24 67 215 28 23 0 0 0 255 255 0 82 255 87 1 251 2 200 2 38 0 29 0 0 0 7 7 41 1 27 252 254 255 255 0 46 255 30 1 175 1 242 2 38 0 30 0 0 0 7 7 84 1 16 0 0 255 255 0 46 255 244 1 175 3 13 2 38 0 30 0 0 0 7 7 34 1 23 0 0 255 255 0 46 255 244 1 178 2 228 2 38 0 30 0 0 0 7 7 37 1 23 0 0 255 255 0 46 255 244 1 178 2 234 2 38 0 30 0 0 0 7 7 59 1 23 0 0 255 255 0 46 255 244 1 175 2 182 2 38 0 30 0 0 0 7 7 49 1 23 0 0 255 255 0 47 255 244 2 73 2 248 0 38 0 31 0 0 0 7 7 61 2 43 0 0 255 255 0 47 255 51 1 217 2 200 2 38 0 31 0 0 0 7 7 49 1 46 252 233 255 255 0 47 255 87 1 217 2 200 2 38 0 31 0 0 0 7 7 41 1 45 252 254 0 2 0 47 255 244 2 33 2 200 0 28 0 43 0 143 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 17 16 184 0 16 220 185 0 13 0 1 244 184 0 8 220 186 0 11 0 8 0 0 17 18 57 184 0 16 16 184 0 19 208 184 0 13 16 184 0 22 208 184 0 0 16 184 0 23 208 184 0 23 47 186 0 25 0 0 0 8 17 18 57 184 0 0 16 185 0 29 0 1 244 184 0 25 16 185 0 32 0 1 244 184 0 11 16 185 0 33 0 1 244 184 0 8 16 185 0 36 0 1 244 48 49 23 34 38 53 52 62 2 51 50 22 23 39 53 35 53 51 53 51 21 51 21 7 17 35 39 35 14 1 39 50 54 55 53 46 1 35 34 14 2 21 20 22 248 92 109 35 58 76 42 42 62 32 4 161 161 83 72 72 70 6 3 28 74 26 34 60 30 31 57 30 29 51 38 22 70 12 123 112 54 87 61 34 31 26 84 85 48 93 93 43 5 253 197 55 28 39 69 33 34 215 28 23 25 44 61 36 77 90 0 255 255 0 46 255 244 1 202 3 13 2 38 0 32 0 0 0 7 7 31 1 9 0 0 255 255 0 46 255 244 1 202 3 13 2 38 0 32 0 0 0 7 7 34 1 9 0 0 255 255 0 46 255 244 1 202 2 228 2 38 0 32 0 0 0 7 7 37 1 9 0 0 255 255 0 46 255 244 1 202 2 234 2 38 0 32 0 0 0 7 7 59 1 9 0 0 255 255 0 46 255 244 1 202 2 175 2 38 0 32 0 0 0 7 7 51 1 9 0 0 255 255 0 46 255 244 1 202 2 146 2 38 0 32 0 0 0 7 7 41 1 9 0 0 255 255 0 46 255 244 1 202 2 218 2 38 0 32 0 0 0 7 7 45 1 9 0 0 255 255 0 46 255 244 1 202 2 182 2 38 0 32 0 0 0 7 7 49 1 9 0 0 255 255 0 46 255 51 1 202 1 242 2 38 0 32 0 0 0 7 7 49 1 7 252 233 255 255 0 46 255 244 1 202 2 248 2 38 0 32 0 0 0 7 7 53 1 9 0 0 255 255 0 46 255 244 1 202 2 209 2 38 0 32 0 0 0 7 7 39 1 9 0 0 255 255 0 46 255 244 1 244 3 17 2 38 0 32 0 0 0 7 7 116 1 9 0 0 255 255 0 18 255 244 1 202 3 17 2 38 0 32 0 0 0 7 7 118 1 9 0 0 255 255 0 46 255 244 1 218 3 23 2 38 0 32 0 0 0 7 7 120 1 9 0 0 255 255 0 46 255 244 1 202 3 35 2 38 0 32 0 0 0 7 7 122 1 9 0 0 255 255 0 46 255 51 1 202 2 228 2 38 0 32 0 0 0 39 7 37 1 9 0 0 0 7 7 49 1 6 252 233 0 2 0 46 255 50 1 202 1 242 0 51 0 60 0 89 0 184 0 0 69 88 184 0 21 47 27 185 0 21 0 9 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 186 0 45 0 0 0 3 43 186 0 30 0 21 0 11 17 18 57 184 0 30 47 184 0 11 16 185 0 33 0 1 244 184 0 30 16 185 0 53 0 1 244 184 0 21 16 185 0 56 0 1 244 48 49 5 34 38 53 52 62 2 55 14 1 35 34 46 2 53 52 62 2 51 50 30 2 21 20 6 7 33 30 1 51 50 54 55 23 14 3 21 20 22 51 50 54 55 23 14 1 3 33 52 38 35 34 14 2 1 102 38 52 11 18 21 10 13 24 12 49 85 63 36 37 61 78 42 46 73 49 26 1 2 254 184 5 87 70 35 59 27 29 33 42 26 10 28 19 12 19 9 21 14 45 251 1 4 63 57 26 47 38 25 206 43 42 19 34 30 24 9 5 2 35 65 94 60 60 95 66 35 32 60 84 52 13 25 9 78 91 21 17 54 23 39 34 31 16 23 23 7 6 41 11 16 1 232 74 77 20 39 56 0 255 255 0 46 255 244 1 202 3 75 2 38 0 32 0 0 0 7 7 134 1 9 0 0 255 255 0 45 255 32 1 236 3 13 2 38 0 34 0 0 0 7 7 34 1 11 0 0 255 255 0 45 255 32 1 236 2 228 2 38 0 34 0 0 0 7 7 37 1 11 0 0 255 255 0 45 255 32 1 236 2 218 2 38 0 34 0 0 0 7 7 45 1 11 0 0 255 255 0 45 255 32 1 236 2 182 2 38 0 34 0 0 0 7 7 49 1 11 0 0 255 255 0 45 255 32 1 236 2 232 2 38 0 34 0 0 0 7 7 83 1 11 0 0 255 255 0 45 255 32 1 236 2 234 2 38 0 34 0 0 0 7 7 59 1 11 0 0 255 255 0 45 255 32 1 236 2 146 2 38 0 34 0 0 0 7 7 41 1 11 0 0 255 255 0 45 255 32 1 236 2 209 2 38 0 34 0 0 0 7 7 39 1 11 0 0 255 255 255 232 0 0 1 215 3 112 2 38 0 35 0 0 0 6 7 38 124 42 0 0 255 255 0 82 255 51 1 215 2 200 2 38 0 35 0 0 0 7 7 49 1 30 252 233 255 255 0 82 255 87 1 215 2 200 2 38 0 35 0 0 0 7 7 41 1 30 252 254 255 255 0 82 255 26 1 215 2 200 2 38 0 35 0 0 0 7 7 45 1 29 252 223 0 1 0 8 0 0 1 215 2 200 0 28 0 111 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 5 16 184 0 4 208 184 0 4 47 184 0 1 208 184 0 4 16 184 0 8 208 184 0 1 16 184 0 9 208 184 0 15 208 186 0 12 0 15 0 0 17 18 57 184 0 0 16 184 0 20 208 184 0 15 16 185 0 24 0 1 244 184 0 12 16 185 0 27 0 1 244 48 49 51 17 35 53 55 53 51 21 51 21 35 21 7 62 1 51 50 22 21 17 35 17 52 38 35 34 6 7 17 82 74 74 82 182 182 3 35 76 51 77 71 82 44 48 38 58 37 2 59 43 5 93 93 48 93 100 33 48 96 94 254 243 1 2 69 60 37 37 254 199 0 255 255 255 236 0 0 0 179 3 13 2 38 1 71 0 0 0 6 7 31 123 0 0 0 255 255 0 67 0 0 1 10 3 13 2 38 1 71 0 0 0 6 7 34 123 0 0 0 255 255 255 224 0 0 1 22 2 228 2 38 1 71 0 0 0 6 7 37 123 0 0 0 255 255 255 206 0 0 1 40 2 209 2 38 1 71 0 0 0 6 7 39 123 0 0 0 255 255 255 233 0 0 1 13 2 175 2 38 1 71 0 0 0 6 7 51 123 0 0 0 255 255 255 246 0 0 1 0 2 146 2 38 1 71 0 0 0 6 7 41 123 0 0 0 255 255 255 224 0 0 1 22 2 234 2 38 1 71 0 0 0 6 7 59 123 0 0 0 255 255 0 55 0 0 0 203 2 248 2 38 1 71 0 0 0 6 7 53 123 0 0 0 255 255 0 67 255 51 0 181 2 180 2 38 0 36 0 0 0 7 7 49 0 124 252 233 0 2 0 38 255 50 0 207 2 180 0 22 0 34 0 65 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 9 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 186 0 16 0 0 0 3 43 184 0 7 16 184 0 10 208 184 0 8 16 184 0 23 220 184 0 29 220 48 49 23 34 38 53 52 54 55 35 17 51 17 14 1 21 20 22 51 50 54 55 23 14 1 3 34 38 53 52 54 51 50 22 21 20 6 129 38 53 43 21 20 82 30 35 28 19 11 19 10 21 14 45 25 24 33 33 24 23 33 33 206 43 42 40 60 21 1 230 254 26 22 54 29 23 23 7 6 41 11 16 3 24 30 23 24 29 29 24 23 30 0 0 1 0 38 255 50 0 207 1 230 0 22 0 53 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 9 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 186 0 16 0 0 0 3 43 184 0 7 16 184 0 10 208 48 49 23 34 38 53 52 54 55 35 17 51 17 14 1 21 20 22 51 50 54 55 23 14 1 129 38 53 43 21 20 82 30 35 28 19 11 19 10 21 14 45 206 43 42 40 60 21 1 230 254 26 22 54 29 23 23 7 6 41 11 16 0 255 255 255 224 0 0 1 24 2 218 2 38 1 71 0 0 0 6 7 45 124 0 0 0 0 1 0 82 0 0 0 164 1 230 0 3 0 37 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 48 49 51 17 51 17 82 82 1 230 254 26 0 0 0 255 255 255 216 255 39 1 22 2 228 2 38 1 188 0 0 0 6 7 37 123 0 0 0 255 255 0 82 255 30 1 230 2 200 2 38 0 38 0 0 0 7 7 82 1 15 0 0 255 255 0 82 255 51 1 230 2 200 2 38 0 38 0 0 0 7 7 49 1 15 252 233 255 255 0 82 255 87 1 230 2 200 2 38 0 38 0 0 0 7 7 41 1 15 252 254 0 1 0 82 0 0 1 230 1 230 0 12 0 83 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 3 0 1 0 0 17 18 57 184 0 1 16 184 0 5 208 184 0 0 16 184 0 9 208 186 0 7 0 1 0 9 17 18 57 186 0 10 0 1 0 0 17 18 57 48 49 51 17 51 17 51 19 51 7 19 35 39 7 21 82 82 3 206 91 161 183 90 142 90 1 230 254 254 1 2 195 254 221 231 106 125 255 255 0 65 255 244 0 254 3 151 2 38 0 39 0 0 0 6 7 35 119 52 0 0 255 255 0 82 255 244 1 20 2 248 0 38 0 39 0 0 0 7 7 61 0 246 0 0 255 255 0 82 255 244 1 107 2 200 0 38 0 39 0 0 0 7 4 117 0 179 1 19 255 255 0 62 255 30 0 235 2 200 2 38 0 39 0 0 0 7 7 82 0 157 0 0 255 255 0 82 255 51 0 216 2 200 2 38 0 39 0 0 0 7 7 49 0 157 252 233 255 255 255 245 255 51 0 255 3 111 2 38 0 39 0 0 0 39 7 41 0 122 0 221 0 7 7 49 0 157 252 233 255 255 0 24 255 87 1 34 2 200 2 38 0 39 0 0 0 7 7 41 0 157 252 254 0 1 255 255 255 244 0 252 2 200 0 23 0 71 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 7 0 4 0 3 43 184 0 7 16 184 0 10 208 184 0 4 16 184 0 13 208 184 0 0 16 185 0 17 0 1 244 48 49 23 34 38 61 1 7 39 55 17 51 17 55 23 7 17 20 22 51 58 1 55 23 14 1 173 47 40 57 30 87 82 54 30 84 14 9 4 7 7 11 8 22 12 56 54 233 36 53 53 1 55 254 244 35 53 52 254 230 20 16 2 62 4 4 0 0 0 255 255 0 82 0 0 2 241 3 13 2 38 0 40 0 0 0 7 7 34 1 163 0 0 255 255 0 82 0 0 2 241 2 182 2 38 0 40 0 0 0 7 7 49 1 163 0 0 255 255 0 82 255 51 2 241 1 242 2 38 0 40 0 0 0 7 7 49 1 170 252 233 255 255 0 82 0 0 1 215 3 13 2 38 0 41 0 0 0 7 7 34 1 36 0 0 255 255 0 82 0 0 1 215 3 13 2 38 0 41 0 0 0 7 7 31 1 35 0 0 255 255 0 82 0 0 1 215 2 234 2 38 0 41 0 0 0 7 7 59 1 36 0 0 255 255 0 82 0 0 1 215 2 209 2 38 0 41 0 0 0 7 7 39 1 36 0 0 255 255 0 82 255 30 1 215 1 242 2 38 0 41 0 0 0 7 7 82 1 23 0 0 255 255 0 82 0 0 1 215 2 182 2 38 0 41 0 0 0 7 7 49 1 36 0 0 255 255 0 82 255 51 1 215 1 242 2 38 0 41 0 0 0 7 7 49 1 23 252 233 255 255 0 82 255 87 1 215 1 242 2 38 0 41 0 0 0 7 7 41 1 23 252 254 255 255 0 63 0 0 2 181 2 187 0 39 0 41 0 222 0 0 0 6 4 129 0 0 255 255 0 46 255 244 1 240 3 13 2 38 0 42 0 0 0 7 7 31 1 15 0 0 255 255 0 46 255 244 1 240 3 13 2 38 0 42 0 0 0 7 7 34 1 15 0 0 255 255 0 46 255 244 1 240 2 228 2 38 0 42 0 0 0 7 7 37 1 15 0 0 255 255 0 46 255 244 1 240 2 209 2 38 0 42 0 0 0 7 7 39 1 15 0 0 255 255 0 46 255 244 1 240 2 175 2 38 0 42 0 0 0 7 7 51 1 15 0 0 255 255 0 46 255 244 1 240 2 146 2 38 0 42 0 0 0 7 7 41 1 15 0 0 255 255 0 46 255 244 1 240 2 249 2 38 0 42 0 0 0 7 7 57 1 15 0 0 255 255 0 46 255 244 1 240 2 234 2 38 0 42 0 0 0 7 7 59 1 15 0 0 255 255 0 46 255 51 1 240 1 242 2 38 0 42 0 0 0 7 7 49 1 16 252 233 255 255 0 46 255 244 1 240 2 248 2 38 0 42 0 0 0 7 7 53 1 15 0 0 255 255 0 46 255 244 1 250 3 17 2 38 0 42 0 0 0 7 7 116 1 15 0 0 255 255 0 24 255 244 1 240 3 17 2 38 0 42 0 0 0 7 7 118 1 15 0 0 255 255 0 46 255 244 1 240 3 23 2 38 0 42 0 0 0 7 7 120 1 15 0 0 255 255 0 46 255 244 1 240 3 35 2 38 0 42 0 0 0 7 7 122 1 15 0 0 255 255 0 46 255 51 1 240 2 228 2 38 0 42 0 0 0 39 7 37 1 15 0 0 0 7 7 49 1 16 252 233 255 255 0 46 255 244 1 240 2 218 2 38 0 42 0 0 0 7 7 45 1 15 0 0 255 255 0 46 255 244 1 240 3 75 2 38 0 42 0 0 0 7 7 134 1 15 0 0 0 3 0 46 255 233 1 240 1 253 0 26 0 36 0 46 0 133 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 45 0 0 0 13 17 18 57 184 0 45 16 184 0 29 208 186 0 2 0 0 0 29 17 18 57 186 0 5 0 29 0 0 17 18 57 186 0 30 0 13 0 0 17 18 57 184 0 30 16 184 0 44 208 186 0 16 0 13 0 44 17 18 57 186 0 19 0 44 0 13 17 18 57 184 0 13 16 185 0 32 0 1 244 184 0 0 16 185 0 37 0 1 244 48 49 5 34 39 7 39 55 46 1 53 52 62 2 51 50 22 23 55 23 7 30 1 21 20 14 2 3 20 23 19 38 35 34 14 2 23 50 62 2 53 52 39 3 22 1 15 79 60 49 37 54 25 29 37 62 81 45 38 72 29 50 36 54 25 29 37 62 81 189 23 214 37 56 31 53 38 22 144 31 53 39 21 24 213 39 12 49 60 29 65 32 85 54 61 95 66 34 25 25 61 29 65 32 87 54 60 95 65 34 1 2 67 46 1 3 40 27 49 69 233 27 49 68 41 67 47 254 252 39 0 0 3 0 46 255 244 3 33 1 242 0 40 0 60 0 67 0 105 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 184 0 16 208 186 0 24 0 10 0 0 17 18 57 184 0 0 16 185 0 41 0 1 244 184 0 29 208 184 0 0 16 184 0 36 208 184 0 10 16 185 0 51 0 1 244 184 0 24 16 185 0 62 0 1 244 184 0 51 16 184 0 65 208 48 49 5 34 46 2 53 52 62 2 51 50 22 23 62 1 51 50 30 2 21 20 7 33 30 3 51 50 54 55 23 14 1 35 34 38 39 6 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 55 51 52 38 35 34 6 1 8 44 79 60 35 36 60 80 44 56 94 26 28 89 54 45 70 48 25 3 254 193 1 25 41 55 31 35 58 27 30 32 78 50 57 94 28 57 120 30 50 36 20 20 36 50 30 30 50 36 20 20 36 50 243 250 62 56 51 74 12 34 65 95 60 61 95 66 34 62 60 57 65 32 60 85 52 28 18 38 62 44 24 23 17 57 20 30 64 57 121 68 27 49 68 42 42 69 50 27 27 50 69 42 42 68 49 27 222 75 80 83 0 0 2 0 46 255 244 2 12 2 145 0 34 0 54 0 67 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 45 0 1 244 186 0 27 0 10 0 45 17 18 57 184 0 0 16 185 0 35 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 23 62 1 53 52 38 39 55 30 1 21 20 14 2 7 30 1 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 15 45 81 62 37 37 62 81 45 50 45 42 44 8 7 64 10 13 19 31 39 21 38 44 37 62 81 45 31 52 37 20 20 37 52 31 31 52 37 20 20 37 52 12 34 65 95 60 61 95 66 34 21 8 45 42 14 29 12 30 17 40 22 30 44 33 21 6 32 102 68 60 95 65 34 68 27 49 68 42 42 69 50 27 27 50 69 42 42 68 49 27 0 255 255 0 46 255 244 2 12 3 13 2 38 1 116 0 0 0 7 7 34 1 15 0 0 255 255 0 46 255 244 2 12 3 13 2 38 1 116 0 0 0 7 7 31 1 15 0 0 255 255 0 46 255 244 2 12 2 248 2 38 1 116 0 0 0 7 7 53 1 15 0 0 255 255 0 46 255 244 2 12 2 209 2 38 1 116 0 0 0 7 7 39 1 0 0 0 255 255 0 46 255 51 2 12 2 145 2 38 1 116 0 0 0 7 7 49 1 16 252 233 0 2 0 46 255 50 1 240 1 242 0 40 0 60 0 73 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 9 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 186 0 34 0 0 0 3 43 184 0 8 16 184 0 28 208 184 0 8 16 185 0 41 0 1 244 184 0 18 16 185 0 51 0 1 244 48 49 5 34 38 53 52 62 2 55 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 14 1 21 20 22 51 50 54 55 23 14 1 3 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 1 39 38 52 11 17 19 9 44 78 59 34 37 62 81 45 45 81 62 37 23 42 58 36 34 37 28 18 12 19 10 21 14 45 44 31 52 37 20 20 37 52 31 31 52 37 20 20 37 52 206 43 42 19 33 29 22 7 2 37 64 92 58 61 95 66 34 34 66 95 61 51 77 59 43 16 16 56 29 23 23 7 6 41 11 16 1 6 27 49 68 42 42 69 50 27 27 50 69 42 42 68 49 27 255 255 0 82 0 0 1 104 3 13 2 38 0 45 0 0 0 7 7 34 0 217 0 0 255 255 0 26 255 30 1 94 1 242 2 38 0 45 0 0 0 6 7 82 121 0 0 0 255 255 0 62 0 0 1 116 2 234 2 38 0 45 0 0 0 7 7 59 0 217 0 0 255 255 0 82 0 0 1 94 2 182 2 38 0 45 0 0 0 7 7 49 0 216 0 0 255 255 0 67 255 51 1 94 1 242 2 38 0 45 0 0 0 7 7 49 0 121 252 233 255 255 0 67 255 51 1 94 2 146 2 38 0 45 0 0 0 39 7 41 0 217 0 0 0 7 7 49 0 121 252 233 255 255 255 244 255 87 1 94 1 242 2 38 0 45 0 0 0 7 7 41 0 121 252 254 255 255 0 28 255 244 1 131 3 13 2 38 0 46 0 0 0 7 7 34 0 219 0 0 255 255 0 28 255 244 1 131 2 228 2 38 0 46 0 0 0 7 7 37 0 219 0 0 255 255 0 28 255 244 1 131 2 234 2 38 0 46 0 0 0 7 7 59 0 219 0 0 255 255 0 28 255 30 1 131 1 242 2 38 0 46 0 0 0 7 7 84 0 222 0 0 255 255 0 28 255 30 1 131 1 242 2 38 0 46 0 0 0 7 7 82 0 222 0 0 255 255 0 28 255 244 1 131 2 182 2 38 0 46 0 0 0 7 7 49 0 219 0 0 255 255 0 28 255 51 1 131 1 242 2 38 0 46 0 0 0 7 7 49 0 223 252 233 0 1 0 82 255 244 2 35 2 210 0 55 0 105 0 184 0 0 69 88 184 0 34 47 27 185 0 34 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 186 0 10 0 34 0 0 17 18 57 186 0 17 0 34 0 0 17 18 57 184 0 34 16 185 0 25 0 1 244 184 0 0 16 184 0 30 208 184 0 30 47 186 0 44 0 0 0 34 17 18 57 186 0 51 0 0 0 34 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 46 4 53 52 62 2 53 52 38 35 34 6 21 17 35 17 52 54 51 50 30 2 21 20 14 2 21 20 30 4 21 20 14 2 1 131 42 68 31 33 26 51 29 42 42 29 44 51 44 29 27 33 28 41 42 54 59 82 102 94 39 61 42 21 28 35 28 29 44 51 44 29 22 42 59 12 26 23 58 22 21 48 32 29 38 28 25 32 45 35 34 48 44 46 32 38 49 77 78 254 12 2 3 94 113 23 40 53 30 38 53 44 41 26 24 32 25 26 36 54 40 32 54 40 23 255 255 0 24 255 244 1 69 2 248 2 38 0 47 0 0 0 7 7 61 1 26 0 0 255 255 0 24 255 30 1 69 2 110 2 38 0 47 0 0 0 7 7 84 0 216 0 0 255 255 0 24 255 30 1 69 2 110 2 38 0 47 0 0 0 7 7 82 0 213 0 0 255 255 0 24 255 51 1 69 2 110 2 38 0 47 0 0 0 7 7 49 0 214 252 233 255 255 0 24 255 87 1 90 2 110 2 38 0 47 0 0 0 7 7 41 0 213 252 254 255 255 255 254 255 244 1 69 3 55 2 38 0 47 0 0 0 7 7 51 0 144 0 136 0 1 0 24 255 244 1 69 2 110 0 33 0 103 0 124 184 0 8 47 24 184 0 0 69 88 184 0 6 47 27 185 0 6 0 9 62 89 184 0 0 69 88 184 0 27 47 27 185 0 27 0 5 62 89 186 0 2 0 33 0 3 43 184 0 6 16 185 0 3 0 1 244 184 0 6 16 184 0 10 208 184 0 3 16 184 0 11 208 184 0 2 16 184 0 14 208 184 0 33 16 184 0 15 208 184 0 27 16 185 0 20 0 1 244 48 49 55 53 55 53 35 53 63 1 51 21 51 21 35 21 51 21 35 21 20 22 51 50 54 55 23 14 1 35 34 46 2 61 1 24 72 72 76 10 69 131 131 131 131 33 42 13 30 12 16 20 47 23 39 53 33 14 231 43 5 140 62 5 136 136 67 140 48 82 45 49 8 5 62 7 11 24 42 60 36 81 0 0 0 255 255 0 75 255 244 1 206 3 13 2 38 0 48 0 0 0 7 7 31 1 16 0 0 255 255 0 75 255 244 1 206 3 13 2 38 0 48 0 0 0 7 7 34 1 16 0 0 255 255 0 75 255 244 1 206 2 228 2 38 0 48 0 0 0 7 7 37 1 16 0 0 255 255 0 75 255 244 1 206 2 209 2 38 0 48 0 0 0 7 7 39 1 16 0 0 255 255 0 75 255 244 1 206 2 175 2 38 0 48 0 0 0 7 7 51 1 16 0 0 255 255 0 75 255 244 1 206 2 146 2 38 0 48 0 0 0 7 7 41 1 13 0 0 255 255 0 75 255 244 1 206 2 218 2 38 0 48 0 0 0 7 7 45 1 16 0 0 255 255 0 75 255 244 1 206 2 239 2 38 0 48 0 0 0 7 7 55 1 16 0 0 255 255 0 75 255 244 1 215 2 249 2 38 0 48 0 0 0 7 7 57 1 16 0 0 255 255 0 75 255 244 1 206 2 234 2 38 0 48 0 0 0 7 7 59 1 16 0 0 255 255 0 75 255 244 1 206 3 29 2 38 0 48 0 0 0 7 7 112 1 16 0 0 255 255 0 75 255 244 1 206 3 76 2 38 0 48 0 0 0 7 7 105 1 16 0 0 255 255 0 75 255 244 1 206 3 72 2 38 0 48 0 0 0 7 7 114 1 16 0 0 255 255 0 75 255 244 1 206 3 76 2 38 0 48 0 0 0 7 7 108 1 16 0 0 255 255 0 75 255 51 1 206 1 230 2 38 0 48 0 0 0 7 7 49 1 34 252 233 255 255 0 75 255 244 1 206 2 248 2 38 0 48 0 0 0 7 7 53 1 16 0 0 0 1 0 75 255 50 1 227 1 230 0 38 0 103 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 9 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 186 0 32 0 0 0 3 43 184 0 11 16 184 0 6 208 186 0 7 0 15 0 11 17 18 57 184 0 11 16 185 0 20 0 1 244 184 0 7 16 185 0 23 0 1 244 184 0 15 16 184 0 24 208 184 0 6 16 184 0 26 208 184 0 26 47 48 49 5 34 38 53 52 54 55 39 35 14 1 35 34 38 53 17 51 17 20 22 51 50 54 55 17 51 17 14 1 21 20 22 51 50 54 55 23 14 1 1 149 38 53 49 32 8 3 34 75 51 78 71 83 42 49 38 58 35 82 45 42 29 17 12 20 9 21 14 45 206 43 42 41 61 23 72 40 48 96 94 1 52 254 215 69 61 39 43 1 89 254 26 22 54 29 23 23 7 6 41 11 16 0 0 1 0 75 255 244 2 46 2 155 0 37 0 89 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 9 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 33 47 27 185 0 33 0 5 62 89 184 0 0 16 185 0 9 0 1 244 184 0 14 16 184 0 31 220 48 49 23 34 38 53 17 51 17 20 22 51 50 54 55 17 51 62 3 53 52 38 39 55 30 1 21 20 14 2 7 17 35 39 35 14 1 224 78 71 83 43 48 38 58 35 21 18 30 23 13 8 6 64 10 13 17 27 35 17 68 7 3 34 75 12 96 94 1 52 254 215 69 61 39 43 1 89 3 12 22 34 25 14 29 12 30 17 40 22 30 45 32 20 6 254 57 76 40 48 0 0 0 255 255 0 75 255 244 2 46 3 13 2 38 1 162 0 0 0 7 7 34 1 10 0 0 255 255 0 75 255 244 2 46 3 13 2 38 1 162 0 0 0 7 7 31 1 10 0 0 255 255 0 75 255 244 2 46 2 248 2 38 1 162 0 0 0 7 7 53 1 10 0 0 255 255 0 75 255 244 2 46 2 209 2 38 1 162 0 0 0 7 7 39 1 10 0 0 255 255 0 75 255 51 2 46 2 155 2 38 1 162 0 0 0 7 7 49 1 28 252 233 255 255 0 24 0 0 2 182 3 13 2 38 0 50 0 0 0 7 7 31 1 104 0 0 255 255 0 24 0 0 2 182 3 13 2 38 0 50 0 0 0 7 7 34 1 104 0 0 255 255 0 24 0 0 2 182 2 228 2 38 0 50 0 0 0 7 7 37 1 104 0 0 255 255 0 24 0 0 2 182 2 175 2 38 0 50 0 0 0 7 7 51 1 104 0 0 255 255 0 12 255 47 1 199 3 13 2 38 0 52 0 0 0 7 7 31 0 242 0 0 255 255 0 12 255 47 1 199 3 13 2 38 0 52 0 0 0 7 7 34 0 242 0 0 255 255 0 12 255 47 1 199 2 228 2 38 0 52 0 0 0 7 7 37 0 242 0 0 255 255 0 12 255 47 1 199 2 175 2 38 0 52 0 0 0 7 7 51 0 242 0 0 255 255 0 12 255 47 1 199 2 182 2 38 0 52 0 0 0 7 7 49 0 242 0 0 255 255 0 12 255 47 1 199 1 230 2 38 0 52 0 0 0 7 7 49 1 135 252 237 255 255 0 12 255 47 1 199 2 248 2 38 0 52 0 0 0 7 7 53 0 242 0 0 255 255 0 12 255 47 1 199 2 209 2 38 0 52 0 0 0 7 7 39 0 242 0 0 255 255 0 31 0 0 1 143 3 13 2 38 0 53 0 0 0 7 7 34 0 228 0 0 255 255 0 31 0 0 1 143 2 234 2 38 0 53 0 0 0 7 7 59 0 228 0 0 255 255 0 31 0 0 1 143 2 182 2 38 0 53 0 0 0 7 7 49 0 228 0 0 255 255 0 31 255 51 1 143 1 230 2 38 0 53 0 0 0 7 7 49 0 228 252 233 255 255 0 31 255 87 1 143 1 230 2 38 0 53 0 0 0 7 7 41 0 228 252 254 0 2 0 53 255 244 1 229 2 218 0 35 0 56 0 93 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 22 16 184 0 19 208 184 0 16 220 184 0 17 208 184 0 10 208 184 0 19 16 184 0 25 208 184 0 16 16 184 0 28 208 184 0 0 16 185 0 36 0 1 244 184 0 10 16 185 0 47 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 46 1 39 7 39 55 38 39 55 30 1 23 55 23 7 30 1 21 20 14 2 39 50 62 2 53 52 38 39 46 1 35 34 14 2 21 20 30 2 1 13 42 78 60 36 32 55 75 44 38 70 26 14 55 38 141 24 127 52 60 38 36 70 32 142 24 129 60 76 31 57 79 47 34 50 34 17 1 1 33 66 34 33 52 36 19 22 39 50 12 32 61 87 54 51 83 59 32 32 34 62 92 38 73 41 65 40 32 52 20 44 27 73 41 66 61 168 119 60 99 71 39 68 29 52 73 44 14 28 13 44 30 24 44 59 34 38 61 43 24 0 0 0 0 2 0 82 255 51 1 251 2 200 0 22 0 39 0 127 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 19 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 5 62 89 186 0 4 0 7 0 17 17 18 57 186 0 20 0 17 0 7 17 18 57 185 0 23 0 1 244 184 0 7 16 185 0 33 0 1 244 184 0 4 16 185 0 36 0 1 244 184 0 20 16 185 0 37 0 1 244 48 49 23 17 51 21 7 62 1 51 50 30 2 21 20 14 2 35 34 38 39 23 21 19 50 62 2 53 52 46 2 35 34 6 7 21 30 1 82 82 1 32 76 40 48 73 50 25 34 58 76 42 35 66 33 1 119 30 51 37 21 14 31 49 34 31 63 36 33 62 205 3 149 194 83 26 37 35 65 91 57 62 97 68 35 28 26 83 164 1 6 27 49 72 45 40 66 47 26 34 32 255 28 23 0 0 0 0 1 0 82 255 73 1 215 1 242 0 32 0 89 0 184 0 0 69 88 184 0 26 47 27 185 0 26 0 9 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 187 0 7 0 1 0 0 0 4 43 184 0 26 16 185 0 14 0 1 244 186 0 22 0 26 0 19 17 18 57 184 0 22 16 185 0 17 0 1 244 184 0 26 16 184 0 20 208 184 0 20 47 48 49 5 34 38 39 55 30 1 51 50 54 53 17 52 38 35 34 6 7 17 35 17 51 23 51 62 1 51 50 22 21 17 20 6 1 82 23 36 12 16 9 24 13 36 24 44 48 38 58 37 82 68 7 3 35 77 51 77 71 60 183 8 5 63 3 6 51 45 1 61 69 61 38 37 254 160 1 230 70 35 47 96 94 254 183 74 88 0 0 0 0 1 255 216 255 39 0 165 1 230 0 15 0 43 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 185 0 7 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 53 17 51 17 20 6 32 23 36 13 17 9 24 13 36 24 82 60 217 8 5 62 3 5 50 45 2 29 253 227 74 88 0 0 4 0 67 255 39 1 171 2 180 0 3 0 15 0 31 0 43 0 96 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 7 62 89 184 0 1 16 184 0 4 208 184 0 10 208 184 0 16 16 185 0 23 0 1 244 184 0 1 16 184 0 27 208 184 0 4 16 184 0 32 208 184 0 38 208 48 49 51 17 51 17 3 34 38 53 52 54 51 50 22 21 20 6 19 34 38 39 55 30 1 51 50 54 53 17 51 17 20 6 19 34 38 53 52 54 51 50 22 21 20 6 82 82 40 24 33 33 24 24 33 33 130 23 36 13 17 9 24 13 36 24 82 60 20 24 33 33 24 23 33 33 1 230 254 26 2 74 30 23 24 29 29 24 23 30 252 221 8 5 62 3 5 50 45 2 29 253 227 74 88 3 35 30 23 24 29 29 24 23 30 0 0 0 0 2 0 75 255 244 1 200 1 242 0 29 0 41 0 109 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 12 16 184 0 6 208 184 0 6 47 186 0 9 0 0 0 12 17 18 57 186 0 18 0 12 0 0 17 18 57 184 0 0 16 185 0 23 0 1 244 184 0 18 16 185 0 30 0 1 244 184 0 12 16 185 0 38 0 1 244 184 0 9 16 185 0 41 0 1 244 48 49 5 34 46 2 53 17 51 23 51 62 1 51 50 22 21 20 6 7 20 30 2 51 50 54 55 23 14 1 39 62 3 53 52 38 35 34 6 7 1 14 52 74 47 22 68 7 2 35 89 49 57 74 143 156 12 28 48 36 41 69 28 32 32 94 168 61 84 51 22 45 32 34 69 38 12 30 54 77 47 1 34 68 36 44 65 62 83 93 17 22 44 34 22 32 20 57 22 41 244 8 24 31 41 24 38 34 36 40 0 0 0 0 2 0 82 255 244 1 251 1 242 0 21 0 38 0 117 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 2 0 0 0 12 17 18 57 184 0 5 208 184 0 5 47 184 0 12 16 184 0 6 208 184 0 6 47 186 0 8 0 12 0 0 17 18 57 184 0 0 16 185 0 22 0 1 244 184 0 12 16 185 0 32 0 1 244 184 0 8 16 185 0 35 0 1 244 184 0 2 16 185 0 36 0 1 244 48 49 5 34 39 35 7 35 17 51 23 51 62 1 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 6 7 21 30 1 1 41 68 71 3 6 67 68 7 3 33 79 43 47 72 48 25 34 58 76 56 30 51 37 21 14 31 49 34 31 63 36 33 62 12 59 47 1 230 57 29 40 35 65 91 57 62 97 68 35 69 27 49 72 45 40 66 47 26 34 32 255 28 23 0 2 0 82 255 244 1 251 2 212 0 34 0 48 0 136 0 184 0 3 47 184 0 0 69 88 184 0 25 47 27 185 0 25 0 9 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 4 0 0 0 25 17 18 57 184 0 6 208 184 0 6 47 184 0 12 16 185 0 18 0 1 244 186 0 22 0 25 0 0 17 18 57 184 0 0 16 185 0 35 0 1 244 184 0 25 16 185 0 43 0 1 244 184 0 22 16 185 0 45 0 1 244 184 0 3 16 185 0 46 0 1 244 48 49 5 34 38 39 35 7 35 17 52 62 2 51 50 22 23 7 38 35 34 6 15 1 62 1 51 50 30 2 21 20 14 2 39 50 62 2 53 52 38 35 34 7 21 30 1 1 41 34 73 32 3 7 66 21 42 63 43 22 43 17 19 27 28 48 45 2 2 33 78 41 47 72 49 25 34 58 76 56 30 51 37 21 59 69 60 70 32 63 12 31 29 48 2 25 42 68 50 27 9 7 63 12 64 57 113 29 39 35 63 91 55 62 96 66 35 69 26 49 70 44 79 97 67 247 28 23 0 0 0 1 0 25 255 244 1 154 1 242 0 33 0 53 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 184 0 24 16 185 0 17 0 1 244 48 49 23 34 38 39 55 30 1 51 50 62 2 53 52 46 2 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 182 45 80 32 35 23 58 33 33 55 41 22 22 38 53 30 35 49 22 42 27 75 55 43 80 60 36 36 61 83 12 33 29 55 20 29 27 49 68 42 42 70 49 27 23 20 54 23 34 34 65 95 62 60 95 65 34 0 0 0 2 0 46 255 187 1 178 1 242 0 10 0 52 0 103 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 9 62 89 184 0 0 69 88 184 0 49 47 27 185 0 49 0 5 62 89 185 0 0 0 1 244 184 0 6 220 185 0 41 0 1 244 186 0 9 0 41 0 49 17 18 57 186 0 15 0 49 0 41 17 18 57 184 0 23 16 185 0 30 0 1 244 186 0 38 0 41 0 49 17 18 57 186 0 51 0 49 0 41 17 18 57 48 49 37 50 54 53 52 38 35 34 6 7 22 7 39 62 1 55 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 22 23 62 1 51 50 22 21 20 14 2 35 34 39 6 1 28 36 47 25 27 27 59 28 37 115 66 11 26 14 29 33 38 64 85 47 48 68 26 40 21 49 29 34 57 42 23 16 14 38 83 42 54 60 21 39 57 35 68 53 23 54 30 23 17 28 38 34 26 123 28 29 51 23 32 91 57 61 95 66 34 34 23 51 19 24 28 50 70 43 34 58 23 41 43 57 46 25 43 33 19 32 42 0 0 0 0 2 0 47 255 73 2 63 2 212 0 31 0 46 0 124 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 9 62 89 184 0 0 69 88 184 0 20 47 27 185 0 20 0 19 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 187 0 25 0 1 0 0 0 4 43 186 0 4 0 7 0 15 17 18 57 186 0 18 0 15 0 7 17 18 57 184 0 7 16 185 0 32 0 1 244 184 0 4 16 185 0 35 0 1 244 184 0 18 16 185 0 36 0 1 244 184 0 15 16 185 0 39 0 1 244 48 49 5 34 38 53 55 14 1 35 34 38 53 52 62 2 51 50 22 23 39 53 51 17 20 22 51 50 54 55 23 14 1 37 50 54 55 53 46 1 35 34 14 2 21 20 22 2 2 63 58 1 30 73 43 92 109 35 58 76 42 42 62 32 4 83 21 29 10 18 8 16 11 31 254 245 34 60 30 31 57 30 29 51 38 22 70 183 73 64 102 29 39 132 122 59 95 66 36 30 26 83 199 253 16 42 46 6 3 63 5 8 240 33 34 254 28 23 27 49 68 42 88 98 0 0 0 2 0 47 255 244 2 67 2 214 0 31 0 46 0 136 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 19 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 11 0 8 0 0 17 18 57 184 0 15 16 185 0 22 0 1 244 184 0 0 16 184 0 26 208 184 0 26 47 186 0 28 0 0 0 8 17 18 57 184 0 0 16 185 0 32 0 1 244 184 0 28 16 185 0 35 0 1 244 184 0 11 16 185 0 36 0 1 244 184 0 8 16 185 0 39 0 1 244 48 49 23 34 38 53 52 62 2 51 50 22 23 39 52 54 51 50 22 23 7 46 1 35 34 6 21 17 35 39 35 14 1 39 50 54 55 53 46 1 35 34 14 2 21 20 22 248 92 109 35 58 76 42 42 62 32 1 63 67 17 28 11 16 7 15 9 33 26 68 7 3 29 75 25 34 60 30 31 57 30 29 51 38 22 70 12 132 122 59 95 66 36 30 26 133 70 81 5 5 63 2 4 50 42 253 201 57 28 41 69 33 34 254 28 23 27 49 68 42 88 98 0 2 0 37 255 244 1 194 1 242 0 28 0 35 0 73 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 186 0 10 0 19 0 0 17 18 57 184 0 10 47 185 0 29 0 1 244 184 0 19 16 185 0 33 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 55 33 46 1 53 52 62 2 51 50 30 2 21 20 14 2 3 33 46 1 35 34 6 221 50 82 32 29 27 63 35 72 81 4 254 185 2 2 29 53 75 47 44 76 57 32 34 62 84 160 1 3 7 68 55 57 72 12 30 20 54 17 21 91 78 9 25 13 52 84 60 32 35 66 95 60 60 94 65 35 1 38 72 79 77 0 2 0 47 255 244 1 217 1 242 0 20 0 35 0 121 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 11 0 8 0 0 17 18 57 184 0 8 16 184 0 14 208 184 0 14 47 184 0 0 16 184 0 15 208 184 0 15 47 186 0 17 0 0 0 8 17 18 57 184 0 0 16 185 0 21 0 1 244 184 0 17 16 185 0 24 0 1 244 184 0 11 16 185 0 25 0 1 244 184 0 8 16 185 0 28 0 1 244 48 49 23 34 38 53 52 62 2 51 50 22 23 51 55 51 17 35 39 35 14 1 39 50 54 55 53 46 1 35 34 14 2 21 20 22 248 92 109 35 59 76 42 41 64 33 2 7 67 68 7 3 29 75 25 34 60 30 31 57 30 29 51 38 22 70 12 132 122 59 95 66 36 30 29 47 254 26 57 28 41 69 33 34 254 28 23 27 49 68 42 88 98 255 255 0 82 0 0 1 213 1 230 2 6 3 228 0 0 0 2 0 37 255 244 1 194 1 242 0 28 0 35 0 81 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 9 0 19 0 0 17 18 57 184 0 9 47 184 0 19 16 185 0 12 0 1 244 184 0 0 16 185 0 29 0 1 244 184 0 9 16 185 0 33 0 1 244 48 49 23 34 46 2 53 52 54 55 33 46 1 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 39 50 54 55 33 20 22 238 46 74 53 28 2 2 1 71 4 75 66 37 60 29 29 34 83 51 46 78 57 33 33 57 78 46 57 69 7 254 253 68 12 32 61 87 54 14 25 9 73 90 23 19 57 23 27 34 66 94 60 60 95 66 35 66 82 75 79 78 0 0 2 0 37 255 244 2 156 1 242 0 46 0 58 0 89 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 6 0 55 0 3 43 186 0 26 0 33 0 3 43 184 0 16 16 185 0 9 0 1 244 184 0 6 16 184 0 19 220 184 0 55 16 184 0 39 220 184 0 0 16 185 0 47 0 1 244 48 49 23 34 46 2 39 37 46 1 35 34 6 7 39 62 1 51 50 22 23 55 23 30 3 51 50 54 55 23 14 1 35 34 46 2 39 7 30 1 21 20 14 2 39 50 62 2 53 52 38 39 5 30 1 249 50 75 53 30 4 1 67 17 72 48 38 58 28 30 34 79 50 71 103 25 81 44 2 9 12 16 11 12 20 8 22 12 33 21 15 29 26 21 5 60 2 3 29 52 75 48 29 47 33 17 1 1 254 254 10 72 12 34 57 76 42 132 53 51 23 19 57 23 27 73 67 33 17 29 35 20 7 9 6 43 9 16 9 23 37 27 24 15 31 17 52 91 68 40 65 28 49 65 37 11 19 9 105 54 59 0 1 0 50 255 244 1 163 1 242 0 47 0 77 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 33 0 1 0 34 0 4 43 186 0 11 0 34 0 33 17 18 57 184 0 19 16 185 0 26 0 1 244 184 0 0 16 185 0 41 0 1 244 48 49 23 34 46 2 53 52 62 2 55 53 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 59 1 21 35 34 6 21 20 22 51 50 54 55 23 14 1 249 41 73 54 31 18 30 39 21 40 42 29 48 64 36 44 71 32 33 27 53 32 41 56 54 59 55 70 60 64 70 56 33 61 32 35 42 78 12 20 38 54 34 26 41 30 19 6 4 14 59 34 33 50 32 16 25 23 55 17 21 38 38 33 42 59 42 40 41 46 21 23 55 30 25 0 0 1 0 37 255 244 1 150 1 242 0 47 0 77 0 184 0 0 69 88 184 0 29 47 27 185 0 29 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 16 0 1 0 13 0 4 43 184 0 0 16 185 0 7 0 1 244 184 0 29 16 185 0 22 0 1 244 186 0 38 0 13 0 16 17 18 57 48 49 23 34 38 39 55 30 1 51 50 54 53 52 38 43 1 53 51 50 54 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 210 50 80 43 35 33 60 33 56 70 64 60 69 54 59 54 52 41 32 57 27 33 33 77 45 34 62 46 27 42 40 21 39 30 18 31 53 71 12 25 30 55 23 21 46 41 40 42 59 42 33 38 38 21 17 55 23 25 16 32 50 33 34 59 14 4 6 19 30 41 26 34 54 38 20 0 0 0 2 0 50 255 244 1 245 1 242 0 28 0 49 0 77 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 42 0 1 0 43 0 4 43 186 0 11 0 43 0 42 17 18 57 184 0 0 16 185 0 29 0 1 244 184 0 19 16 185 0 35 0 1 244 48 49 5 34 46 2 53 52 62 2 55 53 46 1 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 59 1 21 35 34 6 21 20 22 1 3 44 77 56 32 18 30 39 21 40 42 28 49 65 38 50 89 67 39 38 65 88 50 72 84 86 73 42 57 52 57 27 42 58 62 69 12 20 38 54 34 26 41 30 19 6 4 14 59 34 33 50 32 16 32 64 96 64 63 95 64 32 66 96 92 93 98 38 38 33 42 59 42 40 41 46 0 0 1 255 227 255 39 1 3 1 230 0 23 0 77 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 187 0 18 0 1 0 19 0 4 43 184 0 0 16 185 0 7 0 1 244 184 0 19 16 184 0 11 208 184 0 18 16 184 0 13 208 184 0 13 47 48 49 23 34 38 39 55 30 1 51 50 54 53 17 35 53 55 53 51 21 51 21 35 17 20 6 43 23 36 13 17 9 24 13 36 24 86 86 82 83 83 60 217 8 5 62 3 5 50 45 1 30 43 5 207 207 48 254 226 74 88 0 0 0 2 0 50 255 40 2 69 2 117 0 43 0 58 0 117 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 187 0 37 0 1 0 31 0 4 43 187 0 44 0 1 0 14 0 4 43 184 0 0 16 185 0 7 0 1 244 186 0 11 0 14 0 24 17 18 57 186 0 27 0 24 0 14 17 18 57 184 0 11 16 185 0 47 0 1 244 184 0 27 16 185 0 48 0 1 244 184 0 24 16 185 0 51 0 1 244 48 49 5 34 38 39 55 30 1 51 50 54 63 1 14 1 35 34 46 2 53 52 62 2 51 50 22 23 39 52 54 51 50 22 23 7 38 35 34 6 21 17 20 6 3 50 54 55 53 46 1 35 34 14 2 21 20 22 1 3 45 91 38 30 36 73 35 67 65 2 1 28 73 43 46 74 52 28 35 58 77 41 42 60 32 1 63 68 17 28 11 16 14 17 33 26 112 95 34 59 32 32 57 30 29 51 38 22 70 216 27 26 58 24 21 69 59 92 27 38 34 63 91 57 57 92 64 35 30 26 41 66 80 5 5 63 6 50 42 254 18 91 101 1 33 33 34 238 28 23 26 48 65 39 82 96 0 0 2 0 50 255 40 1 219 1 242 0 33 0 48 0 119 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 187 0 34 0 1 0 14 0 4 43 184 0 0 16 185 0 7 0 1 244 186 0 11 0 24 0 14 17 18 57 186 0 27 0 24 0 14 17 18 57 184 0 24 16 184 0 30 208 184 0 30 47 184 0 11 16 185 0 37 0 1 244 184 0 27 16 185 0 38 0 1 244 184 0 24 16 185 0 41 0 1 244 48 49 5 34 38 39 55 30 1 51 50 54 63 1 14 1 35 34 46 2 53 52 62 2 51 50 22 23 51 55 51 17 20 6 3 50 54 55 53 46 1 35 34 14 2 21 20 22 1 3 45 91 38 30 36 73 35 67 65 2 1 28 73 43 46 74 52 28 35 58 77 41 42 63 31 2 7 69 112 95 34 59 32 32 57 30 29 51 38 22 70 216 27 26 58 24 21 69 59 92 27 38 34 63 91 57 57 92 64 35 29 28 45 254 2 91 101 1 33 33 34 238 28 23 26 48 65 39 82 96 0 0 1 0 46 255 244 1 192 1 242 0 35 0 79 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 17 0 1 244 184 0 0 16 185 0 25 0 1 244 186 0 30 0 10 0 0 17 18 57 125 184 0 30 47 24 185 0 32 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 22 51 50 54 55 53 35 53 51 21 14 1 1 24 49 86 63 36 37 65 87 50 57 72 26 40 21 51 39 33 59 43 25 86 72 27 46 15 108 181 27 87 12 33 65 96 62 59 94 66 35 37 23 51 18 28 25 49 70 45 90 100 16 14 119 59 213 26 35 0 0 2 0 12 255 32 1 199 1 230 0 26 0 39 0 95 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 186 0 12 0 7 0 0 17 18 57 186 0 34 0 0 0 7 17 18 57 186 0 6 0 12 0 34 17 18 57 184 0 7 16 184 0 17 208 186 0 19 0 34 0 13 17 18 57 184 0 0 16 185 0 27 0 1 244 48 49 23 34 38 53 52 54 55 3 51 19 30 1 23 51 62 1 55 19 51 3 30 3 21 20 6 39 50 54 53 52 38 39 35 14 1 21 20 22 236 54 57 30 26 169 85 92 11 23 11 4 11 22 11 92 81 166 13 21 15 8 57 53 20 19 20 18 4 17 20 20 224 64 52 35 73 52 1 178 254 253 33 57 32 32 57 33 1 3 254 79 26 44 38 35 18 52 64 57 30 23 27 63 35 35 65 25 23 30 0 0 2 0 16 255 244 1 239 1 242 0 35 0 47 0 113 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 18 0 15 0 0 17 18 57 186 0 42 0 15 0 0 17 18 57 186 0 6 0 18 0 42 17 18 57 184 0 15 16 185 0 9 0 1 244 184 0 15 16 184 0 21 208 184 0 9 16 184 0 27 208 186 0 30 0 42 0 18 17 18 57 184 0 0 16 185 0 36 0 1 244 48 49 5 34 38 53 52 54 55 46 1 35 34 7 39 62 1 51 50 22 23 62 1 51 50 22 23 7 38 35 34 6 7 30 1 21 20 6 39 50 54 53 52 38 39 14 1 21 20 22 1 0 85 89 67 50 26 56 28 28 19 26 15 46 23 41 80 35 35 79 41 23 46 15 26 20 27 29 55 26 49 68 88 85 48 46 55 39 40 54 46 12 89 78 55 106 47 32 35 14 60 11 11 47 40 40 47 11 11 60 14 35 32 47 106 55 78 89 68 59 42 44 86 37 37 86 44 42 59 0 1 0 75 255 51 1 209 1 230 0 20 0 92 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 9 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 186 0 2 0 9 0 0 17 18 57 184 0 5 16 185 0 14 0 1 244 184 0 2 16 185 0 17 0 1 244 184 0 9 16 184 0 18 208 48 49 5 53 55 14 1 35 34 38 53 17 51 17 20 22 51 50 54 55 17 51 17 1 126 5 35 77 51 78 71 83 43 48 38 60 35 83 205 174 106 39 48 96 94 1 52 254 215 69 61 38 44 1 89 253 77 0 0 0 0 1 0 82 0 0 1 215 2 212 0 32 0 102 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 19 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 6 16 185 0 12 0 1 244 186 0 16 0 6 0 0 17 18 57 184 0 0 16 184 0 24 208 184 0 19 16 185 0 28 0 1 244 184 0 16 16 185 0 31 0 1 244 48 49 51 17 52 62 2 51 50 22 23 7 38 35 34 6 15 1 62 1 51 50 22 21 17 35 17 52 38 35 34 6 7 17 82 21 42 63 43 22 43 17 19 27 28 48 45 2 3 35 76 51 77 71 82 44 48 38 58 37 2 25 42 68 50 27 9 7 63 12 64 57 126 33 48 96 94 254 211 1 34 69 60 37 37 254 167 0 0 0 0 1 0 82 255 73 1 215 2 212 0 44 0 104 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 19 62 89 184 0 0 69 88 184 0 38 47 27 185 0 38 0 9 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 187 0 7 0 1 0 0 0 4 43 184 0 38 16 185 0 14 0 1 244 186 0 35 0 25 0 19 17 18 57 184 0 35 16 185 0 17 0 1 244 184 0 25 16 185 0 31 0 1 244 48 49 5 34 38 39 55 30 1 51 50 54 53 17 52 38 35 34 6 7 17 35 17 52 62 2 51 50 22 23 7 38 35 34 6 15 1 62 1 51 50 22 21 17 20 6 1 82 23 36 12 16 9 24 13 36 24 44 48 38 58 37 82 21 42 63 43 22 43 17 19 27 28 48 45 2 3 35 76 51 77 71 60 183 8 5 63 3 6 51 45 1 54 69 60 37 37 254 167 2 25 42 68 50 27 9 7 63 12 64 57 126 33 48 96 94 254 190 74 88 0 1 0 83 0 0 1 225 1 230 0 11 0 63 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 4 0 2 0 9 0 4 43 184 0 1 16 184 0 5 208 184 0 0 16 184 0 8 208 48 49 51 17 51 21 51 53 51 17 35 53 35 21 83 82 234 82 82 234 1 230 197 197 254 26 216 216 0 0 2 0 8 0 0 1 3 2 180 0 11 0 23 0 75 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 9 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 187 0 11 0 1 0 2 0 4 43 184 0 2 16 184 0 6 208 184 0 11 16 184 0 7 208 184 0 3 16 184 0 12 220 184 0 18 220 48 49 55 53 55 53 51 21 51 21 35 21 35 53 19 34 38 53 52 54 51 50 22 21 20 6 8 86 82 83 83 82 42 24 33 33 24 24 33 33 231 43 5 207 207 48 231 231 1 99 30 23 24 29 29 24 23 30 0 0 1 0 46 0 0 1 39 1 230 0 11 0 65 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 2 0 1 244 184 0 5 16 185 0 3 0 1 244 184 0 7 208 184 0 2 16 184 0 10 208 48 49 51 53 51 17 35 53 51 21 35 17 51 21 46 84 84 249 83 83 67 1 96 67 67 254 160 67 0 0 0 0 3 255 172 254 238 1 50 2 180 0 22 0 33 0 45 0 103 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 9 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 7 62 89 185 0 23 0 1 244 184 0 28 220 184 0 13 220 186 0 2 0 5 0 13 17 18 57 186 0 15 0 13 0 5 17 18 57 186 0 20 0 5 0 13 17 18 57 186 0 26 0 13 0 5 17 18 57 184 0 16 16 184 0 34 220 184 0 40 220 48 49 19 38 39 14 1 35 34 46 2 53 52 54 51 50 23 17 51 17 20 7 22 23 37 50 54 55 38 35 34 6 21 20 22 19 34 38 53 52 54 51 50 22 21 20 6 242 38 37 20 63 44 29 46 32 17 63 58 40 43 82 6 58 52 254 245 30 35 8 40 36 26 27 31 147 24 33 33 24 24 33 33 254 238 71 48 29 33 18 30 40 23 45 55 23 2 3 254 3 34 30 58 99 92 31 24 32 23 17 20 27 2 226 30 23 24 29 29 24 23 30 0 0 0 0 2 255 250 255 244 1 40 2 200 0 30 0 43 0 79 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 19 62 89 184 0 0 69 88 184 0 26 47 27 185 0 26 0 5 62 89 186 0 12 0 15 0 3 43 184 0 12 16 184 0 32 208 184 0 38 208 184 0 6 220 184 0 26 16 185 0 19 0 1 244 184 0 15 16 184 0 30 208 48 49 19 34 38 53 52 54 51 50 22 23 53 51 17 51 21 35 21 20 22 51 58 1 55 23 14 1 35 34 38 61 1 39 51 53 52 46 2 35 34 6 21 20 22 121 66 61 46 37 18 26 10 82 83 83 14 9 4 7 7 11 8 22 17 47 40 20 20 5 11 19 15 18 16 31 1 63 49 38 34 45 11 9 247 254 166 47 227 20 16 2 62 4 4 56 54 221 47 6 11 24 19 13 20 14 16 23 0 0 0 0 1 0 82 255 73 1 11 2 200 0 15 0 30 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 19 62 89 187 0 9 0 1 0 0 0 4 43 48 49 23 34 38 53 17 51 17 20 22 51 50 54 55 23 14 1 205 68 55 82 21 29 11 17 8 17 11 31 183 83 72 2 228 253 28 42 46 6 3 63 5 8 0 0 0 1 0 82 255 39 2 46 2 200 0 40 0 111 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 9 62 89 184 0 0 69 88 184 0 26 47 27 185 0 26 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 184 0 0 69 88 184 0 25 47 27 185 0 25 0 5 62 89 184 0 0 16 185 0 9 0 1 244 186 0 31 0 0 0 28 17 18 57 184 0 31 16 185 0 17 0 1 244 184 0 28 16 185 0 22 0 1 244 48 49 5 34 46 2 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 39 19 33 17 35 17 51 21 33 21 7 54 30 2 21 20 14 2 1 96 36 59 48 38 16 41 26 70 53 27 47 35 21 69 65 21 25 17 33 192 254 239 82 82 1 117 188 48 78 54 29 34 57 75 217 13 22 28 15 52 24 38 21 39 55 34 62 70 8 8 45 1 2 254 93 2 200 226 44 253 5 24 50 74 44 53 81 56 29 0 0 0 0 1 0 82 0 0 1 129 1 230 0 5 0 43 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 185 0 3 0 1 244 48 49 51 17 51 17 51 21 82 82 221 1 230 254 93 67 0 0 1 0 77 255 244 2 236 1 230 0 33 0 127 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 9 0 1 244 186 0 31 0 4 0 0 17 18 57 184 0 31 16 185 0 11 0 1 244 184 0 4 16 184 0 12 208 184 0 9 16 184 0 17 208 184 0 0 16 184 0 28 208 186 0 24 0 12 0 28 17 18 57 184 0 24 16 185 0 19 0 1 244 184 0 12 16 184 0 20 208 184 0 28 16 184 0 22 208 184 0 22 47 48 49 23 34 38 53 17 51 17 20 22 51 50 55 17 51 17 20 22 51 50 55 17 51 17 35 39 35 14 1 35 34 38 39 14 1 225 75 73 82 44 47 55 66 83 43 47 54 68 82 68 7 2 32 76 44 56 63 15 38 77 12 96 94 1 52 254 215 69 61 75 1 96 254 215 69 61 75 1 96 254 26 70 34 48 50 43 42 51 0 1 0 77 255 51 2 236 1 230 0 33 0 136 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 9 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 184 0 15 16 184 0 23 208 184 0 11 16 184 0 5 208 186 0 2 0 23 0 5 17 18 57 186 0 8 0 15 0 11 17 18 57 184 0 11 16 185 0 20 0 1 244 184 0 8 16 185 0 22 0 1 244 184 0 20 16 184 0 28 208 184 0 2 16 185 0 30 0 1 244 184 0 23 16 184 0 31 208 48 49 5 53 55 14 1 35 34 38 39 14 1 35 34 38 53 17 51 17 20 22 51 50 55 17 51 17 20 22 51 50 55 17 51 17 2 154 4 35 74 42 56 63 15 38 77 45 75 73 82 44 47 55 66 83 43 47 54 68 82 205 173 103 38 45 50 43 42 51 96 94 1 52 254 215 69 61 75 1 96 254 215 69 61 75 1 96 253 77 0 0 0 1 0 82 255 73 2 241 1 242 0 45 0 129 0 184 0 0 69 88 184 0 33 47 27 185 0 33 0 9 62 89 184 0 0 69 88 184 0 26 47 27 185 0 26 0 5 62 89 187 0 7 0 1 0 0 0 4 43 184 0 33 16 185 0 22 0 1 244 184 0 14 208 184 0 33 16 184 0 39 208 184 0 26 16 184 0 18 208 186 0 36 0 39 0 18 17 18 57 184 0 36 16 185 0 16 0 1 244 186 0 29 0 33 0 26 17 18 57 184 0 29 16 185 0 24 0 1 244 184 0 33 16 184 0 27 208 184 0 27 47 48 49 5 34 38 39 55 30 1 51 50 54 53 17 52 38 35 34 7 17 35 17 52 38 35 34 7 17 35 17 51 23 51 62 1 51 50 22 23 62 1 51 50 22 21 17 20 6 2 112 21 35 12 16 8 23 12 35 21 44 46 55 67 82 44 47 55 67 82 68 7 3 32 75 44 56 63 15 38 77 45 75 73 59 183 8 5 63 3 6 51 45 1 61 69 61 75 254 160 1 41 69 61 75 254 160 1 230 70 35 47 49 44 42 51 96 94 254 183 74 88 0 0 0 1 255 236 255 73 1 215 1 242 0 32 0 89 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 9 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 5 62 89 187 0 7 0 1 0 0 0 4 43 184 0 17 16 184 0 11 208 184 0 11 47 186 0 13 0 17 0 22 17 18 57 184 0 17 16 185 0 26 0 1 244 184 0 13 16 185 0 29 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 53 17 51 23 51 62 1 51 50 22 21 17 35 17 52 38 35 34 6 7 17 20 6 41 19 32 10 16 8 17 11 29 21 70 5 3 35 77 51 77 71 82 44 48 38 58 37 55 183 8 5 63 3 6 46 42 2 2 70 35 47 96 94 254 204 1 41 69 61 38 37 254 132 72 83 0 1 0 82 255 73 2 61 1 242 0 32 0 89 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 187 0 26 0 1 0 0 0 4 43 184 0 19 16 185 0 7 0 1 244 186 0 15 0 19 0 12 17 18 57 184 0 15 16 185 0 10 0 1 244 184 0 19 16 184 0 13 208 184 0 13 47 48 49 5 34 38 53 17 52 38 35 34 6 7 17 35 17 51 23 51 62 1 51 50 22 21 17 20 22 51 50 54 55 23 14 1 2 0 68 55 44 48 38 58 37 82 68 7 3 35 77 51 77 71 21 29 11 17 8 16 10 32 183 83 72 1 69 69 61 38 37 254 160 1 230 70 35 47 96 94 254 176 42 46 6 3 63 5 8 0 0 0 0 1 0 82 0 0 1 205 1 230 0 23 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 1 16 184 0 11 208 184 0 0 16 184 0 14 208 186 0 7 0 11 0 14 17 18 57 186 0 19 0 1 0 0 17 18 57 48 49 51 17 51 19 30 1 23 51 46 1 61 1 51 17 35 3 46 1 39 35 30 1 29 1 82 78 169 14 30 14 4 3 5 78 77 171 14 30 13 4 3 5 1 230 254 237 23 58 23 48 90 39 202 254 26 1 19 22 59 23 48 90 39 202 0 0 3 0 46 255 244 1 240 1 242 0 19 0 26 0 33 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 20 0 1 244 186 0 31 0 10 0 0 17 18 57 184 0 31 47 185 0 24 0 1 244 184 0 0 16 185 0 27 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 3 34 6 7 33 46 1 3 50 54 55 33 30 1 1 15 45 82 62 36 36 62 82 45 45 82 62 36 36 62 82 45 58 78 9 1 35 9 78 59 63 79 5 254 219 5 79 12 32 64 95 63 63 96 65 32 32 65 96 63 63 95 64 32 1 190 80 72 72 80 254 131 89 81 81 89 0 0 2 0 46 255 244 2 167 1 242 0 26 0 43 0 93 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 34 0 1 244 184 0 15 208 184 0 15 47 186 0 20 0 10 0 0 17 18 57 184 0 20 47 185 0 18 0 1 244 184 0 0 16 185 0 27 0 1 244 184 0 22 208 184 0 22 47 48 49 5 34 46 2 53 52 62 2 51 50 22 23 33 21 35 21 51 21 35 21 51 21 33 14 1 39 50 54 55 17 46 1 35 34 14 2 21 20 30 2 1 31 50 87 66 38 38 66 87 50 25 47 30 1 24 229 192 192 239 254 222 29 48 20 15 35 16 16 35 15 33 59 43 25 25 43 59 12 33 64 95 63 63 95 64 33 4 8 63 141 59 160 63 8 4 67 7 5 1 95 5 7 23 47 70 47 48 71 46 23 0 0 3 0 46 255 51 2 122 2 200 0 10 0 19 0 45 0 119 0 184 0 0 69 88 184 0 31 47 27 185 0 31 0 9 62 89 184 0 0 69 88 184 0 32 47 27 185 0 32 0 19 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 5 62 89 184 0 0 69 88 184 0 20 47 27 185 0 20 0 7 62 89 184 0 21 16 185 0 5 0 1 244 184 0 31 16 185 0 6 0 1 244 184 0 14 208 184 0 5 16 184 0 15 208 184 0 31 16 184 0 34 208 184 0 21 16 184 0 44 208 48 49 55 20 30 2 23 17 14 3 5 52 38 39 17 62 3 3 53 46 3 53 52 62 2 55 53 51 21 30 3 21 20 14 2 7 21 131 27 46 63 35 35 63 46 27 1 162 95 76 36 62 46 27 247 50 92 71 43 43 71 92 50 76 51 92 71 42 43 71 93 49 244 44 69 48 28 1 1 122 2 26 48 69 43 87 98 3 254 134 1 28 48 69 254 107 196 1 35 65 92 60 59 92 64 34 2 217 217 2 34 64 92 59 60 92 65 35 1 196 0 0 1 255 253 255 244 1 9 1 230 0 17 0 75 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 6 0 2 244 186 0 14 0 10 0 0 17 18 57 184 0 14 16 185 0 9 0 2 244 184 0 0 16 184 0 12 208 184 0 12 47 48 49 23 34 39 55 30 1 51 50 54 55 17 51 17 35 39 35 14 1 49 29 23 16 13 20 14 31 67 25 82 68 7 2 26 71 12 10 72 4 4 50 62 1 56 254 26 89 47 54 0 0 0 0 1 255 253 255 244 1 9 2 200 0 17 0 75 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 6 0 2 244 186 0 14 0 0 0 10 17 18 57 184 0 14 16 185 0 9 0 2 244 184 0 0 16 184 0 12 208 184 0 12 47 48 49 23 34 39 55 30 1 51 50 54 55 17 51 17 35 39 35 14 1 49 29 23 16 13 20 14 31 67 25 82 68 7 2 26 71 12 10 72 4 4 50 62 2 26 253 56 89 47 54 0 0 0 0 1 255 253 255 73 1 112 1 230 0 29 0 77 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 9 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 187 0 23 0 1 0 0 0 4 43 186 0 4 0 8 0 18 17 18 57 184 0 8 16 185 0 14 0 2 244 184 0 4 16 185 0 17 0 2 244 48 49 5 34 38 61 1 35 14 1 35 34 39 55 30 1 51 50 54 55 17 51 17 20 22 51 50 54 55 23 14 1 1 50 63 53 2 26 71 42 29 23 16 13 20 14 31 67 25 82 21 29 11 17 8 17 11 32 183 76 69 127 47 54 10 72 4 4 50 62 1 56 253 254 42 46 6 3 63 5 8 0 0 0 1 0 82 255 73 1 94 1 242 0 29 0 72 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 187 0 23 0 1 0 0 0 4 43 184 0 10 16 184 0 4 208 184 0 4 47 186 0 6 0 10 0 0 17 18 57 184 0 10 16 185 0 16 0 2 244 184 0 6 16 185 0 19 0 2 244 48 49 23 34 38 53 17 51 23 51 62 1 51 50 23 7 46 1 35 34 6 7 17 20 22 51 50 54 55 23 14 1 205 68 55 68 7 3 25 71 42 29 23 16 12 20 15 31 67 25 21 29 11 17 8 17 11 31 183 83 72 2 2 88 46 54 10 72 4 4 50 62 254 172 42 46 6 3 63 5 8 0 0 0 0 1 0 82 0 0 1 80 1 242 0 16 0 47 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 4 16 185 0 10 0 1 244 48 49 51 17 52 54 51 50 23 7 46 1 35 34 14 2 21 17 82 89 80 52 33 15 17 25 20 18 35 26 16 1 58 86 98 14 69 7 4 16 32 49 32 254 215 0 2 0 82 0 0 1 207 1 230 0 15 0 24 0 75 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 17 0 1 0 13 0 4 43 186 0 10 0 13 0 17 17 18 57 184 0 0 16 184 0 12 208 184 0 1 16 185 0 23 0 1 244 48 49 51 17 51 50 30 2 21 20 6 7 23 35 39 35 21 53 51 50 54 53 52 38 43 1 82 172 39 68 49 28 61 45 131 91 117 91 76 55 61 61 55 76 1 230 15 34 55 40 58 68 14 202 192 192 252 45 43 43 39 0 0 0 2 0 32 0 0 1 157 1 230 0 15 0 24 0 75 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 9 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 5 62 89 187 0 12 0 1 0 18 0 4 43 186 0 8 0 18 0 12 17 18 57 184 0 9 16 184 0 13 208 184 0 15 16 185 0 16 0 1 244 48 49 51 34 46 2 53 52 54 55 39 51 23 51 53 51 17 39 51 53 35 34 6 21 20 22 241 39 68 49 28 61 45 131 92 116 91 82 158 76 76 54 61 61 15 35 55 40 59 68 14 200 189 189 254 26 64 173 47 43 43 40 0 0 1 0 28 255 73 1 131 1 242 0 63 0 87 0 184 0 0 69 88 184 0 39 47 27 185 0 39 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 6 0 1 0 13 0 4 43 184 0 0 16 185 0 21 0 1 244 186 0 29 0 0 0 39 17 18 57 184 0 39 16 185 0 46 0 1 244 186 0 54 0 39 0 0 17 18 57 48 49 23 34 39 21 20 22 51 50 54 55 23 14 1 35 34 38 61 1 55 30 1 51 50 54 53 52 46 2 39 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 30 2 23 30 3 21 20 14 2 209 56 51 24 37 13 23 10 16 13 35 23 68 58 41 32 67 44 48 48 20 31 40 20 26 52 41 26 23 43 62 39 46 77 28 39 25 54 32 46 43 18 30 39 21 26 53 42 27 23 45 67 12 20 28 45 52 5 3 61 5 8 88 74 69 54 23 27 44 32 19 28 21 16 8 9 23 33 44 31 29 51 37 21 32 23 52 19 24 42 28 17 25 19 15 8 10 22 33 48 34 30 52 40 23 0 0 0 1 255 216 255 39 1 31 2 214 0 27 0 53 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 185 0 7 0 1 244 184 0 14 16 185 0 21 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 53 17 52 54 51 50 22 23 7 46 1 35 34 6 21 17 20 6 32 23 36 13 17 9 24 13 36 24 65 78 20 30 11 16 8 17 11 42 28 60 217 8 5 62 3 5 50 45 2 107 75 87 8 5 63 3 6 51 45 253 150 74 88 0 1 255 227 255 39 1 42 2 214 0 35 0 85 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 186 0 30 0 31 0 3 43 184 0 0 16 185 0 7 0 1 244 184 0 31 16 184 0 11 208 184 0 30 16 184 0 13 208 184 0 13 47 184 0 18 16 185 0 25 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 53 17 35 53 55 17 52 54 51 50 22 23 7 46 1 35 34 6 21 17 51 21 35 17 20 6 43 23 36 13 17 9 24 13 36 24 86 86 65 78 20 30 11 16 8 17 11 42 28 83 83 60 217 8 5 62 3 5 50 45 1 30 43 5 1 29 75 87 8 5 63 3 6 51 45 254 228 48 254 226 74 88 0 0 1 0 24 255 72 1 69 2 110 0 25 0 56 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 9 62 89 187 0 19 0 1 0 0 0 4 43 184 0 9 16 185 0 6 0 1 244 184 0 9 16 184 0 13 208 184 0 6 16 184 0 14 208 48 49 23 34 46 2 53 17 35 53 63 1 51 21 51 21 35 17 20 22 51 50 54 55 23 14 1 235 39 53 33 14 72 76 10 69 131 131 33 42 13 30 12 16 20 47 184 23 43 60 36 1 185 62 5 136 136 67 254 70 45 49 8 5 62 7 11 0 0 2 0 8 255 244 2 51 1 230 0 23 0 32 0 123 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 9 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 186 0 23 0 2 0 3 43 184 0 2 16 184 0 6 208 184 0 3 16 184 0 7 208 184 0 6 16 184 0 10 208 184 0 23 16 184 0 28 208 184 0 11 208 184 0 19 16 184 0 13 208 184 0 13 47 186 0 15 0 3 0 19 17 18 57 184 0 19 16 185 0 24 0 1 244 184 0 15 16 185 0 27 0 1 244 48 49 19 53 55 53 51 21 51 53 51 21 51 21 35 17 35 39 35 14 1 35 34 38 61 1 23 50 54 55 53 35 21 20 22 8 86 83 222 82 82 82 68 7 3 34 75 51 78 71 174 38 58 35 222 43 1 6 43 5 176 176 176 176 48 254 250 76 40 48 96 94 84 203 39 43 121 73 69 61 0 0 0 0 1 0 37 255 244 1 248 1 230 0 45 0 89 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 13 16 185 0 12 0 1 244 184 0 15 208 184 0 15 47 184 0 0 16 185 0 23 0 1 244 184 0 12 16 184 0 34 208 184 0 31 208 184 0 31 47 184 0 13 16 184 0 33 208 48 49 5 34 46 2 53 52 62 2 55 53 35 53 51 21 14 1 21 20 30 2 51 50 62 2 53 52 38 39 53 51 21 35 21 30 3 21 20 14 2 1 15 53 83 57 29 15 24 31 16 98 186 41 50 18 34 52 35 34 52 34 18 50 40 185 98 16 31 25 15 30 57 82 12 37 62 80 42 37 63 52 41 15 2 67 53 34 100 72 35 62 46 28 28 46 62 35 72 100 34 53 67 2 15 41 52 63 37 42 80 62 37 0 0 0 1 0 75 255 244 1 224 1 242 0 33 0 69 0 184 0 0 69 88 184 0 26 47 27 185 0 26 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 26 16 184 0 6 208 184 0 6 47 184 0 0 16 185 0 13 0 1 244 184 0 26 16 185 0 21 0 1 244 48 49 5 34 46 2 53 17 51 17 20 30 2 51 50 62 2 53 52 38 35 34 7 39 54 51 50 22 21 20 14 2 1 6 41 68 50 28 83 17 28 39 23 31 49 33 17 38 41 13 15 13 23 35 68 79 28 55 81 12 25 53 80 56 1 28 254 235 41 58 37 17 33 59 79 47 78 80 6 64 8 103 109 64 109 80 45 0 1 0 12 0 0 1 199 1 230 0 13 0 51 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 4 208 186 0 9 0 1 0 4 17 18 57 48 49 51 19 51 19 35 3 46 1 39 35 14 1 7 3 12 172 96 175 85 92 11 23 11 4 11 23 11 91 1 230 254 26 1 20 36 73 35 35 73 36 254 236 0 0 1 0 24 0 0 2 182 1 230 0 32 0 87 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 23 208 186 0 6 0 1 0 23 17 18 57 184 0 1 16 184 0 11 208 184 0 23 16 184 0 14 208 186 0 19 0 1 0 14 17 18 57 186 0 28 0 1 0 0 17 18 57 48 49 51 19 51 19 30 1 23 51 62 1 55 19 51 19 35 3 46 1 39 35 6 7 3 35 3 46 1 39 35 14 1 7 3 24 130 101 70 8 16 9 4 8 15 10 68 96 135 84 72 8 13 8 4 15 18 75 80 76 9 16 9 4 8 14 8 71 1 230 254 251 35 68 37 37 69 35 1 4 254 26 1 25 35 66 34 68 67 254 231 1 25 35 66 34 34 66 35 254 231 0 1 0 12 0 0 1 199 2 212 0 28 0 75 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 6 16 185 0 13 0 1 244 186 0 17 0 0 0 6 17 18 57 184 0 0 16 184 0 19 208 186 0 24 0 6 0 0 17 18 57 48 49 51 19 62 3 51 50 22 23 7 46 1 35 34 6 15 1 19 35 3 46 1 39 35 14 1 7 3 12 194 13 32 44 56 37 17 28 12 16 8 20 9 42 53 15 22 195 84 100 11 24 12 4 11 20 10 86 2 43 36 62 45 26 5 5 65 2 5 59 45 65 254 25 1 13 32 71 34 33 72 32 254 243 0 0 1 255 255 0 0 1 160 1 230 0 15 0 55 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 7 0 2 0 0 17 18 57 184 0 2 16 184 0 12 208 48 49 51 53 3 51 23 30 1 23 51 62 1 63 1 51 3 21 167 168 88 66 13 27 14 4 14 25 13 66 87 167 164 1 66 138 29 54 29 29 54 29 138 254 190 164 0 0 0 0 1 0 31 255 73 1 236 1 230 0 23 0 75 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 9 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 5 62 89 187 0 17 0 1 0 0 0 4 43 184 0 4 16 185 0 12 0 1 244 184 0 6 208 184 0 9 16 185 0 7 0 1 244 184 0 11 208 48 49 5 34 38 61 1 33 53 1 35 53 33 21 1 51 21 20 22 51 50 54 55 23 14 1 1 175 67 57 254 236 1 0 228 1 76 255 0 254 22 29 10 18 8 16 11 31 183 81 66 36 44 1 119 67 44 254 137 95 42 46 6 3 63 5 8 0 0 0 2 0 31 255 175 1 207 1 230 0 28 0 38 0 89 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 9 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 5 62 89 185 0 11 0 1 244 184 0 5 208 184 0 5 47 184 0 8 16 185 0 6 0 1 244 184 0 11 16 184 0 38 208 184 0 38 47 184 0 35 220 184 0 17 220 184 0 4 16 184 0 26 208 48 49 23 39 54 55 35 53 1 35 53 33 21 3 30 1 23 62 1 51 50 22 21 20 14 2 43 1 14 1 55 50 54 53 52 38 35 34 6 7 238 48 8 10 177 1 0 228 1 71 255 25 48 25 28 71 44 43 48 19 38 58 40 51 5 9 86 40 42 19 22 23 47 21 81 10 39 32 44 1 119 67 44 254 137 1 1 1 71 77 47 45 25 43 33 19 18 40 121 36 23 17 23 48 51 0 1 0 3 255 39 1 150 1 230 0 36 0 73 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 185 0 9 0 1 244 186 0 17 0 24 0 0 17 18 57 184 0 24 16 185 0 22 0 1 244 184 0 17 16 185 0 27 0 1 244 48 49 23 34 46 2 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 39 19 35 53 33 21 7 54 30 2 21 20 14 2 200 36 59 48 38 16 41 26 70 53 27 47 35 21 69 65 21 25 17 33 192 241 1 85 188 48 78 54 29 34 57 75 217 13 22 28 15 52 24 38 21 39 55 34 62 70 8 8 45 1 2 67 44 253 5 24 50 74 44 53 81 56 29 0 0 1 255 254 0 0 1 141 2 212 0 27 0 47 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 16 16 185 0 7 0 1 244 48 49 51 17 62 1 53 52 38 35 34 6 7 39 62 3 51 50 30 2 21 20 14 2 7 17 146 87 81 66 60 51 70 25 44 15 39 48 59 35 42 74 55 32 25 45 62 37 1 68 50 93 63 58 68 44 29 54 16 32 24 15 24 48 72 48 43 68 59 50 25 254 225 0 1 0 31 0 0 1 174 2 212 0 27 0 47 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 11 16 185 0 20 0 1 244 48 49 51 17 46 3 53 52 62 2 51 50 30 2 23 7 46 1 35 34 6 21 20 22 23 17 200 37 62 45 25 33 58 78 44 33 56 46 36 15 44 23 66 47 65 71 81 87 1 31 25 50 59 68 43 48 72 48 24 15 24 32 16 54 28 45 68 58 63 93 50 254 188 0 1 0 7 0 0 1 166 2 212 0 32 0 73 0 184 0 0 69 88 184 0 20 47 27 185 0 20 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 5 0 1 0 1 0 4 43 184 0 20 16 185 0 11 0 1 244 184 0 5 16 184 0 29 208 184 0 1 16 184 0 30 208 48 49 51 17 35 53 55 51 62 1 53 52 38 35 34 6 7 39 62 3 51 50 30 2 21 20 6 7 51 21 35 17 158 151 76 89 81 75 65 60 51 70 25 44 15 39 48 58 36 42 74 55 32 76 58 144 182 1 1 62 5 51 99 56 58 68 44 29 54 16 32 24 15 24 48 72 48 64 102 42 67 254 255 0 1 0 19 0 0 1 178 2 212 0 32 0 73 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 3 0 1 0 2 0 4 43 184 0 12 16 185 0 21 0 1 244 184 0 3 16 184 0 28 208 184 0 2 16 184 0 30 208 48 49 51 17 35 53 51 46 1 53 52 62 2 51 50 30 2 23 7 46 1 35 34 6 21 20 22 23 51 23 21 35 17 200 181 144 58 76 33 58 77 45 33 56 45 37 15 44 23 66 47 65 71 76 81 89 76 152 1 1 67 42 102 64 48 72 48 24 15 24 32 16 54 28 45 68 58 56 99 51 5 62 254 255 0 0 0 0 1 0 6 255 6 1 25 2 238 0 21 0 55 0 187 0 3 0 1 0 21 0 4 43 187 0 20 0 1 0 16 0 4 43 184 0 3 16 184 0 7 208 184 0 21 16 184 0 8 208 184 0 20 16 184 0 11 208 184 0 16 16 184 0 12 208 48 49 19 53 55 51 17 51 17 51 21 35 21 51 21 35 17 35 17 35 53 55 51 53 6 77 37 58 103 103 103 103 58 114 77 37 1 75 43 4 1 116 254 140 47 123 47 254 101 1 155 42 5 123 0 0 0 0 3 0 59 255 244 1 210 2 212 0 15 0 35 0 47 0 67 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 42 0 2 0 36 0 4 43 184 0 0 16 185 0 16 0 1 244 184 0 8 16 185 0 26 0 1 244 48 49 5 34 46 2 53 52 54 51 50 22 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 19 34 38 53 52 54 51 50 22 21 20 6 1 7 47 75 53 29 110 94 93 110 29 52 76 46 26 46 34 19 19 34 46 26 27 46 34 19 19 34 46 27 20 28 28 20 19 28 28 12 44 91 140 96 180 185 187 178 96 140 91 44 68 32 72 115 84 76 112 74 35 35 74 112 76 84 115 72 32 1 0 27 20 21 26 26 21 20 27 0 1 0 30 0 0 2 92 2 212 0 40 0 130 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 9 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 19 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 5 62 89 184 0 0 208 184 0 8 16 185 0 5 0 1 244 184 0 1 208 184 0 12 16 185 0 18 0 1 244 184 0 8 16 184 0 23 208 184 0 12 16 184 0 27 208 184 0 27 47 184 0 18 16 184 0 33 208 184 0 33 47 184 0 23 16 184 0 37 208 184 0 1 16 184 0 38 208 48 49 33 17 35 17 35 17 35 53 55 53 52 54 51 50 22 23 7 38 35 34 6 29 1 51 53 52 54 51 50 22 23 7 38 35 34 29 1 51 21 35 17 1 125 203 82 66 66 75 76 24 47 18 17 30 35 36 40 203 69 73 23 41 17 18 27 28 68 103 103 1 163 254 93 1 163 62 5 64 76 88 10 8 62 13 51 48 62 77 75 86 9 7 63 12 94 77 67 254 93 0 255 255 0 30 0 0 2 246 2 212 0 38 2 2 0 0 0 7 0 36 2 65 0 0 255 255 0 30 255 244 3 25 2 212 0 38 2 2 0 0 0 7 0 39 2 65 0 0 0 1 0 30 255 244 2 69 2 212 0 43 0 122 0 124 184 0 20 47 24 184 0 0 69 88 184 0 4 47 27 185 0 4 0 9 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 4 16 185 0 1 0 1 244 184 0 8 16 185 0 14 0 1 244 184 0 4 16 184 0 18 208 184 0 22 208 184 0 1 16 184 0 41 208 184 0 23 208 184 0 0 16 184 0 35 208 184 0 35 47 185 0 28 0 1 244 48 49 51 17 35 53 55 53 52 54 51 50 22 23 7 38 35 34 29 1 51 55 51 21 51 21 35 17 20 22 51 50 54 55 23 14 1 35 34 46 2 53 17 35 17 96 66 66 69 73 23 41 17 18 27 28 68 178 10 68 132 132 34 42 13 30 12 16 20 47 23 39 53 33 14 174 1 163 62 5 77 75 86 9 7 63 12 94 77 136 136 67 254 242 45 49 8 5 62 7 11 24 42 60 36 1 13 254 93 0 0 1 0 30 255 244 3 98 2 212 0 62 0 211 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 19 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 19 62 89 184 0 0 69 88 184 0 26 47 27 185 0 26 0 19 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 9 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 9 62 89 184 0 0 69 88 184 0 32 47 27 185 0 32 0 9 62 89 184 0 0 69 88 184 0 36 47 27 185 0 36 0 9 62 89 184 0 0 69 88 184 0 50 47 27 185 0 50 0 5 62 89 184 0 36 16 185 0 56 0 1 244 184 0 57 208 184 0 60 208 184 0 61 208 184 0 1 208 184 0 2 208 184 0 8 16 185 0 14 0 1 244 184 0 23 16 185 0 29 0 1 244 184 0 2 16 184 0 38 208 184 0 39 208 184 0 50 16 185 0 43 0 1 244 48 49 51 17 35 53 55 53 52 54 51 50 22 23 7 38 35 34 6 29 1 51 53 52 54 51 50 22 23 7 38 35 34 29 1 51 55 51 21 51 21 35 17 20 22 51 50 54 55 23 14 1 35 34 46 2 53 17 35 17 35 17 35 17 96 66 66 75 76 24 47 18 17 30 35 36 40 203 69 73 23 41 17 18 27 28 68 178 10 68 132 132 34 42 13 30 12 16 20 47 23 39 53 33 14 174 82 203 1 163 62 5 64 76 88 10 8 62 13 51 48 62 77 75 86 9 7 63 12 94 77 136 136 67 254 242 45 49 8 5 62 7 11 24 42 60 36 1 13 254 93 1 163 254 93 0 0 0 1 0 46 0 0 1 40 2 144 0 11 0 61 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 10 0 1 244 184 0 1 208 184 0 5 16 185 0 7 0 1 244 184 0 4 208 48 49 51 53 51 17 35 53 51 21 35 17 51 21 46 84 84 250 83 83 71 2 3 70 70 253 253 71 0 0 0 255 255 0 37 0 0 1 40 3 99 2 38 2 7 0 0 0 7 7 32 0 172 0 0 255 255 0 46 0 0 1 51 3 99 2 38 2 7 0 0 0 7 7 35 0 172 0 0 255 255 0 24 0 0 1 64 3 70 2 38 2 7 0 0 0 7 7 38 0 172 0 0 255 255 255 251 0 0 1 93 3 73 2 38 2 7 0 0 0 7 7 40 0 172 0 0 255 255 0 20 0 0 1 68 3 45 2 38 2 7 0 0 0 7 7 52 0 172 0 0 255 255 0 38 0 0 1 50 3 24 2 38 2 7 0 0 0 7 7 42 0 172 0 0 255 255 0 46 0 0 1 40 3 53 2 38 2 7 0 0 0 7 7 50 0 172 0 0 255 255 0 24 0 0 1 64 3 77 2 38 2 7 0 0 0 7 7 60 0 172 0 0 255 255 0 46 0 0 1 40 3 104 2 38 2 7 0 0 0 7 7 54 0 172 0 0 255 255 0 46 255 51 1 40 2 144 2 38 2 7 0 0 0 7 7 49 0 173 252 233 0 1 0 46 255 44 1 40 2 144 0 31 0 85 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 17 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 186 0 25 0 0 0 3 43 184 0 7 16 185 0 8 0 1 244 184 0 12 16 185 0 11 0 1 244 184 0 14 208 184 0 8 16 184 0 17 208 184 0 7 16 184 0 18 208 48 49 23 34 38 53 52 54 55 35 53 51 17 35 53 51 21 35 17 51 21 35 14 1 21 20 22 51 50 54 55 23 14 1 177 39 56 44 24 104 84 84 250 83 83 87 29 34 30 18 12 19 9 23 14 46 212 44 43 41 64 20 71 2 3 70 70 253 253 71 23 55 29 23 23 7 7 45 11 17 0 0 0 255 255 0 26 0 0 1 62 3 74 2 38 2 7 0 0 0 7 7 47 0 172 0 0 0 1 0 90 255 91 2 45 2 144 0 32 0 83 0 184 0 0 69 88 184 0 20 47 27 185 0 20 0 17 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 187 0 7 0 1 0 0 0 4 43 184 0 19 16 184 0 11 208 186 0 13 0 20 0 19 17 18 57 184 0 20 16 184 0 28 208 186 0 23 0 28 0 10 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 35 3 39 35 30 1 21 17 35 17 51 19 23 51 46 1 53 17 51 17 20 6 1 169 22 36 13 16 10 23 13 37 23 5 238 71 4 4 7 79 86 237 71 4 3 7 79 61 165 7 5 66 3 6 52 44 1 157 135 50 103 52 254 169 2 144 254 100 136 50 107 52 1 83 253 109 75 87 0 0 255 255 0 47 255 244 1 217 1 242 2 6 1 198 0 0 255 255 0 47 255 244 1 217 3 13 2 38 1 198 0 0 0 7 7 31 1 26 0 0 255 255 0 47 255 244 1 217 3 13 2 38 1 198 0 0 0 7 7 34 1 26 0 0 255 255 0 47 255 244 1 217 2 228 2 38 1 198 0 0 0 7 7 37 1 26 0 0 255 255 0 47 255 244 1 217 2 209 2 38 1 198 0 0 0 7 7 39 1 26 0 0 255 255 0 47 255 244 1 217 2 175 2 38 1 198 0 0 0 7 7 51 1 26 0 0 255 255 0 47 255 244 1 217 2 146 2 38 1 198 0 0 0 7 7 41 1 26 0 0 255 255 0 47 255 244 1 217 2 218 2 38 1 198 0 0 0 7 7 45 1 26 0 0 255 255 0 47 255 244 1 217 2 239 2 38 1 198 0 0 0 7 7 55 1 26 0 0 255 255 0 47 255 244 1 217 2 234 2 38 1 198 0 0 0 7 7 59 1 26 0 0 255 255 0 47 255 51 1 217 1 242 2 38 1 198 0 0 0 7 7 49 1 28 252 233 255 255 0 47 255 244 1 217 2 248 2 38 1 198 0 0 0 7 7 53 1 26 0 0 255 255 0 47 255 244 2 5 3 17 2 38 1 198 0 0 0 7 7 116 1 26 0 0 255 255 0 35 255 244 1 217 3 17 2 38 1 198 0 0 0 7 7 118 1 26 0 0 255 255 0 47 255 244 1 235 3 23 2 38 1 198 0 0 0 7 7 120 1 26 0 0 255 255 0 47 255 244 1 217 3 35 2 38 1 198 0 0 0 7 7 122 1 26 0 0 255 255 0 47 255 51 1 217 2 228 2 38 1 198 0 0 0 39 7 37 1 26 0 0 0 7 7 49 1 28 252 233 255 255 0 47 255 244 1 217 3 64 2 38 1 198 0 0 0 7 7 124 1 26 0 0 255 255 0 47 255 244 1 217 3 64 2 38 1 198 0 0 0 7 7 126 1 26 0 0 255 255 0 47 255 244 1 217 3 80 2 38 1 198 0 0 0 7 7 128 1 26 0 0 255 255 0 47 255 244 1 217 3 34 2 38 1 198 0 0 0 7 7 130 1 26 0 0 255 255 0 47 255 51 1 217 2 218 2 38 1 198 0 0 0 39 7 45 1 26 0 0 0 7 7 49 1 28 252 233 0 2 0 47 255 50 1 238 1 242 0 38 0 53 0 137 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 186 0 32 0 0 0 3 43 184 0 11 16 184 0 6 208 186 0 7 0 11 0 19 17 18 57 186 0 22 0 19 0 11 17 18 57 184 0 19 16 184 0 25 208 184 0 25 47 184 0 6 16 184 0 26 208 184 0 26 47 184 0 11 16 185 0 39 0 1 244 184 0 7 16 185 0 42 0 1 244 184 0 22 16 185 0 43 0 1 244 184 0 19 16 185 0 46 0 1 244 48 49 5 34 38 53 52 54 55 39 35 14 1 35 34 38 53 52 62 2 51 50 22 23 51 55 51 17 14 1 21 20 22 51 50 54 55 23 14 1 3 50 54 55 53 46 1 35 34 14 2 21 20 22 1 160 38 53 48 32 7 3 29 75 43 92 109 35 59 76 42 41 64 33 2 7 67 45 42 28 18 12 20 9 21 14 45 169 34 60 30 31 57 30 29 51 38 22 70 206 43 42 41 61 23 53 28 41 132 122 59 95 66 36 30 29 47 254 26 22 54 29 23 23 7 6 41 11 16 1 7 33 34 254 28 23 27 49 68 42 88 98 0 0 0 255 255 0 50 255 40 1 219 1 242 2 6 1 207 0 0 255 255 0 50 255 40 1 219 3 13 2 38 1 207 0 0 0 7 7 34 1 30 0 0 255 255 0 50 255 40 1 219 2 228 2 38 1 207 0 0 0 7 7 37 1 31 0 0 255 255 0 50 255 40 1 219 2 218 2 38 1 207 0 0 0 7 7 45 1 31 0 0 255 255 0 50 255 40 1 219 2 182 2 38 1 207 0 0 0 7 7 49 1 31 0 0 255 255 0 50 255 40 1 219 2 232 2 38 1 207 0 0 0 7 7 83 1 31 0 0 255 255 0 50 255 40 1 219 2 234 2 38 1 207 0 0 0 7 7 59 1 31 0 0 255 255 0 50 255 40 1 219 2 146 2 38 1 207 0 0 0 7 7 41 1 31 0 0 255 255 0 50 255 40 1 219 2 209 2 38 1 207 0 0 0 7 7 39 1 31 0 0 0 1 0 82 0 0 0 164 2 200 0 3 0 37 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 19 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 48 49 51 17 51 17 82 82 2 200 253 56 0 0 0 255 255 0 66 0 0 0 255 3 151 2 38 2 53 0 0 0 6 7 35 120 52 0 0 255 255 0 82 0 0 1 20 2 248 0 38 2 53 0 0 0 7 7 61 0 246 0 0 255 255 0 82 0 0 1 108 2 200 0 38 2 53 0 0 0 7 4 117 0 180 1 19 255 255 0 28 255 30 0 201 2 200 2 38 2 53 0 0 0 6 7 82 123 0 0 0 255 255 0 69 255 51 0 177 2 200 2 38 2 53 0 0 0 7 7 49 0 123 252 233 255 255 255 246 255 51 1 0 3 111 2 38 2 53 0 0 0 39 7 41 0 123 0 221 0 7 7 49 0 123 252 233 255 255 255 246 255 87 1 0 2 200 2 38 2 53 0 0 0 7 7 41 0 123 252 254 0 1 255 255 0 0 0 252 2 200 0 11 0 63 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 19 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 187 0 2 0 1 0 11 0 4 43 184 0 2 16 184 0 5 208 184 0 11 16 184 0 8 208 48 49 19 39 55 17 51 17 55 23 7 17 35 17 29 30 87 82 54 30 84 82 1 39 53 53 1 55 254 244 35 53 52 254 138 1 75 255 255 0 30 0 0 1 218 2 212 0 38 0 33 0 0 0 7 2 53 1 54 0 0 255 255 0 3 0 0 2 29 2 144 2 6 0 2 0 0 255 255 0 90 0 0 2 36 2 144 2 6 0 3 0 0 0 1 0 90 0 0 1 212 2 144 0 5 0 47 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 1 16 185 0 3 0 2 244 48 49 51 17 33 21 33 17 90 1 122 254 217 2 144 70 253 182 0 0 0 0 2 0 30 0 0 2 46 2 144 0 5 0 11 0 53 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 17 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 185 0 7 0 2 244 186 0 10 0 2 0 5 17 18 57 48 49 51 53 19 51 19 21 37 33 3 39 35 7 30 216 96 216 254 74 1 90 102 69 4 69 50 2 94 253 162 50 71 1 44 210 210 255 255 0 90 0 0 1 222 2 144 2 6 0 6 0 0 255 255 0 45 0 0 1 241 2 144 2 6 0 27 0 0 255 255 0 90 0 0 2 50 2 144 2 6 0 9 0 0 0 3 0 52 255 244 2 101 2 156 0 3 0 23 0 43 0 67 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 17 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 5 62 89 187 0 2 0 1 0 3 0 4 43 184 0 4 16 185 0 24 0 2 244 184 0 14 16 185 0 34 0 2 244 48 49 19 53 51 21 3 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 220 224 112 62 103 74 41 41 74 103 62 62 103 75 41 41 75 103 62 44 71 51 28 28 51 71 44 44 71 51 28 28 51 71 1 53 72 72 254 191 48 89 127 79 79 125 87 46 47 87 125 78 79 127 89 48 73 38 71 99 62 61 98 68 37 37 68 98 61 62 99 71 38 0 0 255 255 0 90 0 0 0 173 2 144 2 6 0 10 0 0 255 255 0 90 0 0 2 63 2 144 2 6 0 12 0 0 0 1 0 0 0 0 2 3 2 144 0 13 0 51 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 4 208 186 0 9 0 1 0 4 17 18 57 48 49 49 19 51 19 35 3 46 1 39 35 14 1 7 3 209 96 210 88 106 17 28 19 4 18 28 17 105 2 144 253 112 1 99 58 101 58 58 101 58 254 157 0 0 255 255 0 90 0 0 2 125 2 144 2 6 0 14 0 0 255 255 0 90 0 0 2 45 2 144 2 6 0 15 0 0 0 3 0 49 0 0 1 228 2 144 0 3 0 7 0 11 0 67 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 17 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 187 0 6 0 1 0 7 0 4 43 184 0 3 16 185 0 1 0 2 244 184 0 9 16 185 0 11 0 2 244 48 49 51 53 33 21 1 53 33 21 1 53 33 21 49 1 179 254 152 1 29 254 162 1 159 71 71 1 53 71 71 1 21 70 70 0 0 255 255 0 52 255 244 2 101 2 156 2 6 0 16 0 0 0 1 0 90 0 0 2 43 2 144 0 7 0 64 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 184 0 1 16 185 0 5 0 2 244 48 49 51 17 33 17 35 17 33 17 90 1 209 83 254 213 2 144 253 112 2 74 253 182 255 255 0 90 0 0 2 11 2 144 2 6 0 17 0 0 0 1 0 44 0 0 1 245 2 144 0 11 0 57 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 17 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 184 0 4 16 185 0 6 0 2 244 184 0 11 16 185 0 9 0 2 244 48 49 51 53 19 3 53 33 21 33 23 3 33 21 44 226 222 1 167 254 194 201 204 1 95 50 1 27 1 18 49 70 251 254 248 71 0 0 0 255 255 0 28 0 0 1 252 2 144 2 6 0 21 0 0 255 255 255 255 0 0 1 221 2 144 2 6 0 26 0 0 0 3 0 48 255 234 2 159 2 166 0 8 0 17 0 43 0 65 0 125 184 0 18 47 24 184 0 30 47 187 0 15 0 2 0 29 0 4 43 187 0 14 0 2 0 19 0 4 43 184 0 15 16 184 0 3 208 184 0 14 16 184 0 4 208 184 0 29 16 184 0 32 208 184 0 19 16 184 0 42 208 48 49 1 52 38 39 17 62 3 37 20 30 2 23 17 14 1 19 53 46 3 53 52 62 2 55 53 51 21 30 3 21 20 14 2 7 21 2 78 104 89 44 72 50 27 254 51 27 50 72 44 89 104 193 62 101 72 39 39 72 101 62 75 62 101 72 39 39 72 101 62 1 75 84 101 5 254 127 3 30 51 69 42 42 69 51 30 3 1 129 5 101 254 75 93 3 38 67 93 59 58 92 65 37 3 92 92 3 37 65 92 58 59 93 67 38 3 93 0 255 255 0 15 0 0 1 242 2 144 2 6 0 25 0 0 0 1 0 63 0 0 2 124 2 144 0 25 0 89 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 17 62 89 184 0 0 69 88 184 0 25 47 27 185 0 25 0 5 62 89 186 0 10 0 5 0 25 17 18 57 184 0 10 16 185 0 1 0 2 244 184 0 5 16 184 0 11 208 184 0 10 16 184 0 13 208 184 0 11 16 184 0 17 208 184 0 1 16 184 0 24 208 48 49 33 53 46 1 61 1 51 21 20 22 23 17 51 17 62 1 61 1 51 21 20 14 2 7 21 1 54 116 131 82 83 82 79 82 82 83 34 64 91 58 245 5 119 126 161 157 95 88 4 1 88 254 168 5 87 95 157 161 63 92 61 31 3 245 0 0 1 0 45 0 0 2 121 2 156 0 49 0 87 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 1 0 2 244 184 0 0 16 184 0 27 208 185 0 25 0 2 244 184 0 28 208 184 0 28 47 184 0 13 16 185 0 38 0 2 244 184 0 1 16 184 0 48 208 184 0 48 47 48 49 51 53 51 53 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 21 51 21 35 53 62 3 53 52 46 2 35 34 14 2 21 20 30 2 23 21 45 131 21 42 33 21 40 73 103 64 64 103 74 40 21 33 43 21 131 233 28 49 36 21 27 50 72 46 46 72 50 26 20 36 49 28 68 4 21 55 70 83 50 69 116 85 47 47 85 116 69 50 83 70 55 21 4 68 61 22 56 70 85 52 53 91 67 38 38 67 91 53 52 85 70 56 22 61 0 255 255 0 6 0 0 2 51 2 158 0 38 0 2 22 0 0 6 3 107 25 0 0 0 255 255 255 237 0 0 2 30 2 158 0 38 0 6 64 0 0 6 3 107 0 0 0 0 255 255 255 237 0 0 2 114 2 158 0 38 0 9 64 0 0 6 3 107 0 0 0 0 255 255 255 237 0 0 0 237 2 158 0 38 0 10 64 0 0 6 3 107 0 0 0 0 255 255 255 235 0 0 1 27 3 45 2 38 0 10 0 0 0 7 7 52 0 131 0 0 255 255 255 237 255 244 2 148 2 158 0 38 0 16 47 0 0 6 3 107 0 0 0 0 255 255 255 237 0 0 2 89 2 158 0 38 0 26 124 0 0 6 3 107 0 0 0 0 255 255 255 255 0 0 1 221 3 45 2 38 0 26 0 0 0 7 7 52 0 238 0 0 255 255 255 234 0 0 2 168 2 158 0 38 2 86 47 0 0 6 3 107 253 0 0 0 0 2 0 46 255 244 2 34 1 242 0 36 0 55 0 127 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 14 0 10 0 0 17 18 57 184 0 10 16 184 0 16 208 184 0 16 47 184 0 0 16 184 0 31 208 184 0 31 47 185 0 24 0 1 244 186 0 34 0 0 0 10 17 18 57 184 0 0 16 185 0 37 0 1 244 184 0 34 16 185 0 42 0 2 244 184 0 14 16 185 0 43 0 1 244 184 0 10 16 185 0 48 0 1 244 48 49 23 34 46 2 53 52 62 2 51 50 22 23 51 55 51 14 3 21 20 22 51 50 54 55 23 14 1 35 34 38 53 35 6 39 50 62 2 63 1 46 3 35 34 14 2 21 20 22 233 42 68 50 27 35 59 77 42 45 84 21 2 21 81 10 21 18 12 28 20 8 18 8 12 11 30 22 44 52 3 56 78 24 46 36 24 2 8 10 28 32 35 17 26 50 38 23 62 12 32 63 91 60 63 98 67 36 58 69 115 48 105 102 91 33 25 26 5 3 63 5 8 48 51 99 69 24 41 55 31 91 40 50 29 11 25 48 73 48 85 93 0 0 2 0 79 255 77 2 9 2 212 0 29 0 59 0 113 0 125 184 0 0 47 24 184 0 0 69 88 184 0 6 47 27 185 0 6 0 19 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 5 62 89 186 0 38 0 6 0 23 17 18 57 184 0 38 16 185 0 41 0 1 244 186 0 15 0 38 0 41 17 18 57 186 0 26 0 23 0 41 17 18 57 184 0 23 16 185 0 30 0 1 244 184 0 6 16 185 0 51 0 1 244 184 0 26 16 185 0 57 0 1 244 48 49 23 17 52 62 2 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 35 34 38 39 30 1 23 55 50 62 2 53 52 38 35 34 7 39 62 3 53 52 46 2 35 34 6 7 14 1 21 30 1 79 24 50 75 51 36 66 51 30 50 46 72 83 32 53 68 37 46 90 38 2 2 1 150 26 46 35 20 68 68 26 24 13 39 54 34 15 16 28 37 20 57 63 1 2 1 35 82 179 2 158 50 86 62 35 21 43 65 44 54 83 29 4 10 101 77 49 76 53 27 32 42 62 117 62 236 19 36 53 33 58 78 6 63 8 32 42 48 24 28 42 28 14 90 87 88 171 88 45 31 0 0 0 1 0 6 255 77 1 208 1 242 0 29 0 80 0 125 184 0 0 47 24 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 9 62 89 184 0 0 69 88 184 0 20 47 27 185 0 20 0 9 62 89 186 0 16 0 11 0 0 17 18 57 186 0 26 0 0 0 20 17 18 57 48 49 23 62 2 52 53 52 46 2 39 55 30 3 23 51 62 1 55 51 14 3 7 30 1 21 196 1 2 2 33 55 70 37 83 22 48 44 35 11 4 47 73 8 83 10 29 45 64 45 6 4 179 16 27 27 31 20 60 146 147 134 48 21 32 90 106 116 57 91 197 101 62 110 113 123 73 44 98 42 0 2 0 52 255 244 1 228 2 212 0 43 0 59 0 85 0 184 0 0 69 88 184 0 20 47 27 185 0 20 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 52 0 20 0 0 17 18 57 184 0 52 16 184 0 10 208 184 0 20 16 185 0 26 0 1 244 186 0 34 0 0 0 20 17 18 57 184 0 0 16 185 0 44 0 1 244 48 49 5 34 46 2 53 52 62 2 55 46 3 53 52 62 2 51 50 23 7 46 1 35 34 6 21 20 30 2 23 30 3 21 20 14 2 39 50 54 53 52 46 2 39 14 1 21 20 30 2 1 13 42 78 60 37 29 50 69 39 26 49 37 22 19 39 60 41 89 120 20 63 92 35 42 38 23 40 53 30 31 56 43 25 29 55 80 50 66 67 17 29 39 22 77 87 23 38 50 12 30 57 82 52 44 73 57 41 12 19 39 43 49 29 22 39 30 18 39 66 23 18 30 20 20 35 36 37 22 23 48 57 69 44 52 85 61 33 68 89 73 30 51 42 37 17 17 96 71 36 57 40 22 0 0 0 0 1 0 46 255 244 1 172 1 242 0 48 0 101 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 30 0 1 0 37 0 4 43 186 0 9 0 37 0 30 17 18 57 184 0 17 16 185 0 24 0 1 244 184 0 30 16 184 0 33 208 184 0 33 47 184 0 37 16 184 0 34 208 184 0 34 47 184 0 0 16 185 0 42 0 1 244 48 49 23 34 46 2 53 52 54 55 53 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 21 38 34 35 34 21 20 22 51 50 54 55 23 14 1 251 45 75 55 30 59 42 38 39 30 51 67 38 44 79 34 33 29 59 34 45 61 52 59 14 28 19 22 36 18 120 69 63 35 63 35 35 44 82 12 20 38 54 34 53 57 11 4 14 60 34 33 50 32 16 28 25 55 21 22 38 38 33 42 1 2 64 2 82 41 46 22 27 55 34 26 0 0 0 1 0 48 255 72 1 160 2 200 0 45 0 71 0 125 184 0 0 47 24 184 0 0 69 88 184 0 25 47 27 185 0 25 0 19 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 184 0 25 16 185 0 19 0 1 244 184 0 27 208 184 0 27 47 184 0 9 16 185 0 38 0 1 244 48 49 5 39 62 1 53 52 46 2 39 46 3 53 52 62 2 55 42 1 14 1 7 53 33 21 35 14 3 21 20 30 2 23 30 3 21 20 6 1 104 66 26 22 9 25 43 34 37 66 50 30 49 78 95 46 21 61 66 65 24 1 74 5 47 96 78 50 20 38 54 34 35 52 34 16 26 184 27 32 36 20 11 17 13 13 7 7 30 52 81 60 56 122 115 100 35 2 2 1 67 67 33 100 115 120 51 43 59 38 22 6 7 17 24 35 25 23 69 0 0 0 1 0 75 255 77 1 209 1 242 0 27 0 85 0 125 184 0 0 47 24 184 0 0 69 88 184 0 23 47 27 185 0 23 0 9 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 5 62 89 184 0 23 16 185 0 6 0 1 244 186 0 19 0 23 0 13 17 18 57 184 0 19 16 185 0 11 0 1 244 184 0 23 16 184 0 17 208 184 0 17 47 48 49 5 62 1 53 52 38 35 34 14 2 7 17 35 17 52 38 39 51 23 51 62 1 51 50 22 21 17 1 126 3 3 36 43 20 35 34 35 21 82 2 5 75 7 3 38 81 54 71 61 179 120 250 106 69 61 11 26 41 31 254 194 1 97 29 66 38 101 57 56 96 94 254 25 0 3 0 59 255 244 1 207 2 212 0 15 0 26 0 37 0 67 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 21 0 1 0 33 0 4 43 184 0 8 16 185 0 16 0 1 244 184 0 0 16 185 0 27 0 1 244 48 49 5 34 46 2 53 52 54 51 50 22 21 20 14 2 3 34 14 2 7 51 46 3 3 50 62 2 55 35 30 3 1 5 47 75 52 28 108 94 94 108 28 52 75 47 25 42 32 20 2 242 2 20 32 42 25 25 43 32 19 2 242 1 20 32 43 12 44 91 140 96 180 185 185 180 96 140 91 44 2 156 30 64 101 71 71 101 64 30 253 168 28 65 105 77 77 105 65 28 0 0 1 0 82 255 244 0 234 1 230 0 15 0 43 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 10 0 1 244 48 49 23 34 38 53 17 51 14 1 21 20 51 50 55 23 14 1 175 51 42 83 2 4 34 12 18 11 11 28 12 59 54 1 129 99 204 88 39 6 62 5 7 0 0 0 1 0 73 255 248 1 241 1 242 0 37 0 113 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 9 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 184 0 0 69 88 184 0 37 47 27 185 0 37 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 17 16 184 0 28 208 184 0 28 47 186 0 5 0 0 0 28 17 18 57 186 0 23 0 0 0 28 17 18 57 186 0 32 0 28 0 37 17 18 57 48 49 5 46 3 39 14 1 7 14 1 7 21 35 17 52 38 39 51 30 1 29 1 51 62 3 55 23 14 1 7 30 3 23 1 150 20 42 42 40 18 11 23 11 22 17 1 77 3 6 81 5 4 4 29 68 75 78 39 8 41 83 45 18 48 52 57 27 8 22 57 65 69 33 14 29 16 29 77 48 25 1 97 29 72 32 20 61 32 152 50 92 74 51 10 78 13 61 49 36 79 79 73 30 0 0 0 0 1 0 16 255 248 1 231 2 212 0 20 0 91 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 19 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 5 62 89 184 0 13 16 185 0 6 0 1 244 186 0 20 0 0 0 13 17 18 57 48 49 23 39 19 39 46 1 35 34 6 7 39 62 1 51 50 22 23 19 35 3 35 103 87 211 6 20 53 42 20 29 14 20 17 42 33 72 84 32 184 87 134 4 8 8 1 241 21 67 69 10 6 68 8 10 105 105 253 254 1 147 0 0 0 0 1 0 82 255 77 2 23 1 230 0 40 0 95 0 125 184 0 0 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 32 47 27 185 0 32 0 5 62 89 185 0 6 0 1 244 186 0 28 0 1 0 32 17 18 57 184 0 28 16 185 0 11 0 1 244 184 0 1 16 184 0 12 208 184 0 32 16 184 0 25 208 184 0 25 47 185 0 19 0 1 244 48 49 23 17 51 17 20 22 51 50 62 2 55 17 51 14 1 21 20 22 51 50 55 23 14 1 35 34 38 39 35 14 1 35 34 38 39 20 30 2 23 82 82 41 48 16 32 32 32 17 83 2 4 20 16 12 17 11 11 27 20 42 41 5 2 26 69 40 29 48 17 1 2 2 2 179 2 153 254 215 65 65 7 21 37 30 1 76 99 204 88 20 19 6 62 5 7 45 49 47 45 18 29 36 55 48 48 29 0 0 1 0 6 0 0 1 198 1 242 0 21 0 81 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 9 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 9 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 11 0 15 0 0 17 18 57 48 49 51 46 3 39 55 30 3 23 51 62 1 55 51 14 3 7 193 14 38 48 56 31 83 25 48 41 32 11 4 45 67 9 83 10 31 44 58 37 67 131 122 110 47 21 39 102 111 112 49 94 208 99 63 120 118 121 64 0 1 0 28 255 72 1 168 2 200 0 69 0 127 0 125 184 0 0 47 24 184 0 0 69 88 184 0 32 47 27 185 0 32 0 19 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 187 0 45 0 1 0 52 0 4 43 186 0 20 0 52 0 45 17 18 57 184 0 32 16 185 0 26 0 1 244 184 0 31 208 184 0 31 47 184 0 26 16 184 0 34 208 184 0 34 47 184 0 45 16 184 0 48 208 184 0 48 47 184 0 52 16 184 0 49 208 184 0 49 47 184 0 9 16 185 0 62 0 1 244 48 49 5 39 62 1 53 52 46 2 39 46 3 53 52 62 2 55 53 46 1 53 52 54 55 42 1 14 1 7 53 33 21 35 34 14 2 21 20 30 2 51 50 54 55 21 46 1 35 34 14 2 21 20 30 2 23 30 3 21 20 6 1 111 66 26 22 10 25 43 33 39 68 52 30 24 41 54 30 45 56 38 34 20 32 31 35 23 1 132 114 24 44 34 20 22 36 44 22 20 25 20 20 30 20 31 59 47 28 23 42 57 34 36 51 32 15 27 184 27 32 36 20 11 17 14 13 6 7 27 44 67 48 36 63 50 36 9 4 18 73 53 42 64 17 2 2 1 67 67 16 30 45 29 26 45 33 18 2 4 70 5 1 20 38 56 35 36 48 30 18 6 7 17 24 35 25 23 69 0 0 0 2 0 46 255 244 1 233 1 242 0 19 0 31 0 53 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 20 0 1 244 184 0 10 16 185 0 26 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 1 11 45 81 60 35 35 60 81 45 46 81 60 35 35 60 81 46 65 72 72 65 65 71 71 12 34 65 94 61 61 96 65 34 34 65 96 61 61 94 65 34 68 101 85 85 103 103 85 85 101 0 1 0 22 255 244 2 49 1 230 0 35 0 89 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 5 62 89 184 0 0 208 184 0 0 47 184 0 19 16 185 0 16 0 1 244 184 0 9 208 184 0 13 16 184 0 12 208 184 0 12 47 184 0 9 16 184 0 22 208 184 0 0 16 185 0 30 0 1 244 48 49 5 34 38 53 52 62 2 53 35 20 6 7 39 62 1 53 35 53 55 33 21 35 14 3 21 20 22 51 50 55 23 14 1 1 229 58 48 1 2 2 172 18 11 83 17 18 113 70 1 213 97 2 3 2 1 23 23 12 27 11 13 33 12 62 60 19 71 86 92 40 103 217 103 5 103 216 99 63 5 68 41 95 89 71 18 26 22 6 63 5 6 0 0 0 2 0 78 255 77 1 246 1 242 0 22 0 41 0 79 0 125 184 0 0 47 24 184 0 0 69 88 184 0 6 47 27 185 0 6 0 9 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 186 0 17 0 14 0 6 17 18 57 185 0 23 0 1 244 184 0 6 16 185 0 33 0 1 244 184 0 17 16 185 0 39 0 1 244 48 49 23 17 52 62 2 51 50 22 21 20 14 2 35 34 38 39 30 3 21 55 50 62 2 53 52 46 2 35 34 14 2 29 1 30 1 78 34 58 78 44 103 107 34 56 72 38 39 74 34 1 2 1 2 126 27 47 36 20 15 31 48 34 27 48 36 21 34 64 179 1 171 63 94 62 31 132 116 62 97 68 35 30 39 33 57 56 58 32 236 27 49 72 45 40 66 47 26 23 45 68 46 124 41 25 0 0 2 0 46 255 244 2 22 1 230 0 23 0 41 0 73 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 34 0 1 244 184 0 15 208 184 0 15 47 184 0 12 208 184 0 12 47 184 0 0 16 185 0 24 0 1 244 48 49 5 34 46 2 53 52 62 2 51 33 21 46 1 39 21 30 1 21 20 14 2 39 50 62 2 53 52 46 2 35 34 6 21 20 30 2 1 8 44 79 60 35 37 62 80 43 1 10 42 70 42 45 51 33 57 77 44 28 49 34 20 17 33 49 31 58 77 20 36 49 12 33 63 94 60 64 93 61 30 70 3 4 1 4 26 98 69 57 88 62 32 68 25 46 66 41 36 67 51 30 89 91 42 67 48 25 0 0 1 0 26 255 244 1 178 1 230 0 22 0 61 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 7 16 185 0 4 0 1 244 184 0 9 208 184 0 0 16 185 0 16 0 1 244 48 49 5 34 38 53 17 35 53 55 33 21 35 14 1 21 20 22 51 50 54 55 23 14 1 1 32 56 43 163 70 1 82 164 2 2 21 20 11 24 12 12 14 41 12 62 60 1 53 62 5 67 82 159 74 26 22 5 3 63 5 8 0 0 1 0 60 255 244 1 199 1 242 0 37 0 77 0 184 0 0 69 88 184 0 30 47 27 185 0 30 0 9 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 9 62 89 184 0 0 69 88 184 0 29 47 27 185 0 29 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 23 0 1 244 48 49 23 34 38 53 52 54 53 52 38 39 51 30 1 21 20 14 2 21 20 30 2 51 50 54 53 52 38 39 55 30 1 21 20 14 2 249 88 97 4 3 5 80 5 3 2 2 2 17 30 39 22 53 69 17 23 80 21 22 30 54 76 12 95 97 44 85 44 29 66 38 26 55 32 21 49 53 52 22 33 45 29 13 89 95 56 116 67 19 63 127 65 62 95 65 33 0 0 0 3 0 46 255 77 2 122 2 110 0 10 0 19 0 45 0 93 0 125 184 0 20 47 24 124 184 0 33 47 24 184 0 0 69 88 184 0 31 47 27 185 0 31 0 9 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 5 62 89 185 0 5 0 1 244 184 0 31 16 185 0 6 0 1 244 184 0 14 208 184 0 5 16 184 0 15 208 184 0 31 16 184 0 34 208 184 0 21 16 184 0 44 208 48 49 55 20 30 2 23 17 14 3 5 52 38 39 17 62 3 3 53 46 3 53 52 62 2 55 53 51 21 30 3 21 20 14 2 7 21 131 27 46 63 35 35 63 46 27 1 162 95 76 36 62 46 27 247 50 92 71 43 43 71 92 50 76 51 92 71 42 43 71 93 49 244 44 69 48 28 1 1 122 2 26 48 69 43 87 98 3 254 134 1 28 48 69 254 133 170 1 35 65 92 60 59 92 64 34 2 127 127 2 34 64 92 59 60 92 65 35 1 170 0 0 0 0 1 0 9 255 65 1 232 1 242 0 13 0 130 0 125 184 0 1 47 24 125 184 0 10 47 24 184 0 0 69 88 184 0 3 47 27 185 0 3 0 9 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 9 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 9 62 89 184 0 1 16 184 0 0 208 184 0 0 47 186 0 5 0 4 0 1 17 18 57 186 0 12 0 7 0 10 17 18 57 186 0 2 0 5 0 12 17 18 57 186 0 9 0 12 0 5 17 18 57 184 0 10 16 184 0 11 208 184 0 11 47 48 49 23 39 19 3 55 19 51 55 51 3 19 7 3 35 92 83 193 190 82 147 4 125 87 173 204 80 163 4 191 12 1 86 1 58 21 254 252 248 254 191 254 177 21 1 31 0 0 0 0 1 0 61 255 77 2 121 2 110 0 41 0 101 0 124 184 0 23 47 24 125 184 0 0 47 24 184 0 0 69 88 184 0 34 47 27 185 0 34 0 9 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 33 47 27 185 0 33 0 9 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 185 0 22 0 1 244 184 0 25 208 184 0 1 16 184 0 40 208 48 49 5 53 46 3 61 1 52 38 39 51 30 1 21 20 6 20 6 21 20 22 51 17 51 17 62 1 53 52 46 2 39 55 30 1 21 20 6 7 21 1 48 62 89 57 28 2 5 80 4 2 1 1 78 81 77 81 87 4 9 15 12 80 23 21 132 120 179 167 1 35 61 86 52 130 29 66 38 26 55 32 20 45 42 36 12 74 89 2 55 253 201 3 101 104 27 51 51 55 32 19 61 108 63 131 144 3 167 0 0 0 1 0 51 255 244 2 138 1 242 0 57 0 77 0 184 0 9 47 184 0 0 69 88 184 0 8 47 27 185 0 8 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 17 0 1 244 184 0 34 208 184 0 8 16 184 0 43 208 184 0 0 16 184 0 51 208 186 0 55 0 8 0 0 17 18 57 48 49 23 34 46 2 53 52 54 55 23 14 3 21 20 22 51 50 62 2 53 52 38 39 51 14 1 21 20 30 2 51 50 54 53 52 46 2 39 55 30 3 21 20 6 35 34 38 39 35 14 1 220 36 62 45 26 52 38 75 21 32 22 11 53 41 18 32 24 14 4 4 90 4 4 14 24 32 17 41 52 9 19 29 21 74 20 32 23 13 91 76 42 71 18 4 19 67 12 30 60 91 60 78 134 57 33 30 57 60 66 38 76 82 13 29 46 34 30 61 39 39 61 30 35 47 28 12 83 88 37 61 56 55 31 31 29 58 65 72 42 123 121 42 46 46 42 0 1 0 46 255 76 1 147 1 242 0 41 0 46 0 125 184 0 0 47 24 184 0 0 69 88 184 0 17 47 27 185 0 17 0 9 62 89 187 0 34 0 1 0 7 0 4 43 184 0 17 16 185 0 24 0 1 244 48 49 5 39 62 1 53 52 38 39 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 23 30 3 21 20 6 1 60 66 26 27 28 43 34 67 52 33 35 60 78 44 49 66 25 42 21 43 29 30 51 36 20 22 38 50 28 30 41 26 11 30 180 26 33 44 22 24 32 13 12 33 54 81 60 58 91 63 32 34 23 54 19 24 25 46 65 40 43 57 39 25 9 10 20 27 36 25 26 75 0 3 0 78 255 244 2 4 2 210 0 27 0 41 0 58 0 87 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 20 0 11 0 0 17 18 57 186 0 50 0 11 0 0 17 18 57 184 0 50 16 185 0 31 0 1 244 184 0 11 16 185 0 39 0 1 244 184 0 0 16 185 0 42 0 1 244 48 49 5 34 46 2 53 17 52 62 2 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 3 20 6 21 62 3 53 52 38 35 34 6 19 50 54 53 52 46 2 35 34 6 7 21 20 30 2 1 49 39 81 65 42 24 48 74 50 34 66 51 31 55 57 81 91 33 57 77 191 1 61 84 52 22 57 40 57 62 143 57 74 16 35 53 37 16 62 59 30 45 51 12 25 56 91 66 1 9 50 85 61 35 21 42 64 44 54 85 27 4 8 105 79 47 75 52 27 1 236 32 54 24 12 35 44 53 30 57 53 87 254 5 72 62 28 51 39 23 11 17 69 54 69 40 15 0 0 0 2 0 66 255 244 1 207 2 212 0 12 0 50 0 77 0 184 0 0 69 88 184 0 43 47 27 185 0 43 0 19 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 5 62 89 186 0 33 0 43 0 13 17 18 57 184 0 33 16 185 0 5 0 1 244 184 0 43 16 185 0 10 0 1 244 184 0 13 16 185 0 28 0 1 244 48 49 19 20 30 2 55 46 3 35 34 6 19 34 38 53 52 38 39 51 30 1 21 20 30 2 51 50 62 2 55 6 46 2 53 52 62 2 51 50 22 21 20 14 2 145 21 53 92 71 2 22 37 50 30 42 54 114 81 90 2 6 78 6 1 15 26 36 20 25 43 32 19 1 92 122 72 30 27 47 62 36 112 113 29 54 75 2 29 32 60 44 19 10 72 99 62 27 63 253 163 90 91 43 53 26 17 55 40 35 47 29 12 25 64 110 86 12 31 62 82 38 40 67 48 27 182 180 105 143 88 38 0 0 2 0 46 255 77 2 122 1 246 0 37 0 51 0 92 0 125 184 0 0 47 24 184 0 0 69 88 184 0 24 47 27 185 0 24 0 9 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 9 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 185 0 20 0 1 244 184 0 1 16 184 0 34 208 184 0 20 16 184 0 41 208 184 0 24 16 185 0 49 0 1 244 48 49 5 53 46 3 53 52 54 55 23 14 3 21 20 30 2 23 53 52 54 51 50 30 2 21 20 14 2 7 30 1 23 3 20 22 23 62 3 53 52 38 35 34 6 1 47 51 93 71 42 61 46 67 22 33 23 12 26 46 63 38 83 65 41 68 48 26 42 71 92 51 1 2 1 6 1 1 37 62 46 26 58 44 30 41 179 170 1 33 63 93 62 75 130 54 48 26 50 52 58 34 42 65 46 25 2 242 103 99 34 63 90 57 62 96 67 37 1 43 85 42 1 222 61 122 62 2 28 50 71 45 83 96 63 0 0 0 255 255 0 46 255 244 2 34 3 2 2 38 2 96 0 0 0 7 7 36 1 28 0 0 255 255 0 46 255 244 1 172 3 2 2 38 2 100 0 0 0 7 7 36 0 247 0 0 255 255 0 75 255 77 1 209 3 2 2 38 2 102 0 0 0 7 7 36 1 34 0 0 255 255 0 82 255 244 0 234 3 2 2 38 2 104 0 0 0 6 7 36 124 0 0 0 255 255 255 234 255 244 1 14 2 175 2 38 2 104 0 0 0 6 7 51 124 0 0 0 255 255 0 46 255 244 1 233 3 2 2 38 2 110 0 0 0 7 7 36 1 12 0 0 255 255 0 60 255 244 1 199 3 2 2 38 2 115 0 0 0 7 7 36 0 244 0 0 255 255 0 60 255 244 1 199 2 175 2 38 2 115 0 0 0 7 7 51 0 244 0 0 255 255 0 51 255 244 2 138 3 2 2 38 2 119 0 0 0 7 7 36 1 94 0 0 255 255 255 225 255 244 1 23 3 6 2 38 2 104 0 0 0 6 7 107 124 0 0 0 255 255 0 60 255 244 1 199 3 6 2 38 2 115 0 0 0 7 7 107 0 244 0 0 255 255 255 250 0 0 2 66 2 153 0 38 0 2 37 0 0 6 3 126 6 0 0 0 255 255 255 243 0 0 2 58 2 153 0 38 0 2 29 0 0 6 3 127 0 0 0 0 255 255 0 3 0 0 2 51 2 158 0 38 0 2 22 0 0 6 3 128 25 0 0 0 255 255 0 6 0 0 2 51 2 158 0 38 0 2 22 0 0 6 3 107 25 0 0 0 255 255 255 244 0 0 2 199 2 158 0 39 0 2 0 170 0 0 0 6 3 130 0 0 255 255 255 243 0 0 2 195 2 158 0 39 0 2 0 166 0 0 0 6 3 131 0 0 255 255 255 244 0 0 2 195 2 158 0 39 0 2 0 166 0 0 0 6 3 132 0 0 255 255 255 243 0 0 2 191 2 158 0 39 0 2 0 162 0 0 0 6 3 133 0 0 255 255 255 232 0 0 2 98 2 160 0 38 0 2 69 0 0 6 3 134 0 0 0 0 255 255 255 232 0 0 2 98 2 160 0 38 0 2 69 0 0 6 3 135 0 0 0 0 255 255 0 3 0 0 2 29 3 74 2 38 0 2 0 0 0 7 7 47 1 15 0 0 255 255 0 3 0 0 2 29 3 24 2 38 0 2 0 0 0 7 7 42 1 15 0 0 255 255 255 244 0 0 2 84 2 153 0 38 0 6 118 0 0 6 3 126 0 0 0 0 255 255 255 243 0 0 2 84 2 153 0 38 0 6 118 0 0 6 3 127 0 0 0 0 255 255 255 234 0 0 2 30 2 158 0 38 0 6 64 0 0 6 3 128 0 0 0 0 255 255 255 237 0 0 2 30 2 158 0 38 0 6 64 0 0 6 3 107 0 0 0 0 255 255 255 244 0 0 2 203 2 158 0 39 0 6 0 237 0 0 0 6 3 130 0 0 255 255 255 243 0 0 2 200 2 158 0 39 0 6 0 234 0 0 0 6 3 131 0 0 255 255 255 244 0 0 2 199 2 158 0 39 0 6 0 233 0 0 0 6 3 132 0 0 255 255 255 243 0 0 2 195 2 158 0 39 0 6 0 229 0 0 0 6 3 133 0 0 255 255 255 244 0 0 2 168 2 153 0 38 0 9 118 0 0 6 3 126 0 0 0 0 255 255 255 243 0 0 2 168 2 153 0 38 0 9 118 0 0 6 3 127 0 0 0 0 255 255 255 234 0 0 2 114 2 158 0 38 0 9 64 0 0 6 3 128 0 0 0 0 255 255 255 237 0 0 2 114 2 158 0 38 0 9 64 0 0 6 3 107 0 0 0 0 255 255 255 244 0 0 3 31 2 158 0 39 0 9 0 237 0 0 0 6 3 130 0 0 255 255 255 243 0 0 3 28 2 158 0 39 0 9 0 234 0 0 0 6 3 131 0 0 255 255 255 244 0 0 3 27 2 158 0 39 0 9 0 233 0 0 0 6 3 132 0 0 255 255 255 243 0 0 3 23 2 158 0 39 0 9 0 229 0 0 0 6 3 133 0 0 255 255 255 232 0 0 2 238 2 160 0 39 0 9 0 188 0 0 0 6 3 134 0 0 255 255 255 232 0 0 2 238 2 160 0 39 0 9 0 188 0 0 0 6 3 135 0 0 255 255 255 244 0 0 1 35 2 153 0 38 0 10 118 0 0 6 3 126 0 0 0 0 255 255 255 243 0 0 1 35 2 153 0 38 0 10 118 0 0 6 3 127 0 0 0 0 255 255 255 234 0 0 0 237 2 158 0 38 0 10 64 0 0 6 3 128 0 0 0 0 255 255 255 237 0 0 0 237 2 158 0 38 0 10 64 0 0 6 3 107 0 0 0 0 255 255 255 244 0 0 1 154 2 158 0 39 0 10 0 237 0 0 0 6 3 130 0 0 255 255 255 243 0 0 1 151 2 158 0 39 0 10 0 234 0 0 0 6 3 131 0 0 255 255 255 244 0 0 1 150 2 158 0 39 0 10 0 233 0 0 0 6 3 132 0 0 255 255 255 243 0 0 1 146 2 158 0 39 0 10 0 229 0 0 0 6 3 133 0 0 255 255 255 232 0 0 1 105 2 160 0 39 0 10 0 188 0 0 0 6 3 134 0 0 255 255 255 232 0 0 1 105 2 160 0 39 0 10 0 188 0 0 0 6 3 135 0 0 255 255 255 241 0 0 1 21 3 74 2 38 0 10 0 0 0 7 7 47 0 131 0 0 255 255 255 253 0 0 1 9 3 24 2 38 0 10 0 0 0 7 7 42 0 131 0 0 255 255 255 244 255 244 2 198 2 156 0 38 0 16 97 0 0 6 3 126 0 0 0 0 255 255 255 243 255 244 2 184 2 156 0 38 0 16 83 0 0 6 3 127 0 0 0 0 255 255 255 234 255 244 2 154 2 158 0 38 0 16 53 0 0 6 3 128 0 0 0 0 255 255 255 237 255 244 2 148 2 158 0 38 0 16 47 0 0 6 3 107 0 0 0 0 255 255 255 244 255 244 3 71 2 158 0 39 0 16 0 226 0 0 0 6 3 130 0 0 255 255 255 243 255 244 3 67 2 158 0 39 0 16 0 222 0 0 0 6 3 131 0 0 255 255 255 244 255 244 3 61 2 158 0 39 0 16 0 216 0 0 0 6 3 132 0 0 255 255 255 243 255 244 3 57 2 158 0 39 0 16 0 212 0 0 0 6 3 133 0 0 255 255 255 243 0 0 2 129 2 153 0 38 0 17 118 0 0 6 3 127 0 0 0 0 255 255 255 243 0 0 2 134 2 153 0 39 0 26 0 169 0 0 0 6 3 127 0 0 255 255 255 234 0 0 2 89 2 158 0 38 0 26 124 0 0 6 3 128 0 0 0 0 255 255 255 237 0 0 2 89 2 158 0 38 0 26 124 0 0 6 3 107 0 0 0 0 255 255 255 243 0 0 3 3 2 158 0 39 0 26 1 38 0 0 0 6 3 131 0 0 255 255 255 243 0 0 2 254 2 158 0 39 0 26 1 33 0 0 0 6 3 133 0 0 255 255 255 232 0 0 2 207 2 160 0 39 0 26 0 242 0 0 0 6 3 135 0 0 255 255 255 255 0 0 1 221 3 74 2 38 0 26 0 0 0 7 7 47 0 238 0 0 255 255 255 255 0 0 1 221 3 24 2 38 0 26 0 0 0 7 7 42 0 238 0 0 255 255 255 244 0 0 2 218 2 156 0 38 2 86 97 0 0 6 3 126 0 0 0 0 255 255 255 243 0 0 2 204 2 156 0 38 2 86 83 0 0 6 3 127 0 0 0 0 255 255 255 235 0 0 2 171 2 158 0 38 2 86 50 0 0 6 3 128 1 0 0 0 255 255 255 234 0 0 2 168 2 158 0 38 2 86 47 0 0 6 3 107 253 0 0 0 255 255 255 244 0 0 3 89 2 158 0 39 2 86 0 224 0 0 0 6 3 130 0 0 255 255 255 243 0 0 3 85 2 158 0 39 2 86 0 220 0 0 0 6 3 131 0 0 255 255 255 244 0 0 3 84 2 158 0 39 2 86 0 219 0 0 0 6 3 132 0 0 255 255 255 243 0 0 3 81 2 158 0 39 2 86 0 216 0 0 0 6 3 133 0 0 255 255 255 232 0 0 3 6 2 160 0 39 2 86 0 141 0 0 0 6 3 134 0 0 255 255 255 232 0 0 3 6 2 160 0 39 2 86 0 141 0 0 0 6 3 135 0 0 255 255 0 3 255 244 3 9 2 144 0 38 0 2 0 0 0 7 3 110 2 30 0 0 255 255 255 250 255 244 3 46 2 153 0 38 0 2 37 0 0 38 3 126 6 0 0 7 3 110 2 67 0 0 0 0 255 255 255 243 255 244 3 38 2 153 0 38 0 2 29 0 0 38 3 127 0 0 0 7 3 110 2 59 0 0 0 0 255 255 255 244 255 244 3 179 2 158 0 39 0 2 0 170 0 0 0 38 3 130 0 0 0 7 3 110 2 200 0 0 255 255 255 243 255 244 3 175 2 158 0 39 0 2 0 166 0 0 0 38 3 131 0 0 0 7 3 110 2 196 0 0 255 255 255 244 255 244 3 174 2 158 0 39 0 2 0 166 0 0 0 38 3 132 0 0 0 7 3 110 2 195 0 0 255 255 255 243 255 244 3 170 2 158 0 39 0 2 0 162 0 0 0 38 3 133 0 0 0 7 3 110 2 191 0 0 255 255 255 232 255 244 3 78 2 160 0 38 0 2 69 0 0 38 3 134 0 0 0 7 3 110 2 99 0 0 0 0 255 255 255 232 255 244 3 78 2 160 0 38 0 2 69 0 0 38 3 135 0 0 0 7 3 110 2 99 0 0 0 0 255 255 0 90 255 244 3 117 2 144 0 38 0 9 0 0 0 7 3 110 2 138 0 0 255 255 255 244 255 244 3 235 2 153 0 38 0 9 118 0 0 38 3 126 0 0 0 7 3 110 3 0 0 0 0 0 255 255 255 243 255 244 3 235 2 153 0 38 0 9 118 0 0 38 3 127 0 0 0 7 3 110 3 0 0 0 0 0 255 255 255 244 255 244 4 98 2 158 0 39 0 9 0 237 0 0 0 38 3 130 0 0 0 7 3 110 3 119 0 0 255 255 255 243 255 244 4 94 2 158 0 39 0 9 0 234 0 0 0 38 3 131 0 0 0 7 3 110 3 115 0 0 255 255 255 244 255 244 4 94 2 158 0 39 0 9 0 233 0 0 0 38 3 132 0 0 0 7 3 110 3 115 0 0 255 255 255 243 255 244 4 90 2 158 0 39 0 9 0 229 0 0 0 38 3 133 0 0 0 7 3 110 3 111 0 0 255 255 255 232 255 244 4 49 2 160 0 39 0 9 0 188 0 0 0 38 3 134 0 0 0 7 3 110 3 70 0 0 255 255 255 232 255 244 4 49 2 160 0 39 0 9 0 188 0 0 0 38 3 135 0 0 0 7 3 110 3 70 0 0 255 255 0 45 255 244 3 142 2 156 0 38 2 86 0 0 0 7 3 110 2 163 0 0 255 255 255 244 255 244 3 238 2 156 0 38 2 86 97 0 0 38 3 126 0 0 0 7 3 110 3 3 0 0 0 0 255 255 255 243 255 244 3 224 2 156 0 38 2 86 83 0 0 38 3 127 0 0 0 7 3 110 2 245 0 0 0 0 255 255 255 244 255 244 4 109 2 158 0 39 2 86 0 224 0 0 0 38 3 130 0 0 0 7 3 110 3 130 0 0 255 255 255 243 255 244 4 105 2 158 0 39 2 86 0 220 0 0 0 38 3 131 0 0 0 7 3 110 3 126 0 0 255 255 255 244 255 244 4 104 2 158 0 39 2 86 0 219 0 0 0 38 3 132 0 0 0 7 3 110 3 125 0 0 255 255 255 243 255 244 4 100 2 158 0 39 2 86 0 216 0 0 0 38 3 133 0 0 0 7 3 110 3 121 0 0 255 255 255 232 255 244 4 28 2 160 0 39 2 86 0 141 0 0 0 38 3 134 0 0 0 7 3 110 3 49 0 0 255 255 255 232 255 244 4 28 2 160 0 39 2 86 0 141 0 0 0 38 3 135 0 0 0 7 3 110 3 49 0 0 255 255 0 46 255 244 2 34 3 2 2 38 2 96 0 0 0 7 7 53 1 28 0 10 255 255 0 46 255 244 2 34 2 245 2 38 2 96 0 0 0 7 7 67 1 28 0 0 255 255 0 46 255 244 2 34 3 13 2 38 2 96 0 0 0 7 7 31 1 28 0 0 255 255 0 46 255 244 2 34 3 13 2 38 2 96 0 0 0 7 7 34 1 28 0 0 255 255 0 46 255 244 2 34 3 2 2 38 2 96 0 0 0 7 7 140 1 28 0 0 255 255 0 46 255 244 2 34 3 2 2 38 2 96 0 0 0 7 7 137 1 28 0 0 255 255 0 46 255 244 2 34 3 2 2 38 2 96 0 0 0 7 7 139 1 28 0 0 255 255 0 46 255 244 2 34 3 2 2 38 2 96 0 0 0 7 7 136 1 28 0 0 255 255 0 46 255 244 2 34 3 39 2 38 2 96 0 0 0 7 7 141 1 28 0 0 255 255 0 46 255 244 2 34 3 39 2 38 2 96 0 0 0 7 7 138 1 28 0 0 255 255 0 46 255 244 2 34 2 218 2 38 2 96 0 0 0 7 7 45 1 28 0 0 255 255 0 46 255 244 2 34 2 146 2 38 2 96 0 0 0 7 7 41 1 28 0 0 255 255 0 46 255 244 2 34 2 209 2 38 2 96 0 0 0 7 7 39 1 28 0 0 255 255 0 46 255 244 1 172 2 248 2 38 2 100 0 0 0 7 7 53 0 247 0 0 255 255 0 46 255 244 1 172 2 245 2 38 2 100 0 0 0 7 7 67 0 247 0 0 255 255 0 46 255 244 1 172 3 13 2 38 2 100 0 0 0 7 7 31 0 247 0 0 255 255 0 46 255 244 1 172 3 13 2 38 2 100 0 0 0 7 7 34 0 247 0 0 255 255 0 46 255 244 1 172 3 2 2 38 2 100 0 0 0 7 7 140 0 247 0 0 255 255 0 46 255 244 1 172 3 2 2 38 2 100 0 0 0 7 7 137 0 247 0 0 255 255 0 46 255 244 1 172 3 2 2 38 2 100 0 0 0 7 7 139 0 247 0 0 255 255 0 46 255 244 1 172 3 2 2 38 2 100 0 0 0 7 7 136 0 247 0 0 255 255 0 75 255 77 1 209 2 248 2 38 2 102 0 0 0 7 7 53 1 34 0 0 255 255 0 75 255 77 1 209 2 245 2 38 2 102 0 0 0 7 7 67 1 34 0 0 255 255 0 75 255 77 1 209 3 13 2 38 2 102 0 0 0 7 7 31 1 34 0 0 255 255 0 75 255 77 1 209 3 13 2 38 2 102 0 0 0 7 7 34 1 34 0 0 255 255 0 75 255 77 1 209 3 2 2 38 2 102 0 0 0 7 7 140 1 34 0 0 255 255 0 75 255 77 1 209 3 2 2 38 2 102 0 0 0 7 7 137 1 34 0 0 255 255 0 75 255 77 1 209 3 2 2 38 2 102 0 0 0 7 7 139 1 34 0 0 255 255 0 75 255 77 1 209 3 2 2 38 2 102 0 0 0 7 7 136 1 34 0 0 255 255 0 75 255 77 1 209 3 39 2 38 2 102 0 0 0 7 7 141 1 34 0 0 255 255 0 75 255 77 1 209 3 39 2 38 2 102 0 0 0 7 7 138 1 34 0 0 255 255 0 75 255 77 1 209 2 209 2 38 2 102 0 0 0 7 7 39 1 34 0 0 255 255 0 56 255 244 0 234 3 2 2 38 2 104 0 0 0 6 7 53 124 10 0 0 255 255 0 44 255 244 0 234 2 245 2 38 2 104 0 0 0 6 7 67 124 0 0 0 255 255 255 237 255 244 0 234 3 13 2 38 2 104 0 0 0 6 7 31 124 0 0 0 255 255 0 68 255 244 1 11 3 13 2 38 2 104 0 0 0 6 7 34 124 0 0 0 255 255 255 224 255 244 0 239 3 2 2 38 2 104 0 0 0 6 7 140 124 0 0 0 255 255 255 218 255 244 0 234 3 2 2 38 2 104 0 0 0 6 7 137 124 0 0 0 255 255 255 224 255 244 0 252 3 2 2 38 2 104 0 0 0 6 7 139 124 0 0 0 255 255 255 228 255 244 0 246 3 2 2 38 2 104 0 0 0 6 7 136 124 0 0 0 255 255 255 239 255 244 1 9 3 39 2 38 2 104 0 0 0 6 7 141 124 0 0 0 255 255 255 239 255 244 1 9 3 39 2 38 2 104 0 0 0 6 7 138 124 0 0 0 255 255 255 224 255 244 1 24 2 218 2 38 2 104 0 0 0 6 7 45 124 0 0 0 255 255 255 247 255 244 1 1 2 146 2 38 2 104 0 0 0 6 7 41 124 0 0 0 255 255 255 207 255 244 1 41 2 209 2 38 2 104 0 0 0 6 7 39 124 0 0 0 255 255 255 225 255 244 1 23 3 6 2 38 2 104 0 0 0 6 7 110 124 0 0 0 255 255 255 225 255 244 1 23 3 6 2 38 2 104 0 0 0 6 7 107 124 0 0 0 255 255 255 227 255 244 1 21 3 38 2 38 2 104 0 0 0 6 7 111 124 0 0 0 255 255 0 46 255 244 1 233 3 2 2 38 2 110 0 0 0 7 7 53 1 12 0 10 255 255 0 46 255 244 1 233 2 245 2 38 2 110 0 0 0 7 7 67 1 12 0 0 255 255 0 46 255 244 1 233 3 13 2 38 2 110 0 0 0 7 7 31 1 12 0 0 255 255 0 46 255 244 1 233 3 13 2 38 2 110 0 0 0 7 7 34 1 12 0 0 255 255 0 46 255 244 1 233 3 2 2 38 2 110 0 0 0 7 7 140 1 12 0 0 255 255 0 46 255 244 1 233 3 2 2 38 2 110 0 0 0 7 7 137 1 12 0 0 255 255 0 46 255 244 1 233 3 2 2 38 2 110 0 0 0 7 7 139 1 12 0 0 255 255 0 46 255 244 1 233 3 2 2 38 2 110 0 0 0 7 7 136 1 12 0 0 255 255 0 78 255 77 1 246 3 2 2 38 2 112 0 0 0 7 7 53 1 36 0 10 255 255 0 78 255 77 1 246 2 245 2 38 2 112 0 0 0 7 7 67 1 36 0 0 255 255 0 60 255 244 1 199 3 2 2 38 2 115 0 0 0 7 7 53 0 244 0 10 255 255 0 60 255 244 1 199 2 245 2 38 2 115 0 0 0 7 7 67 0 244 0 0 255 255 0 60 255 244 1 199 3 13 2 38 2 115 0 0 0 7 7 31 0 244 0 0 255 255 0 60 255 244 1 199 3 13 2 38 2 115 0 0 0 7 7 34 0 244 0 0 255 255 0 60 255 244 1 199 3 2 2 38 2 115 0 0 0 7 7 140 0 244 0 0 255 255 0 60 255 244 1 199 3 2 2 38 2 115 0 0 0 7 7 137 0 244 0 0 255 255 0 60 255 244 1 199 3 2 2 38 2 115 0 0 0 7 7 139 0 244 0 0 255 255 0 60 255 244 1 199 3 2 2 38 2 115 0 0 0 7 7 136 0 244 0 0 255 255 0 60 255 244 1 199 3 39 2 38 2 115 0 0 0 7 7 141 0 244 0 0 255 255 0 60 255 244 1 199 3 39 2 38 2 115 0 0 0 7 7 138 0 244 0 0 255 255 0 60 255 244 1 199 2 209 2 38 2 115 0 0 0 7 7 39 0 244 0 0 255 255 0 60 255 244 1 199 2 218 2 38 2 115 0 0 0 7 7 45 0 244 0 0 255 255 0 60 255 244 1 199 2 146 2 38 2 115 0 0 0 7 7 41 0 244 0 0 255 255 0 60 255 244 1 199 3 6 2 38 2 115 0 0 0 7 7 110 0 244 0 0 255 255 0 60 255 244 1 199 3 6 2 38 2 115 0 0 0 7 7 107 0 244 0 0 255 255 0 60 255 244 1 199 3 38 2 38 2 115 0 0 0 7 7 111 0 244 0 0 255 255 0 51 255 244 2 138 3 2 2 38 2 119 0 0 0 7 7 53 1 94 0 10 255 255 0 51 255 244 2 138 2 245 2 38 2 119 0 0 0 7 7 67 1 94 0 0 255 255 0 51 255 244 2 138 3 13 2 38 2 119 0 0 0 7 7 31 1 94 0 0 255 255 0 51 255 244 2 138 3 13 2 38 2 119 0 0 0 7 7 34 1 94 0 0 255 255 0 51 255 244 2 138 3 2 2 38 2 119 0 0 0 7 7 140 1 94 0 0 255 255 0 51 255 244 2 138 3 2 2 38 2 119 0 0 0 7 7 137 1 94 0 0 255 255 0 51 255 244 2 138 3 2 2 38 2 119 0 0 0 7 7 139 1 94 0 0 255 255 0 51 255 244 2 138 3 2 2 38 2 119 0 0 0 7 7 136 1 94 0 0 255 255 0 51 255 244 2 138 3 39 2 38 2 119 0 0 0 7 7 141 1 94 0 0 255 255 0 51 255 244 2 138 3 39 2 38 2 119 0 0 0 7 7 138 1 94 0 0 255 255 0 51 255 244 2 138 2 209 2 38 2 119 0 0 0 7 7 39 1 94 0 0 255 255 0 46 255 55 2 34 1 242 2 38 2 96 0 0 0 7 7 103 1 31 0 0 255 255 0 46 255 55 2 34 3 2 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 53 1 28 0 10 255 255 0 46 255 55 2 34 2 245 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 67 1 28 0 0 255 255 0 46 255 55 2 34 3 13 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 31 1 28 0 0 255 255 0 46 255 55 2 34 3 13 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 34 1 28 0 0 255 255 0 46 255 55 2 34 3 2 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 140 1 28 0 0 255 255 0 46 255 55 2 34 3 2 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 137 1 28 0 0 255 255 0 46 255 55 2 34 3 2 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 139 1 28 0 0 255 255 0 46 255 55 2 34 3 2 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 136 1 28 0 0 255 255 0 46 255 55 2 34 3 39 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 141 1 28 0 0 255 255 0 46 255 55 2 34 3 39 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 138 1 28 0 0 255 255 0 46 255 55 2 34 2 209 2 38 2 96 0 0 0 39 7 103 1 31 0 0 0 7 7 39 1 28 0 0 255 255 0 75 255 55 1 209 1 242 2 38 2 102 0 0 0 6 7 103 118 0 0 0 255 255 0 75 255 55 1 209 3 2 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 53 1 34 0 10 0 0 255 255 0 75 255 55 1 209 2 245 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 67 1 34 0 0 0 0 255 255 0 75 255 55 1 209 3 13 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 31 1 34 0 0 0 0 255 255 0 75 255 55 1 209 3 13 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 34 1 34 0 0 0 0 255 255 0 75 255 55 1 209 3 2 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 140 1 34 0 0 0 0 255 255 0 75 255 55 1 209 3 2 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 137 1 34 0 0 0 0 255 255 0 75 255 55 1 209 3 2 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 139 1 34 0 0 0 0 255 255 0 75 255 55 1 209 3 2 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 136 1 34 0 0 0 0 255 255 0 75 255 55 1 209 3 39 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 141 1 34 0 0 0 0 255 255 0 75 255 55 1 209 3 39 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 138 1 34 0 0 0 0 255 255 0 75 255 55 1 209 2 209 2 38 2 102 0 0 0 38 7 103 118 0 0 7 7 39 1 34 0 0 0 0 255 255 0 51 255 55 2 138 1 242 2 38 2 119 0 0 0 7 7 103 1 88 0 0 255 255 0 51 255 55 2 138 3 2 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 53 1 94 0 10 255 255 0 51 255 55 2 138 2 245 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 67 1 94 0 0 255 255 0 51 255 55 2 138 3 13 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 31 1 94 0 0 255 255 0 51 255 55 2 138 3 13 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 34 1 94 0 0 255 255 0 51 255 55 2 138 3 2 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 140 1 94 0 0 255 255 0 51 255 55 2 138 3 2 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 137 1 94 0 0 255 255 0 51 255 55 2 138 3 2 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 139 1 94 0 0 255 255 0 51 255 55 2 138 3 2 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 136 1 94 0 0 255 255 0 51 255 55 2 138 3 39 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 141 1 94 0 0 255 255 0 51 255 55 2 138 3 39 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 138 1 94 0 0 255 255 0 51 255 55 2 138 2 209 2 38 2 119 0 0 0 39 7 103 1 88 0 0 0 7 7 39 1 94 0 0 0 1 0 73 255 69 1 241 1 242 0 43 0 101 0 125 184 0 0 47 24 184 0 0 69 88 184 0 32 47 27 185 0 32 0 9 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 5 62 89 184 0 4 208 184 0 32 16 184 0 21 208 184 0 21 47 186 0 9 0 17 0 21 17 18 57 186 0 26 0 21 0 17 17 18 57 186 0 36 0 21 0 17 17 18 57 184 0 4 16 184 0 41 208 184 0 41 47 48 49 5 39 62 1 55 46 3 39 14 1 7 14 1 7 21 35 17 52 38 39 51 30 1 29 1 51 62 3 55 23 14 1 7 30 3 23 14 1 1 106 96 39 71 29 20 42 42 40 17 11 23 11 22 17 1 77 3 6 81 5 4 4 29 68 75 78 39 8 41 83 45 18 48 52 57 27 33 73 187 8 41 89 43 22 57 64 68 33 14 29 16 29 77 48 25 1 97 29 72 32 20 61 32 152 50 92 74 51 10 78 13 61 49 36 79 79 73 30 53 99 0 0 2 0 46 255 77 1 233 1 242 0 11 0 38 0 67 0 125 184 0 12 47 24 184 0 0 69 88 184 0 23 47 27 185 0 23 0 9 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 5 62 89 185 0 0 0 1 244 184 0 23 16 185 0 6 0 1 244 184 0 13 16 184 0 33 208 48 49 37 50 54 53 52 38 35 34 6 21 20 22 23 53 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 30 3 21 1 11 65 72 72 65 65 71 71 28 39 67 50 28 35 60 81 45 46 81 60 35 28 48 66 38 1 1 1 1 54 102 86 85 103 103 85 86 102 233 170 6 40 63 88 54 61 96 65 34 34 65 96 61 54 86 63 40 7 23 40 39 43 26 0 0 1 0 46 255 72 1 184 1 230 0 37 0 67 0 125 184 0 0 47 24 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 184 0 19 16 185 0 21 0 1 244 184 0 24 208 184 0 9 16 185 0 32 0 1 244 48 49 5 39 62 1 53 52 46 2 39 46 3 53 52 62 2 59 1 21 38 34 35 34 6 21 20 30 2 23 30 1 21 20 6 1 95 66 27 22 6 19 35 29 40 72 55 32 37 66 89 51 151 29 75 41 75 89 23 40 57 34 70 53 29 184 27 32 37 18 10 18 16 15 7 10 35 57 83 57 64 93 61 30 70 2 89 91 40 58 41 27 8 17 51 46 23 73 0 0 0 0 1 0 82 255 77 1 131 1 230 0 11 0 46 0 125 184 0 0 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 187 0 6 0 1 0 7 0 4 43 184 0 1 16 185 0 3 0 1 244 48 49 23 17 33 21 35 23 51 21 35 20 22 23 82 1 49 228 2 206 206 2 2 179 2 153 67 217 59 81 153 88 0 0 0 1 0 17 255 77 1 218 2 178 0 29 0 21 0 186 0 22 0 0 0 3 43 186 0 6 0 0 0 22 17 18 57 48 49 5 39 62 1 53 52 39 14 1 7 39 37 38 39 14 1 7 39 37 46 1 39 55 30 3 21 20 6 1 200 80 10 8 10 63 121 69 34 1 16 15 27 69 132 75 34 1 22 42 116 75 51 87 135 91 48 8 179 10 48 92 46 67 59 29 57 35 69 122 63 56 31 62 38 69 125 72 118 44 61 53 146 174 197 104 51 95 0 0 255 255 0 47 255 86 0 198 1 219 2 39 4 117 0 0 1 105 0 6 4 118 0 0 255 255 0 65 1 93 0 184 1 219 2 7 4 117 0 0 1 105 0 0 255 255 0 65 2 30 0 184 2 156 2 7 4 117 0 0 2 42 0 0 0 1 0 82 1 193 0 185 2 178 0 4 0 11 0 186 0 1 0 0 0 3 43 48 49 19 55 51 15 1 82 22 81 15 34 1 193 241 92 149 0 1 0 64 0 0 0 167 0 242 0 4 0 24 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 2 220 48 49 51 63 1 51 7 64 15 34 54 22 92 150 242 0 255 255 0 238 2 46 1 110 3 2 0 7 7 36 1 15 0 0 0 0 0 1 255 237 1 208 0 86 2 158 0 3 0 20 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 48 49 3 55 23 7 19 29 76 50 1 219 195 11 195 0 255 255 0 122 2 51 1 176 3 6 0 7 7 107 1 21 0 0 0 0 255 255 0 244 255 55 1 111 255 194 0 7 7 103 1 21 0 0 0 0 0 1 0 82 255 244 0 235 1 150 0 16 0 30 0 184 0 4 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 11 0 1 244 48 49 23 34 38 53 17 51 14 1 21 20 22 51 50 55 23 14 1 176 51 43 83 2 4 20 16 12 17 11 11 27 12 59 54 1 49 81 158 72 20 19 6 62 5 7 255 255 0 203 2 60 1 95 2 248 0 7 7 53 1 15 0 0 0 0 255 255 0 203 2 60 1 95 2 248 0 7 7 53 1 15 0 0 0 0 255 255 0 191 2 62 1 83 2 245 0 7 7 67 1 15 0 0 0 0 255 255 0 180 2 46 1 48 3 2 0 7 7 33 1 15 0 0 0 0 255 255 0 238 2 46 1 110 3 2 0 7 7 36 1 15 0 0 0 0 255 255 0 115 2 47 1 130 3 2 0 7 7 140 1 15 0 0 0 0 255 255 0 109 2 47 1 123 3 2 0 7 7 137 1 15 0 0 0 0 255 255 0 115 2 47 1 143 3 2 0 7 7 139 1 15 0 0 0 0 255 255 0 119 2 47 1 137 3 2 0 7 7 136 1 15 0 0 0 0 255 255 0 130 2 50 1 156 3 39 0 7 7 141 1 15 0 0 0 0 255 255 0 130 2 50 1 156 3 39 0 7 7 138 1 15 0 0 0 0 255 255 0 98 2 65 1 188 2 209 0 7 7 39 1 15 0 0 0 0 255 255 0 116 2 51 1 170 3 6 0 7 7 110 1 15 0 0 0 0 255 255 0 116 2 51 1 170 3 6 0 7 7 107 1 15 0 0 0 0 255 255 0 118 2 76 1 168 3 38 0 7 7 111 1 15 0 0 0 0 0 1 255 244 1 205 0 135 2 153 0 15 0 26 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 17 62 89 185 0 7 0 1 244 48 49 19 39 62 1 53 52 38 39 55 30 1 21 20 14 2 24 9 23 33 41 42 9 66 72 18 31 40 1 205 38 9 30 27 23 28 2 47 2 45 44 27 38 26 17 0 1 255 243 1 205 0 134 2 153 0 15 0 26 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 17 62 89 185 0 9 0 1 244 48 49 19 46 3 53 52 54 55 23 14 1 21 20 22 23 98 22 40 31 18 72 66 9 42 41 33 23 1 205 5 17 26 38 27 44 45 2 47 2 28 23 27 30 9 0 0 1 255 234 1 208 0 83 2 158 0 3 0 24 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 17 62 89 184 0 0 220 48 49 19 39 55 23 28 50 76 29 1 208 195 11 195 0 255 255 255 237 1 208 0 86 2 158 2 6 3 107 0 0 0 2 255 244 1 208 1 0 2 158 0 3 0 18 0 43 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 17 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 17 62 89 185 0 10 0 1 244 48 49 19 39 55 23 7 39 62 1 53 52 39 55 30 1 21 20 14 2 201 50 76 29 232 12 18 25 67 9 54 64 16 25 33 1 208 195 11 195 11 38 11 30 21 53 4 47 2 47 46 22 35 27 19 0 2 255 243 1 208 0 252 2 158 0 3 0 18 0 43 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 17 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 17 62 89 185 0 13 0 1 244 48 49 19 39 55 23 7 46 3 53 52 54 55 23 6 21 20 22 23 198 51 76 29 174 17 33 25 16 64 54 9 67 25 18 1 208 195 11 195 11 6 19 27 35 22 46 47 2 47 4 53 21 30 11 0 0 2 255 244 1 208 1 0 2 158 0 3 0 18 0 43 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 17 62 89 185 0 10 0 1 244 48 49 19 55 23 7 35 39 62 1 53 52 39 55 30 1 21 20 14 2 151 29 76 50 182 12 18 25 67 9 54 64 16 25 33 1 219 195 11 195 38 11 30 21 53 4 47 2 47 46 22 35 27 19 0 0 2 255 243 1 208 0 252 2 158 0 3 0 18 0 43 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 17 62 89 185 0 13 0 1 244 48 49 19 55 23 7 35 46 3 53 52 54 55 23 6 21 20 22 23 147 29 76 50 124 17 33 25 16 64 54 9 67 25 18 1 219 195 11 195 6 19 27 35 22 46 47 2 47 4 53 21 30 11 0 0 0 2 255 232 1 183 0 212 2 160 0 23 0 37 0 87 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 15 62 89 184 0 0 69 88 184 0 32 47 27 185 0 32 0 13 62 89 187 0 3 0 1 0 20 0 4 43 184 0 3 16 184 0 11 208 184 0 11 47 184 0 8 16 185 0 15 0 1 244 184 0 23 208 184 0 23 47 184 0 32 16 185 0 31 0 1 244 48 49 3 62 1 51 50 30 2 51 50 54 55 23 14 1 35 34 46 2 35 34 6 7 23 39 62 1 53 52 38 39 55 30 1 21 20 6 24 4 32 33 18 25 21 19 12 12 16 2 42 4 32 33 18 25 21 19 12 12 16 2 49 8 18 24 32 37 7 59 62 57 2 90 35 35 11 13 11 12 19 6 35 35 11 13 11 12 19 157 33 5 14 10 14 16 2 39 2 29 31 31 33 0 2 255 232 1 183 0 212 2 160 0 15 0 39 0 87 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 15 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 13 62 89 187 0 19 0 1 0 36 0 4 43 184 0 8 16 185 0 9 0 1 244 184 0 19 16 184 0 27 208 184 0 27 47 184 0 24 16 185 0 31 0 1 244 184 0 39 208 184 0 39 47 48 49 19 46 3 53 52 54 55 23 14 1 21 20 22 23 39 62 1 51 50 30 2 51 50 54 55 23 14 1 35 34 46 2 35 34 6 7 121 18 34 26 16 63 59 7 37 32 23 19 153 4 32 33 18 25 21 19 12 12 16 2 42 4 32 33 18 25 21 19 12 12 16 2 1 183 3 12 17 24 15 31 29 2 39 2 16 14 10 14 5 130 35 35 11 13 11 12 19 6 35 35 11 13 11 12 19 255 255 0 3 0 0 2 29 2 144 2 6 0 2 0 0 0 2 0 90 0 0 2 27 2 144 0 14 0 23 0 77 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 184 0 1 16 185 0 3 0 2 244 186 0 23 0 1 0 14 17 18 57 184 0 23 16 185 0 6 0 1 244 184 0 14 16 185 0 16 0 2 244 48 49 51 17 33 21 33 21 51 50 30 2 21 20 6 35 39 51 50 54 53 52 38 43 1 90 1 149 254 190 126 52 88 64 36 128 108 130 116 85 83 85 85 114 2 144 70 206 20 43 69 49 103 96 66 63 68 63 56 0 0 255 255 0 90 0 0 2 36 2 144 2 6 0 3 0 0 255 255 0 90 0 0 1 212 2 144 2 6 2 65 0 0 0 2 0 26 255 68 2 100 2 144 0 22 0 33 0 75 0 125 184 0 2 47 24 184 0 0 69 88 184 0 15 47 27 185 0 15 0 17 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 5 62 89 185 0 4 0 2 244 184 0 27 208 184 0 18 208 184 0 2 16 184 0 21 208 184 0 15 16 185 0 28 0 2 244 48 49 51 21 35 39 53 51 62 3 55 62 3 55 33 17 51 21 7 35 53 1 14 1 7 33 17 35 14 3 108 73 9 30 10 22 23 24 12 9 15 13 14 9 1 76 73 9 73 254 205 16 35 22 1 49 183 8 11 11 12 188 209 50 4 26 54 87 65 49 82 80 85 53 253 183 50 209 188 1 37 84 107 31 2 3 42 71 68 70 0 255 255 0 90 0 0 1 222 2 144 2 6 0 6 0 0 0 1 0 6 0 0 3 30 2 156 0 53 0 131 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 21 0 1 0 51 0 4 43 186 0 1 0 21 0 51 17 18 57 184 0 14 16 185 0 7 0 2 244 184 0 14 16 184 0 22 208 184 0 22 47 184 0 21 16 184 0 25 208 184 0 14 16 184 0 31 208 185 0 38 0 2 244 184 0 51 16 184 0 47 208 186 0 44 0 25 0 47 17 18 57 184 0 0 16 184 0 50 208 184 0 46 208 48 49 51 19 39 46 3 35 34 6 7 39 62 1 51 50 30 2 31 1 51 17 51 17 51 55 62 3 51 50 22 23 7 46 1 35 34 14 2 15 1 19 35 3 35 17 35 17 35 3 6 200 69 13 22 20 20 11 5 13 6 14 8 19 9 22 38 36 34 18 77 89 79 88 78 18 34 36 38 22 9 19 8 14 7 12 5 11 20 20 22 13 69 199 91 170 95 79 95 170 1 94 155 27 33 18 5 2 2 78 3 3 10 27 48 37 167 1 21 254 235 167 37 48 27 10 3 3 78 2 2 5 18 33 27 155 254 162 1 55 254 201 1 55 254 201 0 0 0 0 1 255 246 255 244 3 46 2 156 0 81 0 201 0 184 0 0 69 88 184 0 39 47 27 185 0 39 0 17 62 89 184 0 0 69 88 184 0 41 47 27 185 0 41 0 17 62 89 184 0 0 69 88 184 0 58 47 27 185 0 58 0 17 62 89 184 0 0 69 88 184 0 60 47 27 185 0 60 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 5 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 184 0 0 69 88 184 0 80 47 27 185 0 80 0 5 62 89 187 0 52 0 1 0 6 0 4 43 184 0 6 16 184 0 10 208 184 0 17 16 185 0 23 0 2 244 184 0 41 16 185 0 35 0 2 244 184 0 52 16 184 0 47 208 184 0 35 16 184 0 64 208 184 0 23 16 184 0 76 208 48 49 5 34 46 2 47 1 35 17 35 17 35 7 14 3 35 34 39 55 30 1 51 50 62 2 63 1 39 46 3 35 34 6 7 39 54 51 50 30 2 31 1 51 17 51 17 51 55 62 3 51 50 23 7 46 1 35 34 14 2 15 1 23 30 3 51 50 54 55 23 6 3 5 20 34 32 33 19 92 102 78 102 91 19 33 32 34 20 27 15 15 6 12 5 11 18 18 20 14 87 63 12 20 20 19 11 5 13 6 14 15 25 21 36 34 32 17 67 103 78 104 67 17 32 34 36 20 26 15 14 7 12 5 11 20 19 21 11 63 86 14 21 18 18 11 5 12 6 14 14 12 9 26 46 38 204 254 201 1 55 204 38 46 26 9 6 78 2 2 6 18 32 27 194 160 26 32 18 7 2 2 78 6 10 27 48 37 167 1 21 254 235 167 37 48 27 10 6 78 2 2 7 18 32 26 161 193 27 32 18 6 2 2 78 6 0 0 0 0 1 0 10 0 0 3 23 2 144 0 21 0 29 0 187 0 9 0 1 0 15 0 4 43 184 0 9 16 184 0 4 208 184 0 15 16 184 0 19 208 48 49 51 19 3 51 19 51 17 51 17 51 19 51 3 19 35 3 35 17 35 17 35 3 10 200 194 95 166 82 83 83 165 95 193 199 92 166 91 83 90 167 1 101 1 43 254 237 1 19 254 237 1 19 254 213 254 155 1 53 254 203 1 53 254 203 0 0 1 0 42 255 244 2 2 2 156 0 47 0 77 0 184 0 0 69 88 184 0 31 47 27 185 0 31 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 18 0 1 0 15 0 4 43 184 0 0 16 185 0 7 0 2 244 184 0 31 16 185 0 24 0 2 244 186 0 40 0 15 0 18 17 18 57 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 38 43 1 53 51 50 54 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 1 22 72 114 50 47 43 88 57 32 56 42 25 92 85 74 54 87 76 73 55 46 78 30 45 35 106 60 46 77 55 30 50 48 57 75 37 64 86 12 45 51 57 44 36 17 33 48 31 63 60 64 57 56 52 53 33 28 56 35 43 23 43 63 39 52 79 17 4 11 83 68 47 74 51 26 0 1 0 90 0 0 2 54 2 144 0 19 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 6 0 1 0 0 17 18 57 184 0 1 16 184 0 9 208 184 0 0 16 184 0 12 208 186 0 16 0 9 0 12 17 18 57 48 49 51 17 51 17 20 6 7 51 55 19 51 17 35 17 52 54 55 35 7 3 90 82 7 3 4 71 241 88 82 7 3 4 71 241 2 144 254 173 52 107 50 134 1 158 253 112 1 87 52 103 50 134 254 98 0 0 0 255 255 0 90 0 0 2 54 3 73 2 38 3 146 0 0 0 7 7 48 1 76 0 4 0 1 0 90 0 0 2 66 2 156 0 28 0 87 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 3 0 1 0 27 0 4 43 184 0 10 16 184 0 1 208 184 0 1 47 184 0 10 16 185 0 17 0 2 244 186 0 23 0 3 0 27 17 18 57 184 0 0 16 184 0 25 208 48 49 51 17 51 17 51 55 62 3 51 50 22 23 7 46 1 35 34 14 2 15 1 19 35 3 35 17 90 83 113 92 21 34 35 36 22 9 19 8 14 6 13 5 11 18 19 22 15 87 226 91 202 112 2 144 254 235 167 37 48 27 10 3 3 78 2 2 6 18 32 27 155 254 162 1 55 254 201 0 0 0 1 0 90 255 244 2 73 2 156 0 42 0 101 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 17 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 41 47 27 185 0 41 0 5 62 89 187 0 13 0 1 0 6 0 4 43 184 0 19 16 185 0 25 0 2 244 184 0 0 16 185 0 37 0 2 244 48 49 5 34 46 2 47 1 35 17 35 17 51 17 51 55 62 3 51 50 23 7 46 1 35 34 14 2 15 1 23 30 3 51 50 54 55 23 6 2 31 20 34 33 34 21 113 115 83 83 113 92 21 34 33 35 20 26 15 14 6 13 5 11 18 19 22 15 87 110 15 22 19 18 11 5 13 6 14 15 12 9 26 46 38 204 254 201 2 144 254 235 167 37 48 27 10 6 78 2 2 6 18 32 27 156 198 27 32 18 6 2 2 78 6 0 1 0 90 0 0 2 58 2 144 0 12 0 13 0 187 0 4 0 1 0 10 0 4 43 48 49 51 17 51 17 51 19 51 3 19 35 3 35 17 90 83 92 202 96 230 237 94 201 102 2 144 254 237 1 19 254 213 254 155 1 53 254 203 0 1 0 0 255 244 2 28 2 144 0 26 0 65 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 6 0 2 244 184 0 0 16 184 0 17 208 184 0 17 47 184 0 14 16 185 0 18 0 2 244 48 49 23 34 38 39 55 22 51 50 62 2 55 62 1 55 33 17 35 17 35 14 1 7 14 3 56 16 26 14 17 15 13 13 23 23 21 12 20 36 19 1 72 83 180 16 29 17 14 31 38 46 12 4 5 77 6 11 37 70 58 103 200 109 253 112 2 74 91 172 88 75 96 55 21 255 255 0 90 0 0 2 125 2 144 2 6 0 14 0 0 255 255 0 90 0 0 2 50 2 144 2 6 0 9 0 0 255 255 0 52 255 244 2 101 2 156 2 6 0 16 0 0 255 255 0 90 0 0 2 43 2 144 2 6 2 78 0 0 255 255 0 90 0 0 2 11 2 144 2 6 0 17 0 0 255 255 0 52 255 244 2 27 2 156 2 6 0 4 0 0 255 255 0 28 0 0 1 252 2 144 2 6 0 21 0 0 0 1 0 5 255 244 2 2 2 144 0 22 0 71 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 2 244 186 0 16 0 0 0 12 17 18 57 184 0 16 16 185 0 11 0 2 244 184 0 12 16 184 0 18 208 48 49 23 34 38 39 55 30 1 51 50 54 63 1 3 51 19 23 51 55 19 51 3 14 1 136 22 29 14 17 8 20 14 32 39 14 14 224 89 122 50 4 46 113 85 215 25 75 12 5 5 75 3 4 25 28 35 1 246 254 220 129 129 1 36 253 231 61 70 0 3 0 47 255 244 2 173 2 156 0 6 0 13 0 31 0 89 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 17 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 187 0 4 0 2 0 21 0 4 43 187 0 15 0 2 0 3 0 4 43 184 0 4 16 184 0 10 208 184 0 3 16 184 0 11 208 184 0 21 16 184 0 24 208 184 0 15 16 184 0 30 208 48 49 19 20 22 23 17 14 1 5 52 38 39 17 62 1 1 53 46 1 53 52 54 55 53 51 21 30 1 21 20 6 7 21 127 104 98 98 104 1 222 104 98 98 104 254 236 134 148 148 134 74 134 148 148 134 1 75 85 97 3 1 109 3 92 85 85 92 3 254 147 3 97 254 254 94 5 128 116 115 125 4 93 93 4 125 115 116 128 5 94 255 255 0 15 0 0 1 242 2 144 2 6 0 25 0 0 0 1 0 90 255 68 2 104 2 144 0 12 0 65 0 125 184 0 11 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 4 0 2 244 184 0 1 16 184 0 5 208 184 0 4 16 184 0 8 208 48 49 51 17 51 17 33 17 51 17 51 21 7 35 53 90 83 1 31 83 73 9 73 2 144 253 183 2 73 253 183 50 209 188 0 0 1 0 67 0 0 1 252 2 144 0 23 0 55 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 5 62 89 187 0 17 0 2 0 4 0 4 43 184 0 10 16 184 0 21 208 48 49 33 17 14 1 35 34 46 2 61 1 51 21 20 30 2 51 50 54 55 17 51 17 1 169 24 57 39 56 88 61 33 82 21 42 61 40 37 55 20 83 1 38 5 5 22 51 82 59 158 158 41 56 34 14 5 5 1 37 253 112 0 0 0 0 1 0 90 0 0 3 7 2 144 0 11 0 71 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 185 0 3 0 2 244 184 0 1 16 184 0 5 208 184 0 3 16 184 0 7 208 184 0 8 208 184 0 5 16 184 0 9 208 48 49 51 17 51 17 51 17 51 17 51 17 51 17 90 82 220 81 220 82 2 144 253 183 2 73 253 183 2 73 253 112 0 0 1 0 90 255 68 3 80 2 144 0 16 0 81 0 125 184 0 0 47 24 184 0 0 69 88 184 0 3 47 27 185 0 3 0 17 62 89 184 0 0 69 88 184 0 2 47 27 185 0 2 0 5 62 89 185 0 5 0 2 244 184 0 3 16 184 0 7 208 184 0 5 16 184 0 9 208 184 0 7 16 184 0 11 208 184 0 9 16 184 0 14 208 48 49 5 53 33 17 51 17 51 17 51 17 51 17 51 17 51 21 7 2 254 253 92 82 220 81 220 82 73 9 188 188 2 144 253 183 2 73 253 183 2 73 253 183 50 209 0 0 2 0 28 0 0 2 164 2 144 0 16 0 25 0 67 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 17 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 5 62 89 187 0 6 0 2 0 24 0 4 43 184 0 3 16 185 0 1 0 2 244 184 0 16 16 185 0 18 0 2 244 48 49 51 17 35 53 33 17 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 238 210 1 38 108 52 90 66 38 34 63 89 54 114 104 83 85 89 86 97 2 74 70 254 243 22 45 70 48 53 76 49 24 68 62 70 60 60 0 0 0 0 3 0 90 0 0 2 196 2 144 0 14 0 23 0 27 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 187 0 4 0 2 0 22 0 4 43 184 0 14 16 185 0 16 0 2 244 184 0 14 16 184 0 24 208 184 0 1 16 184 0 25 208 48 49 51 17 51 17 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 1 17 51 17 90 83 102 54 89 64 35 34 63 89 55 103 93 83 86 86 86 90 1 196 83 2 144 254 243 21 45 70 49 53 76 49 24 68 62 70 63 57 254 192 2 144 253 112 0 0 0 0 2 0 90 0 0 2 24 2 144 0 14 0 23 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 187 0 4 0 2 0 22 0 4 43 184 0 14 16 185 0 16 0 2 244 48 49 51 17 51 17 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 90 83 121 54 89 64 35 34 63 89 55 122 111 84 86 86 86 109 2 144 254 243 21 45 70 49 53 76 49 24 68 62 70 63 57 0 0 0 1 0 32 255 244 2 7 2 156 0 32 0 73 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 2 244 186 0 11 0 23 0 0 17 18 57 184 0 11 47 185 0 13 0 1 244 184 0 23 16 185 0 16 0 2 244 48 49 23 34 38 39 55 30 1 51 50 54 55 33 53 33 46 1 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 243 67 102 42 46 33 79 51 87 102 5 254 237 1 18 9 99 86 44 74 29 46 32 103 61 62 102 72 40 41 74 101 12 50 45 52 35 39 123 125 71 105 110 33 29 54 32 49 44 86 127 83 84 127 85 44 0 0 0 2 0 90 255 244 3 88 2 156 0 26 0 46 0 101 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 17 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 17 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 12 0 1 0 5 0 4 43 184 0 0 16 185 0 27 0 2 244 184 0 17 16 185 0 37 0 2 244 48 49 5 34 46 2 39 35 17 35 17 51 17 51 62 3 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 2 74 58 96 69 41 3 146 83 83 148 6 43 68 92 56 60 100 71 39 39 71 100 60 43 68 48 25 25 48 68 43 42 68 48 25 25 48 68 12 45 83 119 74 254 203 2 144 254 237 67 107 74 39 47 87 125 78 79 127 89 48 73 38 71 99 62 61 98 68 37 37 68 98 61 62 99 71 38 0 0 0 2 0 22 0 0 1 236 2 144 0 15 0 24 0 84 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 17 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 5 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 187 0 17 0 1 0 1 0 4 43 186 0 5 0 1 0 17 17 18 57 184 0 14 16 185 0 18 0 2 244 48 49 33 17 35 3 35 19 46 1 53 52 62 2 59 1 17 3 51 53 35 34 6 21 20 22 1 153 121 170 96 183 65 83 34 61 85 50 205 193 110 110 77 82 82 1 21 254 235 1 30 17 90 79 51 70 44 19 253 112 1 89 244 52 65 64 63 0 0 0 255 255 0 90 0 0 1 222 3 99 2 38 0 6 0 0 0 7 7 32 1 28 0 0 255 255 0 90 0 0 1 222 3 45 2 38 0 6 0 0 0 7 7 52 1 28 0 0 0 1 0 28 255 244 2 126 2 144 0 39 0 83 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 15 0 1 0 30 0 4 43 184 0 0 16 185 0 7 0 2 244 184 0 0 16 184 0 20 208 184 0 20 47 184 0 23 16 185 0 22 0 2 244 184 0 25 208 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 17 35 17 35 53 33 21 35 21 62 1 51 50 30 2 21 20 14 2 1 202 17 36 11 15 7 22 10 18 38 31 20 84 77 29 54 21 84 178 1 235 229 24 57 34 50 85 63 35 30 51 65 12 6 4 67 3 5 14 31 51 38 74 67 5 5 254 190 2 74 70 70 195 5 5 24 50 80 55 57 78 48 21 0 0 255 255 0 90 0 0 1 212 3 99 2 38 2 65 0 0 0 7 7 35 1 34 0 0 0 1 0 52 255 244 2 27 2 156 0 32 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 17 0 2 244 186 0 22 0 10 0 0 17 18 57 184 0 22 47 185 0 21 0 1 244 184 0 0 16 185 0 26 0 2 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 7 33 21 33 30 1 51 50 54 55 23 14 1 1 82 63 105 76 42 43 77 106 64 60 92 29 45 26 67 42 88 108 11 1 19 254 236 5 107 94 48 72 32 46 39 98 12 44 85 127 84 83 127 86 44 49 32 54 28 34 110 105 71 125 123 39 35 52 45 50 0 255 255 0 42 255 244 1 239 2 156 2 6 0 20 0 0 255 255 0 90 0 0 0 173 2 144 2 6 0 10 0 0 255 255 255 235 0 0 1 27 3 45 2 38 0 10 0 0 0 7 7 52 0 131 0 0 0 3 0 18 0 0 0 245 3 45 0 11 0 23 0 27 0 65 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 17 62 89 184 0 0 69 88 184 0 27 47 27 185 0 27 0 5 62 89 184 0 25 16 184 0 0 220 184 0 6 220 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 3 17 51 17 63 20 25 25 20 20 25 25 117 20 25 25 20 20 25 25 130 83 2 203 28 21 22 27 27 22 21 28 28 21 22 27 27 22 21 28 253 53 2 144 253 112 0 0 0 255 255 0 31 255 244 1 137 2 144 2 6 0 11 0 0 0 2 0 6 255 244 3 91 2 144 0 37 0 46 0 89 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 16 0 2 0 46 0 4 43 184 0 0 16 185 0 6 0 2 244 184 0 0 16 184 0 28 208 184 0 28 47 184 0 14 16 185 0 29 0 2 244 184 0 28 16 185 0 39 0 2 244 48 49 23 34 38 39 55 22 51 50 62 2 55 62 1 55 33 17 51 50 30 2 21 20 14 2 43 1 17 35 14 1 7 14 3 37 51 50 54 53 52 38 43 1 62 16 26 14 17 13 15 13 23 22 22 12 20 36 19 1 52 91 54 89 64 35 34 63 89 55 175 160 16 29 16 14 32 38 46 1 178 81 84 86 86 86 79 12 4 5 77 6 11 37 70 58 103 200 109 254 243 21 45 70 49 53 76 49 24 2 74 91 173 88 75 96 55 20 80 62 70 63 57 0 0 0 2 0 90 0 0 3 117 2 144 0 22 0 31 0 103 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 21 0 1 0 0 17 18 57 184 0 21 47 185 0 3 0 1 244 184 0 1 16 184 0 5 208 184 0 3 16 184 0 7 208 184 0 7 47 184 0 0 16 184 0 19 208 185 0 24 0 2 244 184 0 21 16 184 0 31 208 184 0 31 47 48 49 51 17 51 17 33 17 51 17 51 50 30 2 21 20 14 2 43 1 17 33 17 37 51 50 54 53 52 38 43 1 90 83 1 39 84 91 54 89 64 35 34 63 89 55 176 254 217 1 123 81 84 86 86 86 79 2 144 254 237 1 19 254 243 21 45 70 49 53 76 49 24 1 53 254 203 68 62 70 63 57 0 0 1 0 28 0 0 2 117 2 144 0 25 0 69 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 21 0 1 0 10 0 4 43 184 0 3 16 185 0 2 0 2 244 184 0 5 208 184 0 0 16 184 0 17 208 48 49 51 17 35 53 33 21 35 21 62 1 51 50 30 2 29 1 35 53 52 38 35 34 6 7 17 206 178 1 235 229 24 58 29 53 85 59 31 82 76 78 26 56 21 2 74 70 70 195 5 5 23 50 78 55 195 195 74 63 5 5 254 190 0 0 0 255 255 0 90 0 0 2 66 3 103 2 38 3 148 0 0 0 7 7 35 1 68 0 4 0 2 0 90 255 244 2 73 3 103 0 42 0 46 0 101 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 17 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 41 47 27 185 0 41 0 5 62 89 187 0 13 0 1 0 6 0 4 43 184 0 19 16 185 0 25 0 2 244 184 0 0 16 185 0 37 0 2 244 48 49 5 34 46 2 47 1 35 17 35 17 51 17 51 55 62 3 51 50 23 7 46 1 35 34 14 2 15 1 23 30 3 51 50 54 55 23 6 1 39 55 23 2 31 20 34 33 34 21 113 115 83 83 113 92 21 34 33 35 20 26 15 14 6 13 5 11 18 19 22 15 87 110 15 22 19 18 11 5 13 6 14 15 254 247 37 142 47 12 9 26 46 38 204 254 201 2 144 254 235 167 37 48 27 10 6 78 2 2 6 18 32 27 156 198 27 32 18 6 2 2 78 6 2 201 42 128 55 0 2 0 90 0 0 2 58 3 103 0 12 0 16 0 13 0 187 0 4 0 1 0 10 0 4 43 48 49 51 17 51 17 51 19 51 3 19 35 3 35 17 19 39 55 23 90 83 92 202 96 230 237 94 201 102 132 37 142 47 2 144 254 237 1 19 254 213 254 155 1 53 254 203 2 189 42 128 55 0 255 255 0 90 0 0 2 54 3 103 2 38 3 146 0 0 0 7 7 32 1 76 0 4 255 255 0 5 255 244 2 2 3 69 2 38 3 159 0 0 0 7 7 48 1 1 0 0 0 1 0 90 255 68 2 43 2 144 0 11 0 65 0 125 184 0 10 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 185 0 4 0 2 244 184 0 1 16 184 0 5 208 184 0 11 16 184 0 7 208 48 49 51 17 51 17 33 17 51 17 35 7 35 53 90 83 1 43 83 187 8 73 2 144 253 183 2 73 253 112 188 188 0 0 0 0 2 0 28 0 0 2 58 2 188 0 22 0 31 0 66 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 2 0 1 0 3 0 4 43 187 0 11 0 1 0 31 0 4 43 184 0 3 16 184 0 8 208 184 0 2 16 184 0 9 208 184 0 0 16 185 0 24 0 2 244 48 49 51 17 35 53 51 53 51 21 51 21 35 21 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 166 138 138 84 234 234 78 54 89 64 35 33 61 87 55 84 74 83 81 83 88 67 1 251 68 125 125 68 136 19 41 66 47 53 75 48 22 66 59 69 62 53 0 0 0 3 0 52 255 244 2 101 2 156 0 19 0 26 0 33 0 67 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 23 0 1 0 31 0 4 43 184 0 10 16 185 0 20 0 2 244 184 0 0 16 185 0 27 0 2 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 3 34 6 7 33 46 1 3 50 54 55 33 30 1 1 76 62 103 74 41 41 74 103 62 62 103 75 41 41 75 103 62 82 104 10 1 136 10 104 82 87 106 5 254 116 5 106 12 46 87 128 82 82 125 86 44 44 86 126 81 82 128 87 46 2 98 113 106 106 113 253 228 130 123 123 130 0 0 0 0 1 0 0 0 0 2 49 2 156 0 27 0 69 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 16 16 184 0 1 208 184 0 1 47 186 0 6 0 1 0 0 17 18 57 184 0 16 16 185 0 23 0 2 244 48 49 51 3 51 19 30 1 23 51 62 3 63 1 62 1 51 50 22 23 7 46 1 35 34 6 7 3 210 210 89 105 17 28 19 4 8 13 14 14 8 64 20 57 53 15 21 12 17 5 13 8 22 26 11 147 2 144 254 158 59 100 58 29 53 52 54 29 227 73 66 4 5 77 2 4 37 37 253 254 0 0 0 0 1 0 90 0 0 1 221 3 60 0 7 0 53 0 124 184 0 4 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 184 0 1 16 185 0 5 0 2 244 48 49 51 17 33 55 51 7 33 17 90 1 45 15 71 9 254 217 2 144 172 242 253 182 0 0 0 0 1 0 33 0 0 1 234 2 144 0 13 0 83 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 17 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 186 0 9 0 3 0 11 17 18 57 184 0 9 47 185 0 8 0 1 244 184 0 1 208 184 0 1 47 184 0 3 16 185 0 6 0 2 244 184 0 9 16 184 0 13 208 48 49 19 53 55 17 33 21 33 21 51 21 35 17 35 17 33 79 1 122 254 217 149 149 83 1 51 44 3 1 46 70 232 47 254 205 1 51 0 0 0 0 1 0 6 255 68 3 53 2 156 0 58 0 149 0 125 184 0 0 47 24 184 0 0 69 88 184 0 24 47 27 185 0 24 0 17 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 187 0 30 0 1 0 8 0 4 43 184 0 10 16 184 0 6 208 184 0 2 208 184 0 8 16 184 0 3 208 186 0 11 0 30 0 8 17 18 57 184 0 24 16 185 0 17 0 2 244 184 0 24 16 184 0 32 208 184 0 32 47 184 0 30 16 184 0 35 208 184 0 24 16 184 0 41 208 184 0 17 16 184 0 48 208 186 0 54 0 3 0 35 17 18 57 184 0 2 16 185 0 56 0 2 244 48 49 5 53 35 3 35 17 35 17 35 3 35 19 39 46 3 35 34 6 7 39 62 1 51 50 30 2 31 1 51 17 51 17 51 55 62 3 51 50 22 23 7 46 1 35 34 14 2 15 1 19 51 21 7 2 227 32 170 95 79 95 170 92 200 69 13 22 20 20 11 5 13 6 14 8 19 9 22 38 36 34 18 77 89 79 88 78 18 34 36 38 22 9 19 8 14 7 12 5 11 20 20 22 13 69 159 63 9 188 188 1 55 254 201 1 55 254 201 1 94 155 27 33 18 5 2 2 78 3 3 10 27 48 37 167 1 21 254 235 167 37 48 27 10 3 3 78 2 2 5 18 33 27 155 254 233 50 209 0 1 255 250 255 64 3 58 2 156 0 83 1 7 0 184 0 0 69 88 184 0 42 47 27 185 0 42 0 17 62 89 184 0 0 69 88 184 0 44 47 27 185 0 44 0 17 62 89 184 0 0 69 88 184 0 61 47 27 185 0 61 0 17 62 89 184 0 0 69 88 184 0 63 47 27 185 0 63 0 17 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 0 69 88 184 0 20 47 27 185 0 20 0 5 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 5 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 187 0 55 0 1 0 9 0 4 43 184 0 9 16 184 0 13 208 184 0 20 16 185 0 26 0 2 244 184 0 44 16 185 0 38 0 2 244 184 0 55 16 184 0 50 208 184 0 38 16 184 0 67 208 184 0 26 16 184 0 77 208 184 0 77 47 184 0 78 208 184 0 78 47 184 0 80 208 184 0 80 47 184 0 81 208 184 0 81 47 48 49 5 53 38 39 35 53 46 1 47 1 35 17 35 17 35 7 14 3 35 34 39 55 30 1 51 50 62 2 63 1 39 46 3 35 34 6 7 39 54 51 50 30 2 31 1 51 17 51 17 51 55 62 3 51 50 23 7 46 1 35 34 14 2 15 1 23 30 1 23 51 55 21 51 21 7 2 234 12 12 4 19 37 23 92 102 78 102 91 19 33 32 34 20 27 15 15 6 12 5 11 18 18 20 14 87 63 12 20 20 19 11 5 13 6 14 15 25 21 36 34 32 17 67 103 78 104 67 17 32 34 36 20 26 15 14 7 12 5 11 20 19 21 11 63 86 21 27 14 39 4 22 10 192 183 3 6 2 12 48 45 204 254 201 1 55 204 38 46 26 9 6 78 2 2 6 18 32 27 194 160 26 32 18 7 2 2 78 6 10 27 48 37 167 1 21 254 235 167 37 48 27 10 6 78 2 2 7 18 32 26 161 193 40 35 5 1 1 55 208 0 1 0 14 255 64 3 58 2 144 0 26 0 90 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 187 0 19 0 1 0 3 0 4 43 184 0 3 16 184 0 7 208 184 0 19 16 184 0 14 208 184 0 1 16 185 0 23 0 1 244 48 49 5 53 35 3 35 17 35 17 35 3 35 19 3 51 19 51 17 51 17 51 19 51 3 19 51 21 7 2 234 43 166 91 83 90 167 92 200 194 95 166 82 83 83 165 95 193 159 71 10 192 192 1 53 254 203 1 53 254 203 1 101 1 43 254 237 1 19 254 237 1 19 254 213 254 226 55 208 0 0 0 0 1 0 42 255 68 2 2 2 156 0 50 0 91 0 125 184 0 0 47 24 184 0 0 69 88 184 0 32 47 27 185 0 32 0 17 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 187 0 18 0 1 0 17 0 4 43 184 0 1 16 185 0 8 0 2 244 184 0 32 16 185 0 25 0 2 244 186 0 41 0 17 0 18 17 18 57 184 0 1 16 184 0 49 208 48 49 23 53 46 1 39 55 30 1 51 50 62 2 53 52 38 43 1 53 51 50 54 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 15 1 241 59 97 43 47 43 88 57 32 56 42 25 92 85 74 54 87 76 73 55 46 78 30 45 35 106 60 46 77 55 30 50 48 57 75 29 51 71 41 8 188 178 5 44 45 57 44 36 17 33 48 31 63 60 64 57 56 52 53 33 28 56 35 43 23 43 63 39 52 79 17 4 11 83 68 42 68 49 31 5 179 0 0 0 1 0 90 255 68 2 90 2 156 0 33 0 103 0 125 184 0 0 47 24 184 0 0 69 88 184 0 16 47 27 185 0 16 0 17 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 187 0 9 0 1 0 4 0 4 43 184 0 6 16 184 0 2 208 184 0 16 16 184 0 7 208 184 0 7 47 184 0 16 16 185 0 23 0 2 244 186 0 29 0 9 0 4 17 18 57 184 0 2 16 185 0 31 0 2 244 48 49 5 53 35 3 35 17 35 17 51 17 51 55 62 3 51 50 22 23 7 46 1 35 34 14 2 15 1 19 51 21 7 2 8 33 202 112 83 83 113 92 21 34 35 36 22 9 19 8 14 6 13 5 11 18 19 22 15 87 180 70 9 188 188 1 55 254 201 2 144 254 235 167 37 48 27 10 3 3 78 2 2 6 18 32 27 155 254 233 50 209 0 0 1 0 90 255 64 2 85 2 156 0 42 0 73 0 184 0 0 69 88 184 0 20 47 27 185 0 20 0 17 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 17 62 89 186 0 36 0 0 0 3 43 187 0 14 0 1 0 7 0 4 43 184 0 20 16 185 0 26 0 2 244 184 0 36 16 184 0 39 208 48 49 5 53 46 3 47 1 35 17 35 17 51 17 51 55 62 3 51 50 23 7 46 1 35 34 14 2 15 1 23 30 1 23 51 55 21 51 21 7 2 4 15 27 27 29 17 113 115 83 83 113 92 21 34 33 35 20 26 15 14 6 13 5 11 18 19 22 15 87 110 22 29 14 40 4 26 11 192 182 3 14 27 42 31 204 254 201 2 144 254 235 167 37 48 27 10 6 78 2 2 6 18 32 27 156 198 40 35 5 1 1 55 208 0 0 1 0 90 255 64 2 85 2 144 0 17 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 187 0 10 0 1 0 3 0 4 43 184 0 1 16 185 0 14 0 1 244 48 49 5 53 35 3 35 17 35 17 51 17 51 19 51 3 19 51 21 7 2 4 40 201 102 83 83 92 202 96 230 190 74 11 192 192 1 53 254 203 2 144 254 237 1 19 254 213 254 226 55 208 0 0 0 0 1 0 28 0 0 2 202 2 156 0 30 0 112 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 17 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 17 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 26 47 27 185 0 26 0 5 62 89 187 0 6 0 1 0 28 0 4 43 184 0 3 16 185 0 1 0 2 244 184 0 19 208 48 49 51 17 35 53 33 17 51 55 62 3 51 50 22 23 7 46 1 35 34 14 2 15 1 19 35 3 35 17 226 198 1 26 113 92 20 35 34 37 22 9 19 8 14 7 12 5 11 18 20 22 15 86 225 90 202 112 2 74 70 254 235 167 37 48 27 10 3 3 78 2 2 6 18 32 27 155 254 162 1 55 254 201 0 1 0 28 255 244 2 210 2 156 0 45 0 122 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 17 62 89 184 0 0 69 88 184 0 24 47 27 185 0 24 0 17 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 44 47 27 185 0 44 0 5 62 89 187 0 16 0 1 0 6 0 4 43 184 0 22 16 185 0 11 0 2 244 184 0 28 208 184 0 0 16 185 0 40 0 2 244 48 49 5 34 46 2 47 1 35 17 35 17 7 35 53 33 17 51 55 62 3 51 50 23 7 46 1 35 34 14 2 15 1 23 30 3 51 50 54 55 23 6 2 168 20 34 33 34 21 113 115 83 1 198 1 26 113 92 21 34 33 35 20 26 15 14 6 13 5 11 18 19 22 15 87 110 15 22 19 18 11 5 13 6 14 15 12 9 26 46 38 204 254 201 2 75 1 70 254 235 167 37 48 27 10 6 78 2 2 6 18 32 27 156 198 27 32 18 6 2 2 78 6 0 0 0 0 1 0 28 0 0 2 195 2 144 0 15 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 17 62 89 187 0 4 0 1 0 10 0 4 43 184 0 1 16 185 0 0 0 1 244 48 49 19 53 33 17 51 19 51 3 19 35 3 35 17 35 17 7 28 1 26 92 202 96 230 237 94 201 102 83 1 2 74 70 254 237 1 19 254 213 254 155 1 53 254 203 2 75 1 0 0 0 1 0 90 255 68 2 123 2 144 0 16 0 85 0 125 184 0 0 47 24 184 0 0 69 88 184 0 7 47 27 185 0 7 0 17 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 184 0 2 208 186 0 4 0 7 0 6 17 18 57 184 0 4 47 185 0 10 0 1 244 184 0 7 16 184 0 11 208 184 0 2 16 185 0 14 0 2 244 48 49 5 53 35 17 33 17 35 17 51 17 33 17 51 17 51 21 7 2 41 75 254 207 83 83 1 49 84 73 9 188 188 1 53 254 203 2 144 254 237 1 19 253 183 50 209 0 1 0 52 255 68 2 27 2 156 0 36 0 71 0 125 184 0 0 47 24 184 0 0 69 88 184 0 11 47 27 185 0 11 0 17 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 11 16 185 0 18 0 2 244 184 0 1 16 185 0 28 0 2 244 184 0 1 16 184 0 35 208 48 49 5 53 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 23 14 1 15 1 1 43 54 91 65 37 44 78 106 63 60 91 29 45 26 66 42 47 76 54 29 29 52 75 47 48 72 32 46 32 78 49 8 188 178 7 52 86 119 74 79 126 88 47 49 32 54 28 34 37 69 98 61 62 99 70 38 39 35 52 38 46 8 179 0 0 0 255 255 255 255 0 0 1 221 2 144 2 6 0 26 0 0 0 1 255 255 0 0 1 221 2 144 0 22 0 91 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 17 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 5 62 89 186 0 3 0 4 0 21 17 18 57 184 0 3 47 184 0 4 16 184 0 14 208 186 0 9 0 14 0 21 17 18 57 184 0 3 16 184 0 17 208 184 0 3 16 185 0 22 0 1 244 184 0 18 208 48 49 55 53 55 51 3 51 23 30 1 23 51 62 1 63 1 51 3 51 21 35 21 35 53 57 88 33 179 89 85 16 30 17 4 17 34 15 84 87 179 121 139 84 243 44 3 1 110 185 36 70 37 37 70 36 185 254 146 47 243 243 0 0 0 0 1 0 15 255 68 2 14 2 144 0 30 0 105 0 125 184 0 0 47 24 184 0 0 69 88 184 0 14 47 27 185 0 14 0 17 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 184 0 2 208 186 0 7 0 14 0 12 17 18 57 186 0 13 0 19 0 6 17 18 57 184 0 14 16 184 0 24 208 186 0 20 0 2 0 24 17 18 57 186 0 26 0 6 0 20 17 18 57 184 0 2 16 185 0 28 0 2 244 48 49 5 53 35 39 46 1 39 35 14 1 15 1 35 19 3 51 23 30 1 23 51 62 1 63 1 51 3 19 51 21 7 1 189 39 96 13 27 16 4 14 26 12 95 88 191 178 92 89 13 23 15 4 14 21 12 87 88 179 151 68 9 188 188 177 24 51 30 30 51 24 177 1 83 1 61 168 23 43 29 29 43 23 168 254 191 254 248 50 209 0 1 0 67 255 68 2 69 2 144 0 28 0 71 0 125 184 0 0 47 24 184 0 0 69 88 184 0 12 47 27 185 0 12 0 17 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 187 0 19 0 2 0 6 0 4 43 184 0 12 16 184 0 23 208 184 0 1 16 185 0 26 0 2 244 48 49 5 53 35 17 14 1 35 34 46 2 61 1 51 21 20 30 2 51 50 54 55 17 51 17 51 21 7 1 245 76 24 57 39 56 88 61 33 82 21 42 61 40 37 55 20 83 73 9 188 188 1 38 5 5 22 51 82 59 158 158 41 56 34 14 5 5 1 37 253 183 50 209 0 0 0 0 1 0 90 0 0 2 19 2 144 0 23 0 55 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 5 62 89 187 0 6 0 2 0 19 0 4 43 184 0 23 16 184 0 12 208 48 49 51 17 51 17 62 1 51 50 30 2 29 1 35 53 52 46 2 35 34 6 7 17 90 83 24 57 38 56 89 61 33 82 21 42 62 40 36 55 20 2 144 254 254 4 6 22 51 82 59 194 194 41 56 34 14 6 4 254 183 255 255 0 90 0 0 0 173 2 144 2 6 0 10 0 0 255 255 0 6 0 0 3 30 3 69 2 38 3 142 0 0 0 7 7 48 1 145 0 0 0 2 255 246 255 244 3 46 3 69 0 81 0 101 0 211 0 184 0 0 69 88 184 0 39 47 27 185 0 39 0 17 62 89 184 0 0 69 88 184 0 41 47 27 185 0 41 0 17 62 89 184 0 0 69 88 184 0 58 47 27 185 0 58 0 17 62 89 184 0 0 69 88 184 0 60 47 27 185 0 60 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 5 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 184 0 0 69 88 184 0 80 47 27 185 0 80 0 5 62 89 187 0 91 0 1 0 82 0 4 43 187 0 52 0 1 0 6 0 4 43 184 0 6 16 184 0 10 208 184 0 17 16 185 0 23 0 2 244 184 0 41 16 185 0 35 0 2 244 184 0 52 16 184 0 47 208 184 0 35 16 184 0 64 208 184 0 23 16 184 0 76 208 48 49 5 34 46 2 47 1 35 17 35 17 35 7 14 3 35 34 39 55 30 1 51 50 62 2 63 1 39 46 3 35 34 6 7 39 54 51 50 30 2 31 1 51 17 51 17 51 55 62 3 51 50 23 7 46 1 35 34 14 2 15 1 23 30 3 51 50 54 55 23 6 1 34 46 2 39 51 30 1 51 50 62 2 55 51 14 3 3 5 20 34 32 33 19 92 102 78 102 91 19 33 32 34 20 27 15 15 6 12 5 11 18 18 20 14 87 63 12 20 20 19 11 5 13 6 14 15 25 21 36 34 32 17 67 103 78 104 67 17 32 34 36 20 26 15 14 7 12 5 11 20 19 21 11 63 86 14 21 18 18 11 5 12 6 14 14 254 113 42 56 35 17 1 72 1 36 42 21 29 19 9 1 72 2 16 35 56 12 9 26 46 38 204 254 201 1 55 204 38 46 26 9 6 78 2 2 6 18 32 27 194 160 26 32 18 7 2 2 78 6 10 27 48 37 167 1 21 254 235 167 37 48 27 10 6 78 2 2 7 18 32 26 161 193 27 32 18 6 2 2 78 6 2 205 22 37 48 25 35 51 14 23 31 18 25 48 37 22 0 0 0 2 0 10 0 0 3 23 3 69 0 21 0 41 0 39 0 187 0 31 0 1 0 22 0 4 43 187 0 9 0 1 0 15 0 4 43 184 0 9 16 184 0 4 208 184 0 15 16 184 0 19 208 48 49 51 19 3 51 19 51 17 51 17 51 19 51 3 19 35 3 35 17 35 17 35 3 1 34 46 2 39 51 30 1 51 50 62 2 55 51 14 3 10 200 194 95 166 82 83 83 165 95 193 199 92 166 91 83 90 167 1 43 42 56 35 17 1 72 1 36 42 21 29 19 9 1 72 2 16 35 56 1 101 1 43 254 237 1 19 254 237 1 19 254 213 254 155 1 53 254 203 1 53 254 203 2 193 22 37 48 25 35 51 14 23 31 18 25 48 37 22 255 255 0 3 0 0 2 29 3 69 2 38 0 2 0 0 0 7 7 48 1 16 0 0 255 255 0 8 0 0 3 5 2 144 2 6 0 76 0 0 255 255 0 90 0 0 1 222 3 69 2 38 0 6 0 0 0 7 7 48 1 28 0 0 255 255 0 58 255 244 2 94 2 156 2 6 0 245 0 0 255 255 0 90 0 0 2 54 3 28 2 38 3 146 0 0 0 7 7 42 1 76 0 4 255 255 0 52 255 244 2 101 3 45 2 38 0 16 0 0 0 7 7 52 1 76 0 0 255 255 0 52 255 244 2 101 2 156 2 6 3 192 0 0 255 255 0 5 255 244 2 2 3 24 2 38 3 159 0 0 0 7 7 42 0 252 0 0 255 255 0 5 255 244 2 2 3 108 2 38 3 159 0 0 0 7 7 58 0 252 0 0 255 255 0 52 255 244 1 177 1 242 2 6 0 28 0 0 0 2 0 53 255 244 1 240 2 218 0 34 0 49 0 91 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 25 0 1 0 43 0 4 43 184 0 8 16 185 0 17 0 2 244 186 0 22 0 8 0 0 17 18 57 184 0 22 47 184 0 0 16 185 0 35 0 1 244 184 0 22 16 185 0 46 0 1 244 48 49 5 34 38 53 52 62 2 55 62 3 55 23 14 1 7 14 3 7 62 1 51 50 30 2 21 20 14 2 39 50 62 2 53 52 38 35 34 6 7 21 20 22 1 26 109 120 43 80 113 69 20 28 23 19 11 16 20 49 31 59 85 57 32 6 32 87 46 43 72 51 29 34 58 78 44 28 47 35 19 68 63 35 76 37 75 12 159 148 123 150 87 37 11 3 5 6 8 5 75 13 13 5 9 20 47 86 75 40 41 31 59 84 53 58 94 66 35 68 27 49 68 41 75 89 38 50 38 106 117 0 3 0 82 0 0 1 213 1 230 0 21 0 30 0 39 0 77 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 5 62 89 187 0 23 0 1 0 38 0 4 43 186 0 11 0 38 0 23 17 18 57 184 0 1 16 185 0 29 0 1 244 184 0 21 16 185 0 32 0 1 244 48 49 51 17 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 35 3 51 50 54 53 52 38 43 1 17 51 50 54 53 52 38 43 1 82 187 40 66 47 26 43 38 21 37 28 16 29 51 70 42 114 92 61 52 50 57 98 105 60 59 62 62 100 1 230 14 29 47 33 41 52 11 3 5 18 28 40 26 36 52 35 16 1 26 39 34 34 38 254 144 44 41 37 42 0 0 1 0 82 0 0 1 129 1 230 0 5 0 47 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 1 16 185 0 3 0 1 244 48 49 51 17 33 21 35 17 82 1 47 221 1 230 67 254 93 0 2 0 19 255 84 1 254 1 230 0 18 0 25 0 75 0 125 184 0 2 47 24 184 0 0 69 88 184 0 11 47 27 185 0 11 0 9 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 5 62 89 185 0 4 0 1 244 184 0 23 208 184 0 14 208 184 0 2 16 184 0 17 208 184 0 11 16 185 0 24 0 1 244 48 49 51 21 35 39 53 51 62 3 63 1 33 17 51 21 7 35 53 39 14 1 7 51 17 35 99 71 9 24 10 19 16 16 7 26 1 46 71 8 71 248 8 27 17 226 155 172 187 52 6 21 44 74 59 215 254 93 52 187 172 255 72 90 26 1 96 255 255 0 46 255 244 1 202 1 242 2 6 0 32 0 0 0 1 0 13 0 0 2 156 1 242 0 43 0 127 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 42 0 1 0 15 0 4 43 186 0 1 0 15 0 42 17 18 57 184 0 11 16 185 0 5 0 2 244 184 0 11 16 184 0 24 208 184 0 17 208 184 0 15 16 184 0 20 208 184 0 24 16 185 0 30 0 2 244 184 0 42 16 184 0 37 208 186 0 34 0 37 0 20 17 18 57 184 0 0 16 184 0 40 208 184 0 36 208 48 49 51 19 39 46 1 35 42 1 7 39 54 51 50 22 31 1 51 53 51 21 51 55 62 1 51 50 23 7 38 34 35 34 6 15 1 19 35 39 35 21 35 53 35 7 13 153 39 17 33 20 5 6 5 15 13 16 40 62 26 46 75 73 75 46 26 62 40 16 12 14 5 6 5 20 34 17 38 153 89 122 80 73 80 122 1 0 96 42 24 2 77 5 43 61 108 200 200 108 61 43 5 77 2 24 42 96 255 0 219 219 219 219 0 0 0 0 1 0 1 255 244 2 168 1 242 0 76 0 201 0 184 0 0 69 88 184 0 36 47 27 185 0 36 0 9 62 89 184 0 0 69 88 184 0 38 47 27 185 0 38 0 9 62 89 184 0 0 69 88 184 0 55 47 27 185 0 55 0 9 62 89 184 0 0 69 88 184 0 57 47 27 185 0 57 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 5 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 184 0 0 69 88 184 0 75 47 27 185 0 75 0 5 62 89 187 0 49 0 1 0 6 0 4 43 184 0 6 16 184 0 10 208 184 0 17 16 185 0 22 0 2 244 184 0 38 16 185 0 32 0 2 244 184 0 49 16 184 0 44 208 184 0 32 16 184 0 61 208 184 0 22 16 184 0 71 208 48 49 5 34 46 2 47 1 35 21 35 53 35 7 14 3 35 34 39 55 22 51 50 54 63 1 39 46 3 35 42 1 7 39 54 51 50 30 2 31 1 51 53 51 21 51 55 62 3 51 50 23 7 38 34 35 34 14 2 15 1 23 30 1 51 50 54 55 23 6 2 139 19 33 32 31 16 67 76 73 76 68 16 31 31 33 19 16 13 14 9 8 17 31 23 65 41 9 18 16 18 9 5 7 5 14 12 17 19 35 31 28 14 48 74 73 74 48 14 28 31 34 20 16 13 15 5 6 5 9 18 16 18 9 41 65 22 32 17 5 6 5 15 13 12 9 23 40 32 127 219 219 127 32 40 23 9 5 78 3 25 42 120 97 21 26 14 5 2 77 5 9 23 40 32 108 200 200 108 32 40 23 9 5 77 2 5 14 26 21 97 120 42 25 1 2 78 5 0 0 1 0 13 0 0 2 157 1 230 0 21 0 29 0 187 0 9 0 1 0 15 0 4 43 184 0 9 16 184 0 4 208 184 0 15 16 184 0 19 208 48 49 51 19 39 51 23 51 53 51 21 51 55 51 7 19 35 39 35 21 35 53 35 7 13 167 155 94 126 58 76 58 126 94 155 167 93 132 65 76 65 132 1 4 226 198 198 198 198 226 254 252 216 216 216 216 0 0 0 0 1 0 37 255 244 1 161 1 242 0 47 0 77 0 184 0 0 69 88 184 0 31 47 27 185 0 31 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 18 0 1 0 15 0 4 43 184 0 0 16 185 0 7 0 1 244 184 0 31 16 185 0 24 0 1 244 186 0 40 0 15 0 18 17 18 57 48 49 23 34 38 39 55 30 1 51 50 62 2 53 52 38 43 1 53 51 50 54 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 221 51 90 43 35 34 71 37 25 44 33 19 64 60 67 55 59 58 56 45 42 61 29 35 35 83 53 36 64 48 29 42 38 42 59 32 54 71 12 27 35 53 28 21 12 22 33 20 42 40 59 41 36 37 37 22 21 54 25 29 16 32 50 33 35 58 15 4 11 57 53 34 54 38 20 0 0 1 0 82 0 0 1 227 1 230 0 23 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 6 0 1 0 0 17 18 57 184 0 1 16 184 0 11 208 184 0 0 16 184 0 14 208 186 0 18 0 14 0 11 17 18 57 48 49 51 17 51 21 20 6 7 51 62 1 55 19 51 17 35 53 52 54 55 35 14 1 7 3 82 80 5 3 4 14 37 13 184 77 80 5 3 4 14 37 13 185 1 230 202 39 93 47 23 58 23 1 21 254 26 202 39 93 48 23 59 22 254 234 0 255 255 0 82 0 0 1 227 2 214 2 38 3 236 0 0 0 7 7 46 1 29 0 1 0 1 0 82 0 0 1 229 1 242 0 27 0 83 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 26 0 1 0 3 0 4 43 184 0 10 16 184 0 1 208 184 0 10 16 185 0 16 0 2 244 186 0 22 0 3 0 26 17 18 57 184 0 0 16 184 0 24 208 48 49 51 17 51 21 51 55 62 3 51 50 23 7 38 34 35 34 14 2 15 1 19 35 39 35 21 82 82 94 48 14 28 32 34 20 16 12 14 5 6 5 10 17 17 18 9 41 165 90 135 96 1 230 200 108 32 40 23 9 5 77 2 5 14 26 21 96 255 0 219 219 0 0 1 0 82 255 244 1 233 1 242 0 36 0 101 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 9 62 89 184 0 0 69 88 184 0 20 47 27 185 0 20 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 35 47 27 185 0 35 0 5 62 89 187 0 13 0 1 0 6 0 4 43 184 0 17 16 185 0 24 0 2 244 184 0 0 16 185 0 32 0 2 244 48 49 5 34 46 2 47 1 35 21 35 17 51 21 51 55 62 1 51 50 22 23 7 38 34 35 34 6 15 1 23 30 1 51 50 55 23 6 1 197 17 30 27 25 13 81 96 82 82 95 61 20 54 37 13 15 6 15 5 5 8 18 28 11 54 81 14 24 15 11 9 14 12 12 6 18 31 25 151 219 1 230 200 132 45 35 3 2 77 2 18 25 122 147 24 14 3 78 5 0 1 0 82 0 0 1 229 1 230 0 12 0 13 0 187 0 4 0 1 0 10 0 4 43 48 49 51 17 51 21 51 55 51 7 19 35 39 35 21 82 82 89 130 92 157 167 90 135 96 1 230 198 198 226 254 252 216 216 0 0 1 0 10 255 244 1 193 1 230 0 22 0 61 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 2 244 184 0 0 16 184 0 16 208 184 0 13 16 185 0 17 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 55 62 1 55 33 17 35 17 35 14 1 7 6 54 14 19 11 16 5 10 7 26 32 7 10 18 9 1 43 83 151 8 16 8 21 12 4 4 76 2 2 49 54 79 157 79 254 26 1 163 67 135 67 162 0 0 1 0 82 0 0 2 39 1 230 0 37 0 93 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 6 0 0 0 1 17 18 57 184 0 1 16 184 0 11 208 184 0 0 16 184 0 14 208 186 0 20 0 14 0 11 17 18 57 186 0 26 0 11 0 14 17 18 57 186 0 31 0 1 0 0 17 18 57 48 49 51 17 51 23 30 1 23 51 62 1 63 1 51 17 35 53 52 62 2 55 35 14 1 15 1 35 39 46 1 39 35 30 3 29 1 82 95 95 11 22 11 4 11 23 10 93 94 75 2 3 3 2 4 11 23 11 92 55 94 11 23 11 4 1 3 3 2 1 230 228 30 59 29 29 59 30 228 254 26 218 16 43 45 45 19 29 59 27 225 225 27 59 29 19 45 45 43 16 218 0 0 0 1 0 82 0 0 1 224 1 230 0 11 0 63 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 10 0 2 0 3 0 4 43 184 0 1 16 184 0 5 208 184 0 0 16 184 0 8 208 48 49 51 17 51 21 51 53 51 17 35 53 35 21 82 82 234 82 82 234 1 230 197 197 254 26 216 216 0 255 255 0 46 255 244 1 240 1 242 2 6 0 42 0 0 0 1 0 82 0 0 1 215 1 230 0 7 0 51 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 4 208 184 0 1 16 185 0 5 0 1 244 48 49 51 17 33 17 35 17 35 17 82 1 133 82 225 1 230 254 26 1 163 254 93 0 0 255 255 0 82 255 51 1 251 1 242 2 6 0 43 0 0 255 255 0 46 255 244 1 175 1 242 2 6 0 30 0 0 0 1 0 26 0 0 1 178 1 230 0 7 0 51 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 3 16 185 0 1 0 1 244 184 0 5 208 48 49 51 17 35 53 33 21 35 17 189 163 1 152 163 1 163 67 67 254 93 255 255 0 12 255 47 1 199 1 230 2 6 0 52 0 0 0 3 0 47 255 51 2 175 2 200 0 39 0 54 0 69 0 203 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 19 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 186 0 2 0 5 0 13 17 18 57 186 0 16 0 13 0 5 17 18 57 184 0 13 16 184 0 24 208 184 0 5 16 184 0 34 208 186 0 21 0 24 0 34 17 18 57 186 0 37 0 34 0 24 17 18 57 184 0 5 16 185 0 40 0 1 244 184 0 2 16 185 0 43 0 1 244 184 0 16 16 185 0 44 0 1 244 184 0 13 16 185 0 47 0 1 244 184 0 40 16 184 0 55 208 184 0 47 16 184 0 63 208 184 0 21 16 185 0 66 0 1 244 184 0 37 16 185 0 67 0 1 244 48 49 5 53 55 14 1 35 34 38 53 52 62 2 51 50 22 23 39 53 51 21 7 62 1 51 50 30 2 21 20 14 2 35 34 38 39 23 21 3 50 54 55 17 46 1 35 34 14 2 21 20 22 33 50 54 53 52 46 2 35 34 6 7 17 30 1 1 71 2 20 49 29 84 100 30 51 66 37 29 47 22 2 80 2 23 55 27 43 66 45 23 30 51 68 37 23 49 24 2 158 22 38 20 20 43 21 24 41 31 17 61 1 38 51 64 13 27 42 30 20 42 23 22 43 205 156 73 15 21 132 122 59 95 66 36 20 15 72 177 177 74 17 20 35 65 91 57 62 97 68 35 18 17 72 156 1 6 15 20 1 48 18 15 27 49 68 42 88 98 102 91 40 66 47 26 14 20 254 207 20 13 0 0 0 255 255 0 14 0 0 1 176 1 230 2 6 0 51 0 0 0 1 0 82 255 84 2 23 1 230 0 12 0 65 0 125 184 0 11 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 4 0 1 244 184 0 1 16 184 0 5 208 184 0 4 16 184 0 8 208 48 49 51 17 51 17 51 17 51 17 51 21 7 35 53 82 82 218 82 71 8 71 1 230 254 93 1 163 254 93 52 187 172 0 0 0 1 0 59 0 0 1 174 1 230 0 21 0 55 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 5 62 89 187 0 15 0 1 0 6 0 4 43 184 0 10 16 184 0 19 208 48 49 33 53 14 3 35 34 38 61 1 51 21 20 22 51 50 54 55 53 51 17 1 92 13 21 21 24 16 93 101 82 61 67 22 36 21 82 194 3 3 3 1 78 91 133 133 54 48 4 5 226 254 26 0 0 0 0 1 0 82 0 0 2 155 1 230 0 11 0 67 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 4 0 1 244 184 0 1 16 184 0 5 208 184 0 4 16 184 0 8 208 184 0 5 16 184 0 9 208 48 49 51 17 51 17 51 17 51 17 51 17 51 17 82 82 171 79 172 81 1 230 254 93 1 163 254 93 1 163 254 26 0 0 1 0 82 255 84 2 226 1 230 0 16 0 81 0 125 184 0 0 47 24 184 0 0 69 88 184 0 3 47 27 185 0 3 0 9 62 89 184 0 0 69 88 184 0 2 47 27 185 0 2 0 5 62 89 185 0 6 0 1 244 184 0 3 16 184 0 7 208 184 0 6 16 184 0 10 208 184 0 7 16 184 0 11 208 184 0 10 16 184 0 14 208 48 49 5 53 33 17 51 17 51 17 51 17 51 17 51 17 51 21 7 2 147 253 191 82 171 79 172 81 71 8 172 172 1 230 254 93 1 163 254 93 1 163 254 93 52 187 0 0 2 0 26 0 0 2 42 1 230 0 12 0 20 0 67 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 9 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 187 0 6 0 1 0 19 0 4 43 184 0 3 16 185 0 1 0 1 244 184 0 12 16 185 0 14 0 1 244 48 49 51 17 35 53 51 21 51 50 22 21 20 6 35 39 51 50 53 52 38 43 1 198 172 254 81 87 106 106 87 81 73 121 60 61 73 1 163 67 179 73 79 81 74 66 89 46 42 0 0 0 3 0 82 0 0 2 80 1 230 0 14 0 22 0 26 0 73 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 3 0 1 0 22 0 4 43 184 0 0 16 185 0 16 0 1 244 184 0 0 16 184 0 23 208 184 0 1 16 184 0 24 208 48 49 51 17 51 21 51 50 30 2 21 20 14 2 35 39 51 50 53 52 38 43 1 5 17 51 17 82 82 69 43 71 51 28 28 51 71 43 69 60 121 59 62 60 1 90 82 1 230 179 18 37 57 40 41 58 38 18 66 89 46 42 243 1 230 254 26 0 2 0 82 0 0 1 193 1 230 0 14 0 22 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 187 0 4 0 1 0 21 0 4 43 184 0 14 16 185 0 16 0 1 244 48 49 51 17 51 21 51 50 30 2 21 20 14 2 35 39 51 50 53 52 38 43 1 82 82 92 43 71 51 28 28 51 71 43 92 83 121 59 62 83 1 230 179 18 37 57 40 41 58 38 18 66 89 46 42 0 0 0 1 0 24 255 244 1 154 1 242 0 32 0 67 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 13 0 1 0 10 0 4 43 184 0 0 16 185 0 7 0 1 244 184 0 23 16 185 0 16 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 55 35 53 51 46 1 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 183 47 81 31 34 23 59 36 67 83 5 215 213 9 79 58 36 53 21 39 25 75 54 45 81 61 35 34 61 83 12 33 29 50 20 26 84 85 59 76 75 25 18 50 23 35 31 63 97 65 64 95 63 32 0 0 0 2 0 82 255 244 2 180 1 242 0 26 0 44 0 101 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 9 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 9 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 12 0 2 0 5 0 4 43 184 0 0 16 185 0 27 0 1 244 184 0 17 16 185 0 35 0 1 244 48 49 5 34 46 2 39 35 21 35 17 51 21 51 62 3 51 50 30 2 21 20 14 2 39 50 62 2 53 52 38 35 34 14 2 21 20 30 2 1 226 43 74 56 36 4 105 82 82 106 6 37 56 72 41 43 77 57 33 33 57 77 47 30 48 33 18 69 60 30 48 35 19 19 35 48 12 30 58 84 53 213 1 230 200 50 79 54 29 34 66 95 61 60 95 65 34 68 27 49 68 42 84 104 27 50 69 42 42 68 49 27 0 0 2 0 32 0 0 1 176 1 230 0 16 0 25 0 75 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 9 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 5 62 89 187 0 18 0 1 0 1 0 4 43 186 0 6 0 1 0 18 17 18 57 184 0 4 16 184 0 16 208 184 0 15 16 185 0 19 0 1 244 48 49 33 53 43 1 7 35 55 46 1 53 52 62 2 59 1 17 39 51 53 35 34 6 21 20 22 1 94 90 1 134 93 148 47 64 29 51 70 41 172 158 76 76 57 65 65 192 192 203 14 67 58 40 55 34 15 254 26 252 170 39 43 43 45 0 0 255 255 0 46 255 244 1 202 3 13 2 38 0 32 0 0 0 7 7 31 1 9 0 0 255 255 0 46 255 244 1 202 2 175 2 38 0 32 0 0 0 7 7 51 1 9 0 0 0 1 0 8 255 39 1 243 2 200 0 44 0 118 0 184 0 0 69 88 184 0 27 47 27 185 0 27 0 19 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 185 0 7 0 1 244 184 0 27 16 184 0 26 220 184 0 23 220 184 0 37 220 185 0 17 0 1 244 186 0 34 0 37 0 22 17 18 57 184 0 34 16 185 0 20 0 1 244 184 0 26 16 184 0 30 208 184 0 23 16 184 0 31 208 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 46 2 35 34 6 7 17 35 17 35 53 55 53 51 21 51 21 35 21 7 62 1 51 50 22 21 20 14 2 1 39 19 31 11 16 8 21 11 26 46 33 19 15 31 45 30 34 59 36 82 74 74 82 182 182 4 34 76 49 88 92 28 53 76 217 8 5 62 3 5 28 70 121 93 64 86 53 22 35 37 254 197 2 59 43 5 93 93 48 93 97 33 45 138 150 113 149 89 37 255 255 0 82 0 0 1 134 3 14 2 38 3 229 0 0 0 7 7 34 0 247 0 1 0 1 0 46 255 244 1 175 1 242 0 32 0 67 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 21 0 1 0 22 0 4 43 184 0 10 16 185 0 17 0 1 244 184 0 0 16 185 0 26 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 7 51 21 35 30 1 51 50 54 55 23 14 1 1 18 49 84 61 34 37 64 85 47 48 69 26 39 22 50 32 60 82 10 226 228 5 82 69 35 59 23 33 33 80 12 32 63 95 64 64 97 63 32 34 23 52 19 25 76 75 59 85 84 28 20 52 29 33 0 255 255 0 28 255 244 1 131 1 242 2 6 0 46 0 0 255 255 0 67 0 0 0 181 2 180 2 6 0 36 0 0 255 255 255 233 0 0 1 13 2 175 2 38 1 71 0 0 0 6 7 51 123 0 0 0 0 3 0 17 0 0 0 240 2 174 0 11 0 23 0 27 0 65 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 9 62 89 184 0 0 69 88 184 0 24 47 27 185 0 24 0 5 62 89 184 0 25 16 184 0 0 220 184 0 6 220 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 3 17 51 17 63 20 26 26 20 20 26 26 111 20 26 26 20 20 26 26 127 82 2 76 28 21 21 28 28 21 21 28 28 21 21 28 28 21 21 28 253 180 1 230 254 26 0 0 0 255 255 255 216 255 39 0 181 2 180 2 6 0 37 0 0 0 2 0 12 255 244 2 181 1 230 0 34 0 42 0 89 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 15 0 1 0 42 0 4 43 184 0 0 16 185 0 7 0 2 244 184 0 0 16 184 0 27 208 184 0 27 47 184 0 13 16 185 0 28 0 1 244 184 0 27 16 185 0 36 0 1 244 48 49 23 34 38 39 55 30 1 51 50 54 55 62 1 55 33 21 51 50 30 2 21 20 14 2 43 1 17 35 14 1 7 14 1 37 51 50 53 52 38 43 1 56 14 20 10 15 5 10 7 23 37 9 11 11 4 1 36 64 43 71 51 28 28 51 71 43 147 137 5 10 12 13 70 1 74 55 122 60 62 55 12 4 4 76 2 2 47 56 75 157 83 179 18 37 57 40 41 58 38 18 1 163 67 142 72 77 73 78 89 46 42 0 2 0 82 0 0 2 205 1 230 0 18 0 26 0 79 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 17 0 2 0 3 0 4 43 187 0 26 0 1 0 7 0 4 43 184 0 1 16 184 0 5 208 184 0 0 16 184 0 15 208 185 0 20 0 1 244 48 49 51 17 51 21 51 53 51 21 51 50 22 21 20 6 43 1 53 35 21 37 51 50 53 52 38 43 1 82 82 213 82 64 87 107 107 87 146 213 1 39 56 121 59 62 56 1 230 197 197 179 73 79 81 74 216 216 66 89 46 42 0 255 255 0 8 0 0 1 215 2 200 2 6 1 58 0 0 255 255 0 82 0 0 1 229 3 14 2 38 3 238 0 0 0 7 7 34 1 21 0 1 0 2 0 82 255 244 1 233 3 14 0 36 0 40 0 101 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 9 62 89 184 0 0 69 88 184 0 20 47 27 185 0 20 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 35 47 27 185 0 35 0 5 62 89 187 0 13 0 1 0 6 0 4 43 184 0 17 16 185 0 24 0 2 244 184 0 0 16 185 0 32 0 2 244 48 49 5 34 46 2 47 1 35 21 35 17 51 21 51 55 62 1 51 50 22 23 7 38 34 35 34 6 15 1 23 30 1 51 50 55 23 6 3 39 55 23 1 197 17 30 27 25 13 81 96 82 82 95 61 20 54 37 13 15 6 15 5 5 8 18 28 11 54 81 14 24 15 11 9 14 12 214 42 141 58 12 6 18 31 25 151 219 1 230 200 132 45 35 3 2 77 2 18 25 122 147 24 14 3 78 5 2 74 41 167 55 0 0 2 0 82 0 0 1 229 3 14 0 12 0 16 0 13 0 187 0 4 0 1 0 10 0 4 43 48 49 51 17 51 21 51 55 51 7 19 35 39 35 21 19 39 55 23 82 82 89 130 92 157 167 90 135 96 99 42 141 58 1 230 198 198 226 254 252 216 216 2 62 41 167 55 0 0 255 255 0 82 0 0 1 227 3 14 2 38 3 236 0 0 0 7 7 31 1 29 0 1 255 255 0 12 255 47 1 199 2 213 2 38 0 52 0 0 0 7 7 46 0 242 0 0 0 1 0 82 255 84 1 220 1 230 0 11 0 65 0 125 184 0 10 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 3 0 1 244 184 0 1 16 184 0 5 208 184 0 0 16 184 0 7 208 48 49 51 17 51 17 51 17 51 17 35 7 35 39 82 82 230 82 154 9 70 3 1 230 254 93 1 163 254 26 172 172 0 0 0 0 2 0 26 0 0 2 22 2 110 0 18 0 26 0 66 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 2 0 1 0 3 0 4 43 187 0 26 0 1 0 11 0 4 43 184 0 3 16 184 0 8 208 184 0 2 16 184 0 9 208 184 0 0 16 185 0 20 0 1 244 48 49 51 17 35 53 51 53 51 21 51 21 35 21 51 50 22 21 20 6 35 39 51 50 53 52 38 43 1 178 152 152 82 188 188 81 87 106 106 87 81 72 122 60 62 72 1 183 67 116 116 67 132 73 79 81 74 66 89 46 42 0 0 0 255 255 0 46 255 244 1 240 1 242 2 6 1 228 0 0 0 1 0 12 0 0 1 242 1 242 0 24 0 69 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 14 16 184 0 1 208 184 0 1 47 186 0 6 0 14 0 0 17 18 57 184 0 14 16 185 0 20 0 2 244 48 49 51 3 51 19 30 1 23 51 62 1 63 1 62 1 51 50 22 23 7 38 35 34 6 7 3 187 175 85 92 11 24 11 4 9 18 11 48 20 55 50 15 21 12 16 11 14 22 26 12 109 1 230 254 236 36 72 35 35 72 36 148 72 68 4 5 74 6 36 37 254 164 0 0 0 1 0 82 0 0 1 143 2 146 0 7 0 47 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 184 0 1 16 185 0 5 0 1 244 48 49 51 17 51 55 51 7 35 17 82 234 16 67 9 226 1 230 172 239 254 93 0 0 0 0 1 0 30 0 0 1 143 1 230 0 13 0 73 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 9 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 187 0 2 0 1 0 13 0 4 43 184 0 3 16 185 0 5 0 1 244 184 0 2 16 184 0 8 208 184 0 13 16 184 0 9 208 48 49 55 53 55 53 33 21 35 21 51 21 35 21 35 53 30 66 1 47 221 133 133 82 213 42 5 226 67 159 47 213 213 0 0 0 1 0 13 255 84 2 187 1 242 0 48 0 149 0 125 184 0 0 47 24 184 0 0 69 88 184 0 21 47 27 185 0 21 0 9 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 187 0 25 0 1 0 8 0 4 43 184 0 10 16 184 0 6 208 184 0 2 208 184 0 8 16 184 0 3 208 186 0 11 0 25 0 8 17 18 57 184 0 21 16 185 0 15 0 2 244 184 0 21 16 184 0 27 208 184 0 27 47 184 0 25 16 184 0 30 208 184 0 21 16 184 0 34 208 184 0 15 16 184 0 40 208 186 0 44 0 3 0 30 17 18 57 184 0 2 16 185 0 46 0 1 244 48 49 5 53 35 39 35 21 35 53 35 7 35 19 39 46 1 35 42 1 7 39 54 51 50 22 31 1 51 53 51 21 51 55 62 1 51 50 23 7 38 34 35 34 6 15 1 23 51 21 7 2 108 41 122 80 73 80 122 89 153 39 17 33 20 5 6 5 15 13 16 40 62 26 46 75 73 75 46 26 62 40 16 12 14 5 6 5 20 34 17 38 113 71 8 172 172 219 219 219 219 1 0 96 42 24 2 77 5 43 61 108 200 200 108 61 43 5 77 2 24 42 96 189 52 187 0 0 1 0 1 255 84 2 187 1 242 0 81 0 225 0 184 0 0 69 88 184 0 39 47 27 185 0 39 0 9 62 89 184 0 0 69 88 184 0 41 47 27 185 0 41 0 9 62 89 184 0 0 69 88 184 0 58 47 27 185 0 58 0 9 62 89 184 0 0 69 88 184 0 60 47 27 185 0 60 0 9 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 5 62 89 187 0 52 0 1 0 9 0 4 43 184 0 9 16 184 0 13 208 184 0 22 16 185 0 25 0 1 244 184 0 41 16 185 0 35 0 2 244 184 0 52 16 184 0 47 208 184 0 35 16 184 0 64 208 184 0 25 16 184 0 74 208 184 0 78 208 184 0 78 47 184 0 79 208 184 0 79 47 184 0 78 16 184 0 81 220 48 49 5 53 38 39 35 53 46 1 47 1 35 21 35 53 35 7 14 3 35 34 39 55 22 51 50 54 63 1 39 46 3 35 42 1 7 39 54 51 50 30 2 31 1 51 53 51 21 51 55 62 3 51 50 23 7 38 34 35 34 14 2 15 1 23 30 1 51 50 54 55 23 51 21 7 2 108 13 10 3 19 35 20 67 76 73 76 68 16 31 31 33 19 16 13 14 9 8 17 31 23 65 41 9 18 16 18 9 5 7 5 14 12 17 19 35 31 28 14 48 74 73 74 48 14 28 31 34 20 16 13 15 5 6 5 9 18 16 18 9 41 65 22 32 17 5 6 5 1 33 8 172 163 3 6 2 11 42 37 127 219 219 127 32 40 23 9 5 78 3 25 42 120 97 21 26 14 5 2 77 5 9 23 40 32 108 200 200 108 32 40 23 9 5 77 2 5 14 26 21 97 120 42 25 1 2 4 52 187 0 0 1 0 13 255 84 2 187 1 230 0 26 0 90 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 187 0 19 0 1 0 3 0 4 43 184 0 3 16 184 0 7 208 184 0 19 16 184 0 14 208 184 0 1 16 185 0 23 0 1 244 48 49 5 53 35 39 35 21 35 53 35 7 35 19 39 51 23 51 53 51 21 51 55 51 7 23 51 21 7 2 108 44 132 65 76 65 132 93 167 155 94 126 58 76 58 126 94 155 124 73 8 172 172 216 216 216 216 1 4 226 198 198 198 198 226 193 52 187 0 0 0 1 0 37 255 84 1 161 1 242 0 50 0 81 0 125 184 0 0 47 24 184 0 0 69 88 184 0 32 47 27 185 0 32 0 9 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 187 0 19 0 1 0 16 0 4 43 184 0 1 16 185 0 8 0 1 244 184 0 32 16 185 0 25 0 1 244 184 0 1 16 184 0 49 208 48 49 23 39 46 1 39 55 30 1 51 50 62 2 53 52 38 43 1 53 51 50 54 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 15 1 186 4 38 72 35 35 34 71 37 25 44 33 19 64 60 67 55 59 58 56 45 42 61 29 35 35 83 53 36 64 48 29 42 38 42 59 24 42 56 32 9 172 162 4 27 29 53 28 21 12 22 33 20 42 40 59 41 36 37 37 22 21 54 25 29 16 32 50 33 35 58 15 4 11 57 53 29 49 36 24 5 163 0 0 0 0 1 0 82 255 84 2 5 1 242 0 32 0 118 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 9 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 9 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 9 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 187 0 10 0 1 0 3 0 4 43 184 0 16 16 185 0 22 0 2 244 184 0 1 16 185 0 29 0 1 244 48 49 5 53 35 39 35 21 35 17 51 21 51 55 62 3 51 50 23 7 38 34 35 34 14 2 15 1 23 51 21 7 1 182 43 135 96 82 82 94 48 14 28 32 34 20 16 12 14 5 6 5 10 17 17 18 9 41 122 75 9 172 172 219 219 1 230 200 108 32 40 23 9 5 77 2 5 14 26 21 96 189 52 187 0 0 0 1 0 82 255 84 2 5 1 242 0 37 0 92 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 9 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 187 0 12 0 1 0 5 0 4 43 184 0 16 16 185 0 23 0 2 244 184 0 1 16 185 0 31 0 2 244 184 0 34 208 184 0 35 208 48 49 5 53 46 1 47 1 35 21 35 17 51 21 51 55 62 1 51 50 22 23 7 38 34 35 34 6 15 1 23 30 1 51 50 55 23 51 21 7 1 182 29 45 23 81 96 82 82 95 61 20 54 37 13 15 6 15 5 5 8 18 28 11 54 81 14 24 15 11 9 1 41 9 172 161 2 33 44 151 219 1 230 200 132 45 35 3 2 77 2 18 25 122 147 24 14 3 4 52 187 0 0 0 0 1 0 82 255 84 2 5 1 230 0 17 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 187 0 10 0 1 0 3 0 4 43 184 0 1 16 185 0 14 0 1 244 48 49 5 53 35 39 35 21 35 17 51 21 51 55 51 7 23 51 21 7 1 182 43 135 96 82 82 89 130 92 157 124 75 9 172 172 216 216 1 230 198 198 226 193 52 187 0 0 1 0 26 0 0 2 89 1 242 0 29 0 93 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 5 0 1 0 28 0 4 43 184 0 3 16 185 0 1 0 1 244 184 0 3 16 184 0 12 208 184 0 12 47 185 0 18 0 2 244 186 0 24 0 5 0 28 17 18 57 184 0 0 16 184 0 26 208 48 49 51 17 35 53 51 21 51 55 62 3 51 50 23 7 38 34 35 34 14 2 15 1 23 35 39 35 21 198 172 254 94 48 14 28 31 34 20 16 13 15 5 6 5 9 18 16 18 9 41 165 91 135 95 1 163 67 200 108 32 40 23 9 5 77 2 5 14 26 21 97 255 219 219 0 1 0 26 255 244 2 93 1 242 0 38 0 126 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 9 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 9 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 37 47 27 185 0 37 0 5 62 89 187 0 15 0 1 0 6 0 4 43 184 0 12 16 185 0 10 0 1 244 184 0 26 208 184 0 26 47 184 0 0 16 185 0 34 0 2 244 48 49 5 34 46 2 47 1 35 21 35 17 35 53 51 21 51 55 62 1 51 50 22 23 7 38 34 35 34 6 15 1 23 30 1 51 50 55 23 6 2 57 17 30 27 25 13 81 96 82 172 254 95 61 20 54 37 13 15 6 15 5 5 8 18 28 11 54 81 14 24 15 11 9 14 12 12 6 18 31 25 151 219 1 163 67 200 132 45 35 3 2 77 2 18 25 122 147 24 14 3 78 5 0 0 0 0 1 0 26 0 0 2 89 1 230 0 14 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 9 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 9 62 89 187 0 4 0 1 0 10 0 4 43 184 0 1 16 185 0 0 0 1 244 48 49 19 53 51 21 51 55 51 7 19 35 39 35 21 35 17 26 254 89 130 92 157 167 90 135 96 82 1 163 67 198 198 226 254 252 216 216 1 163 0 0 0 0 1 0 83 255 84 2 39 1 230 0 16 0 79 0 125 184 0 0 47 24 184 0 0 69 88 184 0 7 47 27 185 0 7 0 9 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 187 0 9 0 2 0 4 0 4 43 184 0 6 16 184 0 2 208 184 0 7 16 184 0 11 208 184 0 2 16 185 0 14 0 1 244 48 49 5 53 35 53 35 21 35 17 51 21 51 53 51 17 51 21 7 1 215 72 234 82 82 234 82 70 9 172 172 216 216 1 230 197 197 254 93 52 187 0 1 0 46 255 84 1 175 1 242 0 35 0 71 0 125 184 0 0 47 24 184 0 0 69 88 184 0 11 47 27 185 0 11 0 9 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 11 16 185 0 18 0 1 244 184 0 1 16 185 0 28 0 1 244 184 0 1 16 184 0 34 208 48 49 23 39 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 21 20 30 2 51 50 54 55 23 6 15 1 234 4 40 68 49 27 38 64 85 47 48 68 26 42 21 47 29 33 56 40 23 22 39 56 33 34 57 23 36 53 67 9 172 164 7 40 64 86 53 61 95 66 34 34 23 54 19 24 27 50 69 42 42 68 49 27 29 20 55 47 12 163 0 0 0 1 0 12 255 51 1 199 1 230 0 15 0 80 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 9 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 186 0 7 0 2 0 0 17 18 57 184 0 2 16 184 0 12 208 184 0 1 16 184 0 14 208 48 49 23 53 3 51 19 30 1 23 51 62 1 55 19 51 3 21 195 183 85 91 11 24 11 4 11 23 11 91 81 178 205 205 1 230 254 247 36 71 34 34 71 36 1 9 254 26 205 0 0 0 0 1 0 12 255 51 1 199 1 230 0 22 0 92 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 184 0 0 69 88 184 0 2 47 27 185 0 2 0 5 62 89 184 0 5 208 186 0 11 0 6 0 0 17 18 57 184 0 6 16 184 0 16 208 184 0 5 16 184 0 19 208 184 0 2 16 184 0 20 208 48 49 23 53 35 53 55 51 3 51 19 30 1 23 51 62 1 55 19 51 3 51 21 35 21 195 148 78 52 165 85 91 11 24 11 4 11 23 11 91 81 161 125 142 205 205 42 5 1 183 254 247 36 71 34 34 71 36 1 9 254 73 47 205 0 1 0 14 255 84 1 206 1 230 0 30 0 105 0 125 184 0 0 47 24 184 0 0 69 88 184 0 14 47 27 185 0 14 0 9 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 184 0 2 208 184 0 14 16 184 0 24 208 186 0 6 0 2 0 24 17 18 57 186 0 19 0 14 0 12 17 18 57 186 0 13 0 19 0 6 17 18 57 186 0 26 0 6 0 19 17 18 57 184 0 2 16 185 0 28 0 1 244 48 49 5 53 35 39 46 1 39 35 14 1 15 1 35 55 39 51 23 30 1 23 51 62 1 63 1 51 7 23 51 21 7 1 128 41 71 13 26 14 4 13 24 12 66 86 159 147 89 65 11 24 13 4 11 22 11 59 86 147 115 73 8 172 172 113 22 44 21 21 43 23 113 254 232 107 20 41 20 20 41 20 107 241 178 52 187 0 1 0 59 255 84 1 245 1 230 0 26 0 69 0 184 0 0 47 184 0 0 69 88 184 0 12 47 27 185 0 12 0 9 62 89 184 0 0 69 88 184 0 2 47 27 185 0 2 0 5 62 89 187 0 17 0 1 0 8 0 4 43 184 0 12 16 184 0 22 208 184 0 2 16 185 0 24 0 1 244 48 49 5 53 35 53 14 3 35 34 38 61 1 51 21 20 22 51 50 54 55 53 51 17 51 21 7 1 166 74 13 21 21 24 16 93 101 82 61 67 22 36 21 82 71 9 172 172 194 3 3 3 1 78 91 133 133 54 48 4 5 226 254 93 52 187 0 255 255 0 82 0 0 1 215 2 200 2 6 0 35 0 0 255 255 0 13 0 0 2 156 2 213 2 38 3 232 0 0 0 7 7 46 1 85 0 0 0 2 0 1 255 244 2 168 2 213 0 76 0 98 0 211 0 184 0 0 69 88 184 0 36 47 27 185 0 36 0 9 62 89 184 0 0 69 88 184 0 38 47 27 185 0 38 0 9 62 89 184 0 0 69 88 184 0 55 47 27 185 0 55 0 9 62 89 184 0 0 69 88 184 0 57 47 27 185 0 57 0 9 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 5 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 184 0 0 69 88 184 0 75 47 27 185 0 75 0 5 62 89 187 0 88 0 1 0 77 0 4 43 187 0 49 0 1 0 6 0 4 43 184 0 6 16 184 0 10 208 184 0 17 16 185 0 22 0 2 244 184 0 38 16 185 0 32 0 2 244 184 0 49 16 184 0 44 208 184 0 32 16 184 0 61 208 184 0 22 16 184 0 71 208 48 49 5 34 46 2 47 1 35 21 35 53 35 7 14 3 35 34 39 55 22 51 50 54 63 1 39 46 3 35 42 1 7 39 54 51 50 30 2 31 1 51 53 51 21 51 55 62 3 51 50 23 7 38 34 35 34 14 2 15 1 23 30 1 51 50 54 55 23 6 1 34 46 2 39 51 30 3 51 50 62 2 55 51 14 3 2 139 19 33 32 31 16 67 76 73 76 68 16 31 31 33 19 16 13 14 9 8 17 31 23 65 41 9 18 16 18 9 5 7 5 14 12 17 19 35 31 28 14 48 74 73 74 48 14 28 31 34 20 16 13 15 5 6 5 9 18 16 18 9 41 65 22 32 17 5 6 5 15 13 254 186 42 58 38 18 1 68 1 9 21 33 25 25 33 21 9 1 68 2 17 38 58 12 9 23 40 32 127 219 219 127 32 40 23 9 5 78 3 25 42 120 97 21 26 14 5 2 77 5 9 23 40 32 108 200 200 108 32 40 23 9 5 77 2 5 14 26 21 97 120 42 25 1 2 78 5 2 72 26 43 55 29 21 39 28 17 17 28 39 21 29 55 43 26 0 2 0 13 0 0 2 157 2 213 0 21 0 43 0 39 0 187 0 33 0 1 0 22 0 4 43 187 0 9 0 1 0 15 0 4 43 184 0 9 16 184 0 4 208 184 0 15 16 184 0 19 208 48 49 51 19 39 51 23 51 53 51 21 51 55 51 7 19 35 39 35 21 35 53 35 7 19 34 46 2 39 51 30 3 51 50 62 2 55 51 14 3 13 167 155 94 126 58 76 58 126 94 155 167 93 132 65 76 65 132 235 42 58 38 18 1 68 1 9 21 33 25 25 33 21 9 1 68 2 17 38 58 1 4 226 198 198 198 198 226 254 252 216 216 216 216 2 60 26 43 55 29 21 39 28 17 17 28 39 21 29 55 43 26 0 0 0 255 255 0 82 255 244 0 216 2 200 2 6 0 39 0 0 255 255 0 52 255 244 1 177 2 213 2 38 0 28 0 0 0 7 7 46 1 6 0 0 255 255 0 58 255 244 2 235 1 242 2 6 1 14 0 0 255 255 0 46 255 244 1 202 2 213 2 38 0 32 0 0 0 7 7 46 1 9 0 0 255 255 0 37 255 244 1 194 1 242 2 6 1 200 0 0 255 255 0 82 0 0 1 227 2 147 2 38 3 236 0 0 0 7 7 41 1 28 0 1 255 255 0 46 255 244 1 240 2 175 2 38 0 42 0 0 0 7 7 51 1 15 0 0 255 255 0 46 255 244 1 240 1 242 2 6 1 228 0 0 255 255 0 12 255 47 1 199 2 146 2 38 0 52 0 0 0 7 7 41 0 242 0 0 255 255 0 12 255 47 1 199 2 249 2 38 0 52 0 0 0 7 7 57 0 242 0 0 0 2 0 47 255 244 1 226 2 218 0 46 0 64 0 85 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 57 0 18 0 0 17 18 57 184 0 57 16 184 0 8 208 184 0 18 16 185 0 27 0 2 244 184 0 57 16 185 0 37 0 1 244 184 0 0 16 185 0 47 0 1 244 48 49 5 34 46 2 53 52 54 55 46 3 53 52 62 2 55 62 3 55 23 14 1 7 14 3 21 20 30 2 23 30 3 21 20 14 2 39 50 62 2 53 52 46 2 39 14 1 21 20 30 2 1 2 42 76 58 35 106 87 26 49 38 24 32 61 87 54 30 39 27 21 11 17 21 54 31 53 73 46 20 23 39 51 28 33 57 41 23 31 58 81 49 33 52 36 19 16 29 39 23 78 90 22 38 49 12 30 55 80 50 92 110 27 18 34 35 38 21 37 44 25 13 7 3 4 6 8 5 75 11 13 4 6 7 11 18 17 13 22 24 29 19 24 48 56 68 44 51 86 62 34 68 25 44 61 36 30 48 41 36 17 20 96 72 34 55 39 22 0 4 0 59 255 244 3 111 2 138 0 45 0 65 0 77 0 81 0 135 0 184 0 0 69 88 184 0 23 47 27 185 0 23 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 79 0 1 0 78 0 4 43 187 0 72 0 1 0 56 0 4 43 184 0 0 16 185 0 4 0 1 244 184 0 23 16 184 0 8 208 184 0 8 47 184 0 0 16 184 0 32 208 184 0 32 47 186 0 13 0 32 0 23 17 18 57 184 0 23 16 185 0 27 0 1 244 186 0 36 0 8 0 0 17 18 57 184 0 79 16 184 0 46 220 185 0 66 0 1 244 48 49 23 34 38 47 1 50 54 53 17 51 30 1 31 1 51 46 3 61 1 52 54 51 50 22 31 1 34 6 21 17 35 46 1 47 1 35 30 3 29 1 20 6 1 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 7 53 51 21 91 9 8 8 7 17 17 92 46 88 43 57 4 4 4 3 1 37 41 8 9 8 7 17 18 92 45 88 44 56 4 4 4 2 1 36 2 82 32 56 42 24 24 42 56 32 31 56 42 24 24 42 56 31 39 47 47 39 39 47 47 88 253 12 1 2 65 18 24 2 28 103 204 104 129 47 78 69 65 36 158 50 49 2 2 65 17 24 253 228 103 204 105 128 47 78 69 65 36 159 49 49 1 32 22 41 60 38 39 60 41 21 21 41 60 39 38 60 41 22 55 56 50 51 56 56 51 50 56 181 50 50 0 0 0 0 3 0 32 255 244 2 82 2 156 0 45 0 59 0 73 0 140 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 40 47 27 185 0 40 0 5 62 89 186 0 29 0 43 0 3 43 186 0 66 0 0 0 18 17 18 57 184 0 66 47 184 0 49 220 186 0 10 0 66 0 49 17 18 57 186 0 26 0 66 0 49 17 18 57 186 0 36 0 43 0 29 17 18 57 184 0 18 16 185 0 57 0 1 244 184 0 0 16 185 0 60 0 1 244 186 0 63 0 43 0 29 17 18 57 48 49 23 34 46 2 53 52 62 2 55 46 1 53 52 62 2 51 50 22 21 20 14 2 7 30 1 23 62 1 55 51 14 1 7 30 1 23 7 46 1 39 14 1 3 20 22 23 62 3 53 52 38 35 34 6 19 50 54 55 46 1 39 14 1 21 20 30 2 232 45 73 53 29 21 36 47 25 20 23 22 40 56 34 61 68 26 42 53 27 32 87 47 30 47 15 77 20 56 39 34 62 27 22 35 76 40 38 93 101 17 14 22 41 31 18 29 33 37 44 52 34 62 29 48 89 35 35 47 20 35 47 12 27 48 67 40 33 54 46 39 17 41 77 36 33 56 42 24 72 58 32 54 47 41 20 51 94 39 41 96 57 65 118 52 23 32 8 68 10 37 28 34 41 2 14 27 58 30 15 31 33 37 22 29 43 54 254 11 28 25 42 99 54 28 61 38 27 45 32 17 0 0 0 0 2 0 44 255 244 1 197 2 138 0 11 0 29 0 53 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 12 0 1 244 184 0 6 16 185 0 22 0 1 244 48 49 23 34 38 53 52 54 51 50 22 21 20 6 39 50 62 2 53 52 46 2 35 34 14 2 21 20 22 249 97 108 108 97 96 108 108 96 28 45 33 18 18 33 45 28 28 46 33 18 69 12 172 161 161 168 168 161 161 172 66 31 65 101 70 70 100 63 30 30 63 100 70 140 127 0 0 0 1 0 79 0 0 1 183 2 126 0 12 0 67 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 2 0 1 244 184 0 8 16 185 0 5 0 1 244 185 0 3 0 1 244 184 0 2 16 184 0 10 208 48 49 51 53 51 17 35 53 62 1 55 51 17 51 21 79 146 116 44 65 26 63 132 68 1 214 53 8 23 16 253 198 68 0 1 0 36 0 0 1 196 2 138 0 29 0 65 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 15 62 89 184 0 0 69 88 184 0 29 47 27 185 0 29 0 5 62 89 185 0 27 0 1 244 184 0 24 208 184 0 1 208 184 0 1 47 184 0 16 16 185 0 9 0 1 244 48 49 51 53 62 3 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 14 2 7 62 1 59 1 21 40 72 112 76 40 60 61 40 68 28 47 40 90 63 89 102 39 69 95 57 26 56 25 185 49 72 116 99 83 39 55 70 45 32 47 44 53 103 85 45 91 97 105 59 2 4 71 0 0 0 0 1 0 26 255 244 1 190 2 138 0 51 0 83 0 184 0 0 69 88 184 0 33 47 27 185 0 33 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 9 0 1 244 186 0 17 0 33 0 0 17 18 57 184 0 17 47 185 0 18 0 1 244 184 0 33 16 185 0 26 0 1 244 186 0 41 0 17 0 18 17 18 57 48 49 23 34 46 2 39 55 30 1 51 50 54 53 52 46 2 35 53 50 62 2 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 236 38 63 52 41 16 42 29 77 57 58 74 21 48 78 57 51 69 43 18 59 51 40 67 29 44 37 89 57 42 70 51 28 64 52 29 50 38 21 33 57 76 12 15 25 32 18 54 30 46 63 54 28 47 34 18 63 18 32 44 25 47 54 36 29 52 35 45 22 41 60 39 58 74 20 4 7 27 41 54 33 42 68 47 25 0 0 2 0 17 0 0 1 213 2 126 0 10 0 20 0 89 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 1 0 1 0 12 0 4 43 184 0 12 16 184 0 11 208 184 0 3 208 184 0 3 47 184 0 12 16 184 0 6 208 184 0 1 16 184 0 9 208 186 0 16 0 5 0 0 17 18 57 48 49 33 53 33 53 1 51 17 51 21 35 21 37 51 53 52 54 55 35 14 1 7 1 48 254 225 1 17 92 87 87 254 234 200 3 2 4 12 26 14 176 54 1 152 254 116 66 176 242 185 26 71 26 23 44 23 0 1 0 25 255 244 1 193 2 126 0 38 0 77 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 9 0 1 244 186 0 17 0 22 0 0 17 18 57 184 0 17 47 184 0 22 16 185 0 24 0 1 244 184 0 17 16 185 0 29 0 1 244 48 49 23 34 46 2 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 39 19 33 21 35 7 62 1 51 50 30 2 21 20 14 2 234 38 63 51 41 16 40 28 77 56 29 51 38 22 74 62 33 47 29 44 21 1 63 247 17 23 46 29 41 72 54 31 36 60 77 12 15 24 31 17 54 29 44 21 38 54 33 66 74 20 19 28 1 51 71 189 12 14 24 49 75 52 52 80 55 29 0 2 0 48 255 244 1 201 2 138 0 32 0 46 0 67 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 25 0 1 0 41 0 4 43 184 0 10 16 185 0 17 0 1 244 184 0 0 16 185 0 33 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 7 62 1 51 50 22 21 20 14 2 39 50 62 2 53 52 38 35 34 6 7 30 1 1 12 47 80 59 34 40 68 87 48 52 75 27 46 20 55 30 33 60 46 28 1 30 80 39 83 99 30 52 68 39 24 40 30 17 58 60 31 72 30 8 71 12 38 77 115 77 96 135 85 39 39 29 51 23 27 28 64 103 76 37 43 98 99 46 75 54 30 65 20 37 51 32 63 72 39 45 94 97 0 1 0 44 0 0 1 199 2 126 0 14 0 55 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 7 16 185 0 5 0 1 244 184 0 9 208 184 0 9 47 48 49 51 62 3 55 33 53 33 21 14 3 7 177 4 24 43 67 47 254 194 1 155 57 71 42 19 4 90 150 135 126 66 71 51 72 132 137 153 93 0 0 3 0 41 255 244 1 200 2 138 0 39 0 53 0 69 0 97 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 62 0 19 0 0 17 18 57 184 0 62 16 185 0 40 0 1 244 186 0 10 0 40 0 62 17 18 57 186 0 30 0 62 0 40 17 18 57 184 0 19 16 185 0 46 0 1 244 184 0 0 16 185 0 54 0 1 244 48 49 23 34 46 2 53 52 62 2 55 53 46 1 53 52 62 2 51 50 30 2 21 20 14 2 7 21 30 3 21 20 14 2 3 62 1 53 52 38 35 34 6 21 20 30 2 3 50 54 53 52 46 2 39 14 1 21 20 30 2 250 45 77 55 32 21 33 43 23 35 54 28 48 66 39 42 66 47 25 17 25 31 15 21 40 31 19 30 54 76 1 32 35 58 53 45 58 24 41 53 14 56 69 28 48 63 34 38 51 21 37 50 12 26 47 64 38 31 53 43 33 12 4 25 71 51 37 60 43 24 25 45 63 37 25 46 40 32 11 4 12 31 39 50 32 36 62 46 26 1 104 29 64 35 48 65 56 47 29 41 32 25 254 202 62 50 31 44 33 27 14 26 69 44 27 44 33 18 0 2 0 40 255 244 1 192 2 138 0 13 0 46 0 67 0 184 0 0 69 88 184 0 37 47 27 185 0 37 0 15 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 187 0 0 0 1 0 29 0 4 43 184 0 37 16 185 0 6 0 1 244 184 0 14 16 185 0 21 0 1 244 48 49 19 50 54 55 46 1 35 34 14 2 21 20 22 19 34 38 39 55 30 1 51 50 62 2 55 14 1 35 34 38 53 52 62 2 51 50 30 2 21 20 14 2 235 32 71 31 8 72 61 23 41 30 17 58 30 51 77 26 46 20 55 30 34 60 46 28 1 30 80 40 83 98 30 51 69 38 47 81 59 33 40 68 87 1 54 40 45 94 96 20 37 52 31 63 72 254 190 38 29 52 23 28 28 65 104 77 38 44 98 99 46 75 54 30 38 77 115 77 96 135 85 39 0 0 0 0 3 0 44 255 244 1 197 2 138 0 11 0 23 0 35 0 71 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 12 0 1 244 184 0 6 16 185 0 18 0 1 244 186 0 24 0 6 0 0 17 18 57 184 0 24 16 184 0 30 220 48 49 23 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 55 34 38 53 52 54 51 50 22 21 20 6 249 97 108 108 97 96 108 108 96 56 72 72 56 57 72 72 57 26 35 35 26 25 35 35 12 172 161 161 168 168 161 161 172 66 130 137 138 125 125 138 138 129 205 34 32 32 34 34 32 32 34 0 3 0 44 255 244 1 197 2 138 0 11 0 23 0 33 0 97 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 6 16 185 0 12 0 1 244 186 0 15 0 6 0 0 17 18 57 186 0 16 0 0 0 6 17 18 57 184 0 0 16 185 0 24 0 1 244 186 0 27 0 0 0 6 17 18 57 186 0 28 0 0 0 6 17 18 57 48 49 23 34 38 53 52 54 51 50 22 21 20 6 3 34 6 7 19 62 1 53 52 46 2 3 50 54 55 3 14 1 21 20 22 249 97 108 108 97 96 108 108 96 32 52 17 219 5 5 19 34 47 28 32 51 17 219 5 5 72 12 172 161 161 168 168 161 161 172 2 87 38 41 254 200 26 62 37 70 100 65 31 253 232 40 43 1 56 26 62 37 140 130 0 0 2 0 55 255 244 1 227 2 138 0 15 0 27 0 53 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 16 0 1 244 184 0 8 16 185 0 22 0 1 244 48 49 5 34 46 2 53 52 54 51 50 22 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 1 13 50 79 56 29 114 100 100 114 29 56 79 50 59 72 72 59 59 72 72 12 45 85 124 79 159 170 171 158 79 124 85 45 68 127 138 138 122 122 138 138 127 0 0 0 1 0 50 0 0 0 249 2 126 0 8 0 53 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 15 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 184 0 7 16 185 0 3 0 1 244 185 0 1 0 1 244 48 49 51 17 35 53 62 1 55 51 17 167 117 45 65 26 63 2 26 53 8 23 16 253 130 0 0 0 1 0 37 0 0 1 192 2 138 0 29 0 65 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 15 62 89 184 0 0 69 88 184 0 29 47 27 185 0 29 0 5 62 89 185 0 27 0 1 244 184 0 24 208 184 0 1 208 184 0 1 47 184 0 16 16 185 0 9 0 1 244 48 49 51 53 62 3 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 14 2 7 62 1 59 1 21 43 72 110 76 39 57 62 40 69 27 48 42 91 61 89 100 38 69 94 55 26 56 25 177 49 72 116 99 83 39 55 70 45 32 47 46 51 103 85 45 91 97 105 59 2 4 71 0 0 0 255 255 0 26 255 244 1 190 2 138 2 6 4 66 0 0 255 255 0 34 0 0 1 230 2 126 0 6 4 67 17 0 255 255 0 25 255 244 1 193 2 126 2 6 4 68 0 0 255 255 0 61 255 244 1 214 2 138 0 6 4 69 13 0 0 1 0 44 0 0 1 185 2 126 0 14 0 55 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 7 16 185 0 5 0 1 244 184 0 9 208 184 0 9 47 48 49 51 62 3 55 33 53 33 21 14 3 7 167 4 23 42 65 47 254 208 1 141 56 70 41 18 4 90 150 135 126 66 71 51 72 132 137 153 93 0 255 255 0 55 255 244 1 214 2 138 0 6 4 71 14 0 255 255 0 52 255 244 1 204 2 138 0 6 4 72 12 0 0 3 0 55 255 244 1 227 2 138 0 15 0 27 0 39 0 71 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 16 0 1 244 184 0 8 16 185 0 22 0 1 244 186 0 28 0 8 0 0 17 18 57 184 0 28 16 184 0 34 220 48 49 5 34 46 2 53 52 54 51 50 22 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 55 34 38 53 52 54 51 50 22 21 20 6 1 13 50 79 56 29 114 100 100 114 29 56 79 50 62 73 74 61 62 73 73 62 25 36 36 25 25 36 36 12 45 85 124 79 159 170 171 158 79 124 85 45 68 129 136 136 124 124 136 136 129 203 34 32 32 34 34 32 32 34 0 0 3 0 55 255 244 1 227 2 138 0 15 0 24 0 35 0 97 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 8 16 185 0 16 0 1 244 186 0 19 0 8 0 0 17 18 57 186 0 20 0 0 0 8 17 18 57 184 0 0 16 185 0 25 0 1 244 186 0 28 0 0 0 8 17 18 57 186 0 29 0 0 0 8 17 18 57 48 49 5 34 46 2 53 52 54 51 50 22 21 20 14 2 3 34 6 7 19 54 53 52 38 3 50 54 55 3 6 21 20 30 2 1 13 50 79 56 29 114 100 100 114 29 56 79 50 34 55 19 234 12 77 61 35 55 18 234 12 20 37 51 12 45 85 124 79 159 170 171 158 79 124 85 45 2 87 38 42 254 198 54 74 139 127 253 232 41 42 1 59 54 74 70 102 66 32 0 2 0 44 255 244 1 197 2 74 0 11 0 23 0 53 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 12 0 1 244 184 0 6 16 185 0 18 0 1 244 48 49 23 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 249 94 111 111 94 94 110 110 94 59 65 65 59 60 65 65 12 150 149 149 150 150 149 149 150 66 123 110 110 122 122 110 110 123 0 0 1 0 79 0 0 1 183 2 62 0 12 0 67 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 13 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 2 0 1 244 184 0 8 16 185 0 5 0 1 244 185 0 3 0 1 244 184 0 2 16 184 0 10 208 48 49 51 53 51 17 35 53 62 1 55 51 17 51 21 79 146 116 44 65 26 63 132 68 1 150 53 8 23 16 254 6 68 0 1 0 36 0 0 1 196 2 72 0 29 0 65 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 13 62 89 184 0 0 69 88 184 0 29 47 27 185 0 29 0 5 62 89 185 0 27 0 1 244 184 0 24 208 184 0 1 208 184 0 1 47 184 0 16 16 185 0 9 0 1 244 48 49 51 53 62 3 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 14 2 7 62 1 59 1 21 40 71 111 76 40 58 60 41 68 28 47 40 90 63 88 101 37 67 91 54 26 56 25 176 49 59 97 83 73 35 53 68 44 32 46 45 52 101 84 41 76 80 87 50 2 4 71 0 0 0 0 1 0 26 255 170 1 190 2 74 0 51 0 70 0 184 0 0 69 88 184 0 33 47 27 185 0 33 0 13 62 89 187 0 9 0 1 0 0 0 4 43 186 0 17 0 33 0 0 17 18 57 184 0 17 47 185 0 18 0 1 244 184 0 33 16 185 0 26 0 1 244 186 0 41 0 18 0 17 17 18 57 48 49 23 34 46 2 39 55 30 1 51 50 54 53 52 46 2 35 53 50 62 2 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 3 21 20 14 2 236 38 63 52 41 16 42 29 77 57 58 74 21 48 78 57 51 69 43 18 59 51 40 67 29 44 37 89 57 42 70 51 28 64 52 29 50 38 21 33 57 76 86 15 25 32 18 54 30 45 66 54 28 47 34 19 64 19 33 44 25 47 56 36 29 52 35 45 22 42 61 39 58 77 19 4 7 28 42 55 33 42 69 48 26 0 0 0 2 0 17 255 182 1 213 2 62 0 10 0 19 0 68 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 13 62 89 187 0 12 0 1 0 1 0 4 43 184 0 12 16 184 0 11 208 184 0 3 208 184 0 12 16 184 0 6 208 184 0 1 16 184 0 9 208 186 0 16 0 5 0 0 17 18 57 48 49 5 53 33 53 1 51 17 51 21 35 21 37 51 53 52 54 55 35 6 7 1 48 254 225 1 17 92 87 87 254 234 200 3 2 4 25 27 74 168 55 1 169 254 98 66 168 234 203 26 68 26 50 48 0 0 0 0 1 0 25 255 170 1 193 2 62 0 38 0 60 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 13 62 89 187 0 9 0 1 0 0 0 4 43 186 0 17 0 22 0 0 17 18 57 184 0 22 16 185 0 25 0 1 244 184 0 17 16 185 0 29 0 1 244 48 49 23 34 46 2 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 39 19 33 21 35 7 62 1 51 50 30 2 21 20 14 2 234 38 63 51 41 16 40 28 77 56 29 51 38 22 74 62 33 47 29 44 21 1 63 247 17 23 46 29 41 72 54 31 36 60 77 86 15 25 32 17 52 28 44 21 39 54 34 67 75 19 20 28 1 56 71 194 12 15 24 50 76 52 53 82 56 29 0 255 255 0 49 255 244 1 202 2 138 2 6 4 69 1 0 0 1 0 44 255 182 1 199 2 62 0 14 0 34 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 13 62 89 185 0 5 0 1 244 184 0 9 208 184 0 9 47 48 49 23 62 3 55 33 53 33 21 14 3 7 177 4 24 43 67 47 254 194 1 155 57 71 42 19 4 74 91 153 138 129 66 71 51 73 134 140 156 94 0 255 255 0 41 255 244 1 200 2 138 2 6 4 71 0 0 0 2 0 30 255 170 1 194 2 74 0 13 0 45 0 50 0 184 0 0 69 88 184 0 36 47 27 185 0 36 0 13 62 89 187 0 20 0 1 0 14 0 4 43 187 0 0 0 1 0 28 0 4 43 184 0 36 16 185 0 6 0 1 244 48 49 55 50 54 55 46 1 35 34 14 2 21 20 22 19 34 38 39 55 22 51 50 62 2 55 14 1 35 34 38 53 52 62 2 51 50 30 2 21 20 14 2 229 35 74 32 6 74 65 25 43 31 18 58 38 48 70 32 35 49 62 35 60 45 28 3 31 83 42 89 96 31 53 71 40 52 84 58 31 36 65 90 227 40 46 103 105 22 39 54 33 68 78 254 199 30 27 58 46 27 61 100 74 38 42 108 100 47 79 56 31 43 81 115 73 92 135 89 44 255 255 0 52 255 244 1 205 2 74 0 6 4 87 8 0 0 1 0 50 0 0 0 249 2 62 0 8 0 53 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 13 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 184 0 6 16 185 0 3 0 1 244 185 0 1 0 1 244 48 49 51 17 35 53 62 1 55 51 17 167 117 45 65 26 63 1 218 53 8 23 16 253 194 0 0 0 1 0 41 0 0 1 188 2 72 0 31 0 65 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 13 62 89 184 0 0 69 88 184 0 31 47 27 185 0 31 0 5 62 89 185 0 29 0 1 244 184 0 26 208 184 0 1 208 184 0 1 47 184 0 16 16 185 0 9 0 1 244 48 49 51 53 62 3 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 7 62 1 59 1 21 48 71 108 72 36 55 60 41 63 28 47 40 86 62 44 69 48 25 35 63 89 54 26 56 25 163 49 59 97 83 73 35 53 68 44 32 46 44 53 27 48 68 42 41 76 80 87 50 2 4 71 0 0 255 255 0 26 255 170 1 190 2 74 2 6 4 90 0 0 255 255 0 25 255 182 1 221 2 62 0 6 4 91 8 0 255 255 0 25 255 170 1 193 2 62 2 6 4 92 0 0 255 255 0 57 255 244 1 210 2 138 0 6 4 69 9 0 0 1 0 44 255 182 1 185 2 62 0 14 0 34 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 13 62 89 185 0 5 0 1 244 184 0 9 208 184 0 9 47 48 49 23 62 3 55 33 53 33 21 14 3 7 165 4 23 44 65 47 254 208 1 141 56 71 42 18 4 74 91 154 137 129 66 71 51 73 134 140 155 95 0 255 255 0 49 255 244 1 208 2 138 0 6 4 71 8 0 255 255 0 38 255 170 1 202 2 74 0 6 4 96 8 0 0 2 0 44 255 244 1 197 2 156 0 11 0 29 0 53 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 12 0 1 244 184 0 6 16 185 0 22 0 1 244 48 49 23 34 38 53 52 54 51 50 22 21 20 6 39 50 62 2 53 52 46 2 35 34 6 21 20 30 2 249 94 111 111 94 93 111 111 93 28 45 33 18 18 33 45 28 56 69 18 33 46 12 171 172 171 166 167 170 172 171 66 32 67 105 73 71 103 66 31 129 142 73 105 67 32 0 0 0 1 0 79 0 0 1 183 2 144 0 12 0 67 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 1 0 1 244 184 0 8 16 185 0 5 0 1 244 185 0 3 0 1 244 184 0 1 16 184 0 11 208 48 49 51 53 51 17 35 53 62 1 55 51 17 51 21 79 146 116 44 65 26 63 132 68 1 233 52 8 23 16 253 180 68 0 1 0 36 0 0 1 196 2 156 0 27 0 65 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 17 62 89 184 0 0 69 88 184 0 27 47 27 185 0 27 0 5 62 89 185 0 25 0 1 244 184 0 22 208 184 0 1 208 184 0 1 47 184 0 14 16 185 0 7 0 1 244 48 49 51 53 62 1 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 14 2 7 62 1 59 1 21 40 154 146 60 61 40 68 28 47 40 90 63 89 102 37 67 95 57 26 56 25 181 49 134 204 84 57 73 44 32 46 45 52 106 88 49 99 102 105 54 2 4 71 0 0 0 0 1 0 26 255 244 1 190 2 157 0 51 0 83 0 184 0 0 69 88 184 0 33 47 27 185 0 33 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 9 0 1 244 186 0 17 0 33 0 0 17 18 57 184 0 17 16 185 0 18 0 1 244 184 0 33 16 185 0 26 0 1 244 186 0 42 0 17 0 18 17 18 57 48 49 23 34 46 2 39 55 30 1 51 50 54 53 52 46 2 35 53 50 62 2 53 52 38 39 14 1 7 39 62 1 55 50 30 2 21 20 6 7 21 30 3 21 20 14 2 236 38 63 52 41 16 42 29 77 57 58 74 21 48 78 57 51 69 43 18 59 51 40 67 29 44 37 89 57 42 70 51 28 63 53 29 50 38 21 33 57 76 12 15 25 32 18 54 30 46 66 57 29 48 34 19 63 19 34 46 26 48 56 1 1 36 28 52 35 44 1 23 42 62 39 60 78 19 4 7 29 42 55 34 44 69 48 26 0 0 0 2 0 17 0 0 1 213 2 144 0 10 0 20 0 85 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 12 0 1 0 1 0 4 43 184 0 12 16 184 0 3 208 184 0 3 47 184 0 12 16 184 0 7 208 184 0 1 16 184 0 8 208 186 0 16 0 4 0 0 17 18 57 48 49 33 53 33 53 1 51 17 51 21 35 21 37 51 53 52 54 55 35 14 1 7 1 48 254 225 1 17 92 87 87 254 234 200 3 2 4 12 26 14 181 54 1 165 254 102 65 181 246 200 25 69 26 24 49 24 0 1 0 25 255 244 1 193 2 144 0 38 0 73 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 9 0 1 244 186 0 17 0 22 0 0 17 18 57 184 0 22 16 185 0 24 0 1 244 184 0 17 16 185 0 29 0 1 244 48 49 23 34 46 2 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 39 19 33 21 35 7 62 1 51 50 30 2 21 20 14 2 234 38 63 51 41 16 40 28 77 56 29 51 38 22 74 62 33 47 29 44 21 1 63 247 17 23 46 29 41 72 54 31 36 60 77 12 15 24 31 17 54 29 44 22 40 57 36 71 78 19 19 27 1 51 70 190 13 14 25 51 79 54 54 84 58 30 0 2 0 49 255 244 1 202 2 156 0 32 0 46 0 67 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 25 0 1 0 41 0 4 43 184 0 10 16 185 0 17 0 1 244 184 0 0 16 185 0 33 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 7 62 1 51 50 22 21 20 14 2 39 50 62 2 53 52 38 35 34 6 7 30 1 1 14 47 81 59 34 40 68 87 48 52 75 27 46 19 56 29 34 60 46 28 1 30 80 39 84 98 30 51 69 39 24 40 30 17 58 60 31 72 30 7 72 12 41 81 122 81 96 135 85 39 38 29 51 23 27 28 64 104 76 37 43 103 104 48 78 56 31 65 21 39 55 33 67 78 40 45 102 106 0 1 0 44 0 0 1 199 2 144 0 14 0 55 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 7 16 185 0 5 0 1 244 184 0 9 208 184 0 9 47 48 49 51 62 3 55 33 53 33 21 14 3 7 177 4 23 43 67 48 254 194 1 155 58 71 42 18 4 93 156 140 130 67 70 50 74 135 143 158 96 0 0 3 0 41 255 244 1 200 2 154 0 39 0 52 0 68 0 97 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 61 0 19 0 0 17 18 57 184 0 61 16 185 0 40 0 1 244 186 0 11 0 40 0 61 17 18 57 186 0 29 0 61 0 40 17 18 57 184 0 19 16 185 0 45 0 1 244 184 0 0 16 185 0 53 0 1 244 48 49 23 34 46 2 53 52 62 2 55 53 46 1 53 52 62 2 51 50 30 2 21 20 14 2 7 21 30 3 21 20 14 2 3 54 53 52 38 35 34 6 21 20 30 2 3 50 54 53 52 46 2 39 14 1 21 20 30 2 250 45 77 55 32 21 33 43 23 36 53 28 48 66 39 42 66 47 25 16 26 31 15 22 40 31 18 30 54 76 1 67 58 53 45 58 24 41 53 14 56 69 28 47 63 35 39 50 21 37 50 12 26 47 64 38 33 55 45 35 12 4 26 74 52 37 62 44 24 26 46 63 38 26 47 41 33 11 4 13 32 41 53 34 36 62 46 26 1 112 61 72 48 68 58 48 29 44 33 25 254 193 62 50 33 46 36 28 14 25 75 47 27 44 33 18 0 0 0 0 2 0 40 255 244 1 192 2 156 0 13 0 46 0 67 0 184 0 0 69 88 184 0 37 47 27 185 0 37 0 17 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 187 0 0 0 1 0 29 0 4 43 184 0 37 16 185 0 6 0 1 244 184 0 14 16 185 0 21 0 1 244 48 49 19 50 54 55 46 1 35 34 14 2 21 20 22 19 34 38 39 55 30 1 51 50 62 2 55 14 1 35 34 38 53 52 62 2 51 50 30 2 21 20 14 2 234 34 71 31 6 73 63 23 41 30 17 58 35 54 77 28 46 21 57 32 31 58 45 28 2 29 80 42 82 98 30 51 69 38 47 81 59 33 40 66 86 1 54 41 46 102 105 22 39 55 33 66 79 254 190 38 29 52 23 28 28 65 104 76 37 43 103 103 48 79 55 31 39 78 117 78 100 140 88 40 0 0 0 0 1 0 65 255 244 0 184 0 114 0 11 0 24 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 6 220 48 49 23 34 38 53 52 54 51 50 22 21 20 6 125 25 35 35 25 24 35 35 12 35 27 29 35 35 29 27 35 0 0 1 0 47 255 86 0 198 0 114 0 17 0 24 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 184 0 12 220 48 49 23 39 62 1 39 6 35 34 38 53 52 54 51 50 22 21 20 6 67 20 43 48 1 3 7 24 35 36 25 32 37 70 170 48 19 63 40 1 29 28 27 31 52 45 65 96 255 255 0 65 255 244 0 184 1 219 2 39 4 117 0 0 1 105 0 6 4 117 0 0 255 255 0 47 255 86 0 198 1 219 2 39 4 117 0 0 1 105 0 6 4 118 0 0 255 255 0 94 255 244 3 115 0 114 0 38 4 117 29 0 0 39 4 117 1 108 0 0 0 7 4 117 2 187 0 0 0 2 0 85 255 244 0 204 2 158 0 5 0 17 0 28 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 184 0 12 220 184 0 0 220 48 49 55 3 39 51 7 3 7 34 38 53 52 54 51 50 22 21 20 6 116 11 2 83 2 11 28 25 35 35 25 24 35 35 198 1 122 94 94 254 134 210 35 27 29 35 35 29 27 35 0 2 0 85 255 72 0 204 1 242 0 5 0 17 0 28 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 9 62 89 184 0 6 220 184 0 2 220 48 49 23 55 19 51 19 23 3 34 38 53 52 54 51 50 22 21 20 6 103 2 11 57 11 2 41 25 35 35 25 24 35 35 184 94 1 122 254 134 94 2 44 35 29 27 35 35 27 29 35 0 0 0 0 2 0 38 255 244 1 121 2 170 0 27 0 39 0 42 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 5 62 89 187 0 17 0 1 0 10 0 4 43 184 0 28 16 184 0 34 220 184 0 0 220 48 49 55 38 62 4 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 14 4 23 7 34 38 53 52 54 51 50 22 21 20 6 160 6 17 30 39 34 23 49 48 33 59 23 47 32 85 55 76 91 24 35 39 33 18 4 34 25 34 34 25 25 35 35 198 39 63 53 46 45 46 27 40 57 31 27 43 36 47 85 75 33 54 48 47 50 57 35 210 35 27 29 35 35 29 27 35 0 0 0 0 2 0 48 255 60 1 131 1 242 0 27 0 39 0 42 0 184 0 0 69 88 184 0 34 47 27 185 0 34 0 9 62 89 187 0 21 0 1 0 0 0 4 43 184 0 34 16 184 0 28 220 184 0 10 220 48 49 23 34 38 53 52 62 4 39 51 22 14 4 21 20 22 51 50 54 55 23 14 1 3 34 38 53 52 54 51 50 22 21 20 6 215 76 91 24 35 39 32 18 4 73 5 16 30 39 34 23 48 49 33 58 23 48 32 85 43 25 35 35 25 24 35 35 196 85 75 33 54 48 47 50 57 35 39 63 53 46 45 47 26 40 56 30 27 43 35 48 2 56 35 29 27 35 35 27 29 35 0 0 0 1 0 80 1 175 0 168 2 178 0 5 0 11 0 186 0 2 0 0 0 3 43 48 49 19 47 1 51 15 1 99 16 3 88 3 16 1 175 167 92 92 167 0 255 255 0 80 1 175 1 88 2 178 0 38 4 126 0 0 0 7 4 126 0 176 0 0 0 1 0 57 1 172 0 187 2 184 0 17 0 13 0 187 0 12 0 2 0 0 0 4 43 48 49 19 34 38 53 52 54 55 23 14 1 21 54 51 50 22 21 20 6 120 30 33 54 52 24 38 38 3 6 20 33 30 1 172 46 44 60 88 30 39 25 57 42 1 26 25 26 29 0 0 0 1 0 63 1 175 0 193 2 187 0 17 0 13 0 187 0 12 0 2 0 6 0 4 43 48 49 19 39 62 1 53 6 35 34 38 53 52 54 51 50 22 21 20 6 86 23 38 37 3 5 21 32 30 23 29 34 55 1 175 38 25 57 43 1 26 24 26 30 47 44 60 87 0 0 0 255 255 0 57 1 172 1 107 2 184 0 38 4 128 0 0 0 7 4 128 0 176 0 0 255 255 0 63 1 175 1 113 2 187 0 38 4 129 0 0 0 7 4 129 0 176 0 0 255 255 0 63 255 112 0 193 0 124 2 7 4 129 0 0 253 193 0 0 255 255 0 63 255 112 1 113 0 124 0 39 4 129 0 0 253 193 0 7 4 129 0 176 253 193 0 0 0 1 0 45 0 66 0 217 1 182 0 6 0 11 0 186 0 3 0 0 0 3 43 48 49 55 39 53 55 23 7 23 181 136 136 36 118 118 66 155 62 155 30 156 158 0 0 0 0 1 0 54 0 66 0 226 1 182 0 6 0 11 0 186 0 4 0 0 0 3 43 48 49 55 39 55 39 55 23 21 89 35 118 118 35 137 66 28 158 156 30 155 62 0 0 0 255 255 0 45 0 66 1 119 1 182 0 38 4 134 0 0 0 7 4 134 0 158 0 0 255 255 0 54 0 66 1 128 1 182 0 38 4 135 0 0 0 7 4 135 0 158 0 0 0 1 0 41 0 219 1 15 1 26 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 55 53 51 21 41 230 219 63 63 255 255 0 41 0 219 1 15 1 26 2 6 4 138 0 0 0 1 0 41 0 223 1 183 1 24 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 55 53 33 21 41 1 142 223 57 57 0 0 0 0 1 0 41 0 223 2 247 1 24 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 55 53 33 21 41 2 206 223 57 57 0 0 0 0 1 0 41 0 223 5 179 1 24 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 55 53 33 21 41 5 138 223 57 57 0 0 0 0 1 0 41 0 223 8 111 1 24 0 3 0 13 0 187 0 0 0 1 0 1 0 4 43 48 49 1 21 33 53 8 111 247 186 1 24 57 57 0 0 1 0 41 0 223 1 201 1 24 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 55 53 33 21 41 1 160 223 57 57 0 0 0 255 255 0 41 0 223 2 247 1 24 2 6 4 141 0 0 255 255 0 65 1 3 0 184 1 129 2 7 4 117 0 0 1 15 0 0 0 1 0 40 0 143 1 8 1 128 0 19 0 11 0 186 0 10 0 0 0 3 43 48 49 55 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 152 23 40 31 18 18 31 40 23 22 41 31 18 18 31 41 143 17 32 44 27 27 45 31 18 18 31 45 27 27 44 32 17 0 0 0 1 0 12 255 130 1 232 255 185 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 23 53 33 21 12 1 220 126 55 55 0 0 0 0 1 0 12 2 56 1 232 2 111 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 19 53 33 21 12 1 220 2 56 55 55 0 0 0 1 254 58 255 23 1 198 255 192 0 13 0 13 0 187 0 7 0 1 0 0 0 4 43 48 49 21 34 38 39 55 30 1 51 50 54 55 23 14 1 128 225 101 24 96 225 109 109 225 96 24 101 225 233 65 63 41 58 53 53 58 41 63 65 0 0 0 0 1 0 82 255 80 1 9 2 220 0 13 0 11 0 186 0 6 0 0 0 3 43 48 49 23 46 1 53 52 54 55 23 14 1 21 20 22 23 214 62 70 70 62 51 58 57 57 58 176 100 222 132 132 221 101 24 96 219 115 115 219 96 0 0 1 0 38 255 80 0 221 2 220 0 13 0 11 0 186 0 8 0 0 0 3 43 48 49 23 39 62 1 53 52 38 39 55 30 1 21 20 6 89 51 58 57 57 58 51 62 70 70 176 24 96 219 115 115 219 96 24 101 221 132 132 222 0 0 1 0 94 255 104 1 17 2 196 0 7 0 23 0 187 0 5 0 1 0 0 0 4 43 187 0 2 0 1 0 3 0 4 43 48 49 23 17 51 21 35 17 51 21 94 179 117 117 152 3 92 47 253 2 47 0 1 0 31 255 104 0 209 2 196 0 7 0 23 0 187 0 1 0 1 0 0 0 4 43 187 0 6 0 1 0 3 0 4 43 48 49 23 53 51 17 35 53 51 17 31 116 116 178 152 47 2 254 47 252 164 0 1 0 34 255 104 1 17 2 196 0 49 0 43 0 187 0 47 0 1 0 0 0 4 43 187 0 26 0 1 0 27 0 4 43 187 0 14 0 1 0 13 0 4 43 186 0 38 0 13 0 14 17 18 57 48 49 23 34 38 53 52 62 2 53 52 46 2 35 53 50 62 2 53 52 38 53 52 54 59 1 21 35 34 6 21 20 22 21 20 6 7 21 30 1 21 20 6 21 20 22 59 1 21 228 59 58 3 3 3 8 19 34 25 25 34 19 8 9 58 59 45 27 41 27 6 28 32 32 28 6 27 41 27 152 56 77 27 49 46 46 25 15 27 22 14 52 14 21 28 14 51 88 55 77 56 47 42 49 46 84 51 49 51 9 4 9 52 48 51 84 46 49 42 47 0 0 1 0 31 255 104 1 13 2 196 0 51 0 43 0 187 0 1 0 1 0 0 0 4 43 187 0 24 0 1 0 21 0 4 43 187 0 35 0 1 0 36 0 4 43 186 0 12 0 36 0 35 17 18 57 48 49 23 53 51 50 54 53 52 38 53 52 54 55 53 46 1 53 52 54 53 52 38 43 1 53 51 50 30 2 21 20 6 21 20 22 23 21 34 14 2 21 20 30 2 21 20 14 2 35 31 26 41 27 5 27 32 32 27 5 27 41 26 44 30 44 29 14 9 36 50 25 33 20 8 3 3 3 14 29 44 30 152 47 42 49 46 84 51 48 52 9 4 9 51 49 51 84 46 49 42 47 13 30 51 39 55 88 51 29 47 1 52 14 22 27 15 25 46 46 49 27 39 51 30 13 0 0 0 0 1 0 10 255 96 1 81 2 198 0 3 0 24 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 19 62 89 184 0 0 220 48 49 23 1 51 1 10 1 11 60 254 245 160 3 102 252 154 0 0 0 0 1 0 92 255 6 0 150 2 238 0 3 0 11 0 186 0 1 0 0 0 3 43 48 49 23 17 51 17 92 58 250 3 232 252 24 0 1 0 14 255 96 1 84 2 198 0 3 0 24 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 19 62 89 184 0 0 220 48 49 5 1 51 1 1 25 254 245 59 1 11 160 3 102 252 154 0 0 0 2 0 92 255 6 0 150 2 238 0 3 0 7 0 11 0 186 0 1 0 4 0 3 43 48 49 19 17 51 17 3 17 51 17 92 58 58 58 1 35 1 203 254 53 253 227 1 208 254 48 0 0 1 0 58 1 164 1 104 2 200 0 14 0 20 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 19 62 89 48 49 19 39 55 39 55 23 55 51 23 55 23 7 23 7 39 138 40 57 97 15 102 9 49 9 103 15 97 56 39 71 1 164 29 94 40 46 25 108 107 24 46 40 94 29 86 0 0 1 0 54 255 176 1 144 2 200 0 11 0 54 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 19 62 89 187 0 3 0 1 0 1 0 4 43 184 0 3 16 184 0 7 208 184 0 7 47 184 0 1 16 184 0 9 208 184 0 9 47 48 49 23 19 7 53 23 39 51 7 55 21 39 19 192 5 143 143 5 70 5 143 143 5 80 2 59 5 71 5 160 160 5 71 5 253 197 0 0 1 0 54 255 176 1 144 2 200 0 21 0 88 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 19 62 89 187 0 3 0 1 0 1 0 4 43 187 0 8 0 1 0 6 0 4 43 184 0 8 16 184 0 12 208 184 0 12 47 184 0 6 16 184 0 14 208 184 0 14 47 184 0 3 16 184 0 17 208 184 0 17 47 184 0 1 16 184 0 19 208 184 0 19 47 48 49 23 55 7 53 23 39 55 7 53 23 39 51 7 55 21 39 23 7 55 21 39 23 192 5 143 143 5 5 143 143 5 70 5 143 143 5 5 143 143 5 80 160 5 71 7 177 177 7 71 5 160 160 5 71 7 177 177 7 71 5 160 0 0 2 0 45 255 192 1 196 2 172 0 15 0 71 0 23 0 187 0 23 0 1 0 16 0 4 43 187 0 44 0 1 0 51 0 4 43 48 49 19 20 30 2 23 62 1 53 52 46 2 39 14 1 19 34 38 39 55 30 1 51 50 54 53 52 46 4 53 52 54 55 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 30 4 21 20 6 7 30 1 21 20 14 2 117 40 61 71 31 29 31 40 60 71 31 29 32 119 54 88 31 50 25 58 40 40 45 41 61 72 61 41 48 38 15 17 19 39 56 38 48 77 29 40 24 54 33 42 37 41 62 71 62 41 47 38 14 16 24 43 59 1 92 33 43 32 29 18 14 38 33 34 44 33 28 18 16 40 254 69 38 33 45 24 28 40 29 28 38 30 29 42 61 46 44 64 21 16 40 26 26 47 36 21 34 23 53 20 26 37 26 27 36 30 30 43 61 46 48 59 22 17 39 26 30 50 36 21 0 0 0 0 2 0 41 255 176 1 208 2 144 0 3 0 16 0 37 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 17 62 89 48 49 5 17 51 17 3 34 46 2 53 52 62 2 59 1 17 1 124 84 171 54 93 67 38 36 65 88 52 44 80 2 224 253 32 1 50 25 53 82 57 59 81 51 22 254 82 0 0 0 2 0 92 255 6 1 43 2 238 0 3 0 7 0 27 0 186 0 1 0 0 0 3 43 184 0 0 16 184 0 4 208 184 0 1 16 184 0 5 208 48 49 23 17 51 17 51 17 51 17 92 58 91 58 250 3 232 252 24 3 232 252 24 255 255 0 85 255 244 1 208 2 158 0 38 4 122 0 0 0 7 4 122 1 4 0 0 255 255 0 38 255 244 2 255 2 170 0 38 4 124 0 0 0 7 4 124 1 134 0 0 255 255 0 85 255 244 2 119 2 170 0 38 4 122 0 0 0 7 4 124 0 254 0 0 255 255 0 38 255 244 2 82 2 170 0 38 4 124 0 0 0 7 4 122 1 134 0 0 0 2 0 27 255 244 1 129 2 170 0 32 0 44 0 60 0 184 0 0 69 88 184 0 33 47 27 185 0 33 0 5 62 89 187 0 20 0 1 0 13 0 4 43 184 0 33 16 184 0 39 220 184 0 0 220 184 0 13 16 184 0 2 220 186 0 5 0 20 0 0 17 18 57 48 49 55 47 1 51 21 7 62 3 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 4 23 7 34 38 53 52 54 51 50 22 21 20 6 171 10 5 70 5 13 30 26 18 55 53 36 63 27 47 35 90 54 40 67 46 26 25 38 43 34 20 4 31 25 34 34 25 25 35 35 198 251 83 65 133 23 40 41 46 28 44 61 31 33 43 41 45 23 42 58 34 37 60 51 47 47 53 32 210 35 27 29 35 35 29 27 35 0 1 0 94 0 0 1 17 2 177 0 5 0 13 0 187 0 2 0 1 0 3 0 4 43 48 49 51 17 51 21 35 17 94 179 117 2 177 47 253 126 0 0 0 0 1 0 31 0 0 0 209 2 177 0 5 0 13 0 187 0 4 0 1 0 1 0 4 43 48 49 51 17 35 53 51 17 147 116 178 2 130 47 253 79 0 0 0 0 1 0 94 255 204 1 17 2 126 0 5 0 13 0 187 0 3 0 1 0 0 0 4 43 48 49 23 17 51 17 51 21 94 62 117 52 2 178 253 125 47 0 0 0 1 0 31 255 204 0 209 2 126 0 5 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 23 53 51 17 51 17 31 116 62 52 47 2 131 253 78 0 0 0 2 0 94 255 104 1 91 2 196 0 7 0 11 0 39 0 187 0 8 0 1 0 0 0 4 43 187 0 2 0 1 0 3 0 4 43 184 0 8 16 184 0 5 208 184 0 3 16 184 0 10 208 48 49 23 17 51 21 35 17 51 21 39 51 17 35 94 253 110 110 202 45 45 152 3 92 47 253 2 47 47 2 254 0 2 0 31 255 104 1 28 2 196 0 7 0 11 0 39 0 187 0 1 0 1 0 0 0 4 43 187 0 5 0 1 0 4 0 4 43 184 0 1 16 184 0 8 208 184 0 4 16 184 0 10 208 48 49 23 53 51 17 35 53 51 17 39 51 17 35 31 110 110 253 96 44 44 152 47 2 254 47 252 164 47 2 254 0 1 0 94 1 22 1 17 2 196 0 5 0 13 0 187 0 2 0 1 0 3 0 4 43 48 49 19 17 51 21 35 17 94 179 117 1 22 1 174 47 254 129 0 0 1 0 31 1 22 0 209 2 196 0 5 0 13 0 187 0 4 0 1 0 1 0 4 43 48 49 19 17 35 53 51 17 147 116 178 1 22 1 127 47 254 82 0 0 1 0 94 255 104 1 17 1 22 0 5 0 13 0 187 0 3 0 1 0 0 0 4 43 48 49 23 17 51 17 51 21 94 62 117 152 1 174 254 129 47 0 0 0 1 0 31 255 104 0 209 1 22 0 5 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 23 53 51 17 51 17 31 116 62 152 47 1 127 254 82 0 0 0 3 0 49 255 245 2 183 2 141 0 19 0 39 0 69 0 68 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 30 0 1 0 10 0 4 43 184 0 0 16 185 0 20 0 1 244 184 0 40 220 184 0 30 16 184 0 50 220 185 0 57 0 1 244 184 0 40 16 185 0 63 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 55 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 23 14 1 1 116 65 118 88 52 52 88 118 65 65 117 89 52 52 89 117 65 57 100 75 44 44 75 100 57 57 100 75 44 44 75 100 65 38 66 50 28 31 51 67 36 42 59 24 35 20 41 26 55 67 65 54 32 48 22 30 28 62 11 47 87 123 77 76 122 86 46 46 86 122 76 77 123 87 47 42 42 77 107 66 65 107 76 41 41 76 107 65 66 107 77 42 94 27 51 73 47 43 70 50 26 33 24 39 20 21 75 59 66 77 25 19 42 24 33 0 0 0 4 0 49 255 245 2 183 2 141 0 19 0 39 0 54 0 63 0 60 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 10 0 1 0 30 0 4 43 187 0 63 0 1 0 41 0 4 43 187 0 56 0 1 0 52 0 4 43 184 0 0 16 185 0 20 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 39 17 51 50 30 2 21 20 14 2 43 1 21 53 51 50 54 53 52 38 43 1 1 116 65 118 88 52 52 88 118 65 65 117 89 52 52 89 117 65 57 100 75 44 44 75 100 57 57 100 75 44 44 75 100 62 138 31 54 40 23 23 40 54 31 73 62 45 49 49 45 62 11 47 87 123 77 76 122 86 46 46 86 122 76 77 123 87 47 42 42 77 107 66 65 107 76 41 41 76 107 65 66 107 77 42 106 1 107 14 28 45 30 33 49 33 16 115 165 37 42 36 32 0 0 4 0 23 1 63 1 144 2 201 0 19 0 39 0 53 0 61 0 87 0 184 0 53 47 184 0 42 47 184 0 53 16 184 0 20 220 185 0 0 0 1 244 184 0 42 16 184 0 30 220 185 0 10 0 1 244 186 0 51 0 53 0 42 17 18 57 184 0 51 47 185 0 55 0 1 244 186 0 48 0 55 0 51 17 18 57 184 0 53 16 184 0 50 208 184 0 42 16 185 0 60 0 1 244 48 49 19 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 39 53 51 50 22 21 20 6 7 23 35 39 35 21 53 51 50 53 52 38 43 1 211 39 68 51 30 30 51 68 39 39 69 51 30 30 51 69 39 31 55 40 23 23 40 55 31 32 54 39 23 23 39 54 40 76 32 46 20 17 46 46 35 41 26 43 18 23 28 1 63 29 52 72 44 44 72 52 29 29 52 72 44 44 72 52 29 37 23 42 59 36 35 59 43 24 24 43 59 35 36 59 42 23 61 203 29 36 18 31 6 83 70 70 102 34 15 18 0 0 0 0 2 0 3 1 110 2 96 2 164 0 7 0 27 0 93 0 184 0 27 47 184 0 24 47 184 0 1 208 184 0 27 16 184 0 19 208 186 0 15 0 19 0 1 17 18 57 184 0 15 47 185 0 4 0 1 244 184 0 1 16 184 0 7 208 184 0 19 16 184 0 10 208 184 0 7 16 185 0 13 0 1 244 184 0 1 16 185 0 17 0 1 244 184 0 24 16 185 0 26 0 1 244 184 0 21 208 48 49 19 17 35 53 33 21 35 17 51 17 51 31 1 51 63 1 51 17 35 53 55 35 7 35 39 35 23 21 102 99 1 3 100 148 73 47 28 4 28 46 72 55 7 4 73 47 73 4 7 1 110 1 0 54 54 255 0 1 54 116 78 78 116 254 202 137 105 194 194 105 137 0 2 0 27 1 98 2 96 2 171 0 41 0 61 0 123 0 184 0 61 47 184 0 43 47 184 0 61 16 184 0 0 208 184 0 0 47 185 0 7 0 1 244 184 0 43 16 184 0 20 208 184 0 20 47 186 0 10 0 0 0 20 17 18 57 185 0 27 0 1 244 186 0 30 0 20 0 0 17 18 57 186 0 57 0 61 0 43 17 18 57 184 0 57 47 185 0 46 0 1 244 184 0 43 16 184 0 49 208 184 0 61 16 184 0 52 208 184 0 49 16 185 0 55 0 1 244 184 0 43 16 185 0 59 0 1 244 48 49 19 34 38 39 55 30 1 51 50 54 53 52 38 47 1 46 1 53 52 54 51 50 22 23 7 46 1 35 34 6 21 20 22 31 1 30 1 21 20 14 2 55 17 51 31 1 51 63 1 51 17 35 53 55 35 7 35 39 35 23 21 140 33 57 23 33 18 41 25 23 26 21 22 47 23 37 58 47 28 50 17 29 16 36 17 23 24 22 20 46 29 34 15 29 40 145 73 47 28 4 28 46 72 55 7 4 73 47 73 4 7 1 98 25 23 37 17 21 21 18 20 15 11 23 11 40 35 39 49 22 16 39 12 18 23 15 15 19 9 23 13 39 35 18 32 26 15 12 1 54 116 78 78 116 254 202 137 105 194 194 105 137 0 0 0 0 2 0 28 1 98 2 126 2 171 0 19 0 49 0 75 0 187 0 43 0 1 0 20 0 4 43 187 0 30 0 1 0 37 0 4 43 187 0 5 0 1 0 14 0 4 43 184 0 30 16 184 0 1 208 184 0 1 47 184 0 30 16 184 0 7 208 184 0 7 47 184 0 2 208 184 0 7 16 185 0 13 0 1 244 184 0 16 208 48 49 19 17 51 31 1 51 63 1 51 17 35 53 55 35 7 35 39 35 23 21 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 23 14 1 28 73 47 28 4 28 46 72 55 7 4 73 47 73 4 7 1 196 31 53 39 22 23 40 54 31 30 48 14 32 13 26 19 35 54 52 36 21 30 14 33 20 50 1 110 1 54 116 78 78 116 254 202 137 105 194 194 105 137 12 22 42 61 39 38 61 43 23 23 16 37 13 14 58 56 57 60 16 16 34 22 25 0 0 0 0 3 0 28 1 110 2 134 2 164 0 19 0 28 0 37 0 91 0 187 0 29 0 1 0 28 0 4 43 187 0 22 0 1 0 36 0 4 43 184 0 28 16 184 0 0 208 184 0 22 16 184 0 1 208 184 0 22 16 184 0 7 208 184 0 2 208 184 0 29 16 184 0 14 208 184 0 14 47 185 0 5 0 1 244 184 0 28 16 184 0 9 208 184 0 7 16 185 0 13 0 1 244 184 0 16 208 48 49 19 17 51 31 1 51 63 1 51 17 35 53 55 35 7 35 39 35 23 21 33 17 51 50 22 21 20 6 35 39 51 50 54 53 52 38 43 1 28 73 47 28 4 28 46 72 55 7 4 73 47 73 4 7 1 62 92 74 78 78 72 34 31 46 46 46 47 30 1 110 1 54 116 78 78 116 254 202 137 105 194 194 105 137 1 54 79 73 75 83 47 58 53 51 54 0 2 0 51 255 101 3 28 2 134 0 69 0 84 0 99 0 187 0 64 0 1 0 0 0 4 43 187 0 70 0 1 0 27 0 4 43 187 0 35 0 1 0 77 0 4 43 187 0 10 0 1 0 54 0 4 43 184 0 27 16 184 0 20 208 186 0 23 0 27 0 35 17 18 57 186 0 38 0 35 0 27 17 18 57 184 0 70 16 184 0 44 208 184 0 23 16 185 0 73 0 1 244 184 0 38 16 185 0 74 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 35 34 38 39 35 14 1 35 34 38 53 52 62 2 51 50 22 23 51 55 51 7 6 51 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 51 50 54 55 23 6 3 50 54 63 1 46 1 35 34 14 2 21 20 22 1 147 74 128 95 55 67 115 151 84 76 121 85 46 37 58 71 34 41 57 5 2 25 64 33 51 69 27 50 71 44 26 40 14 2 11 55 39 30 84 24 47 39 24 35 70 104 68 67 126 98 59 45 80 109 64 46 82 34 22 85 123 21 45 26 29 14 30 20 30 47 33 17 40 155 46 91 134 87 100 164 116 63 48 87 122 74 66 99 67 34 38 38 29 39 72 69 40 83 67 42 23 25 40 200 117 28 53 77 49 60 103 74 42 55 100 142 88 73 114 78 41 25 20 49 51 1 12 28 31 159 23 19 32 50 60 28 48 42 0 0 0 0 2 0 51 255 232 2 220 2 176 0 73 0 87 0 107 0 187 0 67 0 1 0 0 0 4 43 187 0 10 0 1 0 57 0 4 43 187 0 74 0 1 0 27 0 4 43 187 0 80 0 1 0 37 0 4 43 184 0 27 16 184 0 20 208 184 0 20 47 186 0 23 0 27 0 37 17 18 57 186 0 40 0 37 0 27 17 18 57 184 0 74 16 184 0 47 208 184 0 47 47 184 0 23 16 185 0 76 0 1 244 184 0 40 16 185 0 77 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 35 34 38 39 35 14 1 35 34 46 2 53 52 62 2 51 50 22 23 51 55 51 7 6 22 51 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 51 50 54 55 23 14 1 39 50 63 1 46 1 35 34 14 2 21 20 22 1 111 65 114 87 50 62 105 139 78 67 109 78 43 31 52 66 34 38 48 5 2 23 62 35 22 39 30 17 25 47 68 42 24 39 13 2 12 56 40 14 21 35 19 42 33 22 32 62 92 61 61 114 89 53 41 71 96 55 35 68 28 23 38 78 57 40 49 27 14 26 20 27 43 30 16 34 24 39 78 118 79 90 147 104 57 42 76 107 66 60 93 63 33 41 36 29 40 18 34 48 29 38 78 63 40 23 25 40 178 60 54 24 48 71 46 54 89 64 35 48 90 126 78 68 99 65 32 17 17 46 22 19 236 58 137 23 18 29 46 55 26 41 39 0 2 0 35 0 0 1 211 2 138 0 27 0 31 0 155 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 15 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 5 62 89 187 0 4 0 1 0 1 0 4 43 187 0 8 0 1 0 5 0 4 43 184 0 8 16 184 0 11 208 184 0 8 16 184 0 15 208 184 0 5 16 184 0 17 208 184 0 4 16 184 0 19 208 184 0 1 16 184 0 21 208 184 0 1 16 184 0 25 208 184 0 4 16 184 0 28 208 184 0 5 16 184 0 30 208 48 49 51 55 35 53 51 55 35 53 51 55 51 7 51 55 51 7 51 21 35 7 51 21 35 7 35 55 35 7 19 51 55 35 90 25 80 87 18 85 92 23 53 23 133 24 53 24 81 87 18 85 92 25 53 24 132 25 32 132 18 132 204 57 148 58 183 183 183 183 58 148 57 204 204 204 1 5 148 255 255 0 67 0 0 0 181 2 180 2 6 0 36 0 0 0 2 0 3 0 0 1 212 2 6 0 9 0 17 0 84 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 11 62 89 184 0 0 69 88 184 0 17 47 27 185 0 17 0 5 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 5 62 89 186 0 2 0 11 0 17 17 18 57 184 0 2 47 186 0 7 0 11 0 17 17 18 57 185 0 16 0 1 244 48 49 19 7 51 39 46 1 39 35 14 1 3 19 51 19 35 39 35 7 180 24 156 24 14 24 14 4 14 24 191 185 94 186 88 48 197 48 1 26 74 74 43 83 43 44 82 254 187 2 6 253 250 146 146 0 0 0 0 3 0 90 0 0 1 229 2 6 0 19 0 28 0 37 0 87 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 186 0 36 0 1 0 19 17 18 57 184 0 36 47 185 0 21 0 1 244 186 0 10 0 21 0 36 17 18 57 184 0 1 16 185 0 27 0 1 244 184 0 19 16 185 0 30 0 1 244 48 49 51 17 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 35 3 51 50 54 53 52 38 43 1 17 51 50 54 53 52 38 43 1 90 170 43 71 52 29 45 45 55 65 31 57 78 46 100 78 69 58 62 62 81 90 65 77 73 69 90 2 6 14 30 49 35 38 61 12 4 11 59 54 39 56 38 18 1 43 42 40 40 35 254 118 43 51 45 42 0 0 0 0 1 0 52 255 244 1 215 2 18 0 29 0 57 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 17 0 1 244 184 0 0 16 185 0 23 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 23 14 1 1 42 53 90 66 37 39 67 93 54 50 79 26 47 22 51 34 77 92 88 77 39 59 25 46 34 85 12 36 69 100 65 63 101 71 37 40 26 51 22 25 106 94 95 107 29 26 50 37 38 0 0 0 0 2 0 90 0 0 1 247 2 6 0 8 0 17 0 53 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 185 0 10 0 1 244 184 0 1 16 185 0 16 0 1 244 48 49 51 17 51 50 22 21 20 6 35 39 51 50 54 53 52 38 43 1 90 143 129 141 140 126 64 62 93 89 89 93 62 2 6 129 128 129 132 65 99 97 91 100 0 0 1 0 90 0 0 1 170 2 6 0 11 0 77 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 184 0 1 16 185 0 3 0 1 244 186 0 7 0 1 0 11 17 18 57 184 0 7 47 185 0 5 0 1 244 184 0 11 16 185 0 9 0 1 244 48 49 51 17 33 21 35 21 51 21 35 21 51 21 90 1 70 243 206 206 253 2 6 66 150 63 173 66 0 0 0 0 1 0 90 0 0 1 161 2 6 0 9 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 187 0 6 0 1 0 7 0 4 43 184 0 1 16 185 0 3 0 1 244 48 49 51 17 33 21 35 21 51 21 35 21 90 1 71 244 207 207 2 6 68 163 64 223 0 0 0 0 1 0 52 255 244 1 227 2 18 0 33 0 79 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 17 0 1 244 184 0 0 16 185 0 23 0 1 244 186 0 28 0 10 0 0 17 18 57 125 184 0 28 47 24 185 0 30 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 53 35 53 51 21 14 1 1 51 56 93 68 38 39 70 96 56 57 78 26 46 21 53 40 81 96 90 87 29 48 16 112 188 29 90 12 36 69 100 65 64 101 70 37 41 24 51 20 26 106 96 94 107 14 14 127 61 226 26 33 0 0 0 1 0 90 0 0 1 248 2 6 0 11 0 81 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 11 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 187 0 4 0 1 0 9 0 4 43 48 49 51 17 51 21 51 53 51 17 35 53 35 21 90 83 248 83 83 248 2 6 211 211 253 250 235 235 0 0 0 0 1 0 90 0 0 0 173 2 6 0 3 0 37 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 48 49 51 17 51 17 90 83 2 6 253 250 0 0 0 0 1 0 31 255 244 1 95 2 6 0 15 0 43 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 5 0 1 244 48 49 23 34 39 55 22 51 50 54 53 17 51 17 20 14 2 190 107 52 58 36 57 42 43 84 19 39 61 12 88 41 58 47 57 1 99 254 151 35 61 46 27 0 0 0 1 0 90 0 0 1 254 2 6 0 12 0 101 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 11 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 186 0 4 0 8 0 1 17 18 57 186 0 7 0 1 0 8 17 18 57 186 0 10 0 8 0 1 17 18 57 48 49 51 17 51 21 51 55 51 7 19 35 3 7 21 90 83 3 218 92 173 197 89 158 90 2 6 246 246 200 254 194 1 4 95 165 0 0 0 0 1 0 90 0 0 1 154 2 6 0 5 0 43 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 185 0 3 0 1 244 48 49 51 17 51 17 51 21 90 83 237 2 6 254 63 69 0 0 1 0 90 0 0 2 45 2 6 0 29 0 111 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 11 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 184 0 0 69 88 184 0 29 47 27 185 0 29 0 5 62 89 186 0 4 0 1 0 29 17 18 57 186 0 16 0 9 0 7 17 18 57 186 0 19 0 1 0 9 17 18 57 186 0 23 0 1 0 29 17 18 57 48 49 51 17 51 19 23 51 55 19 51 17 35 17 52 62 2 55 35 15 1 35 47 1 35 30 3 21 17 90 93 102 37 4 38 100 93 75 2 2 3 2 4 45 99 40 99 45 4 1 4 3 2 2 6 254 248 103 103 1 8 253 250 1 0 18 42 43 43 18 117 253 253 117 18 42 44 42 18 255 0 0 1 0 90 0 0 1 239 2 6 0 19 0 91 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 11 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 186 0 5 0 11 0 9 17 18 57 186 0 15 0 1 0 19 17 18 57 48 49 51 17 51 19 23 51 46 1 61 1 51 17 35 3 39 35 30 1 29 1 90 84 191 60 4 3 8 77 83 192 60 4 3 8 2 6 254 206 111 39 93 42 243 253 250 1 50 111 41 89 42 245 0 0 0 0 2 0 52 255 244 2 26 2 18 0 19 0 31 0 53 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 20 0 1 244 184 0 10 16 185 0 26 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 1 39 54 89 64 36 36 64 89 54 53 89 65 36 36 65 89 53 72 85 85 72 72 85 85 12 38 70 102 63 63 100 69 37 37 69 100 63 63 102 70 38 70 109 94 94 105 105 94 94 109 0 2 0 90 0 0 1 220 2 6 0 14 0 23 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 187 0 16 0 1 0 12 0 4 43 184 0 1 16 185 0 22 0 1 244 48 49 51 17 51 50 30 2 21 20 14 2 43 1 21 17 51 50 54 53 52 38 43 1 90 177 46 77 55 31 31 56 76 46 94 88 69 65 67 69 86 2 6 16 37 60 44 42 63 40 20 196 1 0 50 51 53 42 0 0 0 0 2 0 51 255 103 2 35 2 18 0 11 0 44 0 75 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 11 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 5 62 89 187 0 38 0 1 0 12 0 4 43 184 0 15 16 185 0 0 0 1 244 184 0 25 16 185 0 6 0 1 244 184 0 15 16 184 0 35 208 48 49 37 50 54 53 52 38 35 34 6 21 20 22 23 34 38 39 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 30 1 51 50 54 55 23 14 1 1 38 72 85 85 72 72 85 85 241 81 106 25 45 74 52 29 36 64 89 54 53 89 65 36 29 53 73 45 19 69 47 18 29 12 16 14 44 54 110 97 94 105 105 94 96 111 207 81 63 7 44 69 93 57 63 100 69 37 37 69 100 63 57 93 69 44 7 42 34 5 4 62 7 8 0 0 0 2 0 90 0 0 1 231 2 6 0 15 0 23 0 84 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 187 0 17 0 1 0 13 0 4 43 186 0 10 0 17 0 13 17 18 57 184 0 1 16 185 0 22 0 1 244 48 49 51 17 51 50 30 2 21 20 6 7 23 35 39 35 21 17 51 50 53 52 38 43 1 90 179 43 73 53 30 65 54 138 89 129 96 87 129 67 63 86 2 6 15 36 58 42 59 75 15 218 208 208 1 12 94 50 40 0 0 0 0 1 0 42 255 244 1 180 2 18 0 49 0 73 0 184 0 0 69 88 184 0 26 47 27 185 0 26 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 186 0 16 0 0 0 26 17 18 57 184 0 26 16 185 0 33 0 1 244 186 0 40 0 26 0 0 17 18 57 48 49 23 34 38 39 55 30 1 51 50 54 53 52 46 2 47 1 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 31 1 30 3 21 20 14 2 243 63 101 37 44 33 81 46 51 55 13 23 31 18 65 27 47 35 21 27 48 66 39 57 86 29 43 26 66 38 45 51 45 40 66 28 48 35 19 27 50 71 12 42 33 57 30 36 44 35 19 26 19 15 8 26 10 26 33 44 28 32 53 37 21 38 25 54 23 28 38 35 31 34 16 26 11 23 33 45 33 32 56 40 23 0 0 1 0 28 0 0 1 183 2 6 0 7 0 51 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 3 16 185 0 2 0 1 244 184 0 5 208 48 49 51 17 35 53 33 21 35 17 192 164 1 155 164 1 193 69 69 254 63 0 1 0 87 255 244 1 240 2 6 0 25 0 51 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 13 0 1 244 184 0 6 16 184 0 19 208 48 49 5 34 46 2 53 17 51 17 20 30 2 51 50 62 2 53 17 51 17 20 14 2 1 36 44 75 55 31 83 18 33 45 27 27 45 33 19 79 30 54 75 12 23 54 87 64 1 46 254 209 45 60 36 16 16 36 60 45 1 47 254 210 64 87 54 23 0 0 1 0 0 0 0 1 191 2 6 0 13 0 55 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 5 62 89 186 0 6 0 1 0 13 17 18 57 184 0 1 16 184 0 11 208 48 49 51 3 51 19 30 1 23 51 62 1 55 19 51 3 176 176 87 85 14 24 14 4 15 23 14 83 84 175 2 6 254 244 45 80 45 45 80 45 1 12 253 250 0 0 1 0 23 0 0 2 148 2 6 0 33 0 83 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 33 47 27 185 0 33 0 5 62 89 184 0 23 208 186 0 7 0 23 0 1 17 18 57 184 0 1 16 184 0 11 208 184 0 21 208 186 0 16 0 23 0 21 17 18 57 186 0 29 0 11 0 23 17 18 57 48 49 51 3 51 19 30 1 23 51 62 1 55 19 51 19 30 1 23 51 62 1 55 19 51 3 35 3 46 1 39 35 14 1 7 3 139 116 82 55 8 16 8 3 9 21 10 74 72 72 10 20 11 4 8 14 8 55 77 113 97 80 8 12 6 4 7 12 8 78 2 6 254 242 42 83 42 42 83 42 1 14 254 242 42 83 42 42 83 42 1 14 253 250 1 34 31 59 29 29 59 31 254 222 0 0 1 0 15 0 0 1 182 2 6 0 25 0 111 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 11 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 11 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 5 62 89 184 0 0 69 88 184 0 25 47 27 185 0 25 0 5 62 89 186 0 1 0 2 0 25 17 18 57 186 0 8 0 15 0 2 17 18 57 186 0 14 0 15 0 12 17 18 57 186 0 21 0 15 0 2 17 18 57 48 49 51 19 39 51 23 30 1 23 51 62 1 63 1 51 7 19 35 39 46 1 39 35 14 1 15 1 15 161 150 91 70 10 19 13 4 11 19 9 67 88 150 161 92 76 11 22 13 4 11 21 11 74 1 11 251 122 17 37 23 23 37 17 122 255 254 249 128 20 41 24 24 41 20 128 0 0 1 255 255 0 0 1 160 2 6 0 15 0 55 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 11 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 5 62 89 186 0 8 0 15 0 2 17 18 57 184 0 2 16 184 0 12 208 48 49 51 53 3 51 23 30 1 23 51 62 1 63 1 51 3 21 166 167 88 66 13 27 14 4 14 25 14 66 86 167 196 1 66 137 29 55 29 29 55 29 137 254 190 196 0 0 0 0 1 0 45 0 0 1 177 2 6 0 9 0 69 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 11 62 89 184 0 0 69 88 184 0 9 47 27 185 0 9 0 5 62 89 185 0 7 0 1 244 184 0 1 208 184 0 1 47 184 0 4 16 185 0 2 0 1 244 184 0 6 208 184 0 6 47 48 49 51 53 1 33 53 33 21 1 33 21 45 1 27 254 254 1 103 254 229 1 31 49 1 145 68 49 254 112 69 255 255 0 3 0 0 1 212 2 240 2 38 4 193 0 0 0 7 7 32 0 234 255 141 255 255 0 3 0 0 1 212 2 240 2 38 4 193 0 0 0 7 7 35 0 234 255 141 255 255 0 3 0 0 1 212 2 211 2 38 4 193 0 0 0 7 7 38 0 234 255 141 255 255 0 3 0 0 1 212 2 214 2 38 4 193 0 0 0 7 7 40 0 234 255 141 255 255 0 3 0 0 1 212 2 186 2 38 4 193 0 0 0 7 7 52 0 234 255 141 255 255 0 3 0 0 1 212 2 165 2 38 4 193 0 0 0 7 7 42 0 234 255 141 255 255 0 3 0 0 1 212 2 215 2 38 4 193 0 0 0 7 7 47 0 234 255 141 255 255 0 3 0 0 1 212 2 253 2 38 4 193 0 0 0 7 7 56 0 234 255 141 255 255 0 3 0 0 1 212 2 218 2 38 4 193 0 0 0 7 7 60 0 234 255 141 255 255 0 3 255 51 1 212 2 6 2 38 4 193 0 0 0 7 7 49 0 234 252 233 255 255 0 3 0 0 1 212 2 245 2 38 4 193 0 0 0 7 7 54 0 234 255 141 255 255 0 3 0 0 1 212 3 5 2 38 4 193 0 0 0 7 7 117 0 234 255 141 255 255 0 3 0 0 1 212 3 5 2 38 4 193 0 0 0 7 7 119 0 234 255 141 255 255 0 3 0 0 1 212 3 23 2 38 4 193 0 0 0 7 7 121 0 234 255 141 255 255 0 3 0 0 1 212 3 56 2 38 4 193 0 0 0 7 7 123 0 234 255 141 255 255 0 3 255 51 1 212 2 211 2 38 4 193 0 0 0 39 7 38 0 234 255 141 0 7 7 49 0 234 252 233 255 255 0 3 0 0 1 212 3 65 2 38 4 193 0 0 0 7 7 125 0 234 255 141 255 255 0 3 0 0 1 212 3 65 2 38 4 193 0 0 0 7 7 127 0 234 255 141 255 255 0 3 0 0 1 212 3 69 2 38 4 193 0 0 0 7 7 129 0 234 255 141 255 255 0 3 0 0 1 212 3 60 2 38 4 193 0 0 0 7 7 131 0 234 255 141 255 255 0 3 255 51 1 212 2 215 2 38 4 193 0 0 0 39 7 47 0 234 255 141 0 7 7 49 0 234 252 233 0 2 0 3 255 44 1 242 2 6 0 27 0 37 0 95 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 11 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 186 0 22 0 0 0 3 43 184 0 12 16 184 0 9 208 186 0 10 0 14 0 12 17 18 57 184 0 10 47 184 0 9 16 184 0 16 208 184 0 10 16 185 0 29 0 1 244 186 0 35 0 14 0 12 17 18 57 48 49 5 34 38 53 52 62 2 55 35 39 35 7 35 19 51 19 14 1 21 20 22 51 50 55 23 14 1 1 7 51 39 46 1 39 35 14 1 1 163 40 56 14 22 26 13 18 48 197 48 84 185 94 186 35 45 28 18 23 19 22 14 45 254 253 24 156 24 14 24 14 4 14 24 212 44 43 20 38 32 26 9 146 146 2 6 253 250 14 62 31 23 23 14 45 11 17 1 238 74 74 43 83 43 44 82 0 2 0 8 0 0 2 151 2 6 0 6 0 22 0 115 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 11 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 5 62 89 186 0 2 0 8 0 22 17 18 57 186 0 3 0 8 0 22 17 18 57 184 0 8 16 185 0 10 0 1 244 184 0 22 16 184 0 19 208 186 0 15 0 8 0 19 17 18 57 184 0 15 16 185 0 13 0 1 244 184 0 19 16 185 0 17 0 1 244 184 0 2 16 185 0 21 0 1 244 48 49 19 7 51 53 35 14 1 9 1 33 21 35 21 51 21 35 21 51 21 33 53 35 7 252 48 138 3 22 43 254 246 1 30 1 103 227 190 190 237 254 191 172 76 1 36 89 252 41 83 254 181 2 6 66 150 63 173 66 141 141 0 255 255 0 8 0 0 2 151 2 240 2 38 4 241 0 0 0 7 7 35 1 208 255 141 255 255 0 8 0 0 2 151 2 165 2 38 4 241 0 0 0 7 7 42 1 208 255 141 0 3 0 33 0 0 1 249 2 6 0 23 0 32 0 45 0 103 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 11 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 5 62 89 186 0 43 0 44 0 3 43 186 0 25 0 40 0 3 43 184 0 44 16 184 0 1 208 184 0 43 16 184 0 3 208 184 0 3 47 186 0 15 0 25 0 40 17 18 57 184 0 5 16 185 0 31 0 1 244 184 0 23 16 185 0 34 0 1 244 48 49 51 53 35 53 55 17 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 35 3 51 50 54 53 52 38 43 1 17 51 50 54 53 52 38 43 1 21 51 21 35 109 76 76 170 43 72 52 29 45 46 56 65 31 57 78 46 100 78 68 59 62 62 81 90 65 77 73 69 90 126 126 132 36 4 1 90 14 30 49 35 38 61 12 4 11 59 54 39 56 38 18 1 41 45 42 42 37 254 104 45 53 47 45 73 40 0 0 255 255 0 90 255 87 1 229 2 6 2 38 4 194 0 0 0 7 7 41 1 31 252 254 255 255 0 52 255 30 1 215 2 18 2 38 4 195 0 0 0 7 7 85 1 38 0 0 255 255 0 52 255 244 1 215 2 240 2 38 4 195 0 0 0 7 7 35 1 38 255 141 255 255 0 52 255 244 1 215 2 211 2 38 4 195 0 0 0 7 7 38 1 38 255 141 255 255 0 52 255 244 1 215 2 218 2 38 4 195 0 0 0 7 7 60 1 38 255 141 255 255 0 52 255 244 1 215 2 194 2 38 4 195 0 0 0 7 7 50 1 38 255 141 255 255 0 90 0 0 1 247 2 218 2 38 4 196 0 0 0 7 7 60 1 27 255 141 255 255 0 90 255 51 1 247 2 6 2 38 4 196 0 0 0 7 7 49 1 24 252 233 255 255 0 90 255 87 1 247 2 6 2 38 4 196 0 0 0 7 7 41 1 24 252 254 255 255 0 33 0 0 2 11 2 6 2 6 5 153 0 0 255 255 0 90 0 0 1 170 2 240 2 38 4 197 0 0 0 7 7 32 1 8 255 141 255 255 0 90 0 0 1 170 2 240 2 38 4 197 0 0 0 7 7 35 1 8 255 141 255 255 0 90 0 0 1 170 2 211 2 38 4 197 0 0 0 7 7 38 1 8 255 141 255 255 0 90 0 0 1 170 2 218 2 38 4 197 0 0 0 7 7 60 1 8 255 141 255 255 0 90 0 0 1 170 2 186 2 38 4 197 0 0 0 7 7 52 1 8 255 141 255 255 0 90 0 0 1 170 2 165 2 38 4 197 0 0 0 7 7 42 1 8 255 141 255 255 0 90 0 0 1 170 2 215 2 38 4 197 0 0 0 7 7 47 1 8 255 141 255 255 0 90 0 0 1 170 2 194 2 38 4 197 0 0 0 7 7 50 1 8 255 141 255 255 0 90 255 51 1 170 2 6 2 38 4 197 0 0 0 7 7 49 1 10 252 233 255 255 0 90 0 0 1 170 2 245 2 38 4 197 0 0 0 7 7 54 1 8 255 141 255 255 0 87 0 0 1 185 2 214 2 38 4 197 0 0 0 7 7 40 1 8 255 141 255 255 0 90 0 0 1 231 3 5 2 38 4 197 0 0 0 7 7 117 1 8 255 141 255 255 0 53 0 0 1 170 3 5 2 38 4 197 0 0 0 7 7 119 1 8 255 141 255 255 0 90 0 0 1 215 3 23 2 38 4 197 0 0 0 7 7 121 1 8 255 141 255 255 0 90 0 0 1 170 3 56 2 38 4 197 0 0 0 7 7 123 1 8 255 141 255 255 0 90 255 51 1 170 2 211 2 38 4 197 0 0 0 39 7 38 1 8 255 141 0 7 7 49 1 10 252 233 0 1 0 90 255 44 1 186 2 6 0 33 0 93 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 11 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 186 0 27 0 0 0 3 43 184 0 8 16 185 0 10 0 1 244 186 0 14 0 8 0 7 17 18 57 184 0 14 47 185 0 12 0 1 244 184 0 7 16 185 0 17 0 1 244 184 0 7 16 184 0 18 208 48 49 5 34 38 53 52 54 55 35 17 33 21 35 21 51 21 35 21 51 21 35 14 3 21 20 22 51 50 54 55 23 14 1 1 106 40 55 46 28 251 1 70 243 206 206 253 3 17 33 26 16 30 18 12 19 9 23 14 46 212 44 43 42 65 18 2 6 66 150 63 173 66 2 19 29 37 20 23 23 7 7 45 11 17 0 0 255 255 0 90 0 0 1 170 3 85 2 38 4 197 0 0 0 7 7 135 1 8 255 141 255 255 0 52 255 244 1 227 2 240 2 38 4 199 0 0 0 7 7 35 1 52 255 141 255 255 0 52 255 244 1 227 2 211 2 38 4 199 0 0 0 7 7 38 1 52 255 141 255 255 0 52 255 244 1 227 2 215 2 38 4 199 0 0 0 7 7 47 1 52 255 141 255 255 0 52 255 244 1 227 2 194 2 38 4 199 0 0 0 7 7 50 1 52 255 141 255 255 0 52 255 30 1 227 2 18 2 38 4 199 0 0 0 7 7 82 1 49 0 0 255 255 0 52 255 244 1 227 2 218 2 38 4 199 0 0 0 7 7 60 1 52 255 141 255 255 0 52 255 244 1 227 2 165 2 38 4 199 0 0 0 7 7 42 1 52 255 141 255 255 0 52 255 244 1 229 2 214 2 38 4 199 0 0 0 7 7 40 1 52 255 141 0 1 0 52 255 244 2 24 2 129 0 49 0 89 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 17 0 1 0 24 0 4 43 184 0 10 16 185 0 33 0 1 244 184 0 0 16 185 0 39 0 1 244 186 0 46 0 10 0 0 17 18 57 125 184 0 46 47 24 185 0 44 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 23 38 53 52 54 51 50 22 23 7 46 1 35 34 6 21 20 23 7 46 1 35 34 6 21 20 22 51 50 54 55 53 35 53 51 21 14 1 1 51 56 93 68 38 39 70 96 56 38 30 4 55 46 19 27 12 16 7 12 9 21 23 26 46 21 53 40 81 96 90 87 29 48 16 112 188 29 90 12 36 69 100 65 64 101 70 37 9 12 15 40 53 6 5 59 2 4 23 18 31 32 51 16 22 106 96 94 107 14 14 127 61 226 26 33 255 255 0 90 0 0 1 248 2 211 2 38 4 200 0 0 0 7 7 38 1 41 255 141 255 255 0 90 255 51 1 248 2 6 2 38 4 200 0 0 0 7 7 49 1 41 252 233 255 255 0 90 255 26 1 248 2 6 2 38 4 200 0 0 0 7 7 45 1 41 252 223 0 2 0 32 0 0 2 86 2 6 0 19 0 23 0 103 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 11 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 5 62 89 184 0 3 16 184 0 2 220 184 0 6 208 184 0 3 16 184 0 7 208 184 0 6 16 184 0 10 208 184 0 2 16 184 0 19 220 184 0 22 208 184 0 11 208 184 0 18 16 184 0 14 208 184 0 19 16 184 0 20 220 185 0 16 0 1 244 48 49 19 53 55 53 51 21 51 53 51 21 51 21 35 17 35 53 35 21 35 17 23 51 53 35 32 78 83 248 83 74 74 83 248 83 83 248 248 1 128 41 5 88 88 88 88 46 254 128 239 239 1 128 80 80 0 0 0 255 255 255 252 0 0 0 185 2 240 2 38 4 201 0 0 0 7 7 32 0 131 255 141 255 255 0 77 0 0 1 10 2 240 2 38 4 201 0 0 0 7 7 35 0 131 255 141 255 255 255 239 0 0 1 23 2 211 2 38 4 201 0 0 0 7 7 38 0 131 255 141 255 255 255 210 0 0 1 52 2 214 2 38 4 201 0 0 0 7 7 40 0 131 255 141 255 255 255 235 0 0 1 27 2 186 2 38 4 201 0 0 0 7 7 52 0 131 255 141 255 255 255 253 0 0 1 9 2 165 2 38 4 201 0 0 0 7 7 42 0 131 255 141 255 255 0 74 0 0 0 188 2 194 2 38 4 201 0 0 0 7 7 50 0 131 255 141 255 255 255 239 0 0 1 23 2 218 2 38 4 201 0 0 0 7 7 60 0 131 255 141 255 255 0 63 0 0 0 210 2 245 2 38 4 201 0 0 0 7 7 54 0 131 255 141 255 255 0 77 255 51 0 185 2 6 2 38 4 201 0 0 0 7 7 49 0 131 252 233 0 1 0 43 255 44 0 219 2 6 0 21 0 53 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 11 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 186 0 16 0 0 0 3 43 184 0 7 16 184 0 10 208 48 49 23 34 38 53 52 54 55 35 17 51 17 14 1 21 20 22 51 50 55 23 14 1 139 40 56 43 24 20 83 31 34 30 17 22 19 23 15 45 212 44 43 43 60 22 2 6 253 250 24 52 31 23 23 14 45 11 17 255 255 255 241 0 0 1 21 2 215 2 38 4 201 0 0 0 7 7 47 0 131 255 141 255 255 0 31 255 244 1 195 2 211 2 38 4 202 0 0 0 7 7 38 1 47 255 141 255 255 0 90 255 30 1 254 2 6 2 38 4 203 0 0 0 7 7 82 1 43 0 0 255 255 0 90 255 51 1 254 2 6 2 38 4 203 0 0 0 7 7 49 1 43 252 233 255 255 0 90 255 87 1 254 2 6 2 38 4 203 0 0 0 7 7 41 1 43 252 254 255 255 0 83 0 0 1 154 2 240 2 38 4 204 0 0 0 7 7 35 0 137 255 141 255 255 0 90 0 0 1 154 2 103 2 38 4 204 0 0 0 7 7 61 1 81 255 111 255 255 0 90 255 30 1 154 2 6 2 38 4 204 0 0 0 7 7 82 1 4 0 0 255 255 0 90 0 0 1 154 2 6 2 38 4 204 0 0 0 7 4 117 0 224 0 237 255 255 0 90 255 51 1 154 2 6 2 38 4 204 0 0 0 7 7 49 1 4 252 233 255 255 0 3 255 51 1 154 2 165 2 38 4 204 0 0 0 39 7 42 0 137 255 141 0 7 7 49 1 4 252 233 255 255 0 90 255 87 1 154 2 6 2 38 4 204 0 0 0 7 7 41 1 4 252 254 0 1 255 250 0 0 1 159 2 6 0 13 0 93 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 11 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 186 0 6 0 7 0 3 43 186 0 1 0 0 0 3 43 186 0 13 0 11 0 3 17 18 57 184 0 13 16 184 0 2 208 184 0 13 16 184 0 8 208 184 0 5 208 184 0 11 16 185 0 10 0 1 244 48 49 55 39 55 17 51 21 55 23 7 21 51 21 33 53 24 30 101 83 146 30 176 237 254 192 135 48 56 1 23 242 78 49 94 142 69 174 0 255 255 0 90 0 0 2 45 2 240 2 38 4 205 0 0 0 7 7 35 1 67 255 141 255 255 0 90 0 0 2 45 2 194 2 38 4 205 0 0 0 7 7 50 1 67 255 141 255 255 0 90 255 51 2 45 2 6 2 38 4 205 0 0 0 7 7 49 1 67 252 233 255 255 0 90 0 0 1 239 2 240 2 38 4 206 0 0 0 7 7 35 1 44 255 141 255 255 0 90 0 0 1 239 2 240 2 38 4 206 0 0 0 7 7 32 1 44 255 141 255 255 0 90 0 0 1 239 2 218 2 38 4 206 0 0 0 7 7 60 1 44 255 141 255 255 0 90 0 0 1 239 2 214 2 38 4 206 0 0 0 7 7 40 1 44 255 141 255 255 0 90 255 30 1 239 2 6 2 38 4 206 0 0 0 7 7 82 1 43 0 0 255 255 0 90 0 0 1 239 2 194 2 38 4 206 0 0 0 7 7 50 1 44 255 141 255 255 0 90 255 51 1 239 2 6 2 38 4 206 0 0 0 7 7 49 1 43 252 233 255 255 0 90 255 87 1 239 2 6 2 38 4 206 0 0 0 7 7 41 1 43 252 254 255 255 0 52 255 244 2 26 2 240 2 38 4 207 0 0 0 7 7 32 1 38 255 141 255 255 0 52 255 244 2 26 2 240 2 38 4 207 0 0 0 7 7 35 1 38 255 141 255 255 0 52 255 244 2 26 2 211 2 38 4 207 0 0 0 7 7 38 1 38 255 141 255 255 0 52 255 244 2 26 2 214 2 38 4 207 0 0 0 7 7 40 1 38 255 141 255 255 0 52 255 244 2 26 2 186 2 38 4 207 0 0 0 7 7 52 1 38 255 141 255 255 0 52 255 244 2 26 2 165 2 38 4 207 0 0 0 7 7 42 1 38 255 141 255 255 0 52 255 244 2 26 2 249 2 38 4 207 0 0 0 7 7 58 1 38 255 141 255 255 0 52 255 244 2 26 2 218 2 38 4 207 0 0 0 7 7 60 1 38 255 141 255 255 0 52 255 51 2 26 2 18 2 38 4 207 0 0 0 7 7 49 1 39 252 233 255 255 0 52 255 244 2 26 2 245 2 38 4 207 0 0 0 7 7 54 1 38 255 141 255 255 0 52 255 244 2 26 3 5 2 38 4 207 0 0 0 7 7 117 1 38 255 141 255 255 0 52 255 244 2 26 3 5 2 38 4 207 0 0 0 7 7 119 1 38 255 141 255 255 0 52 255 244 2 26 3 23 2 38 4 207 0 0 0 7 7 121 1 38 255 141 255 255 0 52 255 244 2 26 3 56 2 38 4 207 0 0 0 7 7 123 1 38 255 141 255 255 0 52 255 51 2 26 2 211 2 38 4 207 0 0 0 39 7 38 1 38 255 141 0 7 7 49 1 39 252 233 0 3 0 47 255 233 2 31 2 30 0 26 0 34 0 42 0 137 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 2 0 0 0 13 17 18 57 186 0 5 0 0 0 13 17 18 57 186 0 16 0 13 0 0 17 18 57 186 0 19 0 13 0 0 17 18 57 186 0 29 0 0 0 13 17 18 57 186 0 30 0 13 0 0 17 18 57 184 0 13 16 185 0 32 0 1 244 184 0 0 16 185 0 35 0 1 244 186 0 40 0 0 0 13 17 18 57 186 0 41 0 0 0 13 17 18 57 48 49 5 34 39 7 39 55 46 1 53 52 62 2 51 50 22 23 55 23 7 30 1 21 20 14 2 3 20 23 19 38 35 34 6 19 50 54 53 52 39 3 22 1 39 93 63 56 36 60 26 29 36 64 89 54 46 78 31 56 37 60 26 29 36 65 89 214 26 242 41 66 74 87 161 73 87 25 242 42 12 54 65 29 70 35 93 57 63 100 69 37 27 26 65 29 70 34 91 57 63 102 70 38 1 17 73 50 1 26 43 107 254 211 110 96 70 50 254 230 44 0 0 0 2 0 52 0 0 2 174 2 6 0 16 0 25 0 85 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 6 16 185 0 20 0 1 244 184 0 8 208 186 0 12 0 6 0 0 17 18 57 184 0 12 47 185 0 10 0 1 244 184 0 0 16 185 0 17 0 1 244 184 0 15 208 48 49 33 34 38 53 52 54 51 33 21 35 21 51 21 35 21 51 21 37 51 17 35 34 6 21 20 22 1 72 132 144 143 129 1 96 229 192 192 239 254 152 38 38 97 91 91 129 128 129 132 66 150 63 173 66 66 1 131 99 97 91 100 0 0 0 2 0 52 255 244 2 45 2 163 0 31 0 43 0 75 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 24 0 0 0 10 17 18 57 184 0 24 16 184 0 12 208 184 0 0 16 185 0 32 0 1 244 184 0 10 16 185 0 38 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 23 54 53 52 38 39 55 30 1 21 20 6 7 30 1 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 1 39 54 89 64 36 36 64 89 54 59 48 82 8 6 64 10 13 58 46 40 45 36 65 89 53 72 85 85 72 72 85 85 12 38 70 102 63 63 100 69 37 23 15 67 16 26 14 30 18 38 24 48 59 13 35 108 71 63 102 70 38 70 109 94 94 105 105 94 94 109 0 255 255 0 52 255 244 2 45 2 240 2 38 5 82 0 0 0 7 7 35 1 38 255 141 255 255 0 52 255 244 2 45 2 240 2 38 5 82 0 0 0 7 7 32 1 38 255 141 255 255 0 52 255 244 2 45 2 245 2 38 5 82 0 0 0 7 7 54 1 38 255 141 255 255 0 52 255 244 2 45 2 214 2 38 5 82 0 0 0 7 7 40 1 27 255 141 255 255 0 52 255 51 2 45 2 163 2 38 5 82 0 0 0 7 7 49 1 39 252 233 0 2 0 52 255 44 2 26 2 18 0 36 0 48 0 73 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 11 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 186 0 30 0 0 0 3 43 184 0 6 16 184 0 24 208 184 0 6 16 185 0 37 0 1 244 184 0 16 16 185 0 43 0 1 244 48 49 5 34 38 53 52 54 55 46 3 53 52 62 2 51 50 30 2 21 20 6 7 14 1 21 20 22 51 50 54 55 23 14 1 3 50 54 53 52 38 35 34 6 21 20 22 1 68 40 55 35 26 55 88 62 33 36 64 89 54 53 89 65 36 87 80 41 37 30 18 12 19 9 23 14 46 49 72 85 85 72 72 85 85 212 44 43 33 59 22 1 39 71 99 62 63 100 69 37 37 69 100 63 105 129 34 18 56 26 23 23 7 7 45 11 17 1 14 109 94 94 105 105 94 94 109 0 0 255 255 0 52 255 244 2 26 2 215 2 38 4 207 0 0 0 7 7 47 1 38 255 141 255 255 0 52 255 244 2 26 3 85 2 38 4 207 0 0 0 7 7 135 1 38 255 141 255 255 0 90 0 0 1 231 2 240 2 38 4 210 0 0 0 7 7 35 1 26 255 141 255 255 0 90 0 0 1 231 2 194 2 38 4 210 0 0 0 7 7 50 1 26 255 141 255 255 0 90 0 0 1 231 2 218 2 38 4 210 0 0 0 7 7 60 1 26 255 141 255 255 0 90 255 30 1 231 2 6 2 38 4 210 0 0 0 7 7 82 1 29 0 0 255 255 0 90 255 51 1 231 2 6 2 38 4 210 0 0 0 7 7 49 1 29 252 233 255 255 0 90 255 51 1 231 2 165 2 38 4 210 0 0 0 39 7 42 1 26 255 141 0 7 7 49 1 29 252 233 255 255 0 90 255 87 1 231 2 6 2 38 4 210 0 0 0 7 7 41 1 29 252 254 255 255 0 42 255 244 1 180 2 240 2 38 4 211 0 0 0 7 7 35 0 254 255 141 255 255 0 42 255 244 1 180 2 211 2 38 4 211 0 0 0 7 7 38 0 254 255 141 255 255 0 42 255 244 1 180 2 218 2 38 4 211 0 0 0 7 7 60 0 254 255 141 255 255 0 42 255 30 1 180 2 18 2 38 4 211 0 0 0 7 7 85 0 244 0 0 255 255 0 42 255 30 1 180 2 18 2 38 4 211 0 0 0 7 7 82 1 3 0 0 255 255 0 42 255 244 1 180 2 194 2 38 4 211 0 0 0 7 7 50 0 254 255 141 255 255 0 42 255 51 1 180 2 18 2 38 4 211 0 0 0 7 7 49 1 3 252 233 255 255 0 42 255 244 3 132 2 18 0 38 4 211 0 0 0 7 4 211 1 208 0 0 0 1 0 91 255 244 2 39 2 18 0 42 0 93 0 184 0 0 69 88 184 0 31 47 27 185 0 31 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 186 0 15 0 31 0 0 17 18 57 184 0 15 16 184 0 16 220 184 0 31 16 185 0 20 0 1 244 184 0 0 16 184 0 25 208 184 0 25 47 186 0 35 0 15 0 16 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 52 46 2 47 1 55 46 1 35 34 6 21 17 35 17 52 62 2 51 50 22 23 7 30 1 21 20 14 2 1 132 50 78 26 43 24 51 29 41 44 14 35 60 45 6 113 14 54 42 63 71 84 30 57 82 53 73 94 22 113 84 78 23 42 60 12 35 26 50 23 21 46 36 18 32 27 20 6 46 114 26 37 75 75 254 199 1 71 46 75 53 29 74 59 113 17 73 58 30 54 41 23 255 255 0 28 0 0 1 183 2 218 2 38 4 212 0 0 0 7 7 60 0 233 255 141 255 255 0 28 255 30 1 183 2 6 2 38 4 212 0 0 0 7 7 85 0 228 0 0 255 255 0 28 255 30 1 183 2 6 2 38 4 212 0 0 0 7 7 82 0 233 0 0 255 255 0 28 255 51 1 183 2 6 2 38 4 212 0 0 0 7 7 49 0 233 252 233 255 255 0 28 255 87 1 183 2 6 2 38 4 212 0 0 0 7 7 41 0 233 252 254 0 1 0 28 0 0 1 183 2 6 0 16 0 85 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 1 0 8 0 0 17 18 57 184 0 1 16 184 0 5 208 184 0 8 16 185 0 7 0 1 244 184 0 10 208 184 0 5 16 184 0 13 208 184 0 1 16 184 0 14 208 48 49 51 53 35 53 55 51 53 35 53 33 21 35 21 51 21 35 21 192 124 89 35 164 1 155 164 124 124 233 44 3 169 69 69 169 47 233 0 255 255 0 87 255 244 1 240 2 240 2 38 4 213 0 0 0 7 7 32 1 35 255 141 255 255 0 87 255 244 1 240 2 240 2 38 4 213 0 0 0 7 7 35 1 35 255 141 255 255 0 87 255 244 1 240 2 211 2 38 4 213 0 0 0 7 7 38 1 35 255 141 255 255 0 87 255 244 1 240 2 214 2 38 4 213 0 0 0 7 7 40 1 35 255 141 255 255 0 87 255 244 1 240 2 186 2 38 4 213 0 0 0 7 7 52 1 35 255 141 255 255 0 87 255 244 1 240 2 165 2 38 4 213 0 0 0 7 7 42 1 35 255 141 255 255 0 87 255 244 1 240 2 215 2 38 4 213 0 0 0 7 7 47 1 35 255 141 255 255 0 87 255 244 1 240 2 253 2 38 4 213 0 0 0 7 7 56 1 35 255 141 255 255 0 87 255 244 1 241 2 249 2 38 4 213 0 0 0 7 7 58 1 35 255 141 255 255 0 87 255 244 1 240 2 218 2 38 4 213 0 0 0 7 7 60 1 35 255 141 255 255 0 87 255 244 1 240 3 24 2 38 4 213 0 0 0 7 7 113 1 35 255 141 255 255 0 87 255 244 1 240 3 85 2 38 4 213 0 0 0 7 7 106 1 35 255 141 255 255 0 87 255 244 1 240 3 79 2 38 4 213 0 0 0 7 7 115 1 35 255 141 255 255 0 87 255 244 1 240 3 85 2 38 4 213 0 0 0 7 7 109 1 35 255 141 255 255 0 87 255 51 1 240 2 6 2 38 4 213 0 0 0 7 7 49 1 35 252 233 255 255 0 87 255 244 1 240 2 245 2 38 4 213 0 0 0 7 7 54 1 35 255 141 0 1 0 87 255 44 1 240 2 6 0 45 0 59 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 11 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 185 0 21 0 1 244 184 0 14 16 184 0 27 208 184 0 8 16 184 0 34 208 48 49 5 34 38 53 52 62 2 55 46 3 53 17 51 17 20 30 2 51 50 62 2 53 17 51 17 20 14 2 7 14 1 21 20 22 51 50 55 23 14 1 1 65 40 56 13 19 23 9 45 74 54 29 83 18 33 45 27 27 45 33 19 79 19 33 47 28 39 40 30 17 22 19 22 14 45 212 44 43 21 33 28 23 9 1 25 53 86 62 1 46 254 209 45 60 36 16 16 36 60 45 1 47 254 210 53 73 50 34 13 19 56 25 23 23 14 45 11 17 0 0 1 0 87 255 244 2 99 2 173 0 39 0 55 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 13 0 1 244 184 0 6 16 184 0 19 208 184 0 34 220 48 49 5 34 46 2 53 17 51 17 20 30 2 51 50 62 2 53 17 51 62 1 53 52 39 55 30 1 21 20 14 2 7 17 20 14 2 1 36 44 75 55 31 83 18 33 45 27 27 45 33 19 31 39 51 14 64 10 13 19 31 42 23 30 54 75 12 23 54 87 64 1 46 254 209 45 60 36 16 16 36 60 45 1 47 3 39 41 29 25 30 17 39 23 29 41 30 18 6 254 246 64 87 54 23 255 255 0 87 255 244 2 99 2 240 2 38 5 130 0 0 0 7 7 35 1 35 255 141 255 255 0 87 255 244 2 99 2 240 2 38 5 130 0 0 0 7 7 32 1 35 255 141 255 255 0 87 255 244 2 99 2 245 2 38 5 130 0 0 0 7 7 54 1 35 255 141 255 255 0 87 255 244 2 99 2 214 2 38 5 130 0 0 0 7 7 40 1 35 255 141 255 255 0 87 255 51 2 99 2 173 2 38 5 130 0 0 0 7 7 49 1 35 252 233 255 255 0 23 0 0 2 148 2 240 2 38 4 215 0 0 0 7 7 32 1 86 255 141 255 255 0 23 0 0 2 148 2 240 2 38 4 215 0 0 0 7 7 35 1 86 255 141 255 255 0 23 0 0 2 148 2 211 2 38 4 215 0 0 0 7 7 38 1 86 255 141 255 255 0 23 0 0 2 148 2 186 2 38 4 215 0 0 0 7 7 52 1 86 255 141 255 255 255 255 0 0 1 160 2 240 2 38 4 217 0 0 0 7 7 32 0 208 255 141 255 255 255 255 0 0 1 160 2 240 2 38 4 217 0 0 0 7 7 35 0 208 255 141 255 255 255 255 0 0 1 160 2 211 2 38 4 217 0 0 0 7 7 38 0 208 255 141 255 255 255 255 0 0 1 160 2 186 2 38 4 217 0 0 0 7 7 52 0 208 255 141 255 255 255 255 0 0 1 160 2 194 2 38 4 217 0 0 0 7 7 50 0 208 255 141 255 255 255 255 255 51 1 160 2 6 2 38 4 217 0 0 0 7 7 49 0 207 252 233 255 255 255 255 0 0 1 160 2 245 2 38 4 217 0 0 0 7 7 54 0 208 255 141 255 255 255 255 0 0 1 160 2 214 2 38 4 217 0 0 0 7 7 40 0 208 255 141 255 255 0 45 0 0 1 177 2 240 2 38 4 218 0 0 0 7 7 35 0 250 255 141 255 255 0 45 0 0 1 177 2 218 2 38 4 218 0 0 0 7 7 60 0 250 255 141 255 255 0 45 0 0 1 177 2 194 2 38 4 218 0 0 0 7 7 50 0 250 255 141 255 255 0 45 255 51 1 177 2 6 2 38 4 218 0 0 0 7 7 49 0 253 252 233 255 255 0 45 255 87 1 177 2 6 2 38 4 218 0 0 0 7 7 41 0 253 252 254 0 2 0 33 0 0 2 11 2 6 0 12 0 25 0 87 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 11 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 186 0 24 0 4 0 10 17 18 57 184 0 24 47 184 0 0 208 184 0 24 16 184 0 23 208 184 0 1 208 184 0 10 16 185 0 14 0 1 244 184 0 4 16 185 0 20 0 1 244 48 49 55 53 55 53 51 50 22 21 20 6 43 1 53 23 51 50 54 53 52 38 43 1 21 51 21 35 33 77 143 129 141 140 126 147 83 62 93 89 89 93 62 126 126 248 43 4 223 129 128 129 132 248 183 99 97 91 100 157 47 0 0 0 2 0 90 0 0 1 220 2 6 0 16 0 25 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 5 62 89 187 0 18 0 1 0 14 0 4 43 187 0 24 0 1 0 4 0 4 43 48 49 51 17 51 21 51 50 30 2 21 20 14 2 43 1 21 53 51 50 54 53 52 38 43 1 90 83 94 46 76 56 31 31 56 77 45 94 85 69 66 67 68 85 2 6 86 16 36 60 44 42 62 41 19 112 175 48 53 53 40 0 2 0 58 255 244 2 18 2 18 0 28 0 35 0 81 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 9 0 19 0 0 17 18 57 184 0 9 47 184 0 19 16 185 0 12 0 1 244 184 0 0 16 185 0 29 0 1 244 184 0 9 16 185 0 33 0 1 244 48 49 5 34 46 2 53 52 54 55 33 46 1 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 39 50 54 55 33 30 1 1 34 53 85 61 33 1 1 1 130 5 81 75 39 66 25 40 30 91 58 53 87 62 34 36 63 89 52 63 83 9 254 208 5 81 12 38 71 99 60 6 11 8 86 95 31 21 55 27 38 37 70 100 63 63 100 71 38 68 86 80 78 88 0 0 0 0 1 0 90 255 244 2 7 2 18 0 37 0 97 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 184 0 28 16 185 0 17 0 1 244 186 0 25 0 0 0 28 17 18 57 184 0 25 16 185 0 20 0 2 244 184 0 0 16 184 0 22 208 184 0 22 47 184 0 28 16 184 0 23 208 184 0 23 47 48 49 5 34 38 39 55 30 1 51 50 62 2 53 52 46 2 35 34 6 7 17 35 17 51 21 62 1 51 50 30 2 21 20 14 2 1 105 17 39 13 20 9 19 13 16 29 22 13 18 34 48 29 32 75 24 83 81 31 79 45 41 71 52 29 22 41 59 12 6 7 65 4 4 19 47 79 60 55 75 47 20 43 35 254 130 2 6 63 32 43 29 64 102 72 73 104 67 31 0 2 0 90 255 104 1 180 2 6 0 3 0 19 0 55 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 187 0 11 0 1 0 4 0 4 43 184 0 1 16 184 0 15 208 48 49 51 17 51 17 23 34 38 39 55 30 1 51 50 54 53 17 51 17 20 6 90 83 129 23 36 13 16 10 23 13 37 24 83 62 2 6 253 250 152 8 5 65 3 5 50 45 1 249 254 4 75 87 0 0 1 0 90 255 104 1 239 2 6 0 32 0 83 0 184 0 0 69 88 184 0 20 47 27 185 0 20 0 11 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 187 0 7 0 1 0 0 0 4 43 184 0 19 16 184 0 11 208 186 0 14 0 20 0 19 17 18 57 184 0 20 16 184 0 28 208 186 0 24 0 28 0 10 17 18 57 48 49 5 34 38 39 55 30 1 51 50 54 53 35 3 39 35 30 1 29 1 35 17 51 19 23 51 46 1 61 1 51 17 20 6 1 120 20 32 11 15 8 19 11 29 20 3 192 60 4 3 8 77 84 191 60 4 3 8 77 55 152 6 5 62 2 5 45 41 1 50 111 41 89 42 245 2 6 254 206 111 39 93 42 243 253 247 68 81 255 255 0 3 0 0 1 212 2 6 2 6 4 193 0 0 255 255 0 90 0 0 1 229 2 6 2 6 4 194 0 0 0 1 0 90 0 0 1 162 2 6 0 5 0 47 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 1 16 185 0 3 0 1 244 48 49 51 17 33 21 35 17 90 1 72 245 2 6 70 254 64 0 2 0 30 0 0 1 229 2 6 0 5 0 11 0 53 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 11 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 185 0 7 0 1 244 186 0 10 0 5 0 2 17 18 57 48 49 51 53 19 51 19 21 37 33 47 1 35 7 30 180 95 180 254 145 1 21 81 56 3 56 49 1 213 254 43 49 69 216 165 165 0 255 255 0 90 0 0 1 170 2 6 2 6 4 197 0 0 255 255 0 45 0 0 1 177 2 6 2 6 4 218 0 0 255 255 0 90 0 0 1 248 2 6 2 6 4 200 0 0 0 3 0 52 255 244 2 26 2 18 0 3 0 23 0 35 0 67 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 11 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 5 62 89 187 0 2 0 1 0 3 0 4 43 184 0 4 16 185 0 24 0 1 244 184 0 14 16 185 0 30 0 1 244 48 49 55 53 51 21 7 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 204 182 91 54 89 64 36 36 64 89 54 53 89 65 36 36 65 89 53 73 86 86 73 74 86 86 239 63 63 251 37 71 101 64 63 100 69 37 37 69 100 63 64 101 71 37 67 109 97 97 105 105 97 97 109 255 255 0 90 0 0 0 173 2 6 2 6 4 201 0 0 255 255 0 90 0 0 1 254 2 6 2 6 4 203 0 0 0 1 0 0 0 0 1 190 2 6 0 13 0 51 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 5 62 89 184 0 3 208 186 0 9 0 1 0 13 17 18 57 48 49 49 19 51 19 35 3 46 1 39 35 14 1 7 3 174 97 175 87 85 14 23 14 4 15 22 14 85 2 6 253 250 1 12 45 80 45 45 80 45 254 244 0 0 255 255 0 90 0 0 2 45 2 6 2 6 4 205 0 0 255 255 0 90 0 0 1 239 2 6 2 6 4 206 0 0 0 3 0 49 0 0 1 167 2 6 0 3 0 7 0 11 0 67 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 11 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 5 62 89 187 0 6 0 1 0 7 0 4 43 184 0 3 16 185 0 1 0 1 244 184 0 9 16 185 0 11 0 1 244 48 49 51 53 33 21 37 53 51 21 37 53 33 21 49 1 118 254 201 249 254 208 1 102 66 66 239 63 63 213 66 66 0 255 255 0 52 255 244 2 26 2 18 2 6 4 207 0 0 0 1 0 90 0 0 1 242 2 6 0 7 0 51 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 184 0 3 208 184 0 1 16 185 0 5 0 1 244 48 49 51 17 33 17 35 17 35 17 90 1 152 83 242 2 6 253 250 1 192 254 64 0 0 255 255 0 90 0 0 1 220 2 6 2 6 4 208 0 0 0 1 0 44 0 0 1 177 2 6 0 11 0 69 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 11 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 185 0 9 0 1 244 184 0 1 208 184 0 1 47 184 0 4 16 185 0 6 0 1 244 184 0 3 208 184 0 3 47 48 49 51 53 55 39 53 33 21 33 23 7 33 21 44 187 184 1 109 254 250 164 169 1 32 49 215 209 45 65 188 199 66 0 0 255 255 0 28 0 0 1 183 2 6 2 6 4 212 0 0 255 255 255 255 0 0 1 160 2 6 2 6 4 217 0 0 0 3 0 48 255 238 2 95 2 24 0 6 0 13 0 39 0 71 0 187 0 4 0 1 0 38 0 4 43 187 0 28 0 1 0 3 0 4 43 184 0 4 16 184 0 10 208 184 0 3 16 184 0 11 208 184 0 38 16 184 0 14 220 184 0 38 16 184 0 15 208 184 0 28 16 184 0 25 208 184 0 28 16 184 0 26 220 48 49 1 52 38 39 17 62 1 37 20 22 23 17 14 1 19 53 46 3 53 52 62 2 55 53 51 21 30 3 21 20 14 2 7 21 2 15 87 75 75 87 254 113 87 75 75 87 162 56 89 63 34 34 63 89 56 75 55 90 63 34 34 63 90 55 1 4 66 71 4 254 228 4 73 66 66 73 4 1 28 4 71 254 168 71 3 30 53 74 47 47 74 53 29 2 71 71 2 29 53 74 47 47 74 53 30 3 71 255 255 0 15 0 0 1 182 2 6 2 6 4 216 0 0 0 1 0 63 0 0 2 50 2 6 0 23 0 75 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 11 62 89 184 0 0 69 88 184 0 23 47 27 185 0 23 0 5 62 89 187 0 13 0 1 0 22 0 4 43 184 0 22 16 184 0 1 208 184 0 13 16 184 0 10 208 184 0 5 16 184 0 11 208 184 0 17 208 48 49 33 53 46 1 61 1 51 21 20 22 23 17 51 17 62 1 61 1 51 21 20 6 7 21 1 18 100 111 80 66 65 77 65 66 80 111 100 187 4 96 102 129 124 72 67 4 1 11 254 245 4 67 72 124 129 102 96 4 187 0 1 0 44 0 0 2 37 2 18 0 45 0 89 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 1 0 1 244 184 0 25 208 184 0 0 16 184 0 26 208 184 0 25 16 184 0 28 208 184 0 28 47 184 0 13 16 185 0 36 0 1 244 184 0 1 16 184 0 44 208 184 0 44 47 48 49 51 53 51 53 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 21 51 21 35 53 62 1 53 52 46 2 35 34 14 2 21 20 22 23 21 44 107 17 35 27 17 35 63 89 54 55 89 63 35 17 27 35 17 107 204 48 61 22 40 59 37 37 58 41 21 61 47 66 3 15 42 52 63 37 54 93 67 38 38 67 93 54 37 63 52 42 15 3 66 59 35 103 75 40 70 50 29 29 50 70 40 75 103 35 59 255 255 255 235 0 0 1 27 2 186 2 38 4 201 0 0 0 7 7 52 0 131 255 141 255 255 255 255 0 0 1 160 2 186 2 38 4 217 0 0 0 7 7 52 0 208 255 141 0 3 0 3 0 0 2 131 2 6 0 9 0 17 0 21 0 85 0 124 184 0 19 47 24 184 0 0 69 88 184 0 11 47 27 185 0 11 0 11 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 186 0 2 0 11 0 10 17 18 57 184 0 14 208 186 0 6 0 11 0 14 17 18 57 184 0 2 16 185 0 16 0 1 244 184 0 14 16 184 0 18 208 48 49 19 7 51 39 46 1 39 35 14 1 3 19 51 19 35 39 35 7 33 17 51 17 180 24 156 24 14 24 14 4 14 24 191 185 94 186 88 48 197 48 1 217 83 1 26 74 74 43 83 43 44 82 254 187 2 6 253 250 146 146 1 158 254 98 0 0 2 0 90 0 0 2 255 2 6 0 11 0 15 0 83 0 124 184 0 13 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 10 0 1 0 0 17 18 57 184 0 10 47 185 0 4 0 1 244 184 0 1 16 184 0 5 208 184 0 0 16 184 0 8 208 184 0 12 208 48 49 51 17 51 21 51 53 51 17 35 53 35 21 33 17 51 17 90 83 248 83 83 248 1 255 83 2 6 211 211 253 250 235 235 1 158 254 98 0 2 0 44 0 0 2 253 2 18 0 45 0 49 0 103 0 124 184 0 47 47 24 184 0 0 69 88 184 0 13 47 27 185 0 13 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 1 0 1 244 184 0 25 208 184 0 0 16 184 0 27 208 184 0 25 16 184 0 28 208 184 0 28 47 184 0 13 16 185 0 36 0 1 244 184 0 1 16 184 0 44 208 184 0 44 47 184 0 27 16 184 0 46 208 48 49 51 53 51 53 46 3 53 52 62 2 51 50 30 2 21 20 14 2 7 21 51 21 35 53 62 1 53 52 46 2 35 34 14 2 21 20 22 23 21 33 17 51 17 44 107 17 35 27 17 35 63 89 54 55 89 63 35 17 27 35 17 107 204 48 61 22 40 59 37 37 58 41 21 61 47 1 179 83 66 3 15 42 52 63 37 54 93 67 38 38 67 93 54 37 63 52 42 15 3 66 59 35 103 75 40 70 50 29 29 50 70 40 75 103 35 59 1 158 254 98 0 255 255 0 3 0 0 1 212 2 6 2 6 4 193 0 0 0 2 0 90 0 0 1 223 2 6 0 16 0 24 0 77 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 5 62 89 184 0 1 16 185 0 3 0 1 244 186 0 23 0 1 0 16 17 18 57 184 0 23 16 185 0 6 0 1 244 184 0 16 16 185 0 18 0 1 244 48 49 51 17 33 21 33 21 51 50 30 2 21 20 14 2 35 39 51 50 53 52 38 43 1 90 1 96 254 243 99 44 76 55 32 30 54 75 45 102 91 134 69 68 88 2 6 69 150 14 34 55 40 41 59 38 18 62 96 46 39 255 255 0 90 0 0 1 229 2 6 2 6 4 194 0 0 255 255 0 90 0 0 1 162 2 6 2 6 5 161 0 0 0 2 0 26 255 84 2 30 2 6 0 22 0 32 0 75 0 125 184 0 1 47 24 184 0 0 69 88 184 0 14 47 27 185 0 14 0 11 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 5 62 89 185 0 3 0 1 244 184 0 26 208 184 0 17 208 184 0 1 16 184 0 20 208 184 0 14 16 185 0 27 0 1 244 48 49 23 35 39 53 51 62 3 55 62 3 55 33 17 51 21 7 35 53 33 55 6 7 51 17 35 14 3 105 71 8 27 9 18 19 19 10 8 12 11 12 7 1 38 70 8 71 254 154 98 24 34 243 146 6 9 9 9 172 188 54 4 22 42 66 49 37 62 61 65 40 254 64 54 188 172 240 118 52 1 124 30 51 48 51 0 255 255 0 90 0 0 1 170 2 6 2 6 4 197 0 0 0 1 0 6 0 0 2 179 2 18 0 43 0 137 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 11 62 89 184 0 0 69 88 184 0 4 47 27 185 0 4 0 5 62 89 187 0 2 0 1 0 19 0 4 43 184 0 4 16 184 0 0 208 186 0 5 0 19 0 2 17 18 57 184 0 15 16 185 0 9 0 2 244 184 0 15 16 184 0 21 208 184 0 21 47 184 0 19 16 184 0 24 208 184 0 15 16 184 0 28 208 184 0 9 16 184 0 34 208 184 0 2 16 184 0 41 208 186 0 38 0 41 0 24 17 18 57 184 0 0 16 184 0 40 208 48 49 33 53 35 7 35 19 39 46 1 35 42 1 7 39 54 51 50 22 31 1 51 53 51 21 51 55 62 1 51 50 23 7 38 34 35 34 6 15 1 19 35 39 35 21 1 54 76 139 89 168 56 18 32 20 5 11 5 14 13 21 40 61 29 64 69 78 69 63 29 62 39 21 13 13 6 10 5 20 33 18 55 167 89 139 75 237 237 1 20 116 38 22 2 75 5 39 57 130 214 214 130 57 39 5 75 2 22 38 115 254 235 237 237 0 1 0 43 255 244 1 191 2 18 0 42 0 77 0 184 0 0 69 88 184 0 28 47 27 185 0 28 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 16 0 1 0 13 0 4 43 184 0 0 16 185 0 7 0 1 244 184 0 28 16 185 0 22 0 1 244 186 0 35 0 13 0 16 17 18 57 48 49 23 34 38 39 55 30 1 51 50 54 53 52 38 43 1 53 51 50 54 53 52 38 35 34 7 39 62 1 51 50 22 21 20 6 7 21 30 1 21 20 14 2 243 60 97 43 42 36 74 48 51 72 73 67 65 49 68 60 58 45 73 54 43 32 90 50 83 99 42 40 48 62 32 55 74 12 36 39 56 32 32 49 46 48 45 56 42 42 37 43 51 55 28 35 75 63 41 60 14 4 9 65 51 38 59 41 22 0 0 0 1 0 90 0 0 1 239 2 6 0 19 0 69 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 11 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 184 0 2 208 184 0 11 16 184 0 19 208 186 0 6 0 19 0 2 17 18 57 186 0 16 0 11 0 10 17 18 57 48 49 1 17 35 53 52 54 55 35 7 3 35 17 51 21 20 6 7 51 55 19 1 239 77 8 3 4 60 192 83 77 8 3 4 60 190 2 6 253 250 245 42 89 41 111 254 206 2 6 243 42 93 39 111 1 50 0 0 255 255 0 90 0 0 1 239 2 188 2 38 5 196 0 0 0 7 7 48 1 42 255 119 0 1 0 90 0 0 2 2 2 18 0 26 0 87 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 3 0 1 0 25 0 4 43 184 0 10 16 184 0 1 208 184 0 1 47 184 0 10 16 185 0 17 0 2 244 186 0 21 0 25 0 3 17 18 57 184 0 0 16 184 0 23 208 48 49 51 17 51 21 51 55 62 3 51 50 22 23 7 46 1 35 34 6 15 1 19 35 39 35 21 90 83 87 78 17 30 30 32 20 9 19 7 15 5 10 6 18 29 23 70 188 89 164 88 2 6 213 131 28 37 21 8 4 2 76 2 2 23 37 115 254 235 237 237 0 0 0 1 0 0 255 244 1 212 2 6 0 27 0 65 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 2 244 184 0 0 16 184 0 18 208 184 0 18 47 184 0 15 16 185 0 19 0 1 244 48 49 23 34 38 39 55 30 1 51 50 62 2 55 62 1 55 33 17 35 17 35 14 1 7 14 3 50 14 25 11 17 6 10 6 11 19 19 18 10 17 31 16 1 32 83 142 13 23 14 13 28 34 41 12 3 4 75 2 2 9 28 54 44 79 156 82 253 250 1 194 66 128 63 61 79 47 18 0 255 255 0 90 0 0 2 45 2 6 2 6 4 205 0 0 255 255 0 90 0 0 1 248 2 6 2 6 4 200 0 0 255 255 0 52 255 244 2 26 2 18 2 6 4 207 0 0 255 255 0 90 0 0 1 242 2 6 2 6 5 174 0 0 255 255 0 90 0 0 1 220 2 6 2 6 4 208 0 0 255 255 0 52 255 244 1 215 2 18 2 6 4 195 0 0 255 255 0 28 0 0 1 183 2 6 2 6 4 212 0 0 0 1 0 5 255 244 1 188 2 6 0 19 0 71 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 5 0 2 244 186 0 8 0 9 0 0 17 18 57 186 0 13 0 0 0 9 17 18 57 184 0 9 16 184 0 15 208 48 49 23 34 39 55 22 51 50 63 1 3 51 31 1 51 63 1 51 3 14 1 120 36 22 17 16 21 46 20 12 189 87 95 44 4 39 88 82 179 23 66 12 8 71 6 38 25 1 138 208 108 108 208 254 93 52 59 0 0 0 0 3 0 47 255 244 2 83 2 18 0 6 0 13 0 31 0 89 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 11 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 184 0 22 16 184 0 21 220 185 0 11 0 1 244 184 0 3 208 184 0 14 16 184 0 15 220 185 0 10 0 1 244 184 0 4 208 184 0 21 16 184 0 24 208 184 0 15 16 184 0 30 208 48 49 1 52 38 39 17 62 1 37 20 22 23 17 14 1 19 53 46 1 53 52 54 55 53 51 21 30 1 21 20 6 7 21 2 4 83 77 77 83 254 121 83 77 77 83 160 112 126 126 112 71 112 127 127 112 1 6 63 67 2 254 247 2 68 63 63 68 2 1 9 2 67 254 175 79 4 98 93 93 98 4 73 73 4 98 93 93 98 4 79 255 255 0 15 0 0 1 182 2 6 2 6 4 216 0 0 0 1 0 90 255 84 2 41 2 6 0 12 0 65 0 125 184 0 11 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 3 0 1 244 184 0 1 16 184 0 5 208 184 0 3 16 184 0 8 208 48 49 51 17 51 17 51 17 51 17 51 21 7 35 53 90 83 226 84 70 8 71 2 6 254 64 1 192 254 64 54 188 172 0 0 0 1 0 67 0 0 1 195 2 6 0 21 0 55 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 5 62 89 187 0 15 0 1 0 4 0 4 43 184 0 10 16 184 0 19 208 48 49 33 53 14 1 35 34 46 2 61 1 51 21 20 22 51 50 54 55 53 51 17 1 111 19 46 32 47 76 52 28 82 66 65 29 41 17 84 225 4 4 18 41 67 49 126 126 62 47 4 4 227 253 250 0 0 0 1 0 90 0 0 2 171 2 6 0 11 0 67 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 185 0 3 0 1 244 184 0 1 16 184 0 5 208 184 0 3 16 184 0 7 208 184 0 5 16 184 0 9 208 48 49 51 17 51 17 51 17 51 17 51 17 51 17 90 80 176 80 177 80 2 6 254 64 1 192 254 64 1 192 253 250 0 0 1 0 90 255 84 2 241 2 6 0 16 0 81 0 125 184 0 0 47 24 184 0 0 69 88 184 0 3 47 27 185 0 3 0 11 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 185 0 5 0 1 244 184 0 3 16 184 0 7 208 184 0 5 16 184 0 9 208 184 0 7 16 184 0 11 208 184 0 9 16 184 0 14 208 48 49 5 53 33 17 51 17 51 17 51 17 51 17 51 17 51 21 7 2 162 253 184 80 176 80 177 80 70 8 172 172 2 6 254 64 1 192 254 64 1 192 254 64 54 188 0 0 2 0 28 0 0 2 68 2 6 0 16 0 25 0 67 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 11 62 89 184 0 0 69 88 184 0 16 47 27 185 0 16 0 5 62 89 187 0 6 0 1 0 24 0 4 43 184 0 3 16 185 0 1 0 1 244 184 0 16 16 185 0 18 0 1 244 48 49 51 17 35 53 33 21 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 202 174 1 1 86 46 77 56 30 30 56 77 46 86 78 66 70 69 69 76 1 192 70 204 17 36 58 40 44 61 40 18 67 45 51 48 43 0 3 0 90 0 0 2 118 2 6 0 3 0 18 0 27 0 73 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 11 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 5 62 89 187 0 8 0 1 0 26 0 4 43 184 0 18 16 184 0 0 208 184 0 5 16 184 0 1 208 184 0 18 16 185 0 20 0 1 244 48 49 33 17 51 17 33 17 51 21 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 2 35 83 253 228 83 76 46 77 56 30 30 56 77 46 76 68 66 70 69 69 66 2 6 253 250 2 6 204 17 36 58 40 44 61 40 18 67 45 51 48 43 0 0 2 0 90 0 0 1 222 2 6 0 14 0 23 0 57 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 14 47 27 185 0 14 0 5 62 89 187 0 4 0 1 0 22 0 4 43 184 0 14 16 185 0 16 0 1 244 48 49 51 17 51 21 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 90 83 96 46 77 56 30 30 56 77 46 96 88 66 70 69 69 86 2 6 204 17 36 58 40 44 61 40 18 67 45 51 48 43 0 0 0 0 1 0 32 255 244 1 194 2 18 0 32 0 73 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 11 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 185 0 17 0 1 244 186 0 20 0 0 0 10 17 18 57 184 0 20 47 185 0 22 0 1 244 184 0 0 16 185 0 26 0 1 244 48 49 19 50 30 2 21 20 14 2 35 34 38 39 55 30 1 51 50 54 55 35 53 51 46 1 35 34 6 7 39 62 1 213 51 87 63 36 37 66 90 52 57 87 29 46 25 63 40 70 85 5 223 222 9 80 66 38 59 26 44 35 81 2 18 36 68 99 64 70 103 68 34 44 29 52 25 30 87 94 63 75 83 27 23 52 33 35 0 0 0 0 2 0 90 255 244 2 253 2 18 0 22 0 34 0 101 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 11 62 89 184 0 0 69 88 184 0 13 47 27 185 0 13 0 11 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 10 0 1 0 3 0 4 43 184 0 0 16 185 0 23 0 1 244 184 0 13 16 185 0 29 0 1 244 48 49 5 34 38 39 35 21 35 17 51 21 51 62 1 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 2 14 102 128 8 115 83 83 116 12 127 98 52 88 64 35 35 64 88 53 70 84 84 70 71 83 83 12 131 116 235 2 6 211 106 117 37 69 100 63 63 102 70 38 70 108 95 95 104 104 95 95 108 0 0 2 0 22 0 0 1 176 2 6 0 15 0 23 0 84 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 11 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 187 0 17 0 1 0 3 0 4 43 186 0 7 0 3 0 17 17 18 57 184 0 0 16 185 0 18 0 1 244 48 49 1 17 35 53 35 7 35 55 46 1 53 52 62 2 51 23 51 53 35 34 6 21 20 1 176 84 95 137 94 152 54 66 30 52 73 43 9 87 86 63 65 2 6 253 250 209 209 218 14 75 60 43 58 35 15 250 184 39 50 95 255 255 0 90 0 0 1 170 2 240 2 38 4 197 0 0 0 7 7 32 1 8 255 141 255 255 0 90 0 0 1 170 2 186 2 38 4 197 0 0 0 7 7 52 1 8 255 141 0 1 0 28 255 246 2 38 2 6 0 39 0 83 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 5 62 89 187 0 33 0 1 0 8 0 4 43 184 0 1 16 185 0 0 0 1 244 184 0 3 208 184 0 18 16 185 0 25 0 1 244 184 0 18 16 184 0 38 208 184 0 38 47 48 49 19 53 33 21 35 21 62 1 51 50 30 2 21 20 14 2 35 34 38 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 21 35 17 28 1 164 189 19 43 29 42 73 54 31 26 43 56 30 15 29 10 13 6 18 7 14 30 24 15 65 61 28 38 17 84 1 193 69 69 146 4 4 18 40 62 44 43 60 37 17 4 3 65 2 4 10 22 36 26 53 49 4 4 244 1 193 0 0 0 255 255 0 90 0 0 1 162 2 218 2 38 5 161 0 0 0 7 7 35 1 14 255 119 0 1 0 52 255 244 1 215 2 18 0 32 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 17 0 1 244 186 0 22 0 10 0 0 17 18 57 184 0 22 47 185 0 21 0 1 244 184 0 0 16 185 0 26 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 7 51 21 35 30 1 51 50 54 55 23 14 1 1 42 53 90 66 37 38 68 92 54 51 79 26 47 22 53 36 68 87 10 222 223 5 87 74 39 59 25 46 34 85 12 35 68 102 66 66 101 69 35 40 26 51 22 25 80 78 63 88 93 29 26 50 37 38 0 0 0 255 255 0 42 255 244 1 180 2 18 2 6 4 211 0 0 255 255 0 90 0 0 0 173 2 6 2 6 4 201 0 0 255 255 255 235 0 0 1 27 2 186 2 38 4 201 0 0 0 7 7 52 0 131 255 141 0 3 0 18 0 0 0 245 2 186 0 11 0 23 0 27 0 61 0 184 0 0 69 88 184 0 25 47 27 185 0 25 0 11 62 89 184 0 0 69 88 184 0 27 47 27 185 0 27 0 5 62 89 186 0 6 0 0 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 19 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 3 17 51 17 63 20 25 25 20 20 25 25 117 20 25 25 20 20 25 25 130 83 2 88 27 22 22 27 27 22 22 27 27 22 22 27 27 22 22 27 253 168 2 6 253 250 0 0 0 255 255 0 31 255 244 1 95 2 6 2 6 4 202 0 0 0 2 0 0 255 244 2 212 2 6 0 38 0 47 0 87 0 184 0 0 69 88 184 0 15 47 27 185 0 15 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 17 0 1 0 47 0 4 43 184 0 0 16 185 0 7 0 2 244 184 0 0 16 184 0 29 208 184 0 29 47 184 0 15 16 185 0 30 0 1 244 184 0 7 16 184 0 39 208 48 49 23 34 38 39 55 30 1 51 50 62 2 55 62 1 55 33 21 51 50 30 2 21 20 14 2 43 1 17 35 14 1 7 14 3 37 51 50 54 53 52 38 43 1 50 14 25 11 17 6 10 6 11 19 19 18 10 17 31 16 1 12 67 46 77 55 31 31 55 77 46 150 122 13 23 14 13 28 34 41 1 115 58 66 71 69 69 57 12 3 4 75 2 2 9 28 54 44 79 156 82 204 17 36 58 40 44 61 40 18 1 194 66 128 63 61 79 47 18 79 45 51 48 43 0 0 0 2 0 90 0 0 2 255 2 6 0 22 0 31 0 103 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 21 0 1 0 0 17 18 57 184 0 21 47 185 0 3 0 1 244 184 0 1 16 184 0 5 208 184 0 3 16 184 0 7 208 184 0 7 47 184 0 0 16 184 0 19 208 185 0 24 0 1 244 184 0 21 16 184 0 31 208 184 0 31 47 48 49 51 17 51 21 51 53 51 21 51 50 30 2 21 20 14 2 43 1 53 35 21 37 51 50 54 53 52 38 43 1 90 83 234 84 67 46 77 55 31 31 55 78 46 150 234 1 62 58 66 71 69 69 57 2 6 211 211 204 17 36 58 40 44 61 40 18 235 235 67 45 51 48 43 0 1 0 28 0 0 2 32 2 6 0 25 0 69 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 24 47 27 185 0 24 0 5 62 89 187 0 8 0 1 0 19 0 4 43 184 0 1 16 185 0 0 0 1 244 184 0 3 208 184 0 24 16 184 0 15 208 48 49 19 53 33 21 35 21 62 1 51 50 30 2 29 1 35 53 52 38 35 34 6 7 21 35 17 28 1 164 189 19 43 29 46 72 50 26 82 60 60 28 38 17 84 1 193 69 69 146 4 4 18 39 65 46 143 143 62 47 4 4 244 1 193 0 0 255 255 0 90 0 0 2 2 2 218 2 38 5 198 0 0 0 7 7 35 1 35 255 119 255 255 0 90 0 0 1 239 2 218 2 38 5 196 0 0 0 7 7 32 1 42 255 119 255 255 0 5 255 244 1 188 2 188 2 38 5 207 0 0 0 7 7 48 0 226 255 119 0 1 0 90 255 84 1 238 2 6 0 11 0 59 0 125 184 0 10 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 1 16 184 0 5 208 184 0 0 16 184 0 8 208 48 49 51 17 51 17 51 17 51 17 35 7 35 39 90 83 237 84 160 9 69 4 2 6 254 64 1 192 253 250 172 172 0 0 2 0 28 0 0 1 244 2 46 0 22 0 31 0 72 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 5 62 89 186 0 4 0 1 0 3 43 187 0 12 0 1 0 30 0 4 43 184 0 4 16 184 0 5 220 184 0 4 16 184 0 7 208 184 0 1 16 184 0 9 208 184 0 22 16 185 0 24 0 1 244 48 49 51 17 35 53 51 53 51 21 51 21 35 21 51 50 30 2 21 20 14 2 35 39 51 50 54 53 52 38 43 1 141 113 113 84 194 194 66 46 77 55 31 31 55 78 46 65 57 66 70 68 69 56 1 145 58 99 99 58 94 16 36 56 40 42 61 38 18 63 44 51 48 40 0 3 0 52 255 244 2 26 2 18 0 19 0 26 0 33 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 185 0 20 0 1 244 186 0 31 0 10 0 0 17 18 57 184 0 31 47 185 0 24 0 1 244 184 0 0 16 185 0 27 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 3 34 6 7 33 46 1 3 50 54 55 33 30 1 1 39 54 89 64 36 36 64 89 54 53 89 65 36 36 65 89 53 66 84 9 1 62 9 85 65 69 86 5 254 192 5 86 12 37 70 101 65 65 100 69 35 35 69 100 65 65 101 70 37 1 219 83 78 78 83 254 104 95 89 89 95 0 0 1 0 0 0 0 1 229 2 18 0 25 0 69 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 14 16 184 0 1 208 184 0 1 47 186 0 6 0 1 0 0 17 18 57 184 0 14 16 185 0 21 0 2 244 48 49 51 3 51 19 30 1 23 51 62 1 63 1 62 1 51 50 22 23 7 46 1 35 34 6 7 3 175 175 87 85 14 24 14 5 13 21 13 48 18 50 48 15 19 11 17 6 9 7 19 21 8 120 2 6 254 243 44 81 45 50 76 44 160 66 55 3 4 75 3 1 31 27 254 118 0 0 0 0 1 0 90 0 0 1 170 2 175 0 7 0 53 0 124 184 0 3 47 24 184 0 0 69 88 184 0 1 47 27 185 0 1 0 11 62 89 184 0 0 69 88 184 0 7 47 27 185 0 7 0 5 62 89 184 0 1 16 185 0 5 0 1 244 48 49 51 17 51 55 51 7 35 17 90 252 16 68 8 245 2 6 169 239 254 64 0 0 1 0 33 0 0 1 184 2 6 0 13 0 81 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 11 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 186 0 9 0 3 0 11 17 18 57 184 0 9 47 184 0 8 220 184 0 1 208 184 0 1 47 184 0 3 16 185 0 6 0 1 244 184 0 9 16 184 0 13 208 48 49 55 53 55 53 33 21 35 21 51 21 35 21 35 53 33 79 1 72 245 149 149 83 231 44 3 240 70 170 47 231 231 0 0 0 1 0 6 255 84 2 205 2 18 0 48 0 149 0 125 184 0 0 47 24 184 0 0 69 88 184 0 21 47 27 185 0 21 0 11 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 187 0 25 0 1 0 8 0 4 43 184 0 10 16 184 0 6 208 184 0 2 208 184 0 8 16 184 0 3 208 186 0 11 0 25 0 8 17 18 57 184 0 21 16 185 0 15 0 2 244 184 0 21 16 184 0 27 208 184 0 27 47 184 0 25 16 184 0 30 208 184 0 21 16 184 0 34 208 184 0 15 16 184 0 40 208 186 0 44 0 3 0 30 17 18 57 184 0 2 16 185 0 46 0 1 244 48 49 5 53 35 39 35 21 35 53 35 7 35 19 39 46 1 35 42 1 7 39 54 51 50 22 31 1 51 53 51 21 51 55 62 1 51 50 23 7 38 34 35 34 6 15 1 23 51 21 7 2 126 36 139 75 78 76 139 89 168 56 18 32 20 5 11 5 14 13 21 40 61 29 64 69 78 69 63 29 62 39 21 13 13 6 10 5 20 33 18 55 125 68 8 172 172 237 237 237 237 1 20 116 38 22 2 75 5 39 57 130 214 214 130 57 39 5 75 2 22 38 115 207 54 188 0 0 1 0 43 255 84 1 191 2 18 0 45 0 97 0 125 184 0 0 47 24 184 0 0 69 88 184 0 29 47 27 185 0 29 0 11 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 185 0 8 0 1 244 186 0 15 0 29 0 1 17 18 57 184 0 15 47 185 0 16 0 1 244 184 0 29 16 185 0 23 0 1 244 186 0 35 0 16 0 15 17 18 57 184 0 1 16 184 0 44 208 48 49 23 39 46 1 39 55 30 1 51 50 54 53 52 38 43 1 53 51 50 54 53 52 38 35 34 7 39 62 1 51 50 22 21 20 6 7 21 30 1 21 20 14 2 15 1 208 3 47 79 36 42 36 74 48 51 72 73 67 65 49 68 60 58 45 73 54 43 32 90 50 83 99 42 40 48 62 24 43 59 34 9 172 162 5 36 32 56 32 32 49 46 48 45 56 42 42 37 43 51 55 28 35 75 63 41 60 14 4 9 65 51 33 54 40 25 5 163 0 1 0 90 255 84 2 29 2 18 0 31 0 103 0 125 184 0 0 47 24 184 0 0 69 88 184 0 16 47 27 185 0 16 0 11 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 187 0 9 0 1 0 4 0 4 43 184 0 6 16 184 0 2 208 184 0 16 16 184 0 7 208 184 0 7 47 184 0 16 16 185 0 23 0 2 244 186 0 27 0 9 0 4 17 18 57 184 0 2 16 185 0 29 0 1 244 48 49 5 53 35 39 35 21 35 17 51 21 51 55 62 3 51 50 22 23 7 46 1 35 34 6 15 1 23 51 21 7 1 206 37 164 88 83 83 87 78 17 30 30 32 20 9 19 7 15 5 10 6 18 29 23 70 140 75 8 172 172 237 237 2 6 213 131 28 37 21 8 4 2 76 2 2 23 37 115 207 54 188 0 0 0 1 0 28 0 0 2 114 2 18 0 29 0 116 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 11 62 89 184 0 0 69 88 184 0 15 47 27 185 0 15 0 11 62 89 184 0 0 69 88 184 0 3 47 27 185 0 3 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 25 47 27 185 0 25 0 5 62 89 187 0 6 0 1 0 27 0 4 43 184 0 3 16 185 0 1 0 1 244 184 0 18 208 184 0 18 47 48 49 51 17 35 53 33 21 51 55 62 3 51 50 22 23 7 38 35 34 14 2 15 1 19 35 39 35 21 202 174 1 1 87 78 17 30 30 32 20 9 19 7 15 10 10 9 16 16 18 12 70 188 89 164 88 1 192 70 213 131 28 37 21 8 4 2 76 4 5 13 23 19 115 254 235 237 237 0 0 0 1 0 90 255 84 2 63 2 6 0 16 0 85 0 125 184 0 0 47 24 184 0 0 69 88 184 0 7 47 27 185 0 7 0 11 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 184 0 2 208 186 0 4 0 7 0 6 17 18 57 184 0 4 47 185 0 10 0 1 244 184 0 7 16 184 0 11 208 184 0 2 16 185 0 14 0 1 244 48 49 5 53 35 53 35 21 35 17 51 21 51 53 51 17 51 21 7 1 240 75 248 83 83 248 83 71 8 172 172 235 235 2 6 211 211 254 64 54 188 0 0 0 1 0 52 255 84 1 215 2 18 0 31 0 71 0 125 184 0 0 47 24 184 0 0 69 88 184 0 11 47 27 185 0 11 0 11 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 11 16 185 0 18 0 1 244 184 0 1 16 185 0 24 0 1 244 184 0 1 16 184 0 30 208 48 49 23 39 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 23 6 15 1 247 4 42 70 51 28 39 67 93 54 50 79 26 47 22 51 34 77 92 88 77 39 59 25 46 59 87 9 172 165 8 43 67 91 56 63 101 71 37 40 26 51 22 25 106 94 95 107 29 26 50 65 9 161 255 255 255 255 0 0 1 160 2 6 2 6 4 217 0 0 0 1 255 255 0 0 1 160 2 6 0 22 0 85 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 11 62 89 184 0 0 69 88 184 0 21 47 27 185 0 21 0 5 62 89 186 0 3 0 4 0 21 17 18 57 184 0 4 16 184 0 14 208 186 0 9 0 14 0 21 17 18 57 184 0 3 16 184 0 17 208 184 0 3 16 184 0 22 220 184 0 18 208 48 49 55 53 55 51 3 51 23 30 1 23 51 62 1 63 1 51 3 51 21 35 21 35 53 55 88 9 153 88 66 13 27 14 4 14 25 14 66 86 153 99 113 83 176 43 4 1 39 137 29 55 29 29 55 29 137 254 217 47 176 176 0 0 1 0 15 255 84 1 209 2 6 0 30 0 105 0 125 184 0 0 47 24 184 0 0 69 88 184 0 14 47 27 185 0 14 0 11 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 184 0 2 208 186 0 6 0 14 0 12 17 18 57 184 0 14 16 184 0 24 208 186 0 19 0 2 0 24 17 18 57 186 0 13 0 19 0 6 17 18 57 186 0 26 0 6 0 19 17 18 57 184 0 2 16 185 0 28 0 1 244 48 49 5 53 35 39 46 1 39 35 14 1 15 1 35 19 39 51 23 30 1 23 51 62 1 63 1 51 7 23 51 21 7 1 130 40 76 11 22 13 4 11 21 11 74 88 161 150 91 70 10 19 13 4 11 19 9 67 88 150 118 70 8 172 172 128 20 41 24 24 41 20 128 1 11 251 122 17 37 23 23 37 17 122 255 193 54 188 0 0 0 0 1 0 67 255 84 2 10 2 6 0 26 0 71 0 125 184 0 0 47 24 184 0 0 69 88 184 0 12 47 27 185 0 12 0 11 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 187 0 17 0 1 0 6 0 4 43 184 0 12 16 184 0 21 208 184 0 1 16 185 0 24 0 1 244 48 49 5 53 35 53 14 1 35 34 46 2 61 1 51 21 20 22 51 50 54 55 53 51 17 51 21 7 1 186 75 19 46 32 47 76 52 28 82 66 65 29 41 17 84 71 9 172 172 225 4 4 18 41 67 49 126 126 62 47 4 4 227 254 64 54 188 0 0 0 1 0 90 0 0 1 218 2 6 0 21 0 55 0 184 0 0 69 88 184 0 21 47 27 185 0 21 0 11 62 89 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 187 0 4 0 1 0 15 0 4 43 184 0 19 16 184 0 10 208 48 49 19 21 62 1 51 50 30 2 29 1 35 53 52 38 35 34 6 7 21 35 17 173 20 45 32 48 75 53 28 82 66 65 29 42 17 83 2 6 200 4 4 18 41 67 49 151 151 62 47 4 4 252 2 6 0 255 255 0 90 0 0 0 173 2 6 2 6 4 201 0 0 255 255 0 6 0 0 2 179 2 191 2 38 5 194 0 0 0 7 7 48 1 92 255 122 255 255 0 3 0 0 1 212 2 191 2 38 4 193 0 0 0 7 7 48 0 234 255 122 255 255 0 8 0 0 2 151 2 6 2 6 4 241 0 0 255 255 0 90 0 0 1 170 2 210 2 38 4 197 0 0 0 7 7 48 1 8 255 141 255 255 0 58 255 244 2 18 2 18 2 6 5 155 0 0 255 255 0 90 0 0 1 239 2 143 2 38 5 196 0 0 0 7 7 42 1 42 255 119 255 255 0 52 255 244 2 26 2 167 2 38 4 207 0 0 0 7 7 52 1 38 255 122 255 255 0 52 255 244 2 26 2 18 2 6 5 238 0 0 255 255 0 5 255 244 1 188 2 143 2 38 5 207 0 0 0 7 7 42 0 226 255 119 255 255 0 5 255 244 1 188 2 227 2 38 5 207 0 0 0 7 7 58 0 226 255 119 0 3 0 32 255 244 2 7 2 18 0 44 0 56 0 68 0 147 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 48 0 18 0 0 17 18 57 186 0 63 0 0 0 18 17 18 57 186 0 10 0 48 0 63 17 18 57 186 0 26 0 63 0 48 17 18 57 186 0 33 0 18 0 0 17 18 57 186 0 29 0 33 0 0 17 18 57 186 0 42 0 0 0 33 17 18 57 186 0 36 0 42 0 29 17 18 57 184 0 18 16 185 0 54 0 1 244 184 0 0 16 185 0 57 0 1 244 186 0 60 0 29 0 42 17 18 57 48 49 23 34 46 2 53 52 62 2 55 46 1 53 52 62 2 51 50 22 21 20 14 2 7 30 1 23 62 1 55 51 14 1 7 30 1 23 7 38 39 14 1 3 20 22 23 62 1 53 52 38 35 34 6 19 50 54 55 46 1 39 14 1 21 20 22 204 39 64 45 24 18 30 40 21 17 20 19 35 49 30 54 59 22 35 45 23 28 72 38 25 38 12 75 17 47 33 28 52 23 21 62 69 32 80 85 14 12 38 53 23 27 30 37 43 26 51 23 40 72 29 28 36 60 12 23 40 53 31 26 43 35 30 13 31 60 28 26 47 35 21 63 48 25 41 36 32 15 37 69 29 31 74 42 51 91 41 17 22 6 66 15 45 27 33 1 157 20 43 23 22 48 33 22 33 41 254 131 20 17 32 74 40 20 46 28 41 48 0 2 0 55 255 244 1 194 2 18 0 15 0 27 0 53 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 16 0 1 244 184 0 8 16 185 0 22 0 1 244 48 49 23 34 46 2 53 52 54 51 50 22 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 252 45 73 51 28 106 91 91 107 28 51 74 45 51 64 64 51 50 65 64 12 38 70 102 63 127 142 142 127 63 102 70 38 66 101 106 107 96 97 106 106 101 0 0 0 0 1 0 50 0 0 0 238 2 6 0 8 0 51 0 184 0 0 69 88 184 0 6 47 27 185 0 6 0 11 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 184 0 6 16 184 0 3 220 185 0 1 0 1 244 48 49 51 17 35 53 62 1 55 51 17 156 106 41 58 26 63 1 169 53 7 19 14 253 250 0 1 0 34 0 0 1 152 2 18 0 31 0 61 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 11 62 89 184 0 0 69 88 184 0 31 47 27 185 0 31 0 5 62 89 185 0 29 0 1 244 184 0 1 208 184 0 1 47 184 0 16 16 185 0 9 0 1 244 48 49 51 53 62 3 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 14 2 7 62 1 59 1 21 40 63 99 68 35 51 52 37 61 24 46 37 86 53 40 65 45 24 35 60 82 48 22 53 27 147 48 55 91 78 67 30 44 51 35 24 45 38 42 22 41 57 34 37 73 76 81 44 2 3 70 0 0 0 1 0 23 255 244 1 151 2 18 0 47 0 77 0 184 0 0 69 88 184 0 31 47 27 185 0 31 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 16 0 1 0 15 0 4 43 184 0 0 16 185 0 7 0 1 244 184 0 31 16 185 0 24 0 1 244 186 0 40 0 15 0 16 17 18 57 48 49 23 34 38 39 55 30 1 51 50 54 53 52 46 2 35 53 50 62 2 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 213 66 95 29 40 26 71 53 48 63 18 42 69 51 45 61 37 17 50 45 35 62 26 42 34 82 51 38 65 47 26 57 46 52 71 30 53 71 12 44 30 52 24 36 48 40 22 35 25 14 60 14 24 33 19 36 42 28 25 51 29 37 18 35 51 32 45 60 17 3 11 66 54 35 56 39 20 0 2 0 36 0 0 1 191 2 6 0 10 0 20 0 83 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 11 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 186 0 8 0 4 0 10 17 18 57 184 0 8 47 184 0 1 208 184 0 8 16 185 0 7 0 1 244 184 0 12 208 184 0 3 208 186 0 16 0 4 0 10 17 18 57 48 49 33 53 33 53 19 51 17 51 21 35 21 39 51 53 52 54 55 35 14 1 7 1 37 254 255 241 93 77 77 250 173 2 1 3 13 20 14 138 54 1 70 254 195 63 138 201 133 22 59 22 20 30 21 0 1 0 31 255 244 1 158 2 6 0 36 0 77 0 184 0 0 69 88 184 0 20 47 27 185 0 20 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 7 0 1 244 186 0 15 0 20 0 0 17 18 57 184 0 15 47 184 0 20 16 185 0 22 0 1 244 184 0 15 16 185 0 27 0 1 244 48 49 23 34 38 39 55 30 1 51 50 62 2 53 52 38 35 34 6 7 39 55 33 21 35 7 62 1 51 50 30 2 21 20 14 2 218 68 89 30 38 26 67 51 25 44 32 18 64 51 31 43 25 42 18 1 36 223 12 19 41 25 36 65 49 28 33 54 71 12 44 28 53 23 36 15 29 40 26 50 57 17 16 25 255 68 143 9 13 20 40 61 42 43 66 45 24 0 0 0 2 0 62 255 244 1 186 2 18 0 32 0 44 0 77 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 25 0 1 0 39 0 4 43 184 0 10 16 185 0 17 0 1 244 186 0 22 0 0 0 10 17 18 57 184 0 0 16 185 0 33 0 1 244 48 49 5 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 14 2 7 62 1 51 50 22 21 20 14 2 39 50 54 53 52 38 35 34 6 7 30 1 1 10 44 74 55 31 37 62 81 45 48 70 26 45 18 51 29 30 52 41 25 1 27 74 38 75 89 28 48 64 35 41 57 53 53 27 65 26 8 64 12 31 62 95 65 77 110 70 32 33 24 50 18 22 21 49 80 58 29 35 81 81 38 63 44 24 63 57 47 47 57 30 34 74 70 0 0 0 0 1 0 33 0 0 1 140 2 6 0 14 0 51 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 7 16 185 0 5 0 1 244 184 0 9 208 48 49 51 62 3 55 33 53 33 21 14 3 7 142 4 20 37 58 42 254 242 1 107 51 63 36 17 4 71 119 107 100 53 68 49 58 104 109 122 76 0 0 3 0 54 255 244 1 181 2 18 0 37 0 51 0 65 0 87 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 11 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 38 0 1 0 60 0 4 43 186 0 10 0 38 0 60 17 18 57 186 0 27 0 60 0 38 17 18 57 184 0 19 16 185 0 44 0 1 244 184 0 0 16 185 0 52 0 1 244 48 49 23 34 46 2 53 52 62 2 55 53 46 1 53 52 62 2 51 50 22 21 20 14 2 7 21 30 3 21 20 14 2 3 62 1 53 52 38 35 34 6 21 20 30 2 7 50 54 53 52 46 2 39 14 1 21 20 22 247 42 70 52 29 19 31 39 20 33 49 26 45 61 35 78 90 15 23 28 14 20 36 28 17 27 50 70 5 29 31 52 47 40 51 21 36 47 9 51 61 24 40 56 31 33 49 69 12 21 38 52 30 26 43 34 27 10 4 20 59 41 31 51 36 19 78 60 21 38 31 26 9 3 11 24 32 41 26 30 52 38 22 1 42 22 51 26 37 49 42 36 21 33 25 19 248 46 39 23 34 26 21 11 18 53 36 41 52 0 0 2 0 49 255 244 1 170 2 18 0 10 0 43 0 77 0 184 0 0 69 88 184 0 34 47 27 185 0 34 0 11 62 89 184 0 0 69 88 184 0 11 47 27 185 0 11 0 5 62 89 187 0 0 0 1 0 26 0 4 43 184 0 34 16 185 0 5 0 1 244 184 0 11 16 185 0 18 0 1 244 186 0 23 0 11 0 34 17 18 57 48 49 19 50 54 55 38 35 34 6 21 20 22 19 34 38 39 55 30 1 51 50 62 2 55 14 1 35 34 38 53 52 62 2 51 50 30 2 21 20 14 2 229 26 63 28 15 109 39 57 52 26 49 72 24 44 18 51 29 29 52 40 24 2 26 72 37 74 90 28 47 63 35 43 75 55 31 37 61 81 1 2 29 35 145 57 48 49 55 254 242 33 23 50 17 22 21 49 79 58 29 34 81 81 38 63 44 24 31 62 96 64 78 109 70 32 0 0 2 0 85 255 244 0 204 2 6 0 5 0 17 0 45 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 11 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 184 0 12 220 184 0 0 220 48 49 55 47 1 51 15 2 34 38 53 52 54 51 50 22 21 20 6 116 11 2 83 2 11 28 25 35 35 25 24 35 35 198 240 80 80 240 210 35 27 29 35 35 29 27 35 0 0 0 2 0 85 0 0 0 204 2 18 0 5 0 17 0 49 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 11 62 89 184 0 0 69 88 184 0 5 47 27 185 0 5 0 5 62 89 184 0 12 16 184 0 6 220 184 0 2 220 48 49 51 63 1 51 31 1 3 34 38 53 52 54 51 50 22 21 20 6 103 2 11 57 11 2 41 25 35 35 25 24 35 35 80 240 240 80 1 148 35 29 27 35 35 27 29 35 0 0 2 0 48 255 244 1 111 2 38 0 26 0 38 0 42 0 184 0 0 69 88 184 0 27 47 27 185 0 27 0 5 62 89 187 0 10 0 1 0 16 0 4 43 184 0 27 16 184 0 33 220 184 0 0 220 48 49 55 38 62 4 53 52 38 35 34 7 39 62 1 51 50 22 21 20 14 4 23 7 34 38 53 52 54 51 50 22 21 20 6 160 5 15 28 36 31 22 43 44 62 50 40 31 79 52 72 85 22 33 37 30 17 4 34 25 34 34 25 25 35 35 198 27 40 32 28 31 35 23 29 42 49 48 29 37 68 58 31 44 34 28 30 35 24 210 35 27 29 35 35 29 27 35 0 0 0 2 0 58 255 224 1 121 2 18 0 26 0 38 0 42 0 184 0 0 69 88 184 0 33 47 27 185 0 33 0 11 62 89 187 0 21 0 1 0 0 0 4 43 184 0 33 16 184 0 27 220 184 0 10 220 48 49 23 34 38 53 52 62 4 39 51 22 14 4 21 20 22 51 50 55 23 14 1 3 34 38 53 52 54 51 50 22 21 20 6 215 72 85 22 33 36 30 17 4 73 5 15 28 36 31 22 43 44 62 50 40 31 79 40 25 35 35 25 24 35 35 32 68 58 31 44 34 28 30 35 24 27 40 32 28 31 35 23 29 42 49 48 29 37 1 180 35 29 27 35 35 27 29 35 0 255 255 0 80 1 91 0 168 2 94 2 6 4 126 0 172 255 255 0 80 1 91 1 88 2 94 0 38 4 126 0 172 0 7 4 126 0 176 255 172 255 255 0 57 1 88 0 187 2 100 2 6 4 128 0 172 255 255 0 63 1 91 0 193 2 103 2 6 4 129 0 172 255 255 0 57 1 88 1 107 2 100 0 38 4 128 0 172 0 7 4 128 0 176 255 172 255 255 0 63 1 91 1 113 2 103 0 38 4 129 0 172 0 7 4 129 0 176 255 172 255 255 0 41 0 239 1 15 1 46 2 6 4 138 0 20 0 1 0 41 0 243 1 115 1 44 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 55 53 33 21 41 1 74 243 57 57 0 0 0 0 1 0 41 0 243 2 134 1 44 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 55 53 33 21 41 2 93 243 57 57 0 0 0 0 1 0 82 255 130 1 9 2 118 0 13 0 11 0 186 0 6 0 0 0 3 43 48 49 23 46 1 53 52 54 55 23 14 1 21 20 22 23 214 63 69 69 63 51 58 57 57 58 126 84 184 110 109 184 85 24 79 181 94 94 182 78 0 0 1 0 38 255 130 0 221 2 118 0 13 0 11 0 186 0 8 0 0 0 3 43 48 49 23 39 62 1 53 52 38 39 55 30 1 21 20 6 89 51 58 57 57 58 51 63 69 69 126 24 78 182 94 94 181 79 24 85 184 109 110 184 0 0 1 0 94 255 154 1 17 2 93 0 7 0 23 0 187 0 5 0 1 0 0 0 4 43 187 0 2 0 1 0 3 0 4 43 48 49 23 17 51 21 35 17 51 21 94 179 117 117 102 2 195 47 253 155 47 0 1 0 31 255 154 0 209 2 93 0 7 0 23 0 187 0 1 0 1 0 0 0 4 43 187 0 6 0 1 0 3 0 4 43 48 49 23 53 51 17 35 53 51 17 31 116 116 178 102 47 2 101 47 253 61 0 1 0 34 255 154 1 17 2 93 0 47 0 43 0 187 0 45 0 1 0 0 0 4 43 187 0 24 0 1 0 25 0 4 43 187 0 12 0 1 0 11 0 4 43 186 0 36 0 11 0 12 17 18 57 48 49 23 34 38 53 52 54 53 52 46 2 35 53 50 62 2 53 52 38 53 52 54 59 1 21 35 34 6 21 20 22 21 20 6 7 21 30 1 21 20 6 21 20 22 59 1 21 228 59 58 9 8 19 34 25 25 34 19 8 9 58 59 45 27 41 27 6 28 32 32 28 6 27 41 27 102 49 68 38 62 36 14 26 21 14 52 13 20 26 14 37 61 39 68 49 47 34 40 33 58 34 48 49 8 4 9 50 46 35 58 32 40 35 47 0 0 0 1 0 31 255 154 1 13 2 93 0 45 0 43 0 187 0 1 0 1 0 0 0 4 43 187 0 24 0 1 0 21 0 4 43 187 0 35 0 1 0 36 0 4 43 186 0 12 0 36 0 35 17 18 57 48 49 23 53 51 50 54 53 52 38 53 52 54 55 53 46 1 53 52 54 53 52 38 43 1 53 51 50 22 21 20 6 21 20 30 2 51 21 14 1 21 20 22 21 20 6 35 31 26 41 27 5 27 32 32 27 5 27 41 26 44 60 57 9 8 20 33 25 50 36 9 57 60 102 47 35 40 32 58 35 46 50 9 4 8 49 48 34 58 33 40 34 47 49 68 39 61 37 14 26 20 13 52 1 46 28 36 62 38 68 49 0 0 255 255 0 35 1 127 1 77 3 29 2 7 6 66 0 0 1 139 0 0 255 255 0 87 1 139 0 236 3 17 2 7 6 67 0 0 1 139 0 0 255 255 0 40 1 139 1 64 3 29 2 7 6 68 0 0 1 139 0 0 255 255 0 35 1 127 1 63 3 29 2 7 6 69 0 0 1 139 0 0 255 255 0 42 1 139 1 80 3 17 2 7 6 70 0 0 1 139 0 0 255 255 0 35 1 127 1 67 3 17 2 7 6 71 0 0 1 139 0 0 255 255 0 45 1 127 1 70 3 29 2 7 6 72 0 0 1 139 0 0 255 255 0 50 1 139 1 67 3 17 2 7 6 73 0 0 1 139 0 0 255 255 0 45 1 127 1 64 3 29 2 7 6 74 0 0 1 139 0 0 255 255 0 39 1 127 1 64 3 29 2 7 6 75 0 0 1 139 0 0 255 255 0 65 1 60 0 198 3 94 2 7 6 76 0 0 1 139 0 0 255 255 0 39 1 60 0 172 3 94 2 7 6 77 0 0 1 139 0 0 255 255 0 43 1 131 0 134 1 226 2 7 6 78 0 0 1 139 0 0 255 255 0 33 1 23 0 144 1 226 2 7 6 79 0 0 1 139 0 0 255 255 0 35 255 68 1 77 0 226 2 7 6 66 0 0 255 80 0 0 255 255 0 87 255 80 0 236 0 214 2 7 6 67 0 0 255 80 0 0 255 255 0 40 255 80 1 64 0 226 2 7 6 68 0 0 255 80 0 0 255 255 0 35 255 68 1 63 0 226 2 7 6 69 0 0 255 80 0 0 255 255 0 42 255 80 1 80 0 214 2 7 6 70 0 0 255 80 0 0 255 255 0 35 255 68 1 67 0 214 2 7 6 71 0 0 255 80 0 0 255 255 0 45 255 68 1 70 0 226 2 7 6 72 0 0 255 80 0 0 255 255 0 50 255 80 1 67 0 214 2 7 6 73 0 0 255 80 0 0 255 255 0 45 255 68 1 64 0 226 2 7 6 74 0 0 255 80 0 0 255 255 0 39 255 68 1 64 0 226 2 7 6 75 0 0 255 80 0 0 255 255 0 65 255 1 0 198 1 35 2 7 6 76 0 0 255 80 0 0 255 255 0 39 255 1 0 172 1 35 2 7 6 77 0 0 255 80 0 0 255 255 0 43 255 72 0 134 255 167 2 7 6 78 0 0 255 80 0 0 255 255 0 33 254 220 0 144 255 167 2 7 6 79 0 0 255 80 0 0 0 2 0 35 255 244 1 77 1 146 0 11 0 23 0 36 0 184 0 6 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 12 220 184 0 6 16 184 0 18 220 48 49 23 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 184 68 81 81 68 67 82 82 67 38 48 48 38 39 48 48 12 108 100 99 107 107 99 100 108 51 79 78 78 77 77 78 78 79 0 0 0 1 0 87 0 0 0 236 1 134 0 8 0 32 0 184 0 7 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 7 16 184 0 1 220 48 49 51 17 35 53 62 1 55 51 17 172 85 33 44 20 52 1 52 42 6 19 15 254 122 0 0 0 0 1 0 40 0 0 1 64 1 146 0 26 0 44 0 184 0 16 47 184 0 0 69 88 184 0 26 47 27 185 0 26 0 5 62 89 184 0 24 220 184 0 1 208 184 0 1 47 184 0 16 16 184 0 9 220 48 49 51 53 62 3 53 52 38 35 34 6 7 39 62 1 51 50 22 21 20 14 2 7 51 21 52 45 70 46 24 40 35 25 42 17 38 23 67 40 59 71 22 39 53 31 165 37 41 65 54 47 22 38 44 33 24 35 34 42 64 62 28 52 53 56 32 55 0 1 0 35 255 244 1 63 1 146 0 42 0 60 0 184 0 27 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 14 0 1 0 13 0 4 43 184 0 0 16 184 0 7 220 184 0 27 16 184 0 20 220 186 0 35 0 14 0 13 17 18 57 48 49 23 34 38 39 55 30 1 51 50 54 53 52 38 35 53 50 54 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 30 1 21 20 14 2 180 48 74 23 43 18 50 31 32 46 64 57 51 55 39 32 22 40 17 39 26 61 41 25 45 34 20 38 30 33 51 22 38 51 12 43 33 33 27 31 36 34 34 35 41 40 30 28 34 27 20 34 29 35 14 27 39 25 35 47 14 8 49 39 27 43 31 16 0 0 2 0 42 0 0 1 80 1 134 0 10 0 16 0 74 0 184 0 5 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 12 0 1 0 3 43 184 0 12 16 184 0 11 208 184 0 3 208 184 0 3 47 184 0 12 16 184 0 6 208 184 0 1 16 184 0 9 208 186 0 14 0 5 0 0 17 18 57 48 49 51 53 35 53 55 51 21 51 21 35 21 39 51 53 55 35 7 220 178 164 72 58 58 169 111 4 4 50 104 33 253 240 46 104 150 70 109 81 0 1 0 35 255 244 1 67 1 134 0 34 0 48 0 184 0 18 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 13 0 25 0 3 43 184 0 0 16 184 0 7 220 184 0 18 16 184 0 20 220 48 49 23 34 38 39 55 30 1 51 50 54 53 52 38 35 34 6 7 39 55 51 21 35 7 62 1 51 50 30 2 21 20 14 2 183 52 73 23 43 19 48 34 35 45 46 36 23 35 16 31 18 213 160 11 14 32 17 26 47 35 20 22 37 51 12 43 33 33 27 31 48 38 40 46 18 14 23 188 56 95 6 9 17 34 49 31 30 50 35 20 0 0 2 0 45 255 244 1 70 1 146 0 27 0 39 0 48 0 184 0 8 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 34 0 20 0 3 43 184 0 8 16 184 0 15 220 184 0 0 16 184 0 28 220 48 49 23 34 38 53 52 62 2 51 50 22 23 7 46 1 35 34 6 7 54 51 50 22 21 20 14 2 39 50 54 53 52 38 35 34 6 7 30 1 196 69 82 26 46 62 36 34 44 17 26 14 33 20 44 62 5 43 55 59 63 20 35 47 29 32 39 38 37 22 40 23 5 48 12 104 93 55 82 54 26 18 12 45 10 14 71 75 40 69 56 28 48 36 20 51 45 35 35 44 19 24 58 58 0 0 0 1 0 50 0 0 1 67 1 134 0 14 0 40 0 184 0 7 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 7 16 184 0 5 220 184 0 9 208 184 0 9 47 48 49 51 62 3 55 35 53 33 21 14 3 7 131 3 16 28 43 30 201 1 17 36 45 28 13 3 51 86 80 77 41 55 36 45 84 85 89 51 0 0 3 0 45 255 244 1 64 1 146 0 33 0 45 0 58 0 68 0 184 0 17 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 34 0 54 0 3 43 186 0 9 0 34 0 54 17 18 57 186 0 25 0 54 0 34 17 18 57 184 0 17 16 184 0 40 220 184 0 0 16 184 0 46 220 48 49 23 34 46 2 53 52 54 55 53 46 1 53 52 62 2 51 50 22 21 20 14 2 7 21 30 1 21 20 14 2 39 62 1 53 52 38 35 34 6 21 20 22 23 50 54 53 52 46 2 39 6 21 20 22 182 31 50 36 20 45 29 26 32 19 33 44 25 53 72 11 18 21 10 34 39 21 37 50 7 22 20 38 27 26 36 50 12 32 46 17 28 36 20 54 42 12 17 30 40 22 37 55 17 4 17 41 31 23 38 27 15 55 48 17 28 24 18 7 4 17 49 35 24 41 30 17 235 17 37 20 26 30 31 24 30 34 199 39 28 18 24 18 14 8 32 49 26 42 0 0 0 2 0 39 255 244 1 64 1 146 0 11 0 39 0 48 0 184 0 32 47 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 186 0 24 0 0 0 3 43 184 0 32 16 184 0 6 220 184 0 12 16 184 0 19 220 48 49 55 50 54 55 46 1 35 34 6 21 20 22 23 34 38 39 55 30 1 51 50 54 55 6 35 34 38 53 52 62 2 51 50 22 21 20 14 2 173 23 40 23 5 48 37 31 40 39 13 34 45 17 27 14 33 20 44 62 5 43 55 59 63 20 34 48 27 70 82 26 46 62 192 19 24 58 58 45 35 35 44 204 18 12 45 10 14 72 75 41 69 56 28 48 36 20 104 93 55 82 54 26 0 0 0 1 0 65 255 177 0 198 1 211 0 13 0 11 0 186 0 6 0 0 0 3 43 48 49 23 46 1 53 52 54 55 23 14 1 21 20 22 23 153 43 45 45 43 45 38 33 33 38 79 61 128 85 84 127 61 22 59 125 66 67 125 60 0 0 1 0 39 255 177 0 172 1 211 0 13 0 11 0 186 0 8 0 0 0 3 43 48 49 23 39 62 1 53 52 38 39 55 30 1 21 20 6 86 47 38 33 33 38 47 41 45 44 79 22 60 125 67 66 125 59 22 61 127 84 85 128 0 0 1 0 43 255 248 0 134 0 87 0 11 0 26 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 6 0 2 244 48 49 23 34 38 53 52 54 51 50 22 21 20 6 89 20 26 26 20 20 25 25 8 26 21 22 26 26 22 21 26 0 0 0 0 1 0 33 255 140 0 144 0 87 0 17 0 43 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 5 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 5 62 89 185 0 12 0 2 244 48 49 23 39 62 1 53 6 35 34 38 53 52 54 51 50 22 21 20 6 49 16 30 34 3 5 17 28 28 19 25 28 50 116 37 11 40 28 1 21 21 21 25 37 36 45 68 0 0 255 255 0 35 0 254 1 77 2 156 2 7 6 66 0 0 1 10 0 0 255 255 0 87 1 10 0 236 2 144 2 7 6 67 0 0 1 10 0 0 255 255 0 40 1 10 1 64 2 156 2 7 6 68 0 0 1 10 0 0 255 255 0 35 0 254 1 63 2 156 2 7 6 69 0 0 1 10 0 0 255 255 0 42 1 10 1 80 2 144 2 7 6 70 0 0 1 10 0 0 255 255 0 35 0 254 1 67 2 144 2 7 6 71 0 0 1 10 0 0 255 255 0 45 0 254 1 70 2 156 2 7 6 72 0 0 1 10 0 0 255 255 0 50 1 10 1 67 2 144 2 7 6 73 0 0 1 10 0 0 255 255 0 45 0 254 1 64 2 156 2 7 6 74 0 0 1 10 0 0 255 255 0 39 0 254 1 64 2 156 2 7 6 75 0 0 1 10 0 0 255 255 0 65 0 187 0 198 2 221 2 7 6 76 0 0 1 10 0 0 255 255 0 39 0 187 0 172 2 221 2 7 6 77 0 0 1 10 0 0 255 255 0 43 1 2 0 134 1 97 2 7 6 78 0 0 1 10 0 0 255 255 0 33 0 150 0 144 1 97 2 7 6 79 0 0 1 10 0 0 255 255 0 37 1 131 1 42 2 212 2 6 6 123 0 0 255 255 0 33 1 131 1 66 2 212 2 6 6 157 0 0 255 255 0 30 1 131 1 78 2 212 2 6 6 137 0 0 0 2 255 255 1 139 1 109 3 59 0 9 0 17 0 43 0 184 0 10 47 184 0 13 47 184 0 11 47 186 0 15 0 11 0 10 17 18 57 184 0 15 16 184 0 1 220 186 0 7 0 11 0 10 17 18 57 48 49 19 7 51 39 46 1 39 35 14 1 3 19 51 19 35 39 35 7 137 19 126 19 11 21 11 2 11 21 149 147 72 147 67 39 157 39 2 121 62 62 36 72 35 37 70 254 238 1 176 254 80 127 127 0 3 0 57 1 139 1 111 3 59 0 19 0 28 0 37 0 55 0 184 0 2 47 184 0 19 47 186 0 36 0 2 0 19 17 18 57 184 0 36 16 184 0 21 220 186 0 10 0 36 0 21 17 18 57 184 0 2 16 184 0 27 220 184 0 19 16 184 0 30 220 48 49 19 17 51 50 30 2 21 20 6 7 21 30 1 21 20 14 2 35 39 51 50 54 53 52 38 43 1 17 51 50 54 53 52 38 43 1 57 134 33 56 41 22 38 38 48 52 25 44 61 36 81 62 54 46 49 49 64 73 54 59 58 55 73 1 139 1 176 11 26 40 29 32 51 11 2 8 51 44 32 48 32 15 249 36 34 34 30 254 177 39 43 38 36 0 0 0 1 0 32 1 131 1 104 3 67 0 29 0 27 0 184 0 10 47 184 0 0 47 184 0 10 16 184 0 17 220 184 0 0 16 184 0 23 220 48 49 19 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 23 14 1 225 41 71 52 29 30 53 72 42 41 61 20 35 18 41 26 60 74 71 60 30 47 20 35 26 66 1 131 30 57 82 53 52 84 58 32 32 22 39 17 21 91 78 79 91 24 22 38 30 32 0 0 2 0 57 1 139 1 122 3 59 0 8 0 16 0 27 0 184 0 8 47 184 0 2 47 184 0 8 16 184 0 10 220 184 0 2 16 184 0 15 220 48 49 19 17 51 50 22 21 20 6 35 39 51 50 54 53 52 43 1 57 112 102 107 106 100 52 48 72 73 147 46 1 139 1 176 110 104 106 112 50 86 82 163 0 1 0 57 1 139 1 63 3 59 0 11 0 35 0 184 0 1 47 184 0 0 47 186 0 6 0 7 0 3 43 184 0 1 16 184 0 3 220 184 0 0 16 184 0 10 220 48 49 19 17 33 21 35 21 51 21 35 21 51 21 57 1 0 193 164 164 199 1 139 1 176 53 127 52 148 52 0 0 0 0 1 0 57 1 139 1 58 3 59 0 9 0 27 0 184 0 0 47 184 0 1 47 186 0 6 0 7 0 3 43 184 0 1 16 184 0 3 220 48 49 19 17 33 21 35 21 51 21 35 21 57 1 1 194 165 165 1 139 1 176 53 138 52 189 0 0 0 0 1 0 32 1 131 1 114 3 67 0 33 0 35 0 184 0 0 47 184 0 10 47 186 0 29 0 28 0 3 43 184 0 10 16 184 0 17 220 184 0 0 16 184 0 23 220 48 49 19 34 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 53 35 53 51 21 14 1 232 43 73 54 30 31 55 75 44 45 62 20 36 16 43 32 64 76 72 69 23 40 12 89 146 23 70 1 131 30 57 83 53 52 83 59 31 33 20 40 17 22 91 78 80 91 12 11 107 51 185 21 29 0 0 0 1 0 57 1 139 1 122 3 59 0 11 0 27 0 184 0 1 47 184 0 5 47 184 0 0 47 184 0 8 47 186 0 9 0 3 0 3 43 48 49 19 17 51 21 51 53 51 17 35 53 35 21 57 63 195 63 63 195 1 139 1 176 178 178 254 80 200 200 0 0 0 0 1 0 57 1 139 0 120 3 59 0 3 0 11 0 184 0 1 47 184 0 3 47 48 49 19 17 51 17 57 63 1 139 1 176 254 80 0 0 0 0 1 0 18 1 131 1 10 3 59 0 17 0 15 0 184 0 11 47 184 0 0 47 184 0 7 220 48 49 19 34 38 39 55 30 1 51 50 54 53 17 51 17 20 14 2 140 43 59 20 44 14 36 23 34 34 63 14 31 48 1 131 36 34 31 25 22 41 48 1 41 254 210 29 50 37 22 0 0 0 0 1 0 57 1 139 1 131 3 59 0 12 0 49 0 184 0 0 47 184 0 9 47 184 0 1 47 184 0 5 47 186 0 3 0 1 0 0 17 18 57 186 0 7 0 1 0 9 17 18 57 186 0 10 0 0 0 1 17 18 57 48 49 19 17 51 21 51 55 51 7 19 35 39 7 21 57 63 2 174 70 136 157 69 126 72 1 139 1 176 210 210 165 254 245 219 84 135 0 0 0 1 0 57 1 139 1 52 3 59 0 5 0 15 0 184 0 1 47 184 0 0 47 184 0 4 220 48 49 19 17 51 17 51 21 57 63 188 1 139 1 176 254 132 52 0 0 0 0 1 0 57 1 139 1 174 3 59 0 25 0 59 0 184 0 0 47 184 0 10 47 184 0 1 47 184 0 8 47 186 0 5 0 8 0 10 17 18 57 186 0 14 0 10 0 8 17 18 57 186 0 18 0 0 0 1 17 18 57 186 0 21 0 1 0 0 17 18 57 48 49 19 17 51 31 1 51 63 1 51 17 35 53 52 54 55 35 15 1 35 47 1 35 30 1 29 1 57 73 83 31 3 30 80 73 59 6 2 3 35 81 33 82 36 2 2 6 1 139 1 176 225 86 86 225 254 80 225 29 71 29 96 217 217 96 29 71 29 225 0 0 0 0 1 0 57 1 139 1 118 3 59 0 19 0 39 0 184 0 1 47 184 0 10 47 184 0 11 47 184 0 0 47 186 0 5 0 11 0 10 17 18 57 186 0 15 0 1 0 0 17 18 57 48 49 19 17 51 19 23 51 46 1 61 1 51 17 35 3 39 35 30 1 29 1 57 66 151 46 3 2 5 58 65 151 47 2 2 4 1 139 1 176 254 249 90 32 74 35 212 254 80 1 7 89 33 70 34 215 0 0 2 0 32 1 131 1 155 3 67 0 19 0 31 0 23 0 184 0 10 47 184 0 0 47 184 0 20 220 184 0 10 16 184 0 26 220 48 49 19 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 221 42 69 50 28 28 50 69 42 42 70 50 28 28 50 70 42 57 68 68 57 57 67 67 1 131 31 59 83 53 52 82 57 31 31 57 83 51 53 83 59 31 54 93 79 78 90 90 78 79 93 0 0 0 2 0 57 1 139 1 103 3 59 0 12 0 20 0 27 0 184 0 1 47 184 0 0 47 186 0 14 0 10 0 3 43 184 0 1 16 184 0 19 220 48 49 19 17 51 50 22 21 20 14 2 43 1 21 53 51 50 53 52 38 43 1 57 139 73 90 24 44 59 36 76 69 108 54 54 69 1 139 1 176 58 71 35 51 34 16 167 217 86 45 33 0 2 0 31 1 30 1 165 3 67 0 11 0 42 0 43 0 184 0 15 47 184 0 25 47 186 0 36 0 12 0 3 43 184 0 15 16 184 0 0 220 184 0 25 16 184 0 6 220 184 0 15 16 184 0 33 208 48 49 19 50 54 53 52 38 35 34 6 21 20 22 23 34 38 39 46 3 53 52 62 2 51 50 30 2 21 20 6 7 30 1 51 50 54 55 23 14 1 220 57 68 68 57 57 67 67 193 63 83 19 36 59 42 23 28 50 69 42 42 70 50 28 84 69 15 56 35 15 22 9 12 10 34 1 183 94 80 78 90 90 78 80 94 153 58 45 5 36 58 78 47 52 82 57 31 31 57 83 51 93 116 14 28 25 4 3 48 4 6 0 0 0 0 2 0 57 1 139 1 112 3 59 0 15 0 23 0 41 0 184 0 0 47 184 0 12 47 184 0 1 47 186 0 17 0 13 0 3 43 186 0 10 0 17 0 13 17 18 57 184 0 1 16 184 0 22 220 48 49 19 17 51 50 30 2 21 20 6 7 23 35 39 35 21 53 51 50 53 52 38 43 1 57 141 33 57 42 23 52 43 110 71 101 76 70 101 51 50 70 1 139 1 176 13 29 47 34 50 61 12 186 178 178 228 80 40 33 0 0 1 0 26 1 131 1 76 3 67 0 45 0 43 0 184 0 24 47 184 0 0 47 184 0 7 220 186 0 14 0 0 0 24 17 18 57 184 0 24 16 184 0 31 220 186 0 40 0 24 0 0 17 18 57 48 49 19 34 38 39 55 30 1 51 50 54 53 52 38 47 1 46 3 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 30 2 31 1 30 1 21 20 6 181 46 79 30 37 24 64 33 42 43 40 31 63 16 32 25 16 21 38 52 31 38 69 24 33 21 48 31 35 41 13 20 25 12 63 42 47 80 1 131 34 30 42 25 27 37 29 31 28 13 28 7 19 27 35 24 25 42 31 18 30 24 39 18 22 32 28 15 21 15 12 5 28 17 49 45 55 73 0 0 0 0 1 0 17 1 139 1 84 3 59 0 7 0 19 0 184 0 0 47 184 0 3 47 184 0 2 220 184 0 5 208 48 49 19 17 35 53 33 21 35 17 148 131 1 67 130 1 139 1 123 53 53 254 133 0 0 0 1 0 56 1 131 1 120 3 59 0 25 0 23 0 184 0 6 47 184 0 0 47 184 0 13 220 184 0 6 16 184 0 19 208 48 49 19 34 46 2 61 1 51 21 20 30 2 51 50 62 2 61 1 51 21 20 14 2 217 36 59 43 23 62 15 26 37 21 21 36 27 15 60 24 42 59 1 131 20 45 72 53 250 253 38 51 31 13 13 31 51 38 253 250 53 72 45 20 0 0 1 255 254 1 139 1 92 3 59 0 13 0 25 0 184 0 1 47 184 0 11 47 184 0 0 47 186 0 6 0 1 0 0 17 18 57 48 49 19 3 51 23 30 1 23 51 62 1 63 1 51 3 138 140 66 69 11 18 12 3 12 17 11 67 64 138 1 139 1 176 228 38 66 38 38 66 38 228 254 80 0 0 0 0 1 0 13 1 139 2 1 3 59 0 33 0 61 0 184 0 1 47 184 0 0 47 186 0 6 0 1 0 0 17 18 57 184 0 1 16 184 0 11 208 184 0 21 208 184 0 0 16 184 0 24 208 186 0 16 0 21 0 24 17 18 57 186 0 28 0 0 0 11 17 18 57 48 49 19 3 51 23 30 1 23 51 62 1 63 1 51 23 30 1 23 51 62 1 63 1 51 3 35 39 46 1 39 35 14 1 15 1 104 91 65 43 7 12 6 3 7 14 8 59 56 59 8 15 8 2 6 11 7 44 60 90 75 63 6 10 5 2 5 11 5 61 1 139 1 176 229 35 69 35 35 69 35 229 229 35 69 35 35 69 35 229 254 80 249 25 48 25 25 48 25 249 0 0 0 0 1 0 8 1 139 1 82 3 59 0 25 0 59 0 184 0 2 47 184 0 13 47 184 0 15 47 184 0 0 47 186 0 1 0 2 0 0 17 18 57 186 0 7 0 15 0 13 17 18 57 186 0 14 0 15 0 13 17 18 57 186 0 21 0 2 0 0 17 18 57 48 49 19 55 39 51 23 30 1 23 51 62 1 63 1 51 7 23 35 39 46 1 39 35 14 1 15 1 8 127 118 69 56 8 15 10 3 9 14 8 54 67 119 127 69 60 8 18 11 3 9 18 8 60 1 139 223 209 106 15 29 20 20 29 15 106 212 220 112 17 32 20 20 32 17 112 0 0 1 255 253 1 139 1 67 3 59 0 15 0 29 0 184 0 2 47 184 0 0 47 186 0 7 0 2 0 0 17 18 57 184 0 2 16 184 0 12 208 48 49 19 53 3 51 23 30 1 23 51 62 1 63 1 51 3 21 129 132 66 55 11 20 11 3 11 21 10 53 65 131 1 139 165 1 11 118 24 46 25 25 46 24 118 254 245 165 0 0 0 0 1 0 27 1 139 1 76 3 59 0 9 0 39 0 184 0 4 47 184 0 9 47 184 0 7 220 184 0 1 208 184 0 1 47 184 0 4 16 184 0 2 220 184 0 6 208 184 0 6 47 48 49 19 53 19 35 53 33 21 3 51 21 27 226 206 1 27 225 227 1 139 37 1 86 53 38 254 170 52 0 2 0 37 1 131 1 42 2 212 0 25 0 34 0 53 0 184 0 0 47 184 0 16 47 186 0 6 0 29 0 3 43 184 0 16 16 184 0 9 220 184 0 0 16 184 0 21 208 184 0 0 16 184 0 26 220 186 0 23 0 0 0 26 17 18 57 48 49 19 34 38 53 52 54 55 46 1 35 34 6 7 39 62 1 51 50 22 29 1 35 39 35 14 1 39 50 55 53 14 1 21 20 22 136 45 54 95 104 1 26 35 26 55 20 23 25 69 39 60 55 50 7 4 20 50 13 39 43 77 61 30 1 131 51 43 53 55 11 32 41 21 13 43 15 27 70 63 196 37 18 27 49 40 85 8 39 28 26 24 0 2 0 52 1 131 1 85 3 95 0 20 0 32 0 76 0 184 0 0 47 184 0 7 47 184 0 0 69 88 184 0 13 47 27 185 0 13 0 19 62 89 186 0 3 0 0 0 13 17 18 57 184 0 0 16 184 0 6 208 184 0 6 47 186 0 10 0 13 0 0 17 18 57 184 0 0 16 184 0 21 220 184 0 13 16 184 0 27 220 48 49 19 34 38 39 35 7 35 17 51 21 7 62 1 51 50 22 21 20 14 2 39 50 54 53 52 38 35 34 7 21 30 1 201 23 48 20 4 6 48 62 3 23 49 28 63 67 23 39 50 37 36 49 39 42 39 43 20 41 1 131 20 20 32 1 212 126 58 19 26 88 75 41 65 45 23 51 63 60 52 60 43 161 17 14 0 1 0 30 1 131 1 34 2 212 0 27 0 27 0 184 0 8 47 184 0 0 47 184 0 8 16 184 0 15 220 184 0 0 16 184 0 21 220 48 49 19 34 38 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 51 50 54 55 23 14 1 184 67 87 25 43 57 31 35 49 15 30 15 28 22 42 55 54 43 26 34 14 26 17 51 1 131 87 81 40 63 43 23 22 13 40 12 12 65 53 52 65 16 11 40 15 23 0 0 0 2 0 33 1 131 1 66 3 95 0 20 0 33 0 59 0 184 0 0 47 184 0 8 47 184 0 13 47 184 0 8 16 184 0 28 220 186 0 11 0 28 0 8 17 18 57 184 0 0 16 184 0 16 208 184 0 0 16 184 0 21 220 186 0 18 0 0 0 21 17 18 57 48 49 19 34 38 53 52 62 2 51 50 22 23 39 53 51 17 35 39 35 14 1 39 50 54 55 53 46 1 35 34 6 21 20 22 170 64 73 23 39 51 27 26 44 20 3 62 50 7 3 20 44 14 20 36 20 20 39 18 35 51 42 1 131 90 84 38 60 42 23 19 17 56 119 254 44 35 18 25 51 21 20 162 17 15 61 51 60 63 0 0 0 2 0 28 1 131 1 54 2 212 0 28 0 37 0 49 0 184 0 10 47 184 0 0 47 186 0 19 0 10 0 0 17 18 57 184 0 19 47 184 0 0 16 184 0 22 220 184 0 19 16 184 0 30 220 184 0 10 16 184 0 35 220 48 49 19 34 46 2 53 52 62 2 51 50 30 2 21 20 6 7 35 30 1 51 50 54 55 23 14 1 39 51 52 46 2 35 34 6 186 33 58 42 25 24 41 55 30 37 51 31 13 2 2 217 3 56 45 23 42 17 24 23 57 131 167 8 18 29 22 36 48 1 131 22 43 62 41 39 63 43 24 28 44 52 24 10 14 11 50 55 14 12 40 15 20 195 16 34 26 17 48 0 0 0 1 0 19 1 139 0 220 3 106 0 22 0 39 0 184 0 8 47 184 0 22 47 184 0 18 47 184 0 21 220 184 0 1 208 184 0 18 16 184 0 4 208 184 0 8 16 184 0 14 220 48 49 19 17 35 53 55 53 52 54 51 50 23 7 46 1 35 34 6 29 1 51 21 35 17 64 45 45 48 52 32 24 13 7 18 12 22 22 68 68 1 139 1 16 47 2 42 51 65 10 46 2 4 33 29 46 49 254 240 0 0 0 3 0 30 0 248 1 76 2 212 0 51 0 63 0 78 0 88 0 184 0 0 47 184 0 0 69 88 184 0 21 47 27 185 0 21 0 19 62 89 186 0 71 0 43 0 3 43 186 0 52 0 34 0 3 43 186 0 5 0 43 0 71 17 18 57 186 0 12 0 52 0 34 17 18 57 184 0 21 16 184 0 24 208 184 0 21 16 184 0 58 220 184 0 25 208 184 0 0 16 184 0 64 220 48 49 55 34 38 53 52 55 53 46 1 53 52 54 55 53 46 1 53 52 62 2 51 50 23 51 21 35 30 1 21 20 14 2 35 34 38 39 14 1 21 20 22 59 1 50 22 21 20 14 2 3 50 54 53 52 38 35 34 6 21 20 22 23 50 54 53 52 38 43 1 34 38 39 6 21 20 22 164 60 74 46 13 16 22 14 17 26 20 35 45 26 28 23 110 62 10 13 19 33 45 25 11 25 12 8 11 24 32 62 59 56 23 44 62 37 27 39 39 27 29 38 38 37 44 54 33 30 53 8 23 11 31 48 248 44 42 42 28 4 8 26 19 19 30 9 4 13 44 29 27 43 29 16 9 48 10 32 18 26 42 29 15 4 6 6 17 11 16 16 37 42 23 40 31 18 1 33 39 33 33 37 36 34 33 39 246 37 23 20 16 1 3 22 26 25 27 0 0 0 0 1 0 52 1 139 1 65 3 95 0 19 0 27 0 184 0 7 47 184 0 19 47 184 0 12 47 184 0 2 47 184 0 7 16 184 0 16 220 48 49 19 17 51 21 7 62 1 51 50 22 29 1 35 53 52 38 35 34 7 21 52 62 3 20 56 32 56 46 62 23 38 37 47 1 139 1 212 125 67 21 32 70 56 203 194 38 44 47 229 0 0 0 2 0 42 1 139 0 126 3 89 0 11 0 15 0 19 0 184 0 15 47 184 0 14 47 184 0 0 220 184 0 6 220 48 49 19 34 38 53 52 54 51 50 22 21 20 6 3 17 51 17 84 18 24 24 18 18 24 24 50 62 3 10 22 17 17 23 23 17 17 22 254 129 1 65 254 191 0 0 0 0 2 255 230 0 250 0 128 3 89 0 15 0 27 0 31 0 184 0 0 47 184 0 12 47 184 0 0 16 184 0 7 220 184 0 12 16 184 0 16 220 184 0 22 220 48 49 55 34 38 39 55 30 1 51 50 54 53 17 51 17 20 6 19 34 38 53 52 54 51 50 22 21 20 6 23 17 21 11 13 6 12 10 23 16 62 42 12 18 24 24 18 18 24 24 250 4 4 49 3 3 31 29 1 99 254 161 54 61 2 16 22 17 17 23 23 17 17 22 0 0 1 0 52 1 139 1 76 3 95 0 12 0 49 0 184 0 12 47 184 0 9 47 184 0 5 47 184 0 2 47 186 0 3 0 12 0 2 17 18 57 186 0 7 0 2 0 12 17 18 57 186 0 10 0 12 0 2 17 18 57 48 49 19 17 51 17 51 55 51 7 23 35 39 7 21 52 62 4 131 69 112 126 69 93 56 1 139 1 212 254 205 160 131 190 148 67 81 0 0 0 1 0 52 1 131 0 153 3 95 0 15 0 15 0 184 0 4 47 184 0 0 47 184 0 9 220 48 49 19 34 38 53 17 51 17 20 22 51 58 1 55 23 14 1 117 36 29 62 8 8 3 6 5 9 7 16 1 131 43 38 1 139 254 112 14 11 2 47 3 3 0 0 1 0 52 1 139 1 255 2 212 0 34 0 67 0 184 0 34 47 184 0 7 47 184 0 2 208 186 0 3 0 7 0 34 17 18 57 184 0 7 16 184 0 12 208 186 0 9 0 12 0 26 17 18 57 184 0 34 16 184 0 25 208 184 0 16 208 184 0 7 16 184 0 30 220 184 0 21 208 48 49 19 17 51 23 51 62 1 51 50 23 62 1 51 50 22 29 1 35 53 52 38 35 34 6 7 21 35 53 52 38 35 34 6 7 21 52 50 5 4 20 48 33 67 23 23 53 32 54 47 62 24 35 18 37 23 62 24 35 17 37 23 1 139 1 65 45 22 31 60 24 36 69 57 203 194 38 44 22 25 229 194 38 44 22 25 229 0 0 1 0 52 1 139 1 65 2 212 0 19 0 45 0 184 0 7 47 184 0 19 47 184 0 7 16 184 0 2 208 186 0 3 0 7 0 19 17 18 57 184 0 19 16 184 0 11 208 184 0 7 16 184 0 16 220 48 49 19 17 51 23 51 62 1 51 50 22 29 1 35 53 52 38 35 34 7 21 52 49 6 4 21 55 32 56 46 62 23 37 38 47 1 139 1 65 45 22 31 70 56 203 194 38 44 47 229 0 2 0 30 1 131 1 78 2 212 0 19 0 31 0 23 0 184 0 10 47 184 0 0 47 184 0 20 220 184 0 10 16 184 0 26 220 48 49 19 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 182 31 55 42 24 24 42 55 31 31 55 42 24 24 42 55 31 42 46 46 42 42 47 47 1 131 23 43 62 40 40 63 44 22 22 44 63 40 40 62 43 23 51 65 52 54 64 64 54 52 65 0 0 0 2 0 52 1 1 1 85 2 212 0 20 0 32 0 72 0 184 0 0 47 184 0 15 47 184 0 0 69 88 184 0 7 47 27 185 0 7 0 19 62 89 184 0 1 208 184 0 1 47 186 0 3 0 7 0 15 17 18 57 186 0 18 0 15 0 7 17 18 57 184 0 15 16 184 0 21 220 184 0 7 16 184 0 27 220 48 49 19 17 51 23 51 62 1 51 50 22 21 20 14 2 35 34 38 39 23 21 55 50 54 53 52 38 35 34 7 21 30 1 52 49 7 3 20 51 29 63 67 23 39 50 28 22 49 20 4 78 36 49 39 42 39 43 20 41 1 1 1 203 37 18 27 88 75 41 65 45 23 19 18 63 104 181 63 60 52 60 43 161 17 14 0 2 0 33 1 1 1 66 2 212 0 19 0 31 0 59 0 184 0 13 47 184 0 5 47 184 0 0 47 186 0 2 0 5 0 13 17 18 57 186 0 15 0 13 0 5 17 18 57 184 0 13 16 184 0 17 208 184 0 5 16 184 0 20 220 184 0 13 16 184 0 26 220 48 49 1 53 55 14 1 35 34 38 53 52 62 2 51 50 23 51 55 51 17 39 50 55 53 46 1 35 34 6 21 20 22 1 4 3 18 48 26 64 74 24 39 51 27 52 38 4 6 48 138 38 38 20 39 18 35 51 42 1 1 112 58 18 22 89 79 40 62 44 23 40 32 254 53 181 37 165 17 16 62 55 55 63 0 0 0 0 1 0 52 1 139 0 241 2 212 0 16 0 37 0 184 0 6 47 184 0 16 47 184 0 6 16 184 0 2 208 186 0 3 0 6 0 16 17 18 57 184 0 6 16 184 0 12 220 48 49 19 17 51 23 51 54 51 50 23 7 46 1 35 34 6 7 21 52 50 7 3 38 53 26 12 12 6 18 8 21 44 17 1 139 1 65 56 64 6 56 2 3 31 38 203 0 1 0 19 1 131 1 7 2 212 0 43 0 60 0 184 0 0 47 184 0 0 69 88 184 0 21 47 27 185 0 21 0 19 62 89 184 0 0 16 184 0 7 220 186 0 13 0 21 0 0 17 18 57 184 0 21 16 184 0 28 220 186 0 36 0 0 0 21 17 18 57 48 49 19 34 38 39 55 30 1 51 50 54 53 52 38 39 46 3 53 52 54 51 50 22 23 7 46 1 35 34 6 21 20 30 2 23 30 3 21 20 6 144 36 65 24 30 22 47 27 28 30 45 28 17 34 27 17 58 53 35 52 20 31 18 33 23 27 27 12 20 26 14 17 35 28 17 64 1 131 25 19 41 17 20 26 19 23 23 11 6 16 22 30 21 38 54 22 14 40 14 14 25 15 11 16 12 10 6 6 15 21 31 22 44 55 0 0 1 0 16 1 131 0 225 3 39 0 21 0 60 0 184 0 0 47 184 0 0 69 88 184 0 7 47 27 185 0 7 0 19 62 89 184 0 4 220 184 0 7 16 184 0 9 220 184 0 7 16 184 0 11 208 184 0 4 16 184 0 12 208 184 0 0 16 184 0 16 220 48 49 19 34 38 61 1 35 53 63 1 51 21 51 21 35 21 20 51 50 55 23 14 1 160 53 43 48 50 8 52 88 88 49 21 16 13 14 34 1 131 62 50 167 48 2 91 91 50 167 62 8 46 5 7 0 0 1 0 50 1 131 1 63 2 204 0 20 0 62 0 184 0 0 47 184 0 0 69 88 184 0 4 47 27 185 0 4 0 19 62 89 184 0 0 16 184 0 9 220 184 0 4 16 184 0 13 208 184 0 0 16 184 0 15 208 184 0 15 47 186 0 17 0 0 0 4 17 18 57 48 49 19 34 38 61 1 51 21 20 22 51 50 54 55 53 51 17 35 39 35 14 1 153 56 47 62 23 38 20 41 23 62 49 7 3 20 55 1 131 69 56 204 195 38 43 22 25 229 254 191 45 22 31 0 1 0 8 1 139 1 57 2 204 0 9 0 38 0 184 0 0 47 184 0 0 69 88 184 0 1 47 27 185 0 1 0 19 62 89 186 0 4 0 1 0 0 17 18 57 184 0 7 208 48 49 19 3 51 31 1 51 63 1 51 3 124 116 62 58 31 4 31 58 61 116 1 139 1 65 176 96 96 176 254 191 0 0 0 1 0 16 1 139 1 215 2 204 0 21 0 70 0 184 0 0 47 184 0 0 69 88 184 0 1 47 27 185 0 1 0 19 62 89 186 0 4 0 1 0 0 17 18 57 184 0 7 208 184 0 13 208 184 0 0 16 184 0 16 208 186 0 10 0 13 0 16 17 18 57 186 0 19 0 1 0 16 17 18 57 48 49 19 3 51 31 1 51 63 1 51 31 1 51 63 1 51 3 35 47 1 35 15 1 105 89 64 44 19 4 22 47 56 50 22 4 21 43 59 87 75 43 21 2 21 43 1 139 1 65 179 91 91 179 179 91 91 179 254 191 163 92 92 163 0 0 0 1 0 8 1 139 1 42 2 204 0 17 0 80 0 184 0 0 47 184 0 0 69 88 184 0 2 47 27 185 0 2 0 19 62 89 184 0 0 16 184 0 12 208 184 0 2 16 184 0 8 208 186 0 5 0 12 0 8 17 18 57 186 0 15 0 2 0 0 17 18 57 186 0 1 0 5 0 15 17 18 57 186 0 10 0 14 0 5 17 18 57 48 49 19 55 39 51 31 1 51 63 1 51 7 23 35 47 1 35 15 1 8 108 99 68 41 31 4 27 37 66 98 105 68 43 35 4 33 41 1 139 168 153 66 51 51 66 160 161 69 55 55 69 0 1 0 8 1 5 1 55 2 204 0 24 0 60 0 184 0 0 47 184 0 0 69 88 184 0 10 47 27 185 0 10 0 19 62 89 184 0 0 16 184 0 5 220 186 0 9 0 10 0 0 17 18 57 186 0 15 0 10 0 0 17 18 57 184 0 10 16 184 0 20 208 48 49 19 34 39 55 22 51 50 54 63 1 3 51 23 30 1 23 51 62 1 63 1 51 3 14 1 65 23 18 13 13 11 26 36 9 7 131 63 63 8 15 8 4 7 14 8 52 61 119 18 58 1 5 6 50 6 36 29 21 1 63 169 22 46 25 24 46 23 169 254 172 51 64 0 0 0 1 0 21 1 139 1 16 2 204 0 9 0 39 0 184 0 4 47 184 0 9 47 184 0 7 220 184 0 1 208 184 0 1 47 184 0 4 16 184 0 2 220 184 0 6 208 184 0 6 47 48 49 19 53 55 35 53 51 21 7 51 21 21 168 148 226 167 172 1 139 33 238 50 34 237 50 0 0 0 0 1 0 22 1 139 1 36 3 104 0 23 0 13 0 187 0 9 0 1 0 16 0 4 43 48 49 19 53 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 23 21 134 50 62 22 39 53 30 45 61 20 32 15 43 31 42 45 52 59 1 139 187 33 72 56 32 48 33 16 36 22 40 19 28 43 36 41 59 34 213 0 0 0 0 2 0 50 0 0 0 199 1 207 0 3 0 7 0 40 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 5 0 2 0 4 0 4 43 184 0 0 16 185 0 1 0 2 244 48 49 51 55 51 23 3 39 51 7 50 69 11 69 80 69 149 69 138 138 1 71 136 136 0 0 0 1 0 50 1 13 0 199 1 149 0 3 0 13 0 187 0 1 0 2 0 0 0 4 43 48 49 19 39 51 7 119 69 149 69 1 13 136 136 0 0 1 255 159 0 230 0 171 1 150 0 17 0 13 0 187 0 11 0 1 0 0 0 4 43 48 49 55 34 38 39 7 53 55 30 3 51 50 54 55 23 14 1 104 32 49 14 106 146 5 13 15 18 10 13 18 8 22 12 33 230 42 54 43 63 60 38 49 27 10 9 6 43 9 15 0 0 2 0 8 0 248 1 54 2 204 0 24 0 36 0 76 0 184 0 0 47 184 0 0 69 88 184 0 7 47 27 185 0 7 0 19 62 89 186 0 12 0 0 0 7 17 18 57 186 0 31 0 7 0 0 17 18 57 186 0 6 0 12 0 31 17 18 57 184 0 17 208 186 0 19 0 31 0 12 17 18 57 184 0 0 16 184 0 25 220 48 49 55 34 38 53 52 54 55 3 51 23 30 1 23 51 62 1 63 1 51 3 30 1 21 20 6 39 50 54 53 52 39 35 14 1 21 20 22 160 37 41 21 17 112 63 59 7 15 7 3 7 15 8 58 60 110 18 21 41 38 14 13 25 3 11 13 12 248 44 35 23 48 35 1 27 166 22 37 22 22 37 22 166 254 228 35 47 23 35 44 41 19 15 32 48 23 41 16 15 19 0 0 3 0 28 1 130 1 54 3 147 0 3 0 32 0 41 0 57 0 184 0 14 47 184 0 4 47 186 0 0 0 2 0 3 43 186 0 22 0 14 0 4 17 18 57 184 0 22 47 184 0 4 16 184 0 26 220 184 0 22 16 184 0 33 220 184 0 14 16 184 0 39 220 48 49 19 39 55 23 3 34 46 2 53 52 62 2 51 50 30 2 21 20 6 7 35 30 1 51 50 54 55 23 14 1 39 51 52 46 2 35 34 6 186 112 45 102 35 33 58 42 25 24 41 55 30 37 51 31 13 2 2 217 3 56 45 23 42 17 24 23 57 131 167 8 18 29 22 36 48 2 253 110 40 119 254 102 22 43 62 41 39 63 43 24 28 44 52 24 10 14 11 50 55 14 12 40 15 20 195 16 34 26 17 48 0 0 0 0 3 0 28 1 131 1 54 3 147 0 3 0 32 0 41 0 57 0 184 0 14 47 184 0 4 47 186 0 2 0 0 0 3 43 186 0 22 0 14 0 4 17 18 57 184 0 22 47 184 0 4 16 184 0 26 220 184 0 22 16 184 0 33 220 184 0 14 16 184 0 39 220 48 49 19 39 55 23 3 34 46 2 53 52 62 2 51 50 30 2 21 20 6 7 35 30 1 51 50 54 55 23 14 1 39 51 52 46 2 35 34 6 171 35 103 44 97 33 58 42 25 24 41 55 30 37 51 31 13 2 2 217 3 56 45 23 42 17 24 23 57 131 167 8 18 29 22 36 48 2 253 31 119 40 254 24 22 43 62 41 39 63 43 24 28 44 52 24 10 14 11 50 55 14 12 40 15 20 195 16 34 26 17 48 0 0 0 0 2 0 25 1 131 1 51 2 212 0 26 0 33 0 49 0 184 0 19 47 184 0 0 47 186 0 8 0 19 0 0 17 18 57 184 0 8 47 184 0 19 16 184 0 12 220 184 0 0 16 184 0 27 220 184 0 8 16 184 0 30 220 48 49 19 34 46 2 53 52 54 55 51 46 1 35 34 6 7 39 62 1 51 50 22 21 20 14 2 39 50 54 55 35 20 22 160 38 52 32 13 2 2 217 2 47 45 24 39 18 23 23 53 32 69 82 23 40 53 32 37 47 3 166 36 1 131 28 44 54 25 11 13 12 45 56 14 12 40 15 20 88 81 39 62 43 24 49 48 49 40 57 0 0 0 0 2 0 33 1 131 1 66 2 212 0 20 0 33 0 80 0 184 0 0 47 184 0 0 69 88 184 0 8 47 27 185 0 8 0 19 62 89 186 0 12 0 8 0 0 17 18 57 184 0 14 208 184 0 14 47 184 0 0 16 184 0 15 208 184 0 15 47 186 0 17 0 0 0 8 17 18 57 184 0 0 16 184 0 21 220 184 0 8 16 184 0 28 220 48 49 19 34 38 53 52 62 2 51 50 22 23 51 55 51 17 35 39 35 14 1 39 50 54 55 53 46 1 35 34 6 21 20 22 170 64 73 24 39 51 27 26 44 20 4 6 48 51 5 4 20 44 14 20 36 20 20 39 18 35 51 42 1 131 90 82 39 61 42 23 20 19 31 254 191 35 18 25 52 20 20 162 17 15 61 51 60 62 0 0 2 0 34 0 249 1 67 2 212 0 31 0 44 0 80 0 184 0 0 47 184 0 0 69 88 184 0 23 47 27 185 0 23 0 19 62 89 186 0 32 0 15 0 3 43 184 0 0 16 184 0 7 220 186 0 12 0 15 0 23 17 18 57 186 0 25 0 23 0 15 17 18 57 184 0 23 16 184 0 28 208 184 0 28 47 184 0 23 16 184 0 39 220 48 49 55 34 38 39 55 30 1 51 50 54 61 1 55 14 1 35 34 38 53 52 62 2 51 50 23 51 55 51 17 20 6 39 50 54 55 53 46 1 35 34 6 21 20 22 173 29 62 26 23 23 49 23 43 45 2 22 44 26 64 74 24 39 51 27 50 40 3 6 49 78 60 20 36 21 20 40 18 35 51 42 249 19 17 43 14 14 49 38 13 44 18 24 87 72 37 61 42 23 38 30 254 180 63 72 205 21 20 145 17 15 59 50 50 59 0 0 0 1 0 52 1 139 0 114 3 95 0 3 0 11 0 184 0 2 47 184 0 3 47 48 49 19 17 51 17 52 62 1 139 1 212 254 44 0 0 0 0 2 0 43 1 131 0 134 2 195 0 11 0 23 0 19 0 186 0 6 0 0 0 3 43 186 0 18 0 12 0 3 43 48 49 19 34 38 53 52 54 51 50 22 21 20 6 39 34 38 53 52 54 51 50 22 21 20 6 89 20 26 26 20 20 25 25 20 20 26 26 20 20 25 25 1 131 26 21 22 26 26 22 21 26 225 26 21 22 26 26 22 21 26 0 0 0 1 0 41 2 56 0 197 2 102 0 3 0 11 0 186 0 2 0 3 0 3 43 48 49 19 53 51 21 41 156 2 56 46 46 0 0 1 0 41 2 58 1 51 2 99 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 19 53 33 21 41 1 10 2 58 41 41 0 0 0 1 0 41 2 58 2 10 2 99 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 19 53 33 21 41 1 225 2 58 41 41 0 0 0 2 0 41 1 173 1 35 2 173 0 19 0 31 0 23 0 187 0 20 0 1 0 0 0 4 43 187 0 10 0 1 0 26 0 4 43 48 49 19 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 54 53 52 38 35 34 6 21 20 22 166 25 45 35 20 20 35 45 25 25 45 35 20 20 35 45 25 33 42 42 33 33 42 42 1 173 18 33 47 29 30 47 34 18 18 34 47 30 29 47 33 18 46 46 35 37 46 46 37 35 46 0 0 0 2 0 26 0 103 1 215 2 45 0 33 0 53 0 40 0 184 0 0 69 88 184 0 13 47 27 185 0 13 0 11 62 89 187 0 34 0 1 0 31 0 4 43 184 0 13 16 185 0 44 0 1 244 48 49 55 39 55 46 1 53 52 54 55 39 55 23 54 51 50 22 23 55 23 7 30 1 21 20 6 7 23 7 39 14 1 35 34 39 55 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 70 44 64 17 19 19 17 64 44 68 48 63 29 58 23 68 44 65 17 20 20 17 65 44 68 23 58 29 64 47 111 24 43 32 19 19 32 43 24 24 44 32 19 19 32 44 103 45 65 23 58 35 35 59 23 66 45 70 37 19 18 70 45 66 23 59 35 35 58 23 65 45 69 19 19 38 23 19 36 49 30 30 49 36 19 19 36 49 30 30 49 36 19 0 0 1 0 52 255 146 1 181 2 236 0 45 0 131 0 184 0 0 69 88 184 0 21 47 27 185 0 21 0 15 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 185 0 8 0 1 244 186 0 11 0 21 0 1 17 18 57 186 0 18 0 1 0 21 17 18 57 184 0 21 16 184 0 23 208 184 0 23 47 184 0 21 16 184 0 24 208 184 0 21 16 185 0 31 0 1 244 186 0 34 0 1 0 21 17 18 57 186 0 41 0 21 0 1 17 18 57 184 0 1 16 184 0 44 208 184 0 1 16 185 0 45 0 2 244 48 49 23 53 46 1 39 55 30 1 51 50 54 53 52 46 4 53 52 54 55 53 51 21 30 1 23 7 46 1 35 34 6 21 20 30 4 21 20 6 7 21 222 48 90 32 38 32 77 46 56 55 41 62 73 62 41 79 66 60 48 67 27 44 28 53 41 46 54 41 62 73 62 41 83 72 110 99 5 43 29 57 28 39 56 47 40 53 39 34 44 63 49 67 89 10 101 99 5 42 29 49 27 30 52 44 36 46 35 33 47 69 54 72 92 10 101 0 1 0 53 0 0 1 197 2 138 0 44 0 91 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 7 0 1 0 11 0 4 43 184 0 0 16 185 0 43 0 1 244 184 0 1 208 184 0 1 47 184 0 19 16 185 0 26 0 1 244 184 0 11 16 184 0 33 208 184 0 7 16 184 0 34 208 48 49 51 53 62 1 53 52 38 39 35 53 55 51 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 23 51 21 35 30 1 21 20 6 7 21 33 21 54 51 55 4 3 100 67 18 10 17 27 49 68 42 54 75 26 48 19 48 34 54 57 15 9 159 146 2 3 32 30 1 25 50 28 95 57 14 27 14 52 4 32 61 32 42 68 48 26 43 32 47 23 30 65 52 32 59 32 56 14 27 15 53 70 31 4 71 0 0 0 0 1 0 23 0 0 1 218 2 126 0 29 0 107 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 7 0 6 0 3 43 184 0 6 16 184 0 3 208 184 0 2 208 186 0 14 0 9 0 0 17 18 57 184 0 9 16 184 0 19 208 184 0 7 16 184 0 22 208 184 0 6 16 184 0 23 208 184 0 3 16 184 0 26 208 184 0 2 16 184 0 27 208 48 49 51 53 35 53 51 53 35 53 51 3 51 23 30 1 23 51 62 1 63 1 51 3 51 21 35 21 51 21 35 21 207 162 162 162 141 163 86 78 15 29 16 4 17 29 15 78 84 164 142 163 163 163 158 48 65 47 1 64 171 33 67 35 35 67 33 171 254 192 47 65 48 158 0 0 0 0 1 0 23 0 0 1 218 2 126 0 21 0 79 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 3 0 2 0 3 43 186 0 10 0 5 0 0 17 18 57 184 0 5 16 184 0 15 208 184 0 3 16 184 0 18 208 184 0 2 16 184 0 19 208 48 49 51 17 35 53 51 3 51 23 30 1 23 51 62 1 63 1 51 3 51 21 35 17 207 162 148 170 86 78 15 29 16 4 17 29 15 78 84 171 149 163 1 1 48 1 77 171 33 67 35 35 67 33 171 254 179 48 254 255 0 0 1 0 23 255 244 1 235 2 138 0 53 0 113 0 184 0 0 69 88 184 0 22 47 27 185 0 22 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 14 0 8 0 3 43 184 0 8 16 184 0 5 208 184 0 14 16 184 0 17 208 184 0 22 16 185 0 29 0 1 244 184 0 17 16 184 0 33 208 184 0 14 16 184 0 34 208 184 0 8 16 184 0 42 208 184 0 5 16 184 0 43 208 184 0 0 16 185 0 47 0 1 244 48 49 5 34 46 2 39 35 53 55 38 52 53 60 1 55 35 53 55 62 3 51 50 22 23 7 46 1 35 34 6 7 51 21 33 6 20 21 28 1 23 51 21 35 30 1 51 50 54 55 23 14 1 1 63 45 77 60 41 9 64 59 1 1 59 64 9 42 63 83 49 45 78 26 49 21 50 32 66 80 13 254 254 254 1 1 218 213 13 77 62 37 55 26 49 33 84 12 33 64 91 59 43 4 9 18 9 8 16 8 44 5 59 93 65 34 45 33 47 26 33 98 87 49 7 14 8 10 19 9 48 85 96 36 35 44 44 49 0 0 2 0 61 255 223 1 198 2 141 0 6 0 37 0 55 0 187 0 18 0 1 0 4 0 4 43 187 0 3 0 1 0 8 0 4 43 184 0 18 16 184 0 21 208 184 0 4 16 184 0 28 208 184 0 3 16 184 0 29 208 184 0 8 16 184 0 36 208 48 49 19 20 22 23 17 14 1 19 53 46 3 53 52 62 2 55 53 51 21 30 1 23 7 46 1 39 17 62 1 55 23 14 1 7 21 143 62 57 55 64 119 45 74 53 29 31 54 74 42 52 44 64 23 40 20 45 26 32 52 20 36 29 72 39 1 54 67 88 13 1 79 13 88 254 103 104 5 37 60 84 53 52 82 60 37 6 106 103 2 34 22 52 18 22 2 254 168 2 27 18 52 26 34 3 103 0 1 0 18 255 159 1 206 2 156 0 39 0 49 0 187 0 25 0 1 0 18 0 4 43 187 0 6 0 1 0 0 0 4 43 187 0 14 0 1 0 10 0 4 43 184 0 14 16 184 0 32 208 184 0 10 16 184 0 33 208 48 49 23 34 38 39 55 22 51 50 54 63 1 35 53 55 51 55 62 1 51 50 22 23 7 46 1 35 34 14 2 15 1 51 21 35 7 14 3 91 23 38 12 15 23 27 47 41 8 24 87 69 25 6 11 77 80 22 42 14 18 11 26 19 23 32 21 13 3 7 126 133 26 5 22 38 58 97 8 7 62 10 79 77 219 59 4 56 100 104 11 7 63 5 9 22 36 47 25 63 63 237 46 75 54 30 0 0 3 0 61 255 146 1 222 2 236 0 9 0 16 0 55 0 159 0 184 0 0 69 88 184 0 29 47 27 185 0 29 0 15 62 89 184 0 0 69 88 184 0 32 47 27 185 0 32 0 15 62 89 184 0 0 69 88 184 0 35 47 27 185 0 35 0 15 62 89 184 0 0 69 88 184 0 37 47 27 185 0 37 0 15 62 89 184 0 0 69 88 184 0 18 47 27 185 0 18 0 5 62 89 184 0 0 69 88 184 0 54 47 27 185 0 54 0 5 62 89 184 0 35 16 185 0 0 0 1 244 184 0 18 16 185 0 6 0 1 244 186 0 13 0 54 0 35 17 18 57 186 0 14 0 54 0 35 17 18 57 186 0 46 0 54 0 35 17 18 57 184 0 47 208 48 49 1 34 6 7 3 22 23 19 46 1 3 20 22 23 19 14 1 19 55 38 39 7 35 55 46 1 53 52 54 63 1 51 7 54 50 51 50 23 55 51 7 30 1 23 7 38 39 3 62 1 55 23 14 1 15 1 1 62 8 13 7 60 25 31 62 8 14 180 26 25 54 51 54 120 12 28 29 13 38 16 58 67 107 92 12 38 12 5 12 5 20 16 12 38 14 24 41 16 49 19 21 60 32 51 23 48 32 79 51 12 2 72 1 1 254 8 18 4 2 12 2 2 254 249 68 105 35 1 200 26 128 253 243 99 3 11 113 131 38 151 108 134 169 22 105 99 1 4 102 114 11 35 20 46 24 15 254 6 4 35 31 44 41 49 3 98 0 0 1 0 53 0 0 1 197 2 138 0 52 0 111 0 184 0 0 69 88 184 0 24 47 27 185 0 24 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 39 0 24 0 0 17 18 57 184 0 39 47 184 0 43 208 184 0 44 208 184 0 6 208 184 0 43 16 184 0 7 208 184 0 39 16 184 0 13 208 184 0 39 16 184 0 38 208 184 0 14 208 184 0 24 16 185 0 31 0 1 244 184 0 0 16 185 0 51 0 1 244 48 49 51 53 62 1 61 1 35 53 55 51 46 1 39 35 53 55 51 46 1 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 22 23 51 21 35 22 23 51 21 35 21 20 6 7 21 33 21 54 51 55 107 69 32 4 8 5 84 61 9 5 7 27 49 68 42 54 75 26 48 19 48 34 54 57 5 5 173 160 10 4 146 141 32 30 1 25 50 28 95 57 5 44 5 15 29 15 44 5 19 36 19 42 68 48 26 43 32 47 23 30 65 52 19 35 18 49 31 28 49 6 53 70 31 4 71 0 0 5 0 11 0 0 1 227 2 126 0 3 0 7 0 35 0 41 0 47 0 165 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 15 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 186 0 13 0 12 0 3 43 186 0 0 0 17 0 8 17 18 57 184 0 13 16 185 0 16 0 1 244 184 0 2 208 184 0 8 16 184 0 32 208 184 0 17 16 184 0 21 208 186 0 5 0 32 0 21 17 18 57 184 0 12 16 185 0 9 0 1 244 184 0 33 208 184 0 6 208 184 0 2 16 184 0 20 208 184 0 24 208 184 0 13 16 184 0 45 208 184 0 40 208 184 0 25 208 184 0 12 16 184 0 44 208 184 0 38 208 184 0 28 208 184 0 6 16 184 0 29 208 48 49 19 23 51 39 19 51 39 35 7 53 35 53 55 53 35 53 55 53 51 23 51 53 51 21 51 21 35 21 51 21 35 21 35 39 35 21 19 23 51 39 53 35 7 21 51 39 53 35 135 12 47 55 219 4 11 44 221 75 75 75 75 84 89 87 65 72 72 72 72 84 84 92 139 4 54 2 72 123 77 21 57 2 51 178 178 254 23 166 240 240 38 5 60 37 5 253 253 253 253 42 60 43 240 240 240 1 41 14 34 26 22 38 59 1 0 0 0 0 3 0 10 0 0 1 228 2 126 0 21 0 27 0 33 0 105 0 184 0 0 69 88 184 0 5 47 27 185 0 5 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 20 0 1 0 28 0 4 43 184 0 5 16 185 0 22 0 1 244 186 0 33 0 28 0 22 17 18 57 184 0 33 47 184 0 1 208 184 0 33 16 185 0 23 0 1 244 184 0 4 208 184 0 23 16 184 0 11 208 184 0 33 16 184 0 14 208 48 49 51 17 35 53 55 53 51 50 30 2 23 51 21 35 14 3 43 1 21 17 21 51 46 1 35 3 51 50 54 55 35 83 73 73 121 44 75 58 36 5 62 62 5 36 58 76 43 42 181 8 75 66 32 32 66 76 7 181 1 161 51 5 165 18 39 63 45 56 44 65 43 21 244 2 69 108 59 49 254 232 59 57 0 0 0 0 4 255 241 0 0 1 253 2 126 0 5 0 11 0 35 0 41 0 153 0 184 0 0 69 88 184 0 17 47 27 185 0 17 0 15 62 89 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 186 0 16 0 13 0 3 43 184 0 16 16 184 0 20 208 184 0 2 208 186 0 5 0 12 0 17 17 18 57 184 0 12 16 184 0 32 208 186 0 6 0 32 0 17 17 18 57 184 0 13 16 184 0 39 208 184 0 33 208 184 0 9 208 186 0 22 0 17 0 32 17 18 57 184 0 2 16 184 0 24 208 184 0 17 16 184 0 25 208 184 0 24 16 184 0 28 208 184 0 9 16 184 0 29 208 186 0 36 0 17 0 12 17 18 57 48 49 19 7 51 47 1 35 19 51 63 1 35 23 7 3 35 53 55 3 51 19 51 55 51 23 51 19 51 3 51 21 35 3 35 3 35 3 39 51 63 1 35 23 230 3 43 4 15 4 111 4 11 10 55 15 247 40 71 65 39 77 29 63 35 72 35 65 29 71 37 59 65 38 89 41 55 40 39 4 13 15 53 10 1 116 26 27 162 254 39 136 105 105 198 1 47 38 4 1 37 254 220 252 252 1 36 254 220 43 254 209 1 47 254 209 62 136 105 105 0 0 3 0 68 0 0 1 228 2 153 0 28 0 43 0 47 0 80 0 184 0 0 69 88 184 0 44 47 27 185 0 44 0 5 62 89 186 0 13 0 16 0 3 43 184 0 44 16 184 0 46 220 184 0 0 208 184 0 13 16 184 0 8 208 184 0 16 16 184 0 19 208 184 0 13 16 184 0 22 208 184 0 0 16 184 0 29 220 184 0 8 16 184 0 36 220 48 49 55 34 38 53 52 62 2 51 50 22 23 39 53 35 53 51 53 51 21 51 21 7 17 35 39 35 14 1 39 50 54 55 53 46 1 35 34 14 2 21 20 22 7 53 33 21 225 72 85 27 46 58 32 37 47 25 4 146 146 70 78 78 58 6 3 22 57 21 26 47 24 25 40 28 21 37 28 16 51 113 1 103 110 97 92 41 66 47 25 24 22 83 34 49 67 67 44 5 254 83 43 23 30 59 25 28 155 22 19 18 32 43 25 62 69 169 49 49 0 4 0 10 0 0 1 228 2 126 0 30 0 36 0 45 0 50 0 123 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 9 16 185 0 31 0 1 244 184 0 8 208 184 0 5 208 184 0 4 208 184 0 1 208 184 0 8 16 184 0 32 208 184 0 14 208 184 0 5 16 184 0 41 208 184 0 15 208 184 0 4 16 184 0 42 208 184 0 23 208 184 0 1 16 184 0 50 208 184 0 24 208 184 0 1 16 184 0 46 220 184 0 29 220 48 49 51 17 35 53 55 53 35 53 55 53 51 50 22 23 51 21 35 30 1 21 28 1 7 51 21 35 14 1 43 1 21 17 21 51 46 1 35 23 52 38 39 35 21 51 62 1 7 51 50 55 35 83 73 73 73 73 121 76 112 21 71 63 1 1 1 62 70 20 113 77 42 169 17 69 51 151 1 1 181 181 1 1 183 32 107 32 171 1 121 36 5 59 37 4 120 55 65 41 8 16 9 7 13 6 41 68 65 244 2 69 63 34 29 137 9 16 8 59 6 13 136 76 0 0 0 0 1 0 47 255 146 1 204 2 236 0 41 0 109 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 15 62 89 184 0 0 69 88 184 0 1 47 27 185 0 1 0 5 62 89 184 0 11 16 184 0 13 220 184 0 11 16 184 0 14 208 184 0 11 16 185 0 21 0 1 244 184 0 1 16 185 0 29 0 1 244 186 0 34 0 11 0 1 17 18 57 184 0 34 47 185 0 36 0 1 244 184 0 1 16 184 0 40 208 184 0 1 16 184 0 41 220 48 49 5 53 46 3 53 52 62 2 55 53 51 21 30 1 23 7 46 1 35 34 14 2 21 20 22 51 50 54 55 53 35 53 51 17 14 1 7 21 1 3 47 78 56 31 30 55 78 49 60 42 70 26 49 23 51 34 41 63 43 22 85 77 29 49 14 101 176 29 71 41 110 100 6 50 84 116 72 70 114 84 53 8 101 99 4 44 31 46 27 33 37 68 98 60 123 142 22 15 169 69 254 242 30 36 5 100 0 0 0 0 1 0 23 255 244 1 217 2 138 0 59 0 113 0 184 0 0 69 88 184 0 30 47 27 185 0 30 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 10 0 13 0 3 43 184 0 10 16 184 0 6 208 184 0 13 16 184 0 17 208 184 0 30 16 185 0 23 0 1 244 184 0 17 16 184 0 39 208 184 0 13 16 184 0 40 208 184 0 10 16 184 0 45 208 184 0 6 16 184 0 46 208 184 0 0 16 185 0 53 0 1 244 48 49 5 34 38 53 52 54 55 35 53 55 51 62 1 55 35 53 55 51 62 1 53 52 38 35 34 6 7 39 62 1 51 50 30 2 21 20 6 7 51 21 35 14 1 7 51 21 33 14 1 21 20 22 51 50 54 55 23 14 1 1 15 85 103 10 8 78 68 42 16 38 20 184 69 179 24 32 47 42 37 51 26 43 29 74 56 37 62 45 24 17 14 96 140 20 44 21 225 254 236 15 19 55 53 42 69 29 37 33 94 12 85 76 25 42 19 43 5 20 32 15 44 5 21 48 32 36 48 31 26 46 32 45 22 40 56 35 29 49 20 49 18 32 17 48 19 44 28 39 51 39 27 54 33 45 0 0 0 0 2 0 61 255 146 1 222 2 233 0 6 0 37 0 85 0 184 0 0 69 88 184 0 18 47 27 185 0 18 0 15 62 89 184 0 0 69 88 184 0 8 47 27 185 0 8 0 5 62 89 185 0 3 0 1 244 184 0 18 16 185 0 4 0 1 244 184 0 18 16 184 0 21 208 184 0 4 16 184 0 28 208 184 0 3 16 184 0 29 208 184 0 8 16 184 0 36 208 48 49 19 20 22 23 17 14 1 19 53 46 3 53 52 62 2 55 53 51 21 30 1 23 7 46 1 39 17 62 1 55 23 14 1 7 21 146 69 64 65 68 133 49 80 57 32 31 57 80 50 52 42 71 25 49 18 43 28 29 48 22 48 29 72 46 1 65 112 139 13 2 10 16 136 253 231 99 5 49 84 118 73 70 115 84 52 8 98 95 3 44 31 47 24 31 3 253 241 5 35 29 44 38 47 6 100 0 0 0 1 0 72 0 0 1 195 2 126 0 29 0 103 0 184 0 0 69 88 184 0 14 47 27 185 0 14 0 15 62 89 184 0 0 69 88 184 0 28 47 27 185 0 28 0 5 62 89 184 0 14 16 185 0 12 0 1 244 184 0 9 220 184 0 5 220 184 0 2 220 184 0 12 16 184 0 17 208 184 0 9 16 184 0 20 208 184 0 5 16 184 0 23 208 184 0 2 16 185 0 29 0 1 244 186 0 26 0 2 0 29 17 18 57 48 49 55 53 51 50 54 55 35 53 55 51 46 1 43 1 53 33 21 35 30 1 23 51 21 35 14 1 7 19 35 39 72 71 72 83 5 231 69 160 11 81 66 71 1 123 142 29 38 7 68 66 5 82 65 188 94 178 252 67 58 60 44 5 46 38 68 49 15 53 35 49 75 87 15 254 252 252 0 0 0 0 1 0 23 255 242 1 209 2 126 0 34 0 99 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 5 0 4 0 3 43 184 0 4 16 184 0 1 208 184 0 5 16 184 0 8 220 184 0 11 208 184 0 5 16 184 0 14 208 184 0 4 16 184 0 15 208 184 0 1 16 184 0 18 208 184 0 0 16 185 0 19 0 2 244 48 49 23 17 7 53 55 53 7 53 55 53 51 21 55 21 7 21 55 21 7 21 62 3 53 52 38 39 55 22 21 20 14 2 115 92 92 92 92 84 164 164 164 164 33 69 56 36 1 4 70 7 53 94 128 12 1 17 48 53 48 72 48 52 49 199 158 86 53 86 72 86 52 87 236 1 22 41 61 39 8 21 14 18 32 25 63 94 62 29 0 0 0 0 1 0 33 0 0 1 205 2 126 0 23 0 107 0 184 0 0 69 88 184 0 11 47 27 185 0 11 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 5 0 4 0 3 43 184 0 4 16 184 0 1 220 184 0 5 16 184 0 8 220 184 0 11 16 185 0 10 0 1 244 184 0 13 208 184 0 8 16 184 0 15 208 184 0 5 16 184 0 18 208 184 0 4 16 184 0 19 208 184 0 1 16 184 0 22 208 48 49 51 53 7 53 55 53 7 53 55 53 35 53 33 21 35 21 55 21 7 21 55 21 7 21 207 130 130 130 130 174 1 172 172 129 129 129 129 193 68 53 68 72 68 53 68 203 64 64 164 69 53 69 72 69 53 68 233 0 0 0 2 0 33 0 0 1 205 2 126 0 8 0 12 0 57 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 10 16 184 0 12 208 184 0 4 208 184 0 6 208 184 0 2 208 48 49 51 17 35 53 55 33 21 35 17 1 53 33 21 207 174 70 1 102 172 255 0 1 172 1 218 44 4 48 254 38 2 77 49 49 0 0 2 0 10 0 0 1 167 2 126 0 26 0 35 0 103 0 184 0 0 69 88 184 0 9 47 27 185 0 9 0 15 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 21 0 9 0 0 17 18 57 124 184 0 21 47 24 184 0 22 208 184 0 25 208 184 0 1 208 184 0 22 16 184 0 4 208 184 0 21 16 184 0 5 208 184 0 21 16 184 0 27 208 184 0 8 208 184 0 9 16 185 0 34 0 1 244 48 49 51 53 35 53 55 53 35 53 55 17 51 50 30 2 21 20 14 2 43 1 21 51 21 35 21 17 51 50 54 53 52 38 43 1 83 73 73 73 73 120 47 81 59 33 34 59 81 46 41 202 202 32 72 79 79 72 32 166 43 5 61 44 4 1 59 20 43 68 47 48 70 45 22 61 48 166 1 67 67 66 69 56 0 0 0 0 1 255 89 255 244 0 251 2 156 0 3 0 24 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 1 220 48 49 7 1 51 1 167 1 106 56 254 150 12 2 168 253 88 0 0 0 255 255 255 89 255 244 0 251 2 156 2 6 6 188 0 0 255 255 255 89 255 244 0 251 2 156 2 6 6 188 0 0 255 255 0 35 255 244 3 22 2 156 0 39 6 66 0 0 1 10 0 39 6 188 1 113 0 0 0 7 6 66 1 201 0 0 0 0 0 7 0 35 255 244 4 136 2 156 0 3 0 15 0 27 0 39 0 51 0 63 0 75 0 152 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 28 47 27 185 0 28 0 5 62 89 184 0 0 69 88 184 0 52 47 27 185 0 52 0 5 62 89 187 0 16 0 1 0 4 0 4 43 187 0 34 0 1 0 46 0 4 43 184 0 10 16 185 0 22 0 1 244 184 0 28 16 185 0 40 0 1 244 184 0 34 16 184 0 58 208 184 0 40 16 184 0 64 208 184 0 46 16 184 0 70 208 48 49 23 1 51 1 3 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 1 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 5 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 200 1 106 56 254 150 72 68 81 81 68 67 82 82 67 38 48 48 38 39 48 48 1 238 68 81 81 68 67 82 82 67 38 48 48 38 39 48 48 1 155 68 81 81 68 67 82 82 67 38 48 48 38 39 48 48 12 2 168 253 88 1 10 108 100 99 107 107 99 100 108 51 79 78 78 77 77 78 78 79 254 195 108 100 99 107 107 99 100 108 51 79 78 78 77 77 78 78 79 51 108 100 99 107 107 99 100 108 51 79 78 78 77 77 78 78 79 0 255 255 0 64 255 244 2 237 2 156 0 39 6 67 255 233 1 10 0 39 6 188 1 91 0 0 0 7 6 70 1 157 0 0 0 0 255 255 0 64 255 244 2 249 2 156 0 39 6 67 255 233 1 10 0 39 6 188 1 70 0 0 0 7 6 68 1 185 0 0 0 0 255 255 0 35 255 244 2 252 2 156 0 39 6 69 0 0 1 10 0 39 6 188 1 128 0 0 0 7 6 70 1 172 0 0 0 0 255 255 0 64 255 244 2 244 2 156 0 39 6 67 255 233 1 10 0 39 6 188 1 64 0 0 0 7 6 69 1 181 0 0 0 0 255 255 0 41 255 244 3 4 2 156 0 39 6 68 0 1 1 10 0 39 6 188 1 114 0 0 0 7 6 69 1 197 0 0 0 0 255 255 0 64 255 244 2 248 2 156 0 39 6 67 255 233 1 10 0 39 6 188 1 64 0 0 0 7 6 71 1 181 0 0 0 0 255 255 0 41 255 244 3 8 2 156 0 39 6 68 0 1 1 10 0 39 6 188 1 114 0 0 0 7 6 71 1 197 0 0 0 0 255 255 0 35 255 244 3 8 2 156 0 39 6 69 0 0 1 10 0 39 6 188 1 111 0 0 0 7 6 71 1 197 0 0 0 0 255 255 0 42 255 244 3 33 2 156 0 39 6 70 0 0 1 10 0 39 6 188 1 135 0 0 0 7 6 71 1 222 0 0 0 0 255 255 0 64 255 244 2 241 2 156 0 39 6 67 255 233 1 10 0 39 6 188 1 74 0 0 0 7 6 72 1 171 0 0 0 0 255 255 0 35 255 244 3 1 2 156 0 39 6 71 0 0 1 10 0 39 6 188 1 111 0 0 0 7 6 72 1 187 0 0 0 0 255 255 0 64 255 244 2 248 2 156 0 39 6 67 255 233 1 10 0 39 6 188 1 64 0 0 0 7 6 73 1 181 0 0 0 0 255 255 0 64 255 244 2 245 2 156 0 39 6 67 255 233 1 10 0 39 6 188 1 74 0 0 0 7 6 74 1 181 0 0 0 0 255 255 0 35 255 244 3 5 2 156 0 39 6 69 0 0 1 10 0 39 6 188 1 111 0 0 0 7 6 74 1 197 0 0 0 0 255 255 0 35 255 244 3 5 2 156 0 39 6 71 0 0 1 10 0 39 6 188 1 111 0 0 0 7 6 74 1 197 0 0 0 0 255 255 0 31 255 244 2 241 2 156 0 39 6 73 255 237 1 10 0 39 6 188 1 61 0 0 0 7 6 74 1 177 0 0 0 0 255 255 0 64 255 244 2 251 2 156 0 39 6 67 255 233 1 10 0 39 6 188 1 74 0 0 0 7 6 75 1 187 0 0 0 0 0 5 0 63 255 244 4 33 2 156 0 3 0 12 0 21 0 33 0 45 0 106 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 184 0 0 69 88 184 0 22 47 27 185 0 22 0 5 62 89 187 0 28 0 1 0 40 0 4 43 187 0 19 0 2 0 14 0 4 43 184 0 10 16 185 0 5 0 2 244 184 0 40 16 184 0 16 208 184 0 16 47 184 0 22 16 185 0 34 0 1 244 48 49 23 1 51 1 3 17 35 53 62 1 55 51 17 1 17 35 53 62 1 55 51 17 23 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 164 1 106 56 254 150 72 85 33 44 20 52 1 126 85 33 44 20 52 250 68 81 81 68 67 82 82 67 38 48 48 38 39 48 48 12 2 168 253 88 1 22 1 52 42 6 19 15 254 122 254 246 1 52 42 6 19 15 254 122 12 108 100 99 107 107 99 100 108 51 79 78 78 77 77 78 78 79 255 255 0 35 255 244 3 4 2 156 0 39 6 66 0 0 1 10 0 39 6 188 1 111 0 0 0 7 6 69 1 197 0 0 0 0 0 1 0 34 0 104 1 207 2 44 0 11 0 29 0 187 0 4 0 1 0 1 0 4 43 184 0 4 16 184 0 7 208 184 0 1 16 184 0 9 208 48 49 55 53 35 53 51 53 51 21 51 21 35 21 216 182 182 65 182 182 104 195 62 195 195 62 195 0 1 0 34 1 43 1 207 1 105 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 19 53 33 21 34 1 173 1 43 62 62 0 0 0 1 0 50 0 126 1 191 2 21 0 11 0 11 0 186 0 4 0 0 0 3 43 48 49 55 39 55 39 55 23 55 23 7 23 7 39 94 44 155 155 44 155 154 44 155 155 44 154 126 45 159 158 45 159 159 45 158 159 45 160 0 0 0 0 3 0 34 0 96 1 207 2 51 0 3 0 15 0 27 0 33 0 187 0 10 0 2 0 4 0 4 43 187 0 22 0 2 0 16 0 4 43 187 0 1 0 1 0 0 0 4 43 48 49 19 53 33 21 7 34 38 53 52 54 51 50 22 21 20 6 3 34 38 53 52 54 51 50 22 21 20 6 34 1 173 214 23 32 32 23 23 31 31 23 23 32 32 23 23 31 31 1 43 62 62 203 30 24 23 30 30 23 24 30 1 104 30 24 23 30 30 23 24 30 0 0 0 255 255 0 188 1 7 1 51 1 133 0 7 4 117 0 123 1 19 0 0 255 255 0 34 0 193 1 207 1 212 2 38 6 213 0 107 0 6 6 213 0 150 0 0 0 1 0 34 0 131 1 207 2 21 0 9 0 21 0 186 0 3 0 0 0 3 43 186 0 7 0 0 0 3 17 18 57 48 49 45 1 53 37 21 15 1 21 31 1 1 207 254 83 1 173 211 134 134 211 131 168 66 168 71 78 50 4 50 78 0 0 0 0 1 0 34 0 131 1 207 2 21 0 9 0 21 0 186 0 7 0 0 0 3 43 186 0 4 0 0 0 7 17 18 57 48 49 55 53 63 1 53 47 1 53 5 21 34 211 134 134 211 1 173 131 71 78 50 4 50 78 71 168 66 0 0 0 2 0 34 0 0 1 207 2 21 0 9 0 13 0 26 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 185 0 11 0 1 244 48 49 45 1 53 37 21 15 1 21 31 1 5 53 33 21 1 207 254 83 1 173 210 135 135 210 254 83 1 173 153 153 74 153 71 73 44 4 44 73 224 62 62 0 0 2 0 34 0 0 1 207 2 21 0 9 0 13 0 26 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 5 62 89 185 0 11 0 1 244 48 49 55 53 63 1 53 47 1 53 5 21 1 53 33 21 34 210 135 135 210 1 173 254 83 1 173 153 71 73 44 4 44 73 71 153 74 254 206 62 62 0 0 0 0 2 0 34 0 0 1 207 2 44 0 11 0 15 0 56 0 184 0 0 69 88 184 0 12 47 27 185 0 12 0 5 62 89 187 0 4 0 1 0 1 0 4 43 184 0 4 16 184 0 7 208 184 0 1 16 184 0 9 208 184 0 12 16 185 0 13 0 1 244 48 49 55 53 35 53 51 53 51 21 51 21 35 21 7 53 33 21 216 182 182 65 182 182 247 1 173 127 177 62 190 190 62 177 127 62 62 0 0 1 0 60 1 28 1 181 2 158 0 9 0 26 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 17 62 89 185 0 6 0 2 244 48 49 27 1 51 19 35 47 1 35 15 1 60 152 73 152 72 65 49 4 50 65 1 28 1 130 254 126 176 133 133 176 0 0 0 1 0 34 0 65 1 207 2 83 0 19 0 55 0 187 0 4 0 1 0 18 0 4 43 187 0 8 0 1 0 14 0 4 43 184 0 18 16 184 0 1 208 184 0 14 16 184 0 5 208 184 0 8 16 184 0 11 208 184 0 4 16 184 0 15 208 48 49 63 1 35 53 51 55 35 53 33 55 51 7 51 21 35 7 51 21 33 7 61 76 103 139 91 230 1 10 76 60 76 103 139 91 230 254 246 76 65 127 62 152 62 127 127 62 152 62 127 0 0 0 1 0 36 1 1 1 205 1 147 0 23 0 43 0 186 0 12 0 5 0 3 43 184 0 5 16 184 0 17 208 184 0 17 47 184 0 0 220 184 0 5 16 184 0 8 220 184 0 17 16 184 0 20 220 48 49 1 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 54 55 23 14 1 1 80 30 47 41 38 21 22 38 17 46 27 66 32 30 47 41 38 21 22 38 17 46 27 66 1 1 26 32 26 29 32 33 48 42 26 32 26 29 32 34 48 41 0 0 255 255 0 36 0 151 1 205 1 254 2 38 6 225 0 107 0 6 6 225 0 150 0 0 0 1 0 34 0 104 1 207 1 105 0 5 0 13 0 187 0 4 0 1 0 1 0 4 43 48 49 37 53 33 53 33 17 1 141 254 149 1 173 104 195 62 254 255 0 3 0 40 0 147 2 230 1 255 0 39 0 51 0 65 0 83 0 187 0 52 0 2 0 0 0 4 43 187 0 30 0 1 0 60 0 4 43 187 0 19 0 2 0 46 0 4 43 187 0 40 0 1 0 9 0 4 43 186 0 4 0 30 0 9 17 18 57 186 0 24 0 19 0 0 17 18 57 186 0 43 0 24 0 3 17 18 57 186 0 63 0 3 0 24 17 18 57 48 49 37 34 38 39 35 14 3 35 34 46 2 53 52 62 2 51 50 30 2 23 51 62 3 51 50 30 2 21 20 14 2 37 50 54 55 46 1 35 34 6 21 20 22 5 50 62 2 53 52 38 35 34 6 7 30 1 2 58 64 93 45 4 13 34 43 52 31 31 55 41 24 25 43 60 35 30 51 42 33 14 4 18 41 48 55 32 37 63 45 26 26 46 63 254 104 42 66 26 32 66 38 41 52 55 1 156 25 40 27 14 60 54 43 76 37 42 75 147 65 57 15 36 31 21 25 43 57 33 40 63 44 24 19 31 37 18 24 43 34 20 26 47 64 38 43 70 49 27 82 54 38 43 52 47 42 42 56 4 17 30 39 22 51 63 55 52 56 59 0 0 0 255 255 0 82 255 77 2 23 1 230 2 6 2 107 0 0 0 2 0 40 255 244 1 231 2 156 0 34 0 48 0 77 0 184 0 0 69 88 184 0 27 47 27 185 0 27 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 10 0 1 0 41 0 4 43 186 0 13 0 0 0 27 17 18 57 184 0 27 16 185 0 21 0 1 244 184 0 0 16 185 0 35 0 1 244 48 49 23 34 46 2 53 52 62 2 51 50 22 23 54 52 53 52 46 2 35 34 7 39 62 1 51 50 22 21 20 14 2 39 50 54 55 46 1 35 34 6 21 20 30 2 222 36 66 50 30 30 56 80 51 41 79 29 1 20 36 52 32 64 48 38 32 79 47 97 115 38 70 98 51 65 89 15 33 69 33 74 72 18 31 40 12 27 49 71 45 49 83 59 33 38 33 8 17 9 63 88 56 26 50 51 32 35 146 153 86 140 100 55 68 108 99 42 34 88 66 30 47 34 18 0 1 0 52 255 98 1 51 3 21 0 37 0 23 0 187 0 5 0 1 0 0 0 4 43 187 0 18 0 1 0 25 0 4 43 48 49 23 34 39 55 22 51 50 54 53 52 46 2 53 52 62 2 51 50 22 23 7 46 1 35 34 6 21 20 30 2 21 20 14 2 100 32 16 10 11 23 43 24 13 16 13 11 31 54 43 15 26 6 10 7 17 11 41 24 13 15 13 11 30 54 158 7 62 4 82 78 55 126 130 127 56 48 84 61 35 4 2 62 2 2 85 77 54 126 130 127 55 49 84 61 35 0 1 0 41 255 161 2 49 3 52 0 15 0 13 0 187 0 8 0 2 0 0 0 4 43 48 49 5 3 7 39 55 19 30 1 23 51 62 1 55 19 51 3 1 25 150 71 19 133 116 5 8 4 4 3 6 3 178 60 217 95 1 172 32 45 59 254 166 16 32 16 16 32 16 2 249 252 109 0 0 255 255 0 30 0 0 2 46 2 144 2 6 2 66 0 0 255 255 0 45 0 0 2 121 2 156 2 6 2 86 0 0 0 1 0 22 255 136 1 245 2 126 0 13 0 40 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 15 62 89 187 0 11 0 1 0 0 0 4 43 184 0 4 16 185 0 6 0 1 244 48 49 23 53 19 3 53 33 21 33 21 19 3 21 33 21 22 238 227 1 184 254 175 212 222 1 119 120 53 1 70 1 70 53 71 4 254 209 254 207 4 71 0 0 0 1 0 89 255 136 2 73 2 126 0 7 0 26 0 184 0 0 69 88 184 0 1 47 27 185 0 1 0 15 62 89 185 0 5 0 2 244 48 49 23 17 33 17 35 17 33 17 89 1 240 85 254 184 120 2 246 253 10 2 173 253 83 0 0 2 0 21 255 244 1 146 2 212 0 32 0 42 0 73 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 19 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 3 0 0 0 16 17 18 57 185 0 26 0 1 244 186 0 34 0 0 0 16 17 18 57 184 0 16 16 185 0 40 0 1 244 48 49 5 34 38 39 14 1 7 39 62 1 55 17 52 62 2 51 50 22 21 20 6 7 21 20 22 51 50 54 55 23 14 1 3 21 62 1 53 52 38 35 34 6 1 10 63 91 5 13 26 14 33 23 43 20 22 39 54 31 57 74 104 92 52 37 31 43 18 33 26 66 122 59 66 33 25 27 40 12 86 85 9 18 9 52 15 30 16 1 15 58 82 53 24 78 75 96 175 79 35 70 58 27 17 51 23 40 2 22 213 60 130 70 51 41 66 0 2 0 46 255 244 2 242 2 148 0 32 0 50 0 71 0 184 0 0 69 88 184 0 10 47 27 185 0 10 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 186 0 34 0 16 0 3 43 184 0 0 16 184 0 26 220 186 0 30 0 0 0 10 17 18 57 184 0 10 16 184 0 42 220 48 49 5 34 46 2 53 52 62 2 51 50 30 2 29 1 33 34 29 1 20 22 23 30 1 51 50 54 55 51 14 1 1 33 50 61 1 52 39 46 1 35 34 6 7 14 1 29 1 20 1 144 74 129 96 55 55 96 129 74 73 129 96 56 253 194 4 5 3 41 112 65 68 118 42 52 50 146 254 206 1 184 6 10 42 110 62 65 111 42 3 5 12 53 91 122 70 70 122 91 53 53 91 122 70 8 4 184 6 9 5 47 53 61 51 60 72 1 90 6 184 12 10 44 50 53 45 5 11 6 180 6 0 0 0 0 1 0 26 255 241 2 67 2 7 0 9 0 13 0 187 0 6 0 1 0 7 0 4 43 48 49 5 1 53 1 23 7 33 21 33 23 1 43 254 239 1 17 42 201 1 183 254 73 201 15 1 9 4 1 9 46 187 68 187 0 1 0 42 255 231 2 65 2 15 0 9 0 34 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 11 62 89 184 0 0 220 186 0 8 0 4 0 0 17 18 57 48 49 5 17 7 39 1 51 1 7 39 17 1 19 187 46 1 9 4 1 10 47 187 25 1 183 201 42 1 16 254 240 42 201 254 73 0 0 0 1 0 39 255 241 2 79 2 7 0 9 0 13 0 187 0 5 0 1 0 2 0 4 43 48 49 5 39 55 33 53 33 39 55 1 21 1 63 43 201 254 74 1 182 201 43 1 16 15 46 187 68 187 46 254 247 4 0 0 0 1 0 42 255 231 2 65 2 15 0 9 0 34 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 11 62 89 184 0 0 220 186 0 6 0 4 0 0 17 18 57 48 49 5 1 55 23 17 51 17 55 23 1 1 51 254 247 46 187 68 187 47 254 246 25 1 17 42 201 1 182 254 74 201 42 254 239 0 0 0 1 0 45 255 196 3 82 2 233 0 3 0 11 0 186 0 1 0 0 0 3 43 48 49 23 17 33 17 45 3 37 60 3 37 252 219 0 0 0 0 1 0 25 255 176 3 102 2 253 0 3 0 11 0 186 0 2 0 0 0 3 43 48 49 5 9 2 1 192 254 89 1 167 1 166 80 1 167 1 166 254 90 0 0 3 0 33 255 181 3 94 2 248 0 19 0 39 0 59 0 23 0 187 0 20 0 1 0 0 0 4 43 187 0 10 0 1 0 30 0 4 43 48 49 5 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 39 50 62 2 53 52 46 2 35 34 14 2 21 20 30 2 55 34 46 2 53 52 62 2 51 50 30 2 21 20 14 2 1 192 84 151 114 66 66 114 151 84 84 150 114 66 66 114 150 84 69 128 97 58 58 97 128 69 69 127 98 58 58 98 127 69 52 93 71 42 42 71 93 52 51 94 70 42 42 70 94 75 57 108 155 98 96 154 108 59 59 108 154 96 98 155 108 57 56 48 93 135 86 86 134 93 49 49 93 134 86 86 135 93 48 97 38 69 98 60 59 98 69 38 38 69 98 59 61 98 69 37 0 0 0 0 2 0 45 255 196 3 82 2 233 0 5 0 9 0 23 0 187 0 6 0 1 0 0 0 4 43 187 0 3 0 2 0 8 0 4 43 48 49 23 17 55 33 17 7 37 33 17 33 45 66 2 227 56 253 64 2 170 253 86 60 2 237 56 253 29 66 44 2 171 0 0 0 1 0 51 255 196 3 76 2 253 0 5 0 11 0 186 0 2 0 0 0 3 43 48 49 23 53 1 51 1 21 51 1 139 4 1 138 60 2 3 55 252 201 2 0 2 0 51 255 196 3 76 2 253 0 5 0 8 0 13 0 187 0 6 0 1 0 0 0 4 43 48 49 23 53 1 51 1 21 37 33 1 51 1 139 4 1 138 253 72 2 87 254 213 60 2 3 55 252 201 2 58 2 127 0 1 0 45 255 202 3 102 2 227 0 5 0 21 0 186 0 1 0 0 0 3 43 186 0 4 0 0 0 1 17 18 57 48 49 23 17 51 1 21 1 45 2 3 55 252 201 54 3 25 254 118 4 254 117 0 0 2 0 45 255 202 3 102 2 227 0 5 0 8 0 51 0 186 0 1 0 0 0 3 43 186 0 4 0 0 0 1 17 18 57 186 0 6 0 0 0 1 17 18 57 186 0 7 0 0 0 1 17 18 57 186 0 8 0 0 0 1 17 18 57 48 49 23 17 51 1 21 1 55 9 1 45 2 3 55 252 201 57 2 128 253 128 54 3 25 254 118 4 254 117 97 1 44 1 43 0 1 0 51 255 176 3 76 2 233 0 5 0 11 0 186 0 0 0 2 0 3 43 48 49 1 21 1 35 1 53 3 76 254 118 4 254 117 2 233 2 252 201 3 55 2 0 0 0 2 0 51 255 176 3 76 2 233 0 5 0 8 0 13 0 187 0 0 0 1 0 6 0 4 43 48 49 1 21 1 35 1 53 5 33 1 3 76 254 118 4 254 117 2 184 253 169 1 44 2 233 2 252 201 3 55 2 58 253 129 0 0 0 1 0 25 255 202 3 82 2 227 0 5 0 21 0 186 0 0 0 1 0 3 43 186 0 4 0 1 0 0 17 18 57 48 49 1 17 35 1 53 1 3 82 2 252 201 3 55 2 227 252 231 1 139 4 1 138 0 0 0 0 2 0 25 255 202 3 82 2 227 0 5 0 8 0 51 0 186 0 0 0 1 0 3 43 186 0 4 0 1 0 0 17 18 57 186 0 6 0 1 0 0 17 18 57 186 0 7 0 1 0 0 17 18 57 186 0 8 0 1 0 0 17 18 57 48 49 1 17 35 1 53 1 7 9 1 3 82 2 252 201 3 55 57 253 128 2 128 2 227 252 231 1 139 4 1 138 97 254 213 254 212 0 0 0 2 0 74 255 246 2 213 2 159 0 5 0 9 0 40 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 187 0 3 0 2 0 8 0 4 43 184 0 0 16 185 0 6 0 1 244 48 49 23 17 55 33 17 7 37 33 17 33 74 61 2 78 53 253 213 2 21 253 235 10 2 118 51 253 148 61 43 2 52 0 0 2 0 74 255 246 3 37 3 27 0 18 0 30 0 40 0 184 0 0 69 88 184 0 19 47 27 185 0 19 0 5 62 89 187 0 22 0 2 0 11 0 4 43 184 0 19 16 185 0 13 0 1 244 48 49 37 46 1 39 55 30 1 23 51 62 1 55 33 17 33 17 14 1 7 5 17 55 33 62 1 55 23 6 7 17 7 1 93 27 70 43 56 37 61 20 4 32 105 66 254 39 2 21 68 111 36 254 151 61 1 252 26 55 28 53 41 39 53 104 77 136 64 38 58 126 63 110 218 97 253 204 2 21 95 227 130 124 2 118 51 35 61 28 50 38 45 253 157 61 0 0 0 1 0 0 255 236 2 104 2 172 0 19 0 0 23 46 1 39 55 30 1 23 51 62 3 55 23 14 3 7 151 30 73 48 56 42 67 23 4 27 78 96 110 59 54 59 112 98 82 28 20 83 143 69 38 63 135 67 89 178 165 146 58 50 55 139 164 185 101 0 0 0 0 1 0 29 255 232 1 225 2 182 0 38 0 21 0 186 0 8 0 0 0 3 43 186 0 11 0 0 0 8 17 18 57 48 49 23 34 38 53 52 62 2 51 50 22 23 17 51 30 3 23 30 3 21 20 6 7 39 62 1 53 52 38 39 17 20 14 2 130 41 60 23 42 58 35 20 33 7 50 4 8 15 24 19 34 44 26 10 21 11 35 8 5 65 60 28 47 63 24 38 38 23 42 33 19 7 5 2 25 10 15 15 19 13 24 46 47 51 28 39 69 23 13 24 41 27 48 83 19 254 105 41 63 42 21 0 0 2 0 56 255 246 1 205 2 158 0 5 0 15 0 53 0 184 0 0 69 88 184 0 2 47 27 185 0 2 0 17 62 89 184 0 0 69 88 184 0 0 47 27 185 0 0 0 5 62 89 185 0 6 0 1 244 184 0 2 16 185 0 11 0 1 244 48 49 23 3 19 51 19 3 39 51 63 1 47 1 35 15 1 23 221 165 165 75 165 165 39 4 62 65 65 62 4 63 65 65 10 1 84 1 84 254 172 254 172 69 133 138 137 134 134 137 138 0 0 0 1 0 82 1 193 0 185 2 178 0 4 0 11 0 186 0 1 0 0 0 3 43 48 49 19 55 23 15 1 82 22 81 15 34 1 194 240 1 91 149 0 0 0 255 255 0 82 1 193 1 106 2 178 0 38 7 4 0 0 0 7 7 4 0 177 0 0 0 1 0 64 1 193 0 167 2 178 0 4 0 11 0 186 0 4 0 1 0 3 43 48 49 19 7 47 1 55 167 54 34 15 81 1 194 1 149 91 1 0 0 0 255 255 0 82 1 193 0 185 2 178 2 6 7 4 0 0 255 255 0 57 1 172 0 187 2 184 2 6 4 128 0 0 255 255 0 63 1 175 0 193 2 187 2 6 4 129 0 0 255 255 0 30 2 35 0 151 2 233 0 7 7 96 0 85 3 39 0 0 255 255 0 15 2 35 0 136 2 233 0 7 7 74 0 81 3 39 0 0 255 255 0 128 2 61 1 71 3 13 0 7 7 31 1 15 0 0 0 0 255 255 0 215 2 61 1 158 3 13 0 7 7 34 1 15 0 0 0 0 255 255 0 116 2 56 1 170 2 228 0 7 7 37 1 15 0 0 0 0 255 255 0 116 2 62 1 170 2 234 0 7 7 59 1 15 0 0 0 0 0 1 0 22 2 21 0 92 2 217 0 3 0 11 0 186 0 1 0 0 0 3 43 48 49 19 39 51 7 28 6 70 6 2 21 196 196 0 0 0 255 255 0 6 2 89 1 16 2 146 0 7 7 41 0 139 0 0 0 0 255 255 0 55 2 61 0 254 3 13 0 6 7 34 111 0 255 255 255 224 2 61 0 167 3 13 0 6 7 31 111 0 255 255 0 22 254 246 0 92 255 185 0 6 7 88 57 0 255 255 0 98 2 65 1 188 2 209 0 7 7 39 1 15 0 0 0 0 255 255 0 125 2 75 1 161 2 175 0 7 7 51 1 15 0 0 0 0 255 255 0 138 2 89 1 148 2 146 0 7 7 41 1 15 0 0 0 0 255 255 0 115 2 59 1 171 2 218 0 7 7 45 1 15 0 0 0 0 255 255 0 161 2 42 1 125 2 239 0 7 7 55 1 15 0 0 0 0 255 255 0 175 2 56 1 214 2 249 0 7 7 57 1 15 0 0 0 0 255 255 0 217 2 74 1 69 2 182 0 7 7 49 1 15 0 0 0 0 255 255 0 182 255 30 1 99 0 3 0 7 7 84 1 21 0 0 0 0 255 255 0 205 255 50 1 118 0 3 0 7 7 86 1 15 0 0 0 0 0 12 0 46 255 244 2 28 1 242 0 11 0 23 0 35 0 47 0 59 0 71 0 83 0 95 0 107 0 119 0 131 0 142 0 195 0 184 0 0 69 88 184 0 78 47 27 185 0 78 0 9 62 89 184 0 0 69 88 184 0 60 47 27 185 0 60 0 5 62 89 187 0 42 0 2 0 36 0 4 43 187 0 54 0 2 0 48 0 4 43 187 0 6 0 2 0 0 0 4 43 187 0 138 0 2 0 132 0 4 43 187 0 18 0 2 0 12 0 4 43 184 0 132 16 184 0 24 208 184 0 138 16 184 0 30 208 184 0 30 47 184 0 60 16 185 0 66 0 2 244 184 0 78 16 185 0 72 0 2 244 184 0 36 16 184 0 84 208 184 0 42 16 184 0 90 208 184 0 48 16 184 0 96 208 184 0 96 47 184 0 54 16 184 0 102 208 184 0 0 16 184 0 108 208 184 0 6 16 184 0 114 208 184 0 12 16 184 0 120 208 184 0 18 16 184 0 126 208 48 49 55 34 38 53 52 54 51 50 22 21 20 6 39 34 38 53 52 54 51 50 22 21 20 6 55 34 38 53 52 54 51 50 22 21 20 6 19 34 38 53 52 54 51 50 22 21 20 6 3 34 38 53 52 54 51 50 22 21 20 6 19 34 38 53 52 54 51 50 22 21 20 6 3 34 38 53 52 54 51 50 22 21 20 6 19 34 38 53 52 54 51 50 22 21 20 6 3 34 38 53 52 54 51 50 22 21 20 6 19 34 38 53 52 54 51 50 22 21 20 6 55 34 38 53 52 54 51 50 22 21 20 6 39 34 38 53 52 54 51 50 22 21 20 108 14 20 20 14 16 20 19 45 14 20 20 14 16 21 20 11 14 20 20 14 16 20 19 61 14 20 20 14 15 21 20 16 14 20 20 14 15 21 20 90 14 20 20 14 16 20 20 16 14 20 20 14 16 20 20 90 14 20 20 14 15 21 19 17 14 20 20 14 15 21 19 62 14 21 21 14 15 20 18 10 15 20 20 15 14 22 20 43 14 21 21 14 15 20 97 19 17 18 20 20 18 17 19 109 20 17 18 18 18 18 17 20 110 20 18 18 18 18 18 18 20 254 211 19 19 17 18 18 17 19 19 1 127 19 17 19 18 18 19 17 19 254 102 19 18 17 19 19 17 18 19 1 180 20 18 17 19 19 17 18 20 254 103 19 19 17 18 18 17 19 19 1 126 20 17 18 19 19 18 17 20 254 212 19 17 18 20 20 18 17 19 109 20 17 18 18 18 18 17 20 110 19 18 17 19 19 17 37 0 0 1 255 113 2 61 0 56 3 13 0 3 0 24 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 2 220 48 49 19 39 55 23 14 157 58 141 2 61 153 55 167 0 0 1 255 121 2 185 0 54 3 99 0 3 0 24 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 2 220 48 49 19 39 55 23 17 152 47 142 2 185 115 55 128 0 0 1 255 165 2 46 0 33 3 2 0 3 0 13 0 124 184 0 0 47 24 184 0 2 220 48 49 3 39 55 23 24 67 85 39 2 46 197 15 201 0 1 255 200 2 61 0 143 3 13 0 3 0 24 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 2 220 48 49 3 39 55 23 14 42 141 58 2 61 41 167 55 0 0 1 255 202 2 185 0 135 3 99 0 3 0 24 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 2 220 48 49 3 39 55 23 17 37 142 47 2 185 42 128 55 0 0 1 255 223 2 46 0 95 3 2 0 3 0 11 0 184 0 3 47 184 0 1 220 48 49 3 55 23 7 33 43 85 71 2 57 201 15 197 0 0 0 1 255 101 2 56 0 155 2 228 0 7 0 42 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 13 62 89 184 0 1 220 184 0 7 16 184 0 4 208 186 0 6 0 1 0 7 17 18 57 48 49 3 55 51 23 7 39 35 7 155 114 82 114 35 118 4 118 2 88 140 140 32 113 113 0 0 1 255 108 2 187 0 148 3 70 0 7 0 42 0 184 0 0 69 88 184 0 7 47 27 185 0 7 0 19 62 89 184 0 1 220 184 0 7 16 184 0 4 208 186 0 6 0 1 0 7 17 18 57 48 49 3 55 51 23 7 39 35 7 148 105 86 105 36 110 4 110 2 213 113 113 26 93 93 0 0 1 255 83 2 65 0 173 2 209 0 27 0 48 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 19 220 184 0 5 208 184 0 0 16 184 0 8 208 184 0 5 16 184 0 14 220 184 0 22 208 48 49 19 34 46 2 35 34 6 7 39 62 3 51 50 30 2 51 50 54 55 23 14 3 72 27 38 32 29 17 23 22 2 55 1 13 24 37 26 27 38 32 29 18 22 22 2 55 1 13 24 37 2 65 26 32 26 44 35 3 29 50 36 21 26 32 26 44 35 4 29 49 36 21 0 0 0 1 255 79 2 197 0 177 3 73 0 22 0 48 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 17 220 184 0 5 208 184 0 0 16 184 0 8 208 184 0 5 16 184 0 12 220 184 0 19 208 48 49 19 34 46 2 35 34 6 7 39 62 1 51 50 30 2 51 50 55 23 14 1 75 28 40 33 29 18 19 26 3 56 3 54 45 28 40 33 29 18 40 8 56 3 54 2 197 22 27 22 34 32 4 57 66 22 27 22 66 4 58 65 0 0 1 255 123 2 89 0 133 2 146 0 3 0 11 0 184 0 0 47 184 0 2 220 48 49 3 53 33 21 133 1 10 2 89 57 57 0 1 255 122 2 223 0 134 3 24 0 3 0 24 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 1 220 48 49 3 53 33 21 134 1 12 2 223 57 57 0 0 0 255 255 255 123 2 89 0 133 2 146 2 6 7 41 0 0 255 255 255 122 2 223 0 134 3 24 2 6 7 42 0 0 0 1 255 100 2 59 0 156 2 218 0 21 0 32 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 11 220 184 0 6 220 184 0 16 208 48 49 17 34 46 2 39 55 30 3 51 50 62 2 55 23 14 3 40 58 37 19 2 51 3 15 26 37 24 24 37 26 15 3 51 2 19 38 57 2 59 26 43 54 28 8 19 37 30 18 18 30 37 19 8 28 54 43 26 0 0 1 255 99 2 60 0 157 2 213 0 21 0 32 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 11 220 184 0 6 220 184 0 16 208 48 49 17 34 46 2 39 51 30 3 51 50 62 2 55 51 14 3 42 58 38 18 1 68 1 9 21 33 25 25 33 21 9 1 68 2 17 38 58 2 60 26 43 55 29 21 39 28 17 17 28 39 21 29 55 43 26 0 0 0 0 1 255 110 2 193 0 146 3 74 0 17 0 32 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 9 220 184 0 6 220 184 0 12 208 48 49 17 34 46 2 39 55 30 1 51 50 54 55 23 14 3 35 52 36 20 3 50 6 47 43 43 47 6 50 3 20 36 52 2 193 21 35 47 26 8 35 49 49 35 8 26 47 35 21 0 0 0 1 255 105 2 193 0 151 3 69 0 19 0 32 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 9 220 184 0 6 220 184 0 14 208 48 49 17 34 46 2 39 51 30 1 51 50 62 2 55 51 14 3 42 56 35 17 1 72 1 36 42 21 29 19 9 1 72 2 16 35 56 2 193 22 37 48 25 35 51 14 23 31 18 25 48 37 22 0 0 0 0 1 255 202 2 74 0 54 2 182 0 11 0 11 0 186 0 6 0 0 0 3 43 48 49 17 34 38 53 52 54 51 50 22 21 20 6 23 31 31 23 23 31 31 2 74 30 24 23 31 31 23 24 30 0 0 0 1 255 199 2 202 0 57 3 53 0 11 0 24 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 6 220 48 49 17 34 38 53 52 54 51 50 22 21 20 6 24 33 33 24 24 33 33 2 202 30 24 23 30 30 23 24 30 0 0 2 255 110 2 75 0 146 2 175 0 11 0 23 0 27 0 186 0 6 0 0 0 3 43 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 3 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 96 22 28 28 22 21 28 28 171 21 28 28 21 22 28 28 2 75 29 21 21 29 29 21 21 29 29 21 21 29 29 21 21 29 0 0 0 0 2 255 104 2 203 0 152 3 45 0 11 0 23 0 40 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 6 220 184 0 0 16 184 0 12 208 184 0 6 16 184 0 18 208 48 49 3 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 103 21 28 28 21 22 27 27 184 22 27 27 22 21 28 28 2 203 28 21 22 27 27 22 21 28 28 21 22 27 27 22 21 28 0 0 0 1 255 188 2 60 0 80 2 248 0 14 0 32 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 1 220 184 0 6 220 184 0 7 220 48 49 3 39 62 1 53 52 39 55 30 1 21 20 14 2 32 9 24 32 83 5 69 74 19 31 40 2 60 40 6 21 20 43 4 54 2 47 45 22 31 23 14 0 0 1 255 188 2 186 0 79 3 104 0 14 0 32 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 1 220 184 0 6 220 184 0 7 220 48 49 3 39 62 1 53 52 39 55 30 1 21 20 14 2 32 9 24 32 83 9 66 72 18 31 40 2 186 38 7 20 19 39 3 48 2 41 38 22 31 23 13 0 0 2 255 146 2 42 0 110 2 239 0 11 0 23 0 19 0 186 0 12 0 0 0 3 43 186 0 6 0 18 0 3 43 48 49 17 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 51 59 59 51 51 59 59 51 24 33 33 24 24 33 33 2 42 56 43 42 56 56 42 43 56 37 33 29 28 33 33 28 29 33 0 0 0 0 2 255 159 2 187 0 97 3 112 0 11 0 23 0 19 0 186 0 12 0 0 0 3 43 186 0 6 0 18 0 3 43 48 49 17 34 38 53 52 54 51 50 22 21 20 6 39 50 54 53 52 38 35 34 6 21 20 22 42 55 55 42 42 55 55 42 20 31 31 20 22 30 30 2 187 49 41 42 49 49 42 41 49 36 28 26 26 28 28 26 26 28 0 0 0 0 2 255 160 2 56 0 199 2 249 0 3 0 7 0 11 0 186 0 2 0 0 0 3 43 48 49 3 39 55 31 1 39 55 23 51 45 86 59 51 46 87 58 2 56 21 172 28 165 21 172 28 0 2 255 154 2 191 0 206 3 108 0 3 0 7 0 36 0 184 0 0 69 88 184 0 3 47 27 185 0 3 0 19 62 89 184 0 1 220 184 0 5 208 184 0 3 16 184 0 7 208 48 49 3 55 23 7 63 1 23 7 102 92 56 105 117 92 56 105 2 212 152 32 141 21 152 32 141 0 0 0 0 1 255 101 2 62 0 155 2 234 0 7 0 38 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 2 220 186 0 3 0 2 0 0 17 18 57 184 0 5 208 48 49 3 39 55 23 51 55 23 7 41 114 35 118 4 118 35 114 2 62 140 32 113 113 32 140 0 1 255 108 2 194 0 148 3 77 0 7 0 38 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 2 220 186 0 3 0 2 0 0 17 18 57 184 0 5 208 48 49 3 39 55 23 51 55 23 7 43 105 36 110 4 110 36 105 2 194 113 26 92 92 26 113 0 1 255 227 2 36 0 30 2 248 0 4 0 11 0 186 0 1 0 0 0 3 43 48 49 3 39 51 15 1 25 4 59 1 14 2 36 212 57 155 0 2 255 57 2 56 0 96 2 249 0 3 0 7 0 27 0 184 0 0 47 184 0 2 220 184 0 0 16 184 0 4 208 184 0 2 16 184 0 6 208 48 49 3 39 55 31 1 39 55 23 100 99 58 87 105 100 59 86 2 56 165 28 172 21 165 28 172 0 2 255 50 2 191 0 102 3 108 0 3 0 7 0 40 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 2 220 184 0 0 16 184 0 4 208 184 0 2 16 184 0 6 208 48 49 3 39 55 31 1 39 55 23 101 105 56 92 117 105 56 92 2 191 141 32 152 21 141 32 152 0 0 0 0 1 255 100 2 56 0 156 2 215 0 21 0 23 0 184 0 0 47 184 0 17 220 184 0 6 220 184 0 0 16 184 0 12 208 48 49 3 39 62 3 51 50 30 2 23 7 46 3 35 34 14 2 105 51 2 19 37 58 40 40 57 38 19 2 51 3 15 26 37 24 24 37 26 15 2 56 8 28 54 43 26 26 43 54 28 8 19 37 30 18 18 30 37 0 0 0 1 255 110 2 192 0 146 3 73 0 17 0 36 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 15 220 184 0 6 220 184 0 0 16 184 0 12 208 48 49 3 39 62 3 51 50 30 2 23 7 46 1 35 34 6 96 50 3 20 36 52 35 35 52 36 20 3 50 6 47 43 43 47 2 192 8 26 47 35 21 21 35 47 26 8 35 49 49 0 0 0 1 255 203 2 52 0 46 2 238 0 16 0 11 0 186 0 11 0 0 0 3 43 48 49 3 34 53 52 54 55 23 14 1 7 54 51 50 22 21 20 6 2 51 38 43 18 29 26 2 3 5 15 26 23 2 52 69 35 62 20 32 14 34 23 1 20 20 22 22 0 0 0 1 255 176 2 62 0 68 2 245 0 14 0 11 0 186 0 8 0 9 0 3 43 48 49 19 46 3 53 52 54 55 23 6 21 20 22 23 32 22 40 31 19 74 69 5 83 32 24 2 62 4 13 22 31 22 43 46 2 51 4 43 20 21 6 0 0 0 0 1 255 209 2 50 0 51 2 237 0 15 0 11 0 186 0 11 0 5 0 3 43 48 49 3 39 54 55 6 35 34 38 53 52 54 51 50 21 20 6 30 17 54 3 3 6 15 26 24 17 50 38 2 50 32 28 44 1 19 20 23 22 69 35 63 0 0 255 255 255 188 2 60 0 80 2 248 2 6 7 53 0 0 0 1 255 180 255 7 0 85 255 198 0 7 0 13 0 187 0 5 0 1 0 2 0 4 43 48 49 23 35 53 35 53 51 53 51 85 50 111 111 50 249 72 47 72 0 1 255 171 255 7 0 76 255 198 0 7 0 13 0 187 0 7 0 1 0 0 0 4 43 48 49 23 35 21 35 53 51 21 51 76 111 50 50 111 177 72 191 72 0 1 255 180 2 61 0 85 2 202 0 5 0 26 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 19 62 89 185 0 2 0 1 244 48 49 19 35 53 35 53 51 85 50 111 161 2 61 94 47 0 0 0 1 255 247 1 178 0 148 2 131 0 14 0 11 0 186 0 1 0 0 0 3 43 48 49 3 39 54 53 52 38 39 55 30 1 21 20 14 2 1 8 84 8 6 64 10 13 23 40 55 1 178 41 13 69 16 26 14 30 18 38 24 30 45 31 19 0 0 0 1 255 190 254 252 0 55 255 194 0 13 0 23 0 187 0 13 0 1 0 0 0 4 43 187 0 6 0 1 0 7 0 4 43 48 49 19 6 38 53 52 54 23 21 34 6 21 20 22 51 55 60 61 61 60 40 33 33 40 254 254 2 53 46 46 53 2 35 34 28 28 34 0 0 0 0 1 255 160 255 45 0 96 255 198 0 7 0 34 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 7 62 89 185 0 2 0 1 244 184 0 6 208 184 0 7 208 48 49 23 35 53 51 53 51 21 51 96 192 71 50 71 211 47 106 106 0 0 0 0 1 255 160 255 7 0 96 255 160 0 7 0 21 0 187 0 7 0 1 0 0 0 4 43 184 0 0 16 184 0 4 208 48 49 23 35 21 35 53 35 53 51 96 71 50 71 192 143 106 106 47 0 1 255 160 255 7 0 96 255 198 0 11 0 29 0 187 0 11 0 1 0 0 0 4 43 184 0 0 16 184 0 4 208 184 0 11 16 184 0 6 208 48 49 23 35 21 35 53 35 53 51 53 51 21 51 96 71 50 71 71 50 71 177 72 72 47 72 72 0 1 255 160 255 79 0 96 255 126 0 3 0 13 0 187 0 1 0 1 0 0 0 4 43 48 49 7 53 51 21 96 192 177 47 47 255 255 255 202 255 51 0 54 255 159 2 7 7 49 0 0 252 233 0 0 255 255 255 110 255 55 0 146 255 155 2 7 7 51 0 0 252 236 0 0 255 255 255 146 255 4 0 110 255 201 2 7 7 55 0 0 252 218 0 0 0 1 255 161 255 30 0 78 255 198 0 13 0 23 0 186 0 7 0 8 0 3 43 184 0 7 16 184 0 1 220 184 0 0 220 48 49 7 39 62 1 53 52 38 39 55 30 1 21 20 6 87 8 63 46 36 35 18 65 52 85 226 40 5 23 20 20 19 3 38 8 35 34 44 43 0 0 1 255 178 2 63 0 95 2 232 0 13 0 23 0 186 0 13 0 0 0 3 43 184 0 13 16 184 0 7 220 184 0 6 220 48 49 19 46 1 53 52 54 55 23 14 1 21 20 22 23 39 65 52 85 80 8 63 46 36 35 2 63 7 36 34 44 43 5 41 4 23 21 20 19 3 0 1 255 161 255 30 0 78 0 3 0 15 0 23 0 186 0 7 0 10 0 3 43 184 0 7 16 184 0 1 220 184 0 0 220 48 49 7 39 62 1 53 52 38 39 55 51 7 30 1 21 20 6 87 8 63 46 34 43 44 53 29 35 38 85 226 40 5 23 22 20 22 6 91 67 8 32 31 44 43 0 1 255 161 255 30 0 78 0 3 0 15 0 23 0 186 0 7 0 10 0 3 43 184 0 7 16 184 0 1 220 184 0 0 220 48 49 7 39 62 1 53 52 38 39 55 51 7 30 1 21 20 6 87 8 63 46 34 43 44 53 29 35 38 85 226 40 5 23 22 20 22 6 91 67 8 32 31 44 43 0 1 255 190 255 50 0 103 0 3 0 18 0 11 0 186 0 13 0 0 0 3 43 48 49 23 34 38 53 52 54 55 51 14 1 21 20 22 51 50 55 23 14 1 24 38 52 46 25 58 32 36 28 18 22 18 22 14 46 206 43 42 41 64 19 24 55 29 23 23 13 41 11 16 0 0 0 1 255 190 255 44 0 109 0 3 0 21 0 11 0 186 0 15 0 0 0 3 43 48 49 23 34 38 53 52 62 2 55 51 14 1 21 20 22 51 50 54 55 23 14 1 29 40 55 13 21 26 12 60 32 36 30 18 12 19 9 23 14 46 212 44 43 21 38 33 27 9 24 57 29 23 23 7 7 45 11 17 0 0 0 1 255 221 254 246 0 35 255 185 0 3 0 11 0 186 0 1 0 0 0 3 43 48 49 3 55 51 23 35 6 58 6 254 246 195 195 0 0 0 0 1 255 135 255 30 0 121 255 174 0 7 0 13 0 187 0 6 0 1 0 1 0 4 43 48 49 23 53 35 21 35 53 51 21 75 150 46 242 226 97 97 144 144 255 255 255 101 255 33 0 155 255 205 2 7 7 59 0 0 252 227 0 0 255 255 255 100 255 26 0 156 255 185 2 7 7 45 0 0 252 223 0 0 255 255 255 100 255 20 0 156 255 179 2 7 7 64 0 0 252 220 0 0 255 255 255 83 255 34 0 173 255 178 2 7 7 39 0 0 252 225 0 0 255 255 255 123 255 87 0 133 255 144 2 7 7 41 0 0 252 254 0 0 255 255 255 83 0 189 0 173 1 77 2 7 7 39 0 0 254 124 0 0 0 1 255 201 254 252 0 66 255 194 0 13 0 23 0 187 0 1 0 1 0 0 0 4 43 187 0 8 0 1 0 7 0 4 43 48 49 3 53 50 54 53 52 38 35 53 54 22 21 20 6 55 40 33 33 40 60 61 61 254 254 35 34 28 28 34 35 2 53 46 46 53 0 1 255 135 255 31 0 121 255 174 0 7 0 13 0 187 0 3 0 1 0 0 0 4 43 48 49 7 53 51 21 51 53 51 21 121 46 150 46 225 143 96 96 143 0 2 255 135 255 16 0 121 255 179 0 3 0 7 0 23 0 187 0 4 0 1 0 0 0 4 43 187 0 2 0 1 0 6 0 4 43 48 49 7 53 51 21 39 51 53 35 121 242 196 150 150 240 163 163 40 84 0 0 0 0 1 255 88 255 22 0 168 255 176 0 29 0 71 0 187 0 7 0 2 0 21 0 4 43 184 0 21 16 184 0 0 208 184 0 0 47 184 0 7 16 184 0 17 208 184 0 17 47 185 0 10 0 1 244 184 0 3 208 184 0 21 16 184 0 13 208 184 0 13 47 184 0 7 16 184 0 26 208 184 0 26 47 48 49 7 52 54 51 50 22 23 51 62 1 51 50 22 21 7 52 38 35 34 6 29 1 35 53 52 38 35 34 6 21 168 48 46 26 39 8 2 8 39 26 46 48 48 27 23 23 23 48 23 24 23 26 228 78 70 26 32 32 26 70 78 6 60 40 42 38 19 19 38 42 40 60 0 0 0 0 1 255 172 2 43 0 84 2 212 0 11 0 37 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 19 62 89 184 0 0 69 88 184 0 6 47 27 185 0 6 0 19 62 89 48 49 3 39 55 39 55 23 55 23 7 23 7 39 51 33 51 51 33 51 51 33 51 51 33 51 2 43 33 51 51 34 51 51 34 51 51 33 51 255 255 255 83 2 65 0 173 2 209 2 6 7 39 0 0 255 255 255 79 2 197 0 177 3 73 2 6 7 40 0 0 0 1 255 223 255 55 0 90 255 194 0 17 0 13 0 187 0 11 0 1 0 0 0 4 43 48 49 23 34 38 61 1 51 6 20 21 20 22 51 50 54 55 23 14 1 44 40 37 64 2 18 12 4 8 10 9 10 19 201 48 45 46 13 29 11 17 14 1 2 49 4 5 0 1 254 58 2 38 1 198 2 207 0 13 0 11 0 186 0 4 0 11 0 3 43 48 49 1 39 62 1 51 50 22 23 7 46 1 35 34 6 254 82 24 101 225 128 128 225 101 24 96 225 109 109 225 2 38 42 62 65 65 62 42 58 53 53 0 0 0 0 3 255 114 2 76 0 142 3 76 0 3 0 15 0 27 0 39 0 184 0 0 47 186 0 10 0 4 0 3 43 184 0 0 16 184 0 2 220 184 0 4 16 184 0 16 208 184 0 10 16 184 0 22 208 48 49 3 39 55 23 7 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 7 35 82 49 185 20 26 26 20 20 25 25 172 20 25 25 20 20 26 26 2 193 24 115 34 222 26 19 20 26 26 20 19 26 26 19 20 26 26 20 19 26 0 0 3 255 108 2 203 0 148 3 200 0 11 0 15 0 27 0 52 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 186 0 13 0 15 0 3 43 184 0 0 16 184 0 6 220 184 0 0 16 184 0 16 208 184 0 6 16 184 0 22 208 48 49 3 34 38 53 52 54 51 50 22 21 20 6 63 1 23 7 23 34 38 53 52 54 51 50 22 21 20 6 103 20 25 25 20 20 26 26 45 95 53 111 104 20 26 26 20 20 25 25 2 203 26 20 20 25 25 20 20 26 134 119 36 109 108 26 20 20 25 25 20 20 26 0 0 0 0 3 255 101 2 51 0 155 3 6 0 3 0 15 0 27 0 39 0 184 0 3 47 186 0 10 0 4 0 3 43 184 0 3 16 184 0 1 220 184 0 4 16 184 0 16 208 184 0 10 16 184 0 22 208 48 49 3 55 23 7 39 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 40 45 66 68 116 18 24 24 18 17 24 24 209 17 24 24 17 18 24 24 2 61 201 14 197 32 23 19 19 23 23 19 19 23 23 19 19 23 23 19 19 23 0 0 3 255 114 2 76 0 142 3 76 0 3 0 15 0 27 0 35 0 186 0 10 0 4 0 3 43 186 0 0 0 2 0 3 43 184 0 4 16 184 0 16 208 184 0 10 16 184 0 22 208 48 49 19 39 55 23 7 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 7 96 49 82 138 20 26 26 20 20 25 25 172 20 25 25 20 20 26 26 2 193 105 34 115 141 26 19 20 26 26 20 19 26 26 19 20 26 26 20 19 26 0 0 3 255 108 2 203 0 148 3 200 0 3 0 15 0 27 0 52 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 19 62 89 186 0 3 0 1 0 3 43 184 0 4 16 184 0 10 220 184 0 4 16 184 0 16 208 184 0 10 16 184 0 22 208 48 49 19 7 39 55 7 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 38 37 111 53 46 20 25 25 20 20 26 26 186 20 26 26 20 20 25 25 3 81 26 109 36 253 26 20 20 25 25 20 20 26 26 20 20 25 25 20 20 26 0 3 255 101 2 51 0 155 3 6 0 11 0 15 0 27 0 39 0 184 0 12 47 186 0 6 0 0 0 3 43 184 0 12 16 184 0 14 220 184 0 0 16 184 0 16 208 184 0 6 16 184 0 22 208 48 49 3 34 38 53 52 54 51 50 22 21 20 6 23 39 55 23 55 34 38 53 52 54 51 50 22 21 20 6 113 18 24 24 18 17 24 24 93 64 66 41 73 17 24 24 17 18 24 24 2 83 23 19 19 23 23 19 19 23 32 197 14 201 22 23 19 19 23 23 19 19 23 0 3 255 103 2 76 0 153 3 38 0 23 0 35 0 47 0 55 0 186 0 30 0 24 0 3 43 184 0 30 16 184 0 42 208 184 0 15 220 184 0 8 220 184 0 20 208 184 0 3 220 184 0 11 208 184 0 15 16 184 0 23 208 184 0 24 16 184 0 36 208 48 49 3 62 1 51 50 30 2 51 50 54 55 23 14 1 35 34 46 2 35 34 6 7 23 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 153 2 42 38 26 36 30 28 18 17 24 3 42 2 42 38 26 36 30 28 18 17 24 3 15 20 26 26 20 20 25 25 172 20 25 25 20 20 26 26 2 202 39 53 15 19 15 23 23 4 39 53 15 19 15 23 23 122 26 19 20 26 26 20 19 26 26 19 20 26 26 20 19 26 0 0 0 0 3 255 114 2 76 0 142 3 29 0 11 0 15 0 27 0 39 0 186 0 6 0 0 0 3 43 184 0 6 16 184 0 12 220 184 0 13 220 184 0 0 16 184 0 16 208 184 0 6 16 184 0 22 208 48 49 3 34 38 53 52 54 51 50 22 21 20 6 39 53 33 21 7 34 38 53 52 54 51 50 22 21 20 6 96 20 26 26 20 20 25 25 58 1 11 37 20 25 25 20 20 26 26 2 76 26 19 20 26 26 20 19 26 162 47 47 162 26 19 20 26 26 20 19 26 0 0 0 3 255 108 2 203 0 148 3 139 0 11 0 15 0 27 0 48 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 6 220 184 0 12 220 184 0 13 220 184 0 0 16 184 0 16 208 184 0 6 16 184 0 22 208 48 49 3 34 38 53 52 54 51 50 22 21 20 6 39 53 33 21 7 34 38 53 52 54 51 50 22 21 20 6 103 20 25 25 20 20 26 26 51 1 12 31 20 26 26 20 20 25 25 2 203 26 20 20 25 25 20 20 26 146 46 46 146 26 20 20 25 25 20 20 26 0 0 3 255 114 2 76 0 142 3 72 0 7 0 19 0 31 0 53 0 186 0 14 0 8 0 3 43 184 0 14 16 184 0 6 220 184 0 0 220 186 0 1 0 0 0 6 17 18 57 184 0 3 208 184 0 8 16 184 0 20 208 184 0 14 16 184 0 26 208 48 49 3 23 51 55 23 7 35 39 23 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 98 96 4 96 30 94 68 94 32 20 26 26 20 20 25 25 172 20 25 25 20 20 26 26 3 72 73 73 28 92 92 224 26 19 20 26 26 20 19 26 26 19 20 26 26 20 19 26 0 0 3 255 108 2 203 0 148 3 194 0 7 0 19 0 31 0 62 0 184 0 0 69 88 184 0 8 47 27 185 0 8 0 19 62 89 184 0 14 220 184 0 0 220 184 0 2 220 186 0 3 0 2 0 0 17 18 57 184 0 5 208 184 0 8 16 184 0 20 208 184 0 14 16 184 0 26 208 48 49 3 39 55 23 51 55 23 15 1 34 38 53 52 54 51 50 22 21 20 6 51 34 38 53 52 54 51 50 22 21 20 6 36 99 33 100 4 100 33 99 139 20 25 25 20 20 26 26 186 20 26 26 20 20 25 25 3 71 96 27 75 75 27 96 124 26 20 20 25 25 20 20 26 26 20 20 25 25 20 20 26 0 0 0 0 2 255 122 2 58 0 235 3 17 0 7 0 11 0 31 0 186 0 9 0 11 0 3 43 186 0 7 0 2 0 3 43 184 0 7 16 184 0 1 220 184 0 4 208 48 49 3 39 55 51 23 7 39 35 63 1 23 7 105 29 100 68 100 29 103 4 101 87 49 101 2 58 34 92 92 34 72 23 120 34 114 0 0 0 2 255 127 2 187 0 223 3 120 0 7 0 11 0 44 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 7 220 184 0 2 220 184 0 0 16 184 0 5 208 184 0 8 220 184 0 10 220 48 49 3 39 55 51 23 7 39 35 23 39 55 23 95 34 93 72 93 34 93 4 123 30 97 35 2 187 26 90 90 26 69 5 32 93 39 0 0 2 255 9 2 58 0 134 3 17 0 7 0 11 0 31 0 186 0 11 0 9 0 3 43 186 0 7 0 2 0 3 43 184 0 7 16 184 0 1 220 184 0 4 208 48 49 3 39 55 51 23 7 39 35 39 7 39 55 105 29 100 68 100 29 103 4 97 35 113 48 2 58 34 92 92 34 72 26 31 112 36 0 0 0 2 255 45 2 187 0 129 3 120 0 7 0 11 0 48 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 7 220 184 0 2 220 184 0 0 16 184 0 5 208 184 0 0 16 184 0 9 220 184 0 11 220 48 49 3 39 55 51 23 7 39 35 39 7 39 55 95 34 93 72 93 34 93 4 89 30 90 35 2 187 26 90 90 26 69 25 30 88 37 0 0 2 255 122 2 58 0 209 3 23 0 7 0 23 0 39 0 186 0 7 0 2 0 3 43 184 0 7 16 184 0 1 220 184 0 4 208 184 0 8 220 184 0 9 220 184 0 15 220 184 0 16 220 48 49 3 39 55 51 23 7 39 35 23 39 62 1 53 52 38 39 55 30 1 21 20 14 2 105 29 100 68 100 29 103 4 118 9 19 23 32 37 7 59 63 16 26 33 2 58 34 92 92 34 72 7 35 5 18 16 20 19 2 41 2 36 35 20 28 19 12 0 0 0 0 2 255 127 2 187 0 207 3 138 0 7 0 21 0 52 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 7 220 184 0 2 220 184 0 0 16 184 0 5 208 184 0 8 220 184 0 9 220 184 0 15 220 184 0 16 220 48 49 3 39 55 51 23 7 39 35 23 39 62 1 53 52 38 39 55 30 1 21 20 6 95 34 93 72 93 34 93 4 117 11 19 26 33 38 9 59 61 56 2 187 26 90 90 26 69 14 35 5 15 16 20 17 2 42 2 36 35 38 35 0 0 0 0 2 255 119 2 58 0 137 3 35 0 7 0 31 0 55 0 186 0 7 0 2 0 3 43 184 0 7 16 184 0 1 220 184 0 4 208 184 0 2 16 184 0 23 220 184 0 16 220 184 0 28 208 184 0 11 220 184 0 19 208 184 0 23 16 184 0 31 208 48 49 3 39 55 51 23 7 39 35 39 62 1 51 50 30 2 51 50 54 55 23 14 1 35 34 46 2 35 34 6 7 105 29 100 68 100 29 103 4 135 4 33 35 22 34 29 27 14 15 14 4 43 4 33 35 22 34 29 27 14 15 14 4 2 58 34 88 88 34 69 75 39 50 13 16 13 20 22 4 38 51 13 16 13 20 22 0 2 255 111 2 187 0 145 3 171 0 7 0 31 0 68 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 7 220 184 0 2 220 184 0 0 16 184 0 5 208 184 0 2 16 184 0 23 220 184 0 16 220 184 0 28 208 184 0 11 220 184 0 19 208 184 0 23 16 184 0 31 208 48 49 3 39 55 51 23 7 39 35 39 62 1 51 50 30 2 51 50 54 55 23 14 1 35 34 46 2 35 34 6 7 95 34 93 72 93 34 93 4 143 2 36 41 24 34 29 26 15 18 17 3 45 2 36 41 24 34 29 26 15 18 17 3 2 187 26 87 87 26 66 83 38 53 15 19 15 24 22 5 39 53 16 18 16 24 22 0 0 0 0 2 255 100 2 59 0 156 3 64 0 3 0 25 0 35 0 186 0 15 0 4 0 3 43 184 0 15 16 184 0 0 220 184 0 2 220 184 0 15 16 184 0 9 220 184 0 21 208 48 49 3 39 55 23 7 34 46 2 39 55 30 3 51 50 62 2 55 23 14 3 5 39 88 52 96 40 58 37 19 2 48 3 15 27 38 25 25 38 27 15 3 48 2 19 38 57 2 167 29 124 40 221 26 43 54 28 8 20 39 30 19 19 30 39 20 8 28 54 43 26 0 0 0 0 2 255 110 2 193 0 146 3 180 0 3 0 21 0 44 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 19 62 89 184 0 13 220 184 0 3 220 184 0 1 220 184 0 13 16 184 0 10 220 184 0 16 208 48 49 3 55 23 15 1 34 46 2 39 55 30 1 51 50 54 55 23 14 3 38 95 53 107 3 35 52 36 20 3 47 6 48 45 45 48 6 47 3 20 36 52 3 64 116 36 109 98 21 35 47 26 8 37 51 51 37 8 26 47 35 21 0 0 0 0 2 255 100 2 59 0 156 3 64 0 3 0 25 0 35 0 186 0 15 0 4 0 3 43 184 0 15 16 184 0 0 220 184 0 2 220 184 0 15 16 184 0 9 220 184 0 21 208 48 49 19 39 55 23 7 34 46 2 39 55 30 3 51 50 62 2 55 23 14 3 5 101 52 88 44 40 58 37 19 2 48 3 15 27 38 25 25 38 27 15 3 48 2 19 38 57 2 167 113 40 124 137 26 43 54 28 8 20 39 30 19 19 30 39 20 8 28 54 43 26 0 0 0 0 2 255 110 2 193 0 146 3 180 0 3 0 21 0 44 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 19 62 89 184 0 13 220 184 0 1 220 184 0 3 220 184 0 13 16 184 0 10 220 184 0 16 208 48 49 19 7 39 55 23 34 46 2 39 55 30 1 51 50 54 55 23 14 3 38 41 107 53 57 35 52 36 20 3 47 6 48 45 45 48 6 47 3 20 36 52 3 64 29 109 36 243 21 35 47 26 8 37 51 51 37 8 26 47 35 21 0 0 0 0 2 255 100 2 59 0 156 3 80 0 15 0 37 0 43 0 186 0 27 0 16 0 3 43 184 0 27 16 184 0 0 220 184 0 1 220 184 0 7 220 184 0 8 220 184 0 27 16 184 0 21 220 184 0 33 208 48 49 3 39 62 1 53 52 38 39 55 30 1 21 20 14 2 23 34 46 2 39 55 30 3 51 50 62 2 55 23 14 3 27 8 21 27 35 41 7 61 68 17 28 36 8 40 58 37 19 2 48 3 15 27 38 25 25 38 27 15 3 48 2 19 38 57 2 170 36 5 18 16 20 19 2 50 2 40 40 20 29 20 12 114 26 43 54 28 8 20 39 30 19 19 30 39 20 8 28 54 43 26 0 2 255 110 2 193 0 146 3 184 0 15 0 33 0 52 0 184 0 0 69 88 184 0 16 47 27 185 0 16 0 19 62 89 184 0 25 220 184 0 0 220 184 0 1 220 184 0 7 220 184 0 8 220 184 0 25 16 184 0 22 220 184 0 28 208 48 49 3 39 62 1 53 52 38 39 55 30 1 21 20 14 2 23 34 46 2 39 55 30 1 51 50 54 55 23 14 3 23 10 18 26 33 37 8 59 62 16 25 34 5 35 52 36 20 3 47 6 48 45 45 48 6 47 3 20 36 52 3 32 35 5 15 16 20 17 2 42 2 36 35 19 27 19 11 98 21 35 47 26 8 37 51 51 37 8 26 47 35 21 0 2 255 112 2 59 0 144 3 34 0 17 0 41 0 51 0 186 0 9 0 0 0 3 43 184 0 9 16 184 0 5 220 184 0 13 208 184 0 33 220 184 0 26 220 184 0 38 208 184 0 21 220 184 0 29 208 184 0 33 16 184 0 41 208 48 49 17 34 46 2 39 55 30 1 51 50 54 55 23 14 3 39 62 1 51 50 30 2 51 50 54 55 23 14 1 35 34 46 2 35 34 6 7 37 52 35 18 2 47 4 46 47 47 46 4 47 2 18 35 52 178 4 35 37 22 34 29 27 14 15 14 4 47 4 35 37 22 34 29 27 14 15 14 4 2 59 19 31 38 19 8 25 43 43 25 8 19 38 31 19 143 38 50 13 16 13 21 21 4 38 50 13 16 13 21 22 0 0 0 0 2 255 111 2 196 0 145 3 175 0 17 0 41 0 47 0 184 0 0 47 184 0 9 220 184 0 6 220 184 0 12 208 184 0 33 220 184 0 26 220 184 0 38 208 184 0 21 220 184 0 29 208 184 0 33 16 184 0 41 208 48 49 17 34 46 2 39 55 30 1 51 50 54 55 23 14 3 39 62 1 51 50 30 2 51 50 54 55 23 14 1 35 34 46 2 35 34 6 7 35 51 35 19 3 46 5 46 46 46 46 5 46 3 19 35 51 180 2 36 41 24 34 29 26 15 18 17 3 45 2 36 41 24 34 29 26 15 18 17 3 2 196 17 30 38 21 8 27 42 42 27 8 21 38 30 17 143 39 53 16 18 16 24 22 5 38 53 16 18 16 24 23 0 0 0 0 2 255 127 2 58 0 129 3 36 0 7 0 25 0 43 0 186 0 7 0 2 0 3 43 184 0 7 16 184 0 1 220 184 0 4 208 184 0 2 16 184 0 8 220 184 0 17 220 184 0 13 220 184 0 21 208 48 49 3 39 55 51 23 7 39 35 55 34 46 2 39 55 30 1 51 50 54 55 23 14 3 98 31 95 68 95 31 96 4 2 31 45 31 16 3 38 6 40 42 42 40 6 38 3 16 31 45 2 58 24 83 83 24 62 73 15 26 31 17 10 22 32 32 22 10 17 31 26 15 0 0 0 2 255 119 2 187 0 137 3 175 0 7 0 21 0 56 0 184 0 0 69 88 184 0 0 47 27 185 0 0 0 19 62 89 184 0 7 220 184 0 2 220 184 0 0 16 184 0 5 208 184 0 2 16 184 0 8 220 184 0 15 220 184 0 12 220 184 0 18 208 48 49 3 39 55 51 23 7 39 35 55 34 38 39 55 30 1 51 50 54 55 23 14 1 95 33 92 72 92 33 93 4 2 66 66 5 46 5 42 44 44 42 5 46 5 66 2 187 26 87 87 26 69 73 56 38 8 23 33 33 23 8 38 56 0 0 0 2 255 123 2 89 0 133 3 75 0 3 0 7 0 23 0 186 0 5 0 4 0 3 43 184 0 5 16 184 0 0 220 184 0 2 220 48 49 3 39 55 23 7 53 33 21 34 32 135 38 240 1 10 2 193 39 99 49 193 57 57 0 0 0 2 255 122 2 223 0 134 3 200 0 3 0 7 0 32 0 184 0 0 69 88 184 0 4 47 27 185 0 4 0 19 62 89 184 0 5 220 184 0 0 220 184 0 2 220 48 49 3 39 55 23 7 53 33 21 18 31 121 39 245 1 12 3 59 38 103 48 185 57 57 0 0 2 255 104 2 47 0 122 3 2 0 14 0 18 0 44 0 184 0 18 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 14 220 184 0 9 220 184 0 8 220 184 0 18 16 184 0 16 220 48 49 3 46 3 53 52 54 55 23 6 21 20 22 31 1 55 23 7 55 18 35 27 17 70 59 4 73 26 20 51 43 74 67 2 65 4 14 22 32 22 41 42 2 51 4 39 20 22 5 46 201 14 197 0 2 255 94 2 47 0 108 3 2 0 14 0 18 0 44 0 184 0 15 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 14 220 184 0 9 220 184 0 8 220 184 0 15 16 184 0 17 220 48 49 3 46 3 53 52 54 55 23 6 21 20 22 31 1 39 55 23 65 18 35 27 17 70 59 4 73 26 20 115 64 75 38 2 65 4 14 22 32 22 41 42 2 51 4 39 20 22 5 56 197 14 201 0 2 255 115 2 50 0 141 3 39 0 13 0 37 0 47 0 184 0 0 47 184 0 13 220 184 0 7 220 184 0 6 220 184 0 29 220 184 0 22 220 184 0 34 208 184 0 17 220 184 0 25 208 184 0 29 16 184 0 37 208 48 49 19 46 1 53 52 54 55 23 14 1 21 20 22 23 39 62 1 51 50 30 2 51 50 54 55 23 14 1 35 34 46 2 35 34 6 7 27 36 58 63 59 7 37 32 24 18 176 4 35 37 22 34 29 27 14 15 14 4 47 4 35 37 22 34 29 27 14 15 14 4 2 50 7 34 31 30 29 2 39 2 15 14 11 14 5 124 38 50 13 16 13 21 21 4 38 50 13 16 13 21 21 0 2 255 100 2 47 0 128 3 2 0 14 0 18 0 44 0 184 0 18 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 1 220 184 0 6 220 184 0 7 220 184 0 18 16 184 0 16 220 48 49 3 39 62 1 53 52 39 55 30 1 21 20 14 2 23 55 23 7 120 10 20 27 73 4 59 70 17 27 35 114 42 74 66 2 65 38 5 22 20 39 4 51 2 42 41 22 32 22 14 12 201 14 197 0 0 0 0 2 255 100 2 47 0 115 3 2 0 14 0 18 0 44 0 184 0 15 47 184 0 0 69 88 184 0 0 47 27 185 0 0 0 13 62 89 184 0 1 220 184 0 6 220 184 0 7 220 184 0 15 16 184 0 17 220 48 49 3 39 62 1 53 52 39 55 30 1 21 20 14 2 23 39 55 23 120 10 20 27 73 4 59 70 17 27 35 167 63 74 39 2 65 38 5 22 20 39 4 51 2 42 41 22 32 22 14 22 197 14 201 0 0 0 0 2 255 115 2 50 0 141 3 39 0 23 0 37 0 47 0 184 0 24 47 184 0 25 220 184 0 31 220 184 0 32 220 184 0 15 220 184 0 8 220 184 0 20 208 184 0 3 220 184 0 11 208 184 0 15 16 184 0 23 208 48 49 3 62 1 51 50 30 2 51 50 54 55 23 14 1 35 34 46 2 35 34 6 7 23 39 62 1 53 52 38 39 55 30 1 21 20 6 141 4 35 37 22 34 29 27 14 15 14 4 47 4 35 37 22 34 29 27 14 15 14 4 67 8 18 24 32 37 7 59 63 58 2 207 38 50 13 16 13 21 21 4 38 50 13 16 13 21 21 153 33 5 14 11 14 15 2 39 2 29 30 31 34 255 255 0 30 0 0 1 235 2 212 0 38 0 33 0 0 0 7 0 36 1 54 0 0 255 255 0 30 255 244 1 252 2 212 0 38 0 33 0 0 0 7 0 39 1 36 0 0 0 0 0 36 1 182 0 1 0 0 0 0 0 0 0 112 0 0 0 1 0 0 0 0 0 1 0 15 0 112 0 1 0 0 0 0 0 2 0 7 0 127 0 1 0 0 0 0 0 3 0 38 0 134 0 1 0 0 0 0 0 4 0 15 0 112 0 1 0 0 0 0 0 5 0 58 0 172 0 1 0 0 0 0 0 6 0 21 0 230 0 1 0 0 0 0 0 7 0 96 0 251 0 1 0 0 0 0 0 8 0 26 1 91 0 1 0 0 0 0 0 9 0 12 1 117 0 1 0 0 0 0 0 11 0 25 1 129 0 1 0 0 0 0 0 13 1 144 1 154 0 1 0 0 0 0 0 14 0 26 3 42 0 1 0 0 0 0 1 0 0 12 3 68 0 1 0 0 0 0 1 1 0 10 3 80 0 1 0 0 0 0 1 2 0 11 3 90 0 1 0 0 0 0 1 3 0 11 3 101 0 1 0 0 0 0 1 4 0 9 3 112 0 3 0 1 4 9 0 0 0 224 3 121 0 3 0 1 4 9 0 1 0 30 4 89 0 3 0 1 4 9 0 2 0 14 4 119 0 3 0 1 4 9 0 3 0 76 4 133 0 3 0 1 4 9 0 4 0 30 4 89 0 3 0 1 4 9 0 5 0 116 4 209 0 3 0 1 4 9 0 6 0 42 5 69 0 3 0 1 4 9 0 7 0 192 5 111 0 3 0 1 4 9 0 8 0 52 6 47 0 3 0 1 4 9 0 9 0 24 6 99 0 3 0 1 4 9 0 11 0 50 6 123 0 3 0 1 4 9 0 13 3 32 6 173 0 3 0 1 4 9 0 14 0 52 9 205 0 3 0 1 4 9 1 0 0 24 10 1 0 3 0 1 4 9 1 1 0 20 10 25 0 3 0 1 4 9 1 2 0 22 10 45 0 3 0 1 4 9 1 3 0 22 10 67 0 3 0 1 4 9 1 4 0 18 10 89 67 111 112 121 114 105 103 104 116 32 50 48 49 48 44 32 50 48 49 50 44 32 50 48 49 52 32 65 100 111 98 101 32 83 121 115 116 101 109 115 32 73 110 99 111 114 112 111 114 97 116 101 100 32 40 104 116 116 112 58 47 47 119 119 119 46 97 100 111 98 101 46 99 111 109 47 41 44 32 119 105 116 104 32 82 101 115 101 114 118 101 100 32 70 111 110 116 32 78 97 109 101 32 212 83 111 117 114 99 101 213 46 83 111 117 114 99 101 32 83 97 110 115 32 80 114 111 82 101 103 117 108 97 114 50 46 48 50 48 59 65 68 66 79 59 83 111 117 114 99 101 83 97 110 115 80 114 111 45 82 101 103 117 108 97 114 59 65 68 79 66 69 86 101 114 115 105 111 110 32 50 46 48 50 48 59 80 83 32 50 46 48 48 48 59 104 111 116 99 111 110 118 32 49 46 48 46 56 54 59 109 97 107 101 111 116 102 46 108 105 98 50 46 53 46 54 51 52 48 54 83 111 117 114 99 101 83 97 110 115 80 114 111 45 82 101 103 117 108 97 114 83 111 117 114 99 101 32 105 115 32 97 32 116 114 97 100 101 109 97 114 107 32 111 102 32 65 100 111 98 101 32 83 121 115 116 101 109 115 32 73 110 99 111 114 112 111 114 97 116 101 100 32 105 110 32 116 104 101 32 85 110 105 116 101 100 32 83 116 97 116 101 115 32 97 110 100 47 111 114 32 111 116 104 101 114 32 99 111 117 110 116 114 105 101 115 46 65 100 111 98 101 32 83 121 115 116 101 109 115 32 73 110 99 111 114 112 111 114 97 116 101 100 80 97 117 108 32 68 46 32 72 117 110 116 104 116 116 112 58 47 47 119 119 119 46 97 100 111 98 101 46 99 111 109 47 116 121 112 101 84 104 105 115 32 70 111 110 116 32 83 111 102 116 119 97 114 101 32 105 115 32 108 105 99 101 110 115 101 100 32 117 110 100 101 114 32 116 104 101 32 83 73 76 32 79 112 101 110 32 70 111 110 116 32 76 105 99 101 110 115 101 44 32 86 101 114 115 105 111 110 32 49 46 49 46 32 84 104 105 115 32 108 105 99 101 110 115 101 32 105 115 32 97 118 97 105 108 97 98 108 101 32 119 105 116 104 32 97 32 70 65 81 32 97 116 58 32 104 116 116 112 58 47 47 115 99 114 105 112 116 115 46 115 105 108 46 111 114 103 47 79 70 76 46 32 84 104 105 115 32 70 111 110 116 32 83 111 102 116 119 97 114 101 32 105 115 32 100 105 115 116 114 105 98 117 116 101 100 32 111 110 32 97 110 32 212 65 83 32 73 83 213 32 66 65 83 73 83 44 32 87 73 84 72 79 85 84 32 87 65 82 82 65 78 84 73 69 83 32 79 82 32 67 79 78 68 73 84 73 79 78 83 32 79 70 32 65 78 89 32 75 73 78 68 44 32 101 105 116 104 101 114 32 101 120 112 114 101 115 115 32 111 114 32 105 109 112 108 105 101 100 46 32 83 101 101 32 116 104 101 32 83 73 76 32 79 112 101 110 32 70 111 110 116 32 76 105 99 101 110 115 101 32 102 111 114 32 116 104 101 32 115 112 101 99 105 102 105 99 32 108 97 110 103 117 97 103 101 44 32 112 101 114 109 105 115 115 105 111 110 115 32 97 110 100 32 108 105 109 105 116 97 116 105 111 110 115 32 103 111 118 101 114 110 105 110 103 32 121 111 117 114 32 117 115 101 32 111 102 32 116 104 105 115 32 70 111 110 116 32 83 111 102 116 119 97 114 101 46 104 116 116 112 58 47 47 115 99 114 105 112 116 115 46 115 105 108 46 111 114 103 47 79 70 76 83 108 97 115 104 101 100 32 122 101 114 111 83 116 114 97 105 103 104 116 32 108 65 108 116 101 114 110 97 116 101 32 97 65 108 116 101 114 110 97 116 101 32 103 83 101 114 105 102 101 100 32 73 0 67 0 111 0 112 0 121 0 114 0 105 0 103 0 104 0 116 0 32 0 50 0 48 0 49 0 48 0 44 0 32 0 50 0 48 0 49 0 50 0 44 0 32 0 50 0 48 0 49 0 52 0 32 0 65 0 100 0 111 0 98 0 101 0 32 0 83 0 121 0 115 0 116 0 101 0 109 0 115 0 32 0 73 0 110 0 99 0 111 0 114 0 112 0 111 0 114 0 97 0 116 0 101 0 100 0 32 0 40 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 119 0 119 0 119 0 46 0 97 0 100 0 111 0 98 0 101 0 46 0 99 0 111 0 109 0 47 0 41 0 44 0 32 0 119 0 105 0 116 0 104 0 32 0 82 0 101 0 115 0 101 0 114 0 118 0 101 0 100 0 32 0 70 0 111 0 110 0 116 0 32 0 78 0 97 0 109 0 101 0 32 32 24 0 83 0 111 0 117 0 114 0 99 0 101 32 25 0 46 0 83 0 111 0 117 0 114 0 99 0 101 0 32 0 83 0 97 0 110 0 115 0 32 0 80 0 114 0 111 0 82 0 101 0 103 0 117 0 108 0 97 0 114 0 50 0 46 0 48 0 50 0 48 0 59 0 65 0 68 0 66 0 79 0 59 0 83 0 111 0 117 0 114 0 99 0 101 0 83 0 97 0 110 0 115 0 80 0 114 0 111 0 45 0 82 0 101 0 103 0 117 0 108 0 97 0 114 0 59 0 65 0 68 0 79 0 66 0 69 0 86 0 101 0 114 0 115 0 105 0 111 0 110 0 32 0 50 0 46 0 48 0 50 0 48 0 59 0 80 0 83 0 32 0 50 0 46 0 48 0 48 0 48 0 59 0 104 0 111 0 116 0 99 0 111 0 110 0 118 0 32 0 49 0 46 0 48 0 46 0 56 0 54 0 59 0 109 0 97 0 107 0 101 0 111 0 116 0 102 0 46 0 108 0 105 0 98 0 50 0 46 0 53 0 46 0 54 0 51 0 52 0 48 0 54 0 83 0 111 0 117 0 114 0 99 0 101 0 83 0 97 0 110 0 115 0 80 0 114 0 111 0 45 0 82 0 101 0 103 0 117 0 108 0 97 0 114 0 83 0 111 0 117 0 114 0 99 0 101 0 32 0 105 0 115 0 32 0 97 0 32 0 116 0 114 0 97 0 100 0 101 0 109 0 97 0 114 0 107 0 32 0 111 0 102 0 32 0 65 0 100 0 111 0 98 0 101 0 32 0 83 0 121 0 115 0 116 0 101 0 109 0 115 0 32 0 73 0 110 0 99 0 111 0 114 0 112 0 111 0 114 0 97 0 116 0 101 0 100 0 32 0 105 0 110 0 32 0 116 0 104 0 101 0 32 0 85 0 110 0 105 0 116 0 101 0 100 0 32 0 83 0 116 0 97 0 116 0 101 0 115 0 32 0 97 0 110 0 100 0 47 0 111 0 114 0 32 0 111 0 116 0 104 0 101 0 114 0 32 0 99 0 111 0 117 0 110 0 116 0 114 0 105 0 101 0 115 0 46 0 65 0 100 0 111 0 98 0 101 0 32 0 83 0 121 0 115 0 116 0 101 0 109 0 115 0 32 0 73 0 110 0 99 0 111 0 114 0 112 0 111 0 114 0 97 0 116 0 101 0 100 0 80 0 97 0 117 0 108 0 32 0 68 0 46 0 32 0 72 0 117 0 110 0 116 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 119 0 119 0 119 0 46 0 97 0 100 0 111 0 98 0 101 0 46 0 99 0 111 0 109 0 47 0 116 0 121 0 112 0 101 0 84 0 104 0 105 0 115 0 32 0 70 0 111 0 110 0 116 0 32 0 83 0 111 0 102 0 116 0 119 0 97 0 114 0 101 0 32 0 105 0 115 0 32 0 108 0 105 0 99 0 101 0 110 0 115 0 101 0 100 0 32 0 117 0 110 0 100 0 101 0 114 0 32 0 116 0 104 0 101 0 32 0 83 0 73 0 76 0 32 0 79 0 112 0 101 0 110 0 32 0 70 0 111 0 110 0 116 0 32 0 76 0 105 0 99 0 101 0 110 0 115 0 101 0 44 0 32 0 86 0 101 0 114 0 115 0 105 0 111 0 110 0 32 0 49 0 46 0 49 0 46 0 32 0 84 0 104 0 105 0 115 0 32 0 108 0 105 0 99 0 101 0 110 0 115 0 101 0 32 0 105 0 115 0 32 0 97 0 118 0 97 0 105 0 108 0 97 0 98 0 108 0 101 0 32 0 119 0 105 0 116 0 104 0 32 0 97 0 32 0 70 0 65 0 81 0 32 0 97 0 116 0 58 0 32 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 115 0 99 0 114 0 105 0 112 0 116 0 115 0 46 0 115 0 105 0 108 0 46 0 111 0 114 0 103 0 47 0 79 0 70 0 76 0 46 0 32 0 84 0 104 0 105 0 115 0 32 0 70 0 111 0 110 0 116 0 32 0 83 0 111 0 102 0 116 0 119 0 97 0 114 0 101 0 32 0 105 0 115 0 32 0 100 0 105 0 115 0 116 0 114 0 105 0 98 0 117 0 116 0 101 0 100 0 32 0 111 0 110 0 32 0 97 0 110 0 32 32 24 0 65 0 83 0 32 0 73 0 83 32 25 0 32 0 66 0 65 0 83 0 73 0 83 0 44 0 32 0 87 0 73 0 84 0 72 0 79 0 85 0 84 0 32 0 87 0 65 0 82 0 82 0 65 0 78 0 84 0 73 0 69 0 83 0 32 0 79 0 82 0 32 0 67 0 79 0 78 0 68 0 73 0 84 0 73 0 79 0 78 0 83 0 32 0 79 0 70 0 32 0 65 0 78 0 89 0 32 0 75 0 73 0 78 0 68 0 44 0 32 0 101 0 105 0 116 0 104 0 101 0 114 0 32 0 101 0 120 0 112 0 114 0 101 0 115 0 115 0 32 0 111 0 114 0 32 0 105 0 109 0 112 0 108 0 105 0 101 0 100 0 46 0 32 0 83 0 101 0 101 0 32 0 116 0 104 0 101 0 32 0 83 0 73 0 76 0 32 0 79 0 112 0 101 0 110 0 32 0 70 0 111 0 110 0 116 0 32 0 76 0 105 0 99 0 101 0 110 0 115 0 101 0 32 0 102 0 111 0 114 0 32 0 116 0 104 0 101 0 32 0 115 0 112 0 101 0 99 0 105 0 102 0 105 0 99 0 32 0 108 0 97 0 110 0 103 0 117 0 97 0 103 0 101 0 44 0 32 0 112 0 101 0 114 0 109 0 105 0 115 0 115 0 105 0 111 0 110 0 115 0 32 0 97 0 110 0 100 0 32 0 108 0 105 0 109 0 105 0 116 0 97 0 116 0 105 0 111 0 110 0 115 0 32 0 103 0 111 0 118 0 101 0 114 0 110 0 105 0 110 0 103 0 32 0 121 0 111 0 117 0 114 0 32 0 117 0 115 0 101 0 32 0 111 0 102 0 32 0 116 0 104 0 105 0 115 0 32 0 70 0 111 0 110 0 116 0 32 0 83 0 111 0 102 0 116 0 119 0 97 0 114 0 101 0 46 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 115 0 99 0 114 0 105 0 112 0 116 0 115 0 46 0 115 0 105 0 108 0 46 0 111 0 114 0 103 0 47 0 79 0 70 0 76 0 83 0 108 0 97 0 115 0 104 0 101 0 100 0 32 0 122 0 101 0 114 0 111 0 83 0 116 0 114 0 97 0 105 0 103 0 104 0 116 0 32 0 108 0 65 0 108 0 116 0 101 0 114 0 110 0 97 0 116 0 101 0 32 0 97 0 65 0 108 0 116 0 101 0 114 0 110 0 97 0 116 0 101 0 32 0 103 0 83 0 101 0 114 0 105 0 102 0 101 0 100 0 32 0 73 0 0 0 0 2 0 0 0 0 0 0 255 181 0 50 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 150 0 0 0 3 0 36 0 37 0 38 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 47 0 48 0 49 0 50 0 51 0 52 0 53 0 54 0 55 0 56 0 57 0 58 0 59 0 60 0 61 0 68 0 69 0 70 0 71 0 72 0 73 0 74 0 75 0 76 0 77 0 78 0 79 0 80 0 81 0 82 0 83 0 84 0 85 0 86 0 87 0 88 0 89 0 90 0 91 0 92 0 93 0 173 0 201 0 199 0 174 0 98 1 2 1 3 0 99 1 4 1 5 1 6 1 7 1 8 1 9 1 10 1 11 1 12 1 13 1 14 1 15 1 16 1 17 0 144 1 18 1 19 1 20 1 21 0 100 0 253 1 22 0 255 1 23 1 24 1 25 1 26 1 27 0 203 0 101 0 200 1 28 0 202 1 29 1 30 1 31 1 32 1 33 1 34 1 35 1 36 1 37 1 38 1 39 1 40 1 41 1 42 1 43 0 248 1 44 1 45 1 46 1 47 1 48 1 49 1 50 1 51 1 52 1 53 0 207 0 204 0 205 1 54 0 206 1 55 0 250 1 56 1 57 1 58 1 59 1 60 1 61 1 62 1 63 1 64 1 65 1 66 1 67 1 68 1 69 1 70 1 71 0 226 1 72 1 73 1 74 1 75 1 76 1 77 0 102 1 78 1 79 1 80 1 81 0 211 0 208 0 209 0 175 0 103 1 82 1 83 1 84 1 85 1 86 1 87 1 88 1 89 1 90 1 91 1 92 1 93 0 145 0 176 1 94 1 95 1 96 1 97 1 98 1 99 1 100 1 101 1 102 1 103 1 104 1 105 1 106 1 107 1 108 1 109 0 228 1 110 1 111 1 112 1 113 1 114 1 115 1 116 1 117 1 118 1 119 1 120 0 214 0 212 0 213 1 121 0 104 1 122 1 123 1 124 1 125 1 126 1 127 1 128 1 129 1 130 1 131 1 132 1 133 1 134 1 135 1 136 1 137 1 138 1 139 1 140 1 141 1 142 1 143 1 144 0 235 1 145 0 187 1 146 1 147 1 148 1 149 1 150 0 230 1 151 1 152 1 153 0 233 0 237 1 154 1 155 1 156 0 106 0 105 0 107 0 109 0 108 1 157 1 158 0 110 1 159 1 160 1 161 1 162 1 163 1 164 1 165 1 166 1 167 1 168 1 169 1 170 1 171 1 172 0 160 1 173 1 174 1 175 1 176 0 111 0 254 1 177 1 0 1 178 1 179 1 180 1 181 1 1 0 113 0 112 0 114 1 182 0 115 1 183 1 184 1 185 1 186 1 187 1 188 1 189 1 190 1 191 1 192 1 193 1 194 1 195 1 196 1 197 0 249 1 198 1 199 1 200 1 201 1 202 1 203 1 204 1 205 1 206 1 207 0 117 0 116 0 118 1 208 0 119 1 209 1 210 1 211 1 212 1 213 1 214 1 215 0 215 1 216 1 217 1 218 1 219 1 220 1 221 1 222 1 223 1 224 1 225 1 226 1 227 0 227 1 228 1 229 1 230 1 231 1 232 1 233 0 120 1 234 1 235 1 236 1 237 1 238 0 122 0 121 0 123 0 125 0 124 1 239 1 240 1 241 1 242 1 243 1 244 1 245 1 246 1 247 1 248 1 249 1 250 0 161 0 177 1 251 1 252 1 253 1 254 1 255 2 0 2 1 2 2 2 3 2 4 2 5 2 6 2 7 2 8 2 9 2 10 0 229 2 11 2 12 2 13 2 14 0 137 2 15 2 16 2 17 2 18 2 19 2 20 2 21 0 127 0 126 0 128 2 22 0 129 2 23 2 24 2 25 2 26 2 27 2 28 2 29 2 30 2 31 2 32 2 33 2 34 2 35 2 36 2 37 2 38 2 39 2 40 2 41 2 42 2 43 2 44 2 45 0 236 2 46 0 186 2 47 2 48 2 49 2 50 2 51 0 231 2 52 2 53 2 54 0 234 0 238 2 55 2 56 2 57 2 58 2 59 2 60 2 61 2 62 2 63 2 64 2 65 2 66 2 67 2 68 2 69 2 70 2 71 2 72 2 73 2 74 2 75 2 76 2 77 2 78 2 79 2 80 2 81 2 82 2 83 2 84 2 85 2 86 2 87 2 88 2 89 2 90 2 91 2 92 2 93 2 94 2 95 2 96 2 97 2 98 2 99 2 100 2 101 2 102 2 103 2 104 2 105 2 106 2 107 2 108 2 109 2 110 2 111 2 112 2 113 2 114 2 115 2 116 2 117 2 118 2 119 2 120 2 121 2 122 2 123 2 124 2 125 2 126 2 127 2 128 2 129 2 130 2 131 2 132 2 133 2 134 2 135 2 136 2 137 2 138 2 139 2 140 2 141 2 142 2 143 2 144 2 145 2 146 2 147 2 148 2 149 2 150 2 151 2 152 2 153 2 154 2 155 2 156 2 157 2 158 2 159 2 160 2 161 2 162 2 163 2 164 2 165 2 166 2 167 2 168 2 169 2 170 2 171 2 172 2 173 2 174 2 175 2 176 2 177 2 178 2 179 2 180 2 181 2 182 2 183 2 184 2 185 2 186 2 187 2 188 2 189 2 190 2 191 2 192 2 193 2 194 2 195 2 196 2 197 2 198 2 199 2 200 2 201 2 202 2 203 2 204 2 205 2 206 2 207 2 208 2 209 2 210 2 211 2 212 2 213 2 214 2 215 2 216 2 217 2 218 2 219 2 220 2 221 2 222 2 223 2 224 2 225 2 226 2 227 2 228 2 229 2 230 2 231 2 232 2 233 2 234 0 155 2 235 2 236 2 237 2 238 2 239 2 240 2 241 2 242 2 243 2 244 2 245 2 246 2 247 2 248 2 249 2 250 2 251 2 252 2 253 2 254 2 255 3 0 3 1 3 2 3 3 3 4 3 5 3 6 3 7 3 8 3 9 3 10 3 11 3 12 3 13 3 14 3 15 3 16 3 17 3 18 3 19 3 20 3 21 3 22 3 23 3 24 3 25 3 26 3 27 3 28 3 29 3 30 3 31 3 32 3 33 3 34 3 35 3 36 3 37 3 38 3 39 3 40 3 41 3 42 3 43 3 44 3 45 3 46 3 47 3 48 3 49 3 50 3 51 3 52 3 53 3 54 3 55 3 56 3 57 3 58 3 59 3 60 3 61 3 62 3 63 3 64 3 65 3 66 3 67 3 68 3 69 3 70 3 71 3 72 3 73 3 74 3 75 3 76 3 77 3 78 3 79 3 80 3 81 3 82 3 83 3 84 3 85 3 86 3 87 3 88 3 89 3 90 3 91 3 92 3 93 3 94 3 95 3 96 3 97 3 98 3 99 3 100 3 101 3 102 3 103 3 104 3 105 3 106 3 107 3 108 3 109 3 110 3 111 3 112 3 113 3 114 3 115 3 116 3 117 3 118 3 119 3 120 3 121 3 122 3 123 3 124 3 125 3 126 3 127 3 128 3 129 3 130 3 131 3 132 3 133 3 134 3 135 3 136 3 137 3 138 3 139 3 140 3 141 3 142 3 143 3 144 3 145 3 146 3 147 3 148 3 149 3 150 3 151 3 152 3 153 3 154 3 155 3 156 3 157 3 158 3 159 3 160 3 161 3 162 3 163 3 164 3 165 3 166 3 167 3 168 3 169 3 170 3 171 3 172 3 173 3 174 3 175 3 176 3 177 3 178 3 179 3 180 3 181 3 182 3 183 3 184 3 185 3 186 3 187 3 188 3 189 3 190 3 191 3 192 3 193 3 194 3 195 3 196 3 197 3 198 3 199 3 200 3 201 3 202 3 203 3 204 3 205 3 206 3 207 3 208 3 209 3 210 3 211 3 212 3 213 3 214 3 215 3 216 3 217 3 218 3 219 3 220 3 221 3 222 3 223 3 224 3 225 3 226 3 227 3 228 3 229 3 230 3 231 3 232 3 233 3 234 3 235 3 236 3 237 3 238 3 239 3 240 3 241 3 242 3 243 3 244 3 245 3 246 3 247 3 248 3 249 3 250 3 251 3 252 3 253 3 254 3 255 4 0 4 1 4 2 4 3 4 4 4 5 4 6 4 7 4 8 4 9 4 10 4 11 4 12 4 13 4 14 4 15 4 16 4 17 4 18 4 19 4 20 4 21 4 22 4 23 4 24 4 25 4 26 4 27 4 28 4 29 4 30 4 31 4 32 4 33 4 34 4 35 4 36 4 37 4 38 4 39 4 40 4 41 4 42 4 43 4 44 4 45 4 46 4 47 4 48 4 49 4 50 4 51 4 52 4 53 4 54 4 55 4 56 4 57 4 58 4 59 4 60 4 61 4 62 4 63 4 64 4 65 4 66 4 67 4 68 4 69 4 70 4 71 4 72 4 73 4 74 4 75 4 76 4 77 4 78 4 79 4 80 4 81 4 82 4 83 4 84 4 85 4 86 4 87 4 88 4 89 4 90 4 91 4 92 4 93 4 94 4 95 4 96 4 97 4 98 4 99 4 100 4 101 4 102 4 103 4 104 4 105 4 106 4 107 4 108 4 109 4 110 4 111 4 112 4 113 4 114 4 115 4 116 4 117 4 118 4 119 4 120 4 121 4 122 4 123 4 124 4 125 4 126 4 127 4 128 4 129 4 130 4 131 4 132 4 133 4 134 4 135 4 136 4 137 4 138 4 139 4 140 4 141 4 142 4 143 4 144 4 145 4 146 4 147 4 148 4 149 4 150 4 151 4 152 4 153 4 154 4 155 4 156 4 157 4 158 4 159 4 160 4 161 4 162 4 163 4 164 4 165 4 166 4 167 4 168 4 169 4 170 4 171 4 172 4 173 4 174 4 175 4 176 4 177 4 178 4 179 4 180 4 181 4 182 4 183 4 184 0 9 0 19 0 20 0 21 0 22 0 23 0 24 0 25 0 26 0 27 0 28 4 185 4 186 4 187 4 188 4 189 4 190 4 191 4 192 4 193 4 194 4 195 4 196 4 197 4 198 4 199 4 200 4 201 4 202 4 203 4 204 4 205 4 206 4 207 4 208 4 209 4 210 4 211 4 212 4 213 4 214 4 215 4 216 4 217 4 218 4 219 4 220 4 221 4 222 4 223 4 224 4 225 4 226 4 227 4 228 0 17 0 15 0 29 0 30 0 171 0 4 0 163 0 34 0 162 0 10 0 5 0 182 0 183 0 180 0 181 0 196 0 197 0 190 0 191 0 169 0 170 0 16 4 229 0 178 0 179 4 230 4 231 4 232 4 233 0 195 0 135 0 66 4 234 4 235 0 11 0 12 0 62 0 64 0 94 0 96 0 18 0 95 0 63 0 232 0 13 0 130 0 194 0 134 0 136 4 236 4 237 4 238 4 239 4 240 4 241 4 242 4 243 4 244 4 245 4 246 4 247 4 248 4 249 4 250 4 251 0 139 4 252 0 138 0 140 4 253 4 254 4 255 0 35 5 0 0 6 5 1 5 2 5 3 5 4 5 5 5 6 5 7 5 8 5 9 5 10 5 11 5 12 5 13 5 14 5 15 5 16 5 17 5 18 5 19 5 20 5 21 5 22 5 23 5 24 5 25 5 26 5 27 5 28 5 29 5 30 5 31 5 32 5 33 5 34 5 35 5 36 5 37 5 38 5 39 5 40 5 41 5 42 5 43 5 44 5 45 5 46 5 47 5 48 5 49 5 50 5 51 5 52 5 53 5 54 5 55 5 56 5 57 5 58 5 59 5 60 5 61 5 62 5 63 5 64 5 65 5 66 5 67 5 68 5 69 5 70 5 71 5 72 5 73 5 74 5 75 5 76 5 77 5 78 5 79 5 80 5 81 5 82 5 83 5 84 5 85 5 86 5 87 5 88 5 89 5 90 5 91 5 92 5 93 5 94 5 95 5 96 5 97 5 98 5 99 5 100 5 101 5 102 5 103 5 104 5 105 5 106 5 107 5 108 5 109 5 110 5 111 5 112 5 113 5 114 5 115 5 116 5 117 5 118 5 119 5 120 5 121 5 122 5 123 5 124 5 125 5 126 5 127 5 128 5 129 5 130 5 131 5 132 5 133 5 134 5 135 5 136 5 137 5 138 5 139 5 140 5 141 5 142 5 143 5 144 5 145 5 146 5 147 5 148 5 149 5 150 5 151 5 152 5 153 5 154 5 155 5 156 5 157 5 158 5 159 5 160 5 161 5 162 5 163 5 164 5 165 5 166 5 167 5 168 5 169 5 170 5 171 5 172 5 173 5 174 5 175 5 176 5 177 5 178 5 179 5 180 5 181 5 182 5 183 5 184 5 185 5 186 5 187 5 188 5 189 5 190 5 191 5 192 5 193 5 194 5 195 5 196 5 197 5 198 5 199 5 200 5 201 5 202 5 203 5 204 5 205 5 206 5 207 5 208 5 209 5 210 5 211 5 212 5 213 5 214 5 215 5 216 5 217 5 218 5 219 5 220 5 221 5 222 5 223 5 224 5 225 5 226 5 227 5 228 5 229 5 230 5 231 5 232 5 233 5 234 5 235 5 236 5 237 5 238 5 239 5 240 5 241 5 242 5 243 5 244 5 245 5 246 5 247 5 248 5 249 5 250 5 251 5 252 5 253 5 254 5 255 6 0 6 1 6 2 6 3 6 4 6 5 6 6 6 7 6 8 6 9 6 10 6 11 6 12 6 13 6 14 6 15 6 16 6 17 6 18 6 19 6 20 6 21 6 22 6 23 6 24 6 25 6 26 6 27 6 28 6 29 6 30 6 31 6 32 6 33 6 34 6 35 6 36 6 37 6 38 6 39 6 40 6 41 6 42 6 43 6 44 6 45 6 46 6 47 6 48 6 49 6 50 6 51 6 52 6 53 6 54 6 55 6 56 6 57 6 58 6 59 6 60 6 61 6 62 6 63 6 64 6 65 6 66 6 67 6 68 6 69 6 70 6 71 6 72 6 73 6 74 6 75 6 76 6 77 6 78 6 79 6 80 6 81 6 82 6 83 6 84 6 85 6 86 6 87 6 88 6 89 6 90 6 91 6 92 6 93 6 94 6 95 6 96 6 97 6 98 6 99 6 100 6 101 6 102 6 103 6 104 6 105 6 106 6 107 6 108 6 109 6 110 6 111 6 112 6 113 6 114 6 115 6 116 6 117 6 118 6 119 6 120 6 121 6 122 6 123 6 124 6 125 6 126 6 127 6 128 6 129 6 130 6 131 6 132 6 133 6 134 6 135 6 136 6 137 6 138 6 139 6 140 6 141 6 142 6 143 6 144 6 145 6 146 6 147 6 148 6 149 6 150 6 151 6 152 6 153 6 154 6 155 6 156 6 157 6 158 0 157 6 159 0 158 6 160 6 161 6 162 6 163 6 164 6 165 6 166 6 167 6 168 6 169 6 170 6 171 6 172 6 173 6 174 6 175 6 176 6 177 6 178 6 179 6 180 6 181 6 182 6 183 6 184 6 185 6 186 6 187 6 188 6 189 6 190 6 191 6 192 6 193 6 194 6 195 6 196 6 197 6 198 6 199 6 200 6 201 6 202 6 203 6 204 6 205 6 206 6 207 6 208 6 209 6 210 6 211 6 212 6 213 6 214 6 215 6 216 6 217 6 218 6 219 6 220 6 221 6 222 6 223 6 224 6 225 6 226 0 131 0 189 0 7 0 133 0 150 6 227 6 228 0 132 6 229 6 230 6 231 6 232 6 233 6 234 6 235 6 236 6 237 6 238 6 239 6 240 6 241 6 242 6 243 6 244 0 188 6 245 6 246 0 8 0 198 0 245 0 244 0 246 6 247 6 248 6 249 6 250 6 251 6 252 6 253 6 254 6 255 7 0 7 1 7 2 7 3 7 4 7 5 7 6 0 14 0 239 0 240 0 184 7 7 0 32 0 31 0 33 0 148 0 149 0 147 0 65 0 143 0 97 0 167 0 164 0 146 7 8 0 152 0 156 0 165 7 9 7 10 0 153 0 154 7 11 7 12 7 13 7 14 7 15 7 16 7 17 7 18 7 19 7 20 7 21 7 22 7 23 7 24 7 25 7 26 7 27 7 28 7 29 7 30 7 31 7 32 0 185 7 33 7 34 7 35 7 36 7 37 7 38 7 39 7 40 0 67 0 141 0 216 0 225 7 41 7 42 7 43 7 44 7 45 0 217 0 142 0 218 0 219 0 221 0 223 0 220 0 222 0 224 7 46 7 47 7 48 7 49 7 50 7 51 7 52 7 53 7 54 7 55 7 56 7 57 7 58 7 59 7 60 7 61 7 62 7 63 7 64 7 65 7 66 7 67 7 68 7 69 7 70 7 71 7 72 7 73 7 74 7 75 7 76 7 77 7 78 7 79 7 80 7 81 7 82 7 83 7 84 7 85 7 86 7 87 7 88 7 89 7 90 7 91 7 92 7 93 7 94 7 95 7 96 7 97 7 98 7 99 7 100 7 101 7 102 7 103 7 104 7 105 7 106 7 107 7 108 7 109 7 110 7 111 7 112 7 113 7 114 7 115 7 116 7 117 7 118 7 119 7 120 7 121 7 122 7 123 7 124 7 125 7 126 7 127 7 128 7 129 7 130 7 131 7 132 7 133 7 134 7 135 7 136 7 137 7 138 7 139 7 140 7 141 7 142 7 143 7 144 7 145 7 146 7 147 7 148 7 149 7 150 7 151 7 152 7 153 7 154 7 155 7 156 7 157 7 158 7 159 7 160 7 161 7 162 7 163 0 192 0 193 7 65 109 97 99 114 111 110 6 65 98 114 101 118 101 7 117 110 105 48 49 67 68 7 117 110 105 49 69 65 48 7 117 110 105 49 69 65 50 7 117 110 105 49 69 65 52 7 117 110 105 49 69 65 54 7 117 110 105 49 69 65 56 7 117 110 105 49 69 65 65 7 117 110 105 49 69 65 67 7 117 110 105 49 69 65 69 7 117 110 105 49 69 66 48 7 117 110 105 49 69 66 50 7 117 110 105 49 69 66 52 7 117 110 105 49 69 66 54 7 65 111 103 111 110 101 107 7 117 110 105 48 49 70 67 7 117 110 105 48 49 69 50 7 117 110 105 48 50 52 51 7 117 110 105 49 69 48 54 11 67 99 105 114 99 117 109 102 108 101 120 10 67 100 111 116 97 99 99 101 110 116 6 68 99 97 114 111 110 7 117 110 105 49 69 48 67 7 117 110 105 49 69 48 69 6 68 99 114 111 97 116 6 69 99 97 114 111 110 7 69 109 97 99 114 111 110 6 69 98 114 101 118 101 10 69 100 111 116 97 99 99 101 110 116 7 117 110 105 49 69 66 56 7 117 110 105 49 69 66 65 7 117 110 105 49 69 66 67 7 117 110 105 49 69 66 69 7 117 110 105 49 69 67 48 7 117 110 105 49 69 67 50 7 117 110 105 49 69 67 52 7 117 110 105 49 69 67 54 7 69 111 103 111 110 101 107 7 117 110 105 49 69 49 54 7 117 110 105 48 49 70 52 11 71 99 105 114 99 117 109 102 108 101 120 10 71 100 111 116 97 99 99 101 110 116 7 117 110 105 48 49 50 50 6 71 99 97 114 111 110 7 117 110 105 49 69 50 48 11 117 110 105 48 48 52 55 48 51 48 51 7 117 110 105 48 49 57 51 11 72 99 105 114 99 117 109 102 108 101 120 7 117 110 105 49 69 50 52 7 117 110 105 49 69 50 65 4 72 98 97 114 6 73 116 105 108 100 101 7 73 109 97 99 114 111 110 7 117 110 105 48 49 67 70 7 117 110 105 49 69 67 56 7 117 110 105 49 69 67 65 7 73 111 103 111 110 101 107 7 117 110 105 48 49 50 67 11 74 99 105 114 99 117 109 102 108 101 120 7 117 110 105 48 49 51 54 7 117 110 105 49 69 51 50 7 117 110 105 49 69 51 52 6 76 97 99 117 116 101 6 76 99 97 114 111 110 7 117 110 105 48 49 51 66 4 76 100 111 116 7 117 110 105 49 69 51 54 7 117 110 105 49 69 51 56 7 117 110 105 49 69 51 65 7 117 110 105 49 69 51 69 7 117 110 105 49 69 52 48 7 117 110 105 49 69 52 50 6 78 97 99 117 116 101 7 117 110 105 48 49 70 56 6 78 99 97 114 111 110 7 117 110 105 48 49 52 53 7 117 110 105 49 69 52 52 7 117 110 105 49 69 52 54 7 117 110 105 49 69 52 56 7 79 109 97 99 114 111 110 13 79 104 117 110 103 97 114 117 109 108 97 117 116 7 117 110 105 48 49 68 49 7 117 110 105 49 69 67 67 7 117 110 105 49 69 67 69 7 117 110 105 49 69 68 48 7 117 110 105 49 69 68 50 7 117 110 105 49 69 68 52 7 117 110 105 49 69 68 54 7 117 110 105 49 69 68 56 7 117 110 105 48 49 52 69 7 117 110 105 49 69 53 50 5 79 104 111 114 110 7 117 110 105 49 69 68 65 7 117 110 105 49 69 68 67 7 117 110 105 49 69 68 69 7 117 110 105 49 69 69 48 7 117 110 105 49 69 69 50 7 117 110 105 48 49 69 65 6 82 97 99 117 116 101 6 82 99 97 114 111 110 7 117 110 105 49 69 53 56 7 117 110 105 48 49 53 54 7 117 110 105 49 69 53 65 7 117 110 105 49 69 53 67 7 117 110 105 49 69 53 69 6 83 97 99 117 116 101 11 83 99 105 114 99 117 109 102 108 101 120 7 117 110 105 48 49 53 69 7 117 110 105 48 50 49 56 7 117 110 105 49 69 54 48 7 117 110 105 49 69 54 50 7 117 110 105 49 69 57 69 6 84 99 97 114 111 110 7 117 110 105 48 49 54 50 7 117 110 105 48 50 49 65 7 117 110 105 49 69 54 67 7 117 110 105 49 69 54 69 7 117 110 105 48 49 54 54 6 85 116 105 108 100 101 7 85 109 97 99 114 111 110 6 85 98 114 101 118 101 5 85 114 105 110 103 13 85 104 117 110 103 97 114 117 109 108 97 117 116 7 117 110 105 48 49 68 51 7 117 110 105 48 49 68 53 7 117 110 105 48 49 68 55 7 117 110 105 48 49 68 57 7 117 110 105 48 49 68 66 7 117 110 105 49 69 69 52 7 117 110 105 49 69 69 54 7 85 111 103 111 110 101 107 5 85 104 111 114 110 7 117 110 105 49 69 69 56 7 117 110 105 49 69 69 65 7 117 110 105 49 69 69 67 7 117 110 105 49 69 69 69 7 117 110 105 49 69 70 48 6 87 103 114 97 118 101 6 87 97 99 117 116 101 11 87 99 105 114 99 117 109 102 108 101 120 9 87 100 105 101 114 101 115 105 115 6 89 103 114 97 118 101 11 89 99 105 114 99 117 109 102 108 101 120 7 117 110 105 49 69 56 69 7 117 110 105 49 69 70 52 7 117 110 105 49 69 70 54 7 117 110 105 49 69 70 56 6 90 97 99 117 116 101 10 90 100 111 116 97 99 99 101 110 116 7 117 110 105 49 69 57 50 7 117 110 105 49 69 57 52 7 117 110 105 48 49 56 70 7 117 110 105 48 49 52 65 7 117 110 105 48 49 51 50 7 97 109 97 99 114 111 110 6 97 98 114 101 118 101 7 117 110 105 48 49 67 69 7 117 110 105 49 69 65 49 7 117 110 105 49 69 65 51 7 117 110 105 49 69 65 53 7 117 110 105 49 69 65 55 7 117 110 105 49 69 65 57 7 117 110 105 49 69 65 66 7 117 110 105 49 69 65 68 7 117 110 105 49 69 65 70 7 117 110 105 49 69 66 49 7 117 110 105 49 69 66 51 7 117 110 105 49 69 66 53 7 117 110 105 49 69 66 55 7 97 111 103 111 110 101 107 7 117 110 105 48 49 70 68 7 117 110 105 48 49 69 51 7 117 110 105 48 49 56 48 7 117 110 105 49 69 48 55 11 99 99 105 114 99 117 109 102 108 101 120 10 99 100 111 116 97 99 99 101 110 116 6 100 99 97 114 111 110 7 117 110 105 49 69 48 68 7 117 110 105 49 69 48 70 6 101 99 97 114 111 110 7 101 109 97 99 114 111 110 6 101 98 114 101 118 101 10 101 100 111 116 97 99 99 101 110 116 7 117 110 105 49 69 66 57 7 117 110 105 49 69 66 66 7 117 110 105 49 69 66 68 7 117 110 105 49 69 66 70 7 117 110 105 49 69 67 49 7 117 110 105 49 69 67 51 7 117 110 105 49 69 67 53 7 117 110 105 49 69 67 55 7 101 111 103 111 110 101 107 7 117 110 105 49 69 49 55 7 117 110 105 48 49 70 53 11 103 99 105 114 99 117 109 102 108 101 120 10 103 100 111 116 97 99 99 101 110 116 7 117 110 105 48 49 50 51 6 103 99 97 114 111 110 7 117 110 105 49 69 50 49 11 117 110 105 48 48 54 55 48 51 48 51 11 104 99 105 114 99 117 109 102 108 101 120 7 117 110 105 49 69 50 53 7 117 110 105 49 69 57 54 7 117 110 105 49 69 50 66 4 104 98 97 114 6 105 116 105 108 100 101 7 105 109 97 99 114 111 110 7 117 110 105 48 49 68 48 7 117 110 105 49 69 67 57 7 117 110 105 49 69 67 66 7 105 111 103 111 110 101 107 9 105 111 103 111 110 101 107 46 100 7 117 110 105 48 49 50 68 11 106 99 105 114 99 117 109 102 108 101 120 7 117 110 105 48 49 51 55 7 117 110 105 49 69 51 51 7 117 110 105 49 69 51 53 12 107 103 114 101 101 110 108 97 110 100 105 99 6 108 97 99 117 116 101 6 108 99 97 114 111 110 4 108 100 111 116 7 117 110 105 48 49 51 67 7 117 110 105 49 69 51 55 7 117 110 105 49 69 51 57 7 117 110 105 49 69 51 66 7 117 110 105 49 69 51 70 7 117 110 105 49 69 52 49 7 117 110 105 49 69 52 51 6 110 97 99 117 116 101 7 117 110 105 48 49 70 57 6 110 99 97 114 111 110 7 117 110 105 48 49 52 54 7 117 110 105 49 69 52 53 7 117 110 105 49 69 52 55 7 117 110 105 49 69 52 57 11 110 97 112 111 115 116 114 111 112 104 101 7 111 109 97 99 114 111 110 13 111 104 117 110 103 97 114 117 109 108 97 117 116 7 117 110 105 48 49 68 50 7 117 110 105 49 69 67 68 7 117 110 105 49 69 67 70 7 117 110 105 49 69 68 49 7 117 110 105 49 69 68 51 7 117 110 105 49 69 68 53 7 117 110 105 49 69 68 55 7 117 110 105 49 69 68 57 7 117 110 105 48 49 52 70 7 117 110 105 49 69 53 51 5 111 104 111 114 110 7 117 110 105 49 69 68 66 7 117 110 105 49 69 68 68 7 117 110 105 49 69 68 70 7 117 110 105 49 69 69 49 7 117 110 105 49 69 69 51 7 117 110 105 48 49 69 66 6 114 97 99 117 116 101 7 117 110 105 48 49 53 55 6 114 99 97 114 111 110 7 117 110 105 49 69 53 57 7 117 110 105 49 69 53 66 7 117 110 105 49 69 53 68 7 117 110 105 49 69 53 70 6 115 97 99 117 116 101 11 115 99 105 114 99 117 109 102 108 101 120 7 117 110 105 48 49 53 70 7 117 110 105 48 50 49 57 7 117 110 105 49 69 54 49 7 117 110 105 49 69 54 51 6 116 99 97 114 111 110 7 117 110 105 48 49 54 51 7 117 110 105 48 50 49 66 7 117 110 105 49 69 54 68 7 117 110 105 49 69 54 70 7 117 110 105 49 69 57 55 7 117 110 105 48 49 54 55 6 117 116 105 108 100 101 7 117 109 97 99 114 111 110 6 117 98 114 101 118 101 5 117 114 105 110 103 13 117 104 117 110 103 97 114 117 109 108 97 117 116 7 117 110 105 48 49 68 52 7 117 110 105 48 49 68 54 7 117 110 105 48 49 68 56 7 117 110 105 48 49 68 65 7 117 110 105 48 49 68 67 7 117 110 105 49 69 69 53 7 117 110 105 49 69 69 55 7 117 111 103 111 110 101 107 5 117 104 111 114 110 7 117 110 105 49 69 69 57 7 117 110 105 49 69 69 66 7 117 110 105 49 69 69 68 7 117 110 105 49 69 69 70 7 117 110 105 49 69 70 49 6 119 103 114 97 118 101 6 119 97 99 117 116 101 11 119 99 105 114 99 117 109 102 108 101 120 9 119 100 105 101 114 101 115 105 115 6 121 103 114 97 118 101 11 121 99 105 114 99 117 109 102 108 101 120 7 117 110 105 49 69 56 70 7 117 110 105 49 69 70 53 7 117 110 105 49 69 70 55 7 117 110 105 49 69 70 57 6 122 97 99 117 116 101 10 122 100 111 116 97 99 99 101 110 116 7 117 110 105 49 69 57 51 7 117 110 105 49 69 57 53 7 117 110 105 48 49 52 66 7 117 110 105 48 50 51 55 7 117 110 105 48 49 51 51 7 117 110 105 48 50 53 48 7 117 110 105 48 50 53 50 7 117 110 105 48 50 53 51 7 117 110 105 48 50 53 52 7 117 110 105 48 50 53 53 7 117 110 105 48 50 53 54 7 117 110 105 48 50 53 55 7 117 110 105 48 50 53 56 7 117 110 105 48 50 53 49 7 117 110 105 48 50 57 57 7 117 110 105 48 50 53 57 7 117 110 105 48 50 53 65 7 117 110 105 48 50 53 66 7 117 110 105 48 50 53 67 7 117 110 105 48 50 53 69 7 117 110 105 48 50 53 70 7 117 110 105 48 50 54 48 7 117 110 105 48 50 54 49 7 117 110 105 48 50 54 50 7 117 110 105 48 50 54 51 7 117 110 105 48 50 54 52 7 117 110 105 48 50 54 53 7 117 110 105 48 50 54 54 7 117 110 105 48 50 54 55 7 117 110 105 48 50 57 67 7 117 110 105 48 50 54 56 7 117 110 105 48 50 54 65 7 117 110 105 48 50 57 68 7 117 110 105 48 50 54 67 7 117 110 105 48 50 54 68 7 117 110 105 48 50 54 69 7 117 110 105 48 50 57 70 7 117 110 105 48 50 54 70 7 117 110 105 48 50 55 48 7 117 110 105 48 50 55 49 7 117 110 105 48 50 55 50 7 117 110 105 48 50 55 51 7 117 110 105 48 50 55 52 7 117 110 105 48 50 55 53 7 117 110 105 48 50 55 54 7 117 110 105 48 50 55 56 7 117 110 105 48 50 55 57 7 117 110 105 48 50 55 65 7 117 110 105 48 50 55 66 7 117 110 105 48 50 55 68 7 117 110 105 48 50 55 69 7 117 110 105 48 50 56 48 7 117 110 105 48 50 56 49 7 117 110 105 48 50 56 50 7 117 110 105 48 50 56 51 7 117 110 105 48 50 56 52 7 117 110 105 48 50 56 56 7 117 110 105 48 50 56 57 7 117 110 105 48 50 56 65 7 117 110 105 48 50 56 66 7 117 110 105 48 50 56 67 7 117 110 105 48 50 56 68 7 117 110 105 48 50 56 69 7 117 110 105 48 50 56 70 7 117 110 105 48 50 57 48 7 117 110 105 48 50 57 49 7 117 110 105 48 50 57 50 7 117 110 105 48 50 57 52 7 117 110 105 48 50 57 53 7 117 110 105 48 50 65 49 7 117 110 105 48 50 65 50 7 117 110 105 48 49 67 50 7 117 110 105 48 50 57 56 3 102 95 102 5 102 95 102 95 105 5 102 95 102 95 108 3 102 95 116 5 102 95 102 95 116 3 73 46 97 8 73 103 114 97 118 101 46 97 8 73 97 99 117 116 101 46 97 13 73 99 105 114 99 117 109 102 108 101 120 46 97 8 73 116 105 108 100 101 46 97 11 73 100 105 101 114 101 115 105 115 46 97 9 73 109 97 99 114 111 110 46 97 12 73 100 111 116 97 99 99 101 110 116 46 97 9 117 110 105 48 49 67 70 46 97 9 117 110 105 49 69 67 56 46 97 9 117 110 105 49 69 67 65 46 97 9 73 111 103 111 110 101 107 46 97 9 117 110 105 48 49 50 67 46 97 9 117 110 105 48 49 52 65 46 97 3 97 46 97 8 97 103 114 97 118 101 46 97 8 97 97 99 117 116 101 46 97 13 97 99 105 114 99 117 109 102 108 101 120 46 97 8 97 116 105 108 100 101 46 97 11 97 100 105 101 114 101 115 105 115 46 97 9 97 109 97 99 114 111 110 46 97 8 97 98 114 101 118 101 46 97 7 97 114 105 110 103 46 97 9 117 110 105 48 49 67 69 46 97 9 117 110 105 49 69 65 49 46 97 9 117 110 105 49 69 65 51 46 97 9 117 110 105 49 69 65 53 46 97 9 117 110 105 49 69 65 55 46 97 9 117 110 105 49 69 65 57 46 97 9 117 110 105 49 69 65 66 46 97 9 117 110 105 49 69 65 68 46 97 9 117 110 105 49 69 65 70 46 97 9 117 110 105 49 69 66 49 46 97 9 117 110 105 49 69 66 51 46 97 9 117 110 105 49 69 66 53 46 97 9 117 110 105 49 69 66 55 46 97 9 97 111 103 111 110 101 107 46 97 3 103 46 97 9 117 110 105 48 49 70 53 46 97 13 103 99 105 114 99 117 109 102 108 101 120 46 97 8 103 98 114 101 118 101 46 97 12 103 100 111 116 97 99 99 101 110 116 46 97 9 117 110 105 48 49 50 51 46 97 8 103 99 97 114 111 110 46 97 9 117 110 105 49 69 50 49 46 97 13 117 110 105 48 48 54 55 48 51 48 51 46 97 3 108 46 97 8 108 97 99 117 116 101 46 97 8 108 99 97 114 111 110 46 97 6 108 100 111 116 46 97 9 117 110 105 48 49 51 67 46 97 9 117 110 105 49 69 51 55 46 97 9 117 110 105 49 69 51 57 46 97 9 117 110 105 49 69 51 66 46 97 8 108 115 108 97 115 104 46 97 4 102 108 46 97 5 65 108 112 104 97 4 66 101 116 97 5 71 97 109 109 97 7 117 110 105 48 51 57 52 7 69 112 115 105 108 111 110 4 90 101 116 97 3 69 116 97 5 84 104 101 116 97 4 73 111 116 97 5 75 97 112 112 97 6 76 97 109 98 100 97 2 77 117 2 78 117 2 88 105 7 79 109 105 99 114 111 110 2 80 105 3 82 104 111 5 83 105 103 109 97 3 84 97 117 7 85 112 115 105 108 111 110 3 80 104 105 3 67 104 105 3 80 115 105 7 117 110 105 48 51 65 57 10 65 108 112 104 97 116 111 110 111 115 12 69 112 115 105 108 111 110 116 111 110 111 115 8 69 116 97 116 111 110 111 115 9 73 111 116 97 116 111 110 111 115 12 73 111 116 97 100 105 101 114 101 115 105 115 12 79 109 105 99 114 111 110 116 111 110 111 115 12 85 112 115 105 108 111 110 116 111 110 111 115 15 85 112 115 105 108 111 110 100 105 101 114 101 115 105 115 10 79 109 101 103 97 116 111 110 111 115 5 97 108 112 104 97 4 98 101 116 97 5 103 97 109 109 97 5 100 101 108 116 97 7 101 112 115 105 108 111 110 4 122 101 116 97 3 101 116 97 5 116 104 101 116 97 4 105 111 116 97 5 107 97 112 112 97 6 108 97 109 98 100 97 7 117 110 105 48 51 66 67 2 110 117 2 120 105 7 111 109 105 99 114 111 110 3 114 104 111 5 115 105 103 109 97 3 116 97 117 7 117 112 115 105 108 111 110 3 112 104 105 3 99 104 105 3 112 115 105 5 111 109 101 103 97 7 117 110 105 48 51 67 50 7 117 110 105 48 51 68 48 7 117 110 105 48 51 68 49 7 117 110 105 48 51 68 53 10 97 108 112 104 97 116 111 110 111 115 12 101 112 115 105 108 111 110 116 111 110 111 115 8 101 116 97 116 111 110 111 115 9 105 111 116 97 116 111 110 111 115 12 105 111 116 97 100 105 101 114 101 115 105 115 12 111 109 105 99 114 111 110 116 111 110 111 115 12 117 112 115 105 108 111 110 116 111 110 111 115 15 117 112 115 105 108 111 110 100 105 101 114 101 115 105 115 10 111 109 101 103 97 116 111 110 111 115 17 105 111 116 97 100 105 101 114 101 115 105 115 116 111 110 111 115 20 117 112 115 105 108 111 110 100 105 101 114 101 115 105 115 116 111 110 111 115 7 117 110 105 49 70 48 56 7 117 110 105 49 70 48 57 7 117 110 105 49 70 66 65 7 117 110 105 49 70 66 66 7 117 110 105 49 70 48 65 7 117 110 105 49 70 48 66 7 117 110 105 49 70 48 67 7 117 110 105 49 70 48 68 7 117 110 105 49 70 48 69 7 117 110 105 49 70 48 70 7 117 110 105 49 70 66 56 7 117 110 105 49 70 66 57 7 117 110 105 49 70 49 56 7 117 110 105 49 70 49 57 7 117 110 105 49 70 67 56 7 117 110 105 49 70 67 57 7 117 110 105 49 70 49 65 7 117 110 105 49 70 49 66 7 117 110 105 49 70 49 67 7 117 110 105 49 70 49 68 7 117 110 105 49 70 50 56 7 117 110 105 49 70 50 57 7 117 110 105 49 70 67 65 7 117 110 105 49 70 67 66 7 117 110 105 49 70 50 65 7 117 110 105 49 70 50 66 7 117 110 105 49 70 50 67 7 117 110 105 49 70 50 68 7 117 110 105 49 70 50 69 7 117 110 105 49 70 50 70 7 117 110 105 49 70 51 56 7 117 110 105 49 70 51 57 7 117 110 105 49 70 68 65 7 117 110 105 49 70 68 66 7 117 110 105 49 70 51 65 7 117 110 105 49 70 51 66 7 117 110 105 49 70 51 67 7 117 110 105 49 70 51 68 7 117 110 105 49 70 51 69 7 117 110 105 49 70 51 70 7 117 110 105 49 70 68 56 7 117 110 105 49 70 68 57 7 117 110 105 49 70 52 56 7 117 110 105 49 70 52 57 7 117 110 105 49 70 70 56 7 117 110 105 49 70 70 57 7 117 110 105 49 70 52 65 7 117 110 105 49 70 52 66 7 117 110 105 49 70 52 67 7 117 110 105 49 70 52 68 7 117 110 105 49 70 69 67 7 117 110 105 49 70 53 57 7 117 110 105 49 70 69 65 7 117 110 105 49 70 69 66 7 117 110 105 49 70 53 66 7 117 110 105 49 70 53 68 7 117 110 105 49 70 53 70 7 117 110 105 49 70 69 56 7 117 110 105 49 70 69 57 7 117 110 105 49 70 54 56 7 117 110 105 49 70 54 57 7 117 110 105 49 70 70 65 7 117 110 105 49 70 70 66 7 117 110 105 49 70 54 65 7 117 110 105 49 70 54 66 7 117 110 105 49 70 54 67 7 117 110 105 49 70 54 68 7 117 110 105 49 70 54 69 7 117 110 105 49 70 54 70 7 117 110 105 49 70 66 67 7 117 110 105 49 70 56 56 7 117 110 105 49 70 56 57 7 117 110 105 49 70 56 65 7 117 110 105 49 70 56 66 7 117 110 105 49 70 56 67 7 117 110 105 49 70 56 68 7 117 110 105 49 70 56 69 7 117 110 105 49 70 56 70 7 117 110 105 49 70 67 67 7 117 110 105 49 70 57 56 7 117 110 105 49 70 57 57 7 117 110 105 49 70 57 65 7 117 110 105 49 70 57 66 7 117 110 105 49 70 57 67 7 117 110 105 49 70 57 68 7 117 110 105 49 70 57 69 7 117 110 105 49 70 57 70 7 117 110 105 49 70 70 67 7 117 110 105 49 70 65 56 7 117 110 105 49 70 65 57 7 117 110 105 49 70 65 65 7 117 110 105 49 70 65 66 7 117 110 105 49 70 65 67 7 117 110 105 49 70 65 68 7 117 110 105 49 70 65 69 7 117 110 105 49 70 65 70 7 117 110 105 49 70 48 48 7 117 110 105 49 70 48 49 7 117 110 105 49 70 55 48 7 117 110 105 49 70 55 49 7 117 110 105 49 70 48 50 7 117 110 105 49 70 48 51 7 117 110 105 49 70 48 52 7 117 110 105 49 70 48 53 7 117 110 105 49 70 48 54 7 117 110 105 49 70 48 55 7 117 110 105 49 70 66 48 7 117 110 105 49 70 66 49 7 117 110 105 49 70 66 54 7 117 110 105 49 70 49 48 7 117 110 105 49 70 49 49 7 117 110 105 49 70 55 50 7 117 110 105 49 70 55 51 7 117 110 105 49 70 49 50 7 117 110 105 49 70 49 51 7 117 110 105 49 70 49 52 7 117 110 105 49 70 49 53 7 117 110 105 49 70 50 48 7 117 110 105 49 70 50 49 7 117 110 105 49 70 55 52 7 117 110 105 49 70 55 53 7 117 110 105 49 70 50 50 7 117 110 105 49 70 50 51 7 117 110 105 49 70 50 52 7 117 110 105 49 70 50 53 7 117 110 105 49 70 50 54 7 117 110 105 49 70 50 55 7 117 110 105 49 70 67 54 7 117 110 105 49 70 51 48 7 117 110 105 49 70 51 49 7 117 110 105 49 70 55 54 7 117 110 105 49 70 55 55 7 117 110 105 49 70 51 50 7 117 110 105 49 70 51 51 7 117 110 105 49 70 51 52 7 117 110 105 49 70 51 53 7 117 110 105 49 70 51 54 7 117 110 105 49 70 51 55 7 117 110 105 49 70 68 48 7 117 110 105 49 70 68 49 7 117 110 105 49 70 68 54 7 117 110 105 49 70 68 50 7 117 110 105 49 70 68 51 7 117 110 105 49 70 68 55 7 117 110 105 49 70 52 48 7 117 110 105 49 70 52 49 7 117 110 105 49 70 55 56 7 117 110 105 49 70 55 57 7 117 110 105 49 70 52 50 7 117 110 105 49 70 52 51 7 117 110 105 49 70 52 52 7 117 110 105 49 70 52 53 7 117 110 105 49 70 69 52 7 117 110 105 49 70 69 53 7 117 110 105 49 70 53 48 7 117 110 105 49 70 53 49 7 117 110 105 49 70 55 65 7 117 110 105 49 70 55 66 7 117 110 105 49 70 53 50 7 117 110 105 49 70 53 51 7 117 110 105 49 70 53 52 7 117 110 105 49 70 53 53 7 117 110 105 49 70 53 54 7 117 110 105 49 70 53 55 7 117 110 105 49 70 69 54 7 117 110 105 49 70 69 48 7 117 110 105 49 70 69 49 7 117 110 105 49 70 69 50 7 117 110 105 49 70 69 51 7 117 110 105 49 70 69 55 7 117 110 105 49 70 54 48 7 117 110 105 49 70 54 49 7 117 110 105 49 70 55 67 7 117 110 105 49 70 55 68 7 117 110 105 49 70 54 50 7 117 110 105 49 70 54 51 7 117 110 105 49 70 54 52 7 117 110 105 49 70 54 53 7 117 110 105 49 70 54 54 7 117 110 105 49 70 54 55 7 117 110 105 49 70 70 54 7 117 110 105 49 70 66 51 7 117 110 105 49 70 56 48 7 117 110 105 49 70 56 49 7 117 110 105 49 70 66 50 7 117 110 105 49 70 66 52 7 117 110 105 49 70 56 50 7 117 110 105 49 70 56 51 7 117 110 105 49 70 56 52 7 117 110 105 49 70 56 53 7 117 110 105 49 70 56 54 7 117 110 105 49 70 56 55 7 117 110 105 49 70 66 55 7 117 110 105 49 70 67 51 7 117 110 105 49 70 57 48 7 117 110 105 49 70 57 49 7 117 110 105 49 70 67 50 7 117 110 105 49 70 67 52 7 117 110 105 49 70 57 50 7 117 110 105 49 70 57 51 7 117 110 105 49 70 57 52 7 117 110 105 49 70 57 53 7 117 110 105 49 70 57 54 7 117 110 105 49 70 57 55 7 117 110 105 49 70 67 55 7 117 110 105 49 70 70 51 7 117 110 105 49 70 65 48 7 117 110 105 49 70 65 49 7 117 110 105 49 70 70 50 7 117 110 105 49 70 70 52 7 117 110 105 49 70 65 50 7 117 110 105 49 70 65 51 7 117 110 105 49 70 65 52 7 117 110 105 49 70 65 53 7 117 110 105 49 70 65 54 7 117 110 105 49 70 65 55 7 117 110 105 49 70 70 55 7 117 110 105 48 51 68 55 7 117 110 105 48 51 68 57 7 117 110 105 48 51 68 66 7 117 110 105 48 51 68 68 7 117 110 105 48 51 69 49 7 117 110 105 48 51 55 69 9 97 110 111 116 101 108 101 105 97 13 97 110 111 116 101 108 101 105 97 46 99 97 112 7 117 110 105 48 51 55 52 7 117 110 105 48 51 55 53 5 116 111 110 111 115 9 116 111 110 111 115 46 99 97 112 13 100 105 101 114 101 115 105 115 116 111 110 111 115 7 117 110 105 48 51 55 65 7 117 110 105 49 70 66 69 7 117 110 105 49 70 66 68 7 117 110 105 49 70 66 70 7 117 110 105 49 70 70 69 7 117 110 105 49 70 69 70 7 117 110 105 49 70 70 68 7 117 110 105 49 70 67 68 7 117 110 105 49 70 68 68 7 117 110 105 49 70 67 69 7 117 110 105 49 70 68 69 7 117 110 105 49 70 67 70 7 117 110 105 49 70 68 70 7 117 110 105 49 70 67 48 7 117 110 105 49 70 69 68 7 117 110 105 49 70 69 69 7 117 110 105 49 70 67 49 11 117 110 105 49 70 66 68 46 99 97 112 11 117 110 105 49 70 70 69 46 99 97 112 11 117 110 105 49 70 69 70 46 99 97 112 11 117 110 105 49 70 70 68 46 99 97 112 11 117 110 105 49 70 67 68 46 99 97 112 11 117 110 105 49 70 68 68 46 99 97 112 11 117 110 105 49 70 67 69 46 99 97 112 11 117 110 105 49 70 68 69 46 99 97 112 11 117 110 105 49 70 67 70 46 99 97 112 11 117 110 105 49 70 68 70 46 99 97 112 7 117 110 105 48 52 49 48 7 117 110 105 48 52 49 49 7 117 110 105 48 52 49 50 7 117 110 105 48 52 49 51 7 117 110 105 48 52 49 52 7 117 110 105 48 52 49 53 7 117 110 105 48 52 49 54 9 117 110 105 48 52 49 54 46 97 9 117 110 105 48 52 49 54 46 98 7 117 110 105 48 52 49 55 7 117 110 105 48 52 49 56 7 117 110 105 48 52 49 57 7 117 110 105 48 52 49 65 9 117 110 105 48 52 49 65 46 97 9 117 110 105 48 52 49 65 46 98 7 117 110 105 48 52 49 66 7 117 110 105 48 52 49 67 7 117 110 105 48 52 49 68 7 117 110 105 48 52 49 69 7 117 110 105 48 52 49 70 7 117 110 105 48 52 50 48 7 117 110 105 48 52 50 49 7 117 110 105 48 52 50 50 7 117 110 105 48 52 50 51 7 117 110 105 48 52 50 52 7 117 110 105 48 52 50 53 7 117 110 105 48 52 50 54 7 117 110 105 48 52 50 55 7 117 110 105 48 52 50 56 7 117 110 105 48 52 50 57 7 117 110 105 48 52 50 65 7 117 110 105 48 52 50 66 7 117 110 105 48 52 50 67 7 117 110 105 48 52 50 68 7 117 110 105 48 52 50 69 7 117 110 105 48 52 50 70 7 117 110 105 48 52 48 48 7 117 110 105 48 52 48 49 7 117 110 105 48 52 48 50 7 117 110 105 48 52 48 51 7 117 110 105 48 52 48 52 7 117 110 105 48 52 48 53 7 117 110 105 48 52 48 54 7 117 110 105 48 52 48 55 9 117 110 105 48 52 48 55 46 97 7 117 110 105 48 52 48 56 7 117 110 105 48 52 48 57 7 117 110 105 48 52 48 65 7 117 110 105 48 52 48 66 7 117 110 105 48 52 48 67 9 117 110 105 48 52 48 67 46 97 9 117 110 105 48 52 48 67 46 98 7 117 110 105 48 52 48 68 7 117 110 105 48 52 48 69 7 117 110 105 48 52 48 70 7 117 110 105 48 52 54 50 7 117 110 105 48 52 55 50 7 117 110 105 48 52 55 52 7 117 110 105 48 52 57 48 7 117 110 105 48 52 57 50 7 117 110 105 48 52 57 54 9 117 110 105 48 52 57 54 46 97 9 117 110 105 48 52 57 54 46 98 7 117 110 105 48 52 57 56 7 117 110 105 48 52 57 65 9 117 110 105 48 52 57 65 46 97 9 117 110 105 48 52 57 65 46 98 7 117 110 105 48 52 65 48 9 117 110 105 48 52 65 48 46 97 9 117 110 105 48 52 65 48 46 98 7 117 110 105 48 52 65 50 7 117 110 105 48 52 65 65 7 117 110 105 48 52 65 69 7 117 110 105 48 52 66 48 7 117 110 105 48 52 66 50 7 117 110 105 48 52 66 54 7 117 110 105 48 52 66 65 7 117 110 105 48 52 67 48 7 117 110 105 48 52 67 49 9 117 110 105 48 52 67 49 46 97 9 117 110 105 48 52 67 49 46 98 7 117 110 105 48 52 68 48 7 117 110 105 48 52 68 52 7 117 110 105 48 52 68 54 7 117 110 105 48 52 68 56 7 117 110 105 48 52 69 50 7 117 110 105 48 52 69 54 7 117 110 105 48 52 69 56 7 117 110 105 48 52 69 69 7 117 110 105 48 52 70 50 7 117 110 105 48 52 51 48 7 117 110 105 48 52 51 49 7 117 110 105 48 52 51 50 7 117 110 105 48 52 51 51 7 117 110 105 48 52 51 52 7 117 110 105 48 52 51 53 7 117 110 105 48 52 51 54 9 117 110 105 48 52 51 54 46 97 9 117 110 105 48 52 51 54 46 98 7 117 110 105 48 52 51 55 7 117 110 105 48 52 51 56 7 117 110 105 48 52 51 57 7 117 110 105 48 52 51 65 9 117 110 105 48 52 51 65 46 97 9 117 110 105 48 52 51 65 46 98 7 117 110 105 48 52 51 66 7 117 110 105 48 52 51 67 7 117 110 105 48 52 51 68 7 117 110 105 48 52 51 69 7 117 110 105 48 52 51 70 7 117 110 105 48 52 52 48 7 117 110 105 48 52 52 49 7 117 110 105 48 52 52 50 7 117 110 105 48 52 52 51 7 117 110 105 48 52 52 52 7 117 110 105 48 52 52 53 7 117 110 105 48 52 52 54 7 117 110 105 48 52 52 55 7 117 110 105 48 52 52 56 7 117 110 105 48 52 52 57 7 117 110 105 48 52 52 65 7 117 110 105 48 52 52 66 7 117 110 105 48 52 52 67 7 117 110 105 48 52 52 68 7 117 110 105 48 52 52 69 7 117 110 105 48 52 52 70 7 117 110 105 48 52 53 48 7 117 110 105 48 52 53 49 7 117 110 105 48 52 53 50 7 117 110 105 48 52 53 51 7 117 110 105 48 52 53 52 7 117 110 105 48 52 53 53 7 117 110 105 48 52 53 54 7 117 110 105 48 52 53 55 9 117 110 105 48 52 53 55 46 97 7 117 110 105 48 52 53 56 7 117 110 105 48 52 53 57 7 117 110 105 48 52 53 65 7 117 110 105 48 52 53 66 7 117 110 105 48 52 53 67 9 117 110 105 48 52 53 67 46 97 9 117 110 105 48 52 53 67 46 98 7 117 110 105 48 52 53 68 7 117 110 105 48 52 53 69 7 117 110 105 48 52 53 70 7 117 110 105 48 52 54 51 7 117 110 105 48 52 55 51 7 117 110 105 48 52 55 53 7 117 110 105 48 52 57 49 7 117 110 105 48 52 57 51 7 117 110 105 48 52 57 55 9 117 110 105 48 52 57 55 46 97 9 117 110 105 48 52 57 55 46 98 7 117 110 105 48 52 57 57 7 117 110 105 48 52 57 66 9 117 110 105 48 52 57 66 46 97 9 117 110 105 48 52 57 66 46 98 7 117 110 105 48 52 65 49 9 117 110 105 48 52 65 49 46 97 9 117 110 105 48 52 65 49 46 98 7 117 110 105 48 52 65 51 7 117 110 105 48 52 65 66 7 117 110 105 48 52 65 70 7 117 110 105 48 52 66 49 7 117 110 105 48 52 66 51 7 117 110 105 48 52 66 55 7 117 110 105 48 52 66 66 7 117 110 105 48 52 67 50 9 117 110 105 48 52 67 50 46 97 9 117 110 105 48 52 67 50 46 98 7 117 110 105 48 52 67 70 7 117 110 105 48 52 68 49 7 117 110 105 48 52 68 53 7 117 110 105 48 52 68 55 7 117 110 105 48 52 68 57 7 117 110 105 48 52 69 51 7 117 110 105 48 52 69 55 7 117 110 105 48 52 69 57 7 117 110 105 48 52 69 70 7 117 110 105 48 52 70 51 11 117 110 105 48 52 51 49 46 115 114 98 7 117 110 105 50 49 49 54 6 122 101 114 111 46 48 7 122 101 114 111 46 48 115 9 122 101 114 111 46 112 110 117 109 8 111 110 101 46 112 110 117 109 8 116 119 111 46 112 110 117 109 10 116 104 114 101 101 46 112 110 117 109 9 102 111 117 114 46 112 110 117 109 9 102 105 118 101 46 112 110 117 109 8 115 105 120 46 112 110 117 109 10 115 101 118 101 110 46 112 110 117 109 10 101 105 103 104 116 46 112 110 117 109 9 110 105 110 101 46 112 110 117 109 7 122 101 114 111 46 48 112 8 122 101 114 111 46 48 112 115 9 122 101 114 111 46 116 110 117 109 8 111 110 101 46 116 110 117 109 8 116 119 111 46 116 110 117 109 10 116 104 114 101 101 46 116 110 117 109 9 102 111 117 114 46 116 110 117 109 9 102 105 118 101 46 116 110 117 109 8 115 105 120 46 116 110 117 109 10 115 101 118 101 110 46 116 110 117 109 10 101 105 103 104 116 46 116 110 117 109 9 110 105 110 101 46 116 110 117 109 9 122 101 114 111 46 111 110 117 109 8 111 110 101 46 111 110 117 109 8 116 119 111 46 111 110 117 109 10 116 104 114 101 101 46 111 110 117 109 9 102 111 117 114 46 111 110 117 109 9 102 105 118 101 46 111 110 117 109 8 115 105 120 46 111 110 117 109 10 115 101 118 101 110 46 111 110 117 109 10 101 105 103 104 116 46 111 110 117 109 9 110 105 110 101 46 111 110 117 109 8 122 101 114 111 46 99 97 112 7 111 110 101 46 99 97 112 7 116 119 111 46 99 97 112 9 116 104 114 101 101 46 99 97 112 8 102 111 117 114 46 99 97 112 8 102 105 118 101 46 99 97 112 7 115 105 120 46 99 97 112 9 115 101 118 101 110 46 99 97 112 9 101 105 103 104 116 46 99 97 112 8 110 105 110 101 46 99 97 112 7 117 110 105 48 48 65 68 7 117 110 105 50 69 51 65 7 117 110 105 50 69 51 66 10 102 105 103 117 114 101 100 97 115 104 7 117 110 105 50 48 49 53 7 117 110 105 50 48 51 69 7 117 110 105 50 48 51 70 7 117 110 105 50 48 49 54 7 117 110 105 50 48 51 67 7 117 110 105 50 48 52 55 7 117 110 105 50 48 52 57 7 117 110 105 50 48 52 56 7 117 110 105 50 48 51 68 7 117 110 105 50 51 49 67 7 117 110 105 50 51 49 68 7 117 110 105 50 51 49 69 7 117 110 105 50 51 49 70 7 117 110 105 50 55 69 54 7 117 110 105 50 55 69 55 7 117 110 105 50 69 50 50 7 117 110 105 50 69 50 51 7 117 110 105 50 69 50 52 7 117 110 105 50 69 50 53 7 117 110 105 50 49 49 55 7 117 110 105 50 49 50 48 6 117 49 70 49 54 65 6 117 49 70 49 54 66 7 97 116 46 99 97 115 101 5 105 46 116 114 107 4 65 46 115 99 4 66 46 115 99 4 67 46 115 99 4 68 46 115 99 4 69 46 115 99 4 70 46 115 99 4 71 46 115 99 4 72 46 115 99 4 73 46 115 99 4 74 46 115 99 4 75 46 115 99 4 76 46 115 99 4 77 46 115 99 4 78 46 115 99 4 79 46 115 99 4 80 46 115 99 4 81 46 115 99 4 82 46 115 99 4 83 46 115 99 4 84 46 115 99 4 85 46 115 99 4 86 46 115 99 4 87 46 115 99 4 88 46 115 99 4 89 46 115 99 4 90 46 115 99 9 65 103 114 97 118 101 46 115 99 9 65 97 99 117 116 101 46 115 99 14 65 99 105 114 99 117 109 102 108 101 120 46 115 99 9 65 116 105 108 100 101 46 115 99 12 65 100 105 101 114 101 115 105 115 46 115 99 10 65 109 97 99 114 111 110 46 115 99 9 65 98 114 101 118 101 46 115 99 8 65 114 105 110 103 46 115 99 10 117 110 105 48 49 67 68 46 115 99 10 117 110 105 49 69 65 48 46 115 99 10 117 110 105 49 69 65 50 46 115 99 10 117 110 105 49 69 65 52 46 115 99 10 117 110 105 49 69 65 54 46 115 99 10 117 110 105 49 69 65 56 46 115 99 10 117 110 105 49 69 65 65 46 115 99 10 117 110 105 49 69 65 67 46 115 99 10 117 110 105 49 69 65 69 46 115 99 10 117 110 105 49 69 66 48 46 115 99 10 117 110 105 49 69 66 50 46 115 99 10 117 110 105 49 69 66 52 46 115 99 10 117 110 105 49 69 66 54 46 115 99 10 65 111 103 111 110 101 107 46 115 99 5 65 69 46 115 99 10 117 110 105 48 49 70 67 46 115 99 10 117 110 105 48 49 69 50 46 115 99 10 117 110 105 48 50 52 51 46 115 99 10 117 110 105 49 69 48 54 46 115 99 11 67 99 101 100 105 108 108 97 46 115 99 9 67 97 99 117 116 101 46 115 99 14 67 99 105 114 99 117 109 102 108 101 120 46 115 99 9 67 99 97 114 111 110 46 115 99 13 67 100 111 116 97 99 99 101 110 116 46 115 99 9 68 99 97 114 111 110 46 115 99 10 117 110 105 49 69 48 67 46 115 99 10 117 110 105 49 69 48 69 46 115 99 9 68 99 114 111 97 116 46 115 99 9 69 103 114 97 118 101 46 115 99 9 69 97 99 117 116 101 46 115 99 14 69 99 105 114 99 117 109 102 108 101 120 46 115 99 9 69 99 97 114 111 110 46 115 99 12 69 100 105 101 114 101 115 105 115 46 115 99 10 69 109 97 99 114 111 110 46 115 99 9 69 98 114 101 118 101 46 115 99 13 69 100 111 116 97 99 99 101 110 116 46 115 99 10 117 110 105 49 69 66 56 46 115 99 10 117 110 105 49 69 66 65 46 115 99 10 117 110 105 49 69 66 67 46 115 99 10 117 110 105 49 69 66 69 46 115 99 10 117 110 105 49 69 67 48 46 115 99 10 117 110 105 49 69 67 50 46 115 99 10 117 110 105 49 69 67 52 46 115 99 10 117 110 105 49 69 67 54 46 115 99 10 69 111 103 111 110 101 107 46 115 99 10 117 110 105 49 69 49 54 46 115 99 10 117 110 105 48 49 70 52 46 115 99 14 71 99 105 114 99 117 109 102 108 101 120 46 115 99 9 71 98 114 101 118 101 46 115 99 13 71 100 111 116 97 99 99 101 110 116 46 115 99 10 117 110 105 48 49 50 50 46 115 99 9 71 99 97 114 111 110 46 115 99 10 117 110 105 49 69 50 48 46 115 99 14 117 110 105 48 48 52 55 48 51 48 51 46 115 99 10 117 110 105 48 49 57 51 46 115 99 14 72 99 105 114 99 117 109 102 108 101 120 46 115 99 10 117 110 105 49 69 50 52 46 115 99 10 117 110 105 49 69 50 65 46 115 99 7 72 98 97 114 46 115 99 9 73 103 114 97 118 101 46 115 99 9 73 97 99 117 116 101 46 115 99 14 73 99 105 114 99 117 109 102 108 101 120 46 115 99 9 73 116 105 108 100 101 46 115 99 12 73 100 105 101 114 101 115 105 115 46 115 99 10 73 109 97 99 114 111 110 46 115 99 13 73 100 111 116 97 99 99 101 110 116 46 115 99 10 117 110 105 48 49 67 70 46 115 99 10 117 110 105 49 69 67 56 46 115 99 10 117 110 105 49 69 67 65 46 115 99 10 73 111 103 111 110 101 107 46 115 99 10 117 110 105 48 49 50 67 46 115 99 14 74 99 105 114 99 117 109 102 108 101 120 46 115 99 10 117 110 105 48 49 51 54 46 115 99 10 117 110 105 49 69 51 50 46 115 99 10 117 110 105 49 69 51 52 46 115 99 9 76 97 99 117 116 101 46 115 99 9 76 99 97 114 111 110 46 115 99 10 117 110 105 48 49 51 66 46 115 99 7 76 100 111 116 46 115 99 10 117 110 105 49 69 51 54 46 115 99 10 117 110 105 49 69 51 56 46 115 99 10 117 110 105 49 69 51 65 46 115 99 9 76 115 108 97 115 104 46 115 99 10 117 110 105 49 69 51 69 46 115 99 10 117 110 105 49 69 52 48 46 115 99 10 117 110 105 49 69 52 50 46 115 99 9 78 97 99 117 116 101 46 115 99 10 117 110 105 48 49 70 56 46 115 99 9 78 99 97 114 111 110 46 115 99 9 78 116 105 108 100 101 46 115 99 10 117 110 105 48 49 52 53 46 115 99 10 117 110 105 49 69 52 52 46 115 99 10 117 110 105 49 69 52 54 46 115 99 10 117 110 105 49 69 52 56 46 115 99 9 79 103 114 97 118 101 46 115 99 9 79 97 99 117 116 101 46 115 99 14 79 99 105 114 99 117 109 102 108 101 120 46 115 99 9 79 116 105 108 100 101 46 115 99 12 79 100 105 101 114 101 115 105 115 46 115 99 10 79 109 97 99 114 111 110 46 115 99 16 79 104 117 110 103 97 114 117 109 108 97 117 116 46 115 99 10 117 110 105 48 49 68 49 46 115 99 10 117 110 105 49 69 67 67 46 115 99 10 117 110 105 49 69 67 69 46 115 99 10 117 110 105 49 69 68 48 46 115 99 10 117 110 105 49 69 68 50 46 115 99 10 117 110 105 49 69 68 52 46 115 99 10 117 110 105 49 69 68 54 46 115 99 10 117 110 105 49 69 68 56 46 115 99 9 79 115 108 97 115 104 46 115 99 5 79 69 46 115 99 8 79 104 111 114 110 46 115 99 10 117 110 105 49 69 68 65 46 115 99 10 117 110 105 49 69 68 67 46 115 99 10 117 110 105 49 69 68 69 46 115 99 10 117 110 105 49 69 69 48 46 115 99 10 117 110 105 49 69 69 50 46 115 99 10 117 110 105 48 49 69 65 46 115 99 10 117 110 105 48 49 52 69 46 115 99 10 117 110 105 49 69 53 50 46 115 99 9 82 97 99 117 116 101 46 115 99 10 117 110 105 49 69 53 56 46 115 99 9 82 99 97 114 111 110 46 115 99 10 117 110 105 48 49 53 54 46 115 99 10 117 110 105 49 69 53 65 46 115 99 10 117 110 105 49 69 53 67 46 115 99 10 117 110 105 49 69 53 69 46 115 99 9 83 97 99 117 116 101 46 115 99 14 83 99 105 114 99 117 109 102 108 101 120 46 115 99 9 83 99 97 114 111 110 46 115 99 10 117 110 105 48 49 53 69 46 115 99 10 117 110 105 48 50 49 56 46 115 99 10 117 110 105 49 69 54 48 46 115 99 10 117 110 105 49 69 54 50 46 115 99 13 103 101 114 109 97 110 100 98 108 115 46 115 99 10 117 110 105 49 69 57 69 46 115 99 9 84 99 97 114 111 110 46 115 99 10 117 110 105 48 49 54 50 46 115 99 10 117 110 105 48 50 49 65 46 115 99 10 117 110 105 49 69 54 67 46 115 99 10 117 110 105 49 69 54 69 46 115 99 10 117 110 105 48 49 54 54 46 115 99 9 85 103 114 97 118 101 46 115 99 9 85 97 99 117 116 101 46 115 99 14 85 99 105 114 99 117 109 102 108 101 120 46 115 99 9 85 116 105 108 100 101 46 115 99 12 85 100 105 101 114 101 115 105 115 46 115 99 10 85 109 97 99 114 111 110 46 115 99 9 85 98 114 101 118 101 46 115 99 8 85 114 105 110 103 46 115 99 16 85 104 117 110 103 97 114 117 109 108 97 117 116 46 115 99 10 117 110 105 48 49 68 51 46 115 99 10 117 110 105 48 49 68 53 46 115 99 10 117 110 105 48 49 68 55 46 115 99 10 117 110 105 48 49 68 57 46 115 99 10 117 110 105 48 49 68 66 46 115 99 10 117 110 105 49 69 69 52 46 115 99 10 117 110 105 49 69 69 54 46 115 99 10 85 111 103 111 110 101 107 46 115 99 8 85 104 111 114 110 46 115 99 10 117 110 105 49 69 69 56 46 115 99 10 117 110 105 49 69 69 65 46 115 99 10 117 110 105 49 69 69 67 46 115 99 10 117 110 105 49 69 69 69 46 115 99 10 117 110 105 49 69 70 48 46 115 99 9 87 103 114 97 118 101 46 115 99 9 87 97 99 117 116 101 46 115 99 14 87 99 105 114 99 117 109 102 108 101 120 46 115 99 12 87 100 105 101 114 101 115 105 115 46 115 99 9 89 103 114 97 118 101 46 115 99 9 89 97 99 117 116 101 46 115 99 14 89 99 105 114 99 117 109 102 108 101 120 46 115 99 12 89 100 105 101 114 101 115 105 115 46 115 99 10 117 110 105 49 69 56 69 46 115 99 10 117 110 105 49 69 70 52 46 115 99 10 117 110 105 49 69 70 54 46 115 99 10 117 110 105 49 69 70 56 46 115 99 9 90 97 99 117 116 101 46 115 99 9 90 99 97 114 111 110 46 115 99 13 90 100 111 116 97 99 99 101 110 116 46 115 99 10 117 110 105 49 69 57 50 46 115 99 10 117 110 105 49 69 57 52 46 115 99 6 69 116 104 46 115 99 8 84 104 111 114 110 46 115 99 10 117 110 105 48 49 56 70 46 115 99 10 117 110 105 48 49 52 65 46 115 99 10 117 110 105 48 49 51 50 46 115 99 11 117 110 105 48 49 52 65 46 115 99 97 8 65 108 112 104 97 46 115 99 7 66 101 116 97 46 115 99 8 71 97 109 109 97 46 115 99 10 117 110 105 48 51 57 52 46 115 99 10 69 112 115 105 108 111 110 46 115 99 7 90 101 116 97 46 115 99 6 69 116 97 46 115 99 8 84 104 101 116 97 46 115 99 7 73 111 116 97 46 115 99 8 75 97 112 112 97 46 115 99 9 76 97 109 98 100 97 46 115 99 5 77 117 46 115 99 5 78 117 46 115 99 5 88 105 46 115 99 10 79 109 105 99 114 111 110 46 115 99 5 80 105 46 115 99 6 82 104 111 46 115 99 8 83 105 103 109 97 46 115 99 6 84 97 117 46 115 99 10 85 112 115 105 108 111 110 46 115 99 6 80 104 105 46 115 99 6 67 104 105 46 115 99 6 80 115 105 46 115 99 10 117 110 105 48 51 65 57 46 115 99 15 73 111 116 97 100 105 101 114 101 115 105 115 46 115 99 18 85 112 115 105 108 111 110 100 105 101 114 101 115 105 115 46 115 99 15 65 108 112 104 97 105 111 116 97 115 117 98 46 115 99 13 69 116 97 105 111 116 97 115 117 98 46 115 99 15 79 109 101 103 97 105 111 116 97 115 117 98 46 115 99 10 117 110 105 48 52 49 48 46 115 99 10 117 110 105 48 52 49 49 46 115 99 10 117 110 105 48 52 49 50 46 115 99 10 117 110 105 48 52 49 51 46 115 99 10 117 110 105 48 52 49 52 46 115 99 10 117 110 105 48 52 49 53 46 115 99 10 117 110 105 48 52 49 54 46 115 99 10 117 110 105 48 52 49 55 46 115 99 10 117 110 105 48 52 49 56 46 115 99 10 117 110 105 48 52 49 57 46 115 99 10 117 110 105 48 52 49 65 46 115 99 10 117 110 105 48 52 49 66 46 115 99 10 117 110 105 48 52 49 67 46 115 99 10 117 110 105 48 52 49 68 46 115 99 10 117 110 105 48 52 49 69 46 115 99 10 117 110 105 48 52 49 70 46 115 99 10 117 110 105 48 52 50 48 46 115 99 10 117 110 105 48 52 50 49 46 115 99 10 117 110 105 48 52 50 50 46 115 99 10 117 110 105 48 52 50 51 46 115 99 10 117 110 105 48 52 50 52 46 115 99 10 117 110 105 48 52 50 53 46 115 99 10 117 110 105 48 52 50 54 46 115 99 10 117 110 105 48 52 50 55 46 115 99 10 117 110 105 48 52 50 56 46 115 99 10 117 110 105 48 52 50 57 46 115 99 10 117 110 105 48 52 50 65 46 115 99 10 117 110 105 48 52 50 66 46 115 99 10 117 110 105 48 52 50 67 46 115 99 10 117 110 105 48 52 50 68 46 115 99 10 117 110 105 48 52 50 69 46 115 99 10 117 110 105 48 52 50 70 46 115 99 10 117 110 105 48 52 48 48 46 115 99 10 117 110 105 48 52 48 49 46 115 99 10 117 110 105 48 52 48 50 46 115 99 10 117 110 105 48 52 48 51 46 115 99 10 117 110 105 48 52 48 52 46 115 99 10 117 110 105 48 52 48 53 46 115 99 10 117 110 105 48 52 48 54 46 115 99 10 117 110 105 48 52 48 55 46 115 99 11 117 110 105 48 52 48 55 46 115 99 97 10 117 110 105 48 52 48 56 46 115 99 10 117 110 105 48 52 48 57 46 115 99 10 117 110 105 48 52 48 65 46 115 99 10 117 110 105 48 52 48 66 46 115 99 10 117 110 105 48 52 48 67 46 115 99 10 117 110 105 48 52 48 68 46 115 99 10 117 110 105 48 52 48 69 46 115 99 10 117 110 105 48 52 48 70 46 115 99 10 117 110 105 48 52 54 50 46 115 99 10 117 110 105 48 52 55 50 46 115 99 10 117 110 105 48 52 55 52 46 115 99 10 117 110 105 48 52 57 48 46 115 99 10 117 110 105 48 52 57 50 46 115 99 10 117 110 105 48 52 57 54 46 115 99 10 117 110 105 48 52 57 56 46 115 99 10 117 110 105 48 52 57 65 46 115 99 10 117 110 105 48 52 65 48 46 115 99 10 117 110 105 48 52 65 50 46 115 99 10 117 110 105 48 52 65 65 46 115 99 10 117 110 105 48 52 65 69 46 115 99 10 117 110 105 48 52 66 48 46 115 99 10 117 110 105 48 52 66 50 46 115 99 10 117 110 105 48 52 66 54 46 115 99 10 117 110 105 48 52 66 65 46 115 99 10 117 110 105 48 52 67 48 46 115 99 10 117 110 105 48 52 67 49 46 115 99 10 117 110 105 48 52 68 48 46 115 99 10 117 110 105 48 52 68 52 46 115 99 10 117 110 105 48 52 68 54 46 115 99 10 117 110 105 48 52 68 56 46 115 99 10 117 110 105 48 52 69 50 46 115 99 10 117 110 105 48 52 69 54 46 115 99 10 117 110 105 48 52 69 56 46 115 99 10 117 110 105 48 52 69 69 46 115 99 10 117 110 105 48 52 70 50 46 115 99 12 97 109 112 101 114 115 97 110 100 46 115 99 7 122 101 114 111 46 115 99 6 111 110 101 46 115 99 6 116 119 111 46 115 99 8 116 104 114 101 101 46 115 99 7 102 111 117 114 46 115 99 7 102 105 118 101 46 115 99 6 115 105 120 46 115 99 8 115 101 118 101 110 46 115 99 8 101 105 103 104 116 46 115 99 7 110 105 110 101 46 115 99 9 101 120 99 108 97 109 46 115 99 13 101 120 99 108 97 109 100 111 119 110 46 115 99 11 113 117 101 115 116 105 111 110 46 115 99 15 113 117 101 115 116 105 111 110 100 111 119 110 46 115 99 14 113 117 111 116 101 115 105 110 103 108 101 46 115 99 11 113 117 111 116 101 100 98 108 46 115 99 12 113 117 111 116 101 108 101 102 116 46 115 99 13 113 117 111 116 101 114 105 103 104 116 46 115 99 15 113 117 111 116 101 100 98 108 108 101 102 116 46 115 99 16 113 117 111 116 101 100 98 108 114 105 103 104 116 46 115 99 9 104 121 112 104 101 110 46 115 99 9 101 110 100 97 115 104 46 115 99 9 101 109 100 97 115 104 46 115 99 12 112 97 114 101 110 108 101 102 116 46 115 99 13 112 97 114 101 110 114 105 103 104 116 46 115 99 14 98 114 97 99 107 101 116 108 101 102 116 46 115 99 15 98 114 97 99 107 101 116 114 105 103 104 116 46 115 99 12 98 114 97 99 101 108 101 102 116 46 115 99 13 98 114 97 99 101 114 105 103 104 116 46 115 99 9 122 101 114 111 46 115 117 112 115 8 111 110 101 46 115 117 112 115 8 116 119 111 46 115 117 112 115 10 116 104 114 101 101 46 115 117 112 115 9 102 111 117 114 46 115 117 112 115 9 102 105 118 101 46 115 117 112 115 8 115 105 120 46 115 117 112 115 10 115 101 118 101 110 46 115 117 112 115 10 101 105 103 104 116 46 115 117 112 115 9 110 105 110 101 46 115 117 112 115 14 112 97 114 101 110 108 101 102 116 46 115 117 112 115 15 112 97 114 101 110 114 105 103 104 116 46 115 117 112 115 11 112 101 114 105 111 100 46 115 117 112 115 10 99 111 109 109 97 46 115 117 112 115 9 122 101 114 111 46 115 117 98 115 8 111 110 101 46 115 117 98 115 8 116 119 111 46 115 117 98 115 10 116 104 114 101 101 46 115 117 98 115 9 102 111 117 114 46 115 117 98 115 9 102 105 118 101 46 115 117 98 115 8 115 105 120 46 115 117 98 115 10 115 101 118 101 110 46 115 117 98 115 10 101 105 103 104 116 46 115 117 98 115 9 110 105 110 101 46 115 117 98 115 14 112 97 114 101 110 108 101 102 116 46 115 117 98 115 15 112 97 114 101 110 114 105 103 104 116 46 115 117 98 115 11 112 101 114 105 111 100 46 115 117 98 115 10 99 111 109 109 97 46 115 117 98 115 9 122 101 114 111 46 100 110 111 109 8 111 110 101 46 100 110 111 109 8 116 119 111 46 100 110 111 109 10 116 104 114 101 101 46 100 110 111 109 9 102 111 117 114 46 100 110 111 109 9 102 105 118 101 46 100 110 111 109 8 115 105 120 46 100 110 111 109 10 115 101 118 101 110 46 100 110 111 109 10 101 105 103 104 116 46 100 110 111 109 9 110 105 110 101 46 100 110 111 109 14 112 97 114 101 110 108 101 102 116 46 100 110 111 109 15 112 97 114 101 110 114 105 103 104 116 46 100 110 111 109 11 112 101 114 105 111 100 46 100 110 111 109 10 99 111 109 109 97 46 100 110 111 109 9 122 101 114 111 46 110 117 109 114 8 111 110 101 46 110 117 109 114 8 116 119 111 46 110 117 109 114 10 116 104 114 101 101 46 110 117 109 114 9 102 111 117 114 46 110 117 109 114 9 102 105 118 101 46 110 117 109 114 8 115 105 120 46 110 117 109 114 10 115 101 118 101 110 46 110 117 109 114 10 101 105 103 104 116 46 110 117 109 114 9 110 105 110 101 46 110 117 109 114 14 112 97 114 101 110 108 101 102 116 46 110 117 109 114 15 112 97 114 101 110 114 105 103 104 116 46 110 117 109 114 11 112 101 114 105 111 100 46 110 117 109 114 10 99 111 109 109 97 46 110 117 109 114 13 111 114 100 102 101 109 105 110 105 110 101 46 97 6 65 46 115 117 112 115 6 66 46 115 117 112 115 6 67 46 115 117 112 115 6 68 46 115 117 112 115 6 69 46 115 117 112 115 6 70 46 115 117 112 115 6 71 46 115 117 112 115 6 72 46 115 117 112 115 6 73 46 115 117 112 115 6 74 46 115 117 112 115 6 75 46 115 117 112 115 6 76 46 115 117 112 115 6 77 46 115 117 112 115 6 78 46 115 117 112 115 6 79 46 115 117 112 115 6 80 46 115 117 112 115 6 81 46 115 117 112 115 6 82 46 115 117 112 115 6 83 46 115 117 112 115 6 84 46 115 117 112 115 6 85 46 115 117 112 115 6 86 46 115 117 112 115 6 87 46 115 117 112 115 6 88 46 115 117 112 115 6 89 46 115 117 112 115 6 90 46 115 117 112 115 6 97 46 115 117 112 115 6 98 46 115 117 112 115 6 99 46 115 117 112 115 6 100 46 115 117 112 115 6 101 46 115 117 112 115 6 102 46 115 117 112 115 6 103 46 115 117 112 115 6 104 46 115 117 112 115 6 105 46 115 117 112 115 6 106 46 115 117 112 115 6 107 46 115 117 112 115 6 108 46 115 117 112 115 6 109 46 115 117 112 115 6 110 46 115 117 112 115 6 111 46 115 117 112 115 6 112 46 115 117 112 115 6 113 46 115 117 112 115 6 114 46 115 117 112 115 6 115 46 115 117 112 115 6 116 46 115 117 112 115 6 117 46 115 117 112 115 6 118 46 115 117 112 115 6 119 46 115 117 112 115 6 120 46 115 117 112 115 6 121 46 115 117 112 115 6 122 46 115 117 112 115 7 117 110 105 48 50 67 49 7 117 110 105 48 50 68 48 7 117 110 105 48 50 68 49 7 117 110 105 48 50 68 69 7 117 110 105 48 50 69 48 11 101 103 114 97 118 101 46 115 117 112 115 11 101 97 99 117 116 101 46 115 117 112 115 12 117 110 105 48 50 53 57 46 115 117 112 115 6 97 46 115 117 112 97 6 103 46 115 117 112 97 6 108 46 115 117 112 97 10 99 111 108 111 110 46 115 117 112 115 11 104 121 112 104 101 110 46 115 117 112 115 11 101 110 100 97 115 104 46 115 117 112 115 11 101 109 100 97 115 104 46 115 117 112 115 6 121 101 110 46 67 78 4 69 117 114 111 7 117 110 105 48 49 57 50 13 99 111 108 111 110 109 111 110 101 116 97 114 121 4 108 105 114 97 7 117 110 105 50 48 65 54 6 112 101 115 101 116 97 7 117 110 105 50 48 65 57 4 100 111 110 103 7 117 110 105 50 48 66 49 7 117 110 105 50 48 66 50 7 117 110 105 50 48 66 52 7 117 110 105 50 48 66 53 7 117 110 105 50 48 66 57 7 117 110 105 50 48 66 65 7 117 110 105 50 48 65 69 7 117 110 105 50 48 66 56 7 117 110 105 50 48 66 68 7 117 110 105 50 50 49 53 10 115 108 97 115 104 46 102 114 97 99 8 111 110 101 116 104 105 114 100 9 116 119 111 116 104 105 114 100 115 7 117 110 105 50 49 53 53 7 117 110 105 50 49 53 54 7 117 110 105 50 49 53 55 7 117 110 105 50 49 53 56 7 117 110 105 50 49 53 57 7 117 110 105 50 49 53 65 7 117 110 105 50 49 53 48 9 111 110 101 101 105 103 104 116 104 12 116 104 114 101 101 101 105 103 104 116 104 115 11 102 105 118 101 101 105 103 104 116 104 115 12 115 101 118 101 110 101 105 103 104 116 104 115 7 117 110 105 50 49 53 49 7 117 110 105 50 49 53 50 7 117 110 105 50 49 56 57 7 117 110 105 50 50 49 57 7 117 110 105 48 48 66 53 7 117 110 105 50 50 48 54 7 117 110 105 50 49 50 54 7 117 110 105 50 49 49 51 9 101 115 116 105 109 97 116 101 100 7 117 110 105 50 49 57 48 7 97 114 114 111 119 117 112 7 117 110 105 50 49 57 50 9 97 114 114 111 119 100 111 119 110 7 117 110 105 50 53 65 48 7 117 110 105 50 53 67 54 7 117 110 105 50 53 67 57 7 117 110 105 50 55 53 50 7 116 114 105 97 103 117 112 7 117 110 105 50 53 66 51 7 117 110 105 50 53 66 54 7 117 110 105 50 53 66 55 7 116 114 105 97 103 100 110 7 117 110 105 50 53 66 68 7 117 110 105 50 53 67 48 7 117 110 105 50 53 67 49 7 117 110 105 50 54 49 48 7 117 110 105 50 54 49 49 7 117 110 105 50 55 49 51 7 117 110 105 50 54 54 65 7 117 110 105 50 48 51 50 7 117 110 105 50 48 51 51 7 117 110 105 50 48 51 53 7 117 110 105 48 50 66 57 7 117 110 105 48 50 66 66 7 117 110 105 48 50 66 67 7 117 110 105 48 50 66 69 7 117 110 105 48 50 66 70 7 117 110 105 48 50 67 56 7 117 110 105 48 50 67 57 7 117 110 105 48 50 67 65 7 117 110 105 48 50 67 66 7 117 110 105 48 50 67 67 7 117 110 105 50 53 67 67 7 117 110 105 48 51 48 48 11 117 110 105 48 51 48 48 46 99 97 112 9 117 110 105 48 51 48 48 46 103 7 117 110 105 48 51 48 49 11 117 110 105 48 51 48 49 46 99 97 112 9 117 110 105 48 51 48 49 46 103 7 117 110 105 48 51 48 50 11 117 110 105 48 51 48 50 46 99 97 112 7 117 110 105 48 51 48 51 11 117 110 105 48 51 48 51 46 99 97 112 7 117 110 105 48 51 48 52 11 117 110 105 48 51 48 52 46 99 97 112 7 117 110 105 48 51 48 53 11 117 110 105 48 51 48 53 46 99 97 112 7 117 110 105 48 51 48 54 9 117 110 105 48 51 48 54 46 99 11 117 110 105 48 51 48 54 46 99 97 112 12 117 110 105 48 51 48 54 46 99 99 97 112 7 117 110 105 48 51 48 55 11 117 110 105 48 51 48 55 46 99 97 112 7 117 110 105 48 51 48 56 11 117 110 105 48 51 48 56 46 99 97 112 7 117 110 105 48 51 48 57 11 117 110 105 48 51 48 57 46 99 97 112 7 117 110 105 48 51 48 65 11 117 110 105 48 51 48 65 46 99 97 112 7 117 110 105 48 51 48 66 11 117 110 105 48 51 48 66 46 99 97 112 7 117 110 105 48 51 48 67 11 117 110 105 48 51 48 67 46 99 97 112 9 117 110 105 48 51 48 67 46 97 7 117 110 105 48 51 48 70 11 117 110 105 48 51 48 70 46 99 97 112 7 117 110 105 48 51 49 49 11 117 110 105 48 51 49 49 46 99 97 112 7 117 110 105 48 51 49 50 9 117 110 105 48 51 49 50 46 103 7 117 110 105 48 51 49 51 9 117 110 105 48 51 49 51 46 103 7 117 110 105 48 51 49 56 7 117 110 105 48 51 49 57 7 117 110 105 48 51 49 65 7 117 110 105 48 51 49 66 7 117 110 105 48 51 49 67 7 117 110 105 48 51 49 68 7 117 110 105 48 51 49 69 7 117 110 105 48 51 49 70 7 117 110 105 48 51 50 48 7 117 110 105 48 51 50 51 7 117 110 105 48 51 50 52 7 117 110 105 48 51 50 53 7 117 110 105 48 51 50 54 9 117 110 105 48 51 50 54 46 97 7 117 110 105 48 51 50 55 11 117 110 105 48 51 50 55 46 99 97 112 7 117 110 105 48 51 50 56 11 117 110 105 48 51 50 56 46 99 97 112 7 117 110 105 48 51 50 57 7 117 110 105 48 51 50 65 7 117 110 105 48 51 50 67 7 117 110 105 48 51 50 69 7 117 110 105 48 51 50 70 7 117 110 105 48 51 51 48 7 117 110 105 48 51 51 49 7 117 110 105 48 51 51 52 7 117 110 105 48 51 51 57 7 117 110 105 48 51 51 65 7 117 110 105 48 51 51 66 7 117 110 105 48 51 51 67 7 117 110 105 48 51 51 68 7 117 110 105 48 51 52 50 11 117 110 105 48 51 52 50 46 99 97 112 7 117 110 105 48 51 52 53 7 117 110 105 48 51 54 49 11 117 110 105 48 51 48 56 48 51 48 49 15 117 110 105 48 51 48 56 48 51 48 49 46 99 97 112 13 117 110 105 48 51 48 56 48 51 48 49 46 103 11 117 110 105 48 51 48 56 48 51 48 48 15 117 110 105 48 51 48 56 48 51 48 48 46 99 97 112 13 117 110 105 48 51 48 56 48 51 48 48 46 103 11 117 110 105 48 51 48 56 48 51 48 51 11 117 110 105 48 51 48 56 48 51 48 52 15 117 110 105 48 51 48 56 48 51 48 52 46 99 97 112 11 117 110 105 48 51 48 56 48 51 48 67 15 117 110 105 48 51 48 56 48 51 48 67 46 99 97 112 11 117 110 105 48 51 48 50 48 51 48 49 15 117 110 105 48 51 48 50 48 51 48 49 46 99 97 112 11 117 110 105 48 51 48 50 48 51 48 48 15 117 110 105 48 51 48 50 48 51 48 48 46 99 97 112 11 117 110 105 48 51 48 50 48 51 48 57 15 117 110 105 48 51 48 50 48 51 48 57 46 99 97 112 11 117 110 105 48 51 48 50 48 51 48 51 15 117 110 105 48 51 48 50 48 51 48 51 46 99 97 112 11 117 110 105 48 51 48 54 48 51 48 49 15 117 110 105 48 51 48 54 48 51 48 49 46 99 97 112 11 117 110 105 48 51 48 54 48 51 48 48 15 117 110 105 48 51 48 54 48 51 48 48 46 99 97 112 11 117 110 105 48 51 48 54 48 51 48 57 15 117 110 105 48 51 48 54 48 51 48 57 46 99 97 112 11 117 110 105 48 51 48 54 48 51 48 51 15 117 110 105 48 51 48 54 48 51 48 51 46 99 97 112 11 117 110 105 48 51 48 50 48 51 48 54 15 117 110 105 48 51 48 50 48 51 48 54 46 99 97 112 11 117 110 105 48 51 48 52 48 51 48 49 15 117 110 105 48 51 48 52 48 51 48 49 46 99 97 112 11 117 110 105 48 51 49 50 48 51 48 49 11 117 110 105 48 51 49 50 48 51 48 48 11 117 110 105 48 51 49 50 48 51 48 51 11 117 110 105 48 51 49 51 48 51 48 49 11 117 110 105 48 51 49 51 48 51 48 48 11 117 110 105 48 51 49 51 48 51 48 51 7 117 110 105 48 48 65 48 7 117 110 105 50 48 48 55 10 115 112 97 99 101 46 102 114 97 99 12 110 98 115 112 97 99 101 46 102 114 97 99 7 117 110 105 50 48 50 70 7 117 110 105 70 69 70 70 0 0 0 1 255 255 0 2 0 1 0 0 0 12 0 0 0 0 2 248 0 2 0 124 0 2 0 53 0 1 0 75 0 76 0 1 0 106 0 106 0 1 0 115 0 115 0 2 0 131 0 131 0 1 0 173 0 175 0 1 0 181 0 181 0 1 0 219 0 220 0 1 0 245 0 246 0 1 1 13 1 14 0 1 1 24 1 24 0 2 1 44 1 44 0 1 1 50 1 50 0 2 1 53 1 53 0 2 1 68 1 68 0 2 1 69 1 69 0 1 1 71 1 71 0 1 1 78 1 78 0 2 1 114 1 116 0 1 1 122 1 122 0 1 1 138 1 138 0 2 1 161 1 162 0 1 1 186 1 188 0 1 1 190 1 192 0 1 1 194 1 194 0 1 1 196 1 209 0 1 1 211 1 212 0 1 1 216 1 216 0 1 1 221 1 229 0 1 1 231 1 234 0 1 1 236 1 236 0 1 1 238 1 238 0 1 1 241 1 251 0 1 2 2 2 2 0 2 2 5 2 6 0 2 2 7 2 7 0 1 2 18 2 18 0 1 2 21 2 21 0 1 2 33 2 33 0 1 2 43 2 44 0 1 2 49 2 49 0 2 2 53 2 53 0 1 2 63 2 63 0 4 2 67 2 67 0 4 2 69 2 69 0 4 2 71 2 71 0 4 2 77 2 77 0 4 2 79 2 79 0 4 2 82 2 82 0 4 2 86 2 86 0 4 2 91 2 91 0 2 2 94 2 94 0 2 2 96 2 96 0 1 2 100 2 100 0 1 2 102 2 102 0 1 2 104 2 104 0 1 2 110 2 110 0 1 2 112 2 112 0 1 2 115 2 115 0 1 2 119 2 119 0 1 2 128 2 128 0 2 2 131 2 131 0 2 2 135 3 95 0 2 3 97 3 97 0 1 3 99 3 99 0 1 3 110 3 110 0 4 3 112 3 112 0 4 3 118 3 118 0 4 3 121 3 121 0 4 3 136 3 136 0 1 3 139 3 139 0 1 3 141 3 142 0 1 3 146 3 146 0 1 3 148 3 148 0 1 3 154 3 154 0 1 3 159 3 159 0 1 3 162 3 163 0 1 3 167 3 167 0 1 3 169 3 171 0 1 3 192 3 192 0 1 3 208 3 209 0 1 3 223 3 223 0 1 3 226 3 226 0 1 3 229 3 229 0 1 3 231 3 232 0 1 3 236 3 236 0 1 3 238 3 238 0 1 3 244 3 244 0 1 3 249 3 249 0 1 3 252 3 253 0 1 4 1 4 1 0 1 4 3 4 5 0 1 4 10 4 10 0 1 4 26 4 26 0 1 4 42 4 43 0 1 4 57 4 57 0 1 4 193 4 218 0 1 4 240 4 241 0 1 5 15 5 15 0 1 5 40 5 40 0 1 5 82 5 82 0 1 5 88 5 88 0 1 5 112 5 112 0 1 5 129 5 130 0 1 5 156 5 156 0 1 5 159 5 160 0 1 5 163 5 165 0 1 5 167 5 168 0 1 5 170 5 171 0 1 5 173 5 173 0 1 5 175 5 175 0 1 5 177 5 178 0 1 5 180 5 180 0 1 5 191 5 191 0 1 5 193 5 194 0 1 5 196 5 196 0 1 5 198 5 198 0 1 5 207 5 207 0 1 7 14 7 14 0 1 7 24 7 24 0 1 7 30 7 30 0 1 7 31 7 60 0 3 7 62 7 103 0 3 7 105 7 141 0 3 0 2 0 33 7 31 7 31 0 1 7 33 7 34 0 1 7 36 7 37 0 1 7 39 7 39 0 1 7 41 7 41 0 1 7 43 7 43 0 1 7 45 7 46 0 1 7 49 7 49 0 1 7 51 7 51 0 1 7 53 7 53 0 1 7 55 7 55 0 1 7 57 7 57 0 1 7 59 7 59 0 1 7 62 7 62 0 1 7 64 7 64 0 1 7 66 7 69 0 1 7 83 7 83 0 1 7 100 7 101 0 1 7 105 7 105 0 1 7 107 7 108 0 1 7 110 7 112 0 1 7 114 7 114 0 1 7 116 7 116 0 1 7 118 7 118 0 1 7 120 7 120 0 1 7 122 7 122 0 1 7 124 7 124 0 1 7 126 7 126 0 1 7 128 7 128 0 1 7 130 7 130 0 1 7 132 7 132 0 1 7 134 7 134 0 1 7 136 7 141 0 1 0 0 0 1 0 0 0 10 0 228 3 82 0 4 68 70 76 84 0 26 99 121 114 108 0 44 103 114 101 107 0 82 108 97 116 110 0 100 0 4 0 0 0 0 255 255 0 4 0 0 0 10 0 20 0 30 0 10 0 1 83 82 66 32 0 24 0 0 255 255 0 4 0 1 0 11 0 21 0 31 0 0 255 255 0 4 0 2 0 12 0 22 0 32 0 4 0 0 0 0 255 255 0 4 0 3 0 13 0 23 0 33 0 34 0 5 65 90 69 32 0 48 67 82 84 32 0 62 78 83 77 32 0 76 83 75 83 32 0 90 84 82 75 32 0 104 0 0 255 255 0 4 0 4 0 14 0 24 0 34 0 0 255 255 0 4 0 5 0 15 0 25 0 35 0 0 255 255 0 4 0 6 0 16 0 26 0 36 0 0 255 255 0 4 0 7 0 17 0 27 0 37 0 0 255 255 0 4 0 8 0 18 0 28 0 38 0 0 255 255 0 4 0 9 0 19 0 29 0 39 0 40 107 101 114 110 0 242 107 101 114 110 0 248 107 101 114 110 0 254 107 101 114 110 1 4 107 101 114 110 1 10 107 101 114 110 1 16 107 101 114 110 1 22 107 101 114 110 1 28 107 101 114 110 1 34 107 101 114 110 1 40 109 97 114 107 1 46 109 97 114 107 1 68 109 97 114 107 1 90 109 97 114 107 1 112 109 97 114 107 1 134 109 97 114 107 1 156 109 97 114 107 1 178 109 97 114 107 1 200 109 97 114 107 1 222 109 97 114 107 1 244 109 107 109 107 2 10 109 107 109 107 2 16 109 107 109 107 2 22 109 107 109 107 2 28 109 107 109 107 2 34 109 107 109 107 2 40 109 107 109 107 2 46 109 107 109 107 2 52 109 107 109 107 2 58 109 107 109 107 2 64 115 105 122 101 2 70 115 105 122 101 2 74 115 105 122 101 2 78 115 105 122 101 2 82 115 105 122 101 2 86 115 105 122 101 2 90 115 105 122 101 2 94 115 105 122 101 2 98 115 105 122 101 2 102 115 105 122 101 2 106 0 0 0 1 0 10 0 0 0 1 0 10 0 0 0 1 0 10 0 0 0 1 0 10 0 0 0 1 0 10 0 0 0 1 0 10 0 0 0 1 0 10 0 0 0 1 0 10 0 0 0 1 0 10 0 0 0 1 0 10 0 0 0 9 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 0 0 9 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 0 0 9 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 0 0 9 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 0 0 9 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 0 0 9 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 0 0 9 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 0 0 9 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 0 0 9 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 0 0 9 0 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 168 0 0 0 164 0 0 0 160 0 0 0 156 0 0 0 152 0 0 0 148 0 0 0 144 0 0 0 140 0 0 0 136 0 0 0 132 0 0 0 11 0 24 0 32 0 40 0 48 0 56 0 64 0 72 0 80 0 88 0 96 0 104 0 4 0 0 0 1 0 114 0 4 0 0 0 1 3 246 0 4 0 0 0 1 7 24 0 4 0 0 0 1 7 50 0 4 0 0 0 1 7 158 0 4 0 0 0 1 11 14 0 4 0 0 0 1 11 40 0 4 0 0 0 1 11 114 0 4 0 0 0 1 11 214 0 6 1 0 0 1 12 68 0 2 0 0 0 9 13 36 36 74 37 76 37 102 38 32 63 44 104 214 136 132 190 4 0 100 0 0 0 0 0 0 0 0 0 1 202 82 202 182 0 1 0 12 0 206 0 48 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 0 1 202 0 131 1 14 1 20 1 26 1 32 1 38 1 44 1 50 1 56 1 62 1 68 1 20 1 74 1 80 1 86 1 92 1 86 1 98 1 104 1 110 1 116 1 26 1 122 1 128 1 134 1 140 1 146 1 14 1 152 1 38 1 158 1 158 1 92 1 164 1 92 1 92 1 170 1 92 1 20 1 86 1 176 1 182 1 188 1 182 1 140 1 194 1 200 1 206 1 212 1 218 1 224 1 230 1 236 1 242 1 242 1 122 1 26 1 248 1 80 1 80 1 80 1 86 1 86 1 254 1 92 2 4 2 10 2 16 2 10 1 104 1 110 1 116 1 86 1 92 1 14 1 122 1 128 1 140 2 22 1 146 1 146 2 28 1 194 2 34 1 194 2 40 1 56 1 194 2 46 2 52 1 158 2 58 1 188 1 218 2 64 2 58 2 70 1 14 2 46 1 38 2 76 1 242 2 82 1 92 1 140 1 98 1 218 2 88 2 94 2 100 1 38 1 26 1 92 1 122 1 122 1 92 2 106 2 112 2 118 2 124 2 130 2 136 2 142 2 148 2 154 2 160 2 166 2 106 2 172 2 178 2 184 1 188 0 1 0 0 1 253 0 1 1 13 1 253 0 1 0 126 2 218 0 1 1 16 1 253 0 1 1 137 2 218 0 1 1 8 1 253 0 1 0 219 2 228 0 1 1 2 1 253 0 1 0 123 2 218 0 1 0 123 2 182 0 1 0 125 2 182 0 1 0 122 2 218 0 1 1 163 1 253 0 1 1 35 1 253 0 1 1 15 1 253 0 1 1 22 1 253 0 1 0 216 1 253 0 1 0 219 1 253 0 1 0 143 2 131 0 1 0 235 1 253 0 1 1 104 1 253 0 1 0 223 1 253 0 1 0 243 1 253 0 1 0 229 1 253 0 1 1 157 1 253 0 1 0 124 1 253 0 1 1 184 1 253 0 1 1 13 1 246 0 1 0 125 1 253 0 1 1 20 1 253 0 1 1 37 1 253 0 1 1 26 1 253 0 1 0 251 1 246 0 1 0 242 1 253 0 1 0 232 1 253 0 1 0 244 1 253 0 1 0 221 1 253 0 1 1 7 1 253 0 1 0 136 1 253 0 1 1 30 1 253 0 1 0 171 1 253 0 1 1 19 1 253 0 1 1 161 1 253 0 1 0 195 1 253 0 1 0 132 1 253 0 1 0 207 1 253 0 1 0 187 2 7 0 1 1 12 1 245 0 1 1 31 1 253 0 1 0 247 1 253 0 1 1 34 1 253 0 1 1 11 1 253 0 1 1 91 1 253 0 1 0 249 1 253 0 1 1 85 1 253 0 1 1 21 1 253 0 1 1 93 1 253 0 1 0 204 1 253 0 1 1 138 1 253 0 1 0 234 2 51 0 1 1 20 2 51 0 1 1 9 2 51 0 1 0 250 2 51 0 1 1 41 2 51 0 1 0 131 2 51 0 1 1 32 2 51 0 1 1 67 2 51 0 1 1 45 2 51 0 1 1 39 2 51 0 1 1 30 2 51 0 1 0 208 2 51 0 1 1 15 2 207 0 1 1 15 2 194 0 1 200 52 200 118 0 1 0 12 0 138 0 31 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 0 1 80 0 104 0 216 0 222 0 228 0 234 0 240 0 246 0 252 1 2 1 8 1 14 1 20 1 26 1 32 1 38 1 44 1 50 1 44 1 56 1 62 1 68 1 74 1 80 1 86 1 80 1 92 1 98 1 104 1 110 0 240 1 8 1 116 1 122 1 116 1 128 1 74 1 134 1 140 1 14 1 146 1 152 1 158 1 164 1 164 0 216 1 170 0 240 1 176 1 182 1 188 1 44 1 194 1 200 1 206 1 212 1 218 1 224 1 206 1 44 1 92 1 92 1 44 1 230 1 236 1 242 1 248 1 254 2 4 2 10 2 16 2 22 2 28 2 34 2 40 2 46 2 52 2 58 2 64 2 70 2 76 2 82 1 230 2 88 2 94 2 100 2 106 2 112 2 118 1 230 2 124 1 254 2 22 2 70 2 58 1 230 2 88 2 88 1 14 1 242 2 130 1 254 2 136 2 142 2 148 2 154 0 1 0 0 2 166 0 1 1 14 2 166 0 1 1 31 2 166 0 1 1 73 2 166 0 1 1 52 2 166 0 1 1 29 2 166 0 1 1 30 2 166 0 1 1 97 2 166 0 1 1 69 2 166 0 1 0 131 2 166 0 1 1 92 2 166 0 1 1 55 2 166 0 1 0 133 2 166 0 1 1 107 2 166 0 1 1 71 2 166 0 1 1 76 2 166 0 1 1 47 2 166 0 1 1 39 2 166 0 1 1 22 2 166 0 1 1 11 2 166 0 1 1 66 2 166 0 1 1 1 2 166 0 1 1 137 2 166 0 1 0 238 2 166 0 1 1 24 2 166 0 1 1 16 2 166 0 1 2 52 2 182 0 1 1 79 2 166 0 1 2 20 2 166 0 1 1 75 2 166 0 1 1 67 2 166 0 1 1 86 2 166 0 1 1 52 1 253 0 1 0 129 2 51 0 1 1 1 1 253 0 1 0 171 2 166 0 1 1 34 2 166 0 1 1 143 2 166 0 1 1 76 2 170 0 1 1 66 2 170 0 1 0 252 2 166 0 1 1 64 2 166 0 1 1 37 2 166 0 1 1 153 2 166 0 1 1 5 2 166 0 1 1 189 2 166 0 1 0 234 2 51 0 1 1 20 2 51 0 1 1 39 2 63 0 1 1 27 2 51 0 1 1 9 2 51 0 1 1 10 2 51 0 1 1 52 2 51 0 1 1 41 2 51 0 1 0 131 2 51 0 1 1 47 2 51 0 1 1 32 2 51 0 1 0 137 2 51 0 1 1 67 2 51 0 1 1 45 2 51 0 1 1 39 2 51 0 1 1 30 2 51 0 1 1 38 2 51 0 1 1 26 2 51 0 1 0 254 2 51 0 1 1 36 2 51 0 1 0 226 2 51 0 1 1 86 2 51 0 1 0 229 2 51 0 1 0 208 2 51 0 1 0 250 2 51 0 1 1 208 2 51 0 1 1 14 2 28 0 1 2 59 2 170 0 1 1 42 2 28 0 1 1 32 2 28 0 1 0 222 2 28 0 1 198 32 198 38 0 1 0 12 0 18 0 1 0 0 0 10 0 1 0 10 0 1 0 0 1 253 0 1 1 217 1 253 0 1 198 10 198 18 0 1 0 12 0 22 0 2 0 0 0 38 0 0 0 38 0 13 0 34 0 40 0 46 0 52 0 58 0 64 0 70 0 76 0 82 0 82 0 82 0 70 0 88 0 1 0 0 0 0 0 1 1 87 0 0 0 1 1 17 0 0 0 1 1 12 0 0 0 1 1 14 0 0 0 1 0 223 0 0 0 1 0 217 0 0 0 1 1 38 0 0 0 1 0 244 0 0 0 1 0 229 0 0 0 1 1 37 0 0 0 1 197 188 197 222 0 1 0 12 0 106 0 23 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 0 1 128 0 144 1 40 1 46 1 52 1 58 1 64 1 70 1 76 1 82 1 88 1 94 1 100 1 106 1 112 1 118 1 124 1 130 1 136 1 142 1 148 1 154 1 160 1 166 1 172 1 178 1 184 1 172 1 190 1 40 1 196 1 202 1 130 1 208 1 214 1 220 1 226 1 232 1 238 1 244 1 250 1 232 2 0 2 6 1 220 2 12 2 18 2 24 2 30 2 36 2 12 2 42 2 48 2 54 1 154 2 60 2 66 1 220 1 232 1 106 1 190 1 250 1 214 1 190 1 196 1 94 2 72 1 40 1 178 2 78 2 12 2 84 2 90 2 96 2 30 2 24 1 214 2 102 1 172 1 244 1 244 2 108 2 114 2 114 2 114 1 220 1 250 1 232 2 120 2 30 2 36 2 126 2 132 2 138 2 72 1 148 2 144 1 220 2 150 2 78 2 156 2 162 2 168 1 214 2 174 2 180 2 186 1 70 1 58 2 192 1 88 2 198 2 204 2 210 2 216 2 204 2 222 1 130 2 228 2 234 2 168 2 240 2 246 2 252 3 2 2 132 1 94 2 222 2 168 2 240 2 168 1 214 2 186 1 94 2 192 1 88 2 204 2 216 2 204 2 222 1 130 2 168 2 132 2 174 2 186 3 8 0 1 0 0 255 234 0 1 1 14 255 234 0 1 1 46 255 234 0 1 1 87 255 234 0 1 1 49 255 234 0 1 1 42 255 234 0 1 0 135 255 234 0 1 1 92 255 234 0 1 1 69 255 234 0 1 0 131 255 234 0 1 0 253 255 234 0 1 1 72 255 234 0 1 1 33 255 234 0 1 1 109 255 234 0 1 1 71 255 234 0 1 1 76 255 234 0 1 0 137 255 234 0 1 1 54 255 234 0 1 1 17 255 234 0 1 1 12 255 234 0 1 1 66 255 234 0 1 1 2 255 234 0 1 1 140 255 234 0 1 0 252 255 234 0 1 0 240 255 234 0 1 1 26 255 234 0 1 1 28 255 234 0 1 1 45 255 234 0 1 1 6 255 234 0 1 0 250 255 26 0 1 1 30 255 234 0 1 0 123 255 234 0 1 0 59 255 25 0 1 1 15 255 234 0 1 0 122 255 234 0 1 1 169 255 234 0 1 1 22 255 234 0 1 0 117 255 38 0 1 1 170 255 38 0 1 0 223 255 234 0 1 0 212 255 234 0 1 1 34 255 234 0 1 0 235 255 234 0 1 1 104 255 234 0 1 0 200 255 14 0 1 0 228 255 234 0 1 1 75 255 234 0 1 1 90 255 234 0 1 1 163 255 234 0 1 1 27 255 234 0 1 0 250 255 234 0 1 1 23 255 234 0 1 1 18 255 35 0 1 1 48 255 234 0 1 0 171 255 234 0 1 1 176 255 234 0 1 0 38 255 234 0 1 1 24 255 234 0 1 0 239 255 234 0 1 0 207 255 234 0 1 0 173 255 234 0 1 1 184 255 38 0 1 1 35 255 234 0 1 0 124 255 234 0 1 1 91 255 234 0 1 0 234 255 234 0 1 1 38 255 234 0 1 1 25 255 234 0 1 1 11 255 234 0 1 1 41 255 234 0 1 0 209 255 234 0 1 1 43 255 234 0 1 1 4 255 234 0 1 1 67 255 234 0 1 1 39 255 234 0 1 1 29 255 234 0 1 1 3 255 234 0 1 1 36 255 234 0 1 0 225 255 234 0 1 1 86 255 234 0 1 0 237 255 234 0 1 1 37 255 234 0 1 195 120 194 24 0 1 0 12 0 18 0 1 0 0 0 10 0 1 0 10 0 1 0 0 0 244 0 1 1 37 0 244 0 1 195 92 195 98 0 1 0 12 0 18 0 1 0 0 0 22 0 7 0 22 0 28 0 34 0 40 0 46 0 52 0 58 0 1 0 0 1 230 0 1 1 213 2 134 0 1 2 13 2 154 0 1 1 108 1 230 0 1 1 155 1 240 0 1 1 167 1 243 0 1 1 207 2 17 0 1 1 153 1 230 0 1 195 34 195 40 0 1 0 12 0 18 0 1 0 0 0 30 0 11 0 30 0 36 0 42 0 48 0 54 0 42 0 60 0 66 0 72 0 78 0 84 0 1 0 0 0 0 0 1 1 158 0 0 0 1 1 133 0 0 0 1 0 152 0 0 0 1 1 64 0 0 0 1 1 172 0 0 0 1 1 81 0 0 0 1 0 241 0 0 0 1 0 240 0 0 0 1 1 137 0 0 0 1 1 37 0 0 0 1 194 214 194 220 0 1 0 12 0 18 0 1 0 0 0 34 0 13 0 34 0 40 0 46 0 52 0 58 0 64 0 64 0 70 0 76 0 46 0 82 0 88 0 94 0 1 0 0 0 0 0 1 1 210 0 0 0 1 1 132 0 0 0 1 0 108 0 0 0 1 1 76 0 0 0 1 1 66 0 0 0 1 0 148 0 0 0 1 1 123 0 0 0 1 1 72 0 0 0 1 1 39 0 0 0 1 1 36 0 0 0 1 1 38 0 0 0 1 190 56 194 132 0 1 0 12 0 206 0 48 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 0 0 202 0 3 0 14 0 20 0 20 0 1 0 0 1 253 0 1 0 0 2 220 0 1 0 0 2 183 0 1 193 166 0 4 0 0 0 143 1 40 1 58 1 100 1 110 1 116 1 122 1 128 1 134 1 140 1 146 2 72 4 230 6 176 7 246 8 64 8 70 9 208 11 90 11 96 11 114 11 128 11 138 11 144 11 150 11 236 11 254 12 8 12 26 12 72 12 110 12 132 12 154 12 192 12 230 13 4 13 14 13 24 13 30 13 68 13 106 13 144 13 182 13 220 14 2 14 40 14 78 14 96 14 114 14 132 14 150 14 168 14 186 14 192 14 202 14 208 14 214 14 220 14 226 14 236 14 242 14 248 15 2 15 12 15 18 15 24 15 30 15 36 15 42 15 52 15 58 15 64 15 70 15 76 15 118 15 124 15 130 15 136 15 146 15 156 15 170 15 176 15 194 15 200 15 242 16 16 16 42 16 72 16 102 16 148 16 170 16 188 16 210 16 224 17 6 17 36 17 66 17 100 17 126 17 172 17 198 17 220 18 42 18 120 18 126 18 132 18 138 18 176 18 210 18 216 18 222 18 228 20 78 20 96 20 114 20 120 20 142 20 160 20 178 20 200 20 222 20 228 20 254 21 4 21 10 21 28 21 50 21 56 21 78 21 100 21 110 21 148 21 178 21 196 21 202 21 224 21 242 22 28 22 50 22 76 22 86 22 136 22 202 22 232 0 4 1 61 0 29 1 62 0 36 1 63 0 36 1 64 0 29 0 10 1 59 0 20 1 60 0 13 1 61 0 53 1 62 0 64 1 63 0 64 1 64 0 53 1 65 0 42 1 66 0 13 1 69 0 13 1 70 0 53 0 2 4 118 0 7 4 120 0 7 0 1 4 175 255 249 0 1 4 175 255 249 0 1 4 175 255 249 0 1 4 175 255 249 0 1 4 175 255 249 0 1 4 175 255 249 0 45 0 21 255 232 0 23 255 240 0 24 255 252 0 26 255 232 0 53 255 237 0 197 255 232 0 198 255 232 0 199 255 232 0 200 255 232 0 201 255 232 0 202 255 232 0 226 255 252 0 227 255 252 0 228 255 252 0 229 255 252 0 230 255 232 0 231 255 232 0 232 255 232 0 233 255 232 0 234 255 232 0 235 255 232 0 236 255 232 0 237 255 232 1 180 255 237 1 181 255 237 1 182 255 237 1 183 255 237 1 184 255 237 1 249 255 237 1 250 255 237 4 124 255 229 4 129 255 240 4 131 255 240 4 138 255 246 4 139 255 246 4 140 255 246 4 141 255 246 4 144 255 246 4 145 255 246 4 161 255 202 4 168 255 229 4 170 255 229 4 171 255 229 7 9 255 240 7 10 255 240 0 167 0 21 255 236 0 23 255 242 0 26 255 232 0 28 255 246 0 30 0 1 0 31 0 1 0 32 0 1 0 34 255 246 0 42 0 1 0 44 0 1 0 49 0 6 0 50 0 6 0 51 0 8 0 197 255 236 0 198 255 236 0 199 255 236 0 200 255 236 0 201 255 236 0 202 255 236 0 230 255 232 0 231 255 232 0 232 255 232 0 233 255 232 0 234 255 232 0 235 255 232 0 236 255 232 0 237 255 232 0 248 255 246 0 249 255 246 0 250 255 246 0 251 255 246 0 252 255 246 0 253 255 246 0 254 255 246 0 255 255 246 1 0 255 246 1 1 255 246 1 2 255 246 1 3 255 246 1 4 255 246 1 5 255 246 1 6 255 246 1 7 255 246 1 8 255 246 1 9 255 246 1 10 255 246 1 11 255 246 1 12 255 246 1 13 255 246 1 14 255 246 1 15 255 246 1 16 255 246 1 19 0 1 1 20 0 1 1 21 0 1 1 22 0 1 1 23 0 1 1 24 0 1 1 25 0 1 1 26 0 1 1 27 0 1 1 28 0 1 1 29 0 1 1 30 0 1 1 31 0 1 1 32 0 1 1 33 0 1 1 34 0 1 1 35 0 1 1 36 0 1 1 37 0 1 1 38 0 1 1 39 0 1 1 40 0 1 1 41 0 1 1 42 0 1 1 43 0 1 1 44 0 1 1 45 0 1 1 46 255 246 1 47 255 246 1 48 255 246 1 49 255 246 1 50 255 246 1 51 255 246 1 52 255 246 1 53 255 246 1 97 0 1 1 98 0 1 1 99 0 1 1 100 0 1 1 101 0 1 1 102 0 1 1 103 0 1 1 104 0 1 1 105 0 1 1 106 0 1 1 107 0 1 1 108 0 1 1 109 0 1 1 110 0 1 1 111 0 1 1 112 0 1 1 113 0 1 1 114 0 1 1 115 0 1 1 116 0 1 1 117 0 1 1 118 0 1 1 119 0 1 1 120 0 1 1 121 0 1 1 122 0 1 1 168 0 6 1 169 0 6 1 170 0 6 1 171 0 6 1 194 0 1 1 195 0 1 1 196 0 1 1 198 0 1 1 206 0 1 1 207 0 1 1 208 0 1 1 228 0 1 1 229 0 1 1 230 0 1 2 21 0 1 2 22 0 1 2 23 0 1 2 24 0 1 2 25 0 1 2 26 0 1 2 27 0 1 2 28 0 1 2 29 0 1 2 30 0 1 2 31 0 1 2 32 0 1 2 33 0 1 2 34 0 1 2 35 0 1 2 36 0 1 2 37 0 1 2 38 0 1 2 39 0 1 2 40 0 1 2 41 0 1 2 42 0 1 2 43 0 1 2 44 0 1 2 45 0 1 2 46 0 1 2 47 0 1 2 48 0 1 2 49 0 1 2 50 0 1 2 51 0 1 2 52 0 1 4 138 255 236 4 139 255 236 4 140 255 236 4 141 255 236 4 144 255 236 4 145 255 236 4 146 255 242 4 184 0 20 0 114 0 11 255 236 0 20 255 236 0 21 255 232 0 23 255 240 0 24 255 246 0 26 255 230 0 28 255 242 0 33 255 254 0 34 255 246 0 47 255 242 0 49 0 5 0 50 0 5 0 51 255 249 0 53 0 4 0 133 255 236 0 189 255 236 0 190 255 236 0 191 255 236 0 192 255 236 0 193 255 236 0 194 255 236 0 195 255 236 0 197 255 232 0 198 255 232 0 199 255 232 0 200 255 232 0 201 255 232 0 202 255 232 0 226 255 246 0 227 255 246 0 228 255 246 0 229 255 246 0 230 255 230 0 231 255 230 0 232 255 230 0 233 255 230 0 234 255 230 0 235 255 230 0 236 255 230 0 237 255 230 0 248 255 242 0 249 255 242 0 250 255 242 0 251 255 242 0 252 255 242 0 253 255 242 0 254 255 242 0 255 255 242 1 0 255 242 1 1 255 242 1 2 255 242 1 3 255 242 1 4 255 242 1 5 255 242 1 6 255 242 1 7 255 242 1 8 255 242 1 9 255 242 1 10 255 242 1 11 255 242 1 12 255 242 1 13 255 242 1 14 255 242 1 15 255 242 1 16 255 242 1 46 255 246 1 47 255 246 1 48 255 246 1 49 255 246 1 50 255 246 1 51 255 246 1 52 255 246 1 53 255 246 1 138 255 242 1 139 255 242 1 140 255 242 1 141 255 242 1 142 255 242 1 143 255 242 1 144 255 242 1 168 0 5 1 169 0 5 1 170 0 5 1 171 0 5 1 180 0 4 1 181 0 4 1 182 0 4 1 183 0 4 1 184 0 4 1 241 255 242 1 249 0 4 1 250 0 4 2 2 255 254 2 5 255 254 2 6 255 254 2 62 255 254 4 129 255 246 4 131 255 246 4 134 255 255 4 136 255 255 4 138 0 6 4 139 0 6 4 140 0 6 4 141 0 6 4 144 0 6 4 145 0 6 4 146 255 252 4 159 255 236 4 161 255 222 4 185 255 239 7 9 255 246 7 10 255 246 7 148 255 254 7 149 255 254 0 81 0 11 255 216 0 21 255 236 0 23 255 252 0 26 255 249 0 27 255 252 0 28 255 236 0 37 255 246 0 53 255 232 0 133 255 216 0 197 255 236 0 198 255 236 0 199 255 236 0 200 255 236 0 201 255 236 0 202 255 236 0 230 255 249 0 231 255 249 0 232 255 249 0 233 255 249 0 234 255 249 0 235 255 249 0 236 255 249 0 237 255 249 0 238 255 252 0 239 255 252 0 240 255 252 0 241 255 252 0 242 255 252 0 248 255 236 0 249 255 236 0 250 255 236 0 251 255 236 0 252 255 236 0 253 255 236 0 254 255 236 0 255 255 236 1 0 255 236 1 1 255 236 1 2 255 236 1 3 255 236 1 4 255 236 1 5 255 236 1 6 255 236 1 7 255 236 1 8 255 236 1 9 255 236 1 10 255 236 1 11 255 236 1 12 255 236 1 13 255 236 1 14 255 236 1 15 255 236 1 16 255 236 1 72 255 246 1 180 255 232 1 181 255 232 1 182 255 232 1 183 255 232 1 184 255 232 1 188 255 246 1 205 255 246 1 225 255 246 1 239 255 246 1 240 255 246 1 249 255 232 1 250 255 232 4 117 255 221 4 118 255 221 4 121 255 221 4 132 255 221 4 133 255 221 4 138 255 249 4 139 255 249 4 140 255 249 4 141 255 249 4 144 255 249 4 145 255 249 4 157 255 236 4 161 255 248 4 184 0 45 4 185 0 13 0 18 0 21 255 236 0 23 255 242 0 26 255 226 0 197 255 236 0 198 255 236 0 199 255 236 0 200 255 236 0 201 255 236 0 202 255 236 0 230 255 226 0 231 255 226 0 232 255 226 0 233 255 226 0 234 255 226 0 235 255 226 0 236 255 226 0 237 255 226 4 161 255 232 0 1 6 29 255 236 0 98 0 11 255 201 0 27 255 246 0 28 255 231 0 34 255 246 0 37 255 250 0 46 255 246 0 49 0 19 0 50 0 13 0 53 255 246 0 133 255 201 0 238 255 246 0 239 255 246 0 240 255 246 0 241 255 246 0 242 255 246 0 248 255 231 0 249 255 231 0 250 255 231 0 251 255 231 0 252 255 231 0 253 255 231 0 254 255 231 0 255 255 231 1 0 255 231 1 1 255 231 1 2 255 231 1 3 255 231 1 4 255 231 1 5 255 231 1 6 255 231 1 7 255 231 1 8 255 231 1 9 255 231 1 10 255 231 1 11 255 231 1 12 255 231 1 13 255 231 1 14 255 231 1 15 255 231 1 16 255 231 1 46 255 246 1 47 255 246 1 48 255 246 1 49 255 246 1 50 255 246 1 51 255 246 1 52 255 246 1 53 255 246 1 72 255 250 1 130 255 246 1 131 255 246 1 132 255 246 1 133 255 246 1 134 255 246 1 135 255 246 1 136 255 246 1 168 0 13 1 169 0 13 1 170 0 13 1 171 0 13 1 180 255 246 1 181 255 246 1 182 255 246 1 183 255 246 1 184 255 246 1 188 255 250 1 205 255 250 1 225 255 250 1 238 255 246 1 239 255 250 1 240 255 250 1 249 255 246 1 250 255 246 4 117 255 199 4 118 255 199 4 121 255 199 4 128 0 34 4 129 255 249 4 130 0 34 4 131 255 249 4 132 255 199 4 133 255 199 4 134 255 236 4 136 255 236 4 138 255 232 4 139 255 232 4 140 255 232 4 141 255 232 4 144 255 232 4 145 255 232 4 146 255 240 4 157 255 222 4 159 0 13 4 184 0 62 7 8 0 34 7 9 255 249 7 10 255 249 7 11 0 34 0 98 0 11 255 201 0 27 255 246 0 28 255 231 0 34 255 246 0 37 255 250 0 46 255 246 0 49 0 19 0 50 0 13 0 53 255 246 0 133 255 201 0 238 255 246 0 239 255 246 0 240 255 246 0 241 255 246 0 242 255 246 0 248 255 231 0 249 255 231 0 250 255 231 0 251 255 231 0 252 255 231 0 253 255 231 0 254 255 231 0 255 255 231 1 0 255 231 1 1 255 231 1 2 255 231 1 3 255 231 1 4 255 231 1 5 255 231 1 6 255 231 1 7 255 231 1 8 255 231 1 9 255 231 1 10 255 231 1 11 255 231 1 12 255 231 1 13 255 231 1 14 255 231 1 15 255 231 1 16 255 231 1 46 255 246 1 47 255 246 1 48 255 246 1 49 255 246 1 50 255 246 1 51 255 246 1 52 255 246 1 53 255 246 1 72 255 250 1 130 255 246 1 131 255 246 1 132 255 246 1 133 255 246 1 134 255 246 1 135 255 246 1 136 255 246 1 168 0 13 1 169 0 13 1 170 0 13 1 171 0 13 1 180 255 246 1 181 255 246 1 182 255 246 1 183 255 246 1 184 255 246 1 188 255 250 1 205 255 250 1 225 255 250 1 238 255 246 1 239 255 250 1 240 255 250 1 249 255 246 1 250 255 246 4 117 255 199 4 118 255 199 4 121 255 199 4 128 0 34 4 129 255 249 4 130 0 34 4 131 255 249 4 132 255 199 4 133 255 199 4 134 255 236 4 136 255 236 4 138 255 232 4 139 255 232 4 140 255 232 4 141 255 232 4 144 255 232 4 145 255 232 4 146 255 240 4 157 255 222 4 159 0 13 4 184 0 62 7 8 0 34 7 9 255 249 7 10 255 249 7 11 0 34 0 1 6 29 255 242 0 4 4 157 255 236 4 161 255 163 4 184 0 45 4 185 255 214 0 3 4 161 255 183 4 184 255 221 4 185 255 221 0 2 4 184 0 45 4 185 0 38 0 1 6 29 255 222 0 1 0 43 0 33 0 21 2 104 255 241 2 127 255 236 2 236 255 193 2 238 255 193 2 248 255 218 2 249 255 218 2 250 255 218 2 251 255 218 3 7 255 249 3 8 255 249 3 9 0 20 3 10 255 229 3 15 0 18 3 16 0 18 3 17 0 15 3 28 255 193 3 30 255 193 3 66 255 193 3 68 255 193 3 110 255 241 4 175 255 234 0 4 3 9 0 7 3 15 255 252 3 16 255 252 3 17 0 7 0 2 3 17 0 7 3 18 0 7 0 4 3 9 255 252 3 15 255 252 3 16 255 252 3 17 255 252 0 11 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 8 255 249 3 9 0 20 3 10 255 237 3 15 0 5 3 16 0 5 3 17 0 7 3 18 0 15 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 5 3 9 0 20 3 15 0 13 3 16 0 13 3 17 0 15 3 18 0 15 0 5 3 9 0 16 3 15 0 9 3 16 0 9 3 17 0 7 3 18 0 7 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 7 3 7 0 3 3 8 0 3 3 9 0 40 3 15 255 252 3 16 255 252 3 17 0 15 4 120 0 19 0 2 4 120 0 19 4 173 255 249 0 2 4 118 0 7 4 120 0 7 0 1 4 173 255 241 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 9 2 248 255 241 2 249 255 241 2 250 255 241 2 251 255 241 3 9 0 40 3 15 0 25 3 16 0 25 3 17 0 22 3 18 0 22 0 4 4 129 255 249 4 131 255 249 7 9 255 249 7 10 255 249 0 4 4 129 255 249 4 131 255 249 7 9 255 249 7 10 255 249 0 4 4 129 255 249 4 131 255 249 7 9 255 249 7 10 255 249 0 4 4 129 255 249 4 131 255 249 7 9 255 249 7 10 255 249 0 4 4 129 255 249 4 131 255 249 7 9 255 249 7 10 255 249 0 4 4 129 255 249 4 131 255 249 7 9 255 249 7 10 255 249 0 1 2 117 0 25 0 2 4 175 255 209 5 255 255 218 0 1 4 173 255 241 0 1 4 175 255 235 0 1 4 173 255 241 0 1 4 173 255 241 0 2 4 175 255 209 5 255 255 218 0 1 4 175 255 235 0 1 4 13 0 91 0 2 4 175 255 209 5 255 255 218 0 2 4 175 255 209 5 255 255 218 0 1 4 173 255 241 0 1 4 173 255 241 0 1 4 175 255 235 0 1 4 175 255 235 0 1 4 173 255 241 0 2 4 118 0 7 4 120 0 7 0 1 4 173 255 241 0 1 4 173 255 241 0 1 4 14 0 14 0 1 4 152 0 13 0 10 4 126 0 25 4 127 0 25 4 128 0 38 4 129 0 25 4 130 0 38 4 131 0 25 7 8 0 38 7 9 0 25 7 10 0 25 7 11 0 38 0 1 3 230 0 25 0 1 3 230 0 25 0 1 4 173 255 241 0 2 4 29 255 245 4 54 255 252 0 2 4 29 255 245 4 54 255 252 0 3 3 230 0 25 4 118 0 7 4 120 0 7 0 1 4 173 255 241 0 4 4 76 255 246 4 77 255 242 4 78 255 240 4 82 255 232 0 1 4 76 255 249 0 10 4 75 255 246 4 76 255 230 4 77 255 240 4 78 255 246 4 79 255 216 4 80 255 246 4 81 255 240 4 82 255 222 4 84 255 236 6 171 255 222 0 7 4 76 255 246 4 77 255 246 4 78 255 242 4 80 255 246 4 82 255 242 4 84 255 246 6 171 255 242 0 6 4 76 255 236 4 77 255 246 4 78 255 246 4 80 255 245 4 82 255 236 4 84 255 242 0 7 4 76 255 229 4 77 255 246 4 78 255 242 4 80 255 246 4 82 255 232 4 84 255 242 6 171 255 249 0 7 4 76 255 239 4 77 255 242 4 78 255 242 4 80 255 246 4 82 255 230 4 84 255 240 6 171 255 242 0 11 4 75 255 232 4 76 255 240 4 77 255 236 4 78 255 236 4 79 255 162 4 80 255 230 4 81 255 226 4 82 255 240 4 83 255 226 4 84 255 236 6 171 255 209 0 5 4 76 255 232 4 78 255 246 4 82 255 232 4 84 255 232 6 171 255 242 0 4 4 76 255 236 4 77 255 246 4 78 255 242 4 82 255 232 0 5 4 98 255 243 4 99 255 246 4 100 255 242 4 102 255 252 4 104 255 230 0 3 4 98 255 249 4 100 255 252 4 104 255 236 0 9 4 97 255 246 4 98 255 226 4 99 255 246 4 100 255 238 4 101 255 245 4 102 255 238 4 104 255 205 4 106 255 246 6 171 255 235 0 7 4 98 255 240 4 99 255 246 4 100 255 242 4 102 255 242 4 104 255 230 4 106 255 241 6 171 255 242 0 7 4 98 255 232 4 99 255 246 4 100 255 238 4 102 255 238 4 104 255 226 4 106 255 238 6 171 255 238 0 8 4 97 255 252 4 98 255 226 4 99 255 246 4 100 255 242 4 102 255 242 4 104 255 222 4 106 255 242 6 171 255 240 0 6 4 98 255 232 4 99 255 246 4 100 255 242 4 102 255 242 4 104 255 222 4 106 255 246 0 11 4 97 255 232 4 98 255 236 4 99 255 240 4 100 255 240 4 101 255 198 4 102 255 232 4 103 255 246 4 104 255 236 4 105 255 244 4 106 255 246 6 171 255 230 0 6 4 98 255 232 4 99 255 246 4 100 255 246 4 102 255 246 4 104 255 232 4 106 255 242 0 5 4 98 255 236 4 99 255 246 4 100 255 246 4 102 255 246 4 104 255 226 0 19 2 87 0 15 2 88 0 45 2 89 0 33 2 90 0 45 2 92 0 33 2 93 0 20 2 95 0 33 2 138 0 15 2 149 0 25 2 150 0 45 2 157 0 25 2 158 0 45 2 167 0 25 2 168 0 45 2 179 0 13 2 180 0 33 2 188 0 20 2 196 0 13 2 197 0 33 0 19 2 87 0 15 2 88 0 45 2 89 0 33 2 90 0 45 2 92 0 33 2 93 0 20 2 95 0 33 2 138 0 15 2 149 0 25 2 150 0 45 2 157 0 25 2 158 0 45 2 167 0 25 2 168 0 45 2 179 0 13 2 180 0 33 2 188 0 20 2 196 0 13 2 197 0 33 0 1 5 199 255 249 0 1 5 199 255 249 0 1 5 199 255 249 0 9 1 59 0 15 1 61 0 65 1 62 0 65 1 63 0 65 1 64 0 65 1 65 0 65 1 70 0 65 1 72 0 65 1 143 0 38 0 8 3 140 255 216 3 151 255 236 3 182 255 236 3 230 255 229 3 241 255 229 4 16 255 229 5 192 255 229 5 199 255 249 0 1 5 199 255 249 0 1 5 199 255 249 0 1 4 118 0 7 0 90 4 117 255 169 4 118 255 169 4 121 255 169 4 132 255 169 4 133 255 169 4 193 255 220 4 195 255 230 4 199 255 230 4 202 255 143 4 207 255 230 4 209 255 230 4 211 255 223 4 218 255 227 4 219 255 220 4 220 255 220 4 221 255 220 4 222 255 220 4 223 255 220 4 224 255 220 4 225 255 220 4 226 255 220 4 227 255 220 4 228 255 220 4 229 255 220 4 230 255 220 4 231 255 220 4 232 255 220 4 233 255 220 4 234 255 220 4 235 255 220 4 236 255 220 4 237 255 220 4 238 255 220 4 239 255 220 4 240 255 220 4 246 255 230 4 247 255 230 4 248 255 230 4 249 255 230 4 250 255 230 5 17 255 230 5 18 255 230 5 19 255 230 5 20 255 230 5 21 255 230 5 22 255 230 5 23 255 230 5 24 255 230 5 25 255 230 5 42 255 143 5 65 255 230 5 66 255 230 5 67 255 230 5 68 255 230 5 69 255 230 5 70 255 230 5 71 255 230 5 72 255 230 5 73 255 230 5 74 255 230 5 75 255 230 5 76 255 230 5 77 255 230 5 78 255 230 5 79 255 230 5 80 255 230 5 81 255 230 5 82 255 230 5 83 255 230 5 84 255 230 5 85 255 230 5 86 255 230 5 87 255 230 5 88 255 230 5 89 255 230 5 90 255 230 5 98 255 223 5 99 255 223 5 100 255 223 5 101 255 223 5 102 255 223 5 103 255 223 5 104 255 223 5 105 255 223 5 148 255 227 5 149 255 227 5 150 255 227 5 151 255 227 5 152 255 227 6 29 255 210 0 4 5 214 255 222 5 222 255 222 5 232 255 222 5 245 255 222 0 4 5 214 255 222 5 222 255 222 5 232 255 222 5 245 255 222 0 1 4 175 255 216 0 5 4 173 255 249 5 214 255 243 5 222 255 250 5 232 255 250 5 245 255 243 0 4 5 214 255 222 5 222 255 222 5 232 255 222 5 245 255 222 0 4 5 214 255 250 5 222 255 250 5 232 255 250 5 245 255 250 0 5 4 173 255 249 5 214 255 243 5 222 255 250 5 232 255 250 5 245 255 243 0 5 4 173 255 249 5 214 255 243 5 222 255 250 5 232 255 250 5 245 255 243 0 1 4 175 255 216 0 6 4 152 0 13 4 154 0 13 4 156 0 13 4 173 0 13 4 175 0 13 4 177 0 13 0 1 4 175 255 216 0 1 4 175 255 216 0 4 5 214 255 222 5 222 255 222 5 232 255 222 5 245 255 222 0 5 4 173 255 249 5 214 255 243 5 222 255 250 5 232 255 250 5 245 255 243 0 1 5 248 255 252 0 5 5 214 255 250 5 222 255 250 5 232 255 250 5 245 255 250 6 25 255 245 0 5 4 173 255 249 5 214 255 243 5 222 255 250 5 232 255 250 5 245 255 243 0 2 6 10 255 250 6 16 255 243 0 9 6 9 255 250 6 10 255 249 6 11 255 246 6 12 255 249 6 13 255 235 6 15 255 239 6 16 255 245 6 17 255 247 6 18 255 239 0 7 6 10 255 239 6 12 255 246 6 13 255 227 6 14 255 246 6 15 255 242 6 16 255 240 6 17 255 240 0 4 6 10 255 247 6 12 255 242 6 15 255 246 6 16 255 240 0 1 6 10 255 252 0 5 6 10 255 245 6 11 255 252 6 14 255 246 6 15 255 252 6 16 255 240 0 4 6 10 255 242 6 15 255 248 6 16 255 242 6 18 255 246 0 10 6 9 255 242 6 10 255 246 6 11 255 242 6 12 255 242 6 13 255 213 6 14 255 233 6 15 255 240 6 17 255 240 6 18 255 246 6 29 255 239 0 5 6 10 255 238 6 11 255 246 6 12 255 246 6 16 255 243 6 18 255 246 0 6 6 10 255 239 6 11 255 246 6 12 255 246 6 15 255 252 6 16 255 233 6 18 255 252 0 2 6 11 255 242 6 16 255 239 0 12 4 76 255 229 4 77 255 246 4 78 255 249 4 80 255 249 4 82 255 223 4 84 255 235 4 98 255 232 4 99 255 239 4 100 255 235 4 102 255 235 4 104 255 198 4 106 255 245 0 16 4 75 255 246 4 76 255 240 4 77 255 245 4 78 255 245 4 79 255 179 4 80 255 245 4 81 255 233 4 82 255 236 4 83 255 240 4 84 255 246 4 97 255 238 4 98 255 226 4 103 255 232 4 104 255 228 4 105 255 238 4 106 255 246 0 7 4 77 255 246 4 78 255 246 4 84 255 252 4 99 255 246 4 100 255 238 4 102 255 246 4 104 255 238 0 15 4 76 0 12 4 77 0 30 4 78 0 30 4 79 255 236 4 80 0 30 4 81 255 252 4 97 255 252 4 98 255 246 4 99 0 26 4 100 0 14 4 101 0 20 4 102 0 14 4 103 255 252 4 105 0 10 4 106 255 246 0 2 171 162 0 4 0 0 173 206 174 14 0 11 0 11 0 0 255 236 255 246 255 246 255 242 255 239 255 239 255 239 255 251 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 2 170 186 0 4 0 0 173 232 173 236 0 1 0 5 0 0 255 242 255 236 255 236 255 240 0 2 170 166 0 4 0 0 173 238 174 10 0 5 0 17 0 0 255 252 255 232 0 14 0 14 255 239 255 249 255 226 255 239 255 226 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 232 0 14 0 14 255 239 255 242 255 226 255 239 255 226 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 195 255 203 255 216 0 0 0 0 0 0 0 0 255 252 255 242 0 0 0 0 0 0 255 239 255 246 255 242 255 236 0 0 0 0 0 0 0 0 255 246 255 252 0 8 0 0 255 252 255 242 0 0 0 0 0 0 255 239 255 246 255 242 255 236 0 0 0 0 0 0 0 0 255 246 255 252 0 8 0 2 169 250 0 4 0 0 174 56 174 210 0 26 0 123 0 0 0 16 255 239 255 246 255 176 255 226 255 196 255 219 255 196 0 19 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 183 255 176 255 163 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 232 255 222 255 242 255 209 255 201 255 230 255 236 255 222 255 209 255 201 255 226 255 216 255 242 255 232 255 236 255 232 255 236 255 209 255 235 255 246 255 229 255 235 255 232 255 229 255 236 255 219 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 0 0 0 0 255 230 0 0 0 0 0 0 0 0 255 230 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 0 0 0 255 230 0 0 0 0 0 3 255 242 255 246 255 242 255 236 255 246 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 255 239 255 242 0 0 0 0 0 0 0 0 0 0 255 175 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 163 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 203 0 73 255 171 0 13 255 171 255 183 255 227 0 33 255 238 0 73 255 171 255 227 255 236 255 203 255 246 255 227 0 13 255 183 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 224 0 33 0 0 0 0 0 0 255 211 0 0 0 0 0 0 0 33 0 0 0 0 0 0 255 224 0 0 255 240 0 0 255 211 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 255 216 0 0 255 246 255 250 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 16 0 0 255 216 255 242 255 213 255 226 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 255 239 255 246 255 213 255 239 255 216 255 232 255 226 255 239 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 250 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 227 255 227 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 255 240 0 6 0 0 0 0 255 242 255 216 255 211 0 0 255 230 0 0 255 192 0 0 255 192 255 198 0 0 0 0 0 0 0 0 255 192 0 0 0 0 255 230 0 0 0 0 0 0 255 198 255 246 255 236 0 0 255 216 255 236 0 0 0 0 255 211 255 236 255 232 255 232 255 236 255 230 255 232 255 239 255 240 255 232 255 236 255 230 255 229 255 242 255 240 255 209 255 222 255 218 255 232 255 232 255 236 255 230 255 218 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 242 255 242 255 246 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 198 0 59 255 169 0 0 255 169 255 167 0 0 0 0 0 0 0 59 255 169 255 216 0 0 255 198 0 0 255 216 0 0 255 167 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 194 255 221 0 0 255 214 0 0 0 0 0 0 255 194 0 0 255 214 0 0 0 0 0 0 0 0 0 0 0 0 255 194 255 221 0 0 255 214 0 0 255 235 0 0 0 0 255 235 0 0 255 221 255 235 255 212 255 212 255 221 255 194 255 235 255 212 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 255 242 255 236 255 203 255 242 255 236 255 236 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 0 0 255 242 255 203 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 255 236 0 0 0 0 255 203 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 255 240 255 236 0 6 0 0 0 19 0 13 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 0 0 255 240 0 6 0 0 255 203 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 3 0 19 255 203 0 3 0 6 0 13 255 236 0 3 0 0 0 0 0 0 0 0 0 0 0 0 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 255 240 255 236 0 10 0 0 0 33 0 26 0 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 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 0 0 255 240 0 10 0 0 255 183 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 6 0 33 255 183 0 6 0 10 0 26 255 236 0 6 0 0 0 0 0 0 0 0 0 0 0 0 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 213 255 240 255 236 0 10 0 0 0 26 0 14 0 14 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 213 0 0 255 240 0 10 0 0 255 163 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 26 255 163 0 0 0 10 0 14 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 213 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 255 250 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 186 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 186 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 205 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 25 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 25 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 255 225 0 0 0 0 255 225 0 9 255 232 255 225 255 246 255 246 255 232 0 0 255 225 255 246 0 0 0 0 0 25 255 176 0 58 0 25 255 176 255 242 0 9 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 221 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 255 249 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 0 0 0 0 255 242 0 0 0 0 255 245 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 255 249 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 221 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 236 0 0 0 0 255 252 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 245 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 255 249 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 215 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 232 0 0 0 0 255 252 0 0 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 0 0 0 0 0 0 0 0 0 0 255 239 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 221 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 236 0 0 0 0 255 252 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 255 232 0 2 145 38 0 4 0 0 157 74 161 200 0 75 0 71 0 0 255 242 255 232 255 240 255 252 255 232 255 244 255 240 255 202 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 193 0 0 0 0 0 0 0 0 255 209 0 0 0 10 0 7 255 250 255 226 255 246 255 246 255 250 0 3 255 246 255 253 0 20 0 20 255 240 255 229 255 227 255 216 255 213 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 201 255 242 0 0 255 242 255 230 255 200 255 162 0 0 0 0 0 20 0 0 0 14 0 16 0 15 0 20 0 13 0 24 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 23 255 250 255 246 0 20 255 246 0 23 255 250 255 241 255 249 255 252 255 252 0 4 255 249 255 248 255 189 255 201 255 216 255 176 255 204 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 255 242 0 0 255 252 0 0 255 252 255 246 255 252 0 4 255 246 0 0 255 246 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 232 255 250 255 252 255 242 0 0 255 236 255 226 0 10 255 250 0 4 0 0 0 16 0 10 0 16 0 0 0 6 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 0 0 0 0 0 0 0 255 242 255 246 255 246 255 252 255 242 255 252 255 242 0 0 0 0 0 0 255 236 0 0 0 0 255 240 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 236 255 242 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 6 0 8 0 0 0 6 0 0 0 0 0 0 0 0 0 20 0 0 0 0 0 0 0 0 0 0 255 246 255 235 255 236 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 248 255 240 255 249 0 0 0 0 0 9 0 0 255 250 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 255 229 255 236 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 229 255 238 255 252 255 252 255 249 0 0 0 0 0 0 0 7 0 0 0 0 255 236 0 0 0 0 0 0 0 15 0 0 0 0 0 0 0 0 255 204 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 227 0 0 255 246 255 242 255 242 255 246 0 0 255 252 255 242 255 246 0 0 0 0 0 0 0 10 0 24 0 0 0 0 255 246 255 232 255 236 0 0 255 230 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 232 255 240 255 246 255 230 255 249 255 246 255 222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 0 5 255 249 0 0 0 5 0 0 0 0 0 0 255 236 0 0 255 239 0 0 0 0 255 236 255 236 255 246 0 0 0 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 255 236 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 255 246 255 242 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 225 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 46 0 66 0 46 0 59 0 26 0 34 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 206 255 236 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 13 0 0 255 252 0 33 0 0 0 0 0 34 0 40 0 62 0 75 0 76 0 0 0 0 0 0 0 0 255 242 255 246 255 242 0 0 0 0 0 0 255 246 255 242 0 49 0 14 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 167 255 242 0 6 0 0 0 9 0 3 0 0 0 9 255 246 0 0 255 182 0 0 0 0 0 25 0 13 0 25 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 4 0 4 0 0 0 0 0 0 0 0 255 216 255 156 255 232 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 184 255 242 0 0 0 0 0 0 0 0 255 222 255 219 0 0 0 0 255 246 255 236 255 240 0 0 255 236 255 240 255 230 255 232 255 240 255 226 0 0 0 0 0 0 0 20 0 38 0 0 0 0 255 118 255 236 255 232 255 242 0 0 255 236 0 0 0 0 0 0 255 226 0 0 0 0 255 187 255 249 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 0 0 0 255 240 255 200 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 255 240 255 242 0 6 0 0 255 240 0 0 255 208 255 189 255 230 255 221 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 255 242 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 184 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 230 0 0 0 0 255 242 255 220 0 0 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 248 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 252 0 0 0 0 0 15 0 0 0 0 0 0 0 0 0 14 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 37 255 242 0 14 0 0 0 48 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 253 255 250 0 0 0 0 0 0 0 3 255 252 0 0 0 0 0 0 0 0 255 246 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 242 255 252 0 0 0 0 0 0 255 228 0 14 0 0 0 0 0 0 0 11 0 19 0 13 0 13 0 9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 19 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 8 0 12 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 19 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 243 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 13 0 13 0 19 0 13 0 23 0 28 0 9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 15 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 242 0 0 0 0 0 0 255 239 255 239 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16 0 0 0 0 0 13 0 13 0 19 0 13 0 19 0 19 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 255 220 0 3 0 13 0 13 0 13 0 13 0 6 0 13 0 6 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 235 255 221 0 0 0 0 255 245 255 244 255 230 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 0 13 255 230 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 255 246 255 238 255 212 255 230 0 0 255 245 255 246 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 0 0 255 242 255 246 255 249 0 0 255 252 255 252 0 0 0 20 0 20 255 236 0 0 255 252 255 249 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 255 239 255 244 255 246 255 240 255 249 255 238 255 216 0 20 0 26 0 6 0 0 0 3 0 5 0 5 255 242 255 242 0 3 0 0 0 0 255 210 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 9 255 236 0 0 255 242 255 242 255 236 255 240 255 240 0 0 255 236 0 0 255 238 255 235 0 0 0 0 0 9 0 0 0 0 0 0 255 247 0 0 255 249 255 226 255 246 0 0 255 252 255 246 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 247 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 241 0 0 0 0 0 0 0 0 0 0 255 244 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 53 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 8 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 161 0 0 0 16 0 0 255 246 255 176 255 226 255 196 255 219 0 0 255 196 0 0 0 0 0 19 0 0 255 221 0 0 255 169 0 0 0 0 0 0 0 0 255 239 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 229 0 0 0 0 0 0 0 0 0 0 0 0 255 220 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 136 255 180 255 200 255 180 255 224 255 178 255 104 0 16 0 0 0 0 255 212 0 0 255 229 255 242 0 0 255 202 0 0 0 0 0 0 255 164 0 0 0 0 0 0 0 0 0 0 0 3 255 242 0 0 255 230 0 0 255 246 255 227 255 220 255 222 0 0 0 0 255 220 0 0 255 178 255 167 255 176 255 164 255 158 0 0 0 0 0 0 255 234 255 252 255 244 255 202 255 222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 255 246 0 0 255 240 255 249 255 236 255 222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 0 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 9 0 11 0 20 0 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 255 252 0 20 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 27 0 27 0 27 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 255 199 255 237 0 0 255 210 255 244 255 230 255 231 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 252 255 239 255 252 255 252 0 0 255 242 255 227 255 230 255 249 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 255 250 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 255 230 0 0 255 230 0 0 255 247 255 250 255 242 255 236 255 239 0 0 255 229 0 0 255 236 0 0 255 245 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 255 246 255 250 255 236 0 0 0 0 255 222 0 3 255 232 0 3 0 6 0 16 0 11 0 15 0 6 0 13 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 15 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 239 0 0 255 236 0 0 0 0 0 0 0 6 255 230 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 255 238 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 220 255 137 255 247 255 236 0 0 0 0 0 0 255 232 0 0 255 220 0 0 255 150 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 243 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 255 246 0 0 0 0 0 0 255 210 255 136 0 0 0 4 0 0 0 14 0 0 0 0 0 13 0 0 0 0 255 144 255 248 0 0 0 0 0 0 0 0 255 213 255 206 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 255 242 255 232 0 0 255 178 0 0 0 0 0 0 0 30 0 0 0 0 0 0 255 110 255 246 255 226 255 232 255 223 255 236 0 0 0 0 0 0 255 236 0 0 0 0 255 181 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 18 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 25 255 199 255 240 0 0 0 0 0 0 0 0 255 232 255 242 0 0 0 0 0 0 255 252 0 0 0 0 0 25 0 19 0 0 0 0 0 25 255 246 0 33 0 0 0 13 0 62 0 0 0 0 0 0 255 201 0 0 255 246 255 246 255 232 255 236 0 0 0 0 0 0 255 252 0 0 0 0 255 222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 255 236 255 246 255 240 0 0 0 0 0 0 0 0 255 246 255 246 0 0 0 0 0 0 255 235 0 0 255 249 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 5 0 6 0 0 0 0 0 0 255 246 0 7 255 253 0 0 0 6 0 3 0 13 0 13 0 6 0 16 0 10 0 0 0 0 255 246 0 0 0 0 0 0 0 0 255 252 255 252 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 252 0 0 255 246 0 0 0 0 0 0 0 25 0 0 0 0 0 0 255 238 255 242 255 252 255 246 255 225 255 226 0 0 255 242 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 232 255 246 0 0 255 236 255 245 255 245 255 207 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 246 255 236 0 0 0 0 0 0 0 0 0 0 255 250 0 0 0 0 255 252 255 252 0 0 0 9 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 0 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 255 236 0 0 0 0 255 242 0 0 255 245 255 240 0 23 255 246 0 0 0 3 0 19 0 16 0 23 0 13 0 9 0 6 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 29 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 0 0 0 255 242 255 242 0 0 0 0 0 14 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 194 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 198 255 222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 242 0 0 0 0 255 252 255 230 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 14 0 7 255 236 0 0 0 0 0 0 0 0 255 235 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 34 0 0 0 0 0 0 0 0 0 0 255 246 255 242 255 230 255 238 0 0 255 242 0 0 0 0 0 0 0 0 0 10 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 255 143 255 223 0 0 0 0 0 0 0 0 255 236 255 246 255 227 0 0 255 169 0 0 0 0 0 10 0 6 0 10 0 0 0 0 0 0 255 230 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 210 0 0 0 0 0 0 0 0 255 227 255 220 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 191 0 0 0 0 0 0 0 0 0 0 0 0 255 238 0 0 0 0 0 0 255 242 0 0 0 0 0 0 255 193 255 136 255 197 255 238 255 211 255 230 255 230 255 230 255 223 255 211 255 236 255 150 255 192 0 0 0 0 0 0 0 0 255 183 255 216 255 238 255 196 255 232 255 197 255 210 0 0 255 223 255 222 255 217 255 236 255 223 255 202 0 0 0 0 0 0 0 20 0 34 0 0 0 0 255 130 255 217 255 183 255 190 255 183 255 209 0 0 255 216 0 0 255 181 0 0 0 0 255 167 0 0 255 210 0 0 0 0 0 0 0 0 255 171 255 211 0 0 0 0 0 0 0 0 0 17 0 0 0 0 0 0 0 0 0 9 0 24 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 21 0 0 0 0 0 0 0 0 0 0 0 10 0 10 0 0 0 0 0 10 0 0 0 44 0 47 0 49 0 73 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 17 0 0 0 50 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 14 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 0 0 0 0 0 47 0 47 0 47 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 53 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 8 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 53 0 20 0 47 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 207 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 242 0 0 255 226 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 250 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 250 0 0 0 0 0 0 0 0 0 0 255 246 255 220 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 255 242 0 0 0 0 0 0 255 252 255 223 0 6 0 10 0 6 0 6 0 13 0 6 0 19 0 0 0 0 255 240 0 0 0 0 0 0 0 0 0 0 255 252 255 240 0 0 0 10 0 0 255 252 0 0 0 0 0 0 0 0 255 249 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 209 255 246 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 225 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 247 0 0 255 242 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 221 0 0 0 0 0 0 0 0 0 0 255 236 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 45 0 9 0 0 0 0 255 216 0 0 0 0 255 252 255 249 0 0 0 0 0 0 255 246 255 232 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 193 255 246 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 255 196 0 0 0 20 0 33 0 19 0 26 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 0 0 0 0 0 0 13 0 0 255 252 255 193 0 0 0 20 255 253 0 16 0 10 0 0 0 20 0 0 0 0 255 191 255 245 0 0 0 0 0 0 0 0 255 234 255 242 0 0 255 250 255 246 255 244 255 226 255 246 255 247 255 247 255 241 0 0 255 247 255 237 0 0 0 0 0 0 0 53 0 54 255 252 0 0 255 183 255 246 255 235 255 241 255 237 255 235 0 0 255 237 0 0 255 231 0 0 0 0 255 209 0 0 255 236 0 0 255 252 0 0 0 0 0 0 255 250 0 0 0 0 0 0 0 0 0 0 255 232 255 247 0 0 255 232 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 215 0 0 0 0 0 0 0 0 0 0 255 246 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 38 0 10 0 0 0 0 255 226 0 0 0 0 255 252 0 0 0 0 0 0 0 0 255 246 255 239 0 0 0 0 255 248 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 250 255 197 255 250 0 0 0 0 0 0 0 0 0 0 0 0 255 243 0 0 255 213 0 0 0 20 0 26 0 13 0 14 0 0 0 0 0 0 255 250 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 250 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 0 0 0 6 255 210 0 0 0 20 0 10 0 16 0 16 0 16 0 26 0 4 0 0 255 222 0 0 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 4 255 250 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 250 0 0 0 0 0 0 0 39 0 34 0 0 0 0 255 191 255 250 255 243 0 0 255 246 255 246 0 0 255 240 0 0 255 246 0 0 0 0 255 227 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 255 223 255 241 0 0 255 222 0 0 0 0 255 233 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 236 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 38 0 9 0 0 0 0 0 0 255 252 0 0 255 239 255 242 255 232 0 0 255 236 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 3 0 0 255 246 255 236 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 255 236 0 0 0 6 0 3 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 255 236 0 0 0 0 0 0 0 0 255 249 255 246 0 16 0 20 0 6 255 236 0 3 0 3 0 6 0 0 0 5 0 6 0 0 0 0 255 216 0 0 0 0 0 0 0 0 255 246 0 3 255 240 0 0 255 239 0 0 255 246 255 246 255 240 255 242 255 246 0 0 255 240 0 0 255 249 255 246 0 0 0 8 0 21 0 0 0 0 0 0 255 242 0 0 255 249 255 229 255 242 0 0 255 242 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 255 236 255 252 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 221 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 252 0 0 0 0 0 0 0 0 0 0 0 45 0 13 0 0 0 0 255 216 0 0 0 0 255 252 0 0 255 252 0 0 255 252 255 246 255 232 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 163 255 242 255 246 0 0 0 0 0 0 0 0 255 246 255 236 0 0 255 182 0 0 0 33 0 26 0 13 0 14 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 228 255 242 0 0 0 0 0 0 255 249 0 9 0 0 255 229 255 156 255 221 0 10 255 236 0 9 0 3 0 0 0 14 255 229 255 231 255 165 255 210 0 0 0 0 0 0 0 0 255 189 255 242 0 0 255 229 255 242 255 215 255 222 255 246 255 242 255 232 255 222 0 0 255 242 255 230 0 0 0 0 0 0 0 33 0 46 255 245 0 0 255 156 255 240 255 196 255 215 255 190 255 201 0 0 255 219 0 0 255 209 0 0 0 0 255 189 0 0 255 216 0 0 255 249 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 255 230 0 0 0 0 255 227 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 245 0 0 0 0 0 0 0 0 255 233 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 252 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 25 0 13 0 0 0 0 0 0 0 0 255 250 255 246 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 253 255 237 255 230 0 0 0 0 255 250 255 250 0 0 255 250 255 243 0 0 0 0 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 0 0 0 0 0 0 0 0 0 0 255 223 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 250 255 250 255 242 0 0 0 0 0 0 0 7 0 0 0 0 0 0 0 0 255 246 0 0 255 253 255 251 0 0 0 0 0 0 255 196 0 0 0 0 0 0 0 0 255 240 255 250 255 236 255 240 255 236 0 0 255 233 255 246 255 240 255 240 255 232 0 0 255 240 255 240 0 0 0 0 0 0 0 20 0 20 0 0 0 0 255 223 255 226 255 242 255 235 255 222 255 222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 104 64 0 4 0 0 124 114 127 22 0 57 0 71 0 0 255 252 255 245 0 6 255 245 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 3 255 252 255 236 255 226 255 193 255 246 255 253 0 20 0 20 255 209 255 240 255 229 255 227 255 216 255 213 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 246 0 0 255 246 255 242 0 0 0 20 0 0 0 0 0 0 255 201 0 13 0 24 0 0 0 0 255 200 255 232 0 0 0 0 0 0 0 0 255 250 0 4 0 6 255 249 255 210 0 20 255 246 255 242 255 248 255 230 255 189 255 201 255 162 255 216 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 236 0 0 255 242 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 255 242 0 0 255 246 255 252 0 4 255 246 255 242 0 0 255 246 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 255 246 0 10 0 0 0 0 0 0 0 0 255 232 0 6 0 0 0 0 0 0 255 236 255 236 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 255 250 0 10 0 0 255 242 255 252 0 0 255 242 0 0 255 226 0 0 0 0 0 0 0 0 255 252 255 252 255 250 255 250 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 246 255 230 255 232 0 0 0 0 0 0 0 0 0 0 255 223 0 0 0 0 0 0 255 249 0 0 255 236 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 255 246 255 222 0 0 0 0 0 0 0 0 255 233 0 0 255 242 255 230 0 0 0 0 255 229 0 0 0 0 255 239 255 240 255 242 255 236 255 246 0 7 255 239 255 240 255 246 255 242 255 242 255 232 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 0 255 235 255 236 0 0 255 252 0 0 0 0 0 0 255 252 255 236 0 0 0 6 0 3 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 242 255 252 255 242 255 240 0 16 0 0 0 0 0 0 255 236 255 236 0 5 0 6 0 0 0 0 255 249 255 216 0 0 0 0 0 0 0 0 0 3 0 0 0 0 255 225 255 242 0 0 255 239 0 0 0 0 0 0 255 249 255 246 255 246 0 0 0 0 0 0 0 0 0 0 255 235 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 255 249 255 232 0 0 255 229 0 0 255 242 255 242 0 47 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 236 0 0 255 236 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 246 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 255 226 0 0 255 246 0 0 0 0 0 0 255 201 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 246 255 232 0 0 0 0 0 0 0 0 0 0 255 199 0 0 0 0 0 0 0 0 255 192 255 229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 235 255 192 0 0 255 232 255 235 0 0 0 0 255 200 255 201 0 0 0 0 0 0 0 0 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 249 0 0 0 0 0 0 0 0 0 0 255 195 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 245 255 249 255 252 255 249 255 241 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 252 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 246 255 252 0 0 0 0 255 242 255 242 255 246 0 0 0 0 0 0 255 252 0 0 0 0 0 0 255 252 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 255 252 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 225 255 232 0 0 255 232 255 232 0 10 0 0 0 0 0 0 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 240 255 246 0 0 0 0 255 246 255 232 255 240 0 0 0 0 0 0 0 0 0 20 0 0 0 0 255 246 255 246 255 221 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 216 0 0 255 241 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 241 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 246 0 0 0 0 255 241 0 0 0 0 0 0 0 0 255 249 255 253 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 196 255 226 0 0 0 0 0 0 0 0 255 236 0 0 0 0 255 161 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 230 0 0 0 0 0 0 255 249 0 20 0 0 0 0 0 0 0 0 0 0 255 200 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 200 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 255 196 255 230 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 255 211 255 193 255 211 255 214 255 163 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 127 0 0 255 216 0 0 0 0 0 0 0 0 255 196 255 239 255 239 255 178 0 0 0 0 255 220 0 0 255 210 0 0 0 0 0 0 0 0 0 0 255 202 255 131 0 0 255 182 255 249 0 0 0 0 255 151 255 240 255 216 255 171 255 178 0 0 255 151 255 220 255 204 255 161 0 0 255 183 255 191 0 67 255 223 0 27 0 0 255 220 0 0 0 0 0 0 0 0 255 197 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 252 255 252 255 246 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 0 7 255 229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 255 252 0 0 0 0 255 250 0 0 0 0 0 0 0 0 0 0 255 247 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 235 255 252 255 235 255 235 0 0 0 0 0 0 0 0 0 0 255 221 0 0 0 0 0 13 0 13 255 230 255 230 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 245 0 0 255 244 0 0 0 0 255 235 0 0 255 249 255 252 0 0 0 0 255 231 0 0 0 0 255 238 0 0 255 249 0 0 0 0 0 0 255 238 255 249 255 252 255 212 0 0 255 230 255 245 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 249 0 0 255 242 0 0 255 252 0 0 0 20 0 20 0 0 255 236 0 0 255 252 255 249 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 245 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 255 229 255 252 255 229 255 223 0 20 255 242 0 0 0 0 0 0 255 239 255 242 0 3 0 0 0 0 255 238 255 210 0 0 0 0 0 0 0 0 255 246 0 0 0 0 255 229 255 242 0 9 255 236 255 240 0 0 255 249 255 238 255 235 255 216 0 0 0 0 0 0 0 0 0 0 255 239 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 255 249 255 246 255 252 255 226 0 0 255 246 255 252 0 27 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 255 235 255 252 255 235 255 225 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 0 7 255 163 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 255 209 0 0 0 0 255 252 0 0 255 252 0 0 0 0 0 0 255 249 255 249 255 246 0 0 0 0 0 0 255 242 255 246 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 241 0 0 255 241 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 241 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 246 0 0 0 0 255 241 0 0 0 0 0 0 0 0 255 249 255 253 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 230 0 0 255 246 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 255 252 0 0 0 0 255 252 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 255 249 255 220 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 176 0 0 0 0 0 0 255 209 255 223 0 0 0 0 0 0 0 0 0 0 255 249 255 225 0 0 0 0 255 240 0 0 0 0 255 242 255 219 255 236 255 243 255 223 0 0 0 0 0 0 255 252 0 0 255 235 255 221 255 222 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 241 0 0 0 0 0 0 0 0 255 239 0 0 0 0 255 241 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 162 0 0 255 240 0 0 0 0 0 0 0 0 255 210 255 242 0 0 255 240 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 255 230 0 0 255 192 255 229 255 240 0 0 255 230 0 0 255 236 255 226 255 250 0 0 255 230 0 0 255 246 255 216 0 0 0 0 255 236 0 40 0 0 0 16 0 0 0 0 255 229 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 220 255 232 0 0 0 0 255 236 0 0 0 0 255 220 0 0 255 150 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 243 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 220 0 0 0 0 0 0 255 246 255 232 0 0 0 0 0 0 0 0 255 242 0 6 0 0 0 6 0 0 255 210 0 0 0 0 0 0 0 4 255 232 0 13 0 0 0 0 255 144 0 0 255 248 0 0 0 0 0 0 0 0 255 206 255 232 0 0 0 0 0 0 0 0 0 0 255 246 255 178 0 0 0 0 0 0 0 0 0 0 0 0 255 207 0 0 255 199 255 209 255 216 255 239 255 232 0 0 255 232 255 240 0 0 0 0 255 232 0 0 0 0 255 223 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 46 255 181 0 0 0 0 255 239 255 239 0 0 255 239 255 239 0 0 0 0 0 0 0 0 0 0 255 199 0 0 0 0 0 0 255 246 255 230 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 255 210 0 0 255 244 255 242 255 227 255 231 255 230 255 246 0 0 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 255 230 0 0 255 236 255 239 0 0 255 229 255 236 0 0 255 236 0 0 255 245 255 240 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 255 246 255 236 0 0 0 0 0 13 0 0 255 242 0 0 0 0 0 0 0 0 0 3 0 6 0 0 0 0 0 6 255 232 0 13 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 239 0 0 0 0 0 0 0 15 0 0 255 236 255 236 0 0 0 0 0 0 255 222 0 0 0 0 0 0 0 0 255 232 255 235 255 220 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 238 0 0 0 0 0 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20 0 0 0 0 0 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 249 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 255 229 0 0 0 0 0 0 0 0 255 246 255 252 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 250 0 0 255 223 255 231 255 243 0 0 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 227 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 255 250 0 0 0 0 0 0 0 0 255 243 0 0 0 0 0 0 0 0 255 229 255 232 255 252 255 232 255 200 0 0 0 0 0 0 0 0 0 0 255 220 0 0 0 0 0 0 0 0 255 236 255 196 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 190 255 226 0 0 255 210 255 232 255 236 0 0 255 236 255 243 0 0 0 0 255 232 0 0 0 0 0 0 0 0 255 236 0 0 255 246 0 0 255 240 255 246 0 0 0 0 255 240 255 216 255 246 255 223 0 0 0 0 0 0 0 20 0 0 0 0 255 233 255 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 255 223 0 0 255 230 255 236 0 0 0 0 255 230 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 23 0 0 0 0 0 13 0 0 0 28 0 9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 15 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 255 243 255 242 255 236 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 14 0 7 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 255 230 0 0 0 0 0 0 0 0 0 0 255 238 0 0 0 0 255 236 0 0 0 0 255 242 0 0 0 0 255 250 0 0 0 0 255 242 255 251 0 0 255 230 0 0 255 238 255 242 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 255 236 0 0 0 0 0 0 0 0 255 246 255 227 0 0 255 169 0 0 0 0 0 0 0 10 0 6 0 10 0 0 0 0 0 0 0 0 0 0 255 230 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 210 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 227 0 0 255 220 255 242 0 0 0 0 0 0 0 0 0 0 0 0 255 226 255 230 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 217 255 230 255 222 255 230 255 238 255 193 255 230 0 0 0 0 255 238 0 0 255 223 255 211 255 236 255 150 0 0 255 192 0 0 0 0 0 0 0 0 255 216 255 236 255 242 255 194 0 0 255 196 255 232 255 242 255 202 0 0 0 0 0 0 0 0 0 0 255 214 255 175 0 0 255 199 255 242 255 246 0 0 255 190 255 240 255 220 255 189 255 210 0 0 255 190 255 220 255 211 255 183 0 0 255 209 255 216 0 47 255 211 0 0 0 0 255 226 0 0 0 0 0 0 0 0 255 210 0 0 0 0 0 25 255 167 0 0 0 0 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 246 0 0 255 246 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 249 255 239 255 246 0 0 255 246 255 236 0 0 255 182 0 0 0 0 0 33 0 26 0 13 0 14 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 242 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 246 0 0 0 0 255 246 255 246 0 0 0 0 0 0 0 0 255 222 255 229 255 216 255 242 255 228 255 229 0 0 0 0 0 0 0 10 255 242 0 14 255 229 255 231 255 165 0 9 255 210 0 0 0 0 0 0 0 0 255 242 0 0 255 242 255 242 0 0 255 229 255 242 0 0 255 230 255 249 0 0 0 0 0 0 0 0 255 219 255 205 0 0 255 235 255 241 0 0 0 0 255 215 255 236 255 230 255 215 255 216 0 0 255 215 255 242 255 216 255 190 0 0 255 201 255 219 0 67 255 242 0 0 0 0 255 252 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 76 255 189 0 0 0 0 0 35 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 25 0 9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16 0 0 0 0 0 33 0 0 0 0 255 245 0 0 0 0 255 249 0 0 0 0 255 245 0 0 255 249 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 38 0 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 252 255 236 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 255 246 255 230 255 246 255 229 0 0 0 0 0 0 0 20 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 35 255 225 255 239 255 225 255 199 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 19 0 9 255 221 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16 0 0 0 0 0 33 0 0 0 0 255 222 0 16 255 236 255 249 0 0 0 0 255 222 255 229 255 232 255 236 0 0 0 0 255 252 0 60 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 38 0 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 253 0 0 255 220 0 0 0 0 0 0 255 250 255 243 0 0 0 0 0 0 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 255 240 255 252 255 240 255 242 0 7 255 253 0 0 0 0 0 0 0 0 255 251 0 0 0 0 0 0 0 0 255 196 0 0 0 0 0 0 0 0 255 250 0 0 255 250 255 219 255 243 255 240 255 236 255 242 255 240 0 0 0 0 0 0 0 0 0 0 255 230 0 0 0 0 0 0 0 0 255 240 0 0 255 235 0 0 255 220 255 240 0 0 0 0 255 235 255 220 255 233 255 222 0 0 255 222 0 0 0 35 0 0 0 0 255 250 255 240 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 72 186 0 4 0 0 98 216 102 234 0 60 0 114 0 0 255 240 255 242 255 232 255 229 255 244 255 240 255 202 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 193 0 0 0 0 255 209 0 0 0 10 255 200 0 7 255 250 255 252 0 7 0 3 255 246 0 7 255 226 255 240 0 20 0 20 255 246 255 240 255 229 255 227 255 216 255 213 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 242 255 201 255 216 255 230 255 200 255 162 0 0 255 220 0 7 0 20 0 0 0 7 0 20 0 16 0 0 0 0 0 0 0 0 0 0 0 13 255 232 0 0 0 0 0 0 0 0 0 23 255 250 255 229 255 176 0 20 0 7 0 23 0 25 255 249 0 20 0 7 255 252 0 4 255 249 0 20 255 246 255 249 255 203 0 13 255 246 0 20 255 246 0 20 255 242 255 216 0 14 255 241 255 242 0 16 255 242 0 15 0 20 0 4 255 242 255 242 0 24 255 189 255 201 255 216 255 176 255 204 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 222 0 0 255 212 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 247 0 0 0 0 0 0 255 246 255 235 0 0 255 246 0 0 255 239 0 0 255 252 0 0 0 0 255 249 0 0 255 226 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 252 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 255 220 0 0 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20 0 0 0 0 0 0 0 0 0 6 0 0 255 252 0 0 255 252 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 255 223 0 0 0 0 0 0 0 0 0 0 0 0 255 250 0 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 235 255 201 0 0 0 0 255 202 0 0 0 0 0 0 0 0 0 0 255 242 255 240 255 196 255 216 0 0 0 0 255 229 0 0 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 209 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 255 212 255 156 255 205 255 232 255 189 0 0 0 0 255 222 0 0 0 0 0 0 0 0 0 0 255 252 255 240 255 239 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 255 182 0 0 0 0 0 0 255 242 255 249 255 252 0 0 255 249 255 249 255 241 0 0 255 249 255 245 255 176 255 229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 180 255 203 0 0 0 0 0 0 255 245 255 252 0 0 255 242 0 0 255 252 255 246 255 242 255 229 255 229 255 245 255 229 255 249 255 236 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 236 255 232 255 232 255 245 255 245 255 207 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 255 246 0 0 0 0 0 0 0 0 255 246 255 236 255 236 0 0 0 0 0 0 255 252 255 252 0 0 0 9 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 255 236 255 226 0 0 255 245 255 240 0 23 255 246 0 0 0 0 0 0 0 0 0 13 0 16 255 246 0 3 255 236 0 0 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 228 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 29 0 0 0 0 255 229 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 242 0 0 255 252 255 235 0 0 0 0 0 0 0 14 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 236 0 0 255 252 255 236 255 240 255 236 0 0 255 240 255 239 0 0 255 210 255 213 255 236 0 0 255 240 255 242 0 6 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 226 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16 0 0 0 16 0 0 255 252 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 255 176 255 236 255 236 255 223 0 0 0 0 0 0 255 240 0 0 0 0 255 240 0 0 0 0 255 196 0 0 0 0 0 0 255 209 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 249 0 0 0 0 255 242 255 217 0 0 255 252 0 0 255 242 255 217 255 252 255 225 0 0 0 0 0 0 0 0 255 209 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 243 255 223 0 0 0 0 0 0 255 252 255 252 0 0 0 0 0 0 0 0 255 232 0 0 255 201 255 252 255 246 255 205 255 230 0 0 255 222 0 6 0 0 0 0 255 236 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 220 0 0 255 211 255 247 0 0 255 211 255 232 0 0 255 137 255 236 255 236 0 0 255 150 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 243 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 255 210 0 0 255 178 0 0 0 0 255 178 0 0 0 14 255 136 0 4 0 0 0 0 255 144 0 0 255 248 0 0 0 0 0 0 0 0 255 213 255 206 0 0 0 0 255 207 255 171 255 246 0 0 0 0 255 196 255 171 255 242 255 232 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 255 236 0 0 255 110 255 245 0 0 255 200 0 0 0 0 0 0 255 223 255 236 0 0 255 246 0 0 0 0 0 0 255 232 255 181 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 246 255 236 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 255 246 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 13 0 0 0 8 0 0 0 6 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 8 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 242 0 0 0 0 0 0 0 0 0 0 255 235 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 255 248 255 216 0 0 0 9 0 0 255 252 255 240 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 229 255 236 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 229 255 238 255 216 0 0 0 0 0 0 0 7 255 209 0 0 0 0 0 0 0 0 0 15 0 0 0 0 255 236 255 216 0 0 0 0 0 0 255 204 0 0 0 0 0 0 0 0 0 0 0 0 255 216 255 236 0 0 0 0 0 0 0 0 255 212 0 0 0 0 0 0 255 252 255 242 0 0 255 227 255 242 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 246 0 0 0 0 255 246 0 0 0 0 0 0 255 230 255 242 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 156 0 0 0 0 0 0 0 0 0 0 0 0 255 222 0 0 0 0 0 0 255 207 0 0 255 242 255 242 0 0 255 196 0 0 255 242 0 0 255 246 0 0 0 0 255 246 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 0 0 0 0 0 58 0 0 255 213 255 246 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 211 255 223 0 0 0 0 0 0 0 0 0 0 255 213 0 0 255 232 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 13 0 0 255 196 0 0 255 180 255 226 255 197 255 180 255 226 0 9 255 90 0 0 255 243 0 0 255 161 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 230 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 255 200 0 0 255 200 0 0 0 0 255 249 255 226 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 214 0 0 255 227 0 0 0 0 0 0 255 163 255 211 255 131 255 183 0 0 255 131 0 0 0 0 255 76 0 0 0 0 255 236 255 127 0 0 255 216 0 0 0 0 0 0 0 0 255 163 255 196 255 197 0 0 255 151 255 147 255 187 255 203 255 178 255 143 255 147 255 226 255 239 255 211 0 0 255 220 255 211 255 231 255 191 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20 0 0 255 147 0 0 255 201 0 7 0 0 0 0 255 191 255 207 255 63 0 0 255 216 255 216 0 0 255 191 0 0 255 161 255 183 0 0 255 210 0 0 0 0 255 183 255 151 0 0 0 0 0 0 0 0 255 197 255 197 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 241 255 232 255 223 255 226 0 0 0 0 255 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 255 249 0 0 255 236 0 0 0 0 0 0 0 0 255 246 0 0 255 242 0 0 0 15 0 0 0 0 0 8 0 0 0 0 0 0 0 0 255 246 255 250 0 0 255 246 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 255 249 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 255 236 0 0 255 242 255 232 0 0 255 252 0 0 0 0 0 0 255 239 0 0 255 249 0 0 255 249 0 0 0 0 0 0 0 7 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 3 255 229 0 0 255 246 255 239 0 0 0 0 0 0 0 0 255 236 255 242 0 0 0 0 0 0 255 236 0 0 0 6 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 239 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 255 236 255 232 0 0 255 249 255 246 0 16 255 209 0 0 0 6 0 0 0 0 0 0 0 3 0 20 255 236 255 229 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 255 246 0 3 255 219 255 242 0 0 0 0 0 0 0 13 255 225 0 0 0 0 255 246 0 0 255 240 0 0 255 239 255 240 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 255 249 255 246 0 0 255 236 0 0 255 229 255 242 0 0 255 242 0 0 0 0 255 249 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 240 255 246 255 232 255 229 255 249 255 246 255 222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 5 0 0 0 0 0 5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 255 252 255 252 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 255 246 0 0 0 0 255 242 0 0 0 0 0 0 0 0 255 252 255 240 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 255 236 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 255 233 0 0 0 0 0 0 0 10 255 236 0 0 255 242 0 0 0 0 0 0 0 0 255 246 255 240 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 233 255 246 0 0 0 0 0 0 0 0 255 229 0 0 0 0 255 225 0 0 255 246 0 0 0 0 255 246 255 243 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 233 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 255 246 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 26 0 0 0 26 0 0 0 45 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 255 209 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 0 20 0 0 255 240 0 0 0 0 0 23 0 0 255 240 0 0 0 16 0 0 0 26 0 0 0 0 0 23 0 0 0 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 60 0 33 0 0 0 98 0 0 255 246 0 13 0 13 0 14 0 0 0 0 0 0 0 20 0 0 0 0 0 0 0 0 0 0 0 6 0 0 255 246 255 240 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 40 0 0 0 0 0 0 255 240 0 0 0 0 255 240 0 16 0 53 255 189 0 40 0 15 0 0 255 196 0 53 0 0 0 29 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 27 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 53 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 242 0 0 0 40 255 252 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 60 0 0 0 40 0 0 0 29 0 47 0 0 255 242 0 0 255 223 255 236 0 0 255 223 0 0 0 0 255 176 0 0 0 0 255 240 255 176 0 0 0 0 0 0 0 0 0 0 0 0 255 240 0 0 255 246 0 16 255 223 255 223 255 246 0 0 255 250 255 216 255 223 255 246 0 23 0 0 0 0 0 0 255 246 0 15 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 47 0 24 0 0 0 0 0 0 255 232 0 0 255 242 0 45 0 20 0 0 0 0 0 0 255 156 0 53 0 0 0 0 0 53 255 236 0 53 255 223 255 229 0 0 0 0 0 0 0 53 0 0 255 239 0 0 0 0 0 0 0 0 255 236 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 24 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 255 229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 3 0 0 0 0 0 6 0 13 255 220 0 13 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 0 0 255 229 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 239 0 0 0 15 0 0 255 252 0 8 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 22 0 0 255 241 255 249 0 0 255 246 255 252 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 255 236 0 0 255 232 255 242 0 0 0 0 0 0 0 0 0 0 255 239 0 0 255 249 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 236 0 0 0 0 255 246 0 0 0 0 0 9 0 0 0 0 255 240 0 0 0 13 0 9 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 0 0 255 226 0 0 0 0 0 0 0 0 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 227 255 223 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 255 232 255 240 0 20 0 11 0 13 0 29 255 230 0 20 0 15 0 0 0 0 255 239 0 0 255 246 255 239 255 240 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 255 249 0 0 255 229 255 239 0 0 0 0 0 0 0 13 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 237 255 239 255 199 255 216 255 244 255 230 255 231 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 255 235 0 0 0 0 0 0 255 239 255 252 255 252 0 0 0 0 255 252 0 0 255 239 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 227 255 230 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 255 240 0 0 0 0 0 0 0 0 255 242 255 247 255 230 255 230 255 236 0 0 255 229 255 236 0 0 255 236 0 0 255 245 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 229 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 232 255 236 0 0 0 0 255 222 0 3 0 0 0 0 0 3 0 0 0 0 0 6 0 11 255 232 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 255 233 0 0 255 249 0 0 255 249 255 240 255 242 255 239 0 0 0 15 0 0 0 0 255 229 255 242 0 0 0 0 0 0 0 0 0 0 255 236 0 16 0 0 0 0 0 0 255 246 0 0 0 0 255 239 0 0 255 236 0 0 0 0 0 0 0 0 0 6 255 230 255 252 255 252 0 0 0 0 0 0 0 0 255 242 0 0 255 216 0 0 0 0 255 221 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 238 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 255 232 0 0 0 0 0 0 255 246 255 242 255 216 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 183 0 0 255 180 255 236 255 183 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 0 0 0 0 0 0 255 236 255 236 0 0 0 0 0 0 255 242 0 0 255 219 0 0 0 0 255 239 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 191 255 176 0 0 255 201 0 0 255 246 255 252 255 246 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 235 255 189 0 0 0 0 255 202 0 0 255 242 0 0 0 0 0 0 255 242 255 242 255 202 255 223 0 0 0 0 255 229 255 240 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 189 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 235 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 233 255 236 255 143 255 209 255 229 255 191 0 0 0 0 255 232 0 0 255 246 0 0 0 0 0 0 0 0 255 236 255 232 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 191 0 0 0 4 0 0 255 246 0 0 0 0 255 253 255 246 255 246 255 252 0 0 0 0 255 252 255 203 255 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 191 255 171 0 0 0 0 0 0 255 252 0 0 0 0 255 246 0 0 255 252 255 232 0 0 255 240 255 225 255 242 255 232 255 242 0 0 255 225 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 236 0 0 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 250 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 23 0 19 0 0 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 15 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 242 0 0 255 230 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 14 0 7 0 0 255 236 0 0 0 0 0 0 0 0 255 235 0 0 0 0 0 0 255 227 0 0 255 246 255 246 0 0 255 216 0 0 255 240 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 38 0 0 255 220 0 0 255 246 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 230 255 238 0 0 0 0 0 0 0 0 0 0 255 242 0 10 255 242 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 255 236 255 207 255 223 255 213 255 207 255 236 0 0 255 143 0 0 255 243 0 0 255 169 255 246 0 0 0 0 0 10 0 6 0 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 230 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 230 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 227 255 220 255 210 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 191 0 0 0 0 0 0 0 0 0 0 0 0 255 238 0 0 255 237 0 0 0 0 0 0 255 193 255 223 255 171 255 197 0 0 255 171 255 230 255 230 255 136 255 238 0 0 255 236 255 150 0 0 255 192 0 0 0 0 0 0 0 0 255 183 255 216 255 220 0 0 255 167 255 191 255 197 255 213 255 194 255 160 255 187 255 217 255 236 255 223 255 196 255 232 255 223 255 243 255 207 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 163 0 0 255 217 0 0 0 0 0 0 255 211 255 217 255 130 0 0 255 236 255 232 0 0 255 216 0 0 255 183 255 209 0 0 255 217 0 0 0 0 255 203 255 190 255 167 0 0 0 0 0 0 255 210 255 210 255 211 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 171 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20 0 20 0 0 0 0 0 0 0 0 0 0 0 0 0 4 0 0 255 252 0 0 0 40 0 0 0 0 0 0 0 0 0 17 0 0 0 0 0 0 255 252 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 55 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 20 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 252 0 0 0 0 255 242 0 27 0 0 0 0 0 27 0 0 0 0 0 0 255 252 255 246 0 33 0 33 0 0 255 252 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 255 252 0 0 0 0 0 45 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 236 255 236 255 242 0 0 0 0 0 0 255 249 0 27 0 0 0 0 0 27 0 0 0 0 0 0 255 252 255 246 0 20 0 20 0 0 0 0 0 0 0 0 0 0 0 0 0 7 0 0 255 249 255 239 0 40 0 27 0 7 0 7 255 246 0 36 0 27 0 0 0 0 255 252 0 0 255 246 0 6 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 4 0 0 0 0 0 7 0 67 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 20 0 0 0 7 0 0 0 0 0 0 0 0 0 20 0 7 0 0 0 0 0 0 0 0 0 0 0 0 0 7 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 248 0 7 0 0 0 0 255 246 255 242 255 232 255 229 255 246 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 235 255 201 0 0 0 0 255 195 0 0 255 252 255 252 0 0 0 0 255 249 255 252 255 196 255 220 0 0 0 0 255 229 255 229 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 201 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 241 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 223 255 189 255 209 255 246 255 189 0 0 0 0 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 255 190 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 245 0 0 0 0 255 242 255 203 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 196 255 189 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 0 0 0 0 0 0 0 0 255 239 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 221 0 0 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 255 249 0 0 0 0 255 249 0 0 255 249 0 0 255 242 255 252 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 245 255 245 0 0 0 0 255 246 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 255 252 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 255 252 255 242 255 252 0 0 255 245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 255 242 255 222 255 242 255 252 255 222 255 242 0 0 255 156 255 246 0 0 0 0 255 189 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 242 0 0 0 3 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 255 236 0 13 0 16 0 0 255 229 255 232 255 192 255 212 0 0 255 192 0 0 0 0 255 141 255 236 255 236 0 0 255 169 0 0 255 239 0 0 0 0 0 0 0 0 255 232 255 216 255 236 255 242 255 196 255 196 255 219 255 239 255 232 255 176 255 192 255 242 255 229 255 240 0 0 255 252 255 240 0 0 255 222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 0 0 0 0 0 0 0 255 209 255 229 255 242 0 20 0 0 0 0 255 229 255 242 255 136 255 236 255 252 255 232 0 0 255 221 255 236 255 216 255 229 0 0 255 242 255 246 0 13 255 229 255 216 0 0 0 0 0 0 0 0 255 226 255 226 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 232 0 0 0 0 255 232 0 0 255 217 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 255 246 255 242 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 255 252 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 255 230 0 0 0 0 0 0 0 0 255 252 255 252 0 0 255 242 255 230 0 4 255 246 255 250 0 0 255 246 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 230 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 250 255 246 255 232 255 226 0 0 255 236 255 226 0 10 255 240 0 0 0 4 0 0 0 0 0 0 0 10 255 250 0 0 0 0 0 0 0 0 0 0 255 236 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 233 0 0 255 253 0 0 0 0 0 0 0 0 255 253 255 246 255 252 255 242 0 10 0 0 255 242 255 233 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 255 246 0 0 255 240 0 0 0 0 255 236 0 0 0 0 255 250 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 235 255 201 0 0 0 0 255 212 0 0 255 239 0 0 0 0 0 0 0 0 255 236 255 216 255 223 0 0 0 0 255 240 255 240 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 209 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 0 0 0 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 171 255 209 255 221 255 203 0 0 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 232 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 203 0 0 0 4 0 0 0 0 0 0 0 0 0 4 0 0 0 0 0 0 0 0 0 0 255 252 255 196 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 211 255 196 0 0 0 0 0 0 255 252 0 0 0 0 0 0 0 0 255 252 255 246 0 0 255 236 255 246 255 252 255 239 0 0 0 0 255 236 0 0 0 0 0 0 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 19 206 0 4 0 0 56 34 56 182 0 11 0 144 0 0 0 20 0 20 0 20 255 249 0 80 255 236 0 13 255 236 0 13 0 80 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 40 0 40 0 0 0 4 0 0 0 0 0 0 0 0 0 4 0 0 255 246 0 33 0 15 255 230 255 246 255 230 255 207 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 40 0 40 0 40 255 240 0 26 0 0 255 236 255 183 0 0 0 26 0 0 255 246 0 33 0 40 255 164 255 246 255 164 255 118 0 20 255 221 255 209 255 201 255 209 255 221 255 200 255 191 255 245 255 230 255 210 255 187 255 157 255 236 255 229 255 203 255 245 0 20 255 209 255 162 255 245 255 230 255 210 255 187 255 157 255 186 0 20 255 245 255 230 255 210 255 187 255 157 255 236 255 236 255 221 255 200 255 191 255 234 255 213 255 222 255 236 255 186 255 172 255 152 255 160 255 246 255 242 255 226 255 226 255 229 255 220 255 220 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 246 255 227 0 16 0 0 255 236 255 229 255 216 255 229 0 0 255 236 0 0 255 246 255 227 255 190 0 0 255 190 0 0 0 0 0 0 255 246 255 236 0 6 255 249 0 0 255 237 0 0 0 0 255 230 255 227 255 209 0 0 255 242 255 203 0 0 0 0 0 6 255 216 0 0 0 0 255 230 255 227 255 209 0 0 0 0 0 0 0 0 255 230 255 227 255 209 0 0 0 0 255 249 0 0 255 237 0 0 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 239 255 232 255 242 255 229 255 242 255 246 255 232 255 235 255 236 255 232 255 242 255 242 255 229 255 249 255 252 255 229 255 229 255 236 255 239 255 242 255 229 255 236 255 249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 224 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 229 255 229 255 249 0 0 0 0 255 246 0 0 0 0 255 219 255 246 255 219 0 0 0 0 0 0 0 0 255 242 0 0 255 252 0 0 255 239 0 0 0 0 255 242 255 242 255 216 255 252 0 0 255 203 0 0 0 0 0 0 255 236 0 0 0 0 255 242 255 242 255 216 255 242 0 0 0 0 0 0 255 242 255 242 255 216 0 0 0 0 255 252 0 0 255 239 0 0 0 0 255 239 255 252 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 255 236 255 242 0 0 255 236 255 236 0 0 0 0 255 236 0 0 255 236 255 242 0 0 255 252 255 223 0 0 0 0 0 0 255 236 255 242 0 0 0 0 255 249 255 246 255 242 255 246 255 249 255 249 255 242 255 249 255 242 255 242 255 249 255 242 255 219 255 242 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 243 0 0 0 0 255 226 255 221 0 0 255 239 0 0 255 226 0 0 0 0 255 243 255 201 0 0 255 201 0 0 0 0 0 0 0 0 255 216 0 0 255 249 0 0 255 235 0 0 0 0 255 223 255 220 255 210 255 249 0 0 255 196 0 0 0 0 0 0 0 0 0 0 0 0 255 223 255 220 255 210 255 242 0 0 0 0 0 0 255 223 255 220 255 210 0 0 0 0 255 249 0 0 255 235 0 0 0 0 255 246 255 249 255 242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 226 255 239 255 232 255 242 0 0 255 242 255 229 255 242 255 236 255 242 0 0 255 232 255 242 0 0 0 0 0 0 0 0 255 238 255 226 255 232 255 242 255 238 0 0 255 223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 236 255 223 255 236 0 0 0 0 0 0 255 236 255 220 255 236 255 220 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 235 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 255 197 255 196 255 236 0 0 255 181 0 9 255 236 255 252 0 0 255 181 0 0 255 216 255 196 0 9 0 0 0 9 0 0 255 196 0 0 0 0 0 0 255 236 0 0 0 0 0 13 255 223 255 236 0 0 0 0 0 0 0 0 0 0 255 249 255 223 255 196 255 236 0 0 255 223 255 236 0 0 0 0 0 0 0 0 255 196 255 223 255 236 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 13 0 0 0 0 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 242 0 0 0 0 255 249 0 0 255 232 0 0 0 0 0 0 255 249 0 0 0 0 255 249 255 200 0 0 0 0 0 0 0 0 255 242 0 0 255 249 0 0 0 0 0 0 0 0 255 241 0 0 0 65 0 65 0 0 0 53 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 252 0 0 255 252 0 0 255 252 255 213 255 200 255 246 0 45 255 200 255 243 255 223 255 196 255 223 255 236 255 236 255 223 0 53 255 236 255 171 255 213 255 200 255 242 255 223 255 246 255 173 255 171 255 214 255 203 255 242 255 123 0 0 0 0 0 0 0 0 255 220 255 197 255 196 255 236 0 0 255 174 0 20 0 0 0 0 0 0 255 174 0 7 255 212 255 196 0 0 0 7 0 0 0 0 0 0 0 0 0 0 0 0 255 223 0 0 0 0 0 0 255 198 0 0 0 0 0 0 0 0 0 0 0 0 0 7 255 198 0 0 255 223 0 0 255 198 0 0 0 0 0 0 0 0 0 0 0 0 255 198 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 255 232 0 0 0 0 0 0 0 0 0 0 0 0 255 249 255 209 0 0 0 0 0 0 0 0 0 0 0 0 255 249 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 191 255 198 255 207 0 53 255 198 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 171 255 191 255 198 255 240 255 211 255 207 255 124 255 171 255 214 0 0 255 242 0 0 255 243 255 243 255 230 0 0 255 216 0 0 255 176 0 0 0 0 255 161 0 6 0 0 0 0 0 0 255 161 0 0 255 209 255 169 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 223 0 0 0 0 0 0 255 227 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 227 0 0 255 223 0 0 255 227 0 0 0 0 0 0 0 0 0 0 0 0 255 227 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 246 0 0 0 0 255 246 0 0 255 223 0 0 0 0 0 0 0 0 0 0 0 0 255 246 255 201 0 0 0 0 0 0 0 0 255 246 0 0 255 246 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 201 255 236 0 0 255 201 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 201 0 0 0 0 255 236 255 141 0 0 255 198 0 0 255 229 0 0 0 0 0 0 0 0 0 1 0 48 7 31 7 33 7 34 7 36 7 37 7 39 7 41 7 43 7 45 7 46 7 49 7 51 7 53 7 55 7 57 7 59 7 62 7 64 7 66 7 67 7 68 7 69 7 83 7 100 7 101 7 105 7 107 7 108 7 110 7 111 7 112 7 114 7 116 7 118 7 120 7 122 7 124 7 126 7 128 7 130 7 132 7 134 7 136 7 137 7 138 7 139 7 140 7 141 0 1 0 131 0 28 0 29 0 30 0 31 0 32 0 33 0 34 0 35 0 36 0 37 0 38 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 47 0 48 0 49 0 50 0 51 0 52 0 53 1 13 1 14 1 44 1 69 1 71 1 114 1 115 1 116 1 122 1 161 1 162 1 186 1 187 1 188 1 190 1 191 1 194 1 197 1 198 1 199 1 200 1 201 1 202 1 203 1 204 1 205 1 206 1 207 1 209 1 211 1 216 1 222 1 223 1 224 1 225 1 226 1 227 1 228 1 229 1 231 1 232 1 233 1 234 1 238 1 241 1 242 1 243 1 244 1 245 1 246 1 247 1 248 1 249 1 250 1 251 2 21 2 33 2 43 2 44 2 53 2 96 2 100 2 102 2 104 2 110 2 112 2 115 2 119 3 97 3 99 3 226 3 229 3 231 3 232 3 236 3 238 3 244 3 249 3 252 3 253 4 1 4 3 4 4 4 5 4 10 4 26 4 42 4 43 4 57 5 159 5 160 5 163 5 164 5 165 5 167 5 168 5 170 5 171 5 173 5 175 5 177 5 178 7 14 7 24 7 30 0 1 0 31 7 32 7 35 7 38 7 40 7 42 7 44 7 47 7 48 7 50 7 52 7 54 7 56 7 58 7 60 7 63 7 65 7 102 7 106 7 109 7 113 7 115 7 117 7 119 7 121 7 123 7 125 7 127 7 129 7 131 7 133 7 135 0 1 0 104 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 15 0 16 0 17 0 18 0 19 0 20 0 21 0 22 0 23 0 24 0 25 0 26 0 27 0 75 0 76 0 106 0 131 0 173 0 174 0 175 0 181 0 219 0 220 0 245 0 246 1 208 1 221 1 236 2 7 2 18 3 136 3 139 3 141 3 142 3 146 3 148 3 154 3 159 3 162 3 163 3 167 3 169 3 170 3 171 3 192 3 208 3 209 3 223 4 193 4 194 4 195 4 196 4 197 4 198 4 199 4 200 4 201 4 202 4 203 4 204 4 205 4 206 4 207 4 208 4 209 4 210 4 211 4 212 4 213 4 214 4 215 4 216 4 217 4 218 4 240 4 241 5 15 5 40 5 82 5 88 5 112 5 129 5 130 5 156 5 180 5 191 5 193 5 194 5 196 5 198 5 207 0 1 0 1 7 72 0 1 0 1 7 30 0 1 0 2 7 84 7 85 0 1 0 13 0 4 0 20 0 21 0 30 0 46 0 47 4 195 4 211 4 212 5 112 5 177 5 180 7 30 0 2 0 5 7 70 7 71 0 0 7 74 7 82 0 2 7 88 7 94 0 11 7 96 7 99 0 18 7 103 7 103 0 22 0 2 0 45 0 2 0 17 0 0 0 19 0 53 0 16 0 175 0 175 0 51 0 220 0 220 0 52 0 245 0 245 0 53 1 14 1 14 0 54 1 71 1 71 0 55 1 116 1 116 0 56 1 162 1 162 0 57 1 186 1 186 0 58 1 190 1 192 0 59 1 196 1 200 0 62 1 202 1 204 0 67 1 207 1 209 0 70 1 211 1 212 0 73 1 216 1 216 0 75 1 221 1 223 0 76 1 229 1 229 0 79 1 231 1 234 0 80 1 236 1 236 0 84 1 243 1 248 0 85 2 7 2 7 0 91 2 21 2 21 0 92 2 33 2 33 0 93 2 44 2 44 0 94 2 53 2 53 0 95 2 96 2 96 0 96 2 100 2 100 0 97 2 102 2 102 0 98 2 119 2 119 0 99 4 193 4 208 0 100 4 210 4 218 0 116 5 82 5 82 0 125 5 112 5 112 0 126 5 130 5 130 0 127 5 159 5 160 0 128 5 163 5 165 0 130 5 167 5 168 0 133 5 170 5 171 0 135 5 173 5 173 0 137 5 175 5 175 0 138 5 177 5 178 0 139 5 180 5 180 0 141 5 193 5 193 0 142 7 30 7 30 0 143 0 1 0 1 7 95 0 1 0 1 7 73 0 1 0 7 0 16 0 22 0 42 0 48 4 207 4 213 7 30 0 1 0 1 7 86 0 1 0 11 0 28 0 32 0 36 0 42 0 48 1 71 1 190 1 197 1 200 2 21 7 30 0 1 0 1 7 87 0 1 0 13 0 2 0 6 0 10 0 16 0 22 1 216 2 7 4 193 4 197 4 201 4 207 4 213 5 82 0 1 0 3 7 37 7 49 7 51 0 1 0 143 0 7 0 23 0 51 1 116 1 117 1 118 1 119 1 120 1 121 1 190 1 194 1 197 1 209 1 211 1 221 1 231 1 234 1 236 1 245 1 246 1 247 1 248 1 249 2 65 2 68 2 72 2 80 2 81 2 82 2 84 2 85 2 93 2 94 2 101 2 109 2 117 2 120 2 186 2 187 2 188 2 189 2 190 2 191 2 192 2 193 3 10 3 11 3 12 3 13 3 14 3 18 3 96 3 139 3 140 3 159 3 162 3 165 3 175 3 189 3 193 3 194 3 195 3 206 3 211 3 224 3 225 3 230 3 251 3 252 3 255 4 14 4 27 4 28 4 30 4 34 4 40 4 42 4 43 4 44 4 45 4 75 4 76 4 77 4 78 4 79 4 80 4 81 4 82 4 83 4 84 4 97 4 98 4 99 4 100 4 101 4 102 4 103 4 104 4 105 4 106 4 134 4 136 4 151 4 153 4 155 4 157 4 172 4 174 4 176 4 209 5 112 5 189 5 190 5 191 5 192 5 195 5 209 5 210 5 213 5 223 5 239 5 240 5 241 5 243 5 246 5 248 5 250 5 251 6 9 6 10 6 11 6 12 6 13 6 14 6 15 6 16 6 17 6 18 6 29 6 166 6 167 6 168 6 170 0 1 0 11 1 216 1 236 3 107 3 126 3 127 3 128 3 129 3 130 3 131 3 132 3 133 0 1 0 1 4 60 0 1 0 5 3 149 3 150 3 239 3 240 5 252 0 1 0 26 1 221 1 245 1 246 1 247 1 248 2 111 3 208 3 212 4 42 4 43 4 82 4 104 4 123 4 125 4 146 4 157 4 159 5 248 6 10 6 16 6 18 6 22 6 23 6 25 6 26 6 29 0 2 0 32 0 2 0 30 0 0 0 32 0 35 0 29 0 38 1 24 0 33 1 28 1 58 1 20 1 71 1 71 1 51 1 73 1 78 1 52 1 80 1 83 1 58 1 85 1 184 1 62 1 186 1 187 1 162 1 190 1 194 1 164 1 197 1 198 1 169 1 200 1 200 1 171 1 204 1 204 1 172 1 207 1 209 1 173 1 211 1 214 1 176 1 222 1 225 1 180 1 227 1 228 1 184 1 230 1 231 1 186 1 234 1 235 1 188 1 237 1 238 1 190 1 241 1 241 1 192 1 244 1 244 1 193 1 249 1 250 1 194 2 2 2 2 1 196 2 5 2 52 1 197 2 55 2 55 1 245 4 193 4 200 1 246 4 202 5 28 1 254 5 42 5 46 2 81 5 48 5 153 2 86 5 155 5 158 2 192 7 149 7 149 2 196 0 2 0 6 2 63 2 110 0 0 2 112 3 98 0 48 3 100 3 100 1 35 3 110 3 110 1 36 5 159 5 187 1 37 6 233 6 234 1 66 0 2 0 24 3 136 3 142 0 0 3 145 3 148 0 7 3 151 3 179 0 11 3 181 3 185 0 40 3 188 3 196 0 45 3 199 3 200 0 54 3 203 3 203 0 56 3 206 3 207 0 57 3 210 3 211 0 59 3 213 3 214 0 61 3 217 3 232 0 63 3 235 3 238 0 79 3 241 4 11 0 83 4 16 4 19 0 110 4 22 4 30 0 114 4 33 4 34 0 123 4 37 4 37 0 125 4 40 4 41 0 126 4 44 4 47 0 128 4 51 4 59 0 132 5 188 5 227 0 141 5 229 5 247 0 181 5 250 5 251 0 200 5 253 6 7 0 202 0 2 0 11 4 117 4 122 0 0 4 124 4 124 0 6 4 126 4 141 0 7 4 144 4 145 0 23 4 151 4 151 0 25 4 153 4 153 0 26 4 155 4 155 0 27 4 167 4 172 0 28 4 174 4 174 0 34 4 176 4 176 0 35 7 8 7 11 0 36 0 2 0 10 1 236 1 236 0 1 3 107 3 107 0 9 3 126 3 126 0 5 3 127 3 127 0 2 3 128 3 128 0 10 3 129 3 129 0 8 3 130 3 130 0 7 3 131 3 131 0 4 3 132 3 132 0 6 3 133 3 133 0 3 0 2 0 36 0 4 0 4 0 4 0 8 0 8 0 4 0 16 0 16 0 4 0 18 0 18 0 4 0 30 0 32 0 3 0 33 0 33 0 1 0 34 0 34 0 2 0 42 0 42 0 3 0 44 0 44 0 3 0 47 0 47 0 5 0 49 0 49 0 6 0 50 0 50 0 7 0 52 0 52 0 8 0 81 0 85 0 4 0 108 0 116 0 4 0 156 0 181 0 4 1 19 1 45 0 3 1 46 1 53 0 2 1 97 1 122 0 3 1 138 1 144 0 5 1 168 1 171 0 7 1 172 1 179 0 8 1 194 1 196 0 3 1 198 1 198 0 3 1 206 1 208 0 3 1 209 1 209 0 8 1 228 1 230 0 3 1 241 1 241 0 5 2 2 2 2 0 1 2 5 2 6 0 1 2 7 2 19 0 10 2 21 2 52 0 3 2 62 2 62 0 1 4 217 4 217 0 9 5 140 5 147 0 9 7 148 7 149 0 1 0 2 0 0 0 2 0 4 2 98 2 98 0 2 2 108 2 108 0 3 2 114 2 114 0 4 2 117 2 117 0 1 0 2 0 4 3 150 3 150 0 1 3 239 3 239 0 3 3 240 3 240 0 4 5 252 5 252 0 2 0 2 0 38 3 226 3 226 0 14 3 227 3 227 0 1 3 230 3 230 0 3 3 231 3 231 0 6 3 241 3 241 0 4 3 244 3 244 0 6 3 247 3 247 0 6 3 248 3 248 0 7 3 249 3 249 0 8 3 250 3 250 0 6 3 253 3 253 0 2 4 0 4 0 0 7 4 3 4 3 0 16 4 5 4 5 0 10 4 6 4 7 0 6 4 10 4 10 0 6 4 11 4 11 0 15 4 16 4 16 0 4 4 23 4 23 0 8 4 25 4 25 0 9 4 26 4 26 0 6 4 27 4 27 0 5 4 37 4 37 0 7 4 41 4 41 0 6 4 42 4 43 0 5 4 45 4 45 0 2 4 51 4 52 0 14 4 53 4 53 0 6 4 56 4 57 0 6 4 58 4 59 0 8 5 206 5 206 0 12 5 211 5 211 0 11 5 214 5 214 0 12 5 222 5 222 0 12 5 232 5 232 0 12 5 237 5 237 0 13 5 245 5 245 0 12 5 251 5 251 0 11 0 2 0 25 1 245 1 245 0 23 1 246 1 246 0 24 1 247 1 247 0 25 1 248 1 248 0 4 2 111 2 111 0 11 3 208 3 208 0 2 3 212 3 212 0 1 4 42 4 42 0 21 4 43 4 43 0 22 4 82 4 82 0 18 4 104 4 104 0 17 4 123 4 123 0 6 4 125 4 125 0 12 4 146 4 146 0 10 4 157 4 157 0 20 4 159 4 159 0 5 5 248 5 248 0 3 6 10 6 10 0 9 6 16 6 16 0 19 6 18 6 18 0 8 6 22 6 22 0 13 6 23 6 23 0 16 6 25 6 25 0 14 6 26 6 26 0 15 6 29 6 29 0 7 0 2 1 64 0 2 0 2 0 92 0 4 0 4 0 109 0 8 0 8 0 109 0 11 0 11 0 116 0 16 0 16 0 109 0 18 0 18 0 109 0 20 0 20 0 93 0 21 0 21 0 59 0 22 0 22 0 60 0 23 0 23 0 62 0 24 0 24 0 64 0 25 0 25 0 95 0 26 0 26 0 66 0 27 0 27 0 96 0 28 0 28 0 106 0 30 0 32 0 108 0 33 0 33 0 107 0 34 0 34 0 56 0 36 0 36 0 115 0 37 0 37 0 58 0 42 0 42 0 108 0 44 0 44 0 108 0 47 0 47 0 118 0 48 0 48 0 119 0 49 0 49 0 61 0 50 0 50 0 63 0 51 0 51 0 94 0 52 0 52 0 65 0 53 0 53 0 122 0 54 0 75 0 92 0 79 0 79 0 55 0 81 0 85 0 109 0 89 0 89 0 55 0 108 0 116 0 109 0 120 0 120 0 57 0 133 0 133 0 116 0 156 0 181 0 109 0 189 0 195 0 93 0 197 0 202 0 59 0 203 0 225 0 60 0 226 0 229 0 64 0 230 0 237 0 66 0 238 0 242 0 96 0 243 0 243 0 55 0 245 0 245 0 117 0 248 1 16 0 106 1 19 1 45 0 108 1 46 1 53 0 56 1 59 1 70 0 115 1 72 1 72 0 58 1 97 1 122 0 108 1 138 1 144 0 118 1 145 1 167 0 119 1 168 1 171 0 63 1 172 1 179 0 65 1 180 1 184 0 122 1 188 1 188 0 58 1 189 1 189 0 115 1 190 1 190 0 119 1 194 1 196 0 108 1 198 1 198 0 108 1 205 1 205 0 58 1 206 1 208 0 108 1 209 1 209 0 65 1 211 1 211 0 119 1 222 1 223 0 119 1 225 1 225 0 58 1 228 1 230 0 108 1 239 1 240 0 58 1 241 1 241 0 118 1 244 1 244 0 119 1 249 1 250 0 122 2 2 2 2 0 107 2 5 2 6 0 107 2 21 2 52 0 108 2 62 2 62 0 107 2 63 2 63 0 83 2 66 2 66 0 86 2 68 2 68 0 91 2 70 2 70 0 105 2 73 2 73 0 83 2 76 2 76 0 90 2 77 2 77 0 105 2 80 2 80 0 89 2 81 2 81 0 53 2 82 2 82 0 54 2 84 2 84 0 85 2 85 2 85 0 88 2 87 2 87 0 114 2 94 2 94 0 54 2 96 2 96 0 97 2 98 2 98 0 98 2 106 2 106 0 87 2 108 2 108 0 99 2 110 2 110 0 100 2 113 2 113 0 100 2 114 2 114 0 101 2 116 2 116 0 100 2 117 2 117 0 84 2 119 2 120 0 100 2 123 2 123 0 100 2 124 2 124 0 97 2 129 2 129 0 100 2 132 2 132 0 100 2 135 2 144 0 114 2 145 2 146 0 83 2 192 2 193 0 54 2 204 2 204 0 83 2 205 2 212 0 114 2 231 2 243 0 97 3 23 3 30 0 100 3 49 3 59 0 100 3 60 3 71 0 97 3 84 3 95 0 100 3 97 3 98 0 100 3 136 3 136 0 76 3 140 3 140 0 20 3 142 3 142 0 81 3 145 3 145 0 37 3 151 3 151 0 25 3 154 3 154 0 104 3 157 3 157 0 104 3 158 3 158 0 51 3 159 3 159 0 29 3 160 3 160 0 22 3 161 3 161 0 79 3 163 3 163 0 17 3 166 3 166 0 51 3 169 3 169 0 37 3 171 3 171 0 34 3 174 3 174 0 51 3 176 3 176 0 104 3 177 3 177 0 77 3 181 3 181 0 113 3 182 3 182 0 25 3 184 3 184 0 51 3 189 3 189 0 29 3 191 3 191 0 80 3 192 3 192 0 104 3 193 3 193 0 49 3 196 3 196 0 81 3 199 3 199 0 37 3 203 3 203 0 51 3 207 3 207 0 104 3 210 3 210 0 79 3 211 3 211 0 17 3 214 3 214 0 81 3 217 3 217 0 76 3 222 3 223 0 104 3 224 3 225 0 29 3 226 3 226 0 102 3 227 3 227 0 14 3 228 3 229 0 26 3 230 3 230 0 18 3 231 3 231 0 103 3 232 3 232 0 38 3 235 3 235 0 35 3 236 3 238 0 26 3 241 3 241 0 23 3 242 3 243 0 26 3 244 3 244 0 103 3 245 3 245 0 26 3 247 3 247 0 103 3 248 3 248 0 28 3 249 3 249 0 52 3 250 3 250 0 103 3 251 3 251 0 78 3 252 3 252 0 26 3 253 3 253 0 15 3 254 3 255 0 26 4 0 4 0 0 28 4 1 4 2 0 26 4 3 4 3 0 21 4 4 4 4 0 26 4 5 4 5 0 32 4 6 4 7 0 103 4 9 4 9 0 26 4 10 4 10 0 103 4 12 4 13 0 112 4 15 4 15 0 50 4 16 4 16 0 23 4 17 4 17 0 26 4 19 4 19 0 26 4 22 4 22 0 26 4 23 4 23 0 52 4 24 4 24 0 26 4 25 4 25 0 30 4 26 4 26 0 103 4 27 4 27 0 48 4 28 4 28 0 26 4 30 4 30 0 38 4 33 4 33 0 35 4 34 4 34 0 26 4 37 4 37 0 28 4 40 4 40 0 26 4 41 4 41 0 103 4 42 4 43 0 48 4 44 4 44 0 78 4 45 4 45 0 15 4 47 4 47 0 38 4 51 4 52 0 102 4 53 4 53 0 103 4 55 4 55 0 26 4 56 4 57 0 103 4 58 4 59 0 52 4 117 4 118 0 9 4 121 4 121 0 9 4 124 4 124 0 10 4 126 4 127 0 13 4 128 4 128 0 11 4 129 4 129 0 12 4 130 4 130 0 11 4 131 4 131 0 12 4 132 4 133 0 9 4 134 4 134 0 121 4 135 4 135 0 40 4 136 4 136 0 121 4 137 4 137 0 40 4 138 4 141 0 120 4 144 4 145 0 120 4 168 4 168 0 10 4 170 4 171 0 10 4 192 4 192 0 115 4 193 4 193 0 1 4 195 4 195 0 2 4 199 4 199 0 2 4 202 4 202 0 46 4 207 4 207 0 2 4 209 4 209 0 2 4 211 4 211 0 3 4 212 4 212 0 4 4 213 4 213 0 5 4 214 4 214 0 6 4 215 4 215 0 7 4 216 4 216 0 75 4 217 4 217 0 8 4 218 4 218 0 47 4 219 4 240 0 1 4 246 4 250 0 2 5 17 5 25 0 2 5 42 5 42 0 46 5 65 5 90 0 2 5 98 5 105 0 3 5 106 5 106 0 111 5 107 5 112 0 4 5 113 5 135 0 5 5 136 5 139 0 7 5 140 5 147 0 8 5 148 5 152 0 47 5 159 5 159 0 82 5 164 5 164 0 74 5 166 5 166 0 110 5 169 5 169 0 82 5 173 5 173 0 110 5 177 5 177 0 72 5 178 5 178 0 73 5 180 5 180 0 71 5 184 5 184 0 73 5 185 5 185 0 82 5 188 5 188 0 41 5 189 5 191 0 27 5 192 5 192 0 19 5 193 5 193 0 27 5 194 5 194 0 39 5 195 5 195 0 36 5 196 5 198 0 27 5 199 5 199 0 24 5 200 5 201 0 27 5 202 5 202 0 43 5 203 5 204 0 27 5 205 5 205 0 43 5 206 5 206 0 44 5 207 5 207 0 45 5 208 5 208 0 42 5 209 5 209 0 68 5 210 5 210 0 27 5 211 5 211 0 16 5 212 5 213 0 27 5 214 5 214 0 44 5 215 5 216 0 27 5 217 5 217 0 36 5 218 5 218 0 27 5 219 5 219 0 33 5 220 5 221 0 27 5 222 5 222 0 44 5 223 5 223 0 27 5 224 5 224 0 43 5 225 5 225 0 67 5 226 5 227 0 27 5 229 5 229 0 70 5 230 5 230 0 24 5 231 5 231 0 27 5 232 5 232 0 44 5 233 5 234 0 27 5 235 5 235 0 45 5 236 5 236 0 27 5 237 5 237 0 31 5 238 5 238 0 43 5 239 5 239 0 69 5 240 5 240 0 27 5 242 5 242 0 39 5 243 5 243 0 36 5 244 5 244 0 27 5 245 5 245 0 44 5 246 5 246 0 27 5 247 5 247 0 43 5 250 5 250 0 68 5 251 5 251 0 16 5 252 5 253 0 27 5 254 5 254 0 39 5 255 5 255 0 41 6 1 6 1 0 27 6 3 6 3 0 27 6 4 6 5 0 43 6 6 6 7 0 45 6 233 6 233 0 86 7 8 7 8 0 11 7 9 7 10 0 12 7 11 7 11 0 11 7 148 7 149 0 107 0 2 0 191 0 2 0 2 0 2 0 3 0 3 0 4 0 4 0 4 0 7 0 5 0 5 0 41 0 6 0 6 0 10 0 7 0 7 0 13 0 8 0 8 0 19 0 9 0 9 0 22 0 10 0 10 0 24 0 11 0 11 0 26 0 12 0 12 0 29 0 13 0 13 0 34 0 14 0 15 0 22 0 16 0 16 0 41 0 17 0 17 0 43 0 18 0 18 0 41 0 19 0 19 0 46 0 20 0 20 0 49 0 21 0 21 0 53 0 22 0 22 0 59 0 23 0 23 0 62 0 24 0 24 0 65 0 25 0 25 0 68 0 26 0 26 0 71 0 27 0 27 0 74 0 29 0 29 0 39 0 30 0 30 0 5 0 32 0 32 0 8 0 33 0 33 0 11 0 34 0 34 0 17 0 35 0 35 0 35 0 38 0 38 0 27 0 39 0 39 0 32 0 40 0 41 0 35 0 42 0 43 0 39 0 44 0 44 0 57 0 45 0 45 0 44 0 46 0 46 0 47 0 47 0 47 0 51 0 48 0 48 0 57 0 49 0 49 0 60 0 50 0 50 0 63 0 51 0 51 0 66 0 52 0 52 0 69 0 53 0 53 0 72 0 54 0 75 0 2 0 76 0 78 0 10 0 79 0 80 0 4 0 81 0 85 0 7 0 86 0 89 0 41 0 90 0 107 0 10 0 108 0 116 0 19 0 117 0 119 0 22 0 120 0 120 0 20 0 121 0 132 0 24 0 133 0 133 0 26 0 134 0 136 0 29 0 137 0 137 0 34 0 138 0 138 0 31 0 139 0 144 0 34 0 145 0 155 0 22 0 156 0 173 0 41 0 174 0 174 0 10 0 175 0 180 0 38 0 181 0 181 0 41 0 182 0 188 0 46 0 189 0 195 0 49 0 196 0 196 0 16 0 197 0 202 0 53 0 203 0 219 0 59 0 220 0 225 0 56 0 226 0 229 0 65 0 230 0 237 0 71 0 238 0 242 0 74 0 243 0 243 0 41 0 244 0 244 0 50 0 245 0 246 0 41 0 247 0 247 0 24 1 14 1 16 0 8 1 17 1 18 0 39 1 19 1 23 0 5 1 24 1 24 0 30 1 28 1 45 0 8 1 46 1 53 0 17 1 54 1 58 0 35 1 71 1 71 0 57 1 73 1 76 0 27 1 77 1 77 0 32 1 78 1 78 0 30 1 80 1 83 0 32 1 85 1 96 0 35 1 97 1 114 0 39 1 115 1 115 0 8 1 116 1 121 0 36 1 122 1 122 0 39 1 123 1 129 0 44 1 130 1 136 0 47 1 137 1 137 0 14 1 138 1 144 0 51 1 145 1 161 0 57 1 162 1 167 0 54 1 168 1 171 0 63 1 172 1 179 0 69 1 180 1 184 0 72 1 186 1 186 0 39 1 187 1 187 0 35 1 190 1 190 0 8 1 191 1 193 0 39 1 194 1 194 0 5 1 197 1 197 0 39 1 198 1 198 0 57 1 200 1 200 0 39 1 204 1 204 0 39 1 207 1 207 0 57 1 208 1 208 0 5 1 209 1 209 0 69 1 211 1 211 0 57 1 212 1 213 0 35 1 214 1 214 0 57 1 222 1 223 0 57 1 224 1 225 0 35 1 227 1 227 0 57 1 228 1 228 0 39 1 230 1 230 0 39 1 231 1 231 0 57 1 234 1 235 0 44 1 237 1 237 0 57 1 238 1 238 0 47 1 241 1 241 0 51 1 244 1 244 0 39 1 249 1 250 0 72 2 2 2 2 0 11 2 5 2 6 0 51 2 7 2 19 0 23 2 20 2 20 0 22 2 21 2 52 0 57 2 55 2 55 0 30 4 193 4 193 0 1 4 194 4 194 0 3 4 195 4 195 0 6 4 196 4 196 0 40 4 197 4 197 0 9 4 198 4 198 0 12 4 199 4 199 0 18 4 200 4 200 0 21 4 202 4 202 0 25 4 203 4 203 0 28 4 204 4 204 0 33 4 205 4 206 0 21 4 207 4 207 0 40 4 208 4 208 0 42 4 209 4 209 0 40 4 210 4 210 0 45 4 211 4 211 0 48 4 212 4 212 0 52 4 213 4 213 0 58 4 214 4 214 0 61 4 215 4 215 0 64 4 216 4 216 0 67 4 217 4 217 0 70 4 218 4 218 0 73 4 219 4 240 0 1 4 241 4 243 0 9 4 244 4 245 0 3 4 246 4 250 0 6 4 251 4 254 0 40 4 255 5 16 0 9 5 17 5 25 0 18 5 26 5 28 0 21 5 42 5 42 0 25 5 43 5 45 0 28 5 46 5 46 0 33 5 48 5 53 0 33 5 54 5 64 0 21 5 65 5 80 0 40 5 81 5 81 0 9 5 82 5 87 0 37 5 88 5 90 0 40 5 91 5 97 0 45 5 98 5 105 0 48 5 106 5 106 0 15 5 107 5 112 0 52 5 113 5 129 0 58 5 130 5 135 0 55 5 136 5 139 0 64 5 140 5 147 0 70 5 148 5 152 0 73 5 153 5 153 0 40 5 155 5 156 0 40 5 157 5 158 0 21 7 149 7 149 0 32 0 2 0 184 0 2 0 2 0 27 0 4 0 4 0 30 0 8 0 8 0 30 0 11 0 11 0 47 0 16 0 16 0 30 0 18 0 18 0 30 0 20 0 20 0 48 0 21 0 21 0 2 0 22 0 22 0 33 0 23 0 23 0 3 0 24 0 24 0 4 0 25 0 25 0 37 0 26 0 26 0 5 0 27 0 27 0 39 0 28 0 28 0 26 0 30 0 32 0 50 0 33 0 33 0 28 0 34 0 34 0 49 0 36 0 36 0 68 0 37 0 37 0 55 0 40 0 41 0 61 0 42 0 42 0 50 0 43 0 43 0 61 0 44 0 44 0 50 0 45 0 45 0 61 0 46 0 46 0 31 0 47 0 47 0 1 0 48 0 48 0 32 0 49 0 49 0 34 0 50 0 50 0 35 0 51 0 51 0 36 0 52 0 52 0 38 0 53 0 53 0 56 0 54 0 75 0 27 0 76 0 78 0 66 0 81 0 85 0 30 0 108 0 116 0 30 0 133 0 133 0 47 0 156 0 181 0 30 0 189 0 195 0 48 0 197 0 202 0 2 0 203 0 225 0 33 0 226 0 229 0 4 0 230 0 237 0 5 0 238 0 242 0 39 0 248 1 16 0 26 1 17 1 17 0 64 1 19 1 45 0 50 1 46 1 53 0 49 1 58 1 58 0 64 1 59 1 70 0 68 1 71 1 71 0 61 1 72 1 72 0 55 1 76 1 76 0 61 1 85 1 95 0 61 1 97 1 122 0 50 1 123 1 129 0 61 1 130 1 136 0 31 1 138 1 144 0 1 1 145 1 167 0 32 1 168 1 171 0 35 1 172 1 179 0 38 1 180 1 184 0 56 1 187 1 187 0 61 1 188 1 188 0 55 1 189 1 189 0 68 1 190 1 190 0 32 1 191 1 191 0 61 1 194 1 196 0 50 1 198 1 198 0 50 1 199 1 199 0 61 1 205 1 205 0 55 1 206 1 208 0 50 1 209 1 209 0 38 1 211 1 211 0 32 1 214 1 214 0 61 1 216 1 216 0 70 1 221 1 221 0 61 1 222 1 223 0 32 1 224 1 224 0 61 1 225 1 225 0 55 1 226 1 227 0 61 1 228 1 230 0 50 1 234 1 234 0 61 1 236 1 236 0 61 1 238 1 238 0 31 1 239 1 240 0 55 1 241 1 241 0 1 1 244 1 244 0 32 1 245 1 245 0 63 1 246 1 246 0 45 1 249 1 250 0 56 2 2 2 2 0 28 2 5 2 6 0 28 2 7 2 19 0 60 2 21 2 52 0 50 2 62 2 62 0 28 3 101 3 101 0 69 4 117 4 118 0 20 4 119 4 120 0 19 4 121 4 121 0 20 4 122 4 122 0 58 4 124 4 124 0 6 4 126 4 127 0 41 4 128 4 128 0 40 4 129 4 129 0 7 4 130 4 130 0 40 4 131 4 131 0 7 4 132 4 133 0 20 4 134 4 134 0 52 4 135 4 135 0 54 4 136 4 136 0 52 4 137 4 137 0 54 4 138 4 141 0 51 4 144 4 145 0 51 4 146 4 146 0 21 4 152 4 152 0 57 4 154 4 154 0 57 4 156 4 156 0 57 4 157 4 157 0 59 4 159 4 159 0 42 4 161 4 161 0 8 4 167 4 167 0 58 4 168 4 168 0 6 4 169 4 169 0 58 4 170 4 171 0 6 4 173 4 173 0 57 4 175 4 175 0 57 4 177 4 177 0 57 4 184 4 184 0 43 4 185 4 185 0 44 4 192 4 192 0 68 4 193 4 193 0 9 4 194 4 194 0 67 4 195 4 195 0 29 4 196 4 198 0 67 4 199 4 199 0 29 4 200 4 200 0 67 4 202 4 202 0 10 4 203 4 206 0 67 4 207 4 207 0 29 4 208 4 208 0 67 4 209 4 209 0 29 4 210 4 210 0 67 4 211 4 211 0 11 4 212 4 212 0 12 4 213 4 213 0 13 4 214 4 214 0 14 4 215 4 215 0 15 4 216 4 216 0 16 4 217 4 217 0 17 4 218 4 218 0 18 4 219 4 240 0 9 4 241 4 243 0 65 4 245 4 245 0 67 4 246 4 250 0 29 4 251 4 253 0 67 4 255 5 16 0 67 5 17 5 25 0 29 5 26 5 28 0 67 5 42 5 42 0 10 5 43 5 52 0 67 5 54 5 64 0 67 5 65 5 90 0 29 5 91 5 97 0 67 5 98 5 105 0 11 5 107 5 112 0 12 5 113 5 135 0 13 5 136 5 139 0 15 5 140 5 147 0 17 5 148 5 152 0 18 5 154 5 154 0 67 5 156 5 158 0 67 6 21 6 21 0 22 6 23 6 23 0 25 6 25 6 25 0 23 6 26 6 26 0 24 6 29 6 29 0 46 6 31 6 31 0 53 6 33 6 33 0 62 7 8 7 8 0 40 7 9 7 10 0 7 7 11 7 11 0 40 7 148 7 149 0 28 0 2 0 112 2 63 2 63 0 2 2 64 2 64 0 5 2 65 2 65 0 18 2 66 2 66 0 11 2 67 2 67 0 14 2 68 2 68 0 56 2 69 2 69 0 43 2 70 2 70 0 35 2 71 2 71 0 43 2 72 2 72 0 22 2 73 2 73 0 2 2 74 2 75 0 43 2 76 2 76 0 53 2 77 2 77 0 35 2 78 2 78 0 43 2 79 2 79 0 32 2 80 2 80 0 40 2 81 2 81 0 46 2 82 2 82 0 50 2 83 2 83 0 28 2 84 2 84 0 8 2 85 2 85 0 30 2 86 2 86 0 26 2 87 2 87 0 2 2 88 2 88 0 14 2 89 2 91 0 43 2 92 2 92 0 35 2 93 2 94 0 50 2 95 2 95 0 26 2 97 2 97 0 3 2 98 2 98 0 16 2 99 2 99 0 9 2 100 2 100 0 12 2 101 2 101 0 54 2 102 2 102 0 15 2 103 2 103 0 47 2 104 2 104 0 19 2 105 2 105 0 20 2 106 2 106 0 23 2 107 2 107 0 19 2 108 2 108 0 24 2 109 2 109 0 51 2 110 2 110 0 33 2 112 2 112 0 33 2 113 2 113 0 38 2 114 2 114 0 44 2 115 2 115 0 48 2 116 2 116 0 33 2 117 2 117 0 6 2 118 2 118 0 48 2 119 2 119 0 33 2 120 2 120 0 37 2 121 2 121 0 3 2 122 2 122 0 47 2 123 2 123 0 33 2 125 2 125 0 12 2 126 2 126 0 15 2 127 2 128 0 19 2 129 2 129 0 33 2 130 2 131 0 48 2 132 2 132 0 33 2 133 2 133 0 19 2 134 2 134 0 48 2 135 2 146 0 2 2 147 2 154 0 14 2 155 2 176 0 43 2 177 2 184 0 35 2 185 2 185 0 32 2 186 2 193 0 50 2 194 2 203 0 26 2 204 2 230 0 19 2 244 2 251 0 12 2 252 3 6 0 15 3 7 3 22 0 19 3 23 3 32 0 33 3 33 3 48 0 48 3 49 3 59 0 33 3 72 3 83 0 15 3 84 3 95 0 33 3 96 3 96 0 20 3 97 3 97 0 33 3 98 3 98 0 41 3 100 3 100 0 36 3 110 3 110 0 19 5 159 5 159 0 1 5 160 5 160 0 4 5 161 5 161 0 17 5 162 5 162 0 10 5 163 5 163 0 13 5 164 5 164 0 55 5 165 5 165 0 42 5 166 5 166 0 34 5 167 5 167 0 42 5 168 5 168 0 21 5 169 5 169 0 1 5 170 5 171 0 42 5 172 5 172 0 52 5 173 5 173 0 34 5 174 5 174 0 42 5 175 5 175 0 31 5 176 5 176 0 39 5 177 5 177 0 45 5 178 5 178 0 49 5 179 5 179 0 27 5 180 5 180 0 7 5 181 5 181 0 29 5 182 5 182 0 25 5 183 5 183 0 42 5 184 5 184 0 49 5 185 5 187 0 42 6 233 6 233 0 11 6 234 6 234 0 26 0 2 0 146 2 63 2 63 0 22 2 66 2 66 0 39 2 68 2 68 0 30 2 70 2 70 0 28 2 73 2 73 0 22 2 76 2 76 0 42 2 77 2 77 0 28 2 80 2 80 0 41 2 81 2 81 0 11 2 82 2 82 0 29 2 83 2 83 0 25 2 84 2 84 0 23 2 85 2 85 0 26 2 86 2 86 0 24 2 87 2 87 0 68 2 94 2 94 0 29 2 96 2 96 0 43 2 97 2 97 0 44 2 98 2 98 0 2 2 99 2 99 0 45 2 100 2 100 0 46 2 101 2 101 0 60 2 102 2 102 0 47 2 103 2 103 0 50 2 104 2 104 0 3 2 105 2 105 0 47 2 106 2 106 0 40 2 107 2 107 0 65 2 108 2 108 0 4 2 109 2 109 0 59 2 110 2 110 0 49 2 111 2 111 0 36 2 112 2 112 0 37 2 113 2 113 0 49 2 114 2 114 0 5 2 115 2 115 0 51 2 116 2 116 0 49 2 117 2 117 0 1 2 118 2 118 0 51 2 119 2 120 0 49 2 121 2 122 0 50 2 123 2 123 0 49 2 124 2 124 0 43 2 125 2 125 0 46 2 126 2 126 0 47 2 127 2 127 0 3 2 128 2 128 0 56 2 129 2 129 0 49 2 130 2 131 0 51 2 132 2 132 0 49 2 133 2 133 0 56 2 134 2 134 0 51 2 135 2 144 0 68 2 145 2 146 0 22 2 192 2 193 0 29 2 204 2 204 0 22 2 205 2 212 0 68 2 222 2 222 0 24 2 231 2 243 0 43 2 244 2 251 0 46 2 252 3 6 0 47 3 7 3 8 0 3 3 9 3 9 0 56 3 10 3 10 0 3 3 11 3 22 0 56 3 23 3 30 0 49 3 31 3 32 0 37 3 33 3 48 0 51 3 49 3 59 0 49 3 60 3 71 0 43 3 72 3 83 0 47 3 84 3 95 0 49 3 96 3 96 0 47 3 97 3 98 0 49 3 99 3 99 0 65 3 100 3 100 0 61 3 101 3 101 0 48 3 110 3 110 0 3 4 117 4 118 0 15 4 119 4 120 0 14 4 121 4 121 0 15 4 122 4 122 0 53 4 124 4 124 0 31 4 126 4 127 0 33 4 128 4 128 0 32 4 129 4 129 0 16 4 130 4 130 0 32 4 131 4 131 0 16 4 132 4 133 0 15 4 134 4 134 0 54 4 135 4 135 0 55 4 136 4 136 0 54 4 137 4 137 0 55 4 138 4 141 0 52 4 144 4 145 0 52 4 146 4 146 0 17 4 152 4 152 0 64 4 154 4 154 0 64 4 156 4 156 0 64 4 157 4 157 0 69 4 159 4 159 0 35 4 161 4 161 0 34 4 167 4 167 0 53 4 168 4 168 0 31 4 169 4 169 0 53 4 170 4 171 0 31 4 173 4 173 0 64 4 175 4 175 0 64 4 177 4 177 0 64 4 184 4 184 0 58 5 159 5 159 0 6 5 160 5 161 0 57 5 162 5 162 0 62 5 163 5 163 0 57 5 164 5 164 0 13 5 165 5 165 0 57 5 166 5 166 0 27 5 167 5 168 0 57 5 169 5 169 0 6 5 170 5 171 0 57 5 172 5 172 0 66 5 173 5 173 0 27 5 174 5 175 0 57 5 176 5 176 0 67 5 177 5 177 0 10 5 178 5 178 0 12 5 179 5 179 0 8 5 180 5 180 0 7 5 181 5 181 0 9 5 182 5 182 0 63 5 183 5 183 0 57 5 184 5 184 0 12 5 185 5 185 0 6 5 186 5 186 0 57 5 187 5 187 0 63 6 21 6 21 0 18 6 23 6 23 0 21 6 25 6 25 0 19 6 26 6 26 0 20 6 29 6 29 0 38 6 33 6 33 0 70 6 233 6 233 0 39 6 234 6 234 0 24 7 8 7 8 0 32 7 9 7 10 0 16 7 11 7 11 0 32 0 2 0 173 3 136 3 136 0 2 3 137 3 138 0 57 3 139 3 139 0 19 3 140 3 140 0 48 3 141 3 141 0 25 3 142 3 142 0 33 3 145 3 145 0 57 3 146 3 147 0 42 3 148 3 148 0 33 3 151 3 153 0 42 3 154 3 154 0 36 3 155 3 155 0 42 3 156 3 156 0 13 3 157 3 157 0 16 3 158 3 158 0 45 3 159 3 159 0 54 3 160 3 160 0 11 3 161 3 161 0 22 3 162 3 162 0 48 3 163 3 164 0 42 3 165 3 165 0 48 3 166 3 166 0 39 3 167 3 167 0 42 3 168 3 168 0 39 3 169 3 170 0 36 3 171 3 171 0 42 3 172 3 173 0 25 3 174 3 174 0 6 3 175 3 175 0 19 3 176 3 176 0 16 3 177 3 177 0 9 3 178 3 179 0 42 3 181 3 181 0 30 3 182 3 183 0 39 3 184 3 184 0 51 3 185 3 185 0 33 3 188 3 188 0 42 3 189 3 189 0 54 3 190 3 190 0 42 3 191 3 191 0 59 3 192 3 192 0 36 3 193 3 193 0 28 3 194 3 195 0 19 3 196 3 196 0 33 3 199 3 199 0 57 3 200 3 200 0 33 3 203 3 203 0 33 3 206 3 206 0 48 3 207 3 207 0 16 3 210 3 210 0 22 3 211 3 211 0 48 3 213 3 213 0 42 3 214 3 214 0 33 3 217 3 217 0 2 3 218 3 219 0 25 3 220 3 220 0 36 3 221 3 221 0 42 3 222 3 223 0 36 3 224 3 225 0 54 3 227 3 227 0 3 3 228 3 228 0 55 3 229 3 229 0 17 3 230 3 230 0 46 3 231 3 231 0 23 3 232 3 232 0 31 3 235 3 235 0 55 3 236 3 237 0 40 3 238 3 238 0 31 3 241 3 243 0 40 3 244 3 244 0 34 3 245 3 245 0 40 3 246 3 246 0 34 3 247 3 247 0 14 3 248 3 248 0 43 3 249 3 249 0 52 3 250 3 250 0 34 3 251 3 251 0 20 3 252 3 252 0 46 3 253 3 254 0 40 3 255 3 255 0 46 4 0 4 0 0 37 4 1 4 1 0 40 4 2 4 2 0 37 4 3 4 4 0 34 4 5 4 5 0 40 4 6 4 7 0 23 4 8 4 8 0 4 4 9 4 9 0 17 4 10 4 10 0 14 4 11 4 11 0 7 4 16 4 17 0 37 4 18 4 18 0 49 4 19 4 19 0 31 4 22 4 22 0 40 4 23 4 23 0 52 4 24 4 24 0 40 4 25 4 25 0 37 4 26 4 26 0 34 4 27 4 27 0 26 4 28 4 29 0 17 4 30 4 30 0 31 4 33 4 33 0 55 4 34 4 34 0 31 4 37 4 37 0 31 4 40 4 40 0 46 4 41 4 41 0 14 4 44 4 44 0 20 4 45 4 45 0 46 4 46 4 46 0 49 4 47 4 47 0 31 4 52 4 53 0 23 4 54 4 54 0 34 4 55 4 55 0 40 4 56 4 57 0 34 4 58 4 59 0 52 5 188 5 188 0 1 5 189 5 190 0 56 5 191 5 191 0 18 5 192 5 192 0 47 5 193 5 193 0 24 5 194 5 194 0 32 5 195 5 195 0 56 5 196 5 197 0 41 5 198 5 198 0 32 5 199 5 201 0 41 5 202 5 202 0 35 5 203 5 203 0 41 5 204 5 204 0 12 5 205 5 205 0 15 5 206 5 206 0 44 5 207 5 207 0 53 5 208 5 208 0 10 5 209 5 209 0 21 5 210 5 210 0 47 5 211 5 212 0 41 5 213 5 213 0 47 5 214 5 214 0 38 5 215 5 215 0 41 5 216 5 216 0 38 5 217 5 218 0 35 5 219 5 219 0 41 5 220 5 221 0 24 5 222 5 222 0 5 5 223 5 223 0 18 5 224 5 224 0 15 5 225 5 225 0 8 5 226 5 227 0 41 5 229 5 229 0 29 5 230 5 231 0 38 5 232 5 232 0 50 5 233 5 233 0 32 5 234 5 234 0 41 5 235 5 235 0 53 5 236 5 236 0 41 5 237 5 237 0 58 5 238 5 238 0 35 5 239 5 239 0 27 5 240 5 241 0 18 5 242 5 242 0 32 5 243 5 243 0 56 5 244 5 245 0 32 5 246 5 246 0 47 5 247 5 247 0 15 5 250 5 250 0 21 5 251 5 251 0 47 5 253 5 253 0 41 5 254 5 254 0 32 5 255 5 255 0 1 6 0 6 1 0 24 6 2 6 2 0 35 6 3 6 3 0 41 6 4 6 5 0 35 6 6 6 7 0 53 0 2 1 30 0 2 0 2 0 105 0 4 0 4 0 48 0 8 0 8 0 48 0 11 0 11 0 107 0 16 0 16 0 48 0 18 0 18 0 48 0 21 0 21 0 51 0 22 0 22 0 53 0 23 0 23 0 56 0 25 0 25 0 59 0 26 0 26 0 61 0 27 0 27 0 108 0 33 0 33 0 46 0 36 0 36 0 112 0 47 0 47 0 50 0 49 0 49 0 54 0 52 0 52 0 60 0 54 0 75 0 105 0 81 0 85 0 48 0 108 0 116 0 48 0 133 0 133 0 107 0 156 0 181 0 48 0 197 0 202 0 51 0 203 0 225 0 53 0 230 0 237 0 61 0 238 0 242 0 108 1 59 1 70 0 112 1 138 1 144 0 50 1 172 1 179 0 60 1 189 1 189 0 112 1 209 1 209 0 60 1 241 1 241 0 50 2 2 2 2 0 46 2 5 2 6 0 46 2 7 2 19 0 106 2 62 2 62 0 46 3 101 3 101 0 98 3 136 3 136 0 28 3 137 3 139 0 111 3 140 3 140 0 32 3 141 3 141 0 111 3 142 3 142 0 80 3 145 3 145 0 79 3 146 3 148 0 111 3 151 3 151 0 37 3 152 3 153 0 111 3 154 3 154 0 42 3 155 3 156 0 111 3 157 3 157 0 42 3 158 3 158 0 3 3 159 3 159 0 77 3 160 3 160 0 35 3 161 3 161 0 39 3 162 3 162 0 111 3 163 3 163 0 30 3 164 3 165 0 111 3 166 3 166 0 3 3 167 3 168 0 111 3 169 3 169 0 79 3 170 3 170 0 111 3 171 3 171 0 78 3 172 3 173 0 111 3 174 3 174 0 3 3 175 3 175 0 111 3 176 3 176 0 42 3 177 3 177 0 86 3 178 3 179 0 111 3 181 3 181 0 76 3 182 3 182 0 37 3 183 3 183 0 111 3 184 3 184 0 3 3 185 3 185 0 111 3 188 3 188 0 111 3 189 3 189 0 77 3 190 3 190 0 111 3 191 3 191 0 44 3 192 3 192 0 42 3 193 3 193 0 1 3 194 3 194 0 111 3 196 3 196 0 80 3 199 3 199 0 79 3 200 3 200 0 111 3 203 3 203 0 3 3 206 3 206 0 111 3 207 3 207 0 42 3 208 3 208 0 82 3 210 3 210 0 39 3 211 3 211 0 30 3 212 3 213 0 111 3 214 3 214 0 80 3 217 3 217 0 28 3 218 3 218 0 110 3 219 3 219 0 111 3 221 3 221 0 111 3 222 3 223 0 42 3 224 3 225 0 77 3 226 3 226 0 27 3 227 3 227 0 75 3 228 3 229 0 96 3 230 3 230 0 31 3 231 3 231 0 90 3 232 3 232 0 69 3 233 3 233 0 70 3 235 3 235 0 45 3 236 3 238 0 96 3 241 3 241 0 36 3 242 3 243 0 96 3 244 3 244 0 90 3 245 3 245 0 96 3 246 3 246 0 95 3 247 3 247 0 90 3 248 3 248 0 2 3 249 3 249 0 43 3 250 3 250 0 90 3 251 3 251 0 38 3 252 3 252 0 96 3 253 3 253 0 29 3 254 3 255 0 96 4 0 4 0 0 2 4 1 4 2 0 96 4 3 4 3 0 34 4 4 4 4 0 96 4 5 4 5 0 68 4 6 4 7 0 90 4 8 4 8 0 71 4 9 4 9 0 96 4 10 4 10 0 90 4 11 4 11 0 33 4 12 4 13 0 103 4 15 4 15 0 72 4 16 4 16 0 36 4 17 4 17 0 96 4 18 4 18 0 71 4 19 4 19 0 96 4 22 4 22 0 96 4 23 4 23 0 43 4 24 4 24 0 96 4 25 4 25 0 4 4 26 4 26 0 90 4 27 4 27 0 40 4 28 4 28 0 96 4 29 4 29 0 94 4 30 4 30 0 69 4 33 4 33 0 45 4 34 4 34 0 96 4 37 4 37 0 2 4 40 4 40 0 96 4 41 4 41 0 90 4 42 4 43 0 40 4 44 4 44 0 38 4 45 4 45 0 29 4 47 4 47 0 69 4 51 4 52 0 27 4 53 4 53 0 90 4 54 4 54 0 92 4 55 4 55 0 96 4 56 4 57 0 90 4 58 4 59 0 43 4 117 4 118 0 20 4 119 4 120 0 19 4 121 4 121 0 20 4 122 4 122 0 99 4 124 4 124 0 5 4 126 4 127 0 64 4 128 4 128 0 63 4 129 4 129 0 6 4 130 4 130 0 63 4 131 4 131 0 6 4 132 4 133 0 20 4 134 4 134 0 84 4 135 4 135 0 81 4 136 4 136 0 84 4 137 4 137 0 81 4 138 4 141 0 83 4 144 4 145 0 83 4 146 4 146 0 22 4 152 4 152 0 88 4 154 4 154 0 88 4 156 4 156 0 88 4 157 4 157 0 91 4 159 4 159 0 65 4 161 4 161 0 7 4 167 4 167 0 99 4 168 4 168 0 5 4 169 4 169 0 99 4 170 4 171 0 5 4 173 4 173 0 88 4 175 4 175 0 88 4 177 4 177 0 88 4 184 4 184 0 66 4 185 4 185 0 67 4 192 4 192 0 112 4 193 4 193 0 100 4 195 4 195 0 47 4 199 4 199 0 47 4 201 4 201 0 113 4 202 4 202 0 101 4 207 4 207 0 47 4 209 4 209 0 47 4 211 4 211 0 49 4 212 4 212 0 102 4 213 4 213 0 52 4 214 4 214 0 55 4 215 4 215 0 57 4 216 4 216 0 58 4 218 4 218 0 62 4 219 4 240 0 100 4 246 4 250 0 47 5 17 5 25 0 47 5 30 5 41 0 113 5 42 5 42 0 101 5 65 5 90 0 47 5 98 5 105 0 49 5 107 5 112 0 102 5 113 5 135 0 52 5 136 5 139 0 57 5 148 5 152 0 62 5 188 5 188 0 8 5 189 5 191 0 97 5 192 5 192 0 10 5 193 5 193 0 97 5 194 5 194 0 87 5 195 5 195 0 74 5 196 5 198 0 97 5 199 5 199 0 13 5 200 5 201 0 97 5 202 5 202 0 41 5 203 5 204 0 97 5 205 5 205 0 41 5 206 5 206 0 17 5 207 5 207 0 73 5 208 5 208 0 12 5 209 5 209 0 14 5 210 5 210 0 97 5 211 5 211 0 9 5 212 5 213 0 97 5 214 5 214 0 17 5 215 5 216 0 97 5 217 5 217 0 74 5 218 5 218 0 97 5 219 5 219 0 89 5 220 5 221 0 97 5 222 5 222 0 17 5 223 5 223 0 97 5 224 5 224 0 41 5 225 5 225 0 11 5 226 5 227 0 97 5 229 5 229 0 16 5 230 5 230 0 13 5 231 5 231 0 97 5 232 5 232 0 17 5 233 5 234 0 97 5 235 5 235 0 73 5 236 5 236 0 97 5 237 5 237 0 18 5 238 5 238 0 41 5 239 5 239 0 15 5 240 5 240 0 97 5 242 5 242 0 87 5 243 5 243 0 74 5 244 5 244 0 97 5 245 5 245 0 17 5 246 5 246 0 97 5 247 5 247 0 41 5 248 5 248 0 21 5 250 5 250 0 14 5 251 5 251 0 9 5 252 5 253 0 97 5 254 5 254 0 87 5 255 5 255 0 8 6 0 6 0 0 109 6 1 6 1 0 97 6 3 6 3 0 97 6 4 6 5 0 41 6 6 6 7 0 73 6 21 6 21 0 23 6 23 6 23 0 26 6 25 6 25 0 24 6 26 6 26 0 25 6 29 6 29 0 85 6 31 6 31 0 93 6 33 6 33 0 104 7 8 7 8 0 63 7 9 7 10 0 6 7 11 7 11 0 63 7 148 7 149 0 46 0 2 0 24 4 117 4 118 0 2 4 119 4 120 0 1 4 121 4 121 0 2 4 122 4 122 0 4 4 124 4 124 0 7 4 126 4 127 0 10 4 128 4 128 0 8 4 129 4 129 0 9 4 130 4 130 0 8 4 131 4 131 0 9 4 132 4 133 0 2 4 134 4 134 0 5 4 135 4 135 0 6 4 136 4 136 0 5 4 137 4 137 0 6 4 138 4 141 0 3 4 144 4 145 0 3 4 167 4 167 0 4 4 168 4 169 0 7 4 170 4 170 0 4 4 171 4 171 0 7 7 8 7 8 0 8 7 9 7 10 0 9 7 11 7 11 0 8 0 2 1 69 0 2 0 2 0 131 0 11 0 11 0 11 0 20 0 20 0 90 0 21 0 21 0 50 0 22 0 22 0 52 0 23 0 23 0 55 0 24 0 24 0 58 0 25 0 25 0 92 0 26 0 26 0 17 0 27 0 27 0 93 0 28 0 28 0 130 0 30 0 32 0 46 0 33 0 33 0 132 0 34 0 34 0 133 0 37 0 37 0 10 0 40 0 41 0 142 0 42 0 42 0 46 0 43 0 43 0 142 0 44 0 44 0 46 0 45 0 45 0 142 0 46 0 46 0 134 0 47 0 47 0 48 0 49 0 49 0 53 0 50 0 50 0 56 0 51 0 51 0 91 0 52 0 52 0 59 0 53 0 53 0 143 0 54 0 75 0 131 0 76 0 78 0 129 0 133 0 133 0 11 0 189 0 195 0 90 0 197 0 202 0 50 0 203 0 225 0 52 0 226 0 229 0 58 0 230 0 237 0 17 0 238 0 242 0 93 0 248 1 16 0 130 1 17 1 17 0 16 1 19 1 45 0 46 1 46 1 53 0 133 1 58 1 58 0 16 1 71 1 71 0 142 1 72 1 72 0 10 1 76 1 76 0 142 1 85 1 95 0 142 1 97 1 122 0 46 1 123 1 129 0 142 1 130 1 136 0 134 1 138 1 144 0 48 1 168 1 171 0 56 1 172 1 179 0 59 1 180 1 184 0 143 1 187 1 187 0 142 1 188 1 188 0 10 1 191 1 191 0 142 1 194 1 196 0 46 1 198 1 198 0 46 1 199 1 199 0 142 1 205 1 205 0 10 1 206 1 208 0 46 1 209 1 209 0 59 1 214 1 214 0 142 1 221 1 221 0 142 1 224 1 224 0 142 1 225 1 225 0 10 1 226 1 227 0 142 1 228 1 230 0 46 1 234 1 234 0 142 1 236 1 236 0 142 1 238 1 238 0 134 1 239 1 240 0 10 1 241 1 241 0 48 1 245 1 245 0 94 1 249 1 250 0 143 2 2 2 2 0 132 2 5 2 6 0 132 2 21 2 52 0 46 2 62 2 62 0 132 2 63 2 63 0 119 2 66 2 66 0 85 2 68 2 68 0 89 2 73 2 73 0 119 2 76 2 76 0 88 2 80 2 80 0 87 2 81 2 81 0 43 2 82 2 82 0 15 2 83 2 83 0 37 2 84 2 84 0 84 2 85 2 85 0 38 2 86 2 86 0 86 2 87 2 87 0 118 2 88 2 90 0 102 2 92 2 92 0 100 2 93 2 93 0 127 2 94 2 94 0 15 2 95 2 95 0 99 2 96 2 96 0 35 2 97 2 97 0 120 2 98 2 98 0 96 2 99 2 99 0 121 2 100 2 100 0 123 2 101 2 101 0 128 2 106 2 106 0 97 2 108 2 108 0 98 2 110 2 110 0 39 2 111 2 111 0 109 2 112 2 112 0 126 2 113 2 113 0 39 2 114 2 114 0 41 2 116 2 116 0 39 2 117 2 117 0 83 2 119 2 120 0 39 2 123 2 123 0 39 2 124 2 124 0 35 2 125 2 125 0 123 2 129 2 129 0 39 2 132 2 132 0 39 2 135 2 144 0 118 2 145 2 146 0 119 2 147 2 150 0 102 2 155 2 158 0 102 2 165 2 168 0 102 2 177 2 180 0 100 2 185 2 185 0 102 2 186 2 188 0 127 2 192 2 193 0 15 2 194 2 197 0 99 2 204 2 204 0 119 2 205 2 212 0 118 2 214 2 215 0 102 2 222 2 222 0 86 2 223 2 224 0 99 2 231 2 243 0 35 2 244 2 251 0 123 3 23 3 30 0 39 3 31 3 32 0 126 3 49 3 59 0 39 3 60 3 71 0 35 3 84 3 95 0 39 3 97 3 98 0 39 3 136 3 136 0 116 3 140 3 140 0 3 3 142 3 142 0 9 3 145 3 145 0 80 3 151 3 151 0 14 3 158 3 158 0 31 3 159 3 159 0 7 3 160 3 160 0 23 3 161 3 161 0 75 3 163 3 163 0 22 3 166 3 166 0 31 3 169 3 169 0 80 3 171 3 171 0 78 3 174 3 174 0 31 3 177 3 177 0 72 3 181 3 181 0 6 3 182 3 182 0 14 3 184 3 184 0 31 3 189 3 189 0 7 3 191 3 191 0 34 3 193 3 193 0 26 3 196 3 196 0 9 3 199 3 199 0 80 3 203 3 203 0 31 3 208 3 208 0 107 3 210 3 210 0 75 3 211 3 211 0 22 3 214 3 214 0 9 3 217 3 217 0 116 3 218 3 218 0 136 3 220 3 220 0 137 3 224 3 225 0 7 3 226 3 226 0 115 3 228 3 229 0 141 3 230 3 230 0 1 3 231 3 231 0 27 3 232 3 232 0 81 3 235 3 235 0 79 3 236 3 238 0 141 3 241 3 241 0 13 3 242 3 243 0 141 3 244 3 244 0 27 3 245 3 245 0 141 3 247 3 247 0 27 3 248 3 248 0 29 3 249 3 249 0 32 3 250 3 250 0 27 3 251 3 251 0 74 3 252 3 252 0 141 3 253 3 253 0 20 3 254 3 255 0 141 4 0 4 0 0 29 4 1 4 2 0 141 4 3 4 3 0 73 4 4 4 4 0 141 4 5 4 5 0 77 4 6 4 7 0 27 4 8 4 8 0 12 4 9 4 9 0 141 4 10 4 10 0 27 4 11 4 11 0 117 4 15 4 15 0 5 4 16 4 16 0 13 4 17 4 17 0 141 4 18 4 18 0 12 4 19 4 19 0 141 4 22 4 22 0 141 4 23 4 23 0 32 4 24 4 24 0 141 4 25 4 25 0 8 4 26 4 26 0 27 4 27 4 27 0 24 4 28 4 28 0 141 4 29 4 29 0 139 4 30 4 30 0 81 4 33 4 33 0 79 4 34 4 34 0 141 4 37 4 37 0 29 4 40 4 40 0 141 4 41 4 41 0 27 4 42 4 43 0 24 4 44 4 44 0 74 4 45 4 45 0 20 4 47 4 47 0 81 4 51 4 52 0 115 4 53 4 53 0 27 4 55 4 55 0 141 4 56 4 57 0 27 4 58 4 59 0 32 4 76 4 76 0 67 4 82 4 82 0 70 4 98 4 98 0 66 4 104 4 104 0 69 4 106 4 106 0 65 4 117 4 118 0 135 4 121 4 121 0 135 4 123 4 123 0 138 4 125 4 125 0 140 4 126 4 127 0 63 4 128 4 128 0 61 4 129 4 129 0 62 4 130 4 130 0 61 4 131 4 131 0 62 4 132 4 133 0 135 4 161 4 161 0 18 4 193 4 193 0 45 4 195 4 195 0 47 4 199 4 199 0 47 4 202 4 202 0 113 4 207 4 207 0 47 4 209 4 209 0 47 4 211 4 211 0 105 4 212 4 212 0 49 4 213 4 213 0 51 4 214 4 214 0 54 4 215 4 215 0 57 4 216 4 216 0 114 4 217 4 217 0 60 4 218 4 218 0 106 4 219 4 240 0 45 4 246 4 250 0 47 5 17 5 25 0 47 5 42 5 42 0 113 5 65 5 90 0 47 5 98 5 105 0 105 5 107 5 112 0 49 5 113 5 135 0 51 5 136 5 139 0 57 5 140 5 147 0 60 5 148 5 152 0 106 5 159 5 159 0 36 5 162 5 162 0 122 5 164 5 164 0 104 5 166 5 166 0 40 5 169 5 169 0 36 5 172 5 172 0 103 5 173 5 173 0 40 5 176 5 176 0 101 5 177 5 177 0 42 5 178 5 178 0 44 5 179 5 179 0 125 5 180 5 180 0 112 5 182 5 182 0 124 5 184 5 184 0 44 5 185 5 185 0 36 5 187 5 187 0 124 5 188 5 188 0 19 5 192 5 192 0 2 5 194 5 194 0 82 5 202 5 202 0 28 5 205 5 205 0 28 5 206 5 206 0 30 5 207 5 207 0 76 5 208 5 208 0 4 5 209 5 209 0 110 5 211 5 211 0 21 5 214 5 214 0 30 5 222 5 222 0 30 5 224 5 224 0 28 5 225 5 225 0 95 5 229 5 229 0 111 5 232 5 232 0 30 5 235 5 235 0 76 5 237 5 237 0 33 5 238 5 238 0 28 5 239 5 239 0 25 5 242 5 242 0 82 5 245 5 245 0 30 5 247 5 247 0 28 5 248 5 248 0 108 5 250 5 250 0 110 5 251 5 251 0 21 5 254 5 254 0 82 5 255 5 255 0 19 6 4 6 5 0 28 6 6 6 7 0 76 6 10 6 10 0 68 6 13 6 13 0 64 6 15 6 15 0 71 6 233 6 233 0 85 6 234 6 234 0 86 7 8 7 8 0 61 7 9 7 10 0 62 7 11 7 11 0 61 7 148 7 149 0 132 0 0 0 1 0 0 0 10 2 92 15 184 0 4 68 70 76 84 0 26 99 121 114 108 0 80 103 114 101 107 0 194 108 97 116 110 0 250 0 4 0 0 0 0 255 255 0 22 0 0 0 10 0 20 0 30 0 40 0 50 0 60 0 78 0 88 0 98 0 108 0 118 0 128 0 138 0 148 0 158 0 168 0 178 0 188 0 198 0 208 0 218 0 10 0 1 83 82 66 32 0 62 0 0 255 255 0 23 0 1 0 11 0 21 0 31 0 41 0 51 0 61 0 70 0 79 0 89 0 99 0 109 0 119 0 129 0 139 0 149 0 159 0 169 0 179 0 189 0 199 0 209 0 219 0 0 255 255 0 23 0 2 0 12 0 22 0 32 0 42 0 52 0 62 0 71 0 80 0 90 0 100 0 110 0 120 0 130 0 140 0 150 0 160 0 170 0 180 0 190 0 200 0 210 0 220 0 4 0 0 0 0 255 255 0 23 0 3 0 13 0 23 0 33 0 43 0 53 0 63 0 72 0 81 0 91 0 101 0 111 0 121 0 131 0 141 0 151 0 161 0 171 0 181 0 191 0 201 0 211 0 221 0 34 0 5 65 90 69 32 0 84 67 82 84 32 0 136 78 83 77 32 0 188 83 75 83 32 0 240 84 82 75 32 1 36 0 0 255 255 0 22 0 4 0 14 0 24 0 34 0 44 0 54 0 64 0 82 0 92 0 102 0 112 0 122 0 132 0 142 0 152 0 162 0 172 0 182 0 192 0 202 0 212 0 222 0 0 255 255 0 23 0 5 0 15 0 25 0 35 0 45 0 55 0 65 0 73 0 83 0 93 0 103 0 113 0 123 0 133 0 143 0 153 0 163 0 173 0 183 0 193 0 203 0 213 0 223 0 0 255 255 0 23 0 6 0 16 0 26 0 36 0 46 0 56 0 66 0 74 0 84 0 94 0 104 0 114 0 124 0 134 0 144 0 154 0 164 0 174 0 184 0 194 0 204 0 214 0 224 0 0 255 255 0 23 0 7 0 17 0 27 0 37 0 47 0 57 0 67 0 75 0 85 0 95 0 105 0 115 0 125 0 135 0 145 0 155 0 165 0 175 0 185 0 195 0 205 0 215 0 225 0 0 255 255 0 23 0 8 0 18 0 28 0 38 0 48 0 58 0 68 0 76 0 86 0 96 0 106 0 116 0 126 0 136 0 146 0 156 0 166 0 176 0 186 0 196 0 206 0 216 0 226 0 0 255 255 0 23 0 9 0 19 0 29 0 39 0 49 0 59 0 69 0 77 0 87 0 97 0 107 0 117 0 127 0 137 0 147 0 157 0 167 0 177 0 187 0 197 0 207 0 217 0 227 0 228 97 97 108 116 5 90 97 97 108 116 5 98 97 97 108 116 5 106 97 97 108 116 5 114 97 97 108 116 5 122 97 97 108 116 5 130 97 97 108 116 5 138 97 97 108 116 5 146 97 97 108 116 5 154 97 97 108 116 5 162 99 50 115 99 5 170 99 50 115 99 5 180 99 50 115 99 5 190 99 50 115 99 5 200 99 50 115 99 5 210 99 50 115 99 5 220 99 50 115 99 5 230 99 50 115 99 5 240 99 50 115 99 5 250 99 50 115 99 6 4 99 97 115 101 6 14 99 97 115 101 6 20 99 97 115 101 6 26 99 97 115 101 6 32 99 97 115 101 6 38 99 97 115 101 6 44 99 97 115 101 6 50 99 97 115 101 6 56 99 97 115 101 6 62 99 97 115 101 6 68 99 99 109 112 6 74 99 99 109 112 6 92 99 99 109 112 6 110 99 99 109 112 6 128 99 99 109 112 6 146 99 99 109 112 6 164 99 99 109 112 6 182 99 99 109 112 6 200 99 99 109 112 6 218 99 99 109 112 6 236 100 110 111 109 6 254 100 110 111 109 7 4 100 110 111 109 7 10 100 110 111 109 7 16 100 110 111 109 7 22 100 110 111 109 7 28 100 110 111 109 7 34 100 110 111 109 7 40 100 110 111 109 7 46 100 110 111 109 7 52 102 114 97 99 7 58 102 114 97 99 7 68 102 114 97 99 7 78 102 114 97 99 7 88 102 114 97 99 7 98 102 114 97 99 7 108 102 114 97 99 7 118 102 114 97 99 7 128 102 114 97 99 7 138 102 114 97 99 7 148 108 105 103 97 7 158 108 105 103 97 7 164 108 105 103 97 7 170 108 105 103 97 7 176 108 105 103 97 7 182 108 105 103 97 7 188 108 105 103 97 7 194 108 105 103 97 7 200 108 105 103 97 7 206 108 105 103 97 7 212 108 111 99 108 7 218 108 111 99 108 7 224 108 111 99 108 7 232 108 111 99 108 7 238 108 111 99 108 7 244 108 111 99 108 7 250 108 111 99 108 8 0 108 111 99 108 8 6 110 117 109 114 8 12 110 117 109 114 8 18 110 117 109 114 8 24 110 117 109 114 8 30 110 117 109 114 8 36 110 117 109 114 8 42 110 117 109 114 8 48 110 117 109 114 8 54 110 117 109 114 8 60 110 117 109 114 8 66 111 110 117 109 8 72 111 110 117 109 8 78 111 110 117 109 8 84 111 110 117 109 8 90 111 110 117 109 8 96 111 110 117 109 8 102 111 110 117 109 8 108 111 110 117 109 8 114 111 110 117 109 8 120 111 110 117 109 8 126 111 114 100 110 8 132 111 114 100 110 8 138 111 114 100 110 8 144 111 114 100 110 8 150 111 114 100 110 8 156 111 114 100 110 8 162 111 114 100 110 8 168 111 114 100 110 8 174 111 114 100 110 8 180 111 114 100 110 8 186 112 110 117 109 8 192 112 110 117 109 8 198 112 110 117 109 8 204 112 110 117 109 8 210 112 110 117 109 8 216 112 110 117 109 8 222 112 110 117 109 8 228 112 110 117 109 8 234 112 110 117 109 8 240 112 110 117 109 8 246 115 97 108 116 8 252 115 97 108 116 9 22 115 97 108 116 9 48 115 97 108 116 9 74 115 97 108 116 9 100 115 97 108 116 9 126 115 97 108 116 9 152 115 97 108 116 9 178 115 97 108 116 9 204 115 97 108 116 9 230 115 105 110 102 10 0 115 105 110 102 10 6 115 105 110 102 10 12 115 105 110 102 10 18 115 105 110 102 10 24 115 105 110 102 10 30 115 105 110 102 10 36 115 105 110 102 10 42 115 105 110 102 10 48 115 105 110 102 10 54 115 109 99 112 10 60 115 109 99 112 10 74 115 109 99 112 10 88 115 109 99 112 10 102 115 109 99 112 10 116 115 109 99 112 10 130 115 109 99 112 10 144 115 109 99 112 10 158 115 109 99 112 10 172 115 109 99 112 10 186 115 115 48 49 10 200 115 115 48 49 10 210 115 115 48 49 10 220 115 115 48 49 10 230 115 115 48 49 10 240 115 115 48 49 10 250 115 115 48 49 11 4 115 115 48 49 11 14 115 115 48 49 11 24 115 115 48 49 11 34 115 115 48 50 11 44 115 115 48 50 11 52 115 115 48 50 11 60 115 115 48 50 11 68 115 115 48 50 11 76 115 115 48 50 11 84 115 115 48 50 11 92 115 115 48 50 11 100 115 115 48 50 11 108 115 115 48 50 11 116 115 115 48 51 11 124 115 115 48 51 11 132 115 115 48 51 11 140 115 115 48 51 11 148 115 115 48 51 11 156 115 115 48 51 11 164 115 115 48 51 11 172 115 115 48 51 11 180 115 115 48 51 11 188 115 115 48 51 11 196 115 115 48 52 11 204 115 115 48 52 11 214 115 115 48 52 11 224 115 115 48 52 11 234 115 115 48 52 11 244 115 115 48 52 11 254 115 115 48 52 12 8 115 115 48 52 12 18 115 115 48 52 12 28 115 115 48 52 12 38 115 115 48 53 12 48 115 115 48 53 12 54 115 115 48 53 12 60 115 115 48 53 12 66 115 115 48 53 12 72 115 115 48 53 12 78 115 115 48 53 12 84 115 115 48 53 12 90 115 115 48 53 12 96 115 115 48 53 12 102 115 117 98 115 12 108 115 117 98 115 12 114 115 117 98 115 12 120 115 117 98 115 12 126 115 117 98 115 12 132 115 117 98 115 12 138 115 117 98 115 12 144 115 117 98 115 12 150 115 117 98 115 12 156 115 117 98 115 12 162 115 117 112 115 12 168 115 117 112 115 12 180 115 117 112 115 12 192 115 117 112 115 12 204 115 117 112 115 12 216 115 117 112 115 12 228 115 117 112 115 12 240 115 117 112 115 12 252 115 117 112 115 13 8 115 117 112 115 13 20 122 101 114 111 13 32 122 101 114 111 13 38 122 101 114 111 13 44 122 101 114 111 13 50 122 101 114 111 13 56 122 101 114 111 13 62 122 101 114 111 13 68 122 101 114 111 13 74 122 101 114 111 13 80 122 101 114 111 13 86 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 3 0 17 0 18 0 19 0 0 0 3 0 17 0 18 0 19 0 0 0 3 0 17 0 18 0 19 0 0 0 3 0 17 0 18 0 19 0 0 0 3 0 17 0 18 0 19 0 0 0 3 0 17 0 18 0 19 0 0 0 3 0 17 0 18 0 19 0 0 0 3 0 17 0 18 0 19 0 0 0 3 0 17 0 18 0 19 0 0 0 3 0 17 0 18 0 19 0 0 0 1 0 35 0 0 0 1 0 35 0 0 0 1 0 35 0 0 0 1 0 35 0 0 0 1 0 35 0 0 0 1 0 35 0 0 0 1 0 35 0 0 0 1 0 35 0 0 0 1 0 35 0 0 0 1 0 35 0 0 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 0 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 0 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 0 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 0 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 0 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 0 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 0 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 0 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 0 0 7 0 8 0 9 0 10 0 11 0 12 0 13 0 14 0 0 0 1 0 23 0 0 0 1 0 23 0 0 0 1 0 23 0 0 0 1 0 23 0 0 0 1 0 23 0 0 0 1 0 23 0 0 0 1 0 23 0 0 0 1 0 23 0 0 0 1 0 23 0 0 0 1 0 23 0 0 0 3 0 22 0 24 0 25 0 0 0 3 0 22 0 24 0 25 0 0 0 3 0 22 0 24 0 25 0 0 0 3 0 22 0 24 0 25 0 0 0 3 0 22 0 24 0 25 0 0 0 3 0 22 0 24 0 25 0 0 0 3 0 22 0 24 0 25 0 0 0 3 0 22 0 24 0 25 0 0 0 3 0 22 0 24 0 25 0 0 0 3 0 22 0 24 0 25 0 0 0 1 0 47 0 0 0 1 0 47 0 0 0 1 0 47 0 0 0 1 0 47 0 0 0 1 0 47 0 0 0 1 0 47 0 0 0 1 0 47 0 0 0 1 0 47 0 0 0 1 0 47 0 0 0 1 0 47 0 0 0 1 0 5 0 0 0 2 0 5 0 6 0 0 0 1 0 4 0 0 0 1 0 2 0 0 0 1 0 2 0 0 0 1 0 3 0 0 0 1 0 3 0 0 0 1 0 2 0 0 0 1 0 22 0 0 0 1 0 22 0 0 0 1 0 22 0 0 0 1 0 22 0 0 0 1 0 22 0 0 0 1 0 22 0 0 0 1 0 22 0 0 0 1 0 22 0 0 0 1 0 22 0 0 0 1 0 22 0 0 0 1 0 32 0 0 0 1 0 32 0 0 0 1 0 32 0 0 0 1 0 32 0 0 0 1 0 32 0 0 0 1 0 32 0 0 0 1 0 32 0 0 0 1 0 32 0 0 0 1 0 32 0 0 0 1 0 32 0 0 0 1 0 26 0 0 0 1 0 26 0 0 0 1 0 26 0 0 0 1 0 26 0 0 0 1 0 26 0 0 0 1 0 26 0 0 0 1 0 26 0 0 0 1 0 26 0 0 0 1 0 26 0 0 0 1 0 26 0 0 0 1 0 31 0 0 0 1 0 31 0 0 0 1 0 31 0 0 0 1 0 31 0 0 0 1 0 31 0 0 0 1 0 31 0 0 0 1 0 31 0 0 0 1 0 31 0 0 0 1 0 31 0 0 0 1 0 31 0 0 0 11 0 3 0 36 0 37 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 0 0 11 0 3 0 36 0 37 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 0 0 11 0 3 0 36 0 37 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 0 0 11 0 3 0 36 0 37 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 0 0 11 0 3 0 36 0 37 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 0 0 11 0 3 0 36 0 37 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 0 0 11 0 3 0 36 0 37 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 0 0 11 0 3 0 36 0 37 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 0 0 11 0 3 0 36 0 37 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 0 0 11 0 3 0 36 0 37 0 39 0 40 0 41 0 42 0 43 0 44 0 45 0 46 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 5 0 15 0 16 0 18 0 20 0 21 0 0 0 5 0 15 0 16 0 18 0 20 0 21 0 0 0 5 0 15 0 16 0 18 0 20 0 21 0 0 0 5 0 15 0 16 0 18 0 20 0 21 0 0 0 5 0 15 0 16 0 18 0 20 0 21 0 0 0 5 0 15 0 16 0 18 0 20 0 21 0 0 0 5 0 15 0 16 0 18 0 20 0 21 0 0 0 5 0 15 0 16 0 18 0 20 0 21 0 0 0 5 0 15 0 16 0 18 0 20 0 21 0 0 0 5 0 15 0 16 0 18 0 20 0 21 27 134 0 3 0 36 0 37 0 38 27 124 0 3 0 36 0 37 0 38 27 114 0 3 0 36 0 37 0 38 27 104 0 3 0 36 0 37 0 38 27 94 0 3 0 36 0 37 0 38 27 84 0 3 0 36 0 37 0 38 27 74 0 3 0 36 0 37 0 38 27 64 0 3 0 36 0 37 0 38 27 54 0 3 0 36 0 37 0 38 27 44 0 3 0 36 0 37 0 38 27 78 0 2 0 39 0 40 27 70 0 2 0 39 0 40 27 62 0 2 0 39 0 40 27 54 0 2 0 39 0 40 27 46 0 2 0 39 0 40 27 38 0 2 0 39 0 40 27 30 0 2 0 39 0 40 27 22 0 2 0 39 0 40 27 14 0 2 0 39 0 40 27 6 0 2 0 39 0 40 27 64 0 2 0 41 0 42 27 56 0 2 0 41 0 42 27 48 0 2 0 41 0 42 27 40 0 2 0 41 0 42 27 32 0 2 0 41 0 42 27 24 0 2 0 41 0 42 27 16 0 2 0 41 0 42 27 8 0 2 0 41 0 42 27 0 0 2 0 41 0 42 26 248 0 2 0 41 0 42 27 20 0 3 0 43 0 44 0 45 27 10 0 3 0 43 0 44 0 45 27 0 0 3 0 43 0 44 0 45 26 246 0 3 0 43 0 44 0 45 26 236 0 3 0 43 0 44 0 45 26 226 0 3 0 43 0 44 0 45 26 216 0 3 0 43 0 44 0 45 26 206 0 3 0 43 0 44 0 45 26 196 0 3 0 43 0 44 0 45 26 186 0 3 0 43 0 44 0 45 25 164 0 1 0 33 25 158 0 1 0 33 25 152 0 1 0 33 25 146 0 1 0 33 25 140 0 1 0 33 25 134 0 1 0 33 25 128 0 1 0 33 25 122 0 1 0 33 25 116 0 1 0 33 25 110 0 1 0 33 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 1 0 30 0 0 0 4 0 26 0 27 0 28 0 29 0 0 0 4 0 26 0 27 0 28 0 29 0 0 0 4 0 26 0 27 0 28 0 29 0 0 0 4 0 26 0 27 0 28 0 29 0 0 0 4 0 26 0 27 0 28 0 29 0 0 0 4 0 26 0 27 0 28 0 29 0 0 0 4 0 26 0 27 0 28 0 29 0 0 0 4 0 26 0 27 0 28 0 29 0 0 0 4 0 26 0 27 0 28 0 29 0 0 0 4 0 26 0 27 0 28 0 29 0 0 0 1 0 34 0 0 0 1 0 34 0 0 0 1 0 34 0 0 0 1 0 34 0 0 0 1 0 34 0 0 0 1 0 34 0 0 0 1 0 34 0 0 0 1 0 34 0 0 0 1 0 34 0 0 0 1 0 34 0 50 0 102 0 110 0 118 0 126 0 134 0 142 0 150 0 158 0 166 0 178 0 188 0 196 0 204 0 212 0 222 0 240 0 248 1 0 1 8 1 16 1 24 1 32 1 40 1 48 1 56 1 64 1 76 1 84 1 92 1 100 1 108 1 116 1 124 1 132 1 140 1 148 1 156 1 164 1 172 1 180 1 188 1 196 1 204 1 212 1 220 1 228 1 236 1 244 1 252 2 4 0 1 0 0 0 1 25 214 0 3 0 0 0 1 31 44 0 1 0 0 0 1 1 150 0 1 0 0 0 1 1 148 0 1 0 0 0 1 1 146 0 1 0 0 0 1 1 152 0 1 0 0 0 1 1 150 0 2 0 0 0 1 1 148 0 6 0 0 0 3 1 226 1 244 2 6 0 6 0 0 0 2 2 12 2 32 0 4 0 0 0 1 2 40 0 4 0 0 0 1 3 42 0 4 0 0 0 1 3 240 0 6 0 0 0 2 14 112 14 130 0 6 0 0 0 6 14 138 14 156 14 174 14 192 14 210 14 228 0 1 0 0 0 1 14 228 0 1 0 0 0 1 15 42 0 1 0 0 0 1 16 26 0 1 0 0 0 1 19 104 0 1 0 0 0 1 19 102 0 1 0 0 0 1 19 140 0 1 0 0 0 1 21 68 0 1 0 0 0 1 21 218 0 1 0 0 0 1 21 244 0 1 0 0 0 1 22 14 0 6 0 0 0 3 22 12 22 30 22 48 0 1 0 0 0 1 22 56 0 1 0 0 0 1 22 112 0 1 0 0 0 1 22 110 0 1 0 0 0 1 22 136 0 1 0 0 0 1 22 142 0 1 0 0 0 1 22 168 0 1 0 0 0 1 22 206 0 1 0 0 0 1 22 248 0 1 0 0 0 1 22 246 0 1 0 0 0 1 22 244 0 1 0 0 0 1 23 90 0 1 0 0 0 1 23 110 0 1 0 0 0 1 23 108 0 1 0 0 0 1 23 110 0 1 0 0 0 1 23 158 0 1 0 0 0 1 23 160 0 1 0 0 0 1 23 178 0 1 0 0 0 1 23 180 0 1 0 0 0 1 23 204 0 2 0 0 0 1 23 208 0 1 0 0 0 1 24 38 0 4 0 0 0 1 24 36 0 4 0 0 0 1 34 162 0 1 0 0 0 1 34 172 0 1 35 10 4 156 0 1 35 10 1 30 0 2 35 10 0 4 7 33 7 36 7 67 7 69 0 1 35 8 0 1 0 1 35 10 0 89 0 1 35 10 0 10 0 26 0 32 0 38 0 44 0 50 0 56 0 62 0 68 0 74 0 80 0 2 0 6 7 37 0 2 0 6 7 41 0 2 0 16 7 37 0 2 0 16 7 41 0 2 0 32 7 37 0 2 0 32 7 41 0 2 0 42 7 37 0 2 0 42 7 41 0 2 0 10 7 51 0 2 1 71 7 51 0 3 0 0 0 1 34 204 0 1 34 216 0 1 0 0 0 7 0 3 0 0 0 1 34 204 0 1 34 216 0 1 0 0 0 7 0 3 0 0 0 1 34 204 0 1 34 198 0 1 0 0 0 7 0 3 0 0 0 2 34 88 34 194 0 1 34 180 0 1 0 0 0 48 0 3 0 0 0 1 34 180 0 1 34 160 0 1 0 0 0 49 0 1 34 168 0 5 0 16 0 58 0 100 0 166 0 216 0 5 0 12 0 18 0 24 0 30 0 36 7 118 0 2 7 31 7 116 0 2 7 34 7 122 0 2 7 39 7 132 0 2 7 45 7 120 0 2 7 53 0 5 0 12 0 18 0 24 0 30 0 36 7 126 0 2 7 31 7 124 0 2 7 34 7 130 0 2 7 39 7 128 0 2 7 53 7 130 0 2 7 101 0 8 0 18 0 24 0 30 0 36 0 42 0 48 0 54 0 60 7 108 0 2 7 31 7 110 0 2 7 33 7 105 0 2 7 34 7 107 0 2 7 36 7 111 0 2 7 39 7 112 0 2 7 41 7 114 0 2 7 59 7 111 0 2 7 101 0 6 0 14 0 20 0 26 0 32 0 38 0 44 7 137 0 2 7 31 7 137 0 2 7 33 7 136 0 2 7 34 7 136 0 2 7 36 7 138 0 2 7 39 7 138 0 2 7 101 0 6 0 14 0 20 0 26 0 32 0 38 0 44 7 140 0 2 7 31 7 140 0 2 7 33 7 139 0 2 7 34 7 139 0 2 7 36 7 141 0 2 7 39 7 141 0 2 7 101 0 1 33 172 0 16 0 38 0 48 0 58 0 68 0 78 0 88 0 98 0 108 0 118 0 128 0 146 0 156 0 166 0 176 0 186 0 196 0 1 0 4 0 75 0 2 7 86 0 1 0 4 0 106 0 2 7 86 0 1 0 4 0 115 0 2 7 39 0 1 0 4 0 131 0 2 7 86 0 1 0 4 0 181 0 2 7 86 0 1 0 4 0 219 0 2 7 86 0 1 0 4 1 13 0 2 7 86 0 1 0 4 1 24 0 2 7 59 0 1 0 4 1 44 0 2 7 86 0 2 0 6 0 12 1 53 0 2 7 39 1 50 0 2 7 84 0 1 0 4 1 68 0 2 7 86 0 1 0 4 1 78 0 2 7 59 0 1 0 4 1 122 0 2 7 86 0 1 0 4 1 138 0 2 7 59 0 1 0 4 1 161 0 2 7 86 0 1 0 4 2 49 0 2 7 84 0 1 33 2 0 22 0 50 1 68 1 134 2 136 2 242 3 52 3 62 3 136 4 138 5 106 5 172 6 124 7 6 7 72 7 90 7 228 8 180 8 246 9 56 9 122 9 212 10 46 0 30 0 62 0 70 0 78 0 86 0 94 0 102 0 110 0 118 0 126 0 134 0 142 0 150 0 158 0 166 0 174 0 182 0 190 0 196 0 202 0 208 0 214 0 220 0 226 0 232 0 238 0 244 0 250 1 0 1 6 1 12 2 206 0 3 3 110 7 67 2 205 0 3 3 110 7 69 2 210 0 3 3 110 7 136 2 208 0 3 3 110 7 137 2 212 0 3 3 110 7 138 2 209 0 3 3 110 7 139 2 207 0 3 3 110 7 140 2 211 0 3 3 110 7 141 2 206 0 3 7 103 7 67 2 205 0 3 7 103 7 69 2 210 0 3 7 103 7 136 2 208 0 3 7 103 7 137 2 212 0 3 7 103 7 138 2 209 0 3 7 103 7 139 2 207 0 3 7 103 7 140 2 211 0 3 7 103 7 141 2 204 0 2 3 110 2 137 0 2 7 31 2 138 0 2 7 34 2 146 0 2 7 41 2 145 0 2 7 45 2 136 0 2 7 67 2 135 0 2 7 69 2 204 0 2 7 103 2 142 0 2 7 136 2 140 0 2 7 137 2 144 0 2 7 138 2 141 0 2 7 139 2 139 0 2 7 140 2 143 0 2 7 141 0 8 0 18 0 24 0 30 0 36 0 42 0 48 0 54 0 60 2 149 0 2 7 31 2 150 0 2 7 34 2 148 0 2 7 67 2 147 0 2 7 69 2 154 0 2 7 136 2 152 0 2 7 137 2 153 0 2 7 139 2 151 0 2 7 140 0 28 0 58 0 66 0 74 0 82 0 90 0 98 0 106 0 114 0 122 0 130 0 138 0 146 0 154 0 162 0 170 0 178 0 186 0 192 0 198 0 204 0 210 0 216 0 222 0 228 0 234 0 240 0 246 0 252 2 215 0 3 3 110 7 67 2 214 0 3 3 110 7 69 2 219 0 3 3 110 7 136 2 217 0 3 3 110 7 137 2 221 0 3 3 110 7 138 2 218 0 3 3 110 7 139 2 216 0 3 3 110 7 140 2 220 0 3 3 110 7 141 2 215 0 3 7 103 7 67 2 214 0 3 7 103 7 69 2 219 0 3 7 103 7 136 2 217 0 3 7 103 7 137 2 221 0 3 7 103 7 138 2 218 0 3 7 103 7 139 2 216 0 3 7 103 7 140 2 220 0 3 7 103 7 141 2 213 0 2 3 110 2 157 0 2 7 31 2 158 0 2 7 34 2 156 0 2 7 67 2 155 0 2 7 69 2 213 0 2 7 103 2 162 0 2 7 136 2 160 0 2 7 137 2 164 0 2 7 138 2 161 0 2 7 139 2 159 0 2 7 140 2 163 0 2 7 141 0 13 0 28 0 34 0 40 0 46 0 52 0 58 0 64 0 70 0 76 0 82 0 88 0 94 0 100 2 174 0 2 3 121 2 167 0 2 7 31 2 168 0 2 7 34 2 176 0 2 7 41 2 175 0 2 7 45 2 91 0 2 7 51 2 166 0 2 7 67 2 165 0 2 7 69 2 172 0 2 7 136 2 170 0 2 7 137 2 171 0 2 7 139 2 169 0 2 7 140 2 173 0 2 7 141 0 8 0 18 0 24 0 30 0 36 0 42 0 48 0 54 0 60 2 179 0 2 7 31 2 180 0 2 7 34 2 178 0 2 7 67 2 177 0 2 7 69 2 184 0 2 7 136 2 182 0 2 7 137 2 183 0 2 7 139 2 181 0 2 7 140 0 1 0 4 2 185 0 2 7 67 0 9 0 20 0 26 0 32 0 38 0 44 0 50 0 56 0 62 0 68 2 187 0 2 7 31 2 188 0 2 7 34 2 193 0 2 7 41 2 192 0 2 7 45 2 94 0 2 7 51 2 186 0 2 7 67 2 190 0 2 7 136 2 189 0 2 7 137 2 191 0 2 7 138 0 28 0 58 0 66 0 74 0 82 0 90 0 98 0 106 0 114 0 122 0 130 0 138 0 146 0 154 0 162 0 170 0 178 0 186 0 192 0 198 0 204 0 210 0 216 0 222 0 228 0 234 0 240 0 246 0 252 2 224 0 3 3 110 7 67 2 223 0 3 3 110 7 69 2 228 0 3 3 110 7 136 2 226 0 3 3 110 7 137 2 230 0 3 3 110 7 138 2 227 0 3 3 110 7 139 2 225 0 3 3 110 7 140 2 229 0 3 3 110 7 141 2 224 0 3 7 103 7 67 2 223 0 3 7 103 7 69 2 228 0 3 7 103 7 136 2 226 0 3 7 103 7 137 2 230 0 3 7 103 7 138 2 227 0 3 7 103 7 139 2 225 0 3 7 103 7 140 2 229 0 3 7 103 7 141 2 222 0 2 3 110 2 194 0 2 3 112 2 200 0 2 3 118 2 196 0 2 7 31 2 197 0 2 7 34 2 195 0 2 7 67 2 222 0 2 7 103 2 201 0 2 7 136 2 199 0 2 7 137 2 203 0 2 7 138 2 198 0 2 7 140 2 202 0 2 7 141 0 25 0 52 0 60 0 68 0 76 0 84 0 92 0 100 0 108 0 116 0 124 0 132 0 140 0 146 0 152 0 158 0 164 0 170 0 176 0 182 0 188 0 194 0 200 0 206 0 212 0 218 3 63 0 3 7 103 7 31 3 64 0 3 7 103 7 34 3 62 0 3 7 103 7 67 3 61 0 3 7 103 7 69 3 71 0 3 7 103 7 101 3 68 0 3 7 103 7 136 3 66 0 3 7 103 7 137 3 70 0 3 7 103 7 138 3 67 0 3 7 103 7 139 3 65 0 3 7 103 7 140 3 69 0 3 7 103 7 141 2 233 0 2 7 31 2 234 0 2 7 34 2 242 0 2 7 41 2 241 0 2 7 45 2 232 0 2 7 67 2 231 0 2 7 69 2 243 0 2 7 101 3 60 0 2 7 103 2 238 0 2 7 136 2 236 0 2 7 137 2 240 0 2 7 138 2 237 0 2 7 139 2 235 0 2 7 140 2 239 0 2 7 141 0 8 0 18 0 24 0 30 0 36 0 42 0 48 0 54 0 60 2 246 0 2 7 31 2 247 0 2 7 34 2 245 0 2 7 67 2 244 0 2 7 69 2 251 0 2 7 136 2 249 0 2 7 137 2 250 0 2 7 139 2 248 0 2 7 140 0 23 0 48 0 56 0 64 0 72 0 80 0 88 0 96 0 104 0 112 0 120 0 128 0 136 0 142 0 148 0 154 0 160 0 166 0 172 0 178 0 184 0 190 0 196 0 202 3 75 0 3 7 103 7 31 3 76 0 3 7 103 7 34 3 74 0 3 7 103 7 67 3 73 0 3 7 103 7 69 3 83 0 3 7 103 7 101 3 80 0 3 7 103 7 136 3 78 0 3 7 103 7 137 3 82 0 3 7 103 7 138 3 79 0 3 7 103 7 139 3 77 0 3 7 103 7 140 3 81 0 3 7 103 7 141 2 254 0 2 7 31 2 255 0 2 7 34 2 253 0 2 7 67 2 252 0 2 7 69 3 6 0 2 7 101 3 72 0 2 7 103 3 3 0 2 7 136 3 1 0 2 7 137 3 5 0 2 7 138 3 2 0 2 7 139 3 0 0 2 7 140 3 4 0 2 7 141 0 17 0 36 0 42 0 48 0 54 0 60 0 66 0 72 0 78 0 84 0 90 0 96 0 102 0 108 0 114 0 120 0 126 0 132 3 9 0 2 7 31 3 10 0 2 7 34 3 18 0 2 7 41 3 17 0 2 7 45 2 128 0 2 7 51 3 8 0 2 7 67 3 7 0 2 7 69 3 19 0 2 7 101 3 21 0 2 7 105 3 20 0 2 7 108 3 22 0 2 7 111 3 14 0 2 7 136 3 12 0 2 7 137 3 16 0 2 7 138 3 13 0 2 7 139 3 11 0 2 7 140 3 15 0 2 7 141 0 8 0 18 0 24 0 30 0 36 0 42 0 48 0 54 0 60 3 25 0 2 7 31 3 26 0 2 7 34 3 24 0 2 7 67 3 23 0 2 7 69 3 30 0 2 7 136 3 28 0 2 7 137 3 29 0 2 7 139 3 27 0 2 7 140 0 2 0 6 0 12 3 32 0 2 7 67 3 31 0 2 7 69 0 17 0 36 0 42 0 48 0 54 0 60 0 66 0 72 0 78 0 84 0 90 0 96 0 102 0 108 0 114 0 120 0 126 0 132 3 35 0 2 7 31 3 36 0 2 7 34 3 45 0 2 7 41 3 44 0 2 7 45 2 131 0 2 7 51 3 34 0 2 7 67 3 33 0 2 7 69 3 43 0 2 7 101 3 47 0 2 7 105 3 46 0 2 7 108 3 48 0 2 7 111 3 40 0 2 7 136 3 38 0 2 7 137 3 42 0 2 7 138 3 39 0 2 7 139 3 37 0 2 7 140 3 41 0 2 7 141 0 23 0 48 0 56 0 64 0 72 0 80 0 88 0 96 0 104 0 112 0 120 0 128 0 136 0 142 0 148 0 154 0 160 0 166 0 172 0 178 0 184 0 190 0 196 0 202 3 87 0 3 7 103 7 31 3 88 0 3 7 103 7 34 3 86 0 3 7 103 7 67 3 85 0 3 7 103 7 69 3 95 0 3 7 103 7 101 3 92 0 3 7 103 7 136 3 90 0 3 7 103 7 137 3 94 0 3 7 103 7 138 3 91 0 3 7 103 7 139 3 89 0 3 7 103 7 140 3 93 0 3 7 103 7 141 3 51 0 2 7 31 3 52 0 2 7 34 3 50 0 2 7 67 3 49 0 2 7 69 3 59 0 2 7 101 3 84 0 2 7 103 3 56 0 2 7 136 3 54 0 2 7 137 3 58 0 2 7 138 3 55 0 2 7 139 3 53 0 2 7 140 3 57 0 2 7 141 0 8 0 18 0 24 0 30 0 36 0 42 0 48 0 54 0 60 2 206 0 2 7 67 2 205 0 2 7 69 2 210 0 2 7 136 2 208 0 2 7 137 2 212 0 2 7 138 2 209 0 2 7 139 2 207 0 2 7 140 2 211 0 2 7 141 0 8 0 18 0 24 0 30 0 36 0 42 0 48 0 54 0 60 2 215 0 2 7 67 2 214 0 2 7 69 2 219 0 2 7 136 2 217 0 2 7 137 2 221 0 2 7 138 2 218 0 2 7 139 2 216 0 2 7 140 2 220 0 2 7 141 0 8 0 18 0 24 0 30 0 36 0 42 0 48 0 54 0 60 2 224 0 2 7 67 2 223 0 2 7 69 2 228 0 2 7 136 2 226 0 2 7 137 2 230 0 2 7 138 2 227 0 2 7 139 2 225 0 2 7 140 2 229 0 2 7 141 0 11 0 24 0 30 0 36 0 42 0 48 0 54 0 60 0 66 0 72 0 78 0 84 3 63 0 2 7 31 3 64 0 2 7 34 3 62 0 2 7 67 3 61 0 2 7 69 3 71 0 2 7 101 3 68 0 2 7 136 3 66 0 2 7 137 3 70 0 2 7 138 3 67 0 2 7 139 3 65 0 2 7 140 3 69 0 2 7 141 0 11 0 24 0 30 0 36 0 42 0 48 0 54 0 60 0 66 0 72 0 78 0 84 3 75 0 2 7 31 3 76 0 2 7 34 3 74 0 2 7 67 3 73 0 2 7 69 3 83 0 2 7 101 3 80 0 2 7 136 3 78 0 2 7 137 3 82 0 2 7 138 3 79 0 2 7 139 3 77 0 2 7 140 3 81 0 2 7 141 0 11 0 24 0 30 0 36 0 42 0 48 0 54 0 60 0 66 0 72 0 78 0 84 3 87 0 2 7 31 3 88 0 2 7 34 3 86 0 2 7 67 3 85 0 2 7 69 3 95 0 2 7 101 3 92 0 2 7 136 3 90 0 2 7 137 3 94 0 2 7 138 3 91 0 2 7 139 3 89 0 2 7 140 3 93 0 2 7 141 0 3 0 1 22 170 0 1 23 32 0 0 0 1 0 0 0 49 0 3 0 1 23 74 0 1 23 14 0 0 0 1 0 0 0 49 0 3 0 0 0 1 23 116 0 1 23 116 0 1 0 0 0 49 0 3 0 0 0 1 23 104 0 1 23 104 0 1 0 0 0 49 0 3 0 0 0 1 23 92 0 1 23 92 0 1 0 0 0 49 0 3 0 1 23 80 0 1 23 62 0 0 0 1 0 0 0 49 0 3 0 1 23 70 0 1 23 50 0 0 0 1 0 0 0 49 0 3 0 1 23 58 0 1 23 38 0 0 0 1 0 0 0 49 0 2 23 46 0 36 5 159 5 160 5 161 5 162 5 163 5 164 5 165 5 166 5 167 5 168 5 169 5 170 5 171 5 172 5 173 5 174 5 175 5 176 5 177 5 178 5 179 5 180 5 181 5 182 5 176 5 159 5 163 5 165 5 167 5 183 5 173 5 178 5 184 5 182 5 183 5 184 0 2 22 240 0 121 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 163 5 163 5 163 5 163 5 163 5 163 5 163 5 163 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 183 5 183 5 183 5 173 5 173 5 173 5 173 5 173 5 173 5 173 5 173 5 175 5 175 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 184 5 184 5 184 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 187 5 187 5 187 5 187 5 187 5 187 5 187 5 187 5 187 5 187 5 187 5 187 0 2 22 2 1 168 4 193 4 194 4 195 4 196 4 197 4 198 4 199 4 200 4 201 4 202 4 203 4 204 4 205 4 206 4 207 4 208 4 209 4 210 4 211 4 212 4 213 4 214 4 215 4 216 4 217 4 218 4 219 4 220 4 221 4 222 4 223 4 224 4 225 4 226 4 227 4 228 4 229 4 230 4 231 4 232 4 233 4 234 4 235 4 236 4 237 4 238 4 239 4 240 4 241 4 242 4 243 4 244 4 245 4 246 4 247 4 248 4 249 4 250 4 251 4 252 4 253 4 254 4 255 5 0 5 1 5 2 5 3 5 4 5 5 5 6 5 7 5 8 5 9 5 10 5 11 5 12 5 13 5 14 5 15 5 16 5 17 5 18 5 19 5 20 5 21 5 22 5 23 5 24 5 25 5 26 5 27 5 28 5 29 5 30 5 31 5 32 5 33 5 34 5 35 5 36 5 37 5 38 5 39 5 40 5 41 5 42 5 43 5 44 5 45 5 46 5 47 5 48 5 49 5 50 5 51 5 52 5 53 5 54 5 55 5 56 5 57 5 58 5 59 5 60 5 61 5 62 5 63 5 64 5 65 5 66 5 67 5 68 5 69 5 70 5 71 5 72 5 73 5 74 5 75 5 76 5 77 5 78 5 79 5 89 5 90 5 80 5 81 5 82 5 83 5 84 5 85 5 86 5 87 5 88 5 91 5 93 5 92 5 94 5 95 5 96 5 97 5 98 5 99 5 100 5 101 5 102 5 103 5 104 5 106 5 107 5 108 5 109 5 110 5 111 5 112 5 113 5 114 5 115 5 116 5 117 5 118 5 119 5 120 5 121 5 122 5 123 5 124 5 125 5 126 5 127 5 128 5 129 5 130 5 131 5 132 5 133 5 134 5 135 5 136 5 137 5 138 5 139 5 140 5 141 5 142 5 143 5 144 5 145 5 146 5 147 5 148 5 149 5 150 5 151 5 152 5 153 5 154 5 155 5 156 5 157 5 159 5 160 5 161 5 162 5 163 5 164 5 165 5 166 5 167 5 168 5 169 5 170 5 171 5 172 5 173 5 174 5 175 5 176 5 177 5 178 5 179 5 180 5 181 5 182 5 159 5 163 5 165 5 167 5 183 5 173 5 178 5 184 5 182 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 163 5 163 5 163 5 163 5 163 5 163 5 163 5 163 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 173 5 173 5 173 5 173 5 173 5 173 5 173 5 173 5 175 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 187 5 187 5 187 5 187 5 187 5 187 5 187 5 187 5 187 5 188 5 189 5 190 5 191 5 192 5 193 5 194 5 195 5 196 5 197 5 198 5 199 5 200 5 201 5 202 5 203 5 204 5 205 5 206 5 207 5 208 5 209 5 210 5 211 5 212 5 213 5 214 5 215 5 216 5 217 5 218 5 219 5 220 5 221 5 222 5 223 5 224 5 225 5 226 5 227 5 229 5 230 5 231 5 232 5 233 5 234 5 235 5 236 5 237 5 238 5 239 5 240 5 241 5 242 5 243 5 244 5 245 5 246 5 247 5 248 5 249 5 250 5 251 5 252 5 253 5 254 5 255 6 0 6 1 6 2 6 3 6 4 6 5 6 6 6 7 0 1 18 254 1 202 0 2 19 2 0 20 6 8 6 19 6 20 6 21 4 125 6 23 6 24 6 25 6 26 6 27 6 28 6 29 6 30 6 31 6 32 6 33 6 34 6 35 6 36 6 37 0 2 18 246 0 221 4 193 4 194 4 195 4 196 4 197 4 198 4 199 4 200 4 201 4 202 4 203 4 204 4 205 4 206 4 207 4 208 4 209 4 210 4 211 4 212 4 213 4 214 4 215 4 216 4 217 4 218 4 219 4 220 4 221 4 222 4 223 4 224 4 225 4 226 4 227 4 228 4 229 4 230 4 231 4 232 4 233 4 234 4 235 4 236 4 237 4 238 4 239 4 240 4 241 4 242 4 243 4 244 4 245 4 246 4 247 4 248 4 249 4 250 4 251 4 252 4 253 4 254 4 255 5 0 5 1 5 2 5 3 5 4 5 5 5 6 5 7 5 8 5 9 5 10 5 11 5 12 5 13 5 14 5 15 5 16 5 17 5 18 5 19 5 20 5 21 5 22 5 23 5 24 5 26 5 27 5 28 5 29 5 30 5 31 5 32 5 33 5 34 5 35 5 37 5 38 5 39 5 40 5 40 5 41 5 42 5 43 5 44 5 45 5 46 5 47 5 49 5 48 5 50 5 51 5 52 5 53 5 54 5 55 5 56 5 57 5 58 5 59 5 60 5 61 5 62 5 63 5 64 5 65 5 66 5 67 5 68 5 69 5 70 5 71 5 72 5 73 5 74 5 75 5 76 5 77 5 78 5 79 5 89 5 90 5 80 5 81 5 82 5 83 5 84 5 85 5 86 5 87 5 88 5 91 5 94 5 93 5 92 5 95 5 96 5 97 5 98 5 99 5 100 5 101 5 102 5 103 5 104 5 106 5 107 5 108 5 109 5 110 5 111 5 112 5 113 5 114 5 115 5 116 5 117 5 118 5 119 5 120 5 121 5 122 5 123 5 124 5 125 5 126 5 127 5 128 5 129 5 130 5 131 5 132 5 133 5 134 5 135 5 136 5 137 5 138 5 139 5 140 5 141 5 142 5 143 5 144 5 145 5 146 5 147 5 148 5 149 5 150 5 151 5 152 5 153 5 154 5 156 5 157 5 155 5 25 5 36 0 2 17 124 0 76 5 188 5 189 5 190 5 191 5 192 5 193 5 194 5 195 5 196 5 197 5 198 5 199 5 200 5 201 5 202 5 203 5 204 5 205 5 206 5 207 5 208 5 209 5 210 5 211 5 212 5 213 5 214 5 215 5 216 5 217 5 218 5 219 5 220 5 221 5 222 5 223 5 224 5 225 5 226 5 227 5 229 5 230 5 231 5 232 5 233 5 234 5 235 5 236 5 237 5 238 5 239 5 240 5 241 5 242 5 243 5 244 5 245 5 246 5 247 5 248 5 249 5 250 5 251 5 252 5 254 5 253 5 255 6 0 6 1 6 2 6 3 6 4 6 5 6 6 6 7 5 189 0 2 17 24 0 14 6 80 6 81 6 82 6 83 6 84 6 85 6 86 6 87 6 88 6 89 6 92 6 93 6 90 6 91 0 2 16 246 0 14 6 66 6 67 6 68 6 69 6 70 6 71 6 72 6 73 6 74 6 75 6 78 6 79 6 76 6 77 0 1 16 234 2 33 0 3 0 1 16 234 0 1 16 244 0 0 0 1 0 0 0 49 0 3 0 1 16 234 0 1 16 250 0 0 0 1 0 0 0 49 0 3 0 2 16 252 16 242 0 1 16 232 0 0 0 1 0 0 0 49 0 2 16 240 0 29 6 123 6 124 6 125 6 126 6 127 6 128 6 129 6 130 6 131 6 132 6 133 6 134 6 135 6 136 6 137 6 138 6 139 6 140 6 141 6 142 6 143 6 144 6 145 6 146 6 147 6 148 6 154 6 155 6 156 0 1 16 198 6 95 0 2 16 80 0 14 6 38 6 39 6 40 6 41 6 42 6 43 6 44 6 45 6 46 6 47 6 50 6 51 6 48 6 49 0 2 16 168 0 4 6 160 6 161 6 162 6 163 0 2 16 32 0 14 6 52 6 53 6 54 6 55 6 56 6 57 6 58 6 59 6 60 6 61 6 64 6 65 6 62 6 63 0 2 16 132 0 20 4 75 4 76 4 77 4 78 4 79 4 80 4 81 4 82 4 83 4 84 4 97 4 98 4 99 4 100 4 101 4 102 4 103 4 104 4 105 4 106 0 2 16 102 0 20 4 87 4 88 4 89 4 90 4 91 4 92 4 93 4 94 4 95 4 96 4 97 4 98 4 99 4 100 4 101 4 102 4 103 4 104 4 105 4 106 0 0 1 0 0 1 16 68 0 11 0 1 16 62 0 10 0 2 16 64 0 50 3 103 4 63 4 64 4 65 4 66 4 67 4 68 4 69 4 70 4 71 4 72 4 75 4 76 4 77 4 78 4 79 4 80 4 81 4 82 4 83 4 84 4 190 7 32 7 35 7 38 7 40 7 42 7 47 7 50 7 52 7 54 7 56 7 58 7 60 7 63 7 85 7 87 7 106 7 109 7 113 7 115 7 117 7 119 7 121 7 123 7 125 7 127 7 129 7 131 7 133 0 0 1 1 0 2 16 58 0 11 2 53 2 54 2 55 2 56 2 57 2 58 2 59 2 60 2 61 6 159 2 62 0 1 16 56 0 7 0 1 16 56 254 3 0 0 1 2 0 2 16 52 0 25 2 21 2 22 2 23 2 24 2 25 2 26 2 27 2 28 2 29 2 30 2 31 2 32 2 33 2 34 2 35 2 36 2 37 2 38 2 39 2 40 2 41 2 42 2 43 6 95 6 157 0 1 16 24 0 24 0 0 1 3 0 2 16 20 0 10 2 44 2 45 2 46 2 47 2 48 2 49 2 50 2 51 2 52 6 158 0 1 16 16 0 19 0 0 1 4 0 2 16 12 0 13 2 7 2 8 2 9 2 10 2 11 2 12 2 13 2 14 2 15 2 16 2 17 2 18 2 19 0 2 15 252 0 3 2 7 2 19 2 13 0 1 15 250 0 11 0 28 0 34 0 40 0 46 0 52 0 58 0 64 0 70 0 76 0 82 0 88 0 2 3 107 2 7 0 2 3 126 2 7 0 2 3 127 2 7 0 2 3 128 2 7 0 2 3 107 2 7 0 2 3 130 2 7 0 2 3 131 2 7 0 2 3 132 2 7 0 2 3 133 2 7 0 2 3 134 2 7 0 2 3 135 2 7 0 1 15 172 0 1 0 1 15 174 0 1 0 8 0 3 0 8 0 16 0 22 2 6 0 3 0 33 0 47 2 2 0 2 0 33 2 5 0 2 0 47 0 2 15 144 2 172 4 219 4 220 4 221 4 222 4 223 4 224 4 225 4 226 4 227 4 228 4 229 4 230 4 231 4 232 4 233 4 234 4 235 4 236 4 237 4 238 4 239 4 240 4 241 4 242 4 243 4 244 4 245 4 246 4 247 4 248 4 249 4 250 4 251 4 252 4 253 4 254 4 255 5 0 5 1 5 2 5 3 5 4 5 5 5 6 5 7 5 8 5 9 5 10 5 11 5 12 5 13 5 14 5 15 5 16 5 17 5 18 5 19 5 20 5 21 5 22 5 23 5 24 5 25 5 26 5 27 5 28 5 29 5 42 5 43 5 44 5 45 5 46 5 47 5 48 5 49 5 50 5 51 5 52 5 53 5 54 5 55 5 56 5 57 5 58 5 59 5 60 5 61 5 62 5 63 5 64 5 65 5 66 5 67 5 68 5 69 5 70 5 71 5 72 5 73 5 74 5 75 5 76 5 77 5 78 5 79 5 89 5 90 5 80 5 81 5 82 5 83 5 84 5 85 5 86 5 87 5 88 5 91 5 93 5 92 5 94 5 95 5 96 5 97 5 98 5 99 5 100 5 101 5 102 5 103 5 104 5 106 5 107 5 108 5 109 5 110 5 111 5 112 5 113 5 114 5 115 5 116 5 117 5 118 5 119 5 120 5 121 5 122 5 123 5 124 5 125 5 126 5 127 5 128 5 129 5 130 5 131 5 132 5 133 5 134 5 135 5 136 5 137 5 138 5 139 5 140 5 141 5 142 5 143 5 144 5 145 5 146 5 147 5 148 5 149 5 150 5 151 5 152 5 153 5 154 5 155 5 157 4 241 4 242 4 243 4 244 4 245 4 246 4 247 4 248 4 249 4 250 4 251 4 252 4 253 4 254 5 1 5 2 5 3 5 4 5 5 5 6 5 7 5 8 5 9 5 10 5 11 5 12 5 13 5 14 5 15 5 16 5 26 5 27 5 28 5 29 5 30 5 31 5 32 5 33 5 34 5 35 5 37 5 38 5 39 5 40 5 40 5 41 5 42 5 43 5 44 5 45 5 54 5 55 5 56 5 57 5 58 5 59 5 60 5 61 5 62 5 63 5 64 5 65 5 66 5 67 5 68 5 69 5 70 5 71 5 72 5 73 5 74 5 75 5 76 5 77 5 78 5 79 5 89 5 90 5 80 5 81 5 82 5 83 5 84 5 85 5 86 5 87 5 88 5 91 5 94 5 93 5 92 5 95 5 96 5 97 5 98 5 99 5 100 5 101 5 102 5 103 5 104 5 106 5 107 5 108 5 109 5 110 5 111 5 112 5 113 5 114 5 115 5 116 5 117 5 118 5 119 5 120 5 121 5 122 5 123 5 124 5 125 5 126 5 127 5 128 5 129 5 130 5 131 5 132 5 133 5 134 5 135 5 136 5 137 5 138 5 139 5 140 5 141 5 142 5 143 5 144 5 145 5 146 5 147 5 148 5 149 5 150 5 151 5 152 5 153 5 154 5 156 5 157 5 25 5 159 5 160 5 161 5 162 5 163 5 164 5 165 5 166 5 168 5 169 5 170 5 171 5 172 5 173 5 174 5 175 5 176 5 177 5 178 5 179 5 180 5 181 5 182 5 159 5 163 5 165 5 167 5 183 5 173 5 178 5 184 5 182 2 121 2 122 2 123 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 159 5 163 5 163 5 163 5 163 5 163 5 163 5 163 5 163 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 165 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 167 5 173 5 173 5 173 5 173 5 173 5 173 5 173 5 173 5 175 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 178 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 182 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 185 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 186 5 187 5 187 5 187 5 187 5 187 5 187 5 187 5 187 5 187 3 103 5 188 5 189 5 190 5 191 5 192 5 193 5 194 5 195 5 196 5 197 5 198 5 199 5 200 5 201 5 202 5 203 5 204 5 205 5 206 5 207 5 208 5 209 5 210 5 211 5 212 5 213 5 214 5 215 5 216 5 217 5 218 5 219 5 220 5 221 5 222 5 223 5 224 5 225 5 226 5 227 5 229 5 230 5 231 5 232 5 233 5 234 5 235 5 236 5 237 5 238 5 239 5 240 5 241 5 242 5 243 5 244 5 245 5 246 5 247 5 248 5 249 5 250 5 251 5 252 5 253 5 254 5 255 6 0 6 1 6 2 6 3 6 4 6 5 6 6 6 7 5 188 5 190 5 191 5 192 5 193 5 194 5 195 5 196 5 197 5 198 5 199 5 200 5 201 5 202 5 203 5 204 5 205 5 206 5 207 5 208 5 209 5 210 5 211 5 212 5 213 5 214 5 215 5 216 5 217 5 218 5 219 5 220 5 221 5 222 5 223 5 224 5 225 5 226 5 227 5 229 5 230 5 231 5 232 5 233 5 234 5 235 5 236 5 237 5 238 5 239 5 240 5 241 5 242 5 243 5 244 5 245 5 246 5 247 5 248 5 249 5 250 5 251 5 252 5 254 5 255 6 0 6 1 6 2 6 3 6 4 6 5 6 6 6 7 5 189 6 8 4 74 4 98 4 99 4 100 4 101 4 102 4 103 4 104 4 105 4 106 4 86 4 76 4 77 4 78 4 79 4 80 4 81 4 82 4 83 4 84 6 160 6 19 6 20 6 21 4 125 6 23 6 24 6 25 6 26 6 27 6 28 6 34 6 35 6 36 6 37 4 190 5 36 6 95 6 157 6 158 6 159 7 38 7 40 7 42 7 48 7 50 7 52 7 54 7 56 7 58 7 60 7 63 7 67 7 69 7 85 7 87 7 106 7 109 7 113 7 115 7 117 7 119 7 121 7 123 7 125 7 127 7 129 7 131 7 133 2 62 0 1 12 28 0 143 1 36 1 42 1 48 1 54 1 60 1 66 1 72 1 78 1 84 1 92 1 98 1 104 1 110 1 116 1 122 1 128 1 134 1 140 1 146 1 152 1 158 1 164 1 170 1 176 1 182 1 188 1 194 1 202 1 208 1 214 1 220 1 226 1 232 1 240 1 246 1 254 2 4 2 10 2 18 2 24 2 30 2 36 2 42 2 48 2 54 2 60 2 66 2 72 2 78 2 84 2 90 2 96 2 102 2 108 2 114 2 120 2 126 2 132 2 138 2 144 2 150 2 156 2 162 2 168 2 174 2 180 2 186 2 192 2 198 2 204 2 210 2 216 2 222 2 228 2 234 2 240 2 246 2 252 3 2 3 8 3 14 3 20 3 26 3 32 3 38 3 44 3 50 3 56 3 62 3 68 3 74 3 80 3 86 3 92 3 98 3 104 3 110 3 116 3 122 3 128 3 134 3 140 3 146 3 152 3 158 3 164 3 170 3 176 3 182 3 188 3 194 3 200 3 220 3 236 3 252 4 12 4 28 4 44 4 60 4 76 4 92 4 108 4 116 4 122 4 128 4 134 4 140 4 146 4 152 4 158 4 164 4 170 4 176 4 180 4 190 4 200 4 206 4 212 4 218 4 230 4 242 4 248 4 254 0 2 4 193 6 97 0 2 4 194 6 98 0 2 4 195 6 99 0 2 4 196 6 100 0 2 4 197 6 101 0 2 4 198 6 102 0 2 4 199 6 103 0 2 4 200 6 104 0 3 4 201 6 105 2 7 0 2 4 202 6 106 0 2 4 203 6 107 0 2 4 204 6 108 0 2 4 205 6 109 0 2 4 206 6 110 0 2 4 207 6 111 0 2 4 208 6 112 0 2 4 209 6 113 0 2 4 210 6 114 0 2 4 211 6 115 0 2 4 212 6 116 0 2 4 213 6 117 0 2 4 214 6 118 0 2 4 215 6 119 0 2 4 216 6 120 0 2 4 217 6 121 0 2 4 218 6 122 0 3 4 193 6 123 2 21 0 2 4 194 6 124 0 2 4 195 6 125 0 2 4 196 6 126 0 2 4 197 6 127 0 2 4 198 6 128 0 3 4 199 6 129 2 44 0 2 4 200 6 130 0 3 4 192 4 201 6 131 0 2 4 202 6 132 0 2 4 203 6 133 0 3 4 204 6 134 2 53 0 2 4 205 6 135 0 2 4 206 6 136 0 2 4 207 6 137 0 2 4 208 6 138 0 2 4 209 6 139 0 2 4 210 6 140 0 2 4 211 6 141 0 2 4 212 6 142 0 2 4 213 6 143 0 2 4 214 6 144 0 2 4 215 6 145 0 2 4 216 6 146 0 2 4 217 6 147 0 2 4 218 6 148 0 2 5 30 2 8 0 2 5 31 2 9 0 2 5 32 2 10 0 2 5 33 2 11 0 2 5 34 2 12 0 2 5 35 2 13 0 2 5 36 2 14 0 2 5 37 2 15 0 2 5 38 2 16 0 2 5 39 2 17 0 2 5 40 2 18 0 2 5 41 2 19 0 2 2 20 5 156 0 2 4 219 2 22 0 2 4 220 2 23 0 2 4 221 2 24 0 2 4 222 2 25 0 2 4 223 2 26 0 2 4 224 2 27 0 2 4 225 2 28 0 2 4 226 2 29 0 2 4 227 2 30 0 2 4 228 2 31 0 2 4 229 2 32 0 2 4 230 2 33 0 2 4 231 2 34 0 2 4 232 2 35 0 2 4 233 2 36 0 2 4 234 2 37 0 2 4 235 2 38 0 2 4 236 2 39 0 2 4 237 2 40 0 2 4 238 2 41 0 2 4 239 2 42 0 2 4 240 2 43 0 2 4 255 6 154 0 2 5 0 6 155 0 2 5 17 2 45 0 2 5 18 2 46 0 2 5 19 2 47 0 2 5 20 2 48 0 2 5 21 2 49 0 2 5 22 2 50 0 2 5 23 2 51 0 2 5 24 2 52 0 2 5 46 2 54 0 2 5 47 2 55 0 2 5 49 2 56 0 2 5 48 2 57 0 2 5 50 2 58 0 2 5 51 2 59 0 2 5 52 2 60 0 2 5 53 2 61 0 2 5 155 6 156 0 2 5 167 2 7 0 2 5 167 2 19 0 2 5 167 2 13 0 2 4 60 5 189 0 2 5 253 2 53 0 9 6 9 6 80 6 66 6 38 6 52 4 75 4 87 4 74 4 73 0 7 6 10 6 81 6 67 6 39 6 53 4 76 4 88 0 7 6 11 6 82 6 68 6 40 6 54 4 77 4 89 0 7 6 12 6 83 6 69 6 41 6 55 4 78 4 90 0 7 6 13 6 84 6 70 6 42 6 56 4 79 4 91 0 7 6 14 6 85 6 71 6 43 6 57 4 80 4 92 0 7 6 15 6 86 6 72 6 44 6 58 4 81 4 93 0 7 6 16 6 87 6 73 6 45 6 59 4 82 4 94 0 7 6 17 6 88 6 74 6 46 6 60 4 83 4 95 0 7 6 18 6 89 6 75 6 47 6 61 4 84 4 96 0 3 4 97 4 86 4 85 0 2 4 97 4 63 0 2 4 98 4 64 0 2 4 99 4 65 0 2 4 100 4 66 0 2 4 101 4 67 0 2 4 102 4 68 0 2 4 103 4 69 0 2 4 104 4 70 0 2 4 105 4 71 0 2 4 106 4 72 0 1 4 75 0 4 6 92 6 78 6 50 6 64 0 4 6 93 6 79 6 51 6 65 0 2 6 29 6 161 0 2 6 30 6 162 0 2 6 31 6 163 0 5 6 32 6 90 6 76 6 48 6 62 0 5 6 33 6 91 6 77 6 49 6 63 0 2 7 33 7 32 0 2 7 36 7 35 0 2 7 46 7 47 0 1 0 120 0 1 0 8 0 1 0 4 1 69 0 2 7 86 0 2 7 142 0 48 7 144 1 69 3 180 4 14 5 228 6 66 6 67 6 68 6 69 6 70 6 71 6 72 6 73 6 74 6 75 6 76 6 77 6 78 6 79 7 32 7 35 7 38 7 40 7 42 7 47 7 50 7 52 7 54 7 56 7 58 7 60 7 63 7 85 7 87 7 106 7 109 7 113 7 115 7 117 7 119 7 121 7 123 7 125 7 127 7 129 7 131 7 133 7 145 0 1 0 1 0 36 0 1 0 1 0 246 0 1 0 4 7 31 7 34 7 66 7 68 0 1 0 2 7 45 7 47 0 1 0 1 3 227 0 1 0 10 0 92 0 95 0 158 0 161 1 30 1 33 1 99 1 102 3 179 4 13 0 1 0 4 0 92 0 158 1 30 1 99 0 1 0 1 7 45 0 1 0 4 0 95 0 161 1 33 1 102 0 1 0 1 7 34 0 1 0 2 3 179 4 13 0 1 0 1 7 86 0 1 0 1 1 68 0 1 0 5 7 37 7 45 7 51 7 67 7 69 0 1 0 16 0 2 0 6 0 8 0 10 0 16 0 22 0 28 0 31 0 32 0 34 0 36 0 39 0 42 0 47 0 48 2 44 0 1 0 22 2 63 2 67 2 69 2 71 2 77 2 79 2 82 2 86 2 96 2 100 2 102 2 104 2 110 2 112 2 115 2 119 2 204 2 213 2 222 3 60 3 72 3 84 0 2 0 19 0 2 0 27 0 0 0 54 0 195 0 26 0 197 0 247 0 168 2 63 2 95 0 219 2 135 2 230 0 252 3 136 3 142 1 92 3 145 3 148 1 99 3 151 3 179 1 103 3 181 3 185 1 132 3 188 3 196 1 137 3 199 3 200 1 146 3 203 3 203 1 148 3 206 3 214 1 149 3 217 3 225 1 158 4 193 5 104 1 167 5 107 5 157 2 79 5 159 5 184 2 130 5 188 5 227 2 156 5 229 6 7 2 196 0 1 0 28 7 31 7 34 7 37 7 39 7 41 7 45 7 49 7 51 7 53 7 55 7 57 7 59 7 62 7 84 7 86 7 105 7 108 7 112 7 114 7 116 7 118 7 120 7 122 7 124 7 126 7 128 7 130 7 132 0 1 0 28 7 32 7 35 7 38 7 40 7 42 7 47 7 50 7 52 7 54 7 56 7 58 7 60 7 63 7 85 7 87 7 106 7 109 7 113 7 115 7 117 7 119 7 121 7 123 7 125 7 127 7 129 7 131 7 133 0 1 0 1 4 13 0 1 0 1 3 179 0 1 0 1 5 227 0 1 0 2 4 12 4 14 0 1 0 1 3 180 0 1 0 1 5 228 0 2 0 2 2 96 2 120 0 0 2 124 2 134 0 25 0 2 0 1 2 231 3 95 0 0 0 2 0 13 0 2 0 27 0 0 0 54 0 247 0 26 2 63 2 95 0 220 2 135 2 230 0 253 3 136 3 142 1 93 3 145 3 148 1 100 3 151 3 179 1 104 3 181 3 185 1 133 3 188 3 196 1 138 3 199 3 200 1 147 3 203 3 203 1 149 3 206 3 214 1 150 3 217 3 225 1 159 0 2 0 1 4 63 4 72 0 0 0 2 0 5 4 62 4 62 0 0 4 122 4 131 0 1 4 138 4 138 0 11 4 140 4 141 0 12 4 151 4 156 0 14 0 2 0 11 0 28 0 53 0 0 0 248 1 55 0 26 1 57 1 70 0 90 1 72 1 75 0 104 1 77 1 95 0 108 1 97 1 142 0 127 1 144 1 187 0 173 1 189 1 189 0 217 1 200 1 200 0 218 1 206 1 206 0 219 4 192 4 192 0 220 0 2 0 9 3 226 3 232 0 0 3 235 3 238 0 7 3 241 4 13 0 11 4 15 4 19 0 40 4 22 4 30 0 45 4 33 4 34 0 54 4 37 4 37 0 56 4 40 4 47 0 57 4 50 4 60 0 65 0 2 0 3 4 63 4 72 0 0 4 117 4 118 0 10 4 151 4 152 0 12 0 1 0 1 4 157 0 2 0 1 6 80 6 89 0 0 0 1 0 2 0 1 7 142 0 2 0 2 6 66 6 79 0 0 6 188 6 190 0 14 0 2 0 1 6 80 6 93 0 0 0 2 0 1 6 66 6 75 0 0 0 1 0 2 7 144 7 145 0 2 0 3 0 28 0 53 0 0 1 28 1 29 0 26 1 200 1 200 0 28 0 2 0 1 0 2 0 27 0 0 0 1 0 4 4 119 4 138 4 140 4 141 0 2 0 2 4 63 4 72 0 0 4 87 4 96 0 10 0 2 0 2 4 63 4 72 0 0 4 75 4 84 0 10 0 1 0 2 4 63 4 75 0 1 0 50 3 102 4 87 4 88 4 89 4 90 4 91 4 92 4 93 4 94 4 95 4 96 4 97 4 98 4 99 4 100 4 101 4 102 4 103 4 104 4 105 4 106 4 189 7 31 7 34 7 37 7 39 7 41 7 45 7 49 7 51 7 53 7 55 7 57 7 59 7 62 7 84 7 86 7 105 7 108 7 112 7 114 7 116 7 118 7 120 7 122 7 124 7 126 7 128 7 130 7 132 0 1 0 11 0 39 1 77 1 78 1 79 1 80 1 81 1 82 1 83 1 84 6 134 7 149 0 1 0 1 2 116 0 1 0 1 4 50 0 2 0 4 0 28 0 28 0 0 0 248 1 13 0 1 6 94 6 94 0 23 6 123 6 123 0 24 0 1 0 1 2 97 0 2 0 3 0 34 0 34 0 0 1 46 1 53 0 1 6 129 6 129 0 9 0 1 0 1 2 103 0 2 0 2 0 10 0 10 0 0 0 121 0 132 0 1 0 1 0 3 2 71 2 175 2 176 0 2 0 2 2 90 2 90 0 0 2 165 2 174 0 1 0 1 0 2 4 73 4 85 0 1 0 1 0 33 0 2 0 81 0 54 0 120 0 0 0 133 0 245 0 67 0 247 0 247 0 180 1 14 1 27 0 181 1 30 1 45 0 195 1 54 1 55 0 211 1 57 1 70 0 213 1 72 1 75 0 227 1 85 1 95 0 231 1 97 1 142 0 242 1 144 1 187 1 32 1 189 1 189 1 76 1 206 1 206 1 77 2 63 2 70 1 78 2 72 2 95 1 86 2 97 2 97 1 110 2 103 2 103 1 111 2 116 2 116 1 112 2 135 2 174 1 113 2 177 2 230 1 153 3 102 3 102 1 207 3 136 3 142 1 208 3 145 3 148 1 215 3 151 3 179 1 219 3 181 3 185 1 248 3 188 3 196 1 253 3 199 3 200 2 6 3 203 3 203 2 8 3 206 3 214 2 9 3 217 3 226 2 18 3 228 3 232 2 28 3 235 3 238 2 33 3 241 4 13 2 37 4 15 4 19 2 66 4 22 4 30 2 71 4 33 4 34 2 80 4 37 4 37 2 82 4 40 4 47 2 83 4 51 4 60 2 91 4 62 4 62 2 101 4 73 4 73 2 102 4 76 4 85 2 103 4 98 4 106 2 113 4 119 4 119 2 122 4 122 4 131 2 123 4 153 4 156 2 133 4 189 4 189 2 137 4 192 4 192 2 138 6 94 6 94 2 139 6 123 6 123 2 140 6 129 6 129 2 141 6 134 6 134 2 142 7 37 7 37 2 143 7 39 7 39 2 144 7 41 7 41 2 145 7 47 7 47 2 146 7 49 7 49 2 147 7 51 7 51 2 148 7 53 7 53 2 149 7 55 7 55 2 150 7 57 7 57 2 151 7 59 7 59 2 152 7 62 7 62 2 153 7 66 7 66 2 154 7 68 7 68 2 155 7 84 7 84 2 156 7 86 7 86 2 157 7 105 7 105 2 158 7 108 7 108 2 159 7 112 7 112 2 160 7 114 7 114 2 161 7 116 7 116 2 162 7 118 7 118 2 163 7 120 7 120 2 164 7 122 7 122 2 165 7 124 7 124 2 166 7 126 7 126 2 167 7 128 7 128 2 168 7 130 7 130 2 169 7 132 7 132 2 170 7 149 7 149 2 171 0 2 0 22 0 2 0 53 0 0 0 121 0 132 0 52 0 246 0 246 0 64 0 248 1 13 0 65 1 28 1 29 0 87 1 46 1 53 0 89 1 77 1 84 0 97 1 200 1 200 0 105 2 71 2 71 0 106 2 175 2 176 0 107 3 227 3 227 0 109 4 50 4 50 0 110 4 63 4 72 0 111 4 75 4 75 0 121 4 87 4 97 0 122 4 117 4 118 0 133 4 138 4 138 0 135 4 140 4 141 0 136 4 151 4 152 0 138 7 31 7 31 0 140 7 34 7 34 0 141 7 45 7 45 0 142 0 1 0 48 0 1 1 68 3 179 4 13 5 227 6 80 6 81 6 82 6 83 6 84 6 85 6 86 6 87 6 88 6 89 6 90 6 91 6 92 6 93 7 31 7 34 7 37 7 39 7 41 7 45 7 49 7 51 7 53 7 55 7 57 7 59 7 62 7 84 7 86 7 105 7 108 7 112 7 114 7 116 7 118 7 120 7 122 7 124 7 126 7 128 7 130 7 132 7 142 0 0 0 1 0 0 0 8 0 0 0 4 0 14 0 2 105 100 101 111 114 111 109 110 0 4 68 70 76 84 0 26 99 121 114 108 0 26 103 114 101 107 0 26 108 97 116 110 0 26 0 6 0 0 0 0 0 1 0 2 0 8 0 12 0 1 255 86 0 1 0 0 0 0 0 0 0 1 0 1 0 1 0 0 0 1 0 0 25 1 0 0 0 20 0 0 0 0 0 0 24 249 48 130 24 245 6 9 42 134 72 134 247 13 1 7 2 160 130 24 230 48 130 24 226 2 1 1 49 11 48 9 6 5 43 14 3 2 26 5 0 48 97 6 10 43 6 1 4 1 130 55 2 1 4 160 83 48 81 48 44 6 10 43 6 1 4 1 130 55 2 1 28 162 30 128 28 0 60 0 60 0 60 0 79 0 98 0 115 0 111 0 108 0 101 0 116 0 101 0 62 0 62 0 62 48 33 48 9 6 5 43 14 3 2 26 5 0 4 20 19 83 205 88 154 11 19 179 241 189 209 172 73 170 46 141 60 87 28 254 160 130 19 174 48 130 3 238 48 130 3 87 160 3 2 1 2 2 16 126 147 235 251 124 198 78 89 234 75 154 119 212 6 252 59 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 129 139 49 11 48 9 6 3 85 4 6 19 2 90 65 49 21 48 19 6 3 85 4 8 19 12 87 101 115 116 101 114 110 32 67 97 112 101 49 20 48 18 6 3 85 4 7 19 11 68 117 114 98 97 110 118 105 108 108 101 49 15 48 13 6 3 85 4 10 19 6 84 104 97 119 116 101 49 29 48 27 6 3 85 4 11 19 20 84 104 97 119 116 101 32 67 101 114 116 105 102 105 99 97 116 105 111 110 49 31 48 29 6 3 85 4 3 19 22 84 104 97 119 116 101 32 84 105 109 101 115 116 97 109 112 105 110 103 32 67 65 48 30 23 13 49 50 49 50 50 49 48 48 48 48 48 48 90 23 13 50 48 49 50 51 48 50 51 53 57 53 57 90 48 94 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 48 48 46 6 3 85 4 3 19 39 83 121 109 97 110 116 101 99 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 67 65 32 45 32 71 50 48 130 1 34 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 130 1 15 0 48 130 1 10 2 130 1 1 0 177 172 179 73 84 75 151 28 18 10 216 37 121 145 34 87 42 111 220 184 38 196 67 115 107 194 191 46 80 90 251 20 194 118 142 67 1 37 67 180 161 226 69 244 232 183 123 195 116 204 34 215 180 148 0 2 247 77 237 191 180 183 68 36 107 205 95 69 59 209 68 206 67 18 115 23 130 139 105 180 43 203 153 30 172 114 27 38 77 113 31 177 49 221 251 81 97 2 83 166 170 245 73 44 5 120 69 165 47 137 206 231 153 231 254 140 226 87 63 61 198 146 220 74 248 123 51 228 121 10 251 240 117 136 65 156 255 197 3 81 153 170 215 108 159 147 105 135 101 41 131 133 194 96 20 196 200 201 59 20 218 192 129 240 31 13 116 222 146 34 171 202 247 251 116 124 39 230 247 74 27 127 167 195 158 45 174 138 234 166 230 170 39 22 125 97 247 152 113 17 188 226 80 161 75 229 93 250 229 14 167 44 159 170 101 32 211 216 150 232 200 124 165 78 72 68 255 25 226 68 7 146 11 215 104 132 128 93 106 120 100 69 205 96 70 126 84 193 19 124 197 121 241 201 193 113 2 3 1 0 1 163 129 250 48 129 247 48 29 6 3 85 29 14 4 22 4 20 95 154 245 110 92 204 204 116 154 212 221 125 239 63 219 236 76 128 46 221 48 50 6 8 43 6 1 5 5 7 1 1 4 38 48 36 48 34 6 8 43 6 1 5 5 7 48 1 134 22 104 116 116 112 58 47 47 111 99 115 112 46 116 104 97 119 116 101 46 99 111 109 48 18 6 3 85 29 19 1 1 255 4 8 48 6 1 1 255 2 1 0 48 63 6 3 85 29 31 4 56 48 54 48 52 160 50 160 48 134 46 104 116 116 112 58 47 47 99 114 108 46 116 104 97 119 116 101 46 99 111 109 47 84 104 97 119 116 101 84 105 109 101 115 116 97 109 112 105 110 103 67 65 46 99 114 108 48 19 6 3 85 29 37 4 12 48 10 6 8 43 6 1 5 5 7 3 8 48 14 6 3 85 29 15 1 1 255 4 4 3 2 1 6 48 40 6 3 85 29 17 4 33 48 31 164 29 48 27 49 25 48 23 6 3 85 4 3 19 16 84 105 109 101 83 116 97 109 112 45 50 48 52 56 45 49 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 129 129 0 3 9 155 143 121 239 127 89 48 170 239 104 181 250 227 9 29 187 79 130 6 93 55 95 166 82 159 22 141 234 28 146 9 68 110 245 109 235 88 124 48 232 249 105 141 35 115 11 18 111 71 169 174 57 17 248 42 177 155 176 26 195 142 235 89 150 0 173 206 12 77 178 208 49 166 8 92 42 122 252 226 122 29 87 76 168 101 24 233 121 64 98 37 150 110 199 199 55 106 131 33 8 142 65 234 221 217 87 63 29 119 73 135 42 22 6 94 166 56 106 34 18 163 81 25 131 126 182 48 130 4 163 48 130 3 139 160 3 2 1 2 2 16 14 207 244 56 200 254 191 53 110 4 216 106 152 27 26 80 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 94 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 48 48 46 6 3 85 4 3 19 39 83 121 109 97 110 116 101 99 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 67 65 32 45 32 71 50 48 30 23 13 49 50 49 48 49 56 48 48 48 48 48 48 90 23 13 50 48 49 50 50 57 50 51 53 57 53 57 90 48 98 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 52 48 50 6 3 85 4 3 19 43 83 121 109 97 110 116 101 99 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 83 105 103 110 101 114 32 45 32 71 52 48 130 1 34 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 130 1 15 0 48 130 1 10 2 130 1 1 0 162 99 11 57 68 184 187 35 167 68 73 187 14 255 161 240 97 10 83 147 176 152 219 173 44 15 74 197 110 255 134 60 83 85 15 21 206 4 63 43 253 169 150 150 217 190 97 121 11 91 201 76 134 118 229 224 67 75 34 149 238 194 43 67 193 159 216 104 180 142 64 79 238 133 56 185 17 197 35 242 100 88 240 21 50 111 78 87 161 174 136 164 2 215 42 30 205 75 225 221 99 213 23 137 50 91 176 94 153 90 168 157 40 80 14 23 238 150 219 97 59 69 81 29 207 18 86 11 146 71 252 171 174 246 102 61 71 172 112 114 231 146 231 95 205 16 185 196 131 100 148 25 189 37 128 225 232 210 34 165 208 186 2 122 161 119 147 91 101 195 238 23 116 188 65 134 42 220 8 76 140 146 140 145 45 158 119 68 31 104 214 168 116 119 219 14 91 50 139 86 139 51 189 217 99 200 73 157 58 197 197 234 51 11 210 241 163 27 244 139 190 217 179 87 139 59 222 4 167 122 34 178 36 174 46 199 112 197 190 78 131 38 8 251 11 189 169 79 153 8 225 16 40 114 170 205 2 3 1 0 1 163 130 1 87 48 130 1 83 48 12 6 3 85 29 19 1 1 255 4 2 48 0 48 22 6 3 85 29 37 1 1 255 4 12 48 10 6 8 43 6 1 5 5 7 3 8 48 14 6 3 85 29 15 1 1 255 4 4 3 2 7 128 48 115 6 8 43 6 1 5 5 7 1 1 4 103 48 101 48 42 6 8 43 6 1 5 5 7 48 1 134 30 104 116 116 112 58 47 47 116 115 45 111 99 115 112 46 119 115 46 115 121 109 97 110 116 101 99 46 99 111 109 48 55 6 8 43 6 1 5 5 7 48 2 134 43 104 116 116 112 58 47 47 116 115 45 97 105 97 46 119 115 46 115 121 109 97 110 116 101 99 46 99 111 109 47 116 115 115 45 99 97 45 103 50 46 99 101 114 48 60 6 3 85 29 31 4 53 48 51 48 49 160 47 160 45 134 43 104 116 116 112 58 47 47 116 115 45 99 114 108 46 119 115 46 115 121 109 97 110 116 101 99 46 99 111 109 47 116 115 115 45 99 97 45 103 50 46 99 114 108 48 40 6 3 85 29 17 4 33 48 31 164 29 48 27 49 25 48 23 6 3 85 4 3 19 16 84 105 109 101 83 116 97 109 112 45 50 48 52 56 45 50 48 29 6 3 85 29 14 4 22 4 20 70 198 105 163 14 74 20 30 213 76 218 82 99 23 63 94 54 188 13 230 48 31 6 3 85 29 35 4 24 48 22 128 20 95 154 245 110 92 204 204 116 154 212 221 125 239 63 219 236 76 128 46 221 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 130 1 1 0 120 59 180 145 42 0 76 240 143 98 48 55 120 163 132 39 7 111 24 178 222 37 220 160 212 148 3 170 134 78 37 159 154 64 3 28 221 206 227 121 203 33 104 6 218 182 50 180 109 191 244 44 38 99 51 228 73 100 109 13 230 195 103 14 247 5 164 53 108 124 137 22 198 233 178 223 178 233 221 32 198 113 15 205 149 116 220 182 92 222 189 55 31 67 120 230 120 181 205 40 4 32 163 170 241 75 196 136 41 145 14 128 209 17 252 221 92 118 110 79 94 14 69 70 65 110 13 176 234 56 154 177 58 218 9 113 16 252 28 121 180 128 123 172 105 244 253 156 182 12 22 43 241 127 91 9 61 155 91 226 22 202 19 129 109 0 46 56 13 168 41 143 44 225 178 244 90 169 1 175 21 156 44 47 73 27 219 34 187 195 254 120 148 81 195 134 177 130 136 93 240 61 180 81 161 121 51 43 46 123 185 220 32 9 19 113 235 106 25 91 207 232 165 48 87 44 137 73 63 185 207 127 201 191 62 34 104 99 83 154 189 105 116 172 197 29 60 127 146 224 195 188 28 216 4 117 48 130 5 106 48 130 4 82 160 3 2 1 2 2 16 108 89 239 169 225 0 225 14 227 6 186 143 224 41 37 89 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 129 202 49 11 48 9 6 3 85 4 6 19 2 85 83 49 23 48 21 6 3 85 4 10 19 14 86 101 114 105 83 105 103 110 44 32 73 110 99 46 49 31 48 29 6 3 85 4 11 19 22 86 101 114 105 83 105 103 110 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 58 48 56 6 3 85 4 11 19 49 40 99 41 32 50 48 48 54 32 86 101 114 105 83 105 103 110 44 32 73 110 99 46 32 45 32 70 111 114 32 97 117 116 104 111 114 105 122 101 100 32 117 115 101 32 111 110 108 121 49 69 48 67 6 3 85 4 3 19 60 86 101 114 105 83 105 103 110 32 67 108 97 115 115 32 51 32 80 117 98 108 105 99 32 80 114 105 109 97 114 121 32 67 101 114 116 105 102 105 99 97 116 105 111 110 32 65 117 116 104 111 114 105 116 121 32 45 32 71 53 48 30 23 13 49 50 48 54 48 55 48 48 48 48 48 48 90 23 13 50 50 48 54 48 54 50 51 53 57 53 57 90 48 129 140 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 31 48 29 6 3 85 4 11 19 22 83 121 109 97 110 116 101 99 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 61 48 59 6 3 85 4 3 19 52 83 121 109 97 110 116 101 99 32 67 108 97 115 115 32 51 32 69 120 116 101 110 100 101 100 32 86 97 108 105 100 97 116 105 111 110 32 67 111 100 101 32 83 105 103 110 105 110 103 32 67 65 48 130 1 34 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 130 1 15 0 48 130 1 10 2 130 1 1 0 139 67 175 161 196 168 77 205 208 238 199 54 192 160 138 121 115 40 216 119 229 192 84 199 53 247 187 237 27 159 234 87 112 211 85 27 39 25 169 203 224 1 5 174 5 242 173 231 6 29 209 6 168 173 135 185 24 132 47 30 29 9 98 211 221 13 245 23 180 48 111 94 82 118 22 140 86 123 197 144 58 130 125 181 173 88 230 0 231 24 5 54 237 48 32 161 240 236 195 98 244 153 16 26 148 246 240 87 104 201 114 54 189 124 144 168 22 22 32 165 73 1 81 50 160 150 243 138 48 56 171 134 161 21 163 242 28 32 87 80 75 184 100 210 177 108 230 228 60 182 8 33 196 75 64 150 23 179 203 103 219 134 65 217 91 254 152 29 68 36 58 232 105 161 26 36 107 179 72 20 243 244 14 131 197 77 49 251 189 175 174 33 60 98 235 234 218 216 157 215 236 145 30 179 195 68 30 84 29 130 155 237 89 19 238 48 112 227 108 148 225 44 7 211 143 140 234 97 201 92 171 75 152 42 135 185 218 62 55 131 10 48 186 181 68 152 253 239 189 170 128 53 177 92 173 247 2 3 1 0 1 163 130 1 134 48 130 1 130 48 52 6 8 43 6 1 5 5 7 1 1 4 40 48 38 48 36 6 8 43 6 1 5 5 7 48 1 134 24 104 116 116 112 58 47 47 111 99 115 112 46 118 101 114 105 115 105 103 110 46 99 111 109 48 18 6 3 85 29 19 1 1 255 4 8 48 6 1 1 255 2 1 0 48 101 6 3 85 29 32 4 94 48 92 48 90 6 4 85 29 32 0 48 82 48 38 6 8 43 6 1 5 5 7 2 1 22 26 104 116 116 112 58 47 47 119 119 119 46 115 121 109 97 117 116 104 46 99 111 109 47 99 112 115 48 40 6 8 43 6 1 5 5 7 2 2 48 28 26 26 104 116 116 112 58 47 47 119 119 119 46 115 121 109 97 117 116 104 46 99 111 109 47 114 112 97 48 52 6 3 85 29 31 4 45 48 43 48 41 160 39 160 37 134 35 104 116 116 112 58 47 47 99 114 108 46 118 101 114 105 115 105 103 110 46 99 111 109 47 112 99 97 51 45 103 53 46 99 114 108 48 29 6 3 85 29 37 4 22 48 20 6 8 43 6 1 5 5 7 3 2 6 8 43 6 1 5 5 7 3 3 48 14 6 3 85 29 15 1 1 255 4 4 3 2 1 6 48 42 6 3 85 29 17 4 35 48 33 164 31 48 29 49 27 48 25 6 3 85 4 3 19 18 86 101 114 105 83 105 103 110 77 80 75 73 45 50 45 50 49 52 48 29 6 3 85 29 14 4 22 4 20 163 142 207 25 66 61 49 225 171 33 137 132 109 203 217 121 162 178 178 90 48 31 6 3 85 29 35 4 24 48 22 128 20 127 211 101 167 194 221 236 187 240 48 9 243 67 57 250 2 175 51 49 51 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 130 1 1 0 106 243 29 188 95 77 222 3 249 73 73 29 173 61 118 28 150 186 27 67 230 244 134 2 66 117 120 199 12 194 229 157 196 52 79 14 169 233 74 180 190 65 132 135 234 244 135 180 76 219 16 73 59 247 223 21 144 186 132 248 183 71 235 91 101 80 243 163 74 113 16 22 123 28 225 245 214 237 191 80 86 111 248 153 179 169 81 182 70 174 198 151 224 231 155 12 21 62 187 40 123 49 163 0 243 46 139 135 72 18 137 130 239 9 95 73 12 144 158 200 246 150 163 123 154 117 19 200 71 240 62 63 111 11 80 41 108 43 120 76 48 252 228 96 12 19 64 214 56 117 169 7 121 100 253 202 60 228 239 72 147 11 224 10 72 255 7 107 59 2 131 209 102 213 185 225 152 244 14 159 105 196 46 85 46 1 150 125 126 132 12 128 118 117 54 203 253 70 97 244 105 204 26 157 100 43 186 4 110 233 17 82 218 18 153 161 90 176 131 196 188 71 128 166 39 77 0 122 54 3 60 190 97 152 99 203 159 5 238 128 133 238 221 149 146 247 238 80 212 99 220 143 164 36 121 191 48 130 5 163 48 130 4 139 160 3 2 1 2 2 16 95 78 177 184 171 91 174 72 177 99 34 121 39 161 165 116 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 129 140 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 31 48 29 6 3 85 4 11 19 22 83 121 109 97 110 116 101 99 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 61 48 59 6 3 85 4 3 19 52 83 121 109 97 110 116 101 99 32 67 108 97 115 115 32 51 32 69 120 116 101 110 100 101 100 32 86 97 108 105 100 97 116 105 111 110 32 67 111 100 101 32 83 105 103 110 105 110 103 32 67 65 48 30 23 13 49 53 48 53 49 52 48 48 48 48 48 48 90 23 13 49 55 48 53 48 55 50 51 53 57 53 57 90 48 129 244 49 19 48 17 6 11 43 6 1 4 1 130 55 60 2 1 3 19 2 85 83 49 25 48 23 6 11 43 6 1 4 1 130 55 60 2 1 2 20 8 68 101 108 97 119 97 114 101 49 29 48 27 6 3 85 4 15 19 20 80 114 105 118 97 116 101 32 79 114 103 97 110 105 122 97 116 105 111 110 49 16 48 14 6 3 85 4 5 19 7 50 55 52 56 49 50 57 49 11 48 9 6 3 85 4 6 19 2 85 83 49 19 48 17 6 3 85 4 8 12 10 67 97 108 105 102 111 114 110 105 97 49 17 48 15 6 3 85 4 7 12 8 83 97 110 32 74 111 115 101 49 35 48 33 6 3 85 4 10 12 26 65 100 111 98 101 32 83 121 115 116 101 109 115 32 73 110 99 111 114 112 111 114 97 116 101 100 49 18 48 16 6 3 85 4 11 12 9 84 121 112 101 32 70 111 110 116 49 35 48 33 6 3 85 4 3 20 26 65 100 111 98 101 32 83 121 115 116 101 109 115 32 73 110 99 111 114 112 111 114 97 116 101 100 48 130 1 34 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 130 1 15 0 48 130 1 10 2 130 1 1 0 235 233 232 81 239 57 134 12 12 255 211 100 24 224 111 157 3 68 225 155 143 94 134 222 121 225 150 29 190 129 19 247 67 34 72 7 33 242 138 153 133 94 6 88 241 8 170 192 244 4 45 134 108 10 27 4 168 234 237 214 196 45 236 212 7 202 215 197 178 52 11 142 132 192 15 252 26 112 188 225 30 38 169 197 15 123 212 221 3 184 138 98 62 125 39 103 102 156 55 136 158 93 219 212 154 255 155 155 14 168 229 108 143 186 180 216 144 243 62 102 199 56 232 20 50 247 54 249 51 217 188 242 216 141 212 223 192 78 206 28 243 119 131 137 42 74 9 0 210 129 18 106 113 249 218 133 225 211 179 218 153 204 10 121 70 120 34 72 127 198 239 133 83 35 228 63 255 71 141 166 216 63 180 20 48 223 221 139 156 231 48 75 61 210 235 14 84 208 17 234 248 159 19 246 187 125 154 189 241 222 127 185 126 147 46 60 84 225 62 44 236 101 42 107 30 66 222 227 4 178 211 245 212 121 48 246 227 183 67 187 16 74 137 50 105 181 134 94 69 3 247 104 240 61 19 105 2 3 1 0 1 163 130 1 149 48 130 1 145 48 46 6 3 85 29 17 4 39 48 37 160 35 6 8 43 6 1 5 5 7 8 3 160 23 48 21 12 19 85 83 45 68 101 108 97 119 97 114 101 45 50 55 52 56 49 50 57 48 9 6 3 85 29 19 4 2 48 0 48 102 6 3 85 29 32 4 95 48 93 48 91 6 11 96 134 72 1 134 248 69 1 7 23 6 48 76 48 35 6 8 43 6 1 5 5 7 2 1 22 23 104 116 116 112 115 58 47 47 100 46 115 121 109 99 98 46 99 111 109 47 99 112 115 48 37 6 8 43 6 1 5 5 7 2 2 48 25 12 23 104 116 116 112 115 58 47 47 100 46 115 121 109 99 98 46 99 111 109 47 114 112 97 48 22 6 3 85 29 37 1 1 255 4 12 48 10 6 8 43 6 1 5 5 7 3 3 48 14 6 3 85 29 15 1 1 255 4 4 3 2 7 128 48 29 6 3 85 29 14 4 22 4 20 49 243 219 82 223 150 44 32 47 241 8 6 200 76 229 105 238 55 32 118 48 43 6 3 85 29 31 4 36 48 34 48 32 160 30 160 28 134 26 104 116 116 112 58 47 47 115 99 46 115 121 109 99 98 46 99 111 109 47 115 99 46 99 114 108 48 87 6 8 43 6 1 5 5 7 1 1 4 75 48 73 48 31 6 8 43 6 1 5 5 7 48 1 134 19 104 116 116 112 58 47 47 115 99 46 115 121 109 99 100 46 99 111 109 48 38 6 8 43 6 1 5 5 7 48 2 134 26 104 116 116 112 58 47 47 115 99 46 115 121 109 99 98 46 99 111 109 47 115 99 46 99 114 116 48 31 6 3 85 29 35 4 24 48 22 128 20 163 142 207 25 66 61 49 225 171 33 137 132 109 203 217 121 162 178 178 90 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 130 1 1 0 8 42 137 158 56 23 75 237 54 167 114 199 137 22 95 17 226 154 237 24 90 164 136 87 115 122 14 104 139 15 126 153 247 246 253 214 133 33 180 151 52 121 249 245 75 108 101 31 168 69 30 208 59 245 98 250 103 220 126 231 196 109 162 9 241 221 24 149 110 44 218 192 237 58 191 226 124 212 182 198 214 79 253 6 142 9 205 255 212 69 50 4 76 180 48 188 205 54 226 94 50 172 11 224 17 164 101 105 58 85 188 199 171 23 246 135 215 46 184 78 31 22 227 231 100 216 90 41 163 193 120 31 148 87 96 81 169 174 123 42 150 18 160 8 65 207 90 129 24 149 227 221 255 166 119 62 39 161 23 83 183 220 70 89 53 144 220 118 51 154 177 191 98 43 116 201 16 10 234 240 156 3 30 142 214 108 60 234 23 183 134 241 200 156 94 175 194 163 162 212 65 127 231 155 176 33 48 1 41 226 89 232 137 186 239 23 93 130 17 179 72 87 57 19 100 62 159 50 144 198 127 35 170 11 115 63 156 175 142 128 133 24 122 244 159 220 224 127 140 70 178 243 162 51 104 72 49 130 4 185 48 130 4 181 2 1 1 48 129 161 48 129 140 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 31 48 29 6 3 85 4 11 19 22 83 121 109 97 110 116 101 99 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 61 48 59 6 3 85 4 3 19 52 83 121 109 97 110 116 101 99 32 67 108 97 115 115 32 51 32 69 120 116 101 110 100 101 100 32 86 97 108 105 100 97 116 105 111 110 32 67 111 100 101 32 83 105 103 110 105 110 103 32 67 65 2 16 95 78 177 184 171 91 174 72 177 99 34 121 39 161 165 116 48 9 6 5 43 14 3 2 26 5 0 160 129 222 48 25 6 9 42 134 72 134 247 13 1 9 3 49 12 6 10 43 6 1 4 1 130 55 2 1 4 48 28 6 10 43 6 1 4 1 130 55 2 1 11 49 14 48 12 6 10 43 6 1 4 1 130 55 2 1 21 48 35 6 9 42 134 72 134 247 13 1 9 4 49 22 4 20 240 8 222 190 224 181 107 218 129 156 99 117 208 157 79 227 23 26 121 140 48 126 6 10 43 6 1 4 1 130 55 2 1 12 49 112 48 110 160 108 128 106 0 83 0 111 0 117 0 114 0 99 0 101 0 32 0 83 0 97 0 110 0 115 0 32 0 80 0 114 0 111 0 32 0 102 0 97 0 109 0 105 0 108 0 121 0 32 0 119 0 105 0 116 0 104 0 32 0 71 0 114 0 101 0 101 0 107 0 32 0 97 0 110 0 100 0 32 0 67 0 121 0 114 0 105 0 108 0 108 0 105 0 99 0 32 0 82 0 111 0 109 0 97 0 110 0 115 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 4 130 1 0 45 207 65 34 26 64 109 3 157 97 10 253 47 172 238 235 119 92 199 133 4 234 177 15 139 48 175 103 52 50 168 154 193 244 180 115 11 202 114 95 230 194 122 181 244 167 109 207 69 116 23 237 247 81 163 89 230 127 106 94 11 45 189 27 210 185 191 75 224 168 151 100 92 216 6 62 246 167 186 17 51 193 51 228 125 244 248 61 89 230 133 3 249 91 203 158 171 255 14 49 48 229 59 244 246 166 76 219 136 77 49 106 189 77 116 119 10 112 157 88 230 228 193 151 158 61 138 188 126 112 176 247 254 62 118 132 70 44 143 63 245 46 49 245 75 167 33 195 69 235 38 150 56 236 190 200 1 173 238 200 104 192 207 149 173 98 115 120 240 159 26 58 215 254 168 38 204 223 245 112 249 0 89 145 6 20 173 200 205 146 213 222 204 78 214 22 57 44 215 197 48 223 209 211 104 46 213 84 100 96 222 7 114 199 212 116 132 95 42 154 123 191 129 196 98 194 252 249 183 227 99 171 68 101 144 203 178 177 77 111 37 16 14 215 70 104 244 253 199 132 154 109 98 109 142 22 161 130 2 11 48 130 2 7 6 9 42 134 72 134 247 13 1 9 6 49 130 1 248 48 130 1 244 2 1 1 48 114 48 94 49 11 48 9 6 3 85 4 6 19 2 85 83 49 29 48 27 6 3 85 4 10 19 20 83 121 109 97 110 116 101 99 32 67 111 114 112 111 114 97 116 105 111 110 49 48 48 46 6 3 85 4 3 19 39 83 121 109 97 110 116 101 99 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 67 65 32 45 32 71 50 2 16 14 207 244 56 200 254 191 53 110 4 216 106 152 27 26 80 48 9 6 5 43 14 3 2 26 5 0 160 93 48 24 6 9 42 134 72 134 247 13 1 9 3 49 11 6 9 42 134 72 134 247 13 1 7 1 48 28 6 9 42 134 72 134 247 13 1 9 5 49 15 23 13 49 53 48 57 49 52 49 55 49 57 51 54 90 48 35 6 9 42 134 72 134 247 13 1 9 4 49 22 4 20 45 64 88 122 236 231 205 146 227 224 122 41 230 101 208 50 209 111 153 18 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 4 130 1 0 154 245 101 73 75 50 3 122 75 143 22 172 91 233 223 127 185 194 11 50 41 199 112 157 151 110 18 164 39 15 238 66 40 47 100 237 24 137 125 66 115 199 205 140 218 154 155 252 125 220 227 195 200 158 216 116 237 184 220 151 227 122 138 50 137 228 23 215 234 177 159 47 191 101 136 149 47 210 201 215 9 110 118 87 159 162 56 207 218 75 110 216 207 96 232 158 22 118 109 165 186 240 163 26 200 161 189 226 127 163 34 191 75 99 126 172 212 190 71 51 216 138 249 192 22 235 128 128 129 164 158 162 241 195 88 69 152 127 144 136 185 227 12 13 78 41 107 115 21 23 154 92 226 83 157 85 136 160 134 128 47 178 105 203 199 196 161 69 157 19 70 180 194 201 240 215 217 238 199 103 176 213 235 125 229 163 124 215 21 238 184 56 198 170 90 35 210 72 215 102 101 50 59 53 139 43 92 207 8 122 70 78 105 65 26 61 94 150 18 157 14 228 133 165 108 110 126 100 14 33 254 191 108 82 36 62 180 198 30 225 125 223 122 151 235 180 226 218 126 116 249 1 196 188 126 249 0 0 0]! !

!SourceSansProRegular class methodsFor: 'class initialization' stamp: ''!
initialize 
	EmbeddedFreeTypeFontInstaller registerFont: self! !

!SourceSansProRegular class methodsFor: 'accessing' stamp: ''!
originalFileName
	^ 'SourceSansPro-Regular.ttf'! !

!Sp1MorphicAdapter commentStamp: ''!
I am bridging RoassalPresenter and RSView!
!Sp1MorphicAdapter methodsFor: 'initialization' stamp: ''!
applyScript
	| extent |
	extent := canvas extent.
	self freeCanvas.
	self basicApplyScript.
	canvas extent: extent.
	! !

!Sp1MorphicAdapter methodsFor: 'initialization' stamp: ''!
buildWidget
	^ RSCanvas new createMorph! !

!Sp1MorphicAdapter methodsFor: 'initialization' stamp: ''!
adapt: aComposableModel
	super adapt: aComposableModel.
	canvas := widget roassalCanvas.
	widget
		setProperty: #model toValue: self;
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	self basicApplyScript.! !

!Sp1MorphicAdapter methodsFor: 'initialization' stamp: ''!
release
	self class instVarNames do: [ :n | self instVarNamed: n put: nil ]! !

!Sp1MorphicAdapter methodsFor: 'initialization' stamp: ''!
freeCanvas
	| temp |
	temp := self buildWidget.
	canvas := temp roassalCanvas.
	widget canvas: canvas.
	canvas morph: widget.! !

!Sp1MorphicAdapter methodsFor: 'initialization' stamp: ''!
basicApplyScript
	self model script value: canvas.
	self widgetDo: #startStepping.
	
	canvas when: RSMouseEnter do: [ widget takeKeyboardFocus].! !

!Sp1RoassalPresenter commentStamp: ''!
I am a basic presenter for widgets in roassal with the Spec system!
!Sp1RoassalPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	script := [ :v | ] asValueHolder.
	script whenChangedDo: [ :s | self refresh ].! !

!Sp1RoassalPresenter methodsFor: 'initialization' stamp: ''!
refresh 
	self changed: #applyScript with: #()! !

!Sp1RoassalPresenter methodsFor: 'initialization' stamp: ''!
script
	^ script value! !

!Sp1RoassalPresenter methodsFor: 'initialization' stamp: ''!
release
	self class instVarNames do: [ :n | self instVarNamed: n put: nil ]! !

!Sp1RoassalPresenter methodsFor: 'initialization' stamp: ''!
script: anObject
	script value: anObject! !

!Sp1RoassalPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(#Sp1MorphicAdapter
		adapt: #(model))! !

!Sp1RoassalPresenter class methodsFor: 'specs' stamp: ''!
adapterName
	^ #Sp1MorphicAdapter! !

!SpAbstractAdapter commentStamp: ''!
I am an abstract class.

I'm the superclass of all the adapters used to link a Spec widget presenter to a framework specific widget (by example ButtonPresenter <-> PluggableButtonMorph).

The current implementation installs my instances as dependent of the presenter and my `changed:` method propagates updates to the widget I create (via my `buildWidget` method). This implementation is not optimal. 

In the future my instances should just be responsible to create a widget and install all the communication between the presenter and the widget. I should not be a middle man. 

I'm only interesting for back-ends developers. As a developer, using Spec to define application, you should not care and have to deal with me. !
!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
hSpaceFill

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'updating' stamp: ''!
update: aSymbol with: anArray

	self perform: aSymbol withArguments: anArray! !

!SpAbstractAdapter methodsFor: 'releasing' stamp: ''!
unsubscribe 
	"During initialization, adapters usually subscribe to various observable slots in the presenter. When the adapters are replaced by another during dynamic layouts switching, they need to be unsubscribed because it may cause a memory leaks and, in case of Gtk, even VM crashes.
	
	This is a generic slow and ugly fallback implementation of the unsubscription"

	unsubscribed == true ifTrue: [ ^ self ].
	self presenter unsubscribe: self.
	unsubscribed := true! !

!SpAbstractAdapter methodsFor: 'private' stamp: ''!
widgetDo: aBlock

	^ self widget ifNotNil: aBlock! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
add: aWidget

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
layout: aLayout

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
vShrinkWrap

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'updating' stamp: ''!
update: aSymbol

	self changed: aSymbol! !

!SpAbstractAdapter methodsFor: 'private' stamp: ''!
eventHandlerReceiver: aWidget

	^ aWidget! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
vSpaceFill

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
hRigid

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
vRigid

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
useProportionalLayout

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'emulating' stamp: ''!
sendRightClickEvent

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'factory' stamp: ''!
adapterWasBuilt
	"hook to add after-build opeations (for example, initial status, etc.)"! !

!SpAbstractAdapter methodsFor: 'accessing' stamp: ''!
owner

	"Every object instantiated by the SpecInerpreter should have an owner that will assign it to a particular presenter"
	^ owner! !

!SpAbstractAdapter methodsFor: 'testing' stamp: ''!
hasWidget: aMorphicButtonAdapter 
	
	^ self widget hasWidget: aMorphicButtonAdapter widget! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
removeSubWidgets

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!SpAbstractAdapter methodsFor: 'visibility' stamp: ''!
isVisible
	
	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
isMorphicAdapter

	^ false! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
hShrinkWrap

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'accessing' stamp: ''!
selector
	
	^ selector! !

!SpAbstractAdapter methodsFor: 'accessing' stamp: ''!
selector: anObject
	
	selector := anObject! !

!SpAbstractAdapter methodsFor: 'initialization' stamp: ''!
adapt: aPresenter

	unsubscribed := false.
	"Check if the presenter already had an adapter. If yes, we must first notify it to give it a chance
	to cancel its subscriptions to avoid memory leaks and potential VM crashes"
	aPresenter adapter ifNotNil: [ :oldAdapter | oldAdapter unsubscribe ].

	model := aPresenter.
	aPresenter addDependent: self.

	widget := self buildWidget! !

!SpAbstractAdapter methodsFor: 'accessing' stamp: ''!
widget
	^ widget! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
when: anAnnouncement do: aBlock

	self subclassResponsibility! !

!SpAbstractAdapter methodsFor: 'accessing' stamp: ''!
presenter
	^ model! !

!SpAbstractAdapter methodsFor: 'accessing' stamp: ''!
owner: anObject
	owner := anObject! !

!SpAbstractAdapter methodsFor: 'protocol' stamp: ''!
isRedrawable
	"This must be overriden in the adapter representing your container"
	
	^ false! !

!SpAbstractAdapter methodsFor: 'private' stamp: ''!
replaceLayoutWith: aLayout
	
	! !

!SpAbstractAdapter methodsFor: 'initialization' stamp: ''!
addEventsTo: aWidget
	
	self presenter hasEventHandler ifFalse: [ ^ self ].
	self presenter eventHandler 
		installAllEventsTo: self 
		target: (self eventHandlerReceiver: aWidget)! !

!SpAbstractAdapter class methodsFor: 'accessing' stamp: ''!
adaptingName
	"Answers the name this component adapts."

	^ self subclassResponsibility! !

!SpAbstractAdapter class methodsFor: 'accessing' stamp: ''!
allAdapters
	"The abstract adapters should be able to return all the adapters for a framework"
	
	^ self subclassResponsibility! !

!SpAbstractAdapter class methodsFor: 'instance creation' stamp: ''!
adapt: aPresenter
	
	^ self new
		adapt: aPresenter;
		yourself! !

!SpAbstractAdapter class methodsFor: 'accessing' stamp: ''!
adaptingAliases
	"Answers an array of aliases my class can adapt."

	^ #()! !

!SpAbstractAdapter class methodsFor: 'accessing' stamp: ''!
owner: anOwner

	^ self new owner: anOwner; yourself! !

!SpAbstractAdapter class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpAbstractAdapter! !

!SpAbstractAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ self subclassResponsibility! !

!SpAbstractAdapterTest methodsFor: 'utilities - emulation' stamp: ''!
emulateRightClick

	self emulateClick: MouseButtonEvent yellowButton! !

!SpAbstractAdapterTest methodsFor: 'asserting' stamp: ''!
assertIcon: anIcon equals: aForm 
	
	backendForTest assertIcon: anIcon equals: aForm! !

!SpAbstractAdapterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance! !

!SpAbstractAdapterTest methodsFor: 'accessing' stamp: ''!
adapter

	"Force opening the spec instance here.
	The action should have been correctly configured before
	depending on the spec initialization strategy"
	backendForTest openInstanceOf: self.
	^ presenter adapter! !

!SpAbstractAdapterTest methodsFor: 'running' stamp: ''!
prepareToRunAgain
	"Redefined because setup is cancelled in this class"

	self tearDown.
	super setUp! !

!SpAbstractAdapterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.	"This super is useless but it's to make the release tests happy."
	self error: 'Do not override me.... use #initializeTestedInstance'! !

!SpAbstractAdapterTest methodsFor: 'accessing' stamp: ''!
backendForTest: aClass 
	
	backendForTest := aClass new! !

!SpAbstractAdapterTest methodsFor: 'running' stamp: ''!
tearDown
	window ifNotNil: [ window delete ].
	super tearDown! !

!SpAbstractAdapterTest methodsFor: 'tests' stamp: ''!
testShowPresenterShowsWidget
	
	self presenter show.
	self assert: self adapter isVisible! !

!SpAbstractAdapterTest methodsFor: 'private' stamp: ''!
performTest
	backendForTest
		runTest: [ presenter := self classToTest new.
			self initializeTestedInstance.
			super performTest ]! !

!SpAbstractAdapterTest methodsFor: 'tests' stamp: ''!
testVisibilityWithBlockThatReturnsFalse
	presenter visibleIf: [ false ].
	self deny: self adapter isVisible! !

!SpAbstractAdapterTest methodsFor: 'accessing' stamp: ''!
widget

	^ self adapter widget! !

!SpAbstractAdapterTest methodsFor: 'accessing' stamp: ''!
specInitializationStrategy: aStrategy
	
	specInitializationStrategy := aStrategy! !

!SpAbstractAdapterTest methodsFor: 'accessing' stamp: ''!
window
	^ window! !

!SpAbstractAdapterTest methodsFor: 'accessing' stamp: ''!
window: aWindowPresenter 
	window := aWindowPresenter! !

!SpAbstractAdapterTest methodsFor: 'accessing' stamp: ''!
presenter
	^ presenter! !

!SpAbstractAdapterTest methodsFor: 'tests' stamp: ''!
testVisibilityWithBlock
	presenter visibleIf: [ true ].
	self assert: self adapter isVisible! !

!SpAbstractAdapterTest methodsFor: 'utilities - emulation' stamp: ''!
emulateLeftClick

	self emulateClick: MouseButtonEvent redButton! !

!SpAbstractAdapterTest methodsFor: 'utilities' stamp: ''!
openInstance

	backendForTest openInstanceOf: self 
! !

!SpAbstractAdapterTest methodsFor: 'running' stamp: ''!
runCase
	self resources do: [ :each | each availableFor: self ].
	[ super setUp.
	self performTest ]
		ensure: [ self tearDown.
			self cleanUpInstanceVariables ]! !

!SpAbstractAdapterTest methodsFor: 'tests' stamp: ''!
testHidePresenterHidesWidget
	
	self presenter hide.
	self deny: self adapter isVisible! !

!SpAbstractAdapterTest methodsFor: 'utilities - emulation' stamp: ''!
emulateCenterClick

	self emulateClick: MouseButtonEvent blueButton! !

!SpAbstractAdapterTest methodsFor: 'utilities - emulation' stamp: ''!
emulateClick: mouseButtonCode

	backendForTest emulateClick: mouseButtonCode onTest: self! !

!SpAbstractAdapterTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ self == SpAbstractAdapterTest! !

!SpAbstractAdapterTest class methodsFor: 'testing' stamp: ''!
testParameters 

	^ ParametrizedTestMatrix new
		forSelector: #specInitializationStrategy
			addOptions: { [ SpInitializationStrategy beforeTest ]. [ SpInitializationStrategy afterTest ] };
		forSelector: #backendForTest
			addOptions: { SpMorphicBackendForTest };
		yourself! !

!SpAbstractBackendForTest methodsFor: 'testing' stamp: ''!
emulateClick: mouseButtonCode onTest: anAdapterTest 

	anAdapterTest openInstance.

	MouseButtonEvent yellowButton = mouseButtonCode 
		ifTrue: [ anAdapterTest adapter sendRightClickEvent ].

	MouseButtonEvent redButton = mouseButtonCode 
		ifTrue: [ anAdapterTest adapter clicked ].
! !

!SpAbstractButtonPresenter commentStamp: ''!
A base for button presenters, it defines basic functionality common to all buttons.!
!SpAbstractButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	label := ''.
	
	self whenLabelChangedDo: [ self changed: #label ].
	self whenIconChangedDo: [ self changed: #label ].
! !

!SpAbstractButtonPresenter methodsFor: 'api' stamp: ''!
label: aString
	"Set the label to be shown by the button."

	label := aString! !

!SpAbstractButtonPresenter methodsFor: 'localization' stamp: ''!
localeChanged

	super localeChanged.
	self forceUpdateSlot: #label
	! !

!SpAbstractButtonPresenter methodsFor: 'api' stamp: ''!
iconName: aSymbol

	self icon: (self iconNamed: aSymbol)! !

!SpAbstractButtonPresenter methodsFor: 'api - events' stamp: ''!
whenIconChangedDo: aBlock
	"Inform when icon property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #icon whenChangedDo: aBlock! !

!SpAbstractButtonPresenter methodsFor: 'api' stamp: ''!
icon
	"Answer the icon (an instance of `Form`) defined for this button (it can be nil)"

	^ icon! !

!SpAbstractButtonPresenter methodsFor: 'private' stamp: ''!
shortcutCharacter

	^ nil! !

!SpAbstractButtonPresenter methodsFor: 'api' stamp: ''!
icon: anIcon
	"Sets the icon to be displayed by the button. 
	 The icon must be a `Form`"

	icon := anIcon! !

!SpAbstractButtonPresenter methodsFor: 'api' stamp: ''!
label
	"Answer the label to be shown by the button"

	^ label! !

!SpAbstractButtonPresenter methodsFor: 'api - events' stamp: ''!
whenLabelChangedDo: aBlock
	"Inform when label property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #label whenChangedDo: aBlock! !

!SpAbstractButtonPresenter class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self = SpAbstractButtonPresenter ]! !

!SpAbstractButtonPresenterTest methodsFor: 'tests' stamp: ''!
testWhenLabelChangedDo

	presenter label: 'label1'.

	presenter whenLabelChangedDo: [ :new :old | 
		self assert: old equals: 'label1'. self assert: new equals: 'label2'].

	self assert: presenter label equals: 'label1'.

	self openInstance.
	presenter label: 'label2'.

	self assert: presenter label equals: 'label2'.
! !

!SpAbstractButtonPresenterTest methodsFor: 'tests' stamp: ''!
testWhenIconChangedDo

	presenter iconName: #glamorousCancel.

	presenter whenLabelChangedDo: [ :new :old | 
		self assert: new equals: (self iconNamed: #glamorousCancel)].

	self assert: presenter icon equals: (self iconNamed: #glamorousCancel).

	self openInstance.

	presenter iconName: #pharo.

	self assert: presenter icon equals: (self iconNamed: #pharo).
! !

!SpAbstractButtonPresenterTest methodsFor: 'tests' stamp: ''!
testWhenHelpChanged
	presenter help: 'label1'.
	presenter
		whenHelpChangedDo: [ :new :old | 
			self assert: old equals: 'label1'.
			self assert: new equals: 'label2' ].
	self assert: presenter help equals: 'label1'.
	self openInstance.
	presenter help: 'label2'.
	self assert: presenter help equals: 'label2'! !

!SpAbstractButtonPresenterTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self = SpAbstractButtonPresenterTest ]! !

!SpAbstractFormButtonPresenter commentStamp: ''!
A base for _form control buttons_ (like radiobuttons or checkboxes).
!
!SpAbstractFormButtonPresenter methodsFor: 'api - events' stamp: ''!
whenActivatedDo: aBlock
	"Informs when the control button has been activated (see `SpAbstractFormButtonPresenter>>#state:`.
	 `aBlock` receives zero arguments." 
	
	self whenChangedDo: [ :aBoolean | aBoolean ifTrue: aBlock ]! !

!SpAbstractFormButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	state := false.

	labelClickable := true.
	label := ''.
	self whenLabelClickableChangedDo: [ :aBoolean | self changed: {#labelClickable: . aBoolean} ]! !

!SpAbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
label: aString
	"Sets the label to be shown by the button."

	label := aString! !

!SpAbstractFormButtonPresenter methodsFor: 'localization' stamp: ''!
localeChanged

	super localeChanged.
	self forceUpdateSlot: #label
	! !

!SpAbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
toggleState
	"Toogle the current state of the control button"

	self state: self state not! !

!SpAbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
state: aBoolean
	"Set the state of the control button."

	self state = aBoolean ifTrue: [
		"Do not update in case it does not change"
		^ self ].
	state := aBoolean! !

!SpAbstractFormButtonPresenter methodsFor: 'api - events' stamp: ''!
whenLabelClickableChangedDo: aBlock
	"Informs when the control button label clickable state has been changed (see `SpAbstractFormButtonPresenter>>#labelClickable:`.
	 `aBlock` receives zero arguments." 

	self property: #labelClickable whenChangedDo: aBlock! !

!SpAbstractFormButtonPresenter methodsFor: 'simulating' stamp: ''!
click
	"Simulate a click on the checkbox
	Used when the checkbox is a list item"

	self toggleState! !

!SpAbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
labelClickable: aBoolean
	"Set if the label can be clicked to select the control button"

	labelClickable := aBoolean! !

!SpAbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
labelClickable
	"Answer if the label can be clicked to select the control button"

	^ labelClickable! !

!SpAbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
state
	"Answer the current state of the control button"

	^ state! !

!SpAbstractFormButtonPresenter methodsFor: 'api - events' stamp: ''!
whenChangedDo: aBlock
	"Informs when the control button state has been changed (see `SpAbstractFormButtonPresenter>>#state:`.
	 `aBlock` receives one argument: 
	 - `aBoolean`, indicating control state." 
	
	self property: #state whenChangedDo: aBlock! !

!SpAbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
enabled: aBoolean
	"Set if the button is enabled."

	super enabled: aBoolean.
	self changed: #enabled.
! !

!SpAbstractFormButtonPresenter methodsFor: 'api - events' stamp: ''!
whenDeactivatedDo: aBlock
	"Informs when the control button has been deactivated (see `SpAbstractFormButtonPresenter>>#state:`.
	 `aBlock` receives zero arguments." 
	
	self whenChangedDo: [ :aBoolean | aBoolean ifFalse: aBlock ]! !

!SpAbstractFormButtonPresenter methodsFor: 'api' stamp: ''!
label
	"Answers the label to be shown by the button"

	^ label! !

!SpAbstractFormButtonPresenter methodsFor: 'api - events' stamp: ''!
whenLabelChangedDo: aBlock
	"Informs when the control button label been changed (see `SpAbstractFormButtonPresenter>>#label:`.
	 `aBlock` receives zero arguments." 

	self property: #label whenChangedDo: aBlock ! !

!SpAbstractFormButtonPresenter class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpAbstractFormButtonPresenter! !

!SpAbstractLayoutTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ self subclassResponsibility! !

!SpAbstractLayoutTest methodsFor: 'accessing' stamp: ''!
window: aWindowPresenter 
	window := aWindowPresenter! !

!SpAbstractLayoutTest methodsFor: 'running' stamp: ''!
tearDown
	window ifNotNil: [ window delete ].
	super tearDown! !

!SpAbstractLayoutTest methodsFor: 'accessing' stamp: ''!
adapter

	"Force opening the spec instance here.
	The action should have been correctly configured before
	depending on the spec initialization strategy"
	backendForTest openInstanceOf: self.
	^ presenter adapter! !

!SpAbstractLayoutTest methodsFor: 'running' stamp: ''!
prepareToRunAgain

	backendForTest runTest: [ super prepareToRunAgain ]
! !

!SpAbstractLayoutTest methodsFor: 'accessing' stamp: ''!
window
	^ window! !

!SpAbstractLayoutTest methodsFor: 'accessing' stamp: ''!
backendForTest: aClass 
	
	backendForTest := aClass new! !

!SpAbstractLayoutTest methodsFor: 'accessing' stamp: ''!
widget

	^ self adapter widget! !

!SpAbstractLayoutTest methodsFor: 'accessing' stamp: ''!
presenter
	^ presenter! !

!SpAbstractLayoutTest methodsFor: 'utilities' stamp: ''!
openInstance

	backendForTest openInstanceOf: self 
! !

!SpAbstractLayoutTest methodsFor: 'running' stamp: ''!
runCase

	self resources do: [:each | each availableFor: self].
	[	super setUp.
		backendForTest runTest: [
			presenter := self classToTest new.
			self performTest].
	] ensure: [
		self tearDown.
		self cleanUpInstanceVariables]! !

!SpAbstractLayoutTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.	"This super is useless but it's to make the release tests happy."
	self error: 'Do not override me.... use #initializeTestedInstance'! !

!SpAbstractLayoutTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ self = SpAbstractLayoutTest! !

!SpAbstractLayoutTest class methodsFor: 'testing' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		forSelector: #backendForTest addOptions: SpAbstractBackendForTest allSubclasses;
		yourself! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectManyIndexesKeepsAllSelected
	presenter selectIndex: 1.
	presenter selectIndex: 2.
	self
		assert: self adapter selectedIndexes asArray
		equals: #(1 2)! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests' stamp: ''!
testSelectPresenterWithScrollingMakeSelectedItemVisible
	| visibleItems |

	"TreeTable presenter does not have the same API, do not run the test"
	presenter class adapterName = #TreeTableAdapter ifTrue: [ ^ self ].
	presenter class adapterName = #TreeAdapter ifTrue: [ ^ self ].
	
	self flag: 'TODO: remove the following guard clause once scrolling is implemented on SpComponentListPresenter'.
	presenter class adapterName = #ComponentListAdapter ifTrue: [ ^ self ].
	
	presenter
		items: (1 to: 200);
		selectIndex: 150 scrollToSelection: true;
		openWithSpec.
		
	visibleItems := presenter verticalAlignment firstVisibleRowIndex to: presenter verticalAlignment lastVisibleRowIndex.
		
	self assert: (visibleItems includes: presenter selection selectedIndexes first)! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	super initializeTestedInstance.

	presenter
		beMultipleSelection;
		items: {10. 20. 30. 'aaa' asText}! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'running' stamp: ''!
tearDown

	presenter delete.
	super tearDown! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexSetsSelectedIndexInWidget
	presenter selectIndex: 1.
	self assert: (self adapter selectedIndexes includes: 1)! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedIndex |
	presenter selection
		whenChangedDo: [ :selection | selectedIndex := selection selectedIndexes ].
	self adapter selectIndex: 1.
	self assert: (selectedIndex includes: 1)! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexOutsideRangeUnsetsSelectedIndexInWidget
	presenter selectIndex: 100.
	self assert: self adapter selectedIndexes isEmpty! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testSubscribeToEventDoesNotRaiseEvent

	presenter selection
		whenChangedDo: [ :selection | self fail ].! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testUnselectAllInWidgetRaisesSelectionIndexChangeEventOnce
	| counter |
	counter := 0.
	self adapter selectIndex: 1.
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectIndex: 0.
	self assert: counter equals: 1! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterItemSetsSelectedIndexInWidget
	presenter selectItem: 20.
	self assert: (self adapter selectedIndexes includes: 2)! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testUnselectAllInWidgetRaisesEmptySelectionChangeEvent
	| gotSelection |
	self adapter selectIndex: 1.
	presenter selection
		whenChangedDo: [ :selection | gotSelection := selection ].
	self adapter selectIndex: 0.
	self assert: gotSelection isEmpty! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests' stamp: ''!
testRightClickShowsMenu
	| menu |

	presenter contextMenu: (menu := SpMockMenuPresenter new).
	self deny: menu shown.
	self emulateRightClick.
	self assert: menu shown! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventOnce
	| counter |
	counter := 0.
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectIndex: 1.
	self assert: counter equals: 1! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testStringColumnsShouldBeNonEditable

	self assert: (self adapter isNonEditableRow: 4 column: 1)! !

!SpAbstractListAdapterMultipleSelectionTest methodsFor: 'tests' stamp: ''!
testSelectPresenterWithoutScrollingDoesNotScroll
	| visibleItems verticalAlignment |
	
	"TreeTable presenter does not have the same API, do not run the test"
	presenter class adapterName = #TreeTableAdapter ifTrue: [ ^ self ].
	presenter class adapterName = #TreeAdapter ifTrue: [ ^ self ].
	
	self flag: 'TODO: remove the following guard clause once scrolling is implemented on SpComponentListPresenter'.
	presenter class adapterName = #ComponentListAdapter ifTrue: [ ^ self ].
	
	presenter 
		items: (1 to: 200);
		selectIndex: 150 scrollToSelection: true;
		openWithSpec.

	verticalAlignment := presenter verticalAlignment.		
	visibleItems := verticalAlignment firstVisibleRowIndex to: verticalAlignment lastVisibleRowIndex.
		
	self 
		assert: (verticalAlignment firstVisibleRowIndex to: verticalAlignment lastVisibleRowIndex) 
		equals: visibleItems! !

!SpAbstractListAdapterMultipleSelectionTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == SpAbstractListAdapterMultipleSelectionTest! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterWithScrollingMakeSelectedItemVisible
	| visibleItems |

	"TreeTable presenter does not have the same API, do not run the test"
	presenter class adapterName = #TreeTableAdapter ifTrue: [ ^ self ].
	
	self flag: 'TODO: remove the following guard clause once scrolling is implemented on SpComponentListPresenter'.
	presenter class adapterName = #ComponentListAdapter ifTrue: [ ^ self ].
	
	presenter
		items: (1 to: 200);
		selectIndex: 150 scrollToSelection: true;
		openWithSpec.
		
	visibleItems := presenter verticalAlignment firstVisibleRowIndex to: presenter verticalAlignment lastVisibleRowIndex.
		
	self assert: (visibleItems includes: presenter selection selectedIndex)! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	super initializeTestedInstance.

	presenter
		beSingleSelection;
		items: #(10 20 30).
! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'running' stamp: ''!
tearDown 

	presenter delete.
	super tearDown! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexSetsSelectedIndexInWidget
	presenter selectIndex: 1.
	self assert: (self adapter selectedIndexes includes: 1)! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedIndex |
	presenter selection
		whenChangedDo: [ :selection | selectedIndex := selection selectedIndex ].
	self adapter selectIndex: 1.
	self assert: selectedIndex equals: 1! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testUnselectWidgetIndexRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedIndex |
	self adapter selectIndex: 1.
	presenter selection
		whenChangedDo: [ :selection | selectedIndex := selection selectedIndex ].
	self adapter selectIndex: 0.
	self assert: selectedIndex equals: 0! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexOutsideRangeUnsetsSelectedIndexInWidget
	presenter selectIndex: 100.
	self assert: self adapter selectedIndexes isEmpty! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testSubscribeToEventDoesNotRaiseEvent

	presenter selection
		whenChangedDo: [ :selection | self fail ].! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testUnselectAllInWidgetWithoutSelectionDoesNotRaiseEvent
	| counter |
	counter := 0.
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectIndex: 0.
	self assert: counter equals: 0! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectPresenterItemUnselectsIndexInWidget
	presenter
		selectItem: 20;
		unselectItem: 20.
	self assert: self adapter selectedIndexes isEmpty! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterItemSetsSelectedIndexInWidget
	presenter selectItem: 20.
	self assert: (self adapter selectedIndexes includes: 2)! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectPresenterIndexUnselectsIndexInWidget
	presenter
		selectIndex: 1;
		unselectIndex: 1.
	self assert: self adapter selectedIndexes isEmpty! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectManyIndexesKeepsLastSelectionInWidget
	presenter selectIndex: 1.
	presenter selectIndex: 2.
	self assert: self adapter selectedIndexes equals: #(2)! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testUnselectWidgetIndexRaisesSelectionIndexChangeEventOnce
	| counter |
	counter := 0.
	self adapter selectIndex: 1.
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectIndex: 0.
	self assert: counter equals: 1! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventOnce
	| counter |
	counter := 0.
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectIndex: 1.
	self assert: counter equals: 1! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testUnselectAllInWidgetNotRaisesEmptySelectionChangeEvent
	| gotSelection |
	presenter selection
		whenChangedDo: [ :selection | gotSelection := selection ].
	self adapter selectIndex: 0.
	self assert: gotSelection isNil! !

!SpAbstractListAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterWithoutScrollingDoesNotScroll
	| visibleItems verticalAlignment |
	
	"TreeTable presenter does not have the same API, do not run the test"
	presenter class adapterName = #TreeTableAdapter ifTrue: [ ^ self ].
	
	self flag: 'TODO: remove the following guard clause once scrolling is implemented on SpComponentListPresenter'.
	presenter class adapterName = #ComponentListAdapter ifTrue: [ ^ self ].
	
	presenter 
		items: (1 to: 200);
		openWithSpec.
	verticalAlignment := presenter verticalAlignment.		
	visibleItems := verticalAlignment firstVisibleRowIndex to: verticalAlignment lastVisibleRowIndex.
	
	presenter selectIndex: 150 scrollToSelection: false.
			
	self 
		assert: (verticalAlignment firstVisibleRowIndex to: verticalAlignment lastVisibleRowIndex) 
		equals: visibleItems! !

!SpAbstractListAdapterSingleSelectionTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == SpAbstractListAdapterSingleSelectionTest! !

!SpAbstractListCommonPropertiestTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	presenter items: #(10 20 30).! !

!SpAbstractListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testSingleClickActivatesRowInSingleClickActivationMode

	| activated |
	activated := false.
	self presenter
		activateOnSingleClick;
		whenActivatedDo: [ activated := true ].

	backendForTest clickFirstRowAndColumn: self adapter.
	
	self assert: activated.! !

!SpAbstractListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testTypePerformsSearch

	self presenter selection selectIndex: 1. "10"
	self adapter type: '2'. 
	self 
		assert: self presenter selection selectedIndex 
		equals: 2 "20"! !

!SpAbstractListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testDoubleClickActivatesRowInDoubleClickActivationMode

	| activated |
	activated := false.
	self presenter activateOnDoubleClick.
	self presenter whenActivatedDo: [ activated := true ].
	
	backendForTest doubleClickFirstRowAndColumn: self adapter.
		
	self assert: activated! !

!SpAbstractListCommonPropertiestTest methodsFor: 'tests - scrolling' stamp: ''!
testFirstVisibleRowIsInitiallyFirstRow
	presenter items: (1 to: 500).
	self openInstance.
	self assert: presenter verticalAlignment firstVisibleRowIndex equals: 1! !

!SpAbstractListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testRightClickShowsMenu
	| menu |

	presenter contextMenu: (menu := SpMockMenuPresenter new).
	self deny: menu shown.
	self emulateRightClick.
	self assert: menu shown! !

!SpAbstractListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testChangeListInPresenterUpdatesWidget

	self presenter items: #( '1' '2' '3').

	backendForTest assertList: self adapter displayItems: #('1' '2' '3')! !

!SpAbstractListCommonPropertiestTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self == SpAbstractListCommonPropertiestTest! !

!SpAbstractListPresenter commentStamp: ''!
A base for list presenters, it defines basic functionality common to all lists.!
!SpAbstractListPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultInputPort

	^ self inputItemsPort! !

!SpAbstractListPresenter methodsFor: 'TOREMOVE' stamp: ''!
disableFilter
	self itemFilter: nil! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectionMode
	"Answer the selection object (an instance of `SpSingleSelectionMode` or `SpMultipleSelectionMode`).
	 This is not the item selected, but the selection container (it may contain one or many selected 
	 items).
	 This is the same as `SpAbstractListPresenter>>#selection`"
	
	^ selectionMode! !

!SpAbstractListPresenter methodsFor: 'private' stamp: ''!
disableActivationDuring: aBlock
	| oldActivate |
	
	oldActivate := activationBlock.
	activationBlock := [ ].
	aBlock ensure: [ 
		activationBlock := oldActivate ]! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
refresh
	"Forces a refresh of the list. 
	 This is useful when some model contents has changed, but we do not want to reset the whole list 
	 (and losing selections with it)"

	self withAdapterDo: [ :anAdapter | anAdapter refreshList ]! !

!SpAbstractListPresenter methodsFor: 'TOREMOVE' stamp: ''!
whenItemFilterBlockChangedDo: aBlock

	self property: #itemFilter whenChangedDo: aBlock! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectIndex: anIndex scrollToSelection: shouldScrollToSelection
	"Select item at position `anInteger`.
	 If `shouldScrollToSelection` is true, selection will scroll the presenter view 
	 to show selected element."

    self selectIndex: anIndex.
    shouldScrollToSelection ifTrue: [ 
        self verticalAlignment desiredVisibleRow: anIndex ].! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
updateItemsKeepingSelection: aCollection
	"Update list items keeping current selection. 
	 WARNING: aCollection must includes the elements selected."
	
	self disableActivationDuring: [ 
		| items |
		items := self selection selectedItems.
		self items: aCollection.
		self selectItems: items ]! !

!SpAbstractListPresenter methodsFor: 'simulation' stamp: ''!
clickItem: anInteger 
	
	self selectIndex: anInteger! !

!SpAbstractListPresenter methodsFor: 'api - events' stamp: ''!
whenSortingBlockChangedDo: aBlock
	"Inform when sorting block changed. 
	 `aBlock` receives one argument with the new sort function (or block with two arguments).
	 See `SpAbstractListPresenter>>#sortingBlock`"

	self model whenSortingBlockChangedDo: aBlock! !

!SpAbstractListPresenter methodsFor: 'simulation' stamp: ''!
clickAtIndex: anIndex

	self selectIndex: anIndex.

	activateOnSingleClick ifFalse: [ ^ self ].
	self doActivateAtIndex: anIndex! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
propagateNaturalHeight: aBoolean
	"Indicate when component propagates natural heigth.
	 Natural height propagation means that the height of the presenter containing both scrollbars and 
	 another component (tipically a text presenter) will follow the height of such component."

	propagateNaturalHeight := aBoolean! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
sortingBlock
	"Answer the sorting block defined to sort the model list.
	 `aBlock` is a two arguments block that answer a boolean (e.g. `[ :a :b | a < b ]`) 
	 or a `SortFunction`"

	self flag: #TODO. "Find a better name than 'sortingBlock'"
	^ self model sortingBlock! !

!SpAbstractListPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultOutputPort

	^ self outputSelectionPort! !

!SpAbstractListPresenter methodsFor: 'testing' stamp: ''!
activatesOnSingleClick
	"Answer true if activation event is triggered on single click"
	
	^ activateOnSingleClick! !

!SpAbstractListPresenter methodsFor: 'initialization' stamp: ''!
registerEvents

	self whenSelectionModeChangedDo: [ :selection | 
		self withAdapterDo: [ :anAdapter | anAdapter refreshWidgetSelection ] ].
	self whenMenuChangedDo: [ 
		self withAdapterDo: [ :anAdapter | anAdapter updateMenu ] ]! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
contextMenu: aValuableOrMenuPresenter
	"Set the context menu.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	contextMenu := aValuableOrMenuPresenter! !

!SpAbstractListPresenter methodsFor: 'api - events' stamp: ''!
whenModelChangedDo: aBlock
	"Inform when model has been changed (see `SpAbstractListPresenter>>#model:`. 
	 `aBlock` receive 3 optional arguments: 
	 - new value 
	 - old value 
	 - announcement triggered"

	model whenChangedDo: aBlock! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
removeScrollBarStyle: aStyle
	"Remove `aStyle` from the list of scrollbar styles.
	 See SpTHaveWrappingScrollBars>>#scrollBarStyles"

	scrollBarStyles := scrollBarStyles copyWithout: aStyle! !

!SpAbstractListPresenter methodsFor: 'initialization' stamp: ''!
initializeTHaveWrappingScrollBars

	scrollBarStyles := #().
	self propagateNaturalWidth: false.
	self propagateNaturalHeight: false! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
model
	"Answer the model for this list. 
	 It is tipically, an instance of `SpCollectionListModel`."
	
	^ model! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
addScrollBarStyle: aStyle
	"Add a style for the scrollbar component. 
	 In platforms that do not support separation from component and scrollbar (like Morphic), the 
	 style will be added to the component styles. 
	 In platforms who supports separation between component and scrollbar (like Gtk3), the style 
	 will be taken separately."

	scrollBarStyles := scrollBarStyles copyWith: aStyle! !

!SpAbstractListPresenter methodsFor: 'TOREMOVE' stamp: ''!
matchSubstring
	self itemFilter: [ :each :pattern | each asLowercase includesSubstring: pattern asLowercase ]! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectionMode: aMode
	
	selectionMode ifNotNil: [ 
		selectionMode transferSubscriptionsTo: aMode ].
	selectionMode := aMode! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
withoutScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	wrapScrollBars := false! !

!SpAbstractListPresenter methodsFor: 'TOREMOVE' stamp: ''!
matchBeginOfString
	self itemFilter: [ :each :pattern | each asLowercase beginsWith: pattern asLowercase ]! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectIndexes: aCollectionOfIndexes
	"Select items at positions included in `aCollectionOfIndexes`.
	 NOTE: in single selection mode, first element of `aCollectionOfIndexes` will be selected.
	 Selection will not scroll the presenter view to show selected(s) element(s)."

	self selectionMode selectIndexes: aCollectionOfIndexes! !

!SpAbstractListPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self initializeTHaveWrappingScrollBars.
	
	activationBlock := [ ].
	verticalAlignment := SpVerticalAlignment new.

	self withScrollBars.
	self model: 	self newEmptyModel.

	self beSingleSelection.
	self activateOnDoubleClick.

	self registerEvents! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectItems: aCollection
	"Select items included in `aCollection` if they are included in model list.
	 NOTE: In single selection mode it will select the first element of `aCollection` 
	 It does not scrolls to selected element."

	self selectionMode selectItems: aCollection! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectedItem
	"Return selected item."

	^ self selection selectedItem! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
sortingBlock: aBlock
	"Set sorting block to sort the model list.
	 `aBlock` is a two arguments block that answer a boolean (e.g. `[ :a :b | a < b ]`) 
	 or a `SortFunction`"

	self model sortingBlock: aBlock! !

!SpAbstractListPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
inputItemsPort

	^ SpListItemsPort newPresenter: self! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selection
	"Answer the selection object (an instance of `SpSingleSelectionMode` or `SpMultipleSelectionMode`).
	 This is not the item selected, but the selection container (it may contain one or many selected 
	 items)"
	
	^ selectionMode! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
scrollBarStyles
	"Answer styles defined for the scrollbar component. 
	 In platforms that do not support separation from component and scrollbar (like Morphic), the 
	 style will be added to the component styles. 
	 In platforms who supports separation between component and scrollbar (like Gtk3), the style 
	 will be taken separately."

	^ scrollBarStyles ifNil: [ #() ]! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
unselectAll
	"Remove all selections"
	
	self selection unselectAll! !

!SpAbstractListPresenter methodsFor: 'private' stamp: ''!
itemsAt: aCollectionOfIndex
	^ aCollectionOfIndex collect: [ :anIndex | self itemAt: anIndex ]! !

!SpAbstractListPresenter methodsFor: 'private' stamp: ''!
doActivateAtIndex: anIndex

	"Activate only if there is an item at that position"
	self model at: anIndex ifAbsent: [ ^ self ].
	
	activationBlock cull: ((SpSingleSelectionMode on: self)
		basicSelectIndex: anIndex;
		yourself)! !

!SpAbstractListPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
outputActivationPort
	
	^ SpActivationPort newPresenter: self! !

!SpAbstractListPresenter methodsFor: 'private' stamp: ''!
itemAt: index 
	"If there is an adapter the widget items indexes can be different thant the model items indexes, 
	e.g. when the sort by a column is activated. In this case, ask the adapter to get the element 
	displayed at index."

	^ self adapter 
		ifNotNil: [ :anAdapter | anAdapter elementAt: index ]
		ifNil: [ self model at: index ]! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectItem: anItem 
	"Select `anItem` if it is included in model list.
	 It does not scrolls to selected element."
	
	self selectionMode selectItem: anItem! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
beSingleSelection
	"Enable single selection (this is the default)."
	
	self selectionMode: (SpSingleSelectionMode on: self)! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
propagateNaturalWidth: aBoolean
	"Indicate when component propagates natural width.
	 Natural width propagation means that the width of the presenter containing both scrollbars and 
	 another component (tipically a text presenter) will follow the width of such component.
	 WARNING: Because of a limitation on how the font rendering works in morphic backend, 
	 this properly will fail to preserve the correct width if using monospaced fonts."

	propagateNaturalWidth := aBoolean! !

!SpAbstractListPresenter methodsFor: 'testing' stamp: ''!
isMultipleSelection
	"Answer true if list accepts multiple selection"
	
	^ selectionMode isMultipleSelection! !

!SpAbstractListPresenter methodsFor: 'private' stamp: ''!
itemAtPath: anArray
	"This is to provide polymorphism with SpTreeTablePresentrer"

	^ self itemAt: anArray first! !

!SpAbstractListPresenter methodsFor: 'api - events' stamp: ''!
whenActivatedDo: aBlock
	"Inform when an element has been 'activated'. 
	 `aBlock` receives one argument (a selection object, see `SpAbstractSelectionMode`)"
	
	activationBlock := aBlock! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectIndex: anInteger 
	"Select item at position `anInteger`.
	 Selection will not scroll the presenter view to show selected element."
	
	self selectionMode selectIndex: anInteger! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectIndexes: aCollectionOfIndexes scrollToSelection: shouldScrollToSelection
	"Select items at positions included in `aCollectionOfIndexes`.
	 NOTE: in single selection mode, first element of `aCollectionOfIndexes` will be selected.
	 If `shouldScrollToSelection` is true, selection will scroll the presenter view 
	 to show first selected element."
  
  self selectIndexes: aCollectionOfIndexes.
    shouldScrollToSelection ifTrue: [ 
        self verticalAlignment desiredVisibleRow: aCollectionOfIndexes first ].! !

!SpAbstractListPresenter methodsFor: 'testing' stamp: ''!
hasScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	^ wrapScrollBars! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectAll
	"Select all items in the list or table. 
	 It does not triggers activation event."
	
	self selection selectAll! !

!SpAbstractListPresenter methodsFor: 'api - events' stamp: ''!
whenSearchEnabledChangedDo: aBlock
	"Inform when search enabled/disabled has changed.
	`aBlock` receives zero arguments."
	
	self property: #searchEnabled whenChangedDo: aBlock! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
withScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	wrapScrollBars := true! !

!SpAbstractListPresenter methodsFor: 'private' stamp: ''!
newEmptyModel

	^ SpCollectionListModel on: #()! !

!SpAbstractListPresenter methodsFor: 'accessing' stamp: ''!
verticalAlignment

	^ verticalAlignment! !

!SpAbstractListPresenter methodsFor: 'simulation' stamp: ''!
doubleClickAtIndex: anIndex
	self selectIndex: anIndex.
	
	activateOnSingleClick ifTrue: [ ^ self ].
	self doActivateAtIndex: anIndex! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectFirst
	"Select first element in list. 
	 Useful to avoid selecting by index."
	
	^ self selectIndex: 1! !

!SpAbstractListPresenter methodsFor: 'api - events' stamp: ''!
whenMenuChangedDo: aBlock
	"Inform when menu definition changed. 
	 `aBlock` receives zero arguments."

	self property: #contextMenu whenChangedDo: aBlock! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
unselectItem: anObject 
	"Remove selection of element `anObject`"
	
	self selection unselectItem: anObject! !

!SpAbstractListPresenter methodsFor: 'api - events' stamp: ''!
whenNoneSelectedDo: aBlock
	"Inform when the list has clean selection (there are no items selected).
	 `aBlock` receives zero arguments"

	self whenSelectionChangedDo: [ :selection | 
		selection selectedItem 
			ifNil: [ aBlock value ] ]! !

!SpAbstractListPresenter methodsFor: 'testing' stamp: ''!
isPropagateNaturalWidth
	"Indicate if component propagates natural width.
	 See `SpTHaveWrappingScrollBars>>#propagateNaturalWidth:`"

	^ propagateNaturalWidth ifNil: [ false ]! !

!SpAbstractListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionModeChangedDo: aBlock
	"Inform when selection mode (single/multiple) changed. 
	 `aBlock` receives zero arguments."

	selectionMode whenChangedDo: aBlock! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectedItemsSorted
	"Return all the selected items sorted by their index"

	^ self itemsAt: self selection selectedIndexes sort! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
beMultipleSelection
	"Enable multiple selection."

	self selectionMode: (SpMultipleSelectionMode on: self)! !

!SpAbstractListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionChangedDo: aBlock
	"Inform when there are changes in selection.
	This method works for all selection modes (single, multiple and no selection).
	`aBlock` receives an optional argument with the selection object."

	self selection whenChangedDo: aBlock! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
contextMenu
	"Answer context menu or nil if there is none defined.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	^ contextMenu! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
listSize
	"Return the size of the item list contained in model (see `SpAbstractListPresenter>>#model`)"

	self flag: #TODO. "Maybe this should be called #itemsSize? (since we set #items: and not #list: )"
	^ self model size! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
activateOnDoubleClick
	"Configure the list to trigger activation on double click.
	 An element on a list can be 'activated', meaning it will trigger an event to execute an 
	 action on it. An activation is different than a selection (one can 'select' an element without 
	 activating it).
	 See `SpAbstractListPresenter>>#whenActivatedDo:`"
	
	activateOnSingleClick := false! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
unselectIndex: anInteger 
	"Remove selection of element at index `anInteger`"
	
	self selection unselectIndex: anInteger! !

!SpAbstractListPresenter methodsFor: 'testing' stamp: ''!
activatesOnDoubleClick
	"Answer true if activation event is triggered on double click"
	
	^ activateOnSingleClick not! !

!SpAbstractListPresenter methodsFor: 'TOREMOVE' stamp: ''!
itemFilter
	^ itemFilter! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
activateOnSingleClick
	"Configure the list to trigger activation on single click.
	 An element on a list can be 'activated', meaning it will trigger an event to execute an 
	 action on it. An activation is different than a selection (one can 'select' an element without 
	 activating it).
	 See `SpAbstractListPresenter>>#whenActivatedDo:`"
	
	activateOnSingleClick := true! !

!SpAbstractListPresenter methodsFor: '*Spec2-Commander2' stamp: ''!
contextMenuFromCommandsGroup: aValuable
	self contextMenu: [ aValuable value beRoot asMenuPresenter ]! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
items: aSequenceableCollection
	"Set the items of the list.
	`aSequenceableCollection` is a collection of your domain specific items.
	This resets the collection model and unselects any previously selected item."
	
	model collection: aSequenceableCollection.
	self unselectAll! !

!SpAbstractListPresenter methodsFor: 'testing' stamp: ''!
isPropagateNaturalHeight
	"Indicate if component propagates natural heigth.
	 See `SpTHaveWrappingScrollBars>>#propagateNaturalHeight:`"

	^ propagateNaturalHeight ifNil: [ false ]! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
model: aModel
	"Sets the model used to feed the list presenter with elements of the list. 
	 It is tipically an instance of `SpCollectionListModel`."
	
	model := aModel.
	model whenChangedDo: [ 
		self withAdapterDo: [ :anAdapter | anAdapter refreshList ] ]! !

!SpAbstractListPresenter methodsFor: 'api - selection' stamp: ''!
selectedItems
	"Return all the selected items in the case of a multiple selection list"

	^ self selection selectedItems! !

!SpAbstractListPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
outputSelectionPort
	
	^ SpSelectionPort newPresenter: self! !

!SpAbstractListPresenter methodsFor: 'api' stamp: ''!
items
	"Answer the items of the list"
	
	^ self model collection! !

!SpAbstractListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectedDo: aBlock
	"Inform when an item was selected (a real object in the items list).
	 `aBlock` receives one argument (the new selected element)"

	self whenSelectionChangedDo: [ :selection | 
		selection selectedItem 
			ifNotNil: [ :item | aBlock value: item ] ]! !

!SpAbstractListPresenter methodsFor: 'TOREMOVE' stamp: ''!
itemFilter: aBlock
	"This block will be used with the search field of the list to filter it with the user input dynamically."

	itemFilter := aBlock! !

!SpAbstractListPresenter methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
iconFor: anItem
	"This is needed for the Morphic backend because all of them share the same datasource asking for this method. For lists without icons it will return nil."

	^ nil! !

!SpAbstractListPresenter class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self = SpAbstractListPresenter ]	! !

!SpAbstractListPresenter class methodsFor: 'documentation' stamp: ''!
documentSections
		
	^ OrderedDictionary newFromPairs: {
		'Examples'. self class methods select: [ :each | each protocol = self documentExamplesProtocol ].
		'API Methods'. self methods select: [ :each | each protocol = #'api' ].
		'API Selection Methods'. self methods select: [ :each | each protocol = #'api - selection' ].
		'Testing Methods'. self methods select: [ :each | each protocol = #'testing' ].
		'Events'. self methods select: [ :each | each protocol = #'api - events' ].
	 }! !

!SpAbstractListPresenterTest commentStamp: ''!
testing ListComposablePresenter!
!SpAbstractListPresenterTest methodsFor: 'tests - activation' stamp: ''!
testActivationWithoutActivationBlockDoesNothing

	| activatedItem |
	activatedItem := nil.
	presenter activateOnSingleClick.

	presenter clickAtIndex: 1.
	
	self assert: activatedItem equals: nil! !

!SpAbstractListPresenterTest methodsFor: 'tests' stamp: ''!
testUpdateItemsKeepingSelection 

	presenter items: #($a $b $c).
	presenter selectItem: $c.
	presenter updateItemsKeepingSelection: #($c $d $e $f).
	self assert: presenter selectedItem equals: $c! !

!SpAbstractListPresenterTest methodsFor: 'tests' stamp: ''!
testContextMenu
	| menu changed |
	
	self assert: presenter contextMenu isNil.
	menu := SpMenuPresenter new.
	changed := false.
	presenter whenMenuChangedDo: [ 
		changed := true. ].
	presenter contextMenu: menu.
	self assert: presenter contextMenu equals: menu.
	self assert: changed! !

!SpAbstractListPresenterTest methodsFor: 'tests' stamp: ''!
testSelectAll

	presenter beSingleSelection.
	presenter selectAll.
	"in single mode selectAll has no effect"
	self assertEmpty: presenter selection selectedItems. 
	presenter beMultipleSelection.
	presenter selectAll.
	"but in multiple mode selectAll works"
	self 
		assert: presenter selection selectedItems asArray 
		equals: #(10 20 30)! !

!SpAbstractListPresenterTest methodsFor: 'tests - activation' stamp: ''!
testActivationOnDoubleClickShouldActivateOnDoubleClick

	| activatedItem |
	activatedItem := nil.
	presenter
		activateOnDoubleClick;
		whenActivatedDo: [ :selection | activatedItem := selection selectedItem ].
	
	presenter doubleClickAtIndex: 1.
	
	self assert: activatedItem equals: 10.! !

!SpAbstractListPresenterTest methodsFor: 'tests - smoke' stamp: ''!
testSmokeOpenEmptyPresenter

	window := presenter openWithSpec! !

!SpAbstractListPresenterTest methodsFor: 'tests - activation' stamp: ''!
testActivationOnDoubleClickShouldNotActivateOnClick

	| activatedItem |
	activatedItem := nil.
	presenter
		activateOnDoubleClick;
		whenActivatedDo: [ :selection  | activatedItem := selection selectedItem ].
	
	presenter clickAtIndex: 1.
	
	self assert: activatedItem equals: nil.! !

!SpAbstractListPresenterTest methodsFor: 'tests - activation' stamp: ''!
testActivationOnSingleClickShouldNotActivateOnClickOutside

	| activatedItem |
	activatedItem := nil.
	presenter
		activateOnSingleClick;
		whenActivatedDo: [ :selection | activatedItem := selection selectedIndex ].
	
	presenter clickAtIndex: 100.
	
	self assert: activatedItem equals: nil! !

!SpAbstractListPresenterTest methodsFor: 'tests - smoke' stamp: ''!
testSetSortingBlockBeforeItems
	| count |
	count := 0.
	presenter whenSortingBlockChangedDo: [ :sortFunction | count := count + 1 ].
	presenter sortingBlock: #yourself ascending.
	presenter items: #(3 8 1 0).
	self assert: count equals: 1.
	self assert: (presenter model at: 1) equals: 0! !

!SpAbstractListPresenterTest methodsFor: 'tests - smoke' stamp: ''!
testSortingBlock
	| count |
	count := 0.
	presenter whenSortingBlockChangedDo: [ :sortFunction | count := count + 1 ].
	presenter items: #(3 8 1 0).
	presenter sortingBlock: #yourself ascending.
	self assert: count equals: 1.
	self assert: (presenter model at: 1) equals: 0! !

!SpAbstractListPresenterTest methodsFor: 'tests - activation' stamp: ''!
testActivationOnSingleClickShouldActivateOnClick

	| activatedItem |
	activatedItem := nil.
	presenter
		activateOnSingleClick;
		whenActivatedDo: [ :selection | activatedItem := selection selectedItem ].
	
	presenter clickAtIndex: 1.
	
	self assert: activatedItem equals: 10.! !

!SpAbstractListPresenterTest methodsFor: 'tests - smoke' stamp: ''!
testSmokeOpenPresenterWithItems

	window := presenter
		items: #(1 2 3);
		openWithSpec.! !

!SpAbstractListPresenterTest methodsFor: 'tests' stamp: ''!
testReplaceItemList
	| changed |

	changed := false.
	presenter whenModelChangedDo: [ changed := true ].
	presenter items: #(a b c).
	
	self 
		assert: presenter model collection
		equals: #(a b c).
	self assert: changed! !

!SpAbstractListPresenterTest methodsFor: 'tests' stamp: ''!
testDisableActivationDuring 
	| activated |

	activated := false.
	presenter whenActivatedDo: [ activated := true ].
	
	self deny: activated.
	presenter disableActivationDuring: [ presenter clickAtIndex: 2 ].
	self deny: activated. "still not change"
	self assert: presenter selectedItem equals: 20 "but the selection changed!!"! !

!SpAbstractListPresenterTest methodsFor: 'tests' stamp: ''!
testUnselectAll

	presenter beMultipleSelection.
	presenter selectAll.
	self 
		assert: presenter selection selectedItems asArray 
		equals: #(10 20 30).
	presenter unselectAll.
	self assertEmpty: presenter selection selectedItems! !

!SpAbstractListPresenterTest methodsFor: 'tests' stamp: ''!
testSelectedItemsSortedByIndex

	presenter beMultipleSelection.
	presenter 
		selectIndex: 3;
		selectIndex: 1.
	self 
		assert: presenter selection selectedItems asArray
		equals: #(30 10). 
	self 
		assert: presenter selection selectedItemsSortedByIndex asArray
		equals: #(10 30)! !

!SpAbstractListPresenterTest methodsFor: 'tests' stamp: ''!
testActivationWithTransformation
	| activatedItem |

	activatedItem := nil.
	presenter
		activateOnSingleClick;
		whenActivatedDo: (SpActivationTransform
			activateDo: [ :selection | activatedItem := selection selectedItem ]
			transform: [ :selection | selection selectedItem * 10 ]).
	
	presenter clickAtIndex: 1.
	
	self assert: activatedItem equals: 100! !

!SpAbstractListPresenterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	presenter items: #(10 20 30).! !

!SpAbstractListPresenterTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == SpAbstractListPresenterTest! !

!SpAbstractMorphicAdapter commentStamp: ''!
I am an abstract class providing all the properties shared amongs all the morphic specific adapters!
!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
color: color

	self widgetDo: [ :w | w color: color ]! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
hSpaceFill
	
	self widgetDo: [ :w | w hResizing: #spaceFill ]! !

!SpAbstractMorphicAdapter methodsFor: 'releasing' stamp: ''!
unsubscribe

	super unsubscribe.
	
	self presenter hasAnnouncer ifFalse: [ ^ self ].
	self presenter announcer 
		unsubscribe: self widget;
		unsubscribe: self! !

!SpAbstractMorphicAdapter methodsFor: 'styling' stamp: ''!
addStyle: aStyle
	"ignore style and just apply it again (the new style will not there)"
	self applyStyle: self widget! !

!SpAbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
transferFor: passenger from: source

	^ SpTransferPresenter new
		transfer: passenger;
		from: source;
		yourself! !

!SpAbstractMorphicAdapter methodsFor: 'private' stamp: ''!
showContextMenu

	self presenter contextMenu ifNil: [ ^ self ].
	self showMenu: self presenter contextMenu! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installEvent: anEvent
	"Used when installing events into presenters already built"

	self widgetDo: [ :w |
		anEvent 
			installOn: self 
			target: (self eventHandlerReceiver: w) ]! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
borderColor: color

	self widget ifNotNil: [ :w | w borderColor: color ]! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installMouseDownEvent: anEvent to: aWidget

	aWidget 
		on: #mouseDown
		send: #value:
		to: anEvent action! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
hRigid
	
	self widgetDo: [ :w | w hResizing: #rigid ]! !

!SpAbstractMorphicAdapter methodsFor: 'styling' stamp: ''!
presenterStyles
	"The presenters in the style"

	^ self presenter styles! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installMouseDoubleClickEvent: anEvent to: aWidget

	aWidget 
		on: #doubleClick
		send: #value:
		to: anEvent action! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
useProportionalLayout

	self widgetDo: [ :w | w changeProportionalLayout ]! !

!SpAbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
dragEnabled

	^ self presenter dragEnabled! !

!SpAbstractMorphicAdapter methodsFor: 'emulating' stamp: ''!
keyEvent: type code: keyCode shift: shiftBoolean meta: metaBoolean control: controlBoolean option: optionBoolean
	| evt modifiers |
	
	modifiers := 0.
	shiftBoolean ifTrue: [ modifiers := modifiers | 8 ].
	metaBoolean ifTrue: [ modifiers := modifiers |
		(Smalltalk os isWindows | Smalltalk os isUnix
			ifTrue: [ 2r00010000 ]
			ifFalse: [ 2r01000000 ]) ].
	controlBoolean ifTrue: [ modifiers := modifiers | 2r00010000 ].
	optionBoolean ifTrue: [ modifiers := modifiers |
		(Smalltalk os isWindows | Smalltalk os isUnix
			ifTrue: [ 2r01000000 ]
			ifFalse: [ 2r00100000 ]) ].
		
	evt := KeyboardEvent new
		setType: type
		buttons: modifiers
		position: self widget position + (1 @ 1)
		keyValue: keyCode
		charCode: keyCode
		hand: self currentWorld activeHand
		stamp: Time millisecondClockValue.

	evt key: (KeyboardKey fromCharacter: keyCode asCharacter).
	evt sentTo: self widgetEventReceiver.
	"Some time to allow things to happen?"
	10 milliSeconds wait! !

!SpAbstractMorphicAdapter methodsFor: 'protocol - shortcuts' stamp: ''!
removeKeyCombination: aShortcut

	self widgetDo: [ :w | 
		w removeKeyCombination: aShortcut ]! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installFocusReceivedEvent: anEvent to: aWidget

	aWidget announcer 
		when: MorphGotFocus
		do: [ anEvent action value ]! !

!SpAbstractMorphicAdapter methodsFor: 'visibility' stamp: ''!
isVisible
	
	^ widget visible! !

!SpAbstractMorphicAdapter methodsFor: 'private' stamp: ''!
addContextMenuKeyBindings: aWidget
	
	self flag: #TODO. "Take this from a configuration"
	self 
		bindKeyCombination: $t command mac | $t control unix | $t control win
		toAction: [ self showContextMenu ]
! !

!SpAbstractMorphicAdapter methodsFor: 'styling' stamp: ''!
applyStyle

	self applyStyle: self widget! !

!SpAbstractMorphicAdapter methodsFor: 'spec protocol' stamp: ''!
delete
	
	self widgetDo: [ :w | w delete ]! !

!SpAbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: ''!
acceptDroppingMorph: draggedMorph event: event inMorph: source

	^ self acceptDropBlock cull: draggedMorph model model cull: event cull: source model model! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
borderWidth: width

	self widget ifNotNil: [ :w | w borderWidth: width ]! !

!SpAbstractMorphicAdapter methodsFor: 'testing' stamp: ''!
isMorphicAdapter

	^ true! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installMouseEnterEvent: anEvent to: aWidget

	aWidget 
		on: #mouseEnter
		send: #value:
		to: anEvent action! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
takeKeyboardFocus
	
	self widgetDo: [ :w | w takeKeyboardFocus ]! !

!SpAbstractMorphicAdapter methodsFor: 'initialization' stamp: ''!
adapt: aPresenter

	super adapt: aPresenter.
	self addSettingsTo: self widget.
	self addKeyBindingsTo: self widget.
	self addEventsTo: self widget! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
enable

	self model enabled: true! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
extent

	^ self widget extent! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installMouseMoveEvent: anEvent to: aWidget

	aWidget 
		on: #mouseMove
		send: #value:
		to: anEvent action! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
show 

	self widgetDo: #show! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
enabled
	^ self presenter isEnabled! !

!SpAbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
dragEnabled: aBoolean

	self widget ifNotNil: [ :w | w dragEnabled: aBoolean ]! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installFocusLostEvent: anEvent to: aWidget

	aWidget announcer 
		when: MorphLostFocus
		do: [ anEvent action value ]! !

!SpAbstractMorphicAdapter methodsFor: 'emulating' stamp: ''!
widgetEventReceiver
	
	^ self eventHandlerReceiver: widget! !

!SpAbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
acceptDropBlock

	^ self model acceptDropBlock! !

!SpAbstractMorphicAdapter methodsFor: 'styling' stamp: ''!
styleName
	"i.e. SpButtonAdapter = button"
	
	^ ((self className withoutPrefix: 'SpMorphic') allButLast: 7) uncapitalized! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
color

	^ self model color! !

!SpAbstractMorphicAdapter methodsFor: 'spec protocol' stamp: ''!
changed

	^ self widgetDo: [ :w | w changed ]! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installMouseUpEvent: anEvent to: aWidget

	aWidget 
		on: #mouseUp
		send: #value:
		to: anEvent action! !

!SpAbstractMorphicAdapter methodsFor: 'protocol - shortcuts' stamp: ''!
bindKeyCombination: aShortcut toAction: aBlock

	self widgetDo: [ :w | 
		w 
			bindKeyCombination: aShortcut 
			toAction: aBlock ]! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
add: anAdapter
	self widgetDo: [ :w | w spEnsureLayoutAndAddMorph: anAdapter widget ]! !

!SpAbstractMorphicAdapter methodsFor: 'focus handling' stamp: ''!
focusNext
	
	self presenter withWindowDo: [ :window | | presenters |
		presenters := window allPresentersInFocusOrder.
		(presenters 
			after: self presenter
			ifAbsent: [ presenters first ])
			takeKeyboardFocus ]! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
layout: aLayout
	| layout |
	layout := aLayout asMorphicLayout.
	self widgetDo: [ :w | w layoutFrame: layout ].! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
borderWidth

	^ self model borderWidth! !

!SpAbstractMorphicAdapter methodsFor: 'emulating' stamp: ''!
sendClickEvent
	| evt |

	evt := MouseButtonEvent new 
		setType: nil 
		position: widget center 
		which: MouseButtonEvent redButton 
		buttons: MouseButtonEvent redButton 
		hand: nil 
		stamp: nil.

	(widget handlesMouseDown: evt) ifTrue: [
		widget handleMouseDown: evt.
		widget handleMouseUp: evt ]! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
vShrinkWrap
	
	self widgetDo: [ :w | w vResizing: #shrinkWrap ]! !

!SpAbstractMorphicAdapter methodsFor: 'emulating' stamp: ''!
type: aString

	aString do: [ :each | 
		self 
			keyPressed: each 
			shift: each isUppercase
			meta: false 
			control: false 
			option: false ]! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installKeyUpEvent: anEvent to: aWidget

	aWidget 
		on: #keyUp
		send: #value:
		to: anEvent action! !

!SpAbstractMorphicAdapter methodsFor: 'initialization' stamp: ''!
addSettingsTo: aMorph
	
	self widget ifNil: [ ^ self ].
	"For some reason, some times (it seems to be in with menu groups) you do not have a 
	 Morph here (instead, you have a collection of morphs). This have to be an error 
	 somehow, but no time to dig at it."
	self widget isMorph
		ifTrue: [ self widget presenter: self presenter ].
	self applyVisibility! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
vSpaceFill
	
	self widgetDo: [ :w | w vResizing: #spaceFill ]! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
vRigid
	
	self widgetDo: [ :w | w vResizing: #rigid ]! !

!SpAbstractMorphicAdapter methodsFor: 'accessing' stamp: ''!
helpText
	
	^ self widget balloonText ! !

!SpAbstractMorphicAdapter methodsFor: 'emulating' stamp: ''!
sendRightClickEvent
	| evt |

	evt := MouseButtonEvent new 
		setType: nil 
		position: widget center 
		which: MouseButtonEvent yellowButton 
		buttons: MouseButtonEvent yellowButton 
		hand: nil 
		stamp: nil.

	(widget handlesMouseDown: evt) ifTrue: [
		widget mouseDown: evt.
		widget mouseUp: evt ]! !

!SpAbstractMorphicAdapter methodsFor: '*Spec2-Backend-Tests' stamp: ''!
typeForSearch: aString
	"emulate we are typing to perform a search"
	
	self type: aString! !

!SpAbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
dropEnabled

	^ self presenter dropEnabled! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
enabled: aBoolean

	self widget ifNotNil: [ :w | w enabled: aBoolean ]! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
removeSubWidgets
	
	self widgetDo: [ :w | w removeAllMorphs ]! !

!SpAbstractMorphicAdapter methodsFor: 'initialization' stamp: ''!
applyVisibility
	
	"It may happen that some presenters use generic adapters and they do not have an associated presenter.
	In that case, do not manage visibility..."
	self presenter ifNil: [ ^ self ].

	self widget visible: self presenter isVisible.
	self presenter whenVisibleChangedDo: [ :visible |
		self presenter isVisible
			ifTrue: [ self widget show ]
			ifFalse: [ self widget hide ] ]! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
borderColor

	^ self model borderColor! !

!SpAbstractMorphicAdapter methodsFor: 'emulating' stamp: ''!
keyPressed: keyCode shift: shiftBoolean meta: metaBoolean control: controlBoolean option: optionBoolean
	
	^ self 
		keyEvent: #keystroke
		code: keyCode asciiValue
		shift: shiftBoolean 
		meta: metaBoolean 
		control: controlBoolean 
		option: optionBoolean! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
setBalloonText: aString

	self widget ifNotNil: [ :w | 
		w setBalloonText: (
			aString ifNotNil: [ :theString | theString localizedForPresenter: self presenter ] ) ]
	! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installMouseLeaveEvent: anEvent to: aWidget

	aWidget 
		on: #mouseLeave
		send: #value:
		to: anEvent action! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
help

	^ self model help! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
hShrinkWrap
	
	self widgetDo: [ :w | w hResizing: #shrinkWrap ]! !

!SpAbstractMorphicAdapter methodsFor: 'accessing' stamp: ''!
application 

	^ self presenter application! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
disable
	
	self model enabled: false! !

!SpAbstractMorphicAdapter methodsFor: 'event installing' stamp: ''!
installKeyDownEvent: anEvent to: aWidget

	aWidget 
		on: #keyDown
		send: #value:
		to: anEvent action! !

!SpAbstractMorphicAdapter methodsFor: 'emulating' stamp: ''!
keyDown: keyCode shift: shiftBoolean meta: metaBoolean control: controlBoolean option: optionBoolean
	
	^ self 
		keyEvent: #keyDown
		code: keyCode 
		shift: shiftBoolean 
		meta: metaBoolean 
		control: controlBoolean 
		option: optionBoolean! !

!SpAbstractMorphicAdapter methodsFor: 'styling' stamp: ''!
applyStyle: morph
	"this will apply general properties to the built morph"

	self style applyTo: morph! !

!SpAbstractMorphicAdapter methodsFor: 'styling' stamp: ''!
style

	^ SpMorphStyle 
		fromStylesheet: self styleSheet 
		adapter: self! !

!SpAbstractMorphicAdapter methodsFor: 'protocol' stamp: ''!
when: anAnnouncement do: aBlock

	self widgetDo: [ :w | w announcer
		when: anAnnouncement do: aBlock ]! !

!SpAbstractMorphicAdapter methodsFor: 'focus handling' stamp: ''!
focusPrevious
	
	self presenter withWindowDo: [ :window | | presenters |
		presenters := window allPresentersInFocusOrder.
		(presenters 
			before: self presenter
			ifAbsent: [ presenters last ])
			takeKeyboardFocus ]! !

!SpAbstractMorphicAdapter methodsFor: 'styling' stamp: ''!
styleSheet

	^ self application styleSheet! !

!SpAbstractMorphicAdapter methodsFor: 'drag and drop' stamp: ''!
dropEnabled: aBoolean

	self widget ifNotNil: [ :w | w dropEnabled: aBoolean ]! !

!SpAbstractMorphicAdapter methodsFor: 'initialization' stamp: ''!
addFocusRotationKeyBindings

	self presenter canTakeKeyboardFocus ifFalse: [ ^ self ].

	self 
		bindKeyCombination: Character tab asKeyCombination 
		toAction: [ self focusNext ]. 
	self
		bindKeyCombination: Character tab shift asKeyCombination 
		toAction: [ self focusPrevious ]! !

!SpAbstractMorphicAdapter methodsFor: 'initialization' stamp: ''!
addKeyBindingsTo: aMorph

	self addFocusRotationKeyBindings.
	self presenter contextKeyBindings ifNotNil: [ :aCategory | 
		aCategory allEntries keymaps do: [ :each |
			self 
				bindKeyCombination: each shortcut 
				toAction: each action ] ]! !

!SpAbstractMorphicAdapter methodsFor: 'private' stamp: ''!
buildMenu: aMenuPresenter

	^ aMenuPresenter 
		owner: self presenter;
		buildWithSpec! !

!SpAbstractMorphicAdapter methodsFor: 'private' stamp: ''!
showMenu: aValuable
	| lastShownMenu |
	
	lastShownMenu := self buildMenu: aValuable value.
	lastShownMenu openWithSpec! !

!SpAbstractMorphicAdapter methodsFor: 'styling' stamp: ''!
removeStyle: aStyle
	"ignore style and just apply it again (the removed style will not be there)"
	self applyStyle: self widget! !

!SpAbstractMorphicAdapter class methodsFor: 'accessing' stamp: ''!
adaptingName
	"Override me if adapter will not follow the common pattern"

	"remove 'SpMorphic' part and *in general*, I will have the adapting name"

	^ (self name withoutPrefix: 'SpMorphic') asSymbol! !

!SpAbstractMorphicAdapter class methodsFor: 'accessing' stamp: ''!
allAdapters

	^ self allSubclasses! !

!SpAbstractMorphicListAdapter commentStamp: ''!
I am an abstract class with common behaviour for list and table adapters.
See my subclasses for more details.!
!SpAbstractMorphicListAdapter methodsFor: 'emulating' stamp: ''!
sendClickWithShiftEventToRow: aNumber
	| evt rowWidget |

	rowWidget := widget container submorphs at: aNumber.
	evt := MouseButtonEvent new 
		setType: nil 
		position: rowWidget bounds center 
		which: MouseButtonEvent redButton 
		buttons: (MouseButtonEvent redButton | 8 "shift = 8 mask")
		hand: self currentHand 
		stamp: nil.
	
	(widget handlesMouseDown: evt) ifTrue: [
		widget handleMouseDown: evt.
		widget handleMouseUp: evt ]! !

!SpAbstractMorphicListAdapter methodsFor: 'widget API' stamp: ''!
elementAt: index

	^ self widget dataSource elementAt: index! !

!SpAbstractMorphicListAdapter methodsFor: 'emulating' stamp: ''!
sendClickEventToRow: aNumber
	| evt rowWidget |

	rowWidget := widget container submorphs at: aNumber.
	evt := MouseButtonEvent new 
		setType: nil 
		position: rowWidget bounds center 
		which: MouseButtonEvent redButton 
		buttons: MouseButtonEvent redButton 
		hand: self currentHand 
		stamp: nil.
	
	(widget handlesMouseDown: evt) ifTrue: [
		widget handleMouseDown: evt.
		widget handleMouseUp: evt ]! !

!SpAbstractMorphicListAdapter methodsFor: 'drag and drop' stamp: ''!
acceptDroppingMorph: aTransferMorph event: anEvent 
	
	self presenter acceptDrop cull: (self 
		transferFrom: aTransferMorph 
		event: anEvent)! !

!SpAbstractMorphicListAdapter methodsFor: 'scrolling' stamp: ''!
configureScrolling
	self presenter verticalAlignment
		whenChangedDo: [ widget
				scrollToIndex: self presenter verticalAlignment desiredVisibleRow ].
			
	self presenter
		whenDisplayDo: [ widget
				scrollToIndex: self presenter verticalAlignment desiredVisibleRow.
			self scrollingChanged ].
		
	widget
		onAnnouncement: FTScrollingChanged
		send: #scrollingChanged
		to: self.! !

!SpAbstractMorphicListAdapter methodsFor: 'private' stamp: ''!
showContextMenu

	self widgetDo: [ :w |
		w showMenuForIndex: { self presenter selection selectedIndex. 1 } ]! !

!SpAbstractMorphicListAdapter methodsFor: 'private' stamp: ''!
triggerActivationAction

	self presenter doActivateAtIndex: self presenter selection selectedIndex! !

!SpAbstractMorphicListAdapter methodsFor: 'widget API' stamp: ''!
itemFilter
	^ self model itemFilter! !

!SpAbstractMorphicListAdapter methodsFor: 'drag and drop' stamp: ''!
transferFrom: aTransferMorph event: anEvent
	| rowAndColumn |

	rowAndColumn := self widget container rowAndColumnIndexContainingPoint: anEvent position.
	^ SpDragAndDropTransferToList new
		passenger: aTransferMorph passenger;
		index: (rowAndColumn first ifNil: [ 0 ]);
		yourself! !

!SpAbstractMorphicListAdapter methodsFor: 'scrolling' stamp: ''!
scrollingChanged
	widget container updateAllRows.
	self presenter verticalAlignment
		firstVisibleRowIndex: widget firstVisibleRowIndex;
		lastVisibleRowIndex: widget lastVisibleRowIndex! !

!SpAbstractMorphicListAdapter methodsFor: 'initialization' stamp: ''!
addActivationKeyBindings: aWidget

	self 
		bindKeyCombination: Character cr asKeyCombination
		toAction: [ self triggerActivationAction ]! !

!SpAbstractMorphicListAdapter methodsFor: 'initialization' stamp: ''!
addKeyBindingsTo: aWidget

	super addKeyBindingsTo: aWidget.
	self addContextMenuKeyBindings: aWidget.
	self addActivationKeyBindings: aWidget! !

!SpAbstractMorphicListAdapter methodsFor: 'factory' stamp: ''!
updateSearch

	self presenter isSearchEnabled
		ifTrue: [ widget enableSearch ]
		ifFalse: [ widget disableFunction ]! !

!SpAbstractMorphicListAdapter methodsFor: 'factory' stamp: ''!
updateItemFilterBlockWith: block

	^ block
		ifNotNil: [ 
			widget
				enableFilter: (SpFTSpecFilter block: block);
				explicitFunction ]
		ifNil: [ 
			self updateSearch ]! !

!SpAbstractMorphicListAdapter methodsFor: 'drag and drop' stamp: ''!
wantsDroppedMorph: aTransferMorph event: anEvent 
	
	^ self presenter wantsDrop cull: (self 
		transferFrom: aTransferMorph 
		event: anEvent)! !

!SpAbstractMorphicListAdapter class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpAbstractMorphicListAdapter! !

!SpAbstractMorphicWindowAdapter commentStamp: ''!
I am the adapter used to bridge window presenters and windows or worlds!
!SpAbstractMorphicWindowAdapter methodsFor: 'private' stamp: ''!
setToolbarTo: aMorph
	| newToolbarMorph toolbarPresenter |
	
	self model hasToolbar 
		ifFalse: [
			toolbarMorph ifNotNil: [ 
				aMorph removeMorph: toolbarMorph.
				toolbarMorph := nil.  ].
			^ self. ].
	
	toolbarPresenter := self presenter toolbar.
	newToolbarMorph := toolbarPresenter buildWithSpec.
	toolbarPresenter adapter applyStyle.
	newToolbarMorph
		hResizing: #spaceFill;
		vResizing: #rigid.
	
	"If we have a toolbar morph, we replace with the new one"
	toolbarMorph 
		ifNotNil: [ aMorph replaceSubmorph: toolbarMorph by: newToolbarMorph ]
		ifNil: [	
			menuMorph 
				ifNotNil: [ aMorph addMorph: newToolbarMorph after: menuMorph ]
				ifNil: [ aMorph addMorph: newToolbarMorph ] ].
		
	toolbarMorph := newToolbarMorph
! !

!SpAbstractMorphicWindowAdapter methodsFor: 'private' stamp: ''!
newContainerMorph

	^ Morph new
		color: Color transparent;
		layoutPolicy: TableLayout new;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		listDirection: #topToBottom;
		yourself! !

!SpAbstractMorphicWindowAdapter methodsFor: 'private' stamp: ''!
add: containerMorph toWindow: aSpecWindow

	aSpecWindow 
		addMorph: containerMorph 
		fullFrame: LayoutFrame identity! !

!SpAbstractMorphicWindowAdapter methodsFor: 'private' stamp: ''!
addContent: aMorph toWindow: aSpecWindow
	| containerMorph |
	
	containerMorph := self newContainerMorph.
	containerMorph layoutFrame: aMorph layoutFrame.

	"add all decorations (menu, toolbar and statusbar)"
	self model hasMenu ifTrue: [ self addMenuTo: containerMorph ].

	self setToolbarTo: containerMorph.

	"Register for changes in the toolbar"
	self model whenToolbarChangedDo: [ self setToolbarTo: containerMorph ].

	containerMorph addMorphBack: aMorph.
	aMorph
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	self model hasStatusBar ifTrue: [ self addStatusBarTo: containerMorph ].
	
	self add: containerMorph toWindow: aSpecWindow! !

!SpAbstractMorphicWindowAdapter methodsFor: 'private' stamp: ''!
addMenuTo: aMorph
	
	menuMorph := self model menu buildWithSpec.
	aMorph addMorphBack: menuMorph.	
	menuMorph
		hResizing: #spaceFill;
		vResizing: #rigid! !

!SpAbstractMorphicWindowAdapter methodsFor: 'private' stamp: ''!
addStatusBarTo: aMorph

	| statusBarMorph |
	statusBarMorph := self model statusBar buildWithSpec.
	aMorph addMorphBack: statusBarMorph.	
	statusBarMorph
		hResizing: #spaceFill;
		vResizing: #rigid! !

!SpAbstractMorphicWindowAdapter class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self name = #SpAbstractMorphicWindowAdapter! !

!SpAbstractPort commentStamp: ''!
I'm a base port.!
!SpAbstractPort methodsFor: 'testing' stamp: ''!
isInput 

	^ false! !

!SpAbstractPort methodsFor: 'accessing' stamp: ''!
delegateTo: aPresenter

	delegation := aPresenter! !

!SpAbstractPort methodsFor: 'accessing' stamp: ''!
presenter: aPresenter

	presenter := aPresenter! !

!SpAbstractPort methodsFor: 'accessing' stamp: ''!
presenter 

	^ presenter! !

!SpAbstractPort methodsFor: 'testing' stamp: ''!
isOutput

	^ false! !

!SpAbstractPort methodsFor: 'accessing' stamp: ''!
name

	^ name ifNil: [ self class portName ]! !

!SpAbstractPort methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!SpAbstractPort methodsFor: 'accessing' stamp: ''!
destinationPresenterOrPort

	^ delegation 
		ifNotNil: [ delegation value ]
		ifNil: [ presenter ]! !

!SpAbstractPort class methodsFor: 'instance creation' stamp: ''!
newDelegate: aBlock 

	^ self new 
		delegateTo: aBlock;
		yourself! !

!SpAbstractPort class methodsFor: 'instance creation' stamp: ''!
newPresenter: aPresenter

	^ self new 
		presenter: aPresenter;
		yourself! !

!SpAbstractPort class methodsFor: 'instance creation' stamp: ''!
newName: aName

	^ self new 
		name: aName;
		yourself! !

!SpAbstractPort class methodsFor: 'testing' stamp: ''!
isAbstract 
	^self name = #SpAbstractPort! !

!SpAbstractPort class methodsFor: 'instance creation' stamp: ''!
newName: aName delegate: aBlock 

	^ self new 
		name: aName;
		delegateTo: aBlock;
		yourself! !

!SpAbstractPort class methodsFor: 'accessing' stamp: ''!
portName

	^ self subclassResponsibility! !

!SpAbstractPresenter commentStamp: ''!
A base for all presenters. 
I define common behaviors for widget presenters and also for composable presenters (the ones an user regularly uses).

From a Spec2 users, my key methods are 
- `SpAbstractPresenter>>#application` to get access to the application into which I play.
- `SpAbstractPresenter>>#initializeDialogWindow:` defines the default buttons that decorated a dialog. Subclasses can override it to be able to customize how dialog get decorated.
- `SpAbstractPresenter>>#initializeWindow:` is a hook to define the window title and extend.
- `SpAbstractPresenter>>#openWithSpec` to open the receiver with the default layout. 
- `SpAbstractPresenter>>#openWithSpec: aSelector` to open the receiver with the specified layout.!
!SpAbstractPresenter methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpAbstractPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultInputPort

	^ nil! !

!SpAbstractPresenter methodsFor: 'testing' stamp: ''!
hasAdapter

	^ adapter notNil! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
asBlockedDialogWindow

	^ self defaultBlockedDialogWindowPresenterClass presenter: self! !

!SpAbstractPresenter methodsFor: 'testing' stamp: ''!
isPresenter

	^ true! !

!SpAbstractPresenter methodsFor: 'private - utilities' stamp: ''!
withWidgetDo: aValuable
	"a convenience method to avoid verify by nil all the time"

	^ self adapter ifNotNil: aValuable! !

!SpAbstractPresenter methodsFor: 'private - utilities' stamp: ''!
forceUpdateSlot: aSymbol

	^ (self rawValueHolderNamed: aSymbol) valueChanged! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
root
	"Answer root presenter of this composition."
	
	^ self owner 
		ifNotNil: [ :presenter | presenter root ]
		ifNil: [ self ]! !

!SpAbstractPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultOutputPort

	^ nil! !

!SpAbstractPresenter methodsFor: 'building' stamp: ''!
buildWithSpec: aSpec
	"Build the widget using the spec name provided as argument"
	
	^ self buildWithSpecLayout: (self retrieveSpec: aSpec)! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
eventHandler
	"Answers an generic event handler where you can make your presenter listen to specific 
	low-level events. 
	Example of usage: 
	    myPresenter eventHandler whenLostFocusDo: [ ... ]
	
	WARNING: Now all events are available to all presenters (for example, presenters who can't
	take focus will not respong to focus events even if you register them)."
	
	^ eventHandler ifNil: [ eventHandler := SpEventHandler for: self ]! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
adapter: anAdapter

	"if there existed an adapter already, we need to unsubscribe it to avoid memory leaks"
	adapter ifNotNil: [
		self removeDependent: adapter.
		adapter unsubscribe ].
	
	adapter := anAdapter! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
owner

	^ owner! !

!SpAbstractPresenter methodsFor: 'TOREMOVE' stamp: ''!
autoAccept: aBoolean! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
needRebuild: aBoolean

	needRebuild := aBoolean! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
spec
	self flag: #TODO. "This needs to be removed, but there is a problem with the interpreter.
	(it will be solved as soon as the interpreter is removed :P)"
	
	^ self adapter! !

!SpAbstractPresenter methodsFor: 'building' stamp: ''!
buildWithSpec
	"Build the widget using the default spec"
	
	^ self buildWithSpecLayout: self retrieveDefaultSpec! !

!SpAbstractPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
transmitTo: aPresenter transform: aValuable postTransmission: postValuable
	
	^ self defaultOutputPort
		transmitTo: aPresenter defaultInputPort
		transform: aValuable 
		postTransmission: postValuable! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
openModalWithSpec

	^ self asModalWindow open! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
adapter

	^ adapter! !

!SpAbstractPresenter methodsFor: 'initialization' stamp: ''!
initialize 

	self class initializeSlots: self.
	super initialize.
	needRebuild := true! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
window
	"Answer window containing this composition."
	
	^ self hasWindow
		ifTrue: [ self root ]
		ifFalse: [ nil ]! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
asWindow

	^ self defaultWindowPresenterClass presenter: self! !

!SpAbstractPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
transmitDo: aBlock transform: transformBlock
	
	^ self defaultOutputPort
		transmitDo: aBlock 
		transform: transformBlock! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
openModalWithSpec: aSelector

	^ self asModalWindow openWith: (self retrieveSpec: aSelector)! !

!SpAbstractPresenter methodsFor: 'private - showing' stamp: ''!
defaultDialogWindowPresenterClass
		
	^ self application defaultDialogWindowPresenterClass! !

!SpAbstractPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter
	"Used to initialize the model in the case of the use into a dialog window.
	 Override this to set buttons other than the default (Ok, Cancel)."
	
	aDialogWindowPresenter
		addButton: 'Ok' do: [ :presenter | 
			presenter triggerOkAction.
			presenter close ];
		addButton: 'Cancel' do: [ :presenter | 
			presenter triggerCancelAction.
			presenter close ]	! !

!SpAbstractPresenter methodsFor: 'testing' stamp: ''!
hasWindow

	^ self root isWindowPresenter! !

!SpAbstractPresenter methodsFor: 'private - building' stamp: ''!
retrieveDefaultSpec

	^ self retrieveSpec: self defaultSpecSelector! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
openBlockedDialogWithSpec: aSelector
	"Build the widget using the default spec and display it into a dialog. 
	 Beware: this way will not create a real modal in the sense that the user will keep the focus on other windows. If you want to make the user focus on your dialog only you should use #openDialogAsModalWithSpec: instead."

	^ self asBlockedDialogWindow openWith: (self retrieveSpec: aSelector)! !

!SpAbstractPresenter methodsFor: 'building' stamp: ''!
buildWithSpecLayout: aSpecLayout
	"Build the widget using the spec name provided as argument"

	^ (self buildAdapterWithSpecLayout: aSpecLayout) widget! !

!SpAbstractPresenter methodsFor: 'private - utilities' stamp: ''!
withAdapterDo: aValuable
	"a convenience method to avoid verify by nil all the time"
	
	^ self adapter ifNotNil: aValuable! !

!SpAbstractPresenter methodsFor: 'private - showing' stamp: ''!
defaultBlockedDialogWindowPresenterClass

	^ self application defaultBlockedDialogWindowPresenterClass! !

!SpAbstractPresenter methodsFor: 'private - utilities' stamp: ''!
withWindowDo: aValuable

	self hasWindow ifFalse: [ ^ self ].
	"Since Presenter has window, root = window"
	aValuable value: self root! !

!SpAbstractPresenter methodsFor: 'testing' stamp: ''!
isWindowPresenter

	^ false! !

!SpAbstractPresenter methodsFor: 'private - utilities' stamp: ''!
rawValueHolderNamed: aSymbol

	^ (self class slotNamed: aSymbol) rawRead: self.! !

!SpAbstractPresenter methodsFor: 'private - showing' stamp: ''!
defaultModalWindowPresenterClass
		
	^ self application defaultModalWindowPresenterClass! !

!SpAbstractPresenter methodsFor: 'private - showing' stamp: ''!
defaultWindowPresenterClass 

	^ self application defaultWindowPresenterClass! !

!SpAbstractPresenter methodsFor: 'testing' stamp: ''!
hasOwner

	^ self owner notNil! !

!SpAbstractPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
transmitTo: aPresenter transform: aValuable
	
	^ self defaultOutputPort
		transmitTo: aPresenter defaultInputPort
		transform: aValuable! !

!SpAbstractPresenter methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpAbstractPresenter methodsFor: 'testing' stamp: ''!
hasEventHandler

	^ eventHandler notNil and: [ eventHandler hasEvents ]! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
openBlockedDialogWithSpec
	"Build the widget using the default spec and display it into a dialog. 
	 Beware: this way will not create a real modal in the sense that the user will keep the focus on other windows. If you want to make the user focus on your dialog only you should use #openModalWithSpec instead."

	"A typical use of openBlockedDialogWithSpec is to configure it with callbackscallbacks: 
open
	^ self openBlockedDialogWithSpec
		okAction: [ self accept ];
		cancelAction: [ self cancel ];
		yourself
"

	^ self asBlockedDialogWindow open! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
openDialogWithSpec
	"Build the widget using the default spec and display it into a dialog. 
	 Beware: this way will not create a real modal in the sense that the user will keep the focus on other windows. If you want to make the user focus on your dialog only you should use #openModalWithSpec instead."
	
	"A typical use of openDialogWithSpec is to configure it with callbackscallbacks: 

open
	^ self openDialogWithSpec
		okAction: [ self accept ];
		cancelAction: [ self cancel ];
		yourself
"

	^ self asDialogWindow open! !

!SpAbstractPresenter methodsFor: 'private - showing' stamp: ''!
openWithSpecLayout: aSpecLayout

	^ self asWindow openWith: aSpecLayout! !

!SpAbstractPresenter methodsFor: 'subscription' stamp: ''!
unsubscribe: anObject
	"Observable slots keep subscriptions to them that can leak if not removed in certain cases."
	| observableSlots |
	
	observableSlots := self class allSlots 
		select: [ :aSlot | aSlot isObservableSlot ].

	observableSlots do: [ :aSlot |
		| slotValue | 
		slotValue := aSlot rawRead: self.
		slotValue ifNotNil: [ 
			slotValue unsubscribe: anObject ] ]! !

!SpAbstractPresenter methodsFor: 'private - building' stamp: ''!
retrieveSpec: aSelector
	| layout |

	layout := self class perform: aSelector.
	layout isSpLayout ifTrue: [ 
		layout selector: aSelector ].
	^ layout! !

!SpAbstractPresenter methodsFor: 'private - building' stamp: ''!
defaultSpecSelector
	(Pragma allNamed: #spec: from: self class class to: SpAbstractPresenter class class) detect: [ :each | (each argumentAt: 1) = #default ] ifFound: [ :pragma | ^ pragma methodSelector ].

	^ (Pragma allNamed: #spec from: self class class to: SpAbstractPresenter class class)
		ifEmpty: [ #defaultSpec ]
		ifNotEmpty: [ :pragmas | pragmas size = 1 ifTrue: [ pragmas first methodSelector ] ifFalse: [ #defaultSpec ] ]! !

!SpAbstractPresenter methodsFor: 'updating' stamp: ''!
update: aParameter

	self changed: aParameter! !

!SpAbstractPresenter methodsFor: 'private - building' stamp: ''!
basicBuildAdapterWithSpecLayout: aSpecLayout
	"I assume the SpecBindings is well defined"
	
	self announcer announce: (SpWidgetWillBeBuilt model: self).

	self adapter: (aSpecLayout asSpLayout 
		buildAdapterFor: self 
		bindings: SpBindings value).

	self announcer announce: (SpWidgetBuilt 
		model: self 
		widget: adapter widget).
	
	^ adapter! !

!SpAbstractPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
transmitTo: aPresenter postTransmission: postValuable
	
	^ self defaultOutputPort
		transmitTo: aPresenter defaultInputPort
		postTransmission: postValuable! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
enabled: aBoolean 

	^ self subclassResponsibility! !

!SpAbstractPresenter methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpAbstractPresenter methodsFor: 'testing' stamp: ''!
hasAnnouncer

	^ announcer notNil! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
openWithSpec: aSelector

	^ self asWindow openWith: (self retrieveSpec: aSelector)! !

!SpAbstractPresenter methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
asDialogWindow

	^ self defaultDialogWindowPresenterClass presenter: self! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
application
	"Answer application owner of this composition.
	 The tree for a composition starts always with an application, which is responsible of 
	 providing all resources the presenter needs. "

	^ self owner application! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
openDialogWithSpec: aSelector
	"Build the widget using the default spec and display it into a dialog. 
	 Beware: this way will not create a real modal in the sense that the user will 
	 keep the focus on other windows. If you want to make the user focus on your 
	 dialog only you should use #openModalWithSpec: instead."
	
	^ self asDialogWindow openWith: (self retrieveSpec: aSelector)! !

!SpAbstractPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
transmitTo: aPresenter
	
	^ self defaultOutputPort transmitTo: aPresenter defaultInputPort! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
asModalWindow

	^ self defaultModalWindowPresenterClass presenter: self! !

!SpAbstractPresenter methodsFor: 'testing' stamp: ''!
isMenuPresenter

	^ false! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
needRebuild

	^ needRebuild! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
owner: aPresenter

	owner := aPresenter! !

!SpAbstractPresenter methodsFor: 'showing' stamp: ''!
openWithSpec

	^ self asWindow open! !

!SpAbstractPresenter methodsFor: 'accessing' stamp: ''!
spec: anAdapter
	"This is a remaining of other times... spec accesor in fact contains an adapter"
	
	self flag: #TODO. "Same as #spec, it needs to go"
	self adapter: anAdapter! !

!SpAbstractPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	"Override this to set window values before opening. 
	 You may want to add a menu, a toolbar or a statusbar"

	self flag: #TODO. "Does presenters needs to understand this? (they do if we 
	want to do ButtonPresenter new openWithSpec)."! !

!SpAbstractPresenter methodsFor: 'private - building' stamp: ''!
buildAdapterWithSpecLayout: aSpecLayout
	"Build the adapter using the spec name provided as argument"
	
	^ SpBindings 
		value: self application adapterBindings
		during: [ self basicBuildAdapterWithSpecLayout: aSpecLayout ]! !

!SpAbstractPresenter methodsFor: 'events' stamp: ''!
whenWillBeBuiltDo: aBlock

	self announcer 
		when: SpWidgetWillBeBuilt
		do: aBlock! !

!SpAbstractPresenter methodsFor: 'events' stamp: ''!
whenBuiltDo: aBlock

	self announcer 
		when: SpWidgetBuilt
		do: aBlock! !

!SpAbstractPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
transmitDo: aBlock

	^ self defaultOutputPort transmitDo: aBlock! !

!SpAbstractPresenter class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpAbstractPresenter class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpAbstractPresenter class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpAbstractPresenter class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpAbstractPresenter class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpAbstractPresenter class methodsFor: 'TOREMOVE' stamp: ''!
buttonHeight

	^ self defaultFont height + 12! !

!SpAbstractPresenter class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpAbstractPresenter class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpAbstractPresenter class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpAbstractPresenter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpAbstractPresenter class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpAbstractPresenter class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpAbstractPresenter class methodsFor: 'accessing' stamp: ''!
toolName
	"The tool name can be used in some places such as the About window's title."
	
	^ self name! !

!SpAbstractPresenter class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpAbstractPresenter class methodsFor: 'TOREMOVE' stamp: ''!
toolbarHeight

	^ self defaultFont height + 12! !

!SpAbstractPresenter class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpAbstractPresenter class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpAbstractPresenter! !

!SpAbstractPresenter class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpAbstractPresenter class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpAbstractPresenter class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpAbstractPresenter class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpAbstractPresenter class methodsFor: 'TOREMOVE' stamp: ''!
inputTextHeight

	^ self defaultFont height + 12! !

!SpAbstractPresenter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpAbstractPresenter class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpAbstractPresenter class methodsFor: 'as yet unclassified' stamp: ''!
systemIconName

	^ #smallWindow! !

!SpAbstractPresenter class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpAbstractPresenter class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpAbstractPresenter class methodsFor: 'TOREMOVE' stamp: ''!
labelHeight

	^ self defaultFont height! !

!SpAbstractPresenter class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpAbstractPresenter class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpAbstractPresenter class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpAbstractPresenter class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpAbstractPresenter class methodsFor: 'TOREMOVE' stamp: ''!
buttonWidth

	^ (self defaultFont widthOfString: 'eilwp') + 44! !

!SpAbstractPresenter class methodsFor: 'TOREMOVE' stamp: ''!
defaultFont 

	self flag: #TODO. "This is so wrong. All this needs to be in the theme and in the 
	application"
		
	self class environment at: #StandardFonts ifPresent: [ :standardFonts | 
		^ standardFonts defaultFont ].
	
	^ LogicalFont
		familyName: 'Source Sans Pro'
		pointSize: 10
		stretchValue: 5
		weightValue: 400
		slantValue: 0
! !

!SpAbstractPresenter class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpAbstractPresenter class methodsFor: 'instance creation' stamp: ''!
owner: anOwningPresenter

	^ self basicNew
		owner: anOwningPresenter;
		initialize;
		yourself! !

!SpAbstractPresenter class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpAbstractPresenter class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpAbstractPresenter class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpAbstractSearchTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	presenter items: #(10 20 30).! !

!SpAbstractSearchTest methodsFor: 'accessing' stamp: ''!
selectedIndex

	^ self presenter selection selectedIndex! !

!SpAbstractSearchTest methodsFor: 'accessing' stamp: ''!
selectIndex: index

	self presenter selection selectIndex: index	! !

!SpAbstractSearchTest methodsFor: 'tests' stamp: ''!
testTypePerformsSearch

	self selectIndex: 1. "10"
	self adapter typeForSearch: '2'. 
	self assert: self selectedIndex equals: 2 "20"! !

!SpAbstractSearchTest methodsFor: 'tests' stamp: ''!
testSearchWithFunction

	self presenter searchMatching: [ :item :textToSearch | 
		(item - 1) asString beginsWith: textToSearch ].
	self selectIndex: 1. "10"
	self adapter typeForSearch: '2'.
	self deny: self selectedIndex equals: 2.
	self adapter typeForSearch: '2'. 
	self assert: self selectedIndex equals: 3 "20"! !

!SpAbstractSearchTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self = SpAbstractSearchTest! !

!SpAbstractSelectionMode commentStamp: ''!
A base for selection modes. 
`SpAbstractSelectionMode` children will define selection styles (single, multiple) and realise the different selecting logic. 
!
!SpAbstractSelectionMode methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpAbstractSelectionMode methodsFor: 'testing' stamp: ''!
isEmpty
	"Answer true if there are no selections"
	
	^ self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'private' stamp: ''!
transferSubscriptionsTo: anotherSelectionMode

	self selectionHolder transferSubscriptionsTo: anotherSelectionMode selectionHolder! !

!SpAbstractSelectionMode methodsFor: 'private' stamp: ''!
indexOfItem: anItem
	
	^ self model
		indexOf: anItem
		ifAbsent: [ 0 ].! !

!SpAbstractSelectionMode methodsFor: 'testing' stamp: ''!
includesItem: anItem
	"Answer true if selection includes element `anItem`."

	self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
selectIndex: anIndex
	"Select item at position `anInteger`."
	
	self basicSelectIndex: (self withinRangeIndex: anIndex)! !

!SpAbstractSelectionMode methodsFor: 'testing' stamp: ''!
includesIndex: anIndex
	"Answer true if selection includes element at index `anIndex`."

	self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpAbstractSelectionMode methodsFor: 'private' stamp: ''!
basicSelectIndex: indexToSelect

	self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'private' stamp: ''!
selectionHolder
	^ self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'subscription' stamp: ''!
unsubscribe: anObject 

	(self observablePropertyNamed: #selectedIndexes) unsubscribe: anObject.
! !

!SpAbstractSelectionMode methodsFor: 'api - events' stamp: ''!
whenChangedDo: aBlock 
	"Inform when selection has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
	
	self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
selectAll
	"Select all items."

	^ self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedIndexes
	"Answer a collection with indexes of all selected items."

	self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: '*Spec2-Transmission' stamp: ''!
transmission 
	self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
unselectItem: anObject
	"Unselect item `anObject`."
	
	self unselectIndex: (self indexOfItem: anObject)! !

!SpAbstractSelectionMode methodsFor: 'api' stamp: ''!
model
	"Answer the model used to act the selection.
	 See also `SpAbstractListPresenter>>#model`."

	^ widget model! !

!SpAbstractSelectionMode methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
selectItems: aCollection
	"Select items included in `aCollection` if they are included in model list."
	
	self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
selectIndexes: aCollectionOfIndexes
	"Select items at positions included in `aCollectionOfIndexes`."

	self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'initialization' stamp: ''!
initialize
	self class initializeSlots: self.
	super initialize! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedIndex

	^ self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedItem
	"Answer selected item"

	^ self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'accessing' stamp: ''!
widget: anObject
	widget := anObject! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
unselectIndex: anInteger 
	"Unselect item at position `anInteger`."
	
	self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'accessing' stamp: ''!
widget
	"Returns the presenter"
	^ widget! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
unselectAll
	"Remove all selections."
	
	self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedItems
	"Answer a collection with all selected items."

	^ self subclassResponsibility! !

!SpAbstractSelectionMode methodsFor: 'api - selection' stamp: ''!
selectItem: anItem
	"Select `anItem` if it is included in model list."
	
	self basicSelectIndex: (self indexOfItem: anItem)! !

!SpAbstractSelectionMode methodsFor: 'private' stamp: ''!
withinRangeIndex: anIndex
	
	| indexToSelect |
	indexToSelect := anIndex.
	self model
		at: indexToSelect
		ifAbsent: [ indexToSelect := 0 ].
	^ indexToSelect! !

!SpAbstractSelectionMode methodsFor: 'testing' stamp: ''!
isMultipleSelection
	"Answer true if this is a multiple selection mode."
	
	^ false! !

!SpAbstractSelectionMode class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpAbstractSelectionMode class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpAbstractSelectionMode class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpAbstractSelectionMode class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpAbstractSelectionMode class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpAbstractSelectionMode class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpAbstractSelectionMode class methodsFor: 'documentation' stamp: ''!
addDocumentSectionHierarchy: aBuilder
	
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Hierarchy' ] withLevel: 2.
	SpDocumentHierarchyBuilder new
		fromClass: SpAbstractSelectionMode;
		builder: aBuilder;
		filter: [ :eachClass | eachClass package packageName beginsWith: 'Spec2-' ];
		buildFor: self! !

!SpAbstractSelectionMode class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpAbstractSelectionMode class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpAbstractSelectionMode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpAbstractSelectionMode class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpAbstractSelectionMode class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpAbstractSelectionMode class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpAbstractSelectionMode class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpAbstractSelectionMode class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpAbstractSelectionMode class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpAbstractSelectionMode class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpAbstractSelectionMode class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpAbstractSelectionMode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpAbstractSelectionMode class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpAbstractSelectionMode class methodsFor: 'documentation' stamp: ''!
documentSections
		
	^ OrderedDictionary newFromPairs: {
		'API Methods'. self methods select: [ :each | each protocol = #'api' ].
		'API Selection Methods'. self methods select: [ :each | each protocol = #'api - selection' ].
		'Testing Methods'. self methods select: [ :each | each protocol = #'testing' ].
		'Events'. self methods select: [ :each | each protocol = #'api - events' ].
	}! !

!SpAbstractSelectionMode class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpAbstractSelectionMode class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpAbstractSelectionMode class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpAbstractSelectionMode class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpAbstractSelectionMode class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpAbstractSelectionMode class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpAbstractSelectionMode class methodsFor: '*Spec2-Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	super buildMicroDownUsing: aBuilder withComment: aString.
	"Sections"
	self documentSections keysAndValuesDo: [ :label :methods |
		SpAbstractWidgetPresenter 
			addDocumentSection: aBuilder 
			label: label 
			methods: methods ].
	"Hierarchy"
	self addDocumentSectionHierarchy: aBuilder.
! !

!SpAbstractSelectionMode class methodsFor: 'instance creation' stamp: ''!
on: aWidget

	^ self new
		widget: aWidget;
		yourself! !

!SpAbstractSelectionMode class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpAbstractSelectionMode class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpAbstractSelectionMode class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpAbstractSelectionMode class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpAbstractSelectionModeTest methodsFor: 'running' stamp: ''!
tearDown 

	presenter delete.
	super tearDown! !

!SpAbstractSelectionModeTest methodsFor: 'tests' stamp: ''!
testSubscriptionsAreTransfered
	self subclassResponsibility! !

!SpAbstractSelectionModeTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	presenter := SpListPresenter new.
	presenter items: (1 to: 10)! !

!SpAbstractSelectionModeTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!SpAbstractSelectionModeTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpAbstractSelectionModeTest! !

!SpAbstractTextAdapterTest methodsFor: 'tests' stamp: ''!
testSelectionIntervalNilUnselectsEverything

	presenter text: 'test'.
	presenter selectionInterval: nil.
	
	self openInstance.
	
	self 
		assert: presenter adapter selectionInterval
		equals: (1 to: 0)! !

!SpAbstractTextAdapterTest methodsFor: 'tests' stamp: ''!
testBeNotEditableAfterOpenWorks

	self openInstance.
	presenter beNotEditable.
	self assert: presenter text isEmpty.
	presenter typeByChar: 'x'.
	self assert: presenter text isEmpty	! !

!SpAbstractTextAdapterTest methodsFor: 'tests' stamp: ''!
testChangePlaceholderTextUpdatesPresenter
	presenter placeholder: 'some text'.
	self assert: self adapter placeHolderText equals: 'some text'! !

!SpAbstractTextAdapterTest methodsFor: 'tests' stamp: ''!
testSelectionInterval

	presenter text: 'test'.
	presenter selectionInterval: (1 to: 4).
	
	self openInstance.
	
	self 
		assert: presenter adapter selectionInterval
		equals: (1 to: 4)! !

!SpAbstractTextAdapterTest methodsFor: 'tests' stamp: ''!
testPresenterPlaceholderIsSetInWidget
	presenter placeholder: 'something'.
	self assert: self adapter placeHolderText equals: 'something'! !

!SpAbstractTextAdapterTest methodsFor: 'tests' stamp: ''!
testBeNotEditableWorks

	presenter beNotEditable.
	
	self assert: presenter text isEmpty.
	presenter typeByChar: 'x'.
	self assert: presenter text isEmpty.
	
	"now open and try to type (since is different)"
	self openInstance.
	presenter typeByChar: 'x'.
	self assert: presenter text isEmpty! !

!SpAbstractTextAdapterTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!SpAbstractTextAdapterTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpAbstractTextAdapterTest! !

!SpAbstractTextPresenter commentStamp: ''!
A base for text presenters, it defines basic functionality common to all texts.
!
!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
readSelectionBlock: aBlock
	"Set the block used to calculate the text selection"

	^ readSelection := aBlock! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
insertAndSelectAfterCurrentSelection: aString
	"Insert `aString` at the end of current selection and select the inserted text."
	| selectionInterval |

	self flag: #TODO. "Does this really has to be part of the text api?"
	selectionInterval := self selectionInterval.
	self insert: aString at: selectionInterval last.
	self selectionInterval: (selectionInterval last + 1 to: selectionInterval last + aString size)! !

!SpAbstractTextPresenter methodsFor: 'api - events' stamp: ''!
whenTextChangedDo: aBlock
	"Inform when text has been changed (a character has been enter or `SpAbstractTextPresenter>>text:` has been called)
	 `aBlock` receives two optional arguments 
	 - new text
	 - old text"

	self property: #text whenChangedDo: aBlock! !

!SpAbstractTextPresenter methodsFor: '*NewTools-SpTextPresenterDecorators' stamp: ''!
addTextSegmentDecoration: aDecorationSegment

	self withAdapterPerformOrDefer: [ :anAdapter | 
		anAdapter addTextSegmentDecoration: aDecorationSegment ]! !

!SpAbstractTextPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultInputPort

	^ self inputTextPort! !

!SpAbstractTextPresenter methodsFor: 'localization' stamp: ''!
localeChanged

	super localeChanged.
	self forceUpdateSlot: #placeholder
	! !

!SpAbstractTextPresenter methodsFor: 'api - events' stamp: ''!
whenSubmitDo: aBlock
	"Inform a 'submit' event has been triggered. 
	 It will react when user presses <meta+s> key (this is for historical reasons) and (in case of text fields) with <cr>.
	 `aBlock` receives one argument (the submited text)"

	self subclassResponsibility! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
hasEditingConflicts: aBoolean
	"Set if the text zone has editing conflicts"
	
	^ self changed: #hasEditingConflicts: with: { aBoolean }! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
hasUnacceptedEdits
	"Return if the text zone has unaccepted edits (orange corner)"

	^ hasUnacceptedEdits! !

!SpAbstractTextPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
inputTextPort 

	^ SpTextPort newPresenter: self! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
hasUnacceptedEdits: aBoolean
	"Return if the text zone has unaccepted edits (orange corner)"

	hasUnacceptedEdits := aBoolean! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
wantsVisualFeedback: aBoolean
	wantsVisualFeedback := aBoolean! !

!SpAbstractTextPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultOutputPort

	^ self outputTextChangedPort! !

!SpAbstractTextPresenter methodsFor: 'initialization' stamp: ''!
registerEvents

	self whenTextChangedDo: [ self changed: #getText ].
	self whenReadSelectionIsChangedDo: [ self changed: #readSelection ].
	self property: #hasUnacceptedEdits whenChangedDo: [ :bool | self changed: #setHasUnacceptedEdits: with: {bool} ].
	self property: #selection whenChangedDo: [ :block | self changed: #setSelectionFromModel: with: {block value} ].
	self property: #wantsVisualFeedback whenChangedDo: [ :bool | self changed: #changed with: #() ].
	self property: #askBeforeDiscardingEdits whenChangedDo: [ :bool | self changed: #askBeforeDiscardingEdits: with: {bool} ]! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
contextMenu: aValuableOrMenuPresenter
	"Set the context menu.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	contextMenu := aValuableOrMenuPresenter! !

!SpAbstractTextPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
outputTextChangedPort

	^ SpTextChangedPort newPresenter: self! !

!SpAbstractTextPresenter methodsFor: 'private' stamp: ''!
rawSelection: anInterval

	self property: #selection rawValue: anInterval! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
askBeforeDiscardingEdits
	^ askBeforeDiscardingEdits! !

!SpAbstractTextPresenter methodsFor: 'simulating' stamp: ''!
typeByChar: aString 
	"For simulation: Do as if we type the given string"
	self withAdapterDo: [ :anAdapter | 
		anAdapter typeByChar: aString.
		^ self ].

	self isEditable ifFalse: [ ^ self ].
	aString do: [ :each | 
		self text: (self text ifNil: [ '' ]), (each asString) ]! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
askBeforeDiscardingEdits: aBoolean
	askBeforeDiscardingEdits := aBoolean! !

!SpAbstractTextPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	text := ''.
	placeholder := ''.
	actionToPerform := [ :txt |  ].
	readSelection := [ selection ].
	hasUnacceptedEdits := false.
	selection := 1 to: 0.
	wantsVisualFeedback := true.
	askBeforeDiscardingEdits := true.

	self registerEvents! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
text: aString
	"Set the text of the text presenter"

	text := aString! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
selectedClassOrMetaClass

	^ self behavior! !

!SpAbstractTextPresenter methodsFor: 'api - selection' stamp: ''!
selectedText 
	"Answer the text contained in selection interval 
	(See `SpAbstractTextPresenter>>#selectionInterval`)"
	| selectionInterval |
	
	selectionInterval := self selectionInterval.
	selectionInterval ifEmpty: [ ^ '' ].
	
	^ self text asString
		copyFrom: selectionInterval first 
		to: selectionInterval last! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
isForSmalltalkCode: aBoolean
	
	"self 
		deprecated: 'The forCode functionality has moved to TextCodePresenter, please use it instead TextPresenter.' 
		on: '2019-04-05' 
		in: #Pharo8"! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
notify: errorMessage at: position in: sourceCode

	self changed: #notify:at:in: with: { errorMessage . position . sourceCode }! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
clearUndoManager
	"Clear undo manager contents"

	self flag: #TODO. "Maybe remove?"
	self withAdapterDo: [ :anAdapter | 
		anAdapter clearUndoManager ]! !

!SpAbstractTextPresenter methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
pendingText
	"Return the current pending text"

	self withAdapterDo: [ :anAdapter | 
		anAdapter isMorphicAdapter ifTrue: [ 
			^ anAdapter pendingText ] ].
	^ self getText! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
eventKeyStrokesForPreviousFocus
	"String describing the keystroke to perform to jump to the previous widget"

	^ { Character arrowLeft command ctrl asKeyCombination }! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
cursorPositionIndex
	"Answer the index (position in the string) of the cursor (or nil if the cursor is nowhere)"
	
	^ self withAdapterDo: [ :anAdapter |
		anAdapter cursorPositionIndex ]! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
isForSmalltalkCode

	"self 
		deprecated: 'The forCode functionality has moved to TextCodePresenter, please use it instead TextPresenter.' 
		on: '2019-04-05' 
		in: #Pharo8"

	^ false! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
hasEditingConflicts
	"Return if the text zone has editing conflicts"

	^ self widget 
		ifNil: [ false ]
		ifNotNil: [:w | w hasEditingConflicts ]! !

!SpAbstractTextPresenter methodsFor: 'api - selection' stamp: ''!
selectLine
	"Select line where the cursor is placed at this moment and answer the resulting selection 
	(See `SpAbstractTextPresenter>>#selectionInterval`). "

	self withAdapterDo: [ :anAdapter | anAdapter selectLine ].
	^ self selectionInterval! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
placeholder: aString
	"Set the place holder (also known as ghost text) for this text component."

	placeholder := aString! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
cursorPositionIndex: index
	"Set cursor position index. 
	 This method will place the cursor in the text index position requested."

 	^ self withAdapterDo: [ :anAdapter | anAdapter cursorPositionIndex: index ]! !

!SpAbstractTextPresenter methodsFor: 'testing' stamp: ''!
isEditable

	^ self subclassResponsibility! !

!SpAbstractTextPresenter methodsFor: 'simulating' stamp: ''!
type: aString 
	"For simulation: Do as if we type the given string"
	self withAdapterDo: [ :anAdapter | 
		anAdapter type: aString.
		^ self ].

	self text: aString! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
insert: aString at: positionIndex
	"insert `aString` into the text contents at `positionIndex`"
	
	self withAdapterDo: [ :anAdapter |
		anAdapter insert: aString at: positionIndex ]! !

!SpAbstractTextPresenter methodsFor: 'api - selection' stamp: ''!
selectAll
	"Select all text"
	
	self changed: #selectAll with: #()! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
clearContent
	"Clear current presenter contents"

	self text: ''! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
enabled: aBoolean
	"Set if the widget is enabled (clickable or focusable)"

	super enabled: aBoolean.
	self changed: #enabled: with: { aBoolean }! !

!SpAbstractTextPresenter methodsFor: 'api - events' stamp: ''!
whenMenuChangedDo: aBlock
	"Inform when menu definition changed. 
	 `aBlock` receives zero arguments."

	self property: #contextMenu whenChangedDo: aBlock! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
eventKeyStrokesForNextFocus
	"String describing the keystroke to perform to jump to the next widget"
	^ { Character arrowRight command ctrl asKeyCombination }! !

!SpAbstractTextPresenter methodsFor: '*NewTools-SpTextPresenterDecorators' stamp: ''!
removeAllTextSegmentDecorations

	self withAdapterDo: [ :anAdapter | 
		anAdapter removeAllTextSegmentDecorations ]! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
whenAcceptBlockChangedDo: aBlock
	"Set a block to perform when the accept block changed"
	
	self property: #actionToPerform whenChangedDo: aBlock! !

!SpAbstractTextPresenter methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
pendingText: aText
	"Set the pending text. Do no accept it"

	self withAdapterDo: [ :anAdapter | 
		anAdapter isMorphicAdapter 
			ifTrue: [ ^ anAdapter pendingText: aText ] ].
	self text: aText! !

!SpAbstractTextPresenter methodsFor: 'private' stamp: ''!
readSelection

	^ self readSelectionBlock 
		cull: self text 
		cull: self! !

!SpAbstractTextPresenter methodsFor: 'private' stamp: ''!
whenReadSelectionIsChangedDo: aBlock
	"Set a block to perform when the read selection block changed"

	self property: #readSelection whenChangedDo: aBlock! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
wantsVisualFeedback
	^ wantsVisualFeedback! !

!SpAbstractTextPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionChangedDo: aBlock
	"Inform when selection changed. 
	 `aBlock` receives two optional arguments 
	 - new selection
	 - old selection"

	self property: #selection whenChangedDo: aBlock! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
contextMenu
	"Answer context menu or nil if there is none defined.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	^ contextMenu! !

!SpAbstractTextPresenter methodsFor: 'api - selection' stamp: ''!
selectionInterval: anInterval
	"Set the text selection interval.
	 `anInterval` is an `Interval` from the first character selected to the end."
	
	self flag: #REVIEW. "Maybe it should be called #selectInterval:?"
	selection := anInterval! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
placeholder
	"Answer the place holder (also known as ghost text) for this text component."

	^ placeholder! !

!SpAbstractTextPresenter methodsFor: 'private' stamp: ''!
acceptText: aString
	"Used to set the text value comming from the adapter (we do not want to re-send 
	 this value to the adapter, hence we set it 'raw', not triggering events)"

	self property: #text rawValue: aString! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
readSelectionBlock
	"Return the block used to calculate the text selection"

	^ readSelection! !

!SpAbstractTextPresenter methodsFor: 'api - events' stamp: ''!
whenPlaceholderChangedDo: aBlock
	"Inform when placeholder has been changed (See `SpAbstractTextPresenter>>#placeholder:`).
	 `aBlock` receives two optional arguments 
	 - new placeholder
	 - old placeholder"
	
	self property: #placeholder whenChangedDo: aBlock! !

!SpAbstractTextPresenter methodsFor: '*Spec2-Commander2' stamp: ''!
contextMenuFromCommandsGroup: aValuable
	self contextMenu: [ aValuable value beRoot asMenuPresenter ]! !

!SpAbstractTextPresenter methodsFor: 'api - events' stamp: ''!
whenResetDo: aBlock
	"Inform when a 'reset' event is triggered.
	 It will react when user presses <meta+l> key (this is for historical reasons)."

	self 
		bindKeyCombination: SpCancelChangesCommand defaultShortcutKey
		toAction: aBlock! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
clearSelection
	"Remove selection from the text model"

	self selectionInterval: (0 to: 0)! !

!SpAbstractTextPresenter methodsFor: 'TOREMOVE' stamp: ''!
whenAboutToStyleChangedDo: aBlock
	"Set a block to perform when the about to style block changed"
	
	self whenAboutToStyleBlockChanged: [:block :old :announcement :anAnnouncer | 
		aBlock cull: (block value) cull: old cull: announcement cull: anAnnouncer ]! !

!SpAbstractTextPresenter methodsFor: 'api - selection' stamp: ''!
selectionInterval
	"Answer the text selection interval (an interval from start to end)."
	
	self withAdapterDo: [ :anAdapter | 
		self rawSelection: anAdapter selection ].
	^ selection ifNil: [ 1 to: 0 ]! !

!SpAbstractTextPresenter methodsFor: 'api' stamp: ''!
text
	"Answer current text"

	^ text! !

!SpAbstractTextPresenter class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpAbstractTextPresenter! !

!SpAbstractTextPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ self subclassResponsibility! !

!SpAbstractTextPresenterTest methodsFor: 'tests' stamp: ''!
testClearSelection
	self initializationText.
	self openInstance.
	presenter selectionInterval: (1 to: 10).
	self assert: presenter selectionInterval equals: (1 to: 10).
	presenter clearSelection.
	self assert: presenter selectionInterval isEmpty! !

!SpAbstractTextPresenterTest methodsFor: 'tests' stamp: ''!
testContextMenu
	| menu changed |
	
	self assert: presenter contextMenu isNil.
	menu := SpMenuPresenter new.
	changed := false.
	presenter whenMenuChangedDo: [ 
		changed := true. ].
	presenter contextMenu: menu.
	self assert: presenter contextMenu equals: menu.
	self assert: changed! !

!SpAbstractTextPresenterTest methodsFor: 'tests' stamp: ''!
testSelectAll
	self initializationText.
	self openInstance.
	presenter selectAll.
	self assert: presenter selectionInterval equals: (1 to: 15)! !

!SpAbstractTextPresenterTest methodsFor: 'tests' stamp: ''!
testWhenResetDo
	| reseted |

	reseted := false.
	presenter whenResetDo: [ :aString | reseted := true ].
	
	self openInstance.
	
	self textInputAdapter
		keyDown: $l 
		shift: false
		meta: true 
		control: false 
		option: false.
		
	self assert: reseted! !

!SpAbstractTextPresenterTest methodsFor: 'tests' stamp: ''!
testWhenSubmitDo
	| submitted |

	submitted := false.
	presenter whenSubmitDo: [ :aString | submitted := true ].
	
	self openInstance.
	
	self textInputAdapter
		keyDown: $s 
		shift: false
		meta: true 
		control: false 
		option: false.
		
	self assert: submitted! !

!SpAbstractTextPresenterTest methodsFor: 'private' stamp: ''!
textInputAdapter
	
	^ presenter adapter! !

!SpAbstractTextPresenterTest methodsFor: 'tests' stamp: ''!
testCursorPositionIndex

	presenter text: (String loremIpsum: 80).
	self openInstance. "cursor position does not works if instance is not opened"
	"If not defined, cursor is at begining"	
	self assert: presenter cursorPositionIndex equals: 1.
	"middle"
	presenter cursorPositionIndex: 20.
	self assert: presenter cursorPositionIndex equals: 20.
	"end"
	presenter cursorPositionIndex: 81.
	self assert: presenter cursorPositionIndex equals: 81
! !

!SpAbstractTextPresenterTest methodsFor: 'tests' stamp: ''!
testPlaceholderIsSet

	presenter placeholder: 'enter something...'.
	
	self assert: presenter placeholder equals: 'enter something...'! !

!SpAbstractTextPresenterTest methodsFor: 'tests' stamp: ''!
testClearContent
	self initializationText.
	self denyEmpty: presenter text.
	presenter clearContent.
	self assertEmpty: presenter text! !

!SpAbstractTextPresenterTest methodsFor: 'initialization' stamp: ''!
initializationText
	presenter text: 'Text for tests.'! !

!SpAbstractTextPresenterTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpAbstractTextPresenterTest! !

!SpAbstractTreeFilter commentStamp: ''!
I am an abstract class for tree filters.
My children should propose a filter for tree nodes.!
!SpAbstractTreeFilter methodsFor: 'filtering' stamp: ''!
keepTreeNode: aNode

	^ false! !

!SpAbstractTreePresenter commentStamp: ''!
A base for tree presenters, it defines basic functionality common to all trees.!
!SpAbstractTreePresenter methodsFor: 'initialization' stamp: ''!
initializeTSearchable
	
	self searchMatching: [ :item :pattern | 
		self performDefaultSearch: item matching: pattern ].! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
itemAtPath: anArray ifAbsent: aBlock
	^ [ self itemAtPath: anArray ]
		on: SubscriptOutOfBounds
		do: [ aBlock value ]! !

!SpAbstractTreePresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultInputPort

	^ self inputRootsPort! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
disableActivationDuring: aBlock
	| oldActivate |
	
	oldActivate := activationBlock.
	activationBlock := [ ].
	aBlock ensure: [ 
		activationBlock := oldActivate ]! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
refresh
	"Forces a refresh of the tree. 
	 This is useful when some model contents has changed, but we do not want to reset the whole list 
	 (and losing selections with it)"

	self withAdapterDo: [ :anAdapter | anAdapter refreshTree ]! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
itemAt: index of: anArray then: path
	"dives into elements of tree to find the one that corresponds to path"
	| element |
	
	element := anArray at: index.
	^ path 
		ifNotEmpty: [ 
			self 
				itemAt: path first 
				of: (self childrenFor: element) 
				then: path allButFirst ]
		ifEmpty: [ 
			element ]! !

!SpAbstractTreePresenter methodsFor: 'api - events' stamp: ''!
whenSelectedIndexChangedDo: aBlock 
	"Inform when selected index has changed. 
	 `aBlock` receives one optional argument (the new element)."
	
	self whenSelectionChangedDo: [ :selection | 
		aBlock cull: selection first ]! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
children

	^ childrenBlock! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
enableSearch
	"Enable searching"

	searchEnabled := true! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
propagateNaturalHeight: aBoolean
	"Indicate when component propagates natural heigth.
	 Natural height propagation means that the height of the presenter containing both scrollbars and 
	 another component (tipically a text presenter) will follow the height of such component."

	propagateNaturalHeight := aBoolean! !

!SpAbstractTreePresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultOutputPort

	^ self outputSelectionPort! !

!SpAbstractTreePresenter methodsFor: 'testing' stamp: ''!
activatesOnSingleClick
	"Answer true if activation event is triggered on single click"

	^ activateOnSingleClick! !

!SpAbstractTreePresenter methodsFor: 'initialization' stamp: ''!
registerEvents

	self whenMenuChangedDo: [ 
		self withAdapterDo: [ :anAdapter | anAdapter updateMenu ] ]! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
contextMenu: aValuableOrMenuPresenter
	"Set the context menu.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	contextMenu := aValuableOrMenuPresenter! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
removeScrollBarStyle: aStyle
	"Remove `aStyle` from the list of scrollbar styles.
	 See SpTHaveWrappingScrollBars>>#scrollBarStyles"

	scrollBarStyles := scrollBarStyles copyWithout: aStyle! !

!SpAbstractTreePresenter methodsFor: 'initialization' stamp: ''!
initializeTHaveWrappingScrollBars

	scrollBarStyles := #().
	self propagateNaturalWidth: false.
	self propagateNaturalHeight: false! !

!SpAbstractTreePresenter methodsFor: 'simulation' stamp: ''!
clickAtPath: aPath

	self selectPaths: { aPath }.

	activateOnSingleClick ifFalse: [ ^ self ].
	self doActivateAtPath: aPath! !

!SpAbstractTreePresenter methodsFor: 'testing' stamp: ''!
isSearchEnabled
	"Answer true if search is enabled (See `SpTSearchable>>#enableSearch`)"

	^ searchEnabled! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
roots
	"Answer the roots of the tree"

	^ roots! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
addScrollBarStyle: aStyle
	"Add a style for the scrollbar component. 
	 In platforms that do not support separation from component and scrollbar (like Morphic), the 
	 style will be added to the component styles. 
	 In platforms who supports separation between component and scrollbar (like Gtk3), the style 
	 will be taken separately."

	scrollBarStyles := scrollBarStyles copyWith: aStyle! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
updateRootsKeepingSelection: aCollection 
	"Update tree roots keeping current selection. 
	 WARNING: aCollection must includes the elements selected."

	self disableActivationDuring: [ 
		| selectedPaths |
		
		selectedPaths := (self selection selectedPaths collect: [ :each | self pathItemOf: each ]).
		self roots: aCollection.
		selectedPaths ifNotEmpty: [ 
			self selectPaths: (selectedPaths collect: [ :each | self pathIndexOf: each ]) ] ]! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
selectionMode: aMode
	
	selectionMode ifNotNil: [ 
		selectionMode transferSubscriptionsTo: aMode ].
	selectionMode := aMode! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
withoutScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	wrapScrollBars := false! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
selectItems: aListOfItem
	"Select items included in `aCollection` if they are included in model list.
	 NOTE: In single selection mode it will select the first element of `aCollection` 
	 It does not scrolls to selected element."

	self selection selectItems: aListOfItem! !

!SpAbstractTreePresenter methodsFor: 'api - events' stamp: ''!
whenRootsChangedDo: aBlockClosure 
	"Inform when roots have changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #roots whenChangedDo: aBlockClosure! !

!SpAbstractTreePresenter methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	self initializeTSearchable.
	self initializeTHaveWrappingScrollBars! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
expandAll
	"Expand all nodes of the tree. 
	 WARNING: If your tree is big, this operation can be slow."

	self withAdapterPerformOrDefer: [ :anAdapter | 
		anAdapter expandAll ]! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
selectedItem
	"Return selected item."
	
	^ self selection selectedItem! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
searchMatching: aBlock
	"Enables search and defines a block to perform a search on the model objects. 
	 The block receives two parameters: 
		- item (the model element)
		- pattern (the string to match)"

	searchBlock := aBlock.
	self enableSearch! !

!SpAbstractTreePresenter methodsFor: 'api - events' stamp: ''!
whenSelectedItemChangedDo: aBlock
	"Inform when selected index has changed. 
	 `aBlock` receives one optional argument (the new element)."
	
	self whenSelectionChangedDo: [ :selection | 
		aBlock cull: (selection ifNotNil: [ selection selectedItem ]) ]! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
selection
	"Answer the selection object (an instance of `SpSingleSelectionMode` or `SpMultipleSelectionMode`).
	 This is not the item selected, but the selection container (it may contain one or many selected 
	 items)"
	
	^ selectionMode value! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
scrollBarStyles
	"Answer styles defined for the scrollbar component. 
	 In platforms that do not support separation from component and scrollbar (like Morphic), the 
	 style will be added to the component styles. 
	 In platforms who supports separation between component and scrollbar (like Gtk3), the style 
	 will be taken separately."

	^ scrollBarStyles ifNil: [ #() ]! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
unselectAll 
	"Remove all selections"

	self selection unselectAll! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
expandRoots
	"Expand all roots of the tree"

	self withAdapterPerformOrDefer: [ :anAdapter | 
		anAdapter expandRoots ]! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
children: aBlock
	"Set a block to answer the children of a node when it is expanded.
	 `aBlock` receives one argument, the node element to expand.
	 If there are no children to answer, `aBlock` needs to answer an empty collection."		

	childrenBlock := aBlock! !

!SpAbstractTreePresenter methodsFor: '*Spec2-Transmission' stamp: ''!
outputActivationPort
	
	^ SpActivationPort newPresenter: self! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
selectPathByItems: pathArray scrollToSelection: aBoolean
	"IMPORTANT: Scrolling to selection just has sense when the widget is already shown, because before it 
	 is displayed it does not has real bounds. In morphic (and gtk) it has a minimal extent assigned, 
	 but that will change as soon as the widget is inserted in a container and the container applies its 
	 layout."
	| pathIndexes |

	pathIndexes := self pathIndexOf: pathArray.
	pathIndexes size > 1 ifTrue: [ 
		self expandPath: pathIndexes allButLast ].
	self 
		selectPath: pathIndexes
		scrollToSelection: aBoolean! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
selectItem: anItem
	"Select `anItem` if it is included in model list.
	 It does not scrolls to selected element."

	self selection selectItem: anItem! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
disableSearch
	"Disable searching"

	searchEnabled := false! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
beSingleSelection
	"Enable single selection (this is the default)."
	
	self selectionMode: (SpTreeSingleSelectionMode on: self)! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
itemAtPath: anArray
	
	self withAdapterDo: [ :anAdapter | 
		^ anAdapter itemAtPath: anArray ].

	^ self 
		itemAt: anArray first
		of: self roots
		then: anArray allButFirst! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
propagateNaturalWidth: aBoolean
	"Indicate when component propagates natural width.
	 Natural width propagation means that the width of the presenter containing both scrollbars and 
	 another component (tipically a text presenter) will follow the width of such component.
	 WARNING: Because of a limitation on how the font rendering works in morphic backend, 
	 this properly will fail to preserve the correct width if using monospaced fonts."

	propagateNaturalWidth := aBoolean! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
collapsePath: aPath
	"Collapse the tree path.
	`aPath` is the path to collapse. A path is an array of node indexes (e.g. #(1 2 3))"

	self withAdapterPerformOrDefer: [ :anAdapter |
		anAdapter collapsePath: aPath ]! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
roots: aCollection
	"Set the roots of the tree table.
	 This is the starting point from where the whole tree will be shown."

	roots := aCollection.
	self selection clearSelection! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
unselectPath: aPath
	"Unselects element in `aPath`
	`aPath` is the path to select. A path is an array of node indexes (e.g. #(1 2 3))"

	self selection unselectPath: aPath! !

!SpAbstractTreePresenter methodsFor: 'api - events' stamp: ''!
whenActivatedDo: aBlock
	"Inform when an element has been 'activated'. 
	 `aBlock` receives one argument (a selection object, see `SpAbstractSelectionMode`)"

	activationBlock := aBlock! !

!SpAbstractTreePresenter methodsFor: 'api - events' stamp: ''!
whenMultiSelectionChangedDo: aBlockClosure 
	"Inform when selection mode has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
	
	selectionMode whenChangedDo: aBlockClosure ! !

!SpAbstractTreePresenter methodsFor: 'api - events' stamp: ''!
whenShowColumnHeadersChangedDo: aBlock 
	"Inform when showColumnHeaders property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
	
	self property: #showColumnHeaders whenChangedDo: aBlock ! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
selectPath: aPath scrollToSelection: shouldScrollToSelection
	"Selects element in `aPath`
	`aPath` is the path to select. A path is an array of node indexes (e.g. #(1 2 3)).
	 If `shouldScrollToSelection` is true, it will scroll to selected element.
	 IMPORTANT: Scrolling to selection just has sense when the widget is already shown, because before it 
	 is displayed it does not has real bounds. In morphic (and gtk) it has a minimal extent assigned, 
	 but that will change as soon as the widget is inserted in a container and the container applies its 
	 layout."

	self withAdapterPerformOrDefer: [ :anAdapter |
		self selectPath: aPath.
		shouldScrollToSelection ifTrue: [ adapter scrollToSelection ] ]! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
selectPath: aPath
	"Selects element in `aPath`
	`aPath` is the path to select. A path is an array of node indexes (e.g. #(1 2 3)).
	 It does not scrolls to selected element."

	self selection selectPath: aPath! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
doActivateAtPath: aPath
	"Activate only if there is an item at that position"

	self itemAtPath: aPath ifAbsent: [ ^ self ].
	activationBlock cull: ((SpTreeSingleSelectionMode on: self)
		selectPath: aPath;
		yourself)! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
pathItemOf: aPath
	"answer an array of items following a path. 
	 e.g. #(1 2 3) = { item1. item2. item3 }"

	^ self 
		pathItemOf: aPath 
		in: self roots! !

!SpAbstractTreePresenter methodsFor: 'testing' stamp: ''!
hasScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	^ wrapScrollBars! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
searchValueOf: item 

	^ item asString! !

!SpAbstractTreePresenter methodsFor: 'api - events' stamp: ''!
whenSearchEnabledChangedDo: aBlock
	"Inform when search enabled/disabled has changed.
 	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #searchEnabled whenChangedDo: aBlock! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
withScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	wrapScrollBars := true! !

!SpAbstractTreePresenter methodsFor: 'testing' stamp: ''!
hasCustomSearch
	"Answer true if the list has a custom search defined (See `SpListPresenter>>#searchMatching:`"

	^ searchBlock notNil! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
childrenFor: anObject 

	^ self children value: anObject! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
pathIndexOf: pathArray in: aCollection 
	| pathElement |
	
	pathElement := { aCollection indexOf: pathArray first }.
	pathArray size = 1 ifTrue: [ ^ pathElement ].
	
	^ pathElement, (self 
		pathIndexOf: pathArray allButFirst
		in: (self childrenFor: pathArray first))
! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
verticalAlignment
	^ verticalAlignment! !

!SpAbstractTreePresenter methodsFor: 'api - events' stamp: ''!
whenMenuChangedDo: aBlock
	"Inform when menu definition changed. 
	 `aBlock` receives zero arguments."

	self property: #contextMenu whenChangedDo: aBlock! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
collapseAll
	"Collapse all nodes of the tree. "

	self withAdapterPerformOrDefer: [ :anAdapter | 
		anAdapter collapseAll ]! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
pathIndexOf: anArrayOfElements

	^ self 
		pathIndexOf: anArrayOfElements 
		in: self roots! !

!SpAbstractTreePresenter methodsFor: 'testing' stamp: ''!
isPropagateNaturalWidth
	"Indicate if component propagates natural width.
	 See `SpTHaveWrappingScrollBars>>#propagateNaturalWidth:`"

	^ propagateNaturalWidth ifNil: [ false ]! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
unselectItem: anItem
	"Remove selection of element `anItem`"

	self selection unselectItem: anItem! !

!SpAbstractTreePresenter methodsFor: '*Spec2-Transmission' stamp: ''!
inputRootsPort

	^ SpRootsPort newPresenter: self! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
beMultipleSelection
	"Enable multiple selection."

	self selectionMode: (SpTreeMultipleSelectionMode on: self)! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
selectPaths: pathArray
	"Selects all elements in `pathsArray``
	`pathsArray` is an array of paths. A path is an array of node indexes (e.g. #(1 2 3))"

	self selection selectPaths: pathArray! !

!SpAbstractTreePresenter methodsFor: 'testing' stamp: ''!
isExpanded: aPath 

	self withAdapterDo: [ :anAdapter |  
		^ anAdapter isExpanded: (anAdapter itemAtPath: aPath) ].

	^ false! !

!SpAbstractTreePresenter methodsFor: 'api - events' stamp: ''!
whenSelectionChangedDo: aBlock 
	"Inform when selection has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
	
	self selection whenChangedDo: [ aBlock cull: selectionMode ]! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
contextMenu
	"Answer context menu or nil if there is none defined.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	^ contextMenu! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
activateOnDoubleClick
	"Configure the list to trigger activation on double click.
	 An element on a list can be 'activated', meaning it will trigger an event to execute an 
	 action on it. An activation is different than a selection (one can 'select' an element without 
	 activating it).
	 See `SpTreeTablePresenter>>#whenActivatedDo:`"
	
	activateOnSingleClick := false! !

!SpAbstractTreePresenter methodsFor: 'testing' stamp: ''!
activatesOnDoubleClick
	"Answer true if activation event is triggered on double click"
	
	^ activateOnSingleClick not! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
performSearch: item matching: pattern

	^ searchBlock 
		value: item 
		value: pattern! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
activateOnSingleClick
	"Configure the list to trigger activation on single click.
	 An element on a list can be 'activated', meaning it will trigger an event to execute an 
	 action on it. An activation is different than a selection (one can 'select' an element without 
	 activating it).
	 See `SpTreeTablePresenter>>#whenActivatedDo:`"
	
	activateOnSingleClick := true! !

!SpAbstractTreePresenter methodsFor: '*Spec2-Commander2' stamp: ''!
contextMenuFromCommandsGroup: aValuable
	self contextMenu: [ aValuable value beRoot asMenuPresenter ]! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
items: aCollection
	"Set the roots of a tree. This is a convenience method, synonym of `SpTreePresenter>>#roots:`"

	self roots: aCollection! !

!SpAbstractTreePresenter methodsFor: 'testing' stamp: ''!
isPropagateNaturalHeight
	"Indicate if component propagates natural heigth.
	 See `SpTHaveWrappingScrollBars>>#propagateNaturalHeight:`"

	^ propagateNaturalHeight ifNil: [ false ]! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
selectedItems
	"Return all the selected items in the case of a multiple selection list"
	
	^ self selection selectedItems! !

!SpAbstractTreePresenter methodsFor: '*Spec2-Transmission' stamp: ''!
outputSelectionPort
	
	^ SpSelectionPort newPresenter: self! !

!SpAbstractTreePresenter methodsFor: 'api - selection' stamp: ''!
selectPathByItems: pathArray

	self selectPathByItems: pathArray scrollToSelection: false! !

!SpAbstractTreePresenter methodsFor: 'simulation' stamp: ''!
doubleClickAtPath: aPath
	self selectPath: aPath.
	
	activateOnSingleClick ifTrue: [ ^ self ].
	self doActivateAtPath: aPath! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
performDefaultSearch: item matching: pattern
	| text |
	
	text := (self searchValueOf: item) trimBoth asLowercase.
	^ text beginsWith: pattern! !

!SpAbstractTreePresenter methodsFor: 'private' stamp: ''!
pathItemOf: pathArray in: aCollection 
	| pathElement |
	
	pathElement := aCollection at: pathArray first.
	pathArray size = 1 ifTrue: [ ^ { pathElement } ].
	
	^ { pathElement }, (self 
		pathItemOf: pathArray allButFirst
		in: (self childrenFor: pathElement))
! !

!SpAbstractTreePresenter methodsFor: 'api' stamp: ''!
expandPath: aPath
	"Expand the tree path.
	`aPath` is the path to expand. A path is an array of node indexes (e.g. #(1 2 3))"

	self withAdapterPerformOrDefer: [ :anAdapter |
		anAdapter expandPath: aPath ]! !

!SpAbstractTreePresenter class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self = SpAbstractTreePresenter ]! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testPathItemOf

	presenter 
		roots: #(1 2 3);
		children: [ :x | { x * 10 } ].
	
	self 
		assert: (presenter pathItemOf: #(2 1 1))
		equals: #(2 20 200).
		
! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testPathIndexOf

	presenter 
		roots: #(1 2 3);
		children: [ :x | { x * 10 } ].
	
	self 
		assert: (presenter pathIndexOf: #(2 20 200))
		equals: #(2 1 1).
		
! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testContextMenu
	| menu changed |
	self assert: presenter contextMenu isNil.
	menu := SpMenuPresenter new.
	changed := false.
	presenter whenMenuChangedDo: [ 
		changed := true. ].
	presenter contextMenu: menu.
	self assert: presenter contextMenu equals: menu.
	self assert: changed! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testActivationOnDoubleClickShouldActivateOnDoubleClick
	| activatedItem |
	presenter
		activateOnDoubleClick;
		whenActivatedDo: [ :selection | activatedItem := selection selectedItem ].

	presenter doubleClickAtPath: #(1 2 1).

	self assert: activatedItem equals: 110! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testActivationOnDoubleClickShouldNotActivateOnClick
	| activatedItem |
	presenter
		activateOnDoubleClick;
		whenActivatedDo: [ :selection | activatedItem := selection selectedItem ].

	presenter clickAtPath: #(1).

	self assert: activatedItem isNil! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testActivationOnSingleClickShouldNotActivateOnClickOutside
	| activatedItem |
	presenter
		activateOnSingleClick;
		whenActivatedDo: [ :selection | activatedItem := selection selectedItem ].

	presenter clickAtPath: #(4).

	self assert: activatedItem isNil! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testActivationOnSingleClickShouldActivateOnClick
	| activatedItem |
	presenter
		activateOnSingleClick;
		whenActivatedDo: [ :selection | activatedItem := selection selectedItem ].

	presenter clickAtPath: #(1).

	self assert: activatedItem equals: 1! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testDisableActivationDuring 
	| activated |

	activated := false.
	presenter whenActivatedDo: [ activated := true ].
	
	self deny: activated.
	presenter disableActivationDuring: [ presenter clickAtPath: #(2) ].
	self deny: activated. "still not change"
	self assert: presenter selectedItem equals: 2 "but the selection changed!!"! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testUnselectAll

	presenter beMultipleSelection.
	presenter 
		selectPath: #(1);
		selectPath: #(2).
	self assert: presenter selection selectedPaths equals: #((1) (2)).
	presenter unselectAll.
	self assertEmpty: presenter selection selectedPaths.
	
! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testUpdateRootsKeepingSelection 

	presenter roots: #($a $b $c).
	presenter selectPath: #(3).
	presenter updateRootsKeepingSelection: #($c $d $e $f).
	self assert: presenter selectedItem equals: $c! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testWhenSelectedItemChangedDo
	| selectedItem |

	presenter whenSelectedItemChangedDo: [ :item | selectedItem := item ].

	presenter clickAtPath: #(1).

	self assert: selectedItem equals: 1! !

!SpAbstractTreePresenterTest methodsFor: 'tests' stamp: ''!
testExpandAtPathExpandsTheNode

	self openInstance.
	
	self deny: (presenter isExpanded: #(1)). 
	self deny: (presenter isExpanded: #(1 2)). 
	self deny: (presenter isExpanded: #(1 2 1)). 

	presenter expandPath: #(1 2 1).

	self assert: (presenter isExpanded: #(1)). 
	self assert: (presenter isExpanded: #(1 2)). 
	self assert: (presenter isExpanded: #(1 2 1)). 
! !

!SpAbstractTreePresenterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	presenter 
		roots: #(1 2 3);
		children: [ :aNumber | 
			aNumber < 100 
				ifTrue: [ ((aNumber * 10) to: (aNumber * 10) + 10) asArray ]
				ifFalse: [ #() ] ].
	! !

!SpAbstractTreePresenterTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self = SpAbstractTreePresenterTest ]! !

!SpAbstractTreeSelectionMode methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpAbstractTreeSelectionMode methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ selection isEmpty! !

!SpAbstractTreeSelectionMode methodsFor: 'transfering' stamp: ''!
transferSubscriptionsTo: anotherSelectionMode

	self selectionHolder transferSubscriptionsTo: anotherSelectionMode selectionHolder! !

!SpAbstractTreeSelectionMode methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpAbstractTreeSelectionMode methodsFor: 'accessing' stamp: ''!
selectionHolder

	^ self observablePropertyNamed: #selection! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
selectPath: aPath
	"Select a node in the tree by providing a list of indexes.
	Example:
		A
			B
			C
			E
		D
			G
			T
	selectPath( #(1 2) ) will select the node C
	selectPath( #(2 1) ) will select the node G
	selectPath( #(2) ) will select the node D
	"
	
	self subclassResponsibility! !

!SpAbstractTreeSelectionMode methodsFor: 'subscription' stamp: ''!
unsubscribe: anObject 

	(self observablePropertyNamed: #selection) unsubscribe: anObject! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
pathOf: anItem from: aCollection
    | index |

    index := aCollection indexOf: anItem.
    index > 0 ifTrue: [ ^ { index } ].
    
    aCollection withIndexDo: [ :each :i |
        (self pathOf: anItem from: (presenter childrenFor: each))
            ifNotNil: [ :path | ^ { i }, path ] ].
        
    ^ nil! !

!SpAbstractTreeSelectionMode methodsFor: 'api - events' stamp: ''!
whenChangedDo: aBlock
	
	self property: #selection whenChangedDo: aBlock! !

!SpAbstractTreeSelectionMode methodsFor: '*Spec2-Transmission' stamp: ''!
transmission
	self subclassResponsibility! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
pathOf: anItem
	^ (self pathOf: anItem from: presenter roots)
		ifNil: [ 	NotFound signalFor: anItem in: presenter roots ]! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
unselectItem: anItem
	[ self unselectPath: (self pathOf: anItem) ]
	on: NotFound 
	do: [ "ignore. nothing to unselect" ]! !

!SpAbstractTreeSelectionMode methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
selectItems: aListOfItems
	aListOfItems do: 
		[ :each |
			[ self selectPath: (self pathOf: each) ]
			on: NotFound
			do: [ "ignore. we do not change the selection" ] ]! !

!SpAbstractTreeSelectionMode methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpAbstractTreeSelectionMode methodsFor: 'initialization' stamp: ''!
initialize
	self class initializeSlots: self.
	selection := #().
	super initialize.
! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
itemNotFoundAction
	"ignore. we do not change the selection"! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
selectPaths: pathArray
	self subclassResponsibility! !

!SpAbstractTreeSelectionMode methodsFor: 'accessing' stamp: ''!
selectedItem
	^ self subclassResponsibility! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
unselectAll

	self clearSelection! !

!SpAbstractTreeSelectionMode methodsFor: 'accessing' stamp: ''!
presenter: aPresenter
	presenter := aPresenter! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
clearSelection

	selection := #()! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
selectItem: anItem
	[ self selectPath: (self pathOf: anItem) ]
		on: NotFound
		do: [ self itemNotFoundAction ]! !

!SpAbstractTreeSelectionMode methodsFor: 'accessing' stamp: ''!
isMultipleSelection
	^ false! !

!SpAbstractTreeSelectionMode methodsFor: 'accessing' stamp: ''!
selectedPaths
	^ self subclassResponsibility! !

!SpAbstractTreeSelectionMode methodsFor: 'selecting' stamp: ''!
unselectPath: aPath
	self subclassResponsibility! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpAbstractTreeSelectionMode class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpAbstractTreeSelectionMode class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpAbstractTreeSelectionMode class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpAbstractTreeSelectionMode class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpAbstractTreeSelectionMode class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpAbstractTreeSelectionMode class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpAbstractTreeSelectionMode class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpAbstractTreeSelectionMode class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpAbstractTreeSelectionMode class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpAbstractTreeSelectionMode class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpAbstractTreeSelectionMode class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpAbstractTreeSelectionMode class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpAbstractTreeSelectionMode class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpAbstractTreeSelectionMode class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpAbstractTreeSelectionMode class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing method dictionary' stamp: ''!
on: aPresenter

	^ self new
		presenter: aPresenter;
		yourself! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpAbstractTreeSelectionMode class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpAbstractTreeSelectionMode class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpAbstractTreeSelectionMode class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpAbstractTreeTableAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTreeTablePresenter ! !

!SpAbstractTreeTableAdapterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance
	presenter
		addColumn: (SpStringTableColumn title: 'Value' evaluated: #printString);
		hideColumnHeaders;
		roots: #(1 2 3);
		children: [ :aNumber | {(aNumber * 2) . (aNumber * 3) . (aNumber * 10)} ]! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testItemsWithoutChildrenDoNotHaveExpandIcon
	presenter children: [ :aNumber | aNumber odd ifTrue: [ {(aNumber * 2) . (aNumber * 3) . (aNumber * 10)} ] ifFalse: [ #() ] ].

	self assert: (self adapter isRowMorphExpandableAt: 1).
	self deny: (self adapter isRowMorphExpandableAt: 2).
	self assert: (self adapter isRowMorphExpandableAt: 3)! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testSelectItemSelectsTheGivenElement

	self presenter selection selectPath: #(2).
	self assert: self adapter selectedItem equals: 2.! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testShowingColumnDisplayColumn

	self presenter showColumnHeaders.
	
	backendForTest assertHasHeader: self adapter! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testLazilyComputeChildrenDoesNotComputeChildren
	presenter
		children: [ :aNumber | aNumber odd ifTrue: [ {(aNumber * 2) . (aNumber * 3) . (aNumber * 10)} ] ifFalse: [ #() ] ];
		lazilyComputeChildren.

	self assert: (self adapter isRowMorphExpandableAt: 1).
	self
		assert: (self adapter isRowMorphExpandableAt: 2)
		description: 'If we do not compute the children then we should show an expand icon even if there is no children'.
	self assert: (self adapter isRowMorphExpandableAt: 3)! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testChangingRootsUpdateWidget

	self presenter roots: #(10 11 12).
	
	backendForTest assertList: self adapter displayItems: #('10' '11' '12').
	
! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testSelectItemSelectsTheGivenElementAndExpandsTheBranches

	self presenter selection selectPath: #(2 3).
	self assert: self adapter selectedItem equals: 20.! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testSelectingOutOfRangeKeepOldSelection
	
	self presenter selection selectPath: #(2 3).
	self presenter selection selectPath: #(7 3).
	self assert: self adapter selectedItem equals: 20
! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testRightClickShowsMenu
	| menu |

	presenter contextMenu: (menu := SpMockMenuPresenter new).
	self deny: menu shown.
	self emulateRightClick.
	self assert: menu shown! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testChangingRootsResetsSelection

	self presenter selection selectPath: #(2 3).
	self presenter roots: #(10 11 12).
	
	self assert: self adapter selectedItem equals: nil
! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testSelectingAPathUpdatesSelectionInPresenter

	self presenter selection selectPath: #(2 3).
	self assert: self presenter selectedItem equals: 20.! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testAfterOpeningEmptyLazyChildrenExpandIconVanish
	presenter
		children: [ :aNumber | aNumber odd ifTrue: [ {(aNumber * 2) . (aNumber * 3) . (aNumber * 10)} ] ifFalse: [ #() ] ];
		lazilyComputeChildren.

	self
		assert: (self adapter isRowMorphExpandableAt: 2)
		description: 'If we do not compute the children then we should show an expand icon even if there is no children'.

	self adapter expandRowAt: 2.	"This row has no child"

	self deny: (self adapter isRowMorphExpandableAt: 2)! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testStartsWithoutSelection

	self assert: self adapter selectedItem equals: nil.! !

!SpAbstractTreeTableAdapterTest methodsFor: 'tests' stamp: ''!
testSelectItemRaiseEvent

	| called |
	
	self presenter whenSelectionChangedDo: [ called := true ].
	self presenter selection selectPath: #(2 3).

	self assert: called equals: true! !

!SpAbstractTreeTableAdapterTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	
	^ self = SpAbstractTreeTableAdapterTest! !

!SpAbstractWidgetAdapterTest methodsFor: 'tests' stamp: ''!
testEnabledAffectWidget
	
	presenter enabled: false.
	self deny: self adapter enabled! !

!SpAbstractWidgetAdapterTest methodsFor: 'tests' stamp: ''!
testChangingHelpAffectTheWidget
	
	presenter help: 'ALabel'.
	self assert: self adapter helpText equals: 'ALabel'! !

!SpAbstractWidgetAdapterTest class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self name = #SpAbstractWidgetAdapterTest ! !

!SpAbstractWidgetLayout commentStamp: ''!
I am a layout used for AbstractWidgetPresenters. I will manage all presenter that need to be adapted via a spec adapter for a specific binding.

Examples
--------------------

	SpAbstractWidgetLayout for: #ListAdapter
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	adapterName:		<aSymbol>		Key to use in order to find the real adapter of a presenter for a specific binding.
!
!SpAbstractWidgetLayout methodsFor: 'accessing' stamp: ''!
asSpLayout
	^ self! !

!SpAbstractWidgetLayout methodsFor: 'building' stamp: ''!
adapt: aPresenter bindings: adapterBindings
	| adapter oldAdapter |
	adapter := self adapterFor: aPresenter bindings: adapterBindings.
	oldAdapter := aPresenter adapter. 
	adapter adapt: aPresenter.
	oldAdapter ifNotNil: [ :anAdapter | anAdapter unsubscribe ].
	^ adapter! !

!SpAbstractWidgetLayout methodsFor: 'accessing' stamp: ''!
adapterName: anObject
	adapterName := anObject! !

!SpAbstractWidgetLayout methodsFor: 'accessing' stamp: ''!
adapterName
	^ adapterName! !

!SpAbstractWidgetLayout methodsFor: 'building' stamp: ''!
adapterFor: aPresenter bindings: adapterBindings
	^ self class environment
		at: (adapterBindings translateSymbol: self adapterName)
		ifPresent: [ :class | class owner: aPresenter ]
		ifAbsent: [ self error: 'No binding for ' , self adapterName , ' found.' ]! !

!SpAbstractWidgetLayout methodsFor: 'building' stamp: ''!
buildAdapterFor: aPresenter bindings: adapterBindings
	"In case we are building an adapter, we need to get the actual adapter class for a specific binding and make it adapt the presenter."

	^ aPresenter needRebuild
		ifTrue: [ self adapt: aPresenter bindings: adapterBindings ]
		ifFalse: [ 
			aPresenter needRebuild: true.
			aPresenter adapter
				ifNil: [ self adapt: aPresenter bindings: adapterBindings ]
				ifNotNil: [ :adapter | 
					adapter isRedrawable ifTrue: [ adapter removeSubWidgets ].
					adapter ] ]! !

!SpAbstractWidgetLayout methodsFor: 'accessing' stamp: ''!
allPresenters
	
	^ #()! !

!SpAbstractWidgetLayout class methodsFor: 'instance creation' stamp: ''!
for: aSymbol
	^ self new
		adapterName: aSymbol;
		yourself! !

!SpAbstractWidgetLayoutTest commentStamp: ''!
A SpecAbstractWidgetLayoutTest is a test class for testing the behavior of SpecAbstractWidgetLayout!
!SpAbstractWidgetLayoutTest methodsFor: 'tests' stamp: ''!
testDynamicBuild
	"Cyril: This is currently a duplicated of a test in SpecInterpreter, but this test is useful for more that the SpecInterpreter and since we plan to remove the interpreter I want to ensure we do not lose this test. This comment can be removed once the SpecInterpreter will be removed."

	| model widget1 widget2 widget3 |
	model := SpTestingPresenter new.
	model openWithSpec close.
	widget1 := model list adapter.
	model openWithSpec close.
	widget2 := model list adapter.
	self deny: widget1 identicalTo: widget2.
	model list needRebuild: false.
	model needRebuild: false.
	model openWithSpec close.
	widget3 := model list adapter.
	self assert: widget2 identicalTo: widget3.
	self assert: model needRebuild! !

!SpAbstractWidgetLayoutTest methodsFor: 'tests' stamp: ''!
testAdapterForBindingsRaiseErrorIfNoBinding
	| layout |
	layout := SpAbstractWidgetLayout for: #NonExistingAdapter.
	self should: [ layout adapterFor: SpListPresenter new bindings: SpStubAdapterBindings new ] raise: Error! !

!SpAbstractWidgetLayoutTest methodsFor: 'tests' stamp: ''!
testBuildAdapterForBindings
	| layout |
	layout := SpAbstractWidgetLayout for: #ListAdapter.
	self assert: (layout buildAdapterFor: SpListPresenter new bindings: SpStubAdapterBindings new) widget class equals: SpStubListView! !

!SpAbstractWidgetLayoutTest methodsFor: 'tests' stamp: ''!
testAdapterForBindings
	| layout |
	layout := SpAbstractWidgetLayout for: #ListAdapter.
	self assert: (layout adapterFor: SpListPresenter new bindings: SpStubAdapterBindings new) class equals: SpStubListAdapter! !

!SpAbstractWidgetPresenter commentStamp: ''!
SpAbstractBasicWidget is an abstract class for basic widgets.!
!SpAbstractWidgetPresenter methodsFor: 'TOREMOVE' stamp: ''!
color: aColor
	^ color := aColor! !

!SpAbstractWidgetPresenter methodsFor: 'private - deferring' stamp: ''!
withAdapterPerformOrDefer: aBlock 

	self adapter 
		ifNotNil: [ :anAdapter | aBlock value: anAdapter ]
		ifNil: [ self addDeferredAction: [ aBlock value: self adapter ] ]! !

!SpAbstractWidgetPresenter methodsFor: 'testing' stamp: ''!
isEnabled
	"Answer if presenter is enabled"

	^ enabled! !

!SpAbstractWidgetPresenter methodsFor: 'localization' stamp: ''!
localeChanged

	super localeChanged.
	self forceUpdateSlot: #help
	! !

!SpAbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
acceptDrop
	^ acceptDrop! !

!SpAbstractWidgetPresenter methodsFor: 'TOREMOVE' stamp: ''!
borderWidth
	"Return the border width"

	^ borderWidth! !

!SpAbstractWidgetPresenter methodsFor: 'TOREMOVE' stamp: ''!
borderColor: aColor
	"Set the border width"

	borderColor := aColor! !

!SpAbstractWidgetPresenter methodsFor: 'private - building' stamp: ''!
basicBuildAdapterWithSpecLayout: aSpecLayout
	| builtAdapter |

	builtAdapter := super basicBuildAdapterWithSpecLayout: aSpecLayout.
	self processDeferredActions.
	^ builtAdapter! !

!SpAbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
dragEnabled
	^ dragEnabled! !

!SpAbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
dropEnabled
	^ dropEnabled! !

!SpAbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
wantsDrop: aBlock
	wantsDrop := aBlock! !

!SpAbstractWidgetPresenter methodsFor: 'api' stamp: ''!
enabled: aBooleanOrValuable
	"Set if the widget is enabled (clickable or focusable).
	This can either be a boolean or a block returning a boolean."

	enabled := aBooleanOrValuable! !

!SpAbstractWidgetPresenter methodsFor: 'TOREMOVE' stamp: ''!
eventKeyStrokesForNextFocus
	"String describing the keystroke to perform to jump to the next widget"
	
	^ { Character arrowRight asKeyCombination. Character tab asKeyCombination}! !

!SpAbstractWidgetPresenter methodsFor: 'private - traversing' stamp: ''!
traverseInFocusOrderDo: aBlock excluding: excludes

	self canTakeKeyboardFocus ifFalse: [ ^ self ].
	
	excludes add: self.
	aBlock value: self! !

!SpAbstractWidgetPresenter methodsFor: 'TOREMOVE' stamp: ''!
whenBorderColorChangedDo: aBlock
	"Set a block to be performed when the brder width changed"

	self property: #borderColor whenChangedDo: aBlock! !

!SpAbstractWidgetPresenter methodsFor: 'TOREMOVE' stamp: ''!
borderColor
	"Return the border color"

	^ borderColor! !

!SpAbstractWidgetPresenter methodsFor: 'api - events' stamp: ''!
whenHelpChangedDo: aBlock
	"Inform when help property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #help whenChangedDo: aBlock! !

!SpAbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
wantsDrop
	^ wantsDrop! !

!SpAbstractWidgetPresenter methodsFor: 'api' stamp: ''!
help
	"Return the help string to display as help (tooltip) to the user."

	^ help! !

!SpAbstractWidgetPresenter methodsFor: 'api - events' stamp: ''!
whenEnabledChangedDo: aBlock
	"Inform when enabled status has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #enabled whenChangedDo: aBlock! !

!SpAbstractWidgetPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	enabled := true.
	dragEnabled := false.
	dropEnabled := false.
	wantsDrop := [ :transfer | self dropEnabled ].
	acceptDrop := [ :transfer | ].
	self whenEnabledChangedDo: [ :value | 
		self withAdapterDo: [ :w | w update: #enabled: with: { value } ] ].
	self property: #dragEnabled whenChangedDo: [ :value | 
		self withWidgetDo: [ :w | w update: #dragEnabled: with: { value } ] ].
	self property: #dropEnabled whenChangedDo: [ :value | 
		self withWidgetDo: [ :w | w update: #dropEnabled: with: { value } ] ]! !

!SpAbstractWidgetPresenter methodsFor: 'TOREMOVE' stamp: ''!
borderWidth: anInteger
	"Set the border width"

	borderWidth := anInteger! !

!SpAbstractWidgetPresenter methodsFor: 'api' stamp: ''!
disable
	"Disable the presenter"
	
	self enabled: false! !

!SpAbstractWidgetPresenter methodsFor: 'private - deferring' stamp: ''!
addDeferredAction: aBlock
	"Deferred actions are one-shot actions, performed during adapter initialization."

	deferredActions ifNil: [ deferredActions := #() ].
	deferredActions := deferredActions copyWith: aBlock! !

!SpAbstractWidgetPresenter methodsFor: 'api' stamp: ''!
help: aString
	"Set a help string to display to the user if he let the mouse over the widget (a tooltip)."

	help := aString! !

!SpAbstractWidgetPresenter methodsFor: 'api' stamp: ''!
enable
	"Enable the presenter"
	
	self enabled: true! !

!SpAbstractWidgetPresenter methodsFor: 'TOREMOVE' stamp: ''!
whenBorderWidthChangedDo: aBlock
	"Set a block to be performed when the brder width changed"

	self property: #borderWidth whenChangedDo: aBlock! !

!SpAbstractWidgetPresenter methodsFor: 'private - deferring' stamp: ''!
processDeferredActions

	deferredActions ifNil: [ ^ self ].
	[
		deferredActions do: [ :eachBlock | eachBlock value ] ]
	ensure: [ 
		deferredActions := nil ]! !

!SpAbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
dropEnabled: aBoolean
	dropEnabled := aBoolean! !

!SpAbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
acceptDrop: aBlock
	acceptDrop := aBlock! !

!SpAbstractWidgetPresenter methodsFor: 'drag and drop' stamp: ''!
dragEnabled: aBoolean
	dragEnabled := aBoolean! !

!SpAbstractWidgetPresenter methodsFor: 'TOREMOVE' stamp: ''!
eventKeyStrokesForPreviousFocus
	"String describing the keystroke to perform to jump to the next widget"
	
	^ { Character arrowLeft asKeyCombination. Character tab shift asKeyCombination}! !

!SpAbstractWidgetPresenter methodsFor: 'private' stamp: ''!
replaceLayoutWith: aLayout
	"do nothing, widgets do not have updatable layouts"! !

!SpAbstractWidgetPresenter methodsFor: 'private - traversing' stamp: ''!
traversePresentersDo: aBlock excluding: excludes
	"Terminate"

	excludes add: self.
	aBlock value: self! !

!SpAbstractWidgetPresenter methodsFor: 'initialization' stamp: ''!
defaultColor
	^ self theme backgroundColor! !

!SpAbstractWidgetPresenter methodsFor: 'TOREMOVE' stamp: ''!
color
	^ color! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
documentTransmissionsProtocol

	^ #'*Spec2-Transmission'! !

!SpAbstractWidgetPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpAbstractWidgetLayout for: self adapterName! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentExtraSections: aBuilder
	"a hook to add extra sections when needed"
	! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentSectionHierarchy: aBuilder
	
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Hierarchy' ] withLevel: 2.
	SpDocumentHierarchyBuilder new
		builder: aBuilder;
		filter: [ :eachClass | eachClass package packageName beginsWith: 'Spec2-' ];
		buildFor: self! !

!SpAbstractWidgetPresenter class methodsFor: 'testing' stamp: ''!
isWindow

	^ false! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentSectionFactoryMethod: aBuilder
	| selector |

	selector := self documentFactoryMethodSelector. 
	selector ifNil: [ ^ self ].
	 
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Factory method' ] withLevel: 2.
	aBuilder newLine.
	aBuilder text: 'You can use '. 
	aBuilder monospace: self name. 
	aBuilder text: ' in your presenters by sending '.
	aBuilder monospace: 'SpPresenter>>#', selector.
	aBuilder text: '.'! !

!SpAbstractWidgetPresenter class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpAbstractWidgetPresenter! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ nil! !

!SpAbstractWidgetPresenter class methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
sampleInstanceForTest

	^ self new! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
documentExampleCode
	| exampleMethod |
	
	exampleMethod := self class methods 
		detect: [ :each | 
			(each protocol = self documentExamplesProtocol) 
			and: [ each selector = self documentExampleCodeSelector ] ]
		ifNone: [ ^ nil ].
			
	^ (exampleMethod sourceCode lines 
		allButFirst 	"Remove method name"
		reject: [ :each | each trimLeft beginsWith: '<' ]) "Remove pragmas"
		asStringWithCr
		trimmed! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentSectionExampleCode: aBuilder
	| exampleCode |

	exampleCode := self documentExampleCode. 
	exampleCode ifNil: [ ^ self ].
	
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Example code' ] withLevel: 2.
	aBuilder newLine.
	aBuilder codeblock: exampleCode! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
documentExampleCodeSelector
	
	^ #example! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
documentSections
		
	^ OrderedDictionary newFromPairs: {
		'Examples'. self class methods select: [ :each | each protocol = self documentExamplesProtocol ].
		'API Methods'. self methods select: [ :each | each protocol = #'api' ].
		'Testing Methods'. self methods select: [ :each | each protocol = #'testing' ].
		'Events'. self methods select: [ :each | each protocol = #'api - events' ].
	 }! !

!SpAbstractWidgetPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ self subclassResponsibility! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentSectionTransmissions: aBuilder
	| transmissions defaultInputPort defaultOutputPort |
	
	transmissions := self methods select: [ :each | 
		(each protocol = self documentTransmissionsProtocol) 
		and: [ (each selector beginsWith: 'default') not ] ].
	transmissions ifEmpty: [ ^ self ].
	
	self methods 
		detect: [ :each | each selector = #defaultInputPort ]
		ifFound: [ :aMethod | defaultInputPort := aMethod literals first ].
	self methods 
		detect: [ :each | each selector = #defaultOutputPort ]
		ifFound: [ :aMethod | defaultOutputPort := aMethod literals first ].
	
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Transmissions' ] withLevel: 2.
	aBuilder unorderedListDuring: [  
		(transmissions sorted: #selector ascending) do: [ :each |
			aBuilder item: [
				aBuilder monospace: (each methodClass name, '>>#', each selector).
				(each selector = defaultInputPort or: [ each selector = defaultOutputPort  ])
					ifTrue: [ aBuilder monospace: ' (default)' ] ] ] ]! !

!SpAbstractWidgetPresenter class methodsFor: '*Spec2-Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	super buildMicroDownUsing: aBuilder withComment: aString.

	"Example code"
	self addDocumentSectionExampleCode: aBuilder.
	"Factory method"
	self addDocumentSectionFactoryMethod: aBuilder.
	"Sections"
	self documentSections keysAndValuesDo: [ :label :methods |
		self addDocumentSection: aBuilder label: label methods: methods ].
	"Hook for extra sections"
	self addDocumentExtraSections: aBuilder.
	"Hierarchy"
	self addDocumentSectionHierarchy: aBuilder.
	"Transmissions"
	self addDocumentSectionTransmissions: aBuilder.	! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
documentExamplesProtocol
	
	^ #'*Spec2-Examples'! !

!SpAbstractWidgetPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentSection: aBuilder label: label methods: methods
	
	methods ifEmpty: [ ^ self ].
	
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: label ] withLevel: 2.
	aBuilder unorderedListDuring: [  
		(methods sorted: #selector ascending) do: [ :each |
			aBuilder item: [
				aBuilder monospace: (each methodClass name, '>>#', each selector) ] ] ]! !

!SpAbstractWidgetPresenterDeferringActionTest methodsFor: 'tests' stamp: ''!
testWithAdapterPerformOrDeferDoesNotExecuteWhenNoAdapter
	| presenter executed |
	
	presenter := SpAbstractWidgetPresenter new.
	executed := false.
	presenter withAdapterPerformOrDefer: [ :anAdapter | executed := true ].
	
	self deny: executed! !

!SpAbstractWidgetPresenterDeferringActionTest methodsFor: 'tests' stamp: ''!
testWithAdapterPerformOrDeferExecutesWhenAdapter
	| presenter executed |
	
	presenter := SpAbstractWidgetPresenter new.
	presenter adapter: Object new.
	presenter withAdapterPerformOrDefer: [ :anAdapter | 
		executed := anAdapter. ].
	self assert: executed notNil! !

!SpAcceptChangesCommand methodsFor: 'execution' stamp: ''!
execute

	self context triggerSubmitAction! !

!SpAcceptChangesCommand class methodsFor: 'defaults' stamp: ''!
defaultShortcutKey

	^ $s command mac | $s ctrl win | $s ctrl unix! !

!SpAcceptChangesCommand class methodsFor: 'defaults' stamp: ''!
defaultIconName
	^#smallOk ! !

!SpAcceptChangesCommand class methodsFor: 'defaults' stamp: ''!
defaultName

	^ 'Accept'! !

!SpActionBarPresenter commentStamp: ''!
A full width bar designed to present contextual actions. 
It is expected to be displayed below the content and expand horizontally to fill the area.
This is like the small action bars at the bottom of a list in most mobile apps (or macOS), which shows small icons with actions.
!
!SpActionBarPresenter methodsFor: 'private - traversing' stamp: ''!
presentersInFocusOrder

	^ self presenters! !

!SpActionBarPresenter methodsFor: 'api' stamp: ''!
add: aButtonPresenter
	"Add a button presenter to be shown at the start of the action bar (at the left)."
	
	(items 
		at: #start
		ifAbsentPut: [ OrderedCollection new ] ) 
		add: aButtonPresenter! !

!SpActionBarPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	items := Dictionary new asValueHolder! !

!SpActionBarPresenter methodsFor: 'private - traversing' stamp: ''!
presenters

	^ self items values flattened! !

!SpActionBarPresenter methodsFor: 'api' stamp: ''!
items
	"Answer a dictionary containing the pairs:  
		#start -> anOrderedCollection, 
		#end -> anOrderedCollection"

	^ items value! !

!SpActionBarPresenter methodsFor: 'private - traversing' stamp: ''!
traverseInFocusOrderDo: aBlock excluding: excludes

	self presentersInFocusOrder do: [ :each |
		each traverseInFocusOrderDo: aBlock excluding: excludes ]! !

!SpActionBarPresenter methodsFor: 'api' stamp: ''!
addLast: aButtonPresenter
	"Add a button presenter to be shown at the end of the action bar (at the right)."

	(items 
		at: #end
		ifAbsentPut: [ OrderedCollection new ] ) 
		add: aButtonPresenter! !

!SpActionBarPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newActionBar! !

!SpActionBarPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	| presenter list actionBar |

	"A generic presenter with a list and an action bar"	
	(presenter := SpPresenter new) 
		layout: (SpBoxLayout newTopToBottom 
			add: (list := presenter newList);
			add: (actionBar := presenter newActionBar) expand: false;
			yourself).	
		
	"some settings to the list (to not have the presenter empty)"
	list 
		items: Smalltalk allClassesAndTraits;
		displayIcon: [ :aClass | aClass systemIcon ];
		display: [ :aClass | aClass name ].
		
	"now, we add some buttons to our action bar"
	actionBar 
		add: (presenter newButton
			icon: (presenter application iconNamed: #smallAdd);
			label: 'Add';
			yourself);
		addLast: (presenter newButton 
			icon: (presenter application iconNamed: #smallDelete);
			label: 'Delete';
			yourself);
		addLast: (presenter newButton
			icon: (presenter application iconNamed: #smallCopy);
			label: 'Copy';
			yourself).
			
	^ presenter openWithSpec! !

!SpActionBarPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ActionBarAdapter! !

!SpActionBarPresenterBuilder commentStamp: ''!
I build a ActionBarPresenter from a group of commands.

To do that, I visit recursively groups of command breadth first and simple add each command encountered to the action bar.!
!SpActionBarPresenterBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self actionBarPresenter: SpActionBarPresenter new.! !

!SpActionBarPresenterBuilder methodsFor: 'accessing' stamp: ''!
actionBarPresenter
	^ actionBarPresenter! !

!SpActionBarPresenterBuilder methodsFor: 'visiting' stamp: ''!
visitCommand: aCmCommandEntry 
	aCmCommandEntry positionStrategy
		addButton: aCmCommandEntry asButtonPresenter
		toActionBar: self actionBarPresenter! !

!SpActionBarPresenterBuilder methodsFor: 'accessing' stamp: ''!
actionBarPresenter: anObject
	actionBarPresenter := anObject! !

!SpActionPort commentStamp: ''!
!! Action Input Port (==SpActionPort==)
An ""action input port"" s a generic action to handle the result of a transmission: Instead transmit to a destination presenter, it will execute an action block. 

[[[language=Smalltalk
aPresenter 
	transmitDo: [ :aValue | ... ]
	transform: #asString
]]]

""Important:"" This port is not meant to be used in the same way other input ports, instead, you will use the ==#transmitDo:== mechanism.!
!SpActionPort methodsFor: 'accessing' stamp: ''!
action: aBlock

	actionBlock := aBlock! !

!SpActionPort methodsFor: 'accessing' stamp: ''!
action 

	^ actionBlock! !

!SpActionPort methodsFor: 'handling transmission' stamp: ''!
applyIncomingTransmission: anObject from: outPort to: aPresenter

	self error: 'Should not arrive here'! !

!SpActionPort methodsFor: 'handling transmission' stamp: ''!
incomingTransmission: anObject from: outPort

	self action 
		cull: anObject
		cull: outPort ! !

!SpActionPort class methodsFor: 'instance creation' stamp: ''!
newAction: aBlock

	^ self new
		action: aBlock;
		yourself! !

!SpActionPort class methodsFor: 'accessing' stamp: ''!
portName
	"An action block does not has a name"
	
	^ nil! !

!SpActivatedSelection commentStamp: ''!
I'm a simple object to wrap a selected item for an `SpActivationTransform`.!
!SpActivatedSelection methodsFor: 'accessing' stamp: ''!
value: anObject

	value := anObject! !

!SpActivatedSelection methodsFor: 'accessing' stamp: ''!
selectedItem

	^ value! !

!SpActivatedSelection methodsFor: 'accessing' stamp: ''!
value

	^ value! !

!SpActivationPort commentStamp: ''!
!! Activation Output Port (==SpActivationPort==)
A ""selection output port"" will handle the transmission when a presenter can be activated (e.g. lists).

The presenter exposing a selection output port need to define also the event ==#whenActivatedDo:==.

Presenters exposing this port: *class:SpAbstractListPresenter* subclasses and *class:SpTreeTablePresenter*!
!SpActivationPort methodsFor: 'attaching' stamp: ''!
attachTransmission: aTransmission to: aPresenter

	aPresenter whenActivatedDo: [ :selection | 
		self 
			transmitWith: aTransmission 
			value: (self applyTransform: selection) ]! !

!SpActivationPort class methodsFor: 'accessing' stamp: ''!
portName

	^ 'activation'! !

!SpActivationTransform methodsFor: 'evaluating' stamp: ''!
value: aSelection

	^ self cull: aSelection! !

!SpActivationTransform methodsFor: 'accessing' stamp: ''!
block: aBlock

	block := aBlock! !

!SpActivationTransform methodsFor: 'evaluating' stamp: ''!
cull: aSelection

	^ block cull: (SpActivatedSelection new 
		value: (transformBlock value: aSelection);
		yourself).! !

!SpActivationTransform methodsFor: 'accessing' stamp: ''!
transformBlock: aBlock

	transformBlock := aBlock! !

!SpActivationTransform class methodsFor: 'instance creation' stamp: ''!
activateDo: aBlock transform: transformBlock

	^ self new
		block: aBlock;
		transformBlock: transformBlock;
		yourself! !

!SpAdapterBindings commentStamp: ''!
I am an abstract class

I am used to link a spec-oriented adapter name to a framework specific adapter class name!
!SpAdapterBindings methodsFor: 'utilities' stamp: ''!
adapterClass: aSymbol 
	
	^ Smalltalk 
		at: (self translateSymbol: aSymbol) 
		ifAbsent: [ aSymbol ]! !

!SpAdapterBindings methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	bindings := Dictionary new.
	self initializeBindings! !

!SpAdapterBindings methodsFor: 'accessing' stamp: ''!
abstractAdapterClass
	
	^ self subclassResponsibility! !

!SpAdapterBindings methodsFor: 'initialization' stamp: ''!
initializeBindings
	
	self allAdapters do: [ :each |
		bindings 
			at: each adaptingName 
			put: each name.
		each adaptingAliases do: [ :eachAlias |
			bindings 
				at: eachAlias 
				put: each name ] ]	! !

!SpAdapterBindings methodsFor: 'accessing' stamp: ''!
allAdapters
	^ self abstractAdapterClass allAdapters! !

!SpAdapterBindings methodsFor: 'protocol' stamp: ''!
translateSymbol: aSymbol

	^ bindings 
		at: aSymbol
		ifAbsent: [ aSymbol ]! !

!SpAdapterBindings class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self name = #SpAdapterBindings! !

!SpAfterTestInitializationStrategy commentStamp: ''!
I open the spec instances once the entire fixture and stimuli has run on it.
Then, assertions are run on an open presenter that should have been correctly configured.!
!SpAfterTestInitializationStrategy methodsFor: 'running' stamp: ''!
beforeAssertInTest: aSpecTest
	
	"Assume openInstance will open it only the first time"
	aSpecTest openInstance.! !

!SpApplication commentStamp: ''!
I'm a class that handles many aspects of a Spec Application (hence its name) in a convenient fashion. 
I handle your application initialization, configuration, and its resources. I also keep the windows you have currently opened. 
I'm shared among the presenters that compose the application. This way a common icon manager can be shared between all the presenters.

## Initialization
During initialization of an application, it can optionally configure the backend you want to use, add useful resources, and define a `start` method that will call your initial window.

### Configure backend
Spec2 includes several backends (for the moment, Morphic and Gtk). A SpApplication configures a Morphic backend by default, but you can change it using `useBackend:` or `#useBackend:with:` and sending the backend identifier and optionally a configuration (you may want to do specific backend things to configure your application behavior.

####NOTE: 
It is  important that after you initiate your application, you ==run== it.

The following example shows how to change the backend of an application. 

```

| app |
"You want to subclass SpApplication to create your app"
app := SpApplication new.
app useBackend: #Gtk.
app run
```
See also: `SpApplicationConfiguration`

## Add resources
During initialization, you may want to add special resources (like icons, themes, etc.).
While you can add your own way to access resources, `SpApplication` provides a property registration mechanism (a simple Dictionary and accessors), you may find useful to browse the `accessing properties` protocol.


## Defining a start method.
This is useful to give your application a starting window (in general, this is what you want).

Example: 
```
MyApplication>>start

   (self new: MyMainPresenter) openWithSpec
```

!
!SpApplication methodsFor: 'accessing - properties' stamp: ''!
propertyAt: aKey

	^ self properties at: aKey! !

!SpApplication methodsFor: 'accessing' stamp: ''!
locale

	^ Locale current! !

!SpApplication methodsFor: '*Spec2-Dialogs' stamp: ''!
newRequest

	^ SpRequestDialog newApplication: self! !

!SpApplication methodsFor: 'accessing' stamp: ''!
windows
	
	^ windows ifNil: [ windows := Set new ]! !

!SpApplication methodsFor: 'ui' stamp: ''!
showWaitCursorWhile: aBlock

	self backend 
		showWaitCursorWhile: aBlock 
		inApplication: self! !

!SpApplication methodsFor: 'accessing - backend' stamp: ''!
configuration

	^ configuration! !

!SpApplication methodsFor: 'windows' stamp: ''!
windowClosed: aWindowPresenter
	
	self unregisterWindow: aWindowPresenter! !

!SpApplication methodsFor: 'accessing - properties' stamp: ''!
propertyAt: aKey put: aValue

	^ self properties 
		at: aKey
		put: aValue! !

!SpApplication methodsFor: 'private' stamp: ''!
unregisterWindow: aWindow

	self windows remove: aWindow ifAbsent: [  ]! !

!SpApplication methodsFor: 'running' stamp: ''!
run 

	self start! !

!SpApplication methodsFor: 'icons' stamp: ''!
iconManager: anIconManager

	iconManager := anIconManager 
	! !

!SpApplication methodsFor: 'accessing - resources' stamp: ''!
iconProvider

	^ iconProvider ifNil: [ iconProvider := self newIconProvider ]! !

!SpApplication methodsFor: '*Spec2-Dialogs' stamp: ''!
newConfirm

	^ SpConfirmDialog newApplication: self! !

!SpApplication methodsFor: 'factory' stamp: ''!
newPresenter: aPresenterClass

	^ aPresenterClass newApplication: self! !

!SpApplication methodsFor: '*Spec2-Dialogs' stamp: ''!
newInform

	^ SpInformDialog newApplication: self! !

!SpApplication methodsFor: 'showing' stamp: ''!
defaultDialogWindowPresenterClass
		
	^ SpDialogWindowPresenter! !

!SpApplication methodsFor: 'ui - notifying' stamp: ''!
notify: aSpecNotification
	"how notifications are handled depends on the backend"

	aSpecNotification dispatchTo: self backend! !

!SpApplication methodsFor: '*Spec2-Dialogs' stamp: ''!
newRequestText

	^ SpRequestTextDialog newApplication: self! !

!SpApplication methodsFor: 'accessing - properties' stamp: ''!
propertyAt: aKey ifPresent: aBlock ifAbsentPut: absentBlock

	^ self properties
		at: aKey 
		ifPresent: aBlock
		ifAbsentPut: absentBlock! !

!SpApplication methodsFor: 'showing' stamp: ''!
defaultBlockedDialogWindowPresenterClass

	^ SpBlockedDialogWindowPresenter! !

!SpApplication methodsFor: 'showing' stamp: ''!
defaultModalWindowPresenterClass
		
	^ SpModalWindowPresenter! !

!SpApplication methodsFor: 'private' stamp: ''!
adapterBindings
	
	^ self backend adapterBindings! !

!SpApplication methodsFor: 'showing' stamp: ''!
defaultWindowPresenterClass
		
	^ SpWindowPresenter! !

!SpApplication methodsFor: 'accessing' stamp: ''!
topWindow

	^ self windows 
		detect: [ :each | each isTopWindow ]
		ifNone: [ nil ]! !

!SpApplication methodsFor: 'accessing - backend' stamp: ''!
useBackend: aName with: aConfiguration

	self useBackend: aName.
	configuration := aConfiguration.
	aConfiguration configure: self! !

!SpApplication methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
styleSheet: aStyleClass

	^ self 
		propertyAt: #styleSheet 
		put: aStyleClass! !

!SpApplication methodsFor: '*Spec2-CommandLine' stamp: ''!
prepareAsStandaloneApplication
	"override this to specify  standalone settings"! !

!SpApplication methodsFor: 'accessing - properties' stamp: ''!
propertyAt: aKey ifPresent: aBlock ifAbsent: absentBlock

	^ self properties
		at: aKey 
		ifPresent: aBlock
		ifAbsent: absentBlock! !

!SpApplication methodsFor: 'accessing - properties' stamp: ''!
propertyAt: aKey ifAbsentPut: aBlock

	^ self properties 
		at: aKey
		ifAbsentPut: aBlock! !

!SpApplication methodsFor: 'showing' stamp: ''!
close
	
	self 
		deprecated: 'Use #closeAllWindows instead' 
		transformWith: '`@receiver close' -> '`@receiver closeAllWindows'.
	self closeAllWindows! !

!SpApplication methodsFor: 'ui' stamp: ''!
forceDefer: aBlock
	"doInUIThread: ?"
	self backend forceDefer: aBlock! !

!SpApplication methodsFor: 'accessing - resources' stamp: ''!
iconNamed: aString

	^ self iconProvider iconNamed: aString! !

!SpApplication methodsFor: 'accessing - properties' stamp: ''!
propertyAt: aKey ifAbsent: aBlock

	^ self properties 
		at: aKey
		ifAbsent: aBlock! !

!SpApplication methodsFor: 'accessing' stamp: ''!
reset 

	self closeAllWindows.
	windows removeAll.
	self backend resetAdapterBindings! !

!SpApplication methodsFor: 'ui - dialogs' stamp: ''!
selectFileTitle: aString

	^ self backend selectFileTitle: aString! !

!SpApplication methodsFor: 'accessing - backend' stamp: ''!
useBackend: aName

	backend := SpApplicationBackend findBackendNamed: aName! !

!SpApplication methodsFor: 'private' stamp: ''!
registerWindow: aWindow

	self windows add: aWindow! !

!SpApplication methodsFor: 'ui - dialogs' stamp: ''!
selectDirectoryTitle: aString

	^ self backend selectDirectoryTitle: aString! !

!SpApplication methodsFor: 'accessing - backend' stamp: ''!
backend

	^ backend ifNil: [ 
		self useBackend: self class defaultBackendName.
		backend ]! !

!SpApplication methodsFor: 'accessing' stamp: ''!
closeAllWindows

	self windows do: [ :each | each close ]! !

!SpApplication methodsFor: 'icons' stamp: ''!
iconManager

	^ iconManager ifNil: [ iconManager := Smalltalk ui icons ]! !

!SpApplication methodsFor: 'factory' stamp: ''!
new: aPresenter
	"a synonym for #newPresenter:"
	
	^ self newPresenter: aPresenter! !

!SpApplication methodsFor: 'accessing - properties' stamp: ''!
propertyAt: aKey ifPresent: aBlock

	^ self properties
		at: aKey 
		ifPresent: aBlock! !

!SpApplication methodsFor: '*Spec2-Dialogs' stamp: ''!
newSelect

	^ SpSelectDialog newApplication: self! !

!SpApplication methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
styleSheet
	"A stylesheet defines the application style. 
	 You can defins your own (but it don't, we will take the default)"

	^ self 
		propertyAt: #styleSheet 
		ifAbsent: [ SpStyle defaultStyleSheet ]! !

!SpApplication methodsFor: 'accessing - properties' stamp: ''!
properties

	^ properties ifNil: [ properties := SmallDictionary new ]! !

!SpApplication methodsFor: 'private - factory' stamp: ''!
newIconProvider
	
	^ SpPharoThemeIconProvider new! !

!SpApplication methodsFor: 'running' stamp: ''!
start 
	"Override this to start your app"! !

!SpApplication methodsFor: '*Spec2-Dialogs' stamp: ''!
newProgress

	^ SpProgressDialog newApplication: self! !

!SpApplication methodsFor: 'ui' stamp: ''!
defer: aBlock
	"doInUIThread: ?"
	self backend defer: aBlock! !

!SpApplication methodsFor: 'testing' stamp: ''!
hasWindow: aWindow
	
	^ self windows includes: aWindow! !

!SpApplication class methodsFor: 'accessing' stamp: ''!
defaultBackendName

	^ #Morphic! !

!SpApplication class methodsFor: '*Spec2-CommandLine' stamp: ''!
applicationName

	^ nil! !

!SpApplication class methodsFor: '*Spec2-CommandLine' stamp: ''!
findNamed: aString ifNone: aBlock

	^ self allSubclasses 
		detect: [ :each | each applicationName = aString ]
		ifNone: aBlock! !

!SpApplication class methodsFor: 'examples' stamp: ''!
example1
	"This example shows how to change the backend of an application" 
	| app |
	
	"You want to subclass SpApplication to create your app"
	app := SpApplication new.
	app useBackend: #Gtk.
	app run! !

!SpApplication class methodsFor: '*Spec2-CommandLine' stamp: ''!
findAll

	^ self allSubclasses select: [ :each | each applicationName notNil ] ! !

!SpApplication class methodsFor: 'private' stamp: ''!
defaultApplication: anApplication
	"To be used for testing purposes"

	DefaultApplication := anApplication! !

!SpApplication class methodsFor: 'accessing' stamp: ''!
defaultApplication

	^ DefaultApplication ifNil: [ DefaultApplication := SpNullApplication new ]! !

!SpApplication class methodsFor: 'examples' stamp: ''!
example2
	"This example shows how to change the backend of an application" 
	| app |
	
	"You want to subclass SpApplication to create your app"
	app := SpApplication new.
	"You want to subclass SpGtkConfiguration to create your own cofiguration"
	app useBackend: #Gtk with: SpApplicationConfiguration new.
	app run! !

!SpApplicationBackend commentStamp: ''!
I'm a backend for a Spec applications. 
Backends define different things from an application: 
- which UI backend will use (Morphic by default), 
- access to system resources (such as icons),
- access to standard dialogs usually residing in the operating system (but also simulated)
- ...!
!SpApplicationBackend methodsFor: 'initialization' stamp: ''!
resetAdapterBindings

	adapterBindings := self adapterBindingsClass new! !

!SpApplicationBackend methodsFor: 'accessing' stamp: ''!
adapterBindings

	^ adapterBindings! !

!SpApplicationBackend methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self resetAdapterBindings! !

!SpApplicationBackend methodsFor: 'ui - notifying' stamp: ''!
notifyInfo: aSpecNotification

	self subclassResponsibility! !

!SpApplicationBackend methodsFor: 'accessing' stamp: ''!
name

	^ self class backendName! !

!SpApplicationBackend methodsFor: 'private' stamp: ''!
adapterBindingsClass

	self subclassResponsibility! !

!SpApplicationBackend methodsFor: 'ui - notifying' stamp: ''!
notify: aSpecNotification

	aSpecNotification type 
		notify: aSpecNotification
		on: self! !

!SpApplicationBackend methodsFor: 'ui - notifying' stamp: ''!
notifyError: aSpecNotification

	self subclassResponsibility! !

!SpApplicationBackend methodsFor: 'ui' stamp: ''!
showWaitCursorWhile: aBlock inApplication: anApplication

	self subclassResponsibility! !

!SpApplicationBackend methodsFor: 'ui - dialogs' stamp: ''!
selectFileTitle: aString

	self subclassResponsibility! !

!SpApplicationBackend class methodsFor: 'accessing' stamp: ''!
backendName

	^ self subclassResponsibility! !

!SpApplicationBackend class methodsFor: 'accessing' stamp: ''!
findBackendNamed: aName

	^ (self allSubclasses 
		detect: [ :each | each backendName = aName ])
		new	! !

!SpApplicationConfiguration commentStamp: ''!
I'm responsible to handle application configurations for different back-ends. 

Typically, each Spec application will implement one or several configurations (for example, to run on Morphic or Gtk) by extending this class or one of its children. 
A configuration takes the responsibility to prepare an application to run properly. This preparation can be different depending on the platform where it is running, that's why you have several extension points you can extend/override: 

- `configure:` a generic configuration point that normally will dispatch the configuration to a plarform specific method. 
- `configureOSX:`/`configureUnix:`/`configureWindows:` platform specific entry points.

See also: `SpMorphicConfiguration` and `SpGtkConfiguration`!
!SpApplicationConfiguration methodsFor: 'configuring' stamp: ''!
configureUnix: anApplication! !

!SpApplicationConfiguration methodsFor: 'configuring' stamp: ''!
configure: anApplication
	"Override this to add your application configuration"
	
	OSPlatform current 
		configureApplication: anApplication 
		configuration: self! !

!SpApplicationConfiguration methodsFor: 'configuring' stamp: ''!
configureOSX: anApplication! !

!SpApplicationConfiguration methodsFor: 'configuring' stamp: ''!
configureWindows: anApplication! !

!SpApplicationTest methodsFor: 'running' stamp: ''!
tearDown
	
	application close.
	super tearDown! !

!SpApplicationTest methodsFor: 'tests' stamp: ''!
testCloseWindowRemovesItFromWindowCollection
	| window |
	
	application := SpApplication new.
	window := (application newPresenter: SpButtonPresenter) openWithSpec.
	window close.
	self deny: (application windows includes: window)! !

!SpApplicationTest methodsFor: '*Spec2-Adapters-Morphic-Tests' stamp: ''!
testAdapterBindings

	self assert: application adapterBindings class equals: SpStubAdapterBindings.
	application useBackend: #Morphic.
	self assert: application adapterBindings class equals: SpMorphicAdapterBindings
	! !

!SpApplicationTest methodsFor: 'tests' stamp: ''!
testOpenDialogWindowAddsItToWindowCollection
	| window |
	window := (application newPresenter: SpButtonPresenter) openDialogWithSpec.
	
	self assert: (application windows includes: window)! !

!SpApplicationTest methodsFor: 'tests' stamp: ''!
testUseBackend

	self assert: application backend name equals: #Mock.
	application useBackend: #Morphic.
	self assert: application backend name equals: #Morphic! !

!SpApplicationTest methodsFor: 'tests' stamp: ''!
testCloseDialogWindowRemovesItFromWindowCollection
	| window |

	application := SpApplication new.
	window := (application newPresenter: SpButtonPresenter) openDialogWithSpec.
	window close.
	self deny: (application windows includes: window)! !

!SpApplicationTest methodsFor: 'tests' stamp: ''!
testNewPresenter
	| presenter |

	presenter := application newPresenter: SpButtonPresenter.
	self assert: presenter application equals: application! !

!SpApplicationTest methodsFor: 'tests' stamp: ''!
testOpenWindowAddsItToWindowCollection
	| window |
	window := (application newPresenter: SpButtonPresenter) openWithSpec.
	
	self assert: (application windows includes: window)! !

!SpApplicationTest methodsFor: 'tests' stamp: ''!
testIsPresenter

	self deny: application isPresenter ! !

!SpApplicationTest methodsFor: 'running' stamp: ''!
setUp
	
	super setUp.
	application := SpMockApplication new! !

!SpApplicationWithLocaleTest methodsFor: 'tests' stamp: ''!
testLabel
	| app label string |
	app := SpTestApplicationWithLocale new.
	app locale: (Locale isoLanguage: 'en' isoCountry: 'US').
	app useBackend: #Morphic.
	string := SpTestLocalizedString from: 'string'.
	label := app newPresenter: SpLabelPresenter.
	label label: string.	
	label openWithSpec.
	self assert: label adapter widget contents equals: 'string[en-US](1)'.

	app locale: (Locale isoLanguage: 'de' isoCountry: 'DE').
	label localeChanged.
	self assert: label adapter widget contents equals: 'string[de-DE](2)'.
	
	label window close.! !

!SpApplicationWithToolbar commentStamp: ''!
I am a simple example showing how to use a menu model to have a menu toolbar.

self example!
!SpApplicationWithToolbar methodsFor: 'accessing' stamp: ''!
menu
	^ menu! !

!SpApplicationWithToolbar methodsFor: 'initialization' stamp: ''!
initializePresenters
	menu := self newMenuBar
		addGroup: [ :group | 
			group
				addItem: [ :item | 
					item
						name: 'File';
						icon: (self iconNamed: #openIcon);
						subMenu: self subMenu ].
			group
				addItem: [ :item | 
					item
						name: '';
						description: 'Open file';
						icon: (self iconNamed: #openIcon);
						action: [ self inform: 'Open File' ] ].
			group
				addItem: [ :item | 
					item
						name: '';
						description: 'Save File';
						icon: (self iconNamed: #smallSaveIcon);
						action: [ self inform: 'Save File' ] ].
			group
				addItem: [ :item | 
					item
						name: '';
						description: 'Print file';
						icon: (self iconNamed: #smallPrintIcon);
						action: [ self inform: 'Print file' ] ] ];
		addGroup: [ :group | 
			group
				addItem: [ :item | 
					item
						name: '';
						description: 'Undo';
						icon: (self iconNamed: #smallUndoIcon);
						action: [ self inform: 'Undo' ] ].
			group
				addItem: [ :item | 
					item
						name: '';
						description: 'Redo';
						icon: (self iconNamed: #smallRedoIcon);
						action: [ self inform: 'Redo' ] ] ];
		addGroup: [ :group | 
			group
				addItem: [ :item | 
					item
						name: '';
						description: 'Add menu item';
						icon: (self iconNamed: #add);
						action: [ self addItemTo: group ] ] ].
	menu addKeybindingsTo: self.
	text := self newText.
	self focusOrder add: text! !

!SpApplicationWithToolbar methodsFor: 'initialization' stamp: ''!
addItemTo: aGroup
	aGroup
		addItem: [ :item | 
			item
				name: 'Dynamic';
				icon: (self iconNamed: #delete);
				action: [ aGroup menuItems remove: item.
					self needRebuild: false.
					self buildWithSpec ] ].
	self needRebuild: false.
	self buildWithSpec! !

!SpApplicationWithToolbar methodsFor: 'api' stamp: ''!
title

	^ 'Text editor'! !

!SpApplicationWithToolbar methodsFor: 'initialization' stamp: ''!
subMenu
	^ self newMenu
		addItem: [ :item | 
			item
				name: 'Open';
				icon: (self iconNamed: #openIcon);
				shortcut: $o meta;
				action: [ self inform: 'Open' ] ];
		addItem: [ :item | 
			item
				name: 'Save';
				icon: (self iconNamed: #smallSaveIcon);
				shortcut: $s meta;
				action: [ self inform: 'Save' ] ];
		addItem: [ :item | 
			item
				name: 'Print';
				shortcut: $p meta;
				icon: (self iconNamed: #smallPrintIcon);
				action: [ self inform: 'Print' ] ];
		addItem: [ :item | 
			item
				name: 'Kill';
				shortcut: $k meta;
				icon: (self iconNamed: #smallCancelIcon);
				action: [ self inform: 'Kill' ] ];
		yourself! !

!SpApplicationWithToolbar methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!SpApplicationWithToolbar class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #menu withConstraints: [ :constraints | constraints height: self toolbarHeight ];
		add: #text;
		yourself! !

!SpApplicationWithToolbar class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new openWithSpec! !

!SpApplicationWithToolbarTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpApplicationWithToolbar! !

!SpAthensAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpAthensPresenter! !

!SpAthensAdapterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance
	presenter drawBlock: [ "nothing to do" ].
	presenter surfaceExtent: 800@600! !

!SpAthensAdapterTest methodsFor: 'tests' stamp: ''!
testContextMenu
	| menu changed |
	
	self assert: presenter contextMenu isNil.
	menu := SpMenuPresenter new.
	changed := false.
	presenter whenMenuChangedDo: [ 
		changed := true. ].
	presenter contextMenu: menu.
	self assert: presenter contextMenu equals: menu.
	self assert: changed! !

!SpAthensAdapterTest methodsFor: 'accessing' stamp: ''!
circle: aSurface
	^ aSurface
		createPath: [ :builder | 
			builder
				absolute;
				moveTo: 50 @ 150;
				ccwArcTo: 150 @ 250 angle: 90 degreesToRadians;
				ccwArcTo: 250 @ 150 angle: 90 degreesToRadians;
				ccwArcTo: 150 @ 50 angle: 90 degreesToRadians;
				ccwArcTo: 50 @ 150 angle: 90 degreesToRadians]! !

!SpAthensAdapterTest methodsFor: 'tests' stamp: ''!
testPresentersBlockReceivesAthensCanvas
	| receivedCanvas |
	self presenter drawBlock: [ :canvas | receivedCanvas := canvas ].
	self adapter redraw.
	self openInstance.
	
	1 second wait.
	self assert: receivedCanvas isNotNil.
	self assert: (receivedCanvas isKindOf: AthensCanvas)! !

!SpAthensAdapterTest methodsFor: 'tests' stamp: ''!
testResizeMakesCanvasResize
	| extent |
	
	self presenter drawBlock: [ :canvas |
		extent := canvas surface extent ].
	self openInstance.
	self presenter window resize: 500@500.
	backendForTest waitUntilUIRedrawed.
	self assert: extent x > 100. 
	self assert: extent y > 100.	
	self presenter window resize: 100@100.
	backendForTest waitUntilUIRedrawed.
	self assert: extent x < 100. 
	self assert: extent y < 100.! !

!SpAthensMorph commentStamp: ''!
It exposes an athens surface in a morph!
!SpAthensMorph methodsFor: 'drawing' stamp: ''!
drawOn: aMorphicCanvas

	self redraw.
	self surface 
		displayOnMorphicCanvas: aMorphicCanvas 
		at: bounds origin! !

!SpAthensMorph methodsFor: 'drawing' stamp: ''!
redraw

	self surface drawDuring: [ :canvas | 
		drawBlock 
			cull: canvas
			cull: (0@0 extent: self extent) ]! !

!SpAthensMorph methodsFor: 'accessing' stamp: ''!
drawBlock: aBlock

	drawBlock := aBlock! !

!SpAthensMorph methodsFor: 'accessing' stamp: ''!
surface
 
	lastExtent = self extent ifFalse: [ surface := nil ].
	^ surface ifNil: [ 
		lastExtent := self extent.
		surface := AthensCairoSurface extent: self extent ]! !

!SpAthensPresenter commentStamp: ''!
A presenter that contains an athens surface (See `AthensSurface` and `AthensSurfaceExamples class`). 
Users can draw their own vectorial images  and render them as part of a Spec based application by using this presenter.
!
!SpAthensPresenter methodsFor: 'api' stamp: ''!
drawBlock
	"Answer the block used to draw into an athens canvas."

	^ drawBlock! !

!SpAthensPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self surfaceExtent: self class defaultSurfaceExtent! !

!SpAthensPresenter methodsFor: 'api - events' stamp: ''!
whenExtentChangedDo: aBlock
	"Inform when the Athens surface extent has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #surfaceExtent whenChangedDo: aBlock ! !

!SpAthensPresenter methodsFor: 'api' stamp: ''!
contextMenu
	"Answer context menu or nil if there is none defined.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	^ contextMenu! !

!SpAthensPresenter methodsFor: 'api' stamp: ''!
redraw

	self withAdapterDo: [ :anAdapter | anAdapter redraw ]! !

!SpAthensPresenter methodsFor: 'api' stamp: ''!
drawBlock: aBlock
	"Set the block used to draw into the athens canvas.
	 `aBlock` receives one argument, the `AthensCanvas` instance used to draw the surface.
	 (See `SpAthensPresenter class>>#example` as an example of usage)"

	drawBlock := aBlock! !

!SpAthensPresenter methodsFor: 'api' stamp: ''!
surfaceExtent
	"Anwer the surface extent (the size the surface will have)"

	^ surfaceExtent! !

!SpAthensPresenter methodsFor: 'api - events' stamp: ''!
whenDrawBlockChangedDo: aBlock
	"Inform when drawBlock has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #drawBlock whenChangedDo: aBlock ! !

!SpAthensPresenter methodsFor: 'api' stamp: ''!
surfaceExtent: anExtent
	"Set surface extent (a point) to contain the athens drawing."

	surfaceExtent := anExtent! !

!SpAthensPresenter methodsFor: 'api' stamp: ''!
contextMenu: aValuableOrMenuPresenter
	"Set the context menu.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	contextMenu := aValuableOrMenuPresenter! !

!SpAthensPresenter methodsFor: 'api - events' stamp: ''!
whenMenuChangedDo: aBlock
	"Inform when menu definition changed. 
	 `aBlock` receives zero arguments."

	self property: #contextMenu whenChangedDo: aBlock! !

!SpAthensPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newAthens! !

!SpAthensPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	| extent |
	
	extent := 350@300.
	self new
		surfaceExtent: extent;
		drawBlock: [ :aCanvas | | paint surface |
			surface := aCanvas surface.
			paint := surface 
				createLinearGradient: { 
					0->Color red. 
					1->Color green } 
				start: 0@0 
				stop: extent.
			surface clear.
			aCanvas setPaint: paint.
			aCanvas drawShape: (0@0 corner: extent) ]; 
		openWithSpec! !

!SpAthensPresenter class methodsFor: 'specs' stamp: ''!
adapterName
	^ #AthensAdapter! !

!SpAthensPresenter class methodsFor: 'defaults' stamp: ''!
defaultSurfaceExtent

	^ 300@300! !

!SpAthensPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleResizing
	| extent |
	
	extent := 350@300.
	self new
		surfaceExtent: extent;
		drawBlock: [ :aCanvas :boundingBox | | paint surface |
			"Since sometimes a cairo surface does not brings the correct extent (in X11 or Windows, 
			 for example), we use the bounding box of the component."
			surface := aCanvas surface.
			paint := surface 
				createLinearGradient: { 
					0->Color red. 
					1->Color green } 
				start: 0@0 
				stop: boundingBox extent.
			surface clear.
			aCanvas setPaint: paint.
			aCanvas drawShape: (0@0 extent: boundingBox extent) ]; 
		openWithSpec! !

!SpBaseEventDefinition commentStamp: ''!
I am a base of event definitions for `SpEventHandler.` 
My children will define (and install in an adaptor/widget) a specific kind of low-level event.
!
!SpBaseEventDefinition methodsFor: 'accessing' stamp: ''!
action: anObject
	action := anObject! !

!SpBaseEventDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	self subclassResponsibility! !

!SpBaseEventDefinition methodsFor: 'accessing' stamp: ''!
action
	^ action! !

!SpBaseEventDefinition class methodsFor: 'enumerating' stamp: ''!
do: aBlock

	^ self new action: aBlock! !

!SpBaseTest methodsFor: 'accessing' stamp: ''!
classToTest
	self subclassResponsibility! !

!SpBaseTest methodsFor: 'tests' stamp: ''!
testNonOpenPresenterDoesNotRaiseBuiltEvent
	| built |
	built := false.
	presenter whenBuiltDo: [ built := true ].
	self deny: built! !

!SpBaseTest methodsFor: 'tests' stamp: ''!
testOpenPresenterRaisesDisplayEvent
	| displayed |
	displayed := false.
	presenter whenDisplayDo: [ displayed := true ].
	self openInstance.
	self assert: displayed! !

!SpBaseTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance! !

!SpBaseTest methodsFor: 'accessing' stamp: ''!
adapter

	^ self subclassResponsibility! !

!SpBaseTest methodsFor: 'running' stamp: ''!
tearDown
	window ifNotNil: [ window delete ].
	super tearDown! !

!SpBaseTest methodsFor: 'utilities' stamp: ''!
openInstance: aLayoutSelector
	window := presenter openWithSpec: aLayoutSelector! !

!SpBaseTest methodsFor: 'tests' stamp: ''!
testNonOpenPresenterDoesNotRaiseDisplayedEvent
	| displayed |
	displayed := false.
	presenter whenDisplayDo: [ displayed := true ].
	self deny: displayed! !

!SpBaseTest methodsFor: 'tests' stamp: ''!
testOpenPresenterIsBuilt
	self openInstance.
	self assert: presenter isBuilt! !

!SpBaseTest methodsFor: 'tests' stamp: ''!
testOpenPresenterIsDisplayed
	self openInstance.
	self assert: presenter isDisplayed! !

!SpBaseTest methodsFor: 'tests' stamp: ''!
testOpenPresenterRaisesBuiltEvent
	| built |
	built := false.
	presenter whenBuiltDo: [ built := true ].
	self openInstance.
	self assert: built! !

!SpBaseTest methodsFor: 'accessing' stamp: ''!
widget
	
	^ self adapter widget! !

!SpBaseTest methodsFor: 'assertions' stamp: ''!
denyEvent: anEventName isRaisedInPresenter: aPresenter whenDoing: aBlock
	
	self
		assertWith: [ :times | times = 0 ]
		timesRaisedEvent: anEventName
		inPresenter: aPresenter
		whenDoing: aBlock! !

!SpBaseTest methodsFor: 'assertions' stamp: ''!
assertWith: assertionBlock timesRaisedEvent: anEventName inPresenter: aPresenter whenDoing: actionBlock
	
	| timesCalled |
	timesCalled := 0.
	aPresenter perform: anEventName with: [ timesCalled := timesCalled + 1 ].
	actionBlock value.
	assertionBlock value: timesCalled! !

!SpBaseTest methodsFor: 'accessing' stamp: ''!
presenter
	^ presenter! !

!SpBaseTest methodsFor: 'utilities' stamp: ''!
openInstance
	window ifNil: [ window := presenter openWithSpec ]! !

!SpBaseTest methodsFor: 'assertions' stamp: ''!
assertEvent: anEventName isRaisedInPresenter: aPresenter whenDoing: aBlock
	
	self
		assertWith: [ :times | times > 0 ]
		timesRaisedEvent: anEventName
		inPresenter: aPresenter
		whenDoing: aBlock! !

!SpBaseTest methodsFor: 'tests' stamp: ''!
testNewPresenterIsNotBuilt
	self deny: presenter isBuilt! !

!SpBaseTest methodsFor: 'tests' stamp: ''!
testRebuildPresenterDoNotLetReferencesInAnnouncer
	| oldSize newSize |
	
	presenter buildWithSpec.
	oldSize := presenter announcer subscriptions subscriptions size.
	"rebuild"
	presenter buildWithSpec.
	newSize := presenter announcer subscriptions subscriptions size.
	
	self assert: oldSize equals: newSize! !

!SpBaseTest methodsFor: 'tests' stamp: ''!
testNewPresenterIsNotDisplayed
	self deny: presenter isDisplayed! !

!SpBaseTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	presenter := self classToTest new.
	self initializeTestedInstance! !

!SpBaseTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self = SpBaseTest! !

!SpBeforeTestInitializationStrategy commentStamp: ''!
I open the spec instances before the stimuli has run on it.
Then, all stimuli is run on an open presenter that should been correctly configured.!
!SpBeforeTestInitializationStrategy methodsFor: 'running' stamp: ''!
beforeTest: aSpecTest

	aSpecTest openInstance! !

!SpBindings commentStamp: ''!
I'm a dynamic variable for presenters on which a bindings (Morphic or other) should be used as default.

Example: 

```
	SpecBindings value: #MorphicAdapterBindings during: [ myPresenter openWithSpec ].
```!
!SpBindings methodsFor: 'accessing' stamp: ''!
default
	^ (self class environment at: #SpMorphicAdapterBindings) new! !

!SpBlockedDialogWindowPresenter commentStamp: ''!
I'm a special dialog presenter used to describe a **blocked** DialogWindow. 
Similar to `SpModalWindowPresenter` I will block the process until to get an answer, but without blocking the background.

Usually instances of `SpBlockedDialogWindowPresenter` are created using the method `SpAbstractPresenter>>#openBlockedDialogWithSpec`.
If you want to make the user to show a dialog without blocking the execution of other windows, use `SpAbstractPresenter>>#openDialogWithSpec` instead.

## Usage 
Typically, you do not instantiate directly a blocked dialog, but you open a presenter as one. Since the program execution will be stopped until dialog is resolved (accepted or cancelled), you can ask for the status after calling it.

```
dialog := aPresenter openBlockedDialogWithSpec.
dialog isOk 
	ifTrue: [ ""dialog accepted action"" ]
	ifFalse: [ ""dialof cancelled action "" ]
```

And to control how the dialog should behave, you define the method `initializeDialogWindow:` in your presenters.

```
SomePresenter >> initializeDialogWindow: aDialogPresenter 
	super initializeDialogWindow: aDialogPresenter.
	aDialogPresenter
		initialExtent: 600@400;
		title: 'A title';
		closeOnBackdropClick: true
```!
!SpBlockedDialogWindowPresenter class methodsFor: 'specs' stamp: ''!
adapterName
	^ #BlockedDialogWindowAdapter! !

!SpBoxConstraints commentStamp: ''!
I am the constraints that can be applied to a presenter placed into a box layout.
I can define: 

- expand: the widget will expand to take all the space the layout wants to give it.
- fill: the widget will fill the space taken (this property just has sense if expand=false)
- padding: the padding let before the next presenter.
- width/height: fixed width and height to take. !
!SpBoxConstraints methodsFor: 'accessing' stamp: ''!
width: aNumber
	"Width of component.
	 Set the constraint of the presenter to assign a specific width. 
	 This constraint is applied just when using a Horizontal (Left to Right) layout, 
	 otherwise is ignored.
	 Please notice that 99% of the time you DO NOT NEED (and you do not want) to use 
	 a fixed constraint like this one. 
	 Instead, consider using `SpBoxLayout>>#add:expand:` method, and let the component
	 take its 'natural' width (often defined in a style)."

	self expand: false.
	width := aNumber! !

!SpBoxConstraints methodsFor: 'accessing' stamp: ''!
bePlacedAtEnd

	placedAtStart := false! !

!SpBoxConstraints methodsFor: 'accessing' stamp: ''!
fill: aBoolean

	fill := aBoolean! !

!SpBoxConstraints methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	self bePlacedAtStart! !

!SpBoxConstraints methodsFor: 'accessing' stamp: ''!
width
	"width of component.
	 this just has sense in the case of expand=false"

	^ width! !

!SpBoxConstraints methodsFor: 'accessing' stamp: ''!
padding: aNumber

	padding := aNumber! !

!SpBoxConstraints methodsFor: 'accessing' stamp: ''!
bePlacedAtStart

	placedAtStart := true! !

!SpBoxConstraints methodsFor: 'testing' stamp: ''!
isPlacedAtStart
	
	^ placedAtStart! !

!SpBoxConstraints methodsFor: 'accessing' stamp: ''!
height
	"height of component.
	 this just has sense in the case of expand=false"

	^ height! !

!SpBoxConstraints methodsFor: 'accessing' stamp: ''!
height: aNumber
	"Height of component.
	 Set the constraint of the presenter to assign a fixed height. 
	 This constraint is applied just when using a Vertical (Top to Bottom) layout, 
	 otherwise is ignored.
	 Please notice that 99% of the time you DO NOT NEED (and you do not want) to use 
	 a fixed constraint like this one. 
	 Instead, consider using `SpBoxLayout>>#add:expand:` method, and let the component
	 take its 'natural' heiht (often defined in a style)."

	self expand: false.
	height := aNumber! !

!SpBoxConstraints methodsFor: 'accessing' stamp: ''!
expand: aBoolean

	expand := aBoolean! !

!SpBoxConstraints methodsFor: 'accessing' stamp: ''!
padding
	^ padding ifNil: [ self class defaultPadding ]! !

!SpBoxConstraints methodsFor: 'testing' stamp: ''!
isExpand
	^ expand ifNil: [ self class defaultExpand ]! !

!SpBoxConstraints methodsFor: 'testing' stamp: ''!
isFill
	^ fill ifNil: [ self class defaultFill ]! !

!SpBoxConstraints class methodsFor: 'defaults' stamp: ''!
defaultFill

	^ true! !

!SpBoxConstraints class methodsFor: 'defaults' stamp: ''!
defaultExpand

	^ true! !

!SpBoxConstraints class methodsFor: 'defaults' stamp: ''!
defaultPadding 

	^ 0! !

!SpBoxLayout commentStamp: ''!
I'm a layout that will arrange presenters in a box, vertically (top to bottom) or horizontally (left to right).
Elements can be added at the begining or at the end of the box (see `SpBoxLayout>>#add:` and `SpBoxLayout>>#addLast:` method families).

## Discussion

The box layout is the main layout in Spec, because its versatility and ease to use. While one may think its functionality is limited, the fact that it can be composed with other types of layouts or other instances of itself (other boxes), will let users do almost everything they need.
The basic usage is, however, very simple: 

```Smalltalk
SpBoxLayout newTopToBottom
	add: aPresenter;
	add: otherPresenter;
	yourself.
```

This will arrange `aPresenter` and `otherPresenter` vertically, assigning to each presenter as much `height` as they can receive (usually 50% of the box).  
Of course, being able to do _just that_ would be very limiting, but then is where layout properties start to be important.

### The expand property (`SpBoxLayout>>#add:expand:`)

With the previous example, let's define a some real presenters: 

```Smalltalk
| presenter |

presenter := SpPresenter new.
presenter layout: (SpBoxLayout newTopToBottom
	add: presenter newTextInput;
	add: presenter newText;
	yourself).
		
presenter openWithSpec
```

What's happened when we opened it? Well, the box layout was filled with an input text and a text area, but the height assigned to the first presenter is not what we would have expected, since even if text input is smaller, area height assigned is still half.
The property expand fixes this problem, by telling the layout not to assign more height than what is explicitly needed by the contained presenter: 

```Smalltalk
| presenter |

presenter := SpPresenter new.
presenter layout: (SpBoxLayout newTopToBottom
	add: presenter newTextInput expand: false;
	add: presenter newText;
	yourself).
		
presenter openWithSpec
```

Now the presenter will behave as one would expect (This code is in `SpBoxLayout class>>#exampleExpand`).

### Adding presenters **last**.

Now, consider this problem: You want to add something *at the end* of your presenter (for example, you want to add a button, making a dialog): 

```Smalltalk
| presenter |

presenter := SpPresenter new.
presenter layout: (SpBoxLayout newTopToBottom
	add: 'Enter text' expand: false;
	add: presenter newTextInput expand: false;
	add: (presenter newButton label: 'Ok') expand: false;
	yourself).
		
presenter openWithSpec
```

But you want that button to be shown at the end. This is why we use the `addLast:` method, who will instruct the layout to add this presenter at the end.

```Smalltalk
| presenter |

presenter := SpPresenter new.
presenter layout: (SpBoxLayout newTopToBottom
	add: 'Enter text' expand: false;
	add: presenter newTextInput expand: false;
	addLast: (presenter newButton label: 'Ok') expand: false;
	yourself).
		
presenter openWithSpec
```

That makes the presenter work as expected  (This code is in SpBoxLayout class>>#exampleAddLast).

### Composing layouts

The real power of a layout comes when you understand they can be composed (with other instances of themselves or any other kind, children of `SpExecutableLayout`).
For example, taking the previous example, let's say you want to add two buttons (Ok, Cancel), aligned horizontaly. To accomplish that, you add a new layout with the buttons: 

```Smalltalk
| presenter |

presenter := SpPresenter new.
presenter layout: (SpBoxLayout newTopToBottom
	add: 'Enter text' expand: false;
	add: presenter newTextInput expand: false;
	addLast: (SpBoxLayout newLeftToRight
			addLast: (presenter newButton label: 'Ok') expand: false;
			addLast: (presenter newButton label: 'Cancel') expand: false;
			yourself)
		expand: false;
	yourself).
		
presenter openWithSpec
```

Now, the presenter will show buttons at bottom-right corner (This code is in `SpBoxLayout class>>#exampleComposite`).!
!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
add: aPresenterLayoutOrSymbol
	"Adds `aPresenterLayoutOrSymbol` to the list of presenters to be arranged in the layout. 
	 `aPresenterLayoutOrSymboll` can be
		- any instance of `SpPresenter` hierarchy, 
		- another layout or 
		- a Symbol, matching the name of the instance variable who will contain the element to add."

	self 
		add: aPresenterLayoutOrSymbol 
		withConstraints: [ :constraints | ]! !

!SpBoxLayout methodsFor: 'private' stamp: ''!
addLast: aName expand: shouldExpand fill: shouldFill

	self 
		addLast: aName 
	   withConstraints: [ :constraints | 
			constraints
				expand: shouldExpand;
				fill: shouldFill ]! !

!SpBoxLayout methodsFor: 'api' stamp: ''!
borderWidth
	"Answer the border width defined for the layout (default is zero)"

	^ borderWidth! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
vAlignCenter
	"Sets the vertical align property to CENTER. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment center! !

!SpBoxLayout methodsFor: 'testing' stamp: ''!
isVertical 
	"Answer true if the layout direction is vertical"

	^ self direction = SpLayoutDirection vertical! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
addLast: aName withConstraints: aBlock
	"Adds `aPresenterLayoutOrSymbol` to the **end of the list** of presenters to be arranged 
	in the layout, updating the constraints directly. 
	 `aPresenterLayoutOrSymboll` can be
		- any instance of `SpPresenter` hierarchy, 
		- another layout or 
		- a Symbol, matching the name of the instance variable who will contain the element to add.
	`aBlock` receives one argument (an instance of `SpBoxConstraints`), to be modified directly.
	
	NOTICE that the direct usage of this method is NOT recommended. Consider using add:/add:expand: 
	instead"

	self 
		add: aName 
		withConstraints: [ :constraints |
			constraints bePlacedAtEnd.
			aBlock value: constraints ]! !

!SpBoxLayout methodsFor: 'private' stamp: ''!
add: aName expand: shouldExpand fill: shouldFill padding: aNumber
"
aName 		- the presenter to be added to box
expand 	- true if the new child is to be given extra space allocated to box . 
			  The extra space will be divided evenly between all children that use this option
fill 		- true if space given to child by the expand option is actually allocated to child , 
			  rather than just padding it. This parameter has no effect if expand is set to false. 
padding 	- extra space in pixels to put between this child and its neighbors, over and above 
			  the global amount specified by “spacing” property. If child is a widget at one of 
			  the reference ends of box , then padding pixels are also put between child and the
			  reference edge of box"

	self 
		add: aName 
		withConstraints: [ :constraints |
			constraints 
				expand: shouldExpand;
				fill: shouldFill; 
				padding: aNumber ]! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
replace: aPresenter with: otherPresenter
	"Replace aPresenter with otherPresenter. 
	 Original constraints will be preserved."
	
	self 
		replace: aPresenter 
		with: otherPresenter
		withConstraints: (self constraintsFor: aPresenter)! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
add: aPresenterLayoutOrSymbol height: anInteger 
	"Add a presenter and assign a specific height. 
	 This constraint is applied just when using a Vertical (Top to Bottom) layout, 
	 otherwise is ignored.
	 Please notice that 99% of the time you DO NOT NEED (and you do not want) to use 
	 a fixed constraint like this one. 
	 Instead, consider using `SpBoxLayout>>#add:expand:` method. "

	self 
		add: aPresenterLayoutOrSymbol 
		withConstraints: [ :constraints | constraints height: anInteger ].! !

!SpBoxLayout methodsFor: 'private' stamp: ''!
homogeneous: aBoolean

	homogeneous := aBoolean! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
vAlign
	"I define the vertical alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use vAlignStart, vAlignCenter, vAlignEnd"

	^ vAlign! !

!SpBoxLayout methodsFor: 'private' stamp: ''!
add: aName expand: shouldExpand fill: shouldFill

	self add: aName withConstraints: [ :constraints | 
		constraints
			expand: shouldExpand;
			fill: shouldFill ]! !

!SpBoxLayout methodsFor: 'testing' stamp: ''!
isHorizontal 
	"Answer true if the layout direction is horizontal"

	^ self direction = SpLayoutDirection horizontal! !

!SpBoxLayout methodsFor: 'private' stamp: ''!
adapterName

	^ #BoxAdapter! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
addLast: aName expand: shouldExpand
	"Adds `aPresenterLayoutOrSymbol` to the **end of the list** of presenters to be arranged 
	 in the layout, setting also the expand property. 
	 `aPresenterLayoutOrSymboll` can be
		- any instance of `SpPresenter` hierarchy, 
		- another layout or 
		- a Symbol, matching the name of the instance variable who will contain the element to add.
	`shouldExpand` is a boolean indicating whether the new child is to be given extra space allocated 
	to the box."

	self 
		addLast: aName 
		withConstraints: [ :constraints | 
			constraints expand: shouldExpand ]! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
replaceAtIndex: index with: aPresenter
	"Replace the presenter in `index` with otherPresenter. 
	 Original constraints will be preserved."
	
	self 
		replace: (self presenterAt: index) 
		with: aPresenter! !

!SpBoxLayout methodsFor: 'api' stamp: ''!
spacing
	"Answer the spacing between elements of the layout (default is zero)"

	^ spacing! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
hAlignEnd
	"Sets the horizontal align property to END. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment end! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
addLast: aName
	"Adds `aPresenterLayoutOrSymbol` to the **end of the list** of presenters to be arranged 
	 in the layout. 
	 `aPresenterLayoutOrSymboll` can be
		- any instance of `SpPresenter` hierarchy, 
		- another layout or 
		- a Symbol, matching the name of the instance variable who will contain the element to add."

	self 
		addLast: aName 
		withConstraints: [ :constraints | ]! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
vAlignEnd
	"Sets the vertical align property to END. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment end! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
add: aPresenterLayoutOrSymbol expand: shouldExpand
	"Adds `aPresenterLayoutOrSymbol` to the list of presenters to be arranged in the layout, setting 
	 also the expand property. 
	 `aPresenterLayoutOrSymboll` can be
		- any instance of `SpPresenter` hierarchy, 
		- another layout or 
		- a Symbol, matching the name of the instance variable who will contain the element to add.
	`shouldExpand` is a boolean indicating whether the new child is to be given extra space allocated 
	to the box."

	^ self 
		add: aPresenterLayoutOrSymbol 
		withConstraints: [ :constraints | 
			constraints expand: shouldExpand ]! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
add: aPresenterLayoutOrSymbol withConstraints: aBlock
	"Adds `aPresenterLayoutOrSymbol` to the list of presenters to be arranged in the layout, updating 
	 the constraints directly. 
	 `aPresenterLayoutOrSymboll` can be
		- any instance of `SpPresenter` hierarchy, 
		- another layout or 
		- a Symbol, matching the name of the instance variable who will contain the element to add.
	`aBlock` receives one argument (an instance of `SpBoxConstraints`), to be modified directly.
	
	NOTICE that the direct usage of this method is NOT recommended. Consider using add:/add:expand: 
	instead"
	
	super add: aPresenterLayoutOrSymbol withConstraints: aBlock.
	self announceChildAdded: aPresenterLayoutOrSymbol! !

!SpBoxLayout methodsFor: 'api' stamp: ''!
borderWidth: aNumber
	"Set the border width to be used by the layout"

	borderWidth := aNumber.
	self withAdapterDo: [ :anAdapter | anAdapter updateBorderWidth ]! !

!SpBoxLayout methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self beNotHomogeneous.
	self spacing: 0.
	self borderWidth: 0! !

!SpBoxLayout methodsFor: 'testing' stamp: ''!
isHomogeneous
	"Answer whether the layout should distribute children homogeneous or not"

	^ homogeneous! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
replace: aPresenter with: otherPresenter withConstraints: constraints
	"Replace aPresenter with otherPresenter"
	
	children
		replaceKey: aPresenter
		with: otherPresenter.

	self withAdapterDo: [ :anAdapter |
		anAdapter 
			replace: aPresenter 
			with: otherPresenter
			withConstraints: constraints ]! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
hAlign: anAlignment
	"Sets the horizontal align property. See #hAlign to details"
	
	hAlign := anAlignment! !

!SpBoxLayout methodsFor: 'testing' stamp: ''!
hasAlignment
	"Answer whether the component has any alignment defined"

	^ self hasVAlign or: [ self hasHAlign ]! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
vAlignStart
	"Sets the vertical align property to START. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment start! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
vAlign: anAlignment
	"Sets the vertical align property. See #vAlign to details"

	vAlign := anAlignment! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
hAlignStart
	"Sets the horizontal align property to START. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment start! !

!SpBoxLayout methodsFor: 'testing' stamp: ''!
hasVAlign
	"Answer whether the component has a vertical alignment defined"

	^ vAlign notNil! !

!SpBoxLayout methodsFor: 'private' stamp: ''!
constraintsClass

	^ SpBoxConstraints! !

!SpBoxLayout methodsFor: 'private' stamp: ''!
addLast: aName expand: shouldExpand fill: shouldFill padding: aNumber

	self 
		addLast: aName 
		withConstraints: [ :constraints |
			constraints 
				expand: shouldExpand;
				fill: shouldFill; 
				padding: aNumber ]! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
direction 

	^ direction! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
add: aPresenterLayoutOrSymbol width: anInteger
	"Add a presenter and assign a specific width. 
	 This constraint is applied just when using an Horizontal (Left to Right) layout, 
	 otherwise is ignored.
	 Please notice that 99% of the time you DO NOT NEED (and you do not want) to use 
	 a fixed constraint like this one. 
	 Instead, consider using `SpBoxLayout>>#add:expand:` method. "

	self
		add: aPresenterLayoutOrSymbol
		withConstraints: [ :constraints | constraints width: anInteger ].! !

!SpBoxLayout methodsFor: 'private' stamp: ''!
presenterAt: index

	^ children keyAtIndex: index! !

!SpBoxLayout methodsFor: 'testing' stamp: ''!
hasHAlign
	"Answer whether the component has an horizontal alignment defined"

	^ hAlign notNil! !

!SpBoxLayout methodsFor: 'api' stamp: ''!
beHomogeneous
	"When a layout us set as homogeneous, all its components have assigned same space, regardless 
	 their own expand or size settings."

	self homogeneous: true! !

!SpBoxLayout methodsFor: 'api - adding' stamp: ''!
removeAll
	"Remove all presenters added to this layout."

	children removeAll.
	adapter ifNotNil: [ :anAdapter | 
		anAdapter unsubscribe.
		anAdapter removeAll ]! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
hAlign
	"I define the horizontal alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use hAlignStart, hAlignCenter, hAlignEnd"

	^ hAlign! !

!SpBoxLayout methodsFor: 'accessing' stamp: ''!
hAlignCenter
	"Sets the horizontal align property to CENTER. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment center! !

!SpBoxLayout methodsFor: 'api' stamp: ''!
beNotHomogeneous
	"When a layout us set as not homogeneous, components are ordered respecting their own 
	 properties about expand and/or size assignment. 
	 This is the default."

	self homogeneous: false! !

!SpBoxLayout methodsFor: 'api' stamp: ''!
spacing: aNumber
	"Set the spacing between elements of the layout"

	spacing := aNumber.
	self withAdapterDo: [ :anAdapter | anAdapter updateSpacing ]	! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleComposite
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		add: 'Enter text' expand: false;
		add: presenter newTextInput expand: false;
		addLast: (self newLeftToRight
				addLast: (presenter newButton label: 'Ok') expand: false;
				addLast: (presenter newButton label: 'Cancel') expand: false;
				yourself)
			expand: false;
		yourself).
			
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpBoxLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpBoxLayout class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleHAlignEnd
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		hAlignEnd;
		add: (presenter newButton
			icon: (presenter application iconNamed: #smallOk);
			label: 'Press me!!';
			action: [ presenter application inform: 'Pressed!!' ]) 
		yourself).
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpBoxLayout class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpBoxLayout class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpBoxLayout class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpBoxLayout class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleVAlignCenter
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		vAlignCenter;
		add: (presenter newButton
			icon: (presenter application iconNamed: #smallOk);
			label: 'Press me!!';
			action: [ presenter application inform: 'Pressed!!' ]) 
		yourself).
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleHAlignCenter
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		hAlignCenter;
		add: (presenter newButton
			icon: (presenter application iconNamed: #smallOk);
			label: 'Press me!!';
			action: [ presenter application inform: 'Pressed!!' ]) 
		yourself).
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleVAlignAndHAlign
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		vAlignCenter;
		hAlignCenter;
		add: (presenter newButton
			icon: (presenter application iconNamed: #smallOk);
			label: 'Press me!!';
			action: [ presenter application inform: 'Pressed!!' ]) 
		yourself).
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpBoxLayout class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleAddLast
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		add: 'Enter text' expand: false;
		add: presenter newTextInput expand: false;
		addLast: (presenter newButton label: 'Ok') expand: false;
		yourself).
			
	presenter openWithSpec
! !

!SpBoxLayout class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpBoxLayout class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpBoxLayout class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpBoxLayout class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpBoxLayout class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpBoxLayout class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpBoxLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleVAlignStart
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		vAlignStart;
		add: (presenter newButton
			icon: (presenter application iconNamed: #smallOk);
			label: 'Press me!!';
			action: [ presenter application inform: 'Pressed!!' ]) 
		yourself).
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpBoxLayout class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpBoxLayout class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleVAlignEnd
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		vAlignEnd;
		add: (presenter newButton
			icon: (presenter application iconNamed: #smallOk);
			label: 'Press me!!';
			action: [ presenter application inform: 'Pressed!!' ]) 
		yourself).
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpBoxLayout class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleBorderWidth
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		borderWidth: 10;
		add: 'Enter text' expand: false;
		add: presenter newTextInput expand: false;
		addLast: (self newLeftToRight
				addLast: (presenter newButton label: 'Ok') expand: false;
				addLast: (presenter newButton label: 'Cancel') expand: false;
				yourself)
			expand: false;
		yourself).
			
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpBoxLayout class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleHAlignStart
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		hAlignStart;
		add: (presenter newButton
			icon: (presenter application iconNamed: #smallOk);
			label: 'Press me!!';
			action: [ presenter application inform: 'Pressed!!' ]) 
		yourself).
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleBorderWidthAndSpacing
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		borderWidth: 10;
		spacing: 10;
		add: 'Enter text' expand: false;
		add: presenter newTextInput expand: false;
		addLast: (self newLeftToRight
				spacing: 10;
				addLast: (presenter newButton label: 'Ok') expand: false;
				addLast: (presenter newButton label: 'Cancel') expand: false;
				yourself)
			expand: false;
		yourself).
			
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleExpand
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newTopToBottom
		add: presenter newTextInput expand: false;
		add: presenter newText;
		yourself).
	presenter openWithSpec! !

!SpBoxLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpBoxLayout class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpBoxLayout class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpBoxLayout class methodsFor: '*Spec2-Examples' stamp: ''!
exampleBeHomogeneous
	"This example will show 3 presenters shown homogeneously (equaly distributed in space)"
	| presenter |

	presenter := SpPresenter new.
	presenter layout: (self newLeftToRight
		beHomogeneous;
		add: 'Enter text';
		add: presenter newTextInput;
		add: (presenter newButton 
			label: 'Press me';
			yourself);
		yourself).
			
	presenter openWithSpec! !

!SpBoxLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveElementRemovesFromAdapter

	| element |
	layout add: (element := SpButtonPresenter new).
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpBoxLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testReplaceElementAppliesStyle
	| p1 toReplace p2 replacement |
	
	layout add: (p1 := SpLabelPresenter new).
	layout add: (toReplace := SpLabelPresenter new).
	layout add: (p2 := SpLabelPresenter new).
	self openInstance.
	
	replacement := SpLabelPresenter new.
	replacement addStyle: 'code'. "code assigns code fonts"
	layout replace: toReplace with: replacement.
	
	self assert: self adapter children size equals: 3.
	self 
		assert: replacement adapter widget font
		equals: StandardFonts codeFont! !

!SpBoxLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testReplaceElementBeforeOpenAppliesStyle
	| p1 toReplace p2 replacement |
	
	layout add: (p1 := SpLabelPresenter new).
	layout add: (toReplace := SpLabelPresenter new).
	layout add: (p2 := SpLabelPresenter new).
	
	replacement := SpLabelPresenter new.
	replacement addStyle: 'code'. "code assigns code fonts"
	layout replace: toReplace with: replacement.

	self openInstance.
	
	self assert: self adapter children size equals: 3.
	self 
		assert: replacement adapter widget font
		equals: StandardFonts codeFont! !

!SpBoxLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAdapterElementsAreInSameOrderThanLayout

	| first second |
	layout add: (first := SpButtonPresenter new).
	layout add: (second := SpButtonPresenter new).
	self assert: self adapter children first equals: first adapter widget.
	self assert: self adapter children second equals: second adapter widget.! !

!SpBoxLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddElementAddsToAdapter

	layout add: SpButtonPresenter new.
	self deny: self adapter isEmpty! !

!SpBoxLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddElementAfterOpenAddsToAdapter

	layout add: SpButtonPresenter new.
	self openInstance.
	
	layout add: SpButtonPresenter new.
	self assert: self adapter children size equals: 2! !

!SpBoxLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testLayoutCanHaveMoreThanTwoChildren

	layout add: SpButtonPresenter new.
	layout add: SpButtonPresenter new.
	layout add: SpButtonPresenter new.
	
	self assert: layout children size equals: 3! !

!SpBoxLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testReplaceElementAfterOpen
	| p1 toReplace p2 replacement |
	
	layout add: (p1 := SpLabelPresenter new).
	layout add: (toReplace := SpLabelPresenter new).
	layout add: (p2 := SpLabelPresenter new).
	self openInstance.
	
	replacement := SpButtonPresenter new.
	layout replace: toReplace with: replacement.
	
	self assert: self adapter children size equals: 3.
	self 
		assert: self adapter children 
		equals: { 
			p1 adapter widget. 
			replacement adapter widget. 
			p2 adapter widget }! !

!SpBoxLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveElementAddedAfterOpenRemovesFromAdapter

	| element |
	layout add: (element := SpButtonPresenter new).
	self openInstance.
	
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpBoxLayoutAdapterTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == SpBoxLayoutAdapterTest! !

!SpBoxLayoutAlignmentExample methodsFor: 'initialization' stamp: ''!
newHorizontalAlignmentLayout

	^ SpBoxLayout newTopToBottom
		add: (SpBoxLayout newLeftToRight 
			hAlignStart;
			add: (SpLabelPresenter new label: 'hAlignStart') expand: false;
			yourself);
		add: (SpBoxLayout newLeftToRight 
			hAlignCenter;
			add: (SpLabelPresenter new label: 'hAlignCenter') expand: false;
			yourself);
		add: (SpBoxLayout newLeftToRight 
			hAlignEnd;
			add: (SpLabelPresenter new label: 'hAlignEnd') expand: false;
			yourself);
		yourself
	! !

!SpBoxLayoutAlignmentExample methodsFor: 'initialization' stamp: ''!
newVerticalAlignmentLayout

	^ SpBoxLayout newLeftToRight
		add: (SpBoxLayout newTopToBottom 
			vAlignStart;
			add: (SpLabelPresenter new label: 'vAlignStart') expand: false;
			yourself);
		add: (SpBoxLayout newTopToBottom 
			vAlignCenter;
			add: (SpLabelPresenter new label: 'vAlignCenter') expand: false;
			yourself);
		add: (SpBoxLayout newTopToBottom 
			vAlignEnd;
			add: (SpLabelPresenter new label: 'vAlignEnd') expand: false;
			yourself);
		yourself
	! !

!SpBoxLayoutAlignmentExample methodsFor: 'initialization' stamp: ''!
initializePresenters
	<script: 'self new openWithSpec'>
	| pages |
	
	layout := SpBoxLayout newTopToBottom
		add: (pages := self newNotebook);
		yourself.
		
	pages 
		addPageTitle: 'Horizontal'
		provider: [ 
			SpPresenter new 
				layout: self newHorizontalAlignmentLayout;
				yourself ].
			
	pages 
		addPageTitle: 'Vertical'
		provider: [ 
			SpPresenter new 
				layout: self newVerticalAlignmentLayout;
				yourself ]! !

!SpBoxLayoutReplacePresenterExample methodsFor: 'initialization' stamp: ''!
initializePresenters
	| p1 p2 p3 button |
	<script: 'self new openWithSpec'>
	
	layout := SpBoxLayout newTopToBottom
		add: (p1 := SpLabelPresenter new label: 'Presenter 1');
		add: (p2 := SpLabelPresenter new label: 'Presenter 2'); 
		add: (p3 := SpLabelPresenter new label: 'Presenter 3'); 
		add: (button := SpButtonPresenter new label: 'Replace Presenter 2!!') expand: false;
		yourself.
		
	button action: [ 
		layout 
			replace: layout children second 
			with: (SpLabelPresenter new label: 'Replaced!!') ]! !

!SpBoxLayoutTest methodsFor: 'running' stamp: ''!
testLayoutWithOneElementIsNotEmpty

	layout add: SpButtonPresenter new.
	self deny: layout isEmpty! !

!SpBoxLayoutTest methodsFor: 'running' stamp: ''!
testReplaceAtindexWith
	| p1 toReplace p3 replacement |

	layout add: (p1 := SpLabelPresenter new).
	layout add: (toReplace := SpLabelPresenter new).
	layout add: (p3 := SpLabelPresenter new).
	
	self assert: layout children second equals: toReplace.
	
	replacement := SpButtonPresenter new.
	layout replaceAtIndex: 2 with: replacement.
	
	self assert: layout children second equals: replacement.
	self assert: layout children size equals: 3.
	self assert: layout children equals: { p1. replacement. p3 }! !

!SpBoxLayoutTest methodsFor: 'running' stamp: ''!
testReplaceWith
	| p1 toReplace p3 replacement |

	layout add: (p1 := SpLabelPresenter new).
	layout add: (toReplace := SpLabelPresenter new).
	layout add: (p3 := SpLabelPresenter new).
	
	self assert: layout children second equals: toReplace.
	
	replacement := SpButtonPresenter new.
	layout replace: toReplace with: replacement.
	
	self assert: layout children second equals: replacement.
	self assert: layout children size equals: 3.
	self assert: layout children equals: { p1. replacement. p3 }! !

!SpBoxLayoutTest methodsFor: 'running' stamp: ''!
testElementsAreAddedInOrder

	| second |
	layout add: SpButtonPresenter new.
	layout add: (second := SpButtonPresenter new).
	self assert: layout children last equals: second! !

!SpBoxLayoutTest methodsFor: 'private' stamp: ''!
heightOf: aPresenter

	^ (self extentOf: aPresenter) y! !

!SpBoxLayoutTest methodsFor: 'running' stamp: ''!
testRemoveElementFromLayoutTakesItOut

	| element |
	layout add: (element := SpButtonPresenter new).
	layout remove: element.
	self assert: layout isEmpty! !

!SpBoxLayoutTest methodsFor: 'private' stamp: ''!
widthOf: aPresenter

	^ (self extentOf: aPresenter) x! !

!SpBoxLayoutTest methodsFor: 'private' stamp: ''!
extentOf: aPresenter

	^ aPresenter adapter widget bounds extent! !

!SpBoxLayoutTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == SpBoxLayoutTest! !

!SpBoxLayoutWithTableForTestPresenter methodsFor: 'as yet unclassified' stamp: ''!
table

	^ table! !

!SpBoxLayoutWithTableForTestPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	
	(table := self newTable) 
		items: Smalltalk allClassesAndTraits;
		addColumn: (SpCompositeTableColumn new
			title: 'Test'; 
			addColumn: ((SpImageTableColumn evaluated: [ :each | each systemIcon ]) width: 20);
			addColumn: (SpStringTableColumn evaluated: [ :each | each name ])).! !

!SpBoxLayoutWithTableForTestPresenter class methodsFor: 'specs' stamp: ''!
specWithPadding

	^ SpBoxLayout newTopToBottom
		add: #table expand: false fill: false padding: 10;
		yourself! !

!SpBoxLayoutWithTableForTestPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: #table;
		yourself! !

!SpBoxLayoutWithTableForTestPresenter class methodsFor: 'instance creation' stamp: ''!
open 
	<script>
	
	self new openWithSpec! !

!SpBrowseClassCommand commentStamp: ''!
I browse a class that is returned from the evaluation of my context.
My context must be a block that returns a class.!
!SpBrowseClassCommand methodsFor: 'accessing' stamp: ''!
selector

	^ selector ifNil: [ #doBrowseClass ]! !

!SpBrowseClassCommand methodsFor: 'accessing' stamp: ''!
selector: aSelector

	selector := aSelector! !

!SpBrowseClassCommand methodsFor: 'execution' stamp: ''!
execute

	self context perform: self selector! !

!SpBrowseClassCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $b command mac 
		| $b control win
		| $b control unix! !

!SpBrowseClassCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse the selected class'! !

!SpBrowseClassCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'full class'! !

!SpBrowseClassHierarchyCommand commentStamp: ''!
My context must evaluate to a Behavior. I then browse the hierarchy of that behavior.!
!SpBrowseClassHierarchyCommand methodsFor: 'executing' stamp: ''!
execute

	self context doBrowseHierarchy! !

!SpBrowseClassHierarchyCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse the class hierarchy of the selected class'! !

!SpBrowseClassHierarchyCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'class hierarchy'! !

!SpBrowseClassReferencesCommand commentStamp: ''!
Browse all references to the class returned by the evaluation of the context.!
!SpBrowseClassReferencesCommand methodsFor: 'execution' stamp: ''!
execute

	self context doBrowseClassReferences! !

!SpBrowseClassReferencesCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse all references to the receiver''s class'! !

!SpBrowseClassReferencesCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'class references'! !

!SpBrowseClassVarRefsCommand commentStamp: ''!
My context is a class, I browse the class var refs of that class.
The system navigation is in charge of executing, and will ask the user to select a variable.!
!SpBrowseClassVarRefsCommand methodsFor: 'executing' stamp: ''!
execute	
	
	self systemNavigation browseClassVarRefs: self target! !

!SpBrowseClassVarRefsCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse the references to class variables'! !

!SpBrowseClassVarRefsCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'class variables reference'! !

!SpBrowseClassVariablesCommand commentStamp: ''!
My context is a class, I browse the class variables of that class.!
!SpBrowseClassVariablesCommand methodsFor: 'executing' stamp: ''!
execute

	self systemNavigation browseClassVariables: self target! !

!SpBrowseClassVariablesCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse the class variables'! !

!SpBrowseClassVariablesCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'class variables'! !

!SpBrowseImplementorsCommand commentStamp: ''!
Browse all implementors of the selector found in context.!
!SpBrowseImplementorsCommand methodsFor: 'executing' stamp: ''!
execute

	self context doBrowseImplementors! !

!SpBrowseImplementorsCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $m command mac 
		| $m control win
		| $m control unix! !

!SpBrowseImplementorsCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse all implementors of the selected method or message'! !

!SpBrowseImplementorsCommand class methodsFor: 'accessing' stamp: ''!
defaultName

	^ 'Implementors of it'! !

!SpBrowseImplementorsCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'implementors'! !

!SpBrowseInstVarRefsCommand commentStamp: ''!
My context is a class, I browse the inst var refs of that class.
The system navigation is in charge of executing, and will ask the user to select a variable.!
!SpBrowseInstVarRefsCommand methodsFor: 'executing' stamp: ''!
execute	
	self systemNavigation browseInstVarRefs: self target! !

!SpBrowseInstVarRefsCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse the references to instance variables'! !

!SpBrowseInstVarRefsCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'instance variables reference'! !

!SpBrowseInstancesCommand commentStamp: ''!
I browse all instances of the class returned by the evaluation of my context!
!SpBrowseInstancesCommand methodsFor: 'executing' stamp: ''!
execute

	self target instanceSide inspectAllInstances! !

!SpBrowseInstancesCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse all instances of the selected class'! !

!SpBrowseInstancesCommand class methodsFor: 'accessing' stamp: ''!
shortName

	^ 'all instances'! !

!SpBrowseMethodInheritanceCommand commentStamp: ''!
I browse the inheritance of a method - my context must evaluate to a method.!
!SpBrowseMethodInheritanceCommand methodsFor: 'executing' stamp: ''!
execute
	self systemNavigation
		methodHierarchyBrowserForClass: self target methodClass
		selector: self target selector! !

!SpBrowseMethodInheritanceCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse the hierarchy implementors of the selected method'! !

!SpBrowseMethodInheritanceCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'method inheritance'! !

!SpBrowseMethodReferencesCommand commentStamp: ''!
I browse all references to the computed context that is transformed to a symbol.!
!SpBrowseMethodReferencesCommand methodsFor: 'executing' stamp: ''!
execute

	self context doBrowseMethodReferences! !

!SpBrowseMethodReferencesCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $n command shift mac 
		| $n control shift win
		| $n control shift unix! !

!SpBrowseMethodReferencesCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse all references to the selected method or selector'! !

!SpBrowseMethodReferencesCommand class methodsFor: 'default' stamp: ''!
defaultName 

	^ 'References to it'! !

!SpBrowseMethodReferencesCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'references'! !

!SpBrowseMethodVersionsCommand commentStamp: ''!
Create and schedule a message set browser on all versions of the method returned by the evaluation of the context.!
!SpBrowseMethodVersionsCommand methodsFor: 'executing' stamp: ''!
execute
	| target |

	target := self target.
	Smalltalk tools versionBrowser
		browseVersionsForClass: target methodClass
		selector: target selector! !

!SpBrowseMethodVersionsCommand class methodsFor: 'default' stamp: ''!
defaultDescription 
	'Browse history of the method'! !

!SpBrowseMethodVersionsCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'method versions'! !

!SpBrowseMethodsContainingStringCommand commentStamp: ''!
I browse all methods containing a string returned by the computed context.!
!SpBrowseMethodsContainingStringCommand methodsFor: 'executing' stamp: ''!
execute

	self context doBrowseMethodsContainingString! !

!SpBrowseMethodsContainingStringCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Browse all methods containing the selected string'! !

!SpBrowseMethodsContainingStringCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Method source with it'! !

!SpBrowseMethodsContainingStringCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'methods containing string'! !

!SpBrowseMethodsMatchingStringInsensitiveCommand commentStamp: ''!
Browse all methods matching the selected string (case-insensitive).!
!SpBrowseMethodsMatchingStringInsensitiveCommand methodsFor: 'executing' stamp: ''!
execute

	self context doBrowseMethodsMatchingStringSensitive! !

!SpBrowseMethodsMatchingStringInsensitiveCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Browse all methods containing a string matchign the selected string (case-sensitive)'! !

!SpBrowseMethodsMatchingStringInsensitiveCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Case insensitive method literal strings with it'! !

!SpBrowseMethodsMatchingStringInsensitiveCommand class methodsFor: 'default' stamp: ''!
shortName

	^ nil "Do not use"! !

!SpBrowseMethodsMatchingStringSensitiveCommand commentStamp: ''!
Browse all methods matching the selected string (case-sensitive).!
!SpBrowseMethodsMatchingStringSensitiveCommand methodsFor: 'executing' stamp: ''!
execute

	self context doBrowseMethodsMatchingStringSensitive! !

!SpBrowseMethodsMatchingStringSensitiveCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse all methods containing a string matchign the selected string (case-sensitive)'! !

!SpBrowseMethodsMatchingStringSensitiveCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Case sensitive method literal strings with it'! !

!SpBrowseMethodsMatchingStringSensitiveCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'methods literal strings (case-sensitive)'! !

!SpBrowsePointersToCommand commentStamp: ''!
I inspect all pointers to the object returned by the evaluation of my context!
!SpBrowsePointersToCommand methodsFor: 'executing' stamp: ''!
execute

	self target pointersTo inspect! !

!SpBrowsePointersToCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse all objects referencing the selected object'! !

!SpBrowsePointersToCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'pointers to'! !

!SpBrowseSendersCommand commentStamp: ''!
Browse all senders.
!
!SpBrowseSendersCommand methodsFor: 'executing' stamp: ''!
execute
	
	self context doBrowseSenders! !

!SpBrowseSendersCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $n command mac 
		| $n control win
		| $n control unix! !

!SpBrowseSendersCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse all senders of the selected method or message'! !

!SpBrowseSendersCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Senders of it'! !

!SpBrowseSendersCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'senders'! !

!SpBrowseSubInstancesCommand commentStamp: ''!
I browse all instances of the class (and all its subclasses) returned by the evaluation of my context !
!SpBrowseSubInstancesCommand methodsFor: 'executing' stamp: ''!
execute

	self target instanceSide inspectSubInstances! !

!SpBrowseSubInstancesCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Browse all instances of the selected class and all its subclasses'! !

!SpBrowseSubInstancesCommand class methodsFor: 'default' stamp: ''!
shortName

	^ 'all subinstances'! !

!SpButtonAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpButtonPresenter! !

!SpButtonAdapterTest methodsFor: 'tests' stamp: ''!
testNoClickDoesNotExecuteAction
	| actionExecuted |
	actionExecuted := false.
	presenter action: [ actionExecuted := true].

	self deny: actionExecuted! !

!SpButtonAdapterTest methodsFor: 'tests' stamp: ''!
testChangingIconAffectTheWidget
	
	presenter iconName: #pharo.
	
	self assertIcon: self adapter icon equals: (self iconNamed: #pharo)! !

!SpButtonAdapterTest methodsFor: 'tests' stamp: ''!
testRightClickShouldNotExecuteAction
	| actionExecuted |

	actionExecuted := false.
	presenter action: [ actionExecuted := true.].

	self emulateRightClick.
	self deny: actionExecuted! !

!SpButtonAdapterTest methodsFor: 'tests' stamp: ''!
testChangingLabelAffectTheWidget
	
	presenter label: 'ALabel'.
	self assert: self widget label equals: 'ALabel'! !

!SpButtonAdapterTest methodsFor: 'tests' stamp: ''!
testClickExecuteAction
	| actionExecuted |	

	actionExecuted := false.
	presenter action: [ actionExecuted := true].

	self emulateLeftClick.
	self assert: actionExecuted! !

!SpButtonAdapterTest methodsFor: 'tests' stamp: ''!
testRightClickShowsMenu
	| menu |

	presenter contextMenu: (menu := SpMockMenuPresenter new).
	self deny: menu shown.
	self emulateRightClick.
	self assert: menu shown! !

!SpButtonAdapterTest methodsFor: 'tests' stamp: ''!
testWhenActivatedDo

	| actionExecuted |	
	actionExecuted := false.
	presenter whenActivatedDo: [ actionExecuted := true].

	self emulateLeftClick.
	self assert: actionExecuted! !

!SpButtonBarPresenter commentStamp: ''!
A full width bar for arranging buttons.
A button bar can be used to provide a consistent layout of buttons throughout your application. 
!
!SpButtonBarPresenter methodsFor: 'api' stamp: ''!
add: aButtonPresenter
	"Add `aButtonPresenter` to the button list."
	
	aButtonPresenter owner: self.
	items add: aButtonPresenter! !

!SpButtonBarPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	items := OrderedCollection new asValueHolder.
	self placeAtEnd! !

!SpButtonBarPresenter methodsFor: 'testing' stamp: ''!
isPlaceAtStart
	"Answer when the button bar will place buttons at the start of the bar"

	^ placeAtStart! !

!SpButtonBarPresenter methodsFor: 'private - traversing' stamp: ''!
presenters
	
	^ self items! !

!SpButtonBarPresenter methodsFor: 'testing' stamp: ''!
canTakeKeyboardFocus

	^ false! !

!SpButtonBarPresenter methodsFor: 'api' stamp: ''!
items: aCollectionOfButtonPresenters
	"Set buttons to show, taking elements in `aCollectionOfButtonPresenters`."

	items := OrderedCollection new asValueHolder.
	aCollectionOfButtonPresenters 
		do: [ :each | each owner: self ].
	items addAll: aCollectionOfButtonPresenters! !

!SpButtonBarPresenter methodsFor: 'api' stamp: ''!
placeAtStart 
	"Indicate the button bar will place buttons at the start of the bar (arranged to the left)"

	placeAtStart := true! !

!SpButtonBarPresenter methodsFor: 'api' stamp: ''!
placeAtEnd
	"Indicate the button bar will place buttons at the end of the bar (arranged to the right)"

	placeAtStart := false! !

!SpButtonBarPresenter methodsFor: 'api' stamp: ''!
items
	"Answer list of buttons."

	^ items value! !

!SpButtonBarPresenter methodsFor: 'testing' stamp: ''!
isPlaceAtEnd
	"Answer when the button bar will place buttons at the end of the bar"

	^ self isPlaceAtStart not! !

!SpButtonBarPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newButtonBar! !

!SpButtonBarPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	| presenter list buttonBar |

	"A generic presenter with a list and an action bar"	
	(presenter := SpPresenter new) 
		layout: (SpBoxLayout newTopToBottom
			spacing: 5; 
			add: (list := presenter newList);
			add: (buttonBar := presenter newButtonBar) expand: false;
			yourself).	
		
	"some settings to the list (to not have the presenter empty)"
	list 
		items: Smalltalk allClassesAndTraits;
		displayIcon: [ :aClass | aClass systemIcon ];
		display: [ :aClass | aClass name ].
		
	"now, we add some buttons to our button bar"
	buttonBar
		"We want to place them at the end (as is often used in dialogs)"
		placeAtEnd;
		add: (presenter newButton
			icon: (presenter application iconNamed: #smallAdd);
			label: 'Add';
			yourself);
		add: (presenter newButton 
			icon: (presenter application iconNamed: #smallDelete);
			label: 'Delete';
			yourself);
		add: (presenter newButton
			icon: (presenter application iconNamed: #smallCopy);
			label: 'Copy';
			yourself).
			
	presenter openWithSpec! !

!SpButtonBarPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ButtonBarAdapter! !

!SpButtonPresenter commentStamp: ''!
A button who executes an action when pressed.
!
!SpButtonPresenter methodsFor: 'api - events' stamp: ''!
whenActivatedDo: aBlock
	"Inform that the button has been aclicked, and its action has been performed.
	 `aBlock` receive zero arguments.
	 See also `SpButtonPresenter>>#whenActionPerformedDo:`"
	
	^ self whenActionPerformedDo: aBlock ! !

!SpButtonPresenter methodsFor: 'TOREMOVE' stamp: ''!
font
	^ font! !

!SpButtonPresenter methodsFor: 'TOREMOVE' stamp: ''!
askBeforeChanging: aBoolean
	askBeforeChanging := aBoolean! !

!SpButtonPresenter methodsFor: 'simulating' stamp: ''!
click

	"I emulate the click from the presenter point of view.
	Of course if the button is disabled, I do nothing, like in real life!!!!
	If you want to emulate other stuff use performAction"
	
	self isEnabled ifFalse: [ ^ self ].
	^ self performAction! !

!SpButtonPresenter methodsFor: 'api' stamp: ''!
shortcut
	"Answer the shortcut used to trigger button's action from keyboard."

	^ shortcut! !

!SpButtonPresenter methodsFor: 'private' stamp: ''!
registerShortcut: newShortcut
	| receiver |
	
	receiver := self window.
	(receiver isNil or: [ newShortcut isNil ]) ifTrue: [ ^ self ].
	receiver presenter
		bindKeyCombination: newShortcut
		toAction: [ self performAction ]! !

!SpButtonPresenter methodsFor: 'api' stamp: ''!
contextMenu: aValuableOrMenuPresenter
	"Set the context menu.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	contextMenu := aValuableOrMenuPresenter! !

!SpButtonPresenter methodsFor: 'TOREMOVE' stamp: ''!
whenStateChangedDo: aBlock
	"set a block to perform after that the button has been aclicked, and its action performed"

	self property: #state whenChangedDo: aBlock! !

!SpButtonPresenter methodsFor: 'api - events' stamp: ''!
whenMenuChangedDo: aBlock
	"Inform when menu definition changed. 
	 `aBlock` receives zero arguments."

	self property: #contextMenu whenChangedDo: aBlock! !

!SpButtonPresenter methodsFor: 'api' stamp: ''!
action: aBlock
	"Set the block performed when the button is clicked. 
	 `aBlock` receives zero arguments."

	action := aBlock! !

!SpButtonPresenter methodsFor: 'private' stamp: ''!
performAction

	self action value.
	" Here I set a dummy value just to make the holder raise an event"
	actionPerformed := nil! !

!SpButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	action := [  ].
	state := false.
	askBeforeChanging := false.

	self whenFontChangedDo: [ self changed: #font ].
	self whenStateChangedDo: [ self changed: #state ].
	self whenMenuChangedDo: [ 
		self withAdapterDo: [ :anAdapter | anAdapter updateMenu ] ].
	self 
		property: #askBeforeChanging 
		whenChangedDo: [ :newValue | self changed: {#askBeforeChanging: . newValue} ].
	self
		property: #shortcut
		whenChangedDo: [ :newShortcut :oldShortcut | 
			self unregisterShortcut: oldShortcut.
			self registerShortcut: newShortcut.
			self changed: #label ].

	self color: nil! !

!SpButtonPresenter methodsFor: 'api' stamp: ''!
shortcut: aShortcut
	"Set the shortcut used to trigger button's action from keyboard.
	 `aShortcut` needs to be an instance of `KMKeyCombination` (or polymorphic with it), 
	 usually <meta+some character>"

	shortcut := aShortcut! !

!SpButtonPresenter methodsFor: 'private - focus' stamp: ''!
ensureKeyBindingsFor: widget

	super ensureKeyBindingsFor: widget.
	self shortcut ifNotNil: [ :s | self registerShortcut: s ]! !

!SpButtonPresenter methodsFor: 'api - events' stamp: ''!
whenActionChangedDo: aBlock
	"Inform when action block has been changed. 
	 `aBlock` receives two optional arguments: 
	 - new action block
	 - old action block"

	self property: #action whenChangedDo: aBlock! !

!SpButtonPresenter methodsFor: 'api' stamp: ''!
contextMenu
	"Answer context menu or nil if there is none defined.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	^ contextMenu! !

!SpButtonPresenter methodsFor: 'api' stamp: ''!
action
	"Answer the block performed when the button is clicked."

	^ action! !

!SpButtonPresenter methodsFor: 'TOREMOVE' stamp: ''!
font: aFont
	font := aFont! !

!SpButtonPresenter methodsFor: 'TOREMOVE' stamp: ''!
state: aBoolean
	"set if the button is highlighted"

	state := aBoolean! !

!SpButtonPresenter methodsFor: 'TOREMOVE' stamp: ''!
whenFontChangedDo: aBlock
	"set a block to perform after that the button has been aclicked, and its action performed"

	self property: #font whenChangedDo: aBlock! !

!SpButtonPresenter methodsFor: '*Spec2-Commander2' stamp: ''!
contextMenuFromCommandsGroup: aValuable
	self contextMenu: [ aValuable value beRoot asMenuPresenter ]! !

!SpButtonPresenter methodsFor: 'TOREMOVE' stamp: ''!
state

	self flag: #TODO. "To remove or move to morphic extension"
	^ state! !

!SpButtonPresenter methodsFor: 'private' stamp: ''!
unregisterShortcut: oldShortcut
	| receiver |
	receiver := self window.
	(receiver isNil or: [ oldShortcut isNil ]) ifTrue: [ ^ self ].

	receiver model
		removeKeyCombination: oldShortcut ! !

!SpButtonPresenter methodsFor: 'private' stamp: ''!
shortcutCharacter

	^ self shortcut ifNotNil: [ :s | s platformCharacter ]! !

!SpButtonPresenter methodsFor: 'api - events' stamp: ''!
whenActionPerformedDo: aBlock
	"Inform that the button has been aclicked, and its action has been performed.
	 `aBlock` receive zero arguments."

	self property: #actionPerformed whenChangedDo: aBlock! !

!SpButtonPresenter methodsFor: 'TOREMOVE' stamp: ''!
askBeforeChanging
	^ askBeforeChanging! !

!SpButtonPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newButton! !

!SpButtonPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>
	
	^ self new
		icon: (self iconNamed: #smallOk);
		label: 'Click me!!';
		action: [ 'Clicked!!' crTrace ];
		openWithSpec! !

!SpButtonPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ButtonAdapter! !

!SpButtonPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Button'! !

!SpButtonPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleDisabled
	
	^ self new
		icon: (self iconNamed: #smallCancel);
		label: 'Click me!!';
		action: [ 'Clicked!!' crTrace ];
		disable;
		openWithSpec! !

!SpButtonPresenterTest commentStamp: ''!
SUnit tests for Button model!
!SpButtonPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpButtonPresenter! !

!SpButtonPresenterTest methodsFor: 'tests' stamp: ''!
testAction
	| actionExecuted |

	actionExecuted := false.
	self assert: actionExecuted equals: false.

	presenter action: [ actionExecuted := true ].
	self openInstance.
	self assert: actionExecuted equals: false.

	presenter adapter action.
	self assert: actionExecuted equals: true! !

!SpButtonPresenterTest methodsFor: 'tests' stamp: ''!
testContextMenu
	| menu changed |
	
	self assert: presenter contextMenu isNil.
	menu := SpMenuPresenter new.
	changed := false.
	presenter whenMenuChangedDo: [ 
		changed := true. ].
	presenter contextMenu: menu.
	self assert: presenter contextMenu equals: menu.
	self assert: changed! !

!SpButtonPresenterTest methodsFor: 'tests' stamp: ''!
testWhenStateChangedDo

	presenter whenStateChangedDo: [ :new :old | self deny: old. self assert: new ].

	self deny: presenter state.

	self openInstance.
	presenter state: true.

	self assert: presenter state ! !

!SpButtonPresenterTest methodsFor: 'tests' stamp: ''!
testAskBeforeChanging

	| state |

	self assert: presenter askBeforeChanging not.
	self openInstance.
	state := presenter adapter askBeforeChanging.
	self assert: state not.
	presenter askBeforeChanging: true.
	state := presenter adapter askBeforeChanging.
	self assert: state! !

!SpButtonPresenterTest methodsFor: 'accessing' stamp: ''!
morph

	^ presenter adapter widget! !

!SpButtonPresenterTest methodsFor: 'tests' stamp: ''!
testEnabled
	self assert: presenter isEnabled.
	self openInstance.
	self assert: self morph enabled.
	presenter enabled: false.
	self deny: self morph enabled! !

!SpButtonPresenterTest methodsFor: 'tests' stamp: ''!
testWhenActionPerformedDoAfterAction

	| actionExecuted actionPerformed |

	actionExecuted := 0.
	actionPerformed := 0.

	self assert: actionExecuted equals: 0.
	self assert: actionPerformed equals: 0.

	presenter action: [ actionExecuted := Time microsecondClockValue. 1 milliSecond wait  ].
	presenter whenActionPerformedDo: [ actionPerformed := Time microsecondClockValue ].

	self openInstance.

	self assert: actionExecuted equals: 0.
	self assert: actionPerformed equals: 0.

	presenter adapter action.

	self assert: actionExecuted < actionPerformed.! !

!SpButtonPresenterTest methodsFor: 'tests' stamp: ''!
testWhenActionPerformedDo

	| actionExecuted actionPerformed |

	actionExecuted := false.
	actionPerformed := false.

	self assert: actionExecuted equals: false.
	self assert: actionPerformed equals: false.

	presenter action: [ actionExecuted := true ].
	presenter whenActionPerformedDo: [ actionPerformed := true ].

	self openInstance.

	self assert: actionExecuted equals: false.
	self assert: actionPerformed equals: false.

	presenter adapter action.

	self assert: actionExecuted equals: true.
	self assert: actionPerformed equals: true.
! !

!SpButtonPresenterTest methodsFor: 'tests' stamp: ''!
testWhenActionChangedDo

	| actionModified newBlock oldBlock |

	actionModified := false.
	newBlock := [ 1 ].
	oldBlock := presenter action.

	self assert: actionModified equals: false.

	presenter whenActionChangedDo: [ :new :old |
		self assert: old equals: oldBlock.
		self assert: new equals: newBlock.
		actionModified := true ].

	self openInstance.

	self assert: actionModified equals: false.

	presenter action: newBlock.

	self assert: actionModified equals: true! !

!SpCancelChangesCommand methodsFor: 'execution' stamp: ''!
execute
	
	self context triggerResetAction! !

!SpCancelChangesCommand class methodsFor: 'defaults' stamp: ''!
defaultShortcutKey

	^ $l command mac | $l ctrl win | $l ctrl unix! !

!SpCancelChangesCommand class methodsFor: 'defaults' stamp: ''!
defaultIconName
	^#smallCancel! !

!SpCancelChangesCommand class methodsFor: 'defaults' stamp: ''!
defaultName

	^ 'Cancel'! !

!SpCancelledInteractionError commentStamp: ''!
I am the error raised when the user cancelled a request.!
!SpCancelledInteractionError methodsFor: '*Spec2-Commander2' stamp: ''!
actForSpec
	"Does nothing on purpose."
	self flag: #TODO. "In the best world, we should delegate the behaviour to the Spec presenter which originated the error."! !

!SpChangeSorterPresenter commentStamp: ''!
A change sorter is a little tool to manage changes. 
Developer can give name to change containers and all the change made during this container is active are collected in the container. 
The DualChangeSorter tool supports manipulation of changes between containers and fileout of the changes.

ChangeSorterPresenter new openWithSpec!
!SpChangeSorterPresenter methodsFor: 'menu' stamp: ''!
classMenu
	"Fill aMenu with items appropriate for the class list"

	^ self newMenu
		title: 'Class list';
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Delete class from change set';
						shortcut: $d meta;
						action: [ self forgetClass ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Remove class from system';
						shortcut: $x meta;
						action: [ self removeClass ] ] ];
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Browse full';
						shortcut: $b meta;
						action: [ self browseMethodFull ] ] ];
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'FileOut';
						action: [ self fileOutClass ] ] ];
		yourself! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
selectedClass
	^ classesListPresenter selection selectedItem! !

!SpChangeSorterPresenter methodsFor: 'menu - message' stamp: ''!
fileOutMessage
	"Put a description of the selected message on a file"

	self selectedSelector ifNotNil: [:selector |
		Cursor write showWhile:
			[ self model fileOutSelector: selector from: self selectedClass ]]! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
currentText

	 ^ textPresenter getText! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
methodsOn: aShortcut do: aBlock

	methodsListPresenter bindKeyCombination: aShortcut toAction: aBlock! !

!SpChangeSorterPresenter methodsFor: 'accessing' stamp: ''!
textPresenter

	^ textPresenter! !

!SpChangeSorterPresenter methodsFor: 'menu - message' stamp: ''!
browseMethodFull
	"Create and schedule a full Browser and then select the current class and message."

	self selectedClass ifNotNil:
		[:myClass | Smalltalk tools browser openOnClass: myClass selector: self selectedSelector ]! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
updateMessagesList

	| sel |
	sel := methodsListPresenter selectedItem.
	
	self selectedClass
			ifNil: [ methodsListPresenter items: {} ]
			ifNotNil: [:class | methodsListPresenter items: (self selectedChangeSet selectorsInClass: class name) sort].
				
	methodsListPresenter setSelectedItem: sel! !

!SpChangeSorterPresenter methodsFor: 'api - events' stamp: ''!
whenChangesListChanges: aBlock

	changesListPresenter whenModelChangedDo: aBlock! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
editPostscript

	self selectedChangeSet ifNil: [ ^ self inform: 'No change set selected' ].
	self selectedChangeSet editPostscript! !

!SpChangeSorterPresenter methodsFor: 'private' stamp: ''!
updateTextContents

	| text |
	text := self model setContentsOfChangeSet: self selectedChangeSet forClass: self selectedClass andSelector: self selectedSelector.
	(text asString lines
		anySatisfy: [ :line | 
			self model classDescriptionsMap values , {'Method was added, but cannot be found!!' . 'Added then removed (see versions)' . 'Method has been removed (see versions)' . 'Class organization was changed.'}
				includes: line ]) ifTrue: [ textPresenter withoutSyntaxHighlight ] ifFalse: [ textPresenter withSyntaxHighlight ].
	textPresenter text: text! !

!SpChangeSorterPresenter methodsFor: 'shortcuts' stamp: ''!
classShortcuts: event from: aMorph

	self selectedClass ifNotNil: [ 
		event keyString = '<Cmd-b>' ifTrue: [ ^ self browseMethodFull ].
		event keyString = '<Cmd-d>' ifTrue: [ ^ self forgetClass ].
		event keyString = '<Cmd-x>' ifTrue: [ ^ self removeClass ] ]! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
fileOut

	self selectedChangeSet ifNil: [ ^ self inform: 'No change set selected' ].
	self selectedChangeSet fileOut! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
openChangeSetBrowser

	| cs |
	self selectedChangeSet ifNil: [ ^ self inform: 'No change set selected' ].
	cs := self selectedChangeSet ifNil: [ ^ self ].
	^ Smalltalk tools messageList browseClasses: (RBBrowserEnvironment new forClasses: cs changedClasses)! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
selectedClassIndex

	 ^ classesListPresenter selectedIndex! !

!SpChangeSorterPresenter methodsFor: 'menu - class' stamp: ''!
forgetClass
	"Remove all mention of this class from the changeSet"

	self okToChange ifFalse: [^ self].
	self selectedClass ifNotNil: [:class |
		self model removeClass: class from: self selectedChangeSet.
		self setSelectedChangeSet: self selectedChangeSet ]
! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
setSelectedChangeSet: aChangeSet

	 ^ changesListPresenter selectItem: aChangeSet! !

!SpChangeSorterPresenter methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!SpChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
setFocus

	self focusOrder
		add: changesListPresenter;
		add: classesListPresenter;
		add: methodsListPresenter;
		add: textPresenter! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
browseChangeSet
	"Open a message list browser on methods in the current change set"

	| messages |
	self selectedChangeSet ifNil: [ ^ self inform: 'No change set selected' ].
	messages := self selectedChangeSet changedMessageList select: [ :each | each isValid ].
	Smalltalk tools messageList browse: messages title: 'Methods in Change Set ' , self selectedChangeSet name! !

!SpChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
initialize

	model := ChangeSorterModel new.
	super initialize.
	SystemAnnouncer uniqueInstance weak
		when: CurrentChangeSetChanged
		send: #updateTitle
		to: self.
	self initializeAnnouncements! !

!SpChangeSorterPresenter methodsFor: 'shortcuts' stamp: ''!
registerClassShortcuts: aWidget

	aWidget bindKeyCombination: PharoShortcuts current browseShortcut toAction: [ self selectedClass ifNotNil:[ self browseMethodFull ]].
	aWidget bindKeyCombination: $d meta toAction: [ self selectedClass ifNotNil:[ self forgetClass ]].
	aWidget bindKeyCombination: PharoShortcuts current removeShortcut toAction: [ self selectedClass ifNotNil:[ self removeClass ]]! !

!SpChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
initializeAnnouncements

	SystemAnnouncer uniqueInstance weak 
		when:
			ClassAdded , ClassCommented , ClassRecategorized , ClassModifiedClassDefinition , ClassRemoved , ClassRenamed
				, ClassReorganized , MethodAdded , MethodModified , MethodRecategorized , MethodRemoved , ProtocolAdded
				, ProtocolRemoved
		send: #updateClassesList
		to: self! !

!SpChangeSorterPresenter methodsFor: 'accessing' stamp: ''!
classesListPresenter

	^ classesListPresenter! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
changesPresenterOn: aShortcut do: aBlock

	changesListPresenter bindKeyCombination: aShortcut toAction: aBlock! !

!SpChangeSorterPresenter methodsFor: 'private' stamp: ''!
defaultTitle
	
	^ 'Change Sorter'! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
selectorsMenu: aBlock

	methodsListPresenter menu: aBlock! !

!SpChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
registerSelectorActions

	methodsListPresenter whenSelectionChangedDo: [ :selection | self updateTextContents ]! !

!SpChangeSorterPresenter methodsFor: 'private' stamp: ''!
createRingMethodForRemovedSelector: aSelector inClass: aClass
	"Create RingMethod from the	removealinfo"

	| removalInfo method |
	method := RGMethodDefinition class: aClass selector: aSelector.
	removalInfo := (self selectedChangeSet changeRecorderFor: aClass) methodChanges at: aSelector ifAbsent: [ ^ method ].
	method sourcePointer: removalInfo methodInfoFromRemoval first.
	^ method! !

!SpChangeSorterPresenter methodsFor: 'menu - message' stamp: ''!
browseVersions
	"Create and schedule a changelist browser on the versions of the 
	selected message."
	
	self selectedClass ifNotNil: [:class |
		self selectedSelector ifNotNil: [:selector || method |
			method := self createRingMethodForSelector: selector inClass: class.
			self model browseVersionsFrom: method ]]! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
changesMenu: aBlock
	changesListPresenter contextMenu: aBlock! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
methodsMenu: aBlock

	methodsListPresenter contextMenu: aBlock! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
classesOn: aShortcut do: aBlock

	classesListPresenter bindKeyCombination: aShortcut toAction: aBlock! !

!SpChangeSorterPresenter methodsFor: 'menu - class' stamp: ''!
removeClass
	"Remove the selected class from the system, at interactive user request.  Make certain the user really wants to do this, since it is not reversible.  Answer true if removal actually happened."

	(self model removeClass: self selectedClass)
		ifTrue: [ self setSelectedChangeSet: self selectedChangeSet ]! !

!SpChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	methodsListPresenter := self newList.
	classesListPresenter := self newList.
	changesListPresenter := self newList.
	textPresenter := self newCode.
	self setFocus.
	methodsListPresenter contextMenu: self messageMenu.
	changesListPresenter contextMenu: self changeSetMenu.
	classesListPresenter contextMenu: self classMenu.
	methodsListPresenter matchSubstring.
	classesListPresenter matchSubstring.
	changesListPresenter matchSubstring.
	changesListPresenter items: self model allChanges.
	changesListPresenter display: [ :item | item name ].
	classesListPresenter sortingBlock: [ :a :b | a name < b name ]! !

!SpChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters

	self
		registerChangeActions;
		registerClassActions;
		registerSelectorActions.

	changesListPresenter items
		ifNotEmpty: [ changesListPresenter selectIndex: 1 ]! !

!SpChangeSorterPresenter methodsFor: 'menu - class' stamp: ''!
fileOutClass

	self model fileOutClass: self selectedClass from: self selectedChangeSet! !

!SpChangeSorterPresenter methodsFor: 'menu - message' stamp: ''!
browseSendersOfMessages

	self model browseSendersOfMessagesFrom: self selectedSelector! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
removePostscript

	self selectedChangeSet ifNil: [ ^ self inform: 'No change set selected' ].
	self model removePostscriptFrom: self selectedChangeSet.
	changesListPresenter setSelectedItem: self selectedChangeSet! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
selectedSelector

	^ methodsListPresenter selection selectedItem! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
updateChangesList

	| sel |
	sel := self selectedChangeSet.
	changesListPresenter items: self model allChanges.
	changesListPresenter selectItem: sel! !

!SpChangeSorterPresenter methodsFor: 'menu - message' stamp: ''!
removeMessage
	"Remove the selected message from the system."
	
	self okToChange
		ifFalse: [^ self].
	self selectedSelector
		ifNotNil: [:selector | | class method | 
			class := self selectedClass.
				(class includesSelector: selector) ifFalse:[^ self].
				method := class>>selector.
				(self model removeMethod: method inClass: class)
					ifTrue: [ self updateMessagesList ]]! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
changeSets

	^ self changesListPresenter listItems! !

!SpChangeSorterPresenter methodsFor: 'accessing' stamp: ''!
methodsListPresenter

	^ methodsListPresenter! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
setSelectedChangeSetIndex: anIndex

	 ^ changesListPresenter setSelectedIndex: anIndex! !

!SpChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
registerChangeActions

	changesListPresenter
		whenSelectionChangedDo: [ :selection | 
			self updateTextContents.
			selection selectedItem
				ifNil: [ classesListPresenter items: {}.
					methodsListPresenter items: {} ]
				ifNotNil: [ :change | 
					classesListPresenter unselectAll.
					classesListPresenter items: change changedClasses ] ]! !

!SpChangeSorterPresenter methodsFor: 'menu' stamp: ''!
messageMenu
	"Build a menu with items appropriate for the message list; could be for a single or double changeSorter"

	^ self newMenu
		title: 'Message list';
		addGroup: [ :group | 
			group
				addItem: [ :anItem | 
					anItem
						name: 'Delete method from changeSet';
						shortcut: $d meta;
						action: [ self forgetMessage ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Remove method from system';
						shortcut: $x meta;
						action: [ self removeMessage ] ] ];
		addGroup: [ :group | 
			group
				addItem: [ :anItem | 
					anItem
						name: 'Browse full';
						shortcut: $b meta;
						action: [ self browseMethodFull ] ] ];
		addGroup: [ :group | 
			group
				addItem: [ :anItem | 
					anItem
						name: 'FileOut';
						action: [ self fileOutMessage ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Senders of...';
						shortcut: $n meta;
						action: [ self browseSendersOfMessages ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Implementors of...';
						shortcut: $m meta;
						action: [ self browseImplementorsOfMessages ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Versions';
						shortcut: $v meta;
						action: [ self browseVersions ] ] ];
		yourself! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
removePreamble

	self selectedChangeSet ifNil: [ ^ self inform: 'No change set selected' ].
	self selectedChangeSet hasPreamble ifFalse: [ ^ self inform: 'Change set has no preamble' ].
	self selectedChangeSet removePreamble.
	changesListPresenter setSelectedItem: self selectedChangeSet! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
rename
	| set |
	self selectedChangeSet ifNil: [ ^ self inform: 'No change set selected' ].
	set := self model rename: self selectedChangeSet.

	changesListPresenter
		updateList;
		setSelectedItem: set.
	self updateWindowTitle! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
setSelectedClass: aClass

	 ^ classesListPresenter setSelectedItem: aClass! !

!SpChangeSorterPresenter methodsFor: 'private' stamp: ''!
createRingMethodForSelector: aSelector inClass: aClass
	"Create RingMethod from the class compiledMethod or if it was removed from the removalinfo"
	
	(aClass includesSelector: aSelector) ifTrue:[ ^ aClass compiledMethodAt: aSelector].
	^ self createRingMethodForRemovedSelector: aSelector inClass: aClass.! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
title
	^ String streamContents: [ :stream | stream << self class title << ' on: ' << self model currentChangeSet name ]! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
addPreamble
	self selectedChangeSet ifNil: [ ^ self inform: 'No change set selected' ].
	self model addPreambleTo: self selectedChangeSet.
	changesListPresenter setSelectedItem: self selectedChangeSet! !

!SpChangeSorterPresenter methodsFor: 'accessing' stamp: ''!
changesListPresenter

	^ changesListPresenter! !

!SpChangeSorterPresenter methodsFor: 'shortcuts' stamp: ''!
methodShortcuts: event from: aMorph

	self selectedSelector
		ifNotNil:[
			event keyString = '<Cmd-b>' ifTrue: [ ^ self browseMethodFull ].
			event keyString = '<Cmd-d>' ifTrue: [ ^ self forgetMessage ].
			event keyString = '<Cmd-m>' ifTrue: [ ^ self browseImplementorsOfMessages ].
			event keyString = '<Cmd-n>' ifTrue: [ ^ self browseSendersOfMessages ].
			event keyString = '<Cmd-v>' ifTrue: [ ^ self browseVersions ].
			event keyString = '<Cmd-x>' ifTrue: [ ^ self removeMessage ]].! !

!SpChangeSorterPresenter methodsFor: 'menu - message' stamp: ''!
forgetMessage

	self okToChange ifFalse: [^ self].
	self selectedSelector ifNotNil: [:selector | 
		self model 
			forgetSelector: selector 
			inClass: self selectedClass 
			fromChangeSet: self selectedChangeSet.
		self updateClassesList.
		self setSelectedClassIndex: self selectedClassIndex ]! !

!SpChangeSorterPresenter methodsFor: 'shortcuts' stamp: ''!
registerMethodShortcuts: aWidget

	aWidget bindKeyCombination: PharoShortcuts current browseShortcut toAction: [ self selectedSelector ifNotNil:[ self browseMethodFull ]].
	aWidget bindKeyCombination: $d meta toAction: [ self selectedSelector ifNotNil:[ self forgetMessage ]].
	aWidget bindKeyCombination: PharoShortcuts current browseImplementorsShortcut toAction: [ self selectedSelector ifNotNil:[ self browseImplementorsOfMessages ]].
	aWidget bindKeyCombination: PharoShortcuts current browseSendersShortcut toAction: [ self selectedSelector ifNotNil:[ self browseSendersOfMessages ]].
	aWidget bindKeyCombination: PharoShortcuts current browseVersionsShortcut toAction: [ self selectedSelector ifNotNil:[ self browseVersions ]].
	aWidget bindKeyCombination: PharoShortcuts current removeShortcut toAction: [ self selectedSelector ifNotNil:[ self removeMessage ]].! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
updateClassesListAndMessagesList

	| sel |
	sel := methodsListPresenter selectedItem.
	self updateClassesList.
	methodsListPresenter setSelectedItem: sel.
	self updateMessagesList! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
updateWindowTitle

	self withWindowDo: [ :window | window title: self title ]! !

!SpChangeSorterPresenter methodsFor: 'shortcuts' stamp: ''!
ensureKeyBindingsFor: aWidget

	super ensureKeyBindingsFor: aWidget.
	
	self 
		registerChangeSetShortcuts: changesListPresenter;
		registerClassShortcuts: classesListPresenter;
		registerMethodShortcuts: methodsListPresenter! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
selectedChangeSetIndex

	^ changesListPresenter selectedIndex! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
selectedChangeSet

	^ changesListPresenter selection selectedItem! !

!SpChangeSorterPresenter methodsFor: 'shortcuts' stamp: ''!
registerChangeSetShortcuts: aWidget

	aWidget bindKeyCombination: PharoShortcuts current browseShortcut toAction: [ self selectedChangeSet ifNotNil:[ self browseChangeSet ]].
	aWidget bindKeyCombination: $b meta shift toAction: [ self selectedChangeSet ifNotNil:[ self openChangeSetBrowser ]].
	aWidget bindKeyCombination: $m meta toAction: [ self selectedChangeSet ifNotNil:[ self setCurrentChangeSet ]].
	aWidget bindKeyCombination: $n meta toAction: [ self selectedChangeSet ifNotNil:[ self newSet ]].
	aWidget bindKeyCombination: $o meta toAction: [ self selectedChangeSet ifNotNil:[ self fileOut ]].
	aWidget bindKeyCombination: $r meta toAction: [ self selectedChangeSet ifNotNil:[ self rename ]].
	aWidget bindKeyCombination: $p meta toAction: [ self selectedChangeSet ifNotNil:[ self addPreamble ]].
	aWidget bindKeyCombination: PharoShortcuts current removeShortcut toAction: [ self selectedChangeSet ifNotNil:[ self remove ]].
	aWidget bindKeyCombination: $f meta toAction: [ self findChangeSet ]
		! !

!SpChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
registerClassActions

	classesListPresenter
		whenSelectionChangedDo: [ :selection | 
			self updateTextContents.
			textPresenter behavior: selection selectedItem.
			textPresenter syntaxHighlight: false.
			selection selectedItem
				ifNil: [ methodsListPresenter items: {} ]
				ifNotNil: [ :class | 
					methodsListPresenter unselectAll.
					methodsListPresenter items: (self selectedChangeSet selectorsInClass: class name) sort ] ]! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
newSet

	| aSet |
	self selectedChangeSet ifNil: [ ^ self inform: 'No change set selected' ].
	self okToChange ifFalse: [ ^ self ].
	aSet := self model createNewSet.
	aSet
		ifNotNil: [ self updateChangesList.
			changesListPresenter setSelectedItem: aSet.
			self updateWindowTitle ]! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
updateClassesList

	| sel |
	sel := self selectedClass.
	self selectedChangeSet
		ifNil: [ classesListPresenter items: {} ]
		ifNotNil: [ :change | 
			classesListPresenter
				items: (change changedClasses sort: [ :a :b | a name < b name ]) ].
	sel ifNotNil: [ classesListPresenter selectItem: sel ]! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
remove
	"Completely destroy my change set.  Check if it's OK first"

	self okToChange ifFalse: [^ self].
	self model removeChangeSet: self selectedChangeSet prompting: true.
	self updateChangesList.
	changesListPresenter resetSelection! !

!SpChangeSorterPresenter methodsFor: 'private' stamp: ''!
forceChangesListRefresh

	| sel |	
	sel := self selectedChangeSet.
	changesListPresenter items: self model allChanges.
	changesListPresenter setSelectedItem: sel! !

!SpChangeSorterPresenter methodsFor: 'menu' stamp: ''!
changeSetMenu
	"Set up aMenu to hold commands for the change-set-list pane.  This could be for a single or double changeSorter"

	^ self newMenu
		title: 'Change Set';
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Make changes go to me';
						shortcut: $m meta;
						action: [ self setCurrentChangeSet ] ];
				addItem: [ :anItem | 
					anItem
						name: 'New change set...';
						shortcut: $n meta;
						action: [ self newSet ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Find...';
						shortcut: $f meta;
						action: [ self findChangeSet ] ] ];
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Rename change set';
						shortcut: $r meta;
						action: [ self rename ] ];
				addItem: [ :anItem | 
					anItem
						name: 'File out';
						shortcut: $o meta;
						action: [ self fileOut ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Browse methods';
						shortcut: $b meta;
						action: [ self browseChangeSet ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Browse change set';
						shortcut: $B meta;
						action: [ self openChangeSetBrowser ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Add/Edit preamble';
						shortcut: $p meta;
						action: [ self addPreamble ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Remove preamble';
						action: [ self removePreamble ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Add/Edit postscript...';
						action: [ self editPostscript ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Remove postscript';
						action: [ self removePostscript ] ] ];
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Destroy change set';
						shortcut: $x meta;
						action: [ self remove ] ] ];
		yourself! !

!SpChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter
		title: self title;
		initialExtent: 500 @ 350! !

!SpChangeSorterPresenter methodsFor: 'menu - message' stamp: ''!
browseImplementorsOfMessages

	self model browseMessagesFrom: self selectedSelector! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
classesMenu: aBlock

	classesListPresenter contextMenu: aBlock! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
setCurrentChangeSet

	self selectedChangeSet ifNil: [ ^ self inform: 'No change set selected' ].
	self model setCurrentChangeSet: self selectedChangeSet.
	self updateWindowTitle! !

!SpChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
findChangeSet

	| set |
	set := self model findChangeSetIn: self changeSets.
	changesListPresenter setSelectedItem: set! !

!SpChangeSorterPresenter methodsFor: 'api' stamp: ''!
setSelectedClassIndex: anIndex

	 ^ classesListPresenter setSelectedIndex: anIndex! !

!SpChangeSorterPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ SpPanedLayout newTopToBottom
		positionOfSlider: 35 percent;
		add: (SpPanedLayout newLeftToRight
			add: #changesListPresenter;
			add: #classesListPresenter;
			yourself);
		add: (SpPanedLayout newTopToBottom
			add: #methodsListPresenter;
			add: #textPresenter;
			yourself);
		yourself! !

!SpChangeSorterPresenter class methodsFor: 'opening' stamp: ''!
open
	<script>
	
	self new openWithSpec! !

!SpChangeSorterPresenter class methodsFor: 'accessing' stamp: ''!
title
	^ 'Change sorter'! !

!SpCheckBoxExample commentStamp: ''!
A CheckBoxExample is a simple example of how to use CheckBoxes.

self example!
!SpCheckBoxExample methodsFor: 'initialization' stamp: ''!
setFocus
	self focusOrder
		add: button1;
		add: button2;
		add: button3! !

!SpCheckBoxExample methodsFor: 'updating' stamp: ''!
updateLabel
	label
		label:
			(String
				streamContents: [ :s | 
					{button1 . button2 . button3}
						do: [ :button | 
							s
								<< button label;
								<< ' : ';
								<< (button state ifTrue: [ 'V' ] ifFalse: [ 'X' ]) ]
						separatedBy: [ s << ' - ' ] ])! !

!SpCheckBoxExample methodsFor: 'initialization' stamp: ''!
initializePresenters 

	button1 := self newCheckBox.
	button2 := self newCheckBox.
	button3 := self newCheckBox.
	label := self newLabel.
	
	button1 label: 'Button 1'.
	button2 label: 'Button 2'.
	button3 label: 'Button 3'.
	
	self updateLabel.
	self setFocus.! !

!SpCheckBoxExample methodsFor: 'initialization' stamp: ''!
connectPresenters
	button1 whenActivatedDo: [ self updateLabel ].
	button1 whenDeactivatedDo: [ self updateLabel ].

	button2 whenChangedDo: [ self updateLabel ].

	button3 whenChangedDo: [ self updateLabel ]! !

!SpCheckBoxExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #button1;
				add: #button2;
				add: #button3;
				yourself)
			withConstraints: [ :c | c height: self toolbarHeight ];
		add: #label withConstraints: [ :c | c height: self labelHeight ];
		yourself! !

!SpCheckBoxExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new openWithSpec! !

!SpCheckBoxExample class methodsFor: 'specs' stamp: ''!
title

	^ 'CheckBox Example'! !

!SpCheckBoxExampleTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpCheckBoxExample! !

!SpCheckBoxPresenter commentStamp: ''!
A Checkbox Button that can be activated/deactivated.
!
!SpCheckBoxPresenter methodsFor: 'TOREMOVE' stamp: ''!
labelOnRight

	^ self changed: #labelOnRight with: #()! !

!SpCheckBoxPresenter methodsFor: 'TOREMOVE' stamp: ''!
labelOnLeft

	^ self changed: #labelOnLeft with: #()! !

!SpCheckBoxPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newCheckBox! !

!SpCheckBoxPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example 

	self new 
		label: 'Example';
		state: false;
		whenActivatedDo: [ 'Activated' crTrace ];
		whenDeactivatedDo: [ 'Deactivated' crTrace ];
		openWithSpec! !

!SpCheckBoxPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #CheckBoxAdapter! !

!SpCheckBoxPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Checkbox Button'! !

!SpCheckBoxTableColumn commentStamp: ''!
A column that display a boolean value in the form of a checkbox.

The user need to set the evaluation block (by sending `SpTableColumn>>#evaluated:`) to answer a boolean value that will define if the checkbox is selected or unselected.

## Example
```
SpCheckBoxTableColumn 
	title: 'My CheckBox' 
	evaluated: [ :anObject | anObject = someValue ]
```!
!SpCheckBoxTableColumn methodsFor: 'api' stamp: ''!
onActivation: aBlock
	"Set the block to be executed when a checkbox is activated (marked). 
	 `aBlock` receives one argument, the element in which the checkbox acts."

	onActivation := aBlock! !

!SpCheckBoxTableColumn methodsFor: 'api' stamp: ''!
onDeactivation: aBlock
	"Set the block to be executed when a checkbox is deactivated (unmarked). 
	 `aBlock` receives one argument, the element in which the checkbox acts."

	onDeactivation := aBlock! !

!SpCheckBoxTableColumn methodsFor: 'api' stamp: ''!
onActivation
	"Answer the block to be executed when a checkbox is activated (marked)"

	^ onActivation! !

!SpCheckBoxTableColumn methodsFor: 'api' stamp: ''!
onDeactivation
	"Answer the block to be executed when a checkbox is deactivated (unmarked)"

	^ onDeactivation! !

!SpCheckBoxTableColumn methodsFor: 'visiting' stamp: ''!
acceptColumnVisitor: aBuilder

	^ aBuilder visitCheckboxColumn: self! !

!SpCheckboxAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpCheckBoxPresenter! !

!SpCheckboxAdapterTest methodsFor: 'tests' stamp: ''!
testActivatedCheckboxPresenterStartsActivatedCheckboxMorph

	presenter state: true.
	self assert: self adapter state! !

!SpCheckboxAdapterTest methodsFor: 'tests' stamp: ''!
testClickRaisesChangedEvent

	| activated |
	activated := false.
	presenter whenChangedDo: [ activated := true ].

	self emulateLeftClick.
	self assert: activated! !

!SpCheckboxAdapterTest methodsFor: 'tests' stamp: ''!
testChangingLabelAffectTheWidget
	
	presenter label: 'ALabel'.
	self assert: self widget label equals: 'ALabel'! !

!SpCheckboxAdapterTest methodsFor: 'tests' stamp: ''!
testDeactivatedCheckboxPresenterStartsDeactivatedCheckboxMorph

	presenter state: false.
	self deny: self adapter state! !

!SpCheckboxAdapterTest methodsFor: 'tests' stamp: ''!
testClickActivatedCheckboxDectivatesIt

	presenter state: true.
	
	self emulateLeftClick.
	self deny: presenter state! !

!SpCheckboxAdapterTest methodsFor: 'tests' stamp: ''!
testChangeActivatedAfterOpenCheckboxDectivatesIt

	presenter state: false.
	
	"Force opening the spec instance here.
	We want to test that once open we can change the state"
	self openInstance.

	presenter state: true.
	self assert: presenter state! !

!SpCheckboxAdapterTest methodsFor: 'tests' stamp: ''!
testChangeDeactivatedAfterOpenCheckboxDectivatesIt

	presenter state: true.
	
	"Force opening the spec instance here.
	We want to test that once open we can change the state"
	self openInstance.
	
	presenter state: false.
	self deny: presenter state! !

!SpCheckboxAdapterTest methodsFor: 'tests' stamp: ''!
testClickDeactivatedCheckboxActivatesIt

	presenter state: false.
	
	self emulateLeftClick.
	self assert: presenter state! !

!SpCheckboxPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpCheckBoxPresenter! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testActivatePresenterIsActive

	presenter state: true.
	self assert: presenter state! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testActivateRaisesChangedEvent

	presenter state: false.
	self
		assertEvent: #whenChangedDo:
		isRaisedInPresenter: presenter
		whenDoing: [ presenter state: true ]! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testDeactivatePresenterIsNotActive

	presenter state: false.
	self deny: presenter state! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testDeactivateRaisesDeactivatedEvent

	presenter state: true.
	self
		assertEvent: #whenDeactivatedDo:
		isRaisedInPresenter: presenter
		whenDoing: [ presenter state: false ]! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testStayingActiveDoesNotRaiseChangedEvent

	presenter state: true.
	self
		denyEvent: #whenChangedDo:
		isRaisedInPresenter: presenter
		whenDoing: [ presenter state: true ]! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testDeactivateRaisesChangedEventOnce

	presenter state: true.
	self
		assertWith: [ :times | times = 1 ]
		timesRaisedEvent: #whenChangedDo:
		inPresenter: presenter
		whenDoing: [ presenter state: false ]! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testDeactivateDoesNotRaiseActivateEvent

	presenter state: true.
	self
		assertWith: [ :times | times = 1 ]
		timesRaisedEvent: #whenActivatedDo:
		inPresenter: presenter
		whenDoing: [ presenter state: false ]! !

!SpCheckboxPresenterTest methodsFor: 'accessing' stamp: ''!
morph

	^ presenter adapter widget! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testActivateRaisesActivatedEvent

	presenter state: false.
	self
		assertEvent: #whenActivatedDo:
		isRaisedInPresenter: presenter
		whenDoing: [ presenter state: true ]! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testDeactivateRaisesChangedEvent

	presenter state: true.
	self
		assertEvent: #whenChangedDo:
		isRaisedInPresenter: presenter
		whenDoing: [ presenter state: false ]! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testStayingInactiveDoesNotRaiseChangedEvent

	presenter state: false.
	self
		denyEvent: #whenChangedDo:
		isRaisedInPresenter: presenter
		whenDoing: [ presenter state: false ]! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testActivateRaisesChangedEventOnce

	presenter state: false.
	self
		assertWith: [ :times | times = 1 ]
		timesRaisedEvent: #whenChangedDo:
		inPresenter: presenter
		whenDoing: [ presenter state: true ]! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testActivateDoesNotRaiseDeactivateEvent

	presenter state: false.
	self
		assertWith: [ :times | times = 1 ]
		timesRaisedEvent: #whenDeactivatedDo:
		inPresenter: presenter
		whenDoing: [ presenter state: true ]! !

!SpCheckboxPresenterTest methodsFor: 'tests' stamp: ''!
testLabelIsSet

	presenter label: 'test'.
	self assert: presenter label equals: 'test'! !

!SpChildrenAdded methodsFor: 'accessing' stamp: ''!
child: aPresenter 
	child := aPresenter! !

!SpChildrenAdded methodsFor: 'accessing' stamp: ''!
child
	^ child! !

!SpChildrenAdded methodsFor: 'accessing' stamp: ''!
parent: aPresenter 
	parent := aPresenter! !

!SpChildrenRemoved methodsFor: 'accessing' stamp: ''!
child: aPresenter 
	child := aPresenter! !

!SpChildrenRemoved methodsFor: 'accessing' stamp: ''!
child
	^ child! !

!SpChildrenRemoved methodsFor: 'accessing' stamp: ''!
parent: aPresenter 
	parent := aPresenter! !

!SpChooserPresenter commentStamp: ''!
I am a presenter that is used to choose items from a list. `SpChooserPresenter>>#chosenItems` returns the chosen items. View the examples on the class side.
Note that all the items are sorted according to the displayBlock that is provided by my users. If non block is provided, the default displayBlock of `SpListPresenter` is used. This widget is in work in progress so it will improved to be more fast and not sort the items everytime.!
!SpChooserPresenter methodsFor: 'actions' stamp: ''!
addSelected

	| newSourceItems |
	targetList items:
		targetList unfilteredItems , sourceList selectedItems.
	newSourceItems := sourceItems copy asOrderedCollection.
	newSourceItems removeAllFoundIn: targetList unfilteredItems.
	sourceList items: newSourceItems.
	self resetSelectedItems.
	self sortLists! !

!SpChooserPresenter methodsFor: 'accessing' stamp: ''!
sourceItems: aCollection

	sourceItems := aCollection.
	sourceList items: aCollection.
	self sortLists! !

!SpChooserPresenter methodsFor: 'accessing' stamp: ''!
defaultChosenItems: aCollection

	| newItems |
	targetList items: aCollection.
	newItems := sourceList unfilteredItems copy asOrderedCollection.
	newItems removeAllFoundIn: aCollection.
	sourceList items: newItems.
	self sortLists! !

!SpChooserPresenter methodsFor: 'initialization' stamp: ''!
initializeLayout

	self layout: (SpBoxLayout newLeftToRight
			 spacing: 5;
			 add: #sourceList;
			 add: buttonBarLayout expand: false;
			 add: #targetList;
			 yourself)! !

!SpChooserPresenter methodsFor: 'actions' stamp: ''!
removeSelected

	| newTargetItems |
	sourceList items:
		sourceList unfilteredItems , targetList selectedItems.
	newTargetItems := targetList unfilteredItems copy asOrderedCollection.
	newTargetItems removeAllFoundIn: targetList selectedItems.
	targetList items: newTargetItems.
	self resetSelectedItems.
	self sortLists! !

!SpChooserPresenter methodsFor: 'actions' stamp: ''!
addAll

	| newSourceItems |
	targetList items: targetList unfilteredItems , sourceList items.
	newSourceItems := sourceItems asOrderedCollection.
	newSourceItems removeAllFoundIn: targetList unfilteredItems.
	sourceList items: newSourceItems.
	self resetSelectedItems.
	self sortLists! !

!SpChooserPresenter methodsFor: 'accessing' stamp: ''!
targetList

	^ targetList! !

!SpChooserPresenter methodsFor: 'initialization' stamp: ''!
initializeButtonBarLayout

	| addButton addAllButton removeButton removeAllButton |
	addButton := self newButton
		             addStyle: 'small';
		             label: '>';
		             help: 'Add selected items.';
		             action: [ self addSelected ];
		             yourself.
	addAllButton := self newButton
		                addStyle: 'small';
		                label: '>>';
		                help: 'Add all items.';
		                action: [ self addAll ];
		                yourself.
	removeButton := self newButton
		                addStyle: 'small';
		                label: '<';
		                help: 'Remove selected items.';
		                action: [ self removeSelected ];
		                yourself.
	removeAllButton := self newButton
		                   addStyle: 'small';
		                   label: '<<';
		                   help: 'Remove all items.';
		                   action: [ self removeAll ];
		                   yourself.

	buttonBarLayout := SpBoxLayout newTopToBottom
		                   spacing: 5;
		                   yourself.
	buttonBarLayout
		add: SpNullPresenter new expand: true;
		add: addButton expand: false;
		add: addAllButton expand: false;
		add: removeButton expand: false;
		add: removeAllButton expand: false;
		add: SpNullPresenter new expand: true! !

!SpChooserPresenter methodsFor: 'actions' stamp: ''!
removeAll

	| newTargetItems |
	sourceList items: targetList items , sourceList unfilteredItems.
	newTargetItems := targetList unfilteredItems copy asOrderedCollection.
	newTargetItems removeAllFoundIn: sourceList unfilteredItems.
	targetList items: newTargetItems.
	self resetSelectedItems.
	self sortLists! !

!SpChooserPresenter methodsFor: 'actions' stamp: ''!
resetSelectedItems
	
	sourceList selectItems: #().
	targetList selectItems: #().! !

!SpChooserPresenter methodsFor: 'accessing' stamp: ''!
chosenItems

	^ targetList unfilteredItems! !

!SpChooserPresenter methodsFor: 'accessing' stamp: ''!
sourceList

	^ sourceList! !

!SpChooserPresenter methodsFor: 'actions' stamp: ''!
sortTargetList

	targetList items: (targetList items sorted: displayBlock ascending)! !

!SpChooserPresenter methodsFor: 'initialization' stamp: ''!
initializeLists

	sourceList := self instantiate: SpFilteringSelectableListPresenter.
	targetList := self instantiate: SpFilteringSelectableListPresenter.
	displayBlock := sourceList display! !

!SpChooserPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self initializeLists.
	self initializeButtonBarLayout.
	self initializeLayout! !

!SpChooserPresenter methodsFor: 'accessing' stamp: ''!
displayBlock: aBlock

	displayBlock := aBlock.
	sourceList display: aBlock.
	targetList display: aBlock! !

!SpChooserPresenter methodsFor: 'actions' stamp: ''!
sortLists

	self sortSourceList.
	self sortTargetList! !

!SpChooserPresenter methodsFor: 'actions' stamp: ''!
sortSourceList

	sourceList items: (sourceList items sorted: displayBlock ascending)! !

!SpChooserPresenter class methodsFor: 'instance creation' stamp: ''!
sourceItems: sourceItems displayBlock: displayBlock

	^ self new
		  displayBlock: displayBlock;
		  sourceItems: sourceItems;
		  yourself! !

!SpChooserPresenter class methodsFor: 'instance creation' stamp: ''!
sourceItems: sourceItems chosenItems: selectedItems displayBlock: displayBlock

	^ self new
		  displayBlock: displayBlock;
		  sourceItems: sourceItems;
		  defaultChosenItems: selectedItems;
		  yourself! !

!SpChooserPresenter class methodsFor: 'examples' stamp: ''!
exampleClasses

	^ (self
		   sourceItems: { SpChooserPresenter . SpFilteringListPresenter }
		   chosenItems: { SpFilteringSelectableListPresenter }
		   displayBlock: #name) openWithSpec! !

!SpChooserPresenter class methodsFor: 'examples' stamp: ''!
example

	^ (self sourceItems: self package definedClasses asOrderedCollection)
		  openWithSpec! !

!SpChooserPresenter class methodsFor: 'instance creation' stamp: ''!
sourceItems: sourceItems chosenItems: selectedItems

	^ self new
		  sourceItems: sourceItems;
		  defaultChosenItems: selectedItems;
		  yourself! !

!SpChooserPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Choose items'! !

!SpChooserPresenter class methodsFor: 'instance creation' stamp: ''!
sourceItems: sourceItems

	^ self new
		  sourceItems: sourceItems;
		  yourself! !

!SpChooserPresenter class methodsFor: 'examples' stamp: ''!
examplePackages

	^ (self
		   sourceItems: RPackageOrganizer default packages
		   chosenItems:
		   { (RPackageOrganizer default packageNamed: 'Spec2-CommonWidgets') }
		   displayBlock: #packageName) openWithSpec! !

!SpClassMethodBrowser commentStamp: ''!
A ClassMethodBrowser is a simple browser using spec and reusing MethodBrowser to browse classes>>methods>>sourceCode.

self example!
!SpClassMethodBrowser methodsFor: 'api' stamp: ''!
classes: aList
	classListPresenter items = aList ifTrue: [ ^ self ].

	classListPresenter
		items: aList;
		selectIndex: 1! !

!SpClassMethodBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters
	classListPresenter := self newList.
	methodListPresenter := self newList.
	textPresenter := self newCode.
	textPresenter whenSubmitDo: [ :text | methodListPresenter selectedItem inspect ].
	methodListPresenter display: #selector.
	self focusOrder
		add: classListPresenter;
		add: methodListPresenter;
		add: textPresenter! !

!SpClassMethodBrowser methodsFor: 'initialization' stamp: ''!
connectPresenters
	classListPresenter
		transmitTo: methodListPresenter
		transform: [ :class | class ifNil: [ #() ] ifNotNil: [ class methods sort: #selector descending ] ]
		postTransmission: [ :destination | destination selectIndex: 1 ].
		
	methodListPresenter
		transmitTo: textPresenter
		transform: [ :method | method ifNil: [ '' ] ifNotNil: #sourceCode ]
		postTransmission: [ :destination :origin :transmited | 
			transmited ifNotNil: [ destination beForMethod: transmited ] ]! !

!SpClassMethodBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpPanedLayout newTopToBottom
		add:
			(SpPanedLayout newLeftToRight
				add: #classListPresenter;
				add: #methodListPresenter;
				yourself);
		add: #textPresenter;
		yourself! !

!SpClassMethodBrowser class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := SpClassMethodBrowser new.
	example
		classes: self environment allClasses;
		openWithSpec.
	^ example! !

!SpClassMethodBrowser class methodsFor: 'specs' stamp: ''!
title

	^ 'Class Method Browser'! !

!SpClassMethodBrowserTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpClassMethodBrowser! !

!SpClassStyle commentStamp: ''!
!! Style classes (==SpStyleClass==)

A style class define a set of properties grouped by a common name. You can think a style class of morphic a little bit as a style class of CSS, but it has several differences.
 
!!!! Style classes can be nested
You can nest classes to refine some properties. For example, if you have this definition: 

[[[
.application [
	.button [
		Geometry { #height: 25, #width: 100 }
		.smallButton {
			Geometry { #width: 150 }
		}
	]	
]
]]]

the result style for a button with "smallButton" style will have a Geometry with the form: ==Geometry { #width: 150, #height: 25 }==, which is the result of the merge of all properties, with the deepest nested property taking precedence.

!!!! Style classes are composable
You can compose class styles (stacking them to form a new style). This is an useful practice to add your own styles to the default definition.  

[[[language=Smalltalk  
myStyle := SpStyle defaultStyleSheet, myOwnStyleDefinition			
]]]!
!SpClassStyle methodsFor: 'accessing' stamp: ''!
styles

	^ styles! !

!SpClassStyle methodsFor: 'adding' stamp: ''!
addPropertyFontWith: aBlock 
	
	self addProperty: SpFontStyle with: aBlock! !

!SpClassStyle methodsFor: 'adding' stamp: ''!
addStyle: aStyle

	styles ifNil: [ styles := #() ].
	styles := styles copyWith: aStyle! !

!SpClassStyle methodsFor: 'private' stamp: ''!
mergedStylesWith: anotherStyle

	| allStyles results|
	
	results := OrderedCollection new.
	
	allStyles := (self styles , anotherStyle styles) 
		groupedBy: [:e | e isStyleClass ifTrue: [ e name ] ifFalse: [ e class]].
	
	allStyles valuesDo: [ :value | 
		results add: (value allButFirst inject: value first into: [:accum :each | accum mergeWith: each ])].
	
	^ results asArray! !

!SpClassStyle methodsFor: 'accessing' stamp: ''!
parent: aStyle

	parent := aStyle! !

!SpClassStyle methodsFor: 'printing' stamp: ''!
printOn: stream 

	super printOn: stream.
	stream << '(' << self fullName << ')'! !

!SpClassStyle methodsFor: 'accessing' stamp: ''!
parent 

	^ parent! !

!SpClassStyle methodsFor: 'accessing' stamp: ''!
name: aString 
	
	name := aString! !

!SpClassStyle methodsFor: 'private' stamp: ''!
styles: aCollection

	styles := aCollection asArray! !

!SpClassStyle methodsFor: 'accessing' stamp: ''!
fullName

	^ (self parent 
		ifNotNil: [ 
			| parentName |
			parentName := self parent fullName.
			parentName = 'application' 
				ifTrue: [ self name ]
				ifFalse: [ parentName, '.', self name ] ]
		ifNil: [ self name ])! !

!SpClassStyle methodsFor: 'adding' stamp: ''!
addPropertyGeometryWith: aBlock 
	
	self addProperty: SpGeometryStyle with: aBlock! !

!SpClassStyle methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	styles := #()! !

!SpClassStyle methodsFor: 'adding' stamp: ''!
addProperty: aClass with: aBlock 
	| property |
	
	property := aClass new.
	aBlock value: property.
	self addStyle: property! !

!SpClassStyle methodsFor: 'adding' stamp: ''!
addClass: aName with: aBlock
	| class |
	
	class := self class new
		parent: self;
		name: aName;
		yourself.
	
	aBlock value: class.
	self addStyle: class! !

!SpClassStyle methodsFor: 'testing' stamp: ''!
isStyleClass

	^ true! !

!SpClassStyle methodsFor: 'copying' stamp: ''!
mergeWith: joinStyle

	^ self class new
		name: name;
		styles: (self mergedStylesWith: joinStyle);
		yourself! !

!SpClassStyle methodsFor: 'accessing' stamp: ''!
properties

	^ self styles select: [ :each | each isStyleProperty ]! !

!SpClassStyle methodsFor: 'accessing' stamp: ''!
flattenProperties

	^ (self flattenClasses
		inject: self properties
		into: [ :all :each | all, each properties ])
		flattened! !

!SpClassStyle methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!SpClassStyle methodsFor: 'adding' stamp: ''!
addPropertyTextWith: aBlock 
	
	self addProperty: SpTextStyle with: aBlock! !

!SpClassStyle methodsFor: 'copying' stamp: ''!
, joinStyle

	^ self mergeWith: joinStyle! !

!SpClassStyle methodsFor: 'initialization' stamp: ''!
fromSton: stonReader
	
	styles := stonReader parseList! !

!SpClassStyle methodsFor: 'operations' stamp: ''!
applyTo: aMorph

	self properties do: [ :each | 
		each applyTo: aMorph ]! !

!SpClassStyle methodsFor: 'adding' stamp: ''!
addPropertyDrawWith: aBlock 
	
	self addProperty: SpDrawStyle with: aBlock! !

!SpClassStyle methodsFor: 'accessing' stamp: ''!
flattenClasses

	^ (self styles
		inject: (OrderedCollection with: self)
		into: [ :all :each | 
			each isStyleClass ifTrue: [ all addAll: each flattenClasses ].
			all ])
		flattened! !

!SpClassStyle methodsFor: 'adding' stamp: ''!
addPropertyContainerWith: aBlock 
	
	self addProperty: SpContainerStyle with: aBlock! !

!SpCodeAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpCodePresenter! !

!SpCodeAdapterTest methodsFor: 'tests' stamp: ''!
assertText: text atInterval: interval isStyle: styleName

	interval do: [ :index |
		self assertText: text at: index isStyle: styleName ]! !

!SpCodeAdapterTest methodsFor: 'tests' stamp: ''!
testWithSyntaxHighlight
	presenter withSyntaxHighlight.
	self assert: self adapter hasSyntaxHighlightEnabled! !

!SpCodeAdapterTest methodsFor: 'tests' stamp: ''!
styleTableAt: styleName do: aBlock 
	| attributes |	

	attributes := (SHRBTextStyler initialTextAttributesForPixelHeight: 1) at: styleName.
	attributes do: aBlock! !

!SpCodeAdapterTest methodsFor: 'tests' stamp: ''!
fillTag: tag withAttribute: attr

	attr class = TextColor ifTrue: [ tag foreground: attr color ].
	self flag: #TODO. "Other attributes"! !

!SpCodeAdapterTest methodsFor: 'tests' stamp: ''!
style: aSymbol 
	| tag |
	
	tag := SpCodeStyleForTest new.
	self styleTableAt: aSymbol do: [ :each |
		self fillTag: tag withAttribute: each ]. 
	
	^ tag
	! !

!SpCodeAdapterTest methodsFor: 'accessing' stamp: ''!
testRightClickShowsMenu
	| menu |

	presenter 
		contextMenu: (menu := SpMockMenuPresenter new);
		overrideContextMenu: true.

	self deny: menu shown.
	self emulateRightClick.
	self assert: menu shown! !

!SpCodeAdapterTest methodsFor: 'tests' stamp: ''!
assertText: text at: index isStyle: styleName
	| tag |

	tag := SpCodeStyleForTest new.
	text attributesAt: index do: [ :each | 
		self fillTag: tag withAttribute: each ].
	self assert: tag equals: (self style: styleName)! !

!SpCodeAdapterTest methodsFor: 'tests' stamp: ''!
testTextWithStyle
	| text |

	presenter 
		beForObject: Object;
		text: 'self asString.'.
	
	text := self adapter textWithStyle.
	self assertText: text atInterval: "self" (1 to: 4) isStyle: #self.
	self assertText: text atInterval: "asString" (6 to: 13) isStyle: #unary.

	presenter type: '10 + 42.0'.
	text := self adapter textWithStyle.
	self assertText: text atInterval: "10" (1 to: 2) isStyle: #integer.
	self assertText: text atInterval: "+" (4 to: 4) isStyle: #binary.
	self assertText: text atInterval: "42.0" (6 to: 9) isStyle: #number.

	presenter beForBehavior: Object.
	presenter type: 'm1 ^ "test" 42'.
	text := self adapter textWithStyle.
	self assertText: text atInterval: "m1" (1 to: 2) isStyle: #patternKeyword.
	self assertText: text atInterval: "^" (4 to: 4) isStyle: #return.
	self assertText: text atInterval: "test" (6 to: 11) isStyle: #comment.	
	self assertText: text atInterval: "42" (13 to: 14) isStyle: #number.! !

!SpCodeAdapterTest methodsFor: 'tests' stamp: ''!
testWithoutSyntaxHighlight
	presenter withoutSyntaxHighlight.
	self deny: self adapter hasSyntaxHighlightEnabled! !

!SpCodeBehaviorInteractionModel methodsFor: 'accessing' stamp: ''!
behavior: anObject
	behavior := anObject! !

!SpCodeBehaviorInteractionModel methodsFor: 'testing' stamp: ''!
hasBindingOf: aString

	^ self behavior hasBindingOf: aString! !

!SpCodeBehaviorInteractionModel methodsFor: 'binding' stamp: ''!
bindingOf: aString

	^ self behavior bindingOf: aString! !

!SpCodeBehaviorInteractionModel methodsFor: 'accessing' stamp: ''!
behavior

	^ behavior! !

!SpCodeBehaviorInteractionModel class methodsFor: 'instance creation' stamp: ''!
on: aBehavior

	^ self new behavior: aBehavior! !

!SpCodeBehaviorInteractionModelTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpCodeBehaviorInteractionModel! !

!SpCodeBehaviorInteractionModelTest methodsFor: 'accessing' stamp: ''!
behaviorToTest

	^ SpCodePresenter! !

!SpCodeBehaviorInteractionModelTest methodsFor: 'running' stamp: ''!
initializeInstance: anInteractionModel

	anInteractionModel behavior: self behaviorToTest! !

!SpCodeBehaviorInteractionModelTest methodsFor: 'tests' stamp: ''!
testBindingOf

	self assert: (interactionModel bindingOf: #somethingNotExistent) isNil.
	
	self deny: (interactionModel bindingOf: #Object) isNil.
	self assert: (interactionModel bindingOf: #Object) value equals: Object! !

!SpCodeBehaviorInteractionModelTest methodsFor: 'tests' stamp: ''!
testBehavior

	self assert: interactionModel behavior equals: self behaviorToTest! !

!SpCodeBehaviorInteractionModelTest methodsFor: 'tests' stamp: ''!
testHasBindingOf

	self deny: (interactionModel hasBindingOf: #somethingNotExistent).
	self deny: (interactionModel hasBindingOf: #Object)! !

!SpCodeCommandContextMock methodsFor: 'accessing' stamp: ''!
selection

	^ selection! !

!SpCodeCommandContextMock methodsFor: 'accessing' stamp: ''!
selection: anObject

	selection := anObject! !

!SpCodeCommandTest methodsFor: 'accessing' stamp: ''!
commandClass
		
	^ self subclassResponsibility! !

!SpCodeCommandTest methodsFor: 'private' stamp: ''!
newMockContext
	
	^ SpCodeCommandContextMock new! !

!SpCodeCommandTest methodsFor: 'tests' stamp: ''!
testExecute 

	self flag: #TODO. "How to intercept messages to prevent execution?"! !

!SpCodeCommandTest methodsFor: 'accessing' stamp: ''!
commandToTest

	^ self commandClass new 
		context: self newMockContext;
		yourself! !

!SpCodeCommandTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors

	^ true! !

!SpCodeCommandTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self = SpCodeCommandTest! !

!SpCodeDebugItCommand commentStamp: ''!
I'm a "debug it" command. 
I will debug the selection (or line) of the playground.!
!SpCodeDebugItCommand methodsFor: 'private' stamp: ''!
compile: aStream for: anObject in: evalContext
	| methodClass |

	methodClass := evalContext
		ifNil: [ anObject class ]
		ifNotNil: [ evalContext methodClass ].

	^ context class compiler
		source: aStream;
		class: methodClass;
		context: evalContext;
		requestor: context; "it should enable a visibility of current tool variables in new debugger"
		noPattern: true;
		failBlock: [ ^ nil ];
		compile! !

!SpCodeDebugItCommand methodsFor: 'private' stamp: ''!
debug: aStream
	| method doItReceiver doItContext |

	(self context respondsTo: #doItReceiver)
		ifTrue: [ 
			doItReceiver := self context doItReceiver.
			doItContext := self context doItContext ]
		ifFalse: [ 
			doItReceiver := doItContext := nil ].
		
	method := self compile: aStream for: doItReceiver in: doItContext.
	method isReturnSpecial ifTrue: [ 
		self inform: 'Nothing to debug, the expression is optimized'.
		^ self ].
	method ifNotNil: [
		self debug: method receiver: doItReceiver in: doItContext ]! !

!SpCodeDebugItCommand methodsFor: 'execution' stamp: ''!
execute
	| selection |

	selection := self selectedTextOrLine.
	selection ifEmpty: [ ^ '' ].
	
	self debug: selection readStream! !

!SpCodeDebugItCommand methodsFor: 'private' stamp: ''!
debug: aCompiledMethod receiver: anObject in: evalContext
	| process suspendedContext debugRequest |

	process := [ 
		aCompiledMethod
			valueWithReceiver: anObject
			arguments: (aCompiledMethod numArgs = 0 
				ifTrue: [ #() ] 
				ifFalse: [ { evalContext } ] ) ]
			newProcess.
	suspendedContext := process suspendedContext.

	debugRequest := (OupsDebugRequest newForContext: suspendedContext)
		process: process;
		compiledMethod: aCompiledMethod;
		label: 'debug it';
		yourself.
	debugRequest debugSession application: context application.
	debugRequest submit! !

!SpCodeDebugItCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $d shift command mac 
		| $d shift control win
		| $d shift control unix! !

!SpCodeDebugItCommand class methodsFor: 'default' stamp: ''!
defaultIconName

	^ #smallDebug! !

!SpCodeDebugItCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription

	^ 'Debug selection.'! !

!SpCodeDebugItCommand class methodsFor: 'default' stamp: ''!
defaultName 

	^ 'Debug it'! !

!SpCodeDoItCommand commentStamp: ''!
I'm a "do it" command. 
I will execute the selection (or line) of the playground.!
!SpCodeDoItCommand methodsFor: 'execution' stamp: ''!
execute
	"Treat the current text selection as an expression; evaluate it."
	
	self evaluateSelectionAndDo: [ :result | ]! !

!SpCodeDoItCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $d command mac 
		| $d control win 
		| $d control unix! !

!SpCodeDoItCommand class methodsFor: 'default' stamp: ''!
defaultIconName

	^ #smallDoIt! !

!SpCodeDoItCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription 

	^ 'Evaluate selection.'! !

!SpCodeDoItCommand class methodsFor: 'accessing' stamp: ''!
order

	^ 10! !

!SpCodeDoItCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Do it'! !

!SpCodeInspectItCommand commentStamp: ''!
I'm an "inspect it" command. 
I will execute the selection (or line) of the playground and inspect the result.!
!SpCodeInspectItCommand methodsFor: 'private - actions' stamp: ''!
inspectObject: anObject

	Smalltalk tools inspector openOn: anObject
	"(StInspector onObject: anObject)
		application: context application;
		openWithSpec"! !

!SpCodeInspectItCommand methodsFor: 'execution' stamp: ''!
execute
	"Treat the current text selection as an expression; evaluate it."
	
	self evaluateSelectionAndDo: [ :result | 
		self inspectObject: result ]! !

!SpCodeInspectItCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $i command mac 
		| $i control win
		| $i control unix! !

!SpCodeInspectItCommand class methodsFor: 'defaults' stamp: ''!
defaultIconName

	^ #smallInspectIt! !

!SpCodeInspectItCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription

	^ 'Evaluate selection and inspect the result.'! !

!SpCodeInspectItCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Inspect it'! !

!SpCodeInteractionModel commentStamp: ''!
@@TODO

A simple playground would be defined as: 

[[[language=Smalltalk
SpCodeInteractionMode newForScripting.
]]]

A code editor on a method: 

[[[language=Smalltalk
SpCodeInteractionMode newForMethod: aMethod.
]]]l 
 !
!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
text

	^ self owner text! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
variableBindings

	^ Dictionary new! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
doItContext

	^ nil! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
selectedBehavior

	^ self behavior! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
selectedClass

	^ self behavior! !

!SpCodeInteractionModel methodsFor: 'testing' stamp: ''!
hasBindingOf: aString

	^ self subclassResponsibility! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass

	^ self behavior! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
variableBindingNames
	
	^ self variableBindings keys! !

!SpCodeInteractionModel methodsFor: 'binding' stamp: ''!
bindingOf: aString

	^ self subclassResponsibility! !

!SpCodeInteractionModel methodsFor: 'testing' stamp: ''!
hasBindingThatBeginsWith: aString

	^ self variableBindingNames 
		anySatisfy: [ :each | each beginsWith: aString ]! !

!SpCodeInteractionModel methodsFor: 'interactive error protocol' stamp: ''!
notify: message at: location in: code
	| currentSelection stripMessage |

	"self owner withAdapterDo: [ :anAdapter | 
		anAdapter notify: message at: location in: code ]"

	stripMessage := (message endsWith: '->')
		ifTrue: [ message allButLast: 3 ]
		ifFalse: [ message ].

	currentSelection := self owner selectionInterval.
	self owner 
		insertErrorPopover: (SpCodePopoverErrorPresenter 
			newCode: self owner 
			message: stripMessage) 
		atIndex: (currentSelection isEmptyOrNil
			ifTrue: [ location ]
			ifFalse: [ 
				"both selection and location are 1-based, but position will be zero-based 
				 (zero=first element), to actually arrive to the position I want I need to 
				 substract two elements"
				currentSelection first + location - 2 ])! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
doItReceiver

	^ nil! !

!SpCodeInteractionModel methodsFor: 'testing' stamp: ''!
isForScripting

	^ false! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
owner: aPresenter

	owner := aPresenter! !

!SpCodeInteractionModel methodsFor: 'interactive error protocol' stamp: ''!
interactive

	^ true! !

!SpCodeInteractionModel methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
hasUnsavedCodeChanges
	^false! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
owner

	^ owner! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
bindings

	"no additional bindings provided by the Requestor"

	^ #() asDictionary! !

!SpCodeInteractionModel methodsFor: 'accessing' stamp: ''!
behavior

	^ nil! !

!SpCodeInteractionModelTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ self subclassResponsibility! !

!SpCodeInteractionModelTest methodsFor: 'running' stamp: ''!
initializeInstance: anInteractionModel! !

!SpCodeInteractionModelTest methodsFor: 'tests' stamp: ''!
testBindingOf

	self subclassResponsibility! !

!SpCodeInteractionModelTest methodsFor: 'tests' stamp: ''!
testBehavior

	self subclassResponsibility! !

!SpCodeInteractionModelTest methodsFor: 'tests' stamp: ''!
testDoItReceiver

	self assert: interactionModel doItReceiver isNil! !

!SpCodeInteractionModelTest methodsFor: 'tests' stamp: ''!
testHasBindingOf

	self subclassResponsibility! !

!SpCodeInteractionModelTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	interactionModel := self classToTest new.
	self initializeInstance: interactionModel! !

!SpCodeInteractionModelTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self = SpCodeInteractionModelTest ]! !

!SpCodeMethodInteractionModel methodsFor: 'accessing' stamp: ''!
method

	^ method! !

!SpCodeMethodInteractionModel methodsFor: 'testing' stamp: ''!
hasBindingOf: aString

	^ self behavior hasBindingOf: aString! !

!SpCodeMethodInteractionModel methodsFor: 'accessing' stamp: ''!
bindingOf: aString

	^ self behavior bindingOf: aString! !

!SpCodeMethodInteractionModel methodsFor: 'accessing' stamp: ''!
doItReceiver

	^ self behavior instanceSide! !

!SpCodeMethodInteractionModel methodsFor: 'accessing' stamp: ''!
method: aMethod

	method := aMethod! !

!SpCodeMethodInteractionModel methodsFor: 'accessing' stamp: ''!
behavior

	^ self method ifNotNil: [ self method methodClass ]! !

!SpCodeMethodInteractionModel class methodsFor: 'instance creation' stamp: ''!
on: aMethod

	^ self new method: aMethod! !

!SpCodeMethodInteractionModelTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpCodeMethodInteractionModel! !

!SpCodeMethodInteractionModelTest methodsFor: 'running' stamp: ''!
initializeInstance: anInteractionModel

	anInteractionModel method: self class >> #methodToTest! !

!SpCodeMethodInteractionModelTest methodsFor: 'tests' stamp: ''!
testBindingOf

	self assert: (interactionModel bindingOf: #somethingNotExistent) isNil.
	self assert: (interactionModel bindingOf: #Object) notNil! !

!SpCodeMethodInteractionModelTest methodsFor: 'accessing' stamp: ''!
methodToTest
	| a b |
	
	a := 21.
	b := 2.
	
	^ a * b! !

!SpCodeMethodInteractionModelTest methodsFor: 'tests' stamp: ''!
testBehavior

	self assert: interactionModel behavior equals: self class! !

!SpCodeMethodInteractionModelTest methodsFor: 'tests' stamp: ''!
testDoItReceiver

	self 
		assert: interactionModel doItReceiver 
		equals: self class! !

!SpCodeMethodInteractionModelTest methodsFor: 'tests' stamp: ''!
testHasBindingOf

	self deny: (interactionModel hasBindingOf: #somethingNotExistent).
	self deny: (interactionModel hasBindingOf: #Object)! !

!SpCodeNullInteractionModel methodsFor: 'testing' stamp: ''!
hasBindingOf: aString

	^ false! !

!SpCodeNullInteractionModel methodsFor: 'binding' stamp: ''!
bindingOf: aString

	^ nil! !

!SpCodeNullInteractionModelTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpCodeNullInteractionModel! !

!SpCodeNullInteractionModelTest methodsFor: 'tests' stamp: ''!
testBindingOf

	self assert: (interactionModel bindingOf: #somethingNotExistent) isNil.
	self assert: (interactionModel bindingOf: #Object) isNil! !

!SpCodeNullInteractionModelTest methodsFor: 'tests' stamp: ''!
testBehavior

	self assert: interactionModel behavior isNil! !

!SpCodeNullInteractionModelTest methodsFor: 'tests' stamp: ''!
testHasBindingOf

	self deny: (interactionModel hasBindingOf: #somethingNotExistent).
	self deny: (interactionModel hasBindingOf: #Object)! !

!SpCodeObjectInteractionModel methodsFor: 'testing' stamp: ''!
hasBindingOf: aString

	^ self doItReceiver hasBindingOf: aString! !

!SpCodeObjectInteractionModel methodsFor: 'binding' stamp: ''!
bindingOf: aString

	^ self doItReceiver bindingOf: aString! !

!SpCodeObjectInteractionModel methodsFor: 'accessing' stamp: ''!
object: anObject

	object := anObject! !

!SpCodeObjectInteractionModel methodsFor: 'accessing' stamp: ''!
doItReceiver

	^ self object! !

!SpCodeObjectInteractionModel methodsFor: 'testing' stamp: ''!
isForScripting

	^ true! !

!SpCodeObjectInteractionModel methodsFor: 'accessing' stamp: ''!
object

	^ object! !

!SpCodeObjectInteractionModel methodsFor: 'accessing' stamp: ''!
behavior

	^ self object class! !

!SpCodeObjectInteractionModel class methodsFor: 'instance creation' stamp: ''!
on: anObject

	^ self new object: anObject! !

!SpCodeObjectInteractionModelTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpCodeObjectInteractionModel! !

!SpCodeObjectInteractionModelTest methodsFor: 'running' stamp: ''!
tearDown

	objectToTest := nil.
	super tearDown! !

!SpCodeObjectInteractionModelTest methodsFor: 'running' stamp: ''!
initializeInstance: anInteractionModel

	anInteractionModel object: objectToTest! !

!SpCodeObjectInteractionModelTest methodsFor: 'tests' stamp: ''!
testBindingOf

	self assert: (interactionModel bindingOf: #somethingNotExistent) isNil.
	self assert: (interactionModel bindingOf: #Object) isNil! !

!SpCodeObjectInteractionModelTest methodsFor: 'tests' stamp: ''!
testBehavior

	self assert: interactionModel behavior equals: objectToTest class! !

!SpCodeObjectInteractionModelTest methodsFor: 'tests' stamp: ''!
testDoItReceiver

	self assert: interactionModel doItReceiver equals: objectToTest! !

!SpCodeObjectInteractionModelTest methodsFor: 'accessing' stamp: ''!
objectToTest

	^ objectToTest ifNil: [ objectToTest := SpCodePresenter new ]! !

!SpCodeObjectInteractionModelTest methodsFor: 'tests' stamp: ''!
testHasBindingOf

	self deny: (interactionModel hasBindingOf: #somethingNotExistent).
	self deny: (interactionModel hasBindingOf: #Object)! !

!SpCodePopoverErrorPresenter commentStamp: ''!
I show a compiler error as a popover (instead inserting an error string, which pollutes the text)!
!SpCodePopoverErrorPresenter methodsFor: 'accessing' stamp: ''!
code

	^ code! !

!SpCodePopoverErrorPresenter methodsFor: 'accessing' stamp: ''!
message: aString

	message := aString! !

!SpCodePopoverErrorPresenter methodsFor: 'initialization' stamp: ''!
initializeText

	text := self newText
		beNotWrapWord;
		propagateNaturalWidth: true;
		propagateNaturalHeight: false;
		editable: false;
		text: self message;
		"addStyle: 'codePopover';"
		addStyle: 'codePopoverError';
		yourself! !

!SpCodePopoverErrorPresenter methodsFor: 'api - focus' stamp: ''!
defaultKeyboardFocus

	^ text! !

!SpCodePopoverErrorPresenter methodsFor: 'api' stamp: ''!
dismiss

	super dismiss.
	self code takeKeyboardFocus! !

!SpCodePopoverErrorPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aString

	message := aString! !

!SpCodePopoverErrorPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self initializeText.

	layout := SpBoxLayout newTopToBottom
		add: text expand: false;
		yourself.

	self flag: #TODO. "This is uber bad. Keybindings needs to come from application configuration"
	text
		bindKeyCombination: 
			Character escape asKeyCombination 
			| Character backspace asKeyCombination 
			| Character cr asKeyCombination
			toAction: [ self dismiss ]! !

!SpCodePopoverErrorPresenter methodsFor: 'accessing' stamp: ''!
message

	^ message! !

!SpCodePopoverErrorPresenter methodsFor: 'accessing' stamp: ''!
code: aPresenter

	code := aPresenter! !

!SpCodePopoverErrorPresenter class methodsFor: 'instance creation' stamp: ''!
newCode: aPresenter message: aString

	^ (self on: aString)
		code: aPresenter;
		yourself! !

!SpCodePopoverPrintPresenter commentStamp: ''!
I show the result of a printing as part of a popover !
!SpCodePopoverPrintPresenter methodsFor: 'accessing' stamp: ''!
code

	^ code! !

!SpCodePopoverPrintPresenter methodsFor: 'initialization' stamp: ''!
newTextMultiLine: aString withScrollBars: withScrollBars
	| newText |		

	newText := self newText
		beNotWrapWord;
		propagateNaturalWidth: true;
		propagateNaturalHeight: withScrollBars not;
		editable: false;
		text: aString;
		yourself.

	"this is needed just for the gtk backend"
	withScrollBars ifTrue: [ 
		newText addScrollBarStyle: 'scrollbarPopoverLarge' ].
	
	^ newText! !

!SpCodePopoverPrintPresenter methodsFor: 'accessing' stamp: ''!
objectAsString
	| string |
	
	string := self basicObjectAsString.
	string size <= self class maxLengthShownInPopover 
		ifTrue: [ ^ string ].
	
	(string includesAny: Character separators) 
		ifTrue: [ ^ string withNoLineLongerThan: self class maxLengthShownInPopover ].
	
	^ String streamContents: [ :stream | 
			(string groupsOf: self class maxLengthShownInPopover)
				do: [ :each | stream << each ]
				separatedBy: [ stream cr ] ]! !

!SpCodePopoverPrintPresenter methodsFor: 'initialization' stamp: ''!
initializeText
	| string numLines |

	string := self objectAsString.
	numLines := string lines size.	
	text := self 
		newTextMultiLine: string 
		withScrollBars: numLines >= self class linesToShow.
		
	text 
		"addStyle: 'code';"
		addStyle: 'codePopover'! !

!SpCodePopoverPrintPresenter methodsFor: 'accessing' stamp: ''!
objectAsPrintString
	
	^ String streamContents: [ :stream |
		stream 
			<< ' "'
			<< self basicObjectAsString
			<< '"' ]! !

!SpCodePopoverPrintPresenter methodsFor: 'actions' stamp: ''!
dismissAndPrint

	self dismiss.
	self code insertAndSelectAfterCurrentSelection: self objectAsPrintString! !

!SpCodePopoverPrintPresenter methodsFor: 'actions' stamp: ''!
dismissAndInspect

	self dismiss.
	object inspect.
	"(SpCodeInspectItCommand forContext: context) execute"! !

!SpCodePopoverPrintPresenter methodsFor: 'api - focus' stamp: ''!
defaultKeyboardFocus

	^ text! !

!SpCodePopoverPrintPresenter methodsFor: 'api' stamp: ''!
dismiss

	super dismiss.
	self code takeKeyboardFocus! !

!SpCodePopoverPrintPresenter methodsFor: 'private' stamp: ''!
basicObjectAsString
	
	^ [ object printString ]
		on: Error
		do: [ '<error in printString: try ''Inspect it'' to debug>' ]! !

!SpCodePopoverPrintPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: anObject

	object := anObject! !

!SpCodePopoverPrintPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self initializeText.

	self layout: (SpBoxLayout newTopToBottom
		add: text expand: false;
		yourself).

	self flag: #TODO. "This is uber bad. Keybindings needs to come from application configuration"
	text
		bindKeyCombination: Character cr asKeyCombination | $p meta 
			toAction: [ self dismissAndPrint ];
		bindKeyCombination: $i meta 
			toAction: [ self dismissAndInspect ];
		bindKeyCombination: Character escape asKeyCombination | Character backspace asKeyCombination | $l meta
			toAction: [ self dismiss ]! !

!SpCodePopoverPrintPresenter methodsFor: 'accessing' stamp: ''!
code: aCodePresenter

	code := aCodePresenter! !

!SpCodePopoverPrintPresenter class methodsFor: 'instance creation' stamp: ''!
newCode: aCodePresenter object: anObject 

	^ (self on: anObject)
		code: aCodePresenter;
		yourself ! !

!SpCodePopoverPrintPresenter class methodsFor: 'accessing' stamp: ''!
maxLengthShownInPopover

	^ 80! !

!SpCodePopoverPrintPresenter class methodsFor: 'accessing' stamp: ''!
linesToShow

	^ 15! !

!SpCodePopoverPrintPresenterTest methodsFor: 'tests' stamp: ''!
testPopoverPopupTextTakesExtentFromPresenter
	| window popover string naturalSize |

	[
		window := SpLabelPresenter new openWithSpec.
		string := String loremIpsum withNoLineLongerThan: 80.
		presenter := SpCodePopoverPrintPresenter on: string.
		popover := window presenter newPopover
			bePositionRight;
			presenter: presenter;
			popup.
		MorphicRenderLoop new doOneCycle.	

		naturalSize := self naturalSizeOf: string.
		self 
			assert: popover adapter widget width >= naturalSize x;
			assert: popover adapter widget height >= naturalSize y ]
	ensure: [ 
		popover dismiss.
		window close ]! !

!SpCodePopoverPrintPresenterTest methodsFor: 'tests' stamp: ''!
testObjectAsString
	| string |

	presenter setModelBeforeInitialization: 10 factorial. 
	self 
		assert: presenter objectAsString 
		equals: '3628800'.

	presenter setModelBeforeInitialization: 42 factorial. 
	self 
		assert: presenter objectAsString 
		equals: '1405006117752879898543142606244511569936384000000000'.

	presenter setModelBeforeInitialization: 150 factorial.
	self 
		assert: presenter objectAsString 
		equals: (String streamContents: [ :stream | 
			(150 factorial asString 
				groupsOf: presenter class maxLengthShownInPopover)
				do: [ :each | stream << each ]
				separatedBy: [ stream cr ] ]).	
		
	string := String loremIpsum withNoLineLongerThan: presenter class maxLengthShownInPopover.
	presenter setModelBeforeInitialization: string.
	self 
		assert: presenter objectAsString 
		equals: string printString.
		
	string := String loremIpsum withNoLineLongerThan: 10.
	presenter setModelBeforeInitialization: string.
	self 
		assert: presenter objectAsString 
		equals: string printString! !

!SpCodePopoverPrintPresenterTest methodsFor: 'utilities' stamp: ''!
naturalSizeOf: string
	| stringMorph width height |

	"This is an incredible ugly hack because what should be the correct way of doing it: 
	 Font>>widthOfString: does not works (because it fails to take into account kerning).
	 Why it works on the Editing area is a mystery. 
	 BUT!! It does not work for monospaced fonts!! (again, no idea why)"
	stringMorph := RubEditingArea new 
		font: StandardFonts defaultFont;
		updateTextWith: string asString.

	width := stringMorph width + 12" min: self currentWorld width / 3".
	height := ((stringMorph
		beWrapped;
		width: width;
		yourself) height + 2).
		
	^ width @ height! !

!SpCodePopoverPrintPresenterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	presenter := SpCodePopoverPrintPresenter new! !

!SpCodePresenter commentStamp: ''!
I'm a code (Pharo code) presenter. 
I will style and provide completion according to the behaviour being edited.
!
!SpCodePresenter methodsFor: 'api' stamp: ''!
userActionDuring: aBlock
	"There are a buch of operations that will all trigger a backend update. A tipical case, 
	 changing text and interactionModel will trigger the text-changed event 3 times and that 
	 may cause an excesive compute that we want to avoid. 
	 We use #userActionDuring: to avoid that. 
	[[[language=Smalltalk
	aCodePresenter userActionDuring: [ 
		aCodePresenter
			beForScription;
			text: '42 factorial' ]
	]]]."
	
	self withAdapterDo: [ :anAdapter | 
		anAdapter userActionDuring: aBlock.
		^ self ].
	
	aBlock value! !

!SpCodePresenter methodsFor: 'command support' stamp: ''!
evaluate: aString onCompileError: compileErrorBlock onError: errorBlock 
	"evaluate aString. 
	 evaluate compileErrorBlock if there are compilation errors. 
	 evaluate errorBlock is anything happens *during* evaluation (code compiled, but it does not 
	 executes.). 
	 NOTE for future me. This is how I understand the evaluation works and why we need to catch 
	 differently the error: If there is a syntax error (avoiding compilation), it will evaluate 
	 requestor>>#notify:at:in: to notify the error and then it will call failBlock: *which is not 
	 intended to be used to throw an error*, since that should be handled (and it is) in the 
	 notification. Instead, most users of failBlock: use it to return execution without doing 
	 anything. 
	 Instead, the on:do: will catch all errors happening while executing the code once it is 
	 compiled. "
	| receiver result oldBindings |
	
	^ [
		oldBindings := self interactionModel bindings copy.
		receiver := self interactionModel doItReceiver.
		result := receiver class compiler
			source: aString readStream;
			context: self interactionModel doItContext;
			receiver: self interactionModel doItReceiver;
			requestor: self interactionModel;
			environment: self environment;
			failBlock:  [ ^ compileErrorBlock value ];
			evaluate.
		oldBindings size = self interactionModel bindings size 
			ifFalse: [ self withAdapterDo: [ :anAdapter | anAdapter refreshStyling ] ].
		result ]
	on: Error 
	do: errorBlock! !

!SpCodePresenter methodsFor: 'private' stamp: ''!
buildContextKeyBindingsWith: aCategory
	| category |
	
	category := self newContextMenuKeyBindings.
	aCategory ifNotNil: [ 
		aCategory allEntries keymaps do: [ :each |
			category addKeymapEntry: each ] ].
	
	^ category! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
selectedBehavior

	^ self behavior! !

!SpCodePresenter methodsFor: 'commands' stamp: ''!
doBrowseClass
	| result |

	result := self 
		evaluate: self selectedTextOrLine
		onCompileError: [ ^ self ]
		onError: [ :e | ^ self ].
	self systemNavigation browse: result! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
withLineNumbers

	self lineNumbers: true! !

!SpCodePresenter methodsFor: 'api - events' stamp: ''!
whenSubmitDo: aBlock
	"This method will add a 'submit' event to the widget. It will react when user 
	 presses <meta+s> key (this is for historical reasons) and with enter (cr).
	 `aBlock` receives one argument (the submited text)"

	submitBlock := aBlock.
	super whenSubmitDo: aBlock! !

!SpCodePresenter methodsFor: 'private' stamp: ''!
buildContextMenuWith: aValuable
	| menuPresenter |
	
	overrideContextMenu ifTrue: [ ^ aValuable ].

	menuPresenter := self newContextMenu.
	aValuable ifNotNil: [ 
		aValuable value ifNotNil: [ :menu |
			menu menuGroups do: [ :aGroup |
				menuPresenter addMenuGroup: aGroup ] ] ].

	^ menuPresenter! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
syntaxHighlightTheme: aSymbol
	"The name of the syntax highlight theme to use (e.g. 'Blue', 'Vintage', 'Solarized', 'Tango')"

	syntaxHighlightTheme := aSymbol! !

!SpCodePresenter methodsFor: 'command support' stamp: ''!
environment

	^ environment ifNil: [ self class environment ]! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
hasBindingThatBeginsWith: aString 
	
	^ self interactionModel
		ifNotNil: [ :im | im hasBindingThatBeginsWith: aString ] 
		ifNil: [ false ]! !

!SpCodePresenter methodsFor: 'command support' stamp: ''!
systemNavigation

	^ (systemNavigation ifNil: [ super systemNavigation ])
		environment: self environment;
		yourself! !

!SpCodePresenter methodsFor: 'commands' stamp: ''!
doBrowseMethodReferences

	self doBrowseSenders! !

!SpCodePresenter methodsFor: 'private - commands' stamp: ''!
browseSelectedSelectorIfGlobal: globalBlock ifNotGlobal: nonGlobalBlock
	| variableOrClassName variable |
	variableOrClassName := self selectedSelector.
	variableOrClassName ifNil: [ ^ nil ].

	variable := ((interactionModel doItContext
		ifNil: [ interactionModel behavior ])
			ifNil: [ environment
				ifNil: [ self class environment ] ])
					lookupVar: variableOrClassName declare: false.

	variable ifNil: [ ^ nonGlobalBlock value: variableOrClassName ].
	self systemNavigation openBrowserFor: variableOrClassName withMethods: variable usingMethods! !

!SpCodePresenter methodsFor: 'testing' stamp: ''!
hasSyntaxHighlight

	^ syntaxHighlight! !

!SpCodePresenter methodsFor: 'api - model' stamp: ''!
beForObject: anObject
	"Used when inspecting objects"

	self interactionModel: (SpCodeObjectInteractionModel on: anObject)! !

!SpCodePresenter methodsFor: '*NewTools-Sindarin-Commands' stamp: ''!
nonEmptySelectionInterval
	| selectionInterval |
	selectionInterval := self selectionInterval.
	selectionInterval isEmpty
		ifTrue: [ ^self selectLine ].
	^ selectionInterval! !

!SpCodePresenter methodsFor: 'api - events' stamp: ''!
triggerSubmitAction

	submitBlock ifNil: [ ^ self ].
	submitBlock value: self text! !

!SpCodePresenter methodsFor: 'api - events' stamp: ''!
whenLineNumbersChangedDo: aBlock
	"Set a block to perform when the syntax highlight is enabled/disabled"

	self property: #lineNumbers whenChangedDo: aBlock! !

!SpCodePresenter methodsFor: 'commands' stamp: ''!
doBrowseImplementors

	| result |
	result := self
		          browseSelectedSelectorIfGlobal: [ :global | global browse ]
		          ifNotGlobal: [ :selector | 
		          	self systemNavigation browseAllImplementorsOf: selector ].
	result ifNil: [ self application inform: 'No selectors found.' ]! !

!SpCodePresenter methodsFor: 'api - model' stamp: ''!
beForScripting
	"Use in playgrounds"

	self interactionModel: SpCodeScriptingInteractionModel new! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
syntaxHighlightTheme
	"The name of the syntax highlight theme to use (e.g. 'Blue', 'Vintage', 'Solarized', 'Tango'). 
	 If not defined, the component will take the default value from the system."

	^ syntaxHighlightTheme! !

!SpCodePresenter methodsFor: 'commands' stamp: ''!
doBrowseClassReferences
	| result class |

	result := self 
		evaluate: self selectedTextOrLine
		onCompileError: [ ^ self ]
		onError: [ :e | ^ self ].
		
	(result isClass or: [ result isTrait ])
		ifFalse: [ result := result class ].

	class := result instanceSide.
	class isTrait
		ifTrue: [ self systemNavigation browseAllUsersOfTrait: class ]
		ifFalse: [ self systemNavigation browseAllCallsOnClass: class ]! !

!SpCodePresenter methodsFor: 'api - model' stamp: ''!
beForBehavior: aBehavior
	"used when browsing classes or alike"

	self interactionModel: (SpCodeBehaviorInteractionModel on: aBehavior)! !

!SpCodePresenter methodsFor: 'commands' stamp: ''!
doBrowseMethodsMatchingStringSensitive
	
	self systemNavigation 
		browseMethodsWithString: self selectedTextOrLine 
		matchCase: true! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
behavior: aClass
	"Set the class corresponding to the method class of the source code you are editing"
	! !

!SpCodePresenter methodsFor: 'accessing' stamp: ''!
findClassFromSelection
	self flag: #TODO. "Does this really has to be part of the text api?"

	^ self findClassFrom: self selectedTextOrLine trimmed! !

!SpCodePresenter methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.

	"Use the default menu"
	overrideContextMenu := false.
	
	self withSyntaxHighlight.
	self withLineNumbers.
	
	self registerEventsForStyling.
	self clearInteractionModel! !

!SpCodePresenter methodsFor: 'private' stamp: ''!
syntaxHighlight: aBoolean
	syntaxHighlight := aBoolean ! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
selectedClassOrMetaClass

	^ self interactionModel ifNotNil: [ :im | im selectedClassOrMetaClass ]! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
withoutLineNumbers

	self lineNumbers: false! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
insertPopoverAfterCurrentSelection: aPresenter

	self 
		insertPopoverAfterCurrentSelection: aPresenter
		style: nil! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
insertPrintPopoverAfterCurrentSelection: anObject
	"Inserts a print-it result popover. 
	 This is for use of SpCodePrintItCommand"

	self 
		insertPopoverAfterCurrentSelection: (SpCodePopoverPrintPresenter 
			newCode: self
			object: anObject)
		style: 'print'! !

!SpCodePresenter methodsFor: 'api - model' stamp: ''!
beForMethod: aMethod
	"used when browsing methods"

	self interactionModel: (SpCodeMethodInteractionModel on: aMethod)! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
isForScripting

	^ self interactionModel 
		ifNotNil: [ :im | im isForScripting ]
		ifNil: [ false ]! !

!SpCodePresenter methodsFor: 'command support' stamp: ''!
systemNavigation: aSystemNavigation

	systemNavigation := aSystemNavigation! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
withSyntaxHighlight

	self syntaxHighlight: true! !

!SpCodePresenter methodsFor: 'testing' stamp: ''!
hasLineNumbers

	^ lineNumbers! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
insertErrorPopover: aPresenter atIndex: location

	self selectionInterval: ((location + 1) to: location).
	self insertPopoverAfterCurrentSelection: aPresenter style: 'error'.  ! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
overridingContextMenu
	"Indicates the context menu should will be overriden. This disabled the default context menu 
	 which includes all operations that can be executed in the context of code.
	 When overriding the code context menu, the only visible operations will be the ones you define 
	 on `SpAbstractTextPresenter>>contextMenu:`"
	
	self overrideContextMenu: true! !

!SpCodePresenter methodsFor: 'api - events' stamp: ''!
whenSyntaxHighlightThemeChangedDo: aBlock
	"Set a block to perform when the syntax highlight theme is changed"

	self property: #syntaxHighlightTheme whenChangedDo: aBlock! !

!SpCodePresenter methodsFor: 'api - events' stamp: ''!
whenInteractionModelChangedDo: aBlock
	"Set a block to perform when the behavior class changed"
	
	self 
		property: #interactionModel
		whenChangedDo: aBlock! !

!SpCodePresenter methodsFor: 'command support' stamp: ''!
selectedSelector
	"If text is selected, extract the selectors from the selected text. If there is no selection, try to extract the selectors under the caret position."
	| extractor selectedText fullSource |

	fullSource := self text.
	fullSource ifNil: [ ^ nil ].
	extractor := CNSelectorExtractor new.
	selectedText := self selectedText.
	^ selectedText
		  ifNotEmpty: [ 
				extractor extractSelectorFromSelection: selectedText ]
		  ifEmpty: [
				extractor
				  extractSelectorFromSource: fullSource
				  atPosition: (self cursorPositionIndex ifNil: [ 1 ]) ]! !

!SpCodePresenter methodsFor: 'api - shortcuts' stamp: ''!
contextKeyBindings

	^ self buildContextKeyBindingsWith: super contextKeyBindings! !

!SpCodePresenter methodsFor: 'private' stamp: ''!
basicInteractionModel: anInteractionModel

	interactionModel := anInteractionModel! !

!SpCodePresenter methodsFor: 'command support' stamp: ''!
environment: anEnvironment
	"Set system environment to be used in commands"
	
	environment := anEnvironment! !

!SpCodePresenter methodsFor: 'commands' stamp: ''!
doBrowseHierarchy
	| result |

	result := self 
		evaluate: self selectedTextOrLine
		onCompileError: [ ^ self ]
		onError: [ :e | ^ self ].
	(result isClass or: [ result isTrait ])
		ifFalse: [ result := result class ].
	self systemNavigation browseHierarchy: result! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
doItContext: anObject
! !

!SpCodePresenter methodsFor: 'private' stamp: ''!
overrideContextMenu: aBoolean
	"This property set the type of menu to use: if #overrideContextMenu is false (the default), 
	 the contextMenu will include code presenter default entries. If #overrideContextMenu is true, 
	 just what is defined in #contextMenu will be displayed"

	overrideContextMenu := aBoolean! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
bindingOf: aString

	self interactionModel ifNotNil:  [ :im | ^ im bindingOf: aString  ].
	^ nil! !

!SpCodePresenter methodsFor: 'commands' stamp: ''!
doBrowseSenders
	| result  |
	
	result := self browseSelectedSelectorIfGlobal: [ :global | 
			          self systemNavigation browseAllSendersOf: global ]
			          ifNotGlobal: [ :selector | 
			          self systemNavigation browseAllReferencesTo: selector ].
	result ifNil: [ self application inform: 'No selectors found.' ]! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
clearInteractionModel

	self interactionModel: SpCodeNullInteractionModel new! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
doItReceiver
	
	^ self interactionModel ifNotNil: [ :im | im doItReceiver ]! !

!SpCodePresenter methodsFor: 'commands' stamp: ''!
doBrowseMethodsContainingString
	
	self systemNavigation 
		browseMethodsWithSourceString: self selectedTextOrLine 
		matchCase: false! !

!SpCodePresenter methodsFor: 'private - testing' stamp: ''!
hasEditionContextMenu
	"Answer if edition context menu is active. 
	 Edition context menu is available by default, but it can be disabled by calling `SpTextPresenter>>#withoutEditionContextMenu` or `SpCodePresenter>>#overridingContextMenu`"

	^ super hasEditionContextMenu and: [ overrideContextMenu not ]! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
insertPopoverAfterCurrentSelection: aPresenter style: styleName
	"Popups a popover with contents `aPresenter` after current text selection. 
	 It adds `styleName` to the popover style."

	self withAdapterDo: [ :anAdapter |
		anAdapter insertPopoverAfterCurrentSelection: aPresenter style: styleName ]! !

!SpCodePresenter methodsFor: 'accessing' stamp: ''!
lineNumbers: aBoolean

	lineNumbers := aBoolean! !

!SpCodePresenter methodsFor: 'private' stamp: ''!
newContextMenu
	
	^ self rootCommandsGroup asMenuPresenter! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
selectedTextOrLine

	self selectedText ifNotEmpty: [ :aString | ^ aString ].
	self selectLine.
	^ self selectedText! !

!SpCodePresenter methodsFor: 'testing' stamp: ''!
hasResetAction

	^ resetBlock notNil! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
interactionModel

	^ interactionModel! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
doItReceiver: anObject
! !

!SpCodePresenter methodsFor: 'testing' stamp: ''!
hasSubmitAction

	^ submitBlock notNil! !

!SpCodePresenter methodsFor: 'private' stamp: ''!
newContextMenuKeyBindings
	
	^ self rootCommandsGroup asKMCategory! !

!SpCodePresenter methodsFor: 'api - events' stamp: ''!
triggerResetAction

	resetBlock ifNil: [ ^ self ].
	resetBlock value! !

!SpCodePresenter methodsFor: '*NewTools-Debugger' stamp: ''!
beForContext: aContext
	self interactionModel: (StDebuggerContextInteractionModel on: aContext)! !

!SpCodePresenter methodsFor: 'accessing' stamp: ''!
findClassFrom: aString
	| ast |
	
	self flag: #TODO. "Does this really has to be part of the code api?"

	ast := RBParser parseExpression: aString onError: [ ^ nil ].
	ast nodesDo: [ :node | 
		(node isVariable and: [ node name first isUppercase ])
			ifTrue: [ 
				(self class environment classNamed: node name)
					ifNotNil: [ :aClass | ^ aClass ] ] ].

	^ nil! !

!SpCodePresenter methodsFor: 'api - events' stamp: ''!
whenSyntaxHighlightChangedDo: aBlock
	"Set a block to perform when the syntax highlight is enabled/disabled"

	self property: #syntaxHighlight whenChangedDo: aBlock! !

!SpCodePresenter methodsFor: 'commands' stamp: ''!
doBrowseMethodsMatchingStringInsensitive
	
	self systemNavigation 
		browseMethodsWithString: self selectedTextOrLine 
		matchCase: false! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
doItContext

	^ self interactionModel ifNotNil: [ :im | im doItContext ]! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
insertPopover: aPresenter atIndex: location

	self selectionInterval: ((location + 1) to: location).
	self insertPopoverAfterCurrentSelection: aPresenter! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
hasBindingOf: aString

	self interactionModel ifNotNil: [ :im | ^ im hasBindingOf: aString ].
	^ false! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
contextMenu
	"The code presenter context menu is a compound of two menus: 
		1) the basic interoperation menu (that includes operations like cut&paste but also do it, 
		print it, etc.
		2) the user defined context menu.
    If you want to override completely this menu you need to set the 'overrideMenu' property 
	 to true"

	^ [ self buildContextMenuWith: super contextMenu ]! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
interactionModel: anInteractionModel

	anInteractionModel owner: self.
	self basicInteractionModel: anInteractionModel! !

!SpCodePresenter methodsFor: 'initialization' stamp: ''!
registerEventsForStyling

	self whenInteractionModelChangedDo: [ :im |
		self withAdapterDo: [ :anAdapter |
			anAdapter interactionModel: im ] ]! !

!SpCodePresenter methodsFor: 'api - events' stamp: ''!
whenResetDo: aBlock

	resetBlock := aBlock.
	super whenResetDo: aBlock! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
withoutSyntaxHighlight

	self syntaxHighlight: false! !

!SpCodePresenter methodsFor: 'api' stamp: ''!
allowingContextMenu
	"Indicates the default context menu should be shown (this is the default behaviour). 
	 When allowing the code context menu, visible operations will be collected from  `SpPresenter>>#rootCommandsGroup` and `SpTextPresenter>>#editionCommandsGroup`, and what user 
	 define on `SpAbstractTextPresenter>>contextMenu:` will be appended between those groups."
	
	self overrideContextMenu: false! !

!SpCodePresenter methodsFor: 'private - bindings' stamp: ''!
behavior
	"Return the class corresponding to the method class of the source code you are editing"
	
	^ self interactionModel ifNotNil: [ :im | im behavior ]! !

!SpCodePresenter class methodsFor: 'commands' stamp: ''!
buildEditionCommandsGroupWith: presenter forRoot: aCmCommandsGroup

	super buildEditionCommandsGroupWith: presenter forRoot: aCmCommandsGroup.	
	aCmCommandsGroup register: (self codeAcceptCommandsGroupWith: presenter)! !

!SpCodePresenter class methodsFor: 'commands' stamp: ''!
codeAcceptCommandsGroupWith: aPresenter
	| commandGroup |

	commandGroup := (CmCommandGroup named: 'Accept commands') asSpecGroup
		description: 'Accept or cancel changes.';
		beDisplayedAsGroup;
		yourself.
	
	aPresenter hasSubmitAction ifTrue: [ 
		commandGroup register: (SpAcceptChangesCommand forSpecContext: aPresenter) ].
	aPresenter hasResetAction ifTrue: [ 
		commandGroup register: (SpCancelChangesCommand forSpecContext: aPresenter) ].

	^ commandGroup! !

!SpCodePresenter class methodsFor: 'commands' stamp: ''!
codeSelectionActionCommandsGroupWith: presenter
	| group |
	
	group := (CmCommandGroup named: 'Selection action commands') asSpecGroup.
	group
		description: 'Actions on code selection.';
		beDisplayedAsGroup.
	
	SpCodeSelectionCommand allOrdered 
		do: [ :cmdClass | group register: (cmdClass forSpecContext: presenter) ].
	
	^ group! !

!SpCodePresenter class methodsFor: 'examples' stamp: ''!
exampleOverridingContextMenu
	"This example will show a code presenter, but context menu will be overriden and 
	 it will show just what is defined in #contextMenu: send"
	
	^ self new
		overridingContextMenu;
		contextMenu: (SpMenuPresenter new
			addGroup: [ :group | group addItem: [ :item | 
				item name: 'Testing' ] ]);
		text: 'some method: 42';
		openWithSpec! !

!SpCodePresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newCode! !

!SpCodePresenter class methodsFor: 'examples' stamp: ''!
example

	^ self new
		text: 'some method: 42';
		openWithSpec
! !

!SpCodePresenter class methodsFor: 'commands' stamp: ''!
buildCommandsGroupWith: presenter forRoot: aCmCommandsGroup

	aCmCommandsGroup beDisplayedAsGroup.
	aCmCommandsGroup register: (self codeSelectionActionCommandsGroupWith: presenter).
	aCmCommandsGroup register: (self codeNavigationCommandsGroupWith: presenter)! !

!SpCodePresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #CodeAdapter! !

!SpCodePresenter class methodsFor: 'commands' stamp: ''!
codeNavigationCommandsGroupWith: aPresenter
	| group |
	
	group := (CmCommandGroup named: 'Code search') asSpecGroup
		description: 'Search the system from code selection.';
		beDisplayedAsSubMenu;
		yourself.
		
	self flag: #TODO. "This looks like a very bad way to do this :P"	
	{ 
		SpBrowseClassCommand.		
		SpBrowseImplementorsCommand.
		SpBrowseSendersCommand.
		SpBrowseMethodReferencesCommand.	
		SpBrowseMethodsMatchingStringInsensitiveCommand.
		SpBrowseMethodsMatchingStringSensitiveCommand.
		SpBrowseMethodsContainingStringCommand.
	 } 
	do:[ :commandClass | 
		group register: commandClass forSpec ].
	
	^ group! !

!SpCodePresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Code'! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseMethodsMatchingStringSensitive
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	"Restrict environment to make things faster"
	presenter environment: (SystemDictionary new 
		at: #SpCodePresenterTest put: SpCodePresenterTest;
		yourself).
		
	"no matter what I put, it will find it in this method"
	"First do not find it (case sensitive)"
	presenter text: 'MatchTextToFind' asLowercase. 
	presenter doBrowseMethodsMatchingStringSensitive.
	
	self assert: navigation messageList isEmpty.
	
	"Now find it"
	navigation reset.
	presenter text: 'MatchTextToFind'. 
	presenter doBrowseMethodsMatchingStringSensitive.
	
	self assert: navigation messageList notEmpty.
	self assert: (navigation messageList includes: SpCodePresenterTest >> #testDoBrowseMethodsMatchingStringSensitive).
	! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseClassReferences
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	presenter text: 'SpCodePresenterTest'.
	"Selection"
	presenter selectionInterval: (1 to: 19).
	presenter doBrowseClassReferences.
	
	self assert: navigation messageList notNil.
	self assert: navigation messageList notEmpty! !

!SpCodePresenterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	super initializeTestedInstance.
	presenter environment: self newEnvironment! !

!SpCodePresenterTest methodsFor: 'tests' stamp: ''!
testContextMenu
	| menu changed |
	
	self assert: presenter contextMenu isNotNil. "The code presenter comes with a menu by default"
	menu := SpMenuPresenter new.
	changed := false.
	presenter whenMenuChangedDo: [ 
		changed := true. ].
	presenter contextMenu: menu.
	self assert: changed! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseImplementors
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	presenter text: 'testDoBrowseImplementors'.
	presenter doBrowseImplementors.
	
	self 
		assert: navigation messageList asArray
		equals: { SpCodePresenterTest>>#testDoBrowseImplementors }! !

!SpCodePresenterTest methodsFor: 'tests' stamp: ''!
testContextKeyBindings
	| contextKeyBindings |
	
	contextKeyBindings := presenter contextKeyBindings.
	self assert: contextKeyBindings notNil.
	self assert: (contextKeyBindings isKindOf: KMCategory).
	! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassNameWhenInPlaygroundAndEnvironmentIsNil
	| navigation theClass |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	
	"Reproduce the case of the playground when the environment is nil. We should check on the environment of the tools?"
	presenter environment: nil.
	
	presenter interactionModel: SpCodeScriptingInteractionModel new.
	self openInstance.
	
	presenter text: 'SpNavigationMockClass'.
	presenter doBrowseSenders.
	
	theClass := self class environment at: #SpNavigationMockClass.
	
	self assert: (navigation messageList includes: theClass >> #referenceToYourself)! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseHierarchy
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	presenter text: 'SpCodePresenterTest'.
	"Selection"
	presenter selectionInterval: (1 to: 19).
	presenter doBrowseHierarchy.
	
	self assert: navigation browseClass equals: SpCodePresenterTest! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseClass
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	presenter text: 'SpCodePresenterTest'.
	"Selection"
	presenter selectionInterval: (1 to: 19).
	presenter doBrowseClass.
	
	self assert: navigation browseClass equals: SpCodePresenterTest.
	
	navigation reset.
	"Line"
	presenter cursorPositionIndex: 1.
	presenter selectionInterval: (1 to: 0).
	presenter doBrowseClass.
	self assert: navigation browseClass equals: SpCodePresenterTest.
	
	"Middle of line"
	presenter cursorPositionIndex: 5.
	presenter selectionInterval: (5 to: 4).
	presenter doBrowseClass.
	self assert: navigation browseClass equals: SpCodePresenterTest.

	"End of line"
	presenter cursorPositionIndex: 14.
	presenter selectionInterval: (14 to: 13).
	presenter doBrowseClass.
	self assert: navigation browseClass equals: SpCodePresenterTest.! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassPoolVariableShouldSelectClassPoolVariableUsersWhenInDebuggerButNotAvailable
	| navigation theClass methodInContext evaluationContext |

	theClass := self class environment at: #SpNavigationMockClass.
	methodInContext := Object >> #yourself.
	evaluationContext := (Context newForMethod: methodInContext)
		pc: methodInContext initialPC;
		privRefreshWith: methodInContext;
		yourself.
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	presenter interactionModel: (SpContextInteractionModel
		on: evaluationContext).
	self openInstance.
	
	"Add the binding to the testing environment so we can look for users of it"
	presenter text: 'SomeClassPoolVariable'.
	presenter doBrowseSenders.

	
	self assert: navigation messageList isEmpty! !

!SpCodePresenterTest methodsFor: 'tests' stamp: ''!
testWhenSyntaxHighlightChangedDo
	| count result |
	count := 0.
	result := true.
	presenter
		whenSyntaxHighlightChangedDo: [ :syntaxHighlight | 
			count := count + 1.
			result := syntaxHighlight ].
	presenter withoutSyntaxHighlight.
	self assert: count equals: 1.
	self deny: result! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassNameWhenInPlaygroundButNotAvailable
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	presenter interactionModel: SpCodeScriptingInteractionModel new.
	self openInstance.
	
	presenter text: 'NonExistingClassPleaseFindNothingXXXXXX'.
	presenter doBrowseSenders.
	
	self assert: navigation messageList isEmpty! !

!SpCodePresenterTest methodsFor: 'tests' stamp: ''!
testWhenSyntaxHighlightThemeChangedDo
	| count result |
	
	count := 0.
	result := nil.
	presenter whenSyntaxHighlightThemeChangedDo: [ :syntaxHighlight | 
		count := count + 1.
		result := syntaxHighlight ].
	presenter syntaxHighlightTheme: 'Other'.
	
	self assert: count equals: 1.
	self assert: result equals: 'Other'! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSenders
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	presenter text: 'doBrowseSenders'.
	presenter doBrowseSenders.
	
	self assert: navigation messageList notEmpty.
	self assert: (navigation messageList includes: SpCodePresenterTest >> #testDoBrowseSenders)! !

!SpCodePresenterTest methodsFor: 'tests' stamp: ''!
testFindClassFrom

	self assert: (presenter findClassFrom: '') equals: nil.
	self assert: (presenter findClassFrom: 'Object') equals: Object.
	self assert: (presenter findClassFrom: 'Object.') equals: Object.
	self assert: (presenter findClassFrom: '.Object.') equals: Object.
	self
		assert: (presenter findClassFrom: 'somethingBefore := 42.Object')
		equals: Object.
	self
		assert:
			(presenter
				findClassFrom: 'somethingBefore := 42.Object. somethingAfter := 11')
		equals: Object.
	self
		assert: (presenter findClassFrom: 'NonExistingClass.Object.')
		equals: Object! !

!SpCodePresenterTest methodsFor: 'tests - command support' stamp: ''!
testEnvironment
	| environment navigation |
	
	"Since the environment is not actually working, this is hard to test for now"
	self skip.

	environment := self newEnvironment.
	navigation := SpCodeSystemNavigationMock new.
	
	presenter environment: environment.
	presenter systemNavigation: navigation.
	
	self openInstance.
	
	"we will find Object but not OrderedCollection"
	presenter text: 'Object'.
	presenter doBrowseClass.
	
	self assert: navigation browseClass equals: Object.
	
	navigation reset.
 	presenter text: 'OrderedCollection'.
	presenter doBrowseClass.
	
	self assert: navigation browseClass isNil
! !

!SpCodePresenterTest methodsFor: 'tests' stamp: ''!
testNilTestSelectedSelectorDoesNotBreakExecution
	"Code presenter has nil text for some reason"

	| selector |
	presenter text: nil.
	selector := presenter selectedSelector.
	self assert: selector isNil.! !

!SpCodePresenterTest methodsFor: 'tests - command support' stamp: ''!
testSelectedSelector

	"Testing border cases to avoid breaking execution. The selector extraction logic should be tested in the extractor class"

	"Code presenter has nil text for some reason"

	| selector |
	presenter text: nil.
	selector := presenter selectedSelector.
	self assert: selector isNil.

	"Code presenter is empty"
	presenter text: ''.
	selector := presenter selectedSelector.
	self assert: selector isNil.

	"Code has valid code"
	selector := presenter text: 'anObject do: 1 with: 2'.
	selector := presenter selectedSelector.
	self assert: selector equals: #do:with:.

	"Code has faulty code"
	selector := presenter text: 'anObject do : 1 with: 2'.
	selector := presenter selectedSelector.
	self assert: selector equals: #do.

	"Code has invalid code (no selectors at all)"
	"selector := presenter text: 'anObjectdo : 2'.
	selector := presenter selectedSelector.
	self assert: selector equals: #noMethod"! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseMethodsContainingString
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	"Restrict environment to make things faster"
	presenter environment: (SystemDictionary new 
		at: #SpCodePresenterTest put: SpCodePresenterTest;
		yourself).
	presenter text: 'testDoBrowseMethodsContainingString'.
	presenter doBrowseMethodsContainingString.
	
	self assert: navigation messageList notEmpty.
	self assert: (navigation messageList includes: SpCodePresenterTest >> #testDoBrowseMethodsContainingString)! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseMethodReferences
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	presenter text: 'testDoBrowseMethodReferencesX'.
	presenter doBrowseMethodReferences.
	
	self assert: navigation messageList isEmpty.
	
	navigation reset.
	presenter text: 'doBrowseMethodReferences'.
	presenter doBrowseMethodReferences.
	
	self assert: navigation messageList notEmpty.
	self assert: (navigation messageList includes: SpCodePresenterTest >> #testDoBrowseMethodReferences)! !

!SpCodePresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpCodePresenter! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseMethodsMatchingStringInsensitive
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	"Restrict environment to make things faster"
	presenter environment: (SystemDictionary new 
		at: #SpCodePresenterTest put: SpCodePresenterTest;
		yourself).
		
	"no matter what I put, it will find it in this method"
	"First find it even if is not same case (case insensitive)"
	presenter text: 'MatchTextToFind' asLowercase. 
	presenter doBrowseMethodsMatchingStringInsensitive.
	
	self assert: navigation messageList notEmpty.
	self assert: (navigation messageList includes: SpCodePresenterTest >> #testDoBrowseMethodsMatchingStringSensitive).
	
	"Now find it matching if sensitive"
	navigation reset.
	presenter text: 'MatchTextToFind'. 
	presenter doBrowseMethodsMatchingStringSensitive.
	
	self assert: navigation messageList notEmpty.
	self assert: (navigation messageList includes: SpCodePresenterTest >> #testDoBrowseMethodsMatchingStringSensitive).
	! !

!SpCodePresenterTest methodsFor: 'testing' stamp: ''!
expectedFailures

	"This test do not pass on CI because headless image has display size = 0@0 and then 
	 morphic behaves weird. PropagateNaturalHeight/Width is weak on Morphic because of 
	 this (if not, see the algoritm I was forced to do), but for now passes (just, not on CI :)"
	Smalltalk isHeadless ifTrue: [ ^ #() ].

	"This test will not work on SpCodePresenter because it uses a monospaced font (and this 
	 fails in morphic)"
	^ #(testPropagateNaturalWidth)! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassVariableShouldSelectClassVariableUsersWhenInStaticContext
	| navigation theClass |
	
	theClass := self class environment at: #SpNavigationMockClass.
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	presenter interactionModel: (SpCodeBehaviorInteractionModel
		on: theClass).
	self openInstance.
	
	"Add the binding to the testing environment so we can look for users of it"
	presenter text: 'SomeClassVariable'.
	presenter doBrowseSenders.

	
	self assert: (navigation messageList includes: theClass >> #referenceToTheClassVariable)! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassVariableShouldSelectClassVariableUsersWhenInStaticContextButNotAvailable
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	presenter interactionModel: (SpCodeBehaviorInteractionModel
		on: Object).
	self openInstance.
	
	"Add the binding to the testing environment so we can look for users of it"
	presenter text: 'SomeClassVariable'.
	presenter doBrowseSenders.

	
	self assert: navigation messageList isEmpty! !

!SpCodePresenterTest methodsFor: 'instance creation' stamp: ''!
newEnvironment
	| environment |
	
	environment := SystemDictionary new.
	self class withAllSuperclassesDo: [ :each |
		environment at: each name put: each ].
	
	^ environment! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseClassNotFound
	| navigation |
	
	"in fact, compiling a non existing class is popping a a dialog to choose what 
	 to do (I hate that). Until that is fixed, this test is useless."
	self skip.
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	presenter text: 'ClassThatDoesNotExits'.
	presenter doBrowseClass.
	
	self assert: navigation messageList isNil! !

!SpCodePresenterTest methodsFor: 'tests - command support' stamp: ''!
testSelectedSelectorWithPointerAtEnd
	"Testing border cases to avoid breaking execution. The selector extraction logic should be tested in the extractor class"
	| selector string |

	self openInstance.

	"end of text with several posibilities"
	string := 'Smalltalk allClassesAndTraits reject: #hasComment'.
	presenter text: string.
	"move cursor to end"
	presenter cursorPositionIndex: string size + 1.
	"ensure there is no selection"
	presenter clearSelection.
	"for some reason, clear selection also moved the pointer back to first position. 
	 IMO trhat should not happen, but seems to be a rubric problem. I hacke the selection by 
	 respecting the position wiyh next line."
	presenter selectionInterval: ((string size + 1) to: string size).
	selector := presenter selectedSelector.
	self assert: selector equals: #hasComment.

	"end of text with several lines"	
	string := '42 factorial.
Smalltalk allClassesAndTraits reject: #hasComment'.
	presenter text: string.
	"move cursor to end"
	presenter cursorPositionIndex: string size + 1.
	"ensure there is no selection"
	"ensure there is no selection"
	presenter clearSelection.
	presenter selectionInterval: ((string size + 1) to: string size).
	selector := presenter selectedSelector.
	self assert: selector equals: #hasComment! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassPoolVariableShouldSelectClassPoolVariableUsersWhenInDebugger
	| navigation theClass methodInContext evaluationContext |

	theClass := self class environment at: #SpNavigationMockClass.
	methodInContext := theClass >> #referenceToTheClassVariable.
	evaluationContext := (Context newForMethod: methodInContext)
		pc: methodInContext initialPC;
		privRefreshWith: methodInContext;
		yourself.
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	presenter interactionModel: (SpContextInteractionModel
		on: evaluationContext).
	self openInstance.
	
	"Add the binding to the testing environment so we can look for users of it"
	presenter text: 'SomeClassPoolVariable'.
	presenter doBrowseSenders.

	
	self assert: (navigation messageList includes: theClass >> #referenceToTheClassPoolVariable)! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassVariableShouldSelectClassVariableUsersWhenInDebuggerButNotAvailable
	| navigation theClass methodInContext evaluationContext |

	theClass := self class environment at: #SpNavigationMockClass.
	methodInContext := Object >> #yourself.
	evaluationContext := (Context newForMethod: methodInContext)
		pc: methodInContext initialPC;
		privRefreshWith: methodInContext;
		yourself.
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	presenter interactionModel: (SpContextInteractionModel
		on: evaluationContext).
	self openInstance.
	
	"Add the binding to the testing environment so we can look for users of it"
	presenter text: 'SomeClassVariable'.
	presenter doBrowseSenders.

	
	self assert: navigation messageList isEmpty! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassVariableShouldSelectClassVariableUsersWhenInDebugger
	| navigation theClass methodInContext evaluationContext |

	theClass := self class environment at: #SpNavigationMockClass.
	methodInContext := theClass >> #referenceToTheClassVariable.
	evaluationContext := (Context newForMethod: methodInContext)
		pc: methodInContext initialPC;
		privRefreshWith: methodInContext;
		yourself.
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	presenter interactionModel: (SpContextInteractionModel
		on: evaluationContext).
	self openInstance.
	
	"Add the binding to the testing environment so we can look for users of it"
	presenter text: 'SomeClassVariable'.
	presenter doBrowseSenders.

	
	self assert: (navigation messageList includes: theClass >> #referenceToTheClassVariable)! !

!SpCodePresenterTest methodsFor: 'tests - command support' stamp: ''!
testEvaluateOnCompileErrorOnError

	self 
		assert: (presenter evaluate: 'Obj { }}' onCompileError: [ #compile ] onError: [ :e | #error ])
		equals: #compile.
		
	self 
		assert: (presenter evaluate: 'nil text' onCompileError: [ #compile ] onError: [ :e | #error ])
		equals: #error.	
		
	self 
		assert: (presenter evaluate: '42' onCompileError: [ #compile ] onError: [ :e | #error ])
		equals: 42.		! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassNameShouldNotFindIfNotInEnvironment
	| navigation |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	presenter text: 'NonExistingClassPleaseFindNothingXXXXXX'.
	presenter doBrowseSenders.
	
	self assert: navigation messageList isEmpty! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassNameShouldSelectClassUsers
	| navigation theClass |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	self openInstance.
	
	"Add the binding to the testing environment so we can look for users of it"
	presenter environment add: SpNavigationMockClass binding.
	presenter text: 'SpNavigationMockClass'.
	presenter doBrowseSenders.
	
	theClass := self class environment at: #SpNavigationMockClass.
	
	self assert: (navigation messageList includes: theClass >> #referenceToYourself)! !

!SpCodePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoBrowseSendersOfClassNameWhenInPlayground
	| navigation theClass |
	
	navigation := SpCodeSystemNavigationMock new.
	presenter systemNavigation: navigation.
	
	"Add the binding to the testing environment so we can look for users of it"
	presenter environment add: SpNavigationMockClass binding.
	presenter interactionModel: SpCodeScriptingInteractionModel new.
	self openInstance.
	
	presenter text: 'SpNavigationMockClass'.
	presenter doBrowseSenders.
	
	theClass := self class environment at: #SpNavigationMockClass.
	
	self assert: (navigation messageList includes: theClass >> #referenceToYourself)! !

!SpCodePrintItCommand commentStamp: ''!
I'm a "print it" command. 
I will evalute the selection (or line) of the playground and print the result as string!
!SpCodePrintItCommand methodsFor: 'execution' stamp: ''!
execute
	"Treat the current text selection as an expression; evaluate it. Insert the 
	description of the result of evaluation after the selection and then make 
	this description the new text selection."

	self evaluateSelectionAndDo: [ :result | 
		self printObject: result ]! !

!SpCodePrintItCommand methodsFor: 'private' stamp: ''!
printObject: anObject

	self context insertPrintPopoverAfterCurrentSelection: anObject! !

!SpCodePrintItCommand methodsFor: 'private' stamp: ''!
toPrintableString: printString

	self flag: #TODO. "This is maybe not the best? 
	I think I need to add a popover, but that then means I need to 
	have a special way to handle this special 'insertion' (to transmit the correct insertion 
	to the presenter's adapter)."
	^ String streamContents: [ :stream |
		stream << ' ' << printString  ]! !

!SpCodePrintItCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $p command mac
		| $p control win
		| $p control unix! !

!SpCodePrintItCommand class methodsFor: 'default' stamp: ''!
defaultIconName

	^ #smallPrintIt! !

!SpCodePrintItCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription

	^ 'Evaluate selection and print the result.'! !

!SpCodePrintItCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Print it'! !

!SpCodeProfileItCommand commentStamp: ''!
I'm a "profile it" command. 
I will evalute the selection (or line) of the playground using a profiler.!
!SpCodeProfileItCommand methodsFor: 'execution' stamp: ''!
execute

	self flag: 'TODO'! !

!SpCodeProfileItCommand class methodsFor: 'defaults' stamp: ''!
defaultIconName

	^ #smallProfile! !

!SpCodeProfileItCommand class methodsFor: 'defaults' stamp: ''!
defaultName

	^ 'Profile it'! !

!SpCodeScriptingInteractionModel methodsFor: 'accessing' stamp: ''!
addBinding: aBinding

	self bindings add: aBinding! !

!SpCodeScriptingInteractionModel methodsFor: 'accessing' stamp: ''!
variableBindings

	^ self bindings! !

!SpCodeScriptingInteractionModel methodsFor: 'accessing' stamp: ''!
removeBinding: aBinding
 
	self bindings removeKey: aBinding key! !

!SpCodeScriptingInteractionModel methodsFor: 'testing' stamp: ''!
hasBindingOf: aString

	^ self bindings includesKey: aString asSymbol! !

!SpCodeScriptingInteractionModel methodsFor: 'binding' stamp: ''!
bindingOf: aString

	"if there is no binding, I will include a key"
	(self bindings includesKey: aString)
		ifFalse: [ self addBinding: (WorkspaceVariable key: aString asSymbol) ].
	^ self bindings associationAt: aString! !

!SpCodeScriptingInteractionModel methodsFor: 'testing' stamp: ''!
isForScripting

	^ true! !

!SpCodeScriptingInteractionModel methodsFor: 'accessing' stamp: ''!
bindings

	^ bindings ifNil: [ bindings := Dictionary new ]! !

!SpCodeScriptingInteractionModelTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpCodeScriptingInteractionModel! !

!SpCodeScriptingInteractionModelTest methodsFor: 'tests' stamp: ''!
testVariableBindings

	"this is used in some contexts, but it is just a synonym"
	self 
		assert: interactionModel variableBindings 
		equals: interactionModel bindings! !

!SpCodeScriptingInteractionModelTest methodsFor: 'tests' stamp: ''!
testAddBinding

	interactionModel addBinding: (WorkspaceVariable key: #testVar2 value: 42).
	self assert: interactionModel bindings size equals: 2! !

!SpCodeScriptingInteractionModelTest methodsFor: 'initialization' stamp: ''!
initializeInstance: anInteractionModel

	anInteractionModel addBinding: (WorkspaceVariable  key: #testVar value: 42)! !

!SpCodeScriptingInteractionModelTest methodsFor: 'tests' stamp: ''!
testBindingOf

	"auto create of bindings on demand (it will always answer a value)"
	self assert: (interactionModel bindingOf: #somethingNotExistent) notNil.
	self assert: (interactionModel bindingOf: #somethingNotExistent) value isNil.
	"... even if it is an Object variable... is this correct?"
	self assert: (interactionModel bindingOf: #Object) notNil.
	self assert: (interactionModel bindingOf: #Object) value isNil.
	"and of course it will answer our added bindings"
	self assert: (interactionModel bindingOf: #testVar) notNil.
	self assert: (interactionModel bindingOf: #testVar) value equals: 42
	
	! !

!SpCodeScriptingInteractionModelTest methodsFor: 'tests' stamp: ''!
testRemoveBinding

	interactionModel removeBinding: (WorkspaceVariable key: #testVar).
	self assert: interactionModel bindings isEmpty! !

!SpCodeScriptingInteractionModelTest methodsFor: 'tests' stamp: ''!
testBehavior

	self assert: interactionModel behavior isNil! !

!SpCodeScriptingInteractionModelTest methodsFor: 'tests' stamp: ''!
testHasBindingOf

	self deny: (interactionModel hasBindingOf: #somethingNotExistent).
	self deny: (interactionModel hasBindingOf: #Object).

	self assert: (interactionModel hasBindingOf: #testVar)	! !

!SpCodeScriptingInteractionModelTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	
	^ true! !

!SpCodeSelectionCommand commentStamp: ''!
I'm a code presenter command who's actions depends on the selected text.
In case no text is selected, the commands will take the text from cursor position to begining of line as an "ad hoc" selection.

"context" needs to conform a certain api to be used here: 

- selectedText
- selectedTextOrLine
- doItReceiver
- doItContext!
!SpCodeSelectionCommand methodsFor: 'private' stamp: ''!
evaluateSelectionAndDo: aBlock
	"Treat the current selection as an expression; evaluate it and invoke aBlock with the result.
	If no selection is present select the current line."
	| selection |
	
	selection := self selectedTextOrLine.
	selection ifEmpty: [ ^ '' ].
	
	^ self 
		evaluate: selection 
		andDo: aBlock! !

!SpCodeSelectionCommand methodsFor: 'converting' stamp: ''!
asSpecCommand

	^ SpToolCurrentApplicationCommand decorate: super asSpecCommand! !

!SpCodeSelectionCommand methodsFor: 'accessing' stamp: ''!
selectedTextOrLine

	^ self context selectedTextOrLine! !

!SpCodeSelectionCommand methodsFor: 'private' stamp: ''!
evaluate: aString andDo: aBlock
	"Treat the current selection as an expression; evaluate it and invoke 
	 aBlock with the result."

	aBlock value: (self context 
		evaluate: aString
		onCompileError: [ ^ self ]
		onError: [ :e | e pass ]).! !

!SpCodeSelectionCommand class methodsFor: 'documentation' stamp: ''!
documentContextRequiredSelectors

	^ super documentContextRequiredSelectors, #(selectedTextOrLine)! !

!SpCodeSelectionCommand class methodsFor: 'accessing' stamp: ''!
order
	"At last by default"
	^ 999! !

!SpCodeSelectionCommand class methodsFor: 'accessing' stamp: ''!
allOrdered

	^ self allSubclasses sorted: #order ascending! !

!SpCodeStyleForTest methodsFor: 'comparing' stamp: ''!
= aTag 

	^ self foreground = aTag foreground! !

!SpCodeStyleForTest methodsFor: 'accessing' stamp: ''!
foreground: anObject
	foreground := anObject! !

!SpCodeStyleForTest methodsFor: 'accessing' stamp: ''!
foreground
	^ foreground! !

!SpCodeSystemNavigationMock methodsFor: 'opening' stamp: ''!
browse: aClass

	browseClass := aClass! !

!SpCodeSystemNavigationMock methodsFor: 'enumerating' stamp: ''!
browseMessageList: aList name: labelString autoSelect: autoSelectString refreshingBlock: aBlock

	messageList 	:= aList
	! !

!SpCodeSystemNavigationMock methodsFor: 'accessing' stamp: ''!
browseClass

	^ browseClass! !

!SpCodeSystemNavigationMock methodsFor: 'accessing' stamp: ''!
browseSelector

	^ browseSelector! !

!SpCodeSystemNavigationMock methodsFor: 'accessing' stamp: ''!
messageList

	^ messageList! !

!SpCodeSystemNavigationMock methodsFor: 'accessing' stamp: ''!
browseHierarchy: aClass selector: aSelector

	browseClass := aClass.
	browseSelector := aSelector! !

!SpCodeSystemNavigationMock methodsFor: 'accessing' stamp: ''!
reset

	browseClass := nil.
	browseSelector := nil.	
	messageList := nil
! !

!SpCollectionListModel commentStamp: ''!
A collection model to be used with list presenters (`SpAbstractListPresenter` and children).

This model receives a `collection` of elements to be served to the list.!
!SpCollectionListModel methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpCollectionListModel methodsFor: 'accessing' stamp: ''!
collection
	^ collection! !

!SpCollectionListModel methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpCollectionListModel methodsFor: 'accessing' stamp: ''!
collection: anObject
	| oldValue |

	oldValue := collection.
	collection := anObject.
	self refreshList.
	
	self announcer announce: (ValueChanged 
		oldValue: oldValue 
		newValue: collection)! !

!SpCollectionListModel methodsFor: 'initialization' stamp: ''!
initialize
	self class initializeSlots: self.
	super initialize! !

!SpCollectionListModel methodsFor: 'adding' stamp: ''!
add: anItem
	
	collection := collection copyWith: anItem.
	
	self refreshList.
	self announcer announce: (ValueChanged newValue: self)
	! !

!SpCollectionListModel methodsFor: 'refreshing' stamp: ''!
refreshList

	self sortingBlock ifNotNil: [ :aSortFunction | collection := collection sorted: aSortFunction ]! !

!SpCollectionListModel methodsFor: 'initialization' stamp: ''!
sortingBlock: aBlock
	sorting := aBlock.
	self refreshList! !

!SpCollectionListModel methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpCollectionListModel methodsFor: 'testing' stamp: ''!
hasElementAt: index

	^ self size >= index! !

!SpCollectionListModel methodsFor: 'events' stamp: ''!
whenSortingBlockChangedDo: aBlock

	self property: #sorting whenChangedDo: aBlock! !

!SpCollectionListModel methodsFor: 'accessing' stamp: ''!
indexOf: anIndex ifAbsent: aBlock

	^ collection indexOf: anIndex ifAbsent: aBlock! !

!SpCollectionListModel methodsFor: 'collection' stamp: ''!
removeAll
	
	collection := #().
	
	self refreshList.
	self announcer announce: (ValueChanged newValue: self)
		! !

!SpCollectionListModel methodsFor: 'accessing' stamp: ''!
at: anIndex

	^ collection at: anIndex! !

!SpCollectionListModel methodsFor: 'accessing' stamp: ''!
size

	^ collection size! !

!SpCollectionListModel methodsFor: 'initialization' stamp: ''!
sortingBlock
	^ sorting! !

!SpCollectionListModel methodsFor: 'accessing' stamp: ''!
at: anIndex ifAbsent: aBlock

	^ collection at: anIndex ifAbsent: aBlock! !

!SpCollectionListModel methodsFor: 'events' stamp: ''!
whenChangedDo: aBlock
	
	self announcer 
		when: ValueChanged 
		do: [ :ann |
			aBlock 
				cull: ann newValue 
				cull: ann oldValue
				cull: ann ]
		for: self! !

!SpCollectionListModel methodsFor: 'accessing' stamp: ''!
items

	^ collection! !

!SpCollectionListModel methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpCollectionListModel methodsFor: 'accessing' stamp: ''!
announcer 

	^ announcer ifNil: [ announcer := Announcer new ]! !

!SpCollectionListModel class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpCollectionListModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpCollectionListModel class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpCollectionListModel class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpCollectionListModel class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpCollectionListModel class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpCollectionListModel class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpCollectionListModel class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpCollectionListModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpCollectionListModel class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpCollectionListModel class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpCollectionListModel class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpCollectionListModel class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpCollectionListModel class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpCollectionListModel class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpCollectionListModel class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpCollectionListModel class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpCollectionListModel class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpCollectionListModel class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpCollectionListModel class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpCollectionListModel class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpCollectionListModel class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpCollectionListModel class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpCollectionListModel class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpCollectionListModel class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpCollectionListModel class methodsFor: 'instance creation' stamp: ''!
on: aCollection
	
	^ self new
		collection: aCollection;
		yourself! !

!SpCollectionListModel class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpCollectionListModel class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpCollectionListModel class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpCollectionListModel class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpCommand commentStamp: ''!
I am a command decorator adding informations useful when for usage in context of a Spec application.

Basically, I add:
- an #icon (#blank by default)
- a #shortcutKey (optional)
- a #displayStrategy to handle how to show the command if it is not executable on a context (default is to be disabled)
- a #positionStrategy to handle on which side presenter with left and right side I should be (default is left)
!
!SpCommand methodsFor: 'presenter building' stamp: ''!
configureAsToolbarButton
	self configureAsButtonOfClass: SpToolbarButtonPresenter! !

!SpCommand methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self configureAsToolbarButton! !

!SpCommand methodsFor: 'updating' stamp: ''!
updateEnableStatus 
 	self presenter ifNil: [ ^ self ].   
	self presenter enabled: self canBeExecuted! !

!SpCommand methodsFor: 'accessing' stamp: ''!
buildPresenterBlock
	^ buildPresenterBlock! !

!SpCommand methodsFor: 'accessing' stamp: ''!
buildPresenterBlock: anObject
	buildPresenterBlock := anObject! !

!SpCommand methodsFor: 'presenter building' stamp: ''!
configureAsButtonOfClass: aButtonClass
	self
		buildPresenterBlock: [ :specCommand | 
			aButtonClass new
				label: specCommand name;
				help: specCommand description;
				in: [ :button | 
					specCommand hasIcon
						ifTrue: [ button icon: specCommand icon ] ];
				action: [ specCommand execute ];
				yourself ]! !

!SpCommand methodsFor: 'accessing' stamp: ''!
innerCommand
	| innerCommand |

	innerCommand := self decoratedCommand.
	[ innerCommand isKindOf: CmCommandDecorator ]
	whileTrue: [ innerCommand := innerCommand decoratedCommand ].

	^ innerCommand! !

!SpCommand methodsFor: 'accessing' stamp: ''!
presenter
	^ presenter! !

!SpCommand methodsFor: 'converting' stamp: ''!
asButtonPresenter
	self flag: #TODO. "Needs to use inform user display strategy when available, no other available strategy can be used in this context. See issue #705"
	self configureAsButton.
	^ self buildPresenter! !

!SpCommand methodsFor: 'presenter building' stamp: ''!
configureAsButton
	self configureAsButtonOfClass: SpButtonPresenter! !

!SpCommand methodsFor: 'presenter building' stamp: ''!
buildPresenter
	^ presenter := self buildPresenterBlock value: self! !

!SpCommand methodsFor: 'presenter building' stamp: ''!
configureAsToolBarToggleButton
	self configureAsButtonOfClass: SpToolbarToggleButtonPresenter! !

!SpCommand methodsFor: 'displaying' stamp: ''!
displayIn: aMenuGroupOrPresenter do: aBlock

	self displayStrategy 
		display: self 
		in: aMenuGroupOrPresenter 
		do: aBlock! !

!SpCommandGroup commentStamp: ''!
I am a command group decorator adding informations useful when for usage in context of a Spec application.

Basically, I add:
- an #icon (#blank by default)
- the strategy to display commands group in a MenuPresenter!
!SpCommandGroup methodsFor: 'testing' stamp: ''!
isToolbarPopoverButton

	^ toolbarPopoverButton! !

!SpCommandGroup methodsFor: 'shortcuts installation' stamp: ''!
installShortcutsIn: aPresenter 
	SpShortcutInstaller new
		presenter: aPresenter;
		visit: self! !

!SpCommandGroup methodsFor: 'converting' stamp: ''!
asMenuPresenterWith: aBlock
	| builder |

	builder := SpMenuPresenterBuilder new.
	aBlock value: builder menuPresenter.
	^ builder
		visit: self;
		menuPresenter! !

!SpCommandGroup methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	toolbarPopoverButton := false! !

!SpCommandGroup methodsFor: 'converting' stamp: ''!
asMenuPresenter

	^ SpMenuPresenterBuilder new
		visit: self;
		menuPresenter! !

!SpCommandGroup methodsFor: 'converting' stamp: ''!
asKMCategory

	^ SpKMCategoryBuilder new
		visit: self;
		kmCategory	! !

!SpCommandGroup methodsFor: 'converting' stamp: ''!
asMenuBarPresenter
	^ SpMenuBarPresenterBuilder new
		visit: self;
		menuPresenter! !

!SpCommandGroup methodsFor: 'converting' stamp: ''!
asToolbarPresenterWith: aBlock
	| builder |
	
	builder := SpToolbarPresenterBuilder new.
	aBlock value: builder toolbarPresenter.
	^ builder
		visit: self;
		toolbarPresenter! !

!SpCommandGroup methodsFor: 'converting' stamp: ''!
asMenuBarPresenterWith: aBlock
	| builder |

	builder := SpMenuBarPresenterBuilder new.
	aBlock value: builder menuPresenter.
	^ builder
		visit: self;
		menuPresenter! !

!SpCommandGroup methodsFor: 'configuring' stamp: ''!
beToolbarGroup

	toolbarPopoverButton := false! !

!SpCommandGroup methodsFor: 'converting' stamp: ''!
asToolbarPresenter
	^ SpToolbarPresenterBuilder new
		visit: self;
		toolbarPresenter! !

!SpCommandGroup methodsFor: 'configuring' stamp: ''!
beToolbarPopoverButton

	toolbarPopoverButton := true! !

!SpCommandGroup methodsFor: 'displaying' stamp: ''!
displayIn: aMenuPresenter do: aBlock

	self displayStrategy 
		display: self 
		in: aMenuPresenter 
		do: aBlock! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testCanUpdateEnableStatus
	| buttonPresenter shouldBeAvailable |
	shouldBeAvailable := true.
	command := CmBlockCommand new
		canBeExecutedBlock: [ :ctx | shouldBeAvailable ];
		context: #foo; "need a conext for #canBeExecuted to be performed"
		yourself.
	command := command asSpecCommand.
	buttonPresenter := command asButtonPresenter.
	self assert: buttonPresenter isEnabled.
	
	shouldBeAvailable := false.
	command updateEnableStatus.
	
	self deny: buttonPresenter isEnabled! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testIcon
	self assert: command icon isNil.
	
	command iconName: #add.
	
	self assert: command icon equals: (command iconNamed: #add).! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testIconNameFrom
	self assert: command iconProvider equals: Smalltalk ui icons.
	
	command iconName: #banana from: self.
	
	self assert: command iconProvider equals: self.
	self assert: (command icon) equals: self banana! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testAsButtonPresenter2
	| buttonPresenter |
	command := CmCommand forSpec
		name: 'foo';
		description: 'bar';
		iconName: #blank;
		yourself.
	buttonPresenter := command asButtonPresenter.
	self assert: buttonPresenter label equals: 'foo'.
	self assert: buttonPresenter help equals: 'bar'.
	self
		assert: buttonPresenter icon
		equals: (buttonPresenter iconNamed: #blank)! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testShortcutKey
	self should: [ command shortcutKey ] raise: CmNoShortcutIsDefined.
	
	command shortcutKey: $a asKeyCombination.
	
	self assert: command shortcutKey equals:  $a asKeyCombination! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testIconName
	self assert: command iconName isNil.
	
	command iconName: #add.
	
	self assert: command iconName equals: #add
	
	! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testAsButtonPresenter
	| buttonPresenter |
	command := CmCommand forSpec
		name: 'foo';
		description: 'bar';
		yourself.
	buttonPresenter := command asButtonPresenter.
	self assert: buttonPresenter label equals: 'foo'.
	self assert: buttonPresenter help equals: 'bar'.
	self assert: buttonPresenter icon isNil! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testConfigureAsToolBarButton
	| button |
	command := (CmBlockCommand new
		name: 'foo';
		description: 'bar';
		block: [ 42 ];
		yourself) asSpecCommand.
		
	button := command
					configureAsToolbarButton;
					buildPresenter.
	
	self assert: button class equals: SpToolbarButtonPresenter.
	self assert: button label equals: command name.
	self assert: button help equals: command description.
	self assert: button icon isNil.
	self assert: button action value equals: command execute! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testHasIcon
	self deny: command hasIcon.
	
	command iconName: #banana.
	
	self assert: command hasIcon! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testIconProvider
	self assert: command iconProvider equals: Smalltalk ui icons.
	
	command iconProvider: self.
	
	self assert: command iconProvider equals: self.
	
	command iconName: #banana.
	self assert: (command icon) equals: self banana! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testAsButtonPresenterExecutesOnClick
	| flag buttonPresenter |
	flag := false.
	command := CmBlockCommand new
					block: [ flag := true ];
					yourself.
	
	buttonPresenter := command asSpecCommand asButtonPresenter.
	
	buttonPresenter click.
	
	self assert: flag equals: true! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testConfigureAsButtonWithIcon
	| button |
	command := CmCommand forSpec
					iconName: #arrowUp;
					yourself.
		
	button := command
					configureAsButton;
					buildPresenter.
					
	self assert: button icon equals: command icon! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testConfigureAsToolBarToggleButton
	| button |
	command := (CmBlockCommand new
		name: 'foo';
		description: 'bar';
		block: [ 42 ];
		yourself) asSpecCommand.
		
	button := command
					configureAsToolBarToggleButton;
					buildPresenter.
	
	self assert: button class equals: SpToolbarToggleButtonPresenter.
	self assert: button label equals: command name.
	self assert: button help equals: command description.
	self assert: button icon isNil.
	self assert: button action value equals: command execute! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testHasShortcutKey
	self deny: command hasShortcutKey.
	
	command shortcutKey: $a asKeyCombination.
	
	self assert: command hasShortcutKey.! !

!SpCommandTest methodsFor: 'helpers' stamp: ''!
iconNamed: aSymbol
	aSymbol ~= #banana
		ifTrue: [ self error: 'Only #banana icon is needed for tests.' ].
		
	^ self banana! !

!SpCommandTest methodsFor: 'helpers' stamp: ''!
banana
	"Does not return an icon, it is not needed for the test."
	^ 42! !

!SpCommandTest methodsFor: 'tests' stamp: ''!
testConfigureAsButton
	| button |
	command := (CmBlockCommand new
		name: 'foo';
		description: 'bar';
		block: [ 42 ];
		yourself) asSpecCommand.
		
	button := command
					configureAsButton;
					buildPresenter.
	
	self assert: button class equals: SpButtonPresenter.
	self assert: button label equals: command name.
	self assert: button help equals: command description.
	self assert: button icon isNil.
	self assert: button action value equals: command execute! !

!SpCommandTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	command := SpCommand new! !

!SpComponentListAdapterMultipleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpComponentListPresenter! !

!SpComponentListAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterItemSetsSelectedIndexInWidget
	
	presenter selectItem: (presenter items at: 2).
	self assert: (self adapter selectedIndexes includes: 2)! !

!SpComponentListAdapterSingleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpComponentListPresenter! !

!SpComponentListAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterItemSetsSelectedIndexInWidget
	
	presenter selectItem: (presenter items at: 2).
	self assert: (self adapter selectedIndexes includes: 2)! !

!SpComponentListAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpComponentListPresenter ! !

!SpComponentListAdapterTest methodsFor: 'tests' stamp: ''!
testAddPresenterAddsWidget

	| button |
	button := SpButtonPresenter new.
	presenter addPresenter: button.
	
	backendForTest waitUntilUIRedrawed.
	self assert: self adapter children first equals: button adapter widget ! !

!SpComponentListAdapterTest methodsFor: 'tests' stamp: ''!
testEmptyPresenterHasEmptyAdapter
	
	backendForTest waitUntilUIRedrawed.
	self assertEmpty: self adapter children! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
	| cell item |
	
	item := self elementAt: rowIndex.
	cell := FTCellMorph new
		cellInset: 5;
		yourself.
	cell addMorphBack: (self widgetFor: item).
	
	^ cell! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
newDataSourceMatching: aFTFilter
	| newElements wrappedItem text newDataSource modelCopy |
	
	newElements := self elements select: [ :each | 
		wrappedItem := self model displayValueFor: each.
		table columns anySatisfy: [ :column | 
			text := column transform: wrappedItem.
			aFTFilter matches: text]].
	
	newDataSource := self copy.
	modelCopy := self model copy.
	modelCopy prepareForFilteredDataSourceWith: newElements.
	newDataSource model: modelCopy.
	
	^newDataSource! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
elementAt: rowIndex

	^ self presenters at: rowIndex! !

!SpComponentListDataSource methodsFor: 'drag and drop' stamp: ''!
transferFor: passenger from: aMorph

	^ (self model adapter 
		transferFor: passenger 
		from: self table) 
		buildWithSpec! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
presenters

	^ self model presenters! !

!SpComponentListDataSource methodsFor: 'private' stamp: ''!
widgetFor: aPresenter
	| widget |

	aPresenter adapter ifNotNil: [ :adapter | ^ adapter widget ].
	widget := aPresenter buildWithSpec
		vResizing: #shrinkWrap;
		yourself.
	aPresenter adapter applyStyle: widget. 
		
	^ widget! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
elements

	^ self presenters! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
rowHeight: rowIndex

	rowIndex = 0 ifTrue: [ ^ super rowHeight: rowIndex ].
	^ (self widgetFor: (self elementAt: rowIndex)) height! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
numberOfRows

	^ model
		ifNil: [ 0 ]
		ifNotNil: [ self presenters size ]! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
headerColumn: column

	column id ifNil: [ ^ nil ]. 
	^ FTCellMorph new 
		listCentering: #left;
		addMorph: column id asMorph asReadOnlyMorph;
		yourself! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	| menuPresenter |

	menuPresenter := self model contextMenu.
	menuPresenter ifNil: [ ^ nil ].
	^ SpBindings
		value: self model application adapterBindings
		during: [ 
			| m |
			m := menuPresenter value.
			m isMorph 
				ifTrue: [ m ]
				ifFalse: [ m buildWithSpec ] ]! !

!SpComponentListDataSource methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!SpComponentListPresenter commentStamp: ''!
A presenter to show a dynamic list of presenters. 
When you do not have a list of elements that can be presented as a single list or table, it is possible to display a collection of presenters as a list using this component.
!
!SpComponentListPresenter methodsFor: 'testing' stamp: ''!
isEmpty
	"Answer true if presenter list is empty."	

	^ self presenters isEmpty! !

!SpComponentListPresenter methodsFor: 'testing' stamp: ''!
includes: aPresenter
	"Answer true when the presenter includes `aPresenter` as part of its items." 

	^ self presenters includes: aPresenter  ! !

!SpComponentListPresenter methodsFor: 'api' stamp: ''!
presenters: aSequenceableCollection 
	"Set the list of presenters that will be the items to show in the component list.
	 This is a synonym of `SpAbstractListPresenter>>#items:`
	 See `SpAbstractListPresenter>>#model:`"
	
	^ self items: aSequenceableCollection! !

!SpComponentListPresenter methodsFor: 'api - events' stamp: ''!
whenPresentersChangedDo: aBlock
	"Inform when the presenter list changed (See `SpComponentListPresenter>>#presenters:`.
	 `aBlock` receive 3 optional arguments: 
	 - new value 
	 - old value 
	 - announcement triggered"
	
	self whenModelChangedDo: aBlock! !

!SpComponentListPresenter methodsFor: 'api' stamp: ''!
presenters
	"Answer the presenters of the list.
	 This is a synonym of `SpAbstractListPresenter>>#items`"

	^ self items! !

!SpComponentListPresenter methodsFor: 'initialization' stamp: ''!
addPresenter: aPresenter
	
	aPresenter owner: self.
	self model add: aPresenter! !

!SpComponentListPresenter methodsFor: 'private' stamp: ''!
doActivateAtIndex: index
	
	"Activate only if there is an item at that position"
	self presenters at: index ifAbsent: [ ^ self ].
	
	activationBlock cull: ((SpSingleSelectionMode on: self)
		basicSelectIndex: index;
		yourself)! !

!SpComponentListPresenter methodsFor: 'api' stamp: ''!
items: aSequenceableCollection 
	"Set the items of the list. 
	 `aSequenceableCollection` is a list of presenters OR a list of elements that understand 
	 the method `#asPresenter`."
	
	^ super items: (aSequenceableCollection collect: [ :each | 
		each asPresenter
			owner: self;
			yourself ])! !

!SpComponentListPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newComponentList! !

!SpComponentListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	| list |
	
	list := { 
		SpLabelPresenter new label: 'Test 1'; yourself.
		SpImagePresenter new image: (self iconNamed: #smallOk); yourself.
		SpButtonPresenter new label: 'A button'; yourself }.

	^ self new 
		presenters: list;
		openWithSpec! !

!SpComponentListPresenter class methodsFor: 'specs' stamp: ''!
adapterName
	^ #ComponentListAdapter! !

!SpComponentListPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpComponentListPresenter! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testNewComponentListIsEmpty

	self assertEmpty: self classToTest new! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testAddPresenterToComponentListShouldNotBeEmpty
	presenter addPresenter: SpButtonPresenter new.
	self deny: presenter isEmpty! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testUpdateItemsKeepingSelection 
	| presenters |

	presenters := #($a $b $c) collect: #asPresenter.
	presenter items: presenters.
	presenter selectIndex: 3.
	presenter updateItemsKeepingSelection: (presenters copyWith: $d asPresenter).
	self assert: presenter selectedItem label equals: 'c'! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testAddNoPresenterToComponentListDoesNotRaiseEvent
	| raised |
	
	raised := false.
	presenter whenPresentersChangedDo: [ raised := true ].
	self deny: raised! !

!SpComponentListPresenterTest methodsFor: 'tests - activation' stamp: ''!
testActivationOnDoubleClickShouldActivateOnDoubleClick

	| activatedItem |
	activatedItem := nil.
	presenter
		activateOnDoubleClick;
		whenActivatedDo: [ :selection | activatedItem := selection selectedItem ].
	
	presenter doubleClickAtIndex: 1.
	
	self assert: activatedItem label equals: '10'.! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testAddPresenterToComponentListRaisesSingleEvent
	| button raised |
	raised := 0.
	button := SpButtonPresenter new.
	presenter whenPresentersChangedDo: [ raised := raised + 1 ].
	
	presenter addPresenter: button.
	
	self assert: raised equals: 1! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testSelectAll

	presenter beSingleSelection.
	presenter selectAll.
	"in single mode selectAll has no effect"
	self assertEmpty: presenter selection selectedItems. 
	presenter beMultipleSelection.
	presenter selectAll.
	"but in multiple mode selectAll works"
	self 
		assert: (presenter selection selectedItems asArray collect: #label) 
		equals: #('10' '20' '30')! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testAddPresenterToComponentListRaisesEvent
	| button raised |
	raised := false.
	button := SpButtonPresenter new.
	presenter whenPresentersChangedDo: [ raised := true ].
	
	presenter addPresenter: button.
	
	self assert: raised! !

!SpComponentListPresenterTest methodsFor: 'tests - smoke' stamp: ''!
testSetSortingBlockBeforeItems
	| count |
	
	count := 0.
	presenter whenSortingBlockChangedDo: [ :sortFunction | count := count + 1 ].
	presenter sortingBlock: [ :each | each label asNumber ] ascending.
	presenter items: #(3 8 1 0).
	self assert: count equals: 1.
	self assert: (presenter model at: 1) label equals: '0'! !

!SpComponentListPresenterTest methodsFor: 'tests - smoke' stamp: ''!
testSortingBlock
	| count |
	
	count := 0.
	presenter whenSortingBlockChangedDo: [ :sortFunction | count := count + 1 ].
	presenter items: #(3 8 1 0).
	presenter sortingBlock: [ :each | each label asNumber ] ascending.
	self assert: count equals: 1.
	self assert: (presenter model at: 1) label equals: '0'! !

!SpComponentListPresenterTest methodsFor: 'tests - activation' stamp: ''!
testActivationOnSingleClickShouldActivateOnClick

	| activatedItem |
	activatedItem := nil.
	presenter
		activateOnSingleClick;
		whenActivatedDo: [ :selection | activatedItem := selection selectedItem ].
	
	presenter clickAtIndex: 1.
	
	self assert: activatedItem label equals: '10'.! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testReplaceItemList
	| changed |

	changed := false.
	presenter whenModelChangedDo: [ changed := true ].
	presenter items: #(a b c).
	
	self 
		assert: (presenter model collection collect: #label)
		equals: #(a b c).
	self assert: changed! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testDisableActivationDuring 
	| activated |

	activated := false.
	presenter whenActivatedDo: [ activated := true ].
	
	self deny: activated.
	presenter disableActivationDuring: [ presenter clickAtIndex: 2 ].
	self deny: activated. "still not change"
	self assert: presenter selectedItem label equals: '20' "but the selection changed!!"! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testUnselectAll

	presenter beMultipleSelection.
	presenter selectAll.
	self 
		assert: (presenter selection selectedItems collect: #label as: Array) 
		equals: #('10' '20' '30').
	presenter unselectAll.
	self assertEmpty: presenter selection selectedItems! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testAddPresenterToComponentListIsInPresenterCollection
	| button |

	button := SpButtonPresenter new.
	presenter addPresenter: button.
	self assert: (presenter includes: button)! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testSelectedItemsSortedByIndex

	presenter beMultipleSelection.
	presenter 
		selectIndex: 3;
		selectIndex: 1.
	self 
		assert: (presenter selection selectedItems collect: #label as: Array)
		equals: #('30' '10'). 
	self 
		assert: (presenter selection selectedItemsSortedByIndex collect: #label as: Array)
		equals: #('10' '30')! !

!SpComponentListPresenterTest methodsFor: 'tests' stamp: ''!
testActivationWithTransformation
	| activatedItem |

	activatedItem := nil.
	presenter
		activateOnSingleClick;
		whenActivatedDo: (SpActivationTransform
			activateDo: [ :selection | activatedItem := selection selectedItem ]
			transform: [ :selection | selection selectedItem label asInteger * 10 ]).
	
	presenter clickAtIndex: 1.
	
	self assert: activatedItem equals: 100! !

!SpComposablePresenterWithAdditionalSubpresentersTest methodsFor: 'tests' stamp: ''!
testOpening
	| aPresenter |

	aPresenter := application newPresenter: SpTestingPresenterWithAdditionalPresenters.
	aPresenter openWithSpec.
	#(subpresenter1 subpresenter2 subpresenter3) do: [ :aKey | 
		self 
			assert: (aPresenter additionalSubpresentersMap at: aKey) owner 
			equals: aPresenter ]! !

!SpComposablePresenterWithAdditionalSubpresentersTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	application := SpMockApplication new! !

!SpComposablePresenterWithModelTest methodsFor: 'testing' stamp: ''!
testUpdateModel

	| aPoint presenter |
	
	aPoint := SpTestingPointModel x: 40 y: 54.
	presenter := SpTestingPresenterWithModel on: aPoint.
	
	self assert: presenter x text equals: aPoint x asString.
	self assert: presenter y text equals: aPoint y asString.
	
	aPoint x: 1; y: 2.
	aPoint valueChanged.
	
	"the point itself is not subscribed to the presenter"

	self assert: presenter x text equals: aPoint x asString.
	self assert: presenter y text equals: aPoint y asString.
	
	
	! !

!SpComposablePresenterWithModelTest methodsFor: 'testing' stamp: ''!
testModelSettingModelToModel

	"we had a Model, new model is another Model"
	| model model2 presenter |
	model := SpTestingPointModel x: 1 y: 2.
	model2 := SpTestingPointModel x: 4 y: 5.
	presenter := SpTestingPresenterWithModel on: model.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self deny: presenter announcingObject isValueHolder.
	self assert: model2 isSpAnnouncingObject.
	self deny: model2 isValueHolder.
	presenter model: model2.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self deny: presenter announcingObject isValueHolder.
	self assert: presenter announcingObject == model2.
	self assert: presenter announcingObject announcer numberOfSubscriptions > 0.
! !

!SpComposablePresenterWithModelTest methodsFor: 'testing' stamp: ''!
testModelSettingModelToValueHolder

	| point model presenter |
	
	"we had value holder, new model is a model"
	point := 40@54.

	presenter := SpTestingPresenterWithModel on: point.
	model := SpTestingPointModel x: 1 y: 2.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self assert: presenter announcingObject isValueHolder.
	self assert: model isSpAnnouncingObject.
	self deny: model isValueHolder.
	presenter model: model.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self deny: presenter announcingObject isValueHolder.
	self assert: presenter announcingObject == model.
	self assert: presenter announcingObject announcer numberOfSubscriptions > 0.

! !

!SpComposablePresenterWithModelTest methodsFor: 'testing' stamp: ''!
testModelSettingObjectToValueHolder

	| point point2 presenter |
	
	"we had value holder, new model is a regular object"
	point := 40@54.
	point2 := 1@0.
	presenter := SpTestingPresenterWithModel on: point.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self assert: presenter announcingObject isValueHolder.
	self deny: point2 isSpAnnouncingObject.
	self deny: point2 isValueHolder.
	presenter model: point2.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self assert: presenter announcingObject isValueHolder.
	self assert: presenter model == point2.
	self assert: presenter announcingObject announcer numberOfSubscriptions > 0.
! !

!SpComposablePresenterWithModelTest methodsFor: 'testing' stamp: ''!
testModelSettingValueHolderToValueHolder

	| point point2 valueHolder presenter |
	
	"we had value holder, new model is a regular object"
	point := 40@54.
	point2 := 1@0.
	
	"we had value holder, new model is a value holder"
	presenter := SpTestingPresenterWithModel on: point.
	valueHolder := NewValueHolder value: point2.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self assert: presenter announcingObject isValueHolder.
	self deny: point2 isSpAnnouncingObject.
	self assert: valueHolder isValueHolder.
	presenter model: valueHolder.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self assert: presenter announcingObject isValueHolder.
	self assert: presenter model == point2.
	self assert: presenter announcingObject == valueHolder.
	self assert: presenter announcingObject announcer numberOfSubscriptions > 0.
! !

!SpComposablePresenterWithModelTest methodsFor: 'testing' stamp: ''!
testInstanceCreation

	| aPoint presenter |
	
	aPoint := 40@54.
	presenter := SpTestingPresenterWithModel on: aPoint.
	
	self assert: presenter model equals: aPoint.
	self deny: (aPoint dependents includes: presenter).
	
	
	! !

!SpComposablePresenterWithModelTest methodsFor: 'testing' stamp: ''!
testUpdateModelWithValueHolder

	| aPoint aValueHolder presenter anAnnouncer |
	
	"create a point and a value holder that contains it and can react on announcements"
	aPoint := 40@54.
	aValueHolder := NewValueHolder value: aPoint.
	
	self assert: (aValueHolder value == aPoint).
	anAnnouncer := aValueHolder announcer.
	self assert: (aValueHolder announcer subscriptions subscriptions size) equals: 0. 
	
	presenter := SpTestingPresenterWithModel on: aValueHolder.

	self assert: (anAnnouncer == aValueHolder announcer).
	self assert: presenter x text equals: aPoint x asString.
	self assert: presenter y text equals: aPoint y asString.
	
	aPoint setX: 1 setY: 2.
	self assert: (aValueHolder value == aPoint). 
	aValueHolder valueChanged.
	self assert: (anAnnouncer == aValueHolder announcer).
	
	"the point itself is not subscribed to the presenter"

	self assert: presenter x text equals: aPoint x asString.
	self assert: presenter y text equals: aPoint y asString.
	
	
	! !

!SpComposablePresenterWithModelTest methodsFor: 'testing' stamp: ''!
testInstanceCreationWithValueHolder

	| point valueHolder presenter |
	
	point := (40@54).
	valueHolder := point asValueHolder.
	presenter := SpTestingPresenterWithModel on: valueHolder.
	
	self assert: presenter model equals: point.
	
	
	
	! !

!SpComposablePresenterWithModelTest methodsFor: 'testing' stamp: ''!
testModelSettingObjectToModel

	| point model presenter |
	
	"we had a Model, new model is a regular object"
	model := SpTestingPointModel x: 1 y: 2.
	point := 40@54.
	presenter := SpTestingPresenterWithModel on: model.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self deny: presenter announcingObject isValueHolder.
	self deny: point isSpAnnouncingObject.
	self deny: point isValueHolder.
	presenter model: point.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self assert: presenter announcingObject isValueHolder.
	self assert: presenter model == point.
	self deny: presenter announcingObject == model.
	self assert: presenter announcingObject announcer numberOfSubscriptions > 0.

! !

!SpComposablePresenterWithModelTest methodsFor: 'testing' stamp: ''!
testModelSettingValueHolderToModel

	"we had a Model, new model is a value holder"
	| model point valueHolder presenter |
	point := 1@0.
	model := SpTestingPointModel x: 1 y: 2.
	valueHolder := NewValueHolder value: point.
	presenter := SpTestingPresenterWithModel on: model.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self deny: presenter announcingObject isValueHolder.
	self assert: valueHolder isSpAnnouncingObject.
	self assert: valueHolder isValueHolder.
	presenter model: valueHolder.
	self assert: presenter announcingObject isSpAnnouncingObject.
	self assert: presenter announcingObject isValueHolder.
	self assert: presenter announcingObject == valueHolder.
	self assert: presenter announcingObject announcer numberOfSubscriptions > 0.
! !

!SpCompositeIconProvider commentStamp: ''!
I'm a composite icon provider.
Users can compose (using `,` message) icon providers to define different ways to find icons.
A typical usage is: 

```
(SpLocationIconProvider newLocation: './icons' asFileReference), SpPharoThemeIconProvider new
```!
!SpCompositeIconProvider methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	providers := #()! !

!SpCompositeIconProvider methodsFor: 'accessing' stamp: ''!
providers
	
	^ providers! !

!SpCompositeIconProvider methodsFor: 'copying' stamp: ''!
, aProvider

	self addProvider: aProvider.
	^ self! !

!SpCompositeIconProvider methodsFor: 'accessing' stamp: ''!
addProvider: anIconProvider

	providers := providers copyWith: anIconProvider! !

!SpCompositeIconProvider methodsFor: 'accessing' stamp: ''!
iconNamed: aName ifAbsent: aBlock

	self providers do: [ :each |
		(each iconNamed: aName ifAbsent: [ nil ]) 
			ifNotNil: [ :icon | ^ icon ] ].
	
	^ aBlock value! !

!SpCompositeOutputPort commentStamp: ''!
A composited output port that allow presenters to trigger output transmissions to several subpresenters (or itself)!
!SpCompositeOutputPort methodsFor: 'adding' stamp: ''!
add: aPort 

	ports := ports copyWith: aPort! !

!SpCompositeOutputPort methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	ports := #()! !

!SpCompositeOutputPort methodsFor: 'attaching' stamp: ''!
attachTransmission: aTransmission

	ports do: [ :each | 
		each attachTransmission: aTransmission ]! !

!SpCompositeOutputPort methodsFor: 'attaching' stamp: ''!
attachTransmission: aTransmission to: aPresenter
	
	self error: 'Should not arrive here.'! !

!SpCompositeTableColumn commentStamp: ''!
A composite column (a column that joins other colums to form a single cell view).
A `SpCompositeTableColumn` contain other column definitions to compose a single type of column. 
Typically, it will compose images and texts (or checkbox and text, as for do a cherry pick).

The user does not needs to set an evaluation block for this column (as its value is taken in the composed columns).


## Example
```
SpCompositeTableColumn new 
	title: 'My string';
	addColumn: (SpCompositeTableColumn new
			title: 'Classes';
			addColumn: (SpImageTableColumn new
				width: 20;
				evaluated: [ :aClass | aClass systemIcon ];
				yourself);
			addColumn: (SpStringTableColumn new
				evaluated: [ :aClass | aClass name ];
				yourself);
			yourself);
	yourself
```!
!SpCompositeTableColumn methodsFor: 'api' stamp: ''!
addColumn: aTableColumn 
	"Add a column to the composed columns."
	
	columns add: aTableColumn! !

!SpCompositeTableColumn methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	"there will be at least two, if it is composed :)"
	columns := OrderedCollection new: 2! !

!SpCompositeTableColumn methodsFor: 'api' stamp: ''!
columns
	"Answer the columns composing this composite."

	^ columns! !

!SpCompositeTableColumn methodsFor: 'visiting' stamp: ''!
acceptColumnVisitor: aBuilder

	^ aBuilder visitCompositeColumn: self! !

!SpCompositeTableColumn methodsFor: 'testing' stamp: ''!
isComposite
	"Answer if this is a composite column. 
	 For this class, answer will always be true."

	^ true! !

!SpCompositeTableColumn methodsFor: 'api' stamp: ''!
addAllColumns: aCollection 
	"Add all columns contained in `aCollection` to the composed columns."
	
	aCollection do: [ :each | self addColumn: each ]! !

!SpCompositeTableColumn class methodsFor: 'instance creation' stamp: ''!
title: aString withAll: aCollection

	^ self new
		title: aString;
		addAllColumns: aCollection;
		yourself! !

!SpCompositeTableColumn class methodsFor: 'instance creation' stamp: ''!
withAll: aCollection

	^ self new
		addAllColumns: aCollection;
		yourself! !

!SpCompositeTableColumn class methodsFor: 'instance creation' stamp: ''!
with: column

	^ self new
		addColumn: column;
		yourself! !

!SpCompositeTableColumn class methodsFor: 'instance creation' stamp: ''!
with: column1 with: column2 with: column3

	^ self new
		addColumn: column1;
		addColumn: column2;
		addColumn: column3;
		yourself! !

!SpCompositeTableColumn class methodsFor: 'instance creation' stamp: ''!
with: column1 with: column2 

	^ self new
		addColumn: column1;
		addColumn: column2;
		yourself! !

!SpConfirmDialog commentStamp: ''!
A simple confirm dialog. 
By default, it will show the `label` message and ask for a conformation with `Yes` and `No` as default button options.
!
!SpConfirmDialog methodsFor: 'api - showing' stamp: ''!
openModalWithSpec
	| dialog |
	
	dialog := super openModalWithSpec.
	^ dialog isOk! !

!SpConfirmDialog methodsFor: 'api' stamp: ''!
cancelLabel

	^ cancelLabel ifNil: [ self class defaultCancelLabel ]! !

!SpConfirmDialog methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	self title: 'Confirm'! !

!SpConfirmDialog methodsFor: 'api' stamp: ''!
label: aString

	label label: aString! !

!SpConfirmDialog methodsFor: 'api' stamp: ''!
title: aString

	title := aString! !

!SpConfirmDialog methodsFor: 'api' stamp: ''!
acceptLabel

	^ acceptLabel ifNil: [ self class defaultAcceptLabel ]! !

!SpConfirmDialog methodsFor: 'api' stamp: ''!
extent

	^ initialExtent ifNil: [ self class defaultExtent ]! !

!SpConfirmDialog methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter

	super initializeDialogWindow: aDialogWindowPresenter.
	aDialogWindowPresenter
		addButton: self cancelLabel do: [ :presenter | self cancel ];
		addDefaultButton: self acceptLabel do: [ :presenter | self accept ]
		! !

!SpConfirmDialog methodsFor: 'api' stamp: ''!
acceptLabel: aString

	acceptLabel := aString! !

!SpConfirmDialog methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter
		title: self title;
		initialExtent: self extent! !

!SpConfirmDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	image := self newImage image: self defaultIcon.
	label := self newLabel
	! !

!SpConfirmDialog methodsFor: 'api' stamp: ''!
extent: aPoint

	initialExtent := aPoint! !

!SpConfirmDialog methodsFor: 'api' stamp: ''!
title

	^ title! !

!SpConfirmDialog methodsFor: 'api' stamp: ''!
cancelLabel: aString

	cancelLabel := aString! !

!SpConfirmDialog class methodsFor: 'accessing' stamp: ''!
defaultCancelLabel

	^ 'No'! !

!SpConfirmDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		borderWidth: 5;
		spacing: 5;
		add: (SpBoxLayout newLeftToRight
			spacing: 5;
			vAlignCenter;
			add: #image expand: false;
			add: #label;
			yourself);
		yourself! !

!SpConfirmDialog class methodsFor: 'examples' stamp: ''!
exampleModal
	| ok |

	ok := self new
		title: 'Confirm modal example';
		label: 'Are you sure?';
		acceptLabel: 'Sure!!';
		cancelLabel: 'No, forget it';
		openModalWithSpec.
	
	self inform: (ok 
		ifTrue: [ 'Yes!!' ]
		ifFalse: [ 'No!!' ])! !

!SpConfirmDialog class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector
	
	^ #newConfirm! !

!SpConfirmDialog class methodsFor: 'examples' stamp: ''!
example

	^ self new
		title: 'Confirm example';
		label: 'Are you sure?';
		acceptLabel: 'Sure!!';
		cancelLabel: 'No, forget it';
		label: 'Are you sure?';
		onAccept: [ self inform: 'Yes!!' ];
		onCancel: [ self inform: 'No!!' ];
		openDialogWithSpec! !

!SpConfirmDialog class methodsFor: 'accessing' stamp: ''!
defaultExtent

	^ 450@120! !

!SpConfirmDialog class methodsFor: 'accessing' stamp: ''!
defaultAcceptLabel

	^ 'Yes'! !

!SpContainerStyle commentStamp: ''!
# Container properties (`SpContainerStyle`)

A container property can be applied to container elements (buttonbar, toolbar, actionbar), and define several properties: 

- borderColor: The color of the border (in case borderWidth > 0). 
- borderWidth: The width of the border.
- padding: The space between elements.

See `SpContainerStyle>>#borderColor`

## Usage
The identifier of container in the stylesheet is`Container`.

```
Container { 
	#borderColor: #blue, 
	#borderWidth: 2,
	#padding: 5
}
```!
!SpContainerStyle methodsFor: 'accessing' stamp: ''!
borderWidth: aNumber

	borderWidth := aNumber asStyleVariable! !

!SpContainerStyle methodsFor: 'accessing' stamp: ''!
borderWidth

	^ self borderWidthVariable scaledValue! !

!SpContainerStyle methodsFor: 'accessing - variables' stamp: ''!
borderColorVariable
  "This property can be expressed as 
	- a STON map: ==Color { #red : 1., #green : 0, #blue : 0, #alpha : 1 }==
	- a named selector: ==#red==
	- an hex string: =='FF0000'=="

	^ self toVariable: borderColor! !

!SpContainerStyle methodsFor: 'accessing - variables' stamp: ''!
borderWidthVariable

	^ self toVariable: borderWidth! !

!SpContainerStyle methodsFor: 'accessing' stamp: ''!
padding: aNumber

	padding := aNumber asStyleVariable! !

!SpContainerStyle methodsFor: 'accessing - variables' stamp: ''!
paddingVariable

	^ self toVariable: padding! !

!SpContainerStyle methodsFor: 'accessing' stamp: ''!
borderColor: aColor

	borderColor := aColor asStyleVariable! !

!SpContainerStyle methodsFor: 'operations' stamp: ''!
applyTo: aMorph 

	self borderColorVariable ifNotNil: [ :aVariable | aMorph borderColor: aVariable valueAsColor ].
	self borderWidthVariable ifNotNil: [ :aVariable | aMorph borderWidth: aVariable scaledValue ].
	self paddingVariable ifNotNil: [ :aVariable | aMorph cellInset: aVariable scaledValue ]! !

!SpContainerStyle methodsFor: 'accessing' stamp: ''!
padding

	^ self paddingVariable scaledValue! !

!SpContainerStyle methodsFor: 'accessing' stamp: ''!
borderColor
  "This property can be expressed as 
	- a STON map: ==Color { #red : 1., #green : 0, #blue : 0, #alpha : 1 }==
	- a named selector: ==#red==
	- an hex string: =='FF0000'=="

	^ self borderColorVariable value! !

!SpContainerStyle class methodsFor: 'ston-core' stamp: ''!
stonName

	^ 'Container'! !

!SpContextInteractionModel methodsFor: 'accessing' stamp: ''!
doItContext

	^ self context! !

!SpContextInteractionModel methodsFor: 'accessing' stamp: ''!
context

	^context! !

!SpContextInteractionModel methodsFor: 'testing' stamp: ''!
hasBindingOf: aString
	"we lookup the name without creating a new variable"
	^ (context lookupVar: aString declare: false) notNil! !

!SpContextInteractionModel methodsFor: 'binding' stamp: ''!
bindingOf: aString

	"we can not call #lookupVar: without checking first as it would create the variable"

	^ (self hasBindingOf: aString)
		  ifTrue: [ (context lookupVar: aString) asDoItVariableFrom: context ]
		  ifFalse: [ nil ]! !

!SpContextInteractionModel methodsFor: 'accessing' stamp: ''!
context: aContext
	context := aContext! !

!SpContextInteractionModel methodsFor: 'accessing' stamp: ''!
doItReceiver

	^ self context receiver! !

!SpContextInteractionModel methodsFor: 'testing' stamp: ''!
hasUnsavedCodeChanges

	^ context notNil and: [ context sourceCode ~= owner text asString ]! !

!SpContextInteractionModel methodsFor: 'accessing' stamp: ''!
object

	^ self doItReceiver! !

!SpContextInteractionModel methodsFor: 'accessing' stamp: ''!
behavior

	^ self context receiver class! !

!SpContextInteractionModel class methodsFor: 'instance creation' stamp: ''!
on: aContext

	^ self new context: aContext! !

!SpDatePresenter commentStamp: ''!
A DatePresenter 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 DatePresenter in your UI, and send #date when you want its value.
- or, register to be notified when the date changes:
	DatePresenter new
		date: self date;
		whenDateChanged: [ :newDate | self date: newDate ].

As it is Spec-based, it can be easily adapted and composed into a larger UI.!
!SpDatePresenter methodsFor: 'private' stamp: ''!
chooseDate

	| calendar defaultDate |
	defaultDate := self date ifNil: [ self defaultDate ].
	calendar := CalendarMorph openOn: defaultDate.
	calendar
		center: calendar cursorPoint;
		fitInWorld;
		onChoiceSend: #onDateChosen: to: self.! !

!SpDatePresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	displayBlock := [ :object | object ifNotNil: [ object asStringOrText ] ifNil: '' ].
	self property: #displayBlock whenChangedDo: [ self date: self date ].
	self date: self defaultDate! !

!SpDatePresenter methodsFor: 'accessing - widgets' stamp: ''!
dateModel

	^ dateModel.! !

!SpDatePresenter methodsFor: 'api' stamp: ''!
display
	"Return the one argument block used to wrap your domain specific items.
	The block should return something that can be displayed in a list - like a String or a Text"

	^ displayBlock! !

!SpDatePresenter methodsFor: 'accessing' stamp: ''!
date: aDate

	| dateString |
	date := aDate.
	dateString := self display value: date.
	self dateModel text: dateString.! !

!SpDatePresenter methodsFor: 'private' stamp: ''!
iconMorph

	^ ImageMorph new form: (self iconNamed: #calendarIcon)! !

!SpDatePresenter methodsFor: 'private' stamp: ''!
onDateChosen: aChoseDate

	aChoseDate calendar delete.
	self date: aChoseDate date! !

!SpDatePresenter methodsFor: 'api' stamp: ''!
display: aBlock
	"Set the one argument block used to transfrom your date into a string"

	displayBlock := aBlock! !

!SpDatePresenter methodsFor: 'defaults' stamp: ''!
defaultDate
	^ Date today ! !

!SpDatePresenter methodsFor: 'accessing - widgets' stamp: ''!
chooseDateButton

	^ chooseDateButton.! !

!SpDatePresenter methodsFor: 'api - events' stamp: ''!
whenDateChanged: aBlock

	dateModel whenTextChanged: [ :newText :oldText :announcement :anAnnouncer |
		| oldDate |
		oldDate := date.
		date := newText
			ifNotEmpty: [ Date readFrom: newText readStream ]
			ifEmpty: [ nil ].
		aBlock cull: date cull: oldDate cull: announcement cull: anAnnouncer ]! !

!SpDatePresenter methodsFor: 'accessing' stamp: ''!
date

	^ date! !

!SpDatePresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	dateModel := self newTextInput.
	chooseDateButton := self newButton.
	
	chooseDateButton
		icon: self iconMorph;
		action: [ self chooseDate ];
		extent: self iconMorph extent.! !

!SpDatePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		add: #dateModel;
		add: #chooseDateButton expand: false;
		yourself
		! !

!SpDatePresenter class methodsFor: '*Spec2-Morphic-Examples' stamp: ''!
exampleModal
	<sampleInstance>
	
	^ self new openModalWithSpec! !

!SpDatePresenter class methodsFor: '*Spec2-Morphic-Examples' stamp: ''!
example
	<sampleInstance>
	
	^ self new openWithSpec! !

!SpDatePresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpDatePresenter! !

!SpDatePresenterTest methodsFor: 'tests' stamp: ''!
testOnDateChosen
	| mookChoseDate |
	mookChoseDate := ChoseDate new.
	mookChoseDate
		calendar: StandardWindow new;
		date: Date tomorrow.
	presenter onDateChosen: mookChoseDate.
	self assert: presenter date equals: Date tomorrow! !

!SpDemo commentStamp: ''!
Set of demos that show some of the capabilities of the Spec UI framework.
Execute the following expression: `SpDemo open`!
!SpDemo methodsFor: 'accessing' stamp: ''!
list: anObject
	list := anObject! !

!SpDemo methodsFor: 'accessing' stamp: ''!
page: anObject
	page := anObject! !

!SpDemo methodsFor: 'initialization' stamp: ''!
subMenu
	^ self newMenu
		addItem: [ :item | 
			item
				name: 'Open';
				icon: (self iconNamed: #openIcon);
				shortcut: $o meta;
				action: [ self inform: 'Open' ] ];
		addItem: [ :item | 
			item
				name: 'Save';
				icon: (self iconNamed: #smallSaveIcon);
				shortcut: $s meta;
				action: [ self inform: 'Save' ] ];
		addItem: [ :item | 
			item
				name: 'Print';
				shortcut: $p meta;
				icon: (self iconNamed: #smallPrintIcon);
				action: [ self inform: 'Print' ] ];
		addItem: [ :item | 
			item
				name: 'Close';
				shortcut: $c meta;
				icon: (self iconNamed: #smallCancelIcon);
				action: [ self inform: 'Kill' ] ];
		yourself! !

!SpDemo methodsFor: 'accessing' stamp: ''!
menu: anObject
	menu := anObject! !

!SpDemo methodsFor: 'initialization' stamp: ''!
mainMenu
	| aMenu |
	aMenu := self newMenuBar
		addGroup: [ :group | 
			group
				addItem: [ :item | 
					item
						name: 'File';
						icon: (self iconNamed: #openIcon);
						subMenu: self subMenu ].
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Open file';
						icon: (self iconNamed: #openIcon);
						action: [ self inform: 'Open File' ] ].
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Save File';
						icon: (self iconNamed: #smallSaveIcon);
						action: [ self inform: 'Save File' ] ].
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Print file';
						icon: (self iconNamed: #smallPrintIcon);
						action: [ self inform: 'Print file' ] ] ];
		addGroup: [ :group | 
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Undo';
						icon: (self iconNamed: #smallUndoIcon);
						action: [ self inform: 'Undo' ] ].
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Redo';
						icon: (self iconNamed: #smallRedoIcon);
						action: [ self inform: 'Redo' ] ] ];
		addGroup: [ :group | 
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Add menu item';
						icon: (self iconNamed: #add);
						action: [ self addItemTo: group ] ] ].
	^ aMenu! !

!SpDemo methodsFor: 'api' stamp: ''!
initialExtent

	| fontWidth rowHeight |
	fontWidth := (StandardFonts defaultFont widthOfString: 'M').
	rowHeight := self class inputTextHeight.

	^ (90@24) * (fontWidth @ rowHeight)
	! !

!SpDemo methodsFor: 'accessing' stamp: ''!
defaultPage

	^ self availablePages first.! !

!SpDemo methodsFor: 'api' stamp: ''!
title
	
	^ 'Spec UI Framework Demo'.! !

!SpDemo methodsFor: 'accessing' stamp: ''!
selectedPage
	^ selectedPage! !

!SpDemo methodsFor: 'accessing' stamp: ''!
menu
	^ menu! !

!SpDemo methodsFor: 'accessing' stamp: ''!
selectedPage: anObject
	selectedPage := anObject! !

!SpDemo methodsFor: 'accessing' stamp: ''!
page
	^ page! !

!SpDemo methodsFor: 'initialization' stamp: ''!
initializePresenters

	menu := self mainMenu.
	list := self newList.
	page := SpBoxLayout newTopToBottom 
		add: (self instantiate: (selectedPage := self availablePages first));
		yourself.

	self layout: (SpBoxLayout newTopToBottom
		add: menu expand: false;
		add: (SpPanedLayout newLeftToRight
			positionOfSlider: 200;
			add: list;
			add: page;
			yourself);
		yourself).

	menu addKeybindingsTo: self.

	list
		items: self availablePages;
		display: [ :item | item pageName ];
		contextMenu:
			(self newMenu
				addItem: [ :item | 
					item
						name: 'Browse';
						icon: (self iconNamed: #smallHelp);
						action: [ list selectedItem browse ] ];
				addItem: [ :item | 
					item
						name: 'Browse presenter';
						icon: (self iconNamed: #smallHelp);
						action: [ list selectedItem new pageClass browse ] ];
				yourself).

	self focusOrder
		add: list;
		addAll: page presenters ! !

!SpDemo methodsFor: 'accessing' stamp: ''!
addItemTo: aGroup
	aGroup
		addItem: [ :item | 
			item
				name: 'Dynamic';
				icon: (self iconNamed: #delete);
				action: [ aGroup menuItems remove: item.
					self needRebuild: false.
					self buildWithSpec ] ].
	self needRebuild: false.
	self buildWithSpec! !

!SpDemo methodsFor: 'accessing' stamp: ''!
availablePages
	^ SpDemoPage availablePages! !

!SpDemo methodsFor: 'initialization' stamp: ''!
connectPresenters

	list selectItem: self selectedPage.
	list whenSelectionChangedDo: [ :selection | 
		selection selectedItem
			ifNotNil: [ :newPageClass | 
				newPageClass = self selectedPage
					ifFalse: [ 
						self selectedPage: newPageClass.
						page
							removeAll; 
							add: (self instantiate: newPageClass);
							yourself ] ]
			ifNil: [ 
				"Avoid the user to have no page selected at all." 
				list setSelectedItem: self selectedPage ] ]! !

!SpDemo methodsFor: 'accessing' stamp: ''!
list
	^ list! !

!SpDemo class methodsFor: 'user interface' stamp: ''!
menuExamplesOn: aBuilder
	"Add a custom menu item to the world menu"

	<worldMenu>
	(aBuilder item: #'Spec2 examples')
		iconName: #smallHelpIcon;
		parent: #Help;
		order: 3.5;
		help: 'Open Spec2 demo browser.';
		action: [ self open ].
	aBuilder withSeparatorAfter	! !

!SpDemo class methodsFor: 'specs' stamp: ''!
open
	<example>
	
	^ self new
		openWithSpec! !

!SpDemo class methodsFor: 'instance creation' stamp: ''!
on: aModel

	^ self basicNew 
		model: aModel;
		initialize;
		yourself.! !

!SpDemoAbstractModalPresenter commentStamp: ''!
Description
--------------------

I am an abstract class for example modals.!
!SpDemoAbstractModalPresenter methodsFor: 'accessing' stamp: ''!
content
	^ self subclassResponsibility! !

!SpDemoAbstractModalPresenter methodsFor: 'accessing' stamp: ''!
explanation
	^ explanation! !

!SpDemoAbstractModalPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	explanation := self newText.
	
	explanation text: self content! !

!SpDemoAbstractModalPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #explanation;
		yourself! !

!SpDemoActionBarPage commentStamp: ''!
Demo page for SpecDemoActionBarPresenter!
!SpDemoActionBarPage methodsFor: 'initialization' stamp: ''!
pageClass

	^ SpDemoActionBarPresenter! !

!SpDemoActionBarPage class methodsFor: 'specs' stamp: ''!
pageName

	^ 'ActionBar'! !

!SpDemoActionBarPage class methodsFor: 'specs' stamp: ''!
priority
	^ 13! !

!SpDemoActionBarPresenter commentStamp: ''!
This demo shows an action bar.!
!SpDemoActionBarPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	
	actionBar := self newActionBar
		add: (self newButton
			label: 'Add'; 
			icon: (self iconNamed: #smallOk);
			help: 'Add.';
			action: [ UIManager default defer: [ self inform: 'Add' ] ];
			yourself);
		add: (self newButton
			label: 'Remove'; 
			icon: (self iconNamed: #smallCancel);
			help: 'Remove.';
			action: [ UIManager default defer: [ self inform: 'Remove' ] ];
			yourself);
		addLast: (self newButton
			label: 'Other'; 
			help: 'Other.';
			action: [ UIManager default defer: [ self inform: 'Other' ] ];
			yourself);
		yourself.

	text := self newText! !

!SpDemoActionBarPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom 
		add: #text;
		addLast: #actionBar expand: false fill: false padding: 0;
		yourself! !

!SpDemoButtonsPage commentStamp: ''!
Demo page for SpecDemoButtonsPresenter!
!SpDemoButtonsPage methodsFor: 'initialization' stamp: ''!
pageClass

	^ SpDemoButtonsPresenter
! !

!SpDemoButtonsPage class methodsFor: 'specs' stamp: ''!
pageName

	^ 'Buttons'! !

!SpDemoButtonsPage class methodsFor: 'specs' stamp: ''!
priority

	^ 20! !

!SpDemoButtonsPresenter commentStamp: ''!
This demo shows differenty styles of button elements.!
!SpDemoButtonsPresenter methodsFor: 'initialization' stamp: ''!
subMenu
	^ self newMenu
		addItem: [ :item | 
			item
				name: 'Open';
				icon: (self iconNamed: #openIcon);
				shortcut: $o meta;
				action: [ self inform: 'Open' ] ];
		addItem: [ :item | 
			item
				name: 'Save';
				icon: (self iconNamed: #smallSaveIcon);
				shortcut: $s meta;
				action: [ self inform: 'Save' ] ];
		addItem: [ :item | 
			item
				name: 'Print';
				shortcut: $p meta;
				icon: (self iconNamed: #smallPrintIcon);
				action: [ self inform: 'Print' ] ];
		addItem: [ :item | 
			item
				name: 'Kill';
				shortcut: $k meta;
				icon: (self iconNamed: #smallCancelIcon);
				action: [ self inform: 'Kill' ] ];
		yourself! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonDisabled: anObject
	buttonDisabled := anObject! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithIcon
	^ buttonWithIcon! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonHighlighted: anObject
	buttonHighlighted := anObject! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithColor
	^ buttonWithColor! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithIcon: anObject
	buttonWithIcon := anObject! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithIconOnly: anObject
	buttonWithIconOnly := anObject! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithDifferentFont
	^ buttonWithDifferentFont! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonHighlighted
	^ buttonHighlighted! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithDifferentFont: anObject
	buttonWithDifferentFont := anObject! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonNormal
	^ buttonNormal! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithHelp: anObject

	buttonWithHelp := anObject! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithShortcut
	^ buttonWithShortcut! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonDisabled
	^ buttonDisabled! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonNormal: anObject
	buttonNormal := anObject! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithIconOnly
	^ buttonWithIconOnly! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithMenu: anObject
	buttonWithMenu := anObject! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithColor: anObject
	buttonWithColor := anObject! !

!SpDemoButtonsPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	buttonNormal := self newButton label: 'normal'.
	buttonDisabled := self newButton
		label: 'disabled';
		disable;
		yourself.
	buttonWithIcon := self newButton
		label: 'with icon';
		icon: ((self iconNamed: #pharo) scaledToSize: 16 @ 16);
		yourself.
	buttonWithIconOnly := self newButton
		icon: ((self iconNamed: #pharo) scaledToSize: 16 @ 16);
		help: 'This button has only icon, no label';
		yourself.
	buttonHighlighted := self newButton
		label: 'highlighted';
		state: true;
		yourself.
	buttonWithColor := self newButton
		label: 'red';
		color: Color red;
		yourself.
	buttonWithMenu := self newButton
		label: 'with menu';
		contextMenu: self subMenu;
		yourself.
	buttonWithShortcut := self newButton
		shortcut: $o meta;
		label: 'with shortcut';
		yourself.
	buttonWithHelp := self newButton
		label: 'with help';
		help:
			'This button shows
a multiline help';
		yourself.
	buttonWithDifferentFont := self newButton
		label: 'different font';
		font: StandardFonts codeFont;
		yourself.
	self focusOrder
		add: buttonNormal;
		add: buttonDisabled;
		add: buttonWithIcon;
		add: buttonWithIconOnly;
		add: buttonHighlighted;
		add: buttonWithColor;
		add: buttonWithMenu;
		add: buttonWithShortcut;
		add: buttonWithHelp;
		add: buttonWithDifferentFont! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithShortcut: anObject
	buttonWithShortcut := anObject! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithMenu
	^ buttonWithMenu! !

!SpDemoButtonsPresenter methodsFor: 'accessing' stamp: ''!
buttonWithHelp
	^ buttonWithHelp! !

!SpDemoButtonsPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters

	buttonWithShortcut action: [ self inform: 'button with shortcut pressed' ]																																														! !

!SpDemoButtonsPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpGridLayout new
		beColumnHomogeneous;
		borderWidth: 0;
		add: #buttonNormal at: 1 @ 1;
		add: #buttonDisabled at: 2 @ 1;
		add: #buttonWithIcon at: 3 @ 1;
		add: #buttonWithIconOnly at: 4 @ 1;
		add: #buttonHighlighted at: 5 @ 1;
		add: #buttonWithColor at: 1 @ 2;
		add: #buttonWithMenu at: 2 @ 2;
		add: #buttonWithShortcut at: 3 @ 2;
		add: #buttonWithHelp at: 4 @ 2;
		add: #buttonWithDifferentFont at: 5 @ 2! !

!SpDemoCheckboxesPage commentStamp: ''!
Demo page for SpecDemoCheckboxesPresenter!
!SpDemoCheckboxesPage methodsFor: 'initialization' stamp: ''!
pageClass

	^ SpDemoCheckboxesPresenter
! !

!SpDemoCheckboxesPage class methodsFor: 'specs' stamp: ''!
pageName

	^ 'Checkboxes'! !

!SpDemoCheckboxesPage class methodsFor: 'specs' stamp: ''!
priority

	^ 30! !

!SpDemoCheckboxesPresenter commentStamp: ''!
This demo shows differenty styles of check boxes.!
!SpDemoCheckboxesPresenter methodsFor: 'accessing' stamp: ''!
checkboxDisabled
	^ checkboxDisabled! !

!SpDemoCheckboxesPresenter methodsFor: 'accessing' stamp: ''!
checkboxWithHelp: anObject
	checkboxWithHelp := anObject! !

!SpDemoCheckboxesPresenter methodsFor: 'accessing' stamp: ''!
checkboxWithHelp
	^ checkboxWithHelp! !

!SpDemoCheckboxesPresenter methodsFor: 'accessing' stamp: ''!
checkboxWithLabelOnLeft: anObject
	checkboxWithLabelOnLeft := anObject! !

!SpDemoCheckboxesPresenter methodsFor: 'accessing' stamp: ''!
checkboxNormal: anObject
	checkboxNormal := anObject! !

!SpDemoCheckboxesPresenter methodsFor: 'accessing' stamp: ''!
checkboxWithLabelOnLeft
	^ checkboxWithLabelOnLeft! !

!SpDemoCheckboxesPresenter methodsFor: 'accessing' stamp: ''!
checkboxWithColor: anObject
	checkboxWithColor := anObject! !

!SpDemoCheckboxesPresenter methodsFor: 'accessing' stamp: ''!
checkboxNormal
	^ checkboxNormal! !

!SpDemoCheckboxesPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	checkboxNormal  := self newCheckBox
		label: 'normal'.
	checkboxDisabled := self newCheckBox 
		label: 'disabled';
		disable;
		yourself.
	checkboxWithColor := self newCheckBox 
		label: 'red';
		color: Color red;
		yourself.
	checkboxWithHelp := self newCheckBox 
		label: 'with help';
		help: 'this is checkbox with help';
		yourself.
	checkboxExample := self instantiate: SpCheckBoxExample.

																						! !

!SpDemoCheckboxesPresenter methodsFor: 'accessing' stamp: ''!
checkboxWithColor
	^ checkboxWithColor! !

!SpDemoCheckboxesPresenter methodsFor: 'accessing' stamp: ''!
checkboxDisabled: anObject
	checkboxDisabled := anObject! !

!SpDemoCheckboxesPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newLeftToRight
		add:
			(SpBoxLayout newTopToBottom
				add: #checkboxNormal;
				add: #checkboxDisabled;
				add: #checkboxWithColor;
				add: #checkboxWithHelp;
				yourself);
		add: #checkboxExample;
		yourself! !

!SpDemoFormModel commentStamp: ''!
Simple structure-like model for the form demo!
!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
gender: anObject
	gender := anObject! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
number1
	^ number1! !

!SpDemoFormModel methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	name := 'some name'.
	surname := ''.
	number1 := 1.
	number2 := 12.009.
	scale := 42.
	password := 'password'.
	rememberMe := true.
	date := '2018-01-01' asDate.
	gender := #male.
	selectedItems := { self items at: 3. self items at: 4 }
	! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
number1: anObject
	number1 := anObject! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
number2: anObject
	number2 := anObject! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
rememberMe
	^ rememberMe! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
date: anObject
	date := anObject! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
genders
	^ #(male female)! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
password: anObject
	password := anObject! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
elements
	^ { 
		'name' -> self name.
		'surname' -> self surname.
		'number 1' -> self number1.
		'number 2' -> self number2.
		'scale' -> self scale.
		'password' -> self password.
		'rememberMe' -> self rememberMe.
		'date' -> self date.
		'gender' -> self gender.
		'items' -> self selectedItems
		}! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
surname: anObject
	surname := anObject! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
password
	^ password! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
rememberMe: anObject
	rememberMe := anObject! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
scale
	^ scale! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
gender
	^ gender! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
number2
	^ number2! !

!SpDemoFormModel methodsFor: 'initialization' stamp: ''!
items

	^ #('item 1' 'item 2' 'item 3' 'item 4' 'item 5')! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
scale: anObject
	scale := anObject! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
date
	^ date! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
selectedItems
	^ selectedItems! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
surname
	^ surname! !

!SpDemoFormModel methodsFor: 'accessing' stamp: ''!
selectedItems: anObject
	selectedItems := anObject asArray! !

!SpDemoFormPage commentStamp: ''!
Demo page for SpecDemoFormPresenter!
!SpDemoFormPage methodsFor: 'initialization' stamp: ''!
pageClass

	^ SpDemoFormPresenter
! !

!SpDemoFormPage class methodsFor: 'specs' stamp: ''!
pageName

	^ 'Forms'! !

!SpDemoFormPage class methodsFor: 'specs' stamp: ''!
priority

	^ 10! !

!SpDemoFormPresenter commentStamp: ''!
This demo shows, how to create a simple form with basic elements and how to connect this form to a model. 

In this case, the model is represented by instances of the class `SpecDemoFormModel`, instance created in the `#initialize` method. It is a simple structure-like class with some default values. The model is not held directly but using a value holder named announcingObject (see `SpPresenterWithModel>>#model:`). The encapsulating value holder would not be needed if our model would be a subclass of "Model" (instances of Model provide an announcer by default).

This component has two main subcomponents. The form and a table that shows the current state of the model.

The form is a standalone Spec presenter, an instance of `SpDemoStandaloneFormPresenter`. It works with two instances of the model, "workingModel" which holds a working copy of the model and a model shared with its parent. When the form is restored, the working copy of the model is thrown away and replaced with a new copy of the model. When the form is submitted, the new model is stored (into the value holder and its change is propagated so the table showing the state of the model is refreshed).

The data exchanged between the model and form elements is done in these methods:
`SpDemoStandaloneFormPresenter>>#fillFormWithWorkingModel`
`SpDemoStandaloneFormPresenter>>#fillModelWithFormContent`

The two parts of this window (form and table) should be rendered in boxes with an outline. Spec in Morphic does not have such functionality now. 
`SpDemoLabeledPresenter` is used now.

Text input for number 1 is limited directly on the level of user input. See `SpDemoStandaloneFormPresenter>>#initializePresenters` and `SpDemoStandaloneFormPresenter>>#connectPresenters`. !
!SpDemoFormPresenter methodsFor: 'accessing' stamp: ''!
modelChanged
	table items: self model elements! !

!SpDemoFormPresenter methodsFor: 'initialization' stamp: ''!
initialize
	self model: SpDemoFormModel new.
	super initialize! !

!SpDemoFormPresenter methodsFor: 'accessing' stamp: ''!
form
	^ form! !

!SpDemoFormPresenter methodsFor: 'accessing' stamp: ''!
form: anObject
	form := anObject! !

!SpDemoFormPresenter methodsFor: 'accessing' stamp: ''!
resultPane
	^ resultPane! !

!SpDemoFormPresenter methodsFor: 'accessing' stamp: ''!
table: anObject
	table := anObject! !

!SpDemoFormPresenter methodsFor: 'accessing' stamp: ''!
table
	^ table! !

!SpDemoFormPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	form := self newPresenter 
		layout: (SpBoxLayout newTopToBottom
			add: 'form' expand: false;
			add: (self instantiate: SpDemoStandaloneFormPresenter on: self announcingObject);
			yourself);
		yourself.

	resultPane := self newPresenter 
		layout: (SpBoxLayout newTopToBottom
			add: 'result' expand: false;
			add: (table := self newTable);
			yourself);
		yourself.

	table
		addColumn: (SpStringTableColumn title: 'Name' evaluated: #key);
		addColumn: (SpStringTableColumn title: 'Value' evaluated: #value);
		items: self model elements;
		beResizable! !

!SpDemoFormPresenter methodsFor: 'accessing' stamp: ''!
resultPane: anObject
	resultPane := anObject! !

!SpDemoFormPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpPanedLayout newLeftToRight
		positionOfSlider: (StandardFonts defaultFont widthOfString: 'M') * 35;
		add: #form;
		add: #resultPane;
		yourself! !

!SpDemoImagePage commentStamp: ''!
Description
--------------------

Demo page for SpecDemoImagePresenter!
!SpDemoImagePage methodsFor: 'initialization' stamp: ''!
pageClass

	^ SpDemoImagePresenter! !

!SpDemoImagePage class methodsFor: 'initialization' stamp: ''!
pageName

	^ 'Images'! !

!SpDemoImagePage class methodsFor: 'initialization' stamp: ''!
priority

	^ 16! !

!SpDemoImagePresenter commentStamp: ''!
Description
--------------------

This demo show how to use the image presenter!
!SpDemoImagePresenter methodsFor: 'accessing' stamp: ''!
image1
	^ image1! !

!SpDemoImagePresenter methodsFor: 'accessing' stamp: ''!
image2
	^ image2! !

!SpDemoImagePresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	image1 := self newImage.
	image2 := self newImage.

	image1 image: (self iconNamed: #pharo).
	image2 image: self currentWorld submorphs last form.! !

!SpDemoImagePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: (SpBoxLayout newLeftToRight
			add: 'Image added through an ImagePresenter:';
			add: #image1;
			yourself)
		height: 50;
		add: (SpBoxLayout newLeftToRight
			add: 'Image added through an ImagePresenter:';
			add: #image2;
			yourself);
		add: (SpBoxLayout newLeftToRight
			add: 'Image added directly from the layout definition:';
			add: (self iconNamed: #pharoBig);
			yourself);
		yourself! !

!SpDemoImagePresenter class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	self new openWithSpec! !

!SpDemoLabeledPage commentStamp: ''!
Description
--------------------

I am a page for a labelled presenter demo!
!SpDemoLabeledPage methodsFor: 'initialization' stamp: ''!
pageClass
	^ SpDemoLabeledPresenter! !

!SpDemoLabeledPage class methodsFor: 'initialization' stamp: ''!
pageName

	^ 'Labeled presenter'! !

!SpDemoLabeledPresenter commentStamp: ''!
Description
--------------------

Demo for the labelled presenter!
!SpDemoLabeledPresenter methodsFor: 'accessing' stamp: ''!
email
	^ email! !

!SpDemoLabeledPresenter methodsFor: 'accessing' stamp: ''!
password
	^ password! !

!SpDemoLabeledPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	| passwordInput |

	passwordInput := self newTextInput
		bePassword;
		yourself.
		
	email := self instantiate: (SpLabeledPresenter 
		label: 'Email' 
		input: self newTextInput 
		description: 'Email you will use to send activations mails to your users.').
	password := self instantiate: (SpLabeledPresenter 
		label: 'Password' 
		input: passwordInput 
		description: 'Password of the email account used.')! !

!SpDemoLabeledPresenter class methodsFor: 'initialization' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: #email expand: false;
		add: #password expand: false;
		yourself! !

!SpDemoLinksPage commentStamp: ''!
Description
--------------------

Demo page for SpecDemoLinksPresenter!
!SpDemoLinksPage methodsFor: 'initialization' stamp: ''!
pageClass

	^ SpDemoLinksPresenter! !

!SpDemoLinksPage class methodsFor: 'specs' stamp: ''!
pageName

	^ 'Links'! !

!SpDemoLinksPage class methodsFor: 'specs' stamp: ''!
priority

	^ 15! !

!SpDemoLinksPresenter commentStamp: ''!
Description
--------------------

This demo show how to use the link presenter!
!SpDemoLinksPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	link1 := self newLink.
	link2 := self newLink.
	link3 := self newLink.
	link4 := self newLink.

	link1 url: 'https://pharo.org'.

	link2
		url: 'https://pharo.org';
		label: 'Pharo website'.

	link3
		url: 'https://pharo.org';
		label: 'Pharo website';
		color: Color purple.

	link4
		action: [ Object browse ];
		label: 'Browse Object'! !

!SpDemoLinksPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #link1;
		add: #link2;
		add: #link3;
		add: #link4;
		yourself! !

!SpDemoLinksPresenter class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	self new openWithSpec! !

!SpDemoListsPresenter commentStamp: ''!
Description
--------------------

I am a demo showing how to use Spec lists.!
!SpDemoListsPresenter methodsFor: 'accessing' stamp: ''!
list2
	^ list2! !

!SpDemoListsPresenter methodsFor: 'accessing' stamp: ''!
list3
	^ list3! !

!SpDemoListsPresenter methodsFor: 'accessing' stamp: ''!
multiLabel
	^ multiLabel! !

!SpDemoListsPresenter methodsFor: 'menu' stamp: ''!
list1Menu
	^ self newMenu
		title: 'Context menu example';
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Print in transcript';
						shortcut: $p meta;
						description: 'Print the selected class on Transcript';
						action: [ list1 selectedItem traceCr ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Browse';
						iconName: #open;
						action: [ list1 selectedItem browse ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Print infos';
						subMenu:
							(self newMenu
								addGroup: [ :aSubGroup | 
									aSubGroup
										addItem: [ :item | 
											item
												name: 'Print number of methods';
												action: [ list1 selectedItem methods size traceCr ] ];
										addItem: [ :item | 
											item
												name: 'Print number of variables';
												action: [ list1 selectedItem instanceVariables size traceCr ] ] ]) ] ];
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Item showing only if item a odd number of letters';
						visibleIf: [ list1 selectedItem printString size odd ];
						action: [ list1 selectedItem traceCr ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Disabled in second group';
						disable;
						action: [ list1 selectedItem traceCr ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Disabled if class begins with A';
						enabled: [ list1 selectedItem printString first ~= $A ];
						action: [ list1 selectedItem traceCr ] ] ]! !

!SpDemoListsPresenter methodsFor: 'accessing' stamp: ''!
list1
	^ list1! !

!SpDemoListsPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	list1 := self newList.
	list2 := self newList.
	list3 := self instantiate: SpFilteringListPresenter.
	label := self newLabel.
	multiLabel := self newLabel.

	list1
		items: self class environment allClasses;
		contextMenu: self list1Menu.
	list2
		items: self class environment allClasses;
		sortingBlock: [ :a :b | a asString size < b asString size ];
		beMultipleSelection.
	list3
		items: self class environment allClasses;
		itemFilter: [ :item :string | item asString includesSubstring: string ];
		displayIcon: [ :elem | self iconFor: elem ].
	label label: 'No selection'.
	multiLabel label: 'No multi selection (from list 2 only)'! !

!SpDemoListsPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters
	list1
		whenSelectionChangedDo: [ :selection | 
			[ :elem | 
			label
				label:
					(elem
						ifNil: [ 'Deselection from list 1' ]
						ifNotNil: [ 'Selection from list 1: ' , elem asString ]) ]
				cull: selection selectedItem ].

	list2
		whenSelectionChangedDo: [ :selection | 
			[ :elems | 
			multiLabel
				label:
					(elems
						ifEmpty: [ 'Not multi selection (from list 2 only)' ]
						ifNotEmpty: [ 'Multi-selection from list 2: ' , elems asString ]) ]
				cull: selection selectedItems ].
	list3
		whenSelectionChangedDo: [ :selection | 
			[ :elem | 
			label
				label:
					(elem
						ifNil: [ 'Deselection from list 3' ]
						ifNotNil: [ 'Selection from list 3: ' , elem asString ]) ]
				cull: selection selectedItem ]! !

!SpDemoListsPresenter methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!SpDemoListsPresenter methodsFor: 'defaults' stamp: ''!
iconFor: class
	((class includesBehavior: (Smalltalk globals at: #TestCase ifAbsent: [ false ])) and: [ class isAbstract not ])
		ifTrue: [ class hasPassedTest ifTrue: [ ^ self iconNamed: #testGreenIcon ].
			class hasFailedTest ifTrue: [ ^ self iconNamed: #testYellowIcon ].
			class hasErrorTest ifTrue: [ ^ self iconNamed: #testRedIcon ].
			^ self iconNamed: #testNotRunIcon ].
	class organization classComment ifEmpty: [ ^ self iconNamed: #uncommentedClassIcon ].
	((class includesBehavior: (Smalltalk globals at: #TestCase ifAbsent: [ false ])) and: [ class isAbstract not ])
		ifTrue: [ class hasPassedTest ifTrue: [ ^ self iconNamed: #testGreenIcon ].
			class hasFailedTest ifTrue: [ ^ self iconNamed: #testYellowIcon ].
			class hasErrorTest ifTrue: [ ^ self iconNamed: #testRedIcon ].
			^ self iconNamed: #testNotRunIcon ].
	class organization classComment ifEmpty: [ ^ self iconNamed: #uncommentedClassIcon ].
	^ class systemIcon! !

!SpDemoListsPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add:
					(SpBoxLayout newTopToBottom
						add: 'Menu' withConstraints: [ :constraints | constraints height: self labelHeight ];
						add: #list1;
						yourself);
				add:
					(SpBoxLayout newTopToBottom
						add: 'Multi selection/Sorting' withConstraints: [ :constraints | constraints height: self labelHeight ];
						add: #list2;
						yourself);
				add:
					(SpBoxLayout newTopToBottom
						add: 'Icons/Filter' withConstraints: [ :constraints | constraints height: self labelHeight ];
						add: #list3;
						yourself);
				yourself);
		add:
			(SpBoxLayout newLeftToRight
				add: #multiLabel;
				add: #label;
				yourself)
			withConstraints: [ :constraints | constraints height: self labelHeight ];
		yourself! !

!SpDemoMenuButtonPresenter methodsFor: 'initialization' stamp: ''!
newExampleMenu
	| loremIpsumWorlds |
	
	loremIpsumWorlds := String loremIpsum substrings.
	^ SpMenuPresenter new
		addGroup: [ :group | 
			1 to: 10 atRandom do: [ :index |
				group addItem: [ :item |
					item 
						name: ('{1}: {2}' format: { index. loremIpsumWorlds atRandom }); 
						action: [ button label: item name ] ] ] ];
		yourself! !

!SpDemoMenuButtonPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	<script: 'self new openWithSpec'>

	(button := self newButton)
		label: 'Choice';
		action: [ text text: text text, button label, String cr ].
			
	menu := self newMenuButton
		help: 'An example menu.';
		menu: [ self newExampleMenu ];
		yourself.


	text := self newText! !

!SpDemoMenuButtonPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom 
		add: (SpBoxLayout newLeftToRight
			add: #button;
			add: #menu expand: false fill: false padding: 0;
			yourself) 
			expand: false 
			fill: false 
			padding: 0;
		add: #text;
		yourself! !

!SpDemoMessageBrowser commentStamp: ''!
A small example to be used in the notebook demo.!
!SpDemoMessageBrowser methodsFor: 'initialization' stamp: ''!
updatePresenter

	messageList items: self messages! !

!SpDemoMessageBrowser methodsFor: 'accessing' stamp: ''!
messages: anOrderedCollection

	messages := anOrderedCollection asOrderedCollection.
	self updatePresenter! !

!SpDemoMessageBrowser methodsFor: 'accessing' stamp: ''!
messages

	^ messages ifNil: [ #() ]! !

!SpDemoMessageBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpBoxLayout newTopToBottom
		add: (messageList := self newTable);
		add: (sourceText := self newCode);
		yourself).
		
	messageList 
		addColumn: (SpStringTableColumn title: 'Class' evaluated: [ :each | each origin name ]);
		addColumn: (SpStringTableColumn title: 'Name' evaluated: [ :each | each selector ]).
		
	sourceText beNotEditable! !

!SpDemoMessageBrowser methodsFor: 'initialization' stamp: ''!
connectPresenters

	messageList 
		transmitTo: sourceText  
		transform: [ :aMethod | 
			aMethod 
				ifNotNil: [ aMethod sourceCode ]
				ifNil: [ '' ] ]! !

!SpDemoModal1Presenter commentStamp: ''!
Description
--------------------

I am a presenter for a modal with default buttons whose user can close by clicking on the backdrop.!
!SpDemoModal1Presenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialog
	super initializeDialogWindow: aDialog.
	aDialog
		closeOnBackdropClick: true;
		okAction: [ :presenter | self inform: 'Ok action' ];
		cancelAction: [ :presenter | self inform: 'Cancel' ]! !

!SpDemoModal1Presenter methodsFor: 'accessing' stamp: ''!
content
	^ 'I am a modal demo with default actions buttons. I set closeOnBackdropClick to true (which is the default value) to close the modal if the user click on the backdrop of the modal. This will trigger the cancel action of the modal.'! !

!SpDemoModal2Presenter commentStamp: ''!
Description
--------------------

I am a presenter for a modal with custom buttons whose user cannot close by clicking on the backdrop.!
!SpDemoModal2Presenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialog
	aDialog
		closeOnBackdropClick: false;
		addButton: 'Validate'
			do: [ :presenter | 
			self inform: 'Validate'.
			presenter close ];
		addButton: 'Reset'
			do: [ :presenter | self inform: 'This action does not close the modal' ];
		addButton: 'Cancel'
			do: [ :presenter | 
			self inform: 'Cancel'.
			presenter close ]! !

!SpDemoModal2Presenter methodsFor: 'accessing' stamp: ''!
content
	^ 'I am a modal demo with custom actions buttons.  I set closeOnBackdropClick to false so that the user cannot click on the backdrop to close the modal.'! !

!SpDemoModalPresenter commentStamp: ''!
Description
--------------------

I am a presenter to show how to use modals with spec.!
!SpDemoModalPresenter methodsFor: 'accessing' stamp: ''!
button1
	^ button1! !

!SpDemoModalPresenter methodsFor: 'accessing' stamp: ''!
button2
	^ button2! !

!SpDemoModalPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	button1 := self newButton.
	button2 := self newButton.
	
	button1
		label: 'Open 1';
		action: [ SpDemoModal1Presenter new openModalWithSpec ].
	button2 label: 'Open 2';
		action: [ SpDemoModal2Presenter new openModalWithSpec ]! !

!SpDemoModalPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #button1;
				add: #button2;
				yourself)
			withConstraints: [ :constraints | constraints height: self buttonHeight ];
		yourself! !

!SpDemoModalPresenter class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	self new openWithSpec! !

!SpDemoModalPresenter class methodsFor: 'specs' stamp: ''!
title
	^ 'Modals demo'! !

!SpDemoModalsPage commentStamp: ''!
Description
--------------------

Demo page for SpecDemoModalPresenter!
!SpDemoModalsPage methodsFor: 'initialization' stamp: ''!
pageClass

	^ SpDemoModalPresenter
! !

!SpDemoModalsPage class methodsFor: 'specs' stamp: ''!
pageName

	^ 'Modals'! !

!SpDemoModalsPage class methodsFor: 'specs' stamp: ''!
priority

	^ 30! !

!SpDemoNotebookPage commentStamp: ''!
Description
--------------------

Demo page for SpecDemoNotebookPresenter!
!SpDemoNotebookPage methodsFor: 'initialization' stamp: ''!
pageClass
	^ SpDemoNotebookPresenter! !

!SpDemoNotebookPage class methodsFor: 'specs' stamp: ''!
pageName
	^ 'Notebook'! !

!SpDemoNotebookPage class methodsFor: 'specs' stamp: ''!
priority
	^ 13! !

!SpDemoNotebookPresenter commentStamp: ''!
Description
--------------------

I am a presenter to show how to use notebook with spec.!
!SpDemoNotebookPresenter methodsFor: 'pages' stamp: ''!
objectClassPage

	^ (SpNotebookPage 
		title: 'Object class' 
		icon: (self iconNamed: #nautilusIcon) 
		provider: [ 
			SpDemoMessageBrowser new
				messages: Object methods;
				yourself ])
		beCloseable;
		yourself! !

!SpDemoNotebookPresenter methodsFor: 'pages' stamp: ''!
browserPage

	^ SpNotebookPage
		title: 'Browser'
		icon: (self iconNamed: #nautilusIcon)
		provider: [ 
			SpClassMethodBrowser new
				classes: self class environment allClasses;
				yourself ]! !

!SpDemoNotebookPresenter methodsFor: 'pages' stamp: ''!
objectInspectorPage
	^ SpNotebookPage
		title: 'Object inspector'
		icon: (self iconNamed: #nautilusIcon)
		provider: [ 
			SpObjectInspector new
				inspect: Object;
				yourself ]
		layoutSpec: #inspectorSpec! !

!SpDemoNotebookPresenter methodsFor: 'pages' stamp: ''!
dynamicPage
	^ SpNotebookPage title: 'Dynamic' icon: (self iconNamed: #nautilusIcon) provider: [ SpDynamicWidgetChange new ]! !

!SpDemoNotebookPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	notebook := self newNotebook.
	checkbox := self newCheckBox.
	checkbox label: 'Show dynamic presenter'.

	notebook
		addPage: self objectClassPage;
		addPage: self objectInspectorPage;
		addPage: self browserPage! !

!SpDemoNotebookPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters
	super connectPresenters.

	checkbox whenActivatedDo: [ notebook addPage: (dynamicPage := self dynamicPage) ].

	checkbox
		whenDeactivatedDo: [ dynamicPage
				ifNotNil: [ :page | 
					notebook removePage: page.
					dynamicPage := nil ] ]! !

!SpDemoNotebookPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: #notebook;
		add: #checkbox expand: false;
		yourself! !

!SpDemoNotebookPresenter class methodsFor: 'examples' stamp: ''!
example
	^ self new openWithSpec! !

!SpDemoPage commentStamp: ''!
A superclass for particular Spec demo pages, that need to define a page name and priority in the list of demos.!
!SpDemoPage methodsFor: 'initialization' stamp: ''!
codeFor: aClass
	^ TonelWriter sourceCodeOf: aClass! !

!SpDemoPage methodsFor: 'initialization' stamp: ''!
exampleTab
	^ SpNotebookPage title: 'Example' icon: (self iconNamed: #smallPaint) provider: [ self instantiate: self pageClass ]! !

!SpDemoPage methodsFor: 'initialization' stamp: ''!
pageClass

	self subclassResponsibility 
! !

!SpDemoPage methodsFor: 'accessing' stamp: ''!
tabManager
	^ tabManager! !

!SpDemoPage methodsFor: 'accessing' stamp: ''!
tabManager: anObject
	tabManager := anObject! !

!SpDemoPage methodsFor: 'initialization' stamp: ''!
initializePresenters

	tabManager := self newNotebook.
	"tabManager whenTabSelected: [ self updateTitle ]."
	tabManager
		addPage: self exampleTab;
		addPage: self codeTab.! !

!SpDemoPage methodsFor: 'initialization' stamp: ''!
codeTab
	^ SpNotebookPage
		title: 'Code'
		icon: (self iconNamed: #changeUpdate)
		provider: [ self newText
				text: (self codeFor: self pageClass);
				yourself ]! !

!SpDemoPage class methodsFor: 'initialization' stamp: ''!
pageName

	self subclassResponsibility 
! !

!SpDemoPage class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #tabManager;
		yourself! !

!SpDemoPage class methodsFor: 'initialization' stamp: ''!
priority

	^ 999! !

!SpDemoPage class methodsFor: 'accessing' stamp: ''!
availablePages
	^ self allSubclasses sort: #priority ascending! !

!SpDemoRadioButtonsPage commentStamp: ''!
Demo page for SpecDemoRadioButtonsPresenter.!
!SpDemoRadioButtonsPage methodsFor: 'initialization' stamp: ''!
pageClass
	^ SpDemoRadioButtonsPresenter! !

!SpDemoRadioButtonsPage class methodsFor: 'initialization' stamp: ''!
pageName
	^ 'Radio buttons'! !

!SpDemoRadioButtonsPage class methodsFor: 'initialization' stamp: ''!
priority
	^ 32! !

!SpDemoRadioButtonsPresenter commentStamp: ''!
This demo shows differenty styles of radio buttons.!
!SpDemoRadioButtonsPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	radioButtonExample := self instantiate: SpRadioButtonExample! !

!SpDemoRadioButtonsPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newLeftToRight
		add: #radioButtonExample;
		yourself! !

!SpDemoStandaloneFormPresenter commentStamp: ''!
The presenter that provides only the standalone form for the form demo!
!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
number1Label: anObject
	number1Label := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'actions' stamp: ''!
restore

	self modelChanged

	! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
number2Label: anObject
	number2Label := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'model updates' stamp: ''!
fillModelWithFormContent

	self workingModel
		name: self nameTextInput text;
		surname: self surnameTextInput text;
		number1: number1Input number;
		number2: number2Input number;
		scale: self scaleInput value;
		password: self passwordInput text;
		rememberMe: self checkboxInput state;
		date: self dateInput date.

	self workingModel gender: (genderButtons associations detect: [ :each | each value state ]) key.
	
	self workingModel selectedItems: self itemsInput selectedItems.
! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing - model' stamp: ''!
workingModel
	^ workingModel! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
dateInput: anObject
	dateInput := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
dateLabel
	^ dateLabel! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
genderLabel: anObject
	genderLabel := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
nameLabel: anObject
	nameLabel := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
surnameTextInput
	^ surnameTextInput! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
femaleButton
	^ femaleButton! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
maleButton
	^ maleButton! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing - model' stamp: ''!
workingModel: anObject
	workingModel := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
surnameLabel
	^ surnameLabel! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
dateInput
	^ dateInput! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
checkboxLabel
	^ checkboxLabel! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
nameLabel
	^ nameLabel! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
scaleInput: anObject
	scaleInput := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
genderLabel
	^ genderLabel! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
surnameLabel: anObject
	surnameLabel := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
passwordInput
	^ passwordInput! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
passwordLabel: anObject
	passwordLabel := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'model updates' stamp: ''!
fillFormWithWorkingModel
	| aModel |
	aModel := self workingModel.
	self nameTextInput text: aModel name.
	self surnameTextInput text: aModel surname.
	self number1Input text: aModel number1 asString.
	self number2Input text: aModel number2 asString.
	self scaleInput value: aModel scale.
	self passwordInput text: aModel password.
	self checkboxInput state: aModel rememberMe.
	"self dateInput date: aModel date."
	(genderButtons at: aModel gender) state: true.

	self itemsInput selectItems: self workingModel selectedItems! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
number2Input
	^ number2Input! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
passwordLabel
	^ passwordLabel! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
dateLabel: anObject
	dateLabel := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
itemsLabel: anObject
	itemsLabel := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
submitButton
	^ submitButton! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
itemsLabel
	^ itemsLabel! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
nameTextInput
	^ nameTextInput! !

!SpDemoStandaloneFormPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	nameLabel := self newLabel label: 'name:'.
	nameTextInput := self newTextInput.

	surnameLabel := self newLabel label: 'surname:'.
	surnameTextInput := self newTextInput.
	surnameTextInput placeholder: 'empty'.
	number1Label := self newLabel label: 'number 1:'.
	number1Input := self newNumberInput.

	number2Label := self newLabel label: 'number 2:'.
	number2Input := self newNumberInput
		beFloat;
		digits: 3;
		climbRate: 0.005;
		minimum: 10.005;
		maximum: 20.05.

	scaleLabel := self newLabel label: 'scale:'.
	scaleInput := self newSlider.

	passwordLabel := self newLabel label: 'password:'.
	passwordInput := self newTextInput bePassword.
	checkboxLabel := self newLabel label: 'remember me'.
	checkboxInput := self newCheckBox state: true.

	dateLabel := self newLabel label: 'date:'.
	dateInput := self instantiate: SpDatePresenter.
	dateInput display: [ :item | item yyyymmdd ].

	maleButton := self newRadioButton label: 'male'.
	femaleButton := self newRadioButton label: 'female'.
	maleButton associatedRadioButtons: {femaleButton}.
	genderButtons := Dictionary newFrom: {
		(#male -> maleButton). 
		(#female -> femaleButton)}.

	genderLabel := self newLabel label: 'gender:'.
	itemsLabel := self newLabel label: 'items:'.
	itemsInput := self newList.
	itemsInput beMultipleSelection.
	itemsInput items: self model items.

	submitButton := self newButton label: 'Submit'.
	restoreButton := self newButton label: 'Restore'! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
restoreButton
	^ restoreButton! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
checkboxLabel: anObject
	checkboxLabel := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters
	self submitButton action: [ self submit ].
	self restoreButton action: [ self restore ]! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
number2Input: anObject
	number2Input := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'actions' stamp: ''!
submit

	self fillModelWithFormContent.
	
	self model: workingModel.
	self announcingObject valueChanged.
	! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
submitButton: anObject
	submitButton := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
itemsInput
	^ itemsInput! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
surnameTextInput: anObject
	surnameTextInput := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
number1Input
	^ number1Input! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
scaleInput
	^ scaleInput! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
scaleLabel
	^ scaleLabel! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
checkboxInput: anObject
	checkboxInput := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
number1Label
	^ number1Label! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
itemsInput: anObject
	itemsInput := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
checkboxInput
	^ checkboxInput! !

!SpDemoStandaloneFormPresenter methodsFor: 'initialization' stamp: ''!
modelChanged

	workingModel := self model copy.

	self fillFormWithWorkingModel.

	! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
number1Input: anObject
	number1Input := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
restoreButton: anObject
	restoreButton := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
scaleLabel: anObject
	scaleLabel := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
nameTextInput: anObject
	nameTextInput := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
passwordInput: anObject
	passwordInput := anObject! !

!SpDemoStandaloneFormPresenter methodsFor: 'accessing' stamp: ''!
number2Label
	^ number2Label! !

!SpDemoStandaloneFormPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	
	^ SpBoxLayout newTopToBottom
		add:
			(SpGridLayout build: [ :builder |
				builder
					add: 'Name:';
					add: #nameTextInput;
					nextRow;
					add: 'Surname:';
					add: #surnameTextInput;
					nextRow;
					add: 'Number 1:';
					add: #number1Input;
					nextRow;
					add: 'Number 2:';
					add: #number2Input;
					nextRow;
					add: 'Scale:';
					add: #scaleInput;
					nextRow;
					add: 'Password:';
					add: #passwordInput;
					nextRow;
					add: 'Remember me:';
					add: #checkboxInput;
					nextRow;
					"SpDatePresenter is exclusive from Morphic backend for the moment"
					"add: 'Date:';
					add: #dateInput;
					nextRow;"
					add: 'Gender:';
					add:
						(SpBoxLayout newLeftToRight
							add: #maleButton;
							add: #femaleButton;
							yourself) ]);
		add: (SpBoxLayout newLeftToRight
				add: #submitButton;
				add: #restoreButton;
				yourself)
			expand: false;
		yourself! !

!SpDemoStandaloneFormPresenter class methodsFor: 'instance creation' stamp: ''!
open
	<example>
	(self on: SpDemoFormModel new) openWithSpec! !

!SpDemoTablePage commentStamp: ''!
Description
--------------------

I am a demo showing a demo of tables.!
!SpDemoTablePage methodsFor: 'initialization' stamp: ''!
pageClass
	^ SpDemoTablePresenter! !

!SpDemoTablePage class methodsFor: 'initialization' stamp: ''!
pageName
	^ 'Tables'! !

!SpDemoTablePresenter commentStamp: ''!
Description
--------------------

I show demos of tables!
!SpDemoTablePresenter methodsFor: 'initialization' stamp: ''!
initialize
	selectedClasses := OrderedCollection with: ASTCache with: ASTEvaluationTest with: Abort.
	super initialize! !

!SpDemoTablePresenter methodsFor: 'initialization' stamp: ''!
resetLabel
	label label: (selectedClasses ifEmpty: [ 'No class checked' ] ifNotEmpty: [ (selectedClasses collect: #printString) joinUsing: ' - '])! !

!SpDemoTablePresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	table1 := self newTable.
	label := self newLabel.

	self resetLabel.

	table1
		addColumn:
			((SpCheckBoxTableColumn title: ' ' evaluated: [ :class | selectedClasses includes: class ])
				onActivation: [ :class | 
					selectedClasses add: class.
					self resetLabel ];
				onDeactivation: [ :class | 
					selectedClasses remove: class.
					self resetLabel ];
				width: 20;
				yourself);
		addColumn:
			((SpImageTableColumn title: 'Icon' evaluated: #systemIcon)
				width: 50;
				yourself);
		addColumn: (SpStringTableColumn title: 'Name' evaluated: #name);
		addColumn: (SpStringTableColumn title: 'Number of subclasses' evaluated: [ :class | class subclasses size asString ]);
		items: self class environment allClasses;
		beResizable! !

!SpDemoTablePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #table1;
		add: #label withConstraints: [ :c | c height: self labelHeight ];
		yourself! !

!SpDemoTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpDemo! !

!SpDemoTest methodsFor: 'tests' stamp: ''!
testSmokeTestForDemoPages
	self timeLimit: 1 minute.
	"We could use #shouldnt:raise: but this way give us the stack of the error"
	SpDemoPage availablePages
		do: [ :demoPage | 
			[ [ window := demoPage new openWithSpec ]
				on: Error
				do: [ :e | 
					self
						fail:
							'Broken demo page: ' , demoPage asString
								,
									'

' , e signalerContext shortStack ] ]
				ensure: [ window ifNotNil: #close ] ]! !

!SpDemoTextInputPage commentStamp: ''!
Demo page for SpecDemoTextInputPresenter!
!SpDemoTextInputPage methodsFor: 'initialization' stamp: ''!
pageClass

	^ SpDemoTextInputPresenter
! !

!SpDemoTextInputPage class methodsFor: 'specs' stamp: ''!
pageName

	^ 'Text input'! !

!SpDemoTextInputPage class methodsFor: 'specs' stamp: ''!
priority

	^ 20! !

!SpDemoTextInputPresenter commentStamp: ''!
This demo shows differenty styles of text inputs.!
!SpDemoTextInputPresenter methodsFor: 'accessing' stamp: ''!
fieldEncrypted: anObject
	fieldEncrypted := anObject! !

!SpDemoTextInputPresenter methodsFor: 'accessing' stamp: ''!
fieldNormal: anObject
	fieldNormal := anObject! !

!SpDemoTextInputPresenter methodsFor: 'accessing' stamp: ''!
fieldNormal
	^ fieldNormal! !

!SpDemoTextInputPresenter methodsFor: 'accessing' stamp: ''!
fieldDisabled: anObject
	fieldDisabled := anObject! !

!SpDemoTextInputPresenter methodsFor: 'accessing' stamp: ''!
fieldPlaceholderText
	^ fieldPlaceholderText! !

!SpDemoTextInputPresenter methodsFor: 'accessing' stamp: ''!
fieldDisabled
	^ fieldDisabled! !

!SpDemoTextInputPresenter methodsFor: 'accessing' stamp: ''!
fieldEncrypted
	^ fieldEncrypted! !

!SpDemoTextInputPresenter methodsFor: 'accessing' stamp: ''!
fieldPlaceholderText: anObject
	fieldPlaceholderText := anObject! !

!SpDemoTextInputPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	fieldNormal := self newTextInput.
	
	fieldDisabled := self newTextInput enabled: false.
	
	fieldPlaceholderText := self newTextInput placeholder: 'Placeholder text'.
	
	fieldEncrypted := self newTextInput
		text: 'Password';
		bePassword! !

!SpDemoTextInputPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpGridLayout new
		beColumnNotHomogeneous;
		add: 'Normal:' at: 1 @ 1;
		add: #fieldNormal at: 2 @ 1;
		add: 'Disabled:' at: 1 @ 2;
		add: #fieldDisabled at: 2 @ 2;
		add: 'Placeholder:' at: 1 @ 3;
		add: #fieldPlaceholderText at: 2 @ 3;
		add: 'Password:' at: 1 @ 4;
		add: #fieldEncrypted at: 2 @ 4;
		yourself! !

!SpDemoToolbarPage commentStamp: ''!
Demo page for SpecDemoToolBarPresenter!
!SpDemoToolbarPage methodsFor: 'initialization' stamp: ''!
pageClass

	^ SpDemoToolbarPresenter! !

!SpDemoToolbarPage class methodsFor: 'specs' stamp: ''!
pageName

	^ 'Toolbar'! !

!SpDemoToolbarPage class methodsFor: 'specs' stamp: ''!
priority
	^ 12! !

!SpDemoToolbarPresenter commentStamp: ''!
This demo shows a tool bar.!
!SpDemoToolbarPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	
	toolBar := self newToolbar
		addItem: (SpToolbarButtonPresenter new
			label: 'Ok';
			icon: (self iconNamed: #smallOk);
			help: 'Ok';
			action: [ self inform: 'Ok' ];
			yourself);
		addItem: (SpToolbarButtonPresenter new
			label: 'Cancel';
			icon: (self iconNamed: #smallCancel);
			help: 'Cancel';
			action: [ self inform: 'Cancel' ];
			yourself);
		yourself.
	text := self newText! !

!SpDemoToolbarPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom 
		add: #toolBar expand: false;
		add: #text;
		yourself! !

!SpDemoTreeTablePage commentStamp: ''!
Description
--------------------

I am a demo showing a demo of tree tables.!
!SpDemoTreeTablePage methodsFor: 'initialization' stamp: ''!
pageClass
	^ SpDemoTreeTablePresenter! !

!SpDemoTreeTablePage class methodsFor: 'initialization' stamp: ''!
pageName
	^ 'Tree tables'! !

!SpDemoTreeTablePresenter commentStamp: ''!
Description
--------------------

I show demos of tree tables!
!SpDemoTreeTablePresenter methodsFor: 'accessing' stamp: ''!
menu
	^ self newMenu
		title: 'Context menu example';
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Print in transcript';
						shortcut: $p meta;
						description: 'Print the selected class on Transcript';
						action: [ table1 selectedItem traceCr ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Browse';
						iconName: #open;
						action: [ table1 selectedItem browse ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Print infos';
						subMenu:
							(self newMenu
								addGroup: [ :aSubGroup | 
									aSubGroup
										addItem: [ :item | 
											item
												name: 'Print number of methods';
												action: [ table1 selectedItem methods size traceCr ] ];
										addItem: [ :item | 
											item
												name: 'Print number of variables';
												action: [ table1 selectedItem instanceVariables size traceCr ] ] ]) ] ];
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Item showing only if item a odd number of letters';
						visibleIf: [ table1 selectedItem printString size odd ];
						action: [ table1 selectedItem traceCr ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Disabled in second group';
						disable;
						action: [ table1 selectedItem traceCr ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Disabled if class begins with A';
						enabled: [ table1 selectedItem printString first ~= $A ];
						action: [ table1 selectedItem traceCr ] ] ]! !

!SpDemoTreeTablePresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	table1 := self newTreeTable.
	table1
		addColumn: (SpCompositeTableColumn new
			title: 'Classes';
			addColumn: ((SpImageTableColumn evaluated: #systemIcon)
				width: 20;
				yourself);
			addColumn: (SpStringTableColumn evaluated: #name);
			yourself);
		addColumn: (SpStringTableColumn 
			title: 'Number of subclasses' 
			evaluated: [ :class | class subclasses size asString ]);
		addColumn: (SpStringTableColumn 
			title: 'Number of methods' 
			evaluated: [ :class | class methods size asString ]);
		roots: {Object};
		children: [ :aClass | aClass subclasses ];
		beResizable;
		contextMenu: self menu;
		activateOnDoubleClick;
		whenActivatedDo: [ :selection | selection selectedItem browse ]! !

!SpDemoTreeTablePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #table1;
		add: 'Double click to browse.'
			expand: false
			fill: false
			padding: 0;
		yourself! !

!SpDialogPresenter commentStamp: ''!
I am base for Spec Standard Dialogs.
Standard dialogs are available to provide simple I/O to users.!
!SpDialogPresenter methodsFor: 'private' stamp: ''!
cancel

	self window 
		beCancel; 
		triggerCancelAction;
		close! !

!SpDialogPresenter methodsFor: 'api - showing' stamp: ''!
openModalWithSpec
	"Open dialog in a modal way. "

	^ super openModalWithSpec! !

!SpDialogPresenter methodsFor: 'api - events' stamp: ''!
onAccept: aBlock
	"When the dialog is accepted, it executes this action before close.
	 `aBlock` receives one argument (this dialog)"

	acceptAction := aBlock! !

!SpDialogPresenter methodsFor: 'api - showing' stamp: ''!
openDialogWithSpec
	"Open dialog in a non-modal way."

	^ super openDialogWithSpec! !

!SpDialogPresenter methodsFor: 'accessing' stamp: ''!
parentWindow

	^ parentWindow! !

!SpDialogPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter

	aDialogWindowPresenter 
		okAction: acceptAction;
		cancelAction: cancelAction.
	
	self parentWindow 
		ifNotNil: [ :w | aDialogWindowPresenter centeredRelativeTo: w ] 
		ifNil: [ aDialogWindowPresenter centered ].! !

!SpDialogPresenter methodsFor: 'api - showing' stamp: ''!
openDialogWithSpecParent: aWindow
	"Open dialog in a non-modal way, centering on parent window. "
	
	parentWindow := aWindow.
	^ self openDialogWithSpec! !

!SpDialogPresenter methodsFor: 'private' stamp: ''!
accept

	self window 
		beOk; 
		triggerOkAction;
		close! !

!SpDialogPresenter methodsFor: 'api - events' stamp: ''!
onCancel: aBlock
	"When the dialog is cancelled, it executes this action before close.
	 `aBlock` receives one argument (this dialog)"

	cancelAction := aBlock! !

!SpDialogPresenter methodsFor: 'accessing' stamp: ''!
parentWindow: aWindowPresenter

	parentWindow := aWindowPresenter! !

!SpDialogPresenter methodsFor: 'private' stamp: ''!
defaultIcon

	^ self application iconNamed: #question! !

!SpDialogPresenter methodsFor: 'api - showing' stamp: ''!
openModalWithSpecParent: aWindow
	"Open dialog in a modal way, centering on parent window. "

	parentWindow := aWindow.
	^ self openModalWithSpec! !

!SpDialogPresenter methodsFor: 'accessing' stamp: ''!
icon: aForm

	image ifNotNil: [ image image: aForm ]! !

!SpDialogPresenter class methodsFor: 'accessing' stamp: ''!
defaultCancelLabel

	^ 'Cancel'! !

!SpDialogPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentSectionFactoryMethod: aBuilder
	| selector |

	selector := self documentFactoryMethodSelector. 
	selector ifNil: [ ^ self ].
	 
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Factory method' ] withLevel: 2.
	aBuilder newLine.
	aBuilder text: 'You can open '. 
	aBuilder monospace: self name. 
	aBuilder text: ' dialogs in your presenters by sending '.
	aBuilder monospace: 'SpApplication>>#', selector.
	aBuilder text: '.'! !

!SpDialogPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector
	
	^ nil! !

!SpDialogPresenter class methodsFor: 'documentation' stamp: ''!
documentExampleCode
	| exampleMethod |
	
	exampleMethod := self class methods 
		detect: [ :each | 
			(each protocol = #example) 
			and: [ each selector = #exampleModal ] ]
		ifNone: [ ^ nil ].
			
	^ (exampleMethod sourceCode lines 
		allButFirst 	"Remove method name"
		reject: [ :each | each trimLeft beginsWith: '<' ]) "Remove pragmas"
		asStringWithCr
		trimmed! !

!SpDialogPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentSectionExampleCode: aBuilder
	| exampleCode |

	exampleCode := self documentExampleCode. 
	exampleCode ifNil: [ ^ self ].
	
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Example code' ] withLevel: 2.
	aBuilder newLine.
	aBuilder codeblock: exampleCode! !

!SpDialogPresenter class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	
	^ self new openWithSpec! !

!SpDialogPresenter class methodsFor: 'instance creation' stamp: ''!
openDialog
	<script>
	
	^ self new openDialogWithSpec! !

!SpDialogPresenter class methodsFor: 'documentation' stamp: ''!
documentSections
		
	^ OrderedDictionary newFromPairs: {
		'API Show Methods'. self methods select: [ :each | each protocol = #'api - showing' ].
		'API Methods'. self methods select: [ :each | each protocol = #'api' ].
		'Testing Methods'. self methods select: [ :each | each protocol = #'testing' ].
		'Events'. self methods select: [ :each | each protocol = #'api - events' ].
	}! !

!SpDialogPresenter class methodsFor: 'instance creation' stamp: ''!
openModal
	<script>

	^ self new openModalWithSpec! !

!SpDialogPresenter class methodsFor: '*Spec2-Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	super buildMicroDownUsing: aBuilder withComment: aString.
	"Example code"
	self addDocumentSectionExampleCode: aBuilder.
	"Factory method"
	self addDocumentSectionFactoryMethod: aBuilder.
	"Sections"
	self documentSections keysAndValuesDo: [ :label :methods |
		self addDocumentSection: aBuilder label: label methods: methods ].
	"Hierarchy"
	"self addDocumentSectionHierarchy: aBuilder."
! !

!SpDialogPresenter class methodsFor: 'accessing' stamp: ''!
defaultAcceptLabel

	^ 'Accept'! !

!SpDialogPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentSection: aBuilder label: label methods: methods
	
	methods ifEmpty: [ ^ self ].
	
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: label ] withLevel: 2.
	aBuilder unorderedListDuring: [  
		(methods sorted: #selector ascending) do: [ :each |
			aBuilder item: [
				aBuilder monospace: (each methodClass name, '>>#', each selector) ] ] ]! !

!SpDialogWindow commentStamp: ''!
A SpecDialogWindow is a window made for embedding Spec models into dialog windows
!
!SpDialogWindow methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self beResizeable! !

!SpDialogWindow methodsFor: 'open/close' stamp: ''!
initialExtent 

	^ self model
		ifNil: [ super initialExtent ]
		ifNotNil: [:m | m initialExtent
						ifNil: [ super initialExtent ]]! !

!SpDialogWindow methodsFor: 'protocol' stamp: ''!
setToolbarFrom: aBlock
	| newToolbar |
	
	newToolbar := aBlock value.
	self toolbar: newToolbar! !

!SpDialogWindow methodsFor: 'accessing' stamp: ''!
toolbar
	"Lazy initialization because this method is called efore the initialize method"
	
	^ toolbar! !

!SpDialogWindow methodsFor: 'focus' stamp: ''!
giveFocusToNextFrom: aModel 

	^ self model giveFocusToNextFrom: aModel ! !

!SpDialogWindow methodsFor: 'protocol' stamp: ''!
cancelAction: aBlock

	self toolbar cancelAction: aBlock ! !

!SpDialogWindow methodsFor: 'actions' stamp: ''!
escapePressed

	self model triggerCancelAction! !

!SpDialogWindow methodsFor: 'focus' stamp: ''!
giveFocusToPreviousFrom: aModel 

	^ self model giveFocusToPreviousFrom: aModel! !

!SpDialogWindow methodsFor: 'accessing' stamp: ''!
newButtonRow

	^ self toolbar ifNotNil: [ : t | t buildWithSpec ]! !

!SpDialogWindow methodsFor: 'protocol' stamp: ''!
okAction: aBlock

	self toolbar okAction: aBlock ! !

!SpDialogWindow methodsFor: 'accessing' stamp: ''!
toolbar: anObject
	| content |
	
	toolbar := anObject.
	self removeMorph: (content := self submorphs last).
	self 
		addMorph: (self newDialogPanel 
			addMorphBack: content; 
			addMorphBack: self newButtonRow; 
			yourself) 
		frame: (0 @ 0 corner: 1 @ 1)! !

!SpDialogWindow methodsFor: 'protocol' stamp: ''!
cancelled

	^ self toolbar cancelled! !

!SpDialogWindow methodsFor: 'actions' stamp: ''!
addInitialPanel
	"Do nothing here because Spec will take care of adding the content"! !

!SpDialogWindowPresenter commentStamp: ''!
I'm a presenter used to describe a DialogWindow. 
Pay attention that it will not create a real modal in the sense that the user will keep the focus on other windows.

Usually instances of `SpDialogWindowPresenter` are created using the method `SpAbstractPresenter>>#openDialogWithSpec`.

If you want to make the user focus only on your dialog you should use `SpAbstractPresenter>>#openModalWithSpec` instead.

Canonical actions can be parameterized using the methods: `SpDialogWindowPresenter>>#cancelAction:` and `SpDialogWindowPresenter>>#okAction:`. 

## Usage 
Typically, you do not instantiate directly a dialog, but you open a presenter as one.

```
SomePresenter >> open
	^ self openDialogWithSpec
		okAction: [ self accept ];
		cancelAction: [ self cancel ];
		yourself
```
And to control how the dialog should behave, you define the method `initializeDialogWindow:` in your presenters.

```
SomePresenter >> initializeDialogWindow: aDialogPresenter 
	super initializeDialogWindow: aDialogPresenter.
	aDialogPresenter
		initialExtent: 600@400;
		title: 'A title'	
```!
!SpDialogWindowPresenter methodsFor: 'api' stamp: ''!
beOk
	"Set the status of this dialog as 'Ok'. 
	 See `SpDialogWindowPresenter>>#isOk`"

	cancelled := false! !

!SpDialogWindowPresenter methodsFor: 'private' stamp: ''!
addButton: aButtonPresenter

	buttons add: aButtonPresenter.
	^ aButtonPresenter! !

!SpDialogWindowPresenter methodsFor: 'api' stamp: ''!
beCancel
	"Set the status of this dialog as 'cancelled'. 
	 See `SpDialogWindowPresenter>>#isCancelled`"

	cancelled := true! !

!SpDialogWindowPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	buttons := OrderedCollection new.
	cancelled := true.
	self initializeDefaultActions! !

!SpDialogWindowPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow
		
	super initializeWindow.
	self presenter initializeDialogWindow: self! !

!SpDialogWindowPresenter methodsFor: 'testing' stamp: ''!
isDialog

	^ true! !

!SpDialogWindowPresenter methodsFor: 'testing' stamp: ''!
isOk
	"Answer true if dialog has been accepted."

	^ self isCancelled not! !

!SpDialogWindowPresenter methodsFor: 'private' stamp: ''!
executeDefaultAction

	defaultButton ifNil: [ ^ self ].
	defaultButton action cull: self! !

!SpDialogWindowPresenter methodsFor: 'api' stamp: ''!
triggerCancelAction
	"Trigger defined cancel action. 
	 See `SpDialogWindowPresenter>>#cancelAction:`"
	
	cancelAction ifNil: [ ^ self ].
	cancelAction cull: self! !

!SpDialogWindowPresenter methodsFor: 'api' stamp: ''!
cancelAction
	"Answer the defined cancel action (the one that is executed when pressed 'cancel' button 
	 by default). In initialization phase, cancel action is defined as: 
	 ``` 
	self cancelAction: [ 
		cancelled := true.
		self close ]
	```
	(but it can be redefined by the user)"

	^ cancelAction! !

!SpDialogWindowPresenter methodsFor: 'api' stamp: ''!
cancelAction: aBlock
	"Set the action to execute when 'cancel' button is pressed."

	cancelAction := aBlock! !

!SpDialogWindowPresenter methodsFor: 'api' stamp: ''!
okAction
	"Answer the defined ok action (the one that is executed when pressed 'ok' button 
	 by default). In initialization phase, ok action is defined as: 
	 ``` 
	self okAction: [ 
		cancelled := false.
		self close ]
	```
	(but it can be redefined by the user)"

	^ okAction! !

!SpDialogWindowPresenter methodsFor: 'api' stamp: ''!
buttons 
	"Answer an OrderedCollection that contains all defined buttons. 
	 Default action will always be the last one."
	
	self flag: #TODO. "Default action should be configurable, not the last action defined."
	
	^ buttons ! !

!SpDialogWindowPresenter methodsFor: 'initialization' stamp: ''!
initializeDefaultActions
	"default ok/cancel actions. 
	 this is just for backwards compatibility"
	self okAction: [ 
		cancelled := false.
		self close ].
	self cancelAction: [ 
		cancelled := true.
		self close ]! !

!SpDialogWindowPresenter methodsFor: 'testing' stamp: ''!
isCancelled
	"Answer true if dialog has been cancelled."

	^ cancelled! !

!SpDialogWindowPresenter methodsFor: 'api' stamp: ''!
okAction: aBlock
	"Set the action to execute when 'ok' button is pressed."

	okAction := aBlock! !

!SpDialogWindowPresenter methodsFor: 'api' stamp: ''!
addButton: aString do: aBlock
	"Adds button logic to dialog.
	 This method will add a standard button to the button bar of the dialog, having `aString` 
	 as label and executing `aBlock` when pressed. 
	 `aBlock` receives this dialog as an optional argument.
	 This methods answers the added button presenter, to allow more specific/non standard  
	 definitions.
	 See `SpAbstractPresenter>>#initializeDialogWindow:` as an example of usage."
	
	^ self addButton: (SpButtonPresenter new 
		owner: self;
		label: aString;
		action: [ aBlock cull: self ];
		yourself)! !

!SpDialogWindowPresenter methodsFor: 'testing' stamp: ''!
cancelled
	"Answer true if dialog has been cancelled. 
	 This is a synonym of `SpDialogWindowPresenter>>#cancelled`"

	^ cancelled! !

!SpDialogWindowPresenter methodsFor: 'api' stamp: ''!
triggerOkAction
	"Trigger defined ok action. 
	 See `SpDialogWindowPresenter>>#okAction:`"

	okAction ifNil: [ ^ self ].
	okAction cull: self! !

!SpDialogWindowPresenter methodsFor: 'private - traversing' stamp: ''!
traverseInFocusOrderDo: aBlock excluding: excludes

	super traverseInFocusOrderDo: aBlock excluding: excludes.
	self buttons do: [ :each |
		each traverseInFocusOrderDo: aBlock excluding: excludes ]	! !

!SpDialogWindowPresenter methodsFor: 'NOTUSED' stamp: ''!
addDefaultButton: aString do: aBlock
	"Adds button logic to dialog."
	
	defaultButton := self addButton: aString do: aBlock.
	defaultButton addStyle: 'default'.
	^ defaultButton! !

!SpDialogWindowPresenter methodsFor: 'private' stamp: ''!
addDefaultButton: aButtonPresenter
	"Adds button logic to dialog."
	
	defaultButton := self addButton: aButtonPresenter.
	defaultButton addStyle: 'default'.
	^ defaultButton! !

!SpDialogWindowPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #DialogWindowAdapter! !

!SpDiffPresenter commentStamp: ''!
I am a Spec widget useful for visualising differences between two strings.

When a classContext: is setted, the strings are highlighted using such contextual information.

Examples:

self exampleWithoutOptions.
self exampleWithOptions.!
!SpDiffPresenter methodsFor: 'accessing' stamp: ''!
rightLabel: anObject
	rightLabel := anObject! !

!SpDiffPresenter methodsFor: 'accessing' stamp: ''!
rightText: anObject
	rightText := anObject! !

!SpDiffPresenter methodsFor: 'api' stamp: ''!
beWrapped

	^ beWrapped! !

!SpDiffPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	leftText := ''.
	rightText := ''.
	showOptions := true.
	showOnlyDestination := false.
	showOnlySource := false.
	beWrapped := true.

	self property: #beWrapped whenChangedDo: [ :aBoolean | self changed: #beWrapped: with: {aBoolean} ].
	self property: #leftText whenChangedDo: [ :newText | self changed: #leftText: with: {newText} ].
	self property: #rightText whenChangedDo: [ :newText | self changed: #rightText: with: {newText} ].
	self property: #contextClass whenChangedDo: [ :newClass | self changed: #contextClass: with: {newClass} ].
	self property: #showOptions whenChangedDo: [ :aBoolean | self changed: #showOptions: with: {aBoolean} ].
	self property: #showOnlyDestination whenChangedDo: [ :aBoolean | self changed: #showOnlyDestination: with: {aBoolean} ].
	self property: #showOnlySource whenChangedDo: [ :aBoolean | self changed: #showOnlySource: with: {aBoolean} ].
	self property: #leftLabel whenChangedDo: [ :newText | self changed: #leftLabel: with: {newText} ].
	self property: #rightLabel whenChangedDo: [ :newText | self changed: #rightLabel: with: {newText} ]! !

!SpDiffPresenter methodsFor: 'api' stamp: ''!
showBoth
	self property: #showOnlySource rawValue: false.
	self property: #showOnlyDestination rawValue: false.
	self changed: #showBoth with: {}! !

!SpDiffPresenter methodsFor: 'accessing' stamp: ''!
rightLabel
	^ rightLabel! !

!SpDiffPresenter methodsFor: 'accessing' stamp: ''!
contextClass
	^ contextClass! !

!SpDiffPresenter methodsFor: 'accessing' stamp: ''!
leftLabel
	^ leftLabel! !

!SpDiffPresenter methodsFor: 'api' stamp: ''!
showOptions: aBoolean
	showOptions := aBoolean! !

!SpDiffPresenter methodsFor: 'accessing' stamp: ''!
leftLabel: anObject
	leftLabel := anObject! !

!SpDiffPresenter methodsFor: 'api' stamp: ''!
showOptions
	^ showOptions! !

!SpDiffPresenter methodsFor: 'api' stamp: ''!
beWrapped: aBoolean

	beWrapped := aBoolean! !

!SpDiffPresenter methodsFor: 'undo-redo' stamp: ''!
clearUndoManager
	"The diff presenter does not allow edition, it does not have undo history. But this message is added to have polimorphism in the Message Browser"! !

!SpDiffPresenter methodsFor: 'api' stamp: ''!
showOnlyDestination: aBoolean
	showOnlyDestination := aBoolean! !

!SpDiffPresenter methodsFor: 'api' stamp: ''!
showOnlyDestination
	^ showOnlyDestination! !

!SpDiffPresenter methodsFor: 'api' stamp: ''!
showOnlySource
	^ showOnlySource! !

!SpDiffPresenter methodsFor: 'accessing' stamp: ''!
leftText
	^ leftText! !

!SpDiffPresenter methodsFor: 'accessing' stamp: ''!
rightText
	^ rightText! !

!SpDiffPresenter methodsFor: 'api' stamp: ''!
showOnlySource: aBoolean
	showOnlySource := aBoolean! !

!SpDiffPresenter methodsFor: 'accessing' stamp: ''!
leftText: anObject
	leftText := anObject! !

!SpDiffPresenter methodsFor: 'accessing' stamp: ''!
contextClass: anObject
	contextClass := anObject! !

!SpDiffPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithoutOptions
	"
	self exampleWithoutOptions
	"
	<sampleInstance>
	
	^ self new
		showOptions: false;
		leftText: 'Old text';
		rightText: 'New text';
		openWithSpec
! !

!SpDiffPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #DiffAdapter! !

!SpDiffPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithOptions
	"
	self exampleWithOptions
	"
	<sampleInstance>
	^ self new
		showOptions: true;
		leftText: (True >> #and:) sourceCode;
		rightText: (True >> #or:) sourceCode;
		contextClass: True;
		openWithSpec! !

!SpDirectionableLayout commentStamp: ''!
I'm just an intermediary class offering handy initialization methods such as `beTopToBottom` and `beLeftToRight`.!
!SpDirectionableLayout methodsFor: 'initialization - deprecated' stamp: ''!
beHorizontal
	"Avoid to use me and favor beLeftToRight and is a lot cooler."
	direction := SpLayoutDirection horizontal! !

!SpDirectionableLayout methodsFor: 'initialization' stamp: ''!
beLeftToRight

	direction := SpLayoutDirection horizontal! !

!SpDirectionableLayout methodsFor: 'initialization' stamp: ''!
beTopToBottom

	direction := SpLayoutDirection vertical! !

!SpDirectionableLayout methodsFor: 'initialization - deprecated' stamp: ''!
beVertical
	"Avoid to use me and favor beTopToBottom and is a lot cooler."
	
	direction := SpLayoutDirection vertical! !

!SpDirectionableLayout class methodsFor: 'instance creation' stamp: ''!
new 

	^ super new beVertical! !

!SpDirectionableLayout class methodsFor: 'instance creation' stamp: ''!
newVertical 

	^ self newTopToBottom ! !

!SpDirectionableLayout class methodsFor: 'instance creation' stamp: ''!
newTopToBottom

	^ super new beVertical! !

!SpDirectionableLayout class methodsFor: 'instance creation' stamp: ''!
newLeftToRight

	^ super new beHorizontal! !

!SpDirectionableLayout class methodsFor: 'instance creation' stamp: ''!
newHorizontal

	^ self newLeftToRight! !

!SpDocumentHierarchyBuilder commentStamp: ''!
Create a hierarchy tree to show in microdown documentation.
This builder allows you to create the nice hierarchy you can see at `SpAbstractWidgetPresenter` class comment (in hierarchy section).

## Example
```Smalltalk
SpDocumentHierarchyBuilder new
	"The class where to start the hierarchy (a superclass of aClass)"
	fromClass: aTopClass;
	"The microdown builder" 
	builder: aBuilder;	
	"A filter to make sure we include classes we want in hierarchy" 
	filter: [ :eachClass | eachClass package packageName beginsWith: 'Spec2-' ]; 
	"Build the hierarchy for the class aClass"
	buildFor: aClass
```!
!SpDocumentHierarchyBuilder methodsFor: 'building' stamp: ''!
buildStringFor: aClass
	
	self fillTreeOf: aClass.
	^ String streamContents: [ :stream |
		self 
			addLevel: 0
			from: SpAbstractPresenter 
			to: (ZnNewLineWriterStream on: stream) ]! !

!SpDocumentHierarchyBuilder methodsFor: 'accessing' stamp: ''!
fromClass: aClass

	fromClass := aClass! !

!SpDocumentHierarchyBuilder methodsFor: 'accessing' stamp: ''!
builder: aBuilder

	builder := aBuilder! !

!SpDocumentHierarchyBuilder methodsFor: 'private' stamp: ''!
addLevel: level from: aClass to: stream
	"'├ ─ ╰ │'"
	| path |

	path := (aClass allSuperclasses copyUpTo: self topClass) reversed.
	
	path do: [ :each |
		stream << ((self isPassingThrough: aClass topLevel: each)
			ifTrue: [  '│ ' ]
			ifFalse: [ '  ' ]) ].
		
	level > 0 ifTrue: [ 
		| list |
		list := flattenTree at: aClass superclass ifAbsent: [ #() ].
		list ifNotEmpty: [ 
			(list size = 1 or: [ list last = aClass ])
				ifTrue: [ stream << '╰─ ' ]
				ifFalse: [ stream << '├─ ' ] ] ].

	stream << aClass name.
	stream newLine.
	(flattenTree at: aClass) do: [ :each |
		self 
			addLevel: level + 1 
			from: each 
			to: stream ]! !

!SpDocumentHierarchyBuilder methodsFor: 'private' stamp: ''!
fillTreeOf: aClass

	class := aClass.
	flattenTree := OrderedDictionary new.
	self fillTreeWithSuperclassesOf: aClass.
	self fillTreeWithSubclassesOf: aClass.
	
	^ flattenTree! !

!SpDocumentHierarchyBuilder methodsFor: 'private' stamp: ''!
fillTreeWithSubclassesOf: aClass
		
	flattenTree at: aClass put: (self applyFilterTo: aClass subclasses).
	aClass subclasses do: [ :each |
		self fillTreeWithSubclassesOf: each ]! !

!SpDocumentHierarchyBuilder methodsFor: 'accessing' stamp: ''!
filter: aBlock

	filterBlock := aBlock! !

!SpDocumentHierarchyBuilder methodsFor: 'private' stamp: ''!
applyFilterTo: aCollection

	filterBlock ifNil: [ ^ aCollection ].
	^ aCollection select: filterBlock! !

!SpDocumentHierarchyBuilder methodsFor: 'private' stamp: ''!
fillTreeWithSuperclassesOf: aClass
	| superclasses |

	superclasses := (aClass allSuperclasses copyUpTo: self topClass) reversed.
	superclasses do: [ :each | 
		flattenTree 
			at: each 
			put: { (superclasses 
				after: each
				ifAbsent: [ aClass ]) } ].
	! !

!SpDocumentHierarchyBuilder methodsFor: 'accessing' stamp: ''!
topClass

	^ topClass ifNil: [ self fromClass superclass ]! !

!SpDocumentHierarchyBuilder methodsFor: 'building' stamp: ''!
buildFor: aClass

	self fillTreeOf: aClass.
	self 
		addLevel: 0
		from: self fromClass! !

!SpDocumentHierarchyBuilder methodsFor: 'accessing' stamp: ''!
topClass: aClass

	topClass := aClass! !

!SpDocumentHierarchyBuilder methodsFor: 'accessing' stamp: ''!
fromClass

	 ^  fromClass ifNil: [ SpAbstractPresenter ]! !

!SpDocumentHierarchyBuilder methodsFor: 'testing' stamp: ''!
isPassingThrough: aClass topLevel: aTopClass
	| superclasses |
	
	superclasses := flattenTree at: aTopClass superclass ifAbsent: [ #() ].
	superclasses size <= 1 ifFalse: [ 
		^ (superclasses indexOf: aTopClass) < superclasses size ].
	
	^ false! !

!SpDocumentHierarchyBuilder methodsFor: 'private' stamp: ''!
addLevel: level from: aClass
	"'├ ─ ╰ │'"
	| path |

	path := (aClass allSuperclasses copyUpTo: self topClass) reversed.
	
	builder monospace: '  '.
	
	path do: [ :each |
		builder monospace: ((self isPassingThrough: aClass topLevel: each)
			ifTrue: [  '│ ' ]
			ifFalse: [ '  ' ]) ].
		
	level > 0 ifTrue: [ 
		| list |
		list := flattenTree at: aClass superclass ifAbsent: [ #() ].
		list ifNotEmpty: [ 
			builder monospace: ((list size = 1 or: [ list last = aClass ])
				ifTrue: [ '╰─ ' ]
				ifFalse: [ '├─ ' ]) ] ].

	builder monospace: aClass name.
	aClass = class 
		ifTrue: [ builder monospace: ' (this is me)' ].
	builder newLine.
	(flattenTree at: aClass) do: [ :each |
		self 
			addLevel: level + 1 
			from: each ]! !

!SpDragAndDropTransfer methodsFor: 'accessing' stamp: ''!
passenger: anObject

	passenger := anObject! !

!SpDragAndDropTransfer methodsFor: 'accessing' stamp: ''!
passenger

	^ passenger! !

!SpDragAndDropTransferToList methodsFor: 'accessing' stamp: ''!
index: anInteger

	index := anInteger! !

!SpDragAndDropTransferToList methodsFor: 'accessing' stamp: ''!
index

	^ index! !

!SpDragAndDropTransferToTable methodsFor: 'accessing' stamp: ''!
row

	^ row! !

!SpDragAndDropTransferToTable methodsFor: 'accessing' stamp: ''!
row: anInteger

	row := anInteger! !

!SpDragAndDropTransferToTable methodsFor: 'accessing' stamp: ''!
column

	^ column! !

!SpDragAndDropTransferToTable methodsFor: 'accessing' stamp: ''!
column: anInteger

	column := anInteger! !

!SpDragAndDropTransferToTree methodsFor: 'accessing' stamp: ''!
target

	^ target! !

!SpDragAndDropTransferToTree methodsFor: 'accessing' stamp: ''!
target: anObject

	target := anObject! !

!SpDrawStyle commentStamp: ''!
!! Draw property (`SpDrawStyle`)

Draw properties control how the component (morph) will be draw.
I keep this properties: 

- color: foreground color for the morph if it applies (if the morph understands #color:).
- backgroundColor: background color if it applies (if the morph understands #backgroundColor:).

See `SpDrawStyle>>#color` and `SpDrawStyle>>#backgroundColor`

## Usage
The identifier of draw in the stylesheet is `Draw`.

```
Draw { 
	#color: #red,
	#backgroundColor: '00FF00'
}
```!
!SpDrawStyle methodsFor: 'accessing' stamp: ''!
color: aColorOrSymbol

	color := aColorOrSymbol asStyleVariable! !

!SpDrawStyle methodsFor: 'accessing' stamp: ''!
backgroundColor
  "This property can be expressed as 
	- a STON map: ==Color { #red : 1., #green : 0, #blue : 0, #alpha : 1 }==
	- a named selector: ==#red==
	- an hex string: =='FF0000'=="

	^ self backgroundColorVariable value! !

!SpDrawStyle methodsFor: 'accessing' stamp: ''!
backgroundColor: aColorOrSymbol

	backgroundColor := aColorOrSymbol asStyleVariable! !

!SpDrawStyle methodsFor: 'accessing - variables' stamp: ''!
backgroundColorVariable
  "This property can be expressed as 
	- a STON map: ==Color { #red : 1., #green : 0, #blue : 0, #alpha : 1 }==
	- a named selector: ==#red==
	- an hex string: =='FF0000'=="

	^ self toVariable: backgroundColor! !

!SpDrawStyle methodsFor: 'accessing - variables' stamp: ''!
colorVariable
  "This property can be expressed as 
	- a STON map: ==Color { #red : 1., #green : 0, #blue : 0, #alpha : 1 }==
	- a named selector: ==#red==
	- an hex string: =='FF0000'=="

	^ self toVariable: color! !

!SpDrawStyle methodsFor: 'operations' stamp: ''!
applyTo: aMorph 

	self color ifNotNil: [ :aColor | aMorph color: aColor asStyleVariable valueAsColor ].
	self backgroundColor ifNotNil: [ :aColor |
		"hack to be able to decorate components that does not understand 
		 backgroundColor" 
		(aMorph respondsTo: #backgroundColor:)
			ifTrue: [ aMorph backgroundColor: aColor asStyleVariable valueAsColor ]
			ifFalse: [ aMorph fillStyle: aColor asStyleVariable valueAsColor ] ]! !

!SpDrawStyle methodsFor: 'accessing' stamp: ''!
color
  "This property can be expressed as 
	- a STON map: ==Color { #red : 1., #green : 0, #blue : 0, #alpha : 1 }==
	- a named selector: ==#red==
	- an hex string: =='FF0000'=="

	^ self colorVariable value! !

!SpDrawStyle class methodsFor: 'ston-core' stamp: ''!
stonName

	^ 'Draw'! !

!SpDrawStyleTest methodsFor: 'tests' stamp: ''!
testToColor
	| style |
	
	style := SpDrawStyle new.
	self assert: (style toColor: #FF0000) equals: Color red.
	self assert: (style toColor: #'00FF00FF') equals: Color green.
	self assert: (style toColor: #blue) equals: Color blue! !

!SpDropListAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpDropListPresenter ! !

!SpDropListAdapterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 
	
	super initializeTestedInstance.
	presenter items: #(10 20 30).! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testSelectionStartsSelectingFirst

	self assert: self presenter selectedItem equals: 10.
	self assert: self adapter selectedIndexes equals: #(1).
	! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testResetingSelectionResetsSelection
	self presenter selectItem: 10.

	self presenter resetSelection.

	self assert: self presenter selectedItem equals: nil.
	self assert: self adapter selectedIndexes isEmpty! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testDoesNotShowIcons

	backendForTest assertIcon: self adapter displayedIcon equals: nil. ! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testSelectingASecondElementSelectsIt
	self presenter selectItem: 10.
	self presenter selectItem: 20.

	self assert: self presenter selectedItem equals: 20.
	self assert: self adapter selectedIndexes equals: #(2)! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testAddingIconsShowTheIcon
	#(pharo add book) do: [ :each | self presenter addItemLabeled: each do: [  ] icon: (self iconNamed: each) ].

	self presenter selectItem: #pharo.

	self assert: self adapter selectedIndexes equals: #(4).
	backendForTest assertIcon: self adapter displayedIcon equals: (self iconNamed: #pharo)! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testSelectingAnElementSelectsIt
	self presenter selectItem: 10.

	self assert: self presenter selectedItem equals: 10.
	self assert: self adapter selectedIndexes equals: #(1)! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testSettingNilResetsGeneratesEvent
	| changed |
	self presenter selectItem: 10.
	self presenter whenSelectionChangedDo: [ changed := true ].
	self presenter selectItem: nil.
	self assert: changed! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testRemovingIconsAfterAddingThem
	#(pharo add book) do: [ :each | self presenter addItemLabeled: each do: [  ] icon: (self iconNamed: each) ].

	self presenter selectItem: nil.
	self presenter model removeAll.

	#(pharo add book) do: [ :each | self presenter addItemLabeled: each do: [  ] icon: nil ].

	self assert: self adapter selectedIndexes equals: #(1).
	backendForTest assertIcon: self adapter displayedIcon equals: nil! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testSettingNilResetsSelection
	self presenter selectItem: 10.
	self presenter selectItem: nil.

	self assert: self presenter selectedItem equals: nil.
	self assert: self adapter selectedIndexes isEmpty! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testSelectingAnElementInWidgetUpdatePresenter

	self adapter selectIndex: 2.

	self assert: self presenter selectedItem equals: 20.
	self assert: self adapter selectedIndexes equals: #(2).
	! !

!SpDropListAdapterTest methodsFor: 'tests' stamp: ''!
testSelectionExecutesBlock
	| selected |
	self presenter
		dropListItems:
			(#(10 20 30)
				collect: [ :e | 
					SpDropListItem
						on: e
						do: [ selected := e ] ]).

	self presenter selectItem: 20.
	self assert: selected equals: 20! !

!SpDropListExample commentStamp: ''!
A DropListExample is a simple example of how to use drop lists.

self example!
!SpDropListExample methodsFor: 'initialization' stamp: ''!
setFocus
	
	self focusOrder
		add: uniformDropList;
		add: heterogeneousDropList;
		add: disabledDropList.
	! !

!SpDropListExample methodsFor: 'accessing' stamp: ''!
heterogeneousDropList
	^ heterogeneousDropList! !

!SpDropListExample methodsFor: 'accessing' stamp: ''!
disabledDropList
	^ disabledDropList! !

!SpDropListExample methodsFor: 'accessing' stamp: ''!
uniformDropList

	^ uniformDropList! !

!SpDropListExample methodsFor: 'accessing' stamp: ''!
container
	^ container! !

!SpDropListExample methodsFor: 'initialization' stamp: ''!
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.! !

!SpDropListExample methodsFor: 'initialization' stamp: ''!
initializePresenters
	uniformDropList := self newDropList.
	heterogeneousDropList := self newDropList.
	container := self newMorph.
	disabledDropList := self newDropList.
	container morph: PanelMorph new.
	self instantiateMorphs.
	self containerMorph
		changeTableLayout;
		listDirection: #bottomToLeft.
	disabledDropList
		items: #('Disabled' 'Two' 'Three');
		display: [ :each | each ];
		disable.
	uniformDropList
		items:
			{morph1.
			morph2.
			morph3};
		display: [ :m | m color name capitalized , ' morph' ];
		iconBlock: [ :e | self iconNamed: #testGreenIcon ];
		whenSelectedItemChangedDo: [ :m | 
			self containerMorph
				removeAllMorphs;
				addMorph: m ].
	heterogeneousDropList
		addItemLabeled: 'Open workspace'
			do: [ Smalltalk tools workspace open ]
			icon: (self iconNamed: #smallOkIcon);
		addItemLabeled: 'Inspect current morph'
			do: [ uniformDropList selectedItem inspect ]
			icon: (self iconNamed: #testRedIcon).

	"If this is uncommented, it will fire the action of the first item, which is not what we want:
	heterogeneousDropList setSelectedIndex: 1.
	same for:
	heterogeneousDropList setIndex: 1"
	uniformDropList selectIndex: 1.
	self setFocus! !

!SpDropListExample methodsFor: 'initialization' stamp: ''!
containerMorph
	^ container morph! !

!SpDropListExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #uniformDropList;
				add: #heterogeneousDropList;
				yourself)
			height: self toolbarHeight;
		add: #disabledDropList height: self toolbarHeight;
		add: #container;
		yourself! !

!SpDropListExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	
	^ self new openWithSpec! !

!SpDropListExample class methodsFor: 'specs' stamp: ''!
title

	^ 'Drop list'! !

!SpDropListExampleTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpDropListExample! !

!SpDropListItem commentStamp: ''!
A DropListItem is an item (wrapper) designed to fit into a DropList.!
!SpDropListItem methodsFor: 'protocol' stamp: ''!
action: aBlock
	action := aBlock! !

!SpDropListItem methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].
	^ self label = anObject label and: [ action = anObject action ]! !

!SpDropListItem methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	action := [  ].
	displayBlock := [ :e | e asString ]! !

!SpDropListItem methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ self label hash bitXor: action hash! !

!SpDropListItem methodsFor: 'accessing' stamp: ''!
label: anObject
	"For compatibility with old raw-string usage. Send #display: instead"
	
	displayBlock := [ anObject ]! !

!SpDropListItem methodsFor: 'protocol' stamp: ''!
action
	^ action! !

!SpDropListItem methodsFor: 'protocol' stamp: ''!
display: aBlock
	"Set the block whose execution should return the string to be displayed. 
	aBlock will be executed with an optional argument, which is the underlying item."

	displayBlock := aBlock.! !

!SpDropListItem methodsFor: 'execution' stamp: ''!
value
	"This way, I am polymorphic with nil"

	self action cull: self label cull: self! !

!SpDropListItem methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!SpDropListItem methodsFor: 'private' stamp: ''!
model: anObject

	model := anObject! !

!SpDropListItem methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!SpDropListItem methodsFor: 'accessing' stamp: ''!
icon: anObject
	icon := anObject! !

!SpDropListItem methodsFor: 'accessing' stamp: ''!
label
	
	^ displayBlock cull: model! !

!SpDropListItem class methodsFor: 'instance creation' stamp: ''!
named: label do: aBlock

	^ self new
		action: aBlock;
		model: label;
		display: [ :e | e ];
		yourself! !

!SpDropListItem class methodsFor: 'instance creation' stamp: ''!
on: anObject do: aBlock

	^ self new
		action: aBlock;
		model: anObject;
		yourself! !

!SpDropListMorph commentStamp: ''!
I am a special DropList with icons!
!SpDropListMorph methodsFor: 'private' stamp: ''!
wrapItem: anItem index: anIndex

	^ self model wrapItem: anItem index: anIndex! !

!SpDropListMorph methodsFor: 'private' stamp: ''!
updateListSelectionIndex

	currentIcon ifNotNil: [ self removeMorph: currentIcon ].
		
	super updateListSelectionIndex.
	
	self selectedItem ifNotNil: [ :item | 
		(self getIconFor: item) ifNotNil: [:icon | 
			currentIcon := icon asMorph.
			self addMorphFront: currentIcon ] ] ! !

!SpDropListMorph methodsFor: 'private' stamp: ''!
listMorphClass

	^ PluggableIconListMorph! !

!SpDropListMorph methodsFor: 'drawing' stamp: ''!
newListMorph
	"Answer a new list morph"

	^ (self listMorphClass
		on: self
		list: #list
		selected: #listSelectionIndex
		changeSelected: #listSelectionIndex:
		menu: nil
		keystroke: nil)
			getIconSelector: #getIconFor:;
			autoDeselect: false;
			wrapSelector: #wrapItem:index:;
			roundedCorners: #(2 3);
			setProperty: #morphicLayerNumber toValue: 5;
			borderStyle: (self theme dropListNormalListBorderStyleFor: self);
			on: #mouseDown send: #listMouseDown: to: self;
			yourself! !

!SpDropListMorph methodsFor: 'protocol' stamp: ''!
getIconFor: anItem

	^ self model getIconFor: anItem! !

!SpDropListMorph methodsFor: 'private' stamp: ''!
currentIcon

	^ currentIcon! !

!SpDropListMorph methodsFor: 'configuring' stamp: ''!
configureWith: displayModel item: itemPresenter
	displayModel configureDropList: self item: itemPresenter! !

!SpDropListMorph methodsFor: 'private' stamp: ''!
listHeight
	"Answer the height for the list."

	^ super listHeight + 12! !

!SpDropListPresenter commentStamp: ''!
A presenter to display dropdown lists.

_NOTE: I assume there is a little problem on an empty list, but frankly, who creates an empty drop list?_
!
!SpDropListPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultInputPort

	^ self inputItemsPort! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
addItemLabeled: aString do: aBlock icon: anIcon
	"Add an item to the drop list, along with an icon and an action.
	 `aString` is the label of the element.
	 `aBlock` is the action asociated to this element. It receives zero arguments.
	 `anIcon` is the icon (an instance of `Form`) to be shown."
	| item |

	item := SpDropListItem on: aString do: aBlock.
	item icon: anIcon.

	model add: item.
	"Adding an item adds it to the selection if there is none".
	self selection isEmpty ifTrue: [ 
		self selection selectItem: item ]! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
selectIndex: anInteger 
	"Select the element at position `anInteger` and executes the action associated with it."
	
	self selection selectIndex: anInteger.
	"I execute the block associated with the item"
	self selection selectedItem value! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
display
	"Answer the formatting block to transform how the elements will be displayed. 
	 See also `SpDropListPresenter>>#display:`"
	
	^ displayBlock! !

!SpDropListPresenter methodsFor: 'private' stamp: ''!
getIndex

	^ selection selectedIndex! !

!SpDropListPresenter methodsFor: 'private' stamp: ''!
getIconFor: anItem

	^ self displayIcon cull: anItem model cull: anItem! !

!SpDropListPresenter methodsFor: 'private' stamp: ''!
disableSelectionDuring: aBlock
	| oldSubscriptions holder |
	
	holder := selection observablePropertyNamed: #selectedIndex.
	oldSubscriptions := holder subscriptions.
	holder subscriptions: #().
	aBlock ensure: [ 
		holder subscriptions: oldSubscriptions ]! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
updateItemsKeepingSelection: aCollection
	"Update list items keeping current selection. 
	 WARNING: aCollection must includes the elements selected."
	
	self disableSelectionDuring: [ 
		| item |
		item := self selectedItem.
		self items: aCollection.
		self selectItem: item ]! !

!SpDropListPresenter methodsFor: 'api - events' stamp: ''!
whenSortingBlockChangedDo: aBlock
	"Inform when sorting block has changed.
	 `aBlock` receive 3 optional arguments: 
	 - new value 
	 - old value 
	 - announcement triggered"

	self model whenSortingBlockChangedDo: aBlock! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
sortingBlock
	"Answer the block used to sort the elements of the list."

	^ self model sortingBlock! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
startWithoutSelection
	"Indicate when droplist will start without an element selected."

	startsWithSelection := false! !

!SpDropListPresenter methodsFor: 'testing' stamp: ''!
hasIcons
	"Answer whether the dropdown list will show icons"
	
	^ iconBlock isNotNil and: [ self model collection anySatisfy: [ :e | e icon isNotNil ] ]! !

!SpDropListPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultOutputPort

	^ self outputSelectionPort! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
displayIcon: aBlock	
	"Answer a block that will be used to retrieve the icon to be displayed along with the elements.
	 `aBlock` receives one argument (an element from the list)"
	
	iconBlock := aBlock! !

!SpDropListPresenter methodsFor: 'private' stamp: ''!
getList

	^ model items! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
iconBlock 
	"Answer the block that will be used to retrieve the icon to be displayed along with the 
	 elements."
	
	self 
		deprecated: 'Please use #displayIcon instead' 
		transformWith:  '`@receiver iconBlock' 
						-> '`@receiver displayIcon'.

	^ iconBlock! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
model
	"Answer the model containing the elements to be shown in the drop down list.
	 Tipically, the model is a collection of `SpDropListItem`."
	
	^ model! !

!SpDropListPresenter methodsFor: 'private' stamp: ''!
dropListItems: dropListItems
	"Populate the drop list with a list DropListItems"
	
	model collection: dropListItems! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
startWithSelection
	"Indicate when drop list will start with an element selected."

	startsWithSelection := true! !

!SpDropListPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
inputItemsPort

	^ SpListItemsPort newPresenter: self! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
emptyList
	"Empty the list of elements used to populate the drop down list."
	
	self resetSelection.
	model collection: OrderedCollection new.
! !

!SpDropListPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	model := SpCollectionListModel on: #().
	selection := SpSingleSelectionMode on: self.
	displayBlock := [ :itemModel :item | item label ].
	iconBlock := [ :itemModel :item | item icon ].
	startsWithSelection := true! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
selectedIndex
	"Answer the index of selected item. 
	 You usually do not need to use this method but `SpDropListPresenter>>#selectedItem`."

	^ self getIndex! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
iconBlock: aBlock	
	"Answer a block that will be used to retrieve the icon to be displayed along with the elements.
	 `aBlock` receives one argument (an element from the list)"
	
	self 
		deprecated: 'Please use #displayIcon: instead' 
		transformWith:  '`@receiver iconBlock: `@arg' 
						-> '`@receiver displayIcon: `@arg'.

	iconBlock := aBlock! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
selectedItem
	"Answer selected item"

	^ self selection selectedItem 
		ifNotNil: [ :anItem | anItem model ]! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
sortingBlock: aBlock
	"Set the block or `SortFunction` used to sort the elements of the list."

	self model sortingBlock: aBlock! !

!SpDropListPresenter methodsFor: 'private' stamp: ''!
displayForItem: anItem
	"The order of the arguments may look weird, but then it seems more natural while using the widget"

	^ self display cull: anItem model cull: anItem! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
listSize
	"Return the size of the list of choices"

	^ self listItems size! !

!SpDropListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectedItemChangedDo: aBlock
	"Inform when the selected item is changed.
	 `aBlock` receive 3 optional arguments: 
	 - new value 
	 - old value 
	 - announcement triggered"

	selection whenChangedDo: [	aBlock cull: self selectedItem ]! !

!SpDropListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionChangedDo: aBlock
	"Inform 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 `SpDropListPresenter>>#whenSelectedItemChanged:`
	
	 `aBlock` receive 3 optional arguments: 
	 - new value 
	 - old value 
	 - announcement triggered"


	selection whenChangedDo: aBlock! !

!SpDropListPresenter methodsFor: 'selection' stamp: ''!
resetSelection
	
	self selection unselectAll ! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
selection
	"Answer selection model, an instance of `SpSingleSelectionMode`."
	
	^ selection! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
display: aBlock
	"Set the formatting block to transform how the elements will be displayed. 
	 `aBlock` receives one argument (the element to be displayed) and it should answer a string.
	 See also `SpDropListPresenter>>#display`"

	displayBlock := aBlock 
! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
addItemLabeled: aString do: aBlock
	"Add an item to the drop list, along with an action.
	 `aString` is the label of the element.
	 `aBlock` is the action asociated to this element. It receives zero arguments."

	self addItemLabeled: aString do: aBlock icon: nil.! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
items: aList
	"Populate the drop list with a list of ui specific items"
	"`aList` is a list of domain specific objects. If you want to specify more precisely the item actions, see `SpDropListPresenter>>#addItemLabeled:do:`"
	| dropListItems |

	"This is a guard, because I need to reset the selection *before* the list is set"
	(aList isEmpty 
		or: [ aList size < self selectedIndex ]) 
		ifTrue: [ self resetSelection ].
	
	dropListItems := aList collect: [ :each | SpDropListItem on: each do: [ ] ].
	model collection: dropListItems.
	(dropListItems isNotEmpty
		and: [ startsWithSelection 
		and: [ self selection isEmpty ] ])
		ifTrue: [ self selectIndex: 1 ]
		ifFalse: [ self resetSelection ]! !

!SpDropListPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
outputSelectionPort

	^ SpDropListSelectionPort newPresenter: self! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
selectItem: anItem 
	"Select the element `anItem` if it is in the list. 
	 It executes the action associated with the item if it is defined."
	| realItem |
	
	anItem ifNil: [ 
		self selection unselectAll. 
		^ self ].
	
	realItem := model collection detect: [ :each | each model = anItem ].
	self selection selectItem: realItem.
	"I execute the block associated with the item"
	realItem value! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
displayIcon
	"Answer the block that will be used to retrieve the icon to be displayed along with the 
	 elements."

	^ iconBlock! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
items 
	"Return the list used to populate the drop list"

	^ self listItems! !

!SpDropListPresenter methodsFor: 'api' stamp: ''!
listItems
	"Return the list used to populate the drop list"
	
	^ self getList collect: [ :e | e model ].! !

!SpDropListPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newDropList! !

!SpDropListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example

	^ (self new 
		help: 'Select the presenter.';
		items: SpPresenter withAllSubclasses;
		display: [ :aClass | aClass name ];
		whenSelectedItemChangedDo: [ :aClass | aClass crTrace ];
		openWithSpec)
		extent: 400@25;
		yourself! !

!SpDropListPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #DropListAdapter! !

!SpDropListPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Drop List'! !

!SpDropListPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpDropListPresenter! !

!SpDropListPresenterTest methodsFor: 'tests' stamp: ''!
testDisableSelectionDuring 
	| changed |

	changed := false.
	presenter items: #($a $b $c).
	presenter selectItem: $a.
	presenter whenSelectionChangedDo: [ changed := true ].
	
	self deny: changed.
	presenter disableSelectionDuring: [ presenter selectItem: $b ].
	self deny: changed. "still not change"
	self assert: presenter selectedItem equals: $b "but the selection changed!!"! !

!SpDropListPresenterTest methodsFor: 'tests' stamp: ''!
testEmptyList
	| changed |

	changed := false.
	presenter items: #($a $b $c).
	presenter selectItem: $a.
	
	[ presenter openWithSpec ] 
	ensure: [ presenter withWindowDo: #close ].
	presenter emptyList.
	
	self assert: presenter items isEmpty.
	self assert: presenter selectedIndex equals: 0	! !

!SpDropListPresenterTest methodsFor: 'tests' stamp: ''!
testUpdateItemsKeepingSelection 

	presenter items: #($a $b $c).
	presenter selectItem: $c.
	presenter updateItemsKeepingSelection: #($c $d $e $f).
	self assert: presenter selectedItem equals: $c! !

!SpDropListPresenterTest methodsFor: 'tests' stamp: ''!
testSortingBlock
	| count |
	count := 0.
	presenter
		whenSortingBlockChangedDo: [ :sortFunction | count := count + 1 ].
	presenter items: #(3 8 1 0).
	presenter sortingBlock: [ :a :b | a model < b model ].
	self assert: count equals: 1.
	self assert: (presenter model at: 1) model equals: 0! !

!SpDropListPresenterTest methodsFor: 'tests' stamp: ''!
testSetItemsWithCollectionSmallerThanSelection
	| changed |

	changed := false.
	presenter items: #($a $b $c).
	presenter selectItem: $c.
	
	[ presenter openWithSpec ] 
	ensure: [ presenter withWindowDo: #close ].
	presenter items: #($a).

	self assert: presenter selectedIndex equals: 1! !

!SpDropListPresenterTest methodsFor: 'tests' stamp: ''!
testSetItemsWithEmptyCollection
	| changed |

	changed := false.
	presenter items: #($a $b $c).
	presenter selectItem: $a.
	
	[ presenter openWithSpec ] 
	ensure: [ presenter withWindowDo: #close ].
	presenter items: #().
	
	self assert: presenter items isEmpty.
	self assert: presenter selectedIndex equals: 0! !

!SpDropListSelectionPort commentStamp: ''!
!! Drop List Selection Output Port (==SpDropListSelectionPort==)
A ""drop list selection output port"" is the same as *class:SpSelectionPort*, but to be used exclusively by *class:SpDropListPresenter*.

The presenter exposing a selection output port need to define also the event ==#whenSelectionChangedDo:==.

Presenters exposing this port: *class:SpDropListPresenter*

@@NOTE Maybe this needs to be merged with SpSelectionPort?!
!SpDropListSelectionPort methodsFor: 'attaching' stamp: ''!
attachTransmission: aTransmission to: aPresenter
	
	aPresenter whenSelectionChangedDo: [ :selection | 
		self 
			transmitWith: aTransmission 
			value: (self applyTransform: selection selectedItem) ]! !

!SpDropListSelectionPort class methodsFor: 'accessing' stamp: ''!
portName
	
	^ #selection! !

!SpDropListWithoutInitialSelectionAdapterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	presenter startWithoutSelection.	
	super initializeTestedInstance.
! !

!SpDropListWithoutInitialSelectionAdapterTest methodsFor: 'tests' stamp: ''!
testSelectionStartsEmptyIfStartWithoutSelectionIsSet

	self assert: self presenter selectedItem equals: nil.
	self assert: self adapter selectedIndexes equals: #().
	! !

!SpDropListWithoutInitialSelectionAdapterTest methodsFor: 'tests' stamp: ''!
testAddingAnItemSelectsItIfThereIsNone

	self presenter addItemLabeled: 40 do: [].

	self assert: self presenter selectedItem equals: 40.
	self assert: self adapter selectedIndexes equals: #(4).
	! !

!SpDualChangeSorterPresenter commentStamp: ''!
A `SpDualChangeSorterPresenter is a dual change sorter. It manages two sets of changes so that we can cherry pick and creates new changes. 

`SpDualChangeSorterPresenter` shares the model between its two subcomponents that are instances of  `SpChangeSorterPresenter`. The class `ChangeSorterModel` defines the application logic.
!
!SpDualChangeSorterPresenter methodsFor: 'menu - class' stamp: ''!
moveClassFrom: src to: dest

	self checkThatSidesDiffer: [^ self].
	(self okToChange and: [ src selectedClass notNil]) ifFalse: [ ^ self ].

	self copyClassFrom: src to: dest.
	src forgetClass! !

!SpDualChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
menusRegistration

	self menusRegistrationFrom: changeSorterLeft to: changeSorterRight.
	self menusRegistrationFrom: changeSorterRight to: changeSorterLeft! !

!SpDualChangeSorterPresenter methodsFor: 'accessing' stamp: ''!
changeSorterRight

	^ changeSorterRight! !

!SpDualChangeSorterPresenter methodsFor: 'menu' stamp: ''!
messageMenuFrom: sourcePanel to: destinationPanel
	"Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter"

	^ sourcePanel messageMenu
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Copy method to the other change set';
						action: [ self copyMethodFrom: sourcePanel to: destinationPanel ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Move method to the other change set';
						action: [ self moveMethodFrom: sourcePanel to: destinationPanel ] ] ];
		yourself! !

!SpDualChangeSorterPresenter methodsFor: 'menu' stamp: ''!
classMenuFrom: sourcePanel to: destinationPanel
	"Fill aMenu with items appropriate for the class list"

	^ sourcePanel classMenu
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Copy class to the other change set';
						action: [ self copyClassFrom: sourcePanel to: destinationPanel ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Move class to the other change set';
						action: [ self moveClassFrom: sourcePanel to: destinationPanel ] ] ];
		yourself! !

!SpDualChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
subtractFrom: src to: dest
	"Subtract the changes found on the other side from the requesting side."
	| source destination |
	source := src selectedChangeSet.
	destination := dest selectedChangeSet.
	
	self checkThatSidesDiffer: [^ self].
	
	self model subtractFrom: source to: destination.
	
	changeSorterRight setSelectedChangeSet: source.! !

!SpDualChangeSorterPresenter methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!SpDualChangeSorterPresenter methodsFor: 'api - window' stamp: ''!
title
	^ String streamContents: [ :stream | stream << self class title << ' on: ' << self model currentChangeSet name ]! !

!SpDualChangeSorterPresenter methodsFor: 'menu - method' stamp: ''!
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 ].! !

!SpDualChangeSorterPresenter methodsFor: 'menu - class' stamp: ''!
copyClassFrom: src to: dest
	"Place these changes in the other changeSet also"

	| otherChangeSet |
	self checkThatSidesDiffer: [ ^ self ].
	self okToChange ifFalse: [ ^ self inform: 'Can''t discard edits.' ].
	src selectedClass ifNil: [ ^ self inform: 'Selected class is nil.' ].
	otherChangeSet := dest selectedChangeSet.
	
	self model copyClass: src selectedClass from: src selectedChangeSet to: otherChangeSet.
	
	dest setSelectedChangeSet: otherChangeSet.! !

!SpDualChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
initialize

	model := ChangeSorterModel new.
	isRefreshing := false.
	super initialize.
	SystemAnnouncer uniqueInstance weak
		when: CurrentChangeSetChanged
		send: #updateTitle
		to: self! !

!SpDualChangeSorterPresenter methodsFor: 'menu - method' stamp: ''!
moveMethodFrom: src to: dest

	self copyMethodFrom: src to: dest.
	src forgetMessage.
	src updateClassesListAndMessagesList.! !

!SpDualChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
setFocusOrder

	self focusOrder
		add: changeSorterLeft;
		add: changeSorterRight.! !

!SpDualChangeSorterPresenter methodsFor: 'api' stamp: ''!
updateTitle
	self window title: self title! !

!SpDualChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
shortcutsRegistrationFrom: src to: dest
	
	src changesPresenterOn: $c meta do: [ self copyAllFrom: src to: dest ].
	src changesPresenterOn: $- meta do: [ self subtractFrom: src to: dest ]. ! !

!SpDualChangeSorterPresenter methodsFor: 'accessing' stamp: ''!
changeSorterLeft

	^ changeSorterLeft! !

!SpDualChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
checkThatSidesDiffer: escapeBlock
	"If the change sets on both sides of the dual sorter are the same, put up an error message and escape via escapeBlock, else proceed happily"

	changeSorterLeft selectedChangeSet == changeSorterRight selectedChangeSet
		ifFalse: [ ^ self ].
	self
		inform:
			'This command requires that the
change sets selected on the two
sides of the change sorter *not*
be the same.'.
	^ escapeBlock value! !

!SpDualChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
shortcutsRegistration

	self shortcutsRegistrationFrom: changeSorterLeft to: changeSorterRight.
	self shortcutsRegistrationFrom: changeSorterRight to: changeSorterLeft.! !

!SpDualChangeSorterPresenter methodsFor: 'menu' stamp: ''!
menusRegistrationFrom: src to: dest
	src changesMenu: (self changeSetMenuFrom: src to: dest).
	src classesMenu: (self classMenuFrom: src to: dest).
	src methodsMenu: (self messageMenuFrom: src to: dest)! !

!SpDualChangeSorterPresenter methodsFor: 'menu' stamp: ''!
changeSetMenuFrom: sourcePanel to: destinationPanel
	"Fill aMenu with items appropriate for the changes list"

	^ sourcePanel changeSetMenu
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Copy all to the other change set';
						shortcut: $s meta;
						action: [ self copyAllFrom: sourcePanel to: destinationPanel ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Submerge into the other change set';
						action: [ self submerge: sourcePanel into: destinationPanel ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Subtract the other change set';
						shortcut: $- meta;
						action: [ self subtractFrom: sourcePanel to: destinationPanel ] ] ];
		yourself! !

!SpDualChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	aWindowPresenter initialExtent: 900 @ 530.
	aWindowPresenter title: self title! !

!SpDualChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
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.! !

!SpDualChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	changeSorterLeft := self instantiate: SpChangeSorterPresenter.
	changeSorterRight := self instantiate: SpChangeSorterPresenter.
		
	self menusRegistration.
	self shortcutsRegistration.
	self setFocusOrder! !

!SpDualChangeSorterPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters

	changeSorterLeft 	whenChangesListChanges: [ self refeshedChangeSet: changeSorterRight ].
	changeSorterRight	whenChangesListChanges: [ self refeshedChangeSet: changeSorterLeft ].

! !

!SpDualChangeSorterPresenter methodsFor: 'event' stamp: ''!
refeshedChangeSet: changeSet
	isRefreshing
		ifTrue: [ ^ self ].
	isRefreshing := true.
	changeSet updateChangesList.
	isRefreshing := false! !

!SpDualChangeSorterPresenter methodsFor: 'menu - change set' stamp: ''!
copyAllFrom: src to: dest

	self checkThatSidesDiffer: [ ^ self ].
	self model copyAllChangesFrom: (src selectedChangeSet) to: (dest selectedChangeSet).
	dest updateClassesList.! !

!SpDualChangeSorterPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	^ SpPanedLayout newLeftToRight
		add: #changeSorterLeft;
		add: #changeSorterRight;
		yourself! !

!SpDualChangeSorterPresenter class methodsFor: 'tools-registry' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]"

	registry register: self as: #changeSorter! !

!SpDualChangeSorterPresenter class methodsFor: 'opening' stamp: ''!
open
	<script>
	
	self new openWithSpec! !

!SpDualChangeSorterPresenter class methodsFor: 'accessing' stamp: ''!
title
	^ 'Dual Change Sorter'! !

!SpDualChangeSorterPresenter class methodsFor: 'icons' stamp: ''!
taskbarIconName
	^ #changeSorterIcon! !

!SpDualChangeSorterPresenter class methodsFor: 'menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	
	(aBuilder group: #SystemChanges)
		parent: #Tools;
		order: 410;
		with: [ 
			(aBuilder item: #'Change Sorter')
				action: [ self open ];
				help: 'Examine the different change set of the image.';
				icon: self taskbarIcon ].
	aBuilder withSeparatorAfter! !

!SpDynamicPresenter commentStamp: ''!
IMPORTANT: This presenter is obsolete since all layouts now are dynaamic. 
This presenter just adds as value the capability to store widgets in a dictionary, which is not really an important need, so we are considering remove it.
Also, it is currently broken.

I'm a CompsableModel with a dynamic behavior for managing subwidgets and the value holder communicates with them.

The idea is that instead of having a fix set of valueHolders controlling various aspects of the model. I have a dictionary to hold such elements.

You can also have a look at DynamicalPopup for an example.

I provide the following variables and its accessors
- layout to put a layout created dynamically.
- widget is a Dictionary containing my dynamics widgets.

I'm specializing
- doesNotUnderstand:  to search in my dictionary before rise an exception, so that the programmer can simply use accessors to access my dynamic elements. 
- openWithSpec to use the layout in my variable if it is not nil.

I provide the following messages
- instantiateModels: to create instances of subwidgets. It takes a collection of pair, first of each pair is the string to use as key in the dictionary, second is the class name to instantiate.
- assign:to: to put in the dictionary a widget already instantiated.

todo
- needFullRebuild:
- retrieveSpec:!
!SpDynamicPresenter methodsFor: 'error handling' stamp: ''!
doesNotUnderstand: aMessage
	"To make sure that we can use accessors to access the dynamically managed subcomponents."

	^ self presenterAt: aMessage selector ifAbsent: [ super doesNotUnderstand: aMessage ]! !

!SpDynamicPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName ifAbsent: aBlock
	^ self basicPresenters
		at: aName
		ifAbsent: [ [ self readSlotNamed: aName ]
				on: SlotNotFound
				do: aBlock ]! !

!SpDynamicPresenter methodsFor: 'api' stamp: ''!
openModalWithSpec

	self layout ifNil: [ ^ super openWithSpec ].
	^ self asModalWindow openWith: self layout! !

!SpDynamicPresenter methodsFor: 'accessing' stamp: ''!
presenters

	^ self basicPresenters values! !

!SpDynamicPresenter methodsFor: 'instance creation' stamp: ''!
instantiatePresenters: aCollectionOfPairs
	aCollectionOfPairs pairsDo: [ :k :v | self presenterAt: k asSymbol put: (self createInstanceFor: v) ]! !

!SpDynamicPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName put: aPresenter

	^ self basicPresenters 
		at: aName 
		put: aPresenter! !

!SpDynamicPresenter methodsFor: 'enumerating' stamp: ''!
presentersDo: aBlock

	self basicPresenters valuesDo: aBlock! !

!SpDynamicPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName

	^ self basicPresenters 
		at: aName 
		ifAbsent: [ self readSlotNamed: aName  ]! !

!SpDynamicPresenter methodsFor: 'private - accessing' stamp: ''!
basicPresenters

	^ presenters ifNil: [ presenters := OrderedDictionary new ]! !

!SpDynamicPresenter methodsFor: 'api' stamp: ''!
retrieveSpec: aSelector

	self layout ifNil: [ ^ super retrieveSpec: aSelector ].

	^ self layout! !

!SpDynamicPresenter methodsFor: 'api' stamp: ''!
openWithSpec

	self layout ifNil: [ ^ super openWithSpec ].
	^ self asWindow openWith: self layout! !

!SpDynamicPresenter methodsFor: 'api' stamp: ''!
needFullRebuild: aBoolean

	self needRebuild: aBoolean.
	self presentersDo: [ :w | w needRebuild: aBoolean ]! !

!SpDynamicPresenter methodsFor: 'instance creation' stamp: ''!
assign: aPresenter to: anInstVarName
	self presenterAt: anInstVarName put: aPresenter.
	aPresenter owner: self! !

!SpDynamicPresenter class methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!SpDynamicSpecExample commentStamp: ''!
I am an example of how dynamically create the UI corresponding at an object.

self exampleInt
self exampleNil
self exampleString!
!SpDynamicSpecExample methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpDynamicSpecExample methodsFor: 'accessing' stamp: ''!
title

	^ 'Dynamic Examples'! !

!SpDynamicSpecExample methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpDynamicSpecExample methodsFor: 'initialization' stamp: ''!
initialize
	self class initializeSlots: self.
	super initialize! !

!SpDynamicSpecExample methodsFor: 'protocol' stamp: ''!
open
	self object ifNil: [ ^ self openOnNil ].
	self object isInteger ifTrue: [ ^ self openOnInteger: self object ].
	self object isString ifTrue: [ ^ self openOnString: self object ]! !

!SpDynamicSpecExample methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpDynamicSpecExample methodsFor: 'accessing' stamp: ''!
object: anObject
	object := anObject! !

!SpDynamicSpecExample methodsFor: 'protocol' stamp: ''!
open: anObject
	object := anObject.
	self open! !

!SpDynamicSpecExample methodsFor: 'protocol' stamp: ''!
openOnString: aString
	ui := SpOpenOnStringExample new:aString.
	ui 
		extent: 300 @ 200;openWithSpec! !

!SpDynamicSpecExample methodsFor: 'protocol' stamp: ''!
openOnInteger: anInteger
	ui := SpOpenOnIntExample new: anInteger.
	ui
		extent: 100 @ 100;
		openWithSpec! !

!SpDynamicSpecExample methodsFor: 'accessing' stamp: ''!
object
	^ object! !

!SpDynamicSpecExample methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpDynamicSpecExample methodsFor: 'protocol' stamp: ''!
openOnNil
	ui := SpOpenOnNilExample new.
	ui 
		extent: 200 @ 100; openWithSpec! !

!SpDynamicSpecExample class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpDynamicSpecExample class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpDynamicSpecExample class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpDynamicSpecExample class methodsFor: 'examples' stamp: ''!
exampleInt
	<sampleInstance>
	^ self new open: 42! !

!SpDynamicSpecExample class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpDynamicSpecExample class methodsFor: 'instance creation' stamp: ''!
object: object

	^ self new
		object: object;
		yourself! !

!SpDynamicSpecExample class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpDynamicSpecExample class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpDynamicSpecExample class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpDynamicSpecExample class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpDynamicSpecExample class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpDynamicSpecExample class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpDynamicSpecExample class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpDynamicSpecExample class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpDynamicSpecExample class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpDynamicSpecExample class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpDynamicSpecExample class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpDynamicSpecExample class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpDynamicSpecExample class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpDynamicSpecExample class methodsFor: 'examples' stamp: ''!
exampleString
	<sampleInstance>
	^ self new
		open: 'Hello World'! !

!SpDynamicSpecExample class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpDynamicSpecExample class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpDynamicSpecExample class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpDynamicSpecExample class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpDynamicSpecExample class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpDynamicSpecExample class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpDynamicSpecExample class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpDynamicSpecExample class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpDynamicSpecExample class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpDynamicSpecExample class methodsFor: 'examples' stamp: ''!
exampleNil
	<sampleInstance>
	^ self new
		open: nil! !

!SpDynamicSpecExample class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpDynamicSpecExample class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpDynamicSpecExample class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpDynamicWidgetChange commentStamp: ''!
I am a dummy proto to see how easy it is to replace a subwidget with another one dynamically.

slef example!
!SpDynamicWidgetChange methodsFor: 'accessing' stamp: ''!
bottom
	^ bottom! !

!SpDynamicWidgetChange methodsFor: 'private' stamp: ''!
changeToButton

	self instantiatePresenters: 
		#( bottom #SpButtonPresenter ).
	button font: (LogicalFont familyName: 'Source Sans Pro' pointSize: 9).
		
	bottom label: 'I am useless'.! !

!SpDynamicWidgetChange methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	boolean := true! !

!SpDynamicWidgetChange methodsFor: 'private' stamp: ''!
change

	boolean := boolean not.

	boolean
		 ifTrue: [ self changeToList ]
		 ifFalse: [ self changeToButton ].
		
	self needRebuild: false.
	button needRebuild: false.
	
	self buildWithSpec! !

!SpDynamicWidgetChange methodsFor: 'private' stamp: ''!
changeToList

	self instantiatePresenters: 
		#( bottom #SpListPresenter ).

	button font: (LogicalFont familyName: 'Source Sans Pro' pointSize: 10).
		
	bottom items: (1 to: 100) asOrderedCollection.! !

!SpDynamicWidgetChange methodsFor: 'accessing' stamp: ''!
button
	^ button! !

!SpDynamicWidgetChange methodsFor: 'initialization' stamp: ''!
initializePresenters

	button := self newButton.
	bottom := self newList.
		
	button 
		label: 'Change';
		action: [ self change ];
		state: false.
		
	bottom 
		items: (1 to: 10) asOrderedCollection.! !

!SpDynamicWidgetChange class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #button withConstraints: [ :constraints | constraints height: 25 ];
		add: #bottom;
		yourself! !

!SpDynamicWidgetChange class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new openWithSpec! !

!SpDynamicWidgetChangeTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpDynamicWidgetChange! !

!SpEditableListPresenter commentStamp: ''!
This widget allows you to edit a list of items :
- add / remove an item to/from the list 
- order the list by moving elements up/down/top/bottom.

The default behavior is to work directly on the model collection. It means the collection has to support #add:, #remove: methods (e.g. OrderedCollection).
If you prefer, you can do a copy of the list and give the copy to the EditableList. It will allow the user to accept / reject changes (for example by opening the widget in a DialogWindow) before affecting the original list. If you use a copy of your collection, then it is your responsability to copy EditableList items back to the original list.

The addItemBlock is used to provide a way to give the item to add (e.g. a UIManager default chooseFrom: values:).

Example:
self example!
!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
upButton
	^ upButton! !

!SpEditableListPresenter methodsFor: 'initialization' stamp: ''!
newList
	"Default list collection is an Array.
	As this presenter aims to add / remove items from the list, we need a growable collection"
	^ (self instantiate: SpListPresenter)
			items: OrderedCollection new;
			yourself! !

!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
bottomButton
	^ bottomButton! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
selectIndex: anIndex
	list selectIndex: anIndex! !

!SpEditableListPresenter methodsFor: 'private' stamp: ''!
moveElementAt: index to: newIndex
	"WARNING: this method can only be used if the model is an OrderedCollection"
	| elementToMove |
	
	(newIndex between: 1 and: self items size) 
		ifFalse: [ ^ self ].
		
	elementToMove := list itemAt: index.
	self items 
		remove: elementToMove;
		add: elementToMove beforeIndex: newIndex.
	
	self refresh.
	self list selectIndex: newIndex! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
refresh
	self resetSelection.
	self items: self items! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
addItemBlock: aBlock
	addItemBlock := aBlock.! !

!SpEditableListPresenter methodsFor: 'private' stamp: ''!
performOkAction

	okBlock value! !

!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
downButton
	^ downButton! !

!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
topButton
	^ topButton! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
removeItem: anObject
	self items remove: anObject.
	list selection unselectAll! !

!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
list
	^ list! !

!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
addButton
	^ addButton! !

!SpEditableListPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	title := 'Title'.
	okBlock := [  ].
	removeItemBlock := [ :item | 
								item
									ifNotNil: [ self items remove: item.
													self refresh. ] ]! !

!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
label: aString
	label label: aString ! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
selectedIndex
	^ list selection selectedIndex! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
selectedItem
	^ list selection selectedItem! !

!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
title: aTitle
	title := aTitle ! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
whenSelectionChangedDo: aBlockClosure 
	list whenSelectionChangedDo: aBlockClosure! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
resetSelection
	self selectIndex: 0! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
display: aBlock

	list display: aBlock! !

!SpEditableListPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aWindow

	aWindow 
		addButton: 'Ok' 
		do: [ :presenter | 
			self performOkAction. 
			presenter close ]! !

!SpEditableListPresenter methodsFor: 'private' stamp: ''!
items: anItemList
	list items: anItemList.! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
okAction: aBlock

	okBlock := aBlock! !

!SpEditableListPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	aWindowPresenter title: self title! !

!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
removeButton
	^ removeButton! !

!SpEditableListPresenter methodsFor: 'accessing' stamp: ''!
items
	^ list model items! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
removeItemBlock: aBlock
	removeItemBlock := aBlock.! !

!SpEditableListPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	label := self newLabel.
	list := self newList.
	addButton := self newButton.
	removeButton := self newButton.
	upButton := self newButton.
	downButton := self newButton.
	topButton := self newButton.
	bottomButton := self newButton.
	addButton
		addStyle: 'small';
		icon: (self iconNamed: #addIcon);
		help: 'Add a new item to the list'.
	removeButton
		addStyle: 'small';
		icon: (self iconNamed: #removeIcon);
		help: 'Remove a item from the list'.
	upButton
		addStyle: 'small';
		icon: (self iconNamed: #upIcon);
		help: 'Move this item up from one element'.
	downButton
		addStyle: 'small';
		icon: (self iconNamed: #downIcon);
		help: 'Move this item down from one element'.
	topButton
		addStyle: 'small';
		icon: (self iconNamed: #topIcon);
		help: 'Move this item on the first position of the list'.
	bottomButton
		addStyle: 'small';
		icon: (self iconNamed: #bottomIcon);
		help: 'Move this item on the last position of the list'! !

!SpEditableListPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters
	super connectPresenters.
	addButton action: [ 
		| newItem |
		newItem := addItemBlock value.
		newItem ifNotNil: [ 
			self items add: newItem.
			self 
				refresh;
				selectItem: newItem ] ].
	removeButton 
		action: [ removeItemBlock cull: self selectedItem ].
	topButton action: [ self moveElementAt: self selectedIndex to: 1 ].
	bottomButton action: [ 
		self moveElementAt: self selectedIndex to: self items size ].
	upButton action: [ 
		self moveElementAt: self selectedIndex to: self selectedIndex - 1 ].
	downButton action: [ 
		self moveElementAt: self selectedIndex to: self selectedIndex + 1 ]! !

!SpEditableListPresenter methodsFor: 'api' stamp: ''!
selectItem: anObject
	list selectItem: anObject! !

!SpEditableListPresenter class methodsFor: 'spec' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
					addLast: #addButton expand: false;
					addLast: #removeButton expand: false;
					yourself)
			expand: false;
		add:
			(SpBoxLayout newLeftToRight
				add: #list;
				add:
					(SpBoxLayout newTopToBottom
							add: #topButton expand: false fill: false padding: 0;
							add: #upButton expand: false fill: false padding: 0;
							add: #downButton expand: false fill: false padding: 0;
							add: #bottomButton expand: false fill: false padding: 0;
							yourself)
					expand: false;
				yourself);
		yourself! !

!SpEditableListPresenter class methodsFor: 'spec' stamp: ''!
withoutOrderingBar
	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
					addLast: #addButton expand: false;
					addLast: #removeButton expand: false;
					yourself)
			expand: false;
		add: #list;
		yourself! !

!SpEditableListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>
	| presenter |
	presenter := self new
		items: self selectors asOrderedCollection;
		addItemBlock: [ 1 ];
		openWithSpec;
		yourself.

	presenter withWindowDo: [ :w | w title: 'Selectors list' ].

	^ presenter! !

!SpEditableListPresenter class methodsFor: 'instance creation' stamp: ''!
new: aCollection
	^ self new items: aCollection.
		! !

!SpEditableListPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpEditableListPresenter! !

!SpEditableListPresenterTest methodsFor: 'tests' stamp: ''!
testCanAddNewItem
	presenter 
		items: #(1 2 3) asOrderedCollection;
		addItemBlock: [ 4 ].
		
	presenter addButton click.
	
	self 
		assertCollection: presenter items
		hasSameElements: #(1 2 3 4)! !

!SpEditableListPresenterTest methodsFor: 'tests' stamp: ''!
testCanRemoveSelectedItem
	presenter 
		items: #(1 2 3) asOrderedCollection;
		selectItem: 2.
	
	presenter removeButton click.
	
	self 
		assertCollection: presenter items
		hasSameElements: #(1 3)! !

!SpEditableListPresenterTest methodsFor: 'tests' stamp: ''!
testMoveElementAtTo
	presenter items: {'AAA' . 'BBB' . 'CCC'} asOrderedCollection.
	presenter moveElementAt: 1 to: 3.
	self
		assert: presenter items asArray
		equals: {'BBB' . 'CCC' . 'AAA'}! !

!SpEditableListPresenterTest methodsFor: 'tests' stamp: ''!
testRemoveBlockExecutedWhenSelectedItemRemoved
	| executed selectedItem |
	executed := false.
	presenter 
		items: #(1 2 3) asOrderedCollection;
		removeItemBlock: [ :item | executed := true. selectedItem := item ];
		selectItem: 2.
	
	presenter removeButton click.
	
	self 
		assert: executed
		description: 'removeBlock not exeuted when selected item removed!!'.
	self 
		assert: selectedItem
		equals: 2! !

!SpEditableListPresenterTest methodsFor: 'tests' stamp: ''!
testCanCancelAddNewItem
	presenter 
		items: #(1 2 3) asOrderedCollection;
		addItemBlock: [ nil ].
		
	presenter addButton click.
	
	self 
		assertCollection: presenter items
		hasSameElements: #(1 2 3)! !

!SpEditableListPresenterTest methodsFor: 'tests' stamp: ''!
testWhenAddingNewItemThenNewItemIsSelected
	presenter 
		items: #(1 2 3) asOrderedCollection;
		addItemBlock: [ 4 ].
		
	presenter addButton click.
	
	self 
		assert: presenter selectedItem 
		equals: 4! !

!SpEmptyPresenter methodsFor: 'accessing' stamp: ''!
layout: aSpLayout
	
	layout := aSpLayout! !

!SpEventHandler commentStamp: ''!
I am an event handler to dispatch low-level events to my presenters.
I am used when the "high-level" events (like "clicked" for buttons, etc.) are not enough and users need to control better what is happening. 

I can listen: 
- focus events: got focus, lost focus. 
- mouse events: mouse enter, mouse leave, mouse move
- keyboard events: keydown, keyup

WARNING: Not all presenters will answer equally to all events. For example, presenters who can't take the keyboard focus can't respond to focus events.!
!SpEventHandler methodsFor: 'api - events' stamp: ''!
whenMouseLeaveDo: aBlock
	"Register on a mouse leave event. 
	 aBlock receives 'event' as parameter."

	 self register: (SpMouseLeaveEventDefinition do: aBlock)! !

!SpEventHandler methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	events := Set new! !

!SpEventHandler methodsFor: 'api - events' stamp: ''!
whenFocusLostDo: aBlock
	"Register on a focus lost event. 
	 aBlock does not have parameters."

	 self register: (SpFocusLostEventDefinition do: aBlock)! !

!SpEventHandler methodsFor: 'api - events' stamp: ''!
whenMouseMoveDo: aBlock
	"Register on a mouse move event. 
	 aBlock receives 'event' as parameter."

	 self register: (SpMouseMoveEventDefinition do: aBlock)! !

!SpEventHandler methodsFor: 'api - events' stamp: ''!
whenKeyDownDo: aBlock
	"Register on a key down event. 
	 aBlock receives 'event' as parameter."

	 self register: (SpKeyDownEventDefinition do: aBlock)! !

!SpEventHandler methodsFor: 'testing' stamp: ''!
hasEvents
	
	^ events notEmpty! !

!SpEventHandler methodsFor: 'api - events' stamp: ''!
whenKeyUpDo: aBlock
	"Register on a key down event. 
	 aBlock receives 'event' as parameter."

	 self register: (SpKeyUpEventDefinition do: aBlock)! !

!SpEventHandler methodsFor: 'api - events' stamp: ''!
whenMouseEnterDo: aBlock
	"Register on a mouse enter event. 
	 aBlock receives 'event' as parameter."

	 self register: (SpMouseEnterEventDefinition do: aBlock)! !

!SpEventHandler methodsFor: 'installing' stamp: ''!
installAllEventsTo: anAdapter target: aWidget

	events do: [ :each |
		each installOn: anAdapter target: aWidget ]! !

!SpEventHandler methodsFor: 'api - events' stamp: ''!
whenDoubleClickDo: aBlock

	 self register: (SpMouseDoubleClickDefinition do: aBlock)! !

!SpEventHandler methodsFor: 'api - events' stamp: ''!
whenMouseUpDo: aBlock
	"Register on a mouse up event. 
	 aBlock receives 'event' as parameter."
	
	 self register: (SpMouseUpEventDefinition do: aBlock)! !

!SpEventHandler methodsFor: 'api - events' stamp: ''!
whenFocusReceivedDo: aBlock
	"Register on a focus received event. 
	aBlock does not have parameters."


	 self register: (SpFocusReceivedEventDefinition do: aBlock)! !

!SpEventHandler methodsFor: 'initialization' stamp: ''!
initializePresenter: aPresenter

	presenter := aPresenter.
	self initialize! !

!SpEventHandler methodsFor: 'private' stamp: ''!
register: anEvent

	events add: anEvent.
	presenter withAdapterDo: [ :anAdapter | 
		anAdapter installEvent: anEvent  ]	! !

!SpEventHandler methodsFor: 'api - events' stamp: ''!
whenMouseDownDo: aBlock
	"Register on a mouse down event. 
	 aBlock receives 'event' as parameter."

	 self register: (SpMouseDownEventDefinition do: aBlock)! !

!SpEventHandler class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Use #new'! !

!SpEventHandler class methodsFor: 'instance creation' stamp: ''!
for: aPresenter 

	^ self basicNew 
		initializePresenter: aPresenter;
		yourself! !

!SpEventHandlerTest methodsFor: 'tests' stamp: ''!
testEventIsTransmittedOnText
	| t1 t2 lost got |

	(presenter := SpPresenter new) 
		layout: (SpBoxLayout newTopToBottom
			add: (t1 := presenter newText);
			add: (t2 := presenter newText);
			yourself).

	got := lost := false.
	t1 eventHandler 
		whenFocusReceivedDo: [ got := true ];
		whenFocusLostDo: [ lost := true ].
		
	presenter openWithSpec.
	
	t1 takeKeyboardFocus.
	t2 takeKeyboardFocus.
	
	self assert: got.
	self assert: lost! !

!SpEventHandlerTest methodsFor: 'running' stamp: ''!
tearDown

	presenter ifNil: [ ^ self ].
	presenter withWindowDo: [ :w | w close ].
	presenter := nil.
	
	super tearDown! !

!SpEventHandlerTest methodsFor: 'tests' stamp: ''!
testEventIsInstalledDynamically
	| t1 t2 lost got |

	(presenter := SpPresenter new) 
		layout: (SpBoxLayout newTopToBottom
			add: (t1 := presenter newTextInput);
			add: (t2 := presenter newTextInput);
			yourself).

	presenter openWithSpec.

	got := lost := false.
	t1 eventHandler 
		whenFocusReceivedDo: [ got := true ];
		whenFocusLostDo: [ lost := true ].
	
	t2 takeKeyboardFocus.
	t1 takeKeyboardFocus.
	
	self assert: got.
	self assert: lost! !

!SpEventHandlerTest methodsFor: 'tests' stamp: ''!
testEventIsInstalledOnBuild
	| t1 t2 lost got |

	(presenter := SpPresenter new) 
		layout: (SpBoxLayout newTopToBottom
			add: (t1 := presenter newTextInput);
			add: (t2 := presenter newTextInput);
			yourself).

	got := lost := false.
	t1 eventHandler 
		whenFocusReceivedDo: [ got := true ];
		whenFocusLostDo: [ lost := true ].
		
	presenter openWithSpec.
	
	t1 takeKeyboardFocus.
	t2 takeKeyboardFocus.
	
	self assert: got.
	self assert: lost! !

!SpExamples commentStamp: ''!
A SpecExamples is the first sub-book of SpecHelpTopics. It contains examples of using Spec.
See class side for selectors.
!
!SpExamples class methodsFor: 'pages' stamp: ''!
secondExample
	^HelpTopic 
		title: 'A second example: Protocol List'
		contents: 'The next user interface is the protocol list. This UI combines two sub widgets: 
		a list
		a label.

So again, we start by subclassing SpPresenter

	SpPresenter subclass: #ProtocolList
	instanceVariableNames: ''label protocols''
	classVariableNames: ''
	category: ''Spec-Examples''
	
The initializeWidgets method for this UI is quite similar to the method in ModelList:

	ProtocolList>>initializeWidgets
		protocols := self newList.
		label := self newLabel.
		label text: ''Protocol''.
		protocols displayBlock: [ :m | m selector ].
		self focusOrder add: protocols
	
The layout method is quite different though. Now the sub widgets need to be placed more specifically than in the previous example, we have to build a layout that has a column with the label on top and the list taking all the space that is left.

	ProtocolList class>>defaultSpec
		<spec: #default>
		^ SpecLayout composed
		newColumn: [ :column |
			column
				add: #label
					height: self toolbarHeight;
					add: #protocols ];
		yourself
		
	
The remaining methods are getters, sub widget delegation methods, a method to display the title, and a method to register to list selection changes: 


	"accessing"
	ProtocolList>>label
		^ label

	"accessing"
	ProtocolList>>protocols
		^ protocols

	"api"
	ProtocolList>>items: aCollection
		protocols items: aCollection

	"api"
	ProtocolList>>label: aText
		label label: aText

	"api"
	ProtocolList>>resetSelection
		protocols resetSelection

	"api"
	ProtocolList>>title
		^ ''Protocol widget''

	"api - events"
	ProtocolList>>whenSelectedItemChanged: aBlock
		protocols whenSelectedItemChanged: aBlock

The ProtocolList UI can be seen by evaluating:

 ProtocolList new openWithSpec.
'! !

!SpExamples class methodsFor: 'accessing' stamp: ''!
pages
	^#(firstExample secondExample moreExamples)! !

!SpExamples class methodsFor: 'pages' stamp: ''!
firstExample
	^HelpTopic 
		title: 'A first example: ModelList'
		contents: 'Creating a specific UI always starts with the subclassing of SpPresenter. Each sub widget is stored into an instance variable of the newly created class. All the code presented here is already in the image so you can simply do: 
		
	ModelList browse

And follow the tutorial while browsing the code. So let''s subclass SpPresenter.


	SpPresenter subclass: #ModelList
	instanceVariableNames: ''list''
	classVariableNames: ''
	category: ''Spec-Examples''		
		
The first required step then is to instantiate and define the sub widgets. This step is done in the method initializeWidgets. It creates the list and populates it with the required classes, in alphabetical order.

	ModelList>>initializeWidgets
	list := self newList.
	list items: (AbstractWidgetPresenter allSubclasses
	sorted: [:a :b | a name < b name ]).
	self focusOrder add: list
	
The second required step is to define a layout, which is done on the class side. Since there is here only one sub widget, the layout is quite simple. It simply returns a layout that contains only the list:

	ModelList class>>#defaultSpec
	<spec: #default>
	^ SpecLayout composed
	add: #list;
	yourself
	
The three last methods to define on ModelList are a getter, a method to display the UI title and a method to register to list selection changes.

	"accessing"
	ModelList>>list
		^ list

	"api"
	ModelList>>title
		^ ''Widgets''

	"api - events"
	ModelList>>whenSelectedItemChanged: aBlock
		list whenSelectedItemChanged: aBlock

The first UI is now done. The result can be seen by executing the following snippet of code: 
	ModelList new openWithSpec.

'! !

!SpExamples class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Examples'! !

!SpExamples class methodsFor: 'pages' stamp: ''!
moreExamples
	^HelpTopic 
		title: 'More Examples'
		contents: 'If you browse the Spec-Examples package you will find a lot more examples that will help you understand Spec a little more.
		
ApplicationWithToolbar new openWithSpec

CheckBoxExample new openWithSpec

ClassMethodBrowser new openWithSpec

DropListExample new openWithSpec

DynamicWidgetChange new openWithSpec

ListSelectionPresenter new openWithSpec

MethodBrowser new openWithSpec

ModelList new openWithSpec

ProtocolBrowser new openWithSpec

ProtocolList new openWithSpec

ProtocolViewer new openWithSpec

RadioButtonGroupExample new openWithSpec

ScrollSyncExample new openWithSpec

TabsExample new openWithSpec

TextFieldExample new openWithSpec'! !

!SpExecutableLayout commentStamp: ''!
I'm the common root of layout. 
My subclasses are responsible to define the logic and the API developer will use.
Since the layouts require different specifications most of my code is more internal than to be used directly.

From my methods, the ones that may interested Spec application developers are:

- `add:withConstraints:` to add a presenter as subcomponents
- `remove` to remove an existing presenter from a layout.

Note that adding and removing presenters are raising corresponding announcement `SpChildrenAdded` and `SpChildrenRemoved`. !
!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
allPresenters
	"answer all presenters in the layout hierarchy"
	
	^ self presenters
		inject: #()
		into: [ :all :each | 
			all, (each isSpLayout 
				ifTrue: [ each allPresenters ]
				ifFalse: [ { each } ]) ]! !

!SpExecutableLayout methodsFor: 'testing' stamp: ''!
isEmpty

	^ children isEmpty! !

!SpExecutableLayout methodsFor: 'releasing' stamp: ''!
unsubscribe 

	self announcer unsubscribe: adapter.
	self childLayouts do: [ :childLayout |
		childLayout adapter unsubscribe. 
		childLayout unsubscribe ]! !

!SpExecutableLayout methodsFor: 'testing' stamp: ''!
isSpLayout

	^ true! !

!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
children

	^ children keys! !

!SpExecutableLayout methodsFor: 'private' stamp: ''!
subpresenterOrLayoutNamed: presenterNameOrLayout of: aPresenter

	^ aPresenter additionalSubpresentersMap
		at: presenterNameOrLayout
		ifAbsent: [ 
			aPresenter 
				presenterAt: presenterNameOrLayout 
				ifAbsent: [ 
					self error: 'No presenter named "' , presenterNameOrLayout , '" was found in ' , aPresenter printString ] ]! !

!SpExecutableLayout methodsFor: 'converting' stamp: ''!
asArray

	self error: 'Should not arrive here. This layout is executable then it will not be interpreted.'! !

!SpExecutableLayout methodsFor: 'announcing' stamp: ''!
announce: anAnnouncement

	announcer ifNil: [ ^ self ].
	announcer announce: anAnnouncement! !

!SpExecutableLayout methodsFor: 'private' stamp: ''!
announceChildAdded: aChildPresenter

	self presenter ifNotNil: [
		self announcer announce: (SpChildrenAdded new
			parent: self presenter;
			child: aChildPresenter;
			yourself) ]! !

!SpExecutableLayout methodsFor: 'events' stamp: ''!
whenChildrenAddedDo: aBlock

	self announcer
		when: SpChildrenAdded
		do: aBlock! !

!SpExecutableLayout methodsFor: 'removing' stamp: ''!
remove: aPresenter

	self 
		remove: aPresenter 
		ifAbsent: [ self removeBySymbol: aPresenter ].
	self announceChildRemoved: aPresenter! !

!SpExecutableLayout methodsFor: 'private' stamp: ''!
resolvePresenter: aPresenterOrLayout presenter: aPresenter bindings: bindings

	"most common case: I receive a symbol that I need to convert into a presenter"
	aPresenterOrLayout isSymbol ifTrue: [ 
		^ (self subpresenterOrLayoutNamed: aPresenterOrLayout of: aPresenter)
			ifNil: [ self error: 'You presenter named "', aPresenterOrLayout , '" from ', aPresenter printString ,' was not initialized.' ] ].
	
	"I receive a layout: dig inside."
	aPresenterOrLayout isSpLayout ifTrue: [ 
		^ aPresenterOrLayout 
			buildAdapterFor: aPresenter 
			bindings: bindings ].
	
	"I receive an arbitrary object (needs to understand #asPresenter)"
	^ aPresenterOrLayout asPresenter
		owner: aPresenter;
		yourself! !

!SpExecutableLayout methodsFor: 'private' stamp: ''!
adapterName

	^ self subclassResponsibility! !

!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
constraintsFor: aPresenter

	^ children at: aPresenter! !

!SpExecutableLayout methodsFor: 'building' stamp: ''!
buildAdapterFor: aPresenter bindings: bindings
	| oldAdapter |
	
	oldAdapter := adapter.
	
	adapter := (aPresenter needRebuild or: [ aPresenter adapter isNil ])
		ifTrue: [ 
			(bindings adapterClass: self adapterName) adapt: aPresenter ]
		ifFalse: [ 
			aPresenter adapter
				removeSubWidgets;
				yourself ].
			
	"Ensure we remove the flag `no need of rebuild` if it was set."
	aPresenter needRebuild: true.
	
	adapter layout: self.

	children keysAndValuesDo: [ :presenterNameOrLayout :constraints | 
		"Since a layout can be composed (by other layouts), we can include a 
		 presenter or a layout" 
		adapter 
			add: (self 
				resolvePresenter: presenterNameOrLayout 
				presenter: aPresenter 
				bindings: bindings) 
			constraints: constraints ].
		
	adapter adapterWasBuilt.
	
	oldAdapter ifNotNil: [ oldAdapter unsubscribe ].

	^ adapter! !

!SpExecutableLayout methodsFor: 'announcing' stamp: ''!
announcer

	^ announcer ifNil: [ announcer := Announcer new ]! !

!SpExecutableLayout methodsFor: 'private' stamp: ''!
removeBySymbol: aPresenter
	"I will look for the symbol that represents the presenter (in case of layouts defined by symbolic 
	 representation of presenter) and then I will remove it"

	children keys do: [ :each |
		each isPresenter ifFalse: [ 
			(adapter presenter presenterAt: each) = aPresenter ifTrue: [
				self remove: each ifAbsent: [ NotFound signal: 'Presenter not found.' ] ] ] ]! !

!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
add: aName withConstraints: aBlock

	| constraints |
	constraints := self constraintsClass new.
	aBlock value: constraints.
	children at: aName put: constraints! !

!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
adapter 

	^ adapter! !

!SpExecutableLayout methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	children := OrderedDictionary new! !

!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!SpExecutableLayout methodsFor: 'converting' stamp: ''!
asSpLayout
	
	^ self! !

!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
presenters
	
	^ children keys! !

!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
parentLayoutOf: aKey 
	"Find a child layout that contains a presenter of given key. Useful if you need to find 
	 a parent layout of a presenter that you need to replace."

    (self children anySatisfy: [ :each | each = aKey ])
        ifTrue: [ ^ self ].
    
    self children do: [ :each | 
        each isSpLayout ifTrue: [ 
            | found | 
            found := each parentLayoutOf: aKey.
            found ifNotNil: [ ^ found ] ] ].
        
    ^ nil ! !

!SpExecutableLayout methodsFor: 'private' stamp: ''!
constraintsClass

	^ self subclassResponsibility! !

!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
presenter

	^ adapter ifNotNil: [ adapter presenter ]! !

!SpExecutableLayout methodsFor: 'testing' stamp: ''!
isExecutable

	^ true! !

!SpExecutableLayout methodsFor: 'accessing' stamp: ''!
childLayouts

	^ children keys select: [ :child |
		child isSpLayout ]! !

!SpExecutableLayout methodsFor: 'events' stamp: ''!
whenChildrenRemovedDo: aBlock

	self announcer
		when: SpChildrenRemoved
		do: aBlock! !

!SpExecutableLayout methodsFor: 'private' stamp: ''!
withAdapterDo: aValuable
	"a convenience method to avoid verify by nil all the time"
	
	^ adapter ifNotNil: aValuable! !

!SpExecutableLayout methodsFor: 'private' stamp: ''!
announceChildRemoved: aChildPresenter

	self presenter ifNotNil: [
		self announcer announce: (SpChildrenRemoved new
			parent: self presenter;
			child: aChildPresenter;
			yourself)].! !

!SpExecutableLayout methodsFor: 'private' stamp: ''!
remove: aPresenter ifAbsent: aBlock

	^ (children includesKey: aPresenter)
		ifTrue: [ children removeKey: aPresenter ]
		ifFalse: aBlock! !

!SpExecutableLayout class methodsFor: '*Spec2-Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	super buildMicroDownUsing: aBuilder withComment: aString.
	"Sections"
	self documentSections keysAndValuesDo: [ :label :methods |
		self addDocumentSection: aBuilder label: label methods: methods ].
	"Hierarchy"
	self addDocumentSectionHierarchy: aBuilder.
	! !

!SpExecutableLayout class methodsFor: 'documentation' stamp: ''!
documentSections
		
	^ OrderedDictionary newFromPairs: {
		'Examples'. self class methods select: [ :each | each protocol = '*Spec2-Examples' ].	
		'Adding Methods'. self methods select: [ :each | each protocol = #'api - adding' ].
		'API Methods'. self methods select: [ :each | each protocol = #'api' ]
	}! !

!SpExecutableLayout class methodsFor: 'documentation' stamp: ''!
addDocumentSection: aBuilder label: label methods: methods
	
	methods ifEmpty: [ ^ self ].
	
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: label ] withLevel: 2.
	aBuilder unorderedListDuring: [  
		(methods sorted: #selector ascending) do: [ :each |
			aBuilder item: [
				aBuilder monospace: (each methodClass name, '>>#', each selector) ] ] ]! !

!SpExecutableLayout class methodsFor: 'documentation' stamp: ''!
addDocumentSectionHierarchy: aBuilder
	
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Hierarchy' ] withLevel: 2.
	SpDocumentHierarchyBuilder new
		fromClass: Object;
		builder: aBuilder;
		filter: [ :eachClass | eachClass package packageName beginsWith: 'Spec2-' ];
		buildFor: self! !

!SpExecutableLayoutTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpMockDynamicPresenter! !

!SpExecutableLayoutTest methodsFor: 'tests' stamp: ''!
testRebuildPresenterBeforeOpeningWorks
	self assert: presenter label label equals: ''.
	self
		shouldnt: [ presenter selectFirstElement.
			self openInstance ]
		raise: Error.
	self assert: presenter label label equals: '1'! !

!SpExecutableLayoutTest methodsFor: 'tests' stamp: ''!
testCanDynamicallyRebuildPresenter
	self openInstance.
	self assert: presenter label label equals: ''.
	self shouldnt: [ presenter selectFirstElement ] raise: Error.
	self assert: presenter label label equals: '1'! !

!SpFTArrayIndexColumn commentStamp: ''!
I am a fast table column to represent item in array at particular index.
 
Internal Representation and Key Implementation Points.

This class has and extends API of FTColumn

    Instance Variables
	id:			An id for the column
	width:		An Integer that represent the width of a column.
	index:		<Number>!
!SpFTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
transform: anArray
	^ anArray at: self index! !

!SpFTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
index: anObject
	index := anObject! !

!SpFTArrayIndexColumn methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!SpFTArrayIndexColumn class methodsFor: 'instance creation' stamp: ''!
index: aNumber width: aNumber2
	^ (self index: aNumber) 
		width: aNumber2! !

!SpFTArrayIndexColumn class methodsFor: 'instance creation' stamp: ''!
index: aNumber
	^ self new 
		index: aNumber! !

!SpFTColumn commentStamp: ''!
A column for Fast table!
!SpFTColumn methodsFor: 'accessing' stamp: ''!
width: anObject
	width := anObject! !

!SpFTColumn methodsFor: 'layout' stamp: ''!
acquireWidth: anOwnerWidth
	^ self widthOrUndefined min: anOwnerWidth! !

!SpFTColumn methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!SpFTColumn methodsFor: 'initialization' stamp: ''!
id: anObject
	id := anObject! !

!SpFTColumn methodsFor: 'accessing' stamp: ''!
readObject: anObject

	"Fast table presenters have a block that returns an array that is mapped by this column"
	^ self transform: (table displayBlock value: anObject)! !

!SpFTColumn methodsFor: 'accessing' stamp: ''!
transform: anObject
	^ anObject! !

!SpFTColumn methodsFor: 'accessing' stamp: ''!
table: anObject
	table := anObject! !

!SpFTColumn methodsFor: 'accessing' stamp: ''!
table
	^ table! !

!SpFTColumn methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!SpFTColumn methodsFor: 'accessing' stamp: ''!
title
	^ id! !

!SpFTColumn methodsFor: 'accessing' stamp: ''!
widthOrUndefined
	^ self width ifNil: [ self class undefinedColumnWidth ]! !

!SpFTColumn class methodsFor: 'instance creation' stamp: ''!
id: anObject
	^ self new
		id: anObject;
		yourself! !

!SpFTColumn class methodsFor: 'accessing' stamp: ''!
undefinedColumnWidth
	"This is a contant that defines a column width is undefined, then the layout will try to arrange 
	 it by itself."
	^ 0! !

!SpFTSpecFilter commentStamp: ''!
Description
--------------------

I am a filter for Spec lists. I am parametrized by a block and will filter the entities matching the block.

Example 
--------------------

	FTSpecFilter block: [ :each :pattern | each asLowercase includesSubstring: pattern asLowercase ]!
!SpFTSpecFilter methodsFor: 'accessing' stamp: ''!
block
	^ block! !

!SpFTSpecFilter methodsFor: 'accessing' stamp: ''!
block: anObject
	block := anObject! !

!SpFTSpecFilter methodsFor: 'matching' stamp: ''!
matches: anObject
	^ self block cull: anObject cull: pattern! !

!SpFTSpecFilter class methodsFor: 'instance creation' stamp: ''!
block: aBlockClosure
	^ self new
		block: aBlockClosure;
		yourself! !

!SpFTTableMorph methodsFor: 'drawing' stamp: ''!
drawKeyboardFocusOn: aCanvas

	self color = Color transparent ifTrue: [ ^ self ].
	^ super drawKeyboardFocusOn: aCanvas! !

!SpFTTableMorph methodsFor: 'drag and drop' stamp: ''!
acceptDroppingMorph: aTransferMorph event: anEvent

	^ self dataSource model adapter
		acceptDroppingMorph: aTransferMorph 
		event: anEvent! !

!SpFTTableMorph methodsFor: 'accessing' stamp: ''!
minWidth
	"answer the receiver's minHeight"
	^ self
		valueOfProperty: #minWidth
		ifAbsent: [ 100 ]! !

!SpFTTableMorph methodsFor: 'events-processing' stamp: ''!
handleKeyDown: anEvent
	"System level event handling."

	anEvent wasHandled ifTrue:[ ^ self ].
	
	self shortcutsHandler ifNotNil: [ :handler | 
		handler handleKeystroke: anEvent inMorph: self.
		anEvent wasHandled ifTrue: [ ^ self ] ].
	
	movementDispatcher dispatch: { anEvent }.
	anEvent wasHandled ifTrue: [ ^ self ].
	
	(self handlesKeyDown: anEvent) ifFalse:[ ^ self ].
	anEvent wasHandled: true.
	self keyDown: anEvent.
	
	^ self eventHandler ifNotNil: [ :handler | 
		handler 
			keyDown: anEvent 
			fromMorph: self ]! !

!SpFTTableMorph methodsFor: 'initialization' stamp: ''!
initializeKeyBindings
	"add keybindings used by table"

	movementDispatcher := KMDispatcher target: self.
	movementDispatcher 
		bindKeyCombination: Character arrowUp shift | Character arrowUp asKeyCombination
		toAction: [ :target :morph :event | self keyStrokeArrowUp: event ].
	movementDispatcher
		bindKeyCombination: Character arrowDown shift | Character arrowDown asKeyCombination
		toAction: [ :target :morph :event | self keyStrokeArrowDown: event ].
	movementDispatcher
		bindKeyCombination: Character arrowLeft shift | Character arrowLeft asKeyCombination
		toAction: [ :target :morph :event | self keyStrokeArrowLeft: event ].
	movementDispatcher
		bindKeyCombination: Character arrowRight shift | Character arrowRight asKeyCombination
		toAction: [ :target :morph :event | self keyStrokeArrowRight: event ].
	movementDispatcher
		bindKeyCombination: Character home asKeyCombination
		toAction: [ self selectFirst ].
	movementDispatcher
		bindKeyCombination: Character end asKeyCombination
		toAction: [ self selectLast ].
	movementDispatcher
		bindKeyCombination: self shortcutProvider selectAllShortcut
		toAction: [ self selectAll ]! !

!SpFTTableMorph methodsFor: 'drag and drop' stamp: ''!
wantsDroppedMorph: aTransferMorph event: anEvent

	aTransferMorph isTransferable ifFalse: [ ^ false ].
	^ self dataSource model adapter 
		wantsDroppedMorph: aTransferMorph 
		event: anEvent! !

!SpFilteringListPresenter commentStamp: ''!
I am a presenter that has a list and a text input for filtering the elements on the list.

The list items are filtered based on what the `display` method of the list returns. In other words, what you see is what is used to filter.

I have two predefined filter methods: `self enableItemBeginsWithFilter` and `self enableItemSubstringFilter`. You can set your own method be calling `self itemFilter: aBlock` with a block that has two parameters: the item and the pattern. See the definitions of the above methods for details.

I have two subwidgets:
- A List (`SpListPresenter`) that has the items.
- A Text Input Field (`SpTextInputFieldPresenter`) for entering the filter text.!
!SpFilteringListPresenter methodsFor: 'transmission' stamp: ''!
defaultInputPort

	^ listPresenter defaultInputPort! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
display 

	^ self listPresenter display! !

!SpFilteringListPresenter methodsFor: 'private' stamp: ''!
filterListItems: pattern
	| filteredItems |
	
	unfilteredItems ifNil: [ 
		unfilteredItems := self items ].
	
	pattern ifEmpty: [ 
		self items: unfilteredItems.
		^ self ].

	filteredItems := unfilteredItems select: [ :item |
		itemFilterBlock
			value: (self display value: item)
			value: pattern ].

	listPresenter items: filteredItems! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
filterText

	^  self filterInputPresenter text! !

!SpFilteringListPresenter methodsFor: 'initialization' stamp: ''!
newListToFilter
	
	^ self newList! !

!SpFilteringListPresenter methodsFor: 'transmission' stamp: ''!
defaultOutputPort

	^ listPresenter defaultOutputPort! !

!SpFilteringListPresenter methodsFor: 'accessing' stamp: ''!
filterInputPresenter

	^ filterInputPresenter! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
contextMenu: aValuable
 
	self listPresenter contextMenu: aValuable! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
displayIcon: aBlock

	self listPresenter displayIcon: aBlock! !

!SpFilteringListPresenter methodsFor: 'initialization' stamp: ''!
matchSubstring

	itemFilterBlock := [ :each :pattern | 
	              each asLowercase includesSubstring: pattern asLowercase ]! !

!SpFilteringListPresenter methodsFor: 'transmission' stamp: ''!
inputItemsPort
	
	^ listPresenter inputItemsPort! !

!SpFilteringListPresenter methodsFor: 'accessing' stamp: ''!
listPresenter
	^ listPresenter! !

!SpFilteringListPresenter methodsFor: 'initialization' stamp: ''!
matchBeginOfString

	itemFilterBlock := [ :each :pattern | 
	              each asLowercase beginsWith: pattern asLowercase ]! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
selectedItem
	
	^ listPresenter selectedItem! !

!SpFilteringListPresenter methodsFor: 'api - events' stamp: ''!
whenSelectionChangedDo: aBlock
 
	listPresenter whenSelectionChangedDo: aBlock! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
applyFilter: aString

	self filterInputPresenter text: aString! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
display: aBlock

	self listPresenter display: aBlock! !

!SpFilteringListPresenter methodsFor: 'private' stamp: ''!
itemFilter

	^ itemFilterBlock! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
items: aCollection

	listPresenter items: aCollection.
	unfilteredItems := nil! !

!SpFilteringListPresenter methodsFor: 'transmission' stamp: ''!
outputActivationPort
	
	^ listPresenter outputActivationPort! !

!SpFilteringListPresenter methodsFor: 'transmission' stamp: ''!
outputSelectionPort
	
	^ listPresenter outputSelectionPort! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
selectItem: anObject
	
	listPresenter selectItem: anObject! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
items

	^ listPresenter items! !

!SpFilteringListPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	filterInputPresenter := self newTextInput
		placeholder: 'Filter...';
		yourself.
	listPresenter := self newListToFilter.
	self matchSubstring! !

!SpFilteringListPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters

	filterInputPresenter whenTextChangedDo: [ :text | self filterListItems: text ]! !

!SpFilteringListPresenter methodsFor: 'accessing' stamp: ''!
unfilteredItems

	^ unfilteredItems ifNil: [ unfilteredItems := self items ]! !

!SpFilteringListPresenter methodsFor: 'api' stamp: ''!
itemFilter: aBlock

	itemFilterBlock := aBlock! !

!SpFilteringListPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ self bottomLayout! !

!SpFilteringListPresenter class methodsFor: 'specs' stamp: ''!
bottomLayout

	^ SpBoxLayout newTopToBottom
		  add: #listPresenter;
		  add: #filterInputPresenter expand: false;
		  yourself! !

!SpFilteringListPresenter class methodsFor: 'specs' stamp: ''!
topLayout

	^ SpBoxLayout newTopToBottom
		  add: #filterInputPresenter expand: false;
		  add: #listPresenter;
		  yourself! !

!SpFilteringListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>
	| example |

	example := self new.
	example items: RBBrowserEnvironment default classes asArray.
	example openWithSpec.
	example withWindowDo: [ :window | 
		window title: self name asString , ' example' ].

	^ example! !

!SpFilteringListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithInitializedFilter

	<sampleInstance>
	| example |
	example := self new.
	example matchSubstring.
	example items: RBBrowserEnvironment default classes asArray.
	example displayIcon: [ :aClass | aClass systemIcon ].
	example applyFilter: 'ZZ'.
	example openWithSpec title:
		self name asString , ' example with filter'.

	^ example! !

!SpFilteringListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithFilterOnTop
	<sampleInstance>
	| example |

	example := self new.
	example items: RBBrowserEnvironment default classes asArray.
	example openWithSpec: #topLayout.
	example withWindowDo: [ :window | 
		window title: self name asString , ' example' ].

	^ example! !

!SpFilteringSelectableListPresenter commentStamp: ''!
A presenter to show a list that can be filter, and which elements are selectable.!
!SpFilteringSelectableListPresenter methodsFor: 'private' stamp: ''!
listColumns
	| column |

	column := SpCompositeTableColumn new.
	
	column addColumn: (selectColumn := (SpCheckBoxTableColumn new
		evaluated: [ :anObject | selectedItems includes: anObject ];
		onActivation: [ :anObject | self activateItem: anObject ];
		onDeactivation: [ :anObject |self deactivateItem: anObject ];
		beNotExpandable)).
		
	displayIconBlock ifNotNil: [
		column addColumn: (SpImageTableColumn evaluated: displayIconBlock) beNotExpandable ].
	
	column addColumn: (SpStringTableColumn evaluated: self display).

	^ { column }! !

!SpFilteringSelectableListPresenter methodsFor: 'api' stamp: ''!
selectItems: aCollection

	selectedItems := aCollection asSet.
	listPresenter selectItems: selectedItems asOrderedCollection! !

!SpFilteringSelectableListPresenter methodsFor: 'api' stamp: ''!
onActivation: aBlock

	onActivation := aBlock! !

!SpFilteringSelectableListPresenter methodsFor: 'initialization' stamp: ''!
initialize

	selectedItems := Set new.
	displayBlock := [ :anObject | anObject asString ].
	super initialize! !

!SpFilteringSelectableListPresenter methodsFor: 'private' stamp: ''!
selectFrom: fromIndex to: toIndex

	| newItems |
	newItems := fromIndex < toIndex
		ifTrue: [ listPresenter items copyFrom: fromIndex to: toIndex ]
		ifFalse: [ listPresenter items copyFrom: toIndex to: fromIndex ].
	
	selectedItems addAll: newItems.
	
	self onActivation ifNotNil: [ :valuable | 
		newItems do: [ :item | valuable cull: item ] ].
	
	listPresenter refresh! !

!SpFilteringSelectableListPresenter methodsFor: 'api' stamp: ''!
display

	^ displayBlock! !

!SpFilteringSelectableListPresenter methodsFor: 'api' stamp: ''!
onDeactivation: aBlock

	onDeactivation := aBlock! !

!SpFilteringSelectableListPresenter methodsFor: 'api' stamp: ''!
onActivation

	^ onActivation! !

!SpFilteringSelectableListPresenter methodsFor: 'private' stamp: ''!
toggleSelection

	| selectedItem |
	selectedItem := listPresenter selectedItem.
	(selectedItems includes: selectedItem)
		ifTrue: [ self deactivateItem: selectedItem ]
		ifFalse: [ self activateItem: selectedItem ].
	listPresenter refresh! !

!SpFilteringSelectableListPresenter methodsFor: 'api' stamp: ''!
onDeactivation

	^ onDeactivation! !

!SpFilteringSelectableListPresenter methodsFor: 'private' stamp: ''!
deactivateItem: anObject

	selectedItems remove: anObject.
	
	self onDeactivation ifNotNil: [ :valuable | valuable cull: anObject ]! !

!SpFilteringSelectableListPresenter methodsFor: 'api' stamp: ''!
display: aBlock

	displayBlock := aBlock.
	listPresenter columns: self listColumns! !

!SpFilteringSelectableListPresenter methodsFor: 'initialization' stamp: ''!
newListToFilter
	| table |
	
	table := self newTable. 
	table hideColumnHeaders.
	table columns: self listColumns.
	^ table! !

!SpFilteringSelectableListPresenter methodsFor: 'api' stamp: ''!
selectedItems

	^ selectedItems sorted: [ :a :b | (self items indexOf: a) < (self items indexOf: b) ]! !

!SpFilteringSelectableListPresenter methodsFor: 'api' stamp: ''!
selectItem: anObject

	self selectItems: (self selectedItems copyWith: anObject)! !

!SpFilteringSelectableListPresenter methodsFor: 'api' stamp: ''!
displayIcon: aBlock

	displayIconBlock := aBlock.
	listPresenter columns: self listColumns! !

!SpFilteringSelectableListPresenter methodsFor: 'private' stamp: ''!
activateAll

	| itemsToSelect |
	itemsToSelect := self items \ selectedItems.
	itemsToSelect ifEmpty: [ ^ self ].

	self selectItems: self items.

	self onActivation ifNotNil: [ :valuable | 
		itemsToSelect do: [ :item | valuable cull: item ] ]! !

!SpFilteringSelectableListPresenter methodsFor: 'private' stamp: ''!
activateItem: anObject

	selectedItems add: anObject.
	
	self onActivation ifNotNil: [ :valuable | valuable cull: anObject ]! !

!SpFilteringSelectableListPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	listPresenter
		bindKeyCombination: Character space
		toAction: [ self toggleSelection ].

	listPresenter selection whenSelectedIndexChangedDo: [ 
		:newIndex 
		:prevIndex | previousSelectedIndex := prevIndex ].

	listPresenter eventHandler whenMouseDownDo: [ :event | 
		event shiftPressed
			ifTrue: [ 
				self
					selectFrom: previousSelectedIndex
					to: listPresenter selection selectedIndex ]
			ifFalse: [ self toggleSelection ] ].

	listPresenter
		bindKeyCombination: $a meta
		toAction: [ self activateAll ]! !

!SpFixedProgressBarState commentStamp: ''!
Description
--------------------

I am a state of a ProgressBarPresenter managing the behavior of a fixed progress bar. I will have one value (between 0 and 1) and the progress will not change.

Examples
--------------------

	 ProgressBarFixed value: 0.1
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	valueHolder:		<aValueHolder> 		Value holder keeping the value I should be fixed on.
!
!SpFixedProgressBarState methodsFor: 'accessing' stamp: ''!
value: aNumber
	value := aNumber! !

!SpFixedProgressBarState methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
customizeMorphicBar: aProgressBarMorph
	aProgressBarMorph value: self value! !

!SpFixedProgressBarState methodsFor: 'initialization' stamp: ''!
initialize
	
	self class initializeSlots: self.
	super initialize.
	value := 0! !

!SpFixedProgressBarState methodsFor: 'api - events' stamp: ''!
whenValueChangedDo: aBlock
	self property: #value whenChangedDo: aBlock! !

!SpFixedProgressBarState methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!SpFixedProgressBarState class methodsFor: 'instance creation' stamp: ''!
value: aNumber
	^ self new
		value: aNumber;
		yourself! !

!SpFocusLostEventDefinition commentStamp: ''!
I define a "lost focus" (focus leaved the widget) event.
!
!SpFocusLostEventDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	anAdapter installFocusLostEvent: self to: aWidget! !

!SpFocusReceivedEventDefinition commentStamp: ''!
I define a "got focus" (focus received) event.
!
!SpFocusReceivedEventDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	anAdapter installFocusReceivedEvent: self to: aWidget! !

!SpFontStyle commentStamp: ''!
# Font property (`SpFontStyle`)

Font properties control how a component (morph) with font will draw the text.
I keep this properties: 

- name: The font name (it needs to be available in the list of fonts, e.g. "Source Code Pro") 
- size: The font point size.
- bold: Font is bold? (boolean, default ""false"")
- italic: Font is italic? (boolean, default ""false"")

## Usage
The identifier of font in the stylesheet is `Font`.

```language=Javascript
Font { 
 	#name: "Source Sans Pro",  
	#size: 12,
	#bold: false,
	#italic: false
}
```

## Predefined fonts
User can also point to the fonts pre-defined (comming from Settings).
To do that, is enough to access the property `predefinedFont`, and value can be one of the list: 

- `#default`
- `#code`
- `#ballon`
- `#button`
- `#halo`
- `#list`
- `#menu`

**NOTE:** Using `predefinedFont` will meke any other Font property defined to be ignored.

```language=Javascript
Font { 
 	#predefinedFont: #code
}
```
!
!SpFontStyle methodsFor: 'accessing' stamp: ''!
color: aColorOrSymbol

	color := aColorOrSymbol asStyleVariable! !

!SpFontStyle methodsFor: 'private' stamp: ''!
anyFontDecorator
	
	^ color notNil 
		or: [ size notNil 
		or: [ bold notNil 
		or: [ italic notNil ] ] ]! !

!SpFontStyle methodsFor: 'private' stamp: ''!
addFontToCache: aFont

	self class addFontToCache: aFont! !

!SpFontStyle methodsFor: 'accessing - variables' stamp: ''!
nameVariable

	^ self toVariable: name! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
bold

	^ self boldVariable value! !

!SpFontStyle methodsFor: 'accessing - variables' stamp: ''!
sizeVariable

	^ size! !

!SpFontStyle methodsFor: 'private' stamp: ''!
calculateDefinedFont
	| font |
	
	font := LogicalFont
		familyName: self calculateFontName
		pointSize: self calculateFontSize.

	self isItalic ifTrue: [ font forceItalicOrOblique ].
	self isBold ifTrue: [ font forceBold ].

	^ font! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
italic: aBoolean

	italic := aBoolean asStyleVariable! !

!SpFontStyle methodsFor: 'private' stamp: ''!
calculateFontName
	| var |
	
	var := self nameVariable.
	^ var isEnvironmentVariable 
		ifTrue: [ var familyName ] 
		ifFalse: [ var value ]! !

!SpFontStyle methodsFor: 'accessing - variables' stamp: ''!
boldVariable

	^ self toVariable: bold! !

!SpFontStyle methodsFor: 'private' stamp: ''!
definedFont
	| definedFont |

	(self predefinedFont notNil and: [ self anyFontDecorator not ]) ifTrue: [ 
		^ self obtainPredefinedFont  ].

	self withCachedFontDo: [ :aFont | ^ aFont ].
	
	definedFont := self calculateDefinedFont.
	self addFontToCache: definedFont.
	^ definedFont! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
name: aString

	name := aString asStyleVariable! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
bold: aBoolean

	bold := aBoolean asStyleVariable! !

!SpFontStyle methodsFor: 'private' stamp: ''!
calculateFontSize
	
	self sizeVariable ifNotNil: [ :aVariable |
		aVariable value ifNotNil: [ 
			^ self sizeVariable scaledValue ] ].
	self nameVariable isEnvironmentVariable ifTrue: [ 
		^ self nameVariable pointSize * self currentWorld displayScaleFactor ].
	self hasPredefinedFont ifTrue: [ 
		^ self obtainPredefinedFont pointSize * self currentWorld displayScaleFactor ].

	^ nil! !

!SpFontStyle methodsFor: 'testing' stamp: ''!
isItalic
	"property may be nil, we verify with strict comparisson"
	
	^ self italicVariable value == true ! !

!SpFontStyle methodsFor: 'accessing - variables' stamp: ''!
italicVariable

	^ italic! !

!SpFontStyle methodsFor: 'private' stamp: ''!
withCachedFontDo: aBlock

	self class fontCache 
		detect: [ :each | 
			each familyName = self name 
				and: [ each pointSize = self scaledSize 
				and: [ each isBold = self isBold
				and: [ each isItalic = self isItalic ] ] ] ]
		ifFound: aBlock! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
italic

	^ self italicVariable value! !

!SpFontStyle methodsFor: 'private' stamp: ''!
hasPredefinedFont

	^ self predefinedFont notNil! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
predefinedFont

	^ predefinedFont! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
scaledSize

	^ self sizeVariable scaledValue! !

!SpFontStyle methodsFor: 'operations' stamp: ''!
mergeWith: otherProperty
	| merged |

	merged := super mergeWith: otherProperty.

	"Ensure predefined font will be overriden even if nil."
	otherProperty name 
		ifNotNil: [
			merged 
				writeSlotNamed: 'predefinedFont' value: nil;
				writeSlotNamed: 'name' value: (otherProperty readSlotNamed: 'name') ].
		
	^ merged! !

!SpFontStyle methodsFor: 'private' stamp: ''!
obtainPredefinedFont

	^ StandardFonts perform: (self predefinedFont value, 'Font') asSymbol! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
size

	^ self sizeVariable value! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
size: aNumber

	size := aNumber asStyleVariable! !

!SpFontStyle methodsFor: 'accessing - variables' stamp: ''!
colorVariable
  "This is meant to set the text color.
	This property can be expressed as 
	- a STON map: ==Color { #red : 1., #green : 0, #blue : 0, #alpha : 1 }==
	- a named selector: ==#red==
	- an hex string: =='FF0000'=="

	^ self toVariable: color! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
name

	^ self nameVariable value! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
predefinedFont: aSymbol

	predefinedFont := aSymbol! !

!SpFontStyle methodsFor: 'operations' stamp: ''!
applyTo: aMorph

	"not all morphs understand font, I need to verify it (which is not cool verifying a 
	 selector but other way would be to define #font: in Morph and I do not want that)"
	(aMorph respondsTo: #font:) ifFalse: [ ^ self ].
	
	aMorph font: self definedFont.
	
	self color ifNil: [ ^ self ].
	"Again, not all morphs understand #textColor: and I need to verify it is there."
	(aMorph respondsTo: #textColor:) ifFalse: [ ^ self ].
	aMorph textColor: self colorVariable valueAsColor! !

!SpFontStyle methodsFor: 'testing' stamp: ''!
isBold
	"property may be nil, we verify with strict comparisson"
	
	^ self boldVariable value == true! !

!SpFontStyle methodsFor: 'accessing' stamp: ''!
color
  "This is meant to set the text color.
	This property can be expressed as 
	- a STON map: ==Color { #red : 1., #green : 0, #blue : 0, #alpha : 1 }==
	- a named selector: ==#red==
	- an hex string: =='FF0000'=="

	^ self colorVariable value! !

!SpFontStyle class methodsFor: 'private' stamp: ''!
addFontToCache: aFont

	self fontCache add: aFont! !

!SpFontStyle class methodsFor: 'private' stamp: ''!
fontCache

	^ FontCache ifNil: [ FontCache := WeakSet new ]! !

!SpFontStyle class methodsFor: 'ston-core' stamp: ''!
stonName
	
	^ 'Font'! !

!SpGeneratorListModel commentStamp: ''!
A list model to be used with a generator.

See `SpGeneratorListModel class>>#example`
See `Generator` class.
!
!SpGeneratorListModel methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self collection: OrderedCollection new.
	size := 10000! !

!SpGeneratorListModel methodsFor: 'accessing' stamp: ''!
generator: aGenerator

	generator := aGenerator.! !

!SpGeneratorListModel methodsFor: 'testing' stamp: ''!
hasElementAt: index

	self at: index ifAbsent: [ ^ false ].
	^ true! !

!SpGeneratorListModel methodsFor: 'accessing' stamp: ''!
size

	^ size! !

!SpGeneratorListModel methodsFor: 'accessing' stamp: ''!
at: anIndex

	^ self 
		at: anIndex 
		ifAbsent: [ self error: 'Index not found' ]! !

!SpGeneratorListModel methodsFor: 'accessing' stamp: ''!
generator
	^ generator! !

!SpGeneratorListModel methodsFor: 'accessing' stamp: ''!
at: anIndex ifAbsent: aBlock

	[ collection size < anIndex ] 
	whileTrue: [ 
		self generator atEnd ifTrue: [ ^ aBlock value ].
		collection add: self generator next.
		self generator atEnd ifTrue: [ size := collection size ] ].
	^ collection at: anIndex! !

!SpGeneratorListModel class methodsFor: 'examples' stamp: ''!
example
	| items generator |

	items := ($a to: $z) asArray.
	generator := Generator on: [ :g | items do: [ :each | 
		each crTrace.
		g yield: each ] ].

	SpListPresenter new 
		model: (self new 
			generator: generator;
			yourself);
		openWithSpec.
! !

!SpGeometryStyle commentStamp: ''!
# Geometry properties (`SpGeometryStyle`)

Geometry properties controls how the component (morph) will be arranged within its layout.

- hResizing: the component can be resized horizontally? (boolean, default depends on how the morph behaves outside spec)
- vResizing: the component can be resized vertically? (boolean, default depends on how the morph behaves outside spec)
- width: fixed width of the component.
- height: fixed height of the component.
- minWidth: minimum width of the component (to use when `hResizing=true`) 
- minHeight: minimum height of the component (to use when `vResizing=true`) 
- maxWidth: maximum width of the component (to use when `hResizing=true`) 
- maxHeight: maximum height of the component (to use when `vResizing=true`) 

## Usage
The identifier of geometry in the stylesheet is `Geometry`.

```
Geometry { 
	#hResizing: false,
	#vResizing: false,
	#width: 100,
	#height: 25,
	#minWidth: 50,
	#minHeight: 25,
	#maxWidth: 150,
	#maxHeight: 25
}
```!
!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
minWidth: aNumber

	minWidth := aNumber asStyleVariable! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
width: aNumber

	width := aNumber asStyleVariable! !

!SpGeometryStyle methodsFor: 'accessing - variables' stamp: ''!
widthVariable

	^ self toVariable: (width ifNil: [ 0 ])! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
width

	^ self widthVariable scaledValue! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
hResizing

	^ self hResizingVariable value! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
minWidth

	^ self minWidthVariable 
		ifNotNil: [ :aVariable | aVariable scaledValue ]
		ifNil: [ 0 ]! !

!SpGeometryStyle methodsFor: 'private' stamp: ''!
resizingStringFor: expand

	^ expand
		ifTrue: [ #spaceFill ]
		ifFalse: [ #rigid ]! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
minHeight: aNumber
	
	minHeight := aNumber asStyleVariable! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
hResizing: aBoolean

	hResizing := aBoolean asStyleVariable! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
vResizing: aBoolean

	vResizing := aBoolean asStyleVariable! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
height

	^ self heightVariable scaledValue! !

!SpGeometryStyle methodsFor: 'private' stamp: ''!
geometryValueBetween: baseNumber and: otherNumber

	^ baseNumber = 0 
		ifTrue: [ otherNumber ]
		ifFalse: [ baseNumber ]! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
height: aNumber
	
	height := aNumber asStyleVariable! !

!SpGeometryStyle methodsFor: 'accessing - variables' stamp: ''!
heightVariable

	^ self toVariable: (height ifNil: [ 0 ])! !

!SpGeometryStyle methodsFor: 'accessing - variables' stamp: ''!
minHeightVariable

	^ self toVariable: minHeight! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
minHeight

	^ self minHeightVariable
		ifNotNil: [ :aVariable | aVariable scaledValue ]
		ifNil: [ 0 ]	! !

!SpGeometryStyle methodsFor: 'accessing - variables' stamp: ''!
minWidthVariable

	^ self toVariable: minWidth! !

!SpGeometryStyle methodsFor: 'operations' stamp: ''!
applyTo: aMorph

	(self widthVariable preferredScaledValueWith: aMorph width) 
		ifNotNil: [ :aNumber | aMorph width: aNumber ].
	(self heightVariable preferredScaledValueWith: aMorph height) 
		ifNotNil: [ :aNumber | aMorph height: aNumber ].
	self minWidthVariable
		ifNotNil: [ :aVariable | aMorph minWidth: aVariable scaledValue ].
	self minHeightVariable
		ifNotNil: [ :aVariable | aMorph minHeight: aVariable scaledValue ].
	self hResizingVariable 
		ifNotNil: [ :aVariable | aMorph hResizing: (self resizingStringFor: aVariable value) ].
	self vResizingVariable 
		ifNotNil: [ :aVariable | aMorph vResizing: (self resizingStringFor: aVariable value) ]! !

!SpGeometryStyle methodsFor: 'testing' stamp: ''!
isGeometry

	^ true! !

!SpGeometryStyle methodsFor: 'accessing' stamp: ''!
vResizing

	^ self vResizingVariable value! !

!SpGeometryStyle methodsFor: 'accessing - variables' stamp: ''!
vResizingVariable

	^ self toVariable: vResizing! !

!SpGeometryStyle methodsFor: 'accessing - variables' stamp: ''!
hResizingVariable

	^ self toVariable: hResizing! !

!SpGeometryStyle class methodsFor: 'ston-core' stamp: ''!
stonName
	
	^ 'Geometry'! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
vAlignEnd
	"Sets the vertical align property to END. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment end! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
vAlignCenter
	"Sets the vertical align property to CENTER. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment center! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
hAlign: anAlignment
	"Sets the horizontal align property. See #hAlign to details"
	
	hAlign := anAlignment! !

!SpGridAxisConstraints methodsFor: 'testing' stamp: ''!
hasAlignment
	"Answer whether the component has any alignment defined"

	^ self hasVAlign or: [ self hasHAlign ]! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
vAlignStart
	"Sets the vertical align property to START. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment start! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
vAlign: anAlignment
	"Sets the vertical align property. See #vAlign to details"

	vAlign := anAlignment! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
hAlignStart
	"Sets the horizontal align property to START. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment start! !

!SpGridAxisConstraints methodsFor: 'testing' stamp: ''!
hasVAlign
	"Answer whether the component has a vertical alignment defined"

	^ vAlign notNil! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
beNotExpand 

	self expand: false! !

!SpGridAxisConstraints methodsFor: 'private' stamp: ''!
expand
	^ expand! !

!SpGridAxisConstraints methodsFor: 'testing' stamp: ''!
hasHAlign
	"Answer whether the component has an horizontal alignment defined"

	^ hAlign notNil! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
vAlign
	"I define the vertical alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use vAlignStart, vAlignCenter, vAlignEnd"

	^ vAlign! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
beExpand 

	self expand: true! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
hAlign
	"I define the horizontal alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use hAlignStart, hAlignCenter, hAlignEnd"

	^ hAlign! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
hAlignCenter
	"Sets the horizontal align property to CENTER. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment center! !

!SpGridAxisConstraints methodsFor: 'private' stamp: ''!
expand: anObject
	expand := anObject! !

!SpGridAxisConstraints methodsFor: 'testing' stamp: ''!
isExpand

	^ expand == true! !

!SpGridAxisConstraints methodsFor: 'accessing' stamp: ''!
hAlignEnd
	"Sets the horizontal align property to END. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment end! !

!SpGridAxisConstraints class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpGridAxisConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpGridAxisConstraints class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpGridAxisConstraints class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpGridAxisConstraints class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpGridAxisConstraints class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpGridAxisConstraints class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpGridAxisConstraints class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpGridAxisConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpGridAxisConstraints class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpGridAxisConstraints class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpGridAxisConstraints class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpGridAxisConstraints class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpGridAxisConstraints class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpGridAxisConstraints class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpGridAxisConstraints class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpGridAxisConstraints class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpGridAxisConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpGridAxisConstraints class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpGridAxisConstraints class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpGridAxisConstraints class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpGridAxisConstraints class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpGridAxisConstraints class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpGridAxisConstraints class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpGridAxisConstraints class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpGridAxisConstraints class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpGridAxisConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpGridAxisConstraints class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpGridAxisConstraints class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpGridConstraints commentStamp: ''!
I am the constraints in which an element is placed into a grid layout.
I have a position and a span.!
!SpGridConstraints methodsFor: 'accessing' stamp: ''!
position

	^ position! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
vAlignEnd
	"Sets the vertical align property to END. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment end! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
row

	^ self position y! !

!SpGridConstraints methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self position: 1@1.
	self span: 1@1! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
span: anObject
	span := anObject! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
vAlignCenter
	"Sets the vertical align property to CENTER. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment center! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
hAlign: anAlignment
	"Sets the horizontal align property. See #hAlign to details"
	
	hAlign := anAlignment! !

!SpGridConstraints methodsFor: 'testing' stamp: ''!
hasAlignment
	"Answer whether the component has any alignment defined"

	^ self hasVAlign or: [ self hasHAlign ]! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
vAlignStart
	"Sets the vertical align property to START. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment start! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
vAlign: anAlignment
	"Sets the vertical align property. See #vAlign to details"

	vAlign := anAlignment! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
hAlignStart
	"Sets the horizontal align property to START. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment start! !

!SpGridConstraints methodsFor: 'testing' stamp: ''!
hasVAlign
	"Answer whether the component has a vertical alignment defined"

	^ vAlign notNil! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
column

	^ self position x! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
columnSpan

	^ self span x! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
position: aPoint

	position := aPoint! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
rowSpan

	^ self span y! !

!SpGridConstraints methodsFor: 'testing' stamp: ''!
hasHAlign
	"Answer whether the component has an horizontal alignment defined"

	^ hAlign notNil! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
vAlign
	"I define the vertical alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use vAlignStart, vAlignCenter, vAlignEnd"

	^ vAlign! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
span
	^ span! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
hAlign
	"I define the horizontal alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use hAlignStart, hAlignCenter, hAlignEnd"

	^ hAlign! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
hAlignCenter
	"Sets the horizontal align property to CENTER. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment center! !

!SpGridConstraints methodsFor: 'accessing' stamp: ''!
hAlignEnd
	"Sets the horizontal align property to END. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment end! !

!SpGridConstraints class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpGridConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpGridConstraints class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpGridConstraints class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpGridConstraints class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpGridConstraints class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpGridConstraints class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpGridConstraints class methodsFor: 'instance creation' stamp: ''!
at: aPoint span: spanPoint

	^ self new 
		position: aPoint;
		span: spanPoint;
		yourself! !

!SpGridConstraints class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpGridConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpGridConstraints class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpGridConstraints class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpGridConstraints class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpGridConstraints class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpGridConstraints class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpGridConstraints class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpGridConstraints class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpGridConstraints class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpGridConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpGridConstraints class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpGridConstraints class methodsFor: 'instance creation' stamp: ''!
at: aPoint

	^ self new 
		position: aPoint;
		yourself! !

!SpGridConstraints class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpGridConstraints class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpGridConstraints class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpGridConstraints class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpGridConstraints class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpGridConstraints class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpGridConstraints class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpGridConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpGridConstraints class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpGridConstraints class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpGridLayout commentStamp: ''!
I am a grid layout. 
As my name tells, I can place my elements in a grid, following some constraints: 

- a position is mandatory
- a span can be added if desired

A grid layout is typically used while doing "form-like" presenters, for example, we can 
do something like this: 

```
--------------------------
| Name:      | ######### |
--------------------------
| Password:  | ######### |
--------------------------
|       [Accept] [Cancel]| 
--------------------------
```

You can achieve this in several ways, but a simple one would be where `#nameText` refer to a getter method.


```
SpGridLayout new 
	add: 'Name:' 			at: 1@1;
	add: #nameText 			at: 2@1
	add: 'Password:' 		at: 1@2;
	add: #passwordText 	at: 2@2;
	add: (SpBoxLayout newHorizontal
			addLast: #acceptButton;
			addLast: #cancelButton;
			yourself)
		at: 1@3 
		span: 2@1;
	yourself
```

Note that using a string as in 
```
SpecGridLayout new 
	add: 'Name:' 			at: 1@1;
```
automatically add a label. 


In addition as you can see that we can have other layouts taking several cell elements as in the following where the SpBoxLayout is taking two cells of the grid.
```
add: (SpBoxLayout newHorizontal
			addLast: #acceptButton;
			addLast: #cancelButton;
			yourself)
		at: 1@3 
		span: 2@1;
```



!
!SpGridLayout methodsFor: 'api' stamp: ''!
build: aBlock

	aBlock value: (SpGridLayoutBuilder on: self)! !

!SpGridLayout methodsFor: 'api' stamp: ''!
borderWidth

	^ borderWidth ifNil: [ self class defaultBorderWidth ]! !

!SpGridLayout methodsFor: 'api' stamp: ''!
children

	^ children! !

!SpGridLayout methodsFor: 'api - adding' stamp: ''!
replaceAt: aPoint with: aPresenter
	"This is just a synonym of SpGridLayout>>#add:at:, added for clarity"
	
	^ self 
		add: aPresenter
		at: aPoint! !

!SpGridLayout methodsFor: 'api' stamp: ''!
rowConstraintsAt: rowNumber

	^ rowConstraints 
		at: rowNumber 
		ifAbsent: [ nil ]! !

!SpGridLayout methodsFor: '*Spec2-Tests' stamp: ''!
at: aPoint
	
	^ childrenByPosition at: aPoint! !

!SpGridLayout methodsFor: 'api - adding' stamp: ''!
add: aName at: aPoint

	^ self 
		add: aName 
		at: aPoint
		span: 1@1! !

!SpGridLayout methodsFor: 'api' stamp: ''!
columnSpacing

	^ columnSpacing ifNil: [ self class defaultColumnSpacing ]! !

!SpGridLayout methodsFor: 'api' stamp: ''!
column: aNumber withConstraints: aBlock
	| constraints |

	constraints := SpGridAxisConstraints new.
	aBlock value: constraints.
	columnConstraints 
		at: aNumber
		put: constraints! !

!SpGridLayout methodsFor: 'private' stamp: ''!
adapterName

	^ #GridAdapter! !

!SpGridLayout methodsFor: 'api' stamp: ''!
rowSpacing

	^ rowSpacing ifNil: [ self class defaultRowSpacing ]! !

!SpGridLayout methodsFor: 'api' stamp: ''!
beColumnNotHomogeneous

	self columnHomogeneous: false! !

!SpGridLayout methodsFor: 'api' stamp: ''!
columnSpacing: anObject
	columnSpacing := anObject! !

!SpGridLayout methodsFor: 'api - adding' stamp: ''!
add: aChild withConstraints: aBlock

	super add: aChild withConstraints: aBlock.
	childrenByPosition at: (children at: aChild) position put: aChild.
	self announceChildAdded: aChild.! !

!SpGridLayout methodsFor: 'api' stamp: ''!
rowSpacing: anObject
	rowSpacing := anObject! !

!SpGridLayout methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	self beColumnHomogeneous.
	self beRowNotHomogeneous.
	columnConstraints := Dictionary new.
	rowConstraints := Dictionary new.
	childrenByPosition := Dictionary new.! !

!SpGridLayout methodsFor: 'api' stamp: ''!
borderWidth: anObject
	borderWidth := anObject! !

!SpGridLayout methodsFor: 'testing' stamp: ''!
isColumnHomogeneous
	^ columnHomogeneous! !

!SpGridLayout methodsFor: 'private' stamp: ''!
columnHomogeneous: anObject
	columnHomogeneous := anObject! !

!SpGridLayout methodsFor: 'api' stamp: ''!
row: aNumber withConstraints: aBlock
	| constraints |

	constraints := SpGridAxisConstraints new.
	aBlock value: constraints.
	rowConstraints 
		at: aNumber
		put: constraints! !

!SpGridLayout methodsFor: 'api' stamp: ''!
beColumnHomogeneous

	self columnHomogeneous: true! !

!SpGridLayout methodsFor: 'private' stamp: ''!
constraintsClass

	^ SpGridConstraints! !

!SpGridLayout methodsFor: 'api - adding' stamp: ''!
add: aName at: aPoint span: spanPoint

	childrenByPosition at: aPoint ifPresent: [ :e |
		"Remove element at the same position"
		self remove: e ].

	^ self 
		add: aName 
		withConstraints: [ :constraints |
			constraints 
				position: aPoint;
				span: spanPoint ]! !

!SpGridLayout methodsFor: 'api' stamp: ''!
beRowNotHomogeneous

	self rowHomogeneous: false! !

!SpGridLayout methodsFor: 'testing' stamp: ''!
isRowHomogeneous
	^ rowHomogeneous! !

!SpGridLayout methodsFor: 'api' stamp: ''!
beRowHomogeneous

	self rowHomogeneous: true! !

!SpGridLayout methodsFor: 'api' stamp: ''!
columnConstraintsAt: columnNumber

	^ columnConstraints 
		at: columnNumber 
		ifAbsent: [ nil ]! !

!SpGridLayout methodsFor: 'private' stamp: ''!
rowHomogeneous: anObject
	rowHomogeneous := anObject! !

!SpGridLayout class methodsFor: 'instance creation' stamp: ''!
build: aBlock

	^ self new 
		build: aBlock;
		yourself! !

!SpGridLayout class methodsFor: 'initialization' stamp: ''!
defaultBorderWidth

	^ 20! !

!SpGridLayout class methodsFor: 'initialization' stamp: ''!
defaultRowSpacing

	^ 5! !

!SpGridLayout class methodsFor: 'initialization' stamp: ''!
defaultColumnSpacing

	^ 10! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveElementRemovesFromAdapter

	| element |
	layout add: (element := SpButtonPresenter new) at: 1@1.
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddElementAddsToAdapter

	layout add: SpButtonPresenter new at: 1@1.
	self deny: self adapter isEmpty! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddElementAfterOpenAddsToAdapter

	layout add: SpButtonPresenter new at: 1@1.
	self openInstance.
	
	layout add: SpButtonPresenter new at: 1@2.
	self assert: self adapter children size equals: 2! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testBeColumnNotHomogeneous

	layout 
		beColumnNotHomogeneous;
		add: 'Test' at: 1@1; 
		add: 'Other label test' at: 2@1.
		
	self openInstance.
	
	self 
		deny: presenter adapter widget submorphs first width 
		equals: presenter adapter widget submorphs second width! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testBeRowNotHomogeneous
	| testMorph |
	
	testMorph := Morph new
		vResizing: #rigid;
		extent: 40@40;
		yourself.
	
	layout 
		beRowNotHomogeneous;
		add: 'Test' at: 1@1; 
		add: (presenter newMorph morph: testMorph) at: 1@2.
		
	self openInstance.
	
	self 
		deny: presenter adapter widget submorphs first height 
		equals: presenter adapter widget submorphs second height! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testColumnSpanColumnHomogeneous

	layout 
		beColumnHomogeneous;
		add: 'Test' at: 1@1 span: 2@1; 
		add: 'Other label test' at: 1@2; add: 'span column'at: 2@2.
		
	self openInstance.
	
	self 
		assert: presenter adapter widget submorphs first width 
		equals: (
			(presenter adapter widget submorphs second width) 
			+ (presenter adapter widget submorphs third width))! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddAtSamePositionTwiceReplacesChild

	| first second |
	layout add: (first := SpButtonPresenter new) at: 1@1.
	layout add: (second := SpButtonPresenter new) at: 1@1.
	self assert: self adapter children first equals: second adapter widget! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRowSpanRowNotHomogeneous
	| testMorph |
	
	testMorph := Morph new
		vResizing: #rigid;
		extent: 40@40;
		yourself.
	
	layout 
		beRowNotHomogeneous;
		add: 'Test 1' at: 1@1; add: (presenter newMorph morph: testMorph) at: 2@1 span: 1@2;
		add: 'Test 2' at: 1@2.
		
	self openInstance.
	
	self 
		assert: presenter adapter widget submorphs second height 
		equals: 
			presenter adapter widget submorphs first height 
			+ presenter adapter widget submorphs third height! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testBeColumnHomogeneous

	layout 
		beColumnHomogeneous;
		add: 'Test' at: 1@1; 
		add: 'Other label test' at: 2@1.
		
	self openInstance.
	
	self 
		assert: presenter adapter widget submorphs first width 
		equals: presenter adapter widget submorphs second width! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddAtSamePositionTwiceSetsChildrenSingleTime

	layout add: (SpButtonPresenter new) at: 1@1.
	layout add: (SpButtonPresenter new) at: 1@1.
	self assert: self adapter children size equals: 1! !

!SpGridLayoutAdapterTest methodsFor: 'accessing' stamp: ''!
newLayout

	^ SpGridLayout new! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testBeRowHomogeneous

	layout 
		beRowHomogeneous;
		add: 'Test' at: 1@1; 
		add: (presenter newMorph morph: (Morph new extent: 40@40)) at: 1@2.
		
	self openInstance.
	
	self 
		assert: presenter adapter widget submorphs first height 
		equals: presenter adapter widget submorphs second height! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testColumnSpanColumnNotHomogeneous

	layout 
		beColumnNotHomogeneous;
		add: 'Test' at: 1@1 span: 2@1; 
		add: 'Other' at: 1@2; add: 'span column, larger'at: 2@2.
		
	self openInstance.
	
	"the first column width is equal to the sum of two columns"
	self 
		assert: presenter adapter widget submorphs first width 
		equals: (
			(presenter adapter widget submorphs second width) 
			+ (presenter adapter widget submorphs third width)).
	"the first column still needs to be smaller than the first"
	self 
		assert: presenter adapter widget submorphs second width < (presenter adapter widget submorphs third width)! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveElementAddedAfterOpenRemovesFromAdapter

	| element |
	layout add: (element := SpButtonPresenter new) at: 1@1.
	self openInstance.
	
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpGridLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRowSpanRowHomogeneous
	| testMorph |
	
	testMorph := Morph new
		vResizing: #rigid;
		extent: 40@40;
		yourself.
	
	layout 
		beRowHomogeneous;
		add: 'Test 1' at: 1@1; add: (presenter newMorph morph: testMorph) at: 2@1 span: 1@2;
		add: 'Test 2' at: 1@2.
		
	self openInstance.
	self 
		assert: presenter adapter widget submorphs second height 
		equals: 
			presenter adapter widget submorphs first height 
			+ presenter adapter widget submorphs third height! !

!SpGridLayoutBuilder commentStamp: ''!
I build Grid Layouts using a fluent API.
You do not need to give elements position on the grid but you rather add elements in order (raw by raw) and you tell me when I need to go to next raw.

Example:
SpGridLayout build: [ :builder |
	builder
		add: 'Name:';
		add: #nameTextInput;
		nextRow;
		add: 'Surname:';
		add: #surnameTextInput;
		nextRow ]!
!SpGridLayoutBuilder methodsFor: 'accessing' stamp: ''!
layout
	^ layout ! !

!SpGridLayoutBuilder methodsFor: 'private' stamp: ''!
resetCurrentColumn
	currentColumn := 0.! !

!SpGridLayoutBuilder methodsFor: 'api' stamp: ''!
add: aChild
	layout add: aChild at: self nextColumn @ self currentRow.! !

!SpGridLayoutBuilder methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	currentRow := 1.
	self resetCurrentColumn.! !

!SpGridLayoutBuilder methodsFor: 'private' stamp: ''!
nextColumn
	^ currentColumn := currentColumn + 1! !

!SpGridLayoutBuilder methodsFor: 'api' stamp: ''!
nextRow
	currentRow := currentRow + 1.
	self resetCurrentColumn.! !

!SpGridLayoutBuilder methodsFor: 'private' stamp: ''!
currentRow
	^ currentRow! !

!SpGridLayoutBuilder methodsFor: 'initialization' stamp: ''!
initializeLayout: aGridLayout

	layout := aGridLayout.
	self initialize! !

!SpGridLayoutBuilder class methodsFor: 'instance creation' stamp: ''!
on: aGridLayout

	^ self basicNew
		initializeLayout: aGridLayout;
		yourself! !

!SpGridLayoutBuilderTest methodsFor: 'tests' stamp: ''!
testBuilderAddsElementsOnRaw
	| layout presenters |
	
	presenters := self newPresenters: 3.
	layout := SpGridLayout build: [ :builder | 
		builder 
			add: presenters first;
			add: presenters second;
			add: presenters third ].
	
	self
		assert: (layout at: 1@1)
		equals: presenters first.
	self
		assert: (layout at: 2@1)
		equals: presenters second.
	self
		assert: (layout at: 3@1)
		equals: presenters third.! !

!SpGridLayoutBuilderTest methodsFor: 'instance creation' stamp: ''!
newPresenters: nbPresesenters

	^ (1 to: nbPresesenters)
		 collect: [ :index | SpPresenter new ] as: Array
! !

!SpGridLayoutBuilderTest methodsFor: 'tests' stamp: ''!
testBuilderCanAddElementsOnMultipleRaws
	| layout presenters |
	
	presenters := self newPresenters: 5.
	layout := SpGridLayout build: [ :builder | 
		builder 
			add: presenters first;
			add: presenters second;
			nextRow;
			add: presenters third;
			nextRow;
			add: presenters fourth;
			add: presenters fifth ].
	
	self
		assert: (layout at: 1@1)
		equals: presenters first.
	self
		assert: (layout at: 2@1)
		equals: presenters second.
	self
		assert: (layout at: 1@2)
		equals: presenters third.
	self
		assert: (layout at: 1@3)
		equals: presenters fourth.
	self
		assert: (layout at: 2@3)
		equals: presenters fifth.! !

!SpGridLayoutBuilderTest methodsFor: 'tests' stamp: ''!
testNewBuilderReturnsGridLayout
	| layout |
	layout := SpGridLayout build: [ :builder | ].
	
	self
		assert: layout class
		equals: SpGridLayout
		! !

!SpGridLayoutTest methodsFor: 'tests' stamp: ''!
testInitialStatus
	| layout |

	layout := SpGridLayout new.
	
	self assert: layout isColumnHomogeneous.	
	self deny: layout isRowHomogeneous.
	self assert: layout columnSpacing equals: 10.
	self assert: layout rowSpacing equals: 5.
	self assert: layout borderWidth equals: 20! !

!SpHeaderCellMorph commentStamp: ''!
I am a header cell.
I am used to allow a header to have some extra properties (sort, etc.).

Instead using a FTHeaderColumnCellMorph I extent FTIndentedCellMorph becaue I need the text to be indented.!
!SpHeaderCellMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self listCentering: #left.
	self indentBy: self class indent! !

!SpHeaderCellMorph methodsFor: 'utilities' stamp: ''!
prepareAsSortableColumn: aColumn

	! !

!SpHeaderCellMorph class methodsFor: 'accessing' stamp: ''!
indent

	^ 2! !

!SpHelpTopics commentStamp: ''!
A SpecHelpTopics is the main class which holds the documentation of Spec. This documentation can be accessed from the Help Browser.
See class side for selectors.
!
!SpHelpTopics class methodsFor: 'pages' stamp: ''!
hookingWithTheInspector
	^HelpTopic 	
		title: 'Inspector'
		contents: 'Pharo offers a Spec-based inspector. Inspecting an object opens an inspector that is built using Spec.

You can particularize the inspector in numerous way. For example, consider the following code:

```
OrderedCollection>>inspectorText
	<inspectorPresentationOrder: 90 title: ''My description''>
	^ SpTextPresenter new
		text: ''OrderedCollection of size = '', self size asString;
		yourself.
```

After having defined this method, inspecting the expression `#(1 2 3 5) asOrderedCollection` shows the inspector with a new textual pane.


A Roassal view can also be hooked, as follow:

```
OrderedCollection>>inspectorCanvas2
	<inspectorPresentationOrder: 90 title: ''Visualization''>
	| canvas shapes |
	canvas := RSCanvas new.
	shapes := (self collect: [ :obj | RSBox new model: obj; size: 20 ]) asGroup.
	canvas addAll: shapes.
	RSGridLayout on: shapes.
	
	^ SpRoassal3InspectorPresenter new
		canvas: canvas;
		yourself
```

The default behavior of the Spec inspector is to show an evaluation pane. You can remove it by simply defining the method:

```
OrderedCollection>>inspectorCanvas2Context: aContext
	aContext withoutEvaluator
```

This method follow the naming convention. You simple need to use the method name that define the visualization and add `Context:`.
'! !

!SpHelpTopics class methodsFor: 'accessing' stamp: ''!
key
	^'Spec'! !

!SpHelpTopics class methodsFor: 'accessing' stamp: ''!
pages
	^#(introduction terminology #SpExamples #SpTheHeartOfSpec #SpLayouts #hookingWithTheInspector)! !

!SpHelpTopics class methodsFor: 'accessing' stamp: ''!
bookName
	^ 'Spec'! !

!SpHelpTopics class methodsFor: 'pages' stamp: ''!
introduction
	^HelpTopic 	
		title: 'About Spec'
		contents: 'Spec has been originally developed by B. Van Ryseghem based on an idea of S. Ducasse. It is now maintained by the community and the pharo core team.

Spec is an attempt to support UI logic reuse. Spec is influenced by VisualWorks and Dolphin MVP in the sense that it recognizes the need for a Presenter or Application-Model class, in Spec called SpPresenter that manages the logic and the link between widgets and domain objects. Spec, following the tradition, uses value holders, simple object raising announcements when their values, often domain objects, change.'! !

!SpHelpTopics class methodsFor: 'pages' stamp: ''!
terminology
	^HelpTopic
		title: 'Terminology'
		contents: 'To avoid possible misunderstandings due to confusion in terminology, we first define the following four terms, which will be used frequently:

UI Element: an interactive graphical element displayed as part of the graphical user interface.

UI Model: an object that contains the state and behavior of one or several UI elements.

Widget: the union of a UI Element and its UI model.

Basic Widgets: low level widgets like'
		! !

!SpHorizontalBoxLayoutAdapterTest methodsFor: 'accessing' stamp: ''!
newLayout

	^ SpBoxLayout newLeftToRight! !

!SpHorizontalBoxLayoutTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	layout := SpBoxLayout newLeftToRight.
	presenter layout: layout! !

!SpHorizontalBoxLayoutTest methodsFor: 'tests' stamp: ''!
testReplaceWithFixedWidth
	| p1 toReplace p3 replacement |

	layout add: (p1 := SpLabelPresenter new).
	layout add: (toReplace := SpLabelPresenter new) width: 100.
	layout add: (p3 := SpLabelPresenter new).
	
	self assert: layout children second equals: toReplace.
	
	replacement := SpButtonPresenter new.
	layout replace: toReplace with: replacement.
	
	self assert: layout children second equals: replacement.
	self assert: layout children size equals: 3.
	self assert: layout children equals: { p1. replacement. p3 }! !

!SpHorizontalBoxLayoutTest methodsFor: 'tests' stamp: ''!
testPresenterExtentFollowsChildrenExtent
	| label button |

	layout 
		add: ((label := presenter newLabel) label: 'Label1');
		add: ((button := presenter newButton) label: 'Button1').
		
	self openInstance.
	
	self assert: (self widthOf: presenter) >= ((self widthOf: label) + (self widthOf: button)).
	self assert: (self heightOf: presenter) >= ((self heightOf: label) max: (self heightOf: button))! !

!SpHorizontalBoxLayoutTest methodsFor: 'tests' stamp: ''!
testReplaceWithFixedWidthComposed
	| p1 layoutToReplace toReplace p3 replacement |

	layout add: (p1 := SpLabelPresenter new) width: 100.
	layout add: ((layoutToReplace := SpBoxLayout newLeftToRight)  
		add: (toReplace := SpLabelPresenter new) width: 100;
		add: (SpLabelPresenter new) width: 100;
		yourself).
	layout add: (p3 := SpLabelPresenter new) width: 100.
	
	replacement := SpButtonPresenter new.
	layoutToReplace 
		replace: toReplace 
		with: replacement.
	
	self assert: layout children second children first equals: replacement! !

!SpHorizontalBoxLayoutTest methodsFor: 'tests' stamp: ''!
testReplaceWithFixedWidthAllFixed
	| p1 toReplace p3 replacement |

	layout add: (p1 := SpLabelPresenter new) width: 100.
	layout add: (toReplace := SpLabelPresenter new) width: 100.
	layout add: (p3 := SpLabelPresenter new) width: 100.
	
	self assert: layout children second equals: toReplace.
	
	replacement := SpButtonPresenter new.
	layout replace: toReplace with: replacement.
	
	self assert: layout children second equals: replacement.
	self assert: layout children size equals: 3.
	self assert: layout children equals: { p1. replacement. p3 }! !

!SpHorizontalLayoutDirection methodsFor: 'factory' stamp: ''!
newWidgetOn: anAdapter

	^ anAdapter newHorizontal! !

!SpHorizontalLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
recalculatePages: anAdaptor

	^ anAdaptor recalculatePageWidths! !

!SpHorizontalLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
addPadding: aNumber toMorph: aMorph into: anAdapter

	^ anAdapter 
		addHorizontalPadding: aNumber 
		toMorph: aMorph! !

!SpHorizontalLayoutDirection methodsFor: 'testing' stamp: ''!
isHorizontal

	^ true! !

!SpHorizontalLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
applyHomogeneousLayoutOn: aLayout to: aMorph in: aRect

	aLayout applyHorizontalHomogeneousLayout: aMorph in: aRect! !

!SpHorizontalLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
newSplitter

	^ SpPanedResizerMorph newHorizontal! !

!SpHorizontalLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
setRigidityOfNonExpandedMorph: aMorph

	aMorph 
		vResizing: #spaceFill; 
		hResizing: #rigid! !

!SpHorizontalPanedLayoutAdapterTest methodsFor: 'accessing' stamp: ''!
newLayout
	
	^ SpPanedLayout newLeftToRight! !

!SpHorizontalPanedLayoutTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	layout := SpPanedLayout newLeftToRight.
	presenter layout: layout! !

!SpIconAndLabelToolbarDisplayMode commentStamp: ''!
Display the toolbar with icons and label only!
!SpIconAndLabelToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
extent
	^ 45@45! !

!SpIconAndLabelToolbarDisplayMode methodsFor: 'configuring' stamp: ''!
configureButton: aButton item: aToolbarItem
	"ask for icon and label"
	aButton getLabelSelector: #label.
	aButton getIconSelector: #icon.
	aButton badgeSelector: #badge.
	aButton getStateSelector: #state
	! !

!SpIconAndLabelToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
styleName 

	^ 'toolBar.iconsAndLabel'! !

!SpIconAndLabelToolbarDisplayMode methodsFor: 'printing' stamp: ''!
label

	^ 'Icon and Label'! !

!SpIconProvider commentStamp: ''!
I'm base icon provider. 
Children of `SpIconProvider` will define concrete ways to access icons.!
!SpIconProvider methodsFor: 'copying' stamp: ''!
, aProvider

	^ SpCompositeIconProvider new 
		addProvider: self;
		addProvider: aProvider;
		yourself! !

!SpIconProvider methodsFor: 'accessing' stamp: ''!
iconNamed: aName

	^ self 
		iconNamed: aName 
		ifAbsent: [ self error: ('Icon {1} not found.' format: { aName })  ]! !

!SpIconProvider methodsFor: 'accessing' stamp: ''!
iconNamed: aName ifAbsent: aBlock

	self subclassResponsibility! !

!SpIconToolbarDisplayMode commentStamp: ''!
Display the toolbar with icons only!
!SpIconToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
extent

	^ 30@30! !

!SpIconToolbarDisplayMode methodsFor: 'configuring' stamp: ''!
configureButton: aButton item: aToolbarItem
	"ask for icon (no label)"
	aButton getIconSelector: #icon.
	aButton badgeSelector: #badge.
	aButton getStateSelector: #state! !

!SpIconToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
styleName 

	^ 'toolBar.icons'! !

!SpIconToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
label

	^ 'Icon'! !

!SpImageAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpImagePresenter! !

!SpImageAdapterTest methodsFor: 'building' stamp: ''!
testSettingNilClearsTheImage

	self presenter image: self imageForm.
	self presenter image: nil.
	
	backendForTest assertImage: self adapter image equals: nil.
! !

!SpImageAdapterTest methodsFor: 'building' stamp: ''!
testSettingAnImageSetsTheImage

	self presenter image: self imageForm.
	backendForTest assertImage: self adapter image equals: self imageForm.
! !

!SpImageAdapterTest methodsFor: 'building' stamp: ''!
testSettingAnImageSetsTheImageAndThrowsEvent

	| happened |
	self presenter whenImageChangeDo: [ happened := true ].
	self presenter image: self imageForm.
	
	backendForTest assertImage: self adapter image equals: self imageForm.
	self assert: happened! !

!SpImageAdapterTest methodsFor: 'building' stamp: ''!
testAutoscale

	self presenter image: self imageForm.

	self presenter autoScale: false.
	self deny: self adapter hasImageAutoscaled.

	self presenter autoScale: true.
	self assert: self adapter hasImageAutoscaled.
! !

!SpImageAdapterTest methodsFor: 'building' stamp: ''!
imageForm

	^ (PNGReadWriter on: 
			(ZnBase64Encoder new decode: PolymorphSystemSettings pharoLogoContents) readStream) 
			nextImage! !

!SpImagePresenter commentStamp: ''!
A presenter to display  images.
Images need to be instances of `Form`.  !
!SpImagePresenter methodsFor: 'TOREMOVE' stamp: ''!
action: aBlock
	"Set the action of the image"

	action := aBlock! !

!SpImagePresenter methodsFor: 'api' stamp: ''!
image: aForm
	"Set a `Form` instance to be displayed."
	
	image := aForm! !

!SpImagePresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	action := [  ].
	autoScale := false! !

!SpImagePresenter methodsFor: 'api - events' stamp: ''!
whenImageChangeDo: aBlock 
	"Inform when image to display has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
	
	self property: #image whenChangedDo: aBlock ! !

!SpImagePresenter methodsFor: 'api - events' stamp: ''!
whenAutoScaleChangeDo: aBlockClosure
	"Inform when autoScale state has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #autoScale whenChangedDo: aBlockClosure! !

!SpImagePresenter methodsFor: 'TOREMOVE' stamp: ''!
action

	^ action! !

!SpImagePresenter methodsFor: 'api' stamp: ''!
image
	"Answer the `Form` instance that will be displayed."

	^ image! !

!SpImagePresenter methodsFor: 'api' stamp: ''!
switchAutoscale
	"Toggles autoscale state."
	
	autoScale := autoScale not
! !

!SpImagePresenter methodsFor: 'api' stamp: ''!
autoScale: aBoolean
	"Set whether image will autoscale or not."

	autoScale := aBoolean! !

!SpImagePresenter methodsFor: 'api' stamp: ''!
autoScale
	"Answer if image has autoscale activated."

	^ autoScale! !

!SpImagePresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newImage! !

!SpImagePresenter class methodsFor: '*Spec2-Morphic-Examples' stamp: ''!
example
	<sampleInstance>

	^ self new 
		image: (self iconNamed: #pharoBig);
		openWithSpec! !

!SpImagePresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ImageAdapter! !

!SpImagePresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpImagePresenter! !

!SpImagePresenterTest methodsFor: 'tests' stamp: ''!
testSwitchAutoScale
	| autoState |
	autoState := presenter autoScale.
	presenter switchAutoscale.
	self assert: presenter autoScale equals: autoState not! !

!SpImagePresenterTest methodsFor: 'tests' stamp: ''!
testAutoScale
	| count result |
	count := 0.
	presenter
		whenAutoScaleChangeDo: [ :value | 
			result := value.
			count := count + 1 ].
	presenter autoScale: true.
	self assert: count equals: 1.
	self assert: result! !

!SpImageTableColumn commentStamp: ''!
A column that displays images.

The user need to set the evaluation block (by sending `SpTableColumn>>#evaluated:`) to answer an image (an instance of `Form`).

## Example
```
SpImageTableColumn 
	title: 'My Image' 
	evaluated: [ :anObject | anObject systemIcon ]
```!
!SpImageTableColumn methodsFor: 'visiting' stamp: ''!
acceptColumnVisitor: aBuilder

	^ aBuilder visitImageColumn: self! !

!SpIndeterminatedProgressBarMorph commentStamp: ''!
Description
--------------------

I am a Progress bar with an indeterminated advance. I'll just show a bar going back and forth.

Examples
--------------------

IndeterminatedProgressBarMorph new
	extent: 200@6;
	openInWorld.	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	oddPassage:		<aBoolean>		For design purpose, one passage of the loading is faster that the other. This boolean is used to know if the current passage should be fast or slow.
!
!SpIndeterminatedProgressBarMorph methodsFor: 'drawing' stamp: ''!
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: [ cachedWidth := self completedWidth.
			"Compared to my superclass, we do not always start at the origin of the progress bar since it's not a determinated progress"
			area := (area left + (cachedWidth - (area width / 2.5))) @ area top corner: area origin + (cachedWidth @ area height).
			aCanvas fillRectangle: area fillStyle: self barFillStyle ].
	self borderStyle frameRectangle: self bounds on: aCanvas! !

!SpIndeterminatedProgressBarMorph methodsFor: 'initialization' stamp: ''!
initialize
	self flag: #pharoTodo. "I think this class should be merged in ProgressBarMorph in Pharo 8."
	super initialize.
	oddPassage := true! !

!SpIndeterminatedProgressBarMorph methodsFor: 'stepping and presenter' stamp: ''!
step
	"At each step we are increasing the value of the progress bar. If we get at the end, we juts begin once again."

	| range |
	super step.

	range := end - start.

	self value: self value + (range / self indeterminateStepIncrease).

	self value > range ifFalse: [ ^ self ].

	self value: start.
	oddPassage := oddPassage not! !

!SpIndeterminatedProgressBarMorph methodsFor: 'stepping and presenter' stamp: ''!
indeterminateStepIncrease
	"To get a feeling of recent design we use a progression with two timing and we switch the speed at each passage."

	^ oddPassage ifTrue: [ 40 ] ifFalse: [ 15 ]! !

!SpIndeterminatedProgressBarMorph methodsFor: 'stepping and presenter' stamp: ''!
stepTime
	^ 20! !

!SpIndeterminatedProgressBarMorph class methodsFor: 'examples' stamp: ''!
example
	<script>
	self new
		extent: 200 @ 6;
		openInWorld! !

!SpIndeterminatedProgressBarState commentStamp: ''!
Description
--------------------

I am a state of a ProgressBarPresenter managing the behavior of a indeterminated progress bar. I will have no value and display a bar going back and forth.

Examples
--------------------

	ProgressBarIndeterminated new!
!SpIndeterminatedProgressBarState methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
customizeMorphicBar: aProgressBarMorph
	"Nothing to do here"! !

!SpIndeterminatedProgressBarState methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
progressBarMorph
	^ SpIndeterminatedProgressBarMorph! !

!SpIndeterminatedProgressBarState methodsFor: 'api - events' stamp: ''!
whenValueChangedDo: aBlock
	"Value cannot change in indeterminate state"! !

!SpIndexTableColumn commentStamp: ''!
A column to display the row index of the collection being shown.
This is useful to add the index information (like happens in many spreadsheets, etc.)

The user does not needs to set an evaluation block for this column (as its value is taken elsewhere).

## Example
```
SpIndexTableColumn title: 'My index'
```!
!SpIndexTableColumn methodsFor: 'visiting' stamp: ''!
acceptColumnVisitor: aBuilder

	^ aBuilder visitIndexColumn: self! !

!SpInformDialog commentStamp: ''!
A dialog to present some simple information to users.!
!SpInformDialog methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self title: 'Inform'! !

!SpInformDialog methodsFor: 'api' stamp: ''!
label: aString

	label label: aString! !

!SpInformDialog methodsFor: 'api' stamp: ''!
title: aString

	title := aString! !

!SpInformDialog methodsFor: 'api' stamp: ''!
acceptLabel

	^ acceptLabel ifNil: [ self class defaultAcceptLabel ]! !

!SpInformDialog methodsFor: 'api' stamp: ''!
extent

	^ initialExtent ifNil: [ self class defaultExtent ]! !

!SpInformDialog methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter

	super initializeDialogWindow: aDialogWindowPresenter.
	aDialogWindowPresenter
		addDefaultButton: self acceptLabel 
		do: [ :presenter | self accept ]
		! !

!SpInformDialog methodsFor: 'api' stamp: ''!
acceptLabel: aString

	acceptLabel := aString! !

!SpInformDialog methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter
		title: self title;
		initialExtent: self extent! !

!SpInformDialog methodsFor: 'accessing' stamp: ''!
defaultIcon

	^ self application iconNamed: #info! !

!SpInformDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	image := self newImage image: self defaultIcon.
	label := self newLabel! !

!SpInformDialog methodsFor: 'api' stamp: ''!
extent: aPoint

	initialExtent := aPoint! !

!SpInformDialog methodsFor: 'api' stamp: ''!
title

	^ title! !

!SpInformDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		borderWidth: 5;
		spacing: 5;
		add: (SpBoxLayout newLeftToRight
			vAlignCenter;
			spacing: 5;
			add: #image expand: false;
			add: #label;
			yourself);
		yourself! !

!SpInformDialog class methodsFor: 'examples' stamp: ''!
exampleModal

	self new
		title: 'Inform modal example';
		label: 'You are seeing an inform dialog!!';
		acceptLabel: 'Close this!!';
		openModalWithSpec! !

!SpInformDialog class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector
	
	^ #newInform! !

!SpInformDialog class methodsFor: 'examples' stamp: ''!
example

	self new
		title: 'Inform example';
		label: 'You are seeing an inform dialog!!';
		acceptLabel: 'Close this!!';
		openDialogWithSpec! !

!SpInformDialog class methodsFor: 'accessing' stamp: ''!
defaultExtent

	^ 450@120! !

!SpInformDialog class methodsFor: 'accessing' stamp: ''!
defaultAcceptLabel

	^ 'Ok'! !

!SpInitializationStrategy methodsFor: 'running' stamp: ''!
beforeAssertInTest: aSpecTest

	"By default do nothing.
	Hook for subclasses"! !

!SpInitializationStrategy methodsFor: 'running' stamp: ''!
beforeTest: aSpecTest 
	
	"By default do nothing.
	Hook for subclasses"! !

!SpInitializationStrategy class methodsFor: 'accessing' stamp: ''!
afterTest
	
	^ SpAfterTestInitializationStrategy new! !

!SpInitializationStrategy class methodsFor: 'accessing' stamp: ''!
beforeTest
	
	^ SpBeforeTestInitializationStrategy new! !

!SpInitializeWindowExample commentStamp: ''!
I'm an example showing how to use the #prepareWindow: message to enhance the window in which your presenter will be shown. 
The example adds a menu, a toolbar and a statusbar. 
You can choose which one(s) you want to add.

self show.!
!SpInitializeWindowExample methodsFor: 'private - building' stamp: ''!
buildPopMessageToolBarItem
		
	^ SpToolbarButtonPresenter new
		label: 'Pop';
		icon: (self iconNamed: #glamorousDown);
		help: 'Pop last status bar message';
		action: [ self popMessage ];
		yourself! !

!SpInitializeWindowExample methodsFor: 'private - building' stamp: ''!
buildFileMenu

	^ self newMenu
		addItem: [ :item | item name: 'Push message'; action: [ self pushMessage ] ];
		addItem: [ :item | item name: 'Pop message'; action: [ self popMessage ] ];
		yourself! !

!SpInitializeWindowExample methodsFor: 'api' stamp: ''!
initialExtent
 
	^ 600@400! !

!SpInitializeWindowExample methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	count := 0! !

!SpInitializeWindowExample methodsFor: 'actions' stamp: ''!
text: aPresenter

	text := aPresenter! !

!SpInitializeWindowExample methodsFor: 'actions' stamp: ''!
popMessage

	statusBar popMessage! !

!SpInitializeWindowExample methodsFor: 'actions' stamp: ''!
pushMessage
	
	count := count + 1.
	statusBar pushMessage: ('StatusBar message {1}...' format: { count })! !

!SpInitializeWindowExample methodsFor: 'private - building' stamp: ''!
buildPushMessageToolBarItem
		
	^ SpToolbarButtonPresenter new
		label: 'Push';
		icon: (self iconNamed: #glamorousUp);
		help: 'Push a new status bar message';
		action: [ self pushMessage ];
		yourself! !

!SpInitializeWindowExample methodsFor: 'private - building' stamp: ''!
buildStatusBar

	^ SpStatusBarPresenter new! !

!SpInitializeWindowExample methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	"I'm called whenever the component will be displayed in a window (or dialog). 
	 This is usually attained sending #openWithSpec or #openDialogWithSpec."
	
	super initializeWindow: aWindowPresenter.
	aWindowPresenter
		menu: (menu := self buildMenuBar);
		toolbar: (toolbar := self buildToolbar);
		statusBar: (statusBar := self buildStatusBar)! !

!SpInitializeWindowExample methodsFor: 'private - building' stamp: ''!
buildToolbar
	
	^ self newToolbar 
		addItem: self buildPushMessageToolBarItem;
		addItem: self buildPopMessageToolBarItem;
		addItem: self buildPopMessageToolBarItem position: SpToolbarItemPosition right;
		yourself! !

!SpInitializeWindowExample methodsFor: 'initialization' stamp: ''!
initializePresenters
	
	text := self newText text: 'Implementing #initializeWindow:, you can add a menu, toolbar and statusBar to your component.

BEWARE: This elements will be added just when you will open the presenter as a window or dialog. Otherwise, your component will behave just as another composable presenter.'! !

!SpInitializeWindowExample methodsFor: 'api' stamp: ''!
title 

	^ 'Example of using #prepareWindow:'! !

!SpInitializeWindowExample methodsFor: 'private - building' stamp: ''!
buildMenuBar

	^ self newMenuBar
		addGroup: [ :group | group
			addItem: [ :item | item name: 'File'; subMenu: self buildFileMenu ] ]! !

!SpInitializeWindowExample methodsFor: 'accessing ui' stamp: ''!
text 

	^ text! !

!SpInitializeWindowExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #text;
		yourself! !

!SpInitializeWindowExample class methodsFor: 'showing' stamp: ''!
show
	<script>

	self new openWithSpec! !

!SpInputPort commentStamp: ''!
!! Input ports
Input ports define the transmission destination points of a presenter. 
They handle an incoming transmissions and transmit them properly to the target presenter.

This transmission happens in *method:SpInputPort#incomingTransmission:from:*, that concrete implementations of input ports needs to define to populate the destination presenter.

See: *class:SpLabelPort*,*class:SpListItemsPort*, *class:SpModelPort*, *class:SpTextPort*, *class:SpActionPort*!
!SpInputPort methodsFor: 'testing' stamp: ''!
isInput 

	^ true! !

!SpInputPort methodsFor: 'handling transmission' stamp: ''!
applyIncomingTransmission: anObject from: outPort to: aPresenter
	
	self subclassResponsibility! !

!SpInputPort methodsFor: 'handling transmission' stamp: ''!
incomingTransmission: anObject from: outPort
	"When a transmission happens, the origin transmission has is triggers a value ==anObject== 
	 (already transformed if #transform: is specified) from the outPort *class:SpOutputPort*.
	 This method uses the incoming value to populate the destination presenter, according 
	 with the concrete port definition. 
	 Yes, this sounds abstract, you can check concrete implementations for a better 
	 understanding of it.
	[[[language=Smalltalk
	self destinationPresenter setModel: anObject
	]]]"
	| presenterOrPort |
	
	presenterOrPort := self destinationPresenterOrPort.
	presenterOrPort isPresenter
		ifTrue: [ self applyIncomingTransmission: anObject from: outPort to: presenterOrPort ]
		ifFalse: [ presenterOrPort incomingTransmission: anObject from: outPort ]
	! !

!SpInputPort class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self name = #SpInputPort! !

!SpInteractionCancelled commentStamp: ''!
I am the error raised when the user cancelled a request.!
!SpInteractionCancelled class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!SpInteractionError commentStamp: ''!
I model an abstract interaction error.

These errors are raised when an interaction with a user did not end well.!
!SpInteractionError methodsFor: '*Spec2-Commander2' stamp: ''!
actForSpec
	"Override this method to define the behaviour of when an interaction error occurs."
	self subclassResponsibility! !

!SpInvalidUserInput commentStamp: ''!
I am the error raised when a user entered bad input during interaction.!
!SpInvalidUserInput class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!SpInvalidUserInputError commentStamp: ''!
I am the error raised when a user entered bad input during interaction.!
!SpInvalidUserInputError methodsFor: '*Spec2-Commander2' stamp: ''!
actForSpec
	"Does nothing on purpose."
	UIManager default
		inform: self messageText.
	self flag: #TODO "In the best world, we should delegate the behaviour to the Spec presenter which originated the error."! !

!SpKMCategoryBuilder methodsFor: 'accessing' stamp: ''!
kmCategory

	^ kmCategory! !

!SpKMCategoryBuilder methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	kmCategory := KMCategory new! !

!SpKMCategoryBuilder methodsFor: 'visiting' stamp: ''!
visitCommand: aCmCommand

	aCmCommand hasShortcutKey ifFalse: [ ^ self ].

	kmCategory addKeymapEntry: (KMKeymap
		shortcut: aCmCommand shortcutKey
		action: [ 
			aCmCommand canBeExecuted 
				ifTrue: [ aCmCommand execute ] ])! !

!SpKMCategoryBuilder class methodsFor: 'accessing' stamp: ''!
menuPresenterClass
	^ SpMenuPresenter! !

!SpKeyDownEventDefinition commentStamp: ''!
I define a key down event!
!SpKeyDownEventDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	anAdapter installKeyDownEvent: self to: aWidget! !

!SpKeyUpEventDefinition commentStamp: ''!
I define a key up event!
!SpKeyUpEventDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	anAdapter installKeyUpEvent: self to: aWidget! !

!SpLabelAdapterTest commentStamp: ''!
SUnit tests for MorphicLabelAdapter!
!SpLabelAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpLabelPresenter! !

!SpLabelAdapterTest methodsFor: 'tests' stamp: ''!
testSetLabelInPresenterSetsInInMorph
	presenter label: 'something'.
	self assert: self adapter label equals: 'something'! !

!SpLabelPort commentStamp: ''!
!! Label Input Port (==SpLabelPort==)
A ""label input port"" define an incomming transmission to modify the label of alabel presenter.

The presenter exposing a text input port need to define also the method ==#label:==.

Presenters exposing this port: *class:SpLabelPresenter*.!
!SpLabelPort methodsFor: 'handling transmission' stamp: ''!
applyIncomingTransmission: anObject from: outPort to: aPresenter

	aPresenter label: anObject! !

!SpLabelPort class methodsFor: 'accessing' stamp: ''!
portName

	^ #text! !

!SpLabelPresenter commentStamp: ''!
A label presenter displays smalls (or medium) amounts of text.

_NOTE: In the future, it should be possible to attach another widget to a label, but for now it is not implemented._!
!SpLabelPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	label := ''.
	self whenLabelChangedDo: [ self changed: #getText ]! !

!SpLabelPresenter methodsFor: 'api' stamp: ''!
label: aString
	"Set the label to be displayed"

	label := aString! !

!SpLabelPresenter methodsFor: 'localization' stamp: ''!
localeChanged

	super localeChanged.
	self forceUpdateSlot: #label
		! !

!SpLabelPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
defaultInputPort

	^ self inputLabelPort! !

!SpLabelPresenter methodsFor: 'testing' stamp: ''!
canTakeKeyboardFocus

	^ false! !

!SpLabelPresenter methodsFor: '*Spec2-Transmission' stamp: ''!
inputLabelPort

	^ SpLabelPort newPresenter: self! !

!SpLabelPresenter methodsFor: 'initialization' stamp: ''!
defaultColor

	self flag: #TOREMOVE. "This needs to be removed"
	^ self theme textColor! !

!SpLabelPresenter methodsFor: 'api' stamp: ''!
label
	"Answer the label to be displayed."

	^ label! !

!SpLabelPresenter methodsFor: 'api - events' stamp: ''!
whenLabelChangedDo: aBlock
	"Inform when label property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #label whenChangedDo: aBlock! !

!SpLabelPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newLabel! !

!SpLabelPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	"This example opens a spec window with a label."

	^ self new
		label: 'Label example';
		openWithSpec.! !

!SpLabelPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #LabelAdapter! !

!SpLabelPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Label presenter'! !

!SpLabelPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpLabelPresenter! !

!SpLabelPresenterTest methodsFor: 'tests' stamp: ''!
testLabelChangeRaisesEvent

	self
		assertEvent: #whenChangedDo:
		isRaisedInPresenter: presenter
		whenDoing: [ presenter label: 'test' ]! !

!SpLabelPresenterTest methodsFor: 'tests' stamp: ''!
testLabelChangeRaisesEventOnce

	self
		assertWith: [ :times | times = 1 ]
		timesRaisedEvent: #whenChangedDo:
		inPresenter: presenter
		whenDoing: [ presenter label: 'test' ]! !

!SpLabelPresenterTest methodsFor: 'tests' stamp: ''!
testLabelIsSet

	presenter label: 'test'.
	self assert: presenter label equals: 'test'! !

!SpLabelToolbarDisplayMode commentStamp: ''!
Display the toolbar with labels only!
!SpLabelToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
extent
	^ 45@25! !

!SpLabelToolbarDisplayMode methodsFor: 'configuring' stamp: ''!
configureButton: aButton item: aToolbarItem
	"ask for label (no icon)"
	aButton getLabelSelector: #label.
	aButton badgeSelector: #badge.
	aButton getStateSelector: #state	! !

!SpLabelToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
styleName

	^ 'toolBar.label'! !

!SpLabelToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
label

	^ 'Label'! !

!SpLabeledPresenter commentStamp: ''!
Description
--------------------

A LabelledPresenter is a simple presenter to display an input with a label and optionnaly a description.

Example:

	self instantiate: (LabelledPresenter label: 'Email' input: self newTextInput description: 'Email adress to use to send activation and informations emails.')!
!SpLabeledPresenter methodsFor: 'accessing' stamp: ''!
input
	^ input! !

!SpLabeledPresenter methodsFor: 'accessing' stamp: ''!
label: aString
	labelPresenter label: aString! !

!SpLabeledPresenter methodsFor: 'accessing' stamp: ''!
description: aString
	aString ifNil: [ ^ self ].
	
	descriptionPresenter := self newLabel
		addStyle: 'italic';
		label: aString;
		yourself! !

!SpLabeledPresenter methodsFor: 'accessing' stamp: ''!
descriptionPresenter: anObject
	descriptionPresenter := anObject! !

!SpLabeledPresenter methodsFor: 'accessing' stamp: ''!
labelPresenter
	^ labelPresenter! !

!SpLabeledPresenter methodsFor: 'accessing' stamp: ''!
labelPresenter: anObject
	labelPresenter := anObject! !

!SpLabeledPresenter methodsFor: 'accessing' stamp: ''!
input: anObject
	input := anObject.
	self focusOrder add: input! !

!SpLabeledPresenter methodsFor: 'accessing' stamp: ''!
descriptionPresenter
	^ descriptionPresenter! !

!SpLabeledPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	labelPresenter := self newLabel.
	descriptionPresenter :=  self newNullPresenter. "By default it is null"! !

!SpLabeledPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newLeftToRight
		add: #labelPresenter withConstraints: [ :constraints | constraints width: self labelWidth ];
		add:
			(SpBoxLayout newTopToBottom
				add: #input withConstraints: [ :constraints | constraints height: self inputTextHeight ];
				add: #descriptionPresenter withConstraints: [ :constraints | constraints height: self inputTextHeight ]);
		yourself! !

!SpLabeledPresenter class methodsFor: 'instance creation' stamp: ''!
label: aString input: aPresenter
	^ self label: aString input: aPresenter description: nil! !

!SpLabeledPresenter class methodsFor: 'instance creation' stamp: ''!
label: aString input: aPresenter description: anotherString
	^ self new
		label: aString;
		input: aPresenter;
		description: anotherString;
		yourself! !

!SpLayoutAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpEmptyPresenter! !

!SpLayoutAdapterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	layout := self newLayout.
	presenter layout: layout! !

!SpLayoutAdapterTest methodsFor: 'accessing' stamp: ''!
newLayout
	
	self subclassResponsibility! !

!SpLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testEmptyLayoutHasEmptyAdapter

	self assert: self adapter isEmpty! !

!SpLayoutAdapterTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == SpLayoutAdapterTest! !

!SpLayoutConstraints methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	self spec: #defaultSpec! !

!SpLayoutConstraints methodsFor: 'accessing' stamp: ''!
spec: anObject
	spec := anObject! !

!SpLayoutConstraints methodsFor: 'accessing' stamp: ''!
spec
	^ spec! !

!SpLayoutDirection methodsFor: 'factory' stamp: ''!
newWidgetOn: anAdapter

	^ self subclassResponsibility! !

!SpLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
recalculatePages: anAdaptor

	self subclassResponsibility! !

!SpLayoutDirection methodsFor: 'testing' stamp: ''!
isVertical

	^ false! !

!SpLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
addPadding: aNumber toMorph: aMorph into: anAdapter

	^ self subclassResponsibility! !

!SpLayoutDirection methodsFor: 'testing' stamp: ''!
isHorizontal

	^ false! !

!SpLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
applyHomogeneousLayoutOn: aLayout to: aMorph in: aRect

	self subclassResponsibility! !

!SpLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
newSplitter
	^ self subclassResponsibility! !

!SpLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
setRigidityOfNonExpandedMorph: aMorph 
	self subclassResponsibility! !

!SpLayoutDirection class methodsFor: 'accessing' stamp: ''!
vertical

	^ SpVerticalLayoutDirection uniqueInstance! !

!SpLayoutDirection class methodsFor: 'accessing' stamp: ''!
uniqueInstance 
	
	self = SpLayoutDirection ifTrue: [ 
		self error: 'I''m abstract, use one of my children' ].
	^ uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! !

!SpLayoutDirection class methodsFor: 'accessing' stamp: ''!
horizontal

	^ SpHorizontalLayoutDirection uniqueInstance! !

!SpLayoutFrame commentStamp: ''!
I am a wrapper for the layout of widget.

Each framework can then adapt me as it wants in its adapters!
!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
topOffset: anObject
	
	topOffset := anObject! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
leftOffset: anObject
	
	leftOffset := anObject! !

!SpLayoutFrame methodsFor: 'converting' stamp: ''!
asArray
	 
	^ { leftFraction . 
		topFraction .
		rightFraction .
		bottomFraction .	
		leftOffset .
		topOffset .
		rightOffset .
		bottomOffset } ! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
rightOffset
	
	^ rightOffset! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
rightFraction
	
	^ rightFraction! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
leftFraction
	
	^ leftFraction! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
owner

	"Every object instantiated by the SpecInerpreter should have an owner that will assign it to a particular presenter"
	^ owner! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
rightOffset: anObject
	
	rightOffset := anObject! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
bottomOffset: anObject
	
	bottomOffset := anObject! !

!SpLayoutFrame methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	bottomFraction := 1.
	bottomOffset := 0.
	leftFraction := 0.
	leftOffset := 0.
	rightFraction := 1.
	rightOffset := 0.
	topFraction := 0.
	topOffset := 0.! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
rightFraction: anObject
	
	rightFraction := anObject! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
bottomFraction
	
	^ bottomFraction! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
topLeftOffset: aPoint

	topOffset := aPoint y.
	leftOffset := aPoint x.! !

!SpLayoutFrame methodsFor: 'testing' stamp: ''!
hasNoOffsets

	^ leftOffset = 0 and: [rightOffset = 0  and: [ topOffset = 0 and: [ bottomOffset = 0 ]]].
	! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
owner: anObject
	owner := anObject! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
topFraction: anObject
	
	topFraction := anObject! !

!SpLayoutFrame methodsFor: 'converting' stamp: ''!
asSpLayoutFrame

	^ self! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
leftOffset
	
	^ leftOffset! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
bottomRightOffset: aPoint

	bottomOffset := aPoint y.
	rightOffset := aPoint x.! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
leftFraction: anObject
	
	leftFraction := anObject! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
topOffset
	
	^ topOffset! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
bottomOffset
	
	^ bottomOffset! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
bottomFraction: anObject
	
	bottomFraction := anObject! !

!SpLayoutFrame methodsFor: 'accessing' stamp: ''!
topFraction
	
	^ topFraction! !

!SpLayoutFrame methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
asMorphicLayout
	
	^ LayoutFrame identity
		topFraction: self topFraction;
		topOffset: self topOffset;
		bottomFraction: self bottomFraction;
		bottomOffset: self bottomOffset;
		rightFraction: self rightFraction;
		rightOffset: self rightOffset;
		leftFraction: self leftFraction;
		leftOffset: self leftOffset;
		yourself! !

!SpLayoutFrame class methodsFor: 'instance creation' stamp: ''!
owner: anObject

	^ self new owner: anObject; yourself.! !

!SpLayoutFrame class methodsFor: 'instance creation' stamp: ''!
identity
	"by default a layout frame is initialized to represent the identity transformation"
	^ self new! !

!SpLayoutTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpEmptyPresenter! !

!SpLayoutTest methodsFor: 'tests' stamp: ''!
testInitialLayoutIsEmpty

	self assert: layout isEmpty! !

!SpLayoutTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors

	^ true! !

!SpLayoutTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == SpLayoutTest! !

!SpLayoutWidgetAlignment commentStamp: ''!
I indicate the alignment of the presenter in relation with the layout.!
!SpLayoutWidgetAlignment methodsFor: '*Spec2-Morphic' stamp: ''!
asMorphicAlign

	^ self subclassResponsibility! !

!SpLayoutWidgetAlignment class methodsFor: 'accessing' stamp: ''!
center

	^ SpLayoutWidgetAlignmentCenter uniqueInstance! !

!SpLayoutWidgetAlignment class methodsFor: 'instance creation' stamp: ''!
new 

	self error: 'Use #uniqueInstance'! !

!SpLayoutWidgetAlignment class methodsFor: 'instance creation' stamp: ''!
uniqueInstance

	self = SpLayoutWidgetAlignment ifTrue: [ 
		self error: 'I''m an abstract class. Use one of my children instead.' ].
	^ uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! !

!SpLayoutWidgetAlignment class methodsFor: 'accessing' stamp: ''!
start

	^ SpLayoutWidgetAlignmentStart uniqueInstance! !

!SpLayoutWidgetAlignment class methodsFor: 'accessing' stamp: ''!
end

	^ SpLayoutWidgetAlignmentEnd uniqueInstance! !

!SpLayoutWidgetAlignmentCenter commentStamp: ''!
I will place the widget centered in relation to the layout.!
!SpLayoutWidgetAlignmentCenter methodsFor: '*Spec2-Morphic' stamp: ''!
asMorphicAlign

	^ #center! !

!SpLayoutWidgetAlignmentEnd commentStamp: ''!
I will place the widget at the end in relation to the layout.!
!SpLayoutWidgetAlignmentEnd methodsFor: '*Spec2-Morphic' stamp: ''!
asMorphicAlign

	^ #bottomRight! !

!SpLayoutWidgetAlignmentStart commentStamp: ''!
I will place the widget at the start in relation to the layout.!
!SpLayoutWidgetAlignmentStart methodsFor: '*Spec2-Morphic' stamp: ''!
asMorphicAlign

	^ #topLeft! !

!SpLayouts commentStamp: ''!
A SpecExamples is the third sub-book of SpecHelpTopics. Here you will find more complex ways of laying out Spec.
See class side for selectors.
!
!SpLayouts class methodsFor: 'pages' stamp: ''!
columns
	^HelpTopic 
		title: 'Layouts in columns'
		contents: 'Having the widgets rendered as a column is easy:

	^ SpecLayout composed
			newColumn: [ :column |
				column
					add: #theList;
					add: #theButton
			];
			yourself'! !

!SpLayouts class methodsFor: 'accessing' stamp: ''!
pages
	^#(intro columns rows columnsAndRows)! !

!SpLayouts class methodsFor: 'accessing' stamp: ''!
bookName
	^'Spec Layouts'! !

!SpLayouts class methodsFor: 'pages' stamp: ''!
intro
	^HelpTopic 
		title: 'Layouts'
		contents: 'As layouts can become quite complex, this section provides a list of examples of the construction of layouts.  All the methods for adding sub widgets can be found in the ''commands'' and ''commands-advanced'' protocols of the SpecLayout class. You can explore them by doing:
			SpecLayout browse
		
		
Often the layout of user interfaces can be described in rows and columns, and Spec provides for an easy way to specify such layouts.'! !

!SpLayouts class methodsFor: 'pages' stamp: ''!
rows
	^HelpTopic 
		title: 'Layouts in rows'
		contents: 'If you want to arrange your widgets in a row, that''s simple:
		
		
	^ SpecLayout composed
			newRow: [ :row |
				row
					add: #theList;
					add: #theButton
			];
			yourself'! !

!SpLayouts class methodsFor: 'pages' stamp: ''!
columnsAndRows
	^HelpTopic 
		title: 'Combining Columns and Rows'
		contents: 'Rows and columns can be combined to build more complex layouts, and splitters between cells can be added. The example 1.24 shows how to create a 3 columns layout, containing three buttons in each column. This example also shows the addSplitter message, which adds a splitter between the element added before it and the element added after.


	^ SpecLayout composed
			newRow: [ :row |
				row
					newColumn: [ :column |
						column
							add: #button1;
							add: #button2;
							add: #button3
					];
					addSplitter;
					newColumn: [ :column |
						column
							add: #button4;
							add: #button5;
							add: #button6
					];
					addSplitter;
					newColumn: [ :column |
						column
							add: #button7;
							add: #button8;
							add: #button9
					];
			];
			yourself

The height of rows as well as the width of columns can be specified, to prevent them to take all the available space.  Here is an example of a row with a height of 30.

		^ SpecLayout composed
				newRow: [ :row |
					row
						add: #theList;
						add: #theButton
				] height: 30;
				yourself
				
				
And the same but for a column:

		^ SpecLayout composed
				newColumn: [ :column |
					column
						add: #theList;
						add: #theButton
				] width: 30;
			    yourself
			
			
Note that it is generally considered a bad habit to hardcode the size of the widgets. Methods are available on SpPresenter providing sensible default sizes, like the width of a button. When specifying custom widget sizes, care should be taken to take in account the current font size.'
			
		
! !

!SpLinkPresenter commentStamp: ''!
A presenter used to display a link. 
It will display me as a link the user should be able to click and it will open a web page in the user browser.
If there is no `label` set, the `url` will be taken as label aswell. 
!
!SpLinkPresenter methodsFor: 'api' stamp: ''!
action: aBlock
	"Set the action to execute when link is pressed.
	 See also `SpLinkPresenter>>#url:`."

	action := aBlock! !

!SpLinkPresenter methodsFor: 'private' stamp: ''!
performAction

	self action value! !

!SpLinkPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self whenLabelChangedDo: [ self changed: #getText ]! !

!SpLinkPresenter methodsFor: 'api' stamp: ''!
label: aString
	"Set the label to display as the link."

	^ label := aString! !

!SpLinkPresenter methodsFor: 'localization' stamp: ''!
localeChanged

	super localeChanged.
	self forceUpdateSlot: #label
		! !

!SpLinkPresenter methodsFor: 'api - events' stamp: ''!
whenActionChangedDo: aBlock
	"Inform when action has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #action whenChangedDo: aBlock! !

!SpLinkPresenter methodsFor: 'api' stamp: ''!
action
	"Answer the action to execute when link is pressed."

	^ action! !

!SpLinkPresenter methodsFor: 'api' stamp: ''!
url: aString
	"Set the url to open when link is pressed. Also, it sets action (See `SpLinkPresenter>>#action:` 
	 to open an external browser to the url.
	 If there is no label selected (See `SpLinkPresenter>>#label:`, it sets it to the value 
	 of `aString`."

	self action: [ WebBrowser openOn: aString ].
	self label ifNil: [ self label: aString ]! !

!SpLinkPresenter methodsFor: 'api - events' stamp: ''!
whenUrlChangedDo: aBlock
	"Inform when label state has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #url whenChangedDo: aBlock! !

!SpLinkPresenter methodsFor: 'TOREMOVE' stamp: ''!
defaultColor
	^ nil! !

!SpLinkPresenter methodsFor: 'api' stamp: ''!
label
	"Answer the label to display as the link"
	
	^ label! !

!SpLinkPresenter methodsFor: 'api - events' stamp: ''!
whenLabelChangedDo: aBlock
	"Inform when label state has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #label whenChangedDo: aBlock! !

!SpLinkPresenter class methodsFor: '*Spec2-Morphic-Examples' stamp: ''!
example
	<sampleInstance>
	| example |

	example := self new
		url: 'https://pharo.org';
		label: 'Pharo website';
		extent: 200 @ 20;
		openWithSpec;
		yourself.

	example withWindowDo: [ :w | w title: 'Link presenter' ].

	^ example! !

!SpLinkPresenter class methodsFor: 'specs' stamp: ''!
adapterName
	^ #LinkAdapter! !

!SpLinkPresenter class methodsFor: 'documentation' stamp: ''!
documentExamplesProtocol
	
	^ #'*Spec2-Morphic-Examples'! !

!SpLinkPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpLinkPresenter! !

!SpLinkPresenterTest methodsFor: 'tests' stamp: ''!
testWhenLabelChangedDo
	| count result |
	count := 0.
	presenter
		whenLabelChangedDo: [ :label | 
			count := count + 1.
			result := label ].
	presenter label: 'Test'.
	self assert: result equals: 'Test'.
	self assert: count equals: 1! !

!SpLinkPresenterTest methodsFor: 'tests' stamp: ''!
testLabelIsUrlByDefault
	self assert: presenter label isNil.
	presenter url: 'Test'.
	self assert: presenter label equals: 'Test'.
	presenter label: 'Label'.
	self assert: presenter label equals: 'Label'! !

!SpLinkPresenterTest methodsFor: 'tests' stamp: ''!
testWhenActionChangedDo
	| count result |
	count := 0.
	presenter
		whenActionChangedDo: [ :block | 
			count := count + 1.
			result := block ].
	presenter action: [ 'Test' ].
	self assert: result isBlock.
	self assert: result value equals: 'Test'.
	self assert: count equals: 1! !

!SpLinkTableColumn commentStamp: ''!
A column to display a link.

## Example
```
SpIndexTableColumn 
	title: 'Link' 
	evaluated: [ :anObject | anObject name ]
	action: [ :anObject | "Execute something with this object" ]
```!
!SpLinkTableColumn methodsFor: 'accessing' stamp: ''!
action: anObject
	action := anObject! !

!SpLinkTableColumn methodsFor: 'accessing' stamp: ''!
action
	^ action! !

!SpLinkTableColumn methodsFor: 'accessing' stamp: ''!
url: anObject
	url := anObject! !

!SpLinkTableColumn methodsFor: 'visiting' stamp: ''!
acceptColumnVisitor: aBuilder

	^ aBuilder visitLinkColumn: self! !

!SpLinkTableColumn methodsFor: 'accessing' stamp: ''!
url
	^ url! !

!SpLinkTableColumn class methodsFor: 'instance creation' stamp: ''!
title: aString evaluated: aBlock url: urlBlock

	^ self new 
		title: aString;
		evaluated: aBlock;
		url: urlBlock;
		yourself! !

!SpLinkTableColumn class methodsFor: 'instance creation' stamp: ''!
title: aString evaluated: aBlock action: actionBlock

	^ self new 
		title: aString;
		evaluated: aBlock;
		action: actionBlock;
		yourself! !

!SpListAdapterMultipleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpListPresenter! !

!SpListAdapterSingleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpListPresenter! !

!SpListCommonPropertiestTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpListPresenter! !

!SpListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testSetColumnTitleInPresenterShowsThemInWidget

	self presenter headerTitle: 'test'.
	
	self assert: self adapter isShowColumnHeaders! !

!SpListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testChangingFromSingleToMultipleSelection
	presenter beSingleSelection.
	self deny: presenter isMultipleSelection.
	presenter beMultipleSelection.
	self assert: presenter isMultipleSelection! !

!SpListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testSetColumnTitleInPresenterPutsColumnHeaderMorph

	SystemVersion current major = 7
		ifTrue: [
			"Test failing in Pharo7 due to a bug in FastTable"
			^ self skip ].

	self presenter headerTitle: 'test'.

	backendForTest assertListHeaderOf: self adapter equals: #('test')! !

!SpListCommonPropertiestTest methodsFor: 'tests - scrolling' stamp: ''!
testScrollUpToPreviousIndexScrollsTopToIndex
	self flag: #pharo7.
	SystemVersion current major < 8 ifTrue: [ self skip. "Feature not supported in Pharo 7" ].
	presenter items: (1 to: 500).
	presenter verticalAlignment desiredVisibleRow: 100.
	self openInstance.

	presenter verticalAlignment desiredVisibleRow: 50.

	self assert: presenter verticalAlignment firstVisibleRowIndex equals: 50! !

!SpListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testEnablingFilteringUpdateOpenedList
	self deny: self adapter hasFilter.
	presenter matchSubstring.
	self assert: self adapter hasFilter.
	presenter itemFilter: nil.
	self deny: self adapter hasFilter! !

!SpListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testRemoveHeaderTitleInPresenterRemovesColumnHeaderMorph
	self flag: #pharo7.
	SystemVersion current major < 8 ifTrue: [ self skip. "Feature not supported in Pharo 7" ].

	self presenter headerTitle: 'test'.
	self presenter hideHeaderTitle.

	backendForTest denyHasHeader: self adapter! !

!SpListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testSelectingANotVisibleItemDoesNotScroll
	| verticalAlignment visibleItems |
	presenter items: (1 to: 500).
	verticalAlignment := presenter verticalAlignment.
	self openInstance.
	visibleItems := verticalAlignment firstVisibleRowIndex to: verticalAlignment lastVisibleRowIndex.
	presenter selectItem: 400.

	self 
		assert: (verticalAlignment firstVisibleRowIndex to: verticalAlignment lastVisibleRowIndex) 
		equals: visibleItems! !

!SpListCommonPropertiestTest methodsFor: 'tests - scrolling' stamp: ''!
testScrollDownToNonExistingIndexScrollsBottomToLastIndex
	self flag: #pharo7.
	SystemVersion current major < 8 ifTrue: [ self skip. "Feature not supported in Pharo 7" ].
	presenter items: (1 to: 500).
	presenter verticalAlignment desiredVisibleRow: 600.

	"Force opening the spec instance here.
	We want to test that once open we can change the state"
	self openInstance.

	self assert: presenter verticalAlignment lastVisibleRowIndex equals: 500! !

!SpListCommonPropertiestTest methodsFor: 'tests - scrolling' stamp: ''!
testScrollDownToPosteriorIndexScrollsBottomToIndex
	self flag: #pharo7.
	SystemVersion current major < 8 ifTrue: [ self skip. "Feature not supported in Pharo 7" ].
	presenter items: (1 to: 500).
	presenter verticalAlignment desiredVisibleRow: 100.

	"Force opening the spec instance here.
	We want to test that once open we can change the state"
	self openInstance.

	"Some backends will show entirely row 100 and a part of the next row, so row 101 is also a valid answer"
	self assert: (presenter verticalAlignment lastVisibleRowIndex between: 100 and: 101)! !

!SpListCommonPropertiestTest methodsFor: 'tests - scrolling' stamp: ''!
testScrollUpToNegativeIndexScrollsTopToFirstIndex
	self flag: #pharo7.
	SystemVersion current major < 8 ifTrue: [ self skip. "Feature not supported in Pharo 7" ].
	presenter items: (1 to: 500).
	presenter verticalAlignment desiredVisibleRow: 100.
	self openInstance.

	presenter verticalAlignment desiredVisibleRow: -1.

	self assert: presenter verticalAlignment firstVisibleRowIndex equals: 1! !

!SpListCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testChangingFromMultipleToSingleSelection
	presenter beMultipleSelection.
	self assert: presenter isMultipleSelection.
	presenter beSingleSelection.
	self deny: presenter isMultipleSelection! !

!SpListItemsPort commentStamp: ''!
!! List Items Input Port (==SpListItemsPort==)
A ""list items input port"" define an incomming transmission to modify items of a list, tree or table presenter.

The presenter exposing a list items input port need to define also the method ==#items:==.

Presenters exposing this port: *class:SpAbstractListPresenter* subclasses and: *class:SpDropListPresenter*.!
!SpListItemsPort methodsFor: 'handling transmission' stamp: ''!
applyIncomingTransmission: anObject from: outPort to: aPresenter
	
	aPresenter items: anObject! !

!SpListItemsPort class methodsFor: 'accessing' stamp: ''!
portName

	^ #items! !

!SpListPresenter commentStamp: ''!
A `SpListPresenter` is presenter which handles a basic list displaying information about a domain list. 
For example a list presenter will display the name of a list of contacts. It refines the API of `SpAbstractListPresenter` that is shared with `SpComponentListPresenter` (which is a list of presenters) and `SpTablePresenter` (which is a list with multiple columns in a sense). 

### Design point
There are two design points worth notice:

A list presenter has a strategy that encapsulates specific API and action related to selection (how to select, how many items can be selected, currently selected items...). Such strategy is accessed via the `selection` message. It returns an instance of subclasses of `SpAbstractSelectionMode`: `SpMultipleSelectionMode` and `SpSingleSelectionMode`. 
It means many fonctionality related to the selection (selected items, multiple items, ....) are defined in the API of the mode and not of the main class.
 
A list presenter does not offer the possibility to add one item in isolation instead you should use the `items:` setter to set the full list domain object. The responsibility to manage the items displayed by a list presenter is not the one of that list presenter but its users e.g, the presenter you will write and that instantiates and uses the list presenter. This is normal since there is no way that the list presenter could track changes into the domain object representing the list items.!
!SpListPresenter methodsFor: 'api' stamp: ''!
displayItalic

	^ italicAction! !

!SpListPresenter methodsFor: 'api' stamp: ''!
headerTitle
	"Answer the header title."

	^ headerTitle! !

!SpListPresenter methodsFor: 'widget API' stamp: ''!
iconFor: anItem

	^ self displayIcon 
		cull: anItem 
		cull: self! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayBold

	^ boldAction! !

!SpListPresenter methodsFor: 'api' stamp: ''!
display
	"Answer the display block that will transform the objects from `SpAbstractListPresenter>>#model` into a
	 displayable string."

	^ display! !

!SpListPresenter methodsFor: 'private' stamp: ''!
resetListSelection
	self selectIndex: 0! !

!SpListPresenter methodsFor: 'private' stamp: ''!
displayValueFor: anObject

	^ self display value: anObject! !

!SpListPresenter methodsFor: 'api' stamp: ''!
enableSearch
	"Enable searching"

	searchEnabled := true! !

!SpListPresenter methodsFor: 'private' stamp: ''!
searchValueOf: item 

	^ self displayValueFor: item! !

!SpListPresenter methodsFor: 'api - events' stamp: ''!
whenSearchEnabledChangedDo: aBlock
	"Inform when search enabled/disabled has changed.
 	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #searchEnabled whenChangedDo: aBlock! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayColor: aBlock
	"Changes the font color of cells of the column. 
	 `aBlock` receives an argument (the model element) and should answer an instance of Color."

	colorAction := aBlock! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayUnderline

	^ underlineAction! !

!SpListPresenter methodsFor: 'testing' stamp: ''!
hasCustomSearch
	"Answer true if the list has a custom search defined (See `SpListPresenter>>#searchMatching:`"

	^ searchBlock notNil! !

!SpListPresenter methodsFor: 'testing' stamp: ''!
hasIcons
	"Answer true if the list has an icon provider (See `SpListPresenter>>#icons:`)."

	^ self displayIcon notNil! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayIcon: aBlock
	"Set a block which takes an item as argument and returns the icon to display in the list. 
	 `aBlock` receives one argument"

	icon := aBlock! !

!SpListPresenter methodsFor: 'private' stamp: ''!
clickOnSelectedItem
	| item |
	item := self selection selectedItem.
	(item notNil and: [ item respondsTo: #click ])
		ifTrue: [ ^ item click ]
		ifFalse: [ ^ false ]! !

!SpListPresenter methodsFor: 'private' stamp: ''!
prepareForFilteredDataSourceWith: items
	model := items! !

!SpListPresenter methodsFor: 'private' stamp: ''!
registerEvents
	super registerEvents.
	"Do not use whenAutoDeselectChangedDo: to avoid the deprecation warning."
	self 
		property: #autoDeselect 
		whenChangedDo: [ :aBoolean | self changed: #autoDeselect: with: {aBoolean} ].
	self whenDisplayChangedDo: [ 
		self withAdapterDo: [ :anAdapter | anAdapter refreshWidgetList ] ].
	self 
		property: #headerTitle 
		whenChangedDo: [ 
			self withAdapterDo: [ :anAdapter | anAdapter refreshWidgetHeaderTitle ] ]! !

!SpListPresenter methodsFor: 'testing' stamp: ''!
isSearchEnabled
	"Answer true if search is enabled (See `SpTSearchable>>#enableSearch`)"

	^ searchEnabled! !

!SpListPresenter methodsFor: 'private' stamp: ''!
displayValueAt: anIndex
	"Return the effective string that is displayed on the list. 
	Note that it is different from the item, because often an item is an object whose only a facette (e.g., name) is displayed. In such case displayValueAt: return the string of the displayed facette"

	^ self displayValueFor: (model at: anIndex)! !

!SpListPresenter methodsFor: 'TOREMOVE' stamp: ''!
resetSortingBlock
	"Reset the sortering block with the default value which consists in not sorting"

	self model sortingBlock: nil! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayBackgroundColor

	^ backgroundColorAction! !

!SpListPresenter methodsFor: 'api' stamp: ''!
icons
	"Return the block used to return an icon that will be displayed in the list"
	self 
		deprecated: 'Use #displayIcon' 
		transformWith: '`@receiver icons' -> '`@receiver displayIcon'.

	^ icon! !

!SpListPresenter methodsFor: 'api' stamp: ''!
icons: aBlock
	"Set a block which takes an item as argument and returns the icon to display in the list. 
	 `aBlock` receives one argument"
	self 
		deprecated: 'Use #displayIcon:' 
		transformWith: '`@receiver icons: `@arg' -> '`@receiver displayIcon: `@arg'.

	icon := aBlock! !

!SpListPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self initializeTSearchable.
	autoDeselect := true.
	allowToSelect := true.
	display := [ :object | object asStringOrText ]! !

!SpListPresenter methodsFor: 'api' stamp: ''!
hideHeaderTitle
	"Hide list header."

	headerTitle := nil! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayItalic: aBlock
	"If `aBlock` answer true, the cell will be displayed in italic.
	 `aBlock` receives one argument (the model element)."

	italicAction := aBlock! !

!SpListPresenter methodsFor: 'api' stamp: ''!
searchMatching: aBlock
	"Enables search and defines a block to perform a search on the model objects. 
	 The block receives two parameters: 
		- item (the model element)
		- pattern (the string to match)"

	searchBlock := aBlock.
	self enableSearch! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayUnderline: aBlock
	"If `aBlock` answer true, the cell will be displayed underlined.
	 `aBlock` receives one argument (the model element)."

	underlineAction := aBlock! !

!SpListPresenter methodsFor: 'api' stamp: ''!
headerTitle: aString
	"Set the header title."

	headerTitle := aString! !

!SpListPresenter methodsFor: 'api - events' stamp: ''!
whenIconsChangedDo: aBlock
	"Inform when the icons block has changed.
 	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #icon whenChangedDo: aBlock! !

!SpListPresenter methodsFor: 'api - events' stamp: ''!
whenDisplayChangedDo: aBlock
	"Inform when the display block has changed.
 	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #display whenChangedDo: aBlock! !

!SpListPresenter methodsFor: 'testing' stamp: ''!
hasHeaderTitle
	"Answer true if the list has a title (See `SpListPresenter>>#headerTitle:`)."

	^ headerTitle isEmptyOrNil not! !

!SpListPresenter methodsFor: 'private' stamp: ''!
performSearch: item matching: pattern

	^ searchBlock 
		value: item 
		value: pattern! !

!SpListPresenter methodsFor: 'api' stamp: ''!
display: aBlock
	"Set the block that will be applied on each of the list items. 
	 The result of the block will be used to display the item on the screen.
	 `aBlock` receives one argument.
	 Here is the typical example:

	 initializePresenters
   		...
   		fontFamilyList := self newList.
		fontFamilyList display: [ :fontFamily | fontFamily familyName ]
   		...
	 "

	display := aBlock! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayBold: aBlock
	"If `aBlock` answer true, the cell will be displayed in bold.
	 `aBlock` receives one argument (the model element)."

	boldAction := aBlock! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayIcon
	"Return the block used to return an icon that will be displayed in the list"

	^ icon! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayColor

	^ colorAction! !

!SpListPresenter methodsFor: 'api' stamp: ''!
disableSearch
	"Disable searching"

	searchEnabled := false! !

!SpListPresenter methodsFor: 'api' stamp: ''!
updateList
	"Update the list re taking the list defined in `SpAbstractListPresenter>>#model` and filling the list with 
	 them (this is useful when the list contained changed internally (like adding element to a collection, etc.). 
	 Sending this message will reset any existing selection."

	self withAdapterDo: [ :anAdapter | anAdapter refreshWidgetList ].
	self unselectAll! !

!SpListPresenter methodsFor: 'private' stamp: ''!
performDefaultSearch: item matching: pattern
	| text |
	
	text := (self searchValueOf: item) trimBoth asLowercase.
	^ text beginsWith: pattern! !

!SpListPresenter methodsFor: 'api' stamp: ''!
displayBackgroundColor: aBlock
	"Changes the background color of cells of the column. 
	 `aBlock` receives an argument (the model element) and should answer an instance of Color. 
	 NOTE: This may be not working at the moment :("

	backgroundColorAction := aBlock! !

!SpListPresenter methodsFor: 'initialization' stamp: ''!
initializeTSearchable
	
	self searchMatching: [ :item :pattern | 
		self performDefaultSearch: item matching: pattern ].! !

!SpListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithHeaderTitle
	<sampleInstance>
	^ self new
		items: self environment allClasses;
		headerTitle: 'Title';
		openWithSpec;
		yourself! !

!SpListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithDecoratedString
	
	^ self new
		items: self environment allClasses;
		displayIcon: [ :aClass | self iconNamed: aClass systemIconName  ];
		displayColor: [ :aClass | 
			(aClass name endsWith: 'Test')
				ifTrue: [ Color green ]
				ifFalse: [ Smalltalk ui theme textColor ] ];
		displayItalic: [ :aClass | aClass name includesSubstring: 'abstract' caseSensitive: false ];
		displayBold: [ :aClass | aClass hasSubclasses ];
		displayUnderline: [ :aClass | aClass numberOfMethods > 10 ];
		openWithSpec! !

!SpListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleMultipleSelection
	<sampleInstance>
	^ self new
		items: self environment allClasses;
		beMultipleSelection;
		openWithSpec;
		yourself! !

!SpListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleDragAndDrop
	| list1 list2 |

	(list1 := self new)
		items: #( 'abc' 'def' 'xyz' );
		dragEnabled: true.
		
	(list2 := self new)
		dropEnabled: true;
		wantsDrop: [ :transfer | transfer passenger allSatisfy: #isString ];
		acceptDrop: [ :transfer | list2 items: (list2 items, transfer passenger) ].
				
	SpPresenter new 
		layout: (SpBoxLayout newLeftToRight
			add: list1;
			add: list2;
			yourself);
		openWithSpec! !

!SpListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithIcons
	<sampleInstance>
	^ self new
		displayIcon: [ :e | self iconNamed: #forwardIcon ];
		items: (1 to: 10) asArray;
		openWithSpec;
		yourself! !

!SpListPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>
	^ self new
		items: self environment allClasses;
		openWithSpec;
		yourself! !

!SpListPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ListAdapter! !

!SpListPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'List'! !

!SpListPresenterHeaderTest methodsFor: 'tests' stamp: ''!
testHeaderIsHiddenWhenNoTitleIsDefined
	| list |
	
	list := SpListPresenter new
		items: (1 to: 10);
		display: #asString;
		yourself.
		
	self deny: list hasHeaderTitle.
	[
		list openWithSpec.
		MorphicRenderLoop new doOneCycle.
		self deny: list adapter firstRowIsHeader ]
	ensure: [ 
		list window close ]! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectUnselectedItemKeepsSelectionList

	presenter
		selectItem: 10;
		unselectItem: 20.
	self assert: presenter selection selectedItems asArray equals: #(10)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexesOutsideRangeIsEmpty
	presenter selectIndexes: {4 . 5}.
	self assert: presenter selection isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectIndexRaisesSelectionChangeEventWithSelectedItem
	| selectedItems |
	presenter
		whenSelectionChangedDo: [ :selection | selectedItems := selection selectedItems ].
	presenter selectIndex: 1.
	self assert: (selectedItems includes: 10)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectMultipleItemAddsAllToSelectedIndexList

	presenter selectItem: 10.
	presenter selectItem: 30.
	self assert: (presenter selection includesIndex: 1).
	self assert: (presenter selection includesIndex: 3).! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexAddsIndexToSelectedIndexList

	presenter selectIndex: 1.
	self assert: (presenter selection includesIndex: 1)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectSelectedItemRaisesSelectionEventOnce
	
	| counter |
	counter := 0.
	presenter
		selectItem: 10;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectItem: 10.
	self assert: counter equals: 1! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectMultipleIndexesRaisesSelectionChangeEventMultipleTimes
	| events |
	events := 0.
	presenter whenSelectionChangedDo: [ :selection | events := events + 1 ].

	presenter	selectIndex: 1.
	presenter	selectIndex: 3.

	self assert: events equals: 2! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexesAddsIndexesToSelectedIndexList
	presenter selectIndexes: {1 . 2}.
	self assert: (presenter selection includesIndexes: {1 . 2})! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectAllSelectsAllItems

	presenter selectAll.
	self assert: presenter selection selectedItems asSet equals: presenter model items asSet! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexesOutsideRangeHasNoSelectedIndexes
	presenter selectIndexes: {4 . 5}.
	self assert: presenter selection selectedIndexes isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectMultipleIndexesAddsAllToSelectedItemList

	presenter selectIndex: 1.
	presenter selectIndex: 3.
	self assert: (presenter selection includesItem: 10).
	self assert: (presenter selection includesItem: 30).! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectUnselectedItemRaisesNoSelectionEvent
	
	| counter |
	counter := 0.
	presenter
		selectItem: 10;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectItem: 20.
	self assert: counter equals: 0! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsThenSelectOutsideRangeKeepsElements
	presenter selectItems: {10 . 20}.
	presenter selectItems: {4000 . 5000}.
	self assert: (presenter selection includesItems: {10 . 20})! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectSelectedItemRemovesItFromSelectionList

	presenter
		selectItem: 10;
		unselectItem: 10.
	self assert: (presenter selection isEmpty)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemThenSelectOutsideRangeKeepsFirstElement

	presenter selectItem: 10.
	presenter selectItem: 5000.
	self assert: (presenter selection includesItem: 10)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpListPresenter! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectIndexOutsideRangeDoesNotModifySelection

	presenter whenSelectionChangedDo: [ :selection | self fail ].
	
	presenter selectIndex: 4.
	"If we arrive here and the test did not fail, we succeeded"! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexOutsideRangeHasNoSelectedItems

	presenter selectIndex: 4.
	self assert: presenter selection selectedItems isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemThenSelectOutsideRangeKeepsSingleSelectedItem

	presenter selectItem: 10.
	presenter selectItem: 3000.
	self assert: presenter selection selectedItems size equals: 1! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemOutsideRangeHasNoSelectedItems

	presenter selectItem: 400.
	self assert: presenter selection selectedItems isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexesThenSelectOutsideRangeKeepsElements
	presenter selectIndexes: {1 . 2}.
	presenter selectIndexes: {50 . 60}.
	self assert: (presenter selection includesItems: {10 . 20})! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemOutsideRangeIsEmpty

	presenter selectItem: 4000.
	self assert: presenter selection isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectUnselectedIndexKeepsSelectionList

	presenter
		selectIndex: 1;
		unselectIndex: 2.
	self assert: presenter selection selectedIndexes asArray equals: #(1)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectSelectedIndexRaisesSelectionEventOnce
	
	| counter |
	counter := 0.
	presenter
		selectIndex: 1;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectIndex: 1.
	self assert: counter equals: 1! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexThenSelectOutsideRangeKeepsFirstIndex

	presenter selectIndex: 1.
	presenter selectIndex: 50.
	self assert: (presenter selection includesIndex: 1)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemAddsIndexToSelectedIndexList

	presenter selectItem: 10.
	self assert: (presenter selection includesIndex: 1)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsAddsItemsToSelectedItemList
	presenter selectItems: {10 . 20}.
	self assert: (presenter selection includesItems: {10 . 20})! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexTwiceAddsIndexToSelectedIndexListOnlyOnce

	presenter
		selectIndex: 1;
		selectIndex: 1.
	self assert: presenter selection selectedIndexes asArray equals: #(1)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsThenSelectOutsideRangeKeepsIndexes
	presenter selectItems: {10 . 20}.
	presenter selectItems: {500 . 600}.
	self assert: (presenter selection includesIndexes: {1 . 2})! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexOutsideRangeIsEmpty

	presenter selectIndex: 4.
	self assert: presenter selection isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectAllRaisesSelectionEventOnce
	"Because it does nothing in single selection mode"
	| events |
	events := 0.
	presenter whenSelectionChangedDo: [ :selection | events := events + 1 ].

	presenter selectAll.

	self assert: events equals: 1! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectSelectedIndexRemovesItFromSelectionList

	presenter
		selectIndex: 1;
		unselectIndex: 1.
	self assert: (presenter selection isEmpty)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemAddsItemToSelectedItemList

	presenter selectItem: 10.
	self assert: (presenter selection includesItem: 10)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectMultipleItemsAddsAllToSelectedItemList

	presenter selectItem: 10.
	presenter selectItem: 30.
	self assert: (presenter selection includesItem: 10).
	self assert: (presenter selection includesItem: 30).! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexesAddsItemsToSelectedItemList
	presenter selectIndexes: {1 . 2}.
	self assert: (presenter selection includesItems: {10 . 20})! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemThenSelectOutsideRangeKeepsFirstIndex

	presenter selectItem: 10.
	presenter selectItem: 500.
	self assert: (presenter selection includesIndex: 1)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexThenSelectOutsideRangeKeepsFirstElement

	presenter selectIndex: 1.
	presenter selectIndex: 50.
	self assert: (presenter selection includesItem: 10)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectMultipleIndexesAddsAllToSelectedIndexList

	presenter selectIndex: 1.
	presenter selectIndex: 3.
	self assert: (presenter selection includesIndex: 1).
	self assert: (presenter selection includesIndex: 3).! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsOutsideRangeIsEmpty
	presenter selectItems: {4000 . 5000}.
	self assert: presenter selection isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectUnselectedIndexRaisesNoSelectionEvent
	
	| counter |
	counter := 0.
	presenter
		selectIndex: 1;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectIndex: 2.
	self assert: counter equals: 0! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexOutsideRangeHasNoSelectedIndexes

	presenter selectIndex: 4.
	self assert: presenter selection selectedIndexes isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsOutsideRangeHasNoSelectedItems
	presenter selectItems: {300 . 400}.
	self assert: presenter selection selectedItems isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectAllUnselectsall

	presenter
		selectIndex: 1;
		unselectAll.
	self assert: presenter selection isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexAddsItemToSelectedItemList

	presenter selectIndex: 1.
	self assert: (presenter selection includesItem: 10)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	presenter
		beMultipleSelection;
		items: #(10 20 30)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsAddsIndexesToSelectedIndexList
	presenter selectItems: {10 . 20}.
	self assert: (presenter selection includesIndexes: #(1 2))! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexesThenSelectOutsideRangeKeepsIndexes
	presenter selectIndexes: {1 . 2}.
	presenter selectIndexes: {50 . 60}.
	self assert: (presenter selection includesIndexes: {1 . 2})! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsOutsideRangeHasNoSelectedIndexes
	presenter selectItems: {300 . 400}.
	self assert: presenter selection selectedIndexes isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemOutsideRangeDoesNotModifySelection

	presenter whenSelectionChangedDo: [ :selection | self fail ].
	
	presenter selectItem: 100.
	"If we arrive here and the test did not fail, we succeeded"! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectMultipleItemsRaisesSelectionChangeEventMultipleTimes
	| events |
	events := 0.
	presenter whenSelectionChangedDo: [ :selection | events := events + 1 ].

	presenter selectItem: 10.
	presenter selectItem: 30.

	self assert: events equals: 2! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexesTwiceAddsIndexesToSelectedIndexListOnlyOnce
	presenter
		selectIndexes: {1 . 2};
		selectIndexes: {1 . 2}.
	self assertCollection: presenter selection selectedIndexes hasSameElements: {1 . 2}! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectIndexRaisesSelectionChangeEventWithSelectedIndex
	| selectedIndexes |
	presenter
		whenSelectionChangedDo: [ :selection | selectedIndexes := selection selectedIndexes ].
	presenter selectIndex: 1.
	self assert: (selectedIndexes includes: 1)! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectAllRaisesSelectionEventOnce
	"Because it does nothing in single selection mode"

	| events |
	events := 0.

	"Be sure there is one element selected at least to make selection change"
	presenter selectIndex: 1.
	presenter
		whenSelectionChangedDo: [ :selection | events := events + 1 ].
	presenter unselectAll.
	self assert: events equals: 1! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexesOutsideRangeHasNoSelectedItems
	presenter selectIndexes: {4 . 5}.
	self assert: presenter selection selectedItems isEmpty! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexThenSelectOutsideRangeKeepsSingleSelectedItem

	presenter selectIndex: 1.
	presenter selectIndex: 50.
	self assert: presenter selection selectedItems size equals: 1! !

!SpListPresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemOutsideRangeHasNoSelectedIndexes

	presenter selectItem: 400.
	self assert: presenter selection selectedIndexes isEmpty! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectIndexOutsideRangeRaisesSelectionChangeEventWithUnsetItem
	| selectedItem |
	presenter
		whenSelectionChangedDo: [ :selection | selectedItem := selection selectedItem ].
	presenter selectIndex: 4.
	self assert: selectedItem equals: nil! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectIndexRaisesSelectionChangeEventWithSelectedItem
	| selectedElement |

	presenter
		whenSelectionChangedDo: [ :selection | selectedElement := selection selectedItem ].
	presenter selectIndex: 1.
	self assert: selectedElement equals: 10! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectIndexRaisesSelectionItemChangeEventWithSelectedIndex
	| selectedItem |
	presenter
		whenSelectionChangedDo: [ :selection | selectedItem := selection selectedItem ].
	presenter selectIndex: 1.
	self assert: selectedItem equals: 10! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemOutsideRangeUnsetsSelectedIndex
	
	presenter selectItem: 40.
	self assert: presenter selection selectedIndex equals: 0! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemOutsideRangeUnsetsSelectedItem

	presenter selectItem: 40.
	self assert: presenter selection selectedItem equals: nil! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectNonSelectedItemRaisesNoEvent
	
	| counter |
	counter := 0.
	presenter
		selectItem: 10;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectItem: 20.

	self assert: counter equals: 0! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemOutsideRangeRaisesSelectionChangeEventWithUnsetIndex
	| selectedIndex |

	presenter
		whenSelectionChangedDo: [ :selection | selectedIndex := selection selectedIndex ].
	presenter selectItem: 40.
	self assert: selectedIndex equals: 0! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemOutsideRangeRaisesSelectionChangeEventWithUnsetItem
	| selectedItem |
	presenter
		whenSelectionChangedDo: [ :selection | selectedItem := selection selectedItem ].
	presenter selectItem: 40.
	self assert: selectedItem equals: nil! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectMultipleIndexesRaisesSelectionChangeEventMultipleTimes
	| events |
	events := 0.
	presenter whenSelectionChangedDo: [ :selection | events := events + 1 ].

	presenter	selectIndex: 1.
	presenter	selectIndex: 3.

	self assert: events equals: 2! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemSetsSelectedItem
	presenter selectItem: 20.
	self assert: presenter selection selectedItem equals: 20! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectSelectedItemRaisesSingleEvent
	
	| counter |
	counter := 0.
	presenter
		selectItem: 10;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectItem: 10.

	self assert: counter equals: 1! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexSetsSelectedIndex

	presenter selectIndex: 1.
	self assert: presenter selection selectedIndex equals: 1! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexTwiceMakesIsListedOnceInSelectedIndexes
	presenter
		selectIndex: 3;
		selectIndex: 3.

	self assert: presenter selection selectedIndexes asArray equals: #(3)! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectAllWithExistingSelectionLeavesSelection
	presenter
		selectIndex: 1;
		selectAll.

	self assert: (presenter selection includesIndex: 1)! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexTwiceMakesIndexSelected
	presenter
		selectIndex: 3;
		selectIndex: 3.

	self assert: (presenter selection includesIndex: 3)! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectNonSelectedItemDoesNotRemovesSelection
	presenter
		selectItem: 10;
		unselectItem: 30.

	self assert: presenter selection selectedItem equals: 10! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemRaisesSelectionItemChangeEventWithSelectedItem
	| selectedItem |
	presenter
		whenSelectionChangedDo: [ :selection | selectedItem := selection selectedItem ].
	presenter selectItem: 10.
	self assert: selectedItem equals: 10! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexOutsideRangeUnsetsSelectedItem

	presenter selectIndex: 4.
	self assert: presenter selection selectedItem equals: nil! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectAllDoesNotSelect
	presenter selectAll.

	self assert: presenter selection isEmpty! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectSelectedIndexRemovesSelection
	presenter
		selectIndex: 1;
		unselectIndex: 1.

	self assert: presenter selection isEmpty! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectAllDoesNotRaiseEvent
	"Because it does nothing in single selection mode"
	| events |
	events := 0.
	presenter whenSelectionChangedDo: [ :selection | events := events + 1 ].

	presenter selectAll.

	self assert: events equals: 0! !

!SpListPresenterSingleSelectionTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.

	presenter
		beSingleSelection;
		items: #(10 20 30)! !

!SpListPresenterSingleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpListPresenter! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectNonSelectedIndexRaisesNoEvent
	
	| counter |
	counter := 0.
	presenter
		selectIndex: 1;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectIndex: 2.

	self assert: counter equals: 0! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectSelectedItemRemovesSelection

	presenter
		selectItem: 10;
		unselectItem: 10.

	self assert: presenter selection isEmpty! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedIndex |
	presenter selection
		whenChangedDo: [ :selection | selectedIndex := selection selectedIndex ].
	presenter selectItem: 10.
	self assert: selectedIndex equals: 1! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectSelectedIndexRaisesSingleEvent
	
	| counter |
	counter := 0.
	presenter
		selectIndex: 1;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectIndex: 1.

	self assert: counter equals: 1! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemRaisesSelectionChangeEventWithSelectedItem
	| selectedElement |
	presenter
		whenSelectionChangedDo: [ :selection | selectedElement := selection selectedItem ].
	presenter selectItem: 20.
	self assert: selectedElement equals: 20! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemSetsSelectedIndex

	presenter selectItem: 20.
	self assert: presenter selection selectedIndex equals: 2! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemRaisesSelectionChangeEventWithSelectedIndex
	| selectedIndex |

	presenter
		whenSelectionChangedDo: [ :selection | selectedIndex := selection selectedIndex ].
	presenter selectItem: 20.
	self assert: selectedIndex equals: 2! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectAllUnselectsSingleSelection

	presenter
		selectIndex: 1;
		unselectAll.
	self assert: presenter selection isEmpty! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexSetsSelectedItem

	presenter selectIndex: 1.
	self assert: presenter selection selectedItem equals: 10! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectIndexOutsideRangeRaisesSelectionChangeEventWithUnsetIndex
	| selectedIndex |
	presenter
		whenSelectionChangedDo: [ :selection | selectedIndex := selection selectedIndex ].
	presenter selectIndex: 4.
	self assert: selectedIndex equals: 0! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectIndexRaisesSelectionChangeEventWithSelectedIndex
	| selectedIndex |
	presenter
		whenSelectionChangedDo: [ :selection | selectedIndex := selection selectedIndex ].
	presenter selectIndex: 1.
	self assert: selectedIndex equals: 1! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectAllRaisesSelectionEventOnce
	"Because it does nothing in single selection mode"
	| events |
	events := 0.
	presenter whenSelectionChangedDo: [ :selection | events := events + 1 ].

	presenter unselectAll.

	self assert: events equals: 1! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectNonSelectedIndexDoesNotRemovesSelection
	presenter
		selectIndex: 1;
		unselectIndex: 3.

	self assert: presenter selection selectedIndex equals: 1! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectIndexRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedIndex |
	presenter selection
		whenChangedDo: [ :selection | 
			selectedIndex := selection selectedIndex ].
	presenter selectIndex: 1.
	self assert: selectedIndex equals: 1! !

!SpListPresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectIndexOutsideRangeUnsetsSelectedIndex
	presenter selectIndex: 4.

	self assert: (presenter selection includesIndex: 0)! !

!SpListPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	
	^ SpListPresenter! !

!SpListPresenterTest methodsFor: 'tests' stamp: ''!
testWhenIconsChangedDo
	| icon counter |
	counter := 0.
	presenter
		whenIconsChangedDo: [ :iconBlock | 
			icon := iconBlock cull: #add.
			counter := counter + 1 ].
	presenter displayIcon: [ :item | Smalltalk ui icons iconNamed: item asSymbol ].
	self assert: icon equals: (Smalltalk ui icons iconNamed: #add).
	self assert: counter equals: 1! !

!SpListPresenterTest methodsFor: 'tests - header' stamp: ''!
testIconFor
	presenter
		items: #(#add #back #catalog);
		displayIcon: [ :item | Smalltalk ui icons iconNamed: item asSymbol ].
	self assert: (presenter iconFor: #add) equals: (Smalltalk ui icons iconNamed: #add)! !

!SpListPresenterTest methodsFor: 'tests - header' stamp: ''!
testHideHeaderTitleUnsetsTitle

	presenter
		headerTitle: 'title';
		hideHeaderTitle.
	
	self deny: presenter hasHeaderTitle! !

!SpListPresenterTest methodsFor: 'tests - header' stamp: ''!
testSetHeaderTitleHasTitle

	presenter headerTitle: 'title'.
	
	self assert: presenter hasHeaderTitle! !

!SpListPresenterTest methodsFor: 'tests - header' stamp: ''!
testSetHeaderTitleSetsTitle

	presenter headerTitle: 'title'.
	
	self assert: presenter headerTitle equals: 'title'! !

!SpListSearchTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpListPresenter! !

!SpListSelectionModel commentStamp: ''!
This is deprecated class because the original class ListSelectionModel was renamed to ListSelectionPresenter. You should stop to use this class and modify your code to use ListSelectionPresenter.!
!SpListSelectionPresenter commentStamp: ''!
A ListSelectionPresenter is a basic example to show multi selection on lists

self example!
!SpListSelectionPresenter methodsFor: 'update' stamp: ''!
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 selection selectedIndexes sort
		collect: [ :i | i printString ].
	indexes := indexes joinUsing: '; '.
	items := listModel selectedItems collect: [ :i | i printString ].
	items := items sort joinUsing: '; '.
	UIManager default
		defer: [ textModel1 text: indexes.
			textModel2 text: items ] ] fork! !

!SpListSelectionPresenter methodsFor: 'accessing' stamp: ''!
textModel1

	^ textModel1! !

!SpListSelectionPresenter methodsFor: 'accessing' stamp: ''!
listModel

	^ listModel! !

!SpListSelectionPresenter methodsFor: 'accessing' stamp: ''!
textModel2

	^ textModel2! !

!SpListSelectionPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	listModel := self newList.
	textModel1 := self newText.
	textModel2 := self newCode.
	listModel beMultipleSelection.
	listModel items: self class environment allClasses! !

!SpListSelectionPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters
	listModel whenSelectionChangedDo: [ self updateText ]! !

!SpListSelectionPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpPanedLayout newTopToBottom
		add: #listModel;
		add:
			(SpPanedLayout newLeftToRight
				add: #textModel1;
				add: #textModel2;
				yourself);
		yourself! !

!SpListSelectionPresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new openWithSpec! !

!SpListSelectionPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpListSelectionPresenter! !

!SpListsDemoPage commentStamp: ''!
Description
--------------------

I am a demo page to show how to use spec lists.!
!SpListsDemoPage methodsFor: 'initialization' stamp: ''!
pageClass
	^ SpDemoListsPresenter! !

!SpListsDemoPage class methodsFor: 'initialization' stamp: ''!
pageName
	^ 'Lists'! !

!SpLocationIconProvider commentStamp: ''!
I provide access to icons in png from the file system. 
It receive locations (directory references) where to find them.

Alternatively, it can also look for gtk theme icons (stored by name in the gtk theme).!
!SpLocationIconProvider methodsFor: 'accessing' stamp: ''!
icons

	^ icons! !

!SpLocationIconProvider methodsFor: 'initialization' stamp: ''!
initializeBlankIcon

	self setBlankIcon: (Form extent: 16@16 depth: 8)! !

!SpLocationIconProvider methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	locations := #().
	icons := Dictionary new.
	self initializeBlankIcon! !

!SpLocationIconProvider methodsFor: 'accessing' stamp: ''!
setBlankIcon: aForm
	"To be able to specify the form that represents a missing icon."
	
	icons at: #blank put: aForm! !

!SpLocationIconProvider methodsFor: 'accessing' stamp: ''!
addLocation: aReference

	locations := locations copyWith: aReference! !

!SpLocationIconProvider methodsFor: 'utilities' stamp: ''!
loadAllIcons

	self locations do: [ :eachLocation |
		(eachLocation filesMatching: '*.png') do: [ :each |
			icons 
				at: each basename
				put: (self loadIcon: each) ] ]! !

!SpLocationIconProvider methodsFor: 'utilities' stamp: ''!
loadIcon: fileReference

	fileReference exists ifFalse: [ 
		self error: ('Icon {1} does not exit' format: { fileReference fullName }) ].

	^ fileReference binaryReadStreamDo: [ :stream |
		 Form fromBinaryStream: stream ]! !

!SpLocationIconProvider methodsFor: 'utilities' stamp: ''!
loadIconNamed: aSymbol

	self locations do: [ :each | | ref |
		ref := (each / aSymbol) withExtension: 'png'.
		ref exists ifTrue: [ 
			^ self loadIcon: ref ] ].
	^ nil! !

!SpLocationIconProvider methodsFor: 'inspecting' stamp: ''!
inspectionIcons
	<inspectorPresentationOrder: 0 title: 'Icons'> 

	^ SpListPresenter new
		items: (icons associations sorted: [ :a :b | a key < b key ]);
		displayIcon: [ :each | each value ];
		display: [ :each | each key ];
		yourself! !

!SpLocationIconProvider methodsFor: 'accessing' stamp: ''!
iconNamed: aName ifAbsent: aBlock

	| icon |
	icon := icons at: aName ifAbsent: [ nil ].
	icon ifNil: [ 
		icon := self loadIconNamed: aName.
		icon ifNil: [ ^ aBlock value ].
		icons at: aName put: icon ].

	^ icon! !

!SpLocationIconProvider methodsFor: 'accessing' stamp: ''!
locations

	^ locations! !

!SpLocationIconProvider methodsFor: 'accessing' stamp: ''!
menuIconNamed: aName 

	^ self iconNamed: aName! !

!SpLocationIconProvider class methodsFor: 'instance creation' stamp: ''!
newLocation: aLocation

	^ self new 
		addLocation: aLocation;
		yourself! !

!SpMenuBarPresenter commentStamp: ''!
A presenter to describe a menuBar. 
I'm different from a simple menu in: 

- I cannot be used as submenu (simple menus can).
- I will render a menuBar instead a simple menu (this can be the same as a menu in certain platforms, but others may differ).

Tipically, this menu will be presented at the top of a window.!
!SpMenuBarPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentExtraSections: aBuilder
	"It does not applies here"! !

!SpMenuBarPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newMenuBar! !

!SpMenuBarPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	| presenter menuBar submenuFile submenuEdit |

	(presenter := SpPresenter new) 
		layout: (SpBoxLayout newTopToBottom 
			add: (menuBar := presenter newMenuBar) expand: false;
			add: (presenter newLabel label: 'Empty space');
			yourself).
			
	submenuFile := SpMenuPresenter new 
		addItem: [ :item | item name: 'Quit'; icon: (self iconNamed: #smallQuit); action: [ "Action" ] ];
		yourself.
			
	submenuEdit := SpMenuPresenter new 
		addItem: [ :item | item name: 'Copy'; icon: (self iconNamed: #smallCopy); action: [ "Action" ] ];
		addItem: [ :item | item name: 'Cut'; icon: (self iconNamed: #smallCut); action: [ "Action" ] ];
		addItem: [ :item | item name: 'Paste'; icon: (self iconNamed: #smallPaste); action: [ "Action" ] ];
		yourself.

	menuBar addGroup: [ :group | group
		addItem: [ :item | item name: 'File'; subMenu: submenuFile ];
		addItem: [ :item | item name: 'Edit'; subMenu: submenuEdit ] ].

	^ presenter openWithSpec! !

!SpMenuBarPresenter class methodsFor: 'documentation' stamp: ''!
documentExampleCodeSelector

	^ #example! !

!SpMenuBarPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #MenuBarAdapter! !

!SpMenuBarPresenterBuilder commentStamp: ''!
I am a visitor that builds a Spec MenuBarPresenter from a commands and commands group.!
!SpMenuBarPresenterBuilder class methodsFor: 'accessing' stamp: ''!
menuPresenterClass
	^ SpMenuBarPresenter! !

!SpMenuBarPresenterBuilderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	menuBuilder := SpMenuBarPresenterBuilder new.! !

!SpMenuButtonPresenter commentStamp: ''!
A presenter to create a menu button (a button who exposes a menu instead having an action) 
!
!SpMenuButtonPresenter methodsFor: 'api' stamp: ''!
menu: aValuable
	"Set the menu to show. 
	 `aValuable` can be an instance of `SpMenuPresenter` or a block to allow dynamic behavior."

	menu := aValuable! !

!SpMenuButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.! !

!SpMenuButtonPresenter methodsFor: 'api' stamp: ''!
menu
	"Answer the menu (an instance of `SpMenuPresenter` or a block) to show."

	^ menu! !

!SpMenuButtonPresenter methodsFor: 'api - events' stamp: ''!
whenMenuChangedDo: aBlock
	"Inform when menu  property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #menu whenChangedDo: aBlock! !

!SpMenuButtonPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newMenuButton! !

!SpMenuButtonPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	| presenter menuButton loremIpsumWords |

	(presenter := SpPresenter new) 
		layout: (SpBoxLayout newTopToBottom
			add: (SpBoxLayout newLeftToRight
					addLast: (menuButton := presenter newMenuButton) expand: false;
					yourself)
				expand: false;
			yourself).	

	loremIpsumWords := String loremIpsum substrings.
	menuButton menu: [ 
		SpMenuPresenter new
			addGroup: [ :group | group
				addItem: [ :item | item name: '1: ', loremIpsumWords atRandom ];
				addItem: [ :item | item name: '2: ', loremIpsumWords atRandom ];
				addItem: [ :item | item name: '3: ', loremIpsumWords atRandom ] ];
			yourself ].
		
	^ presenter openWithSpec! !

!SpMenuButtonPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #MenuButtonAdapter! !

!SpMenuButtonPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'MenuButton'! !

!SpMenuButtonPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpMenuButtonPresenter! !

!SpMenuButtonPresenterTest methodsFor: 'tests' stamp: ''!
testSmokeMenu
	
	presenter menu: (SpMenuPresenter new
		addGroup: [ :group | group
			addItem: [ :item | item name: 'One' ];
			addItem: [ :item | item name: 'Two' ];
			addItem: [ :item | item name: 'Three' ] ];
		yourself).
	self openInstance! !

!SpMenuGroupPresenter commentStamp: ''!
A presenter for grouping menu items.
A group is always part of a menu (See `SpMenuPresenter`), and it groups items (See `SpMenuItemPresenter`).!
!SpMenuGroupPresenter methodsFor: 'private' stamp: ''!
add: aName target: targetObject selector: aSelector
	
	self flag: #TODO. "This is for compatibility with the old menu builder and needs to be removed!!"
	self addItem: [ :item | 
		item 
			name: aName; 
			action: [ targetObject perform: aSelector ] ].
	^ self menuItems last! !

!SpMenuGroupPresenter methodsFor: 'testing' stamp: ''!
isEmpty
	"Answer true if the group is empty"

	^ items isEmpty! !

!SpMenuGroupPresenter methodsFor: 'TOREMOVE' stamp: ''!
fromSpec: aSpec
	self addItem: [ :item | item fromSpec: aSpec ]! !

!SpMenuGroupPresenter methodsFor: 'TOREMOVE' stamp: ''!
autoRefresh: aBoolean
	autoRefresh := aBoolean! !

!SpMenuGroupPresenter methodsFor: 'api' stamp: ''!
addItem: aBlock
	| item |
	
	item := self instantiate: SpMenuItemPresenter.
	aBlock value: item.
	self addMenuItem: item! !

!SpMenuGroupPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	items := OrderedCollection new asValueHolder! !

!SpMenuGroupPresenter methodsFor: 'api' stamp: ''!
menuItems

	^ items value! !

!SpMenuGroupPresenter methodsFor: 'testing' stamp: ''!
canTakeKeyboardFocus
	"Answer when the presenter can take keyboard focus."

	^ false! !

!SpMenuGroupPresenter methodsFor: 'TOREMOVE' stamp: ''!
autoRefresh
	^ autoRefresh! !

!SpMenuGroupPresenter methodsFor: 'private' stamp: ''!
addMenuItem: aMenuItem

	aMenuItem owner: self.
	items add: aMenuItem! !

!SpMenuGroupPresenter methodsFor: 'private' stamp: ''!
rootMenu

	^ self owner rootMenu! !

!SpMenuGroupPresenter methodsFor: 'private' stamp: ''!
buildWithSpecLayout: aSpecLayout
	"Build the widget using the spec name provided as argument"
	| widget|
	adapter := self basicBuildAdapterWithSpecLayout: aSpecLayout.
	widget := adapter widget.
	self announce: (SpWidgetBuilt model: self widget: widget).
	^ widget! !

!SpMenuGroupPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleMenuGroup
	| menu |
	
	menu := SpMenuPresenter new 
		addGroup: [ :aGroup |
			aGroup addItem: [ :anItem |
				anItem name: 'Item Group 1'; action: [ "action here" ] ] ];
		addGroup: [ :aGroup |
			aGroup addItem: [ :anItem |
				anItem name: 'Item Group 2'; action: [ "action here" ] ] ].
	
	SpMenuButtonPresenter new 
		menu: menu;
		openWithSpec! !

!SpMenuGroupPresenter class methodsFor: 'documentation' stamp: ''!
documentExampleCodeSelector

	^ #exampleMenuGroup! !

!SpMenuGroupPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #MenuGroupAdapter! !

!SpMenuItemPresenter commentStamp: ''!
A presenter to define a menu item. 
A menu item needs to be included into a group (See `SpMenuGroupPresenter`) and through it a context menu (See `SpMenuPresenter`), or a menu bar (See `SpMenuBarPresenter`).

A menu item can have: an action (See `SpMenuItemPresenter>>#action:`) **OR** it can include a submenu (See `SpMenuItemPresenter>>#subMenu:`), but it cannot have both properties at a time.

Tipically, you do not call directly `SpMenuItemPresenter`. Instead, you use the builder method provided when building a `SpMenuPresenter` (See example below).!
!SpMenuItemPresenter methodsFor: 'TOREMOVE' stamp: ''!
fromSpec: aSpec
	| en newSubMenu |
	en := aSpec enabledBlock ifNil: [ aSpec enabled ].
	newSubMenu := aSpec subMenu ifNotNil: [ :sub | SpMenuPresenter new fromSpec: sub ].
	self
		name: aSpec label;
		state: aSpec checked;
		enabled: en;
		icon: aSpec icon;
		shortcut: aSpec keyText;
		subMenu: newSubMenu;
		action: aSpec action! !

!SpMenuItemPresenter methodsFor: 'TOREMOVE' stamp: ''!
autoRefresh: aBlock
	autoRefresh := aBlock! !

!SpMenuItemPresenter methodsFor: 'localization' stamp: ''!
localeChanged

	super localeChanged.
	self forceUpdateSlot: #name
	! !

!SpMenuItemPresenter methodsFor: 'testing' stamp: ''!
hasShortcut

	^ self shortcut notNil! !

!SpMenuItemPresenter methodsFor: 'TOREMOVE' stamp: ''!
iconName: aSymbol
	"This will need to be removed because #iconNamed: will be depending on application, hence it 
	 does not has sense."

	self icon: (self iconNamed: aSymbol)! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
description
	"Answer the description for the menu item."

	^ description! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
icon
	"Answer the icon to be shown with the menu item."

	^ icon! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
name: aString
	"The label of the menu item. 
	 In certain backends (Gtk), we allow this label to contain mnemonics using an underscore ($_)
	 before the mnemonic letter: 
	 ```
	 aMenuItemPresenter name: '_File'.
	 ```"

	name := aString! !

!SpMenuItemPresenter methodsFor: 'TOREMOVE' stamp: ''!
keyText: aString

	self flag: #TODO. "This is for backward compatibility and needs to be removed!!"
	self shortcut: aString first meta! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
shortcut
	^ shortcut! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
subMenu: aMenuPresenter
	"Set the submenu that will be displayed with this menu.
	 If a submenu is shown, defined action (See `SpMenuItemPresenter>>#action:`) will be ignored."


	aMenuPresenter ifNotNil: [ aMenuPresenter owner: self ].
	subMenu := aMenuPresenter! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
icon: anIcon
	"Set an icon (an instance of `Form`) to be shown with the menu item."

	icon := anIcon! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
action: aBlock
	"Set the action to be executed when the menu item is selected.
	 `aBlock` receives zero arguments."

	action := aBlock! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
shortcut: aShortcut
	"Set a shortcut (an instance of `KMKeyCombination`) that be shown with the menu item. 
	 **IMPORTANT:** Since most menus are added dinamically to its presenters (as part of a 
	 context menu), the shortcut defined in the menu is **NOT** automatically added to the 
	 window. User needs to declare them using `SpPresenter>>#bindKeyCombination:toAction:` 
	 or `SpPresenter>>#contextKeyBindings:`"
	
	shortcut := aShortcut! !

!SpMenuItemPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	action := [  ].
	name := ''.
	autoRefresh := false! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
action
	"Answer the action to be executed when the menu item is selected."

	^ action! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
description: aString
	"Set a description for the menu item. In some platforms (like Morphic), it can be shown as a 
	 tooltip text."

	description := aString! !

!SpMenuItemPresenter methodsFor: 'TOREMOVE' stamp: ''!
state: aBoolean

	self flag: #REVIEW. "Maybe not removed but implemented correctly?"
	state := aBoolean! !

!SpMenuItemPresenter methodsFor: 'api - events' stamp: ''!
whenNameChangedDo: aBlock 
	"Inform when name  has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #name whenChangedDo: aBlock! !

!SpMenuItemPresenter methodsFor: 'testing' stamp: ''!
isMenuPresenter

	^ true! !

!SpMenuItemPresenter methodsFor: 'private' stamp: ''!
performMenuActionWith: aMenuItem
	| en |

	en := self isEnabled.
	en isBlock ifTrue: [ en := en value ].
	en ifFalse: [ ^ self ].

	self action cull: aMenuItem! !

!SpMenuItemPresenter methodsFor: 'TOREMOVE' stamp: ''!
autoRefresh
	^ autoRefresh! !

!SpMenuItemPresenter methodsFor: 'TOREMOVE' stamp: ''!
state
	^ state! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
name
	"Answer the name of the menu item. This will be displayed as label."

	^ name! !

!SpMenuItemPresenter methodsFor: 'api - events' stamp: ''!
whenIconChangedDo: aBlock 
	"Inform when icon has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #icon whenChangedDo: aBlock! !

!SpMenuItemPresenter methodsFor: 'api - events' stamp: ''!
whenDescriptionChangedDo: aBlock 
	"Inform when description has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #description whenChangedDo: aBlock! !

!SpMenuItemPresenter methodsFor: 'private' stamp: ''!
rootMenu 
	
	^ self owner rootMenu! !

!SpMenuItemPresenter methodsFor: 'api' stamp: ''!
subMenu
	"Answer the submenu that will be displayed with this menu if any, or nil."

	^ subMenu! !

!SpMenuItemPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithSubMenu

	^ SpMenuPresenter new
		addItem: [ :item | item name: 'Test 1'; action: [ "action" ] ];
		addItem: [ :item | 
			item 
				name: 'Test 2'; 
				subMenu: (SpMenuPresenter new 
					addItem: [ :subMenuItem | subMenuItem name: 'SubMenu 1'; action: [ ] ];
					addItem: [ :subMenuItem | subMenuItem name: 'SubMenu 2'; action: [ ] ];
					addItem: [ :subMenuItem | subMenuItem name: 'SubMenu 3'; action: [ ] ];
					yourself) ];
		addItem: [ :item | item name: 'Test 3'; action: [ "Action" ] ];
		openWithSpecAt: self currentHand position.! !

!SpMenuItemPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithinMenuButton
	| presenter menuButton loremIpsumWords |

	(presenter := SpPresenter new) 
		layout: (SpBoxLayout newTopToBottom
			add: (SpBoxLayout newLeftToRight
					addLast: (menuButton := presenter newMenuButton) expand: false;
					yourself)
				expand: false;
			yourself).	

	loremIpsumWords := String loremIpsum substrings.
	menuButton menu: [ 
		SpMenuPresenter new
			addGroup: [ :group | group
				addItem: [ :item | item name: '1: ', loremIpsumWords atRandom ];
				addItem: [ :item | item name: '2: ', loremIpsumWords atRandom ];
				addItem: [ :item | item name: '3: ', loremIpsumWords atRandom ] ];
			yourself ].
		
	^ presenter openWithSpec! !

!SpMenuItemPresenter class methodsFor: 'documentation' stamp: ''!
documentExampleCodeSelector

	^ #exampleShowAtPointer! !

!SpMenuItemPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #MenuItemAdapter! !

!SpMenuItemPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleShowAtPointer

	^ SpMenuPresenter new
		addItem: [ :item | item name: 'Test 1'; action: [ "Action" ] ];
		addItem: [ :item | item name: 'Test 2'; action: [ "action" ] ];
		addItem: [ :item | item name: 'Test 3'; action: [ "Action" ] ];
		openWithSpecAt: self currentHand position.! !

!SpMenuItemPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpMenuItemPresenter! !

!SpMenuItemPresenterTest methodsFor: 'tests' stamp: ''!
testIcon

	presenter icon: (Smalltalk ui icons iconNamed: 'smallCancel').
	self openInstance.
	presenter icon: (Smalltalk ui icons iconNamed: 'smallOk').
	self 
		assert: presenter adapter widgetIcon 
		equals: (Smalltalk ui icons iconNamed: 'smallOk')! !

!SpMenuItemPresenterTest methodsFor: 'tests' stamp: ''!
testName

	presenter name: 'Test'.
	self openInstance.
	presenter name: 'Changed'.
	self assert: presenter adapter widgetName equals: 'Changed'! !

!SpMenuPresenter commentStamp: ''!
A presenter to describe a menu.
A menu presenter contains groups of menu items (having one unique group by default, to simplify building simple menus).
A menu presenter is included in presenters that implement the `#contextMenu:` (See below) method, but it can also be invoked by calling `SpMenuPresenter>>#openWithSpecAt:`!
!SpMenuPresenter methodsFor: 'private' stamp: ''!
addMenuGroup: aMenuGroup

	aMenuGroup owner: self.
	groups add: aMenuGroup! !

!SpMenuPresenter methodsFor: 'TOREMOVE' stamp: ''!
autoRefresh: aBoolean
	autoRefresh := aBoolean! !

!SpMenuPresenter methodsFor: 'api' stamp: ''!
addItem: aBlock
	"Add an item to the menu. When the menu group has not been specified previously, add the 
	 item in a default group.
	 For adding multiple groups, see `SpMenuPresenter>>#addGroup:`"

	self defaultGroup addItem: aBlock! !

!SpMenuPresenter methodsFor: 'api - building' stamp: ''!
fromSpec: aSpec
	| grps subgroup |
	
	grps := OrderedCollection new.
	aSpec label ifNotNil: [ :label | self title: label ]. "only change the title when a new one is specified"
	
	subgroup := OrderedCollection new.
	aSpec items do: [ :each | 
		subgroup add: each.
		each separator
			ifTrue: [ 
				grps add: subgroup copy.
				subgroup removeAll ] ].
	subgroup ifNotEmpty: [ grps add: subgroup copy ].
	
	grps do: [ :each | self 
		addGroup: [ :group | each do: [ :spec | 
			group addItem: [ :item | item fromSpec: spec ] ] ] ]! !

!SpMenuPresenter methodsFor: 'localization' stamp: ''!
localeChanged

	super localeChanged.
	self forceUpdateSlot: #title
	! !

!SpMenuPresenter methodsFor: 'TOREMOVE' stamp: ''!
iconName: aSymbol
	self icon: (self iconNamed: aSymbol)! !

!SpMenuPresenter methodsFor: 'api' stamp: ''!
addGroup: aBlock
	"Add a group of items. 
	 If you do not want a multiple-group menu, you can use `SpMenuPresenter>>#addItem:` instead."
	| group |

	group := self instantiate: SpMenuGroupPresenter.
	aBlock value: group.
	self addMenuGroup: group! !

!SpMenuPresenter methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	self title value
		ifNotNil: [ :t | 
			aStream
				nextPutAll: ' ''';
				nextPutAll: t;
				nextPutAll: '''' ]! !

!SpMenuPresenter methodsFor: 'testing' stamp: ''!
canTakeKeyboardFocus

	^ false! !

!SpMenuPresenter methodsFor: 'TOREMOVE' stamp: ''!
neglect: aModel

	aModel neglectMenuModel: self! !

!SpMenuPresenter methodsFor: 'api' stamp: ''!
icon
	^ icon! !

!SpMenuPresenter methodsFor: 'api' stamp: ''!
icon: anIcon
	icon := anIcon! !

!SpMenuPresenter methodsFor: 'api' stamp: ''!
title
	^ title! !

!SpMenuPresenter methodsFor: 'api' stamp: ''!
openWithSpecAtPointer
	"Open this menu at cursor position"

	self buildWithSpecAsPopup.
	self withAdapterDo: [ :anAdapter | anAdapter openAtPointer ]! !

!SpMenuPresenter methodsFor: 'api' stamp: ''!
addKeybindingsTo: aPresenter
	"bind keybindings (shortcuts) defined in this menu to aPresenter"

	aPresenter applyKeyBindingsFromMenu: self! !

!SpMenuPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	groups := OrderedCollection new! !

!SpMenuPresenter methodsFor: 'api' stamp: ''!
openWithSpecAt: aPosition
	"Open this menu at `aPosition`. 
	 `aPosition` os a instance of `Point`"

	self buildWithSpecAsPopup.
	self withAdapterDo: [ :anAdapter | anAdapter openAt: aPosition ]! !

!SpMenuPresenter methodsFor: 'api' stamp: ''!
title: aString
	title := aString! !

!SpMenuPresenter methodsFor: 'accessing' stamp: ''!
defaultGroup

	^ defaultGroup ifNil: [ 
		defaultGroup := self instantiate: SpMenuGroupPresenter.
		self addMenuGroup: defaultGroup.
		defaultGroup ]! !

!SpMenuPresenter methodsFor: 'api - building' stamp: ''!
addAllFromPragma: pragma target: target

	self fromSpec: (PragmaMenuBuilder 
		pragmaKeyword: pragma
		model: target) menuSpec! !

!SpMenuPresenter methodsFor: 'accessing' stamp: ''!
shortcutGroup: aKeyGroup
	
	shortcutGroup := aKeyGroup! !

!SpMenuPresenter methodsFor: 'testing' stamp: ''!
isMenuPresenter

	^ true! !

!SpMenuPresenter methodsFor: 'TOREMOVE' stamp: ''!
autoRefresh
	^ autoRefresh! !

!SpMenuPresenter methodsFor: 'api' stamp: ''!
menuGroups
	^ groups! !

!SpMenuPresenter methodsFor: 'accessing' stamp: ''!
rootMenu

	^ self owner isMenuPresenter 
		ifTrue: [ self owner rootMenu ]
		ifFalse: [ self ]
! !

!SpMenuPresenter methodsFor: 'accessing' stamp: ''!
shortcutGroup
	"Some platforms use acceleration groups to store shortcut keys. 
	 if that's the case, we use this property to access it later (and store 
	 in windows, for example)"

	^ shortcutGroup! !

!SpMenuPresenter methodsFor: 'api - building' stamp: ''!
buildWithSpecAsPopup

	^ self buildWithSpec! !

!SpMenuPresenter class methodsFor: 'documentation' stamp: ''!
addDocumentExtraSections: aBuilder

	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Presenters implementing `#contextMenu:`' ] withLevel: 2.
	aBuilder unorderedListDuring: [ 
		(SpTContextMenu users sorted: #name ascending) do: [ :eachType | 
			aBuilder item: [
				aBuilder monospace: eachType name ] ] ]	! !

!SpMenuPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newMenu! !

!SpMenuPresenter class methodsFor: 'documentation' stamp: ''!
documentExampleCodeSelector

	^ #exampleShowAtPointer! !

!SpMenuPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithGroups

	^ self new 
		addGroup: [ :group | group  
			addItem: [ :item | item name: 'Group 1. Test 1'; action: [ "Action" ] ];
			addItem: [ :item | item name: 'Group 1. Test 2'; action: [ "Action" ] ];
			addItem: [ :item | item name: 'Group 1. Test 3'; action: [ "Action" ] ] ];
		addGroup: [ :group | group  
			addItem: [ :item | item name: 'Group 2. Test 1'; action: [ "Action" ] ];
			addItem: [ :item | item name: 'Group 2. Test 2'; action: [ "Action" ] ];
			addItem: [ :item | item name: 'Group 2. Test 3'; action: [ "Action" ] ] ];
		openWithSpecAt: self currentHand position	! !

!SpMenuPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #MenuAdapter! !

!SpMenuPresenter class methodsFor: 'specs' stamp: ''!
popup
	<spec>
	
	^ #(MenuAdapter
		adaptAsPopup: #(presenter))! !

!SpMenuPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleShowAtPointer

	^ self new 
		addItem: [ :item | item name: 'Test 1'; action: [ "Action" ] ];
		addItem: [ :item | item name: 'Test 2'; action: [ "Action" ] ];
		addItem: [ :item | item name: 'Test 3'; action: [ "Action" ] ];
		openWithSpecAt: self currentHand position! !

!SpMenuPresenterBuilder commentStamp: ''!
I am a visitor that builds a Spec MenuPresenter from a commands and commands group.!
!SpMenuPresenterBuilder methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	self menuPresenter: self class menuPresenterClass new.
	stack := Stack new
		push: self menuPresenter;
		yourself! !

!SpMenuPresenterBuilder methodsFor: 'private' stamp: ''!
fillItem: aMenuItem with: aCommand

	aMenuItem
		name: aCommand name;
		description: aCommand description;
		icon: aCommand icon;
		action: [ aCommand execute ].

	aCommand hasShortcutKey ifTrue: [ 
		aMenuItem shortcut: aCommand shortcutKey ].
		
	^ aMenuItem! !

!SpMenuPresenterBuilder methodsFor: 'visiting' stamp: ''!
visitCommandGroup: aCmCommandsGroup

	aCmCommandsGroup isRoot ifTrue: [ 
		super visitCommandGroup: aCmCommandsGroup.
		^ self ].
	
	aCmCommandsGroup 
		displayIn: stack top 
		do: [ :specGroupOrSubMenu |
			stack push: specGroupOrSubMenu.
			super visitCommandGroup: aCmCommandsGroup.
			stack pop ]! !

!SpMenuPresenterBuilder methodsFor: 'accessing' stamp: ''!
menuPresenter: anObject
	menuPresenter := anObject! !

!SpMenuPresenterBuilder methodsFor: 'visiting' stamp: ''!
visitCommand: aCmCommand

	aCmCommand 
		displayIn: stack top 
		do: [ :item | self fillItem: item with: aCmCommand ]! !

!SpMenuPresenterBuilder methodsFor: 'accessing' stamp: ''!
menuPresenter
	^ menuPresenter! !

!SpMenuPresenterBuilder class methodsFor: 'accessing' stamp: ''!
menuPresenterClass
	^ SpMenuPresenter! !

!SpMenuPresenterBuilderTest commentStamp: ''!
A LtMenuPresenterBuilderTest is a test class for testing the behavior of LtMenuPresenterBuilder!
!SpMenuPresenterBuilderTest methodsFor: 'tests' stamp: ''!
testVisitCommandsGroup
	| menuItems |
	self assert: menuBuilder menuPresenter defaultGroup menuItems isEmpty.
	
	commandsGroup acceptVisitor: menuBuilder.
	
	menuItems := menuBuilder menuPresenter defaultGroup menuItems.
	self assert: menuItems size equals: 3.
	self assert: menuItems first class equals: SpMenuItemPresenter.
	self assert: menuItems first name equals: commandsGroup entries first name.
	self assert: menuItems first description equals: commandsGroup entries first description.
	self assert: menuItems first subMenu isNil.
	self assert: menuItems second class equals: SpMenuItemPresenter.
	self assert: menuItems second name equals: commandsGroup entries second name.
	self assert: menuItems second description equals: commandsGroup entries second description.
	self assert: menuItems second subMenu isNotNil.
	self assert: menuItems second subMenu class equals: SpMenuPresenter.
	self assert: menuItems second subMenu menuGroups size equals: 1.
	self assert: menuItems second subMenu menuGroups first menuItems size equals: 2.
	self assert: menuItems second subMenu menuGroups first menuItems first class equals: SpMenuItemPresenter.
	self assert: menuItems second subMenu menuGroups first menuItems first name equals: commandsGroup entries second entries first name.
	self assert: menuItems second subMenu menuGroups first menuItems first description equals: commandsGroup entries second entries first description.
	self assert: menuItems second subMenu menuGroups first menuItems second class equals: SpMenuItemPresenter.
	self assert: menuItems second subMenu menuGroups first menuItems second name equals: commandsGroup entries second entries second name.
	self assert: menuItems second subMenu menuGroups first menuItems second description equals: commandsGroup entries second entries second description.
	self assert: menuItems third class equals: SpMenuItemPresenter.
	self assert: menuItems third name equals: commandsGroup entries third name.
	self assert: menuItems third description equals: commandsGroup entries third description.
	self assert: menuItems third subMenu isNil.! !

!SpMenuPresenterBuilderTest methodsFor: 'tests' stamp: ''!
testVisitCommandThatCantBeRunWithDisableStrategy
	self assert: menuBuilder menuPresenter defaultGroup menuItems isEmpty.
	(CmBlockCommand new
		name: 'c';
		description: 'desc';
		context: [ 41 ];
		canBeExecutedBlock: [ :x | x = 42 ];
		block: [ :x | 42 ];
		yourself) asSpecCommand acceptVisitor: menuBuilder.
	self
		assert: menuBuilder menuPresenter defaultGroup menuItems size
		equals: 1! !

!SpMenuPresenterBuilderTest methodsFor: 'tests' stamp: ''!
testVisitCommand
	| menuItem evaluationResult |
	evaluationResult := nil.
	self assert: menuBuilder menuPresenter defaultGroup menuItems isEmpty.
	(CmBlockCommand new
		name: 'c';
		description: 'desc';
		context: [ 41 ];
		block: [ :x | evaluationResult := x + 1 ];
		yourself) asSpecCommand acceptVisitor: menuBuilder.
	self
		assert: menuBuilder menuPresenter defaultGroup menuItems size
		equals: 1.
	menuItem := menuBuilder menuPresenter defaultGroup menuItems first.
	self assert: menuItem class equals: SpMenuItemPresenter.
	self assert: menuItem name equals: 'c'.
	self assert: menuItem description equals: 'desc'.
	self assert: evaluationResult isNil.
	menuItem action value.
	self assert: evaluationResult equals: 42! !

!SpMenuPresenterBuilderTest methodsFor: 'tests' stamp: ''!
testVisitCommandThatCantBeRunWithHideStrategy
	self assert: menuBuilder menuPresenter defaultGroup menuItems isEmpty.
	(CmBlockCommand new
		name: 'c';
		description: 'desc';
		context: [ 41 ];
		canBeExecutedBlock: [ :x | x = 42 ];
		block: [ :x | 42 ];
		yourself) asSpecCommand beHiddenWhenCantBeRun
		acceptVisitor: menuBuilder.
	self assert: menuBuilder menuPresenter defaultGroup menuItems isEmpty! !

!SpMenuPresenterBuilderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	menuBuilder := SpMenuPresenterBuilder new.
	commandsGroup := (CmCommandGroup named: 'root') asSpecGroup beRoot
		register:
			(CmBlockCommand new
				name: 'c1';
				block: [  ];
				yourself) asSpecCommand;
		register:
			((CmCommandGroup named: 'sub1') asSpecGroup
				register:
					(CmBlockCommand new
						name: 'c2';
						block: [  ];
						yourself) asSpecCommand;
				register:
					(CmBlockCommand new
						name: 'c3';
						block: [  ];
						yourself) asSpecCommand);
		register:
			(CmBlockCommand new
				name: 'c4';
				block: [  ];
				yourself) asSpecCommand;
		yourself! !

!SpMenuPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpMenuPresenter! !

!SpMenuPresenterTest methodsFor: 'tests' stamp: ''!
testValue 

	self assert: presenter value equals: presenter! !

!SpMenuPresenterTest methodsFor: 'tests' stamp: ''!
testFromSpecSubMenu
	| root subMenuRoot parent subMenu |
	root := PluggableMenuSpec withModel: nil.
	parent := root add: 'parent'.
	subMenuRoot := PluggableMenuSpec withModel: nil.
	subMenuRoot add: 'child'.
	parent subMenu: subMenuRoot.
	presenter fromSpec: root.
	subMenu := presenter menuGroups first menuItems first subMenu.
	self assert: subMenu menuGroups size equals: 1.
	self assert: subMenu menuGroups first menuItems size equals: 1.
	self assert: subMenu menuGroups first menuItems first name equals: 'child'.
	self openInstance! !

!SpMenuPresenterTest methodsFor: 'tests' stamp: ''!
testFromSpecSingle
	| menuDescription |
	menuDescription := PluggableMenuSpec withModel: nil.
	menuDescription add: 'item'.
	presenter fromSpec: menuDescription.
	self assert: presenter menuGroups size equals: 1.
	self assert: presenter menuGroups first menuItems size equals: 1.
	self assert: presenter menuGroups first menuItems first name equals: 'item'.
	self openInstance! !

!SpMergeStyleTest methodsFor: 'tests' stamp: ''!
testMergingTwoStylesWithASameClassHasRightOnlyClass

	result := (left mergeWith: right) flattenClasses.

	self assert: (result anySatisfy: [ :e | e fullName = 'rightClass' ]).			
! !

!SpMergeStyleTest methodsFor: 'tests' stamp: ''!
testMergingTwoStylesWithASameClassHasClassInBothSides

	result := (left mergeWith: right) flattenClasses.

	self assert: (result anySatisfy: [ :e | e fullName = 'aCommonClass' ]).
	self assert: (result anySatisfy: [ :e | e fullName = 'aCommonClass.inner' ]).	
! !

!SpMergeStyleTest methodsFor: 'tests' stamp: ''!
testMergingTwoStylesWithASameClassHasCorrectNumberOfEntries

	result := (left mergeWith: right) flattenClasses.

	self assert: result size equals: 5.
! !

!SpMergeStyleTest methodsFor: 'tests' stamp: ''!
testMergingTwoStylesWithASameClassHasLeftOnlyClass

	result := (left mergeWith: right) flattenClasses.

	self assert: (result anySatisfy: [ :e | e fullName = 'leftClass' ]).	
! !

!SpMergeStyleTest methodsFor: 'tests' stamp: ''!
testMergingTwoStylesWithASameClassHasThePropertiesCorrectInCommonClass

	| innerClass |

	result := (left mergeWith: right) flattenClasses.

	innerClass := result detect: [ :e | e fullName = 'aCommonClass' ].
	self assert: innerClass properties size equals: 1.
	self assert: (innerClass properties at: 1) color equals: Color transparent.
	self assert: (innerClass properties at: 1) backgroundColor equals: Color black.! !

!SpMergeStyleTest methodsFor: 'running' stamp: ''!
setUp 

	super setUp.
	
	left := SpStyle newApplication
					addClass: 'aCommonClass' with: [ :aCommonClass |
						aCommonClass addPropertyDrawWith: [ :propDraw | propDraw color: Color transparent ]];
					addClass: 'leftClass' with: [ :leftClass |
						leftClass addPropertyDrawWith: [ :propDraw | propDraw color: Color red ]].
	
	right := SpStyle newApplication
					addClass: 'aCommonClass' with: [ :aCommonClass |
						aCommonClass addClass: 'inner' with: [ :anInnerClass |  ].
						aCommonClass addPropertyDrawWith: [ :propDraw | propDraw color: Color transparent ].
						aCommonClass addPropertyDrawWith: [ :propDraw | propDraw backgroundColor: Color black ]];
					addClass: 'rightClass' with: [ :rightClass |
						rightClass addPropertyDrawWith: [ :propDraw | propDraw color: Color blue ]].

	
	! !

!SpMethodBrowser commentStamp: ''!
A MethodBrowser is a simple browser using Spec to display a list of methods and their source code

self example!
!SpMethodBrowser methodsFor: 'api' stamp: ''!
sortingBlock: aBlock 

	listModel sortingBlock: aBlock ! !

!SpMethodBrowser methodsFor: 'accessing' stamp: ''!
whenSubmitDo: aBlock

	textModel whenSubmitDo: aBlock! !

!SpMethodBrowser methodsFor: 'accessing' stamp: ''!
action
	^ textModel acceptBlock! !

!SpMethodBrowser methodsFor: 'api' stamp: ''!
methods: aList

	"Here I reroute my entry point to the list model's entry point"
	self listModel items: aList! !

!SpMethodBrowser methodsFor: 'accessing' stamp: ''!
listModel

	^ listModel! !

!SpMethodBrowser methodsFor: 'focus' stamp: ''!
takeKeyboardFocus

	^ self listModel takeKeyboardFocus! !

!SpMethodBrowser methodsFor: 'accessing' stamp: ''!
textModel

	^ textModel! !

!SpMethodBrowser methodsFor: 'accessing' stamp: ''!
toolbarModel

	^ toolbarModel! !

!SpMethodBrowser methodsFor: 'api' stamp: ''!
wrapWith: aBlock
	listModel display: aBlock! !

!SpMethodBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters
	listModel := self instantiate: SpListPresenter .
	textModel := self newCode.
	toolbarModel := self instantiate: SpMethodToolbarPresenter.
	self focusOrder
		add: listModel;
		add: toolbarModel;
		add: textModel! !

!SpMethodBrowser methodsFor: 'initialization' stamp: ''!
connectPresenters

	listModel whenSelectionChangedDo: [ :selection | 
		selection isEmpty
			ifTrue: [ 
				textModel text: ''.
				textModel beForMethod: nil.
				toolbarModel method: nil ]
			ifFalse: [ | m |
				m := selection selectedItem. 
				textModel text: m sourceCode.
				textModel beForMethod: m.
				toolbarModel method: m ] ].
	self whenSubmitDo: [ :text | self listModel selectedItem inspect ].
	self wrapWith: [ :item | item methodClass name , '>>#' , item selector ]! !

!SpMethodBrowser methodsFor: 'api' stamp: ''!
displayBlock: aBlock

	listModel displayBlock: aBlock! !

!SpMethodBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpPanedLayout newTopToBottom
		add: #listModel;
		add:
			(SpBoxLayout newTopToBottom
				add: #toolbarModel withConstraints: [ :constraints | constraints height: self toolbarHeight ];
				add: #textModel;
				yourself);
		yourself! !

!SpMethodBrowser class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := SpMethodBrowser new.
	example methods: Object methods;
	 openWithSpec.
	^example! !

!SpMethodBrowser class methodsFor: 'specs' stamp: ''!
title

	^ 'Method Browser'! !

!SpMethodBrowserTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpMethodBrowser! !

!SpMethodToolbarPresenter commentStamp: ''!
A MethodToolbar is xxxxxxxxx.

self example!
!SpMethodToolbarPresenter methodsFor: 'accessing' stamp: ''!
sendersModel

	^ sendersModel! !

!SpMethodToolbarPresenter methodsFor: 'accessing' stamp: ''!
usersModel
	^ usersModel! !

!SpMethodToolbarPresenter methodsFor: 'initialization' stamp: ''!
registerForChanges
	self
		property: #method
		whenChangedDo: [ :contents | 
			| boolean |
			boolean := contents ifNil: [ false ] ifNotNil: [ true ].
			browseModel state: boolean.
			usersModel state: boolean.
			sendersModel state: boolean.
			versionModel state: boolean.
			implementorsModel state: boolean ]! !

!SpMethodToolbarPresenter methodsFor: 'private' stamp: ''!
browseMethod

	self method ifNotNil: [ :aMethod | aMethod browse ]! !

!SpMethodToolbarPresenter methodsFor: 'private' stamp: ''!
usersMethod
	self method methodClass ifNotNil: [ :class | self model browseClassRefsOf: class ]! !

!SpMethodToolbarPresenter methodsFor: 'initialization' stamp: ''!
setImplementorsModel
	
	implementorsModel
		state: false;
		label: 'Implementors';
		action: [ self implementorsMethod ].
	
! !

!SpMethodToolbarPresenter methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aMethod

	self method: aMethod! !

!SpMethodToolbarPresenter methodsFor: 'private' stamp: ''!
implementorsMethod
	self method ifNotNil: [ :aMethod | self model browseMessagesFrom: aMethod selector ]! !

!SpMethodToolbarPresenter methodsFor: 'initialization' stamp: ''!
setBrowseModel
	
	browseModel
		state: false;
		label: 'Browse';
		action: [ self browseMethod ].
	
! !

!SpMethodToolbarPresenter methodsFor: 'accessing' stamp: ''!
browseModel

	^ browseModel! !

!SpMethodToolbarPresenter methodsFor: 'accessing' stamp: ''!
implementorsModel

	^ implementorsModel! !

!SpMethodToolbarPresenter methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!SpMethodToolbarPresenter methodsFor: 'api' stamp: ''!
emptyDropList
	
	dropListModel emptyList! !

!SpMethodToolbarPresenter methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!SpMethodToolbarPresenter methodsFor: 'initialization' stamp: ''!
initialize
	model := AbstractTool new.

	super initialize! !

!SpMethodToolbarPresenter methodsFor: 'private' stamp: ''!
sendersMethod
	self method ifNotNil: [ :aMethod | self model browseSendersOfMessagesFrom: aMethod selector ]! !

!SpMethodToolbarPresenter methodsFor: 'initialization' stamp: ''!
setFocusOrder

	self focusOrder
		add: browseModel;
		add: usersModel;
		add: sendersModel;
		add: implementorsModel;
		add: versionModel.
		! !

!SpMethodToolbarPresenter methodsFor: 'initialization' stamp: ''!
setVersionModel
	
	versionModel
		state: false;
		label: 'Version';
		action: [ self versionMethod ].
	
! !

!SpMethodToolbarPresenter methodsFor: 'api' stamp: ''!
addItemLabeled: aString do: aBlock

	dropListModel addItemLabeled: aString do: aBlock! !

!SpMethodToolbarPresenter methodsFor: 'accessing' stamp: ''!
dropListModel

	^ dropListModel! !

!SpMethodToolbarPresenter methodsFor: 'accessing' stamp: ''!
versionModel

	^ versionModel! !

!SpMethodToolbarPresenter methodsFor: 'api' stamp: ''!
method: aMethod

	method := aMethod! !

!SpMethodToolbarPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	browseModel := self newButton.
	usersModel := self newButton.
	sendersModel := self newButton.
	implementorsModel := self newButton.
	versionModel := self newButton.
	dropListModel := self newDropList.
	self
		setFocusOrder;
		setBrowseModel;
		setUsersModel;
		setVersionModel;
		setSendersModel;
		setImplementorsModel! !

!SpMethodToolbarPresenter methodsFor: 'initialization' stamp: ''!
setUsersModel
	usersModel
		state: false;
		label: 'Users';
		action: [ self usersMethod ]! !

!SpMethodToolbarPresenter methodsFor: 'initialization' stamp: ''!
setSendersModel
	
	sendersModel
		state: false;
		label: 'Senders';
		action: [ self sendersMethod ].
	
! !

!SpMethodToolbarPresenter methodsFor: 'private' stamp: ''!
versionMethod
	self method ifNotNil: [ :aMethod | self model browseVersionsFrom: aMethod ]! !

!SpMethodToolbarPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	^ SpBoxLayout newLeftToRight
		add: #browseModel;
		add: #usersModel;
		add: #sendersModel;
		add: #implementorsModel;
		add: #versionModel;
		add: #dropListModel;
		yourself! !

!SpMethodToolbarPresenter class methodsFor: '*Spec2-Morphic-Examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := SpMethodToolbarPresenter new.
	example
		method: SpButtonPresenter >> #state:;
		method: nil;
		extent: 550 @ 100;
		openWithSpec.
		^example ! !

!SpMethodToolbarPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Toolbar'! !

!SpMethodToolbarPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpMethodToolbarPresenter! !

!SpMillerActivation methodsFor: 'accessing' stamp: ''!
value: anInteger 
	value := anInteger! !

!SpMillerActivation methodsFor: 'accessing' stamp: ''!
selectedItem
	
	^ value! !

!SpMillerActivation class methodsFor: 'instance creation' stamp: ''!
on: anInteger 
	
	^ self new
		value: anInteger;
		yourself! !

!SpMillerColumnAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpMillerColumnPresenter! !

!SpMillerColumnAdapterTest methodsFor: 'tests' stamp: ''!
testOnePresenterShowsOneWidget

	self presenter addPresenter: (SpNullMillerPresenter on: SpLabelPresenter new).
	
	self assert: self adapter childrenWidgets size equals: 1! !

!SpMillerColumnAdapterTest methodsFor: 'tests' stamp: ''!
testManyPresentersShowManyWidgets

	3 timesRepeat: [ self presenter addPresenter: (SpNullMillerPresenter on: SpLabelPresenter new).].
	self assert: self adapter childrenWidgets size equals: 3! !

!SpMillerColumnAdapterTest methodsFor: 'tests' stamp: ''!
testEnabledAffectWidget

	"This test is not valid for non-widget presenters"
	^ self skip! !

!SpMillerColumnAdapterTest methodsFor: 'tests' stamp: ''!
testResettingMillerListRemovesWidgets

	3 timesRepeat: [ self presenter addPresenter: (SpNullMillerPresenter on: SpLabelPresenter new).].
	
	self presenter resetTo: 0.
	self assert: self adapter childrenWidgets isEmpty! !

!SpMillerColumnAdapterTest methodsFor: 'tests' stamp: ''!
testEmptyMillerListHasNoWidgets

	self assert: self adapter childrenWidgets isEmpty! !

!SpMillerColumnAdapterTest methodsFor: 'tests' stamp: ''!
testChangingHelpAffectTheWidget

	"This test is not valid for non-widget presenters"
	^ self skip! !

!SpMillerColumnPresenter commentStamp: ''!
I am a miller columns widget, a.k.a. cascading lists.
I am composed of presenters flowing to the right.
Every time that one of my inner presenters is activated, I "dive in" that element, showing a new presenter for the activated element to the right of the current selection.

You have to set me:
- `presenterBlock:` aBlock that receives a model as argument and returns a `SpMillerPresenter` or compatible (read below)
- a first presenter using either
  - `setModel:` with a model  that calculates the initial presenter using the presenter block if already available.
  - `setPresenter:` with a `SpMillerPresenter` or compatible (read below)

`SpMillerColumnPresenter` works on `SpMillerPresenter` or compatible objects.
All presenters inside this one should be polymorphic, defining: `whenActivatedDo:`, an event that will invoke a valuable with a selection object (understanding the message `selectedObject`).!
!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
withHorizontalScrollBar

	horizontalScrollBar := true! !

!SpMillerColumnPresenter methodsFor: 'private' stamp: ''!
announceColumnsWillChange: index

	columnsWillChangeBlock ifNil: [ ^ self ]. 
	columnsWillChangeBlock cull: index! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
visiblePages

	^ layout visiblePages! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
visiblePages: aNumber 

	layout visiblePages: aNumber! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
addPresenter: newSubPresenter

	newSubPresenter whenActivatedDo: [ :selection | 
		self changeSelection: selection selectedItem from: newSubPresenter ].
	newSubPresenter owner: self.
	layout add: newSubPresenter! !

!SpMillerColumnPresenter methodsFor: 'private' stamp: ''!
changeSelection: selection from: aPresenter
	| selectedPresenterIndex |

	selectedPresenterIndex := self presenters indexOf: aPresenter.
	self announceColumnsWillChange: selectedPresenterIndex.
	self resetTo: selectedPresenterIndex.
	self pushModel: selection.
	self announceColumnsChanged: selectedPresenterIndex! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
selectPage: aNumber

	self withAdapterDo: [ :anAdapter |
		anAdapter selectPage: aNumber ]! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
withoutHorizontalScrollBar

	horizontalScrollBar := false! !

!SpMillerColumnPresenter methodsFor: 'api - events' stamp: ''!
whenColumnsWillChangeDo: aBlock

	columnsWillChangeBlock := aBlock! !

!SpMillerColumnPresenter methodsFor: 'testing' stamp: ''!
hasHorizontalScrollBar

	^ horizontalScrollBar! !

!SpMillerColumnPresenter methodsFor: 'private - traversing' stamp: ''!
traverseInFocusOrderDo: aBlock excluding: excludes

	self pages do: [ :each | 
		each 
			traverseInFocusOrderDo: aBlock 
			excluding: excludes ]! !

!SpMillerColumnPresenter methodsFor: 'private' stamp: ''!
resetTo: anIndex
	"Remove all presenters up to anIndex.
	0 means to remove all elements."
	self presenters copy withIndexDo: [ :presenter :index |
		index <= anIndex ifFalse: [ layout remove: presenter ] ]! !

!SpMillerColumnPresenter methodsFor: 'private' stamp: ''!
newPresenterFor: aModel

	^ newPresenterBlock value: aModel! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
spacing

	^ layout spacing! !

!SpMillerColumnPresenter methodsFor: 'private' stamp: ''!
announceColumnsChanged: index

	columnsChangedBlock ifNil: [ ^ self ]. 
	columnsChangedBlock cull: index! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
presenterBlock: aBlock 
	
	newPresenterBlock := aBlock! !

!SpMillerColumnPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	newPresenterBlock := [ :model | Error signal: 'should provide a new presenter block' ].
	self withHorizontalScrollBar! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
presenters

	^ layout presenters! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
pages
	
	^ layout presenters! !

!SpMillerColumnPresenter methodsFor: 'api - events' stamp: ''!
whenColumnsChangedDo: aBlock

	columnsChangedBlock := aBlock! !

!SpMillerColumnPresenter methodsFor: 'paginator' stamp: ''!
scrollByDeltaPercent: percent
	
	self withAdapterDo: [ :anAdapter | 
		anAdapter scrollByDeltaPercent: percent ]! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
size

	^ self presenters size! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
removeAllFrom: aPage
	"remove all columns starting by this page."
	| index |

	index := (self pages indexOf: aPage) - 1.
	self resetTo: index.
	self selectPage: index! !

!SpMillerColumnPresenter methodsFor: 'api' stamp: ''!
spacing: aNumber

	layout spacing: aNumber! !

!SpMillerColumnPresenter methodsFor: 'model' stamp: ''!
pushModel: aModel

	self addPresenter: (self newPresenterFor: aModel)! !

!SpMillerColumnPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	
	layout := SpMillerLayout newHorizontal! !

!SpMillerColumnPresenter methodsFor: 'api - events' stamp: ''!
whenHorizontalScrollBarChangedDo: aBlock

	self property: #horizontalScrollBar whenChangedDo: aBlock! !

!SpMillerColumnPresenter methodsFor: 'model' stamp: ''!
setRootModel: aModel

	self resetTo: 0.
	self pushModel: aModel! !

!SpMillerColumnPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	^ SpMillerColumnPresenter new
		presenterBlock: [ :model | 
			SpListPresenter new
				items: (1 to: model);
				yourself ];
		setRootModel: 10;
		openWithSpec! !

!SpMillerColumnPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	
	^ SpMillerColumnPresenter! !

!SpMillerColumnPresenterTest methodsFor: 'tests' stamp: ''!
testSetRootModelManyTimesPushesOnlyOnePresenterToList

	self presenter presenterBlock: [ :model | 
		SpNullMillerPresenter on: (SpLabelPresenter new label: model asString) ].

	1 to: 3 do: [ :each | self presenter setRootModel: each ].
	
	self assert: self presenter size equals: 1! !

!SpMillerColumnPresenterTest methodsFor: 'tests' stamp: ''!
testSetRootModelWithPresenterDoesNotFail

	self presenter presenterBlock: [ :model | 
		SpNullMillerPresenter on: (SpLabelPresenter new label: model asString) ].
	
	self
		shouldnt: [self presenter setRootModel: 1]
		raise: Error! !

!SpMillerColumnPresenterTest methodsFor: 'tests' stamp: ''!
testSetRootModelWithoutPresenterBlockFails

	self
		should: [self presenter setRootModel: 1]
		raise: Error! !

!SpMillerColumnPresenterTest methodsFor: 'tests' stamp: ''!
testAddManyPresentersPushesThemToPresenterList

	3 timesRepeat: [self presenter addPresenter: (SpNullMillerPresenter on: SpLabelPresenter new)].
	self assert: self presenter size equals: 3! !

!SpMillerColumnPresenterTest methodsFor: 'tests' stamp: ''!
testSetRootModelResetsToSinglePresenter

	self presenter presenterBlock: [ :model | 
		SpNullMillerPresenter on: (SpLabelPresenter new label: model asString) ].
	3 timesRepeat: [self presenter addPresenter: (SpNullMillerPresenter on: SpLabelPresenter new)].
	
	self presenter setRootModel: 1.
	self assert: self presenter size equals: 1! !

!SpMillerColumnPresenterTest methodsFor: 'tests' stamp: ''!
testSetRootModelManyTimesPushesOnlyLastPresenterToList

	| nullMillerPresenter |
	self presenter presenterBlock: [ :model | 
		SpNullMillerPresenter on: (SpLabelPresenter new label: model asString) ].

	1 to: 3 do: [ :each | self presenter setRootModel: each ].
	
	nullMillerPresenter := self presenter presenters first.
	self
		assert: nullMillerPresenter wrappedPresenter label
		equals: 3 asString! !

!SpMillerColumnPresenterTest methodsFor: 'tests' stamp: ''!
testActivateSubPresenterPushesElementToList

	| mock |
	self presenter presenterBlock: [ :model | mock := SpMockMillerPresenter new ].	
	self presenter setRootModel: 1.
	
	mock activate.
	self assert: self presenter size equals: 2! !

!SpMillerColumnPresenterTest methodsFor: 'tests' stamp: ''!
testAddPresenterPushesItToPresenterList

	self presenter addPresenter: (SpNullMillerPresenter on: SpLabelPresenter new).
	self assert: self presenter size equals: 1! !

!SpMillerColumnPresenterTest methodsFor: 'tests' stamp: ''!
testPushModelUsesPresenterBlock

	| subpresenter |
	self presenter presenterBlock: [ :model | 
		subpresenter := SpNullMillerPresenter on: (SpLabelPresenter new label: model asString) ].	
	self presenter pushModel: 1.
	self assert: self presenter presenters first equals: subpresenter! !

!SpMillerColumnPresenterTest methodsFor: 'tests' stamp: ''!
testSetRootModelPushesPresenterToList

	self presenter presenterBlock: [ :model | 
		SpNullMillerPresenter on: (SpLabelPresenter new label: model asString) ].
	self presenter setRootModel: 1.
	
	self assert: self presenter size equals: 1! !

!SpMillerLayout commentStamp: ''!
I'm a layout to implement miller lists. 
Since I am intended to be used dynamically (adding/removing components on demand), I implement just `add:` and `remove:` related methods.
You can also control borderWith and spacing between elements.!
!SpMillerLayout methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpMillerLayout methodsFor: 'adding' stamp: ''!
add: aName

	self 
		add: aName 
		withConstraints: [ :constraints | ]! !

!SpMillerLayout methodsFor: 'accessing' stamp: ''!
visiblePages

	^ visiblePages! !

!SpMillerLayout methodsFor: 'accessing' stamp: ''!
borderWidth

	^ borderWidth! !

!SpMillerLayout methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpMillerLayout methodsFor: 'accessing' stamp: ''!
visiblePages: aNumber

	visiblePages := aNumber! !

!SpMillerLayout methodsFor: 'initialization - deprecated' stamp: ''!
beHorizontal

	direction := SpLayoutDirection horizontal! !

!SpMillerLayout methodsFor: 'testing' stamp: ''!
isVertical 

	^ self direction = SpLayoutDirection vertical! !

!SpMillerLayout methodsFor: 'initialization' stamp: ''!
beTopToBottom

	direction := SpLayoutDirection vertical! !

!SpMillerLayout methodsFor: 'testing' stamp: ''!
isHorizontal 

	^ self direction = SpLayoutDirection horizontal! !

!SpMillerLayout methodsFor: 'initialization - deprecated' stamp: ''!
beVertical

	direction := SpLayoutDirection vertical! !

!SpMillerLayout methodsFor: 'removing' stamp: ''!
remove: aPresenter

	children 
		removeKey: aPresenter 
		ifAbsent: [ self removeBySymbol: aPresenter ].
	adapter ifNotNil: [ :theAdapter | theAdapter remove: aPresenter ]! !

!SpMillerLayout methodsFor: 'api - events' stamp: ''!
whenVisiblePagesChangedDo: aBlock

	self property: #visiblePages whenChangedDo: aBlock! !

!SpMillerLayout methodsFor: 'private' stamp: ''!
adapterName

	^ #MillerAdapter! !

!SpMillerLayout methodsFor: 'accessing' stamp: ''!
spacing

	^ spacing! !

!SpMillerLayout methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpMillerLayout methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpMillerLayout methodsFor: 'adding' stamp: ''!
add: aPresenter withConstraints: aBlock
	
	super add: aPresenter withConstraints: aBlock.
	adapter ifNotNil: [ :theAdapter |
		theAdapter add: aPresenter constraints: (children at: aPresenter) ]! !

!SpMillerLayout methodsFor: 'initialization' stamp: ''!
initialize
	
	self class initializeSlots: self.

	super initialize.
	self spacing: 0.
	self borderWidth: 0.
	self visiblePages: 2! !

!SpMillerLayout methodsFor: 'accessing' stamp: ''!
borderWidth: aNumber

	borderWidth := aNumber! !

!SpMillerLayout methodsFor: 'initialization' stamp: ''!
beLeftToRight

	direction := SpLayoutDirection horizontal! !

!SpMillerLayout methodsFor: 'private' stamp: ''!
constraintsClass

	^ SpLayoutConstraints! !

!SpMillerLayout methodsFor: 'accessing' stamp: ''!
direction 

	^ direction! !

!SpMillerLayout methodsFor: 'removing' stamp: ''!
removeAll

	children removeAll.
	adapter ifNotNil: [ :anAdapter | 
		anAdapter unsubscribe.
		anAdapter removeAll ]! !

!SpMillerLayout methodsFor: 'accessing' stamp: ''!
spacing: aNumber

	spacing := aNumber! !

!SpMillerLayout class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpMillerLayout class methodsFor: 'instance creation' stamp: ''!
new 

	self error: 'Use one of my siblings'! !

!SpMillerLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpMillerLayout class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpMillerLayout class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpMillerLayout class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpMillerLayout class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpMillerLayout class methodsFor: 'instance creation' stamp: ''!
newLeftToRight

	^ super new beHorizontal! !

!SpMillerLayout class methodsFor: 'instance creation' stamp: ''!
newHorizontal 

	^ super new beHorizontal! !

!SpMillerLayout class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpMillerLayout class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpMillerLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMillerLayout class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpMillerLayout class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpMillerLayout class methodsFor: 'instance creation' stamp: ''!
newVertical 

	^ super new beVertical! !

!SpMillerLayout class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpMillerLayout class methodsFor: 'instance creation' stamp: ''!
newTopToBottom

	^ super new beVertical! !

!SpMillerLayout class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpMillerLayout class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpMillerLayout class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpMillerLayout class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpMillerLayout class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpMillerLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMillerLayout class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpMillerLayout class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpMillerLayout class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpMillerLayout class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpMillerLayout class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpMillerLayout class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpMillerLayout class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpMillerLayout class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpMillerLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpMillerLayout class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpMillerLayout class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpMillerPaginatorPresenter commentStamp: ''!
A presenter that chains a miller list (`SpMillerColumnPresenter`) along with a paginator (`SpPaginatorPresenter`). 
This is the most common usage of paginator, and there are several places where we want to use a miller list with pagination and this common presenter will be provifing basic functionality pre-made for consumption.!
!SpMillerPaginatorPresenter methodsFor: 'api' stamp: ''!
paginatorPresenter

	^ paginator! !

!SpMillerPaginatorPresenter methodsFor: 'private' stamp: ''!
newPaginator
		
	^ self instantiate: SpPaginatorPresenter! !

!SpMillerPaginatorPresenter methodsFor: 'api' stamp: ''!
pages

	^ millerList pages! !

!SpMillerPaginatorPresenter methodsFor: 'api' stamp: ''!
removeAllFrom: aPresenter

	millerList removeAllFrom: aPresenter.
	self updatePaginator: ((millerList pages size - millerList visiblePages + 1) max: 1)! !

!SpMillerPaginatorPresenter methodsFor: 'private' stamp: ''!
updatePaginator: pageSelected

	millerList pages size > 1 
		ifTrue: [ 
			"add a paginator, chained to the miller list"
			paginator ifNil: [ 
				paginator := self newPaginator.
				paginatorContainerLayout add: paginator expand: false.
				paginator chainTo: millerList ].
			paginator pages: millerList pages.
			paginator selectPage: pageSelected ]
		ifFalse: [
			"we do not want the paginator, let's remove it"
			paginatorContainerLayout removeAll. 
			paginator := nil ]! !

!SpMillerPaginatorPresenter methodsFor: 'api' stamp: ''!
millerListPresenter

	^ millerList! !

!SpMillerPaginatorPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpBoxLayout newTopToBottom
		add: (millerList := self instantiate: SpMillerColumnPresenter);
		add: ((paginatorContainerLayout := SpBoxLayout newLeftToRight)
				hAlignCenter; 
				yourself)
			expand: false;
		yourself).
		
	millerList withoutHorizontalScrollBar.
	millerList whenColumnsChangedDo: [ :page | self updatePaginator: page ].
	self updatePaginator: 1! !

!SpMillerPresenter commentStamp: ''!
I'm a kind of API that a `SpMillerPresenter` should implement: basically one single method `whenActivedDo:`.!
!SpMillerPresenter methodsFor: 'initialization' stamp: ''!
whenActivatedDo: aBlock

	self subclassResponsibility! !

!SpMockApplication class methodsFor: 'accessing' stamp: ''!
defaultBackendName

	^ #Mock! !

!SpMockBackend methodsFor: 'private' stamp: ''!
adapterBindingsClass

	^ SpStubAdapterBindings! !

!SpMockBackend class methodsFor: 'accessing' stamp: ''!
backendName

	^ #Mock! !

!SpMockDynamicPresenter methodsFor: 'action' stamp: ''!
selectFirstElement
	list selectIndex: 1! !

!SpMockDynamicPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	list := self newList.
	label := self newLabel.
	
	list items: #(1 2 3)! !

!SpMockDynamicPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters
	list
		whenSelectionChangedDo: [ :sel | 
			label := self newLabel.
			label label: sel selectedItem asString.
			self needRebuild: false.
			self buildWithSpec ]! !

!SpMockDynamicPresenter methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!SpMockDynamicPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #list;
		add: #label;
		yourself! !

!SpMockDynamicPresenter class methodsFor: 'instance creation' stamp: ''!
openWithRebuildBeforeOpening
	<script>
	^ self new
		selectFirstElement;
		openWithSpec! !

!SpMockDynamicPresenter class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	^ self new openWithSpec! !

!SpMockFocusOrderPresenter methodsFor: 'accessing' stamp: ''!
firstPresenter

	^ firstPresenter! !

!SpMockFocusOrderPresenter methodsFor: 'accessing' stamp: ''!
thirdPresenter

	^ thirdPresenter! !

!SpMockFocusOrderPresenter methodsFor: 'accessing' stamp: ''!
secondPresenter

	^ secondPresenter! !

!SpMockFocusOrderPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	firstPresenter := self newButton label: 'First'.
	secondPresenter := self newButton label: 'Second'.
	thirdPresenter := self newButton label: 'Third'! !

!SpMockFocusOrderPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: #firstPresenter;
		add: #secondPresenter;
		add: #thirdPresenter;
		yourself! !

!SpMockMenu methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpMockMenu methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpMockMenu methodsFor: 'initialization' stamp: ''!
initialize
	
	self class initializeSlots: self.
	super initialize.
	shown := false! !

!SpMockMenu methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpMockMenu methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
popUpEvent: evt in: aWorld

	self shown: true! !

!SpMockMenu methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
setInvokingView: aRubTextEditor! !

!SpMockMenu methodsFor: 'accessing' stamp: ''!
shown
	^ shown! !

!SpMockMenu methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
invokeModal

	self shown: true! !

!SpMockMenu methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
popUpInWorld: aWorld

	self shown: true! !

!SpMockMenu methodsFor: 'accessing' stamp: ''!
shown: anObject
	shown := anObject! !

!SpMockMenu methodsFor: 'accessing' stamp: ''!
realMenu
	^ realMenu! !

!SpMockMenu methodsFor: 'accessing' stamp: ''!
realMenu: anObject
	realMenu := anObject! !

!SpMockMenu methodsFor: 'owner' stamp: ''!
privateOwner: aRubEditingArea 
	
	"Nothing"! !

!SpMockMenu methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
isInWorld
	
	^ false! !

!SpMockMenu methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpMockMenu methodsFor: 'accessing' stamp: ''!
whenShownDo: aBlock
	self property: #shown whenChangedDo: aBlock! !

!SpMockMenu class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpMockMenu class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpMockMenu class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpMockMenu class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpMockMenu class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpMockMenu class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpMockMenu class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpMockMenu class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpMockMenu class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMockMenu class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpMockMenu class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpMockMenu class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpMockMenu class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpMockMenu class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpMockMenu class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpMockMenu class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpMockMenu class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpMockMenu class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMockMenu class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpMockMenu class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpMockMenu class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpMockMenu class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpMockMenu class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpMockMenu class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpMockMenu class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpMockMenu class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpMockMenu class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpMockMenu class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpMockMenu class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpMockMenuPresenter methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	shown := false.! !

!SpMockMenuPresenter methodsFor: 'accessing' stamp: ''!
shown
	^ shown! !

!SpMockMenuPresenter methodsFor: 'accessing' stamp: ''!
shown: anObject
	^ shown := anObject! !

!SpMockMenuPresenter methodsFor: 'building' stamp: ''!
buildWithSpec

	^ SpMockMenu new
		realMenu: super buildWithSpec;
		whenShownDo: [ shown := true ];
		yourself! !

!SpMockMillerPresenter methodsFor: 'initialization' stamp: ''!
whenActivatedDo: aBlock

	activationBlock := aBlock! !

!SpMockMillerPresenter methodsFor: 'simulating' stamp: ''!
activate
	
	activationBlock value: (SpMillerActivation on: 1)! !

!SpMockPesenterWithoutGetter methodsFor: 'initialization' stamp: ''!
initializePresenters
	buttonPresenter := self newButton! !

!SpMockPesenterWithoutGetter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newLeftToRight
		add: #buttonPresenter;
		yourself! !

!SpModalWindowPresenter commentStamp: ''!
I'm a window presenter used to describe a **modal** DialogWindow. 
On the contrary of the `SpDialogWindowPresenter`, I will block the user to focus any other window.

Usually instances of `SpModalWindowPresenter` are created using the method `SpAbstractPresenter>>#openModalWithSpec`.

If you want to make the user to show a dialog without blocking the execution of other windows, use `SpAbstractPresenter>>#openDialogWithSpec` instead.

## Usage
Typically, you do not instantiate directly a modal dialog, but you open a presenter as one. Since the program execution will be stopped until dialog is resolved (accepted or cancelled), you can ask for the status after calling it.

```
dialog := aPresenter openModalWithSpec.
dialog isOk 
	ifTrue: [ "dialog accepted action" ]
	ifFalse: [ "dialof cancelled action " ]
```

The method `SpModalWindowPresenter>>#closeOnBackdropClick:` controls whether the user is able to close or not the modal dialog.

And to control how the dialog should behave, you define the method `initializeDialogWindow:` in your presenters.

```
SomePresenter >> initializeDialogWindow: aDialogPresenter 
	super initializeDialogWindow: aDialogPresenter.
	aDialogPresenter
		initialExtent: 600@400;
		title: 'A title';
		closeOnBackdropClick: true
```!
!SpModalWindowPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	closeOnBackdropClick := false! !

!SpModalWindowPresenter methodsFor: 'api' stamp: ''!
closeOnBackdropClick: aBoolean
	"Set when the user will be able to click on the backdrop to close the modal 
	 launching the cancel action."

	closeOnBackdropClick := aBoolean! !

!SpModalWindowPresenter methodsFor: 'api' stamp: ''!
closeOnBackdropClick
	"Answer if the user will be able to click on the backdrop to close the modal 
	 launching the cancel action."
	
	^ closeOnBackdropClick! !

!SpModalWindowPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ModalWindowAdapter! !

!SpModelPort commentStamp: ''!
!! Model Input Port (==SpModelPort==)
A ""model input port"" define an incomming transmission to modify the model of a presenter.

The presenter exposing a model input port need to define also the method ==#setModel:==.

Presenters exposing this port: *class:SpPresenterSelectorPresenter* and *class:SpPresenterWithModel*!
!SpModelPort methodsFor: 'handling transmission' stamp: ''!
applyIncomingTransmission: anObject from: outPort to: aPresenter
	"sets model to destination presenter"

	aPresenter setModel: anObject! !

!SpModelPort class methodsFor: 'accessing' stamp: ''!
portName
	
	^ #model! !

!SpMorphPort commentStamp: ''!
I define an incomming transmission to modify the morph value of a presenter.
I'm used on MorphPresenter.!
!SpMorphPort methodsFor: 'handling transmission' stamp: ''!
applyIncomingTransmission: anObject from: outPort to: aPresenter

	aPresenter morph: anObject! !

!SpMorphPort class methodsFor: 'accessing' stamp: ''!
portName

	^ #morph! !

!SpMorphPresenter commentStamp: ''!
A presenter to display a morph.
Sometimes, an user may want to plug a custom morph into Spec2. !
!SpMorphPresenter methodsFor: 'transmission' stamp: ''!
defaultInputPort

	^ self inputMorphPort! !

!SpMorphPresenter methodsFor: 'api' stamp: ''!
morph
	"Answer the morph that will be plugged into the presenter."

	^ morph! !

!SpMorphPresenter methodsFor: 'api' stamp: ''!
morph: aMorph
	"Set the morph that will be plugged into the presenter."

	morph := aMorph! !

!SpMorphPresenter methodsFor: 'transmission' stamp: ''!
inputMorphPort 

	^ self class environment 
		at: #SpMorphPort
		ifPresent: [ :aClass | aClass newPresenter: self ]
		ifAbsent: [ nil ]! !

!SpMorphPresenter methodsFor: 'api - events' stamp: ''!
whenMorphChangedDo: aBlock 
	"Inform when morph has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #morph whenChangedDo: aBlock! !

!SpMorphPresenter class methodsFor: 'documentation' stamp: ''!
documentTransmissionsProtocol

	^ #'transmission'! !

!SpMorphPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newMorph! !

!SpMorphPresenter class methodsFor: '*Spec2-Morphic-Examples' stamp: ''!
example

	^ self new 
		morph: (Morph new
			color: Color random;
			yourself);
		openWithSpec! !

!SpMorphPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #MorphAdapter! !

!SpMorphPresenter class methodsFor: 'documentation' stamp: ''!
documentExamplesProtocol
	
	^ #'*Spec2-Morphic-Examples'! !

!SpMorphPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpMorphPresenter! !

!SpMorphPresenterTest methodsFor: 'tests' stamp: ''!
testChangingMorphUpdatesContents
	| m1 m2 |

	m1 := Morph new color: Color red.
	m2 := Morph new color: Color green.
	self assert: presenter morph isNil.
	self openInstance.

	presenter morph: m1.
	backendForTest waitUntilUIRedrawed.
	self assert: presenter adapter widget equals: m1.
	presenter morph: m2.
	backendForTest waitUntilUIRedrawed.
	self assert: presenter adapter widget equals: m2! !

!SpMorphPresenterTest methodsFor: 'tests' stamp: ''!
testChangingHelpAffectTheWidget
	"It does not has sense here"

	self skip! !

!SpMorphStyle commentStamp: ''!
!! A Style in a Morph (SpMorphStyle)

This is for internal use of the framework, but it is interesting to notice how it works since it may give some insigts on how to declare things.
At creation of a component, an instance of ==SpMorphStyle== is created and by taking the stylesheet it collects styles from most external to more internal. So, for example, this stylesheet: 

[[[
.application [
	Geometry { #height: 100 }, 
	.button [
		Geometry { #width: 100 }
	]
]
]]]

Will collect, for a button (*class:SpButtonPresenter*, who has a style name ==button==), the styles

[[[
application
application.button
]]] 

This collection will be used to get all properties defined and perform a merge between them (*method:SpStyleProperty#mergeWith:*), to get all one single property for each type of them. Which means at the end it will apply a property ==Geometry { #width: 100, #height: 25 }==.
!
!SpMorphStyle methodsFor: 'accessing' stamp: ''!
styles
	^ styles! !

!SpMorphStyle methodsFor: 'private' stamp: ''!
propertiesLike: aClass

	^ (self styles 
		inject: OrderedCollection new
		into: [ :all :eachStyle | 
			eachStyle properties 
				select: [ :eachProperty | eachProperty class = aClass ]
				thenDo: [ :eachProperty | all add: eachProperty ].
			all ])
		flattened! !

!SpMorphStyle methodsFor: 'accessing - geometry' stamp: ''!
width

	^ self lookupProperty: SpGeometryStyle valueOf: #width! !

!SpMorphStyle methodsFor: 'accessing - geometry' stamp: ''!
minWidth

	^ self lookupProperty: SpGeometryStyle valueOf: #minWidth! !

!SpMorphStyle methodsFor: 'accessing - container' stamp: ''!
borderWidth

	^ self lookupProperty: SpContainerStyle valueOf: #borderWidth! !

!SpMorphStyle methodsFor: 'private' stamp: ''!
calculateMergedProperties
	| properties groups |
	
	properties := OrderedCollection new.
	groups := (self styles 
		flatCollect: [ :each | each properties ])
		groupedBy: [ :each | each class ].
		
	groups valuesDo: [ :eachCollection |
		properties add: (eachCollection allButFirst 
			inject: eachCollection first
			into: [ :all :each | all, each ]) ].
	
	^ properties! !

!SpMorphStyle methodsFor: 'accessing - font' stamp: ''!
font

	^ self lookupProperty: SpFontStyle valueOf: #definedFont! !

!SpMorphStyle methodsFor: 'accessing' stamp: ''!
lookupProperty: aPropertyClass valueOf: aSymbol
	"I perform the lookup of a property, for which I need a class and a property name.
	 I will traverse all collected properties from last to first, to ensure most detailed 
	 property is answered"

	(self propertiesLike: aPropertyClass)
		reverseDo: [ :each | 
			(each perform: aSymbol) 
				ifNotNil: [ :value | ^ value ] ].
	^ nil! !

!SpMorphStyle methodsFor: 'accessing - geometry' stamp: ''!
extent

	^ self lookupProperty: SpGeometryStyle valueOf: #extent! !

!SpMorphStyle methodsFor: 'accessing' stamp: ''!
mergedProperties

	^ mergedProperties ifNil: [ mergedProperties := self calculateMergedProperties ]! !

!SpMorphStyle methodsFor: 'accessing - geometry' stamp: ''!
height

	^ self lookupProperty: SpGeometryStyle valueOf: #height! !

!SpMorphStyle methodsFor: 'accessing' stamp: ''!
mergedLookupProperty: aPropertyClass valueOf: aSymbol
	"I perform the lookup of a property, for which I need a class and a property name.
	 I will traverse all collected properties from last to first, to ensure most detailed 
	 property is answered"

	^ (self mergedPropertiesLike: aPropertyClass) first
		! !

!SpMorphStyle methodsFor: 'accessing - geometry' stamp: ''!
maxWidth

	^ self lookupProperty: SpGeometryStyle valueOf: #maxWidth! !

!SpMorphStyle methodsFor: 'accessing - geometry' stamp: ''!
minHeight

	^ self lookupProperty: SpGeometryStyle valueOf: #minHeight! !

!SpMorphStyle methodsFor: 'accessing' stamp: ''!
styles: anObject
	styles := anObject! !

!SpMorphStyle methodsFor: 'accessing' stamp: ''!
applyTo: aMorph 

	aMorph setProperty: #style toValue: self.
	self mergedProperties 
		do: [ :each | each applyTo: aMorph ]! !

!SpMorphStyle methodsFor: 'private' stamp: ''!
mergedPropertiesLike: aClass

	^ self mergedProperties select: [ :eachProperty | eachProperty class = aClass ]
		! !

!SpMorphStyle methodsFor: 'accessing - container' stamp: ''!
padding 

	^ self lookupProperty: SpContainerStyle valueOf: #padding! !

!SpMorphStyle methodsFor: 'accessing - geometry' stamp: ''!
maxHeight

	^ self lookupProperty: SpGeometryStyle valueOf: #maxHeight! !

!SpMorphStyle class methodsFor: 'instance creation' stamp: ''!
newStyles: anArray

	^ self new 
		styles: anArray;
		yourself! !

!SpMorphStyle class methodsFor: 'instance creation' stamp: ''!
fromStylesheet: aStyle adapter: anAdapter
	"I collect all styles that apply to an adapter.
	 I traverse all styles in a very precise order: from more generic to more specific, this way 
	 the order of the collected elements will be in reverse order of execution."
	| allStyleClasses styles |
		
	allStyleClasses := aStyle flattenClasses.
	styles := OrderedCollection new.
	(({ 'application'. anAdapter styleName }, 
		anAdapter presenterStyles, 
		(anAdapter presenterStyles collect: [ :each | anAdapter styleName, '.', each ])) 
		do: [ :each |
			"a hack to not do a double dispatch on string :(" 
			each isString 
				ifTrue: [ 
					allStyleClasses 
						select: [ :eachStyle | eachStyle fullName = each ]
						thenDo: [ :aStyleClass | styles add: aStyleClass ] ] 
				ifFalse: [ 
					styles add: each ] ]).
	"WARNING. Order is important"
	^ self newStyles: styles asArray! !

!SpMorphStyleTest methodsFor: 'private' stamp: ''!
newLookup: aString
	| rootClass |

	rootClass := SpStyleSTONReader fromString: aString.
	^ SpMorphStyle newStyles: rootClass flattenClasses ! !

!SpMorphStyleTest methodsFor: 'tests' stamp: ''!
testDeepMultipleLookup
	"This should answer the deepest width (last appearence)"
	| styleResolver |
	
	styleResolver := self newLookup: '.application [ 
		Geometry { #width: 11 },
		.other [
			Geometry { #width: 22 },
			.deep1 [
				Geometry { #width: 33 }
			],
			.deep2 [
				Geometry { #width: 42 }
			]
		]
	]'.

	self assert: styleResolver width equals: 42! !

!SpMorphStyleTest methodsFor: 'tests' stamp: ''!
testSimpleLookup
	"this should answer the width defined in the only level"
	| styleResolver |
	
	styleResolver := self newLookup: '.application [ 
		Geometry { #width: 42 } 
	]'.

	self assert: styleResolver width equals: 42! !

!SpMorphStyleTest methodsFor: 'tests' stamp: ''!
testNestedStyles
	| lookup labelAdapter styleSheet |

	styleSheet := (SpStyleSTONReader fromString: '
.application [
	.label [
		Geometry { #width: 21 },
		.nested [ 
			Geometry { #width: 42 },
			.deepNested [ 
				Geometry { #width: 84 } ] ] ] ]').

	"No nesting"
	labelAdapter := SpLabelPresenter new 
		buildWithSpec;
		adapter.
	lookup := SpMorphStyle fromStylesheet: styleSheet adapter: labelAdapter.
	self assert: lookup width equals: 21.

	"nesting"			
	labelAdapter := SpLabelPresenter new 
		addStyle: 'nested';
		buildWithSpec;
		adapter.
	lookup := SpMorphStyle fromStylesheet: styleSheet adapter: labelAdapter.
	self assert: lookup width equals: 42.
	
	"deep-nesting"			
	labelAdapter := SpLabelPresenter new 
		addStyle: 'nested.deepNested';
		buildWithSpec;
		adapter.
	lookup := SpMorphStyle fromStylesheet: styleSheet adapter: labelAdapter.
	self assert: lookup width equals: 84! !

!SpMorphStyleTest methodsFor: 'tests' stamp: ''!
testTwoClassWithSameName
	| morphStyle style1 style2 property label |

	style1 := SpStyleSTONReader fromString: '
.application [
	.label [ 
		Font { #name: "Source Sans Pro", #size: 10  } ] ]'.
	
	style2 := SpStyleSTONReader fromString: '
.application [
	.label [ 
		Font { #bold: true } ] ]'.

	label := SpLabelPresenter new buildWithSpec; yourself.
	
	morphStyle := SpMorphStyle fromStylesheet: style1 adapter: label adapter.
	property := morphStyle mergedProperties anyOne.
	
	self assert: morphStyle mergedProperties size equals: 1.
	self assert: property class equals: SpFontStyle.
	self assert: property name equals: 'Source Sans Pro'.
	self deny: property isBold.

	morphStyle := SpMorphStyle fromStylesheet: style1, style2 adapter: label adapter.
	property := morphStyle mergedProperties anyOne.
	
	self assert: morphStyle mergedProperties size equals: 1.
	self assert: property class equals: SpFontStyle.
	self assert: property name equals: 'Source Sans Pro'.
	self assert: property isBold! !

!SpMorphStyleTest methodsFor: 'tests' stamp: ''!
testFromStylesheetAdapter
	| lookup labelAdapter |

	labelAdapter := SpLabelPresenter new 
		buildWithSpec;
		adapter.

	lookup := SpMorphStyle
		fromStylesheet: (SpStyleSTONReader fromString: '
.application [
	.label [
		Geometry { #width: 42 }
		]
	]')
		adapter: labelAdapter.
		
	self assert: lookup width equals: 42.
	
	lookup := SpMorphStyle
		fromStylesheet: (SpStyleSTONReader fromString: '
.application [
	Geometry { #width: 42 },
	.label [ ]
	]')
		adapter: labelAdapter.
	self assert: lookup width equals: 42.
	
	"it refuses deeper class (because is not part of the tree)"
	lookup := SpMorphStyle
		fromStylesheet: (SpStyleSTONReader fromString: '
.application [
	.label [
		Geometry { #width: 42 }
	],
	.other [ 
		.label [ 
			Geometry { #width: 22 } 
		] 
	]
]')
		adapter: labelAdapter.
! !

!SpMorphStyleTest methodsFor: 'tests' stamp: ''!
testApplyTo
	| styleResolver morph |
	
	styleResolver := self newLookup: '.application [ 
		Geometry { #width: 11 },
		.other [
			Geometry { #width: 22 },
			.deep1 [
				Geometry { #width: 33 }
			],
			.deep2 [
				Geometry { #width: 42 }
			]
		]
	]'.

	morph := Morph new.
	styleResolver applyTo: morph.
	self assert: morph width equals: 42! !

!SpMorphStyleTest methodsFor: 'tests' stamp: ''!
testDeepLookup
	"This should answer the deepest width"
	| styleResolver |
	
	styleResolver := self newLookup: '.application [ 
		Geometry { #width: 11 },
		.other [
			Geometry { #width: 22 },
			.deep [
				Geometry { #width: 42 }
			]
		]
	]'.

	self assert: styleResolver width equals: 42! !

!SpMorphWrapper commentStamp: ''!
A MorphWrapper is used to wrap a morph with a layout in the goal to be easily added to another morph!
!SpMorphWrapper methodsFor: 'adding' stamp: ''!
addIn: aContainer
		
	aContainer
		addMorph: morph
		fullFrame: layout! !

!SpMorphWrapper methodsFor: 'accessing' stamp: ''!
fullFrame: anObject
	
	layout := anObject! !

!SpMorphWrapper methodsFor: 'accessing' stamp: ''!
frame: rectangle
	
	layout := rectangle asSpLayoutFrame! !

!SpMorphWrapper methodsFor: 'accessing' stamp: ''!
morph: anObject
	
	morph := anObject! !

!SpMorphWrapper class methodsFor: 'instance creation' stamp: ''!
morph: morph layout: aLayout 

	^ self new
		layout: aLayout;
		morph: morph;
		yourself! !

!SpMorphicActionBarAdapter commentStamp: ''!
I'm an adapter to provide an action bar (which is represented using an SpToolbarMorph)!
!SpMorphicActionBarAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| panelMorph |
	
	"Using a toolbar morph because is more or less the same, it just change 
	 the kind of elements it can have inside (which are just buttons)"
	panelMorph := SpToolbarMorph new.
	self addModelTo: panelMorph.
	
	^ panelMorph! !

!SpMorphicActionBarAdapter methodsFor: 'factory' stamp: ''!
addModelTo: aMorph

	self flag: #TODO. "Maybe validate they are just buttons inside?"
	(self model items at: #start ifAbsent: [ #() ]) do: [ :each |
		aMorph addItemLeft: (self buildActionButton: each) ].
	(self model items at: #end ifAbsent: [ #() ]) reverseDo: [ :each |
		aMorph addItemRight: (self buildActionButton: each) ]! !

!SpMorphicActionBarAdapter methodsFor: 'factory' stamp: ''!
buildActionButton: aButtonPresenter
	| morph |
	
	self flag: #TODO. "This should not be here once we implement bubble up styles with the 
	new style mechanism (because then we will have a style '.actionBar.button' instead 
	'actionButton'"
	morph := aButtonPresenter buildWithSpec.
	aButtonPresenter adapter 
		styleName: 'actionButton';
		applyStyle: morph.
		
	^ morph! !

!SpMorphicActionBarAdapter methodsFor: 'factory' stamp: ''!
newPanelMorph

	^ Morph new
		  changeTableLayout;
		  hResizing: #spaceFill;
		  vResizing: #rigid;
		  height: self class defaultHeight;
		  cellInset: self class defaultItemSeparation;
		  color: Color random;
		  yourself! !

!SpMorphicActionBarAdapter class methodsFor: 'accessing' stamp: ''!
defaultItemSeparation
	
	^ 3@0! !

!SpMorphicActionBarAdapter class methodsFor: 'accessing' stamp: ''!
defaultHeight

	^ 30! !

!SpMorphicAdapterBindings commentStamp: ''!
I am used to link the spec-adapter names to the morphic adapters!
!SpMorphicAdapterBindings methodsFor: 'initialize' stamp: ''!
abstractAdapterClass
	^ SpAbstractMorphicAdapter! !

!SpMorphicAdapterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance! !

!SpMorphicAdapterTest methodsFor: 'accessing' stamp: ''!
adapter

	^ presenter adapter! !

!SpMorphicAdapterTest methodsFor: 'running' stamp: ''!
tearDown
	window ifNotNil: [ window delete ].
	super tearDown! !

!SpMorphicAdapterTest methodsFor: 'private' stamp: ''!
performTest
	
	specInitializationStrategy beforeTest: self.
	super performTest.! !

!SpMorphicAdapterTest methodsFor: 'accessing' stamp: ''!
widget

	"Force opening the spec instance here.
	The action should have been correctly configured before
	depending on the spec initialization strategy"
	self openInstance.
	MorphicRenderLoop new doOneCycle.
	^ self adapter widget! !

!SpMorphicAdapterTest methodsFor: 'accessing' stamp: ''!
specInitializationStrategy: aStrategy
	
	specInitializationStrategy := aStrategy! !

!SpMorphicAdapterTest methodsFor: 'accessing' stamp: ''!
presenter
	^ presenter! !

!SpMorphicAdapterTest methodsFor: 'utilities' stamp: ''!
openInstance

	window ifNil: [ window := presenter openWithSpec ].
	MorphicRenderLoop new doOneCycle.! !

!SpMorphicAdapterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	presenter := self classToTest new.
	self initializeTestedInstance! !

!SpMorphicAdapterTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ self == SpMorphicAdapterTest! !

!SpMorphicAdapterTest class methodsFor: 'testing' stamp: ''!
testParameters 

	^ ParametrizedTestMatrix new
		forSelector: #specInitializationStrategy
		addOptions: { [ SpInitializationStrategy beforeTest ]. [ SpInitializationStrategy afterTest ] }! !

!SpMorphicAdapterTestCase class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!SpMorphicAllItemsStrategy methodsFor: 'accessing' stamp: ''!
isMatching: anItem

	^ dataSource model 
		performSearch: anItem data 
		matching: pattern! !

!SpMorphicAthensAdapter commentStamp: ''!
I'm an adapter to bridge to Athens using an instance of class `SpAthensMorph` as widget!
!SpMorphicAthensAdapter methodsFor: 'drawing' stamp: ''!
redraw

	widget redraw! !

!SpMorphicAthensAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	| instance |
	instance := SpAthensMorph new.
	self presenter whenDrawBlockChangedDo: [ :newBlock | 
		instance drawBlock: newBlock ].
	self presenter whenExtentChangedDo: [ :newExtent | 
		instance extent: newExtent ].
	instance extent: self presenter surfaceExtent.
	instance drawBlock: self presenter drawBlock.
	instance setBalloonText: self model help.
	self presenter whenHelpChangedDo: [ 
		instance setBalloonText: self model help ].
	^ instance! !

!SpMorphicAthensAdapter methodsFor: 'accessing' stamp: ''!
surface

	^ widget surface! !

!SpMorphicBackend commentStamp: ''!
I'm a Spec2 backend for the morphic UI framework. See class comment of class `SpApplicationBackend` for more details!
!SpMorphicBackend methodsFor: 'ui dialogs' stamp: ''!
selectDirectoryTitle: aString

	^ UIManager default chooseDirectory: aString path: ''! !

!SpMorphicBackend methodsFor: 'private - notifying' stamp: ''!
notifyInfo: aSpecNotification

	GrowlMorph 
		openWithLabel: 'Information' translated 
		contents: aSpecNotification message! !

!SpMorphicBackend methodsFor: 'private' stamp: ''!
adapterBindingsClass

	^ SpMorphicAdapterBindings! !

!SpMorphicBackend methodsFor: 'private - notifying' stamp: ''!
notifyError: aSpecNotification

	GrowlMorph
		openWithLabel: 'Error'
		contents: aSpecNotification message
		backgroundColor: GrowlMorph theme dangerBackgroundColor
		labelColor: GrowlMorph theme textColor! !

!SpMorphicBackend methodsFor: 'deferred message' stamp: ''!
forceDefer: aBlock

	UIManager default defer: aBlock! !

!SpMorphicBackend methodsFor: 'display' stamp: ''!
showWaitCursorWhile: aBlock inApplication: anApplication

	Cursor wait showWhile: aBlock! !

!SpMorphicBackend methodsFor: 'deferred message' stamp: ''!
defer: aBlock

	UIManager default defer: aBlock! !

!SpMorphicBackend methodsFor: 'ui dialogs' stamp: ''!
selectFileTitle: aString

	^ UIManager default
		  chooseExistingFileReference: aString
		  extensions: nil
		  path: ''! !

!SpMorphicBackend class methodsFor: 'accessing' stamp: ''!
backendName

	^ #Morphic! !

!SpMorphicBackendForTest methodsFor: 'asserting' stamp: ''!
assertListHeaderOf: anAdapter equals: aCollection 

	| tableContainer tableRowMorph cells |
	
	self waitUntilUIRedrawed.
	
	tableContainer := anAdapter widget submorphs first.
	tableRowMorph := tableContainer submorphs first.
	cells := tableRowMorph submorphs.
	
	self assert: (cells collect: [ :c | c submorphs first contents]) asArray = aCollection asArray! !

!SpMorphicBackendForTest methodsFor: 'running' stamp: ''!
defaultWaitDuration
	^ 500 milliSecond! !

!SpMorphicBackendForTest methodsFor: 'utilities' stamp: ''!
waitUntilUIRedrawed
	"I wait until the UI has been redrawn. 
	I take care of selecting how to do it. 
	If I am in the CI I should defer a semaphore signal. 
	If I am running in the UI process I can directly execute a doOneCycle on the World.
	If I am in the CI the tests and the UI run in different process. So I should not do a #doOneCycle.
	If I do it, I am in a race condition!!"

	self isRunningInUIProcess
		ifTrue: [
			MorphicRenderLoop new doOneCycle.
			^ self ].

	self currentWorld defer: [ uiWaitingSemaphore ifNotNil: #signal ].
	uiWaitingSemaphore wait: self defaultWaitDuration! !

!SpMorphicBackendForTest methodsFor: 'asserting' stamp: ''!
assertIcon: anAlphaImageMorph equals: aForm 
	
	self assert: (anAlphaImageMorph ifNotNil: #form) = aForm! !

!SpMorphicBackendForTest methodsFor: 'asserting' stamp: ''!
denyHasHeader: anAdapter 

	| tableContainer |
	self waitUntilUIRedrawed.

	tableContainer := anAdapter widget submorphs first.
	self assert: tableContainer submorphs size = 3! !

!SpMorphicBackendForTest methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self initializeSemaphore! !

!SpMorphicBackendForTest methodsFor: 'testing' stamp: ''!
isRunningInUIProcess
	^ UIManager default uiProcess == Processor activeProcess! !

!SpMorphicBackendForTest methodsFor: 'emulating' stamp: ''!
clickFirstRowAndColumn: anAdapter 

	self waitUntilUIRedrawed.
	
	anAdapter widget mouseDown: (MouseEvent new
		setHand: HandMorph new;
		setPosition: anAdapter widget submorphs first submorphs first bounds center;
		yourself).
! !

!SpMorphicBackendForTest methodsFor: 'opening' stamp: ''!
openInstanceOf: aTest 

	aTest window ifNil: [ 
		aTest presenter application: app.
		aTest window: aTest presenter openWithSpec ].

	self waitUntilUIRedrawed.
! !

!SpMorphicBackendForTest methodsFor: 'testing' stamp: ''!
assertImage: actual equals: expected 
	
	(expected isNil and: [ actual isNil or: [actual width = 1 and: [ actual height =1 ]] ]) ifTrue: [ ^ self ].
	
	self assert: actual width = expected width.
	self assert: actual height = expected height.	
	self assert: actual bits = expected bits.		! !

!SpMorphicBackendForTest methodsFor: 'initialization' stamp: ''!
initializeSemaphore
	uiWaitingSemaphore := Semaphore new! !

!SpMorphicBackendForTest methodsFor: 'simulating' stamp: ''!
doubleClickFirstRowAndColumn: anAdapter 

	self waitUntilUIRedrawed.

	anAdapter widget doubleClick: (MouseEvent new
		setPosition: anAdapter widget submorphs first submorphs first bounds center;
		yourself).
! !

!SpMorphicBackendForTest methodsFor: 'testing' stamp: ''!
canChangeFonts
	
	^ true! !

!SpMorphicBackendForTest methodsFor: 'asserting' stamp: ''!
assertHasHeader: anAdapter
	self waitUntilUIRedrawed.

	self assert: (anAdapter widget instVarNamed: #showColumnHeaders)! !

!SpMorphicBackendForTest methodsFor: 'running' stamp: ''!
runTest: aBlock
	app := SpApplication new.
	app useBackend: #Morphic.
	aBlock value! !

!SpMorphicBackendForTest methodsFor: 'asserting' stamp: ''!
assertList: anAdapter displayItems: aCollection 
	
	| tableContainer tableRowContents |
	
	self waitUntilUIRedrawed.
	
	tableContainer := anAdapter widget submorphs first.
	tableRowContents := tableContainer submorphs collect: [ :row | 
		| cell |
		cell := row submorphs first.
		(cell submorphs detect: [:e | e isKindOf: StringMorph]) contents ].
	
	self assert: tableRowContents first = aCollection first.
	self assert: tableRowContents second = aCollection second.
	self assert: tableRowContents third = aCollection third.! !

!SpMorphicBackendForTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpMorphicBackendForTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpMorphicBackendForTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpMorphicBackendForTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpMorphicBackendForTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpMorphicBackendForTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpMorphicBackendForTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpMorphicBackendForTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpMorphicBackendForTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicBackendForTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpMorphicBackendForTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpMorphicBackendForTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpMorphicBackendForTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpMorphicBackendForTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpMorphicBackendForTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpMorphicBackendForTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpMorphicBackendForTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpMorphicBackendForTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicBackendForTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpMorphicBackendForTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpMorphicBackendForTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpMorphicBackendForTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpMorphicBackendForTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpMorphicBackendForTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpMorphicBackendForTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpMorphicBackendForTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpMorphicBackendForTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpMorphicBackendForTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpMorphicBackendForTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpMorphicBaseBoxLayout commentStamp: ''!
A base for the box layout to apply to inner widgets.
It uses one of the `SpMorphicBoxLayoutCalculator` to correctly distribute space, taking into account when space should be distributed homogeneously or not.
!
!SpMorphicBaseBoxLayout methodsFor: 'private' stamp: ''!
leftToRightCalculator

	^ leftToRightCalculator ifNil: [ leftToRightCalculator := self newLeftToRightCalculator ]! !

!SpMorphicBaseBoxLayout methodsFor: 'accessing' stamp: ''!
specLayout: aLayout

	specLayout := aLayout! !

!SpMorphicBaseBoxLayout methodsFor: 'testing' stamp: ''!
isHomogeneous

	^ specLayout isHomogeneous! !

!SpMorphicBaseBoxLayout methodsFor: 'private' stamp: ''!
layoutLeftToRight: aMorph in: newBounds

	self leftToRightCalculator
		calculateFor: aMorph
		in: newBounds! !

!SpMorphicBaseBoxLayout methodsFor: 'accessing' stamp: ''!
borderWidth

	^ specLayout borderWidth! !

!SpMorphicBaseBoxLayout methodsFor: 'private' stamp: ''!
layoutTopToBottom: aMorph in: newBounds

	self topToBottomCalculator
		calculateFor: aMorph 
		in: newBounds! !

!SpMorphicBaseBoxLayout methodsFor: 'private' stamp: ''!
newTopToBottomCalculator

	^ SpMorphicBoxLayoutCalculatorTopToBottom newProperties: properties! !

!SpMorphicBaseBoxLayout methodsFor: 'accessing' stamp: ''!
direction

	^ specLayout direction! !

!SpMorphicBaseBoxLayout methodsFor: 'layout' stamp: ''!
layoutHomogeneous: aMorph in: aRect

	self direction 
		applyHomogeneousLayoutOn: self 
		to: aMorph 
		in: aRect! !

!SpMorphicBaseBoxLayout methodsFor: 'private' stamp: ''!
newLeftToRightCalculator

	^ SpMorphicBoxLayoutCalculatorLeftToRight newProperties: properties! !

!SpMorphicBaseBoxLayout methodsFor: 'private' stamp: ''!
topToBottomCalculator
	"there will be just one, we reuse the variable `calculator`"

	^ topToBottomCalculator ifNil: [ topToBottomCalculator := self newTopToBottomCalculator ]! !

!SpMorphicBaseBoxLayout methodsFor: 'layout' stamp: ''!
applyVerticalHomogeneousLayout: aMorph in: aRect
	| allMorphs elementHeight |

	aMorph submorphs size = 2 ifFalse: [ 
		self error: 'It does not looks like a spec box panel' ].
	
	allMorphs := aMorph submorphs flatCollect: [ :each | each submorphs ].
	elementHeight := (aRect height - (self borderWidth * 2) - (self spacing * (allMorphs size - 1)) / (allMorphs size max: 1)) floor.

	allMorphs do: [ :each | 
		each minHeight: elementHeight ]! !

!SpMorphicBaseBoxLayout methodsFor: 'accessing' stamp: ''!
spacing

	^ specLayout spacing! !

!SpMorphicBaseBoxLayout methodsFor: 'layout' stamp: ''!
applyHorizontalHomogeneousLayout: aMorph in: aRect
	| allMorphs elementWidth |

	aMorph submorphs size = 2 ifFalse: [ 
		self error: 'It does not looks like a spec box panel' ].
	
	allMorphs := aMorph submorphs flatCollect: [ :each | each submorphs ].
	elementWidth := (aRect width - (self borderWidth * 2) - (self spacing * (allMorphs size - 1)) / (allMorphs size max: 1)) floor.

	allMorphs do: [ :each | 
		each setProperty: #homogeneousWidth toValue: elementWidth ]! !

!SpMorphicBaseMenuAdapter commentStamp: ''!
I am the adapter used to build a MenuMorph from a MenuPresenter!
!SpMorphicBaseMenuAdapter methodsFor: 'spec protocol' stamp: ''!
openAtPointer

	self openAt: self currentHand position! !

!SpMorphicBaseMenuAdapter methodsFor: 'private' stamp: ''!
getTitleText

	^ self presenter title ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicBaseMenuAdapter methodsFor: 'protocol' stamp: ''!
menuGroups

	^ self model menuGroups reject: [ :e | e isEmpty ]! !

!SpMorphicBaseMenuAdapter methodsFor: 'protocol' stamp: ''!
icon

	^ self model icon! !

!SpMorphicBaseMenuAdapter methodsFor: 'initialization' stamp: ''!
addKeyBindingsTo: aMorph
	"This does not have keybindings"! !

!SpMorphicBaseMenuAdapter methodsFor: 'spec protocol' stamp: ''!
openAt: aPoint 

	self widgetDo: [ :w | w invokeAt: (aPoint + (2@7)) in: self currentWorld allowKeyboard: true ]! !

!SpMorphicBaseMenuAdapter methodsFor: 'protocol' stamp: ''!
title

	^ self getTitleText! !

!SpMorphicBaseMenuAdapter class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self name = #SpMorphicBaseMenuAdapter! !

!SpMorphicBaseTextAdapter commentStamp: ''!
I'm an abstract superclass for Morphic text adapters!
!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
accept: aString notifying: aNotifyier

	updating := true.
	[
		self presenter text: aString.
		"Raise an announcement"
		self presenter changed: #clearUserEdits]
	ensure: [ 
		updating := false ].

	^ true! !

!SpMorphicBaseTextAdapter methodsFor: '*NewTools-SpTextPresenterDecorators' stamp: ''!
addTextSegmentDecoration: aDecorationSegment
	
	self widgetDo: [ :w | 
		w addSegment: (RubUnderlinedSegmentMorph on: aDecorationSegment) ]! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
selectFrom: nodeStart to: nodeStop

	self widget selectFrom: nodeStart to: nodeStop! !

!SpMorphicBaseTextAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
placeHolderText
	^ widget ghostText asString! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
selectLine

	self widgetDo: [ :w |
		self selectionInterval: w textArea editor lineIntervalAtCursorPosition ]! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
setScrollValue: aValue

	self widgetDo: [ :w | 
		w scrollPane
			hScrollbarValue: aValue x;
			vScrollbarValue: aValue y;
			updateScrollbars ]! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
placeholder: aText

	^ self model placeholder: aText! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
hasEditingConflicts: aBoolean
 
	self widgetDo: [ :w | w hasEditingConflicts: aBoolean ]! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
codePaneMenu: aMenu shifted: shifted

	| menuPresenter |
	menuPresenter := self model contextMenu.
	menuPresenter ifNil: [ ^ nil ].
	^ SpBindings
		  value: self model application adapterBindings
		  during: [ menuPresenter value buildWithSpec ]! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
cursorPositionIndex: index 

	self subclassResponsibility! !

!SpMorphicBaseTextAdapter methodsFor: 'initialization' stamp: ''!
showContextMenu

	self widgetDo: [ :w | 
		(w textArea getMenu: false) ifNotNil: [ :menu | 
			menu
				invokeAt: w position + w textArea cursor center
				in: self currentWorld ] ]! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
hasUnacceptedEdits: aBoolean

	self model hasUnacceptedEdits: aBoolean! !

!SpMorphicBaseTextAdapter methodsFor: 'private' stamp: ''!
setEditingModeFor: textArea

	textArea beForPlainText! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
insert: aString at: positionIndex

	| text |
	text := self getText.
	text := String streamContents: [ :stream | 
		        stream << (text copyFrom: 1 to: positionIndex).
		        stream << aString.
		        text size > positionIndex ifTrue: [ 
			        stream << (text copyFrom: positionIndex + 1 to: text size) ] ].

	self presenter text: text! !

!SpMorphicBaseTextAdapter methodsFor: 'emulating' stamp: ''!
type: aString

	self widget setText: aString! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
selectAll

	self widgetDo: [ :w | w selectAll ]! !

!SpMorphicBaseTextAdapter methodsFor: 'accessing' stamp: ''!
interactionModel
	^ self! !

!SpMorphicBaseTextAdapter methodsFor: 'private' stamp: ''!
selectionInterval: anInterval on: aWidget
	| interval |
		
	interval := anInterval ifNil: [ 1 to: 0 ].

	aWidget textArea editor 
		selectFrom: interval first 
		to: interval last! !

!SpMorphicBaseTextAdapter methodsFor: '*NewTools-SpTextPresenterDecorators' stamp: ''!
removeAllTextSegmentDecorations
	
	self widgetDo: [ :w | 
		w segments do: [ :each | w textArea removeSegment: each ] ]! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
getText

	^ self model text! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
setSelection: interval

	selection := interval! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
clearUserEditFlag

	self model text: self getText.
	self changed: #clearUserEdits! !

!SpMorphicBaseTextAdapter methodsFor: 'accessing' stamp: ''!
announcer

	^ self model announcer! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
pendingText: aText

	self widgetDo: [ :w | 
		w 
			setText: aText;
			hasUnacceptedEdits: true ]! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
askBeforeDiscardingEdits

	^ self model askBeforeDiscardingEdits! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
readSelection

	^ self model readSelection! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
askBeforeDiscardingEdits: aBoolean

	self widget askBeforeDiscardingEdits: aBoolean! !

!SpMorphicBaseTextAdapter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	updating := false! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
scrollValueChanged: aValue

	self model scrollValue: aValue step! !

!SpMorphicBaseTextAdapter methodsFor: 'emulating' stamp: ''!
typeByChar: aString

	aString do: [ :each | 
		self 
			keyPressed: each 
			shift: each isUppercase
			meta: false 
			control: false 
			option: false ]! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
wantsVisualFeedback

	^ self model wantsVisualFeedback! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
font: aFont

	self widgetDo: [ :w | w font: aFont ]! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
setSelectionFromModel: aSelection

	self widget ifNotNil: [ :w | w setSelection: aSelection ]! !

!SpMorphicBaseTextAdapter methodsFor: 'private' stamp: ''!
selectionInterval: anInterval

	self widgetDo: [ :w | 
		self selectionInterval: anInterval on: w ]! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
notify: errorMessage at: position in: sourceCode

	self widgetDo: [ :w | 
		w notify: errorMessage at: position in: sourceCode ]! !

!SpMorphicBaseTextAdapter methodsFor: 'widget API' stamp: ''!
placeholder

	^ self model placeholder! !

!SpMorphicBaseTextAdapter methodsFor: 'accessing' stamp: ''!
selection

	^ selection! !

!SpMorphicBaseTextAdapter methodsFor: 'undo-redo' stamp: ''!
clearUndoManager

	self widget textArea editingState clearUndoManager: nil! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
pendingText

	^ self widgetDo: [ :w | w text ]! !

!SpMorphicBaseTextAdapter methodsFor: 'initialization' stamp: ''!
addKeyBindingsTo: aMorph

	super addKeyBindingsTo: aMorph.
	self 
		bindKeyCombination: Character escape asKeyCombination 
			toAction: [ :target :morph :event | self bubbleUpEvent: event ];
		bindKeyCombination: $t meta 
			toAction: [ self showContextMenu ]! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
canChangeText

	^ self widget textArea canChangeText! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
cursorPositionIndex

	self widgetDo: [ :w | ^ w textArea editor pointIndex ]! !

!SpMorphicBaseTextAdapter methodsFor: 'accessing' stamp: ''!
acceptAllowed

	^ self widget editingMode acceptAllowed! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
setHasUnacceptedEdits: aBoolean

	self widgetDo: [ :w | w basicHasUnacceptedEdits: aBoolean ]! !

!SpMorphicBaseTextAdapter methodsFor: 'private' stamp: ''!
bubbleUpEvent: anEvent

	anEvent wasHandled: false.
	self presenter window adapter widget handleEvent: anEvent! !

!SpMorphicBaseTextAdapter methodsFor: 'spec protocol' stamp: ''!
selectionInterval

	^ self widget selectionInterval! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpMorphicBaseTextAdapter class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpMorphicBaseTextAdapter class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpMorphicBaseTextAdapter class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpMorphicBaseTextAdapter class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpMorphicBaseTextAdapter class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpMorphicBaseTextAdapter class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicBaseTextAdapter class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpMorphicBaseTextAdapter class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpMorphicBaseTextAdapter class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self name = #SpMorphicBaseTextAdapter! !

!SpMorphicBaseTextAdapter class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpMorphicBaseTextAdapter class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicBaseTextAdapter class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpMorphicBaseTextAdapter class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpMorphicBaseTextAdapter class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpMorphicBaseTextAdapter class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpMorphicBaseTextAdapter class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpMorphicBaseTextAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpMorphicBaseTextAdapter class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpMorphicBaseTextAdapter class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpMorphicBlockedDialogWindowAdapter commentStamp: ''!
I am a morphic adapter used to show a blocked dialog for a BlockedDialogWindowPresenter in Morphic.!
!SpMorphicBlockedDialogWindowAdapter methodsFor: 'api' stamp: ''!
open
	"I am copying here what is defined in SystemWindow>>#openModal (but introducing the centered 
	 check inbetween because #openInWorld will use the RealEstateAgent to position the window 
	 and we want to (maybe) center it before showing it."
	self widget openInWorld.
	self presenter isCentered 
		ifTrue: [ self centered ].
	self presenter windowIsOpened.
	MorphicRenderLoop new doOneCycleWhile: [ self widget isInWorld ]! !

!SpMorphicBlockedDialogWindowAdapter methodsFor: 'api' stamp: ''!
mouseClick: evt onBackdrop: aMorph

	self closeOnBackdropClick ifFalse: [ ^ self ].

	self model triggerCancelAction.
	self model close. "Ensure the modal is closed"
	aMorph delete! !

!SpMorphicBlockedDialogWindowAdapter methodsFor: 'api' stamp: ''!
closeOnBackdropClick

	^ self model closeOnBackdropClick! !

!SpMorphicBoxAdapter commentStamp: ''!
I'm an adapter for Box Layouts.
A paned layout will split (horizontally or vertically) panels (in fixed yet proportional spaces).!
!SpMorphicBoxAdapter methodsFor: 'accessing' stamp: ''!
replace: aPresenter with: otherPresenter withConstraints: constraints

	| panel oldMorph newMorph |	
	oldMorph := aPresenter adapter widget.
	panel := (startPanel submorphs includes: oldMorph)
		ifTrue: [ startPanel ] 
		ifFalse: [ endPanel ].
	
	newMorph := self 
		buildMorph: otherPresenter 
		constraints: constraints.

	panel replaceSubmorph: oldMorph by: newMorph! !

!SpMorphicBoxAdapter methodsFor: 'private' stamp: ''!
addHorizontalPadding: aNumber toMorph: aMorph

	^ self newWrapMorph
		  hResizing: aMorph hResizing;
		  vResizing: aMorph vResizing;
		  width: aMorph width + (aNumber * 2);
		  height: aMorph height;
		  addMorph: (aMorph
			   hResizing: #spaceFill;
			   vResizing: #spaceFill;
			   yourself)
		  fullFrame: (LayoutFrame identity
			   leftOffset: aNumber;
			   rightOffset: aNumber negated);
		  yourself! !

!SpMorphicBoxAdapter methodsFor: 'factory' stamp: ''!
add: aPresenter
 
	self add: aPresenter constraints: SpBoxConstraints new! !

!SpMorphicBoxAdapter methodsFor: 'factory' stamp: ''!
layout: aLayout

	layout := aLayout.
	
	widget ifNil: [
		"build of widget was differed up to here (to know what is the direction)"
		widget := aLayout direction newWidgetOn: self.
		widget borderWidth: aLayout borderWidth.
		aLayout hasAlignment 
			ifTrue: [ widget := self applyAlignmentTo: widget ].
		"the spacing needs to be applied to the inner sub-panels"
		{ startPanel. endPanel } 
			do: [ :each | each cellInset: aLayout spacing ]
		"widget homogeneous: aLayout isHomogeneous" ].

	aLayout whenChildrenAddedDo: [ :ann |
		self
			add: ann child
			constraints: (aLayout constraintsFor: ann child) ].
	
	aLayout whenChildrenRemovedDo: [ :ann |
		self remove: ann child ].
	
	super layout: aLayout! !

!SpMorphicBoxAdapter methodsFor: 'updating' stamp: ''!
updateSpacing

	{ startPanel. endPanel } 
			do: [ :each | each cellInset: layout spacing ]! !

!SpMorphicBoxAdapter methodsFor: 'private' stamp: ''!
addConstraints: constraints toChild: childMorph
	"Adds constraits by child"
	| theMorph |
	
	theMorph := self addPadding: constraints padding toMorph: childMorph.
	constraints isExpand 
		ifTrue: [ 
			"if is not 'fill', in fact I need to pad it with another (since it 'expands', 
			 but does not 'fills')"
			constraints isFill ifFalse: [ 
				theMorph
					hResizing: #rigid;
					vResizing: #rigid.
				theMorph := self newPanel
					addMorphBack: theMorph;
					yourself ]. 
			"Set to fill"
			theMorph 
				hResizing: #spaceFill;
				vResizing: #spaceFill ]
		ifFalse: [
			"Set morph to stay rigid"
			layout direction setRigidityOfNonExpandedMorph: theMorph.
			constraints width ifNotNil: [ :w | theMorph width: w ].
			constraints height ifNotNil: [ :h | theMorph height: h ] ].
	
	^ theMorph ! !

!SpMorphicBoxAdapter methodsFor: 'private' stamp: ''!
addPadding: aNumber toMorph: aMorph
	
	aNumber = 0 ifTrue: [ ^ aMorph ].
	
	^ layout direction 
		addPadding: aNumber 
		toMorph: aMorph
		into: self! !

!SpMorphicBoxAdapter methodsFor: 'private' stamp: ''!
addVerticalPadding: aNumber toMorph: aMorph

	^ self newWrapMorph
		  hResizing: aMorph hResizing;
		  vResizing: aMorph vResizing;
		  width: aMorph width;
		  height: aMorph height + (aNumber * 2);
		  addMorph: (aMorph
			   hResizing: #spaceFill;
			   vResizing: #spaceFill;
			   yourself)
		  fullFrame: (LayoutFrame identity
			   topOffset: aNumber;
			   bottomOffset: aNumber negated);
		  yourself! !

!SpMorphicBoxAdapter methodsFor: 'accessing' stamp: ''!
children

	^ startPanel submorphs, endPanel submorphs! !

!SpMorphicBoxAdapter methodsFor: 'factory' stamp: ''!
newVertical

	^ (self newPanelWith: self newPanelLayout)
		listDirection: #topToBottom;
		addMorphBack: ((startPanel := self newPanel)
			listDirection: #topToBottom;
			yourself);
		addMorphBack: ((endPanel := self newPanel)
			listDirection: #topToBottom;
			vResizing: #shrinkWrap;
			height: 0;
			yourself);
		yourself! !

!SpMorphicBoxAdapter methodsFor: 'private' stamp: ''!
verifyBoxExtentOf: aPanel withChild: childMorph
	| width height |

	width := childMorph width + (widget borderWidth * 2).
	height := childMorph height + (widget borderWidth * 2).

	layout isVertical 
		ifTrue: [ height := height + aPanel height + aPanel cellInset ]
		ifFalse: [ width := width + aPanel width + aPanel cellInset ].
		 
	aPanel extent: (aPanel width max: width)@(aPanel height max: height)! !

!SpMorphicBoxAdapter methodsFor: 'private' stamp: ''!
applyAlignmentToChild: aWidget

	layout vAlign 
		ifNotNil: [ aWidget vResizing: #rigid ].
	layout hAlign 
		ifNotNil: [ aWidget hResizing: #rigid ]
! !

!SpMorphicBoxAdapter methodsFor: 'accessing' stamp: ''!
removeAll

	startPanel removeAllMorphs.
	endPanel removeAllMorphs.
	self verifyBoxExtent! !

!SpMorphicBoxAdapter methodsFor: 'accessing' stamp: ''!
replace: aPresenter with: otherPresenter

	| panel oldMorph newMorph |	
	oldMorph := aPresenter adapter widget.
	panel := (startPanel submorphs includes: oldMorph)
		ifTrue: [ startPanel ] 
		ifFalse: [ endPanel ].
	
	newMorph := self 
		buildMorph: otherPresenter 
		constraints: (layout constraintsFor: otherPresenter).

	panel replaceSubmorph: oldMorph by: newMorph! !

!SpMorphicBoxAdapter methodsFor: 'accessing' stamp: ''!
childrenWidgets
	
	^ self children! !

!SpMorphicBoxAdapter methodsFor: 'adding' stamp: ''!
add: aPresenter constraints: constraints

	super add: aPresenter constraints: constraints! !

!SpMorphicBoxAdapter methodsFor: 'private' stamp: ''!
basicAdd: aPresenter constraints: constraints to: aPanel
	| childMorph |

	childMorph := self buildMorph: aPresenter constraints: constraints.	

	self applyAlignmentToChild: childMorph.
	self verifyBoxExtentOf: aPanel withChild: childMorph.

	constraints isPlacedAtStart
		ifTrue: [ startPanel addMorphBack: childMorph ]
		ifFalse: [ endPanel addMorphBack: childMorph ].

	^ childMorph! !

!SpMorphicBoxAdapter methodsFor: 'accessing' stamp: ''!
remove: aPresenter

	| morph |
	morph := aPresenter adapter widget.	
	startPanel removeMorph: morph.
	endPanel removeMorph: morph.
	self verifyBoxExtent
	! !

!SpMorphicBoxAdapter methodsFor: 'private' stamp: ''!
applyAlignmentTo: aWidget

	layout isVertical
		ifTrue: [ 
			layout vAlign ifNotNil: [ :align | 
				startPanel vResizing: #shrinkWrap.
				aWidget listCentering: align asMorphicAlign ].
			layout hAlign ifNotNil: [ :align | 
				startPanel hResizing: #shrinkWrap.
				aWidget wrapCentering: align asMorphicAlign.
				aWidget cellPositioning: align asMorphicAlign ] ]
		ifFalse: [ 
			layout vAlign ifNotNil: [ :align | 
				startPanel vResizing: #shrinkWrap.
				aWidget wrapCentering: align asMorphicAlign.
				aWidget cellPositioning: align asMorphicAlign ].
			layout hAlign ifNotNil: [ :align | 
				startPanel hResizing: #shrinkWrap.
				aWidget listCentering: align asMorphicAlign ] ].

	^ aWidget! !

!SpMorphicBoxAdapter methodsFor: 'private' stamp: ''!
verifyBoxExtent

	(startPanel hasSubmorphs not and: [ endPanel hasSubmorphs not ])
		ifTrue: [ widget extent: 0@0 ]! !

!SpMorphicBoxAdapter methodsFor: 'factory' stamp: ''!
newHorizontal

	^ (self newPanelWith: self newPanelLayout)
		listDirection: #leftToRight;
		addMorphBack: ((startPanel := (self newPanelWith: SpMorphicBoxChildLayout new))
			listDirection: #leftToRight;
			yourself);
		addMorphBack: ((endPanel := (self newPanelWith: SpMorphicBoxChildLayout new))
			listDirection: #leftToRight;
			hResizing: #shrinkWrap;
			width: 0;
			yourself);
	  yourself! !

!SpMorphicBoxAdapter methodsFor: 'factory' stamp: ''!
removeSubWidgets

	startPanel removeAllMorphs.
	endPanel removeAllMorphs! !

!SpMorphicBoxAdapter methodsFor: 'factory' stamp: ''!
newPanelLayout

	^ SpMorphicBoxLayout new
		specLayout: layout;
		yourself! !

!SpMorphicBoxAdapter methodsFor: 'factory' stamp: ''!
newWrapMorph

	^ Morph new
		  layoutPolicy: ProportionalLayout new;
		  color: Color transparent;
		  borderColor: Color transparent yourself! !

!SpMorphicBoxAdapter class methodsFor: 'as yet unclassified' stamp: ''!
useExperimentalWhile: aBlock

	Experimental := true.
	aBlock ensure: [ Experimental := false ]! !

!SpMorphicBoxLayout commentStamp: ''!
I am the layout to be applied to the morph that represents a "Box Layout" (See `SpMorphicBoxAdapter`). 

If layout is homogeneous, it does a first pass to distribute size homogeneously (but it respects `minWidth`/`minHeight`).
To calculate the size, it relies in one of the `SpMorphicBoxLayoutCalculator` children, which are refacctored versions of what was found in the original `TableLayout`.
**NOTE:** The refactor is "ongoing", since I do not have time to do it properly. I just started to understand what is made there and I have no much time to spend on it right now. 

To improve performance, it prevents recursive calls on it while it is still calculating. !
!SpMorphicBoxLayout methodsFor: 'layout' stamp: ''!
layout: aMorph in: aRect

	calculating ifTrue: [ ^ self ].
	[
		calculating := true. 
		self isHomogeneous 
			ifTrue: [ self layoutHomogeneous: aMorph in: aRect ].
		super layout: aMorph in: aRect ]
	ensure: [
		calculating := false ]! !

!SpMorphicBoxLayout methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	calculating := false! !

!SpMorphicBoxLayoutCalculator commentStamp: ''!
A base for the calculator of sizes of morphs on a box layout.
This is an **ONGOING** refactor of what is found in `TableLayout`, trying to get a better (and more understandable) design.!
!SpMorphicBoxLayoutCalculator methodsFor: 'calculating' stamp: ''!
calculateFor: aMorph in: newBounds

	self subclassResponsibility! !

!SpMorphicBoxLayoutCalculator methodsFor: 'initialization' stamp: ''!
initializeProperties: anObject

	self initialize.
	properties := anObject! !

!SpMorphicBoxLayoutCalculator class methodsFor: 'instance creation' stamp: ''!
newProperties: anObject

	^ self basicNew 
		initializeProperties: anObject;
		yourself! !

!SpMorphicBoxLayoutCalculatorLeftToRight commentStamp: ''!
A refactor of `TableLayout>>layoutLeftToRight:in:`!
!SpMorphicBoxLayoutCalculatorLeftToRight methodsFor: 'calculating' stamp: ''!
calculateCellFor: aMorph
 	| sizeY sizeX props cell minExtent homogeneousWidth |

	props := aMorph layoutProperties ifNil: [ aMorph ].
	props disableTableLayout ifTrue: [ ^ self ].
	
	number := number + 1.
	cell := LayoutCell new target: aMorph.
	
	(props hResizing == #spaceFill) 
		ifTrue:[
			cell hSpaceFill: true.
			extra := aMorph spaceFillWeight.
			cell extraSpace: extra.
			sum := sum + extra ] 
		ifFalse:[
			cell hSpaceFill: false ].
		
	(props vResizing == #spaceFill) ifTrue:[ vFill := true ].
	minExtent := aMorph minExtent.
	homogeneousWidth := aMorph valueOfProperty: #homogeneousWidth.
	homogeneousWidth ifNotNil: [
		minExtent := (minExtent x max: homogeneousWidth)@(minExtent y) ].
	size := minExtent. sizeX := size x. sizeY := size y.
	sizeX < minX
		ifTrue:[ sizeX := minX ]
		ifFalse:[ sizeX > maxX ifTrue: [ sizeX := maxX ] ].
		
	sizeY < minY
		ifTrue:[ sizeY := minY ]
		ifFalse:[ sizeY > maxY ifTrue:[ sizeY := maxY ] ].

	cell cellSize: sizeX.
	last ifNil:[ first := cell ] ifNotNil:[ last nextCell: cell ].
	last := cell.
	width := width + sizeX.
	sizeY > height 
		ifTrue: [ height := sizeY ]! !

!SpMorphicBoxLayoutCalculatorLeftToRight methodsFor: 'calculating' stamp: ''!
calculateFor: aMorph in: newBounds
	"An optimized left-to-right list layout"	
	| inset extent posX posY centering extraPerCell cell amount |
	
	size := properties minCellSize asPoint. minX := size x. minY := size y.
	size := properties maxCellSize asPoint. maxX := size x. maxY := size y.
	inset := properties cellInset asPoint x.
	extent := newBounds extent.
	number := 0. vFill := false. sum := 0.
	width := height := 0.
	first := last := nil.

	properties reverseTableCells
		ifTrue:[ aMorph submorphsReverseDo: [ :each | self calculateCellFor: each ] ]
		ifFalse:[ aMorph submorphsDo: [ :each | self calculateCellFor: each ] ].

	number > 1 ifTrue:[ width := width + ((number-1) * inset) ].

	(properties hResizing == #shrinkWrap and: [ properties rubberBandCells or: [ sum isZero ] ])
		ifTrue:[ extent := width @ (extent y max: height) ].
	(properties vResizing == #shrinkWrap and:[ properties rubberBandCells or:[ vFill not ] ])
		ifTrue:[ extent := (extent x max: width) @ height ].

	posX := newBounds left.
	posY := newBounds top.

	"Compute extra vertical space"
	extra := extent y - height.
	extra < 0 ifTrue: [ extra := 0 ].
	extra > 0 ifTrue: [
		vFill 
			ifTrue:[ height := extent y ] 
			ifFalse:[
				centering := properties wrapCentering.
				centering == #bottomRight ifTrue:[ posY := posY + extra ].
				centering == #center ifTrue:[ posY := posY + (extra // 2) ] ] ].

	"Compute extra horizontal space"
	extra := extent x - width.
	extra < 0 ifTrue: [ extra := 0 ].
	extraPerCell := 0.
	extra > 0 
		ifTrue: [
			sum isZero 
				ifTrue: [
				"extra space but no #spaceFillers"
				centering := properties listCentering.
				centering == #bottomRight ifTrue:[ posX := posX + extra ].
				centering == #center ifTrue:[ posX := posX + (extra // 2) ] ] 
			ifFalse:[
				extraPerCell := extra asFloat / sum asFloat ] ].

	number := 0.
	extra := last := 0.
	cell := first.
	[ cell isNil ] whileFalse: [
		number := number + 1.
		width := cell cellSize.
		(extraPerCell > 0 and: [ cell hSpaceFill ]) 
			ifTrue: [
				extra := (last := extra) + (extraPerCell * cell extraSpace).
				amount := extra truncated - last truncated.
				width := width + amount ].
		cell target layoutInBounds: (posX @ posY extent: width @ height).
		posX := posX + width + inset.
		cell := cell nextCell ].
! !

!SpMorphicBoxLayoutCalculatorTopToBottom commentStamp: ''!
A refactor of `TableLayout>>layoutTopToBottom:in:`!
!SpMorphicBoxLayoutCalculatorTopToBottom methodsFor: 'calculating' stamp: ''!
calculateCellFor: m
 	| sizeX props sizeY cell |
	
	props := m layoutProperties ifNil:[m].
	props disableTableLayout ifTrue:[ ^ self ].
	
	number := number + 1.
	cell := LayoutCell new target: m.
	(props vResizing == #spaceFill) ifTrue:[
		cell vSpaceFill: true.
		extra := m spaceFillWeight.
		cell extraSpace: extra.
		sum := sum + extra.
	] ifFalse:[cell vSpaceFill: false].
	(props hResizing == #spaceFill) ifTrue:[vFill := true].
	size := m minExtent. sizeX := size x. sizeY := size y.
	sizeX < minX
		ifTrue:[sizeX := minX]
		ifFalse:[sizeX > maxX ifTrue:[sizeX := maxX]].
	sizeY < minY
		ifTrue:[sizeY := minY]
		ifFalse:[sizeY > maxY ifTrue:[sizeY := maxY]].
	cell cellSize: sizeY.
	first ifNil:[first := cell] ifNotNil:[last nextCell: cell].
	last := cell.
	height := height + sizeY.
	sizeX > width ifTrue:[width := sizeX].

! !

!SpMorphicBoxLayoutCalculatorTopToBottom methodsFor: 'calculating' stamp: ''!
calculateFor: aMorph in: newBounds
	"An optimized top-to-bottom list layout"
	| inset extent posX posY centering extraPerCell cell amount |

	size := properties minCellSize asPoint. minX := size x. minY := size y.
	size := properties maxCellSize asPoint. maxX := size x. maxY := size y.
	inset := properties cellInset asPoint y.
	extent := newBounds extent.
	number := 0. vFill := false. sum := 0.
	width := height := 0.
	first := last := nil.

	properties reverseTableCells
		ifTrue:[aMorph submorphsReverseDo: [ :each | self calculateCellFor: each]]
		ifFalse:[aMorph submorphsDo: [ :each | self calculateCellFor: each]].

	number > 1 ifTrue:[height := height + (number-1 * inset)].

	(properties vResizing == #shrinkWrap and:[properties rubberBandCells or:[sum isZero]])
		ifTrue:[extent := (extent x max: width) @ height].
	(properties hResizing == #shrinkWrap and:[properties rubberBandCells or:[vFill not]])
		ifTrue:[extent := width @ (extent y max: height)].

	posX := newBounds left.
	posY := newBounds top.

	"Compute extra horizontal space"
	extra := extent x - width.
	extra < 0 ifTrue:[extra := 0].
	extra > 0 ifTrue:[
		vFill ifTrue:[
			width := extent x.
		] ifFalse:[
			centering := properties wrapCentering.
			centering == #bottomRight ifTrue:[posX := posX + extra].
			centering == #center ifTrue:[posX := posX + (extra // 2)]
		].
	].


	"Compute extra vertical space"
	extra := extent y - height.
	extra < 0 ifTrue:[extra := 0].
	extraPerCell := 0.
	extra > 0 ifTrue:[
		sum isZero ifTrue:["extra space but no #spaceFillers"
			centering := properties listCentering.
			centering == #bottomRight ifTrue:[posY := posY + extra].
			centering == #center ifTrue:[posY := posY + (extra // 2)].
		] ifFalse:[extraPerCell := extra asFloat / sum asFloat].
	].

	number := 0.
	extra := last := 0.
	cell := first.
	[cell == nil] whileFalse:[
		number := number + 1.
		height := cell cellSize.
		(extraPerCell > 0 and:[cell vSpaceFill]) ifTrue:[
			extra := (last := extra) + (extraPerCell * cell extraSpace).
			amount := extra truncated - last truncated.
			height := height + amount.
		].
		cell target layoutInBounds: (posX @ posY extent: width @ height).
		posY := posY + height + inset.
		cell := cell nextCell.
	].! !

!SpMorphicBoxLayoutTest methodsFor: 'running' stamp: ''!
tearDown
	instance
		ifNotNil: [ instance close.
			instance := nil ].
	super tearDown! !

!SpMorphicBoxLayoutTest methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	backend := SpMorphicBackendForTest new! !

!SpMorphicBoxLayoutTest methodsFor: 'tests' stamp: ''!
testClassIsDisplayedWithCorrectAlignment
	| presenter table |

	presenter := SpBoxLayoutWithTableForTestPresenter new.
	instance := presenter openWithSpec.

	table := presenter table adapter widget.
	self assert: instance window left <= table left.
	self assert: table left <= table submorphs first left! !

!SpMorphicBoxLayoutTest methodsFor: 'tests' stamp: ''!
testAddWithPaddingHorizontal
	| base presenter layout |

	base := SpBoxLayoutWithTableForTestPresenter new.
	presenter := SpLabelPresenter new.
	
	layout := SpBoxLayout newLeftToRight
		add: presenter expand: false fill: false padding: 10;
		yourself.
		
	base buildAdapterWithSpecLayout: layout.

	"validate the widget is within a parent that keeps the widget with a padding"	
	self 
		assert: presenter adapter widget extent
		equals: (presenter adapter widget owner extent - (20@0))! !

!SpMorphicBoxLayoutTest methodsFor: 'tests' stamp: ''!
testBeHomogeneousWorksWhenExpandingWindow
	| presenter p1 p2 p3 |

	presenter := SpPresenter new.
	presenter layout: (SpBoxLayout newHorizontal 
		beHomogeneous;
		add: (p1 := presenter newButton);
		add: (p2 := presenter newLabel);
		add: (p3 := presenter newList);
		yourself).

	p1 label: 'Button'.
	p2 label: 'Label'.
	p3 items: #(one two three).

	[ 
		presenter openWithSpec.
		backend waitUntilUIRedrawed.
		presenter withWindowDo: [ :window |
			window adapter widgetDo: [ :widget |
				widget extent: widget extent + (200@10) ] ].
		backend waitUntilUIRedrawed.
	]
	ensure: [ presenter withWindowDo: #close ].		

	self assert: presenter adapter widget width 
		>= (p1 adapter widget width 
			+ p2 adapter widget width
			+ p3 adapter widget width).
	self assert: p2 adapter widget width equals: p3 adapter widget width.	
	self assert: p1 adapter widget width equals: p2 adapter widget width.
	self assert: presenter window adapter widget width 
		>= presenter adapter widget width! !

!SpMorphicBoxLayoutTest methodsFor: 'tests' stamp: ''!
testBeHomogeneous
	| presenter p1 p2 p3 |

	"not working on CI :("
	self skipOnPharoCITestingEnvironment.

	presenter := SpPresenter new.
	presenter layout: (SpBoxLayout newHorizontal 
		beHomogeneous;
		add: (p1 := presenter newButton);
		add: (p2 := presenter newLabel);
		add: (p3 := presenter newList);
		yourself).

	p1 label: 'Button'.
	p2 label: 'Label'.
	p3 items: #(one two three).

	[ 
		presenter openWithSpec.
	 	backend waitUntilUIRedrawed ]
	ensure: [ presenter withWindowDo: #close ].		

	self assert: presenter adapter widget width 
		>= (p1 adapter widget width 
			+ p2 adapter widget width
			+ p3 adapter widget width).
	self assert: p2 adapter widget width equals: p3 adapter widget width.	
	self assert: p1 adapter widget width equals: p2 adapter widget width! !

!SpMorphicBoxLayoutTest methodsFor: 'tests' stamp: ''!
testNestedLayoutModifiesHeightOfTopLayout
	| base presenter layout |

	base := SpBoxLayoutWithTableForTestPresenter new.

	presenter := SpLabelPresenter new
		label: 'Test';
		yourself.
	
	layout := SpBoxLayout newTopToBottom
		add: (SpBoxLayout newLeftToRight 
				add: presenter expand: false;
				yourself) 
			expand: false;
		yourself.
		
	base buildAdapterWithSpecLayout: layout.

	"validate the widget is within a parent that keeps the widget with a padding"	
	self 
		assert: presenter adapter widget owner owner height  
		equals: presenter adapter widget height! !

!SpMorphicBoxLayoutTest methodsFor: 'tests' stamp: ''!
testAddWithPaddingVertical
	| base presenter layout |

	base := SpBoxLayoutWithTableForTestPresenter new.
	presenter := SpLabelPresenter new.
	
	layout := SpBoxLayout newTopToBottom
		add: presenter expand: false fill: false padding: 10;
		yourself.
		
	base buildAdapterWithSpecLayout: layout.

	"validate the widget is within a parent that keeps the widget with a padding"	
	self 
		assert: presenter adapter widget extent
		equals: (presenter adapter widget owner extent - (0@20))! !

!SpMorphicBoxLayoutTest methodsFor: 'tests' stamp: ''!
testLayoutHeightTakesAllSpaceNeeded
	| string presenter textPresenter layout |

	string := String loremIpsum withNoLineLongerThan: 80.

	presenter := SpPresenter new.

	textPresenter := SpTextPresenter new.
	textPresenter text: string.
	textPresenter propagateNaturalHeight: true. 

	layout := SpBoxLayout newTopToBottom 
		add: textPresenter;
		yourself.	
	
	presenter 
		layout: layout;
		buildWithSpec.
	
	self assert: presenter adapter widget height >= (string lines size * string asMorph height).! !

!SpMorphicBoxLayoutTest methodsFor: 'tests' stamp: ''!
testBeHomogeneousWorksWhenContractingWindow
	| presenter p1 p2 p3 windowWidth presenterWidth width1 width2 width3 |

	"not working on CI :("
	self skipOnPharoCITestingEnvironment.

	presenter := SpPresenter new.
	presenter layout: (SpBoxLayout newHorizontal 
		beHomogeneous;
		add: (p1 := presenter newButton);
		add: (p2 := presenter newLabel);
		add: (p3 := presenter newList);
		yourself).

	p1 label: 'Button'.
	p2 label: 'Label'.
	p3 items: #(one two three).

	[ 
		presenter openWithSpec.
		backend waitUntilUIRedrawed.
		presenter withWindowDo: [ :window |
			window adapter widgetDo: [ :widget |
				widget extent: widget extent - (50@50) ] ].
		backend waitUntilUIRedrawed
	]
	ensure: [ presenter withWindowDo: #close ].		

	windowWidth := presenter window adapter widget width.
	presenterWidth := presenter adapter widget width.
	width1 := p1 adapter widget width.
	width2 := p2 adapter widget width.
	width3 := p3 adapter widget width.
	self assert: presenterWidth >= (width1 + width2 + width3).
	self assert: width1 equals: width2.	
	self assert: width2 equals: width3.
	self assert: windowWidth >= presenterWidth! !

!SpMorphicBoxLayoutTest methodsFor: 'tests' stamp: ''!
testPresenterTakesRightHeight
	| presenter l1 l2 |
	
	(presenter := SpPresenter new) 
		layout: (SpBoxLayout newTopToBottom 
			add: (l1 := (presenter newLabel label: 'Line 1')) expand: false;
			add: (l2 := (presenter newLabel label: 'Line 2')) expand: false).
	
	presenter buildWithSpec.	
	
	self 
		assert: presenter adapter widget height 
		equals: l1 adapter widget height + l2 adapter widget height! !

!SpMorphicButtonAdapter commentStamp: ''!
SpecInterpreter
	interpretASpec: MorphicButtonAdapter  defaultSpec
	model: (MorphicButtonAdapter model: ButtonPresenter new)
!
!SpMorphicButtonAdapter methodsFor: 'menus support' stamp: ''!
deleteIfPopUp: evt! !

!SpMorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
menu: aMenu

	| menuPresenter |
	menuPresenter := self model contextMenu.
	menuPresenter ifNil: [ ^ nil ].
	^ SpBindings
		  value: self model application adapterBindings
		  during: [ menuPresenter buildWithSpec ]! !

!SpMorphicButtonAdapter methodsFor: 'private' stamp: ''!
buildLabel: text withIcon: icon
	| iconLabel |

	icon ifNil: [ 
		^ (text localizedForPresenter: self presenter) ifNil: [ '' ] ].
	
	iconLabel := IconicListItemMorph new.
	iconLabel icon: (self presenter isEnabled
		ifTrue: [ icon ]
		ifFalse: [ icon asGrayScaleWithAlpha ]).
	text isEmptyOrNil ifFalse: [ 
		iconLabel morph: (text asMorph 
			lock;
			yourself) ].
		
	^ iconLabel! !

!SpMorphicButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| button | 

	button := self newButton.	
	button 
		getEnabledSelector: #enabled ;
		getFontSelector: #font ;
		hResizing: #spaceFill ;
		vResizing: #spaceFill ;
		askBeforeChanging: self askBeforeChanging ;
		setBalloonText: self getHelpText ;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled ;	
		eventHandler: (MorphicEventHandler new 
			on: #keyStroke 
			send: #keyStroke:fromMorph: 
			to: self).
	
	self color ifNotNil: [ self setWidgetColor: button ].
	
	button 
		bindKeyCombination: Character space 
		toAction: [ self action ].

	^ button! !

!SpMorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
font

	^ self model font! !

!SpMorphicButtonAdapter methodsFor: 'factory' stamp: ''!
newButton

	^ PluggableButtonMorph
		  on: self
		  getState: #state
		  action: #action
		  label: #label
		  menu: #menu:! !

!SpMorphicButtonAdapter methodsFor: 'menus support' stamp: ''!
isSelected: aBooolean! !

!SpMorphicButtonAdapter methodsFor: 'accessing' stamp: ''!
styleName: aString 

	styleName := aString! !

!SpMorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
showSubMenuIfPresent

	self model contextMenu ifNil: [ ^ self ].
	self showSubMenu: self model contextMenu
	! !

!SpMorphicButtonAdapter methodsFor: 'private' stamp: ''!
getHelpText

	^ self presenter help ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicButtonAdapter methodsFor: 'emulating' stamp: ''!
clicked

	| evt |
	evt := MouseButtonEvent new
		       setType: nil
		       position: widget center
		       which: MouseButtonEvent redButton
		       buttons: MouseButtonEvent redButton
		       hand: nil
		       stamp: nil.

	(widget handlesMouseDown: evt) ifTrue: [ 
		widget 
			mouseDown: evt;
			mouseUp: evt ]! !

!SpMorphicButtonAdapter methodsFor: 'accessing' stamp: ''!
helpText

	^ self widget helpText! !

!SpMorphicButtonAdapter methodsFor: 'accessing' stamp: ''!
icon

	^ widget label icon! !

!SpMorphicButtonAdapter methodsFor: 'accessing' stamp: ''!
enabled: aBoolean

	super enabled: aBoolean.
	self widgetDo: [ :w | w label: self label ]! !

!SpMorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
label
	
	^ self 
		buildLabel: (self presenter label withAccentuatedCharacter: self presenter shortcutCharacter) 
		withIcon: self presenter icon! !

!SpMorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
keyStroke: anEvent fromMorph: aMorph! !

!SpMorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
showSubMenu: aMenu

	aMenu menuGroups ifNil: [ ^ self ].

	subMenuWidget ifNotNil: [ 
		subMenuWidget delete.
		subMenuWidget := nil ].
	subMenuWidget := (SpMorphicMenuAdapter adaptAsPopup: aMenu) widget.
	subMenuWidget
		popUpAdjacentTo: { 
				self widget bounds bottomLeft.
				self widget bounds bottomRight }
		forHand: self widget activeHand
		from: self widget.
	subMenuWidget popUpOwner: self! !

!SpMorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
action

	self showSubMenuIfPresent.

	self widget ifNotNil: [:m | m takeKeyboardFocus ].
	self model performAction.! !

!SpMorphicButtonAdapter methodsFor: 'accessing' stamp: ''!
unscaledInitialExtent

	^ 15@26! !

!SpMorphicButtonAdapter methodsFor: 'widget API' stamp: ''!
state

	^ self model state! !

!SpMorphicButtonAdapter methodsFor: 'updating' stamp: ''!
updateMenu	
	"There is no need to updateMenu here because it will be resolved at #menu:"! !

!SpMorphicButtonAdapter methodsFor: 'accessing' stamp: ''!
styleName

	^ styleName ifNil: [ super styleName ]! !

!SpMorphicButtonAdapter methodsFor: 'factory' stamp: ''!
setWidgetColor: button

	| normalColorBlock clickedColorBlock |

	normalColorBlock := [ :aButton |
			(aButton valueOfProperty: #noFill ifAbsent: [false]) 
					ifTrue: [ SolidFillStyle color: Color transparent ]
					ifFalse: [ SolidFillStyle color: self color ] ].
	
	clickedColorBlock := [ :aButton | SolidFillStyle color: self color muchDarker ].
	button theme: ((SpUIThemeDecorator theme: button theme)
							property: #buttonNormalFillStyleFor: returnsValueOf: normalColorBlock;
							property: #buttonMouseOverFillStyleFor: returnsValueOf: normalColorBlock;
							property: #buttonPressedFillStyleFor: returnsValueOf: clickedColorBlock;
							yourself)! !

!SpMorphicButtonAdapter methodsFor: 'private' stamp: ''!
getLabelText

	^ self presenter label ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicButtonAdapter methodsFor: 'protocol' stamp: ''!
askBeforeChanging

	^ self model askBeforeChanging! !

!SpMorphicButtonBarAdapter commentStamp: ''!
Spec Adapter to Morphic for a ButtonBarPresenter using a PanelMorph!
!SpMorphicButtonBarAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| panelMorph |
	
	panelMorph := PanelMorph new 
		changeTableLayout;
		listDirection: self listDirection;
		hResizing: #spaceFill;
		vResizing: #rigid;
		cellInset: self class defaultItemSeparation;
		height: self class defaultHeight;
		yourself.

	self addModelTo: panelMorph.
	
	^ panelMorph! !

!SpMorphicButtonBarAdapter methodsFor: 'factory' stamp: ''!
addModelTo: panelMorph

	self model items do: [ :each |
		self model focusOrder add: each.
		panelMorph addMorph: (each buildWithSpec
			width: 100;
			hResizing: #rigid;
			yourself) ]! !

!SpMorphicButtonBarAdapter methodsFor: 'factory' stamp: ''!
listDirection
	
	self model isPlaceAtEnd ifTrue: [ ^ #rightToLeft ].
	self model isPlaceAtStart ifTrue: [ ^ #leftToRight ].
	
	self error: 'Undefined location to place buttons.'! !

!SpMorphicButtonBarAdapter class methodsFor: 'accessing' stamp: ''!
defaultItemSeparation
	
	^ 3@0! !

!SpMorphicButtonBarAdapter class methodsFor: 'accessing' stamp: ''!
defaultHeight

	^ 30! !

!SpMorphicCheckBoxAdapter commentStamp: ''!
I am an adapter to ease the bridge a CheckBoxPresenter and a CheckboxMorph!
!SpMorphicCheckBoxAdapter methodsFor: 'spec protocol' stamp: ''!
labelOnRight

	^ self widgetDo: [ :w | w listDirection: #rightToLeft ]! !

!SpMorphicCheckBoxAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	| checkButton |
	checkButton := CheckboxMorph
						on: self 
						selected: #state
						changeSelected: #state:.
	checkButton 
			label: self getLabelText; 
			beCheckbox;
			hResizing: #spaceFill; 
			vResizing: #shrinkWrap; 
			setBalloonText: self getHelpText;
			getEnabledSelector: #enabled;
			dragEnabled: self dragEnabled;
			dropEnabled: self dropEnabled;	
			labelClickable: self labelClickable.
			
	self presenter whenLabelChangedDo: [ :newLabel | checkButton label: (newLabel ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]) ].
	self presenter whenChangedDo: [ checkButton updateSelection ].
	^ checkButton! !

!SpMorphicCheckBoxAdapter methodsFor: 'widget API' stamp: ''!
state: aBoolean
	
	^ self presenter state: aBoolean! !

!SpMorphicCheckBoxAdapter methodsFor: 'spec protocol' stamp: ''!
labelOnLeft

	^ self widgetDo: [ :w | w listDirection: #leftToRight ]! !

!SpMorphicCheckBoxAdapter methodsFor: 'widget API' stamp: ''!
labelClickable
	
	^ self model labelClickable! !

!SpMorphicCheckBoxAdapter methodsFor: 'private' stamp: ''!
getHelpText

	^ self presenter help ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicCheckBoxAdapter methodsFor: 'emulating' stamp: ''!
clicked
	
	widget toggleSelected! !

!SpMorphicCheckBoxAdapter methodsFor: 'accessing' stamp: ''!
helpText
	
	^ widget balloonText! !

!SpMorphicCheckBoxAdapter methodsFor: 'widget API' stamp: ''!
state
	
	^ self presenter state! !

!SpMorphicCheckBoxAdapter methodsFor: 'private' stamp: ''!
getLabelText

	^ self presenter label ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicCheckBoxAdapter methodsFor: 'widget API' stamp: ''!
label
	
	^ self getLabelText! !

!SpMorphicCodeAdapter methodsFor: 'private' stamp: ''!
hasSyntaxHighlightEnabled
	"this is used just for testing"
	
	^ self presenter hasSyntaxHighlight! !

!SpMorphicCodeAdapter methodsFor: 'widget API' stamp: ''!
setInteractionModel: anInteractionModel to: w

	w textArea editor isSmalltalkEditor ifFalse: [ ^ self ].
	w completionEngine: (self newCompletionEngine: anInteractionModel)! !

!SpMorphicCodeAdapter methodsFor: 'widget API' stamp: ''!
userActionDuring: aBlock

	aBlock value! !

!SpMorphicCodeAdapter methodsFor: 'widget API' stamp: ''!
selectedBehavior

	^ self presenter selectedBehavior! !

!SpMorphicCodeAdapter methodsFor: 'private' stamp: ''!
newCompletionEngine: anInteractionModel

	^ SpMorphicCodeCompletionEngine new 
		scripting: anInteractionModel isForScripting;
		doItRequestor: anInteractionModel;
		doItContext: anInteractionModel doItContext;
		completionClass: anInteractionModel selectedClassOrMetaClass;
		yourself! !

!SpMorphicCodeAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| newWidget |
	
	newWidget := super buildWidget.
	
	self presenter hasLineNumbers ifTrue: [ 
		newWidget withLineNumbers ].
	self presenter interactionModel ifNotNil: [ :im | 
		self setInteractionModel: im to: newWidget ].
 
	self presenter whenLineNumbersChangedDo: [ :hasLineNumbers | 
		self changeLineNumbers: hasLineNumbers to: newWidget ].
	self presenter whenSyntaxHighlightChangedDo: [ :hasSyntaxHighlight | 
		self setEditingModeFor: newWidget ].
	
	self presenter syntaxHighlightTheme ifNotNil: [ 
		self setSyntaxHighlightThemeFor: newWidget ].
	self presenter whenSyntaxHighlightThemeChangedDo: [ :value |
		self setSyntaxHighlightThemeFor: newWidget ].
	
	^ newWidget! !

!SpMorphicCodeAdapter methodsFor: 'NOCompletion' stamp: ''!
guessTypeForName: aString

	^nil! !

!SpMorphicCodeAdapter methodsFor: 'private - shout' stamp: ''!
bindingOf: aString

	^ self presenter bindingOf: aString! !

!SpMorphicCodeAdapter methodsFor: 'widget API' stamp: ''!
insertPopoverAfterCurrentSelection: aPresenter style: styleName
	| popover pos |

	self widgetDo: [ :w |

		popover := self presenter newPopover
			bePositionRight;
			presenter: aPresenter;
			yourself.
			
		styleName ifNotNil: [ 
			popover addStyle: styleName ].
		popover buildWithSpec.
		"popover style needs to be applied when poping up. 
		 Do not apply it here!! (I am letting it here as documentation)"
		"popover adapter applyStyle."
	
		pos := self computeOriginFor: w.
		"(20@0) is a magic number to position correctly the popover"
		popover popupPointingTo: (pos corner: (pos + (20@0))).
		popover takeKeyboardFocus ]! !

!SpMorphicCodeAdapter methodsFor: 'widget API' stamp: ''!
doItReceiver

	^ self presenter doItReceiver! !

!SpMorphicCodeAdapter methodsFor: 'private' stamp: ''!
hasSyntaxHighlight

	^ self presenter hasSyntaxHighlight! !

!SpMorphicCodeAdapter methodsFor: 'private' stamp: ''!
setEditingModeFor: textArea

	self hasSyntaxHighlight
		ifTrue: [ 
			self 
				setEditingModeFor: textArea 
				withBehavior: self behavior 
				forScripting: self isForScripting ]
		ifFalse: [ 
			super setEditingModeFor: textArea ]! !

!SpMorphicCodeAdapter methodsFor: 'private' stamp: ''!
changeLineNumbers: hasLineNumbers to: aMorph 

	hasLineNumbers 
		ifTrue: [ aMorph withLineNumbers ]
		ifFalse: [ aMorph withoutLineNumbers ]! !

!SpMorphicCodeAdapter methodsFor: 'widget API' stamp: ''!
refreshStyling

	self presenter hasSyntaxHighlight ifFalse: [ ^ self ].
	self widgetDo: [ :w | w textArea shoutStyler refreshStyling ]! !

!SpMorphicCodeAdapter methodsFor: 'NOCompletion' stamp: ''!
receiverClass

	^ self behavior! !

!SpMorphicCodeAdapter methodsFor: 'private' stamp: ''!
setSyntaxHighlightThemeFor: textArea
	| theme |
	
	theme := self presenter syntaxHighlightTheme.
	theme ifNil: [ ^ self ].

	textArea shoutStyler 
		styler: (SpMorphicCodeTextStyler newWithAttributeTableNamed: theme);
		refreshStyling! !

!SpMorphicCodeAdapter methodsFor: 'widget API' stamp: ''!
doItContext

	^ self presenter doItContext! !

!SpMorphicCodeAdapter methodsFor: 'private' stamp: ''!
originMorphFor: aMorph

	(aMorph textArea hasSelection not and: [ 
		aMorph textArea hasHighlightSegment ]) ifTrue: [ 
			^ aMorph textArea getHighlightSegment ].
	^ aMorph textArea cursor! !

!SpMorphicCodeAdapter methodsFor: 'private - shout' stamp: ''!
hasBindingOf: aString

	^ self presenter hasBindingOf: aString! !

!SpMorphicCodeAdapter methodsFor: 'NOCompletion' stamp: ''!
selectedClassOrMetaClass

	^ self behavior! !

!SpMorphicCodeAdapter methodsFor: 'widget API' stamp: ''!
isForScripting

	^ self presenter isForScripting! !

!SpMorphicCodeAdapter methodsFor: 'private' stamp: ''!
computeOriginFor: aMorph
	| desiredTop desiredLeft |

	aMorph textArea scrollSelectionIntoView: nil.
	desiredTop := (self originMorphFor: aMorph) positionInWorld y - 6.
						"unclear why 6 is the magic number"
	desiredLeft := (self originMorphFor: aMorph) right + aMorph positionInWorld x + 6.
	
	^ desiredLeft @ desiredTop! !

!SpMorphicCodeAdapter methodsFor: 'widget API' stamp: ''!
interactionModel: anInteractionModel

	self classOrMetaClass: anInteractionModel behavior.
	self widgetDo: [ :w |
		self setInteractionModel: anInteractionModel to: w ]! !

!SpMorphicCodeAdapter methodsFor: 'private' stamp: ''!
setEditingModeFor: textArea withBehavior: aBehavior forScripting: aBoolean

	textArea model: self.
	(aBoolean or: [ aBehavior isNil ]) 
		ifTrue: [ 
			textArea beForSmalltalkScripting.
			textArea editingMode classOrMetaClass: aBehavior ]
		ifFalse: [
			textArea beForSmalltalkCodeInClass: aBehavior ].
	"Following code should bring correct requestor (a code presenter) with a proper code interaction model into styler to enable a visibility of external variables (like workspace variables)"
	textArea shoutStyler styler 
		isForWorkspace: aBoolean;
		workspace: self presenter.
	textArea shoutStyler refreshStyling! !

!SpMorphicCodeAdapter methodsFor: 'initialization' stamp: ''!
addKeyBindingsTo: aMorph

	super addKeyBindingsTo: aMorph.
	self presenter contextKeyBindings ifNotNil: [ :kmCategory |
	 	kmCategory allEntries keymaps do: [ :each |
			self
				bindKeyCombination: each shortcut 
				toAction: each action ] ]! !

!SpMorphicCodeAdapter methodsFor: 'private - shout' stamp: ''!
classOrMetaClass: aClass

	self 
		setEditingModeFor: self widget textArea 
		withBehavior: aClass
		forScripting: self isForScripting! !

!SpMorphicCodeAdapter methodsFor: 'private' stamp: ''!
textWithStyle
	"This method is to be used for testing. 
	 DO NOT USE IT!!"
	
	^ self widget getText! !

!SpMorphicCodeAdapter methodsFor: 'widget API' stamp: ''!
behavior

	^ self presenter behavior! !

!SpMorphicCodeCompletionEngine commentStamp: ''!
I'm a code completion engine.
I can have several configurations: 

- I have a completionClass, and I am not for scripting -> I will be used in a browser.
- I have a completionClass, and I am for scripting -> I will be used in an inspector.
- I do not have a completionClass, and I am not for scripting -> I am in a method without class
- I do not have a completionClass, and I am for scripting -> I will be used in a workspace (playground)
!
!SpMorphicCodeCompletionEngine methodsFor: 'accessing' stamp: ''!
completionClass

	^ completionClass! !

!SpMorphicCodeCompletionEngine methodsFor: 'accessing' stamp: ''!
completionClass: anObject

	completionClass := anObject! !

!SpMorphicCodeCompletionEngine methodsFor: 'accessing' stamp: ''!
doItContext

	^ doItContext! !

!SpMorphicCodeCompletionEngine methodsFor: 'accessing' stamp: ''!
completionBuilder: anObject

	completionBuilder := anObject! !

!SpMorphicCodeCompletionEngine methodsFor: 'accessing' stamp: ''!
doItContext: aContext

	doItContext := aContext! !

!SpMorphicCodeCompletionEngine methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	contextClass := CoCompletionContext! !

!SpMorphicCodeCompletionEngine methodsFor: 'accessing' stamp: ''!
variableBindingNames

	^ self doItRequestor variableBindingNames! !

!SpMorphicCodeCompletionEngine methodsFor: 'accessing' stamp: ''!
doItRequestor

	^ doItRequestor! !

!SpMorphicCodeCompletionEngine methodsFor: 'accessing' stamp: ''!
scripting: aBoolean 

	scripting := aBoolean! !

!SpMorphicCodeCompletionEngine methodsFor: 'accessing' stamp: ''!
completionBuilder

	^ completionBuilder ifNil: [ CoASTHeuristicsResultSetBuilder new ]! !

!SpMorphicCodeCompletionEngine methodsFor: 'testing' stamp: ''!
isScripting

	^ scripting! !

!SpMorphicCodeCompletionEngine methodsFor: 'accessing' stamp: ''!
doItRequestor: aRequestor

	doItRequestor := aRequestor! !

!SpMorphicCodeTextStyler methodsFor: 'initialization' stamp: ''!
initializeAttributeTable: attrTable

	attributeTable := attrTable.
	self initialize! !

!SpMorphicCodeTextStyler methodsFor: 'private' stamp: ''!
attributesFor: aSymbol 
	
	^ attributeTable at: aSymbol ifAbsent: [ #() ]! !

!SpMorphicCodeTextStyler class methodsFor: 'instance creation' stamp: ''!
new

	^ self newWithAttributeTable: self styleTable! !

!SpMorphicCodeTextStyler class methodsFor: 'instance creation' stamp: ''!
newWithAttributeTableNamed: aString

	^ self newWithAttributeTable: (self newAttributesForStyleTableNamed: aString)! !

!SpMorphicCodeTextStyler class methodsFor: 'instance creation' stamp: ''!
newWithAttributeTable: attrTable

	^ self basicNew
		initializeAttributeTable: attrTable;
		yourself! !

!SpMorphicComponentListAdapter methodsFor: 'accessing' stamp: ''!
elementAt: index 
	
	^ self widget dataSource elementAt: index! !

!SpMorphicComponentListAdapter methodsFor: 'updating' stamp: ''!
refreshList

	^ self widget refresh! !

!SpMorphicComponentListAdapter methodsFor: 'accessing' stamp: ''!
selectIndex: aNumber 
	
	(aNumber = 0 and: [ widget selectedIndexes isEmpty ]) ifTrue: [ ^ self ].	
	(widget selectedIndexes includes: aNumber) ifTrue: [ ^ self ].
	widget selectIndex: aNumber! !

!SpMorphicComponentListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	widget := SpFTTableMorph new
		beRowNotHomogeneous;
		dataSource: self newDataSource;
		setMultipleSelection: self presenter isMultipleSelection;
		hideColumnHeaders;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		setBalloonText: self help;
		onAnnouncement: FTSelectionChanged send: #selectionChanged: to: self;
		onAnnouncement: FTStrongSelectionChanged send: #strongSelectionChanged: to: self;
		yourself.
		
	self presenter whenPresentersChangedDo: [ self refreshList ].
	self refreshWidgetSelection.
	self presenter whenSelectionChangedDo: [ self refreshWidgetSelection ].
	
	^ widget! !

!SpMorphicComponentListAdapter methodsFor: 'factory' stamp: ''!
newDataSource
	
	^ SpComponentListDataSource new
		model: self presenter;
		yourself! !

!SpMorphicComponentListAdapter methodsFor: 'accessing' stamp: ''!
children

	^ self rows collect: [ :row | | cell | 
		cell := row submorphs first.
		cell submorphs first ]! !

!SpMorphicComponentListAdapter methodsFor: 'event handling' stamp: ''!
selectionChanged: ann
	| diff |
	
	self presenter selection isMultipleSelection ifTrue: [ 
		self presenter selection selectIndexes: (ann newSelectedIndexes reject: [ :e | e = 0 ]) ].
	self presenter selection isMultipleSelection ifFalse: [ 
		self presenter selection selectIndex: (ann newSelectedIndexes
			ifNotEmpty: [ :indexes | indexes first ]
			ifEmpty: [ 0 ]) ].
	diff := ann newSelectedIndexes difference: ann oldSelectedIndexes.
	(diff notEmpty and: [ self presenter activatesOnSingleClick ])
		ifTrue: [ self presenter doActivateAtIndex: diff last ].
	
	ann newSelectedIndexes ifNotEmpty: [ ^ self ].
	self presenter selection unselectAll! !

!SpMorphicComponentListAdapter methodsFor: 'private' stamp: ''!
showContextMenu

	self widgetDo: [ :w |
		w showMenuForIndex: { self presenter selection selectedIndex. 1 } ]! !

!SpMorphicComponentListAdapter methodsFor: 'private' stamp: ''!
triggerActivationAction

	self presenter doActivateAtIndex: self presenter selection selectedIndex! !

!SpMorphicComponentListAdapter methodsFor: 'initialization' stamp: ''!
addActivationKeyBindings: aWidget

	self 
		bindKeyCombination: Character cr asKeyCombination
		toAction: [ self triggerActivationAction ]! !

!SpMorphicComponentListAdapter methodsFor: 'accessing' stamp: ''!
selectedIndexes

	^ widget selectedIndexes! !

!SpMorphicComponentListAdapter methodsFor: 'emulating' stamp: ''!
sendRightClickEvent
	| evt |

	evt := MouseButtonEvent new 
		setType: nil 
		position: widget center 
		which: MouseButtonEvent yellowButton 
		buttons: MouseButtonEvent yellowButton 
		hand: nil 
		stamp: nil.
	
	self widget click: evt! !

!SpMorphicComponentListAdapter methodsFor: 'testing' stamp: ''!
isNonEditableRow: aRow column: aColumn 
	"no rows are directly editable in a component list (they can be 
	 if defined like that in the inner presenters, but it is handled different)"
	^ true! !

!SpMorphicComponentListAdapter methodsFor: 'initialization' stamp: ''!
addKeyBindingsTo: aWidget

	super addKeyBindingsTo: aWidget.
	self addContextMenuKeyBindings: aWidget.
	self addActivationKeyBindings: aWidget! !

!SpMorphicComponentListAdapter methodsFor: 'accessing' stamp: ''!
rows
	| tableContainer |

	tableContainer := self widget submorphs first.
	^ tableContainer submorphs! !

!SpMorphicComponentListAdapter methodsFor: 'factory' stamp: ''!
strongSelectionChanged: aFTStrongSelectionChanged
	
	self presenter activatesOnDoubleClick ifFalse: [ ^ self ]. 	
	self presenter doubleClickAtIndex: aFTStrongSelectionChanged selectedIndex! !

!SpMorphicComponentListAdapter methodsFor: 'factory' stamp: ''!
refreshWidgetSelection
	| rowIndexes |

	rowIndexes := self presenter selection selectedIndexes.
	rowIndexes = self widget selectedIndexes ifTrue: [ ^ self ].
	rowIndexes isEmpty
		ifTrue: [ self widget basicSelectIndexes: #() ]
		ifFalse: [ self widget basicSelectIndexes: rowIndexes ].
	self refreshList! !

!SpMorphicConfiguration commentStamp: ''!
!! Morphic configurations

Morphic configurations will prepare your application to run in a Morphic backend. Tipically, you will not change much of what is already provided on a Pharo system, but there are several entry points you may want to extend/override: 

- *method:SpMorphicConfiguration#styleSheet*!
!SpMorphicConfiguration methodsFor: 'styling' stamp: ''!
configure: anApplication

	super configure: anApplication.
	anApplication styleSheet: self styleSheet! !

!SpMorphicConfiguration methodsFor: 'styling' stamp: ''!
styleSheet
	"Define the default styleSheet to use in your application. You can override this and add your 
	 own application dependent styles (and you can compose them, see *SpStyle*).
	
	[[[language=Smalltalk
	^ SpStyle defaultStyleSheet copy
	]]]"
	
	^ styleSheet ifNil: [ styleSheet := SpStyle defaultStyleSheet copy ]! !

!SpMorphicContainerAdapter commentStamp: ''!
I am the adapter providing the correct container class: PanelMorph!
!SpMorphicContainerAdapter methodsFor: 'protocol' stamp: ''!
newVSplitterAt: aPosition
	
	self widgetDo: [ :w | w newVSplitterAt: aPosition ]! !

!SpMorphicContainerAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ PanelMorph new
		  changeProportionalLayout;
		  vResizing: #spaceFill;
		  hResizing: #spaceFill;
		  yourself! !

!SpMorphicContainerAdapter methodsFor: 'protocol' stamp: ''!
isRedrawable
	"This must be overriden in the adapter representing your container"
	
	^ true! !

!SpMorphicContainerAdapter methodsFor: 'protocol' stamp: ''!
checkSplitters
	
	self widgetDo: [ :w | w checkSplitters ]! !

!SpMorphicContainerAdapter methodsFor: 'protocol' stamp: ''!
newHSplitterAt: aPosition
	
	self widgetDo: [ :w | w newHSplitterAt: aPosition ]! !

!SpMorphicDialogWindowAdapter commentStamp: ''!
I am the adapter used to bridge a DialogWindowPresenter and a DialogWindow!
!SpMorphicDialogWindowAdapter methodsFor: 'factory' stamp: ''!
buildButtonBar

	| buttonBar |
	buttonBar := (SpButtonBarPresenter owner: self model) placeAtEnd.
	self model buttons do: [ :buttonPresenter | 
		buttonBar add: buttonPresenter ].

	^ buttonBar! !

!SpMorphicDialogWindowAdapter methodsFor: 'private' stamp: ''!
addPresenterIn: widgetToBuild withSpecLayout: aSpec
	"I replace the mainPanel (which contains contents and button bar) because like that I get the 
	 status bar at the end (where it belongs)"

	super addPresenterIn: widgetToBuild withSpecLayout: aSpec.
	self model buttons ifNotEmpty: [ 	
		widgetToBuild setToolbarFrom: [ self buildButtonBar ] ]! !

!SpMorphicDialogWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpDialogWindow new
		  model: self model;
		  in: [ :this | self subscribeToAnnouncements: this ];
		  yourself! !

!SpMorphicDiffAdapter commentStamp: ''!
I am an adpater to bridge a DiffPresenter and a DiffMorph!
!SpMorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
rightLabel: aText

	self widgetDo: [ :w | 
		w leftLabel: self leftLabel rightLabel: aText ]! !

!SpMorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
rightText: aText

	self widgetDo: [ :w | 
		w destTextModel setText: aText.
		w updateText ]! !

!SpMorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
beWrapped

	^ self model beWrapped! !

!SpMorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
showBoth

	self widgetDo: [ :w | w showBoth ]! !

!SpMorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
rightLabel

	^ self model rightLabel! !

!SpMorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
contextClass

	^ self model contextClass! !

!SpMorphicDiffAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ DiffMorph new
		  on: self;
		  from: self leftText
		  to: self rightText
		  contextClass: self contextClass;
		  hResizing: #spaceFill;
		  vResizing: #spaceFill;
		  setBalloonText: self help;
		  showOptions: self showOptions;
		  leftLabel: self leftLabel rightLabel: self rightLabel;
		  showOnlyDestination: self showOnlyDestination;
		  yourself! !

!SpMorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
leftLabel

	^ self model leftLabel! !

!SpMorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
leftLabel: aText

	self widgetDo: [ :w | 
		w leftLabel: aText rightLabel: self rightLabel ]! !

!SpMorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
showOptions

	^ self model showOptions! !

!SpMorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
showOptions: aBoolean

	self widgetDo: [ :w | w showOptions: aBoolean ]! !

!SpMorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
beWrapped: aBoolean

	self widgetDo: [ :w | w beWrapped: aBoolean ]! !

!SpMorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
showOnlyDestination: aBoolean

	self widgetDo: [ :w | w showOnlyDestination: aBoolean ]! !

!SpMorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
showOnlyDestination

	^ self model showOnlyDestination! !

!SpMorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
showOnlySource

	^ self model showOnlySource! !

!SpMorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
leftText

	^ self model leftText! !

!SpMorphicDiffAdapter methodsFor: 'widget API' stamp: ''!
rightText

	^ self model rightText! !

!SpMorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
showOnlySource: aBoolean

	self widgetDo: [ :w | w showOnlySource: aBoolean ]! !

!SpMorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
leftText: aText

	self widgetDo: [ :w | 
		w sourceTextModel setText: aText.
		w updateText ]! !

!SpMorphicDiffAdapter methodsFor: 'spec protocol' stamp: ''!
contextClass: aClass

	self widgetDo: [ :w | 
		w
			contextClass: aClass;
			updateText ]! !

!SpMorphicDropListAdapter commentStamp: ''!
I am the adapter used to bridget a DropListPresenter and a DropListMorph!
!SpMorphicDropListAdapter methodsFor: 'widget API' stamp: ''!
wrapItem: anItem index: anIndex

	| result |
	result := self model displayForItem: anItem.
	^ result asString! !

!SpMorphicDropListAdapter methodsFor: 'accessing' stamp: ''!
elementAt: index
	
	^ self presenter getList at: index! !

!SpMorphicDropListAdapter methodsFor: 'accessing' stamp: ''!
selectIndex: anInteger 
	
	self widget listSelectionIndex: anInteger! !

!SpMorphicDropListAdapter methodsFor: 'widget API' stamp: ''!
getIndex

	^ self model getIndex! !

!SpMorphicDropListAdapter methodsFor: 'widget API' stamp: ''!
setIndex: anIndex

	^ self model selectIndex: anIndex! !

!SpMorphicDropListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	self model model whenChangedDo: [ 
		self changed: #getList.
		self changed: #getIndex ].
	self model selection whenChangedDo: [ self changed: #getIndex ].

	^ SpDropListMorph new
		  wrapSelector: #wrap:withIndex:;
		  on: self
		  list: #getList
		  selected: #getIndex
		  changeSelected: #setIndex:;
		  hResizing: #spaceFill;
		  vResizing: #spaceFill;
		  dragEnabled: self dragEnabled;
		  dropEnabled: self dropEnabled;
		  enabled: self enabled;
		  setBalloonText: self help;
		  yourself! !

!SpMorphicDropListAdapter methodsFor: 'icons' stamp: ''!
getIconFor: aDropListItem 
	
	^ self model getIconFor: aDropListItem! !

!SpMorphicDropListAdapter methodsFor: 'accessing' stamp: ''!
selectedIndexes

	| selectedIndex |
	selectedIndex := self widget getCurrentSelectionIndex.
	^ selectedIndex = 0
		  ifTrue: [ #(  ) ]
		  ifFalse: [ { selectedIndex } ]! !

!SpMorphicDropListAdapter methodsFor: 'accessing' stamp: ''!
displayedIcon
	
	self model hasIcons ifFalse: [^ nil].
	^ self widget currentIcon! !

!SpMorphicDropListAdapter methodsFor: 'widget API' stamp: ''!
getList

	^ self model getList! !

!SpMorphicGridAdapter commentStamp: ''!
I'm an adapter for Grid Layouts.
A grid layout will arrange components according to its coordinates and span information.!
!SpMorphicGridAdapter methodsFor: 'private' stamp: ''!
applyChildrenAlignmentTo: aWidget constraints: constraints

	constraints hasAlignment 
		ifTrue: [ ^ self basicApplyChildrenAlignmentTo: aWidget constraints: constraints ].
	(layout columnConstraintsAt: constraints column) ifNotNil: [ :axisConstraints |
		axisConstraints hasAlignment 
			ifTrue: [ ^ self basicApplyChildrenAlignmentTo: aWidget constraints: axisConstraints ] ].
	(layout rowConstraintsAt: constraints row) ifNotNil: [ :axisConstraints |
		axisConstraints hasAlignment 
			ifTrue: [ ^ self basicApplyChildrenAlignmentTo: aWidget constraints: axisConstraints ] ].

	^ aWidget! !

!SpMorphicGridAdapter methodsFor: 'factory' stamp: ''!
layout: aLayout
	"Build of widget was differed up to here (to know what is the direction)"

	layout := aLayout.

	widget ifNil: [ 
		widget := self newPanel.
		widget layoutPolicy layout: aLayout ].
	
	aLayout whenChildrenAddedDo: [ :ann |
		self
			add: ann child
			constraints: (aLayout constraintsFor: ann child) ].
	
	aLayout whenChildrenRemovedDo: [ :ann |
		self remove: ann child ].

	super layout: aLayout! !

!SpMorphicGridAdapter methodsFor: 'factory' stamp: ''!
newPanel

	^ super newPanel
		layoutPolicy: SpMorphicGridLayout new;
		yourself! !

!SpMorphicGridAdapter methodsFor: 'private' stamp: ''!
addConstraints: constraints toChild: childMorph
	"Adds constraits by child"
	
	childMorph hResizing: #spaceFill.
	childMorph vResizing: #spaceFill.
	childMorph 
		setProperty: #gridConstraints 
		toValue: constraints.
	
	^ childMorph! !

!SpMorphicGridAdapter methodsFor: 'accessing' stamp: ''!
children
	
	^ widget submorphs! !

!SpMorphicGridAdapter methodsFor: 'private' stamp: ''!
basicApplyChildrenAlignmentTo: aWidget constraints: constraints

	| alignmentWidget |	
	constraints hasAlignment ifFalse: [ ^ aWidget ].
	
	aWidget 
		changeTableLayout;
		hResizing: #shrinkWrap; 
		vResizing: #shrinkWrap.
	
	alignmentWidget := Morph new
		changeTableLayout; 
		color: Color transparent;
		addMorphBack: aWidget.

	constraints vAlign ifNotNil: [ :align |
		alignmentWidget listCentering: align asMorphicAlign ].
	constraints hAlign ifNotNil: [ :align |
		alignmentWidget wrapCentering: align asMorphicAlign ].
		
	^ alignmentWidget! !

!SpMorphicGridAdapter methodsFor: 'private' stamp: ''!
basicAdd: aPresenter constraints: constraints to: aPanel
	| childMorph |

	childMorph := self 
		buildMorph: aPresenter 
		constraints: constraints.
	
	aPanel addMorphBack: childMorph.
		
	^ childMorph	! !

!SpMorphicGridAdapter methodsFor: 'removing' stamp: ''!
remove: aPresenter

	| morph |
	morph := aPresenter adapter widget.
	widget removeMorph: morph! !

!SpMorphicGridLayout commentStamp: ''!
I'm a grid layout.
I can arrange submorphs in a grid according to its properties (position and span, see GrisLayoutProperties), and according certain layout properties: 

- columnHomogeneous -> weather a columns will have same size.
- rowHomogeneous -> weather a row will have same size. 
- padding -> the padding to start drawing cells
- colSpacing -> the column space between cells
- rowSpacing -> the row space between cells

WARNING: I'm designed to work for Spec. While any other morph could benefit from this layout, tipic properties of morphic (like vResizing and hResizing) can not behave as expected. !
!SpMorphicGridLayout methodsFor: 'private' stamp: ''!
layoutMorph: aMorph staringAt: originPoint withComputation: computation
	| constraints pos extent |
	
	constraints := aMorph valueOfProperty: #gridConstraints.
	pos := originPoint + (computation positionAt: constraints position).

	aMorph vResizing: (self resizingSyle: self isRowHomogeneous).
	aMorph hResizing: (self resizingSyle: self isColumnHomogeneous).
	
	(layout rowConstraintsAt: constraints position y) ifNotNil: [ :c |
		c expand ifNotNil: [ :expand | aMorph vResizing: (self resizingSyle: expand) ] ].
		
	(layout columnConstraintsAt: constraints position x) ifNotNil: [ :c |
		c expand ifNotNil: [ :expand | aMorph hResizing: (self resizingSyle: expand) ] ].

	"if widget is resizable, it will take all the available space. 
	 if widget is not resizable, we need to take into account its alignment constraint, since it 
	 can be placed differently."
	extent := (aMorph hResizing = #spaceFill and: [ aMorph vResizing = #spaceFill ])
		ifTrue: [ computation cellExtentAt: constraints position ]
		ifFalse: [ self calculateExtentFor: aMorph constraint: constraints computation: computation ].
	
	aMorph bounds: (pos extent: extent)! !

!SpMorphicGridLayout methodsFor: 'layout' stamp: ''!
layout: aMorph in: aRect

	calculating ifTrue: [ ^ self ].
	[
		calculating := true. 
		self basicLayout: aMorph in: aRect ]
	ensure: [
		calculating := false ]! !

!SpMorphicGridLayout methodsFor: 'private' stamp: ''!
calculateWidthFor: aMorph base: aNumber

	^ aNumber! !

!SpMorphicGridLayout methodsFor: 'accessing' stamp: ''!
layout
	^ layout! !

!SpMorphicGridLayout methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	calculating := false! !

!SpMorphicGridLayout methodsFor: 'accessing' stamp: ''!
layout: aGridLayout

	layout := aGridLayout! !

!SpMorphicGridLayout methodsFor: 'testing' stamp: ''!
isColumnHomogeneous

	^ self layout isColumnHomogeneous! !

!SpMorphicGridLayout methodsFor: 'layout' stamp: ''!
basicLayout: aMorph in: aRect
	| computation morphs innerBounds origin |
	
	morphs := aMorph submorphs.
	innerBounds := aRect insetBy: self padding.
	computation := (SpMorphicGridLayoutComputation layout: self)
		computeMorphs: morphs 
		bounds: innerBounds.
	
	"Now calculate the bounds for each widget"
	origin := innerBounds origin.
	morphs do: [ :each | 
		self 
			layoutMorph: each 
			staringAt: origin 
			withComputation: computation ].

	"aMorph bounds: ((origin - self padding) corner: (computation extent + self padding))"! !

!SpMorphicGridLayout methodsFor: 'private' stamp: ''!
calculateExtentFor: aMorph constraint: constraint computation: computation
	| cellExtent height width |

	cellExtent := computation cellExtentAt: constraint position.
	width := self calculateWidthFor: aMorph base: cellExtent x.
	height := self calculateHeightFor: aMorph base: cellExtent y.
		
	^ width @ height! !

!SpMorphicGridLayout methodsFor: 'accessing' stamp: ''!
columnSpacing

	^ self layout columnSpacing! !

!SpMorphicGridLayout methodsFor: 'testing' stamp: ''!
isRowHomogeneous

	^ self layout isRowHomogeneous! !

!SpMorphicGridLayout methodsFor: 'private' stamp: ''!
resizingSyle: expand
	
	^ expand 
		ifTrue: [ #spaceFill ]
		ifFalse: [ #rigid ]! !

!SpMorphicGridLayout methodsFor: 'private' stamp: ''!
calculateHeightFor: aMorph base: aNumber

	^ aNumber! !

!SpMorphicGridLayout methodsFor: 'accessing' stamp: ''!
padding

	^ self layout borderWidth! !

!SpMorphicGridLayout methodsFor: 'accessing' stamp: ''!
columnConstraintsAt: aNumber
 
	^ layout columnConstraintsAt: aNumber! !

!SpMorphicGridLayout methodsFor: 'accessing' stamp: ''!
rowSpacing

	^ self layout rowSpacing! !

!SpMorphicGridLayoutComputation commentStamp: ''!
I'm a computation to apply to a morph with GridLayout policy. 
Computation happens easily: 

- Computates number of columns and row
- Computates widths and heights (taking into account different element contraints)

check computeMorphs:bounds: to have a better idea :)!
!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
isColumnExpandable: colNumber

	^ (layout columnConstraintsAt: colNumber)
		ifNotNil: [ :c | c isExpand ]
		ifNil: [ false ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
numColumns

	^ numColumns! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
rowHeights

	^ rowHeights! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
allGridConstraints

	^ morphs collect: [ :each | 
		each 
			valueOfProperty: #gridConstraints
			ifAbsent: [ self error: 'Constraints not defined for ', each asString ] ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
cellExtents

	^ cellExtents! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
columnPositions

	^ columnPositions! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
baseRowHeight

	^ (bounds height / numRows) asInteger! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
calculateNotHomogeneousRowHeights
	"Column heights are 
	 - the max height of cells of that row
	"
	| newRowHeights |	

	newRowHeights := Array new: numRows withAll: 0.
	"skip spanned rows (otherwise row will take an spanned row)"
	morphs 
		select: [ :each | (each valueOfProperty: #gridConstraints) rowSpan = 1 ]
		thenDo: [ :each | | row |
			row := (each valueOfProperty: #gridConstraints) row.
			newRowHeights 
				at: row 
				put: ((newRowHeights at: row) max: (self heightOf: each)) ].
		
	^ newRowHeights! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
baseColumnWidth

	^ (bounds width / numColumns) asInteger! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
numRows

	^ numRows! !

!SpMorphicGridLayoutComputation methodsFor: 'accessing' stamp: ''!
positionAt: aPoint

	^ (self columnPositions at: aPoint x) @ (self rowPositions at: aPoint y) ! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
minWidthOf: aMorph 
	| minWidth |

	minWidth := (self geometryPropertyOf: aMorph) ifNotNil: [ :geometry | geometry minWidth ]. 
	^ minWidth ifNil: [ 0 ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
rowPositions

	^ rowPositions! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
computeCellExtents
	"Calculate cell extents"

	cellExtents := SmallDictionary new.
	self allGridConstraints do: [ :constraint | | width height |
		width := (columnWidths 
			copyFrom: constraint column 
			to: constraint column + constraint columnSpan - 1) 
			sum.
		height := (rowHeights 
			copyFrom: constraint row 
			to: constraint row + constraint rowSpan - 1) 
			sum.
		cellExtents 
			at: constraint position 
			put: width@height ]! !

!SpMorphicGridLayoutComputation methodsFor: 'accessing' stamp: ''!
cellExtentAt: aPoint

	^ self cellExtents at: aPoint! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
calculateRowHeights

	^ layout isRowHomogeneous
		  ifTrue: [ self calculateHomogeneousRowHeights ]
		  ifFalse: [ self calculateNotHomogeneousRowHeights ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
columnWidths

	^ columnWidths! !

!SpMorphicGridLayoutComputation methodsFor: 'accessing' stamp: ''!
layout

	^ layout! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
computeNumberOfRowsAndColumns
	
	numRows := 0.
	numColumns := 0.
	self allGridConstraints do: [ :each |
		numRows := numRows max: (each row + each rowSpan - 1).
		numColumns := numColumns max: (each column + each columnSpan - 1) ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
minHeightOf: aMorph 
	| minHeight |

	minHeight := (self geometryPropertyOf: aMorph) ifNotNil: [ :geometry | geometry minHeight ]. 
	^ minHeight ifNil: [ 0 ]! !

!SpMorphicGridLayoutComputation methodsFor: 'computation' stamp: ''!
computeMorphs: anArray bounds: aRect

	morphs := anArray.
	bounds := aRect.

	self
		computeNumberOfRowsAndColumns;
		computeWidgetSizes;
		computeRowPositions;
		computeColumnPositions;
		computeCellExtents! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
calculateHomogeneousColumnWidths
	"Columns are homogeneous. 
	 - width will be bounds width/numColumns UNLESS there is a column with a min width bigger 
	   than that number.
	 - if min width > bounds width/numColumns, then all columns becomw width = min width (to 
		make them homogeneous)"
	| columnWidth |	

	columnWidth := 0.
	morphs do: [ :each | 
		columnWidth := columnWidth max: (self minWidthOf: each) ].
	
	^ Array new: numColumns withAll: (self baseColumnWidth max: columnWidth)! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
calculateNotHomogeneousColumnWidths
	"Column widths are 
	 - the max width of cells of that column. EXCEPT if
	 - the column is expandable, in which case, they will receive the remaining width 
	   after assigning the others (a minimum if there is no remaining place)"
	| newColumnWidths expandables |

	newColumnWidths := Array new: numColumns withAll: 0.
	
	"Assign non expandable values, 
	 skip spanned columns (otherwise column will take an spanned width)"
	morphs 
		select: [ :each | (each valueOfProperty: #gridConstraints) columnSpan = 1 ]
		thenDo: [ :each | | column |
			column := (each valueOfProperty: #gridConstraints) column.
			(self isColumnExpandable: column) ifFalse: [ 
				newColumnWidths 
					at: column
					put: ((newColumnWidths at: column) max: (self widthOf: each))] ].
		
	"now I count the zeroes, if there are remaining means we need to assign the remaining 
	 width (divided between the remaining)"
	expandables := newColumnWidths count: [ :each | each isZero ].
	expandables > 0 ifTrue: [ | width accumulatedWidth |
		accumulatedWidth := (newColumnWidths reject: [ :each | each isZero ]) 
			ifNotEmpty: [ :nonZeroWidths | nonZeroWidths sum ]
			ifEmpty: [ 0 ]. 
		width := ((bounds width - accumulatedWidth) / expandables) asInteger.
		newColumnWidths := newColumnWidths collect: [ :each | 
			each = 0 
				ifTrue: [ width ]
				ifFalse: [ each ] ] ].
		
	^ newColumnWidths! !

!SpMorphicGridLayoutComputation methodsFor: 'accessing' stamp: ''!
extent 

	^ self columnWidths sum @ self rowHeights sum! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
heightOf: aMorph 
	| height |

	
	height := (self geometryPropertyOf: aMorph) ifNotNil: [ :geometry | geometry height ].
	^ (height isNil or: [ height = 0 ])
		ifTrue: [ aMorph height ]
		ifFalse: [ height ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
styleOf: aMorph 

	^ aMorph 
		valueOfProperty: #style
		ifAbsent: [ SpMorphStyle newStyles: #() ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
calculateColumnWidths

	^ layout isColumnHomogeneous
		  ifTrue: [ self calculateHomogeneousColumnWidths ]
		  ifFalse: [ self calculateNotHomogeneousColumnWidths ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
computeRowPositions
	"Calculate row positions"

	rowPositions := Array new: numRows.	
	rowPositions at: 1 put: 0.
	2 to: numRows do: [ :index | 
		rowPositions 
			at: index 
			put: (rowPositions at: index - 1) + (rowHeights at: index - 1) + self layout rowSpacing ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
geometryPropertyOf: aMorph 
		
	^ (self styleOf: aMorph) mergedProperties
		detect: [ :each | each class = SpGeometryStyle ]
		ifNone: [ nil ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
calculateHomogeneousRowHeights
	"Rows are homogeneous. 
	 - height will be bounds height/numRows UNLESS there is a row with a min height bigger 
	   than that number
	 - if min height > bounds height/numRows, then all rows become height = min height (to 
		make them homogeneous)"
	| rowHeight |

	rowHeight := 0.
	morphs do: [ :each | 
		rowHeight := rowHeight max: (self minHeightOf: each) ].
	
	^ Array new: numRows withAll: (self baseRowHeight max: rowHeight)! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
isRowExpandable: rowNumber

	^ (layout rowConstraintsAt: rowNumber)
		  ifNotNil: [ :c | c isExpand ]
		  ifNil: [ false ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private' stamp: ''!
widthOf: aMorph 
	| width |

	width := (self geometryPropertyOf: aMorph) ifNotNil: [ :geometry | geometry width ].
	^ (width isNil or: [ width = 0 ])
		ifTrue: [ aMorph width ]
		ifFalse: [ width ]! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
computeWidgetSizes
	"Collect actual widget sizes"

	rowHeights := self calculateRowHeights.
	columnWidths := self calculateColumnWidths! !

!SpMorphicGridLayoutComputation methodsFor: 'initialization' stamp: ''!
initializeLayout: aLayout

	self initialize.
	layout := aLayout! !

!SpMorphicGridLayoutComputation methodsFor: 'private - computation' stamp: ''!
computeColumnPositions
	"Calculate columns positions"
	
	columnPositions := Array new: numColumns.
	columnPositions at: 1 put: 0.
	2 to: numColumns do: [ :index |
		columnPositions 
			at: index 
			put: (columnPositions at: index - 1) + (columnWidths at: index - 1) + self layout columnSpacing ]! !

!SpMorphicGridLayoutComputation class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Use #morphs:bounds:'! !

!SpMorphicGridLayoutComputation class methodsFor: 'instance creation' stamp: ''!
layout: aLayout

	^ self basicNew 
		initializeLayout: aLayout;
		yourself ! !

!SpMorphicGridLayoutTest methodsFor: 'running' stamp: ''!
setUp
	
	super setUp.
	label1 := Morph new.
	morph1 := Morph new.
	label2 := Morph new.
	morph2 := Morph new.
	
	panel := Morph new
		extent: 100@100;
		yourself.
		
	{ label1. morph1. label2. morph2 } do: [ :each |
		panel addMorphBack: each.
		self style applyTo: each ]! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testRowSpacing
	"
	-----------
	| 50 | 50 |
	-----------
	| 5  | 5  |
	-----------
	| 50 | 50 |
	-----------
	"
	| layout |
	
	self place: label1 at: 1@1.
	self place: morph1 at: 2@1.
	self place: label2 at: 1@2.
	self place: morph2 at: 2@2.
	
	(layout := self newLayout) layout rowSpacing: 5.
	layout layout: panel in: (0@0 corner: 100@100).
	
	self assert: label1 bounds equals: (0@0 corner: 50@20).
	self assert: morph1 bounds equals: (50@0 corner: 100@20).
	self assert: label2 bounds equals: (0@25 corner: 50@45).
	self assert: morph2 bounds equals: (50@25 corner: 100@45)! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testSpanRow
	"Each element in a different row and column
	
	--------------------
	| 50  |      |     | 
	-------  50  -------
	| 50  |      | 50  | 
	--------------------
	"
	| layout |
	
	self place: label1 at: 1@1.
	self place: morph1 at: 2@1 span: 1@2.
	self place: label2 at: 1@2.
	self place: morph2 at: 3@2.
	
	layout := self newLayout.
	layout layout: panel in: (0@0 corner: 100@100).
	
	self assert: label1 bounds equals: (0@0 corner: 50@20).
	self assert: morph1 bounds equals: (50@0 corner: 100@40).	
	self assert: label2 bounds equals: (0@20 corner: 50@40).
	self assert: morph2 bounds equals: (100@20 corner: 150@40)! !

!SpMorphicGridLayoutTest methodsFor: 'accessing' stamp: ''!
style 

	^ self styleExtent: 50@20! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testColumnNotHomogeneousDiferentRowsAndColumns
	"Each element in a different row and column
	
	-------------------------
	| 30  |     |     |     |
	-------------------------
	|     | 40  |     |     |
	-------------------------
	|     |     | 50  |     |
	-------------------------
	|     |     |     | 60  |
	-------------------------	
	"
	| layout |
	
	self place: label1 at: 1@1.
	self place: morph1 at: 2@2.
	self place: label2 at: 3@3.
	self place: morph2 at: 4@4.
	
	layout := self newLayout.
	layout layout beColumnNotHomogeneous.
	"make columns differ, to make each column different"
	(self styleExtent: 30@20) applyTo: label1.
	(self styleExtent: 40@20) applyTo: morph1.
	(self styleExtent: 50@20) applyTo: label2.
	(self styleExtent: 60@20) applyTo: morph2.
	
	layout layout: panel in: (0@0 corner: 100@100).
	
	self assert: label1 bounds equals: (0@0 corner: 30@20).
	self assert: morph1 bounds equals: (30@20 corner: 70@40).	
	self assert: label2 bounds equals: (70@40 corner: 120@60).
	self assert: morph2 bounds equals: (120@60 corner: 180@80)
! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testColumnHomogeneousDiferentRowsAndColumns
	"Each element in a different row and column
	
	-------------------------
	| 100 |     |     |     |
	-------------------------
	|     | 100 |     |     |
	-------------------------
	|     |     | 100 |     |
	-------------------------
	|     |     |     | 100 |
	-------------------------	
	"
	| layout |
	
	self place: label1 at: 1@1.
	self place: morph1 at: 2@2.
	self place: label2 at: 3@3.
	self place: morph2 at: 4@4.
			
	layout := self newLayout.
	layout layout beColumnHomogeneous.
	"make one column width to 100 (it should force all columns to 100, instead 25)"
	(self styleMinExtent: 100@20) applyTo: label2.
	
	layout layout: panel in: (0@0 corner: 100@100).
	
	self assert: label1 bounds equals: (0@0 corner: 100@20).
	self assert: morph1 bounds equals: (100@20 corner: 200@40).	
	self assert: label2 bounds equals: (200@40 corner: 300@60).
	self assert: morph2 bounds equals: (300@60 corner: 400@80)
! !

!SpMorphicGridLayoutTest methodsFor: 'accessing' stamp: ''!
place: aMorph at: aPoint span: spanPoint

	aMorph 
		setProperty: #gridConstraints 
		toValue: (SpGridConstraints at: aPoint span: spanPoint)! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testBasicLayout
	"
	-----------
	| 50 | 50 |
	-----------
	| 50 | 50 |
	-----------
	"
	| layout |
	
	self place: label1 at: 1@1.
	self place: morph1 at: 2@1.
	self place: label2 at: 1@2.
	self place: morph2 at: 2@2.
	
	layout := self newLayout.
	layout layout: panel in: (0@0 corner: 100@100).
	
	self assert: label1 bounds equals: (0@0 corner: 50@20).
	self assert: morph1 bounds equals: (50@0 corner: 100@20).
	self assert: label2 bounds equals: (0@20 corner: 50@40).
	self assert: morph2 bounds equals: (50@20 corner: 100@40)! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testColumnNotHomogeneousPairedRowsAndColumns
	"Paired elements in rows and columns
	
	-----------
	| 50 | 60 |
	-----------
	| 50 | 60 |
	-----------
	
	"
	| layout |
	
	self place: label1 at: 1@1.
	self place: morph1 at: 2@1.
	self place: label2 at: 1@2.
	self place: morph2 at: 2@2.
	
	layout := self newLayout.
	layout layout beColumnNotHomogeneous.
	"make columns differ, to make each column different"
	(self styleExtent: 30@20) applyTo: label1.
	(self styleExtent: 50@20) applyTo: morph1.
	(self styleExtent: 40@20) applyTo: label2.
	(self styleExtent: 60@20) applyTo: morph2.
	
	layout layout: panel in: (0@0 corner: 100@100).
	
	self assert: label1 bounds equals: (0@0 corner: 40@20).
	self assert: morph1 bounds equals: (40@0 corner: 100@20).	
	self assert: label2 bounds equals: (0@20 corner: 40@40).
	self assert: morph2 bounds equals: (40@20 corner: 100@40)
! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testColumnSpacing
	"
	---------------
	| 50 | 5 | 50 |
	---------------
	| 50 | 5 | 50 |
	---------------
	"
	| layout |
	
	self place: label1 at: 1@1.
	self place: morph1 at: 2@1.
	self place: label2 at: 1@2.
	self place: morph2 at: 2@2.
	
	(layout := self newLayout) layout columnSpacing: 5.
	layout layout: panel in: (0@0 corner: 100@100).
	
	self assert: label1 bounds equals: (0@0 corner: 50@20).
	self assert: morph1 bounds equals: (55@0 corner: 105@20).
	self assert: label2 bounds equals: (0@20 corner: 50@40).
	self assert: morph2 bounds equals: (55@20 corner: 105@40)! !

!SpMorphicGridLayoutTest methodsFor: 'accessing' stamp: ''!
styleExtent: aPoint
	| rootStyle |

	rootStyle := (SpStyleSTONReader fromString: ('
.application [ 
	Geometry \{ 
		#width: {1}, 
		#height: {2}, 
		#hResizing: false, 
		#vResizing: false \} ]'
	format: { aPoint x. aPoint y })).
	
	^ SpMorphStyle newStyles: rootStyle flattenClasses! !

!SpMorphicGridLayoutTest methodsFor: 'accessing' stamp: ''!
newLayout
	
	^ SpMorphicGridLayout new
		layout: (SpGridLayout new
			borderWidth: 0;
			columnSpacing: 0;
			rowSpacing: 0;
			columnHomogeneous: false;
			rowHomogeneous: false;
			yourself);
		yourself! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testBorderWidthNotHomogeneous
	"
	+---+----+----+
	| 5 | 5  | 5  |
	+---+----+----+
	| 5 | 50 | 50 |
	+---+----+----+
	| 5 | 50 | 50 | 
	+---+----+----+
	"
	| layout |
	
	self place: label1 at: 1@1.
	self place: morph1 at: 2@1.
	self place: label2 at: 1@2.
	self place: morph2 at: 2@2.
	
	(layout := self newLayout) layout
		beRowNotHomogeneous; 
		beColumnNotHomogeneous;
		borderWidth: 5.
	layout layout: panel in: (0@0 corner: 100@100).
	
	self assert: label1 bounds equals: (5@5 corner: 55@25).
	self assert: morph1 bounds equals: (55@5 corner: 105@25).
	self assert: label2 bounds equals: (5@25 corner: 55@45).
	self assert: morph2 bounds equals: (55@25 corner: 105@45)! !

!SpMorphicGridLayoutTest methodsFor: 'accessing' stamp: ''!
styleMinExtent: aPoint
	| rootStyle |

	rootStyle := (SpStyleSTONReader fromString: ('
.application [ Geometry \{ #minWidth: {1}, #minHeight: {2} \} ]'
	format: { aPoint x. aPoint y })).
	
	^ SpMorphStyle newStyles: rootStyle flattenClasses! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testLayoutIn
	"This is a meta-test that tries all the others (just to have access to all tests while seeing 
	 the class. Yes, I know that means all tests are executed twice in CI, but they are fast :)"

	(self class localSelectors 
		reject: [ :each | each = #testLayoutIn ])
		select: [ :each | each beginsWith: 'test' ]
		thenDo: [ :each |
			self setUp.
			self perform: each.
			self tearDown ]! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testBorderWidthHomogeneous
	"
	+---+----+----+---+
	| 5 | 5  | 5  | 5 |
	+---+----+----+---+
	| 5 | 45 | 45 | 5 |
	+---+----+----+---+
	| 5 | 45 | 45 | 5 |
	+---+----+----+---+
	| 5 | 5  | 5  | 5 |
	+---+----+----+---+
	"
	| layout |
	
	self place: label1 at: 1@1.
	self place: morph1 at: 2@1.
	self place: label2 at: 1@2.
	self place: morph2 at: 2@2.
	
	(layout := self newLayout) layout 
		beColumnHomogeneous;
		beRowHomogeneous;
		borderWidth: 5.
	layout layout: panel in: (0@0 corner: 100@100).
	
	self assert: label1 bounds equals: (5@5 corner: 50@50).
	self assert: morph1 bounds equals: (50@5 corner: 95@50).
	self assert: label2 bounds equals: (5@50 corner: 50@95).
	self assert: morph2 bounds equals: (50@50 corner: 95@95)! !

!SpMorphicGridLayoutTest methodsFor: 'tests' stamp: ''!
testSpanColumn
	"Each element in a different row and column
	
	--------------------
	| 50  |  50  | 50  | 
	--------------------
	|     |        100 | 
	--------------------
	"
	| layout |
	
	self place: label1 at: 1@1.
	self place: morph1 at: 2@1.
	self place: label2 at: 3@1.
	self place: morph2 at: 2@2 span: 2@1.
	
	layout := self newLayout.
	layout layout: panel in: (0@0 corner: 100@100).
	
	self assert: label1 bounds equals: (0@0 corner: 50@20).
	self assert: morph1 bounds equals: (50@0 corner: 100@20).	
	self assert: label2 bounds equals: (100@0 corner: 150@20).
	self assert: morph2 bounds equals: (50@20 corner: 150@40)
! !

!SpMorphicGridLayoutTest methodsFor: 'accessing' stamp: ''!
place: aMorph at: aPoint 

	aMorph 
		setProperty: #gridConstraints 
		toValue: (SpGridConstraints at: aPoint)! !

!SpMorphicImageAdapter commentStamp: ''!
I am the bridge between an ImagePresenter and a AlphaImageMorph!
!SpMorphicImageAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	| alphaImage |
	alphaImage := AlphaImageMorph new.
	alphaImage model: self.
	alphaImage
		getImageSelector: #getImage;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		layout: self layoutValue;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		setBalloonText: self help;
		update: #getImage.

	self model
		whenImageChangeDo: [ alphaImage image: (self getImage ifNil: [ Form extent: 1 @ 1 depth: 32 ]) ];
		whenAutoScaleChangeDo: [ widget layout: self layoutValue ].

	^ alphaImage! !

!SpMorphicImageAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
hasImageAutoscaled
	^ self widget layout = #scaledAspect! !

!SpMorphicImageAdapter methodsFor: 'accessing' stamp: ''!
image
	
	^ widget scaledImage! !

!SpMorphicImageAdapter methodsFor: 'private' stamp: ''!
click

	^ self model action value! !

!SpMorphicImageAdapter methodsFor: 'widget protocol' stamp: ''!
getImage

	^ self model image! !

!SpMorphicImageAdapter methodsFor: 'widget protocol' stamp: ''!
layoutValue

	^ self model autoScale
		  ifTrue: [ #scaledAspect ]
		  ifFalse: [ #center ]! !

!SpMorphicImageAdapter methodsFor: 'widget protocol' stamp: ''!
switchAutoscale

	self widgetDo: [ :w | w layout: self layoutValue ]! !

!SpMorphicLabelAdapter commentStamp: ''!
I am the adapter used to bridget a LabelPresenter and a LabelMorph!
!SpMorphicLabelAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	| label |
	label := LabelMorph new model: self.
	label
		getEnabledSelector: #enabled;
		getTextSelector: #getText;
		vResizing: #shrinkWrap;
		hResizing: #spaceFill;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		setBalloonText: self getHelpText;
		setProperty: #minWidth toValue: 3. "3 is the default value of StringMorph. We do not want the default value of LabelMorph that is the min width of the content..."

	^ label! !

!SpMorphicLabelAdapter methodsFor: 'styling' stamp: ''!
applyStyle: aMorph

	aMorph fitContents.
	super applyStyle: aMorph! !

!SpMorphicLabelAdapter methodsFor: 'private' stamp: ''!
getHelpText

	^ self presenter help ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicLabelAdapter methodsFor: 'model access' stamp: ''!
getText

	^self presenter label ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicLabelAdapter methodsFor: 'accessing' stamp: ''!
label
	
	^ widget contents! !

!SpMorphicLayoutAdapter commentStamp: ''!
I'm a base adapter for layouts.!
!SpMorphicLayoutAdapter methodsFor: 'testing' stamp: ''!
isEmpty

	^ self children isEmpty! !

!SpMorphicLayoutAdapter methodsFor: 'styling' stamp: ''!
applyStyle: aPresenter to: aMorph
	self flag: #TODO. "This is a HACK, to apply styles just when I'm using new layouts 
	(otherwise, it interferes on how the old layout is displayed). 
	 Of course, this needs to be applied where it belongs, but for now we need to keep 
	 it this way :("
	
	aPresenter adapter ifNil: [ ^ self ].
	aPresenter adapter applyStyle: aMorph! !

!SpMorphicLayoutAdapter methodsFor: 'private' stamp: ''!
applyChildrenAlignmentTo: childMorph constraints: constraints
	"When it applies (like the case of SpGridLayout), widgets may want to configure alignment 
	 here."
	
	^ childMorph! !

!SpMorphicLayoutAdapter methodsFor: 'accessing' stamp: ''!
adapter
	
	^ nil! !

!SpMorphicLayoutAdapter methodsFor: 'accessing' stamp: ''!
layout

	^ layout! !

!SpMorphicLayoutAdapter methodsFor: 'protocol' stamp: ''!
layout: aLayout

	"Basic apply visibility to the widget.
	This call is here because layouts and widgets work differently"
	self widget presenter: self presenter.
	self applyVisibility.
	self applyStyle.
	self addKeyBindingsTo: self widget.
	self addEventsTo: self widget.! !

!SpMorphicLayoutAdapter methodsFor: 'private' stamp: ''!
addConstraints: constraints toChild: childMorph

	self subclassResponsibility! !

!SpMorphicLayoutAdapter methodsFor: 'factory' stamp: ''!
newPanel

	^ self newPanelWith: TableLayout new! !

!SpMorphicLayoutAdapter methodsFor: 'building' stamp: ''!
buildWidget

	^ nil! !

!SpMorphicLayoutAdapter methodsFor: 'testing' stamp: ''!
isSpLayout

	^ true! !

!SpMorphicLayoutAdapter methodsFor: 'accessing' stamp: ''!
children

	^ self subclassResponsibility! !

!SpMorphicLayoutAdapter methodsFor: 'factory' stamp: ''!
newPanelWith: aLayout 

	^ Morph new
	  layoutPolicy: aLayout;
	  hResizing: #spaceFill;
	  vResizing: #spaceFill;
	  color: Color transparent;
	  borderColor: Color transparent;
	  clipSubmorphs: true;
	  "stop being grabbed"beSticky;
	  borderWidth: 0;
	  extent: 0 @ 0;
	  yourself! !

!SpMorphicLayoutAdapter methodsFor: 'protocol' stamp: ''!
takeKeyboardFocus

	self presenter presentersInFocusOrder 
		ifNotEmpty: [ :presenters | presenters first takeKeyboardFocus ]! !

!SpMorphicLayoutAdapter methodsFor: 'updating' stamp: ''!
updateBorderWidth

	widget borderWidth: layout borderWidth! !

!SpMorphicLayoutAdapter methodsFor: 'accessing' stamp: ''!
add: aPresenter constraints: constraints
 
	aPresenter owner: self model. 
	self widgetDo: [ :aPanel |
		self 
			basicAdd: aPresenter
			constraints: constraints 
			to: aPanel ]! !

!SpMorphicLayoutAdapter methodsFor: 'building' stamp: ''!
buildWithSpec: aString 

	^ self buildWithSpec! !

!SpMorphicLayoutAdapter methodsFor: 'initialization' stamp: ''!
addKeyBindingsTo: aMorph
	"This is called before the layout actually exists. 
	 Skipping it."
	! !

!SpMorphicLayoutAdapter methodsFor: 'private' stamp: ''!
basicAdd: aPresenter constraints: constraints to: aPanel 

	self subclassResponsibility! !

!SpMorphicLayoutAdapter methodsFor: 'private' stamp: ''!
buildMorph: aPresenter constraints: constraints 
	| childMorph |
	
	childMorph := aPresenter buildWithSpec: constraints spec.
	aPresenter adapter 
		ifNotNil: [ :anAdapter | anAdapter applyStyle ].

	"Add children alignment constraints (if applies)"
	childMorph := self 
		applyChildrenAlignmentTo: childMorph 
		constraints: constraints. 
	childMorph := self 
		addConstraints: constraints 
		toChild: childMorph.
		
	^ childMorph! !

!SpMorphicLayoutAdapter methodsFor: 'initialization' stamp: ''!
replaceLayoutWith: aLayout 

	| oldAdapter |
	self widget owner ifNil: [ ^ self ].

	oldAdapter := self.
	self model adapter: (aLayout
		buildAdapterFor: self model
		bindings: self model application adapterBindings).
		
	oldAdapter widget owner 
		replaceSubmorph: oldAdapter widget  
		by: self model adapter widget! !

!SpMorphicLayoutAdapter methodsFor: 'building' stamp: ''!
buildWithSpec
	
	^ self widget! !

!SpMorphicLineMarkDisplayer methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	| right font lines visibleRectangle left lineMarks lineMarkNumbers |
	
	super drawOn: aCanvas.
	
	self paragraph selectionStart ifNil: [ ^ self ].
	self paragraph selectionStop ifNil: [ ^ self ].
	self paragraph lines ifNil: [ ^ self ].
	
	right := self bounds right.
	left := self bounds left.
	font := self fontToUse. "needed for the ygap"
	lines := self lines.
	lineMarks := self adapter lineMarks asDictionary.
	lineMarkNumbers := lineMarks keys.

	aCanvas
		clipBy: self bounds
		during: [ :clippedCanvas | 
			clippedCanvas 
				fillRectangle: self verticalSeparatorBounds 
				color: self verticalSeparatorColor.
			
			visibleRectangle := clippedCanvas clipRect.
			((self lineIndexForPoint: visibleRectangle topLeft) to: (self lineIndexForPoint: visibleRectangle bottomRight))
			select: [ :i | lineMarkNumbers includes: i ] 
			thenDo: [ :i | 
				| line iconForm lineBounds ygap |

				line := lines at: i.			
				ygap := ((line lineHeight - font height) // 2 - 1) rounded.
				iconForm := self iconNamed: (self markAt: (lineMarks at: i) value) iconName. 
				lineBounds := self side = #left
					ifTrue: [ 
						(right - (iconForm width/2)) @ (line bottom - font height - ygap) corner: (right + (iconForm width/2)) @ line bottom ]
					ifFalse: [ 
						(left + self horizontalGapBefore) @ (line bottom - font height - ygap) corner: right @ line bottom ].
				lineBounds := lineBounds translateBy: 0 @ (self offset y negated + self bounds top).
				clippedCanvas 
					translucentImage: iconForm
					at: lineBounds topLeft - (iconForm width@0) ] ]! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ self paragraphProvider lineNumbersBackgroundColor ! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
fontToUse

	^ self textArea font! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
selectionColorToUse
	^ self primarySelectionColor! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
level
	^ 2! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
adapter: anObject

	adapter := anObject! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
markAt: aSymbol

	^ self adapter markAt: aSymbol! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
iconNamed: aSymbol

	^ self adapter presenter application iconNamed: aSymbol! !

!SpMorphicLineMarkDisplayer methodsFor: 'menus' stamp: ''!
getMenu: shiftState
	"Answer the menu to be presented when the yellow button is pressed while the shift key is down"

	^ nil "self menu"! !

!SpMorphicLineMarkDisplayer methodsFor: 'event handling' stamp: ''!
mouseMove: anEvent
	| lineIndex line |
	lineIndex := self lineIndexForPoint: anEvent position.
	line := self lines at: lineIndex.
	anEvent setPosition: line topLeft.
	self textArea mouseMove: anEvent
! !

!SpMorphicLineMarkDisplayer methodsFor: 'drawing' stamp: ''!
drawOnAthensCanvas: aCanvas
	| prev right font lines visibleRectangle tcolor left |
	
	true ifTrue: [ ^ self ].
	
	super drawOnAthensCanvas: aCanvas.
	self paragraph selectionStart ifNil: [ ^ self ].
	self paragraph selectionStop ifNil: [ ^ self ].
	self paragraph lines ifNil: [ ^ self ].
	right := self bounds right.
	left := self bounds left.
	font := self fontToUse.
	prev := nil.
	lines := self lines.
	tcolor := self textColor.
	aCanvas
		clipBy: self bounds
		during: [ 
			| backBnd |
			aCanvas setShape: self verticalSeparatorBounds.
			aCanvas setPaint: self verticalSeparatorColor.
			aCanvas draw.
			visibleRectangle := aCanvas clipRect.
			(self lineIndexForPoint: visibleRectangle topLeft) to: (self lineIndexForPoint: visibleRectangle bottomRight) do: [ :i | 
				| line |
				line := lines at: i.
				(self selectionStart == self selectionStop and: [self selectionStop textLine lineNumber = line lineNumber])
					ifTrue: [ 
						backBnd := self bounds.
						backBnd := (backBnd left) @ line top corner: self verticalSeparatorBounds left @ line bottom.
						backBnd := backBnd translateBy: 0 @ (self offset y negated + self bounds top).
						aCanvas setShape: backBnd.
						aCanvas setPaint: self selectionColorToUse.
						aCanvas draw ].
				prev = line lineNumber
					ifFalse: [ 
						| lineMark lineBnd ygap |
						ygap := ((line lineHeight - font height) // 2 - 1) rounded.
						lineMark := line lineNumber asString.
						self side = #left
							ifTrue: [ 
								| width |
								width := (self fontToUse widthOfString: lineMark) + self horizontalGapAfter.
								lineBnd := (right - width) @ (line bottom - font height - ygap) corner: (right + width) @ line bottom ]
							ifFalse: [ lineBnd := (left + self horizontalGapBefore) @ (line bottom - font height - ygap) corner: right @ line bottom ].
						lineBnd := lineBnd translateBy: 0 @ (self offset y negated + self bounds top).
						aCanvas morphicDrawString: lineMark in: lineBnd font: font color: tcolor.
						prev := line lineNumber ] ] ]! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
verticalSeparatorBounds
	| bnds  |
	bnds := self bounds.
	^ self side = #left
		ifTrue: [ (bnds topRight -  (self verticalSeparatorWidth @ 0)) corner: bnds bottomRight ]
		ifFalse: [ (bnds topLeft corner: bnds bottomLeft + (self verticalSeparatorWidth @ 0)) ]! !

!SpMorphicLineMarkDisplayer methodsFor: 'geometry' stamp: ''!
computedWidthFrom: aRectangle
	^ (((self fontToUse widthOfString: self paragraph numberOfPhysicalLines asString) + self horizontalGapBefore
		+ self horizontalGapAfter + self verticalSeparatorWidth) max: self minimumWidth) truncated! !

!SpMorphicLineMarkDisplayer methodsFor: 'geometry' stamp: ''!
horizontalGapAfter
	^ 3! !

!SpMorphicLineMarkDisplayer methodsFor: 'geometry' stamp: ''!
horizontalGapBefore
	^ 3! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
adapter

	^ adapter! !

!SpMorphicLineMarkDisplayer methodsFor: 'geometry' stamp: ''!
minimumWidth
	^ (self fontToUse widthOfString: 'MM') + self horizontalGapAfter + self horizontalGapBefore + self  verticalSeparatorWidth 
! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
verticalSeparatorColor
	^ (self textArea backgroundColor contrastingBlackAndWhiteColor ) alpha: 0.3! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
textColor
	^ self textArea lineNumbersTextColor 
! !

!SpMorphicLineMarkDisplayer methodsFor: 'event handling' stamp: ''!
yellowButtonActivity: shiftKeyState 
	"Invoke the text-editing menu.
	Check if required first!!"
	(self getMenu: shiftKeyState)
		ifNotNil: [ :menu|
			menu invokeModal. 
			self changed.
			^ true].
	^ true! !

!SpMorphicLineMarkDisplayer methodsFor: 'menus' stamp: ''!
menu
	"Answer the menu to be presented when the yellow button is pressed while the shift key is down"

	^ (PragmaMenuBuilder pragmaKeyword: self menuKeyword  model: self) menu! !

!SpMorphicLineMarkDisplayer methodsFor: 'event handling' stamp: ''!
mouseDown: anEvent
	| lineIndex line |
	(anEvent yellowButtonPressed and: [ anEvent commandKeyPressed not ]) "First check for option (menu) click"
		ifTrue: [ ^ (self yellowButtonActivity: anEvent shiftPressed) ].

	lineIndex := self lineIndexForPoint: anEvent position.
	line := self lines at: lineIndex.
	anEvent setPosition: line topLeft.
	self textArea mouseDown: anEvent! !

!SpMorphicLineMarkDisplayer methodsFor: 'menus' stamp: ''!
menuKeyword 
	^ #RubLineNumberMenu
	! !

!SpMorphicLineMarkDisplayer methodsFor: 'event handling' stamp: ''!
mouseUp: anEvent
	| lineIndex line |
	lineIndex := self lineIndexForPoint: anEvent position.
	line := self lines at: lineIndex.
	anEvent setPosition: line topLeft.
	self textArea mouseUp: anEvent.
! !

!SpMorphicLineMarkDisplayer methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^ true! !

!SpMorphicLineMarkDisplayer methodsFor: 'accessing' stamp: ''!
verticalSeparatorWidth
	^ 1! !

!SpMorphicLineMarkDisplayer class methodsFor: 'querying' stamp: ''!
key
	^ #patchLineMarks! !

!SpMorphicLinkAdapter commentStamp: ''!
Description
--------------------

I am the adapter used to bridge a URLPresenter and a morphic!
!SpMorphicLinkAdapter methodsFor: 'accessing - colors' stamp: ''!
urlHoverColor

	^ self urlColor darker! !

!SpMorphicLinkAdapter methodsFor: 'event handling' stamp: ''!
mouseLeave: anEvent from: aMorph

	aMorph color: self urlColor.
	self currentHand showTemporaryCursor: nil! !

!SpMorphicLinkAdapter methodsFor: 'accessing' stamp: ''!
action

	^ self model action! !

!SpMorphicLinkAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	"Since Pharo does not yet have a real morph for URL, I create my own. Maybe later we will have real links in Morphic?"

	| aMorph |
	aMorph := StringMorph new
		          contents: self getLabelText;
		          dragEnabled: self dragEnabled;
		          dropEnabled: self dropEnabled;
		          vResizing: #shrinkWrap;
		          hResizing: #spaceFill;
		          setBalloonText: self getHelpText;
		          color: self urlColor;
		          on: #mouseEnter send: #mouseEnter:from: to: self;
		          on: #mouseLeave send: #mouseLeave:from: to: self;
		          on: #mouseDown send: #mouseDown:from: to: self;
		          on: #mouseUp send: #mouseUp:from: to: self;
		          yourself.

	self presenter whenLabelChangedDo: [ :newLabel | 
		aMorph contents: (newLabel ifNotNil: [ :aString | 
				 aString localizedForPresenter: self presenter ]) ].

	^ aMorph! !

!SpMorphicLinkAdapter methodsFor: 'event handling' stamp: ''!
mouseEnter: anEvent from: aMorph

	aMorph color: self urlHoverColor.
	self currentHand showTemporaryCursor: Cursor webLink! !

!SpMorphicLinkAdapter methodsFor: 'accessing - colors' stamp: ''!
urlColor

	^ self color ifNil: [ self theme urlColor ]! !

!SpMorphicLinkAdapter methodsFor: 'event handling' stamp: ''!
mouseUp: anEvent from: aMorph

	aMorph color: self urlHoverColor.
	self action value! !

!SpMorphicLinkAdapter methodsFor: 'private' stamp: ''!
getHelpText

	^ self presenter help 
		ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicLinkAdapter methodsFor: 'accessing - colors' stamp: ''!
urlDuringClickColor

	^ self urlHoverColor darker! !

!SpMorphicLinkAdapter methodsFor: 'event handling' stamp: ''!
mouseDown: anEvent from: aMorph

	aMorph color: self urlDuringClickColor! !

!SpMorphicLinkAdapter methodsFor: 'private' stamp: ''!
getLabelText

	^ self presenter label 
		ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicLinkAdapter methodsFor: 'accessing' stamp: ''!
label

	^ self getLabelText! !

!SpMorphicListAdapter commentStamp: ''!
I am the adapter used to bridge a ListPresenter and a PluggableListMorph!
!SpMorphicListAdapter methodsFor: 'widget API' stamp: ''!
acceptDroppingMorph: draggedMorph event: event inMorph: source
	| item index |
	
	index := source rowAtLocation: event position.
	item := self presenter model at: index ifAbsent: [ nil ].
	
	^ self acceptDropBlock valueWithEnoughArguments: { draggedMorph model model . event. source model model. item. index }! !

!SpMorphicListAdapter methodsFor: 'widget API' stamp: ''!
refreshList

	^ self widget refresh! !

!SpMorphicListAdapter methodsFor: 'widget API' stamp: ''!
refreshWidgetList
	(self widget showIndex < self widget dataSource numberOfRows
		and: [ self widget isIndexVisible: self widget showIndex ])
		ifFalse: [ self widget resetPosition ].
	self refreshWidgetSelection.
	(self widget hasSelection
		and: [ self widget isIndexVisible: self widget selectedIndex ])
		ifFalse: [ self widget resetPosition.
			self widget ensureVisibleFirstSelection ].
	self widget refresh! !

!SpMorphicListAdapter methodsFor: 'selecting' stamp: ''!
selectIndex: anInteger 
	
	(anInteger = 0 and: [ widget selectedIndexes isEmpty ]) ifTrue: [ ^ self ].	
	(widget selectedIndexes includes: anInteger) ifTrue: [^self].
	widget selectIndex: anInteger! !

!SpMorphicListAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| datasource |
	
	datasource := SpMorphicListDataSource new.
	datasource model: self model.
	widget := SpFTTableMorph new
		dataSource: datasource;
		hideColumnHeaders;
		enableSearch;
		beResizable;
		columns: { self newListColumn };
		setMultipleSelection: self model isMultipleSelection;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		setBalloonText: self help;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		onAnnouncement: FTSelectionChanged send: #selectionChanged: to: self;
		onAnnouncement: FTStrongSelectionChanged send: #strongSelectionChanged: to: self;
		yourself.

	self presenter whenModelChangedDo: [ widget refresh ].
	self presenter whenSelectionChangedDo: [ self refreshWidgetSelection ].
	self presenter selection whenChangedDo: [ self refreshWidgetSelection ].
	self presenter whenSearchEnabledChangedDo: [ self updateSearch ].
	self refreshWidgetHeaderTitle.
	self refreshWidgetSelection.
	self presenter whenItemFilterBlockChangedDo: [ :block | self updateItemFilterBlockWith: block ].
	self updateItemFilterBlockWith: self itemFilter.

	self configureScrolling.
	widget 
		bindKeyCombination: Character space 
		toAction: [ self model clickOnSelectedItem ].

	^ widget! !

!SpMorphicListAdapter methodsFor: 'emulating' stamp: ''!
firstRowIsHeader 

	^ self widget container submorphs first class = FTTableHeaderRowMorph! !

!SpMorphicListAdapter methodsFor: 'widget API' stamp: ''!
listSize

	^ self model listSize! !

!SpMorphicListAdapter methodsFor: 'factory' stamp: ''!
newListColumn
	| column |
	
	column := SpStringTableColumn
		title: self presenter headerTitle
		evaluated: self presenter display.	
	
	self presenter displayColor 
		ifNotNil: [ :aBlock | column displayColor: aBlock ].
	self presenter displayBold
		ifNotNil: [ :aBlock | column displayBold: aBlock ].
	self presenter displayItalic
		ifNotNil: [ :aBlock | column displayItalic: aBlock ].
	self presenter displayUnderline
		ifNotNil: [ :aBlock | column displayUnderline: aBlock ].
	self presenter displayBackgroundColor 
		ifNotNil: [ :aBlock | column displayBackgroundColor: aBlock ].
	
	^ SpMorphicTableColumn new 
		model: column;
		yourself! !

!SpMorphicListAdapter methodsFor: 'spec protocol' stamp: ''!
autoDeselect: aBoolean

	self widgetDo: [ :w | w autoDeselect: aBoolean ]! !

!SpMorphicListAdapter methodsFor: 'accessing' stamp: ''!
isShowColumnHeaders
	
	^ widget isShowColumnHeaders ! !

!SpMorphicListAdapter methodsFor: 'widget API' stamp: ''!
listElementAt: anIndex ifAbsent: aBlock

	^ self model listElementAt: anIndex ifAbsent: aBlock! !

!SpMorphicListAdapter methodsFor: 'emulating' stamp: ''!
hasFilter

	^ self widget hasFilter! !

!SpMorphicListAdapter methodsFor: 'factory' stamp: ''!
selectionChanged: ann
	| diff |
	
	self presenter selection isMultipleSelection
		ifTrue: [ 
			self presenter selection
				selectIndexes: (ann newSelectedIndexes reject: [ :e | e = 0 ]) ].
	self presenter selection isMultipleSelection
		ifFalse: [ 
			self presenter selection
				selectIndex: (ann newSelectedIndexes
					ifNotEmpty: [ :indexes | indexes first ]
					ifEmpty: [ 0 ]) ].
	diff := ann newSelectedIndexes difference: ann oldSelectedIndexes.
	(diff notEmpty and: [ self presenter activatesOnSingleClick ])
		ifTrue: [ self presenter doActivateAtIndex: diff last ].
	ann newSelectedIndexes ifNotEmpty: [ ^ self ].
	self presenter selection unselectAll! !

!SpMorphicListAdapter methodsFor: 'events' stamp: ''!
updateMenu
	
	"there is no need to updateMenu here because it will be resolved at the dataSource"! !

!SpMorphicListAdapter methodsFor: 'testing' stamp: ''!
selectedIndexes
	
	^ widget selectedIndexes! !

!SpMorphicListAdapter methodsFor: 'emulating' stamp: ''!
sendRightClickEvent
	| evt |

	evt := MouseButtonEvent new 
		setType: nil 
		position: widget center 
		which: MouseButtonEvent yellowButton 
		buttons: MouseButtonEvent yellowButton 
		hand: nil 
		stamp: nil.
	
	"Sending directly to #click: because that's what it was being tested, but this 
	 is a a weird way to make the call. Usually the parent method should have work, 
	 but since it was using mouseDown:/mouseUp: instead handleMouseDown:/handleMouseUp:
	 the event was not arriving. This is not fixed, but we do not want to introduce 
	 a regression here, so we let it like that :)"
	self widget click: evt! !

!SpMorphicListAdapter methodsFor: 'widget API' stamp: ''!
backgroundColorFor: anItem at: index

	^ self model backgroundColorFor: anItem at: index! !

!SpMorphicListAdapter methodsFor: 'testing' stamp: ''!
isNonEditableRow: aRow column: aColumn

	^ (self widget dataSource
		cellColumn: (self widget columns at: aColumn)
		row: aRow) submorphs allSatisfy: [ :e | e asReadOnlyMorph == e ]! !

!SpMorphicListAdapter methodsFor: 'events' stamp: ''!
strongSelectionChanged: aFTStrongSelectionChanged
	self presenter activatesOnDoubleClick
		ifTrue: [ self presenter
				doubleClickAtIndex: aFTStrongSelectionChanged selectedIndex ]! !

!SpMorphicListAdapter methodsFor: 'widget API' stamp: ''!
backgroundColorFor: anItem
	^ self model backgroundColorFor: anItem! !

!SpMorphicListAdapter methodsFor: 'widget API' stamp: ''!
refreshWidgetSelection
	| rowIndexes |
	rowIndexes := self presenter selection selectedIndexes.
	rowIndexes = self widget selectedIndexes
		ifTrue: [ ^ self ].
	rowIndexes isEmpty
		ifTrue: [ self widget basicSelectIndexes: #() ]
		ifFalse: [ self widget basicSelectIndexes: rowIndexes ].
	^ self widget refresh! !

!SpMorphicListAdapter methodsFor: 'widget API' stamp: ''!
refreshWidgetHeaderTitle
	
	self presenter hasHeaderTitle 
		ifTrue: [ 
			self widget columns first model title: self presenter headerTitle.
			self widget
				showColumnHeaders;
				refresh. ]
		ifFalse: [ 
			self widget columns first model title: nil.
			self widget
				hideColumnHeaders;
				refresh ].! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
	| cell item builder |

	cell := FTCellMorph new.
	item := self model itemAt: rowIndex.
	self model hasIcons ifTrue: [ 
		(self model iconFor: item) ifNotNil: [ :icon | 
			cell addMorphBack: icon asMorph ] ].
	builder := SpMorphicTableCellBuilder on: self.
	builder 
		cell: cell;
		rowIndex: rowIndex;
		visit: column model.

	^ cell! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
newDataSourceMatching: aFTFilter
	| newElements wrappedItem text newDataSource modelCopy |
	
	newElements := self elements select: [ :each | 
		wrappedItem := self model displayValueFor: each.
		table columns anySatisfy: [ :column | 
			text := column transform: wrappedItem.
			aFTFilter matches: text]].
	
	newDataSource := self copy.
	modelCopy := self model copy.
	modelCopy prepareForFilteredDataSourceWith: newElements.
	newDataSource model: modelCopy.
	
	^newDataSource! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
elementAt: rowIndex

	^ self listModel at: rowIndex! !

!SpMorphicListDataSource methodsFor: 'drag and drop' stamp: ''!
transferFor: passenger from: aMorph

	^ (self model adapter 
		transferFor: passenger 
		from: self table) 
		buildWithSpec
		  dragHand: aMorph currentHand;
		  yourself! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString
	| search |

	aString isEmptyOrNil ifTrue: [ ^ #() ].
	search := aString trimBoth asLowercase.
	^ Array streamContents: [ :stream |
		self elements withIndexDo: [ :each :rowIndex | 
			(self model performSearch: each matching: search) 
				ifTrue: [ stream nextPut: rowIndex ] ] ]! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
listModel

	^ model model! !

!SpMorphicListDataSource methodsFor: 'testing' stamp: ''!
hasElementAt: index 
	
	^ self model model hasElementAt: index! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
elements

	^ self model items! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
numberOfRows
	^ model
		ifNil: [ 0 ]
		ifNotNil: [ self listModel size ]! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
headerColumn: column

	column id ifNil: [ ^ nil ]. 
	^ FTCellMorph new 
		listCentering: #left;
		addMorph: column id asMorph asReadOnlyMorph;
		yourself! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	| menuPresenter |

	menuPresenter := self model contextMenu.
	menuPresenter ifNil: [ ^ nil ].
	^ SpBindings
		value: self model application adapterBindings
		during: [ 
			| m |
			m := menuPresenter value.
			m isMorph 
				ifTrue: [ m ]
				ifFalse: [ m buildWithSpec ] ]! !

!SpMorphicListDataSource methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!SpMorphicMenuAdapter commentStamp: ''!
I am the adapter used to bridge to MenuMorph!
!SpMorphicMenuAdapter methodsFor: 'private' stamp: ''!
buildWidget
	
	widget := self basicMenuPopUp.
	self menuGroups
		do: [ :group | 
			| items |
			items := group buildWithSpec.
			items do: [ :item | widget addMorphBack: item ] ]
		separatedBy: [ widget addLine ].

	^ widget! !

!SpMorphicMenuAdapter methodsFor: 'private' stamp: ''!
basicMenuPopUp

	^ MenuMorph new
		addIfNeededTitle: self title andIcon: self icon;
		yourself! !

!SpMorphicMenuAdapter methodsFor: 'initialization' stamp: ''!
adaptAsPopup: aPresenter

	model := aPresenter.
	aPresenter addDependent: self.
	widget := self buildWidgetPopup! !

!SpMorphicMenuAdapter methodsFor: 'private' stamp: ''!
buildWidgetPopup
	
	^ self buildWidget! !

!SpMorphicMenuAdapter class methodsFor: 'instance creation' stamp: ''!
adaptAsPopup: aPresenter

	^ self new
		  adaptAsPopup: aPresenter;
		  yourself! !

!SpMorphicMenuBarAdapter commentStamp: ''!
I'm an adapter to provide a menu bar using a ToolDockingBarMorph!
!SpMorphicMenuBarAdapter methodsFor: 'accessing' stamp: ''!
menuGroup

	^ self presenter menuGroup! !

!SpMorphicMenuBarAdapter methodsFor: 'private' stamp: ''!
adoptMenuItemModel: item accumulator: controls
	
	item subMenu
		ifNil: [ | button |
			button := self buildButtonFor: item.
			controls add: button ]
		ifNotNil: [ 
			self emptyAccumulator: controls.
			widget addMorphBack: (self theme newToolSpacerIn: widget).
			widget 
				add: item name
				font: self theme menuBarFont
				icon: item icon
				help: item description
				subMenu: item subMenu buildWithSpecAsPopup.
			widget addMorphBack: (self theme newToolSpacerIn: widget) ]! !

!SpMorphicMenuBarAdapter methodsFor: 'private' stamp: ''!
adoptMenuGroupModel: aGroupModel first: aBoolean
	| controls |
	
	aBoolean ifFalse: [ 
		widget 
			addMorphBack: (self theme newToolSpacerIn: widget);
			addMorphBack: (self theme newToolbarHandleIn: widget);
			addMorphBack: (self theme newToolSpacerIn: widget) ].
			
	controls := OrderedCollection new.
	aGroupModel menuItems do: [ :item | 
		self adoptMenuItemModel: item accumulator: controls ].
	
	self emptyAccumulator: controls! !

!SpMorphicMenuBarAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	widget := ToolDockingBarMorph new
		          hResizing: #spaceFill;
		          vResizing: #spaceFill;
		          yourself.

	self menuGroups doWithIndex: [ :aGroup :index | 
		self adoptMenuGroupModel: aGroup first: index = 1 ].

	^ widget! !

!SpMorphicMenuBarAdapter methodsFor: 'private' stamp: ''!
emptyAccumulator: controls

	controls do: [ :button | widget addMorphBack: button ].
	controls removeAll! !

!SpMorphicMenuBarAdapter methodsFor: 'private' stamp: ''!
buildButtonFor: item

	^ self theme
		  newButtonIn: widget
		  for: item
		  getState: nil
		  action: #performMenuActionWith:
		  arguments: { widget }
		  getEnabled: #isEnabled
		  label: (IconicListItemMorph text: item name icon: item icon)
		  help: item description! !

!SpMorphicMenuButtonAdapter commentStamp: ''!
Adapter for a menu button!
!SpMorphicMenuButtonAdapter methodsFor: 'widget API' stamp: ''!
action 

	self presenter menu ifNotNil: [ :aValuable |
		aValuable value ifNotNil: [ :aMenu |
			aMenu owner: self presenter.
			self showSubMenu: aMenu ] ].
	
	self widget ifNotNil: [ :m | 
		m takeKeyboardFocus ] ! !

!SpMorphicMenuButtonAdapter methodsFor: 'widget API' stamp: ''!
font
	
	self flag: #REMOVE. "Not used anymore. Font is set with styles"
	^ nil ! !

!SpMorphicMenuButtonAdapter methodsFor: 'factory' stamp: ''!
newButton

	^ PluggableButtonMorph
		  on: self
		  getState: nil
		  action: #action
		  label: #label
		  icon: #icon
		  menu: nil! !

!SpMorphicMenuButtonAdapter methodsFor: 'accessing' stamp: ''!
icon

	^ self presenter icon ifNil: [ self defaultIcon ]! !

!SpMorphicMenuButtonAdapter methodsFor: 'drag and drop' stamp: ''!
dragEnabled

	^ false! !

!SpMorphicMenuButtonAdapter methodsFor: 'drag and drop' stamp: ''!
dropEnabled

	^ false! !

!SpMorphicMenuButtonAdapter methodsFor: 'factory' stamp: ''!
defaultIcon
		
	^ self application iconNamed: #arrowDown! !

!SpMorphicMenuButtonAdapter methodsFor: 'protocol' stamp: ''!
askBeforeChanging

	^ false! !

!SpMorphicMenuGroupAdapter commentStamp: ''!
I am used to compute a MenuGroupPresenter.
There is not Morphic represenation of a MenuGroup, that is why I do not have a coresponding morph.!
!SpMorphicMenuGroupAdapter methodsFor: 'protocol' stamp: ''!
menuItems
	
	^ self model menuItems! !

!SpMorphicMenuGroupAdapter methodsFor: 'private' stamp: ''!
buildWidget

	^ self menuItems select: #isVisible thenCollect: #buildWithSpec! !

!SpMorphicMenuGroupAdapter methodsFor: 'initialization' stamp: ''!
addKeyBindingsTo: aMorph
	"This does not has keybindings"! !

!SpMorphicMenuGroupAdapter methodsFor: 'private' stamp: ''!
applyVisibility
	"Do nothing. Morphs implement #visible but the widget of this adapter is an ordered collection."! !

!SpMorphicMenuItemAdapter commentStamp: ''!
I am the bridge between a MenuItemPresenter and a ToggleMenuItemMorph!
!SpMorphicMenuItemAdapter methodsFor: 'private' stamp: ''!
widgetName
	"For testing purposes"
	
	^ self widget contents! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
action

	^ self model action! !

!SpMorphicMenuItemAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ self autoRefresh
		  ifTrue: [ self buildWidgetAutoRefresh ]
		  ifFalse: [ self buildWidgetNoRefresh ]! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
balloonText
	| balloonText | 
	
	balloonText := self model description.
	balloonText ifNil: [ ^ nil ].
	
	^ (balloonText isBlock or: [ balloonText isMessageSend ])
		ifTrue: [ balloonText cull: self model ]
		ifFalse: [ balloonText ]! !

!SpMorphicMenuItemAdapter methodsFor: 'factory' stamp: ''!
buildWidgetAutoRefresh

	^ UpdatingMenuItemMorph new
		  target: self;
		  balloonTextSelector: #balloonText;
		  subMenuSelector: #subMenu;
		  nameSelector: #name;
		  selector: #performMenuActionWith:;
		  argumentsBlock: self actionArguments;
		  getStateSelector: #state;
		  iconSelector: #icon;
		  enablementSelector: #enabled;
		  keyText: self shortcutText;
		  yourself! !

!SpMorphicMenuItemAdapter methodsFor: 'factory' stamp: ''!
buildWidgetNoRefresh
	| item |

	item := SpToggleMenuItemMorph new
		contents: self name;
		target: self;
		selector: #performMenuActionWith:;
		subMenu: self subMenu;
		argumentsBlock: self actionArguments;
		getStateSelector: self stateSelector;
		icon: self icon;
		enablementSelector: #enabled;
		balloonText: self balloonText;
		keyText: self shortcutText;
		yourself.

	self presenter whenNameChangedDo: [ item contents: self name ].
	self presenter whenIconChangedDo: [ item icon: self icon ].
	self presenter whenDescriptionChangedDo: [ item balloonText: self balloonText ].

	^ item! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
performMenuActionWith: arguments

	^ self model performMenuActionWith: arguments! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
autoRefresh

	| autoRefresh |
	autoRefresh := self model autoRefresh.

	^ (autoRefresh isBlock or: [ autoRefresh isMessageSend ])
		  ifTrue: [ autoRefresh cull: self model ]
		  ifFalse: [ autoRefresh ]! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
enabled

	| enabled |
	enabled := self model isEnabled.

	^ (enabled isBlock or: [ enabled isMessageSend ])
		  ifTrue: [ enabled cull: self model ]
		  ifFalse: [ enabled ]! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
name

	| name |
	name := self presenter name.

	^ (name isBlock or: [ name isMessageSend ])
		  ifTrue: [ name cull: self model ]
		  ifFalse: [ 
			  name ifNotNil: [ :aString | 
				  aString localizedForPresenter: self presenter ] ]! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
icon

	| icon |
	icon := self model icon.

	^ (icon isBlock or: [ icon isMessageSend ])
		  ifTrue: [ icon cull: self model ]
		  ifFalse: [ icon ]! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
shortcut

	| shortcut |
	shortcut := self model shortcut.

	^ (shortcut isBlock or: [ shortcut isMessageSend ])
		  ifTrue: [ shortcut cull: self model ]
		  ifFalse: [ shortcut ]! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
shortcutText
	| shortcut |
	
	shortcut := self shortcut.
	shortcut isString ifTrue: [
		shortcut := self defaultModifierShortcut ].
	shortcut ifNil: [ ^ nil ].

	^ KMShortcutPrinter toString: shortcut asKeyCombination	! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
state

	| state |
	state := self model state.

	^ (state isBlock or: [ state isMessageSend ])
		  ifTrue: [ state cull: self model ]
		  ifFalse: [ state ]! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
stateSelector

	^ self state ifNotNil: [ #state ]! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
actionArguments

	^ [ Array with: self ]! !

!SpMorphicMenuItemAdapter methodsFor: 'private' stamp: ''!
defaultModifierShortcut
	
	^ self shortcut first isUppercase
		ifTrue: [ OSPlatform current defaultModifier + KMModifier shift + self shortcut first ]
		ifFalse: [ OSPlatform current defaultModifier + self shortcut first ]! !

!SpMorphicMenuItemAdapter methodsFor: 'widget API' stamp: ''!
subMenu

	| subMenu |
	subMenu := self model subMenu.
	subMenu ifNil: [ ^ nil ].

	^ (subMenu isBlock or: [ subMenu isMessageSend ])
		  ifTrue: [ subMenu cull: self model ]
		  ifFalse: [ subMenu buildWithSpecAsPopup ]! !

!SpMorphicMenuItemAdapter methodsFor: 'private' stamp: ''!
widgetIcon
	"For testing purposes"
	
	^ self widget icon! !

!SpMorphicMillerAdapter commentStamp: ''!
I'm an adapter for Miller Layouts.
A paned layout will split (horizontally or vertically) panels (in fixed yet proportional spaces), 
and it will scroll the panels that exceed SpMillerLayout>>#visiblePages property.  !
!SpMorphicMillerAdapter methodsFor: 'private' stamp: ''!
recalculatePages

	self widget ifNil: [ ^ self ].
	self childrenWidgets ifEmpty: [ ^ self ].
	(needRecalculatePages not 
		and: [ lastExtent = self widget extent 
		and: [ lastPageSize = self childrenWidgets size ] ]) 
		ifTrue: [ ^ self ].

	needRecalculatePages := false.
	lastExtent := self widget extent.
	lastPageSize := self childrenWidgets size.
	layout direction recalculatePages: self! !

!SpMorphicMillerAdapter methodsFor: 'accessing' stamp: ''!
add: aPresenter
 
	self add: aPresenter constraints: SpLayoutConstraints new! !

!SpMorphicMillerAdapter methodsFor: 'factory' stamp: ''!
disableHScrollBar
	
	widget hScrollbarShowNever! !

!SpMorphicMillerAdapter methodsFor: 'private' stamp: ''!
initialize

	super initialize.
	needRecalculatePages := false
! !

!SpMorphicMillerAdapter methodsFor: 'private' stamp: ''!
addConstraints: constraints toChild: childMorph
	"adds constraits by child"

	"Set morph to stay rigid"
	layout direction setRigidityOfNonExpandedMorph: childMorph.
	
	^ childMorph! !

!SpMorphicMillerAdapter methodsFor: 'factory' stamp: ''!
layout: aLayout

	layout := aLayout.
	
	widget ifNil: [
		"build of widget was differed up to here (to know what is the direction)"
		innerWidget := aLayout direction newWidgetOn: self.
		innerWidget borderWidth: aLayout borderWidth.
		innerWidget cellInset: aLayout spacing.
		
		layout whenVisiblePagesChangedDo: [ self forceRecalculatePages ].
		
		widget := self newScrollPaneFor: innerWidget.
		self presenter hasHorizontalScrollBar 
			ifFalse: [ self disableHScrollBar ].
		self presenter whenHorizontalScrollBarChangedDo: [ :show |
			show 
				ifTrue: [ self enableHScrollBar ]
			 	ifFalse: [ widget hScrollbarShowNever ] ] ].

	super layout: aLayout! !

!SpMorphicMillerAdapter methodsFor: 'factory' stamp: ''!
newPanel

	^ super newPanel
		extent: 1@1;
		yourself! !

!SpMorphicMillerAdapter methodsFor: 'private' stamp: ''!
recalculatePageHeights

	| newHeight widgets height |
	height := self widget height.
	widgets := self childrenWidgets.
	newHeight := widgets size = 1
		ifTrue: [ height ]
		ifFalse: [ height / (layout visiblePages min: widgets size) - (layout spacing / (layout visiblePages min: widgets size)) ].
		
	widgets reverseWithIndexDo: [ :each :index |
		each 
			top: (index - 1) * newHeight;
			height: newHeight ]! !

!SpMorphicMillerAdapter methodsFor: 'private' stamp: ''!
forceRecalculatePages

	needRecalculatePages := true.
	self recalculatePages! !

!SpMorphicMillerAdapter methodsFor: 'paginator' stamp: ''!
scrollByDeltaPercent: percent

	| millerWidth millerDelta |	
	millerWidth := self widget scroller localSubmorphBounds width.
	millerDelta := millerWidth * (percent / 100).
	self widget scroller offset: (self widget scroller offset x + millerDelta)@0	! !

!SpMorphicMillerAdapter methodsFor: 'factory' stamp: ''!
newVertical

	^ self newPanel 
		listDirection: #topToBottom;
		yourself! !

!SpMorphicMillerAdapter methodsFor: 'accessing' stamp: ''!
selectPage: aNumber

	self widget defer: [
		(self childrenWidgets at: aNumber ifAbsent: [ nil ])
			ifNotNil: [ :aMorph | self widget showMorph: aMorph ] ]! !

!SpMorphicMillerAdapter methodsFor: 'accessing' stamp: ''!
removeAll

	needRecalculatePages := true.
	innerWidget removeAllMorphs! !

!SpMorphicMillerAdapter methodsFor: 'private' stamp: ''!
scrollToShowLastPage

	self widget defer: [ | size firstMorphIndex |
		size := innerWidget submorphs size.
		firstMorphIndex := size - self presenter visiblePages + 1. 
		self widget showMorph: (innerWidget submorphs at: ((firstMorphIndex max: 1) min: size)) ]! !

!SpMorphicMillerAdapter methodsFor: 'accessing' stamp: ''!
childrenWidgets
	
	^ innerWidget submorphs! !

!SpMorphicMillerAdapter methodsFor: 'private' stamp: ''!
add: aPresenter constraints: constraints

	self widget ifNil: [ ^ self ].

	aPresenter owner: self model. 
	needRecalculatePages := true.
	self 
		basicAdd: aPresenter
		constraints: constraints 
		to: innerWidget.
	self scrollToShowLastPage! !

!SpMorphicMillerAdapter methodsFor: 'private' stamp: ''!
recalculatePageWidths

	| newWidth widgets width |
	widgets := self childrenWidgets.
	width := self widget width.
	newWidth := widgets size = 1
		ifTrue: [ width ]
		ifFalse: [ (width / (layout visiblePages min: widgets size)) - (layout spacing / (layout visiblePages min: widgets size)) ].
		
	widgets reverseWithIndexDo: [ :each :index |
		each 
			left: (index - 1) * newWidth;
			width: newWidth ]! !

!SpMorphicMillerAdapter methodsFor: 'private' stamp: ''!
basicAdd: aPresenter constraints: constraints to: aPanel

	| childMorph |
	childMorph := self buildMorph: aPresenter constraints: constraints.	
	aPanel addMorphBack: childMorph.
	
	^ childMorph! !

!SpMorphicMillerAdapter methodsFor: 'accessing' stamp: ''!
remove: aPresenter

	| morph |
	needRecalculatePages := true.
	morph := aPresenter adapter widget.	
	innerWidget removeMorph: morph! !

!SpMorphicMillerAdapter methodsFor: 'factory' stamp: ''!
enableHScrollBar
	
	widget hScrollbarShowWhenNeeded! !

!SpMorphicMillerAdapter methodsFor: 'factory' stamp: ''!
newHorizontal

	^ self newPanel 
		listDirection: #leftToRight;
		yourself! !

!SpMorphicMillerAdapter methodsFor: 'factory' stamp: ''!
removeSubWidgets

	innerWidget removeAllMorphs! !

!SpMorphicMillerAdapter methodsFor: 'factory' stamp: ''!
newScrollPaneFor: aWidget

	^ MillerScrollPane new
		  changeScrollerTableLayout;
		  hResizing: #spaceFill;
		  vResizing: #spaceFill;
		  color: Color transparent;
		  borderColor: Color transparent;
		  scrollTarget: aWidget;
		  onLayoutChange: [ self recalculatePages ];
		  yourself! !

!SpMorphicModalWindowAdapter commentStamp: ''!
I am a morphic adapter used to show a modal for a ModalWindowPresenter in Morphic.!
!SpMorphicModalWindowAdapter methodsFor: 'protocol' stamp: ''!
open

	backdropMorph := FullscreenMorph new
		color: self theme modalBackdropColor;
		on: #click send: #mouseClick:onBackdrop: to: self;
		openInWorld;
		yourself.

	self widget beSticky.
	"I am copying here what is defined in SystemWindow>>#openModal (but introducing the centered 
	 check inbetween because #openInWorld will use the RealEstateAgent to position the window 
	 and we want to (maybe) center it before showing it."
	self widget openInWorld.
	self presenter isCentered 
		ifTrue: [ self centered ].
	self presenter windowIsOpened.
	self waitWhile: [ self widget isInWorld ]! !

!SpMorphicModalWindowAdapter methodsFor: 'event handling' stamp: ''!
mouseClick: evt onBackdrop: aMorph

	self closeOnBackdropClick ifFalse: [ ^ self ].

	self model triggerCancelAction.
	self model close. "Ensure the modal is closed"
	aMorph delete! !

!SpMorphicModalWindowAdapter methodsFor: 'private' stamp: ''!
waitWhile: aBlock
	
	MorphicRenderLoop new doOneCycleWhile: aBlock! !

!SpMorphicModalWindowAdapter methodsFor: 'protocol' stamp: ''!
close
 
	backdropMorph ifNotNil: [ 
		backdropMorph delete.
		backdropMorph := nil ].
	super close! !

!SpMorphicModalWindowAdapter methodsFor: 'testing' stamp: ''!
closeOnBackdropClick

	^ self model closeOnBackdropClick! !

!SpMorphicMorphAdapter commentStamp: ''!
I'm a spec adapter for a morph!
!SpMorphicMorphAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| newWidget |

	newWidget := self presenter morph 
		ifNil: [ Morph new color: Color transparent ].
	newWidget presenter: self presenter.

	self presenter whenMorphChangedDo: [ :aMorph | 
		self updateMorph: aMorph ].
	
	^ newWidget! !

!SpMorphicMorphAdapter methodsFor: 'factory' stamp: ''!
updateMorph: aMorph

	self applyStyle: aMorph.
	aMorph presenter: self presenter.
	widget owner ifNotNil: [ :ownerMorph | 
		ownerMorph 
			replaceSubmorph: widget
			by: aMorph ].
	widget := aMorph! !

!SpMorphicNotebookAdapter commentStamp: ''!
I'm an adapter to show a notebook (a tab manager)!
!SpMorphicNotebookAdapter methodsFor: 'factory' stamp: ''!
buildContentForPage: aPage

	^ aPage retrievePresenter ifNotNil: [ :presenter |
		self ensurePage: aPage isBuiltWithPresenter: presenter.
		presenter adapter widget ]! !

!SpMorphicNotebookAdapter methodsFor: 'updating' stamp: ''!
updatePageContent: aPage

	self widgetDo: [ :w |
		(w pageWithModel: aPage) reset.
		"if we are updating the page being displayed, we need to trigger a refresh"
		aPage = self presenter selectedPage ifTrue: [ 
			w updatePageIndex: (self model selectedPageIndex) ] ]! !

!SpMorphicNotebookAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
numberOfTabs
	^ self widget tabSelectorMorph tabs size! !

!SpMorphicNotebookAdapter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self initializeTBackendUpdating! !

!SpMorphicNotebookAdapter methodsFor: 'private' stamp: ''!
backendDetectCyclesDo: aBlock 

	self isBackendUpdating ifTrue: [ ^ self ].
	^ aBlock value! !

!SpMorphicNotebookAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| notebookMorph |

	notebookMorph := SpNotebookMorph new
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		setBalloonText: self help;
		yourself.
	self addModelTo: notebookMorph.

	self presenter 
		whenPagesChangedDo: [ :pages | self updatePagesWith: pages ];
		whenSelectedPageChangedDo: [ :page | self selectPage: page ].

	^ notebookMorph! !

!SpMorphicNotebookAdapter methodsFor: 'private' stamp: ''!
backendUpdatingDo: aBlock 
	| oldStatus |

	oldStatus := backendUpdating.
	backendUpdating := true.
	aBlock ensure: [ 
		backendUpdating := oldStatus ]! !

!SpMorphicNotebookAdapter methodsFor: 'updating' stamp: ''!
selectPage: aPage

	self widgetDo: [ :w | 
		w page: (aPage ifNotNil: [ (w pageWithModel: aPage) ]) ]! !

!SpMorphicNotebookAdapter methodsFor: 'factory' stamp: ''!
buildLabelForPage: aPage
	| labelPresenter labelMorph |

	labelPresenter := aPage labelPresenterFor: self presenter.
	labelMorph := labelPresenter buildWithSpec.
	labelPresenter adapter applyStyle.
	
	^ labelMorph! !

!SpMorphicNotebookAdapter methodsFor: 'protocol' stamp: ''!
takeKeyboardFocus

	self widget tabSelectorMorph takeKeyboardFocus! !

!SpMorphicNotebookAdapter methodsFor: 'factory' stamp: ''!
addModelTo: aNotebook
	
	self presenter pages ifEmpty: [ ^ self ].
	self presenter pages do: [ :each | 
		"Since I do not have the page added, I need to take it from the list. 
		 But I know this will be the last added :)" 
		self addPage: each to: aNotebook ].
	"force first page to be drawn"
	self presenter selectedPage ifNil: [ self presenter selectPageIndex: 1 ].
	aNotebook selectedPageIndex: self presenter selectedPageIndex.
	aNotebook announcer 
		when: SpNotebookPageChanged 
		send: #pageChanged: 
		to: self! !

!SpMorphicNotebookAdapter methodsFor: 'initialization' stamp: ''!
initializeTBackendUpdating

	backendUpdating := false! !

!SpMorphicNotebookAdapter methodsFor: 'factory' stamp: ''!
ensurePage: aPage isBuiltWithPresenter: presenter

	"is already built *for this notebook (owner)*"
	(presenter hasAdapter 
		and: [ presenter owner = self presenter ])
		ifTrue: [ ^ self ].

	"if not built or not same owner, I need to rebuild"		
	presenter owner: self presenter. 
	aPage layoutSpec
		ifNil: [ presenter buildWithSpec ]
		ifNotNil: [ :spec | presenter buildWithSpec: spec ]! !

!SpMorphicNotebookAdapter methodsFor: 'private' stamp: ''!
pageChanged: ann

	self backendUpdatingDo: [ self presenter selectPage: ann page model ]
	! !

!SpMorphicNotebookAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
clickTab: anIndex
	| evt tab |

	tab := self widget tabSelectorMorph tabs at: anIndex.
	evt := MouseButtonEvent new
		setType: nil
		position: widget center
		which: MouseButtonEvent redButton
		buttons: MouseButtonEvent redButton
		hand: tab activeHand
		stamp: nil.

	(tab handlesMouseDown: evt)
		ifTrue: [ tab handleMouseDown: evt.
			tab handleMouseDown: evt ]! !

!SpMorphicNotebookAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
selectedPageName
	"I am assuming I am testing the standard. Hence, the presenter will be an 
	 instance of `SpNotebookPageLabelPresenter`. 
	 Yes, this is weak :("
	
	^ self widget tabSelectorMorph selectedTab submorphs first presenter label! !

!SpMorphicNotebookAdapter methodsFor: 'updating' stamp: ''!
updatePagesWith: aCollection
	| pagesToRemove |
	
	self widget ifNil: [ ^ self ].
		
	pagesToRemove := self widget pages reject: [ :pageMorph | 
		aCollection anySatisfy: [ :page | page = pageMorph model ] ].
	pagesToRemove do: [ :pageMorph | self widget removePage: pageMorph ].
	aCollection 
		reject: [ :page | self widget hasPageWithModel: page ] 
		thenDo: [ :page | self addPage: page to: self widget ]! !

!SpMorphicNotebookAdapter methodsFor: 'initialization' stamp: ''!
addFocusRotationKeyBindings

	self widget tabSelectorMorph
		bindKeyCombination: Character tab asKeyCombination 
			toAction: [ self focusNext ];
		bindKeyCombination: Character tab shift asKeyCombination 
			toAction: [ self focusPrevious ]! !

!SpMorphicNotebookAdapter methodsFor: 'factory' stamp: ''!
addPage: aNotebookPage to: aNotebook

	aNotebook 
		addLazyPage: [ self buildContentForPage: aNotebookPage ] 
		label: (self buildLabelForPage: aNotebookPage)
		model: aNotebookPage.
	"Since I do not have the page added, I need to take it from the list. But I know 
	 this will be the last added :)"
	aNotebook pages last model: aNotebookPage! !

!SpMorphicNotebookAdapter methodsFor: 'private' stamp: ''!
isBackendUpdating

	^ backendUpdating! !

!SpMorphicNotebookAdapter methodsFor: 'updating' stamp: ''!
updatePageTitle: aPage

	self widgetDo: [ :w |
		w 
			relabelPage: (w pageWithModel: aPage) 
			with: (self buildLabelForPage: aPage) ]! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpMorphicNotebookAdapter class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpMorphicNotebookAdapter class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpMorphicNotebookAdapter class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpMorphicNotebookAdapter class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpMorphicNotebookAdapter class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpMorphicNotebookAdapter class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicNotebookAdapter class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpMorphicNotebookAdapter class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpMorphicNotebookAdapter class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpMorphicNotebookAdapter class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicNotebookAdapter class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpMorphicNotebookAdapter class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpMorphicNotebookAdapter class methodsFor: 'table defaults' stamp: ''!
cellInset 

	^ 3! !

!SpMorphicNotebookAdapter class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpMorphicNotebookAdapter class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpMorphicNotebookAdapter class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpMorphicNotebookAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpMorphicNotebookAdapter class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpMorphicNotebookAdapter class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpMorphicNumberInputFieldAdapter commentStamp: ''!
I am the adapter used to display a NumberInputFieldPresenter with Morphic.

I will display a text morph accepting only number from the user. The up and down keys will increase or decrease the value of the input. On top of that I also have two icons. One with an arrow up and one with an arrow down.!
!SpMorphicNumberInputFieldAdapter methodsFor: 'actions' stamp: ''!
decreaseValueOf: aTextMorph

	aTextMorph setText: (self decreasedValueFrom: aTextMorph getText)! !

!SpMorphicNumberInputFieldAdapter methodsFor: 'actions' stamp: ''!
increasedValueFrom: aString
	"I get the current value from a aString and increase it by the step.
	
	In case of a float we need to print only up to a number of decimals even if the step is of the right number of decimals because float do not have a good precision."

	| newValue |
	newValue := aString ifEmpty: [ 0 ] ifNotEmpty: [ :text | text asNumber + self model climbRate ].
	newValue := self inBounds: newValue.
	
	^ self model isInteger
		ifTrue: [ newValue rounded asString ]
		ifFalse: [ newValue printShowingDecimalPlaces: self model digits ]! !

!SpMorphicNumberInputFieldAdapter methodsFor: 'events' stamp: ''!
keystroke: aRubricEvent

	aRubricEvent event keyCharacter = Character arrowUp
		ifTrue: [ self increaseValueOf: aRubricEvent morph.
			^ true ].

	aRubricEvent event keyCharacter = Character arrowDown
		ifTrue: [ self decreaseValueOf: aRubricEvent morph.
			^ true ].
		
	^ false! !

!SpMorphicNumberInputFieldAdapter methodsFor: 'ensure bounds' stamp: ''!
inferiorToMaximum: aNumber

	^ self model maximum ifNil: [ aNumber ] ifNotNil: [ :max | aNumber min: max ]! !

!SpMorphicNumberInputFieldAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	| textMorph iconsContainer |	
	textMorph := super buildWidget.
	textMorph announcer when: RubKeystroke send: #keystroke: to: self.

	"We add an arrow up and arrow down to the morph to match common input number implementations"	
	iconsContainer := Morph new
		extent: 12 @ 12;
		color: Color transparent;
		changeTableLayout;
		listDirection: #topToBottom;
		addMorph: (self newIconButtonAction: #decreaseValueOf: with: textMorph iconSelector: #arrowDoubleDownIcon);
		addMorph: (self newIconButtonAction: #increaseValueOf: with: textMorph iconSelector: #arrowDoubleUpIcon);
		yourself.

	"With the layout frame I set next to it, the arrows will be at the top right of the text morph. We should be able to make it vertically centered but I don't know how to do that with morphs. If someone knows, please do :)"
	textMorph
		changeProportionalLayout;
		addMorph: iconsContainer
			fullFrame:
			(LayoutFrame identity
				bottomFraction: 0;
				leftFraction: 1;
				topOffset: 4;
				leftOffset: -25;
				yourself).

	^ textMorph! !

!SpMorphicNumberInputFieldAdapter methodsFor: 'ensure bounds' stamp: ''!
superiorToMinimum: aNumber

	^ self model minimum
		  ifNil: [ aNumber ]
		  ifNotNil: [ :min | aNumber max: min ]! !

!SpMorphicNumberInputFieldAdapter methodsFor: 'actions' stamp: ''!
increaseValueOf: aTextMorph

	aTextMorph setText: (self increasedValueFrom: aTextMorph getText)! !

!SpMorphicNumberInputFieldAdapter methodsFor: 'testing' stamp: ''!
shouldAccept: aText
	| regex value |
	aText ifEmpty: [ ^ true ].

	"First we check if it matches the number type and the number of digits if it is a float."
	regex := self model isInteger
		ifTrue: [ '(\-)?[0-9]*' ]
		ifFalse: [ '(\-)?[0-9]+(\.[0-9]{0,' , self model digits asString , '})?' ].
		
	(regex asRegex matches: aText) ifFalse: [ ^ false ].

	"Then we need to verify the min and max value"
	value := aText asNumber.
	self model minimum ifNotNil: [ :min | value < min ifTrue: [ ^ false ] ].
	self model maximum ifNotNil: [ :max | value > max ifTrue: [ ^ false ] ].
	
	^ true
	! !

!SpMorphicNumberInputFieldAdapter methodsFor: 'ensure bounds' stamp: ''!
inBounds: aNumber
	"I return a the closest number from my input that is inside the bounds defined by the user.
	
	For example with 10 as min and 20 as max I will return:
	
	- Input: 15 Result: 15
	- Input: 8  Result: 10
	- Input: 25 Result: 20"
	
	^ self inferiorToMaximum: (self superiorToMinimum: aNumber)! !

!SpMorphicNumberInputFieldAdapter methodsFor: 'actions' stamp: ''!
decreasedValueFrom: aString
	"I get the current value from a string and decrease it by the step.
	
	In case of a float we need to print only up to a number of decimals even if the step is of the right number of decimals because float do not have a good precision."

	| newValue |
	newValue := aString ifEmpty: [ 0 ] ifNotEmpty: [ :text | text asNumber - self model climbRate ].
	newValue := self inBounds: newValue.
	
	^ self model isInteger
		ifTrue: [ newValue rounded asString ]
		ifFalse: [ newValue printShowingDecimalPlaces: self model digits ]! !

!SpMorphicNumberInputFieldAdapter methodsFor: 'factory' stamp: ''!
newIconButtonAction: aSymbol with: textMorph iconSelector: anIconSymbol

	^ IconicButtonMorph new
		  target: self;
		  actionSelector: aSymbol;
		  arguments: { textMorph };
		  labelGraphic: (self iconNamed: anIconSymbol);
		  color: Color transparent;
		  extent: 16 @ 8;
		  borderWidth: 0;
		  yourself! !

!SpMorphicNumberInputFieldAdapterTest commentStamp: ''!
I am a test class for the MorphicNumberInputFieldAdapter.!
!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testShouldAcceptInteger
	presenter
		beInteger;
		minimum: 90;
		maximum: 120.

	self assert: (adapter shouldAccept: '').
	self assert: (adapter shouldAccept: '100').
	self deny: (adapter shouldAccept: '100.10').
	self deny: (adapter shouldAccept: '80').
	self deny: (adapter shouldAccept: '150').
	self deny: (adapter shouldAccept: 'string').
	self deny: (adapter shouldAccept: '10string')! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testShouldAcceptNegativeFloat
	presenter
		beFloat;
		maximum: 120;
		digits: 3;
		minimum: -150.
	
	self assert: (adapter shouldAccept: '-100.1').
	self deny: (adapter shouldAccept: '-200.1')! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testShouldAcceptIntegerWithoutMinMax
	presenter
		beInteger;
		maximum: nil;
		minimum: nil.
		
	self assert: (adapter shouldAccept: '').
	self assert: (adapter shouldAccept: '100').
	self deny: (adapter shouldAccept: '100.10').
	self assert: (adapter shouldAccept: '80').
	self assert: (adapter shouldAccept: '150').
	self deny: (adapter shouldAccept: 'string').
	self deny: (adapter shouldAccept: '10string')! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testShouldAccept
	presenter
		beInteger;
		minimum: 90;
		maximum: 120.

	self assert: (adapter shouldAccept: '').
	self assert: (adapter shouldAccept: '100').
	self deny: (adapter shouldAccept: 'string').
	self deny: (adapter shouldAccept: '10string')! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testShouldAcceptFloatWithMaxDigits
	presenter
		beFloat;
		minimum: 0;
		maximum: 120;
		digits: 5.
		
	self assert: (adapter shouldAccept: '1.1111').
	self assert: (adapter shouldAccept: '1.11111').
	self deny: (adapter shouldAccept: '1.111111')! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testShouldAcceptNegativeInteger
	presenter
		beInteger;
		maximum: 120;
		minimum: -150.
	
	self assert: (adapter shouldAccept: '-100').
	self deny: (adapter shouldAccept: '-200')! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testShouldAcceptFloat
	presenter
		beFloat;
		minimum: 90;
		maximum: 120;
		digits: 3.

	self assert: (adapter shouldAccept: '').
	self assert: (adapter shouldAccept: '100').
	self assert: (adapter shouldAccept: '100.1').
	self deny: (adapter shouldAccept: '80.1').
	self deny: (adapter shouldAccept: '150.1').
	self deny: (adapter shouldAccept: 'string').
	self deny: (adapter shouldAccept: '10string').
	self deny: (adapter shouldAccept: '100.1111')! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testDecreasedValueFrom
	presenter
		beInteger;
		minimum: 80;
		climbRate: 2.
		
	self assert: (adapter decreasedValueFrom: '85') equals: '83'.
	self assert: (adapter decreasedValueFrom: '81') equals: '80'.
	self assert: (adapter decreasedValueFrom: '80') equals: '80'.
	
	presenter
		beFloat;
		climbRate: 2.5;
		digits: 1.

	self assert: (adapter decreasedValueFrom: '85') equals: '82.5'.
	self assert: (adapter decreasedValueFrom: '81') equals: '80.0'! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testInBounds
	presenter maximum: nil.
	presenter minimum: nil.
	self assert: (adapter inBounds: 100) equals: 100.
	self assert: (adapter inBounds: 160) equals: 160.
	self assert: (adapter inBounds: 80) equals: 80.
	presenter maximum: 150.
	presenter minimum: 90.
	self assert: (adapter inBounds: 100) equals: 100.
	self assert: (adapter inBounds: 160) equals: 150.
	self assert: (adapter inBounds: 80) equals: 90! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'helpers' stamp: ''!
actualClass
	^ SpMorphicNumberInputFieldAdapter! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testIncreasedValueFrom
	presenter
		beInteger;
		maximum: 100;
		climbRate: 2.
		
	self assert: (adapter increasedValueFrom: '85') equals: '87'.
	self assert: (adapter increasedValueFrom: '99') equals: '100'.
	self assert: (adapter increasedValueFrom: '100') equals: '100'.
	
	presenter
		beFloat;
		climbRate: 2.5;
		digits: 1.

	self assert: (adapter increasedValueFrom: '85') equals: '87.5'.
	self assert: (adapter increasedValueFrom: '99') equals: '100.0'! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testShouldAcceptFloatWithoutMinMax
	presenter
		beFloat;
		digits: 3;
		maximum: nil;
		minimum: nil.
		
	self assert: (adapter shouldAccept: '').
	self assert: (adapter shouldAccept: '100').
	self assert: (adapter shouldAccept: '100.1').
	self assert: (adapter shouldAccept: '80.1').
	self assert: (adapter shouldAccept: '150.1').
	self deny: (adapter shouldAccept: 'string').
	self deny: (adapter shouldAccept: '10string')! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testSuperiorToMinimum
	presenter minimum: nil.
	self assert: (adapter superiorToMinimum: 100) equals: 100.
	presenter minimum: 90.
	self assert: (adapter superiorToMinimum: 100) equals: 100.
	presenter minimum: 120.
	self assert: (adapter superiorToMinimum: 100) equals: 120! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testInferiorToMaximum
	presenter maximum: nil.
	self assert: (adapter inferiorToMaximum: 100) equals: 100.
	presenter maximum: 150.
	self assert: (adapter inferiorToMaximum: 100) equals: 100.
	presenter maximum: 90.
	self assert: (adapter inferiorToMaximum: 100) equals: 90! !

!SpMorphicNumberInputFieldAdapterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	presenter := SpNumberInputFieldPresenter new.
	adapter := self actualClass adapt: presenter! !

!SpMorphicOverlayAdapter commentStamp: ''!
I'm a morphic adapter for an overlay layout. I contain a main widget and an overlay that superposes it.

Internally, I create a normal panel morph with a SpMorphicOverlayLayout.
The SpMorphicOverlayLayout collaborates with the layout's constraints to decide wether a child is the main widget or an overlay widget.!
!SpMorphicOverlayAdapter methodsFor: 'protocol' stamp: ''!
layout: aLayout

	widget ifNil: [ 
		widget := self newPanel
          layoutPolicy: SpMorphicOverlayLayout new;
          yourself ].

	aLayout whenChildrenAddedDo: [ :ann | 
		self
			basicAdd: ann child
			constraints: (aLayout constraintsFor: ann child)
			to: widget ].

	aLayout whenChildrenRemovedDo: [ :ann | self removeChild: ann child ].

	super layout: aLayout! !

!SpMorphicOverlayAdapter methodsFor: 'protocol' stamp: ''!
addConstraints: constraints toChild: childMorph
	"Adds constraits by child"

	| theMorph |
	theMorph := childMorph.
	"Keep constraints to layout usage"
	theMorph setProperty: #constraints toValue: constraints. 
	
	^ theMorph ! !

!SpMorphicOverlayAdapter methodsFor: 'accessing' stamp: ''!
children
	
	^ widget submorphs! !

!SpMorphicOverlayAdapter methodsFor: 'protocol' stamp: ''!
basicAdd: aPresenter constraints: constraints to: aWidget
	| childMorph |
	
	childMorph := self buildMorph: aPresenter constraints: constraints.	
	aWidget addMorph: childMorph.
	
	^ childMorph! !

!SpMorphicOverlayAdapter methodsFor: 'accessing' stamp: ''!
removeChild: aPresenter

	| morph |
	morph := aPresenter adapter widget.
	widget removeMorph: morph! !

!SpMorphicOverlayLayout commentStamp: ''!
I'm a morphic layout that superposes morphs.
I have a main submorph and an overlay that is drawn on top.
To decide how to lay out each of these submorphs, they need a property named #constraints with a constraint object.
If the constraints object indicates it is an overlay object, it will be rendered on top.
Otherwise, it will be rendered first in the bottom.

Example

p := PanelMorph new
	hResizing: #spaceFill;
	vResizing: #spaceFill;
	layoutPolicy: SpMorphicOverlayLayout new.

mainMorph := Morph new
	hResizing: #spaceFill;
	vResizing: #spaceFill;
	setProperty: #constraints
	toValue: SpOverlayConstraints new.

overlay := Morph new
	hResizing: #spaceFill;
	vResizing: #spaceFill;
	color: Color green;
	setProperty: #constraints
	toValue: (SpOverlayConstraints new beOverlay; yourself);
	yourself.

p
	addMorphBack: overlay;
	addMorphBack: mainMorph.
p openInWindow!
!SpMorphicOverlayLayout methodsFor: 'layout' stamp: ''!
layout: aMorph in: layoutBounds
	aMorph submorphsDo: [ :m | | constraints |
		constraints := m valueOfProperty: #constraints.
		(m visible and: [ constraints isOverlay not ])
			ifTrue: [ m bounds: layoutBounds ].
		(m visible and: [ constraints isOverlay ])
			ifTrue: [ | morphBounds left top newBounds |
				morphBounds := layoutBounds area > (0@0 corner: m extent) area
					ifTrue: [ layoutBounds origin corner: (layoutBounds origin + m extent) ]
					ifFalse: [ layoutBounds ].
				
				left := (layoutBounds width / 2) - (morphBounds width / 2).
				top := (layoutBounds height / 2) - (morphBounds height / 2).
				newBounds := (layoutBounds origin + (left@top) corner: layoutBounds corner + (left@top)).

				m bounds: newBounds ].
		m visible
			ifFalse: [ m bounds: (0@0 corner: 0@0) ] ]! !

!SpMorphicPaginatorAdapter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self initializeTBackendUpdating! !

!SpMorphicPaginatorAdapter methodsFor: 'private' stamp: ''!
backendDetectCyclesDo: aBlock 

	self isBackendUpdating ifTrue: [ ^ self ].
	^ aBlock value! !

!SpMorphicPaginatorAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| morph |
	
	morph := SpPaginatorMorph new
		addPages: self presenter pages;
		selectPage: self presenter pages size;
		yourself.

	self presenter whenSelectedPageChangedDo: [ :aNumber |
		self backendDetectCyclesDo: [ 
				morph selectPage: aNumber ] ].
	morph whenSelectedPageChangedDo: [ :aNumber |
		self backendUpdatingDo: [ 
			self presenter selectPage: aNumber ] ].
	
	self presenter whenVisiblePagesChangedDo: [ :aNumber |
		self backendDetectCyclesDo: [ 
			morph numberOfPagesShown: aNumber ] ].
	morph whenNumberOfPagesShownChangedDo: [ :aNumber |
		self backendUpdatingDo: [
			self presenter visiblePages: aNumber ] ].
	
	self presenter whenPageAddedDo: [ :anObject | 
		morph 
			addPage: anObject; 
			selectLastPage ].
	self presenter whenPageRemovedDo: [ :anObject |
		anObject 
			ifNotNil: [ morph removePage: anObject ]
			ifNil: [ morph removeAllPages ] ].
		
	morph selectionMorph whenDraggingDo: [ :delta | 
		self presenter dragging: (delta * 100 / widget width) ].

	^ morph! !

!SpMorphicPaginatorAdapter methodsFor: 'private' stamp: ''!
backendUpdatingDo: aBlock 
	| oldStatus |

	oldStatus := backendUpdating.
	backendUpdating := true.
	aBlock ensure: [ 
		backendUpdating := oldStatus ]! !

!SpMorphicPaginatorAdapter methodsFor: 'paginator' stamp: ''!
scrollByDeltaPercent: percent
	| millerWidth millerDelta |
	
	millerWidth := self widget scroller localSubmorphBounds width.
	millerDelta := millerWidth * (percent / 100).
	self widget scroller offset: (self widget scroller offset x + millerDelta)@0! !

!SpMorphicPaginatorAdapter methodsFor: 'initialization' stamp: ''!
initializeTBackendUpdating

	backendUpdating := false! !

!SpMorphicPaginatorAdapter methodsFor: 'private' stamp: ''!
isBackendUpdating

	^ backendUpdating! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpMorphicPaginatorAdapter class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpMorphicPaginatorAdapter class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpMorphicPaginatorAdapter class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpMorphicPaginatorAdapter class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpMorphicPaginatorAdapter class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpMorphicPaginatorAdapter class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicPaginatorAdapter class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpMorphicPaginatorAdapter class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpMorphicPaginatorAdapter class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpMorphicPaginatorAdapter class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicPaginatorAdapter class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpMorphicPaginatorAdapter class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpMorphicPaginatorAdapter class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpMorphicPaginatorAdapter class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpMorphicPaginatorAdapter class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpMorphicPaginatorAdapter class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpMorphicPaginatorAdapter class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpMorphicPaginatorAdapter class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpMorphicPanedAdapter commentStamp: ''!
I'm an adapter for Paned Layouts.
A paned layout will split (horizontally or vertically) a panel and allow its resize. !
!SpMorphicPanedAdapter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	children := OrderedCollection new! !

!SpMorphicPanedAdapter methodsFor: 'factory' stamp: ''!
layout: aLayout

	layout := aLayout.
	widget ifNil: [ 
		widget := aLayout direction newWidgetOn: self.
		widget layoutPolicy position: aLayout positionOfSlider.
		self selector: self splitterNewSelector ].

	layout whenChildrenAddedDo: [ :ann | 
		self
			basicAdd: ann child
			constraints: (layout constraintsFor: ann child)
			to: widget ].

	layout whenChildrenRemovedDo: [ :ann | self removeChild: ann child ].
	
	super layout: aLayout! !

!SpMorphicPanedAdapter methodsFor: 'factory' stamp: ''!
newPanel

	^ super newPanel
		layoutPolicy: SpMorphicPanedLayout new;
		yourself! !

!SpMorphicPanedAdapter methodsFor: 'adding/removing' stamp: ''!
addConstraints: constraints toChild: childMorph
	"Adds constraits by child"
	| theMorph |	
	
	theMorph := childMorph.
	"Keep constraints to layout usage"
	theMorph setProperty: #constraints toValue: constraints. 
	
	^ theMorph ! !

!SpMorphicPanedAdapter methodsFor: 'accessing' stamp: ''!
children

	^ children! !

!SpMorphicPanedAdapter methodsFor: 'accessing' stamp: ''!
direction

	^ self layout direction! !

!SpMorphicPanedAdapter methodsFor: 'factory' stamp: ''!
newVertical

	^ self newPanel 
		listDirection: #topToBottom;
		yourself	! !

!SpMorphicPanedAdapter methodsFor: 'private' stamp: ''!
splitterNewSelector

	^ layout isHorizontal
		  ifTrue: [ #newHorizontal ]
		  ifFalse: [ #newVertical ]! !

!SpMorphicPanedAdapter methodsFor: 'adding/removing' stamp: ''!
basicAdd: aPresenter constraints: constraints to: aPanel
	| childMorph position |

	childMorph := self buildMorph: aPresenter constraints: constraints.	
	children add: childMorph.

	position := layout children indexOf: (aPresenter isSpLayout
		ifTrue: [ aPresenter layout ]
		ifFalse: [ aPresenter ]).
	position = 0 ifTrue: [ 
		"Not found, check for symbols. If is symbol, I need to get the presenter"
		layout children withIndexDo: [ :each :index | 
			(each isSymbol and: [ (layout presenter presenterAt: each) = aPresenter ]) 
				ifTrue: [ position := index ] ].
		"If I still do not find it, I may be adding dynamically. Check if there is room and add it"
		position = 0 ifTrue: [ 
			layout children size < 2 ifTrue: [
				position := layout children size + 1 ].
			position = 0 ifTrue: [  
				self error: 'Can''t find a child.' ] ] ]. 
	
	(position = 1)
		ifTrue: [ aPanel addMorphFront: childMorph ]
		ifFalse: [ aPanel addMorphBack: childMorph ].
	self addSplitterIn: aPanel for: childMorph.
	
	^ childMorph! !

!SpMorphicPanedAdapter methodsFor: 'adding/removing' stamp: ''!
removeChild: aPresenter
	
	| morph |
	morph := aPresenter adapter widget.
	children remove: morph.
	widget removeMorph: morph! !

!SpMorphicPanedAdapter methodsFor: 'factory' stamp: ''!
newHorizontal

	^ self newPanel 
		listDirection: #leftToRight;
		yourself! !

!SpMorphicPanedAdapter methodsFor: 'private' stamp: ''!
resizingSetSelector

	^ layout isHorizontal
		  ifTrue: [ #hResizing: ]
		  ifFalse: [ #vResizing: ]! !

!SpMorphicPanedAdapter methodsFor: 'adding/removing' stamp: ''!
addSplitterIn: aPanel for: childMorph

	aPanel submorphs size = 1 ifFalse: [ ^ self ].
	aPanel addMorphBack: self direction newSplitter! !

!SpMorphicPanedLayout commentStamp: ''!
I'm a table layout for PanedLayouts. 
I add some posibilities to layouting (like defining the initial position in proportional 
numbers instead a fixed number).

This is needed because sometimes I want to express a position like: 

SpecPanedLayout new 
	position: 80 percent;
	...
	
instead a fixed number I may change in other places.
 !
!SpMorphicPanedLayout methodsFor: 'private' stamp: ''!
ensureHeightPosition: aMorph in: aRect
	| firstMorph height |

	self position ifNil: [ ^ self ].

	firstMorph := aMorph submorphs first.
	firstMorph vResizing = #rigid 
		ifFalse: [ firstMorph vResizing: #rigid ].
	height := self heightPositionIn: aRect extent.
	firstMorph height = height
		ifFalse: [ firstMorph height: height ]! !

!SpMorphicPanedLayout methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!SpMorphicPanedLayout methodsFor: 'private' stamp: ''!
layoutLeftToRight: aMorph in: newBounds

	self ensureWidthPosition: aMorph in: newBounds.
	super layoutLeftToRight: aMorph in: newBounds! !

!SpMorphicPanedLayout methodsFor: 'private' stamp: ''!
ensureWidthPosition: aMorph in: aRect
	| firstMorph width |

	self position ifNil: [ ^ self ].

	firstMorph := aMorph submorphs first.
	firstMorph hResizing = #rigid 
		ifFalse: [ firstMorph hResizing: #rigid ].
	width := self widthPositionIn: aRect extent.
	firstMorph width = width 
		ifFalse: [ firstMorph width: width ].
	 ! !

!SpMorphicPanedLayout methodsFor: 'private' stamp: ''!
layoutTopToBottom: aMorph in: newBounds

	self ensureHeightPosition: aMorph in: newBounds.
	super layoutTopToBottom: aMorph in: newBounds! !

!SpMorphicPanedLayout methodsFor: 'accessing' stamp: ''!
position: anObject
	position := anObject! !

!SpMorphicPanedLayout methodsFor: 'private' stamp: ''!
widthPositionIn: aPoint

	^ self position < 1
		  ifTrue: [ (aPoint x * self position) asInteger ]
		  ifFalse: [ self position ]! !

!SpMorphicPanedLayout methodsFor: 'testing' stamp: ''!
isHorizontal

	^ (properties listDirection == #topToBottom 
		or: [ properties listDirection == #bottomToTop ]) not! !

!SpMorphicPanedLayout methodsFor: 'accessing' stamp: ''!
resetPosition

	position := nil! !

!SpMorphicPanedLayout methodsFor: 'private' stamp: ''!
heightPositionIn: aPoint 

	^ self position < 1 
		ifTrue: [ (aPoint y * self position) asInteger ]
		ifFalse: [ self position ]! !

!SpMorphicPanedLayout methodsFor: 'accessing' stamp: ''!
preservePositionProportionOn: layoutedMorph

	| referenceMorph |
	referenceMorph := layoutedMorph submorphs first.
	position := self isHorizontal
		            ifTrue: [ (referenceMorph width * 100 / layoutedMorph width) asInteger percent ]
		            ifFalse: [ (referenceMorph height * 100 / layoutedMorph height) asInteger percent ]! !

!SpMorphicPanedLayoutTest methodsFor: 'tests' stamp: ''!
testListTakesAssignedSpace
	| list |

	(instance := SpPresenter new) 
		layout: (SpPanedLayout newTopToBottom 
			add: (SpPanedLayout newLeftToRight
				add: (list := instance newTree);
				add: (instance newLabel);
				yourself);
			add: instance newText;
			yourself).
		
	list items: #(a).
	
	instance openWithSpec.

	self 
		assert: list adapter widget container width 
		equals: list adapter widget width! !

!SpMorphicPanedLayoutTest methodsFor: 'tests' stamp: ''!
testReplacePresenter
	| presenter p1 p2 p3 widget |
	
	presenter := SpPresenter new.
	presenter application: SpApplication new.

	presenter layout: (SpPanedLayout newLeftToRight 
		addFirst: (p1 := presenter newButton label: '1');
		addSecond: (p2 := presenter newButton label: '2');
		yourself).
	
	[ presenter openWithSpec ]
	ensure: [ presenter window close ].

	p3 := presenter newLabel label: 'Test'.

	presenter layout addFirst: p3.
	
	widget := presenter adapter widget.
	self assert: widget submorphs size equals: 3 "one plus for the slider".
	self assert: widget submorphs first equals: p3 adapter widget
	! !

!SpMorphicPanedLayoutTest methodsFor: 'running' stamp: ''!
tearDown

	instance ifNotNil: [ 
		instance window close.
		instance := nil ].
	super tearDown! !

!SpMorphicPatchAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| newWidget |
	
	newWidget := SpRubScrolledTextMorph new
		beWrapped;
		enabled: self enabled;
		autoAccept: true;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		setBalloonText: self help;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		hScrollbarShowWhenNeeded;
		yourself.
	
	self setEditable: false to: newWidget.
	self setEditingModeFor: newWidget.
	self setPatchTo: newWidget.
	self presenter whenPatchChangedDo: [ :aPatchModel | 
		self setPatch: aPatchModel ].
	
	newWidget withRuler: (SpMorphicLineMarkDisplayer new
		adapter: self;
		yourself).
	newWidget textArea withDecorator: (SpMorphicPatchLineDecorator new
		adapter: self;
		yourself).
	
	^ newWidget! !

!SpMorphicPatchAdapter methodsFor: 'factory' stamp: ''!
setPatch: aPatchModel
	
	self widgetDo: [ :w |
		self setPatch: aPatchModel patch to: w ]! !

!SpMorphicPatchAdapter methodsFor: 'accessing' stamp: ''!
lineMarks

	^ lineMarks ifNil: [ #() ]! !

!SpMorphicPatchAdapter methodsFor: 'private accessing' stamp: ''!
setPatch: patch to: aWidget 
	| visitor |
	
	visitor := SpMorphicPatchLineVisitor new
		visitPatch: patch;
		yourself.	
	
	lineMarks := visitor lineMarks.

	self 
		setText: visitor contents
		to: aWidget! !

!SpMorphicPatchAdapter methodsFor: 'factory' stamp: ''!
setEditingModeFor: textArea

	textArea beForPlainText! !

!SpMorphicPatchAdapter methodsFor: 'factory' stamp: ''!
setEditable: aBoolean to: aWidget

	aWidget textArea readOnly: aBoolean not! !

!SpMorphicPatchAdapter methodsFor: 'private accessing' stamp: ''!
setPatchTo: aWidget

	(self presenter model isNil 
		or: [ self presenter model isEmpty ])
		ifTrue: [  
			self setText: '' to: aWidget. 
			^ self ].
		
	self 
		setPatch: self presenter model patch
		to: aWidget! !

!SpMorphicPatchAdapter methodsFor: 'accessing' stamp: ''!
markAt: aSymbol

	^ self presenter marks at: aSymbol! !

!SpMorphicPatchAdapter methodsFor: 'private accessing' stamp: ''!
setText: text to: aWidget

	aWidget textArea editingState clearUndoManager: nil.
	aWidget setText: text! !

!SpMorphicPatchLineDecorator methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	| lines |

	lines := self paragraph lines.
	self adapter lineMarks do: [ :each | | line bounds | 
		line := lines at: each key.
		bounds := (line topLeft - (self margins left @ 0)) 
			corner: (line bottomRight + (self margins right @ 0)).
		aCanvas 
			fillRectangle: bounds 
			color: (self markAt: each value) backgroundColor ]! !

!SpMorphicPatchLineDecorator methodsFor: 'accessing' stamp: ''!
adapter

	^ adapter! !

!SpMorphicPatchLineDecorator methodsFor: 'accessing' stamp: ''!
adapter: anAdapter

	adapter := anAdapter! !

!SpMorphicPatchLineDecorator methodsFor: 'accessing' stamp: ''!
markAt: aSymbol

	^ self adapter markAt: aSymbol! !

!SpMorphicPatchLineDecorator class methodsFor: 'querying' stamp: ''!
key
	^ #patchLineDecorator! !

!SpMorphicPatchLineVisitor methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	lineNumber := 0.
	lineMarks := OrderedCollection new.
	stream := String new writeStream! !

!SpMorphicPatchLineVisitor methodsFor: 'accessing' stamp: ''!
lineMarks

	^ lineMarks! !

!SpMorphicPatchLineVisitor methodsFor: 'accessing' stamp: ''!
contents

	^ stream contents! !

!SpMorphicPatchLineVisitor methodsFor: 'visiting' stamp: ''!
visitDelete: aPatchElement

	lineNumber := lineNumber + 1.
	lineMarks add: lineNumber -> #delete.
	stream << aPatchElement element << String cr! !

!SpMorphicPatchLineVisitor methodsFor: 'visiting' stamp: ''!
visitMatch: aPatchElement

	lineNumber := lineNumber + 1.
	stream << aPatchElement element << String cr! !

!SpMorphicPatchLineVisitor methodsFor: 'visiting' stamp: ''!
visitInsert: aPatchElement

	lineNumber := lineNumber + 1.
	lineMarks add: lineNumber -> #insert.
	stream << aPatchElement element << String cr! !

!SpMorphicPopoverAdapter commentStamp: ''!
I'm the adapter used to bridge a Popover and its morphic representation.!
!SpMorphicPopoverAdapter methodsFor: 'api' stamp: ''!
popupPointingTo: aRectangle

	self widgetDo: [ :w |
		self applyStyle: w.
		w popupPointingTo: aRectangle ]! !

!SpMorphicPopoverAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| panelMorph |
	
	panelMorph := SpPopoverMorph new.
	self addModelTo: panelMorph.
	
	^ panelMorph! !

!SpMorphicPopoverAdapter methodsFor: 'api' stamp: ''!
popup

	self widgetDo: [ :w | 
		self applyStyle: w.
		w popup ]! !

!SpMorphicPopoverAdapter methodsFor: 'factory' stamp: ''!
contentPresenter
	
	^ self presenter presenter! !

!SpMorphicPopoverAdapter methodsFor: 'factory' stamp: ''!
addModelTo: aMorph

	aMorph contentMorph: self presenterWidget.	
	aMorph beRelativeTo: self presenter relativeTo adapter widget. 	
	self setPopoverPositionTo: aMorph.
	
	self presenter whenPresenterChangedDo: [
		aMorph contentMorph: self presenterWidget ]! !

!SpMorphicPopoverAdapter methodsFor: 'api' stamp: ''!
dismiss 

	self widgetDo: [ :w | w popdown ]! !

!SpMorphicPopoverAdapter methodsFor: 'factory' stamp: ''!
presenterWidget

	self contentPresenter buildWithSpec.
	self contentPresenter adapter applyStyle.
	^ self contentPresenter adapter widget! !

!SpMorphicPopoverAdapter methodsFor: 'factory' stamp: ''!
setPopoverPositionTo: gtkPopover
		
	^ self presenter position applyTo: gtkPopover! !

!SpMorphicPopoverAdapter class methodsFor: 'accessing' stamp: ''!
defaultItemSeparation
	
	^ 3@0! !

!SpMorphicPopoverAdapter class methodsFor: 'accessing' stamp: ''!
defaultHeight

	^ 30! !

!SpMorphicProgressBarAdapter commentStamp: ''!
Description
--------------------

I am a Morphic adapter to bridge the ProgressBarPresenter and the ProgressBarMorph.!
!SpMorphicProgressBarAdapter methodsFor: 'updating' stamp: ''!
updateState

	self progressBarState customizeMorphicBar: progressBar
! !

!SpMorphicProgressBarAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| panel |
	
	panel := Morph new
		changeProportionalLayout;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		yourself.

	progressBar := (self progressBarState progressBarMorph from: 0 to: 1)
		     changeProportionalLayout;
		     hResizing: #spaceFill;
		     vResizing: #spaceFill;
		     yourself.

	self progressBarState customizeMorphicBar: progressBar.

	panel 
		addMorph: progressBar
		fullFrame: LayoutFrame identity.
	
	^ panel! !

!SpMorphicProgressBarAdapter methodsFor: 'accessing' stamp: ''!
progressBarState

	^ self model state! !

!SpMorphicRadioButtonAdapter commentStamp: ''!
I am the adapter used to link a RadioButtonPresenter with a CheckboxMorph (which can also act as a radio button)!
!SpMorphicRadioButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	| radioButton |
	self presenter isInitialStateSet ifFalse: [ 
		"initial state is false, set all associated buttons to false too"
		self presenter property: #state rawValue: false.
		self presenter associatedRadioButtons do: [ :each |
			each property: #state rawValue: false ] ].

	radioButton := CheckboxMorph new
		on: self 
			selected: #state 
			changeSelected: #state:;
		getEnabledSelector: #enabled;
		label: self getLabelText;
		labelClickable: self labelClickable;
		beRadioButton;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		setBalloonText: self getHelpText;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		yourself.
		
	self presenter whenLabelChangedDo: [ :newLabel | 
		radioButton label: (newLabel ifNotNil: [ :aString | 
			aString localizedForPresenter: self presenter ]) ].
	self presenter whenChangedDo: [ radioButton updateSelection ].

	^ radioButton! !

!SpMorphicRadioButtonAdapter methodsFor: 'widget API' stamp: ''!
state: aBoolean

	^ self presenter state: aBoolean! !

!SpMorphicRadioButtonAdapter methodsFor: 'widget API' stamp: ''!
labelClickable

	^ self presenter labelClickable! !

!SpMorphicRadioButtonAdapter methodsFor: 'factory' stamp: ''!
getHelpText

	^ self presenter help ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicRadioButtonAdapter methodsFor: 'simulating' stamp: ''!
clicked
	
	widget toggleSelected! !

!SpMorphicRadioButtonAdapter methodsFor: 'widget API' stamp: ''!
state

	^ self presenter state! !

!SpMorphicRadioButtonAdapter methodsFor: 'private' stamp: ''!
getLabelText

	^ self presenter label ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicRadioButtonAdapter methodsFor: 'widget API' stamp: ''!
label

	^ self getLabelText! !

!SpMorphicRoassalAdapter commentStamp: ''!
I am bridging RoassalPresenter and RTView!
!SpMorphicRoassalAdapter methodsFor: 'scripting actions' stamp: ''!
applyScript
	| extent |
	extent := canvas extent.
	self freeCanvas.
	self basicApplyScript.
	canvas extent: extent.
	! !

!SpMorphicRoassalAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ RSCanvas new createMorph! !

!SpMorphicRoassalAdapter methodsFor: 'initialization' stamp: ''!
adapt: aComposableModel
	super adapt: aComposableModel.
	canvas := widget roassalCanvas.
	self model currentCanvas ifNotNil: [ :aCanvas |
		widget canvas: aCanvas.
		aCanvas 
			morph: widget;
			extent: widget extent.
		canvas := aCanvas.
		 ].
	widget
		setProperty: #model toValue: self;
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	self basicApplyScript.! !

!SpMorphicRoassalAdapter methodsFor: 'initialization' stamp: ''!
release
	self class instVarNames do: [ :n | self instVarNamed: n put: nil ]! !

!SpMorphicRoassalAdapter methodsFor: 'scripting actions' stamp: ''!
freeCanvas
	| temp |
	temp := self buildWidget.
	canvas := temp roassalCanvas.
	widget canvas: canvas.
	canvas morph: widget.
	canvas extent: widget extent.! !

!SpMorphicRoassalAdapter methodsFor: 'scripting actions' stamp: ''!
basicApplyScript
	self model script value: canvas.
	self model canvas: canvas.
	self widgetDo: #startStepping.
	canvas when: RSMouseEnter do: [ widget takeKeyboardFocus ].! !

!SpMorphicRoassalAdapter class methodsFor: 'class initialization' stamp: ''!
initialize 

	"we need to reset the cached adapter bindigns"
	SpNullApplication reset! !

!SpMorphicRootItemsStrategy methodsFor: 'accessing' stamp: ''!
isMatching: anItem

	^ dataSource model 
		performSearch: anItem data 
		matching: pattern! !

!SpMorphicScrollableAdapter commentStamp: ''!
I'm a morphic adapter for a scrollable layout. I contain a main widget that takes as much space as he wants and I add scrolling to it.

Internally, I create a GeneralScrollPane.
When I'm empty, I set the GeneralScrollPane's to an empty panel morph which I keep around to know if I'm empty or not.!
!SpMorphicScrollableAdapter methodsFor: 'protocol' stamp: ''!
layout: aLayout

	emptyLayoutMarker := PanelMorph new
		                     hResizing: #spaceFill;
		                     vResizing: #spaceFill;
		                     yourself.
	widget ifNil: [ 
		widget := GeneralScrollPane new
			          changeScrollerTableLayout;
			          hResizing: #spaceFill;
			          vResizing: #spaceFill;
			          color: Color transparent;
			          borderColor: Color transparent;
			          scrollTarget: emptyLayoutMarker;
			          yourself ].

	aLayout child ifNotNil: [ 
		self basicAdd: aLayout child constraints: (aLayout constraintsFor: aLayout child) to: widget ].

	aLayout whenChildrenAddedDo: [ :ann | 
		self basicAdd: ann child constraints: (aLayout constraintsFor: ann child) to: widget ].

	aLayout whenChildrenRemovedDo: [ :ann | self removeChild: ann child ].

	super layout: aLayout! !

!SpMorphicScrollableAdapter methodsFor: 'protocol' stamp: ''!
addConstraints: constraints toChild: childMorph
	"Adds constraits by child"
	
	| theMorph |	
	theMorph := childMorph.
	"Keep constraints to layout usage"
	theMorph setProperty: #constraints toValue: constraints. 
	
	^ theMorph ! !

!SpMorphicScrollableAdapter methodsFor: 'accessing' stamp: ''!
children

	widget scrollTarget == emptyLayoutMarker
		ifTrue: [ ^ #() ].
	^ { widget scrollTarget }! !

!SpMorphicScrollableAdapter methodsFor: 'protocol' stamp: ''!
basicAdd: aPresenter constraints: constraints to: aPanel

	| childMorph |
	childMorph := self buildMorph: aPresenter constraints: constraints.	
	
	childMorph 
		hResizing: #spaceFill;
		vResizing: #spaceFill.

	aPanel scrollTarget: childMorph.
	
	^ childMorph! !

!SpMorphicScrollableAdapter methodsFor: 'removing' stamp: ''!
removeChild: aPresenter

	self assert: aPresenter adapter widget == widget scrollTarget.
	widget scrollTarget: emptyLayoutMarker! !

!SpMorphicSearchInputFieldAdapter commentStamp: ''!
I'm a morphic adapter to provide a search input field!
!SpMorphicSearchInputFieldAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| textMorph iconsContainer |
	
	textMorph := super buildWidget.

	iconsContainer := Morph new
		extent: 12 @ 12;
		color: Color transparent;
		changeTableLayout;
		listDirection: #topToBottom;
		addMorph: (IconicButtonMorph new
			target: self;
			actionSelector: #clearText;
			labelGraphic: (self iconNamed: #windowCloseInactive);
			color: Color transparent;
			extent: 16 @ 8;
			borderWidth: 0;
			yourself);
		yourself.

	"With the layout frame I set next it, the arrows will be at the top right of the 
	 text morph. We should be able to make it vertically centered but I don't know 
	 how to do that with morphs. If someone knows, please do :)"
	textMorph
		changeProportionalLayout;
		addMorph: iconsContainer
			fullFrame: (LayoutFrame identity
				bottomFraction: 0;
				leftFraction: 1;
				topOffset: 4;
				leftOffset: -25;
				yourself).

	^ textMorph! !

!SpMorphicSearchInputFieldAdapter methodsFor: 'actions' stamp: ''!
clearText

	self widgetDo: [ :w | w setTextWith: '' ] ! !

!SpMorphicSliderAdapter commentStamp: ''!
I am the adapter used to bridget a SliderPresenter and a PluggableSliderMorph!
!SpMorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
value: aValue

	| value |	
	value := aValue isNumber
		ifTrue: [ aValue ] 
		ifFalse: [ 
			(aValue includes: $/)
				ifTrue: [ (NumberParser on: aValue) nextFraction ]
				ifFalse: [ aValue asNumber ] ].

	^ self presenter value: value asFloat! !

!SpMorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
absoluteValue: aFloat

	^ self presenter absoluteValue: aFloat! !

!SpMorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
absoluteValue

	^ self presenter absoluteValue! !

!SpMorphicSliderAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	| preWidget |
	preWidget := PluggableSliderMorph new
		             model: self;
		             getValueSelector: #value;
		             setValueSelector: #value:;
		             value: self absoluteValue;
		             getLabelSelector: #label;
		             max: self max;
		             min: self min;
		             quantum: self quantum;
		             setBalloonText: self help;
		             vResizing: #spaceFill;
		             hResizing: #spaceFill;
		             yourself.
	self presenter isHorizontal ifFalse: [ 
		preWidget := TransformationMorph new asFlexOf: preWidget.
		preWidget transform withAngle: 90 degreesToRadians negated ].

	self presenter whenMinChangedDo: [ :newValue | 
		preWidget min: newValue ].
	self presenter whenMaxChangedDo: [ :newValue | 
		preWidget max: newValue ].
	self presenter whenQuantumChangedDo: [ :newValue | 
		preWidget quantum: newValue ].
	self presenter whenValueChangedDo: [ :newValue | 
		preWidget value: newValue ].

	^ preWidget! !

!SpMorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
min

	^ self presenter min! !

!SpMorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
value
	^ self presenter value! !

!SpMorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
quantum

	^ self model quantum! !

!SpMorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
label

	^ self presenter label! !

!SpMorphicSliderAdapter methodsFor: 'widget API' stamp: ''!
max

	^ self presenter max! !

!SpMorphicSpinnerAdapter commentStamp: ''!
I'm the adapter used to bridge a Spinner and its morphic representation.!
!SpMorphicSpinnerAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ SpSpinnerMorph new! !

!SpMorphicStatusBarAdapter commentStamp: ''!
I'm the adapter used to bridge a StatusBarPresenter and its morphic representation.!
!SpMorphicStatusBarAdapter methodsFor: 'private' stamp: ''!
pushMessage: message to: aMorph

	pushedMessages add: message.
	aMorph 
		removeAllMorphs;
		addMorph: message asStringMorph! !

!SpMorphicStatusBarAdapter methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	pushedMessages := OrderedCollection new! !

!SpMorphicStatusBarAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	| panelMorph |
	panelMorph := PanelMorph new
		              changeTableLayout;
		              listDirection: #leftToRight;
		              hResizing: #spaceFill;
		              vResizing: #spaceFill;
		              cellInset: self class defaultItemSeparation;
		              height: self class defaultHeight;
		              yourself.

	self addModelTo: panelMorph.

	^ panelMorph! !

!SpMorphicStatusBarAdapter methodsFor: 'updating' stamp: ''!
update: aSymbol 

	aSymbol = #pushMessage ifTrue: [ self pushMessage ].
	aSymbol = #popMessage ifTrue: [ self popMessage ].

	^ super update: aSymbol! !

!SpMorphicStatusBarAdapter methodsFor: 'api' stamp: ''!
popMessage

	self widgetDo: [ :w |
		self popMessageFrom: w ]! !

!SpMorphicStatusBarAdapter methodsFor: 'factory' stamp: ''!
addModelTo: aMorph

	self model message ifNotNil: [ :message |
		self pushMessage: message to: aMorph ]! !

!SpMorphicStatusBarAdapter methodsFor: 'api' stamp: ''!
pushMessage

	self widgetDo: [ :w |
		self 
			pushMessage: self model message 
			to: w ]! !

!SpMorphicStatusBarAdapter methodsFor: 'private' stamp: ''!
popMessageFrom: aMorph

	| message |
	pushedMessages ifEmpty: [ ^ self ].
	pushedMessages removeLast.
	message := pushedMessages ifNotEmpty: #last ifEmpty: [ '' ].

	aMorph
		removeAllMorphs;
		addMorph: message asStringMorph! !

!SpMorphicStatusBarAdapter class methodsFor: 'accessing' stamp: ''!
defaultItemSeparation

	^ 5! !

!SpMorphicStatusBarAdapter class methodsFor: 'accessing' stamp: ''!
defaultHeight

	^ 25! !

!SpMorphicTabAdapter methodsFor: 'accessing' stamp: ''!
layout: aLayout

	widget ifNil: [ 
		widget := SpNotebookMorph new
			vResizing: #spaceFill;
			hResizing: #spaceFill;
			yourself ].

	aLayout whenChildrenAddedDo: [ :ann | 
		self
			basicAdd: ann child
			constraints: (aLayout constraintsFor: ann child)
			to: widget ].

	aLayout whenChildrenRemovedDo: [ :ann | self remove: ann child ].

	self presenter whenDisplayDo: [ 
		widget pages ifNotEmpty: [ widget selectedPageIndex: 1 ] ].
	
	super layout: aLayout! !

!SpMorphicTabAdapter methodsFor: 'private' stamp: ''!
addConstraints: constraints toChild: childMorph
	"Adds constraits by child"
	| theMorph |	
	
	theMorph := childMorph.
	"Keep constraints to layout usage"
	theMorph setProperty: #constraints toValue: constraints. 
	
	^ theMorph ! !

!SpMorphicTabAdapter methodsFor: 'accessing' stamp: ''!
children

	^ widget pages! !

!SpMorphicTabAdapter methodsFor: 'private' stamp: ''!
basicAdd: aPresenter constraints: constraints to: aNotebook 
	| page |

	page := SpNotebookPageMorph new 
		lazyPageMorphCreation: [ self buildMorph: aPresenter constraints: constraints ];
		yourself.
	
	aNotebook addPage: page label: constraints label! !

!SpMorphicTabAdapter methodsFor: 'removing' stamp: ''!
remove: aPresenter

	widget removePage: (widget pages 
		detect: [ :each | each actualPageMorph = aPresenter adapter widget ])! !

!SpMorphicTableAdapter commentStamp: ''!
I am the adapter used to realise a SpTablePresenter.
I will create a tree table (using FTTableMorph), using the columns TableColumn* as definitions.

Is important notice here that most of the row/cell creation happens on SpMorphicTableDataSource. Check there for some implementation details.!
!SpMorphicTableAdapter methodsFor: 'testing' stamp: ''!
columns
	^ widget columns! !

!SpMorphicTableAdapter methodsFor: 'private' stamp: ''!
ifSorted: sortedBlock ifNotSorted: notSortedBlock 
	widget columns 
		do: [ :column | | state | 
			column isSorted
				ifTrue: [ 
					state := column sortingStrategy state.
					state isSorted
						ifTrue: [ ^ sortedBlock cull: state ] ] ].
	^ notSortedBlock value! !

!SpMorphicTableAdapter methodsFor: 'selection' stamp: ''!
selectIndex: anInteger 

	(anInteger = 0 and: [ widget selectedIndexes isEmpty ]) ifTrue: [ ^ self ].	
	(widget selectedIndexes includes: anInteger) ifTrue: [^self].
	widget selectIndex: anInteger! !

!SpMorphicTableAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	widget := SpFTTableMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		intercellSpacing: self class intercellSpacing;
		yourself.

	self addModelTo: widget.

	^ widget! !

!SpMorphicTableAdapter methodsFor: 'factory' stamp: ''!
addModelTo: tableMorph

	self model columns do: [ :each |
		tableMorph addColumn: (self newColumnFrom: each) ].
	self ensureAtLeastOneColumnIn: tableMorph.

	self isResizable 
		ifTrue: [ tableMorph beResizable ] 
		ifFalse: [ tableMorph beNotResizable ].
	
	tableMorph setMultipleSelection: self model isMultipleSelection.

	self refreshShowColumnHeaders.
	self refreshWidgetSelection.
	
	self presenter whenShowColumnHeadersChangedDo: [ :showColumns |
		self refreshShowColumnHeaders ].

	self presenter whenModelChangedDo: [ self refreshModel ].
	self presenter whenColumnsChangedDo: [ self refreshColumnsInWidget ].
	
	tableMorph setBalloonText: self help.

	self configureScrolling.

	tableMorph
		onAnnouncement: FTSelectionChanged
			send: #selectionChanged:
			to: self;
		onAnnouncement: FTStrongSelectionChanged
			send: #strongSelectionChanged:
			to: self.

	tableMorph dataSource: self newDataSource.
	
	self presenter whenItemFilterBlockChangedDo: [ :block | 
		self updateItemFilterBlockWith: block ].
	self presenter whenSearchEnabledChangedDo: [ 
		self updateSearch ].
	self updateItemFilterBlockWith: self itemFilter! !

!SpMorphicTableAdapter methodsFor: 'factory' stamp: ''!
defaultColumn

	^ SpStringTableColumn new evaluated: #yourself! !

!SpMorphicTableAdapter methodsFor: 'testing' stamp: ''!
selectedIndexes
	
	^ widget selectedIndexes ! !

!SpMorphicTableAdapter methodsFor: 'emulating' stamp: ''!
sendRightClickEvent
	| evt |

	evt := MouseButtonEvent new 
		setType: nil 
		position: widget center 
		which: MouseButtonEvent yellowButton 
		buttons: MouseButtonEvent yellowButton 
		hand: nil 
		stamp: nil.
	
	self widget click: evt! !

!SpMorphicTableAdapter methodsFor: 'testing' stamp: ''!
isNonEditableRow: aRow column: aColumn

	^ (self widget dataSource
		cellColumn: (self widget columns at: aColumn)
		row: aRow) submorphs allSatisfy: [ :e | e asReadOnlyMorph == e ]! !

!SpMorphicTableAdapter methodsFor: 'factory' stamp: ''!
refreshColumnsInWidget

	widget columns: (self model columns collect: [ :each | self newColumnFrom: each ]).
	self ensureAtLeastOneColumnIn: widget.! !

!SpMorphicTableAdapter methodsFor: 'refreshing' stamp: ''!
refreshWidgetSelection
	| rowIndexes |
	rowIndexes := self presenter selection selectedIndexes.
	rowIndexes = self widget selectedIndexes
		ifTrue: [ ^ self ].
	rowIndexes isEmpty
		ifTrue: [ self widget basicSelectIndexes: #() ]
		ifFalse: [ self widget basicSelectIndexes: rowIndexes ].
	^ self refreshList! !

!SpMorphicTableAdapter methodsFor: 'emulating' stamp: ''!
clickOnColumnHeaderAt: anIndex
	self widgetDo: [ :tableWidget | tableWidget clickOnColumnHeaderAt: anIndex ]! !

!SpMorphicTableAdapter methodsFor: 'factory' stamp: ''!
refreshShowColumnHeaders
	
	self presenter isShowingColumnHeaders 
		ifTrue: [ 
			self widget
				showColumnHeaders;
				refresh ]
		ifFalse: [ 
			self widget
				hideColumnHeaders;
				refresh ]! !

!SpMorphicTableAdapter methodsFor: 'testing' stamp: ''!
isShowingColumnHeaders
	^ self model isShowingColumnHeaders! !

!SpMorphicTableAdapter methodsFor: 'refreshing' stamp: ''!
refreshList

	^ self widget refresh! !

!SpMorphicTableAdapter methodsFor: 'refreshing' stamp: ''!
refreshModel

	widget dataSource resetElements.
	self
		ifSorted: [ :sortingStrategyState | sortingStrategyState executeSortingOn: widget dataSource ]
		ifNotSorted: [ self refreshList ]! !

!SpMorphicTableAdapter methodsFor: 'testing' stamp: ''!
isResizable
	^ self model isResizable! !

!SpMorphicTableAdapter methodsFor: 'private - factory' stamp: ''!
newDataSource 

	^ SpMorphicTableDataSource new
		model: self model;
		yourself
! !

!SpMorphicTableAdapter methodsFor: 'factory' stamp: ''!
selectionChanged: ann
	| diff selection |

	selection := self presenter selection.
	selection selectIndexes: (selection isMultipleSelection
		ifTrue: [ 
			 (ann newSelectedIndexes reject: [ :e | e = 0 ]) ]
		ifFalse: [ 
			{ ann newSelectedIndexes
				ifNotEmpty: [ :indexes | indexes first ]
				ifEmpty: [ 0 ] } ]).

	diff := ann newSelectedIndexes difference: ann oldSelectedIndexes.
	(diff notEmpty and: [ self presenter activatesOnSingleClick ])
		ifTrue: [ self presenter doActivateAtIndex: diff last ].
		
	ann newSelectedIndexes ifEmpty: [ selection unselectAll ]! !

!SpMorphicTableAdapter methodsFor: 'testing' stamp: ''!
isShowColumnHeaders

	^ widget isShowColumnHeaders 	! !

!SpMorphicTableAdapter methodsFor: 'drag and drop' stamp: ''!
transferFrom: aTransferMorph event: anEvent
	| rowAndColumn |

	rowAndColumn := self widget container rowAndColumnIndexContainingPoint: anEvent position.
	^ SpDragAndDropTransferToTable new
		passenger: aTransferMorph passenger;
		row: (rowAndColumn first ifNil: [ 0 ]);
		column: (rowAndColumn second ifNil: [ 0 ]);
		yourself! !

!SpMorphicTableAdapter methodsFor: 'updating' stamp: ''!
updateMenu
	
	"there is no need to updateMenu here because it will be resolved at the dataSource"! !

!SpMorphicTableAdapter methodsFor: 'factory' stamp: ''!
ensureAtLeastOneColumnIn: tableMorph
	self model columns ifNotEmpty: [ ^ self ].
	tableMorph addColumn: (self newColumnFrom: self defaultColumn)! !

!SpMorphicTableAdapter methodsFor: 'initialization' stamp: ''!
addKeyBindingsTo: aWidget

	super addKeyBindingsTo: aWidget.
	self addContextMenuKeyBindings: aWidget! !

!SpMorphicTableAdapter methodsFor: 'private - factory' stamp: ''!
newColumnFrom: aTableColumn

	^ (SpMorphicTableColumn on: aTableColumn)
		width: aTableColumn width;
		yourself! !

!SpMorphicTableAdapter methodsFor: 'factory' stamp: ''!
strongSelectionChanged: aFTStrongSelectionChanged

	self presenter activatesOnDoubleClick ifFalse: [ ^ self ].	
	self presenter doubleClickAtIndex: aFTStrongSelectionChanged selectedIndex! !

!SpMorphicTableAdapter class methodsFor: 'accessing' stamp: ''!
intercellSpacing

	^ 2@0! !

!SpMorphicTableCellBuilder commentStamp: ''!
I build cells for a MorphicTableAdapter.!
!SpMorphicTableCellBuilder methodsFor: 'accessing' stamp: ''!
rowIndex: anObject
	rowIndex := anObject! !

!SpMorphicTableCellBuilder methodsFor: 'private' stamp: ''!
addItalicColumn: aTableColumn item: item to: content

	aTableColumn displayItalic ifNotNil: [ :block |
		(block cull: item) ifTrue: [ 
			^ content asText addAttribute: TextEmphasis italic ] ].
	
	^ content
	! !

!SpMorphicTableCellBuilder methodsFor: 'private' stamp: ''!
addBoldColumn: aTableColumn item: item to: content

	aTableColumn displayBold ifNotNil: [ :block |
		(block cull: item) ifTrue: [ 
			^ content asText addAttribute: TextEmphasis bold ] ].
	
	^ content
	! !

!SpMorphicTableCellBuilder methodsFor: 'private' stamp: ''!
addUnderlineColumn: aTableColumn item: item to: content

	aTableColumn displayUnderline ifNotNil: [ :block |
		(block cull: item) ifTrue: [ 
			^ content asText addAttribute: TextEmphasis underlined ] ].
	
	^ content
	! !

!SpMorphicTableCellBuilder methodsFor: 'accessing' stamp: ''!
rowIndex
	^ rowIndex! !

!SpMorphicTableCellBuilder methodsFor: 'private' stamp: ''!
addCell: anObject column: aTableColumn
	| morph |

	anObject ifNil: [ ^ self ]. 
	
	morph := 	anObject asMorph asReadOnlyMorph.
	self 
		addCellMorph: morph 
		column: aTableColumn! !

!SpMorphicTableCellBuilder methodsFor: 'private' stamp: ''!
addCellColumn: aTableColumn
	
	self 
		addCell: (aTableColumn readObject: self item) 
		column: aTableColumn! !

!SpMorphicTableCellBuilder methodsFor: 'accessing' stamp: ''!
cell: anObject
	cell := anObject! !

!SpMorphicTableCellBuilder methodsFor: 'private' stamp: ''!
addCellMorph: morph column: aTableColumn

	aTableColumn isExpandable ifFalse: [
		aTableColumn width: (aTableColumn width 
			ifNotNil: [ :width | width max: morph width ]
			ifNil: [ morph width ]).
		cell hResizing: #shrinkWrap.
		morph 
			hResizing: #rigid;
			width: aTableColumn width ].
	
	cell addMorphBack: morph! !

!SpMorphicTableCellBuilder methodsFor: 'private' stamp: ''!
addColorColumn: aTableColumn item: item to: content

	aTableColumn displayColor ifNotNil: [ :block |
		(block cull: item) ifNotNil: [ :aColor |
			^ content asText addAttribute: (TextColor color: aColor) ]  ].
	
	^ content
	! !

!SpMorphicTableCellBuilder methodsFor: 'accessing' stamp: ''!
dataSource: anObject
	dataSource := anObject! !

!SpMorphicTableCellBuilder methodsFor: 'private' stamp: ''!
addBackgroundColorColumn: aTableColumn item: item toMorph: aMorph

	aTableColumn displayBackgroundColor ifNotNil: [ :block |
		(block cull: item) ifNotNil: [ :aColor |
			aMorph color: aColor ]  ].
	
	^ aMorph
	! !

!SpMorphicTableCellBuilder methodsFor: 'visiting' stamp: ''!
visitImageColumn: aTableColumn
	| morph imageMorph image |
	
	image := aTableColumn readObject: self item.
	image ifNil: [ ^ self ].
	
	imageMorph := image asMorph.
	morph := 	Morph new 
		color: Color transparent;
		addMorphBack: imageMorph;
		extent: imageMorph extent;
		yourself.

	self 
		addCellMorph: morph 
		column: aTableColumn! !

!SpMorphicTableCellBuilder methodsFor: 'visiting' stamp: ''!
visitCheckboxColumn: aTableColumn
	| presenter morph |
	
	presenter := SpCheckBoxPresenter new
		addStyle: 'compact';
		state: (aTableColumn readObject: self item);
		yourself.

	aTableColumn onActivation ifNotNil: [ :valuable | 
		presenter whenActivatedDo: [ valuable cull: self item ] ].
	aTableColumn onDeactivation ifNotNil: [ :valuable | 
		presenter whenDeactivatedDo: [ valuable cull: self item ] ].

	morph := presenter buildWithSpec.
	presenter adapter applyStyle: morph.

	self 
		addCellMorph: morph
		column: aTableColumn ! !

!SpMorphicTableCellBuilder methodsFor: 'visiting' stamp: ''!
visitIndexColumn: aTableColumn

	self 
		addCell: self rowIndex 
		column: aTableColumn! !

!SpMorphicTableCellBuilder methodsFor: 'visiting' stamp: ''!
visitCompositeColumn: aTableColumn

	super visitCompositeColumn: aTableColumn.
	aTableColumn isExpandable ifFalse: [ 
		cell hResizing: #rigid.
		cell width: aTableColumn width ]! !

!SpMorphicTableCellBuilder methodsFor: 'private' stamp: ''!
item 

	^ self dataSource elementAt: self rowIndex! !

!SpMorphicTableCellBuilder methodsFor: 'accessing' stamp: ''!
cell
	^ cell! !

!SpMorphicTableCellBuilder methodsFor: 'accessing' stamp: ''!
dataSource
	^ dataSource! !

!SpMorphicTableCellBuilder methodsFor: 'visiting' stamp: ''!
visitStringColumn: aTableColumn
	| content item |
	
	item := self item.

	content := aTableColumn readObject: item.
	"add properties"
	content := self addColorColumn: aTableColumn item: item to: content.
	content := self addItalicColumn: aTableColumn item: item to: content.
	content := self addBoldColumn: aTableColumn item: item to: content.
	content := self addUnderlineColumn: aTableColumn item: item to: content.

	aTableColumn isEditable
		ifTrue: [ self visitStringColumnEditable: aTableColumn on: content ]
		ifFalse: [ "add cell"
			self addCell: content column: aTableColumn.
			"add background (this is a special case of properties, 
			since background needs to be applied to the cell and not to the text)"
			self addBackgroundColorColumn: aTableColumn item: item toMorph: cell ]! !

!SpMorphicTableCellBuilder methodsFor: 'visiting' stamp: ''!
visitLinkColumn: aTableColumn
	| presenter morph |
	
	presenter := SpLinkPresenter new
		addStyle: 'table';
		label: (aTableColumn readObject: self item);
		yourself.
	
	aTableColumn url 
		ifNotNil: [ presenter url: (aTableColumn url value: self item) ].
	aTableColumn action 
		ifNotNil: [ presenter action: [ aTableColumn action value: self item ] ].

	morph := presenter buildWithSpec.
	presenter adapter applyStyle: morph.

	self 
		addCellMorph: morph
		column: aTableColumn! !

!SpMorphicTableCellBuilder methodsFor: 'visiting' stamp: ''!
visitStringColumnEditable: aTableColumn on: content
	| presenter morph |

	presenter := self dataSource model newTextInput
		addStyle: 'compact';
  		text: content;
		yourself.

	aTableColumn acceptAction ifNotNil: [ :valuable | 
		presenter whenSubmitDo: [ :aString |
			valuable cull: self item cull: aString ] ].
	
	"add cell"
	morph := presenter buildWithSpec.
	presenter adapter applyStyle.
	self addCellMorph: morph column: aTableColumn! !

!SpMorphicTableCellBuilder class methodsFor: 'instance creation' stamp: ''!
on: aDataSource

	^ self new dataSource: aDataSource! !

!SpMorphicTableColumn commentStamp: ''!
I'm a column for the table on a MorphicTableAdapter hierarchy.
I delegate most of my behavior to my model (which is a TableColumn* instance)!
!SpMorphicTableColumn methodsFor: 'private' stamp: ''!
defaultSortFunction

	^ [ :each | (self readObject: each) ] ascending! !

!SpMorphicTableColumn methodsFor: 'accessing' stamp: ''!
width

	^ self model width ifNil: [ super width ]! !

!SpMorphicTableColumn methodsFor: 'testing' stamp: ''!
isSorted

	^ self sortingStrategy isSortingEnabled and: [ self sortingStrategy state isSorted ]! !

!SpMorphicTableColumn methodsFor: 'testing' stamp: ''!
isExpandable

	^ self model isExpandable! !

!SpMorphicTableColumn methodsFor: 'accessing' stamp: ''!
readObject: anObject 

	^ self model readObject: anObject! !

!SpMorphicTableColumn methodsFor: 'accessing' stamp: ''!
model: anObject

	model := anObject.
	model isSortable ifTrue: [ 
		self sortableUsing: model sortFunction ]! !

!SpMorphicTableColumn methodsFor: 'accessing' stamp: ''!
sortFunction

	^ self model sortFunction! !

!SpMorphicTableColumn methodsFor: 'sorting' stamp: ''!
sortableUsing: aSortFunction

	^ super sortableUsing: (aSortFunction ifNil: [ self defaultSortFunction ])! !

!SpMorphicTableColumn methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!SpMorphicTableColumn methodsFor: 'accessing' stamp: ''!
id 

	^ self model title! !

!SpMorphicTableColumn methodsFor: 'testing' stamp: ''!
isSortable

	^ self model isSortable! !

!SpMorphicTableColumn class methodsFor: 'instance creation' stamp: ''!
on: anObject

	^ self new model: anObject! !

!SpMorphicTableColumnVisitor commentStamp: ''!
I'm a visitor to be used to traverse TableColumn hierarchy.!
!SpMorphicTableColumnVisitor methodsFor: 'visiting' stamp: ''!
visitImageColumn: aTableColumn! !

!SpMorphicTableColumnVisitor methodsFor: 'visiting' stamp: ''!
visitCheckboxColumn: aCheckboxTableColumn! !

!SpMorphicTableColumnVisitor methodsFor: 'visiting' stamp: ''!
visitIndexColumn: aTableColumn! !

!SpMorphicTableColumnVisitor methodsFor: 'visiting' stamp: ''!
visitCompositeColumn: aTableColumn
	
	aTableColumn columns do: [ :each |
		self visit: each  ]! !

!SpMorphicTableColumnVisitor methodsFor: 'visiting' stamp: ''!
visitStringColumn: aTableColumn! !

!SpMorphicTableColumnVisitor methodsFor: 'visiting' stamp: ''!
visitLinkColumn: aTableColumn

	self visitStringColumn: aTableColumn! !

!SpMorphicTableColumnVisitor methodsFor: 'visiting' stamp: ''!
visit: aTableColumn

	aTableColumn acceptColumnVisitor: self! !

!SpMorphicTableContainerAdapter commentStamp: ''!
I am the adapter providing container with table layout
!
!SpMorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
width: aNumber

	self
		hRigid;
		widgetDo: [ :w | w width: aNumber ]! !

!SpMorphicTableContainerAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ PanelMorph new
		  layoutPolicy: TableLayout new;
		  vResizing: #spaceFill;
		  hResizing: #spaceFill;
		  yourself! !

!SpMorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
layoutProperties: props

	self widgetDo: [ :w | w layoutProperties: props ]! !

!SpMorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
minHeight: aNumber

	self widgetDo: [ :w | w minHeight: aNumber ]! !

!SpMorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
height: aNumber

	self 
		vRigid;
		widgetDo: [ :w | w height: aNumber ]! !

!SpMorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
isRedrawable
	"This must be overriden in the adapter representing your container"
	
	^ true! !

!SpMorphicTableContainerAdapter methodsFor: 'protocol' stamp: ''!
minWidth: aNumber

	self widgetDo: [ :w | w minWidth: aNumber ]! !

!SpMorphicTableDataSource commentStamp: ''!
I'm a dataSource to be used in MorphicTableAdapter to realise a TablePresenter.
I define my cells following the definition on columns (MorphicTableColumn).
I use a builder (MorphicTableCellBuilder) to realise the cell content. !
!SpMorphicTableDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
	| cell builder |

	cell := FTCellMorph new.
	builder := SpMorphicTableCellBuilder on: self.
	builder 
		cell: cell;
		rowIndex: rowIndex;
		visit: column model.
	self setHeaderColumnLazyProperties: column.
		
	^ cell! !

!SpMorphicTableDataSource methodsFor: 'accessing' stamp: ''!
resetElements

	elements := nil! !

!SpMorphicTableDataSource methodsFor: 'accessing' stamp: ''!
headerForColumn: aColumn

	^ self headersByColumn 
		at: aColumn 
		ifAbsentPut: [ self newHeaderColumn: aColumn ]! !

!SpMorphicTableDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString
	
	aString isEmptyOrNil ifTrue: [ ^ #() ].
	^ Array streamContents: [ :stream |
		self elements withIndexDo: [ :each :index |
			(self model performSearch: each matching: aString)
				ifTrue: [ stream nextPut: index ] ] ]! !

!SpMorphicTableDataSource methodsFor: 'sorting' stamp: ''!
sortByColumn: aColumn

	aColumn sortDataSource: self.
	self model selection unselectAll.! !

!SpMorphicTableDataSource methodsFor: 'accessing' stamp: ''!
elements 
	
	^ elements ifNil: [
		self model 
			ifNotNil: #items
			ifNil: [ #() ] ]! !

!SpMorphicTableDataSource methodsFor: 'accessing' stamp: ''!
headersByColumn 

	^ headersByColumn ifNil: [ headersByColumn := SmallDictionary new ]	! !

!SpMorphicTableDataSource methodsFor: 'sorting' stamp: ''!
sortByColumn: aColumn event: anEvent morph: aMorph

	self sortByColumn: aColumn! !

!SpMorphicTableDataSource methodsFor: 'accessing' stamp: ''!
headerColumn: column

	(column id isNil and: [ self model isShowingColumnHeaders not ]) ifTrue: [ ^ nil ].
	^ self headerForColumn: column! !

!SpMorphicTableDataSource methodsFor: 'accessing' stamp: ''!
model: aTablePresenter

	model := aTablePresenter! !

!SpMorphicTableDataSource methodsFor: 'private' stamp: ''!
setHeaderColumnLazyProperties: column
	"Some properties of a header just acquire value after rendering cells. This method makes sure 
	 properties are set, but is responsibility of the user to actually call it (usually after create 
	 a cell). See senders of this method too see where it goes."
	| headerMorph |
	
	column isExpandable ifTrue: [ ^ self ].  
	
	headerMorph := self headerForColumn: column.
	headerMorph hResizing = #rigid 
		ifFalse: [ headerMorph hResizing: #rigid ].
	headerMorph width = column model width ifFalse: [ 
		headerMorph width: (column model width ifNil: [ 0 ]). ]! !

!SpMorphicTableDataSource methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	| menuPresenter |

	menuPresenter := self model contextMenu.
	menuPresenter ifNil: [ ^ nil ].
	^ SpBindings
		value: self model application adapterBindings
		during: [ menuPresenter value buildWithSpec ]! !

!SpMorphicTableDataSource methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!SpMorphicTableDataSource methodsFor: 'private - factory' stamp: ''!
newHeaderColumn: column
	| headerMorph |
	
	headerMorph := SpHeaderCellMorph new 
		addMorph: (column id ifNil: [ '' ]) asMorph asReadOnlyMorph;
		yourself.
		
	column isSortable ifTrue: [ 
		headerMorph eventHandler: (MorphicEventHandler new 
			on: #click 
			send: #sortByColumn:event:morph:
			to: self
			withValue: column).
	column sortingIcon ifNotNil: [ :icon | headerMorph addMorph: icon ] ].

	^ headerMorph! !

!SpMorphicTableDataSource methodsFor: 'testing' stamp: ''!
isMatch: anObject pattern: aString
	| text |
	
	text := (self toString: anObject) trimBoth asLowercase.
	^ text beginsWith: aString! !

!SpMorphicTableDataSource class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpMorphicTableDataSource class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpMorphicTableDataSource class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpMorphicTableDataSource class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpMorphicTableDataSource class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpMorphicTableDataSource class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpMorphicTableDataSource class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpMorphicTableDataSource class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpMorphicTableDataSource class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicTableDataSource class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpMorphicTableDataSource class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpMorphicTableDataSource class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpMorphicTableDataSource class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpMorphicTableDataSource class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpMorphicTableDataSource class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpMorphicTableDataSource class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpMorphicTableDataSource class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpMorphicTableDataSource class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicTableDataSource class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpMorphicTableDataSource class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpMorphicTableDataSource class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpMorphicTableDataSource class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpMorphicTableDataSource class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpMorphicTableDataSource class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpMorphicTableDataSource class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpMorphicTableDataSource class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpMorphicTableDataSource class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpMorphicTableDataSource class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpMorphicTableDataSource class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpMorphicTextAdapter commentStamp: ''!
I am the adapter used to bridge a TextPresenter and a RubScrolledTextMorph for regular text!
!SpMorphicTextAdapter methodsFor: 'visiting' stamp: ''!
accept: aString notifying: aNotifyier

	^ super 
		accept: (aString ifNotNil: [ aString asString ])
		notifying: aNotifyier! !

!SpMorphicTextAdapter methodsFor: 'commands' stamp: ''!
findNextText

	self editor findAgain! !

!SpMorphicTextAdapter methodsFor: 'protocol - shortcuts' stamp: ''!
bindKeyCombination: aShortcut toAction: aBlock 

	self widgetDo: [ :w | 
		w textArea
			bindKeyCombination: aShortcut 
			toAction: aBlock ]! !

!SpMorphicTextAdapter methodsFor: 'private' stamp: ''!
editor

	^ widget textArea editor! !

!SpMorphicTextAdapter methodsFor: 'commands' stamp: ''!
copyText

	self editor copySelection! !

!SpMorphicTextAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| newWidget |
	
	newWidget := (SpRubScrolledTextMorph on: self)
		getTextSelector: #getText;
		setTextSelector: #accept:notifying:;
		getSelectionSelector: #readSelection;
		menuProvider: self selector: #codePaneMenu:shifted:;
		setSelectionSelector: #setSelection:;
		ghostText: self placeholder;
		beWrapped;
		enabled: self enabled;
		askBeforeDiscardingEdits: self askBeforeDiscardingEdits;
		autoAccept: true;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		setBalloonText: self help;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		registerScrollChanges: #scrollValueChanged:;
		hScrollbarShowWhenNeeded;
		yourself.
	
	self setEditable: self presenter isEditable to: newWidget.
	self setEditingModeFor: newWidget.
	self setText: self presenter text to: newWidget.
	self presenter selectionInterval 
		ifNotNil: [  :anInterval | self selectionInterval: anInterval on: newWidget ].

	self setWrapWord: self presenter isWrapWord to: newWidget.	
	self setUndoRedo: self presenter hasUndoRedoHistory to: newWidget. 
	self presenter whenTextChangedDo: [ :text | 
		self setText: text to: newWidget ].
	self presenter whenSelectionChangedDo: [ :selectionInterval | 
		self selectionInterval: selectionInterval ].
	self presenter whenPlaceholderChangedDo: [ :text | 
		self setGhostText: text to: newWidget ].
	self presenter whenEditableChangedDo: [ :value | 
		self setEditable: value to: newWidget ].
	self presenter whenWrapWordChangedDo: [ :value | 
		self setWrapWord: value to: newWidget ].
	
	^ newWidget! !

!SpMorphicTextAdapter methodsFor: 'widget API' stamp: ''!
cursorPosition

	^ self widgetDo: [ :w |
		w textArea selectionStart
			ifNotNil: [ :sel | self linePositionOf: sel ] ]! !

!SpMorphicTextAdapter methodsFor: 'widget API' stamp: ''!
codePaneMenu: aMenu shifted: shifted

	| menuPresenter |
	menuPresenter := self model contextMenu value
		                 ifNotNil: [ :contextMenu | contextMenu ]
		                 ifNil: [ SpMenuPresenter new ].
	self presenter hasEditionContextMenu ifTrue: [ 
		self presenter editionContextMenu menuGroups do: [ :each | 
			menuPresenter addMenuGroup: each ] ].
	^ SpBindings
		  value: self model application adapterBindings
		  during: [ menuPresenter value buildWithSpec ]! !

!SpMorphicTextAdapter methodsFor: 'widget API' stamp: ''!
cursorPositionIndex: index 

	self widgetDo: [ :w | w textArea pointBlock: (w textArea paragraph characterBlockForIndex: index) ]! !

!SpMorphicTextAdapter methodsFor: 'commands' stamp: ''!
cutText

	self editor cut! !

!SpMorphicTextAdapter methodsFor: 'private' stamp: ''!
eventHandlerReceiver: aWidget

	^ aWidget textArea! !

!SpMorphicTextAdapter methodsFor: 'private' stamp: ''!
setGhostText: text to: aWidget

	aWidget ghostText: text! !

!SpMorphicTextAdapter methodsFor: 'api' stamp: ''!
lineAtCursorPosition

	^ self widgetDo: [ :w | 
		w textArea editor lineAtCursorPosition ]! !

!SpMorphicTextAdapter methodsFor: 'styling' stamp: ''!
presenterStyles
	"The presenters in the style"

	^ self presenter scrollBarStyles, self presenter styles ! !

!SpMorphicTextAdapter methodsFor: 'private' stamp: ''!
setEditable: aBoolean to: aWidget

	aWidget textArea readOnly: aBoolean not! !

!SpMorphicTextAdapter methodsFor: 'factory' stamp: ''!
setUndoRedo: aBoolean to: newWidget

	newWidget textArea editingState undoManager: (aBoolean 
		ifTrue: [ HistoryIterator new ]
		ifFalse: [ SpNullHistoryIterator new ])! !

!SpMorphicTextAdapter methodsFor: 'private' stamp: ''!
linePositionOf: sel

	| textLine linePosition |
	textLine := sel textLine.
	linePosition := sel stringIndex - textLine first + 1.
	^ linePosition @ textLine lineNumber! !

!SpMorphicTextAdapter methodsFor: 'initialization' stamp: ''!
addFocusRotationKeyBindings
	"Text areas needs to be able to process tab. Cancel the binding."! !

!SpMorphicTextAdapter methodsFor: 'private' stamp: ''!
setWrapWord: aBoolean to: aWidget

	aBoolean 
		ifTrue: [ aWidget beWrapped ]
		ifFalse: [ aWidget beNotWrapped ]! !

!SpMorphicTextAdapter methodsFor: 'commands' stamp: ''!
selectAndPasteText

	self editor pasteRecent! !

!SpMorphicTextAdapter methodsFor: 'private' stamp: ''!
updateExtentPropagationOf: string on: aWidget
	| stringMorph width height |

	(self presenter isPropagateNaturalWidth 
		or: [ self presenter isPropagateNaturalHeight ])
		ifFalse: [ ^ self ].

	"This is an incredible ugly hack because what should be the correct way of doing it: 
	 Font>>widthOfString: does not works (because it fails to take into account kerning).
	 Why it works on the Editing area is a mystery. 
	 BUT!! It does not work for monospaced fonts!! (again, no idea why)"
	stringMorph := RubEditingArea new 
		font: aWidget font;
		updateTextWith: string asString.

	width := stringMorph width + 12" min: self currentWorld width / 3".
	self presenter isPropagateNaturalWidth 
		ifTrue: [ aWidget width: width ].

	self presenter isPropagateNaturalHeight 
		ifTrue: [ 
			height := ((stringMorph
				beWrapped;
				width: width;
				yourself) height + 2)"min: self currentWorld height / 3". 
			aWidget height: height ]! !

!SpMorphicTextAdapter methodsFor: 'commands' stamp: ''!
findText

	self editor find! !

!SpMorphicTextAdapter methodsFor: 'commands' stamp: ''!
pasteText

	self editor paste! !

!SpMorphicTextAdapter methodsFor: 'private' stamp: ''!
setText: text to: aWidget

	updating ifTrue: [ ^ self ].

	aWidget textArea editingState clearUndoManager: nil.
	aWidget setText: text.
	self updateExtentPropagationOf: text on: aWidget! !

!SpMorphicTextInputFieldAdapter commentStamp: ''!
I am the adapter used to bridge a TextInputFieldPresenter and a PluggableTextFieldMorph!
!SpMorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: ''!
accept: aText notifying: aNotifyier
	"We use #asString because rubric send Text instead of strings."

	super
		accept: aText asString 
		notifying: aNotifyier! !

!SpMorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: ''!
entryCompletion

	^ self model entryCompletion! !

!SpMorphicTextInputFieldAdapter methodsFor: 'spec protocol' stamp: ''!
encrypted: aBoolean

	self widgetDo: [ :w | 
		w encrypted: aBoolean.
		w changed ]! !

!SpMorphicTextInputFieldAdapter methodsFor: 'accessing' stamp: ''!
text: aString

	widget
		setText: aString;
		acceptTextInModel! !

!SpMorphicTextInputFieldAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| newWidget |

	newWidget := (SpRubTextFieldMorph on: self)
		getTextSelector: #getText;
		setTextSelector: #accept:notifying:;
		getSelectionSelector: #readSelection;
		menuProvider: self selector: #codePaneMenu:shifted:;
		setSelectionSelector: #setSelection:;
		entryCompletion: self entryCompletion;
		ghostText: self getPlaceholderText;
		encrypted: self encrypted;
		enabled: self enabled;
		askBeforeDiscardingEdits: self askBeforeDiscardingEdits;
		autoAccept: true;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		setBalloonText: self help;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		maxLength: self presenter maxLength;
		yourself.

	self presenter selectionInterval 
		ifNotNil: [  :anInterval | self selectionInterval: anInterval on: newWidget ].

	self presenter whenTextChangedDo: [ :text | newWidget setText: text ].
	self presenter whenSelectionChangedDo: [ :selectionInterval | 
		self selectionInterval: selectionInterval ].
	self presenter whenPlaceholderChangedDo: [ :text | 
		newWidget ghostText: (text ifNotNil: [ :aString | 
			aString localizedForPresenter: self presenter ]) ].
	self presenter whenPasswordChangedDo: [ :isPassword | 
		newWidget encrypted: isPassword ].
	self presenter whenMaxLengthChangedDo: [ :length | 
		newWidget maxLength: length ].
	self setEditable: self presenter isEditable to: newWidget. 
	self presenter whenEditableChangedDo: [ :value | 
		self setEditable: value to: newWidget ].

	^ newWidget! !

!SpMorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: ''!
encrypted
	^ self model isPassword! !

!SpMorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: ''!
cursorPositionIndex: index 

	self widgetDo: [ :w | ^ w textArea editor selectAt: index ]! !

!SpMorphicTextInputFieldAdapter methodsFor: 'private' stamp: ''!
eventHandlerReceiver: aWidget

	^ aWidget textArea! !

!SpMorphicTextInputFieldAdapter methodsFor: 'private' stamp: ''!
getPlaceholderText

	^ self presenter placeholder ifNotNil: [ :aString | 
		aString localizedForPresenter: self presenter ]! !

!SpMorphicTextInputFieldAdapter methodsFor: 'private' stamp: ''!
setEditable: aBoolean to: aWidget

	aWidget textArea readOnly: aBoolean not! !

!SpMorphicTextInputFieldAdapter methodsFor: 'emulating' stamp: ''!
widgetEventReceiver
	
	^ widget! !

!SpMorphicTextInputFieldAdapter methodsFor: 'testing' stamp: ''!
isPassword
	
	^ self widget font isKindOf: FixedFaceFont! !

!SpMorphicTickingWindowAdapter commentStamp: ''!
I am the adapter used to bridge a TickingWindowPresenter and a TickingSpecWindow!
!SpMorphicTickingWindowAdapter methodsFor: 'stepping' stamp: ''!
step

	self model step! !

!SpMorphicTickingWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpTickingSpecWindow new
		  model: self;
		  isResizeable: self isResizable;
		  yourself! !

!SpMorphicToggleButtonAdapter commentStamp: ''!
I'm the adapter used to bridge a ToggleButton and its morphic representation.!
!SpMorphicToggleButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| checkButton |

	checkButton := PluggableToggleButtonMorph
		on: self
		getState: #state
		action: #toggleAction:
		label: #label
 		menu: nil.

	checkButton
		icon: self icon;
		label: self getLabelText;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		setBalloonText: self getHelpText;
		getEnabledSelector: #enabled;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled.

	self presenter whenLabelChangedDo: [ :newLabel | 
		checkButton label: (newLabel ifNotNil: [ :aString | 
			aString localizedForPresenter: self presenter ]) ].
	self presenter whenIconChangedDo: [ checkButton icon: self icon ].
	self presenter whenChangedDo: [ self buttonChanged ].

	^ checkButton! !

!SpMorphicToggleButtonAdapter methodsFor: 'widget API' stamp: ''!
state: aBoolean
	
	^ self presenter state: aBoolean! !

!SpMorphicToggleButtonAdapter methodsFor: 'accessing' stamp: ''!
styleName: aString 

	styleName := aString! !

!SpMorphicToggleButtonAdapter methodsFor: 'widget API' stamp: ''!
state
	
	^ self presenter state! !

!SpMorphicToggleButtonAdapter methodsFor: 'private' stamp: ''!
getHelpText

	^ self presenter help ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicToggleButtonAdapter methodsFor: 'emulating' stamp: ''!
clicked
	
	widget performAction.
	self model state: widget isPressed! !

!SpMorphicToggleButtonAdapter methodsFor: 'accessing' stamp: ''!
helpText
	
	^ widget balloonText! !

!SpMorphicToggleButtonAdapter methodsFor: 'widget API' stamp: ''!
icon
	
	^ self presenter icon! !

!SpMorphicToggleButtonAdapter methodsFor: 'events' stamp: ''!
toggleAction: aBoolean 
	
	self model state: aBoolean.
	^ self model action cull: aBoolean ! !

!SpMorphicToggleButtonAdapter methodsFor: 'accessing' stamp: ''!
styleName

	^ styleName ifNil: [ super styleName ]! !

!SpMorphicToggleButtonAdapter methodsFor: 'private' stamp: ''!
getLabelText

	^ self presenter label ifNotNil: [ :aString | aString localizedForPresenter: self presenter ]! !

!SpMorphicToggleButtonAdapter methodsFor: 'private' stamp: ''!
buttonChanged
	| state associated |
	
	state := self state.
	associated := self presenter associatedToggleButtons.	
	state ifTrue: [ 
		associated do: [ :each | each state: false ] ].
	
	widget pressed: state! !

!SpMorphicToggleButtonAdapter methodsFor: 'widget API' stamp: ''!
label
	
	^ self getLabelText! !

!SpMorphicToolbarAdapter commentStamp: ''!
I'm the adapter used to bridge a ToolBarPresenter and its morphic representation.!
!SpMorphicToolbarAdapter methodsFor: 'factory' stamp: ''!
configureItem: itemModel morph: itemMorph toolBar: toolBarMorph
	
	itemMorph 
		font: toolBarMorph toolbarItemFont;
		minWidth: toolBarMorph displayMode width.
	
	toolBarMorph displayMode 
		configureMorph: itemMorph 
		item: itemModel.
		
	^ itemMorph! !

!SpMorphicToolbarAdapter methodsFor: 'testing' stamp: ''!
numberOfItems
	
	^ self widget leftPanel submorphs size + self widget rightPanel submorphs size! !

!SpMorphicToolbarAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	| toolBarMorph |
	toolBarMorph := SpToolbarMorph new.
	self addModelTo: toolBarMorph.

	^ toolBarMorph! !

!SpMorphicToolbarAdapter methodsFor: 'testing' stamp: ''!
hasButtonWithLabel: aString

	^ (self widget leftPanel submorphs , self widget rightPanel submorphs)
		detect: [ :e | (e isKindOf: SpToolbarButtonMorph) and: [ e label = aString ] ]
		ifFound: [ true ]
		ifNone: [ false ]! !

!SpMorphicToolbarAdapter methodsFor: 'factory' stamp: ''!
addModelTo: toolBarMorph

	toolBarMorph
		displayMode: self presenter displayMode;
		height: self presenter displayMode height;
		setBalloonText: self presenter help.

	self presenter whenItemsChangeDo: [ self updateItems: toolBarMorph ].

	self updateItems: toolBarMorph! !

!SpMorphicToolbarAdapter methodsFor: 'factory' stamp: ''!
updateItems: toolBarMorph

	toolBarMorph clearItems.

	self presenter leftItems do: [ :each | 
		toolBarMorph 
			addItem: (self 
				configureItem: each 
				morph: each buildWithSpec 
				toolBar: toolBarMorph)
			position: SpToolbarItemPosition left ].

	self presenter rightItems do: [ :each | 
		toolBarMorph 
			addItem: (self 
				configureItem: each 
				morph: each buildWithSpec 
				toolBar: toolBarMorph)
			position: SpToolbarItemPosition right ]! !

!SpMorphicToolbarButtonAdapter commentStamp: ''!
I'm the adapter used to bridge a ToolBarButton and its morphic representation.!
!SpMorphicToolbarButtonAdapter methodsFor: 'accessing' stamp: ''!
badge

	^ self presenter badge! !

!SpMorphicToolbarButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| button |
	
	button := self newButton.
	
	self presenter whenLabelChangedDo: [ self updateLabel ].
	self presenter whenIconChangedDo: [ self updateIcon ].

	^ button! !

!SpMorphicToolbarButtonAdapter methodsFor: 'factory' stamp: ''!
newButton
	
	^ (self morphClass
			on: self
			getState: nil 
			action: #execute)
		helpText: self presenter help;
		beIconTop;
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		borderWidth: 0;
		borderColor: Color transparent;		
		cellPositioning: #center;
		yourself! !

!SpMorphicToolbarButtonAdapter methodsFor: 'factory' stamp: ''!
morphClass

	^ SpToolbarButtonMorph! !

!SpMorphicToolbarButtonAdapter methodsFor: 'updating' stamp: ''!
updateIcon

	self button update: self button getIconSelector! !

!SpMorphicToolbarButtonAdapter methodsFor: 'execution' stamp: ''!
execute

	self presenter action cull: self presenter! !

!SpMorphicToolbarButtonAdapter methodsFor: 'updating' stamp: ''!
updateLabel

	self button update: self button getLabelSelector! !

!SpMorphicToolbarButtonAdapter methodsFor: 'accessing - structure variables' stamp: ''!
state

	^ false! !

!SpMorphicToolbarButtonAdapter methodsFor: 'execution' stamp: ''!
execute: isPressed

	self presenter state: isPressed.
	self presenter action ifNotNil: [ :action | 
		action cull: self presenter ]! !

!SpMorphicToolbarButtonAdapter methodsFor: 'accessing' stamp: ''!
icon
	| icon |
	
	icon := self presenter icon.
	icon ifNil: [ ^ nil ].
	
	^ self presenter isEnabled
		ifTrue: [ icon ]
		ifFalse: [ icon asGrayScaleWithAlpha ]! !

!SpMorphicToolbarButtonAdapter methodsFor: 'updating' stamp: ''!
button

	^ widget! !

!SpMorphicToolbarButtonAdapter methodsFor: 'accessing' stamp: ''!
enabled: aBoolean

	super enabled: aBoolean.
	self updateIcon! !

!SpMorphicToolbarButtonAdapter methodsFor: 'accessing' stamp: ''!
label

	^ self presenter label! !

!SpMorphicToolbarMenuButtonAdapter commentStamp: ''!
I'm the adapter used to bridge a ToolBarMenuButton and its morphic representation.!
!SpMorphicToolbarMenuButtonAdapter methodsFor: 'control' stamp: ''!
deleteIfPopUp: anEvent 
	! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'widget API' stamp: ''!
showSubMenu: aMenu

	aMenu menuGroups ifNil: [ ^ self ].

	subMenuWidget ifNotNil: [ 
		subMenuWidget delete.
		subMenuWidget := nil ].
	subMenuWidget := (SpMorphicMenuAdapter adaptAsPopup: aMenu) widget.
	subMenuWidget
		popUpAdjacentTo: { 
				self widget bounds bottomLeft.
				self widget bounds bottomRight }
		forHand: self currentWorld activeHand
		from: self widget.
	subMenuWidget popUpOwner: self! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpMorphicToolbarMenuButtonMorph
		  newButton: super buildWidget
		  menuButton: self newMenuButton! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'testing' stamp: ''!
isSelected: aBooolean! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'accessing' stamp: ''!
icon

	^ self presenter icon! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'accessing' stamp: ''!
showMenu

	self presenter menu ifNotNil: [ :aValuable | 
		aValuable value ifNotNil: [ :aMenu | 
			aMenu owner: self presenter.
			self showSubMenu: aMenu ] ].
	self widget ifNotNil: [ :m | m takeKeyboardFocus ]! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'updating' stamp: ''!
button

	^ widget submorphs first! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'drag and drop' stamp: ''!
dragEnabled

	^ false! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'drag and drop' stamp: ''!
dropEnabled

	^ false! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'factory' stamp: ''!
newMenuButton

	^ IconicButton new
		  target: self;
		  actionSelector: #showMenu;
		  arguments: {  };
		  labelGraphic: self menuIcon;
		  color: Color transparent;
		  borderWidth: 0! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'accessing' stamp: ''!
menuIcon

	^ self application iconNamed: #arrowDown! !

!SpMorphicToolbarMenuButtonAdapter methodsFor: 'protocol' stamp: ''!
askBeforeChanging

	^ false! !

!SpMorphicToolbarMenuButtonMorph commentStamp: ''!
Morphic implementation of a ToolBarMenuButton!
!SpMorphicToolbarMenuButtonMorph methodsFor: 'accessing' stamp: ''!
menuButton 

	^ self submorphs second! !

!SpMorphicToolbarMenuButtonMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self
		changeTableLayout;
		listDirection: #leftToRight;
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		color: Color transparent;
		borderColor: Color transparent;
		clipSubmorphs: true;
		borderWidth: 0;
		extent: 0@0! !

!SpMorphicToolbarMenuButtonMorph methodsFor: 'accessing' stamp: ''!
font: aFont

	self submorphs do: [ :each | 
		(each respondsTo: #font:) ifTrue: [ each font: aFont ] ]! !

!SpMorphicToolbarMenuButtonMorph methodsFor: 'configuring' stamp: ''!
configureWith: aMode item: aButton

	"Transmit to button"
	self button
		configureWith: aMode 
		item: aButton! !

!SpMorphicToolbarMenuButtonMorph methodsFor: 'accessing' stamp: ''!
button 

	^ self submorphs first! !

!SpMorphicToolbarMenuButtonMorph methodsFor: 'initialization' stamp: ''!
initializeButton: aButtonMorph menuButton: aMenuButton

	self initialize.
	self addMorphBack: (aButtonMorph
			 hResizing: #shrinkWrap;
			 yourself).
	self addMorphBack: aMenuButton! !

!SpMorphicToolbarMenuButtonMorph class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Use newButton:menuButton:'! !

!SpMorphicToolbarMenuButtonMorph class methodsFor: 'instance creation' stamp: ''!
newButton: aButtonMorph menuButton: aMenuButton

	^ self basicNew
		initializeButton: aButtonMorph menuButton: aMenuButton;
		yourself! !

!SpMorphicToolbarPopoverButtonAdapter commentStamp: ''!
I'm the adapter used to bridge a ToolBarPopoverButton and its morphic representation.!
!SpMorphicToolbarPopoverButtonAdapter methodsFor: 'execution' stamp: ''!
execute

	self presenter newPopover
		addStyle: 'popoverButton';
		presenter: self presenter content value;
		popup! !

!SpMorphicToolbarToggleButtonAdapter commentStamp: ''!
I'm the adapter used to bridge a ToolBarToggleButton and its morphic representation.!
!SpMorphicToolbarToggleButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| newWidget |

	newWidget := super buildWidget.
	self presenter whenToggledDo: [ 
		self buttonChanged ].
	
	^ newWidget! !

!SpMorphicToolbarToggleButtonAdapter methodsFor: 'factory' stamp: ''!
newButton

	^ super newButton
		action: #execute:
		yourself! !

!SpMorphicToolbarToggleButtonAdapter methodsFor: 'factory' stamp: ''!
morphClass 

	^ SpToolbarToggleButtonMorph! !

!SpMorphicToolbarToggleButtonAdapter methodsFor: 'accessing - structure variables' stamp: ''!
state

	^ self presenter isSelected! !

!SpMorphicToolbarToggleButtonAdapter methodsFor: 'private' stamp: ''!
buttonChanged
	| state associated |
	
	state := self state.
	associated := self presenter associatedToggleButtons.
	state ifTrue: [ 
		associated do: [ :each | each state: false ] ].
	
	widget pressed: state! !

!SpMorphicTransferAdapter commentStamp: ''!
I am a morphic specific adapter used to build a transfer object during a drang and drop operation!
!SpMorphicTransferAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpTransferMorph new
		  model: self;
		  passenger: self passenger;
		  source: self source;
		  yourself! !

!SpMorphicTransferAdapter methodsFor: 'widget API' stamp: ''!
source

	^ [ self model source ]! !

!SpMorphicTransferAdapter methodsFor: 'widget API' stamp: ''!
passenger

	^ [ self model passenger ]! !

!SpMorphicTreeAdapter methodsFor: 'factory' stamp: ''!
columns
	
	^ #()! !

!SpMorphicTreeAdapter methodsFor: 'factory' stamp: ''!
registerColumnsChangedEventTo: tableMorph! !

!SpMorphicTreeAdapter methodsFor: 'factory' stamp: ''!
defaultColumn
	| column |

	column := SpStringTableColumn evaluated: self presenter display.	
	
	self presenter displayColor 
		ifNotNil: [ :aBlock | column displayColor: aBlock ].
	self presenter displayBold
		ifNotNil: [ :aBlock | column displayBold: aBlock ].
	self presenter displayItalic
		ifNotNil: [ :aBlock | column displayItalic: aBlock ].
	self presenter displayUnderline
		ifNotNil: [ :aBlock | column displayUnderline: aBlock ].
	self presenter displayBackgroundColor 
		ifNotNil: [ :aBlock | column displayBackgroundColor: aBlock ].

	^ self presenter displayIcon 
		ifNotNil: [ :iconBlock |
			SpCompositeTableColumn new 
				addColumn: (SpImageTableColumn evaluated: iconBlock) beNotExpandable;
				addColumn: column;
				yourself ]
		ifNil: [ column ]! !

!SpMorphicTreeAdapter methodsFor: 'factory' stamp: ''!
ensureAtLeastOneColumnIn: tableMorph

	tableMorph addColumn: (self newColumnFrom: self defaultColumn)! !

!SpMorphicTreeTableAdapter commentStamp: ''!
I am the adapter used to realise a SpTreeTablePresenter.
I will create a tree table (using FTTableMorph), using the columns TableColumn* as definitions.

Is important notice here that most of the row/cell creation happens on SpMorphicTreeTableDataSource. Check there for some implementation details.!
!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
expandPath: anArray  

	widget dataSource expandPath: anArray! !

!SpMorphicTreeTableAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
iconOfRowMorphAt: anInteger
	"Return the first icon of a row morph at a certain index in the tree. 
	If it is expandable, it will be an IconicButton, else it will be an empty image morph."

	| row indentCell |
	row := self rowMorphAt: anInteger.
	indentCell := row submorphs anyOne.
	"The expand icon should be an IconicButton"

	^ indentCell submorphs first! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
basicSelectionChanged: ann
	| selection |
	
	selection := self presenter selection.
	ann newSelectedIndexes ifEmpty: [ ^ selection unselectAll ].
	(ann newSelectedIndexes difference: ann oldSelectedIndexes) ifEmpty: [ ^ self ].
	
	selection selectPaths: (ann newSelectedIndexes
		collect: [ :index | self widget dataSource pathFromIndex: index ]).
		
	self presenter activatesOnSingleClick ifTrue: [ 
		self presenter doActivateAtPath: selection selectedPath ]! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
columns
	
	^ self presenter columns! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	| tableMorph |

	tableMorph := SpFTTableMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		intercellSpacing: self class intercellSpacing;
		dragEnabled: self dragEnabled;
		dropEnabled: self dropEnabled;
		yourself.

	self addModelTo: tableMorph.
	widget := tableMorph.
	self configureScrolling.

	^ tableMorph! !

!SpMorphicTreeTableAdapter methodsFor: 'private' stamp: ''!
showContextMenu

	self widgetDo: [ :w |
		w showMenuForIndex: { self presenter selection selectedIndex. 1 } ]! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
addModelTo: tableMorph

	self addColumnsFromPresenterTo: tableMorph.
	self ensureAtLeastOneColumnIn: tableMorph.

	self presenter selection isMultipleSelection ifTrue: [  
		tableMorph beMultipleSelection ].

	self isShowingColumnHeaders 
		ifTrue: [ tableMorph showColumnHeaders ] 
		ifFalse: [ tableMorph hideColumnHeaders ].

	self isResizable 
		ifTrue: [ tableMorph beResizable ] 
		ifFalse: [ tableMorph beNotResizable ].
		
	self isSearchEnabled
		ifTrue: [ tableMorph enableSearch ]
		ifFalse: [ tableMorph disableFunction ].

	tableMorph setBalloonText: self model help.
	
	tableMorph dataSource: self newDataSource.
	
	self presenter selection isEmpty 
		ifFalse: [ self updateSelectionOf: tableMorph ].
	
	self presenter whenSelectionChangedDo: [ 
		self updateSelectionOf: tableMorph ].
	
	self presenter whenRootsChangedDo: [ 
		tableMorph selectIndexes: #().
		tableMorph dataSource: self newDataSource ].
	
	self presenter whenShowColumnHeadersChangedDo: [ 	
		self isShowingColumnHeaders 
			ifTrue: [ tableMorph showColumnHeaders ] 
			ifFalse: [ tableMorph hideColumnHeaders ] ].
		
	self registerColumnsChangedEventTo: tableMorph.
	
	tableMorph
		onAnnouncement: FTSelectionChanged
			send: #selectionChanged:
			to: self;
		onAnnouncement: FTStrongSelectionChanged
			send: #strongSelectionChanged:
			to: self! !

!SpMorphicTreeTableAdapter methodsFor: 'initialization' stamp: ''!
addActivationKeyBindings: aWidget

	self 
		bindKeyCombination: Character cr asKeyCombination
		toAction: [ self triggerActivationAction ]! !

!SpMorphicTreeTableAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
isRowMorphExpandableAt: anInteger
	"Return true if the row at the index has an expandable icon. This is specific to FastTable."

	^ (self iconOfRowMorphAt: anInteger) isKindOf: IconicButtonMorph! !

!SpMorphicTreeTableAdapter methodsFor: 'testing' stamp: ''!
columnCount
	
	^ self widget columns size! !

!SpMorphicTreeTableAdapter methodsFor: 'testing' stamp: ''!
isSearchEnabled

	^ self presenter isSearchEnabled! !

!SpMorphicTreeTableAdapter methodsFor: 'emulating' stamp: ''!
sendClickEventToRowAtPath: aPath
	| evt rowWidget index |

	index := widget dataSource indexFromPath: aPath.
	rowWidget := widget container submorphs at: index.
	evt := MouseButtonEvent new 
		setType: nil 
		position: rowWidget bounds center 
		which: MouseButtonEvent redButton 
		buttons: MouseButtonEvent redButton 
		hand: self currentHand 
		stamp: nil.
	
	(widget handlesMouseDown: evt) ifTrue: [
		widget handleMouseDown: evt.
		widget handleMouseUp: evt ]! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
expandAll

	widget dataSource expandAll! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
selectedItem
	
	| selectedIndex |
	selectedIndex := self widget selectedIndex.
	
	selectedIndex = 0 ifTrue: [ ^ nil ].
	
	^ (self widget dataSource elementAt: selectedIndex) data! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
acceptDroppingMorph: aTransferMorph event: anEvent 
	
	self presenter acceptDrop cull: (self 
		transferFrom: aTransferMorph 
		event: anEvent)! !

!SpMorphicTreeTableAdapter methodsFor: 'scrolling' stamp: ''!
configureScrolling
	self presenter verticalAlignment
		whenChangedDo: [ widget
				scrollToIndex: self presenter verticalAlignment desiredVisibleRow ].
			
	self presenter
		whenDisplayDo: [ widget
				scrollToIndex: self presenter verticalAlignment desiredVisibleRow.
			self scrollingChanged ].
		
	widget
		onAnnouncement: FTScrollingChanged
		send: #scrollingChanged
		to: self.! !

!SpMorphicTreeTableAdapter methodsFor: 'testing' stamp: ''!
isResizable

	^ self presenter isResizable! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
selectionChanged: ann

	self suspendSelectionEventsDuring: [ 
		self basicSelectionChanged: ann ]! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
sortByColumn: aColumn 
	
	self widgetDo: [ :w | 
		w dataSource sortByColumn: (w columns 
			detect: [ :each | each model = aColumn ]) ]! !

!SpMorphicTreeTableAdapter methodsFor: 'emulating' stamp: ''!
sendClickWithShiftEventToRowAtPath: aPath
	| evt rowWidget index |
	
	index := widget dataSource indexFromPath: aPath.
	rowWidget := widget container submorphs at: index.
	evt := MouseButtonEvent new 
		setType: nil 
		position: rowWidget bounds center 
		which: MouseButtonEvent redButton 
		buttons: (MouseButtonEvent redButton | 8 "shift = 8 mask")
		hand: self currentHand 
		stamp: nil.

	(widget handlesMouseDown: evt) ifTrue: [
		widget handleMouseDown: evt.
		widget handleMouseUp: evt ]! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
expandRoots

	widget dataSource expandRoots! !

!SpMorphicTreeTableAdapter methodsFor: 'updating' stamp: ''!
updateMenu
	"there is no need to updateMenu here because it will be resolved at the dataSource"! !

!SpMorphicTreeTableAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
rowMorphAt: anInteger
	"Return the row morph at an index. Used for tests."

	^ self widget container visibleRowMorphAtIndex: anInteger! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
ensureAtLeastOneColumnIn: tableMorph
	self model columns ifNotEmpty: [ ^ self ].
	tableMorph addColumn: (self newColumnFrom: self defaultColumn)! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
itemAtPath: anArray

	self widgetDo: [ :w | 
		^ (w dataSource itemAtPath: anArray) ifNotNil: [ :item | item data ] ].
	^ nil! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
addColumnsFromPresenterTo: tableMorph

	"I need to ensure first column will have the size required and this is tricky on 
	 fixed width of column: I need to enlarge that width with the width of the expander."
	self columns withIndexDo: [ :each :index | | column |
		column := self newColumnFrom: each.
		(index = 1 and: [ column width notNil ]) ifTrue: [ 
			column width: column width + SpMorphicTreeTableDataSource emptyMorph width ]. 
		tableMorph addColumn: column ].
			! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
collapsePath: anArray  

	widget dataSource collapsePath: anArray! !

!SpMorphicTreeTableAdapter methodsFor: 'private' stamp: ''!
rootForItems: aCollection

	^ FTRootItem new
		data: aCollection;
		yourself! !

!SpMorphicTreeTableAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
expandRowAt: anInteger
	"Click on the iconic button of a row at an index in the tree."

	| evt expandIcon |
	expandIcon := self iconOfRowMorphAt: anInteger.

	evt := MouseButtonEvent new
		setType: nil
		position: expandIcon center
		which: MouseButtonEvent redButton
		buttons: MouseButtonEvent redButton
		hand: nil
		stamp: nil.

	expandIcon mouseDown: evt.
	expandIcon mouseUp: evt! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
registerColumnsChangedEventTo: tableMorph
	
	self presenter whenColumnsChangedDo: [
		tableMorph columns: #(). 
		self presenter columns do: [ :each | tableMorph addColumn: (self newColumnFrom: each) ].
		tableMorph dataSource: self newDataSource ].
! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
selectPath: anArray
	| index |
	
	((anArray isEmpty or: [ anArray first = 0 ]) 
		and: [ widget selectedIndexes isEmpty ]) 
		ifTrue: [ ^ self ].
	index := anArray 
		ifNotEmpty: [ widget dataSource indexFromPath: anArray ]
		ifEmpty: [ 0 ].  
	(widget selectedIndexes includes: index) ifTrue: [ ^ self ].
	widget selectIndex: index! !

!SpMorphicTreeTableAdapter methodsFor: 'private' stamp: ''!
triggerActivationAction

	self presenter doActivateAtPath: self presenter selection selectedPath! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
defaultColumn

	^ SpStringTableColumn new evaluated: [ :each | each yourself ]! !

!SpMorphicTreeTableAdapter methodsFor: 'scrolling' stamp: ''!
scrollingChanged
	widget container updateAllRows.
	self presenter verticalAlignment
		firstVisibleRowIndex: widget firstVisibleRowIndex;
		lastVisibleRowIndex: widget lastVisibleRowIndex! !

!SpMorphicTreeTableAdapter methodsFor: 'emulating' stamp: ''!
sendRightClickEvent
	| evt |

	evt := MouseButtonEvent new 
		setType: nil 
		position: widget center 
		which: MouseButtonEvent yellowButton 
		buttons: MouseButtonEvent yellowButton 
		hand: nil 
		stamp: nil.
	
	self widget click: evt! !

!SpMorphicTreeTableAdapter methodsFor: 'testing' stamp: ''!
isNonEditableRow: aRow column: aColumn

	^ (self widget dataSource
		cellColumn: (self widget columns at: aColumn)
		row: aRow) submorphs 
		allSatisfy: [ :e | e asReadOnlyMorph == e ]! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
selectedPath
	
	^ self selectedPaths first ! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
collapseAll

	widget dataSource collapseAll! !

!SpMorphicTreeTableAdapter methodsFor: 'updating' stamp: ''!
refreshTree

	self widget refresh! !

!SpMorphicTreeTableAdapter methodsFor: 'updating' stamp: ''!
updateSelectionOf: tableMorph
	
	self 
		selectInto: tableMorph 
		paths: self model selection selectedPaths! !

!SpMorphicTreeTableAdapter methodsFor: 'testing' stamp: ''!
isExpanded: anItem
	| path |
	
	path := widget dataSource 
		pathOfItem: anItem 
		root: widget dataSource rootItem.

  path ifEmpty: [ ^ false ].
	
	^ (widget dataSource itemAtPath: path) 
		ifNotNil: [ :node | node isExpanded ]
		ifNil: [ false ]! !

!SpMorphicTreeTableAdapter methodsFor: 'testing' stamp: ''!
isShowingColumnHeaders

	^ self presenter isShowingColumnHeaders! !

!SpMorphicTreeTableAdapter methodsFor: 'selecting' stamp: ''!
selectInto: aFTTableMorph paths: aCollectionOfPaths 
	
	| indexes items |
	
	items := aCollectionOfPaths collect: [ :aPath | | item |
		item := aFTTableMorph dataSource itemAtPath: aPath expanding: true.
		item 
			ifNil: [ aFTTableMorph selectIndex: 0. ^ self ].
		item ].

	aFTTableMorph refresh.
	indexes := items collect: [:item | aFTTableMorph dataSource indexOfItem: item].

	aFTTableMorph selectIndexes: indexes andMakeVisibleIf: false.! !

!SpMorphicTreeTableAdapter methodsFor: 'private - factory' stamp: ''!
newDataSource 

	^ SpMorphicTreeTableDataSource new
		model: self model; 
		rootItem: (self rootForItems: self model roots);
		childrenBlock: [ :data :item | self model childrenFor: data ];
		yourself! !

!SpMorphicTreeTableAdapter methodsFor: 'updating' stamp: ''!
transferFrom: aTransferMorph event: anEvent
	| rowAndColumn aTarget |

	rowAndColumn := self widget container rowAndColumnIndexContainingPoint: anEvent position.
	
	aTarget := rowAndColumn first 
		ifNil: [ nil ]
		ifNotNil: [ :anIndex | (self widget dataSource itemAtIndex: anIndex) data ].
		
	^ SpDragAndDropTransferToTree new
		passenger: aTransferMorph passenger;
		row: (rowAndColumn first ifNil: [ 0 ]);
		column: (rowAndColumn second ifNil: [ 0 ]);
		target: aTarget;
		yourself! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
scrollToSelection
	widget ensureVisibleFirstSelection.! !

!SpMorphicTreeTableAdapter methodsFor: 'initialization' stamp: ''!
addFocusRotationKeyBindings
	
	^ super addFocusRotationKeyBindings! !

!SpMorphicTreeTableAdapter methodsFor: 'initialization' stamp: ''!
addKeyBindingsTo: aWidget

	super addKeyBindingsTo: aWidget.
	self addContextMenuKeyBindings: aWidget.
	self addActivationKeyBindings: aWidget! !

!SpMorphicTreeTableAdapter methodsFor: 'private - factory' stamp: ''!
newColumnFrom: aTableColumn

	^ (SpMorphicTableColumn on: aTableColumn)
		width: aTableColumn width;
		yourself! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
strongSelectionChanged: aFTStrongSelectionChanged
	self presenter activatesOnDoubleClick
		ifFalse: [ ^ self ].
	self presenter doubleClickAtPath: self selectedPath! !

!SpMorphicTreeTableAdapter methodsFor: 'accessing' stamp: ''!
selectedPaths
	
	^ self widget selectedIndexes collect: [ :e | self widget dataSource pathFromIndex: e  ] ! !

!SpMorphicTreeTableAdapter methodsFor: 'updating' stamp: ''!
wantsDroppedMorph: aTransferMorph event: anEvent 
	
	^ self presenter wantsDrop cull: (self 
		transferFrom: aTransferMorph 
		event: anEvent)! !

!SpMorphicTreeTableAdapter methodsFor: 'factory' stamp: ''!
suspendSelectionEventsDuring: aBlock
	| registry subscriptions |

	registry := self widget announcer subscriptions.
	subscriptions := Set new.
	registry 
		subscriptionsOf: self 
		do: [ :each | 
			({ FTSelectionChanged. FTStrongSelectionChanged } includes: each announcementClass) 
				ifTrue: [ subscriptions add: each ] ]. 
			
	subscriptions do: [ :each | registry remove: each ].
	aBlock ensure: [ 
		 subscriptions do: [ :each | registry add: each ] ]! !

!SpMorphicTreeTableAdapter class methodsFor: 'accessing' stamp: ''!
intercellSpacing

	^ 2@0! !

!SpMorphicTreeTableCellBuilder commentStamp: ''!
I build cells for a MorphicTreeTableAdapter.!
!SpMorphicTreeTableCellBuilder methodsFor: 'accessing' stamp: ''!
item: anObject

	item := anObject! !

!SpMorphicTreeTableCellBuilder methodsFor: 'accessing' stamp: ''!
item
	
	^ item! !

!SpMorphicTreeTableDataSource commentStamp: ''!
I'm a dataSource to be used in MorphicTableAdapter to realise a TablePresenter.
I define my cells following the definition on columns (MorphicTableColumn).
I use a builder (MorphicTreeTableCellBuilder) to realise the cell content. !
!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
cellColumn: column row: rowIndex
	| cell builder item |
	
	item := self elementAt: rowIndex.
	cell := FTIndentedCellMorph new.
	(self isFirstColumn: column) ifTrue: [
		cell indentBy: (self cellIndentFor: item).
		cell addMorphBack: (self buttonFor: item) ].

	builder := SpMorphicTreeTableCellBuilder on: self.
	builder 
		cell: cell;
		item: item data;
		visit: column model.
	
	^ cell ! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
pathOfNode: anItem root: aRoot 
	
	aRoot isExpanded ifFalse: [ ^#() ].
	
	(aRoot children includes: anItem)
		ifTrue: [ ^ { aRoot children indexOf: anItem } ].
		
	aRoot children withIndexDo: [ :aChild :index | | aSubPath |
		aSubPath := self pathOfNode: anItem root: aChild.
		aSubPath ifNotEmpty: [ ^ { index } , aSubPath ] ].
	
	^ #().! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
indexOfItem: anItem 
	
	^ self allShownItems indexOf: anItem! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
cellIndentFor: item 

	^ item depth * 16! !

!SpMorphicTreeTableDataSource methodsFor: 'paths' stamp: ''!
indexFromPath: anArray 

	^ anArray sum! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
headerForColumn: aColumn

	^ self headersByColumn 
		at: aColumn 
		ifAbsentPut: [ self newHeaderColumn: aColumn ]! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
allShownItems

	^ rootItem children flatCollect: [ :e | e withExpandedChildren ].! !

!SpMorphicTreeTableDataSource methodsFor: 'testing' stamp: ''!
shouldDisplayExpandableArrowFor: item
	^ (self canDisplayChildrenOf: item) and: [
			self model shouldLazilyComputeChildren
				ifTrue: [ item hasComputedChildren ]
				ifFalse: [ item hasChildren ] ]! !

!SpMorphicTreeTableDataSource methodsFor: 'sorting' stamp: ''!
sortByColumn: aColumn event: anEvent morph: aMorph

	self sortByColumn: aColumn! !

!SpMorphicTreeTableDataSource methodsFor: 'private' stamp: ''!
setHeaderColumnLazyProperties: column
	"Some properties of a header just acquire value after rendering cells. This method makes sure 
	 properties are set, but is responsibility of the user to actually call it (usually after create 
	 a cell). See senders of this method too see where it goes."
	| headerMorph |
	
	column isExpandable ifTrue: [ ^ self ].  
	
	headerMorph := self headerForColumn: column.
	headerMorph hResizing = #rigid 
		ifFalse: [ headerMorph hResizing: #rigid ].
	headerMorph width = column model width ifFalse: [ 
		headerMorph width: (column model width ifNil: [ 0 ]). ]! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	| menuPresenter |

	menuPresenter := self model contextMenu.
	menuPresenter ifNil: [ ^ nil ].
	^ SpBindings
		value: self model application adapterBindings
		during: [ menuPresenter value buildWithSpec ]! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
itemAtIndex: anInteger 
	
	^ self allShownItems at: anInteger! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!SpMorphicTreeTableDataSource methodsFor: 'private - factory' stamp: ''!
newHeaderColumn: column
	| headerMorph |
	
	headerMorph := SpHeaderCellMorph new 
		addMorph: (column id ifNil: [ '' ]) asMorph asReadOnlyMorph;
		yourself.
		
	column isSortable ifTrue: [ 
		headerMorph eventHandler: (MorphicEventHandler new 
			on: #click 
			send: #sortByColumn:event:morph:
			to: self
			withValue: column).
	column sortingIcon ifNotNil: [ :icon | headerMorph addMorph: icon ] ].

	^ headerMorph! !

!SpMorphicTreeTableDataSource methodsFor: 'sorting' stamp: ''!
sortElements: aSortFunction

	unsortedElements ifNil: [ unsortedElements := self rootsItems ].
	self rootItem data: ((self rootItem children collect: #data) sorted: aSortFunction)! !

!SpMorphicTreeTableDataSource methodsFor: 'testing' stamp: ''!
isFirstColumn: column
	
	^ (table columns indexOf: column) = 1! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
rootItem: anItem

	super rootItem: anItem.
	self addSourceToRootItem! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
toString: anItem
	"Override me if you expect something else."

	^ super toString: anItem data! !

!SpMorphicTreeTableDataSource methodsFor: 'drag and drop' stamp: ''!
passengerAt: rowIndex
	"Answer 'passenger' for drag&drop operation (a passenger is the object who will travel between 
	 drag and drop). By default, passenger is same as current element"
	^ (self allShownItems at: rowIndex) data! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
searchText: aString

	^ (self class perform: (self searchStrategy, 'Strategy') asSymbol) 
		searchWith: aString 
		dataSource: self! !

!SpMorphicTreeTableDataSource methodsFor: 'sorting' stamp: ''!
sortByColumn: aColumn

	aColumn sortDataSource: self.
	self model selection unselectAll.! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
buttonFor: item

	^ (self shouldDisplayExpandableArrowFor: item) 
		ifTrue: [ item generateButton ] 
		ifFalse: [ self class emptyMorph ]! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
itemAtPath: aPath expanding: shouldExpandItems
	
	| item |
	
	(aPath isNil or: [aPath isEmpty]) ifTrue: [ ^ nil ].
	item := self rootItem.
	
	aPath do: [ :index |
		(shouldExpandItems and: [item isRoot not]) ifTrue: [ item expand ].
		item children size < index ifTrue: [ ^ nil ].		
		item := item children at: index.
	].

	^ item! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
headersByColumn 

	^ headersByColumn ifNil: [ headersByColumn := SmallDictionary new ]	! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
pathOfItem: anItem root: aNode
	"Looks for the path of an item (contained in a node)"
	
	aNode isExpanded ifFalse: [ ^#() ].
	
	aNode children 
		detect: [ :each | each data = anItem ]
		ifFound: [ :childNode | ^ { aNode children indexOf: childNode } ].
		
	aNode children withIndexDo: [ :aChild :index | | aSubPath |
		aSubPath := self pathOfItem: anItem root: aChild.
		aSubPath ifNotEmpty: [ ^ { index } , aSubPath ] ].
	
	^ #()! !

!SpMorphicTreeTableDataSource methodsFor: 'paths' stamp: ''!
pathFromIndex: anInteger 
	| item |
	
	item := self allShownItems at: anInteger ifAbsent: [ ^ #() ].
	^ self pathOfNode: item root: rootItem! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
headerColumn: column

	(column id isNil and: [ self model isShowingColumnHeaders not ]) ifTrue: [ ^ nil ].
	^ self headerForColumn: column! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
model: aTablePresenter

	model := aTablePresenter! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
expandPath: anArray root: nodes 
	| node |
	
	anArray ifEmpty: [ ^ self ].
	nodes ifEmpty: [ ^ self ].

	node := nodes at: anArray first.
	node expand.
	self expandPath: anArray allButFirst root: node children! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
itemAtPath: aPath 
	
	^ self itemAtPath: aPath expanding: false! !

!SpMorphicTreeTableDataSource methodsFor: 'private' stamp: ''!
collapsePath: aPath

	(self itemAtPath: aPath) ifNotNil:[ :aNode | 
		aNode collapseAll.
		self tableRefresh ]! !

!SpMorphicTreeTableDataSource methodsFor: 'accessing' stamp: ''!
expandPath: anArray

	self expandPath: anArray root: self rootItem children.
	self tableRefresh! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpMorphicTreeTableDataSource class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpMorphicTreeTableDataSource class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpMorphicTreeTableDataSource class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpMorphicTreeTableDataSource class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpMorphicTreeTableDataSource class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpMorphicTreeTableDataSource class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicTreeTableDataSource class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpMorphicTreeTableDataSource class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpMorphicTreeTableDataSource class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpMorphicTreeTableDataSource class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpMorphicTreeTableDataSource class methodsFor: 'search strategies' stamp: ''!
allItemsStrategy

	^ SpMorphicAllItemsStrategy! !

!SpMorphicTreeTableDataSource class methodsFor: 'search strategies' stamp: ''!
defaultStrategy

	^ SpMorphicVisibleItemsStrategy! !

!SpMorphicTreeTableDataSource class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpMorphicTreeTableDataSource class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpMorphicTreeTableDataSource class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpMorphicTreeTableDataSource class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpMorphicTreeTableDataSource class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpMorphicTreeTableDataSource class methodsFor: 'search strategies' stamp: ''!
rootsOnlyStrategy

	^ SpMorphicRootItemsStrategy! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpMorphicTreeTableDataSource class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpMorphicTreeTableDataSource class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpMorphicTreeTableDataSource class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpMorphicVisibleItemsStrategy methodsFor: 'accessing' stamp: ''!
isMatching: anItem

	^ dataSource model 
		performSearch: anItem data
		matching: pattern! !

!SpMorphicWindowAdapter commentStamp: ''!
I am the adapter used to bridge a WindowPresenter and a SystemWindow!
!SpMorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
isDisplayed

	^ self widget isDisplayed! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
askOkToClose

	^ self model askOkToClose! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
isMinimized

	self widgetDo: [ :w | ^ w isMinimized ].
	^ false! !

!SpMorphicWindowAdapter methodsFor: 'spec protocol' stamp: ''!
minimize

	self widgetDo: [ :w | w minimize ]! !

!SpMorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
open

	self widget openInWorld.
	self presenter initialPosition 
		ifNotNil: [ :aPosition | self widget position: aPosition ].
	self presenter isCentered 
		ifTrue: [ self centered ].
	self presenter presenter takeKeyboardFocus.
	self windowIsOpened! !

!SpMorphicWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpWindow new
		model: model;
		isResizeable: self isResizable;
		in: [ :this | self subscribeToAnnouncements: this ];
		yourself! !

!SpMorphicWindowAdapter methodsFor: 'updating' stamp: ''!
windowIsOpened

	self presenter windowIsOpened! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
okToChange

	^ self model okToChange! !

!SpMorphicWindowAdapter methodsFor: 'spec protocol' stamp: ''!
isTopWindow

	self widgetDo: [ :w | ^ w isTopWindow ].
	^ false! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
isMaximized

	self widgetDo: [ :w | ^ w isMaximized ].
	^ false! !

!SpMorphicWindowAdapter methodsFor: 'factory' stamp: ''!
subscribeToAnnouncements: aWindow

	aWindow announcer 
		when: SpWindowWillClose send: #announce: to: self presenter announcer;
		when: SpWindowResizing send: #announce: to: self presenter announcer;
		when: WindowClosed send: #windowClosed to: self! !

!SpMorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
close

	self widget ifNotNil: [ :w | w close ]! !

!SpMorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
extent: aPoint

	^ self widget extent: aPoint! !

!SpMorphicWindowAdapter methodsFor: 'event installing' stamp: ''!
installFocusReceivedEvent: anEvent to: aWidget

	aWidget announcer
		when: WindowActivated
		do: [ anEvent action value ]! !

!SpMorphicWindowAdapter methodsFor: 'icons' stamp: ''!
taskbarIcon

	^ self model taskbarIcon! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
title

	^ self model title! !

!SpMorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
addPresenterIn: aWindow withSpecLayout: aSpec
	| contentWidget |

	self presenter initialPosition 
		ifNotNil: [ :position | aWindow position: position ].
	self presenter initialExtent 
		ifNotNil: [ :extent | aWindow extent: extent ].
	self presenter hasDecorations 
		ifFalse: [ aWindow removeLabelArea ].
	self presenter whenDecorationsChangedDo: [ :aBoolean |
		aBoolean 
			ifTrue: [ aWindow initializeLabelArea ]
			ifFalse: [ aWindow removeLabelArea ] ].
	self presenter whenResizableChangedDo: [ :aBoolean | 
		aWindow isResizeable: aBoolean ].

	contentWidget := self presenter presenter buildWithSpecLayout: aSpec.	
	self presenter presenter adapter applyStyle.
	self 
		addContent: contentWidget 
		toWindow: aWindow! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
delete

	self widgetDo: [ :w | 
		w delete.
		self application windowClosed: self ]! !

!SpMorphicWindowAdapter methodsFor: 'updating' stamp: ''!
windowClosed

	self windowIsClosing.
	self presenter windowClosed! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
initialExtent

	^ self model initialExtent! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
title: aString

	self widgetDo: [ :w | 
		w setLabel: (aString ifNotNil: [ :theString | 
				 theString localizedForPresenter: self presenter ]) ]! !

!SpMorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
beep 
	
	widget flash! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
isResizable

	^ self model isResizable! !

!SpMorphicWindowAdapter methodsFor: 'updating' stamp: ''!
windowIsClosing

	self model windowIsClosing! !

!SpMorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
centered

	self widgetDo: [ :w | 
		w
			computeFullBounds;
			position: (self currentWorld extent - w extent) // 2 ]! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
resize: aPoint

	widget extent: aPoint! !

!SpMorphicWindowAdapter methodsFor: 'event installing' stamp: ''!
installFocusLostEvent: anEvent to: aWidget

	aWidget announcer
		when: WindowDeActivated
		do: [ anEvent action value ]! !

!SpMorphicWindowAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
windowSize

	^ widget extent! !

!SpMorphicWindowAdapter methodsFor: 'initialization' stamp: ''!
addFocusRotationKeyBindings
	"Windows should not process keybindings (because then the active widget will not get 
	 the event)"! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
cancelled

	^ false! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
centeredRelativeTo: aWindowPresenter
	| bounds position |

	self widgetDo: [ :w | 
		w computeFullBounds.
		bounds := aWindowPresenter
			ifNotNil: [ aWindowPresenter adapter widget bounds ]
			ifNil: [ self currentWorld bounds ].
		position := bounds origin + ((bounds extent - w extent) // 2).
		w position: position ]! !

!SpMorphicWindowAdapter methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
windowIsResizable

	^ widget isResizeable! !

!SpMorphicWindowAdapter methodsFor: 'widget API' stamp: ''!
aboutTitle
    ^ self model model
         ifNotNil: [ :m | (m respondsTo: #aboutTitle)
		ifTrue: [m aboutTitle]
		ifFalse: [m class name]].! !

!SpMorphicWindowAdapter methodsFor: 'protocol' stamp: ''!
rebuildWithSpecLayout: aSpec

	| sub |
	sub := self model window submorphs copy.
	self model window removeAllMorphs.
	sub allButLast do: [ :e | self model window addMorphBack: e ].
	self model addPresenterIn: self widget withSpecLayout: aSpec.
	self widget model: self! !

!SpMorphicWindowAdapter methodsFor: 'spec protocol' stamp: ''!
maximize

	self widgetDo: [ :w | w maximize ]! !

!SpMorphicWindowAdapterTest methodsFor: 'tests' stamp: ''!
testOpenWidgetPresenterAppliesStyle
	| presenter window |

	presenter := SpTextPresenter new.
	[ window := presenter openWithSpec ]
	ensure: [ window close ].
	
	self 
		assert: presenter adapter widget font 
		equals: StandardFonts defaultFont.
	
	presenter := SpTextPresenter new.
	presenter addStyle: 'code'.
	[ window := presenter openWithSpec ]
	ensure: [ window close ].

	self 
		assert: presenter adapter widget font 
		equals: StandardFonts codeFont.
! !

!SpMorphicWorldAdapter commentStamp: ''!
I am the adapter used to bridge a WorldPresenter and a WorldMorph!
!SpMorphicWorldAdapter methodsFor: 'adding' stamp: ''!
addPresenterIn: widgetToBuild withSpecLayout: aSpec

	self 
		addContent: (self model presenter buildWithSpecLayout: aSpec) 
		toWindow: widgetToBuild! !

!SpMorphicWorldAdapter methodsFor: 'private' stamp: ''!
newContainerMorph

	^ super newContainerMorph
		  adoptPaneColor: self theme backgroundColor;
		  yourself! !

!SpMorphicWorldAdapter methodsFor: 'private' stamp: ''!
title: aString
	"Update the host window title"

	DisplayScreen hostWindowTitle: aString! !

!SpMorphicWorldAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ self presenter currentWorld
		borderColor: self theme backgroundColor;
		borderWidth: 4;
		yourself! !

!SpMorphicWorldAdapter methodsFor: 'api' stamp: ''!
centered
	"Do nothing. I will fill the full world"! !

!SpMouseDoubleClickDefinition commentStamp: ''!
I define a double click event!
!SpMouseDoubleClickDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	anAdapter installMouseDoubleClickEvent: self to: aWidget! !

!SpMouseDownEventDefinition commentStamp: ''!
I define a mouse down event!
!SpMouseDownEventDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	anAdapter installMouseDownEvent: self to: aWidget! !

!SpMouseEnterEventDefinition commentStamp: ''!
I define a mouse enter event!
!SpMouseEnterEventDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	anAdapter installMouseEnterEvent: self to: aWidget! !

!SpMouseLeaveEventDefinition commentStamp: ''!
I define a key down event!
!SpMouseLeaveEventDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	anAdapter installMouseLeaveEvent: self to: aWidget! !

!SpMouseMoveEventDefinition commentStamp: ''!
I define a mouse move event!
!SpMouseMoveEventDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	anAdapter installMouseMoveEvent: self to: aWidget! !

!SpMouseUpEventDefinition commentStamp: ''!
I define a mouse up event!
!SpMouseUpEventDefinition methodsFor: 'installing' stamp: ''!
installOn: anAdapter target: aWidget

	anAdapter installMouseUpEvent: self to: aWidget! !

!SpMultipleSelectionMode commentStamp: ''!
Implement multiple selection mode (Users can select multiple element of list or table)!
!SpMultipleSelectionMode methodsFor: 'testing' stamp: ''!
includesIndexes: aCollection
	^ aCollection allSatisfy: [ :anIndex | self selectedIndexes includes: anIndex ]! !

!SpMultipleSelectionMode methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ self selectedIndexes isEmpty! !

!SpMultipleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectIndexes: aCollectionOfIndexes
	"Select items at positions included in `aCollectionOfIndexes`."
	| indexes |

	indexes := aCollectionOfIndexes 
		collect: [ :each | self withinRangeIndex: each ]
		thenReject: [ :each | each = 0 ]. "0 index means out of range"
	(aCollectionOfIndexes isNotEmpty and: [ indexes isEmpty ]) "all indexes are out of range"
		ifTrue: [ ^ #() ].

	indexes := indexes asOrderedCollection removeDuplicates.
	indexes = self selectedIndexes ifTrue: [ ^ self ].

	^ selectedIndexes := indexes! !

!SpMultipleSelectionMode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	selectedIndexes := OrderedCollection new! !

!SpMultipleSelectionMode methodsFor: 'testing' stamp: ''!
includesItem: anItem

	^ self selectedItems includes: anItem! !

!SpMultipleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectItems: aCollection
	"Select items included in `aCollection` if they are included in model list."

	self selectIndexes: (aCollection collect: [ :anItem | self indexOfItem: anItem ])! !

!SpMultipleSelectionMode methodsFor: 'testing' stamp: ''!
includesIndex: anIndex

	^ self selectedIndexes includes: anIndex! !

!SpMultipleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedIndex
	"Answer the first selected index."

	^ self selectedIndexes 
		ifNotEmpty: [ :indexes | indexes first ] 
		ifEmpty: [ 0 ]! !

!SpMultipleSelectionMode methodsFor: 'private' stamp: ''!
basicSelectIndex: indexToSelect

	"Adding to the selection an out of range should not change selection"
	indexToSelect = 0 ifTrue: [ ^ self ].

	self selectIndexes: (self selectedIndexes copyWith: indexToSelect)! !

!SpMultipleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedItem
	"Answer first selected item."

	^ self selectedItems 
		ifNotEmpty: [ :items | items first ]
		ifEmpty: [ nil ]! !

!SpMultipleSelectionMode methodsFor: 'private' stamp: ''!
selectedItemsSortedByIndex

	^ self widget itemsAt: self selectedIndexes sort! !

!SpMultipleSelectionMode methodsFor: 'private' stamp: ''!
selectionHolder
	^ self observablePropertyNamed: #selectedIndexes! !

!SpMultipleSelectionMode methodsFor: 'api - selection' stamp: ''!
unselectAll
	"Remove all selections."
	
	self selectIndexes: #()! !

!SpMultipleSelectionMode methodsFor: 'api - selection' stamp: ''!
unselectIndex: anIndex
	"Unselect item at position `anInteger`."

	self selectIndexes: (self selectedIndexes copyWithout: anIndex)! !

!SpMultipleSelectionMode methodsFor: 'testing' stamp: ''!
includesItems: aCollection
	^ aCollection allSatisfy: [ :anItem | self selectedItems includes: anItem ]! !

!SpMultipleSelectionMode methodsFor: 'api - events' stamp: ''!
whenChangedDo: aBlock
	"Inform when selection has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #selectedIndexes whenChangedDo: [ aBlock cull: self ]! !

!SpMultipleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectAll
	"Select all items."
	
	self selectIndexes: (1 to: self model size)! !

!SpMultipleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedIndexes
	"Answer a collection with indexes of all selected items."

	^ selectedIndexes! !

!SpMultipleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedItems
	"Answer a collection with all selected items."

	^ self widget itemsAt: self selectedIndexes! !

!SpMultipleSelectionMode methodsFor: '*Spec2-Transmission' stamp: ''!
transmission 
	
	^ self selectedItems! !

!SpMultipleSelectionMode methodsFor: 'testing' stamp: ''!
isMultipleSelection
	
	^ true! !

!SpMultipleSelectionModeTest methodsFor: 'tests' stamp: ''!
testGetRightElementAfterSortingOfElementsChanged
	presenter := SpTablePresenter new. "use a TablePresenter since ListPresenter cannot sort"
	presenter 
		items: (1 to: 10) asArray;
		beMultipleSelection;
		openWithSpec.
	
	presenter 
		withAdapterDo: [ :adapter | adapter widget dataSource sortElements: [ :a :b | a > b ] ];
		selectIndexes: #(1 3).
	
	self 
		assert: presenter selection selectedItems asArray 
		equals: #(10 8)! !

!SpMultipleSelectionModeTest methodsFor: 'tests' stamp: ''!
testSelectionIsResetAfterSorting
	presenter := SpTablePresenter new.	"use a TablePresenter since ListPresenter cannot sort"
	presenter
		items: (1 to: 10) asArray;
		beMultipleSelection;
		openWithSpec;
		selectIndexes: #(1 3).
		
	presenter
		withAdapterDo: [ :adapter | 
			adapter widget dataSource
				sortByColumn: presenter adapter columns first
				event: nil
				morph: nil ].
			
	self assert: presenter selection selectedItems isEmpty! !

!SpMultipleSelectionModeTest methodsFor: 'tests' stamp: ''!
testSelectionIsResetAfterItemsAssignment
	presenter
		beMultipleSelection;
		openWithSpec;
		selectIndexes: #(1 2 3).

	presenter items: #(2 5).

	self 
		assert: presenter selection selectedItems asArray
		equals: #()! !

!SpMultipleSelectionModeTest methodsFor: 'tests' stamp: ''!
testSubscriptionsAreTransfered
	| count |
	count := 0.
	presenter beMultipleSelection.
	presenter whenSelectionChangedDo: [ count := count + 1 ].
	presenter beSingleSelection.
	presenter selectIndex: 2.
	self assert: count equals: 1! !

!SpNavigationMockClass methodsFor: 'mock' stamp: ''!
referenceToYourself

	^ SpNavigationMockClass! !

!SpNavigationMockClass methodsFor: 'mock' stamp: ''!
referenceToTheClassVariable

	^ SomeClassVariable! !

!SpNavigationMockClass methodsFor: 'mock' stamp: ''!
referenceToTheClassPoolVariable

	^ SomeClassPoolVariable! !

!SpNavigationMockClassPool methodsFor: 'mock' stamp: ''!
referenceToYourself

	^ SpNavigationMockClass! !

!SpNonObservableSlotError class methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!SpNotebookAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpNotebookPresenter! !

!SpNotebookAdapterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance
	presenter
		addPage: (SpNotebookPage title: 'Mock' icon: (self iconNamed: #changeUpdate) provider: [ SpButtonPresenter new ]);
		addPage: (SpNotebookPage title: 'Mock2' icon: (self iconNamed: #changeUpdate) provider: [ SpLabelPresenter new ])! !

!SpNotebookAdapterTest methodsFor: 'tests' stamp: ''!
testRemovePage
	| page |
	presenter addPage: (page := SpNotebookPage title: 'Mock3' provider: [ SpLabelPresenter new ]).
	self assert: self adapter numberOfTabs equals: 3.
	presenter removePage: page.
	self assert: self adapter numberOfTabs equals: 2! !

!SpNotebookAdapterTest methodsFor: 'tests' stamp: ''!
testChangeTitleUpdatesTab

	presenter selectPageIndex: 2.
	self assert: self adapter selectedPageName equals: 'Mock2'.
	
	presenter selectedPage title: 'Changed'.
	self assert: self adapter selectedPageName equals: 'Changed'! !

!SpNotebookAdapterTest methodsFor: 'tests' stamp: ''!
testSelectedPage
	presenter selectPageIndex: 2.
	self assert: self adapter selectedPageName equals: 'Mock2'! !

!SpNotebookAdapterTest methodsFor: 'tests' stamp: ''!
testAddPage
	self assert: self adapter numberOfTabs equals: 2.
	presenter addPage: (SpNotebookPage title: 'Mock3' provider: [ SpLabelPresenter new ]).
	self assert: self adapter numberOfTabs equals: 3! !

!SpNotebookAdapterTest methodsFor: 'tests' stamp: ''!
testSelectingPageShouldAnnounceChangeEvent
	| change |

	self adapter widget tabSelectorMorph selectedIndex: 1.
	self adapter widget announcer when: SpNotebookPageChanged do: [ :ann | change := ann ].
	
	self adapter widget tabSelectorMorph selectedIndex: 2.
	
	self assert: change oldPage model title equals: 'Mock'.
	self assert: change page model title equals: 'Mock2'! !

!SpNotebookAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveMiddlePageWhenLastIsSelected

	presenter addPage: (SpNotebookPage title: 'Mock3' provider: [ SpLabelPresenter new ]).
	self assert: self adapter numberOfTabs equals: 3.
	presenter selectPageIndex: 3.
	self assert: self adapter selectedPageName equals: 'Mock3'.
	presenter removePageAt: 2.
	self assert: self adapter numberOfTabs equals: 2.
	self assert: self adapter selectedPageName equals: 'Mock3'! !

!SpNotebookAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveAll

	self assert: self adapter numberOfTabs equals: 2.
	presenter removeAll.
	self assert: self adapter numberOfTabs equals: 0! !

!SpNotebookAdapterTest methodsFor: 'tests' stamp: ''!
testRemovePageAt

	presenter addPage: (SpNotebookPage title: 'Mock3' provider: [ SpLabelPresenter new ]).
	self assert: self adapter numberOfTabs equals: 3.
	presenter selectPageIndex: 1.
	self assert: self adapter selectedPageName equals: 'Mock'.
	presenter removePageAt: 2.
	self assert: self adapter numberOfTabs equals: 2.
	self assert: self adapter selectedPageName equals: 'Mock'! !

!SpNotebookAdapterTest methodsFor: 'tests' stamp: ''!
testClickOnPage

	self adapter clickTab: 2.
	self assert: self adapter selectedPageName equals: 'Mock2'! !

!SpNotebookMorph commentStamp: ''!
I'm a tab morph used to build spec notebooks.
I extend my parent by adding special ways to add pages (allowing any widget to be a page).
I also add a toolbar to add actions.!
!SpNotebookMorph methodsFor: 'private' stamp: ''!
removePageIndex: anInteger
	self removePage: (self pages at: anInteger)! !

!SpNotebookMorph methodsFor: 'adding' stamp: ''!
addLazyPage: aBlock label: aStringOrMorph model: aSpNotebookPage 
	| newPage label |
	
	newPage := SpNotebookPageMorph new.
	newPage lazyPageMorphCreation: aBlock.

	"not adding actions here, for our notebook it will be 
	coded in the label widget (since I may want to control when close, etc.)"
	label := self 
		buildLabelFrom: aStringOrMorph 
		withAction: nil. 
	
	newPage labelMorph: label.
	
	self addPage: newPage label: label! !

!SpNotebookMorph methodsFor: 'factory' stamp: ''!
newContentMorph
	"Answer a new content morph"

	^ PanelMorph new
		roundedCorners: #(2 3 4);
		changeTableLayout; 
		layoutInset: 4;
		cellInset: 8;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		borderStyle: (self theme tabPanelBorderStyleFor: self);
		yourself! !

!SpNotebookMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self 
		removeMorph: self contentMorph;
		removeMorph: self tabSelectorMorph;  
		headerMorph: self newHeaderMorph;
		addMorph: self headerMorph;
		addMorph: self contentMorph! !

!SpNotebookMorph methodsFor: 'accessing' stamp: ''!
headerMorph: anObject
	headerMorph := anObject.
	
	headerMorph clipSubmorphs: true.! !

!SpNotebookMorph methodsFor: 'factory' stamp: ''!
newCloseButtonFor: aSpNotebookPage

	^ self theme
		newCloseControlIn: self
		for: aSpNotebookPage
		action: [ aSpNotebookPage removeFromNotebook ]
		help: 'Close this page' translated! !

!SpNotebookMorph methodsFor: 'private' stamp: ''!
buildLabelFrom: aStringOrMorph withAction: aMorph
	| innerLabel |

	innerLabel := aStringOrMorph isMorph
		ifTrue: [ aStringOrMorph ]
		ifFalse: [ self buildLabelFrom: aStringOrMorph ].
	
	aMorph ifNotNil: [
		innerLabel addMorphBack: aMorph ].

	^ innerLabel! !

!SpNotebookMorph methodsFor: 'private' stamp: ''!
postAddPage: aMorph 
	"a hook to format the page after creation"! !

!SpNotebookMorph methodsFor: 'private' stamp: ''!
removePage: aPage
	| removedPageIndex |
	
	removedPageIndex := self pages indexOf: aPage.

	self suspendAnnouncementsDuring: [ 
		self pages remove: aPage.
		self tabSelectorMorph removeTabIndex: removedPageIndex ].

	self announcer announce: (SpNotebookPageRemoved new
			tabs: self;
			page: aPage;
			pageIndex: removedPageIndex;
			newIndex: self tabSelectorMorph selectedIndex).

	self pages ifEmpty: [ self contentMorph removeAllMorphs ]! !

!SpNotebookMorph methodsFor: 'private' stamp: ''!
buildLabelFrom: aString 
	
	^ LabelMorph newLabel: aString! !

!SpNotebookMorph methodsFor: 'adding' stamp: ''!
addPage: aMorph label: aStringOrMorph
	
	super addPage: aMorph label: aStringOrMorph.
	aMorph privateOwner: self! !

!SpNotebookMorph methodsFor: 'accessing' stamp: ''!
pageWithModel: anObject
	"an utility to easy find pages with a model"

	^ self pages detect: [ :each | each model = anObject ]! !

!SpNotebookMorph methodsFor: 'private' stamp: ''!
updatePageIndex: index oldIndex: oldSelectedIndex
	"Change to the given page index, update the toolbar and send the announcement"
	| oldPage newPage |

	index = 0 ifTrue: [ ^ self ].

	oldPage := self pages at: oldSelectedIndex.
	self pageMorph
		ifNotNil: [ :aPage | self updateContentMorph: aPage with: (self pageAt: index) ]
		ifNil: [ self contentMorph addMorph: (self pageAt: index) ].

	newPage := self pages at: index.
	self postAddPage: newPage.
	self headerMorph layoutChanged.
	self pageMorph layoutChanged.
	self adoptPaneColor: (self owner ifNil: [ self ]) paneColor.
	self tabSelectorMorph font ifNotNil: [ :aFont | 
		(self tabSelectorMorph tabs at: index) font: aFont ].
	
	self announcer announce: (SpNotebookPageChanged new
		page: newPage;
		oldPage: oldPage;
		pageIndex: index)! !

!SpNotebookMorph methodsFor: 'private' stamp: ''!
updateContentMorph: aMorph with: newMorph
	| pageBounds |

	pageBounds := self pageMorph bounds.
	self contentMorph replaceSubmorph: aMorph by: newMorph.
	self flag: 'Without setting here the bounds the page moves a few pixels when 
	refreshing the inspector'.
	self pageMorph bounds: pageBounds.
	self pageMorph layoutChanged! !

!SpNotebookMorph methodsFor: 'private' stamp: ''!
suspendAnnouncementsDuring: aBlock
	| subscriptions |
	subscriptions := self announcer subscriptions subscriptions.
	subscriptions do: [ :sub | self announcer unsubscribe: sub ].
	aBlock value.
	subscriptions do: [ :sub | self announcer basicSubscribe: sub ]! !

!SpNotebookMorph methodsFor: 'testing' stamp: ''!
hasPageWithModel: anObject
	"an utility to easy know if the notebook has a page for a model"

	^ self pages anySatisfy: [ :each | each model = anObject ]! !

!SpNotebookMorph methodsFor: 'private' stamp: ''!
updatePageIndex: index
	"Change to the given page index, update the toolbar and send the announcement"
	| oldPage newPage |

	index = 0 ifTrue: [ ^ self ].

	oldPage := self pages at: self selectedPageIndex.
	self pageMorph
		ifNotNil: [ :aPage | self updateContentMorph: aPage with: (self pageAt: index) ]
		ifNil: [ self contentMorph addMorph: (self pageAt: index) ].

	newPage := self pages at: index.
	self postAddPage: newPage.

	self headerMorph layoutChanged.
	self pageMorph layoutChanged.
	self adoptPaneColor: (self owner ifNil: [ self ]) paneColor.
	self tabSelectorMorph font ifNotNil: [ :aFont |
		(self tabSelectorMorph tabs at: index) font: aFont ].

	self announcer announce: (SpNotebookPageChanged new
		page: newPage;
		oldPage: oldPage;
		pageIndex: index)! !

!SpNotebookMorph methodsFor: 'factory' stamp: ''!
newTabSelectorMorph 

	^ SpNotebookTabSelectorMorph new
		vResizing: #shrinkWrap;
		hResizing: #spaceFill;
		cellInset: self class tabCellInset;
		yourself! !

!SpNotebookMorph methodsFor: 'accessing' stamp: ''!
headerMorph
	^ headerMorph! !

!SpNotebookMorph methodsFor: 'private' stamp: ''!
newHeaderMorph

	^ (self theme newRowIn: self theme for: { self tabSelectorMorph }) 
		cellInset: 0; 
		cellPositioning: #bottomCenter; 
		borderWidth: 0! !

!SpNotebookMorph methodsFor: 'private' stamp: ''!
pageAt: index

	^ (self pages at: index) actualPageMorph! !

!SpNotebookMorph class methodsFor: 'accessing' stamp: ''!
tabCellInset

	^ 2! !

!SpNotebookPage commentStamp: ''!
A page for a SpNotebookPresenter.
A page can have a title, an icon and some other interesting properties.

An important member is `SpNotebookPage>>#presenterProvider`, which contains a block to retrieve the content of the page, which can be resolved lazily.!
!SpNotebookPage methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpNotebookPage methodsFor: 'api - events' stamp: ''!
whenRetrievedDo: aBlock 
	"Inform when a page has been retrived, allowing extra settings.
	 `aBlock` is a block with one orgument (the presenter retrieved)"
	
	retrievedBlock := aBlock! !

!SpNotebookPage methodsFor: 'api - events' stamp: ''!
whenTitleChangedDo: aBlock

	self property: #title whenChangedDo: aBlock! !

!SpNotebookPage methodsFor: 'private' stamp: ''!
retrievePresenter
	"refresh all the time, because content may have change"

	activePresenter := self presenterProvider value.
	retrievedBlock ifNotNil: [ 
		retrievedBlock cull: activePresenter ].
	^ activePresenter! !

!SpNotebookPage methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpNotebookPage methodsFor: 'testing' stamp: ''!
isCloseable
	"Answer when the page is closeable or not"

	^ closeable! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
resetContent
	"force a redraw of contents of this page (next time it is selected)"
	
	self owner updatePageContent: self! !

!SpNotebookPage methodsFor: 'private' stamp: ''!
unsubscribe: anObject
	| observableSlots |
	
	observableSlots := self class allSlots 
		select: [ :aSlot | aSlot isObservableSlot ]
		thenDo: [ :aSlot |
			| slotValue | 
			slotValue := aSlot rawRead: self.
			slotValue ifNotNil: [ 
				slotValue unsubscribe: anObject ] ].! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
presenterProvider: aBlock
	"Set the presenter provider (tipically a block, but any valuable could work).
	 The block will be executed before showing the page contents."

	presenterProvider := aBlock! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
icon
	"Answer the icon (an instance of `Form`) to show with title"

	^ icon! !

!SpNotebookPage methodsFor: 'accessing' stamp: ''!
owner

	^ owner! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
beCloseable
	"Set the page as closeable, make a closing button to appear with the title."

	closeable := true! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
title
	"Answer the title to show in the notebook"

	^ title! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
icon: anIcon
	"Set the icon (an instance of `Form`) to show with title"

	icon := anIcon! !

!SpNotebookPage methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
layoutSpec

	^ layoutSpec! !

!SpNotebookPage methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpNotebookPage methodsFor: 'initialization' stamp: ''!
initialize
	
	self class initializeSlots: self.
	super initialize.
	closeable := false! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
layoutSpec: aSymbol

	layoutSpec := aSymbol! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
title: aString
	"Set the title to show in the notebook"

	title := aString! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
activePresenter
	"Answer current active presenter fot this page (it may be nil, if page has not been displayed yet)"
	
	^ activePresenter! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
removeFromNotebook
	"Remove this page from the notebook."

	owner removePage: self! !

!SpNotebookPage methodsFor: 'api' stamp: ''!
presenterProvider
	"Answer the presenter provider (tipically a block, but any valuable could work)."

	^ presenterProvider! !

!SpNotebookPage methodsFor: 'private' stamp: ''!
pageTitleChanged

	self owner ifNil: [ ^ self ].
	self owner pageTitleChanged: self! !

!SpNotebookPage methodsFor: 'accessing' stamp: ''!
owner: anObject

	owner := anObject! !

!SpNotebookPage methodsFor: 'api - events' stamp: ''!
whenIconChangedDo: aBlock

	self property: #icon whenChangedDo: aBlock! !

!SpNotebookPage methodsFor: 'accessing' stamp: ''!
labelPresenterFor: ownerPresenter
	"There is one, and *just one* active label presenter for each page.
	 The only case I can think that can be changed is if owner changed (if we move the page from 
	 one notebook to another?)"
	
	labelPresenter ifNil: [ ^ labelPresenter := self newLabelPresenterFor: ownerPresenter ].
	labelPresenter owner = ownerPresenter ifTrue: [ ^ labelPresenter ].
	
	self unsubscribe: labelPresenter.
	labelPresenter := self newLabelPresenterFor: ownerPresenter.
	^ labelPresenter! !

!SpNotebookPage methodsFor: 'private - factory' stamp: ''!
newLabelPresenterFor: ownerPresenter
	"override this to implement custom labels"

	^ ownerPresenter 
		instantiate: SpNotebookPageLabelPresenter 
		on: self! !

!SpNotebookPage class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpNotebookPage class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpNotebookPage class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpNotebookPage class methodsFor: 'instance creation' stamp: ''!
title: aString icon: anIcon provider: aBlock

	^ self new 
		title: aString;
		icon: anIcon;
		presenterProvider: aBlock;
		yourself! !

!SpNotebookPage class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpNotebookPage class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpNotebookPage class methodsFor: 'documentation' stamp: ''!
addDocumentExtraSections: aBuilder! !

!SpNotebookPage class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpNotebookPage class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpNotebookPage class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpNotebookPage class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpNotebookPage class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpNotebookPage class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpNotebookPage class methodsFor: 'documentation' stamp: ''!
addDocumentSectionFactoryMethod: aBuilder
	| selector |

	selector := self documentFactoryMethodSelector. 
	selector ifNil: [ ^ self ].
	 
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Factory method' ] withLevel: 2.
	aBuilder newLine.
	aBuilder text: 'You can use '. 
	aBuilder monospace: self name. 
	aBuilder text: ' in your presenters by sending '.
	aBuilder monospace: 'SpPresenter>>#', selector.
	aBuilder text: '.'! !

!SpNotebookPage class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpNotebookPage class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpNotebookPage class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpNotebookPage class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpNotebookPage class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpNotebookPage class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpNotebookPage class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newNotebookPage! !

!SpNotebookPage class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpNotebookPage class methodsFor: 'instance creation' stamp: ''!
title: aString provider: aBlock

	^ self new 
		title: aString;
		presenterProvider: aBlock;
		yourself! !

!SpNotebookPage class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpNotebookPage class methodsFor: 'documentation' stamp: ''!
documentSections
		
	^ OrderedDictionary newFromPairs: {
		'API Methods'. self methods select: [ :each | each protocol = #'api' ].
		'Testing Methods'. self methods select: [ :each | each protocol = #'testing' ].
		'Events'. self methods select: [ :each | each protocol = #'api - events' ].
	 }! !

!SpNotebookPage class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpNotebookPage class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpNotebookPage class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpNotebookPage class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpNotebookPage class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpNotebookPage class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpNotebookPage class methodsFor: '*Spec2-Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	super buildMicroDownUsing: aBuilder withComment: aString.
	"Factory method"
	self addDocumentSectionFactoryMethod: aBuilder.
	"Sections"
	self documentSections keysAndValuesDo: [ :label :methods |
		SpAbstractWidgetPresenter 
			addDocumentSection: aBuilder 
			label: label 
			methods: methods ]! !

!SpNotebookPage class methodsFor: 'instance creation' stamp: ''!
title: aString icon: anIcon provider: aBlock layoutSpec: aSymbol

	^ self new 
		title: aString;
		icon: anIcon;
		presenterProvider: aBlock;
		layoutSpec: aSymbol;
		yourself! !

!SpNotebookPage class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpNotebookPage class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpNotebookPage class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpNotebookPage class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpNotebookPageAnnouncement methodsFor: 'accessing' stamp: ''!
page: anObject
	page := anObject! !

!SpNotebookPageAnnouncement methodsFor: 'accessing' stamp: ''!
pageIndex: anObject
	pageIndex := anObject! !

!SpNotebookPageAnnouncement methodsFor: 'accessing' stamp: ''!
pageIndex
	^ pageIndex! !

!SpNotebookPageAnnouncement methodsFor: 'accessing' stamp: ''!
page
	^ page! !

!SpNotebookPageChanged methodsFor: 'accessing' stamp: ''!
oldPage: anObject
	oldPage := anObject! !

!SpNotebookPageChanged methodsFor: 'accessing' stamp: ''!
oldPage
	^ oldPage! !

!SpNotebookPageLabelPresenter commentStamp: ''!
A presenter that acts as tab label for the notebook page.
It is possible to put any widget in as label, this is just the "default" implementation.!
!SpNotebookPageLabelPresenter methodsFor: 'transmission' stamp: ''!
defaultInputPort

	^ self inputModelPort! !

!SpNotebookPageLabelPresenter methodsFor: 'transmission' stamp: ''!
inputModelPort

	^ SpModelPort newPresenter: self! !

!SpNotebookPageLabelPresenter methodsFor: 'private - updating' stamp: ''!
updateIcon

	iconPresenter image: self model icon! !

!SpNotebookPageLabelPresenter methodsFor: 'private - updating' stamp: ''!
updateTitle

	labelPresenter label: self model title! !

!SpNotebookPageLabelPresenter methodsFor: 'initialization' stamp: ''!
updatePresenter

	self model 
		whenTitleChangedDo: [ self updateTitle ];
		whenIconChangedDo: [ self updateIcon ]! !

!SpNotebookPageLabelPresenter methodsFor: 'subscription' stamp: ''!
unsubscribePage: aPage

	aPage unsubscribe: self! !

!SpNotebookPageLabelPresenter methodsFor: 'private' stamp: ''!
setModel: aModel

	self model: aModel! !

!SpNotebookPageLabelPresenter methodsFor: 'accessing - model' stamp: ''!
model: aModel

	(model notNil 
		and: [ model ~= aModel ])
		ifTrue: [ self unsubscribePage: model ].

	model := aModel.
	self updatePresenter! !

!SpNotebookPageLabelPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aModel

	model := aModel! !

!SpNotebookPageLabelPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	
	self layout: (SpBoxLayout newLeftToRight
		spacing: 3;
		yourself).
		
	self model icon ifNotNil: [
		self layout 
			add: (iconPresenter := (self newImage image: self model icon)) 
			expand: false ].

	self layout 
		vAlignCenter;
		add: (labelPresenter := self newLabel 
			label: self model title asString;
			yourself)
		expand: false.

	self model isCloseable ifTrue: [
		self layout 
			addLast: (self newButton 
				addStyle: 'small';
				addStyle: 'flat';
				icon: (self application iconNamed: #windowCloseInactive);
				action: [ self model removeFromNotebook ];
				yourself)
			expand: false ].
		
	"self eventHandler whenDoubleClickDo: [ :event | 'ok' crTrace  ]."! !

!SpNotebookPageLabelPresenter methodsFor: 'accessing - model' stamp: ''!
model

	^ model! !

!SpNotebookPageLabelPresenter methodsFor: 'accessing' stamp: ''!
label

	^ labelPresenter label! !

!SpNotebookPageMorph methodsFor: 'accessing' stamp: ''!
labelMorph

	^ labelMorph! !

!SpNotebookPageMorph methodsFor: 'testing' stamp: ''!
isRendered

	^ actualPageMorph notNil! !

!SpNotebookPageMorph methodsFor: 'accessing' stamp: ''!
labelMorph: anObject

	labelMorph := anObject! !

!SpNotebookPageMorph methodsFor: 'accessing' stamp: ''!
actualPageMorph

	^ actualPageMorph ifNil: [
		actualPageMorph := self lazyPageMorphCreation value
			hResizing: #spaceFill;
			vResizing: #spaceFill;
			yourself ]! !

!SpNotebookPageMorph methodsFor: 'accessing' stamp: ''!
lazyPageMorphCreation: anObject

	lazyPageMorphCreation := anObject! !

!SpNotebookPageMorph methodsFor: 'theme' stamp: ''!
themeChanged

	super themeChanged.
	labelMorph themeChanged.
	actualPageMorph ifNotNil: [ 
		actualPageMorph themeChanged ]! !

!SpNotebookPageMorph methodsFor: 'accessing' stamp: ''!
lazyPageMorphCreation

	^ lazyPageMorphCreation! !

!SpNotebookPageMorph methodsFor: 'accessing' stamp: ''!
model: anObject

	model := anObject! !

!SpNotebookPageMorph methodsFor: 'accessing' stamp: ''!
actualPageMorph: anObject

	actualPageMorph := anObject! !

!SpNotebookPageMorph methodsFor: 'initialization' stamp: ''!
reset

	self actualPageMorph: nil! !

!SpNotebookPageMorph methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!SpNotebookPageRemoved methodsFor: 'accessing' stamp: ''!
tabs: anObject
	tabs := anObject! !

!SpNotebookPageRemoved methodsFor: 'accessing' stamp: ''!
tabs
	^ tabs! !

!SpNotebookPageRemoved methodsFor: 'accessing' stamp: ''!
newIndex
	^ newIndex! !

!SpNotebookPageRemoved methodsFor: 'accessing' stamp: ''!
newIndex: anObject
	newIndex := anObject! !

!SpNotebookPanelMorph methodsFor: 'change reporting' stamp: ''!
changed
	"Report that the area occupied by this morph should be redrawn.
	Fixed to include submorphs outside the outerBounds."

	self world
		ifNil: [ ^ self ].

 	^ fullBounds 
		ifNil: [ self invalidRect: self bounds ]
		ifNotNil: [ self invalidRect: fullBounds ]! !

!SpNotebookPanelMorph methodsFor: 'change reporting' stamp: ''!
adoptPaneColor: paneColor
	"Change our color too."

	self assureExtension.

	extension fillStyle
		ifNil: [ self color: paneColor ].
	self borderStyle baseColor: paneColor darker.
	
	self submorphsDo: [ :m | m adoptPaneColor: paneColor ]! !

!SpNotebookPanelMorph methodsFor: 'accessing' stamp: ''!
extent: aPoint
	| newExtent |	
	newExtent := aPoint rounded.
	(bounds extent closeTo: newExtent)
		ifTrue: [ ^ self ].

	self invalidRect: bounds.
	bounds := bounds topLeft extent: newExtent.
	self layoutChanged.
	self invalidRect: bounds! !

!SpNotebookPresenter commentStamp: ''!
I'm a presenter for a tabbed notebook container. 
This is a container whos children are pages (instances of `SpNotebookPage`), which have a title and a content.!
!SpNotebookPresenter methodsFor: 'private' stamp: ''!
updatePageContent: aPage

	self withAdapterDo: [ :anAdapter | 
		anAdapter updatePageContent: aPage ]! !

!SpNotebookPresenter methodsFor: 'private' stamp: ''!
pagesChanged

	self changed: #updatePages! !

!SpNotebookPresenter methodsFor: 'api - events' stamp: ''!
whenSelectedPageChangedDo: aBlock
	"Inform when selected page has changed.
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self 
		property: #selectedPage 
		whenChangedDo: aBlock! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
addPage: aPage
	"Add a page (an instance of `SpNotebookPage`) to the notebook."

	aPage owner: self.
	pagesHolder add: aPage! !

!SpNotebookPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	pagesHolder := OrderedCollection new asValueHolder.
	pagesHolder whenChangedDo: [ self pagesChanged ]! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
pages 
	"Answer all pages in the notebook."

	^ pagesHolder value! !

!SpNotebookPresenter methodsFor: 'private' stamp: ''!
pageTitleChanged: aPage 

	self changed: #updatePageTitle: with: { aPage }! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
removePage: aPage
	"Remove the page `aPage` from the notebook."
	
	pagesHolder remove: aPage! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
removePageAt: anIndex
	"Remove the page at index `anIndex`."

	pagesHolder removeAt: anIndex! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
selectPage: aPage
	"Selects the page `aPage` from the notebook, switching to show it."

	aPage = self selectedPage ifTrue: [ ^ self ].
	selectedPage := aPage! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
selectedPage
	"Answer current selected page."

	^ selectedPage! !

!SpNotebookPresenter methodsFor: 'api - events' stamp: ''!
whenPageAddedDo: aBlock
	"Inform when a page has been added.
	 `aBlock` receives one argument (the added page)"

	pagesHolder whenAddedDo: aBlock! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
removeAll
	"Remove all pages in notebook"
	
	selectedPage := nil.
	pagesHolder removeAll! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
selectedPageIndex
	"Answer the index of selected page"
	| page |
	
	page := self selectedPage.
	page ifNil: [ ^ 0 ].
	
	^ self pages indexOf: page! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
selectPageIndex: aNumber
	"Select the page with the index `aNumber`."

	self selectPage: (self pages at: aNumber)! !

!SpNotebookPresenter methodsFor: 'api - events' stamp: ''!
whenPagesChangedDo: aBlock
	"Inform when pages has been changed.
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	pagesHolder whenChangedDo: aBlock! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
pages: aCollection
	"Set all pages of the notebook.
	 `aCollection` contains instances of `SpNotebookPage`."

	aCollection do: [ :each | each owner: self ].
	pagesHolder rawValue: aCollection asOrderedCollection.
	pagesHolder valueChanged: nil! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
resetAllPageContents
	"Resets all page contents, forcing a refresh next time a page is selected."

	self pages do: [ :each | each resetContent ]! !

!SpNotebookPresenter methodsFor: 'api' stamp: ''!
addPageTitle: aString provider: aBlock 
	"A convenience method to directly add a page with a provider."
	
	^ self addPage: (SpNotebookPage title: aString provider: aBlock)! !

!SpNotebookPresenter methodsFor: 'private - traversing' stamp: ''!
traverseInFocusOrderDo: aBlock excluding: excludes

	excludes add: self.
	aBlock value: self.
	
	self selectedPage ifNil: [ ^ self ].
	self selectedPage activePresenter
		traverseInFocusOrderDo: aBlock 
		excluding: excludes! !

!SpNotebookPresenter methodsFor: 'api - events' stamp: ''!
whenPageRemovedDo: aBlock
	"Inform when a page has been removed.
	 `aBlock` receives one argument (the removed page)"

	pagesHolder whenRemovedDo: aBlock! !

!SpNotebookPresenter methodsFor: 'private' stamp: ''!
pageAt: index

	^ self pages at: index! !

!SpNotebookPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newNotebook! !

!SpNotebookPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example

	^ self new 
		addPageTitle: 'Test 1' provider: [ SpLabelPresenter new label: 'Content 1' ];
		addPageTitle: 'Test 2' provider: [ SpLabelPresenter new label: 'Content 2' ];
		addPageTitle: 'Test 3' provider: [ SpLabelPresenter new label: 'Content 3' ];
		openWithSpec! !

!SpNotebookPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #NotebookAdapter! !

!SpNotebookPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpNotebookPresenter! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testRemovePage
	| page |
	presenter addPage: self mockPage.
	page := SpNotebookPage title: 'test' provider: [ SpButtonPresenter new ].
	presenter addPage: page.
	self assert: presenter pages size equals: 2.
	presenter removePage: page.
	self assert: presenter pages size equals: 1! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testRemoveAllCleansSelection
	| page |
	
	presenter addPage: self mockPage.
	page := SpNotebookPage title: 'test' provider: [ SpButtonPresenter new ].
	presenter addPage: page.
	self assert: presenter pages size equals: 2.
	presenter selectPage: page.
	presenter removeAll.
	self assert: presenter pages size equals: 0.
	self assert: presenter selectedPage isNil
	! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testRemoveAllDoesNotSelectsAnyPage
	| page1 page2 selected |
	
	page1 := SpNotebookPage title: 'test 1' provider: [ selected := 1. SpButtonPresenter new ].
	presenter addPage: page1.
	page2 := SpNotebookPage title: 'test 2' provider: [ selected := 2. SpButtonPresenter new ].
	presenter addPage: page2.
	self assert: presenter pages size equals: 2.
	
	"it needs to be open"
	[ presenter openWithSpec ]
	ensure: [ presenter withWindowDo: #close ].
	
	presenter selectPage: page1.
	presenter removeAll.
	self assert: presenter pages size equals: 0.
	self assert: presenter selectedPage isNil.
	self assert: selected equals: 1! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testAddPage
	self assertEmpty: presenter pages.
	presenter addPage: self mockPage.
	self assert: presenter pages size equals: 1
	! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testSelectPage
	| mock mock2 |
	mock := self mockPage.
	mock2 := SpNotebookPage title: 'test' provider: [ SpButtonPresenter new ].
	presenter addPage: mock.
	presenter addPage: mock2.
	presenter selectPage: mock2.
	self assert: presenter selectedPage equals: mock2! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testWhenSelectedPageChangedDo
	| mock mock2 counter selected |
	counter := 0.
	mock := self mockPage.
	mock2 := SpNotebookPage title: 'test' provider: [ SpButtonPresenter new ].
	presenter
		whenSelectedPageChangedDo: [ :page | 
			selected := page.
			counter := counter + 1 ].
	presenter addPage: mock.
	presenter addPage: mock2.
	presenter selectPageIndex: 2.
	self assert: counter equals: 1.
	self assert: selected equals: mock2! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testRemoveAfterSettingPagesWithAnArray
	| page |
	
	page := SpNotebookPage title: 'test' provider: [ SpButtonPresenter new ].
	presenter pages: { 
	 	self mockPage.
		page } .
	self assert: presenter pages size equals: 2.
	presenter removePageAt: 1.
	self assertCollection: presenter pages hasSameElements: {page}! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testSelectPageIndex
	| mock mock2 |
	mock := self mockPage.
	mock2 := SpNotebookPage title: 'test' provider: [ SpButtonPresenter new ].
	presenter addPage: mock.
	presenter addPage: mock2.
	presenter selectPageIndex: 2.
	self assert: presenter selectedPage equals: mock2! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testPageAt
	| page |
	presenter addPage: self mockPage.
	page := SpNotebookPage title: 'test' provider: [ SpButtonPresenter new ].
	presenter addPage: page.
	self assert: (presenter pageAt: 2) equals: page! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testRemoveAll
	| page |
	
	presenter addPage: self mockPage.
	page := SpNotebookPage title: 'test' provider: [ SpButtonPresenter new ].
	presenter addPage: page.
	self assert: presenter pages size equals: 2.
	presenter removeAll.
	self assert: presenter pages size equals: 0! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testWhenPagesChangedDo
	| counter |
	counter := 0.
	self assertEmpty: presenter pages.
	presenter whenPagesChangedDo: [ counter := counter + 1 ].
	presenter addPage: self mockPage.
	self assert: counter equals: 1! !

!SpNotebookPresenterTest methodsFor: 'tests' stamp: ''!
testRemovePageAt
	| page |
	presenter addPage: self mockPage.
	page := SpNotebookPage title: 'test' provider: [ SpButtonPresenter new ].
	presenter addPage: page.
	self assert: presenter pages size equals: 2.
	presenter removePageAt: 1.
	self assertCollection: presenter pages hasSameElements: {page}! !

!SpNotebookPresenterTest methodsFor: 'accessing' stamp: ''!
mockPage
	^ SpNotebookPage
		title: 'Mock'
		icon: (self iconNamed: #changeUpdate)
		provider: [ SpButtonPresenter new ]! !

!SpNotebookTabSelectorMorph methodsFor: 'operations' stamp: ''!
removeTabIndex: anInteger
	"Remove the tab at the given index and
	adjust any selected (next or first if was last)."
	
	self tabs removeAt: anInteger.
	selectedIndex >= anInteger ifTrue: [
		selectedIndex = anInteger
			ifTrue: [
				self selectedIndex: 0. "to update new tab at current selected index"
				self tabs ifNotEmpty: [self selectedIndex: anInteger ] ]
			ifFalse: [ self selectedIndex: selectedIndex - 1 ] ].
	self updateTabs! !

!SpNotebookTabSelectorMorph methodsFor: 'operations' stamp: ''!
newLabelMorph: aStringOrMorph selected: selectedStringOrMorph
	"Answer a new label morph with the given label text or morph and
	alternate when selected."

	^ TabLabelMorph new
		roundedCorners: #(1 4);
		cornerStyle: self cornerStyle;
		changeTableLayout;
		listDirection: #leftToRight;
		listCentering: #center;
		layoutInset: (self theme tabLabelInsetFor: self);
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		label: aStringOrMorph selected: selectedStringOrMorph;
		in: [ :this | self font ifNotNil: [ this font: self font ] ];
		on: #mouseDown send: #tabClicked:with: to: self;
		tabSelector: self! !

!SpNotebookTabSelectorMorph methodsFor: 'operations' stamp: ''!
newLabelMorph: aStringOrMorph
	"Answer a new label morph with the given label text."

	^ TabLabelMorph new
		roundedCorners: #(1 4);
		cornerStyle: self cornerStyle;
		changeTableLayout;
		listDirection: #leftToRight;
		listCentering: #center;
		layoutInset: (self theme tabLabelInsetFor: self);
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		label: aStringOrMorph;
		in: [ :this | self font ifNotNil: [ this font: self font ] ];
		on: #mouseDown send: #tabClicked:with: to: self;
		tabSelector: self! !

!SpNullApplication commentStamp: ''!
I'm a default application for the case where no application is defined.
I'm meant to provide backwards compatibility and I SHOULD NOT BE USED REGULARLY.!
!SpNullApplication class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	
	DefaultApplication ifNotNil: [ 
		DefaultApplication reset ].
	DefaultApplication := nil! !

!SpNullHistoryIterator commentStamp: ''!
A history iterator to be used when disabling undo/redo!
!SpNullHistoryIterator methodsFor: 'adding' stamp: ''!
addItem: aHistoryItem
	"do nothing"! !

!SpNullHistoryIterator methodsFor: 'adding' stamp: ''!
at: anInteger put: anItem
	"do nothing"! !

!SpNullMillerPresenter commentStamp: ''!
I'm a basic miller presenter that wraps a non-miller presenter and does nothing on activation.
Useful to wrap elements that do not need to flow to the right.!
!SpNullMillerPresenter methodsFor: 'initialization' stamp: ''!
whenActivatedDo: aBlock
	"Do nothing"! !

!SpNullMillerPresenter methodsFor: 'initialization' stamp: ''!
wrappedPresenter

	^ wrappedPresenter! !

!SpNullMillerPresenter methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aModel

	wrappedPresenter := aModel.
	wrappedPresenter owner: self! !

!SpNullMillerPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	
	^ SpBoxLayout newLeftToRight
		add: #wrappedPresenter;
		yourself! !

!SpNullPresenter commentStamp: ''!
A null presenter that contains nothing.
Used by DynamicPresentersListBuilder to fill empty space when required for the layout.!
!SpNullPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	"Returns empty layout. That's the point of null presenter."

	^ SpBoxLayout newTopToBottom! !

!SpNumberInputFieldPresenter commentStamp: ''!
A presenter  for a  text field specialised on numbers. 
`SpNumberInputFieldPresenter` accepts a number type (integer or float) and a range (min, max). 
!
!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
number
	"Answer the number ingressed."

	^ self text trimmed 
		ifNotEmpty: [ :aString | aString asNumber ]
		ifEmpty: [ 0 ]! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
minimum: aNumber
	"Answer the minimum number to accept."

	minimum := aNumber! !

!SpNumberInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenNumberTypeChangedDo: aBlock
	"Inform when numberType property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #numberType whenChangedDo: aBlock! !

!SpNumberInputFieldPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self beInteger.
	self digits: self class defaultDigits.
	self climbRate: self class defaultClimbRate.! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
rangeMinimum: minNumber maximum: maxNumber 
	"A convenience method to set the maximum and minimum values to accept."

	self minimum: minNumber.
	self maximum: maxNumber! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
minimum
	"Answer the minimum number to accept (it can be nil, if not minimum is set)"

	^ minimum! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
digits
	"Answer digits to show when we have a float number"

	^ digits! !

!SpNumberInputFieldPresenter methodsFor: 'testing' stamp: ''!
isInteger 
	"Answer if the number type is an integer."

	^ self numberType = Integer! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
climbRate: aNumber
	"Set the jump rate when a spin is present."

	climbRate := aNumber! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
number: aNumber
	"Set the number to display."

	self text: aNumber asString
! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
beFloat
	"Set the presenter to display float numbers"

	self numberType: Float! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
digits: aNumber
	"Set digits to show when we have a float number"

	digits := aNumber! !

!SpNumberInputFieldPresenter methodsFor: 'testing' stamp: ''!
isFloat 
	"Answer if the number type is a float."

	^ self numberType = Float! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
maximum
	"Answer the maximum number to accept (it can be nil, if not maximum is set)"

	^ maximum! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
numberType
	"Answer the type of number the input field will show (Integer or Float)"

	^ numberType! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
climbRate
	"Answer the jump rate when a spin is present."

	^ climbRate! !

!SpNumberInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenMaximumChangedDo: aBlock
	"Inform when maximum property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #maximum whenChangedDo: aBlock! !

!SpNumberInputFieldPresenter methodsFor: 'private' stamp: ''!
numberType: aClass
	"This can be Integer or Float, no more"

	numberType := aClass! !

!SpNumberInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenDigitsChangedDo: aBlock
	"Inform when digits property state has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #digits whenChangedDo: aBlock! !

!SpNumberInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenNumberChangedDo: aBlock
	"Inform when number property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self whenTextChangedDo: [ :txt | aBlock value: self number ]! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
beInteger
	"Set the presenter to display integer numbers"

	self numberType: Integer! !

!SpNumberInputFieldPresenter methodsFor: 'api' stamp: ''!
maximum: aNumber
	"Set the maximum number to accept"

	maximum := aNumber! !

!SpNumberInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenClimbRateChangedDo: aBlock
	"Inform when climbRate property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #climbRate whenChangedDo: aBlock! !

!SpNumberInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenMinimumChangedDo: aBlock
	"Inform when minimum property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #minimum whenChangedDo: aBlock! !

!SpNumberInputFieldPresenter class methodsFor: 'accessing' stamp: ''!
defaultDigits

	^ 2! !

!SpNumberInputFieldPresenter class methodsFor: 'accessing' stamp: ''!
defaultClimbRate

	^ 1! !

!SpNumberInputFieldPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newNumberInput! !

!SpNumberInputFieldPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>

	^ self new
		extent: 300 @ 20;
		placeholder: 'Enter a number';
		minimum: 10;
		maximum: 30;
		climbRate: 2;
		openWithSpec! !

!SpNumberInputFieldPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #NumberInputFieldAdapter! !

!SpNumberInputFieldPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpNumberInputFieldPresenter! !

!SpNumberInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testWhenMinimumChangedDo
	| count result |
	count := 0.
	presenter
		whenMinimumChangedDo: [ :value | 
			count := count + 1.
			result := value ].
	presenter minimum: 10.
	self assert: count equals: 1.
	self assert: result equals: 10! !

!SpNumberInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testWhenClimbRateChangedDo
	| count result |
	count := 0.
	presenter
		whenClimbRateChangedDo: [ :value | 
			count := count + 1.
			result := value ].
	presenter climbRate: 1.
	self assert: count equals: 1.
	self assert: result equals: 1! !

!SpNumberInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testWhenMaximumChangedDo
	| count result |
	count := 0.
	presenter
		whenMaximumChangedDo: [ :value | 
			count := count + 1.
			result := value ].
	presenter maximum: 10.
	self assert: count equals: 1.
	self assert: result equals: 10! !

!SpNumberInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testWhenNumberChangedDo
	| count result |
	count := 0.
	presenter
		whenNumberChangedDo: [ :value | 
			count := count + 1.
			result := value ].
	presenter number: 10.
	self assert: count equals: 1.
	self assert: result equals: 10! !

!SpNumberInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testWhenNumberTypeChangedDo
	| count result |
	count := 0.
	presenter
		whenNumberTypeChangedDo: [ :value | 
			count := count + 1.
			result := value ].
	presenter beFloat.
	self assert: count equals: 1.
	self assert: result equals: Float! !

!SpNumberInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testWhenDigitsChangedDo
	| count result |
	count := 0.
	presenter
		whenDigitsChangedDo: [ :value | 
			count := count + 1.
			result := value ].
	presenter digits: 2.
	self assert: count equals: 1.
	self assert: result equals: 2! !

!SpObjectInspector commentStamp: ''!
A small inspector to be used in the demos.

```
self example
```!
!SpObjectInspector methodsFor: 'initialization' stamp: ''!
updatePresenter

	variablesList items: inspectedObject class allSlots! !

!SpObjectInspector methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpPanedLayout newTopToBottom
		positionOfSlider: 70 percent;
		add: (SpPanedLayout newLeftToRight
			add: (variablesList := self newList);
			add: (variableValueCode := self newCode);
			yourself);
		add: (evaluatorCode := self newCode);
		yourself).
		
	variablesList display: [ :aSlot | aSlot name ]! !

!SpObjectInspector methodsFor: 'instance creation' stamp: ''!
inspect: anObject

	inspectedObject := anObject.
	self updatePresenter! !

!SpObjectInspector class methodsFor: 'instance creation' stamp: ''!
inspect: anObject

	^ self new 
		inspect: anObject;
		openWithSpec! !

!SpObjectInspector class methodsFor: 'examples' stamp: ''!
example

	self inspect: self new! !

!SpObservablePoint commentStamp: ''!
I am a point used to test observable properties.
I have an observable property x and a non-observable property y.

I use TObservable that has methods to ease the usage of my observable properties.!
!SpObservablePoint methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpObservablePoint methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpObservablePoint methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self class initializeSlots: self.! !

!SpObservablePoint methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpObservablePoint methodsFor: 'accessing' stamp: ''!
y: anInteger 
	y := anInteger! !

!SpObservablePoint methodsFor: 'accessing' stamp: ''!
x
	^ x! !

!SpObservablePoint methodsFor: 'accessing' stamp: ''!
x: anInteger 
	x := anInteger! !

!SpObservablePoint methodsFor: 'accessing' stamp: ''!
y
	^ y! !

!SpObservablePoint methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpObservablePoint class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpObservablePoint class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpObservablePoint class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpObservablePoint class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpObservablePoint class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpObservablePoint class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpObservablePoint class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpObservablePoint class methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!SpObservablePoint class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpObservablePoint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpObservablePoint class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpObservablePoint class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpObservablePoint class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpObservablePoint class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpObservablePoint class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpObservablePoint class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpObservablePoint class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpObservablePoint class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpObservablePoint class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpObservablePoint class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpObservablePoint class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpObservablePoint class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpObservablePoint class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpObservablePoint class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpObservablePoint class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpObservablePoint class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpObservablePoint class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpObservablePoint class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpObservablePoint class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpObservablePoint class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpObservableSlot commentStamp: ''!
DEPRECATED: Do not use this slot. Use `ObservableSlot` instead.!
!SpObservableSlot methodsFor: 'testing' stamp: ''!
isObservableSlot
	
	^ true! !

!SpObservableSlot methodsFor: 'initialization' stamp: ''!
rawRead: anObject

	^ super read: anObject! !

!SpObservableSlot methodsFor: 'initialization' stamp: ''!
wantsInitialization

	^ true! !

!SpObservableSlot methodsFor: 'initialization' stamp: ''!
read: anObject

	^ (super read: anObject) value! !

!SpObservableSlot methodsFor: 'initialization' stamp: ''!
write: aValue to: anObject

	(super read: anObject) ifNotNil: [ :v | v value: aValue ].
	^ aValue! !

!SpObservableSlot methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	"Push the value holder into the stack"
	aMethodBuilder pushInstVar: index.
	aMethodBuilder send: #value! !

!SpObservableSlot methodsFor: 'code generation' stamp: ''!
emitStore: aMethodBuilder
	"generate bytecode for 'varName value: <stackTop>', make sure to preserve the stackTop"
	| temp |

	temp := '0slotTempForStackManipulation'.	
	"We pop the value from the stack into a temp to push it back in the right order"
	aMethodBuilder addTemp: temp.
	aMethodBuilder storeTemp: temp.

	"Push the value holder into the stack, then the value again, then send"
	aMethodBuilder pushInstVar: index.
	aMethodBuilder pushTemp: temp.
	aMethodBuilder send: #value:.
	"we have to return the value, not the valueHolder"
	aMethodBuilder popTop! !

!SpObservableSlot methodsFor: 'initialization' stamp: ''!
initialize: anObject
	super write: SpValueHolder new to: anObject! !

!SpObservableSlot class methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!SpObservableSlotTest methodsFor: 'tests' stamp: ''!
testSubscribeToExistentNonObservablePropertyRaisesError

	self
		should: [
			point
				property: #y
				whenChangedDo: [ self fail: 'This event shouldnt have been subscribed at all' ] ]
		raise: NonObservableSlotError! !

!SpObservableSlotTest methodsFor: 'tests' stamp: ''!
testExplicitNotificationRaisesEventOnlyOnce

	| count |
	count := 0.
	point property: #x whenChangedDo: [ count := count + 1 ].

	point notifyPropertyChanged: #x.

	self assert: count equals: 1.! !

!SpObservableSlotTest methodsFor: 'tests' stamp: ''!
testExplicitNotifyUnexistentPropertyChangedRaisesError

	self
		should: [ point notifyPropertyChanged: #z ]
		raise: SlotNotFound! !

!SpObservableSlotTest methodsFor: 'tests' stamp: ''!
testObservableSlotWorksAsNormalSlot

	point x: 17.
	point y: 299.
	
	self assert: point x equals: 17.
	self assert: point y equals: 299.! !

!SpObservableSlotTest methodsFor: 'tests' stamp: ''!
testSubscribeBlockWithoutParametersIsCalled

	| called |
	called := false.
	point property: #x whenChangedDo: [ called := true ].

	point x: 17.

	self assert: called.! !

!SpObservableSlotTest methodsFor: 'tests' stamp: ''!
testSubscribeToUnexistentPropertyRaisesError

	self
		should: [
			point
				property: #z
				whenChangedDo: [ self fail: 'This event shouldnt have been subscribed at all' ] ]
		raise: SlotNotFound! !

!SpObservableSlotTest methodsFor: 'tests' stamp: ''!
testSubscribeToChangeRaisesEventWithNewValue

	| newValue |
	point property: #x whenChangedDo: [ :new | newValue := new ].

	point x: 17.

	self assert: newValue equals: 17.! !

!SpObservableSlotTest methodsFor: 'tests' stamp: ''!
testChangeInInstanceVariableRaisesEventOnlyOnce

	|  count |
	count := 0.
	point property: #x whenChangedDo: [ count := count + 1 ].

	point x: 17.

	self assert: count equals: 1.! !

!SpObservableSlotTest methodsFor: 'tests' stamp: ''!
testExplicitNotificationRaisesEventWithNewValue

	| newValue |
	point x: 17.
	point property: #x whenChangedDo: [ :new | newValue := new ].

	point notifyPropertyChanged: #x.

	self assert: newValue equals: 17.! !

!SpObservableSlotTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	point := SpObservablePoint new.! !

!SpOpenOnIntExample commentStamp: ''!
I am the component of DynamycSpecExample used for Integer.

self example !
!SpOpenOnIntExample methodsFor: 'accessing' stamp: ''!
title
	^ 'OpenOnIntExample'! !

!SpOpenOnIntExample methodsFor: 'accessing' stamp: ''!
minus
	^ minus! !

!SpOpenOnIntExample methodsFor: 'initialization' stamp: ''!
initializePresenters
	text := self instantiate: SpLabelPresenter.
	plus := self instantiate: SpButtonPresenter.
	minus := self instantiate: SpButtonPresenter.
	plus
		label: '+'.
	minus
		label: '-'! !

!SpOpenOnIntExample methodsFor: 'initialization' stamp: ''!
connectPresenters
	minus
		action: [ | currentValue |
			currentValue := text label asInteger.
			text label: (currentValue - 1) asString ].
	plus
		action: [ | currentValue |
			currentValue := text label asInteger.
			text label: (currentValue + 1) asString ]! !

!SpOpenOnIntExample methodsFor: 'accessing' stamp: ''!
plus
	^ plus! !

!SpOpenOnIntExample methodsFor: 'initialization' stamp: ''!
initialize: anInteger
	text label: anInteger asString! !

!SpOpenOnIntExample methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!SpOpenOnIntExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #text withConstraints: [ :constraints | constraints height: 25 ];
		add:
			(SpBoxLayout newLeftToRight
				add: #minus;
				add: #plus;
				yourself)
			withConstraints: [ :constraints | constraints height: 25 ];
		yourself! !

!SpOpenOnIntExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ (self new: 42)
		extent: 100 @ 100;
		openWithSpec;
		yourself! !

!SpOpenOnIntExample class methodsFor: 'instantiation' stamp: ''!
new: anInteger
	^ self new initialize: anInteger! !

!SpOpenOnIntExampleTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpOpenOnIntExample! !

!SpOpenOnNilExample commentStamp: ''!
I am the component of DynamycSpecExample used for nil.

self example

I display simply an TextInputFieldPresenter, disable to don't be edditable by the user.!
!SpOpenOnNilExample methodsFor: 'initialization' stamp: ''!
initializePresenters
	text := self instantiate: SpTextInputFieldPresenter.
	text
		text: 'Object is nil';
		enabled: false.! !

!SpOpenOnNilExample methodsFor: 'accessing' stamp: ''!
title
	^ 'OpenOnNilExample'! !

!SpOpenOnNilExample methodsFor: 'initialization' stamp: ''!
initialize: anInteger
	text label: anInteger asString! !

!SpOpenOnNilExample methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!SpOpenOnNilExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #text withConstraints: [ :constraints | constraints height: 25 ];
		yourself! !

!SpOpenOnNilExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new
		extent: 200 @ 100;
		openWithSpec;
		yourself! !

!SpOpenOnNilExampleTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpOpenOnNilExample! !

!SpOpenOnStringExample commentStamp: ''!
I am the component of DynamycSpecExample used for String.

self example 

I show also how to dynamically redrawn a widget.!
!SpOpenOnStringExample methodsFor: 'accessing' stamp: ''!
title
	^ 'OpenOnStringExample'! !

!SpOpenOnStringExample methodsFor: 'accessing' stamp: ''!
input
	^ input! !

!SpOpenOnStringExample methodsFor: 'initialization' stamp: ''!
openOnString
	| ui temp object |
	object whenChangedDo: [ :o | ui label label: o asString ].
	temp := object value.
! !

!SpOpenOnStringExample methodsFor: 'accessing' stamp: ''!
check
	^ check! !

!SpOpenOnStringExample methodsFor: 'accessing' stamp: ''!
button
	^ button! !

!SpOpenOnStringExample methodsFor: 'initialization' stamp: ''!
initializePresenters
	label := self instantiate: SpLabelPresenter.
	check := self instantiate: SpCheckBoxPresenter.
	input := self instantiate: SpTextInputFieldPresenter.
	button := self instantiate: SpButtonPresenter.
	button
		label: 'reset';
		action: [ input text: textToReset ].
	check
		label: 'Label on top';
		state: false! !

!SpOpenOnStringExample methodsFor: 'initialization' stamp: ''!
connectPresenters
	button action: [ input text: textToReset ].
	input whenTextChangedDo: [ :text | label label: text ].
	check
		whenActivatedDo: [ self needRebuild: false.
			self buildWithSpecLayout: self class defaultSpec ];
		whenDeactivatedDo: [ self needRebuild: false.
			self buildWithSpecLayout: self class bottomLayout ]! !

!SpOpenOnStringExample methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!SpOpenOnStringExample methodsFor: 'initialization' stamp: ''!
initialize: aString
	label label: aString.
	input text: aString.
	textToReset := aString! !

!SpOpenOnStringExample methodsFor: 'accessing' stamp: ''!
textToReset
	^ textToReset! !

!SpOpenOnStringExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #label;
				add: #check withConstraints: [ :constraints | constraints width: 100 ];
				yourself)
			withConstraints: [ :constraints | constraints height: 25 ];
		add:
			(SpBoxLayout newLeftToRight
				add: #input;
				add: #button;
				yourself)
			withConstraints: [ :constraints | constraints height: 25 ];
		yourself! !

!SpOpenOnStringExample class methodsFor: 'specs' stamp: ''!
bottomLayout
	<spec>
	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: #input;
				add: #button;
				yourself)
			withConstraints: [ :constraints | constraints height: 25 ];
		add:
			(SpBoxLayout newLeftToRight
				add: #label;
				add: #check withConstraints: [ :constraints | constraints width: 100 ];
				yourself)
			withConstraints: [ :constraints | constraints height: 25 ];
		yourself! !

!SpOpenOnStringExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ (self new: 'Hello world')
		extent: 300 @ 200;
		openWithSpec;
		yourself! !

!SpOpenOnStringExample class methodsFor: 'instantiation' stamp: ''!
new: aString
	^ self new initialize: aString! !

!SpOpenOnStringExampleTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpOpenOnStringExample! !

!SpOutputPort commentStamp: ''!
!! Output ports
An output port defines origin actions (and the possible data associated to such action) to transmit to an destination (input) port.

It also defines the transformations to apply to the output data before give them to the input port.

Finally, it can also define some operation to do after the transmission is completed. 

Transmission are ''attached'' to a presenter (each concrete output port will override *method:SpOutputPort#attachTransmission:*).!
!SpOutputPort methodsFor: 'transmitting' stamp: ''!
transmitTo: aPort transform: aValuable postTransmission: postValuable

	^ SpTransmission new
		fromPort: self;
		toPort: aPort;
		transform: aValuable;
		postTransmission: postValuable;
		apply! !

!SpOutputPort methodsFor: 'transmitting' stamp: ''!
transmitTo: aPort transform: aValuable

	^ SpTransmission new
		fromPort: self;
		toPort: aPort;
		transform: aValuable;
		apply! !

!SpOutputPort methodsFor: 'private' stamp: ''!
transmitWith: aTransmission value: transmitted

	aTransmission applyPreTransmissionWith: transmitted.
	aTransmission toPort
		incomingTransmission: (aTransmission transformed: transmitted)
		from: self.
	aTransmission applyPostTransmissionWith: transmitted! !

!SpOutputPort methodsFor: 'attaching' stamp: ''!
attachTransmission: aTransmission
	"A transmission is no more than a definition of what to transmit to who. 
	 By overriding this method, concrete output ports can listen the event they need to and 
	 execute the transmission (sending ==#transmitTo:value:==).
	[[[language=Smalltalk
	self destinationPresenter whenSelectionChangedDo: [ :selection | 
		self 
			transmitWith: aTransmission 
			value: selection transmission ]
	]]]"
	| presenterOrPort |
	
	"We attach transmission to presenter. If destination is not a presenter, then it has to be a
	chained port (in that case we just chan the transmission ;)"
	
	presenterOrPort := self destinationPresenterOrPort.
	presenterOrPort isPresenter
		ifTrue: [ 
			self attachTransmission: aTransmission to: presenterOrPort ]
		ifFalse: [ 
			presenterOrPort 
				transform: transformations;				
				attachTransmission: aTransmission ]! !

!SpOutputPort methodsFor: 'transmitting' stamp: ''!
transmitTo: aPort

	^ SpTransmission new
		fromPort: self;
		toPort: aPort;
		apply! !

!SpOutputPort methodsFor: 'attaching' stamp: ''!
attachTransmission: aTransmission to: aPresenter
		
	self subclassResponsibility! !

!SpOutputPort methodsFor: 'transmitting' stamp: ''!
transmitDo: aBlock transform: transformBlock
	
	^ SpTransmission new
		fromPort: self;
		do: aBlock;
		transform: transformBlock;
		apply! !

!SpOutputPort methodsFor: 'private' stamp: ''!
applyTransform: anObject
	| transformedObject |

	transformations ifNil: [ ^ anObject ].

	transformedObject := anObject.	
	transformations do: [ :eachBlock | 
		transformedObject := eachBlock value: transformedObject ].
	^ transformedObject ! !

!SpOutputPort methodsFor: 'transmitting' stamp: ''!
transmitTo: aPort postTransmission: postValuable

	^ SpTransmission new
		fromPort: self;
		toPort: aPort;
		postTransmission: postValuable;
		apply! !

!SpOutputPort methodsFor: 'testing' stamp: ''!
isOutput

	^ true! !

!SpOutputPort methodsFor: 'copying' stamp: ''!
, otherPort

	^ SpCompositeOutputPort new
		add: self;
		add: otherPort;
		yourself! !

!SpOutputPort methodsFor: 'accessing' stamp: ''!
transform: aBlock
	"Sometimes you do not want to transmit to the outside the object you are using but a 
	 transformation of it (for example, if you are using a list of wrapped elements instead the 
	 actual elements).
	 You can transform the output like this: 
	```Smalltalk
	(SpSelectionPort newPresenter: self)
		transform: [ :aNode | aNode wrappedElement ]; 
		yourself
	```"

	aBlock ifNil: [ ^ self ].
	transformations ifNil: [ transformations := #() ].
	transformations := transformations copyWith: aBlock! !

!SpOutputPort methodsFor: 'transmitting' stamp: ''!
transmitDo: aBlock
	
	^ SpTransmission new
		fromPort: self;
		do: aBlock;
		apply! !

!SpOutputPort class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self name = #SpOutputPort! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
vAlignEnd
	"Sets the vertical align property to END. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment end! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
beOverlay
	
	^ overlay := true! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
vAlignCenter
	"Sets the vertical align property to CENTER. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment center! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
hAlign: anAlignment
	"Sets the horizontal align property. See #hAlign to details"
	
	hAlign := anAlignment! !

!SpOverlayConstraints methodsFor: 'testing' stamp: ''!
hasAlignment
	"Answer whether the component has any alignment defined"

	^ self hasVAlign or: [ self hasHAlign ]! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
vAlignStart
	"Sets the vertical align property to START. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment start! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
vAlign: anAlignment
	"Sets the vertical align property. See #vAlign to details"

	vAlign := anAlignment! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
hAlignStart
	"Sets the horizontal align property to START. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment start! !

!SpOverlayConstraints methodsFor: 'testing' stamp: ''!
hasVAlign
	"Answer whether the component has a vertical alignment defined"

	^ vAlign notNil! !

!SpOverlayConstraints methodsFor: 'testing' stamp: ''!
isOverlay
	
	^ overlay = true! !

!SpOverlayConstraints methodsFor: 'testing' stamp: ''!
hasHAlign
	"Answer whether the component has an horizontal alignment defined"

	^ hAlign notNil! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
vAlign
	"I define the vertical alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use vAlignStart, vAlignCenter, vAlignEnd"

	^ vAlign! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
hAlign
	"I define the horizontal alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use hAlignStart, hAlignCenter, hAlignEnd"

	^ hAlign! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
hAlignCenter
	"Sets the horizontal align property to CENTER. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment center! !

!SpOverlayConstraints methodsFor: 'accessing' stamp: ''!
hAlignEnd
	"Sets the horizontal align property to END. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment end! !

!SpOverlayConstraints class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpOverlayConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpOverlayConstraints class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpOverlayConstraints class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpOverlayConstraints class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpOverlayConstraints class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpOverlayConstraints class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpOverlayConstraints class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpOverlayConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpOverlayConstraints class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpOverlayConstraints class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpOverlayConstraints class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpOverlayConstraints class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpOverlayConstraints class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpOverlayConstraints class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpOverlayConstraints class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpOverlayConstraints class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpOverlayConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpOverlayConstraints class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpOverlayConstraints class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpOverlayConstraints class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpOverlayConstraints class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpOverlayConstraints class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpOverlayConstraints class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpOverlayConstraints class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpOverlayConstraints class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpOverlayConstraints class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpOverlayConstraints class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpOverlayConstraints class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpOverlayLayout methodsFor: 'accessing' stamp: ''!
addOverlay: aPresenter withConstraints: aBlock
	
	self
		add: aPresenter
		withConstraints: [ :constraints | 
			constraints beOverlay.
			aBlock value: constraints ].
	overlays add: aPresenter.
	self announceChildAdded: aPresenter! !

!SpOverlayLayout methodsFor: 'accessing' stamp: ''!
child: aPresenter

	singleChild ifNotNil: [ self remove: singleChild ].
	self
		add: aPresenter
		withConstraints: [ :constraints | ].
	singleChild := aPresenter.
	self announceChildAdded: aPresenter! !

!SpOverlayLayout methodsFor: 'accessing' stamp: ''!
child

	^ singleChild! !

!SpOverlayLayout methodsFor: 'accessing' stamp: ''!
initialize
	super initialize.
	overlays := OrderedCollection new! !

!SpOverlayLayout methodsFor: 'accessing' stamp: ''!
removeOverlay: aPresenter

	overlays remove: aPresenter.	
	self remove: aPresenter! !

!SpOverlayLayout methodsFor: 'private' stamp: ''!
constraintsClass
	
	^ SpOverlayConstraints! !

!SpOverlayLayout methodsFor: 'accessing' stamp: ''!
remove: aPresenter
	
	singleChild := nil.
	super remove: aPresenter! !

!SpOverlayLayout methodsFor: 'private' stamp: ''!
adapterName
	
	^ #OverlayAdapter! !

!SpOverlayLayout methodsFor: 'accessing' stamp: ''!
addOverlay: aPresenter
	
	self
		add: aPresenter
		withConstraints: [ :constraints | constraints beOverlay ].
	overlays add: aPresenter.
	self announceChildAdded: aPresenter! !

!SpOverlayLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveChildAddedAfterOpenRemovesFromAdapter

	| element |
	layout child: (element := SpButtonPresenter new).
	self openInstance.
	
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpOverlayLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveChildElementRemovesFromAdapter

	| element |
	layout child: (element := SpButtonPresenter new).
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpOverlayLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddTwiceReplacesChild

	| first second |
	layout child: (first := SpButtonPresenter new).
	layout child: (second := SpButtonPresenter new).
	self assert: self adapter children first equals: second adapter widget! !

!SpOverlayLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testLayoutWithOverlayIsNotEmpty

	layout addOverlay: SpButtonPresenter new.
	self deny: self adapter isEmpty! !

!SpOverlayLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testLayoutWithChildIsNotEmpty

	layout child: SpButtonPresenter new.
	self deny: self adapter isEmpty! !

!SpOverlayLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testOverlaysAreBeforeMainChild

	| overlay |
	layout child: SpButtonPresenter new.
	layout addOverlay: (overlay := SpButtonPresenter new).
	self assert: self adapter children first equals: overlay adapter widget! !

!SpOverlayLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testOverlaysAreAddedInOrder
	| first |

	layout addOverlay: SpButtonPresenter new.
	layout addOverlay: (first := SpButtonPresenter new).
	self assert: self adapter children first equals: first adapter widget! !

!SpOverlayLayoutAdapterTest methodsFor: 'accessing' stamp: ''!
newLayout

	^ SpOverlayLayout new! !

!SpOverlayLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testLayoutWithChildAndOverlayHasBothElements

	| overlay |
	layout child: SpButtonPresenter new.
	layout addOverlay: (overlay := SpButtonPresenter new).
	self assert: self adapter children size equals: 2! !

!SpOverlayLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddTwiceSetsChildrenSingleTime

	| first second |
	layout child: (first := SpButtonPresenter new).
	layout child: (second := SpButtonPresenter new).
	self assert: self adapter children size equals: 1! !

!SpOverlayLayoutTest methodsFor: 'tests' stamp: ''!
testLayoutWithOneElementIsNotEmpty

	layout child: SpButtonPresenter new.
	self deny: layout isEmpty! !

!SpOverlayLayoutTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	layout := SpOverlayLayout new.
	presenter layout: layout! !

!SpOverlayLayoutTest methodsFor: 'tests' stamp: ''!
testLayoutWithOverlayWidgetIsNotEmpty

	layout addOverlay: SpButtonPresenter new.
	self deny: layout isEmpty! !

!SpOverlayLayoutTest methodsFor: 'tests' stamp: ''!
testRemoveOverlayFromLayoutTakesItOut

	| element |
	layout addOverlay: (element := SpButtonPresenter new).
	layout remove: element.
	self assert: layout isEmpty! !

!SpOverlayLayoutTest methodsFor: 'tests' stamp: ''!
testReplaceElementKeepsSingleElement

	| replacement |
	layout child: SpButtonPresenter new.
	layout child: (replacement := SpButtonPresenter new).
	self assert: layout children size equals: 1! !

!SpOverlayLayoutTest methodsFor: 'tests' stamp: ''!
testRemoveElementFromLayoutTakesItOut

	| element |
	layout child: (element := SpButtonPresenter new).
	layout remove: element.
	self assert: layout isEmpty! !

!SpPaginatorEdgeGripMorph commentStamp: ''!
A morph to grab borders of a `SpPaginatorSelectionMorph` and enlarge or contract its selection area.
Since it is designed to be contained in a specific morph (`SpPaginatorSelectionMorph`) and its morph it self is a part of a `SpPaginatorMorph`, it has some important assumptions: 

- the `SpPaginatorEdgeGripMorph>>#containerTarget` will be the owner of the target, and it limits  displacement of the selection morph.
- the target of the edge is the selection area always, and it can move (at least for the moment) just left or right.!
!SpPaginatorEdgeGripMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize. 
	self
		hResizing: #rigid;
		vResizing: #spaceFill! !

!SpPaginatorEdgeGripMorph methodsFor: 'accessing' stamp: ''!
beRight

	self edgeName: #right! !

!SpPaginatorEdgeGripMorph methodsFor: 'accessing' stamp: ''!
positionPoint: aPoint

	self position: (aPoint x) @ self top! !

!SpPaginatorEdgeGripMorph methodsFor: 'event handling' stamp: ''!
mouseUp: anEvent

	super mouseUp: anEvent.
	self owner mouseUp: anEvent! !

!SpPaginatorEdgeGripMorph methodsFor: 'event handling' stamp: ''!
mouseMove: anEvent

	self target ifNil: [ ^ self ].
	(self target 
		canResizeTo: anEvent cursorPoint x 
		direction: self edgeName) 
		ifFalse: [ ^ self ].

	target ifNil: [^self].

	"We cannot delegate to the implementation in the superclass.
	The implementation of the superclass handles fast dragging. 
	In a paginator morph there is not such thing as fast dragging.
	Calling it breaks the paginator."
	
	lastMouse at: 1 put: anEvent cursorPoint.
	self targetPoint: lastMouse first - lastMouse last.
	self positionPoint: (lastMouse first - lastMouse second).! !

!SpPaginatorEdgeGripMorph methodsFor: 'accessing' stamp: ''!
beLeft

	self edgeName: #left! !

!SpPaginatorExample methodsFor: 'initialization' stamp: ''!
initializePresenters 
	<script: 'self new openWithSpec'>

	layout := SpBoxLayout newTopToBottom
		spacing: 5;
		add: (millerList := self instantiate: SpMillerColumnPresenter);
		add: (SpBoxLayout newLeftToRight
				hAlignCenter; 
				add: (paginator := self instantiate: SpPaginatorPresenter) expand: false;
				yourself)
			expand: false;
		yourself.
		
	millerList withoutHorizontalScrollBar.

	paginator chainTo: millerList.

	1 to: 10 do: [ :index | | presenter |
		presenter := SpListPresenter new
			items: (1 to: index);
			yourself.
		millerList addPresenter: presenter.
		paginator addPage: presenter ]! !

!SpPaginatorMorph commentStamp: ''!
A morph to show a paginator.
A paginator is just another way to offer "scrolling" of contents: instead having a bar, we have selectable bullers (pages) that represent part of the contents.

Users can add pages by calling `SpPaginatorMorph>>#addPage:` or `SpPaginatorMorph>>#addPages:`. Amount of pages to be part of the selected area (shown) are handled through `SpPaginatorMorph>>#numberOfPagesShown:`.!
!SpPaginatorMorph methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpPaginatorMorph methodsFor: 'private' stamp: ''!
doSelectPageFromMorph: aMorph

	self selectPage: (pagesMorph submorphs indexOf: aMorph)! !

!SpPaginatorMorph methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpPaginatorMorph methodsFor: 'private' stamp: ''!
baseWidth

	^ SpPaginatorPageMorph baseWidth! !

!SpPaginatorMorph methodsFor: 'geometry' stamp: ''!
bounds: aRectangle

	super bounds: aRectangle.
	selectionMorph height: aRectangle height! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
selectPage: aNumber

	selectedPage = aNumber ifTrue: [ ^ self ].
	(aNumber + self numberOfPagesShown - 1 > pagesMorph submorphs size) 
		ifTrue: [ ^ self selectPage: aNumber - 1 ].

	self moveSelectionToPage: aNumber.
	self basicSelectPage: aNumber! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
selectedPage

	^ selectedPage! !

!SpPaginatorMorph methodsFor: 'private' stamp: ''!
moveNext
	self flag: #REMOVE. 
	selectionMorph left: (((selectionMorph left + selectionMorph width) + self baseWidth) > self right 
		ifTrue: [ 0 ]
		ifFalse: [ selectionMorph left + self baseWidth ])! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
addPages: aCollection

	aCollection do: [ :each | self addPage: each ]! !

!SpPaginatorMorph methodsFor: 'private' stamp: ''!
basicSelectPage: aNumber
	
	selectedPage := aNumber! !

!SpPaginatorMorph methodsFor: 'initialization' stamp: ''!
newPagesMorph

	^ Morph new 
		color: Color transparent;
		changeTableLayout; 
		listDirection: #leftToRight; 
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		yourself! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
selectLastPage

	self selectPage: (pagesMorph submorphs size)! !

!SpPaginatorMorph methodsFor: 'private' stamp: ''!
moveSelectionToPage: aNumber

	selectionMorph left: self left + ((aNumber - 1) * self baseWidth)! !

!SpPaginatorMorph methodsFor: 'private' stamp: ''!
adjustValues

	self adjustSelectionToClosestPage.
	self adjustShownPages! !

!SpPaginatorMorph methodsFor: 'private' stamp: ''!
adjustShownPages
	| newShownPages |

	newShownPages := (selectionMorph width / self baseWidth) asInteger max: 1.
	self numberOfPagesShown = newShownPages 
		ifFalse: [ self numberOfPagesShown: newShownPages ]! !

!SpPaginatorMorph methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpPaginatorMorph methodsFor: 'initialization' stamp: ''!
extent: aPoint

	super extent: aPoint.
	pagesMorph height: aPoint y.
	selectionMorph height: aPoint y! !

!SpPaginatorMorph methodsFor: 'private' stamp: ''!
adjustSelectionToClosestPage
	| closestPage |

	closestPage := ((selectionMorph left - self left) / self baseWidth) rounded + 1.	
	selectionMorph left: self left + ((closestPage - 1) * self baseWidth).
	
	closestPage = self selectedPage 
		ifFalse: [ self basicSelectPage: closestPage ]! !

!SpPaginatorMorph methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpPaginatorMorph methodsFor: 'initialization' stamp: ''!
newSelectionMorph
	
	^ SpPaginatorSelectionMorph new
		whenDragFinishedDo: [ self adjustValues ];
		yourself! !

!SpPaginatorMorph methodsFor: 'initialization' stamp: ''!
initialize

	self class initializeSlots: self.
	super initialize.
	self 
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap.

	self addMorphBack: (selectionMorph := self newSelectionMorph).
	self addMorphBack: (pagesMorph := self newPagesMorph).
	
	self numberOfPagesShown: self class defaultNumberOfPagesShown.
	"We select the first page first"
	self basicSelectPage: 1.! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
addPage: anObject

	pagesMorph addMorphBack: (SpPaginatorPageMorph new
		vResizing: #spaceFill;
		model: anObject;
		whenSelectedDo: [ :aMorph | self doSelectPageFromMorph: aMorph ];
		yourself).
	self width: pagesMorph submorphs size * self baseWidth! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
selectionColor: aColor 

	selectionMorph color: aColor! !

!SpPaginatorMorph methodsFor: 'events' stamp: ''!
whenSelectedPageChangedDo: aBlock 

	self property: #selectedPage whenChangedDo: aBlock! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
removePage: anObject

	pagesMorph removeMorph: (pagesMorph submorphs 
		detect: [ :each | each model = anObject ]) ! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
removeAllPages

	pagesMorph removeAllMorphs! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
selectedPages
	
	^ (self selectedPage to: self selectedPage + self numberOfPagesShown - 1) asArray! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
numberOfPagesShown: aNumber

	numberOfPagesShown := aNumber.
	selectionMorph updateSizePages: numberOfPagesShown pageWidth: self baseWidth! !

!SpPaginatorMorph methodsFor: 'events' stamp: ''!
whenNumberOfPagesShownChangedDo: aBlock 

	self property: #numberOfPagesShown whenChangedDo: aBlock! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
selectionMorph

	^ selectionMorph! !

!SpPaginatorMorph methodsFor: 'accessing' stamp: ''!
numberOfPagesShown

	^ numberOfPagesShown! !

!SpPaginatorMorph methodsFor: 'initialization' stamp: ''!
defaultColor

	^ Color transparent! !

!SpPaginatorMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpPaginatorMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpPaginatorMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpPaginatorMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpPaginatorMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpPaginatorMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpPaginatorMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpPaginatorMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpPaginatorMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpPaginatorMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpPaginatorMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpPaginatorMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpPaginatorMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpPaginatorMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpPaginatorMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpPaginatorMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpPaginatorMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpPaginatorMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpPaginatorMorph class methodsFor: 'accessing' stamp: ''!
defaultNumberOfPagesShown

	^ 2! !

!SpPaginatorMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpPaginatorMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpPaginatorMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpPaginatorMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpPaginatorMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpPaginatorMorph class methodsFor: 'accessing' stamp: ''!
defaultHeight

	^ 18! !

!SpPaginatorMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpPaginatorMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpPaginatorMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpPaginatorMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpPaginatorMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpPaginatorMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpPaginatorMorphTest methodsFor: 'running' stamp: ''!
tearDown

	morph delete.
	super tearDown! !

!SpPaginatorMorphTest methodsFor: 'tests' stamp: ''!
testSelectPage

	self assert: morph selectedPages equals: #(1 2).
	morph selectPage: 5.
	self assert: morph selectedPages equals: #(5 6).
	"10 is last, I cannot select 10, 11... then I select 9, 10"
	morph selectPage: 10.
	self assert: morph selectedPages equals: #(9 10)! !

!SpPaginatorMorphTest methodsFor: 'tests' stamp: ''!
testWhenSelectedPageChangedDo
	| selectedPage |

	morph whenSelectedPageChangedDo: [ :pageNumber | selectedPage := pageNumber ].
	morph selectPage: 5.

	self assert: selectedPage equals: 5	! !

!SpPaginatorMorphTest methodsFor: 'tests' stamp: ''!
testWhenNumberOfPagesShownChangedDo
	| numberShown |

	morph whenNumberOfPagesShownChangedDo: [ :aNumber | numberShown := aNumber ].
	morph selectPage: 5.
	morph numberOfPagesShown: 3.

	self assert: numberShown equals: 3! !

!SpPaginatorMorphTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	morph := SpPaginatorMorph new 
		color: Color white;
		hResizing: #shrinkWrap;
		yourself.
	1 to: 10 do: [ :index | 
		morph addPage: index ].
	morph openInWorld.
! !

!SpPaginatorPageMorph commentStamp: ''!
A morph representing a "page" inside a `SpPaginatorMorph`.
Pages can be selected and users can control it with `SpPaginatorPageMorph>>#whenSelectedDo:`.!
!SpPaginatorPageMorph methodsFor: 'initialization' stamp: ''!
newContentMorph

	^ Morph new
		color: Color white;
		borderColor: self theme borderColor;
		borderWidth: 1;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		yourself! !

!SpPaginatorPageMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self 
		color: Color transparent;
		changeTableLayout;
		listDirection: #leftToRight;
		cellInset: self class defaultInset;
		cellSpacing: self class defaultInset;
		hResizing: #rigid;
		vResizing: #spaceFill;
		width: self class baseWidth.

	self addMorphBack: self newContentMorph.! !

!SpPaginatorPageMorph methodsFor: 'event handling' stamp: ''!
mouseDown: event

	super mouseDown: event.
	selectedBlock ifNotNil: [ 
		selectedBlock value: self ]! !

!SpPaginatorPageMorph methodsFor: 'menus' stamp: ''!
model: anObject

	model := anObject! !

!SpPaginatorPageMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: event

	^ true! !

!SpPaginatorPageMorph methodsFor: 'menus' stamp: ''!
model

	^ model! !

!SpPaginatorPageMorph methodsFor: 'events' stamp: ''!
whenSelectedDo: aBlock

	selectedBlock := aBlock! !

!SpPaginatorPageMorph class methodsFor: 'accessing' stamp: ''!
defaultInset

	^ 3! !

!SpPaginatorPageMorph class methodsFor: 'accessing' stamp: ''!
baseWidth

	^ 14! !

!SpPaginatorPresenter commentStamp: ''!
A presenter to show a paginator. 
Tipically, a paginator is associated to a miller list (See `SpMillerPaginatorPresenter`).!
!SpPaginatorPresenter methodsFor: 'api' stamp: ''!
chainTo: aPresenter
	"It will 'chain' this paginator with `aPresenter`. 
	 In order to work, `aPresenter` needs to implement this methods: 
		- `selectPage:` to react to a page change.
		- `visiblePages:` to react to an amount of pages displayed change.
		- `scrollByDeltaPercent:` to react to movement while displacing."
	
	self 
		whenSelectedPageChangedDo: [ :pageNumber | aPresenter selectPage: pageNumber ];
		whenVisiblePagesChangedDo: [ :aNumber | aPresenter visiblePages: aNumber ];
		whenDraggingDo: [ :deltaPercent | aPresenter scrollByDeltaPercent: deltaPercent ]! !

!SpPaginatorPresenter methodsFor: 'api - events' stamp: ''!
whenSelectedPageChangedDo: aBlock
	"Inform when a page selection has been changed.
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #selectedPage whenChangedDo: aBlock! !

!SpPaginatorPresenter methodsFor: 'api' stamp: ''!
addPage: aPresenter
	"Add a page related to `aPresenter`."
	
	pagesHolder add: aPresenter.
	self selectPage: pagesHolder size! !

!SpPaginatorPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	pagesHolder := OrderedCollection new asValueHolder.! !

!SpPaginatorPresenter methodsFor: 'api' stamp: ''!
visiblePages
	"Answer the paginator visible pages (visible pages are the pages marked as selected)."

	^ visiblePages! !

!SpPaginatorPresenter methodsFor: 'api' stamp: ''!
visiblePages: aNumber
	"Set the amount of visible pages to be shown the selected area."

	visiblePages := aNumber! !

!SpPaginatorPresenter methodsFor: 'api' stamp: ''!
pages
	"Answer a collection of all pages added to paginator."	

	^ pagesHolder value! !

!SpPaginatorPresenter methodsFor: 'api - events' stamp: ''!
whenDraggingDo: aBlock
	"Inform when selected area is being dragged (to change selected page).
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
	
	self property: #dragging whenChangedDo: aBlock! !

!SpPaginatorPresenter methodsFor: 'api' stamp: ''!
selectPage: aNumber
	"Select (make the selection area be placed at) the page at index `aNumber`."

	selectedPage := aNumber! !

!SpPaginatorPresenter methodsFor: 'api - events' stamp: ''!
whenPageAddedDo: aBlock
	"Inform when a page has been added.
	 `aBlock` receives one argument, the new page added."

	pagesHolder whenAddedDo: aBlock! !

!SpPaginatorPresenter methodsFor: 'private' stamp: ''!
dragging: aNumber

	dragging := aNumber! !

!SpPaginatorPresenter methodsFor: 'api' stamp: ''!
pages: aCollection
	"Set pages of paginator taken elements from `aCollection`."

	pagesHolder removeAll.
	aCollection do: [ :each | pagesHolder add: each ]! !

!SpPaginatorPresenter methodsFor: 'api - events' stamp: ''!
whenVisiblePagesChangedDo: aBlock
	"Inform when a visible pages has been changed.
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #visiblePages whenChangedDo: aBlock! !

!SpPaginatorPresenter methodsFor: 'api - events' stamp: ''!
whenPageRemovedDo: aBlock
	"Inform when a page has been added.
	 `aBlock` receives one argument, the page removed."

	pagesHolder whenRemovedDo: aBlock! !

!SpPaginatorPresenter class methodsFor: '*Spec2-Morphic-Examples' stamp: ''!
example

	^ SpPaginatorExample new openWithSpec! !

!SpPaginatorPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #PaginatorAdapter! !

!SpPaginatorPresenter class methodsFor: 'documentation' stamp: ''!
documentExamplesProtocol
	
	^ #'*Spec2-Morphic-Examples'! !

!SpPaginatorSelectionMorph commentStamp: ''!
A morph to being used as a selection area in a `SpPaginatorMorph`.
It can be dragged and resized.!
!SpPaginatorSelectionMorph methodsFor: 'private' stamp: ''!
announceDragFinished

	dragFinishedAction ifNil: [ ^ self ].
	dragFinishedAction cull: self left! !

!SpPaginatorSelectionMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self 
		changeTableLayout;
		listDirection: #leftToRight;
		hResizing: #rigid;
		vResizing: #spaceFill.
	self addResizingEdges! !

!SpPaginatorSelectionMorph methodsFor: 'accessing' stamp: ''!
minimumWidth

	^ minimumWidth! !

!SpPaginatorSelectionMorph methodsFor: 'events' stamp: ''!
whenDragFinishedDo: aBlock

	dragFinishedAction := aBlock! !

!SpPaginatorSelectionMorph methodsFor: 'events' stamp: ''!
whenDraggingDo: aBlock

	draggingAction := aBlock! !

!SpPaginatorSelectionMorph methodsFor: 'accessing' stamp: ''!
updateSizePages: pages pageWidth: pageWidth 
	
	(minimumWidth isNil or: [ pageWidth < minimumWidth ])
		ifTrue: [ minimumWidth := pageWidth ].
	self width: pages * pageWidth! !

!SpPaginatorSelectionMorph methodsFor: 'event handling' stamp: ''!
mouseDown: anEvent 

	super mouseDown: anEvent.
	lastX := self left.
	lastMouseX := anEvent cursorPoint x! !

!SpPaginatorSelectionMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: anEvent

	super mouseLeave: anEvent.
	lastMouseX ifNil: [ ^ self ].
	lastMouseX := nil.
	self resetPosition! !

!SpPaginatorSelectionMorph methodsFor: 'testing' stamp: ''!
canResizeTo: xNumber direction: direction

	(xNumber between: self owner left and: self owner right) ifFalse: [ ^ false ].
	(xNumber between: self left and: self right) ifTrue: [ 
		(direction = #left) ifTrue: [ ^ (self right - xNumber) > minimumWidth ]. 		
		(direction = #right) ifTrue: [ ^ (xNumber - self left) > minimumWidth ] ].
		
	^ true! !

!SpPaginatorSelectionMorph methodsFor: 'private' stamp: ''!
resetPosition

	lastX ifNil: [ ^ self ].
	self left: lastX.
	lastX := nil! !

!SpPaginatorSelectionMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: anEvent

	^ true
	! !

!SpPaginatorSelectionMorph methodsFor: 'event handling' stamp: ''!
mouseUp: anEvent 

	super mouseMove: anEvent.
	lastMouseX := nil.
	self announceDragFinished
	! !

!SpPaginatorSelectionMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	
	^ self theme paginatorSelectionColor! !

!SpPaginatorSelectionMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: anEvent

	^ true! !

!SpPaginatorSelectionMorph methodsFor: 'initialization' stamp: ''!
addResizingEdges

	"left resizer"
	self addMorphBack: (SpPaginatorEdgeGripMorph new 
		beLeft;
		target: self;
		yourself).

	"A transparent morph to fill the space"
	self addMorphBack: (Morph new 
		color: Color transparent;
		height: 0;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		yourself).

	"right resizer"
	self addMorphBack: (SpPaginatorEdgeGripMorph new 
		beRight;
		target: self; 
		yourself)! !

!SpPaginatorSelectionMorph methodsFor: 'event handling' stamp: ''!
mouseMove: anEvent 
	| x posX oldPosX |

	super mouseMove: anEvent.

	anEvent redButtonPressed ifFalse: [ ^ self ].
	lastMouseX ifNil: [ ^ self ].

	x := anEvent cursorPoint x.	
	posX := ((self left + (x - lastMouseX)) max: self owner left) min: (self owner right - self width).
	oldPosX := self left.
	self left: posX.
	lastMouseX := x.
	draggingAction ifNotNil: [ 
		draggingAction
			cull: posX - oldPosX
			cull: posX
			cull: oldPosX ]! !

!SpPanedConstraints commentStamp: ''!
I define the constraints of a presenter to be shown in a Paned Layout.
!
!SpPanedConstraints methodsFor: 'accessing' stamp: ''!
beNotShrinkable

	shrink := false! !

!SpPanedConstraints methodsFor: 'testing' stamp: ''!
canResize

	^ resize! !

!SpPanedConstraints methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	self beResizable.
	self beShrinkable! !

!SpPanedConstraints methodsFor: 'accessing' stamp: ''!
beShrinkable

	shrink := true! !

!SpPanedConstraints methodsFor: 'testing' stamp: ''!
canShrink

	^ shrink! !

!SpPanedConstraints methodsFor: 'accessing' stamp: ''!
beResizable

	resize := true! !

!SpPanedConstraints methodsFor: 'accessing' stamp: ''!
beNotResizable

	resize := false! !

!SpPanedConstraints class methodsFor: 'as yet unclassified' stamp: ''!
defaultFill

	^ true! !

!SpPanedConstraints class methodsFor: 'as yet unclassified' stamp: ''!
defaultExpand

	^ true! !

!SpPanedConstraints class methodsFor: 'as yet unclassified' stamp: ''!
defaultPadding 

	^ 0! !

!SpPanedLayout commentStamp: ''!
I'm a Paned Layout as if you would not how to read my name. I manage two and only two children, a first and a second one.

From that perspective, a paned layout is like a `SpBoxLayout`: it places childen in vertical or horizontal fashion, but it will add a splitter in between, that user can drag to resize the panel.

Nice methods to consider are:
- `SpPanedLayout>>#addFirst:` and `SpPanedLayout>>#addFirst:` to add my two children.
- `SpPanedLayout>>#positionOfSlider:`. It controls the position of the slider. 
-- `aNumber` can be a fixed number indicating the exact position where the slider will be placed in the pane.
-- `aFloat or percent` can also be a fraction or a percentage, indicating the percentage position 
	 of the slider. e.g. `30 percent` or (0.3) indicates the slider will be place at 1/3 of the 
	 panel."!
!SpPanedLayout methodsFor: 'api' stamp: ''!
position
	"Indicates original position of splitter. 
	 It can be nil (then it defaults to 50%).
	 It can be a percentage (e.g. 30 percent)"
	
	self
		deprecated: 'Use #positionOfSlider instead'
		transformWith: '`@receiver position' -> '`@receiver positionOfSlider'.

	^ positionOfSlider! !

!SpPanedLayout methodsFor: 'api - adding' stamp: ''!
add: aPresenterLayoutOrSymbol
	"Adds `aPresenterLayoutOrSymbol` as one of the elements to put in the paned layout. 
	 Te position of the element will be calculated in order of addition (and there cannot 
	 be more than two). 
	 `aPresenterLayoutOrSymbol` can be
		- any instance of `SpPresenter` hierarchy, 
		- another layout or 
		- a Symbol, matching the name of the instance variable who will contain the element to add."

	self 
		add: aPresenterLayoutOrSymbol 
		withConstraints: [ :constraints | ]
		place: children size + 1! !

!SpPanedLayout methodsFor: 'api - adding' stamp: ''!
addFirst: aPresenter
	"Add aPresenter as first element of the paned layout."
	
	self 
		add: aPresenter 
		withConstraints: [ :constraints | ]
		place: 1! !

!SpPanedLayout methodsFor: 'private' stamp: ''!
add: aChild withConstraints: aBlock place: aPosition
	"Add a child to the layout following the constraints in the block.
	The position is an integer index (1 or 2) indicating whether the child is first or last in 
	the pane.
	For a horizontal layout, index 1 means left, index 2 means right.
	For a vertical layout, index 1 means top, index 2 means bottom."
	
	| constraints |
	aPosition > 2 ifTrue: [ 
		self error: 'You can not add more than two paned presenters.' ].

	(childrenByPosition at: aPosition) 
		ifNotNil: [ :element | self remove: element ].

	constraints := self constraintsClass new.
	aBlock value: constraints.
	
	childrenByPosition at: aPosition put: aChild.
	
	children 
		at: aChild 
		put: constraints.
	
	self announceChildAdded: aChild.! !

!SpPanedLayout methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self positionOfSlider: 50 percent.
	childrenByPosition := Array new: 2! !

!SpPanedLayout methodsFor: 'api' stamp: ''!
position: aNumber
	"Position of the slider. 
	 - `aNumber` can be a fixed number indicating the exact position where the slider will 
	 be placed in the pane.
	 - `aNumber` can also be a fraction or a percentage, indicating the percentage position 
	 of the slider. E.g. 30 percent (0.3) indicates the slider will be place at 1/3 of the 
	 panel."

	self
		deprecated: 'Use #positionOfSlider: instead'
		transformWith: '`@receiver position: `@arg' -> '`@receiver positionOfSlider: `@arg'.
	
	positionOfSlider := aNumber! !

!SpPanedLayout methodsFor: 'api' stamp: ''!
children

	^ childrenByPosition reject: #isNil! !

!SpPanedLayout methodsFor: 'private' stamp: ''!
constraintsClass

	^ SpPanedConstraints! !

!SpPanedLayout methodsFor: 'api' stamp: ''!
direction 

	^ direction! !

!SpPanedLayout methodsFor: 'testing' stamp: ''!
isVertical 

	^ self direction = SpLayoutDirection vertical! !

!SpPanedLayout methodsFor: 'api' stamp: ''!
positionOfSlider
	"Indicates original position of splitter. 
	 It can be nil (then it defaults to 50%).
	 It can be a percentage (e.g. 30 percent)"

	^ positionOfSlider! !

!SpPanedLayout methodsFor: 'api - adding' stamp: ''!
replaceFirst: aPresenter
	"This is just a synonym of `SpPanedLayout>>#addFirst:`, added for clarity"
	
	self addFirst: aPresenter ! !

!SpPanedLayout methodsFor: 'api - adding' stamp: ''!
addSecond: aName
	"Add aPresenter as second element of the paned layout."

	self 
		add: aName 
		withConstraints: [ :constraints | ]
		place: 2! !

!SpPanedLayout methodsFor: 'testing' stamp: ''!
isHorizontal 

	^ self direction = SpLayoutDirection horizontal! !

!SpPanedLayout methodsFor: 'api - adding' stamp: ''!
replaceSecond: aPresenter
	"This is just a synonym of `SpPanedLayout>>#addSecond:`, added for clarity"
	
	self addSecond: aPresenter ! !

!SpPanedLayout methodsFor: 'private' stamp: ''!
adapterName

	^ #PanedAdapter! !

!SpPanedLayout methodsFor: 'api' stamp: ''!
positionOfSlider: aNumber
	"Position of the slider. 
	 - `aNumber` can be a fixed number indicating the exact position where the slider will 
	 be placed in the pane.
	 - `aFloat` can also be a fraction or a percentage, indicating the percentage position 
	 of the slider, e.g. 30 percent (0.3) indicates the slider will be place at 1/3 of the panel."

  positionOfSlider := aNumber! !

!SpPanedLayout methodsFor: 'api' stamp: ''!
remove: aPresenter ifAbsent: aBlock

	super remove: aPresenter ifAbsent: aBlock.
	childrenByPosition 
		at: (childrenByPosition indexOf: aPresenter)
		put: nil! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveSecondElementRemovesFromAdapter

	| element |
	layout addSecond: (element := SpButtonPresenter new).
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddFirstElementAfterOpenAddsToAdapter

	layout addSecond: SpButtonPresenter new.
	self openInstance.
	
	layout addFirst: SpButtonPresenter new.
	self assert: self adapter children size equals: 2! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddSecondTwiceSetsChildrenSingleTime

	| first second |
	layout addSecond: (first := SpButtonPresenter new).
	layout addSecond: (second := SpButtonPresenter new).
	self assert: self adapter children size equals: 1! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testLayoutWithSecondElementIsNotEmpty

	layout addSecond: SpButtonPresenter new.
	self deny: self adapter isEmpty! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveSecondElementAddedAfterOpenRemovesFromAdapter

	| element |
	layout addSecond: (element := SpButtonPresenter new).
	self openInstance.
	
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddFirstTwiceReplacesChild

	| first second |
	layout addFirst: (first := SpButtonPresenter new).
	layout addFirst: (second := SpButtonPresenter new).
	self assert: self adapter children first equals: second adapter widget! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddSecondElementAfterOpenAddsToAdapter

	layout addFirst: SpButtonPresenter new.
	self openInstance.
	
	layout addSecond: SpButtonPresenter new.
	self assert: self adapter children size equals: 2! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testLayoutWithFirstElementIsNotEmpty

	layout addFirst: SpButtonPresenter new.
	self deny: self adapter isEmpty! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveFirstElementAddedAfterOpenRemovesFromAdapter

	| element |
	layout addFirst: (element := SpButtonPresenter new).
	self openInstance.
	
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddFirstTwiceSetsChildrenSingleTime

	| first second |
	layout addFirst: (first := SpButtonPresenter new).
	layout addFirst: (second := SpButtonPresenter new).
	self assert: self adapter children size equals: 1! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveFirstElementRemovesFromAdapter

	| element |
	layout addFirst: (element := SpButtonPresenter new).
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAdapterElementsAreInExplicitOrder

	| first second |
	layout addFirst: (first := SpButtonPresenter new).
	layout addSecond: (second := SpButtonPresenter new).
	self assert: self adapter children first equals: first adapter widget.
	self assert: self adapter children second equals: second adapter widget.! !

!SpPanedLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddSecondTwiceReplacesChild

	| first second |
	layout addSecond: (first := SpButtonPresenter new).
	layout addSecond: (second := SpButtonPresenter new).
	self assert: self adapter children first equals: second adapter widget! !

!SpPanedLayoutAdapterTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == SpPanedLayoutAdapterTest! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testLayoutWithOneSecondElementIsNotEmpty

	layout addSecond: SpButtonPresenter new.
	self deny: layout isEmpty! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testLayoutWithOneFirstElementIsNotEmpty

	layout addFirst: SpButtonPresenter new.
	self deny: layout isEmpty! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testReplaceFirstElementReplacesIt
	| replacement |

	layout addFirst: SpButtonPresenter new.
	layout addFirst: (replacement := SpButtonPresenter new).
	self assert: layout children first equals: replacement! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testElementsAreAddedInOrder

	| second |
	layout addFirst: SpButtonPresenter new.
	layout addSecond: (second := SpButtonPresenter new).
	self assert: layout children last equals: second! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testReplaceSecondElementKeepsSingleElement

	| replacement |
	layout addSecond: SpButtonPresenter new.
	layout addSecond: (replacement := SpButtonPresenter new).
	self assert: layout children size equals: 1! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testReplaceSecond
	| replacement |

	layout addFirst: SpButtonPresenter new.
	layout addSecond: SpButtonPresenter new.
	layout replaceSecond: (replacement := SpButtonPresenter new).
	self assert: layout children second equals: replacement! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testRemoveFirstElementFromLayoutTakesItOut

	| element |
	layout addFirst: (element := SpButtonPresenter new).
	layout remove: element.
	self assert: layout isEmpty! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testRemoveSecondElementFromLayoutTakesItOut

	| element |
	layout addSecond: (element := SpButtonPresenter new).
	layout remove: element.
	self assert: layout isEmpty! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testReplaceSecondElementReplacesIt

	| replacement |
	layout addSecond: SpButtonPresenter new.
	layout addSecond: (replacement := SpButtonPresenter new).
	self assert: layout children first equals: replacement! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testReplaceFirst
	| replacement |

	layout addFirst: SpButtonPresenter new.
	layout replaceFirst: (replacement := SpButtonPresenter new).
	self assert: layout children first equals: replacement! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testReplaceFirstElementKeepsSingleElement

	| replacement |
	layout addFirst: SpButtonPresenter new.
	layout addFirst: (replacement := SpButtonPresenter new).
	self assert: layout children size equals: 1! !

!SpPanedLayoutTest methodsFor: 'running' stamp: ''!
testElementsAreAddedInOrderIndependentlyOfTheConfigurationOrder

	| second |
	layout addSecond: (second := SpButtonPresenter new).
	layout addFirst: SpButtonPresenter new.
	self assert: layout children last equals: second! !

!SpPanedLayoutTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == SpPanedLayoutTest! !

!SpPanedResizerHorizontalMorph commentStamp: ''!
I'm a paned horizontal resizer.
I'm called "horizonal" (even if my draw is vertical) because I split horizontally the panes between me.

self exampleHorizontal.!
!SpPanedResizerHorizontalMorph methodsFor: 'private' stamp: ''!
setTargetBounds
	| target |
	
	target := self target.
	target bounds: (target bounds withRight: self left - 1)! !

!SpPanedResizerHorizontalMorph methodsFor: 'private' stamp: ''!
setLayoutSizing
	"Adjust the sizing for use within table layouts."

	self 
		hResizing: #rigid; 
		vResizing: #spaceFill! !

!SpPanedResizerHorizontalMorph methodsFor: 'testing' stamp: ''!
isHorizontal
	"Answer true if the receiver has a horizontal layout."
	
	^ true! !

!SpPanedResizerHorizontalMorph methodsFor: 'accessing' stamp: ''!
positionPoint: aPoint
	"Reposition based on ptName."
	
	^ self position: aPoint x @ self top! !

!SpPanedResizerHorizontalMorph methodsFor: 'private' stamp: ''!
setTargetLayoutSizing

	(self target hResizing = #rigid) ifTrue: [ ^ self ].
	self target hResizing: #rigid.
	self targetAfter hResizing: #spaceFill.! !

!SpPanedResizerHorizontalMorph methodsFor: 'accessing' stamp: ''!
edgeName
	"Answer the value of edgeName"

	^ #right! !

!SpPanedResizerMorph commentStamp: ''!
I'm a base splitter to be used with a SpecPanedLayout. 
Splitters can be placed vertically or horizontally and my children deal with each of the cases.
The way I work is easy: 

- I need to be placed between two other morphs.
- I also need to act inside a morph with PanedLayout. 

self exampleVertical.
self exampleHorizontal.!
!SpPanedResizerMorph methodsFor: 'private' stamp: ''!
resetLayoutPosition
	"Since we are going to move the split bar, layout position (if any) needs to be reseted"
	
	self owner layoutPolicy resetPosition! !

!SpPanedResizerMorph methodsFor: 'testing' stamp: ''!
splitsTopAndBottom
	
	^ self isHorizontal! !

!SpPanedResizerMorph methodsFor: 'accessing' stamp: ''!
target 
	"answers previous morph in owners submorph list"
	
	^ self owner ifNotNil: [ :aMorph | 
		aMorph submorphs before: self ]! !

!SpPanedResizerMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		setLayoutSizing;
		extent: self defaultWidth @ self defaultHeight! !

!SpPanedResizerMorph methodsFor: 'private' stamp: ''!
setTargetBounds 

	self subclassResponsibility! !

!SpPanedResizerMorph methodsFor: 'private' stamp: ''!
targetAfter 

	^ self owner submorphs after: self! !

!SpPanedResizerMorph methodsFor: 'private' stamp: ''!
setLayoutSizing
	"Adjust the sizing for use within table layouts."

	self subclassResponsibility! !

!SpPanedResizerMorph methodsFor: 'event handling' stamp: ''!
mouseDown: anEvent
	"Remember the receiver and target offsets too."
	
	(self bounds containsPoint: anEvent cursorPoint)
		ifTrue: [ self fillStyle: self pressedFillStyle ].
		
	lastMouse := anEvent cursorPoint - self position.
	self eventHandler ifNotNil: [ :handler |
		handler mouseDown: anEvent fromMorph: self ]! !

!SpPanedResizerMorph methodsFor: 'actions' stamp: ''!
resizeCursor

	^ Cursor resizeForEdge: self edgeName! !

!SpPanedResizerMorph methodsFor: 'updating' stamp: ''!
themeChanged
	"Update the fill style."

	self fillStyle: self normalFillStyle.
	super themeChanged! !

!SpPanedResizerMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Change our color too."
	
	super adoptPaneColor: paneColor.
	self fillStyle: self normalFillStyle! !

!SpPanedResizerMorph methodsFor: 'accessing' stamp: ''!
defaultWidth
	"Answer the default width for the receiver."
	
	^ self class splitterWidth! !

!SpPanedResizerMorph methodsFor: 'testing' stamp: ''!
isHorizontal
	"Answer true if the receiver has a horizontal layout."
	
	^ self subclassResponsibility! !

!SpPanedResizerMorph methodsFor: 'accessing' stamp: ''!
positionPoint: aPoint
	"Reposition based on ptName."
	
	^ self subclassResponsibility! !

!SpPanedResizerMorph methodsFor: 'private' stamp: ''!
setTargetLayoutSizing

	self subclassResponsibility! !

!SpPanedResizerMorph methodsFor: 'event handling' stamp: ''!
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.
	self preserveLayoutPosition! !

!SpPanedResizerMorph methodsFor: 'private' stamp: ''!
preserveLayoutPosition

	self owner layoutPolicy preservePositionProportionOn: self owner! !

!SpPanedResizerMorph methodsFor: 'style' stamp: ''!
pressedFillStyle
	"Return the pressed fillStyle of the receiver."
	
	^ self theme splitterPressedFillStyleFor: self! !

!SpPanedResizerMorph methodsFor: 'accessing' stamp: ''!
edgeName
	"Answer the value of edgeName"

	^ self subclassResponsibility! !

!SpPanedResizerMorph methodsFor: 'accessing' stamp: ''!
defaultHeight
	"Answer the default height for the receiver."
	
	^ self class splitterWidth! !

!SpPanedResizerMorph methodsFor: 'event handling' stamp: ''!
mouseMove: anEvent
	"Track the mouse for resizing."

	self target ifNil: [ ^ self ].

	self
		setTargetLayoutSizing;
		resetLayoutPosition;
		positionPoint: anEvent cursorPoint - lastMouse;
		setTargetBounds! !

!SpPanedResizerMorph methodsFor: 'style' stamp: ''!
normalFillStyle
	"Return the normal fillStyle of the receiver."
	
	^self theme splitterNormalFillStyleFor: self! !

!SpPanedResizerMorph class methodsFor: 'instance creation' stamp: ''!
new 
	
	self error: 'Use #newHorizonal or #newVertical'! !

!SpPanedResizerMorph class methodsFor: 'examples' stamp: ''!
exampleHorizontal
	<example>
	
	(PanelMorph new
		 layoutPolicy: SpMorphicPanedLayout new;
		 listDirection: #leftToRight;
		 addMorphBack: (Morph new
				  color: Color red;
				  vResizing: #spaceFill;
				  hResizing: #spaceFill;
				  yourself);
		 addMorphBack: self newHorizontal;
		 addMorphBack: (Morph new
				  color: Color blue;
				  hResizing: #spaceFill;
				  vResizing: #spaceFill;
				  yourself);
		 openInWindow) extent: 500 @ 500! !

!SpPanedResizerMorph class methodsFor: 'instance creation' stamp: ''!
newVertical
	
	^ SpPanedResizerVerticalMorph basicNew initialize! !

!SpPanedResizerMorph class methodsFor: 'testing' stamp: ''!
isAbstract 

	 ^ self name = #SpPanedResizerMorph! !

!SpPanedResizerMorph class methodsFor: 'accessing' stamp: ''!
splitterWidth

	^ 4! !

!SpPanedResizerMorph class methodsFor: 'examples' stamp: ''!
exampleVertical
	<example>
	
	(PanelMorph new
		 layoutPolicy: SpMorphicPanedLayout new;
		 addMorphBack: (Morph new
				  color: Color red;
				  vResizing: #spaceFill;
				  hResizing: #spaceFill;
				  yourself);
		 addMorphBack: self newVertical;
		 addMorphBack: (Morph new
				  color: Color blue;
				  vResizing: #spaceFill;
				  hResizing: #spaceFill;
				  yourself);
		 openInWindow) extent: 500 @ 500! !

!SpPanedResizerMorph class methodsFor: 'instance creation' stamp: ''!
newHorizontal 
	
	^ SpPanedResizerHorizontalMorph basicNew initialize! !

!SpPanedResizerVerticalMorph commentStamp: ''!
I'm a paned vertical resizer.
I'm called "vertical" (even if my draw is horizontal) because I split vertically the panes between me.

self exampleVertical.!
!SpPanedResizerVerticalMorph methodsFor: 'private' stamp: ''!
setTargetBounds

	| target |
	target := self target.
	target bounds: (target position corner: (target right @ (self top - 1)))! !

!SpPanedResizerVerticalMorph methodsFor: 'private' stamp: ''!
setLayoutSizing
	
	self 
		hResizing: #spaceFill; 
		vResizing: #rigid! !

!SpPanedResizerVerticalMorph methodsFor: 'testing' stamp: ''!
isHorizontal
	"Answer true if the receiver has a horizontal layout."
	
	^ false! !

!SpPanedResizerVerticalMorph methodsFor: 'accessing' stamp: ''!
positionPoint: aPoint
	"Reposition based on ptName."
	
	^ self position: self left @ aPoint y! !

!SpPanedResizerVerticalMorph methodsFor: 'private' stamp: ''!
setTargetLayoutSizing

	(self target vResizing = #rigid) ifTrue: [ ^ self ].
	self target vResizing: #rigid.
	self targetAfter vResizing: #spaceFill! !

!SpPanedResizerVerticalMorph methodsFor: 'accessing' stamp: ''!
edgeName
	"Answer the value of edgeName"

	^ #bottom! !

!SpPanelMorphWithSplitters commentStamp: ''!
A PanelMorphWithSplitters is which add splitters the way SystemWindow do it!
!SpPanelMorphWithSplitters methodsFor: 'private' stamp: ''!
addPaneVSplitters
	"Add the vertical pane splitters."

	|remaining targetRight sameRight sameLeft |
	remaining := paneMorphs reject: [:each |
			each layoutFrame rightFraction = 1 or: [
				each layoutFrame rightFraction = 0]].
	[remaining notEmpty] whileTrue: [
		targetRight := remaining first layoutFrame rightFraction.
		sameRight := remaining select: [:each |
			each layoutFrame rightFraction = targetRight].
		sameLeft := paneMorphs select: [:each |
			each layoutFrame leftFraction = targetRight and: [
				each layoutFrame rightFraction ~= targetRight]].
		remaining := remaining
			copyWithoutAll: (self addPaneVSplitterBetween: sameRight and: sameLeft)]! !

!SpPanelMorphWithSplitters methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	paneMorphs := OrderedCollection new.! !

!SpPanelMorphWithSplitters methodsFor: 'submorphs - add/remove' stamp: ''!
addMorph: aMorph fullFrame: aLayout

	paneMorphs add: aMorph.
	super addMorph: aMorph fullFrame: aLayout! !

!SpPanelMorphWithSplitters methodsFor: 'submorphs - add/remove' stamp: ''!
addMorph: aMorph

	paneMorphs add: aMorph.
	^ super addMorph: aMorph! !

!SpPanelMorphWithSplitters methodsFor: 'private' stamp: ''!
addPaneHSplitters
	"Add the horizontal pane splitters."

	|remaining targetBottom sameBottom sameTop|
	remaining := paneMorphs reject: [:each |
			each layoutFrame bottomFraction = 1 or: [
				each layoutFrame bottomFraction = 0]].
	[remaining notEmpty] whileTrue: [
		targetBottom := remaining first layoutFrame bottomFraction.
		sameBottom := remaining select: [:each |
			each layoutFrame bottomFraction = targetBottom].
		sameTop := paneMorphs select: [:each |
			each layoutFrame topFraction = targetBottom].
		remaining := remaining
			copyWithoutAll: (self addPaneHSplitterBetween: sameBottom and: sameTop)]! !

!SpPanelMorphWithSplitters methodsFor: 'private' stamp: ''!
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! !

!SpPanelMorphWithSplitters methodsFor: 'private' stamp: ''!
linkSplittersToSplitters
	"The pane morphs are already linked. Cross link the splitters as appropriate."
	
	self splitters do: [:each |
		each splitsTopAndBottom
			ifTrue: [self splitters do: [:eachMorph |
					eachMorph splitsTopAndBottom ~= each splitsTopAndBottom ifTrue: [
						eachMorph layoutFrame bottomFraction = each layoutFrame topFraction
							ifTrue: [each addLeftOrTop: eachMorph].
						eachMorph layoutFrame topFraction = each layoutFrame bottomFraction
							ifTrue: [each addRightOrBottom: eachMorph]]]]
			ifFalse: [self splitters do: [:eachMorph |
					eachMorph splitsTopAndBottom ~= each splitsTopAndBottom ifTrue: [
						eachMorph layoutFrame rightFraction = each layoutFrame leftFraction
							ifTrue: [each addLeftOrTop: eachMorph].
						eachMorph layoutFrame leftFraction = each layoutFrame rightFraction
							ifTrue: [each addRightOrBottom: eachMorph]]]].
				
		each comeToFront.]! !

!SpPanelMorphWithSplitters methodsFor: 'private' stamp: ''!
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! !

!SpPanelMorphWithSplitters methodsFor: 'layout - properties' stamp: ''!
layoutFrame: aFrame

	self activate.
	super layoutFrame: aFrame! !

!SpPanelMorphWithSplitters methodsFor: 'private' stamp: ''!
addPaneSplitters
	"Add the vertical and horizontal pane splitters."

	self removePaneSplitters.
	self addPaneVSplitters.
	self addPaneHSplitters.
	self linkSplittersToSplitters! !

!SpPatchMark methodsFor: 'accessing' stamp: ''!
backgroundColor

	^ backgroundColor! !

!SpPatchMark methodsFor: 'accessing' stamp: ''!
backgroundColor: anObject

	backgroundColor := anObject! !

!SpPatchMark methodsFor: 'accessing' stamp: ''!
iconName: anObject

	iconName := anObject! !

!SpPatchMark methodsFor: 'accessing' stamp: ''!
iconName

	^ iconName! !

!SpPatchMark methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!SpPatchMark methodsFor: 'private' stamp: ''!
name: anObject

	name := anObject! !

!SpPatchMark class methodsFor: 'instance creation' stamp: ''!
newName: aString

	^ self new 
		name: aString; 
		yourself! !

!SpPatchModel methodsFor: 'testing' stamp: ''!
isEmpty

	^ self source isEmpty 
		and: [ self destination isEmpty ] 
		! !

!SpPatchModel methodsFor: 'accessing' stamp: ''!
destination

	^ destination ifNil: [ '' ]! !

!SpPatchModel methodsFor: 'accessing' stamp: ''!
source

	^ source ifNil: [ '' ]! !

!SpPatchModel methodsFor: 'accessing' stamp: ''!
patch

	^ DiffBuilder 
		buildPatchFrom: self source lines
		to: self destination lines! !

!SpPatchModel methodsFor: 'initialization' stamp: ''!
from: aSource to: aDestination

	source := aSource.
	destination := aDestination! !

!SpPatchModel class methodsFor: 'instance creation' stamp: ''!
newFrom: aSource to: aDestination

	^ self new 
		from: aSource 
		to: aDestination! !

!SpPatchPresenter methodsFor: 'private' stamp: ''!
basicInteractionModel: anInteractionModel

	interactionModel := anInteractionModel! !

!SpPatchPresenter methodsFor: 'api - events' stamp: ''!
whenPatchChangedDo: aBlock

	self property: #patch whenChangedDo: aBlock! !

!SpPatchPresenter methodsFor: 'api - model' stamp: ''!
patch: aPatchModel

	patch := aPatchModel! !

!SpPatchPresenter methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.! !

!SpPatchPresenter methodsFor: 'api' stamp: ''!
syntaxHighlightTheme: aSymbol
	"The name of the syntax highlight theme to use (e.g. 'Blue', 'Vintage', 'Solarized', 'Tango')"

	syntaxHighlightTheme := aSymbol! !

!SpPatchPresenter methodsFor: 'api - model' stamp: ''!
beForMethod: aMethod
	"used when browsing methods"

	self interactionModel: (SpCodeMethodInteractionModel on: aMethod)! !

!SpPatchPresenter methodsFor: 'private' stamp: ''!
interactionModel: anInteractionModel

	anInteractionModel owner: self.
	self basicInteractionModel: anInteractionModel! !

!SpPatchPresenter methodsFor: 'api' stamp: ''!
marks

	^ marks ifNil: [ 
		self marks: self class defaultMarks.
		marks ]! !

!SpPatchPresenter methodsFor: 'api - model' stamp: ''!
beForScripting
	"Use in playgrounds"

	self interactionModel: SpCodeScriptingInteractionModel new! !

!SpPatchPresenter methodsFor: 'api' stamp: ''!
syntaxHighlightTheme
	"The name of the syntax highlight theme to use (e.g. 'Blue', 'Vintage', 'Solarized', 'Tango'). 
	 If not defined, the component will take the default value from the system."

	^ syntaxHighlightTheme! !

!SpPatchPresenter methodsFor: 'api' stamp: ''!
marks: aCollectionOfMarks

	marks := aCollectionOfMarks 
		collect: [ :each | each name -> each ]
		as: SmallDictionary! !

!SpPatchPresenter methodsFor: 'private' stamp: ''!
model

	^ patch! !

!SpPatchPresenter methodsFor: 'api - model' stamp: ''!
beForBehavior: aBehavior
	"used when browsing classes or alike"

	self interactionModel: (SpCodeBehaviorInteractionModel on: aBehavior)! !

!SpPatchPresenter methodsFor: 'api - model' stamp: ''!
patchFrom: source to: destination

	self patch: (SpPatchModel 
		newFrom: source 
		to: destination)! !

!SpPatchPresenter class methodsFor: 'as yet unclassified' stamp: ''!
defaultMarks

	^ {  
		(SpPatchMark newName: #insert) 
			backgroundColor: (Color green alpha: 0.1); 
			iconName: #changeAdd;
			yourself.
		(SpPatchMark newName: #delete)
			backgroundColor: (Color red alpha: 0.1);
			iconName: #changeRemove;
			yourself.
		(SpPatchMark newName: #change)
			backgroundColor: (Color gray alpha: 0.1);
			iconName: #changeUpdate;
			yourself.
	}! !

!SpPatchPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #PatchAdapter! !

!SpPatchSideBySidePresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #PatchSideBySideAdapter! !

!SpPharoThemeIconProvider commentStamp: ''!
I'm a provider that redirects to the default Pharo icon provider.!
!SpPharoThemeIconProvider methodsFor: 'accessing' stamp: ''!
noIcon

	^ ThemeIcons current blankIcon! !

!SpPharoThemeIconProvider methodsFor: 'accessing' stamp: ''!
iconNamed: aName 

	^ self 
		iconNamed: aName 
		ifAbsent: [ self noIcon ]! !

!SpPharoThemeIconProvider methodsFor: 'accessing' stamp: ''!
iconNamed: aName ifAbsent: aBlock

	^ ThemeIcons current 
		iconNamed: aName 
		ifNone: aBlock! !

!SpPopoverBottomPosition commentStamp: ''!
I define a popover needs to be shown at the bottom of its owner.!
!SpPopoverBottomPosition methodsFor: 'operations' stamp: ''!
applyTo: aWidget

	aWidget bePositionBottom! !

!SpPopoverContentExample commentStamp: ''!
I am an example of a popover content.
I will show a simple text.!
!SpPopoverContentExample methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpBoxLayout newTopToBottom
		borderWidth: 10; 
		add: (self newLabel label: 'A cool popup!!');
		yourself)! !

!SpPopoverContentPresenter commentStamp: ''!
A popover content presenter. 
All popovers contents need to extent this presenter (to get some functionalies).!
!SpPopoverContentPresenter methodsFor: 'api' stamp: ''!
dismiss

	^ self owner dismiss! !

!SpPopoverDeleteListenerMorph commentStamp: ''!
A morph that acts EXCLUSIVELY as a listener of mouse events. 
The purpose is to listen to mouse events and send them back to a `SpPopoverMorph`.

See `SpPopoverMorph>>#registerToDeleteEvents`.!
!SpPopoverDeleteListenerMorph methodsFor: 'events-processing' stamp: ''!
handleMouseUp: evt

	^ self eventHandler ifNotNil: [:handler | handler mouseUp: evt fromMorph: self ]! !

!SpPopoverDeleteListenerMorph methodsFor: 'events-processing' stamp: ''!
handleMouseDown: evt

	^ self eventHandler ifNotNil: [:handler | handler mouseDown: evt fromMorph: self ]! !

!SpPopoverDeleteListenerMorph methodsFor: 'events-processing' stamp: ''!
handleMouseMove: evt

	^ self eventHandler ifNotNil: [:handler | handler mouseMove: evt fromMorph: self ]! !

!SpPopoverExample commentStamp: ''!
I am a simple example of a popover. 
I will show a button pad to allow an user to display a popup in different places.

[[[
self new openWithSpec
]]]!
!SpPopoverExample methodsFor: 'initialization' stamp: ''!
showPopover: aPosition relativeTo: aPresenter

	popover ifNotNil: [ popover dismiss ].
	(popover := self newPopover)
		relativeTo: aPresenter;
		position: aPosition;
		presenter: (SpPresenter new 
			layout: (SpBoxLayout newTopToBottom
				borderWidth: 10; 
				spacing: 5;
				add: (self newLabel label: 'A cool popup!!');
				add: (self newButton 
					label: 'Dismiss';
					action: [ popover dismiss ];
					yourself);
				yourself);
			yourself);
		popup! !

!SpPopoverExample methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter 
		title: 'Popover example';
		initialExtent: 800@600! !

!SpPopoverExample methodsFor: 'initialization' stamp: ''!
initializePresenters

		top := self newButton
			label: 'Top';
			action: [ self showPopover: SpPopoverPosition top relativeTo: top ].
		left := self newButton
			label: 'Left';
			action: [ self showPopover: SpPopoverPosition left relativeTo: left ].
		bottom := self newButton
			label: 'Bottom';
			action: [ self showPopover: SpPopoverPosition bottom relativeTo: bottom ].
		right := self newButton
			label: 'Right';
			action: [ self showPopover: SpPopoverPosition right relativeTo: right ].! !

!SpPopoverExample class methodsFor: 'initialization' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		hAlignCenter;
		vAlignCenter; 
		add: #top expand: false;
		add: #left  expand: false;
		add: #bottom expand: false;
		add: #right expand: false;
		yourself! !

!SpPopoverExample class methodsFor: 'showing' stamp: ''!
open
	<script>

	^ self new openWithSpec! !

!SpPopoverLeftPosition commentStamp: ''!
I define a popover needs to be shown at the left of its owner.!
!SpPopoverLeftPosition methodsFor: 'operations' stamp: ''!
applyTo: aWidget

	aWidget bePositionLeft! !

!SpPopoverMorph commentStamp: ''!
I am a popover morph, which is a morph who will pop in relation to another morph (or/and in a relative position). 
It has a position: top, left, bottom and right (default is right).
It will be dismissed if click outside or keyboard focus translate to another place other than its children.!
!SpPopoverMorph methodsFor: 'private' stamp: ''!
calculatePositionBottomFrom: aRect
	| x y |
	
	y := aRect corner y + self separatatedBy.
	x := aRect corner x - ((aRect width + self width) // 2).

	^ x @ y
	! !

!SpPopoverMorph methodsFor: 'drawing' stamp: ''!
drawOn: canvas

	self drawBorderOn: canvas.
	super drawOn: canvas.
	showArrow ifTrue: [ 
		self drawArrowOn: canvas ]! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
hideArrow

	showArrow := false! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
arrowTopVertices
	| rect |
	
	rect := ((self left + (self width / 2)) - self borderWidth)@(self bottom - (self borderWidth / 2)) extent: self arrowSize@(self borderWidth / 2).
	^ { 
		rect topLeft. 
		rect bottomCenter.
		rect topRight.
	 }! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
bePositionRight

	position := #right! !

!SpPopoverMorph methodsFor: 'drawing' stamp: ''!
drawBorderOn: canvas
	
	canvas 
		fillRectangle: (self bounds insetBy: self borderWidth / 2) 
		color: self color! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
arrowSize

	^ arrowSize ifNil: [ 20 ]! !

!SpPopoverMorph methodsFor: 'api' stamp: ''!
popdown
	
	self delete! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
setPositionFrom: aRect

	self position: (self calculatePositionFrom: aRect)

	! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
arrowLeftVertices
	| rect |
	
	"rect := (self right - (self borderWidth / 2))@((self top + (self height / 2)) - (self arrowSize / 2)) extent: (self borderWidth / 2)@self arrowSize."
	rect := (self right - (self borderWidth / 2))@(self top + (self borderWidth * 1.5)) extent: (self borderWidth / 2)@self arrowSize.
	
	^ { 
		rect topLeft. 
		rect rightCenter.
		rect bottomLeft.
	 }! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
setSize
	| morph |
	
	morph := self submorphs first.
	self extent: morph extent 
		+ (self borderWidth * 2) 
		+ (morph borderWidth * 2) 
		+ (self cellInset * 2)
		+ (4@0) "a magic to correctly display (otherwise it will add an horizontal 
		scrollbar to contents)".
	 "I need this to calculate properly the size (otherwise I cannot position 
	  the popover correctly"
	self computeFullBounds! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
arrowBottomVertices
	| rect |
	
	rect := ((self left + (self width / 2)) - self borderWidth)@(self top) extent: self arrowSize@(self borderWidth / 2).
	^ { 
		rect bottomLeft. 
		rect topCenter.
		rect bottomRight.
	 }! !

!SpPopoverMorph methodsFor: 'drawing' stamp: ''!
drawArrowOn: canvas
		
	canvas 
		drawPolygon: self arrowVertices
		fillStyle: self color! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
arrowSize: aNumber

	arrowSize := aNumber! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
relativeTo 

	^ relativeTo! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
showArrow

	showArrow := true! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
calculatePositionFrom: aRect

	position = #top ifTrue: [ ^ self calculatePositionTopFrom: aRect ].
	position = #left ifTrue: [ ^ self calculatePositionLeftFrom: aRect ].
	position = #bottom ifTrue: [ ^ self calculatePositionBottomFrom: aRect ].
	position = #right ifTrue: [ ^ self calculatePositionRightFrom: aRect ].
	
	self error: 'Should not arrive here'


	! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
calculatePositionTopFrom: aRect
	| x y |
	
	y := aRect origin y - self separatatedBy - self height.
	x := aRect corner x - ((aRect width + self width) // 2).

	^ x @ y	! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
registerToDeleteEvents

	deleteMorph ifNotNil: [ self activeHand removeMouseListener: deleteMorph ].
	self activeHand addMouseListener: (deleteMorph := SpPopoverDeleteListenerMorph new 
		on: #mouseDown send: #validateMousePosition: to: self;
		on: #mouseUp send: #validateMousePosition: to: self;
		yourself)! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
calculatePositionRightFrom: aRect
	| x y |
	
	x := aRect corner x + self separatatedBy.
	y := aRect origin y - self borderWidth.

	^ x @ y! !

!SpPopoverMorph methodsFor: 'submorphs - add/remove' stamp: ''!
delete

	self activeHand ifNotNil: [ :hand | 
		deleteMorph ifNotNil: [ 
			hand removeMouseListener: deleteMorph ] ].
	super delete! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
calculatePositionLeftFrom: aRect
	| x y |
	
	x := aRect origin x - self separatatedBy - self width.
	y := aRect origin y - self borderWidth.

	^ x @ y	! !

!SpPopoverMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self 
		changeTableLayout;
		listDirection: #leftToRight;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		borderWidth: 10;
		borderColor: Color transparent;
		listCentering: #center;
		beSticky.
	self bePositionBottom.
	self showArrow! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
beRelativeTo: aMorph

	relativeTo := aMorph! !

!SpPopoverMorph methodsFor: 'api' stamp: ''!
popupPointingTo: aRectangle

	self setSize.
	self setPositionFrom: aRectangle.
	self openInWorld.
	self takeKeyboardFocus.
	self registerToDeleteEvents! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
bePositionTop

	position := #top! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
contentMorph: aMorph 

	self removeAllMorphs.
	self addMorphBack: aMorph! !

!SpPopoverMorph methodsFor: 'api' stamp: ''!
popup

	self popupPointingTo: self relativeTo boundsInWorld! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
arrowRightVertices
	| rect |
	
	"rect := self left@((self top + (self height / 2)) - (self arrowSize / 2)) extent: (self borderWidth / 2)@self arrowSize."
	rect := self left@(self top + (self borderWidth * 1.5)) extent: (self borderWidth / 2)@self arrowSize.

	
	^ { 
		rect topRight. 
		rect leftCenter.
		rect bottomRight.
	 }! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
bePositionBottom

	position := #bottom! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
bePositionLeft

	position := #left! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
arrowVertices

	position = #bottom ifTrue: [ ^ self arrowBottomVertices ].
	position = #right ifTrue: [ ^ self arrowRightVertices ].
	position = #top ifTrue: [ ^ self arrowTopVertices ].
	position = #left ifTrue: [ ^ self arrowLeftVertices ].
	
	self error: 'Should not arrive here'! !

!SpPopoverMorph methodsFor: 'accessing' stamp: ''!
defaultColor

	^ self theme lightBaseColor! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
separatatedBy

	^ 0! !

!SpPopoverMorph methodsFor: 'private' stamp: ''!
validateMousePosition: evt
	"Handle a mouse up event."
	
	(self fullContainsPoint: evt position) ifTrue: [ ^ self ].
	"Mouse up outside. Release eventual focus and delete if pop up."
	"evt hand releaseMouseFocus: self."
	self currentWorld defer: [ self delete ]! !

!SpPopoverPosition commentStamp: ''!
I represent the position of a popover in relation to its owner.
I am an abstract class and my children will define: top, left, bottom or right position.!
!SpPopoverPosition methodsFor: 'operations' stamp: ''!
applyTo: aWidget

	self subclassResponsibility! !

!SpPopoverPosition class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Use #uniqueInstance'! !

!SpPopoverPosition class methodsFor: 'accessing' stamp: ''!
bottom

	^ SpPopoverBottomPosition uniqueInstance! !

!SpPopoverPosition class methodsFor: 'accessing' stamp: ''!
right

	^ SpPopoverRightPosition uniqueInstance! !

!SpPopoverPosition class methodsFor: 'accessing' stamp: ''!
left

	^ SpPopoverLeftPosition uniqueInstance! !

!SpPopoverPosition class methodsFor: 'instance creation' stamp: ''!
uniqueInstance

	self = SpPopoverPosition 
		ifTrue: [ self error: 'I''m abstract, use one of my children.' ].	
	^ uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! !

!SpPopoverPosition class methodsFor: 'accessing' stamp: ''!
top

	^ SpPopoverTopPosition uniqueInstance! !

!SpPopoverPresenter commentStamp: ''!
A presenter to display a popover. 
`SpPopoverPresenter` will be relative to its owner, but Iitcan be shown pointing to a particular place (see `SpPopoverPresenter>>#popup`, and `SpPopoverPresenter>>#popupPointingTo:`)
Also, it can be show at the top, left, bottom or right of the owner or rectangle to point.

The presenter placed on a popover needs to extend `SpPopoverContentPresenter` (or implement its API) to gain all properties.!
!SpPopoverPresenter methodsFor: 'api' stamp: ''!
position
	"Answer the position (top, left, bottom, right) of the presenter."

	^ position! !

!SpPopoverPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self bePositionBottom! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
bePositionRight
	"Set the popover to appear at the right of the owner (or the presenter set 
	 by `SpPopoverPresenter>>#relativeTo:`)
	 See also `SpPopoverPresenter>>#position:`"

	self position: SpPopoverPosition right! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
bePositionTop
	"Set the popover to appear at the top of the owner (or the presenter set 
	 by `SpPopoverPresenter>>#relativeTo:`)
	 See also `SpPopoverPresenter>>#position:`"

	self position: SpPopoverPosition top! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
popup
	"Shows the popover, relative to `SpPopoverPresenter>>#relativeTo`."

	self adapter ifNil: [ self buildWithSpec ].
	self withAdapterDo: [ :anAdapter |
		anAdapter popup ]! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
popupPointingTo: aRectangle
	"Shows the popover, relative to `SpPopoverPresenter>>#relativeTo`, and 
	 pointing to `aRectangle`"

	self adapter ifNil: [ self buildWithSpec ].
	self withAdapterDo: [ :anAdapter |
		anAdapter popupPointingTo: aRectangle ]! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
position: aPosition
	"Set the position (top, left, bottom, right) of the presenter."

	position := aPosition! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
relativeTo: aPresenter
	"Set the presenter that will show the popover (and the popover will be shown relative to it)."

	relativeTo := aPresenter! !

!SpPopoverPresenter methodsFor: 'api - focus' stamp: ''!
defaultKeyboardFocus

	^ self presenter! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
dismiss 
	"Dismiss this popover"

	^ self withAdapterDo: [ :anAdapter | anAdapter dismiss ]! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
presenter
	"Answer the presenter that will be shown by the popover."

	^ presenter! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
presenter: aPresenter
	"Set the presenter that will be shown by the popover."

	aPresenter owner: self.
	presenter := aPresenter! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
relativeTo
	"Answer the presenter that will show the popover (and the popover will be shown relative to it)."

	^ relativeTo ifNil: [ self owner ]! !

!SpPopoverPresenter methodsFor: 'api - events' stamp: ''!
whenPresenterChangedDo: aBlock
	"Inform when content presenter has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #presenter whenChangedDo: aBlock! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
bePositionBottom
	"Set the popover to appear at the bottom of the owner (or the presenter set 
	 by `SpPopoverPresenter>>#relativeTo:`). 
	 See also `SpPopoverPresenter>>#position:`"

	self position: SpPopoverPosition bottom! !

!SpPopoverPresenter methodsFor: 'api' stamp: ''!
bePositionLeft
	"Set the popover to appear at the left of the owner (or the presenter set 
	 by `SpPopoverPresenter>>#relativeTo:`)
	 See also `SpPopoverPresenter>>#position:`"

	self position: SpPopoverPosition left! !

!SpPopoverPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newPopover! !

!SpPopoverPresenter class methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
sampleInstanceForTest

	^ super sampleInstanceForTest
		relativeTo: (SpButtonPresenter new
			buildWithSpec; 
			yourself);
		presenter: SpLabelPresenter new;
		yourself! !

!SpPopoverPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example

	^ SpPopoverExample new openWithSpec! !

!SpPopoverPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #PopoverAdapter! !

!SpPopoverPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	
	
	^ SpPopoverPresenter! !

!SpPopoverPresenterTest methodsFor: 'tests' stamp: ''!
testPopoverPopupTextTakesExtentFromPresenter

	[
		window := SpLabelPresenter new openWithSpec.
		presenter 
			bePositionRight;
			presenter: (presenter newText 
				beNotWrapWord;
				propagateNaturalWidth: true;
				propagateNaturalHeight: true;
				editable: false;
				text: (String loremIpsum withNoLineLongerThan: 80);
				yourself);
			relativeTo: window;
			popup.
		MorphicRenderLoop new doOneCycle.	

		self 
			assert: presenter adapter widget width >= presenter presenter adapter widget width;
			assert: presenter adapter widget height >= presenter presenter adapter widget height. ]
	ensure: [ 
		presenter dismiss ]! !

!SpPopoverPresenterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	"Adding an owner to be sure it some functions (relative to its owner/referenced object) 
	 will be correctly tested"
	presenter owner: ((ownerPresenter := SpPresenter new)
		layout: SpBoxLayout newTopToBottom;
		buildWithSpec;
		yourself).
		
	presenter presenter: (SpPresenter new 
		layout: (SpBoxLayout newTopToBottom
			add: 'Test Popover';
			add: (presenter newButton label: 'Button');
			yourself);
		yourself)! !

!SpPopoverPresenterTest methodsFor: 'tests' stamp: ''!
testPopoverPopupTakesExtentFromPresenter

	[
		window := SpLabelPresenter new openWithSpec.
		presenter 
			relativeTo: window;
			popup.
		MorphicRenderLoop new doOneCycle.	
		self 
			assert: presenter adapter widget width >= presenter presenter adapter widget width;
			assert: presenter adapter widget height >= presenter presenter adapter widget height. ]
	ensure: [ 
		presenter dismiss ]! !

!SpPopoverPresenterTest methodsFor: 'tests' stamp: ''!
testPopoverTakesExtentFromPresenter

	self openInstance.
	
	self 
		assert: presenter adapter widget width >= presenter presenter adapter widget width;
		assert: presenter adapter widget height >= presenter presenter adapter widget height.! !

!SpPopoverRightPosition commentStamp: ''!
I define a popover needs to be shown at the right of its owner.!
!SpPopoverRightPosition methodsFor: 'operations' stamp: ''!
applyTo: aWidget

	aWidget bePositionRight! !

!SpPopoverTopPosition commentStamp: ''!
I define a popover needs to be shown at the top of its owner.!
!SpPopoverTopPosition methodsFor: 'operations' stamp: ''!
applyTo: aWidget

	aWidget bePositionTop! !

!SpPresenter commentStamp: ''!
`SpPresenter` is an abstract class which represents an presenter made to be composed with other `SpPresenter` instances.

Often, I am used to display other subclasses of `SpPresenter` or subclasses of `SpAbstractWidgetPresenter`.

I collaborate with 
- `ObservableSlot` to manage some of my variables.
- `SpLayout`
- `SpWindowPresenter` or `SpDialogWindowPresenter` to display myself.

A new subclass of `SpPresenter` must at least define `initializeWidgets` and `defaultSpec` on the class side.

I provide the following methods
- aboutText: set the text displayed in the About.
- initializeWindow: to set the title, and other information related to the window.
- extent: set the initial size of the window, alternative possibility is define again initialExtent, it must be called before have displayed the widget. 
- focusOrder: set an instance what manage the order of focus of the keyboard navigation.
- bindKeyCombination:toAction: create a shortcut on keyboard what perform the block of the  action.
- owner getter of my parent.
- window getter of the window displaying me.

On my class side, I provide methods returning standard height and width for some elements.

## Window

- `SpPresenter>>#openWithSpec` instantiates a `SpWindowPresenter` using the lookup to found the layout to use.
- `SpPresenter>>#openDialogWithSpec` instanciates a `SpDialogWindowPresenter` using the lookup to found the layout to use.
Their variants `openWithSpec:` and `openDialogWithSpec:` use the layout parameter.

These methods can be useful to manage the window
- `SpPresenter>>#isDisplayed` returns true if the window of the widget is displayed
- `SpPresenter>>#hasWindow` returns true if the widget have a window
- `SpPresenter>>#centered` to center the window in the world.
- `SpPresenter>>#delete` to delete the window.

## Instantiation

`SpPresenter>>#initializePresenters` is called by the initialize method, it should contain initialization of subwidgets.

The instantiation of a subwidget should use one of that way
- `instantiate:` take a presenter class as parameter and return the created instance.
- methods named 'new' followed by a widget name are shortcut working with `instantiate:`

```
	list := self newList.
	list2 := self instantiate: SpListPresenter
```

Usually, the subwidgets must be added in the focusOrder using something like 'self focusOrder add: accessor of  the  subwidget'

`SpPresenter>>#connectPresenters` is called by the initialize method after initializePresenters, it should manage interaction of subwidgets.

Methods named 'when' followed by an event provide hook to perform the action in parameter.

### Note
Be careful about code order if you are overriding initialize method.
Normally in Spec initializing instance variables should be done BEFORE calling `super initialize` (so the opposite of the normal approach), because super initialize calls `initalizePresenters` and `connectPresenters` that normally would make use of those variables.

## Layout

As a general principle refer to the subclasses of`SpExecutableLayout`.

`defaultSpec` or a method containing the pragma `<spec: #default>` must be defined in the class side of my subclasses.
It contains information about how visually position its elements.
It possible to define more than one method to give the possibility to use another layout, by default the one containing the pragma will be used if it exists, if not `defaultSpec` will be used.

Developer may also want to define instance level layouts. A good idiom is the following one:

```
SpMyPresenter >> initializePresenters
	... instantiate presenters ...
	self initializeLayout
```

```
SpMyPresenter >> initializeLayout
	self layout: (SpXXLayout new add: ...; yourself)
```



!
!SpPresenter methodsFor: 'scripting - layouts' stamp: ''!
newGridLayout

	^ SpGridLayout new! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
askOkToClose
	"DO NOT USE
	With Spec 2, SpPresenter was refactored to move all window management to WindowPresenter.
	From now on, if you want to interact with a window you need to:
	- Implement #initializeWindow: method (#initializeDialog: for dialogs) to manage window elements before the presenter is opened
	- Use the method #window or #withWindowDo: to interact with windows after it has been opened.
	
	This method cannot be deprecated because during a transition phase we keep this mecanism. "

	^ askOkToClose! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
locale 

	^ self application locale! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newCheckBox
	^ self instantiate: SpCheckBoxPresenter! !

!SpPresenter methodsFor: 'api' stamp: ''!
addStyle: aName
	"Add a style-class to a presenter. Styles are defined in the application stylesheet and will 
	 affect presenters by applying the properties the user adds to the class.
	 Styles can be added and removed dynamically (see `SpPresenter>>#removeStyle:`)
	
	```language=Smalltalk
	button := self newButton 
		label: 'Example of style';
		addStyle: 'myButton';
		yourself.
	```"

	(styles includes: aName) ifTrue: [ ^ self ].
	styles := styles copyWith: aName.
	self withAdapterDo: [ :anAdapter | anAdapter addStyle: aName ]! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newButtonBar

	^ self instantiate: SpButtonBarPresenter! !

!SpPresenter methodsFor: 'private - traversing' stamp: ''!
traversePresentersDo: aBlock

	self 
		traversePresentersDo: aBlock 
		excluding: Set new! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newNotebookPage

	self flag: #TODO. "NotebookPage needs to be a Presenter?"
	^ SpNotebookPage new! !

!SpPresenter methodsFor: 'private - initialization' stamp: ''!
initializePrivateAnnouncer

  announcer := Announcer new! !

!SpPresenter methodsFor: 'api' stamp: ''!
hide
	"hide current presenter making it invisible for the user"

	visible := false! !

!SpPresenter methodsFor: 'api - events' stamp: ''!
whenVisibleChangedDo: aBlock
	"Inform when visible property have been changed (See `SpPresenter>>#show` and `SpPresenter>>#hide`).
	 `aBlock` receives two optional arguments 
	 - new visible status (a Boolean)
	 - old visible status (a Boolean)"
	
	self property: #visible whenChangedDo: aBlock! !

!SpPresenter methodsFor: 'private' stamp: ''!
okToChange

	^ self hasWindow
		ifTrue: [ self window okToChange ]
		ifFalse: [ true ] ! !

!SpPresenter methodsFor: 'specs' stamp: ''!
defaultSpec

	^ self class perform: self defaultSpecSelector! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
windowIcon
	"DO NOT USE
	With Spec 2, SpPresenter was refactored to move all window management to WindowPresenter.
	From now on, if you want to interact with a window you need to:
	- Implement #initializeWindow: method (#initializeDialog: for dialogs) to manage window elements before the presenter is opened
	- Use the method #window or #withWindowDo: to interact with windows after it has been opened.
	
	This method cannot be deprecated because during a transition phase we keep this mecanism. "

	^ windowIcon! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
additionalSubpresentersMap

	"additionalSubpresentersMap serves for storing of sub-presenters that are not
	stored in instance variables"
	
	self flag: #TOREMOVE. "This is now provided by TDynamicPresenter"
	^ additionalSubpresentersMap ifNil: [ additionalSubpresentersMap := Dictionary new ]! !

!SpPresenter methodsFor: 'api - shortcuts' stamp: ''!
removeKeyCombination: aShortcut
	"Remove the action associated to `aShortcut`"

	self contextKeyBindings removeKey: aShortcut ifAbsent: [ ^ self ].
	self withAdapterDo: [ :anAdapter | 
		anAdapter removeKeyCombination: aShortcut ]! !

!SpPresenter methodsFor: 'private' stamp: ''!
announceDisplayed
	"When using a VersatileDialogPresenter the adapter is nil.
	We do not know if that is a correct behaviour"

	self announcer
		announce:
			(SpWidgetDisplayed new
				presenter: self;
				widget: (adapter ifNotNil: [ adapter widget ]);
				yourself)! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newProgressBar
	^ self instantiate: SpProgressBarPresenter! !

!SpPresenter methodsFor: 'testing' stamp: ''!
isVisible
	"Answer when the presenter is visible. 
	 See `SpPresenter>>#show` and `SpPresenter>>#hide`."
	
	^ visible value! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newActionBar

	^ self instantiate: SpActionBarPresenter! !

!SpPresenter methodsFor: 'private' stamp: ''!
rebuildLayout

	self replaceLayoutWith: self layout! !

!SpPresenter methodsFor: 'private - traversing' stamp: ''!
traverseInFocusOrderDo: aBlock excluding: excludes

	"(excludes includes: self) ifTrue: [ ^ self ]. 
	excludes add: self.
	aBlock value: self."
	self presentersInFocusOrder do: [ :each |
		each traverseInFocusOrderDo: aBlock excluding: excludes ]! !

!SpPresenter methodsFor: 'private' stamp: ''!
delete

	self withWindowDo: #delete! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newPresenter

	^ self instantiate: SpPresenter! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newDropList
	^ self instantiate: SpDropListPresenter! !

!SpPresenter methodsFor: '*Spec2-Morphic' stamp: ''!
newImage
	^ self instantiate: SpImagePresenter! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newPresenterWith: aBlock
	| presenter |

	presenter := self instantiate: SpPresenter.
	aBlock value: aBlock.

	^ presenter! !

!SpPresenter methodsFor: 'inspector-extensions' stamp: ''!
inspectionSubPresentersContext: aContext
	
	aContext active: self presenters notEmpty! !

!SpPresenter methodsFor: 'private - traversing' stamp: ''!
presentersDo: aBlock

	self layout ifNil: [ ^ self ].
	self layout allPresenters do: [ :each |
		aBlock value: (each asPresenterOn: self) ]! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newNotebook

	^ self instantiate: SpNotebookPresenter! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newToolbar

	^ self instantiate: SpToolbarPresenter! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
extent
	^ extent! !

!SpPresenter methodsFor: 'api' stamp: ''!
show
	"show current presenter making it visible for the user"

	visible := true! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
whenWindowChanged: aBlock

	self flag: #TODO. "This is here for backwards compatibility (you can have same 
	functionality in #initializeWindow:"
	self announcer 
		when: SpWindowBuilt 
		do: [ :ann | aBlock cull: ann model ]! !

!SpPresenter methodsFor: 'private' stamp: ''!
allPresentersInFocusOrder

	^ Array streamContents: [ :stream |
		self traverseInFocusOrderDo: [ :each |
			stream << each  ] ]! !

!SpPresenter methodsFor: 'inspector-extensions' stamp: ''!
inspectionSubPresenters
	<inspectorPresentationOrder: 910 title: 'Subpresenters'>
	
	^ SpTreePresenter new
		roots: self presenters;
		children: [ :each | each presenters ];
		expandRoots;
		yourself! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newTree

	^ self instantiate: SpTreePresenter! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
focusOrder: anObject
	^ focusOrder := anObject! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
visibleIf: aValuable

	visible := aValuable! !

!SpPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	"The method initializePresenters instantiates, saves in instance vari- ables, and partially configures the different widgets that will be part of the UI.
	In general the initializePresenters method should follow the pattern:
		• widget instantiation
		• widget configuration specification
		• specification of focus order"

	"self subclassResponsibility"! !

!SpPresenter methodsFor: '*Spec2-Interactions' stamp: ''!
confirm: queryString label: titleString
	
	^ (self application newConfirm 
		title: titleString;
		message: queryString;
		openModalWithSpec)
		isOk! !

!SpPresenter methodsFor: 'testing' stamp: ''!
isDisplayed
	"Answer if the widget is currently displayed on screen"
	
	^ self hasWindow 
		ifTrue: [ self root isDisplayed ]
		ifFalse: [ false ]! !

!SpPresenter methodsFor: 'api - shortcuts' stamp: ''!
bindKeyCombination: aShortcut toAction: aBlock
	"Adds a single shortcut to the list of `SpPresenter>>#contextKeyBindings`. Action `aBlock` 
	 will be executed when presenter the key combination is presseed.
	 - `aShortcut` is an instance of `KMKeyCombination`
	 - `aBlock` receive zero arguments."

	contextKeyBindings ifNil: [ contextKeyBindings := KMCategory new ].
	contextKeyBindings addKeymapEntry: (KMKeymap
		shortcut: aShortcut
		action: aBlock).
	self withAdapterDo: [ :anAdapter | 
		anAdapter bindKeyCombination: aShortcut toAction: aBlock ]! !

!SpPresenter methodsFor: 'initialization - deprecated' stamp: ''!
initializeWidgets
	"Now, presenters should implement #initializePresenters instead."! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newDynamicPresentersListIn: accessorSymbol usingBuilder: aDynamicPresentersListBuilder
	|mutatorSymbol newDynamicPresenter |
	mutatorSymbol := (accessorSymbol , ':') asSymbol.
	(self perform: accessorSymbol)
		ifNotNil: [ :dynamicPresenter | dynamicPresenter owner: nil ].
	newDynamicPresenter := aDynamicPresentersListBuilder build.
	
	self perform: mutatorSymbol with: newDynamicPresenter.
	
	newDynamicPresenter owner: self.
	
	self needRebuild: false.
	self buildWithSpec! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newLabel
	^ self instantiate: SpLabelPresenter! !

!SpPresenter methodsFor: 'scripting - layouts' stamp: ''!
newScrollableLayout

	^ SpScrollableLayout new! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
requestWindowClose

	"returns <true> if the user is allowed to close the window. Useful if you want to ask user if he wants to save the changed content etc."
	
	^ true! !

!SpPresenter methodsFor: 'api - events' stamp: ''!
whenDisplayDo: aBlock
	"Inform when presenter has been displayed.
	 `aBlock` receives one argument 
	 - an announcement (instance of `SpWidgetDisplayed`)"

	self announcer when: SpWidgetDisplayed do: aBlock! !

!SpPresenter methodsFor: 'testing' stamp: ''!
canTakeKeyboardFocus
	"Answer when the presenter can take keyboard focus."

	^ true! !

!SpPresenter methodsFor: 'private - building' stamp: ''!
basicBuildAdapterWithSpecLayout: aSpecLayout

	layout == aSpecLayout 
		ifFalse: [ layout := aSpecLayout ].
	^ super basicBuildAdapterWithSpecLayout: aSpecLayout! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
iconNamed: aSymbol

	^ self application iconNamed: aSymbol! !

!SpPresenter methodsFor: '*Spec2-Morphic' stamp: ''!
asWorldWindow

	^ SpWorldPresenter presenter: self! !

!SpPresenter methodsFor: 'scripting - layouts' stamp: ''!
newPanedLayoutLeftToRight

	^ SpPanedLayout newLeftToRight! !

!SpPresenter methodsFor: 'private - initialization' stamp: ''!
initializePrivateValueHolders

	askOkToClose := false.
	titleHolder := self class title! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newTable

	^ self instantiate: SpTablePresenter! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
focusOrder

	^ focusOrder ifNil: [ focusOrder := OrderedCollection new ].! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newToolbarMenuButton

	^ self instantiate: SpToolbarMenuButtonPresenter! !

!SpPresenter methodsFor: 'instance creation' stamp: ''!
instantiatePresenters: aCollectionOfPairs
	"instantiatePresenters: is legacy code in SpPresenter and must not be used. It will be deprecated and removed."

	"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) ] ]! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newToggleButton

	^ self instantiate: SpToggleButtonPresenter! !

!SpPresenter methodsFor: 'private - traversing' stamp: ''!
presenters

	^ Array streamContents: [ :stream |
		self presentersDo: [ :each | 
			stream << each ] ]! !

!SpPresenter methodsFor: '*NewTools-Core' stamp: ''!
addWindowShortcutsTo: aWindowPresenter
	"override this method to add window shortcuts defined in an inner presenter. 
	 (for example, see *class:StHeaderPanel* who adds a shortcut to access the 
	 contained presenter"! !

!SpPresenter methodsFor: 'testing' stamp: ''!
isBuilt
	"Answer if this presenter has been built."

	^ self isDisplayed! !

!SpPresenter methodsFor: 'scripting - layouts' stamp: ''!
newOverlayLayout

	^ SpOverlayLayout new! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newSpinner

	^ self instantiate: SpSpinnerPresenter! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName
	"Retrieves a subpresenter of this composed presenter."

	^ self readSlotNamed: aName! !

!SpPresenter methodsFor: 'private' stamp: ''!
resolveSymbol: aSymbol

	^ Smalltalk at: aSymbol! !

!SpPresenter methodsFor: '*Spec2-Interactions' stamp: ''!
request: request initialAnswer: initialAnwser title: title
	| answer |
	
	answer := self application newRequest
		title: title;
		label: request;
		text: initialAnwser;
		openModalWithSpec.
					
	answer ifNil: [ SpCancelledInteractionError signal ].
	
	^ answer! !

!SpPresenter methodsFor: '*Spec2-Commander2' stamp: ''!
rootCommandsGroup

	^ SpRecursiveContextSetter 
		visit: (self class buildRootCommandsGroupFor: self defaultCommandsContext) 
		toSetContext: self defaultCommandsContext! !

!SpPresenter methodsFor: 'private' stamp: ''!
replaceLayoutWith: aLayout

	self withAdapterDo: [ :anAdapter |
		anAdapter replaceLayoutWith: aLayout ]! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newPresenterSelector

	^ self instantiate: SpPresenterSelectorPresenter! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
aboutText
	"DO NOT USE
	With Spec 2, SpPresenter was refactored to move all window management to WindowPresenter.
	From now on, if you want to interact with a window you need to:
	- Implement #initializeWindow: method (#initializeDialog: for dialogs) to manage window elements before the presenter is opened
	- Use the method #window or #withWindowDo: to interact with windows after it has been opened.
	
	This method cannot be deprecated because during a transition phase we keep this mecanism. "

	^ aboutText! !

!SpPresenter methodsFor: 'private' stamp: ''!
applyKeyBindingsFromMenu: aMenuPresenter
	"traverses aMenuPresenter and bind shortcuts associated "

	aMenuPresenter menuGroups do: [ :group |
		group menuItems do: [ :item |
			item shortcut ifNotNil: [ :shortcut | 
				self 
					bindKeyCombination: shortcut 
					toAction: [ item performMenuActionWith: #() ] ].
			item subMenu ifNotNil: [ :subMenu | subMenu addKeybindingsTo: self	] ] ]! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
defer: aBlock

	self application defer: aBlock! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newText
	^ self instantiate: SpTextPresenter! !

!SpPresenter methodsFor: 'scripting - layouts' stamp: ''!
newBoxLayoutTopToBottom

	^ SpBoxLayout newTopToBottom! !

!SpPresenter methodsFor: 'api - focus' stamp: ''!
focusedPresenter
	"Answer the focused presenter if any (nil if no presenter is focused)"

	^ self allPresentersInFocusOrder
		detect: [ :each | each hasKeyboardFocus ]
		ifNone: [ nil ]! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newList
	^ self instantiate: SpListPresenter! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName ifAbsent: aBlock
	"Retrieves a subpresenter of this composed presenter."

	^ [ self readSlotNamed: aName ]
		on: SlotNotFound
		do: aBlock! !

!SpPresenter methodsFor: 'localization' stamp: ''!
localeChanged

	"do nothing here. Override me in subclasses to update strings presented to the users"
	! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newNullPresenter
	^ self instantiate: SpNullPresenter! !

!SpPresenter methodsFor: 'private - initialization' stamp: ''!
initializePrivateAnnouncements

	self 
		property: #titleHolder 
		whenChangedDo: [ self withWindowDo: [ :w | w title: titleHolder ] ].
	self 
		property: #layout 
		whenChangedDo: [ :newLayout | self replaceLayoutWith: newLayout ]! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newMenuBar
	^ self instantiate: SpMenuBarPresenter! !

!SpPresenter methodsFor: '*NewTools-Inspector' stamp: ''!
asInspection

	^ StPresenterInspection for: self! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newButton
	^ self instantiate: SpButtonPresenter! !

!SpPresenter methodsFor: 'testing' stamp: ''!
isRoot
	"Answer if this presenter is the root of the presenter hierarchy.
	 To be root, the presenter has to be contained in a window"

	self withWindowDo: [ :w |
		^ w presenter = self ].

	^ false! !

!SpPresenter methodsFor: 'private - initialization' stamp: ''!
initializePrivateHooks
	self flag: #todo. "We should remove later #initializeWidgets and #initializePresenter."
	self initializeWidgets.
	self initializePresenters.
	self initializePresenter.
	self connectPresenters.
	self updatePresenter.
! !

!SpPresenter methodsFor: 'initialization' stamp: ''!
updatePresenter! !

!SpPresenter methodsFor: 'api - shortcuts' stamp: ''!
contextKeyBindings: aKMCategory
	"Set the context keybindings for this presenter."
	
	contextKeyBindings := aKMCategory! !

!SpPresenter methodsFor: 'scripting - layouts' stamp: ''!
newPanedLayoutTopToBottom

	^ SpPanedLayout newTopToBottom! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
announce: anAnnouncement

	self announcer announce: anAnnouncement! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newComponentList
	^ self instantiate: SpComponentListPresenter! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newStatusBar

	^ self instantiate: SpStatusBarPresenter! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newMenuButton

	^ self instantiate: SpMenuButtonPresenter! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newToolbarButton

	^ self instantiate: SpToolbarButtonPresenter! !

!SpPresenter methodsFor: '*Spec2-Morphic' stamp: ''!
newMorph

	^ self instantiate: SpMorphPresenter! !

!SpPresenter methodsFor: 'api - focus' stamp: ''!
hasKeyboardFocus
	"Answer true if this presenter has the active keyboard focus."

	self canTakeKeyboardFocus ifFalse: [ ^ false ].
	self withAdapterDo: [ :anAdapter | ^ anAdapter hasKeyboardFocus ].
	^ false! !

!SpPresenter methodsFor: '*Spec2-Morphic' stamp: ''!
newLink
	^ self instantiate: SpLinkPresenter! !

!SpPresenter methodsFor: 'instance creation' stamp: ''!
instantiate: aPresenterClass
	"Instantiate a SpPresenter subclass and set its instance owner"

	^ aPresenterClass owner: self! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newAthens

	^ self instantiate: SpAthensPresenter! !

!SpPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	visible := true.
	styles := #().

	self initializePrivateAnnouncer.
	self initializePrivateValueHolders.
	self initializePrivateHooks.
	self initializePrivateAnnouncements! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
initialExtent
	
	"DO NOT USE
	With Spec 2, SpPresenter was refactored to move all window management to WindowPresenter.
	From now on, if you want to interact with a window you need to:
	- Implement #initializeWindow: method (#initializeDialog: for dialogs) to manage window elements before the presenter is opened
	- Use the method #window or #withWindowDo: to interact with windows after it has been opened.
	
	This method cannot be deprecated because during a transition phase we keep this mecanism. "
	^ nil! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
toolName

	^ self class toolName! !

!SpPresenter methodsFor: 'private' stamp: ''!
addAll: aWindow withSpecLayout: aSpec

	aWindow
		addMorph: (self buildWithSpecLayout: aSpec)
		frame: (0@0 corner: 1@1).! !

!SpPresenter methodsFor: 'api - focus' stamp: ''!
takeKeyboardFocus
	"Causes this presenter to have the keyboard focus for the window it's inside. The presenter must 
	 be focusable (it has to answer true to `SpPresenter>>#canTakeKeyboardFocus`."
	| focus |

	focus := self defaultKeyboardFocus ifNil: [ self ].
	focus == self ifFalse: [ ^ focus takeKeyboardFocus ].
	
	self withAdapterDo: [ :anAdapter | 
		anAdapter takeKeyboardFocus ]! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
application: anApplication

	application := anApplication! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
cancelled
	self flag: #TODO. "just for dialogs... I wonder if we need it here?"

	self withWindowDo: #cancelled! !

!SpPresenter methodsFor: 'private' stamp: ''!
layoutPresenters

	layout ifNil: [ ^ self presenters ].
	
	^ layout allPresenters
		select: [ :each | each isSymbol or: [ each isPresenter ] ]
		thenCollect: [ :each | 
			each isPresenter 
				ifTrue: [ each ]
				ifFalse:[ self presenterAt: each ] ]! !

!SpPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters
	"The method connectPresenters defines the interactions between the different widgets. By connecting the behaviors of the different widgets it specifies the overall presentation, i.e., how the overall UI responds to interactions by the user. Usually this method consists of specifications of actions to perform when a certain event is received by a widget. The whole interaction flow of the UI then emerges from the propagation of those events."! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newRadioButton
	^ self instantiate: SpRadioButtonPresenter! !

!SpPresenter methodsFor: 'api - shortcuts' stamp: ''!
contextKeyBindings
	"Answer contextKeyBindings stores a KMCategory with keybindings for this presenter. 
	 Note that not all presenters can have key bindings, just the ones that can take the 
	 keyboard focus. 
	 Also, all user defined presenters can have context key bindings."

	^ contextKeyBindings! !

!SpPresenter methodsFor: 'private - traversing' stamp: ''!
allPresenters

	^ Array streamContents: [ :stream |
		self traversePresentersDo: [ :each | 
			stream << each ] ]! !

!SpPresenter methodsFor: '*Spec2-CommonWidgets' stamp: ''!
newFilteringList

	^ self instantiate: SpFilteringListPresenter! !

!SpPresenter methodsFor: 'api' stamp: ''!
styles 
	"Answer the collection of styles to be applied to this presenter"

	^ styles! !

!SpPresenter methodsFor: 'api' stamp: ''!
layout: aLayout
	"Set the layout for current presenter. 
	 See `SpExecutableLayout` hierarchy for details on what can be set as layout."

	layout := aLayout! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
update

	"self deprecated: 'This method is a remaining from ancient times and should not be used, 
	while it works on morphic backend in certain cases, it will not translate correctly and 
	it will cause memory leaks'.  "
	self needRebuild: false.
	self buildWithSpec! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newToolbarToggleButton

	^ self instantiate: SpToolbarToggleButtonPresenter! !

!SpPresenter methodsFor: '*Spec2-Commander2' stamp: ''!
defaultCommandsContext
	"The default context set to commands is the presenter itself.
	 This method might be overriden to change this behaviour.
	"
	^ self! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newMenu
	^ self instantiate: SpMenuPresenter! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newTextInput
	^ self instantiate: SpTextInputFieldPresenter! !

!SpPresenter methodsFor: 'api - focus' stamp: ''!
defaultKeyboardFocus
	"Answer the presentar that will act as default responder when showing this presenter or 
	 receive the `SpPresenter>>#takeKeyboardFocus` message. By default, this answers self, 
	 but it can be overriden to place the focus somewhere else"

	^ self! !

!SpPresenter methodsFor: 'private - building' stamp: ''!
retrieveSpec: aSelector

	self layout ifNotNil: [ ^ self layout ].
	^ super retrieveSpec: aSelector! !

!SpPresenter methodsFor: '*Spec2-Code' stamp: ''!
newCode

	^ self instantiate: SpCodePresenter! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
on: anAnnouncement send: aSelector to: aTarget

	self announcer
		when: anAnnouncement 
		send: aSelector 
		to: aTarget! !

!SpPresenter methodsFor: 'accessing - model' stamp: ''!
setModel: aDomainObject

! !

!SpPresenter methodsFor: 'private - traversing' stamp: ''!
traverseInFocusOrderDo: aBlock

	self 
		traverseInFocusOrderDo: aBlock 
		excluding: Set new! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newDiff
	^ self instantiate: SpDiffPresenter! !

!SpPresenter methodsFor: 'converting' stamp: ''!
asPresenterOn: aPresenter
	"This allows to use presenter instances inside layouts directly"

	^ self! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newSearchInput

	^ self instantiate: SpSearchInputFieldPresenter! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newToolbarPopoverButton

	^ self instantiate: SpToolbarPopoverButtonPresenter! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
enabled: aBoolean

	self presentersDo: [ :each | 
		each enabled: aBoolean ]! !

!SpPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aDomainObject

! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
extent: aPoint
	^ extent := aPoint! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
title
	"DO NOT USE
	With Spec 2, SpPresenter was refactored to move all window management to WindowPresenter.
	From now on, if you want to interact with a window you need to:
	- Implement #initializeWindow: method (#initializeDialog: for dialogs) to manage window elements before the presenter is opened
	- Use the method #window or #withWindowDo: to interact with windows after it has been opened.
	
	This method cannot be deprecated because during a transition phase we keep this mecanism. "

	^ titleHolder! !

!SpPresenter methodsFor: 'scripting - layouts' stamp: ''!
newBoxLayoutLeftToRight

	^ SpBoxLayout newLeftToRight! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newPopover

	^ self instantiate: SpPopoverPresenter! !

!SpPresenter methodsFor: 'instance creation' stamp: ''!
instantiate: aPresenterClass on: aModel
	"Instantiate a SpPresenter subclass and set its instance owner and model"

	^ aPresenterClass owner: self on: aModel! !

!SpPresenter methodsFor: 'private' stamp: ''!
createInstanceFor: aClassSymbol
	"Retrieve the class corresponding to aClassSymbol using the bindings, then create a new instance of this class"

	| class |
	class := self resolveSymbol: aClassSymbol.
	^ self instantiate: class.! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
application

	^ self hasOwner 
		ifTrue: [ self owner application ]
		ifFalse: [
			application ifNil: [ 
				self flag: #TODO. "This is incorrect, no component who is also a root
				(it does not has owner) should not have an application. But in older times
				it was not like that and to support such components we assign them to a 
				default application"
				application := SpApplication defaultApplication ] ]! !

!SpPresenter methodsFor: 'accessing' stamp: ''!
layout

	^ layout! !

!SpPresenter methodsFor: 'private' stamp: ''!
presentersInFocusOrder

	^ focusOrder ifNil: [ 
		self layoutPresenters
			select: [ :each | each isVisible and: [ each canTakeKeyboardFocus ] ] ]! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newNumberInput
	^ self instantiate: SpNumberInputFieldPresenter! !

!SpPresenter methodsFor: 'TOREMOVE' stamp: ''!
centered

	self withWindowDo: #centered! !

!SpPresenter methodsFor: 'converting' stamp: ''!
asPresenter
	"This allows to use presenter instances inside layouts directly"

	^ self! !

!SpPresenter methodsFor: 'private - traversing' stamp: ''!
traversePresentersDo: aBlock excluding: excludes

	(excludes includes: self) ifTrue: [ ^ self ]. 
	excludes add: self.
	aBlock value: self.

	self layout ifNil: [ ^ self ].
	self layout allPresenters do: [ :each | | var |
		var := each asPresenterOn: self. 
		var traversePresentersDo: aBlock excluding: excludes ]! !

!SpPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	"override this to set window values before opening. 
	 You may want to add a menu, a toolbar or a statusbar"

	"IMPORTANT: Please ovirride this method and set yourself the informations you want in your window.
	The content of this method is here to help the transition between Spec 1 and 2.
	In the next Spec version the content of this method will be removed and it will do nothing by default because the goal is to remove the management of all of those informations from Composable to put them in WindowPresenter."

	aWindowPresenter
		title: self title;
		initialExtent: self initialExtent;
		windowIcon: self windowIcon! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newSlider
	^ self instantiate: SpSliderPresenter! !

!SpPresenter methodsFor: 'api - events' stamp: ''!
whenContextKeyBindingsChangedDo: aBlock
	"Inform when context keybindings have been changed (See `SpPresenter>>#contextKeyBindings:`).
	 `aBlock` receives two optional arguments 
	 - new keybinginds KMCategory
	 - old keybinginds KMCategory"
	
	self property: #contextKeyBindings whenChangedDo: aBlock! !

!SpPresenter methodsFor: 'api' stamp: ''!
removeStyle: aName
	"Remove style from presenter.
	 See `SpPresenter>>#removeStyle:`"

	(styles includes: aName) ifFalse: [ ^ self ].
	styles := styles copyWithout: aName.
	self withAdapterDo: [ :anAdapter | anAdapter removeStyle: aName ]! !

!SpPresenter methodsFor: 'scripting - widgets' stamp: ''!
newTreeTable

	^ self instantiate: SpTreeTablePresenter! !

!SpPresenter methodsFor: 'initialization - deprecated' stamp: ''!
initializePresenter
	"Now, presenters should implement #connectPresenters instead."
	"Obsolete. Do not use me, use connectPresenters"
	self 
		property: #extent 
		whenChangedDo: [ :ex | 
			self withAdapterDo: [ :widget | 
				(widget respondsTo: #extent:) 
					ifTrue: [ widget extent: ex ] ] ]! !

!SpPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	"Override to initialize the layout in a non-dynamic way"

	^ nil! !

!SpPresenter class methodsFor: 'accessing' stamp: ''!
currentApplication 

	^ SpApplication defaultApplication! !

!SpPresenter class methodsFor: 'instance creation' stamp: ''!
newApplication: anApplication owner: anOwningPresenter model: aDomainObject

	^ self basicNew
		application: anApplication;
		owner: anOwningPresenter;
		setModelBeforeInitialization: aDomainObject;
		initialize;
		yourself! !

!SpPresenter class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpPresenter! !

!SpPresenter class methodsFor: '*Spec2-Commander2' stamp: ''!
buildRootCommandsGroupFor: aPresenter
	| rootCommandGroup |
	
	rootCommandGroup := CmCommandGroup forSpec beRoot.
	"Register default commands."
	self buildCommandsGroupWith: aPresenter forRoot: rootCommandGroup.
	"Register extension commands."
	self buildExtensionCommandsWith: aPresenter forRoot: rootCommandGroup.
	
	^ rootCommandGroup! !

!SpPresenter class methodsFor: 'instance creation' stamp: ''!
newApplication: anApplication

	^ self basicNew
		application: anApplication;
		initialize;
		yourself! !

!SpPresenter class methodsFor: 'labeled-presenters' stamp: ''!
iconWidth
	^ 24! !

!SpPresenter class methodsFor: '*Spec2-Commander2' stamp: ''!
buildExtensionCommandsWith: aPresenter forRoot: rootCommandGroup
	
	(Pragma allNamed: #extensionCommands in: self class) do: [ :pragma | 
		(self 
			perform: pragma methodSelector 
			withArguments: { aPresenter . rootCommandGroup }) ]! !

!SpPresenter class methodsFor: '*Spec2-Commander2' stamp: ''!
buildCommandsGroupWith: presenter forRoot: aCmCommandsGroup
	"This hook allows you to build your groups of commands.
	 You must attach them to aLtCommandsGroup throught the registration mechanism.
	 The presenter instance to which this group of command will be bound is provided (this is useful for setting commands context).
	 To be overrided by subclasses.
	"! !

!SpPresenter class methodsFor: 'instance creation' stamp: ''!
newApplication: anApplication model: aModel

	^ self basicNew
		application: anApplication;
		setModelBeforeInitialization: aModel;
		initialize;
		yourself! !

!SpPresenter class methodsFor: 'instance creation' stamp: ''!
owner: anOwningPresenter on: aDomainObject

	^ self basicNew
		owner: anOwningPresenter;
		setModelBeforeInitialization: aDomainObject;
		initialize;
		yourself! !

!SpPresenter class methodsFor: 'specs' stamp: ''!
title
	
	^ 'Untitled window'! !

!SpPresenter class methodsFor: 'instance creation' stamp: ''!
newApplication: anApplication owner: anOwningPresenter

	^ self basicNew
		application: anApplication;
		owner: anOwningPresenter;
		initialize;
		yourself! !

!SpPresenter class methodsFor: 'labeled-presenters' stamp: ''!
labelWidth
	^ 100! !

!SpPresenter class methodsFor: 'instance creation' stamp: ''!
on: aDomainObject

	^ self 
		newApplication: self currentApplication
		model: aDomainObject ! !

!SpPresenterBuildTest methodsFor: 'tests' stamp: ''!
testBuildPresenterWillSetPresenterProperty
	| presenter |
	
	presenter := SpPresenter new layout: SpBoxLayout newVertical; yourself.
	presenter buildWithSpec.
	self 
		assert: presenter adapter widget presenter
		equals: presenter.

	presenter := SpPresenter new layout: SpPanedLayout newVertical; yourself.
	presenter buildWithSpec.
	self 
		assert: presenter adapter widget presenter
		equals: presenter.

	presenter := SpPresenter new layout: SpGridLayout new; yourself.
	presenter buildWithSpec.
	self 
		assert: presenter adapter widget presenter
		equals: presenter! !

!SpPresenterBuildTest methodsFor: 'tests' stamp: ''!
testBuildWidgetPresenterWillSetPresenterProperty
	| package |

	package := RPackageOrganizer default packageNamed: 'Spec2-Core'.
	SpAbstractWidgetPresenter allSubclasses 
		select: [ :each | 
			(each package = package) 
			and: [ each isAbstract not 
			and: [ each isWindow not ] ] ]
		thenDo: [ :aClass | | presenter | 
			presenter := aClass sampleInstanceForTest.
			presenter buildWithSpec.
			presenter adapter widget isMorph ifTrue: [  
				self 
					assert: presenter adapter widget presenter
					equals: presenter ] ]! !

!SpPresenterBuilder commentStamp: ''!
A simple presenter builder class that uses `SpTPresenterBuilder`. 
It allows users to compose presenters without hardcoding class name.

The following two lines are equivalent and the second one is preferred for common presenters.

```
list := self instantiate: SpListPresenter
list := self newList.
```!
!SpPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newGridLayout

	^ SpGridLayout new! !

!SpPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newBoxLayoutTopToBottom

	^ SpBoxLayout newTopToBottom! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newList
	^ self instantiate: SpListPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newCheckBox
	^ self instantiate: SpCheckBoxPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newButtonBar

	^ self instantiate: SpButtonBarPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newNullPresenter
	^ self instantiate: SpNullPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newMenuBar
	^ self instantiate: SpMenuBarPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newNotebookPage

	self flag: #TODO. "NotebookPage needs to be a Presenter?"
	^ SpNotebookPage new! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newButton
	^ self instantiate: SpButtonPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newPanedLayoutTopToBottom

	^ SpPanedLayout newTopToBottom! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newComponentList
	^ self instantiate: SpComponentListPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newStatusBar

	^ self instantiate: SpStatusBarPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newMenuButton

	^ self instantiate: SpMenuButtonPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToolbarButton

	^ self instantiate: SpToolbarButtonPresenter! !

!SpPresenterBuilder methodsFor: '*Spec2-Morphic' stamp: ''!
newMorph

	^ self instantiate: SpMorphPresenter! !

!SpPresenterBuilder methodsFor: '*Spec2-Morphic' stamp: ''!
newLink
	^ self instantiate: SpLinkPresenter! !

!SpPresenterBuilder methodsFor: 'instance creation' stamp: ''!
instantiate: aPresenterClass
	"Instantiate a SpPresenter subclass and set its instance owner"
	
	^ aPresenterClass new! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newAthens

	^ self instantiate: SpAthensPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newProgressBar
	^ self instantiate: SpProgressBarPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newActionBar

	^ self instantiate: SpActionBarPresenter! !

!SpPresenterBuilder methodsFor: '*Spec2-Morphic' stamp: ''!
newImage
	^ self instantiate: SpImagePresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newPresenter

	^ self instantiate: SpPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newDropList
	^ self instantiate: SpDropListPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newPresenterWith: aBlock
	| presenter |

	presenter := self instantiate: SpPresenter.
	aBlock value: aBlock.

	^ presenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newNotebook

	^ self instantiate: SpNotebookPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToolbar

	^ self instantiate: SpToolbarPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newTree

	^ self instantiate: SpTreePresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newRadioButton
	^ self instantiate: SpRadioButtonPresenter! !

!SpPresenterBuilder methodsFor: '*Spec2-CommonWidgets' stamp: ''!
newFilteringList

	^ self instantiate: SpFilteringListPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newDynamicPresentersListIn: accessorSymbol usingBuilder: aDynamicPresentersListBuilder
	|mutatorSymbol newDynamicPresenter |
	mutatorSymbol := (accessorSymbol , ':') asSymbol.
	(self perform: accessorSymbol)
		ifNotNil: [ :dynamicPresenter | dynamicPresenter owner: nil ].
	newDynamicPresenter := aDynamicPresentersListBuilder build.
	
	self perform: mutatorSymbol with: newDynamicPresenter.
	
	newDynamicPresenter owner: self.
	
	self needRebuild: false.
	self buildWithSpec! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newLabel
	^ self instantiate: SpLabelPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToolbarToggleButton

	^ self instantiate: SpToolbarToggleButtonPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newScrollableLayout

	^ SpScrollableLayout new! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newMenu
	^ self instantiate: SpMenuPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newTextInput
	^ self instantiate: SpTextInputFieldPresenter! !

!SpPresenterBuilder methodsFor: '*Spec2-Code' stamp: ''!
newCode

	^ self instantiate: SpCodePresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newDiff
	^ self instantiate: SpDiffPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newSearchInput

	^ self instantiate: SpSearchInputFieldPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToolbarPopoverButton

	^ self instantiate: SpToolbarPopoverButtonPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newPanedLayoutLeftToRight

	^ SpPanedLayout newLeftToRight! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newTable

	^ self instantiate: SpTablePresenter! !

!SpPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newBoxLayoutLeftToRight

	^ SpBoxLayout newLeftToRight! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newPopover

	^ self instantiate: SpPopoverPresenter! !

!SpPresenterBuilder methodsFor: 'instance creation' stamp: ''!
instantiate: aPresenterClass on: aModel
	"Instantiate a SpPresenter subclass and set its instance owner and model"

	^ aPresenterClass on: aModel! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToolbarMenuButton

	^ self instantiate: SpToolbarMenuButtonPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToggleButton

	^ self instantiate: SpToggleButtonPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newNumberInput
	^ self instantiate: SpNumberInputFieldPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newOverlayLayout

	^ SpOverlayLayout new! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newSpinner

	^ self instantiate: SpSpinnerPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newPresenterSelector

	^ self instantiate: SpPresenterSelectorPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newSlider
	^ self instantiate: SpSliderPresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newTreeTable

	^ self instantiate: SpTreeTablePresenter! !

!SpPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newText
	^ self instantiate: SpTextPresenter! !

!SpPresenterBuilder class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpPresenterBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpPresenterBuilder class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpPresenterBuilder class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpPresenterBuilder class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpPresenterBuilder class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpPresenterBuilder class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpPresenterBuilder class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpPresenterBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpPresenterBuilder class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpPresenterBuilder class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpPresenterBuilder class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpPresenterBuilder class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpPresenterBuilder class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpPresenterBuilder class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpPresenterBuilder class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpPresenterBuilder class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpPresenterBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpPresenterBuilder class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpPresenterBuilder class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpPresenterBuilder class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpPresenterBuilder class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpPresenterBuilder class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpPresenterBuilder class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpPresenterBuilder class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpPresenterBuilder class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpPresenterBuilder class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpPresenterBuilder class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpPresenterBuilder class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpPresenterFocusOrderTest methodsFor: 'private' stamp: ''!
focusedPresenter
	
	^ mock allPresentersInFocusOrder 
		detect: [ :each | each adapter widget hasKeyboardFocus ]
		ifNone: [ nil ]! !

!SpPresenterFocusOrderTest methodsFor: 'running' stamp: ''!
defaultWaitDuration
	^ 500 milliSecond! !

!SpPresenterFocusOrderTest methodsFor: 'utilities' stamp: ''!
waitUntilUIRedrawed
	"I wait until the UI has been redrawn. 
	I take care of selecting how to do it. 
	If I am in the CI I should defer a semaphore signal. 
	If I am running in the UI process I can directly execute a doOneCycle on the World.
	If I am in the CI the tests and the UI run in different process. So I should not do a #doOneCycle.
	If I do it, I am in a race condition!!"

	self isRunningInUIProcess
		ifTrue: [
			MorphicRenderLoop new doOneCycle.
			^ self ].

	self currentWorld defer: [ uiWaitingSemaphore ifNotNil: #signal ].
	uiWaitingSemaphore wait: self defaultWaitDuration! !

!SpPresenterFocusOrderTest methodsFor: 'emulating' stamp: ''!
pressTab

	self 
		keyDown: Character tab
		shift: false
		meta: false
		control: false
		option: false.
	self waitUntilUIRedrawed		! !

!SpPresenterFocusOrderTest methodsFor: 'running' stamp: ''!
tearDown

	mock ifNotNil: [ 
		mock hasWindow ifTrue: [ 
			mock window close ] ].
	
	super tearDown! !

!SpPresenterFocusOrderTest methodsFor: 'testing' stamp: ''!
isRunningInUIProcess
	^ UIManager default uiProcess == Processor activeProcess! !

!SpPresenterFocusOrderTest methodsFor: 'emulating' stamp: ''!
keyDown: keyCode shift: shiftBoolean meta: metaBoolean control: controlBoolean option: optionBoolean
	
	^ self 
		keyEvent: #keyDown
		code: keyCode 
		shift: shiftBoolean 
		meta: metaBoolean 
		control: controlBoolean 
		option: optionBoolean! !

!SpPresenterFocusOrderTest methodsFor: 'initialization' stamp: ''!
initializeSemaphore
	uiWaitingSemaphore := Semaphore new! !

!SpPresenterFocusOrderTest methodsFor: 'tests' stamp: ''!
testFocusRotationBackwards

	mock := SpMockFocusOrderPresenter new
		openWithSpec;
		yourself.
	
	"Focus first"
	self takeKeyboardFocus: mock.
	self assert: (mock presenterAt: #firstPresenter) equals: self focusedPresenter.
	"Focus third"
	self pressShiftTab.
	self assert: (mock presenterAt: #thirdPresenter) equals: self focusedPresenter.
	"Focus second"
	self pressShiftTab.
	self assert: (mock presenterAt: #secondPresenter) equals: self focusedPresenter.
	"Focus first again"
	self pressShiftTab.
	self assert: (mock presenterAt: #firstPresenter) equals: self focusedPresenter! !

!SpPresenterFocusOrderTest methodsFor: 'emulating' stamp: ''!
takeKeyboardFocus: aPresenter

	aPresenter takeKeyboardFocus.
	self waitUntilUIRedrawed! !

!SpPresenterFocusOrderTest methodsFor: 'emulating' stamp: ''!
keyEvent: type code: keyCode shift: shiftBoolean meta: metaBoolean control: controlBoolean option: optionBoolean
	| evt modifiers widget |
	
	widget := self focusedPresenter adapter widget.
	modifiers := 0.
	shiftBoolean ifTrue: [ modifiers := modifiers | 8 ].
	metaBoolean ifTrue: [ modifiers := modifiers |
		(Smalltalk os isWindows | Smalltalk os isUnix
			ifTrue: [ 2r00010000 ]
			ifFalse: [ 2r01000000 ]) ].
	controlBoolean ifTrue: [ modifiers := modifiers | 2r00010000 ].
	optionBoolean ifTrue: [ modifiers := modifiers |
		(Smalltalk os isWindows | Smalltalk os isUnix
			ifTrue: [ 2r01000000 ]
			ifFalse: [ 2r00100000 ]) ].
		
	evt := KeyboardEvent new
		setType: type
		buttons: modifiers
		position:  widget position + (1 @ 1)
		keyValue: keyCode
		charCode: keyCode
		hand: self currentWorld activeHand
		stamp: Time millisecondClockValue.

	evt key: (KeyboardKey fromCharacter: keyCode asCharacter).
	evt sentTo: widget.
	"Some time to allow things to happen?"
	10 milliSeconds wait! !

!SpPresenterFocusOrderTest methodsFor: 'tests' stamp: ''!
testTakeKeyboardFocus

	mock := SpMockFocusOrderPresenter new
		openWithSpec;
		yourself.
		
	"Focus first"
	self takeKeyboardFocus: mock.
	self assert: (mock presenterAt: #firstPresenter) equals: self focusedPresenter.
	"Focus second"
	self takeKeyboardFocus: (mock presenterAt: #secondPresenter).
	self deny: (mock presenterAt: #firstPresenter) equals: self focusedPresenter.
	self assert: (mock presenterAt: #secondPresenter) equals: self focusedPresenter.
	"Focus first again"
	self takeKeyboardFocus: (mock presenterAt: #firstPresenter).
	self assert: (mock presenterAt: #firstPresenter) equals: self focusedPresenter.
	self deny: (mock presenterAt: #secondPresenter)  equals: self focusedPresenter! !

!SpPresenterFocusOrderTest methodsFor: 'tests' stamp: ''!
testCustomFocusOrder

	mock := SpMockFocusOrderPresenter new.
	mock focusOrder 
		add: (mock thirdPresenter);
		add: (mock firstPresenter);
		add: (mock secondPresenter).
	mock openWithSpec.
	
	"Focus third"
	self takeKeyboardFocus: mock.
	self assert: (mock thirdPresenter) equals: self focusedPresenter.
	"Focus first"
	self pressTab.
	self assert: (mock firstPresenter) equals: self focusedPresenter.
	"Focus second"
	self pressTab.
	self assert: (mock secondPresenter) equals: self focusedPresenter.
	"Focus third again"
	self pressTab.
	self assert: (mock thirdPresenter) equals: self focusedPresenter! !

!SpPresenterFocusOrderTest methodsFor: 'emulating' stamp: ''!
pressShiftTab

	self 
		keyDown: Character tab
		shift: true
		meta: false
		control: false
		option: false.
	self waitUntilUIRedrawed		! !

!SpPresenterFocusOrderTest methodsFor: 'emulating' stamp: ''!
keyPressed: keyCode shift: shiftBoolean meta: metaBoolean control: controlBoolean option: optionBoolean
	
	^ self 
		keyEvent: #keystroke
		code: keyCode asciiValue
		shift: shiftBoolean 
		meta: metaBoolean 
		control: controlBoolean 
		option: optionBoolean! !

!SpPresenterFocusOrderTest methodsFor: 'tests' stamp: ''!
testFocusRotationForward

	mock := SpMockFocusOrderPresenter new
		openWithSpec;
		yourself.
		
	"Focus first"
	self takeKeyboardFocus: mock.
	self assert: (mock presenterAt: #firstPresenter) equals: self focusedPresenter.
	"Focus second"
	self pressTab.
	self assert: (mock presenterAt: #secondPresenter) equals: self focusedPresenter.
	"Focus third"
	self pressTab.
	self assert: (mock presenterAt: #thirdPresenter) equals: self focusedPresenter.
	"Focus first again"
	self pressTab.
	self assert: (mock presenterAt: #firstPresenter) equals: self focusedPresenter! !

!SpPresenterFocusOrderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self initializeSemaphore! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpPresenterFocusOrderTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpPresenterFocusOrderTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpPresenterFocusOrderTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpPresenterFocusOrderTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpPresenterFocusOrderTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpPresenterFocusOrderTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpPresenterFocusOrderTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpPresenterFocusOrderTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpPresenterFocusOrderTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpPresenterFocusOrderTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpPresenterFocusOrderTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpPresenterFocusOrderTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpPresenterFocusOrderTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpPresenterFocusOrderTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpPresenterFocusOrderTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpPresenterFocusOrderTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpPresenterFocusOrderTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpPresenterFocusOrderTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpPresenterSelectorExample commentStamp: ''!
I am an example of a presenter chooser.
I will show a list and a way to select it.!
!SpPresenterSelectorExample methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter title: 'Presenter Selector Example'! !

!SpPresenterSelectorExample methodsFor: 'initialization' stamp: ''!
initializePresenters
	"self new openWithSpec"

	list := self newList items: #(1 2 3).
	choice := self newPresenterSelector
		when: [ :aNumber | aNumber = 1 ] show: [ self newLabel label: 'One' ];
		when: [ :aNumber | aNumber = 2 ] show: [ self newLabel label: 'Two' ];
		when: [ :aNumber | aNumber = 3 ] show: [ self newLabel label: 'Three' ];
		defaultShow: [ self newLabel label: 'Choose one!!' ];
		"update presenter is needed to make sure the presenter will have correct initial 
		 value (before anything happens)"
		updatePresenter.
		
	list transmitTo: choice! !

!SpPresenterSelectorExample class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newLeftToRight
		add: #list;
		add: #choice;
		yourself.
! !

!SpPresenterSelectorPresenter commentStamp: ''!
A selector presenter that chooses what to show (when condition is satisfied).
The purpose is to allow users to choose different outputs depending on the result of a condition  defined.
The basic usage would be:

```
choose := self newPresenterSelector
	when: [ aCondition ] show: [ aPresenter ];
	when: [ anotherCondition ] show: [ anotherPresenter ];
	defaultShow: [ defaultPresenter ]
```!
!SpPresenterSelectorPresenter methodsFor: 'transmission' stamp: ''!
defaultInputPort

	^ self inputModelPort! !

!SpPresenterSelectorPresenter methodsFor: 'initialization' stamp: ''!
initialize

	cases := SmallDictionary new.
	super initialize.! !

!SpPresenterSelectorPresenter methodsFor: 'api' stamp: ''!
showingPresenter

	^ self layout children
		ifNotEmpty: [ :presenters | presenters first ] 
		ifEmpty: [ nil ]! !

!SpPresenterSelectorPresenter methodsFor: 'defining conditions' stamp: ''!
defaultShow: aPresenterOrBlock

	default := aPresenterOrBlock! !

!SpPresenterSelectorPresenter methodsFor: 'transmission' stamp: ''!
inputModelPort

	^ SpModelPort newPresenter: self! !

!SpPresenterSelectorPresenter methodsFor: 'api - focus' stamp: ''!
defaultKeyboardFocus

	^ layout children 
		ifNotEmpty: [ :children | children first ]
		ifEmpty: [ super defaultKeyboardFocus ]! !

!SpPresenterSelectorPresenter methodsFor: 'initialization' stamp: ''!
updatePresenter

	layout removeAll.
	"try to match a case"
	cases keysAndValuesDo: [ :aBlock :aPresenterOrBlock |
		(aBlock cull: model) ifTrue: [ 
			layout add: (aPresenterOrBlock cull: model).
			^ self ] ].
	"no case matches, use the default (if any)"
	default ifNotNil: [
		layout add: (default cull: model) ]! !

!SpPresenterSelectorPresenter methodsFor: 'accessing - model' stamp: ''!
setModel: anObject

	model := anObject.
	self updatePresenter! !

!SpPresenterSelectorPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: anObject

	model := anObject! !

!SpPresenterSelectorPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	layout := SpBoxLayout newTopToBottom! !

!SpPresenterSelectorPresenter methodsFor: 'defining conditions' stamp: ''!
when: conditionBlock show: aPresenterOrBlock

	cases 
		at: conditionBlock 
		put: aPresenterOrBlock! !

!SpPresenterSelectorPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example

	SpPresenterSelectorExample new openWithSpec! !

!SpPresenterTest methodsFor: 'tests' stamp: ''!
testAsDialogWindow

	presenter := SpPresenter new.
	self 
		assert: presenter asDialogWindow class
		equals: presenter application defaultDialogWindowPresenterClass! !

!SpPresenterTest methodsFor: 'tests' stamp: ''!
testPresentersIncludesPresentersAddedToTheLayout
	| p1 p2 |
	
	presenter := SpPresenter new.
	presenter layout: (SpBoxLayout newTopToBottom
		add: (p1 := presenter newLabel);
		add: (p2 := presenter newLabel);
		yourself).
	
	self assert: presenter presenters equals: { p1. p2 }! !

!SpPresenterTest methodsFor: 'tests' stamp: ''!
testAsWindow

	presenter := SpPresenter new.
	self 
		assert: presenter asWindow class
		equals: presenter application defaultWindowPresenterClass! !

!SpPresenterTest methodsFor: 'tests' stamp: ''!
testTraversePresentersDoIncludesPresentersAddedToTheLayout
	| p1 p2 result |
	
	presenter := SpPresenter new.
	presenter layout: (SpBoxLayout newTopToBottom
		add: (p1 := presenter newLabel);
		add: (p2 := presenter newLabel);
		yourself).
	
	result := Array streamContents: [ :stream | 
		presenter traversePresentersDo: [ :each | stream << each ] ].	
	self assert: result equals: { presenter. p1. p2 }! !

!SpPresenterTest methodsFor: 'tests' stamp: ''!
testAdapterDoesNotRemainsAsDependencyWhenReplacingIt

	presenter := SpPresenter new.
	presenter layout: (SpBoxLayout new add:  SpListPresenter  new; add: SpTextPresenter new; yourself).
	
	3 timesRepeat: [ 
		presenter openWithSpec.
		presenter window close ].
	
	self assert: presenter dependents size equals: 1.
! !

!SpPresenterTest methodsFor: 'tests' stamp: ''!
testAsModalWindow

	presenter := SpPresenter new.
	self 
		assert: presenter asModalWindow class
		equals: presenter application defaultModalWindowPresenterClass! !

!SpPresenterWithModel commentStamp: ''!
I am a composable presenter that keeps reference to its domain model (announcingObject) optionally wrapped in a value holder and subscribes yourself to it. The model (announcingObject) can be instance of a subclass of Model, a value holder or a regular object.

The difference is that if an announcing object is given as model, it is stored directly into announcingObject. For regular objects, they got wrapped automatically in a value holder.

You should implement the method `modelChanged` in my subclasses.
!
!SpPresenterWithModel methodsFor: 'initialization' stamp: ''!
modelChanged

	"subclass responsibility (optional)"! !

!SpPresenterWithModel methodsFor: '*Spec2-Transmission' stamp: ''!
defaultInputPort

	^ self inputModelPort! !

!SpPresenterWithModel methodsFor: '*Spec2-Transmission' stamp: ''!
inputModelPort

	^ SpModelPort newPresenter: self! !

!SpPresenterWithModel methodsFor: 'updating' stamp: ''!
updatePresenter

	self modelChanged ! !

!SpPresenterWithModel methodsFor: 'accessing - private' stamp: ''!
setAnnouncingObject: aDomainObject

	announcingObject := aDomainObject isSpAnnouncingObject ifFalse: [ aDomainObject asValueHolder ] ifTrue: [ aDomainObject ].
	announcingObject whenChangedDo: [ self modelChanged ].
	! !

!SpPresenterWithModel methodsFor: 'transmission' stamp: ''!
setModel: aDomainObject

	^	self model: aDomainObject! !

!SpPresenterWithModel methodsFor: 'accessing' stamp: ''!
model: aDomainObject
	"aDomainObject can be regular object, a value holder or an instance of Model"
	
	(aDomainObject isSpAnnouncingObject not and: [ self announcingObject isValueHolder ])
		ifTrue: [ self announcingObject value: aDomainObject ]
		ifFalse: [ self setAnnouncingObject: aDomainObject ]
	! !

!SpPresenterWithModel methodsFor: 'accessing - private' stamp: ''!
announcingObject

	^ announcingObject! !

!SpPresenterWithModel methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aDomainObject

	self setAnnouncingObject: aDomainObject.
! !

!SpPresenterWithModel methodsFor: 'accessing' stamp: ''!
model

	 ^ self announcingObject value! !

!SpProgressBarDemo commentStamp: ''!
A demo for progress bar usage

   self example!
!SpProgressBarDemo methodsFor: 'accessing' stamp: ''!
indeterminated
	^ indeterminated! !

!SpProgressBarDemo methodsFor: 'accessing' stamp: ''!
withProgressionBlock: anObject
	withProgressionBlock := anObject! !

!SpProgressBarDemo methodsFor: 'accessing' stamp: ''!
withProgressionBlock
	^ withProgressionBlock! !

!SpProgressBarDemo methodsFor: 'accessing' stamp: ''!
withText: anObject
	withText := anObject! !

!SpProgressBarDemo methodsFor: 'accessing' stamp: ''!
fixed
	^ fixed! !

!SpProgressBarDemo methodsFor: 'accessing' stamp: ''!
withText
	^ withText! !

!SpProgressBarDemo methodsFor: 'accessing' stamp: ''!
fixed: anObject
	fixed := anObject! !

!SpProgressBarDemo methodsFor: 'initialization' stamp: ''!
connectPresenters
	withText whenValueChangedDo: [ :value | label label: (value * 100) asInteger asString , '%' ]! !

!SpProgressBarDemo methodsFor: 'initialization' stamp: ''!
initializePresenters
	| progress progress2 |
	indeterminated := self newProgressBar.
	fixed := self newProgressBar.
	withProgressionBlock := self newProgressBar.
	withText := self newProgressBar.
	label := self newLabel.

	indeterminated indeterminate.
	
	fixed fixedPercentage: 30.

	progress := 0.
	withProgressionBlock progress: [ progress := progress + 0.01 ] every: 0.5 second.
	
	progress2 := 0.
	withText progress: [ progress2 := progress2 + 0.01 ] every: 0.1 second.
	label label: 'This is a progress bar'! !

!SpProgressBarDemo methodsFor: 'accessing' stamp: ''!
indeterminated: anObject
	indeterminated := anObject! !

!SpProgressBarDemo methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!SpProgressBarDemo class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #indeterminated withConstraints: [ :constraints | constraints height: 6 ];
		add: 'Indeterminated';
		add: #fixed withConstraints: [ :constraints | constraints height: 10 ];
		add: 'Fixed';
		add: #withProgressionBlock withConstraints: [ :constraints | constraints height: 20 ];
		add: 'With progression block';
		add:
			(SpBoxLayout newLeftToRight
				add: #withText;
				add: #label withConstraints: [ :constraints | constraints width: 40 ];
				yourself)
			withConstraints: [ :constraints | constraints height: 40 ];
		add: 'With label';
		yourself! !

!SpProgressBarDemo class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	
	^ self new openWithSpec! !

!SpProgressBarDemoPage commentStamp: ''!
Description
--------------------

I am a demo page to show how to use progress bar.!
!SpProgressBarDemoPage methodsFor: 'initialization' stamp: ''!
pageClass
	^ SpProgressBarDemo! !

!SpProgressBarDemoPage class methodsFor: 'initialization' stamp: ''!
pageName
	^ 'Progress bar'! !

!SpProgressBarPresenter commentStamp: ''!
A presenter used to define a progress bar.

`SpProgressBarPresenter` uses a strategy to define the kind of progress ba (It can be fixed at a value, indetermineted or progressing).!
!SpProgressBarPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self fixedAt: 0! !

!SpProgressBarPresenter methodsFor: 'api' stamp: ''!
progress: aBlock
	"Using this option, the progress bar will increase with time. 
	 The progression block should return the progression between 0 and 1."

	self progress: aBlock every: 0.2 second! !

!SpProgressBarPresenter methodsFor: 'private' stamp: ''!
state: aState

	state := aState.
	self withAdapterPerformOrDefer: [ :anAdapter | anAdapter updateState ]! !

!SpProgressBarPresenter methodsFor: 'api' stamp: ''!
indeterminate
	"If selected, the progress bar will go back and forth without any clear progression. 
	 Use it do show a progress bar with indeterminate progression."

	self state: SpIndeterminatedProgressBarState new! !

!SpProgressBarPresenter methodsFor: 'api - events' stamp: ''!
whenValueChangedDo: aBlock
	"Inform when progress value has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #state whenChangedDo: aBlock! !

!SpProgressBarPresenter methodsFor: 'api' stamp: ''!
fixedPercentage: aNumber
	"Declare that the progress bar will be fixed at a certain value. 
	 The value should be in percent"

	self fixedAt: aNumber percent! !

!SpProgressBarPresenter methodsFor: 'private' stamp: ''!
state

	^ state! !

!SpProgressBarPresenter methodsFor: 'api' stamp: ''!
progress: aBlock every: aDelay
	"Using this option, the progress bar will increase with time. 
	 The progression block should return the progression between 0 and 1 and 
	 the delay will be used to know the delay between two refresh."

	self state: (SpProgressingProgressBarState progression: aBlock every: aDelay)! !

!SpProgressBarPresenter methodsFor: 'api' stamp: ''!
value

	^ self state value! !

!SpProgressBarPresenter methodsFor: 'api' stamp: ''!
fixedAt: aNumber
	"Declare that the progress bar will be fixed at a certain value. 
	 The value should be the completed ratio between 0 and 1."
	
	self state: (SpFixedProgressBarState value: aNumber)! !

!SpProgressBarPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleIndeterminate

	^ self new 
		application: (SpApplication new useBackend: #Gtk);
		indeterminate;
		openWithSpec! !

!SpProgressBarPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newProgressBar! !

!SpProgressBarPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	| progress |

	progress := 0.
	^ self new 
		progress: [ progress:= progress + 0.1 ] every: 0.5 seconds;
		openWithSpec! !

!SpProgressBarPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleFixedPercentage

	^ self new 
		application: (SpApplication new useBackend: #Gtk);
		fixedPercentage: 30;
		openWithSpec! !

!SpProgressBarPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleFixedAt

	^ self new 
		application: (SpApplication new useBackend: #Gtk);
		fixedAt: 0.3;
		openWithSpec! !

!SpProgressBarPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ProgressBarAdapter! !

!SpProgressBarState commentStamp: ''!
Description
--------------------

I am an abstract class the is the root of a Strategy Design Pattern. My subclasses should have the state of different kind of progress bar. 

My subclasses are used by the ProgressBarPresenter.
!
!SpProgressBarState methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpProgressBarState methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
customizeMorphicBar: aProgressBarMorph
	self subclassResponsibility! !

!SpProgressBarState methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpProgressBarState methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpProgressBarState methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
progressBarMorph
	^ ProgressBarMorph! !

!SpProgressBarState methodsFor: 'api - events' stamp: ''!
whenValueChangedDo: aBlock
	"My subclasses should fire the block when the current value changes."

	self subclassResponsibility! !

!SpProgressBarState methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpProgressBarState class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpProgressBarState class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpProgressBarState class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpProgressBarState class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpProgressBarState class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpProgressBarState class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpProgressBarState class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpProgressBarState class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpProgressBarState class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpProgressBarState class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpProgressBarState class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpProgressBarState class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpProgressBarState class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpProgressBarState class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpProgressBarState class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpProgressBarState class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpProgressBarState class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpProgressBarState class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpProgressBarState class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpProgressBarState class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpProgressBarState class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpProgressBarState class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpProgressBarState class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpProgressBarState class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpProgressBarState class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpProgressBarState class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpProgressBarState class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpProgressBarState class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpProgressBarState class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpProgressDialog commentStamp: ''!
A dialog to show a message and a progress bar.!
!SpProgressDialog methodsFor: 'compatibility' stamp: ''!
value: aFraction

	self progress: (aFraction / maxValue) asFloat! !

!SpProgressDialog methodsFor: 'api' stamp: ''!
progress

	^ progressBar value! !

!SpProgressDialog methodsFor: 'api' stamp: ''!
progressPercent: aNumber

	progressBar fixedPercentage: aNumber asFloat floor! !

!SpProgressDialog methodsFor: 'api' stamp: ''!
informUserDuring: aBlock
	
	openAction := aBlock.
	self openModalWithSpec.
	parentWindow ifNotNil: [
		parentWindow takeKeyboardFocus ]! !

!SpProgressDialog methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self title: 'Progress'.
	maxValue := 1.0! !

!SpProgressDialog methodsFor: 'api' stamp: ''!
label: aString

	label label: aString! !

!SpProgressDialog methodsFor: 'api' stamp: ''!
title: aString

	title := aString! !

!SpProgressDialog methodsFor: 'api' stamp: ''!
progress: aFraction

	progressBar fixedAt: aFraction! !

!SpProgressDialog methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter
	
	aDialogWindowPresenter whenOpenedDo: [ self afterOpenAction ].
	
	self parentWindow 
		ifNotNil: [ :w | aDialogWindowPresenter centeredRelativeTo: w ] 
		ifNil: [ aDialogWindowPresenter centered ]! !

!SpProgressDialog methodsFor: 'api' stamp: ''!
informUser: aString during: aBlock 

	self informUserDuring: [ :bar | 
		bar label: aString. 
		aBlock value ]! !

!SpProgressDialog methodsFor: 'private - actions' stamp: ''!
afterOpenAction
		
	openAction ifNil: [ ^ self ].

	[ 
		[ 
			openAction value: self.
			self accept ]
		on: Error 
		fork: [ :e | 
			self cancel.
			e pass ].
	] fork! !

!SpProgressDialog methodsFor: 'compatibility' stamp: ''!
value

	^ self progress! !

!SpProgressDialog methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter 
		title: self title;
		initialExtent: self class extent! !

!SpProgressDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpBoxLayout newTopToBottom
		borderWidth: 5;
		add: (label := self newLabel) expand: false;
		add: (progressBar := self newProgressBar) expand: false;
		yourself)! !

!SpProgressDialog methodsFor: 'initialization' stamp: ''!
reset

	self label: ''.
	self max: 1.0.
	self progress: 0.0.
	! !

!SpProgressDialog methodsFor: 'api' stamp: ''!
label

	^ label label! !

!SpProgressDialog methodsFor: 'api' stamp: ''!
title

	^ title! !

!SpProgressDialog methodsFor: 'compatibility' stamp: ''!
max: aNumber
	"sets the maximum value. 
	 Affects how #value: is calculated"

	maxValue := aNumber asFloat! !

!SpProgressDialog class methodsFor: 'examples' stamp: ''!
exampleModal

	self new
		title: 'Example Progress';
		label: 'You are seeing a progress dialog!!';
		progressPercent: 30;
		openModalWithSpec! !

!SpProgressDialog class methodsFor: 'accessing' stamp: ''!
extent

	^ 600@100! !

!SpProgressDialog class methodsFor: 'examples' stamp: ''!
exampleInformUserDuring

	self new
		title: 'Example Progress';
		informUserDuring: [ :bar | 
			1 to: 10 do: [ :index | 
				bar 
					label: ('Step {1}...' format: { index });
					progressPercent: index * 10.
				1 second wait ] ]! !

!SpProgressDialog class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector
	
	^ #newProgress! !

!SpProgressDialog class methodsFor: 'examples' stamp: ''!
example

	self new
		title: 'Example Progress';
		label: 'You are seeing a progress dialog!!';
		progressPercent: 30;
		openDialogWithSpec! !

!SpProgressingProgressBarState commentStamp: ''!
Description
--------------------

I am a state of a ProgressBarPresenter managing the behavior of a progress bar which value can progress.

I will have a block that should return a number between 0 and 1 to get the current progress and a delay defining the refresh rate of the progress bar.

Examples
--------------------

	ProgressBarProgressing progression: [ model computationStep ] every: 0.2 seconds
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	currentValueHolder:		<aValueHolder>		Store the current value of the progress bar. We need it to be able to notify the user when it changes so that the user can register to the change.
	progression:					<aValuable>			A block returning a number between 0 and 1 defining the progress of the bar.
	refreshDelay:				<aDelay>				A delay defining the refresh rate of the bar.
!
!SpProgressingProgressBarState methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
customizeMorphicBar: aProgressBarMorph
	self flag: #todo.	"This is not the best solution but we do not know yet what is. Pablo would like to have a minimal version of TaskIt in the image that could be used. But at least this is only in one place and we can update it easily."
	[ [ self currentValue < 1 ]
		whileTrue: [ self currentValue: self progression value.
			aProgressBarMorph value: self currentValue.
			self refreshDelay wait ] ] fork! !

!SpProgressingProgressBarState methodsFor: 'accessing' stamp: ''!
currentValue: aNumber
	currentValue := aNumber! !

!SpProgressingProgressBarState methodsFor: 'initialization' stamp: ''!
initialize
	self class initializeSlots: self.
	super initialize.
	currentValue := 0! !

!SpProgressingProgressBarState methodsFor: 'accessing' stamp: ''!
currentValue
	^ currentValue! !

!SpProgressingProgressBarState methodsFor: 'accessing' stamp: ''!
progression: aValuable
	progression := aValuable! !

!SpProgressingProgressBarState methodsFor: 'accessing' stamp: ''!
progression
	^ progression! !

!SpProgressingProgressBarState methodsFor: 'accessing' stamp: ''!
refreshDelay
	^ refreshDelay! !

!SpProgressingProgressBarState methodsFor: 'accessing' stamp: ''!
refreshDelay: aDelay
	refreshDelay := aDelay! !

!SpProgressingProgressBarState class methodsFor: 'instance creation' stamp: ''!
progression: aBlock every: aDelay
	^ self new
		progression: aBlock;
		refreshDelay: aDelay;
		yourself! !

!SpPropertyStyle commentStamp: ''!
# Style properties (`SpPropertyStyle`)

Style properties define different kind of properties a morphic component can have. There are several types of properties, defined as: 

- `SpContainerStyle`
- `SpDrawStyle`
- `SpFontStyle`
- `SpGeometryStyle`!
!SpPropertyStyle methodsFor: 'private' stamp: ''!
toColor: aColorOrSymbol

	"Try if color"
	aColorOrSymbol isSymbol ifFalse: [ ^ aColorOrSymbol ].
	"Try by name"
	(Color named: aColorOrSymbol) ifNotNil: [ :aColor | ^ aColor ]. 
	"Try by HEX (CSS style)"				
	^ Color fromHexString: aColorOrSymbol! !

!SpPropertyStyle methodsFor: 'operations' stamp: ''!
mergeWith: otherProperty
	| merged |

	self species = otherProperty species ifFalse: [ 
		self error: 'Trying to merge two different properties' ].
 
	merged := self species new.
	self class allSlots do: [ :eachSlot | 
		"other property will have precedence over this one"
		merged 
			writeSlot: eachSlot 
			value: ((otherProperty readSlot: eachSlot) ifNil: [ self readSlot: eachSlot ]) ].
		
	^ merged! !

!SpPropertyStyle methodsFor: 'testing' stamp: ''!
isStyleProperty

	^ true! !

!SpPropertyStyle methodsFor: 'copying' stamp: ''!
, other

	^ self mergeWith: other! !

!SpPropertyStyle methodsFor: 'instance creation' stamp: ''!
fromSton: stonReader

	"I will use accessors because I want to be able to add convenience methods"
	stonReader parseMapDo: [ :message :value |
		self 
			perform: message asMutator 
			with: (value ifNotNil: [ value asStyleVariable ]) ]! !

!SpPropertyStyle methodsFor: 'operations' stamp: ''!
applyTo: aMorph
	! !

!SpPropertyStyle methodsFor: 'testing' stamp: ''!
isGeometry

	^ false! !

!SpPropertyStyle methodsFor: 'private' stamp: ''!
toVariable: anObject

	^ anObject ifNotNil: [ anObject asStyleVariable ].
	! !

!SpPropertyStyleTest methodsFor: 'tests' stamp: ''!
testMergeWith
	| p1 p2 p3 |
	
	p1 := SpGeometryStyle new
		width: 20;
		height: 20;
		yourself.
	p2 := SpGeometryStyle new
		width: 40;
		height: 40;
		yourself.
		
	p3 := p1, p2.
	
	self assert: p3 width equals: 40.
	self assert: p3 height equals: 40	! !

!SpPropertyStyleTest methodsFor: 'tests' stamp: ''!
testMergeWithFontRemovePredefinedFont
	| p1 p2 p3 |
	
	p1 := SpFontStyle new
		predefinedFont: #default;
		yourself.
	p2 := SpFontStyle new
		name: 'Source Code Pro';
		size: 10;
		yourself.
		
	p3 := p1, p2.
	
	self assert: p3 predefinedFont isNil.
	! !

!SpPropertyStyleTest methodsFor: 'tests' stamp: ''!
testMergeWithPredefinedFontCanBeDecorated
	| p1 p2 p3 |
	
	p1 := SpFontStyle new
		predefinedFont: #default;
		yourself.
	p2 := SpFontStyle new
		name: nil;
		color: Color white;
		size: 42;
		yourself.
	
	p3 := p1, p2.
	
	self deny: p3 predefinedFont isNil.
	self assert: p3 color equals: Color white.
	self assert: p3 definedFont pointSize equals: 42! !

!SpPropertyStyleTest methodsFor: 'tests' stamp: ''!
testMergeWithFontDoNotRemovePredefinedFontWhenNoFontIsDefined
	| p1 p2 p3 |
	
	p1 := SpFontStyle new
		predefinedFont: #default;
		yourself.
	p2 := SpFontStyle new
		name: nil;
		color: Color white;
		yourself.
		
	p3 := p1, p2.
	
	self deny: p3 predefinedFont isNil.
	self assert: p3 color equals: Color white! !

!SpRGBSlidersPresenter commentStamp: ''!
I am an elementary Spec widget allowing a user to choose a Color by its RGB values.

self example

I manage three SliderInput.
I set their min at 0 and their max at 255.

I provide the methods color that calculate the Color obtains with the current value of the sliders.!
!SpRGBSlidersPresenter methodsFor: 'accessing' stamp: ''!
greenSlider
	^ greenSlider! !

!SpRGBSlidersPresenter methodsFor: 'initialization' stamp: ''!
whenChangedDo: aBlock
	redSlider whenValueChangedDo: aBlock.
	greenSlider whenValueChangedDo: aBlock.
	blueSlider whenValueChangedDo: aBlock! !

!SpRGBSlidersPresenter methodsFor: 'accessing' stamp: ''!
blueSlider
	^ blueSlider! !

!SpRGBSlidersPresenter methodsFor: 'accessing' stamp: ''!
redSlider
	^ redSlider! !

!SpRGBSlidersPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	redSlider := self instantiate: SpSliderInputPresenter.
	greenSlider := self instantiate: SpSliderInputPresenter.
	blueSlider := self instantiate: SpSliderInputPresenter.
	redSlider
		min: 0;
		max: 255; label: 'Red' translated.
	greenSlider
		min: 0;
		max: 255; label: 'Green' translated.
	blueSlider
		min: 0;
		max: 255; label: 'Blue' translated.
	self focusOrder
		add: redSlider;
		add: greenSlider;
		add: blueSlider! !

!SpRGBSlidersPresenter methodsFor: 'accessing' stamp: ''!
color
	^ (Color
				r: redSlider value
				g: greenSlider value
				b: blueSlider value
				range: 255)! !

!SpRGBSlidersPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #redSlider;
		add: #greenSlider;
		add: #blueSlider;
		yourself! !

!SpRGBSlidersPresenter class methodsFor: '*Spec2-Morphic-Examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self new
		extent: 300 @ 200;
		openWithSpec;
		yourself.
	example withWindowDo: [ :window | window title: 'RGBSliders example' ].
	^ example! !

!SpRGBSlidersPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpRGBSlidersPresenter! !

!SpRGBSlidersPresenterTest methodsFor: 'tests' stamp: ''!
testwhenChangedDo
	| numberOfChanges |
	numberOfChanges := 0.
	presenter whenChangedDo: [ numberOfChanges := numberOfChanges + 1 ].
	presenter redSlider value: 66.
	presenter greenSlider value: 17.
	presenter blueSlider value: 200.
	self assert: numberOfChanges equals: 3! !

!SpRGBSlidersPresenterTest methodsFor: 'tests' stamp: ''!
testColor

	| random red green blue |
	random := Random new.
	red := random nextInteger: 255.
	green := random nextInteger: 255.
	blue := random nextInteger: 255.

	presenter redSlider value: red.
	presenter greenSlider value: green.
	presenter blueSlider value: blue.
	self assert: presenter color equals: (Color
			 r: red
			 g: green
			 b: blue
			 range: 255)! !

!SpRGBWidget commentStamp: ''!
I am a Spec widget  allowing a user to choose a Color by its RGB values and providing a preview.

self example

I am composed of a RGBSliders and an ImagePresenter that display simply a form of the current color.

I provide the following methods
- color a shortcut color to access the current color of the RGBSliders.
- makeNewForm return a fresh copy of the current displayed form.

I provide extentForPreview, a point used to define the size of the preview.!
!SpRGBWidget methodsFor: 'api' stamp: ''!
makeNewForm
	^ (Form extent: 30 @ 30 depth: 32) fillColor: self color! !

!SpRGBWidget methodsFor: 'accessing' stamp: ''!
sliders
	^ sliders! !

!SpRGBWidget methodsFor: 'accessing' stamp: ''!
preview
	^ preview! !

!SpRGBWidget methodsFor: 'api - events' stamp: ''!
whenExtentForPreviewChanged: aBlock
 extentForPreview whenChangedDo: aBlock ! !

!SpRGBWidget methodsFor: 'initialization' stamp: ''!
initializePresenters
	preview := self instantiate: SpImagePresenter.
	sliders := self instantiate: SpRGBSlidersPresenter.
	preview image: (Form extent: 30 @ 30 depth: 32).
	preview image: self makeNewForm.
	self focusOrder add: sliders! !

!SpRGBWidget methodsFor: 'initialization' stamp: ''!
connectPresenters
	sliders whenChangedDo: [ preview image: self makeNewForm ].! !

!SpRGBWidget methodsFor: 'api' stamp: ''!
color
 ^ sliders color! !

!SpRGBWidget class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #preview;
		add: #sliders;
		yourself! !

!SpRGBWidget class methodsFor: '*Spec2-Morphic-Examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self new
		extent: 300 @ 250;
		openWithSpec;
		yourself.
	example withWindowDo: [ :window | window title: 'RGBWidget example' ].
	^ example! !

!SpRGBWidgetTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpRGBWidget! !

!SpRadioButtonAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpRadioButtonPresenter ! !

!SpRadioButtonAdapterTest methodsFor: 'tests' stamp: ''!
testChangingLabelAffectTheWidget
	
	presenter label: 'ALabel'.
	self assert: self widget label equals: 'ALabel'! !

!SpRadioButtonAdapterTest methodsFor: 'tests' stamp: ''!
testIfSingleRadioButtonStartsSelected

	self assert: self adapter state.! !

!SpRadioButtonExample commentStamp: ''!
I am a demo to show how to use radio buttons with Spec.

self example!
!SpRadioButtonExample methodsFor: 'updating' stamp: ''!
updateLabel
	label
		label:
			(String
				streamContents: [ :s | 
					{button1 . button2 . button3}
						do: [ :button | 
							s
								<< button label;
								<< ' : ';
								<< (button state ifTrue: [ 'V' ] ifFalse: [ 'X' ]) ]
						separatedBy: [ s << ' - ' ] ])! !

!SpRadioButtonExample methodsFor: 'initialization' stamp: ''!
initializePresenters

	button1 := self newRadioButton.
	button2 := self newRadioButton.
	button3 := self newRadioButton.
	label := self newLabel.
	button1 associatedRadioButtons: { button2. button3 }.

	button1 label: 'Button 1'.
	button2 label: 'Button 2'.
	button3 label: 'Button 3'.

	self updateLabel.! !

!SpRadioButtonExample methodsFor: 'initialization' stamp: ''!
connectPresenters
	button1 whenActivatedDo: [ self updateLabel ].
	button1 whenDeactivatedDo: [ self updateLabel ].

	button2 whenChangedDo: [ self updateLabel ].

	button3 whenChangedDo: [ self updateLabel ]! !

!SpRadioButtonExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: (SpBoxLayout newTopToBottom
				add: #button1 expand: false;
				add: #button2 expand: false;
				add: #button3 expand: false;
				yourself);
		add: #label expand: false;
		yourself! !

!SpRadioButtonExample class methodsFor: 'examples' stamp: ''!
example

	^ self new openWithSpec! !

!SpRadioButtonExample class methodsFor: 'specs' stamp: ''!
title

	^ 'Radio Button Example'! !

!SpRadioButtonExampleTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpRadioButtonExample! !

!SpRadioButtonInteractionTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTestPresenterWithThreeRadioButtons ! !

!SpRadioButtonInteractionTest methodsFor: 'tests' stamp: ''!
testShowPresenterShowsWidget

	"Composable presenters do not have adapters so this test breaks..."
	self skip! !

!SpRadioButtonInteractionTest methodsFor: 'tests' stamp: ''!
testClickingRadio3DeselectsRadio1

	self openInstance.
	self presenter radio3 adapter clicked.
	
	self deny: self presenter radio1 state! !

!SpRadioButtonInteractionTest methodsFor: 'tests' stamp: ''!
testClickingRadio3DeselectsRadio2

	self openInstance.
	self presenter radio3 adapter clicked.
	
	self deny: self presenter radio2 state! !

!SpRadioButtonInteractionTest methodsFor: 'tests' stamp: ''!
testRadio1StartsDeselected

	self deny: self presenter radio1 state! !

!SpRadioButtonInteractionTest methodsFor: 'tests' stamp: ''!
testRadio2StartsSelected

	self assert: self presenter radio2 state! !

!SpRadioButtonInteractionTest methodsFor: 'tests' stamp: ''!
testRadio2WidgetStartsSelected

	self openInstance.

	self assert: self presenter radio2 adapter state! !

!SpRadioButtonInteractionTest methodsFor: 'tests' stamp: ''!
testClickingRadio3SelectsIt

	self openInstance.
	self presenter radio3 adapter clicked.
	
	self assert: self presenter radio3 state! !

!SpRadioButtonInteractionTest methodsFor: 'tests' stamp: ''!
testHidePresenterHidesWidget

	"Composable presenters do not have adapters so this test breaks..."
	self skip! !

!SpRadioButtonInteractionTest methodsFor: 'tests' stamp: ''!
testRadio3StartsDeselected

	self openInstance.
	self deny: self presenter radio3 state! !

!SpRadioButtonPresenter commentStamp: ''!
A presenter for Radio Buttons.!
!SpRadioButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	state := true.
	initialStateSet := true.
	associatedRadioButtons := #()! !

!SpRadioButtonPresenter methodsFor: 'api' stamp: ''!
state: aValue
	"Set the state `aBoolean` of current radio button. 
	 Changing the state affect other associated radio buttons by toggling also their state.
	 See also `SpRadioButtonPresenter>>#associatedRadioButtons:`"

	(aValue not 
		and: [ associatedRadioButtons noneSatisfy: [ :e | e state ] ])
		ifTrue: [ 
			"If I am the only one in true, I cannot be unselected" 
			^ self ].

	super state: aValue.
	
	aValue ifTrue: [ 
		associatedRadioButtons 
			do: [ :e | e state: false ] ].! !

!SpRadioButtonPresenter methodsFor: 'private' stamp: ''!
basicAssociatedRadioButtons: aCollection 
	
	associatedRadioButtons := aCollection copyWithout: self! !

!SpRadioButtonPresenter methodsFor: 'testing' stamp: ''!
isInitialStateSet
	"Answer if the radio button and its associates start the display with one of the buttons 
	 set. This is often used when you do not have a default option and you need to require the 
	 user to expressely pick one choice."

	^ initialStateSet! !

!SpRadioButtonPresenter methodsFor: 'api' stamp: ''!
initialStateNotSet
	"Setting this value to the first radio button will cause the entire group to be unset 
	 on first display. This will be ignored if sent to other than the own containing the 
	 associated buttons"

	initialStateSet := false! !

!SpRadioButtonPresenter methodsFor: 'api' stamp: ''!
associatedRadioButtons
	"Answer the collection of radio buttons associated (grouped) to this one.
	 See also `SpRadioButtonPresenter>>#associatedRadioButtons:`"

	^ associatedRadioButtons! !

!SpRadioButtonPresenter methodsFor: 'api' stamp: ''!
associatedRadioButtons: aCollection 
	"Set the list of radio buttons associated with this one.
	 By using this, you will be grouping together this radio button along with the ones contained 
	 in `aCollection`.
	 You should NOT send this message to all associated radio buttons, the first of them is enough."
	| allElements |
	
	"pass group to all members"	
	allElements := { self }, aCollection.
	allElements do: [ :each | 
		each basicAssociatedRadioButtons: allElements ].
	
	"self state: true."
	aCollection do: [ :each | each state: false ]! !

!SpRadioButtonPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newRadioButton! !

!SpRadioButtonPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example

	^ SpRadioButtonExample new openWithSpec! !

!SpRadioButtonPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #RadioButtonAdapter! !

!SpRadioButtonPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Radio Button'! !

!SpRadioButtonPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^  SpRadioButtonPresenter! !

!SpRecursiveContextSetter commentStamp: ''!
Visit recursively the tree of commands groups to set the context stored in my #context inst. var. to all CmCommands located at the leaves of the tree.!
!SpRecursiveContextSetter methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!SpRecursiveContextSetter methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!SpRecursiveContextSetter methodsFor: 'visiting' stamp: ''!
visitCommand: aCmCommand
	aCmCommand context
		ifNotNil: [ ^ self ].
	
	aCmCommand
		context: self context! !

!SpRecursiveContextSetter class methodsFor: 'instance creation' stamp: ''!
context: context
	^ self new
		context: context;
		yourself! !

!SpRecursiveContextSetter class methodsFor: 'helper' stamp: ''!
visit: aCommandOrGroup toSetContext: anObject
	aCommandOrGroup
		acceptVisitor: (self context: anObject).
		
	^ aCommandOrGroup! !

!SpRecursiveContextSetterTest commentStamp: ''!
A SpRecursiveContextSetterTest is a test class for testing the behavior of SpRecursiveContextSetter!
!SpRecursiveContextSetterTest methodsFor: 'tests' stamp: ''!
testVisitCommand
	| commandsGroup |
	commandsGroup := (CmCommandGroup named: 'root') asSpecGroup beRoot
		register:
			(CmBlockCommand new
				name: 'c1';
				block: [  ];
				context: 42;
				yourself) asSpecCommand;
		register:
			((CmCommandGroup named: 'sub1') asSpecGroup
				register:
					(CmBlockCommand new
						name: 'c2';
						block: [  ];
						context: 42;
						yourself) asSpecCommand;
				register:
					(CmBlockCommand new
						name: 'c3';
						block: [  ];
						yourself) asSpecCommand);
		register:
			(CmBlockCommand new
				name: 'c4';
				block: [  ];
				yourself) asSpecCommand;
		yourself.
	self assert: (commandsGroup / 'c1') context equals: 42.
	self assert: (commandsGroup / 'sub1' / 'c2') context equals: 42.
	self assert: (commandsGroup / 'sub1' / 'c3') context isNil.
	self assert: (commandsGroup / 'c4') context isNil.
	SpRecursiveContextSetter visit: commandsGroup toSetContext: 43.
	self assert: (commandsGroup / 'c1') context equals: 42.
	self assert: (commandsGroup / 'sub1' / 'c2') context equals: 42.
	self assert: (commandsGroup / 'sub1' / 'c3') context equals: 43.
	self assert: (commandsGroup / 'c4') context equals: 43! !

!SpRequestDialog commentStamp: ''!
A simple dialog to request some information (a text)!
!SpRequestDialog methodsFor: 'api' stamp: ''!
text 
	
	^ textInput text trimmed! !

!SpRequestDialog methodsFor: 'api - showing' stamp: ''!
openModalWithSpec
	| dialog |
	
	dialog := super openModalWithSpec.
	^ dialog isOk
		ifTrue: [ self text trimmed ]
		ifFalse: [ nil ]! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
cancelLabel

	^ cancelLabel ifNil: [ self class defaultCancelLabel ]! !

!SpRequestDialog methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	self title: 'Request'! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
label: aString

	label label: aString! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
text: aString

	textInput text: aString! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
title: aString

	title := aString! !

!SpRequestDialog methodsFor: 'private' stamp: ''!
validateAnswer
	
	validateBlock ifNotNil: [ 
		^ validateBlock value: textInput text].
	
	^ true! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
validateAnswer: aBlock

	validateBlock := aBlock! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
acceptLabel

	^ acceptLabel ifNil: [ self class defaultAcceptLabel ]! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
extent

	^ initialExtent ifNil: [ self class defaultExtent ]! !

!SpRequestDialog methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter

	super initializeDialogWindow: aDialogWindowPresenter.
	aDialogWindowPresenter
		addButton: self cancelLabel do: [ :presenter | self cancel ];
		addDefaultButton: self acceptLabel do: [ :presenter | self accept ]! !

!SpRequestDialog methodsFor: 'visiting' stamp: ''!
accept

	self validateAnswer ifFalse: [ ^ self ].
	super accept! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
acceptLabel: aString

	acceptLabel := aString! !

!SpRequestDialog methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter
		title: self title;
		initialExtent: self extent;
		whenOpenedDo: [ textInput takeKeyboardFocus ]! !

!SpRequestDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	image := self newImage image: self defaultIcon.
	label := self newLabel.
	textInput := self newTextInput! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
extent: aPoint

	initialExtent := aPoint! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
title

	^ title! !

!SpRequestDialog methodsFor: 'api' stamp: ''!
cancelLabel: aString

	cancelLabel := aString! !

!SpRequestDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		borderWidth: 5;
		spacing: 5;
		add: (SpBoxLayout newLeftToRight
				vAlignCenter;
				spacing: 5;
				add: #image expand: false; 
				add: #label;
				yourself) 
			expand: false;
		add: #textInput expand: false;
		yourself! !

!SpRequestDialog class methodsFor: 'examples' stamp: ''!
exampleModal
	| string |

	string := self new
		title: 'Request modal example';
		label: 'The meaning of life?';
		text: 'I am tempted to say 42...';
		acceptLabel: 'I know!!';
		cancelLabel: 'Cancel';
		openModalWithSpec.
		
	string ifNotNil: [ 
		self inform: string ]! !

!SpRequestDialog class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector
	
	^ #newRequest! !

!SpRequestDialog class methodsFor: 'examples' stamp: ''!
example

	self new
		title: 'Request example';
		label: 'The meaning of life?';
		text: 'I am tempted to say 42...';
		acceptLabel: 'I know!!';
		cancelLabel: 'Cancel';
		onAccept: [ :dialog | self inform: dialog presenter text ];
		openDialogWithSpec! !

!SpRequestDialog class methodsFor: 'accessing' stamp: ''!
defaultExtent

	^ 450@160! !

!SpRequestTextDialog commentStamp: ''!
A dialog to request multiple lines of text to users.!
!SpRequestTextDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	image := self newImage image: (self application iconNamed: #question).
	label := self newLabel.
	textInput := self newText! !

!SpRequestTextDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		borderWidth: 5;
		spacing: 5;
		add: (SpBoxLayout newLeftToRight
				vAlignCenter;
				spacing: 5;
				add: #image expand: false;
				add: #label;
				yourself)
			expand: false;
		add: #textInput;
		yourself! !

!SpRequestTextDialog class methodsFor: 'examples' stamp: ''!
exampleModal

	^ super exampleModal! !

!SpRequestTextDialog class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector
	
	^ #newRequestText! !

!SpRequestTextDialog class methodsFor: 'examples' stamp: ''!
example

	^ super example! !

!SpRequestTextDialog class methodsFor: 'accessing' stamp: ''!
defaultExtent

	^ 450@300! !

!SpRoassal3InspectorPresenter methodsFor: 'enumerating' stamp: ''!
whenActivatedDo: aBlock
	| context |
	context := canvas inspectorContext.
	context presentation: aBlock.
	canvas morph setTakeKeyboardFocus.
	canvas shapes @ context.
	canvas
		when: RSShapeAddedEvent
		do: [ :evt | evt shape @ context ].! !

!SpRoassal3InspectorPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize! !

!SpRoassal3InspectorPresenter methodsFor: 'accessing' stamp: ''!
canvas: aRSCanvas
	canvas := aRSCanvas.
	self morph: canvas createMorph.! !

!SpRoassal3InspectorPresenter methodsFor: 'ports' stamp: ''!
activateOnDoubleClick! !

!SpRoassal3InspectorPresenter methodsFor: 'ports' stamp: ''!
activateOnSingleClick! !

!SpRoassal3InspectorPresenter methodsFor: 'ports' stamp: ''!
defaultOutputPort

	^ self outputSelectionPort! !

!SpRoassal3InspectorPresenter methodsFor: 'ports' stamp: ''!
outputActivationPort
	^ SpActivationPort newPresenter: self! !

!SpRoassal3InspectorPresenter methodsFor: 'ports' stamp: ''!
outputSelectionPort
	^ SpActivationPort newPresenter: self! !

!SpRoassal3InspectorPresenter methodsFor: 'accessing' stamp: ''!
canvas
	^ canvas! !

!SpRoassalPresenter commentStamp: ''!
I am a basic presenter for widgets in roassal with the Spec system!
!SpRoassalPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	script := [ :aCanvas | ] asValueHolder.
	script whenChangedDo: [ :s | self refresh ].! !

!SpRoassalPresenter methodsFor: 'accessing' stamp: ''!
currentCanvas
	^ currentCanvas! !

!SpRoassalPresenter methodsFor: 'api' stamp: ''!
contextMenu
	"Answer context menu or nil if there is none defined.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	^ contextMenu! !

!SpRoassalPresenter methodsFor: 'accessing' stamp: ''!
canvas: aRSCanvas
	currentCanvas := aRSCanvas! !

!SpRoassalPresenter methodsFor: 'public' stamp: ''!
refresh 
	self changed: #applyScript with: #()! !

!SpRoassalPresenter methodsFor: 'accessing' stamp: ''!
script
	^ script value! !

!SpRoassalPresenter methodsFor: 'accessing' stamp: ''!
whenPresenterResized: aBlock

	self announcer 
		when: PresenterResized 
		do: [ :ann | aBlock cull: ann extent ]! !

!SpRoassalPresenter methodsFor: 'dependencies' stamp: ''!
release
	self class instVarNames do: [ :n | self instVarNamed: n put: nil ]! !

!SpRoassalPresenter methodsFor: 'accessing' stamp: ''!
script: anObject
	script value: anObject! !

!SpRoassalPresenter methodsFor: 'api' stamp: ''!
contextMenu: aValuableOrMenuPresenter
	"Set the context menu.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	contextMenu := aValuableOrMenuPresenter! !

!SpRoassalPresenter methodsFor: 'api - events' stamp: ''!
whenMenuChangedDo: aBlock
	"Inform when menu definition changed. 
	 `aBlock` receives zero arguments."

	self property: #contextMenu whenChangedDo: aBlock! !

!SpRoassalPresenter methodsFor: 'accessing' stamp: ''!
canvas
	^ currentCanvas ifNil: [ currentCanvas := RSCanvas new ]! !

!SpRoassalPresenter class methodsFor: 'instance creation' stamp: ''!
on: anOwningPresenter withCanvas: aTrachelCanvas

	^ self basicNew
		owner: anOwningPresenter;
		canvas: aTrachelCanvas;
		initialize;
		yourself! !

!SpRoassalPresenter class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	^ self new openWithSpec! !

!SpRoassalPresenter class methodsFor: 'specs' stamp: ''!
adapterName
	^ #RoassalAdapter! !

!SpRootsPort methodsFor: 'handling transmission' stamp: ''!
applyIncomingTransmission: anObject from: outPort to: aPresenter

	aPresenter roots: anObject! !

!SpRubFindReplaceDialog commentStamp: ''!
I am a Spec dialog used for find & replace service. I am currently partly dependent on Morphic backend because of more user friendly keyboard manipulation.!
!SpRubFindReplaceDialog methodsFor: 'accessing' stamp: ''!
findInput: anObject
	findInput := anObject.! !

!SpRubFindReplaceDialog methodsFor: 'initialization' stamp: ''!
updateFindText

	service findText: self findInput text asString.! !

!SpRubFindReplaceDialog methodsFor: 'initialization' stamp: ''!
updateFromModel

	findInput text: (self service findText
		ifEmpty: [ '' ]
		ifNotEmpty: [ :aText | aText asString lines first ]).

! !

!SpRubFindReplaceDialog methodsFor: 'morphic dependencies' stamp: ''!
assignEnterKeystrokeEventFor: aPresenter

	"Morphic dependent!!"

	aPresenter whenBuiltDo: [ :this | this widget announcer when: RubReturnEntered do: [ :ann |
		self find ] ].! !

!SpRubFindReplaceDialog methodsFor: 'accessing' stamp: ''!
service
	^ service! !

!SpRubFindReplaceDialog methodsFor: 'operations' stamp: ''!
replace
	self updateService.
	self newReplacement.
	service replace.
	service find! !

!SpRubFindReplaceDialog methodsFor: 'operations' stamp: ''!
replaceAll
	self updateService.
	self newReplacement.
	service replaceAll.! !

!SpRubFindReplaceDialog methodsFor: 'operations' stamp: ''!
find 
	self updateService.
	service find! !

!SpRubFindReplaceDialog methodsFor: 'accessing' stamp: ''!
findInput
	^ findInput! !

!SpRubFindReplaceDialog methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter
	
	findButton := aDialogWindowPresenter addButton: 'Find' do: [ :presenter | 
			self find ].
	replaceButton := aDialogWindowPresenter addButton: 'Replace' do: [ :presenter | 
			self replace ].
	replaceAllButton := aDialogWindowPresenter addButton: 'Replace All' do: [ :presenter | 
			self replaceAll ].
	cancelButton := aDialogWindowPresenter addButton: 'Cancel' do: [ :presenter | 
			presenter triggerCancelAction.
			presenter close ].
		
	self focusOrder 
		add: findButton;
		add: replaceButton;
		add: replaceAllButton;
		add: cancelButton.
				
	aDialogWindowPresenter
		title: self title;
		initialExtent: 430 @ 220.
		
	aDialogWindowPresenter whenClosedDo: [ service discardDialog ]
! !

!SpRubFindReplaceDialog methodsFor: 'private' stamp: ''!
newReplacement
	| t |
	(t := replaceTextInput text asString) ifEmpty: [^ self ].
	
	service replaceText: replaceTextInput text asString.
! !

!SpRubFindReplaceDialog methodsFor: 'morphic dependencies' stamp: ''!
closeWindowOnEscIn: aPresenter

	"Morphic dependent!!"

	aPresenter whenBuiltDo: [ :this | this widget announcer when: RubKeystroke do: [ :ann |
		ann event keyCharacter = Character escape ifTrue: [ self window triggerCancelAction ] ] ].! !

!SpRubFindReplaceDialog methodsFor: 'accessing' stamp: ''!
service: anObject
	service := anObject! !

!SpRubFindReplaceDialog methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aService

	service := aService! !

!SpRubFindReplaceDialog methodsFor: 'accessing' stamp: ''!
findButton
	^ findButton! !

!SpRubFindReplaceDialog methodsFor: 'private' stamp: ''!
updateService

	service caseSensitive: caseCheckBox state.
	service isRegex: regExpCheckBox state.
	service entireWordsOnly: entireCheckBox state.
	service wrapAround: wrapCheckBox state.
	service searchBackwards: backwardsCheckBox state.
	! !

!SpRubFindReplaceDialog methodsFor: 'initialization' stamp: ''!
initializePresenters
	findInput := self newTextInput autoAccept: true; placeholder: 'Text to find'.
	
	findInput whenTextChangedDo: [ self updateFindText ].
	
	self closeWindowOnEscIn: findInput.
	self assignEnterKeystrokeEventFor: findInput.
	
	regExpCheckBox := self newCheckBox label: 'Regular expression'.
	backwardsCheckBox := self newCheckBox label: 'Search backwards'.
	caseCheckBox := self newCheckBox label: 'Case sensitive'.
	wrapCheckBox := self newCheckBox label: 'Wrap around'.
	entireCheckBox := self newCheckBox label: 'Entire words only'.
			
	replaceTextInput := self newTextInput autoAccept: true.
	self closeWindowOnEscIn: replaceTextInput.

	replaceLabel := self newLabel label: 'Replace with:'.
	
	self focusOrder 
		add: findInput;
		add: replaceTextInput;
		add: regExpCheckBox;
		add: backwardsCheckBox;
		add: caseCheckBox;
		add: wrapCheckBox;
		add: entireCheckBox.
		! !

!SpRubFindReplaceDialog methodsFor: 'accessing' stamp: ''!
findButton: anObject
	findButton := anObject! !

!SpRubFindReplaceDialog methodsFor: 'accessing' stamp: ''!
title 
	
	^ 'Find & Replace'! !

!SpRubFindReplaceDialog class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	^ SpBoxLayout newVertical
		add: #findInput expand: false;
		add: (SpGridLayout new 
			beColumnHomogeneous;
			beRowHomogeneous;
			add: #regExpCheckBox at: 1@1;
			add: #backwardsCheckBox at: 2@1;
			add: #caseCheckBox at: 1@2;
			add: #wrapCheckBox at: 2@2;
			add: #entireCheckBox at: 1@3;
			yourself);
		addLast: (SpBoxLayout newHorizontal 
			borderWidth: 5;
			spacing: 5;
			add: #replaceLabel  expand: false fill: false padding: 0;
			add: #replaceTextInput;
			yourself);
		"addLast: (SpBoxLayout newHorizontal 
			borderWidth: 3;
			spacing: 5;
			add: #findButton;
			add: #replaceButton;
			add: #replaceAllButton;
			add: #cancelButton);"
		yourself! !

!SpRubFindReplaceService commentStamp: ''!
I am a FindReplace service that allows to use Spec based dialog as a replacement of a native Morphic find & replace dialog. 

I can currently work only with the default Morphic Spec backend.!
!SpRubFindReplaceService methodsFor: 'events handling' stamp: ''!
discardDialog

	dialog := nil.
	dialogWindow := nil.! !

!SpRubFindReplaceService methodsFor: 'events handling' stamp: ''!
whenTextAreaLostFocus: anAnnounce
! !

!SpRubFindReplaceService methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	textAreaHolder := WeakArray new: 1 ! !

!SpRubFindReplaceService methodsFor: 'services' stamp: ''!
textArea: aTextArea
	textAreaHolder at: 1 put: aTextArea.
	aTextArea announcer 
		when: RubFindReplaceWindowRequired send: #whenFindReplaceWindowRequired: to: self. 
! !

!SpRubFindReplaceService methodsFor: 'user-interface' stamp: ''!
whenDialogDeleted
! !

!SpRubFindReplaceService methodsFor: 'services' stamp: ''!
findNext

	^ nil! !

!SpRubFindReplaceService methodsFor: 'services' stamp: ''!
replace
	findStartIndex := self searchBackwards 
		ifTrue: [self textArea editor stopIndex] 
		ifFalse: [self textArea editor startIndex].
	(self find)
		ifNotNil: [self textArea replaceSelectionWith: self replaceText]! !

!SpRubFindReplaceService methodsFor: 'accessing' stamp: ''!
findText: aStringOrText
	
	super findText: aStringOrText.
	self textArea whenFindTextChanged: RubFindTextChanged new.
	^ true! !

!SpRubFindReplaceService methodsFor: 'updating' stamp: ''!
findPolicyChanged! !

!SpRubFindReplaceService methodsFor: 'services' stamp: ''!
replaceAll
	| startIdx |
	startIdx := self wrapAround ifTrue: [1] ifFalse: [self textArea editor selectionInterval first].
	self textArea replaceAll: self findRegex with: self replaceText startingAt: startIdx
! !

!SpRubFindReplaceService methodsFor: 'events handling' stamp: ''!
openDialog

	dialogWindow ifNotNil: [ dialogWindow close ].

	dialog := SpRubFindReplaceDialog on: self.
	dialog updateFromModel.

	dialogWindow := dialog openDialogWithSpec! !

!SpRubFindReplaceService methodsFor: 'accessing' stamp: ''!
searchBackwards: aBoolean
	searchBackwards := aBoolean.
	self updateFindStartIndex.
	self findPolicyChanged
! !

!SpRubFindReplaceService methodsFor: 'services' stamp: ''!
find
	| where |
	self setStartIndex.
	where := self findAndSelectRegex.
	where ifNil: [ self textArea flash ].
	^ where! !

!SpRubFindReplaceService methodsFor: 'services' stamp: ''!
findAndSelect
	| where |
	findStartIndex > 0
		ifTrue: [ where := self textArea
				findAndSelect: self findRegex
				startingAt: findStartIndex
				searchBackwards: self searchBackwards ].
	(where isNil and: [ self wrapAround ])
		ifTrue: [ | idx |
			idx := self searchBackwards
				ifTrue: [ self textArea editor string size ]
				ifFalse: [ 1 ].
			where := self textArea
				findAndSelect: self findRegex
				startingAt: idx
				searchBackwards: self searchBackwards ].
	^ where! !

!SpRubFindReplaceService methodsFor: 'services' stamp: ''!
dialogIsActiveFor: aTextArea

 ^ false ! !

!SpRubFindReplaceService methodsFor: 'events handling' stamp: ''!
whenFindReplaceWindowRequired: anAnnouncement

	self textArea hasSelection
		ifTrue: [ self findText: self textArea selection ].

	self openDialog! !

!SpRubFindReplaceService methodsFor: 'accessing' stamp: ''!
caseSensitive
	^ caseSensitive ifNil: [caseSensitive := RubAbstractTextArea caseSensitiveFinds]! !

!SpRubFindReplaceService methodsFor: 'updating' stamp: ''!
updateFindStartIndex
	| si |
	self textArea 
		ifNil: [ ^self ]
		ifNotNil: [ :aTextArea |
			aTextArea changed.
			self changed: #replaceEnabled.
			si := aTextArea selectionInterval.
			self findStartIndex: (self searchBackwards ifTrue: [si first - 1] ifFalse: [si last + 1]) ]! !

!SpRubFindReplaceService methodsFor: 'events handling' stamp: ''!
whenTextAreaGotFocus: anAnnounce
	self textArea: anAnnounce morph.! !

!SpRubFindReplaceService methodsFor: 'services' stamp: ''!
textArea
	^ textAreaHolder at: 1 ! !

!SpRubFindReplaceService methodsFor: 'events handling' stamp: ''!
whenTextAreaSelectionChanged: anAnnouncement 
	self updateFindStartIndex! !

!SpRubFindReplaceService methodsFor: 'updating' stamp: ''!
setStartIndex
	findStartIndex
		ifNil: [ findStartIndex := self searchBackwards
				ifTrue: [ self textArea editor stopIndex ]
				ifFalse: [ self textArea editor startIndex ] ]! !

!SpRubFindReplaceService methodsFor: 'services' stamp: ''!
findAndSelectRegex
	^ self findRegex ifNotNil: [ self findAndSelect ]! !

!SpRubScrolledTextMorph methodsFor: 'accessing' stamp: ''!
drawKeyboardFocus: aBoolean 
	
	self drawFocusBorder: aBoolean! !

!SpRubScrolledTextMorph methodsFor: 'drag and drop' stamp: ''!
acceptDroppingMorph: aTransferMorph event: anEvent

	^ self model model acceptDrop cull: (SpDragAndDropTransfer new
			   passenger: aTransferMorph passenger;
			   yourself)! !

!SpRubScrolledTextMorph methodsFor: 'drag and drop' stamp: ''!
wantsDroppedMorph: aTransferMorph event: anEvent

	^ aTransferMorph isTransferable and: [ 
		  self model model wantsDrop cull: (SpDragAndDropTransfer new
				   passenger: aTransferMorph passenger;
				   yourself) ]! !

!SpRubTextFieldMorph methodsFor: 'accessing' stamp: ''!
drawKeyboardFocus: aBoolean

	self drawFocusBorder: aBoolean.
	drawKeyboardFocus := aBoolean! !

!SpRubTextFieldMorph methodsFor: 'drawing' stamp: ''!
drawKeyboardFocusOn: aCanvas

	drawKeyboardFocus ifFalse: [ ^ self ].
	^ super drawKeyboardFocusOn: aCanvas! !

!SpRubTextFieldMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize. 
	drawKeyboardFocus := true! !

!SpRubTextFieldMorph methodsFor: 'drag and drop' stamp: ''!
acceptDroppingMorph: aTransferMorph event: anEvent

	^ self model model acceptDrop cull: (SpDragAndDropTransfer new
			   passenger: aTransferMorph passenger;
			   yourself)! !

!SpRubTextFieldMorph methodsFor: 'drag and drop' stamp: ''!
wantsDroppedMorph: aTransferMorph event: anEvent

	^ aTransferMorph isTransferable and: [ 
		  self model model wantsDrop cull: (SpDragAndDropTransfer new
				   passenger: aTransferMorph passenger;
				   yourself) ]! !

!SpRunCommandLineHandler commentStamp: ''!
I execute a Mate application.

Usage: run [--list] <applicationName>
 
	list    lists all applications contained in image,
	
Example:

	pharo Pharo.image run HelloWorld
	pharo Pharo.image run IDE!
!SpRunCommandLineHandler methodsFor: 'activation' stamp: ''!
applicationName
	^ applicationName ifNil: [ applicationName := self argumentAt: 1 ]! !

!SpRunCommandLineHandler methodsFor: 'activation' stamp: ''!
runApplication
	| appClass |
	
	appClass := SpApplication 
		findNamed: self applicationName
		ifNone: [ ^ self exitFailure: ('Application {1} not found.' format: { self applicationName }) ].
	
	[ 
		appClass basicNew
			prepareAsStandaloneApplication;
			initialize;
			run ] 
	fork! !

!SpRunCommandLineHandler methodsFor: 'activation' stamp: ''!
listApplications 
	| nl |
	
	nl := Smalltalk platform lineEnding.
	self stdout 
		<< 'List of applications: ' << nl
		<< '---- ' << nl.
	SpApplication findAll do: [ :each | 
		self stdout << each applicationName << nl ].
	
	self exitSuccess! !

!SpRunCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self activateHelpWithoutArguments ifTrue: [ ^ self ].
	(self hasOption: 'list') ifTrue: [ ^ self listApplications ]. 
	self runApplication! !

!SpRunCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'run'! !

!SpScrollSyncExample commentStamp: ''!
I am an example that exposes to the world how to use a ScrollPane announcement to have a nice morph being in sync with the current vertical scrollbar position.

self example!
!SpScrollSyncExample methodsFor: 'private' stamp: ''!
syncMorphPosition
	currentVerticalScrollPosition = text scrollValue y
		ifTrue: [ ^ self ].
	currentVerticalScrollPosition := text scrollValue y.
	self needRebuild: false.
	text needRebuild: false.
	self buildWithSpecLayout: self defaultSpecLayout

	! !

!SpScrollSyncExample methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	currentVerticalScrollPosition := 0! !

!SpScrollSyncExample methodsFor: 'accessing' stamp: ''!
sideRuler
	^ sideRuler! !

!SpScrollSyncExample methodsFor: 'layouts' stamp: ''!
defaultSpecLayout
	<spec>
	
	^ SpBoxLayout newTopToBottom
		add: #sideRuler;
		add: #text;
		yourself! !

!SpScrollSyncExample methodsFor: 'initialization' stamp: ''!
initializePresenters
	text := self newText.
	sideRuler := self newMorph.

	sideRuler
		morph:
			(Morph new
				color: Color yellow;
				extent: 50 @ 500;
				useGradientFill;
				hResizing: #spaceFill;
				vResizing: #spaceFill;
				yourself).

	text whenScrollValueChangedDo: [ :newPosition | self syncMorphPosition ].
	text text: self loremIpsum! !

!SpScrollSyncExample methodsFor: 'private' stamp: ''!
loremIpsum
	^ String loremIpsum: 2854! !

!SpScrollSyncExample methodsFor: 'accessing' stamp: ''!
currentVerticalScrollPosition
	^ currentVerticalScrollPosition! !

!SpScrollSyncExample methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!SpScrollSyncExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	^ SpBoxLayout newLeftToRight
		add: #sideRuler withConstraints: [ :constraints | constraints width: 50 ];
		add: #text;
		yourself! !

!SpScrollSyncExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new openWithSpec! !

!SpScrollSyncExample class methodsFor: 'specs' stamp: ''!
title

	^ self name! !

!SpScrollSyncExampleTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpScrollSyncExample! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
vAlignEnd
	"Sets the vertical align property to END. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment end! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
child: aPresenter

	singleChild ifNotNil: [ self remove: singleChild ].
	self
		add: aPresenter
		withConstraints: [ :constraints | ].
	singleChild := aPresenter.
	self announceChildAdded: aPresenter! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
child

	^ singleChild! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
vAlignCenter
	"Sets the vertical align property to CENTER. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment center! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
hAlign: anAlignment
	"Sets the horizontal align property. See #hAlign to details"
	
	hAlign := anAlignment! !

!SpScrollableLayout methodsFor: 'testing' stamp: ''!
hasAlignment
	"Answer whether the component has any alignment defined"

	^ self hasVAlign or: [ self hasHAlign ]! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
vAlignStart
	"Sets the vertical align property to START. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment start! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
vAlign: anAlignment
	"Sets the vertical align property. See #vAlign to details"

	vAlign := anAlignment! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
hAlignStart
	"Sets the horizontal align property to START. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment start! !

!SpScrollableLayout methodsFor: 'testing' stamp: ''!
hasVAlign
	"Answer whether the component has a vertical alignment defined"

	^ vAlign notNil! !

!SpScrollableLayout methodsFor: 'private' stamp: ''!
constraintsClass

	^ SpBoxConstraints! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
scrollTo: aPoint

	self withAdapterDo: [ :anAdapter |
		anAdapter scrollTo: aPoint ]! !

!SpScrollableLayout methodsFor: 'testing' stamp: ''!
hasHAlign
	"Answer whether the component has an horizontal alignment defined"

	^ hAlign notNil! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
vAlign
	"I define the vertical alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use vAlignStart, vAlignCenter, vAlignEnd"

	^ vAlign! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
remove: aPresenter

	singleChild := nil.
	super remove: aPresenter
	! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
hAlign
	"I define the horizontal alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use hAlignStart, hAlignCenter, hAlignEnd"

	^ hAlign! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
hAlignCenter
	"Sets the horizontal align property to CENTER. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment center! !

!SpScrollableLayout methodsFor: 'private' stamp: ''!
adapterName

	^ #ScrollableAdapter! !

!SpScrollableLayout methodsFor: 'accessing' stamp: ''!
hAlignEnd
	"Sets the horizontal align property to END. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment end! !

!SpScrollableLayout class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpScrollableLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpScrollableLayout class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpScrollableLayout class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpScrollableLayout class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpScrollableLayout class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpScrollableLayout class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpScrollableLayout class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpScrollableLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpScrollableLayout class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpScrollableLayout class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpScrollableLayout class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpScrollableLayout class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpScrollableLayout class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpScrollableLayout class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpScrollableLayout class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpScrollableLayout class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpScrollableLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpScrollableLayout class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpScrollableLayout class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpScrollableLayout class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpScrollableLayout class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpScrollableLayout class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpScrollableLayout class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpScrollableLayout class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpScrollableLayout class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpScrollableLayout class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpScrollableLayout class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpScrollableLayout class methodsFor: 'instance creation' stamp: ''!
with: aSymbolOrPresenter

	^ self new 
		child: aSymbolOrPresenter;
		yourself! !

!SpScrollableLayout class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpScrollableLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveChildAddedAfterOpenRemovesFromAdapter

	| element |
	layout child: (element := SpButtonPresenter new).
	self openInstance.
	
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpScrollableLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveChildElementRemovesFromAdapter

	| element |
	layout child: (element := SpButtonPresenter new).
	layout remove: element.
	self assert: self adapter isEmpty! !

!SpScrollableLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddTwiceReplacesChild

	| first second |
	layout child: (first := SpButtonPresenter new).
	layout child: (second := SpButtonPresenter new).
	self assert: self adapter children first equals: second adapter widget! !

!SpScrollableLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testLayoutWithChildIsNotEmpty

	layout child: SpButtonPresenter new.
	self deny: self adapter isEmpty! !

!SpScrollableLayoutAdapterTest methodsFor: 'accessing' stamp: ''!
newLayout

	^ SpScrollableLayout new! !

!SpScrollableLayoutAdapterTest methodsFor: 'tests' stamp: ''!
testAddTwiceSetsChildrenSingleTime

	| first second |
	layout child: (first := SpButtonPresenter new).
	layout child: (second := SpButtonPresenter new).
	self assert: self adapter children size equals: 1! !

!SpScrollableLayoutExamplePage commentStamp: ''!
I am a demo page for the spec examples demo app to exemplify the use of SpScrollablePresenters!
!SpScrollableLayoutExamplePage methodsFor: 'initialization' stamp: ''!
pageClass

	^SpScrollableLayoutExamplePresenter 
! !

!SpScrollableLayoutExamplePage class methodsFor: 'initialization' stamp: ''!
pageName

	^'Scrollable layout'
! !

!SpScrollableLayoutExamplePresenter commentStamp: ''!
In the current spec status (19/10/2021), I am a documented example of how to use SpScrollableLayouts.!
!SpScrollableLayoutExamplePresenter methodsFor: 'building' stamp: ''!
addTextFieldTo: aLayout

	aLayout
		add: (self newLabel
				 label: 'This is a text field';
				 yourself)
		expand: false
		fill: false
		padding: 5.
	aLayout add: self newText withConstraints: [ :c | c height: 120 ]! !

!SpScrollableLayoutExamplePresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	<script: 'self new openWithSpec'>
	|scrollablePresenter|
	super initializePresenters.
	
	"We initialize the layout to a vertical box layout.
	Presenters will stack vertically."
	layout := SpBoxLayout newTopToBottom.
	
	"For this demo, we add a lot of presenters (here, text fields.
	The idea is to fill the entire vertical space so that we need 
	to scroll up and down to see all the presenters."
	10 timesRepeat: [ self addTextFieldTo: layout ].		

	self flag: 'The following is how SpScrollablePresenter work today. 
	It should change in the future to directly take our box layout as input instead of the following.'.
	"To use a scroll layout, we need to embed our own layout into an intermediate presenter."
	scrollablePresenter := SpPresenter new.
	scrollablePresenter layout: layout.
	
	"We then set our layout to a scrollable layout in which we
	have a single presenter (our intermediate presenter)"
	self layout: (SpScrollableLayout with: scrollablePresenter)! !

!SpSearchInputFieldPresenter commentStamp: ''!
A text field used to search.
It displays an additional "clear" icon.
!
!SpSearchInputFieldPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>
	
	^ self new
		placeholder: 'Search...';
		openWithSpec! !

!SpSearchInputFieldPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #SearchInputFieldAdapter! !

!SpSelectDialog commentStamp: ''!
A dialog that allow the users to select from a list of `items`!
!SpSelectDialog methodsFor: 'api - showing' stamp: ''!
openModalWithSpec
	| dialog |
	
	dialog := super openModalWithSpec.
	^ dialog isOk
		ifTrue: [ list selectedItem ]
		ifFalse: [ nil ]! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
cancelLabel

	^ cancelLabel ifNil: [ self class defaultCancelLabel ]! !

!SpSelectDialog methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	self title: 'Request'! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
label: aString

	label label: aString! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
selectedItem

	^ list selectedItem! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
title: aString

	title := aString! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
acceptLabel

	^ acceptLabel ifNil: [ self class defaultAcceptLabel ]! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
extent

	^ initialExtent ifNil: [ self class defaultExtent ]! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
display: aBlock

	list display: aBlock! !

!SpSelectDialog methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter

	super initializeDialogWindow: aDialogWindowPresenter.
	aDialogWindowPresenter
		addButton: self cancelLabel do: [ :presenter | self cancel ];
		addDefaultButton: self acceptLabel do: [ :presenter | self accept ]! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
items: aCollection

	list items: aCollection! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
acceptLabel: aString

	acceptLabel := aString! !

!SpSelectDialog methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter
		title: self title;
		initialExtent: self extent;
		whenOpenedDo: [ list takeKeyboardFocus ]! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
displayIcon: aBlock

	list displayIcon: aBlock! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
items

	^ list items! !

!SpSelectDialog methodsFor: 'initialization' stamp: ''!
initializePresenters

	label := self newLabel.
	list := self newList.
	
	list addStyle: 'spSelectList'.
	list whenActivatedDo: [ self accept ]! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
extent: aPoint

	initialExtent := aPoint! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
title

	^ title! !

!SpSelectDialog methodsFor: 'api' stamp: ''!
cancelLabel: aString

	cancelLabel := aString! !

!SpSelectDialog class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		borderWidth: 5;
		spacing: 5;
		add: #label expand: false;
		add: #list;
		yourself! !

!SpSelectDialog class methodsFor: 'examples' stamp: ''!
exampleModal
	| selection |

	selection := self new
		title: 'Select modal example';
		label: 'Select a class';
		items: Smalltalk allClassesAndTraits;
		display: [ :each | each name ];
		displayIcon: [ :each | each systemIcon ];
		openModalWithSpec.
		
	selection ifNotNil: [ 
		self inform: selection asString ]! !

!SpSelectDialog class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector
	
	^ #newSelect! !

!SpSelectDialog class methodsFor: 'examples' stamp: ''!
example

	self new
		title: 'Select example';
		label: 'Select a class';
		items: Smalltalk allClassesAndTraits;
		display: [ :each | each name ];
		displayIcon: [ :each | each systemIcon ];
		onAccept: [ :dialog | self inform: dialog presenter selectedItem asString ];
		openDialogWithSpec! !

!SpSelectDialog class methodsFor: 'accessing' stamp: ''!
defaultExtent

	^ 450@300! !

!SpSelectEntity commentStamp: ''!
A to-1 relationship field with keyboard selection with entry completion and a separate dialog for detailed searching (and creating new entities).

See my class side for an example

!
!SpSelectEntity methodsFor: 'accessing' stamp: ''!
selectEntity: anObject
	selectEntity := anObject! !

!SpSelectEntity methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	displaySymbol := #displayString.
	placeholder := 'Choose one'.
	possibleEntities := #().
	selectDialog := [  ]! !

!SpSelectEntity methodsFor: 'api - events' stamp: ''!
whenDisplaySymbolChanged: aBlock
	self property: #displaySymbol whenChangedDo: aBlock! !

!SpSelectEntity methodsFor: 'accessing' stamp: ''!
entityText
	^ entityText! !

!SpSelectEntity methodsFor: 'api - events' stamp: ''!
whenPossibleEntitiesChanged: aBlock
	self property: #possibleEntities whenChangedDo: aBlock! !

!SpSelectEntity methodsFor: 'api' stamp: ''!
placeholder: aString
	placeholder := aString.
	entityText placeholder: aString! !

!SpSelectEntity methodsFor: 'accessing' stamp: ''!
entityText: anObject
	entityText := anObject! !

!SpSelectEntity methodsFor: 'api' stamp: ''!
possibleEntities
	^ possibleEntities ifNil: [ #() ] ifNotNil: [ possibleEntities value ]! !

!SpSelectEntity methodsFor: 'api' stamp: ''!
placeholder
	^ placeholder ifNil: [ '' ]! !

!SpSelectEntity methodsFor: 'api' stamp: ''!
possibleEntities: aBlock
	"Set the block used to return a collection of all possible entity choices"

	possibleEntities := aBlock.
	entityText entryCompletion: self entitiesEntryCompletion! !

!SpSelectEntity methodsFor: 'api' stamp: ''!
displaySymbol
	"return the method selector used to get the label of the entity that is for entry completion"

	^ displaySymbol ifNil: [ #printString ]! !

!SpSelectEntity methodsFor: 'accessing' stamp: ''!
selectEntity
	^ selectEntity! !

!SpSelectEntity methodsFor: 'api' stamp: ''!
entity
	^ entity! !

!SpSelectEntity methodsFor: 'api - events' stamp: ''!
whenSelectDialogChanged: aBlock
	self property: #selectDialog whenChangedDo: aBlock! !

!SpSelectEntity methodsFor: 'api' stamp: ''!
selectDialog
	^ selectDialog! !

!SpSelectEntity methodsFor: 'entryCompletion' stamp: ''!
entitiesEntryCompletion
	^ EntryCompletion new
				dataSourceBlock: [:currText | self possibleEntities collect: [:each | 
		each perform: self displaySymbol ]];
				chooseBlock: [ :selectedName | 
					self entity: (self possibleEntities detect: [ :each | 
						(each perform: self displaySymbol) = selectedName ])];
				filterBlock: [:currEntity :currText | 
					currEntity asUppercase includesSubstring: currText asString asUppercase].! !

!SpSelectEntity methodsFor: 'api' stamp: ''!
displaySymbol: anObject
	displaySymbol := anObject.
	entityText entryCompletion: self entitiesEntryCompletion! !

!SpSelectEntity methodsFor: 'api - events' stamp: ''!
whenEntityChanged: aBlock
	self property: #entity whenChangedDo: aBlock! !

!SpSelectEntity methodsFor: 'api - events' stamp: ''!
whenPlaceholderChanged: aBlock
	"aBlock will be performed when ghostText changed"

	self property: #placeholder whenChangedDo: aBlock! !

!SpSelectEntity methodsFor: 'initialization' stamp: ''!
initializePresenters

	entityText := self newTextInput
		placeholder: self placeholder;
		entryCompletion: self entitiesEntryCompletion;
		yourself.
	selectEntity := self newButton
		icon: (self iconNamed: #glamorousSearch);
		help: 'Open a selection dialog'.
	self focusOrder
		add: entityText;
		add: selectEntity! !

!SpSelectEntity methodsFor: 'initialization' stamp: ''!
connectPresenters
	selectEntity 
		action: [  |select|
			select := self selectDialog value.
			select openDialogWithSpec
				okAction: [  
					self entity: select selectedItem ]]
! !

!SpSelectEntity methodsFor: 'api' stamp: ''!
selectDialog: anObject
	"Set a block that returns an object that will 
	first be sent #openDialogWithSpec
	and then as okAction sent #selectedItem"

	selectDialog := anObject! !

!SpSelectEntity methodsFor: 'api' stamp: ''!
entity: anObject
	entity := anObject.
	anObject ifNotNil: [ self entityText text: (anObject perform: self displaySymbol) ] ifNil: [ self entityText text: '' ]! !

!SpSelectEntity class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: (SpBoxLayout newLeftToRight
				add: #entityText;
				add: #selectEntity expand: false;
				yourself)
			expand: false;
		yourself! !

!SpSelectEntity class methodsFor: '*Spec2-Morphic-Examples' stamp: ''!
example
	self new
		selectDialog: [ SpListPresenter new
				items: #(Henrik Peter);
				yourself ];
		displaySymbol: #asString;
		placeholder: 'Names';
		possibleEntities: [ #(Diego Stephan Norbert Stephane Marcus Torsten Sven Sean) sorted ];
		openDialogWithSpec! !

!SpSelectionPort commentStamp: ''!
# Selection Output Port (`SpSelectionPort`)
A *selection output port* will handle the transmission when a presenter can be selected (e.g. lists).

The presenter exposing a selection output port need to define also the event `#whenSelectionChangedDo:`.

Presenters exposing this port: `SpAbstractListPresenter` subclasses and `SpTreeTablePresenter`!
!SpSelectionPort methodsFor: 'attaching' stamp: ''!
attachTransmission: aTransmission to: aPresenter
		
	aPresenter whenSelectionChangedDo: [ :selection | 
		self 
			transmitWith: aTransmission 
			value: (self applyTransform: selection transmission) ]! !

!SpSelectionPort class methodsFor: 'accessing' stamp: ''!
portName
	
	^ #selection! !

!SpShortcutInstaller commentStamp: ''!
I install shortcuts of Spec commands in my #presenter.!
!SpShortcutInstaller methodsFor: 'accessing' stamp: ''!
presenter: anObject
	presenter := anObject! !

!SpShortcutInstaller methodsFor: 'accessing' stamp: ''!
presenter
	^ presenter! !

!SpShortcutInstaller methodsFor: 'visiting' stamp: ''!
visitCommand: aCmCommand
	aCmCommand hasShortcutKey
		ifFalse: [ ^ self ].
	self presenter
		bindKeyCombination: aCmCommand shortcutKey
		toAction: [ aCmCommand canBeExecuted
				ifTrue: [ aCmCommand execute ] ]! !

!SpSingleSelectionMode commentStamp: ''!
I implement single selection mode (my users can select just one element of list or table)!
!SpSingleSelectionMode methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ self selectedIndex = 0! !

!SpSingleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectIndexes: aCollectionOfIndexes
	"Take first index from `aCollectionOfIndexes` and selects it. Ignore all the rest."

	aCollectionOfIndexes ifEmpty: [ ^ self unselectAll ].
	self selectIndex: aCollectionOfIndexes first.! !

!SpSingleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectItems: aCollection
	"Take first element from `aCollection` and selects it. Ignore all the rest."

	aCollection ifEmpty: [ ^ self unselectAll ].
	self selectItem: aCollection first.! !

!SpSingleSelectionMode methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	selectedIndex := 0! !

!SpSingleSelectionMode methodsFor: 'testing' stamp: ''!
includesItem: anItem

	^ self selectedItem = anItem! !

!SpSingleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedIndex
	"Answer index of current selected element"

	^ selectedIndex! !

!SpSingleSelectionMode methodsFor: 'testing' stamp: ''!
includesIndex: anIndex
	^ self selectedIndex = anIndex! !

!SpSingleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedItem
	"Answer selected item"

	self selectedIndex = 0 ifTrue: [ ^ nil ].
	self widget withAdapterDo: [ :anAdapter |
		^ anAdapter elementAt: self selectedIndex ].
	^ self model at: self selectedIndex! !

!SpSingleSelectionMode methodsFor: 'private' stamp: ''!
basicSelectIndex: indexToSelect
	selectedIndex := indexToSelect! !

!SpSingleSelectionMode methodsFor: 'private' stamp: ''!
selectionHolder
	^ self observablePropertyNamed: #selectedIndex! !

!SpSingleSelectionMode methodsFor: 'api - selection' stamp: ''!
unselectIndex: anInteger
	"Unselect element at index `anInteger`"

	self selectedIndex = anInteger ifTrue: [ self basicSelectIndex: 0 ]! !

!SpSingleSelectionMode methodsFor: 'api - events' stamp: ''!
whenSelectedIndexChangedDo: aBlock

	self property: #selectedIndex whenChangedDo: aBlock! !

!SpSingleSelectionMode methodsFor: 'api - selection' stamp: ''!
unselectAll
	"Unselect current selected element."
	
	self selectIndex: 0! !

!SpSingleSelectionMode methodsFor: 'api - events' stamp: ''!
whenChangedDo: aBlock

	self whenSelectedIndexChangedDo: [ aBlock cull: self ]! !

!SpSingleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectAll
	"Do nothing, since single selection mode wont allow for selecting all elements."! !

!SpSingleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedIndexes
	"Answer an array with a single element containing current selected element index."
		
	^ self isEmpty
		ifTrue: [ #() ]
		ifFalse: [ { self selectedIndex } ]! !

!SpSingleSelectionMode methodsFor: 'api - selection' stamp: ''!
selectedItems
	"Answer an array with a single element, the selected item"
	
	^ self selectedItem
		ifNotNil: [ :anItem | { anItem } ]
		ifNil: [ #() ]! !

!SpSingleSelectionMode methodsFor: '*Spec2-Transmission' stamp: ''!
transmission 
	
	^ self selectedItem! !

!SpSingleSelectionModeTest methodsFor: 'tests' stamp: ''!
testGetRightElementAfterSortingOfElementsChanged
	presenter := SpTablePresenter new. "use a TablePresenter since ListPresenter cannot sort"
	presenter 
		items: (1 to: 10) asArray;
		beSingleSelection;
		openWithSpec.
	
	presenter 
		withAdapterDo: [ :adapter | adapter widget dataSource sortElements: [ :a :b | a > b ] ];
		selectIndex: 3.
	
	self assert: presenter selection selectedItem equals: 8! !

!SpSingleSelectionModeTest methodsFor: 'tests' stamp: ''!
testDropListSelectionIsResetAfterItemsAssignment
	presenter := SpDropListPresenter new.
	presenter
		items: (1 to: 10) asArray;
		selectIndex: 1.

	presenter items: #(2 5).

	self 
		assert: presenter selection selectedItem
		equals: nil! !

!SpSingleSelectionModeTest methodsFor: 'tests' stamp: ''!
testDropListSelectionIsNotAffectedBySorting
	"To get the proper selection when a presenter is sorted, the selection asks the adapter to return the right element according to the sorting.
	DropList does not share the same hierarchy as other lists.
	We need to ensure that drop list is polymorphic with other lists and handle correctly the selection"
	presenter := SpDropListPresenter new.
	presenter 
		items: (1 to: 10) asArray;
		selectIndex: 3;
		openWithSpec.
		
	self assert: presenter selection selectedItem model equals: 3! !

!SpSingleSelectionModeTest methodsFor: 'tests' stamp: ''!
testSelectionIsResetAfterSorting
	presenter := SpTablePresenter new.	"use a TablePresenter since ListPresenter cannot sort"
	presenter
		items: (1 to: 10) asArray;
		beSingleSelection;
		openWithSpec;
		selectIndex: 1.
		
	presenter
		withAdapterDo: [ :adapter | 
			adapter widget dataSource
				sortByColumn: presenter adapter columns first
				event: nil
				morph: nil ].
			
	self assert: presenter selection selectedItem equals: nil! !

!SpSingleSelectionModeTest methodsFor: 'tests' stamp: ''!
testSelectionIsResetAfterItemsAssignment
	presenter
		beSingleSelection;
		openWithSpec;
		selectIndex: 1.

	presenter items: #(2 5).

	self 
		assert: presenter selection selectedItem 
		equals: nil! !

!SpSingleSelectionModeTest methodsFor: 'tests' stamp: ''!
testSubscriptionsAreTransfered
	| count |
	count := 0.
	presenter beSingleSelection.
	presenter whenSelectionChangedDo: [ count := count + 1 ].
	presenter beMultipleSelection.
	presenter selectIndex: 2.
	self assert: count equals: 1! !

!SpSliderInputPresenter commentStamp: ''!
I am an elementary Spec Widget managing a slider and an input.

Self example

Between the bounds min and max of the slider, I ensure that the value of the input on the accept and the value of the slider are the same.

Note
====
- min and max must be set before use me.
- if autoAccept is true, the character '-' could create problems!
!SpSliderInputPresenter methodsFor: 'accessing' stamp: ''!
value: aNumber
	slider value: aNumber ! !

!SpSliderInputPresenter methodsFor: 'accessing' stamp: ''!
input
	^ input! !

!SpSliderInputPresenter methodsFor: 'accessing' stamp: ''!
label: aString
	slider label: aString! !

!SpSliderInputPresenter methodsFor: 'api - events' stamp: ''!
whenValueChangedDo: aBlock
	slider whenValueChangedDo: aBlock! !

!SpSliderInputPresenter methodsFor: 'accessing' stamp: ''!
slider
	^ slider! !

!SpSliderInputPresenter methodsFor: 'accessing' stamp: ''!
min: aNumber
	slider min: aNumber.
	input text: aNumber asString ! !

!SpSliderInputPresenter methodsFor: 'accessing' stamp: ''!
value
	^ slider value! !

!SpSliderInputPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	slider := self newSlider.
	input := self newTextInput
! !

!SpSliderInputPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters

	slider whenValueChangedDo: [ :sliderValue | 
		input text: sliderValue asString ].

	input whenTextChangedDo: [ :text | 
		text isEmpty ifFalse: [ "`text isEmpty` conditional is for avoid converting an empty string into a number because an error is raised." 
			slider value: text asNumber ] ]! !

!SpSliderInputPresenter methodsFor: 'accessing' stamp: ''!
label
	^ slider label! !

!SpSliderInputPresenter methodsFor: 'accessing' stamp: ''!
max: aNumber
	slider max: aNumber! !

!SpSliderInputPresenter class methodsFor: 'specs' stamp: ''!
sliderLeft
	<spec>
	^ SpPanedLayout newLeftToRight
		positionOfSlider: 85 percent;
		add: #slider withConstraints: [ :constraints | constraints beNotResizable ];
		add: #input;
		yourself! !

!SpSliderInputPresenter class methodsFor: 'specs' stamp: ''!
sliderTop
	<spec>
	^ SpBoxLayout newTopToBottom
		add: #slider;
		add: #input withConstraints: [ :constraints | constraints height: self buttonHeight ];
		yourself! !

!SpSliderInputPresenter class methodsFor: 'specs' stamp: ''!
sliderBottom
	<spec>
	^ SpBoxLayout newTopToBottom
		add: #input withConstraints: [ :constraints | constraints height: self buttonHeight ];
		add: #slider;
		yourself! !

!SpSliderInputPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ self sliderLeft! !

!SpSliderInputPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>
	| example |
	example := self new
		min: 0;
		max: 250;
		value: 120;
		extent: 400 @ 50;
		openWithSpec.
	example withWindowDo: [ :window | window title: 'SliderInput example' ].
	^ example! !

!SpSliderInputPresenter class methodsFor: 'specs' stamp: ''!
sliderRight
	<spec>
	^ SpPanedLayout newLeftToRight
		positionOfSlider: 15 percent;
		add: #input;
		add: #slider;
		yourself! !

!SpSliderInputPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpSliderInputPresenter! !

!SpSliderMark methodsFor: 'accessing' stamp: ''!
value: aValue
	value := aValue! !

!SpSliderMark methodsFor: 'accessing' stamp: ''!
text: aText
	text := aText! !

!SpSliderMark methodsFor: 'accessing' stamp: ''!
value
	^ value! !

!SpSliderMark methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!SpSliderPresenter commentStamp: ''!
A presenter that show a slider.
!
!SpSliderPresenter methodsFor: 'api' stamp: ''!
color: aColor

	"Hack because during the interpretation, the state is slightly inconistent"
	self widget ifNotNil: [:w | w == self ifFalse: [ super color: aColor ]]! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
value: aNumber
	"Set the value in a range between min and max"

	value = aNumber ifTrue: [ ^ self ].
	value := aNumber! !

!SpSliderPresenter methodsFor: 'api - events' stamp: ''!
whenAbsoluteValueChangedDo: aBlock
	"Inform when absolute value has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #absoluteValue whenChangedDo: aBlock! !

!SpSliderPresenter methodsFor: 'initialization' stamp: ''!
valueToAbsoluteValue: v
	^ ((v - self min) / (self max - self min)) asFloat! !

!SpSliderPresenter methodsFor: 'api - events' stamp: ''!
whenMaxChangedDo: aBlock 
	"Inform when maximum property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #max whenChangedDo: aBlock! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
beHorizontal
	isHorizontal := true! !

!SpSliderPresenter methodsFor: 'testing' stamp: ''!
isVertical
	^ self isHorizontal not! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
min: anObject
	"Set the minimum value"

	min := anObject! !

!SpSliderPresenter methodsFor: 'testing' stamp: ''!
isHorizontal
	^ isHorizontal! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
beVertical
	isHorizontal := false! !

!SpSliderPresenter methodsFor: 'initialization' stamp: ''!
absoluteValueToValue: v
	^ self min + (v * (self max - self min)) roundTo: self quantum! !

!SpSliderPresenter methodsFor: 'initialization' stamp: ''!
reset
	"Reset the cursor to the minimum value"
	
	self value: self min! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
label
	"Return the label of the slider"

	^ label! !

!SpSliderPresenter methodsFor: 'api - events' stamp: ''!
whenLabelChangedDo: aBlock
	"Inform when label has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #label whenChangedDo: aBlock! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
max: anObject
	"Set the maximun value"

	max := anObject! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
absoluteValue: aFloat
	"Set the position of the slider in a scale between 0 and 1 despite of the min and max value"

	absoluteValue := aFloat! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
absoluteValue
	"Return the position of the slider in a scale between 0 and 1 despite of the min and max value"

	^ absoluteValue! !

!SpSliderPresenter methodsFor: 'initialization' stamp: ''!
initialize
	| isChanging |
	super initialize.

	isHorizontal := true.
	marks := OrderedCollection new.
	max := 100.
	min := 0.
	quantum := 1.
	value := 0.
	absoluteValue := 0.
	label := ''.
	isChanging := false.

	self whenMaxChangedDo: [ :m | self changed: {#max: . m} ].
	self whenMinChangedDo: [ :m | self changed: {#min: . m} ].
	self whenQuantumChangedDo: [ :m | self changed: {#quantum: . m} ].
	self
		whenValueChangedDo: [ :v | 
			isChanging
				ifFalse: [ isChanging := true.
					self absoluteValue: (self valueToAbsoluteValue: v).
					self changed: {#scaledValue: . v}.
					isChanging := false ].
			self changed: #value ].
	self
		whenAbsoluteValueChangedDo: [ :v | 
			isChanging
				ifFalse: [ isChanging := true.
					self value: (self absoluteValueToValue: v).
					self changed: {#value: . v}.
					isChanging := false ] ].
	self whenLabelChangedDo: [ :v | self changed: #label ]! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
label: aString
	"Set the label of the slider"

	label := aString! !

!SpSliderPresenter methodsFor: 'api - events' stamp: ''!
whenMarksChangedDo: aBlock
	"Inform when marks property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #marks whenChangedDo: aBlock! !

!SpSliderPresenter methodsFor: 'api - events' stamp: ''!
whenValueChangedDo: aBlock 
	"Block performed when the value changed"

	self property: #value whenChangedDo: aBlock! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
addMark: aString at: aValue
	"Add the mark `aString` at `aValue` ."
	
	^ self marks: (self marks
		add: (SpSliderMark new
			value: aValue;
			text: aString;
			yourself);
		yourself)! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
marks
	^ marks! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
min
	"Return the minimum value"

	^ min! !

!SpSliderPresenter methodsFor: 'initialization' stamp: ''!
scaleValue: v
	^ ((v - self min) / (self max - self min)) asFloat! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
value
	"Return the current value in a range between min and max"

	^ value! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
quantum
	"Return the quantum betwen values"

	^ quantum! !

!SpSliderPresenter methodsFor: 'api - events' stamp: ''!
whenQuantumChangedDo: aBlock 
	"Block performed when the quantum value changed"

	self property: #quantum whenChangedDo: aBlock! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
marks: anObject
	marks := anObject! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
quantum: aNumber
	"Set the quantum betwen values"

	quantum := aNumber! !

!SpSliderPresenter methodsFor: 'api - events' stamp: ''!
whenMinChangedDo: aBlock 
	"Inform when minimum property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #min whenChangedDo: aBlock! !

!SpSliderPresenter methodsFor: 'api' stamp: ''!
max
	"Return the maximun value"

	^ max! !

!SpSliderPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newSlider! !

!SpSliderPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>
	| slider |
	
	^ (slider := self new)
		min: 0;
		max: 100;
		whenValueChangedDo: [ :value | slider label: value asString ];
		openWithSpec! !

!SpSliderPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #SliderAdapter! !

!SpSliderPresenterBackendTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpSliderPresenter ! !

!SpSliderPresenterBackendTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance
	presenter
		min: 1;
		max: 100;
		quantum: 1;
		value: 20! !

!SpSliderPresenterBackendTest methodsFor: 'tests' stamp: ''!
testSmokeVerticalTest
	self presenter beVertical.
	! !

!SpSliderPresenterBackendTest methodsFor: 'tests' stamp: ''!
testSmokeHorizontalTest
	self presenter beHorizontal.! !

!SpSliderPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpSliderPresenter! !

!SpSliderPresenterTest methodsFor: 'tests' stamp: ''!
testReset
	self initMinMax.
	presenter
		value: 50;
		reset.
	self assert: presenter value == 0! !

!SpSliderPresenterTest methodsFor: 'tests' stamp: ''!
testAbsoluteValueToValueScales
	self initMinMax.
	self assert:  (presenter absoluteValueToValue: 0.5) equals: 50! !

!SpSliderPresenterTest methodsFor: 'tests' stamp: ''!
testValueToAbsoluteValueScales
	self initMinMax.
	self assert:  (presenter valueToAbsoluteValue: 50) equals: 0.5! !

!SpSliderPresenterTest methodsFor: 'tests' stamp: ''!
testAbsoluteValue
	self initMinMax.
	presenter absoluteValue: 0.5.
	self assert: presenter value == 50! !

!SpSliderPresenterTest methodsFor: 'initialization' stamp: ''!
initMinMax

	presenter
		min: 0;
		max: 100! !

!SpSmokeTest commentStamp: ''!
I am an abstract test for Spec widgets.

I use classToTest to initialize an instance. And I can keep the created windows in a variable that I clean after tests.

I provide openInstance and openInstance: to open it. These methods make me keep the created window in the variable.

- testOpenWithSpec tests a call at openWhitSpec, it test the minimal use but can fail in some widgets needing to be initialized.
- testExample tests the class side method example if exist, example should be a representative use.!
!SpSmokeTest methodsFor: 'tests' stamp: ''!
testOpenWithSpec
	"We do not use #shouldnt:raise: to get feedback on the CI"

	[ self openInstance ]
		on: Error
		do: [ :e | 
			self
				fail:
					'Broken class simple instance: ' , self classToTest asString
						,
							'
' , e signalerContext shortStack ]! !

!SpSmokeTest methodsFor: 'tests' stamp: ''!
testExample
	"We do not use #shouldnt:raise: to get feedback on the CI"

	self flag: #todo.	"All widgets should have an example. When it will be done remove this skip"
	(self classToTest respondsTo: #example) ifFalse: [ self skip ].

	[ window := self classToTest example ]
		on: Error
		do: [ :e | 
			self
				fail:
					'Broken class example: ' , self classToTest asString
						,
							'
' , e signalerContext shortStack ]! !

!SpSmokeTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!SpSmokeTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self name = #SpSmokeTest! !

!SpSpecTest class methodsFor: 'testing' stamp: ''!
isAbstract
	^ self = SpSpecTest! !

!SpSpinnerMorph methodsFor: 'stepping and presenter' stamp: ''!
width: aWidth

	super width: aWidth.
	transformationMorph width: aWidth! !

!SpSpinnerMorph methodsFor: 'stepping and presenter' stamp: ''!
initialize

	| wheelImageMorph |
	super initialize.
	self color: Color transparent.
	wheelImageMorph := self newSpinnerMorph.
	
	transformationMorph := TransformationMorph new asFlexOf: wheelImageMorph.
	transformationMorph 
		vResizing: #rigid;
		hResizing: #rigid.

	self addMorph: transformationMorph! !

!SpSpinnerMorph methodsFor: 'stepping and presenter' stamp: ''!
step

	| oldAngle transform |
	oldAngle := transformationMorph rotationDegrees.
	transform := transformationMorph transform withAngle: (oldAngle + 15) degreesToRadians negated.
	transformationMorph
		transform: transform;
		invalidRect: transformationMorph fullBounds! !

!SpSpinnerMorph methodsFor: 'stepping and presenter' stamp: ''!
extent

	^ transformationMorph extent! !

!SpSpinnerMorph methodsFor: 'stepping and presenter' stamp: ''!
spinnerForm

	^ self class spinnerForm! !

!SpSpinnerMorph methodsFor: 'stepping and presenter' stamp: ''!
newSpinnerMorph

	^ self spinnerForm asMorph! !

!SpSpinnerMorph methodsFor: 'stepping and presenter' stamp: ''!
height: aHeight

	super height: aHeight.
	transformationMorph height: aHeight! !

!SpSpinnerMorph methodsFor: 'stepping and presenter' stamp: ''!
wantsSteps

	^ true! !

!SpSpinnerMorph methodsFor: 'stepping and presenter' stamp: ''!
stepTime

	^ 50! !

!SpSpinnerMorph class methodsFor: 'examples' stamp: ''!
example

	self new openInWindow ! !

!SpSpinnerMorph class methodsFor: 'accessing' stamp: ''!
spinnerForm

	SpinnerForm ifNotNil: [ ^ SpinnerForm ].
	^ SpinnerForm := Form
		extent: 40 @ 40
		depth: 32
		fromArray: self spinnerFormContents
		offset: 0 @ 0! !

!SpSpinnerMorph class methodsFor: 'private' stamp: ''!
spinnerFormContents
		
	^ #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1280145589 2202892982 1565292724 71270335 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2773515703 4082664381 4268595409 4082927812 3461381560 90597068 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 911243955 4082401467 4287215086 4287346672 4287346672 4082993860 1615690420 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1582201525 4066479816 4287346672 4287346672 4287346672 4285504213 2370796726 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 743143859 4099047096 4287083756 4287346672 4287280879 4065953472 1431206836 0 0 0 0 0 0 0 156529065 90597068 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 693140660 1766685110 1078950835 0 0 0 0 0 0 0 2303753914 4082270393 4100231370 4065690044 3042016696 16777471 0 0 0 0 0 693140660 3461447096 4182670262 4182735798 2974973368 357071286 0 0 0 0 0 0 0 0 0 0 0 0 1229748917 4098981560 4133786059 4065690044 2370928312 0 0 0 0 0 0 0 810515124 1699641781 1045330868 0 0 0 0 0 0 290158772 3964763319 4252213209 4287280879 4287215086 4184380366 3427892663 16777471 0 0 0 0 0 0 0 0 0 0 0 3545398968 4286228191 4287346672 4287083500 4166024119 156529065 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1833793972 4133720266 4287346672 4287346672 4287346672 4287280880 4065690044 944601782 0 0 0 0 0 0 0 0 0 0 0 3629219513 4286359777 4287346672 4287149294 4166024119 189100985 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2454748341 4285504470 4287346672 4287346672 4287346672 4287346672 4049636551 1498250164 0 0 0 0 0 0 0 0 0 0 0 1464826805 4099047098 4251621328 4065953215 2639363769 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1565292724 4082993603 4287346672 4287346672 4287346672 4287215086 4099047354 709786038 0 0 0 0 0 0 0 0 0 0 0 0 944601782 2119072694 1397521077 16777471 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 71270335 3595664823 4133786059 4286622949 4286425570 4099639234 2790358456 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 206929855 2471722681 3729882808 3595730617 1951366582 41910143 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 390953393 2807070135 3947986359 4115626678 3276963256 944601782 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 324040878 3847257271 4150826190 4286820328 4287083500 4268924632 4098981047 1061976502 0 0 0 1162968501 3947986104 3998252215 1330674356 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2404547767 4133720266 4287346672 4287346672 4287346672 4287346672 4269188060 3662708151 0 0 0 3880811703 4286228449 4286491364 4048583607 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3528621753 4286360034 4287346672 4287346672 4287346672 4287346672 4287346671 4182735542 223245744 0 0 3880811703 4286228449 4286491364 4048583607 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3528621753 4286360034 4287346672 4287346672 4287346672 4287346672 4287346671 4182735542 223245744 0 0 1162968501 3947986103 3998252215 1347385781 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2370796726 4133785802 4287346672 4287346672 4287346672 4287346672 4269187803 3662708151 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 324040878 3847257271 4150826190 4286820328 4287083243 4268990424 4098981047 1061976502 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 390953393 2790358454 3947986359 4115626678 3260120760 944601782 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 156529065 1666021812 2773581495 2589031863 1347189173 41910143 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 357071286 3696196791 4099770563 4285767641 4285636054 4082533052 3058793655 55924138 0 0 0 0 0 0 0 0 0 0 0 0 0 357071286 307527608 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2891021495 4167471820 4287346672 4287346672 4287346672 4287280878 4082795968 1917746613 0 0 0 0 0 0 0 0 0 0 0 0 1028618675 4132404150 4098915254 843872946 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777471 4132404151 4287083500 4287346672 4287346672 4287346672 4287346672 4286293984 3428023993 0 0 0 0 0 0 0 0 0 0 0 0 1984788917 4200697288 4166945476 1783397044 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 206929855 4199513013 4287346672 4287346672 4287346672 4287346672 4287346672 4286754534 3847323064 0 0 0 0 0 0 0 0 0 0 0 0 324040878 3125968569 3042148024 257259451 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3897589175 4286556900 4287346672 4287346672 4287346672 4287346672 4268924631 3042148024 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1800305589 4099244477 4286820328 4287346672 4287346672 4286425570 4132469943 961312946 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2119203766 4115692471 4015621568 4032266942 4048518069 1380809140 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41910143 2689564088 1901165753 0 0 0 0 0 0 0 0 0 223245744 1028618675 860911796 106266538 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 273645487 4216224436 3562044856 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 609056952 340557746 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! !

!SpSpinnerPresenter commentStamp: ''!
A simple spinner.!
!SpSpinnerPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newSpinner! !

!SpSpinnerPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example

	^ self new 
		openWithSpec! !

!SpSpinnerPresenter class methodsFor: 'specs' stamp: ''!
adapterName
	
	^ #SpinnerAdapter! !

!SpStatusBarPresenter commentStamp: ''!
A presenter to render a StatusBar.
A status bar is a simple component that will push messages to be shown in the bar.
In general, this is used to present information to the user in a non-intrusive way, hence it is usually less important (otherwise you should use dialogs, etc.)

A status bar acts as a stack of messages that will be shown to the user. 
The messages can be pushed (See `SpStatusBarPresenter>>#pushMessage:`) and then popped (See `SpStatusBarPresenter>>#popMessage`). !
!SpStatusBarPresenter methodsFor: 'private' stamp: ''!
message: aString
	message := aString! !

!SpStatusBarPresenter methodsFor: 'api' stamp: ''!
popMessage 
	"Pop current message (it will dismiss current message and restore previous one)"
	
	self message: nil.
	self changed: #popMessage! !

!SpStatusBarPresenter methodsFor: 'testing' stamp: ''!
canTakeKeyboardFocus
	"Answer whether the presenter can be focused or not. 
	 In case of `SpStatusBarPresenter`, this message will answer always false."

	^ false! !

!SpStatusBarPresenter methodsFor: 'api' stamp: ''!
pushMessage: aString 
	"Push a new message to the stack (replacing current message with a new one)."
	
	self message: aString.
	self changed: #pushMessage! !

!SpStatusBarPresenter methodsFor: 'api' stamp: ''!
message
	"Answer current shown message."

	^ message! !

!SpStatusBarPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newStatusBar! !

!SpStatusBarPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	| presenter pushButton popButton statusBar count |
	
	(presenter := SpPresenter new)
		layout: (SpBoxLayout newTopToBottom 
			add: (SpBoxLayout newLeftToRight 
				add: (pushButton := presenter newButton);
				add: (popButton := presenter newButton);
				yourself);
			addLast: (statusBar := presenter newStatusBar) expand: false;
			yourself).
		
	count := 0.
	pushButton 
		label: 'Push'; 
		action: [ 
			count := count + 1. 
			statusBar pushMessage: ('Message {1}' format: { count }) ].
	popButton 
		label: 'Pop';
		action: [ 
			statusBar popMessage ].
		
	^ presenter openWithSpec! !

!SpStatusBarPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #StatusBarAdapter! !

!SpStringTableColumn commentStamp: ''!
A column to display strings.
A `SpStringTableColumn` cell can be edited (see `SpStringTableColumn>>#beEditable` and `SpStringTableColumn>>#onAcceptEdition:`)

The user need to set the evaluation block (by sending `SpTableColumn>>#evaluated:`) to answer an image (an instance of `Form`).

## Example
```
SpStringTableColumn 
	title: 'My string' 
	evaluated: [ :anObject | anObject printString ]
```!
!SpStringTableColumn methodsFor: 'api' stamp: ''!
displayBackgroundColor

	^ backgroundColorAction! !

!SpStringTableColumn methodsFor: 'testing' stamp: ''!
isSortable

	^ sortable! !

!SpStringTableColumn methodsFor: 'comparing' stamp: ''!
compareFunction: aBlock
	"sets the sorting of this column to use the two argument aBlock for comparing (aBlock should return a boolean). 
	it is often simpler to use a boolean compare than the threeway compare required by sortFunction: "

	aBlock ifNil: [ 
		super sortFunction: nil. 
		self isSortable: false.
		^ self ].
	
	super sortFunction: [ :a :b| 
		(aBlock value: a value: b) 
			ifTrue:[ -1 ] 
			ifFalse:[ 1 ] ] 
		asSortFunction .
	self isSortable: true! !

!SpStringTableColumn methodsFor: 'private' stamp: ''!
isSortable: aBoolean 

	sortable := aBoolean! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
beSortable

	self isSortable: true! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
displayBold

	^ boldAction! !

!SpStringTableColumn methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	editable := false.
	sortable := false! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
displayItalic: aBlock
	"If `aBlock` answer true, the cell will be displayed in italic.
	 `aBlock` receives one argument (the model element)."

	italicAction := aBlock! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
sortFunction: aBlockOrSortFunction
	"Set the THREEWAY sort function to apply to the values of this column in order to sort elements.
	 `aBlockOrSortFunction` is a block that receives two arguments to compare or an instace of 
	 `SortFunction`. "

	 aBlockOrSortFunction ifNil: [ 
		super sortFunction: nil.
		self isSortable: false.
		^ self ].
	
	super sortFunction: aBlockOrSortFunction asSortFunction.
	self isSortable: aBlockOrSortFunction notNil! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
displayUnderline: aBlock
	"If `aBlock` answer true, the cell will be displayed underlined.
	 `aBlock` receives one argument (the model element)."

	underlineAction := aBlock! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
beNotSortable

	self isSortable: false! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
beNotEditable 
	"Set the cell as not editable (this is the default)."

	editable := false! !

!SpStringTableColumn methodsFor: 'visiting' stamp: ''!
acceptColumnVisitor: aBuilder

	^ aBuilder visitStringColumn: self! !

!SpStringTableColumn methodsFor: 'testing' stamp: ''!
isEditable 
	"Answer true if column has editable cells"
	
	^ editable! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
acceptAction
	"Answer the action (set by `SpStringTablePresenter>>#onAcceptEdition:`) to execute when accepting an edition."
	
	^ acceptAction! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
displayBold: aBlock
	"If `aBlock` answer true, the cell will be displayed in bold.
	 `aBlock` receives one argument (the model element)."

	boldAction := aBlock! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
onAcceptEdition: aBlock
	"Set the block to execute when cell edition is accepted.
	 `aBlock` receives two arguments: 
		- the element of the table (See `SpAbstractListPresenter>>#items:`
		- the string entered while editing"

	acceptAction := aBlock! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
displayColor: aBlock
	"Changes the font color of cells of the column. 
	 `aBlock` receives an argument (the model element) and should answer an instance of Color."

	colorAction := aBlock! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
displayUnderline

	^ underlineAction! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
sortFunction

	^ super sortFunction ifNil: [ self evaluation ascending ]! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
displayColor

	^ colorAction! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
beEditable 
	"Set the cell as editable."

	editable := true! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
displayBackgroundColor: aBlock
	"Changes the background color of cells of the column. 
	 `aBlock` receives an argument (the model element) and should answer an instance of Color. 
	 NOTE: This may be not working at the moment :("

	backgroundColorAction := aBlock! !

!SpStringTableColumn methodsFor: 'api' stamp: ''!
displayItalic

	^ italicAction! !

!SpStringTableColumn class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpStringTableColumn class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpStringTableColumn class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpStringTableColumn class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpStringTableColumn class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpStringTableColumn class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpStringTableColumn class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpStringTableColumn class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpStringTableColumn class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpStringTableColumn class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpStringTableColumn class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpStringTableColumn class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpStringTableColumn class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpStringTableColumn class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpStringTableColumn class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpStringTableColumn class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpStringTableColumn class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpStringTableColumn class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpStringTableColumn class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpStringTableColumn class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpStringTableColumn class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpStringTableColumn class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpStringTableColumn class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpStringTableColumn class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpStringTableColumn class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpStringTableColumn class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpStringTableColumn class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpStringTableColumn class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpStringTableColumn class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpStringTableColumnTest commentStamp: ''!
A SpStringTableColumnTest is a test class for testing the behavior of SpStringTableColumn!
!SpStringTableColumnTest methodsFor: 'tests' stamp: ''!
testIsSortable
	|widget|
	widget := SpStringTableColumn new.
	self deny: widget isSortable.
	widget sortFunction: [:a :b|].
	self assert: widget isSortable.
	widget sortFunction: nil.
	self deny: widget isSortable! !

!SpStubAbstractAdapter commentStamp: ''!
I am an abstract class providing all the properties shared amongs all the stub adapters. They do not produce real views, only stub objects.
!
!SpStubAbstractAdapter methodsFor: 'initialization' stamp: ''!
color: color! !

!SpStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
hSpaceFill! !

!SpStubAbstractAdapter methodsFor: 'factory' stamp: ''!
addPresenterIn: widgetToBuild withSpecLayout: aSpec
	
	! !

!SpStubAbstractAdapter methodsFor: 'compatibility' stamp: ''!
bindKeyCombination: aShortcut toAction: aBlock

! !

!SpStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
add: aWidget! !

!SpStubAbstractAdapter methodsFor: 'initialization' stamp: ''!
borderWidth: width! !

!SpStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
hShrinkWrap
! !

!SpStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
layout: aLayout! !

!SpStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
vShrinkWrap! !

!SpStubAbstractAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ self class new! !

!SpStubAbstractAdapter methodsFor: 'initialization' stamp: ''!
borderColor: color! !

!SpStubAbstractAdapter methodsFor: 'factory' stamp: ''!
takeKeyboardFocus! !

!SpStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
vSpaceFill! !

!SpStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
when: anAnnouncement do: aBlock! !

!SpStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
hRigid! !

!SpStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
vRigid! !

!SpStubAbstractAdapter methodsFor: 'initialization' stamp: ''!
dropEnabled: aBoolean! !

!SpStubAbstractAdapter methodsFor: 'factory' stamp: ''!
useProportionalLayout! !

!SpStubAbstractAdapter methodsFor: 'initialization' stamp: ''!
dragEnabled: aBoolean! !

!SpStubAbstractAdapter methodsFor: 'initialization' stamp: ''!
enabled: aBoolean! !

!SpStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
removeSubWidgets! !

!SpStubAbstractAdapter methodsFor: 'initialization' stamp: ''!
setBalloonText: aString! !

!SpStubAbstractAdapter class methodsFor: 'accessing' stamp: ''!
adaptingName
	"Override me if adapter will not follow the common pattern"

	"remove 'SpStub' part and *in general*, I will have the adapting name"

	^ (self name withoutPrefix: 'SpStub') asSymbol! !

!SpStubAbstractAdapter class methodsFor: 'accessing' stamp: ''!
allAdapters

	^ self allSubclasses! !

!SpStubAdapterBindings commentStamp: ''!
I am used to link the Spec presenter names to the stub adapters that generate no real views.

Usefull  for images or UI managers without possible real UI output or  for tests. Can serve as template for real Spec adapters

Usage:

CurrentSpecDefaultBindings value: SpecStubAdapterBindings during: [ 
	ButtonPresenter new openWithSpec.
].!
!SpStubAdapterBindings methodsFor: 'initialize' stamp: ''!
abstractAdapterClass
	^ SpStubAbstractAdapter! !

!SpStubBoxAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ SpStubBoxView new! !

!SpStubBoxAdapter methodsFor: 'factory' stamp: ''!
basicAdd: aPresenter constraints: constraints to: aPanel! !

!SpStubButtonAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubButtonView new! !

!SpStubButtonView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubCheckBoxAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubCheckBoxAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubCheckBoxView new! !

!SpStubCheckBoxView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubCodeAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubCodeView new! !

!SpStubContainerAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubContainerAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubContainerView new! !

!SpStubContainerView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubDialogWindowAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubDialogWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubDialogWindowView new! !

!SpStubDialogWindowView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubDiffAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubDiffAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubDiffView new! !

!SpStubDiffView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubDropListAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubDropListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubDropListView new! !

!SpStubDropListView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubFastTableAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubFastTableAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubFastTableView new! !

!SpStubFastTableView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubGridAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ SpStubGridView new! !

!SpStubIconListAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubIconListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubIconListView new! !

!SpStubIconListView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubImageAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubImageAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubImageView new! !

!SpStubImageView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubLabelAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubLabelAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubLabelAdapter new! !

!SpStubLayoutAdapter methodsFor: 'factory' stamp: ''!
add: aPresenter constraints: constraints! !

!SpStubListAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubListAdapter methodsFor: 'factory' stamp: ''!
refreshWidgetList
! !

!SpStubListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubListView new! !

!SpStubListAdapter methodsFor: 'factory' stamp: ''!
refreshWidgetSelection
! !

!SpStubListView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubMenuAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubMenuAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubMenuView new! !

!SpStubMenuGroupAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubMenuGroupAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubMenuGroupView new! !

!SpStubMenuGroupView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubMenuItemAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubMenuItemAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubMenuItemView new! !

!SpStubMenuItemView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubMenuView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubMultiColumnListAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubMultiColumnListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubMultiColumnListView new! !

!SpStubMultiColumnListView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubNumberInputFieldAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubNumberInputFieldAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ SpStubNumberInputFieldView new! !

!SpStubNumberInputFieldView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubPanedAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ SpStubPanedView new! !

!SpStubRadioButtonAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubRadioButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubRadioButtonView new! !

!SpStubRadioButtonView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubSliderAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubSliderAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubSliderView new! !

!SpStubSliderView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubSpacerAdapter commentStamp: ''!
Stub!
!SpStubSpacerAdapter methodsFor: 'factory' stamp: ''!
buildWidget
	^ SpStubSpacerView new! !

!SpStubSpacerView commentStamp: ''!
Stub!
!SpStubTabAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubTabAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubTabView new! !

!SpStubTabManagerAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubTabManagerAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubTabManagerView new! !

!SpStubTabManagerView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubTabView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubTableContainerAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubTableContainerAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubTableContainerView new! !

!SpStubTableContainerView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubTextAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubTextAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubTextView  new! !

!SpStubTextInputFieldAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubTextInputFieldAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubTextInputFieldView new! !

!SpStubTextInputFieldView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubTextView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubTickingWindowAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubTickingWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubTickingWindowView new! !

!SpStubTickingWindowView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubToolbarAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubToolbarAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubToolbarView new! !

!SpStubTransferAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubTransferAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubTransferView new! !

!SpStubTransferView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubTreeAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubTreeAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubTreeView new! !

!SpStubTreeColumnAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubTreeColumnAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubTreeColumnView new! !

!SpStubTreeColumnView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubTreeNodeAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubTreeNodeAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubTreeNodeView new! !

!SpStubTreeNodeView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubTreeView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStubView commentStamp: ''!
I am an abstract stub view. My subclasses do not display any real UI component!
!SpStubView methodsFor: 'compatibility' stamp: ''!
bindKeyCombination: aShortcut toAction: aBlock

	! !

!SpStubWindowAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpStubWindowAdapter methodsFor: 'factory' stamp: ''!
addPresenterIn: widgetToBuild withSpecLayout: aSpec
	self
		addContent: (self model presenter buildWithSpecLayout: aSpec)
		toWindow: widgetToBuild! !

!SpStubWindowAdapter methodsFor: 'factory' stamp: ''!
delete! !

!SpStubWindowAdapter methodsFor: 'factory' stamp: ''!
open

	self presenter windowIsOpened! !

!SpStubWindowAdapter methodsFor: 'factory' stamp: ''!
beep! !

!SpStubWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpStubWindowView new! !

!SpStubWindowAdapter methodsFor: 'factory' stamp: ''!
title: aString! !

!SpStubWindowAdapter methodsFor: 'factory' stamp: ''!
addContent: aView toWindow: aSpecWindow

! !

!SpStubWindowAdapter methodsFor: 'factory' stamp: ''!
close! !

!SpStubWindowView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpStyle commentStamp: ''!
!! Stylesheets for Morphic backend

A style is a property container to "style" morphic components, and define (in a certain degree) its behaviour within the different layouts implemented.
There are two kinds of style elements: style classes and style properties.

!!!! Stylesheet STON format
To easy the definition and storage outside an image, a stylesheet may be defined as a STON file, string or stream, that you can later read using *class:SpStyleSTONReader*.
A defined stylesheet has to have always a root element, and this root element needs to be called ==.application==. 

See this small example: 

[[[language=Smalltalk
SpStyleSTONReader fromString: '
.application [  
	.myButton [
		Geometry { #width: 150 }
	]
]'
]]]

As a more complex example, see *method:SpStyle class#createDefaultStyleSheet* who defines the default behaviour of all elements of a Morphic Spec backend.

!!!! Referencing style elements in your presenters
You can add styles to your presenters easily by using *class:SpAbstractWidgetPresenter>>#addStyle:*

@@TODO more examples

See *class:SpStyleClass*, *class:SpStyleProperty*, *class:SpMorphStyle*!
!SpStyle methodsFor: 'testing' stamp: ''!
isStyleClass

	^ false! !

!SpStyle methodsFor: 'testing' stamp: ''!
isStyleProperty

	^ false! !

!SpStyle methodsFor: 'operations' stamp: ''!
applyTo: aMorph

	self subclassResponsibility! !

!SpStyle class methodsFor: 'instance creation' stamp: ''!
newApplication

	^ SpClassStyle new 
		name: 'application';
		yourself! !

!SpStyle class methodsFor: 'private' stamp: ''!
createDefaultStyleSheet

	^ SpStyleVariableSTONReader fromString: self defaultStyleSheetData
	! !

!SpStyle class methodsFor: 'accessing' stamp: ''!
defaultStyleSheet

	self flag: #TODO. "This is wrong. Default style sheet should reside in the Pharo application, 
	but since we do not have that abstraction (yet) in the system, we put it here for now"
	^ DefaultStyleSheet ifNil: [ 
		DefaultStyleSheet := self createDefaultStyleSheet ].
! !

!SpStyle class methodsFor: 'private' stamp: ''!
defaultStyleSheetData

	^'
.application [
	Font { #name : EnvironmentFont(#default) },
	Geometry { #height: 25 },
	.box [ Geometry { #height: Reset, #vResizing: true, #hResizing: true } ],
	.label [
		Geometry { #hResizing: true, #height: 18 },
		.headerError [ Draw { #color:  #red }  ],
		.headerSuccess [ Draw { #color: #green } ],
		.header [ Draw { #color: Color{ #rgb: 622413393 } } ],
		.shortcut [ Draw { #color: Color{ #rgb: 622413393 } } ],
		.fixed [ Geometry { #hResizing: false, #width: 100 } ],
		.dim [ Draw { #color : Color{ #rgb: 708480675 } } ]
	],
	.notebookLabel [ 
		Geometry { #minWidth: 90 } 
	],
	.link [ Geometry { #hResizing: true } ],
	.button [  
		Geometry { #width: 100, #height: 30 },
		.small [ Geometry { #width: 25, #height: 25 } ]
	],
	.checkBox [  
		Geometry { #hResizing: true },
		.compact [ Geometry { #hResizing: false, #width: 20 } ]
	],
	.radioButton [ Geometry { #hResizing: true } ],
	.dropList [ Geometry { #width: 150, #hResizing: true } ],
	.list [ Geometry { #width: 150, #minHeight: 125, #hResizing: true, #vResizing: true } ],
	.slider [ Geometry { #width: 150, #hResizing: true } ],
	.actionBar [  
		Container { #borderWidth: 0, #padding: 5 },
		Geometry { #width: 150, #height: 29, #hResizing: true, #vResizing: false }
	],
	.menuBar [ Geometry { #width: 150, #hResizing: true } ],
	.actionButton [  
		Geometry { #width: 70, #hResizing: false },
		.showIcon [ Geometry { #width: 25 } ]
	],
	.selected [ Container { #borderWidth: 1 } ],
	.unselected [ Container { #borderWidth: 0 } ],
	.toolbar [ 
		Geometry { #height: Reset, #hResizing: true },
		.icons [ Geometry { #height: 30 } ],
		.iconsAndLabel [ Geometry { #height: 45 } ]
	],
	.text [ Geometry { #height: Reset } ],
	.code [ Font { #name: EnvironmentFont(#code) } ],
	.patch [ Font { #name: EnvironmentFont(#code) } ],
	.codePopover [ 
		Draw { #color : #transparent },
		.button [ Geometry { #width : 25 } ]
	],
	.codePopoverError [ 
		Draw { #backgroundColor: #C20000 },
		Font { #color: #white } 
	],
	.scrollbarPopoverLarge [ Geometry { #height: 350 } ],
	.popover [
		.print [ Draw { #color: EnvironmentColor(#balloonBackground) } ],
		.error [ Draw { #color: #C20000 } ],
		.popoverButton [ Draw { #color: EnvironmentColor(#popoverButton) } ] ],
	.paginator [ Geometry { #height: 20 } ],
	.morph [ 
		Geometry { #width: Reset, #height: Reset, #vResizing: true, #hResizing: true },
		Font { #name: Reset } ],
	.image [ Geometry { #width: Reset, #height: Reset, #vResizing: true, #hResizing: true } ] ]
'! !

!SpStyle class methodsFor: 'class initialization' stamp: ''!
reset 
	<script>

	DefaultStyleSheet := nil! !

!SpStyleAbstractVariable commentStamp: ''!
An abstract variable to be used for style properties (values will be expressed in instance of `SpStyleAbstractVariable` children instead its _atomic_ values.!
!SpStyleAbstractVariable methodsFor: 'evaluating' stamp: ''!
preferredValueWith: anObject

	^ self value! !

!SpStyleAbstractVariable methodsFor: 'evaluating' stamp: ''!
preferredScaledValueWith: anObject

	^ self value! !

!SpStyleAbstractVariable methodsFor: 'evaluating' stamp: ''!
scaledValue

	^ self value! !

!SpStyleAbstractVariable methodsFor: 'evaluating' stamp: ''!
value

	^ self subclassResponsibility! !

!SpStyleAbstractVariable methodsFor: 'testing' stamp: ''!
isEnvironmentVariable

	^ false! !

!SpStyleAbstractVariable methodsFor: 'converting' stamp: ''!
asStyleVariable

	^ self! !

!SpStyleEnvironmentColorVariable commentStamp: ''!
A variable to access environment colors (defined in `UITheme` and subclasses) !
!SpStyleEnvironmentColorVariable methodsFor: 'evaluating' stamp: ''!
valueAsColor
	
	^ self value! !

!SpStyleEnvironmentColorVariable methodsFor: 'evaluating' stamp: ''!
value

	self name ifNil: [ ^ nil ].
	^ Smalltalk ui theme perform: (self name, 'Color') asSymbol! !

!SpStyleEnvironmentColorVariable class methodsFor: 'documentation' stamp: ''!
documentExampleCode

	^ 'Draw { #color: EnvironmentColor(#background) }'! !

!SpStyleEnvironmentColorVariable class methodsFor: 'ston-core' stamp: ''!
stonName

	^ 'EnvironmentColor'! !

!SpStyleEnvironmentColorVariable class methodsFor: 'documentation' stamp: ''!
documentValidValues

	^ UITheme selectors
		select: [ :each | 
			(each endsWith: 'Color') 
				and: [ ((UITheme current perform: each) isKindOf: Color) ] ]
		thenCollect: [ :each | each allButLast: 5 ]! !

!SpStyleEnvironmentFontVariable commentStamp: ''!
A variable to access environment fonts (defined in `StandardFonts class`).
This variable must be used to assign the attribute `name` of a `SpStyleFont` property.!
!SpStyleEnvironmentFontVariable methodsFor: 'evaluating' stamp: ''!
value

	^ StandardFonts perform: (self name, 'Font') asSymbol! !

!SpStyleEnvironmentFontVariable methodsFor: 'accessing' stamp: ''!
name

	^ super name ifNil: [ #default ]! !

!SpStyleEnvironmentFontVariable methodsFor: 'accessing' stamp: ''!
familyName

	^ self value familyName! !

!SpStyleEnvironmentFontVariable methodsFor: 'accessing' stamp: ''!
pointSize

	^ self value pointSize! !

!SpStyleEnvironmentFontVariable class methodsFor: 'documentation' stamp: ''!
documentExampleCode

	^ 'Font { #name: EnvironmentFont(#default) }'! !

!SpStyleEnvironmentFontVariable class methodsFor: 'ston-core' stamp: ''!
stonName

	^ 'EnvironmentFont'! !

!SpStyleEnvironmentFontVariable class methodsFor: 'documentation' stamp: ''!
documentValidValues

	^ StandardFonts class selectors 
		select: [ :each | each endsWith: 'Font' ]
		thenCollect: [ :each | each allButLast: 4 ]! !

!SpStyleEnvironmentVariable commentStamp: ''!
A base for environment variables (values that point to values in the environment).!
!SpStyleEnvironmentVariable methodsFor: 'testing' stamp: ''!
isEnvironmentVariable

	^ true! !

!SpStyleEnvironmentVariable methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!SpStyleEnvironmentVariable methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!SpStyleEnvironmentVariable methodsFor: 'instance creation' stamp: ''!
fromSton: stonReader

	self name: stonReader parseContainedValue! !

!SpStyleEnvironmentVariable class methodsFor: 'documentation' stamp: ''!
documentExampleCode

	^ '(none)'! !

!SpStyleEnvironmentVariable class methodsFor: '*Spec2-Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	super buildMicroDownUsing: aBuilder withComment: aString.
	self addDocumentExample: aBuilder.
	self addDocumentValidValues: aBuilder	
! !

!SpStyleEnvironmentVariable class methodsFor: 'ston-core' stamp: ''!
stonName

	^ 'Environment'! !

!SpStyleEnvironmentVariable class methodsFor: 'documentation' stamp: ''!
addDocumentValidValues: aBuilder	

	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Valid values' ] withLevel: 2.
	aBuilder newLine.
	aBuilder unorderedListDuring: [  
		(self documentValidValues sorted) do: [ :each |
			aBuilder item: [
				aBuilder monospace: '#', each asString ] ] ]	! !

!SpStyleEnvironmentVariable class methodsFor: 'documentation' stamp: ''!
documentValidValues
	
	^ #()! !

!SpStyleEnvironmentVariable class methodsFor: 'documentation' stamp: ''!
addDocumentExample: aBuilder

	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Example' ] withLevel: 2.
	aBuilder newLine.
	aBuilder monospace: self documentExampleCode! !

!SpStyleResetVariable commentStamp: ''!
A variable to reset previous values. 
This variable has to be used when user want to override the value of a parent property and replace it for the default value.

## Example

`Geometry { #height: Reset }`!
!SpStyleResetVariable methodsFor: 'evaluating' stamp: ''!
preferredValueWith: anObject

	^ nil! !

!SpStyleResetVariable methodsFor: 'evaluating' stamp: ''!
value

	^ nil! !

!SpStyleResetVariable methodsFor: 'instance creation' stamp: ''!
fromSton: stonReader! !

!SpStyleResetVariable class methodsFor: 'ston-core' stamp: ''!
stonName

	^ 'Reset'! !

!SpStyleSTONReader commentStamp: ''!
I am a STON reader specialised on reading an SpStyle.

Contrary to my parent, I accept .class [ ... ] constructions.!
!SpStyleSTONReader methodsFor: 'parsing' stamp: ''!
parseSimpleValue
	| char |

	readStream atEnd ifFalse: [ 
		char := readStream peek.
		(self isStyleClassChar: char) ifTrue: [ 
			^ self parseStyleClass ] ].

	^ super parseSimpleValue! !

!SpStyleSTONReader methodsFor: 'private' stamp: ''!
styleClasses

	^ SpStyle allSubclasses, Color withAllSubclasses! !

!SpStyleSTONReader methodsFor: 'private' stamp: ''!
styleClass

	^ SpClassStyle! !

!SpStyleSTONReader methodsFor: 'private' stamp: ''!
lookupClass: name

	"The SpStyleSTONReader only looks for ston names in the hierarchy of SpStyle"
	
	^ classes 
		at: name 
		ifAbsentPut: [ 
			self styleClasses 
				detect: [ :class | class isMeta not and: [ class stonName = name ]  ]
				ifNone: [ NotFound signalFor: name ] ]! !

!SpStyleSTONReader methodsFor: 'parsing' stamp: ''!
parseStyleClass
	| name reference style |

	[
		reference := self newReference.
		name := self parseStyleName.
		style := self styleClass new
			name: name;
			parent: currentStyle;
			yourself.
		self 
			pushStyle: style 
			during: [ style fromSton: self ]. 
		self setReference: reference to: style ]
	on: NotFound 
	do: [ :notFound |
		acceptUnknownClasses 
			ifTrue: [ 
				style := STON mapClass new.
				self storeReference: style.
				self parseMapDo: [ :key :value |
					style at: key put: value ].
				style at: STON classNameKey put: notFound object ]
			ifFalse: [ self error: 'Cannot resolve class named ', notFound object printString ] ].
	
	^ style! !

!SpStyleSTONReader methodsFor: 'private parsing' stamp: ''!
parseStyleName
	| styleName |

	readStream next. "ignore dot"
	styleName := self stringStreamContents: [ :stream |
		[ readStream atEnd not and: [ self isClassChar: readStream peek ] ] whileTrue: [ 
			stream nextPut: readStream next ] ].
	self consumeWhitespace.
	^ styleName asString! !

!SpStyleSTONReader methodsFor: 'accessing' stamp: ''!
pushStyle: aStyle during: aBlock
	| oldStyle |
	
	oldStyle := currentStyle.
	currentStyle := aStyle.
	aBlock ensure: [ 
		currentStyle := oldStyle ]! !

!SpStyleSTONReader methodsFor: 'private' stamp: ''!
isStyleClassChar: char 

	^ char = $.! !

!SpStyleSTONReader class methodsFor: 'instance creation' stamp: ''!
fromString: aString

	^ self fromStream: aString readStream! !

!SpStyleSTONReader class methodsFor: 'instance creation' stamp: ''!
fromStream: readStream

	^ (self on: readStream) next! !

!SpStyleTest methodsFor: 'running' stamp: ''!
tearDown 

	aClass ifNotNil: [ :e | e removeFromSystem ].
	super tearDown! !

!SpStyleTest methodsFor: 'tests' stamp: ''!
testParsingAStyleIsNotAffectedByExistingClass

	| aStylesheet |

	aClass := Object subclass: #Font.
	aStylesheet := SpStyle createDefaultStyleSheet.
	
	self assert: aStylesheet styles isNotEmpty
	
	! !

!SpStyleVariable commentStamp: ''!
A holder for an attribute `atomic` value.
It holds numbers, strings, symbols.!
!SpStyleVariable methodsFor: 'accessing' stamp: ''!
value: anObject

	value := anObject! !

!SpStyleVariable methodsFor: 'evaluating' stamp: ''!
preferredValueWith: anObject

	^ self value = 0 
		ifTrue: [ anObject ]
		ifFalse: [ self value ]! !

!SpStyleVariable methodsFor: 'evaluating' stamp: ''!
preferredScaledValueWith: anObject

	^ self value = 0 
		ifTrue: [ anObject ]
		ifFalse: [ self scaledValue ]! !

!SpStyleVariable methodsFor: 'evaluating' stamp: ''!
valueAsColor

	^ self toColor: self value! !

!SpStyleVariable methodsFor: 'private' stamp: ''!
toColor: aColorOrSymbol

	"Try if color"
	aColorOrSymbol isSymbol ifFalse: [ ^ aColorOrSymbol ].
	"Try by name"
	(Color named: aColorOrSymbol) ifNotNil: [ :aColor | ^ aColor ]. 
	"Try by HEX (CSS style)"				
	^ Color fromHexString: aColorOrSymbol! !

!SpStyleVariable methodsFor: 'evaluating' stamp: ''!
scaledValue

	^ (self value ifNil: [ 0 ]) * self currentWorld displayScaleFactor! !

!SpStyleVariable methodsFor: 'evaluating' stamp: ''!
value

	^ value! !

!SpStyleVariable class methodsFor: 'ston-core' stamp: ''!
stonName

	^ 'Variable'! !

!SpStyleVariable class methodsFor: 'instance creation' stamp: ''!
newValue: anObject

	^ self new 
		value: anObject;
		yourself! !

!SpStyleVariableSTONReader methodsFor: 'parsing' stamp: ''!
parseSimpleValue
	| char |

	readStream atEnd ifFalse: [ 
		char := readStream peek.
		(self isContainedValueChar: char) ifTrue: [ 
			^ self parseContainedValue ] ].

	^ super parseSimpleValue! !

!SpStyleVariableSTONReader methodsFor: 'private' stamp: ''!
styleClasses

	^ super styleClasses, SpStyleAbstractVariable allSubclasses! !

!SpStyleVariableSTONReader methodsFor: 'parsing' stamp: ''!
parseNamedInstVarsFor: anObject

	self parseMapDo: [ :instVarName :value |
		anObject 
			instVarNamed: instVarName asString 
			put: value asStyleVariable ]! !

!SpStyleVariableSTONReader methodsFor: 'parsing' stamp: ''!
parseContainedValue
	| result | 

	self parseContainedValueDo: [ :aValue | result := aValue ].

	^ result
! !

!SpStyleVariableSTONReader methodsFor: 'parsing' stamp: ''!
parseContainedValueDo: block

	self expectChar: $(.
	(self matchChar: $)) ifTrue: [ ^ self ]. "short cut for empty value"
	[ readStream atEnd ] whileFalse: [
		block cull: self parseValue.
		(self matchChar: $)) ifTrue: [ ^ self ]  ].

	self error: 'end of contained value expected'! !

!SpStyleVariableSTONReader methodsFor: 'parsing' stamp: ''!
isContainedValueChar: char

	^ char = $(! !

!SpStyleVariableTest methodsFor: 'tests' stamp: ''!
testParseResetVariable
	| property |

	property := SpStyleVariableSTONReader fromString: 'Geometry { #vResizing: Reset }'.
	self assert: property vResizing isNil.
	self assert: property vResizingVariable value isNil! !

!SpStyleVariableTest methodsFor: 'tests' stamp: ''!
testParseBasicValue
	| property |

	property := SpStyleVariableSTONReader fromString: 'Geometry { #height: 25 }'.
	self assert: property height equals: 25.
	self assert: property heightVariable value equals: 25! !

!SpStyleVariableTest methodsFor: 'tests' stamp: ''!
testParseColorVariable
	| property |

	property := SpStyleVariableSTONReader fromString: 'Container { #borderColor: #red }'.
	self assert: property borderColor equals: #red.
	self assert: property borderColorVariable value equals: #red.
	self assert: property borderColorVariable valueAsColor equals: Color red.
	
	property := SpStyleVariableSTONReader fromString: 'Container { 
		#borderColor: Color { #red:1, #green:0, #blue:0, #alpha:1 } }'.
	self assert: property borderColor equals: Color red.
	self assert: property borderColorVariable value equals: Color red.
	self assert: property borderColorVariable valueAsColor equals: Color red! !

!SpStyleVariableTest methodsFor: 'tests' stamp: ''!
testParseFontVariable
	| property |
	
	property := SpStyleVariableSTONReader fromString: 'Font { #name: EnvironmentFont(#code) }'.
	self assert: property nameVariable class equals: SpStyleEnvironmentFontVariable.
	self assert: property nameVariable value equals: StandardFonts codeFont.	
! !

!SpSystemDiscoveryCommand commentStamp: ''!
My subclasses implement commands related to the live system discovery and exploration.!
!SpSystemDiscoveryCommand class methodsFor: 'default' stamp: ''!
defaultIconName
	^ #smallObjects! !

!SpSystemNavigationCommand commentStamp: ''!
My subclasses implement commands related to system navigation.
I give a selector from a context that must:
- be a block
- evaluate to a string or symbol!
!SpSystemNavigationCommand methodsFor: 'accessing' stamp: ''!
selector

	^ self target trimBoth asSymbol! !

!SpSystemNavigationCommand methodsFor: 'accessing' stamp: ''!
systemNavigation

	^ self context systemNavigation
		environment: self environment;
		yourself! !

!SpSystemNavigationCommand methodsFor: 'accessing' stamp: ''!
environment

	^ self context environment! !

!SpSystemNavigationCommand class methodsFor: 'documentation' stamp: ''!
documentContextRequiredSelectors
	"Using a String and not a Symbol because `RBBrowserEnvironmentTest>>#testMatches` fails 
	 if answering a symbol (because it detects the referenced selector)"

	^ #('environment')! !

!SpSystemNavigationCommand class methodsFor: 'default' stamp: ''!
defaultIconName
	^#smallSystemBrowser ! !

!SpSystemNavigationCommand class methodsFor: 'default' stamp: ''!
defaultName
	^'Browse ', self shortName ! !

!SpSystemNavigationCommand class methodsFor: 'default' stamp: ''!
shortName
	^self subclassResponsibility ! !

!SpSystemSelectionCommand commentStamp: ''!
A base for commands working on current text selection.!
!SpSystemSelectionCommand methodsFor: 'accessing' stamp: ''!
selectedTextOrLine

	^ self context selectedTextOrLine! !

!SpSystemSelectionCommand methodsFor: 'private' stamp: ''!
evaluate: aString ifError: aBlock

	^ [
		self class compilerClass new
			environment: self environment;
			class: UndefinedObject;
			source: self selectedTextOrLine;
			evaluate ]
		on: Error 
		do: aBlock
	! !

!SpSystemSelectionCommand methodsFor: 'private' stamp: ''!
selectedSelector
	| node selection |
	
	selection := self selectedTextOrLine.
	node := RBParser parseFaultyExpression: selection.
	node nodesDo: [ :n | 
		n isMessage ifTrue: [ ^ n selector ].
		n isVariable ifTrue: [ ^ n name ].
		n isLiteralNode ifTrue: [ ^ n value ] ].
	"fall back"
	^ selection trimmed asSymbol! !

!SpSystemSelectionCommand class methodsFor: 'documentation' stamp: ''!
documentContextRequiredSelectors

	^ super documentContextRequiredSelectors, #(selectedTextOrLine)! !

!SpTAlignable commentStamp: ''!
I add alignment properties to layouts. 
Alignments can be added by layout basis (see SpBoxLayout) or widget basis (see SpGridConstraints).!
!SpTAlignable methodsFor: 'accessing' stamp: ''!
vAlignEnd
	"Sets the vertical align property to END. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment end! !

!SpTAlignable methodsFor: 'accessing' stamp: ''!
vAlignCenter
	"Sets the vertical align property to CENTER. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment center! !

!SpTAlignable methodsFor: 'accessing' stamp: ''!
hAlign: anAlignment
	"Sets the horizontal align property. See #hAlign to details"
	
	hAlign := anAlignment! !

!SpTAlignable methodsFor: 'testing' stamp: ''!
hasAlignment
	"Answer whether the component has any alignment defined"

	^ self hasVAlign or: [ self hasHAlign ]! !

!SpTAlignable methodsFor: 'accessing' stamp: ''!
vAlignStart
	"Sets the vertical align property to START. See #vAlign for details"

	self vAlign: SpLayoutWidgetAlignment start! !

!SpTAlignable methodsFor: 'accessing' stamp: ''!
vAlign: anAlignment
	"Sets the vertical align property. See #vAlign to details"

	vAlign := anAlignment! !

!SpTAlignable methodsFor: 'accessing' stamp: ''!
hAlignStart
	"Sets the horizontal align property to START. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment start! !

!SpTAlignable methodsFor: 'testing' stamp: ''!
hasVAlign
	"Answer whether the component has a vertical alignment defined"

	^ vAlign notNil! !

!SpTAlignable methodsFor: 'testing' stamp: ''!
hasHAlign
	"Answer whether the component has an horizontal alignment defined"

	^ hAlign notNil! !

!SpTAlignable methodsFor: 'accessing' stamp: ''!
vAlign
	"I define the vertical alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use vAlignStart, vAlignCenter, vAlignEnd"

	^ vAlign! !

!SpTAlignable methodsFor: 'accessing' stamp: ''!
hAlign
	"I define the horizontal alignment of the widgets in the layout.
	 aligns can be start, center and end. 
	 To set this value, you can use hAlignStart, hAlignCenter, hAlignEnd"

	^ hAlign! !

!SpTAlignable methodsFor: 'accessing' stamp: ''!
hAlignCenter
	"Sets the horizontal align property to CENTER. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment center! !

!SpTAlignable methodsFor: 'accessing' stamp: ''!
hAlignEnd
	"Sets the horizontal align property to END. See #hAlign for details"

	self hAlign: SpLayoutWidgetAlignment end! !

!SpTAlignable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTAlignable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTAlignable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTAlignable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTAlignable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTAlignable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTAlignable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTAlignable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTAlignable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTAlignable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTAlignable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTAlignable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTAlignable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTAlignable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTAlignable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTAlignable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTAlignable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTAlignable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTAlignable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTAlignable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTAlignable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTAlignable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTAlignable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTAlignable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTAlignable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTAlignable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTBackendUpdating commentStamp: ''!
Add functionality to verify if there is a backend updating in course. 
This is used to prevent cycles when announcing changes from-to the backend.!
!SpTBackendUpdating methodsFor: 'private' stamp: ''!
backendDetectCyclesDo: aBlock 

	self isBackendUpdating ifTrue: [ ^ self ].
	^ aBlock value! !

!SpTBackendUpdating methodsFor: 'private' stamp: ''!
backendUpdatingDo: aBlock 
	| oldStatus |

	oldStatus := backendUpdating.
	backendUpdating := true.
	aBlock ensure: [ 
		backendUpdating := oldStatus ]! !

!SpTBackendUpdating methodsFor: 'initialization' stamp: ''!
initializeTBackendUpdating

	backendUpdating := false! !

!SpTBackendUpdating methodsFor: 'private' stamp: ''!
isBackendUpdating

	^ backendUpdating! !

!SpTBackendUpdating classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTBackendUpdating classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTBackendUpdating classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTBackendUpdating classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTBackendUpdating classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTBackendUpdating classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTBackendUpdating classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTBackendUpdating classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTBackendUpdating classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTBackendUpdating classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTBackendUpdating classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTBackendUpdating classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTBackendUpdating classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTBackendUpdating classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTBackendUpdating classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTBackendUpdating classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTBackendUpdating classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTBackendUpdating classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTBackendUpdating classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTBackendUpdating classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTBackendUpdating classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTBackendUpdating classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTBackendUpdating classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTBackendUpdating classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTBackendUpdating classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTBackendUpdating classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTContextMenu commentStamp: ''!
I'm a trait to add context menus capabilities to the presenter that use it.
Note that I just add some behaviour at presenter level, the right implementation needs 
to be solved in the backend adaptor.!
!SpTContextMenu methodsFor: 'initialization' stamp: ''!
initialize
	
	self class initializeSlots: self.
	super initialize.! !

!SpTContextMenu methodsFor: 'api' stamp: ''!
contextMenu
	"Answer context menu or nil if there is none defined.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	^ contextMenu! !

!SpTContextMenu methodsFor: 'api' stamp: ''!
contextMenu: aValuableOrMenuPresenter
	"Set the context menu.
	 Context menu can be an instace of `SpMenuPresenter` or a block (that will answer eventually an 
	 instance of `SpMenuPresenter` aswell. 
	 If your context menu is defined through a block it means is dynamic, and it will be evaluated 
	 each time the context menu is invoked."

	contextMenu := aValuableOrMenuPresenter! !

!SpTContextMenu methodsFor: 'api - events' stamp: ''!
whenMenuChangedDo: aBlock
	"Inform when menu definition changed. 
	 `aBlock` receives zero arguments."

	self property: #contextMenu whenChangedDo: aBlock! !

!SpTContextMenu classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTContextMenu classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTContextMenu classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTContextMenu classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTContextMenu classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTContextMenu classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTContextMenu classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTContextMenu classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTContextMenu classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTContextMenu classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTContextMenu classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTContextMenu classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTContextMenu classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTContextMenu classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTContextMenu classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTContextMenu classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTContextMenu classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTContextMenu classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTContextMenu classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTContextMenu classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTContextMenu classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTContextMenu classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTContextMenu classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTContextMenu classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTContextMenu classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTContextMenu classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTDecoratedColumn commentStamp: ''!
Add column decoration capabilities to users.
A column can be decorated with certain attributes (see selectors defined) that receive a valuable. 

The valuable is always in the form [ :anItem | aResult ], but result may vary depending on the decoration (explained in messages).!
!SpTDecoratedColumn methodsFor: 'api' stamp: ''!
displayBackgroundColor

	^ backgroundColorAction! !

!SpTDecoratedColumn methodsFor: 'api' stamp: ''!
displayBold

	^ boldAction! !

!SpTDecoratedColumn methodsFor: 'api' stamp: ''!
displayItalic: aBlock
	"If `aBlock` answer true, the cell will be displayed in italic.
	 `aBlock` receives one argument (the model element)."

	italicAction := aBlock! !

!SpTDecoratedColumn methodsFor: 'api' stamp: ''!
displayUnderline: aBlock
	"If `aBlock` answer true, the cell will be displayed underlined.
	 `aBlock` receives one argument (the model element)."

	underlineAction := aBlock! !

!SpTDecoratedColumn methodsFor: 'api' stamp: ''!
displayBold: aBlock
	"If `aBlock` answer true, the cell will be displayed in bold.
	 `aBlock` receives one argument (the model element)."

	boldAction := aBlock! !

!SpTDecoratedColumn methodsFor: 'api' stamp: ''!
displayColor: aBlock
	"Changes the font color of cells of the column. 
	 `aBlock` receives an argument (the model element) and should answer an instance of Color."

	colorAction := aBlock! !

!SpTDecoratedColumn methodsFor: 'api' stamp: ''!
displayUnderline

	^ underlineAction! !

!SpTDecoratedColumn methodsFor: 'api' stamp: ''!
displayColor

	^ colorAction! !

!SpTDecoratedColumn methodsFor: 'api' stamp: ''!
displayBackgroundColor: aBlock
	"Changes the background color of cells of the column. 
	 `aBlock` receives an argument (the model element) and should answer an instance of Color. 
	 NOTE: This may be not working at the moment :("

	backgroundColorAction := aBlock! !

!SpTDecoratedColumn methodsFor: 'api' stamp: ''!
displayItalic

	^ italicAction! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTDecoratedColumn classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTDecoratedColumn classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTDecoratedColumn classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTDecoratedColumn classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTDecoratedColumn classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTDecoratedColumn classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTDecoratedColumn classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTDecoratedColumn classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTDecoratedColumn classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTDecoratedColumn classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTDecoratedColumn classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTDecoratedColumn classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTDecoratedColumn classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTDecoratedColumn classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTDecoratedColumn classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTDecoratedColumn classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTDynamicPresenter commentStamp: ''!
I'm a trait that add "dynamic" behavior to presenters. 
I can be used to create components that may have variable number of children.

DEPRECATED: This trait should not be used, since all presenters are dynamic now.!
!SpTDynamicPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName ifAbsent: aBlock
	^ self basicPresenters
		at: aName
		ifAbsent: [ [ self readSlotNamed: aName ]
				on: SlotNotFound
				do: aBlock ]! !

!SpTDynamicPresenter methodsFor: 'accessing' stamp: ''!
presenters

	^ self basicPresenters values! !

!SpTDynamicPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName put: aPresenter

	^ self basicPresenters 
		at: aName 
		put: aPresenter! !

!SpTDynamicPresenter methodsFor: 'enumerating' stamp: ''!
presentersDo: aBlock

	self basicPresenters valuesDo: aBlock! !

!SpTDynamicPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName

	^ self basicPresenters 
		at: aName 
		ifAbsent: [ self readSlotNamed: aName  ]! !

!SpTDynamicPresenter methodsFor: 'private - accessing' stamp: ''!
basicPresenters

	^ presenters ifNil: [ presenters := OrderedDictionary new ]! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTDynamicPresenter classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTDynamicPresenter classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTDynamicPresenter classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTDynamicPresenter classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTDynamicPresenter classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTDynamicPresenter classTrait methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!SpTDynamicPresenter classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTDynamicPresenter classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTDynamicPresenter classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTDynamicPresenter classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTDynamicPresenter classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTDynamicPresenter classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTDynamicPresenter classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTDynamicPresenter classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTDynamicPresenter classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTDynamicPresenter classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTDynamicPresenter classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTHaveWrappingScrollBars commentStamp: ''!
I add "wrapp by scrollbars" functionality to add to presenters that can be handled with or without them (like Lists, Tables and Texts areas)

Some backends like Morphic forces the scrollbars in their Tables and Lists. 
But some others like Gtk3 don't. This traits adds configuration of the precence 
of scrollbars for platforms who do not have them automatically.
By default lists/tables will have scrollbars added by default, but you can tune this 
if your backend of choice supports it.
THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED.!
!SpTHaveWrappingScrollBars methodsFor: 'api' stamp: ''!
withoutScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	wrapScrollBars := false! !

!SpTHaveWrappingScrollBars methodsFor: 'api' stamp: ''!
scrollBarStyles
	"Answer styles defined for the scrollbar component. 
	 In platforms that do not support separation from component and scrollbar (like Morphic), the 
	 style will be added to the component styles. 
	 In platforms who supports separation between component and scrollbar (like Gtk3), the style 
	 will be taken separately."

	^ scrollBarStyles ifNil: [ #() ]! !

!SpTHaveWrappingScrollBars methodsFor: 'testing' stamp: ''!
hasScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	^ wrapScrollBars! !

!SpTHaveWrappingScrollBars methodsFor: 'api' stamp: ''!
propagateNaturalHeight: aBoolean
	"Indicate when component propagates natural heigth.
	 Natural height propagation means that the height of the presenter containing both scrollbars and 
	 another component (tipically a text presenter) will follow the height of such component."

	propagateNaturalHeight := aBoolean! !

!SpTHaveWrappingScrollBars methodsFor: 'testing' stamp: ''!
isPropagateNaturalHeight
	"Indicate if component propagates natural heigth.
	 See `SpTHaveWrappingScrollBars>>#propagateNaturalHeight:`"

	^ propagateNaturalHeight ifNil: [ false ]! !

!SpTHaveWrappingScrollBars methodsFor: 'api' stamp: ''!
withScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	wrapScrollBars := true! !

!SpTHaveWrappingScrollBars methodsFor: 'api' stamp: ''!
removeScrollBarStyle: aStyle
	"Remove `aStyle` from the list of scrollbar styles.
	 See SpTHaveWrappingScrollBars>>#scrollBarStyles"

	scrollBarStyles := scrollBarStyles copyWithout: aStyle! !

!SpTHaveWrappingScrollBars methodsFor: 'initialization' stamp: ''!
initializeTHaveWrappingScrollBars

	scrollBarStyles := #().
	self propagateNaturalWidth: false.
	self propagateNaturalHeight: false! !

!SpTHaveWrappingScrollBars methodsFor: 'api' stamp: ''!
propagateNaturalWidth: aBoolean
	"Indicate when component propagates natural width.
	 Natural width propagation means that the width of the presenter containing both scrollbars and 
	 another component (tipically a text presenter) will follow the width of such component.
	 WARNING: Because of a limitation on how the font rendering works in morphic backend, 
	 this properly will fail to preserve the correct width if using monospaced fonts."

	propagateNaturalWidth := aBoolean! !

!SpTHaveWrappingScrollBars methodsFor: 'testing' stamp: ''!
isPropagateNaturalWidth
	"Indicate if component propagates natural width.
	 See `SpTHaveWrappingScrollBars>>#propagateNaturalWidth:`"

	^ propagateNaturalWidth ifNil: [ false ]! !

!SpTHaveWrappingScrollBars methodsFor: 'api' stamp: ''!
addScrollBarStyle: aStyle
	"Add a style for the scrollbar component. 
	 In platforms that do not support separation from component and scrollbar (like Morphic), the 
	 style will be added to the component styles. 
	 In platforms who supports separation between component and scrollbar (like Gtk3), the style 
	 will be taken separately."

	scrollBarStyles := scrollBarStyles copyWith: aStyle! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTHaveWrappingScrollBars classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTHaveWrappingScrollBars classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTModel commentStamp: ''!
A trait to add "model" behavior to a presenter.!
!SpTModel methodsFor: 'transmission' stamp: ''!
defaultInputPort

	^ self inputModelPort! !

!SpTModel methodsFor: 'transmission' stamp: ''!
inputModelPort

	^ SpModelPort newPresenter: self! !

!SpTModel methodsFor: 'private' stamp: ''!
setModel: aModel

	self model: aModel! !

!SpTModel methodsFor: 'accessing - model' stamp: ''!
model: aModel

	model := aModel.
	self updatePresenter! !

!SpTModel methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aModel

	model := aModel! !

!SpTModel methodsFor: 'accessing - model' stamp: ''!
model

	^ model! !

!SpTModel classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTModel classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTModel classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTModel classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTModel classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTModel classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTModel classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTModel classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTModel classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTModel classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTModel classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTModel classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTModel classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTModel classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTModel classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTModel classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTModel classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTModel classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTModel classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTModel classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTModel classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTModel classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTMorphicTableDataSourceCommons methodsFor: 'accessing' stamp: ''!
headerForColumn: aColumn

	^ self headersByColumn 
		at: aColumn 
		ifAbsentPut: [ self newHeaderColumn: aColumn ]! !

!SpTMorphicTableDataSourceCommons methodsFor: 'sorting' stamp: ''!
sortByColumn: aColumn

	aColumn sortDataSource: self.
	self model selection unselectAll.! !

!SpTMorphicTableDataSourceCommons methodsFor: 'accessing' stamp: ''!
headersByColumn 

	^ headersByColumn ifNil: [ headersByColumn := SmallDictionary new ]	! !

!SpTMorphicTableDataSourceCommons methodsFor: 'sorting' stamp: ''!
sortByColumn: aColumn event: anEvent morph: aMorph

	self sortByColumn: aColumn! !

!SpTMorphicTableDataSourceCommons methodsFor: 'accessing' stamp: ''!
headerColumn: column

	(column id isNil and: [ self model isShowingColumnHeaders not ]) ifTrue: [ ^ nil ].
	^ self headerForColumn: column! !

!SpTMorphicTableDataSourceCommons methodsFor: 'accessing' stamp: ''!
model: aTablePresenter

	model := aTablePresenter! !

!SpTMorphicTableDataSourceCommons methodsFor: 'private' stamp: ''!
setHeaderColumnLazyProperties: column
	"Some properties of a header just acquire value after rendering cells. This method makes sure 
	 properties are set, but is responsibility of the user to actually call it (usually after create 
	 a cell). See senders of this method too see where it goes."
	| headerMorph |
	
	column isExpandable ifTrue: [ ^ self ].  
	
	headerMorph := self headerForColumn: column.
	headerMorph hResizing = #rigid 
		ifFalse: [ headerMorph hResizing: #rigid ].
	headerMorph width = column model width ifFalse: [ 
		headerMorph width: (column model width ifNil: [ 0 ]). ]! !

!SpTMorphicTableDataSourceCommons methodsFor: 'accessing' stamp: ''!
menuColumn: column row: rowIndex
	| menuPresenter |

	menuPresenter := self model contextMenu.
	menuPresenter ifNil: [ ^ nil ].
	^ SpBindings
		value: self model application adapterBindings
		during: [ menuPresenter value buildWithSpec ]! !

!SpTMorphicTableDataSourceCommons methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!SpTMorphicTableDataSourceCommons methodsFor: 'private - factory' stamp: ''!
newHeaderColumn: column
	| headerMorph |
	
	headerMorph := SpHeaderCellMorph new 
		addMorph: (column id ifNil: [ '' ]) asMorph asReadOnlyMorph;
		yourself.
		
	column isSortable ifTrue: [ 
		headerMorph eventHandler: (MorphicEventHandler new 
			on: #click 
			send: #sortByColumn:event:morph:
			to: self
			withValue: column).
	column sortingIcon ifNotNil: [ :icon | headerMorph addMorph: icon ] ].

	^ headerMorph! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTMorphicTableDataSourceCommons classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTMorphicUIRedrawer commentStamp: ''!
I am a class giving the user the hability to wait for an UI redraw in Morphic. 

I am useful for tests when they need to be executed in a CI in non interactive mode.!
!SpTMorphicUIRedrawer methodsFor: 'running' stamp: ''!
defaultWaitDuration
	^ 500 milliSecond! !

!SpTMorphicUIRedrawer methodsFor: 'utilities' stamp: ''!
waitUntilUIRedrawed
	"I wait until the UI has been redrawn. 
	I take care of selecting how to do it. 
	If I am in the CI I should defer a semaphore signal. 
	If I am running in the UI process I can directly execute a doOneCycle on the World.
	If I am in the CI the tests and the UI run in different process. So I should not do a #doOneCycle.
	If I do it, I am in a race condition!!"

	self isRunningInUIProcess
		ifTrue: [
			MorphicRenderLoop new doOneCycle.
			^ self ].

	self currentWorld defer: [ uiWaitingSemaphore ifNotNil: #signal ].
	uiWaitingSemaphore wait: self defaultWaitDuration! !

!SpTMorphicUIRedrawer methodsFor: 'testing' stamp: ''!
isRunningInUIProcess
	^ UIManager default uiProcess == Processor activeProcess! !

!SpTMorphicUIRedrawer methodsFor: 'initialization' stamp: ''!
initializeSemaphore
	uiWaitingSemaphore := Semaphore new! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTMorphicUIRedrawer classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTMorphicUIRedrawer classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTObservable methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpTObservable methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	
	slot := self class slotNamed: aName.
	slot isObservableSlot
		ifFalse: [ SpNonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpTObservable methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #todo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpTObservable methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlock 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ (self observablePropertyNamed: aName) whenChangedDo: aBlock! !

!SpTObservable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTObservable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTObservable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTObservable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTObservable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTObservable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTObservable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTObservable classTrait methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!SpTObservable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTObservable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTObservable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTObservable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTObservable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTObservable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTObservable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTObservable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTObservable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTObservable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTObservable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTObservable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTObservable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTObservable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTObservable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTObservable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTObservable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTObservable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTObservable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTPresenterBuilder commentStamp: ''!
A builder to define presenters through method factory pattern. 
This allow users to compose presenters without needed to have hardcoded the name of them (which could or not change/be present/etc.)

The following two lines are equivalent and the second one is preferred for common presenters.

```
list := self instantiate: SpListPresenter
list := self newList.
```!
!SpTPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newGridLayout

	^ SpGridLayout new! !

!SpTPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newBoxLayoutTopToBottom

	^ SpBoxLayout newTopToBottom! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newList
	^ self instantiate: SpListPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newCheckBox
	^ self instantiate: SpCheckBoxPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newButtonBar

	^ self instantiate: SpButtonBarPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newNullPresenter
	^ self instantiate: SpNullPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newMenuBar
	^ self instantiate: SpMenuBarPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newNotebookPage

	self flag: #TODO. "NotebookPage needs to be a Presenter?"
	^ SpNotebookPage new! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newButton
	^ self instantiate: SpButtonPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newPanedLayoutTopToBottom

	^ SpPanedLayout newTopToBottom! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newComponentList
	^ self instantiate: SpComponentListPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newStatusBar

	^ self instantiate: SpStatusBarPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newMenuButton

	^ self instantiate: SpMenuButtonPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToolbarButton

	^ self instantiate: SpToolbarButtonPresenter! !

!SpTPresenterBuilder methodsFor: '*Spec2-Morphic' stamp: ''!
newMorph

	^ self instantiate: SpMorphPresenter! !

!SpTPresenterBuilder methodsFor: '*Spec2-Morphic' stamp: ''!
newLink
	^ self instantiate: SpLinkPresenter! !

!SpTPresenterBuilder methodsFor: 'instance creation' stamp: ''!
instantiate: aPresenterClass
	"Instantiate a SpPresenter subclass and set its instance owner"

	^ aPresenterClass owner: self! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newAthens

	^ self instantiate: SpAthensPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newProgressBar
	^ self instantiate: SpProgressBarPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newActionBar

	^ self instantiate: SpActionBarPresenter! !

!SpTPresenterBuilder methodsFor: '*Spec2-Morphic' stamp: ''!
newImage
	^ self instantiate: SpImagePresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newPresenter

	^ self instantiate: SpPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newDropList
	^ self instantiate: SpDropListPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newPresenterWith: aBlock
	| presenter |

	presenter := self instantiate: SpPresenter.
	aBlock value: aBlock.

	^ presenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newNotebook

	^ self instantiate: SpNotebookPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToolbar

	^ self instantiate: SpToolbarPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newTree

	^ self instantiate: SpTreePresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newRadioButton
	^ self instantiate: SpRadioButtonPresenter! !

!SpTPresenterBuilder methodsFor: '*Spec2-CommonWidgets' stamp: ''!
newFilteringList

	^ self instantiate: SpFilteringListPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newDynamicPresentersListIn: accessorSymbol usingBuilder: aDynamicPresentersListBuilder
	|mutatorSymbol newDynamicPresenter |
	mutatorSymbol := (accessorSymbol , ':') asSymbol.
	(self perform: accessorSymbol)
		ifNotNil: [ :dynamicPresenter | dynamicPresenter owner: nil ].
	newDynamicPresenter := aDynamicPresentersListBuilder build.
	
	self perform: mutatorSymbol with: newDynamicPresenter.
	
	newDynamicPresenter owner: self.
	
	self needRebuild: false.
	self buildWithSpec! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newLabel
	^ self instantiate: SpLabelPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToolbarToggleButton

	^ self instantiate: SpToolbarToggleButtonPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newScrollableLayout

	^ SpScrollableLayout new! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newMenu
	^ self instantiate: SpMenuPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newTextInput
	^ self instantiate: SpTextInputFieldPresenter! !

!SpTPresenterBuilder methodsFor: '*Spec2-Code' stamp: ''!
newCode

	^ self instantiate: SpCodePresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newDiff
	^ self instantiate: SpDiffPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newSearchInput

	^ self instantiate: SpSearchInputFieldPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToolbarPopoverButton

	^ self instantiate: SpToolbarPopoverButtonPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newPanedLayoutLeftToRight

	^ SpPanedLayout newLeftToRight! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newTable

	^ self instantiate: SpTablePresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newBoxLayoutLeftToRight

	^ SpBoxLayout newLeftToRight! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newPopover

	^ self instantiate: SpPopoverPresenter! !

!SpTPresenterBuilder methodsFor: 'instance creation' stamp: ''!
instantiate: aPresenterClass on: aModel
	"Instantiate a SpPresenter subclass and set its instance owner and model"

	^ aPresenterClass owner: self on: aModel! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToolbarMenuButton

	^ self instantiate: SpToolbarMenuButtonPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newToggleButton

	^ self instantiate: SpToggleButtonPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newNumberInput
	^ self instantiate: SpNumberInputFieldPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - layouts' stamp: ''!
newOverlayLayout

	^ SpOverlayLayout new! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newSpinner

	^ self instantiate: SpSpinnerPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newPresenterSelector

	^ self instantiate: SpPresenterSelectorPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newSlider
	^ self instantiate: SpSliderPresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newTreeTable

	^ self instantiate: SpTreeTablePresenter! !

!SpTPresenterBuilder methodsFor: 'scripting - widgets' stamp: ''!
newText
	^ self instantiate: SpTextPresenter! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTPresenterBuilder classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTPresenterBuilder classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTPresenterBuilder classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTPresenterBuilder classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTPresenterBuilder classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTPresenterBuilder classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTPresenterBuilder classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTPresenterBuilder classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTPresenterBuilder classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTPresenterBuilder classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTPresenterBuilder classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTPresenterBuilder classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTPresenterBuilder classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTPresenterBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTPresenterBuilder classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTPresenterBuilder classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTSearchable commentStamp: ''!
I add search capability to lists/tables and trees. 
I implement basic common API but real implementation (as always) needs to be done in the backend adapters. !
!SpTSearchable methodsFor: 'initialization' stamp: ''!
initialize
	
	self class initializeSlots: self.
	super initialize.
	self initializeTSearchable! !

!SpTSearchable methodsFor: 'api' stamp: ''!
searchMatching: aBlock
	"Enables search and defines a block to perform a search on the model objects. 
	 The block receives two parameters: 
		- item (the model element)
		- pattern (the string to match)"

	searchBlock := aBlock.
	self enableSearch! !

!SpTSearchable methodsFor: 'api' stamp: ''!
enableSearch
	"Enable searching"

	searchEnabled := true! !

!SpTSearchable methodsFor: 'private' stamp: ''!
performSearch: item matching: pattern

	^ searchBlock 
		value: item 
		value: pattern! !

!SpTSearchable methodsFor: 'private' stamp: ''!
searchValueOf: item 

	^ self displayValueFor: item! !

!SpTSearchable methodsFor: 'api - events' stamp: ''!
whenSearchEnabledChangedDo: aBlock
	"Inform when search enabled/disabled has changed.
 	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #searchEnabled whenChangedDo: aBlock! !

!SpTSearchable methodsFor: 'testing' stamp: ''!
hasCustomSearch
	"Answer true if the list has a custom search defined (See `SpListPresenter>>#searchMatching:`"

	^ searchBlock notNil! !

!SpTSearchable methodsFor: 'api' stamp: ''!
disableSearch
	"Disable searching"

	searchEnabled := false! !

!SpTSearchable methodsFor: 'testing' stamp: ''!
isSearchEnabled
	"Answer true if search is enabled (See `SpTSearchable>>#enableSearch`)"

	^ searchEnabled! !

!SpTSearchable methodsFor: 'private' stamp: ''!
performDefaultSearch: item matching: pattern
	| text |
	
	text := (self searchValueOf: item) trimBoth asLowercase.
	^ text beginsWith: pattern! !

!SpTSearchable methodsFor: 'initialization' stamp: ''!
initializeTSearchable
	
	self searchMatching: [ :item :pattern | 
		self performDefaultSearch: item matching: pattern ].! !

!SpTSearchable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpTSearchable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpTSearchable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpTSearchable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpTSearchable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpTSearchable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpTSearchable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpTSearchable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpTSearchable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTSearchable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpTSearchable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpTSearchable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpTSearchable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpTSearchable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpTSearchable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpTSearchable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpTSearchable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpTSearchable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpTSearchable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpTSearchable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpTSearchable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpTSearchable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpTSearchable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpTSearchable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpTSearchable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpTSearchable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpTabAnnouncement methodsFor: 'accessing' stamp: ''!
presenter: anObject

	presenter := anObject! !

!SpTabAnnouncement methodsFor: 'accessing' stamp: ''!
presenter

	^ presenter! !

!SpTabAnnouncement class methodsFor: 'instance creation' stamp: ''!
newPresenter: aPresenter

	^ self new
		presenter: aPresenter;
		yourself! !

!SpTabConstraints methodsFor: 'accessing' stamp: ''!
label: anObject

	label := anObject! !

!SpTabConstraints methodsFor: 'accessing' stamp: ''!
label

	^ label! !

!SpTabLayout methodsFor: 'accessing' stamp: ''!
add: aPresenter withConstraints: aBlock
	
	super add: aPresenter withConstraints: aBlock.
	self announceChildAdded: aPresenter! !

!SpTabLayout methodsFor: 'accessing' stamp: ''!
initialize

	super initialize.
	initialPageIndex := 1! !

!SpTabLayout methodsFor: 'accessing' stamp: ''!
initialPageIndex
	
	^ initialPageIndex! !

!SpTabLayout methodsFor: 'private' stamp: ''!
constraintsClass

	^ SpTabConstraints! !

!SpTabLayout methodsFor: 'accessing' stamp: ''!
add: aName label: aString

	self 
		add: aName 
		withConstraints: [ :constraints | 
			constraints label: aString ]! !

!SpTabLayout methodsFor: 'private' stamp: ''!
adapterName

	^ #TabAdapter! !

!SpTabLayout methodsFor: 'accessing' stamp: ''!
initialPageIndex: aNumber

	initialPageIndex := aNumber! !

!SpTableAdapterMultipleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpTablePresenter! !

!SpTableAdapterMultipleSelectionTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	super initializeTestedInstance.

	presenter addColumn: (SpStringTableColumn evaluated: [ :e | e ])! !

!SpTableAdapterSingleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpTablePresenter! !

!SpTableAdapterSingleSelectionTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	super initializeTestedInstance.
	presenter addColumn: (SpStringTableColumn evaluated: [:e | e displayString]).! !

!SpTableColumn commentStamp: ''!
A base definition for table columns.
A `SpTableColumn` define the common behavior of a column.!
!SpTableColumn methodsFor: 'api' stamp: ''!
width: aNumber
	"Set the width of a column to `aNumber`. 
	 Note that setting width to a value will make this column not expandable. 
	 (See `SpTableColumn>>#beNotExpandable`"

	width := aNumber! !

!SpTableColumn methodsFor: 'api' stamp: ''!
evaluation
	"Answer the evaluation block to transform the table element (See `SpAbstractListPresenter>>#items:`)
	 into a value to display in this column"

	^ evaluation! !

!SpTableColumn methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self beExpandable! !

!SpTableColumn methodsFor: 'api' stamp: ''!
sortFunction: aBlockOrSortFunction
	"Set the sort function to apply to the values of this column in order to sort elements.
	 `aBlockOrSortFunction` is a block that receives two arguments to compare or an instace of 
	 `SortFunction`. "

	sortFunction := aBlockOrSortFunction! !

!SpTableColumn methodsFor: 'api' stamp: ''!
beExpandable
	"Indicate that this column may be expanded if requested by the rendering.
	 This will cause the column to take as much width as it is given.
	 By default, all columns are expandable."

	expandable := true! !

!SpTableColumn methodsFor: 'api' stamp: ''!
title: aString
	"Set the header title of this column."

	title := aString! !

!SpTableColumn methodsFor: 'api' stamp: ''!
beNotExpandable
	"Indicate that this column will not be expanded when requested by the rendering.
	 This will cause the column to have a fixed width (often calculated by the width of its 
	 elements)."

	expandable := false! !

!SpTableColumn methodsFor: 'api' stamp: ''!
width
	"Answer the fixed width of this column (or nil if column is expandable, 
	 see `SpTableColumn>>#beExpandable`)"

	^ width! !

!SpTableColumn methodsFor: 'testing' stamp: ''!
isEditable
	"Answer if this column is editable"

	^ false! !

!SpTableColumn methodsFor: 'visiting' stamp: ''!
acceptColumnVisitor: aBuilder

	^ self subclassResponsibility! !

!SpTableColumn methodsFor: 'private' stamp: ''!
readObject: anObject 

	^ self evaluation cull: anObject! !

!SpTableColumn methodsFor: 'testing' stamp: ''!
isExpandable
	"Answer if this column is expandable"

	"if width is defined, it cannot be expandable (because column with take the defined width)"
	^ expandable and: [ self width isNil ]! !

!SpTableColumn methodsFor: 'api' stamp: ''!
evaluated: aBlock
	"Define how the column will evaluate the element of the table/tree model 
	 (See `SpAbstractListPresenter>>#items:) to get the value to display in this 
	 column.
	 `aBlock` receives one orgument (the element to evaluate) and it needs to answer an 
	 object of the type expected by the type of the column (See SpTableColumn subclasses)"

	evaluation := aBlock! !

!SpTableColumn methodsFor: 'api' stamp: ''!
sortFunction
	"Answer the a sort function to apply to the values of this column in order to sort elements. 
	 If not defined, most table column types will not allow the table sorting capabilities. 
	 This is not the case of `SpStringTableColumn` which defines a sorting by default (but you can 
	 disable it anyway, see `SpStringTableColumn>>#beNotSortable`."

	^ sortFunction! !

!SpTableColumn methodsFor: 'testing' stamp: ''!
isComposite
	"Answer if this is a composite column"

	^ false! !

!SpTableColumn methodsFor: 'api' stamp: ''!
title
	"Answer the header title of this column."

	^ title! !

!SpTableColumn methodsFor: 'testing' stamp: ''!
isSortable
	"Answer if this column is sortable"

	^ self sortFunction notNil! !

!SpTableColumn class methodsFor: 'instance creation' stamp: ''!
title: aString evaluated: aValuable

	^ self new 
		title: aString;
		evaluated: aValuable;
		yourself! !

!SpTableColumn class methodsFor: '*Spec2-Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	super buildMicroDownUsing: aBuilder withComment: aString.
	"Sections"
	self documentSections keysAndValuesDo: [ :label :methods |
		SpAbstractWidgetPresenter 
			addDocumentSection: aBuilder 
			label: label 
			methods: methods ].
	"Hierarchy"
	self addDocumentSectionHierarchy: aBuilder.
! !

!SpTableColumn class methodsFor: 'instance creation' stamp: ''!
title: aString

	^ self new 
		title: aString;
		yourself! !

!SpTableColumn class methodsFor: 'documentation' stamp: ''!
documentSections
		
	^ OrderedDictionary newFromPairs: {
		'API Methods'. self methods select: [ :each | each protocol = #'api' ].
		'Testing Methods'. self methods select: [ :each | each protocol = #'testing' ].
	 }! !

!SpTableColumn class methodsFor: 'instance creation' stamp: ''!
evaluated: aValuable

	^ self new 
		evaluated: aValuable;
		yourself! !

!SpTableColumn class methodsFor: 'adding' stamp: ''!
addDocumentSectionHierarchy: aBuilder
	
	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Hierarchy' ] withLevel: 2.
	SpDocumentHierarchyBuilder new
		fromClass: SpTableColumn;
		builder: aBuilder;
		filter: [ :eachClass | eachClass package packageName beginsWith: 'Spec2-' ];
		buildFor: self! !

!SpTableCommonPropertiestTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpTablePresenter! !

!SpTableCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testListWithoutColumnsHasSingleColumn

	self assert: self adapter columns size equals: 1! !

!SpTableCommonPropertiestTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	super initializeTestedInstance.
	presenter addColumn: (SpStringTableColumn title: 'Number' evaluated: #yourself).
	
	"Hide headers. We will try to click the first element, and the header is an extra element."
	presenter hideColumnHeaders.! !

!SpTableCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testAddColumnInPresenterAddsItToWidget

	| newColumn |
	newColumn := SpStringTableColumn title: 'Hex' evaluated: #hex.
	self presenter
		addColumn: newColumn.

	self assert: self adapter columns last id equals: newColumn title! !

!SpTableCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testHideColumnHeadersInPresenterHidesThemInWidget

	self presenter hideColumnHeaders.
	
	self deny: self adapter isShowColumnHeaders  ! !

!SpTableCommonPropertiestTest methodsFor: 'tests' stamp: ''!
testShowColumnHeadersInPresenterShowsThemInWidget

	SystemVersion current major = 7
		ifTrue: [
			"Test failing in Pharo7 due to a bug in FastTable"
			^ self skip ].

	self presenter showColumnHeaders.
	
	self assert: self adapter isShowColumnHeaders! !

!SpTablePresenter commentStamp: ''!
A presenter for a table.
A table has columns with a type (See column types section).
 
**IMPORTANT:** A table presenter does not contain other presenters. Instead, it maps the model provided (See `SpAbstractListPresenter>>#items:`) with the columns defined. If you need this behavior, you will need to use `SpComponentListPresenter`.
!
!SpTablePresenter methodsFor: 'api - events' stamp: ''!
whenShowColumnHeadersChangedDo: aBlock
	"Inform when showColumnHeaders property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
		
	self property: #showColumnHeaders whenChangedDo: aBlock! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
columns
	"Answer the columns composing this table."

	^ columns! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
hideColumnHeaders
	"Hide the column headers"

	showColumnHeaders := false! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
enableSearch
	"Enable searching"

	searchEnabled := true! !

!SpTablePresenter methodsFor: 'private' stamp: ''!
searchValueOf: anObject
	
	^ anObject asString! !

!SpTablePresenter methodsFor: 'api - events' stamp: ''!
whenSearchEnabledChangedDo: aBlock
	"Inform when search enabled/disabled has changed.
 	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #searchEnabled whenChangedDo: aBlock! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
addColumns: aCollection
	"Add a list of columns.
	 `aCollection` is a list of instances of `SpTableColumn`"

	aCollection do: [ :each | self addColumn: each ]! !

!SpTablePresenter methodsFor: 'testing' stamp: ''!
hasCustomSearch
	"Answer true if the list has a custom search defined (See `SpListPresenter>>#searchMatching:`"

	^ searchBlock notNil! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
beResizable
	"Mark the table as 'resizable', which means there will be a slider to resize the columns."

	self isResizable: true! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
showColumnHeaders
	"Show column headers"

	showColumnHeaders := true! !

!SpTablePresenter methodsFor: 'testing' stamp: ''!
isSearchEnabled
	"Answer true if search is enabled (See `SpTSearchable>>#enableSearch`)"

	^ searchEnabled! !

!SpTablePresenter methodsFor: 'emulating' stamp: ''!
clickOnColumnHeaderAt: anIndex
	self withAdapterDo: [ :tableAdapter | tableAdapter clickOnColumnHeaderAt: anIndex ]! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
addColumn: aColumn
	"Add a column to the table. A column should be an instance of `SpTableColumn`"

	columns := columns copyWith: aColumn! !

!SpTablePresenter methodsFor: 'private' stamp: ''!
valueAtColumn: aColumn row: aRow

	^ (columns at: aColumn) readObject: (self model items at: aRow)! !

!SpTablePresenter methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	self initializeTSearchable.
	showColumnHeaders := true.
	columns := #().
	isResizable := false! !

!SpTablePresenter methodsFor: 'testing' stamp: ''!
isShowingColumnHeaders
	"Answer true if the table is configured to show column headers."

	^ showColumnHeaders! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
searchMatching: aBlock
	"Enables search and defines a block to perform a search on the model objects. 
	 The block receives two parameters: 
		- item (the model element)
		- pattern (the string to match)"

	searchBlock := aBlock.
	self enableSearch! !

!SpTablePresenter methodsFor: 'api - events' stamp: ''!
whenIsResizableChangedDo: aBlock
	"Inform when resizable property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
	
	self property: #isResizable whenChangedDo: aBlock! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
columns: aCollection
	"Set all columns at once. 
	 `aCollection` is a list of instances of `SpTableColumn`"

	columns := aCollection! !

!SpTablePresenter methodsFor: 'testing' stamp: ''!
isResizable
	"Answer true if table allows resizing of its columns."

	^ isResizable! !

!SpTablePresenter methodsFor: 'api - events' stamp: ''!
whenColumnsChangedDo: aBlock
	"Inform when columns have changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"	
	
	self property: #columns whenChangedDo: aBlock! !

!SpTablePresenter methodsFor: 'private' stamp: ''!
performSearch: item matching: pattern

	^ searchBlock 
		value: item 
		value: pattern! !

!SpTablePresenter methodsFor: 'private' stamp: ''!
isResizable: aBoolean
	isResizable := aBoolean! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
disableSearch
	"Disable searching"

	searchEnabled := false! !

!SpTablePresenter methodsFor: 'api' stamp: ''!
beNotResizable
	"Mark the table as 'not resizable', which means there will be not possibility to resize the 
	 columns of it."
	
	self isResizable: false! !

!SpTablePresenter methodsFor: 'private' stamp: ''!
performDefaultSearch: item matching: pattern
	| text |
	
	text := (self searchValueOf: item) trimBoth asLowercase.
	^ text beginsWith: pattern! !

!SpTablePresenter methodsFor: 'initialization' stamp: ''!
initializeTSearchable
	
	self searchMatching: [ :item :pattern | 
		self performDefaultSearch: item matching: pattern ].! !

!SpTablePresenter class methodsFor: 'documentation' stamp: ''!
addDocumentExtraSections: aBuilder

	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Column types' ] withLevel: 2.
	aBuilder unorderedListDuring: [ 
		(SpTableColumn allSubclasses sorted: #name ascending) do: [ :eachType | 
			aBuilder item: [
				aBuilder monospace: eachType name ] ] ]! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithDecoratedString
	
	^ self new
		addColumn: (SpImageTableColumn title: 'Icon' evaluated: [ :aClass | aClass systemIcon ]);
		addColumn: (SpStringTableColumn new 
			title: 'Name'; 
			evaluated: [ :aClass | aClass name ];
			displayColor: [ :aClass | 
				(aClass name endsWith: 'Test')
					ifTrue: [ Color green ]
					ifFalse: [ Smalltalk ui theme textColor ] ];
			displayItalic: [ :aClass | aClass name includesSubstring: 'abstract' caseSensitive: false ];
			displayBold: [ :aClass | aClass hasSubclasses ];
			displayUnderline: [ :aClass | aClass numberOfMethods > 10 ];
			yourself);
		items: Smalltalk allClasses;
		openWithSpec! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithSortableColumnHeaders

	^ self new
		showColumnHeaders;
		addColumn: (SpStringTableColumn title: 'Number' evaluated: #yourself) beSortable;
		addColumn: (SpStringTableColumn title: 'Hex' evaluated: #hex) beSortable;
		items: (1 to: 16) asArray;
		openWithSpec! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithoutColumnHeaders
	<sampleInstance>
	| example |
	example := self new.
	example
		addColumn: (SpStringTableColumn title: 'Number' evaluated: #yourself);
		addColumn: (SpStringTableColumn title: 'Hex' evaluated: #hex);
		items: (1 to: 10) asArray;
		hideColumnHeaders;
		openWithSpec.
	^ example! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWriteableTable
	"The selector names are NOT stored, but serves merely to have something one can edit"
	| items |
	
	items := String methods.
	^ self new
		addColumn: (SpStringTableColumn new 
			title: 'Editable selector name';
			evaluated: [ :m | m selector ];
			displayBold: [ :m | m selector isKeyword ];
			beEditable ;
			onAcceptEdition: [ :m :t | Transcript nextPutAll: t;cr;endEntry ];
			yourself);
		addColumn: (SpStringTableColumn title: 'Size' evaluated: #size) beSortable;
		showColumnHeaders;
		items: items;
		openWithSpec! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleFixedWidthResizable
	"A fixed width cannot be changed even if the table is resizable"
	
	^ self new
		beResizable;
		addColumn: ((SpImageTableColumn title: 'Icon' evaluated: #systemIcon) width: 30);
		addColumn: (SpStringTableColumn title: 'Name' evaluated: #name);
		addColumn: (SpStringTableColumn title: 'Methods' evaluated: [ :each | each methods size ]);
		items: Smalltalk allClasses;
		openWithSpec! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleSorting
	"Example shows the two kinds of sorting, using a boolean compare, or a threeway sorting"
	| classNameCompare methodCountSorter |

	classNameCompare := [ :c1 :c2 | c1 name < c2 name ].
	methodCountSorter := [ :c1 :c2 | 
	                     c1 methodDictionary size threeWayCompareTo:
		                     c2 methodDictionary size ].

	self new
		addColumn: ((SpStringTableColumn title: 'Name' evaluated: #name) 
				 compareFunction: classNameCompare);
		addColumn: ((SpStringTableColumn
				  title: 'Methods' evaluated: [ :c | c methodDictionary size ]) 
				sortFunction: methodCountSorter);
		items: Smalltalk globals allClasses;
		openWithSpec! !

!SpTablePresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newTable! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>
	
	^ self new
		addColumn: (SpImageTableColumn title: 'Icon' evaluated: #systemIcon);
		addColumn: (SpStringTableColumn title: 'Name' evaluated: #name);
		items: Smalltalk allClasses;
		openWithSpec! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleFixedWidth
	
	^ self new
		addColumn: ((SpImageTableColumn title: 'Icon' evaluated: #systemIcon) width: 30);
		addColumn: (SpStringTableColumn title: 'Name' evaluated: #name);
		items: Smalltalk allClasses;
		openWithSpec! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleResizableColumns
	
	^ self new
		beResizable;
		addColumn: (SpImageTableColumn title: 'Icon' evaluated: #systemIcon);
		addColumn: (SpStringTableColumn title: 'Name' evaluated: #name);
		items: Smalltalk allClasses;
		openWithSpec! !

!SpTablePresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TableAdapter! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithColumnHeaders
	<sampleInstance>

	^ self new
		addColumn: (SpStringTableColumn title: 'Number' evaluated: #yourself);
		addColumn: (SpStringTableColumn title: 'Hex' evaluated: #hex);
		showColumnHeaders;
		items: (1 to: 10) asArray;
		openWithSpec! !

!SpTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithCompositeColumn
	
	^ self new
		showColumnHeaders;
		addColumn: (SpStringTableColumn title: 'Package' evaluated: [ :aClass | aClass package packageName ]);
		addColumn: (SpCompositeTableColumn new
			title: 'Class';
			addColumn: (SpImageTableColumn evaluated: #systemIcon) beNotExpandable;
			addColumn: (SpStringTableColumn evaluated: #name);
			yourself);
		items: Smalltalk allClasses;
		openWithSpec! !

!SpTablePresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	
	^ SpTablePresenter! !

!SpTablePresenterTest methodsFor: 'tests' stamp: ''!
testSelectedItemsReturnsRightElementAfterSortingOfElementsChanged
	[ presenter
		addColumn: (SpStringTableColumn title: ' i ' evaluated: #value);
		addColumn: (SpStringTableColumn title: ' 1 / i ' evaluated: [ :item | (1 / item) value ]) beSortable;
		openWithSpec;
		selectIndex: 1. "10"
		
	"sort by 1/i ascending"
	presenter clickOnColumnHeaderAt: 2.

	presenter selectIndex: 1.
	
	self assert: presenter selectedItems first equals: 30 "items are still sorted by 1/i ascending value" ]
		ensure: [ presenter delete ]! !

!SpTablePresenterTest methodsFor: 'tests - activation' stamp: ''!
testAddColumnRaisesColumnChangedEvent

	| columnsChanged |
	columnsChanged := false.
	presenter whenColumnsChangedDo: [ columnsChanged := true ].

	presenter addColumn: (SpStringTableColumn new evaluated: #yourself).
	
	self assert: columnsChanged! !

!SpTablePresenterTest methodsFor: 'tests - activation' stamp: ''!
testShowColumnHeadersShowHeaders

	presenter showColumnHeaders.

	self assert: presenter isShowingColumnHeaders! !

!SpTablePresenterTest methodsFor: 'tests' stamp: ''!
testGivenSortingIsActiveWhenAffectingNewItemsThenNewItemsAreSorted
	[ presenter
		addColumn: (SpStringTableColumn title: ' i ' evaluated: #value);
		addColumn: (SpStringTableColumn title: ' 1 / i ' evaluated: [ :item | (1 / item) value ]) beSortable;
		openWithSpec;
		selectIndex: 1.

	"sort by 1/i ascending"
	presenter clickOnColumnHeaderAt: 2.

	presenter
		items: #(40 50); 
		selectIndex: 1.
	
	self assert: presenter selection selectedItem equals: 50 "items are still sorted by 1/i ascending value" ]
		ensure: [ presenter delete ]! !

!SpTablePresenterTest methodsFor: 'tests - activation' stamp: ''!
testHideColumnHeadersRaisesOneEventOnly

	| count |
	count := 0.
	presenter whenShowColumnHeadersChangedDo: [ count := count + 1 ].
	presenter hideColumnHeaders.

	self assert: count equals: 1! !

!SpTablePresenterTest methodsFor: 'tests - activation' stamp: ''!
testHideColumnHeadersDoesNotShowHeaders

	presenter hideColumnHeaders.

	self deny: presenter isShowingColumnHeaders! !

!SpTablePresenterTest methodsFor: 'tests - activation' stamp: ''!
testAddColumnRaisesOneEventOnly

	| count |
	count := 0.
	presenter whenColumnsChangedDo: [ count := count + 1 ].

	presenter addColumn: (SpStringTableColumn new evaluated: #yourself).
	
	self assert: count equals: 1! !

!SpTablePresenterTest methodsFor: 'tests - activation' stamp: ''!
testShowColumnHeadersRaisesOneEventOnly

	| count |
	count := 0.
	presenter whenShowColumnHeadersChangedDo: [ count := count + 1 ].
	presenter showColumnHeaders.

	self assert: count equals: 1! !

!SpTableSearchTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTablePresenter! !

!SpTestApplicationWithLocale methodsFor: 'accessing' stamp: ''!
locale
	^ locale! !

!SpTestApplicationWithLocale methodsFor: 'accessing' stamp: ''!
initialize 

	super initialize.
	
	locale := Locale isoLanguage: 'en' isoCountry: 'US'.! !

!SpTestApplicationWithLocale methodsFor: 'accessing' stamp: ''!
locale: anObject
	locale := anObject! !

!SpTestLocalizedString methodsFor: 'accessing' stamp: ''!
string: anObject
	string := anObject! !

!SpTestLocalizedString methodsFor: 'accessing' stamp: ''!
initialize 

	super initialize.
	requestsCount := 0! !

!SpTestLocalizedString methodsFor: 'accessing' stamp: ''!
localizedForPresenter: aPresenter 

	requestsCount := requestsCount + 1.
	
	^ string, '[', aPresenter locale localeID isoString, '](', requestsCount asString, ')'! !

!SpTestLocalizedString methodsFor: 'accessing' stamp: ''!
isEmptyOrNil

	^ self string isEmpty! !

!SpTestLocalizedString methodsFor: 'accessing' stamp: ''!
string
	^ string! !

!SpTestLocalizedString methodsFor: 'accessing' stamp: ''!
withAccentuatedCharacter: aCharacter

! !

!SpTestLocalizedString methodsFor: 'accessing' stamp: ''!
asString 
	^ string asString! !

!SpTestLocalizedString class methodsFor: 'instance creation' stamp: ''!
from: aString

	^ self new string: aString! !

!SpTestPresenterWithThreeRadioButtons methodsFor: 'accessing' stamp: ''!
radio3
	^ radio3! !

!SpTestPresenterWithThreeRadioButtons methodsFor: 'accessing' stamp: ''!
radio2
	^ radio2! !

!SpTestPresenterWithThreeRadioButtons methodsFor: 'initialization' stamp: ''!
initializePresenters
	
	radio1 := self newRadioButton
					label: 'radio1';
					yourself. 
	radio2 := self newRadioButton
					label: 'radio2';
					yourself. 

	radio3 := self newRadioButton
					label: 'radio3';
					yourself. 
	
	radio1 associatedRadioButtons: {radio2. radio3}.
! !

!SpTestPresenterWithThreeRadioButtons methodsFor: 'initialization' stamp: ''!
connectPresenters 

	radio1 state: false.
	radio2 state: true.
	radio3 state: false
! !

!SpTestPresenterWithThreeRadioButtons methodsFor: 'accessing' stamp: ''!
radio1
	^ radio1! !

!SpTestPresenterWithThreeRadioButtons class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom 
		add: #radio1;
		add: #radio2;
		add: #radio3;
		yourself! !

!SpTestPresenterWithToolbar commentStamp: ''!
A presenter with a tollbar and a button to use in Window / World tests.!
!SpTestPresenterWithToolbar methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	| toolbar |
	toolbar := SpToolbarPresenter new
		addItemLeft: (SpToolbarButtonPresenter new
			label: 'toolbar button';
			yourself);
		yourself.
	aWindowPresenter
		title: self class name;
		initialExtent: 700 @ 500;
		toolbar: toolbar! !

!SpTestPresenterWithToolbar methodsFor: 'initialization' stamp: ''!
initializePresenters
	button := self newButton
		label: 'test';
		yourself.! !

!SpTestPresenterWithToolbar class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: (SpPanedLayout newTopToBottom
			add: #button;
			yourself);
		yourself! !

!SpTestWorldPresenter commentStamp: ''!
I specialized SpWorldPresenter fo test purporses.
I hold an instance of World that you can access using #currentWorld.
I allows to test a WorldPresenter in a World that is not the current world.!
!SpTestWorldPresenter methodsFor: 'private - showing' stamp: ''!
openWithSpecLayout: aLayout
	super openWithSpecLayout: aLayout.
	isClosed := false! !

!SpTestWorldPresenter methodsFor: 'accessing' stamp: ''!
widget
	^ self currentWorld! !

!SpTestWorldPresenter methodsFor: 'accessing' stamp: ''!
currentWorld
	^ self class currentWorld! !

!SpTestWorldPresenter class methodsFor: 'ui requests' stamp: ''!
currentWorld
	^ TestWorld ifNil: [ TestWorld := self newWorld ]! !

!SpTestWorldPresenter class methodsFor: 'class initialization' stamp: ''!
reset
	TestWorld := nil! !

!SpTestWorldPresenter class methodsFor: 'instance creation' stamp: ''!
newWorld
	| hand |
	hand := HandMorph new.
	^ WorldMorph new 
		addHand: hand;
		activeHand: hand;
		yourself! !

!SpTestingPointModel commentStamp: ''!
A testing model for testing of the class ComposablePresenterWithModel!
!SpTestingPointModel methodsFor: 'accessing' stamp: ''!
setX: xValue setY: yValue 

	x := xValue.
	y := yValue! !

!SpTestingPointModel methodsFor: 'accessing' stamp: ''!
y: anObject
	y := anObject! !

!SpTestingPointModel methodsFor: 'accessing' stamp: ''!
x
	^ x! !

!SpTestingPointModel methodsFor: 'accessing' stamp: ''!
x: anObject
	x := anObject! !

!SpTestingPointModel methodsFor: 'accessing' stamp: ''!
y
	^ y! !

!SpTestingPointModel class methodsFor: 'instance creation' stamp: ''!
x: xInteger y: yInteger 

	^ self new setX: xInteger setY: yInteger! !

!SpTestingPresenter commentStamp: ''!
A TestingComposablePresenter is a stupid composable model used to test SpecInterpreter.!
!SpTestingPresenter methodsFor: 'accessing' stamp: ''!
getText
	^ Text new! !

!SpTestingPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	list := self newList! !

!SpTestingPresenter methodsFor: 'accessing' stamp: ''!
list

	^ list! !

!SpTestingPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #list;
		yourself! !

!SpTestingPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'You should not see me !!'! !

!SpTestingPresenterWithAdditionalPresenters commentStamp: ''!
This presenter contains several subpresenters that are stored in additionalSubpresentersMap plus one presenter that is stored in instance variable but does not have any public accessors.!
!SpTestingPresenterWithAdditionalPresenters methodsFor: 'initialization' stamp: ''!
initializePresenters
 
	self class keys do: [ :aKey |
		self additionalSubpresentersMap at: aKey put: (self newButton label: aKey)].
	
	subpresenter4 := self newButton label: 'subpresenter4'! !

!SpTestingPresenterWithAdditionalPresenters class methodsFor: 'accessing' stamp: ''!
defaultSpec
	<spec>
	| aLayout |
	aLayout := SpBoxLayout newTopToBottom.

	self keys do: [ :aKey | aLayout add: aKey ].

	aLayout add: #subpresenter4.

	^ aLayout! !

!SpTestingPresenterWithAdditionalPresenters class methodsFor: 'accessing' stamp: ''!
keys 

	^ #(subpresenter1 subpresenter2 subpresenter3)! !

!SpTestingPresenterWithModel commentStamp: ''!
A testing presenter for testing of the class SpPresenterWithModel

	| model presenter |
	model := SpTestingPointModel x: 1 y: 2.
	presenter := SpTestingPresenterWithModel on: model.
	presenter openWithSpec!
!SpTestingPresenterWithModel methodsFor: 'initialization' stamp: ''!
modelChanged

	x text: self model x asString.
	y text: self model y asString.	
	! !

!SpTestingPresenterWithModel methodsFor: 'accessing' stamp: ''!
y: anObject
	y := anObject! !

!SpTestingPresenterWithModel methodsFor: 'accessing' stamp: ''!
x
	^ x! !

!SpTestingPresenterWithModel methodsFor: 'accessing' stamp: ''!
x: anObject
	x := anObject! !

!SpTestingPresenterWithModel methodsFor: 'accessing' stamp: ''!
y
	^ y! !

!SpTestingPresenterWithModel methodsFor: 'initialization' stamp: ''!
initializePresenters
	
	x := self newTextInput.
	y := self newTextInput.! !

!SpTestingPresenterWithModel methodsFor: 'api' stamp: ''!
title

	^ 'Point'! !

!SpTestingPresenterWithModel class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newLeftToRight
		add: #x;
		add: #y;
		yourself! !

!SpTestingPresenterWithModel class methodsFor: 'specs' stamp: ''!
open

	<example>
	
	(self on: 1@2) openWithSpec! !

!SpTextAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTextPresenter! !

!SpTextAdapterTest methodsFor: 'tests' stamp: ''!
testSettingTextManuallyAffectsTheUndoManager
	| undoManager |

	self openInstance.
	presenter text: 'one'.

	undoManager := presenter adapter widget textArea editingState undoManager.	
	self deny: undoManager hasNext.
	self assert: undoManager hasPrevious! !

!SpTextAdapterTest methodsFor: 'tests' stamp: ''!
testWithoutUndoRedoHistory
	| undoManager |

	presenter withoutUndoRedoHistory.
	self openInstance.
	presenter text: 'one'.
	presenter type: 'two'.
	presenter type: 'three'.
	
	undoManager := presenter adapter widget textArea editingState undoManager.	
	self deny: undoManager hasNext.
	self deny: undoManager hasPrevious! !

!SpTextAdapterTest methodsFor: 'tests' stamp: ''!
testSettingTextManuallyClearsTheUndoManager
	| undoManager |

	self openInstance.
	presenter text: 'one'.

	"setting affect the undo manager"
	presenter 
		type: 'two';
		type: 'three'.

	presenter text: 'four'.

	undoManager := presenter adapter widget textArea editingState undoManager.	
	self deny: undoManager hasNext.
	self assert: undoManager hasPrevious.
	self assert: undoManager size equals: 1! !

!SpTextAdapterTest methodsFor: 'tests' stamp: ''!
testTextIsAlwaysString

	presenter text: 'one'.
	self openInstance.
	
	self assert: (presenter text isKindOf: String)
! !

!SpTextAdapterTest methodsFor: 'accessing' stamp: ''!
testRightClickShowsMenu
	| menu |

	presenter contextMenu: (menu := SpMockMenuPresenter new).

	self deny: menu shown.
	self emulateRightClick.
	self assert: menu shown! !

!SpTextAdapterTest methodsFor: 'tests' stamp: ''!
testLineAtCursorPosition

	self openInstance.
	presenter text: 'one
two
three'.
	
	presenter cursorPositionIndex: 5.
	self assert: presenter lineAtCursorPosition equals: 'two'.
	
	presenter cursorPositionIndex: 8.
	self assert: presenter lineAtCursorPosition equals: 'two'.	
	
	presenter cursorPositionIndex: 14.
	self assert: presenter lineAtCursorPosition equals: 'three'.
	
	presenter text: ''.
	presenter cursorPositionIndex: 1.
	self assert: presenter lineAtCursorPosition equals: ''.
	
	! !

!SpTextAdapterTest methodsFor: 'accessing' stamp: ''!
testKeyBindings
	| handled |

	handled := false.
	presenter 
		bindKeyCombination: $x meta 
		toAction: [ handled := true ].

	self adapter 
		keyDown: $x 
		shift: false 
		meta: true
		control: false
		option: false. 

	self assert: handled! !

!SpTextChangedPort commentStamp: ''!
!! Text Changed Output Port (==SpTextChangedPort==)
A ""text changed output port"" will handle the transmission when an input presenter content changes.

The presenter exposing a selection output port need to define also the event ==#whenTextChangedDo:==.

Presenters exposing this port: *class:SpAbstractTextPresenter* subclasses.!
!SpTextChangedPort methodsFor: 'attaching' stamp: ''!
attachTransmission: aTransmission to: aPresenter

	aPresenter whenTextChangedDo: [ :aString | 
		self 
			transmitWith: aTransmission 
			value: (self applyTransform: aString) ]! !

!SpTextChangedPort class methodsFor: 'accessing' stamp: ''!
portName
	^ #changed! !

!SpTextCopyCommand methodsFor: 'execution' stamp: ''!
execute

	context doTextCopy! !

!SpTextCopyCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $c command mac 
		| $c control win 
		| $c control unix! !

!SpTextCopyCommand class methodsFor: 'defaults' stamp: ''!
defaultIconName
	^#smallCopy! !

!SpTextCopyCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Copy'! !

!SpTextCutCommand methodsFor: 'execution' stamp: ''!
execute

	context doTextCut! !

!SpTextCutCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $x command mac 
		| $x control win 
		| $x control unix! !

!SpTextCutCommand class methodsFor: 'defaults' stamp: ''!
defaultIconName
	^#smallCut ! !

!SpTextCutCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Cut'! !

!SpTextEditionCommand commentStamp: ''!
I'm a base command for edition in code presenters. 
Operations like "copy", "paste" will be implemented by extending me. !
!SpTextEditionCommand class methodsFor: 'accessing' stamp: ''!
order
	"at the end by default"

	^ 999! !

!SpTextEditionCommand class methodsFor: 'accessing' stamp: ''!
allOrdered

	^ self allSubclasses sorted: #order ascending! !

!SpTextFieldExample commentStamp: ''!
A TextFieldExample is a simple example of how to use TextFields.!
!SpTextFieldExample methodsFor: 'api' stamp: ''!
initialExtent
	^ 900@550! !

!SpTextFieldExample methodsFor: 'accessing' stamp: ''!
methodBrowser

	^ methodBrowser! !

!SpTextFieldExample methodsFor: 'initialization' stamp: ''!
initializePresenters

	methodBrowser := self instantiate: SpDemoMessageBrowser.

	textField := self newTextInput.
	textField
		placeholder: 'Enter a class name';
		removeEntryCompletion! !

!SpTextFieldExample methodsFor: 'initialization' stamp: ''!
connectPresenters
	
	textField whenTextChangedDo: [ :text | 
		self class environment
			at: text asSymbol
			ifPresent: [ :class | methodBrowser messages: class methods ]
			ifAbsent: [ methodBrowser messages: #() ] ]! !

!SpTextFieldExample methodsFor: 'accessing' stamp: ''!
textField

	^ textField! !

!SpTextFieldExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #textField withConstraints: [ :constraints | constraints height: StandardFonts defaultFont height + 15 ];
		add: #methodBrowser;
		yourself! !

!SpTextFieldExample class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new openWithSpec! !

!SpTextFieldExample class methodsFor: 'specs' stamp: ''!
title

	^ 'Text Field Example'! !

!SpTextFieldExampleTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpTextFieldExample! !

!SpTextFindCommand methodsFor: 'executing' stamp: ''!
execute

	context doTextFind! !

!SpTextFindCommand class methodsFor: 'defaults' stamp: ''!
defaultShortcutKey

	^ $f command mac 
		| $f control unix
		| $f control win! !

!SpTextFindCommand class methodsFor: 'default' stamp: ''!
defaultIconName

	^ #smallFind! !

!SpTextInputFieldAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpTextInputFieldPresenter! !

!SpTextInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testMaxLengthIsSetInWidget

	presenter maxLength: 10.
	self assert: self widget maxLength equals: 10! !

!SpTextInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testPasswordIsSetInWidget

	presenter bePassword.
	self assert: self adapter isPassword! !

!SpTextInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testChangeWidgetTextUpdatesPresenter

	self adapter text: 'some text'.
	
	self assert: presenter text equals: 'some text'! !

!SpTextInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testNotPasswordIsSetInWidget

	presenter bePassword: false.
	self deny: self adapter isPassword! !

!SpTextInputFieldAdapterTest methodsFor: 'tests' stamp: ''!
testPresenterTextIsSetInWidget

	presenter text: 'something'.
	self assert: self widget text equals: 'something'! !

!SpTextInputFieldPresenter commentStamp: ''!
A presenter to handle a single line of text.
!
!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
beText
	"Set this input text as a text editor."

	self bePassword: false! !

!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
updateText
	"Update text but applying lenght constraints"
	
	self text: self text.! !

!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
removeEntryCompletion
	"Remove the entry completion"
	
	self entryCompletion: nil! !

!SpTextInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenEntryCompletionChangedDo: aBlock
	"Inform when entryCompletion property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #entryCompletion whenChangedDo: aBlock! !

!SpTextInputFieldPresenter methodsFor: 'private' stamp: ''!
bePassword: aBoolean
	
	isPassword := aBoolean! !

!SpTextInputFieldPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	maxLength := 0.
	isPassword := false.
	self beEditable.
! !

!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
entryCompletion
	"Return an entry completion used to suggest text while typing"

	^ entryCompletion! !

!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
text: aString
	"Set input text contents."
	| truncatedText |

	truncatedText := self maxLength = 0
		ifTrue: [ aString ]
		ifFalse: [ aString first: (self maxLength min: aString size) ].
	super text: truncatedText! !

!SpTextInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenSubmitDo: aBlock
	"This method will add a 'submit' event to the widget. It will react when user 
	 presses <meta+s> key (this is for historical reasons), and with enter (cr).
	 `aBlock` receives one argument (the submited text)"

	self 
		bindKeyCombination: Character cr asKeyCombination | $s meta 
		toAction: aBlock! !

!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
maxLength
	"Answer maximum allowed length (if set)"

	^ maxLength! !

!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
beNotEditable
	"Set content text as not editable (readonly)"

	self editable: false! !

!SpTextInputFieldPresenter methodsFor: 'testing' stamp: ''!
isEditable
	"Answer true if edition is allowed (component is NOT readonly)"

	^ editable! !

!SpTextInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenEditableChangedDo: aBlock
	"Inform when editable property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #editable whenChangedDo: aBlock! !

!SpTextInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenPasswordChangedDo: aBlockClosure 
	"Inform when password property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
	
	self property: #isPassword whenChangedDo: aBlockClosure! !

!SpTextInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenMaxLengthChangedDo: aBlockClosure 
	"Inform when maxLength property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
	
	self property: #maxLength whenChangedDo: aBlockClosure! !

!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
entryCompletion: anEntryCompletion
	"Set an entry completion used to suggest text while typing"

	entryCompletion := anEntryCompletion! !

!SpTextInputFieldPresenter methodsFor: 'TOREMOVE' stamp: ''!
eventKeyStrokesForPreviousFocus
	"String describing the keystroke to perform to jump to the previous widget"
	
	^ { Character tab shift asKeyCombination }! !

!SpTextInputFieldPresenter methodsFor: 'private' stamp: ''!
editable: aBoolean

	editable := aBoolean! !

!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
beEditable
	"Allow edition (deny readonly)."

	self editable: true! !

!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
bePassword
	"Set this input text as a password editor."
	
	self bePassword: true! !

!SpTextInputFieldPresenter methodsFor: 'TOREMOVE' stamp: ''!
eventKeyStrokesForNextFocus
	"String describing the keystroke to perform to jump to the next widget"	
		
	^ { Character tab asKeyCombination }! !

!SpTextInputFieldPresenter methodsFor: 'api' stamp: ''!
maxLength: anInteger 
	"Set maximum allowed length."
	
	maxLength := anInteger.
	self updateText.! !

!SpTextInputFieldPresenter methodsFor: 'testing' stamp: ''!
isPassword
	"Answer true if input field will be shown as a password (hiding characters)."
	
	^ isPassword! !

!SpTextInputFieldPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
examplePassword

	^ self new
		extent: 300 @ 25;
		bePassword;
		placeholder: 'This is a ghost';
		text: 'shhh';
		openWithSpec! !

!SpTextInputFieldPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleEntryCompletion
	| applicants entryCompletion |

	applicants := (Array
		streamContents: [ :strm | 
			Symbol allSymbolTablesDo: [ :each | 
				(each notEmpty 
					and: [ each first canBeGlobalVarInitial 
					and: [ Smalltalk globals includesKey: each ] ])
					ifTrue: [ strm nextPut: each ] ] ]) sort.
	
	entryCompletion := EntryCompletion new
		dataSourceBlock: [ :currText | applicants ];
		filterBlock: [ :currApplicant :currText | 
			currText size > 3 
				and: [ currApplicant asUppercase includesSubstring: currText asString asUppercase ] ].

	^ self new
		extent: 300 @ 25;
		placeholder: 'Enter a class name (at least 4 letters)';
		entryCompletion: entryCompletion;
		openWithSpec! !

!SpTextInputFieldPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>

	^ self new
		extent: 300 @ 25;
		placeholder: 'This is a ghost';
		text: 'This is a text';
		openWithSpec! !

!SpTextInputFieldPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TextInputFieldAdapter! !

!SpTextInputFieldPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpTextInputFieldPresenter! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testBePasswordIsSet

	presenter bePassword.
	
	self assert: presenter isPassword! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testDefaultIsNotPassword

	self deny: presenter isPassword! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testDefaultTextIsEmpty

	self assert: presenter text isEmpty! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testMaxLengthTruncatesAlreadyTypedText

	presenter text: '1234567890 ---'.
	presenter maxLength: 10.
	self assert: presenter text equals: '1234567890'! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testBeTextIsSet
	presenter beText.
	self deny: presenter isPassword! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testMaxLengthTruncatesText

	presenter maxLength: 10.
	presenter text: '1234567890 ---'.
	self assert: presenter text equals: '1234567890'! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testDefaultMaxLengthIsZero

	self assert: presenter maxLength equals: 0! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testWhenPlaceholderChangesRaisesSingleEvent

	self
		assertWith: [ :times | times = 1 ]
		timesRaisedEvent: #whenPlaceholderChangedDo:
		inPresenter: presenter
		whenDoing: [ presenter placeholder: 'test' ]! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testBeNotPasswordIsSet

	presenter bePassword: false.
	
	self deny: presenter isPassword! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testDefaultPlaceholderIsEmpty

	self assert: presenter placeholder isEmpty! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testMaxLengthIsSet

	presenter maxLength: 10.
	
	self assert: presenter maxLength equals: 10! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testWhenTextChangesRaisesSingleEvent

	self
		assertWith: [ :times | times = 1 ]
		timesRaisedEvent: #whenTextChangedDo:
		inPresenter: presenter
		whenDoing: [ presenter text: 'test' ]! !

!SpTextInputFieldPresenterTest methodsFor: 'tests' stamp: ''!
testTextIsSet

	presenter text: 'aText'.
	
	self assert: presenter text equals: 'aText'! !

!SpTextPasteCommand methodsFor: 'execution' stamp: ''!
execute

	context doTextPaste! !

!SpTextPasteCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $v command mac 
		| $v control win 
		| $v control unix! !

!SpTextPasteCommand class methodsFor: 'defaults' stamp: ''!
defaultIconName
	^#smallPaste! !

!SpTextPasteCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Paste'! !

!SpTextPort commentStamp: ''!
!! Text Input Port (==SpTextPort==)
A ""text input port"" define an incomming transmission to modify the text of a text presenter (input fields or text areas).

The presenter exposing a text input port need to define also the method ==#text:==.

Presenters exposing this port: *class:SpAbstractTextPresenter* subclasses.!
!SpTextPort methodsFor: 'handling transmission' stamp: ''!
applyIncomingTransmission: anObject from: outPort to: aPresenter

	aPresenter text: anObject! !

!SpTextPort class methodsFor: 'accessing' stamp: ''!
portName

	^ #text! !

!SpTextPresenter commentStamp: ''!
A presenter to handle basic multi-line text.!
!SpTextPresenter methodsFor: 'private' stamp: ''!
wrapWord: aBoolean

	wrapWord := aBoolean! !

!SpTextPresenter methodsFor: 'api - events' stamp: ''!
whenScrollValueChangedDo: aBlock
	"Inform when scrollValue property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"
	
	self property: #scrollValue whenChangedDo: aBlock! !

!SpTextPresenter methodsFor: 'private' stamp: ''!
editionCommandsGroup

	^ SpRecursiveContextSetter 
		visit: (self class buildEditionCommandsGroupFor: self defaultCommandsContext) 
		toSetContext: self defaultCommandsContext! !

!SpTextPresenter methodsFor: 'testing' stamp: ''!
isWrapWord
	"Answer true if words will be wrapped to make text fit horizontally into component area."

	^ wrapWord! !

!SpTextPresenter methodsFor: 'commands' stamp: ''!
doTextFindNext

		self withAdapterDo: [ :anAdapter | anAdapter findNextText ]! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
cursorPosition
	"Answer a Point (column, row) with current cursor position"

	^ self withAdapterDo: [ :anAdapter | anAdapter cursorPosition ]! !

!SpTextPresenter methodsFor: 'api - events' stamp: ''!
whenSubmitDo: aBlock
	"This method will add a 'submit' event to the widget. It will react when user 
	 presses <meta+s> key (this is for historical reasons) and with enter (cr).
	 `aBlock` receives one argument (the submited text)"

	self 
		bindKeyCombination: SpAcceptChangesCommand defaultShortcutKey 
		toAction: [ aBlock value: self text ]! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
withEditionContextMenu
	"Enables edition context menu. When this option is selected, right-clicking in the text area 
	 will show a standard edition menu (copy, cut, copy&paste). 
	 Adding your own context menu (See `SpAbstractTextPresenter>>#contextMenu:`) will make both 
	 menus (edition and your own) to be combined into one single context menu."

	editionContextMenu := true! !

!SpTextPresenter methodsFor: 'private - testing' stamp: ''!
hasEditionContextMenu

	^ editionContextMenu! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
beNotEditable
	"Set content text as not editable (readonly)"

	self editable: false! !

!SpTextPresenter methodsFor: 'testing' stamp: ''!
isEditable
	"Answer true if edition is allowed (component is NOT readonly)"

	^ editable! !

!SpTextPresenter methodsFor: 'api - events' stamp: ''!
whenEditableChangedDo: aBlock
	"Inform when editable property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #editable whenChangedDo: aBlock! !

!SpTextPresenter methodsFor: 'commands' stamp: ''!
doTextSelectAndPaste

	self withAdapterDo: [ :anAdapter | anAdapter selectAndPasteText ]! !

!SpTextPresenter methodsFor: 'testing' stamp: ''!
hasScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	^ wrapScrollBars! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
propagateNaturalHeight: aBoolean
	"Indicate when component propagates natural heigth.
	 Natural height propagation means that the height of the presenter containing both scrollbars and 
	 another component (tipically a text presenter) will follow the height of such component."

	propagateNaturalHeight := aBoolean! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
withUndoRedoHistory

	undoRedoHistory := true! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
withScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	wrapScrollBars := true! !

!SpTextPresenter methodsFor: 'private' stamp: ''!
editable: aBoolean

	editable := aBoolean! !

!SpTextPresenter methodsFor: 'initialization' stamp: ''!
registerEvents

	super registerEvents.
	self whenScrollValueChangedDo: [ :newPosition | 
		self changed: #setScrollValue: with: { newPosition } ]! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
removeScrollBarStyle: aStyle
	"Remove `aStyle` from the list of scrollbar styles.
	 See SpTHaveWrappingScrollBars>>#scrollBarStyles"

	scrollBarStyles := scrollBarStyles copyWithout: aStyle! !

!SpTextPresenter methodsFor: 'initialization' stamp: ''!
initializeTHaveWrappingScrollBars

	scrollBarStyles := #().
	self propagateNaturalWidth: false.
	self propagateNaturalHeight: false! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
beEditable
	"Allow edition (deny readonly)."

	self editable: true! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
scrollValue: aPoint
	"Set the scroll position"

	^ scrollValue := aPoint! !

!SpTextPresenter methodsFor: 'testing' stamp: ''!
isPropagateNaturalWidth
	"Indicate if component propagates natural width.
	 See `SpTHaveWrappingScrollBars>>#propagateNaturalWidth:`"

	^ propagateNaturalWidth ifNil: [ false ]! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
addScrollBarStyle: aStyle
	"Add a style for the scrollbar component. 
	 In platforms that do not support separation from component and scrollbar (like Morphic), the 
	 style will be added to the component styles. 
	 In platforms who supports separation between component and scrollbar (like Gtk3), the style 
	 will be taken separately."

	scrollBarStyles := scrollBarStyles copyWith: aStyle! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
withoutScrollBars
	"Some backends like Morphic forces the scrollbars in their Tables and Lists. 
	 But some others like Gtk3 don't. This option allows you to configure the precence 
	 of scrollbars for platforms who do not have them automatically.
	 By default lists/tables will have scrollbars added by default, but you can tune this 
	 if your backend of choice supports it.
	 THIS CANNOT BE CHANGED ONCE THE WIDGET IS CREATED."

	wrapScrollBars := false! !

!SpTextPresenter methodsFor: 'commands' stamp: ''!
doTextFind

	self withAdapterDo: [ :anAdapter | anAdapter findText ]! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
beWrapWord
	"Set component to wrap words to make the text fit in screen."

	self wrapWord: true! !

!SpTextPresenter methodsFor: 'commands' stamp: ''!
doTextCut

	self withAdapterDo: [ :anAdapter | anAdapter cutText ]! !

!SpTextPresenter methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	self initializeTHaveWrappingScrollBars.
	self flag: #REVIEW. "We really need scrollValue?"
	scrollValue := 0@0.
	self beEditable.
	self beWrapWord.
	self withScrollBars.
	self withEditionContextMenu.
	self withUndoRedoHistory! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
withoutEditionContextMenu
	"Disable default edition context menu. 
	 See also `SpTextPresenter>>#withEditionContextMenu`."

	editionContextMenu := false! !

!SpTextPresenter methodsFor: 'private' stamp: ''!
editionContextMenu

	^ self editionCommandsGroup asMenuPresenter! !

!SpTextPresenter methodsFor: 'commands' stamp: ''!
doTextCopy

	self withAdapterDo: [ :anAdapter | anAdapter copyText ]! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
beNotWrapWord
	"Set component to not wrap words when text does not fit in screen.
	 Instead, the editor will add an horizontal scrollbar."

	self wrapWord: false! !

!SpTextPresenter methodsFor: 'commands' stamp: ''!
doTextPaste

		self withAdapterDo: [ :anAdapter | anAdapter pasteText ]! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
scrollValue
	"Return the current scroll position"

	^ scrollValue! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
withoutUndoRedoHistory

	undoRedoHistory := false! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
scrollBarStyles
	"Answer styles defined for the scrollbar component. 
	 In platforms that do not support separation from component and scrollbar (like Morphic), the 
	 style will be added to the component styles. 
	 In platforms who supports separation between component and scrollbar (like Gtk3), the style 
	 will be taken separately."

	^ scrollBarStyles ifNil: [ #() ]! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
lineAtCursorPosition

	self withAdapterDo: [ :anAdapter | ^ anAdapter lineAtCursorPosition ].
	^ nil! !

!SpTextPresenter methodsFor: 'api - events' stamp: ''!
whenCursorPositionChangedDo: aBlock
	"Inform when cursorPosition property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #cursorPosition whenChangedDo: aBlock! !

!SpTextPresenter methodsFor: 'api - events' stamp: ''!
whenWrapWordChangedDo: aBlock
	"Inform when wordWrap property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #wrapWord whenChangedDo: aBlock! !

!SpTextPresenter methodsFor: 'testing' stamp: ''!
isPropagateNaturalHeight
	"Indicate if component propagates natural heigth.
	 See `SpTHaveWrappingScrollBars>>#propagateNaturalHeight:`"

	^ propagateNaturalHeight ifNil: [ false ]! !

!SpTextPresenter methodsFor: 'private' stamp: ''!
editionContextKeyBindings

	^ self editionCommandsGroup asKMCategory! !

!SpTextPresenter methodsFor: 'testing' stamp: ''!
hasUndoRedoHistory

	^ undoRedoHistory! !

!SpTextPresenter methodsFor: 'api' stamp: ''!
propagateNaturalWidth: aBoolean
	"Indicate when component propagates natural width.
	 Natural width propagation means that the width of the presenter containing both scrollbars and 
	 another component (tipically a text presenter) will follow the width of such component.
	 WARNING: Because of a limitation on how the font rendering works in morphic backend, 
	 this properly will fail to preserve the correct width if using monospaced fonts."

	propagateNaturalWidth := aBoolean! !

!SpTextPresenter class methodsFor: 'commands' stamp: ''!
textSearchCommandsGroupWith: aPresenter
	| group |

	group := (CmCommandGroup named: 'Search commands') asSpecGroup.
	group
		description: 'Search text.';
		beDisplayedAsGroup.
	
	SpTextSearchCommand allOrdered 
		do: [ :commandClass | group register: (commandClass forSpecContext: aPresenter) ].
	
	^ group! !

!SpTextPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithoutEditionContextMenu
	"This example should show a text editor without the default edition context menu"

	^ self new
		withoutEditionContextMenu;
		text:
			'This is a test.
If this had been an actual emergency...
(If you right click here, no context menu will be shown)';
		openWithSpec

! !

!SpTextPresenter class methodsFor: 'commands' stamp: ''!
buildEditionCommandsGroupFor: presenterInstance
	| rootCommandGroup |

	rootCommandGroup := CmCommandGroup forSpec beRoot.
	self 
		buildEditionCommandsGroupWith: presenterInstance 
		forRoot: rootCommandGroup.
	
	^ rootCommandGroup! !

!SpTextPresenter class methodsFor: 'commands' stamp: ''!
buildEditionCommandsGroupWith: presenter forRoot: aCmCommandsGroup

	aCmCommandsGroup beDisplayedAsGroup.
	aCmCommandsGroup register: (self textSearchCommandsGroupWith: presenter).	
	aCmCommandsGroup register: (self textEditionCommandsGroupWith: presenter).! !

!SpTextPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newText! !

!SpTextPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example

	^ self new
		text:
			'This is a test.
If this had been an actual emergency...';
		openWithSpec! !

!SpTextPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TextAdapter! !

!SpTextPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Text'! !

!SpTextPresenter class methodsFor: 'commands' stamp: ''!
textEditionCommandsGroupWith: aPresenter
	| group |

	group := (CmCommandGroup named: 'Selection edition commands') asSpecGroup.
	group
		description: 'Edit code selection.';
		beDisplayedAsGroup.
	
	SpTextEditionCommand allOrdered 
		do: [ :commandClass | group register: (commandClass forSpecContext: aPresenter) ].
	
	^ group! !

!SpTextPresenterDecorator commentStamp: ''!
I specify segment decorations for text presenters.
Adapters must transform me to text segment compatible with the target backend.

For now, I can be composed of two styles, #highlight and #underlined.
!
!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
stop 
	^interval last! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
iconBlock: anObject
	iconBlock := anObject! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
title: anObject
	title := anObject! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
highlightColor: anObject
	highlightColor := anObject! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
interval
	^ interval! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
underlineColor: anObject
	underlineColor := anObject! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
borderColor: anObject
	borderColor := anObject! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
underlineColor
	^ underlineColor! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
highlightColor
	^ highlightColor! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
interval: anInterval

	interval := anInterval! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
start 
	^interval first! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
iconBlock
	^ iconBlock! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
borderColor
	^ borderColor! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
icon: anObject
	icon := anObject! !

!SpTextPresenterDecorator methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!SpTextPresenterDecorator class methodsFor: 'accessing' stamp: ''!
defaultHighlightColor
		
	^ Color orange alpha: 0.5! !

!SpTextPresenterDecorator class methodsFor: 'accessing' stamp: ''!
highlightStyleName

	^ #highlight! !

!SpTextPresenterDecorator class methodsFor: 'instance creation' stamp: ''!
forHighlight

	^ self new
		highlightColor: self defaultHighlightColor;
		underlineColor: self defaultUnderlineColor;	
		yourself! !

!SpTextPresenterDecorator class methodsFor: 'accessing' stamp: ''!
underlineStyleName

	^ #underline! !

!SpTextPresenterDecorator class methodsFor: 'accessing' stamp: ''!
defaultUnderlineColor
		
	^ Color white alpha: 0! !

!SpTextPresenterDecoratorMorphicAdapterTest methodsFor: 'tests' stamp: ''!
testRemoveAllTextPresenterDecorators
	self assertEmpty: widget segments.
	adapter addTextSegmentDecoration: decorator.
	adapter removeAllTextSegmentDecorations.
	self assertEmpty: widget segments! !

!SpTextPresenterDecoratorMorphicAdapterTest methodsFor: 'tests' stamp: ''!
testAddTextPresenterDecorator
	self assertEmpty: widget segments.
	adapter addTextSegmentDecoration: decorator.
	self assert: widget segments size equals: 1.
	self assert: widget segments first class identicalTo: RubUnderlinedSegmentMorph ! !

!SpTextPresenterDecoratorMorphicAdapterTest methodsFor: 'tests' stamp: ''!
testTransformTextPresenterDecoratorToSegment! !

!SpTextPresenterDecoratorMorphicAdapterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	decorator := SpTextPresenterDecorator new.
	decorator highlightColor: Color red.	
	decorator underlineColor: Color green.
	decorator title: 'Test segment decoration'.
	decorator icon: (self iconNamed: #halt).
	decorator iconBlock: [ :seg| seg].
	decorator interval: (1 to: 42).
	adapter := SpMorphicTextAdapter adapt: SpTextPresenter new.
	widget := adapter widget! !

!SpTextPresenterDecoratorTest methodsFor: 'tests' stamp: ''!
testStartStop
	decorator interval: (0 to: 10).
	self assert: decorator start equals: 0.
	self assert: decorator stop equals: 10.! !

!SpTextPresenterDecoratorTest methodsFor: 'tests' stamp: ''!
testForHighlight

	decorator := SpTextPresenterDecorator forHighlight.
	
	self 
		assert: decorator highlightColor 
		equals: SpTextPresenterDecorator defaultHighlightColor.
	self 
		assert: decorator underlineColor
		equals: SpTextPresenterDecorator defaultUnderlineColor! !

!SpTextPresenterDecoratorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	decorator := SpTextPresenterDecorator new
! !

!SpTextPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpTextPresenter! !

!SpTextPresenterTest methodsFor: 'tests' stamp: ''!
testInsertAt
	
	self initializationText.
	self openInstance.
	presenter insert: 'insertion ' at: 9.
	self assert: presenter text equals: 'Text for insertion tests.'! !

!SpTextPresenterTest methodsFor: 'tests' stamp: ''!
testSelectLine

	presenter text: 'Text for tests.
with multiple
lines'.
	self openInstance.
	presenter selectLine.
	self assert: presenter selectionInterval equals: (1 to: 15)! !

!SpTextPresenterTest methodsFor: 'tests' stamp: ''!
testPropagateNaturalHeightWithMultipleLines
	| string |

	"This test do not pass on CI because headless image has display size = 0@0 and then 
	 morphic behaves weird. PropagateNaturalHeight/Width is weak on Morphic because of 
	 this (if not, see the algoritm I was forced to do), but for now passes (just, not on CI :)"
	Smalltalk isHeadless ifTrue: [ ^ self skip ].
 
	string := String loremIpsum withNoLineLongerThan: 80.
	presenter text: string.
	presenter propagateNaturalHeight: true. 
	self openInstance.
	self assert: presenter adapter widget height >= (string lines size * string asMorph height).! !

!SpTextPresenterTest methodsFor: 'tests' stamp: ''!
testPropagateNaturalWidth
	| lipsum stringMorph expectedWidth |

	"This test do not pass on CI because headless image has display size = 0@0 and then 
	 morphic behaves weird. PropagateNaturalHeight/Width is weak on Morphic because of 
	 this (if not, see the algoritm I was forced to do), but for now passes (just, not on CI :)"
	Smalltalk isHeadless ifTrue: [ ^ self skip ].

	lipsum := String loremIpsum withNoLineLongerThan: 50.

	presenter text: lipsum.
	presenter propagateNaturalWidth: true. 
	self openInstance.
	
	stringMorph := RubEditingArea new 
		font: presenter adapter widget font;
		updateTextWith: lipsum.

	expectedWidth := stringMorph width + 12 min: self currentWorld width / 3.
	
	
	self assert: presenter adapter widget width >= expectedWidth.
	
	! !

!SpTextPresenterTest methodsFor: 'tests' stamp: ''!
testPropagateNaturalHeight


	"This test do not pass on CI because headless image has display size = 0@0 and then 
	 morphic behaves weird. PropagateNaturalHeight/Width is weak on Morphic because of 
	 this (if not, see the algoritm I was forced to do), but for now passes (just, not on CI :)"
	Smalltalk isHeadless ifTrue: [ ^ self skip ].

	presenter text: String loremIpsum.
	presenter propagateNaturalHeight: true. 
	self openInstance.
	self assert: presenter adapter widget height >= String loremIpsum asMorph height.! !

!SpTextPresenterTest methodsFor: 'tests' stamp: ''!
testSelectLineSecondLine

	presenter text: 'Text for tests.
with multiple
lines'.
	self openInstance.
	presenter cursorPositionIndex: 17.
	presenter selectLine.
	self assert: presenter selectionInterval equals: (17 to: 29)! !

!SpTextPresenterTest methodsFor: 'tests' stamp: ''!
testEditable

	presenter beNotEditable.
	self openInstance.
	
	presenter adapter 
		keyDown: $x asciiValue
		shift: false 
		meta: false 
		control: false 
		option: false.
	
	self assert: presenter text equals: ''.
	
	presenter beEditable.
	
	presenter adapter 
		keyPressed: $x 
		shift: false 
		meta: false 
		control: false 
		option: false.
	
	self assert: presenter text equals: 'x'.
! !

!SpTextSearchCommand class methodsFor: 'accessing' stamp: ''!
order
	"at the end by default"

	^ 999! !

!SpTextSearchCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Find'! !

!SpTextSearchCommand class methodsFor: 'accessing' stamp: ''!
allOrdered

	^ self allSubclasses sorted: #order ascending! !

!SpTextSelectAndPasteCommand methodsFor: 'execution' stamp: ''!
execute

	context doTextSelectAndPaste! !

!SpTextSelectAndPasteCommand class methodsFor: 'defaults' stamp: ''!
defaultIconName
	^#smallCopy ! !

!SpTextSelectAndPasteCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Paste...'! !

!SpTextStyle commentStamp: ''!
Text property controls how the "input text" fields (`SpTextInputFieldPresenter` hierarchy for now)!
!SpTextStyle methodsFor: 'accessing' stamp: ''!
drawKeyboardFocus: aBoolean

	drawKeyboardFocus := aBoolean asStyleVariable! !

!SpTextStyle methodsFor: 'accessing - variables' stamp: ''!
drawKeyboardFocusVariable

	^ self toVariable: drawKeyboardFocus! !

!SpTextStyle methodsFor: 'accessing' stamp: ''!
drawKeyboardFocus

	^ self drawKeyboardFocusVariable value! !

!SpTextStyle methodsFor: 'operations' stamp: ''!
applyTo: aMorph


	self drawKeyboardFocusVariable
		ifNotNil: [ :aVariable | aMorph drawKeyboardFocus: aVariable value ]! !

!SpTextStyle class methodsFor: 'ston-core' stamp: ''!
stonName
	
	^ 'Text'! !

!SpTheHeartOfSpec commentStamp: ''!
A SpecExamples is the second sub-book of SpecHelpTopics. It contains the core of Spec briefly explained.
See class side for selectors.
!
!SpTheHeartOfSpec class methodsFor: 'accessing' stamp: ''!
pages
	^#(intro #initializePresenters widgetInstantiation #connectPresenters layouts)! !

!SpTheHeartOfSpec class methodsFor: 'accessing' stamp: ''!
bookName
	^'The Heart of Spec'! !

!SpTheHeartOfSpec class methodsFor: 'pages' stamp: ''!
widgetInstantiation
	^HelpTopic
		title: 'Widget Instantiation'
		contents: 'The instantiation of the model for a widget (and hence the widget) can be done in two ways: 
Through the use of an creation method or through the use of the instantiate: method. Considering the first option, the framework provides unary messages for the creation of all basic widgets. The format of these messages is:   
	new[Widget]

for example newButton creates a button widget, and newList creates a list widget. 
The complete list of available widget creation methods can be found in the class Composable-Model in the protocol widgets. 

Considering the second option, to reuse any composite widgets, i.e. a subclass of SpPresenter, the widget needs to be initialized using the instantiate: method. For example, to reuse a Message-Browser widget, the code is:

	self instantiate: MessageBrowser.'! !

!SpTheHeartOfSpec class methodsFor: 'pages' stamp: ''!
intro
	^HelpTopic 
		title: 'The Heart of Spec'
		contents: 'All user interfaces in Spec are constructed through the composition of existing user interfaces. To define a user interface, it is sufficient to define the model of the user interface. The UI elements that correspond to this model are instantiated by Spec, depending on the underlying UI framework. 
		
It is the composition of this model and these UI elements that makes up the resulting widget that is shown to the user, i.e. the resulting user interface. Hence, since all UIs are constructed through composition of other UIs, and it is sufficient to define the model to define the UI, the root class of all UIs is named SpPresenter. So, to define a new user interface, a subclass of SpPresenter needs to be created.

Spec is inspired by the MVP pattern. It is built around three axes that materialize themselves as the following three methods: 

SpPresenter>>#initializeWidgets
SpPresenter>>#initializePresenter
SpPresenter class>>#defaultSpec. 
	
These methods are hence typically found in the model for each user interface. In the following topics we describe the responsibility for each method, i.e. how these three work together to build the overall UI.'! !

!SpTheHeartOfSpec class methodsFor: 'pages' stamp: ''!
layouts
	^HelpTopic
		title: 'The layout method'
		contents: 'This method specifies the layout of the different widgets in the UI. It also specifies how a widget reacts when the window is resized. For the same UI multiple layouts can be described, and when the UI is built a specific layout to use can be specified. If no such specific layout is given, the following lookup mechanism will be used to obtain the layout method:

1. Search on class side, throughout the whole class hierarchy, for a method with the pragma <spec: #default>.
2. If multiple such methods exist, the first one found is used.
3. If none such methods exist and if there is exactly one method with the pragma <spec>, this method is used.
4. No layout method is found, an error is raised.

This method is on class side because it returns a value that usually is the same for all the instances. Put differently, usually all the instances of the same user interface have the same layout and hence this can be considered as being a class-side accessor for a class variable. Note that the lookup for the spec method to use starts on instance side, which allows a UI to have a more specific layout depending on the state of the instance.

In its simplest form, this method could be:

	^ SpecLayout composed
			add: #theList;
			yourself


The symbol theList refers to an instance side method returning a widget. This is because instance variables are private, so the layout class needs to use an accessor to obtain it when building the UI. Note that by default, a widget will take all the space available in its container.
This method is not restricted to laying out sub widgets. It can also refer to sub widgets contained in sub widgets, i.e. when reusing an existing UI, specify a new layout for the sub widgets that comprise this UI. To do this, instead of giving a symbol, an array with 2 symbols must be given. 
The first symbol identifies the UI being reused and the second the sub widget within this UI whose new layout position is being specified. 
As said above, multiple layouts can be described for the same user interface. In order to retrieve the correct method to apply, these methods need to be flagged with a pragma. The pragma can be either <spec: default> for the layout to use by default, or <spec> for the other layouts.

Specifying this method is mandatory, as without it the UI would show no widgets to the user.'
! !

!SpTheHeartOfSpec class methodsFor: 'pages' stamp: ''!
initializePresenters
	^HelpTopic
		title: 'The initializeWidgets method'
		contents: 'This method is used to instantiate the models for the different widgets that will be part of the UI and store them in their respective instance variables. Instantiation of the models will in turn result in the instantiation and initialization of the different widgets that make up the UI. Consequently, configuration and default values of each widget are specified here as well, which is why this method is called initializeWidgets. This focus in this method is to specify what the widgets will look like and what their self-contained behavior is. 
The behavior to update model state, e.g. when pressing a Save button, is described in this method as well. It is explicitly not the responsibility of this method to define the interactions between the widgets.

In general the initializeWidgets method should follow the pattern:
• widgets instantiation
• widgets configuration specification
• specification of order of focus

The last step is not mandatory but highly recommended. Indeed, without this final step keyboard navigation will not work at all.

An example of the initializeWidgets method could be:

	initializeWidgets
		theButton := self newButton.
		theList := self newList.
		theButton label: ''I am a button''.
		self focusOrder
		add: theButton;
		add: theList.

Specifying this method is mandatory, as without it the UI would have no widgets.'! !

!SpTheHeartOfSpec class methodsFor: 'pages' stamp: ''!
connectPresenters
	^HelpTopic
		title: 'The initializePresenter method'
		contents: 'This method takes care of the interactions between the different widgets. By linking the behavior of the different widgets it specifies the overall presentation, i.e. how the overall UI responds to interactions by the user. Usually this method consists of specifications of actions to perform when a certain event is received by a widget. From the propagation of those events the whole interaction flow of the UI emerges. In Spec, the different UI models are contained in value holders, and the event mechanism relies on the announcements of these value holders to manage the interactions between widgets. 
Value holders provide a single method whenChangedDo: that is used to register a block to perform on change. In addition to this primitive whenChangedDo: method, the basic widgets provide more specific hooks, e.g. when an item in a list is selected or deselected.'! !

!SpTickingSpecWindow commentStamp: ''!
TickingSpecWindow new openInWorld!
!SpTickingSpecWindow methodsFor: 'stepping and presenter' stamp: ''!
step
	self model step.! !

!SpTickingSpecWindow methodsFor: 'stepping' stamp: ''!
wantsSteps
	^ true! !

!SpTickingSpecWindow methodsFor: 'stepping' stamp: ''!
stepTime

	^ self model stepTime! !

!SpTickingWindowPresenter commentStamp: ''!
In addition to my superclass, I provide an API to execute the `step` method every `stepTime`.!
!SpTickingWindowPresenter methodsFor: 'stepping' stamp: ''!
step
	self presenter step! !

!SpTickingWindowPresenter methodsFor: 'stepping' stamp: ''!
stepTime
	^ self presenter stepTime! !

!SpTickingWindowPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TickingWindowAdapter! !

!SpToggleButtonAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpToggleButtonPresenter ! !

!SpToggleButtonExample commentStamp: ''!
A demo to show how to use associated toggle buttons with Spec.

self example!
!SpToggleButtonExample methodsFor: 'updating' stamp: ''!
updateLabel
	label
		label:
			(String
				streamContents: [ :s | 
					{button1 . button2 . button3}
						do: [ :button | 
							s
								<< button label;
								<< ' : ';
								<< (button state ifTrue: [ 'V' ] ifFalse: [ 'X' ]) ]
						separatedBy: [ s << ' - ' ] ])! !

!SpToggleButtonExample methodsFor: 'initialization' stamp: ''!
initializePresenters

	button1 := self newToggleButton.
	button2 := self newToggleButton.
	button3 := self newToggleButton.
	label := self newLabel.
	button1 associatedToggleButtons: { button2. button3 }.

	button1 label: 'Button 1'.
	button2 label: 'Button 2'.
	button3 label: 'Button 3'.

	self updateLabel! !

!SpToggleButtonExample methodsFor: 'initialization' stamp: ''!
connectPresenters

	button1 whenActivatedDo: [ self updateLabel ].
	button1 whenDeactivatedDo: [ self updateLabel ].
	button2 whenChangedDo: [ self updateLabel ].
	button3 whenChangedDo: [ self updateLabel ]! !

!SpToggleButtonExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: (SpBoxLayout newTopToBottom
				add: #button1 expand: false;
				add: #button2 expand: false;
				add: #button3 expand: false;
				yourself);
		add: #label expand: false;
		yourself! !

!SpToggleButtonExample class methodsFor: 'examples' stamp: ''!
example

	^ self new openWithSpec! !

!SpToggleButtonExample class methodsFor: 'specs' stamp: ''!
title

	^ 'Toggle Button Example'! !

!SpToggleButtonPresenter commentStamp: ''!
A presenter to display a toggle button.
A toggle button is a button that can be activated (toggled) or deactivated (untoggled).
!
!SpToggleButtonPresenter methodsFor: 'api' stamp: ''!
action: aBlock
	"Set the action to execute when button is pressed. 
	 `aBlock` receives zero arguments."
	
	action := aBlock! !

!SpToggleButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	action := [ ]! !

!SpToggleButtonPresenter methodsFor: 'api' stamp: ''!
associatedToggleButtons: aCollection 
	"Set the list of toggle buttons associated with this one.
	 By using this, you will be grouping together this toggle button along with the ones contained 
	 in `aCollection`.
	 You should NOT send this message to all associated toggle buttons, the first of them is enough."
	| allElements |
	
	"pass group to all members"	
	allElements := { self }, aCollection.
	allElements do: [ :each | 
		each basicAssociatedToggleButtons: allElements ].
	
	"self state: true."
	aCollection do: [ :each | each state: false ]! !

!SpToggleButtonPresenter methodsFor: 'api' stamp: ''!
action 
	"Answer the action to execute when button is pressed.
	 See `SpToggleButtonPresenter>>#action:`"
	
	^ action! !

!SpToggleButtonPresenter methodsFor: 'api' stamp: ''!
associatedToggleButtons

	^ associatedToggleButtons ifNil: [ #() ]! !

!SpToggleButtonPresenter methodsFor: 'api - events' stamp: ''!
whenIconChangedDo: aBlock
	"Inform when icon property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #icon whenChangedDo: aBlock! !

!SpToggleButtonPresenter methodsFor: 'api' stamp: ''!
icon
	"Answer the icon (an instance of `Form`) to be shown with the button."

	^ icon! !

!SpToggleButtonPresenter methodsFor: 'private' stamp: ''!
basicAssociatedToggleButtons: aCollection 
	
	associatedToggleButtons := aCollection copyWithout: self! !

!SpToggleButtonPresenter methodsFor: 'api' stamp: ''!
icon: anIcon
	"Set the icon (an instance of `Form`) to be shown with the button."

	icon := anIcon! !

!SpToggleButtonPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newToggleButton! !

!SpToggleButtonPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example

	self new
		icon: (self iconNamed: #smallOk);
		whenActivatedDo: [ UIManager default defer: [ self inform: 'Activated' ] ];
		whenDeactivatedDo: [ UIManager default defer: [ self inform: 'Deactivated' ] ];
		openWithSpec! !

!SpToggleButtonPresenter class methodsFor: 'specs' stamp: ''!
adapterName
	
	^ #ToggleButtonAdapter! !

!SpToggleButtonPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Toggle Button'! !

!SpToggleButtonPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithAssociatedButtons

	^ SpToggleButtonExample new openWithSpec! !

!SpToggleMenuItemMorph methodsFor: 'private - drawing' stamp: ''!
itemShortcut

	"In Spec, this is always already normalised"
	^ (ToggleMenuItemShortcut owner: self keyText: '') 
		normalizedKeyText: self keyText;
		yourself! !

!SpTokenTreeFilter commentStamp: ''!
I am a filter for a token.

If a node item contains my token I accept it!
!SpTokenTreeFilter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	token := ''.! !

!SpTokenTreeFilter methodsFor: 'filtering' stamp: ''!
keepTreeNode: aNode

	^ aNode matchTokenFilter: self! !

!SpTokenTreeFilter methodsFor: 'accessing' stamp: ''!
token

	^ token! !

!SpTokenTreeFilter methodsFor: 'accessing' stamp: ''!
token: anObject
	
	token := anObject! !

!SpTokenTreeFilter class methodsFor: 'instance creation' stamp: ''!
token: token

	^ self new
		token: token;
		yourself! !

!SpToolCommand commentStamp: ''!
I'm a base command to be used on spec 2 presenters. 
My children will define actions that can be executed as part of the Pharo System. 
!
!SpToolCommand methodsFor: 'accessing' stamp: ''!
transform

	^ transform! !

!SpToolCommand methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	transform := [ :aContext | aContext ]! !

!SpToolCommand methodsFor: 'converting' stamp: ''!
asSpecCommand
	| command |
	
	command := super asSpecCommand.
	self shortcutKey ifNotNil: [ :key | command shortcutKey: key ].
	self defaultIconName
		ifNotNil: [ :iconName | command iconName: iconName ].
	
	^ SpToolCurrentApplicationCommand decorate: command! !

!SpToolCommand methodsFor: 'accessing' stamp: ''!
transform: aBlock

	transform := aBlock! !

!SpToolCommand methodsFor: 'accessing' stamp: ''!
target

	^ self transform value: self context! !

!SpToolCommand methodsFor: 'accessing' stamp: ''!
shortcutKey

	^ self class defaultShortcutKey! !

!SpToolCommand methodsFor: 'accessing' stamp: ''!
defaultIconName
	^self class defaultIconName! !

!SpToolCommand class methodsFor: 'defaults' stamp: ''!
defaultShortcutKey

	^ nil! !

!SpToolCommand class methodsFor: 'documentation' stamp: ''!
documentContextRequiredSelectors

	^ #()! !

!SpToolCommand class methodsFor: 'documentation' stamp: ''!
addDocumentContextRequiredSelectors: aBuilder
	| requiredSelectors |

	requiredSelectors := self documentContextRequiredSelectors. 

	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Required Context API' ] withLevel: 2.	
	requiredSelectors 
		ifNotEmpty: [ 
			aBuilder text: 'To work properly, the context passed to this command has to implement the following vocabulary (See `CmCommand>>#context:`).'.
			aBuilder newLine.
			aBuilder unorderedListDuring: [  
				(requiredSelectors sorted) do: [ :each |
					aBuilder item: [
						aBuilder monospace: each ] ] ] ]
		ifEmpty: [ 
			aBuilder text: '(No required API is defined)' ]! !

!SpToolCommand class methodsFor: 'defaults' stamp: ''!
defaultIconName
	^nil! !

!SpToolCommand class methodsFor: '*Spec2-Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	super buildMicroDownUsing: aBuilder withComment: aString.
	self addDocumentContextRequiredSelectors: aBuilder! !

!SpToolCommand class methodsFor: 'default' stamp: ''!
shortName
	"For menus some commands can implement this helper to provide shorter names.
	Example: default name = 'Browse Command', short name = 'command'.
	It is intended to be accessed through a menu 'browse' then  'command' instead of directly 'browse command'"

	^ self defaultName! !

!SpToolCurrentApplication commentStamp: ''!
A dynamic variable to keep current executing application while executing a tool command. 
It helps to transmit the ongoing application (taken from the tool command context) to deeper in the system navigation.!
!SpToolCurrentApplicationCommand commentStamp: ''!
A decorator to wrap command on current application dynamic variable.!
!SpToolCurrentApplicationCommand methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage

	^ aMessage sendTo: self decoratedCommand! !

!SpToolCurrentApplicationCommand methodsFor: 'executing' stamp: ''!
execute

	SpToolCurrentApplication 
		value: self context application
		during: [ self decoratedCommand execute ]! !

!SpToolbarAdapterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpToolbarPresenter ! !

!SpToolbarAdapterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance
	presenter 
! !

!SpToolbarAdapterTest methodsFor: 'tests' stamp: ''!
testAddLabelledButtonAddTheButton
	presenter addItem: (SpToolbarButtonPresenter new
				label: 'a label';
				iconNamed: #abstract;
				action: [];
				yourself).
				
	self assert: (self adapter hasButtonWithLabel: 'a label').
	self assert: (self adapter numberOfItems) equals: 1! !

!SpToolbarButtonMorph commentStamp: ''!
A button morph typically used on a toolbar. The button can have a badge.!
!SpToolbarButtonMorph methodsFor: 'style' stamp: ''!
mouseOverBorderStyle

	^ self normalBorderStyle! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
badgeFont
	^ badgeFont ifNil: [ badgeFont := self newBadgeFont ]! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
drawOn: aCanvas
	super drawOn: aCanvas.
	self hasBadge
		ifTrue: [ self drawBadgeOn: aCanvas ]! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
badge
	badgeSelector ifNil: [ ^ nil ].
	^ self model perform: badgeSelector! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
newBadgeFont
	| baseBadgeFont |
	baseBadgeFont := StandardFonts codeFont.
 	^ (LogicalFont 
		familyName: baseBadgeFont familyName 
		pointSize: baseBadgeFont pointSize - 3)
			weightValue: 700! !

!SpToolbarButtonMorph methodsFor: 'style' stamp: ''!
normalBorderStyle

	^ BorderStyle width: 0 color: Color transparent! !

!SpToolbarButtonMorph methodsFor: 'style' stamp: ''!
pressedBorderStyle
	"Return the pressed borderStyle of the receiver."

	^ self normalBorderStyle! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
drawBadgeOn: aCanvas
	| badgeString badgeBounds textBounds textWidth textHeight width |
	
	badgeString := self badge asString.
	textWidth := self badgeFont widthOfString: badgeString.
	textHeight := self badgeFont height.
	width := 14 max: textWidth + 2. 
	badgeBounds := ((bounds right - width - 2)@(bounds top + 2) extent: width@14).
	aCanvas 
		fillOval: badgeBounds
		fillStyle: self badgeColor.
		
	textBounds := 
		(badgeBounds center - ((textWidth@textHeight) / 2.0)) + (1@0) 
		extent: textWidth@textHeight. 
	aCanvas 
		drawString: badgeString
		in: textBounds
		font: self badgeFont 
		color: self badgeTextColor! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
getIconSelector

	^ getIconSelector! !

!SpToolbarButtonMorph methodsFor: 'configuring' stamp: ''!
configureWith: displayModel item: itemPresenter
	displayModel configureButton: self item: itemPresenter! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
badgeTextColor
	^ self theme badgeTextColor! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
getIconSelector: aSelector

	getIconSelector := aSelector.
	self update: getIconSelector! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
badgeSelector: aSymbol
	badgeSelector := aSymbol! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
getLabelSelector

	^ getLabelSelector! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
hasBadge
	^ self badge notNil! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
getLabelSelector: aSelector

	getLabelSelector := aSelector.
	self update: getLabelSelector! !

!SpToolbarButtonMorph methodsFor: 'accessing' stamp: ''!
badgeColor
	^ self theme badgeColor! !

!SpToolbarButtonMorph methodsFor: 'style' stamp: ''!
normalFillStyle

	^ Color transparent! !

!SpToolbarButtonPresenter commentStamp: ''!
A button to be shown in a `SpToolbarPresenter`.
A `SpToolbarButtonPresenter` can show a badge.!
!SpToolbarButtonPresenter methodsFor: 'api' stamp: ''!
action: aBlock
	"Set the block performed when the button is clicked. 
	 `aBlock` receives zero arguments."

	action := aBlock! !

!SpToolbarButtonPresenter methodsFor: 'api' stamp: ''!
badge
	"Answer the badge that will be shown with the button."

	^ badge! !

!SpToolbarButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.! !

!SpToolbarButtonPresenter methodsFor: 'api' stamp: ''!
label: aString
	"Set the label to be shown by the button."

	label := aString! !

!SpToolbarButtonPresenter methodsFor: 'api' stamp: ''!
action
	"Answer the block performed when the button is clicked."

	^ action! !

!SpToolbarButtonPresenter methodsFor: 'simulating' stamp: ''!
click
	
	self action cull: self! !

!SpToolbarButtonPresenter methodsFor: 'execution' stamp: ''!
execute

	self withAdapterDo: [ :anAdapter | anAdapter execute ]! !

!SpToolbarButtonPresenter methodsFor: 'api - events' stamp: ''!
whenIconChangedDo: aBlock 
	"Inform when icon property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #icon whenChangedDo: aBlock ! !

!SpToolbarButtonPresenter methodsFor: 'api' stamp: ''!
icon
	"Answer the icon (an instance of `Form`) defined for this button (it can be nil)"

	^ icon! !

!SpToolbarButtonPresenter methodsFor: '*Iceberg-TipUI' stamp: ''!
hasBadge
	^ badge isNotNil! !

!SpToolbarButtonPresenter methodsFor: 'api' stamp: ''!
badge: aString
	"Set the badge to be shown with the button.
	 A badge is an extra piece of information that can be added to the button. Typically, this 
	 is used to show some status (for example, number of elements that will be touched if 
	 the button is pressed)"
	
	badge := aString! !

!SpToolbarButtonPresenter methodsFor: 'api' stamp: ''!
icon: anObject
	icon := anObject! !

!SpToolbarButtonPresenter methodsFor: 'api' stamp: ''!
label
	"Answer the label to be shown by the button"

	^ label! !

!SpToolbarButtonPresenter methodsFor: 'api - events' stamp: ''!
whenLabelChangedDo: aBlock 
	"Inform when label property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #label whenChangedDo: aBlock ! !

!SpToolbarButtonPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newToolbarButton! !

!SpToolbarButtonPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ToolbarButtonAdapter! !

!SpToolbarDisplayMode commentStamp: ''!
A base for different display modes for a toolbar!
!SpToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
width

	^ self extent x! !

!SpToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
extent
	^ self subclassResponsibility! !

!SpToolbarDisplayMode methodsFor: 'configuring' stamp: ''!
configureButton: aButton item: aToolbarItem
	self subclassResponsibility! !

!SpToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
height

	^ self extent y! !

!SpToolbarDisplayMode methodsFor: 'configuring' stamp: ''!
configureMorph: aMorph item: itemPresenter
	aMorph configureWith: self item: itemPresenter! !

!SpToolbarDisplayMode methodsFor: 'accessing' stamp: ''!
styleName 

	^ self subclassResponsibility! !

!SpToolbarDisplayMode methodsFor: 'configuring' stamp: ''!
configureDropList: aSpDropListMorph item: aSpDropListPresenter 
	self flag: 'TODO: maybe customize the drop list to have a better look''n feel'.! !

!SpToolbarDisplayMode class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use #uniqueInstance'! !

!SpToolbarDisplayMode class methodsFor: 'accessing' stamp: ''!
modeIcon
	^ SpIconToolbarDisplayMode uniqueInstance! !

!SpToolbarDisplayMode class methodsFor: 'accessing' stamp: ''!
modeIconAndLabel
	^ SpIconAndLabelToolbarDisplayMode uniqueInstance! !

!SpToolbarDisplayMode class methodsFor: 'instance creation' stamp: ''!
uniqueInstance

	self = SpToolbarDisplayMode 
		ifTrue: [ self error: 'I''m abstract. Use one of my children' ].
	^ uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! !

!SpToolbarDisplayMode class methodsFor: 'accessing' stamp: ''!
default
	^ self modeIconAndLabel! !

!SpToolbarDisplayMode class methodsFor: 'accessing' stamp: ''!
all

	^ { 
	self modeIcon.
	self modeIconAndLabel.
	self modeLabel.
	 }! !

!SpToolbarDisplayMode class methodsFor: 'accessing' stamp: ''!
modeLabel
	^ SpLabelToolbarDisplayMode uniqueInstance! !

!SpToolbarItemLeftPosition commentStamp: ''!
This class has a single instance representing a left item position.

Do not use the class directly, instead use:

	ITItemPosition left!
!SpToolbarItemLeftPosition methodsFor: 'accessing' stamp: ''!
addItem: anObject into: aToolbar
	aToolbar addItemLeft: anObject! !

!SpToolbarItemPosition commentStamp: ''!
Abstract superclass for item positioning. Each subclass should only have one instance.

The default item positioning is left.

  	ITItemPosition default
	ITItemPosition right
	ITItemPosition left!
!SpToolbarItemPosition methodsFor: 'accessing' stamp: ''!
addItem: anObject into: aToolbar
	self subclassResponsibility! !

!SpToolbarItemPosition class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'Use uniqueInstance'! !

!SpToolbarItemPosition class methodsFor: 'accessing' stamp: ''!
right
	^ SpToolbarItemRightPosition uniqueInstance
	! !

!SpToolbarItemPosition class methodsFor: 'accessing' stamp: ''!
left
	^ SpToolbarItemLeftPosition uniqueInstance
	! !

!SpToolbarItemPosition class methodsFor: 'instance creation' stamp: ''!
uniqueInstance

	^ uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! !

!SpToolbarItemPosition class methodsFor: 'accessing' stamp: ''!
default
	^ self left	! !

!SpToolbarItemRightPosition commentStamp: ''!
This class has a single instance representing a right item position.

Do not use the class directly, instead use:

	ITItemPosition right!
!SpToolbarItemRightPosition methodsFor: 'accessing' stamp: ''!
addItem: anObject into: aToolbar
	aToolbar addItemRight: anObject! !

!SpToolbarMenuButtonPresenter commentStamp: ''!
A presenter to create a menu button (a button who exposes a menu instead having an action) in a `SpToolbarPresenter`.!
!SpToolbarMenuButtonPresenter methodsFor: 'api' stamp: ''!
menu: aMenuOrBlock
	"Set the menu associated to this menu button. 
	 It can also be a block (or valuable) which will answer an instance of `SpMenuPresenter`
	 when evaluated. "

	menu := aMenuOrBlock! !

!SpToolbarMenuButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self addStyle: 'button'! !

!SpToolbarMenuButtonPresenter methodsFor: 'api' stamp: ''!
menu
	"Answer the menu associated to this menu button. 
	 It can also be a block (or valuable) which will answer an instance of `SpMenuPresenter`
	 when evaluated. "

	^ menu! !

!SpToolbarMenuButtonPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newToolbarMenuButton! !

!SpToolbarMenuButtonPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ToolbarMenuButtonAdapter! !

!SpToolbarMorph commentStamp: ''!
I'm a toolbar morph.
I can display toolbar items in left side or right side panels. 
!
!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
color: aColor
	color := aColor! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
addItemRight: aMorph

	self hasRightPanel
		ifFalse: [ self addMorphBack: rightPanel ]. 

	rightPanel addMorphBack: (aMorph
		vResizing: #spaceFill;
		yourself).
	rightPanel width: (rightPanel submorphs sum: #width)! !

!SpToolbarMorph methodsFor: 'private' stamp: ''!
leftPanel
	^ leftPanel! !

!SpToolbarMorph methodsFor: 'private' stamp: ''!
rightPanel
	^ rightPanel! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
addItem: aToolbarItem
	
	self addItem: aToolbarItem position: SpToolbarItemPosition left! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
addItem: aToolbarItem position: aPosition

	aPosition addItem: aToolbarItem into: self.
	self computeFullBounds.
	self minWidth: self calculateWidth.
	self width: self minWidth.
	self refresh! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
addItemLeft: aMorph

	leftPanel addMorphBack: (aMorph
		vResizing: #spaceFill;
		yourself)! !

!SpToolbarMorph methodsFor: 'private' stamp: ''!
calculateWidth

	^ (leftPanel submorphs sum: #width) 
		+ (self hasRightPanel ifTrue: [ rightPanel submorphs sum: #width ] ifFalse: [ 0 ])! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
displayMode
	^ displayMode ifNil: [ displayMode := SpToolbarDisplayMode default ]! !

!SpToolbarMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	self
		changeTableLayout;
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		vResizing: #rigid;
		wrapCentering: #center; 
		color: self defaultColor;
		extent: 0@0.
	
	self initializePanels! !

!SpToolbarMorph methodsFor: 'initialization' stamp: ''!
initializePanels

	leftPanel := self newPanelMorph.
	rightPanel := self newPanelMorph
		listDirection: #rightToLeft;
		hResizing: #spaceFill.

	self addMorphBack: leftPanel! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
refresh

	self flag: #TODO. "Maybe remove?"! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
toolbarItemFont
	^ toolbarItemFont ifNil: [ toolbarItemFont := self newToolbarItemFont ]! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
toolbarItemSize

	^ self displayMode height! !

!SpToolbarMorph methodsFor: 'updating' stamp: ''!
clearItems
	
	leftPanel removeAllMorphs.
	rightPanel removeAllMorphs.! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
toolbarItemFont: anObject
	toolbarItemFont := anObject! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
addItemsFromContext: aContext
	
	self flag: #TODO.
	"| menu |
	
	menu := CmdMenu activatedBy: ITToolbarActivation.
	menu buildInContext: aContext.
	menu buildToolbarOn: self"
! !

!SpToolbarMorph methodsFor: 'private' stamp: ''!
rightPanel: anObject
	rightPanel := anObject! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
defaultColor
	^ Color transparent! !

!SpToolbarMorph methodsFor: 'accessing' stamp: ''!
displayMode: anObject
	displayMode := anObject! !

!SpToolbarMorph methodsFor: 'private' stamp: ''!
hasRightPanel

	^ self submorphs includes: rightPanel! !

!SpToolbarMorph methodsFor: 'private - factory' stamp: ''!
newPanelMorph

	^ Morph new
		changeTableLayout;
		listDirection: #leftToRight;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		cellInset: self class defaultItemSeparation@0;
		extent: 0@0;
		color: Color transparent;
		yourself! !

!SpToolbarMorph methodsFor: 'private' stamp: ''!
leftPanel: anObject
	leftPanel := anObject! !

!SpToolbarMorph methodsFor: 'private - factory' stamp: ''!
newToolbarItemFont
	| buttonFont |

	buttonFont := self theme buttonFont.
	^ LogicalFont 
		familyName: buttonFont familyName 
		pointSize: buttonFont pointSize - 3! !

!SpToolbarMorph class methodsFor: 'accessing' stamp: ''!
defaultItemSize

	^ 50! !

!SpToolbarMorph class methodsFor: 'accessing' stamp: ''!
statusBarHeight
	
	^ 25! !

!SpToolbarMorph class methodsFor: 'accessing' stamp: ''!
defaultItemSeparation

	^ 0! !

!SpToolbarMorph class methodsFor: 'accessing' stamp: ''!
defaultHeight
	
	^ self defaultMode height! !

!SpToolbarMorph class methodsFor: 'accessing' stamp: ''!
defaultMode

	^ SpToolbarDisplayMode default! !

!SpToolbarPopoverButtonPresenter commentStamp: ''!
A presenter to create a popover button (a button who exposes a popover instead having an action) in a `SpToolbarPresenter`.!
!SpToolbarPopoverButtonPresenter methodsFor: 'api' stamp: ''!
content: aPresenterOrBlock
	"Set the presenter associated to this popover button. 
	 It can also be a block (or valuable) which will answer an instance of `SpPresenter`
	 when evaluated. "

	content := aPresenterOrBlock! !

!SpToolbarPopoverButtonPresenter methodsFor: 'api' stamp: ''!
content
	"Answer the content presenter associated to this popover button. 
	 It can also be a block (or valuable) which will answer an instance of `SpPresenter`
	 when evaluated. "

	^ content! !

!SpToolbarPopoverButtonPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newToolbarPopoverButton! !

!SpToolbarPopoverButtonPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ToolbarPopoverButtonAdapter! !

!SpToolbarPresenter commentStamp: ''!
A presenter to display a toolbar.
!
!SpToolbarPresenter methodsFor: 'api' stamp: ''!
beText
	"Set the toolbar to display just the labels.
	 See also `SpToolbarPresenter>>#displayMode:`"

	self displayMode: SpToolbarDisplayMode modeLabel! !

!SpToolbarPresenter methodsFor: 'private' stamp: ''!
addItemRight: aToolbarItem 

	aToolbarItem owner: self.
	rightItems add: aToolbarItem.
	self notifyPropertyChanged: #rightItems.	! !

!SpToolbarPresenter methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ self items isEmpty! !

!SpToolbarPresenter methodsFor: 'api' stamp: ''!
add: aToolbarButtonPresenter 
	"Add a toolbar button to the toolbar."
	
	self addItem: aToolbarButtonPresenter! !

!SpToolbarPresenter methodsFor: 'api' stamp: ''!
addItem: aToolbarItem
	"Add a toolbar button to the toolbar.
	 This is a synonym of `SpToolbarPresenter>>#add:`"
	
	self addItem: aToolbarItem position: SpToolbarItemPosition left! !

!SpToolbarPresenter methodsFor: 'private' stamp: ''!
leftItems
	^ leftItems! !

!SpToolbarPresenter methodsFor: 'testing' stamp: ''!
isDisplayModeIcons

	^ self displayMode = SpToolbarDisplayMode modeIcon! !

!SpToolbarPresenter methodsFor: 'testing' stamp: ''!
isDisplayModeText

	^ self displayMode = SpToolbarDisplayMode modeLabel! !

!SpToolbarPresenter methodsFor: 'private - traversing' stamp: ''!
traverseInFocusOrderDo: aBlock excluding: excludes

	self presentersInFocusOrder do: [ :each |
		each traverseInFocusOrderDo: aBlock excluding: excludes ]! !

!SpToolbarPresenter methodsFor: 'private' stamp: ''!
itemNamed: aString 
	
	^ self items detect: [ :e | e label = aString ]! !

!SpToolbarPresenter methodsFor: 'events' stamp: ''!
whenItemsChangeDo: aBlockClosure 
	
	self 
		property: #leftItems whenChangedDo: aBlockClosure;
		property: #rightItems whenChangedDo: aBlockClosure! !

!SpToolbarPresenter methodsFor: '*Spec2-Commander2' stamp: ''!
fillWith: aCommandGroup

	self removeAllItems.
	SpToolbarPresenterBuilder new 
		toolbarPresenter: self;
		visit: aCommandGroup! !

!SpToolbarPresenter methodsFor: 'private - traversing' stamp: ''!
presentersInFocusOrder

	^ self items! !

!SpToolbarPresenter methodsFor: 'private' stamp: ''!
addItemLeft: aToolbarItem 
	
	aToolbarItem owner: self.
	leftItems add: aToolbarItem.
	self notifyPropertyChanged: #leftItems.! !

!SpToolbarPresenter methodsFor: 'private' stamp: ''!
addItem: aToolbarItem position: aPosition
	
	aToolbarItem owner: self.
	aPosition addItem: aToolbarItem into: self! !

!SpToolbarPresenter methodsFor: 'api' stamp: ''!
displayMode
	"Answer the display mode of the toolbar (an instance of `SpToolbarDisplayMode`"

	^ displayMode! !

!SpToolbarPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self beBoth.
	
	leftItems := OrderedCollection new.
	rightItems := OrderedCollection new.	! !

!SpToolbarPresenter methodsFor: 'private - traversing' stamp: ''!
presenters

	^ self items! !

!SpToolbarPresenter methodsFor: 'api' stamp: ''!
beBoth
	"Set the toolbar to display both text and icons.
	 See also `SpToolbarPresenter>>#displayMode:`"

	self displayMode: SpToolbarDisplayMode modeIconAndLabel! !

!SpToolbarPresenter methodsFor: 'private' stamp: ''!
rightItems
	^ rightItems! !

!SpToolbarPresenter methodsFor: 'api' stamp: ''!
beIcons
	"Set the toolbar to display just the icons.
	See also `SpToolbarPresenter>>#displayMode:`"

	self displayMode: SpToolbarDisplayMode modeIcon! !

!SpToolbarPresenter methodsFor: 'api' stamp: ''!
removeAllItems
	"Remove all items in the toolbar"

	leftItems := OrderedCollection new.
	rightItems := OrderedCollection new! !

!SpToolbarPresenter methodsFor: 'testing' stamp: ''!
isDisplayModeBoth

	^ self displayMode = SpToolbarDisplayMode modeIconAndLabel! !

!SpToolbarPresenter methodsFor: 'testing' stamp: ''!
notEmpty

	^ self isEmpty not! !

!SpToolbarPresenter methodsFor: 'api' stamp: ''!
items
	"Answer all buttons in the toolbar"

	^ leftItems , rightItems! !

!SpToolbarPresenter methodsFor: 'api' stamp: ''!
displayMode: aDisplayMode
	"Set the display mode of this toolbar. 
	 `aDisplayMode` is an instance of `SpToolbarDisplayMode`"

	displayMode ifNotNil: [ 
		self removeStyle: displayMode styleName ].
	displayMode := aDisplayMode.
	self addStyle: displayMode styleName
! !

!SpToolbarPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newToolbar! !

!SpToolbarPresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	| loremIpsumWords menuButton |
	
	loremIpsumWords := String loremIpsum substrings.
	^ self new 
		beBoth;
		add: (SpToolbarButtonPresenter new 
			icon: (self iconNamed: #smallOk);
			label: 'Simple';
			action: [ UIManager default defer: [ self inform: 'Pressed' ] ];
			yourself);
		add: (SpToolbarButtonPresenter new 
			enabled: false;
			icon: (self iconNamed: #smallOk);
			label: 'Disabled';
			action: [ UIManager default defer: [ self inform: 'Pressed' ] ];
			yourself);
		add: (SpToolbarToggleButtonPresenter new
			icon: (self iconNamed: #smallOk);
			label: 'Toggle';
			action: [ :value | UIManager default defer: [ self inform: value asString ] ];
			yourself);
		add: ((menuButton := SpToolbarMenuButtonPresenter new)
			label: 'Menu';
			icon: (self iconNamed: #smallOk);
			action: [ UIManager default defer: [ self inform: menuButton label ] ];
			menu: [ 
				SpMenuPresenter new
					addGroup: [ :group | 
						1 to: 10 do: [ :index |
							group addItem: [ :item | item 
								name: ('{1}: {2}' format: { index. loremIpsumWords atRandom });
								action: [ menuButton label: item name ] ] ] ];
					yourself ];
			yourself);
		openWithSpec! !

!SpToolbarPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ToolbarAdapter! !

!SpToolbarPresenterBuilder commentStamp: ''!
I build a ToolBarPresenter from a group of commands.

To do that, I visit recursively groups of command breadth first and simple add each command encountered to the tool bar.!
!SpToolbarPresenterBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self toolbarPresenter: SpToolbarPresenter new.! !

!SpToolbarPresenterBuilder methodsFor: 'visiting' stamp: ''!
visitCommandGroup: aCmCommandsGroup
	
	aCmCommandsGroup isToolbarPopoverButton 
		ifTrue: [ self addPopoverButtonFrom: aCmCommandsGroup ]
		ifFalse: [ super visitCommandGroup: aCmCommandsGroup ]! !

!SpToolbarPresenterBuilder methodsFor: 'private' stamp: ''!
addPopoverButtonFrom: aCommandsGroup
	| button |

	self toolbarPresenter addItem: ((button := self toolbarPresenter newToolbarPopoverButton) 
		label: aCommandsGroup name;
		icon: aCommandsGroup icon;
		content: [ 
			self class new
				visit: aCommandsGroup copy beToolbarGroup;
				toolbarPresenter ];
		yourself)	! !

!SpToolbarPresenterBuilder methodsFor: 'accessing' stamp: ''!
toolbarPresenter: anObject
	toolbarPresenter := anObject! !

!SpToolbarPresenterBuilder methodsFor: 'accessing' stamp: ''!
toolbarPresenter
	^ toolbarPresenter! !

!SpToolbarPresenterBuilder methodsFor: 'visiting' stamp: ''!
visitCommand: aCmCommandEntry
	aCmCommandEntry positionStrategy
		addButton: aCmCommandEntry buildPresenter
		toToolbar: self toolbarPresenter! !

!SpToolbarPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpToolbarPresenter! !

!SpToolbarPresenterTest methodsFor: 'tests' stamp: ''!
testAddItemPosition
	| itemLeft itemRight |

	self assert: presenter items isEmpty.
	presenter addItem: (itemLeft := self newToolbarItem) position: SpToolbarItemPosition left.
	presenter addItem: (itemRight := self newToolbarItem) position: SpToolbarItemPosition right.

	self assertCollection: presenter leftItems hasSameElements: { itemLeft }.
	self assertCollection: presenter rightItems hasSameElements: { itemRight }! !

!SpToolbarPresenterTest methodsFor: 'private' stamp: ''!
newToolbarItem
	
	^ SpToolbarButtonPresenter new! !

!SpToolbarPresenterTest methodsFor: 'tests' stamp: ''!
testAddItem

	presenter addItem: SpToolbarButtonPresenter new.
	self assert: presenter items size equals: 1! !

!SpToolbarPresenterTest methodsFor: 'tests' stamp: ''!
testDisplayMode

	presenter beBoth.
	self assert: presenter isDisplayModeBoth.
	presenter beIcons.
	self assert: presenter isDisplayModeIcons.	
	presenter beText.
	self assert: presenter isDisplayModeText
	! !

!SpToolbarPresenterTest methodsFor: 'tests' stamp: ''!
testItems 
	| item |

	self assert: presenter items isEmpty.
	presenter addItem: (item := self newToolbarItem).

	self assertCollection: presenter leftItems hasSameElements: { item }! !

!SpToolbarPresenterTest methodsFor: 'tests' stamp: ''!
testIsEmpty 

	self assert: presenter isEmpty.
	presenter addItem: SpToolbarButtonPresenter new.
	self deny: presenter isEmpty! !

!SpToolbarToggleButtonExample commentStamp: ''!
A demo to show how to use associated toolbar toggle buttons with Spec.

self example!
!SpToolbarToggleButtonExample methodsFor: 'updating' stamp: ''!
updateLabel
	label
		label:
			(String
				streamContents: [ :s | 
					{button1 . button2 . button3}
						do: [ :button | 
							s
								<< button label;
								<< ' : ';
								<< (button state ifTrue: [ 'V' ] ifFalse: [ 'X' ]) ]
						separatedBy: [ s << ' - ' ] ])! !

!SpToolbarToggleButtonExample methodsFor: 'initialization' stamp: ''!
initializePresenters

	toolbar := self newToolbar.

	button1 := self newToolbarToggleButton.
	button2 := self newToolbarToggleButton.
	button3 := self newToolbarToggleButton.
	
	toolbar add: button1.
	toolbar add: button2.
	toolbar add: button3.

	label := self newLabel.
	button1 associatedToggleButtons: { button2. button3 }.

	button1 label: 'Button 1'; icon: (self application iconNamed: #smallOk).
	button2 label: 'Button 2'; icon: (self application iconNamed: #smallOk).
	button3 label: 'Button 3'; icon: (self application iconNamed: #smallOk).

	self updateLabel! !

!SpToolbarToggleButtonExample methodsFor: 'initialization' stamp: ''!
connectPresenters

	button1 whenActivatedDo: [ self updateLabel ].
	button1 whenDeactivatedDo: [ self updateLabel ].
	button2 whenChangedDo: [ self updateLabel ].
	button3 whenChangedDo: [ self updateLabel ]! !

!SpToolbarToggleButtonExample class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: (SpBoxLayout newTopToBottom
			vAlignStart;
			add: #toolbar expand: false;
			yourself);
		add: #label expand: false;
		yourself! !

!SpToolbarToggleButtonExample class methodsFor: 'examples' stamp: ''!
example

	^ self new openWithSpec! !

!SpToolbarToggleButtonExample class methodsFor: 'specs' stamp: ''!
title

	^ 'Toolbar Toggle Button Example'! !

!SpToolbarToggleButtonMorph methodsFor: 'style' stamp: ''!
mouseOverBorderStyle
	^ BorderStyle simple
		width: 0;
		baseColor: Color transparent! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
badgeFont
	^ badgeFont ifNil: [ badgeFont := self newBadgeFont ]! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
drawOn: aCanvas
	super drawOn: aCanvas.
	self hasBadge ifTrue: [
		self drawBadgeOn: aCanvas ]! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
badge
	badgeSelector ifNil: [ ^ nil ].
	^ self model perform: badgeSelector! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
newBadgeFont
	| baseBadgeFont |
	baseBadgeFont := StandardFonts codeFont.
 	^ (LogicalFont 
		familyName: baseBadgeFont familyName 
		pointSize: baseBadgeFont pointSize - 3)
			weightValue: 700! !

!SpToolbarToggleButtonMorph methodsFor: 'style' stamp: ''!
normalBorderStyle
	^ BorderStyle simple
		width: 0;
		baseColor: Color transparent! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
drawBadgeOn: aCanvas
	| badgeString badgeBounds textBounds textWidth textHeight width |
	
	badgeString := self badge asString.
	textWidth := self badgeFont widthOfString: badgeString.
	textHeight := self badgeFont height.
	width := 14 max: textWidth + 2. 
	badgeBounds := ((bounds right - width - 2)@(bounds top + 2) extent: width@14).
	aCanvas 
		fillOval: badgeBounds
		fillStyle: self badgeColor.
		
	textBounds := 
		(badgeBounds center - ((textWidth@textHeight) / 2.0)) + (1@0) 
		extent: textWidth@textHeight. 
	aCanvas 
		drawString: badgeString
		in: textBounds
		font: self badgeFont 
		color: self badgeTextColor! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
getIconSelector

	^ getIconSelector! !

!SpToolbarToggleButtonMorph methodsFor: 'configuring' stamp: ''!
configureWith: displayModel item: itemPresenter
	
	displayModel configureButton: self item: itemPresenter! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
badgeTextColor
	^ self theme badgeTextColor! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
getIconSelector: aSelector

	getIconSelector := aSelector.
	self update: getIconSelector! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
badgeSelector: aSymbol
	badgeSelector := aSymbol! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
getLabelSelector

	^ getLabelSelector! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
drawSubmorphsOn: aCanvas
	
	super drawSubmorphsOn: aCanvas! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
getLabelSelector: aSelector

	getLabelSelector := aSelector.
	self update: getLabelSelector! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
hasBadge
	^ self badge notNil! !

!SpToolbarToggleButtonMorph methodsFor: 'accessing' stamp: ''!
badgeColor
	^ self theme badgeColor! !

!SpToolbarToggleButtonMorph methodsFor: 'style' stamp: ''!
normalFillStyle
	^ Color transparent! !

!SpToolbarToggleButtonMorphTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpToolbarToggleButtonPresenter ! !

!SpToolbarToggleButtonMorphTest methodsFor: 'running' stamp: ''!
defaultWaitDuration
	^ 500 milliSecond! !

!SpToolbarToggleButtonMorphTest methodsFor: 'utilities' stamp: ''!
waitUntilUIRedrawed
	"I wait until the UI has been redrawn. 
	I take care of selecting how to do it. 
	If I am in the CI I should defer a semaphore signal. 
	If I am running in the UI process I can directly execute a doOneCycle on the World.
	If I am in the CI the tests and the UI run in different process. So I should not do a #doOneCycle.
	If I do it, I am in a race condition!!"

	self isRunningInUIProcess
		ifTrue: [
			MorphicRenderLoop new doOneCycle.
			^ self ].

	self currentWorld defer: [ uiWaitingSemaphore ifNotNil: #signal ].
	uiWaitingSemaphore wait: self defaultWaitDuration! !

!SpToolbarToggleButtonMorphTest methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self initializeSemaphore! !

!SpToolbarToggleButtonMorphTest methodsFor: 'testing' stamp: ''!
isRunningInUIProcess
	^ UIManager default uiProcess == Processor activeProcess! !

!SpToolbarToggleButtonMorphTest methodsFor: 'initialization' stamp: ''!
initializeSemaphore
	uiWaitingSemaphore := Semaphore new! !

!SpToolbarToggleButtonMorphTest methodsFor: 'tests' stamp: ''!
testClickDeactivatedCheckboxActivatesIt
	| state |

	self flag: #FIXME. "This test is not passing on spec-all CI (even if it passes in 
	local and in spec-basic CI)"
	self skipOnPharoCITestingEnvironment.

	state := presenter isSelected.

	self openInstance.
	self waitUntilUIRedrawed.
	presenter adapter widget simulateClick.
	self waitUntilUIRedrawed.

	self assert: presenter isSelected equals: state not! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpToolbarToggleButtonMorphTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpToolbarToggleButtonMorphTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpToolbarToggleButtonPresenter commentStamp: ''!
A presenter to display a toggle button in a `SpToolbarPresenter`.
A toggle button is a button that can be activated (toggled) or deactivated (untoggled).
!
!SpToolbarToggleButtonPresenter methodsFor: 'api - events' stamp: ''!
whenActivatedDo: aBlock
	"Inform when the button has been selected. 
	 `aBlock` receives zero arguments."

	self whenChangedDo: [ :newSelectedValue | 
		newSelectedValue ifTrue: [ aBlock value ] ]! !

!SpToolbarToggleButtonPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	selected := false! !

!SpToolbarToggleButtonPresenter methodsFor: 'api' stamp: ''!
toggle
	"Toggles the status of the button"
	
	self setSelection: selected not! !

!SpToolbarToggleButtonPresenter methodsFor: 'api' stamp: ''!
associatedToggleButtons: aCollection 
	"Set the list of toggle buttons associated with this one.
	 By using this, you will be grouping together this toggle button along with the ones contained 
	 in `aCollection`.
	 You should NOT send this message to all associated toggle buttons, the first of them is enough."
	| allElements |
	
	"pass group to all members"	
	allElements := { self }, aCollection.
	allElements do: [ :each | 
		each basicAssociatedToggleButtons: allElements ].
	
	"self state: true."
	aCollection do: [ :each | each state: false ]! !

!SpToolbarToggleButtonPresenter methodsFor: 'api' stamp: ''!
beUnselected
	"Set the status of the button to 'unselected' (untoggled)"

	self setSelection: false! !

!SpToolbarToggleButtonPresenter methodsFor: 'api' stamp: ''!
selected: aBoolean

	self 
		deprecated: 'Use #state: instead.' 
		transformWith: '`@receiver selected: `@arg' -> '`@receiver state: `@arg'.  
	self setSelection: aBoolean! !

!SpToolbarToggleButtonPresenter methodsFor: 'api' stamp: ''!
state: aBoolean

	self setSelection: aBoolean! !

!SpToolbarToggleButtonPresenter methodsFor: 'api - events' stamp: ''!
whenToggledDo: aBlock 
	"Inform when the button has been toggles. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #selected whenChangedDo: aBlock ! !

!SpToolbarToggleButtonPresenter methodsFor: 'api - events' stamp: ''!
whenUnselectedDo: aBlock
	"Inform when the button has been unselected. 
	 `aBlock` receives zero arguments."

	self 
		deprecated: 'Use #whenDeactivatedDo: instead.' 
		transformWith: '`@receiver whenUnselectedDo: `@arg' -> '`@receiver whenDeactivatedDo: `@arg'.  

	self whenChangedDo: [ :newSelectedValue | 
		newSelectedValue ifFalse: [ aBlock value ] ]! !

!SpToolbarToggleButtonPresenter methodsFor: 'testing' stamp: ''!
isSelected

	^ self state! !

!SpToolbarToggleButtonPresenter methodsFor: 'api' stamp: ''!
associatedToggleButtons

	^ associatedToggleButtons ifNil: [ #() ]! !

!SpToolbarToggleButtonPresenter methodsFor: 'api' stamp: ''!
state

	^ selected! !

!SpToolbarToggleButtonPresenter methodsFor: 'private' stamp: ''!
whenChangedDo: aBlock
	"Only execute aBlock if old value is different from new value"

	self
		property: #selected
		whenChangedDo: [ :newSelectedValue :oldSelectedValue | 
			newSelectedValue = oldSelectedValue
				ifFalse: [ aBlock cull: newSelectedValue cull: oldSelectedValue ] ]! !

!SpToolbarToggleButtonPresenter methodsFor: 'execution' stamp: ''!
execute: state

	self setSelection: state.
	self action ifNil: [ ^ self ].
	self action 
		cull: state 
		cull: self! !

!SpToolbarToggleButtonPresenter methodsFor: 'api - events' stamp: ''!
whenDeactivatedDo: aBlock
	"Inform when the button has been selected. 
	 `aBlock` receives zero arguments."

	self whenChangedDo: [ :newSelectedValue | 
		newSelectedValue ifTrue: [ aBlock value ] ]! !

!SpToolbarToggleButtonPresenter methodsFor: 'private' stamp: ''!
setSelection: aBoolean

	selected := aBoolean.
	self changed: #isSelected! !

!SpToolbarToggleButtonPresenter methodsFor: 'private' stamp: ''!
basicAssociatedToggleButtons: aCollection 
	
	associatedToggleButtons := aCollection copyWithout: self! !

!SpToolbarToggleButtonPresenter methodsFor: 'api - events' stamp: ''!
whenSelectedDo: aBlock
	"Inform when the button has been selected. 
	 `aBlock` receives zero arguments."

	self 
		deprecated: 'Use #whenActivatedDo: instead.' 
		transformWith: '`@receiver whenSelectedDo: `@arg' -> '`@receiver whenActivatedDo: `@arg'.  

	self whenChangedDo: [ :newSelectedValue | 
		newSelectedValue ifTrue: [ aBlock value ] ]! !

!SpToolbarToggleButtonPresenter methodsFor: 'api' stamp: ''!
beSelected
	"Set the status of the button to 'selected' (toggled)"
	
	self setSelection: true! !

!SpToolbarToggleButtonPresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newToolbarToggleButton! !

!SpToolbarToggleButtonPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #ToolbarToggleButtonAdapter! !

!SpToolbarToggleButtonPresenterTest commentStamp: ''!
A SpToolBarToggleButtonTest is a test class for testing the behavior of SpToolBarToggleButton!
!SpToolbarToggleButtonPresenterTest methodsFor: 'tests' stamp: ''!
testUnselectedBlockNotExecutedWhenAlreadyUnselectedAndUnselectedTriggered
	| toggleButton unselectedBlockExecuted |
	unselectedBlockExecuted := false.
	toggleButton := SpToolbarToggleButtonPresenter new.
	toggleButton beUnselected.
	toggleButton whenUnselectedDo: [ unselectedBlockExecuted := true ].
	
	toggleButton beUnselected.
		
	self deny: unselectedBlockExecuted! !

!SpToolbarToggleButtonPresenterTest methodsFor: 'tests' stamp: ''!
testSelectedBlockExecutedWhenBecomeSelected
	| toggleButton selectedBlockExecuted |
	selectedBlockExecuted := false.
	toggleButton := SpToolbarToggleButtonPresenter new.
	toggleButton whenSelectedDo: [ selectedBlockExecuted := true ].
	
	toggleButton beSelected.
		
	self assert: selectedBlockExecuted! !

!SpToolbarToggleButtonPresenterTest methodsFor: 'tests' stamp: ''!
testBecomeSelectedWhenToggledAndUnselected
	| toggleButton |
	toggleButton := SpToolbarToggleButtonPresenter new.
	toggleButton beSelected.
	self assert: toggleButton isSelected.
	
	toggleButton toggle.
	
	self deny: toggleButton isSelected.! !

!SpToolbarToggleButtonPresenterTest methodsFor: 'tests' stamp: ''!
testBecomeUnselectedWhenToggledAndSelected
	| toggleButton |
	toggleButton := SpToolbarToggleButtonPresenter new.
	self deny: toggleButton isSelected.
		
	toggleButton toggle.
	
	self assert: toggleButton isSelected.
! !

!SpToolbarToggleButtonPresenterTest methodsFor: 'tests' stamp: ''!
testUnselectedBlockExecutedWhenBecomeUnselected
	| toggleButton unselectedBlockExecuted |
	unselectedBlockExecuted := false.
	toggleButton := SpToolbarToggleButtonPresenter new.
	toggleButton beSelected.
	toggleButton whenUnselectedDo: [ unselectedBlockExecuted := true ].
	
	toggleButton beUnselected.
		
	self assert: unselectedBlockExecuted! !

!SpToolbarToggleButtonPresenterTest methodsFor: 'tests' stamp: ''!
testUnselectedBlockNotExecutedWhenBecomeSelected
	| toggleButton unselectedBlockExecuted |
	unselectedBlockExecuted := false.
	toggleButton := SpToolbarToggleButtonPresenter new.
	toggleButton beUnselected.
	toggleButton whenUnselectedDo: [ unselectedBlockExecuted := true ].
	
	toggleButton beSelected.
		
	self deny: unselectedBlockExecuted! !

!SpToolbarToggleButtonPresenterTest methodsFor: 'tests' stamp: ''!
testToggleBlockExecutedWhenToggled
	| toggleButton toggled |
	toggled := false.
	toggleButton := SpToolbarToggleButtonPresenter new.
	toggleButton whenToggledDo: [ toggled := true ].
	
	toggleButton toggle.
	
	self assert: toggled! !

!SpToolbarToggleButtonPresenterTest methodsFor: 'tests' stamp: ''!
testSelectedBlockNotExecutedWhenAlreadySelectedAndUnselectedTriggered
	| toggleButton selectedBlockExecuted |
	selectedBlockExecuted := false.
	toggleButton := SpToolbarToggleButtonPresenter new.
	toggleButton beSelected.
	toggleButton whenSelectedDo: [ selectedBlockExecuted := true ].
	
	toggleButton beSelected.
		
	self deny: selectedBlockExecuted! !

!SpToolbarToggleButtonPresenterTest methodsFor: 'tests' stamp: ''!
testSelectedBlockNotExecutedWhenBecomeUnselected
	| toggleButton selectedBlockExecuted |
	selectedBlockExecuted := false.
	toggleButton := SpToolbarToggleButtonPresenter new.
	toggleButton beSelected.
	toggleButton whenSelectedDo: [ selectedBlockExecuted := true ].

	toggleButton beUnselected.	
		
	self deny: selectedBlockExecuted! !

!SpTransferMorph commentStamp: ''!
I am a Spec specific subclass of TransferMorph used to initialize the trasnfer morph state correctly with the Spec constraints!
!SpTransferMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	dragHand := self activeHand! !

!SpTransferMorph methodsFor: 'accessing' stamp: ''!
shouldCopy

	^ self dragHand shiftPressed! !

!SpTransferMorph methodsFor: 'accessing' stamp: ''!
passenger: aBlock
	passenger := aBlock value! !

!SpTransferMorph methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!SpTransferMorph methodsFor: 'accessing' stamp: ''!
source: aBlock
	source := aBlock value! !

!SpTransferMorph methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!SpTransferPresenter commentStamp: ''!
I am a model representing a transfer during a drag and drop operation. I keep a pointer the source of the drag, and a pointer to what is dragged!
!SpTransferPresenter methodsFor: 'accessing' stamp: ''!
from: aModel
	source := aModel! !

!SpTransferPresenter methodsFor: 'accessing' stamp: ''!
source
	^ source! !

!SpTransferPresenter methodsFor: 'accessing' stamp: ''!
passenger
	^ passenger! !

!SpTransferPresenter methodsFor: 'accessing' stamp: ''!
transfer: anObject
	passenger := anObject! !

!SpTransferPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TransferAdapter! !

!SpTransmission commentStamp: ''!
!! What is a transmission?
Transmissions are a way to connect presenters, thinking on the "flow" of information more than the way it is displayed. For example, think on a master-detail (A->B) relationship, when you navigate the elements in master A, you want to see the detail B. This is tipically solved showing a list with master elements and a form with the detail of each master. 
In Spec, this will be declared more or less like this: 

[[[language=Smalltalk
layout := SpBoxLayout newHorizontal
	add: (list := self newList);
	add: (detail := self newText);
	yourself.	
]]]

But this does not says how ==list== and ==detail== are linked. 

The transmission sub-framework solves this in an elegant way: Each presenter defines ''output ports'' (ports to send information) and ''input ports'' (ports to receive information). Each presenter defines also a default input port and a default output port.

!!!! Transmitting from an output port to an input port (==#transmitTo:==)

A transmission connects a presenter's output port with a presenter's input port. 
See this example: 

[[[language=Smalltalk
list transmitTo: detail.
]]]

This will connect the ==list== presenter ""default output port"" with the ==detail== presenter ""default input port"". This line is equivallent (but a lot simpler) to this one:  

[[[language=Smalltalk
list defaultOutputPort transmitTo: detail defaultInputPort
]]]

Is important to remark that a transmission does not connects two components, it connect two ""component ports"". The distinction is important because there can be many ports!!  
Take for example *class:SpListPresenter*, it defines two output ports (selection and activation), this means it is possible to define also this transmission: 

[[[language=Smalltalk
list outputActivationPort transmitTo: detail defaultInputPort
]]]

!!!! Transforming a transmission (==#transmitTo:transform:==)
The object transmitted from a presenter output port can be inadequate for the input port. To solve this problem a transmission allow transformations.
This is as simple as using the ==#transform:== protocol: 

[[[language=Smalltalk
list 
	transmitTo: detail 
	transform: [ :aValue | aValue asString ].
]]]

[[[language=Smalltalk
list defaultOutputPort 
	transmitTo: detail defaultInputPort 
	transform: [ :aValue | aValue asString ].
]]]

!!!! Transmitting from an output port to an arbitrary input receiver (==#transmitDo:==, ==#transmitDo:transform:==)
It is possible that the user requires to listen an output port, but instead transmitting the value to another presenter, other operation is needed. 
There is the ==#transmitDo:== protocol to handle this situation: 

[[[language=Smalltalk
list transmitDo: [ :aValue | aValue crTrace ].
]]]

!!!! Acting after a transmission (==#postTransmission:==)
Sometimes after a transmission happens, the user needs to react to modify something given the new status achieved by the presenter (like, pre-selecting something).
The ==#postTransmission:== protocol allows you to handle that situation.

[[[language=Smalltalk
list 
	transmitTo: detail 
	postTransmission: [ :fromPresenter :toPresenter :value | 
		"something to do here"
		toPresenter enabled: value isEmptyOrNil not ].
]]]

See *method:SpTransmission#postTransmission:*!
!SpTransmission methodsFor: 'actions' stamp: ''!
from: aPresenter port: aSymbol to: anotherPresenter transform: aValuable
	self
		from: aPresenter
		port: aSymbol
		to: anotherPresenter
		transform: aValuable
		postTransmission: nil! !

!SpTransmission methodsFor: 'actions' stamp: ''!
from: aPresenter port: aSymbol to: anotherPresenter transform: aValuable postTransmission: anotherValuable

	self
		from: aPresenter port: aSymbol;
		to: anotherPresenter;
		transform: aValuable;
		postTransmission: anotherValuable;
		apply! !

!SpTransmission methodsFor: 'private' stamp: ''!
apply
	fromPort attachTransmission: self! !

!SpTransmission methodsFor: 'accessing' stamp: ''!
postTransmission
	^ postTransmission! !

!SpTransmission methodsFor: 'private' stamp: ''!
from: aPresenter
	self fromPort: aPresenter defaultOutputPort! !

!SpTransmission methodsFor: 'actions' stamp: ''!
from: aPresenter to: anotherPresenter transform: aValuable
	
	self
		from: aPresenter
		to: anotherPresenter
		transform: aValuable
		postTransmission: nil! !

!SpTransmission methodsFor: 'private' stamp: ''!
fromPort: aPort
	fromPort := aPort! !

!SpTransmission methodsFor: 'private' stamp: ''!
toPresenter
	^ self toPort presenter! !

!SpTransmission methodsFor: 'private' stamp: ''!
to: aPresenter

	self toPort: aPresenter defaultInputPort! !

!SpTransmission methodsFor: 'accessing' stamp: ''!
fromPort

	^ fromPort! !

!SpTransmission methodsFor: 'private' stamp: ''!
fromPresenter
	^ self fromPort presenter! !

!SpTransmission methodsFor: 'accessing' stamp: ''!
preTransmission
	^ preTransmission! !

!SpTransmission methodsFor: 'private' stamp: ''!
toPort: aPort
	toPort := aPort! !

!SpTransmission methodsFor: 'private' stamp: ''!
transformed: anObject 

	transformBlock ifNil: [ ^ anObject ].
	^ transformBlock value: anObject! !

!SpTransmission methodsFor: 'accessing' stamp: ''!
preTransmission: aValuable
	preTransmission := aValuable! !

!SpTransmission methodsFor: 'actions' stamp: ''!
do: aBlock
	"Will create a generic action block to handle transmission"
	
	self toPort: (SpActionPort newAction: aBlock)! !

!SpTransmission methodsFor: 'private' stamp: ''!
applyPreTransmissionWith: aTransmittedObject

	self preTransmission ifNil: [ ^ self ].
	self preTransmission 
		cull: self toPresenter 
		cull: self fromPresenter 
		cull: aTransmittedObject! !

!SpTransmission methodsFor: 'private' stamp: ''!
applyPostTransmissionWith: aTransmittedObject

	self postTransmission ifNil: [ ^ self ].
	self postTransmission 
		cull: self toPresenter 
		cull: self fromPresenter 
		cull: aTransmittedObject! !

!SpTransmission methodsFor: 'actions' stamp: ''!
from: aPresenter to: anotherPresenter
	
	self
		from: aPresenter
		to: anotherPresenter
		transform: nil! !

!SpTransmission methodsFor: 'script' stamp: ''!
transform: aBlock

	transformBlock := aBlock! !

!SpTransmission methodsFor: 'actions' stamp: ''!
from: aPresenter to: anotherPresenter transform: aValuable postTransmission: anotherValuable
	self
		from: aPresenter;
		to: anotherPresenter;
		transform: aValuable;
		postTransmission: anotherValuable;
		apply! !

!SpTransmission methodsFor: 'accessing' stamp: ''!
postTransmission: aValuable
	postTransmission := aValuable! !

!SpTransmission methodsFor: 'accessing' stamp: ''!
toPort

	^ toPort! !

!SpTransmissionExample methodsFor: 'initialization' stamp: ''!
classTemplateFor: aPackage
	
	aPackage ifNil: [ ^ '' ].

	^ 'Object subclass: #NameOfSubclass
	slots: {}
	classVariables: {}
	package: ''', aPackage name,''' ' 
	! !

!SpTransmissionExample methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter
		title: 'Transmission example browser';
		initialExtent: 800@600! !

!SpTransmissionExample methodsFor: 'initialization' stamp: ''!
initializePresenters

	packages := self newList display: #name.
	classes := self newList display: #name.
	protocols := self newList display: [ :aPair | aPair value name ].
	methods := self newList display: #selector.
	code := self newCode.

	packages
		transmitTo: classes
		transform: [ :aPackage | 
			aPackage 
				ifNotNil: [ aPackage definedClasses asArray ]
				ifNil: [ #() ] ].
	packages
		transmitTo: code
		transform: [ :aPackage | self classTemplateFor: aPackage ].
	
	classes
		transmitTo: protocols
		transform: [ :aClass | 
			aClass 
				ifNotNil: [ 
					aClass organization allProtocols
						collect: [ :each | aClass -> each ]
						as: OrderedCollection ]
				ifNil: [ #() ] ]
		postTransmission: [ :destination :origin | destination selectIndex: 1 ].
	classes 
		transmitTo: code 
		transform: [ :aClass | 
			aClass 
				ifNotNil: [ aClass definitionString ] 
				ifNil: [ '' ] ].
	
	protocols
		transmitTo: methods
		transform: [ :aPair | 
			aPair 
				ifNotNil:[ 
					aPair value methodSelectors
						collect: [ :each | aPair key >> each ]
						as: OrderedCollection ]
				ifNil: [ #() ] ].
	protocols
		transmitTo: code
		transform: [ :aPair | 
			aPair 
				ifNotNil: [ aPair key sourceCodeTemplate ]
				ifNil: [ '' ] ].

	methods 
		transmitTo: code 
		transform: [ :aMethod | 
			aMethod 
				ifNotNil: [ aMethod sourceCode ] 
				ifNil: [ '' ] ].

	packages items: RPackageOrganizer default packages! !

!SpTransmissionExample class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: (SpBoxLayout newLeftToRight 
			add: #packages;
			add: #classes;
			add: #protocols;
			add: #methods);
		add: #code;
		yourself! !

!SpTransmissionExample class methodsFor: 'showing' stamp: ''!
open 
	<script>
	
	^ self new openWithSpec! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTreePresenter! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectManyIndexesKeepsAllSelected
	
	presenter selectPath: #(1).
	presenter selectPath: #(2).
	self
		assert: self adapter selectedPaths
		equals: #((1) (2))! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	presenter
		beMultipleSelection;
		roots: #(10 20 30 'abc')! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexSetsSelectedIndexInWidget
	
	presenter selectPath: #(1).
	self assert: (self adapter selectedPaths includes: #(1))! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedPaths |
	
	presenter selection whenChangedDo: [ :selection | selectedPaths := selection ].
	self adapter selectPath: #(1).
	self assert: (selectedPaths includes: #(1))! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexOutsideRangeUnsetsSelectedIndexInWidget
	
	presenter selectPath: #(100).
	self assert: self adapter selectedPaths isEmpty! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testUnselectAllInWidgetRaisesSelectionIndexChangeEventOnce
	| counter |
	
	counter := 0.
	self adapter selectPath: #(1).
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #().
	self assert: counter equals: 1! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testShiftClicktAccumulatesSelection
	
	self openInstance.
	presenter adapter sendClickWithShiftEventToRowAtPath: #(1).
	presenter adapter sendClickWithShiftEventToRowAtPath: #(2).
	self
		assert: self adapter selectedPaths
		equals: #((2) (1))! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterItemSetsSelectedIndexInWidget
	"There is no selectedIndex in trees (but selectedPath).
	 This cancels superclass method"
	
	self skip! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'tests' stamp: ''!
testUnselectAllInWidgetRaisesEmptySelectionChangeEvent
	| gotSelection |
	
	self adapter selectPath: #(1).
	presenter selection
		whenChangedDo: [ :selection | gotSelection := selection ].
	self adapter selectPath: #().
	self assertEmpty: gotSelection! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testClickDoesNotAccumulatesSelection
	
	self openInstance.
	presenter adapter sendClickEventToRowAtPath: #(1).
	presenter adapter sendClickEventToRowAtPath: #(2).
	self
		assert: self adapter selectedPaths
		equals: #((2))! !

!SpTreeAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventOnce
	| counter |
	
	counter := 0.
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #(1).
	self assert: counter equals: 1! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTreePresenter! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterWithScrollingMakeSelectedItemVisible
	| visibleItems |

	presenter
		roots: (1 to: 200);
		openWithSpec.
		
	presenter selectPath: { 150 } scrollToSelection: true.
	visibleItems := presenter verticalAlignment firstVisibleRowIndex to: presenter verticalAlignment lastVisibleRowIndex.
		
	self assert: (visibleItems includes: presenter selection selectedPath first)! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	presenter
		beSingleSelection;
		roots: #(10 20 30).
	! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexSetsSelectedIndexInWidget
	
	presenter selectPath: #(1).
	self assert: (self adapter selectedPaths includes: #(1))! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectWidgetIndexRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedPath |
	
	self adapter selectPath: #(1).
	presenter selection 
		whenChangedDo: [ :selection | selectedPath := selection ].
	self adapter selectPath: #().
	self assertEmpty: selectedPath! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedPath |
	
	presenter selection
		whenChangedDo: [ :selection | selectedPath := selection ].
	self adapter selectPath: #(1).
	self assert: selectedPath equals: #(1)! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexOutsideRangeUnsetsSelectedIndexInWidget
	
	presenter selectPath: #(100).
	self assert: self adapter selectedPaths isEmpty! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectAllInWidgetRaisesSelectionIndexChangeEventOnce
	| counter |
	
	counter := 0.
	self adapter selectPath: #(1).
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #().
	self assert: counter equals: 1! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectAllInWidgetWithoutSelectionDoesNotRaiseEvent
	| counter |
	
	counter := 0.
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #().
	self assert: counter equals: 0! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectPresenterItemUnselectsIndexInWidget
	
	self skip. "No selectItem for the moment"! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterItemSetsSelectedIndexInWidget
	
	self skip. "No selectItem for the moment"! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectPresenterIndexUnselectsIndexInWidget
	
	presenter
		selectPath: #(1);
		unselectPath: #(1).
	self assert: self adapter selectedPaths isEmpty! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectManyIndexesKeepsLastSelectionInWidget
	
	presenter selectPath: #(1).
	presenter selectPath: #(2).
	self assert: self adapter selectedPaths equals: #(#(2))! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectWidgetIndexRaisesSelectionIndexChangeEventOnce
	| counter |
	
	counter := 0.
	self adapter selectPath: #(1).
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #().
	self assert: counter equals: 1! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventOnce
	| counter |
	
	counter := 0.
	presenter selection whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #(1).
	self assert: counter equals: 1! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectAllInWidgetNotRaisesEmptySelectionChangeEvent
	| gotSelection |
	
	presenter selection
		whenChangedDo: [ :selection | gotSelection := selection ].
	self adapter selectPath: #().
	self assert: gotSelection isNil! !

!SpTreeAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterWithoutScrollingDoesNotScroll
	| visibleItems verticalAlignment |
	
	presenter 
		roots: (1 to: 200);
		openWithSpec.
	verticalAlignment := presenter verticalAlignment.		
	visibleItems := verticalAlignment firstVisibleRowIndex to: verticalAlignment lastVisibleRowIndex.
	
	presenter selectPath: { 150 } scrollToSelection: false.
		
	self 
		assert: (verticalAlignment firstVisibleRowIndex to: verticalAlignment lastVisibleRowIndex) 
		equals: visibleItems! !

!SpTreeColumn commentStamp: ''!
I am a Tree column made especially to be used by the Spec framework!
!SpTreeColumn methodsFor: 'compatibility' stamp: ''!
bindKeyCombination: aKMCombination toAction: aBlock

	"Do nothing"
	! !

!SpTreeColumn methodsFor: 'accessing' stamp: ''!
visible: aBoolean

	"Do nothing. Morphs implement visible but this column, though it inherits from Morphic column and has an adapter, dos not."! !

!SpTreeColumn methodsFor: 'column drawing' stamp: ''!
rowMorphFor: aNode 
	| node rowMorph |
	
	node := aNode nodeModel.
	rowMorph := self rowMorphGetSelector
		ifNil: [node rowMorphForColumn: self]
		ifNotNil: [self rowMorphGetterBlock value: node value: self container].
	rowMorph := rowMorph asMorph.
	rowMorph
		ifNotNil: [rowMorph borderWidth: 0]
		ifNil: [rowMorph := self defaultRowMorph].
	^ rowMorph rowMorphForNode: node inColumn: self
! !

!SpTreeColumn methodsFor: 'private' stamp: ''!
setHeaderButtonLabel: aLabel font: aFont icon: anIconForm target: aReceiver actionSelector: aSelector
	(aLabel isNil
		and: [ anIconForm isNil and: [ aReceiver isNil or: [ aSelector isNil ] ] ])
		ifTrue: [ ^ self ].
	self headerButton.
	aLabel
		ifNil: [ self header label: '' font: nil ]
		ifNotNil: [ self header label: aLabel font: aFont ].
	anIconForm
		ifNotNil: [ self header icon: (ImageMorph new form: anIconForm) ].
	(aSelector notNil and: [ aReceiver notNil ])
		ifFalse: [ ^ self ].
	self header actionSelector: aSelector.
	self header target: aReceiver! !

!SpTreeMultipleSelectionMode methodsFor: 'selection' stamp: ''!
selectPaths: pathArray
	(pathArray isEmpty 
		or: [ 
			pathArray size = 1 
			and: [ pathArray first isEmpty] ]) 
		ifTrue: [ ^ self unselectAll ].

	pathArray
		do: [ :path | presenter itemAtPath: path ifAbsent: [ ^ self ] ].
	selection = pathArray ifTrue: [ ^ self ].
	
	selection := pathArray! !

!SpTreeMultipleSelectionMode methodsFor: 'testing' stamp: ''!
includesItem: anItem
	^ self selectedItems includes: anItem! !

!SpTreeMultipleSelectionMode methodsFor: 'accessing' stamp: ''!
selectedItem

	^ self selectedPaths 
		ifNotEmpty: [ :paths | presenter itemAtPath: paths first  ]
		ifEmpty: [ nil ]! !

!SpTreeMultipleSelectionMode methodsFor: 'selection' stamp: ''!
selectPath: aPath 
	"Check comment in my superclass to know how to use selectPath:"
	
	aPath ifEmpty: [ ^ self unselectAll ].
	(selection includes: aPath) ifTrue: [ ^ self ].
	presenter itemAtPath: aPath ifAbsent: [ ^ self ].
	
	selection := selection copyWith: aPath.! !

!SpTreeMultipleSelectionMode methodsFor: 'testing' stamp: ''!
includesItems: anItemList
	^ self selectedItems includesAll: anItemList! !

!SpTreeMultipleSelectionMode methodsFor: 'testing' stamp: ''!
includesPaths: aListOfPaths
	^ selection includesAll: aListOfPaths! !

!SpTreeMultipleSelectionMode methodsFor: 'accessing' stamp: ''!
selectedPath
	
	^ self selectedPaths 
		ifNotEmpty: [ :paths | paths last ]
		ifEmpty: [ nil ]! !

!SpTreeMultipleSelectionMode methodsFor: 'accessing' stamp: ''!
selectedItems
	selection ifEmpty: [ ^ #() ].
	^ selection collect: [ :path | presenter itemAtPath: path ]! !

!SpTreeMultipleSelectionMode methodsFor: '*Spec2-Transmission' stamp: ''!
transmission
	
	^ self selectedItems! !

!SpTreeMultipleSelectionMode methodsFor: 'testing' stamp: ''!
isMultipleSelection

	^ true! !

!SpTreeMultipleSelectionMode methodsFor: 'accessing' stamp: ''!
selectedPaths
	^ selection! !

!SpTreeMultipleSelectionMode methodsFor: 'testing' stamp: ''!
includesPath: aPath
	^ selection includes: aPath! !

!SpTreeMultipleSelectionMode methodsFor: 'selection' stamp: ''!
unselectPath: aPath
	self selectPaths: (self selectedPaths copyWithout: aPath)! !

!SpTreePresenter commentStamp: ''!
A presenter to display tree of elements.
A `SpTreePresenter` will display a line with a description of the element (See `SpTreePresenter>>#display:`, and optionally an icon (See `SpTreePresenter>>#icon:`).

A `SpTreePresenter` can be seen as a simplified `SpTreeTablePresenter`.
!
!SpTreePresenter methodsFor: 'api' stamp: ''!
displayBackgroundColor

	^ backgroundColorAction! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
showColumnHeaders
	"Show column headers"

	showColumnHeaders := true! !

!SpTreePresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	self withScrollBars.
	
	activationBlock := [ ].
	
	displayBlock := [ :each | each asString ].
	showColumnHeaders := false.
	isResizable := false.
	childrenBlock := [ :item | #() ].
	roots := #().
	verticalAlignment := SpVerticalAlignment new.

	self beSingleSelection.
	self activateOnDoubleClick.
	self registerEvents! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayBold

	^ boldAction! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
hideColumnHeaders
	"Hide the column headers"

	showColumnHeaders := false! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayItalic: aBlock
	"If `aBlock` answer true, the cell will be displayed in italic.
	 `aBlock` receives one argument (the model element)."

	italicAction := aBlock! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
display
	"Answer the display block that will transform the model nodes into a displayable string."

	^ displayBlock! !

!SpTreePresenter methodsFor: 'testing' stamp: ''!
isShowingColumnHeaders
	"Answer true if the table is configured to show column headers."

	^ showColumnHeaders! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayUnderline: aBlock
	"If `aBlock` answer true, the cell will be displayed underlined.
	 `aBlock` receives one argument (the model element)."

	underlineAction := aBlock! !

!SpTreePresenter methodsFor: 'testing' stamp: ''!
isResizable
	"Answer true if table allows resizing of its columns."

	^ isResizable! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
display: aBlock
	"Set the block that will be applied on each of the list items. 
	 The result of the block will be used to display the item on the screen.
	 `aBlock` receives one argument.
	 Here is the typical example:

	 initializePresenters
   		...
   		tree := self newTree.
		tree display: [ :anObject | anObject printString ]
   		...
	 "

	displayBlock := aBlock! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayBold: aBlock
	"If `aBlock` answer true, the cell will be displayed in bold.
	 `aBlock` receives one argument (the model element)."

	boldAction := aBlock! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayColor: aBlock
	"Changes the font color of cells of the column. 
	 `aBlock` receives an argument (the model element) and should answer an instance of Color."

	colorAction := aBlock! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayUnderline

	^ underlineAction! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
beResizable
	"Mark the table as 'resizable', which means there will be a slider to resize the columns."

	self isResizable: true! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayIcon: aBlock
	"Set a block which takes an item as argument and returns the icon to display in the tree.
	 `aBlock` receives one argument"
	
	iconBlock := aBlock! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayIcon
	"Return the block used to return an icon that will be displayed in the tree"

	^ iconBlock! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayColor

	^ colorAction! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
beNotResizable
	"Mark the table as 'not resizable', which means there will be not possibility to resize the 
	 columns of it."

	self isResizable: false! !

!SpTreePresenter methodsFor: 'private' stamp: ''!
isResizable: aBoolean
	isResizable := aBoolean! !

!SpTreePresenter methodsFor: 'private' stamp: ''!
shouldLazilyComputeChildren

	^ false! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayBackgroundColor: aBlock
	"Changes the background color of cells of the column. 
	 `aBlock` receives an argument (the model element) and should answer an instance of Color. 
	 NOTE: This may be not working at the moment :("

	backgroundColorAction := aBlock! !

!SpTreePresenter methodsFor: 'api' stamp: ''!
displayItalic

	^ italicAction! !

!SpTreePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithDecoratedString
	
	^ self new
		displayIcon: [ :aClass | aClass systemIcon ];
		displayColor: [ :aClass | 
			(aClass name endsWith: 'Test')
				ifTrue: [ Color green ]
				ifFalse: [ Smalltalk ui theme textColor ] ];
		displayItalic: [ :aClass | aClass name includesSubstring: 'abstract' caseSensitive: false ];
		displayBold: [ :aClass | aClass hasSubclasses ];
		displayUnderline: [ :aClass | aClass numberOfMethods > 10 ];
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		openWithSpec! !

!SpTreePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleExpandPath
	
	^ self new
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		displayIcon: [ :aClass | aClass systemIcon ];
		display: [ :aClass | aClass name ];
		expandPath: #(1 1 3); "Object/Exception/Notification"
		openWithSpec! !

!SpTreePresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newTree! !

!SpTreePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example
	<sampleInstance>
	
	^ self new
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		displayIcon: [ :aClass | aClass systemIcon ];
		display: [ :aClass | aClass name ];
		openWithSpec! !

!SpTreePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleSelectPathByItems
	
	^ self new
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		displayIcon: [ :aClass | aClass systemIcon ];
		display: [ :aClass | aClass name ];
		openWithSpec;
		selectPathByItems: self withAllSuperclasses reversed allButFirst scrollToSelection: true! !

!SpTreePresenter class methodsFor: 'documentation' stamp: ''!
documentSections
		
	^ OrderedDictionary newFromPairs: {
		'Examples'. self class methods select: [ :each | each protocol = self documentExamplesProtocol ].
		'API Methods'. self methods select: [ :each | each protocol = #'api' ].
		'API Selection Methods'. self methods select: [ :each | each protocol = #'api - selection' ].
		'Testing Methods'. self methods select: [ :each | each protocol = #'testing' ].
		'Events'. self methods select: [ :each | each protocol = #'api - events' ].
	 }! !

!SpTreePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleExpandRoots
	
	^ self new
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		displayIcon: [ :aClass | aClass systemIcon ];
		display: [ :aClass | aClass name ];
		expandRoots;
		openWithSpec! !

!SpTreePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithContextMenu
	<sampleInstance>
	| tree |
	
	^ (tree := self new)
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		displayIcon: [ :aClass | aClass systemIcon ];
		display: [ :aClass | aClass name ];
		contextMenu: [
			SpMenuPresenter new 
				addGroup: [ :group | group 
					addItem: [ :item | item name: tree selectedItem asString ] ] ];
		openWithSpec! !

!SpTreePresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TreeAdapter! !

!SpTreePresenterExpandTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTreePresenter! !

!SpTreePresenterExpandTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	presenter 
		roots: #(1);
		children: [ :aNumber | 
			aNumber < 1000
				ifTrue: [ (aNumber * 10 to: (aNumber * 10) + 10) asOrderedCollection ]
				ifFalse: [ #() ] ].! !

!SpTreePresenterExpandTest methodsFor: 'tests' stamp: ''!
testExpandPath

	presenter expandPath: #(1 2 3).
	self openInstance.
	self deny: presenter roots isEmpty.
	self assert: (presenter adapter isExpanded: (presenter itemAtPath: #(1 2 3)))! !

!SpTreePresenterExpandTest methodsFor: 'tests' stamp: ''!
testExpandRoots

	presenter expandRoots.
	self openInstance.
	self deny: presenter roots isEmpty.
	self 
		assert: (presenter roots select: [ :anItem | presenter adapter isExpanded: anItem ])
		equals: presenter roots! !

!SpTreePresenterExpandTest methodsFor: 'tests' stamp: ''!
testExpandRootsAfterInitialization

	self openInstance.
	presenter expandRoots.
	self deny: presenter roots isEmpty.
	self 
		assert: (presenter roots select: [ :anItem | presenter adapter isExpanded: anItem ])
		equals: presenter roots! !

!SpTreePresenterExpandTest methodsFor: 'tests' stamp: ''!
testCollapseAll

	presenter expandAll.
	self openInstance.
	self deny: presenter roots isEmpty.
	self assert: (presenter adapter isExpanded: (presenter itemAtPath: #(1 2 3))).	
	presenter collapseAll.
	self deny: (presenter adapter isExpanded: (presenter itemAtPath: #(1 2 3)))! !

!SpTreePresenterExpandTest methodsFor: 'tests' stamp: ''!
testCollapsePath

	presenter expandAll.
	self openInstance.
	self deny: presenter roots isEmpty.
	self assert: (presenter adapter isExpanded: (presenter itemAtPath: #(1 2 3))).	
	presenter collapsePath: #(1 2 3).
	self deny: (presenter adapter isExpanded: (presenter itemAtPath: #(1 2 3)))! !

!SpTreePresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTreePresenter! !

!SpTreeSingleSelectionMode methodsFor: 'accessing' stamp: ''!
selectPaths: pathArray

	self selectPath: (pathArray 
		ifNotEmpty: [ pathArray last ]
		ifEmpty: [ pathArray ])! !

!SpTreeSingleSelectionMode methodsFor: 'selection' stamp: ''!
itemNotFoundAction
	self clearSelection! !

!SpTreeSingleSelectionMode methodsFor: 'accessing' stamp: ''!
selectedItem
	
	selection ifEmpty: [ ^ nil ].
	
	^ presenter itemAtPath: selection.! !

!SpTreeSingleSelectionMode methodsFor: 'accessing' stamp: ''!
selectPath: aPath
	"Check comment in my superclass to know how to use selectPath:"

	"If the path is out of range, keep the selection."
	aPath ifEmpty: [ ^ self unselectAll ].
	presenter 
		itemAtPath: aPath 
		ifAbsent: [ ^ self ].
	selection := aPath.
! !

!SpTreeSingleSelectionMode methodsFor: 'accessing' stamp: ''!
selectedPath
	
	^ selection! !

!SpTreeSingleSelectionMode methodsFor: '*Spec2-Transmission' stamp: ''!
transmission
	
	^ self selectedItem! !

!SpTreeSingleSelectionMode methodsFor: 'accessing' stamp: ''!
selectedPaths
	
	selection ifEmpty: [ ^ #() ].
	^ { selection }! !

!SpTreeSingleSelectionMode methodsFor: 'selecting' stamp: ''!
unselectPath: aPath
	"If the path is out of range, keep the selection."
	selection = aPath ifFalse: [ ^ self ].
	self clearSelection! !

!SpTreeTableAdapterMultiColumnMultiSelectionTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	presenter
		addColumn: (SpStringTableColumn title: 'Value' evaluated: #printString);
		addColumn: (SpImageTableColumn title: 'Icon' evaluated: [ :x | self iconNamed: #add ]);
		hideColumnHeaders;	
		beMultipleSelection;
		roots: #(1 2 3);
		children: [ :aNumber | { aNumber * 2. aNumber * 3. aNumber * 10 } ].
! !

!SpTreeTableAdapterMultiColumnTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance
	super initializeTestedInstance.
	presenter addColumn: (SpImageTableColumn title: 'Icon' evaluated: [ :x | self iconNamed: #add ])! !

!SpTreeTableAdapterMultiColumnTest methodsFor: 'tests' stamp: ''!
testAddingColumnUpdatesWidget

	self presenter addColumn: (SpStringTableColumn title: 'Value' evaluated: #printString).
	
	self assert: self adapter columnCount equals: 3! !

!SpTreeTableAdapterMultipleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTreeTablePresenter! !

!SpTreeTableAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectManyIndexesKeepsAllSelected
	
	presenter selectPath: #(1).
	presenter selectPath: #(2).
	self
		assert: self adapter selectedPaths
		equals: #((1) (2))! !

!SpTreeTableAdapterMultipleSelectionTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	presenter
		beMultipleSelection;
		addColumn: (SpStringTableColumn title: 'Test' evaluated: #asString);
		roots: #(10 20 30 'abc')! !

!SpTreeTableAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexSetsSelectedIndexInWidget
	
	presenter selectPath: #(1).
	self assert: (self adapter selectedPaths includes: #(1))! !

!SpTreeTableAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedPaths |
	
	presenter selection whenChangedDo: [ :selection | selectedPaths := selection ].
	self adapter selectPath: #(1).
	self assert: (selectedPaths includes: #(1))! !

!SpTreeTableAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexOutsideRangeUnsetsSelectedIndexInWidget
	
	presenter selectPath: #(100).
	self assert: self adapter selectedPaths isEmpty! !

!SpTreeTableAdapterMultipleSelectionTest methodsFor: 'tests - widget-to-model' stamp: ''!
testUnselectAllInWidgetRaisesSelectionIndexChangeEventOnce
	| counter |
	
	counter := 0.
	self adapter selectPath: #(1).
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #().
	self assert: counter equals: 1! !

!SpTreeTableAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterItemSetsSelectedIndexInWidget
	"There is no selectedIndex in trees (but selectedPath).
	 This cancels superclass method"
	
	self skip! !

!SpTreeTableAdapterMultipleSelectionTest methodsFor: 'tests' stamp: ''!
testUnselectAllInWidgetRaisesEmptySelectionChangeEvent
	| gotSelection |
	
	self adapter selectPath: #(1).
	presenter selection
		whenChangedDo: [ :selection | gotSelection := selection ].
	self adapter selectPath: #().
	self assertEmpty: gotSelection! !

!SpTreeTableAdapterMultipleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventOnce
	| counter |
	
	counter := 0.
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #(1).
	self assert: counter equals: 1! !

!SpTreeTableAdapterSingleColumnMultiSelectionTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance
	super initializeTestedInstance.
	presenter beMultipleSelection! !

!SpTreeTableAdapterSingleColumnMultiSelectionTest methodsFor: 'tests' stamp: ''!
testSelecting2ElementsUpdatesThePresenterCorrectly

! !

!SpTreeTableAdapterSingleColumnMultiSelectionTest methodsFor: 'tests' stamp: ''!
testSelectingAPathUpdatesSelectionInPresenter

	self presenter selection 
		selectPath: #(1 2);
		selectPath: #(2 3).
		
	self assert: self adapter selectedPaths asArray equals: #(#(1 2) (2 3))! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTreeTablePresenter! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterWithScrollingMakeSelectedItemVisible
	| visibleItems |

	presenter
		roots: (1 to: 200);
		openWithSpec.
		
	presenter selectPath: { 150 } scrollToSelection: true.
	visibleItems := presenter verticalAlignment firstVisibleRowIndex to: presenter verticalAlignment lastVisibleRowIndex.
		
	self assert: (visibleItems includes: presenter selection selectedPath first)! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	presenter
		beSingleSelection;
		addColumn: (SpStringTableColumn title: 'Test' evaluated: #asString);
		roots: #(10 20 30).
	! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexSetsSelectedIndexInWidget
	
	presenter selectPath: #(1).
	self assert: (self adapter selectedPaths includes: #(1))! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectWidgetIndexRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedPath |
	
	self adapter selectPath: #(1).
	presenter selection 
		whenChangedDo: [ :selection | selectedPath := selection ].
	self adapter selectPath: #().
	self assertEmpty: selectedPath! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventWithSelectedIndex
	| selectedPath |
	
	presenter selection
		whenChangedDo: [ :selection | selectedPath := selection ].
	self adapter selectPath: #(1).
	self assert: selectedPath equals: #(1)! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterIndexOutsideRangeUnsetsSelectedIndexInWidget
	
	presenter selectPath: #(100).
	self assert: self adapter selectedPaths isEmpty! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectAllInWidgetRaisesSelectionIndexChangeEventOnce
	| counter |
	
	counter := 0.
	self adapter selectPath: #(1).
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #().
	self assert: counter equals: 1! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests' stamp: ''!
testSelectWhenSortedTransmitsCorrectElement
	| item |
	
	presenter columns first beSortable.
	presenter whenSelectionChangedDo: [ :selection | item := selection selectedItem ].	
	self openInstance.
	presenter clickAtPath: #(1).
	self assert: item equals: 10.
	"ascending (no change)"
	presenter adapter sortByColumn: presenter columns first. 
	"desscending (inverses numbers, there will be a change)"
	presenter adapter sortByColumn: presenter columns first.
	"click last element, since they are inversed, it will be the same as before"
	presenter clickAtPath: #(3).
	self assert: item equals: 10! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectAllInWidgetWithoutSelectionDoesNotRaiseEvent
	| counter |
	
	counter := 0.
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #().
	self assert: counter equals: 0! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectPresenterItemUnselectsIndexInWidget
	
	self skip. "No selectItem for the moment"! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterItemSetsSelectedIndexInWidget
	
	self skip. "No selectItem for the moment"! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectPresenterIndexUnselectsIndexInWidget
	
	presenter
		selectPath: #(1);
		unselectPath: #(1).
	self assert: self adapter selectedPaths isEmpty! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectManyIndexesKeepsLastSelectionInWidget
	
	presenter selectPath: #(1).
	presenter selectPath: #(2).
	self assert: self adapter selectedPaths equals: #(#(2))! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectWidgetIndexRaisesSelectionIndexChangeEventOnce
	| counter |
	
	counter := 0.
	self adapter selectPath: #(1).
	presenter selection
		whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #().
	self assert: counter equals: 1! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectWidgetIndexRaisesSelectionIndexChangeEventOnce
	| counter |
	
	counter := 0.
	presenter selection whenChangedDo: [ :selection | counter := counter + 1 ].
	self adapter selectPath: #(1).
	self assert: counter equals: 1! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testUnselectAllInWidgetNotRaisesEmptySelectionChangeEvent
	| gotSelection |
	
	presenter selection
		whenChangedDo: [ :selection | gotSelection := selection ].
	self adapter selectPath: #().
	self assert: gotSelection isNil! !

!SpTreeTableAdapterSingleSelectionTest methodsFor: 'tests - model-to-widget' stamp: ''!
testSelectPresenterWithoutScrollingDoesNotScroll
	| visibleItems verticalAlignment |
	
	presenter 
		roots: (1 to: 200);
		openWithSpec.
	verticalAlignment := presenter verticalAlignment.		
	visibleItems := verticalAlignment firstVisibleRowIndex to: verticalAlignment lastVisibleRowIndex.
	
	presenter selectPath: { 150 } scrollToSelection: false.
		
	self 
		assert: (verticalAlignment firstVisibleRowIndex to: verticalAlignment lastVisibleRowIndex) 
		equals: visibleItems! !

!SpTreeTablePresenter commentStamp: ''!
A presenter for tree with a table.
A table has columns with a type (See column types section).

**IMPORTANT:** A table presenter does not contain other presenters. Instead, it maps the model provided (See `SpTreeTablePresenter>>#roots:` and `SpTreeTablePresenter>>#children:`) with the columns defined. If you need this behavior, you will need to use `SpComponentListPresenter`.
!
!SpTreeTablePresenter methodsFor: 'api' stamp: ''!
addColumn: aColumn
	"Add a column to the table. A column should be an instance of `SpTableColumn`"

	columns := self columns copyWith: aColumn! !

!SpTreeTablePresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	self withScrollBars.
	
	activationBlock := [ ].
	
	showColumnHeaders := true.
	columns := #().
	isResizable := false.
	childrenBlock := [ :item | #() ].
	roots := #().
	lazilyComputeChildren := false.
	verticalAlignment := SpVerticalAlignment new.


	self beSingleSelection.
	self activateOnDoubleClick.
	self registerEvents! !

!SpTreeTablePresenter methodsFor: 'api' stamp: ''!
columns
	"Answer the columns composing this table."

	^ columns! !

!SpTreeTablePresenter methodsFor: 'api' stamp: ''!
hideColumnHeaders
	"Hide the column headers"

	showColumnHeaders := false! !

!SpTreeTablePresenter methodsFor: 'testing' stamp: ''!
isShowingColumnHeaders
	"Answer true if the table is configured to show column headers."

	^ showColumnHeaders! !

!SpTreeTablePresenter methodsFor: 'api' stamp: ''!
selectionMode
	"Answer the selection object (an instance of `SpSingleSelectionMode` or `SpMultipleSelectionMode`).
	 This is not the item selected, but the selection container (it may contain one or many selected 
	 items).
	 This is the same as `SpAbstractListPresenter>>#selection`"

	^ selectionMode! !

!SpTreeTablePresenter methodsFor: 'api - events' stamp: ''!
whenIsResizableChangedDo: aBlock
	"Inform when resizable property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #isResizable whenChangedDo: aBlock! !

!SpTreeTablePresenter methodsFor: 'api' stamp: ''!
columns: aCollection
	"Set all columns at once. 
	 `aCollection` is a list of instances of `SpTableColumn`"

	columns := aCollection! !

!SpTreeTablePresenter methodsFor: 'testing' stamp: ''!
isResizable
	"Answer true if table allows resizing of its columns."

	^ isResizable! !

!SpTreeTablePresenter methodsFor: 'api - events' stamp: ''!
whenColumnsChangedDo: aBlock
	"Inform when columns have changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"	
	

	self property: #columns whenChangedDo: aBlock! !

!SpTreeTablePresenter methodsFor: 'private' stamp: ''!
lazilyComputeChildren
	"When we compute lazily the children, we will show in all cases the expand arrow even if there is no children until we open this children."

	lazilyComputeChildren := true! !

!SpTreeTablePresenter methodsFor: 'api' stamp: ''!
beResizable
	"Mark the table as 'resizable', which means there will be a slider to resize the columns."

	self isResizable: true! !

!SpTreeTablePresenter methodsFor: 'private' stamp: ''!
lazilyComputeChildren: aBoolean
	lazilyComputeChildren := aBoolean! !

!SpTreeTablePresenter methodsFor: 'private' stamp: ''!
isResizable: aBoolean
	isResizable := aBoolean! !

!SpTreeTablePresenter methodsFor: 'api' stamp: ''!
beNotResizable
	"Mark the table as 'not resizable', which means there will be not possibility to resize the 
	 columns of it."

	self isResizable: false! !

!SpTreeTablePresenter methodsFor: 'private' stamp: ''!
shouldLazilyComputeChildren
	^ lazilyComputeChildren! !

!SpTreeTablePresenter methodsFor: 'api' stamp: ''!
showColumnHeaders
	"Show column headers"

	showColumnHeaders := true! !

!SpTreeTablePresenter class methodsFor: 'documentation' stamp: ''!
addDocumentExtraSections: aBuilder

	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Column types' ] withLevel: 2.
	aBuilder unorderedListDuring: [ 
		(SpTableColumn allSubclasses sorted: #name ascending) do: [ :eachType | 
			aBuilder item: [
				aBuilder monospace: eachType name ] ] ]! !

!SpTreeTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithDecoratedString
	
	^ self new
		addColumn: (SpImageTableColumn title: 'Icon' evaluated: [ :aClass | aClass systemIcon ]);
		addColumn: (SpStringTableColumn new 
			title: 'Name'; 
			evaluated: [ :aClass | aClass name ];
			displayColor: [ :aClass | 
				(aClass name endsWith: 'Test')
					ifTrue: [ Color green ]
					ifFalse: [ Smalltalk ui theme textColor ] ];
			displayItalic: [ :aClass | aClass name includesSubstring: 'abstract' caseSensitive: false ];
			displayBold: [ :aClass | aClass hasSubclasses ];
			displayUnderline: [ :aClass | aClass numberOfMethods > 10 ];
			yourself);
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		openWithSpec! !

!SpTreeTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleExpandPath

	^ self new
		addColumn: (SpCompositeTableColumn new
			title: 'Classes';
			addColumn: ((SpImageTableColumn evaluated: #systemIcon) width: 20);
			addColumn: (SpStringTableColumn evaluated: #name);
			yourself);
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		expandPath: #(1 1 3); "Object/Exception/Notification"
		openWithSpec! !

!SpTreeTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleWithTwoColumns 

	^ self  new
		addColumn: (SpCompositeTableColumn new
			title: 'Classes';
			addColumn: ((SpImageTableColumn evaluated: [:c| c systemIcon]) );
			addColumn: (SpStringTableColumn evaluated: #name);
			yourself);
		addColumn: (SpStringTableColumn new
			title: 'Methods';
			evaluated: [:class | class methodDictionary size asString]);
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		openWithSpec! !

!SpTreeTablePresenter class methodsFor: 'documentation' stamp: ''!
documentFactoryMethodSelector

	^ #newTreeTable! !

!SpTreeTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
example

	^ self new
		addColumn: (SpCompositeTableColumn new
			title: 'Classes';
			addColumn: ((SpImageTableColumn evaluated: #systemIcon) width: 20);
			addColumn: (SpStringTableColumn evaluated: #name);
			yourself);
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		openWithSpec! !

!SpTreeTablePresenter class methodsFor: 'documentation' stamp: ''!
documentSections
		
	^ OrderedDictionary newFromPairs: {
		'Examples'. self class methods select: [ :each | each protocol = self documentExamplesProtocol ].
		'API Methods'. self methods select: [ :each | each protocol = #'api' ].
		'API Selection Methods'. self methods select: [ :each | each protocol = #'api - selection' ].
		'Testing Methods'. self methods select: [ :each | each protocol = #'testing' ].
		'Events'. self methods select: [ :each | each protocol = #'api - events' ].
	 }! !

!SpTreeTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleExpandRoots

	^ self new
		addColumn: (SpCompositeTableColumn new
			title: 'Classes';
			addColumn: ((SpImageTableColumn evaluated: #systemIcon) width: 20);
			addColumn: (SpStringTableColumn evaluated: #name);
			yourself);
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		expandRoots;
		openWithSpec! !

!SpTreeTablePresenter class methodsFor: '*Spec2-Examples' stamp: ''!
exampleResizableColumns

	^ self  new
		beResizable;
		addColumn: (SpCompositeTableColumn new
			title: 'Classes';
			addColumn: ((SpImageTableColumn evaluated: [:c| c systemIcon]) );
			addColumn: (SpStringTableColumn evaluated: #name);
			yourself);
		addColumn: (SpStringTableColumn new
			title: 'Methods';
			evaluated: [:class | class methodDictionary size asString]);
		roots: { Object };
		children: [ :aClass | aClass subclasses ];
		openWithSpec! !

!SpTreeTablePresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TreeTableAdapter! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectInvalidPathHasNoSelectedPaths

	presenter selectPath: #(4).
	self assert: presenter selection selectedPaths isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectUnselectedItemKeepsSelectionList

	presenter
		selectItem: 10;
		unselectItem: 20.
	self assert: presenter selection selectedItems asArray equals: #(10)! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsOutsideRangeHasNoSelectedPaths
	presenter selectItems: {3000 . 4000}.
	
	self assert: presenter selection selectedPaths isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathsAddsItemsToSelectedItemList
	| paths |
	paths := { #(1 2) . #(2 2) }.
	presenter selectPaths: paths.
	
	self assert: (presenter selection includesItems: {3 . 6})
	! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectMultipleItemAddsAllToSelectedPathList

	presenter 
		selectItem: 10;
		selectItem: 30.
	self 
		assertCollection: presenter selection selectedPaths
		hasSameElements: { #(1 3) . #(1 2 3) }! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectInvalidPathsIsEmpty
	presenter selectPaths: { #(40) . #(10 20)}.
	self assert: presenter selection isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectSelectedItemRaisesSelectionEventOnce
	
	| counter |
	counter := 0.
	presenter
		selectItem: 10;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectItem: 10.
	self assert: counter equals: 1! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectUnselectedItemRaisesNoSelectionEvent
	
	| counter |
	counter := 0.
	presenter
		selectItem: 10;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectItem: 20.
	self assert: counter equals: 0! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsThenSelectOutsideRangeKeepsElements
	presenter selectItems: {10 . 20}.
	presenter selectItems: {4000 . 5000}.
	self assert: (presenter selection includesItems: {10 . 20})! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectInvalidPathsHasNoSelectedPaths
	presenter selectPaths: { #(10 20) . #(20 20) }.
	self assert: presenter selection selectedPaths isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectSelectedItemRemovesItFromSelectionList

	presenter
		selectItem: 10;
		unselectItem: 10.
	self assert: (presenter selection isEmpty)! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemThenSelectOutsideRangeKeepsFirstElement

	presenter selectItem: 10.
	presenter selectItem: 5000.
	self assert: (presenter selection includesItem: 10)! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsThenSelectOutsideRangeKeepsPaths
	presenter selectItems: {10 . 20}.
	presenter selectItems: {5000 . 6000}.
	
	self 
		assertCollection: presenter selection selectedPaths
		hasSameElements: { #(1 1 3) . #(1 3) }! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpTreeTablePresenter! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemThenSelectOutsideRangeKeepsSingleSelectedItem

	presenter selectItem: 10.
	presenter selectItem: 3000.
	self assert: presenter selection selectedItems size equals: 1! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectSelectedPathRaisesSelectionEventOnce
	
	| counter |
	counter := 0.
	presenter
		selectPath: #(1 2);
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectPath: #(1 2).
		
	self assert: counter equals: 1! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsAddsPathsToSelectedPathList
	presenter selectItems: {10 . 20}.

	self 
		assertCollection: presenter selection selectedPaths 
		hasSameElements: { #(1 3) . #(1 1 3) }! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectedItemIsNilIfNothingIsSelected

	self assert: presenter selection selectedItem isNil.
	presenter selectItems: {10 . 20}.
	self deny: presenter selection selectedItem isNil.
	presenter unselectAll.
	self assert: presenter selection selectedItem isNil! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemOutsideRangeHasNoSelectedItems

	presenter selectItem: 4000.
	self assert: presenter selection selectedItems isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathAddsIndexToSelectedPathList

	presenter selectPath: #(1).
	self assert: (presenter selection includesPath: #(1))! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectUnselectedPathKeepsSelectionList

	presenter
		selectPath: #(1 2);
		unselectPath: #(2 2).
	self 
		assert: presenter selection selectedPaths
		equals: { #(1 2) }! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsAddsItemsToSelectedItemList
	presenter selectItems: {10 . 20}.
	self assert: (presenter selection includesItems: {10 . 20})! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectedPathsIsEmptyIfNothingIsSelected

	self assert: presenter selection selectedPaths isEmpty.
	presenter selectPath: #(1).
	self deny: presenter selection selectedPaths isEmpty.
	presenter unselectAll.
	self assert: presenter selection selectedPaths isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathsThenSelectInvalidPathKeepsElements

	presenter 
		selectPaths: {#(1 3) . #(2 2)};
		selectPaths:	{#(50) .	#(60 2)}.
	self assert: (presenter selection includesItems: #(10 6))! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectUnselectedPathRaisesNoSelectionEvent
	
	| counter |
	counter := 0.
	presenter
		selectPath: #(1 2);
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectPath: #(2 2).

	self assert: counter equals: 0! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemAddsItemToSelectedItemList

	presenter selectItem: 10.
	self assert: (presenter selection includesItem: 10)! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathThenSelectInvalidPathKeepsFirstElement
	
	presenter selectPath: #(1 3).
	presenter selectPath: #(50).
	self assert: (presenter selection includesItem: 10)! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectMultipleItemsAddsAllToSelectedItemList

	presenter selectItem: 10.
	presenter selectItem: 30.
	self assert: (presenter selection includesItem: 10).
	self assert: (presenter selection includesItem: 30).! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectMultiplePathsRaisesSelectionChangeEventMultipleTimes
	| events |
	events := 0.
	presenter whenSelectionChangedDo: [ :selection | events := events + 1 ].

	presenter	selectPath: #(1 1).
	presenter	selectPath: #(3).

	self assert: events equals: 2! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathsThenSelectInvalidPathKeepsPaths
	| paths |
	paths := {#(1 3) . #(2 2)}.
	presenter 
		selectPaths: paths;
		selectPaths:	{#(50) .	#(60 2)}.
	self assert: (presenter selection includesPaths: paths)! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectedItemsIsEmptyIfNothingIsSelected

	self assert: presenter selection selectedItems isEmpty.
	presenter selectItems: {10 . 20}.
	self deny: presenter selection selectedItems isNil.
	presenter unselectAll.
	self assert: presenter selection selectedItems isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsOutsideRangeIsEmpty
	presenter selectItems: {4000 . 5000}.
	self assert: presenter selection isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectAllUnselectsall

	presenter
		selectPath: #(1 2);
		unselectAll.
		
	self assert: presenter selection isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemsOutsideRangeHasNoSelectedItems
	presenter selectItems: {3000 . 4000}.
	
	self assert: presenter selection selectedItems isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectAbsentItemGivesEmptySelection

	presenter selectItem: 4000.
	self assert: presenter selection isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	presenter
		addColumn: (SpStringTableColumn title: 'Value' evaluated: #printString);
		beMultipleSelection;
		roots: #(1 2 3);
		children: [ :aNumber | 
			aNumber < 100
				ifTrue: [ { aNumber * 2. aNumber * 3. aNumber * 10 } ]
				ifFalse: [ #() ] ];
		yourself.! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathThenSelectInvalidPathKeepsSingleSelectedItem
	
	presenter selectPath: #(1 3).
	presenter selectPath: #(50).
	self 
		assert: presenter selection selectedItems size 
		equals: 1! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectSelectedPathRemovesItFromSelectionList

	presenter
		selectPath: #(1 2);
		unselectPath: #(1 2).
	self assert: (presenter selection isEmpty)! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemOutsideRangeDoesNotModifySelection

	presenter whenSelectionChangedDo: [ :selection | self fail ].
	
	presenter selectItem: 1000.
	"If we arrive here and the test did not fail, we succeeded"! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathAddsItemToSelectedItemList

	presenter selectPath: #(1 3).
	self assert: (presenter selection includesItem: 10)! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectMultipleItemsRaisesSelectionChangeEventMultipleTimes
	| events |
	events := 0.
	presenter whenSelectionChangedDo: [ :selection | events := events + 1 ].

	presenter selectItem: 10.
	presenter selectItem: 30.

	self assert: events equals: 2! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathRaisesSelectionChangeEventWithSelectedPath
	| selectedPaths |
	presenter
		whenSelectionChangedDo: [ :selection | selectedPaths := selection selectedPaths ].
		
	presenter selectPath: #(1 2).
	
	self assert: (selectedPaths includes: #(1 2)).! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemOutsideRangeHasNoSelectedPath

	presenter selectItem: 4000.
	self assert: presenter selection selectedPaths isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemThenSelectOutsideRangeKeepsFirstPath

	presenter selectItem: 10.
	presenter selectItem: 5000.
	self 
		assertCollection: presenter selection selectedPaths
		hasSameElements: #( #(1 3) )! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectedPathIsNilIfNothingIsSelected

	self assert: presenter selection selectedPath isNil.
	presenter selectPath: #(1).
	self deny: presenter selection selectedPath isNil.
	presenter unselectAll.
	self assert: presenter selection selectedPath isNil! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectInvalidPathHasNoSelectedItems

	presenter selectPath: #(4).
	self assert: presenter selection selectedItems isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectMultiplePathsAddsAllToSelectedPathList

	presenter 
		selectPath: #(1 2);
		selectPath: #(2 2).
	self assert: (presenter selection includesItem: 3).
	self assert: (presenter selection includesItem: 6).

	self assert: (presenter selection includesPath: #(1 2)).
	self assert: (presenter selection includesPath: #(2 2)).! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectMultiplePathsAddsAllToSelectedItemList

	presenter 
		selectPath: #(1 2);
		selectPath: #(2 2).
	self assert: (presenter selection includesItem: 3).
	self assert: (presenter selection includesItem: 6).! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathsAddsPathsToSelectedPathList
	| paths |
	paths := { #(1 2) . #(2 2) }.
	presenter selectPaths: paths.
	self assert: (presenter selection includesPaths: paths).! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectInvalidPathDoesNotModifySelection

	presenter whenSelectionChangedDo: [ :selection | self fail ].
	
	presenter selectPath: #(50 1).
	"If we arrive here and the test did not fail, we succeeded".! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectInvalidPathsHasNoSelectedItems
	presenter selectPaths: { #(10 20) . #(20 20) }.
	self assert: presenter selection selectedItems isEmpty! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectPathRaisesSelectionChangeEventWithSelectedItem
	| selectedItems |
	presenter
		whenSelectionChangedDo: [ :selection | selectedItems := selection selectedItems ].
		
	presenter selectPath: #(1 3).
	
	self assert: (selectedItems includes: 10)! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectAllRaisesSelectionEventOnce
	"Because it does nothing in single selection mode"

	| nbEvents |
	nbEvents := 0.

	"Be sure there is one element selected at least to make selection change"
	presenter selectPath: #(1 1).
	presenter
		whenSelectionChangedDo: [ :selection | nbEvents := nbEvents + 1 ].
		
	presenter unselectAll.
	
	self assert: nbEvents equals: 1! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemAddsPathToSelectedPathList

	presenter selectItem: 10.
	self assert: (presenter selection includesPath: #(1 3))! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathThenSelectInvalidPathKeepsFirstPath
	
	presenter selectPath: #(1 3).
	presenter selectPath: #(50).
	self assert: (presenter selection includesPath: #(1 3))! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathTwiceAddsPathToSelectedPathListOnlyOnce

	presenter selectPath: #(1 3).
	presenter selectPath: #(1 3).
	self 
		assert: presenter selection selectedPaths
		equals: #( #(1 3) )! !

!SpTreeTablePresenterMultipleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathsTwiceAddsPathssToSelectedPathListOnlyOnce
	| paths |
	paths := {#(1 3) . #(2 2)}.
	presenter 
		selectPaths: paths;
		selectPaths:	paths.
	self 
		assertCollection: presenter selection selectedPaths 
		hasSameElements: paths! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectPathOutsideRangeRaisesSelectionChangeEventWithUnsetPath
	| selectedPath |
	presenter
		whenSelectionChangedDo: [ :selection | selectedPath := selection selectedPath ].
	presenter selectPath: #(4).
	
	self assert: selectedPath equals: nil! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathSetsSelectedPath

	presenter selectPath: #(1 1).
	
	self 
		assert: presenter selection selectedPath 
		equals: #(1 1)! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testWhenSelectPathTwiceThenIsListedOnceInSelectedPaths
	presenter
		selectPath: #(3 1);
		selectPath: #(3 1).

	self 
		assertCollection: presenter selection selectedPaths
		hasSameElements: { #(3 1) }! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectNonSelectedItemRaisesNoEvent
	
	| counter |
	counter := 0.
	presenter
		selectItem: 10;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectItem: 20.

	self assert: counter equals: 0! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemOutsideRangeUnsetsSelectedItem

	presenter selectItem: 4000.
	self assert: presenter selection selectedItem equals: nil! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectSelectedItemRaisesSingleEvent
	
	| counter |
	counter := 0.
	presenter
		selectItem: 10;
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectItem: 10.

	self assert: counter equals: 1! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemOutsideRangeRaisesSelectionChangeEventWithUnsetItem
	| selectedItem |
	presenter
		whenSelectionChangedDo: [ :selection | selectedItem := selection selectedItem ].
	presenter selectItem: 4000.
	self assert: selectedItem equals: nil! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectPathOutsideRangeRaisesSelectionChangeEventWithUnsetItem
	| selectedItem |
	presenter
		whenSelectionChangedDo: [ :selection | selectedItem := selection selectedItem ].
	presenter selectPath: #(4).
	
	self assert: selectedItem equals: nil! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectPathRaisesSelectionPathChangeEventWithSelectedPath
	| selectedPath |
	presenter selection
		whenChangedDo: [ :selection | selectedPath := selection ].
	presenter selectPath: #(1 2).
	
	self assert: selectedPath equals: #(1 2)! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemSetsSelectedItem
	presenter selectItem: 20.
	self assert: presenter selection selectedItem equals: 20! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathOutsideRangeUnsetsSelectedItem
	presenter selectPath: { 4 }.
	
	self 
		assert: presenter selection selectedItem 
		equals: nil! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectNonSelectedPathDoesNotRemovesSelection
	presenter
		selectPath: #(1 1);
		unselectPath: #(1 3).

	self 
		assert: presenter selection selectedPath
		equals: #(1 1)! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectMultiplePathsRaisesSelectionChangeEventMultipleTimes
	| events |
	events := 0.
	presenter whenSelectionChangedDo: [ :selection | events := events + 1 ].

	presenter	selectPath: #(1).
	presenter	selectPath: #(1 3).

	self assert: events equals: 2! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectNonSelectedItemDoesNotRemovesSelection
	presenter
		selectItem: 10;
		unselectItem: 30.

	self 
		assert: presenter selection selectedItem 
		equals: 10! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemRaisesSelectionItemChangeEventWithSelectedItem
	| selectedItem |
	presenter
		whenSelectionChangedDo: [ :selection | selectedItem := selection selectedItem ].
	presenter selectItem: 10.
	self assert: selectedItem equals: 10! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectPathRaisesSelectionItemChangeEventWithSelectedItem
	| selectedItem |
	presenter
		whenSelectionChangedDo: [ :selection | selectedItem := selection selectedItem ].
	presenter selectPath: #(1 3).
	
	self 
		assert: selectedItem 
		equals: 10! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectNonSelectedPathRaisesNoEvent
	
	| counter |
	counter := 0.
	presenter
		selectPath: #(1 1);
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectPath: #(2 1).

	self assert: counter equals: 0! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.

	super setUp.
	presenter
		addColumn: (SpStringTableColumn title: 'Value' evaluated: #printString);
		beSingleSelection;
		roots: #(1 2 3);
		children: [ :aNumber | 
			aNumber < 100
				ifTrue: [ { aNumber * 2. aNumber * 3. aNumber * 10 } ]
				ifFalse: [ #() ] ];
		yourself.! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpTreeTablePresenter! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - unselect-item' stamp: ''!
testUnselectSelectedItemRemovesSelection

	presenter
		selectItem: 10;
		unselectItem: 10.

	self assert: presenter selection isEmpty! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectPathRaisesSelectionChangeEventWithSelectedPath
	| selectedPath |
	presenter
		whenSelectionChangedDo: [ :selection | selectedPath := selection selectedPath ].
	presenter selectPath: #(1 2).
	
	self assert: selectedPath equals: #(1 2).! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemSetsSelectedPath

	presenter selectItem: 20.
	self assert: presenter selection selectedPath equals: #(1 1 3)! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemRaisesSelectionChangeEventWithSelectedItem
	| selectedElement |
	presenter
		whenSelectionChangedDo: [ :selection | selectedElement := selection selectedItem ].
	presenter selectItem: 20.
	self assert: selectedElement equals: 20! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectAllUnselectsSingleSelection

	presenter
		selectPath: #(1 1);
		unselectAll.
	self assert: presenter selection isEmpty! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemRaisesSelectionChangeEventWithSelectedPath
	| selectedPath |

	presenter
		whenSelectionChangedDo: [ :selection | selectedPath := selection selectedPath ].
	presenter selectItem: 20.
	
	self assert: selectedPath equals: #(1 1 3)! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathSetsSelectedItem

	presenter selectPath: #(1 3).
	
	self 
		assert: presenter selection selectedItem 
		equals: 10! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemRaisesSelectionPathChangeEventWithSelectedPath
	| selectedPath |
	
	presenter selection
		whenChangedDo: [ :selection | selectedPath := selection ].
	presenter selectItem: 10.
	
	self assert: selectedPath equals: #(1 3)! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSetSelectPathRaisesSelectionChangeEventWithSelectedItem
	| selectedElement |

	presenter
		whenSelectionChangedDo: [ :selection | selectedElement := selection selectedItem ].
	presenter selectPath: #(1 3).
	
	self assert: selectedElement equals: 10! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectAllRaisesSelectionEventOnce
	"Because it does nothing in single selection mode"
	| events |
	events := 0.
	presenter whenSelectionChangedDo: [ :selection | events := events + 1 ].

	presenter unselectAll.

	self assert: events equals: 1! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectSelectedPathRemovesSelection
	presenter
		selectPath: #(1 1);
		unselectPath: #(1 1).

	self assert: presenter selection isEmpty! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSelectItemOutsideRangeUnsetsSelectedPath
	
	presenter selectItem: 4000.
	
	self 
		assert: presenter selection selectedPath equals: #()! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-item' stamp: ''!
testSetSelectItemOutsideRangeRaisesSelectionChangeEventWithUnsetPath
	| selectedPath |

	presenter
		whenSelectionChangedDo: [ :selection | selectedPath := selection selectedPath ].
	presenter selectItem: 4000.
	self assert: selectedPath equals: #()! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - select-index' stamp: ''!
testSelectPathOutsideRangeUnsetsSelectedPath
	presenter selectPath: #(4).

	self 
		assert: presenter selection selectedPath
	 	equals: #()! !

!SpTreeTablePresenterSingleSelectionTest methodsFor: 'tests - unselect-index' stamp: ''!
testUnselectSelectedPathRaisesSingleEvent
	
	| counter |
	counter := 0.
	presenter
		selectPath: #(1 1);
		whenSelectionChangedDo: [ counter := counter + 1 ];
		unselectPath: #(1 1).

	self assert: counter equals: 1! !

!SpTreeTablePresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTreeTablePresenter! !

!SpTreeTableSearchTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpTreeTablePresenter! !

!SpTreeTableSearchTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance 

	presenter roots: #(10 20 30).! !

!SpTreeTableSearchTest methodsFor: 'tests' stamp: ''!
selectedIndex

	^ self presenter selection selectedPath 
		ifNotEmpty: #first
		ifEmpty: [ 0 ]! !

!SpTreeTableSearchTest methodsFor: 'tests' stamp: ''!
selectIndex: index 

	self presenter selection selectPath: { index }! !

!SpUIThemeDecorator commentStamp: ''!
I decorate a UITheme allowing to override desired properties.

See #example on class side.!
!SpUIThemeDecorator methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	(self hasProperty: aMessage selector)
		ifTrue: [ |objOrBlock|
			objOrBlock := self objectAtProperty: aMessage selector.
			^ objOrBlock isBlock
				ifTrue: [ objOrBlock valueWithPossibleArgs: aMessage arguments ]
				ifFalse: [ objOrBlock value ] ].
	
	self theme
		ifNotNil: [ :t | ^ t perform: aMessage selector withArguments: aMessage arguments ].
	
	^ super doesNotUnderstand: aMessage! !

!SpUIThemeDecorator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	themeOverrideDict := Dictionary new! !

!SpUIThemeDecorator methodsFor: 'accessing' stamp: ''!
objectAtProperty: aSymbol
	^ themeOverrideDict at: aSymbol! !

!SpUIThemeDecorator methodsFor: 'accessing' stamp: ''!
theme
	^ theme! !

!SpUIThemeDecorator methodsFor: 'accessing' stamp: ''!
theme: anObject
	theme := anObject! !

!SpUIThemeDecorator methodsFor: 'accessing' stamp: ''!
property: aSymbol returnsValueOf: anObject
	themeOverrideDict
		at: aSymbol put: anObject! !

!SpUIThemeDecorator methodsFor: 'testing' stamp: ''!
hasProperty: aSymbol
	^ themeOverrideDict includesKey: aSymbol! !

!SpUIThemeDecorator class methodsFor: 'instance creation' stamp: ''!
theme: aUITheme
	^ self new
		theme: aUITheme;
		yourself! !

!SpUIThemeDecorator class methodsFor: 'examples' stamp: ''!
exampleDecoratorToMakePluggableButtonRed
	| normalColorBlock clickedColorBlock |
	normalColorBlock := [ :aButton |
							(aButton valueOfProperty: #noFill ifAbsent: [false]) 
								ifTrue: [ SolidFillStyle color: Color transparent ]
								ifFalse: [ SolidFillStyle color: Color red ] ].
	clickedColorBlock := [ :aButton | SolidFillStyle color: Color red muchDarker ].
	^ (SpUIThemeDecorator theme: Smalltalk ui theme)
			property: #buttonNormalFillStyleFor: returnsValueOf: normalColorBlock;
			property: #buttonMouseOverFillStyleFor: returnsValueOf: normalColorBlock;
			property: #buttonPressedFillStyleFor: returnsValueOf: clickedColorBlock;
			yourself! !

!SpUIThemeDecoratorTest commentStamp: ''!
I hold tests for UIThemeDecorator.!
!SpUIThemeDecoratorTest methodsFor: 'tests' stamp: ''!
testDoesNotUnderstand
	| block |
	themeDecorator
		property: #foo returnsValueOf: 42.
		
	self assert: (themeDecorator foo) equals: 42.
	
	block := [ 42 ].
	themeDecorator
		property: #fooBlock returnsValueOf: block.
	"Returns the result of the block evaluation."
	self assert: (themeDecorator fooBlock) equals: 42.
	
	block := [ :x | x + 42 ].
	
	themeDecorator
		property: #fooBlock: returnsValueOf: block.
	"Returns the result of the block evaluation."
	self assert: (themeDecorator fooBlock: 3) equals: 45.! !

!SpUIThemeDecoratorTest methodsFor: 'tests' stamp: ''!
testHasProperty
	self
		assert: (themeDecorator hasProperty: #buttonNormalFillStyleFor:);
		assert: (themeDecorator hasProperty: #buttonMouseOverFillStyleFor:);
		assert: (themeDecorator hasProperty: #buttonPressedFillStyleFor:);
		deny: (themeDecorator hasProperty: #controlButtonSelectedDisabledFillStyleFor:);
		deny: (themeDecorator hasProperty: #scrollbarMouseOverBorderStyleFor:);
		deny: (themeDecorator hasProperty: #scrollbarThumbCornerStyleIn:)! !

!SpUIThemeDecoratorTest methodsFor: 'tests' stamp: ''!
testPropertyReturnsValueOf
	| block |
	themeDecorator
		property: #foo returnsValueOf: 42.
		
	self assert: (themeDecorator objectAtProperty: #foo) equals: 42.
	
	block := [ 42 ].
	
	themeDecorator
		property: #fooBlock returnsValueOf: block.
	"Returns the block, not its value."
	self assert: (themeDecorator objectAtProperty: #fooBlock) equals: block.! !

!SpUIThemeDecoratorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	themeDecorator := SpUIThemeDecorator exampleDecoratorToMakePluggableButtonRed! !

!SpValueHolder commentStamp: ''!
I am a class holding any object inside its unique instance variable. 
Each time the instance variable value changes, an announcement is emitted. 

The instance variable is accessed through `value` and `value:` while the registration is done by `whenChangedDo: aBlock`. 

In addition, infinite loops of propagation are prevented. 
Use case: you have two lists A, and B, and you want to keep their selection synchronised. 
So when A selection changes, you set B selection. 
But since B selection changes, you set A selection, and so on… 

This case is prevented by the use of a `lock` variable.!
!SpValueHolder methodsFor: 'accessing' stamp: ''!
value: anObject
	"Handle circular references as explained in the class comment"
	lock ifTrue: [ ^ self ].
	
	lock := true.
	
	[ | oldValue |
	oldValue := value.
	value := anObject.
	self valueChanged: oldValue ]
		ensure: [ lock := false ]! !

!SpValueHolder methodsFor: 'transfert' stamp: ''!
transferSubscriptionsTo: aSpValueHolder
	aSpValueHolder subscriptions: subscriptions! !

!SpValueHolder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	lock := false.
	subscriptions := OrderedCollection new! !

!SpValueHolder methodsFor: 'accessing' stamp: ''!
rawValue: aValue
	value := aValue! !

!SpValueHolder methodsFor: 'subscription' stamp: ''!
unsubscribe: anObject 

	subscriptions := subscriptions reject: [ :each | each receiver = anObject ].! !

!SpValueHolder methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	
	aStream 
		nextPutAll: '[ '; 
		print: self value;
		nextPutAll: ' ]'! !

!SpValueHolder methodsFor: 'accessing' stamp: ''!
subscriptions: anObject
	subscriptions := anObject! !

!SpValueHolder methodsFor: 'enumerating' stamp: ''!
whenChangedDo: aBlock
	subscriptions add: aBlock! !

!SpValueHolder methodsFor: 'evaluating' stamp: ''!
value
	^ value! !

!SpValueHolder methodsFor: 'accessing' stamp: ''!
valueChanged
	self valueChanged: nil! !

!SpValueHolder methodsFor: 'accessing' stamp: ''!
valueChanged: oldValue
	subscriptions do: [ :block | block cull: self value cull: oldValue ]! !

!SpValueHolder methodsFor: 'accessing' stamp: ''!
subscriptions
	^ subscriptions! !

!SpValueHolder class methodsFor: 'instance creation' stamp: ''!
value: contents

	^ self new
		rawValue: contents;
		yourself! !

!SpValueHolder class methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!SpValueSubscription commentStamp: ''!
I'm a value holder subscription. 
I keep an action and I can be able to execute it.

My purpose is to give entity to the change action, so users can operate over the actions (for example unsubscribing them)!
!SpValueSubscription methodsFor: 'accessing' stamp: ''!
action: aBlock

	action := aBlock! !

!SpValueSubscription methodsFor: 'accessing' stamp: ''!
action

	^ action! !

!SpValueSubscription methodsFor: 'evaluating' stamp: ''!
cull: newValue cull: oldValue

	action 
		cull: newValue 
		cull: oldValue! !

!SpValueSubscription class methodsFor: 'instance creation' stamp: ''!
with: aBlock

	^ self new 
		action: aBlock;
		yourself! !

!SpValueSubscription class methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!SpVersatileDialogPresenter commentStamp: ''!
A am versatile presenter for modal dialog windows with the customizable content

I have:
- title
- main message      - the basic text of the dialog 
- main icon         - the icon that is displayed next to the main message 
                      or next to the content area, if any 
- content area      - a text or another presenter with the detailed information of the dialog 
- buttons           - added using addButton:text:value
- more options text - a label of the button that shows more options of the dialog
- less options text - a label of the button that shows more options of the dialog in case
                      that the options are visible
- footnote icon     - an icon that is displayed next to the footnote 
- footnote area     - a text or another presenter with the footnote
!
!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName ifAbsent: aBlock
	^ self basicPresenters
		at: aName
		ifAbsent: [ [ self readSlotNamed: aName ]
				on: SlotNotFound
				do: aBlock ]! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
footnoteIcon

	^ footnoteIcon! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
contentArea

	^ contentArea! !

!SpVersatileDialogPresenter methodsFor: 'api' stamp: ''!
addButton: id text: buttonText value: anObject

	^ self addButton: id text: buttonText value: anObject condition: true! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
contentArea: aTextOrPresenter

	contentArea := aTextOrPresenter.! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
moreOptionsArea

	^ moreOptionsArea! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
mainMessage

	^ mainMessage! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName put: aPresenter

	^ self basicPresenters 
		at: aName 
		put: aPresenter! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
result

	^ result! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
result: anObject

	result := anObject! !

!SpVersatileDialogPresenter methodsFor: 'api' stamp: ''!
buttonAt: id

	^ buttons at: id! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
footnoteIcon: aForm

	footnoteIcon := aForm.! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
buttons

	^ buttons! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
mainIcon: aFrom

	mainIcon := aFrom! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
mainIconPresenter
	^ mainIconPresenter! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
moreOptionsText

	^ moreOptionsText! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
lessOptionsText

	^ lessOptionsText! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
defaultButtonId: anObject
	defaultButtonId := anObject! !

!SpVersatileDialogPresenter methodsFor: 'private' stamp: ''!
return: anObject

	self result: anObject.
	self window close.! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
layout
	| mainLayout row |
	mainLayout := SpBoxLayout newTopToBottom.


	"if the content area is not defined, place main message next to the main icon"
	contentArea
		ifNotNil: [ mainMessage
				ifNotNil: [ mainMessagePresenter := (mainMessage isString or: [ mainMessage isText ]) ifTrue: [ self newLabel label: mainMessage ] ifFalse: [ mainMessage ].
					mainLayout add: #mainMessagePresenter ] ].

	row := SpBoxLayout newLeftToRight.

	mainIcon
		ifNotNil: [ mainIconPresenter := self newImage image: self mainIcon.
			row add: #mainIconPresenter withConstraints: [ :constraints | constraints width: self mainIcon width * 2 ] ].

	contentArea
		ifNotNil: [ contentAreaPresenter := (contentArea isString or: [ contentArea isText ]) ifTrue: [ self newLabel label: contentArea ] ifFalse: [ contentArea ].
			row add: #contentAreaPresenter ]
		ifNil: [ mainMessage
				ifNotNil: [ mainMessagePresenter := (mainMessage isString or: [ mainMessage isText ]) ifTrue: [ self newLabel label: mainMessage ] ifFalse: [ mainMessage ].
					row add: #mainMessagePresenter ] ].

	mainLayout add: row.

	row := SpBoxLayout newLeftToRight.


	moreOptionsArea
		ifNotNil: [ moreOptionsButton label: (moreOptionsVisible ifFalse: [ self moreOptionsText ] ifTrue: [ self lessOptionsText ]).
			moreOptionsButton icon: (self iconNamed: (moreOptionsVisible ifFalse: [ #arrowDown ] ifTrue: [ #arrowUp ])).

			row add: #moreOptionsButton.
			moreOptionsAreaPresenter := (moreOptionsArea isString or: [ moreOptionsArea isText ]) ifTrue: [ self newLabel label: moreOptionsArea ] ifFalse: [ moreOptionsArea ] ].
	buttons keysAndValuesDo: [ :buttonKey :aButton | row add: buttonKey ].

	mainLayout add: row.

	moreOptionsVisible ifTrue: [ mainLayout add: #moreOptionsAreaPresenter ].

	footnoteArea
		ifNotNil: [ row := SpBoxLayout newLeftToRight.
			footnoteIcon
				ifNotNil: [ footnoteIconPresenter := self newImage image: footnoteIcon.
					row add: #footnoteIconPresenter withConstraints: [ :constraints | constraints width: self footnoteIcon width * 2 ] ].

			footnoteAreaPresenter := (footnoteArea isString or: [ footnoteArea isText ]) ifTrue: [ self newLabel label: footnoteArea ] ifFalse: [ footnoteArea ].
			row add: #footnoteAreaPresenter ].
	mainLayout add: row.

	defaultButtonId ifNotNil: [ (self buttonAt: defaultButtonId) takeKeyboardFocus ].

	^ mainLayout! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
moreOptionsButton
	^ moreOptionsButton! !

!SpVersatileDialogPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	moreOptionsVisible := false.
	buttons := OrderedDictionary new! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
footnoteArea

	^ footnoteArea! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
presenters

	^ self basicPresenters values! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
moreOptionsArea: aTextOrPresenter

	moreOptionsArea := aTextOrPresenter.! !

!SpVersatileDialogPresenter methodsFor: 'enumerating' stamp: ''!
presentersDo: aBlock

	self basicPresenters valuesDo: aBlock! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
contentAreaPresenter
	^ contentAreaPresenter! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
presenterAt: aName

	^ self basicPresenters 
		at: aName 
		ifAbsent: [ self readSlotNamed: aName  ]! !

!SpVersatileDialogPresenter methodsFor: 'private - accessing' stamp: ''!
basicPresenters

	^ presenters ifNil: [ presenters := OrderedDictionary new ]! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
defaultButtonId
	^ defaultButtonId! !

!SpVersatileDialogPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter
	aDialogWindowPresenter initialExtent: 400 @ 200! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
lessOptionsText: aText

	lessOptionsText := aText.! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
moreOptionsText: aText

	moreOptionsText := aText.! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
mainMessage: aTextOrPresenter

	mainMessage := aTextOrPresenter.! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
mainIcon

	^ mainIcon! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
footnoteArea: aTextOrPresenter

	footnoteArea := aTextOrPresenter.! !

!SpVersatileDialogPresenter methodsFor: 'accessing' stamp: ''!
mainMessagePresenter
	^ mainMessagePresenter! !

!SpVersatileDialogPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters 

	moreOptionsText := 'More options' asText.
	lessOptionsText := 'Less options' asText.
	moreOptionsButton := self newButton label: moreOptionsText.
	! !

!SpVersatileDialogPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters 

	super connectPresenters.
	
	moreOptionsButton action: [ 
		moreOptionsVisible := moreOptionsVisible not.
		self needRebuild: false.
		self buildWithSpec ].
	
! !

!SpVersatileDialogPresenter methodsFor: 'api' stamp: ''!
addButton: id text: buttonText value: anObject condition: aCondition
	| aButton |
	aButton := self newButton label: buttonText.
	aButton action: [ aCondition value ifTrue: [ self return: anObject ] ].

	buttons at: id put: aButton.

	self presenterAt: id put: aButton! !

!SpVersatileDialogPresenter class methodsFor: 'specs' stamp: ''!
example1
	<example>
	| dialog |
	(dialog := SpVersatileDialogPresenter new)
		mainMessage: 'Confirm your choice' asText allBold;
		mainIcon: (self iconNamed: #question);
		contentArea: 'Do you want to discard your content?';
		moreOptionsArea: (dialog newCheckBox label: 'Discard permanently');
		addButton: #yes text: 'yes' value: #yes;
		addButton: #no text: 'no' value: #no;
		addButton: #cancel text: 'cancel' value: #cancel;
		footnoteIcon: (self iconNamed: #error);
		footnoteArea: 'This operation can be very dangerous.';
		openModalWithSpec.
	dialog withWindowDo: [ :w | w title: 'Confirmation' ].
	dialog result traceCr.

	self inform: dialog moreOptionsArea state asString! !

!SpVersatileDialogPresenter class methodsFor: 'specs' stamp: ''!
example4
	<example>
	| dialog |
	dialog := SpVersatileDialogPresenter new.

	1 to: 5 do: [ :aNumber | dialog addButton: ('button' , aNumber asString) asSymbol text: aNumber printStringRoman value: aNumber ].

	dialog defaultButtonId: #button2.

	dialog openModalWithSpec.

	dialog withWindowDo: [ :w | w title: 'Select number' ].
	dialog result traceCr! !

!SpVersatileDialogPresenter class methodsFor: 'specs' stamp: ''!
example3
	<example>
	| dialog |
	dialog := SpVersatileDialogPresenter new
		mainMessage: 'Save content' asText allBold;
		addButton: #save text: 'Save' value: true;
		addButton: #cancel text: 'Cancel' value: false;
		mainIcon: (self iconNamed: #question);
		footnoteIcon: (self iconNamed: #error);
		footnoteArea: 'Saving may take several minutes';
		yourself.

	(dialog buttonAt: #save) icon: (self iconNamed: #smallSave).

	dialog openModalWithSpec.

	dialog withWindowDo: [ :w | w title: 'Confirmation' ].
	dialog result traceCr! !

!SpVersatileDialogPresenter class methodsFor: 'specs' stamp: ''!
example2
	<example>
	| dialog |
	dialog := SpVersatileDialogPresenter new
		mainMessage: 'Save content' asText allBold;
		addButton: #save text: 'Save' value: true;
		addButton: #cancel text: 'Cancel' value: false;
		mainIcon: (self iconNamed: #question);
		openModalWithSpec;
		yourself.

	dialog withWindowDo: [ :w | w title: 'Confirmation' ].
	dialog result traceCr! !

!SpVersatileDialogPresenter class methodsFor: 'testing' stamp: ''!
isDeprecated

	^ true! !

!SpVersatileDialogPresenter class methodsFor: 'specs' stamp: ''!
example5
	<example>
	| dialog listPresenter |
	dialog := SpVersatileDialogPresenter new.
	listPresenter := dialog newList.
	listPresenter items: #(one two three).
	dialog contentArea: listPresenter.
	dialog
		addButton: #ok
		text: 'OK'
		value: true
		condition: [ listPresenter selection isEmpty not ].
	dialog addButton: #cancel text: 'Cancel' value: false.
	dialog mainIcon: (self iconNamed: #question).

	dialog openModalWithSpec.

	dialog withWindowDo: [ :w | w title: 'Confirmation' ].
	dialog result traceCr! !

!SpVersatileDialogPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest
	^ SpVersatileDialogPresenter! !

!SpVersatileDialogPresenterTest methodsFor: 'tests' stamp: ''!
testListBox
	| dialog app listPresenter |
	app := SpMockApplication new.

	dialog := SpVersatileDialogPresenter newApplication: app.
	listPresenter := dialog newList.
	listPresenter items: #(one two three).
	dialog contentArea: listPresenter.
	dialog
		addButton: #ok
		text: 'OK'
		value: #ok
		condition: [ listPresenter selection isEmpty not ].
	dialog addButton: #cancel text: 'Cancel' value: nil.
	dialog mainIcon: (self iconNamed: #question).

	dialog openModalWithSpec.
	dialog withWindowDo: [ :w | w title: 'Confirmation' ].

	dialog contentArea selection selectIndex: 2.

	(dialog buttons at: #ok) click.

	self assert: dialog result equals: #ok.
	self assert: dialog contentArea selection selectedItem equals: #two! !

!SpVersatileDialogPresenterTest methodsFor: 'tests' stamp: ''!
testResult 

	| dialog app |
	
	app := SpMockApplication new.
	
	dialog := SpVersatileDialogPresenter newApplication: app.
	dialog mainMessage: 'Save content' asText allBold.
	dialog addButton: #save text: 'Save' value: true.
	dialog addButton: #cancel text: 'Cancel' value: false.
	dialog mainIcon: (self iconNamed: #question).
	dialog moreOptionsArea: (dialog newCheckBox label: 'Save header').

	dialog openModalWithSpec. 
	dialog withWindowDo: [ :w | w title: 'Confirmation' ].
	(dialog buttons at: #save) performAction.
	dialog moreOptionsArea click.

	self assert: dialog result.	
	self assert: dialog moreOptionsArea state.! !

!SpVerticalAlignment commentStamp: ''!
I represent the vertical scrolling of a presenter.
You can ask the first and last index of the visible rows.
I can move the scrolling to make an element visible with the #desiredVisibleRow: method.!
!SpVerticalAlignment methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!SpVerticalAlignment methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!SpVerticalAlignment methodsFor: 'accessing' stamp: ''!
firstVisibleRowIndex: anInteger
	firstVisibleRowIndex := anInteger! !

!SpVerticalAlignment methodsFor: 'initialization' stamp: ''!
initialize
	self class initializeSlots: self.
	super initialize.
	desiredVisibleRow := 1! !

!SpVerticalAlignment methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!SpVerticalAlignment methodsFor: 'accessing' stamp: ''!
desiredVisibleRow: anInteger
	desiredVisibleRow := anInteger! !

!SpVerticalAlignment methodsFor: 'accessing' stamp: ''!
firstVisibleRowIndex
	"valid only after UI is open"

	^ firstVisibleRowIndex! !

!SpVerticalAlignment methodsFor: 'accessing' stamp: ''!
desiredVisibleRow
	^ desiredVisibleRow! !

!SpVerticalAlignment methodsFor: 'initialization' stamp: ''!
whenChangedDo: aBlockClosure
	self property: #desiredVisibleRow whenChangedDo: aBlockClosure! !

!SpVerticalAlignment methodsFor: 'initialization' stamp: ''!
lastVisibleRowIndex
	^ lastVisibleRowIndex! !

!SpVerticalAlignment methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!SpVerticalAlignment methodsFor: 'initialization' stamp: ''!
lastVisibleRowIndex: anInteger
	lastVisibleRowIndex := anInteger! !

!SpVerticalAlignment class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SpVerticalAlignment class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SpVerticalAlignment class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SpVerticalAlignment class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SpVerticalAlignment class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SpVerticalAlignment class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SpVerticalAlignment class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SpVerticalAlignment class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SpVerticalAlignment class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpVerticalAlignment class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SpVerticalAlignment class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SpVerticalAlignment class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SpVerticalAlignment class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SpVerticalAlignment class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SpVerticalAlignment class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SpVerticalAlignment class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SpVerticalAlignment class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SpVerticalAlignment class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SpVerticalAlignment class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SpVerticalAlignment class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SpVerticalAlignment class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SpVerticalAlignment class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SpVerticalAlignment class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SpVerticalAlignment class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SpVerticalAlignment class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SpVerticalAlignment class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SpVerticalAlignment class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SpVerticalAlignment class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SpVerticalAlignment class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SpVerticalBoxLayoutAdapterTest methodsFor: 'accessing' stamp: ''!
newLayout

	^ SpBoxLayout newTopToBottom! !

!SpVerticalBoxLayoutTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	layout := SpBoxLayout newTopToBottom.
	presenter layout: layout! !

!SpVerticalBoxLayoutTest methodsFor: 'tests' stamp: ''!
testReplaceWithFixedHeightComposed
	| p1 layoutToReplace toReplace p3 replacement |

	layout add: (p1 := SpLabelPresenter new) width: 100.
	layout add: ((layoutToReplace := SpBoxLayout newTopToBottom)  
		add: (toReplace := SpLabelPresenter new) height: 100;
		add: (SpLabelPresenter new) height: 100;
		yourself).
	layout add: (p3 := SpLabelPresenter new) width: 100.
	
	replacement := SpButtonPresenter new.
	layoutToReplace 
		replace: toReplace 
		with: replacement.
	
	self assert: layout children second children first equals: replacement! !

!SpVerticalBoxLayoutTest methodsFor: 'tests' stamp: ''!
testPresenterExtentFollowsChildrenExtent
	| label button |

	layout 
		add: ((label := presenter newLabel) label: 'Label1');
		add: ((button := presenter newButton) label: 'Button1').
		
	self openInstance.
	
	self assert: (self widthOf: presenter) >= ((self widthOf: label) max: (self widthOf: button)).
	self assert: (self heightOf: presenter) >= ((self heightOf: label) + (self heightOf: button))! !

!SpVerticalBoxLayoutTest methodsFor: 'tests' stamp: ''!
testReplaceWithFixedHeight
	| p1 toReplace p3 replacement |

	layout add: (p1 := SpLabelPresenter new).
	layout add: (toReplace := SpLabelPresenter new) height: 100.
	layout add: (p3 := SpLabelPresenter new).
	
	self assert: layout children second equals: toReplace.
	
	replacement := SpButtonPresenter new.
	layout replace: toReplace with: replacement.
	
	self assert: layout children second equals: replacement.
	self assert: layout children size equals: 3.
	self assert: layout children equals: { p1. replacement. p3 }! !

!SpVerticalBoxLayoutTest methodsFor: 'tests' stamp: ''!
testReplaceWithFixedHeightAllFixed
	| p1 toReplace p3 replacement |

	layout add: (p1 := SpLabelPresenter new) height: 100.
	layout add: (toReplace := SpLabelPresenter new) height: 100.
	layout add: (p3 := SpLabelPresenter new) height: 100.
	
	self assert: layout children second equals: toReplace.
	
	replacement := SpButtonPresenter new.
	layout replace: toReplace with: replacement.
	
	self assert: layout children second equals: replacement.
	self assert: layout children size equals: 3.
	self assert: layout children equals: { p1. replacement. p3 }! !

!SpVerticalLayoutDirection methodsFor: 'factory' stamp: ''!
newWidgetOn: anAdapter

	^ anAdapter newVertical! !

!SpVerticalLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
recalculatePages: anAdaptor

	^ anAdaptor recalculatePageHeights! !

!SpVerticalLayoutDirection methodsFor: 'testing' stamp: ''!
isVertical

	^ true! !

!SpVerticalLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
addPadding: aNumber toMorph: aMorph into: anAdapter

	^ anAdapter 
		addVerticalPadding: aNumber 
		toMorph: aMorph! !

!SpVerticalLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
applyHomogeneousLayoutOn: aLayout to: aMorph in: aRect

	aLayout applyVerticalHomogeneousLayout: aMorph in: aRect! !

!SpVerticalLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
newSplitter
	^ SpPanedResizerMorph newVertical! !

!SpVerticalLayoutDirection methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
setRigidityOfNonExpandedMorph: aMorph

	aMorph 
		hResizing: #spaceFill; 
		vResizing: #rigid! !

!SpVerticalPanedLayoutAdapterTest methodsFor: 'accessing' stamp: ''!
newLayout
	
	^ SpPanedLayout newTopToBottom! !

!SpVerticalPanedLayoutTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	layout := SpPanedLayout newTopToBottom.
	presenter layout: layout! !

!SpWeakValueHolder commentStamp: ''!
I'm a weak value holder. 
I keep a weak reference to the instance in contents.!
!SpWeakValueHolder methodsFor: 'accessing' stamp: ''!
contents
	^ self basicAt: 1! !

!SpWeakValueHolder methodsFor: 'accessing' stamp: ''!
contents: anObject
	self basicAt: 1 put: anObject! !

!SpWeakValueHolder class methodsFor: 'instance creation' stamp: ''!
new
	^ (self basicNew: 1) initialize! !

!SpWeakValueHolder class methodsFor: 'instance creation' stamp: ''!
contents: anObject
	^ self new contents: anObject! !

!SpWidgetBuilt commentStamp: ''!
I am an announcement raised when a widget has been built with all its children, but not yet shown.!
!SpWidgetBuilt methodsFor: 'accessing' stamp: ''!
widget: anObject
	widget := anObject! !

!SpWidgetBuilt methodsFor: 'accessing' stamp: ''!
widget
	^ widget! !

!SpWidgetBuilt methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!SpWidgetBuilt methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!SpWidgetBuilt class methodsFor: 'instance creation' stamp: ''!
model: model widget: widget

	^ self new
		model: model;
		widget: widget;
		yourself! !

!SpWidgetDisplayed commentStamp: ''!
I am an announcement raised when a widget has been already shown in the screen.!
!SpWidgetDisplayed methodsFor: 'accessing' stamp: ''!
widget: anObject
	widget := anObject! !

!SpWidgetDisplayed methodsFor: 'accessing' stamp: ''!
widget
	^ widget! !

!SpWidgetDisplayed methodsFor: 'accessing' stamp: ''!
presenter: anObject
	presenter := anObject! !

!SpWidgetDisplayed methodsFor: 'accessing' stamp: ''!
presenter
	^ presenter! !

!SpWidgetWillBeBuilt commentStamp: ''!
I am an announcement  raised when a widget will be built. 

I may be used in situations when you need to change the content of the context menu before it will be displayed and so on.!
!SpWidgetWillBeBuilt methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!SpWidgetWillBeBuilt methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!SpWidgetWillBeBuilt class methodsFor: 'instance creation' stamp: ''!
model: model

	^ self new
		model: model;
		yourself! !

!SpWindow commentStamp: ''!
I am a window used by WindowSpec.

I have been introduced since it's currently the best solution to prevent to add dozen of respondsTo: in StandardWindow or add dirty extensions to Object (because all models are not subclasses of Model)!
!SpWindow methodsFor: 'open/close' stamp: ''!
deleteDiscardingChanges

	self announceWillClose.
	^ super deleteDiscardingChanges! !

!SpWindow methodsFor: 'private' stamp: ''!
announceWillClose
	| announcement |

	announcement := SpWindowWillClose new
		window: self;
		yourself.
	self announce: announcement.
	self currentWorld announcer announce: announcement! !

!SpWindow methodsFor: 'updating' stamp: ''!
okToChange

	^ self model okToChange! !

!SpWindow methodsFor: 'open/close' stamp: ''!
close 

	self announceWillClose.
	super close.! !

!SpWindow methodsFor: 'protocol' stamp: ''!
aboutText

	^ self model aboutText! !

!SpWindow methodsFor: 'closing' stamp: ''!
allowedToClose

	super allowedToClose ifFalse: [ ^ false ].
	^ self model askOkToClose 
		ifTrue: [ self model requestWindowClose ]
		ifFalse: [ true ].! !

!SpWindow methodsFor: 'testing' stamp: ''!
hasWidget: aMorph 
	
	^ self allMorphs includes: aMorph! !

!SpWindow methodsFor: 'open/close' stamp: ''!
extent: aPoint 
	| announcement oldExtent |

	oldExtent := self extent. 
	super extent: aPoint.
	announcement := SpWindowResizing new
		window: self;
		oldSize: oldExtent;
		newSize: aPoint;
		yourself.
	self announce: announcement.
	self currentWorld announcer announce: announcement! !

!SpWindowAnnouncement methodsFor: 'accessing' stamp: ''!
window
	^ window! !

!SpWindowAnnouncement methodsFor: 'accessing' stamp: ''!
window: anObject
	window := anObject! !

!SpWindowBuilt commentStamp: ''!
I am an announcement raised when a window has been built.!
!SpWindowBuilt methodsFor: 'accessing' stamp: ''!
model: aModel

	model := aModel! !

!SpWindowBuilt methodsFor: 'accessing' stamp: ''!
model 

	^ model! !

!SpWindowBuilt class methodsFor: 'instance creation' stamp: ''!
model: aWindowPresenter

	^ self new 
		model: aWindowPresenter;
		yourself! !

!SpWindowPresenter commentStamp: ''!
I'm a presenter defining a Window.
`SpWindowPresenter` defines common behavior for windows (such as title, extent, position). 
It can also hold a menuBar, a toolBar, and a statusBar.

Typically you do not use this presenter directly but through a presenter you want to show. 
When you execute `aPresenter openWithSpec`, what happens is that a `SpWindowPresenter` is created. Then the `SpPresenter>>#initializeWindow:` message is sent and an user can configure its window there.

You can also access your window when your presenter is active by using `SpAbstractPresenter>>#withWindowDo:`.

## Usage 

Typically, you do not instantiate directly a window, but you open a presenter as one.

```
SpTextPresenter new
	text: 'The answer is 42';
	openWithSpec.
```
!
!SpWindowPresenter methodsFor: 'private' stamp: ''!
defaultInitialExtent
	
	^ 400@300! !

!SpWindowPresenter methodsFor: 'TOREMOVE' stamp: ''!
askOkToClose

	^ askOkToClose! !

!SpWindowPresenter methodsFor: 'private - building' stamp: ''!
buildWindowWithLayout: windowSpecLayout presenterLayout: presenterSpecLayout

	"set adapter of the window"
	self adapter: (windowSpecLayout asSpLayout
		buildAdapterFor: self 
		bindings: SpBindings value).
	self window: self adapter widget.
	self processDeferredActions.
	"add presenter"
	self addPresenterIn: self window withSpecLayout: presenterSpecLayout.
	"announce its result"
	self announce: (SpWidgetBuilt model: self widget: self window).
	self presenter announce: (SpWindowBuilt model: self).	
	
	^ self window! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
initialPosition
	"Answer initial position of the window (if previously set).
	 If initial position is not set, the backend will place the window within its own logic."

	^ initialPosition! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
menu: aMenuBarPresenter
	"Set a menu bar associated with this window.
	 Menu will appear on top of the window allowing user to interact with it."
	
	aMenuBarPresenter ifNotNil: [ aMenuBarPresenter owner: self ].
	^ menu := aMenuBarPresenter! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isDialog
	"Answer if window instance is a dialog"

	^ false! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isMinimized
	"Answer if window is minimized"

	self withAdapterDo: [ :anAdapter | ^ anAdapter isMinimized ].
	^ false! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
minimize
	"Minimize the window."
	
	self withAdapterDo: [ :anAdapter | anAdapter minimize ]! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
window: aWindow
	window := aWindow! !

!SpWindowPresenter methodsFor: 'updating' stamp: ''!
windowIsOpened

	isClosed := false! !

!SpWindowPresenter methodsFor: 'dialog compatibility' stamp: ''!
triggerCancelAction
	"Do nothing (ensure polymorphism with DialogWindow)"! !

!SpWindowPresenter methodsFor: 'api - events' stamp: ''!
whenClosedDo: aBlock
	"Inform when window is closed.
	 `aBlock` receives zero arguments."
	
	self 
		property: #isClosed 
		whenChangedDo: [ :value | value ifTrue: aBlock ]! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
centeredRelativeToTopWindow
	"Prepare the window to be centered to top window (the window that is currently active)"

	self application topWindow
		ifNotNil: [ :aWindow | self centeredRelativeTo: aWindow ]
		ifNil: [ self centered ]! !

!SpWindowPresenter methodsFor: 'TOREMOVE' stamp: ''!
askOkToClose: aBoolean

	askOkToClose := aBoolean! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
okToChange

	self flag: #TODO. "Maybe wrong?"
	self presenter canDiscardEdits ifTrue: [ ^ true ].
	"Solicit cancel from view"
	self changed: #wantToChange.  
	^ self canDiscardEdits! !

!SpWindowPresenter methodsFor: 'api - events' stamp: ''!
whenResizingDo: aBlock
	"Inform when window is resizing. 
	 `aBlock` receives one optional argument (an instance of the announcement `SpWindowResizing`)"
	
	self announcer 
		when: SpWindowResizing
		do: aBlock! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isTopWindow
	"Answer true if this si the active window (the one that has the focus)"
	
	self withAdapterDo: [ :anAdapter | 
		^ anAdapter isTopWindow ].

	^ false! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isMaximized
	"Answer if window is maximized"

	self withAdapterDo: [ :anAdapter | ^ anAdapter isMaximized ].
	^ false! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
windowIcon
	^ windowIcon! !

!SpWindowPresenter methodsFor: 'dialog compatibility' stamp: ''!
triggerOkAction
	"Do nothing (ensure polymorphism with DialogWindow)"! !

!SpWindowPresenter methodsFor: 'private - traversing' stamp: ''!
traverseInFocusOrderDo: aBlock excluding: excludes

	"I am not focusable (not with tab)"
	self presenter 
		traverseInFocusOrderDo: aBlock 
		excluding: excludes! !

!SpWindowPresenter methodsFor: 'api - events' stamp: ''!
whenFocusReceivedDo: aBlock
	"Inform when window receives focus. 
	 This is a convenience method that exposes a functionality of the event handler 
	 (See `SpEventHandler>>#whenFocusReceivedDo:`, but in the case of windows is 
	 useful to have it here."

	self eventHandler whenFocusReceivedDo: aBlock! !

!SpWindowPresenter methodsFor: 'TOREMOVE' stamp: ''!
taskbarIcon
	^ self windowIcon
		ifNil: [
			self presenter
				ifNil: [ super taskbarIcon ]
				ifNotNil: #taskbarIcon ]! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isCentered
	"Answer if window is centered to screen."

	^ centered! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
hasMenu 
	"Answer if window has a menu defined"
	
	^ self menu notNil! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
delete
	"DO NOT USE. This will destroy the window and maybe you do not want that :/
	 I'm keeping this here because of testing."

	self withAdapterDo: [ :anAdapter | anAdapter delete ]! !

!SpWindowPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow
		
	self presenter initializeWindow: self! !

!SpWindowPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	titleHolder := self class defaultTitle.
	isClosed := true.
	resizable := true.
	centered := false.
	askOkToClose := true.
	decorations := true.

	"presenter whenChangedDo: [ :m | self updateTitle ]."
	self 
		property: #titleHolder 
		whenChangedDo: [ :aString | 
			self withAdapterDo: [ :anAdapter | anAdapter title: aString ] ].
	self 
		property: #centered 
		whenChangedDo: [ :aBoolean | 
			self withAdapterDo: [ :anAdapter | anAdapter centered ] ]! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
initialExtent
	"Answer initial extent of the window. By default, it answer what is defined 
	 in `SpWindowPresenter>>#defaultInitialExtent`"

	^ initialExtent ifNil: [ self defaultInitialExtent ]! !

!SpWindowPresenter methodsFor: 'api - events' stamp: ''!
whenFocusLostDo: aBlock
	"Inform when window lost focus. 
	 This is a convenience method that exposes a functionality of the event handler 
	 (See `SpEventHandler>>#whenFocusLostDo:`, but in the case of windows is 
	 useful to have it here."

	self eventHandler whenFocusLostDo: aBlock! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
statusBar
	"Answer the status bar associated with this window (if defined)"

	^ statusbar! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
beep 
	"Emits a beep if the backend allows it."
	
	self adapter beep! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
window
	^ window! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isResizable
	"Answer if window is resizeable"

	^ resizable! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isResizeable
	"Answer if window is resizeable"
	
	self 
		deprecated: 'Use #isResizable instead'  
		transformWith: '`@receiver isResizeable' -> '`@receiver isResizable'.

	^ self isResizable! !

!SpWindowPresenter methodsFor: 'updating' stamp: ''!
windowIsClosing

	self presenter windowIsClosing! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
updateTitle
	"Update the window title"

	self changed: #title: with: { self title }! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
withoutDecorations
	"Remove decorations on window (header bar and buttons)"
	
	decorations := false! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
menu
	"Answer the menu of the window (if defined). 
	 See also `SpWindowPresenter>>#menu:`"

	^ menu! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
presenter
	"Answer the presenter to show as content of the window."

	^ presenter! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
presenter: aPresenter
	"Set the presenter to show as content of the window."

	aPresenter owner: self.
	presenter := aPresenter! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
resize: anExtent

	self withAdapterPerformOrDefer: [ :anAdapter | 
		anAdapter resize: anExtent ]! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
statusBar: aStatusBarPresenter
	"Set a status bar for the window. 
	 Status bar will be shown at the bottom of the window."

	aStatusBarPresenter ifNotNil: [ aStatusBarPresenter owner: self ].
	^ statusbar := aStatusBarPresenter! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
toolbar: aToolbarPresenter
	"Set a toolbar associated with this window.
	 Menu will appear on top of the window allowing user to interact with it."

	aToolbarPresenter ifNotNil: [ aToolbarPresenter owner: self ].
	^ toolbar := aToolbarPresenter! !

!SpWindowPresenter methodsFor: 'notifying' stamp: ''!
notify: aSpecNotification
	"Receives a notification and delivers it as required"

	self withAdapterDo: [ :anAdapter |
		aSpecNotification type 
			notify: aSpecNotification 
			on: anAdapter ]! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
hasPresenter: aPresenter
	"Answer if window includes `aPresenter`"

	^ aPresenter isNotNil and: [aPresenter adapter notNil
		and: [ self adapter hasWidget: aPresenter adapter ]]! !

!SpWindowPresenter methodsFor: 'TOREMOVE' stamp: ''!
aboutText: aString
	aboutText := aString! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
hasToolbar
	"Answer if window has a toolbar defined"

	^ self toolbar notNil and: [ self toolbar notEmpty ]! !

!SpWindowPresenter methodsFor: 'private - building' stamp: ''!
buildWithSpecLayout: aSpecLayout
	
	^ SpBindings 
		value: self application adapterBindings
		during: [ self basicBuildWithSpecLayout: aSpecLayout ]! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
beNotResizable
	"Make the window NOT resizable (borders will be undraggable). 
	 Window can still be resized progamatically."

	self resizable: false! !

!SpWindowPresenter methodsFor: 'TOREMOVE' stamp: ''!
aboutTitle
	"Answer the title of my About window"

	(self presenter respondsTo: #aboutTitle) ifTrue: [ ^ self presenter aboutTitle ].
	
	^ self presenter toolName! !

!SpWindowPresenter methodsFor: 'dialog compatibility' stamp: ''!
cancelled

	^ false! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
centeredRelativeTo: aWindowPresenter
	"Prepare the window to be centered to another window"

	self withAdapterPerformOrDefer: [ :anAdapter |
		anAdapter centeredRelativeTo: aWindowPresenter ]! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
windowIcon: aForm
	windowIcon := aForm! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isDisplayed
	"Answer if window is displayed (visible)"

	^ self adapter
		ifNotNil: [ :w | w isDisplayed ]
		ifNil: [ false ] ! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isWindowPresenter
	"Answer if current presenter instance is a window presenter"
	
	^ true! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isClosed
	"Answer if window has is closed"

	^ isClosed! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
resizable: aBoolean

	resizable := aBoolean! !

!SpWindowPresenter methodsFor: 'api - showing' stamp: ''!
open

	self openWith: self presenter retrieveDefaultSpec! !

!SpWindowPresenter methodsFor: 'api - events' stamp: ''!
whenWillCloseDo: aBlock
	"Inform when window will close, allowing process before the close happen. 
	 Note that user cannot cancel the close operation using this event. 
	 `aBlock` receives one optional argument (an instance of the announcement `SpWindowWillClose`)."
	
	self announcer 
		when: SpWindowWillClose
		do: aBlock! !

!SpWindowPresenter methodsFor: 'private - showing' stamp: ''!
openWithSpecLayout: aSpec

	self buildWithSpecLayout: aSpec.
	self application registerWindow: self.
	self withAdapterDo: [ :anAdapter | anAdapter open ].
	self allPresenters do: [ :each | each announceDisplayed ].
	self updateTitle! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
requestWindowClose

	^ self presenter
		ifNotNil: [ :aPresenter | aPresenter requestWindowClose ]
		ifNil: [ true ]! !

!SpWindowPresenter methodsFor: 'api - events' stamp: ''!
whenOpenedDo: aBlock
	"Inform when window is opened. 
	 `aBlock` receives zero arguments."

	self 
		property: #isClosed 
		whenChangedDo: [ :value | value ifFalse: aBlock ]! !

!SpWindowPresenter methodsFor: 'api - events' stamp: ''!
whenToolbarChangedDo: aBlock
	"Inform when the toolbar has been changed.
	
	 `aBlock` receives two optional arguments 
	 - new toolbar
	 - old toolbar"
	
	self property: #toolbar whenChangedDo: aBlock! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
initialPosition: aPoint
	"Set initial position of the window. 
	 `aPoint` is an instance of `Point`, indicating x@y coordinates"

	initialPosition := aPoint! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
beResizable
	"Make the window resizable (borders will be draggable)"

	self resizable: true! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
hasStatusBar
	"Answer if window has a status bar defined"
	
	^ self statusBar notNil! !

!SpWindowPresenter methodsFor: 'private - building' stamp: ''!
basicBuildWithSpecLayout: presenterSpecLayout
	"Build the widget using the spec name provided as argument"

	^(self spec isNil or: [ self needRebuild ])
		ifTrue: [ 
			self 
				buildWindowWithLayout: self retrieveDefaultSpec 
				presenterLayout: presenterSpecLayout ]
		ifFalse: [
			self adapter widget ]! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
close
	"Close current window."

	"Only manage closing if the presenter is really open"
	self isOpen ifFalse: [ ^ self ].
	self withAdapterDo: [ :anAdapter | 
		anAdapter close ]! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
isOpen
	"Answer if window is open."
	
	^ self isClosed not! !

!SpWindowPresenter methodsFor: 'api - events' stamp: ''!
whenDecorationsChangedDo: aBlock
	"Inform when decorations property has changed. 
	 `aBlock` has three optional arguments: 
	 - new value
	 - old value
	 - the announcement triggering this action"

	self property: #decorations whenChangedDo: aBlock! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
withDecorations
	"Add decorations on window (header bar and buttons)"
	
	decorations := true! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
title
	^ titleHolder! !

!SpWindowPresenter methodsFor: 'TOREMOVE' stamp: ''!
windowIsOpening

	self windowIsOpened! !

!SpWindowPresenter methodsFor: 'private - building' stamp: ''!
addPresenterIn: widget withSpecLayout: aSpec
	
	self presenter ifNil: [ ^ self ].
	self initializeWindow.
	self withAdapterDo: [ :anAdapter |
		anAdapter addPresenterIn: widget withSpecLayout: aSpec ]! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
windowClosed
	
	isClosed := true.
	self application windowClosed: self! !

!SpWindowPresenter methodsFor: 'private' stamp: ''!
title: aString
	titleHolder := aString! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
toolbar
	"Answer the toolbar associated with this window (if defined)"

	^ toolbar! !

!SpWindowPresenter methodsFor: 'api - events' stamp: ''!
whenResizableChangedDo: aBlock

	self property: #resizable whenChangedDo: aBlock! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
centered
	"Prepare the window to be centered"
	
	centered := true! !

!SpWindowPresenter methodsFor: 'api - showing' stamp: ''!
openWith: aSpecLayout

	self openWithSpecLayout: aSpecLayout! !

!SpWindowPresenter methodsFor: 'testing' stamp: ''!
hasDecorations
	"Answer if window has decorations (header bar and buttons)"

	^ decorations! !

!SpWindowPresenter methodsFor: 'private - traversing' stamp: ''!
traversePresentersDo: aBlock excluding: excludes
	
	super traversePresentersDo: aBlock excluding: excludes.
	presenter traversePresentersDo: aBlock excluding: excludes! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
initialExtent: anExtent
	"Set initial extent of the window. 
	 `anExtent` is an instance of `Point`, indicating width@height"

	initialExtent := anExtent! !

!SpWindowPresenter methodsFor: 'TOREMOVE' stamp: ''!
aboutText
	^ aboutText ifNil: [ aboutText := 'The about text for this window has not been set.' ]! !

!SpWindowPresenter methodsFor: 'private - building' stamp: ''!
rebuildWithSpecLayout: aSpec

	self withAdapterDo: [ :anAdapter | 
		anAdapter rebuildWithSpecLayout: aSpec ]! !

!SpWindowPresenter methodsFor: 'api' stamp: ''!
maximize
	"Maximise the window"

	self withAdapterDo: [ :anAdapter | anAdapter maximize ]! !

!SpWindowPresenter class methodsFor: 'testing' stamp: ''!
isWindow

	^ true! !

!SpWindowPresenter class methodsFor: 'accessing' stamp: ''!
defaultTitle

	^ 'Untitled window'! !

!SpWindowPresenter class methodsFor: 'instance creation' stamp: ''!
presenter: aPresenter
	^ (self application: aPresenter application)
		presenter: aPresenter;
		yourself! !

!SpWindowPresenter class methodsFor: 'instance creation' stamp: ''!
application: anApplication
	^ self new
		application: anApplication;
		yourself! !

!SpWindowPresenter class methodsFor: '*Spec2-Morphic-Backend-Tests' stamp: ''!
sampleInstanceForTest

	^ nil! !

!SpWindowPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #WindowAdapter! !

!SpWindowPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ SpWindowPresenter! !

!SpWindowPresenterTest methodsFor: 'tests' stamp: ''!
testResize
	
	self openInstance.

	self 
		deny: presenter adapter windowSize 
		equals: 600@600.
	presenter resize: 600@600.
	self 
		assert: presenter adapter windowSize
		equals: 600@600! !

!SpWindowPresenterTest methodsFor: 'initialization' stamp: ''!
initializeTestedInstance

	presenter presenter: SpLabelPresenter new! !

!SpWindowPresenterTest methodsFor: 'tests' stamp: ''!
testWhenClosedDo
	| closed |
	closed := false.
	presenter whenClosedDo: [ closed := true ].
	self openInstance.
	presenter close.
	self assert: closed! !

!SpWindowPresenterTest methodsFor: 'tests' stamp: ''!
testWhenOpenedDo
	| opened |
	opened := false.
	presenter whenOpenedDo: [ opened := true ].
	self openInstance.
	self assert: opened! !

!SpWindowPresenterTest methodsFor: 'tests' stamp: ''!
testInitialPosition
	presenter initialPosition: 100 @ 100.
	self openInstance.
	self assert: window adapter widget position equals: 100 @ 100! !

!SpWindowPresenterTest methodsFor: 'tests' stamp: ''!
testIsTopWindow

	self deny: presenter isTopWindow.
	self openInstance.
	presenter takeKeyboardFocus.
	self assert: presenter isTopWindow.
	presenter close.
	self deny: presenter isTopWindow! !

!SpWindowPresenterTest methodsFor: 'tests' stamp: ''!
testIsClosed
	self assert: presenter isClosed.
	self openInstance.
	self deny: presenter isClosed.
	presenter close.
	self assert: presenter isClosed! !

!SpWindowPresenterTest methodsFor: 'utilities' stamp: ''!
openInstance
	window ifNil: [ window := presenter openWithSpecLayout: SpLabelPresenter defaultSpec ]! !

!SpWindowPresenterTest methodsFor: 'tests' stamp: ''!
testBeNotResizeable
	
	self openInstance.

	self assert: presenter adapter windowIsResizable.
	presenter beNotResizable.
	self deny: presenter adapter windowIsResizable.
! !

!SpWindowPresenterTest methodsFor: 'tests' stamp: ''!
testRebuildPresenterDoNotLetReferencesInAnnouncer
	| oldSize newSize |
	
	presenter buildWithSpecLayout: SpLabelPresenter defaultSpec.
	oldSize := presenter announcer subscriptions subscriptions size.
	"rebuild"
	presenter rebuildWithSpecLayout: SpLabelPresenter defaultSpec.
	newSize := presenter announcer subscriptions subscriptions size.
	
	self assert: oldSize equals: newSize! !

!SpWindowPresenterTest methodsFor: 'tests' stamp: ''!
testWhenWillCloseDo
	| willClose closed |

	willClose := false.
	closed := false.
	presenter whenWillCloseDo: [ willClose := true ].
	presenter whenClosedDo: [ closed := willClose ].
	self openInstance.
	presenter close.
	self assert: willClose.
	self assert: closed! !

!SpWindowResizing commentStamp: ''!
I am an announcement emitted when a window is resized.
Collapsing and expanding a window changes the size and therefore it may 
trigger this announcement.

I provide the old and new window size.!
!SpWindowResizing methodsFor: 'testing' stamp: ''!
newSize
	^ newSize! !

!SpWindowResizing methodsFor: 'testing' stamp: ''!
isResized
	^ true! !

!SpWindowResizing methodsFor: 'testing' stamp: ''!
oldSize: anObject
	oldSize := anObject! !

!SpWindowResizing methodsFor: 'testing' stamp: ''!
newSize: anObject
	newSize := anObject! !

!SpWindowResizing methodsFor: 'testing' stamp: ''!
oldSize
	^ oldSize! !

!SpWindowTest commentStamp: ''!
SUnit tests for SpecWindow!
!SpWindowTest methodsFor: 'tests' stamp: ''!
testTitle
	| presenter window |
	windowPresenter := SpTextPresenter new openWithSpec.

	self assert: windowPresenter isDisplayed.
	self assert: windowPresenter title equals: 'Text'.
	windowPresenter close.

	presenter := SpTextPresenter new.
	[ window := presenter openWithSpec.
	presenter withWindowDo: [ :w | w title: 'Test Window' ].
	self assert: presenter window title equals: 'Test Window' ]
		ensure: [ window ifNotNil: #delete ]! !

!SpWindowTest methodsFor: 'tests' stamp: ''!
testCloseWindowRemovesItFromApplicationWindowCollection
	| application |
	application := SpApplication new.
	windowPresenter := (application newPresenter: SpButtonPresenter) openWithSpec.
	windowPresenter window close.
	self deny: (application windows includes: windowPresenter).
	self assert: application windows isEmpty.! !

!SpWindowTest methodsFor: 'tests' stamp: ''!
testAboutText
	| presenter window |
	windowPresenter := SpWindowPresenter new.
	windowPresenter aboutText: 'test'.
	self assert: windowPresenter aboutText equals: 'test'.
	windowPresenter close.

	presenter := SpTextPresenter new.
	[ window := presenter openWithSpec.
	presenter withWindowDo: [ :w | w aboutText: 'test2' ].
	self assert: presenter window aboutText equals: 'test2' ]
		ensure: [ window ifNotNil: #delete ]! !

!SpWindowTest methodsFor: 'tests' stamp: ''!
testIsDisplayed
	"Test for case: 16800 -> ask a SpecWindow for #isDisplayed always returns true"
	
	windowPresenter := SpTextPresenter new openWithSpec.
	self assert: (windowPresenter isDisplayed).
	
	windowPresenter window minimize.	
	self assert: (windowPresenter isDisplayed).
		
	windowPresenter window close.
	self assert: (windowPresenter isDisplayed not).

	! !

!SpWindowWillClose commentStamp: ''!
I am an announcement emitted when a window will be closed.!
!SpWorldPresenter commentStamp: ''!
I am a model representing Pharo World.

This way, every spec application can be opened as the Pharo system window as window, to simulate native a application.!
!SpWorldPresenter methodsFor: 'private' stamp: ''!
defaultInitialExtent
	
	^ self currentWorld extent! !

!SpWorldPresenter methodsFor: 'api' stamp: ''!
isDisplayed

	^ true! !

!SpWorldPresenter methodsFor: 'private' stamp: ''!
addPresenterIn: container withSpecLayout: aSpec

	self presenter ifNil: [ ^ self ].
	self presenter initializeWindow: self.
	self 
		changed: #addPresenterIn:withSpecLayout:
		with: { container. aSpec }! !

!SpWorldPresenter methodsFor: 'private - showing' stamp: ''!
openWithSpecLayout: aSpec

	self buildWithSpecLayout: aSpec.
	self updateTitle! !

!SpWorldPresenter methodsFor: 'api' stamp: ''!
widget

	^ widget ! !

!SpWorldPresenter methodsFor: 'private' stamp: ''!
updateTitle
	"Update the window title"

	self title: self title! !

!SpWorldPresenter methodsFor: 'private' stamp: ''!
openWithSpec: aSpec

	self buildWithSpec: aSpec.
	self updateTitle! !

!SpWorldPresenter methodsFor: 'api' stamp: ''!
ensureExtentFor: aWidget

	self extent ifNotNil: [ :ext | DisplayScreen hostWindowSize: ext ].
	self initialExtent ifNotNil: [ :ext | DisplayScreen hostWindowSize: ext ].! !

!SpWorldPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	self setUpWorld.
	^ SpAbstractWidgetLayout for: #WorldAdapter! !

!SpWorldPresenter class methodsFor: 'private' stamp: ''!
setUpWorld

	self currentWorld changeProportionalLayout.
	self currentWorld submorphs do: [:e | e delete ].
 
 	(Smalltalk at: #PolymorphSystemSettings) 
		perform: #desktopColor: 
		with: self currentWorld theme backgroundColor.
 	"((Smalltalk at: #UITheme) perform: #currentSettings) perform: #windowColor: with: (Color r: 0.745 g: 0.745 b: 0.745)."
	(Smalltalk at: #TaskbarMorph) perform: #showTaskbar: with: false! !

!SpWorldPresenterTest methodsFor: 'running' stamp: ''!
tearDown

	worldMorph delete.
	super tearDown! !

!SpWorldPresenterTest methodsFor: 'tests' stamp: ''!
testOpenPresenterInWorldDisplayToolbarDoesNotHidePresenter
	| windowPresenter worldPanel |
	windowPresenter := application
		newPresenter: SpTestPresenterWithToolbar.
		
	(SpTestWorldPresenter presenter: windowPresenter) open.
		
	worldPanel := worldMorph submorphs first.
	self
		assert:
			(worldPanel submorphs first bounds
				intersect: worldPanel submorphs second bounds)
				= (0 @ 0 extent: 0 @ 0)
		description: 'toolbar should not intersect with presenter when opening in world'! !

!SpWorldPresenterTest methodsFor: 'tests' stamp: ''!
testOpenPresenterInWorldRemoveExisitingMorphsInWorld
	| buttonPresenter |
	worldMorph addMorph: CircleMorph new.
	buttonPresenter := (application newPresenter: SpButtonPresenter)
		label: 'testOpenPresenterInWorldRemoveExisitingMorphsInWorld'. 
	
	(SpTestWorldPresenter presenter: buttonPresenter) open.

	self deny: (worldMorph submorphs anySatisfy: [ :morph | morph class = CircleMorph ]).
	self assert: worldMorph submorphs size equals: 1.
	self assert: worldMorph submorphs first class equals: Morph! !

!SpWorldPresenterTest methodsFor: 'tests' stamp: ''!
testOpenPresenterInWorldDisplayInFullWorld
	| buttonPresenter |
	
	buttonPresenter := (application newPresenter: SpButtonPresenter)
		label: 'test'.
	
	(SpTestWorldPresenter presenter: buttonPresenter) open.
	
	self currentWorld addMorph: worldMorph.
	
	self
		assert: worldMorph submorphs first submorphs first extent
		equals: worldMorph extent - 8 "border"! !

!SpWorldPresenterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	worldMorph := SpTestWorldPresenter
		reset;
		currentWorld.
	worldMorph
		extent: 300 @ 400;
		borderWidth: 0;
		color: Color veryLightGray.
	application := SpNullApplication new! !

!SpWrappedItem commentStamp: ''!
An utily class!
!SpWrappedItem methodsFor: 'accessing' stamp: ''!
selectedItem
	^ selectedItem! !

!SpWrappedItem methodsFor: 'accessing' stamp: ''!
selectedItem: anObject
	selectedItem := anObject! !

!SpaceTally commentStamp: ''!
I'm responsible to help getting information about system space usage. The information I compute is represented by a spaceTallyItem

try something like: 

((SpaceTally new spaceTally: (Array with: TextMorph with: Point)) 
	asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) 

SpaceTally new systemWideSpaceTally


This class has been created from a part of SystemDictionary. It still deserves a nice
clean, such as using object instead of array having 4 slots.

sd-20 June 2003!
!SpaceTally methodsFor: 'class analysis' stamp: ''!
compareTallyIn: beforeFileName to: afterFileName
	"SpaceTally new compareTallyIn: 'tally' to: 'tally2'"

	| answer beforeDict a afterDict allKeys |
	beforeDict := Dictionary new.
	beforeFileName asFileReference readStreamDo: [ :s|
		[s atEnd] whileFalse: [
			a := Array readFrom: s nextLine.
			beforeDict at: a first put: a allButFirst ]].
	afterDict := Dictionary new.
	
	afterFileName asFileReference readStreamDo: [ :s|
		[s atEnd] whileFalse: [
			a := Array readFrom: s nextLine.
			afterDict at: a first put: a allButFirst ]].

	answer := String new writeStream.
	allKeys := (Set new addAll: beforeDict keys; addAll: afterDict keys; yourself) asSortedCollection.
	allKeys do: [ :each | | before diff after |
		before := beforeDict at: each ifAbsent: [#(0 0 0)].
		after := afterDict at: each ifAbsent: [#(0 0 0)].
		diff := before with: after collect: [ :vBefore :vAfter | vAfter - vBefore].
		diff = #(0 0 0) ifFalse: [
			answer nextPutAll: each,'  ',diff printString; cr.
		].
	].
	StandardWindow new
		withText: answer contents
		label: 'space diffs';
		openInWorld
	


! !

!SpaceTally methodsFor: 'class analysis' stamp: ''!
computeSpaceUsage
	| c instanceCount |
	results items
		do: [ :entry | 
			c := self class environment at: entry analyzedClassName.
			instanceCount := c instanceCount.
			entry codeSize: c spaceUsed.
			entry instanceCount: instanceCount.
			entry spaceForInstances: c instancesSizeInMemory.
			Smalltalk garbageCollectMost ]! !

!SpaceTally methodsFor: 'utilities' stamp: ''!
spaceForInstancesOf: aClass
	"Answer a pair of the number of bytes consumed by all instances of the
	 given class, including their object headers, and the number of instances."

	| instances total |
	instances := aClass allInstances.
	instances isEmpty ifTrue: [^#(0 0)].
	total := 0.
	aClass isVariable
		ifTrue:
			[instances do:
				[:i| total := total + (aClass byteSizeOfInstanceOfSize: i basicSize)]]
		ifFalse:
			[total := instances size * aClass byteSizeOfInstance].
	^{ total. instances size }! !

!SpaceTally methodsFor: 'class analysis' stamp: ''!
systemWideSpaceTally
	"Answer a collection of SpaceTallyItems representing the memory space (in bytes) consumed 	by the code and instances of each class in the system. Note that code sizes do not currently 	report memory consumed by class variables. "

	"(SpaceTally new systemWideSpaceTally asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) asArray"

	self
		computeSpaceUsageResultsForClassesInstancesAssociations: self privateAllObjects.
	^ self results items! !

!SpaceTally methodsFor: 'fileout' stamp: ''!
printSpaceDifferenceFrom: fileName1 to: fileName2
	"For differential results, run printSpaceAnalysis twice with different fileNames,
	then run this method...
		SpaceTally new printSpaceAnalysis: 0 on: 'STspace.text1' asFileReference writeStream.
			--- do something that uses space here ---
		SpaceTally new printSpaceAnalysis: 0 on: 'STspace.text2' asFileReference writeStream.
		SpaceTally new printSpaceDifferenceFrom: 'STspace.text1' to: 'STspace.text2'
"
	| f coll1 coll2 item |
	f := fileName1 asFileReference readStream.
	coll1 := OrderedCollection new.
	[f atEnd] whileFalse: [coll1 add: f nextLine].
	f close.
	f := fileName2 asFileReference readStream.
	coll2 := OrderedCollection new.
	[f atEnd] whileFalse:
		[item := f nextLine.
		((coll1 includes: item) and: [(item endsWith: 'percent') not])
			ifTrue: [coll1 remove: item]
			ifFalse: [coll2 add: item]].
	f close.
	StandardWindow new 
		withText: (String streamContents: 
			[:s | 
			s nextPutAll: fileName1; cr.
			coll1 do: [:x | s nextPutAll: x; cr].
			s cr; cr.
			s nextPutAll: fileName2; cr.
			coll2 do: [:x | s nextPutAll: x; cr]])
		 label: 'Differential Space Analysis';
		openInWorld! !

!SpaceTally methodsFor: 'class analysis' stamp: ''!
preAllocateResultsFor: classes
	results := SpaceTallyResult new: classes size.
	classes
		do: [ :cl | results addItem: (SpaceTallyItem analyzedClassName: cl name) ]! !

!SpaceTally methodsFor: 'fileout' stamp: ''!
printSpaceTallyItem: aSpaceTallyItem percent: percent on: aStream
	aStream
		nextPutAll: (aSpaceTallyItem analyzedClassName padRightTo: 45);
		nextPutAll: (aSpaceTallyItem codeSize printString padLeftTo: 12);
		nextPutAll: (aSpaceTallyItem instanceCount printString padLeftTo: 12);
		nextPutAll: (aSpaceTallyItem spaceForInstances printString padLeftTo: 14).
	aStream 
		nextPutAll: ((percent printShowingDecimalPlaces: 2) padLeftTo: 12);
		nextPutAll: (((aSpaceTallyItem spaceForInstances / (aSpaceTallyItem instanceCount max: 1)) asFloat printShowingDecimalPlaces: 2) padLeftTo: 20);
		cr! !

!SpaceTally methodsFor: 'accessing' stamp: ''!
results

	^ results! !

!SpaceTally methodsFor: 'fileout' stamp: ''!
privateAllObjects
	Smalltalk garbageCollect.
	^ SystemNavigation default allObjects groupedBy: #class! !

!SpaceTally methodsFor: 'fileout' stamp: ''!
computeSpaceUsageResultsForClassesInstancesAssociations: aCollectionOfClasses
	results := SpaceTallyResult new: aCollectionOfClasses size.
	aCollectionOfClasses associations
		do: [ :assoc | 
			| instances class |
			instances := assoc value.
			class := assoc key.
			class isMeta
				ifFalse: [ results
						addItem:
							(SpaceTallyItem
								analyzedClassName: class name
								codeSize: class spaceUsed
								instanceCount: instances size
								spaceForInstances: (instances sum: #sizeInMemory)) ] ]! !

!SpaceTally methodsFor: 'fileout' stamp: ''!
printHeader: aStream
	aStream
		nextPutAll: ('Class' padRightTo: 45);
		nextPutAll: ('code space' padLeftTo: 12);
		nextPutAll: ('# instances' padLeftTo: 12);
		nextPutAll: ('inst space' padLeftTo: 12);
		nextPutAll: ('percent' padLeftTo: 12);
		nextPutAll: ('inst average size' padLeftTo: 20);
		cr! !

!SpaceTally methodsFor: 'fileout' stamp: ''!
printSpaceAnalysis
	self systemWideSpaceTally.
	'STspace.txt' asFileReference
		writeStreamDo: [ :stream | self printSpaceAnalysis: 1 on: stream ]! !

!SpaceTally methodsFor: 'fileout' stamp: ''!
saveTo: aFileName
	"| st |
	st := SpaceTally new.
	st spaceTally: (Array with: TextMorph with: Point).
	st saveTo: 'spaceTally2'"
	| file |
	file := aFileName asFileReference.
	file exists ifTrue: [ file delete ].
	
	file writeStreamDo: [ :s|
		results items do: [:each | s nextPutAll: each analyzedClassName asString ; 
						nextPutAll: ' '; nextPutAll: each codeSize printString; 
						nextPutAll: ' '; nextPutAll: each instanceCount printString; 
						nextPutAll: ' '; nextPutAll: each spaceForInstances printString; cr]].! !

!SpaceTally methodsFor: 'fileout' stamp: ''!
computeSpaceForClass: cl
	| codeSpace instSpace instCount |
	codeSpace := cl spaceUsed.
	Smalltalk garbageCollectMost.
	instCount := cl instanceCount.
	instSpace := cl instancesSizeInMemory.
	results
		addItem:
			(SpaceTallyItem
				analyzedClassName: cl name
				codeSize: codeSpace
				instanceCount: instCount
				spaceForInstances: instSpace)! !

!SpaceTally methodsFor: 'printing' stamp: ''!
printSpaceAnalysis: threshold on: aStream
"SpaceTally new printSpaceAnalysis: 1 on: (FileStream forceNewFileNamed: 'STspace.text')"

	"If threshold > 0, then only those classes with more than that number
	of instances will be shown, and they will be sorted by total instance space.
	If threshold = 0, then all classes will appear, sorted by name."

	| totalPercent items |
	"If inst count threshold > 0, then sort by space"
	totalPercent := 0.0.
	items :=  results itemsForThreshold: threshold.
	self printHeader: aStream.
	items
		do: [ :s | 
			| percent |
			percent := s spaceForInstances * 100.0
				/  results totalInstSpace roundTo: 0.1.
			totalPercent := totalPercent + percent.
			self printSpaceTallyItem: s percent: percent on: aStream ].
	aStream
		cr;
		nextPutAll: ('Total' padRightTo: 45);
		nextPutAll: ( results totalCodeSpace printString padLeftTo: 12);
		nextPutAll: ( results totalInstCount printString padLeftTo: 12);
		nextPutAll: ( results totalInstSpace printString padLeftTo: 14);
		nextPutAll: ((totalPercent roundTo: 0.1) printString padLeftTo: 12)! !

!SpaceTally methodsFor: 'class analysis' stamp: ''!
spaceTally: classes
	"Answer a collection of SpaceTallyItems representing the memory space (in bytes) consumed 	by the code and instances of each class in the system. Note that code sizes do not currently 	report memory consumed by class variables. "

	"
	((SpaceTally new spaceTally: (Array with: TextMorph with: Point)) items asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) asArray
	"

	self preAllocateResultsFor: classes.
	Smalltalk garbageCollect.
	self computeSpaceUsage.
	^ results
! !

!SpaceTally class methodsFor: 'fileout' stamp: ''!
printSpaceAnalysis	
	<script>
	self new printSpaceAnalysis! !

!SpaceTally class methodsFor: 'fileout' stamp: ''!
printSpaceAnalysis: aThreshold on: aStream
	<script>
	self new
		systemWideSpaceTally;
		printSpaceAnalysis: aThreshold on: aStream! !

!SpaceTallyItem commentStamp: ''!
I'm represent an entry in the spaceTally.!
!SpaceTallyItem methodsFor: 'accessing' stamp: ''!
instanceCount

	^ instanceCount! !

!SpaceTallyItem methodsFor: 'accessing' stamp: ''!
codeSize: aNumber

	codeSize := aNumber! !

!SpaceTallyItem methodsFor: 'accessing' stamp: ''!
instanceCount: aNumber

	instanceCount := aNumber! !

!SpaceTallyItem methodsFor: 'accessing' stamp: ''!
spaceForInstances

	^ spaceForInstances! !

!SpaceTallyItem methodsFor: 'printing' stamp: ''!
printOn: aStream

	analyzedClassName ifNotNil: [ aStream print: analyzedClassName ].
	aStream nextPutAll: ' ('.
	codeSize
		ifNotNil: [ aStream
				nextPutAll: 'code size: ';
				print: codeSize
			].
	instanceCount
		ifNotNil: [ aStream
				nextPutAll: ' instance count: ';
				print: instanceCount
			].
	spaceForInstances
		ifNotNil: [ aStream
				nextPutAll: ' space for instances: ';
				print: spaceForInstances
			].
	aStream nextPut: $)! !

!SpaceTallyItem methodsFor: 'accessing' stamp: ''!
codeSize

	^ codeSize! !

!SpaceTallyItem methodsFor: 'accessing' stamp: ''!
analyzedClassName

	^ analyzedClassName! !

!SpaceTallyItem methodsFor: 'accessing' stamp: ''!
spaceForInstances: aNumber

	spaceForInstances := aNumber! !

!SpaceTallyItem methodsFor: 'accessing' stamp: ''!
analyzedClassName: aClassName

	analyzedClassName := aClassName! !

!SpaceTallyItem class methodsFor: 'instance creation' stamp: ''!
analyzedClassName: aClassName

	^ self new
		analyzedClassName: aClassName ; yourself
		! !

!SpaceTallyItem class methodsFor: 'instance creation' stamp: ''!
analyzedClassName: aClassName codeSize: codeSize instanceCount: instanceCount spaceForInstances: spaceForInstances

	^ self new
		analyzedClassName: aClassName ;
		codeSize: codeSize ;
		instanceCount: instanceCount ;
		spaceForInstances: spaceForInstances ; yourself! !

!SpaceTallyResult commentStamp: ''!
I represent a result of the computation of the SpaceTally 

I store SpaceTallyItems for each class. I interact with SpaceTally.

Public API and Key Messages

- item   
- total* methods 

 
Internal Representation and Key Implementation Points.

    Instance Variables
	items:		<aCollectionOfSpaceTallyItem>

Implementation Points

My total* methods could be cached for perf!
!SpaceTallyResult methodsFor: 'adding' stamp: ''!
addItem: aSpaceTallyItem
	items add: aSpaceTallyItem! !

!SpaceTallyResult methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	items := OrderedCollection new! !

!SpaceTallyResult methodsFor: 'initialization' stamp: ''!
itemSize: aSize
	items := OrderedCollection new: aSize! !

!SpaceTallyResult methodsFor: 'accessing' stamp: ''!
totalInstCount
	^ self items sum: #instanceCount! !

!SpaceTallyResult methodsFor: 'accessing' stamp: ''!
totalCodeSpace
	^ self items sum: #codeSize! !

!SpaceTallyResult methodsFor: 'accessing' stamp: ''!
itemsForThreshold: threshold
	| totalInstSpace |
	threshold <= 0
		ifTrue: [ ^ self items ].
	totalInstSpace := self totalInstSpace.
	^(self items
		select: [ :s | 
			s instanceCount >= threshold
				or: [ s spaceForInstances > (totalInstSpace // 500) ] ])
		asSortedCollection: [ :s :s2 | s spaceForInstances > s2 spaceForInstances ]! !

!SpaceTallyResult methodsFor: 'accessing' stamp: ''!
totalInstSpace
	^ self items sum: #spaceForInstances! !

!SpaceTallyResult methodsFor: 'accessing' stamp: ''!
items
	^ items! !

!SpaceTallyResult class methodsFor: 'instance creation' stamp: ''!
new: aSize
	^ self new
		itemSize: aSize;
		yourself! !

!SpaceTallyTest commentStamp: ''!
SUnit tests for SpaceTally!
!SpaceTallyTest methodsFor: 'tests' stamp: ''!
testPrintOnStream
	| contents |
	contents := String
		streamContents: [ :s | SpaceTally printSpaceAnalysis: 1 on: s ].
	self assert: contents isString! !

!SpaceTallyTest methodsFor: 'tests' stamp: ''!
test2Classes
	| result |
	result := (SpaceTally new
		spaceTally: (Array with: TextMorph with: Point)) items
		asSortedCollection: [ :a :b | a spaceForInstances > b spaceForInstances ].
	self assert: result size equals: 2.
	self
		assertCollection: (result collect: [:each | each analyzedClassName])
		hasSameElements: #(#Point #TextMorph).
	self
		assert:
			result anyOne codeSize + result anyOne instanceCount
				+ result anyOne spaceForInstances > 0! !

!SpaceTallyTest methodsFor: 'tests' stamp: ''!
testSystemWide
	self
		assert:
			(SpaceTally new systemWideSpaceTally
				asSortedCollection: [ :a :b | a spaceForInstances > b spaceForInstances ])
				asArray isNotEmpty! !

!SparseLargeArray commentStamp: ''!
A version of SparseLargeTable that does not populate its bins until a value other than the default is stored.!!!
!SparseLargeArray methodsFor: 'initialization' stamp: 'nil'!
initChunkSize: aChunkSize size: aSize arrayClass: aClass base: b defaultValue: d
       chunkSize := aChunkSize.
       size := aSize.
       base := b.
       defaultValue := d.
       arrayClass := aClass! !

!SparseLargeArray methodsFor: 'private' stamp: 'nil'!
analyzeSpaceSaving

      | elems tablesTotal nonNilTables lastPage lastChunkSize |
      elems := 0.
       tablesTotal := self basicSize.
       nonNilTables := 0.
       lastPage := self basicAt: self basicSize.
       (lastChunkSize := size \\ chunkSize) = 0 ifTrue:
               [lastChunkSize := chunkSize].
       1 to: self basicSize do:
               [:i | | page |
               (page := self basicAt: i) ifNotNil:
                       [nonNilTables := nonNilTables + 1.
                        1 to: (page == lastPage ifTrue: [lastChunkSize] ifFalse: [chunkSize]) do:
                               [:j|
                               (page at: j) ~= defaultValue ifTrue:
                                       [elems := elems + 1]]]].

       ^String streamContents:
               [:strm |
               strm nextPutAll: 'total: '; print: size.
               strm nextPutAll: ' elements: '; print: elems.
               strm nextPutAll: ' tables: '; print: tablesTotal.
               strm nextPutAll: ' non-nil: '; print: nonNilTables]! !

!SparseLargeArray methodsFor: 'accessing' stamp: 'nil'!
noCheckAt: index put: value
       | chunkIndex chunk lastChunkSize |
       chunkIndex := index - base // chunkSize + 1.
       (chunk := self basicAt: chunkIndex) ifNil:
               [value = defaultValue ifTrue:
                       [^value].
               chunk := arrayClass
                                       new: ((chunkIndex == self basicSize
                                                  and: [(lastChunkSize := size \\ chunkSize) > 0])
                                                       ifTrue: [lastChunkSize]
                                                       ifFalse: [chunkSize])
                                       withAll: defaultValue.
               self basicAt: chunkIndex put: chunk].
       ^chunk at: index - base \\ chunkSize + 1 put: value! !

!SparseLargeArray methodsFor: 'accessing' stamp: 'nil'!
atAllPut: anObject
       "Put anObject at every one of the receiver's indices."

       1 to: self basicSize do:
               [:i|
               self basicAt: i put: nil].
       defaultValue := anObject! !

!SparseLargeArray methodsFor: 'accessing' stamp: 'nil'!
noCheckAt: index
      ^(self basicAt: index - base // chunkSize + 1)
               ifNil: [defaultValue]
               ifNotNil: [:chunk| chunk at: index - base \\ chunkSize + 1]! !

!SparseLargeTable commentStamp: ''!
Derivated from Stephan Pair's LargeArray, but to hold a sparse table, in which most of the entries are the same default value, it uses some tricks.!
!SparseLargeTable methodsFor: 'private' stamp: 'nil'!
privateSize: s

	size := s.! !

!SparseLargeTable methodsFor: 'private' stamp: 'nil'!
allDefaultValueSubtableAt: index

	| t |
	t := self basicAt: index.
	t ifNil: [^ true].
	t do: [:e |
		e ~= defaultValue ifTrue: [^ false].
	].
	^ true.! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'nil'!
chunkSize

	^chunkSize! !

!SparseLargeTable methodsFor: 'private' stamp: 'nil'!
analyzeSpaceSaving

	| total elems tablesTotal nonNilTables |
	total := size - base + 1.
	elems := 0.
	base to: size do: [:i | (self at: i) ~= defaultValue ifTrue: [elems := elems + 1]].
	tablesTotal := self basicSize.
	nonNilTables := 0.
	1 to: self basicSize do: [:i | (self basicAt: i) ifNotNil: [nonNilTables := nonNilTables + 1]].

	^ String streamContents: [:strm |
		strm nextPutAll: 'total: '.
		strm nextPutAll: total printString.
		strm nextPutAll: ' elements: '.
		strm nextPutAll: elems printString.
		strm nextPutAll: ' tables: '.
		strm nextPutAll: tablesTotal printString.
		strm nextPutAll: ' non-nil: '.
		strm nextPutAll: nonNilTables printString.
	].! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'nil'!
noCheckAt: index put: value

	| chunkIndex t |
	chunkIndex := index - base // chunkSize + 1.
	chunkIndex > self basicSize ifTrue: [^ value].
	t :=  self basicAt: chunkIndex.
	t ifNil: [^ value].
	^ t at: (index - base + 1 - (chunkIndex - 1 * chunkSize)) put: value! !

!SparseLargeTable methodsFor: 'printing' stamp: 'nil'!
printOn: aStream

	(#(String) includes: self arrayClass name) 
		ifTrue: [^self storeOn: aStream].
	^super printOn: aStream! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'nil'!
at: index

	self pvtCheckIndex: index.
	^self noCheckAt: index.! !

!SparseLargeTable methodsFor: 'private' stamp: 'nil'!
similarInstance

	^self class
		new: self size 
		chunkSize: self chunkSize 
		arrayClass: self arrayClass! !

!SparseLargeTable methodsFor: 'private' stamp: 'nil'!
similarInstance: newSize

	^self class
		new: newSize 
		chunkSize: self chunkSize 
		arrayClass: self arrayClass! !

!SparseLargeTable methodsFor: 'printing' stamp: 'nil'!
printElementsOn: aStream
	| element |
	aStream nextPut: $(.
	base to: size do: [:index | element := self at: index. aStream print: element; space].
	self isEmpty ifFalse: [aStream skip: -1].
	aStream nextPut: $)! !

!SparseLargeTable methodsFor: 'copying' stamp: 'nil'!
copyEmpty
	"Answer a copy of the receiver that contains no elements."
	^self speciesNew: 0! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'nil'!
at: index put: value
	
	self pvtCheckIndex: index.
	^self noCheckAt: index put: value! !

!SparseLargeTable methodsFor: 'initialization' stamp: 'nil'!
initChunkSize: aChunkSize size: aSize arrayClass: aClass base: b defaultValue: d

	| lastChunkSize |
	chunkSize := aChunkSize.
	size := aSize.
	base := b.
	defaultValue := d.
	1 to: (self basicSize - 1) do: [ :in | self basicAt: in put: (aClass new: chunkSize withAll: defaultValue) ].
	lastChunkSize := size \\ chunkSize.
	lastChunkSize = 0 ifTrue: [lastChunkSize := chunkSize].
	size = 0 
		ifTrue: [self basicAt: 1 put: (aClass new: 0)]
		ifFalse: [self basicAt: self basicSize put: (aClass new: lastChunkSize withAll: defaultValue)].! !

!SparseLargeTable methodsFor: 'copying' stamp: 'nil'!
postCopy
	super postCopy.
	1 to: self basicSize do: [:i | self basicAt: i put: (self basicAt: i) copy]! !

!SparseLargeTable methodsFor: 'private' stamp: 'nil'!
speciesNew

	^self species
		new: self size 
		chunkSize: self chunkSize 
		arrayClass: self arrayClass! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'nil'!
zapDefaultOnlyEntries

	1 to: self basicSize do: [:i |
		(self allDefaultValueSubtableAt: i) ifTrue: [self basicAt: i put: nil].
	].! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'nil'!
noCheckAt: index
	| chunkIndex t |

	chunkIndex := index - base // chunkSize + 1.
	(chunkIndex > self basicSize or: [chunkIndex < 1]) ifTrue: [^ defaultValue].
	t := self basicAt: chunkIndex.
	t ifNil: [^ defaultValue].
	^ t at: (index - base + 1 - (chunkIndex - 1 * chunkSize))! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'nil'!
size

	^size! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'nil'!
base

	^ base.! !

!SparseLargeTable methodsFor: 'private' stamp: 'nil'!
similarSpeciesInstance

	^self similarInstance! !

!SparseLargeTable methodsFor: 'private' stamp: 'nil'!
similarSpeciesInstance: newSize

	^self similarInstance: newSize! !

!SparseLargeTable methodsFor: 'printing' stamp: 'nil'!
storeOn: aStream

	| x |
	(#(String) includes: self arrayClass name) ifTrue: 
		[aStream nextPut: $'.
		1 to: self size do:
			[:i |
			aStream nextPut: (x := self at: i).
			x == $' ifTrue: [aStream nextPut: x]].
		aStream nextPutAll: ''' asLargeArrayChunkSize: '.
		aStream nextPutAll: self chunkSize asString.
		^self].
	^super storeOn: aStream! !

!SparseLargeTable methodsFor: 'private' stamp: 'nil'!
speciesNew: newSize

	^self species
		new: newSize 
		chunkSize: self chunkSize 
		arrayClass: self arrayClass! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'nil'!
arrayClass

	^(self basicAt: 1) class! !

!SparseLargeTable methodsFor: 'private' stamp: 'nil'!
pvtCheckIndex: index 

	index isInteger ifFalse: [self errorNonIntegerIndex].
	index < 1 ifTrue: [self errorSubscriptBounds: index].
	index > size ifTrue: [self errorSubscriptBounds: index].! !

!SparseLargeTable class methodsFor: 'accessing' stamp: 'nil'!
defaultChunkSizeForFiles

	^8000! !

!SparseLargeTable class methodsFor: 'instance creation' stamp: 'nil'!
new: size chunkSize: chunkSize arrayClass: aClass

	^self new: size chunkSize: chunkSize arrayClass: Array base: 1.! !

!SparseLargeTable class methodsFor: 'instance creation' stamp: 'nil'!
new: size

	^self new: size chunkSize: self defaultChunkSize! !

!SparseLargeTable class methodsFor: 'instance creation' stamp: 'nil'!
new: size chunkSize: chunkSize arrayClass: aClass base: b

	^self new: size chunkSize: chunkSize arrayClass: Array base: 1 defaultValue: nil.! !

!SparseLargeTable class methodsFor: 'accessing' stamp: 'nil'!
defaultChunkSize

	^100! !

!SparseLargeTable class methodsFor: 'instance creation' stamp: 'nil'!
new: size chunkSize: chunkSize arrayClass: aClass base: b defaultValue: d

	| basicSize |
	(basicSize := ((size - 1) // chunkSize) + 1) = 0
		ifTrue: [basicSize := 1].
	^(self basicNew: basicSize)
		initChunkSize: chunkSize size: size arrayClass: aClass base: b defaultValue: d;
		yourself! !

!SparseLargeTable class methodsFor: 'instance creation' stamp: 'nil'!
new: size chunkSize: chunkSize

	^self new: size chunkSize: chunkSize arrayClass: Array! !

!SpecAdapterBindings commentStamp: ''!
I am an abstract class

I am used to link a spec-oriented adapter name to a framework specific adapter class name!
!SpecAdapterBindings methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.

	bindings := Dictionary new.
	self initializeBindings! !

!SpecAdapterBindings methodsFor: 'initialize' stamp: ''!
initializeBindings
	"This implementation is stupid, but it exposes all the container which need to be bound"
	
	^ bindings
		at: #ButtonAdapter				put: #ButtonAdapter;
		at: #CheckBoxAdapter			put: #CheckBoxAdapter;
		at: #ContainerAdapter			put: #ContainerAdapter;
		at: #DiffAdapter				put: #MorphicDiffAdapter;
		at: #ImageAdapter				put: #ImageAdapter;
		at: #LabelAdapter				put: #LabelAdapter;
		at: #ListAdapter				put: #ListAdapter;
		at: #IconListAdapter			put: #IconListAdapter;
		at: #FastTableAdapter			put: #FastTableAdapter;
		at: #DropListAdapter			put: #DropListAdapter;
		at: #MultiColumnListAdapter	put: #MultiColumnListAdapter;
		at: #MenuAdapter				put: #MenuAdapter;
		at: #MenuGroupAdapter		put: #MenuGroupAdapter;
		at: #MenuItemAdapter			put: #MenuItemAdapter;	
		at: #RadioButtonAdapter		put: #RadioButtonAdapter;
		at: #SliderAdapter				put: #SliderAdapter;
		at: #TabManagerAdapter		put: #TabManagerAdapter;
		at: #TabAdapter				put: #TabAdapter;
		at: #TextAdapter				put: #TextAdapter;
		at: #TextInputFieldAdapter		put: #TextInputFieldAdapter;
		at: #TransferAdapter			put: #TransferAdapter;
		at: #TreeAdapter				put: #TreeAdapter;
		at: #TreeColumnAdapter		put: #TreeColumnAdapter;
		at: #TreeNodeAdapter			put: #TreeNodeAdapter;		
		at: #WindowAdapter			put: #WindowAdapter;
		at: #TickingWindowAdapter	put: #TickingWindowAdapter;
		at: #DialogWindowAdapter		put: #DialogWindowAdapter;
		yourself! !

!SpecAdapterBindings methodsFor: 'protocol' stamp: ''!
translateSymbol: aSymbol

	^ bindings 
		at: aSymbol
		ifAbsent: [ aSymbol ]! !

!SpecAdapterBindings class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self name = #SpecAdapterBindings! !

!SpecColumnLayout commentStamp: ''!
A SpecColumnLayout is the layout used to specify a new column!
!SpecColumnLayout methodsFor: 'private' stamp: ''!
resetArrayComputation

	super resetArrayComputation.
	
	size := self commands size.
	numberOfProportionals := 0.
	lastFractionIndex := 0.
	autoFractionComputation := true.
	currentOffset := 0.
	currentProportional := 0! !

!SpecColumnLayout methodsFor: 'private' stamp: ''!
countNumberOfProportionals

	self commands	do: [ :e | 
		e layoutFrame hasNoOffsets
			ifTrue: [ 
				(e layoutFrame topFraction == 0 and: [ e layoutFrame bottomFraction == 1 ])
					ifFalse: [ autoFractionComputation := false ].
				numberOfProportionals := numberOfProportionals + 1 ] ]! !

!SpecColumnLayout methodsFor: 'private' stamp: ''!
setWidgetLayoutWithOffset: widget at: index

	height := widget bottomOffset - widget topOffset.
	
	index = size
		ifTrue: [ 
			widget layoutFrame:
				((0 @ 1 corner: 1 @ 1) asSpecLayoutFrame
					topLeftOffset: widget leftOffset @ height negated;
					bottomRightOffset: widget rightOffset @ 0) ]
		ifFalse: [ 
			widget layoutFrame:
				((0 @ currentProportional corner: 1 @ currentProportional) asSpecLayoutFrame
					topLeftOffset: widget leftOffset @ currentOffset;
					bottomRightOffset: widget rightOffset @ (currentOffset + height)).
			currentOffset := currentOffset + height ]! !

!SpecColumnLayout methodsFor: 'converting' stamp: ''!
privateAsArray

	self resetArrayComputation.
	self countNumberOfProportionals.

	autoFractionComputation
		ifTrue: [ self autoFractionComputation ]
		ifFalse: [ self manualFractionComputation ].

	self shiftLastWidgets.

	result addAll: super privateAsArray.
	^ result asArray! !

!SpecColumnLayout methodsFor: 'commands' stamp: ''!
add: aSpec height: aNumber
	
	self add: aSpec origin: 0@0 corner: 1@1 offsetOrigin: 0@0 offsetCorner: 0@aNumber ! !

!SpecColumnLayout methodsFor: 'private' stamp: ''!
setWidgetLayoutWithNoOffset: widget at: index delta: delta

	widget layoutFrame:
		((0 @ currentProportional corner: 1 @ (currentProportional + delta)) asSpecLayoutFrame 
			topOffset: currentOffset;
			yourself).
				
	currentOffset := 0.
	currentProportional := currentProportional + delta.
	
	lastFractionIndex := index! !

!SpecColumnLayout methodsFor: 'private' stamp: ''!
autoFractionComputation
	| delta |
	delta := numberOfProportionals isZero
		ifTrue: [ 0 ]
		ifFalse: [ 1 / numberOfProportionals ].
	self commands
		doWithIndex: [ :e :idx | 
			e layoutFrame hasNoOffsets
				ifTrue: [ self setWidgetLayoutWithNoOffset: e at: idx delta: delta ]
				ifFalse: [ self setWidgetLayoutWithOffset: e at: idx ] ]! !

!SpecColumnLayout methodsFor: 'private' stamp: ''!
manualFractionComputation
	
	self commands	doWithIndex: [ :e :idx | 
		e layoutFrame hasNoOffsets
			ifTrue: [  | delta |
				delta := e layoutFrame bottomFraction - e layoutFrame topFraction.
				self setWidgetLayoutWithNoOffset: e at: idx delta: delta ]
			ifFalse: [ self setWidgetLayoutWithOffset: e at: idx ] ]! !

!SpecColumnLayout methodsFor: 'private' stamp: ''!
shiftLastWidgets
	| index ante |	
	
	(lastFractionIndex > 0 and: [ lastFractionIndex < size ]) ifFalse: [ ^ self ].
	
	index := size - 1.
	[ index > lastFractionIndex ] whileTrue: [ | myHeight |
			ante := self commands at: index.
			index := index - 1.
			myHeight := ante bottomOffset - ante topOffset.
			ante
				topOffset: (height + myHeight) negated;
				bottomOffset: height negated.
			height := height + myHeight ].
		
	self assert: index = lastFractionIndex.
	
	ante := self commands at: index.
	ante bottomOffset: height negated! !

!SpecColumnLayout methodsFor: 'commands' stamp: ''!
addSplitter

	self commands add: (SpecSplitterHorizontal commands: self commands)! !

!SpecDialogWindow commentStamp: ''!
A SpecDialogWindow is a window made for embedding Spec models into dialog windows
!
!SpecDialogWindow methodsFor: 'accessing' stamp: ''!
newContentMorph
	"Answer a new content morph."

	^ self specWidget
		ifNotNil: [ :w | 
			w
				hResizing: #spaceFill;
				vResizing: #spaceFill ]! !

!SpecDialogWindow methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.

	self beResizeable! !

!SpecDialogWindow methodsFor: 'open/close' stamp: ''!
initialExtent 

	^ self model
		ifNil: [ super initialExtent ]
		ifNotNil: [:m | m initialExtent
						ifNil: [ super initialExtent ]]! !

!SpecDialogWindow methodsFor: 'protocol' stamp: ''!
setToolbarFrom: aBlock
	| newToolbar |
	
	newToolbar := aBlock value.
	
	toolbar := newToolbar.
	newToolbar owner: self! !

!SpecDialogWindow methodsFor: 'accessing' stamp: ''!
toolbar
	"Lazy initialization because this method is called efore the initialize method"
	
	^ toolbar! !

!SpecDialogWindow methodsFor: 'accessing' stamp: ''!
specWidget: anObject

	specWidget := anObject.! !

!SpecDialogWindow methodsFor: 'focus' stamp: ''!
giveFocusToNextFrom: aModel 

	^ self model giveFocusToNextFrom: aModel ! !

!SpecDialogWindow methodsFor: 'protocol' stamp: ''!
cancelAction: aBlock

	self toolbar cancelAction: aBlock ! !

!SpecDialogWindow methodsFor: 'actions' stamp: ''!
escapePressed

	self toolbar triggerCancelAction! !

!SpecDialogWindow methodsFor: 'focus' stamp: ''!
giveFocusToPreviousFrom: aModel 

	^ self model giveFocusToPreviousFrom: aModel! !

!SpecDialogWindow methodsFor: 'accessing' stamp: ''!
newButtonRow
	^ self toolbar ifNotNil: [ :t | t buildWithSpec ]! !

!SpecDialogWindow methodsFor: 'actions' stamp: ''!
newMainPanel
	"Answer a new main panel."
	| panel |
	panel := self newDialogPanel.
	self newContentMorph ifNotNil: [:m | panel 	addMorphBack: m ].
	self newButtonRow ifNotNil: [:m | panel 	addMorphBack: m ].
	^ panel! !

!SpecDialogWindow methodsFor: 'accessing' stamp: ''!
model: aModel

	super model: aModel.

	aModel model focusOrder
		addLast: toolbar.
	toolbar focusOrder addLast: model! !

!SpecDialogWindow methodsFor: 'protocol' stamp: ''!
cancelled

	^ self toolbar cancelled! !

!SpecDialogWindow methodsFor: 'actions' stamp: ''!
close

	super close.
	self toolbar cancel! !

!SpecDialogWindow methodsFor: 'protocol' stamp: ''!
okAction: aBlock

	self toolbar okAction: aBlock ! !

!SpecDialogWindow methodsFor: 'accessing' stamp: ''!
specWidget

	^ specWidget! !

!SpecDialogWindow methodsFor: 'accessing' stamp: ''!
toolbar: anObject

	toolbar := anObject.
	anObject owner: self.
	
	self removeMorph: self submorphs last.
	self addMainPanel! !

!SpecDropListMorph commentStamp: ''!
I am a special DropList with icons!
!SpecDropListMorph methodsFor: 'private' stamp: ''!
wrapItem: anItem index: anIndex

	^ self model wrapItem: anItem index: anIndex! !

!SpecDropListMorph methodsFor: 'private' stamp: ''!
updateListSelectionIndex

	currentIcon ifNotNil: [ self removeMorph: currentIcon ].
		
	super updateListSelectionIndex.
	
	self selectedItem ifNotNil: [ :item | 
		(self getIconFor: item) ifNotNil: [:icon | 
			currentIcon := icon asMorph.
			self addMorphFront: currentIcon ] ] ! !

!SpecDropListMorph methodsFor: 'private' stamp: ''!
listMorphClass

	^ PluggableIconListMorph! !

!SpecDropListMorph methodsFor: 'drawing' stamp: ''!
newListMorph
	"Answer a new list morph"

	^ (self listMorphClass
		on: self
		list: #list
		selected: #listSelectionIndex
		changeSelected: #listSelectionIndex:
		menu: nil
		keystroke: nil)
			getIconSelector: #getIconFor:;
			autoDeselect: false;
			wrapSelector: #wrapItem:index:;
			roundedCorners: #(2 3);
			setProperty: #morphicLayerNumber toValue: 5;
			borderStyle: (self theme dropListNormalListBorderStyleFor: self);
			on: #mouseDown send: #listMouseDown: to: self;
			yourself! !

!SpecDropListMorph methodsFor: 'protocol' stamp: ''!
getIconFor: anItem

	^ self model getIconFor: anItem! !

!SpecDropListMorph methodsFor: 'private' stamp: ''!
listHeight
	"Answer the height for the list."

	^ super listHeight + 12! !

!SpecFTColumn commentStamp: ''!
A column for Fast table!
!SpecFTColumn methodsFor: 'accessing' stamp: ''!
width: anObject
	width := anObject! !

!SpecFTColumn methodsFor: 'layout' stamp: ''!
acquireWidth: anOwnerWidth
	^ self widthOrUndefined min: anOwnerWidth! !

!SpecFTColumn methodsFor: 'accessing' stamp: ''!
width
	^ width! !

!SpecFTColumn methodsFor: 'initialization' stamp: ''!
id: anObject
	id := anObject! !

!SpecFTColumn methodsFor: 'accessing' stamp: ''!
transform: anObject
	^ anObject! !

!SpecFTColumn methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!SpecFTColumn methodsFor: 'accessing' stamp: ''!
widthOrUndefined
	^ self width ifNil: [ self class undefinedColumnWidth ]! !

!SpecFTColumn class methodsFor: 'instance creation' stamp: ''!
id: anObject
	^ self new
		id: anObject;
		yourself! !

!SpecFTColumn class methodsFor: 'accessing' stamp: ''!
undefinedColumnWidth
	"This is a constant that defines a column width is undefined, then the layout will try to arrange 
	 it by itself."
	^ 0! !

!SpecFocusOrder commentStamp: ''!
A SpecFocusOrder manage the path of focus between widgets.

I use a collection (presenters) to keep widgets I managed. When I reach the end of the collection, I try to give the focus at the parent in the hierarchy, if it is nil I loop.

I provide the following methods
- add: and addLast: to add a widget in my collection
- giveFocusToNextFrom:for: and giveFocusToPreviousFrom:for: to make me change the focus, the first argument is presenter who leave the focus and the second is the current model in the hierarchy.
- ifEmpty:ifNotEmpty: and ifNotEmpty: are send in my collection.
- presenters is the getter of my collection.
- removeAll to remove all my widgets.

My super class is not OrderedCollection because it could be a problem for the devellopement of another behaviour.!
!SpecFocusOrder methodsFor: 'accessing' stamp: ''!
add: aPresenter
	presenters add: aPresenter! !

!SpecFocusOrder methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	presenters := OrderedCollection new.! !

!SpecFocusOrder methodsFor: 'accessing' stamp: ''!
presenters
	^ presenters! !

!SpecFocusOrder methodsFor: 'to clean later' stamp: ''!
removeAll
^ presenters removeAll! !

!SpecFocusOrder methodsFor: 'operating' stamp: ''!
giveFocusToPreviousFrom: aPresenter for: aModel
	| focus |
	focus := self presenters.
	(focus includes: aPresenter)
		ifTrue: [ | index previous |
			index := (focus indexOf: aPresenter) - 1.
			index > 0
				ifTrue: [ previous := focus at: index.
					previous takeLastKeyboardFocus.
					^ true ] ].
	^ aModel owner
		ifNil: [ | next |
			next := focus at: focus size ifAbsent: [ ^ false ].
			next takeLastKeyboardFocus.
			true ]
		ifNotNil: [ aModel owner giveFocusToPreviousFrom: aModel.
			true ]	" I loop "! !

!SpecFocusOrder methodsFor: 'to clean later' stamp: ''!
ifEmpty: aBlock ifNotEmpty: aBlock2
	^ presenters
		ifEmpty: aBlock
		ifNotEmpty: aBlock2! !

!SpecFocusOrder methodsFor: 'operating' stamp: ''!
giveFocusToNextFrom: aPresenter for: aModel
	"aPresenter is the object what currently get the focus, aModel is the object use to call the good parent in a complex hierarchy"

	| focus |
	focus := self presenters.
	(focus includes: aPresenter)
		ifTrue: [ | index next |
			index := (focus indexOf: aPresenter) + 1.
			index <= focus size
				ifTrue: [ next := focus at: index.
					next takeKeyboardFocus.
					^ true ] ].
	^ aModel owner
		ifNil: [ | next |
			next := focus at: 1 ifAbsent: [ ^ false ].
			next takeKeyboardFocus.
			true ]
		ifNotNil: [ aModel owner giveFocusToNextFrom: aModel.
			true ]	"loop if there is no parent, else give it the focus"! !

!SpecFocusOrder methodsFor: 'accessing' stamp: ''!
addLast: aPresenter
	presenters addLast: aPresenter! !

!SpecFocusOrder methodsFor: 'to clean later' stamp: ''!
ifNotEmpty: aBlock
	^ presenters ifNotEmpty: aBlock! !

!SpecInterpreter commentStamp: ''!
A SpecInterpreter is a interpreter for spec presenters!
!SpecInterpreter methodsFor: 'interpreting-private' stamp: ''!
performNextSelectorAndIncrementIndex
	| args numArgs selector |

	selector := (arrayToInterpret at: index).
	selector isArray not
		ifTrue: [ 
			selector := selector asSymbol.
			numArgs := selector numArgs.
			args := arrayToInterpret copyFrom: index + 1 to: index + numArgs ]
		ifFalse: [ 
			"Here I assume that if it's not a symbol, it's a collection"
			| array |
			array := selector.
			selector := array first.
			numArgs := 0.
			args := array allButFirst ].
	
	args := args collect: [ :each | self class private_interpretASpec: each model: model selector: spec selector ].

	index := index + numArgs + 1.
	^ self actionToPerformWithSelector: selector arguments: args! !

!SpecInterpreter methodsFor: 'interpreting' stamp: ''!
interpretASpec: aPresenter model: aModel  selector: aSelector
	
	self model: aModel.
	^ self interpretASpec: aPresenter selector: aSelector! !

!SpecInterpreter methodsFor: 'interpreting-private' stamp: ''!
retrieveSpecFrom: aPresenter selector: aSelector

	((self model respondsTo: #needRebuild) and: [ self model needRebuild not and: [ self model spec notNil ] ])
		ifTrue: [
			spec := self model spec.
			self model needRebuild: true.
			((spec respondsTo: #isRedrawable) and: [ spec instance isSpecAdapter ])
				ifFalse: [ spec := self computeSpecFrom: arrayToInterpret first selector: aSelector ]
				ifTrue: [ 
					spec isRedrawable
						ifTrue: [ spec removeSubWidgets ]
						ifFalse: [ ^ spec instance ] ] ]
		ifFalse: [ spec := self computeSpecFrom: arrayToInterpret first selector: aSelector ].
	
	aSelector
		ifNil: [ aPresenter isSpecLayout ifTrue: [ spec selector: aPresenter selector ] ]
		ifNotNil: [ spec selector: aSelector ].
		
	^ nil! !

!SpecInterpreter methodsFor: 'interpreting-private' stamp: ''!
computeSpecFrom: aSymbol selector: aSelector
	| instance |

	instance := (aSymbol isSymbol and: [ aSymbol ~= #model ])
		ifTrue: [ | result |
			result := self convertSymbolOfClassToInstance: aSymbol.
			result isSpecContainer
				ifTrue: [ 
					result := result buildAdapterWithSpec.
					model addDependent: result ].
			result ]
		ifFalse: [ self class private_interpretASpec: aSymbol model: model selector: aSelector ].
		
	^ SpecWrapper
		instance: instance
		selector: aSelector! !

!SpecInterpreter methodsFor: 'bindings' stamp: ''!
convertSymbolOfClassToInstance: aSymbol
	| translatedSymbol |
	
	translatedSymbol := self bindings translateSymbol: aSymbol.
	
	^ (Smalltalk 
		at: translatedSymbol
		ifAbsent: [ ^ translatedSymbol ]) new! !

!SpecInterpreter methodsFor: 'interpreting-private' stamp: ''!
actionToPerformWithSelector: selector arguments: args

	^ spec instance perform: selector withArguments: args! !

!SpecInterpreter methodsFor: 'interpreting' stamp: ''!
interpretASpec: aPresenter selector: aSelector
	aPresenter ifNil: [ ^ nil ].
	
	(self extractArrayToInterpretFrom: aPresenter) ifNotNil: [ :result | ^ result ].
	
	(self retrieveSpecFrom: aPresenter selector: aSelector)
		ifNotNil: [ :instance | ^ instance ].

	index := 2.
	[ index <= arrayToInterpret size ]
		whileTrue: [ 
			| newInstance |
			
			newInstance := self performNextSelectorAndIncrementIndex.
			
			index > arrayToInterpret size
				ifTrue: [ ^ self returnInterpretationOf: newInstance ].
			spec instance: newInstance ].	
			
	"If you get here, there is a problem. Must probably it comes from the Spec which is wrongly defined"
	self assert: arrayToInterpret size < 2.
	
	(model respondsTo: #spec:)
		ifTrue: [ model spec: spec ].
		
	^ spec instance! !

!SpecInterpreter methodsFor: 'interpreting-private' stamp: ''!
returnInterpretationOf: newInstance
	| result |
	(model respondsTo: #spec:) ifTrue: [ model spec: spec ].
	result := self class private_interpretASpec: newInstance model: spec instance selector: spec selector.
	^ (result isKindOf: ComposablePresenter)
		ifTrue: [ | return |
			return := result private_buildWithSpec.
			return ]
		ifFalse: [ result ]! !

!SpecInterpreter methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!SpecInterpreter methodsFor: 'bindings' stamp: ''!
bindings

	^ self class bindings! !

!SpecInterpreter methodsFor: 'interpreting-private' stamp: ''!
extractArrayToInterpretFrom: aFragment

	arrayToInterpret := aFragment.
	
	aFragment isSpecLayout
		ifTrue: [ arrayToInterpret := aFragment asArray ].
	
	(arrayToInterpret isCollection and: [ arrayToInterpret isSequenceable ])
		ifFalse: [ ^ arrayToInterpret ].
	
	(aFragment isString or: [ aFragment isText ])
		ifTrue: [ 
			^ aFragment == #model
				ifTrue: [ model ]
				ifFalse: [ self convertSymbolOfClassToInstance: aFragment ] ].
	^ nil! !

!SpecInterpreter methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!SpecInterpreter class methodsFor: 'protocol' stamp: ''!
interpretASpec: aPresenter model: aModel selector: aSelector
	| result |
	
	 [ result :=  self 
				private_interpretASpec: aPresenter
				model: aModel
				selector: aSelector ] ensure: [ self hardResetBindings ].
	^ result! !

!SpecInterpreter class methodsFor: 'protocol' stamp: ''!
interpretASpec: aSpec model: aModel
	
	^ self
		interpretASpec: aSpec
		model: aModel
		selector: nil! !

!SpecInterpreter class methodsFor: 'accessing' stamp: ''!
hardResetBindings

	bindings := nil! !

!SpecInterpreter class methodsFor: 'private' stamp: ''!
private_interpretASpec: aPresenter model: aModel selector: aSelector
	
	^ self new
		interpretASpec: aPresenter
		model: aModel
		selector: aSelector! !

!SpecInterpreter class methodsFor: 'accessing' stamp: ''!
bindings: anAdapterBinding

	bindings := anAdapterBinding! !

!SpecInterpreter class methodsFor: 'private' stamp: ''!
private_buildWidgetFor: aComposablePresenter withSpec: aSymbol
	
	^ self private_interpretASpec: (aComposablePresenter retrieveSpec: aSymbol) model: aComposablePresenter selector: aSymbol! !

!SpecInterpreter class methodsFor: 'private' stamp: ''!
defaultBindings
	
	^ (CurrentSpecDefaultBindings value ifNil: [ self environment at: #MorphicAdapterBindings]) new
	! !

!SpecInterpreter class methodsFor: 'accessing' stamp: ''!
bindings

	^ self defaultBindings ! !

!SpecLayout commentStamp: ''!
A SpecPresenter is a object used to describe a user interface!
!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
newColumn: aBlock left: aNumber
	
	self newColumn: aBlock left: aNumber right: nil! !

!SpecLayout methodsFor: 'commands' stamp: ''!
newColumn: aBlock  width: aNumber
	
	self newColumn: aBlock  origin: 0@0 corner: 0@1 offsetOrigin: 0@0 offsetCorner: aNumber @0! !

!SpecLayout methodsFor: 'testing' stamp: ''!
isSpecLayout

	^ true! !

!SpecLayout methodsFor: 'accessing' stamp: ''!
commands
	^ commands! !

!SpecLayout methodsFor: 'converting' stamp: ''!
addVSplitter

	self commands add: (SpecSplitterVertical commands: self commands)! !

!SpecLayout methodsFor: 'private' stamp: ''!
computeNotSplitterWidget: widget
	
	self
		setOffsetsFor: widget
		top: widget topOffset
		left: widget leftOffset
		bottom: widget bottomOffset
		right: widget rightOffset
		borderWidth: self class windowBorderWidth.
	
	widget generateArguments.
	widget asSpecElements do: [ :el | result add: el ]! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock right: aNumber
	
	self add: aBlock top: nil bottom: nil left: nil right: aNumber! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
newColumn: aBlock right: aNumber
	
	self newColumn: aBlock left: nil right: aNumber! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock left: aNumber
	
	self add: aBlock top: nil bottom: nil left: aNumber right: nil! !

!SpecLayout methodsFor: 'initialization' stamp: ''!
setRightOffset: right for: windowBorderWidth borderWidth: widget

	widget rightFraction = 1
		ifTrue: [ 
			right isZero
				ifTrue: [ widget rightOffset: windowBorderWidth negated ]
				ifFalse: [ widget rightOffset: right - self splitterWidth ] ]! !

!SpecLayout methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	
	type := #ContainerPresenter.
	self commands: OrderedCollection new.! !

!SpecLayout methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock withSpec: aSpec right: aNumber
	
	self add: aBlock withSpec: aSpec top: nil bottom: nil left: nil right: aNumber! !

!SpecLayout methodsFor: 'private' stamp: ''!
computeSplitters

	(self commands select: [ :e | e isSplitter ])
		do: [ :e | 
			shouldCheckSplitters := true.
			e generateArguments.
			e asSpecElements do: [ :el | result add: el ] ].
	shouldCheckSplitters
		ifTrue: [ result add: #checkSplitters ]! !

!SpecLayout methodsFor: 'initialization' stamp: ''!
setBottomOffset: bottom for: widget borderWidth: windowBorderWidth

	widget bottomFraction = 1
		ifTrue: [ 
			bottom isZero
				ifTrue: [ widget bottomOffset: windowBorderWidth negated ]
				ifFalse: [ widget bottomOffset: bottom - self splitterWidth ] ]! !

!SpecLayout methodsFor: 'commands' stamp: ''!
newRow: aBlock origin: originPoint corner: cornerPoint offsetOrigin: ooPoint offsetCorner: ocPoint
	| block |
	
	block := aBlock.
	block isBlock ifFalse: [ block := [:r | r add: aBlock ] ].
	
	commands add: (SpecLayoutAddRow
							block: block
							layoutFrame: ((originPoint corner: cornerPoint) asSpecLayoutFrame 
										topLeftOffset: ooPoint;
										bottomRightOffset: ocPoint)).! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock withSpec: aSpec bottom: aNumber
	
	self add: aBlock withSpec: aSpec top: nil bottom: aNumber left: nil right: nil! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
newRow: aBlock top: top bottom: bottom
	| layout |
	
	layout := self computeLayoutFromTop: top bottom: bottom left: nil right: nil.
		
	self 
		newRow: aBlock
		origin: layout first
		corner: layout second
		offsetOrigin: layout third
		offsetCorner: layout fourth! !

!SpecLayout methodsFor: 'commands' stamp: ''!
newColumn: aBlock origin: originPoint corner: cornerPoint offsetOrigin: ooPoint offsetCorner: ocPoint
	| block |
	
	block := aBlock.
	block isBlock ifFalse: [ block := [:c | c add: aBlock ] ].
	
	commands add: (SpecLayoutAddColumn
							block: block
							layoutFrame: ((originPoint corner: cornerPoint) asSpecLayoutFrame
										topLeftOffset: ooPoint;
										bottomRightOffset: ocPoint)).! !

!SpecLayout methodsFor: 'private' stamp: ''!
computeNotSplitterWidgets

	(self commands reject: [ :e | e isSplitter ]) 
		do: [ :e | self computeNotSplitterWidget: e ]! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock withSpec: aSpec top: top bottom: bottom left: left right: right
	| layout |
	
	layout := self computeLayoutFromTop: top bottom: bottom left: left right: right.
		
	self 
		add: aBlock
		withSpec: aSpec 
		origin: layout first
		corner: layout second
		offsetOrigin: layout third
		offsetCorner: layout fourth! !

!SpecLayout methodsFor: 'commands' stamp: ''!
add: modelGetter withSpec: aSymbol origin: originPoint corner: cornerPoint offsetOrigin: ooPoint offsetCorner: ocPoint

	commands add: (SpecLayoutAddWithSpec 
							subwidget: modelGetter 
							spec: aSymbol 
							layoutFrame: ((originPoint corner: cornerPoint) asSpecLayoutFrame 
												topLeftOffset: ooPoint;
												bottomRightOffset: ocPoint))! !

!SpecLayout methodsFor: 'private' stamp: ''!
computeLayoutFromTop: top bottom: bottom left: left right: right
	| originY offsetCornerX cornerX offsetOriginY offsetCornerY cornerY originX offsetOriginX |
	
	originX := left isFloat
		ifTrue: [ left ]
		ifFalse: [ 0 ].
	originY := top isFloat
		ifTrue: [ top ]
		ifFalse: [ 0 ].
	cornerX := right isFloat
		ifTrue: [ 1 - right ]
		ifFalse: [ 1 ].
	cornerY := bottom isFloat
		ifTrue: [ 1 - bottom ]
		ifFalse: [ 1 ].
	offsetOriginX := left isInteger
		ifTrue: [ left ]
		ifFalse: [ 0 ].
	offsetOriginY := top isInteger
		ifTrue: [ top ]
		ifFalse: [ 0 ].
	offsetCornerX := right isInteger
		ifTrue: [ right negated ]
		ifFalse: [ 0 ].
	offsetCornerY := bottom isInteger
		ifTrue: [ bottom negated ]
		ifFalse: [ 0 ].
		
	^ { originX@originY. cornerX@cornerY. offsetOriginX@offsetOriginY. offsetCornerX@offsetCornerY }! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock withSpec: aSpec left: aNumber
	
	self add: aBlock withSpec: aSpec top: nil bottom: nil left: aNumber right: nil! !

!SpecLayout methodsFor: 'commands' stamp: ''!
add: aSpec 
	
	self add: aSpec origin: 0@0 corner: 1@1! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock withSpec: aSpec left: left right: right
	
	self add: aBlock withSpec: aSpec top: nil bottom: nil left: left right: right! !

!SpecLayout methodsFor: 'commands' stamp: ''!
send: aSelector withArguments: arguments


	self commands add: (SpecLayoutSend
							selector: aSelector
							arguments: arguments).! !

!SpecLayout methodsFor: 'commands' stamp: ''!
newColumn: aBlock origin: originPoint corner: cornerPoint 

	self newColumn: aBlock origin: originPoint corner: cornerPoint offsetOrigin: 0@0 offsetCorner: 0@0! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock bottom: aNumber
	
	self add: aBlock top: nil bottom: aNumber left: nil right: nil! !

!SpecLayout methodsFor: 'converting' stamp: ''!
asArray
	^ (OrderedCollection new
		add: self type;
		addAll: self privateAsArray;
		yourself) asArray! !

!SpecLayout methodsFor: 'converting' stamp: ''!
addHSplitter

	self commands add: (SpecSplitterHorizontal commands: self commands)! !

!SpecLayout methodsFor: 'accessing' stamp: ''!
commands: anObject
	commands := anObject! !

!SpecLayout methodsFor: 'accessing' stamp: ''!
type: anObject
	type := anObject! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock left: left right: right
	
	self add: aBlock top: nil bottom: nil left: left right: right! !

!SpecLayout methodsFor: 'commands' stamp: ''!
add: aSpec origin: originPoint corner: cornerPoint offsetOrigin: ooPoint offsetCorner: ocPoint
	
	commands add: (SpecLayoutAdd 
							subwidget: aSpec
							layoutFrame: 
								((originPoint corner: cornerPoint) asSpecLayoutFrame 
									topLeftOffset: ooPoint;
									bottomRightOffset: ocPoint ))! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock withSpec: aSpec top: aNumber
	
	self add: aBlock withSpec: aSpec top: aNumber bottom: nil left: nil right: nil! !

!SpecLayout methodsFor: 'commands' stamp: ''!
add: aSpec origin: originPoint corner: cornerPoint 

	self add: aSpec origin: originPoint corner: cornerPoint offsetOrigin: 0@0 offsetCorner: 0@0! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock top: top bottom: bottom
	
	self add: aBlock top: top bottom: bottom left: nil right: nil! !

!SpecLayout methodsFor: 'initialization' stamp: ''!
setLeftOffset: left for: widget borderWidth: windowBorderWidth

	widget leftFraction = 0
		ifTrue: [ 
			left isZero
				ifTrue: [ widget leftOffset: windowBorderWidth ]
				ifFalse: [ widget leftOffset: left + self splitterWidth ] ]
		ifFalse: [ 
			widget leftFraction = 1
				ifFalse: [ widget leftOffset: left + self splitterWidth ] ]! !

!SpecLayout methodsFor: 'accessing' stamp: ''!
type
	^ type! !

!SpecLayout methodsFor: 'commands' stamp: ''!
add: modelGetter withSpec: aSymbol origin: originPoint corner: cornerPoint 

	self add: modelGetter withSpec: aSymbol origin: originPoint corner: cornerPoint offsetOrigin: 0@0 offsetCorner: 0@0! !

!SpecLayout methodsFor: 'initialization' stamp: ''!
setTopOffset: top for: widget borderWidth: windowBorderWidth

	widget topFraction = 0
		ifTrue: [
			top isZero
				ifTrue: [ widget topOffset: windowBorderWidth ]
				ifFalse: [ widget topOffset: top + self splitterWidth ] ]
		ifFalse: [ 
			widget topFraction = 1
				ifFalse: [ widget topOffset: top + self splitterWidth ] ]! !

!SpecLayout methodsFor: 'converting' stamp: ''!
resetArrayComputation
	result := OrderedCollection new.
	shouldCheckSplitters := false! !

!SpecLayout methodsFor: 'commands' stamp: ''!
newRow: aBlock 
	
	self newRow: aBlock origin: 0@0 corner: 1@1! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock top: aNumber

	self add: aBlock top: aNumber bottom: nil left: nil right: nil! !

!SpecLayout methodsFor: 'private' stamp: ''!
setOffsetsFor: widget top: top left: left bottom: bottom right: right borderWidth: windowBorderWidth

	self setRightOffset: right for: windowBorderWidth borderWidth: widget.
	self setLeftOffset: left for: widget borderWidth: windowBorderWidth.
	self setBottomOffset: bottom for: widget borderWidth: windowBorderWidth.
	self setTopOffset: top for: widget borderWidth: windowBorderWidth! !

!SpecLayout methodsFor: 'commands' stamp: ''!
newColumn: aBlock 
	
	self newColumn: aBlock origin: 0@0 corner: 1@1! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
newColumn: aBlock left: left right: right
	| layout |
	
	layout := self computeLayoutFromTop: nil bottom: nil left: left right: right.

	self 
		newColumn: aBlock
		origin: layout first
		corner: layout second
		offsetOrigin: layout third
		offsetCorner: layout fourth! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock withSpec: aSpec top: top bottom: bottom
	
	self add: aBlock withSpec: aSpec top: top bottom: bottom left: nil right: nil! !

!SpecLayout methodsFor: 'converting' stamp: ''!
privateAsArray

	self resetArrayComputation.
	
	self computeNotSplitterWidgets.
	self computeSplitters.
	
	^ result asArray! !

!SpecLayout methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
newRow: aBlock top: aNumber
	
	self newRow: aBlock top: aNumber bottom: nil! !

!SpecLayout methodsFor: 'accessing - defaults' stamp: ''!
splitterWidth
	
	^ 4! !

!SpecLayout methodsFor: 'commands' stamp: ''!
newRow: aBlock origin: originPoint corner: cornerPoint 

	self newRow: aBlock origin: originPoint corner: cornerPoint offsetOrigin: 0@0 offsetCorner: 0@0! !

!SpecLayout methodsFor: 'commands' stamp: ''!
send: aSelector
	
	self send: aSelector withArguments: #()! !

!SpecLayout methodsFor: 'commands' stamp: ''!
newRow: aBlock height: aNumber
	
	self newRow: aBlock origin: 0@0 corner: 1@0 offsetOrigin: 0@0 offsetCorner: 0@aNumber ! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
newRow: aBlock bottom: aNumber
	
	self newRow: aBlock top: nil bottom: aNumber! !

!SpecLayout methodsFor: 'commands-advanced' stamp: ''!
add: aBlock top: top bottom: bottom left: left right: right
	| layout |
	
	layout := self computeLayoutFromTop: top bottom: bottom left: left right: right.
		
	self 
		add: aBlock
		origin: layout first
		corner: layout second
		offsetOrigin: layout third
		offsetCorner: layout fourth! !

!SpecLayout methodsFor: 'commands' stamp: ''!
add: modelGetter withSpec: aSymbol 
	
	self add: modelGetter withSpec: aSymbol origin: 0@0 corner: 1@1! !

!SpecLayout class methodsFor: 'constants' stamp: ''!
windowBorderWidth

	^ 0! !

!SpecLayout class methodsFor: 'instance creation' stamp: ''!
composed

	^self new
		type: #ContainerPresenter;
		yourself! !

!SpecLayoutAdd commentStamp: ''!
A SpecLayoutAdd represents the action to add a subwidget into a spec layout!
!SpecLayoutAdd methodsFor: 'accessing' stamp: ''!
subwidget
	^ subwidget! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
topOffset: aNumber

	layoutFrame topOffset: aNumber! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
leftOffset: aNumber

	^ layoutFrame leftOffset: aNumber! !

!SpecLayoutAdd methodsFor: 'accessing' stamp: ''!
layoutFrame

	^ layoutFrame! !

!SpecLayoutAdd methodsFor: 'instance creation' stamp: ''!
generateArguments
	
	self arguments: {{subwidget .#layout:. layoutFrame generateSpec}}.! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
rightOffset

	^ layoutFrame rightOffset! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
rightFraction

	^ layoutFrame rightFraction! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
leftFraction

	^ layoutFrame leftFraction ! !

!SpecLayoutAdd methodsFor: 'instance creation' stamp: ''!
subwidget: aSpec fractions: frac offsets: off

	subwidget := aSpec isSymbol
				ifTrue: [{#model. aSpec}]
				ifFalse: [
					aSpec isCollection
						ifTrue: [
							aSpec isEmpty 
								ifTrue: [ "should raise an error" ]
								ifFalse: [ aSpec first == #model 
											ifTrue: [ aSpec ]
											ifFalse: [ {#model}, aSpec ]]]
						ifFalse: [ 
							"Not a symbol or a collection. We assume it's an object to add directly (like a morph by example)"
							aSpec ]].
	self fractions: frac.
	self offsets: off.
	
	self generateArguments! !

!SpecLayoutAdd methodsFor: 'accessing' stamp: ''!
layoutFrame: newFrame

	layoutFrame := newFrame asSpecLayoutFrame! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
rightOffset: aNumber

	layoutFrame rightOffset: aNumber! !

!SpecLayoutAdd methodsFor: 'accessing' stamp: ''!
subwidget: anObject
	subwidget := anObject! !

!SpecLayoutAdd methodsFor: 'accessing' stamp: ''!
fractions
	^ layoutFrame fractionRectangle! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
bottomOffset: aNumber

	layoutFrame bottomOffset: aNumber! !

!SpecLayoutAdd methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self selector: #add:.
	layoutFrame := SpecLayoutFrame identity! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
rightFraction: aNumber

	^ layoutFrame rightFraction: aNumber! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
bottomFraction

	^ layoutFrame bottomFraction! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
topFraction: aNumber

	layoutFrame topFraction: aNumber! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
leftOffset

	^ layoutFrame leftOffset! !

!SpecLayoutAdd methodsFor: 'accessing' stamp: ''!
offsets
	"to deprecate 
	"
	self flag: #fix.
	^ layoutFrame leftOffset  @ layoutFrame topOffset corner:  layoutFrame rightOffset  @ layoutFrame bottomOffset ! !

!SpecLayoutAdd methodsFor: 'instance creation' stamp: ''!
subwidget: aSpec layoutFrame: aLayoutFrame
	
	subwidget := aSpec isSymbol
				ifTrue: [{#model. aSpec}]
				ifFalse: [
					aSpec isCollection
						ifTrue: [
							aSpec isEmpty 
								ifTrue: [ "should raise an error" ]
								ifFalse: [ aSpec first == #model 
											ifTrue: [ aSpec ]
											ifFalse: [ {#model}, aSpec ]]]
						ifFalse: [ 
							"Not a symbol or a collection. We assume it's an object to add directly (like a morph by example)"
							aSpec ]].
	
	layoutFrame := aLayoutFrame.
	self generateArguments! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
leftFraction: aNumber

	layoutFrame leftFraction: aNumber
! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
topOffset

	^ layoutFrame topOffset! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
bottomOffset

	^ layoutFrame bottomOffset ! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
bottomFraction: aNumber

	layoutFrame bottomFraction: aNumber ! !

!SpecLayoutAdd methodsFor: 'protocol' stamp: ''!
topFraction

	^ layoutFrame topFraction! !

!SpecLayoutAdd class methodsFor: 'instance creation' stamp: ''!
subwidget: subwidget layoutFrame: aLayoutFrame

	^ self new
		subwidget: subwidget 
		layoutFrame: aLayoutFrame asSpecLayoutFrame; 
		yourself! !

!SpecLayoutAddColumn commentStamp: ''!
A SpecLayoutAddColumn is an action representing the addition of a column to a layout!
!SpecLayoutAddColumn methodsFor: 'instance creation' stamp: ''!
block: aBlock layoutFrame: aLayoutFrame

	| row |
	row := SpecColumnLayout composed.
	aBlock value: row.
	subwidget := row asArray.
	self layoutFrame: aLayoutFrame.
	self generateArguments! !

!SpecLayoutAddColumn class methodsFor: 'instance creation' stamp: ''!
block: aBlock layoutFrame: aLayoutFrame

	^ self new
			block: aBlock 
			layoutFrame: aLayoutFrame;
			yourself! !

!SpecLayoutAddRow commentStamp: ''!
A SpecLayoutAddRow is an action representing the addition of a row to a layout
!
!SpecLayoutAddRow methodsFor: 'instance creation' stamp: ''!
block: aBlock layoutFrame: aLayoutFrame

	| row |
	row := SpecRowLayout composed.
	aBlock value: row.
	subwidget := row asArray.
	self layoutFrame: aLayoutFrame.
	self generateArguments! !

!SpecLayoutAddRow class methodsFor: 'instance creation' stamp: ''!
block: aBlock layoutFrame: aLayoutFrame

	^ self new
			block: aBlock 
			layoutFrame: aLayoutFrame;
			yourself! !

!SpecLayoutAddWithSpec commentStamp: ''!
A SpecLayoutAddWithSpec is an action representing an add in the spec layout with a spec selector precised!
!SpecLayoutAddWithSpec methodsFor: 'instance creation' stamp: ''!
subwidget: sub spec: aSpecSelector layoutFrame: aFrameLayout

	self subwidget: (sub isArray 
						ifTrue: [ #(model), sub , {#retrieveSpec:. aSpecSelector} ]
						ifFalse: [ {#model. sub . #retrieveSpec: . aSpecSelector } ]).
						
	self layoutFrame: aFrameLayout.
	self generateArguments! !

!SpecLayoutAddWithSpec class methodsFor: 'instance creation' stamp: ''!
subwidget: subwidget spec: aSpecSelector layoutFrame: aLayoutFrame

	^ self new
		subwidget: subwidget 
		spec: aSpecSelector 
		layoutFrame:  aLayoutFrame;
		yourself! !

!SpecLayoutFrame commentStamp: ''!
I am a wrapper for the layout of widget.

Each framework can then adapt me as it wants in its adapters!
!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
bottomOffset: anObject
	
	bottomOffset := anObject! !

!SpecLayoutFrame methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.

	bottomFraction := 1.
	bottomOffset := 0.
	leftFraction := 0.
	leftOffset := 0.
	rightFraction := 1.
	rightOffset := 0.
	topFraction := 0.
	topOffset := 0.! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
rightFraction: anObject
	
	rightFraction := anObject! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
bottomFraction
	
	^ bottomFraction! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
topLeftOffset: aPoint

	topOffset := aPoint y.
	leftOffset := aPoint x.! !

!SpecLayoutFrame methodsFor: 'testing' stamp: ''!
hasNoOffsets

	^ leftOffset = 0 and: [rightOffset = 0  and: [ topOffset = 0 and: [ bottomOffset = 0 ]]].
	! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
topOffset: anObject
	
	topOffset := anObject! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
leftOffset: anObject
	
	leftOffset := anObject! !

!SpecLayoutFrame methodsFor: 'converting' stamp: ''!
asArray
	 
	^ { leftFraction . 
		topFraction .
		rightFraction .
		bottomFraction .	
		leftOffset .
		topOffset .
		rightOffset .
		bottomOffset } ! !

!SpecLayoutFrame methodsFor: 'converting' stamp: ''!
asSpecLayoutFrame

	^ self! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
rightOffset
	
	^ rightOffset! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
rightFraction
	
	^ rightFraction! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
leftFraction
	
	^ leftFraction! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
leftOffset
	
	^ leftOffset! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
topFraction: anObject
	
	topFraction := anObject! !

!SpecLayoutFrame methodsFor: 'generation' stamp: ''!
generateSpec

	^ self asArray generateSpec! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
bottomRightOffset: aPoint

	bottomOffset := aPoint y.
	rightOffset := aPoint x.! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
leftFraction: anObject
	
	leftFraction := anObject! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
rightOffset: anObject
	
	rightOffset := anObject! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
bottomOffset
	
	^ bottomOffset! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
topOffset
	
	^ topOffset! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
bottomFraction: anObject
	
	bottomFraction := anObject! !

!SpecLayoutFrame methodsFor: 'accessing' stamp: ''!
topFraction
	
	^ topFraction! !

!SpecLayoutFrame methodsFor: '*Spec-MorphicAdapters' stamp: ''!
asMorphicLayout
	
	^ LayoutFrame identity
		topFraction: self topFraction;
		topOffset: self topOffset;
		bottomFraction: self bottomFraction;
		bottomOffset: self bottomOffset;
		rightFraction: self rightFraction;
		rightOffset: self rightOffset;
		leftFraction: self leftFraction;
		leftOffset: self leftOffset;
		yourself! !

!SpecLayoutFrame class methodsFor: 'instance creation' stamp: ''!
identity
	"by default a layout frame is initialized to represent the identity transformation"
	^ self new! !

!SpecLayoutProperties commentStamp: ''!
Used to describe properties for layouts in Spec!
!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
wrapCentering
	^#topLeft! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
maxCellSize
	^SmallInteger maxVal! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
wrapDirection
	^#none! !

!SpecLayoutProperties methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	hResizing := vResizing := #rigid.
	disableLayout := false.! !

!SpecLayoutProperties methodsFor: 'accessing' stamp: ''!
hResizing
	^hResizing! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
cellSpacing
	"Default"
	^#none! !

!SpecLayoutProperties methodsFor: 'accessing' stamp: ''!
disableTableLayout
	^disableLayout! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
layoutInset
	^0! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
listCentering
	"Default"
	^#topLeft! !

!SpecLayoutProperties methodsFor: 'accessing' stamp: ''!
hResizing: aSymbol
	hResizing := aSymbol! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
minCellSize
	^0! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
reverseTableCells
	^false! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
rubberBandCells
	^false! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
cellPositioning
	^#center! !

!SpecLayoutProperties methodsFor: 'accessing' stamp: ''!
disableTableLayout: aBool
	disableLayout := aBool! !

!SpecLayoutProperties methodsFor: 'accessing' stamp: ''!
vResizing
	^vResizing! !

!SpecLayoutProperties methodsFor: 'accessing' stamp: ''!
vResizing: aSymbol
	vResizing := aSymbol! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
cellInset
	"Default"
	^0! !

!SpecLayoutProperties methodsFor: 'testing' stamp: ''!
includesTableProperties
	^false! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
listDirection
	"Default"
	^#topToBottom! !

!SpecLayoutProperties methodsFor: 'converting' stamp: ''!
asTableLayoutProperties
	^(SpecTableLayoutProperties new)
		hResizing: self hResizing;
		vResizing: self vResizing;
		disableTableLayout: self disableTableLayout;
		yourself! !

!SpecLayoutProperties methodsFor: 'initialize' stamp: ''!
initializeFrom: defaultProvider
	"Initialize the receiver from a default provider"
	self hResizing: defaultProvider hResizing.
	self vResizing: defaultProvider vResizing.
	self disableTableLayout: defaultProvider disableTableLayout.! !

!SpecLayoutProperties methodsFor: 'table defaults' stamp: ''!
listSpacing
	"Default"
	^#none! !

!SpecLayoutSend commentStamp: ''!
A SpecLayoutSend is a spec layout action used when a selector is sent to the layout!
!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
bottomOffset: aNumber

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
rightFraction: aNumber

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
bottomFraction

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
topOffset: aNumber

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
leftOffset: aNumber

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
rightOffset

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
rightFraction

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
leftFraction

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
leftOffset

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
topFraction: aNumber

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
leftFraction: aNumber

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
rightOffset: aNumber

	^ 0! !

!SpecLayoutSend methodsFor: 'testing' stamp: ''!
isSplitter

	^ false! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
bottomOffset

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
topOffset

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
asSpecElements

	^ {self selector.}, self arguments! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
bottomFraction: aNumber

	^ 0! !

!SpecLayoutSend methodsFor: 'protocol' stamp: ''!
topFraction

	^ 0! !

!SpecLayoutSend class methodsFor: 'instance creation' stamp: ''!
selector: selector arguments: arguments

	^ self new
		arguments: arguments;
		selector: selector;
		yourself! !

!SpecPragmaCollector commentStamp: ''!
A SpecPragmaCollector is a specialized PragmaCollector.

Sonce we just want specs defined on class side, we do not have to check the whole system, then to restrain.!
!SpecPragmaCollector methodsFor: 'accessing' stamp: ''!
behavior: anObject
	behavior := anObject! !

!SpecPragmaCollector methodsFor: 'private' stamp: ''!
allPragmasIn: aClass

	^ Array streamContents: [:stream | aClass pragmasDo: [:pragma | stream nextPut: pragma ]]! !

!SpecPragmaCollector methodsFor: 'private' stamp: ''!
allPragmas

	^ self allPragmasIn: (self behavior ifNil: [ ^ #() ])! !

!SpecPragmaCollector methodsFor: 'system changes' stamp: ''!
installSystemNotifications
	"We do not need to register anything for spec, and if we do it will make it really slow"! !

!SpecPragmaCollector methodsFor: 'initializing' stamp: ''!
reset
	"reinitialize current system settings"
	self
		noMoreAnnounceWhile: [self collected copy
				do: [:pragma | self removePragma: pragma].
			self allPragmas
				do: [:pragma | self addPragma: pragma]].
	self announce: (PragmaCollectorReset collector: self)! !

!SpecPragmaCollector methodsFor: 'accessing' stamp: ''!
behavior
	^ behavior! !

!SpecPragmaCollector class methodsFor: 'instance creation' stamp: ''!
behavior: aBehavior

	^ self new
		behavior: aBehavior;
		yourself! !

!SpecRowLayout commentStamp: ''!
A SpecRowLayout isthe layout used to specify a new row!
!SpecRowLayout methodsFor: 'private' stamp: ''!
resetArrayComputation

	super resetArrayComputation.
	
	currentOffset := 0.
	currentProportional := 0.
	numberOfProportionals := 0.
	lastFractionIndex := 0.
	autoFractionComputation := true.
	size := self commands size! !

!SpecRowLayout methodsFor: 'private' stamp: ''!
countNumberOfProportionals

	self commands do: [ :e | 
		e layoutFrame hasNoOffsets
			ifTrue: [ 
				(e layoutFrame leftFraction == 0 and: [ e layoutFrame rightFraction == 1 ])
					ifFalse: [ autoFractionComputation := false ].
				numberOfProportionals := numberOfProportionals + 1 ] ]! !

!SpecRowLayout methodsFor: 'private' stamp: ''!
setWidgetLayoutWithOffset: e at: idx
	| y0 y1 |
	
	width := e offsets width.
	y0 := e offsets top.
	y1 := e offsets bottom.
	
	idx = size
		ifTrue: [ 
			e layoutFrame:
				((1 @ 0 corner: 1 @ 1) asSpecLayoutFrame
					topLeftOffset: width negated @ y0;
					bottomRightOffset: 0 @ y1) ]
		ifFalse: [ 
			e layoutFrame:
				((currentProportional @ 0 corner: currentProportional @ 1) asSpecLayoutFrame
					topLeftOffset: currentOffset @ y0;
					bottomRightOffset: (currentOffset + width) @ y1).
			currentOffset := currentOffset + width ]! !

!SpecRowLayout methodsFor: 'converting' stamp: ''!
privateAsArray

	self resetArrayComputation.
	self countNumberOfProportionals.
	
	autoFractionComputation
		ifTrue: [ self manualFractionComputation ]
		ifFalse: [ self autoFractionComputation ].
	
	self shiftLastWidgets.
	
	result addAll: super privateAsArray.
	^ result asArray! !

!SpecRowLayout methodsFor: 'commands' stamp: ''!
add: aSpec width: aNumber
	
	self add: aSpec origin: 0@0 corner: 1@1 offsetOrigin: 0@0 offsetCorner: aNumber @0! !

!SpecRowLayout methodsFor: 'private' stamp: ''!
setWidgetLayoutWithNoOffset: widget at: index delta: delta

	widget layoutFrame: ((currentProportional @ 0 corner: (currentProportional + delta) @ 1) asSpecLayoutFrame leftOffset: currentOffset).
	
	currentOffset := 0.
	currentProportional := currentProportional + delta.
	lastFractionIndex := index! !

!SpecRowLayout methodsFor: 'private' stamp: ''!
autoFractionComputation
	
	self commands
		doWithIndex: [ :e :idx | 
			e layoutFrame hasNoOffsets
				ifTrue: [ | delta |
					delta := e layoutFrame rightFraction - e layoutFrame leftFraction.
					self setWidgetLayoutWithNoOffset: e at: idx delta: delta ]
				ifFalse: [ self setWidgetLayoutWithOffset: e at: idx ] ]! !

!SpecRowLayout methodsFor: 'private' stamp: ''!
manualFractionComputation
	| delta |
	delta := numberOfProportionals isZero
		ifTrue: [ 0 ]
		ifFalse: [ 1 / numberOfProportionals ].
	self commands
		doWithIndex: [ :e :idx | 
			e layoutFrame hasNoOffsets
				ifTrue: [ self setWidgetLayoutWithNoOffset: e at: idx delta: delta ]
				ifFalse: [ self setWidgetLayoutWithOffset: e at: idx ] ]! !

!SpecRowLayout methodsFor: 'private' stamp: ''!
shiftLastWidgets
	| index ante |
	
	(lastFractionIndex > 0 and: [ lastFractionIndex < size ]) ifFalse: [ ^ self ].
	
	index := size - 1.
	[ index > lastFractionIndex ] whileTrue: [ | myWidth |
		ante := self commands at: index.
		index := index - 1.
		myWidth := ante rightOffset - ante leftOffset.
		ante
			leftOffset: (width + myWidth) negated;
			rightOffset: width negated.
		width := width + myWidth ].
	
	self assert: index = lastFractionIndex.
	
	ante := self commands at: index.
	ante layoutFrame rightOffset: width negated! !

!SpecRowLayout methodsFor: 'commands' stamp: ''!
addSplitter

	self commands add: (SpecSplitterVertical commands: self commands)! !

!SpecSplitterHorizontal commentStamp: ''!
A SpecSplitterHorizontal is a description of the addition of a horizontal splitter!
!SpecSplitterHorizontal methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	selector := #newHSplitterAt:.
	layoutFrame := (0 @ 0 corner: 0 @ 0) asSpecLayoutFrame bottomOffset: 1! !

!SpecSplitterHorizontal methodsFor: 'accessing' stamp: ''!
commands
	
	^ commands! !

!SpecSplitterHorizontal methodsFor: 'protocol' stamp: ''!
generateArguments
	| index |

	index := self commands identityIndexOf: self.

	self arguments: { index }! !

!SpecSplitterHorizontal methodsFor: 'accessing' stamp: ''!
commands: anObject
	
	commands := anObject! !

!SpecSplitterHorizontal methodsFor: 'testing' stamp: ''!
isSplitter

	^ true! !

!SpecSplitterHorizontal class methodsFor: 'instance creation' stamp: ''!
commands: commands

	^ self new
		commands: commands;
		yourself! !

!SpecSplitterVertical commentStamp: ''!
A SpecSplitterVertical is the description of the addition of a vertical splitter!
!SpecSplitterVertical methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	selector := #newVSplitterAt:.
	layoutFrame := (0 @ 0 corner: 0 @ 0) asSpecLayoutFrame rightOffset: 1! !

!SpecSplitterVertical methodsFor: 'accessing' stamp: ''!
commands
	
	^ commands! !

!SpecSplitterVertical methodsFor: 'protocol' stamp: ''!
generateArguments
	| index |

	index := self commands identityIndexOf: self.

	self arguments: { index }! !

!SpecSplitterVertical methodsFor: 'accessing' stamp: ''!
commands: anObject
	
	commands := anObject! !

!SpecSplitterVertical methodsFor: 'testing' stamp: ''!
isSplitter

	^ true! !

!SpecSplitterVertical class methodsFor: 'instance creation' stamp: ''!
commands: commands

	^ self new
		commands: commands;
		yourself! !

!SpecStubAbstractAdapter commentStamp: ''!
I am an abstract class providing all the properties shared amongst all the stub adapters. They do not produce real views, only stub objects.
!
!SpecStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
hSpaceFill! !

!SpecStubAbstractAdapter methodsFor: 'factory' stamp: ''!
addModelIn: widgetToBuild withSpecLayout: aSpec
	
	! !

!SpecStubAbstractAdapter methodsFor: 'compatibility' stamp: ''!
bindKeyCombination: aShortcut toAction: aBlock

! !

!SpecStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
add: aWidget! !

!SpecStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
hShrinkWrap
! !

!SpecStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
layout: aLayout! !

!SpecStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
vShrinkWrap! !

!SpecStubAbstractAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ self class new! !

!SpecStubAbstractAdapter methodsFor: 'factory' stamp: ''!
takeKeyboardFocus! !

!SpecStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
vSpaceFill! !

!SpecStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
when: anAnnouncement do: aBlock! !

!SpecStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
hRigid! !

!SpecStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
vRigid! !

!SpecStubAbstractAdapter methodsFor: 'factory' stamp: ''!
useProportionalLayout! !

!SpecStubAbstractAdapter methodsFor: 'protocol' stamp: ''!
removeSubWidgets! !

!SpecStubAdapterBindings commentStamp: ''!
I am used to link the Spec presenter names to the stub adapters that generate no real views.

Useful  for images or UI managers without possible real UI output or  for tests. Can serve as template for real Spec adapters

Usage:

CurrentSpecDefaultBindings value: SpecStubAdapterBindings during: [ 
	ButtonPresenter new openWithSpec.
].!
!SpecStubAdapterBindings methodsFor: 'font' stamp: ''!
defaultFont

	^ StubFixedFont new! !

!SpecStubAdapterBindings methodsFor: 'initialize' stamp: ''!
initializeBindings
	
	^ bindings
		at: #ButtonAdapter				put: #SpecStubButtonAdapter;
		at: #CheckBoxAdapter			put: #SpecStubCheckBoxAdapter;
		at: #ContainerAdapter			put: #SpecStubContainerAdapter;
		at: #DiffAdapter				put: #SpecStubDiffAdapter;
		at: #DropListAdapter			put: #SpecStubDropListAdapter;
		at: #LabelAdapter				put: #SpecStubLabelAdapter;
		at: #ListAdapter				put: #SpecStubListAdapter;
		at: #IconListAdapter			put: #SpecStubIconListAdapter;
		at: #FastTableAdapter			put: #SpecStubFastTableAdapter;
		at: #ImageAdapter				put: #SpecStubImageAdapter;
		at: #MultiColumnListAdapter	put: #SpecStubMultiColumnListAdapter;
		at: #MenuAdapter				put: #SpecStubMenuAdapter;
		at: #MenuGroupAdapter			put: #SpecStubMenuGroupAdapter;
		at: #MenuItemAdapter			put: #SpecStubMenuItemAdapter;
		at: #RadioButtonAdapter		put: #SpecStubRadioButtonAdapter;
		at: #SliderAdapter				put: #SpecStubSliderAdapter;
		at: #TabManagerAdapter		put: #SpecStubTabManagerAdapter;
		at: #TabAdapter					put: #SpecStubTabAdapter;
		at: #TextAdapter				put: #SpecStubTextAdapter;
		at: #TextInputFieldAdapter	put: #SpecStubTextInputFieldAdapter;
		at: #TransferAdapter			put: #SpecStubTransferAdapter;
		at: #TreeAdapter				put: #SpecStubTreeAdapter;
		at: #TreeColumnAdapter		put: #SpecStubTreeColumnAdapter;
		at: #TreeNodeAdapter			put: #SpecStubTreeNodeAdapter;
		at: #WindowAdapter				put: #SpecStubWindowAdapter;
		at: #TickingWindowAdapter	put: #SpecStubTickingWindowAdapter;
		at: #DialogWindowAdapter		put: #SpecStubDialogWindowAdapter;
		yourself! !

!SpecStubButtonAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubButtonView new! !

!SpecStubButtonView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubCheckBoxAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubCheckBoxAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubCheckBoxView new! !

!SpecStubCheckBoxView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubContainerAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubContainerAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubContainerView new! !

!SpecStubContainerView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubDialogWindowAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubDialogWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubDialogWindowView new! !

!SpecStubDialogWindowView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubDiffAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubDiffAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubDiffView new! !

!SpecStubDiffView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubDropListAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubDropListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubDropListView new! !

!SpecStubDropListView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubFastTableAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubFastTableAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubFastTableView new! !

!SpecStubFastTableView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubIconListAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubIconListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubIconListView new! !

!SpecStubIconListView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubImageAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubImageAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubImageView new! !

!SpecStubImageView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubLabelAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubLabelAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubLabelAdapter new! !

!SpecStubListAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubListView new! !

!SpecStubListView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubMenuAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubMenuAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubMenuView new! !

!SpecStubMenuGroupAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubMenuGroupAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubMenuGroupView new! !

!SpecStubMenuGroupView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubMenuItemAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubMenuItemAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubMenuItemView new! !

!SpecStubMenuItemView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubMenuView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubMultiColumnListAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubMultiColumnListAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubMultiColumnListView new! !

!SpecStubMultiColumnListView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubRadioButtonAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubRadioButtonAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubRadioButtonView new! !

!SpecStubRadioButtonView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubSliderAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubSliderAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubSliderView new! !

!SpecStubSliderView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubTabAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubTabAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubTabView new! !

!SpecStubTabManagerAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubTabManagerAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubTabManagerView new! !

!SpecStubTabManagerView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubTabView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubTextAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubTextAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubTextView  new! !

!SpecStubTextInputFieldAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubTextInputFieldAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubTextInputFieldView new! !

!SpecStubTextInputFieldView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubTextView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubTickingWindowAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubTickingWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubTickingWindowView new! !

!SpecStubTickingWindowView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubTransferAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubTransferAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubTransferView new! !

!SpecStubTransferView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubTreeAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubTreeAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubTreeView new! !

!SpecStubTreeColumnAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubTreeColumnAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubTreeColumnView new! !

!SpecStubTreeColumnView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubTreeNodeAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubTreeNodeAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubTreeNodeView new! !

!SpecStubTreeNodeView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubTreeView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecStubViews commentStamp: ''!
I am an abstract stub view. My subclasses do not display any real UI component!
!SpecStubWindowAdapter commentStamp: ''!
Adapt the presenter on a stub view that displays no real UI elements.!
!SpecStubWindowAdapter methodsFor: 'factory' stamp: ''!
open! !

!SpecStubWindowAdapter methodsFor: 'factory' stamp: ''!
title: aString! !

!SpecStubWindowAdapter methodsFor: 'factory' stamp: ''!
buildWidget

	^ SpecStubWindowView new! !

!SpecStubWindowView commentStamp: ''!
Only stub object, no real view is displayed.
!
!SpecTableLayout commentStamp: ''!
A SpecTableLayout is a variant of spec layout that uses TableLayout layout policy.!
!SpecTableLayout methodsFor: 'commands' stamp: ''!
add: aSpec 
	commands add: (SpecTableLayoutAdd subwidget: aSpec) ! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
layoutInset: aNumber
	layoutProperties layoutInset: aNumber! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
newColumn: aBlock width: aNumber
	self add: ((self createColumn: aBlock) width: aNumber)! !

!SpecTableLayout methodsFor: 'private' stamp: ''!
createColumn: aBlock
	| column |
	column := SpecTableLayout column.
	aBlock value: column.
	^ column! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
addSpacerWeighted: aNumber
	commands add: (SpecTableLayoutAddSpacer weighted: aNumber) ! !

!SpecTableLayout methodsFor: 'testing' stamp: ''!
isSpecLayout

	^ true! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
cellInset: aNumber
	layoutProperties cellInset: aNumber! !

!SpecTableLayout methodsFor: 'accessing' stamp: ''!
commands
	^ commands! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
cellSpacing: aSymbol
	layoutProperties cellSpacing: aSymbol! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
minHeight: aNumber
	self send: #minHeight: withArguments: {aNumber}! !

!SpecTableLayout methodsFor: 'converting' stamp: ''!
asArray
	commands 
		select: [ :c | c isKindOf: SpecTableLayoutAddSpacer ] 
		thenDo: [ :c | c orientation: self orientation ].
	
	^ { #TableContainerPresenter . #layoutProperties: . layoutProperties } , 
	  (commands flatCollect: #asSpecElements)! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
cellPositioning: aSymbol
	layoutProperties cellPositioning: aSymbol! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
hResizing: aSymbol
	layoutProperties hResizing: aSymbol! !

!SpecTableLayout methodsFor: 'accessing' stamp: ''!
commands: anObject
	commands := anObject! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
addSpacer
	self addSpacerWeighted: 1 ! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
listCentering: aSymbol
	layoutProperties listCentering: aSymbol! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
rubberBandCells: aBool
	layoutProperties rubberBandCells: aBool! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
maxCellSize: aNumber
	layoutProperties maxCellSize: aNumber! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
send: aSelector withArguments: arguments
	commands 
		add: (SpecTableLayoutSend
					selector: aSelector
					arguments: arguments)! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
vResizing: aSymbol
	layoutProperties vResizing: aSymbol! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
wrapCentering: aSymbol
	layoutProperties wrapCentering: aSymbol! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
listSpacing: aSymbol
	layoutProperties listSpacing: aSymbol! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
width: aNumber
	"Doesn't work when opened in window, only when part of another layout"
	self send: #width: withArguments: {aNumber}! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
addSpacerSized: aNumber
	commands add: (SpecTableLayoutAddSpacer sized: aNumber) ! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
newRow: aBlock
	self add: (self createRow: aBlock)! !

!SpecTableLayout methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	
	commands := OrderedCollection new.
	layoutProperties := SpecTableLayoutProperties new.
	layoutProperties 
		reverseTableCells: true;
		hResizing: #spaceFill;
		vResizing: #spaceFill.! !

!SpecTableLayout methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
newColumn: aBlock
	self add: (self createColumn: aBlock)! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
wrapDirection: aSymbol
	layoutProperties wrapDirection: aSymbol! !

!SpecTableLayout methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
add: aSpec wrapped: aBlock
	| wrapper |
	wrapper := SpecWrapperTableLayout wrap: aSpec.
	aBlock value: wrapper.
	self add: wrapper
	! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
add: modelGetter withSpec: aSymbol wrapped: aBlock
	| wrapper |
	wrapper := SpecWrapperTableLayout wrap: modelGetter withSpec: aSymbol.
	aBlock value: wrapper.
	self add: wrapper
	! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
minCellSize: aNumber
	layoutProperties minCellSize: aNumber! !

!SpecTableLayout methodsFor: 'private' stamp: ''!
createRow: aBlock
	| row |
	row :=  SpecTableLayout row.
	aBlock value: row.
	^ row! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
height: aNumber
	"Doesn't work when opened in window, only when part of another layout"
	self send: #height: withArguments: {aNumber}! !

!SpecTableLayout methodsFor: 'private' stamp: ''!
orientation
	| dir |
	dir := layoutProperties listDirection.
	^ ((dir == #topToBottom) | (dir == #bottomToTop))
		ifTrue: [ #vertical ]
		ifFalse: [ #horizontal ]! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
send: aSelector
	self send: aSelector withArguments: #()! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
newRow: aBlock height: aNumber
	self add: ((self createRow: aBlock) height: aNumber)! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
listDirection: aSymbol
	layoutProperties listDirection: aSymbol! !

!SpecTableLayout methodsFor: 'commands - layout properties' stamp: ''!
reverseTableCells: aBool
	layoutProperties reverseTableCells: aBool! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
add: modelGetter withSpec: aSymbol 
	commands add: (SpecTableLayoutAddWithSpec subwidget: modelGetter spec: aSymbol) ! !

!SpecTableLayout methodsFor: 'commands' stamp: ''!
minWidth: aNumber
	self send: #minWidth: withArguments: {aNumber}! !

!SpecTableLayout class methodsFor: 'instance creation' stamp: ''!
row
	^ self new listDirection: #leftToRight! !

!SpecTableLayout class methodsFor: 'instance creation' stamp: ''!
column
	^ self new listDirection: #topToBottom! !

!SpecTableLayoutAdd commentStamp: ''!
A SpecTableLayoutAdd represents the action to add a subwidget into a spec table layout
!
!SpecTableLayoutAdd methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self selector: #add:! !

!SpecTableLayoutAdd methodsFor: 'accessing' stamp: ''!
subwidget
	^ subwidget! !

!SpecTableLayoutAdd methodsFor: 'instance creation' stamp: ''!
generateArguments
	self arguments: {{subwidget}}! !

!SpecTableLayoutAdd methodsFor: 'accessing' stamp: ''!
subwidget: aSpec
	subwidget := aSpec isSymbol
		ifTrue: [{#model. aSpec}]
		ifFalse: [
			aSpec isCollection
				ifTrue: [
					aSpec isEmpty 
						ifTrue: [ "should raise an error" ]
						ifFalse: [ aSpec first == #model 
										ifTrue: [ aSpec ]
										ifFalse: [ {#model}, aSpec ]]]
				ifFalse: [ 
					"Not a symbol or a collection. We assume it's an object to add directly (like a morph by example)"
					aSpec ]].
		
	self generateArguments! !

!SpecTableLayoutAdd class methodsFor: 'instance creation' stamp: ''!
subwidget: aSymbol
	^ self new 
		subwidget: aSymbol;
		yourself! !

!SpecTableLayoutAddSpacer commentStamp: ''!
A SpecTableLayoutAddSpring class is a description of the addition of a spacer to a table layout.

Can be either:
- flexible (fills available space; default) 
- of a fixed size

Note that flexible spacers do not work with wrapDirection other than #none.
!
!SpecTableLayoutAddSpacer methodsFor: 'initialization' stamp: ''!
initialize
	subwidget := #(PanelMorph).
	spaceFillWeight := 1.
	size := 0.
	orientation := #vertical.
	super initialize! !

!SpecTableLayoutAddSpacer methodsFor: 'instance creation' stamp: ''!
generateArguments
	| resizingMode resizing width height dimensions |
	width := 0.
	height := 0.
	dimensions := OrderedCollection new.
	
	(size > 0) 
		ifTrue: [ "fixed size"
			(orientation == #horizontal) 
				ifTrue: [ width := size ] 
				ifFalse: [ height := size ].
			resizingMode := #rigid. ]
		ifFalse: [ "flexible"
			dimensions add: #spaceFillWeight:; add: spaceFillWeight.
			resizingMode := #spaceFill. ].
	
	dimensions add: #width:; add: width; add: #height:; add: height.
	
	resizing := 
		(orientation == #horizontal) 
			ifTrue: [ {#hResizing: . resizingMode . #vResizing: . #shrinkWrap} ]
			ifFalse: [ {#hResizing: . #shrinkWrap . #vResizing: . resizingMode} ].
	
	self arguments: { {subwidget} , resizing , dimensions }! !

!SpecTableLayoutAddSpacer methodsFor: 'accessing' stamp: ''!
size: aNumber
	size := aNumber! !

!SpecTableLayoutAddSpacer methodsFor: 'accessing' stamp: ''!
spaceFillWeight: aNumber
	spaceFillWeight := aNumber! !

!SpecTableLayoutAddSpacer methodsFor: 'accessing' stamp: ''!
orientation: aSymbol
	((aSymbol == #horizontal) | (aSymbol == #vertical))
		ifFalse: [ Error signal: 'orientation must be either #horizontal or #vertical' ]
		ifTrue: [ orientation := aSymbol ]! !

!SpecTableLayoutAddSpacer methodsFor: 'protocol' stamp: ''!
asSpecElements
	self generateArguments.
	^ super asSpecElements! !

!SpecTableLayoutAddSpacer class methodsFor: 'instance creation' stamp: ''!
weighted: aNumber
	^ self new spaceFillWeight: aNumber! !

!SpecTableLayoutAddSpacer class methodsFor: 'instance creation' stamp: ''!
sized: aNumber
	^ self new size: aNumber! !

!SpecTableLayoutAddWithSpec commentStamp: ''!
A SpecLayoutAddWithSpec is an action representing an add in the spec table layout with a spec selector precised
!
!SpecTableLayoutAddWithSpec methodsFor: 'instance creation' stamp: ''!
subwidget: sub spec: aSpecSelector
	self subwidget: (sub isArray 
						ifTrue: [ #(model), sub , {#retrieveSpec:. aSpecSelector} ]
						ifFalse: [ {#model. sub . #retrieveSpec: . aSpecSelector } ]).
	
	self generateArguments! !

!SpecTableLayoutAddWithSpec class methodsFor: 'instance creation' stamp: ''!
subwidget: sub spec: aSpecSelector
	^ self new 
		subwidget: sub 
		spec: aSpecSelector! !

!SpecTableLayoutProperties commentStamp: ''!
Used to describe properties for table layouts in Spec!
!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
wrapCentering
	^wrapCentering! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
layoutInset: aNumber
	layoutInset := aNumber! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
cellInset: aNumber
	cellInset := aNumber! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
cellSpacing: aSymbol
	cellSpacing := aSymbol.! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
rubberBandCells: aBool
	rubberBandCells := aBool.! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
cellPositioning: aSymbol
	cellPositioning := aSymbol! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
listCentering: aSymbol
	listCentering := aSymbol! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
rubberBandCells
	^rubberBandCells! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
cellPositioning
	^cellPositioning! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
wrapCentering: aSymbol
	wrapCentering := aSymbol! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
maxCellSize: aNumber
	maxCellSize := aNumber.! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
cellInset
	^cellInset! !

!SpecTableLayoutProperties methodsFor: 'testing' stamp: ''!
includesTableProperties
	^true! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
listDirection
	^listDirection! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
listSpacing: aSymbol
	listSpacing := aSymbol! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
maxCellSize
	^maxCellSize! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
wrapDirection
	^wrapDirection! !

!SpecTableLayoutProperties methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	cellSpacing := listSpacing := wrapDirection := #none.
	cellPositioning := #center.
	listCentering := wrapCentering := #topLeft.
	listDirection := #topToBottom.
	reverseTableCells := rubberBandCells := false.
	layoutInset := cellInset := minCellSize := 0.
	maxCellSize := 1073741823. "SmallInteger maxVal"
! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
cellSpacing
	^cellSpacing! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
wrapDirection: aSymbol
	wrapDirection := aSymbol! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
layoutInset
	^layoutInset! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
listCentering
	^listCentering! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
minCellSize
	^minCellSize! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
reverseTableCells
	^reverseTableCells! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
minCellSize: aNumber
	minCellSize := aNumber.! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
listDirection: aSymbol
	listDirection := aSymbol.! !

!SpecTableLayoutProperties methodsFor: 'accessing' stamp: ''!
reverseTableCells: aBool
	reverseTableCells := aBool! !

!SpecTableLayoutProperties methodsFor: 'table defaults' stamp: ''!
listSpacing
	^listSpacing! !

!SpecTableLayoutSend commentStamp: ''!
A SpecTableLayoutSend is a spec layout action used when a selector is sent to the layout. It differs from SpecLayoutSend by being independent from specific layout.
!
!SpecTableLayoutSend methodsFor: 'protocol' stamp: ''!
asSpecElements

	^ {self selector.}, self arguments! !

!SpecTableLayoutSend class methodsFor: 'instance creation' stamp: ''!
selector: selector arguments: arguments

	^ self new
		arguments: arguments;
		selector: selector;
		yourself! !

!SpecTransferMorph commentStamp: ''!
I am a Spec specific subclass of TransferMorph used to initialize the trasnfer morph state correctly with the Spec constraints!
!SpecTransferMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	dragHand := self activeHand! !

!SpecTransferMorph methodsFor: 'accessing' stamp: ''!
shouldCopy

	^ self dragHand shiftPressed! !

!SpecTransferMorph methodsFor: 'accessing' stamp: ''!
passenger: aBlock
	passenger := aBlock value! !

!SpecTransferMorph methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!SpecTransferMorph methodsFor: 'accessing' stamp: ''!
source: aBlock
	source := aBlock value! !

!SpecTransferMorph methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!SpecTreeColumn commentStamp: ''!
I am a Tree column made especially to be used by the Spec framework!
!SpecTreeColumn methodsFor: 'compatibility' stamp: ''!
bindKeyCombination: aKMCombination toAction: aBlock

	"Do nothing"
	! !

!SpecTreeColumn methodsFor: 'column drawing' stamp: ''!
rowMorphFor: aNode 
	| node rowMorph |
	
	node := aNode nodeModel.
	rowMorph := self rowMorphGetSelector
		ifNil: [node rowMorphForColumn: self]
		ifNotNil: [self rowMorphGetterBlock value: node value: self container].
	rowMorph := rowMorph asMorph.
	rowMorph
		ifNotNil: [rowMorph borderWidth: 0]
		ifNil: [rowMorph := self defaultRowMorph].
	^ rowMorph rowMorphForNode: node inColumn: self
! !

!SpecTreeColumn methodsFor: 'private' stamp: ''!
setHeaderButtonLabel: aLabel font: aFont icon: anIconForm target: aReceiver actionSelector: aSelector
	(aLabel isNil
		and: [ anIconForm isNil and: [ aReceiver isNil or: [ aSelector isNil ] ] ])
		ifTrue: [ ^ self ].
	self headerButton.
	aLabel
		ifNil: [ self header label: '' font: nil ]
		ifNotNil: [ self header label: aLabel font: aFont ].
	anIconForm
		ifNotNil: [ self header icon: (ImageMorph new form: anIconForm) ].
	(aSelector notNil and: [ aReceiver notNil ])
		ifFalse: [ ^ self ].
	self header actionSelector: aSelector.
	self header target: aReceiver! !

!SpecTreeModel commentStamp: ''!
I am tree model used by the Spec infrastructure to provide a "pluggable" api since we do not have multiple inheritance in Pharo!
!SpecTreeModel methodsFor: 'drag and drop - private' stamp: ''!
acceptDroppingMorph: draggedMorph event: event inMorph: source

	^ self model acceptDroppingMorph: draggedMorph event: event inMorph: source! !

!SpecTreeModel methodsFor: 'drag and drop - private' stamp: ''!
transferFor: passenger from:  source

	^ self model transferFor: passenger from: source! !

!SpecTreeModel methodsFor: 'drag and drop - private' stamp: ''!
dragPassengerFor: item inMorph: dragSource 
	
	^ self model dragPassengerFor: item inMorph: dragSource! !

!SpecTreeModel methodsFor: 'private' stamp: ''!
resetRootNodes

	rootNodes := nil! !

!SpecTreeModel methodsFor: 'accessing' stamp: ''!
menu: menu shifted: b

	^ self model menu: menu shifted: b! !

!SpecTreeModel methodsFor: 'overrided' stamp: ''!
doubleClick

	self model doubleClick! !

!SpecTreeModel methodsFor: 'accessing' stamp: ''!
rootNodeFromItem: item

	^ self model rootNodeFromItem: item! !

!SpecTreeModel methodsFor: 'drag and drop - private' stamp: ''!
dragPassengersFor: item inMorph: dragSource
	
	^ self model dragPassengersFor: item inMorph: dragSource! !

!SpecTreeModel methodsFor: 'accessing' stamp: ''!
rootNodes

	^ rootNodes ifNil: [ rootNodes := super rootNodes ]! !

!SpecTreeModel methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!SpecTreeModel methodsFor: 'drag and drop - private' stamp: ''!
wantsDroppedMorph: draggedMorph event: anEvent inMorph: source

	^ self model wantsDroppedMorph: draggedMorph event: anEvent inMorph: source! !

!SpecTreeModel methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!SpecTreeModel methodsFor: 'accessing' stamp: ''!
rootItems

	^ self model roots! !

!SpecTreeModel class methodsFor: 'instance creation' stamp: ''!
model: model

	^ self new
		model: model;
		yourself! !

!SpecTreeNodeModel commentStamp: ''!
I am a Tree node especially made for being used by the Spec framework.!
!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
childrenItemsBlock
	^ childrenItemsBlock! !

!SpecTreeNodeModel methodsFor: 'compatibility' stamp: ''!
bindKeyCombination: aShortcut toAction: aBlock
	"Do nothing"! !

!SpecTreeNodeModel methodsFor: 'protocol' stamp: ''!
hasContentToShow

	^ self nodeModel hasContentToShow! !

!SpecTreeNodeModel methodsFor: 'building' stamp: ''!
hasContents
	hasContents isBlock
		ifTrue: [ ^ hasContents value ].
	^ self childrenItems notEmpty! !

!SpecTreeNodeModel methodsFor: 'protocol' stamp: ''!
isExpanded: aBoolean

	self nodeModel isExpanded: aBoolean! !

!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
childrenItems: aCollection
	childrenItems := aCollection! !

!SpecTreeNodeModel methodsFor: 'protocol' stamp: ''!
selected: aBoolean

	self nodeModel selected: aBoolean! !

!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
nodeModel
	^ nodeModel! !

!SpecTreeNodeModel methodsFor: 'protocol' stamp: ''!
lastClicked: aBoolean

	self nodeModel lastClicked: aBoolean.
	aBoolean
		ifTrue: [ self model highlightedItem: self nodeModel ]
		ifFalse: [ self model highlightedItem: nil ].! !

!SpecTreeNodeModel methodsFor: 'protocol' stamp: ''!
isExpanded

	^ self nodeModel isExpanded! !

!SpecTreeNodeModel methodsFor: 'protocol' stamp: ''!
selected

	^ self nodeModel selected! !

!SpecTreeNodeModel methodsFor: 'events' stamp: ''!
mouseDown: event

	self nodeModel mouseDownAction cull: event! !

!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
setChildren: aBlock
	"Store a aBlock which will return the children when evaluated."

	self childrenItemsBlock: aBlock! !

!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
helpText

	^ nodeModel help! !

!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
childrenItems
	^ self model autoRefreshOnExpand
		ifTrue: [ childrenItemsBlock value ]
		ifFalse: [ childrenItems ifNil: [ childrenItems := childrenItemsBlock value ] ]! !

!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
icon

	^ icon! !

!SpecTreeNodeModel methodsFor: 'protocol' stamp: ''!
content
	^ self nodeModel content! !

!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
nodeModel: anObject
	nodeModel := anObject! !

!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
contents
	^ self childrenItems collect: [ :child | self childNodeFromItem: child ]! !

!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
childrenItemsBlock: aBlock
	childrenItemsBlock := aBlock! !

!SpecTreeNodeModel methodsFor: 'building' stamp: ''!
hasContents: aBlock

	hasContents := aBlock! !

!SpecTreeNodeModel methodsFor: 'accessing' stamp: ''!
icon: anIcon

	icon := anIcon! !

!SpecTreeNodeModel methodsFor: 'building' stamp: ''!
childNodeFromItem: anItem

	^ (anItem
		container: self model;
		buildWithSpec)
		parentNode: self;
		yourself! !

!SpecWindow commentStamp: ''!
I am a window used by WindowSpec.

I have been introduced since it's currently the best solution to prevent to add dozen of respondsTo: in StandardWindow or add dirty extensions to Object (because all models are not subclasses of Model)!
!SpecWindow methodsFor: 'updating' stamp: ''!
okToChange

	^ self model okToChange! !

!SpecWindow methodsFor: 'controls' stamp: ''!
close

	self model ifNotNil: [ :aModel |
		aModel askOkToClose
			ifTrue: [ self okToChange ifFalse: [ ^ self ] ] ].
		
	super close! !

!SpecWindow methodsFor: 'protocol' stamp: ''!
aboutText

	^ self model aboutText! !

!SpecWrapper commentStamp: ''!
I am a small wrapper used to encapsulate data created and used during spec interpretation!
!SpecWrapper methodsFor: 'accessing' stamp: ''!
selector
	
	^ selector! !

!SpecWrapper methodsFor: 'accessing' stamp: ''!
instance
	
	^ instance! !

!SpecWrapper methodsFor: 'accessing' stamp: ''!
selector: anObject
	
	selector := anObject! !

!SpecWrapper methodsFor: 'protocol' stamp: ''!
isRedrawable
	
	^ self instance isRedrawable! !

!SpecWrapper methodsFor: 'accessing' stamp: ''!
instance: anObject
	
	instance := anObject! !

!SpecWrapper methodsFor: 'protocol' stamp: ''!
removeSubWidgets
	
	^ self instance removeSubWidgets! !

!SpecWrapper class methodsFor: 'instance creation' stamp: ''!
instance: instance selector: selector

	^ self new
		instance: instance;
		selector: selector;
		yourself! !

!SpecWrapperTableLayout commentStamp: ''!
A SpecWrapperTableLayout is a variant of SpecTableLayout that is a  wrapper around a single element.
It is used to set hResizing, vResizing, and/or some other properties affecting layout.
!
!SpecWrapperTableLayout methodsFor: 'commands' stamp: ''!
addSpacerSized: aNumber
	self shouldNotImplement! !

!SpecWrapperTableLayout methodsFor: 'commands' stamp: ''!
add: aSpec
	elementAdded 
		ifTrue: [ Error signal: ('{0} can only hold 1 element' format: { self class name }) ]
		ifFalse: [ super add: aSpec. elementAdded := true. ]! !

!SpecWrapperTableLayout methodsFor: 'initialization' stamp: ''!
initialize
	elementAdded := false.
	super initialize! !

!SpecWrapperTableLayout methodsFor: 'commands' stamp: ''!
addSpacerWeighted: aNumber
	self shouldNotImplement! !

!SpecWrapperTableLayout methodsFor: 'commands' stamp: ''!
add: aSpec wrapped: aBlock
	self shouldNotImplement! !

!SpecWrapperTableLayout methodsFor: 'commands' stamp: ''!
add: modelGetter withSpec: aSymbol wrapped: aBlock
	self shouldNotImplement! !

!SpecWrapperTableLayout methodsFor: 'commands' stamp: ''!
addSpacer
	self shouldNotImplement! !

!SpecWrapperTableLayout methodsFor: 'commands' stamp: ''!
add: modelGetter withSpec: aSymbol 
	elementAdded 
		ifTrue: [ Error signal: ('{0} can only hold 1 element' format: { self class name }) ]
		ifFalse: [ super add: modelGetter withSpec: aSymbol. elementAdded := true. ]! !

!SpecWrapperTableLayout class methodsFor: 'instance creation' stamp: ''!
row
	self shouldNotImplement! !

!SpecWrapperTableLayout class methodsFor: 'instance creation' stamp: ''!
wrap: modelGetter withSpec: aSymbol 
	^ self new add: modelGetter withSpec: aSymbol! !

!SpecWrapperTableLayout class methodsFor: 'instance creation' stamp: ''!
column
	self shouldNotImplement! !

!SpecWrapperTableLayout class methodsFor: 'instance creation' stamp: ''!
wrap: aSpec
	^ self new add: aSpec! !

!SplitJoinTest commentStamp: ''!
"Evaluate me to view the SplitJoin documentation:"

self showDocumentation

"CHANGES LOG:
- merged implementations by Keith Hodges (Join) and Damiena Pollet
  and Oscar Nierstrasz (RubyShards) into SplitJoin package
- moved all extension methods to *splitjoin method category
- merged all tests into SplitJoinTest
- fixed protocol in SequenceableCollection to splitOn: and joinUsing:
  and split: join: for splitters and joiners
- added Object>>joinTo: aStream and SequenceableCollection>>joinTo: aStream
  to support joining of either sequences or sequences of sequences
- prepared some documentation
- added systematic tests for all split/join cases
- added Object>>join:
- prepared split/join tests for all 16 cases
- prepares split+join tests for 4 standard cases
- reviewed/merged old tests
- changed splitjoin tests to use different joiner
- added separate test for split+join=id cases
- adapted documentation -- join result type is type of joiner or array or string
- fix split tests to check result asOrderedCollection
- added split tests for OrderedCollection and SortedCollection
- new join: method for OrderedCollection and SortedCollection
  (uses appendTo: in Object and SequenceableCollection)
- reviewed all split: implementations -- removed unnecessary helper methods
- check boundary conditions -- split on empty sequence ...
"!
!SplitJoinTest methodsFor: 'running' stamp: ''!
testJoinArrayUsingOrderedCollection
	self assert: ((1 to: 4) joinUsing: #(8 9) asOrderedCollection)
		equals: #(1 8 9 2 8 9 3 8 9 4) asOrderedCollection! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testJoinArrayUsingSortedCollection
	self assert: ((1 to: 4) joinUsing: #(8 9) asSortedCollection)
		equals: #(1 8 9 2 8 9 3 8 9 4) asSortedCollection! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testJoinUsingLastOnArray
	
	{	{  1. 2. 3 } 	-> '1, 2 and 3' .
		{  1. 2 } 	-> '1 and 2' .
		{  1 } 		-> '1' .
		{  }			-> ''.
	} 	asDictionary keysAndValuesDo: 
		[ 	:testCollection :resultString |
			self	 assert: ( testCollection joinUsing: ', ' last: ' and ') equals: resultString. 
		]! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitArrayOnElement
	self assert: ((1 to: 10) asArray splitOn: 4)
		equals: #(#(1 2 3) #(5 6 7 8 9 10)) asOrderedCollection! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testJoinStringUsingChar
	self assert: ('splitjoin' joinUsing: $-)
		equals: 's-p-l-i-t-j-o-i-n'! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitJoinStringOnString
	self assert: ('oo' join: ('ow' split: 'how now brown cow?'))
		equals: 'hoo noo broon coo?'! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testJoinArrayUsingObject
	self assert: ((1 to: 4) joinUsing: 0)
		equals: #(1 0 2 0 3 0 4)! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testJoinArrayUsingChar
	self assert: ((1 to: 4) joinUsing: $:)
		equals:  '1:2:3:4'! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitArrayOnBlock
	self assert: ((1 to: 10) asArray splitOn: [:n| n even])
		equals: #(#(1) #(3) #(5) #(7) #(9) #()) asOrderedCollection! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitJoinOnElement
	self assert: (0 join: (3 split: #(1 2 3 4 5)))
		equals: #(1 2 0 4 5)! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitStringOnBlock
	self assert: ('foobar' splitOn: [:ch | 'aeiou' includes: ch])
		equals: #('f' '' 'b' 'r') asOrderedCollection! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitSortedCollectionOnElement
	self assert: (((1 to: 10) asSortedCollection) splitOn: 4)
		equals: {(1 to: 3) asSortedCollection . (5 to: 10) asSortedCollection} asOrderedCollection.! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitSortedCollectionOnSortedCollection
	self assert: (((1 to: 10) asSortedCollection) splitOn: ((4 to: 5) asSortedCollection))
		equals: {(1 to: 3) asSortedCollection . (6 to: 10) asSortedCollection} asOrderedCollection.! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitStringOnSubstring
	self assert: ('the banana man can can bananas' splitOn: 'an')
		equals: #('the b' '' 'a m' ' c' ' c' ' b' '' 'as') asOrderedCollection! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testJoinArrayUsingString
	self assert: ((1 to: 4) joinUsing: '--')
		equals: '1--2--3--4'! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testJoinArrayUsingArray
	self assert: ((1 to: 4) joinUsing: #(8 9))
		equals: #(1 8 9 2 8 9 3 8 9 4)! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitStringOnChar
	self assert: ('does eat oats and lambs eat oats' splitOn: Character space)
		equals: #('does' 'eat' 'oats' 'and' 'lambs' 'eat' 'oats') asOrderedCollection! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitJoinStringOnChar
	self assert: ($: join: (Character space split: 'how now brown cow?'))
		equals: 'how:now:brown:cow?'! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testJoinUsingLastOnArrayOfStrings
	self
		assert: (#('Pharo is modern' 'open source' 'highly portable' 'fast' 'full-featured' ) joinUsing: ', ' last: ' and ')
		equals: 'Pharo is modern, open source, highly portable, fast and full-featured'! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitJoinIdentity
	| array string |
	array := #(5 1 4 1 3 1 2 1).
	string := 'how now brown cow'.
	self assert: (1 join: (1 split: array)) equals: array.
	self assert: (#(1 3) join: (#(1 3) split: array)) equals: array.
	self assert: ($o join: ($o split: string)) equals: string.
	self assert: ('ow' join: ('ow' split: string)) equals: string.! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitOrderedCollectionOnElement
	self assert: (((1 to: 10) asOrderedCollection) splitOn: 4)
		equals: {(1 to: 3) asOrderedCollection . (5 to: 10) asOrderedCollection} asOrderedCollection.! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitOrderedCollectionOnOrderedCollection
	self assert: (((1 to: 10) asOrderedCollection) splitOn: ((4 to: 5) asOrderedCollection))
		equals: {(1 to: 3) asOrderedCollection . (6 to: 10) asOrderedCollection} asOrderedCollection.! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitJoinOnSequence
	self assert: (#(6 6 6) join: (#(3 4) split: #(1 2 3 4 5)))
		equals: #(1 2 6 6 6 5)! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitJoinBoundaryCases
	"Empty splitter, joiner or sequence."
	self assert: (#() join: (#() split: #())) equals: #().
	self assert: ('' join: ('' split: '')) equals: ''.
	self assert: ('' join: #('')) equals: ''. 

	"Overlapping splitters, or at end of sequence"
	self assert: ('an' join: ('an' split: 'banana')) equals: 'banana'.
	self assert: ('na' join: ('na' split: 'banana')) equals: 'banana'.
	self assert: ('ana' join: ('ana' split: 'banana')) equals: 'banana'.! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testJoinStringUsingString
	self assert: ('bda' joinUsing: 'an')
		equals: 'bandana'! !

!SplitJoinTest methodsFor: 'running' stamp: ''!
testSplitArrayOnSequence
	self assert: ((1 to: 10) asArray splitOn: (4 to: 5))
		equals: #(#(1 2 3) #(6 7 8 9 10)) asOrderedCollection! !

!SplitJoinTest class methodsFor: 'sunitgui' stamp: ''!
packageNamesUnderTest
	<ignoreForCoverage>
	^ #('SplitJoin')! !

!SplitJoinTest class methodsFor: 'documentation' stamp: ''!
documentation
	<ignoreForCoverage>
	"self showDocumentation"
	
	^ '"This package provides functionality for splitting and joining strings similarly to that offered by Perl, Python and Ruby. In addition, split and join work for any kind of sequence, and offer the possibility to split strings using regular expressions.

Suppose object A is a SequenceableCollection of elements of type T (let''s call its type S[T]), and B is a splitter of type either T or S[T]. Then A splitOn: B yields an object C of type OC[S[T]] (OC=OrderedCollection). B can be either an element or a subsequence, so:"

	''abracadabra'' splitOn: $b.
	"-> an OrderedCollection(''a'' ''racada'' ''ra'')"

	''abracadabra'' splitOn: ''ca''.
	"-> an OrderedCollection(''abra'' ''dabra'')"

"A splitOn: B is the same as B split: A, so:"

	''ab'' split: ''abracadabra''.
	"-> an OrderedCollection('''' ''racad'' ''ra'')"

"joinUsing: and join: are the inverse of splitOn: and split:. You may use either of the forms:
	C joinUsing: B
or:
	B join: C
The result is normally the same type as the joiner. If the joiner (B) is of type S[T] and C is of type OC[S[T]] or Array[S[T]], the result is also of type S[T]. For example:"

	'' loves '' join: #(''john'' ''jane'' ''jack'').
	"-> ''john loves jane loves jack''"

"An object that is not a sequence can also be used as a joiner, in which case the final result is an array. Also the collection being joined may contain elements that are not sequences, in which case they are treated as singleton arrays."

	1 join: ''hello''.
	"-> #($h 1 $e 1 $l 1 $l 1 $o)"

"Note that in the case of characters and strings being used as joiners, the result is always a string."

"In general:
	((A splitOn: B) joinUsing: B) = A
or:
	(B join: (B split: A)) = A
so:"

	(''r'' join: (''r'' split: ''abracadabra'')) = ''abracadabra''.
	"->  true"

"Although the main application is for Strings, split and join will work for any kinds of SequenceableCollections, including Arrays and Intervals."

	[:n | n isPrime] split: (2 to: 20).
	"-> an OrderedCollection(#() #() #(4) #(6) #(8 9 10) #(12) #(14 15 16) #(18) #(20))"

"In addition, the following special cases are supported:

- split an S[T] using a block of type T->Boolean:"

	''abracadabra'' splitOn: [:x | ''bc'' includes: x].
	"-> an OrderedCollection(''a'' ''ra'' ''ada'' ''ra'')"

"- split a String using a regex:"

	''abracadabra'' splitOn: ''[bcdr]+'' asRegex.
	"-> an OrderedCollection(''a'' ''a'' ''a'' ''a'' ''a'')"

"- join all elements of an S[T] yielding another S[T]: '' ''- "

	''abracadabra'' joinUsing: '':''.
	" -> ''a:b:r:a:c:a:d:a:b:r:a''"

"Note that in these cases the rule that (B join: (B split: A)) = A does not hold, either because B maps to different elements, or because there is no A to start with."

	$: join: (1 to: 4).
	"-> ''1:2:3:4''"

"Finally, there is the convenient utility method joinUsing:last:, used as follows:"

	(1 to: 5) joinUsing: '', '' last: '' and ''.
	"-> ''1, 2, 3, 4 and 5''"

"This package merges and generalizes functionality from the Join package by Keith Hodges and the RubyShards package by Damien Pollet and Oscar Nierstrasz. "
'! !

!StAbstractProcessorTest methodsFor: 'running' stamp: ''!
tearDown 

	StSourceFactory reset.
	super tearDown.! !

!StAbstractProcessorTest methodsFor: 'tests' stamp: ''!
processor

	^ self subclassResponsibility ! !

!StAbstractProcessorTest methodsFor: 'tests' stamp: ''!
testSearchingInvalidTextDoesNotReturnResult

	self runForText: 'assdsadasdsada'.
	self assert: candidates results isEmpty! !

!StAbstractProcessorTest methodsFor: 'asserting' stamp: ''!
assertQuantityOfResults: anInteger 
	
	self assert: candidates results size equals: anInteger! !

!StAbstractProcessorTest methodsFor: 'asserting' stamp: ''!
denyResultsIncludes: anElement 

	self deny: ((candidates results collect: [:each | each content]) includes: anElement )! !

!StAbstractProcessorTest methodsFor: 'asserting' stamp: ''!
assertResultsIncludes: anElement 
	
	self assert: ((candidates results collect: [:each | each content]) includes: anElement)! !

!StAbstractProcessorTest methodsFor: 'testing' stamp: ''!
rerunWithText: aText 
	
	text := aText.
	context search: aText.
	context text: aText.
	candidates reset.
	processor filterInContext: context! !

!StAbstractProcessorTest methodsFor: 'tests' stamp: ''!
runForText: aText

	candidates := StMockCandidatesList new.
	text := aText.
	stream := StMockSpotterStream new
		receiver: candidates;
		yourself.

	context:= StSpotterContext new 
		step: self;
		stream: stream;
		text: text;
		search: text;
		yourself.

	processor := self processor.
			
	processor filterInContext: context.! !

!StAbstractProcessorTest methodsFor: 'running' stamp: ''!
setUp 
	
	super setUp.
	StDefaultSourceFactory forTest.! !

!StAbstractProcessorTest class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self == StAbstractProcessorTest! !

!StAbstractStringFilter commentStamp: ''!
I implement an abstract string based filter.
My users can update the filteringText using the message #filteringText:
When a new filtering is done I can handle the update of the filtering strategy and also I keep a list of already returned values so on a reset the filter is reapply to them, without reseting the inner iterator.
If the filter requires a full reset, I reset myself and the inner one.

My subclasses implements #criterium: to change how the strings are compared.!
!StAbstractStringFilter methodsFor: 'initialization' stamp: ''!
initialize

	filteringText := ''.
	results := OrderedCollection new.
	returnedIndex := ''.! !

!StAbstractStringFilter methodsFor: 'accessing' stamp: ''!
next

	| nextOne |

	(returnedIndex < results size) ifTrue: [  
		returnedIndex := returnedIndex + 1.
		^ results at: returnedIndex.	
	].

	nextOne := super next.
	
	nextOne 
		ifNil: [ ^ nil ].
	
	results add: nextOne.
	returnedIndex := results size.
	
	^ nextOne! !

!StAbstractStringFilter methodsFor: 'protected' stamp: ''!
criterium: aString

	self subclassResponsibility 
! !

!StAbstractStringFilter methodsFor: 'protected' stamp: ''!
doReset

	originalUnwrapped reset.
	returnedIndex := 0.
	results := OrderedCollection new! !

!StAbstractStringFilter methodsFor: 'accessing' stamp: ''!
filteringText: aString

	inner := originalUnwrapped select: [ :e | self criterium: e].

	(aString asLowercase beginsWith: filteringText asLowercase) 
		ifFalse: [ 
			self reset ].

	filteringText := aString.
	results := results select: [ :e | self criterium: e].
	returnedIndex := 0.

! !

!StAbstractStringFilter methodsFor: 'accessing' stamp: ''!
originalUnwrapped: anObject
	originalUnwrapped := anObject! !

!StAbstractStringFilter methodsFor: 'accessing' stamp: ''!
originalUnwrapped
	^ originalUnwrapped! !

!StAbstractStringFilter methodsFor: 'testing' stamp: ''!
atEnd

	^ (returnedIndex = results size) and: [ inner atEnd ]! !

!StAbstractStringFilter class methodsFor: 'instance creation' stamp: ''!
on: aStCombinator with: aString

	^ self new
		originalUnwrapped: aStCombinator;
		filteringText: aString! !

!StAbstractStringFilter class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == StAbstractStringFilter! !

!StBaseFilter commentStamp: ''!
A base for spotter filters. 
A spotter filter provides the functionality for filtering items based on a query.

It returns the list of all items that match the filter, but subclasses should only send to the processor the first  `StBaseFilter>>#itemsLimit` items .
!
!StBaseFilter methodsFor: 'public' stamp: ''!
value: aSpotterContext
	"I provide an entry point for performing a search that is 
	polymorphic with BlockClosure>>value:. I return the list of
	filtered items."
	
	^ [ self applyFilterInContext: aSpotterContext ]
		ensure: [ context := nil " release the context after search is completed " ] ! !

!StBaseFilter methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!StBaseFilter methodsFor: 'private - model' stamp: ''!
addItem: anItem
	self context streamed add: anItem.
	self context addItem: anItem! !

!StBaseFilter methodsFor: 'private' stamp: ''!
applyFilterInContext: aSpotterContext error: anException
	('[Spotter] Exception in filter <' , self class name , '>: '
		, anException asString) traceCr.
	^ self defaultFilteredItems! !

!StBaseFilter methodsFor: 'private - model' stamp: ''!
itemFilterNameFor: anItem
	"I return the string/text representation of an item used by the filter."
	
	^ self processor itemFilterNameFor: anItem! !

!StBaseFilter methodsFor: 'private - model' stamp: ''!
step
	^ self context step! !

!StBaseFilter methodsFor: 'private - model' stamp: ''!
processor
	^ self context processor! !

!StBaseFilter methodsFor: 'accessing - defaults' stamp: ''!
defaultFilteredItems
	^ OrderedCollection new: 100 " not a limitation, just a reasonable start size "! !

!StBaseFilter methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!StBaseFilter methodsFor: 'private' stamp: ''!
applyFilter
	^ self filteredItems! !

!StBaseFilter methodsFor: 'private' stamp: ''!
applyFilterInContext: aSpotterContext
	self prepareFilterInContext: aSpotterContext.
	^ self applyFilter! !

!StBaseFilter methodsFor: 'accessing' stamp: ''!
filteredItems
	^ filteredItems! !

!StBaseFilter methodsFor: 'private - model' stamp: ''!
addItems: aCollection
	self context streamed addAll: aCollection.
	self context addItems: aCollection! !

!StBaseFilter methodsFor: 'accessing' stamp: ''!
streamed
	^ streamed ifNil: [ streamed := self defaultStreamed ]! !

!StBaseFilter methodsFor: 'testing' stamp: ''!
hasFilteredItems
	^ self filteredItems isEmptyOrNil not! !

!StBaseFilter methodsFor: 'private' stamp: ''!
prepareFilterInContext: aSpotterContext
	"I provide a hook for preprocessing the query once before performing a search."
	
	self context: aSpotterContext.! !

!StBaseFilter methodsFor: 'private - model' stamp: ''!
allItems
	" WARNING: #allItems might be a list, block or iterator. we have to evaluate it in order to calculate the remaining/unstreamed items. #allItems are/were designed to be polymorphic to collections and streams. so this should be safe "
	| allItems |

	allItems := self processor allItemsIn: self context.
	^ self context isContinuing
		ifTrue: [ allItems value stFasterDifferencePreservingOrder: self context streamed ]
		ifFalse: [ allItems ]! !

!StBaseFilter methodsFor: 'public' stamp: ''!
stFilter

	^ self! !

!StBaseFilter methodsFor: 'accessing - defaults' stamp: ''!
defaultStreamed
	^ true! !

!StBaseFilter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	self filteredItems: self defaultFilteredItems! !

!StBaseFilter methodsFor: 'accessing' stamp: ''!
streamed: anObject
	streamed := anObject! !

!StBaseFilter methodsFor: 'private - model' stamp: ''!
itemsLimit
	^ self context itemsLimit! !

!StBaseFilter methodsFor: 'public' stamp: ''!
stListFilter

	^ self! !

!StBaseFilter methodsFor: 'accessing' stamp: ''!
filteredItems: aCollection
	filteredItems := aCollection! !

!StBaseFilter methodsFor: 'private - model' stamp: ''!
allItemsDo: aBlock
	self allItems do: aBlock! !

!StBaseFilter class methodsFor: 'public' stamp: ''!
stFilter

	^ self new! !

!StBaseFilter class methodsFor: 'public' stamp: ''!
stListFilter

	^ self new! !

!StBeginsWithFilter commentStamp: ''!
I implement a simple beginsWith: string filter.!
!StBeginsWithFilter methodsFor: 'protected' stamp: ''!
criterium: aValue

	^ aValue asString asLowercase beginsWith: filteringText asLowercase

! !

!StBeginsWithFilter methodsFor: 'filtering' stamp: ''!
beginsWithFilter: aString

	self filteringText: aString! !

!StBenchProcessors commentStamp: ''!
I am a test class to measure the impact of the new implementation of spotter processors.!
!StBenchProcessors methodsFor: 'benching' stamp: ''!
runClassBenchMarksFor: aString resultsInto: aWriteStream for: processorName
	| context oldProcessor newProcessor oldBench newBench |
	
	oldBench := [
		context := self contextForText: aString.
		oldProcessor := self perform: ('old' , processorName) asSymbol.
		oldProcessor filterInContext: context ] bench.

	newBench := [
		context := self contextForText: aString.
		newProcessor := self perform: ('new' , processorName) asSymbol.
		newProcessor filterInContext: context ] bench.

	aWriteStream
			<< 'Searching:';
			print: aString; tab; tab; tab;
			<< 'Old Implementation:'; 
			<< oldBench; tab;	
			<< 'new Implementation:'; 
			<< newBench; cr.! !

!StBenchProcessors methodsFor: 'benchmarking' stamp: ''!
oldClassProcessor

	^ StSpotterCandidatesListProcessor new
		allCandidates: [ Smalltalk allClassesAndTraits ];
		title: 'Classes';
		filter: StFilterFuzzy;
		itemIcon: #systemIcon;
		keyBinding: $b meta;
		wantsToDisplayOnEmptyQuery: false;
		yourself! !

!StBenchProcessors methodsFor: 'benching' stamp: ''!
oldImplementorsProcessor

	^ StSpotterCandidatesListProcessor new
		title: 'Implementors';
		filter: StFilterImplementor item: [ :filter :context | 
			SystemNavigation default allBehaviorsDo: [ :class | class methodsDo: filter ] ];
		keyBinding: $m meta;
		wantsToDisplayOnEmptyQuery: false! !

!StBenchProcessors methodsFor: 'benching' stamp: ''!
newImplementorsProcessor
	
	^ StImplementorsProcessor new! !

!StBenchProcessors methodsFor: 'benchmarking' stamp: ''!
newClassProcessor

	^ StClassProcessor new! !

!StBenchProcessors methodsFor: 'benchmarking' stamp: ''!
benchClassFinding
	<script: 'self new benchClassFinding'>

	| numberOfClasses |
	
	numberOfClasses := SystemNavigation default allBehaviors size.

	(String streamContents: [ :aStream |
		aStream 
			<< 'Classes'; cr;
			<< '-------'; cr;
			cr;
			<< 'Total Classes:';
			print: numberOfClasses;
			cr;cr.

		self runClassBenchMarksFor: 'znu' resultsInto: aStream for: #ClassProcessor.	
		self runClassBenchMarksFor: 'ast' resultsInto: aStream for: #ClassProcessor.	
		self runClassBenchMarksFor: 'gtspotter' resultsInto: aStream for: #ClassProcessor.	
		self runClassBenchMarksFor: 'test' resultsInto: aStream for: #ClassProcessor.	
	]) inspect.
! !

!StBenchProcessors methodsFor: 'benchmarking' stamp: ''!
contextForText: aString

	| candidates stream |

	candidates := StMockCandidatesList new.
	stream := StMockSpotterStream new
		receiver: candidates;
		onAddedSelector: #addObject:inProcessor:;
		yourself.

	^ StSpotterContext new 
		step: self;
		stream: stream;
		text: aString;
		search: aString;
		yourself.

	! !

!StBenchProcessors methodsFor: 'benchmarking' stamp: ''!
benchImplementors
	<script: 'self new benchImplementors'>

	| numberOfMethods |
	
	numberOfMethods := SystemNavigation default allBehaviors sum: [:c | c localMethods size].

	(String streamContents: [ :aStream |
		aStream 
			<< 'Methods'; cr;
			<< '-------'; cr;
			cr;
			<< 'Total Methods:';
			print: numberOfMethods;
			cr;cr.

		self runClassBenchMarksFor: 'asString' resultsInto: aStream for: #ImplementorsProcessor.	
		self runClassBenchMarksFor: 'printOn:' resultsInto: aStream for: #ImplementorsProcessor.	
		self runClassBenchMarksFor: 'asUrl' resultsInto: aStream for: #ImplementorsProcessor.	
		self runClassBenchMarksFor: 'test' resultsInto: aStream for: #ImplementorsProcessor.	
	]) inspect.
! !

!StBreakpointCommand methodsFor: 'testing' stamp: ''!
appliesTo: aTool
	^ [ aTool owner class ~= StDebuggerRawObjectInspector ]
		on: Error
		do: [ false ]! !

!StBreakpointCommand class methodsFor: 'deafult' stamp: ''!
defaultIconName

	^#smallDebug	! !

!StBreakpointCommand class methodsFor: 'instance creation' stamp: ''!
forSpec 
	^self forSpecWithIconNamed: self defaultIconName! !

!StBreakpointInspectionItem commentStamp: ''!
I am a data holder for breakpoints to be displayed in StObjectBreakpointInspection tables.!
!StBreakpointInspectionItem methodsFor: 'control' stamp: ''!
isEnabledInContext: aStHaltAndBreakpointController 
	^aStHaltAndBreakpointController isBreakpointEnabled: breakpoint! !

!StBreakpointInspectionItem methodsFor: 'printing' stamp: ''!
printContents
	^displayEntity printContentsForBreakpointInspection! !

!StBreakpointInspectionItem methodsFor: 'initialization' stamp: ''!
buildVariableBreakpointItemFor: aVariableBreakpoint

	type := Break name asString.
	scope := aVariableBreakpoint isObjectCentric
		          ifTrue: [ aVariableBreakpoint targetInstance ]
		          ifFalse: [ aVariableBreakpoint targetClassOrMethod ].
	displayEntity := aVariableBreakpoint! !

!StBreakpointInspectionItem methodsFor: 'printing' stamp: ''!
printScope
	breakpoint isObjectCentric ifTrue:[^'self'].
	^ scope printString! !

!StBreakpointInspectionItem methodsFor: 'control' stamp: ''!
disableInContext: aStHaltAndBreakpointController 
	aStHaltAndBreakpointController disableBreakpoint: breakpoint! !

!StBreakpointInspectionItem methodsFor: 'printing' stamp: ''!
printEntity
	^displayEntity printTargetForBreakpointInspection! !

!StBreakpointInspectionItem methodsFor: 'initialization' stamp: ''!
buildBreakpointItemFor: aBreakpoint

	node := aBreakpoint node.
	interval := node start to: node stop.
	type := Break name asString.
	scope := aBreakpoint isObjectCentric
		          ifTrue: [ aBreakpoint targetInstance ]
		          ifFalse: [ node methodNode methodClass ].
	displayEntity := aBreakpoint! !

!StBreakpointInspectionItem methodsFor: 'control' stamp: ''!
enableInContext: aStHaltAndBreakpointController 
	aStHaltAndBreakpointController enableBreakpoint: breakpoint! !

!StBreakpointInspectionItem methodsFor: 'accessing' stamp: ''!
entityToBrowse

	breakpoint isVariableBreakpoint ifTrue: [ 
		^ breakpoint targetClassOrMethod ].
	^ breakpoint node methodNode method! !

!StBreakpointInspectionItem methodsFor: 'updating' stamp: ''!
removeInPresenterContext: aStObjectBreakpointInspection 
	breakpoint remove.
	aStObjectBreakpointInspection update! !

!StBreakpointInspectionItem methodsFor: 'accessing' stamp: ''!
breakpoint
	^ breakpoint! !

!StBreakpointInspectionItem methodsFor: 'updating' stamp: ''!
updateSourceCodePaneFor: aStObjectBreakpointInspection

	breakpoint isVariableBreakpoint ifTrue: [ 
		aStObjectBreakpointInspection 
			updateSourceCodeForVariableBreakpointItem: self.
		^ self ].
	aStObjectBreakpointInspection updateSourceCodeForHaltItem: self! !

!StBreakpointInspectionItem methodsFor: 'initialization' stamp: ''!
forBreakpoint: aBreakpoint 
	breakpoint := aBreakpoint.
	^aBreakpoint asBreakpointInspectionItemIn: self! !

!StBytecodeInspectorSlotNode methodsFor: 'accessing' stamp: ''!
key
	^ 'rcvr: ' , (self slot index - 1) asString, ' [' , super key , ']'! !

!StCamelCaseSplitTest methodsFor: 'tests' stamp: ''!
testTwoDifferentWordsStartingWithUpperCase

	self 
		assertCollection: 'AnObject' splitCamelCase 
		hasSameElements: {'An'. 'Object'}! !

!StCamelCaseSplitTest methodsFor: 'tests' stamp: ''!
testSingleUppercaseLetter

	self 
		assertCollection: 'A' splitCamelCase 
		hasSameElements: { 'A' }! !

!StCamelCaseSplitTest methodsFor: 'tests' stamp: ''!
testSingleLowercaseLetter

	self 
		assertCollection: 'a' splitCamelCase 
		hasSameElements: {'a'}! !

!StCamelCaseSplitTest methodsFor: 'tests' stamp: ''!
testTwoDifferentWordsStartingWithLowerCase

	self 
		assertCollection: 'anObject' splitCamelCase 
		hasSameElements: {'an'. 'Object'}! !

!StCamelCaseSplitTest methodsFor: 'tests' stamp: ''!
testSplittingShouldNotLosePrefix

	self 
		assertCollection: 'GTSpotter' splitCamelCase 
		hasSameElements: {'GTSpotter'}! !

!StCaseSelectorIterator commentStamp: ''!
I implement a decorator that is useful with the string comparison.
I implement a selection based in the first letter of the filteringText.
I have two iterators inside, one for lowercase and other for uppercase text.

If the text starts with a lowercase letter, I will iterate the values first from the lowercase, and the from the uppercase.
If the text starts with an uppercase letter, I will iterate the values first from the uppercase, and the from the lowercase.
!
!StCaseSelectorIterator methodsFor: 'accessing' stamp: ''!
lowercaseIterator
	^ lowercaseIterator! !

!StCaseSelectorIterator methodsFor: 'protected' stamp: ''!
doReset

	lowercaseIterator reset.
	uppercaseIterator reset.! !

!StCaseSelectorIterator methodsFor: 'accessing' stamp: ''!
lowercaseIterator: anObject
	lowercaseIterator := anObject! !

!StCaseSelectorIterator methodsFor: 'accessing' stamp: ''!
uppercaseIterator
	^ uppercaseIterator! !

!StCaseSelectorIterator methodsFor: 'filtering' stamp: ''!
filteringText: aString
	aString
		ifEmpty: [ inner := lowercaseIterator.
			^ self ].

	inner := aString first isLowercase
		ifTrue: [ lowercaseIterator , uppercaseIterator ]
		ifFalse: [ uppercaseIterator , lowercaseIterator ].! !

!StCaseSelectorIterator methodsFor: 'accessing' stamp: ''!
uppercaseIterator: anObject
	uppercaseIterator := anObject! !

!StClassEntry commentStamp: ''!
I wrap a Class or Trait entry, to modify its behavior if required for the class!
!StClassEntry methodsFor: 'converting' stamp: ''!
asString

	^ content name! !

!StClassEntry methodsFor: 'accessing' stamp: ''!
icon

	^ content systemIcon! !

!StClassEntry methodsFor: '*NewTools-Spotter' stamp: ''!
headerCategoryForUnifiedProcessor: aLink on: aSpotterPresenter

	^ aSpotterPresenter headerCategoryUnifiedFor: aLink! !

!StClassEntry methodsFor: 'evaluating' stamp: ''!
doEvaluate
	content browse! !

!StClassEntry class methodsFor: '*NewTools-Spotter' stamp: ''!
prepareUnifiedHeaderDescriptionFor: aHeaderPresenter

	^ aHeaderPresenter prepareAsClasses! !

!StClassIterator commentStamp: ''!
I implement an iteration over all the classes in the system.
!
!StClassIterator methodsFor: 'enumerating' stamp: ''!
elementsDo: aValuable

	SystemNavigation default allBehaviorsDo: aValuable! !

!StClassProcessor commentStamp: ''!
I am simple processor that iterates on the classes!
!StClassProcessor methodsFor: 'filtering' stamp: ''!
newTextFilteringSource

	^ StSourceFactory current classesSubstringSource! !

!StClassProcessor class methodsFor: 'accessing' stamp: ''!
order
	
	^ 100! !

!StClassProcessor class methodsFor: 'settings' stamp: ''!
hideInSettings

	"I am hidden because the implementation in the unified processor is richer"
	^ true! !

!StClassProcessor class methodsFor: 'default-settings' stamp: ''!
defaultEnabled

	^ false! !

!StClassProcessor class methodsFor: 'accessing' stamp: ''!
title

	^ 'Classes'! !

!StClassProcessorTest methodsFor: 'tests' stamp: ''!
testFindGTClassProcessorTest

	self runForText: 'stclassprocessortest'.
	self assertResultsIncludes: StClassProcessorTest! !

!StClassProcessorTest methodsFor: 'tests' stamp: ''!
testFindGTClassProcessorTestAfterAddingTest

	self runForText: 'stclass'.
	self rerunWithText: 'stclassprocess'.
	
	self assertResultsIncludes: StClassProcessorTest ! !

!StClassProcessorTest methodsFor: 'tests' stamp: ''!
testFindGTClassProcessorTestWithPartialText

	self runForText: 'stclass'.
	self assertResultsIncludes: StClassProcessorTest! !

!StClassProcessorTest methodsFor: 'tests' stamp: ''!
processor

	^ StClassProcessor new! !

!StClassProcessorTest methodsFor: 'tests' stamp: ''!
testGTClassProcessorIsRemovedAfterUpdatingText

	self runForText: 'gtclass'.
	self rerunWithText: 'gtclassprocesst'.
	
	self denyResultsIncludes: StClassProcessor! !

!StClassProcessorTest methodsFor: 'tests' stamp: ''!
testPopularStringDoesReturnOnlyTenResults

	self runForText: 'test'.
	self assertQuantityOfResults: 25.! !

!StClassWithSelectorWordFilter methodsFor: 'filtering' stamp: ''!
additionalFilter: aString firstWord: firstWord otherWords: otherWords on: anEntry

	^ anEntry content methodClass name = className
		and: [ otherWords
				allSatisfy: [ :otherW | anEntry asString asLowercase includesSubstring: otherW ] ]! !

!StClassWithSelectorWordFilter methodsFor: 'filtering' stamp: ''!
splitWords: aString

	| splitted message |

	splitted := aString splitOn: '>>'.
	splitted size = 1 ifTrue: [ ^ super splitWords: aString ].
	
	className := splitted first trimBoth.
	message := (splitted second copyWithout: $#) trimBoth.
	
	className isEmpty 
		ifTrue: [ ^ super splitWords: aString ].
	
	^ super splitWords: message
		
	! !

!StCollectionBasedProcessor commentStamp: ''!
I am an abstract processor that is used when the results collection already exists or this is really cheap to calculate.!
!StCollectionBasedProcessor methodsFor: 'filtering' stamp: ''!
collection

	^ self subclassResponsibility ! !

!StCollectionBasedProcessor methodsFor: 'filtering' stamp: ''!
newEntryOn: anElement

	^ self subclassResponsibility ! !

!StCollectionBasedProcessor methodsFor: 'filtering' stamp: ''!
newTextFilteringSource

	^ ((StCollectionIterator on: self collection) 
			collect: [ :each | self newEntryOn: each ]) 
			asSubstringFilter! !

!StCollectionBasedProcessor class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self = StCollectionBasedProcessor ! !

!StCollectionIterator commentStamp: ''!
I wrap an existing collection and expose it as a iterator!
!StCollectionIterator methodsFor: 'accessing' stamp: ''!
collection
	^ collection! !

!StCollectionIterator methodsFor: 'accessing' stamp: ''!
collection: anObject
	collection := anObject! !

!StCollectionIterator methodsFor: 'enumerating' stamp: ''!
elementsDo: aValuable

	collection do: aValuable ! !

!StCollectionIterator class methodsFor: 'instance creation' stamp: ''!
on: aSequenceableCollection

	^ self basicNew
		collection: aSequenceableCollection;
		initialize;
		yourself! !

!StCommand commentStamp: ''!
I am a base command for new tools. 
I define common behavior that all commands can have: 

- maybe an icon
- maybe a shortcut!
!StCommand methodsFor: 'converting' stamp: ''!
asSpecCommand 
	| command |
	
	command := super asSpecCommand 
		iconProvider: self application;
		iconName: self class defaultIconName;
		yourself.
		
	self class defaultShortcut 
		ifNotNil: [ :keyCombination | command shortcutKey: keyCombination ].
		
	^ command! !

!StCommand methodsFor: 'accessing' stamp: ''!
application

	^ context application! !

!StCommand class methodsFor: 'accessing' stamp: ''!
defaultShortcut

	^ nil! !

!StCommand class methodsFor: 'accessing' stamp: ''!
defaultIconName

	^ nil! !

!StCopyStackToClipboardCommand commentStamp: ''!
Requests the debugger to copy its stack on the Clipboard!
!StCopyStackToClipboardCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ true! !

!StCopyStackToClipboardCommand methodsFor: 'hooks' stamp: ''!
execute
	self debugger copyStackToClipboard! !

!StCopyStackToClipboardCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ nil! !

!StCopyStackToClipboardCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ #debuggerCopyStack! !

!StCopyStackToClipboardCommand class methodsFor: 'initialization' stamp: ''!
defaultDescription
	^ 'Copy a short debugging stack to the clipboard.'! !

!StCopyStackToClipboardCommand class methodsFor: 'initialization' stamp: ''!
defaultName
	^ 'Copy Stack to Clipboard'! !

!StDebuggeAssertionFailureContextNotFound commentStamp: ''!
I am raised when a context cannot find in its sender chain an assertion failure context, that is, a context that compared two value, an actual and an expected.!
!StDebugger commentStamp: ''!
The StDebugger is a presenter that provides Pharo debugging functionality by using a DebugSession.

The debugging logic is in DebugSession and the corresponding debugging actions. 

SpecDebugger only provides a graphical interface to access that functionality. 
To interact with the DebugSession, the debugger uses a StDebuggerActionModel, which has responsibility to perform actions to the execution context.


!!!!Structure of the Pharo debugger

!!!!!!Sub-presenters and layouts
The debugger is composed of default views and extension views.
Default views are the stack, the commands, the status line, the code pane and the inspector.
An extension view automatically appears if any debugging extension is present and if extensions are activated in the settings.
If not, extensions do not appear.

Default and extension views are available in a vertical and an horizontal layout.
It is configureable in the settings under ==Tools >> Debugging >> Debugger layout==.
It is possible to fully customize the debugger layout, and therefore to add or remove any view.
The customized layout must then me selected in the aforementioned setting to be set as default.
To appear in that setting's list of possible values, the layout must be implemented in a method under the ==specs== protocol of the ==StDebugger== class side.

""The stack.""
It shows the call stack of the current interrupted context.
Each element in the stack is a context representing a message send.

The context menu (through right click) provides different interactions with the selected stack element: inspection, exploration, exportation, etc.

By default, only a small part of the stack is shown.
More of the stack is observable by either clicking on the bottom context (the last in the stack) or through the context menu.

""Commands.""
Commands are actions applicable to the current context
After each debugging action (''e.g.'', a step), the list of commands is being updated.
New commands may appear or disappear.
It depends if they are applicable or not to the current context and debugging session.
For instance, when a ==doesNotUnderstand== exception is raised (''i.e.'', a method does not exist), the command ''createMethod'' will appear.
In that case, it gives users the possibility to create the missing method and continue the execution.

""The status line.""
This view provides information about the current context.
Non-critical information, such as the current instruction being stepped, are displayed in gray.
Critical information ,such as halts or breakpoints or DNU exceptions, are displayed in red.

""The code.""
The code pane shows the source code of the interrupted context's method.
The source code is annotated with informations about the position of the interrupted execution.
This position corresponds to the next execution that will be executed if a step action is performed.
It is coloured in blue if that instruction is selected in the source code, or in orange and underlined if the selection is empty.

A context menu (through right click) provides inspection, exploration, and stepping actions applicable to the context.
Such actions include, ''e.g.'', browse implementors of a selected message or skip execution of selected parts of the code.

""The inspector.""
It provides views on the current context.
It contains tabs with different inspections or views on the current context or on the system.

The raw inspection shows three items: ''Receiver'', ''Temps'' and ''Context''.
The receiver item shows information about the receiver of the message, or the object executing the method from the context.
The temps item shows the temporary variables of the current context.
Finally, the context item shows lower-level details, such as the interrupted context, the debug session or the debugger itself.
Double-clicking on an item will spawn a new view in the same inspector, with an inspection on the selected item.

The breakpoints inspection shows all breakpoints installed for the current receiver.
Those breakpoints are either installed on the receiver's class (''e.g.'', halts) or on that specific receiver (''i.e.'', object-centric breakpoints or halts.)
Ticking or unticking a breakpoint in that list will activate or deactivate that breakpoint.

The meta inspection shows methods of the receiver's class hierarchy.
Methods can be modified and saved in directly in that pane.!
!StDebugger methodsFor: 'commands - support' stamp: ''!
stackSelectionReceiverClassContext
	^ [ stackTable selection selectedItem receiver class ]! !

!StDebugger methodsFor: '*NewTools-Sindarin-Tools' stamp: ''!
sindarinDebugger
	^ SindarinDebugger attachTo: self session! !

!StDebugger methodsFor: 'commands' stamp: ''!
doBrowseClass

	self systemNavigation browse: self stackSelectionMethodContext value! !

!StDebugger methodsFor: 'api' stamp: ''!
okToChange

	self code canDiscardEdits
		ifTrue: [ ^ true ].
	self code changed: #wantToChange.
	^ self code canDiscardEdits! !

!StDebugger methodsFor: 'presenter - code' stamp: ''!
recordUnsavedCodeChanges

	|codeInteractionModel codeText|
	codeInteractionModel := self code interactionModel.
	codeInteractionModel hasUnsavedCodeChanges ifFalse:[^self].
	
	codeText := self code text asString.
	self unsavedCodeChanges at: codeInteractionModel context put: codeText! !

!StDebugger methodsFor: 'accessing - context' stamp: ''!
interruptedContext

	^ self session interruptedContext! !

!StDebugger methodsFor: 'initialization' stamp: ''!
initializeBreakpointInspector
	breakpointInspector := self
		instantiate: StDebuggerBreakpointInspection
		on: (StInspectorModel on: nil).! !

!StDebugger methodsFor: 'updating - widgets' stamp: ''!
updateCodeFromContext

	self updateCodeFromContext: self currentContext! !

!StDebugger methodsFor: 'accessing - context' stamp: ''!
currentContext
	"I answer the context on which an action should be executed.
	This is either the selected context or if nothing is selected the interrupted context."
	
	^ self selectedContext isNil 
		ifTrue: [ self interruptedContext ]
		ifFalse: [ self selectedContext ]! !

!StDebugger methodsFor: 'updating - widgets' stamp: ''!
updateToolbar
	
	toolbarCommandGroup ifNil: [ ^ self ].
	toolbarCommandGroup allCommands do: [ :spCommand | 
		spCommand updateEnableStatus ]! !

!StDebugger methodsFor: 'initialization' stamp: ''!
initializeStack

	stackTable := self newTable.
	stackTable
		addColumn: ((SpImageTableColumn
				  title: ''
				  evaluated: [ :context | self stackIconForContext: context ])
				 width: 8;
				 sortFunction: nil;
				 yourself);
		addColumn: ((SpStringTableColumn
				  title: 'Class'
				  evaluated: [ :item | self printReceiverClassInContext: item ])
				 sortFunction: nil;
				 yourself);
		addColumn:
			((SpStringTableColumn title: 'Method' evaluated: [ :item | 
					  | method |
					  method := item method.
					  method isCompiledBlock
						  ifTrue: [ method sourceNode sourceCode ]
						  ifFalse: [ method selector ] ])
				 sortFunction: nil;
				 yourself);
		addColumn:
			((SpStringTableColumn title: 'Package' evaluated: [ :item | 
					  | package |
					  package := item method package.
					  package ifNil: [ '-' ] ifNotNil: [ package name asString ] ])
				 sortFunction: nil;
				 yourself).
	stackTable transmitDo: [ :context | 
		stackTable selection isEmpty ifFalse: [ 
			self updateInspectorFromContext: context.
			self updateCodeFromContext: context.
			self expandStackIfLastItemIsSelected.
			self updateWindowTitle ] ].
	stackHeader := self instantiate: StHeaderBar.
	stackHeader label: 'Stack'.
	stackHeader toolbarActions: (CmCommandGroup new
			 register:
				 ((StDebuggerToggleFilterStackCommand forSpecContext: self) 
					  iconName: #changeSorter);
			 register:
				 (StDebuggerSettingsCommand forSpecWithIconNamed: #configuration);
			 asSpecGroup)! !

!StDebugger methodsFor: 'commands - support' stamp: ''!
canExecuteCreateMissingClassCommand
	^ self debuggerActionModel isInterruptedContextMissingClassException! !

!StDebugger methodsFor: 'accessing' stamp: ''!
debuggerInspectorClass
	^ StDebuggerInspector! !

!StDebugger methodsFor: 'commands - support' stamp: ''!
canExecuteCreateSubclassResponsibilityCommand
	^ self debuggerActionModel isInterruptedContextSubclassResponsibilityException! !

!StDebugger methodsFor: 'commands - support' stamp: ''!
canExecuteReturnCommand

	^ self debuggerActionModel isInterruptedContextDead not! !

!StDebugger methodsFor: 'updating - session' stamp: ''!
removeActionsForSession: aSession
	self flag: 'Rewrite it'.
	aSession
		ifNotNil: [ aSession
				removeActionsForEvent: #restart;
				removeActionsForEvent: #resume;
				removeActionsForEvent: #stepInto;
				removeActionsForEvent: #stepOver;
				removeActionsForEvent: #stepThrough;
				removeActionsForEvent: #contextChanged ]! !

!StDebugger methodsFor: 'presenter - code' stamp: ''!
acceptCodeChanges: newSource forContext: aContext

	"It is wrong here that I have to use code adapter widget.
	It is expected down in the compilation call chain that the notified requestor answers to textMorph.
	This is for modifying the source code when declaring temps"

	self
		recompileMethodTo: newSource
		inContext: aContext
		notifying: code adapter widget.
	self clearUnsavedCodeChanges! !

!StDebugger methodsFor: 'presenter - code' stamp: ''!
unsavedCodeChangesFor: aContext 
	^self unsavedCodeChanges at: aContext! !

!StDebugger methodsFor: 'updating - widgets' stamp: ''!
updateCodeTextSegmentDecoratorsIn: aContext forInterval: selectionInterval
	
	self code removeAllTextSegmentDecorations.
	
	"This decorates the receiver and the next node with an underline"
	"self code
		addTextSegmentDecoration:
			(SpTextPresenterDecorator new
				underlineColor: Color orange;
				interval: (aContext currentNode start to: aContext currentNode stop + 1);
				yourself)."
				
	"This decorates the next executing node"
	self code addTextSegmentDecoration: (SpTextPresenterDecorator forHighlight
		interval: (selectionInterval first to: selectionInterval last + 1);
		yourself)
				
	"	icon: (self iconNamed: #warning);
		iconBlock: [ :n | n inspect ];
		title: 'Click me!!';"! !

!StDebugger methodsFor: '*NewTools-Debugger-Tests' stamp: ''!
inspector

	^ inspector! !

!StDebugger methodsFor: 'actions' stamp: ''!
clear

	extensionToolsNotebook pages do: [ :page | 
		page activePresenter windowIsClosing ].
	extensionTools := nil.
	self unsubscribeFromSystemAnnouncer.	
	self removeActionsForSession: self session.
	
	"When we programmatically close the window, we do not need to terminate the session as it was already cleared"
	programmaticallyClosed ifTrue: [ ^ self ].
	debuggerActionModel clearDebugSession! !

!StDebugger methodsFor: 'presenter - code' stamp: ''!
updateCodeFromContext: aContext
	| selectionInterval |

	aContext ifNil: [ ^ self clearCode ].
	
	self recordUnsavedCodeChanges.
	selectionInterval := self session selectedCodeRangeForContext: aContext.
	aContext sourceCode = self code text 
		ifFalse: [ self updateSourceCodeFor: aContext ].
	self code beForContext: aContext.
	self code selectionInterval: (selectionInterval last to: selectionInterval last - 1).
	self
		updateCodeTextSegmentDecoratorsIn: aContext
		forInterval: selectionInterval.
	! !

!StDebugger methodsFor: 'updating - actions' stamp: ''!
updateStep
	self flag: #DBG_UPDATE_OF_MODEL_SHOULD_BE_AUTOMATED.
	debuggerActionModel updateTopContext.
	debuggerActionModel updateContextPredicate.	
	debuggerActionModel updateDebugSession.
		
	self updateStackFromSession: self session.
	self updateWindowTitle.
	self updateExtensionsFrom: self session.	
	self updateToolbar.
	self flag: #DBG_INSPECTOR_UPDATE_BUG.
	inspector getRawInspectorPresenterOrNil ifNotNil: [ :p | p update ]! !

!StDebugger methodsFor: 'initialization' stamp: ''!
initializePresenters

	self initializeStack.
	self initializeToolbar.
	self initializeCode.
	self initializeInspector.
	self initializeExtensionTools! !

!StDebugger methodsFor: 'accessing' stamp: ''!
debuggerActionModel
	^ debuggerActionModel
		ifNil: [ debuggerActionModel := StDebuggerActionModel on: self session]! !

!StDebugger methodsFor: 'opening' stamp: ''!
openWithNotification: notificationString

	self openWithFullView! !

!StDebugger methodsFor: 'actions' stamp: ''!
runToSelection
	self debuggerActionModel
		runToSelection: self code selectionInterval
		inContext: self currentContext! !

!StDebugger methodsFor: 'commands - support' stamp: ''!
stackSelectionMethodSelectorContext

	^ [ stackTable selection selectedItem method selector ]! !

!StDebugger methodsFor: 'accessing - context' stamp: ''!
selectedContext

	^ self stackTable selection selectedItem! !

!StDebugger methodsFor: 'actions' stamp: ''!
proceedDebugSession

	self removeActionsForSession: self session.
	self debuggerActionModel proceedDebugSession.
	self close! !

!StDebugger methodsFor: 'accessing - context' stamp: ''!
context
 
	^ self interruptedContext! !

!StDebugger methodsFor: 'system subscriptions' stamp: ''!
subscribeToMethodAddedAnnouncement

	SystemAnnouncer uniqueInstance weak
		when: MethodAdded
		send: #updateAfterMethodAdded
		to: self! !

!StDebugger methodsFor: 'updating - actions' stamp: ''!
updateContextChanged
	self updateStep! !

!StDebugger methodsFor: 'accessing - widgets' stamp: ''!
stackTable
	^stackTable! !

!StDebugger methodsFor: 'actions' stamp: ''!
stepInto
	self debuggerActionModel stepInto: self currentContext! !

!StDebugger methodsFor: 'stack' stamp: ''!
expandStackIfLastItemIsSelected
	| selection |
	selection := stackTable selection.
	selection selectedItem == stackTable items last ifFalse: [ ^ self ].
	stackTable items: (self filterStack:
			 (self session stackOfSize: 2 * stackTable items size)).
	stackTable selectIndex: selection selectedIndex! !

!StDebugger methodsFor: 'stack' stamp: ''!
findFirstRelevantStackIndexIn: aStack
	| counter |
	counter := 1.
	aStack do: [ :context | 
		context method methodClass == TestAsserter ifFalse: [ ^ counter ].
		counter := counter + 1 ].
	^ 1! !

!StDebugger methodsFor: 'actions' stamp: ''!
createSubclassResponsibility

	| senderContext msg msgCategory chosenClass |
	senderContext := self interruptedContext sender.
	msg := Message
		       selector: senderContext selector
		       arguments: senderContext arguments.
	msgCategory := senderContext methodClass organization 
		               categoryOfElement: msg selector.
	chosenClass := self requestClassFrom: senderContext receiver class.
	chosenClass ifNil: [ ^ self ].
	self debuggerActionModel
		implement: msg
		classified: msgCategory
		inClass: chosenClass
		forContext: senderContext! !

!StDebugger methodsFor: 'commands - support' stamp: ''!
stackSelectionReceiverContext
	^ [ stackTable selection selectedItem receiver ]! !

!StDebugger methodsFor: 'printing' stamp: ''!
printReceiverClassInContext: aContext

	| receiverClass methodClass |
	receiverClass := aContext receiver class.
	methodClass := aContext method methodClass.
	receiverClass == methodClass ifTrue: [ ^ receiverClass name ].
	^ (WriteStream on: String new)
		  nextPutAll: receiverClass name;
		  space;
		  nextPut: $(;
		  nextPutAll: methodClass name;
		  nextPut: $);
		  contents! !

!StDebugger methodsFor: 'updating - actions' stamp: ''!
updateStepOver

	self updateStep 
	! !

!StDebugger methodsFor: 'commands - support' stamp: ''!
canExecuteCreateMissingMethodCommand
	^ self debuggerActionModel isInterruptedContextDoesNotUnderstand! !

!StDebugger methodsFor: 'stack' stamp: ''!
selectTopContext
	stackTable selectIndex: 1! !

!StDebugger methodsFor: 'commands' stamp: ''!
doBrowseReceiverClass

	self systemNavigation browse: self stackSelectionReceiverClassContext value! !

!StDebugger methodsFor: 'stack' stamp: ''!
updateStackFromSession: aSession
	|stack|
	stack := (self filterStack: aSession stack).
	stackTable items: stack.
	stackTable selectIndex: (self findFirstRelevantStackIndexIn: stack)! !

!StDebugger methodsFor: 'presenter - code' stamp: ''!
discardCodeChangesFor: aContext

	self unsavedCodeChanges removeKey: aContext ifAbsent: [  ].
	self code text: aContext sourceCode.
	self update! !

!StDebugger methodsFor: 'commands - support' stamp: ''!
buildContextMenus
	| stackGroup codeCommands debuggerCommandGroup |
	
	debuggerCommandGroup := self rootCommandsGroup.
	"Stack"
	stackGroup := debuggerCommandGroup / StDebuggerStackCommandTreeBuilder groupName.
	stackTable contextMenu: stackGroup beRoot asMenuPresenter.

	"Toolbar"
	toolbarCommandGroup := debuggerCommandGroup / StDebuggerToolbarCommandTreeBuilder groupName.
	SpToolbarPresenterBuilder new
		toolbarPresenter: toolbar;
		visit: toolbarCommandGroup.
	self updateToolbar.

	"Code"
	codeCommands := debuggerCommandGroup / StDebuggerCodeCommandTreeBuilder groupName.
	code contextMenu: codeCommands beRoot asMenuPresenter! !

!StDebugger methodsFor: 'actions' stamp: ''!
showFullStack
	stackTable items: (self filterStack: self session stack)
! !

!StDebugger methodsFor: 'accessing - widgets' stamp: ''!
toolbar

	^ toolbar! !

!StDebugger methodsFor: 'accessing' stamp: ''!
sessionHolder
	^ sessionHolder ifNil: [ sessionHolder := nil asValueHolder ]! !

!StDebugger methodsFor: 'stack' stamp: ''!
stackIconForContext: context

	self unsavedCodeChanges at: context ifAbsent: [ ^ nil ].
	^ self iconNamed: #overlayDirty! !

!StDebugger methodsFor: 'initialization' stamp: ''!
initializeToolbar

	toolbar := self newToolbar.
	toolbar addStyle: 'stToolbar'.
	toolbar displayMode: self application toolbarDisplayMode! !

!StDebugger methodsFor: 'initialization' stamp: ''!
initializeShortcuts: aWindowPresenter

	self flag: #DBG_TempSolvesSpecBug_RemoveWhenFixed.
	"This is only because of a problem in presenters, where shortcuts only work in the scope of their presenter.
	Consequently, debug shortcuts from the debugger toolbar only work if the mouse is over the toolbar button.
	This should be removed once the spec bug is fixed"
	aWindowPresenter
		bindKeyCombination: StProceedCommand defaultShortcut
		toAction: [ self proceedDebugSession ].
	aWindowPresenter
		bindKeyCombination: StStepIntoCommand defaultShortcut
		toAction: [ self stepInto ].
	aWindowPresenter
		bindKeyCombination: StStepOverCommand defaultShortcut
		toAction: [ self stepOver ].
	aWindowPresenter
		bindKeyCombination: StStepThroughCommand defaultShortcut
		toAction: [ self stepThrough ].
	aWindowPresenter
		bindKeyCombination: StRestartCommand defaultShortcut
		toAction: [ self restartCurrentContext ]! !

!StDebugger methodsFor: 'updating - actions' stamp: ''!
updateRestart
	self updateStep! !

!StDebugger methodsFor: 'actions' stamp: ''!
copyStackToClipboard
	self debuggerActionModel copyStackToClipboard! !

!StDebugger methodsFor: 'accessing - context' stamp: ''!
newTitle

	^ self debuggerActionModel statusStringForContext! !

!StDebugger methodsFor: 'actions' stamp: ''!
createMissingClass

	| variableNode |
	variableNode := self session exception variableNode.
	[ 
	| newClassBinding |
	self flag: 'This method is actually hard to test because it requires user input to complete. How to test that automatically?'.
	newClassBinding := OCUndeclaredVariableWarning new
		                   node: variableNode;
		                   defineClass: variableNode name ]
		on: Abort
		do: [ ^ self ].

	self debuggerActionModel restartContext:
		self interruptedContext sender! !

!StDebugger methodsFor: 'ui requests' stamp: ''!
requestProtocolIn: aClass

	| entryCompletion applicants choice |
	self class fastTDD ifTrue: [ ^ Protocol unclassified ].
	applicants := AbstractTool protocolSuggestionsFor: aClass.
	entryCompletion := EntryCompletion new
		                   dataSourceBlock: [ :currText | applicants ];
		                   filterBlock: [ :currApplicant :currText | 
			                   currText size > 3 and: [ 
					                   currApplicant asLowercase includesSubstring:
							                   currText asString asLowercase ] ].

	choice := (UIManager default
		           request:
		           'Start typing for suggestions (3 characters minimum)'
		           initialAnswer: Protocol unclassified
		           title: 'Choose a protocol'
		           entryCompletion: entryCompletion) ifNil: [ Abort signal ].

	^ choice ifEmpty: [ Protocol unclassified ]! !

!StDebugger methodsFor: 'actions' stamp: ''!
recompileMethodTo: aString inContext: aContext notifying: aNotifyer

	aContext ifNil: [ ^ self ].
	self session
		recompileMethodTo: aString
		inContext: aContext
		notifying: aNotifyer! !

!StDebugger methodsFor: 'extensions' stamp: ''!
instantiateExtensionToolsPage: aToolClass
	| toolInstance |
	toolInstance := self instantiate: aToolClass on: self.
	self registerExtensionTool: toolInstance.
	^ SpNotebookPage
		title: toolInstance debuggerExtensionToolName
		provider: [ toolInstance ]! !

!StDebugger methodsFor: 'actions' stamp: ''!
stepOver
	self debuggerActionModel stepOver: self currentContext! !

!StDebugger methodsFor: 'updating - widgets' stamp: ''!
updateAfterMethodAdded
	debuggerActionModel updateContextPredicate.
	self updateToolbar ! !

!StDebugger methodsFor: 'ui requests' stamp: ''!
warning: aString for: aPresenter

	self newPopover
		addStyle: 'error';
		relativeTo: aPresenter;
		position: SpPopoverPosition top;
		presenter: (SpPresenter new
				 layout: (SpBoxLayout newTopToBottom
						  borderWidth: 2;
						  spacing: 0;
						  add: (self newLabel label: aString);
						  yourself);
				 yourself);
		popup! !

!StDebugger methodsFor: 'accessing' stamp: ''!
session
	^ self sessionHolder value! !

!StDebugger methodsFor: 'actions' stamp: ''!
createMissingMethodFor: aMessage in: aClass
	self flag: #DBG_MISSINGTEST.
	self debuggerActionModel
		implement: aMessage
		classified: (self requestProtocolIn: aClass)
		inClass: aClass
		forContext: self interruptedContext.
	self selectTopContext! !

!StDebugger methodsFor: 'actions' stamp: ''!
selectNextExecutedExpression

	| sourceNodeExecuted |
	sourceNodeExecuted := self currentContext sourceNodeExecuted.
	self code selectionInterval:
		(sourceNodeExecuted start to: sourceNodeExecuted stop)! !

!StDebugger methodsFor: 'commands - support' stamp: ''!
canExecuteDebugCommand
	^ self debuggerActionModel isContextSteppable! !

!StDebugger methodsFor: 'commands - support' stamp: ''!
canExecuteRestartCommand

	^ (self debuggerActionModel isInterruptedContextPostMortem or: [ 
		   self debuggerActionModel isInterruptedContextDead ]) not! !

!StDebugger methodsFor: 'initialization' stamp: ''!
updatePresenter

	self updateStackFromSession: self session.
	self buildContextMenus! !

!StDebugger methodsFor: 'system subscriptions' stamp: ''!
unsubscribeFromSystemAnnouncer

	SystemAnnouncer uniqueInstance unsubscribe: self! !

!StDebugger methodsFor: 'actions' stamp: ''!
stepThrough
	self debuggerActionModel stepThrough: self currentContext! !

!StDebugger methodsFor: 'actions' stamp: ''!
restartCurrentContext

	self debuggerActionModel restartContext: self currentContext.
	self clearUnsavedCodeChanges.
	self code text: self currentContext sourceCode.
	self updateCodeFromContext! !

!StDebugger methodsFor: 'updating - widgets' stamp: ''!
clearCode
	
	self code
		clearInteractionModel;
		clearSelection;
		clearContent! !

!StDebugger methodsFor: 'presenter - code' stamp: ''!
clearUnsavedCodeChanges

	unsavedCodeChanges := IdentityDictionary new! !

!StDebugger methodsFor: 'accessing - widgets' stamp: ''!
code

	^ code! !

!StDebugger methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self debuggerActionModel updateContextPredicate.			
	self setSessionHolderSubscriptions.
	self forceSessionUpdate.
	self subscribeToMethodAddedAnnouncement.
	
	programmaticallyClosed := false.! !

!StDebugger methodsFor: 'api' stamp: ''!
initialExtent 
	"This code was taken from the old debugger to get the same behavior. Fell free to refactor"
	self flag: 'Do it better'.
	"RealEstateAgent standardWindowExtent y < 400"true "a tiny screen" 
		ifTrue: [ ^ 1000@800 ].
	
	^ [ | w h |
		w := Display width.
		h := Display height.
		(w - (w // 3)) @ (h - (h // 5)) ]
		on: Error
		do: [ 850@650 ]! !

!StDebugger methodsFor: 'updating - widgets' stamp: ''!
updateInspectorFromContext: aContext

	inspector
		updateLayoutForContexts: self session interruptedContext
		isAssertionFailure:
		self debuggerActionModel isInterruptedContextAnAssertEqualsFailure.
	inspector updateWith: (self newDebuggerContextFor: aContext).
	self flag: #DBG_INSPECTOR_UPDATE_BUG.
	inspector getRawInspectorPresenterOrNil ifNotNil: [ :p | p update ]! !

!StDebugger methodsFor: 'instance creation' stamp: ''!
newDebuggerContext

	^ self class debuggerContextClass new
		  exception: self session exception;
		  yourself! !

!StDebugger methodsFor: 'instance creation' stamp: ''!
newDebuggerContextFor: aContext

	^ self newDebuggerContext
		  context: aContext;
		  yourself! !

!StDebugger methodsFor: 'updating - widgets' stamp: ''!
updatePredicatesForContext: aContext

	self debuggerActionModel updateContextPredicate! !

!StDebugger methodsFor: 'presenter - code' stamp: ''!
updateSourceCodeFor: aContext

	| codeText |
	codeText := self unsavedCodeChanges
		            at: aContext
		            ifAbsent: [ aContext sourceCode ].
	self code text: codeText! !

!StDebugger methodsFor: 'updating - actions' stamp: ''!
updateStepThrough

	self updateStep ! !

!StDebugger methodsFor: 'accessing' stamp: ''!
interruptedProcess

	^ self session interruptedProcess! !

!StDebugger methodsFor: 'updating - actions' stamp: ''!
updateStepInto
	self updateStep! !

!StDebugger methodsFor: 'extensions' stamp: ''!
registerExtensionTool: anExtension
	self extensionTools add: anExtension! !

!StDebugger methodsFor: 'actions' stamp: ''!
fileOutSelectedContext
	self debuggerActionModel
		fileOutMethod: stackTable selection selectedItem method! !

!StDebugger methodsFor: 'extensions' stamp: ''!
initializeExtensionTools

	| sortedToolClasses pages |
	extensionToolsNotebook := self newNotebook.

	self class usesExtensions ifFalse: [ ^ self ].
	sortedToolClasses := SortedCollection new sortBlock: [ :s1 :s2 | s1 displayOrder <= s2 displayOrder ].
	sortedToolClasses addAll: (self class extensionToolsClasses select: [ :s | s showInDebugger ]).
	pages := sortedToolClasses collect: [ :toolClass | 
		         self instantiateExtensionToolsPage: toolClass ].
	extensionToolsNotebook pages: pages! !

!StDebugger methodsFor: 'ui requests' stamp: ''!
requestSuperclassOf: aClass to: aSuperclass

	| classes |
	classes := OrderedCollection with: aClass.
	classes addAll: (aClass allSuperclassesIncluding: aSuperclass).
	classes addAll:
		(aClass traits sort: [ :t1 :t2 | t1 asString < t2 asString ]).
	classes size = 1 ifTrue: [ ^ classes first ].
	^ (UIManager default
		   chooseFrom: (classes collect: [ :c | c name ])
		   values: classes
		   title: 'Define selector in:') ifNil: [ Abort signal ]! !

!StDebugger methodsFor: 'updating - session' stamp: ''!
registerActionsForSession: aSession
	self flag: 'Rewrite it'.
	aSession
		ifNotNil: [ aSession
				when: #restart send: #updateRestart to: self;
				when: #resume send: #updateResume to: self;
				when: #stepInto send: #updateStepInto to: self;
				when: #stepOver send: #updateStepOver to: self;
				when: #stepThrough send: #updateStepThrough to: self;
				when: #contextChanged send: #updateContextChanged to: self ]! !

!StDebugger methodsFor: 'initialization' stamp: ''!
connectPresenters

	super connectPresenters.
	self whenDisplayDo: [ 
		self updateToolbar.
		self updateCodeFromContext ]! !

!StDebugger methodsFor: 'ui requests' stamp: ''!
requestClassFrom: aClass

	self class fastTDD ifTrue: [ ^ aClass ].
	^ self requestSuperclassOf: aClass to: ProtoObject! !

!StDebugger methodsFor: 'actions' stamp: ''!
peelToFirstLike: aContext

	self debuggerActionModel peelToFirstLike: aContext.
	self clearUnsavedCodeChanges.
	self code text: self currentContext sourceCode! !

!StDebugger methodsFor: 'updating - session' stamp: ''!
setSessionHolderSubscriptions
	self sessionHolder
		whenChangedDo: [ :newSession :oldSession | 
			self removeActionsForSession: oldSession.
			self registerActionsForSession: newSession.
			self updateStackFromSession: newSession.
			self updateExtensionsFrom: newSession ]! !

!StDebugger methodsFor: 'opening' stamp: ''!
openWithFullView
	"Create and schedule a full debugger with the given label. Do not
	terminate the current active process."

	self openWithSpec! !

!StDebugger methodsFor: 'initialization' stamp: ''!
initializeInspector

	inspector := self
		instantiate: self debuggerInspectorClass
		on: (self debuggerInspectorModelClass on: self newDebuggerContext).
	inspector label: 'Receiver'! !

!StDebugger methodsFor: 'updating - widgets' stamp: ''!
updateExtensionsFrom: newSession
	self extensionTools do:[:tool| tool updatePresenter]! !

!StDebugger methodsFor: 'opening' stamp: ''!
close

	programmaticallyClosed := true.
	[ self withWindowDo: #close ] ensure: [ 
		debuggerActionModel ifNotNil: [ :actionModel | 
			actionModel clearDebugSession ] ]! !

!StDebugger methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: aSession

	self session: aSession! !

!StDebugger methodsFor: '*NewTools-Debugger-Tests' stamp: ''!
toolbarCommandGroup

	^ toolbarCommandGroup! !

!StDebugger methodsFor: 'commands - support' stamp: ''!
stackSelectionMethodContext

	^ [ stackTable selection selectedItem method ]! !

!StDebugger methodsFor: 'updating - session' stamp: ''!
removeSessionHolderSubscriptions
	self sessionHolder announcer unsubscribe: self sessionHolder.
	self removeActionsForSession: self session! !

!StDebugger methodsFor: 'stack' stamp: ''!
filterStack: aStack
	^self debuggerActionModel filterStack: aStack! !

!StDebugger methodsFor: 'updating - actions' stamp: ''!
updateResume

	! !

!StDebugger methodsFor: 'presenter - code' stamp: ''!
initializeCode

	code := self newCode.
	code whenSubmitDo: [ :text | 
		self acceptCodeChanges: text string forContext: self selectedContext ].
	code whenResetDo: [ self discardCodeChangesFor: self selectedContext ]! !

!StDebugger methodsFor: 'extensions' stamp: ''!
extensionTools
	^ extensionTools ifNil: [ extensionTools := OrderedCollection new ]! !

!StDebugger methodsFor: 'updating - widgets' stamp: ''!
updateWindowTitle

	self withWindowDo: [ :window | window title: self newTitle ].! !

!StDebugger methodsFor: 'accessing' stamp: ''!
debuggerInspectorModelClass
	^ StDebuggerInspectorModel! !

!StDebugger methodsFor: 'actions' stamp: ''!
createMissingMethod

	| msg chosenClass |
	self flag: #DBG_MISSINGTEST.
	msg := self interruptedContext tempAt: 1.
	[ 
	chosenClass := self requestClassFrom:
		               self interruptedContext receiver class.
	self createMissingMethodFor: msg in: chosenClass ]
		on: Abort
		do: [ ^ self ].
		
	code takeKeyboardFocus ! !

!StDebugger methodsFor: 'updating - session' stamp: ''!
forceSessionUpdate
	self sessionHolder valueChanged! !

!StDebugger methodsFor: 'accessing' stamp: ''!
session: aSession
	self sessionHolder value: aSession! !

!StDebugger methodsFor: 'actions' stamp: ''!
returnEnteredValue
	| expression |
	self flag: #DBG_HowToTestNilIfUserCancels.
	expression := (UIManager default
		request: 'Enter expression for return value:') ifNil: [^self].
	self debuggerActionModel
		returnValueFromExpression: expression
		fromContext: self currentContext! !

!StDebugger methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	super initializeWindow: aWindowPresenter.
	aWindowPresenter
		title: self debuggerActionModel statusStringForContext;
		initialExtent: self initialExtent;
		whenClosedDo: [ self clear ].

	self initializeShortcuts: aWindowPresenter! !

!StDebugger methodsFor: 'presenter - code' stamp: ''!
unsavedCodeChanges

	^ unsavedCodeChanges ifNil: [ 
		  unsavedCodeChanges := IdentityDictionary new ]! !

!StDebugger class methodsFor: 'instance creation' stamp: ''!
debugSession: aDebugSession
	| debugger |

	debugger := self on: aDebugSession.
	aDebugSession application 
		ifNotNil: [ :app | debugger application: app ].
	debugger openWithFullView.
	
	^ debugger! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
activateDebuggerExtensions
	^ ActivateDebuggerExtensions
		ifNil: [ ActivateDebuggerExtensions := true ]! !

!StDebugger class methodsFor: 'opening' stamp: ''!
openOn: aDebugSession withFullView: aBool
	
	^ self openOn: aDebugSession withFullView: aBool andNotification: nil! !

!StDebugger class methodsFor: 'specs' stamp: ''!
usingSpecSelector
	^ (UsingSpecSelector
		ifNil: [ UsingSpecSelector := StDebuggerSpecSelector defaultSelector ])
		selectSpecSelector! !

!StDebugger class methodsFor: 'specs' stamp: ''!
stackAndCodeLayout

	^ SpPanedLayout newTopToBottom
		positionOfSlider: 30 percent;
		add: self stackLayout;
		add: self codeLayout;
		yourself! !

!StDebugger class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ self perform: self usingSpecSelector! !

!StDebugger class methodsFor: 'settings' stamp: ''!
debuggerLayoutSettingsOn: aBuilder
	<systemsettings>
	(aBuilder pickOne: #usingSpecSelector)
		label: 'Default debugger spec layout';
		target: self;
		default: #debuggerWithoutExtensionsSpec;
		parent: #debugging;
		domainValues: self availableSpecSelectors;
		description: 'Sets the default spec layout of the debugger.'! !

!StDebugger class methodsFor: 'class initialization' stamp: ''!
initialize 
	self flag: 'Error recursion is used only here?'.
	ErrorRecursion := false! !

!StDebugger class methodsFor: 'opening' stamp: ''!
openOn: aDebugSession withFullView: aBool andNotification: aString
	| debugger |
	debugger := self on: aDebugSession.
	debugger openWithFullView.
	^ debugger! !

!StDebugger class methodsFor: 'specs - selectors' stamp: ''!
debuggerWithExtensionsSpec

	^ SpPanedLayout newTopToBottom
		positionOfSlider: 65 percent;
		add: (SpPanedLayout newLeftToRight
			positionOfSlider: 65 percent;
			add: self stackAndCodeLayout;
			add: #extensionToolsNotebook;
			yourself);
		add: #inspector;
		yourself! !

!StDebugger class methodsFor: 'settings' stamp: ''!
fastTDD: aBoolean

	FastTDD := aBoolean! !

!StDebugger class methodsFor: 'tools registry' stamp: ''!
extensionToolsClasses
	^TStDebuggerExtension users! !

!StDebugger class methodsFor: 'specs' stamp: ''!
stackLayout
	^ SpBoxLayout newTopToBottom
		add: #stackHeader
			expand: false
			fill: false
			padding: 5;
		add: #stackTable;
		yourself! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
rank
	^rank ifNil:[rank := self defaultDebuggerRank]! !

!StDebugger class methodsFor: 'specs - selectors' stamp: ''!
debuggerWithoutExtensionsSpec

	^ SpPanedLayout newTopToBottom
		positionOfSlider: 65 percent;
		add: self stackAndCodeLayout;
		add: #inspector;
		yourself! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
debuggerContextClass
	^ StDebuggerContext! !

!StDebugger class methodsFor: 'utilities' stamp: ''!
closeAllDebuggers
	<script>
	StDebugger allInstancesDo: [ :dbg | dbg close ]! !

!StDebugger class methodsFor: 'specs' stamp: ''!
availableSpecSelectors
	^ self class allSelectorsInProtocol: 'specs - selectors'! !

!StDebugger class methodsFor: '*NewTools-Debugger-Fuel' stamp: ''!
fuelOutStackCommandWith: aPresenter forRootGroup: aCmCommandsGroup
	<extensionCommands>
	| command stackGroupName stackGroup |
	command := StFuelOutStackCommand forSpecContext: aPresenter.
	stackGroupName := StDebuggerStackCommandTreeBuilder new stackGroupName.
	stackGroup := aCmCommandsGroup / stackGroupName / stackGroupName.
	stackGroup register: command! !

!StDebugger class methodsFor: 'commands' stamp: ''!
buildCommandsGroupWith: stDebuggerInstance forRoot: rootCommandGroup
	StDebuggerStackCommandTreeBuilder
		buildCommandsGroupWith: stDebuggerInstance
		forRoot: rootCommandGroup.
	StDebuggerToolbarCommandTreeBuilder
		buildCommandsGroupWith: stDebuggerInstance
		forRoot: rootCommandGroup.
	StDebuggerCodeCommandTreeBuilder
		buildCommandsGroupWith: stDebuggerInstance
		forRoot: rootCommandGroup! !

!StDebugger class methodsFor: '*NewTools-Sindarin-Commands' stamp: ''!
buildSindarinExtentionCommandsGroupWith: stDebuggerInstance forRoot: rootCommandGroup

	<extensionCommands>
	| commands codeGroup toolbarGroup toolbarSindarinGroup |
	commands := (Pragma allNamed: #codeExtensionDebugCommand:) collect: [ 
		            :prg | 
		            | class |
		            class := prg methodClass soleInstance.
		            class forSpecContext: stDebuggerInstance ].


	codeGroup := rootCommandGroup
	             / StDebuggerCodeCommandTreeBuilder groupName
	             / StDebuggerCodeCommandTreeBuilder new codeDebugCommandsGroupName.
	commands do: [ :c | codeGroup register: c ].

	toolbarGroup := rootCommandGroup / StDebuggerToolbarCommandTreeBuilder groupName.
	toolbarSindarinGroup := CmCommandGroup forSpec
			beToolbarPopoverButton;
			name: 'Advanced Step';
			icon: (stDebuggerInstance application iconNamed: #smallExpert);
			yourself.
	toolbarGroup register: toolbarSindarinGroup.
	commands do: [ :c | toolbarSindarinGroup register: c ].		 ! !

!StDebugger class methodsFor: 'settings' stamp: ''!
fastTDDSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #fastTDD)
		label: 'Fast TDD';
		target: self;
		default: false;
		parent: #debugging;
		description: 'Create classes and methods directly in the receiver''s class
without requesting information from the user'! !

!StDebugger class methodsFor: 'tools registry' stamp: ''!
usesExtensions

	^ self activateDebuggerExtensions and: [ 
		  self hasAnyActivatedExtension: self extensionToolsClasses ]! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
availableAutomatically: anObject
	availableAutomatically := anObject! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
defaultDebuggerRank

	^ 10! !

!StDebugger class methodsFor: 'specs' stamp: ''!
codeLayout

	^ SpBoxLayout newTopToBottom
		  add: #toolbar expand: false;
		  add: #code;
		  yourself! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
taskbarIconName

	^#smallDebugIcon! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
availableAutomatically
	^ availableAutomatically ifNil: [ 
		  availableAutomatically := DebuggerSettings defaultAvailability ]! !

!StDebugger class methodsFor: 'debugging' stamp: ''!
handlesContext: aContext
	^true! !

!StDebugger class methodsFor: 'settings' stamp: ''!
fastTDD
	^FastTDD ifNil:[FastTDD := false]! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
activateDebuggerExtensions: anObject
	ActivateDebuggerExtensions := anObject! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
spanNewSessionFrom: anotherSession
	self flag: 'Where is that used? 2019-06-28'.
	^ anotherSession spanNewSession! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
sessionClass
	self flag: 'Should be replaced by Sindarin - should even be removed in that case!!'.
	^ DebugSession! !

!StDebugger class methodsFor: 'tools registry' stamp: ''!
hasAnyActivatedExtension: extensionsClasses

	^ extensionsClasses anySatisfy: [ :toolClass | 
		  toolClass showInDebugger ]! !

!StDebugger class methodsFor: 'specs' stamp: ''!
usingSpecSelector: aSelector

	UsingSpecSelector := StDebuggerSpecSelector on: aSelector! !

!StDebugger class methodsFor: 'accessing' stamp: ''!
rank: anInteger
	rank := anInteger! !

!StDebuggerActionModel commentStamp: ''!
I implement debug actions exposed by debuggers, and performed on the current debug session.!
!StDebuggerActionModel methodsFor: 'debug - execution' stamp: ''!
proceedDebugSession

	contextPredicate := nil.
	self session
		resume;
		clear! !

!StDebuggerActionModel methodsFor: 'debug - stepping' stamp: ''!
stepOver: aContext
	filterStack := (self topContext method hasPragmaNamed:
		                #debuggerCompleteToSender)
		               ifTrue: [ false ]
		               ifFalse: [ self class shouldFilterStack ].
	self session stepOver: aContext.
	self updateTopContext! !

!StDebuggerActionModel methodsFor: 'accessing' stamp: ''!
session
	^session! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
updateTopContext

	topContext := self interruptedContext! !

!StDebuggerActionModel methodsFor: 'debug - execution' stamp: ''!
peelToFirstLike: aContext
	self session peelToFirstLike: aContext.
	self updateTopContext! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
referenceContext
	"The reference context is the context that we wish to see in the debugger's stack.
	It it either the interrupted context if we are in a non-exception case,
	or the exception's signaler context in all other cases."
	self contextPredicate contextSignalsException ifFalse:[^self interruptedContext].
	^topContext receiver signalerContext ! !

!StDebuggerActionModel methodsFor: 'debug - predicates' stamp: ''!
isInterruptedContextMissingClassException

	^ self contextPredicate isContextMissingClassException! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
predicateFor: aContext failure: testFailure postMortem: isContextPostMortem

	^ (StDebuggerTestFailureContextPredicate context: aContext)
		  failure: testFailure;
		  postMortem: isContextPostMortem;
		  yourself! !

!StDebuggerActionModel methodsFor: 'debug - stack' stamp: ''!
shouldFilterStack

	^ self filterStack and: [ self class shouldFilterStack ]! !

!StDebuggerActionModel methodsFor: 'debug - session' stamp: ''!
updateDebugSession
	self contextPredicate updateSessionForModel: self 
		! !

!StDebuggerActionModel methodsFor: 'accessing' stamp: ''!
interruptedContext
	^self session interruptedContext! !

!StDebuggerActionModel methodsFor: 'accessing' stamp: ''!
filterStack
	^ filterStack! !

!StDebuggerActionModel methodsFor: 'debug - predicates' stamp: ''!
isInterruptedContextDead
	^ self contextPredicate isContextDead! !

!StDebuggerActionModel methodsFor: 'debug - execution' stamp: ''!
clearDebugSession
	contextPredicate := nil.
	self session terminate; clear! !

!StDebuggerActionModel methodsFor: 'debug - execution' stamp: ''!
runToSelection: aSelectionInterval inContext: aContext
	self session runToSelection: aSelectionInterval inContext: aContext.
	self updateTopContext! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
statusStringForContext

	^ self contextPredicate printDescription! !

!StDebuggerActionModel methodsFor: 'debug - stepping' stamp: ''!
stepInto: aContext 
	filterStack := false.
	aContext stepIntoQuickMethod: true.
	self session stepInto: aContext.
	aContext stepIntoQuickMethod: false.
	self updateTopContext.
! !

!StDebuggerActionModel methodsFor: 'accessing' stamp: ''!
topContext
	^ topContext! !

!StDebuggerActionModel methodsFor: 'debug - stack' stamp: ''!
filterStack: aStack
	| context contextsToReject |	
	self shouldFilterStack ifFalse: [  ^aStack ].
	context := aStack first.
	contextsToReject := 0.

	[ 
	context notNil and: [ context ~~ self referenceContext  ] ] 
		whileTrue: [ 
			contextsToReject := contextsToReject + 1.
			context := context sender ].
	[ 
	context notNil and: [ 
		context method hasPragmaNamed: #debuggerCompleteToSender ] ] 
		whileTrue: [ 
			contextsToReject := contextsToReject + 1.
			context := context sender ].
	contextsToReject timesRepeat: [ aStack removeFirst ].
	^ aStack! !

!StDebuggerActionModel methodsFor: 'debug - session' stamp: ''!
updateDebugSessionException: e

	self session exception: e! !

!StDebuggerActionModel methodsFor: 'debug - predicates' stamp: ''!
isContextAnAssertionFailure

	^ self contextPredicate isContextAnAssertionFailure! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
updateContextPredicateFor: aContext    
	contextPredicate := self contextPredicateFor: aContext.
	^contextPredicate! !

!StDebuggerActionModel methodsFor: 'debug - predicates' stamp: ''!
isInterruptedContextSubclassResponsibilityException
	^ self contextPredicate isContextSubclassResponsibilityException! !

!StDebuggerActionModel methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	self computeInitialTopContext.
	filterStack := true! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
predicateFor: aContext postMortem: isContextPostMortem

	^ (StDebuggerContextPredicate context: aContext)
		  postMortem: isContextPostMortem;
		  yourself! !

!StDebuggerActionModel methodsFor: 'debug - predicates' stamp: ''!
isInterruptedContextPostMortem
	^ self contextPredicate isContextPostMortem! !

!StDebuggerActionModel methodsFor: 'accessing' stamp: ''!
contextPredicate

	^ contextPredicate ifNil: [ 
		  contextPredicate := self updateContextPredicateFor:
			                      self topContext ]! !

!StDebuggerActionModel methodsFor: 'debug - stack' stamp: ''!
fileOutMethod: aMethod
	aMethod methodClass fileOutMethod: aMethod selector! !

!StDebuggerActionModel methodsFor: 'debug - stepping' stamp: ''!
stepThrough: aContext
	self session stepThrough: aContext.
	self updateTopContext! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
isContextPostMortem: aContext

	aContext == topContext ifFalse: [ 
		^ self session isContextPostMortem: aContext ].

	"If the context is top context, we work on the interrupted context.
	The top context is not visible from the session"
	^ self session isContextPostMortem: self interruptedContext! !

!StDebuggerActionModel methodsFor: 'debug - predicates' stamp: ''!
isInterruptedContextAnAssertEqualsFailure

	^ self contextPredicate isContextAnAssertionFailure! !

!StDebuggerActionModel methodsFor: 'debug - session' stamp: ''!
autoClassifyMessage: aMessage inClass: aClass

	| method |
	method := aClass lookupSelector: aMessage selector.
	method protocol = Protocol unclassified ifTrue: [ 
		MethodClassifier classify: method ]! !

!StDebuggerActionModel methodsFor: 'debug - execution' stamp: ''!
restartContext: aContext
	self session restart: aContext.
	self updateTopContext! !

!StDebuggerActionModel methodsFor: 'accessing' stamp: ''!
session: aDebugSession
	session := aDebugSession! !

!StDebuggerActionModel methodsFor: 'debug - session' stamp: ''!
implement: aMessage classified: messageCategory inClass: aClass forContext: aContext

	self session
		implement: aMessage
		classified: messageCategory
		inClass: aClass
		forContext: aContext.
	self autoClassifyMessage: aMessage inClass: aClass.
	self updateTopContext! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
contextPredicateFor: aContext

	| postMortem ex |
	postMortem := self isContextPostMortem: aContext.

	(self contextSignalsAnException: aContext) ifFalse: [ 
		^ self predicateFor: aContext postMortem: postMortem ].

	ex := aContext receiver.
	(ex isKindOf: TestFailure) ifTrue: [ 
		^ self predicateFor: aContext failure: ex postMortem: postMortem ].

	^ self predicateFor: aContext exception: ex postMortem: postMortem! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
updateContextPredicate
	^self updateContextPredicateFor: self topContext! !

!StDebuggerActionModel methodsFor: 'debug - stack' stamp: ''!
copyStackToClipboard
	Clipboard
		clipboardText:
			(String
				streamContents: [ :s | self interruptedContext shortDebugStackOn: s ])! !

!StDebuggerActionModel methodsFor: 'debug - predicates' stamp: ''!
isContextSteppable

	self interruptedContext ifNil: [ ^ false ].
	^ self contextPredicate isSteppable! !

!StDebuggerActionModel methodsFor: 'debug - execution' stamp: ''!
returnValueFromExpression: aString fromContext: aContext
	| value |
	value := session class compiler
		source: aString;
		context: aContext;
		receiver: aContext receiver;
		evaluate.
	self session returnValue: value from: aContext.
	self updateTopContext! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
computeInitialTopContext

	topContext := session exception signalContext.
	topContext ifNil: [ 
		topContext := self interruptedContext.
		^ self ].
	(topContext hasContext: self interruptedContext) ifFalse: [ 
		topContext := self interruptedContext ]! !

!StDebuggerActionModel methodsFor: 'context' stamp: ''!
predicateFor: aContext exception: exception postMortem: isContextPostMortem

	^ (StDebuggerErrorContextPredicate context: aContext)
		  exception: exception;
		  postMortem: isContextPostMortem;
		  yourself! !

!StDebuggerActionModel methodsFor: 'debug - predicates' stamp: ''!
isInterruptedContextDoesNotUnderstand
	^self contextPredicate isContextDoesNotUnderstand
! !

!StDebuggerActionModel methodsFor: 'debug - predicates' stamp: ''!
contextSignalsAnException: aContext

	^ aContext notNil 
		and: [ (aContext receiver isKindOf: Exception) 
		and: [  aContext selector = #signal ] ]! !

!StDebuggerActionModel class methodsFor: 'asserting' stamp: ''!
shouldFilterStack: aBoolean
	ShouldFilterStack := aBoolean! !

!StDebuggerActionModel class methodsFor: 'instance creation' stamp: ''!
on: aDebugSession

	^ self basicNew
		  session: aDebugSession;
		  initialize! !

!StDebuggerActionModel class methodsFor: 'settings' stamp: ''!
shouldFilterStackSettingsOn: aBuilder
	<systemsettings>
	(aBuilder setting: #shouldFilterStack)
		label: 'Filter the debugger stack';
		target: self;
		default: true;
		parent: #debugging;
		description: 'Defines if methods with pragma #debuggerCompleteToSender are filtered (hidden) in the debugger stack'! !

!StDebuggerActionModel class methodsFor: 'asserting' stamp: ''!
shouldFilterStack
	^ShouldFilterStack ifNil:[ShouldFilterStack := true]! !

!StDebuggerActionModelTest methodsFor: 'tests - predicates' stamp: ''!
testIsContextAnAssertionFailure
	self changeSession: StTestDebuggerProvider new debuggerWithFailingAssertionContext session.
	self assert: debugActionModel isContextAnAssertionFailure! !

!StDebuggerActionModelTest methodsFor: 'tests - predicates' stamp: ''!
testIsInterruptedContextMissingClassException	
	StTestDebuggerProvider compileMissingClassContextBuilder.
	self changeSession: StTestDebuggerProvider new debuggerWithMissingClassContext session.
	self assert: debugActionModel isInterruptedContextMissingClassException! !

!StDebuggerActionModelTest methodsFor: 'helper' stamp: ''!
methodClass
	^self! !

!StDebuggerActionModelTest methodsFor: 'helper' stamp: ''!
session
	^debugger session! !

!StDebuggerActionModelTest methodsFor: 'tests' stamp: ''!
testImplementClassifiedInClassForContext
	|method|
	method := (StDebuggerUsingSpecSelectorMock lookupSelector: #method).
	self assert:	method equals: nil.
	[ StDebuggerUsingSpecSelectorMock new method ]
		on: Error
		do: [ :dnu | 
			debugActionModel
				implement: dnu message
				classified: Protocol unclassified
				inClass: StDebuggerUsingSpecSelectorMock
				forContext: dnu signalerContext ].
	method := (StDebuggerUsingSpecSelectorMock lookupSelector: #method).
	self deny: method	equals: nil.
	self assert: method methodClass identicalTo: StDebuggerUsingSpecSelectorMock! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testStepThrough
	| method ctx |
	method := self class >> #setResult.
	ctx := session interruptedContext.
	debugActionModel stepThrough: ctx.
	self assert: session interruptedContext identicalTo: ctx.
	self assert: ctx top equals: 4.
	debugActionModel stepThrough: ctx.
	self assert: session interruptedContext identicalTo: ctx.
	self assert: result equals: 4.
	self
		assert: (method sourceNodeForPC: session interruptedContext pc)
		identicalTo: method ast statements second! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testClearDebugSession
	| process |
	process := session interruptedProcess.
	self deny: process isTerminated.
	debugActionModel clearDebugSession.
	self assert: process isTerminated.
	self assert: session interruptedContext isNil! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testRestartContext
	|topContext topPC|
	topContext := 
	session interruptedContext.
	topPC := topContext pc.
	session stepInto.
	self deny: session interruptedContext identicalTo: topContext.
	debugActionModel restartContext: topContext.
	self assert: session interruptedContext identicalTo: topContext.
	self assert: session interruptedContext pc equals: topPC! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testStepOver
	| method ctx |
	method := self class >> #setResult.
	ctx := session interruptedContext.
	debugActionModel stepOver: ctx.
	self assert: session interruptedContext identicalTo: ctx.
	self assert: ctx top equals: 4.
	debugActionModel stepOver: ctx.
	self assert: session interruptedContext identicalTo: ctx.
	self assert: result equals: 4.
	self
		assert: (method sourceNodeForPC: session interruptedContext pc)
		identicalTo: method ast statements second! !

!StDebuggerActionModelTest methodsFor: 'helper' stamp: ''!
method2: i
	<haltOrBreakpointForTesting>
	i = 9999 ifTrue: [ self halt. ^i ].
	^self method1: i+1! !

!StDebuggerActionModelTest methodsFor: 'tests - stack filtering' stamp: ''!
testFilterMissingSubclassResponsibilityStack

	|stack filteredStack|	
	
	"We change the stack with an interrupted context that does not contain the <debuggerCompleteToSender> pragma"
	self changeSession: StTestDebuggerProvider new debuggerWithMissingSubclassResponsibilityContext session.
	stack := OrderedCollection new.
	stack add: debugActionModel topContext.
	stack add: debugActionModel topContext sender.
	stack add: debugActionModel interruptedContext.
	stack add: (self emptyContextForMethod: (self class>>#method1:)).
	stack add: (self emptyContextForMethod: (self class>>#method2:)).
	
	filteredStack := debugActionModel filterStack: stack copy.
	self assert: filteredStack size equals: 2.
	self assert: filteredStack first identicalTo: stack fourth.
	self assert: filteredStack second identicalTo: stack fifth! !

!StDebuggerActionModelTest methodsFor: 'benchmarks' stamp: ''!
bench: aBlock
	^ aBlock timeToRun asNanoSeconds! !

!StDebuggerActionModelTest methodsFor: 'benchmarks' stamp: ''!
benchmarkFilterStack
	| stack1 stack2 beforeResults afterResults |
	[ self method1: 0 ]
		on: Halt
		do: [ :halt | 
			session := Process new
				           newDebugSessionNamed: 'profiling'
				           startedAt: halt signalerContext.
			stack1 := session stack.	
			stack2 := stack1 copy.		
			debugActionModel := StDebuggerActionModel new.
			debugActionModel session: session.
			beforeResults := 0.
			10000 timesRepeat: [ 
				beforeResults := beforeResults + (self bench: [ 
					                  stack1 reject: [ :aContext | 
						                  aContext method hasPragmaNamed:
							                  #debuggerCompleteToSender ] ]) ].
			afterResults := 0.
			10000 timesRepeat: [ 
				afterResults := afterResults
				                +
				                (self bench: [ 
					                 debugActionModel filterStack: stack2 ]) ] ].
	^'Old behavior: ', beforeResults printString, ' nanoseconds measured. 
	New behavior: ', afterResults printString, ' nanoseconds measured.'! !

!StDebuggerActionModelTest methodsFor: 'tests - predicates' stamp: ''!
testIsInterruptedContextSubclassResponsibilityException
	self changeSession: StTestDebuggerProvider new debuggerWithMissingSubclassResponsibilityContext session.
	self assert: debugActionModel isInterruptedContextSubclassResponsibilityException! !

!StDebuggerActionModelTest methodsFor: 'helper' stamp: ''!
method1: i
	^self method2: i+1! !

!StDebuggerActionModelTest methodsFor: 'tests - stack filtering' stamp: ''!
testFilterDNUStack

	|stack filteredStack|
	self changeSession: StTestDebuggerProvider new debuggerWithDNUContext session.
	stack := OrderedCollection new.
	
	"First, the stack contains a top context (i.e. from which a signal was sent), then the interrupted context"
	stack add: debugActionModel topContext.
	
	"Second, the stack contexts is a MNU that has a method with the <debuggerCompleteToSender> pragma"
	stack add: debugActionModel interruptedContext.	
	
	"Then we have an imaginary call stack"
	stack add: (self emptyContextForMethod: (self class>>#method1:)).
	stack add: (self emptyContextForMethod: (self class>>#method2:)).
	
	filteredStack := debugActionModel filterStack: stack copy.
	
	self assert: filteredStack size equals: 2.
	self assert: filteredStack first identicalTo: stack third.
	self assert: filteredStack second identicalTo: stack fourth
	! !

!StDebuggerActionModelTest methodsFor: 'tests' stamp: ''!
testImplementMethodClassification

	| method |
	[ StDebuggerUsingSpecSelectorMock new method ]
		on: Error
		do: [ :dnu | 
			debugActionModel
				implement: dnu message
				classified: Protocol unclassified
				inClass: StDebuggerUsingSpecSelectorMock
				forContext: dnu signalerContext ].

	[ StDebuggerUsingSpecSelectorMock new testMethod ]
		on: Error
		do: [ :dnu | 
			debugActionModel
				implement: dnu message
				classified: Protocol unclassified
				inClass: StDebuggerUsingSpecSelectorMock
				forContext: dnu signalerContext ].

	[ StDebuggerUsingSpecSelectorMock new unclassifiedMethod ]
		on: Error
		do: [ :dnu | 
			debugActionModel
				implement: dnu message
				classified: Protocol unclassified
				inClass: StDebuggerUsingSpecSelectorMock
				forContext: dnu signalerContext ].

	method := StDebuggerUsingSpecSelectorMock lookupSelector: #method.
	self assert: method protocol equals: 'accessing'.
	
	method := StDebuggerUsingSpecSelectorMock lookupSelector: #testMethod.
	self assert: method protocol equals: 'tests'.
	
	method := StDebuggerUsingSpecSelectorMock lookupSelector: #unclassifiedMethod.
	self assert: method protocol equals: Protocol unclassified! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testCopyStackToClipboard
	debugActionModel copyStackToClipboard.
	self
		assert: Clipboard clipboardText string
		equals:
			(String
				streamContents: [ :s | session interruptedContext shortDebugStackOn: s ])! !

!StDebuggerActionModelTest methodsFor: 'tests - stack filtering' stamp: ''!
testDynamicShouldFilterStackUpdate

	|mockDebugActionModel context|
	mockDebugActionModel := StMockDebuggerActionModel new.		
	self assert: mockDebugActionModel filterStack.
	self assert: mockDebugActionModel shouldFilterStack.
	
	context := Context
		sender: nil
		receiver: nil
		method: Object >> #doesNotUnderstand:
		arguments: #(#message).
	mockDebugActionModel interruptedContext: context.
	mockDebugActionModel stepInto: context.
	self deny: mockDebugActionModel filterStack.
	self deny: mockDebugActionModel shouldFilterStack.
	
	mockDebugActionModel stepOver: context.
	self deny: mockDebugActionModel filterStack.
	self deny: mockDebugActionModel shouldFilterStack.
	
	mockDebugActionModel := StMockDebuggerActionModel new.		
	self assert: mockDebugActionModel filterStack.
	self assert: mockDebugActionModel shouldFilterStack.
	
	context := Context
		sender: nil
		receiver: nil
		method: Object >> #asString
		arguments: #().
	mockDebugActionModel interruptedContext: context.
	mockDebugActionModel stepInto: context.
	self deny: mockDebugActionModel filterStack.
	self deny: mockDebugActionModel shouldFilterStack.
	
	mockDebugActionModel stepOver: context.
	self assert: mockDebugActionModel filterStack.
	self assert: mockDebugActionModel shouldFilterStack.
	
	
	
	
	! !

!StDebuggerActionModelTest methodsFor: 'tests - predicates' stamp: ''!
testIsInterruptedContextDead
	session interruptedContext pc: nil.
	self assert: debugActionModel isInterruptedContextDead! !

!StDebuggerActionModelTest methodsFor: 'tests - stack filtering' stamp: ''!
testDynamicShouldFilterStack

	|mockDebugActionModel|
	mockDebugActionModel := StMockDebuggerActionModel new.
	
	self assert: mockDebugActionModel filterStack.
	
	StDebuggerActionModel shouldFilterStack: true.
	self assert: mockDebugActionModel shouldFilterStack.
	
	StDebuggerActionModel shouldFilterStack: false.
	self deny: mockDebugActionModel shouldFilterStack ! !

!StDebuggerActionModelTest methodsFor: 'tests - predicates' stamp: ''!
testUpdateDebugSession

	| exception |
	self changeSession:
		StTestDebuggerProvider new debuggerWithErrorContext session.
	exception := session exception.
	session exception: nil.
	debugActionModel updateDebugSession.
	self assert: session exception notNil.
	self assert: session exception identicalTo: exception! !

!StDebuggerActionModelTest methodsFor: 'tests - stack filtering' stamp: ''!
testDefaultShouldFilterStack

	self assert: StDebuggerActionModel shouldFilterStack! !

!StDebuggerActionModelTest methodsFor: 'running' stamp: ''!
setUp
	| method context process |
	super setUp.
	method := self class >> #setResult.
	process := [ method valueWithReceiver: self arguments: #() ]
		newProcess.
	context := process suspendedContext.
	session ifNotNil: [ session clear ].
	session := (StTestDebuggerProvider new debuggerWithContext: context)
		session.
	session
		stepIntoUntil: [ :currentContext | currentContext method == method ].
	debugActionModel := StDebuggerActionModel on: session.
	shouldFilterStack := StDebuggerActionModel shouldFilterStack.! !

!StDebuggerActionModelTest methodsFor: 'tests - contexts' stamp: ''!
testUpdateTopContextAfterSessionOperation
	|mockDebugActionModel context|
	context := [  ] asContext.
	mockDebugActionModel := StMockDebuggerActionModel new.
	mockDebugActionModel stepInto: context.
	self assert: mockDebugActionModel tag equals: #updateTopContext.
	
	mockDebugActionModel := StMockDebuggerActionModel new.
	mockDebugActionModel stepOver: context.
	self assert: mockDebugActionModel tag equals: #updateTopContext.
	
	mockDebugActionModel := StMockDebuggerActionModel new.
	mockDebugActionModel stepThrough: context.
	self assert: mockDebugActionModel tag equals: #updateTopContext.
	
	mockDebugActionModel := StMockDebuggerActionModel new.
	mockDebugActionModel restartContext: context.
	self assert: mockDebugActionModel tag equals: #updateTopContext.
	
	mockDebugActionModel := StMockDebuggerActionModel new.
	mockDebugActionModel returnValueFromExpression: 'nil' fromContext: [] asContext.
	self assert: mockDebugActionModel tag equals: #updateTopContext.
	
	mockDebugActionModel := StMockDebuggerActionModel new.
	mockDebugActionModel runToSelection: nil inContext: nil.
	self assert: mockDebugActionModel tag equals: #updateTopContext.
	
	mockDebugActionModel := StMockDebuggerActionModel new.
	mockDebugActionModel implement: nil classified: nil inClass: nil forContext: nil.
	self assert: mockDebugActionModel tag equals: #updateTopContext
	
	
	! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testReturnValueFromExpressionFromContext
	session stepInto.
	session stepInto.
	debugActionModel returnValueFromExpression: '0' fromContext: session interruptedContext.
	self assert: session interruptedContext top equals: 0.
	session resume.
	self assert: result equals: 0! !

!StDebuggerActionModelTest methodsFor: 'running' stamp: ''!
tearDown
	debugger ifNotNil: [ debugger close].
	session ifNotNil: [ session clear ].
	session := nil.
	StDebuggerUsingSpecSelectorMock removeSelector: #testMethod.
	StDebuggerUsingSpecSelectorMock removeSelector: #method.
	StDebuggerUsingSpecSelectorMock removeSelector: #unclassifiedMethod.
	StTestDebuggerProvider removeSelector: #buildDebuggerWithMissingClassContext.
	StTestDebuggerProvider removeSelector: #foobar.
	StDebuggerActionModel shouldFilterStack: shouldFilterStack.
	super tearDown! !

!StDebuggerActionModelTest methodsFor: 'helper' stamp: ''!
fileOutMethod: anObject
	result := anObject! !

!StDebuggerActionModelTest methodsFor: 'helper' stamp: ''!
setResult
	result := 2 squared.
	^result! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testFileOutMethod
	debugActionModel fileOutMethod: self.
	self assert: result equals: self selector! !

!StDebuggerActionModelTest methodsFor: 'tests - stack filtering' stamp: ''!
testFilterStack

	|stack filteredStack|
	self changeSession: StTestDebuggerProvider new debuggerWithDNUContext session.
	stack := OrderedCollection new.
	
	"First, add to the stack a MNU context that has a method with the <debuggerCompleteToSender> pragma"
	stack add: debugActionModel interruptedContext.	
	
	"Then we have an imaginary call stack"
	stack add: (self emptyContextForMethod: (self class>>#method1:)).
	stack add: (self emptyContextForMethod: (self class>>#method2:)).
	
	
	StDebuggerActionModel shouldFilterStack: false.
	filteredStack := debugActionModel filterStack: stack copy.
	self assertCollection:  filteredStack equals: stack.
	
	StDebuggerActionModel shouldFilterStack: true.
	filteredStack := debugActionModel filterStack: stack copy.
	self assert: filteredStack size equals: 2.
	self assert: filteredStack first identicalTo: stack second.
	self assert: filteredStack second identicalTo: stack third! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testRunToSelectionInContext
	|method node|
	method := (self class >> #setResult).
	node :=  method ast statements second.
	debugActionModel runToSelection: (node start to: node stop) inContext: session interruptedContext.
	self assert: result equals: 4.
	self assert: (method sourceNodeForPC: session interruptedContext pc) identicalTo: node! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testStepInto
	|ctx|
	ctx := session interruptedContext.
	debugActionModel stepInto: ctx.
	self deny: ctx stepIntoQuickMethod.
	self assert: session interruptedContext sender identicalTo: ctx.
	self assert: session stack second identicalTo: ctx! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testPeelToFirstLike

	| firstCaller |
	
	self changeSession:
		StTestDebuggerProvider new debuggerWithRecursiveContext session.
		
	session stepInto.
	session stepInto.
	
	firstCaller := session stack first.	
	session stepInto.
	session stepInto.
	session stepInto.
	session stepInto.
	debugActionModel updateTopContext.
	
	"Explaining the context"
	self deny: session stack first method identicalTo: session stack second method.
	self assert: session stack first method identicalTo: session stack third method.	
	self assert: debugActionModel topContext identicalTo: session stack first.
		
	"The peel to first like the first context should pop contexts until the session is back to the first recursive sender down in the stack"
	debugActionModel peelToFirstLike: firstCaller.
	self assert: session interruptedContext identicalTo: firstCaller.
	self assert: debugActionModel topContext identicalTo: firstCaller! !

!StDebuggerActionModelTest methodsFor: 'tests - predicates' stamp: ''!
testIsInterruptedContextAnAssertEqualsFailure

	self changeSession:
		StTestDebuggerProvider new debuggerWithFailingAssertionContext
			session.
	self assert: debugActionModel isContextAnAssertionFailure! !

!StDebuggerActionModelTest methodsFor: 'tests - predicates' stamp: ''!
testIsInterruptedContextPostMortem
	session resume.
	self assert: debugActionModel isInterruptedContextPostMortem! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testCreateMissingMethod! !

!StDebuggerActionModelTest methodsFor: 'tests - contexts' stamp: ''!
testUpdateTopContext
	
	self changeSession: StTestDebuggerProvider new debuggerWithMissingSubclassResponsibilityContext session.
	self deny: debugActionModel topContext identicalTo: debugActionModel interruptedContext.
	debugActionModel updateTopContext.		
	self assert: debugActionModel topContext identicalTo: debugActionModel interruptedContext
	
	
	! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testStepIntoQuickMethods
	|ctx|
	ctx := StMockContext new.
	debugActionModel session: StMockSession new.
	debugActionModel stepInto: ctx.
	
	"When we step into a context, first that context is configured to step into quick method (aContext stepIntoQuickMethod: true),
	second it steps,
	after stepping it is configured back to **not** stepping into quick methods (aContext stepIntoQuickMethod: false).
	The mock context just records that sequence of configuration."
	self assert: ctx stepIntoQuickMethodBooleans size equals: 2.
	self assert: ctx stepIntoQuickMethodBooleans first equals: true.
	self assert: ctx stepIntoQuickMethodBooleans second equals: false! !

!StDebuggerActionModelTest methodsFor: 'tests - predicates' stamp: ''!
testIsInterruptedContextDoesNotUnderstand
	self changeSession: StTestDebuggerProvider new debuggerWithDNUContext session.
	self assert: debugActionModel isInterruptedContextDoesNotUnderstand.
	StTestDebuggerProvider compile: 'foobar ^self'.
	self deny: debugActionModel isInterruptedContextDoesNotUnderstand! !

!StDebuggerActionModelTest methodsFor: 'helper' stamp: ''!
changeSession: aDebugSession

	session clear.
	session := aDebugSession.
	debugActionModel := StDebuggerActionModel on: session! !

!StDebuggerActionModelTest methodsFor: 'tests - predicates' stamp: ''!
testIsContextSteppable
	self assert: debugActionModel isContextSteppable! !

!StDebuggerActionModelTest methodsFor: 'tests - actions' stamp: ''!
testProceedDebugSession
	self deny: session interruptedContext isNil.
	self assert: result isNil.
	debugActionModel proceedDebugSession.
	self assert: session interruptedContext isNil.
	self assert: result equals: 4! !

!StDebuggerActionModelTest methodsFor: 'helper' stamp: ''!
emptyContextForMethod: aCompiledMethod
	^ (Context newForMethod: aCompiledMethod)
		  initializeWith: nil
		  stackPtr: nil
		  method: aCompiledMethod
		  receiver: nil
		  sender: nil;
		  yourself! !

!StDebuggerActionModelTest methodsFor: 'tests' stamp: ''!
testInitialization
	self assert: debugActionModel session identicalTo: session.
	self
		assert: debugActionModel interruptedContext
		identicalTo: session interruptedContext! !

!StDebuggerActionModelTest methodsFor: 'helper' stamp: ''!
methodWithPragma
	<debuggerCompleteToSender>! !

!StDebuggerActionModelTest methodsFor: 'tests - contexts' stamp: ''!
testComputeInitialTopContext
	|newSession|
	self changeSession: StTestDebuggerProvider new debuggerWithMissingSubclassResponsibilityContext session.
	self assert: debugActionModel topContext identicalTo: session exception signalContext.
	
	newSession := StTestDebuggerProvider new debuggerWithMissingSubclassResponsibilityContext session.
	newSession restart: newSession interruptedContext sender.	
	self changeSession: newSession.
	self assert: debugActionModel topContext identicalTo: session interruptedContext
	! !

!StDebuggerActionModelTest class methodsFor: 'benchmarking' stamp: ''!
benchFilterStack
	<script>
	^self new benchmarkFilterStack inspect! !

!StDebuggerAssertionContextTest methodsFor: 'tests' stamp: ''!
testFindFailedAssertionContextInSenderChain
	| debugger |
	debugger := StTestDebuggerProvider new debuggerWithFailingAssertionContext.
	session := debugger session.
	self assert: session interruptedContext findFailedAssertionContextInSenderChain notNil.
	session clear.
	debugger := StTestDebuggerProvider new debuggerWithDNUContext. 
	session := debugger session.
	self should: [ session interruptedContext findFailedAssertionContextInSenderChain ] raise: StDebuggeAssertionFailureContextNotFound.
	! !

!StDebuggerAssertionContextTest methodsFor: 'running' stamp: ''!
tearDown
	session ifNotNil:[session clear].
	super tearDown ! !

!StDebuggerAssertionContextTest methodsFor: 'tests' stamp: ''!
testFindFailedAssertionResultsInSenderChain
	| debugger assertionResult|
	debugger := StTestDebuggerProvider new debuggerWithFailingAssertionContext.
	session := debugger session.
	assertionResult := session interruptedContext findFailedAssertionResultsInSenderChain.
	
	self assert: assertionResult actual equals: 4.
	self assert: assertionResult expected equals: 2.
	
	session clear.
	debugger := StTestDebuggerProvider new debuggerWithDNUContext. 
	session := debugger session.
	self should: [session interruptedContext findFailedAssertionResultsInSenderChain] raise: StDebuggeAssertionFailureContextNotFound.
	! !

!StDebuggerAssertionFailureResult commentStamp: ''!
I am just a convenience place holder for the results of an assertion failure:
- actual: the actual result of the assertion
- expected: the expected result of the assertion
I am meant to be used when expected and actual results do not satisfy the assertion.!
!StDebuggerAssertionFailureResult methodsFor: 'accessing' stamp: ''!
actual

	^ actual! !

!StDebuggerAssertionFailureResult methodsFor: 'accessing' stamp: ''!
actual: anObject

	actual := anObject! !

!StDebuggerAssertionFailureResult methodsFor: 'accessing' stamp: ''!
expected

	^ expected! !

!StDebuggerAssertionFailureResult methodsFor: 'accessing' stamp: ''!
expected: anObject

	expected := anObject! !

!StDebuggerBreakpointInspection commentStamp: ''!
Breakpoint inspection specialized for the debugger.
Instead of showing breakpoints and halts in the inspected object, shows them for the whole system.
Data is taken from system's and tools' caches.!
!StDebuggerBreakpointInspection methodsFor: 'private' stamp: ''!
breakPointsForModel
	^ Breakpoint all! !

!StDebuggerBreakpointInspection methodsFor: 'debugger extension' stamp: ''!
debuggerExtensionToolName

	^ 'Breakpoints'! !

!StDebuggerBreakpointInspection methodsFor: 'debugger extension' stamp: ''!
displayOrder
	^self class displayOrder! !

!StDebuggerBreakpointInspection methodsFor: 'private' stamp: ''!
buildHaltData

	^ StHaltCache defaultCache methodsWithHalts values flattened 
		  collect: [ :node | StHaltInspectionItem forHalt: node ]! !

!StDebuggerBreakpointInspection class methodsFor: 'debugger extension' stamp: ''!
displayOrder: anInteger
	debuggerExtensionDisplayOrder := anInteger! !

!StDebuggerBreakpointInspection class methodsFor: 'debugger extension' stamp: ''!
showInDebugger: aBoolean
	showDebuggerExtension := aBoolean! !

!StDebuggerBreakpointInspection class methodsFor: 'debugger extension' stamp: ''!
displayOrder

	^ debuggerExtensionDisplayOrder ifNil: [ 
		  debuggerExtensionDisplayOrder := self defaultDisplayOrder ]! !

!StDebuggerBreakpointInspection class methodsFor: 'debugger extension' stamp: ''!
defaultDisplayOrder

	^ 3! !

!StDebuggerBreakpointInspection class methodsFor: 'debugger extension' stamp: ''!
showInDebugger
	^showDebuggerExtension ifNil: [showDebuggerExtension := false]! !

!StDebuggerCodeCommandTreeBuilder commentStamp: ''!
I build the default command tree for the debugger code presenter.
The command classes I instantiate are specified under the "accessing - commands classes" protocol.
The group names and descriptions are specified under the "accessing" protocol.

You can evolve the default groups names and descriptions and the default command classes, but you cannot extend me.
Using me to add command in the tree makes them default for the debugger toolbar presenter.!
!StDebuggerCodeCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
codeExecutionControlCommandsClasses
	^ {StRunToSelectionCommand}! !

!StDebuggerCodeCommandTreeBuilder methodsFor: 'building' stamp: ''!
buildDebuggerCommandGroup
	| codeGroup |
	codeGroup := self group.
	codeGroup decoratedGroup register: self codeDebugCommands.
	codeGroup beDisplayedAsGroup! !

!StDebuggerCodeCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
codeDebugCommandsGroupName
	^'Execution'! !

!StDebuggerCodeCommandTreeBuilder methodsFor: 'commands' stamp: ''!
codeDebugCommands
	| group |
	group := (CmCommandGroup named: self codeDebugCommandsGroupName)
		asSpecGroup.
	group beDisplayedAsGroup.
	group description: self codeDebugCommandsDescription.
	group iconName: #smallDoIt.
	self codeExecutionControlCommandsClasses
		do: [ :cmdClass | 
			group
				register: (self buildSpecCommand: cmdClass forContext: stDebuggerInstance) ].
	^ group! !

!StDebuggerCodeCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
codeDebugCommandsDescription
	^'Execution control'! !

!StDebuggerCodeCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
groupDescription
	^ 'Debug actions from code'! !

!StDebuggerCodeCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
displayStrategy
	^CmUIDisplayAsSubMenu ! !

!StDebuggerCodeCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
groupName 	
	^'Code'! !

!StDebuggerCodeCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testCodeDebugCommandsDescription
	self assert: builder  codeDebugCommandsDescription equals: 'Execution control'! !

!StDebuggerCodeCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testCodeExecutionControlCommandsClasses
	self
		assertCollection: builder codeExecutionControlCommandsClasses
		equals: {StRunToSelectionCommand}! !

!StDebuggerCodeCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testCodeDebugCommandsGroupName
	self assert: builder  codeDebugCommandsGroupName equals: 'Execution'! !

!StDebuggerCodeCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testDisplayStrategy
	self assert: builder class displayStrategy equals: CmUIDisplayAsSubMenu! !

!StDebuggerCodeCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testCodeDebugCommands
	|codeCommandClasses|
	codeCommandClasses := OrderedCollection new.
	codeCommandClasses addAll: builder codeExecutionControlCommandsClasses.
	self
		assertCommandGroup: builder codeDebugCommands
		hasSameCommands: codeCommandClasses
		withContext: debugger
		displayStrategy: CmUIDisplayAsGroup! !

!StDebuggerCodeCommandTreeBuilderTest methodsFor: 'instance creation' stamp: ''!
newBuilder
	^ StDebuggerCodeCommandTreeBuilder
		buildCommandsGroupWith: debugger
		forRoot: rootGroup! !

!StDebuggerCodeCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testGroupDescription
	self assert: builder class groupDescription equals: 'Debug actions from code'! !

!StDebuggerCodeCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testGroupName
	self assert: builder class groupName equals: 'Code'! !

!StDebuggerCommand commentStamp: ''!
I command actions that can be requested from a debugger!
!StDebuggerCommand methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ context = anObject context
		and: [ basicName = anObject name ]! !

!StDebuggerCommand methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self description: (String streamContents: [ :stream | 
		stream 
			<< self class defaultName
			<< ': '
			<< self class defaultDescription ])! !

!StDebuggerCommand methodsFor: 'converting' stamp: ''!
asSpecCommand
	
	^ super asSpecCommand
		iconProvider: StPharoApplication current iconProvider;
		yourself! !

!StDebuggerCommand methodsFor: 'accessing' stamp: ''!
debugger
	^self context! !

!StDebuggerCommand methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ context hash bitXor: basicName hash! !

!StDebuggerCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ aDebugger canExecuteDebugCommand! !

!StDebuggerCommand methodsFor: 'accessing' stamp: ''!
canBeExecuted
	^ self appliesTo: self debugger! !

!StDebuggerCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ self subclassResponsibility! !

!StDebuggerCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == StDebuggerCommand! !

!StDebuggerCommand class methodsFor: 'instance creation' stamp: ''!
toolbarCommandsForDebugger: debugger

	^ self
		instantiateCommandsFromPragma: #toolbarDebugCommand:
		for: debugger! !

!StDebuggerCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName
	^ self subclassResponsibility! !

!StDebuggerCommand class methodsFor: 'instance creation' stamp: ''!
forSpecContext: anObject
	^ (self
		forSpecWithIconNamed: self defaultIconName
		shortcutKey: self defaultShortcut)
		context: anObject;
		yourself! !

!StDebuggerCommand class methodsFor: 'default' stamp: ''!
shortName
	^self defaultName! !

!StDebuggerCommand class methodsFor: 'instance creation' stamp: ''!
codeContextMenuCommandsForDebugger: debugger

	^ self
		instantiateCommandsFromPragma: #CodeContextMenuDebugCommand
		for: debugger! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStStepOverCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StStepOverCommand forContext: debugger.
	"StStepOverCommand command calls the #stepOver action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #stepOver! !

!StDebuggerCommandTest methodsFor: 'tests' stamp: ''!
testCommandsInMissingSubclassResponsibilityContext

	|debugger|
	debugger := debuggerProvider debuggerWithMissingSubclassResponsibilityContext.
	
	"Executable commands relative to context"
	self assert: (StDefineSubclassResponsabilityCommand forContext: debugger) canBeExecuted.
	self assert: (StDefineMissingEntityCommand forContext: debugger) canBeExecuted.  
	self assert: (StRestartCommand forContext: debugger) canBeExecuted. 
	self assert: (StReturnValueCommand forContext: debugger) canBeExecuted. 
	
	"Non-executable commands relative to context"
	self deny: (StStepIntoCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepOverCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepThroughCommand forContext: debugger) canBeExecuted. 
	self deny: (StRunToSelectionCommand forContext: debugger) canBeExecuted.
	self deny: (StProceedCommand forContext: debugger) canBeExecuted.
	self deny: (StDefineClassCommand forContext: debugger) canBeExecuted.  
	self deny: (StDefineMethodCommand forContext: debugger) canBeExecuted.  
	
	"Executable commands, whatever the context"
	self assert: (StCopyStackToClipboardCommand forContext: debugger) canBeExecuted. 
	self assert: (StFileOutMethodCommand forContext: debugger) canBeExecuted. 
	self assert: (StPeelToFirstCommand forContext: debugger) canBeExecuted. 
	self assert: (StShowFullStackCommand forContext: debugger) canBeExecuted.	
	self assert: (StWhereIsCommand forContext: debugger) canBeExecuted. ! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStRunToSelectionCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StRunToSelectionCommand forContext: debugger.
	"StRunToSelectionCommand command calls the #runToSelection action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #runToSelection! !

!StDebuggerCommandTest methodsFor: 'tests' stamp: ''!
testCommandsInDNUContext

	|debugger|
	debugger := debuggerProvider debuggerWithDNUContext.
	
	"Executable commands relative to context"
	self assert: (StDefineMethodCommand forContext: debugger) canBeExecuted.
	self assert: (StDefineMissingEntityCommand forContext: debugger) canBeExecuted.  
	self assert: (StRestartCommand forContext: debugger) canBeExecuted. 
	self assert: (StReturnValueCommand forContext: debugger) canBeExecuted. 
	
	"Non-executable commands relative to context"
	self deny: (StStepIntoCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepOverCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepThroughCommand forContext: debugger) canBeExecuted. 
	self deny: (StRunToSelectionCommand forContext: debugger) canBeExecuted.
	self deny: (StProceedCommand forContext: debugger) canBeExecuted.
	self deny: (StDefineClassCommand forContext: debugger) canBeExecuted.  
	self deny: (StDefineSubclassResponsabilityCommand forContext: debugger) canBeExecuted.  
	
	"Executable commands, whatever the context"
	self assert: (StCopyStackToClipboardCommand forContext: debugger) canBeExecuted. 
	self assert: (StFileOutMethodCommand forContext: debugger) canBeExecuted. 
	self assert: (StPeelToFirstCommand forContext: debugger) canBeExecuted. 
	self assert: (StShowFullStackCommand forContext: debugger) canBeExecuted.	
	self assert: (StWhereIsCommand forContext: debugger) canBeExecuted. ! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStFileOutMethodCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StFileOutMethodCommand forContext: debugger.
	"StFileOutMethodCommand command calls the #fileOutSelectedContext action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #fileOutSelectedContext! !

!StDebuggerCommandTest methodsFor: 'tests' stamp: ''!
testCommandsInDeadContext

	|debugger|

	debugger := debuggerProvider debuggerWithErrorContext.
	debugger debuggerActionModel contextPredicate context pc: nil.
		
	"Non-executable commands relative to context"
	self deny: (StRestartCommand forContext: debugger) canBeExecuted. 
	self deny: (StReturnValueCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepIntoCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepOverCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepThroughCommand forContext: debugger) canBeExecuted. 
	self deny: (StRunToSelectionCommand forContext: debugger) canBeExecuted.
	self deny: (StProceedCommand forContext: debugger) canBeExecuted.
	self deny: (StDefineClassCommand forContext: debugger) canBeExecuted.  
	self deny: (StDefineSubclassResponsabilityCommand forContext: debugger) canBeExecuted.  
	self deny: (StDefineMethodCommand forContext: debugger) canBeExecuted.
	self deny: (StDefineMissingEntityCommand forContext: debugger) canBeExecuted.  
	
	"Executable commands, whatever the context"
	self assert: (StCopyStackToClipboardCommand forContext: debugger) canBeExecuted. 
	self assert: (StFileOutMethodCommand forContext: debugger) canBeExecuted. 
	self assert: (StPeelToFirstCommand forContext: debugger) canBeExecuted. 
	self assert: (StShowFullStackCommand forContext: debugger) canBeExecuted.	
	self assert: (StWhereIsCommand forContext: debugger) canBeExecuted. ! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStDefineClassCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StDefineClassCommand forContext: debugger.
	"StDefineClassCommand command calls the #createMissingClass action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #createMissingClass! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStStepIntoCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StStepIntoCommand forContext: debugger.
	"StStepIntoCommand command calls the #stepInto action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #stepInto! !

!StDebuggerCommandTest methodsFor: 'tests' stamp: ''!
testCommandsInFailingTestContext

	|debugger|
	debugger := debuggerProvider debuggerWithFailingTestContext.
	self flag:'Cannot work until we can properly detect a failing assertion context'.
	
	"Executable commands relative to context"	
	self assert: (StRestartCommand forContext: debugger) canBeExecuted. 
	self assert: (StReturnValueCommand forContext: debugger) canBeExecuted. 
	
	"Non-executable commands relative to context"
	self deny: (StStepIntoCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepOverCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepThroughCommand forContext: debugger) canBeExecuted. 
	self deny: (StRunToSelectionCommand forContext: debugger) canBeExecuted.
	self deny: (StProceedCommand forContext: debugger) canBeExecuted.
	self deny: (StDefineClassCommand forContext: debugger) canBeExecuted.  
	self deny: (StDefineSubclassResponsabilityCommand forContext: debugger) canBeExecuted.  
	self deny: (StDefineMethodCommand forContext: debugger) canBeExecuted.
	self deny: (StDefineMissingEntityCommand forContext: debugger) canBeExecuted.  
	
	"Executable commands, whatever the context"
	self assert: (StCopyStackToClipboardCommand forContext: debugger) canBeExecuted. 
	self assert: (StFileOutMethodCommand forContext: debugger) canBeExecuted. 
	self assert: (StPeelToFirstCommand forContext: debugger) canBeExecuted. 
	self assert: (StShowFullStackCommand forContext: debugger) canBeExecuted.	
	self assert: (StWhereIsCommand forContext: debugger) canBeExecuted. ! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStStepThroughCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StStepThroughCommand forContext: debugger.
	"StStepThroughCommand command calls the #stepThrough action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #stepThrough! !

!StDebuggerCommandTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."

	super setUp.
	debuggerProvider := StTestDebuggerProvider new! !

!StDebuggerCommandTest methodsFor: 'tests' stamp: ''!
testCommandsInMissingClassContext
	"When a class is missing, it is possible we are trying to send it a message.
	Define new class and define new method must be possible. "	
	| debugger |
	
	StTestDebuggerProvider compileMissingClassContextBuilder.
	debugger := debuggerProvider debuggerWithMissingClassContext.
	
	"Executable commands relative to context"	
	self assert: (StDefineClassCommand forContext: debugger) canBeExecuted.	
	self deny: (StDefineMethodCommand forContext: debugger) canBeExecuted.
	self assert: (StDefineMissingEntityCommand forContext: debugger) canBeExecuted.  
	self assert: (StRestartCommand forContext: debugger) canBeExecuted. 
	self assert: (StReturnValueCommand forContext: debugger) canBeExecuted. 
	
	"Non-executable commands relative to context"
	self deny: (StStepIntoCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepOverCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepThroughCommand forContext: debugger) canBeExecuted. 
	self deny: (StRunToSelectionCommand forContext: debugger) canBeExecuted.
	self deny: (StProceedCommand forContext: debugger) canBeExecuted. 
	self deny: (StDefineSubclassResponsabilityCommand forContext: debugger) canBeExecuted.  
	
	
	"Executable commands, whatever the context"
	self assert: (StCopyStackToClipboardCommand forContext: debugger) canBeExecuted. 
	self assert: (StFileOutMethodCommand forContext: debugger) canBeExecuted. 
	self assert: (StPeelToFirstCommand forContext: debugger) canBeExecuted. 
	self assert: (StShowFullStackCommand forContext: debugger) canBeExecuted.	
	self assert: (StWhereIsCommand forContext: debugger) canBeExecuted. ! !

!StDebuggerCommandTest methodsFor: 'running' stamp: ''!
tearDown
	debuggerProvider terminate.
	(StTestDebuggerProvider lookupSelector:
		 #buildDebuggerWithMissingClassContext) ifNotNil: [ :method | 
		method removeFromSystem ].
	super tearDown! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStRestartCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StRestartCommand forContext: debugger.
	"StRestartCommand command calls the #restartCurrentContext action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #restartCurrentContext! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStReturnValueCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StReturnValueCommand forContext: debugger.
	"StReturnValueCommand command calls the #returnEnteredValue action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #returnEnteredValue! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStCopyStackToClipboardCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StCopyStackToClipboardCommand forContext: debugger.
	"StCopyStackToClipboardCommand command calls the #copyStackToClipboard action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #copyStackToClipboard! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStWhereIsCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StWhereIsCommand forContext: debugger.
	"StWhereIsCommand command calls the #selectNextExecutedExpression action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #selectNextExecutedExpression! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStDefineMethodCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StDefineMethodCommand forContext: debugger.
	"StDefineMethodCommand command calls the #createMissingMethod action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #createMissingMethod! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStShowFullStackCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StShowFullStackCommand forContext: debugger.
	"StShowFullStackCommand command calls the #showFullStack action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #showFullStack! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStDefineSubclassResponsabilityCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StDefineSubclassResponsabilityCommand forContext: debugger.
	"StDefineSubclassResponsabilityCommand command calls the #createSubclassResponsibility action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #createSubclassResponsibility! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStProceedCommandExecution
	"Generated 5 June 2020"
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StProceedCommand forContext: debugger.
	"StProceedCommand command calls the #proceedDebugSession action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #proceedDebugSession! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStPeelToFirstCommandExecution
	
	|debugger command|
	debugger := StDummyDebuggerPresenter new.
	command := StPeelToFirstCommand forContext: debugger.
	"StCopyStackToClipboardCommand command calls the #copyStackToClipboard action interface of the debugger object"
	command execute.
	self assert: debugger tag equals: #peelToFirstLike:! !

!StDebuggerCommandTest methodsFor: 'tests - execution' stamp: ''!
testStDefineMissingEntityCommandExecution
	| debugger command |
	
	StTestDebuggerProvider compileMissingClassContextBuilder.
	debugger := debuggerProvider debuggerWithDNUContext.
	command := StDefineMissingEntityCommand forContext: debugger.
	self
		assertCollection: (command subCommands collect: [ :c | c class ])
		equals: StDefineMissingEntityCommand allSubclasses.
	self
		assert: command applicableCommand class
		identicalTo: StDefineMethodCommand.	
	
	debugger := debuggerProvider debuggerWithMissingClassContext.
	command := StDefineMissingEntityCommand forContext: debugger.
	self
		assert: command applicableCommand class
		identicalTo: StDefineClassCommand.
		
	debugger := debuggerProvider debuggerWithMissingSubclassResponsibilityContext.
	command := StDefineMissingEntityCommand forContext: debugger.
	self
		assert: command applicableCommand class
		identicalTo: StDefineSubclassResponsabilityCommand.
	! !

!StDebuggerCommandTest methodsFor: 'tests' stamp: ''!
testCommandsInErrorContext

	|debugger|

	debugger := debuggerProvider debuggerWithErrorContext.
		
	"Executable commands relative to context"	
	self assert: (StRestartCommand forContext: debugger) canBeExecuted. 
	self assert: (StReturnValueCommand forContext: debugger) canBeExecuted. 
	
	"Non-executable commands relative to context"
	self deny: (StStepIntoCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepOverCommand forContext: debugger) canBeExecuted. 
	self deny: (StStepThroughCommand forContext: debugger) canBeExecuted. 
	self deny: (StRunToSelectionCommand forContext: debugger) canBeExecuted.
	self deny: (StProceedCommand forContext: debugger) canBeExecuted.
	self deny: (StDefineClassCommand forContext: debugger) canBeExecuted.  
	self deny: (StDefineSubclassResponsabilityCommand forContext: debugger) canBeExecuted.  
	self deny: (StDefineMethodCommand forContext: debugger) canBeExecuted.
	self deny: (StDefineMissingEntityCommand forContext: debugger) canBeExecuted.  
	
	"Executable commands, whatever the context"
	self assert: (StCopyStackToClipboardCommand forContext: debugger) canBeExecuted. 
	self assert: (StFileOutMethodCommand forContext: debugger) canBeExecuted. 
	self assert: (StPeelToFirstCommand forContext: debugger) canBeExecuted. 
	self assert: (StShowFullStackCommand forContext: debugger) canBeExecuted.	
	self assert: (StWhereIsCommand forContext: debugger) canBeExecuted. ! !

!StDebuggerCommandTest methodsFor: 'tests' stamp: ''!
testCommandsInRunnableContext

	|debugger|
	debugger := debuggerProvider debuggerWithRunnableContext.
	
	"Executable commands relative to context"
	self assert: (StStepIntoCommand forContext: debugger) canBeExecuted. 
	self assert: (StStepOverCommand forContext: debugger) canBeExecuted. 
	self assert: (StStepThroughCommand forContext: debugger) canBeExecuted. 
	self assert: (StRunToSelectionCommand forContext: debugger) canBeExecuted.
	self assert: (StProceedCommand forContext: debugger) canBeExecuted. 	
	self assert: (StRestartCommand forContext: debugger) canBeExecuted. 
	self assert: (StReturnValueCommand forContext: debugger) canBeExecuted.
	
	"Non-executable commands relative to context"
	self deny: (StDefineSubclassResponsabilityCommand forContext: debugger) canBeExecuted.  
	self deny: (StDefineMethodCommand forContext: debugger) canBeExecuted.	
	self deny: (StDefineClassCommand forContext: debugger) canBeExecuted.  
	self deny: (StDefineMissingEntityCommand forContext: debugger) canBeExecuted.  
	
	"Executable commands, whatever the context"
	self assert: (StCopyStackToClipboardCommand forContext: debugger) canBeExecuted. 
	self assert: (StFileOutMethodCommand forContext: debugger) canBeExecuted. 
	self assert: (StPeelToFirstCommand forContext: debugger) canBeExecuted. 
	self assert: (StShowFullStackCommand forContext: debugger) canBeExecuted.
	self assert: (StProceedCommand forContext: debugger) canBeExecuted.  	 
	self assert: (StWhereIsCommand forContext: debugger) canBeExecuted. ! !

!StDebuggerCommandTreeBuilder commentStamp: ''!
I am an abstract class which provides interfaces for building a tree of commands for the StDebugger.
I set the debugger instance and the root command group on which the tree is going to be built, and instantiation interface on class side.
My subclasses must implement buildDebugerCommandGroup in which they build their particular subgroup of commands.
My subclasses know how to inject their subgroup into the main command tree.  

My subclasses are responsible to provide groups of commands classes that are instantiated on the given context and presenter. 

For instance: 
- an "accessing" protocol with methods returning names of groups
- an "accessing-command classes" protocol returning arrays of methods (i.e., groups)!
!StDebuggerCommandTreeBuilder methodsFor: 'building' stamp: ''!
buildDebuggerCommandGroup
	self subclassResponsibility ! !

!StDebuggerCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
groupDescription
	^self class groupDescription! !

!StDebuggerCommandTreeBuilder methodsFor: 'converting' stamp: ''!
asMenuPresenter 	
	^rootCommandGroup asMenuPresenter! !

!StDebuggerCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
displayStrategy
	^self class displayStrategy new! !

!StDebuggerCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
groupName 
	^self class groupName! !

!StDebuggerCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
group
	^ rootCommandGroup
		commandOrGroupNamed: self groupName
		ifNone: [ self buildAndRegisterGroup ]! !

!StDebuggerCommandTreeBuilder methodsFor: 'building' stamp: ''!
buildCommandsGroupWith: aStDebuggerInstance forRoot: aRootCommandGroup
	stDebuggerInstance := aStDebuggerInstance.
	rootCommandGroup := aRootCommandGroup.
	self buildDebuggerCommandGroup! !

!StDebuggerCommandTreeBuilder methodsFor: 'building' stamp: ''!
buildAndRegisterGroup
	"builds the group that will register under the provided root command group"

	| group |
	group := (CmCommandGroup named: self groupName) asSpecGroup.
	group description: self groupDescription.
	group displayStrategy: self displayStrategy.
	rootCommandGroup register: group.
	^ group! !

!StDebuggerCommandTreeBuilder methodsFor: 'building' stamp: ''!
buildSpecCommand: aCommandClass forContext: anObject
	^ aCommandClass forSpecContext: anObject! !

!StDebuggerCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
groupDescription
	^self subclassResponsibility ! !

!StDebuggerCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
displayStrategy
	^self subclassResponsibility ! !

!StDebuggerCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
groupName
	^self subclassResponsibility ! !

!StDebuggerCommandTreeBuilder class methodsFor: 'commands' stamp: ''!
buildCommandsGroupWith: aStDebuggerInstance forRoot: aRootCommandGroup
	^self new buildCommandsGroupWith: aStDebuggerInstance forRoot: aRootCommandGroup! !

!StDebuggerCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testGroup
	|rootGroup|
	rootGroup := (CmCommandGroup named: 'root') asSpecGroup.
	builder buildCommandsGroupWith: StDebugger basicNew forRoot: rootGroup.
	self assert: builder group identicalTo: rootGroup / builder class groupName.
	self assert: builder group name equals: builder class groupName.
	self assert: builder group description equals: builder class groupDescription! !

!StDebuggerCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testDisplayStrategy
	self assert: builder displayStrategy class equals: builder class displayStrategy! !

!StDebuggerCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testGroupBuilding
	|rootGroup|
	rootGroup := (CmCommandGroup named: 'root') asSpecGroup.
	builder buildCommandsGroupWith: StDebugger basicNew forRoot: rootGroup.
	builder buildAndRegisterGroup.
	self assert: rootGroup groups size equals: 1.
	self assert: rootGroup groups first identicalTo: rootGroup / builder class groupName.
	self assert: rootGroup groups first name equals: builder class groupName.
	self assert: rootGroup groups first description equals: builder class groupDescription.
	self assert: rootGroup groups first displayStrategy class identicalTo: builder class displayStrategy.
	self deny: rootGroup groups first isRoot! !

!StDebuggerCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testGroupDescription
	self assert: builder groupDescription equals: builder class groupDescription! !

!StDebuggerCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testGroupName
	self assert: builder groupName equals: builder class groupName! !

!StDebuggerCommandTreeBuilderTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
	
	super setUp.
	builder := StDebuggerMockCommandTreeBuilder new! !

!StDebuggerContext commentStamp: ''!
I am a simple wrapper holding the current context and the current debug session in a debugger.
My purpose is only to display context and debug session related information in the debugger inspector.!
!StDebuggerContext methodsFor: 'accessing' stamp: ''!
context

	^ context ifNil: [ context := [] asContext ]! !

!StDebuggerContext methodsFor: 'nodes' stamp: ''!
temporaryVariablesNodes

	^ self context astScope allTemps collect: [ :temp | 
		  (StInspectorTempNode hostObject: self context) tempVariable: temp ]! !

!StDebuggerContext methodsFor: 'building' stamp: ''!
exceptionNodesFor: anException

	^ OrderedCollection new
		  add: (StInspectorDynamicNode
				   hostObject: anException
				   label: 'Exception'
				   value: anException);
		  yourself! !

!StDebuggerContext methodsFor: 'nodes' stamp: ''!
receiverNodes

	^ self context receiver allInspectorNodes reject: [ :node | 
		  node label = 'self' ]! !

!StDebuggerContext methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!StDebuggerContext methodsFor: 'nodes' stamp: ''!
selfNode

	^ StInspectorSelfNode hostObject: self context receiver! !

!StDebuggerContext methodsFor: 'nodes' stamp: ''!
stackTopNode
	^StInspectorStackTopNode hostObject: self context! !

!StDebuggerContext methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: context asString ! !

!StDebuggerContext methodsFor: 'accessing' stamp: ''!
exception
	^ exception ifNil:[exception := OupsNullException new]! !

!StDebuggerContext methodsFor: 'building' stamp: ''!
doesNotUnderstandNodesFor: anException

	^ (self exceptionNodesFor: anException)
		  add: (StInspectorDynamicNode
				   hostObject: anException receiver
				   label: 'DNU receiver'
				   value: anException receiver);
		  yourself! !

!StDebuggerContext methodsFor: 'building' stamp: ''!
nullExceptionNodesFor: anException

	^ #(  )! !

!StDebuggerContext methodsFor: 'accessing' stamp: ''!
exception: anException
	exception := anException ! !

!StDebuggerContext methodsFor: 'nodes' stamp: ''!
exceptionNodes

	^ self exception stDebuggerInspectorNodesFor: self! !

!StDebuggerContext methodsFor: 'nodes' stamp: ''!
thisContextNode 
	^StInspectorThisContextNode hostObject: self context! !

!StDebuggerContext methodsFor: 'accessing' stamp: ''!
buildInspectorNodes

	| nodes argsNodes tempsNodes tempsAndArgs |
	nodes := OrderedCollection new.
	tempsAndArgs := self temporaryVariablesNodes.
	argsNodes := tempsAndArgs select: [ :tempNode | tempNode tempVariable isArgumentVariable ].
	tempsNodes := tempsAndArgs select: [ :tempNode | tempNode tempVariable isTempVariable ].
	nodes add: self selfNode.
	nodes addAll: argsNodes.
	nodes addAll: tempsNodes.
	nodes addAll: self receiverNodes.
	nodes add: self stackTopNode.
	nodes add: self thisContextNode.
	nodes addAll: self exceptionNodes.
	^ nodes! !

!StDebuggerContext class methodsFor: 'instance creation' stamp: ''!
context: aContext

	^ self new
		  context: aContext;
		  yourself! !

!StDebuggerContextInteractionModel methodsFor: 'accessing' stamp: ''!
doItContext

	^ self context! !

!StDebuggerContextInteractionModel methodsFor: 'accessing' stamp: ''!
context

	^context! !

!StDebuggerContextInteractionModel methodsFor: 'testing' stamp: ''!
hasBindingOf: aString
	"we lookup the name without creating a new variable"
	^ (context lookupVar: aString declare: false) notNil! !

!StDebuggerContextInteractionModel methodsFor: 'binding' stamp: ''!
bindingOf: aString

	"we can not call #lookupVar: without checking first as it would create the variable"

	^ (self hasBindingOf: aString)
		  ifTrue: [ (context lookupVar: aString) asDoItVariableFrom: context ]
		  ifFalse: [ nil ]! !

!StDebuggerContextInteractionModel methodsFor: 'accessing' stamp: ''!
context: aContext
	context := aContext! !

!StDebuggerContextInteractionModel methodsFor: 'accessing' stamp: ''!
doItReceiver

	^ self context receiver! !

!StDebuggerContextInteractionModel methodsFor: 'testing' stamp: ''!
hasUnsavedCodeChanges

	^ context notNil and: [ context sourceCode ~= owner text asString ]! !

!StDebuggerContextInteractionModel methodsFor: 'accessing' stamp: ''!
object

	^ self doItReceiver! !

!StDebuggerContextInteractionModel methodsFor: 'accessing' stamp: ''!
behavior

	^ self context receiver class! !

!StDebuggerContextInteractionModel class methodsFor: 'instance creation' stamp: ''!
on: aContext

	^ self new context: aContext! !

!StDebuggerContextInteractionModelTest methodsFor: 'tests' stamp: ''!
testHasUnsavedCodeChanges

	| model code |
	model := StDebuggerContextInteractionModel new.
	model context: [  ] asContext.
	code := SpCodePresenter new text: [  ] asContext sourceCode.
	model owner: code.
	
	self deny: model hasUnsavedCodeChanges.
	
	code text: 'changed source'.
	self assert: model hasUnsavedCodeChanges! !

!StDebuggerContextInteractionModelTest methodsFor: 'tests' stamp: ''!
testNilContextModel

	self deny:
		StDebuggerContextInteractionModel new hasUnsavedCodeChanges! !

!StDebuggerContextPredicate commentStamp: ''!
I describe the status of a context:
- I can print a meaningful description of the context
- I can tell if the current context is steppable (predicates)

I reference the context I describe.
I become obsolete as soon as an action is performed on the context.!
!StDebuggerContextPredicate methodsFor: 'predicates' stamp: ''!
isContextAnAssertionFailure
	^false! !

!StDebuggerContextPredicate methodsFor: 'predicates' stamp: ''!
isContextDead
	^context isDead! !

!StDebuggerContextPredicate methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!StDebuggerContextPredicate methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	postMortem := false! !

!StDebuggerContextPredicate methodsFor: 'printing' stamp: ''!
printHaltDescriptionOn: str

	context sourceNodeExecuted isHaltNode ifFalse: [ ^ self ].
	str << 'Halt in'.
	str space! !

!StDebuggerContextPredicate methodsFor: 'accessing' stamp: ''!
context: aContext
	context := aContext! !

!StDebuggerContextPredicate methodsFor: 'printing' stamp: ''!
printDescription
	|str|
	str := WriteStream on: String new.
	self printDescriptionPrefixOn: str.
	str << context printString.
	^str contents! !

!StDebuggerContextPredicate methodsFor: 'predicates' stamp: ''!
isSteppable

	^ self isContextPostMortem not and: [ self isContextDead not ]! !

!StDebuggerContextPredicate methodsFor: 'testing' stamp: ''!
contextSignalsException
	^false! !

!StDebuggerContextPredicate methodsFor: 'predicates' stamp: ''!
isContextDoesNotUnderstand
	^false! !

!StDebuggerContextPredicate methodsFor: 'predicates' stamp: ''!
isContextMissingClassException
	^false! !

!StDebuggerContextPredicate methodsFor: 'updating' stamp: ''!
updateSessionForModel: aStDebuggerActionModel
	aStDebuggerActionModel updateDebugSessionException: OupsNullException new
	! !

!StDebuggerContextPredicate methodsFor: 'predicates' stamp: ''!
isContextPostMortem
	^postMortem! !

!StDebuggerContextPredicate methodsFor: 'printing' stamp: ''!
printDescriptionPrefixOn: str

	self printPostMortemDescriptionOn: str.
	self printHaltDescriptionOn: str! !

!StDebuggerContextPredicate methodsFor: 'predicates' stamp: ''!
isContextSubclassResponsibilityException
	^false! !

!StDebuggerContextPredicate methodsFor: 'accessing' stamp: ''!
postMortem: aBoolean
	postMortem := aBoolean! !

!StDebuggerContextPredicate methodsFor: 'printing' stamp: ''!
printPostMortemDescriptionOn: str

	postMortem ifFalse: [ ^ self ].
	str << '[Post-mortem]'.
	str space! !

!StDebuggerContextPredicate class methodsFor: 'instance creation' stamp: ''!
context: anObject

	^ self new context: anObject! !

!StDebuggerContextPredicateTest methodsFor: 'tests' stamp: ''!
testPrintHaltDescription
	|haltContext|
	haltContext := (StTestDebuggerProvider new debuggerWithRunnableContext) interruptedContext.
	predicate context: haltContext.
	self assert: predicate printDescription equals: 'Halt in ', haltContext printString! !

!StDebuggerContextPredicateTest methodsFor: 'tests' stamp: ''!
testContext
	self assert: predicate context identicalTo: context! !

!StDebuggerContextPredicateTest methodsFor: 'tests' stamp: ''!
testIsSteppable

	self assert: predicate isSteppable.
	predicate postMortem: true.
	self deny: predicate isSteppable.

	predicate postMortem: false.
	self assert: predicate isSteppable.
	context pc: nil.
	self assert: context isDead.
	self deny: predicate isSteppable! !

!StDebuggerContextPredicateTest methodsFor: 'tests' stamp: ''!
testPrintDescription
	self skip.
	self assert: predicate printDescription equals: '0'! !

!StDebuggerContextPredicateTest methodsFor: 'tests' stamp: ''!
testIsContextDead
	
	self deny: predicate isContextDead.
	context pc: nil.
	self assert: predicate isContextDead! !

!StDebuggerContextPredicateTest methodsFor: 'tests' stamp: ''!
testPrintPostMortemDescription
	self skip.
	predicate postMortem: true.
	self assert: predicate printDescription equals: '[Post-mortem] 0'! !

!StDebuggerContextPredicateTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	context := [  ] asContext.
	predicate := (StDebuggerContextPredicate context: context)! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testBuildInspectorNodes
	|nodes nodesNames|
	debuggerContext context: self contextWithArgs.
	nodes := debuggerContext buildInspectorNodes.		
	nodesNames := (nodes collect:[:n| n key]).
	
	"Args"
	self assertCollection: nodesNames includesAll: #(#i #j).
	
	"Temps"
	self assertCollection: nodesNames includesAll: #(#a #b).

	"Self"
	self assertCollection: nodesNames includesAll: #(#self #instVar).
	
	"Stacktop"
	self assertCollection: nodesNames includesAll: #('stackTop').
		
	"thisContext"
	self assertCollection: nodesNames includesAll: #('thisContext').	
	
	"There is no more elements"
	self assert: nodesNames size equals: 8! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testThisContextNode
	|ctx node|
	ctx := self contextWithTemps.
	debuggerContext context: ctx.
	node := debuggerContext thisContextNode.	
	self assert: node key equals: 'thisContext'.
	self assert: node rawValue identicalTo: ctx! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testArgumentsNodesInBlock
	|nodes|
	debuggerContext context: self contextWithArgsInBlock.
	nodes := debuggerContext temporaryVariablesNodes select: [ :tempNode | tempNode tempVariable isArgumentVariable ].	
	self assert: nodes size equals: 2.
	self assert: nodes first key equals: 'a'.
	self assert: nodes first variableTag equals: 'arg'.
	self assert: nodes first rawValue equals: 4.
	self assert: nodes second key equals: 'b'.
	self assert: nodes second variableTag equals: 'arg'.
	self assert: nodes second rawValue equals: 2.
	self deny: (nodes anySatisfy: [:n| n key = 'self'])! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testNullExceptionNodes

	self assertEmpty: debuggerContext exceptionNodes! !

!StDebuggerContextTest methodsFor: 'helpers' stamp: ''!
contextWithTemps

	"Creates and returns a context in which we step until we enter a method with temporary variables, then step two times over the assignement of the first temp"

	| context |
	context := [ hostObject methodWithTemps ] asContext.
	[ context method selector = #methodWithTemps ] whileFalse: [ 
		context := context step ].

	context := context step.
	context := context step.
	^ context! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testContext

	| closure contextSource ctx |
	closure := debuggerContext context closure.
	contextSource := closure method sourceCode
		                 copyFrom: closure sourceNode start
		                 to: closure sourceNode stop.
	self assert: contextSource equals: '[]'.
	ctx := self contextWithArgs.
	debuggerContext context: ctx.
	self assert: debuggerContext context identicalTo: ctx! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testExceptionNodes

	| nodes object exception |
	object := Object new.
	[ object toto ]
		on: Error
		do: [ :e | 
			exception := e freeze.
			debuggerContext context: e signalerContext.
			debuggerContext exception: e ].
	nodes := debuggerContext exceptionNodes.
	self assert: nodes size equals: 2.
	self assert: nodes first key equals: 'Exception'.
	self assert: nodes first rawValue equals: exception.
	self assert: nodes first variableTag equals: 'implicit'.
	self
		assert: nodes first rawValue class
		identicalTo: MessageNotUnderstood.
	self assert: nodes second key equals: 'DNU receiver'.
	self assert: nodes second rawValue identicalTo: object.
	self assert: nodes first variableTag equals: 'implicit'.! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testSelfNodes

	| node |
	debuggerContext context: self contextWithTemps.
	node := debuggerContext selfNode.
	self assert: node key equals: 'self'.
	self assert: node rawValue identicalTo: hostObject.! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testArgumentsNodes
	|nodes| 
	debuggerContext context: self contextWithArgs.
	nodes := debuggerContext temporaryVariablesNodes select: [ :tempNode | tempNode tempVariable isArgumentVariable ].	
	self assert: nodes size equals: 2.
	self assert: nodes first key equals: 'i'.
	self assert: nodes first variableTag equals: 'arg'.
	self assert: nodes first rawValue equals: 4.
	self assert: nodes first class equals: StInspectorTempNode.
	self assert: nodes second key equals: 'j'.
	self assert: nodes second variableTag equals: 'arg'.
	self assert: nodes second rawValue equals: 2.
	self assert: nodes second class equals: StInspectorTempNode.
	self deny: (nodes anySatisfy: [:n| n key = 'self'])! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testStackTopNode	
	| node|
	"We step once on the context to be on the value part of the next assignment"
	debuggerContext context: self contextWithTemps step.
	node := debuggerContext stackTopNode.	
	self assert: node key equals: 'stackTop'.
	self assert: node rawValue equals: 0! !

!StDebuggerContextTest methodsFor: 'helpers' stamp: ''!
contextWithArgsInBlock

	"Creates and returns a context in which we step until we enter a method with arguments in a block, then step 4 times until we're in the block"

	| context |
	context := [ hostObject methodWithArgsInBlock ] asContext.
	[ context method selector = #methodWithArgsInBlock ] whileFalse: [ 
		context := context step ].

	4 timesRepeat: [ context := context step ].
	context := context step.
	^ context! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testNoDuplicatesBetweenArgsAndTemps
	|nodes nodesNamesArray nodesNamesSet|
	debuggerContext context: self contextWithArgs.
	nodes := debuggerContext allInspectorNodes.	
	nodesNamesArray := (nodes collect:[:n| n key]) asSortedCollection.
	nodesNamesSet := nodesNamesArray asSet asSortedCollection.
	self assertCollection: nodesNamesArray equals: nodesNamesSet! !

!StDebuggerContextTest methodsFor: 'helpers' stamp: ''!
contextWithArgs

	"Creates and returns a context in which we step until we enter a method with temporary variables, then step two times over the assignement of the first temp"

	| context |
	context := [ hostObject methodWithArg1: 4 arg2: 2  ] asContext.
	[ context method selector = #methodWithArg1:arg2: ] whileFalse: [ 
		context := context step ].

	context := context step.
	context := context step.
	^ context! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testBuildInspectorNodesForException
	| nodes object exception |
	object := Object new.
	[ object toto ]
		on: Error
		do: [ :e | 
			exception := e freeze.
			debuggerContext context: e signalerContext.
			debuggerContext exception: e ].
	nodes := debuggerContext buildInspectorNodes.
	self assert: (nodes at: (nodes size - 1)) key equals: 'Exception'.
	self assert: (nodes at: (nodes size - 1)) rawValue identicalTo: exception.
	self assert: (nodes last) key equals: 'DNU receiver'. 
	self assert: (nodes last) rawValue identicalTo: object! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testReceiverNodes

	| nodes |
	debuggerContext context: self contextWithTemps.
	nodes := debuggerContext receiverNodes.
	self assert: nodes size equals: 1.
	self assert: nodes first key equals: 'instVar'.
	self assert: nodes first rawValue equals: hostObject instVar! !

!StDebuggerContextTest methodsFor: 'tests' stamp: ''!
testTemporaryVariablesNodes
	|nodes|	
	debuggerContext context: self contextWithTemps.
	nodes := debuggerContext temporaryVariablesNodes.
	self assert: nodes size equals: 2.
	self assert: nodes first key equals: 'a'.
	self assert: nodes first variableTag equals: 'temp. var'.	
	self assert: nodes first rawValue equals: 0.
	self assert: nodes first tempVariable isTempVariable.
	self assert: nodes second key equals: 'b'.
	self assert: nodes second variableTag equals: 'temp. var'.	
	self assert: nodes second rawValue equals: nil.
	self assert: nodes first tempVariable isTempVariable.
	self deny: (nodes anySatisfy: [:n| n key = 'self'])! !

!StDebuggerContextTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	debuggerContext := StDebuggerContext new.
	hostObject := StDebuggerObjectForTests new! !

!StDebuggerErrorContextPredicate commentStamp: ''!
I provide a specialized context description in the case where an exception was found on the stack of the context.

I reference that exception.!
!StDebuggerErrorContextPredicate methodsFor: 'accessing' stamp: ''!
assertEqualsSelectors
	self flag: 'Add the denies... use a pragma?'.
	^ #(#assert:equals: #assert:closeTo:precision: #assert:closeTo: #assert:identicalTo: #assertCollection:equals: #assertCollection:hasSameElements:)
	
"#( #assert:equals: #assert:closeTo:precision:
	     #assert:closeTo: #assert:identicalTo: #assertCollection:equals:
	     #assertCollection:hasSameElements: )"! !

!StDebuggerErrorContextPredicate methodsFor: 'printing' stamp: ''!
printDescription

	| str |
	str := WriteStream on: String new.
	self printDescriptionPrefixOn: str.
	str << ((exception isKindOf: OupsNullException)
		 ifTrue: [ context printString ]
		 ifFalse: [ exception description ]).
	^ str contents! !

!StDebuggerErrorContextPredicate methodsFor: 'accessing' stamp: ''!
exceptionWhiteList

	^ { 
		  Warning.
		  OupsNullException.
		  Halt }! !

!StDebuggerErrorContextPredicate methodsFor: 'predicates' stamp: ''!
isSteppable

	super isSteppable ifFalse: [ ^ false ].

	(exception isKindOf: MessageNotUnderstood) ifTrue: [ 
		^ self isContextDoesNotUnderstand not and: [ 
			  self isContextMissingClassException not ] ].

	^ exception isResumable! !

!StDebuggerErrorContextPredicate methodsFor: 'testing' stamp: ''!
contextSignalsException
	^true! !

!StDebuggerErrorContextPredicate methodsFor: 'predicates' stamp: ''!
isContextDoesNotUnderstand

	^ exception class = MessageNotUnderstood and: [ 
		  | message |
		  message := exception message.
		  
			  (exception receiver respondsTo: message selector) not and: [ 
				  exception signalerContext method methodClass == Object ] ]! !

!StDebuggerErrorContextPredicate methodsFor: 'predicates' stamp: ''!
isContextMissingClassException

	^ exception class == VariableNotDeclared! !

!StDebuggerErrorContextPredicate methodsFor: 'updating' stamp: ''!
updateSessionForModel: aStDebuggerActionModel

	aStDebuggerActionModel updateDebugSessionException: exception! !

!StDebuggerErrorContextPredicate methodsFor: 'accessing' stamp: ''!
exception: anObject
	exception := anObject! !

!StDebuggerErrorContextPredicate methodsFor: 'predicates' stamp: ''!
isContextSubclassResponsibilityException
	^ exception class == SubclassResponsibility! !

!StDebuggerExtensionGeneratorForTests commentStamp: ''!
I just provide helper methods to generate and remove classes that use the `TStDebuggerExtension` trait.
These classes are used exclusively in tests, and should be part of the system (remove them in your `tearDown`).!
!StDebuggerExtensionGeneratorForTests class methodsFor: 'running' stamp: ''!
removeTestClass

	Smalltalk
		at: #TStDebuggerExtensionTestClass
		ifPresent: [ :class | class removeFromSystem ]! !

!StDebuggerExtensionGeneratorForTests class methodsFor: 'running' stamp: ''!
testClass

	^ Smalltalk at: #TStDebuggerExtensionTestClass! !

!StDebuggerExtensionGeneratorForTests class methodsFor: 'running' stamp: ''!
generateTestClass

	Object
		subclass: #TStDebuggerExtensionTestClass
		uses: TStDebuggerExtension
		instanceVariableNames: ''
		classVariableNames: ''
		package: 'NewTools-Debugger-Tests-Model'! !

!StDebuggerExtensionMechanismTest methodsFor: 'running' stamp: ''!
tearDown

	StDebuggerExtensionGeneratorForTests removeTestClass.
	self debuggerClass activateDebuggerExtensions: oldExtensionActivation.
	super tearDown! !

!StDebuggerExtensionMechanismTest methodsFor: 'accessing' stamp: ''!
debugger
	^ debugger ifNil: [ debugger := self debuggerClass basicNew ]! !

!StDebuggerExtensionMechanismTest methodsFor: 'accessing' stamp: ''!
debuggerClass
	^ StDebugger! !

!StDebuggerExtensionMechanismTest methodsFor: 'tests - extensions' stamp: ''!
testRegisterExtensionTool
	|dbg object|
	dbg := self debugger.
	self assertEmpty: dbg extensionTools.
	dbg registerExtensionTool: (object := Object new).
	self assert: dbg extensionTools size equals: 1.
	self assertCollection: dbg extensionTools equals: { object } asOrderedCollection ! !

!StDebuggerExtensionMechanismTest methodsFor: 'tests - extensions' stamp: ''!
testInstantiateExtensionToolsPage
	|dbg toolPage|
	dbg := self debugger.
	toolPage := dbg instantiateExtensionToolsPage: StDummyDebuggerPresenter.
	self assert: toolPage class identicalTo: SpNotebookPage.
	self assert: toolPage presenterProvider value class identicalTo: StDummyDebuggerPresenter.
	self assert: toolPage title equals: StDummyDebuggerPresenter new debuggerExtensionToolName.
	self assertCollection: dbg extensionTools includesAll: { toolPage presenterProvider value}.
	 ! !

!StDebuggerExtensionMechanismTest methodsFor: 'tests - extensions' stamp: ''!
testUsesExtensions
	| testClass |
	testClass := StDebuggerExtensionGeneratorForTests testClass.	
	testClass showInDebugger: true.
	self debuggerClass activateDebuggerExtensions: false.
	self deny: self debuggerClass usesExtensions.
	self debuggerClass activateDebuggerExtensions: true.
	self assert: self debuggerClass usesExtensions! !

!StDebuggerExtensionMechanismTest methodsFor: 'tests - extensions' stamp: ''!
testExtensionToolsClasses

	self
		assertCollection: StDebugger extensionToolsClasses
		equals: TStDebuggerExtension users! !

!StDebuggerExtensionMechanismTest methodsFor: 'tests - extensions' stamp: ''!
testHasAnyActivatedExtensions

	| testClass |
	testClass := StDebuggerExtensionGeneratorForTests testClass.
	self deny: (self debuggerClass hasAnyActivatedExtension: { testClass }).
	testClass showInDebugger: true.
	self assert: (self debuggerClass hasAnyActivatedExtension: { testClass })! !

!StDebuggerExtensionMechanismTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	oldExtensionActivation := self debuggerClass activateDebuggerExtensions.
	StDebuggerExtensionGeneratorForTests generateTestClass! !

!StDebuggerExtensionSettings commentStamp: ''!
I define settings to configure debugger extensions, *i.e.*, all users of `TStDebuggerExtension`.!
!StDebuggerExtensionSettings class methodsFor: 'settings' stamp: ''!
debuggerExtensionSettingsForClass: toolClass builder: aBuilder

	| toolName |
	toolName := toolClass basicNew debuggerExtensionToolName.

	(aBuilder group: toolName asSymbol)
		label: toolName;
		with: [ 
			(aBuilder setting: #showInDebugger)
				label: 'Show in debugger';
				target: toolClass;
				default: toolClass showInDebugger;
				description: 'Activate the tool tab in the debugger right column.'.
			(aBuilder pickOne: #displayOrder)
				label: 'Position';
				target: toolClass;
				default: toolClass defaultDisplayOrder;
				domainValues: (1 to: 100) asArray;
				description:
					'Position of the tool tab in the debugger right column.' ]! !

!StDebuggerExtensionSettings class methodsFor: 'settings' stamp: ''!
debuggerExtensionSettingsOn: aBuilder

	<systemsettings>
	| debuggerClass |
	debuggerClass := StDebugger.
	(aBuilder group: #debuggerExtensions)
		label: 'Debugger Extensions';
		parent: #debugging;
		description:
			'Tools that extend the StDebugger and appear in the right column of the debugger';
		with: [ 
			| settingsGroup |
			settingsGroup := aBuilder setting: #activateDebuggerExtensions.
			settingsGroup label: 'Activate extensions'.
			settingsGroup target: debuggerClass.
			settingsGroup default: true.
			settingsGroup description:
					'(De)Activate the debugger extensions tools in the debugger right column.'.
			settingsGroup with: [ 
					debuggerClass extensionToolsClasses do: [ :toolClass | 
							self
								debuggerExtensionSettingsForClass: toolClass
								builder: aBuilder ] ] ]! !

!StDebuggerInspector commentStamp: ''!
I am an inspector dedicated to the debugger.
I wrap a StInspector object which provides inspection views for the inspected object.
I add specific debugger functionalities:
- I remember selection in the inspector list depending on the context
- I dynamically change my layout depending on the context (e.g., I show a diff view in case of an assertion failure)!
!StDebuggerInspector methodsFor: 'layout' stamp: ''!
updateLayoutForContexts: aContext isAssertionFailure: isTopContextFailingAssertion

	| assertionResult |
	isTopContextFailingAssertion ifFalse: [ 
		currentLayoutSpec = self defaultLayoutSpec ifTrue: [ ^ self ].
		self setDefaultLayout.
		^self ].
	currentLayoutSpec = self assertionLayoutSpec ifTrue: [ ^ self ].

	[ assertionResult := aContext findFailedAssertionResultsInSenderChain ]
		on: StDebuggeAssertionFailureContextNotFound
		do: [ self setDefaultLayout.
			^self ].		
	
	assertionFailure := StFailingAssertionInspector
		                    diffInspectorsFromActual: assertionResult actual
		                    expected: assertionResult expected
		                    application: self application.
	self setAssertionLayout! !

!StDebuggerInspector methodsFor: 'layout' stamp: ''!
currentLayoutSpec
	^currentLayoutSpec! !

!StDebuggerInspector methodsFor: 'updating' stamp: ''!
updateEvaluationPaneReceiver
	"| context evaluator |
	
	context := self model inspectedObject context.
	evaluator := inspector millerList pages first evaluator.
	evaluator beForContextReceiver: context"! !

!StDebuggerInspector methodsFor: 'stepping' stamp: ''!
step
	inspector step! !

!StDebuggerInspector methodsFor: 'layout' stamp: ''!
setDefaultLayout
	
	currentLayoutSpec := self defaultLayoutSpec.
	self layout: self class defaultSpec! !

!StDebuggerInspector methodsFor: 'accessing' stamp: ''!
assertionFailure
	^assertionFailure ! !

!StDebuggerInspector methodsFor: 'updating' stamp: ''!
forceRawInspectionUpdate

	self getRawInspectorPresenterOrNil ifNotNil: [ :inspection | 
		inspection update ]! !

!StDebuggerInspector methodsFor: 'accessing' stamp: ''!
rawInspectionSelectionCache
	^ rawInspectionSelectionCache ifNil: [ 
		  rawInspectionSelectionCache := Dictionary new ]! !

!StDebuggerInspector methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aModel

	model := aModel! !

!StDebuggerInspector methodsFor: 'layout' stamp: ''!
setAssertionLayout
	currentLayoutSpec := self assertionLayoutSpec.
	self layout: self class assertionFailureSpec! !

!StDebuggerInspector methodsFor: 'accessing - model' stamp: ''!
model

	^ model! !

!StDebuggerInspector methodsFor: 'private' stamp: ''!
getRawInspectorPresenterOrNil
	^ inspector millerList pages first rawInspectorPageOrNil activePresenter! !

!StDebuggerInspector methodsFor: 'updating' stamp: ''!
shouldUpdateContext: oldContext with: newContext

	^ oldContext ~~ newContext! !

!StDebuggerInspector methodsFor: 'initialization' stamp: ''!
initializeLateralToolbar
	| button |
	
	lateralToolbar := self newToolbar.
	lateralToolbar addStyle: 'stToolbar'.
	lateralToolbar beIcons.
	button := self newToolbarButton.

	button
		label: '';
		icon: (self iconNamed: #expandBox);
		help: 'Expand the diff view';
		action: [ 
			self class toggleMaximizeAssertionSpec.
			self setAssertionLayout ];
		borderWidth: 0.

	lateralToolbar add: button! !

!StDebuggerInspector methodsFor: 'private' stamp: ''!
getRawInspectorSelectedPath
	^ self getRawInspectorPresenterOrNil
		  ifNil: [ #(  ) ]
		  ifNotNil: [ :raw | raw selectedPath ]! !

!StDebuggerInspector methodsFor: 'accessing' stamp: ''!
label: aString

	label label: aString! !

!StDebuggerInspector methodsFor: 'accessing' stamp: ''!
debuggerInspectorModelClass
	^ StDebuggerInspectorModel! !

!StDebuggerInspector methodsFor: 'accessing' stamp: ''!
inspectedObject

	^ self model inspectedObject! !

!StDebuggerInspector methodsFor: 'updating' stamp: ''!
updateWith: inspectedObject

	| oldContext newContext |
	oldContext := self model inspectedObject ifNotNil: [ :dbgCtx | 
		              dbgCtx context ].
	newContext := inspectedObject ifNotNil: [ :dbgCtx | dbgCtx context ].
	(self shouldUpdateContext: oldContext with: newContext) ifFalse: [ ^ self ].

	self saveRawInspectionSelectionForContext: oldContext.
	self model: (self debuggerInspectorModelClass on: inspectedObject).
	self updateEvaluationPaneReceiver.
	self restoreRawInspectionSelectionForContext: newContext! !

!StDebuggerInspector methodsFor: 'private' stamp: ''!
saveRawInspectionSelectionForContext: aContext
	| selectionPath |
	aContext ifNil: [ ^ self ].
	selectionPath := self getRawInspectorSelectedPath.
	self rawInspectionSelectionCache
		at: aContext receiver class -> aContext selector
		put: selectionPath.
	self rawInspectionSelectionCache
		at: aContext receiver class
		put: selectionPath! !

!StDebuggerInspector methodsFor: 'layout' stamp: ''!
defaultLayoutSpec
	^#defaultSpec! !

!StDebuggerInspector methodsFor: 'layout' stamp: ''!
assertionLayoutSpec
	^#assertionFailureSpec! !

!StDebuggerInspector methodsFor: 'accessing - model' stamp: ''!
model: aModel

	model := aModel.
	inspector model: model! !

!StDebuggerInspector methodsFor: 'private' stamp: ''!
restoreRawInspectionSelectionForContext: aContext
	aContext ifNil: [ ^ self ].
	self getRawInspectorPresenterOrNil
		ifNotNil: [ :raw | 
			| receiverClass selector path |
			receiverClass := aContext receiver class.
			selector := aContext selector.
			path := self rawInspectionSelectionCache
				at: receiverClass -> selector
				ifAbsent: [ #() ].
			path ifEmpty: [ self rawInspectionSelectionCache at: receiverClass ifAbsent: [ #() ] ].
			path ifEmpty: [ | roots pathStart |
					roots := raw attributeTable roots.
					pathStart := 1.
					1 to: roots size do: [ :i | 
						(roots at: i) key = 'Temps' ifTrue: [ pathStart := i ] ].
					path := {pathStart. 1} ].
			raw selectPath: path ]! !

!StDebuggerInspector methodsFor: 'initialization' stamp: ''!
initializePresenters

	label := self newLabel.
	inspector := self instantiate: StInspector on: self model.
	currentLayoutSpec := self defaultLayoutSpec.
	self initializeLateralToolbar! !

!StDebuggerInspector class methodsFor: 'instance creation' stamp: ''!
openOn: anObject

	^ (self on: (StInspectorModel on: anObject)) openWithSpec! !

!StDebuggerInspector class methodsFor: 'specs' stamp: ''!
toggleMaximizeAssertionSpec
	self maximizeAssertionSpec: self maximizeAssertionSpec not! !

!StDebuggerInspector class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		  add: #inspector;
		  yourself! !

!StDebuggerInspector class methodsFor: 'specs' stamp: ''!
assertionFailureSpec
	| assertionFailureLayout |
	
	assertionFailureLayout := SpPanedLayout newTopToBottom.
	assertionFailureLayout positionOfSlider: (self maximizeAssertionSpec
			 ifTrue: [ 95 percent ]
			 ifFalse: [ 40 percent ]).
	assertionFailureLayout add: (SpBoxLayout newLeftToRight
			 add: (SpBoxLayout newTopToBottom
				add: #lateralToolbar expand: false;
				yourself)
			 expand: false;
			 add: #assertionFailure;
			 yourself).

	self maximizeAssertionSpec ifFalse: [ 
		assertionFailureLayout add: #inspector ].
	^ assertionFailureLayout! !

!StDebuggerInspector class methodsFor: 'specs' stamp: ''!
title
	 ^'Debugger Inspection'! !

!StDebuggerInspector class methodsFor: 'specs' stamp: ''!
maximizeAssertionSpec
	^maximizeAssertionSpec ifNil:[maximizeAssertionSpec := false]! !

!StDebuggerInspector class methodsFor: 'specs' stamp: ''!
maximizeAssertionSpec: aboolean
	maximizeAssertionSpec := aboolean! !

!StDebuggerInspectorModel commentStamp: ''!
I am a model representing the first variable lists in the debugger inspector.
!
!StDebuggerInspectorModel methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	inspectedObject := self debuggerContextClass new! !

!StDebuggerInspectorModel methodsFor: 'accessing' stamp: ''!
debuggerContextClass
	^ StDebuggerContext! !

!StDebuggerInspectorModel methodsFor: 'accessing' stamp: ''!
inspectedObject

	^ inspectedObject ifNil: [ inspectedObject := self debuggerContextClass new ]! !

!StDebuggerInspectorModel methodsFor: 'accessing' stamp: ''!
defaultObjectInspectorClass

	^ StDebuggerRawObjectInspector! !

!StDebuggerInspectorModel methodsFor: 'accessing' stamp: ''!
allInspectorNodes

	^ self inspectedObject buildInspectorNodes! !

!StDebuggerInspectorModel methodsFor: 'accessing' stamp: ''!
labelString

	^ (self descriptionStringFor: self inspectedObject context receiver) 
		  truncateWithElipsisTo: 30! !

!StDebuggerInspectorTest methodsFor: 'running' stamp: ''!
tearDown
	session ifNotNil:[session clear].
	StDebuggerInspector maximizeAssertionSpec: nil.
	super tearDown! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testDefaultLayoutSpec
	
	self assert: inspector currentLayoutSpec equals: inspector defaultLayoutSpec! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testSetAssertionLayoutSpec
	|inspectorLayout expectedLayout|
	inspector setAssertionLayout. 
	inspectorLayout := inspector layout.
	expectedLayout := inspector class assertionFailureSpec.
	self assert: inspector currentLayoutSpec equals: inspector assertionLayoutSpec.					
	self assertCollection: inspectorLayout children size equals: expectedLayout children size. 
	self assert: inspectorLayout children first class identicalTo:  expectedLayout children first class.
	self assert: inspectorLayout children first direction equals: expectedLayout children first direction.
	self assert: inspectorLayout children second equals:  expectedLayout children second.
	self assert: inspectorLayout direction equals: expectedLayout direction.
	self assert: inspectorLayout class identicalTo: expectedLayout class! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testUpdateLayoutForContextsWithAssertionFailure
	| debugger assertionFailure |
	debugger := StTestDebuggerProvider new
		debuggerWithFailingAssertionContext.
	session := debugger session.
	inspector
		updateLayoutForContexts: session interruptedContext
		isAssertionFailure: true.
	assertionFailure := inspector assertionFailure.
	self
		assert: inspector currentLayoutSpec
		equals: inspector assertionLayoutSpec.
	self
		assert: assertionFailure actualObject
		equals: ((session interruptedContext tempNamed: #aStringOrBlock) at: 2).
	self
		assert: assertionFailure expectedObject
		equals: ((session interruptedContext tempNamed: #aStringOrBlock) at: 1)! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testMinimizedAssertionLayoutSpec
	|inspectorLayout|
	
	inspector class maximizeAssertionSpec: false.
	inspector setAssertionLayout. 
	inspectorLayout := inspector layout.
	self assert: inspectorLayout children size equals: 2.
	self assert: inspectorLayout children first class identicalTo: SpBoxLayout.
	self assert: inspectorLayout children second equals: #inspector! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testMaximizedAssertionLayoutSpec
	|inspectorLayout|
	
	inspector class maximizeAssertionSpec: true.
	inspector setAssertionLayout. 
	inspectorLayout := inspector layout.
	self assert: inspectorLayout children size equals: 1.
	self assert: inspectorLayout children first class identicalTo: SpBoxLayout ! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testSetDefaultLayoutSpec
	|inspectorLayout expectedLayout|
	inspector setDefaultLayout. 
	inspectorLayout := inspector layout.
	expectedLayout := inspector class defaultSpec.
	self assert: inspector currentLayoutSpec equals: inspector defaultLayoutSpec.
	self assertCollection: inspectorLayout children equals: expectedLayout children. 
	self assert: inspectorLayout direction equals: expectedLayout direction.
	self assert: inspectorLayout class identicalTo: expectedLayout class! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testToggleMaximizeAssertionSpec

	|oldFlag|
	oldFlag := StDebuggerInspector maximizeAssertionSpec.
	StDebuggerInspector toggleMaximizeAssertionSpec.
	self assert: StDebuggerInspector maximizeAssertionSpec equals: oldFlag not! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testUpdateLayoutForContextsWithShouldntRaiseFailure
	| debugger assertionFailure |
	debugger := StTestDebuggerProvider new debuggerWithFailingShouldntRaiseContext.
	session := debugger session.
	inspector
		updateLayoutForContexts: session interruptedContext
		isAssertionFailure: true.
	assertionFailure := inspector assertionFailure.
	self
		deny: inspector currentLayoutSpec
		equals: inspector assertionLayoutSpec.
	! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testMaximizeAssertionSpec
	self deny: StDebuggerInspector maximizeAssertionSpec! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testShouldUpdateContext

	| debugger |
	debugger := StTestDebuggerProvider new
		            debuggerWithFailingAssertionContext.
	session := debugger session.
	self assert: (inspector
			 shouldUpdateContext: session interruptedContext sender
			 with: session interruptedContext).
	self deny: (inspector
			 shouldUpdateContext: session interruptedContext
			 with: session interruptedContext)! !

!StDebuggerInspectorTest methodsFor: 'tests' stamp: ''!
testUpdateLayoutForContextsWithoutAssertionFailure
	| debugger |
	debugger := StTestDebuggerProvider new
		debuggerWithFailingAssertionContext.
	session := debugger session.
	inspector
		updateLayoutForContexts: session interruptedContext
		isAssertionFailure: false.
	self
		assert: inspector currentLayoutSpec
		equals: inspector defaultLayoutSpec.
	self assert: inspector assertionFailure equals: nil! !

!StDebuggerInspectorTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
	super setUp.
	inspector := StDebuggerInspector new! !

!StDebuggerMockCommandTreeBuilder commentStamp: ''!
Debugger command tree builder mock to test general behavior outside of a debugger!
!StDebuggerMockCommandTreeBuilder methodsFor: 'building' stamp: ''!
buildDebuggerCommandGroup
	! !

!StDebuggerMockCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
groupDescription
	^'mock group'! !

!StDebuggerMockCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
displayStrategy
	^CmUIDisplayAsSubMenu! !

!StDebuggerMockCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
groupName
	^'mock'! !

!StDebuggerObjectForTests commentStamp: ''!
I am a dummy object to test StDebuggerContext inspector nodes building.!
!StDebuggerObjectForTests methodsFor: 'utilities' stamp: ''!
methodWithTemps
	|a b|
	a := 0.
	b := 0.
	^a + b! !

!StDebuggerObjectForTests methodsFor: 'utilities' stamp: ''!
methodWithArg1: i arg2: j
	|a b|
	a := i.
	b := j.	
	^a + b! !

!StDebuggerObjectForTests methodsFor: 'initialization' stamp: ''!
initialize 
	instVar := 0! !

!StDebuggerObjectForTests methodsFor: 'accessing' stamp: ''!
instVar
	^ instVar! !

!StDebuggerObjectForTests methodsFor: 'util' stamp: ''!
haltingMethod <haltOrBreakpointForTesting> self halt. ^self! !

!StDebuggerObjectForTests methodsFor: 'utilities' stamp: ''!
methodWithArgsInBlock
	^[ :a :b| a + b ] value: 4 value: 2! !

!StDebuggerRawObjectInspector commentStamp: ''!
An object inspector specialized for debuggers.
I show only a compacted raw view instead of a notebook page, in particular I remove tabs and provide an optional layout without a header.
Activating one of my items (by clicking or double-clicking on it) shows a miller list with a standard object inspector.!
!StDebuggerRawObjectInspector methodsFor: 'initialization' stamp: ''!
rawInspectorPageOrNil
	^raw! !

!StDebuggerRawObjectInspector methodsFor: 'accessing' stamp: ''!
selectedObject
	"The debugger raw object inspector is opened on a StDebuggerContext object that holds context information. Here the view expected by users is on the receiver and not on the StDebuggerContext."
	^super selectedObject context receiver! !

!StDebuggerRawObjectInspector methodsFor: 'stepping' stamp: ''!
step
	super step.
	raw step! !

!StDebuggerRawObjectInspector methodsFor: 'initialization' stamp: ''!
initializeLayout
	
	self layout: (SpBoxLayout newTopToBottom 
		add: header expand: false fill: false padding: 5;
		add: raw;
		yourself).
! !

!StDebuggerRawObjectInspector methodsFor: 'private - updating' stamp: ''!
updateHeaderBar
	| filter |

	super updateHeaderBar.
	self rawInspectorPageOrNil ifNil: [ ^ self ].
"	self rawInspectorPageOrNil attributeTable hasActiveFilter ifFalse: [header label: self model labelString. ^ self ]."
	filter := self rawInspectorPageOrNil attributeTable filter.
	filter ifNil:[ 
		header label: self model labelString. 
		^ self].
	header label: '[Active filter: ', filter, '] ', self model labelString! !

!StDebuggerRawObjectInspector methodsFor: 'initialization' stamp: ''!
initializePresenters


	raw := self model inspectionRaw.
	raw beForDebugger.
	raw owner: self.
	self addActivationTo: raw.
	
	super initializePresenters! !

!StDebuggerRawObjectInspector class methodsFor: 'specs' stamp: ''!
noHeaderSpec
	<spec: #default>
	^ SpBoxLayout newTopToBottom
		add: #raw;
		yourself! !

!StDebuggerRawObjectInspectorTest methodsFor: 'tests' stamp: ''!
testSelectedObject

	| context debuggerContext inspector |
	context := Context
		           sender: thisContext
		           receiver: Object new
		           method: Object >> #yourself
		           arguments: #(  ).
	debuggerContext := StDebuggerContext context: context.
	inspector := StDebuggerRawObjectInspector onObject: debuggerContext.
	self assert: inspector selectedObject identicalTo: context receiver! !

!StDebuggerSettingsCommand commentStamp: ''!
I open a settings browser focused on the debugger and debugging systems settings.!
!StDebuggerSettingsCommand methodsFor: 'executing' stamp: ''!
execute
	| regexpSearch browser window path |
	regexpSearch := SettingBrowser regexpSearch.
	SettingBrowser regexpSearch: true.
	
	browser := SettingBrowser new 
		changeSearchedText: 'Debugging';
		yourself.
		 
	window := browser open.
	path := (window submorphs detect: [ :each | (each isKindOf: MorphTreeMorph)  ]) nodeList.
	browser expandNodePath: path first contents first contents first path.
	SettingBrowser regexpSearch: regexpSearch! !

!StDebuggerSettingsCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^'I open a settings browser focused on the debugger and debugging systems settings.'! !

!StDebuggerSettingsCommand class methodsFor: 'default' stamp: ''!
defaultName 
	^'Settings'! !

!StDebuggerSpecSelector commentStamp: ''!
I select and returns the spec selector to be used by the StDebugger presenter.
	Two cases:
	- current selector exists or is not valid: returns default spec selector with debugger extensions
	- current selector exists: select a version with or without debugger extensions
	
Three cases:
	- custom selector: returned as is
	- selector is one of the display strategy with or without debugger extensions
		- extensions activated: force return of spec selector with extensions
		- extensions not activated: force return of spec selector without extensions
		
	Checks performed to tell if extensions are activated:
		- activateDebuggerExtensions must be true
		- AND at least one existing extension class is activated as debugger extension!
!StDebuggerSpecSelector methodsFor: 'accessing' stamp: ''!
debuggerClass 
	^self class debuggerClass! !

!StDebuggerSpecSelector methodsFor: 'specs - selectors' stamp: ''!
selectSpecSelector
	"Sets and returns the spec selector to be use by the presenter.
	Two cases:
	- current selector exists or is not valid: returns default spec selector with extensions
	- current selector exists: select a version with or without debugger extensions"

	| selector |
	selector := (self debuggerClass availableSpecSelectors
		includes: specSelector)
		ifTrue: [ specSelector ]
		ifFalse: [ self class defaultDebuggerWithExtensionSpecSelector ].
	(self isDefaultSelector: selector) ifFalse:[^selector].
	^ self selectExtensionActivationSpecFrom: selector! !

!StDebuggerSpecSelector methodsFor: 'accessing' stamp: ''!
specSelector: anObject
	specSelector := anObject! !

!StDebuggerSpecSelector methodsFor: 'specs - selectors' stamp: ''!
selectorForDebuggerStatus: debuggerExtensionsActivated extensionsStatus: debuggerHasExtensions
	"This is only relevant in the case we use default StDebugger specs for which the extension column can be configured in settings"

	^ (debuggerExtensionsActivated and: [ debuggerHasExtensions ])
		ifTrue: [ self class defaultDebuggerWithExtensionSpecSelector ]
		ifFalse: [ self class defaultDebuggerWithoutExtensionSpecSelector ]! !

!StDebuggerSpecSelector methodsFor: 'specs - default selector' stamp: ''!
specSelector
	^ specSelector! !

!StDebuggerSpecSelector methodsFor: 'testing' stamp: ''!
isDefaultSelector: aSelector
	^ {self class defaultDebuggerWithExtensionSpecSelector.
	self class defaultDebuggerWithoutExtensionSpecSelector}
		includes: aSelector! !

!StDebuggerSpecSelector methodsFor: 'specs - selectors' stamp: ''!
selectExtensionActivationSpecFrom: aDefaultSpecSelector

	"Altered depending on the current configuration of the debugger extensions.
	The selection just adds or remove the extensions from the spec selector"

	self class defaultDebuggerWithoutExtensionSpecSelector
	= aDefaultSpecSelector ifTrue: [ ^ aDefaultSpecSelector ].
	^ self
		  selectorForDebuggerStatus:
		  self debuggerClass activateDebuggerExtensions
		  extensionsStatus: (self debuggerClass hasAnyActivatedExtension:
				   self debuggerClass extensionToolsClasses)! !

!StDebuggerSpecSelector class methodsFor: 'specs - default selectors' stamp: ''!
defaultDebuggerWithExtensionSpecSelector
	^#debuggerWithExtensionsSpec! !

!StDebuggerSpecSelector class methodsFor: 'accessing' stamp: ''!
debuggerClass 	
	^StDebugger! !

!StDebuggerSpecSelector class methodsFor: 'instance creation' stamp: ''!
on: aSelector
	^self new specSelector: aSelector! !

!StDebuggerSpecSelector class methodsFor: 'instance creation' stamp: ''!
defaultSelector
	^self on: self defaultDebuggerWithExtensionSpecSelector! !

!StDebuggerSpecSelector class methodsFor: 'specs - default selectors' stamp: ''!
defaultDebuggerWithoutExtensionSpecSelector
	^#debuggerWithoutExtensionsSpec! !

!StDebuggerSpecSelectorTest methodsFor: 'helpers' stamp: ''!
defaultSelectorWithExtensions
	^ StDebuggerSpecSelector
		defaultDebuggerWithExtensionSpecSelector! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testDefaultSelector
	self
		assert: StDebuggerSpecSelector defaultSelector specSelector
		equals: specSelector class defaultDebuggerWithExtensionSpecSelector! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testSelectNonDefaultSpecSelector
	| nonDefaultSelector mockSelector |		
	mockSelector := StDebuggerUsingSpecSelectorMock new.	
	nonDefaultSelector := mockSelector nonDefaultSelector.
	mockSelector specSelector: nonDefaultSelector.	
		
	mockSelector	initializeWithExtensionsNoneActivated.
	self
		assert: mockSelector selectSpecSelector
		equals: nonDefaultSelector.		
		
	mockSelector initializeWithoutExtensionsNoneActivated.
	self
		assert: mockSelector selectSpecSelector
		equals: nonDefaultSelector.
				
	mockSelector initializeWithoutExtensionsAllActivated.
	self
		assert: mockSelector selectSpecSelector
		equals: nonDefaultSelector.
		
	mockSelector initializeWithExtensionsAllActivated.	
	self
		assert: mockSelector selectSpecSelector
		equals: nonDefaultSelector
	! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testSelectSpecSelectorWithExtensions
	| withExtensionSelector withoutExtensionSelector mockSelector |
	withExtensionSelector := self defaultSelectorWithExtensions.
	withoutExtensionSelector := self defaultSelectorWithoutExtensions.			
	mockSelector := StDebuggerUsingSpecSelectorMock new.
	mockSelector specSelector: withExtensionSelector.	
			
	mockSelector initializeWithExtensionsNoneActivated.
	self
		assert: mockSelector selectSpecSelector
		equals: withoutExtensionSelector.	
		
	mockSelector initializeWithoutExtensionsNoneActivated.
	self
		assert: mockSelector selectSpecSelector
		equals: withoutExtensionSelector.
		
	mockSelector initializeWithoutExtensionsAllActivated.
	self
		assert: mockSelector selectSpecSelector
		equals: withoutExtensionSelector.
		
	mockSelector initializeWithExtensionsAllActivated.
	self
		assert: mockSelector selectSpecSelector
		equals: withExtensionSelector! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testSelectorForDebuggerStatusExtensionsStatus
	| selector |
	selector := specSelector
		selectorForDebuggerStatus: false
		extensionsStatus: false.
	self
		assert: selector
		equals: specSelector class defaultDebuggerWithoutExtensionSpecSelector.
		
	selector := specSelector
		selectorForDebuggerStatus: true
		extensionsStatus: false.
	self
		assert: selector
		equals: specSelector class defaultDebuggerWithoutExtensionSpecSelector.
		
	selector := specSelector
		selectorForDebuggerStatus: false
		extensionsStatus: true.
	self
		assert: selector
		equals: specSelector class defaultDebuggerWithoutExtensionSpecSelector.
		
	selector := specSelector
		selectorForDebuggerStatus: true
		extensionsStatus: true.
	self
		assert: selector
		equals: specSelector class defaultDebuggerWithExtensionSpecSelector! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testDebuggerClass
	self assert: specSelector debuggerClass identicalTo: StDebugger! !

!StDebuggerSpecSelectorTest methodsFor: 'helpers' stamp: ''!
defaultSelectorWithoutExtensions
	^ StDebuggerSpecSelector
		defaultDebuggerWithoutExtensionSpecSelector! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testIsDefaultSelector
	self deny: (specSelector isDefaultSelector: #anySelector).
	self
		assert:
			(specSelector
				isDefaultSelector: specSelector class defaultDebuggerWithExtensionSpecSelector).
	self
		assert:
			(specSelector
				isDefaultSelector: specSelector class defaultDebuggerWithoutExtensionSpecSelector)! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testCustomSelectSpecSelector
	| customSelector mockSelector |
	mockSelector := StDebuggerUsingSpecSelectorMock new.
	customSelector := mockSelector nonDefaultSelector.	
	mockSelector specSelector: customSelector.
	
	mockSelector initializeWithExtensionsNoneActivated.
	self assert: mockSelector selectSpecSelector equals: customSelector.
	
	mockSelector initializeWithoutExtensionsNoneActivated.
	self assert: mockSelector selectSpecSelector equals: customSelector.
	
	mockSelector initializeWithoutExtensionsAllActivated.
	self assert: mockSelector selectSpecSelector equals: customSelector.
	
	mockSelector initializeWithExtensionsAllActivated.	
	self assert: mockSelector selectSpecSelector equals: customSelector! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testSelectExtensionActivationSpecFrom
	| withExtensionSelector withoutExtensionSelector mockSelector |
	withExtensionSelector := self defaultSelectorWithExtensions.
	withoutExtensionSelector := self defaultSelectorWithoutExtensions.	
	mockSelector := StDebuggerUsingSpecSelectorMock new.
		
	mockSelector	initializeWithExtensionsNoneActivated.		
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: withExtensionSelector)
		equals: withoutExtensionSelector.
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: withoutExtensionSelector)
		equals: withoutExtensionSelector.
		
	mockSelector initializeWithoutExtensionsNoneActivated.
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: withExtensionSelector)
		equals: withoutExtensionSelector.
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: withoutExtensionSelector)
		equals: withoutExtensionSelector.
		
	mockSelector initializeWithoutExtensionsAllActivated.
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: withExtensionSelector)
		equals: withoutExtensionSelector.
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: withoutExtensionSelector)
		equals: withoutExtensionSelector.
		
	mockSelector initializeWithExtensionsAllActivated.
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: withExtensionSelector)
		equals: withExtensionSelector.
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: withoutExtensionSelector)
		equals: withoutExtensionSelector.! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testCustomSelectExtensionActivationSpecFrom
	| customSelector mockSelector |
	customSelector := #anySelector.
	mockSelector := StDebuggerUsingSpecSelectorMock new.
	
	mockSelector initializeWithExtensionsNoneActivated.
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: customSelector)
		equals: self defaultSelectorWithoutExtensions.
		
	mockSelector initializeWithoutExtensionsNoneActivated.
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: customSelector)
		equals: self defaultSelectorWithoutExtensions.
		
	mockSelector initializeWithoutExtensionsAllActivated.
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: customSelector)
		equals: self defaultSelectorWithoutExtensions.
		
	mockSelector initializeWithExtensionsAllActivated.		
	self
		assert: (mockSelector selectExtensionActivationSpecFrom: customSelector)
		equals: self defaultSelectorWithExtensions! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testSelectSpecSelectorWithoutExtensions
	| withoutExtensionSelector mockSelector |
	withoutExtensionSelector := self defaultSelectorWithoutExtensions.			
	mockSelector := StDebuggerUsingSpecSelectorMock new.
	mockSelector specSelector: withoutExtensionSelector.	
		
	mockSelector initializeWithExtensionsNoneActivated.		
	self
		assert: mockSelector selectSpecSelector
		equals: withoutExtensionSelector.
		
	mockSelector initializeWithoutExtensionsNoneActivated.	
	self
		assert: mockSelector selectSpecSelector
		equals: withoutExtensionSelector.
		
	mockSelector initializeWithoutExtensionsAllActivated.	
	self
		assert: mockSelector selectSpecSelector
		equals: withoutExtensionSelector.
		
	mockSelector initializeWithExtensionsAllActivated.	
	self
		assert: mockSelector selectSpecSelector
		equals: withoutExtensionSelector.! !

!StDebuggerSpecSelectorTest methodsFor: 'tests - spec' stamp: ''!
testNilSelectSpecSelector
	| withExtensionSelector withoutExtensionSelector  mockSelector |
	withExtensionSelector := self defaultSelectorWithExtensions.
	withoutExtensionSelector := self defaultSelectorWithoutExtensions.	
	mockSelector := StDebuggerUsingSpecSelectorMock new.
	mockSelector specSelector: nil.
	
	mockSelector	initializeWithExtensionsNoneActivated.	
	self assert: mockSelector selectSpecSelector equals: withoutExtensionSelector.
	
	mockSelector initializeWithoutExtensionsNoneActivated.	
	self assert: mockSelector selectSpecSelector equals: withoutExtensionSelector.
	
	mockSelector initializeWithoutExtensionsAllActivated.
	self assert: mockSelector selectSpecSelector equals: withoutExtensionSelector.
	
	mockSelector initializeWithExtensionsAllActivated.		
	self assert: mockSelector selectSpecSelector equals: withExtensionSelector! !

!StDebuggerSpecSelectorTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
	super setUp.
	specSelector := StDebuggerSpecSelector new! !

!StDebuggerStackCommandTreeBuilder commentStamp: ''!
I build the default command tree for the debugger stack presenter.
The command classes I instantiate are specified under the "accessing - commands classes" protocol.
The group names and descriptions are specified under the "accessing" protocol.

You can evolve the default groups names and descriptions and the default command classes, but you cannot extend me.
Using me to add command in the tree makes them default for the debugger stack presenter.!
!StDebuggerStackCommandTreeBuilder methodsFor: 'commands' stamp: ''!
stackContextMenuActionsCommands
	| group |
	group := (CmCommandGroup named: self stackContextMenuActionsGroupName)
		asSpecGroup.
	group beDisplayedAsGroup.
	group description: self stackContextMenuActionsDescription.
	group iconName: #smallDoIt.
	self stackActionsCommandsClasses
		do: [ :cmdClass | 
			group
				register: (self buildSpecCommand: cmdClass forContext: stDebuggerInstance) ].
	^ group! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
browseGroupDescription
	^ 'Navigate the system from the stack'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
stackEditionCommandsClasses
	^ {
	StCopyStackToClipboardCommand.
	StShowFullStackCommand.
	StPeelToFirstCommand.
	StFileOutMethodCommand
	}! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
stackMethodCommandsClasses
	^ {
	SpBrowseMethodInheritanceCommand.
	SpBrowseMethodVersionsCommand
	}! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'commands' stamp: ''!
stackContextNavigationCommands
	"Commands to navigate the context"

	^ (CmCommandGroup named: self stackContextNavigationGroupName) asSpecGroup
		beDisplayedAsGroup;
		register: ((SpBrowseClassCommand forSpecContext: stDebuggerInstance)
			name: 'method';
			shortcutKey: nil;
			yourself);
		register: (((SpBrowseClassCommand forContext: stDebuggerInstance)
			selector: #doBrowseReceiverClass;
			asSpecCommand)
				name: 'receiver';
				shortcutKey: nil;
				yourself);
		yourself! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
stackMethodSelectorCommandsClasses
	^ {
	SpBrowseImplementorsCommand.
	SpBrowseSendersCommand.
	SpBrowseMethodReferencesCommand
	}! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
stackContextMenuExplorationGroupName
	^ 'Explore'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
stackExplorationCommandsClasses
	^ OrderedCollection new
		addAll: self stackReceiverClassExplorationCommandsClasses;
		addAll: self stackReceiverExplorationCommandsClasses;
		yourself! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
stackContextNavigationGroupName
	^ 'Receiver class code navigation commands'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
stackActionsCommandsClasses
	^ {
	StReturnValueCommand
	}! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
stackContextMenuActionsGroupName
	^ 'Context Actions'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
stackContextMenuExplorationDescription
	^ 'Explore the receiver object''s graph'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
stackGroupDescription
	^ 'Stack edition'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
stackReceiverCommandsClasses
	^ {
	SpBrowseClassReferencesCommand.
	SpBrowseClassHierarchyCommand.
	SpBrowseClassVariablesCommand.
	SpBrowseClassVarRefsCommand.
	SpBrowseInstVarRefsCommand
	}! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'commands' stamp: ''!
stackMethodSelectorNavigationCommands
	"Commands to navigate the selected context's method selector as context "

	| group |
	group := (CmCommandGroup
		named: self stackMethodSelectorNavigationGroupName) asSpecGroup.
	group beDisplayedAsGroup.
	self stackMethodSelectorCommandsClasses
		do: [ :navCmdClass | 
			group
				register:
					(self
						buildSpecCommand: navCmdClass
						forContext: stDebuggerInstance stackSelectionMethodSelectorContext) ].
	^ group! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
stackReceiverExplorationCommandsClasses
	^ {SpBrowsePointersToCommand}! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'commands' stamp: ''!
stackContextMenuBrowseCommands
	| group |
	group := (CmCommandGroup named: self browseGroupName) asSpecGroup.
	group description: self browseGroupDescription.
	group iconName: #smallSystemBrowser.
	group register: self stackContextNavigationCommands.
	group register: self stackMethodNavigationCommands.
	group register: self stackMethodSelectorNavigationCommands.
	group register: self stackReceiverClassNavigationCommands.
	^ group! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
stackMethodNavigationGroupName
	^ 'Selected method navigation commands'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'commands' stamp: ''!
stackMethodNavigationCommands
	"Commands to navigate the selected context's method "
	| group |

	group := (CmCommandGroup named: self stackMethodNavigationGroupName) asSpecGroup.
	group beDisplayedAsGroup.
	self stackMethodCommandsClasses do: [ :navCmdClass | 
		group register: (self
			buildSpecCommand: navCmdClass
			forContext: stDebuggerInstance stackSelectionMethodContext) ].
	^ group! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
stackReceiverClassNavigationGroupName
	^ 'Receiver class navigation commands'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
stackContextMenuActionsDescription
	^ 'Actions on the selected context'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'building' stamp: ''!
buildDebuggerCommandGroup
	|stackGroup|
	stackGroup := self group.	
	stackGroup decoratedGroup register: self stackContextMenuBrowseCommands.
	stackGroup decoratedGroup register: self stackContextMenuExplorationCommands.	
	stackGroup decoratedGroup register: self stackContextMenuStackEditionsCommands.
	stackGroup decoratedGroup register: self stackContextMenuActionsCommands.

	! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'commands' stamp: ''!
stackContextMenuExplorationCommands
	| group |
	group := (CmCommandGroup
		named: self stackContextMenuExplorationGroupName) asSpecGroup.
	group description: self stackContextMenuExplorationDescription.
	group iconName: SpSystemDiscoveryCommand defaultIconName.
	self stackReceiverClassExplorationCommandsClasses
		do: [ :cmdClass | 
			group
				register:
					(self
						buildSpecCommand: cmdClass
						forContext: stDebuggerInstance stackSelectionReceiverClassContext) ].
	self stackReceiverExplorationCommandsClasses
		do: [ :cmdClass | 
			group
				register:
					(self
						buildSpecCommand: cmdClass
						forContext: stDebuggerInstance stackSelectionReceiverContext) ].
	^ group! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
stackReceiverClassExplorationCommandsClasses
	^ {
	SpBrowseInstancesCommand.
	SpBrowseSubInstancesCommand.
	}! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'commands' stamp: ''!
stackContextMenuStackEditionsCommands
	| group |
	group := (CmCommandGroup named: self stackGroupName) asSpecGroup.
	group description: self stackGroupDescription.
	group iconName: #edit.
	self stackEditionCommandsClasses
		do: [ :cmdClass | 
			group
				register: (self buildSpecCommand: cmdClass forContext: stDebuggerInstance) ].
	^ group! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
stackGroupName
	^ 'Stack'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'commands' stamp: ''!
stackReceiverClassNavigationCommands
	"Commands to navigate the selected context's receiver class as context "

	| group |
	group := (CmCommandGroup
		named: self stackReceiverClassNavigationGroupName) asSpecGroup.
	group beDisplayedAsGroup.
	self stackReceiverCommandsClasses
		do: [ :navCmdClass | 
			group
				register:
					(self
						buildSpecCommand: navCmdClass
						forContext: stDebuggerInstance stackSelectionReceiverClassContext) ].
	^ group! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
stackMethodSelectorNavigationGroupName
	^ 'Selected method''s selector navigation commands'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
browseGroupName
	^ 'Browse'! !

!StDebuggerStackCommandTreeBuilder methodsFor: 'building' stamp: ''!
buildSpecCommand: aCommandClass forContext: anObject
	| cmd |
	cmd := super buildSpecCommand: aCommandClass forContext: anObject.
	cmd name: aCommandClass shortName.
	^ cmd! !

!StDebuggerStackCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
groupDescription
	^ 'Actions on the debugger stack.'! !

!StDebuggerStackCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
displayStrategy
	^CmUIDisplayAsSubMenu! !

!StDebuggerStackCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
groupName 	
	^'Stack'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackGroupDescription
	self assert: builder stackGroupDescription equals: 'Stack edition'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackGroupName
	self assert: builder stackGroupName equals: 'Stack'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackMethodNavigationCommands
	self
		assertCommandGroup: builder stackMethodNavigationCommands
		hasSameCommands: builder stackMethodCommandsClasses
		withContext: debugger stackTable selection selectedItem method
		displayStrategy: CmUIDisplayAsGroup! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackContextNavigationCommands
	| cmdGroup commands |

	cmdGroup := builder stackContextNavigationCommands.
	commands := cmdGroup allCommands
		collect: [ :spCommand | spCommand innerCommand ].
		
	self deny: cmdGroup isRoot.
	
	self assert: commands first class identicalTo: SpBrowseClassCommand.
	self assert: commands first name equals: 'method'.
	"self assert: commands first context identicalTo: debugger stackTable selection selectedItem method."
	self assert: commands first selector equals: #doBrowseClass.
	
	self assert: commands second class identicalTo: SpBrowseClassCommand.
	self assert: commands second name equals: 'receiver'.
	"self assert: commands second context identicalTo: debugger stackTable selection selectedItem receiver class"
	self assert: commands second selector equals: #doBrowseReceiverClass.
	! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackReceiverClassNavigationGroupName
	self
		assert: builder stackReceiverClassNavigationGroupName
		equals: 'Receiver class navigation commands'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackContextMenuStackEditionsCommands
	self
		assertCommandGroup: builder stackContextMenuStackEditionsCommands
		hasSameCommands: builder stackEditionCommandsClasses
		withContext: debugger
		displayStrategy: CmUIDisplayAsSubMenu! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackContextNavigationGroupName
	self
		assert: builder stackContextNavigationGroupName
		equals: 'Receiver class code navigation commands'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackContextMenuActionsCommands
	self
		assertCommandGroup: builder stackContextMenuActionsCommands
		hasSameCommands: builder stackActionsCommandsClasses
		withContext: debugger
		displayStrategy: CmUIDisplayAsGroup! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackContextMenuBrowseCommands
	|cmdGroup cmdEntries expectedEntries|	

	cmdGroup := builder stackContextMenuBrowseCommands.
	
	self deny: cmdGroup isRoot.
	self assert: cmdGroup groups size equals: 4.
	self assert: cmdGroup name equals: builder browseGroupName.
	self assert: cmdGroup description equals: builder browseGroupDescription.
	self assert: cmdGroup displayStrategy class identicalTo: CmUIDisplayAsSubMenu.
	
	cmdEntries := self commandsFromSpecGroup: (cmdGroup / builder stackContextNavigationGroupName).
	expectedEntries := self commandsFromSpecGroup: builder stackContextNavigationCommands. 	
	self assertCommands: cmdEntries equals: expectedEntries.
	
	cmdEntries := self commandsFromSpecGroup: (cmdGroup / builder stackMethodNavigationGroupName).
	expectedEntries := self commandsFromSpecGroup: builder stackMethodNavigationCommands. 	
	self assertCommands: cmdEntries equals: expectedEntries.
	
	cmdEntries := self commandsFromSpecGroup: (cmdGroup / builder stackMethodSelectorNavigationGroupName).
	expectedEntries := self commandsFromSpecGroup: builder stackMethodSelectorNavigationCommands. 	
	self assertCommands: cmdEntries equals: expectedEntries.
	
	cmdEntries := self commandsFromSpecGroup: (cmdGroup / builder stackReceiverClassNavigationGroupName).
	expectedEntries := self commandsFromSpecGroup: builder stackReceiverClassNavigationCommands. 	
	self assertCommands: cmdEntries equals: expectedEntries
	! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackMethodCommandsClasses
	self
		assertCollection: builder stackMethodCommandsClasses
		equals:
			{SpBrowseMethodInheritanceCommand.
			SpBrowseMethodVersionsCommand}! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testGroupDescription
	self
		assert: builder class groupDescription
		equals: 'Actions on the debugger stack.'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackContextMenuActionsDescription
	self
		assert: builder stackContextMenuActionsDescription
		equals: 'Actions on the selected context'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testGroupName
	self assert: builder class groupName equals: 'Stack'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackContextMenuActionsGroupName
	self
		assert: builder stackContextMenuActionsGroupName
		equals: 'Context Actions'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackMethodSelectorNavigationGroupName
	self
		assert: builder stackMethodSelectorNavigationGroupName
		equals: 'Selected method''s selector navigation commands'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testNavigationCommandForContext
	| cmd |
	
	cmd := builder buildSpecCommand: StMockDebugCommand forContext: self.
	self assert: cmd innerCommand class identicalTo: StMockDebugCommand.
	self assert: cmd context identicalTo: self! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackContextMenuExplorationDescription
	self
		assert: builder stackContextMenuExplorationDescription
		equals: 'Explore the receiver object''s graph'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testBrowseGroupDescription
	self
		assert: builder browseGroupDescription
		equals: 'Navigate the system from the stack'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testBrowseGroupName
	self assert: builder browseGroupName equals: 'Browse'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackReceiverClassNavigationCommands
	self
		assertCommandGroup: builder stackReceiverClassNavigationCommands
		hasSameCommands: builder stackReceiverCommandsClasses
		withContext: debugger stackTable selection selectedItem receiver class
		displayStrategy: CmUIDisplayAsGroup! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackExplorationCommandsClasses
	self
		assertCollection: builder stackExplorationCommandsClasses
		equals:
			(OrderedCollection new
				addAll: builder stackReceiverClassExplorationCommandsClasses;
				addAll: builder stackReceiverExplorationCommandsClasses;
				yourself)! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackReceiverExplorationCommandsClasses
	self
		assertCollection: builder stackReceiverExplorationCommandsClasses
		equals: {SpBrowsePointersToCommand}! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackMethodSelectorNavigationCommands
	self
		assertCommandGroup: builder stackMethodSelectorNavigationCommands
		hasSameCommands: builder stackMethodSelectorCommandsClasses
		withContext: debugger stackTable selection selectedItem method selector
		displayStrategy: CmUIDisplayAsGroup! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackContextMenuExplorationCommands
	|  cmdGroup cmdEntries |
	
	cmdGroup := builder stackContextMenuExplorationCommands.
	cmdEntries := cmdGroup allCommands 
		collect:[ :spCmd| spCmd innerCommand ].
	self deny: cmdGroup isRoot.
	self assert: cmdEntries size equals: 3.
	self assert: cmdGroup name equals: builder stackContextMenuExplorationGroupName.
	self assert: cmdGroup description equals: builder stackContextMenuExplorationDescription.
	self
		assertCommandGroupEntries: cmdEntries
		hasCommands: builder stackExplorationCommandsClasses.
	self
		assertCommandGroup: cmdGroup
		hasDisplayStrategy: CmUIDisplayAsSubMenu.
	self
		assertCommands:
			{cmdEntries first.
			cmdEntries second}
		haveContext: debugger stackTable selection selectedItem receiver class.
	self
		assertCommands: {cmdEntries last}
		haveContext: debugger stackTable selection selectedItem receiver ! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testDisplayStrategy
	self
		assert: builder class displayStrategy
		equals: CmUIDisplayAsSubMenu! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackActionsCommandsClasses
	self
		assertCollection: builder stackActionsCommandsClasses
		equals: {StReturnValueCommand}! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'helper' stamp: ''!
newBuilder
	^ StDebuggerStackCommandTreeBuilder
		buildCommandsGroupWith: debugger
		forRoot: rootGroup! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackContextMenuExplorationGroupName
	self
		assert: builder stackContextMenuExplorationGroupName
		equals: 'Explore'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackReceiverClassExplorationCommandsClasses
	self
		assertCollection: builder stackReceiverClassExplorationCommandsClasses
		equals:
			{SpBrowseInstancesCommand.
			SpBrowseSubInstancesCommand}! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackMethodSelectorCommandsClasses
	self
		assertCollection: builder stackMethodSelectorCommandsClasses
		equals:
			{SpBrowseImplementorsCommand.
			SpBrowseSendersCommand.
			SpBrowseMethodReferencesCommand}! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackReceiverCommandsClasses
	self
		assertCollection: builder stackReceiverCommandsClasses
		equals:
			{SpBrowseClassReferencesCommand.
			SpBrowseClassHierarchyCommand.
			SpBrowseClassVariablesCommand.
			SpBrowseClassVarRefsCommand.
			SpBrowseInstVarRefsCommand}! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackMethodNavigationGroupName
	self
		assertCollection: builder stackMethodNavigationGroupName
		equals: 'Selected method navigation commands'! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testStackEditionCommandsClasses
	self
		assertCollection: builder stackEditionCommandsClasses
		equals:
			{StCopyStackToClipboardCommand.
			StShowFullStackCommand.
			StPeelToFirstCommand.
			StFileOutMethodCommand}! !

!StDebuggerStackCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testCommandGroupStructure
	|stackGroup|
	stackGroup := rootGroup groups first.	
	self assert: stackGroup entries size equals: 4.
	self assert: stackGroup groups first name equals: builder browseGroupName.
	self assert: stackGroup groups first description equals: builder browseGroupDescription.
	self assert: stackGroup groups second name equals: builder stackContextMenuExplorationGroupName.
	self assert: stackGroup groups second description equals: builder stackContextMenuExplorationDescription.
	self assert: stackGroup groups third name equals: builder stackGroupName.
	self assert: stackGroup groups third description equals: builder stackGroupDescription.
	self assert: stackGroup groups fourth name equals: builder stackContextMenuActionsGroupName.
	self assert: stackGroup groups fourth description equals: builder stackContextMenuActionsDescription.! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testAcceptCodeChangesForContext
	| context newSource |
	
	dbg := StTestDebuggerProvider new debuggerWithObjectHalting.
	dbg
		application: dbg class currentApplication;
		initialize;
		buildContextMenus.
	context := dbg stackTable items first.
	newSource := 'haltingMethod ^1+1 squared'.	
	dbg code type: newSource.
	dbg code update.
	dbg unsavedCodeChanges at: 4 put: 2.
	
	dbg acceptCodeChanges: newSource forContext: context.
	self assertEmpty: dbg unsavedCodeChanges.
	self assert: dbg code text equals: newSource! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testRecordUnsavedCodeChanges
	| lastContext |
	
	dbg := self debuggerOn: session.
	dbg stepInto; stepInto.
	lastContext := dbg stackTable items last.		
	dbg code type: 'a'.
	dbg code update.
	
	self assert: dbg code text equals: 'a'.
	self deny: dbg selectedContext sourceCode equals: dbg code text.

	dbg stackTable selectItem: lastContext.
	self assert: dbg code text equals: lastContext sourceCode.
	self assert: (dbg unsavedCodeChangesFor: dbg stackTable items first) equals: 'a'! !

!StDebuggerTest methodsFor: 'accessing' stamp: ''!
debugger
	^ debugger ifNil: [ debugger := self debuggerClass basicNew ]! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testDiscardCodeChangesFor
	| firstContext lastContext |
	
	dbg := self debuggerOn: session.
	dbg stepInto; stepInto.
	firstContext := dbg stackTable items first.	
	lastContext := dbg stackTable items last.		
	dbg code type: 'a'.
	dbg code update.
	dbg stackTable selectItem: lastContext.
	
	self assert: (dbg unsavedCodeChangesFor: firstContext) equals: 'a'.
	dbg stackTable selectItem: firstContext.
	
	dbg discardCodeChangesFor: firstContext.	
	self should: [ (dbg unsavedCodeChangesFor: firstContext) ] raise: KeyNotFound.
	self assert: dbg code text equals: firstContext sourceCode
	
	! !

!StDebuggerTest methodsFor: 'tests - stack table' stamp: ''!
testStackTableWithNewSession
	self debugger session: session.
	self
		assert: (self initializedDebugger stackTable) items
		equals: session shortStack.
	self
		assert: self debugger stackTable selection selectedIndex
		equals: 1.
	self
		assert:
			self debugger stackTable selection selectedItem
				identicalTo: session shortStack first! !

!StDebuggerTest methodsFor: 'accessing' stamp: ''!
inspectorTableFor: inspector
	|contextInspector|
	contextInspector := (inspector class slotNamed: #contextInspector) read: inspector.
	^(contextInspector class slotNamed: #attributeTable) read: contextInspector! !

!StDebuggerTest methodsFor: 'tests - session' stamp: ''!
testRestartContext
	| firstContext lastContext |
	
	dbg := self debuggerOn: session.
	dbg stepInto; stepInto.
	firstContext := dbg stackTable items first.	
	lastContext := dbg stackTable items last.
		
	"We select the last context and we change the code but we do not save.
	The unsaved code change is kept when we select another context (the first one)"	
	dbg stackTable selectItem: lastContext.	
	dbg code type: 'a'.
	dbg code update.	
	dbg stackTable selectItem: firstContext.	
	self assert: (dbg unsavedCodeChangesFor: lastContext) equals: 'a'.	
		
	"We select again the last context and restart it:
	- unsaved code changes are dropped
	- the restarted context is now the first context of the stack
	- the code is reset to the source of the restarted context"	
	dbg stackTable selectItem: lastContext.				
	dbg restartCurrentContext. 	
	self assertEmpty: dbg unsavedCodeChanges.
	self assert: dbg code text equals: lastContext sourceCode.
	self assert: dbg stackTable items first equals: lastContext
	
	
! !

!StDebuggerTest methodsFor: 'tests - raw inspection' stamp: ''!
testRestoreReceiverRawInspectionSelectionAfterContextChange

	self skip.
	self flag: #DBG_TEST! !

!StDebuggerTest methodsFor: 'tests - stack table' stamp: ''!
testStackTableAfterStepIn
	| stackTableItems startingStackSize |
	
	dbg := self debuggerOn: session.
	startingStackSize := dbg stackTable items size.
	dbg stepInto; stepInto.
	stackTableItems := dbg stackTable items.
	self assert: dbg stackTable selection selectedIndex equals: 1.
	self
		assert: dbg stackTable selection selectedItem identicalTo: session shortStack first.
	self assert: stackTableItems size equals: startingStackSize + 1.
	self assert: stackTableItems equals: session shortStack! !

!StDebuggerTest methodsFor: 'tests - initialization' stamp: ''!
testDebuggerApplication
	self
		assert: (self debuggerOn: session) application
		identicalTo: StDebugger currentApplication! !

!StDebuggerTest methodsFor: 'tests - toolbar' stamp: ''!
testToolbarDisplayMode
	debugger := self debuggerOn: session.
	self
		assert: debugger toolbar displayMode
		equals: debugger application toolbarDisplayMode! !

!StDebuggerTest methodsFor: 'tests - receiver inspector' stamp: ''!
testReceiverList
	| currentReceiver |
	dbg := self debuggerOn: session.	
	
	dbg stepInto; stepInto. "getting into Number>>squared"
	currentReceiver := dbg inspector inspectedObject context receiver.	
	self assert: currentReceiver equals: 1
! !

!StDebuggerTest methodsFor: 'tests - stack table' stamp: ''!
testStackTableElementsPrinting
	| columns classColumn methodColumn method block context |

	self debugger session: session.
	columns := self initializedDebugger stackTable columns.
	classColumn := columns second.
	methodColumn := columns third.
	"The following column was removed to experiment a new layout, just keeping the test in case of roolback."
	"senderColumn := columns third."
	method := self class >> #testStackTableElementsPrinting.
	block := [ :a | a ].
	
	context := (Context newForMethod: method) setSender: self receiver: self method: method arguments: #(  ).
	self assert: (classColumn evaluation value: context) equals: self class name.
	self assert: (methodColumn evaluation value: context) equals: method selector.
	"The following column was removed to experiment a new layout, just keeping the test in case of roolback."
	"self assert: (senderColumn evaluation value: context) equals: self stDisplayString."
	
	context := (Context newForMethod: method) setSender: self receiver: self method: block method arguments: #(  ).
	self assert: (classColumn evaluation value: context) equals: self class name.
	self assert: (methodColumn evaluation value: context) equals: block sourceNode sourceCode.
	"The following column was removed to experiment a new layout, just keeping the test in case of roolback."
	"self assert: (senderColumn evaluation value: context) equals: self stDisplayString."! !

!StDebuggerTest methodsFor: 'tests - accepting faulty code' stamp: ''!
testSavingQuickMethodWhenSteppingIntoStackSizeBeforeIsTheSameAfter

	self replaceMethodWithQuickMethodStepping.

	self assert: dbg session stack size equals: stackSizeBefore! !

!StDebuggerTest methodsFor: 'tests - stack table' stamp: ''!
testStackTableSelectionChanged

	dbg := self debuggerOn: session.
	dbg stepInto; stepInto.
	dbg stackTable selectItem: dbg stackTable items second.
	self
		assert:
			dbg inspector inspectedObject context
				identicalTo: dbg stackTable selection selectedItem.
	self
		assert:
			dbg inspector inspectedObject context receiver
				identicalTo: dbg stackTable selection selectedItem receiver.
	self
		assert: dbg code text
		equals: dbg stackTable items second sourceCode! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testUnsavedCodeChangesFor
	| ctx codeChanges |
	
	dbg := self debuggerOn: session.
	self should: [dbg unsavedCodeChangesFor: dbg currentContext] raise: KeyNotFound.
	dbg unsavedCodeChanges at: (ctx := Object new) put: (codeChanges := Object new).
	self assert: (dbg unsavedCodeChangesFor: ctx) identicalTo: codeChanges
	
! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testCodeChangeAfterContextChange
	| firstContext lastContext |
	dbg := self debuggerOn: session.
	dbg stepInto; stepInto.
	firstContext := dbg stackTable items first.	
	lastContext := dbg stackTable items last.	
	
	self assert: dbg code text equals: firstContext sourceCode.
	dbg stackTable selectItem: lastContext.
	self assert: dbg code text equals: lastContext sourceCode.
	dbg stackTable selectItem: firstContext.
	self assert: dbg code text equals: firstContext sourceCode.
	
	self should: [ dbg unsavedCodeChangesFor:  firstContext] raise: KeyNotFound.	
	self should: [ dbg unsavedCodeChangesFor:  lastContext] raise: KeyNotFound! !

!StDebuggerTest methodsFor: 'tests - actions' stamp: ''!
testCopyStackToClipboard
	debugger := self debuggerOn: session.
	debugger copyStackToClipboard.
	self
		assert: Clipboard clipboardText string
		equals: (String streamContents: [ :s | 
				 session interruptedContext shortDebugStackOn: s ])! !

!StDebuggerTest methodsFor: 'tests - session' stamp: ''!
testReturnEnteredValue
	self skip.
	self flag: #DBG_TEST! !

!StDebuggerTest methodsFor: 'tests - accepting faulty code' stamp: ''!
testSavingQuickMethodWhenSteppingIntoStaysInQuickMethod
	
	"We tell the parent that we wanted to step into"
	self replaceMethodWithQuickMethodStepping.
	
	self assert: dbg stackTable items first sourceCode equals: 'haltingMethod ^ 1'! !

!StDebuggerTest methodsFor: 'tests - raw inspection' stamp: ''!
testSaveReceiverRawInspectionSelection

	self skip.
	self flag: #DBG_TEST! !

!StDebuggerTest methodsFor: 'tests - context inspector' stamp: ''!
testContextChangedAfterStepOverAndReturn
	| currentContext |
	dbg := self debuggerOn: session.	
		
	dbg stepInto; stepInto. "getting into Number>>squared"
	currentContext := dbg inspector inspectedObject context.
	dbg stepOver; stepOver.  "stepping over ^self * self (i.e. returning)"
	self
		deny: dbg inspector inspectedObject context
		equals: currentContext! !

!StDebuggerTest methodsFor: 'running' stamp: ''!
tearDown

	session clear.
	self debuggerClass fastTDD: oldFastTDD.
	debugger ifNotNil: [ 
		debugger unsubscribeFromSystemAnnouncer.
		debugger close.
		debugger session ifNotNil: [ :s | s clear ] ].
	StTestDebuggerProvider removeSelector: #foobar. 
	StDebuggerObjectForTests compile: 'haltingMethod <haltOrBreakpointForTesting> self halt. ^self' classified: 'util'.
	super tearDown! !

!StDebuggerTest methodsFor: 'accessing' stamp: ''!
debuggerClass
	^ StDebugger! !

!StDebuggerTest methodsFor: 'tests - raw inspection' stamp: ''!
testRestoreReceiverRawInspectionSelection
	self skip.
	self flag: #DBG_TEST! !

!StDebuggerTest methodsFor: 'tests - actions' stamp: ''!
testRequestClassFrom

	self
		assert: (self debugger requestClassFrom: self class)
		identicalTo: self class! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testRestoreUnsavedCodeChanges
	| firstContext lastContext |
	
	dbg := self debuggerOn: session.
	dbg stepInto; stepInto.
	firstContext := dbg stackTable items first.
	lastContext := dbg stackTable items last.
	
	self assert: dbg code text equals: firstContext sourceCode.
	dbg code type: 'a'.
	dbg update.
	
	dbg stackTable selectItem: lastContext.
	self assert: dbg code text equals: lastContext sourceCode.
	
	dbg stackTable selectItem: firstContext.
	self assert: dbg code text equals: 'a'! !

!StDebuggerTest methodsFor: 'tests - receiver inspector' stamp: ''!
testReceiverChangedAfterStepIn 

	dbg := self debuggerOn: session.
	
	dbg stepInto. "We enter the block context"
	self assert: dbg inspector inspectedObject context receiver identicalTo: session shortStack first receiver.
	
	dbg stepInto. "We step into the first message"
	self assert: dbg inspector inspectedObject context receiver identicalTo: session shortStack first receiver! !

!StDebuggerTest methodsFor: 'tests - stack table' stamp: ''!
testStackTableAfterReturn
	| stackTableItems stackSizeAfterStepIn |
	
	dbg := self debuggerOn: session.

	"we dive into a method"
	dbg stepInto; stepInto.
	stackSizeAfterStepIn := dbg stackTable items size.

	"we return from it"
	dbg stepOver; stepOver.
	stackTableItems := dbg stackTable items.
	self assert: dbg stackTable selection selectedIndex equals: 1.
	self assert: dbg stackTable selection selectedItem identicalTo: session shortStack first.
	self assert: stackTableItems size equals: stackSizeAfterStepIn - 1.
	self assert: stackTableItems equals: session shortStack! !

!StDebuggerTest methodsFor: 'tests - context inspector' stamp: ''!
testContextUnchangedAfterStepOver
	| currentContext |
	
	dbg := self debuggerOn: session.	
	
	dbg stepInto; stepInto. "getting into Number>>squared"
	currentContext := dbg inspector inspectedObject.
	"stepping over one time ^self * self (i.e. we are on the return node but still in the same context)"
	dbg stepOver. 
	self assert: dbg inspector inspectedObject identicalTo:  currentContext! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testUpdateSourceCodeFor

	dbg := self debuggerOn: session.
	dbg unsavedCodeChanges at: 4 put: '2'.
	
	dbg updateSourceCodeFor: 4.
	self assert: dbg code text equals: '2'.
	
	dbg updateSourceCodeFor: (self class>>#testUpdateSourceCodeFor).
	self assert: dbg code text equals: (self class>>#testUpdateSourceCodeFor) sourceCode.! !

!StDebuggerTest methodsFor: 'tests - stack table' stamp: ''!
testPrintReceiverClassInContext
	|ctx result|
	ctx := Context sender: nil receiver: Set new method: (Collection>>#add:) arguments: Array new. 
	result := self debugger printReceiverClassInContext: ctx.
	self assert: result equals: 'Set (Collection)'.
	
	ctx := Context sender: nil receiver: Set new method: (Set>>#add:) arguments: Array new. 
	result := self debugger printReceiverClassInContext: ctx.
	self assert: result equals: 'Set'.! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testInitialCodeSelectionAfterStepping
	| adapter segments highlightSegment pcRangeForContext |
	
	dbg := self debuggerOn: session.
	adapter := SpMorphicCodeAdapter new.
	adapter adapt: dbg code.	
	dbg code adapter: adapter.
	dbg code adapter buildWidget.
	dbg stackTable selectItem: dbg stackTable items first.		
	
	pcRangeForContext := (session pcRangeForContext: dbg currentContext).
	segments := dbg code adapter widget segments.
	self assert: segments size equals: 1.
	highlightSegment := segments first.	
	
	self
		assert:  (highlightSegment firstIndex to: highlightSegment lastIndex)
		equals: (pcRangeForContext first to: pcRangeForContext last + 1)
	"The pc range is highlighted with an additionnal index to encompass the full text of the node (why?)"! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testSaveCodeModification
	| context newSource |
	
	dbg := StTestDebuggerProvider new debuggerWithObjectHalting.
	dbg
		application: dbg class currentApplication;
		initialize;
		buildContextMenus.
	context := dbg stackTable items first.
	newSource := 'haltingMethod ^1+1 squared'.	
	dbg code type: newSource.
	dbg code update.
	dbg unsavedCodeChanges at: 4 put: 2.
	
	dbg code triggerSubmitAction.	
	self assertEmpty: dbg unsavedCodeChanges.
	self assert: context sourceCode equals: newSource.
	self assert: dbg code text equals: context sourceCode
	
	
! !

!StDebuggerTest methodsFor: 'accessing' stamp: ''!
executionControlCommandFrom: aDebugger

	^ debugger toolbar leftItems select: [ :p | 
		  #( 'Proceed' 'Into' 'Over' 'Through' ) includes: p label ]! !

!StDebuggerTest methodsFor: 'tests - initialization' stamp: ''!
testDebuggerActionModel
	"Checking that when initializing a debugger its action model is correctly set up.
	We cannot check that by calling the accessor because it is a lazy accessor. 
	We're using slot reflection instead."

	| slot debuggerActionModel |
	slot := StDebugger slotNamed: #debuggerActionModel.
	debugger := self debuggerOn: session.
	debuggerActionModel := slot read: debugger.

	self assert: debuggerActionModel notNil! !

!StDebuggerTest methodsFor: 'tests - context inspector' stamp: ''!
testContextChangedAfterStepIn 

	dbg := self debuggerOn: session.
	dbg buildContextMenus.	
	
	dbg stepInto. "We enter the block context"
	self assert: dbg inspector inspectedObject context identicalTo: session shortStack first.
	
	dbg stepInto. "We step into the first message"
	self assert: dbg inspector inspectedObject context identicalTo:session shortStack first.
! !

!StDebuggerTest methodsFor: 'tests - receiver inspector' stamp: ''!
testReceiverChangedAfterStepOverAndReturn
	| currentReceiver |
	
	dbg := self debuggerOn: session.	
	
	dbg stepInto; stepInto. "getting into Number>>squared"
	currentReceiver := dbg inspector inspectedObject.
	dbg stepOver; stepOver. "stepping over ^self * self (i.e. returning)"
	self
		deny: dbg inspector inspectedObject
		equals: currentReceiver! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testCancelCodeChangesFor
	| firstContext lastContext |
	dbg := self debuggerOn: session.
	dbg stepInto; stepInto.
	firstContext := dbg stackTable items first.	
	lastContext := dbg stackTable items last.		
	dbg code type: 'a'.
	dbg code update.
	dbg stackTable selectItem: lastContext.
	
	self assert: (dbg unsavedCodeChangesFor: firstContext) equals: 'a'.
	dbg stackTable selectItem: firstContext.
	
	dbg code triggerResetAction.
	self should: [ (dbg unsavedCodeChangesFor: firstContext) ] raise: KeyNotFound.
	self assert: dbg code text equals: firstContext sourceCode
	
	! !

!StDebuggerTest methodsFor: 'tests - stack table' stamp: ''!
testStackTablePackagesLabels
	|stackTable packageColumn ctx|
	self debugger session: session.
	stackTable := self initializedDebugger stackTable.
	packageColumn := stackTable columns last.
	
	"The method is defined in the same package as its class"
	ctx := Context
		sender: nil
		receiver: nil
		method: (StTestDebuggerProvider >> #debuggerWithDNUContext)
		arguments: #().
	self assert: (packageColumn readObject: ctx) equals: StTestDebuggerProvider package name.
	
	"The extension method is defined in another package than its class"
	ctx := Context
		sender: nil
		receiver: nil
		method: (StDebugger >> #inspector)
		arguments: #().
	self assert: (packageColumn readObject: ctx) equals: StTestDebuggerProvider package name.
	
	"Doit methods have no package."
	ctx := Context
		sender: nil
		receiver: nil
		method: (Smalltalk compiler compile: 'doIt 1 + 1')
		arguments: #().
	self assert: (packageColumn readObject: ctx) equals: '-'
	
! !

!StDebuggerTest methodsFor: 'tests - context inspector' stamp: ''!
testNewDebuggerContext
	| debuggerContext |
	
	debugger := (self debuggerOn: session).
	debuggerContext := debugger newDebuggerContext.
	self assert: debuggerContext class identicalTo: debugger class debuggerContextClass.
	self assert: debuggerContext exception equals: session exception! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testCodeSelectionAfterRestart
	| adapter segments highlightSegment pcRangeForContext |
	
	dbg := self debuggerOn: session.
	adapter := SpMorphicCodeAdapter new.
	adapter adapt: dbg code.	
	dbg code adapter: adapter.
	dbg code adapter buildWidget.	
	dbg
		stepInto;
		stepInto.
	dbg restartCurrentContext.
	
	pcRangeForContext := (session pcRangeForContext: dbg currentContext).
	segments := dbg code adapter widget segments.
	self assert: segments size equals: 1.
	highlightSegment := segments first.	
	
	self
		assert:  (highlightSegment firstIndex to: highlightSegment lastIndex)
		equals: (pcRangeForContext first to: pcRangeForContext last + 1)
	"The pc range is highlighted with an additionnal index to encompass the full text of the node (why?)"! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testClearUnsavedChanges

	dbg := self debuggerOn: session.
	dbg unsavedCodeChanges at: 4 put: 2.
	dbg clearUnsavedCodeChanges.
	self assertEmpty: dbg unsavedCodeChanges! !

!StDebuggerTest methodsFor: 'accessing' stamp: ''!
debuggerOn: aDebugSession

	^ self debugger
		  session: aDebugSession;
		  application: self debuggerClass currentApplication;
		  initialize;
		  yourself! !

!StDebuggerTest methodsFor: 'running' stamp: ''!
setUp	
	super setUp.	
	session := StTestDebuggerProvider new sessionForDebuggerTests.
	oldFastTDD := self debuggerClass fastTDD.
	self debuggerClass fastTDD: true! !

!StDebuggerTest methodsFor: 'tests - stack table' stamp: ''!
testStackTableInitialization
	self assert: self debugger stackTable isNil! !

!StDebuggerTest methodsFor: 'tests - actions' stamp: ''!
testRequestProtocolIn

	self
		assert: (self debugger requestProtocolIn: self class)
		equals: Protocol unclassified! !

!StDebuggerTest methodsFor: 'tests - raw inspection' stamp: ''!
testSaveReceiverRawInspectionSelectionAfterContextChange

	self skip.
	self flag: #DBG_TEST! !

!StDebuggerTest methodsFor: 'tests - stack table' stamp: ''!
testSelectLastStackElementWithoutMoreElements
	| stackTable startingStackSize |
	
	dbg := self debuggerOn: session.
	stackTable := dbg stackTable.
	startingStackSize := stackTable items size.
	stackTable selectItem: stackTable items last.
	
	self assert: stackTable items size equals: startingStackSize! !

!StDebuggerTest methodsFor: 'tests - context inspector' stamp: ''!
testContextTempVarList
	| contextItems inspectorTable |
	
	dbg := self debuggerOn: session.
	inspectorTable := dbg inspector getRawInspectorPresenterOrNil attributeTable.
	
	5 timesRepeat: [ dbg stepInto  ].	
	contextItems := inspectorTable roots.
	self assert: contextItems size equals: 8. 	
		
	"First node is self"
	self assert: (contextItems at: 1) class equals: StInspectorSelfNode.	
	
	"Next nodes are temps"
	self assert: (contextItems at: 2) tempVariable isTempVariable.
	self assert: (contextItems at: 3) tempVariable isTempVariable.
	self assert: (contextItems at: 4) tempVariable isTempVariable.
	self assert: (contextItems at: 5) tempVariable isTempVariable.
	
	"receiver"	
	self assert: (contextItems at: 6) rawValue identicalTo: session shortStack first receiver session.
	
	"stackTop"
	self assert: (contextItems at: 7) rawValue equals: 1.
	
	"thisContext"
	self assert: contextItems last rawValue identicalTo: dbg currentContext! !

!StDebuggerTest methodsFor: 'accessing' stamp: ''!
initializedDebugger

	dbg := self debugger.
	dbg application: self debuggerClass currentApplication.
	dbg initialize.

	^ dbg! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testUnsavedCodeChanges

	dbg := self debuggerOn: session.
	self assert: dbg unsavedCodeChanges class identicalTo: IdentityDictionary.
	self assertEmpty: dbg unsavedCodeChanges ! !

!StDebuggerTest methodsFor: 'tests - initialization' stamp: ''!
testFastTDD
	self debuggerClass fastTDD: nil.
	self deny: self debuggerClass fastTDD! !

!StDebuggerTest methodsFor: 'tests - actions' stamp: ''!
testClose
	| windowPresenter |
	
	windowPresenter := SpWindowPresenter new.
	windowPresenter windowIsOpened.
	debugger := (self debuggerOn: session).	
	windowPresenter presenter: debugger.	
	debugger initializeWindow: windowPresenter.
	
	"We trigger the closing from the presenter instead of the debugger itself,
	because the window is not really open so the debugger will not close through debugger close."
	windowPresenter windowClosed.	
	self deny: (SystemAnnouncer uniqueInstance hasSubscriber: debugger)! !

!StDebuggerTest methodsFor: 'tests - receiver inspector' stamp: ''!
testReceiverUnchangedAfterStepOver 
	| currentReceiver |
	
	dbg := self debuggerOn: session.	
	
	dbg stepInto; stepInto. "getting into Number>>squared"
	currentReceiver := dbg inspector inspectedObject context receiver.
	"stepping over one time ^self * self (i.e. we are on the return node but still in the same context)"
	dbg stepOver. 
	self assert: dbg inspector inspectedObject context receiver identicalTo:  currentReceiver
! !

!StDebuggerTest methodsFor: 'tests - stack table' stamp: ''!
testSelectLastStackElementWithMoreElements
	| stackTable selectedItem |
	
	dbg := self debuggerOn: session.
	stackTable := dbg stackTable.
	
	dbg stepInto; stepInto.
	stackTable items: (session stackOfSize: 1).
	
	self assert: stackTable items size equals: 1.
	self assert: stackTable items last equals: session stack first.	
		
	"As we select the last element of the stack table, 
	it should expand the size of the displayed stack"
	selectedItem := stackTable items last.
	stackTable selectItem: selectedItem.
	self assert: stackTable items size equals: session stack size.
	self assert: stackTable items equals: session stack.
	self assert: stackTable selection selectedItem identicalTo: selectedItem

	! !

!StDebuggerTest methodsFor: 'tests - accepting faulty code' stamp: ''!
replaceMethodWithQuickMethodStepping

	"True is a good default value. We step into always by default"

	| context newSource callerContext |
	dbg := StTestDebuggerProvider new debuggerWithObjectHalting.
	dbg
		application: dbg class currentApplication;
		initialize;
		buildContextMenus.

	"Track the size of the stack before compiling the new method for later checking"
	context := dbg stackTable items first. 
	
	"We tell the parent that we did not want to step into"
	stackSizeBefore := context stack size.
	callerContext := context sender.

	newSource := 'haltingMethod ^ 1'.
	dbg code type: newSource.
	dbg code update.
	dbg acceptCodeChanges: newSource forContext: context.
	dbg updateStep! !

!StDebuggerTest methodsFor: 'tests - receiver inspector' stamp: ''!
testUpdateLayoutForContextsIfAssertionFailure

	| assertionFailure currentLayout expectedLayout |
	debugger := StTestDebuggerProvider new
		            debuggerWithFailingAssertionContext.
	session := debugger session.
	debugger application: StDebugger currentApplication.
	debugger initialize.
	debugger updateInspectorFromContext: session interruptedContext.
	assertionFailure := debugger inspector assertionFailure.
	currentLayout := debugger inspector layout.
	expectedLayout := StDebuggerInspector assertionFailureSpec.
	StDebuggerInspector maximizeAssertionSpec: false.
	self assert: currentLayout direction equals: expectedLayout direction.
	self
		assertCollection: currentLayout children first class
		equals: expectedLayout children first class.
	self
		assertCollection: currentLayout children first direction
		equals: expectedLayout children first direction.
	self
		assertCollection: currentLayout children second
		equals: expectedLayout children second.
	self
		assert: currentLayout positionOfSlider
		equals: expectedLayout positionOfSlider.
	self
		assert: currentLayout children size
		equals: expectedLayout children size.
	self
		assert: assertionFailure actualObject
		equals:
		((session interruptedContext tempNamed: #aStringOrBlock) at: 2).
	self
		assert: assertionFailure expectedObject
		equals:
		((session interruptedContext tempNamed: #aStringOrBlock) at: 1)! !

!StDebuggerTest methodsFor: 'tests - code pane' stamp: ''!
testCodeSelectionAfterStepping
	| adapter segments highlightSegment pcRangeForContext |
	
	dbg := self debuggerOn: session.
	adapter := SpMorphicCodeAdapter new.
	adapter adapt: dbg code.	
	dbg code adapter: adapter.
	dbg code adapter buildWidget.	
	dbg
		stepInto;
		stepInto.
	
	pcRangeForContext := (session pcRangeForContext: dbg currentContext).
	segments := dbg code adapter widget segments.
	self assert: segments size equals: 1.
	highlightSegment := segments first.	
	
	self
		assert:  (highlightSegment firstIndex to: highlightSegment lastIndex)
		equals: (pcRangeForContext first to: pcRangeForContext last + 1)
	"The pc range is highlighted with an additionnal index to encompass the full text of the node (why?)"! !

!StDebuggerTest methodsFor: 'tests - context inspector' stamp: ''!
testNewDebuggerContextFor
	| debuggerContext ctx |
	
	debugger := (self debuggerOn: session).
	ctx := [  ] asContext.
	debuggerContext := debugger newDebuggerContextFor: ctx.
	self assert: debuggerContext class identicalTo: debugger class debuggerContextClass.
	self assert: debuggerContext exception equals: session exception.
	self assert: debuggerContext context identicalTo: ctx! !

!StDebuggerTest methodsFor: 'tests - toolbar' stamp: ''!
testToolbarInDNUContext
	|commands|
	session clear.
	session := StTestDebuggerProvider new sessionWithDNUAfterStep.

	self debuggerOn: session.
	"debugger buildContextMenus.	"
	commands := self executionControlCommandFrom: debugger.	

	"We're not in a DNU, buttons are enabled"
	commands do: [ :c| self assert: c isEnabled].
	
	"We step into the DNU, buttons should be disabled"
	debugger stepInto.
	debugger stepOver.

	commands do: [ :c| self deny: c isEnabled].

	"We define the missing method from outside the debugger, buttons should automatically be enabled"
	StTestDebuggerProvider compile: 'foobar ^self'.
	commands do: [ :c| self assert: c isEnabled].
	
	! !

!StDebuggerTestFailureContextPredicate commentStamp: ''!
I provide a specialized context description in the case where a test failure was found on the stack of the context.

I reference that test  failure.
!
!StDebuggerTestFailureContextPredicate methodsFor: 'predicates' stamp: ''!
isContextAnAssertionFailure
	^true! !

!StDebuggerTestFailureContextPredicate methodsFor: 'printing' stamp: ''!
printDescription

	| str |
	str := WriteStream on: String new.
	self printDescriptionPrefixOn: str.

	(failure isKindOf: TestFailure) ifTrue: [ 
		str << failure description.
		^ str contents ].
	(failure isClass and: [ failure includesBehavior: TestFailure ]) 
		ifTrue: [ 
			| variable |
			variable := context temporaryVariableNamed: #aStringOrBlock.
			str << (variable readInContext: context) value.
			^ str contents ].

	str << 'Cannot print test failure in: '.
	str << context printString.
	^ str contents! !

!StDebuggerTestFailureContextPredicate methodsFor: 'accessing' stamp: ''!
failure: anObject
	failure := anObject! !

!StDebuggerTestFailureContextPredicate methodsFor: 'printing' stamp: ''!
isSteppable 
	^false! !

!StDebuggerTestFailureContextPredicate methodsFor: 'testing' stamp: ''!
contextSignalsException
	^true! !

!StDebuggerToggleFilterStackCommand commentStamp: ''!
I toggle the stack filtering in the debugger on and off, and I trigger a debugger update.!
!StDebuggerToggleFilterStackCommand methodsFor: 'executing' stamp: ''!
execute
	StDebuggerActionModel shouldFilterStack: StDebuggerActionModel shouldFilterStack not.
	self context updateStep! !

!StDebuggerToggleFilterStackCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^'Toggle stack filtering on and off'! !

!StDebuggerToggleFilterStackCommand class methodsFor: 'default' stamp: ''!
defaultName 
	^'Toggle stack filtering'! !

!StDebuggerToolCommandTreeBuilderTest methodsFor: 'running' stamp: ''!
tearDown
	debugger ifNotNil:[debugger clear].
	super tearDown.
! !

!StDebuggerToolCommandTreeBuilderTest methodsFor: 'assertions' stamp: ''!
assertCommandGroup: cmdGroup hasSameCommands: expectedCommands withContext: expectedContext displayStrategy: displayStrategy
	| commands |
	self deny: cmdGroup isRoot.
	self assertCommandGroup: cmdGroup hasDisplayStrategy: displayStrategy.
	commands := cmdGroup allCommands
		collect: [ :spCommand | spCommand innerCommand ].
	self
		assertCommandGroupEntries: commands
		hasCommands: expectedCommands.
	self assertCommands: commands haveContext: expectedContext! !

!StDebuggerToolCommandTreeBuilderTest methodsFor: 'assertions' stamp: ''!
assertCommandGroup: cmdGroup hasDisplayStrategy: displayStrategy
	self
		assert: cmdGroup displayStrategy class
		identicalTo: displayStrategy! !

!StDebuggerToolCommandTreeBuilderTest methodsFor: 'assertions' stamp: ''!
assertCommandGroupEntries: commands hasCommands: expectedCommands
	self
		assertCollection: (commands collect: [ :cmd | cmd class ])
		hasSameElements: expectedCommands! !

!StDebuggerToolCommandTreeBuilderTest methodsFor: 'assertions' stamp: ''!
assertCommands: commands haveContext: expectedContext
	commands
		do: [ :cmd | self assert: cmd context identicalTo: expectedContext ]! !

!StDebuggerToolCommandTreeBuilderTest methodsFor: 'instance creation' stamp: ''!
newBuilder
	^self subclassResponsibility ! !

!StDebuggerToolCommandTreeBuilderTest methodsFor: 'helper' stamp: ''!
commandsFromSpecGroup: group

	^ group decoratedGroup entries collect: [ :cmd | cmd innerCommand ]! !

!StDebuggerToolCommandTreeBuilderTest methodsFor: 'assertions' stamp: ''!
assertCommands: commands equals: expectedCommands
	self assert: commands size equals: expectedCommands size.
	commands
		with: expectedCommands
		do: [ :actual :expected | 
			self assert: actual name equals: expected name.
			self assert: actual context identicalTo: expected context.
			self assert: actual class identicalTo: expected class ]! !

!StDebuggerToolCommandTreeBuilderTest methodsFor: 'running' stamp: ''!
setUp
	| context process |
	super setUp.
	context := [ ^ 1 + 1 ] asContext.
	process := Process
		forContext: context
		priority: Processor userInterruptPriority.
	session := DebugSession
		named: 'test session'
		on: process
		startedAt: context.
	session exception: OupsNullException new.
	debugger := StDebugger basicNew
		application: StDebugger currentApplication;
		session: session;
		initialize.
	debugger stackTable selectItem: debugger stackTable items first.
	rootGroup := (CmCommandGroup named: 'root') asSpecGroup.
	builder := self newBuilder! !

!StDebuggerToolCommandTreeBuilderTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^self class = StDebuggerToolCommandTreeBuilderTest ! !

!StDebuggerToolbarCommandTreeBuilder commentStamp: ''!
I build the default command tree for the debugger toolbar presenter.
The command classes I instantiate are specified under the "accessing - commands classes" protocol.
The group names and descriptions are specified under the "accessing" protocol.

You can evolve the default groups names and descriptions and the default command classes, but you cannot extend me.
Using me to add command in the tree makes them default for the debugger toolbar presenter.!
!StDebuggerToolbarCommandTreeBuilder methodsFor: 'building' stamp: ''!
buildCommandGroupFrom: commandClasses named: commandGroupName description: commandGroupDescription
	| group |
	group := (CmCommandGroup named: commandGroupName) asSpecGroup.
	group beDisplayedAsGroup.
	group description: commandGroupDescription.
	group iconName: #smallDebug.
	commandClasses
		do: [ :cmdClass | 
			group
				register: (self buildSpecCommand: cmdClass forContext: stDebuggerInstance) ].
	^ group! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
contextControlGroupDescription
	^'Actions performed on the interrupted context'! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'building' stamp: ''!
buildDebuggerCommandGroup
	|group|
	group := self group.
	group displayStrategy: self displayStrategy.
	group decoratedGroup register: self executionControlDebuggingCommands. 
	group decoratedGroup register: self contextRequestDebuggingCommands.
	group decoratedGroup register: self contextControlDebuggingCommands
	! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
contextRequestCommandClasses
	^ {
	StWhereIsCommand
	}! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'commands' stamp: ''!
contextRequestDebuggingCommands
	^ self
		buildCommandGroupFrom: self contextRequestCommandClasses
		named: self contextRequestGroupName
		description: self contextRequestGroupDescription! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
contextRequestGroupDescription
	^ 'Requests on the interrupted context'! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'commands' stamp: ''!
executionControlDebuggingCommands
	^ self
		buildCommandGroupFrom: self executionControlCommandClasses
		named: self executionControlGroupName
		description: self executionControlGroupDescription! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
executionControlCommandClasses
	^ {
	StProceedCommand.
	StStepIntoCommand.
	StStepOverCommand.
	StStepThroughCommand.
	StRunToSelectionCommand.
	StRestartCommand.
	StReturnValueCommand
	}! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
executionControlGroupName
	^'Execution control'! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
contextControlGroupName
	^'Context control'! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
executionControlGroupDescription
	^'Debug actions applied to the executed context'! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
contextRequestGroupName
	^'Context requests'! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
defaultDebugActionsDescription
	^'Defaults debugging actions'! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing - commands classes' stamp: ''!
contextControlCommandClasses
	^ {StDefineMissingEntityCommand}! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'accessing' stamp: ''!
defaultDebugActionsGroupName
	^'Debugging actions'! !

!StDebuggerToolbarCommandTreeBuilder methodsFor: 'commands' stamp: ''!
contextControlDebuggingCommands
	^ self
		buildCommandGroupFrom: self contextControlCommandClasses
		named: self contextControlGroupName
		description: self contextControlGroupDescription! !

!StDebuggerToolbarCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
groupDescription
	^ 'Debug actions'! !

!StDebuggerToolbarCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
displayStrategy
	^CmUIDisplayAsGroup! !

!StDebuggerToolbarCommandTreeBuilder class methodsFor: 'accessing' stamp: ''!
groupName 	
	^'Toolbar'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testBuildCommandGroupFromNamedDescription
	| group spCommands |
	group := builder
		buildCommandGroupFrom:
			{StMockDebugCommand.
			StMockDebugCommand}
		named: #testName
		description: #testDescription.
	self assert: group name equals: #testName.	
	self assert: group description equals: #testDescription.
	spCommands := group allCommands.
	self assert: spCommands size equals: 2.
	self assert: spCommands first innerCommand class equals: StMockDebugCommand.
	self assert: spCommands second innerCommand class equals: StMockDebugCommand.
	self assert: spCommands first context identicalTo: debugger.
	self assert: spCommands second context identicalTo: debugger! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testExecutionControlGroupDescription
	self
		assert: builder executionControlGroupDescription
		equals: 'Debug actions applied to the executed context'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testContextControlDebuggingCommands
	self
		assertCommandGroup: builder contextControlDebuggingCommands
		hasSameCommands: builder contextControlCommandClasses
		withContext: debugger
		displayStrategy: CmUIDisplayAsGroup! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testContextRequestCommandClasses
	self
		assertCollection: builder contextRequestCommandClasses
		equals: {StWhereIsCommand}! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testExecutionControlGroupName
	self
		assert: builder executionControlGroupName
		equals: 'Execution control'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testContextRequestGroupDescription
	self
		assert: builder contextRequestGroupDescription
		equals: 'Requests on the interrupted context'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testContextControlCommandClasses
	self
		assertCollection: builder contextControlCommandClasses
		equals: {StDefineMissingEntityCommand}! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testContextRequestGroupName
	self
		assert: builder contextRequestGroupName
		equals: 'Context requests'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testContextControlGroupDescription
	self
		assert: builder contextControlGroupDescription
		equals: 'Actions performed on the interrupted context'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testDefaultDebugActionsGroupName
	self
		assert: builder defaultDebugActionsGroupName
		equals: 'Debugging actions'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testDisplayStrategy
	self assert: builder class displayStrategy equals: CmUIDisplayAsGroup! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testExecutionControlDebuggingCommands
	self
		assertCommandGroup: builder executionControlDebuggingCommands
		hasSameCommands: builder executionControlCommandClasses
		withContext: debugger
		displayStrategy: CmUIDisplayAsGroup! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'instance creation' stamp: ''!
newBuilder
	^ StDebuggerToolbarCommandTreeBuilder
		buildCommandsGroupWith: debugger
		forRoot: rootGroup! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testContextControlGroupName
	self
		assert: builder contextControlGroupName
		equals: 'Context control'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testGroupDescription
	self assert: builder class groupDescription equals: 'Debug actions'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testContextRequestDebuggingCommands
	self
		assertCommandGroup: builder contextRequestDebuggingCommands
		hasSameCommands: builder contextRequestCommandClasses
		withContext: debugger
		displayStrategy: CmUIDisplayAsGroup! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testExecutionControlCommandClasses
	self
		assertCollection: builder executionControlCommandClasses
		equals:
			{StProceedCommand.
			StStepIntoCommand.
			StStepOverCommand.
			StStepThroughCommand.
			StRunToSelectionCommand.
			StRestartCommand.
			StReturnValueCommand}! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testGroupName
	self assert: builder class groupName equals: 'Toolbar'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testExecutionControlShortcuts

	| commandsWithShortcuts |
	commandsWithShortcuts := builder executionControlCommandClasses 
		                         select: [ :class | 
		                         class defaultShortcut notNil ].
	self assert: commandsWithShortcuts notEmpty.
	commandsWithShortcuts do: [ :class | 
		| command |
		command := builder buildSpecCommand: class forContext: self.
		self assert: command shortcutKey equals: class defaultShortcut ]! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testDefaultDebugActionsDescription
	self
		assert: builder defaultDebugActionsDescription
		equals: 'Defaults debugging actions'! !

!StDebuggerToolbarCommandTreeBuilderTest methodsFor: 'tests' stamp: ''!
testCommandGroupStructure
	|stackGroup|
	stackGroup := rootGroup groups first.	
	self assert: stackGroup entries size equals: 3.
	self assert: stackGroup groups first name equals: builder executionControlGroupName.
	self assert: stackGroup groups first description equals: builder executionControlGroupDescription.
	self assert: stackGroup groups second name equals: builder contextRequestGroupName.
	self assert: stackGroup groups second description equals: builder contextRequestGroupDescription.
	self assert: stackGroup groups third name equals: builder contextControlGroupName.
	self assert: stackGroup groups third description equals: builder contextControlGroupDescription.
! !

!StDebuggerTreeTablePresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	counter := 0! !

!StDebuggerTreeTablePresenter methodsFor: 'api' stamp: ''!
hasActiveFilter
	^counter > 0! !

!StDebuggerTreeTablePresenter methodsFor: 'api' stamp: ''!
applyFilter

	filter ifNil: [ ^items ].
	self flag: 'Ugly hack because links presenter trigger 2 times their action. But for now it works'.
	counter > 3 ifTrue:  [ counter := 0. filter := nil. ^items ].

	^items select: [:item| item variableTag = filter]! !

!StDebuggerTreeTablePresenter methodsFor: 'accessing' stamp: ''!
filter
	^ filter! !

!StDebuggerTreeTablePresenter methodsFor: 'api' stamp: ''!
roots: aCollection

	items := aCollection.
	super roots: self applyFilter
! !

!StDebuggerTreeTablePresenter methodsFor: 'api' stamp: ''!
toggleFilter: aVariableTag

"	filter := filter = aVariableTag
		          ifTrue: [ nil ]
		          ifFalse: [ aVariableTag ]."
	filter := aVariableTag.
	counter := counter + 1.

	self roots: items! !

!StDebuggerUsingSpecSelectorMock commentStamp: ''!
I mock the state of StDebuggerUsingSpecSelector to test variations in its state.!
!StDebuggerUsingSpecSelectorMock methodsFor: 'initialization' stamp: ''!
initializeWithExtensionsNoneActivated
	withDebuggerExtensions := true.
	withActivatedExtensions := false! !

!StDebuggerUsingSpecSelectorMock methodsFor: 'accessing' stamp: ''!
nonDefaultSelector
	^#nonDefaultSelector! !

!StDebuggerUsingSpecSelectorMock methodsFor: 'initialization' stamp: ''!
initializeWithoutExtensionsNoneActivated
	withDebuggerExtensions := false.
	withActivatedExtensions := false! !

!StDebuggerUsingSpecSelectorMock methodsFor: 'accessing' stamp: ''!
debuggerClass 	
	^self! !

!StDebuggerUsingSpecSelectorMock methodsFor: 'accessing' stamp: ''!
activateDebuggerExtensions
	^withDebuggerExtensions ! !

!StDebuggerUsingSpecSelectorMock methodsFor: 'accessing' stamp: ''!
availableSpecSelectors
	^ StDebugger availableSpecSelectors
		add: self nonDefaultSelector;
		yourself! !

!StDebuggerUsingSpecSelectorMock methodsFor: 'specs' stamp: ''!
columnInspectorsSpec! !

!StDebuggerUsingSpecSelectorMock methodsFor: 'accessing' stamp: ''!
hasAnyActivatedExtension: anObject
	^ withActivatedExtensions! !

!StDebuggerUsingSpecSelectorMock methodsFor: 'initialization' stamp: ''!
initializeWithExtensionsAllActivated
	withDebuggerExtensions := true.
	withActivatedExtensions := true! !

!StDebuggerUsingSpecSelectorMock methodsFor: 'accessing' stamp: ''!
extensionToolsClasses
	^{}! !

!StDebuggerUsingSpecSelectorMock methodsFor: 'initialization' stamp: ''!
initializeWithoutExtensionsAllActivated
	withDebuggerExtensions := false.
	withActivatedExtensions := true! !

!StDebuggerUsingSpecSelectorMock class methodsFor: 'initialization' stamp: ''!
initializeWithExtensionsNoneActivated
	^self new initializeWithExtensionsNoneActivated! !

!StDebuggerUsingSpecSelectorMock class methodsFor: 'initialization' stamp: ''!
initializeWithoutExtensionsNoneActivated
	^self new initializeWithoutExtensionsNoneActivated! !

!StDebuggerUsingSpecSelectorMock class methodsFor: 'initialization' stamp: ''!
initializeWithExtensionsAllActivated
	^self new initializeWithExtensionsAllActivated! !

!StDebuggerUsingSpecSelectorMock class methodsFor: 'initialization' stamp: ''!
initializeWithoutExtensionsAllActivated
	^self new initializeWithoutExtensionsAllActivated! !

!StDefaultSourceFactory commentStamp: ''!
I represent the creation of sources without indexes. 
!
!StDefaultSourceFactory methodsFor: 'sources - implementors' stamp: ''!
implementorsBeginsWithSource

	^ (StImplementorsIterator new collect: [ :e | StMethodEntry on: e ]) asBeginsWithFilter! !

!StDefaultSourceFactory methodsFor: 'sources - classes' stamp: ''!
classesBeginsWithSource

	^ ((StClassIterator new select: [ :e | e isMeta not ])
		collect: [ :e | StClassEntry on: e ]) asBeginsWithFilter! !

!StDefaultSourceFactory methodsFor: 'sources - implementors' stamp: ''!
implementorsSubstringSource

	^ (StImplementorsIterator new collect: [ :e | StMethodEntry on: e ]) asSubstringFilter! !

!StDefaultSourceFactory methodsFor: 'sources - classes' stamp: ''!
classesSubstringSource

	^ ((StClassIterator new select: [ :e | e isMeta not ])
		collect: [ :e | StClassEntry on: e ]) asSubstringFilter! !

!StDefaultSourceFactory class methodsFor: 'detecting implementations' stamp: ''!
priority 
	
	"I have a lower priority, because I don't use any fancy scheme"
	^ 0 ! !

!StDefaultSourceFactory class methodsFor: 'detecting implementations' stamp: ''!
isAvailable 

	"I am always available, I am the default implementation"
	^ true! !

!StDefineClassCommand commentStamp: ''!
I request the debugger to define a missing class in case the current context is interrupted on a DNU exception and a receiver that is an unknown symbol!
!StDefineClassCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ aDebugger canExecuteCreateMissingClassCommand! !

!StDefineClassCommand methodsFor: 'executing' stamp: ''!
execute	
	self debugger createMissingClass! !

!StDefineClassCommand class methodsFor: 'accessing' stamp: ''!
defaultName
	^ 'Create missing class'! !

!StDefineMethodCommand commentStamp: ''!
I request the debugger to define a missing method in case the current context is interrupted on a DNU exception!
!StDefineMethodCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ aDebugger canExecuteCreateMissingMethodCommand! !

!StDefineMethodCommand methodsFor: 'hooks' stamp: ''!
execute
	self debugger createMissingMethod! !

!StDefineMethodCommand class methodsFor: 'accessing' stamp: ''!
defaultName
	^ 'Create missing command'! !

!StDefineMissingEntityCommand commentStamp: ''!
This command requests from a debugger to create a missing method (DNU or subclassResponsibility) or class.

This command delegates concrete behavior to its subclasses.
Each instance of this command has a collection of mutually exclusive subcommands (one for each of its subclasses). 
Each subcommand has the same debugger.

For a given debugging context (i.e., the context of the debugger's debug session), only one of the subcommand can be executed.
For instance, if we are in the context of a DNU, it makes only sense to propose to create the missing method (StCreateMissingMethodDebugCommand) and all other subcommands are inapplicable.!
!StDefineMissingEntityCommand methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	subCommands := OrderedCollection new! !

!StDefineMissingEntityCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ subCommands
		anySatisfy: [ :subCommand | subCommand appliesTo: aDebugger ]! !

!StDefineMissingEntityCommand methodsFor: 'accessing' stamp: ''!
context: aDebugger
	super context: aDebugger.
	subCommands := self class allSubclasses
		collect: [ :subCommand | subCommand forContext: aDebugger ]! !

!StDefineMissingEntityCommand methodsFor: 'executing' stamp: ''!
execute
	self applicableCommand ifNotNil: [ :cmd | cmd execute ]! !

!StDefineMissingEntityCommand methodsFor: 'private' stamp: ''!
applicableCommand
	^ subCommands
		detect: [ :subCommand | subCommand canBeExecuted ]
		ifNone: [ nil ]! !

!StDefineMissingEntityCommand methodsFor: 'accessing' stamp: ''!
subCommands
	^subCommands! !

!StDefineMissingEntityCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ nil! !

!StDefineMissingEntityCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ #debuggerDefineEntity! !

!StDefineMissingEntityCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription
    ^ 'Create the missing class or method in the user prompted class, and restart the debugger at the location where it can be edited.'! !

!StDefineMissingEntityCommand class methodsFor: 'accessing' stamp: ''!
defaultName
	^ 'Create'! !

!StDefineSubclassResponsabilityCommand commentStamp: ''!
I request the debugger to define a subclass responsibility method, in case the current context is interrupted on a subclass responsibility exception!
!StDefineSubclassResponsabilityCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ aDebugger canExecuteCreateSubclassResponsibilityCommand! !

!StDefineSubclassResponsabilityCommand methodsFor: 'actions' stamp: ''!
execute
	self debugger createSubclassResponsibility! !

!StDefineSubclassResponsabilityCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ nil! !

!StDefineSubclassResponsabilityCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName
	^ #changeAdd! !

!StDefineSubclassResponsabilityCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription
	^ 'Create a method in a class having the responsability to implement it.'! !

!StDefineSubclassResponsabilityCommand class methodsFor: 'accessing' stamp: ''!
defaultName
	^ 'Create subclass responsibility'! !

!StDummyDebuggerPresenter commentStamp: ''!
I am a dummy debugger presenter for tests.
I'm used in tests to easily ensure that commands or other clients call the correct interface on their debugger object.
The debugger interface itself is tested in the debugger test class.!
!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
proceedDebugSession
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
unimplementedSubclassResponsibility
	self subclassResponsibility ! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
selectNextExecutedExpression
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
showFullStack
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
createMissingMethod
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
peelToFirstLike: aStDummyDebuggerPresenter

	tag := thisContext method selector.
	^ true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
stepInto
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'accessing' stamp: ''!
debuggerExtensionToolName
	^'Test extendedDebuggingToolTitle'
	! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
fileOutSelectedContext
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
createSubclassResponsibility
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'accessing' stamp: ''!
tag
	^ tag! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
copyStackToClipboard
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
returnEnteredValue
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
createMissingClass
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
restartCurrentContext
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
stepThrough
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'accessing context' stamp: ''!
currentContext
	^self! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
runToSelection
tag := thisContext method selector.
^true! !

!StDummyDebuggerPresenter methodsFor: 'mocks' stamp: ''!
stepOver
tag := thisContext method selector.
^true! !

!StDummyTestClassWithHalts commentStamp: ''!
I am only there to be used by the StBreakpointCacheTest class.
Compile method with and without breakpoints, but remove them after the tests.!
!StDummyTestClassWithHalts methodsFor: 'accessing' stamp: ''!
var
	"the var is used for testing, this accessor us just here so that it has one user"
	^var! !

!StEntry commentStamp: ''!
I wrap the return elements from the spotter processor. 
As the processor returns different elements I add the behaviour required to show the element. 

Also, I redirect the messages that should be answer by my content!
!StEntry methodsFor: 'spotter-extensions' stamp: ''!
displayString

	^ self asString! !

!StEntry methodsFor: 'comparing' stamp: ''!
= anEntry

	^ self species = anEntry species
		and: [ anEntry content = self content ]! !

!StEntry methodsFor: 'comparing' stamp: ''!
hash

	^ content hash! !

!StEntry methodsFor: 'testing' stamp: ''!
matchesText: aString

	^ self asString = aString! !

!StEntry methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
stActDefault
	^ content stActDefault ! !

!StEntry methodsFor: 'accessing' stamp: ''!
content: anObject
	content := anObject! !

!StEntry methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.	
	aStream
		<< '( ';
		print: content;
		<< ' )'! !

!StEntry methodsFor: 'converting' stamp: ''!
asString 

	^ self subclassResponsibility ! !

!StEntry methodsFor: 'evaluating' stamp: ''!
evaluateFor: aSpotter 

	self doEvaluate! !

!StEntry methodsFor: 'accessing' stamp: ''!
icon
	
	^ self subclassResponsibility! !

!StEntry methodsFor: 'accessing' stamp: ''!
content
	^ content! !

!StEntry methodsFor: '*NewTools-Spotter' stamp: ''!
headerCategoryForUnifiedProcessor: aLink on: aSpotterPresenter

	^ aSpotterPresenter headerCategoryFor: aLink 			
! !

!StEntry methodsFor: 'accessing' stamp: ''!
spotterPreview

	^ (content spotterPreview: SpPresenterBuilder new)
		addStyle: 'stSpotterPreview';
		yourself! !

!StEntry methodsFor: 'spotter-extensions' stamp: ''!
stSpotterProcessorsFor: aSpotterStep

	^ content stSpotterProcessorsFor: aSpotterStep! !

!StEntry methodsFor: 'accessing' stamp: ''!
label

	^ self asString! !

!StEntry methodsFor: 'evaluating' stamp: ''!
doEvaluate 

	self subclassResponsibility ! !

!StEntry class methodsFor: '*NewTools-Spotter' stamp: ''!
prepareUnifiedHeaderDescriptionFor: aHeaderPresenter
	"do nothing"! !

!StEntry class methodsFor: 'wrapping' stamp: ''!
on: aValue
	
	^ self new
		content: aValue;
		yourself! !

!StEntry class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self == StEntry! !

!StErrorContext commentStamp: ''!
I represent an erroneous inspector context.
I arrive when an inspector context fails with an exception.
In that case, I force the inspection presenter to be a debug inspection presenter.!
!StErrorContext methodsFor: 'initialization' stamp: ''!
getError

	^ error! !

!StErrorContext methodsFor: 'initialization' stamp: ''!
setError: anError

	error := anError! !

!StErrorContext methodsFor: 'testing' stamp: ''!
isErrorContext
	
	^ true! !

!StErrorContext methodsFor: 'initialization' stamp: ''!
basicNewInspectionPresenter

	^ self debugInspectorPresenter! !

!StEvaluateCommand commentStamp: ''!
A command to "evaluate and go" the content of a selection (evaluate the selection and open an inspector with the results).
!
!StEvaluateCommand methodsFor: 'executing' stamp: ''!
execute
	
	self context doEvaluateAndGo! !

!StEvaluateCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ $g command mac 
		| $g control win
		| $g control unix! !

!StEvaluateCommand class methodsFor: 'documentation' stamp: ''!
documentContextRequiredSelectors

	^ super documentContextRequiredSelectors, #(doEvaluateAndGo)! !

!StEvaluateCommand class methodsFor: 'default' stamp: ''!
defaultIconName

	^ #glamorousGo! !

!StEvaluateCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Evaluate selection and open an inspection column.'! !

!StEvaluateCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Do it and go'! !

!StEvaluatedSelectionModel commentStamp: ''!
A selection container to simulate a selection object (the object that is sent when a selection is triggered on `activation` and `selection` events). 
This is used so we can trigger `activation` events outside lists tables and trees (for example, in a playground or an inpector evaluator).   !
!StEvaluatedSelectionModel methodsFor: 'accessing' stamp: ''!
value: anObject

	value := anObject! !

!StEvaluatedSelectionModel methodsFor: 'api - selection' stamp: ''!
selectedItem

	^ self value! !

!StEvaluatedSelectionModel methodsFor: 'accessing' stamp: ''!
value

	^ value! !

!StEvaluatedSelectionModel class methodsFor: 'instance creation' stamp: ''!
newValue: anObject 

	^ self new
		value: anObject;
		yourself! !

!StFailingAssertionInspector commentStamp: ''!
I present a side-by-side view of a failing assert, with at my left an inspector on the failing object and at my left the expected object.

Only opens for following assertions failures:
#assert:equals: 
#assert:closeTo:precision: 
#assert:closeTo: 
#assert:identicalTo: 
#assertCollection:equals: 
#assertCollection:hasSameElements:!
!StFailingAssertionInspector methodsFor: 'views' stamp: ''!
treeTableInspectionFor: aModel
	| rawInspection |
	rawInspection := StRawInspection new.
	^ self newTreeTable
		  roots: aModel value allInspectorNodes;
		  children: [ :node | node children ];
		  addColumn: rawInspection variablesColumn;
		  addColumn: rawInspection valuesColumn;
		  yourself! !

!StFailingAssertionInspector methodsFor: 'accessing' stamp: ''!
expectedObject: anObject
	expectedObject := anObject! !

!StFailingAssertionInspector methodsFor: 'accessing' stamp: ''!
actualObject
	^ actualObject! !

!StFailingAssertionInspector methodsFor: 'accessing' stamp: ''!
actualObjectMillerList
	^ actualObjectMillerList! !

!StFailingAssertionInspector methodsFor: 'accessing' stamp: ''!
actualObject: anObject
	actualObject := anObject! !

!StFailingAssertionInspector methodsFor: 'accessing' stamp: ''!
expectedObject
	^ expectedObject! !

!StFailingAssertionInspector methodsFor: 'accessing' stamp: ''!
expectedObjectMillerList
	^ expectedObjectMillerList! !

!StFailingAssertionInspector methodsFor: 'initialization' stamp: ''!
initializeMillerList: list forObject: object
	list
		presenterBlock: [ :aModel | self treeTableInspectionFor: aModel ];
		setRootModel: object ! !

!StFailingAssertionInspector methodsFor: 'accessing' stamp: ''!
stringDiff
	^stringDiff! !

!StFailingAssertionInspector methodsFor: 'initialization' stamp: ''!
initializePresenters
	self flag: 'Not nice but works. This needs improvement.'.
	(actualObject isString and: [ expectedObject isString ])
		ifTrue: [ ^ self initializePresentersForString ].
		
	actualObjectHeader := (self instantiate: StHeaderBar)
		label: 'Actual object: ' , (actualObject printStringLimitedTo: 40);
		yourself.
	"actualObjectHeader applyStyleToLabel: 'label.headerError'."
	actualObjectMillerList := SpMillerColumnPresenter new.
	self
		initializeMillerList: actualObjectMillerList
		forObject: actualObject.
	expectedObjectHeader := (self instantiate: StHeaderBar)
		label: 'Expected object: ' , (expectedObject printStringLimitedTo: 40);
		yourself.
	"expectedObjectHeader applyStyleToLabel: 'label.headerSuccess'."
	expectedObjectMillerList := SpMillerColumnPresenter new.
	self
		initializeMillerList: expectedObjectMillerList
		forObject: expectedObject! !

!StFailingAssertionInspector methodsFor: 'initialization' stamp: ''!
initializePresentersForString
	
	stringDiff := self newDiff.
	stringDiff showOptions: false.
	stringDiff leftLabel: 'Actual result (left) versus expected result (right)'.
	stringDiff rightLabel: ''.
	stringDiff leftText: actualObject.
	stringDiff rightText: expectedObject! !

!StFailingAssertionInspector class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newLeftToRight
		  positionOfSlider: 50 percent;
		  add: (SpBoxLayout newTopToBottom
				   add: #actualObjectHeader expand: false;
				   add: #actualObjectMillerList;
				   yourself);
		  add: (SpBoxLayout newTopToBottom
				   add: #expectedObjectHeader expand: false;
				   add: #expectedObjectMillerList;
				   yourself);
		  yourself! !

!StFailingAssertionInspector class methodsFor: 'instance creation' stamp: ''!
diffInspectorsFromActual: actualObject expected: expectedObject application: aStApplication
	| diffPresenter |
	diffPresenter := self basicNew
		application: aStApplication;
		actualObject: actualObject;
		expectedObject: expectedObject;
		initialize.
		
	self flag: 'Not nice but works. This needs improvement.'.
	(actualObject isString and: [ expectedObject isString ])
		ifTrue: [ diffPresenter buildWithSpec: #stringSpec ].
	^ diffPresenter! !

!StFailingAssertionInspector class methodsFor: 'specs' stamp: ''!
stringSpec
	^ SpBoxLayout newTopToBottom
		add: #stringDiff;
		yourself! !

!StFailingAssertionInspectorTest methodsFor: 'tests' stamp: ''!
testDiffForStrings
	|a e inspector|
	a := 'a'.
	e := 'e'.
	inspector := StFailingAssertionInspector
		diffInspectorsFromActual: a
		expected: e
		application: nil.
	self deny: inspector stringDiff equals: nil.
	self assert: inspector actualObjectMillerList equals: nil.
	self assert: inspector expectedObjectMillerList equals: nil.! !

!StFailingAssertionInspectorTest methodsFor: 'tests' stamp: ''!
testDiffForNonStringObjects
	|a e inspector|
	a := 'a'.
	e := 1.
	inspector := StFailingAssertionInspector
		diffInspectorsFromActual: a
		expected: e
		application: nil.
	self deny: inspector actualObjectMillerList equals: nil.
	self deny: inspector expectedObjectMillerList equals: nil.
	self assert: inspector stringDiff equals: nil.
	a := 4.
	e := 1.
	inspector := StFailingAssertionInspector
		diffInspectorsFromActual: a
		expected: e
		application: nil.
	self deny: inspector actualObjectMillerList equals: nil.
	self deny: inspector expectedObjectMillerList equals: nil.
	self assert: inspector stringDiff equals: nil.! !

!StFileOutMethodCommand commentStamp: ''!
Requests the debugger to file out the method of the selected context in the stack!
!StFileOutMethodCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ true! !

!StFileOutMethodCommand methodsFor: 'actions' stamp: ''!
execute
	self debugger fileOutSelectedContext! !

!StFileOutMethodCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ nil! !

!StFileOutMethodCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName
	^ #smallExport! !

!StFileOutMethodCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription
	^ 'Write the source code of the selected method on a file.'! !

!StFileOutMethodCommand class methodsFor: 'accessing' stamp: ''!
defaultName	
	^ 'File out method'! !

!StFilter commentStamp: ''!
I implement the select: operation on the iterator.
I apply the block and filter the elements returned by myself.
!
!StFilter methodsFor: 'accessing' stamp: ''!
next

	| value |

	[ inner atEnd ]
		whileFalse: [ value := inner next.
			(self filter: value)
				ifTrue: [ ^ value ] ].
	^ nil! !

!StFilter methodsFor: 'initialization' stamp: ''!
filter: aValue

	^ aBlock value: aValue! !

!StFilterAlike commentStamp: ''!
Filter "alike" items.
It usues the `String>>#alike:` method to obtain the matching elements. !
!StFilterAlike methodsFor: 'private' stamp: ''!
prepareFilterInContext: aSpotterContext
	super prepareFilterInContext: aSpotterContext.
	
	lowerThreshold ifNil: [ lowerThreshold := self defaultLowerThreshold ]. " performance optimization "
	upperThreshold ifNil: [ upperThreshold := self defaultUpperThreshold ]. " performance optimization "! !

!StFilterAlike methodsFor: 'accessing' stamp: ''!
upperThreshold: anObject
	upperThreshold := anObject! !

!StFilterAlike methodsFor: 'private' stamp: ''!
applyFilterWithQuery
	| allItemsPrepocessed allItemsPrepocessedAndSorted alikeMatches otherMatches upper lower |
	alikeMatches := OrderedCollection  new.
	otherMatches := OrderedCollection new.	
	" calculate the <similarity> of all items and throw away everything that is below the lower threshold (irrelevant) "			
	allItemsPrepocessed := OrderedCollection streamContents: [ :allItems | 
		lower := lowerThreshold * query size.
		self allItemsDo: [ :each | 
			| weight |
			(weight :=  (self itemFilterNameFor: each) alike: query) > lower ifTrue: [
				allItems nextPut: (Array with: weight with: each) ] ] ].
	" sort all items using <similarity> "
	allItemsPrepocessedAndSorted := allItemsPrepocessed asSortedCollection: [ :a :b | a first > b first ].
	" calculate the upper threshold "
	upper := allItemsPrepocessed isEmpty 
		ifTrue: [ upperThreshold ]
		ifFalse: [ (allItemsPrepocessedAndSorted collect: [ :each | each first ]) median " try an adaptive threshold (slow if not presorted) " ].
	" stream all items based on upper and lower threshold "
	allItemsPrepocessedAndSorted do: [ :each | 
		each first >= upper 
			ifTrue: [
				alikeMatches add: each last.
				alikeMatches size > self itemsLimit ifFalse: [ 
					self addItem: each ] ]
			ifFalse:[ otherMatches add: each last ] ].
	" push less relevant matches onto the result "
	(alikeMatches size < self itemsLimit) ifTrue: [ 
		(otherMatches first: ((self itemsLimit - alikeMatches size) min: otherMatches size)) do: [ :each |
			self addItem: each ] ].
	self filteredItems: alikeMatches , otherMatches ! !

!StFilterAlike methodsFor: 'accessing - defaults' stamp: ''!
defaultLowerThreshold
	" lower threshold: to cut off the large irrelevent chunk before sorting/filtering is appplied "
	^ 0.33! !

!StFilterAlike methodsFor: 'accessing - defaults' stamp: ''!
defaultUpperThreshold
	" upper threshold: to keep a reasonably sized set of interesting matches "
	^ 0.45! !

!StFilterAlike methodsFor: 'accessing' stamp: ''!
lowerThreshold
	^ lowerThreshold! !

!StFilterAlike methodsFor: 'accessing' stamp: ''!
upperThreshold
	^ upperThreshold! !

!StFilterAlike methodsFor: 'accessing' stamp: ''!
lowerThreshold: anObject
	lowerThreshold := anObject! !

!StFilterBlock commentStamp: ''!
A filter that evaluates a block to obtain matching items.!
!StFilterBlock methodsFor: 'private' stamp: ''!
isMatchedItem: anItem

	^ self matcher 
		ifNotNil: [ self matcher value: anItem value: self context ]
		ifNil: [ (self itemFilterNameFor: anItem) includesSubstring: query caseSensitive: caseSensitive ]
		! !

!StFilterBlock methodsFor: 'accessing' stamp: ''!
matcher
	^ matcher! !

!StFilterBlock methodsFor: 'accessing' stamp: ''!
matcher: anObject
	matcher := anObject! !

!StFilterFuzzy commentStamp: ''!
A filter that uses the `FuzzyMatcher` to obtain matching items.!
!StFilterFuzzy methodsFor: 'private' stamp: ''!
applyFilterWithQuery
	
	| result |

	result := FuzzyMatcher allSortedByScoreMatching: query 
		in: self allItems
		by: [ :each | self itemFilterNameFor: each ].
	
	self 
		addItems: (result takeFirst: self itemsLimit);
		filteredItems: result
! !

!StFilterImplementor commentStamp: ''!
A filter for implementors. !
!StFilterImplementor methodsFor: 'private - model' stamp: ''!
itemFilterNameFor: each

	self flag: 'this filter wants to filter items by #selector (speed 10x), but dive-in-category wants to filter by #printString. Most filters in dive-in-category wants to filter by #printString, but not all. Others: files, topics, help, ... ?'.
	^ each selector! !

!StFilterImplementor methodsFor: 'private' stamp: ''!
applyFilterWithQuery

	super applyFilterWithQuery.
	self filteredItems: (self filteredItems reject: [ :each | each isFromTrait ])! !

!StFilterImplementor methodsFor: 'public' stamp: ''!
stListFilter

	^ StFilterSubstring new! !

!StFilterImplementor class methodsFor: 'public' stamp: ''!
stListFilter

	^ StFilterSubstring new! !

!StFilterRegex commentStamp: ''!
A filter that executes regex to each item to obtain matching items.!
!StFilterRegex methodsFor: 'private' stamp: ''!
prepareFilterInContext: aSpotterContext
	super prepareFilterInContext: aSpotterContext.
	
	self regex: (caseSensitive " performance optimization "
		ifTrue: [ self query asRegex ] 
		ifFalse: [ self query asRegexIgnoringCase ])! !

!StFilterRegex methodsFor: 'accessing' stamp: ''!
regex
	^ regex! !

!StFilterRegex methodsFor: 'private' stamp: ''!
applyFilterInContext: aSpotterContext error: exception
	
	super applyFilterInContext: aSpotterContext error: exception.
	^ (StFilterSubstrings new
		caseSensitive: self caseSensitive;
		yourself) value: aSpotterContext! !

!StFilterRegex methodsFor: 'accessing' stamp: ''!
regex: anObject
	regex := anObject! !

!StFilterRegex methodsFor: 'private' stamp: ''!
isMatchedItem: anItem
	^ self regex matches: (self itemFilterNameFor: anItem)! !

!StFilterStringMatch commentStamp: ''!
A filter that executes `String>>#match:` to each item to obtain matching items.!
!StFilterStringMatch methodsFor: 'private' stamp: ''!
isMatchedItem: anItem
	^ query match: (self itemFilterNameFor: anItem)! !

!StFilterSubstring commentStamp: ''!
A filter that seaerchs substrings to obtain matching items.!
!StFilterSubstring methodsFor: 'private' stamp: ''!
doApplyFilterWithQuery
	| exactMatches prefixMatches otherMatches nonExactMatches |
	"we want to distinguish between exact matches"
	exactMatches := OrderedCollection new.
	"... results for which the query matches the prefix"
	prefixMatches := OrderedCollection new.	
	"... and the rest of the results"
	otherMatches := OrderedCollection new.

	self allItemsDo: [ :each | 
		| index queryString itemName |
		itemName := self itemFilterNameFor: each.
		queryString := self queryForItem: each.
		index := self indexForItemName: itemName andQuery: queryString.
		index >= 1 ifTrue: [
			index = 1 
				ifTrue: [ 
					itemName size = queryString size 
						ifTrue: [ 
							exactMatches add: each.
							self addItem: each.
														
							exactMatches size = self itemsLimit ifTrue: [ 
								self filteredItems: exactMatches.
								StLimitArrived signal	] ]							
						ifFalse: [ prefixMatches add: each ] ]
				ifFalse: [ otherMatches add: each ] ] ].
	nonExactMatches := prefixMatches, otherMatches.
	(exactMatches size < self itemsLimit) ifTrue: [ 
		| restVisibleItems |
		restVisibleItems := nonExactMatches first: ((self itemsLimit - exactMatches size) min: nonExactMatches size).
		self addItems: restVisibleItems ].
	self filteredItems: exactMatches, nonExactMatches! !

!StFilterSubstring methodsFor: 'private' stamp: ''!
indexForItemName: aString andQuery: aQueryString
	^ aString 
		findString: aQueryString
		startingAt: 1 
		caseSensitive: self caseSensitive! !

!StFilterSubstring methodsFor: 'private' stamp: ''!
queryForItem: each
	^ query " performance optimization "! !

!StFilterSubstrings commentStamp: ''!
A filter that searches for substring to each item to obtain matching items.!
!StFilterSubstrings methodsFor: 'private' stamp: ''!
prepareFilterInContext: aSpotterContext
	super prepareFilterInContext: aSpotterContext.
	
	separators ifNil: [  separators := self defaultSeparators  ]. " performance optimization "
	self query: (self query substrings: self separators) asSet asArray! !

!StFilterSubstrings methodsFor: 'private' stamp: ''!
isMatchedItem: anItem
	| itemName |
	itemName := self itemFilterNameFor: anItem.
	^ query allSatisfy: [ :fragment | 
		itemName includesSubstring: fragment caseSensitive: self caseSensitive ]! !

!StFilterSubstrings methodsFor: 'accessing - defaults' stamp: ''!
defaultSeparators
	^ ' '! !

!StFilterSubstrings methodsFor: 'accessing' stamp: ''!
separators: anObject
	separators := anObject! !

!StFilterSubstrings methodsFor: 'accessing' stamp: ''!
separators
	^ separators! !

!StFuelOutStackCommand commentStamp: ''!
Serializes a portion of the current stack trace using fuel.!
!StFuelOutStackCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ true! !

!StFuelOutStackCommand methodsFor: 'actions' stamp: ''!
execute
	FLDebuggerStackSerializer serializeStackFromContext: self context interruptedContext! !

!StFuelOutStackCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ nil! !

!StFuelOutStackCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName
	^ #smallExport! !

!StFuelOutStackCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription
	^ 'Serialize a portion of the current stack trace using fuel.'! !

!StFuelOutStackCommand class methodsFor: 'accessing' stamp: ''!
defaultName	
	^ 'Fuel out stack'! !

!StGeneratorBlockIterator commentStamp: ''!
I wrap a block and expose it as an iterator!
!StGeneratorBlockIterator methodsFor: 'accessing' stamp: ''!
block
	^ block! !

!StGeneratorBlockIterator methodsFor: 'accessing' stamp: ''!
block: anObject
	block := anObject! !

!StGeneratorBlockIterator methodsFor: 'enumerating' stamp: ''!
elementsDo: aValuable

	block value: aValuable! !

!StGeneratorBlockIterator class methodsFor: 'instance creation' stamp: ''!
on: aBlock

	^ self basicNew
		block: aBlock;
		initialize;
		yourself! !

!StGeneratorBlockIteratorTest methodsFor: 'tests' stamp: ''!
testIteratorOnACalculatedCollectionReturnsOnlyFirst

	| it m |
	 
	it := StGeneratorBlockIterator on: [ :aBlock | 
		SystemNavigation default allBehaviorsDo: [ :e | e methodsDo: aBlock ] ].	
	
	m := it next.
	
	self assert: m isNotNil.
	self assert: m isCompiledMethod.	! !

!StGeneratorBlockIteratorTest methodsFor: 'tests' stamp: ''!
testIteratorWithInfiniteBlockOnlyCallFirstTimes
	| it count |
	
	count := 1. 
	it := StGeneratorBlockIterator on: [ :aBlock | [aBlock value: count. count := count + 1] repeat ].
	it next: 4.
	self assert: count equals: 5.! !

!StGeneratorBlockIteratorTest methodsFor: 'tests' stamp: ''!
testIteratorWithSingleElementIsAtEndAfterNext
	| it |
	 
	it := StGeneratorBlockIterator on: [ :aBlock | aBlock value: 1 ].	
	it next.
	self assert: it atEnd.! !

!StGeneratorBlockIteratorTest methodsFor: 'tests' stamp: ''!
testIteratorWithEmptyBlockIsAtEnd
	| it |
	
	it := StGeneratorBlockIterator on: [ :aBlock |  ].
	self assert: it atEnd.! !

!StGeneratorBlockIteratorTest methodsFor: 'tests' stamp: ''!
testIteratorWithInfiniteBlockNotCallIfNotUsed
	| it count |
	
	count := 0. 
	it := StGeneratorBlockIterator on: [ :aBlock | [aBlock value: count. count := count + 1] repeat ].	
	self assert: count equals: 0.! !

!StGeneratorIteratorTest methodsFor: 'tests' stamp: ''!
testCollectionWithSingleManyElementsReturnsTheRequested
	| gen |
	
	gen := StCollectionIterator on: #(1 2 3 4 5 6 7 8 9 10).
	
	self assert: gen next equals: 1.
	self assert: gen next equals: 2.
	self assert: gen next equals: 3.! !

!StGeneratorIteratorTest methodsFor: 'tests' stamp: ''!
testEmptyCollectionIsAtEnd
	| gen |
	
	gen := StCollectionIterator on: #().
	self assert: gen atEnd! !

!StGeneratorIteratorTest methodsFor: 'tests' stamp: ''!
testCollectionWithSingleElementReturnsIt
	| gen |
	
	gen := StCollectionIterator on: #(1).
	self assert: gen next equals: 1! !

!StGeneratorIteratorTest methodsFor: 'tests' stamp: ''!
testCollectionWithSingleManyElementsReturnsTheRequestedInCollection
	| gen |
	
	gen := StCollectionIterator on: #(1 2 3 4 5 6 7 8 9 10).
	self assertCollection: (gen next:3) hasSameElements: #(1 2 3).
! !

!StGeneratorIteratorTest methodsFor: 'tests' stamp: ''!
testCollectionWithSingleWithALotOfElementsReturnsTheRequestedInCollection
	| gen |
	
	gen := StCollectionIterator on: (1 to: 10**99).
	self assertCollection: (gen next:3) hasSameElements: #(1 2 3).
! !

!StGeneratorIteratorTest methodsFor: 'tests' stamp: ''!
testResetRestartsIterationOnTheCollection
	| gen |
	
	gen := StCollectionIterator on: #(1 2 3 4 5 6 7 8 9 10).
	
	self assertCollection: (gen next:3) hasSameElements: #(1 2 3).
	gen reset.
	self assertCollection: (gen next:3) hasSameElements: #(1 2 3).
	! !

!StGenericGenerator commentStamp: ''!
I wrap a generator to provide the same API than the iterators.
My subclasses should implement #elementsDo: to iterate the collection or implement the values.
In this method, each of the generated values should be used with the valuable pased.


Ex:
elementsDo: aValuable
	[ true ] whileTrue: [ aValuable value: 42  ].
	
This example generates an infinite iterator always returning 42.
Using the generator will produce that the method is only executed on demand.

This Iterator can also wrap collections, iterating one element at the time.

Ex:
elementsDo: aValuable
	SystemNavigation default allBehaviorsDo: aValuable!
!StGenericGenerator methodsFor: 'enumerating' stamp: ''!
elementsDo: aValuable

	^ self subclassResponsibility! !

!StGenericGenerator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self reset! !

!StGenericGenerator methodsFor: 'accessing' stamp: ''!
next

	^ generator next! !

!StGenericGenerator methodsFor: 'protected' stamp: ''!
doReset
	generator := Generator on: [ :aGenerator | 
		self elementsDo: [ :each | aGenerator yield: each ] ]! !

!StGenericGenerator methodsFor: 'initialization' stamp: ''!
next: aQuantity

	^ generator next: aQuantity! !

!StGenericGenerator methodsFor: 'testing' stamp: ''!
atEnd 

	^ generator atEnd! !

!StGenericGenerator class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == StGenericGenerator! !

!StHaltAndBreakpointControlTest methodsFor: 'running' stamp: ''!
tearDown
	StHaltCache defaultCache updateSubscriptions.
	cache removeSubscriptions.
	cache := nil.
	self removeMethodsWithHalts.
	super tearDown! !

!StHaltAndBreakpointControlTest methodsFor: 'helpers' stamp: ''!
compileMethodsWithHalts
	self methodWithHaltSources
		do: [ :source | self testClass compile: source ]! !

!StHaltAndBreakpointControlTest methodsFor: 'helpers' stamp: ''!
removeMethodsWithHalts
	self testClass methods
		do: [ :method | self testClass removeSelector: method selector]! !

!StHaltAndBreakpointControlTest methodsFor: 'helpers' stamp: ''!
methodWithHaltSources
	| sources |
	sources := OrderedCollection new.
	sources add: 'mHalt self halt'.
	sources add: 'mHaltIf self haltIf: [true]'.
	sources add: 'mHalt: arg self halt: arg'.
	sources add: 'mHaltOnce self haltOnce'.
	sources add: 'mHaltOnCount: n self haltOnCount: n'.
	sources add: 'mHaltIfNil self haltIfNil'.
	sources add: 'mNoHalt ^self printString'.	
	sources add: 'mRejectHalt self haltOnAccessTo. self haltOnRead. self haltOnWrite. self haltOnAccess.'.
	^sources! !

!StHaltAndBreakpointControlTest methodsFor: 'accessing' stamp: ''!
testClass
	^ StDummyTestClassWithHalts! !

!StHaltAndBreakpointControlTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	StHaltCache defaultCache removeSubscriptions.	
	cache := StHaltCache new.
	cache isActive: true.
	self compileMethodsWithHalts.! !

!StHaltAndBreakpointController commentStamp: ''!
I provide control over halts messages and breakpoints for activating and deactivating them.
I also tell if a program node has active breakpoints or halts on it.!
!StHaltAndBreakpointController methodsFor: 'links' stamp: ''!
disableHaltLink: control
	^ MetaLink new
		metaObject: self class;
		selector: #skipHaltNode:;
		arguments: #(node);
		control: control;
		yourself! !

!StHaltAndBreakpointController methodsFor: 'API' stamp: ''!
isHaltOrBreakpointEnabled: aStBreakpointInspectionItem 
	^aStBreakpointInspectionItem isEnabledInContext: self! !

!StHaltAndBreakpointController methodsFor: 'control' stamp: ''!
skipNode: aNode
	(self isHaltEnabledFor: aNode)
		ifFalse: [ ^ self ].
	aNode enableHalts: false.
	self installSkipLinkOn: aNode! !

!StHaltAndBreakpointController methodsFor: 'API' stamp: ''!
enableHaltNode: aMessageNode
	self removeSkipLinksFor: aMessageNode.
	aMessageNode enableHalts: true! !

!StHaltAndBreakpointController methodsFor: 'API' stamp: ''!
isBreakpointEnabled: aBreakpoint 
	^aBreakpoint isEnabled! !

!StHaltAndBreakpointController methodsFor: 'API' stamp: ''!
enableBreakpoint: aBreakpoint

	aBreakpoint enable! !

!StHaltAndBreakpointController methodsFor: 'API' stamp: ''!
disableHaltOrBreakpointFor: haltOrBreakpointItem

	haltOrBreakpointItem disableInContext: self! !

!StHaltAndBreakpointController methodsFor: 'API' stamp: ''!
enableHaltOrBreakpointFor: haltOrBreakpointItem

	haltOrBreakpointItem enableInContext: self! !

!StHaltAndBreakpointController methodsFor: 'API' stamp: ''!
disableBreakpoint: aBreakpoint

	aBreakpoint disable! !

!StHaltAndBreakpointController methodsFor: 'links' stamp: ''!
removeSkipLinksFor: aNode
	(aNode links
		select:
			[ :link | link control = #instead and: [ link metaObject == self class ] ])
		do: [ :link | link uninstall ]! !

!StHaltAndBreakpointController methodsFor: 'API' stamp: ''!
disableHaltNode: aMessageNode
	self skipNode: aMessageNode.
	aMessageNode enableHalts: false! !

!StHaltAndBreakpointController methodsFor: 'links' stamp: ''!
installSkipLinkOn: aMessageNode
	| control |
	control := aMessageNode isReturn
		ifTrue: [ #before ]
		ifFalse: [ #instead ].
	aMessageNode link: (self disableHaltLink: control)! !

!StHaltAndBreakpointController methodsFor: 'API' stamp: ''!
isHaltEnabledFor: aProgramNode
	^ aProgramNode enabledForHaltOrBreakpoint! !

!StHaltAndBreakpointController methodsFor: 'API' stamp: ''!
isHaltNodeEnabled: aRBMessageNode 
	^aRBMessageNode enabledForHaltOrBreakpoint! !

!StHaltAndBreakpointController class methodsFor: 'Helpers' stamp: ''!
tracer: aTracer
	tracer := aTracer! !

!StHaltAndBreakpointController class methodsFor: 'Helpers' stamp: ''!
printSkipTextFor: aProgramNode
	^ aProgramNode methodNode source asText
		makeBoldFrom: aProgramNode start to: aProgramNode stop;
		yourself! !

!StHaltAndBreakpointController class methodsFor: 'API' stamp: ''!
skipHaltNode: aProgramNode
	self trace: (self printSkipTextFor: aProgramNode)! !

!StHaltAndBreakpointController class methodsFor: 'Helpers' stamp: ''!
trace: aTextOrString
	self tracer crTrace: aTextOrString! !

!StHaltAndBreakpointController class methodsFor: 'Helpers' stamp: ''!
tracer
	^ tracer ifNil: [ tracer := Transcript ]! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - halts' stamp: ''!
testDisabledHaltIsDisabled

	haltController disableHaltNode: self node.
	self deny: (haltController isHaltEnabledFor: self node).
	self deny: (haltController isHaltOrBreakpointEnabled:
			 (StHaltInspectionItem forHalt: self node))! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - breakpoints' stamp: ''!
testNoTraceForEnabledBreakpoint
	[ testObject mNoHalt ]
		on: Halt
		do: [ :e | e resume ].
	self assert: trace isNil! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - breakpoints' stamp: ''!
testDisabledBreakpointisDisabled

	haltController disableBreakpoint: breakpoint.
	self deny: (haltController isBreakpointEnabled: breakpoint).
	self deny: (haltController isHaltOrBreakpointEnabled:
			 (StBreakpointInspectionItem forBreakpoint: breakpoint))! !

!StHaltAndBreakpointControllerTest methodsFor: 'running' stamp: ''!
tearDown
	trace := nil.
	StHaltAndBreakpointController tracer: oldTracer.
	breakpoint ifNotNil: [ breakpoint remove ].
	super tearDown! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - halts' stamp: ''!
testDisableHalt
	
	self should: [ testObject mHalt ] raise: Halt.	
	haltController disableHaltNode: self node.
	self shouldnt: [ testObject mHalt ] raise: Halt! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - halts' stamp: ''!
testTraceForDisabledHalt
	haltController disableHaltNode: self node.
	testObject mHalt.
	self
		assert: trace
		equals: (StHaltAndBreakpointController printSkipTextFor: self node)! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - halts' stamp: ''!
testNoTraceForEnabledHalt
	[ testObject mHalt ]
		on: Halt
		do: [ :e | e resume ].
	self assert: trace isNil! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - breakpoints' stamp: ''!
testEnabledBreakpointIsEnabled

	self assert: (haltController isBreakpointEnabled: breakpoint).
	self assert: (haltController isHaltOrBreakpointEnabled:
			 (StBreakpointInspectionItem forBreakpoint: breakpoint))! !

!StHaltAndBreakpointControllerTest methodsFor: 'helper' stamp: ''!
node
	^ (cache nodeCacheForSelector: 'StDummyTestClassWithHalts>>#mHalt') first ! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - breakpoints' stamp: ''!
testDisableBreakpoint
	self should: [ testObject mNoHalt ] raise: Break.
	haltController disableBreakpoint: breakpoint.
	self shouldnt: [ testObject mNoHalt ] raise: Break
	! !

!StHaltAndBreakpointControllerTest methodsFor: 'helper' stamp: ''!
crTrace: aTextOrString
	trace := aTextOrString ! !

!StHaltAndBreakpointControllerTest methodsFor: 'helper' stamp: ''!
installBreakpointOn: aNode
	^ Breakpoint new
		node: aNode;
		install;
		yourself! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - halts' stamp: ''!
testEnableDisabledHalt	
	haltController disableHaltNode: self node.
	self shouldnt: [ testObject mHalt ] raise: Halt.
	haltController enableHaltNode: self node.
	self should: [ testObject mHalt ] raise: Halt! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - halts' stamp: ''!
testEnabledHaltIsEnabled
	self assert: (haltController isHaltEnabledFor: self node)! !

!StHaltAndBreakpointControllerTest methodsFor: 'tests - breakpoints' stamp: ''!
testEnableDisabledBreakpoint
	haltController disableBreakpoint: breakpoint.
	self shouldnt: [ testObject mNoHalt ] raise: Break.
	haltController enableBreakpoint: breakpoint.
	self should: [ testObject mNoHalt ] raise: Break! !

!StHaltAndBreakpointControllerTest methodsFor: 'helper' stamp: ''!
nodeForBreakpoint
	^ (StDummyTestClassWithHalts >> #mNoHalt) ast statements first! !

!StHaltAndBreakpointControllerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	testObject := StDummyTestClassWithHalts new.
	haltController := StHaltAndBreakpointController new.
	oldTracer := StHaltAndBreakpointController tracer.
	StHaltAndBreakpointController tracer: self.
	breakpoint := self installBreakpointOn: self nodeForBreakpoint! !

!StHaltBreakpointInspectionItemTest methodsFor: 'tests - initialization' stamp: ''!
testNewVariableBreakpointItem
	|bp item|
	bp := self variableBreakpoint.
	item := StHaltInspectionItem forBreakpoint: bp.
	self assert: item breakpoint identicalTo: bp. 
	self assert: item node isNil.
	self assert: item interval isNil.
	self assert: item scope identicalTo: bp targetClassOrMethod.
	self assertCollection: item displayEntity equals: bp.
	self assert: item type equals: Break printString! !

!StHaltBreakpointInspectionItemTest methodsFor: 'running' stamp: ''!
tearDown

	self removeHaltNode.
	StHaltCache defaultCache updateSubscriptions.
	super tearDown! !

!StHaltBreakpointInspectionItemTest methodsFor: 'helpers' stamp: ''!
haltNode

	^ (StDummyTestClassWithHalts >> #mHalt) ast statements first! !

!StHaltBreakpointInspectionItemTest methodsFor: 'tests - initialization' stamp: ''!
testNewHaltItem
	|item|
	item := StHaltInspectionItem forHalt: self haltNode.
	self assert: item node identicalTo: self haltNode.
	self assert: item interval equals: (self haltNode start to: self haltNode stop).
	self assert: item scope identicalTo: self haltNode methodNode method methodClass.
	self assert: item displayEntity identicalTo: self haltNode methodNode.
	self assert: item type equals: Halt name asString! !

!StHaltBreakpointInspectionItemTest methodsFor: 'tests - initialization' stamp: ''!
testNewObjectCentricVariableBreakpointItem
	|bp item|
	bp := self variableBreakpoint.
	bp scopeTo: self.
	item := StHaltInspectionItem forBreakpoint: bp.
	self assert: item scope identicalTo: self! !

!StHaltBreakpointInspectionItemTest methodsFor: 'tests - printing' stamp: ''!
testPrintVariableBreakpointItem

	| bp item |
	bp := self variableBreakpoint.
	item := StHaltInspectionItem forBreakpoint: bp.
	self assert: item printContents equals: bp printContentsForBreakpointInspection.
	self assert: item printEntity equals: bp printTargetForBreakpointInspection.
	self assert: item printScope equals: bp targetClassOrMethod printString.
	
	self flag: 'This is not super nice...'.
	"If the breakpoint is scoped to an object, it should show 'self' in that object's inspector.
	This has no meaning outside the inspected object."	
	bp scopeTo: Object new.
	self assert: item printScope equals: 'self'.! !

!StHaltBreakpointInspectionItemTest methodsFor: 'tests - initialization' stamp: ''!
testNewObjectCentricBreakpointItem
	|bp item|
	bp := self breakpoint.
	bp scopeTo: self.
	item := StHaltInspectionItem forBreakpoint: bp.
	self assert: item scope identicalTo: self! !

!StHaltBreakpointInspectionItemTest methodsFor: 'tests - printing' stamp: ''!
testPrintHaltItem

	|item|
	item := StHaltInspectionItem forHalt: self haltNode.
	self assert: item printContents equals: self haltNode methodNode sourceCode.
	self assert: item printEntity equals: self haltNode methodNode method printString.
	self assert: item printScope equals: self haltNode methodNode methodClass printString! !

!StHaltBreakpointInspectionItemTest methodsFor: 'tests - printing' stamp: ''!
testPrintBreakpointItem

	|bp item|
	bp := self breakpoint.
	item := StHaltInspectionItem forBreakpoint: bp.
	self assert: item printContents equals: bp node methodNode sourceCode.
	self assert: item printEntity equals: bp printTargetForBreakpointInspection.
	self assert: item printScope equals: bp node methodNode methodClass printString.
	
	self flag: 'This is not super nice...'.
	"If the breakpoint is scoped to an object, it should show 'self' in that object's inspector.
	This has no meaning outside the inspected object."	
	bp scopeTo: Object new.
	self assert: item printScope equals: 'self'.! !

!StHaltBreakpointInspectionItemTest methodsFor: 'helpers' stamp: ''!
removeHaltNode

	StDummyTestClassWithHalts removeSelector: #mHalt! !

!StHaltBreakpointInspectionItemTest methodsFor: 'helpers' stamp: ''!
breakpoint

	^ Breakpoint new node:
		  (StDummyTestClassWithHalts >> #mHalt) ast statements first! !

!StHaltBreakpointInspectionItemTest methodsFor: 'helpers' stamp: ''!
compileHaltNode

	StDummyTestClassWithHalts compile: 'mHalt self halt'.! !

!StHaltBreakpointInspectionItemTest methodsFor: 'tests - initialization' stamp: ''!
testNewBreakpointItem
	|bp item|
	bp := self breakpoint.
	item := StHaltInspectionItem forBreakpoint: bp.
	self assert: item breakpoint identicalTo: bp. 
	self assert: item node identicalTo: bp node.
	self assert: item interval equals: (bp node start to: bp node stop).
	self assert: item scope identicalTo: bp node methodNode method methodClass.
	self assert: item displayEntity identicalTo: bp.
	self assert: item type equals: Break printString! !

!StHaltBreakpointInspectionItemTest methodsFor: 'helpers' stamp: ''!
variableBreakpoint

	^ StDummyTestClassWithHalts newBreakpointForVariable: #var! !

!StHaltBreakpointInspectionItemTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	StHaltCache defaultCache removeSubscriptions.	
	self compileHaltNode.! !

!StHaltCache commentStamp: ''!
I cache all message nodes that are halts in the system. 
There is already a breakpoint cache in the Breakpoint class.

The cache is built when I am initialized,  then I register to the method changes system announcement to update the cache each time a method is added, modified or removed.

I associate the selector of methods in which I found halts to a set holding the AST nodes of those halts.

For now it is a simple cache that does not require as much functionality than AbstractCache provides, so it does not subclass it.
However, it might be interesting if I evolve later, or if I need safe concurrent access (which AbstractCache provides).

By default, the cache does not lookup halts in all the system's methods. This can be enabled in a settings under tools>debugging>halt cache. The cache must be refreshed to effectively perform the lookup (StHaltCache refresh).!
!StHaltCache methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!StHaltCache methodsFor: 'accessing' stamp: ''!
scanAllSystem
	^scanAllSystem ifNil:[scanAllSystem := false] ! !

!StHaltCache methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!StHaltCache methodsFor: 'cache' stamp: ''!
refreshCache
	self buildCache! !

!StHaltCache methodsFor: 'cache' stamp: ''!
buildCache
	self scanAllSystem ifFalse:[^self].
	SystemNavigation new allHalts
		do: [ :compiledMethod | self buildCacheForMethod: compiledMethod ]! !

!StHaltCache methodsFor: 'cache' stamp: ''!
uncacheMethod: aMethodSelector
	"Methods not in the cache are irrelevant, so we don't care if they are absent from the dictionary"

	(methodsWithHalts keys includes: aMethodSelector)
		ifFalse: [ ^ self ].
	methodsWithHalts removeKey: aMethodSelector.
	self cacheChanged! !

!StHaltCache methodsFor: 'notifying' stamp: ''!
methodAdded: methodAddedAnnouncement
	self buildCacheForMethod: methodAddedAnnouncement methodAdded! !

!StHaltCache methodsFor: 'accessing' stamp: ''!
scanAllSystem: aBoolean
	scanAllSystem := aBoolean! !

!StHaltCache methodsFor: 'cache' stamp: ''!
cacheNode: aNode forSelector: aMethodSelector
	(methodsWithHalts at: aMethodSelector ifAbsentPut: IdentitySet new)
		add: aNode! !

!StHaltCache methodsFor: 'testing' stamp: ''!
shouldConsiderMethod: aCompiledMethod

	"We do not consider test or debugging methods"

	^ #( #haltOrBreakpointForTesting #haltOrBreakpointForDevelopment
	     #debuggerCompleteToSender ) noneSatisfy: [ :pragmaName | 
		  aCompiledMethod hasPragmaNamed: pragmaName ]! !

!StHaltCache methodsFor: 'cache' stamp: ''!
setNodeCache: haltAndBreakpointNodes forSelector: aSelector
	methodsWithHalts at: aSelector put: haltAndBreakpointNodes! !

!StHaltCache methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!StHaltCache methodsFor: 'accessing' stamp: ''!
methodsWithHalts
	^ methodsWithHalts! !

!StHaltCache methodsFor: 'testing' stamp: ''!
shouldConsiderHaltNode: aNode
	| selector shouldRejectNode |
	selector := aNode selector.
	shouldRejectNode := ('*haltOnRead*' match: selector)
		or: [ ('*haltOnWrite*' match: selector)
				or: [ '*haltOnAccess*' match: selector ] ].
	^ shouldRejectNode not and: [ 'halt*' match: selector ]! !

!StHaltCache methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!StHaltCache methodsFor: 'accessing' stamp: ''!
isActive
	^ isActive ifNil: [ isActive := false ]! !

!StHaltCache methodsFor: 'initialization' stamp: ''!
initialize
	methodsWithHalts := Dictionary new.
	self buildCache.
	self class initializeSlots: self.
	self property: #isActive whenChangedDo: [ self updateSubscriptions ]! !

!StHaltCache methodsFor: 'notifying' stamp: ''!
cacheChanged
	SystemAnnouncer uniqueInstance announce: StHaltCacheChanged! !

!StHaltCache methodsFor: 'system subscription' stamp: ''!
registerSubscriptions
	SystemAnnouncer uniqueInstance weak when: MethodModified send: #methodChanged: to: self.
	SystemAnnouncer uniqueInstance weak when: MethodRemoved send: #methodRemoved: to: self.
	SystemAnnouncer uniqueInstance weak when: MethodAdded send: #methodAdded: to: self! !

!StHaltCache methodsFor: 'cache' stamp: ''!
nodeCacheForSelector: aMethodSelector
	^ methodsWithHalts at: aMethodSelector ifAbsent: #()! !

!StHaltCache methodsFor: 'system subscription' stamp: ''!
updateSubscriptions
	self isActive ifTrue: [ ^ self registerSubscriptions ].
	^ self removeSubscriptions! !

!StHaltCache methodsFor: 'system subscription' stamp: ''!
removeSubscriptions
	SystemAnnouncer uniqueInstance unsubscribe: self! !

!StHaltCache methodsFor: 'cache' stamp: ''!
buildCacheForMethod: aCompiledMethod
	"- extract all halt nodes from the method's ast
	- extract all nodes with installed breakpoints from the method's ast
	- cache all extracted nodes into the methodsWithHalts dictionary"

	| ast haltNodes |
	(self shouldConsiderMethod: aCompiledMethod)
		ifFalse: [ ^ self ].
	ast := aCompiledMethod ast.
	haltNodes := ast sendNodes
		select: [ :node | self shouldConsiderHaltNode: node ].
	haltNodes
		ifEmpty: [ self uncacheMethod: aCompiledMethod printString.
			^ self ].
	self setNodeCache: haltNodes forSelector: aCompiledMethod printString.
	self cacheChanged! !

!StHaltCache methodsFor: 'notifying' stamp: ''!
methodRemoved: methodRemovedAnnouncement
	self uncacheMethod: methodRemovedAnnouncement methodRemoved printString! !

!StHaltCache methodsFor: 'notifying' stamp: ''!
methodChanged: methodCModifiedAnnouncement
	self buildCacheForMethod: methodCModifiedAnnouncement newMethod! !

!StHaltCache methodsFor: 'accessing' stamp: ''!
isActive: aBoolean
	isActive := aBoolean! !

!StHaltCache class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!StHaltCache class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!StHaltCache class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!StHaltCache class methodsFor: 'accessing - cache' stamp: ''!
refresh
	<script>
	self defaultCache refreshCache! !

!StHaltCache class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!StHaltCache class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!StHaltCache class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!StHaltCache class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!StHaltCache class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!StHaltCache class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!StHaltCache class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!StHaltCache class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!StHaltCache class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!StHaltCache class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!StHaltCache class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!StHaltCache class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!StHaltCache class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!StHaltCache class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!StHaltCache class methodsFor: 'accessing - cache' stamp: ''!
defaultCache
	^ DefaultCache ifNil: [ DefaultCache := self new ]! !

!StHaltCache class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!StHaltCache class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!StHaltCache class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!StHaltCache class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!StHaltCache class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!StHaltCache class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	DefaultCache
		ifNotNil: [ DefaultCache removeSubscriptions.
			DefaultCache := nil ]! !

!StHaltCache class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!StHaltCache class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!StHaltCache class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!StHaltCache class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!StHaltCache class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!StHaltCache class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!StHaltCache class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!StHaltCache class methodsFor: 'settings' stamp: ''!
haltCacheSettingsOn: aBuilder
	<systemsettings>
	(aBuilder group: #haltcache)
		label: 'Halt Cache';
		parent: #debugging;
		description: 'Halt cache settings';
		with: [ 
			(aBuilder setting: #scanAllSystem)
				label:
					'Perform a system-wide lookup to find all halts and breakpoints';
				target: self defaultCache;
				default: false;
				description:
					'If true, then the halt cache will check for halts in all methods from the system. 
This can be slow for large systems (with lots of methods).' ];
		with: [ 
			(aBuilder setting: #isActive)
				label: 'Subscribe to method changes';
				target: self defaultCache;
				default: false;
				description:
					'Activates or deactivate system subscriptions to method changes. 
If deactivated, the list of halts will not be updated in the debugging tools browsers.' ]! !

!StHaltCacheChanged commentStamp: ''!
Simple announcement to signal any update in the halt cache!
!StHaltCacheTest methodsFor: 'tests - halts cache' stamp: ''!
testMethodWithHaltRemoval
	|methodCacheForSimpleHalt |
	methodCacheForSimpleHalt := cache methodsWithHalts size.
	
	self testClass removeSelector: #mHalt.	
	self assert: cache methodsWithHalts size equals: methodCacheForSimpleHalt - 1.
	self assert: 
		(cache methodsWithHalts keys select:[:methodSelector| methodSelector = 'StDummyTestClassWithHalts>>#mHalt']) isEmpty! !

!StHaltCacheTest methodsFor: 'tests - cache building' stamp: ''!
testScanAllSystemDisabled
	|newCache|
	newCache := StHaltCache new.
	self assert: newCache methodsWithHalts isEmpty! !

!StHaltCacheTest methodsFor: 'tests - cache building' stamp: ''!
testRefreshCacheWithScanAllSystem
	|newCache|
	newCache := StHaltCache new.
	newCache scanAllSystem: true.
	newCache refreshCache.
	self assert: cache methodsWithHalts size >= 6! !

!StHaltCacheTest methodsFor: 'tests - halts cache' stamp: ''!
testRemoveAllHaltsFromMethod
	| methodCacheForSimpleHalt |
	methodCacheForSimpleHalt := cache methodsWithHalts size.
	self testClass compile: 'mHalt ^self'.
	self
		assert: cache methodsWithHalts size
		equals: methodCacheForSimpleHalt - 1.
	self
		assert:
			(cache methodsWithHalts keys
				select:
					[ :methodSelector | methodSelector = 'StDummyTestClassWithHalts>>#mHalt' ])
				isEmpty! !

!StHaltCacheTest methodsFor: 'tests - cache building' stamp: ''!
testScanAllSystemEnabled
	|newCache|
	newCache := StHaltCache basicNew.
	newCache scanAllSystem: true.
	newCache initialize.
	self assert: cache methodsWithHalts size >= 6! !

!StHaltCacheTest methodsFor: 'tests - cache building' stamp: ''!
testRefreshCacheWithoutScanAllSystem
	|newCache|
	newCache := StHaltCache new.
	newCache refreshCache.
	self assert: newCache methodsWithHalts isEmpty! !

!StHaltCacheTest methodsFor: 'tests - halts cache' stamp: ''!
testAddingHaltToMethod
	| nodeCacheForSimpleHalt originalNodeCacheSize |
	nodeCacheForSimpleHalt := cache
		nodeCacheForSelector: 'StDummyTestClassWithHalts>>#mHalt'.
	originalNodeCacheSize := nodeCacheForSimpleHalt size.
	self testClass compile: 'mHalt self halt. self halt'.
	nodeCacheForSimpleHalt := cache
		nodeCacheForSelector: 'StDummyTestClassWithHalts>>#mHalt'.
	self
		assert: nodeCacheForSimpleHalt size
		equals: originalNodeCacheSize + 1.
	(self testClass >> #mHalt) ast statements
		do: [ :node | self assert: (nodeCacheForSimpleHalt includes: node) ].
	self
		assert:
			(cache methodsWithHalts keys
				select:
					[ :methodSelector | methodSelector = 'StDummyTestClassWithHalts>>#mHalt' ])
				size
		equals: 1! !

!StHaltCacheTest methodsFor: 'tests - halts cache' stamp: ''!
testNewMethodWithHalt
	|methodCacheForSimpleHalt haltNode|
	methodCacheForSimpleHalt := cache methodsWithHalts size.
	
	self testClass compile: 'mHalt2 self halt.'.	
	haltNode := (self testClass>>#mHalt2) ast statements first.	
	
	self assert: cache methodsWithHalts size equals: methodCacheForSimpleHalt + 1.
	self assert: (cache nodeCacheForSelector: 'StDummyTestClassWithHalts>>#mHalt2') size equals: 1.
	self assert: (cache nodeCacheForSelector: 'StDummyTestClassWithHalts>>#mHalt2') asOrderedCollection first identicalTo: haltNode.
! !

!StHaltCacheTest methodsFor: 'tests - cache initialization' stamp: ''!
testCacheDectivation
	cache removeSubscriptions.
	cache := StHaltCache new.
	cache isActive: true.
	self assert: (SystemAnnouncer uniqueInstance hasSubscriber: cache).
	cache isActive: false.
	self deny: (SystemAnnouncer uniqueInstance hasSubscriber: cache) ! !

!StHaltCacheTest methodsFor: 'tests - cache initialization' stamp: ''!
testCacheActivation
	cache removeSubscriptions.
	cache := StHaltCache new.
	cache isActive: true.
	self assert: cache isActive.
	self assert: (SystemAnnouncer uniqueInstance hasSubscriber: cache) ! !

!StHaltCacheTest methodsFor: 'tests - cache building' stamp: ''!
testInitialCacheBuild
	self assert: cache methodsWithHalts size equals: 6.
	(self testClass methods
		reject: [ :m | 
			#('StDummyTestClassWithHalts>>#mNoHalt' 'StDummyTestClassWithHalts>>#mRejectHalt')
				includes: m printString ])
		do: [ :method | 
			| haltNode nodeCache |
			haltNode := method ast statements first.
			self
				assert: (cache methodsWithHalts keys includes: method printString).
			nodeCache := cache nodeCacheForSelector: method printString.
			self assert: nodeCache size equals: 1.
			self
				assert: nodeCache asOrderedCollection first
				identicalTo: haltNode ]! !

!StHaltCacheTest methodsFor: 'tests - halts cache' stamp: ''!
testShouldConsiderHaltNode
	| node |
	node := RBMessageNode receiver: RBVariableNode selfNode selector: #haltOnAccessTo.
	self deny: (cache shouldConsiderHaltNode: node).
		
	node := RBMessageNode receiver: RBVariableNode selfNode selector: #haltOnRead.
	self deny: (cache shouldConsiderHaltNode: node).
	
	node := RBMessageNode receiver: RBVariableNode selfNode selector: #haltOnWrite.
	self deny: (cache shouldConsiderHaltNode: node).
	
	node := RBMessageNode receiver: RBVariableNode selfNode selector: #haltOnAccess.
	self deny: (cache shouldConsiderHaltNode: node).
	
	node := RBMessageNode receiver: RBVariableNode selfNode selector: #mhalt.
	self deny: (cache shouldConsiderHaltNode: node).
	
	node := RBMessageNode receiver: RBVariableNode selfNode selector: #halt.
	self assert: (cache shouldConsiderHaltNode: node).
	
	node := RBMessageNode receiver: RBVariableNode selfNode selector: #haltOnce.
	self assert: (cache shouldConsiderHaltNode: node).
	
	node := RBMessageNode receiver: RBVariableNode selfNode selector: #haltIf.
	self assert: (cache shouldConsiderHaltNode: node).
	
	node := RBMessageNode receiver: RBVariableNode selfNode selector: #haltOnCallTo.
	self assert: (cache shouldConsiderHaltNode: node).
	
	! !

!StHaltCacheTest methodsFor: 'tests - cache initialization' stamp: ''!
testInitialActivation
	cache := StHaltCache new.
	self deny: cache isActive.
	self deny: (SystemAnnouncer uniqueInstance hasSubscriber: cache) ! !

!StHaltInspectionItem commentStamp: ''!
I am a data holder for halts and breakpoints to be displayed in StObjectBreakpointInspection tables.!
!StHaltInspectionItem methodsFor: 'accessing' stamp: ''!
node: anObject
	node := anObject! !

!StHaltInspectionItem methodsFor: 'accessing' stamp: ''!
scope: anObject
	scope := anObject! !

!StHaltInspectionItem methodsFor: 'control' stamp: ''!
isEnabledInContext: aStHaltAndBreakpointController 
	^aStHaltAndBreakpointController isHaltNodeEnabled: node! !

!StHaltInspectionItem methodsFor: 'printing' stamp: ''!
printContents
	^displayEntity sourceCode! !

!StHaltInspectionItem methodsFor: 'accessing' stamp: ''!
interval
	^ interval! !

!StHaltInspectionItem methodsFor: 'accessing' stamp: ''!
node
	^ node! !

!StHaltInspectionItem methodsFor: 'initialization' stamp: ''!
forHalt: aRBMessageNode 
	node := aRBMessageNode.
	type := Halt name asString.
	interval := node start to: node stop.
	scope := aRBMessageNode methodNode methodClass.
	displayEntity := aRBMessageNode methodNode! !

!StHaltInspectionItem methodsFor: 'accessing' stamp: ''!
type: anObject
	type := anObject! !

!StHaltInspectionItem methodsFor: 'printing' stamp: ''!
printScope

	^ scope printString! !

!StHaltInspectionItem methodsFor: 'control' stamp: ''!
disableInContext: aStHaltAndBreakpointController 
	aStHaltAndBreakpointController disableHaltNode: node! !

!StHaltInspectionItem methodsFor: 'printing' stamp: ''!
printEntity
	^displayEntity method printString! !

!StHaltInspectionItem methodsFor: 'updating' stamp: ''!
removeInPresenterContext: aStObjectBreakpointInspection 
	self inform: 'Edit your code to remove halts'! !

!StHaltInspectionItem methodsFor: 'control' stamp: ''!
enableInContext: aStHaltAndBreakpointController 
	aStHaltAndBreakpointController enableHaltNode: node! !

!StHaltInspectionItem methodsFor: 'accessing' stamp: ''!
displayEntity
	^ displayEntity! !

!StHaltInspectionItem methodsFor: 'accessing' stamp: ''!
entityToBrowse

	^ node methodNode method! !

!StHaltInspectionItem methodsFor: 'accessing' stamp: ''!
interval: anObject
	interval := anObject! !

!StHaltInspectionItem methodsFor: 'updating' stamp: ''!
updateSourceCodePaneFor: aStObjectBreakpointInspection 
	aStObjectBreakpointInspection updateSourceCodeForHaltItem: self! !

!StHaltInspectionItem methodsFor: 'accessing' stamp: ''!
scope
	^ scope! !

!StHaltInspectionItem methodsFor: 'accessing' stamp: ''!
type
	^ type! !

!StHaltInspectionItem class methodsFor: 'instance creation' stamp: ''!
forHalt: aRBMessageNode 
	^self new forHalt: aRBMessageNode! !

!StHaltInspectionItem class methodsFor: 'instance creation' stamp: ''!
forBreakpoint: aBreakpoint 
	^StBreakpointInspectionItem new forBreakpoint: aBreakpoint ! !

!StHaltOnCallCommand methodsFor: 'executing' stamp: ''!
execute

	^ context haltInspectedObjectOnCallToSelectedMethod! !

!StHaltOnCallCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Halts when this method is called'! !

!StHaltOnCallCommand class methodsFor: 'default' stamp: ''!
defaultName 

	^ 'Halt on call'! !

!StHaltOnReadCommand methodsFor: 'executing' stamp: ''!
execute
	^context haltInspectedObjectOnReadAccess! !

!StHaltOnReadCommand class methodsFor: 'deafult' stamp: ''!
defaultIconName

	^ #smallObjects! !

!StHaltOnReadCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Halts when the selected or any variable is read'! !

!StHaltOnReadCommand class methodsFor: 'default' stamp: ''!
defaultName 

	^ 'Halt on read'! !

!StHaltOnStateAccessCommand methodsFor: 'executing' stamp: ''!
execute
	^context haltInspectedObjectOnStateAccess! !

!StHaltOnStateAccessCommand class methodsFor: 'deafult' stamp: ''!
defaultIconName

	^ #smallObjects! !

!StHaltOnStateAccessCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Halts when the selected or any variable is read or written'! !

!StHaltOnStateAccessCommand class methodsFor: 'default' stamp: ''!
defaultName 

	^ 'Halt on state access'! !

!StHaltOnWriteCommand methodsFor: 'executing' stamp: ''!
execute
	^context haltInspectedObjectOnWriteAccess! !

!StHaltOnWriteCommand class methodsFor: 'deafult' stamp: ''!
defaultIconName

	^ #smallObjects! !

!StHaltOnWriteCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Halts when the selected or any variable is written'! !

!StHaltOnWriteCommand class methodsFor: 'default' stamp: ''!
defaultName 

	^ 'Halt on write'! !

!StHeaderBar commentStamp: ''!
I am a generic header bar for tool component panels. 
I am used to add title, a toolbar and shortcut used to get to the panel.!
!StHeaderBar methodsFor: 'accessing' stamp: ''!
shortcut: aShortcut 

	self shortcutLabel: (KMShortcutPrinter toString: aShortcut)! !

!StHeaderBar methodsFor: 'accessing' stamp: ''!
label: aString

	titleLabel label: aString! !

!StHeaderBar methodsFor: 'testing' stamp: ''!
isCloseable

	^ closeButton notNil! !

!StHeaderBar methodsFor: 'private' stamp: ''!
enableCloseDoing: aBlock

	closeButton := self newButton
		addStyle: 'small';
		icon: (self application iconNamed: #glamorousClose);
		action: aBlock;
		yourself.
		
	layout addLast: closeButton expand: false! !

!StHeaderBar methodsFor: 'events' stamp: ''!
whenClosedDo: aBlock

	self isCloseable ifFalse: [ self enableCloseDoing: aBlock ].
	closeButton action: aBlock! !

!StHeaderBar methodsFor: 'accessing' stamp: ''!
toolbarActions: aCommandGroup

	toolbar removeAllItems.
	SpToolbarPresenterBuilder new 
		toolbarPresenter: toolbar;
		visit: aCommandGroup! !

!StHeaderBar methodsFor: 'accessing' stamp: ''!
beNotCloseable

	closeButton ifNil: [ ^ self ].
	
	layout remove: closeButton.
	closeButton := nil! !

!StHeaderBar methodsFor: 'accessing' stamp: ''!
beCloseable

	self isCloseable ifTrue: [ ^ self ].
	self enableCloseDoing: [  ]! !

!StHeaderBar methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpBoxLayout newLeftToRight
		beNotHomogeneous;
		borderWidth: 3;
		spacing: 3;
		add: (titleLabel := self newLabel) expand: false;
		add: (shortcutLabel := self newLabel) expand: false;
		addLast: (toolbar := self newToolbar) expand: false;
		yourself).

	shortcutLabel addStyle: 'shortcut'.
	"toolbar displayMode: self application toolbarDisplayMode"
	toolbar addStyle: 'stToolbar'.
	toolbar beIcons	"is a mini toolbar, items should be... tiny :)"! !

!StHeaderBar methodsFor: 'private' stamp: ''!
shortcutLabel: aString 

	shortcutLabel label: aString! !

!StHeaderBar class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newLeftToRight
		beNotHomogeneous;
		borderWidth: 3;
		spacing: 3;
		"add: #closeButton expand: false;"
		add: #titleLabel expand: false;
		add: #shortcutLabel expand: false;
		addLast: #toolbar expand: false;
		yourself! !

!StHeaderPanel commentStamp: ''!
!! SpHeaderPanel

A header panel is a presenter that provides a header and contains an arbitrary presenter. 

Through its property ==headerBar== (see *class:StHeaderBar*), it provides: a label, a shortcut <meta+panelNumber> and a small toolbar.

This presenter is used to homogenize the panels in tools.!
!StHeaderPanel methodsFor: 'accessing - header' stamp: ''!
shortcut: aShortcut

	shortcut := aShortcut.
	headerBar shortcut: aShortcut! !

!StHeaderPanel methodsFor: 'accessing - header' stamp: ''!
label: aString

	headerBar label: aString! !

!StHeaderPanel methodsFor: 'initialization' stamp: ''!
addWindowShortcutsTo: aWindowPresenter

	shortcut ifNil: [ ^ self ].
	aWindowPresenter 
		bindKeyCombination: shortcut
		toAction: [ presenter takeKeyboardFocus ]! !

!StHeaderPanel methodsFor: 'accessing' stamp: ''!
presenter: aPresenter

	presenter ifNotNil: [ layout remove: presenter ].
	presenter := aPresenter.
	layout add: presenter! !

!StHeaderPanel methodsFor: 'accessing' stamp: ''!
number: aNumber

	self shortcut: (self shortcutForPanel: aNumber)! !

!StHeaderPanel methodsFor: 'private' stamp: ''!
shortcutForPanel: aNumber
	"This is a convenience method to assign shortcuts to panels. 
	 panels will be different areas of a tool: a package panel in a browser, an inspector in 
	 the debugger."
	| char |
	
	char := aNumber asString first.
	^ char command mac 
		| char control win 
		| char control unix! !

!StHeaderPanel methodsFor: 'accessing - header' stamp: ''!
toolbarActions: aCommandGroup

	headerBar toolbarActions: aCommandGroup! !

!StHeaderPanel methodsFor: 'initialization' stamp: ''!
initializePresenters

	headerBar := self instantiate: StHeaderBar.
	
	layout := SpBoxLayout newTopToBottom
		add: headerBar expand: false;
		yourself! !

!StHelpBrowserPresenter commentStamp: ''!
Execute the following code to open HelpBrowser on doc:
```
StHelpBrowserPresenter openOnHelpFolder:  FileSystem workingDirectory / 'doc'.
```

Execute the following code to load doc in the cache:
```
| doc |
doc := FileSystem workingDirectory / 'pharo-local' / 'doc'.
StHelpBrowserPresenter internalizeHelpFrom: doc.
```
And to watch the cache inspect the following:
```
StNewHelpBrowserPresenter helpCache
```

To flush the cache execute the following code:
```
StNewHelpBrowserPresenter emptyHelpCache
```

Code to load and use the cache:
```
StHelpBrowserPresenter internalizeHelpFrom: FileSystem disk workingDirectory / 'doc'.
StHelpBrowserPresenter open
```!
!StHelpBrowserPresenter methodsFor: 'initialization' stamp: ''!
setModelBeforeInitialization: anHelpTopic
	
	rootTopic := anHelpTopic! !

!StHelpBrowserPresenter methodsFor: 'accessing' stamp: ''!
helpTopicVisitor
	
	helpTopicVisitor ifNil: [ helpTopicVisitor := StTopicBuilderVisitor ].
	^ helpTopicVisitor! !

!StHelpBrowserPresenter methodsFor: 'initialization' stamp: ''!
title
	^ 'Help Topic Browser'! !

!StHelpBrowserPresenter methodsFor: 'accessing' stamp: ''!
helpTopicVisitor: aClass 
	helpTopicVisitor := aClass! !

!StHelpBrowserPresenter methodsFor: 'internals' stamp: ''!
render

	| document |
	document := self parserClass parse: self dummyHelp.
	textOutput morph setText: (self morphWriter start: document)! !

!StHelpBrowserPresenter methodsFor: 'initialization' stamp: ''!
initialExtent
	^ 800@600! !

!StHelpBrowserPresenter methodsFor: 'internals' stamp: ''!
createRootTopicFromFolder: aFolder
	| topic |
	topic := (self createTopicsFromFileOrFolder: aFolder) first.
	topic subtopics do: [ :each | self propagateNodeIn: each ].
	self rootTopic: topic.! !

!StHelpBrowserPresenter methodsFor: 'internals' stamp: ''!
sortFileAndFolder: aFileOrFolder

	| sorted |
	sorted := SortedCollection sortBlock: [ :a :b | 
		          a basename <= b basename ].
	sorted addAll: (aFileOrFolder children select: [ :e | 
			 e isDirectory or: [ self isMicFile: e ] ]).
	^ sorted! !

!StHelpBrowserPresenter methodsFor: 'accessing' stamp: ''!
rootTopic
	^ rootTopic ifNil: [ self rootTopic: (self helpTopicClass named: 'Help'). rootTopic ]! !

!StHelpBrowserPresenter methodsFor: 'accessing' stamp: ''!
topicList
	^ topicList! !

!StHelpBrowserPresenter methodsFor: 'internals' stamp: ''!
createTopicsFromFile: aFileOrFolder

	| visitor |
	visitor := self helpTopicVisitor new.
	visitor visit: (Microdown new resolvedTreeFromFile: aFileOrFolder).
	^ visitor helpTopics subtopics! !

!StHelpBrowserPresenter methodsFor: 'internals' stamp: ''!
dummyHelp

	^  '# Empty Help
	This a dummy help.'! !

!StHelpBrowserPresenter methodsFor: 'hooks' stamp: ''!
morphWriter

	^ MicRichTextComposer new! !

!StHelpBrowserPresenter methodsFor: 'internals' stamp: ''!
createTopicsFromCache
	self createRootTopicFromFolder: self class helpCache.! !

!StHelpBrowserPresenter methodsFor: 'search' stamp: ''!
searchAndClick: aTopicName 
	| collection |
	collection := OrderedCollection new.
	collection add: 1.
	self class search: aTopicName in: rootTopic subtopics  with: collection.
	self topicList clickAtPath: collection! !

!StHelpBrowserPresenter methodsFor: 'hooks' stamp: ''!
helpTopicClass

	^ StNodeHelpTopic! !

!StHelpBrowserPresenter methodsFor: 'testing' stamp: ''!
isMicFile: aFile

	^ #( 'mic' 'md' ) includes: aFile extension! !

!StHelpBrowserPresenter methodsFor: 'internals' stamp: ''!
createTopicsFromFileOrFolder: aFileOrFolder

	| subTopic sorted topic |
	(aFileOrFolder isFile and: [ self isMicFile: aFileOrFolder ]) 
		ifTrue: [ ^ self createTopicsFromFile: aFileOrFolder ].

	topic := self helpTopicClass named:
		         aFileOrFolder basenameWithoutExtension capitalized.
	sorted := self sortFileAndFolder: aFileOrFolder.
	sorted do: [ :fileOrFolder | 
		(self createTopicsFromFileOrFolder: fileOrFolder) do: [ :each | 
			topic addSubtopic: each ] ].
	subTopic := OrderedCollection new.
	subTopic add: topic.
	^ subTopic! !

!StHelpBrowserPresenter methodsFor: 'hooks' stamp: ''!
parserClass 
	^ MicroDownParser! !

!StHelpBrowserPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	super initializePresenters.
	topicList := self newTree.
	topicList 
		roots: { self rootTopic };
		children: [ :aNode | aNode subtopics ];
		display: [ :each | each title ].
	
	"Using a morph container as the output because a text presenter is intended to receive 
	 strings, not instances of Text (the fact that it works now is just casual, and will 
	 be removed in the future)"
	textOutput := self newMorph
		morph: (RubScrolledTextMorph new 
			hResizing: #spaceFill; 
			vResizing: #spaceFill;
			in: [ :this | this textArea readOnly: true ];
			yourself);
		yourself.



! !

!StHelpBrowserPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters
 
	topicList
		whenSelectionChangedDo: [ :selection | 
					| item node |
					item := selection selectedItem.
					node := item node.
					node ifNotNil: [ self renderNode: node ]];
				displayIcon: [ :each | each icon ]! !

!StHelpBrowserPresenter methodsFor: 'internals' stamp: ''!
propagateNodeIn: aRootTopic

	aRootTopic node children ifEmpty: [ 
		aRootTopic subtopics do: [ :each | 
			self propagateNodeIn: each.
			each node children do: [ :node |
				aRootTopic addNode: node ]
			 ] ]
	! !

!StHelpBrowserPresenter methodsFor: 'internals' stamp: ''!
renderNode: aNode

	textOutput morph setText: (self morphWriter visit: aNode)! !

!StHelpBrowserPresenter methodsFor: 'accessing' stamp: ''!
rootTopic: aHelpTopic 
	rootTopic := aHelpTopic asHelpTopic! !

!StHelpBrowserPresenter class methodsFor: 'instance creation' stamp: ''!
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 on:  aHelpTopic)
		openWithSpec;
		yourself! !

!StHelpBrowserPresenter class methodsFor: 'cache' stamp: ''!
internalizeHelpFrom: aFolderOrFile  at: aFolderReference

	aFolderOrFile isDirectory 
		ifTrue:  [ | directoryPath |
					directoryPath := aFolderReference / aFolderOrFile basename.
					self filesystem createDirectory: directoryPath.
					aFolderOrFile children do: [ :folderOrFile | self internalizeHelpFrom: folderOrFile  at: directoryPath ] ]
		ifFalse: [ | file filePath |
					(self new isMicFile: aFolderOrFile) 
						ifTrue: [ 
							filePath := aFolderReference / aFolderOrFile basename.
							file := self filesystem workingDirectory resolve: filePath.
							file writeStreamDo: [ :stream |stream nextPutAll: aFolderOrFile contents ] ] ]! !

!StHelpBrowserPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	| searchInput |
	searchInput := (SpTextInputFieldPresenter new
				placeholder: 'Enter you search').
	 ^ SpBoxLayout newTopToBottom
			add: (SpPanedLayout newLeftToRight
				add: #topicList;
				add: #textOutput;
				yourself);
			add: searchInput height: 30 ;
			add: (SpButtonPresenter new
				label: 'Search';
				action: [ lastopenHelp searchAndClick: searchInput text ]) height: 50;
			yourself! !

!StHelpBrowserPresenter class methodsFor: 'accessing' stamp: ''!
filesystem: aFileSystem
	filesystem := aFileSystem! !

!StHelpBrowserPresenter class methodsFor: 'basic search' stamp: ''!
search: aTopicName in: topicCollection with: aCollection
	
	| lookedup |
	lookedup := aTopicName asLowercase.	
		
	topicCollection ifNotEmpty: [ 
		topicCollection doWithIndex: [ :topic :i |
		aCollection add: i.
		((topic title asLowercase splitOn: Character space) anySatisfy: [ :each | lookedup match: each ])
			ifTrue: [ ^ aCollection ]
			ifFalse: [ (self search: aTopicName in: topic subtopics with: aCollection) isCollection 
				ifTrue: [ ^ aCollection]].
			aCollection removeLast ]
		 ]
	! !

!StHelpBrowserPresenter class methodsFor: 'instance creation' stamp: ''!
openOnHelpFolder: aFileReference

	"Open an help browser on a given folder."

	"Implementation note: the logic is not really good because I have to copy the logic from SpPresenter class>>#newApplication:model:.
	Especially how to pass a model before the initialization which is normally done via message #on: "

	| fileReference |
	lastopenHelp := self basicNew.
	fileReference := aFileReference exists
		ifFalse: [  self helpCache ]
		ifTrue: [ aFileReference ].
	lastopenHelp createRootTopicFromFolder: fileReference.
	^ lastopenHelp
		  setModelBeforeInitialization: lastopenHelp rootTopic;
		  initialize;
		  openWithSpec;
		  yourself! !

!StHelpBrowserPresenter class methodsFor: 'cache' stamp: ''!
internalizeHelpFrom: aFolderOrFile

	| fileRef |
	fileRef := aFolderOrFile asFileReference.
	self filesystem: FileSystem memory.
	[ self internalizeHelpFrom: fileRef at: filesystem workingDirectory.
	self helpCache: self filesystem workingDirectory / fileRef basename ] 
		on: FileDoesNotExistException 
		do: [  'We do not do anything special because the only thing we could do is to reinitialize
and we may lose the contents if there was one.' ]! !

!StHelpBrowserPresenter class methodsFor: 'accessing' stamp: ''!
emptyHelpCache

	helpCache := nil! !

!StHelpBrowserPresenter class methodsFor: 'instance creation' stamp: ''!
open
	"Open a HelpBrowser on the internalized docs."
	<example>

	^ self openOnHelpFolder: self helpCache ! !

!StHelpBrowserPresenter class methodsFor: 'accessing' stamp: ''!
helpCache: aCache
	helpCache := aCache! !

!StHelpBrowserPresenter class methodsFor: 'accessing' stamp: ''!
helpCache

	^ helpCache ifNil: [ helpCache := FileSystem memory workingDirectory ]! !

!StHelpBrowserPresenter class methodsFor: 'accessing' stamp: ''!
filesystem
	^ filesystem! !

!StHelpBrowserPresenter class methodsFor: 'instance creation' stamp: ''!
openOnCustomHelp: aDescription
	[ aDescription bookName.
	 ^ self openOn: (CustomHelpHelpBuilder new createTopicFrom: aDescription)] 
	on: MessageNotUnderstood do: [ | inst |
		inst:= self basicNew.
		inst createTopicsFromCache.
		^ inst 
				setModelBeforeInitialization: inst rootTopic;
				initialize;
				openWithSpec;
				yourself
	 ]
	! !

!StHelpBrowserPresenter class methodsFor: 'instance creation' stamp: ''!
openOnHelpFolder
	"Open an help browser."
	
	self openOnHelpFolder: FileSystem workingDirectory / 'pharo-local' / 'doc'

	! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testSpHelpBrowserGotTopicsThatISpecify

	| topic browser |
	browser := self presenterClass new.
	browser rootTopic: (self helpTopicClass named: 'foo').
	topic := browser rootTopic.
	self assert: topic title equals: 'foo'! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testOpenOnDoesNotExistFolder

	| browser rootTopic save |
	[ 
	save := self presenterClass helpCache.
	self presenterClass emptyHelpCache.
	browser := self presenterClass openOnHelpFolder:
		           FileSystem workingDirectory
		           / 'ojdoajdjvsaidqsjkjfzeuican'.
	rootTopic := browser rootTopic.
	self assert: rootTopic title equals: '/'.
	window := browser window ] ensure: [ 
		self presenterClass helpCache: save ]! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testOpenOnCustomHelpWithString

	| browser rootTopic save |
	[ 
	save := self presenterClass helpCache.
	self presenterClass emptyHelpCache.
	browser := self presenterClass openOnCustomHelp:
		           self presenterClass >> #rootTopic:.
	rootTopic := browser rootTopic.
	self assert: rootTopic title equals: '/'.
	window := browser window ] ensure: [ 
		self presenterClass helpCache: save ]! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testSpHelpBrowserGotHelpTopicVisitorPerDefault

	| visitor browser |
	browser := self presenterClass new.
	visitor := browser helpTopicVisitor.
	self assert: visitor equals: StTopicBuilderVisitor! !

!StHelpBrowserPresenterTest methodsFor: 'tests - interaction' stamp: ''!
testOpenIsWorkingSmokeTestOnSpecificHelp

	| browser topic |
	topic := StNodeHelpTopic named: 'Test'.
	browser := self presenterClass on: topic.
	self assert: browser rootTopic equals: topic.
	window := browser openWithSpec! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testOpenOnCustomHelpWithMethod

	| browser rootTopic save |
	[ 
	save := self presenterClass helpCache.
	self presenterClass emptyHelpCache.
	browser := self presenterClass openOnCustomHelp:
		           self presenterClass >> #rootTopic:.
	rootTopic := browser rootTopic.
	self assert: rootTopic title equals: '/'.
	window := browser window ] ensure: [ 
		self presenterClass helpCache: save ]! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testOpenOnSystemHelp2

	| browser rootTopic |
	browser := self presenterClass on: SystemHelp2 asHelpTopic.
	rootTopic := browser rootTopic.
	self assert: rootTopic title equals: 'Help'.
	self assert: rootTopic icon isNil.
	window := browser openWithSpec! !

!StHelpBrowserPresenterTest methodsFor: 'tests - search' stamp: ''!
presenterClass

	^ StHelpBrowserPresenter! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testOpenOnCustomHelpWithObject

	| browser rootTopic save |
	[ 
	save := self presenterClass helpCache.
	self presenterClass emptyHelpCache.
	browser := self presenterClass openOnCustomHelp: Object new.
	rootTopic := browser rootTopic.
	self assert: rootTopic title equals: '/'.
	window := browser window ] ensure: [ 
		self presenterClass helpCache: save ]! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testSpHelpBrowserPresenterTopicFromSystemOnFile

	| file browser rootTopic |
	file := filesystem workingDirectory / 'fd1.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: self class spFd1 ].
	browser := self presenterClass new.
	rootTopic := (browser createRootTopicFromFolder: file) rootTopic.
	self assert: rootTopic subtopics size equals: 2! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testSpHelpBrowserGotRootTopicThatISpecify

	| topic browser |
	browser := self presenterClass new.
	topic := self helpTopicClass  named: 'Test'.
	browser rootTopic: topic.
	self assert: browser rootTopic equals: topic! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testSpHelpBrowserPresenterOpenADirectory

	| directory browser |
	directory := filesystem workingDirectory / self class spDirectoryName.
	filesystem createDirectory: self class spDirectoryName.
	browser := self presenterClass new.
	browser createRootTopicFromFolder: directory.

	self
		assert: browser rootTopic title
		equals: directory basenameWithoutExtension capitalized! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testSpHelpBrowserGotHelpTopicVisitorThatISpecify

	| visitor browser |
	browser := self presenterClass new.
	browser helpTopicVisitor: StTopicBuilderVisitor.
	visitor := browser helpTopicVisitor.
	self assert: visitor equals: StTopicBuilderVisitor! !

!StHelpBrowserPresenterTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	filesystem := FileSystem memory.
	! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testSpHelpBrowserGotTopicsPerDefault

	| topic browser |
	browser := self presenterClass new.
	topic := browser rootTopic.
	self assert: topic title equals: 'Help'! !

!StHelpBrowserPresenterTest methodsFor: 'running' stamp: ''!
tearDown 

	window ifNotNil: [ window close ].
	super tearDown.! !

!StHelpBrowserPresenterTest methodsFor: 'tests - cache' stamp: ''!
testHelpCacheReturnFileReferenceEmptyIfNil

	| cache |
	cache := self presenterClass helpCache.
	self presenterClass emptyHelpCache.
	self assert: self presenterClass helpCache hasChildren not.
	self presenterClass helpCache: cache! !

!StHelpBrowserPresenterTest methodsFor: 'tests - interaction' stamp: ''!
testOpenIsWorkingSmokeTest

	| browser |
	browser := self presenterClass new.
	window := browser openWithSpec! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testSpHelpBrowserPresenterDocTopicFromFileSystemOnFile

	| file browser rootTopic |
	file := filesystem workingDirectory / 'fd1.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: self class spFd1 ].
	browser := self presenterClass new.
	rootTopic := browser createTopicsFromFileOrFolder: file.
	self assert: rootTopic size equals: 2! !

!StHelpBrowserPresenterTest methodsFor: 'tests - cache' stamp: ''!
testTopicsWithCacheFrom

	| docFolder file browser save |
	[ 
	save := self presenterClass helpCache.

	filesystem createDirectory: 'doc'.
	docFolder := filesystem workingDirectory / 'doc'.
	file := filesystem workingDirectory / 'doc' / 'file.mic'.
	file writeStreamDo: [ :stream | 
		stream nextPutAll: '# section
this is a text' ].
	self presenterClass internalizeHelpFrom: docFolder.
	browser := self presenterClass open.
	window := browser window.
	self assert: browser rootTopic title equals: 'Doc'.
	self assert: browser rootTopic subtopics size equals: 1 ] ensure: [ 
		self presenterClass helpCache: save ]! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testSpHelpBrowserPresenterTopicFromSystemOnDirectoryWithFiles

	| directory file1 file2 browser rootTopic |
	filesystem createDirectory: 'test'.
	directory := filesystem workingDirectory / 'test'.


	file1 := filesystem workingDirectory / 'test/fd1.mic'.
	file1 writeStreamDo: [ :stream | stream nextPutAll: self class spFd1 ].

	file2 := filesystem workingDirectory / 'test/fd2.mic'.
	file2 writeStreamDo: [ :stream | stream nextPutAll: self class spFd2 ].

	browser := self presenterClass new.
	rootTopic := (browser createRootTopicFromFolder: directory) rootTopic.
	self assert: rootTopic subtopics size equals: 3! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testOpenOnCustomHelp2

	| browser rootTopic |
	browser := self presenterClass on: CustomHelp2 asHelpTopic.
	self flag: #toFix.
	"return an help topic and not a nodeHelpTopic"
	rootTopic := browser rootTopic.
	self assert: rootTopic title equals: 'Help'.
	self assert: rootTopic icon isNotNil.
	window := browser openWithSpec! !

!StHelpBrowserPresenterTest methodsFor: 'tests - cache' stamp: ''!
testHelpCacheOnlyAcceptFolderAndMicFiles

	| docFolder file cache save |
	[ 
	save := self presenterClass helpCache.

	filesystem createDirectory: 'doc'.
	docFolder := filesystem workingDirectory / 'doc'.
	file := filesystem workingDirectory / 'doc' / 'file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: 'this is a text' ].

	file := filesystem workingDirectory / 'doc' / 'Stupid.txt'.
	file writeStreamDo: [ :stream | 
		stream nextPutAll: 'This is a stupid mistyped extension text' ].

	filesystem createDirectory: 'doc/Epicea'.
	file := filesystem workingDirectory / 'doc' / 'Epicea' / 'fileEp.mic'.
	file writeStreamDo: [ :stream | 
		stream nextPutAll: 'this is a text about Epicea' ].
	self presenterClass internalizeHelpFrom: docFolder.
	cache := self presenterClass helpCache.
	self assert: cache children size equals: 2.
	self assert: cache allChildren size equals: 4 ] ensure: [ 
		self presenterClass helpCache: save ]! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testSpHelpBrowserPresenterDocTopicFromSystem

	| file directory browser rootTopic |
	filesystem createDirectory: 'test'.
	directory := filesystem workingDirectory / 'test'.
	file := filesystem workingDirectory / 'test/fd1.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: self class spFd1 ].
	browser := self presenterClass new.
	rootTopic := (browser createRootTopicFromFolder: directory) rootTopic.
	self assert: rootTopic subtopics size equals: 2! !

!StHelpBrowserPresenterTest methodsFor: 'tests - search' stamp: ''!
helpTopicClass

	^ StNodeHelpTopic! !

!StHelpBrowserPresenterTest methodsFor: 'tests - cache' stamp: ''!
testHelpCacheHandleShittyFiles

	| docFolder file cache save |
	[ 
	save := self presenterClass helpCache.

	filesystem createDirectory: 'doc'.
	docFolder := filesystem workingDirectory / 'doc'.
	file := filesystem workingDirectory / 'doc' / 'file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: 'this is a text' ].

	file := filesystem workingDirectory / 'doc' / '.DS_Store'.
	file writeStreamDo: [ :stream | stream nextPutAll: 'crap crap' ].
	self presenterClass internalizeHelpFrom: docFolder.
	cache := self presenterClass helpCache.
	self assert: cache basenameWithoutExtension equals: 'doc'.
	self assert: cache children size equals: 1 ] ensure: [ 
		self presenterClass helpCache: save ]! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testOpenOnCustomHelpWithDescription

	| browser rootTopic save |
	[ 
	save := self presenterClass helpCache.
	self presenterClass emptyHelpCache.
	browser := self presenterClass openOnCustomHelp: SUnitTutorial.
	rootTopic := browser rootTopic.
	self assert: rootTopic title equals: 'Tutorial'.
	window := browser window ] ensure: [ 
		self presenterClass helpCache: save ]! !

!StHelpBrowserPresenterTest methodsFor: 'tests - cache' stamp: ''!
testHelpCache

	| docFolder file cache save |
	[ 
	save := self presenterClass helpCache.

	filesystem createDirectory: 'doc'.
	docFolder := filesystem workingDirectory / 'doc'.
	file := filesystem workingDirectory / 'doc' / 'file.mic'.
	file writeStreamDo: [ :stream | stream nextPutAll: 'this is a text' ].
	self presenterClass internalizeHelpFrom: docFolder.
	cache := self presenterClass helpCache.
	self assert: cache basenameWithoutExtension equals: 'doc'.
	self
		assert: cache children first basenameWithoutExtension
		equals: 'file' ] ensure: [ self presenterClass helpCache: save ]! !

!StHelpBrowserPresenterTest methodsFor: 'tests' stamp: ''!
testOpenOnCustomHelpWithClass

	| browser rootTopic save |
	[ 
	save := self presenterClass helpCache.
	self presenterClass emptyHelpCache.
	browser := self presenterClass openOnCustomHelp: self presenterClass.
	rootTopic := browser rootTopic.
	self assert: rootTopic title equals: '/'.
	window := browser window ] ensure: [ 
		self presenterClass helpCache: save ]! !

!StHelpBrowserPresenterTest class methodsFor: 'resources' stamp: ''!
spFileName

	^ 'test.md'! !

!StHelpBrowserPresenterTest class methodsFor: 'resources' stamp: ''!
spDirectoryName

	^ 'tests'! !

!StHelpBrowserPresenterTest class methodsFor: 'resources' stamp: ''!
spFd2

	^ '# Chapitre 3
Un paragraphe sur 3'! !

!StHelpBrowserPresenterTest class methodsFor: 'resources' stamp: ''!
spFd1

	^ '# Chapitre Bar
Un paragraphe sur Bar

## 1
_Un paragraphe 1_

## 2
Un paragraphe 2

# Chapitre Foo

un paragraphe sur Foo'! !

!StHelpBrowserPresenterTest class methodsFor: 'resources' stamp: ''!
spFileContentsOneSection

	^ '# Section 1
This is a test'! !

!StHelpEntry commentStamp: ''!
I wrap a HelpTopic entry, to modify its behavior if required for the spotter!
!StHelpEntry methodsFor: 'converting' stamp: ''!
asString 

	^ content title! !

!StHelpEntry methodsFor: 'accessing' stamp: ''!
icon
	
	^ content stTopicIcon! !

!StHelpEntry methodsFor: 'evaluating' stamp: ''!
doEvaluate 

	content stActDefault ! !

!StHelpProcessor commentStamp: ''!
I am a processor that gets all the help topics in the system.!
!StHelpProcessor methodsFor: 'filtering' stamp: ''!
collection

	^ SystemHelp asHelpTopic stAllSubtopics! !

!StHelpProcessor methodsFor: 'private - extraction' stamp: ''!
helpTag

	^ #Help! !

!StHelpProcessor methodsFor: 'filtering' stamp: ''!
newEntryOn: anElement

	^ StHelpEntry on: anElement! !

!StHelpProcessor methodsFor: 'key-bindings' stamp: ''!
installKeymappingsOn: aPresenter onExecution: aBlock

	aPresenter
		bindKeyCombination: self keyBinding
		toAction: [ 
			self query toggleFilter: self helpTag.
			aBlock cull: self ]! !

!StHelpProcessor methodsFor: 'key-bindings' stamp: ''!
keyBinding

	^ $h meta! !

!StHelpProcessor methodsFor: 'key-bindings' stamp: ''!
installKeymappingsOn: aPresenter

	aPresenter
		bindKeyCombination: $h meta
		toAction: [ aPresenter onKeyProcessor: self ]! !

!StHelpProcessor class methodsFor: 'accessing' stamp: ''!
order
	
	^ 2000! !

!StHelpProcessor class methodsFor: 'default-settings' stamp: ''!
defaultEnabled

	^ true! !

!StHelpProcessor class methodsFor: 'accessing' stamp: ''!
title

	^ 'Help topics'! !

!StHelpProcessorTest methodsFor: 'tests' stamp: ''!
testBeginsWithQueryShowsResults

	self runForText: 'Contr'.
	self assertResultsIncludesHelpTopic: HowToContributeHelp asHelpTopic.
! !

!StHelpProcessorTest methodsFor: 'tests' stamp: ''!
processor

	^ StHelpProcessor new! !

!StHelpProcessorTest methodsFor: 'tests' stamp: ''!
testLookingSubstringShowsResults

	self runForText: 'menu'.
	self denyResultsIncludesHelpTopic: HowToContributeHelp asHelpTopic.
	self assertResultsIncludesHelpTopic: WorldMenuHelp asHelpTopic.
! !

!StHelpProcessorTest methodsFor: 'tests' stamp: ''!
assertResultsIncludesHelpTopic: aHelpTopic

	^ self assert: (candidates results
				anySatisfy: [ :each | each content title = aHelpTopic title ])! !

!StHelpProcessorTest methodsFor: 'tests' stamp: ''!
testEmptyQueryShowsResults

	self runForText: ''.
	self denyResultsIncludesHelpTopic: WelcomeHelp asHelpTopic.
! !

!StHelpProcessorTest methodsFor: 'tests' stamp: ''!
denyResultsIncludesHelpTopic: aHelpTopic

	^ self assert: (candidates results
				noneSatisfy: [ :each | each content title = aHelpTopic title ])! !

!StHistoryProcessor commentStamp: ''!
I am a processor that shows all the entries in the spotter history.!
!StHistoryProcessor methodsFor: 'filtering' stamp: ''!
collection

	^ StSpotter history reject: [ :each | each isNil ]! !

!StHistoryProcessor methodsFor: 'filtering' stamp: ''!
newEntryOn: anElement

	^ anElement! !

!StHistoryProcessor methodsFor: 'configuration' stamp: ''!
showForEmptyQuery

	^ true! !

!StHistoryProcessor class methodsFor: 'accessing' stamp: ''!
order
	
	^ 80! !

!StHistoryProcessor class methodsFor: 'default-settings' stamp: ''!
defaultEnabled

	^ true! !

!StHistoryProcessor class methodsFor: 'accessing' stamp: ''!
title

	^ 'History'! !

!StHistoryProcessorTest methodsFor: 'running' stamp: ''!
tearDown

	StSpotter resetHistory.
	super tearDown! !

!StHistoryProcessorTest methodsFor: 'tests' stamp: ''!
processor

	^ StHistoryProcessor new! !

!StHistoryProcessorTest methodsFor: 'tests' stamp: ''!
testLookingSubstringShowsResults

	self runForText: 'unifi'.
	self denyResultsIncludes: self class.
	self assertResultsIncludes: StUnifiedProcessorTest.
! !

!StHistoryProcessorTest methodsFor: 'tests' stamp: ''!
testLookingHistoryQueryShowsResults

	self runForText: 'sthistory'.
	self assertResultsIncludes: self class.
! !

!StHistoryProcessorTest methodsFor: 'tests' stamp: ''!
testEmptyQueryShowsResults

	self runForText: ''.
	self assertResultsIncludes: self class.
! !

!StHistoryProcessorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp. 
	
	firstValue := StClassEntry on: self class.
	secondValue := StClassEntry on: StUnifiedProcessorTest.
	
	StSpotter new historize: firstValue.
	StSpotter new historize: secondValue.! !

!StIconBookBuilder commentStamp: ''!
I set pageIcon when the topic has not subtopics.
I set bookIcon when the topic has subtopics.!
!StIconBookBuilder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	bookIcon := #bookIcon.
	pageIcon := #pageIcon! !

!StIconBookBuilder methodsFor: 'build' stamp: ''!
buildBookIcon: aTopic

	^ aTopic iconName: bookIcon! !

!StIconBookBuilder methodsFor: 'build' stamp: ''!
buildIcon: aTopic

	self buildBookIcon: aTopic! !

!StIconBookBuilder methodsFor: 'build' stamp: ''!
setIconOf: aTopic
	^ aTopic iconName: pageIcon! !

!StIconClassBuilder commentStamp: ''!
I set the icon of topic with a class icon!
!StIconClassBuilder methodsFor: 'build' stamp: ''!
buildIcon: aTopic
	^ aTopic icon: (self class environment at: aTopic title asSymbol) systemIcon! !

!StImplementorsIterator commentStamp: ''!
I implement an iterator over all the implementors in the system!
!StImplementorsIterator methodsFor: 'enumerating' stamp: ''!
elementsDo: aValuable

	SystemNavigation default
		allBehaviorsDo: [ :aClass | aClass methodsDo: aValuable ]! !

!StImplementorsProcessor commentStamp: ''!
I am simple processor that iterates on the implementors!
!StImplementorsProcessor methodsFor: 'filtering' stamp: ''!
newTextFilteringSource

	^ StSourceFactory current implementorsSubstringSource! !

!StImplementorsProcessor class methodsFor: 'accessing' stamp: ''!
order
	
	^ 100! !

!StImplementorsProcessor class methodsFor: 'settings' stamp: ''!
hideInSettings

	"I am hidden because the implementation in the unified processor is richer"
	^ true! !

!StImplementorsProcessor class methodsFor: 'default-settings' stamp: ''!
defaultEnabled

	^ false! !

!StImplementorsProcessor class methodsFor: 'accessing' stamp: ''!
title

	^ 'Implementors'! !

!StImplementorsProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisMethodAfterAddingText

	self runForText: 'test'.
	self runForText: 'testFindThisMethod'.
	
	self assertResultsIncludes: thisContext method! !

!StImplementorsProcessorTest methodsFor: 'tests' stamp: ''!
processor

	^ StImplementorsProcessor new! !

!StImplementorsProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisMethod

	self runForText: 'testFindThisMethod'.
	self assertResultsIncludes: thisContext method! !

!StImplementorsProcessorTest methodsFor: 'tests' stamp: ''!
testPopularStringDoesReturnOnlyTenResults

	self runForText: 'test'.
	self assertQuantityOfResults: 25.! !

!StImplementorsProcessorTest methodsFor: 'tests' stamp: ''!
testPopularStringDoesReturnOnlyTenResultsWithUppercase

	self runForText: 'Test'.
	self assertQuantityOfResults: 25.! !

!StInspection commentStamp: ''!
A base inspection on an inspectionModel (which contains an inspected object).
Inspections are ways to see/inspect an object. 
They are the pages seen in the basic inspector.!
!StInspection methodsFor: 'converting' stamp: ''!
asInspection

	^ self! !

!StInspection methodsFor: 'accessing' stamp: ''!
context

	^ context! !

!StInspection methodsFor: 'stepping' stamp: ''!
step
	"do nothing, it depends on my children"! !

!StInspection methodsFor: 'testing' stamp: ''!
hasOutputActivationPort

	^ false! !

!StInspection methodsFor: 'api' stamp: ''!
activateOnDoubleClick
! !

!StInspection methodsFor: 'accessing' stamp: ''!
context: aContext

	context := aContext! !

!StInspection methodsFor: 'api' stamp: ''!
activateOnSingleClick! !

!StInspection methodsFor: 'accessing - model' stamp: ''!
model: anInspectionModel

	model := anInspectionModel! !

!StInspection methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: anInspectionModel 

	model := anInspectionModel! !

!StInspection methodsFor: 'accessing - model' stamp: ''!
model
	^ model! !

!StInspectionCollector commentStamp: ''!
I collect inspections from an object which wants to be inspected.
I traverse the hierarchy of the object collecting #extensionPragmas and applying them.

For now, I have two pragmas that receive 2 or 3 arguments: 

- inspectorPresentationOrder:title:
- inspectorPresentationOrder:title:if:

order: inspection appearance order
title: inspection title
if: a block receiving ONE argument that will be evaluated to determine if that inspection needs to be shown.

The arguments of the pragmas are required because the tabs are calculated lazily and this information 
is required before.!
!StInspectionCollector methodsFor: 'accessing' stamp: ''!
collectInspectionContexts
	| pragmas |
	
	pragmas := self uniquePragmas: (self extensionPragmas
		inject: #()
		into: [ :all :each | all, (self collectPragmas: each) ]).

	^ (pragmas 
		collect: [ :each | self contextFromPragma: each ]
		thenSelect: [ :each | each isActive ])
		sorted: #order ascending! !

!StInspectionCollector methodsFor: 'private' stamp: ''!
contextFromPragma: aPragma
	"Return the inspection context for a pragma.
	Safe version: Return an error context if the context cannot be obtained"
	[ ^ self basicContextFromPragma: aPragma ]
		on: Exception
		do: [ :error | 
			^ (StErrorContext fromPragma: aPragma)
				  inspectedObject: self inspectedObject;
				  setError: error freeze;
				  yourself ]! !

!StInspectionCollector methodsFor: 'private' stamp: ''!
collectPragmas: aPragmaName

	^ Pragma
		allNamed: aPragmaName
		from: self inspectedObject class
		to: ProtoObject! !

!StInspectionCollector methodsFor: 'accessing' stamp: ''!
inspectedObject
	^ inspectedObject! !

!StInspectionCollector methodsFor: 'accessing' stamp: ''!
inspectedObject: anObject
	inspectedObject := anObject! !

!StInspectionCollector methodsFor: 'private' stamp: ''!
uniquePragmas: aCollection
	| unique |
	
	unique := OrderedDictionary new.
	aCollection do: [ :each |
		unique
			at: each methodSelector
			ifAbsentPut: [ each ] ].
	^ unique values! !

!StInspectionCollector methodsFor: 'private' stamp: ''!
extensionPragmas

	^ self class defaultExtensionPragmas! !

!StInspectionCollector methodsFor: 'private' stamp: ''!
basicContextFromPragma: aPragma
	"Get the context for a pragma or fail if an error happens"
	| context |
	
	context := StInspectionContext fromPragma: aPragma.
	context inspectedObject: self inspectedObject.

	(self inspectedObject respondsTo: context contextMethodSelector) ifTrue: [ 
		self inspectedObject 
			perform: context contextMethodSelector
			with: context ].

	^ context! !

!StInspectionCollector class methodsFor: 'instance creation' stamp: ''!
on: anObject

	^ self new 
		inspectedObject: anObject;
		yourself! !

!StInspectionCollector class methodsFor: 'defaults' stamp: ''!
defaultExtensionPragmas

	^ #(inspectorPresentationOrder:title:)! !

!StInspectionContext commentStamp: ''!
An object to control the visibility and properties of inspections. 
It will be passed to the objects defining the inspections, in case they implement the method defined in `StInspectionContext>>#contextMethodSelector`.

If I fail to create a presentation, I provide a debug presentation instead.

## Example
If you define a method `Object>>#inspectionMeta`, you can define a context method `Object>>#inspectionMetaContext:`.!
!StInspectionContext methodsFor: 'initialization' stamp: ''!
debugInspectorPresenter

	"Create a debug inspector presenter.
	
	I create a code presenter that contains code to recreate this presenter.
	This is useful for debugging and reporting errors when rendering/building"

	| debugExpression |
	debugExpression := String streamContents: [ :str |
		str nextPutAll: '"Error while creating the inspector. Debug it by executing the following:"'; cr.
		str nextPutAll: '| collector pragma context |'; cr.
		str nextPutAll: 'collector := StInspectionCollector on: self.'; cr.
		str
			nextPutAll: 'pragma := (';
			nextPutAll: inspectedObject class name;
			nextPutAll: ' lookupSelector: #';
			nextPutAll: methodSelector;
			nextPutAll: ') pragmas first.'; cr.
		str nextPutAll: 'context := collector basicContextFromPragma: pragma.'; cr.
		str nextPutAll: 'context basicNewInspectionPresenter'.
	].

	"I am itself an evaluator, no need to some other one."
	self withoutEvaluator.
	^ SpCodePresenter new
		beForObject: self inspectedObject;
		text: (Text string: debugExpression attribute: TextColor red);
		yourself! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
methodSelector

	^ methodSelector! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
methodSelector: aSelector

	methodSelector := aSelector! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
beActive

	self active: true! !

!StInspectionContext methodsFor: 'testing' stamp: ''!
hasEvaluator

	^ evaluator! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
withoutEvaluator

	self evaluator: false! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
title
	^ title! !

!StInspectionContext methodsFor: 'private - factory' stamp: ''!
basicNewInspectionPresenter

	^ self methodSelectorNeedsBuilder 
		ifTrue: [ 
			self inspectedObject 
				inspectorPerform: self methodSelector 
				with: self newPresenterBuilder ]
		ifFalse: [ 
			self inspectedObject inspectorPerform: self methodSelector ]! !

!StInspectionContext methodsFor: 'private - testing' stamp: ''!
methodSelectorNeedsBuilder

	^ self methodSelector last = $:! !

!StInspectionContext methodsFor: 'testing' stamp: ''!
isActive

	^ active! !

!StInspectionContext methodsFor: 'private - factory' stamp: ''!
newInspectionPresenter

	"Create an inspection presenter for the current object and pragma.
	If creation fails, create a debug inspector instead"
	^ [self basicNewInspectionPresenter]
		on: Exception do: [ :error |
			self debugInspectorPresenter ]! !

!StInspectionContext methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	active := true.
	evaluator := true! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
inspectedObject

	^ inspectedObject! !

!StInspectionContext methodsFor: 'private - factory' stamp: ''!
newPresenterBuilder

	^ SpPresenterBuilder new! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
order
	^ order! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
order: aNumber

	order := aNumber! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
title: anObject
	title := anObject! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
beInactive

	self active: false! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
inspectedObject: anObject

	inspectedObject := anObject! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
evaluator: aBoolean

	evaluator := aBoolean! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
active: aBoolean

	active := aBoolean! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
withEvaluator

	self evaluator: true! !

!StInspectionContext methodsFor: 'initialization' stamp: ''!
fromPragma: aPragma

	self
		order: (aPragma argumentAt: 1);
		title: (aPragma argumentAt: 2);
		methodSelector: aPragma methodSelector! !

!StInspectionContext methodsFor: 'factory' stamp: ''!
newInspectionView
	| presenter |

	presenter := self newInspectionPresenter.
	^ presenter asInspection
		context: self;
		yourself! !

!StInspectionContext methodsFor: 'accessing' stamp: ''!
contextMethodSelector
	| selector |

	selector := self methodSelectorNeedsBuilder
		ifTrue: [ self methodSelector allButLast ]
		ifFalse: [ self methodSelector ].
	^ (selector, 'Context:') asSymbol! !

!StInspectionContext class methodsFor: 'instance creation' stamp: ''!
fromPragma: aPragma

	^ self new 
		fromPragma: aPragma;
		yourself! !

!StInspector commentStamp: ''!
I am an inspector of objects. 
I offer multiple views using a miller list as a navigation. 
One particular feature is that you can use the evaluator tab to enter code, and evaluating it results in opening another pane to the right.

The object finder asks dynamically the object for the actual presentations that are displayed in each pane.

Example:
self openOn: Smalltalk.

Register it as a replacement for inspector:
self registerToolsOn: Smalltalk tools.!
!StInspector methodsFor: 'private - updating' stamp: ''!
updateList

	millerList millerListPresenter
		resetTo: 0;
		setRootModel: self model! !

!StInspector methodsFor: 'initialization' stamp: ''!
windowTitle

	^ self model windowTitle! !

!StInspector methodsFor: 'private - stepping' stamp: ''!
startProcessing

	StInspectorRefreshService uniqueInstance register: self! !

!StInspector methodsFor: 'transmission' stamp: ''!
defaultInputPort

	^ self inputModelPort! !

!StInspector methodsFor: 'accessing' stamp: ''!
millerList

	^ millerList! !

!StInspector methodsFor: 'private - stepping' stamp: ''!
step 

	millerList pages
		do: [ :each | each step ]! !

!StInspector methodsFor: 'accessing' stamp: ''!
withHeaderBar: bool
	withHeaderBar := bool! !

!StInspector methodsFor: 'private' stamp: ''!
keepLastPageSelectedTabName
	
	lastPageSelectedTabName := millerList pages 
		ifNotEmpty: [ :pages | pages last selectedPageName ]
		ifEmpty: [ nil ]! !

!StInspector methodsFor: 'transmission' stamp: ''!
inputModelPort

	^ SpModelPort newPresenter: self! !

!StInspector methodsFor: 'private - updating' stamp: ''!
updateTitle
		
	self isRoot ifFalse: [ ^ self ].
	self withWindowDo: [ :window | 
		window title: self title ].! !

!StInspector methodsFor: 'api - focus' stamp: ''!
defaultKeyboardFocus

	^ millerList presenters 
		ifNotEmpty: [ :list | list first ] 
		ifEmpty: [ self ]! !

!StInspector methodsFor: 'private' stamp: ''!
preferredExtent: aSize

	(self window isMaximized 
		or: [ self window isMinimized ])
		ifTrue: [ ^ self ].
	self class preferredExtent: aSize! !

!StInspector methodsFor: 'accessing' stamp: ''!
withHeaderBar
	 ^withHeaderBar ifNil: [ withHeaderBar := true ]! !

!StInspector methodsFor: 'private' stamp: ''!
setModel: aModel

	self model: aModel! !

!StInspector methodsFor: 'accessing - model' stamp: ''!
model: anInspectorModel

	model := anInspectorModel.
	self updateTitle.
	self updateList! !

!StInspector methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	super initializeWindow: aWindowPresenter.
	aWindowPresenter 
		title: self windowTitle;
		windowIcon: self windowIcon;
		initialExtent: self class preferredExtent;
		whenOpenedDo: [ self takeKeyboardFocus ];
		whenFocusReceivedDo: [ self startProcessing ];
		whenFocusLostDo: [ self stopProcessing ];
		whenClosedDo: [ self stopProcessing ];
		whenResizingDo: [ :ann | self preferredExtent: ann newSize ]! !

!StInspector methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: anInspectorModel

	model := anInspectorModel! !

!StInspector methodsFor: 'initialization' stamp: ''!
windowIcon
	
	^ self application iconNamed: #smallInspectIt! !

!StInspector methodsFor: 'accessing' stamp: ''!
firstPage

	^ millerList pages first! !

!StInspector methodsFor: 'initialization' stamp: ''!
initializePresenters

	millerList := self instantiate: SpMillerPaginatorPresenter.
	millerList millerListPresenter
		spacing: self spacing;
		presenterBlock: [ :aModel | self newInspectorFor: aModel ];
		setRootModel: self model;
		whenColumnsWillChangeDo: [ self keepLastPageSelectedTabName ]! !

!StInspector methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!StInspector methodsFor: 'private - factory' stamp: ''!
newInspectorFor: aModel
	| newInspector |

	newInspector := self
		instantiate: aModel defaultObjectInspectorClass
		on: aModel asInspectorModel.
	self class inspectorDiveOnSingleClick 
		ifTrue: [ newInspector activateOnSingleClick ].
	
	millerList pages ifNotEmpty: [ :pages | 
		newInspector 
			"prepare to close"
			whenClosedDo: [ millerList removeAllFrom: newInspector  ];
			"select last shown page (or default)"
			trySelectAnyPageWithName: { 
				lastPageSelectedTabName. 
				pages last selectedPageName } ].
		
	^ newInspector! !

!StInspector methodsFor: 'accessing' stamp: ''!
spacing
	
	^ self class defaultSpacing! !

!StInspector methodsFor: 'private - stepping' stamp: ''!
stopProcessing

	StInspectorRefreshService uniqueInstance unregister: self! !

!StInspector class methodsFor: 'instance creation' stamp: ''!
openOn: anObject

	^ (self onObject: anObject) openWithSpec! !

!StInspector class methodsFor: 'instance creation' stamp: ''!
inspector: anObject
	
	self 
		deprecated: 'Use #inspect: instead.'
		transformWith: '`@receiver inspector: `@statements1'
				-> '`@receiver inspect: `@statements1'.

	^ self openOn: anObject! !

!StInspector class methodsFor: 'instance creation' stamp: ''!
explore: anObject
 
	self openOn: anObject.
	^ anObject! !

!StInspector class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: #millerList;
		yourself! !

!StInspector class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>

	(aBuilder group: #inspector)
		parent: #tools;
		label: 'Inspector';
		description: 'Inspector'.
		
	(aBuilder setting: #inspectorDiveOnSingleClick)
		parent: #inspector;
		default: self inspectorDiveOnSingleClick;
		target: self;
		description: 'Whether inspector will dive with single or double click';
		label: 'Dive on single click'! !

!StInspector class methodsFor: 'instance creation' stamp: ''!
inspect: anObject

	^ self openOn: anObject! !

!StInspector class methodsFor: 'class initialization' stamp: ''!
initialize

	self register! !

!StInspector class methodsFor: 'instance creation' stamp: ''!
inspect: anObject label: aString

	(self openOn: anObject) title: aString.
	^ anObject
! !

!StInspector class methodsFor: 'settings' stamp: ''!
indexableDisplayLimit: aNumber

	IndexableDisplayLimit := aNumber! !

!StInspector class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	"self registerToolsOn: Smalltalk tools " 
	registry register: self as: #inspector! !

!StInspector class methodsFor: 'settings' stamp: ''!
inspectorDiveOnSingleClick

	^ InspectorDiveOnSingleClick ifNil: [
		InspectorDiveOnSingleClick := self defaultInspectorDiveOnSingleClick ]! !

!StInspector class methodsFor: 'settings' stamp: ''!
indexableDisplayLimit

	^ IndexableDisplayLimit ifNil: [ 5000 ]! !

!StInspector class methodsFor: 'settings' stamp: ''!
defaultInspectorDiveOnSingleClick

	^ true! !

!StInspector class methodsFor: 'accessing' stamp: ''!
defaultSpacing

	^ 3! !

!StInspector class methodsFor: 'settings' stamp: ''!
inspectorDiveOnSingleClick: aBoolean

	InspectorDiveOnSingleClick := aBoolean! !

!StInspector class methodsFor: 'accessing' stamp: ''!
preferredExtent
	
	^ preferredExtent ifNil: [ preferredExtent := self defaultPreferredExtent ]! !

!StInspector class methodsFor: 'accessing' stamp: ''!
defaultPreferredExtent

	^ 700@500! !

!StInspector class methodsFor: 'instance creation' stamp: ''!
onObject: anObject

	^ self on: (StInspectorModel on: anObject)! !

!StInspector class methodsFor: 'tools registry' stamp: ''!
register
	<script>

	self registerToolsOn: Smalltalk tools! !

!StInspector class methodsFor: 'accessing' stamp: ''!
preferredExtent: aPoint
	
	preferredExtent := aPoint! !

!StInspectorAssociationNode methodsFor: 'actions' stamp: ''!
save: aValue
	self hostObject put: aValue! !

!StInspectorAssociationNode methodsFor: 'accessing' stamp: ''!
variableTag
	^ 'association'! !

!StInspectorAssociationNode methodsFor: 'accessing' stamp: ''!
key

	^ self hostObject key! !

!StInspectorAssociationNode methodsFor: 'accessing' stamp: ''!
rawValue

	^ self hostObject value! !

!StInspectorAssociationNode class methodsFor: 'instance creation' stamp: ''!
hostObject: anObject index: index
	^ (self hostObject: anObject)
		index: index;
		yourself! !

!StInspectorBaseTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ self subclassResponsibility! !

!StInspectorBaseTest methodsFor: 'private - utilities' stamp: ''!
waitUntilUIRedrawed

	backendForTest waitUntilUIRedrawed! !

!StInspectorBaseTest methodsFor: 'running' stamp: ''!
tearDown

	presenter withWindowDo: [ :window | window close ].
	super tearDown! !

!StInspectorBaseTest methodsFor: 'running' stamp: ''!
initializeInstanceBeforeInitialization: aPresenter
	! !

!StInspectorBaseTest methodsFor: 'running' stamp: ''!
initializeInstance: aPresenter
	! !

!StInspectorBaseTest methodsFor: 'private - utilities' stamp: ''!
openInstance

	presenter openWithSpec! !

!StInspectorBaseTest methodsFor: 'private - utilities' stamp: ''!
waitUntilContentsAreFlush
		
	20 milliSeconds wait
	! !

!StInspectorBaseTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	backendForTest := SpMorphicBackendForTest new.
	application := StPharoApplication new.
			
	presenter := self classToTest basicNew. 
	self initializeInstanceBeforeInitialization: presenter.
	presenter application: application.
	presenter initialize.
	self initializeInstance: presenter! !

!StInspectorBaseTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self = StInspectorBaseTest ]! !

!StInspectorBrowseSelectedCommand commentStamp: ''!
Browse current selected object.!
!StInspectorBrowseSelectedCommand methodsFor: 'converting' stamp: ''!
asSpecCommand

	^ super asSpecCommand 
		iconName: #smallSystemBrowser;
		yourself! !

!StInspectorBrowseSelectedCommand methodsFor: 'execution' stamp: ''!
interestingObject

	^ self context selectedObject! !

!StInspectorBrowseSelectedCommand methodsFor: 'execution' stamp: ''!
execute 

	self interestingObject browse! !

!StInspectorBrowseSelectedCommand class methodsFor: 'documentation' stamp: ''!
documentContextRequiredSelectors

	^ super documentContextRequiredSelectors, #(selectedObject)! !

!StInspectorBrowseSelectedCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Browse this instance class definition'! !

!StInspectorBrowseSelectedCommand class methodsFor: 'default' stamp: ''!
defaultName
	<toolbarInspectCommand: 30>

	^ 'Browse'! !

!StInspectorCommand commentStamp: ''!
A base for inspector toolbar commands.!
!StInspectorCommand methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self description: (String streamContents: [ :stream | 
		stream 
			<< self class defaultName
			<< ': '
			<< self class defaultDescription ])	! !

!StInspectorCommand methodsFor: 'converting' stamp: ''!
asSpecCommand
	| command |
	
	command := super asSpecCommand.
	self shortcutKey ifNotNil: [ :key | command shortcutKey: key ].
	self defaultIconName
		ifNotNil: [ :iconName | command iconName: iconName ].
	
	^ command! !

!StInspectorCommand methodsFor: 'execution' stamp: ''!
interestingObject

	^ self model inspectedObject! !

!StInspectorCommand methodsFor: 'testing' stamp: ''!
appliesTo: anInspector

	^ true! !

!StInspectorCommand methodsFor: 'accessing' stamp: ''!
owner 
	
	^ self context owner! !

!StInspectorCommand methodsFor: 'accessing' stamp: ''!
model

	^ self context model! !

!StInspectorCommand methodsFor: 'converting' stamp: ''!
shortcutKey

	^ self class defaultShortcutKey! !

!StInspectorCommand methodsFor: 'converting' stamp: ''!
defaultIconName

	^ self class defaultIconName! !

!StInspectorCommand class methodsFor: 'default' stamp: ''!
defaultShortcutKey

	^ nil! !

!StInspectorCommand class methodsFor: 'instance creation' stamp: ''!
toolbarCommandsFor: inspector

	^ self
		instantiateCommandsFromPragma: #toolbarInspectCommand:
		for: inspector! !

!StInspectorCommand class methodsFor: 'documentation' stamp: ''!
documentContextRequiredSelectors
		
	^ #()! !

!StInspectorCommand class methodsFor: 'documentation' stamp: ''!
addDocumentContextRequiredSelectors: aBuilder
	| requiredSelectors |

	requiredSelectors := self documentContextRequiredSelectors. 

	aBuilder newLine.
	aBuilder header: [ :builder | builder text: 'Required Context API' ] withLevel: 2.	
	requiredSelectors 
		ifNotEmpty: [ 
			aBuilder text: 'To work properly, the context passed to this command has to implement the following vocabulary (See `CmCommand>>#context:`).'.
			aBuilder newLine.
			aBuilder unorderedListDuring: [  
				(requiredSelectors sorted) do: [ :each |
					aBuilder item: [
						aBuilder monospace: each ] ] ] ]
		ifEmpty: [ 
			aBuilder text: '(No required API is defined)' ]! !

!StInspectorCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ nil! !

!StInspectorCommand class methodsFor: 'documentation' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	super buildMicroDownUsing: aBuilder withComment: aString.
	self addDocumentContextRequiredSelectors: aBuilder! !

!StInspectorDynamicNode commentStamp: ''!
I am a variable node for representing any dynamically computed attribute that should be displayed in the Raw presentation. 
I should not be used for slots or indexed variables.!
!StInspectorDynamicNode methodsFor: 'accessing' stamp: ''!
variableTag
	^  tag ifNil: [ super variableTag ]! !

!StInspectorDynamicNode methodsFor: 'accessing' stamp: ''!
label: aString
	label := aString! !

!StInspectorDynamicNode methodsFor: 'accessing' stamp: ''!
rawValue: anObject
	value := anObject! !

!StInspectorDynamicNode methodsFor: 'accessing' stamp: ''!
key
	^ label! !

!StInspectorDynamicNode methodsFor: 'accessing' stamp: ''!
variableTag: aTag
	tag := aTag! !

!StInspectorDynamicNode methodsFor: 'accessing' stamp: ''!
rawValue

	^ value! !

!StInspectorDynamicNode methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!StInspectorDynamicNode class methodsFor: 'instance creation' stamp: ''!
hostObject: anObject label: aString value: anotherObject
	^ (self hostObject: anObject) 
		label: aString;
		rawValue: anotherObject;
		yourself! !

!StInspectorIndexedNode commentStamp: ''!
I am a variable node for representing the indexed variables of an object. 
I used the index of a variable as a key. 
I extract the value from the host object every time #rawValue is called!
!StInspectorIndexedNode methodsFor: 'accessing' stamp: ''!
index
	^ index! !

!StInspectorIndexedNode methodsFor: 'actions' stamp: ''!
save: aValue
	self hostObject at: self index put: aValue! !

!StInspectorIndexedNode methodsFor: 'accessing' stamp: ''!
variableTag
	^ 'inst. var'! !

!StInspectorIndexedNode methodsFor: 'comparing' stamp: ''!
= anObject

	^ super = anObject and: [ index = anObject index ]! !

!StInspectorIndexedNode methodsFor: 'comparing' stamp: ''!
hash

	^ index hash! !

!StInspectorIndexedNode methodsFor: 'accessing' stamp: ''!
key
	^ self index! !

!StInspectorIndexedNode methodsFor: 'accessing' stamp: ''!
rawValue

	^ self hostObject basicAt: index! !

!StInspectorIndexedNode methodsFor: 'as yet unclassified' stamp: ''!
debuggerColor
	^(SHRBTextStyler new attributesFor: #instVar) first color! !

!StInspectorIndexedNode methodsFor: 'accessing' stamp: ''!
index: anInteger
	index := anInteger! !

!StInspectorIndexedNode methodsFor: 'accessing' stamp: ''!
errorMessage
	^ 'error obtaining indexed variable value'! !

!StInspectorIndexedNode class methodsFor: 'instance creation' stamp: ''!
hostObject: anObject index: index
	^ (self hostObject: anObject)
		index: index;
		yourself! !

!StInspectorInspectSelectedCommand commentStamp: ''!
Open an inspector on current selected object. !
!StInspectorInspectSelectedCommand methodsFor: 'execution' stamp: ''!
interestingObject

	^ self context selectedObject! !

!StInspectorInspectSelectedCommand methodsFor: 'execution' stamp: ''!
execute 

	self interestingObject stInspect! !

!StInspectorInspectSelectedCommand class methodsFor: 'documentation' stamp: ''!
documentContextRequiredSelectors

	^ super documentContextRequiredSelectors, #(selectedObject)! !

!StInspectorInspectSelectedCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ #smallInspectIt! !

!StInspectorInspectSelectedCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Inspect this instance'! !

!StInspectorInspectSelectedCommand class methodsFor: 'default' stamp: ''!
defaultName
	<toolbarInspectCommand: 20>

	^ 'Inspect'! !

!StInspectorMockObject methodsFor: 'inspector extensions' stamp: ''!
methodWithFailingPresentation
	<inspectorPresentationOrder: 0 title: 'PresentationWithFailingPresentation'>

	self error! !

!StInspectorMockObject methodsFor: 'inspector extensions' stamp: ''!
methodWithHaltingContextContext: aContext
	
	"This selector is automatically called by concatenating Context: to an inspector presentation"
	<haltOrBreakpointForTesting>
	
	self halt! !

!StInspectorMockObject methodsFor: 'inspector extensions' stamp: ''!
inspectionMock1
	<inspectorPresentationOrder: 0 title: 'Mock 1'>

	^ SpLabelPresenter new
		label: 'Test';
		yourself! !

!StInspectorMockObject methodsFor: 'inspector extensions' stamp: ''!
methodWithDnuingContextContext: aContext
	
	"This selector is automatically called by concatenating Context: to an inspector presentation"
	
	self iShouldNotUnderstandThis! !

!StInspectorMockObject methodsFor: 'inspector extensions' stamp: ''!
methodWithFailingContext
	<inspectorPresentationOrder: 0 title: 'PresentationWithFailingContext'>

	^ SpLabelPresenter new
		label: 'Test';
		yourself! !

!StInspectorMockObject methodsFor: 'inspector extensions' stamp: ''!
methodWithHaltingContext
	<inspectorPresentationOrder: 0 title: 'PresentationWithHaltingContext'>

	^ SpLabelPresenter new
		label: 'Test';
		yourself! !

!StInspectorMockObject methodsFor: 'inspector extensions' stamp: ''!
methodWithHaltingPresentation
	<inspectorPresentationOrder: 0 title: 'PresentationWithHaltingContext'>
	<haltOrBreakpointForTesting>
	
	self halt! !

!StInspectorMockObject methodsFor: 'inspector extensions' stamp: ''!
methodWithDnuingPresentation
	<inspectorPresentationOrder: 0 title: 'PresentationWithDNUingContext'>

	self iShouldNotUnderstandThis! !

!StInspectorMockObject methodsFor: 'inspector extensions' stamp: ''!
methodWithDnuingContext
	<inspectorPresentationOrder: 0 title: 'PresentationWithDNUingContext'>

	^ SpLabelPresenter new
		label: 'Test';
		yourself! !

!StInspectorMockObject methodsFor: 'inspector extensions' stamp: ''!
methodWithFailingContextContext: aContext
	
	"This selector is automatically called by concatenating Context: to an inspector presentation"
	
	self error! !

!StInspectorMockObjectSubclass methodsFor: 'as yet unclassified' stamp: ''!
inspectionMock1Context: aContext

	aContext active: false! !

!StInspectorModel commentStamp: ''!
An model to provide inspector data on an inspected object.
The inspector wraps all inspected objects with this to being able to display values. !
!StInspectorModel methodsFor: 'accessing' stamp: ''!
inspectedObject

	^ inspectedObject! !

!StInspectorModel methodsFor: 'converting' stamp: ''!
asInspectorModel

	^ self! !

!StInspectorModel methodsFor: 'accessing' stamp: ''!
inspectedObject: anObject

	inspectedObject := anObject! !

!StInspectorModel methodsFor: 'accessing' stamp: ''!
allInspectorNodes

	^ self inspectedObject allInspectorNodes! !

!StInspectorModel methodsFor: 'accessing' stamp: ''!
descriptionStringFor: object
	| header printString |
	
	header := (object class name first isVowel
		ifTrue: [ 'an ' ]
		ifFalse: [ 'a ' ]) , 
		object class name.
	
	printString := self smallDescriptionStringFor: object.
	^ ((printString beginsWith: header)
		ifTrue: [ printString ]
		ifFalse: [ 
			String streamContents: [ :out | 
				out << header; << ' ('; << printString; << ')' ] ])! !

!StInspectorModel methodsFor: 'accessing' stamp: ''!
labelString
	
	^ self descriptionString truncateWithElipsisTo: 30! !

!StInspectorModel methodsFor: 'accessing' stamp: ''!
objectInspectionContexts

	^ self inspectedObject inspectionContexts! !

!StInspectorModel methodsFor: 'accessing' stamp: ''!
descriptionString

	^ self descriptionStringFor: self inspectedObject! !

!StInspectorModel methodsFor: 'printing' stamp: ''!
printOn: stream

	super printOn: stream.
	stream << '('.
	stream print: self inspectedObject.
	stream << ')'! !

!StInspectorModel methodsFor: 'accessing' stamp: ''!
smallDescriptionString
	
	^ (StObjectPrinter asTruncatedTextFrom: self inspectedObject) asString! !

!StInspectorModel methodsFor: 'accessing' stamp: ''!
smallDescriptionStringFor: anObject
	
	^ (StObjectPrinter asTruncatedTextFrom: anObject) asString! !

!StInspectorModel methodsFor: 'accessing' stamp: ''!
windowTitle

	^ 'Inspector on {1}' format:
		  { ([ self inspectedObject displayString ]
			   on: Exception
			   do: [ :e | e printString ]) }! !

!StInspectorModel methodsFor: 'accessing' stamp: ''!
behavior 
	
	^ self inspectedObject class! !

!StInspectorModel class methodsFor: 'instance creation' stamp: ''!
new 

	self error: 'Use #on:'! !

!StInspectorModel class methodsFor: 'instance creation' stamp: ''!
on: anObject

	^ super new inspectedObject: anObject! !

!StInspectorNode commentStamp: ''!
I model an attribute of an object in the `StInspector`. I am used in the Raw presentation of an Object. My main responsibility is to associate a variable name of a host object with its value. 

Public API and Key Messages

- hostObject return the object (host) holding the  attribute that I represent;
- label return a string label of the attribute, which may be an instance variable name or a dynamically generated name for dynamic attributes;
- value return the value  of the attribute; catches any errors and returns nil;
- rawValue return the value of the attribute without any catch for errors;
- key return an object used as unique key to identify an attribute, it may be an integer for indexed variables or a string for dynamic ones.
!
!StInspectorNode methodsFor: 'actions' stamp: ''!
save: aValue! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
variableTag
	^ 'implicit'! !

!StInspectorNode methodsFor: 'comparing' stamp: ''!
= anObject

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].
	^ hostObject == anObject hostObject! !

!StInspectorNode methodsFor: 'comparing' stamp: ''!
hash

	^ hostObject hash! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
mementoValue

	^ self value! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
key
	"Answer the key of this object variable (slot, indexed attribute, computed value)."
	^ self subclassResponsibility! !

!StInspectorNode methodsFor: 'private' stamp: ''!
iconError: error
	
	^ self iconNamed: #smallWarningIcon! !

!StInspectorNode methodsFor: 'converting' stamp: ''!
asInspectorModel

	^ StInspectorModel on: self rawValue! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
children 
	
	^ self value allInspectorNodes! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
rawValue
	"Answer the object value of this object variable (slot, indexed attribute, computed value)."
	^ self subclassResponsibility! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
value
	"Answer the object value of this object variable (slot, indexed attribute, computed value).
	Return nil in case there is an error obtaining the value"
	^ [ self rawValue ] on: Exception do: [ nil ]! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
icon

	^ [ self value inspectorIcon ifNil: [ self value class systemIcon ] ]
		  on: Error
		  do: [ :error | self iconError: error ]! !

!StInspectorNode methodsFor: '*NewTools-Debugger' stamp: ''!
debuggerColor
	^(SHRBTextStyler new attributesFor: #comment) first color! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
hostObject: anObject

	"
	Allow nil objects for the moment. Normally the inspector should be able to inspect nil.
	self
		assert: [ anObject isNotNil ]
		description: [ 'Host object must not be nil' ]."

	self
		assert: [ hostObject isNil ]
		description: [ 'Host can be assigned only once' ].

	hostObject := anObject! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
stringValue

	^ self value stDisplayString! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
hostObject
	^ hostObject! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
label
	"Answer the label of this object variable (slot, indexed attribute, computed value)."
	^ self key asString! !

!StInspectorNode methodsFor: 'accessing' stamp: ''!
errorMessage
	^ 'error obtaining value'! !

!StInspectorNode class methodsFor: 'instance creation' stamp: ''!
hostObject: anObject 
	^ self new
		hostObject: anObject;
		yourself! !

!StInspectorRefreshCommand commentStamp: ''!
A command to show the refresh content option for inspectors.!
!StInspectorRefreshCommand methodsFor: 'execution' stamp: ''!
execute 

	self context refreshContent! !

!StInspectorRefreshCommand class methodsFor: 'documentation' stamp: ''!
documentContextRequiredSelectors

	^ super documentContextRequiredSelectors, #(refreshContent)! !

!StInspectorRefreshCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ #glamorousRefresh! !

!StInspectorRefreshCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Refresh current panel'! !

!StInspectorRefreshCommand class methodsFor: 'default' stamp: ''!
defaultName
	<toolbarInspectCommand: 10>

	^ 'Refresh'! !

!StInspectorRefreshService commentStamp: ''!
I'm a service to process refresh of inspectors. 
I keep a registry of all opened inspectors and execute the required stepping (by default every 500ms), but I'm only active if I have inspectors registered (otherwise, I will stop until a new inspector is registered) !
!StInspectorRefreshService methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self stepDelay: 1000 milliSeconds.
	mutex := Mutex new.
	inspectors := Set new! !

!StInspectorRefreshService methodsFor: 'stepping' stamp: ''!
stepService

	inspectors do: [ :each | each step ]! !

!StInspectorRefreshService methodsFor: 'accessing' stamp: ''!
name
	
	^ 'StInspector Refresh Service'! !

!StInspectorRefreshService methodsFor: 'registry' stamp: ''!
register: anInspector

	mutex critical: [ 
		inspectors add: anInspector.
		self isRunning ifFalse: [ 
			self start ] ].! !

!StInspectorRefreshService methodsFor: 'registry' stamp: ''!
unregister: anInspector

	mutex critical: [ 
		inspectors remove: anInspector ifAbsent: [ ].
		inspectors ifEmpty: [ 
			self stop ] ]! !

!StInspectorRefreshService class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Use #uniqueInstance'! !

!StInspectorRefreshService class methodsFor: 'instance creation' stamp: ''!
uniqueInstance

	^ uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! !

!StInspectorSelfNode commentStamp: ''!
I model the `self` variable. This the value of this variable is always the host object. !
!StInspectorSelfNode methodsFor: 'accessing' stamp: ''!
key
	^ 'self'! !

!StInspectorSelfNode methodsFor: 'accessing' stamp: ''!
children
 
	^ #()! !

!StInspectorSelfNode methodsFor: 'accessing' stamp: ''!
rawValue

	^ self hostObject! !

!StInspectorSelfNode methodsFor: '*NewTools-Debugger' stamp: ''!
debuggerColor
	^(SHRBTextStyler new attributesFor: #self) first color ! !

!StInspectorSlotNode commentStamp: ''!
I am a variable node for representing the slots of an object. I used the name of a slot as a key. I extract the value from the host object every time #rawValue is called.!
!StInspectorSlotNode methodsFor: 'actions' stamp: ''!
save: anObject

	self hostObject 
		writeSlot: self slot 
		value: anObject! !

!StInspectorSlotNode methodsFor: 'accessing' stamp: ''!
variableTag
	^ 'inst. var'! !

!StInspectorSlotNode methodsFor: 'comparing' stamp: ''!
= anObject

	^ super = anObject and: [ slot = anObject slot ]! !

!StInspectorSlotNode methodsFor: 'comparing' stamp: ''!
hash

	^ super hash bitXor: slot hash! !

!StInspectorSlotNode methodsFor: 'accessing' stamp: ''!
key
	^ self slot name! !

!StInspectorSlotNode methodsFor: 'accessing' stamp: ''!
slot: aSlot

	self
		assert: [ aSlot isNotNil ]
		description: [ 'Slot can not be nil' ].

	slot := aSlot.! !

!StInspectorSlotNode methodsFor: 'accessing' stamp: ''!
rawValue

	^  slot read: self hostObject! !

!StInspectorSlotNode methodsFor: 'printing' stamp: ''!
printOn: stream 

	super printOn: stream.
	stream << '(' << self slot name << ')'! !

!StInspectorSlotNode methodsFor: 'accessing' stamp: ''!
slot
	^ slot! !

!StInspectorSlotNode methodsFor: '*NewTools-Debugger' stamp: ''!
debuggerColor
	^(SHRBTextStyler new attributesFor: #instVar) first color! !

!StInspectorSlotNode methodsFor: 'accessing' stamp: ''!
errorMessage
	^ 'error obtaining variable value'! !

!StInspectorSlotNode class methodsFor: 'instance creation' stamp: ''!
hostObject: anObject slot: aSlot
	^ (self hostObject: anObject)
		slot: aSlot;
		yourself! !

!StInspectorStackTopNode commentStamp: ''!
A model for the `top` stack node. 
This is to be used when debugging.!
!StInspectorStackTopNode methodsFor: 'accessing' stamp: ''!
key
	^ 'stackTop'! !

!StInspectorStackTopNode methodsFor: 'accessing' stamp: ''!
children
 
	^ #()! !

!StInspectorStackTopNode methodsFor: 'accessing' stamp: ''!
rawValue

	^ self hostObject stackPtr > 0
		ifTrue: [ self hostObject top ]
		ifFalse: [ #emptyStack ]! !

!StInspectorStackTopNode methodsFor: '*NewTools-Debugger' stamp: ''!
debuggerColor
	^(SHRBTextStyler new attributesFor: #thisContext) first color! !

!StInspectorTempNode commentStamp: ''!
I am a variable node for representing a temporary variable stored in a Context object that has a name attached. 
This includes  local variables and method parameters.!
!StInspectorTempNode methodsFor: 'accessing' stamp: ''!
variableTag

	^ tempVariable variableTag! !

!StInspectorTempNode methodsFor: 'comparing' stamp: ''!
= anObject

	"Answer whether the receiver and anObject represent the same object."

	self == anObject ifTrue: [ ^ true ].
	self class = anObject class ifFalse: [ ^ false ].
	^ tempVariable = anObject tempVariable and: [ 
		  hostObject = anObject hostObject ]! !

!StInspectorTempNode methodsFor: 'comparing' stamp: ''!
hash

	"Answer an integer value that is related to the identity of the receiver."

	^ tempVariable hash bitXor: (hostObject hash)! !

!StInspectorTempNode methodsFor: 'accessing' stamp: ''!
key
	^ tempVariable name! !

!StInspectorTempNode methodsFor: 'accessing' stamp: ''!
tempVariable
	^ tempVariable! !

!StInspectorTempNode methodsFor: 'accessing' stamp: ''!
children
	^ #()! !

!StInspectorTempNode methodsFor: 'accessing' stamp: ''!
rawValue
	"Answer the object value of this object variable (slot, indexed attribute, computed value)."

	^ [ 
		"we use #tempNamed: to force a re-lookup of the variable"
		self hostObject tempNamed: tempVariable name]
		  on: Exception
		  do: [ :err | 'cannot read ' , tempVariable name ]! !

!StInspectorTempNode methodsFor: 'accessing' stamp: ''!
tempVariable: anObject
	tempVariable := anObject! !

!StInspectorTempNode methodsFor: 'accessing' stamp: ''!
debuggerColor
	^ tempVariable debuggerColors! !

!StInspectorTest methodsFor: 'running' stamp: ''!
tearDown

	inspector window 
		ifNotNil: [ :window | window close ].
	super tearDown! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testConfigureContextWithErrorShouldMarkContextAsError


	| collector pragma context |
	collector := StInspectionCollector on: StInspectorMockObject new.
	pragma := (StInspectorMockObject >> #methodWithFailingContext) pragmas first.

	context := collector contextFromPragma: pragma.
	self assert: context isErrorContext! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testConfigureContextWithHaltShouldMarkContextAsError


	| collector pragma context |
	collector := StInspectionCollector on: StInspectorMockObject new.
	pragma := (StInspectorMockObject >> #methodWithHaltingContext) pragmas first.

	context := collector contextFromPragma: pragma.
	self assert: context isErrorContext! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testContextSelectorForNonBuilderSelector

	| c |
	c := StInspectionContext new methodSelector: #selectorWithoutArgument.
	
	self 
		assert: c contextMethodSelector
		equals: #selectorWithoutArgumentContext:! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testBuildPresentationWithDoesNotUndertandShouldReturnCodePresenter


	| collector pragma context |
	collector := StInspectionCollector on: StInspectorMockObject new.
	pragma := (StInspectorMockObject >> #methodWithDnuingPresentation) pragmas first.

	context := collector contextFromPragma: pragma.
	
	"Smoke test -> creating an inspection presenter should not fail. Instead it should create an error presenter"
	context newInspectionPresenter! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testBuildPresentationWithFailureShouldReturnCodePresenter


	| collector pragma context |
	collector := StInspectionCollector on: StInspectorMockObject new.
	pragma := (StInspectorMockObject >> #methodWithFailingPresentation) pragmas first.

	context := collector contextFromPragma: pragma.
	
	"Smoke test -> creating an inspection presenter should not fail. Instead it should create an error presenter"
	context newInspectionPresenter! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testConfigureContextWithDoesNotUnderstandShouldMarkContextAsError


	| collector pragma context |
	collector := StInspectionCollector on: StInspectorMockObject new.
	pragma := (StInspectorMockObject >> #methodWithDnuingContext) pragmas first.

	context := collector contextFromPragma: pragma.
	self assert: context isErrorContext! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testFirstPage

	inspector openWithSpec.
	self assert: inspector firstPage notNil.
	self assert: (inspector firstPage isKindOf: StObjectInspectorPresenter)! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testContextSelectorForBuilderSelector

	| c |
	c := StInspectionContext new methodSelector: #selectorWithArgument:.
	
	self 
		assert: c contextMethodSelector
		equals: #selectorWithArgumentContext:! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testDefineContextInSubclass

	| c |
	c := StInspectionCollector on: StInspectorMockObjectSubclass new.

	self deny: (c contextFromPragma: (StInspectorMockObject >> #inspectionMock1) pragmas first) isActive! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testModel

	self assert: inspector model inspectedObject equals: 42.
	
	inspector model: (StInspectorModel on: #fourtytwo).
	
	self assert: inspector model inspectedObject equals: #fourtytwo.
	self assert: inspector firstPage model equals: inspector model! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testDefaultKeyboardFocus

	inspector openWithSpec.
	self 
		assert: inspector defaultKeyboardFocus 
		equals: inspector millerList presenters first! !

!StInspectorTest methodsFor: 'tests' stamp: ''!
testBuildPresentationWithHaltShouldReturnCodePresenter


	| collector pragma context |
	collector := StInspectionCollector on: StInspectorMockObject new.
	pragma := (StInspectorMockObject >> #methodWithHaltingPresentation) pragmas first.

	context := collector contextFromPragma: pragma.
	
	"Smoke test -> creating an inspection presenter should not fail. Instead it should create an error presenter"
	context newInspectionPresenter! !

!StInspectorTest methodsFor: 'running' stamp: ''!
setUp
	
	super setUp.
	inspector := StInspector onObject: 42
	! !

!StInspectorThisContextNode commentStamp: ''!
A model for the `thisContext` variable.
This is to be used when debugging.!
!StInspectorThisContextNode methodsFor: 'accessing' stamp: ''!
key
	^ 'thisContext'! !

!StInspectorThisContextNode methodsFor: 'accessing' stamp: ''!
children 
	
	^ self value allInspectorNodes! !

!StInspectorThisContextNode methodsFor: '*NewTools-Debugger' stamp: ''!
debuggerColor
	^(SHRBTextStyler new attributesFor: #thisContext) first color! !

!StInspectorWrapperNode commentStamp: ''!
I am a node that wraps in the host object another node and delegates all API methods to the wrapped node. I can further provide a different label for the wrapped node.!
!StInspectorWrapperNode methodsFor: 'accessing' stamp: ''!
variableTag
	^ self hostObject variableTag! !

!StInspectorWrapperNode methodsFor: 'accessing' stamp: ''!
label: aString
	label := aString! !

!StInspectorWrapperNode methodsFor: 'accessing' stamp: ''!
key
	^ label ifNil: [ self hostObject key ]! !

!StInspectorWrapperNode methodsFor: 'accessing' stamp: ''!
rawValue

	^ self hostObject rawValue! !

!StInspectorWrapperNode methodsFor: 'accessing' stamp: ''!
errorMessage
	^ self hostObject errorMessage! !

!StInspectorWrapperNode class methodsFor: 'instance creation' stamp: ''!
hostObject: anObject label: aString
	^ (self hostObject: anObject) 
		label: aString;
		yourself! !

!StIterator commentStamp: ''!
I represent an abstract Iterator.
My subclasses should implement #next, #doReset, and #atEnd.

I implement some construction messages to ease the construction of chains of iterators.

#, allows to create sequence of iterators, the results are from the first one, then from the second one and so on. 

#asBeginsWithFilter
Creates an iterator that allows to filter by a string, comparing with beginsWith:, with an starting filter of ''.
#beginsWithFilter: aString
Create an iterator that allows to filter by a string, comparing with beginsWith:, with an starting filter of aString.

#asSubStringFilter
Creates an iterator that allows to filter by a string, comparing with substring:, with an starting filter of ''.

#substringFilter: aString
Create an iterator that allows to filter by a string, comparing with substring:, with an starting filter of aString.

#asWithoutDuplicates 
Creates an itearator that returns no duplicates.!
!StIterator methodsFor: 'filtering' stamp: ''!
asBeginsWithFilter
	
	^ self beginsWithFilter: ''! !

!StIterator methodsFor: 'accessing' stamp: ''!
next

	self subclassResponsibility ! !

!StIterator methodsFor: 'filtering' stamp: ''!
asWithoutDuplicates
	
	^ StWithoutDuplicatesDecorator on: self! !

!StIterator methodsFor: 'protected' stamp: ''!
doReset
	
	^ self subclassResponsibility! !

!StIterator methodsFor: 'initialization' stamp: ''!
next: aQuantity

	^ OrderedCollection streamContents: [ :stream | | total last |
			total := 0.
			[ (last := self next).
				last ifNotNil: [  
					stream nextPut: last.
					total := total + 1 ] ]
				doWhileTrue: [ total < aQuantity and: [ last notNil ] ] ]! !

!StIterator methodsFor: 'filtering' stamp: ''!
select: aBlockClosure 
	
	^ StFilter on: self with: aBlockClosure ! !

!StIterator methodsFor: 'accessing' stamp: ''!
upToEnd

	^ OrderedCollection
		streamContents:
			[ :stream | [ self atEnd ] whileFalse: [ stream nextPut: self next ] ]! !

!StIterator methodsFor: 'filtering' stamp: ''!
asSubstringFilter
	
	^ self substringFilter: ''! !

!StIterator methodsFor: 'filtering' stamp: ''!
substringFilter: aString 
	
	^ StSubStringFilter on: self with: aString! !

!StIterator methodsFor: 'filtering' stamp: ''!
beginsWithFilter: aString 
	
	^ StBeginsWithFilter on: self with: aString! !

!StIterator methodsFor: 'sequencing' stamp: ''!
, aStGeneratorIterator 
	
	^ StSequenceIterator with: { self. aStGeneratorIterator }! !

!StIterator methodsFor: 'events' stamp: ''!
onReset: aValuable

	onReset := aValuable! !

!StIterator methodsFor: 'testing' stamp: ''!
atEnd 

	^ self subclassResponsibility ! !

!StIterator methodsFor: 'transforming' stamp: ''!
collect: aBlockClosure 
	
	^ StTransformation on: self with: aBlockClosure! !

!StIterator methodsFor: 'reseting' stamp: ''!
reset

	self doReset.
	onReset ifNotNil: [ onReset value ]! !

!StIterator class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == StIterator! !

!StIteratorBlockDecorator commentStamp: ''!
I implement a simple block decorator, I am a abstract class that have a block.!
!StIteratorBlockDecorator methodsFor: 'accessing' stamp: ''!
block: aBlockClosure

	aBlock := aBlockClosure! !

!StIteratorBlockDecorator class methodsFor: 'instance creation' stamp: ''!
on: aStGeneratorIterator with: aBlockClosure 
	
	^ self new
		inner: aStGeneratorIterator;
		block: aBlockClosure;
		yourself! !

!StIteratorBlockDecorator class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == StIteratorBlockDecorator! !

!StIteratorDecorator commentStamp: ''!
I implement an abstract decorator for the implementors.
I have an iterator in the inner instance variable and all the messages are redirected to it. 
My subclasses can override the required behaviour.!
!StIteratorDecorator methodsFor: 'accessing' stamp: ''!
inner: anObject
	inner := anObject! !

!StIteratorDecorator methodsFor: 'accessing' stamp: ''!
next

	^ inner next! !

!StIteratorDecorator methodsFor: 'protected' stamp: ''!
doReset 
	
	inner reset! !

!StIteratorDecorator methodsFor: 'testing' stamp: ''!
atEnd 

	^ inner atEnd! !

!StIteratorDecorator class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == StIteratorDecorator! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testIteratorOnACollectionReturnsTheFirstValueAndSecondValue

	| it |

	it := StCollectionIterator on: #(1 2 3).
	self assert: (it next) equals: 1.
	self assert: (it next) equals: 2	! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testIteratorOnACollectionWithTwoCollectReturnsCorrectFirstValue

	| it |
	it := ((StCollectionIterator on: #(1 2 3)) collect: [:e | e * 3]) collect: [:e | e * 2].
	self assert: it next equals: 6.
! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testIteratorOnACollectionWithTwoCollectReturnsCorrectValues
	| it |
	
	it := ((StCollectionIterator on: #(1 2 3)) collect: [:e | e * 3]) collect: [:e | e * 2].
	self assertCollection: (it next: 3) hasSameElements: #(6 12 18).
! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testWordsAwareIteratorFiltersByASingleWordFindingNothing

	| inner it |
	
	inner := (StCollectionIterator on: { 'aaa'. 'xxxyyybbb'. 'xxxcccbbb' }) asSubstringFilter.
	it := StWordsAwareFilter new
		inner: inner;
		yourself.
		
	it filteringText: 'zzz'.
	
	self assert: it next equals: nil! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testBeginsWithFilterDoesNotFetchTwiceIfTheFilterIsARefinementOfPreviousText

	| it |
	it := (StGeneratorBlockIterator on: [ :x | x value: 'bbb'; value:'bbb1'; error ]) beginsWithFilter: 'b'.
	it next.
	it beginsWithFilter: 'bb'.
	
	self assert: it next equals: 'bbb'! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testWordsAwareIteratorFiltersLeftOutBecauseSecondWord

	| inner it |
	
	inner := (StCollectionIterator on: { 'aaa'. 'xxxyyybbb'. 'xxxcccbbb' }) asSubstringFilter.
	it := StWordsAwareFilter new
		inner: inner;
		yourself.
		
	it filteringText: 'xxx aaa'.
	
	self assert: it next equals: nil.
! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testWordsAwareIteratorFiltersByASequenceOfWords

	| inner it |
	
	inner := (StCollectionIterator on: { 'aaa'. 'xxxyyybbb'. 'xxxcccbbb' }) asSubstringFilter.
	it := StWordsAwareFilter new
		inner: inner;
		yourself.
		
	it filteringText: 'xxx bbb'.
	
	self assert: it next equals: 'xxxyyybbb'.
	self assert: it next equals: 'xxxcccbbb'	! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testSubstringFilterDoesNotFetchTwiceIfTheFilterIsARefinementOfPreviousText

	| it |
	it := (StGeneratorBlockIterator on: [ :x | x value: '1bbb'; value:'11bbb1'; error ]) substringFilter: 'b'.
	it next.
	it substringFilter: 'bb'.
	
	self assert: it next equals: '1bbb'! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testSubstringFilterReturnsValidResultsWithTheSameFilter
	| it |

	it := (StCollectionIterator on: { 'aaa'. 'xxxbbb'. 'ccc' }) substringFilter: 'b'.
	it substringFilter: 'b'.
	
	self assert: it next equals: 'xxxbbb'! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testNonDuplicatesRemoveDuplicatesWithThree
	| it |
	
	it := (StCollectionIterator on: #(1 1 2 2 3 3)) asWithoutDuplicates.
	self assert: (it next:3) equals: #(1 2 3) asOrderedCollection ! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testSequenceDetectsAtEnd

	| it |
	it := (StCollectionIterator on: #(1 2 3)) , (StCollectionIterator on: #(4 5 6)).
	it next: 3.
	self deny: it atEnd.
	it next: 3.
	self assert: it atEnd.
		

	! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testSequenceReturnsTheSequenceOfAllResults
	| it |
	
	it := (StCollectionIterator on: #(1 2 3)) , (StCollectionIterator on: #(4 5 6)).
	self assertCollection: (it next: 6) hasSameElements: #(1 2 3 4 5 6)! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testIteratorOnACollectionReturnsTheCollection

	| it |
	it := StCollectionIterator on: #(1 2 3).
	self assertCollection: (it next:3) hasSameElements: #(1 2 3)! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testSubstringFilterReturnsValidResults

	| it |
	it := (StCollectionIterator on: { 'xxxaaa'. 'xxxbbb'. 'xxxccc' }) substringFilter: 'b'.
	self assert: it next equals: 'xxxbbb'! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testNonDuplicatesRemoveDuplicates

	| it |
	
	it := (StCollectionIterator on: #(1 1)) asWithoutDuplicates.
	self assert: (it next:1) equals: #(1) asOrderedCollection! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testWordsAwareIteratorFiltersByASequenceOfCamelCaseMixingCase

	| inner it |
	
	inner := (StCollectionIterator on: { 'aaa'. 'xxxyyyBBB'. 'XXXcccbbb'. 'xxxcccbbb' }) asSubstringFilter.
	it := StWordsAwareFilter new
		inner: inner;
		yourself.
		
	it filteringText: 'xxxBbb'.
	
	self assert: it next equals: 'xxxyyyBBB'.
	self assert: it next equals: 'XXXcccbbb'.
	self assert: it next equals: 'xxxcccbbb'	! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testWordsAwareIteratorFiltersByASingleWord

	| inner it |
	
	inner := (StCollectionIterator on: { 'aaa'. 'xxxyyybbb'. 'xxxcccbbb' }) asSubstringFilter.
	it := StWordsAwareFilter new
		inner: inner;
		yourself.
		
	it filteringText: 'xxx'.
	
	self assert: it next equals: 'xxxyyybbb'.
	self assert: it next equals: 'xxxcccbbb'	! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testSequenceReturnsTheSequenceOfAllResultsInParts
	| it |
	
	it := (StCollectionIterator on: #(1 2 3)) , (StCollectionIterator on: #(4 5 6)).
	
	self assertCollection: (it next: 3) hasSameElements: #(1 2 3).
	self assertCollection: (it next: 3) hasSameElements: #(4 5 6)	! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testIteratorOnACollectionReturnsTheFirstValue

	| it |

	it := StCollectionIterator on: #(1 2 3).
	self assert: (it next) equals: 1! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testBeginsWithFilterReturnsValidResults

	| it |
	it := (StCollectionIterator on: { 'aaa'. 'bbb'. 'ccc' }) beginsWithFilter: 'b'.
	self assert: it next equals: 'bbb'! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testIteratorOnACollectionWithCollectReturnsCorrectFirstValue

	| it |
	it := (StCollectionIterator on: #(1 2 3)) collect: [:e | e * 3].
	self assert: (it next) equals: 3.
! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testWordsAwareIteratorFiltersByASequenceOfCamelCase

	| inner it |
	
	inner := (StCollectionIterator on: { 'aaa'. 'xxxyyybbb'. 'xxxcccbbb' }) asSubstringFilter.
	it := StWordsAwareFilter new
		inner: inner;
		yourself.
		
	it filteringText: 'xxxBbb'.
	
	self assert: it next equals: 'xxxyyybbb'.
	self assert: it next equals: 'xxxcccbbb'	! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testNonDuplicatesRemoveDuplicatesResetReturnsWithoutDuplicates

	| it |
	
	it := (StCollectionIterator on: #(1 1 2 2 3 3)) asWithoutDuplicates.
	self assert: (it next:3) equals: #(1 2 3) asOrderedCollection.
	
	it reset. 
	
	self assert: (it next:3) equals: #(1 2 3) asOrderedCollection ! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testWordsAwareIteratorFiltersByASequenceOfCamelCaseWithUppercase

	| inner it |
	
	inner := (StCollectionIterator on: { 'aaa'. 'xxxyyybbb'. 'xxxcccbbb' }) asSubstringFilter.
	it := StWordsAwareFilter new
		inner: inner;
		yourself.
		
	it filteringText: 'XxxBbb'.
	
	self assert: it next equals: 'xxxyyybbb'.
	self assert: it next equals: 'xxxcccbbb'	! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testIteratorOnACollectionWithCollectReturnsCorrectValues

	| it |
	it := (StCollectionIterator on: #(1 2 3)) collect: [:e | e * 3].
	self assertCollection: (it next: 3) hasSameElements: #(3 6 9).
! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testIteratorOnACollectedCollectionIsFiltered

	| it |
	it := ((StCollectionIterator on: #(1 2 3)) 
		collect: [ :e | e * 2 ])
		select: [:e | e even].
	self assertCollection: (it next: 3) hasSameElements: #(2 4 6).
! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testIteratorOnACollectionIsFiltered

	| it |

	it := (StCollectionIterator on: #(1 2 3)) select: [:e | e even].

	self assertCollection: (it next: 3) hasSameElements: #(2).
! !

!StIteratorsTest methodsFor: 'tests' stamp: ''!
testBeginsWithFilterReturnsValidResultsWithTheSameFilter

	| it |
	it := (StCollectionIterator on: { 'aaa'. 'bbb'. 'ccc' }) beginsWithFilter: 'b'.
	it beginsWithFilter: 'b'.
	
	self assert: it next equals: 'bbb'! !

!StLimitArrived commentStamp: ''!
Raises when the limit of candidates to find (defined in `StSpotterPragmaBasedProcessor class>>#defaultItemsLimit`) is reached.!
!StMetaBrowser commentStamp: ''!
A special inspection that shows a simplified browser. 
This inspection allow the user to operate with the class of the instance.

Also, this inspection allows the user to place instance breakpoints (breakpoints that will act when the method where the breakpoint is) is called for the instance being inspected.!
!StMetaBrowser methodsFor: 'private' stamp: ''!
methodsOf: aClass

	aClass ifNil: [ ^ #() ].
	^ aClass methods sorted: #selector ascending
! !

!StMetaBrowser methodsFor: 'accessing' stamp: ''!
selectedObject

	^ self selectedMethod! !

!StMetaBrowser methodsFor: 'initialization' stamp: ''!
classListMenu
	
	^ (self rootCommandsGroup / 'classes') asMenuPresenter ! !

!StMetaBrowser methodsFor: 'accessing' stamp: ''!
selectedClass

	^ classes selection selectedItem! !

!StMetaBrowser methodsFor: 'initialization' stamp: ''!
methodListMenu

	^ (self rootCommandsGroup / 'methods') asMenuPresenter! !

!StMetaBrowser methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
haltInspectedObjectOnCallToSelectedMethod
	|method|
	method := self selectedMethod ifNil:[^self].
	self model haltOnCallTo: method selector! !

!StMetaBrowser methodsFor: 'private - updating' stamp: ''!
updateSourceWith: method

	source userActionDuring: [
		method
			ifNotNil: [ 
				source text: method sourceCode; beForMethod: method  ]
			ifNil: [ 
				source text: ''; clearInteractionModel ] ]! !

!StMetaBrowser methodsFor: 'private - actions' stamp: ''!
compile: aString
	| compiledSelector cursorPosition |

	cursorPosition := source cursorPositionIndex.

	compiledSelector := self selectedMethod methodClass
		compile: aString
		classified: 	self selectedMethod protocol.
	
	self updateMethods: self selectedClass.
	methods items 
		detect: [ :each | each selector = compiledSelector ]
		ifFound: [ :aMethod | 
			methods selectItem: aMethod.
			source cursorPositionIndex: cursorPosition ]! !

!StMetaBrowser methodsFor: 'private - updating' stamp: ''!
updateMethods: aClass
	
	methods items: (aClass
		ifNotNil: [ aClass methods sorted: #selector ascending ]
		ifNil: [ #() ])
	! !

!StMetaBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters
	| classHierarchy |
	
	classHierarchy := self model class withAllSuperclasses reversed.

	classes := self newTreeTable
		addColumn: (SpStringTableColumn title: 'Class hierarchy' evaluated: #name);
		roots: { classHierarchy first };
		children: [ :aClass | classHierarchy select: [ :subclass | subclass superclass == aClass ] ];
		contextMenu: [ self classListMenu ];
		yourself.
	methods := (self instantiate: SpFilteringListPresenter)
		display: [ :each | each selector ];	
		contextMenu: [ self methodListMenu ];
		yourself.

	source := self newCode
		lineNumbers: StPharoSettings codeShowLineNumbers;
		beForMethod: self selectedMethod;
		whenSubmitDo: [ :aString | self compile: aString ];
		whenResetDo: [ self updateSourceWith: self selectedMethod  ];
		yourself.
		
	classes 
		transmitTo: methods 
		transform: [ :aClass | self methodsOf: aClass ].
	methods 
		transmitDo: [ :aMethod | self updateSourceWith: aMethod ].

	classes selectPath: (Array new: classHierarchy size withAll: 1)! !

!StMetaBrowser methodsFor: 'accessing' stamp: ''!
selectedMethod

	^ methods selectedItem! !

!StMetaBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec
	
	^ SpPanedLayout newTopToBottom
		add: (SpPanedLayout newLeftToRight
			add: #classes;
			add: #methods;
			yourself);
		add: #source;
		yourself! !

!StMetaBrowser class methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
objectCentricBreakpointCommandsWith: presenter forRootGroup: aRootCmCommandsGroup
	<extensionCommands>
	
	(aRootCmCommandsGroup / 'methods')
		register: StHaltOnCallCommand forSpec! !

!StMetaBrowser class methodsFor: 'commands' stamp: ''!
buildCommandsGroupWith: presenter forRoot: aCmCommandsGroup

	aCmCommandsGroup
		register: ((CmCommandGroup named: 'classes') asSpecGroup
			beDisplayedAsGroup;
			register: (StInspectorBrowseSelectedCommand forSpecContext: presenter);
			yourself);
		register: ((CmCommandGroup named: 'methods') asSpecGroup
			beDisplayedAsGroup;
			register: (StInspectorInspectSelectedCommand forSpecContext: presenter);
			register: (StInspectorBrowseSelectedCommand forSpecContext: presenter);
			yourself)! !

!StMethodEntry commentStamp: ''!
I wrap a CompiledMethod, to modify its behavior if required for the class!
!StMethodEntry methodsFor: 'converting' stamp: ''!
asString

	^ content selector! !

!StMethodEntry methodsFor: 'accessing' stamp: ''!
icon

	^ content systemIcon! !

!StMethodEntry methodsFor: '*NewTools-Spotter' stamp: ''!
headerCategoryForUnifiedProcessor: aLink on: aSpotterPresenter

	^ aSpotterPresenter headerCategoryUnifiedFor: aLink! !

!StMethodEntry methodsFor: 'accessing' stamp: ''!
label

	^ content printString! !

!StMethodEntry methodsFor: 'evaluating' stamp: ''!
doEvaluate

	^ content browse! !

!StMethodEntry class methodsFor: '*NewTools-Spotter' stamp: ''!
prepareUnifiedHeaderDescriptionFor: aHeaderPresenter

	^ aHeaderPresenter prepareAsImplementors! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addSubclasses
	^ addSubclasses! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
iconBuilder 
	^ iconBuilder! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'private building' stamp: ''!
iconBuilder: aIconBuilder

	iconBuilder := aIconBuilder! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'initialization' stamp: ''!
initialize

	"Initializes the receiver"

	super initialize.
	addSubclasses := false.
	addMethods := true.
	subclassesAsSeparateTopic := true.
	addMethodsWithoutComment := true.
	iconBuilder := StIconClassBuilder new! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
subclassesAsSeparateTopic
	^ subclassesAsSeparateTopic! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addSubclasses: anObject
	addSubclasses := anObject! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addMethodsWithoutComment
	^ addMethodsWithoutComment! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'private building' stamp: ''!
buildSubclassTopicFor: aSubclass
	 
	^ self class new
			rootToBuildFrom: aSubclass;
			addSubclasses: addSubclasses;
			addMethods: addMethods;
			subclassesAsSeparateTopic: subclassesAsSeparateTopic;
			build;
			topicToBuild 
	 ! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addMethods: anObject
	addMethods := anObject! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'building' stamp: ''!
build

	| builder |
	builder := MicroDownParser builder.
	topicToBuild := self topicClass
		                named: rootToBuildFrom name
		                with: self iconBuilder.
	rootToBuildFrom
		buildMicroDownUsing: builder
		withComment: rootToBuildFrom comment.
	topicToBuild addNode: (MicroDownParser new parse: builder contents).

	addMethods ifTrue: [ self buildSubnodesForMethods ].
	addSubclasses ifTrue: [ self buildSubnodesForSubclasses ]! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addMethods
	^ addMethods! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'private building' stamp: ''!
buildMethodTopicsOn: topic for: aClass

	|stream methodComment|
	stream := String new writeStream.
	aClass selectors asSortedCollection do: [:selector | 
		methodComment := (aClass>>selector) comment.
		addMethodsWithoutComment | methodComment notNil ifTrue: [ 
			stream 
				nextPutAll: '`';
				nextPutAll: aClass name;
				nextPutAll: '>>#';
				nextPutAll: selector asString;
				nextPutAll: '`';
				cr.		

		methodComment ifNil: [ methodComment := 'Method has no comment.' ].
		stream nextPutAll: '_"'; nextPutAll: methodComment; nextPutAll: '"_';cr;cr ] ].
	
	topic addNode: (MicroDownParser new parse: stream contents).
	
	! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
subclassesAsSeparateTopic: anObject
	subclassesAsSeparateTopic := anObject! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'private building' stamp: ''!
topicClass

	^ StNodeHelpTopic! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'accessing' stamp: ''!
addMethodsWithoutComment: anObject
	addMethodsWithoutComment := anObject! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'private building' stamp: ''!
buildSubnodesForMethods

	| instanceSide classSide |
	instanceSide := self topicClass named: 'Instance side'.
	classSide := self topicClass named: 'Class side'.
	topicToBuild
		addSubtopic: instanceSide;
		addSubtopic: classSide.
	self buildMethodTopicsOn: instanceSide for: rootToBuildFrom.
	self buildMethodTopicsOn: classSide for: rootToBuildFrom class! !

!StMicrodownClassAPIHelpBuilder methodsFor: 'private building' stamp: ''!
buildSubnodesForSubclasses

	| topic |
	rootToBuildFrom subclasses isEmpty ifTrue: [ ^ self ].
	iconBuilder buildIcon: topicToBuild.
	topic := subclassesAsSeparateTopic
		         ifTrue: [ 
			         topicToBuild addSubtopic:
				         (self topicClass
					          named: 'Subclasses'
					          with: self iconBuilder) ]
		         ifFalse: [ topicToBuild ].
	rootToBuildFrom subclasses do: [ :subclass | 
		topic addSubtopic: (self buildSubclassTopicFor: subclass) ].
	topic sortSubtopicsByTitle! !

!StMicrodownClassAPIHelpBuilder class methodsFor: 'building' stamp: ''!
buildHierarchicalHelpTopicFrom: aClass withSubclasses: aBoolean withMethods: anotherBoolean
	"Start building from the given class"
	
	^ self new 
		addSubclasses: aBoolean;
		addMethods: anotherBoolean;
		rootToBuildFrom: aClass;
		build;
		topicToBuild ! !

!StMicrodownClassAPIHelpBuilder class methodsFor: 'building' stamp: ''!
sample
	<sampleInstance>
	
	StHelpBrowserPresenter openOn: (self buildHierarchicalHelpTopicFrom: SpPresenter withSubclasses: true withMethods: true)! !

!StMockCandidatesList methodsFor: 'adding' stamp: ''!
initialize 
	
	super initialize.
	results := OrderedCollection new! !

!StMockCandidatesList methodsFor: 'events' stamp: ''!
processorEnded: aSptClassProcessor 

	! !

!StMockCandidatesList methodsFor: 'adding' stamp: ''!
addObject: anObject inProcessor: aProcessor

	results add: anObject! !

!StMockCandidatesList methodsFor: 'accessing' stamp: ''!
results
	^ results! !

!StMockCandidatesList methodsFor: 'adding' stamp: ''!
onAmountChanged: aQuantity in: processor

	totalResults := aQuantity! !

!StMockCandidatesList methodsFor: 'events' stamp: ''!
processorStarted: aSptClassProcessor 
	
	! !

!StMockCandidatesList methodsFor: 'adding' stamp: ''!
addCandidate: anEntry in: aProcessor

	results add: anEntry 
	
	! !

!StMockCandidatesList methodsFor: 'accessing' stamp: ''!
reset
	
	results removeAll.
	totalResults := 0.! !

!StMockCandidatesList methodsFor: 'adding' stamp: ''!
addAllCandidates: aCollection in: aProcessor

	results removeAll.
	results addAll: aCollection! !

!StMockCandidatesList methodsFor: 'adding' stamp: ''!
addObjects: aCollection inProcessor: aProcessor

	results addAll: aCollection! !

!StMockContext commentStamp: ''!
I'm an object answering to part of the API of Context, but doing nothing.
You can use me in your tests where messages are sent to a context but you do not actually want to act on a real one, or when you want to record what was done on the context.!
!StMockContext methodsFor: 'accessing' stamp: ''!
stepIntoQuickMethodBooleans

	^ stepIntoQuickMethodBooleans ifNil: [ 
		  stepIntoQuickMethodBooleans := OrderedCollection new ]! !

!StMockContext methodsFor: 'debugger access' stamp: ''!
stepIntoQuickMethod: aBoolean
	self stepIntoQuickMethodBooleans add: aBoolean! !

!StMockDebugCommand commentStamp: ''!
A mock command for dezbugger command tree builder tests!
!StMockDebugCommand methodsFor: 'executing' stamp: ''!
execute
	^self context! !

!StMockDebugCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ #defaultShortcut! !

!StMockDebugCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName
	^ #defaultIconName! !

!StMockDebugCommand class methodsFor: 'initialization' stamp: ''!
defaultName

	^ UUID new printString! !

!StMockDebuggerActionModel commentStamp: ''!
I'm used to mock certain aspects of the `StDebuggerActionModel` class for testing.!
!StMockDebuggerActionModel methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	self interruptedContext: (Context
			 sender: nil
			 receiver: nil
			 method: Object >> #doesNotUnderstand:
			 arguments: #( #message ))! !

!StMockDebuggerActionModel methodsFor: 'accessing' stamp: ''!
session
	^StMockSession new! !

!StMockDebuggerActionModel methodsFor: 'debug - stepping' stamp: ''!
updateTopContext
	tag :=  #updateTopContext
	! !

!StMockDebuggerActionModel methodsFor: 'debug - session' stamp: ''!
autoClassifyMessage: aMessage inClass: aClass! !

!StMockDebuggerActionModel methodsFor: 'accessing' stamp: ''!
tag
	^tag
	! !

!StMockDebuggerActionModel methodsFor: 'accessing' stamp: ''!
interruptedContext: anObject

	interruptedContext := anObject.
	topContext := anObject! !

!StMockDebuggerActionModel methodsFor: 'context' stamp: ''!
computeInitialTopContext! !

!StMockSession commentStamp: ''!
I'm an object answering to part of the API of `DebugSession`, but doing nothing.
You can use me in your tests where messages are sent to a debug session but you do not actually want to act on a real one. !
!StMockSession methodsFor: 'debugging actions' stamp: ''!
stepOver: aContext! !

!StMockSession methodsFor: 'debugging actions' stamp: ''!
returnValue: value from: aContext! !

!StMockSession methodsFor: 'debugging actions' stamp: ''!
stepThrough: aContext! !

!StMockSession methodsFor: 'debugging actions' stamp: ''!
restart: aContext! !

!StMockSession methodsFor: 'debug - session' stamp: ''!
implement: aMessage classified: messageCategory inClass: aClass forContext: aContext

	! !

!StMockSession methodsFor: 'accessing' stamp: ''!
interruptedContext
	 ^self! !

!StMockSession methodsFor: 'debugging actions' stamp: ''!
runToSelection: aSelectionInterval inContext: aContext! !

!StMockSession methodsFor: 'debugging actions' stamp: ''!
stepInto: aContext ! !

!StMockSpotterStream methodsFor: 'performing' stamp: ''!
performSymbol: aSymbol withArguments: aCollection
	self receiver perform: aSymbol withEnoughArguments: aCollection! !

!StNodeCollector commentStamp: ''!
A tool to collect inspection nodes. 
It acts on an object.

```
(StNodeCollector for: anObject) collectNodes.
```!
!StNodeCollector methodsFor: 'private' stamp: ''!
slotNodes

	^ self objectClass allSlots collect: [ :each | 
			StInspectorSlotNode 
				hostObject: self object 
				slot: each ]! !

!StNodeCollector methodsFor: 'building' stamp: ''!
collectNodes

	^ self slotNodes , self indexedNodes! !

!StNodeCollector methodsFor: 'private' stamp: ''!
indexedNodes
	| nodes indexableDisplayLimit top bottom topLimit bottomLimit |
	
	nodes := OrderedCollection new.
	
	indexableDisplayLimit := StInspector indexableDisplayLimit.        
	top := 1.
	bottom := self object basicSize.
	topLimit    := indexableDisplayLimit min: bottom.
	bottomLimit := indexableDisplayLimit max: (bottom - indexableDisplayLimit).

	top to: topLimit do: [ :index | 
		nodes add: (StInspectorIndexedNode 
			hostObject: self object
			index: index) ].
	
	bottomLimit + 1 to: bottom do: [ :index |
		nodes add: (StInspectorIndexedNode 
			hostObject: self object
			index: index) ].
	
	^ nodes! !

!StNodeCollector methodsFor: 'initialization' stamp: ''!
initializeObject: anObject

	self initialize.
	object := anObject! !

!StNodeCollector methodsFor: 'accessing' stamp: ''!
objectClass 
	
	^ self object class! !

!StNodeCollector methodsFor: 'accessing' stamp: ''!
object 
	
	^ object! !

!StNodeCollector class methodsFor: 'instance creation' stamp: ''!
for: anObject

	^ self basicNew 
		initializeObject: anObject;
		yourself! !

!StNodeHelpTopic commentStamp: ''!
I'm a help topic and as such I hold a Microdown root document. 
This is in this document that further microdown elements will be added. 

Note that I can have subtopics in addition to the microdown element. 
A subtopic is just similar to myself.!
!StNodeHelpTopic methodsFor: 'accessing' stamp: ''!
iconBuilder 
	^ iconBuilder! !

!StNodeHelpTopic methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.
	node := MicRootBlock new.
	iconBuilder := StIconBookBuilder new.
	iconBuilder setIconOf: self! !

!StNodeHelpTopic methodsFor: 'accessing' stamp: ''!
subtopics: aCollection

	iconBuilder buildIcon: self.
	super subtopics: aCollection! !

!StNodeHelpTopic methodsFor: 'adding' stamp: ''!
addSubtopic: aHelpTopic with: aLevel
		
	(aLevel > 1 and: [ self subtopics isNotEmpty] )
		ifTrue: [ self subtopics last addSubtopic: aHelpTopic with: aLevel - 1 ] 
		ifFalse: [ self addSubtopic: aHelpTopic ]! !

!StNodeHelpTopic methodsFor: 'adding' stamp: ''!
addSubtopic: aSubTopic

	iconBuilder buildIcon: self.
	super addSubtopic: aSubTopic! !

!StNodeHelpTopic methodsFor: 'accessing' stamp: ''!
node
	"Returns the microdown elements holding the document of the help"
	
	^ node! !

!StNodeHelpTopic methodsFor: 'adding' stamp: ''!
addNode: aNode

	node addChild: aNode! !

!StNodeHelpTopic methodsFor: 'inspecting' stamp: ''!
inspectionMCTopicTree
	<inspectorPresentationOrder: 930 title: 'TopicTree'>

	^ SpTreePresenter new 
		roots: { self };
		children: [ :aNode | aNode subtopics ];
		display: [ :each | 
			String
				streamContents: [ :stream | 
					each displayStringOn: stream						
			 ] ];
		yourself! !

!StNodeHelpTopic methodsFor: 'accessing' stamp: ''!
iconBuilder: aIconBuilder

	iconBuilder := aIconBuilder! !

!StNodeHelpTopic class methodsFor: 'instance creation' stamp: ''!
named: aName with: anIconBuilder
	| topic |
	topic := self named: aName.
	topic iconBuilder: anIconBuilder.
	topic iconBuilder buildIcon: topic.
	^ topic! !

!StNullFilter commentStamp: ''!
A filter that answers all elements (not a filter at all)!
!StNullFilter methodsFor: 'private' stamp: ''!
doApplyFilterWithQuery

	self streamed 
		ifTrue: [
			" this will be more responsive (faster) for very large collections and/or expensive filters "
			| allItems |
			self filteredItems: (allItems := OrderedCollection new).
			self allItems withIndexDo: [ :each :index |				
				allItems add: each.
				self addItem: each.
				index = self itemsLimit ifTrue: [ StLimitArrived signal ] ] ]
		ifFalse: [
			" this will be much much faster for small collections and/or very quick filters " 
			self filteredItems: self allItems.
			self addItems: (self allItems first: (self itemsLimit min: self allItems size)) ]! !

!StNullFilter methodsFor: 'public' stamp: ''!
stListFilter

	^ StFilterSubstring new! !

!StNullFilter class methodsFor: 'public' stamp: ''!
stListFilter

	^ StFilterSubstring new! !

!StObjectBreakpointInspection commentStamp: ''!
I am an inspection for halts and breakpoints, my scope is the inspected object.!
!StObjectBreakpointInspection methodsFor: 'updating' stamp: ''!
updateSourceCodeForBreakpointItem: aStBreakpointInspectionItem

	"Halts and standard breakpoints items both behave the same"

	self updateSourceCodeForHaltItem: aStBreakpointInspectionItem! !

!StObjectBreakpointInspection methodsFor: 'system subscription' stamp: ''!
unsubscribeFromCacheChanges
	SystemAnnouncer uniqueInstance unsubscribe: self! !

!StObjectBreakpointInspection methodsFor: 'initialization' stamp: ''!
initialize
	breakpointController := StHaltAndBreakpointController new.
	super initialize! !

!StObjectBreakpointInspection methodsFor: 'private' stamp: ''!
breakpointsForModel

	^ Breakpoint all select: [ :bp | bp scopeIncludes: model ]! !

!StObjectBreakpointInspection methodsFor: 'updating' stamp: ''!
windowIsClosing
	^ self unsubscribeFromCacheChanges! !

!StObjectBreakpointInspection methodsFor: 'private' stamp: ''!
buildBreakpointData
	^ (self breakpointsForModel
		collect: [ :b | StBreakpointInspectionItem forBreakpoint: b ])
	"	reject: [ :data | 
			| node breakpoint |
			node := data at: #node.
			breakpoint := data at: #breakpoint.
			node methodNode methodClass isAnonymous
				and: [ breakpoint isObjectCentric not
						or: [ breakpoint isVariableBreakpoint ] ] ]"! !

!StObjectBreakpointInspection methodsFor: 'breakpoints' stamp: ''!
isBreakpointObjectCentric: breakpointData
	| breakpoint |
	breakpoint := breakpointData at: #breakpoint ifAbsent: [ ^ false ].
	^ breakpoint isObjectCentric
		and: [ breakpoint isVariableBreakpoint not ]! !

!StObjectBreakpointInspection methodsFor: 'presenters' stamp: ''!
buildHaltAndBreakpointTable
	"List of methods in which a breakpoint is installed"

	methodsWithBreakpoints := self newTable.
	methodsWithBreakpoints 
		addColumn:
			((SpCheckBoxTableColumn
				title: ' '
				evaluated: [ :item | 	self haltOrBreakpoinsEnabledFor: item ])
				onActivation: [ :item | self enableHaltOrBreakpointFor: item ];
				onDeactivation: [ :item | self disableHaltOrBreakpointFor: item ];
				width: 20;
				yourself);
		addColumn:
			((SpStringTableColumn
				title: 'Type'
				evaluated: [ :item | item type ])
				width: 65;
				yourself);
		addColumn:
			((SpStringTableColumn
				title: 'Scope'
				evaluated: [ :item | item printScope])
				width: 120;
				yourself);
		addColumn:
			(SpStringTableColumn
				title: 'Target'
				evaluated: [ :item | item printEntity]).
	methodsWithBreakpoints
		contextMenu: self rootCommandsGroup asMenuPresenter! !

!StObjectBreakpointInspection methodsFor: 'breakpoints' stamp: ''!
disableHaltOrBreakpointFor: haltOrBreakpointItem

	breakpointController disableHaltOrBreakpointFor: haltOrBreakpointItem! !

!StObjectBreakpointInspection methodsFor: 'breakpoints' stamp: ''!
enableHaltOrBreakpointFor: haltOrBreakpointItem

	breakpointController enableHaltOrBreakpointFor: haltOrBreakpointItem! !

!StObjectBreakpointInspection methodsFor: 'accessing' stamp: ''!
methodsWithBreakpoints
	^ methodsWithBreakpoints! !

!StObjectBreakpointInspection methodsFor: 'presenters' stamp: ''!
buildSourceCode
	"Source code of methods in which breakpoint are installed"

	breakpointsInSourceCode := self newCode.
	breakpointsInSourceCode beNotEditable! !

!StObjectBreakpointInspection methodsFor: 'commands' stamp: ''!
doBrowseBreakpointMethod
	| entityToBrowse |
	
	entityToBrowse := self methodsWithBreakpoints selection selectedItem entityToBrowse.
	self systemNavigation browse: entityToBrowse.! !

!StObjectBreakpointInspection methodsFor: 'updating' stamp: ''!
updateSourceCodeForHaltItem: aStHaltInspectionItem

	breakpointsInSourceCode withLineNumbers.
	breakpointsInSourceCode selectionInterval:
		aStHaltInspectionItem interval.
	breakpointsInSourceCode beForBehavior: model class! !

!StObjectBreakpointInspection methodsFor: 'breakpoints' stamp: ''!
haltOrBreakpoinsEnabledFor: haltOrBreakpointItem

	^ breakpointController isHaltOrBreakpointEnabled:
		  haltOrBreakpointItem! !

!StObjectBreakpointInspection methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	super initializeWindow: aWindowPresenter.
	aWindowPresenter
		whenClosedDo: [ SystemAnnouncer uniqueInstance unsubscribe: self ]! !

!StObjectBreakpointInspection methodsFor: 'presenters' stamp: ''!
configureSourceCodeUpdate

	methodsWithBreakpoints whenSelectionChangedDo: [ :selection | 
		selection isEmpty ifFalse: [ 
			| selectedItem |
			selectedItem := selection selectedItem.
			breakpointsInSourceCode text: selectedItem printContents.
			selectedItem updateSourceCodePaneFor: self ] ]! !

!StObjectBreakpointInspection methodsFor: 'updating' stamp: ''!
updateSourceCodeForVariableBreakpointItem: aStBreakpointInspectionItem

	breakpointsInSourceCode
		beForObject: model;
		withoutLineNumbers.
	breakpointsInSourceCode beForBehavior: model class! !

!StObjectBreakpointInspection methodsFor: 'initialization' stamp: ''!
initializePresenters
	self buildSourceCode.
	self buildHaltAndBreakpointTable.
	self configureSourceCodeUpdate.
	self buildTableData.
	SystemAnnouncer uniqueInstance weak when: StHaltCacheChanged send: #buildTableData to: self.
	SystemAnnouncer uniqueInstance weak when: BreakpointAdded send: #buildTableData to: self! !

!StObjectBreakpointInspection methodsFor: 'private' stamp: ''!
buildHaltData

	^ (model class allMethods flatCollect: [ :m | 
		   StHaltCache defaultCache nodeCacheForSelector:
			   m compiledMethod printString ]) collect: [ :node | 
		  StHaltInspectionItem forHalt: node ]! !

!StObjectBreakpointInspection methodsFor: 'private' stamp: ''!
buildHaltAndBreakpointData
	| breakpointData |
	breakpointData := OrderedCollection new."SortedCollection
		sortBlock: [ :a :b | (a at: #node) methodNode selector < (b at: #node) methodNode selector ]."
	breakpointData addAll: self buildBreakpointData.
	breakpointData addAll: self buildHaltData.
	^ breakpointData! !

!StObjectBreakpointInspection methodsFor: 'presenters' stamp: ''!
labelForHaltSelector: aSelector
	"This was intended to be used to display more precise information about the kind of halt we display in the presenter."
	self flag: 'Not used yet. Kept as documentation for further use'.
	(#(haltIf: haltIfNil) includes: aSelector)
		ifTrue: [ ^ 'condition' ].
	(#(haltOnCount:) includes: aSelector)
		ifTrue: [ ^ 'on count' ].
	(#(haltOnce) includes: aSelector)
		ifTrue: [ ^ 'once' ].
	^ 'always'! !

!StObjectBreakpointInspection methodsFor: 'presenters' stamp: ''!
buildTableData
	methodsWithBreakpoints items: self buildHaltAndBreakpointData! !

!StObjectBreakpointInspection class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newTopToBottom
		add: #methodsWithBreakpoints;
		add: #breakpointsInSourceCode;
		yourself! !

!StObjectBreakpointInspection class methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
removeBreakpointCommandFor: presenter
	| cmd |
	cmd := StRemoveBreakpointCommand forSpecContext: presenter.
	cmd iconName: #smallDelete.
	cmd innerCommand
		transform: [ :ctx | ctx methodsWithBreakpoints selection selectedItem ].
	^ cmd! !

!StObjectBreakpointInspection class methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
objectCentricCommandsWith: presenter forRootGroup: aCmCommandsGroup
	<extensionCommands>
	
	aCmCommandsGroup
		register: (self removeBreakpointCommandFor: presenter);
		register: (self browseBreakpointMethodCommandFor: presenter)! !

!StObjectBreakpointInspection class methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
browseBreakpointMethodCommandFor: presenter

	^ ((SpBrowseClassCommand forContext: presenter)
		selector: #doBrowseBreakpointMethod;
			asSpecCommand)
			name: 'Browse method';
			yourself! !

!StObjectBreakpointInspectionTest methodsFor: 'running' stamp: ''!
tearDown
	breakpoint1 ifNotNil: [ breakpoint1 remove ].
	breakpoint2 ifNotNil: [ breakpoint2 remove ].
	breakpoint3 ifNotNil: [ breakpoint3 remove ].
	breakpoint4 ifNotNil: [ breakpoint4 remove ].
	self removeHelperMethods.
	super tearDown! !

!StObjectBreakpointInspectionTest methodsFor: 'tests' stamp: ''!
testAllBreakpointsForModel

	inspection := StObjectBreakpointInspection basicNew model: instance.
	self assertCollection: inspection breakpointsForModel equals: { 
			breakpoint1.
			breakpoint2.
			breakpoint3.
			breakpoint4 } asOrderedCollection! !

!StObjectBreakpointInspectionTest methodsFor: 'tests' stamp: ''!
testObjectCentricBreakpointsForModel

	breakpoint1 remove.
	breakpoint1 := nil.
	breakpoint2 remove.
	breakpoint2 := nil.
	inspection := StObjectBreakpointInspection basicNew model:
		              instance.
	self assertCollection: inspection breakpointsForModel equals: { 
			breakpoint3.
			breakpoint4. } asOrderedCollection! !

!StObjectBreakpointInspectionTest methodsFor: 'helpers' stamp: ''!
removeHelperMethods

	StDummyTestClassWithHalts removeSelector: #varRead.
	StDummyTestClassWithHalts removeSelector: #varWrite! !

!StObjectBreakpointInspectionTest methodsFor: 'tests' stamp: ''!
testBreakpointsForModel

	inspection := StObjectBreakpointInspection basicNew model:
		              StDummyTestClassWithHalts new.
	self assertCollection: inspection breakpointsForModel equals: { 
			breakpoint1.
			breakpoint2 } asOrderedCollection! !

!StObjectBreakpointInspectionTest methodsFor: 'helpers' stamp: ''!
compileHelperMethods

	StDummyTestClassWithHalts compile: 'varRead ^var'.
	StDummyTestClassWithHalts compile: 'varWrite var := 0'! !

!StObjectBreakpointInspectionTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self removeHelperMethods.
	self compileHelperMethods.
	
	breakpoint1 := Breakpoint new node: (StDummyTestClassWithHalts>>#varRead) ast.
	breakpoint1  install.
	
	breakpoint2  := VariableBreakpoint watchVariable: #var inClass: StDummyTestClassWithHalts.
	
	instance := StDummyTestClassWithHalts new.	
	breakpoint3 := VariableBreakpoint watchVariable: #var inObject: instance.
	breakpoint4 := instance haltOnCallTo: #varRead.	
	
	! !

!StObjectContextModel commentStamp: ''!
A model to be used with `StObjectContextPresenter`.
It keeps references to: 

- the inspector model
- the inspection context
- the inspection object!
!StObjectContextModel methodsFor: 'accessing' stamp: ''!
inspection: anObject
	inspection := anObject! !

!StObjectContextModel methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!StObjectContextModel methodsFor: 'accessing' stamp: ''!
inspectedObject
	^ inspectedObject! !

!StObjectContextModel methodsFor: 'accessing' stamp: ''!
inspection
	^ inspection! !

!StObjectContextModel methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!StObjectContextModel methodsFor: 'accessing' stamp: ''!
codeSnippet: aString

	(self stringWithoutInitialCommentFrom: aString asString) 
		ifNotEmpty: [ :snippet |
			self class 
				codeSnippetFor: self inspectedObject class
				value: snippet ]! !

!StObjectContextModel methodsFor: 'accessing' stamp: ''!
inspectedObject: anObject
	inspectedObject := anObject! !

!StObjectContextModel methodsFor: 'private building' stamp: ''!
stringWithoutInitialCommentFrom: aString

	^ (aString trimLeft notEmpty and: [ aString trimLeft first = $" ])
		ifFalse: [ aString trimRight ]
		ifTrue: [ | startIndex doubleQuoteCounter |
			startIndex := aString findAnySubstring: '"' startingAt: (aString indexOf: $") + 1.
			doubleQuoteCounter := 1.
			"we need to iterate over the whole string queuing quotes to support nested double quotes"
			[ startIndex <= aString size
				and: [ doubleQuoteCounter % 2 = 1
					or: [ (aString at: startIndex) = $"
						or: [ (aString at: startIndex) isSeparator ] ] ] ]
			whileTrue: [ 
				(aString at: startIndex) = $" ifTrue: [ 
					doubleQuoteCounter := doubleQuoteCounter + 1 ].
				startIndex := startIndex + 1 ].
	
			(startIndex >= (aString size + 1)) ifTrue: [ "No content if a comment cannot be identified. " ^ '' ].
			(aString
				copyFrom: startIndex
				to: aString size) trimBoth ]! !

!StObjectContextModel methodsFor: 'accessing' stamp: ''!
smallDescriptionString

	^ self inspection smallDescriptionStringFor: self inspectedObject! !

!StObjectContextModel methodsFor: 'accessing' stamp: ''!
codeSnippet

	^ self class 
		codeSnippetFor: self inspectedObject class
		ifAbsent: [ 'self' ]! !

!StObjectContextModel methodsFor: 'testing' stamp: ''!
hasEvaluator
	
	^ self context hasEvaluator! !

!StObjectContextModel methodsFor: 'factory' stamp: ''!
newInspectionView

	^ self context newInspectionView! !

!StObjectContextModel class methodsFor: 'private' stamp: ''!
codeSnippetFor: aClass ifAbsent: aBlock

	^ self codeSnippets 
		at: aClass
		ifAbsent: aBlock! !

!StObjectContextModel class methodsFor: 'private' stamp: ''!
codeSnippets

	^ CodeSnippets ifNil: [ CodeSnippets := WeakIdentityKeyDictionary new ]! !

!StObjectContextModel class methodsFor: 'private' stamp: ''!
codeSnippetFor: aClass value: aString

	self codeSnippets 	
		at: aClass 
		put: aString! !

!StObjectContextModelTest methodsFor: 'tests' stamp: ''!
testStringWithoutInitialCommentFrom
	| model string | 
		
	model := StObjectContextModel new.
	
	self assert: (model stringWithoutInitialCommentFrom: 'self') equals: 'self'. 
	self assert: (model stringWithoutInitialCommentFrom: '"self" 42') equals: '42'. 	
	
	string := '"some thing in 
several 
lines"
42 "other"'.
	self assert: (model stringWithoutInitialCommentFrom: string) equals: '42 "other"'. 		! !

!StObjectContextPresenter commentStamp: ''!
A presenter object inspection that is aware of the inspection context.
It is used to build enhance inspection view (e.g. show or not the evaluator).!
!StObjectContextPresenter methodsFor: 'private' stamp: ''!
evaluator

	^ evaluator! !

!StObjectContextPresenter methodsFor: 'private' stamp: ''!
menuActionsFor: aCodePresenter
	
	^ CmCommandGroup forSpec
		beRoot;
		register: ((CmCommandGroup named: 'Extra') asSpecGroup
			beDisplayedAsGroup;
			register: (StEvaluateCommand forSpecContext: self);
			yourself);
		register: (aCodePresenter rootCommandsGroup name: 'Code');
		register: (aCodePresenter editionCommandsGroup name: 'Edition');
		yourself! !

!StObjectContextPresenter methodsFor: 'api - events' stamp: ''!
whenActivatedDo: aBlock

	activationBlock := aBlock! !

!StObjectContextPresenter methodsFor: 'stepping' stamp: ''!
step

	view step! !

!StObjectContextPresenter methodsFor: 'testing' stamp: ''!
hasOutputActivationPort
	
	^ self hasEvaluator or: [ view hasOutputActivationPort ]! !

!StObjectContextPresenter methodsFor: 'api' stamp: ''!
activateOnDoubleClick
	
	view hasOutputActivationPort ifFalse: [ ^ self ].
	view activateOnDoubleClick! !

!StObjectContextPresenter methodsFor: 'api' stamp: ''!
activateOnSingleClick
	
	view hasOutputActivationPort ifFalse: [ ^ self ].
	view activateOnSingleClick! !

!StObjectContextPresenter methodsFor: 'initialization' stamp: ''!
intializePresentersWithEvaluator
	
	(evaluator := self newCode)
		beForObject: self model inspectedObject;
		text: self evaluatorInitialText;
		overridingContextMenu;
		contextMenu: [ (self menuActionsFor: evaluator) asMenuPresenter ];
		contextKeyBindings: (self menuActionsFor: evaluator) asKMCategory;
		whenTextChangedDo: [ :aString | self model codeSnippet: aString ].
	
	self layout: (SpPanedLayout newTopToBottom
		positionOfSlider: 70 percent;
		add: view;
		add: evaluator;
		yourself)! !

!StObjectContextPresenter methodsFor: 'transmission' stamp: ''!
outputActivationPort

	^ view hasOutputActivationPort 
		ifTrue: [ (SpActivationPort newPresenter: self), view outputActivationPort ]
		ifFalse: [ SpActivationPort newPresenter: self ]! !

!StObjectContextPresenter methodsFor: 'private' stamp: ''!
evaluatorActions
	
	^ CmCommandGroup forSpec
		beDisplayedAsGroup;
		register: (StEvaluateCommand forSpecContext: self);
		yourself! !

!StObjectContextPresenter methodsFor: 'testing' stamp: ''!
hasEvaluator

	^ self model hasEvaluator! !

!StObjectContextPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aModel
	
	model := aModel! !

!StObjectContextPresenter methodsFor: 'commands' stamp: ''!
doEvaluateAndGo
	| value |
	
	activationBlock ifNil: [ ^ self ].

	value := self evaluator 
		evaluate: self evaluator selectedTextOrLine
		onCompileError: [ ^ self ]
		onError: [ :e | e pass ].
	
	activationBlock value: (StEvaluatedSelectionModel newValue: value)! !

!StObjectContextPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	view := self model newInspectionView.
	self hasEvaluator
		ifTrue: [ self intializePresentersWithEvaluator ]
		ifFalse: [ self intializePresentersWithoutEvaluator ]! !

!StObjectContextPresenter methodsFor: 'accessing - model' stamp: ''!
model

	^ model! !

!StObjectContextPresenter methodsFor: 'private' stamp: ''!
evaluatorInitialText

	^ self model inspectedObject evaluatorInitialText: self 
	! !

!StObjectContextPresenter methodsFor: 'initialization' stamp: ''!
intializePresentersWithoutEvaluator
	
	self layout: (SpBoxLayout newTopToBottom
		add: view;
		yourself)! !

!StObjectContextPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ StObjectContextPresenter! !

!StObjectContextPresenterTest methodsFor: 'tests' stamp: ''!
testDoEvaluateDeclareGlobal
	| value |
	
	self deny: (Smalltalk globals includesKey: #MyGlobalForTest).
	
	self openInstance.
	
	presenter evaluator text: 'MyGlobalForTest'. 
	presenter whenActivatedDo: [ :selection | value := selection value ].

	[presenter doEvaluateAndGo] on: OCUndeclaredVariableWarning do: [ :warn | warn declareGlobal ].
	
	self assert: value equals:  nil.
	
	self assert: (Smalltalk globals includesKey: #MyGlobalForTest).
	Smalltalk globals removeKey: #MyGlobalForTest! !

!StObjectContextPresenterTest methodsFor: 'initialization' stamp: ''!
initializeInstanceBeforeInitialization: aPresenter
	| model context |

	model := StInspectorModel on: StInspectorMockObject new.
	context := StInspectionContext fromPragma: (StInspectorMockObject>>#inspectionMock1) pragmas first.
	context inspectedObject: model inspectedObject.
	aPresenter setModelBeforeInitialization: (StObjectContextModel new 
		inspection: model;
		inspectedObject: model inspectedObject;
		context: context; 
		yourself)! !

!StObjectContextPresenterTest methodsFor: 'tests' stamp: ''!
testDoEvaluateAndGo
	| evaluatedValue |

	self openInstance.
	
	presenter whenActivatedDo: [ :selection | evaluatedValue := selection value ].
	presenter evaluator text: '2*2'.
	
	presenter doEvaluateAndGo.
	
	self assert: evaluatedValue equals: 4! !

!StObjectInspectorPresenter commentStamp: ''!
I am a single object inspector.
I present a notebook with the possible inspection of the object.

I am usually embedded into an StInspector, but I can be used standalone.!
!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
evaluator 
	^evaluator! !

!StObjectInspectorPresenter methodsFor: 'api - events' stamp: ''!
whenActivatedDo: aBlock

	activationBlock := aBlock! !

!StObjectInspectorPresenter methodsFor: 'transmission' stamp: ''!
defaultInputPort

	^ self inputModelPort! !

!StObjectInspectorPresenter methodsFor: 'stepping' stamp: ''!
step

	alivePresentersByPage 
		do: [ :each | each step ]! !

!StObjectInspectorPresenter methodsFor: 'initialization' stamp: ''!
initializeLayout
	
	self layout: (SpBoxLayout newTopToBottom 
		add: header expand: false fill: false padding: 5;
		add: views;
		yourself)! !

!StObjectInspectorPresenter methodsFor: 'private - updating' stamp: ''!
refresh
	"model changed?  
	 update inspector values."

	self updateTitle.
	self updateHeaderBar.
	self updateEvaluator.
	self updatePages! !

!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
refreshContent
	"I force a refresh of current page contents. "

	views selectedPage resetContent! !

!StObjectInspectorPresenter methodsFor: 'transmission' stamp: ''!
inputModelPort

	^ SpModelPort newPresenter: self! !

!StObjectInspectorPresenter methodsFor: 'private - updating' stamp: ''!
updateEvaluator

	"evaluator beForObject: self model inspectedObject"! !

!StObjectInspectorPresenter methodsFor: 'api - events' stamp: ''!
whenClosedDo: aBlock

	header whenClosedDo: aBlock! !

!StObjectInspectorPresenter methodsFor: 'private - updating' stamp: ''!
updateHeaderBar
		
	header label: self model labelString.
	header toolbarActions: self rootCommandsGroup ! !

!StObjectInspectorPresenter methodsFor: 'api - focus' stamp: ''!
defaultKeyboardFocus

	views pages ifNotEmpty: [ :pages | 
		pages first activePresenter 
			ifNotNil: [ :aPresenter | ^ aPresenter ] ].
		
	^ self! !

!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
selectedPage

	^ views selectedPage! !

!StObjectInspectorPresenter methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
haltInspectedObjectOnReadAccess
	^self inspectedObject haltOnRead! !

!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
selectedPageName

	^ self selectedPage title! !

!StObjectInspectorPresenter methodsFor: 'private - factory' stamp: ''!
newInspectionForContext: aContext
	
	^ StObjectContextPresenter on: (StObjectContextModel new 
		inspection: self model;
		inspectedObject: self inspectedObject;
		context: aContext; 
		yourself)! !

!StObjectInspectorPresenter methodsFor: 'private' stamp: ''!
allContexts

	^ self model objectInspectionContexts! !

!StObjectInspectorPresenter methodsFor: 'private' stamp: ''!
setModel: aModel

	self model: aModel! !

!StObjectInspectorPresenter methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
haltInspectedObjectOnWriteAccess
	^ self inspectedObject haltOnWrite! !

!StObjectInspectorPresenter methodsFor: 'private' stamp: ''!
activate: aSelection

	activationBlock ifNil: [ ^ self ].
	activationBlock cull: aSelection! !

!StObjectInspectorPresenter methodsFor: 'private - builder' stamp: ''!
buildToolbar

	^ self rootCommandsGroup asToolbarPresenterWith: [ :presenter | 
			presenter 
				displayMode: self application toolbarDisplayMode;
				addStyle: 'stToolbar' ]! !

!StObjectInspectorPresenter methodsFor: 'private' stamp: ''!
keepPresenter: aPresenter

	alivePresentersByPage add: aPresenter! !

!StObjectInspectorPresenter methodsFor: 'model access' stamp: ''!
setModelBeforeInitialization: anInspectorModel

	model := anInspectorModel! !

!StObjectInspectorPresenter methodsFor: 'model access' stamp: ''!
model 

	^ model! !

!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
title

	^ self model windowTitle! !

!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
rawInspectorPageOrNil

	^ views pages 
		detect: [ :page | page title = 'Raw' ] 
		ifNone: [ nil ]! !

!StObjectInspectorPresenter methodsFor: 'private' stamp: ''!
allPages

	^ self allContexts 
		collect: [ :each | self newPageForContext: each ]
	! !

!StObjectInspectorPresenter methodsFor: 'initialization' stamp: ''!
initialize

	activateOnSingleClick := false.
	super initialize.
	"I keep the presenters I'm showing in this variable because they can change (and they are 
	 initialized lazily in the notebook)"
	alivePresentersByPage := WeakSet new! !

!StObjectInspectorPresenter methodsFor: 'private' stamp: ''!
addActivationTo: aPresenter
	
	aPresenter hasOutputActivationPort ifFalse: [ ^ self ]. 
	activateOnSingleClick ifTrue: [ aPresenter activateOnSingleClick ].
	aPresenter outputActivationPort 
		transmitDo: [ :selection | self activate: selection ]! !

!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
inspectedObject
 	
	^ self model inspectedObject! !

!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
selectedObject
	^ self inspectedObject! !

!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
trySelectAnyPageWithName: aCollection
	"Tries to select a the first page of aCollection that exists in the pages list."
	| pagesToSearch |

	pagesToSearch := ((aCollection asOrderedCollection 
		reject: [ :each | each isNil ])
		reject: [ :each | each = StRawInspection label ])
		removeDuplicates.
	pagesToSearch ifEmpty: [ ^ self ].

	pagesToSearch do: [ :eachName |
		views pages 
			detect: [ :each | each title = eachName ]
			ifFound: [ :aPage | 
				views selectPage: aPage.
				^ self ] ]! !

!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
activateOnDoubleClick

	activateOnSingleClick := true! !

!StObjectInspectorPresenter methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
haltInspectedObjectOnStateAccess
	^ self inspectedObject haltOnAccess ! !

!StObjectInspectorPresenter methodsFor: 'private - updating' stamp: ''!
updateTitle
		
	self isRoot ifFalse: [ ^ self ].
	self withWindowDo: [ :window | 
		window title: self title ].! !

!StObjectInspectorPresenter methodsFor: 'accessing' stamp: ''!
activateOnSingleClick

	activateOnSingleClick := true! !

!StObjectInspectorPresenter methodsFor: 'model access' stamp: ''!
model: anInspectorModel

	"if same object, I do not want to update to not trigger infinite updates"
	model inspectedObject == anInspectorModel inspectedObject 
		ifTrue: [ ^ self ].
	model := anInspectorModel.
	self refresh! !

!StObjectInspectorPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	super initializeWindow: aWindowPresenter.
	aWindowPresenter 
		title: self title;
		toolbar: self buildToolbar! !

!StObjectInspectorPresenter methodsFor: 'private - factory' stamp: ''!
newPageForContext: aContext

	^ SpNotebookPage new
		title: aContext title;
		presenterProvider: [ self newInspectionForContext: aContext ];
		whenRetrievedDo: [ :presenter | 
			self keepPresenter: presenter.
			self addActivationTo: presenter ];
		yourself! !

!StObjectInspectorPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	views := self newNotebook.
	header := self instantiate: StHeaderBar.
	self initializeLayout.

	self refresh! !

!StObjectInspectorPresenter methodsFor: 'private - updating' stamp: ''!
updatePages

	views 
		pages: self allPages;
		selectPageIndex: 1! !

!StObjectInspectorPresenter class methodsFor: 'opening' stamp: ''!
openOn: anObject

	^ (self onObject: anObject) openWithSpec! !

!StObjectInspectorPresenter class methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
objectCentricBreakpointCommandsWith: aPresenter forRootGroup: aRootCommandsGroup
	<extensionCommands>
	
	aRootCommandsGroup 
		register: (CmCommandGroup forSpec
			beToolbarPopoverButton;
			name: 'Halt';
			icon: (aPresenter application iconNamed: #smallObjects);
			register: (StHaltOnReadCommand forSpec);
			register: (StHaltOnWriteCommand forSpec);
			register: (StHaltOnStateAccessCommand forSpec);
			yourself)! !

!StObjectInspectorPresenter class methodsFor: 'tools registry' stamp: ''!
inspect: anObject

	^ self openOn: anObject! !

!StObjectInspectorPresenter class methodsFor: 'accessing' stamp: ''!
defaultTitle

	^ 'Inspector'! !

!StObjectInspectorPresenter class methodsFor: 'commands' stamp: ''!
buildRootCommandsGroupFor: aPresenter
	| rootCommandGroup |
	
	rootCommandGroup := CmCommandGroup forSpec beRoot.
	"Register extension commands first."
	self buildExtensionCommandsWith: aPresenter forRoot: rootCommandGroup.
	"Register default commands."
	self buildCommandsGroupWith: aPresenter forRoot: rootCommandGroup.
	
	^ rootCommandGroup! !

!StObjectInspectorPresenter class methodsFor: 'commands' stamp: ''!
buildCommandsGroupWith: presenter forRoot: aCmCommandsGroup
	| group |
	
	group := (CmCommandGroup named: 'Toolbar') asSpecGroup.
	(StInspectorCommand toolbarCommandsFor: presenter)
		do: [ :cmd | group register: cmd ].
	
	aCmCommandsGroup register: group! !

!StObjectInspectorPresenter class methodsFor: 'opening' stamp: ''!
onObject: anObject

	^ self on: (StInspectorModel on: anObject)! !

!StObjectPrinter commentStamp: ''!
This is a utility class for printing objects to Text or String.
!
!StObjectPrinter methodsFor: 'printing' stamp: ''!
asNonTruncatedTextFrom: anObject
	^ self class asNonTruncatedTextFrom: anObject! !

!StObjectPrinter methodsFor: 'printing' stamp: ''!
asTruncatedTextFrom: anObject
	^ self class asTruncatedTextFrom: anObject! !

!StObjectPrinter class methodsFor: 'converting' stamp: ''!
asNonTruncatedTextFrom: anObject
	"I return a representation of the receiver in which all lines breaks 
	are replaced by spaces. I return a String unless there is an error 
	printing the object. In this case I return a Text highlighted in red."
	^ [ anObject asString replaceAll: String cr with: String space ] 
			on: Exception 
			do: [ Text string: 'error printing' attribute: TextColor red ]! !

!StObjectPrinter class methodsFor: 'converting' stamp: ''!
asTruncatedTextFrom: anObject
	"I return a truncated representation of the receiver in which all lines breaks 
	are replaced by spaces. I return a String unless there is an error printing the
	object. In this case I return a Text highlighted in red."
	^ [ (anObject displayString copyReplaceAll: String cr with: String space) replaceAll: String lf with: String space ]
		on: Exception
		do: [ :error | self textFromError: error ]! !

!StObjectPrinter class methodsFor: 'converting' stamp: ''!
textFromError: anError

	| message |
	message := anError messageText ifEmpty: [ anError class name ].
	^ Text string: 'Error printing: ', message attribute: TextColor red! !

!StObjectPrinterTest methodsFor: 'assertions' stamp: ''!
assertIsError: aCollection expectedMessage: aMessage
	
	self assert: aCollection asString equals: 'Error printing: ', aMessage.
	self assert: aCollection runs anyOne first color equals: Color red! !

!StObjectPrinterTest methodsFor: 'tests' stamp: ''!
testPrintDoesNotUnderstand

	| printedValue selector error |
	selector := #iShouldNotUnderstandThis.
	
	error := MessageNotUnderstood new message: ((Message selector: selector) lookupClass: StObjectWithPrintDoesNotUnderstand).
	printedValue := StObjectPrinter asTruncatedTextFrom: (StObjectWithPrintDoesNotUnderstand withMissingMessageSelector: selector).
	
	self assertIsError: printedValue expectedMessage: error messageText! !

!StObjectPrinterTest methodsFor: 'tests' stamp: ''!
testPrintError

	| printedValue |
	printedValue := StObjectPrinter asTruncatedTextFrom: StObjectWithPrintError new.
	
	self assertIsError: printedValue expectedMessage: 'Some error message'! !

!StObjectPrinterTest methodsFor: 'tests' stamp: ''!
testPrintHalt

	| printedValue |
	printedValue := StObjectPrinter asTruncatedTextFrom: StObjectWithPrintHalt new.
	
	self assertIsError: printedValue expectedMessage: 'Halt'! !

!StObjectWithPrintDoesNotUnderstand methodsFor: 'printing' stamp: ''!
printOn: aString

	^ self perform: selector! !

!StObjectWithPrintDoesNotUnderstand methodsFor: 'accessing' stamp: ''!
missingMessageSelector: aString 
	selector := aString! !

!StObjectWithPrintDoesNotUnderstand class methodsFor: 'instance creation' stamp: ''!
withMissingMessageSelector: aString 
	^ self new missingMessageSelector: aString! !

!StObjectWithPrintError methodsFor: 'printing' stamp: ''!
printOn: aString

	^ self error: 'Some error message'! !

!StObjectWithPrintHalt methodsFor: 'printing' stamp: ''!
printOn: aString

	<haltOrBreakpointForTesting>

	^ self halt! !

!StOrderedFilter commentStamp: ''!
A base filter for ordered collections.!
!StPackageEntry commentStamp: ''!
I wrap a RPackage entry, to modify its behavior if required for the class!
!StPackageEntry methodsFor: 'converting' stamp: ''!
asString

	^ content name! !

!StPackageEntry methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #package! !

!StPackageEntry methodsFor: '*NewTools-Spotter' stamp: ''!
headerCategoryForUnifiedProcessor: aLink on: aSpotterPresenter

	^ aSpotterPresenter headerCategoryUnifiedFor: aLink! !

!StPackageEntry methodsFor: 'evaluating' stamp: ''!
doEvaluate

	content browse! !

!StPackageEntry class methodsFor: '*NewTools-Spotter' stamp: ''!
prepareUnifiedHeaderDescriptionFor: aHeaderPresenter

	^ aHeaderPresenter prepareAsPackages! !

!StPackageIterator commentStamp: ''!
I implement an iterator over all the packages in the system!
!StPackageIterator methodsFor: 'enumerating' stamp: ''!
elementsDo: aValuable

	RPackageOrganizer default packagesDo: aValuable! !

!StPackageProcessor commentStamp: ''!
I am simple processor that iterates on the packages in the system!
!StPackageProcessor methodsFor: 'filtering' stamp: ''!
newTextFilteringSource

	^ (StPackageIterator new collect: [ :e | StClassEntry on: e ]) asSubstringFilter! !

!StPackageProcessor class methodsFor: 'accessing' stamp: ''!
order
	
	^ 100! !

!StPackageProcessor class methodsFor: 'settings' stamp: ''!
hideInSettings

	"I am hidden because the implementation in the unified processor is richer"
	^ true! !

!StPackageProcessor class methodsFor: 'default-settings' stamp: ''!
defaultEnabled

	^ false! !

!StPackageProcessor class methodsFor: 'accessing' stamp: ''!
title
	^ 'Packages'! !

!StPackageProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisPackage

	self runForText: 'newtools-spotter-processors-tests'.
	self assertResultsIncludes: self class package! !

!StPackageProcessorTest methodsFor: 'tests' stamp: ''!
processor

	^ StPackageProcessor new! !

!StPackageProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisPackageAfterAddingText

	self runForText: 'newtools-spo'.
	self runForText: 'newtools-spotter-processors-tests'.

	self assertResultsIncludes: self class package
	
	! !

!StPackageProcessorTest methodsFor: 'tests' stamp: ''!
testGTSpotterNewIsRemovedAfterAddingText

	self runForText: 'gt-spotter'.
	self rerunWithText: 'gt-spotter-new-te'.
	
	self denyResultsIncludes: StClassProcessor package! !

!StPackageProcessorTest methodsFor: 'tests' stamp: ''!
testPopularStringDoesReturnOnlyTenResults

	self runForText: 'test'.
	self assertQuantityOfResults: 25.! !

!StPeelToFirstCommand commentStamp: ''!
Requests the debugger to peel the stack to the first occurrence of the currently selected message in the stack!
!StPeelToFirstCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ true! !

!StPeelToFirstCommand methodsFor: 'actions' stamp: ''!
execute
	self debugger peelToFirstLike: self debugger currentContext! !

!StPeelToFirstCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ nil! !

!StPeelToFirstCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName
	^ #down! !

!StPeelToFirstCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription
	^ 'Peels the stack back to the second occurance of the currently selected message.'! !

!StPeelToFirstCommand class methodsFor: 'accessing' stamp: ''!
defaultName
	^ 'Peel to first like this'! !

!StPharoApplication commentStamp: ''!
The application for the Pharo IDE.!
!StPharoApplication methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self resetConfiguration.
	SystemAnnouncer uniqueInstance weak 
		when: UIThemeChanged 
		send: #resetConfiguration
		to: self! !

!StPharoApplication methodsFor: 'system startup' stamp: ''!
shutDown: quitting! !

!StPharoApplication methodsFor: 'settings' stamp: ''!
toolbarDisplayMode

	^ StPharoSettings toolbarDisplayMode! !

!StPharoApplication methodsFor: '*NewTools-Playground' stamp: ''!
addSharedBinding: aBinding
	
	self sharedBindings add: aBinding! !

!StPharoApplication methodsFor: '*NewTools-Playground' stamp: ''!
removeSharedBinding: aBinding

	self sharedBindings removeKey: aBinding key! !

!StPharoApplication methodsFor: 'private - factory' stamp: ''!
newIconProvider

	^ StPharoDefaultIconProvider new! !

!StPharoApplication methodsFor: 'running' stamp: ''!
run 

	Current ifNotNil: [ Current close ].
	super run. 
	Current := self! !

!StPharoApplication methodsFor: 'accessing - resources' stamp: ''!
defaultWindowExtent
	
	self flag: #TODO. "Replace this with a real real estate"
	^ 800@600! !

!StPharoApplication methodsFor: 'private - running' stamp: ''!
start

	! !

!StPharoApplication methodsFor: 'initialization' stamp: ''!
resetConfiguration
	
	self flag: #TODO. "Replace this with a proper initialization mechanism (which is not
	implemented at the moment, and we need to choose the backend from it)"
	self class environment 
		at: #StPharoMorphicConfiguration
		ifPresent: [ :aClass | self useBackend: #Morphic with: aClass new ]! !

!StPharoApplication methodsFor: 'system startup' stamp: ''!
startUp: resuming

	self resetConfiguration! !

!StPharoApplication methodsFor: 'accessing - resources' stamp: ''!
tools

	^ Smalltalk os tools! !

!StPharoApplication methodsFor: '*NewTools-Morphic' stamp: ''!
useMorphic

	self
		useBackend: #Morphic 
		with: StPharoMorphicConfiguration new! !

!StPharoApplication methodsFor: '*NewTools-Playground' stamp: ''!
sharedBindings
	"bindings that are shared by all playgrounds"
	
	^ self 
		propertyAt: #sharedBindings 
		ifAbsentPut: [ Dictionary new ]! !

!StPharoApplication class methodsFor: 'class initialization' stamp: ''!
initialize 

	SessionManager default registerToolClassNamed: self name! !

!StPharoApplication class methodsFor: 'instance creation' stamp: ''!
current 
	
	^ Current ifNil: [ Current := self new ]! !

!StPharoApplication class methodsFor: 'system startup' stamp: ''!
shutDown: quitting

	Current ifNil: [ ^ self ].
	Current shutDown: quitting! !

!StPharoApplication class methodsFor: 'system startup' stamp: ''!
startUp: resuming

	Current ifNil: [ ^ self ].
	Current startUp: resuming! !

!StPharoApplication class methodsFor: 'private' stamp: ''!
use: application during: aBlock 
	| oldCurrent |
	
	oldCurrent := Current.
	Current := application.
	^ aBlock ensure: [ Current := oldCurrent ]! !

!StPharoDefaultIconProvider methodsFor: 'class initialization' stamp: ''!
initialize

	super initialize. 
	synonyms := Dictionary new.
	self initializeSynonyms! !

!StPharoDefaultIconProvider methodsFor: 'class initialization' stamp: ''!
initializeSynonyms

	synonyms 
		at: #debuggerCopyStack 			put: #smallCopy;
		at: #debuggerDefineEntity 		put: #changeAdd;
		at: #debuggerPeelToFirst 		put: #down;
		at: #debuggerProceed 				put: #glamorousGo;
		at: #debuggerRestart 				put: #glamorousRestart;
		at: #debuggerReturn 				put: #refresh;
		at: #debuggerStepInto 			put: #glamorousInto;
		at: #debuggerStepOver 			put: #glamorousOver;
		at: #debuggerStepThrough 		put: #glamorousThrough;
		at: #debuggerRunToSelection 	put: #glamorousRightSide; 
		at: #debuggerWhereIs 				put: #glamorousSearch! !

!StPharoDefaultIconProvider methodsFor: 'accessing' stamp: ''!
iconNamed: aSymbol

	^ super iconNamed: (synonyms 
		at: aSymbol 
		ifAbsent: [ aSymbol ])! !

!StPharoMorphicConfiguration methodsFor: 'configuring' stamp: ''!
configureUnix: anApplication
	
	anApplication styleSheet: self styleSheet! !

!StPharoMorphicConfiguration methodsFor: 'configuring' stamp: ''!
configure: anApplication

	super configure: anApplication! !

!StPharoMorphicConfiguration methodsFor: 'private' stamp: ''!
styleSheet

	^ StPharoStyleContributor availableContributors 
		inject: SpStyle defaultStyleSheet 
		into: [ :accum :each | accum, (each styleSheetContribution) ]! !

!StPharoMorphicConfiguration methodsFor: 'private' stamp: ''!
styleSheetOSX
	"Just an example on how to build styles programatically ;)"

	^ SpStyle newApplication 
		addClass: 'label' with: [ :label |
			label addClass: 'shortcut' with: [ :shortcut |
				shortcut addPropertyFontWith: [ :font |
					font name: 'Lucida Grande'; size: 10 ] ] ];
		yourself! !

!StPharoMorphicConfiguration methodsFor: 'configuring' stamp: ''!
configureOSX: anApplication
	
	anApplication styleSheet: (self styleSheet, self styleSheetOSX)
	! !

!StPharoMorphicConfiguration methodsFor: 'configuring' stamp: ''!
configureWindows: anApplication
	
	anApplication styleSheet: self styleSheet! !

!StPharoMorphicConfiguration class methodsFor: 'defaults' stamp: ''!
defaultStyleSheet

	^ SpStyle defaultStyleSheet! !

!StPharoSettings class methodsFor: 'settings' stamp: ''!
toolbarDisplayMode
	"Defines how the toolbar will be displayed (icons+text, icons, text)"

	^ ToolbarDisplayMode ifNil: [ ToolbarDisplayMode := self defaultToolbarDisplayMode ]! !

!StPharoSettings class methodsFor: 'settings' stamp: ''!
toolbarDisplayMode: aMode
	"self toolbarDisplayMode: SpToolbarDisplayMode modeIcon"
	
	ToolbarDisplayMode := aMode! !

!StPharoSettings class methodsFor: 'defaults' stamp: ''!
defaultCodeShowLineNumbers

	^ true! !

!StPharoSettings class methodsFor: 'settings' stamp: ''!
codeShowLineNumbers: aBoolean 

	CodeShowLineNumbers := aBoolean! !

!StPharoSettings class methodsFor: 'settings' stamp: ''!
codeShowLineNumbers
	"Defines if code editors will display line numbers"

	^ CodeShowLineNumbers ifNil: [ CodeShowLineNumbers := self defaultCodeShowLineNumbers ]! !

!StPharoSettings class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>

	(aBuilder setting: #codeShowLineNumbers)
		parent: #tools;
		order: 0;
		default: self codeShowLineNumbers;
		target: self;
		description: 'If code panels will display line numbers';
		label: 'Show line numbers in code panels'.

	(aBuilder pickOne: #toolbarDisplayMode)
		parent: #tools;
		order: 1;
		default: self toolbarDisplayMode;
		target: self;
		domainValues: (SpToolbarDisplayMode all collect: [ :each | each label -> each ]);
		description: 'Toolbars will be displayed in icon+label, icon, or label mode.';
		label: 'Toolbar display mode'		! !

!StPharoSettings class methodsFor: 'defaults' stamp: ''!
defaultToolbarDisplayMode

	^ SpToolbarDisplayMode modeIconAndLabel! !

!StPharoStyleContributor commentStamp: ''!
This class presents an entry point to extend the stylesheet used by the Pharo application.
Subclasses of it should implement #styleSheetContribution returning a StyleSheet that is composed with the default one. 

Also subclasses are able to extend the #isApplicable method in the class side and decide to apply or not in different scenarios (e.g., different Operating Systems)!
!StPharoStyleContributor methodsFor: 'styles' stamp: ''!
styleSheetContribution
	
	^ self subclassResponsibility
! !

!StPharoStyleContributor class methodsFor: 'as yet unclassified' stamp: ''!
availableContributors

	^ self allSubclasses
		select: [ :each | each isApplicable ]
		thenCollect: [ :each | each new ]! !

!StPharoStyleContributor class methodsFor: 'testing' stamp: ''!
isApplicable 

	^ true! !

!StPlayground commentStamp: ''!
It is useful to explore ideas or learn something before writing it to a more definitive place.
In older versions of Pharo, this tool was known as Workspace.

The idea of a playground is not new in smalltalk systems and many other dynamic languages have implemented in one way or another some features of it, usually through a REPL, which shares much of a playground functionality. 

Some of the things a playground can do for you: 

- it can execute code (and print its results).
- it can debug some piece of code you just typed.
- it can search references, implementors and senders
- it can store variables (both locally or shared to all playgrounds).

!!!! Opening:
You usually will open a playground by choosing it from the Pharo menu (Playground option), but it can also be opened programatically. 
[[[language=Smalltalk
StPlayground open.
StPlayground openContents: 'Some scripting'
]]]

!!!! Using the playground
Most of the functionalities a playground does can be found in the context menu of it (==<meta+t>== or right button click), and we will not explain in detail each of them. But there are some usages that may requirse some more documentation than "self discovery". Here are some hints you may find useful: 

!!!!!! Keyboard friendly
There is a shortcut, ==<meta+t>==, that will show the context menu corresponding to the playground. Additionaly, there will be entries to control also what you can find in the toolbar or status bar. This redundancy is intentional and it will allow the user to navigate through all the options of the playgrounds without needing a secondary device (which, of course, can be used anyway if desired).

!!!!!! The print it popover
If you try to print results of a computation, you will see that you receive a popover with the results of the execution (e.g. ==21*2== will show a popover with the ==42== number). There are some other things you can do with this popover besides just dismiss it (pressing ==<esc>==, ==<backspace>== or just focusing somewhere else).
You can also: 

- press ==<cr>== to print the result into your playground (it will be shown enclosed with "quotation marks", as a comment.
- press ==<meta+i>== to inspect the result.

!!!!!! The bindings window
The bindings window will be shown by selecting the "Bindings" option of the context menu or toolbar.
You will see the variables panel and an inspector allowing you to explore/modify the values of a variable. There is also a context menu in the variables list that will allow you some other options. One interesting option you will see is the "make variable shared" option. This option will make the variable common to all playgrounds. It is an easy way to explore some posibilities in a separated space, not modifying what you already have there.

See *class:StPlaygroundBindingsPresenter*

!!!!!! The pages window
The pages window will be shown by selecting the "Pages" option of the context menu or toolbar.
This window will list all playgrounds pages stored in the playground cache directory. You can choose any playground edited in any moment and load it into your playgroud.

See *class:StPlaygroundPagesPresenter*
!
!StPlayground methodsFor: 'private - stepping' stamp: ''!
startProcessing
	
	"A playground does not steps, do nothing"! !

!StPlayground methodsFor: 'actions' stamp: ''!
loadPage: aFileReference

	self firstPage loadPage: aFileReference! !

!StPlayground methodsFor: 'api - focus' stamp: ''!
defaultKeyboardFocus

	^ self firstPage! !

!StPlayground methodsFor: 'private - factory' stamp: ''!
newDefaultPlaygroundPage

	^ StPlaygroundPage new! !

!StPlayground methodsFor: 'initialization' stamp: ''!
windowIcon
	
	^ self application iconNamed: #workspace! !

!StPlayground methodsFor: 'accessing' stamp: ''!
page

	^ self firstPage page! !

!StPlayground methodsFor: 'private - stepping' stamp: ''!
stopProcessing
	
	"A playground does not steps, but it needs to force a flush of last changes"
	self firstPage ensureContentsFlushed! !

!StPlayground methodsFor: 'accessing' stamp: ''!
contents: aString 

	self firstPage contents: aString! !

!StPlayground methodsFor: 'private - factory' stamp: ''!
newInspectorFor: aModel
	| modelToInspectOrPlayground |
	
	modelToInspectOrPlayground := (millerList pages isEmpty and: [ aModel isNil ]) 
		ifTrue: [ self newDefaultPlaygroundPage ]
		ifFalse: [ aModel ].

	^ super newInspectorFor: modelToInspectOrPlayground! !

!StPlayground methodsFor: 'initialization' stamp: ''!
windowTitle

	^ self class defaultTitle! !

!StPlayground class methodsFor: 'instance creation' stamp: ''!
openContents: aString
	"Open a new workspace with the given contents. It looks better when aString is code since the style is applied"

	^ self new
		contents: aString;
		openWithSpec! !

!StPlayground class methodsFor: 'class initialization' stamp: ''!
initialize

	"Make playground active by default"
	self register! !

!StPlayground class methodsFor: 'accessing' stamp: ''!
cacheDirectory
	
	^ CacheDirectory ifNil: [ self defaultCacheDirectory ]! !

!StPlayground class methodsFor: 'private' stamp: ''!
defaultCacheDirectory
	
	^ (FileLocator localDirectory / 'play-cache') ensureCreateDirectory! !

!StPlayground class methodsFor: 'accessing' stamp: ''!
defaultTitle 

	^ 'Playground'! !

!StPlayground class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]" 

	registry register: self as: #workspace
! !

!StPlayground class methodsFor: 'instance creation' stamp: ''!
open 
	<script>
	
	^ self new openWithSpec! !

!StPlayground class methodsFor: 'accessing' stamp: ''!
defaultExtent

	^ 600@400! !

!StPlayground class methodsFor: 'accessing' stamp: ''!
cacheDirectory: aDirectory
	
	self flag: #TODO. "This go to settings"
	CacheDirectory := aDirectory ensureCreateDirectory! !

!StPlayground class methodsFor: 'tools registry' stamp: ''!
register
	"Add ourselves to registry. See [Smalltalk tools]" 
	<script>

	self registerToolsOn: Smalltalk tools! !

!StPlayground class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #Playground)
		parent: #InputOutput;
		action: [ Smalltalk tools openWorkspace ];
		order: 1;
		keyText: 'o, w';
		help: 'A window used as a scratchpad area where fragments of Pharo code can be entered, stored, edited, and evaluated.';
		icon: (self iconNamed: #workspaceIcon)! !

!StPlaygroundAdoptVersionCommand commentStamp: ''!
Adopt selected version on current playground. 
This command is to be used on `StPlaygroundPageVersionsPresenter`!
!StPlaygroundAdoptVersionCommand methodsFor: 'executing' stamp: ''!
execute

	self context doAdoptVersion! !

!StPlaygroundAdoptVersionCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultDescription

	^ 'Adopt version contents in current playground'! !

!StPlaygroundAdoptVersionCommand class methodsFor: 'accessing - defaults' stamp: ''!
defaultName

	^ 'Adopt'! !

!StPlaygroundAdoptVersionOnNewPlaygroundCommand commentStamp: ''!
Adopt selected version in a new playground. 
This command is to be used on `StPlaygroundPageVersionsPresenter`!
!StPlaygroundAdoptVersionOnNewPlaygroundCommand methodsFor: 'executing' stamp: ''!
execute

	self context doAdoptVersionOnNewPlayground! !

!StPlaygroundAdoptVersionOnNewPlaygroundCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Adopt version contents in new playground'! !

!StPlaygroundAdoptVersionOnNewPlaygroundCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Adopt on new playground'! !

!StPlaygroundBaseTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ self subclassResponsibility! !

!StPlaygroundBaseTest methodsFor: 'private - utilities' stamp: ''!
waitUntilUIRedrawed

	backendForTest waitUntilUIRedrawed! !

!StPlaygroundBaseTest methodsFor: 'running' stamp: ''!
tearDown

	presenter withWindowDo: [ :window | window close ].
	super tearDown! !

!StPlaygroundBaseTest methodsFor: 'running' stamp: ''!
initializeInstanceBeforeInitialization: aPresenter
	! !

!StPlaygroundBaseTest methodsFor: 'running' stamp: ''!
initializeInstance: aPresenter
	! !

!StPlaygroundBaseTest methodsFor: 'instance creation' stamp: ''!
newPage 

	^ StPlaygroundPage new 
		timeToWait: 5 milliSeconds;
		baseDirectory: memoryFileSystem;
		yourself! !

!StPlaygroundBaseTest methodsFor: 'private - utilities' stamp: ''!
openInstance

	presenter openWithSpec! !

!StPlaygroundBaseTest methodsFor: 'running' stamp: ''!
initializeMemoryFileSystem: aFileSystem! !

!StPlaygroundBaseTest methodsFor: 'private - utilities' stamp: ''!
waitUntilContentsAreFlush
		
	20 milliSeconds wait
	! !

!StPlaygroundBaseTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	backendForTest := SpMorphicBackendForTest new.
	application := StPharoApplication new.
	
	memoryFileSystem := FileSystem memory.
	self initializeMemoryFileSystem: memoryFileSystem.
		
	presenter := self classToTest basicNew. 
	self initializeInstanceBeforeInitialization: presenter.
	presenter application: application.
	presenter initialize.
	self initializeInstance: presenter! !

!StPlaygroundBaseTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self = StPlaygroundBaseTest ]! !

!StPlaygroundBindingsCommand commentStamp: ''!
Show the page bindings browser.!
!StPlaygroundBindingsCommand methodsFor: 'execution' stamp: ''!
execute 

	(StPlaygroundBindingsPresenter 
		newApplication: context application 
		model: context) 
		openDialogWithSpec! !

!StPlaygroundBindingsCommand class methodsFor: 'default' stamp: ''!
defaultIconName

	^ #glamorousTable! !

!StPlaygroundBindingsCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Edit bindings list.'! !

!StPlaygroundBindingsCommand class methodsFor: 'accessing' stamp: ''!
order

	^ 10! !

!StPlaygroundBindingsCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Bindings'! !

!StPlaygroundBindingsPresenter commentStamp: ''!
I am a presenter to show all bindings of parent Playground.
I show a list of active bindings. 
A panel to inspect each of the bindings values is shown too.!
!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
newCodeWithTransmissionOn: aBinding
	
	^ self newCode 
		text: aBinding value printString;
		beNotEditable;
		withoutSyntaxHighlight;
		withoutLineNumbers; 
		yourself! !

!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
updatePresenterKeepingSelection
	| selection |
	
	selection := self selectedBinding.
	self updatePresenterWithSelection: [ 
		bindingList selectItem: ((bindingList items includes: selection) 
			ifTrue: [ selection ]
			ifFalse: [ bindingList items first ]) ]! !

!StPlaygroundBindingsPresenter methodsFor: 'actions' stamp: ''!
removeSelectedBinding

	self selectedBindingIsLocal 
		ifTrue: [ parent interactionModel removeBinding: self selectedBinding ]
		ifFalse: [ self application removeSharedBinding: self selectedBinding ].
	self updatePresenterKeepingSelection! !

!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
newInspectorWithTransmission: aClass on: aBinding
	
	^ self 
		instantiate: aClass 
		on: aBinding value! !

!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
updatePresenter
	
	self updatePresenterWithSelection: [
		bindingList selectIndex: 1 ]! !

!StPlaygroundBindingsPresenter methodsFor: 'testing' stamp: ''!
isLocalBinding: aBinding

	^ (self application sharedBindings includesKey: aBinding key) not! !

!StPlaygroundBindingsPresenter methodsFor: 'testing' stamp: ''!
selectedBindingIsLocal
	| selection |

	selection := self selectedBinding.
	selection ifNil: [ ^ false ].
	
	^ self isLocalBinding: selection! !

!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
initializeListPanel

	bindingPanel := (self instantiate: StHeaderPanel)
		number: 1;
		label: 'Bindings'.
		
	bindingList := self newTable
		addColumn: (SpStringTableColumn title: 'Name' evaluated: [ :each | each key ]);
		addColumn: (SpStringTableColumn 
			title: 'Scope' 
			evaluated: [ :each | self scopeNameFor: each ]) 
			beNotExpandable;
		contextMenu: [ self contextMenu ];
		contextKeyBindings: self contextMenuKeyBindings;
		yourself.
	
	bindingPanel presenter: bindingList! !

!StPlaygroundBindingsPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aPlayground

	parent := aPlayground! !

!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
initializeInspectorPanel

	inspectorPanel := (self instantiate: StHeaderPanel)
		number: 2;
		label: 'Inspector'.

	inspector := self newPresenterSelector
		when: [ :aBinding | aBinding notNil ] show: [ :aBinding | 
			self flag: #TODO. "Temporal? This is to avoid a dependency (while making 
			inspector work properly)"
			self class environment 
				at: #StInspector
				ifPresent: [ :aClass | self newInspectorWithTransmission: aClass on: aBinding ]
				ifAbsent: [ self newCodeWithTransmissionOn: aBinding ] ];
		when: [ :aBinding | aBinding isNil ] show: [ 
			bindingList items
				ifNotEmpty: [ self class unselectedMessage asPresenter ]
				ifEmpty: [ self class emptyMessage asPresenter ] ];
		updatePresenter.

	inspectorPanel presenter: inspector! !

!StPlaygroundBindingsPresenter methodsFor: 'accessing' stamp: ''!
bindings

	^ parent interactionModel bindings! !

!StPlaygroundBindingsPresenter methodsFor: 'actions' stamp: ''!
toggleSelectedBindingScope

	self selectedBindingIsLocal 
		ifTrue: [ self moveSelectedBindingToSharedScope ]
		ifFalse: [ self moveSelectedBindingToLocalScope ].
	self updatePresenterKeepingSelection! !

!StPlaygroundBindingsPresenter methodsFor: 'testing' stamp: ''!
hasSelectedBinding

	^ self selectedBinding notNil! !

!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
title

	parent withWindowDo: [ :w | 
		^ 'Bindings for {1}' format: { w title } ].
	^ self class defaultTitle! !

!StPlaygroundBindingsPresenter methodsFor: 'private' stamp: ''!
moveSelectedBindingToLocalScope
	| selection |
		
	selection := self selectedBinding.
	parent interactionModel makeBindingLocal: selection! !

!StPlaygroundBindingsPresenter methodsFor: 'private' stamp: ''!
scopeNameFor: aBinding

	^ self application sharedBindings
		at: aBinding key
		ifPresent: [ :found | 'shared' ]
		ifAbsent: [ 'local' ]! !

!StPlaygroundBindingsPresenter methodsFor: 'private' stamp: ''!
contextMenu

	^ self contextMenuActions asMenuPresenter! !

!StPlaygroundBindingsPresenter methodsFor: 'private' stamp: ''!
contextMenuKeyBindings

	^ self contextMenuActions asKMCategory! !

!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter

	aDialogWindowPresenter 
		centeredRelativeTo: parent window;
		addButton: 'Close' do: [ :presenter | 
			presenter triggerOkAction.
			presenter close ]! !

!StPlaygroundBindingsPresenter methodsFor: 'accessing' stamp: ''!
selectedBinding

	^ bindingList ifNotNil: [ bindingList selection selectedItem ]! !

!StPlaygroundBindingsPresenter methodsFor: 'private' stamp: ''!
moveSelectedBindingToSharedScope
	| selection |
		
	selection := self selectedBinding.
	parent interactionModel makeBindingShared: selection! !

!StPlaygroundBindingsPresenter methodsFor: 'private' stamp: ''!
contextMenuActions

	^ CmCommandGroup forSpec
		beRoot;
		register: (StRemoveBindingCommand forSpecContext: self);
		register: (StToggleBindingCommand forSpecContext: self);
		yourself! !

!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	super initializeWindow: aWindowPresenter.
	aWindowPresenter 
		title: self title;
		initialExtent: self class defaultExtent! !

!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
updatePresenterWithSelection: aBlock
	| newBindings oldBindings |

	newBindings := self sortedBindingAssociations. 
	oldBindings := bindingList items.
	"I re-set the items even if they are the same because I want to force a refresh"	
	bindingList items: newBindings.
	newBindings = oldBindings ifTrue: [ ^ self ].
	newBindings ifNotEmpty: aBlock! !

!StPlaygroundBindingsPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self initializeListPanel.
	self initializeInspectorPanel.
	
	bindingList transmitTo: inspector.
! !

!StPlaygroundBindingsPresenter methodsFor: 'accessing' stamp: ''!
sortedBindingAssociations

	^ self bindings associations sort: [ :a | self isLocalBinding: a ] ascending! !

!StPlaygroundBindingsPresenter class methodsFor: 'accessing' stamp: ''!
emptyMessage

	^ 'There are no bindings to list.'! !

!StPlaygroundBindingsPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newLeftToRight
		positionOfSlider: 30 percent;
		add: #bindingPanel;
		add: #inspectorPanel;
		yourself! !

!StPlaygroundBindingsPresenter class methodsFor: 'accessing' stamp: ''!
unselectedMessage

	^ 'Select a variable to inspect its value.'! !

!StPlaygroundBindingsPresenter class methodsFor: 'accessing' stamp: ''!
defaultTitle

	^ 'Bindings'! !

!StPlaygroundBindingsPresenter class methodsFor: 'accessing' stamp: ''!
defaultExtent

	^ 600@400! !

!StPlaygroundCommand commentStamp: ''!
A base command for playground actions (the ones that are specific of the playground).!
!StPlaygroundCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == StPlaygroundCommand! !

!StPlaygroundCommand class methodsFor: 'accessing' stamp: ''!
order

	^ 100! !

!StPlaygroundDoItCommand commentStamp: ''!
I'm a "do it and inspect" command.
I will select all contents of a playground and I will execute it, inspecting the result.!
!StPlaygroundDoItCommand methodsFor: 'execution' stamp: ''!
execute 

	context doEvaluateAllAndGo! !

!StPlaygroundDoItCommand class methodsFor: 'default' stamp: ''!
defaultIconName

	^ #glamorousGo! !

!StPlaygroundDoItCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Do it all and inspect.'! !

!StPlaygroundDoItCommand class methodsFor: 'accessing' stamp: ''!
order

	^ 0! !

!StPlaygroundDoItCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Do it'! !

!StPlaygroundInteractionModel commentStamp: ''!
An interaction model to be used in playground contexts. 
It will allow a playground to share variables.!
!StPlaygroundInteractionModel methodsFor: 'binding' stamp: ''!
addBinding: aBinding

	(self isGlobalVariable: aBinding key) ifTrue: [ ^ self ].
	bindings ifNil: [ bindings := Dictionary new ].
	bindings add: aBinding! !

!StPlaygroundInteractionModel methodsFor: 'accessing' stamp: ''!
application

	^ self owner application! !

!StPlaygroundInteractionModel methodsFor: 'binding' stamp: ''!
hasBindingOf: aString

	^ (self sharedBindings includesKey: aString asSymbol)
		or: [ (self localBindings includesKey: aString asSymbol) ]! !

!StPlaygroundInteractionModel methodsFor: 'private' stamp: ''!
isGlobalVariable: aSymbol

	^ (self class environment classNamed: aSymbol) notNil! !

!StPlaygroundInteractionModel methodsFor: 'binding' stamp: ''!
bindingOf: aString
	| key |

	key := aString asSymbol.
	"prevent the case when a tool (like completion) asks for a global binding"
	(self class bindingOf: key) ifNotNil: [ :aBinding | ^ aBinding ].
	"Look in shared"
	(self sharedBindings includesKey: key)
		ifTrue: [ ^ self sharedBindings associationAt: key ].
	"if there is no binding, I will include a key"
	(self localBindings includesKey: key)
		ifFalse: [ self addBinding: (WorkspaceVariable key: key) ].
	^ self localBindings associationAt: key! !

!StPlaygroundInteractionModel methodsFor: 'accessing' stamp: ''!
makeBindingShared: aBinding	
	
	self removeBinding: aBinding.
	self application addSharedBinding: aBinding! !

!StPlaygroundInteractionModel methodsFor: 'accessing' stamp: ''!
makeBindingLocal: aBinding	

	self application removeSharedBinding: aBinding.
	self addBinding: aBinding! !

!StPlaygroundInteractionModel methodsFor: 'accessing' stamp: ''!
sharedBindings
	
	^ self application sharedBindings 

! !

!StPlaygroundInteractionModel methodsFor: 'binding' stamp: ''!
bindings
	"Combining shared bindings and local bindings needs to be done like this because the 
	 #add: method of Dictionary stores the whole association (which in this case is a 
	 WorkspaceVariable and we need that. #at:put: cannot be used because it will create 
	 an Association and want to keep the WorkspaceVariable."
	| joinedBindings |
	
	"just a small optimisation"
	self application sharedBindings ifEmpty: [ ^ self localBindings ].

	joinedBindings := self application sharedBindings copy.
	self localBindings associations 
		do: [ :each | joinedBindings add: each ].

	^ joinedBindings! !

!StPlaygroundInteractionModel methodsFor: 'accessing' stamp: ''!
localBindings
	
	^ super bindings

! !

!StPlaygroundInteractionModel methodsFor: 'binding' stamp: ''!
addBindings: aCollection

	aCollection do: [ :each | self addBinding: each ]! !

!StPlaygroundInteractionModelTest methodsFor: 'tests' stamp: ''!
testMakeBindingLocal
	| im1 im2 binding |
	
	im1 := self newInteractionModel.
	im2 := self newInteractionModel.
	
	binding := WorkspaceVariable key: #testBinding value: 42.
	application addSharedBinding: binding.

	self assert: (application sharedBindings includesKey: #testBinding).
	self assert: (im1 hasBindingOf: #testBinding).
	self assert: (im2 hasBindingOf: #testBinding).
	
	im1 makeBindingLocal: binding.
	self deny: (application sharedBindings includesKey: #testBinding).
	self assert: (im1 hasBindingOf: #testBinding).
	self deny: (im2 hasBindingOf: #testBinding)! !

!StPlaygroundInteractionModelTest methodsFor: 'instance creation' stamp: ''!
newInteractionModel

	^ StPlaygroundInteractionModel new
		owner: (StPlayground new
			application: application;
			yourself);
		yourself! !

!StPlaygroundInteractionModelTest methodsFor: 'tests' stamp: ''!
testMakeBindingShared
	| im1 im2 binding |
	
	im1 := self newInteractionModel.
	im2 := self newInteractionModel.
	
	binding := WorkspaceVariable key: #testBinding value: 42.

	im1 addBinding: binding.
	self deny: (application sharedBindings includesKey: #testBinding).
	self assert: (im1 hasBindingOf: #testBinding).
	self deny: (im2 hasBindingOf: #testBinding).
	
	im1 makeBindingShared: binding.
	self assert: (application sharedBindings includesKey: #testBinding).
	self assert: (im1 hasBindingOf: #testBinding).
	self assert: (im2 hasBindingOf: #testBinding)
	! !

!StPlaygroundInteractionModelTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	application := StPharoApplication new.! !

!StPlaygroundLoadPageCommand commentStamp: ''!
Load selected page on current playground. 
This command is to be used on `StPlaygroundPagesPresenter`!
!StPlaygroundLoadPageCommand methodsFor: 'executing' stamp: ''!
execute

	self context doLoadPage! !

!StPlaygroundLoadPageCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Load page contents in current playground'! !

!StPlaygroundLoadPageCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Load'! !

!StPlaygroundLoadPageOnNewPlaygroundCommand commentStamp: ''!
Load selected page in a new playground. 
This command is to be used on `StPlaygroundPagesPresenter`!
!StPlaygroundLoadPageOnNewPlaygroundCommand methodsFor: 'executing' stamp: ''!
execute

	self context doLoadPageOnNewPlayground! !

!StPlaygroundLoadPageOnNewPlaygroundCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Load page contents in new playground'! !

!StPlaygroundLoadPageOnNewPlaygroundCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Load on new playground'! !

!StPlaygroundMenuExtensionCommand commentStamp: ''!
Extension point to add functionality to the playground. 

Commands inheriting `StPlaygroundMenuExtensionCommand` will be added to the playground context menu.!
!StPlaygroundMenuExtensionCommand class methodsFor: 'accessing' stamp: ''!
allCommands

	^ self allSubclasses! !

!StPlaygroundPage commentStamp: ''!
!! Playground pages (StPlaygroundPage)

A playground page keeps in sync what is being typed into a playground and the disk cache.
Pages are stored (by default) at ==StPlayground cacheDirectory== and have a timestamp as name.

@@TODO complete!
!StPlaygroundPage methodsFor: 'accessing' stamp: ''!
timeToWait: aDuration

	timeToWait := aDuration! !

!StPlaygroundPage methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	contentReceived := false.
	creationTime := DateAndTime now.
	mutex := Mutex new! !

!StPlaygroundPage methodsFor: 'accessing' stamp: ''!
creationTime

	^ creationTime! !

!StPlaygroundPage methodsFor: 'inspector compatibility' stamp: ''!
defaultObjectInspectorClass
	"Since the playground can be the starting point of an inspection (using <meta+g>), the 
	 playground page (which is the model of a playground) needs to behave as a valid starting point. 
	 This method declares answer the presenter to use in the inspection miller list."

	^ StPlaygroundPagePresenter! !

!StPlaygroundPage methodsFor: 'inspector compatibility' stamp: ''!
asInspectorModel
	"Since the playground can be the starting point of an inspection (using <meta+g>), the 
	 playground page (which is the model of a playground) needs to behave as a valid starting point. 
	 This method declares the page as a valid inspector model."

	^ self! !

!StPlaygroundPage methodsFor: 'accessing' stamp: ''!
timeToWait

	^ timeToWait ifNil: [ self class defaultTimeToWait ]! !

!StPlaygroundPage methodsFor: 'accessing' stamp: ''!
baseDirectory: aDirectory
	
	baseDirectory := aDirectory! !

!StPlaygroundPage methodsFor: 'accessing' stamp: ''!
fileName

	^ fileName ifNil: [ fileName := self creationTimeForFileName ]! !

!StPlaygroundPage methodsFor: 'accessing versions' stamp: ''!
versions
	
	^ Array streamContents: [ :stream | 
		self versionLog entriesDo: [ :anEntry | 
			stream nextPut: anEntry ] ]! !

!StPlaygroundPage methodsFor: 'accessing' stamp: ''!
fileReference

	^ (self baseDirectory / self fileName) withExtension: self class pageExtension! !

!StPlaygroundPage methodsFor: 'private' stamp: ''!
storeVersion
	| entry |

	"If last version is equal to the one that I want to store, skip it"
	self versions ifNotEmpty: [ :versions | 
		versions last content = self contents 
			ifTrue: [ ^ self ] ].
	"store new version"
	entry := OmEntry content: self contents.
	entry tags at: #timestamp put: DateAndTime now.
	self versionLog newEntry: entry! !

!StPlaygroundPage methodsFor: 'accessing versions' stamp: ''!
versionLog
	
	^ versionLog ifNil: [ 
		versionLog := OmFileStore fromFile: (self fileReference withExtension: 'ombu') ]! !

!StPlaygroundPage methodsFor: 'initialization' stamp: ''!
fromReference: aFileReference

	aFileReference parent = self baseDirectory 
		ifFalse: [ self baseDirectory: aFileReference parent ].
	fileName := aFileReference basenameWithoutExtension.
	creationTime := aFileReference creationTime! !

!StPlaygroundPage methodsFor: 'accessing' stamp: ''!
contents

	^ self fileReference 
		ifExists: [ :ref | ref contents ]
		ifAbsent: [ '' ]! !

!StPlaygroundPage methodsFor: 'private' stamp: ''!
creationTimeForFileName

	^ (self creationTime asString 
		copyReplaceAll: ':' with: '-') 
		copyReplaceAll: '.' with: '-'! !

!StPlaygroundPage methodsFor: 'private' stamp: ''!
flush

	mutex critical: [ 
		flushContents ifNil: [ ^ self ].
		self fileReference parent ensureCreateDirectory.
		self fileReference 
			ensureDelete;
			writeStreamDo: [ :stream |
				stream << flushContents ].
		flushContents := nil.
		self storeVersion ]! !

!StPlaygroundPage methodsFor: 'accessing' stamp: ''!
baseDirectory
	
	^ baseDirectory ifNil:[ StPlayground cacheDirectory ]! !

!StPlaygroundPage methodsFor: 'accessing' stamp: ''!
contents: aString

	aString asString trimmed ifEmpty: [ ^ self ].
	mutex critical: [
		self basicContents: aString.
		contentReceived := true.
		self spawnFlushProcess ]! !

!StPlaygroundPage methodsFor: 'private' stamp: ''!
spawnFlushProcess

	(flushProcess notNil 
		and: [ flushProcess isTerminated not ])
		ifTrue: [ ^ self ].
		
	flushProcess := [
 		[ contentReceived ] whileTrue: [
			contentReceived := false.
			self timeToWait wait ].
		self flush.
		flushProcess := nil.
		"in case I need to restart"
		contentReceived ifTrue: [ self spawnFlushProcess ].
	] fork! !

!StPlaygroundPage methodsFor: 'private' stamp: ''!
basicContents: aString 
	
	flushContents := aString! !

!StPlaygroundPage methodsFor: 'accessing' stamp: ''!
ensureContentsFlushed

	flushContents isEmptyOrNil ifTrue: [ ^ self ].
	self flush! !

!StPlaygroundPage class methodsFor: 'accessing' stamp: ''!
defaultTimeToWait

	^ 10 seconds! !

!StPlaygroundPage class methodsFor: 'accessing' stamp: ''!
pageExtension

	^ 'ph'! !

!StPlaygroundPage class methodsFor: 'instance creation' stamp: ''!
fromReference: aFileReference

	^ self new fromReference: aFileReference! !

!StPlaygroundPagePresenter commentStamp: ''!
The content of a playground page. 
Since `StPlayground` is in fact a miller list that allows users to navigate, the actual "playground" resides here.!
!StPlaygroundPagePresenter methodsFor: 'api - events' stamp: ''!
whenActivatedDo: aBlock

	activationBlock := aBlock! !

!StPlaygroundPagePresenter methodsFor: 'private' stamp: ''!
toolbarActions

	^ CmCommandGroup forSpec
		in: [ :this | self addToolbarCommandsTo: this ];
		yourself! !

!StPlaygroundPagePresenter methodsFor: 'initialization' stamp: ''!
initializeStatusbar 

	(statusbar := self instantiate: SpPresenter)
		layout: (SpBoxLayout newLeftToRight
			borderWidth: 3;
			vAlignCenter;
			add: (lineLabel := statusbar newLabel) expand: false;
			addLast: (toggleLineNumberButton := statusbar newToggleButton) expand: false;
			yourself).

	lineLabel addStyle: 'dim'.

	toggleLineNumberButton
		label: (StShowLineNumbersCommand iconLabelFor: self showLineNumbers);
		help: StShowLineNumbersCommand defaultDescription;
		state: self showLineNumbers;
		whenChangedDo: [ :state | self showLineNumbers: state ]! !

!StPlaygroundPagePresenter methodsFor: 'actions' stamp: ''!
loadPage: aFileReference

	self basicPage: (StPlaygroundPage fromReference: aFileReference).
	text text: page contents.
	^ page! !

!StPlaygroundPagePresenter methodsFor: 'testing' stamp: ''!
hasOutputActivationPort
	
	^ true! !

!StPlaygroundPagePresenter methodsFor: 'api - focus' stamp: ''!
defaultKeyboardFocus

	^ text! !

!StPlaygroundPagePresenter methodsFor: 'private' stamp: ''!
basicPage: aPage 

	page := aPage! !

!StPlaygroundPagePresenter methodsFor: 'accessing' stamp: ''!
selectedTextOrLine
	
	^ text selectedTextOrLine! !

!StPlaygroundPagePresenter methodsFor: 'private' stamp: ''!
addToolbarCommandsTo: aGroup

	self class toolbarCommands do: [ :each | 
		aGroup register: (each forSpecContext: self) ]! !

!StPlaygroundPagePresenter methodsFor: 'accessing' stamp: ''!
selectAll
	
	^ text selectAll! !

!StPlaygroundPagePresenter methodsFor: 'inspector compatibility' stamp: ''!
selectedPageName
	"Since the playground can be the starting point of an inspection (using <meta+g>), the 
	 page presenter (which is the playground itself) needs to respond to which kind of page 
	 is selected."

	^ self class defaultTitle! !

!StPlaygroundPagePresenter methodsFor: 'private' stamp: ''!
showLineNumbers

	^ StPharoSettings codeShowLineNumbers! !

!StPlaygroundPagePresenter methodsFor: 'initialization' stamp: ''!
updatePresenter

	self updateLineNumber! !

!StPlaygroundPagePresenter methodsFor: 'accessing' stamp: ''!
interactionModel

	^ text interactionModel! !

!StPlaygroundPagePresenter methodsFor: 'initialization' stamp: ''!
windowIcon
	
	^ self application iconNamed: #workspace! !

!StPlaygroundPagePresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aPage

	page := aPage! !

!StPlaygroundPagePresenter methodsFor: 'commands' stamp: ''!
doEvaluateAndGo
	| value |
	
	activationBlock ifNil: [ ^ self ].

	value := text 
		evaluate: text selectedTextOrLine
		onCompileError: [ ^ self ]
		onError: [ :e | e pass ].
	
	activationBlock value: (StEvaluatedSelectionModel newValue: value)! !

!StPlaygroundPagePresenter methodsFor: 'accessing' stamp: ''!
contents: aString

	text text: aString! !

!StPlaygroundPagePresenter methodsFor: 'accessing' stamp: ''!
ensureContentsFlushed
	
	self page ensureContentsFlushed! !

!StPlaygroundPagePresenter methodsFor: 'private' stamp: ''!
addMenuCommandsTo: aGroup

	self class extendedMenuCommands 
		do: [ :each | aGroup register: (each forSpecContext: self) ]	! !

!StPlaygroundPagePresenter methodsFor: 'private' stamp: ''!
menuActionsFor: aCodePresenter

	^ CmCommandGroup forSpec
		beRoot;
		register: ((CmCommandGroup named: 'Extra') asSpecGroup
			beDisplayedAsGroup;
			register: (StEvaluateCommand forSpecContext: self);
			yourself);
		register: (aCodePresenter rootCommandsGroup name: 'Code');
		register: (aCodePresenter editionCommandsGroup name: 'Edition');
		in: [ :this | self addMenuCommandsTo: this ];
		register: ((CmCommandGroup named: 'Playground') asSpecGroup
			register: ((CmCommandGroup named: 'Base options') asSpecGroup
				beDisplayedAsGroup;
				in: [ :this | self addToolbarCommandsTo: this ];
				yourself);
			register: ((CmCommandGroup named: 'Miscelaneous options') asSpecGroup
				beDisplayedAsGroup;
				register: (StShowLineNumbersCommand forSpecContext: self);
				yourself);
			yourself);
		yourself! !

!StPlaygroundPagePresenter methodsFor: 'private - updating' stamp: ''!
updateLineNumber
	| pos |
	
	lineLabel ifNil: [ ^ self ].	
	pos := text cursorPosition.
	lineLabel label: (pos 
		ifNotNil: [ ('Line: {1}:{2}' format: { pos y. pos x }) ]
		ifNil: [ '' ])! !

!StPlaygroundPagePresenter methodsFor: 'commands' stamp: ''!
doEvaluateAllAndGo

	self selectAll.
	self doEvaluateAndGo! !

!StPlaygroundPagePresenter methodsFor: 'api' stamp: ''!
activateOnDoubleClick
	"For compatibility, playground will not activate on single or double click (but in <meta+g>)"! !

!StPlaygroundPagePresenter methodsFor: 'private' stamp: ''!
preferredExtent: aSize

	(self window isMaximized 
		or: [ self window isMinimized ])
		ifTrue: [ ^ self ].
	self class preferredExtent: aSize! !

!StPlaygroundPagePresenter methodsFor: 'api' stamp: ''!
activateOnSingleClick
	"For compatibility, playground will not activate on single or double click (but in <meta+g>)"! !

!StPlaygroundPagePresenter methodsFor: 'initialization' stamp: ''!
initializeToolbar

	toolbar := self newToolbar
		displayMode: self application toolbarDisplayMode;
		addStyle: 'stToolbar';
		fillWith: self toolbarActions;
		yourself! !

!StPlaygroundPagePresenter methodsFor: 'actions' stamp: ''!
toggleShowLineNumbers

	self showLineNumbers: self showLineNumbers not! !

!StPlaygroundPagePresenter methodsFor: 'private - actions' stamp: ''!
showLineNumbers: aBoolean

	StPharoSettings codeShowLineNumbers: aBoolean.
	text lineNumbers: aBoolean.
	toggleLineNumberButton label: (StShowLineNumbersCommand iconLabelFor: self showLineNumbers)! !

!StPlaygroundPagePresenter methodsFor: 'transmission' stamp: ''!
outputActivationPort

	^ SpActivationPort newPresenter: self! !

!StPlaygroundPagePresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	super initializeWindow: aWindowPresenter.
	aWindowPresenter 
		title: self class defaultTitle;
		windowIcon: self windowIcon;
		whenOpenedDo: [ text takeKeyboardFocus ]! !

!StPlaygroundPagePresenter methodsFor: 'accessing' stamp: ''!
page

	^ page! !

!StPlaygroundPagePresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self initializeToolbar.
	self initializeStatusbar.

	(text := self newCode)
		interactionModel: StPlaygroundInteractionModel new;
		lineNumbers: self showLineNumbers;
		overridingContextMenu;
		contextMenu: [ (self menuActionsFor: text) asMenuPresenter ];
		contextKeyBindings: (self menuActionsFor: text) asKMCategory;
		whenTextChangedDo: [ :aString | page contents: aString ].
		
	text eventHandler 
		whenKeyUpDo: [ :event | self updateLineNumber ];
		whenMouseUpDo: [ :event | self updateLineNumber ];
		"before taking focus position will be nil, ensure I have the correct one"
		whenFocusReceivedDo: [ self updateLineNumber ].
		
	self updatePresenter! !

!StPlaygroundPagePresenter methodsFor: 'private' stamp: ''!
text

	^ text! !

!StPlaygroundPagePresenter class methodsFor: 'private commands' stamp: ''!
toolbarCommands

	^ (self baseToolbarCommands, self extendedToolbarCommands) sorted: #order ascending! !

!StPlaygroundPagePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		spacing: 3;
		add: #toolbar expand: false;
		add: #text;
		add: #statusbar expand: false;
		yourself! !

!StPlaygroundPagePresenter class methodsFor: 'instance creation' stamp: ''!
openContents: aString
	"Open a new workspace with the given contents. It looks better when aString is code since the style is applied"

	^ self new
		contents: aString;
		openWithSpec! !

!StPlaygroundPagePresenter class methodsFor: 'accessing' stamp: ''!
cacheDirectory
	
	^ CacheDirectory ifNil: [ self defaultCacheDirectory ]! !

!StPlaygroundPagePresenter class methodsFor: 'private' stamp: ''!
defaultCacheDirectory
	
	^ (FileLocator localDirectory / 'play-cache') ensureCreateDirectory! !

!StPlaygroundPagePresenter class methodsFor: 'private commands' stamp: ''!
baseToolbarCommands

	^ { 
		StPlaygroundDoItCommand.
		StPlaygroundPublishCommand.
		StPlaygroundBindingsCommand.				
		StPlaygroundVersionsCommand.
		StPlaygroundPagesCommand.
	}! !

!StPlaygroundPagePresenter class methodsFor: 'accessing' stamp: ''!
defaultTitle 

	^ 'Playground'! !

!StPlaygroundPagePresenter class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]" 

	registry register: self as: #workspace
! !

!StPlaygroundPagePresenter class methodsFor: 'instance creation' stamp: ''!
open 
	<script>
	
	^ (self on: StPlaygroundPage new) openWithSpec! !

!StPlaygroundPagePresenter class methodsFor: 'private commands' stamp: ''!
extendedToolbarCommands

	^ StPlaygroundToolbarExtensionCommand allCommands! !

!StPlaygroundPagePresenter class methodsFor: 'accessing' stamp: ''!
cacheDirectory: aDirectory
	
	self flag: #TODO. "This go to settings"
	CacheDirectory := aDirectory ensureCreateDirectory! !

!StPlaygroundPagePresenter class methodsFor: 'private commands' stamp: ''!
extendedMenuCommands

	^ StPlaygroundMenuExtensionCommand allCommands! !

!StPlaygroundPagePresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ StPlaygroundPagePresenter! !

!StPlaygroundPagePresenterTest methodsFor: 'running' stamp: ''!
tearDown

	classFactory ifNotNil: [ 
		classFactory cleanUp.
		classFactory := nil ].
	super tearDown! !

!StPlaygroundPagePresenterTest methodsFor: 'private' stamp: ''!
classFactory

	^ classFactory ifNil: [ classFactory := ClassFactoryForTestCase new ]! !

!StPlaygroundPagePresenterTest methodsFor: 'tests' stamp: ''!
testAddMenuCommandsTo
	| group commands class |

	class := self classFactory newSubclassOf: StPlaygroundMenuExtensionCommand.
	
	group := CmCommandGroup forSpec.
	presenter addMenuCommandsTo: group.
	commands := group allCommands collect: [ :each | each innerCommand class ] as: Array.	
	self assert: (commands includes: class).
! !

!StPlaygroundPagePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoEvaluateAllAndGo
	| value |
	
	self openInstance.
	
	presenter contents: '42 factorial'.
	presenter whenActivatedDo: [ :selection | value := selection value ].

	presenter doEvaluateAllAndGo.
	self 
		assert: value
		equals:  1405006117752879898543142606244511569936384000000000! !

!StPlaygroundPagePresenterTest methodsFor: 'initialization' stamp: ''!
initializeInstanceBeforeInitialization: aPresenter

	aPresenter setModelBeforeInitialization: self newPage! !

!StPlaygroundPagePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoEvaluateDeclareGlobal
	| value |
	
	self deny: (Smalltalk globals includesKey: #MyGlobalForTest).
	
	self openInstance.
	
	presenter contents: 'MyGlobalForTest'.
	presenter whenActivatedDo: [ :selection | value := selection value ].

	presenter text selectionInterval: (1 to: 16).
	[presenter doEvaluateAndGo] on: OCUndeclaredVariableWarning do: [ :warn | warn declareGlobal ].
	
	self assert: value equals:  nil.
	
	self assert: (Smalltalk globals includesKey: #MyGlobalForTest).
	Smalltalk globals removeKey: #MyGlobalForTest! !

!StPlaygroundPagePresenterTest methodsFor: 'tests' stamp: ''!
testAddToolbarCommandsTo
	| group commands class |

	class := self classFactory newSubclassOf: StPlaygroundToolbarExtensionCommand.
	
	group := CmCommandGroup forSpec.
	presenter addToolbarCommandsTo: group.
	commands := group allCommands collect: [ :each | each innerCommand class ] as: Array.	
	self assert: (commands includes: class).
! !

!StPlaygroundPagePresenterTest methodsFor: 'tests' stamp: ''!
testToolbarActions
	| group commands class |

	class := self classFactory newSubclassOf: StPlaygroundToolbarExtensionCommand.
	
	group := presenter toolbarActions.
	commands := group allCommands collect: [ :each | each innerCommand class ] as: Array.	
	self assert: (commands includes: class).
! !

!StPlaygroundPagePresenterTest methodsFor: 'tests - commands' stamp: ''!
testDoEvaluateAndGo
	| value |
	
	self openInstance.
	
	presenter contents: '42 factorial'.
	presenter whenActivatedDo: [ :selection | value := selection value ].

	presenter text selectionInterval: (1 to: 2).
	presenter doEvaluateAndGo.
	self 
		assert: value
		equals:  42.
			
	presenter text selectionInterval: (1 to: 12).
	presenter doEvaluateAndGo.
	self 
		assert: value
		equals:  1405006117752879898543142606244511569936384000000000! !

!StPlaygroundPageSummaryPresenter commentStamp: ''!
I am a presenter to show a summary of a page.
It will include the first line of the page and the creation date.
I am meant to be used in StPlaygroundPagesPresenter, as element of a list.!
!StPlaygroundPageSummaryPresenter methodsFor: 'initialization' stamp: ''!
pageFirstLine
		
	page readStreamDo: [ :stream | | line |
		[ stream atEnd not and: [ (line := stream nextLine trimmed) isEmpty ] ] whileTrue.
		line isEmptyOrNil ifFalse: [ ^ line ] ].

	^ 'Empty'! !

!StPlaygroundPageSummaryPresenter methodsFor: 'accessing' stamp: ''!
contents

	^ page contents! !

!StPlaygroundPageSummaryPresenter methodsFor: 'accessing' stamp: ''!
page

	^ page! !

!StPlaygroundPageSummaryPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aPage

	page := aPage! !

!StPlaygroundPageSummaryPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	layout := SpBoxLayout newTopToBottom
		borderWidth: 1;
		spacing: 2;
		add: (firstLineLabel := self newLabel) expand: false;
		add: (timeLabel := self newLabel) expand: false;
		yourself.

	firstLineLabel label: self pageFirstLine.
	timeLabel 
		addStyle: 'dim';
		label: page creationTime epiceaBrowsersAsString! !

!StPlaygroundPageSummaryPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ StPlaygroundPageSummaryPresenter! !

!StPlaygroundPageSummaryPresenterTest methodsFor: 'initialization' stamp: ''!
initializeInstanceBeforeInitialization: aPresenter

	aPresenter setModelBeforeInitialization: memoryFileSystem / 'test1.ph'! !

!StPlaygroundPageSummaryPresenterTest methodsFor: 'tests' stamp: ''!
testPageFirstLine
	
	self assert: presenter pageFirstLine equals: 'Empty'.	
	presenter setModelBeforeInitialization: memoryFileSystem / 'test2.ph'.
	self assert: presenter pageFirstLine equals: 'Test'! !

!StPlaygroundPageSummaryPresenterTest methodsFor: 'initialization' stamp: ''!
initializeMemoryFileSystem: aFileSystem

	aFileSystem / 'test1.ph' writeStreamDo: [ :stream | stream << '' ].
	aFileSystem / 'test2.ph' writeStreamDo: [ :stream | 
		stream << 'Test'; cr.
		stream << 'Test 2' ].! !

!StPlaygroundPageSummaryPresenterTest methodsFor: 'tests' stamp: ''!
testContents

	self assert: presenter contents equals: ''.
	presenter setModelBeforeInitialization: memoryFileSystem / 'test2.ph'.
	self assert: presenter contents equals: 'Test
Test 2'	! !

!StPlaygroundPageTest methodsFor: 'tests' stamp: ''!
testVersions
	| v1 v2 v3 page |
	
	v1 := 'v1'.
	v2 := 'v2'.
	v3 := 'v3'.
	
	page := StPlaygroundPage new.
	
	page basicContents: v1.
	page flush.
	
	page basicContents: v2.
	page flush.
	
	page basicContents: v3.
	page flush.
	
	self assert: page versions size equals: 3.
	self assert: page versions first content equals: v1.
	self assert: page versions second content equals: v2.	
	self assert: page versions third content equals: v3! !

!StPlaygroundPageTest methodsFor: 'tests' stamp: ''!
testStoreVersion
	| v1 page |
	
	v1 := 'v1'.
	page := self newPage.
	page basicContents: v1.
	page flush.
	self deny: page versions isEmpty.
	self assert: page versions first content equals: v1! !

!StPlaygroundPageTest methodsFor: 'tests' stamp: ''!
testFlush
	| page |
	
	page := self newPage.
	page basicContents: 'test'.

	self assert: page contents isEmpty.
	
	page flush.
	
	self assert: page contents equals: 'test'
		

	! !

!StPlaygroundPageTest methodsFor: 'tests' stamp: ''!
testDoNotStoreVersionIfEqual
	| v1 page |
	
	v1 := 'v1'.
	page := self newPage.
	page basicContents: v1.
	page flush.
	"Execute twice with same content"
	page storeVersion.
	
	self deny: page versions isEmpty.
	self assert: page versions size equals: 1! !

!StPlaygroundPageTest methodsFor: 'tests' stamp: ''!
testFromReference
	| memory file page |
	
	memory := FileSystem memory.
	file := memory / 'test.ph'.
	file writeStreamDo: [ :stream | stream << 'TEST'].
	
	page := StPlaygroundPage fromReference: file. 
	self assert: page fileReference equals: file.
! !

!StPlaygroundPageTest methodsFor: 'instance creation' stamp: ''!
newPage 

	^ StPlaygroundPage new 
		baseDirectory: FileSystem memory;
		timeToWait: 10 milliSeconds;
		yourself! !

!StPlaygroundPageTest methodsFor: 'tests' stamp: ''!
testContents

	| page waitMock |
	page := self newPage.
	waitMock := StPlaygroundPageTestMockedWaitable new.
	page timeToWait: waitMock.
	page contents: 'test'.
	self assert: page contents isEmpty.
	page contents: 'test 2'.
	self assert: page contents isEmpty.
	waitMock resume.
	self assert: page contents equals: 'test 2'! !

!StPlaygroundPageTestMockedWaitable commentStamp: ''!
A Mock class to deterministically perform tests instead on relying on the system clock and process scheduler's grace.
When wait is called on this object from a secondary thread (<=IMPORTANT), it will be blocked until the resume method is called or its timeout(default 500 ms) is reached.

This is essentially a Semaphore, with a built-in timeout and specific for these kind of tests.!
!StPlaygroundPageTestMockedWaitable methodsFor: 'accessing' stamp: ''!
wait

	| semRes |
	semRes := sem wait: (Duration milliSeconds: timeout).
	sem2 signal.
	^ semRes! !

!StPlaygroundPageTestMockedWaitable methodsFor: 'accessing' stamp: ''!
timeout: aNumberMiliseconds

	timeout := aNumberMiliseconds! !

!StPlaygroundPageTestMockedWaitable methodsFor: 'initialization' stamp: ''!
initialize

	sem := Semaphore new.
	sem2 := Semaphore new.
	timeout := 500! !

!StPlaygroundPageTestMockedWaitable methodsFor: 'accessing' stamp: ''!
resume

	sem signal.
	^ sem2 wait: (Duration milliSeconds: timeout)! !

!StPlaygroundPageVersionsPresenter commentStamp: ''!
A presenter to show all stored versions of a page. 
A version is taken each time we will flush a new version of the page to the disk, making changes in the playground recoverable..!
!StPlaygroundPageVersionsPresenter methodsFor: 'actions' stamp: ''!
adoptSelectedVersion

	self adoptVersion: versionList selectedItem! !

!StPlaygroundPageVersionsPresenter methodsFor: 'actions' stamp: ''!
adoptVersion: anEntry

	self parent contents: anEntry content.
	self window close.
	self parent takeKeyboardFocus! !

!StPlaygroundPageVersionsPresenter methodsFor: 'transmission' stamp: ''!
defaultInputPort

	^ self inputModelPort! !

!StPlaygroundPageVersionsPresenter methodsFor: 'actions' stamp: ''!
doAdoptVersion

	self adoptSelectedVersion! !

!StPlaygroundPageVersionsPresenter methodsFor: 'transmission' stamp: ''!
inputModelPort

	^ SpModelPort newPresenter: self! !

!StPlaygroundPageVersionsPresenter methodsFor: 'private' stamp: ''!
displayValueFor: aDateAndTime

	"^ ((DateAndTime now - aDateAndTime) truncateTo: 2 minutes) humanReadablePrintString"
	^ aDateAndTime epiceaBrowsersAsString! !

!StPlaygroundPageVersionsPresenter methodsFor: 'initialization' stamp: ''!
updatePresenter

	versionList items: self model page versions reversed! !

!StPlaygroundPageVersionsPresenter methodsFor: 'initialization' stamp: ''!
versionsActions

	^ CmCommandGroup forSpec
		beRoot;
		register: (StPlaygroundAdoptVersionCommand forSpecContext: self);
		register: (StPlaygroundAdoptVersionOnNewPlaygroundCommand forSpecContext: self);
		yourself! !

!StPlaygroundPageVersionsPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter

	aDialogWindowPresenter
		addButton: 'Adopt' do: [ :presenter | 
			presenter triggerOkAction.
			self adoptSelectedVersion ];
		addButton: 'Close' do: [ :presenter | 
			presenter triggerCancelAction.
			presenter close ]	! !

!StPlaygroundPageVersionsPresenter methodsFor: 'private' stamp: ''!
parent
	"a synonym to be clearer"

	^ self model! !

!StPlaygroundPageVersionsPresenter methodsFor: 'private' stamp: ''!
setModel: aModel

	self model: aModel! !

!StPlaygroundPageVersionsPresenter methodsFor: 'accessing - model' stamp: ''!
model: aModel

	model := aModel.
	self updatePresenter! !

!StPlaygroundPageVersionsPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	super initializeWindow: aWindowPresenter.
	aWindowPresenter 
		title: 'Versions';
		initialExtent: self class preferredExtent! !

!StPlaygroundPageVersionsPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aModel

	model := aModel! !

!StPlaygroundPageVersionsPresenter methodsFor: 'actions' stamp: ''!
doAdoptVersionOnNewPlayground
	| playground |
	
	(playground := StPlayground new) 
		contents: versionList selectedItem content;
		openWithSpec.
	self window close.
	playground takeKeyboardFocus! !

!StPlaygroundPageVersionsPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpPanedLayout newLeftToRight
		positionOfSlider: 40 percent;
		add: (versionList := self newList);
		add: (sourceCode := self newCode);
		yourself).
		
	versionList
		 display: [ :anEntry | self displayValueFor: (anEntry tagAt: #timestamp) ];
		 contextMenu: [ self versionsActions asMenuPresenter ].
	sourceCode 
		beForScripting;
		beNotEditable.
	
	versionList 
		transmitTo: sourceCode 
		transform: [ :anEntry | 
			anEntry 
				ifNotNil: [ anEntry content ]
				ifNil: [ 'no source' ] ]! !

!StPlaygroundPageVersionsPresenter methodsFor: 'accessing - model' stamp: ''!
model

	^ model! !

!StPlaygroundPageVersionsPresenter class methodsFor: 'accessing' stamp: ''!
preferredExtent

	^ 700@400! !

!StPlaygroundPagesCommand commentStamp: ''!
I open the page selector persenter and allow the user to chose a page to load.!
!StPlaygroundPagesCommand methodsFor: 'execution' stamp: ''!
execute 

	(StPlaygroundPagesPresenter 
		newApplication: context application
		model: context) 
		openDialogWithSpec! !

!StPlaygroundPagesCommand class methodsFor: 'accessing' stamp: ''!
defaultIconName

	^ #glamorousMore! !

!StPlaygroundPagesCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Load a saved page'! !

!StPlaygroundPagesCommand class methodsFor: 'accessing' stamp: ''!
order

	^ 30! !

!StPlaygroundPagesCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Pages'! !

!StPlaygroundPagesPresenter commentStamp: ''!
I am a presenter to show saved pages from a playground. 
A playground saves (or tries to save) everything you will put in a playground and it will store in the playground cache to make it available later (or even outside the image).

I show a list and a preview of a page content, to allow users to chose a page to load.!
!StPlaygroundPagesPresenter methodsFor: 'actions' stamp: ''!
loadPage: aPage

	self parent loadPage: aPage.
	self window close.
	self parent takeKeyboardFocus ! !

!StPlaygroundPagesPresenter methodsFor: 'accessing' stamp: ''!
pages
	
	^ (StPlayground cacheDirectory allChildrenMatching: '*.ph')
		sorted: [ :a :b | a creationTime > b creationTime ]! !

!StPlaygroundPagesPresenter methodsFor: 'private' stamp: ''!
pagesActions

	^ CmCommandGroup forSpec
		beRoot;
		register: (StPlaygroundLoadPageCommand forSpecContext: self);
		register: (StPlaygroundLoadPageOnNewPlaygroundCommand forSpecContext: self);
		yourself! !

!StPlaygroundPagesPresenter methodsFor: 'initialization' stamp: ''!
pagesAsPresenters

	^ self pages collect: [ :each | 
		self 
			instantiate: StPlaygroundPageSummaryPresenter
			on: each  ]! !

!StPlaygroundPagesPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter

	aDialogWindowPresenter 
		centeredRelativeToTopWindow;
		addButton: 'Load' do: [ :presenter |
			presenter triggerOkAction.
			self loadSelectedPage ];		
		addButton: 'Close' do: [ :presenter |
			presenter triggerCancelAction.
			presenter close ]! !

!StPlaygroundPagesPresenter methodsFor: 'private' stamp: ''!
parent

	^ parent! !

!StPlaygroundPagesPresenter methodsFor: 'accessing' stamp: ''!
selectedPage

	^ pageList selection selectedItem page! !

!StPlaygroundPagesPresenter methodsFor: 'actions' stamp: ''!
loadSelectedPage

	self loadPage: self selectedPage! !

!StPlaygroundPagesPresenter methodsFor: 'actions' stamp: ''!
doLoadPage
	
	self loadSelectedPage! !

!StPlaygroundPagesPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	super initializeWindow: aWindowPresenter.
	aWindowPresenter 
		title: self class defaultTitle;
		initialExtent: self class defaultExtent;
		whenOpenedDo: [ pageList takeKeyboardFocus ]! !

!StPlaygroundPagesPresenter methodsFor: 'actions' stamp: ''!
doLoadPageOnNewPlayground
	| playground |
	
	(playground := StPlayground new) 
		loadPage: self selectedPage;
		openWithSpec.
	self window close.
	playground takeKeyboardFocus 		! !

!StPlaygroundPagesPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aPlayground

	parent := aPlayground! !

!StPlaygroundPagesPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	(pageListPanel := self instantiate: StHeaderPanel)		
		number: 1;
		label: 'Pages';
		presenter: (pageList := self newComponentList
			presenters: self pagesAsPresenters;
			contextMenu: [ self pagesActions asMenuPresenter ];
			whenActivatedDo: [ self loadSelectedPage ];
			bindKeyCombination: Character cr asKeyCombination toAction: [ self loadSelectedPage ];
			yourself).
		
	(pagePreviewPanel := self instantiate: StHeaderPanel)
		number: 2;
		label: 'Preview';
		presenter: (pagePreview := self newPresenterSelector
			when: [ :aPage | aPage notNil ] show: [ :aPage | 
				self newCode 
					editable: false;
					text: aPage contents ];
			when: [ :aPage | aPage isNil ] show: [ 
				pageList items
					ifNotEmpty: [ self class unselectedMessage asPresenter ]
					ifEmpty: [ self class emptyMessage asPresenter ] ];
			yourself).
	
	pageList transmitTo: pagePreview.
	
	pageList items 
		ifNotEmpty: [ pageList selectIndex: 1 ]
		ifEmpty: [ pagePreview updatePresenter ]! !

!StPlaygroundPagesPresenter class methodsFor: 'accessing' stamp: ''!
emptyMessage

	^ 'There are no pages to list.'! !

!StPlaygroundPagesPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpPanedLayout newLeftToRight
		positionOfSlider: 30 percent;
		add: #pageListPanel;
		add: #pagePreviewPanel;
		yourself! !

!StPlaygroundPagesPresenter class methodsFor: 'accessing' stamp: ''!
unselectedMessage

	^ 'Select a page to preview it.'! !

!StPlaygroundPagesPresenter class methodsFor: 'accessing' stamp: ''!
pages

	! !

!StPlaygroundPagesPresenter class methodsFor: 'accessing' stamp: ''!
defaultTitle

	^ 'Pages'! !

!StPlaygroundPagesPresenter class methodsFor: 'accessing' stamp: ''!
defaultExtent

	^ 700@400! !

!StPlaygroundPagesPresenterTest methodsFor: 'accessing' stamp: ''!
classToTest

	^ StPlaygroundPagesPresenter! !

!StPlaygroundPagesPresenterTest methodsFor: 'tests' stamp: ''!
testLoadPage

	self deny: presenter window notNil.
	self openInstance.
	self assert: presenter window isOpen.
	presenter loadPage: (memoryFileSystem / 'test1.ph').
	self deny: presenter window isOpen .
	self 
		assert: presenter parent page contents
		equals: (memoryFileSystem / 'test1.ph') contents! !

!StPlaygroundPagesPresenterTest methodsFor: 'initialization' stamp: ''!
initializeInstanceBeforeInitialization: aPresenter

	aPresenter setModelBeforeInitialization: (StPlayground newApplication: application)! !

!StPlaygroundPagesPresenterTest methodsFor: 'initialization' stamp: ''!
initializeMemoryFileSystem: aFileSystem

	aFileSystem / 'test1.ph' writeStreamDo: [ :stream | stream << '42 factorial' ].
	aFileSystem / 'test2.ph' writeStreamDo: [ :stream | 
		stream << '"Test'; cr.
		stream << 'Test 2"' ].! !

!StPlaygroundPublishCommand commentStamp: ''!
Publish the content of a page in [http://ws.stfx.eu](http://ws.stfx.eu)!
!StPlaygroundPublishCommand methodsFor: 'execution' stamp: ''!
execute 
	| contents publishedUrl |

	(self application confirm: 'Publish playground content to the cloud?') 
		ifFalse: [ ^ self ].
	
	contents := self page contents.
	contents ifEmpty: [ 
        self application inform: 'Nothing was published because the playground is empty'.
        ^ self ].

    Clipboard clipboardText: (publishedUrl := (self post: contents) asString).
    self inform: publishedUrl , ' was published and the url was copied to clipboard'! !

!StPlaygroundPublishCommand methodsFor: 'accessing' stamp: ''!
page

	^ context page! !

!StPlaygroundPublishCommand methodsFor: 'public' stamp: ''!
post: aString
	| response url |

	response := ZnClient new
		systemPolicy;
		beOneShot;
		accept: ZnMimeType textPlain;
		url: self class urlProvider;
		entity: (ZnEntity text: aString);
		post;
		response.
		
	url := response location.
	^ url asZnUrl inContextOf: self class urlProvider! !

!StPlaygroundPublishCommand class methodsFor: 'accessing' stamp: ''!
urlProvider

	^ 'http://ws.stfx.eu' asZnUrl! !

!StPlaygroundPublishCommand class methodsFor: 'accessing' stamp: ''!
defaultIconName

	^ #glamorousSaveToUrl! !

!StPlaygroundPublishCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^  'Publish contents to the cloud.'! !

!StPlaygroundPublishCommand class methodsFor: 'accessing' stamp: ''!
order

	^ 5! !

!StPlaygroundPublishCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Publish'! !

!StPlaygroundTest methodsFor: 'running' stamp: ''!
classToTest

	^ StPlayground! !

!StPlaygroundTest methodsFor: 'tests' stamp: ''!
testLoadPage
	| page |

	presenter openWithSpec.
	self waitUntilUIRedrawed.
	presenter contents: 'Test 1'.
	presenter page flush.

	page := self newPage
		contents: 'Test 2';
		flush;
		yourself.
	presenter loadPage: page fileReference.
	self waitUntilUIRedrawed.
	self 
		assert: presenter page contents 
		equals: page contents! !

!StPlaygroundTest methodsFor: 'running' stamp: ''!
initializeInstanceBeforeInitialization: aPresenter

	aPresenter setModelBeforeInitialization: self newPage! !

!StPlaygroundTest methodsFor: 'tests' stamp: ''!
testStopProcessing
	| page |

	presenter openWithSpec.
	self waitUntilUIRedrawed.
	page := self newPage
		contents: 'Test 1';
		flush;
		yourself.
	presenter loadPage: page fileReference.
	self waitUntilUIRedrawed.
	"a lot of time"
	presenter page timeToWait: 1 minute.
	presenter contents: 'Test 2'.
	"no time to flush"
	self assert: page contents equals: 'Test 1'.
	"now we can close and test."
	presenter window close.
	self assert: page contents equals: 'Test 2'.
	! !

!StPlaygroundTest methodsFor: 'instance creation' stamp: ''!
newPlayground

	^ StPlayground 
		newApplication: application
		model: self newPage
		! !

!StPlaygroundTest methodsFor: 'tests' stamp: ''!
testNewInspectorForWorksWhenModelIsNil
	| inspectorPanel |

	inspectorPanel := presenter newInspectorFor: nil.
	self assert: inspectorPanel notNil.
	self assert: (inspectorPanel isKindOf: StObjectInspectorPresenter)! !

!StPlaygroundTest methodsFor: 'tests' stamp: ''!
testContents

	presenter openWithSpec.
	self waitUntilUIRedrawed.
	presenter contents: 'Test'.
	presenter page flush.
	self 
		assert: presenter model contents 
		equals: 'Test'.
		
	! !

!StPlaygroundToolbarExtensionCommand commentStamp: ''!
Extension point to add functionality to the playground. 

Commands inheriting `StPlaygroundToolbarExtensionCommand` will be added to the toolbar.!
!StPlaygroundToolbarExtensionCommand class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self == StPlaygroundToolbarExtensionCommand ]! !

!StPlaygroundToolbarExtensionCommand class methodsFor: 'accessing' stamp: ''!
allCommands

	^ self allSubclasses reject: [ :each | each isAbstract ]! !

!StPlaygroundVersionsCommand commentStamp: ''!
Open the page versions browsers.!
!StPlaygroundVersionsCommand methodsFor: 'execution' stamp: ''!
execute 

	(StPlaygroundPageVersionsPresenter 
		newApplication: context application
		model: context) 
		openDialogWithSpec! !

!StPlaygroundVersionsCommand class methodsFor: 'accessing' stamp: ''!
defaultIconName

	^ #history! !

!StPlaygroundVersionsCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Browse page versions'! !

!StPlaygroundVersionsCommand class methodsFor: 'accessing' stamp: ''!
order

	^ 20! !

!StPlaygroundVersionsCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Versions'! !

!StPresenter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter
	"All tools should call its parent"

	self traversePresentersDo: [ :each |
		each addWindowShortcutsTo: aWindowPresenter ]! !

!StPresenter methodsFor: 'private' stamp: ''!
shortcutForPanel: aNumber
	"This is a convenience method to assign shortcuts to panels. 
	 panels will be different areas of a tool: a package panel in a browser, an inspector in 
	 the debugger."
	| char |
	
	char := aNumber asString first.
	^ char command mac 
		| char control win 
		| char control unix! !

!StPresenter methodsFor: 'initialization' stamp: ''!
preferredExtent

	^ self class preferredExtent! !

!StPresenter class methodsFor: 'instance creation' stamp: ''!
new

	^ self newApplication: self currentApplication! !

!StPresenter class methodsFor: 'private' stamp: ''!
currentApplication

	^ SpToolCurrentApplication value ifNil: [ StPharoApplication current ]! !

!StPresenter class methodsFor: 'instance creation' stamp: ''!
owner: anOwningPresenter on: aDomainObject

	^ self 
		newApplication: self currentApplication
		owner: anOwningPresenter
		model: aDomainObject! !

!StPresenter class methodsFor: 'accessing' stamp: ''!
preferredExtent

	^ 600@400! !

!StPresenter class methodsFor: 'instance creation' stamp: ''!
owner: anOwningPresenter

	^ self 
		newApplication: self currentApplication
		owner: anOwningPresenter! !

!StPresenterInspection commentStamp: ''!
An inspection container to hold any kind of presenter and show them as inspections.
Called in `SpPresenter>>#asInspection`, a presenter inspection is used to build an inspector, when collecting the inspections defined for the instance.!
!StPresenterInspection methodsFor: 'testing' stamp: ''!
hasOutputActivationPort

	^ self presenter respondsTo: #outputActivationPort
	! !

!StPresenterInspection methodsFor: 'accessing' stamp: ''!
activateOnDoubleClick

	self presenter activateOnDoubleClick! !

!StPresenterInspection methodsFor: 'accessing' stamp: ''!
presenter: aPresenter

	aPresenter owner: self.
	presenter := aPresenter! !

!StPresenterInspection methodsFor: 'accessing' stamp: ''!
activateOnSingleClick

	self presenter activateOnSingleClick! !

!StPresenterInspection methodsFor: 'accessing' stamp: ''!
presenter
	^ presenter! !

!StPresenterInspection methodsFor: 'ports' stamp: ''!
defaultOutputPort
	
	^ self presenter defaultOutputPort! !

!StPresenterInspection methodsFor: 'ports' stamp: ''!
outputActivationPort

	^ self presenter outputActivationPort! !

!StPresenterInspection class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: #presenter;
		yourself! !

!StPresenterInspection class methodsFor: 'instance creation' stamp: ''!
for: aPresenter

	^ self new
		presenter: aPresenter;
		yourself! !

!StProceedCommand commentStamp: ''!
Request the debugger to proceed the debug session!
!StProceedCommand methodsFor: 'hooks' stamp: ''!
execute
	self debugger proceedDebugSession! !

!StProceedCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ PharoShortcuts current resumeExecutionShortcut! !

!StProceedCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName
	^ #debuggerProceed! !

!StProceedCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Relinquish debugger control and proceed execution from the current point of debugger control.'! !

!StProceedCommand class methodsFor: 'default' stamp: ''!
defaultName
	<toolbarDebugCommand: 10>
	^ 'Proceed'! !

!StQuery commentStamp: ''!
I am the reification of a Spotter query.
I know how to parse the search string and returns the categories selected (#Classes, #Implementors, etc) and the look up string.
I also handle how to return the results to spotter and how to update the searching morph when a category change.

I am updated from a Spotter context (updateFromContext:), and I update the search bar with #updateSearchingMorph.

The processors talk with me to add results to the query, and later show them (#addResult: #informAllResultAmount:).

I am also configurable to filter classes, implementors or add another modified.!
!StQuery methodsFor: 'accessing' stamp: ''!
searchingText
	
	^ query! !

!StQuery methodsFor: 'accessing' stamp: ''!
textInSearchBar

	^ String streamContents: [ :stream | 
		modifiers do: [ :each | stream print:each; space ].
		stream nextPutAll: query ]! !

!StQuery methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	modifiers := OrderedCollection new.
	query:= ''.! !

!StQuery methodsFor: 'results' stamp: ''!
informAllResultAmount: anInteger 

	spotterContext stream
		performSymbol: #onAmountChanged:in:
		withArguments: { anInteger. processor }.
	! !

!StQuery methodsFor: 'accessing' stamp: ''!
processor

	^ processor! !

!StQuery methodsFor: 'testing' stamp: ''!
isSearchEmpty

	^ query isEmpty! !

!StQuery methodsFor: 'accessing' stamp: ''!
categoriesSelected

	^ modifiers copy! !

!StQuery methodsFor: 'updating' stamp: ''!
updateFromContext: aSpotterContext
	| textParts texts |

	modifiers removeAll.
	texts := (aSpotterContext search ifNil:[ '' ]) trimBoth.
	textParts := texts substrings: { Character space. Character tab }.
	query := ''.
	
	textParts do: [ :aPart | 
		((aPart beginsWith: '#') 
			and: [ ((texts copyWithout: Character space) includesSubstring: '>>#') not ])
			ifTrue: [ modifiers add: aPart allButFirst asSymbol ]
			ifFalse: [ query := (query, ' ', aPart) trimBoth ] ].

	spotterContext := aSpotterContext! !

!StQuery methodsFor: 'results' stamp: ''!
addResult: anEntry

	spotterContext stream
		performSymbol: #addCandidate:in:
		withArguments: { anEntry. processor }! !

!StQuery methodsFor: 'testing' stamp: ''!
hasCategoryMatching: aSymbol

	^ self categoriesSelected anySatisfy: [ :each | each asLowercase beginsWith: aSymbol ]! !

!StQuery methodsFor: 'testing' stamp: ''!
hasAnyCategory

	^ self categoriesSelected notEmpty! !

!StQuery methodsFor: 'accessing' stamp: ''!
processor: aProcessor

	processor := aProcessor! !

!StQuery methodsFor: 'configuring' stamp: ''!
toggleFilter: filterTag

	(modifiers includes: filterTag) 
		ifTrue: [ modifiers remove: filterTag ]
		ifFalse: [ modifiers add: filterTag ]! !

!StRawInspection commentStamp: ''!
A raw inspection is the basic inspection over any object of the system. 
It will show the variables the object is composed of and it will allow dive into and editing of them.!
!StRawInspection methodsFor: 'building' stamp: ''!
variablesColumn

	^ SpCompositeTableColumn new
		title: 'Variable';
		width: 170;
		addColumn: (SpImageTableColumn new
			beNotExpandable;
			evaluated: #icon;
			yourself);
		addColumn: (SpStringTableColumn new
			evaluated: #label;
			yourself);
		sortFunction: #label ascending;
		yourself! !

!StRawInspection methodsFor: 'stepping' stamp: ''!
step
	| rootNodes |

	rootNodes := self model allInspectorNodes.
	mementoNodes ifNil: [ 
		mementoNodes := rootNodes collect: #mementoValue.
		^ self ].
	(rootNodes collect: #value) = mementoNodes ifTrue: [ ^ self ].

	mementoNodes := rootNodes collect: #mementoValue.
	attributeTable updateRootsKeepingSelection: rootNodes! !

!StRawInspection methodsFor: '*NewTools-Debugger' stamp: ''!
beForDebugger

	attributeTable := (self instantiate: StDebuggerTreeTablePresenter)
		beResizable;
		contextMenu: [ self rootCommandsGroup asMenuPresenter ];
		yourself.
		
	StInspector inspectorDiveOnSingleClick
		ifTrue: [ attributeTable activateOnSingleClick ].
	
	self addVariableTagColumn.
	self addVariablesColumn.
	self addValuesColumn.	

	attributeTable
		roots: self inspectorNodes;
		children: [ :node | #() ]! !

!StRawInspection methodsFor: 'testing' stamp: ''!
hasOutputActivationPort

	^ true! !

!StRawInspection methodsFor: '*NewTools-Debugger' stamp: ''!
variableTagColumn

	^  SpLinkTableColumn new 
		title: 'Type';
		width: 70;
		evaluated: [ :aNode | aNode variableTag ];
		action: [ :aNode |  attributeTable toggleFilter: aNode variableTag. owner updateHeaderBar. ];
		sortFunction: #variableTag ascending;
		yourself! !

!StRawInspection methodsFor: 'accessing' stamp: ''!
selectPath: aPath

	attributeTable selectPath: aPath! !

!StRawInspection methodsFor: 'building' stamp: ''!
addVariablesColumn

	attributeTable addColumn: self variablesColumn! !

!StRawInspection methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
haltInspectedObjectOnReadAccess
	^self haltInspectedObjectOnAccess: #read! !

!StRawInspection methodsFor: 'building' stamp: ''!
addValuesColumn

	attributeTable addColumn: self valuesColumn! !

!StRawInspection methodsFor: 'building' stamp: ''!
valuesColumn

	^ SpStringTableColumn new
		title: 'Value';
		evaluated: #stringValue;
		"beEditable;"
		onAcceptEdition: [ :node :value | 
			self inform: node label , '=' , value asString	"node value: value" ];
		sortFunction: #stringValue ascending;
		yourself! !

!StRawInspection methodsFor: 'ports' stamp: ''!
defaultOutputPort

	^ self outputSelectionPort! !

!StRawInspection methodsFor: '*NewTools-Debugger' stamp: ''!
selectedPageName

	^'Context'! !

!StRawInspection methodsFor: 'accessing' stamp: ''!
selectedPath

	^ attributeTable selection selectedPath! !

!StRawInspection methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
haltInspectedObjectOnWriteAccess
	^ self haltInspectedObjectOnAccess: #write! !

!StRawInspection methodsFor: 'accessing' stamp: ''!
selectFirst

	self selectPath: #(1)! !

!StRawInspection methodsFor: '*NewTools-Debugger' stamp: ''!
attributeTable

	^attributeTable! !

!StRawInspection methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
haltInspectedObjectOnAccess: access
	| selectedItem |
	selectedItem := self selectedItem.
	selectedItem ifNil:[
		"No selection: halt on all accesses"
		^ self model haltOnAccess: access ].
	selectedItem key asSymbol == #self 
		ifTrue:[
			"Self is selected: halt on all accesses"
			^ self model haltOnAccess: access].
	^ self model haltOnAccess: access to: selectedItem key! !

!StRawInspection methodsFor: 'accessing' stamp: ''!
selectedItem

	^ attributeTable selectedItem! !

!StRawInspection methodsFor: 'accessing' stamp: ''!
selectedObject

	^ attributeTable selectedItem value! !

!StRawInspection methodsFor: 'building' stamp: ''!
setAttributeTable

	attributeTable
		roots: self inspectorNodes;
		children: [ :node | node children ]! !

!StRawInspection methodsFor: 'api' stamp: ''!
activateOnDoubleClick

	attributeTable activateOnDoubleClick! !

!StRawInspection methodsFor: '*NewTools-Debugger' stamp: ''!
activePresenter
	^self! !

!StRawInspection methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
haltInspectedObjectOnStateAccess
	^ self haltInspectedObjectOnAccess: #all! !

!StRawInspection methodsFor: 'api' stamp: ''!
activateOnSingleClick

	attributeTable activateOnSingleClick! !

!StRawInspection methodsFor: 'ports' stamp: ''!
outputActivationPort
	
	^ (SpActivationPort newPresenter: self) 
		delegateTo: [ attributeTable ];
		yourself! !

!StRawInspection methodsFor: 'ports' stamp: ''!
outputSelectionPort
	
	^ (SpSelectionPort newPresenter: self)
		delegateTo: [ attributeTable ];
		yourself! !

!StRawInspection methodsFor: 'accessing - model' stamp: ''!
model: aModel

	super model: aModel.
	self setAttributeTable! !

!StRawInspection methodsFor: 'accessing' stamp: ''!
inspectorNodes

	^ self model allInspectorNodes! !

!StRawInspection methodsFor: 'initialization' stamp: ''!
initializePresenters

	attributeTable := self newTreeTable
		beResizable;
		contextMenu: [ self rootCommandsGroup asMenuPresenter ];
		yourself.
	self addVariablesColumn.
	self addValuesColumn.
	self setAttributeTable! !

!StRawInspection methodsFor: '*NewTools-Debugger' stamp: ''!
addVariableTagColumn

	attributeTable addColumn: self variableTagColumn! !

!StRawInspection class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom 
		add: #attributeTable;
		yourself! !

!StRawInspection class methodsFor: '*NewTools-ObjectCentricBreakpoints' stamp: ''!
objectCentricBreakpointCommandsWith: presenter forRootGroup: aRootCmCommandsGroup
	<extensionCommands>
	({StHaltOnReadCommand forSpec.
	StHaltOnWriteCommand forSpec.
	StHaltOnStateAccessCommand forSpec}
		select: [ :spCommand | spCommand decoratedCommand appliesTo: presenter ])
		do: [ :spCommand | aRootCmCommandsGroup register: spCommand ]! !

!StRawInspection class methodsFor: 'accessing' stamp: ''!
label

	^ 'Raw'! !

!StRawInspection class methodsFor: 'commands' stamp: ''!
buildCommandsGroupWith: presenter forRoot: aCmCommandsGroup
	aCmCommandsGroup
		beDisplayedAsGroup;
		register: (StInspectorInspectSelectedCommand forSpecContext: presenter);
		register: (StInspectorBrowseSelectedCommand forSpecContext: presenter);
		register:
			(SpBrowsePointersToCommand
				forSpecContext: [ presenter selectedItem value ])! !

!StRemoveBindingCommand commentStamp: ''!
Remove a binding.!
!StRemoveBindingCommand methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self
		name: 'Remove binding';
		description: 'Remove current binding.'! !

!StRemoveBindingCommand methodsFor: 'converting' stamp: ''!
asSpecCommand 
	
	^ super asSpecCommand 
		iconProvider: self application;
		iconName: #smallDelete;
		shortcutKey: $x control unix | $x control win | $x command mac;
		yourself! !

!StRemoveBindingCommand methodsFor: 'accessing' stamp: ''!
application

	^ StPharoApplication current! !

!StRemoveBindingCommand methodsFor: 'executing' stamp: ''!
execute
	
	context removeSelectedBinding! !

!StRemoveBreakpointCommand commentStamp: ''!
Removes a breakpoint from a selected breakpoint item in a StObjectBreakpointInspection. !
!StRemoveBreakpointCommand methodsFor: 'executing' stamp: ''!
execute

	(self transform value: self context) removeInPresenterContext:
		self context! !

!StRemoveBreakpointCommand class methodsFor: 'default' stamp: ''!
defaultName
	^'Remove'! !

!StReporter commentStamp: ''!
I'm an abstract class. 
Better use my subclasses: 

```
StSystemReporter new openWithSpec
```

or 

```
StSizeReporter new openWithSpec
```

!
!StReporter methodsFor: 'building report' stamp: ''!
createTextForReport: items

	^ (Text streamContents: [:stream | 
						items do: [:each |
								self perform: each value with: stream.
								stream cr]])! !

!StReporter methodsFor: 'initialization' stamp: ''!
initialize
	topics := OrderedCollection new.
	self fillTopics.
	super initialize.
	! !

!StReporter methodsFor: 'utils' stamp: ''!
header: aString on: aStream
	aStream
		withAttribute: TextEmphasis bold
		do: [ aStream
				nextPutAll: aString;
				cr.
			aString size timesRepeat: [ aStream nextPut: $- ].
			aStream cr ]! !

!StReporter methodsFor: 'initialization' stamp: ''!
topicSpec

	^ topics! !

!StReporter methodsFor: 'adding' stamp: ''!
addTopicSpec: aPair

	topics add: aPair! !

!StReporter methodsFor: 'initialization' stamp: ''!
fillTopics

	^ self! !

!StReporter methodsFor: 'utils' stamp: ''!
enumerate: aBlock startAt: first on: aStream
	"Utility method to enumerate Options or Parameters from first to 1000"

	| idx value |
	idx := first.
	[ 
	value := aBlock value: idx.
	value isNil or: [ idx > 1000 ] ]
		whileFalse: [ 
			aStream
				nextPut: $#;
				nextPutAll: idx printString;
				tab;
				nextPutAll: value;
				cr.
			idx := idx + 1 ].
	idx = first
		ifTrue: [ 
			aStream
				nextPutAll: 'none';
				cr ]! !

!StReporter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	aWindowPresenter title: self title.
	aWindowPresenter initialExtent: self extent! !

!StReporter methodsFor: 'utils' stamp: ''!
enumerate: aBlock on: aStream

	self 
		enumerate: aBlock 
		startAt: 0 
		on: aStream! !

!StReporter methodsFor: 'initialization' stamp: ''!
initializePresenters 

	topicList := self newList.
	topicList beMultipleSelection.
	topicList display: [ :each | each key ].
	reportText := self newText beNotEditable.! !

!StReporter methodsFor: 'initialization' stamp: ''!
connectPresenters  
	
	topicList whenSelectionChangedDo: [ :selection | 
			selection selectedItems
				ifNotNil: [ :items |
								reportText text: (self createTextForReport: items)]].
						
	topicList items: topics! !

!StReporter class methodsFor: 'specs' stamp: ''!
defaultSpec
	"self new openWithSpec"
	^ (SpBoxLayout newLeftToRight 
			add: #topicList withConstraints: [ :constraints | constraints width: 140 ];
			add: #reportText;
			yourself)! !

!StReporter class methodsFor: 'specs' stamp: ''!
open 
	<script>
	self new openWithSpec! !

!StRestartCommand commentStamp: ''!
Request the debugger to restart its current context!
!StRestartCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ aDebugger canExecuteRestartCommand! !

!StRestartCommand methodsFor: 'hooks' stamp: ''!
execute
	self debugger restartCurrentContext! !

!StRestartCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ PharoShortcuts current restartExecutionShortcut! !

!StRestartCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ #debuggerRestart! !

!StRestartCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Go back the start of the current execution context, resetting all local variables and take debugger control.'! !

!StRestartCommand class methodsFor: 'default' stamp: ''!
defaultName
	<toolbarDebugCommand: 900>

	^ 'Restart'! !

!StReturnValueCommand commentStamp: ''!
Requests the debugger to return from the current context with the result of the evaluation of a user-defined expression.!
!StReturnValueCommand methodsFor: 'accessing' stamp: ''!
appliesTo: aDebugger
	"I can always return from a context, for ex. if I'm stuck because of a DNU.
	Except from dead contexts"
	^ aDebugger canExecuteReturnCommand! !

!StReturnValueCommand methodsFor: 'actions' stamp: ''!
execute
	self debugger returnEnteredValue! !

!StReturnValueCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ nil! !

!StReturnValueCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ #debuggerReturn! !

!StReturnValueCommand class methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Return entered value'! !

!StReturnValueCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription
	^ 'Return of a given value to the previous context.'! !

!StReturnValueCommand class methodsFor: 'accessing' stamp: ''!
defaultName
	<toolbarDebugCommand: 910>
	^ 'Return'! !

!StRunToSelectionCommand commentStamp: ''!
Request the debugger to run the execution up to the cursor selection!
!StRunToSelectionCommand methodsFor: 'hooks' stamp: ''!
execute
	self debugger runToSelection! !

!StRunToSelectionCommand class methodsFor: 'default' stamp: ''!
defaultShortcut
	^ nil! !

!StRunToSelectionCommand class methodsFor: 'default' stamp: ''!
defaultIconName

	^ #debuggerRunToSelection! !

!StRunToSelectionCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Execute methods up to the text cursor position and return debugger control.'! !

!StRunToSelectionCommand class methodsFor: 'default' stamp: ''!
defaultName
	<toolbarDebugCommand: 50>
	^ 'Run to'! !

!StSelector commentStamp: ''!
A wrapper for selectors to be used in spotter (so they are something more than just symbols). !
!StSelector methodsFor: 'private' stamp: ''!
senders
	^ SystemNavigation default allSendersOf: self name! !

!StSelector methodsFor: 'private' stamp: ''!
implementors
	^ methods ifNil: [ 
		methods := (SystemNavigation default allImplementorsOf: self name) 
			collect: [ :each | each compiledMethod ] ]! !

!StSelector methodsFor: 'spotter' stamp: ''!
spotterUsersFor: aStep
	<stSpotterOrder: 50>

	^ aStep listProcessor
		title: 'Senders';
		filter: StFilterSubstring item: [ :filter :context | 
			self senders do: [ :sender | 
				filter value: sender compiledMethod ] ];
		keyBinding: $n meta! !

!StSelector methodsFor: 'displaying' stamp: ''!
displayStringOn: stream

	stream nextPutAll: self name! !

!StSelector methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!StSelector methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!StSelector methodsFor: 'adding' stamp: ''!
addMethod: aCompiledMethod
	"this is a private method that can be used by the constructor on the class side
	exclusively within the context of Spotter"
	methods ifNil: [ methods := OrderedCollection new ].
	methods add: aCompiledMethod! !

!StSendersIterator commentStamp: ''!
I am an iterator to find the senders of a message.
I always receive a filteringText because it does not have any sense to show senders of an empty string.
Also, I lookup all the senders of the complete symbol.!
!StSendersIterator methodsFor: 'enumerating' stamp: ''!
elementsDo: aValuable

	selector ifNil: [ ^ self ].
	^ selector senders do: [ :aMethod | aValuable value: (StMethodEntry on: aMethod )]! !

!StSendersIterator methodsFor: 'filtering' stamp: ''!
filteringText: aString

	selector := aString ifEmpty: [ nil] ifNotEmpty: [aString asSymbol].
	self reset.! !

!StSendersProcessor commentStamp: ''!
I implement the lookup of #Senders and the Meta + n binding.
!
!StSendersProcessor methodsFor: 'key-bindings' stamp: ''!
sendersTag
		
	^ #Senders! !

!StSendersProcessor methodsFor: 'testing' stamp: ''!
askingForSenders

	^ query hasCategoryMatching: #s! !

!StSendersProcessor methodsFor: 'key-bindings' stamp: ''!
installKeymappingsOn: aPresenter onExecution: aBlock

	aPresenter
		bindKeyCombination: self keyBinding
		toAction: [ 
			self query toggleFilter: self sendersTag.
			aBlock cull: self ]! !

!StSendersProcessor methodsFor: 'spotter-api' stamp: ''!
isRelevantForQuery: aString 
	
	^ true! !

!StSendersProcessor methodsFor: 'filtering' stamp: ''!
executeQuery

	self askingForSenders ifFalse: [ ^ self ].
	^ super executeQuery ! !

!StSendersProcessor methodsFor: 'filtering' stamp: ''!
newTextFilteringSource

	^ StSendersIterator new ! !

!StSendersProcessor methodsFor: 'key-bindings' stamp: ''!
keyBinding

	^ $n meta! !

!StSendersProcessor methodsFor: 'testing' stamp: ''!
categoriesIncludes: aCategory

	^ aCategory asLowercase beginsWith: #s! !

!StSendersProcessor class methodsFor: 'accessing' stamp: ''!
order
	
	^ 150! !

!StSendersProcessor class methodsFor: 'default-settings' stamp: ''!
defaultEnabled

	^ true! !

!StSendersProcessor class methodsFor: 'accessing' stamp: ''!
title
	
	^ 'Senders'! !

!StSequenceIterator commentStamp: ''!
I am sequence iterator, I will take all the iterators I have in myself and then I will go over the elements of them.
I iterate first all elements from the first one, and then the elements of the second one, and so on.!
!StSequenceIterator methodsFor: 'accessing' stamp: ''!
iterators: aCollection 

	iterators := aCollection ! !

!StSequenceIterator methodsFor: 'accessing' stamp: ''!
next

	iterators do: [ :e | e next ifNotNil: [ :aValue | ^ aValue ] ].
	^ nil! !

!StSequenceIterator methodsFor: 'protected' stamp: ''!
doReset

	^ iterators do: [ :e | e reset ]! !

!StSequenceIterator methodsFor: 'testing' stamp: ''!
atEnd 

	^ iterators allSatisfy: [ :e | e atEnd ]! !

!StSequenceIterator class methodsFor: 'instance creation' stamp: ''!
with: aCollection 
	
	^ self new
		iterators: aCollection;
		yourself! !

!StShowFullStackCommand commentStamp: ''!
Request the debugger to show all the stack in its stack pane!
!StShowFullStackCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ true! !

!StShowFullStackCommand methodsFor: 'hooks' stamp: ''!
execute
	self debugger showFullStack! !

!StShowFullStackCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ nil! !

!StShowFullStackCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName
	^ #glamorousMore! !

!StShowFullStackCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Shows the full stack.'! !

!StShowFullStackCommand class methodsFor: 'default' stamp: ''!
defaultName
	<toolbarDebugCommand: 999>
	^ 'Stack'! !

!StShowLineNumbersCommand commentStamp: ''!
!! StShowLineNumbersCommand
Toggles the show line number state (to hide or show line numbers column).

[[[language=Smalltalk
(StShowLineNumbersCommand forSpecContext: (StPlayground new)) execute
]]]!
!StShowLineNumbersCommand methodsFor: 'executing' stamp: ''!
execute

	context toggleShowLineNumbers! !

!StShowLineNumbersCommand methodsFor: 'accessing' stamp: ''!
name

	^ context showLineNumbers
		ifTrue: [ self class hideLineNumbersLabel ]
		ifFalse: [ self class showLineNumbersLabel ]! !

!StShowLineNumbersCommand class methodsFor: 'private' stamp: ''!
showLineNumbersLabel

	^ 'Show line numbers'! !

!StShowLineNumbersCommand class methodsFor: 'private' stamp: ''!
hideLineNumbersLabel

	^ 'Hide line numbers'! !

!StShowLineNumbersCommand class methodsFor: 'default' stamp: ''!
iconLabelFor: aBoolean
	
	^ aBoolean 
		ifTrue: [ '+L' ]
		ifFalse: [ 'L' ]! !

!StShowLineNumbersCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Show/hide line numbers'! !

!StShowLineNumbersCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Show line numbers'! !

!StSindarinBytecodeContextInspectorModel methodsFor: '*NewTools-Sindarin-Tools' stamp: ''!
contextReceiverSlotNodes
	^ self inspectedObject receiver class allSlots
		collect: [ :each | 
			StBytecodeInspectorSlotNode
				hostObject: self inspectedObject receiver
				slot: each ]! !

!StSindarinBytecodeContextInspectorModel methodsFor: 'accessing' stamp: ''!
allInspectorNodes
	| tempNodes slotNodes stackTopNode |
	tempNodes := self contextTempNodes.
	slotNodes := self contextReceiverSlotNodes.
	stackTopNode := self stacktopNode.
	^ OrderedCollection new
		add: stackTopNode;
		addAll: tempNodes;
		addAll: slotNodes;
		yourself! !

!StSindarinBytecodeContextInspectorModel methodsFor: 'accessing' stamp: ''!
stacktopNode
	^ StInspectorStackTopNode hostObject: self inspectedObject! !

!StSindarinBytecodeContextInspectorModel methodsFor: '*NewTools-Sindarin-Tools' stamp: ''!
contextTempNodes
	^ self inspectedObject astScope allTemps collect: [ :temp | 
		  (StInspectorTempNode hostObject: self inspectedObject) tempVariable: temp ]
! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'initialization' stamp: ''!
toolbarActions
	| group |
	group := (CmCommandGroup named: 'Bytecode Toolbar') asSpecGroup.
	
	group register: (SindarinStepBytecodeCommand forSpecContext: self).

	
	^ group! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'accessing' stamp: ''!
debugger 
	^stDebugger! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'updating' stamp: ''!
updateBytecode

	| selectionIndex |
	bytecodeList := self sindarin currentBytecode.
	currentPC := self sindarin pc.
	bytecode
		items: bytecodeList;
		displayIcon: [ :elem | 
			elem offset = currentPC
				ifTrue: [ Smalltalk iconNamed: #glamorousRight ]
				ifFalse: [ Smalltalk iconNamed: #blank ] ].
	bcContextInspection model:
		(StSindarinBytecodeContextInspectorModel on: self sindarin context).
	selectionIndex := currentPC - bytecodeList first offset + 1.
	selectionIndex <= bytecodeList size ifTrue: [ 
		bytecode selectIndex: selectionIndex ]! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'accessing' stamp: ''!
sindarin
	^sindarinDebugger ! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'updating' stamp: ''!
updatePresenter
	super updatePresenter.
	self debugger interruptedContext isDead ifTrue:[ ^self ].
	self updateBytecode! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'debugger extension' stamp: ''!
debuggerExtensionToolName
	^ 'Bytecode' ! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'initialization' stamp: ''!
initializeToolbar
	toolbar := self newToolbar.
	toolbar addStyle: 'stToolbar'.
	toolbar beIcons.
	SpToolbarPresenterBuilder new
		toolbarPresenter: toolbar;
		visit: self toolbarActions! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'actions' stamp: ''!
stepBytecode
	self sindarin stepBytecode.
	self debugger forceSessionUpdate ! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'debugger extension' stamp: ''!
displayOrder
	^self class displayOrder! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'accessing' stamp: ''!
setModelBeforeInitialization: aStDebugger
	"My original model is the debugger presenter that I extend"
	stDebugger := aStDebugger.
	sindarinDebugger := aStDebugger sindarinDebugger! !

!StSindarinBytecodeDebuggerPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	bytecode := self newList.
	bcContextInspection := nil inspectionRaw.
	bcContextInspection owner: self.
	self initializeToolbar! !

!StSindarinBytecodeDebuggerPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #toolbar expand: false fill: false padding: 0;
		add: #bytecode;		
		add: #bcContextInspection;
		yourself! !

!StSindarinBytecodeDebuggerPresenter class methodsFor: 'debugger extension' stamp: ''!
displayOrder: anInteger
	debuggerExtensionDisplayOrder := anInteger! !

!StSindarinBytecodeDebuggerPresenter class methodsFor: 'debugger extension' stamp: ''!
showInDebugger: aBoolean
	showDebuggerExtension := aBoolean! !

!StSindarinBytecodeDebuggerPresenter class methodsFor: 'debugger extension' stamp: ''!
displayOrder

	^ debuggerExtensionDisplayOrder ifNil: [ 
		  debuggerExtensionDisplayOrder := self defaultDisplayOrder ]! !

!StSindarinBytecodeDebuggerPresenter class methodsFor: 'debugger extension' stamp: ''!
defaultDisplayOrder

	^ 2! !

!StSindarinBytecodeDebuggerPresenter class methodsFor: 'debugger extension' stamp: ''!
showInDebugger
	^showDebuggerExtension ifNil: [showDebuggerExtension := false]! !

!StSindarinContextInteractionModel methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!StSindarinContextInteractionModel methodsFor: 'binding' stamp: ''!
hasBindingOf: aString
	self bindings at: aString ifAbsent: [ 
		^ (context receiver class hasSlotNamed: aString) or: [ 
			  (context temporaryVariableNamed: aString) notNil ] ].
	^ true! !

!StSindarinContextInteractionModel methodsFor: 'binding' stamp: ''!
bindingOf: aString
	^ self bindings at: aString ifAbsent: [ 
		  (context receiver class hasSlotNamed: aString)
			  ifTrue: [ context receiver class slotNamed: aString ]
			  ifFalse: [ context temporaryVariableNamed: aString ] ]! !

!StSindarinContextInteractionModel methodsFor: 'accessing' stamp: ''!
context: anObject
	context := anObject! !

!StSindarinDebuggerPresenter methodsFor: 'stepping' stamp: ''!
refresh 
	stack items: self model stack.
	stack selectIndex: 1! !

!StSindarinDebuggerPresenter methodsFor: 'stepping' stamp: ''!
stepIn 
	self model step.
	self refresh! !

!StSindarinDebuggerPresenter methodsFor: 'initialization' stamp: ''!
buildToolbar
	| group |
	group := CmCommandGroup forSpec.
	SindarinCommand allSubclasses
		do: [ :cmd | group register: (cmd forSpecContext: self) ].
	^ group asToolbarPresenterWith: [ :presenter |
		presenter 
			displayMode: self application toolbarDisplayMode;
			addStyle: 'stToolbar' ]! !

!StSindarinDebuggerPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	stack := self newList.
	stack
		whenSelectionChangedDo: [ :selection | 
			selection selectedItem
				ifNil: [ inspector model: nil.
					currentNodeSource text: '' ]
				ifNotNil: [ | node |
					node := selection selectedItem node.
					inspector model: node.
					inspector setAttributeTable.
					currentNodeSource text: node source.
					currentNodeSource beForBehavior: node methodNode methodClass.
					currentNodeSource selectionInterval: (node start to: node stop).
					currentNodeSource
						doItReceiver: selection selectedItem home receiver;
						doItContext: selection selectedItem ].
			currentNodeSource accept ].
	stack items: self model stack.
	inspector := StRawInspection on: self model stack first.
	currentNodeSource := self newCode.
	currentNodeSource
		whenBuiltDo: [ :ann | ann widget font: StandardFonts codeFont ].
	currentNodeSource withSyntaxHighlight.
	currentNodeSource text: self model node source.
	currentNodeSource beForBehavior: self model method methodClass.
	stack selectIndex: 1.
	toolbar := self buildToolbar! !

!StSindarinDebuggerPresenter methodsFor: 'stepping' stamp: ''!
stepOver 
	self model stepOver.
	self refresh! !

!StSindarinDebuggerPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec

	^ SpBoxLayout newTopToBottom
		add: #toolbar expand: false;
		add:
			(SpPanedLayout newTopToBottom
				add: #stack;
				add:
					(SpPanedLayout newLeftToRight
						add: #inspector;
						add: #currentNodeSource;
						yourself);
				yourself);
		yourself! !

!StSindarinDebuggerPresenter class methodsFor: 'specs' stamp: ''!
title
	^'Sindarin Debugger'! !

!StSindarinDebuggerScriptingPresenter commentStamp: ''!
I am a StDebugger extension for scripting the developer's debugging session.
I provides ways to:
- write a live script directly in the debugger (and affecting the debug session)
- save/load scripts
- create debugging commands from scripts

My owner must be a spec debugger!
!StSindarinDebuggerScriptingPresenter methodsFor: 'building' stamp: ''!
toolbarActions
	| group |
	group := (CmCommandGroup named: 'Toolbar') asSpecGroup.
	
	group register: (SindarinRunScriptCommand forSpecContext: self).
	group register: (SindarinSaveScriptCommand forSpecContext: self).
	group register: (SindarinLoadScriptCommand forSpecContext: self).
	group register: (SindarinCreateCommandFromScriptCommand forSpecContext: self).
	group register: (SindarinRemoveCommandCommand forSpecContext: self).

	
	^ group! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'actions' stamp: ''!
createCommandFromScript
	self flag: 'todo'! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'accessing' stamp: ''!
debugger 
	^stDebugger! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'actions' stamp: ''!
removeScriptCommand
	self flag: 'todo'! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'actions' stamp: ''!
executeScript
	| stream result model receiver evaluationContext |
	self debugger removeSessionHolderSubscriptions.
	stream := code text readStream.
	model := code interactionModel.
	receiver := model context receiver.
	evaluationContext := model context.
	result := receiver class compiler
		          source: stream;
		          context: evaluationContext;
		          receiver: receiver;
		          requestor: model;
		          failBlock: [ nil ];
		          evaluate.
	resultInspection model: result.
	resultInspection update.
	self debugger setSessionHolderSubscriptions.
	self debugger forceSessionUpdate! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'accessing' stamp: ''!
sindarin
	^sindarinDebugger ! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'initialization' stamp: ''!
updatePresenter 	
	self updateCode.
	super updatePresenter ! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'debugger extension' stamp: ''!
debuggerExtensionToolName

	^ 'Sindarin'! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'initialization' stamp: ''!
initializeToolbar
	toolbar := self newToolbar.
	toolbar addStyle: 'stToolbar'.
	toolbar beIcons.
	SpToolbarPresenterBuilder new
		toolbarPresenter: toolbar;
		visit: self toolbarActions! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'debugger extension' stamp: ''!
displayOrder
	^self class displayOrder! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'actions' stamp: ''!
loadScript
	self flag: 'todo'! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'actions' stamp: ''!
saveScript
	self flag: 'todo'! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters
	code := self newCode.
	code interactionModel: StSindarinContextInteractionModel new.
	code syntaxHighlight: true.
	"code contextMenu: [  ]."
	code text: 'sindarin stepOver'.
	self updateCode.
	self flag: 'Build a generic sindarin script class with sidnarin as an instance var and its instance should be the receiver of the code'.
	self flag: 'set the doit conetxt of the code to the current selected context'.
	resultInspection := nil inspectionRaw.
	resultInspection owner: self.
	self initializeToolbar! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'accessing' stamp: ''!
setModelBeforeInitialization: aStDebugger
	"My original model is the debugger presenter that I extend"
	stDebugger := aStDebugger.
	sindarinDebugger := aStDebugger sindarinDebugger! !

!StSindarinDebuggerScriptingPresenter methodsFor: 'initialization' stamp: ''!
updateCode
	code interactionModel context: self debugger currentContext.
	code interactionModel bindings
		at: #sindarin
		put: (WorkspaceVariable key: #sindarin value: self sindarin)! !

!StSindarinDebuggerScriptingPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #toolbar expand: false;
		add: #code;
		add: 'Result (right click to see more...)' 
			expand: false 
			fill: false 
			padding: 5;
		add: #resultInspection;
		yourself! !

!StSindarinDebuggerScriptingPresenter class methodsFor: 'debugger extension' stamp: ''!
displayOrder: anInteger
	debuggerExtensionDisplayOrder := anInteger! !

!StSindarinDebuggerScriptingPresenter class methodsFor: 'debugger extension' stamp: ''!
showInDebugger: aBoolean
	showDebuggerExtension := aBoolean! !

!StSindarinDebuggerScriptingPresenter class methodsFor: 'debugger extension' stamp: ''!
displayOrder

	^ debuggerExtensionDisplayOrder ifNil: [ 
		  debuggerExtensionDisplayOrder := self defaultDisplayOrder ]! !

!StSindarinDebuggerScriptingPresenter class methodsFor: 'debugger extension' stamp: ''!
defaultDisplayOrder

	^ 1! !

!StSindarinDebuggerScriptingPresenter class methodsFor: 'debugger extension' stamp: ''!
showInDebugger
	^showDebuggerExtension ifNil: [showDebuggerExtension := false]! !

!StSizeReporter commentStamp: ''!
I'm a reporter dedicated to size of the system.

```
StSizeReporter new openWithSpec
```
!
!StSizeReporter methodsFor: 'building report' stamp: ''!
reportNbClasses: aStream

	self header: 'Number of classes' on: aStream.
	aStream nextPutAll: '# All classes '.
	self printNumber: self imageClasses size on: aStream.
	aStream cr; nextPutAll: '# Tests classes: '.
	self printNumber: self testClasses size on: aStream.
	aStream cr; nextPutAll: '# Manifest classes: '.
	self printNumber: self manifestClasses size on: aStream.
	aStream cr; nextPutAll: '# BaselineOf-s:  '.
	self printNumber: self baselineClasses size on: aStream.
	aStream cr; nextPutAll: '# Effective classes:  '.
	self printNumber: (self imageClasses size - self testClasses size - self manifestClasses size - self baselineClasses size) on: aStream.
		
		! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
manifestClasses

	^ data at: #manifestClasses! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
baselineClassLoc
	^ data at: #baselineClassLoc ifAbsent: [ self computeLocs. data at: #baselineClassLoc ]! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
testClassLoc

	^ data at: #testClassLoc ifAbsent: [ self computeLocs. data at: #testClassLoc ]
	! !

!StSizeReporter methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	data := Dictionary new. 
	data at: #imageClasses put: self class environment allClasses.
	data at: #imageClassPackages put: (self imageClasses collect: [ :each | each package ] as: Set).
	
	data at: #manifestClasses put: (self imageClasses select: [ :each | each isManifest ]).
	data at: #manifestClassPackages put: (self manifestClasses collect: [ :each | each package ] as: Set).
	
	data at: #testClasses put: (self imageClasses select: [ :each | each isTestCase ]).
	data at: #testClassPackages put: (self testClasses collect: [ :each | each package ] as: Set).
	
	data at: #baselineClasses put: (self imageClasses select: [:c | c name beginsWith: 'BaselineOf' ]).
	data at: #baselineClassPackages put: (self baselineClasses collect: [ :each | each package ] as: Set).
	
	data at: #effectiveClasses put: (self imageClasses reject: [ :c | c isManifest or: [ c isTestCase or: [ c name beginsWith: 'BaselineOf' ] ]]).
	data at: #effectiveClassPackages put: (self effectiveClasses collect: [ :each | each package ] as: Set).
	
	topicList selectIndex: 1.! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
effectiveClasses

	^ data at: #effectiveClasses! !

!StSizeReporter methodsFor: 'building report' stamp: ''!
reportSmartInfo: aStream

	self header: 'Smarter data' on: aStream.
	aStream nextPutAll: 'Analysis foreffective classes'.
	aStream cr.
	aStream nextPutAll: ' i.e., no test, baseline, manifest classes'.
	aStream cr.
	aStream nextPutAll: '# packages: '.
	self printNumber: self effectiveClassPackages size on: aStream.
	aStream cr.
	aStream nextPutAll: '# classes: '.
	self printNumber: self effectiveClasses size on: aStream.
	aStream cr.
	aStream nextPutAll: '# average number of classes per package: '.
	aStream print: (self effectiveClasses size / self effectiveClassPackages size) asFloat rounded.
	aStream cr.
	aStream nextPutAll: '# max number of classes in a package: '.
	aStream print: (self effectiveClassPackages asOrderedCollection max: [ :aPackage | aPackage definedClasses size]).
	aStream cr.
	aStream nextPutAll: '# average number of methods per classes: '.
	aStream print: ((self effectiveClasses inject: 0 into: [ :sum :c | sum + c numberOfMethods ]) / self effectiveClasses size) asFloat rounded.
	

! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
imageClassPackages

	^ data at: #imageClassPackages! !

!StSizeReporter methodsFor: 'building report' stamp: ''!
topicSpec
  {	#'# smart report' -> #reportSmartInfo: .
	#'# raw classes' -> #reportNbClasses:  .
	#'# raw traits' -> #reportNbTraits: .
	#'# raw LOC' -> #reportLOC: }
		do: [ :each | self addTopicSpec: each ].
	^ topics
		 ! !

!StSizeReporter methodsFor: 'utils' stamp: ''!
printNumber: aNumber on: aStream

	aNumber
		printSeparatedBy: Character space 
		every: 3
		signed: false
		on: aStream! !

!StSizeReporter methodsFor: 'building report' stamp: ''!
extent

	^ 600@ 400! !

!StSizeReporter methodsFor: 'initialization' stamp: ''!
fillTopics

  {	#'# smart report' -> #reportSmartInfo: .
	#'# raw classes' -> #reportNbClasses:  .
	#'# raw traits' -> #reportNbTraits: .
	#'# raw LOC' -> #reportLOC: }
		do: [ :each | self addTopicSpec: each ].

		 ! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
effectiveClassPackages

	^ data at: #effectiveClassPackages! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
effectiveClassLoc

	^ data at: #effectiveClassLoc ifAbsentPut: [ self computeLocs. 
			self imageClassLoc - self baselineClassLoc - self testClassLoc - self manifestClassLoc ]
	! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
imageClasses

	^ data at: #imageClasses! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
manifestClassLoc

	^ data at: #manifestClassLoc ifAbsent: [ self computeLocs. data at: #manifestClassLoc ]
	! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
testClasses

	^ data at: #testClasses! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
imageClassLoc 
	^ data at: #imageClassLoc  ifAbsent: [ self computeLocs. data at: #imageClassLoc ]! !

!StSizeReporter methodsFor: 'building report' stamp: ''!
reportLOC: aStream
	
	self header: 'Number of LinesOfCode' on: aStream.
	aStream nextPutAll: '# for all classes: '.
	self printNumber: self imageClassLoc on: aStream.
	aStream cr.
	aStream nextPutAll: '# for manifest classes: '.
	self printNumber: self manifestClassLoc on: aStream.
	aStream cr.
	aStream nextPutAll: '# for test classes: '.
	self printNumber: self testClassLoc on: aStream.
	aStream cr.
	aStream nextPutAll: '# for baselines: '.
	self printNumber: self baselineClassLoc on: aStream.
	aStream cr.
	aStream nextPutAll: '# for effective classes: '.
	self printNumber: self effectiveClassLoc on: aStream.
	aStream cr.
	aStream nextPutAll: 'Average LOC per class for effective classes: '.
	aStream print: (self effectiveClassLoc / self effectiveClasses size) asFloat rounded! !

!StSizeReporter methodsFor: 'building report' stamp: ''!
reportNbTraits: aStream
	| imageTraits |
	imageTraits := self class environment allTraits.
	self header: 'Number of traits' on: aStream.
	aStream 
		nextPutAll: imageTraits size asString; cr ;
		nextPutAll: 'not used: ' ;
		nextPutAll: (imageTraits count: [ :t | t users isEmpty ]) asString; cr
! !

!StSizeReporter methodsFor: 'ui' stamp: ''!
title 

	^ 'Size reporter'! !

!StSizeReporter methodsFor: 'compute' stamp: ''!
computeLocs 

	data at: #manifestClassLoc put:  (self manifestClasses inject: 0 into: [ :sum :each | sum + each linesOfCode]).
	data at: #testClassLoc put: (self testClasses inject: 0 into: [ :sum :each | sum + each linesOfCode]).
	data at: #baselineClassLoc put: (self baselineClasses inject: 0 into: [ :sum :each | sum + each linesOfCode]).
	data at: #imageClassLoc put: (self imageClasses inject: 0 into: [ :sum :each | sum + each linesOfCode]).
	data at: #effectiveClassLoc put: self imageClassLoc - self baselineClassLoc - self manifestClassLoc - self testClassLoc! !

!StSizeReporter methodsFor: 'accessing' stamp: ''!
baselineClasses

	^ data at: #baselineClasses! !

!StSourceFactory commentStamp: ''!
I represent the responsibility to create the sources, 
so there could be different strategies to generate the sources, for example with or without indexes.!
!StSourceFactory methodsFor: 'sources - implementors' stamp: ''!
implementorsBeginsWithSource

	^ self subclassResponsibility! !

!StSourceFactory methodsFor: 'sources - classes' stamp: ''!
classesBeginsWithSource

	 ^ self subclassResponsibility ! !

!StSourceFactory methodsFor: 'sources - implementors' stamp: ''!
implementorsSubstringSource

	^ self subclassResponsibility! !

!StSourceFactory methodsFor: 'sources - classes' stamp: ''!
classesSubstringSource

	 ^ self subclassResponsibility ! !

!StSourceFactory class methodsFor: 'accessing' stamp: ''!
current

	^ Current ifNil: [ self defaultSourceFactory ]! !

!StSourceFactory class methodsFor: 'accessing' stamp: ''!
forTest

	Current := self new! !

!StSourceFactory class methodsFor: 'detecting implementations' stamp: ''!
priority 

	^ self subclassResponsibility ! !

!StSourceFactory class methodsFor: 'detecting implementations' stamp: ''!
isAvailable 

	^ self subclassResponsibility! !

!StSourceFactory class methodsFor: 'class initialization' stamp: ''!
reset

	Current := nil! !

!StSourceFactory class methodsFor: 'detecting implementations' stamp: ''!
defaultSourceFactory

	| sourceFactoryClass |
	sourceFactoryClass := (self subclasses
		sorted: [ :a :b | a priority > b priority ])
		detect: [ :each | each isAvailable ].
		
	^ sourceFactoryClass new! !

!StSpotter commentStamp: ''!
When exploring the system, is useful to have a single entry point that will allow users to search for different component of the system. 
Spotter provides such entry point and is usually available by pressing <meta+enter>.

Spotter is just a front-end to show the result of different processors (see *StSpotterProcessor*) that provide results. Those processors can be configured in different ways and will provide different access options. 

Some known processors and options are: 

## Classes processor: 
- Type #classes in the search bar
- Press <meta+b>

## Implementors processor: 
- Type #implementors in the search bar
- Press <meta+m>

## Senders processor: 
- Type #senders in the search bar
- Press <meta+n>!
!StSpotter methodsFor: 'actions' stamp: ''!
openFinder

	self window close.
	self flag: #TODO. "Move finder to spec (right now is a morph)"
	Finder open! !

!StSpotter methodsFor: 'private' stamp: ''!
previewContainer

	^ previewContainer! !

!StSpotter methodsFor: 'private - processing' stamp: ''!
keepLastSelectedEntry
	"When starting a process (a new query), it may happen that I have already a selection on the 
	 result list. Since my new query may be a refination (or expansion) of an existing search. 
	 As an explication, if you search for the string 'Obje', what in fact happens in spotter is that 
	 several search starts and resuls are produced before having time of cancelling it. 
	 So, you may be browsing the result of the search 'Obj' to select 'Object', 
	 then the results of the search 'Obje' start to arrive... we need to keep the entry selected to 
	 ensure the selection of 'Object' will stay there when the new results arrive."

	lastSelectedEntry := resultList selectedItem 
		ifNotNil: [ :aPresenter | aPresenter model value ]! !

!StSpotter methodsFor: 'private - updating' stamp: ''!
headerCategoryFor: aLink

	^ categories 
		at: aLink processor
		ifAbsentPut: [ self newSpotterHeaderPresenter: aLink processor ]! !

!StSpotter methodsFor: 'initialization' stamp: ''!
updatePresenter

	self feedTip! !

!StSpotter methodsFor: 'private - updating' stamp: ''!
updateSearchFromProcessor: aProcessor

	searchText text: aProcessor query textInSearchBar.
	searchText cursorPositionIndex: searchText text size + 1.! !

!StSpotter methodsFor: 'private - factory' stamp: ''!
newSpotterHeaderPresenter: aProcessor

	^ (self instantiate: StSpotterHeaderPresenter on: aProcessor)
		nested: self model isNested;
		whenDiveInDo: [ :processor | self diveInProcessor: processor ];
		whenDiveOutDo: [ self diveOut ];
		yourself! !

!StSpotter methodsFor: 'private' stamp: ''!
stopProcessing
	"Start the process."

	self model stopProcessing! !

!StSpotter methodsFor: 'accessing - model' stamp: ''!
model

	^ model ifNil: [ model := self defaultModel ]! !

!StSpotter methodsFor: 'private' stamp: ''!
searchText

	^ searchText! !

!StSpotter methodsFor: 'private - updating' stamp: ''!
updateResultList: aCandidateLink

	mutex critical: [ queue add: aCandidateLink ].
	lastUpdateTime ifNil: [ lastUpdateTime := Time millisecondClockValue ].
	(updating or: [ (Time millisecondClockValue - lastUpdateTime) < 50 ]) 
		ifTrue: [ ^ self ].
	
	self flushPendingUpdates! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
activateLink: aCandidateLink

	self window close.
	self historize: aCandidateLink.
	aCandidateLink value evaluateFor: self! !

!StSpotter methodsFor: 'initialization' stamp: ''!
initialize

	mutex ifNil: [ mutex := Mutex new ].
	queue := OrderedCollection new.
	updating := false.
	categories := Dictionary new.
	super initialize! !

!StSpotter methodsFor: 'initialization' stamp: ''!
initialExtent

	self flag: #TODO. "Maybe calculate coordinates?"
	^ self isShowingPreview 
		ifTrue: [ 750@450 ]
		ifFalse: [ 500@450 ]! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
searchingString
	| searchString searchChunks |
	
	searchString := searchText text trimmed.
	searchChunks := searchString substrings.
	^ (searchChunks anySatisfy: [ :each | each first = $# ])
		ifTrue: [ ' ' join: (searchChunks reject: [ :each | each first = $# ]) ]
		ifFalse: [ searchString ]! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
hideSpinner

	self application defer: [ spinner hide ]! !

!StSpotter methodsFor: 'private - processing' stamp: ''!
resetLastSelectedEntry
	
	lastSelectedEntry := nil! !

!StSpotter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter
 
	aDialogWindowPresenter closeOnBackdropClick: true! !

!StSpotter methodsFor: 'testing' stamp: ''!
isShowingTips

	^ self class isShowingTips! !

!StSpotter methodsFor: 'testing' stamp: ''!
isShowingPreview

	^ self class isShowingPreview! !

!StSpotter methodsFor: 'private' stamp: ''!
removeAll

	mutex critical: [ queue removeAll ]. 
	categories removeAll.
	self allowUIToDraw! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
maybeActivateFirstElementOfResultList
	"| text |

	text := self searchingString.
	resultList presenters
		detect: [ :each | each matchesText: text ]
		ifFound: [ :aPresenter | self activate: aPresenter ]."
		
	self activate: resultList selectedItem ! !

!StSpotter methodsFor: 'private - updating' stamp: ''!
updateResultProcessor: processor amount: amount

	self application defer: [ 
		categories 
			at: processor 
			ifPresent: [ :aPresenter | aPresenter finalAmount: amount ] ]! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
historize: aCandidateLink

	self class historize: aCandidateLink! !

!StSpotter methodsFor: 'initialization' stamp: ''!
initializePresenters
	| contentsLayout |

	self layout: (SpBoxLayout newTopToBottom
		borderWidth: 10;
		spacing: 5;
		add: (searchText := self newSearchInput) expand: false;
		add: (SpOverlayLayout new
			child: ((contentsLayout := SpBoxLayout newLeftToRight)
				beHomogeneous;
				spacing: 5;
				add: (resultList := self newComponentList);
				yourself);
			addOverlay: (spinner := self newSpinner) 
				withConstraints: [ :c | c vAlignCenter; hAlignCenter ];
			yourself)
		yourself).

	self isShowingPreview ifTrue: [ self addPreviewPanelTo: contentsLayout ].
	self isShowingTips ifTrue: [ self addTipsPanel ].

	self addStyle: 'stSpotter'.
	
	spinner hide.

	resultList
		addStyle: 'stSpotterList';		
		bindKeyCombination: Character arrowUp asKeyCombination 
			toAction: [ :target :widget :event |
				self transferFocusToSearchTextArrowUp.
				event wasHandled: false ];
		bindKeyCombination: Character arrowDown asKeyCombination 
			toAction: [ :target :widget :event | 
				self transferFocusToSearchTextArrowDown.
				event wasHandled: false ];
		bindKeyCombination: Character arrowRight asKeyCombination 
			toAction: [ self tryDiveIn ];
		bindKeyCombination: Character arrowLeft asKeyCombination 
			toAction: [ self tryDiveOut ]; 
		whenActivatedDo: [ :selection | 
			self activate: selection selectedItem ].
	resultList eventHandler 
		whenKeyDownDo: [ :anEvent | self handleKeyEvent: anEvent ].

	searchText 
		placeholder: 'Search...';
		addStyle: 'stSpotterSearch';
		whenTextChangedDo: [ :aString | self updateSearch: aString ];
		bindKeyCombination: Character arrowDown asKeyCombination 
			toAction: [ self transferFocusToResultList ];
		bindKeyCombination: Character arrowUp asKeyCombination 
			toAction: [ self transferFocusToResultListAtLast ];
		bindKeyCombination: Character cr asKeyCombination 
			toAction: [ self maybeActivateFirstElementOfResultList ].
	! !

!StSpotter methodsFor: 'private' stamp: ''!
allowUIToDraw

	"5 is a magic number we tested is enough to allow the UI to display the spotter"
	5 timesRepeat: [ Processor yield ].
! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
diveOut

	self resetLastSelectedEntry.
	self removeAllResults.
	self model popStep.
	self model lastSearchText ifNotNil: [ :aString | 
		searchText text: aString.
		searchText cursorPositionIndex: aString size + 1 ]! !

!StSpotter methodsFor: 'private' stamp: ''!
transferFocusToSearchTextArrowDown

	(resultList items notEmpty 
		and: [ resultList selection selectedIndex = resultList items size ])
		ifTrue: [ searchText takeKeyboardFocus ]! !

!StSpotter methodsFor: 'private' stamp: ''!
startProcessing
	"Start the process."

	self model schedule: [ 
		self allowUIToDraw.
		self model startProcessingOn: self
	]! !

!StSpotter methodsFor: 'private' stamp: ''!
transferFocusToResultListAt: index

	resultList items isEmptyOrNil ifTrue: [ ^ self ].
	
	resultList 
		selectIndex: index;
		takeKeyboardFocus! !

!StSpotter methodsFor: 'private' stamp: ''!
transferFocusToSearchTextArrowUp

	(resultList items notEmpty 
		and: [ resultList selection selectedIndex = 1 ])
		ifTrue: [ searchText takeKeyboardFocus ]! !

!StSpotter methodsFor: 'private' stamp: ''!
transferFocusToResultListAtLast 

	self transferFocusToResultListAt: (resultList presenters size)! !

!StSpotter methodsFor: 'private - updating' stamp: ''!
flushPendingUpdates

	self application defer: [ 
		self model schedule: [ 
			mutex critical: [ 
				[ 
				self queuedUpdateResultList.
				lastUpdateTime := Time millisecondClockValue ]
					on: Exception
					fork: [ :e | "Allow halts and that, but eat errors (since otherwise, ugly things can happen)"
						(e isKindOf: Error)
							ifTrue: [ ('Spotter error: ' , e printString) crTrace ]
							ifFalse: [ e pass ] ] ] ] ]! !

!StSpotter methodsFor: 'initialization' stamp: ''!
addPreviewPanelTo: contentsLayout

	contentsLayout 	add: (previewContainer := SpBoxLayout newTopToBottom).
	resultList whenSelectionChangedDo: [ :selection | 
		self showPreview: selection selectedItem ]! !

!StSpotter methodsFor: 'private - updating' stamp: ''!
nextSelectablePresenter: selectedPresenter oldPresenters: oldPresenters newPresenters: newPresenters

	"look for current selected presenter"	
	| text |
	(selectedPresenter notNil and: [ selectedPresenter model notNil ]) ifTrue: [ 	
		newPresenters 
			detect: [ :each | each model value = selectedPresenter model value ]
			ifFound: [ :aPresenter | ^ aPresenter ] ].
	"not found, look for last selected"
	lastSelectedEntry ifNotNil: [ 
		newPresenters 
			detect: [ :each | each model value = lastSelectedEntry ]
			ifFound: [ :aPresenter | ^ aPresenter ] ].
	"select first in list that matches"
	text := self searchingString.
	newPresenters
		detect: [ :each | each matchesText: text ]
		ifFound: [ :aPresenter | ^ aPresenter ]. 
	"select first in list that is not a header"
	newPresenters
		detect: [ :each | each isHeader not ]
		ifFound: [ :aPresenter | ^ aPresenter ]. 
	
	^ nil! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
showPreview: aPresenter

	previewContainer removeAll.	
	(aPresenter isNil or: [ aPresenter isHeader ]) 
		ifTrue: [ ^ self ].

	aPresenter model value spotterPreview 
		ifNotNil: [ :previewPresenter | 
			previewContainer add: (previewPresenter 
				owner: self; 
				yourself) ]! !

!StSpotter methodsFor: 'private' stamp: ''!
defaultModel

	^ StSpotterModel new
		in: [ :this | self configureModel: this ];
		yourself! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
tryDiveIn
	| item |
	
	self model isNested ifTrue: [ ^ self ].
	item := resultList selectedItem.
	item ifNil: [ ^ self ].
	item isHeader ifFalse: [ ^ self ].
	item diveIn! !

!StSpotter methodsFor: 'private - updating' stamp: ''!
updateSearch: aString
	
	self model schedule: [
		self model 
			processSearch: aString 
			on: self ]! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
activate: aPresenter

	aPresenter ifNil: [ ^ self ].
	aPresenter activateOn: self! !

!StSpotter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aSpotterModel

	model := aSpotterModel.
	self configureModel: model! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
tryDiveOut
	| item |
	
	self model isNested ifFalse: [ ^ self ].
	item := resultList selectedItem.
	item ifNil: [ ^ self ].
	item isHeader ifFalse: [ ^ self ].
	item diveOut! !

!StSpotter methodsFor: 'processing' stamp: ''!
startNewProcess

	self keepLastSelectedEntry.
	self removeAll! !

!StSpotter methodsFor: 'private' stamp: ''!
handleKeyEvent: anEvent
	
	(#( 30 "arrow up" 31 "arrow down" 13 "cr") includes: anEvent keyCharacter asInteger)
		ifFalse: [ searchText takeKeyboardFocus ]! !

!StSpotter methodsFor: 'initialization' stamp: ''!
addTipsPanel 

	self layout: (SpBoxLayout newTopToBottom
		add: self layout;
		add: (SpBoxLayout newLeftToRight
				vAlignCenter;
				borderWidth: 3;
				spacing: 3;
				add: (self newImage 
					image: (self application iconNamed: #smallHelp);
					in: [ :this | this eventHandler whenMouseDownDo: [ :anEvent | self feedTip ] ];
					yourself)
					expand: false;
				add: ((tip := self newLabel)
					in: [ :this | this eventHandler whenMouseDownDo: [ :anEvent | self feedTip ] ];
					yourself);
				addLast: (SpBoxLayout newTopToBottom 
					add: (self newLink 
						label: 'Advanced Search...';
						action: [ self openFinder ];
						yourself);
					yourself)
					expand: false;
				yourself)
			expand: false;
		yourself)! !

!StSpotter methodsFor: 'private - updating' stamp: ''!
queuedUpdateResultList
	| categoryPresenter presenters selectedPresenter |

	updating ifTrue: [ ^ self ].
	updating := true.

	[  
		[ queue isEmpty ] 
		whileFalse: [ | aCandidateLink |
			aCandidateLink := queue removeFirst.
			categoryPresenter := aCandidateLink processor 
				headerCategoryFor: aCandidateLink
				on: self.
			(categoryPresenter includesLink: aCandidateLink) ifFalse: [ 
				categoryPresenter addCandidate: aCandidateLink inSpotter: self ] ].
	
		categories ifEmpty: [ ^ self ].
		presenters := (categories values 
			sorted: [ :each | each order ] ascending)
			flatCollect: [ :each | each withCandidates ]. 
	
		selectedPresenter := self 
			nextSelectablePresenter: resultList selectedItem
			oldPresenters: resultList presenters
			newPresenters: presenters.
		resultList presenters: presenters.
		selectedPresenter 
			ifNotNil: [ resultList selectItem: selectedPresenter ].
	]
	ensure: [ 
		updating := false ]! !

!StSpotter methodsFor: 'private - updating' stamp: ''!
headerCategoryUnifiedFor: aLink

	^ categories 
		at: aLink value class
		ifAbsentPut: [ 
			(self newSpotterHeaderPresenter: aLink processor)
				type: aLink value class;
				yourself ]! !

!StSpotter methodsFor: 'private' stamp: ''!
removeAllResults

	resultList presenters: #().
	self removeAll! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
diveInProcessor: aProcessor

	self model schedule: [
		self showSpinner.
		self resetLastSelectedEntry.
		self removeAllResults.
		self model pushStepForProcessor: aProcessor.
		resultList verticalAlignment desiredVisibleRow: 1.
		searchText text: '' ]! !

!StSpotter methodsFor: 'private' stamp: ''!
configureModel: aModel 

	aModel 
		whenNoResultsDo: [ self removeAllResults ];
		"whenSearchUpdatedDo: [ :aCandidateLink | 
			self updateResultList: aCandidateLink ];"
		whenAmountChangedDo: [ :processor :amount | 
			self updateResultProcessor: processor amount: amount ];
		whenQueryStartedDo: [ self showSpinner ];
		whenQueryEndedDo: [ self hideSpinner ]! !

!StSpotter methodsFor: 'private - factory' stamp: ''!
newSpotterCandidateLinkPresenter: aLink

	^ self instantiate: StSpotterCandidateLinkPresenter on: aLink! !

!StSpotter methodsFor: 'actions' stamp: ''!
feedTip
	
	tip ifNil: [ ^ self ].
	tip label: self class tips atRandom! !

!StSpotter methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	super initializeWindow: aWindowPresenter.
	aWindowPresenter 
		title: 'Spotter';
		withoutDecorations;
		initialExtent: self initialExtent;
		whenOpenedDo: [ self startProcessing ];
		whenClosedDo: [ 
			self stopProcessing.
			self class windowClosed ];
		centered.

	self flag: #TODO. "This is more or less hacky, since I am using the processors that are
	relevant to the first level of spotter as the only ones, but for now it is working"
	self model activeProcessors do: [ :each | 
		each 
			installKeymappingsOn: aWindowPresenter
			onExecution: [ :aProcessor | self updateSearchFromProcessor: aProcessor ] ]! !

!StSpotter methodsFor: 'private - actions' stamp: ''!
showSpinner

	spinner isVisible ifTrue: [ ^ self ].
	self model schedule: [
		self application defer: [ spinner show ]]! !

!StSpotter methodsFor: 'private' stamp: ''!
transferFocusToResultList
	| index |

	index := resultList selection selectedIndex + 1.
	self transferFocusToResultListAt: ((index > resultList items size)
		ifTrue: [ 1 ]
		ifFalse: [ index ])! !

!StSpotter class methodsFor: 'accessing' stamp: ''!
resetHistory
	<script>
	"
	self resetHistory
	"
	History := nil! !

!StSpotter class methodsFor: 'instance creation' stamp: ''!
openOn: aModel

	self reset.
	spotter := self on: aModel.
	^ spotter openModalWithSpec! !

!StSpotter class methodsFor: 'accessing' stamp: ''!
history

	^ self basicHistory reject: [ :each | each isNil ]! !

!StSpotter class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>

	(aBuilder group: #spotter)
		parent: #tools;
		label: 'Spotter';
		description: 'Spotter configuration'.

	(aBuilder setting: #previewVisible)
		parent: #spotter;
		default: self isShowingPreview;
		target: self;
		description: 'If Spotter will show the preview panel on the right of spotter';
		label: 'Show Preview Panel'.
		
	(aBuilder setting: #tipsVisible)
		parent: #spotter;
		default: self isShowingTips;
		target: self;
		description: 'If Spotter will show the tips at the bottom of spotter';
		label: 'Show Tips Panel'.! !

!StSpotter class methodsFor: 'private' stamp: ''!
tips 

	^ Tips ifNil: [ Tips := self createTips ]! !

!StSpotter class methodsFor: 'settings' stamp: ''!
tipsVisible: aBoolean
		
	TipsVisible := aBoolean! !

!StSpotter class methodsFor: 'instance creation' stamp: ''!
openOnOrigin: anObject

	^ self openOn: (StSpotterModel newOrigin: anObject)! !

!StSpotter class methodsFor: 'settings' stamp: ''!
tipsVisible
		
	^ TipsVisible! !

!StSpotter class methodsFor: 'settings' stamp: ''!
previewVisible: aBoolean
	
	PreviewVisible := aBoolean! !

!StSpotter class methodsFor: 'class initialization' stamp: ''!
initialize

	self showPreview.
	self showTips! !

!StSpotter class methodsFor: 'testing' stamp: ''!
isShowingTips

	^ TipsVisible! !

!StSpotter class methodsFor: 'testing' stamp: ''!
isShowingPreview

	^ PreviewVisible! !

!StSpotter class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	"self registerToolsOn: Smalltalk tools"

	registry register: self as: #spotter! !

!StSpotter class methodsFor: 'private' stamp: ''!
historize: aCandidateLink

	self basicHistory 
		removeAllSuchThat: [ :each | each value = aCandidateLink value ];
		addFirst: aCandidateLink! !

!StSpotter class methodsFor: 'settings' stamp: ''!
previewVisible
		
	^ PreviewVisible! !

!StSpotter class methodsFor: 'private' stamp: ''!
basicHistory

	^ History ifNil: [ History := WeakOrderedCollection new ]! !

!StSpotter class methodsFor: 'accessing' stamp: ''!
hidePreview
	<script>

	PreviewVisible := false! !

!StSpotter class methodsFor: 'instance creation' stamp: ''!
open

	self reset.
	spotter := self new.
	^ spotter openModalWithSpec! !

!StSpotter class methodsFor: 'private' stamp: ''!
createTips

	^ {
		'<meta+b> filters for Classes'.
		'<meta+m> filters for Implementors'.
		'<meta+n> filters for Senders'.
		'<meta+p> filters for Packages'.
		'<meta+h> filters for Help topics'.
		'Adding #Classes in the query filters for Classes'.
		'Adding #Implementors in the query filters for Implementors'.
		'Adding #Help in the query filters for Help Topics'.
		'Adding #Packages in the query filters for Packages'.
		'Adding #Menu in the query filters for System Menu entries'.
		'Using words separated with spaces looks up for all of them'.
		'Using camel case looks up for all of the parts'.
		'Clicking in the question mark shows another tip'.
		'Clicking in this tip shows another tip'.
	}! !

!StSpotter class methodsFor: 'class initialization' stamp: ''!
reset
	
	spotter ifNotNil: [ 
		spotter window close.
		spotter := nil ]! !

!StSpotter class methodsFor: 'private' stamp: ''!
windowClosed

	spotter := nil! !

!StSpotter class methodsFor: 'accessing' stamp: ''!
showPreview
	<script>
	
	PreviewVisible := true! !

!StSpotter class methodsFor: 'accessing' stamp: ''!
showTips
	<script>
	
	TipsVisible := true! !

!StSpotter class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #Spotter)
		action: [ Smalltalk tools spotter open ];
		keyText: 'Shift + Enter';
		order: 1;
		parent: #Searching;
		help: 'Search tool to explore Pharo system effectively.';
		iconName: #smallFindIcon! !

!StSpotter class methodsFor: 'accessing' stamp: ''!
hideTips
	<script>

	TipsVisible := false! !

!StSpotterAllCandidatesAdded commentStamp: ''!
Announce all candidates has been found.!
!StSpotterAllCandidatesAdded methodsFor: 'accessing' stamp: ''!
candidateLinks: anObject
	candidateLinks := anObject! !

!StSpotterAllCandidatesAdded methodsFor: 'accessing' stamp: ''!
candidateLinks
	^ candidateLinks! !

!StSpotterAnnouncement commentStamp: ''!
A base announcement for spotter events.!
!StSpotterAnnouncement methodsFor: 'accessing' stamp: ''!
category: anObject
	"Set the category (ie the kind of group of elements). This has nothing to do with class category."
	category := anObject! !

!StSpotterAnnouncement methodsFor: 'accessing' stamp: ''!
category
	"Return the category (ie the kind of group of elements). This has nothing to do with class category."
	^ category! !

!StSpotterBasePresenter commentStamp: ''!
A base for presenters to be displayed as part of the spotter results list.!
!StSpotterBasePresenter methodsFor: 'testing' stamp: ''!
matchesText: aString 
	
	self subclassResponsibility! !

!StSpotterBasePresenter methodsFor: 'testing' stamp: ''!
isHeader

	^ false! !

!StSpotterBasePresenter methodsFor: 'accessing' stamp: ''!
model

	^ self subclassResponsibility! !

!StSpotterBasePresenter methodsFor: 'actions' stamp: ''!
activateOn: spotterPresenter

	self subclassResponsibility! !

!StSpotterBaseTest methodsFor: 'private' stamp: ''!
waitUntilUIRedrawed

	backendForTest waitUntilUIRedrawed! !

!StSpotterBaseTest methodsFor: 'private' stamp: ''!
waitUntilEnded: model

	[ (StSpotterModel delayBeforeQuery + 50 milliSeconds) wait ] 
	doWhileTrue: [ 
		model scheduler workers anySatisfy: [ :each | each isBusy ] ].
! !

!StSpotterBaseTest methodsFor: 'private' stamp: ''!
defer: aBlock

	World defer: aBlock.
	self waitUntilUIRedrawed! !

!StSpotterBaseTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	backendForTest := SpMorphicBackendForTest new! !

!StSpotterBaseTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ super isAbstract or: [ self = StSpotterBaseTest ]! !

!StSpotterBlockIterator commentStamp: ''!
Define an iterator on a block to be used to feed items to spotter.
A block receives the `StSpotterBlockIterator>>#onDo:` event, to call when iterating on an element.!
!StSpotterBlockIterator methodsFor: 'accessing' stamp: ''!
onDo: anObject
	onDo := anObject! !

!StSpotterBlockIterator methodsFor: 'accessing' stamp: ''!
onDo
	^ onDo ifNil: [ onDo := [ :anItemBlock :aContext | " do nothing " ] ]! !

!StSpotterBlockIterator methodsFor: 'private' stamp: ''!
itemDo: aBlock 
	self onDo 
		cull: aBlock
		cull: self context ! !

!StSpotterCandidateAdded commentStamp: ''!
Announce a new canditate has been found.!
!StSpotterCandidateAdded methodsFor: 'accessing' stamp: ''!
candidate
	^ candidateLink value! !

!StSpotterCandidateAdded methodsFor: 'accessing' stamp: ''!
candidateLink

	^ candidateLink! !

!StSpotterCandidateAdded methodsFor: 'accessing' stamp: ''!
candidateLink: anObject
	candidateLink := anObject! !

!StSpotterCandidateLink commentStamp: ''!
a link with a `StSpotterCandidateLink>>#candidate`.
it is intended to work as element of a linked list.!
!StSpotterCandidateLink methodsFor: 'comparing' stamp: ''!
< anotherCandidateLink

	^ self weight < anotherCandidateLink weight! !

!StSpotterCandidateLink methodsFor: 'converting' stamp: ''!
asStSpotterCandidateLink

	^ self! !

!StSpotterCandidateLink methodsFor: 'accessing' stamp: ''!
previous
	^ self previousLink! !

!StSpotterCandidateLink methodsFor: 'accessing' stamp: ''!
candidate
	^ self value! !

!StSpotterCandidateLink methodsFor: 'private' stamp: ''!
privateProcessorLink: aLink

	processorLink := aLink! !

!StSpotterCandidateLink methodsFor: 'testing' stamp: ''!
matchesText: aString
	
	^ self value 
		ifNotNil: [ self value matchesText: aString ]
		ifNil: [ false ]! !

!StSpotterCandidateLink methodsFor: 'accessing' stamp: ''!
next
	^ self nextLink! !

!StSpotterCandidateLink methodsFor: 'accessing' stamp: ''!
renderingProcessor: aProcessorLink

	renderingProcessorLink ifNil: [ 
		renderingProcessorLink := aProcessorLink processor asStSpotterProcessorLink ].
	processorLink ifNil: [ processorLink := aProcessorLink ]! !

!StSpotterCandidateLink methodsFor: 'accessing' stamp: ''!
processor

	^ self processorLink value! !

!StSpotterCandidateLink methodsFor: 'copying' stamp: ''!
copy
	| link |
	
	link := self class value: self value.
	link privateProcessorLink: processorLink.
	link privateRenderingProcessorLink: renderingProcessorLink.
	link weight: weight.
	
	^ link! !

!StSpotterCandidateLink methodsFor: 'printing' stamp: ''!
displayStringOn: stream

	stream nextPutAll: 'Candidate link: '.
	self value displayStringOn: stream ! !

!StSpotterCandidateLink methodsFor: 'accessing' stamp: ''!
processorLink: anObject

	"we set rendering processor only if one is not set. it allows to have a collection of items,
	that have different rendering processors"
	
	processorLink ifNil: [ self renderingProcessor: anObject ].
	processorLink := anObject.
	! !

!StSpotterCandidateLink methodsFor: 'accessing' stamp: ''!
weight

	^ weight! !

!StSpotterCandidateLink methodsFor: 'accessing' stamp: ''!
weight: anObject 

	weight := anObject! !

!StSpotterCandidateLink methodsFor: 'comparing' stamp: ''!
> anotherCandidateLink

	^ self weight > anotherCandidateLink weight! !

!StSpotterCandidateLink methodsFor: 'private' stamp: ''!
privateRenderingProcessorLink: aLink

	renderingProcessorLink := aLink! !

!StSpotterCandidateLink methodsFor: 'accessing' stamp: ''!
processorLink
	^ processorLink! !

!StSpotterCandidateLink methodsFor: 'accessing' stamp: ''!
renderingProcessor

	renderingProcessorLink ifNil: [ self renderingProcessor: processorLink ].
	^ renderingProcessorLink value! !

!StSpotterCandidateLink methodsFor: 'testing' stamp: ''!
isFirst

	^ self previousLink processorLink ~= self processorLink! !

!StSpotterCandidateLinkPresenter commentStamp: ''!
A presenter to show a candidate (an option that can be choosen). 
!
!StSpotterCandidateLinkPresenter methodsFor: 'testing' stamp: ''!
matchesText: aString

	^ self model 
		ifNotNil: [ self model matchesText: aString ]
		ifNil: [ false ]! !

!StSpotterCandidateLinkPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aCandidateLink

	model := aCandidateLink! !

!StSpotterCandidateLinkPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpBoxLayout newLeftToRight
		borderWidth: 2;
		spacing: 5;
		vAlignCenter;
		add: (iconPresenter := self newImage) expand: false;
		add: (labelPresenter := self newLabel);
		yourself).
		
	self addStyle: 'stSpotterLink'.
	self entry ifNotNil: [ 
		iconPresenter image: self entry icon.
		labelPresenter label: self entry label ]! !

!StSpotterCandidateLinkPresenter methodsFor: 'accessing' stamp: ''!
entry

	^ self model value! !

!StSpotterCandidateLinkPresenter methodsFor: 'accessing - model' stamp: ''!
model

	^ model! !

!StSpotterCandidateLinkPresenter methodsFor: 'actions' stamp: ''!
activateOn: spotterPresenter

	spotterPresenter activateLink: self model! !

!StSpotterCandidatesAmountChanged commentStamp: ''!
Announces the ammount of candidates found changed.!
!StSpotterCandidatesAmountChanged methodsFor: 'accessing' stamp: ''!
amount: anObject

	amount := anObject! !

!StSpotterCandidatesAmountChanged methodsFor: 'accessing' stamp: ''!
amount

	^ amount! !

!StSpotterCandidatesList commentStamp: ''!
Maintains a list of candidates (results of a `StSpotterQuery`).!
!StSpotterCandidatesList methodsFor: 'testing' stamp: ''!
isEmpty
	"Return true if there are no candidates in the list, false otherwise"
	<return: #Boolean>

	^ self candidates isEmpty! !

!StSpotterCandidatesList methodsFor: 'private' stamp: ''!
privateAddCandidate: aCandidateLink inEmpty: aProcessorLink
	| head current |
	current := aProcessorLink.	"not nil"
	head := nil.	"nil"
	[ head isNil and: [ current isNotNil ] ]
		whileTrue: [ current := current nextLink.	"next category"
			"head of next category if not nil break loop"
			current ifNotNil: [ head := current headLink ] ].

	"means all next categories are empty, just add to the end"
	current
		ifNil: [ self candidates addLast: aCandidateLink ]
		ifNotNil: [ self candidates add: aCandidateLink beforeLink: head ].
	aProcessorLink
		headLink: aCandidateLink;
		tailLink: aCandidateLink.

	aProcessorLink incrementSize.

	^ aCandidateLink! !

!StSpotterCandidatesList methodsFor: 'processors' stamp: ''!
previousProcessorLinkOf: aProcessorLink
	"returns previous processor link, that has more than zero candidates.
	if passed processor is the first one, will continue searching from the end"
	| current |
	
	aProcessorLink ifNil: [ ^ aProcessorLink ].
	
	current := aProcessorLink previousLink.
	current ifNil: [ current := self processors stTail ].
	
	[ current = aProcessorLink ] whileFalse: [
		(current isEmpty) ifFalse: [ ^ current ].
		current := current previousLink.
		current ifNil: [ current := self processors stTail ] ].

	^ aProcessorLink
	! !

!StSpotterCandidatesList methodsFor: 'testing' stamp: ''!
isNotEmpty
	"Return true if there is at least one candidate in the list, false otherwise"
	<return: #Boolean>

	^ self isEmpty not! !

!StSpotterCandidatesList methodsFor: 'notifying' stamp: ''!
processorEnded: aProcessor

	self announcer announce: (StSpotterProcessorEnded newProcessor: self)! !

!StSpotterCandidatesList methodsFor: 'notifying' stamp: ''!
notifyAllCandidatesRemoved

	"self announcer announce: (GTSpotterAllCandidatesRemoved new)"! !

!StSpotterCandidatesList methodsFor: 'processors' stamp: ''!
nextProcessorLinkOf: aProcessorLink
	"returns next processor link, that has more than zero candidates.
	if passed processor is the last one, will continue searching from the beginning"
	| current |
	
	aProcessorLink ifNil: [ ^ aProcessorLink ].
	
	current := aProcessorLink nextLink.
	current ifNil: [ current := self processors head ].
	
	[ current = aProcessorLink ] whileFalse: [
		(current isEmpty) ifFalse: [ ^ current ].
		current := current nextLink.
		current ifNil: [ current := self processors head ] ].

	^ aProcessorLink! !

!StSpotterCandidatesList methodsFor: 'private' stamp: ''!
privateAddCandidate: aCandidateLink weightedInNotFull: aProcessorLink
	| head tail |
	
	head := aProcessorLink headLink.
	tail := aProcessorLink tailLink.

	"fast check if we need to add it before first"
	(aCandidateLink weight > head weight)
		ifTrue: [ head := self candidates add: aCandidateLink beforeLink: head ]
		ifFalse: [
			"fast check if we need to add it after the last"
			(aCandidateLink weight > tail weight)
				ifFalse: [ tail := self candidates add: aCandidateLink afterLink: tail ]
				ifTrue: [  ] ]! !

!StSpotterCandidatesList methodsFor: 'accessing' stamp: ''!
candidates

	^ candidates ifNil: [ candidates := DoubleLinkedList new ]! !

!StSpotterCandidatesList methodsFor: 'adding/removing' stamp: ''!
addProcessor: aProcessor
	| processorLink |
	
	processorLink := aProcessor asStSpotterProcessorLink.
	"linking processor with it's link"
	self processorLinksMap add: (aProcessor -> processorLink).
	self processors addLast: processorLink.
	
	^ processorLink! !

!StSpotterCandidatesList methodsFor: 'candidates' stamp: ''!
head

	^ self candidates head! !

!StSpotterCandidatesList methodsFor: 'adding/removing' stamp: ''!
addCandidate: anObjectOrLink in: aProcessor
	"before adding candidates we need to define all categories, because their order is important"
	| processorLink candidateLink |
	
	"processorLink is DoubleLink"
	processorLink := self getProcessorLink: aProcessor.
	candidateLink := anObjectOrLink asStSpotterCandidateLink processorLink: processorLink.
	
	"if head is nil, it means there are no candidates yet"
	candidateLink := processorLink isEmpty
		ifTrue: [ self privateAddCandidate: candidateLink inEmpty: processorLink ]
		ifFalse: [ self privateAddCandidate: candidateLink inNotEmpty: processorLink ].
		
	count := count + 1.
	candidateLink weight: count.
		
	self notifyCandidateAdded: candidateLink in: aProcessor.
	
	^ candidateLink! !

!StSpotterCandidatesList methodsFor: 'private' stamp: ''!
privateAddCandidate: aCandidateLink inNotEmpty: aProcessorLink
	
	"aCandidateLink weight
		ifNotNil: [ ^ self privateAddCandidate: aCandidateLink weightedIn: aProcessorLink ]."
	
	self candidates add: aCandidateLink afterLink: (aProcessorLink tailLink).
	aProcessorLink incrementSize.
	"updating category tail"
	aProcessorLink tailLink: aCandidateLink.
	^ aCandidateLink! !

!StSpotterCandidatesList methodsFor: 'notifying' stamp: ''!
processorStarted: aProcessor

	self announcer announce: (StSpotterProcessorStarted newProcessor: self)! !

!StSpotterCandidatesList methodsFor: 'adding/removing' stamp: ''!
addAllCandidates: aCollection in: aProcessor
	| allLinks |
	
	allLinks := aCollection collect: [ :each | 
		| processorLink candidateLink |
		processorLink := self getProcessorLink: aProcessor.
		candidateLink := each asStSpotterCandidateLink processorLink: processorLink.	"if head is nil, it means there are no candidates yet"
		candidateLink := processorLink isEmpty
			ifTrue: [ self privateAddCandidate: candidateLink inEmpty: processorLink ]
			ifFalse: [ self privateAddCandidate: candidateLink inNotEmpty: processorLink ].
		candidateLink ].

	self announcer announce: (StSpotterAllCandidatesAdded new
		candidateLinks: allLinks;
		category: aProcessor;
		yourself)! !

!StSpotterCandidatesList methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer ifNil: [ announcer := Announcer new ]! !

!StSpotterCandidatesList methodsFor: 'processors' stamp: ''!
getProcessorLinkByCandidateLink: aCandidateLink

	^ aCandidateLink processorLink! !

!StSpotterCandidatesList methodsFor: 'processors' stamp: ''!
getProcessorLink: aProcessor

	^ self processorLinksMap at: aProcessor ifAbsentPut: [ self addProcessor: aProcessor ]! !

!StSpotterCandidatesList methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	count := 0! !

!StSpotterCandidatesList methodsFor: 'adding/removing' stamp: ''!
removeAllCandidatesOf: aProcessor
	| processorLink head tail current |
	
	processorLink := self getProcessorLink: aProcessor.
	processorLink isEmpty ifTrue: [ ^ self ].
	
	head := processorLink headLink.
	tail := processorLink tailLink.
		
	(head = tail) ifTrue: [
		self candidates stRemoveCycledLink: head.
		processorLink clear. ].
	
	current := head.
	[ current = tail ] whileFalse: [ | nextCurrent |
		nextCurrent := current nextLink.
		self candidates stRemoveCycledLink: current.
		current := nextCurrent ].
	
	self candidates stRemoveCycledLink: current.
	
	processorLink clear.
	
	
	
	
	
	! !

!StSpotterCandidatesList methodsFor: 'candidates' stamp: ''!
getCandidateLink: aCandiate in: aProcessor
	"returns a corresponding candidateLink, that belongs to a processor"
	(self getCandidateLinks: (self getProcessorLink: aProcessor))
		do: [ :each | each value = aCandiate ifTrue: [ ^ each ] ].
	
	^ nil
	! !

!StSpotterCandidatesList methodsFor: 'accessing' stamp: ''!
processors

	^ categories ifNil: [ categories := DoubleLinkedList new ].! !

!StSpotterCandidatesList methodsFor: 'candidates' stamp: ''!
stTail

	^ self candidates stTail! !

!StSpotterCandidatesList methodsFor: 'stream handling' stamp: ''!
onAmountChanged: anInteger in: aProcessor
	"Amount must be non-negative"
	"If amount is not positive there is no need to do anything"
	
	anInteger <= 0 ifTrue: [ ^ self ].
	self announcer announce: (StSpotterCandidatesAmountChanged new 
		amount: anInteger; 
		category: aProcessor; 
		yourself)! !

!StSpotterCandidatesList methodsFor: 'candidates' stamp: ''!
getCandidateLinks: aProcessorLink
	"returns all candidate links that belongs to a processor link"
	| list head tail current |
	
	head := aProcessorLink headLink.
	tail := aProcessorLink tailLink.
	
	list := OrderedCollection new.
	head ifNil: [ ^ list ].
	(head = tail) ifTrue: [ list add: head. ^ list ].
	
	current := head.
	
	[ current = tail ] whileFalse: [
		list add: current.
		current := current nextLink ].
	"adding last one"
	list add: current.
	
	^ list! !

!StSpotterCandidatesList methodsFor: 'notifying' stamp: ''!
notifyCandidateAdded: aCandidateLink in: aProcessor

	self announcer announce: (StSpotterCandidateAdded new 
		candidateLink: aCandidateLink; 
		category: aProcessor; 
		yourself).! !

!StSpotterCandidatesList methodsFor: 'private' stamp: ''!
privateAddCandidate: aCandidateLink weightedIn: aProcessorLink

	^ aProcessorLink isFull
		ifTrue: [ self privateAddCandidate: aCandidateLink weightedInFull: aProcessorLink ]
		ifFalse: [ self privateAddCandidate: aCandidateLink weightedInNotFull: aProcessorLink ]! !

!StSpotterCandidatesList methodsFor: 'adding/removing' stamp: ''!
removeAllCandidates

	self processors linksDo: [ :each | each clear ].
	self candidates removeAll.
	self notifyAllCandidatesRemoved! !

!StSpotterCandidatesList methodsFor: 'private' stamp: ''!
privateAddCandidate: aCandidateLink weightedInFull: aProcessorLink

	! !

!StSpotterCandidatesList methodsFor: 'accessing' stamp: ''!
processorLinksMap

	^ processorLinksMap ifNil: [ processorLinksMap := Dictionary new ]
	! !

!StSpotterCandidatesListProcessor methodsFor: 'private' stamp: ''!
actOn: anObject for: aStep
	
	actBlock
		ifNil: [ super actOn: anObject for: aStep ]
		ifNotNil: [ actBlock cull: anObject cull: aStep ]! !

!StSpotterCandidatesListProcessor methodsFor: 'private' stamp: ''!
itemNameFor: anObject

	^ itemNameBlock ifNil: [ super itemNameFor: anObject ] ifNotNil: [ itemNameBlock cull: anObject ]! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting' stamp: ''!
filter: aFilter item: anIterator 

	self filter: aFilter.
	self items: anIterator stIterator.
	! !

!StSpotterCandidatesListProcessor methodsFor: 'private' stamp: ''!
itemIconFor: anObject

	^ itemIconBlock ifNil: [ super itemIconFor: anObject ] ifNotNil: [ itemIconBlock cull: anObject ]! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting' stamp: ''!
itemsLimit: anInteger
	candidatesLimit := anInteger! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing' stamp: ''!
itemIcon
	^ itemIconBlock! !

!StSpotterCandidatesListProcessor methodsFor: 'private' stamp: ''!
withItemsLimit: aLimit do: aBlock
	| previousCandidatesLimit |
	previousCandidatesLimit := candidatesLimit.
	^ [ candidatesLimit := aLimit. aBlock value ] 
		ensure: [ candidatesLimit := previousCandidatesLimit ]! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting' stamp: ''!
filter: aGTFilterOrBlockWithOneArgument
	filterBlock := aGTFilterOrBlockWithOneArgument ! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting' stamp: ''!
itemIcon: aBlockWithOneArgument
	itemIconBlock := aBlockWithOneArgument! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting - convenience' stamp: ''!
matchAlike
	self filter: StFilterAlike! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing' stamp: ''!
filter
	^ filterBlock! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting' stamp: ''!
sort: aBlockWithTwoArguments
	sortBlock := aBlockWithTwoArguments! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting' stamp: ''!
actLogic: aBlockWithTwoArguments

	actBlock := aBlockWithTwoArguments! !

!StSpotterCandidatesListProcessor methodsFor: 'private' stamp: ''!
computeAllItemsIn: aContext
	^ allCandidatesBlock cull: aContext! !

!StSpotterCandidatesListProcessor methodsFor: 'private' stamp: ''!
doFilterInContext: aSpotterContext

	^ aSpotterContext 
		doFilter: filterBlock stFilter 
		forProcessor: self! !

!StSpotterCandidatesListProcessor methodsFor: 'compatibility' stamp: ''!
allCandidates: aBlockWithOneArgument
	self items: aBlockWithOneArgument! !

!StSpotterCandidatesListProcessor methodsFor: 'testing' stamp: ''!
hasDynamicItems

	^ allCandidatesBlock stHasDynamicItems! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing' stamp: ''!
keyBinding: anObject
	keyBinding := anObject! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting - convenience' stamp: ''!
matchSubstring
	self filter: StFilterSubstring! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing' stamp: ''!
sort
	^ sortBlock! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing' stamp: ''!
title
	^ title ifNil: [ super title ]! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting' stamp: ''!
title: aString
	title := aString! !

!StSpotterCandidatesListProcessor methodsFor: 'compatibility' stamp: ''!
filterUsing: aFilter
	self filter: aFilter! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting - convenience' stamp: ''!
matchRegex
	self filter: StFilterRegex! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing - defaults' stamp: ''!
defaultItemsLimit
	^ self class defaultItemsLimit! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing' stamp: ''!
itemName
	^ itemNameBlock! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting - convenience' stamp: ''!
matchSubstrings
	self filter: StFilterSubstrings! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing - defaults' stamp: ''!
defaultContinueItemsLimit
	" Spotter becomes extraordenary slow when rendering too many results. So we set the maximum limit to 100. This is only a temporary solution until we have fixed the problem. Until then no spotter processor will ever generate more then 100 results. "
	^ 100! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing' stamp: ''!
wantsToDisplayOnEmptyQuery
	^ wantsToDisplayOnEmptyQuery ifNil: [ super wantsToDisplayOnEmptyQuery ]! !

!StSpotterCandidatesListProcessor methodsFor: 'compatibility' stamp: ''!
defaultCandidatesLimit
	^ self defaultItemsLimit! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting' stamp: ''!
items: aBlock
	allCandidatesBlock := aBlock! !

!StSpotterCandidatesListProcessor methodsFor: 'compatibility' stamp: ''!
candidatesLimit: anInteger
	self itemsLimit: anInteger! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting - convenience' stamp: ''!
matchString
	self filter: StFilterStringMatch! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting - convenience' stamp: ''!
match: aBlockWithTwoArguments

	self filter: (StFilterBlock new 
		matcher: aBlockWithTwoArguments;
		yourself)! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing' stamp: ''!
itemsLimit
	^ candidatesLimit ifNil: [ self defaultItemsLimit ]! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting' stamp: ''!
itemName: aBlockWithOneArgument
	itemNameBlock := aBlockWithOneArgument! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing' stamp: ''!
keyBinding
	^ keyBinding! !

!StSpotterCandidatesListProcessor methodsFor: 'scripting' stamp: ''!
wantsToDisplayOnEmptyQuery: anObject
	wantsToDisplayOnEmptyQuery := anObject! !

!StSpotterCandidatesListProcessor methodsFor: 'accessing' stamp: ''!
actLogic
	^ actBlock! !

!StSpotterCandidatesProcessor methodsFor: 'compatibility' stamp: ''!
computeCandidatesIn: aContext

	^ self computeAllItemsIn: aContext! !

!StSpotterCandidatesProcessor methodsFor: 'private' stamp: ''!
itemNameFor: anObject
	^ anObject displayString! !

!StSpotterCandidatesProcessor methodsFor: 'private' stamp: ''!
itemFilterNameFor: anObject
	^ self itemNameFor: anObject! !

!StSpotterCandidatesProcessor methodsFor: 'private' stamp: ''!
itemIconFor: anObject
	^ nil! !

!StSpotterCandidatesProcessor methodsFor: 'compatibility' stamp: ''!
allCandidatesIn: aContext
	^ self allItemsIn: aContext! !

!StSpotterCandidatesProcessor methodsFor: 'private' stamp: ''!
prepareProcessorInContext: aContext
	super prepareProcessorInContext: aContext.
	
	self hasDynamicItems ifTrue: [ allCandidates := nil ]! !

!StSpotterCandidatesProcessor methodsFor: 'accessing' stamp: ''!
origin

	^ origin! !

!StSpotterCandidatesProcessor methodsFor: 'accessing' stamp: ''!
origin: anObject

	origin := anObject! !

!StSpotterCandidatesProcessor methodsFor: 'private' stamp: ''!
computeAllItemsIn: aContext

	^ OrderedCollection new
	! !

!StSpotterCandidatesProcessor methodsFor: 'private' stamp: ''!
continueItemsLimit
	^ (self defaultContinueItemsLimit - self itemsLimit) max: 0! !

!StSpotterCandidatesProcessor methodsFor: 'public' stamp: ''!
allItemsIn: aContext

	^ allCandidates ifNil: [ allCandidates := (self computeAllItemsIn: aContext) copy ].! !

!StSpotterCandidatesProcessor methodsFor: 'private' stamp: ''!
doFilterInContext: aSpotterContext

	^ aSpotterContext 
		doFilter: StFilterBlock stFilter 
		forProcessor: self! !

!StSpotterCandidatesProcessor methodsFor: 'compatibility' stamp: ''!
candidatesLimit
	^ self itemsLimit! !

!StSpotterCandidatesProcessor methodsFor: 'accessing' stamp: ''!
itemsLimit
	"Return the maximal number of elements that can be found during search.
	Default implementation returns infinity, so the number of element is not limited."
	^ Float infinity! !

!StSpotterCandidatesProcessor methodsFor: 'accessing' stamp: ''!
title
	^ 'undefined'! !

!StSpotterCandidatesProcessor class methodsFor: 'instance creation' stamp: ''!
on: anObject

	^ self new origin: anObject! !

!StSpotterContext commentStamp: ''!
Defines the context execution of a `StSpotterQuery`. 
It has the `StSpotterContext>>#text` that is being searched and the `StSpotterContext>>#stream` for it. !
!StSpotterContext methodsFor: 'public' stamp: ''!
cacheAt: aSymbol ifAbsentPut: aBlock
	^ self cache at: aSymbol ifAbsentPut: aBlock! !

!StSpotterContext methodsFor: 'accessing - defaults' stamp: ''!
defaultCache
	^ IdentityDictionary new 
		at: #processorsAndFilters put: (IdentityDictionary new: 100); " not a limitation, just a reasonable start size "
		at: #processorsAndStreamed put: (IdentityDictionary new: 100); " not a limitation, just a reasonable start size "
		yourself! !

!StSpotterContext methodsFor: 'testing' stamp: ''!
isEmpty
	^ self text isNil
		or: [ self textTrimmed isEmpty ]! !

!StSpotterContext methodsFor: 'public' stamp: ''!
cacheAt: aSymbol ifAbsent: aBlock
	^ self cache at: aSymbol ifAbsent: aBlock! !

!StSpotterContext methodsFor: 'public' stamp: ''!
addItem: anObject

	self stream 
		addObject: anObject 
		inProcessor: self processor! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
step
	^ step! !

!StSpotterContext methodsFor: 'public' stamp: ''!
removeCacheAt: aSymbol
	^ self cache removeKey: aSymbol ifAbsent: [ nil ]! !

!StSpotterContext methodsFor: 'private' stamp: ''!
continueFilter
	| processors nonEmptyProcessors |
	processors := self cache at: #processorsAndFilters ifAbsent: [ ^ self ].
	nonEmptyProcessors := processors associations select: [ :assoc | assoc key hasFilteredCandidates ].
	nonEmptyProcessors size = 1 ifFalse: [ ^ self ].
	self canContinue ifFalse: [ ^ self ].
	
	self withContinue: true do: [ 
		nonEmptyProcessors do: [ :assoc | 
			assoc key continueFilterInContext: self ] ]! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
processor
	^ processor! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
filter: anObject
	filter := anObject! !

!StSpotterContext methodsFor: 'accessing - dynamic' stamp: ''!
spotter
	^ self step spotter! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
filter
	^ filter! !

!StSpotterContext methodsFor: 'accessing - defaults' stamp: ''!
defaultTextLowercase
	^ self textTrimmed asLowercase! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
cache
	^ cache! !

!StSpotterContext methodsFor: 'public' stamp: ''!
cacheAt: aSymbol
	^ self cacheAt: aSymbol ifAbsent: [ nil ]! !

!StSpotterContext methodsFor: 'public' stamp: ''!
cacheAt: aSymbol put: anObject
	^ self cache at: aSymbol put: anObject! !

!StSpotterContext methodsFor: 'private' stamp: ''!
doFilter: aFilter forProcessor: aProcessor

	self processor: aProcessor.
	self filter: aFilter.
	self streamed: (OrderedCollection new: 100). " not a limitation, just a reasonable start size "
	(self cache at: #processorsAndFilters) at: aProcessor put: aFilter.
	(self cache at: #processorsAndStreamed) at: aProcessor put: streamed.

	^ aFilter value: self! !

!StSpotterContext methodsFor: 'comparing' stamp: ''!
equals: aContext
	aContext ifNil: [ ^ false ].
   ^ self matches: aContext search! !

!StSpotterContext methodsFor: 'testing' stamp: ''!
isContinuing
	^ self continuing 
		and: [ self streamed isEmptyOrNil not 
			and: [ self canContinue ] ]! !

!StSpotterContext methodsFor: 'accessing - defaults' stamp: ''!
defaultTextTrimmed
	^ self text trimBoth! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
continuing: anObject
	continuing := anObject! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
processor: anObject
	processor := anObject! !

!StSpotterContext methodsFor: 'public' stamp: ''!
addItems: aCollection

	self stream 
		addObjects: aCollection 
		inProcessor: self processor! !

!StSpotterContext methodsFor: 'accessing - defaults' stamp: ''!
defaultContinuing
	^ false! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
streamed
	^ streamed! !

!StSpotterContext methodsFor: 'public' stamp: ''!
textTrimmed
	^ textTrimmed ifNil: [ textTrimmed := self defaultTextTrimmed ]! !

!StSpotterContext methodsFor: 'private' stamp: ''!
withContinue: aBoolean do: aBlock
	| previousContinuing |
	previousContinuing := continuing.
	^ [ continuing := aBoolean. aBlock value ]
		ensure: [ continuing := previousContinuing ]! !

!StSpotterContext methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	cache := self defaultCache.
	text := self defaultText.
	continuing := self defaultContinuing.! !

!StSpotterContext methodsFor: 'accessing - defaults' stamp: ''!
defaultText
	^ ''! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
text: anObject
	text := anObject ifNil: [ self defaultText ]! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
continuing
	^ continuing! !

!StSpotterContext methodsFor: 'public' stamp: ''!
textLowercase
	^ textLowercase ifNil: [ textLowercase := self defaultTextLowercase ]! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
search: anObject
	" search stores the fully entered text (including categories) "
	search := anObject! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
step: anObject
	step := anObject! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
stream: anObject
	stream := anObject! !

!StSpotterContext methodsFor: 'private' stamp: ''!
doContinueFilterForProcessor: aGTProcessor
	self processor: aGTProcessor.
	self filter: ((self cache at: #processorsAndFilters) at: aGTProcessor).
	self streamed: ((self cache at: #processorsAndStreamed) at: aGTProcessor).

	^ aGTProcessor withItemsLimit: aGTProcessor continueItemsLimit do: [ filter value: self ]! !

!StSpotterContext methodsFor: 'testing' stamp: ''!
matches: aString
	^ self isEmpty not
		and: [ self search = aString ]! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
stream
	^ stream! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
cache: anObject
	cache := anObject! !

!StSpotterContext methodsFor: 'testing' stamp: ''!
canContinue
	 " divein / really ugly, spotter-step does not really know why it was created or where it comes from :( "
	" another hack: diveIncategory must never continue because it just streams all items from the previous step. continuing in diveInCategory would duplicate all items!! " 
	^ self step event == #diveIn
		or: [ self step event isNil ]! !

!StSpotterContext methodsFor: 'public' stamp: ''!
itemsLimit
	^ self processor itemsLimit! !

!StSpotterContext methodsFor: 'testing' stamp: ''!
notEmpty
	^ self isEmpty not! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
search
	^ search! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
streamed: anObject
	streamed := anObject! !

!StSpotterContext methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!StSpotterHeaderPresenter commentStamp: ''!
A presenter to display a group of results.
Each processor define a group. 
Each group has a list of children (instances of *StSpotterCandidateListPresenter). 
!
!StSpotterHeaderPresenter methodsFor: 'private - actions' stamp: ''!
diveOut

	diveOutAction ifNil: [ ^ self ].
	diveOutAction cull: self model! !

!StSpotterHeaderPresenter methodsFor: 'events' stamp: ''!
whenDiveOutDo: aBlock

	diveOutAction := aBlock! !

!StSpotterHeaderPresenter methodsFor: 'accessing' stamp: ''!
type: aClass

	 aClass prepareUnifiedHeaderDescriptionFor: self! !

!StSpotterHeaderPresenter methodsFor: 'initialization' stamp: ''!
updatePresenter

	labelPresenter label: '#', self model title.
	helpLabelPresenter label: (self model keyBinding 
		ifNotNil: [ :binding | binding asString ]
		ifNil: [ '' ])! !

!StSpotterHeaderPresenter methodsFor: 'events' stamp: ''!
whenDiveInDo: aBlock

	diveInAction := aBlock! !

!StSpotterHeaderPresenter methodsFor: 'accessing' stamp: ''!
finalAmount

	^ finalAmount! !

!StSpotterHeaderPresenter methodsFor: 'actions' stamp: ''!
doDive

	nested 
		ifTrue: [ self diveOut ]
		ifFalse: [ self diveIn ]! !

!StSpotterHeaderPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aProcessor

	model := aProcessor! !

!StSpotterHeaderPresenter methodsFor: 'accessing' stamp: ''!
prepareAsImplementors

	order := self model order + 1.
	labelPresenter label: '#Implementors'.
	helpLabelPresenter label: (self model keyBindingForImplementors acceptVisitor: OSPlatform current shortcutPrinter).! !

!StSpotterHeaderPresenter methodsFor: 'accessing' stamp: ''!
prepareAsPackages

	order := self model order + 2.
	labelPresenter label: '#Packages'.
	helpLabelPresenter label: (self model keyBindingForPackages acceptVisitor: OSPlatform current shortcutPrinter).! !

!StSpotterHeaderPresenter methodsFor: 'accessing - model' stamp: ''!
model

	^ model! !

!StSpotterHeaderPresenter methodsFor: 'accessing' stamp: ''!
prepareAsClasses

	labelPresenter label: '#Classes'.
	helpLabelPresenter label: (self model keyBindingForClasses acceptVisitor: OSPlatform current shortcutPrinter).! !

!StSpotterHeaderPresenter methodsFor: 'initialization' stamp: ''!
initialize

	candidatePresentersList := OrderedCollection new.
	nested := false.
	super initialize! !

!StSpotterHeaderPresenter methodsFor: 'testing' stamp: ''!
matchesText: aString

	^ false! !

!StSpotterHeaderPresenter methodsFor: 'accessing' stamp: ''!
order

	^ order ifNil: [ self model order ]! !

!StSpotterHeaderPresenter methodsFor: 'private - updating' stamp: ''!
updateAmount

	amountLabelPresenter label: ('{1}/{2}' format: { 
		candidatePresentersList size. 
		self finalAmount ifNil: [ '...' ] })! !

!StSpotterHeaderPresenter methodsFor: 'accessing' stamp: ''!
withCandidates

	^ { self }, (candidatePresentersList sort: [ :each | each model weight ] ascending)! !

!StSpotterHeaderPresenter methodsFor: 'accessing' stamp: ''!
nested: aBoolean

	nested = aBoolean ifTrue: [ ^ self ].

	nested := aBoolean.
	diveButtonPresenter image: (self application iconNamed: (nested 
		ifTrue: [ #smallBack ]
		ifFalse: [ #smallForward ]))! !

!StSpotterHeaderPresenter methodsFor: 'private - actions' stamp: ''!
diveIn

	diveInAction ifNil: [ ^ self ].
	diveInAction cull: self model! !

!StSpotterHeaderPresenter methodsFor: 'accessing' stamp: ''!
addCandidate: aCandidateLink inSpotter: spotterPresenter

	candidatePresentersList add: (spotterPresenter newSpotterCandidateLinkPresenter: aCandidateLink).
	self updateAmount! !

!StSpotterHeaderPresenter methodsFor: 'testing' stamp: ''!
includesLink: aLink

	^ candidatePresentersList anySatisfy: [ :each | each entry = aLink value ]! !

!StSpotterHeaderPresenter methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpBoxLayout newLeftToRight
		borderWidth: 5;
		spacing: 5;
		vAlignCenter;
		add: (labelPresenter := self newLabel) expand: false;
		add: (amountLabelPresenter := self newLabel) expand: false;
		add: (helpLabelPresenter := self newLabel) expand: false;
		addLast: (diveButtonPresenter := self newImage) expand: false; 
		yourself).

	self addStyle: 'stSpotterHeader'.
	amountLabelPresenter addStyle: 'dim'.
	helpLabelPresenter addStyle: 'dim'.
	diveButtonPresenter image: (self application iconNamed: #smallForward).
	diveButtonPresenter eventHandler
		whenMouseDownDo: [ :event | 
			event isPrimaryButton ifTrue: [ self doDive ] ].! !

!StSpotterHeaderPresenter methodsFor: 'testing' stamp: ''!
isHeader

	^ true! !

!StSpotterHeaderPresenter methodsFor: 'actions' stamp: ''!
activateOn: spotterPresenter

	self doDive! !

!StSpotterHeaderPresenter methodsFor: 'accessing' stamp: ''!
finalAmount: aNumber

	finalAmount := aNumber! !

!StSpotterIterator commentStamp: ''!
Define an iterator to be used to feed items to spotter!
!StSpotterIterator methodsFor: 'public' stamp: ''!
value: aContext
	self context: aContext! !

!StSpotterIterator methodsFor: 'mimic collection' stamp: ''!
isEmpty
	^ self items isEmpty! !

!StSpotterIterator methodsFor: 'accessing' stamp: ''!
context
	^ context! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
reject: aBlock thenDo: aBlock2
	self do: [ :each | 
		(aBlock value: each) 
			ifFalse: [ aBlock2 value: each ] ]! !

!StSpotterIterator methodsFor: 'mimic collection' stamp: ''!
first: anInteger
	^ self items copyFrom: 1 to: (self size min: (anInteger max: 0))! !

!StSpotterIterator methodsFor: 'public' stamp: ''!
stIterator
	^ self! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
select: aBlock as: aCollectionClass
	| collection |
	collection := self newAs: aCollectionClass.
	self do: [ :each | 
		(aBlock value: each) 
			ifTrue: [ collection add: each ] ].
	^ collection! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
reject: aBlock as: aCollectionClass
	| collection |
	collection := self newAs: aCollectionClass.
	self do: [ :each | 
		(aBlock value: each) 
			ifFalse: [ collection add: each ] ].
	^ collection! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
select: aBlock
	^ self select: aBlock as: self defaultItemsClass! !

!StSpotterIterator methodsFor: 'accessing' stamp: ''!
context: aContext
	" we assume that if the context changes, so will the result of the iterator - so we reset the internal collection "
	context := aContext.
	self reset.! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
select: aBlock thenDo: aBlock2
	self do: [ :each | 
		(aBlock value: each) 
			ifTrue: [ aBlock2 value: each ] ]! !

!StSpotterIterator methodsFor: 'mimic collection' stamp: ''!
asArray
	^ self items asArray! !

!StSpotterIterator methodsFor: 'public' stamp: ''!
gtIterator
	^ self! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
reject: aBlock thenCollect: aBlock2 as: aCollectionClass
	| collection |
	collection := self newAs: aCollectionClass.
	self reject: aBlock thenDo: [ :each | 
		collection add: (aBlock2 value: each) ].
	^ collection! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
detect: aBlock ifFound: aBlock2 ifNone: aBlock3
	self do: [ :each | aBlock value ifTrue: [ ^ aBlock2 value: each ] ].
	^ aBlock3 value! !

!StSpotterIterator methodsFor: 'mimic enumerating' stamp: ''!
do: aBlock
	" the iterator must keep an internal collection of items being iterated. This guarantees that the iteration is not done multiple times in case somebody sends multiple subsequent messages like #size, #items or #first:. This will slightly decrease performance while iterating "
	items 
		ifNotNil: [ 
			items do: aBlock ]
		ifNil: [ 
			items := self defaultItems.
			self itemDo: [ :each | 
				items add: each.
				aBlock value: each ] ]! !

!StSpotterIterator methodsFor: 'private' stamp: ''!
newAs: aCollectionClass
	^ items 
		ifNil: [ aCollectionClass new ] 
		ifNotNil: [ aCollectionClass new: self size ]! !

!StSpotterIterator methodsFor: 'accessing - defaults' stamp: ''!
defaultItemsClass
	^ OrderedCollection ! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
collect: aBlock as: aCollectionClass
	| collection |
	collection := self newAs: aCollectionClass.
	self do: [ :each | 
		collection add: (aBlock value: each) ].
	^ collection! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
collect: aBlock
	^ self collect: aBlock as: self defaultItemsClass! !

!StSpotterIterator methodsFor: 'public' stamp: ''!
cull: aContext
	self context: aContext! !

!StSpotterIterator methodsFor: 'testing' stamp: ''!
hasDynamicItems
	^ true! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
reject: aBlock
	^ self reject: aBlock as: self defaultItemsClass! !

!StSpotterIterator methodsFor: 'accessing - defaults' stamp: ''!
defaultItems
	^ self defaultItemsClass new ! !

!StSpotterIterator methodsFor: 'initialization' stamp: ''!
reset
	items := nil.! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
select: aBlock thenCollect: aBlock2
	^ self select: aBlock thenCollect: aBlock2 as: self defaultItemsClass! !

!StSpotterIterator methodsFor: 'mimic collection' stamp: ''!
asSet
	^ self items asSet! !

!StSpotterIterator methodsFor: 'mimic collection' stamp: ''!
isEmptyOrNil
	^ self items isEmptyOrNil! !

!StSpotterIterator methodsFor: 'private' stamp: ''!
itemDo: aBlock
	self subclassResponsibility! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
anySatisfy: aBlock
	self do: [ :each | (aBlock value: each) ifTrue: [ ^ true ] ].
	^ false! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
detect: aBlock ifNone: aBlock2
	^ self detect: aBlock ifFound: [ :each | each ] ifNone: aBlock2! !

!StSpotterIterator methodsFor: 'mimic collection' stamp: ''!
last: anInteger
	^ self items last: (self size min: (anInteger max: 0))! !

!StSpotterIterator methodsFor: 'mimic collection' stamp: ''!
size
	^ self items size! !

!StSpotterIterator methodsFor: 'public' stamp: ''!
value
	^ self items! !

!StSpotterIterator methodsFor: 'private' stamp: ''!
items: anObject
	items := anObject! !

!StSpotterIterator methodsFor: 'mimic collection' stamp: ''!
asOrderedCollection
	^ self items copy " we must not expose the internal representation !! "! !

!StSpotterIterator methodsFor: 'private' stamp: ''!
items
	^ items ifNil: [ 
		items := self defaultItems.
		self itemDo: [ :each | 
			items add: each ] ]! !

!StSpotterIterator methodsFor: 'mimic collection' stamp: ''!
notEmpty
	^ self isEmpty not! !

!StSpotterIterator methodsFor: 'mimic enumerating' stamp: ''!
withIndexDo: aBlock
	| index |
	index := 0.
	self do: [ :each | aBlock cull: each cull: (index := index + 1) ]! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
allSatisfy: aBlock
	self do: [ :each | (aBlock value: each) ifFalse: [ ^ false ] ].
	^ true! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
select: aBlock thenCollect: aBlock2 as: aCollectionClass
	| collection |
	collection := self newAs: aCollectionClass.
	self select: aBlock thenDo: [ :each | 
		collection add: (aBlock2 value: each) ].
	^ collection! !

!StSpotterIterator methodsFor: 'mimic various enumerating' stamp: ''!
detect: aBlock
	^ self detect: aBlock ifNone: [ NotFound signalFor: aBlock ]! !

!StSpotterIterator class methodsFor: 'accessing' stamp: ''!
gtIterator
	^ self new! !

!StSpotterModel commentStamp: ''!
A model to process queries (to be used with StSpotter).
The main method is `StSpotterModel>>processSearch:on:` (is the entry point to any query).

To process searches the spotter model will use a worker pool to schedule a `StSpotterQuery`, which is the actual responsible of processing it.!
!StSpotterModel methodsFor: 'private' stamp: ''!
defaultProcessors

	^ (StSpotterProcessor allEnabledSubclasses 
		collect: [ :each | each new ])
		sort: #order ascending! !

!StSpotterModel methodsFor: 'accessing' stamp: ''!
lastSearchText

	^ self activeStep lastSearchText! !

!StSpotterModel methodsFor: 'accessing' stamp: ''!
links

	^ self activeStep links! !

!StSpotterModel methodsFor: 'private' stamp: ''!
steps

	^ steps ifNil: [ 
		self addStep: self newDefaultStep.
		steps ]! !

!StSpotterModel methodsFor: 'events' stamp: ''!
whenAmountChangedDo: aBlock

	amountChangedAction := aBlock! !

!StSpotterModel methodsFor: 'private - queries' stamp: ''!
pushStepForProcessor: aProcessor
	| step allCandidates processorLink |

	self activeStep deactivate.

	step := self newStep.
	processorLink := aProcessor asStSpotterProcessorLink.
	allCandidates := aProcessor allFilteredCandidates collect: [ :each | 
		each asStSpotterCandidateLink renderingProcessor: processorLink ].
	step origin: allCandidates.
	self addStep: step! !

!StSpotterModel methodsFor: 'private - announcing' stamp: ''!
announceQueryStarted: ann

	queryStartedAction ifNil: [ ^ self ].
	queryStartedAction value! !

!StSpotterModel methodsFor: 'accessing' stamp: ''!
results

	^ self activeStep results! !

!StSpotterModel methodsFor: 'accessing - query' stamp: ''!
startProcessingOn: spotter

	self doProcessSearch: '' on: spotter. 
! !

!StSpotterModel methodsFor: 'private' stamp: ''!
scheduler

	^ scheduler! !

!StSpotterModel methodsFor: 'private - announcing' stamp: ''!
announceAllCandidatesAdded: ann

	searchUpdatedAction ifNil: [ ^ self ].

	ann candidateLinks 
		do: [ :each | searchUpdatedAction value: each ]! !

!StSpotterModel methodsFor: 'events' stamp: ''!
whenQueryStartedDo: aBlock

	queryStartedAction := aBlock! !

!StSpotterModel methodsFor: 'accessing - query' stamp: ''!
stopProcessing

	self activeStep deactivate.
	scheduler stop
	! !

!StSpotterModel methodsFor: 'accessing' stamp: ''!
stSpotterProcessorsFor: aStep

	self defaultProcessors 
		do: [ :each | aStep addProcessor: each ]! !

!StSpotterModel methodsFor: 'initialization' stamp: ''!
initializeOrigin: anObject
	
	self initialize.
	self addStep: (self newStep
		origin: anObject;
		yourself)! !

!StSpotterModel methodsFor: 'events' stamp: ''!
whenSearchUpdatedDo: aBlock

	searchUpdatedAction := aBlock! !

!StSpotterModel methodsFor: 'accessing' stamp: ''!
activeStep

	^ self steps last! !

!StSpotterModel methodsFor: 'private - announcing' stamp: ''!
announceNoResults

	noResultsAction ifNil: [ ^ self ].
	noResultsAction value! !

!StSpotterModel methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	scheduler := TKTWorkerPool new.
	scheduler poolMaxSize: 5.
	scheduler start.
	
	mutex := Mutex new! !

!StSpotterModel methodsFor: 'private - announcing' stamp: ''!
announceQueryEnded: ann

	queryEndedAction ifNil: [ ^ self ].
	queryEndedAction value! !

!StSpotterModel methodsFor: 'testing' stamp: ''!
isNested

	^ self steps size > 1! !

!StSpotterModel methodsFor: 'private - factory' stamp: ''!
newDefaultStep

	^ self newStep
		origin: self;
		yourself! !

!StSpotterModel methodsFor: 'accessing - query' stamp: ''!
pushQuery: aQuery

	self schedule: [ 
		mutex critical: [ 
			self activeStep pushQuery: aQuery ] ]! !

!StSpotterModel methodsFor: 'accessing' stamp: ''!
popStep
	| lastQuery |

	"Do not pop first"
	self steps size > 1 ifFalse: [ ^ self ]. 

	lastQuery := self activeStep activeQuery.
	self activeStep deactivate.
	self steps removeLast.
	self activeStep activate! !

!StSpotterModel methodsFor: 'accessing' stamp: ''!
schedule: aBlock

	scheduler purge.
	scheduler schedule: [
		aBlock 
			on: Error 
			fork: [ :e | e pass ] ]! !

!StSpotterModel methodsFor: 'private - announcing' stamp: ''!
announceAmountChanged: ann

	amountChangedAction ifNil: [ ^ self ].
	amountChangedAction 
		value: ann category 
		value: ann amount! !

!StSpotterModel methodsFor: 'private - announcing' stamp: ''!
announceCandidateAdded: ann

	searchUpdatedAction ifNil: [ ^ self ].
	searchUpdatedAction value: ann candidateLink! !

!StSpotterModel methodsFor: 'events' stamp: ''!
whenNoResultsDo: aBlock

	noResultsAction := aBlock! !

!StSpotterModel methodsFor: 'private - queries' stamp: ''!
processSearch: aString on: spotter

	queryRequestTime := Time now.
	
	[ self class delayBeforeQuery wait. 
		((self class delayBeforeQuery + queryRequestTime) <= Time now)
			ifTrue: [ self doProcessSearch: aString on: spotter ] ] fork.	! !

!StSpotterModel methodsFor: 'events' stamp: ''!
whenQueryEndedDo: aBlock

	queryEndedAction := aBlock! !

!StSpotterModel methodsFor: 'private - factory' stamp: ''!
newStep

	^ StSpotterStep on: self! !

!StSpotterModel methodsFor: 'accessing' stamp: ''!
activeProcessors

	^ self activeStep processors! !

!StSpotterModel methodsFor: 'private' stamp: ''!
addStep: aStep

	steps ifNil: [ steps := OrderedCollection new ].
	steps addLast: aStep! !

!StSpotterModel methodsFor: 'private - queries' stamp: ''!
doProcessSearch: aString on: spotter

	pendingQuery := StSpotterQuery 
		newSearch: aString 
		on: spotter.
	
	self pushQuery: pendingQuery! !

!StSpotterModel class methodsFor: 'instance creation' stamp: ''!
newOrigin: anObject 

	^ self basicNew 
		initializeOrigin: anObject;
		yourself! !

!StSpotterModel class methodsFor: 'instance creation' stamp: ''!
delayBeforeQuery

	^ 500 milliSeconds ! !

!StSpotterModelTest methodsFor: 'tests' stamp: ''!
testSpotterModelShouldWaitToPerformActualSearch

	| model started |
	model := StSpotterModel new.
	started := false.
	
	model whenQueryStartedDo: [ started := true ].
	
	[ model processSearch: 'Object' on: StSpotter new ] fork.

	self deny: started.
	
	5 timesRepeat: [
		50 milliSeconds wait.
		self deny: started ].
	
	300 milliSeconds wait.
	self assert: started! !

!StSpotterModelTest methodsFor: 'tests' stamp: ''!
testAnnounceQueryEndedIsSentOnce
	| model count |

	self skipOnPharoCITestingEnvironment.

	count := 0.
	(model := StSpotterModel new)
		whenQueryEndedDo: [ count := count + 1 ].

	[ 
		model processSearch: 'Object' on: StSpotter new.
	] fork.
	
	self waitUntilEnded: model.
	
	self assert: count equals: 1.! !

!StSpotterPragmaBasedProcessor methodsFor: 'accessing' stamp: ''!
stop
	
	running := false! !

!StSpotterPragmaBasedProcessor methodsFor: 'public' stamp: ''!
actOn: anObject for: aStep
	anObject spotterActDefault: aStep! !

!StSpotterPragmaBasedProcessor methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	running := false! !

!StSpotterPragmaBasedProcessor methodsFor: '*NewTools-Spotter' stamp: ''!
headerCategoryFor: aLink on: aSpotterPresenter

	^ aSpotterPresenter headerCategoryFor: aLink! !

!StSpotterPragmaBasedProcessor methodsFor: 'accessing' stamp: ''!
order: aNumber
	"Assign to processor its spotter order to arrange categories
	within spotter ui"
	order := aNumber! !

!StSpotterPragmaBasedProcessor methodsFor: 'accessing' stamp: ''!
order
	"Return assigned spotter order used to arrange categories in spotter UI"
	<return: #Number>
	
	^ order! !

!StSpotterPragmaBasedProcessor methodsFor: 'testing' stamp: ''!
shouldFilterInContext: aSpotterContext
	^ aSpotterContext notEmpty 
		or: [ self wantsToDisplayOnEmptyQuery ]! !

!StSpotterPragmaBasedProcessor methodsFor: 'key-bindings' stamp: ''!
installKeymappingsOn: aPresenter onExecution: aBlock
! !

!StSpotterPragmaBasedProcessor methodsFor: 'testing' stamp: ''!
isRelevantForQuery: categoryQueryPrefix
	| trimmedProcessorTitle |
	trimmedProcessorTitle := self title asLowercase 
										copyReplaceAll: String space
										with: ''.
	^ trimmedProcessorTitle beginsWith: categoryQueryPrefix! !

!StSpotterPragmaBasedProcessor methodsFor: 'private' stamp: ''!
prepareProcessorInContext: aContext
	allFilteredCandidates := nil! !

!StSpotterPragmaBasedProcessor methodsFor: 'testing' stamp: ''!
hasFilteredCandidates
	^ self allFilteredCandidates notEmpty! !

!StSpotterPragmaBasedProcessor methodsFor: 'accessing' stamp: ''!
wantsToDisplayOnEmptyQuery
	^ true! !

!StSpotterPragmaBasedProcessor methodsFor: 'printing' stamp: ''!
displayStringOn: stream
	stream 
		nextPutAll: 'Processor: ';
		nextPutAll: self title asString! !

!StSpotterPragmaBasedProcessor methodsFor: 'private' stamp: ''!
filterInContext: aSpotterContext

	running := true.
	aSpotterContext stream 
		performSymbol: #processorStarted: 
		withArguments: { self }.
	
	self prepareProcessorInContext: aSpotterContext.
	(self shouldFilterInContext: aSpotterContext) ifTrue: [
		allFilteredCandidates := self doFilterInContext: aSpotterContext ].
	aSpotterContext stream 
		performSymbol: #onAmountChanged:in: 
		withArguments: { self allFilteredCandidates size . self }.
		
	running := false.
	aSpotterContext stream 
		performSymbol: #processorEnded: 
		withArguments: { self }.
! !

!StSpotterPragmaBasedProcessor methodsFor: 'testing' stamp: ''!
isRunning 
	
	^ running! !

!StSpotterPragmaBasedProcessor methodsFor: 'private' stamp: ''!
withItemsLimit: aLimit do: aBlock
	^ aBlock value! !

!StSpotterPragmaBasedProcessor methodsFor: 'private' stamp: ''!
doFilterInContext: aSpotterContext
	"override this method to:
	- add items to the stream
	- return all found items at the end"
	self subclassResponsibility! !

!StSpotterPragmaBasedProcessor methodsFor: 'private' stamp: ''!
doContinueFilterInContext: aSpotterContext
	^ aSpotterContext doContinueFilterForProcessor: self! !

!StSpotterPragmaBasedProcessor methodsFor: 'private' stamp: ''!
continueFilterInContext: aSpotterContext

	" We DO NOT prepare the context since we could no longer continue producing filtered candidates. "
	(self shouldFilterInContext: aSpotterContext) ifTrue: [
		" The continue-filter only puts more items on the stream but doesn't do any filtering at all. Therefore the original collection (=result/candidates) and its size remains the same and can be reused after the continue-filter has added more items. So we do not ressign the result to #allFilteredCandidates as it is done for the regular filter-loop. #allFilteredCandidates must never be modified more than once because the next #diveIntoCategory would render an invalid set of items !!!!!! "
		self doContinueFilterInContext: aSpotterContext ].
	aSpotterContext stream 
		performSymbol: #onAmountChanged:in:
		withArguments: { self allFilteredCandidates size . self }! !

!StSpotterPragmaBasedProcessor methodsFor: 'key-bindings' stamp: ''!
keyBinding

	^ nil! !

!StSpotterPragmaBasedProcessor methodsFor: 'key-bindings' stamp: ''!
installKeymappingsOn: aGTSpotterMorph

	self keyBinding
		ifNotNil: [ | keyCombination |
			keyCombination := self keyBinding asKeyCombination.
			aGTSpotterMorph 
				bindKeyCombination: keyCombination 
				ofProcessor: self 
				toAction: [ aGTSpotterMorph onKeyProcessor: self ] ]! !

!StSpotterPragmaBasedProcessor methodsFor: 'accessing' stamp: ''!
title
	self subclassResponsibility! !

!StSpotterPragmaBasedProcessor methodsFor: 'public' stamp: ''!
allFilteredCandidates
	^ allFilteredCandidates ifNil: [ allFilteredCandidates := OrderedCollection new ]! !

!StSpotterPragmaBasedProcessor class methodsFor: 'accessing - defaults' stamp: ''!
defaultItemsLimit

	^ DefaultItemsLimit ifNil: [ DefaultItemsLimit := 25 ]! !

!StSpotterPragmaBasedProcessor class methodsFor: 'accessing - defaults' stamp: ''!
defaultItemsLimit: aValue

	DefaultItemsLimit := aValue! !

!StSpotterPragmaBasedProcessor class methodsFor: 'accessing - defaults' stamp: ''!
settingsOn: aBuilder
	<systemsettings>

	(aBuilder setting: #defaultItemsLimit)
		target: self;
		parent: #spotter;
		label: 'Number of results per category';
		default: 25;
		order: 100;
		description: 'Number of results per category to show in Spotter'! !

!StSpotterProcessor commentStamp: ''!
I am a extensible spotter processor. 
I perform the integration with Spotter, but also I handle the lifecycle of the query, creating it from the spotter context; storing the results and the filter. 

The filter is divided in two instance variables. The #filter contains the whole iterator that will be used. As some of the parts of the decorator requires to be notified when the filtering text is changed there is a collection of filters that require this.

My subclasses should implement #newTextFilteringSource to return the filtering iterator to use or newSource if the iterator building is more complex (see StUnifiedProcessor).

My subclasses can override #installKeymappingsOn: to install keybindings in Spotter.
Also, there is #configureFilter to extend the configuration of the source when there is a change in the query.

I also handled the notifications when the query finish, so Spotter UI can show it correctly.!
!StSpotterProcessor methodsFor: 'accessing' stamp: ''!
actLogic

	^ [ :anItem :aStep | anItem evaluateFor: aStep ]! !

!StSpotterProcessor methodsFor: 'filtering' stamp: ''!
stop

	running := false! !

!StSpotterProcessor methodsFor: 'key-bindings' stamp: ''!
installKeymappingsOn: aPresenter onExecution: aBlock

	self installKeymappingsOn: aPresenter! !

!StSpotterProcessor methodsFor: 'accessing' stamp: ''!
itemIcon

	^ [ :anItem | anItem icon ]! !

!StSpotterProcessor methodsFor: 'events' stamp: ''!
notifyStarted: aSpotterContext

	running := true.
	aSpotterContext stream 
		performSymbol: #processorStarted: 
		withArguments: { self }.
! !

!StSpotterProcessor methodsFor: 'filtering' stamp: ''!
filter 
	
	^ filter ifNil: [ self ensureFilter ]! !

!StSpotterProcessor methodsFor: 'spotter-api' stamp: ''!
isRunning 

	^ running! !

!StSpotterProcessor methodsFor: 'configuration' stamp: ''!
maxResults

	^ StSpotterPragmaBasedProcessor defaultItemsLimit! !

!StSpotterProcessor methodsFor: 'filtering' stamp: ''!
newTextFilteringSource

	self subclassResponsibility ! !

!StSpotterProcessor methodsFor: 'accessing' stamp: ''!
title

	^ self class title! !

!StSpotterProcessor methodsFor: 'filtering' stamp: ''!
configureFilter

	self ensureFilter.
	textFilteringIterators do: [ :each | 
		each filteringText: self query searchingText ]! !

!StSpotterProcessor methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	running := false.! !

!StSpotterProcessor methodsFor: 'accessing' stamp: ''!
query

	^ query ifNil: [ 
		query := StQuery new 
			processor: self; 
			yourself ]! !

!StSpotterProcessor methodsFor: 'accessing' stamp: ''!
order: aNumber

	^ order! !

!StSpotterProcessor methodsFor: 'accessing' stamp: ''!
order

	^ order ifNil: [ self class order ]! !

!StSpotterProcessor methodsFor: 'events' stamp: ''!
notifyEnded: aSpotterContext

	running := false.
	aSpotterContext stream 
		performSymbol: #processorEnded: 
		withArguments: { self }.
! !

!StSpotterProcessor methodsFor: 'spotter-api' stamp: ''!
isRelevantForQuery: categoryQueryPrefix

	^ (self title asLowercase copyReplaceAll: String space with: '')
			beginsWith: categoryQueryPrefix! !

!StSpotterProcessor methodsFor: 'accessing' stamp: ''!
query: aQuery

	query := aQuery! !

!StSpotterProcessor methodsFor: 'accessing' stamp: ''!
itemName

	^ [ :anItem | anItem asString ]! !

!StSpotterProcessor methodsFor: 'filtering' stamp: ''!
render: anEntry
		
	^ anEntry render! !

!StSpotterProcessor methodsFor: '*NewTools-Spotter' stamp: ''!
headerCategoryFor: aLink on: aSpotterPresenter

	^ aSpotterPresenter headerCategoryFor: aLink! !

!StSpotterProcessor methodsFor: 'spotter-api' stamp: ''!
filterInContext: aSpotterContext 

	self notifyStarted: aSpotterContext.
	self query updateFromContext: aSpotterContext.
	self executeQuery.
	self notifyEnded: aSpotterContext.! !

!StSpotterProcessor methodsFor: 'filtering' stamp: ''!
executeQuery

	(self query isSearchEmpty and: [ self showForEmptyQuery not ]) 
		ifTrue: [ ^ self ].
	
	self configureFilter.
	
	results := OrderedCollection new.
	[ self isRunning and: [ self filter atEnd or: [ results size = self maxResults ] ] ] 
		whileFalse: [
			self filter next ifNotNil: [ :aResult | 
				self query addResult: aResult.
				results add: aResult ] ].

	(results size = self maxResults)
		ifTrue: [ ^ self ].

	self query informAllResultAmount: results size! !

!StSpotterProcessor methodsFor: 'configuration' stamp: ''!
showForEmptyQuery

	^ false! !

!StSpotterProcessor methodsFor: 'filtering' stamp: ''!
ensureFilter

	^ filter ifNil: [
		filter := self newSource ]! !

!StSpotterProcessor methodsFor: 'key-bindings' stamp: ''!
keyBinding 
	^ nil! !

!StSpotterProcessor methodsFor: 'filtering' stamp: ''!
newSource

	| source |
	source := self newTextFilteringSource.

	textFilteringIterators := OrderedCollection new.
	textFilteringIterators add: source.
	
	^ source
	! !

!StSpotterProcessor methodsFor: 'key-bindings' stamp: ''!
installKeymappingsOn: aPresenter 
	"Nothing to do"! !

!StSpotterProcessor methodsFor: 'spotter-api' stamp: ''!
allFilteredCandidates

	self configureFilter.		
	^ self filter upToEnd! !

!StSpotterProcessor class methodsFor: 'testing' stamp: ''!
isEnabled

	self isAbstract
		ifTrue: [ ^ false ].
	^ enabled ifNil: [ self defaultEnabled ] ifNotNil: [ enabled ]! !

!StSpotterProcessor class methodsFor: 'accessing' stamp: ''!
order
	
	^ self subclassResponsibility ! !

!StSpotterProcessor class methodsFor: 'accessing' stamp: ''!
allEnabledSubclasses
	
	^ self allConcreteSubclasses select: [ :e | e isEnabled ]! !

!StSpotterProcessor class methodsFor: 'settings' stamp: ''!
settingsTitle

	^ self title! !

!StSpotterProcessor class methodsFor: 'settings' stamp: ''!
hideInSettings

	^ false! !

!StSpotterProcessor class methodsFor: 'settings' stamp: ''!
enabled 

	^ enabled ifNil: [ self defaultEnabled ]! !

!StSpotterProcessor class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self == StSpotterProcessor ! !

!StSpotterProcessor class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>

	(aBuilder group: #spotterProcessors)
		parent: #spotter;
		label: 'Sources';
		description: 'It configures the sources that are queried when using spotter'.

	self allConcreteSubclasses 
		reject: [ :each | each hideInSettings ] 
		thenDo: [ :aProcessorClass | 
			(aBuilder setting: aProcessorClass name , '_enabled')
				parent: #spotterProcessors;
				default: aProcessorClass defaultEnabled;
				getSelector: #enabled;
				setSelector: #enabled:;
				target: aProcessorClass;
				description: aProcessorClass settingsDescription;
				label: aProcessorClass settingsTitle ]! !

!StSpotterProcessor class methodsFor: 'settings' stamp: ''!
settingsDescription

	^ self title! !

!StSpotterProcessor class methodsFor: 'settings' stamp: ''!
enabled: aValue

	enabled := aValue! !

!StSpotterProcessor class methodsFor: 'accessing' stamp: ''!
allConcreteSubclasses
	
	^ self allSubclasses reject: [ :e | e isAbstract ]! !

!StSpotterProcessor class methodsFor: 'default-settings' stamp: ''!
defaultEnabled

	^ self subclassResponsibility ! !

!StSpotterProcessor class methodsFor: 'accessing' stamp: ''!
title
	
	^ self subclassResponsibility ! !

!StSpotterProcessorEnded commentStamp: ''!
Announce a processor execution ended.!
!StSpotterProcessorEnded methodsFor: 'accessing' stamp: ''!
processor

	^ processor! !

!StSpotterProcessorEnded methodsFor: 'accessing' stamp: ''!
processor: anObject

	processor := anObject! !

!StSpotterProcessorEnded class methodsFor: 'instance creation' stamp: ''!
newProcessor: aProcessor

	^ self new 
		processor: aProcessor;
		yourself! !

!StSpotterProcessorLink commentStamp: ''!
a link with a `StSpotterProcessorLink>>#processor`.
it is intended to work as element of a linked list.!
!StSpotterProcessorLink methodsFor: 'testing' stamp: ''!
isEmpty

	^ self headLink isNil! !

!StSpotterProcessorLink methodsFor: 'accessing' stamp: ''!
tailLink: anObject
	tailLink := anObject! !

!StSpotterProcessorLink methodsFor: 'testing' stamp: ''!
isFull

	^ self size = self processor itemsLimit! !

!StSpotterProcessorLink methodsFor: 'accessing' stamp: ''!
processor

	^ self value! !

!StSpotterProcessorLink methodsFor: 'printing' stamp: ''!
displayStringOn: stream
	stream 
		nextPutAll: 'Processor link: ';
		nextPutAll: self processor title asString! !

!StSpotterProcessorLink methodsFor: 'accessing' stamp: ''!
tailLink
	^ tailLink! !

!StSpotterProcessorLink methodsFor: 'accessing' stamp: ''!
size

	^ size ifNil: [ size := 0 ]! !

!StSpotterProcessorLink methodsFor: 'accessing' stamp: ''!
headLink: anObject
	headLink := anObject! !

!StSpotterProcessorLink methodsFor: 'accessing' stamp: ''!
headLink
	^ headLink! !

!StSpotterProcessorLink methodsFor: 'actions' stamp: ''!
clear

	self
		headLink: nil;
		tailLink: nil.
		
	size := 0.! !

!StSpotterProcessorLink methodsFor: 'accessing' stamp: ''!
asStSpotterProcessorLink

	^ self! !

!StSpotterProcessorLink methodsFor: 'actions' stamp: ''!
incrementSize

	size := self size + 1! !

!StSpotterProcessorLink class methodsFor: 'accessing' stamp: ''!
from: aDoubleLink

	! !

!StSpotterProcessorStarted commentStamp: ''!
Announce a processor execution started.!
!StSpotterProcessorStarted methodsFor: 'accessing' stamp: ''!
processor

	^ processor! !

!StSpotterProcessorStarted methodsFor: 'accessing' stamp: ''!
processor: anObject

	processor := anObject! !

!StSpotterProcessorStarted class methodsFor: 'instance creation' stamp: ''!
newProcessor: aProcessor

	^ self new 
		processor: aProcessor;
		yourself! !

!StSpotterQuery commentStamp: ''!
A query (a search) for Spotter.
A query iterates all defined `relevantProcessors` to retrieve the `results`.
To produce a result, it takes the `searchText` and `process` it.!
!StSpotterQuery methodsFor: 'testing' stamp: ''!
isFinished

	^ finished! !

!StSpotterQuery methodsFor: 'initialization' stamp: ''!
initializeCandidatesList

	candidatesList := StSpotterCandidatesList new.
	candidatesList announcer 
		when: StSpotterCandidateAdded send: #candidateAdded: to: self;
		when: StSpotterAllCandidatesAdded send: #allCandidatesAdded: to: self;
		"when: GTSpotterAllCandidatesRemoved do: [ self deselect ];
		when: StSpotterQueryStarted send: #queryStarted: to: self;"
		when: StSpotterQueryEnded send: #queryEnded: to: self.! !

!StSpotterQuery methodsFor: 'private' stamp: ''!
filteringText
		
	^ self searchText substrings 
		detect: [ :each | each beginsWith: '#' ]
		ifFound: [ :categoryQuery | categoryQuery ]
		ifNone: [ nil ]! !

!StSpotterQuery methodsFor: 'private' stamp: ''!
candidateAdded: ann

	candidateLinks add: ann candidateLink.
	spotterPresenter updateResultList: ann candidateLink
	! !

!StSpotterQuery methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self initializeCandidatesList.
	finished := false.	
	candidateLinks := Set new! !

!StSpotterQuery methodsFor: 'accessing' stamp: ''!
links

	^ candidateLinks! !

!StSpotterQuery methodsFor: 'events' stamp: ''!
queryEnded: aStSpotterQueryEnded 

	spotterPresenter flushPendingUpdates! !

!StSpotterQuery methodsFor: 'processing' stamp: ''!
notifyEnded: aContext

	self announcer announce: StSpotterQueryEnded new! !

!StSpotterQuery methodsFor: 'accessing' stamp: ''!
processors

	^ processors! !

!StSpotterQuery methodsFor: 'accessing' stamp: ''!
processors: aCollection

	processors := aCollection! !

!StSpotterQuery methodsFor: 'accessing' stamp: ''!
searchText: aString

	searchText := aString! !

!StSpotterQuery methodsFor: 'accessing' stamp: ''!
results

	^ self links collect: [ :each | each value ]! !

!StSpotterQuery methodsFor: 'processing' stamp: ''!
notifyStarted: aContext
	
	self announcer announce: StSpotterQueryStarted new! !

!StSpotterQuery methodsFor: 'private' stamp: ''!
allCandidatesAdded: ann
	
	ann candidateLinks ifEmpty: [ ^ self ].
	candidateLinks addAll: ann candidateLinks! !

!StSpotterQuery methodsFor: 'private - factory' stamp: ''!
newStreamFor: candidates

	^ StSpotterStream new
		onAddedSelector: #addCandidate:in:;
		onRemoveSelector: #removeAllCandidatesOf:;
		receiver: candidates;
		yourself! !

!StSpotterQuery methodsFor: 'accessing' stamp: ''!
spotter: aSpotterPresenter

 spotterPresenter := aSpotterPresenter! !

!StSpotterQuery methodsFor: 'accessing' stamp: ''!
candidatesList

	^ candidatesList! !

!StSpotterQuery methodsFor: 'private' stamp: ''!
relevantProcessors

	^ self filteringText
		ifNotNil: [ :aString | self relevantProcessorsFor: aString ]
		ifNil: [ self processors ]! !

!StSpotterQuery methodsFor: 'private - factory' stamp: ''!
newContextFor: aStream text: aString

	^ StSpotterContext new 
		step: self;
		stream: aStream;
		text: aString;
		search: aString;
		yourself! !

!StSpotterQuery methodsFor: 'private' stamp: ''!
relevantProcessorsFor: aString
		
	^ (self processors select: [ :each | each isRelevantForQuery: aString ])! !

!StSpotterQuery methodsFor: 'processing' stamp: ''!
process
	| stream context |

	spotterPresenter startNewProcess.

	finished := false.
	stream := self newStreamFor: candidatesList.
	context := self newContextFor: stream text: self searchText.
	self notifyStarted: context.
	self relevantProcessors
		do: [ :each | each filterInContext: context ].
	finished := true.
	self notifyEnded: context.

	self candidatesList isEmpty 
		ifTrue: [ spotterPresenter removeAllResults ]! !

!StSpotterQuery methodsFor: 'accessing' stamp: ''!
searchText

	^ searchText! !

!StSpotterQuery methodsFor: 'accessing' stamp: ''!
announcer

	^ self candidatesList announcer! !

!StSpotterQuery methodsFor: 'accessing' stamp: ''!
terminate

	self processors do: [ :each | each stop ]! !

!StSpotterQuery class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Use #newSearch:on:'! !

!StSpotterQuery class methodsFor: 'instance creation' stamp: ''!
on: aString

	^ self basicNew 
		initializeText: aString; 
		yourself! !

!StSpotterQuery class methodsFor: 'instance creation' stamp: ''!
newSearch: aString on: spotter

	^ super new 
		spotter: spotter;
		searchText: aString;
		yourself! !

!StSpotterQueryEnded commentStamp: ''!
Announce a query ended its execution.!
!StSpotterQueryStarted commentStamp: ''!
Announce a query started.!
!StSpotterStep commentStamp: ''!
A spotter search has a scope that is composed by its main search, but to dive into categories is also possible. 
A step encapsulates this scope, making it possible.

So, in the processing search scheme of things: 

a model (`StSpotterModel`) has a step (`StSpotterStep`) which receives a query (`StSpotterQuery`) which is the one performing the actual search.!
!StSpotterStep methodsFor: 'accessing' stamp: ''!
lastSearchText

	^ self activeQuery searchText! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
links

	^ activeQuery 
		ifNotNil: [ :aQuery | aQuery links ]
		ifNil: [ #() ]! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
previousProcessorFrom: aCollection

	aCollection do: [ :each | 
		" we assume they are all identical "
		each asStSpotterCandidateLink processor ifNotNil: [ ^ each processor ] ]. 
	
	^ StSpotterCandidatesListProcessor new
		title: 'Items';
		filter: StFilterSubstring;
		yourself! !

!StSpotterStep methodsFor: 'accessing - query' stamp: ''!
pushQuery: aQuery

	self deactivate.
	
	aQuery processors: (self processors sort: #order ascending).
	self activateQuery: aQuery.
	aQuery process! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
processors: aCollection

	processors := aCollection! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
processors

	^ processors ifNil: [ 
		processors := OrderedCollection new.
		self origin stSpotterProcessorsFor: self.
		processors ]! !

!StSpotterStep methodsFor: 'private' stamp: ''!
activateQuery: aQuery

	activeQuery ifNotNil: [ self disconnectQuery: aQuery ].
	activeQuery := aQuery.
	self connectQuery: aQuery.
	self refreshQueryStatus: aQuery! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
results

	^ activeQuery 
		ifNotNil: [ :aQuery | aQuery results ]
		ifNil: [ #() ]! !

!StSpotterStep methodsFor: 'factory' stamp: ''!
listProcessor
	| processor |
	
	processor := StSpotterCandidatesListProcessor new.
	self addProcessor: processor.
	
	^ processor! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
origin

	^ origin! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
origin: anObject

	origin := anObject! !

!StSpotterStep methodsFor: 'private' stamp: ''!
disconnectQuery: aQuery

	aQuery announcer unsubscribe: self model! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
candidatesList

	^ activeQuery 
		ifNotNil: [ :aQuery | aQuery candidatesList ]
		ifNil: [ #() ]! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
addProcessor: processor
	
	processors add: processor! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
activeQuery

	^ activeQuery! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
model: aSpotterModel

	model := aSpotterModel! !

!StSpotterStep methodsFor: 'private' stamp: ''!
refreshQueryStatus: aQuery

	aQuery links ifEmpty: [ ^ self ].

	self model announceAllCandidatesAdded: (StSpotterAllCandidatesAdded new
		candidateLinks: aQuery links;
		yourself).

	aQuery isFinished ifTrue: [ 
		self model announceAmountChanged: (StSpotterCandidatesAmountChanged new 
			amount: aQuery links size;
			yourself) ]! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
activate

	activeQuery ifNil: [ ^ self ].
	self activateQuery: activeQuery! !

!StSpotterStep methodsFor: 'private' stamp: ''!
connectQuery: aQuery

	aQuery announcer
		when: StSpotterCandidateAdded send: #announceCandidateAdded: to: self model;
		when: StSpotterAllCandidatesAdded send: #announceAllCandidatesAdded: to: self model;
		when: StSpotterCandidatesAmountChanged send: #announceAmountChanged: to: self model;
		when: StSpotterQueryStarted send: #announceQueryStarted: to: self model;
		when: StSpotterQueryEnded send: #announceQueryEnded: to: self model.! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!StSpotterStep methodsFor: 'accessing' stamp: ''!
deactivate

	self activeQuery ifNil: [ ^ self ].

	self activeQuery terminate.
	self disconnectQuery: self activeQuery.
! !

!StSpotterStep class methodsFor: 'instance creation' stamp: ''!
on: aSpotterModel

	^ self new 
		model: aSpotterModel;
		yourself! !

!StSpotterStream commentStamp: ''!
A place to store the results of a `StSpotterQuery` and to send notifications about it.!
!StSpotterStream methodsFor: 'updating' stamp: ''!
updateTimestamp

	self timestamp: Time microsecondClockValue! !

!StSpotterStream methodsFor: 'accessing' stamp: ''!
onRemoveSelector

	^ onRemoveSelector! !

!StSpotterStream methodsFor: 'accessing' stamp: ''!
timestamp: anObject
	timestamp := anObject! !

!StSpotterStream methodsFor: 'accessing' stamp: ''!
receiver
	^ receiver! !

!StSpotterStream methodsFor: 'performing' stamp: ''!
performSymbol: aSymbol withArguments: aCollection
	| time |

	"we save current timestamp here, so that defer block can check if it belongs to the correct task"
	time := self timestamp.
	"UI manages commands for us"
	Processor yield.
	"if timestamp is wrong just skip command"
	time = self timestamp ifTrue: [ 
		self receiver perform: aSymbol withEnoughArguments: aCollection ]! !

!StSpotterStream methodsFor: 'adding/removing' stamp: ''!
addObject: firstObject inProcessor: secondObject

	self 
		performSymbol: self onAddedSelector 
		withArguments: { firstObject. secondObject }.
	Processor yield! !

!StSpotterStream methodsFor: 'accessing' stamp: ''!
onAddedSelector

	^ onAddedSelector! !

!StSpotterStream methodsFor: 'accessing' stamp: ''!
onAddedSelector: anObject

	onAddedSelector := anObject! !

!StSpotterStream methodsFor: 'accessing' stamp: ''!
receiver: anObject
	receiver := anObject! !

!StSpotterStream methodsFor: 'adding/removing' stamp: ''!
removeAllCandidates

	self 
		performSymbol: #removeAllCandidates 
		withArguments: { }.
	Processor yield! !

!StSpotterStream methodsFor: 'accessing' stamp: ''!
timestamp
	^ timestamp! !

!StSpotterStream methodsFor: 'accessing' stamp: ''!
onRemoveSelector: anObject

	onRemoveSelector := anObject! !

!StSpotterStream methodsFor: 'adding/removing' stamp: ''!
addObjects: aCollection inProcessor: aProcessor

	self 
		performSymbol: #addAllCandidates:in: 
		withArguments: { aCollection . aProcessor }.
	Processor yield! !

!StSpotterStyleContributor methodsFor: 'styles' stamp: ''!
styleSheetContribution
	
	^ SpStyle newApplication 
		addClass: 'stSpotter' with: [ :spotterClass | spotterClass 
			addPropertyContainerWith: [ :c | c borderColor: Smalltalk ui theme backgroundColor ];
			addPropertyDrawWith: [ :draw | draw backgroundColor: Smalltalk ui theme backgroundColor ] ];
		addClass: 'stSpotterHeader' with: [ :spotterLinkClass | spotterLinkClass 
			addPropertyGeometryWith: [ :geometry | geometry height: 30; vResizing: false ] ]; 
		addClass: 'stSpotterLink' with: [ :spotterLinkClass | spotterLinkClass 
			addPropertyGeometryWith: [ :geometry | geometry height: 25; vResizing: false ] ];
		addClass: 'componentList' with: [ :componentList | componentList 
			addClass: 'stSpotterList' with: [ :spotter | spotter 
				addPropertyDrawWith: [ :draw | draw color: Color transparent ] ] ];
		addClass: 'searchInputField' with: [ :class | class 
			addClass: 'stSpotterSearch' with: [ :spotterClass | spotterClass
				addPropertyDrawWith: [ :draw | draw color: Color transparent ];
				addPropertyTextWith: [ :text | text drawKeyboardFocus: false ];
				addPropertyGeometryWith: [ :geometry | geometry minHeight: 35; vResizing: false ];
				addPropertyFontWith: [ :font | font size: (StandardFonts defaultFont pointSize * 1.2) asInteger ] ] ];
		addClass: 'text' with: [ :class | class 
			addClass: 'stSpotterPreview' with: [ :spotter | spotter
				addPropertyDrawWith: [ :draw | draw color: Color transparent ] ] ];
		addClass: 'code' with: [ :class | class 
			addClass: 'stSpotterPreview' with: [ :spotterClass | spotterClass
				addPropertyDrawWith: [ :draw | draw color: Color transparent ] ] ];
		yourself! !

!StSpotterTest methodsFor: 'tests' stamp: ''!
testSearchingString

	spotter searchText text: 'Test'.
	self assert: spotter searchingString equals: 'Test'.
	
	spotter searchText text: '#Classes Test'.
	self assert: spotter searchingString equals: 'Test'.
	
	spotter searchText text: '#Classes #Implementors Test'.
	self assert: spotter searchingString equals: 'Test'.
	
	spotter searchText text: '#Classes Test #Implementors'.
	self assert: spotter searchingString equals: 'Test'.
	
	spotter searchText text: '#Classes Test a thing #Implementors'.
	self assert: spotter searchingString equals: 'Test a thing'.! !

!StSpotterTest methodsFor: 'tests' stamp: ''!
testOpenSpotterRefreshesPreviewOnce
	| count |
	
	"I need to skip it because this CI seems to not run it properly"
	self skipOnPharoCITestingEnvironment.
	
	count := 0.
	spotter previewContainer 
		whenChildrenAddedDo: [ :ann | count := count + 1 ].
	
	spotter openWithSpec.
	spotter updateSearch: 'Obj'.
	self waitUntilEnded: spotter model.
	20 timesRepeat: [ self waitUntilUIRedrawed ].
	spotter window close.
	
	self assert: count equals: 1! !

!StSpotterTest methodsFor: 'running' stamp: ''!
setUp
	
	super setUp.
	spotter := StSpotter new! !

!StStepIntoCommand commentStamp: ''!
Requests the debugger to step into the next expression evaluation!
!StStepIntoCommand methodsFor: 'hooks' stamp: ''!
execute
	self debugger stepInto! !

!StStepIntoCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ PharoShortcuts current stepIntoShortcut! !

!StStepIntoCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ #debuggerStepInto! !

!StStepIntoCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Step in the highlighted message, i.e. follow the sent message, taking debugger control in the method invoked.'! !

!StStepIntoCommand class methodsFor: 'default' stamp: ''!
defaultName
	<toolbarDebugCommand: 20>
	
	^ 'Into'! !

!StStepOverCommand commentStamp: ''!
Requests the debugger to step over the next expression evaluation!
!StStepOverCommand methodsFor: 'hooks' stamp: ''!
execute
	self debugger stepOver! !

!StStepOverCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ PharoShortcuts current stepOverShortcut! !

!StStepOverCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ #debuggerStepOver! !

!StStepOverCommand class methodsFor: 'accessing' stamp: ''!
defaultDescription
	^'Step over the highlighted message, i.e. do not follow the sent message, taking debugger control after the method invoked returns.'! !

!StStepOverCommand class methodsFor: 'accessing' stamp: ''!
defaultName
	<toolbarDebugCommand: 40>

	^ 'Over'! !

!StStepThroughCommand commentStamp: ''!
Requests the debugger to step over the next expression evaluation!
!StStepThroughCommand methodsFor: 'hooks' stamp: ''!
execute
	self debugger stepThrough! !

!StStepThroughCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ PharoShortcuts current stepThroughShortcut! !

!StStepThroughCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ #debuggerStepThrough ! !

!StStepThroughCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Step over the highlighted message, i.e. do not follow the sent message, taking debugger control after the method invoked returns or whenever execution should return inside a block used as an argument before that.'! !

!StStepThroughCommand class methodsFor: 'default' stamp: ''!
defaultName
	<toolbarDebugCommand: 30>

	^ 'Through'! !

!StStringFilter commentStamp: ''!
A string based filter.!
!StStringFilter methodsFor: 'private' stamp: ''!
prepareFilterInContext: aSpotterContext
	super prepareFilterInContext: aSpotterContext.
	
	caseSensitive ifNil: [ caseSensitive := self defaultCaseSensitive ]. " performance optimization "
	self query: (caseSensitive " performance optimization "
		ifTrue: [ self context textTrimmed ]
		ifFalse: [ self context textLowercase ])! !

!StStringFilter methodsFor: 'private' stamp: ''!
doApplyFilterWithQuery

	self subclassResponsibility ! !

!StStringFilter methodsFor: 'private' stamp: ''!
applyFilterWithQuery

	[ self doApplyFilterWithQuery ]
		on: StLimitArrived do: [ ^ self ]! !

!StStringFilter methodsFor: 'accessing' stamp: ''!
query
	^ query! !

!StStringFilter methodsFor: 'accessing' stamp: ''!
query: anObject
	query := anObject! !

!StStringFilter methodsFor: 'testing' stamp: ''!
hasQuery
	^ self query isEmptyOrNil not! !

!StStringFilter methodsFor: 'private' stamp: ''!
applyFilterWithoutQuery
	" WARNING: this is not a copy of GTNullFilter>>#applyFilterWithoutQuery !!!!!! "

	[ self streamed 
		ifTrue: [
			" this will be more responsive (faster) for very large collections and/or expensive filters "
			| reducedItems |
			self filteredItems: (reducedItems := OrderedCollection new).
			self allItems withIndexDo: [ :each :index |
				reducedItems add: each.
				self addItem: each.
				index = self itemsLimit ifTrue: [ StLimitArrived signal ] ] ]
		ifFalse: [
			" this will be much much faster for small collections and/or very quick filters " 
			self filteredItems: (self allItems first: (self itemsLimit min: self allItems size)).
			self addItems: self filteredItems ]] on: StLimitArrived do: [ ^ self ]! !

!StStringFilter methodsFor: 'private' stamp: ''!
applyFilter
	self hasQuery ifFalse: [ 
		self applyFilterWithoutQuery.
		^ self allItems. " return the unfiltered items (all) - used for divein (no filtering appied) "  ].
	self applyFilterWithQuery.
	^ self filteredItems " return the filtered items only "! !

!StStringFilter methodsFor: 'accessing' stamp: ''!
caseSensitive
	^ caseSensitive! !

!StStringFilter methodsFor: 'accessing - defaults' stamp: ''!
defaultCaseSensitive
	^ false! !

!StStringFilter methodsFor: 'accessing' stamp: ''!
caseSensitive: anObject
	caseSensitive := anObject! !

!StSubStringFilter commentStamp: ''!
I implement a simple substring string filter using includesSubstring:.!
!StSubStringFilter methodsFor: 'protected' stamp: ''!
criterium: aValue

	^ aValue asString asLowercase includesSubstring: filteringText asLowercase

! !

!StSubStringFilter methodsFor: 'filtering' stamp: ''!
substringFilter: aString
	
	self filteringText: aString! !

!StSystemReporter commentStamp: ''!
I'm a little tool that display information about the system.

```
StSystemReporter new openWithSpec.
StSystemReporter open
```

!
!StSystemReporter methodsFor: 'building report' stamp: ''!
reportVMStats: aStream
	self header: 'Virtual Machine Statistics' on: aStream.
	aStream
		nextPutAll: Smalltalk vm statisticsReport! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportLinuxOSDetails: aStream
	self header: 'Operating System Details' on: aStream.
	#(
		'/etc/issue'
		'/etc/lsb-release'
		'/proc/version'
	) do: [:path|
		self readContentsSafelyFromFile: path andWriteTo: aStream]! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportWin32GFXDetails: aStream
	self header: 'Graphics Hardware Details' on: aStream.
	aStream nextPutAll: (Smalltalk vm getSystemAttribute: 10003)! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportWin32VMConfig: aStream
	| exePath iniPath |
	self header: 'VM Configuration' on: aStream.
	exePath := Smalltalk vm vmFileName.
	iniPath := (exePath copyUpToLast: $.), '.ini'.
	aStream nextPutAll: iniPath; cr; cr.
	self readContentsSafelyFromFile: iniPath andWriteTo: aStream
! !

!StSystemReporter methodsFor: 'utils' stamp: ''!
title 
	^ 'System Reporter'! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportWin32HardwareDetails: aStream
	self header: 'Hardware Details' on: aStream.
	aStream nextPutAll: (Smalltalk vm getSystemAttribute: 10001)! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportModules: aStream

	self header: 'Loaded VM Modules' on: aStream.
	Smalltalk vm listLoadedModules asSortedCollection do: [:each | aStream nextPutAll: each; cr].
	aStream cr.
	self header: 'VM Built-in Modules' on: aStream.
	Smalltalk vm listBuiltinModules asSortedCollection do: [:each | aStream nextPutAll: each; cr]

! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportVMOptions: aStream
	self header: 'Virtual Machine Commandline Options' on: aStream.
	self enumerate: [:idx | Smalltalk vm optionAt: idx] startAt: 1 on: aStream! !

!StSystemReporter methodsFor: 'utils' stamp: ''!
isWindows

	^Smalltalk os isWindows! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportOS: aStream
	self header: 'Operating System/Hardware' on: aStream.
	aStream
		nextPutAll: Smalltalk os platformName; space;
		nextPutAll: Smalltalk os version; space;
		nextPutAll: Smalltalk os subtype; cr
! !

!StSystemReporter methodsFor: 'initialization' stamp: ''!
topicSpec
	
	topics addAll:  {
		(#Image -> #reportImage:) .
		(#'Image Parameters' -> #reportImageParameters:).
		(#'Image Sources' -> #reportSources:).
		(#'MC Repositories' -> #reportRepositories:).
		(#'MC Working Copies' -> #reportWorkingCopies:).
		(#'VM General' -> #reportVM:).
		(#'VM Options' -> #reportVMOptions:).
		(#'VM Modules' -> #reportModules:).
		(#'VM Parameters' -> #reportVMParameters:).
		(#'VM Stats' -> #reportVMStats:).
		(#OS -> #reportOS:).
		(#'OS Environment' -> #reportOSEnvironment:).
		}.
		
	self isWindows
		ifTrue: [ topics addAll: {
			(#'OS Details' -> #reportWin32OSDetails:).
			(#'VM Configuration' -> #reportWin32VMConfig:).
			(#'Hardware Details' -> #reportWin32HardwareDetails:).
			(#'GFX Hardware Details' -> #reportWin32GFXDetails:).	
			} ].	
		
	self isLinux 
		ifTrue: [ topics add: #'OS Details' -> #reportLinuxOSDetails: ].
	^ topics! !

!StSystemReporter methodsFor: 'utils' stamp: ''!
extent

	^ 500@ 600! !

!StSystemReporter methodsFor: 'initialization' stamp: ''!
fillTopics 
	
	 {
		(#Image -> #reportImage:) .
		(#'Image Parameters' -> #reportImageParameters:).
		(#'Image Sources' -> #reportSources:).
		(#'VM General' -> #reportVM:).
		(#'VM Options' -> #reportVMOptions:).
		(#'VM Modules' -> #reportModules:).
		(#'VM Parameters' -> #reportVMParameters:).
		(#'VM Stats' -> #reportVMStats:).
		(#OS -> #reportOS:).
		(#'OS Environment' -> #reportOSEnvironment:).
		} do: [ :each | self addTopicSpec: each ].
		
	self isWindows
		ifTrue: [ 
			{ (#'OS Details' -> #reportWin32OSDetails:).
			(#'VM Configuration' -> #reportWin32VMConfig:).
			(#'Hardware Details' -> #reportWin32HardwareDetails:).
			(#'GFX Hardware Details' -> #reportWin32GFXDetails:).	
			} do: [ :each | self addTopicSpec: each ]. 
			].	
		
	self isLinux 
		ifTrue: [ self addTopicSpec: #'OS Details' -> #reportLinuxOSDetails: ].
	^ topics! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportWin32OSDetails: aStream
	self header: 'Operating System Details' on: aStream.
	aStream nextPutAll: (Smalltalk vm getSystemAttribute: 10002)! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportVM: aStream
	self header: 'Virtual Machine' on: aStream.
	aStream
		nextPutAll: Smalltalk vm vmFileName;
		cr;
		nextPutAll: Smalltalk vm version;
		cr.
	Smalltalk vm buildDate
		ifNotNil: [ :string | 
			aStream
				nextPutAll: string;
				cr ].
	[ 
	Smalltalk vm platformSourceVersion
		ifNotNil: [ :v | 
			aStream
				nextPutAll: 'platform sources revision ';
				nextPutAll: v;
				cr ] ]
		on: Warning
		do: [ 
			"unsupported primitive"
			 ].
	[ 
	Smalltalk vm interpreterSourceVersion
		ifNotNil: [ :v | 
			aStream
				nextPutAll: 'VMMaker versionString ';
				nextPutAll: v;
				cr ] ]
		on: Warning
		do: [ 
			"unsupported primitive"
			 ].
	[ 
	Smalltalk vm interpreterClass
		ifNotNil: [ :string | 
			aStream
				nextPutAll: string;
				cr ].
	Smalltalk vm cogitClass
		ifNotNil: [ :string | 
			aStream
				nextPutAll: string;
				cr ] ]
		on: Error
		do: [ 
			"unsupported primitives"
			 ]! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportImageParameters: aStream
	self header: 'Image Commandline Parameters' on: aStream.
	self enumerate: [:idx | Smalltalk image argumentAt: idx] on: aStream! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
readContentsSafelyFromFile: osPath andWriteTo: aStream
	 [ osPath asFileReference readStreamDo: [:s | aStream nextPutAll: s contents ]
    ] on: Error do: [:ex| ex return: ex printString]! !

!StSystemReporter methodsFor: 'utils' stamp: ''!
isLinux
	
	^Smalltalk os isLinux! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportImage: aStream
	self header: 'Image' on: aStream.
	aStream 
		nextPutAll: Smalltalk image imagePath; cr;
		nextPutAll: SystemVersion current version; cr;
		nextPutAll: Smalltalk image lastUpdateString; cr;
		nextPutAll: ChangeSet current name; cr
! !

!StSystemReporter methodsFor: 'initialization' stamp: ''!
connectPresenters 

	super connectPresenters.
	topicList  selectIndex: 1.! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportSources: aStream
	self header: 'Image Sources' on: aStream.
	aStream nextPutAll: SourceFiles class printString; cr.
	aStream nextPutAll: SourceFiles reportString.! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportVMParameters: aStream
	| vmParameters |
	self header: 'Virtual Machine Parameters' on: aStream.
	vmParameters := Smalltalk vm getParameters.
	#(
		1 'end (v3)/size(Spur) of old-space (0-based, read-only)'
		2 'end (v3)/size(Spur) of young/new-space (read-only)'
		3 'end (v3)/size(Spur) of heap (read-only)'
		4 'nil (was allocationCount (read-only))'
		5 'nil (was allocations between GCs (read-write)'
		6 'survivor count tenuring threshold (read-write)'
		7 'full GCs since startup (read-only)'
		8 'total milliseconds in full GCs since startup (read-only)'
		9 'incremental GCs (SqueakV3) or scavenges (Spur) since startup (read-only)'
		10 'total milliseconds in incremental GCs (SqueakV3) or scavenges (Spur) since startup (read-only)'
		11 'tenures of surving objects since startup (read-only)'
		12 '12-20 were specific to ikp''s JITTER VM, now 12-19 are open for use'
		13 '12-20 were specific to ikp''s JITTER VM, now 12-19 are open for use'
		14 '12-20 were specific to ikp''s JITTER VM, now 12-19 are open for use'
		15 '12-20 were specific to ikp''s JITTER VM, now 12-19 are open for use'
		16 '12-20 were specific to ikp''s JITTER VM, now 12-19 are open for use'
		17 '12-20 were specific to ikp''s JITTER VM, now 12-19 are open for use'
		18 '12-20 were specific to ikp''s JITTER VM, now 12-19 are open for use'
		19 '12-20 were specific to ikp''s JITTER VM, now 12-19 are open for use'
		20	'utc microseconds at VM start-up (actually at time initialization, which precedes image load).'
		21	'root table size (read-only)'
		22	'root table overflows since startup (read-only)'
		23	'bytes of extra memory to reserve for VM buffers, plugins, etc (stored in image file header).'
		24	'memory threshold above which shrinking object memory (rw)'
		25	'memory headroom when growing object memory (rw)'
		26	'interruptChecksEveryNms - force an ioProcessEvents every N milliseconds	(rw) 27	number of times mark loop iterated for current IGC/FGC (read-only)	includes ALL marking'
		28	'number of times sweep loop iterated for current IGC/FGC (read-only)'
		29	'number of times make forward loop iterated for current IGC/FGC	(read-only) 30	number of times compact move loop iterated for current	IGC/FGC (read-only)'
		31	'number of grow memory requests (read-only)'
		32	'number of shrink memory requests (read-only)'
		33	'number of root table entries used for current IGC/FGC (read-only)'
		34	'number of allocations done before current IGC/FGC (read-only)'
		35	'number of survivor objects after current IGC/FGC (read-only)'
		36	'millisecond clock when current IGC/FGC completed (read-only)'
		37	'number of marked objects for Roots of the world, not including Root	Table entries for current IGC/FGC (read-only)'
		38	'milliseconds taken by current IGC (read-only)'
		39	'Number of finalization signals for Weak Objects pending when current	IGC/FGC completed (read-only)'
		40	'BytesPerOop for this image'
		41	'imageFormatVersion for the VM'
		42	'number of stack pages in use'
		43	'desired number of stack pages (stored in image file header, max 65535)'
		44	'size of eden, in bytes'
		45	'desired size of eden, in bytes (stored in image file header)'
		46	'machine code zone size, in bytes (Cog only; otherwise nil)'
		47	'desired machine code zone size (stored in image file header; Cog only;	otherwise nil)'
		48	'various header flags. See getCogVMFlags.'
		49	'max size the image promises to grow the external semaphore table to (0	sets to default, which is 256 as of writing)'
		50	'nil; reserved for VM parameters that persist in the image (such as	eden above)'
		51 	'nil; reserved for VM parameters that persist in the image (such as	eden above)'
		52	'root table capacity'
		53	'number of segments (Spur only; otherwise nil)'
		54	'total size of free old space (Spur only, otherwise nil)'
		55	'ratio of growth and image size at or above which a GC will be performed	post scavenge'
		56	'number of process switches since startup (read-only)'
		57	'number of ioProcessEvents calls since startup (read-only)'
		58	'number of ForceInterruptCheck calls since startup (read-only)'
		59	'number of check event calls since startup (read-only)'
		60	'number of stack page overflows since startup (read-only)'
		61	'number of stack page divorces since startup (read-only)	62	compiled code compactions since startup (read-only; Cog only; otherwise nil)'
		63	'total milliseconds in compiled code compactions since startup	(read-only; Cog only; otherwise nil)'
		64	'the number of methods that currently have jitted machine-code'
		65	'whether the VM supports a certain feature, MULTIPLE_BYTECODE_SETS is bit 0, IMMTABILITY is bit 1'
		66	'the byte size of a stack page'
		67	'the max allowed size of old space (Spur only; nil otherwise; 0 implies	no limit except that of the underlying platform)'
		68	'the average number of live stack pages when scanned by GC (at	scavenge/gc/become et al)'
		69	'the maximum number of live stack pages when scanned by GC (at	scavenge/gc/become et al)'
		70	'the vmProxyMajorVersion (the interpreterProxy VM_MAJOR_VERSION)'
		71	'the vmProxyMinorVersion (the interpreterProxy VM_MINOR_VERSION)')
			 pairsDo: [:idx :desc |
		aStream
			nextPut: $#;
			nextPutAll: idx printString;
			tab;
			nextPutAll: (vmParameters at: idx) printString;
			tab;
			nextPutAll: desc;
			cr]! !

!StSystemReporter methodsFor: 'building report' stamp: ''!
reportOSEnvironment: aStream
	| env |
	self header: 'Operating System Environment' on: aStream.
	env := [ Smalltalk os environment] on: Error do: [ ^self ].
	env keys asSortedCollection do: [:name |
		aStream nextPutAll: name; nextPut: $=; nextPutAll: (env at: name); cr ]! !

!StSystemReporter class methodsFor: 'system menu' stamp: ''!
systemReporterMenuOn: aBuilder 
	<worldMenu>
	
	(aBuilder item: #'System Reporter')
		parent: #SystemTools;
		action: [ self open ];
		order: 1;
		help: 'If you have a bug, use this tool to provide information about your system.'! !

!StTestDebuggerProvider commentStamp: ''!
Utilitary class to provide various kind of debuggers, interrupted context and debug sessions for testing purposes!
!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
produceShouldntRaiseFailure
	TestCase new shouldnt: [ 1/0 ] raise: ZeroDivide! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
terminate 
	session ifNotNil:[session clear].
	session := nil! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
intermediateRecursiveMethodCall

	"Dummy assignment to avoid the test session to step to the next interesting bytecode (= next return)"

	| a |
	a := 0.
	^ self recursiveMethodCall! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithRecursiveContext

	| debugger |
	debugger := self debuggerWithContext:
		            [ self recursiveMethodCall ] asContext.

	^ debugger! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
newDebugger

	| debugger |
	debugger := StDebugger basicNew.
	debugger session: session.
	debugger debuggerActionModel updateContextPredicate.
	^ debugger! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithFailingAssertionContext
	[ self produceAssertionFailure ]
		on: TestFailure
		do: [ :err | 
			self sessionFor: err signalerContext exception: err.
			^ self newDebugger ]! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithMissingSubclassResponsibilityContext
	[ StDummyDebuggerPresenter new unimplementedSubclassResponsibility ]
		on: SubclassResponsibility
		do: [ :err | 			
			self sessionFor: err signalerContext exception: err.
			^ self newDebugger ]! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
methodProducingDNU

	^ self foobar! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
session

	^ session! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
sessionFor: aContext

	| process |
	process := Process
		           forContext: aContext
		           priority: Processor userInterruptPriority.
	session := DebugSession
		           named: 'test session'
		           on: process
		           startedAt: aContext.
	session exception ifNil: [ session exception: OupsNullException new ]! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
sessionForDebuggerTests

	| context process sessionForTests |
	context := [ 
	           | i |
	           i := 1 squared.
	           i = 1 ifTrue: [ 
		           | j |
		           j := i + 1 ].
	           ^ 1 + i ] asContext.
	process := Process
		           forContext: context
		           priority: Processor userInterruptPriority.
	sessionForTests := DebugSession
		                   named: 'test session'
		                   on: process
		                   startedAt: context.
	sessionForTests exception: (OupsNullException fromSignallerContext: context).
	^ sessionForTests! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithMissingClassContext
	"The called method must contain a undeclared variable (the missing class).
	It makes the CI test fail, so it has to be generated and removed after usage.
	buildDebuggerWithMissingClassContext has to be generated when starting a test (see class side for generation) and removed in the test's tearDown."
	^ self buildDebuggerWithMissingClassContext! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithObjectHalting
	[ StDebuggerObjectForTests new haltingMethod ]
		on: Halt
		do: [ :err | 
			self sessionFor: err signalerContext exception: err.
			^ self newDebugger ]! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithErrorContext

	[ #(  ) at: 1 ]
		on: Error
		do: [ :err | 
			self sessionFor: err signalerContext exception: err.
			^ self newDebugger ]! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
produceTestFailure
	TestCase new fail! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithContext: aContext
	self sessionFor: aContext.
	^ self newDebugger! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithRunnableContext
<haltOrBreakpointForTesting>
	[ Halt now ]
		on: Halt
		do: [ :err | 
			self sessionFor: err signalerContext exception: err.
			^ self newDebugger ]! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithFailingShouldntRaiseContext
	[ self produceShouldntRaiseFailure ]
		on: TestFailure
		do: [ :err | 
			self sessionFor: err signalerContext exception: err.
			^ self newDebugger ]! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
sessionFor: aContext exception: e

	e freezeUpTo: nil.
	self sessionFor: e signalerContext.
	session exception: e! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
sessionWithDNUAfterStep

	| context process sessionForTests |
	context := [ ^ self methodProducingDNU ] asContext.
	process := Process
		           forContext: context
		           priority: Processor userInterruptPriority.
	sessionForTests := DebugSession
		                   named: 'test session'
		                   on: process
		                   startedAt: context.
	sessionForTests exception: (OupsNullException fromSignallerContext: context).
	^ sessionForTests! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
recursiveMethodCall

	"Dummy assignment to avoid the test session to step to the next interesting bytecode (= next return)"

	| a |
	a := 0.
	^ self intermediateRecursiveMethodCall! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithDNUContext
	[ self methodProducingDNU ]
		on: Error
		do: [ :err | 
			self sessionFor: err signalerContext exception: err.					
			^ self newDebugger ]! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
produceAssertionFailure
	TestCase new assert: 4 equals: 2! !

!StTestDebuggerProvider methodsFor: 'helpers' stamp: ''!
debuggerWithFailingTestContext
	[ self produceTestFailure ]
		on: TestFailure
		do: [ :err | 
			self sessionFor: err signalerContext exception: err.
			^ self newDebugger ]! !

!StTestDebuggerProvider class methodsFor: 'helpers' stamp: ''!
compileMissingClassContextBuilder
	
	self compile: 'buildDebuggerWithMissingClassContext
	
	[ MissingClass new ]
		on: Error
		do: [ :err | 			
			self sessionFor: err signalerContext copy exception: err.
			^ self newDebugger ]'! !

!StToggleBindingCommand commentStamp: ''!
Toggle the scope of a variable (shared or local)!
!StToggleBindingCommand methodsFor: 'executing' stamp: ''!
execute
	
	context toggleSelectedBindingScope! !

!StToggleBindingCommand methodsFor: 'accessing' stamp: ''!
name

	context ifNil: [ ^ super name ].

	^ context selectedBindingIsLocal
		ifTrue: [ self class moveToSharedName ]
		ifFalse: [ self class moveToLocalName ]! !

!StToggleBindingCommand class methodsFor: 'accessing' stamp: ''!
moveToLocalName

	^ 'Make binding local'! !

!StToggleBindingCommand class methodsFor: 'accessing' stamp: ''!
moveToSharedName

	^ 'Make binding shared'! !

!StToggleBindingCommand class methodsFor: 'default' stamp: ''!
defaultDescription

	^ 'Switch binding scope from local to shared and viceversa.'! !

!StToggleBindingCommand class methodsFor: 'default' stamp: ''!
defaultName

	^ 'Move to shared/local scope'! !

!StTopicBuilderVisitor commentStamp: ''!
When I visit a header I create a `StNodeHelpTopic`.
When I visit anything node I add the node at the last `StNodeHelpTopic` create.!
!StTopicBuilderVisitor methodsFor: 'internals' stamp: ''!
propagateNode: aNode from: aTopic
	aTopic owner ifNotNil: [ 
		aTopic owner addNode: aNode.
		self propagateNode: aNode from: aTopic owner ]
	
	
	
	! !

!StTopicBuilderVisitor methodsFor: 'initialization' stamp: ''!
initialize 
	
	super initialize.
	helpTopics := StNodeHelpTopic new.
	actualTopic := helpTopics! !

!StTopicBuilderVisitor methodsFor: 'accessing' stamp: ''!
helpTopics
	^ helpTopics! !

!StTopicBuilderVisitor methodsFor: 'visiting-document' stamp: ''!
visitHeader: aHeader

	aHeader level < 3 ifTrue:[
		| topic |
		topic := self helpTopicClass named: aHeader header capitalized.
		actualTopic := topic.
		helpTopics addSubtopic: topic with: aHeader level ]! !

!StTopicBuilderVisitor methodsFor: 'visiting-document' stamp: ''!
visitAll: aCollection

	aCollection do: [ :each |
		each accept: self.
		actualTopic addNode: each.
		self propagateNode: each from: actualTopic ].
	^ helpTopics
	
	! !

!StTopicBuilderVisitor methodsFor: 'visiting-document' stamp: ''!
helpTopicClass

	^ StNodeHelpTopic! !

!StTopicBuilderVisitor methodsFor: 'visiting-document' stamp: ''!
visit: anObject
	"The normal case is to have
	
	#header 
		ljklj
		jlkklk
		jlkl
		
	#header 2
		fgddfg	
		gjhgj
		
	Now it may be the case where we have some text before a header and we should not lose it. 
	"
	
	self visitAll: anObject children.
	
	! !

!StTopicBuilderVisitorTest methodsFor: 'tests' stamp: ''!
testTopicBuilderVisitorWithOneSection

	| file text |
	text := '
blabla
blabla
'.
	(file := filesystem workingDirectory / self class spFileName) 
		writeStreamDo: [ :stream | 
		stream nextPutAll: self class spFileContentsOneSection ].
	self visitFile: file.
	self assert: (visitor helpTopics subtopics first) title equals: 'Section 1'.
	self assert: visitor helpTopics subtopics size equals: 1! !

!StTopicBuilderVisitorTest methodsFor: 'tests' stamp: ''!
testTopicBuilderVisitorWithLevelsSections

	| file topics |
	(file := filesystem workingDirectory / self class spFileName) 
		writeStreamDo: [ :stream | 
		stream nextPutAll: self class spFileContentsLevelsSections ].
	self visitFile: file.
	topics := visitor helpTopics subtopics.
	self assert: topics first title equals: 'Section 1'.
	self assert: topics first subtopics first title equals: 'Section 2'.! !

!StTopicBuilderVisitorTest methodsFor: 'tests' stamp: ''!
testTopicBuilderVisitorWithMoreSections

	| file |
	(file := filesystem workingDirectory / self class spFileName) 
		writeStreamDo: [ :stream | 
		stream nextPutAll: self class spFileContentsMoreSections ].
	self visitFile: file.
	self assert: (visitor helpTopics subtopics second) title equals: 'Section 2'.
	self assert: visitor helpTopics subtopics size equals: 2! !

!StTopicBuilderVisitorTest methodsFor: 'tests' stamp: ''!
testTopicBuilderVisitorWithMoreSubSection

	| file |
	(file := filesystem workingDirectory / self class spFileName) 
		writeStreamDo: [ :stream | 
			stream nextPutAll: self class spFileContentsWithMoreSubSection ].
	self visitFile: file.
	self
		assert: (visitor helpTopics subtopics first subtopics second) title
		equals: 'Section 3'.
	self assert: visitor helpTopics subtopics size equals: 1.
	self assert: visitor helpTopics subtopics first subtopics size equals: 2! !

!StTopicBuilderVisitorTest methodsFor: 'tests' stamp: ''!
testTopicBuilderVisitorVisitHeaderAtLevel2

	| file text header |
	text := '## SectionTest
	This is a paragraphe'.
	(file := filesystem workingDirectory / self class spFileName) 
		writeStreamDo: [ :stream | 
		stream nextPutAll: text ].
	header := (MicroDownParser new parse: file contents) children first.
	visitor visitHeader: header.
	self assert: visitor helpTopics subtopics first title equals: 'SectionTest'.
	self assert: visitor helpTopics subtopics first contents equals: ''
! !

!StTopicBuilderVisitorTest methodsFor: 'tests' stamp: ''!
helpTopicClass

	^ StNodeHelpTopic! !

!StTopicBuilderVisitorTest methodsFor: 'tests' stamp: ''!
testTopicBuilderVisitorWithOneSubSection

	| file |
	(file := filesystem workingDirectory / self class spFileName) 
		writeStreamDo: [ :stream | 
			stream nextPutAll: self class spFileContentsWithOneSubSection ].
	self visitFile: file.
	self
		assert: ((visitor helpTopics subtopics first) subtopics first) title
		equals: 'Section 2'.
	self assert: visitor helpTopics subtopics size equals: 1.
	self assert: visitor helpTopics subtopics first subtopics size equals: 1! !

!StTopicBuilderVisitorTest methodsFor: 'helper' stamp: ''!
visitFile: file

	visitor visit: (MicroDownParser new parse: file contents)! !

!StTopicBuilderVisitorTest methodsFor: 'tests' stamp: ''!
testTopicBuilderVisitorVisitHeader

	| file text header |
	text := '# SectionTest
	This is a paragraphe'.
	(file := filesystem workingDirectory / self class spFileName) 
		writeStreamDo: [ :stream | 
		stream nextPutAll: text ].
	header := (MicroDownParser new parse: file contents) children first.
	visitor visitHeader: header.
	self assert: visitor helpTopics subtopics first title equals: 'SectionTest'.
	self assert: visitor helpTopics subtopics first contents equals: ''
! !

!StTopicBuilderVisitorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	filesystem := FileSystem memory.
	visitor := StTopicBuilderVisitor new
	! !

!StTopicBuilderVisitorTest class methodsFor: 'resources' stamp: ''!
spFileName

	^ 'test.md'! !

!StTopicBuilderVisitorTest class methodsFor: 'resources' stamp: ''!
spFileContentsLevelsSections

	^ '# Section 1
blabla1
## Section 2
blabla2
### Section 3
blabla3
#### Section 4
blabla4
##### Section 5
blabla5
###### Section 6
blabla6'! !

!StTopicBuilderVisitorTest class methodsFor: 'resources' stamp: ''!
spFileContentsOneSection

	^ '# Section 1	
_blabla_
blabla'
! !

!StTopicBuilderVisitorTest class methodsFor: 'resources' stamp: ''!
spFileContentsWithMoreSubSection

	^ '# Section 1
blabla1
## Section 2
blabla2
## Section 3
blabla3'! !

!StTopicBuilderVisitorTest class methodsFor: 'resources' stamp: ''!
spFileContentsWithOneSubSection

	^ '# Section 1
blabla1
## Section 2
blabla2'! !

!StTopicBuilderVisitorTest class methodsFor: 'resources' stamp: ''!
spFileContentsMoreSections

	^ '# Section 1
blabla1
# Section 2
blabla2
'! !

!StTransformation commentStamp: ''!
I implement the collect: operation on the iterator.
I apply the block and transform the elements returned by myself.
!
!StTransformation methodsFor: 'accessing' stamp: ''!
next
	^ inner next ifNotNil: [ :aValue | self transform: aValue ]! !

!StTransformation methodsFor: 'tranforming' stamp: ''!
transform: anElement

	^ aBlock value: anElement! !

!StUnifiedProcessor commentStamp: ''!
I am a complex processor that unifies queries from: Classes, Implementors and Packages.
I can handle filtering by categories, so to have different behavior when the query includes #Classes, #Packages, #Implementors.
I configure the keymapping for the categories in spotter.

My source is a complex one: 
 
 - I will filter the duplicates out.
 - I will configure it using the categories in the query.
 - I have two behaviors, depending of the case of query. If it is uppercase, I will search first in implementors, then in classes and then in packages. If it is lowercase I will search in classes, packages and then implementors.
 - I first search for matches starting with the query and then for matches with the query in any place of the entry.!
!StUnifiedProcessor methodsFor: '*NewTools-Spotter' stamp: ''!
keyBindingForImplementors

	^ $m meta! !

!StUnifiedProcessor methodsFor: '*NewTools-Spotter' stamp: ''!
keyBindingForPackages

	^ $p meta! !

!StUnifiedProcessor methodsFor: 'spotter-api' stamp: ''!
classesTag

	^ #Classes! !

!StUnifiedProcessor methodsFor: 'filtering' stamp: ''!
configureFilter

	(categories ~= self query categoriesSelected)
		ifTrue: [
			categories := self query categoriesSelected.
			filter := nil ].

	super configureFilter.
	
	"I will clear the duplicates, as a new query have done"
	filter clearDuplicates! !

!StUnifiedProcessor methodsFor: '*NewTools-Spotter' stamp: ''!
headerCategoryFor: aLink on: aSpotterPresenter

	^ aLink value 
		headerCategoryForUnifiedProcessor: aLink 
		on: aSpotterPresenter! !

!StUnifiedProcessor methodsFor: 'key-bindings' stamp: ''!
installKeymappingsOn: aPresenter onExecution: aBlock

	aPresenter
		bindKeyCombination: $b meta
		toAction: [
			self query toggleFilter: self classesTag.
			aBlock cull: self ].

	aPresenter
		bindKeyCombination: $m meta
		toAction: [ 
			self query toggleFilter: self implementorsTag.
			aBlock cull: self ].
		
	aPresenter
		bindKeyCombination: $p meta
		toAction: [ 
			self query toggleFilter: self packagesTag.
			aBlock cull: self ]	! !

!StUnifiedProcessor methodsFor: 'sources' stamp: ''!
calculateUppercaseSourcesOn: anStream
	| classesBeginsWith classesIncludesString packagesBeginsWith packagesIncludesString wordsAwareClassesSource wordsAwarePackageSource classAndSelectorImplementors |
	
	(self categoriesIncludes: #Classes) 
		ifTrue: [
			classesBeginsWith := StSourceFactory current classesBeginsWithSource.			
			textFilteringIterators add: classesBeginsWith.
			anStream nextPut: classesBeginsWith ].

	(self categoriesIncludes: #Packages) 
		ifTrue: [
			packagesBeginsWith := (StPackageIterator new 
				collect: [ :each | StPackageEntry on: each ]) 
				asBeginsWithFilter.			
			textFilteringIterators add: packagesBeginsWith.
			anStream nextPut: packagesBeginsWith ].

	(self categoriesIncludes: #Classes) 
		ifTrue: [
			classesIncludesString := StSourceFactory current classesSubstringSource.
			textFilteringIterators add: classesIncludesString.
			anStream nextPut: classesIncludesString ].
		
	(self categoriesIncludes: #Packages) 
		ifTrue: [
			packagesIncludesString := (StPackageIterator new 
				collect: [ :each | StPackageEntry on: each ]) 
				asSubstringFilter.		
			textFilteringIterators add: packagesIncludesString.
			anStream nextPut: packagesIncludesString ].
		
	(self categoriesIncludes: #Classes) 
		ifTrue: [
			wordsAwareClassesSource := StWordsAwareFilter new 
				inner: (StSourceFactory current classesSubstringSource); 
				yourself.
			textFilteringIterators add: wordsAwareClassesSource.
			anStream nextPut: wordsAwareClassesSource ].

	(self categoriesIncludes: #Implementors) 
		ifTrue: 	[ 	
			classAndSelectorImplementors := StClassWithSelectorWordFilter new 
				inner: (StSourceFactory current implementorsSubstringSource); 
				yourself.
			textFilteringIterators add: classAndSelectorImplementors.
			anStream nextPut: classAndSelectorImplementors ].

	(self categoriesIncludes: #Packages) 
		ifTrue: [
			wordsAwarePackageSource := StWordsAwareFilter new 
				inner: ((StPackageIterator new 
					collect: [ :each | StPackageEntry on: each ]) 
					asSubstringFilter); 
				yourself.
			textFilteringIterators add: wordsAwarePackageSource.
			anStream nextPut: wordsAwarePackageSource ]! !

!StUnifiedProcessor methodsFor: 'spotter-api' stamp: ''!
isRelevantForQuery: aString 
	
	^ true! !

!StUnifiedProcessor methodsFor: 'filtering' stamp: ''!
newTextFilteringSource
	"It should not arrive here"
	^ nil! !

!StUnifiedProcessor methodsFor: 'filtering' stamp: ''!
newSource
	| uppercaseIterators lowercaseIterators caseSelectorIterator root |
	
	textFilteringIterators := OrderedCollection new.
	lowercaseIterators := OrderedCollection streamContents: [ :stream | 
		self calculateLowercaseSourcesOn: stream ].
	uppercaseIterators := OrderedCollection streamContents: [ :stream | 
		self calculateUppercaseSourcesOn: stream ].

	caseSelectorIterator := StCaseSelectorIterator new 
		lowercaseIterator: (StSequenceIterator with: lowercaseIterators);
		uppercaseIterator: (StSequenceIterator with: uppercaseIterators).
		
	textFilteringIterators add: caseSelectorIterator.
	
	root := caseSelectorIterator asWithoutDuplicates.
		
	^ root! !

!StUnifiedProcessor methodsFor: 'sources' stamp: ''!
categoriesIncludes: aCategory

	^ categories isNil 
		or: [ categories isEmpty 
		or: [ (categories includes: aCategory)
		or: [ categories anySatisfy: [ :each | aCategory asLowercase beginsWith: each asLowercase ] ] ] ]! !

!StUnifiedProcessor methodsFor: '*NewTools-Spotter' stamp: ''!
keyBindingForClasses

	^ $b meta! !

!StUnifiedProcessor methodsFor: 'sources' stamp: ''!
calculateLowercaseSourcesOn: anStream

	| implementorsBeginsWith implementorsSubstring wordsAwareImplementors |

	(self categoriesIncludes: #Implementors) 
		ifFalse: [ ^ self ].

	implementorsBeginsWith := StSourceFactory current implementorsBeginsWithSource.
	implementorsSubstring := StSourceFactory current implementorsSubstringSource.
	wordsAwareImplementors := StWordsAwareFilter new 
		inner: (StSourceFactory current implementorsSubstringSource); 
		yourself.
	
	textFilteringIterators add: implementorsBeginsWith.
	textFilteringIterators add: implementorsSubstring.
	textFilteringIterators add: wordsAwareImplementors.
	
	anStream nextPut: implementorsBeginsWith.
	anStream nextPut: implementorsSubstring.
	anStream nextPut: wordsAwareImplementors 
! !

!StUnifiedProcessor methodsFor: 'spotter-api' stamp: ''!
implementorsTag

	^ #Implementors! !

!StUnifiedProcessor methodsFor: 'spotter-api' stamp: ''!
packagesTag

	^ #Packages! !

!StUnifiedProcessor class methodsFor: 'accessing' stamp: ''!
order
	
	^ 100! !

!StUnifiedProcessor class methodsFor: 'settings' stamp: ''!
settingsTitle

	^ 'Classes, Implementors & Packages'! !

!StUnifiedProcessor class methodsFor: 'settings' stamp: ''!
settingsDescription

	^ 'I am the main processor: I show classes, packages and implementors'! !

!StUnifiedProcessor class methodsFor: 'default-settings' stamp: ''!
defaultEnabled

	^ true! !

!StUnifiedProcessor class methodsFor: 'accessing' stamp: ''!
title

	^ 'Results'! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisMethodWithFullClass

	self runForText: 'StUnifiedProcessorTest >> #testFindThisMethod'.
	self assertResultsIncludes: thisContext method! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisPackageWithCategory

	self runForText: '#Packages newtools-spotter-processors'.
	self assertResultsIncludes: StUnifiedProcessorTest package! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisMethodAfterAddingText

	self runForText: 'test'.
	self runForText: 'testFindThisMethod'.
	
	self assertResultsIncludes: thisContext method! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisPackage

	self runForText: 'newtools-spotter-processors'.
	self assertResultsIncludes: StUnifiedProcessorTest package! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testLookingForDiskStoreWithSpaceReturnsDiskStore

	self runForText: 'Disk Store'.
	self assertResultsIncludes: DiskStore! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testPopularStringDoesReturnOnlyTwentyResults

	self runForText: 'test'.
	self assertQuantityOfResults: 25.! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
processor

	^ StUnifiedProcessor new! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testPopularStringDoesReturnOnlyTwentyResultsWithCapital

	self runForText: 'Test'.
	self assertQuantityOfResults: 25.! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindStClassProcessorTestAfterAddingTest

	self runForText: 'stun'.
	self rerunWithText: 'stunifiedprocess'.
	
	self assertResultsIncludes: self class! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisPackageWithOtherCategory

	self runForText: '#Classes newtools-spotter-processors'.
	self denyResultsIncludes: self class package! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testGTClassProcessorIsRemovedAfterUpdatingText

	self runForText: 'stclass'.
	self rerunWithText: 'stclassprocesst'.
	
	self denyResultsIncludes: StClassProcessor! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindStClassProcessorTestWithPartialText

	self runForText: 'stunifi'.
	self assertResultsIncludes: self class! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisPackageAfterAddingText

	self runForText: 'newtools-spo'.
	self runForText: 'newtools-spotter-processors'.

	self assertResultsIncludes: StUnifiedProcessorTest package
	
	! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testLookingForStoreDiskLowercaseReturnsThisMethod

	self runForText: 'store disk'.
	self assertResultsIncludes: StUnifiedProcessorTest >> #testLookingForStoreDiskLowercaseReturnsThisMethod! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisMethodWithFullClassDoesNotIncludeOtherClassMethod

	self runForText: 'StUnifiedProcessorTest >> #testFindThisMethod'.
	self denyResultsIncludes: StImplementorsProcessorTest >> #testFindThisMethod! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testLookingForStoreDiskWithSpaceReturnsDiskStore

	self runForText: 'Store Disk'.
	self assertResultsIncludes: DiskStore! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testPopularStringDoesReturnOnlyTwentyResultsForPackage

	self runForText: '-Test'.
	self assertQuantityOfResults: 25.! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisMethod

	self runForText: 'testFindThisMethod'.
	self assertResultsIncludes: thisContext method! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindCloseEnoughMethod

	self runForText: 'yourself'.
	
	self assertResultsIncludes: Object >> #yourself! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindThisMethodWithFullClassIsTheCorrectclass

	self runForText: 'StUnifiedProcessorTest >> #testFindThisMethod'.
	self
		assert:
			((candidates results collect: [:each | each content])
				allSatisfy: [ :aMethod | aMethod methodClass = self class ])! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testGTSpotterNewIsRemovedAfterAddingText

	self runForText: 'newtools-spotter'.
	self rerunWithText: 'newtools-spotter-other'.
	
	self denyResultsIncludes: StClassProcessor package! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testFindStClassProcessorTest

	self runForText: 'stunifiedprocessortest'.
	self assertResultsIncludes: StUnifiedProcessorTest! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testLookingForStoreDiskReturnsDiskStore

	self runForText: 'StoreDisk'.
	self assertResultsIncludes: DiskStore! !

!StUnifiedProcessorTest methodsFor: 'tests' stamp: ''!
testLookingForStoreLowercaseReturnsDiskStore

	self runForText: 'store disk'.
	self assertResultsIncludes: DiskStore! !

!StUnorderedFilter commentStamp: ''!
a base filter for "unordered" elements (not a collection)!
!StUnorderedFilter methodsFor: 'private' stamp: ''!
doApplyFilterWithQuery

	| unorderedMatchedItems |

	unorderedMatchedItems := OrderedCollection new.
	self allItemsDo: [ :each | 
		(self isMatchedItem: each)
				ifTrue: [
					unorderedMatchedItems add: each.
					self addItem: each.
					unorderedMatchedItems size = self itemsLimit ifTrue: [ StLimitArrived signal ] ] ].
	self filteredItems: unorderedMatchedItems! !

!StUnorderedFilter methodsFor: 'private' stamp: ''!
isMatchedItem: anItem
	^ false! !

!StWhereIsCommand commentStamp: ''!
Requests the debugger to reselect in its code pane the next expression to be executed!
!StWhereIsCommand methodsFor: 'testing' stamp: ''!
appliesTo: aDebugger
	^ true! !

!StWhereIsCommand methodsFor: 'hooks' stamp: ''!
execute
	self debugger selectNextExecutedExpression! !

!StWhereIsCommand class methodsFor: 'initialization' stamp: ''!
defaultShortcut
	^ nil! !

!StWhereIsCommand class methodsFor: 'initialization' stamp: ''!
defaultIconName

	^ #debuggerWhereIs ! !

!StWhereIsCommand class methodsFor: 'default' stamp: ''!
defaultDescription
	^ 'Highligh the next method to be executed (step) by the debugger.'! !

!StWhereIsCommand class methodsFor: 'default' stamp: ''!
defaultName
	<toolbarDebugCommand: 1000>
	^ 'Where is?'! !

!StWindowEntry commentStamp: ''!
I wrap a Window, to modify its behavior if required for the spotter!
!StWindowEntry methodsFor: 'converting' stamp: ''!
asString 

	^ '{1} [{2}]' format: { content label. content className }! !

!StWindowEntry methodsFor: 'accessing' stamp: ''!
icon
	
	^ content taskbarIcon! !

!StWindowEntry methodsFor: 'evaluating' stamp: ''!
doEvaluate

	content stActDefault! !

!StWindowsProcessor commentStamp: ''!
I am a processor to get all the windows open in the world. It filters out the top most window!
!StWindowsProcessor methodsFor: 'filtering' stamp: ''!
collection

	^ (self currentWorld submorphs select: [ :window | window isKindOf: SystemWindow ]) 
		ifNotEmpty: [ :aCollection | aCollection allButFirst ]! !

!StWindowsProcessor methodsFor: 'filtering' stamp: ''!
newEntryOn: anElement

	^ StWindowEntry on: anElement! !

!StWindowsProcessor methodsFor: 'configuration' stamp: ''!
showForEmptyQuery

	^ true! !

!StWindowsProcessor class methodsFor: 'accessing' stamp: ''!
order
	
	^ 50! !

!StWindowsProcessor class methodsFor: 'default-settings' stamp: ''!
defaultEnabled

	^ true! !

!StWindowsProcessor class methodsFor: 'accessing' stamp: ''!
title

	^ 'Windows'! !

!StWindowsProcessorTest methodsFor: 'running' stamp: ''!
tearDown

	{backWindow1. backWindow2. topMostWindow} 
		do:[:e | e ifNotNil: [ e close ]].

	super tearDown.	! !

!StWindowsProcessorTest methodsFor: 'tests' stamp: ''!
testBackWindowsAreFindWhenUsingSubstring

	self runForText: 'wind'.
	self assertResultsIncludes: backWindow1.
	self assertResultsIncludes: backWindow2.	! !

!StWindowsProcessorTest methodsFor: 'tests' stamp: ''!
testBackWindowsAreShown

	self runForText: ''.
	self assertResultsIncludes: backWindow1.
	self assertResultsIncludes: backWindow2.	! !

!StWindowsProcessorTest methodsFor: 'tests' stamp: ''!
processor

	^ StWindowsProcessor new! !

!StWindowsProcessorTest methodsFor: 'tests' stamp: ''!
testTopMostWindowIsNotShown

	self runForText: ''.
	self denyResultsIncludes: topMostWindow! !

!StWindowsProcessorTest methodsFor: 'tests' stamp: ''!
testBackWindowsAreFind

	self runForText: 'back'.
	self assertResultsIncludes: backWindow1.
	self assertResultsIncludes: backWindow2.	! !

!StWindowsProcessorTest methodsFor: 'tests' stamp: ''!
testEmptyQueryShowsResults

	self runForText: ''.
	self assertResultsIncludes: backWindow1! !

!StWindowsProcessorTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	backWindow1 := StandardWindow new title: 'backWindow1'; openInWorld; yourself.
	backWindow2 := StandardWindow new title: 'backWindow2'; openInWorld; yourself.
	topMostWindow := StandardWindow new title: 'topMostWindow'; openInWorld; yourself.		
	! !

!StWithoutDuplicatesDecorator commentStamp: ''!
I implement a decorator for the iterators. 
I don't allow duplicates to be returned. For doing so, I have a collection of the already returned values, so I can filter duplicates.!
!StWithoutDuplicatesDecorator methodsFor: 'initialization' stamp: ''!
initialize 

	super initialize.
	uniqueResults := Set new.! !

!StWithoutDuplicatesDecorator methodsFor: 'accessing' stamp: ''!
next

	| aValue |
	aValue := inner next.
	
	[aValue isNotNil and: [ uniqueResults includes: aValue ]]
		whileTrue: [ aValue := inner next ].
		
	uniqueResults add: aValue.
	^ aValue
	! !

!StWithoutDuplicatesDecorator methodsFor: 'protected' stamp: ''!
doReset 

	inner reset.
	self clearDuplicates! !

!StWithoutDuplicatesDecorator methodsFor: 'resetting' stamp: ''!
clearDuplicates
	
	uniqueResults removeAll! !

!StWithoutDuplicatesDecorator class methodsFor: 'instance creation' stamp: ''!
on: anInner

	^ self new 
		inner: anInner;
		yourself! !

!StWordsAwareFilter commentStamp: ''!
I implement a complex filter on top of my inner iterator.
I will take the filtering text and split it on the spaces, $: and camel case syntax to try to detect all the elements that have those words.

My iterator is query with the first word of the filtering text and the filtering the elements that have all the words in any part. 
For example, doing the query StoreDisk will answer also DiskStore !
!StWordsAwareFilter methodsFor: 'accessing' stamp: ''!
inner: anIterator

	inner := anIterator.
	realFilter := anIterator! !

!StWordsAwareFilter methodsFor: 'filtering' stamp: ''!
additionalFilter: aString firstWord: firstWord otherWords: otherWords on: anEntry

	^ otherWords allSatisfy: [ :otherW | anEntry asString asLowercase includesSubstring: otherW ]
! !

!StWordsAwareFilter methodsFor: 'filtering' stamp: ''!
splitWords: aString

	^ (aString substrings: ' :-')
		flatCollect: [ :each | each splitCamelCase  ]! !

!StWordsAwareFilter methodsFor: 'filtering' stamp: ''!
filteringText: aString

	| firstWord otherWords |
	words := self splitWords: aString.
	words ifEmpty: [ ^ self ].
	
	firstWord := words first.
	otherWords := words allButFirst collect: [:each | each asLowercase].
		
	realFilter filteringText: firstWord.
	inner := realFilter select: [ :anEntry | 
		anEntry isNotNil and: 
		[self additionalFilter: aString firstWord: firstWord otherWords: otherWords on: anEntry ]].
! !

!StWorldMenuEntry commentStamp: ''!
I wrap a World menu entry, to modify its behavior if required for the spotter!
!StWorldMenuEntry methodsFor: 'comparing' stamp: ''!
= anEntry

	^ self species = anEntry species
		and: [ anEntry asString = self asString ]! !

!StWorldMenuEntry methodsFor: 'converting' stamp: ''!
asString 

	^ content contents! !

!StWorldMenuEntry methodsFor: 'accessing' stamp: ''!
icon

	^ content icon! !

!StWorldMenuEntry methodsFor: 'evaluating' stamp: ''!
doEvaluate 

	content stActDefault! !

!StWorldMenuProcessor commentStamp: ''!
I am a simple processor that returns all the world menu entries. !
!StWorldMenuProcessor methodsFor: 'filtering' stamp: ''!
askingForMenu

	^ (query hasCategoryMatching: #menu) 
		or: [ query isSearchEmpty not
		or: [ query hasAnyCategory not and: [ query isSearchEmpty ] ] ]! !

!StWorldMenuProcessor methodsFor: 'spotter-api' stamp: ''!
isRelevantForQuery: aString 
	
	^ true! !

!StWorldMenuProcessor methodsFor: 'configuration' stamp: ''!
showForEmptyQuery

	^ true! !

!StWorldMenuProcessor methodsFor: 'filtering' stamp: ''!
executeQuery

	self askingForMenu ifFalse: [ ^ self ].
	^ super executeQuery! !

!StWorldMenuProcessor methodsFor: 'filtering' stamp: ''!
newTextFilteringSource

	^ ((StGeneratorBlockIterator
		on: [ :aValuable | self currentWorld worldMenu withAllLeafItemsDo: aValuable ])
		collect: [ :e | StWorldMenuEntry on: e ]) asSubstringFilter! !

!StWorldMenuProcessor class methodsFor: 'accessing' stamp: ''!
order
	
	^ 90! !

!StWorldMenuProcessor class methodsFor: 'default-settings' stamp: ''!
defaultEnabled

	^ true! !

!StWorldMenuProcessor class methodsFor: 'accessing' stamp: ''!
title

	^ 'Menu'! !

!StWorldMenuProcessorTest methodsFor: 'asserting' stamp: ''!
denyResultsIncludesMenuEntry: aString 
	
	self assert: (candidates results noneSatisfy: [:each | each content contents = aString ])! !

!StWorldMenuProcessorTest methodsFor: 'tests' stamp: ''!
testSearchingSaIncludesSaveAndSaveAs

	self runForText: 'sa'.
	self assertResultsIncludesMenuEntry: 'Save'.
	self assertResultsIncludesMenuEntry: 'Save as...'	! !

!StWorldMenuProcessorTest methodsFor: 'tests' stamp: ''!
processor

	^ StWorldMenuProcessor new! !

!StWorldMenuProcessorTest methodsFor: 'tests' stamp: ''!
testSearchingVeDoesNotIncludeIceberg

	self runForText: 've'.
	self denyResultsIncludesMenuEntry: 'Iceberg'.
! !

!StWorldMenuProcessorTest methodsFor: 'tests' stamp: ''!
testEmptyQueryShowsResults

	self runForText: ''.
	self assertResultsIncludesMenuEntry: 'Iceberg'.
! !

!StWorldMenuProcessorTest methodsFor: 'tests' stamp: ''!
testSearchingSettingsFindsTheCorrectEntry

	self runForText: 'settings'.
	self assertResultsIncludesMenuEntry: 'Settings'! !

!StWorldMenuProcessorTest methodsFor: 'tests' stamp: ''!
testSearchingVeIncludesSaveAndSaveAs

	self runForText: 'Ve'.
	self assertResultsIncludesMenuEntry: 'Save'.
	self assertResultsIncludesMenuEntry: 'Save as...'	! !

!StWorldMenuProcessorTest methodsFor: 'asserting' stamp: ''!
assertResultsIncludesMenuEntry: aString 
	
	self assert: (candidates results anySatisfy: [:each | each content contents = aString ])! !

!StWorldMenuProcessorTest methodsFor: 'tests' stamp: ''!
testSearchingSaDoesNotIncludeIceberg

	self runForText: 'sa'.
	self denyResultsIncludesMenuEntry: 'Iceberg'.
! !

!Stack commentStamp: ''!
I implement a simple Stack. #push: adds a new object of any kind on top of the stack. #pop returns the first element and remove it from the stack. #top answer the first element of the stack without removing it.!
!Stack methodsFor: 'adding' stamp: ''!
push: anObject 
	"Adds a new object of any kind on top of the stack."
	
	self addFirst: anObject.
	^ anObject! !

!Stack methodsFor: 'removing' stamp: ''!
pop
	"Returns the first element and remove it from the stack."

	^self removeFirst! !

!Stack methodsFor: 'accessing' stamp: ''!
top
	"Answer the first element of the stack without removing it."
	
	^ self first! !

!StackLayout commentStamp: ''!
A stack based layout!
!StackLayout methodsFor: 'layout' stamp: ''!
layout: aMorph in: layoutBounds
	"Compute the layout for the given morph based on the new bounds.
	Supports submorph hResizing, vResizing, cellInset, cellPositioning
	(top, *center, bottom*)."

	|props cell box pos vr newBounds minExt|
	aMorph submorphs ifEmpty: [^self].
	props := aMorph assureTableProperties.
	minExt := self minExtentOf: aMorph in: layoutBounds.
	newBounds := layoutBounds origin extent: (layoutBounds extent max: minExt).
	cell := newBounds.
	aMorph submorphs with: cachedMinExtents do: [:m :ext |
		((vr := m vResizing) == #shrinkWrap or: [m bounds ~= cell])
			ifTrue: [((vr == #shrinkWrap) not and: [m extent = cell extent])
						ifTrue: [m position: cell origin]
						ifFalse: [box := m bounds.
								m hResizing == #spaceFill 
									ifTrue: [box := cell origin extent: cell width @ box height].
								vr  == #spaceFill
									ifTrue: [box := box origin extent: box width @ cell height].
								vr  == #shrinkWrap
									ifTrue:[box := box origin extent: box width @ ext y].
								pos := props cellPositioning.
								box := box align: (box perform: pos) with: (cell perform: pos).
								m bounds: box]]]! !

!StackLayout methodsFor: 'private' stamp: ''!
flushLayoutCache
	"Flush any cached information associated with the receiver."
	
	cachedMinExtent := nil! !

!StackLayout methodsFor: 'layout' stamp: ''!
minExtentOf: aMorph in: newBounds
	"Return the minimal size aMorph's children would require given the new bounds"
	
	|min extent|
	cachedMinExtent ifNotNil: [^cachedMinExtent].
	aMorph submorphs ifEmpty: [^0 @ 0].
	extent := 0@0.
	cachedMinExtents := aMorph submorphs collect: [:m |
		min := m minExtent.
		extent := extent max: min.
		min].
	^cachedMinExtent := extent! !

!StackTest commentStamp: ''!
SUnit tests for stacks!
!StackTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!StackTest methodsFor: 'tests - empty' stamp: ''!
testIfEmptyifNotEmpty
	self assert: (self empty ifEmpty: [ true ] ifNotEmpty: [ false ]).
	self assert: (self nonEmpty ifEmpty: [ false ] ifNotEmpty: [ true ])! !

!StackTest methodsFor: 'tests' stamp: ''!
testPop
	| aStack res elem |
	elem := 'anElement'.
	aStack := Stack new.
	self assertEmpty: aStack.

	aStack push: 'a'.
	aStack push: elem.
	res := aStack pop.
	self assert: res equals: elem.
	self assert: res identicalTo: elem.

	self assert: aStack size equals: 1.
	aStack pop.
	self assertEmpty: aStack! !

!StackTest methodsFor: 'tests' stamp: ''!
testEmptyError
	| aStack |
	aStack := Stack new.
	self should: [ aStack top ] raise: Error.
	self should: [ aStack pop ] raise: Error.
	aStack push: 'element'.
	aStack top.
	aStack pop.	"The stack is empty again due to previous pop"
	self should: [ aStack top ] raise: Error.
	self should: [ aStack pop ] raise: Error! !

!StackTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureEmptyTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!StackTest methodsFor: 'accessing' stamp: ''!
empty
	
 	^ empty! !

!StackTest methodsFor: 'accessing' stamp: ''!
nonEmpty
	
 	^ nonEmpty! !

!StackTest methodsFor: 'tests - empty' stamp: ''!
testIfNotEmpty
	self empty ifNotEmpty: [ self assert: false ].
	self nonEmpty ifNotEmpty: [ self assert: true ].
	self assert: (self nonEmpty ifNotEmpty: [ :s | s ]) = self nonEmpty! !

!StackTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!StackTest methodsFor: 'tests' stamp: ''!
testSize
	| aStack |
	aStack := Stack new.
	self assert: aStack size equals: 0.
	aStack push: 'a'.
	self assert: aStack size equals: 1.
	aStack push: 'b'.
	self assert: aStack size equals: 2.
	aStack pop.
	self assert: aStack size equals: 1.
	aStack pop.
	self assert: aStack size equals: 0! !

!StackTest methodsFor: 'tests - empty' stamp: ''!
testIsEmptyOrNil
	self assert: self empty isEmptyOrNil.
	self deny: self nonEmpty isEmptyOrNil! !

!StackTest methodsFor: 'tests - empty' stamp: ''!
testIsEmpty
	self assert: self empty isEmpty.
	self deny: self nonEmpty isEmpty! !

!StackTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	 
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!StackTest methodsFor: 'tests' stamp: ''!
testPush
	| aStack |
	aStack := Stack new.
	aStack push: 'a'.
	self assert: aStack size equals: 1.
	aStack push: 'b'.
	self assert: aStack size equals: 2! !

!StackTest methodsFor: 'tests' stamp: ''!
testTop
	| aStack |
	aStack := Stack new.
	self assertEmpty: aStack.
	aStack push: 'a'.
	aStack push: 'b'.
	self assert: aStack top equals: 'b'.
	self assert: aStack top equals: 'b'.
	self assert: aStack size equals: 2! !

!StackTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	empty := Stack new.
	nonEmpty := Stack new.
	nonEmpty push: 1.
	nonEmpty push: -2.
	nonEmpty push: 3.
	nonEmpty push: 1.! !

!StackTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!StackTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!StackTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!StackTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!StackTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!StackTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!StackTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!StackTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!StackTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!StackTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!StackTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!StackTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!StackTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!StackTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!StackTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!StackTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!StackTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!StackTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!StackTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!StackTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!StackTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!StackTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!StackTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!StackTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!StackTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!StackTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!StackTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!StackTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!StackTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!StandardFonts commentStamp: ''!
I am a facade and a global reference to actual fonts to be used system wide in a number of predefined categories.

I also provide methods to interactively choose these fonts, to reset all fonts to some default value, to set larger demo fonts, to construct a font menu and to manipulate the current settings as an external specification.

The font categories that I know of are: ButtonFont, CodeFont, HaloFont, ListFont, MenuFont and WindowTitleFont

Examples:
- I open a dialog to choose the font for buttons with:
StandardFonts chooseButtonFont.

- To change base size for all fonts (when you want big fonts for a screencast or a presentation):
StandardFonts setDemoFonts.

- Then restore default fonts with:
StandardFonts restoreDefaultFonts.!
!StandardFonts class methodsFor: 'font accessing' stamp: ''!
listFont
	^ ListFont ifNil: [ListFont := self defaultFont]! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
restoreDefaultFonts
	"Since this is called from menus, we can take the opportunity to prompt for missing font styles."
	"
	self restoreDefaultFonts
	"
	self setFontsToSmall! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
windowTitleFont: aFont
	WindowTitleFont := aFont! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
balloonFont
	^ BalloonFont ifNil: [BalloonFont := self defaultFont]! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
chooseListFont
	self chooseStandardFont: #listFont! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
setFontsFromSpec: fontsSpec
	"set some fonts by interpreting fontsSpec.
	fontsSpec is a collection.
	Each fontsSpec element is an array with 3 elements: 
	(1) the font accessor (i.e. #codeFont:)
	(2) the font family (i.e. 'Arial')
	(3) the font point size.
	To see an example of fontsSpec, inspect the result of 
	StandardFonts getCurrentFontsSpec.
	"
	| fontNames map emphases |
	fontNames := fontsSpec
				collect: [:array | array second].
	map := IdentityDictionary new.
	emphases := IdentityDictionary new.
	fontNames
		do: [:originalName | 
			| decoded style |
			decoded := TextStyle decodeStyleName: originalName.
			style := map
						at: originalName
						put: (TextStyle named: decoded second).
			emphases at: originalName put: decoded first.
			style
				ifNil: [map at: originalName put: TextStyle default]].
	fontsSpec
		do: [:triplet | self
				perform: triplet first
				with: (((map at: triplet second)
						fontOfPointSize: triplet third)
						emphasized: (emphases at: triplet second))]! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
setDemoFonts
	"StandardFonts setDemoFonts"
	|size font codeFont titleFont|

	size := UIManager default request: 'Base font size?' initialAnswer: '14'.
	size isEmptyOrNil ifTrue: [^ self].
	size := size asInteger.
	(size isNil or: [size <= 0]) ifTrue: [^ self].
	font := LogicalFont familyName: 'DejaVu Sans' pointSize: size.
	codeFont := LogicalFont familyName: 'DejaVu Sans Mono' pointSize: size.
	titleFont := LogicalFont familyName: 'DejaVu Serif' pointSize: size.

	StandardFonts
		listFont: font;
		menuFont: font;
		codeFont: codeFont;
		buttonFont: font;
		defaultFont: font;
		windowTitleFont: titleFont.! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
buttonFont
	^ ButtonFont ifNil: [ButtonFont := self defaultFont]! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
menuFont
	^ MenuFont ifNil: [MenuFont := self defaultFont]! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
balloonFont: aFont
	BalloonFont := aFont! !

!StandardFonts class methodsFor: 'styles' stamp: ''!
bigPointSizeForStyleNamed: aSymbol
	| all s idx |
	StrikeFont defaultFontKey.
	all := TextStyle pointSizesFor: StrikeFont defaultFontKey.
	s := self pointSizeForStyleNamed: aSymbol.
	idx := all indexOf: s ifAbsent: [^ s].
	^ idx = all size
			ifTrue: [all at: idx]
			ifFalse: [all at: idx + 1]! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
codeFont: aFont
	 CodeFont := aFont! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
getCurrentFontsSpec
	"self getCurrentFontsSpec "
	^ self systemFontAspects collect: [:aspect | | font |
		font := self perform: aspect.
		Array with: (aspect, ':') asSymbol with: font familyName with: font pointSize]! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
systemFontLabelOf: aSelector
	^ self systemFontAspectsAndLabels
		detect: [ :assoc | assoc key = aSelector ]
		ifFound: [ :assoc | assoc value ]
		ifNone: [ '' ]! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
systemFontLabels
	^ self systemFontAspectsAndLabels collect: [:assoc | assoc value]! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
defaultFont: aFont
	"Establish the default text font and style"

	| aStyle newDefaultStyle |
	aFont ifNil: [^ StandardFonts setFontsFromSpec: {{#defaultFont:. StrikeFont defaultFontKey. StrikeFont defaultFontSize}}].
	aStyle := aFont textStyle ifNil: [^ self].
	newDefaultStyle := aStyle copy.
	newDefaultStyle defaultFontIndex: (aStyle fontIndexOf: aFont).
	TextSharedInformation at: #DefaultTextStyle put: newDefaultStyle.! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
systemFontAspects
	^ self systemFontAspectsAndLabels collect: [:assoc | assoc key]! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
windowTitleFont
	^ WindowTitleFont ifNil: [WindowTitleFont := StandardFonts defaultFont]! !

!StandardFonts class methodsFor: 'styles' stamp: ''!
setFontsToStyleNamed: aSymbol
	self setFontsFromSpec: (self fontsSpecForStyleNamed: aSymbol)! !

!StandardFonts class methodsFor: 'styles' stamp: ''!
setFontsToHuge
	self setFontsToStyleNamed: #huge! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
chooseBalloonFont
	self chooseStandardFont: #balloonFont! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
chooseButtonFont
	self chooseStandardFont: #buttonFont! !

!StandardFonts class methodsFor: 'menu' stamp: ''!
setDefaultFonts: defaultFontsSpec
	"Since this is called from menus, we can take the opportunity to prompt for missing font styles."

	| fontNames map emphases |
	fontNames := defaultFontsSpec collect: [:array | array second].
	map := IdentityDictionary new.
	emphases := IdentityDictionary new.
	fontNames do: [:originalName | | decoded style |
		decoded := TextStyle decodeStyleName: originalName.
		style := map at: originalName put: (TextStyle named: decoded second).
		emphases at: originalName put: decoded first.
		style ifNil: [map at: originalName put: (TextStyle default) ]].
	defaultFontsSpec do: [:triplet | self
		perform: triplet first
		with: (((map at: triplet second) fontOfPointSize: triplet third) emphasized: (emphases at: triplet second))]! !

!StandardFonts class methodsFor: 'styles' stamp: ''!
smallPointSizeForStyleNamed: aSymbol
	| all s idx |
	StrikeFont defaultFontKey.
	all := TextStyle pointSizesFor: StrikeFont defaultFontKey.
	s := self pointSizeForStyleNamed: aSymbol.
	idx := all indexOf: s ifAbsent: [^ s].
	^ idx > 1
			ifTrue: [all at: idx - 1]
			ifFalse: [all at: idx]! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
codeFont
	^ CodeFont ifNil: [CodeFont := self defaultFont]! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
chooseDefaultFont
	self chooseStandardFont: #defaultFont! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
chooseStandardFont: aSelector 
	self
		chooseFontWithTitle: (self systemFontLabelOf: aSelector)	, '...'
		for: self
		setSelector: (aSelector , ':') asSymbol
		getSelector: aSelector! !

!StandardFonts class methodsFor: 'small font fixing' stamp: ''!
fixSmallDejaVuPunctuationMarks
	"Just a small hack to make small font punctuation marks readable"
	| fb |
	StandardFonts setFontsToStyleNamed: #small. "To be sure we use the small font"
	fb :=StandardFonts defaultFont emphasized: 1. "copy the bold font"
	"For each punctuation mark, replace the corresponding glyph with the one found in the bold font" 
	#($. $: $; $' $` $, $")
		do: [:ch |
			StandardFonts defaultFont characterFormAt: ch put: (fb characterFormAt: ch) deepCopy].! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
chooseWindowTitleFont
	self chooseStandardFont: #windowTitleFont! !

!StandardFonts class methodsFor: 'styles' stamp: ''!
fontsSpecForStyleNamed: aSymbol
	| k small regular big |
	k := StrikeFont defaultFontKey.
	small := self smallPointSizeForStyleNamed: aSymbol.
	regular := self pointSizeForStyleNamed: aSymbol.
	big := self bigPointSizeForStyleNamed: aSymbol.
	^ {
			{#defaultFont:. k. regular }. 
			{#codeFont:. k. regular }.
			{#listFont:. k. regular }. 
			{#menuFont:. k. regular }. 
			{#windowTitleFont:. k. big }. 
			{#balloonFont:. k. small }. 
			{#haloFont:. k. small }.
			{#buttonFont:. k. regular } }! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
setAllStandardFontsTo: aFont
	self systemFontAspects do: [:selector | StandardFonts perform: (selector, ':') asSymbol with: aFont].! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
menuFont: aFont
	aFont ~= MenuFont 
		ifTrue: [ MenuFont := aFont ].! !

!StandardFonts class methodsFor: 'styles' stamp: ''!
setFontsToSmall
	self setFontsToStyleNamed: #small! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
printStandardSystemFonts
	"self printStandardSystemFonts"

	| string |
	string := String streamContents: [ :s |

	StandardFonts systemFontAspects do: [:selector |
		| font |
		font := StandardFonts perform: selector.
		s
			nextPutAll: selector; space;
			nextPutAll: font familyName; space;
			nextPutAll: (AbstractFont emphasisStringFor: font emphasis);
			nextPutAll: ' points: ';
			print: font pointSize;
			nextPutAll: ' height: ';
			print: font height;
			cr
		]].
	UIManager default  
		longMessage: string
		title: 'Current system font settings' translated.! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
haloFont: aFont
	HaloFont := aFont! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
setSmallBitmapFonts

	| sans fixed |
	
	sans := 'Bitmap Source Sans Pro'.
	fixed := 'Bitmap Source Code Pro'.
	
	self defaultFont: (LogicalFont familyName: sans pointSize: 10).
	self codeFont: (LogicalFont familyName: fixed pointSize: 10).
	self listFont: (LogicalFont familyName: sans pointSize: 10).
	self menuFont: (LogicalFont familyName: sans pointSize: 10).
	self buttonFont: (LogicalFont familyName: sans pointSize: 10).
 	self windowTitleFont: (LogicalFont familyName: sans pointSize: 11).
	self balloonFont: (LogicalFont familyName: sans pointSize: 9).
 	self haloFont: (LogicalFont familyName: sans pointSize: 9).! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
defaultFont
	^ TextStyle defaultFont! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
chooseCodeFont
	self chooseStandardFont: #codeFont! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
chooseFontWithTitle: aTitle for: aReceiver setSelector: aSetSelector getSelector: aGetSelector
	FontChooser
		openWithWindowTitle: aTitle
		for: aReceiver
		setSelector: aSetSelector
		getSelector: aGetSelector! !

!StandardFonts class methodsFor: 'styles' stamp: ''!
setFontsToVeryLarge
	self setFontsToStyleNamed: #verylarge! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
haloFont
	^ HaloFont ifNil: [HaloFont := StandardFonts defaultFont]! !

!StandardFonts class methodsFor: 'styles' stamp: ''!
setFontsToMedium
	self setFontsToStyleNamed: #medium! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
systemFontAspectsAndLabels
	^ {#defaultFont -> 'Default font' translated. #listFont -> 'List font'  translated. #menuFont -> 'Menu font'  translated. #windowTitleFont -> 'Window title'  translated. #balloonFont -> 'Balloon help font'  translated. #codeFont -> 'Code font'  translated. #buttonFont -> 'Button font'  translated. #haloFont -> 'Halo font'  translated }! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
chooseMenuFont
	self chooseStandardFont: #menuFont! !

!StandardFonts class methodsFor: 'styles' stamp: ''!
pointSizeForStyleNamed: aSymbol
	"
	self pointSizeForStyleNamed: #small.
	self pointSizeForStyleNamed: #Medium.
	self pointSizeForStyleNamed: #LARGE.
	self pointSizeForStyleNamed: #verylarge.
	self pointSizeForStyleNamed: #Huge.
	self pointSizeForStyleNamed: #xxxxx.
	"
	^ (#(#(#small 9) #(#medium 12) #(#large 14) #(veryLarge 18) #(huge 24)) 
		detect: [:info | info first asUppercase = aSymbol asUppercase] ifNone: []) 
			ifNotNil: [:info | info second]! !

!StandardFonts class methodsFor: 'styles' stamp: ''!
setFontsToLarge
	self setFontsToStyleNamed: #large! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
listFont: aFont
	 ListFont := aFont! !

!StandardFonts class methodsFor: '*Fonts-Chooser' stamp: ''!
chooseHaloFont
	self chooseStandardFont: #haloFont! !

!StandardFonts class methodsFor: 'font accessing' stamp: ''!
buttonFont: aFont
	 ButtonFont := aFont! !

!StandardWindow commentStamp: ''!
Themed SystemWindow that avoids being picked up except via the title bar. Supports opening in "fullscreen" mode, taking docking bars into account.
Prevents yellow button menu.
Uses TEasilyThemed for easy theme access to subclasses.!
!StandardWindow methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		icon: iconSelector
		getEnabled: enabledSel
		help: helpText! !

!StandardWindow methodsFor: 'open/close' stamp: ''!
openFullscreen
	"Open the receiver in a FullscreenMorph."

	^FullscreenMorph new
		setContentMorph: self;
		openInWorld! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newAlphaImage: aForm help: helpText
	"Answer an alpha image morph."

	^self theme
		newAlphaImageIn: self
		image: aForm
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText
	"Answer a morph list for the given model."

	^self
		newMorphListFor: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: nil
		help: helpText! !

!StandardWindow methodsFor: 'services' stamp: ''!
deny: aStringOrText title: aString
	"Open a denial dialog."

	^self theme
		denyIn: self
		text: aStringOrText
		title: aString! !

!StandardWindow methodsFor: 'services' stamp: ''!
question: aStringOrText
	"Open a question dialog."

	^self question: aStringOrText title: 'Question' translated! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel
	"Answer a text editor for the given model."

	^self
		newTextEditorFor: aModel
		getText: getSel
		setText: setSel
		getEnabled: nil! !

!StandardWindow methodsFor: 'services' stamp: ''!
message: aStringOrText title: aString
	"Open a message dialog."

	^self theme
		messageIn: self
		text: aStringOrText
		title: aString! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: aModel
		label: aString
		offset: offset
		alpha: alpha
		getEnabled: enabledSel! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newString: aStringOrText style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: aStyle! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newColorPresenterFor: aModel getColor: getSel help: helpText
	"Answer a color presenter with the given selectors."

	^self theme
		newColorPresenterIn: self
		for: aModel
		getColor: getSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: #bottomLeft! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newImage: aForm
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newSeparator
	"Answer an horizontal separator."

	^self theme
		newSeparatorIn: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newScrollPaneFor: aMorph
	"Answer a new scroll pane morph to scroll the given morph."
	
	^self theme
		newScrollPaneIn: self
		for: aMorph! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newStack: controls
	"Answer a morph laid out with a stack of controls."

	^self theme
		newStackIn: self
		for: controls! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newLabelGroup: labelsAndControls
	"Answer a morph laid out with a column of labels and a column of associated controls.
	Controls having a vResizing value of #spaceFill will
	cause their row to use #spaceFill also, otherwise #shrinkWrap."

	^self theme
		newLabelGroupIn: self
		for: labelsAndControls! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newGroupboxForAll: controls
	"Answer a plain groupbox with the given controls."

	^self theme
		newGroupboxIn: self
		forAll: controls! !

!StandardWindow methodsFor: 'open/close' stamp: ''!
delete
	"If fullscreen remove the owner too."
	
	self mustNotClose ifTrue: [^ self].
	self model ifNotNil: [ 
		self model okToChange ifFalse: [ ^ self ].
		self model okToClose ifFalse: [ ^ self ] ].
	self isFullscreen
		ifTrue: [self owner delete]
		ifFalse: [super delete]! !

!StandardWindow methodsFor: 'services' stamp: ''!
message: aStringOrText
	"Open a message dialog."

	^self message: aStringOrText title: 'Information' translated! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newCancelButton
	"Answer a new cancel button."

	^self newCancelButtonFor: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newVerticalSeparator
	"Answer a vertical separator."

	^self theme
		newVerticalSeparatorIn: self! !

!StandardWindow methodsFor: 'testing' stamp: ''!
isActive
	"Answer active if fullscreen too."
	
	^self isFullscreen or: [super isActive]! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText
	"Answer a list for the given model."

	^self
		newListFor: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: nil
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newNoButton
	"Answer a new No button."

	^self newNoButtonFor: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newYesButtonFor: aModel
	"Answer a new yes button."

	^self theme
		newYesButtonIn: self
		for: aModel! !

!StandardWindow methodsFor: 'services' stamp: ''!
textEntry: aStringOrText
	"Open a text entry dialog."

	^self textEntry: aStringOrText title: 'Entry' translated! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title for: contentMorph
	"Answer a new pluggable dialog with the given content."

	^self theme
		newPluggableDialogWindowIn: self
		title: title
		for: contentMorph! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newToolbar
	"Answer a toolbar."

	^self theme
		newToolbarIn: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText
	"Answer a bracket slider with the given selectors."

	^self
		newBracketSliderFor: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum 
		getEnabled: nil
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: aClass
		default: defaultValue
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseColor
	"Answer the result of a color selector dialog ."

	^self chooseColor: Color black! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText
		entryCompletion: anEntryCompletion! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newGroupbox: aString
	"Answer a groupbox with the given label."

	^self theme
		newGroupboxIn: self
		label: aString! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title
	"Answer a new pluggable dialog with the given content."

	^self
		newPluggableDialogWindow: title
		for: nil! !

!StandardWindow methodsFor: 'layout' stamp: ''!
layoutBounds
	"Bounds of pane area only."
	
	^self isFullscreen
		ifTrue: [self perform: #layoutBounds withArguments: #() inSuperclass: Morph]
		ifFalse: [super layoutBounds]! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: nil 
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a bracket slider with the given selectors."

	^self theme
		newBracketSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseFont
	"Answer the result of a font selector dialog."

	^self chooseFont: nil! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newExpander: aString forAll: controls
	"Answer an expander with the given label and controls."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: controls! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		label: (AlphaImageMorph new image: aForm)
		help: helpText! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseExistingFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseExistingFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!StandardWindow methodsFor: 'initialize' stamp: ''!
withText: aStringOrText label: title 
	
	self title: title.
	self 
		addMorph: (RubScrolledTextMorph new 
				setText: aStringOrText asString;
				yourself)
		fullFrame: LayoutFrame identity.						
	self themeChanged.! !

!StandardWindow methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText
	"Open a question dialog."

	^self questionWithoutCancel: aStringOrText title: 'Question' translated! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseColor: aColor 
	"Answer the result of a color selector dialog with the given color."

	^self theme
		chooseColorIn: self
		title: 'Colour Selector' translated
		color: aColor! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseDirectory: title 
	"Answer the result of a file dialog with the given title, answer a directory."

	^self
		chooseDirectory: title
		path: nil! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText list: aList
	"Open a drop list chooser dialog."

	^self
		chooseDropList: aStringOrText
		title: 'Choose' translated
		list: aList! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel ghostText: ghostText getEnabled: enabledSel help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: String
		default: ''
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: false
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel 
		help: helpText! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseForSaveFileReference: 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
		chooseForSaveFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector
	"Answer a new tree morph."
	
	^self theme
		newTreeIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newWindowFor: aModel title: titleString
	"Answer a new window morph."
	
	^self theme
		newWindowIn: self
		for: aModel
		title: titleString! !

!StandardWindow methodsFor: 'open/close' stamp: ''!
open
	"Where else would you want to open it?."

	self openInWorld! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newToolbar: controls
	"Answer a toolbar with the given controls."

	^self theme
		newToolbarIn: self
		for: controls! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newOKButtonFor: aModel getEnabled: enabledSel
	"Answer a new OK button."

	^self theme
		newOKButtonIn: self
		for: aModel
		getEnabled: enabledSel! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newStack
	"Answer a morph laid out as a stack."

	^self theme
		newStackIn: self
		for: #()! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newToolSpacer
	"Answer a tool spacer."

	^self theme
		newToolSpacerIn: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newTitle: aString for: control
	"Answer a morph laid out with a column with a title."

	^self theme
		newTitleIn: self
		label: aString
		for: control! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion

	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel 
		help: helpText
		entryCompletion: anEntryCompletion! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText
	"Answer an inremental slider with the given selectors."

	^self theme
		newIncrementalSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: min
		max: max
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText
	"Answer a slider with the given selectors."

	^self theme
		newSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: 0
		max: 1
		quantum: nil
		getEnabled: enabledSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newOKButtonFor: aModel
	"Answer a new OK button."

	^self
		newOKButtonFor: aModel
		getEnabled: nil! !

!StandardWindow methodsFor: 'morphic ui' stamp: ''!
mouseMove: evt
	"Handle a mouse-move event"

	self isFullscreen ifTrue: [^self]. "do nothing if fullscreen"
	^super mouseMove: evt! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newCancelButtonFor: aModel
	"Answer a new cancel button."

	^self theme
		newCancelButtonIn: self
		for: aModel! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector
	"Answer a text editor for the given model."

	^self theme
		newTextEditorIn: self
		for: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: menuSelector! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newSVSelector: aColor help: helpText
	"Answer a saturation-volume selector with the given color."

	^self theme
		newSVSelectorIn: self
		color: aColor
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newButtonLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new button text label."

	^self theme
		newButtonLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseFont: aFont 
	"Answer the result of a font selector dialog with the given initial font."

	^self theme
		chooseFontIn: self
		title: 'Font Selector' translated
		font: aFont! !

!StandardWindow methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString
	"Open an alert dialog."

	^self
		alert: aStringOrText
		title: aString
		configure: [:d | ]! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newString: aStringOrText
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: #plain! !

!StandardWindow methodsFor: 'controls' stamp: ''!
title: aString
	
	self setLabel: aString! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newTabGroup: labelsAndPages
	"Answer a tab group with the given tab labels associated with pages."

	^self theme
		newTabGroupIn: self
		for: labelsAndPages! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newButtonLabel: aString
	"Answer a new button text label."

	^self
		newButtonLabelFor: nil
		label: aString
		getEnabled: nil! !

!StandardWindow methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString entryText: defaultEntryText
	"Open a text entry dialog."

	^self theme
		textEntryIn: self
		text: aStringOrText
		title: aString
		entryText: defaultEntryText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a slider with the given selectors."

	^self theme
		newSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: min
		max: max
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: cornerSymbol! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newLabelGroup: labelsAndControls font: aFont labelColor: aColor
	"Answer a morph laid out with a column of labels and a column of associated controls.
	Controls having a vResizing value of #spaceFill will
	cause their row to use #spaceFill also, otherwise #shrinkWrap."

	^self theme
		newLabelGroupIn: self
		for: labelsAndControls
		font: aFont
		labelColor: aColor! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseForSaveFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseForSaveFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow
	"Answer a new pluggable dialog."

	^self
		newPluggableDialogWindow: 'Dialog'! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newExpander: aString for: aControl
	"Answer an expander with the given label and control."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: {aControl}! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newExpander: aString
	"Answer an expander with the given label."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: #()! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseExistingFileReference: 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
		chooseExistingFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self theme
		newRadioButtonIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		font: aFont
		help: helpText! !

!StandardWindow methodsFor: 'services' stamp: ''!
question: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionIn: self
		text: aStringOrText
		title: aString! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newCloseButtonFor: aModel
	"Answer a new close button."

	^self theme
		newCloseButtonIn: self
		for: aModel! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newFuzzyLabel: aString
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: nil
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: nil! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newRow
	"Answer a morph laid out as a row."

	^self theme
		newRowIn: self
		for: #()! !

!StandardWindow methodsFor: 'services' stamp: ''!
abort: aStringOrText title: aString
	"Open an error dialog."

	^self theme
		abortIn: self
		text: aStringOrText
		title: aString! !

!StandardWindow methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		alertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText
		entryCompletion: anEntryCompletion! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newNoButtonFor: aModel
	"Answer a new No button."

	^self theme
		newNoButtonIn: self
		for: aModel! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newOverflowRowForAll: aCollectionOfMorphs
	"Answer a new overflow row morph that provides a drop down for
	the given contents that are unable to fit the bounds."
	
	^self theme
		newOverflowRowIn: self
		forAll: aCollectionOfMorphs! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a morph list for the given model."

	^self theme
		newMorphListIn: self
		for: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText title: aString list: aList
	"Open a drop list chooser dialog."

	^self theme
		chooseDropListIn: self
		text: aStringOrText
		title: aString
		list: aList! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newYesButton
	"Answer a new Yes button."

	^self newYesButtonFor: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newHSVSelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVSelectorIn: self
		color: aColor
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: nil
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		getLabel: labelSel
		help: helpText! !

!StandardWindow methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		setLabel: self defaultLabel;
		setWindowColor: self defaultColor! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newPanel
	"Answer a new panel."

	^self theme
		newPanelIn: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newGroupbox: aString forAll: controls
	"Answer a groupbox with the given label and controls."

	^self theme
		newGroupboxIn: self
		label: aString
		forAll: controls! !

!StandardWindow methodsFor: 'services' stamp: ''!
proceed: aStringOrText
	"Open a proceed dialog."

	^self proceed: aStringOrText title: 'Proceed' translated! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a drop list for the given model."

	^self theme
		newDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newToolbarHandle
	"Answer a toolbar handle."

	^self theme
		newToolbarHandleIn: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newLabel: aString
	"Answer a new text label."

	^self
		newLabelFor: nil
		label: aString
		getEnabled: nil! !

!StandardWindow methodsFor: 'event handling' stamp: ''!
yellowButtonActivity: shiftState 
	"Do nothing."
	^ false! !

!StandardWindow methodsFor: 'operations' stamp: ''!
flash
	"Flash the window."
	
	(self hasProperty: #activeModalFlash) ifTrue: [ ^self ].
	self setProperty: #activeModalFlash toValue: true.
		
	[ 
		
		| oldColor newColor duration |
	
		oldColor := self fillStyle.
		newColor := self color alphaMixed: 0.5 with: Color white.
		duration := 0.
	
		2 timesRepeat: [
			duration milliSeconds asDuration wait.
			duration := 200.
			
			self color: newColor.
			
			duration milliSeconds asDuration wait.
			
			self color = newColor ifFalse: [ 
				"the color changed while waiting (theme changed)"
				oldColor := self fillStyle 
			].
		
			self fillStyle: oldColor.
		].
	
		self removeProperty: #activeModalFlash
	
	] fork.! !

!StandardWindow methodsFor: 'services' stamp: ''!
longMessage: aStringOrText title: aString
	"Open a (long) message dialog."

	^self theme
		longMessageIn: self
		text: aStringOrText
		title: aString! !

!StandardWindow methodsFor: 'testing' stamp: ''!
openedFullscreen
	"Should activate and update the layout."

	self allMorphs do: [:m | m layoutChanged].
	self activate! !

!StandardWindow methodsFor: 'services' stamp: ''!
centeredAlert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		centeredAlertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newToolDockingBar
	"Answer a tool docking bar."

	^self theme
		newToolDockingBarIn: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseColor: aColor title: title
	"Answer the result of a color selector dialog with the given title and initial colour."

	^self theme
		chooseColorIn: self
		title: title
		color: aColor! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newMultistateButton
	"Answer a new multistate button morph.
	To be usable it needs to have fill styles assigned to various states along
	with mouse-up/down actions."
	
	^self theme
		newMultistateButtonIn: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newOKButton
	"Answer a new OK button."

	^self newOKButtonFor: self! !

!StandardWindow methodsFor: 'initialize' stamp: ''!
defaultColor
	"Answer the default color/fill style for the receiver"
	
	^self theme windowColor! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newHueSelector: aModel getHue: getSel setHue: setSel help: helpText
	"Answer a hue selector with the given selectors."

	^self theme
		newHueSelectorIn: self
		for: aModel
		getHue: getSel
		setHue: setSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		getLabel: labelSel
		getEnabled: enabledSel! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a morph drop list for the given model."

	^self theme
		newMorphDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newGroupbox
	"Answer a plain groupbox."

	^self theme
		newGroupboxIn: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newEmbeddedMenu
	"Answer a new menu."

	^self theme
		newEmbeddedMenuIn: self
		for: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newHSVASelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVASelectorIn: self
		color: aColor
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 
	"Answer a text editor for the given model."

	^self 
		newTextEditorFor: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: nil! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newGroupboxFor: control
	"Answer a plain groupbox with the given control."

	^self theme
		newGroupboxIn: self
		for: control! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newDialogPanel
	"Answer a new main dialog panel."

	^self theme
		newDialogPanelIn: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newImageFor: aModel get: getSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newImageIn: self
		for: aModel
		get: getSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newGroupbox: aString for: control
	"Answer a groupbox with the given label and control."

	^self theme
		newGroupboxIn: self
		label: aString
		for: control! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newMenuFor: aModel
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: aModel! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newString: aStringOrText font: aFont style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: aFont
		style: aStyle! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel 
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newMenu
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText
	"Answer an alpha channel selector with the given selectors."

	^self theme
		newAlphaSelectorIn: self
		for: aModel
		getAlpha: getSel
		setAlpha: setSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		font: aFont
		help: helpText
		entryCompletion: anEntryCompletion! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: enabledSel
		help: helpText! !

!StandardWindow methodsFor: 'services' stamp: ''!
deny: aStringOrText
	"Open a denial dialog."

	^self deny: aStringOrText title: 'Access Denied' translated! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: aModel
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: enabledSel! !

!StandardWindow methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionWithoutCancelIn: self
		text: aStringOrText
		title: aString! !

!StandardWindow methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString
	"Open a text entry dialog."

	^self
		textEntry: aStringOrText
		title: aString
		entryText: ''! !

!StandardWindow methodsFor: 'submorphs - accessing' stamp: ''!
noteNewOwner: aMorph 
	"Go fullscreen if needed."

	super noteNewOwner: aMorph.
	(self isFullscreen and: [labelArea owner notNil]) ifTrue: [
		self
			beWithoutGrips;
			removeLabelArea;
			makeBorderless.
		(self submorphs size = 1 and: [self submorphs first isKindOf: PanelMorph])
			ifTrue: [self submorphs first roundedCorners: #()]]! !

!StandardWindow methodsFor: 'open/close' stamp: ''!
postOpenInWorld: aWorld

	self allMorphs do: [:m | m layoutChanged].
	super postOpenInWorld: aWorld! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!StandardWindow methodsFor: 'morphic ui' stamp: ''!
wantsRoundedCorners
	"Check to see if the property is set first."
	
	^self isFullscreen
		ifTrue: [false]
		ifFalse: [^super wantsRoundedCorners]! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newText: aStringOrText
	"Answer a new text."

	^self theme
		newTextIn: self
		text: aStringOrText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
title
	
	^self label! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self
		newRadioButtonFor: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!StandardWindow methodsFor: 'morphic ui' stamp: ''!
defaultLabel
	"Answer the default label for the receiver."

	^'Window' translated! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText
	"Answer a drop list for the given model."

	^self
		newDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		useIndex: true
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newRow: controls
	"Answer a morph laid out with a row of controls."

	^self theme
		newRowIn: self
		for: controls! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		getLabel: labelSel
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newColumn: controls
	"Answer a morph laid out with a column of controls."

	^self theme
		newColumnIn: self
		for: controls! !

!StandardWindow methodsFor: 'testing' stamp: ''!
isFullscreen
	"Answer whether the window should be draw as fullscreen, i.e.
	no title bar or borders."

	^self owner isKindOf: FullscreenMorph! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newSliderFor: aModel getValue: getSel setValue: setSel help: helpText
	"Answer a slider with the given selectors."

	^self theme
		newSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: 0
		max: 1
		quantum: nil
		getEnabled: nil
		help: helpText! !

!StandardWindow methodsFor: 'services' stamp: ''!
chooseDirectory: title path: path
	"Answer the result of a file dialog with the given title, answer a directory."

	^self theme
		chooseDirectoryIn: self
		title: title
		path: path! !

!StandardWindow methodsFor: 'services' stamp: ''!
alert: aStringOrText
	"Open an alert dialog."

	^self alert: aStringOrText title: 'Alert' translated! !

!StandardWindow methodsFor: 'services' stamp: ''!
proceed: aStringOrText title: aString
	"Open a proceed dialog and answer true if not cancelled, false otherwise."

	^self theme
		proceedIn: self
		text: aStringOrText
		title: aString! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newCloseControlFor: aModel action: aValuable help: helpText
	"Answer a new cancel button."

	^self theme
		newCloseControlIn: self
		for: aModel
		action: aValuable
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newButtonFor: aModel action: actionSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: nil 
		label: stringOrText
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newCloseButton
	"Answer a new close button."

	^self newCloseButtonFor: self! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newImage: aForm size: aPoint
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm
		size: aPoint! !

!StandardWindow methodsFor: 'accessing' stamp: ''!
model: anObject
	"Reset the minimum extent."

	super model: anObject.
	self title: self title! !

!StandardWindow methodsFor: 'services' stamp: ''!
abort: aStringOrText
	"Open an error dialog."

	^self abort: aStringOrText title: 'Error' translated! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		useIndex: true
		help: helpText! !

!StandardWindow methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a drop list for the given model."

	^self theme
		newDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!StandardWindow class methodsFor: 'instance creation' stamp: ''!
newWithTheme: aUITheme
	"Answer a new window with the given theme."

	^ self basicNew
		basicTheme: aUITheme;
		initialize! !

!StandardWindow class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!StandardWindow class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!StandardWindow class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!StandardWindow class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!StandardWindow class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!StandardWindow class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!StandardWindow class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!StandardWindow class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!StandardWindow class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!StandardWindow class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!StandardWindow class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!StandardWindow class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!StandardWindow class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!StandardWindow class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!StandardWindow class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!StandardWindow class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!StandardWindow class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!StandardWindow class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!StandardWindow class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!StandardWindow class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!StandardWindow class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!StandardWindow class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!StandardWindow class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!StandardWindow class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!StandardWindow class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!StandardWindow class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!StandardWindow class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!StandardWindow class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!StandardWindow class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!StartupAction commentStamp: ''!
I am an atomic item used to execute a portion of code at image startup.!
!StartupAction methodsFor: 'accessing' stamp: ''!
code

	^ code! !

!StartupAction methodsFor: 'comparing' stamp: ''!
= anObject

	anObject class = self class ifFalse: [ ^ false ].
	^ self code = anObject code and: [ self name = anObject name and: [ self runOnce = anObject runOnce ]]! !

!StartupAction methodsFor: 'accessing' stamp: ''!
hasBeenExecuted

	^ hasBeenExecuted ifNil: [ hasBeenExecuted := false ]! !

!StartupAction methodsFor: 'execution' stamp: ''!
execute

	| block correctlyExecuted |
	(self hasBeenExecuted and: [ self runOnce ]) ifTrue: [ ^ self ].
	block := self code isBlock
				ifTrue: [ self code ]
				ifFalse: [[ self class compiler evaluate: self code ]].
	correctlyExecuted := true. 
	block on: Halt, Error do: [ :ex | 
		StartupPreferencesLoader default errors add: {ex. self}.
		ex pass ].
	self hasBeenExecuted: correctlyExecuted.! !

!StartupAction methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream <<'a ' << self class name << '(' << self name << ')'! !

!StartupAction methodsFor: 'accessing' stamp: ''!
runOnce: anObject
	
	runOnce := anObject! !

!StartupAction methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!StartupAction methodsFor: 'accessing' stamp: ''!
name: anObject
	
	name := anObject! !

!StartupAction methodsFor: 'accessing' stamp: ''!
hasBeenExecuted: anObject
	
	hasBeenExecuted := anObject! !

!StartupAction methodsFor: 'accessing' stamp: ''!
runOnce

	^ runOnce ifNil: [ runOnce := false ]! !

!StartupAction methodsFor: 'accessing' stamp: ''!
code: anObject
	
	code := anObject! !

!StartupAction methodsFor: 'printing' stamp: ''!
storeOn: aStream

	aStream << self class name << ' name: '<< self name printString <<' code: ' << code printString.
	self runOnce ifTrue: [ aStream << ' runOnce: true']! !

!StartupAction class methodsFor: 'instance creation' stamp: ''!
name: nameOfItem code: code runOnce: aBoolean

	^ self new
		code: code;
		name: nameOfItem;
		runOnce: aBoolean;
		yourself! !

!StartupAction class methodsFor: 'instance creation' stamp: ''!
name: nameOfItem code: code

	^ self new
		code: code;
		name: nameOfItem;
		yourself! !

!StartupPreferencesHandler commentStamp: ''!
I manage the links of the chain of responsibilities to retrieve the good preference file.!
!StartupPreferencesHandler methodsFor: 'actions' stamp: ''!
lookInGeneralPreferencesFolder

	^ StartupPreferencesLoader preferencesGeneralFolder 
		ifNotNil: [ :folder | self lookInFolder:  folder forFilesMatching: '*.st' ].! !

!StartupPreferencesHandler methodsFor: 'actions' stamp: ''!
buildActionList
	"All found files will be executed."
	
	| directories |
	directories := OrderedCollection new.
	directories add: [ self lookInGeneralPreferencesFolder ].
	directories add: [ self lookInPreferencesVersionFolder ].
	directories add: [ self lookInImageFolder ].
	^ directories! !

!StartupPreferencesHandler methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	actions := self buildActionList.! !

!StartupPreferencesHandler methodsFor: 'private' stamp: ''!
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 isDirectory 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 ]! !

!StartupPreferencesHandler methodsFor: 'private' stamp: ''!
lookInFolder: folder forFilesMatching: pattern

	| result files |
	result := OrderedCollection new.
	folder isDirectory ifFalse: [ ^ nil ].
	
	files := folder filesMatching: pattern.
	files do: [ :e | result add: e ].

	^ result isEmpty
		ifTrue: [ nil ]
		ifFalse: [ result ]! !

!StartupPreferencesHandler methodsFor: 'actions' stamp: ''!
perform

	| results |
	results := OrderedCollection new.
	actions do: [:each |
		each value ifNotNil: [ :res |  results addAll: res ]
	].
	^ results
! !

!StartupPreferencesHandler methodsFor: 'actions' stamp: ''!
lookInPreferencesVersionFolder

	^ StartupPreferencesLoader preferencesVersionFolder 
		ifNotNil: [ :folder | 
			self 
				lookInFolder: folder
				forFilesMatching: '*.st' ].! !

!StartupPreferencesHandler methodsFor: 'actions' stamp: ''!
lookInImageFolder

	^ self 
		lookInFolder: FileSystem workingDirectory 
		forFilesMatching: StartupPreferencesLoader startupScriptName.! !

!StartupPreferencesLoader commentStamp: ''!
StartupPreferencesLoader searches for and executes .st files from certain locations such as Library/Preferences/pharo on Mac OS X.  

StartupPreferencesLoader looks within such locations for a 'pharo' folder. This contains the startup scripts common to all versions of Pharo, and also optionally a folder per Pharo version holding startup scripts suitable for that version only.  So a typical directory layout might be...

.../some/folders/pharo/Content/Resources/pharo.image.
.../some/folders/pharo/Content/Resources/startup.st
.../some/folders/.config/pharo/author.st
.../some/folders/.config/pharo/useSharedCache.st
.../some/folders/.config/pharo/1.4/mystartupFor14only.st
.../some/folders/.config/pharo/2.0/mystartupFor20only.st

(**Note however that '.config' is an invalid filename on Windows, so '..config' is used instead)

To know the real values for you...
Print the result of "StartupPreferencesLoader preferencesGeneralFolder" which holds the startup scripts common to all versions of Pharo.
Print the result of "StartupPreferencesLoader preferencesVersionFolder" which holds the startup scripts specific to the version of the current image.

-----------


StartupPreferencesLoader example

will define a script sample startup.st in your unix root on unix 

Its contents is 

StartupPreferencesLoader default executeAtomicItems: {
	StartupAtomicItem name: 'Open Help' code: 'Workspace openContents: ''Here is just an example of how to use the StartupPreferencesLoader.
I should only be displayed once.
	
You can also see StartupPreferencesLoader class>>#example'' label: ''Help''' isSingleton: true.
	StartupAtomicItem name: 'Open Workspace' code: 'Workspace openContents: ''I should be displayed each time'''.
}

EXAMPLE 1
============

	" an example of script generation "
	| item1 item2 |
	item1 := StartupAction name: 'Open Help' code: 'Smalltalk tools workspace openContents: ''Here is just an example of how to use the StartupPreferencesLoader.
I should only be displayed once.
	
 You can also see StartupPreferencesLoader class>>#example'' label: ''Help''' runOnce: true.
	item2 := StartupAction name: 'Open Workspace' code:  [ Workspace openContents: 'I should be displayed each time' ].
	StartupPreferencesLoader default addAtStartupInGeneralPreferenceFolder: {item1. item2}.
	
	StartupPreferencesLoader default loadFromDefaultLocations.
	StartupPreferencesLoader default loadFromDefaultLocations.

EXAMPLE 2
============

	" it's my personal script provided as example"
	| items |
	items := OrderedCollection new.
	items add: (StartupAction name: 'Set the Author' code: [ Author fullName: Author fullName printString ]). "replace it by your name"
	
	StartupPreferencesLoader default addAtStartupInPreferenceVersionFolder: items named: 'author.st'.
	items removeAll.
	
	items add: (StartupAction name: 'Dragging Option' code: [ UITheme defaultSettings fastDragging: true ]).
	items add: (StartupAction name: 'Dialog Auto Accept' code: [ TextEditorDialogWindow autoAccept: true ]).
	StartupPreferencesLoader default addAtStartupInPreferenceVersionFolder: items named: 'settings.st'.
	items removeAll.
	
	items add: (StartupAction name: 'Fonts option' code: [ FreeTypeSystemSettings loadFt2Library: true.	
	FreeTypeFontProvider current updateFromSystem.
	StandardFonts defaultFont: (LogicalFont familyName: 'Lucida Grande' pointSize: 10) forceNotBold.
	GraphicFontSettings resetAllFontToDefault.
	StandardFonts codeFont: (LogicalFont familyName: 'Consolas' pointSize: 10).] runOnce: true).
	
	StartupPreferencesLoader default addAtStartupInPreferenceVersionFolder: items named: 'fonts.st'.
	items removeAll.
	StartupPreferencesLoader default addAtStartupInImageDirectory: items.
	
	StartupPreferencesLoader default loadFromDefaultLocations.

EXAMPLE 3
============

	| items |
	items := OrderedCollection new.
	
	items add: (StartupAction name: 'General Preferences for all Pharo versions' code: [ 
		FileStream stdout lf; nextPutAll: 'Setting general preferences for all Pharo versions'; lf.
		FileStream stdout lf; nextPutAll: 'Finished'; lf.
		 ]).
	StartupPreferencesLoader default addAtStartupInGeneralPreferenceFolder: items named: 'generalSettings.st'.
	
	items removeAll.
	items add: (StartupAction name: 'Settings' code: [ 
		FileStream stdout lf; nextPutAll: 'Setting general preferences for Pharo 2.0'; lf.
		FileStream stdout lf; nextPutAll: 'Finished'; lf.
		 ]).
	StartupPreferencesLoader default addAtStartupInPreferenceVersionFolder: items named: 'settings.st'.
	
	items removeAll.
	items add: (StartupAction name: 'Image diretory' code: [ 
		FileStream stdout lf; nextPutAll: 'Setting preferences for image directory'; lf.
		FileStream stdout lf; nextPutAll: 'Finished'; lf.
		 ]).
	StartupPreferencesLoader default addAtStartupInImageDirectory: items !
!StartupPreferencesLoader methodsFor: 'accessing' stamp: ''!
add: anAction
	| action |
	action := actions at: anAction name ifAbsentPut: [ anAction ].
	"make sure the possible existing action ueses new code or
	changed runOnce-behavior"
	action code: anAction code.
	action runOnce: anAction runOnce.
	^ action! !

!StartupPreferencesLoader methodsFor: 'script generation' stamp: ''!
addAtStartupInPreferenceVersionFolder: aCollection named: fileName
	self 
		addAtStartup: aCollection 
		inDirectory: self preferencesVersionFolder 
		named: fileName! !

!StartupPreferencesLoader methodsFor: 'script generation' stamp: ''!
addAtStartupInImageDirectory:  aCollection
	self 
		addAtStartup: aCollection 
		inDirectory: FileSystem workingDirectory 
		named: self class startupScriptName
! !

!StartupPreferencesLoader methodsFor: 'accessing' stamp: ''!
actions

	^ actions! !

!StartupPreferencesLoader methodsFor: 'private' stamp: ''!
buildStreamFor: aCollection
	^ String
		streamContents:
			[ :stream | 
			stream
				nextPutAll: 'StartupPreferencesLoader default executeAtomicItems: {';
				crlf.
			aCollection
				do: [ :item | 
					stream
						tab;
						nextPutAll: item storeString;
						nextPut: $.;
						crlf ].
			stream
				nextPut: $};
				nextPut: $.;
				crlf;
				crlf ]! !

!StartupPreferencesLoader methodsFor: 'cleaning' stamp: ''!
cleanSavedActionsAndErrors
	actions := Dictionary new. 
	errors := OrderedCollection new. ! !

!StartupPreferencesLoader methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	actions := Dictionary new. 
	errors := OrderedCollection new. ! !

!StartupPreferencesLoader methodsFor: 'utilities' stamp: ''!
preferencesGeneralFolder

	^ self class preferencesGeneralFolder.! !

!StartupPreferencesLoader methodsFor: 'cleaning' stamp: ''!
removeAllScriptsFromAllDirectories
	self removeScriptFromImageDirectory.
	self removeAllScriptsFromPreferencesVersionDirectory.
	self removeAllScriptsFromGeneralPreferencesDirectory.
! !

!StartupPreferencesLoader methodsFor: 'private' stamp: ''!
addAtStartup: aCollection inDirectory: aFileReference named: fileName
	aFileReference ensureCreateDirectory.
	aFileReference / fileName writeStreamDo: [ :stream | stream nextPutAll: (self buildStreamFor: aCollection) ]! !

!StartupPreferencesLoader methodsFor: 'utilities' stamp: ''!
preferencesVersionFolder

	^ self class preferencesVersionFolder.! !

!StartupPreferencesLoader methodsFor: 'script generation' stamp: ''!
addAtStartupInPreferenceVersionFolder: aCollection 
	self 
		addAtStartup: aCollection 
		inDirectory: self preferencesVersionFolder 
		named: self class startupPreferencesVersionFolderScriptName! !

!StartupPreferencesLoader methodsFor: 'cleaning' stamp: ''!
removeAllScriptsFromDirectory: aDirectory
	aDirectory deleteAllChildren! !

!StartupPreferencesLoader methodsFor: 'cleaning' stamp: ''!
removeScriptFromImageDirectory
	(FileSystem workingDirectory / self class startupScriptName) delete.
! !

!StartupPreferencesLoader methodsFor: 'startup loading' stamp: ''!
loadFromDefaultLocations
	self class allowStartupScript ifFalse: [ ^ self ].
	
	[ self load: self retrieveFilesStream ]
		on: StartupPreferencesLoadingError
		do: [ :ex | ex return ]! !

!StartupPreferencesLoader methodsFor: 'startup loading' stamp: ''!
retrieveFilesStream

	^ StartupPreferencesHandler new perform! !

!StartupPreferencesLoader methodsFor: 'cleaning' stamp: ''!
removeAllScriptsFromPreferencesVersionDirectory
	self removeAllScriptsFromDirectory: self preferencesVersionFolder.

! !

!StartupPreferencesLoader methodsFor: 'script generation' stamp: ''!
addAtStartupInGeneralPreferenceFolder: aCollection named: fileName
	self 
		addAtStartup: aCollection 
		inDirectory: self preferencesGeneralFolder 
		named: fileName! !

!StartupPreferencesLoader methodsFor: 'script generation' stamp: ''!
addAtStartupInGeneralPreferenceFolder: aCollection 
	self 
		addAtStartup: aCollection 
		inDirectory: self preferencesGeneralFolder 
		named: self class startupGeneralPreferencesFolderScriptName! !

!StartupPreferencesLoader methodsFor: 'private' stamp: ''!
load: aCollection
	errors removeAll.
	aCollection do: [:file | file fileIn ].! !

!StartupPreferencesLoader methodsFor: 'cleaning' stamp: ''!
removeAllScriptsAndCleanSavedActions
	self removeAllScriptsFromAllDirectories.
	self cleanSavedActionsAndErrors.
	! !

!StartupPreferencesLoader methodsFor: 'cleaning' stamp: ''!
removeAllScriptsFromGeneralPreferencesDirectory
	self removeAllScriptsFromDirectory: self preferencesGeneralFolder.
	
	
! !

!StartupPreferencesLoader methodsFor: 'code execution' stamp: ''!
executeAtomicItems: aCollection
	"No sender but send from the generated script"

	'Load Startup Preferences'
		displayProgressFrom: 0 to: aCollection size
		during: [:bar | 
			aCollection doWithIndex: [:item :index | 
				bar current: index.
				(self add: item) execute ]]! !

!StartupPreferencesLoader methodsFor: 'accessing' stamp: ''!
errors

	^ errors! !

!StartupPreferencesLoader class methodsFor: 'instance creation' stamp: ''!
new

	^ self error: 'use #default instead'! !

!StartupPreferencesLoader class methodsFor: 'private' stamp: ''!
preferencesGeneralFolder

	^ [ FileLocator preferences asFileReference / 'pharo' ]
		on: Error
		do: [ :ex |
			"Non NB-VMs will fail with a generic error"		
			StartupPreferencesLoadingError signal ]! !

!StartupPreferencesLoader class methodsFor: '*System-Settings-Browser' stamp: ''!
startupLoaderMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #SystemStartupLoader)
		action: [ self default loadFromDefaultLocations ];
		label: 'Run startup scripts';
		parent: #SystemStartup;
		order: 1;
		help: 'Run startup scripts.';
		iconName: #scriptManagerIcon.
	aBuilder withSeparatorAfter! !

!StartupPreferencesLoader class methodsFor: '*System-Settings-Browser' stamp: ''!
startupPreferencesVersionFolderMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #SystemStartupFolder)
		action: [ self preferencesVersionFolder
				ensureCreateDirectory;
				inspect ];
		label: 'Version Preferences folder';
		parent: #SystemStartup;
		order: 2;
		help: 'Open the preferences per version folder.';
		iconName: #smallOpenIcon! !

!StartupPreferencesLoader class methodsFor: 'setting' stamp: ''!
startupPreferencesSettingsOn: aBuilder
	<systemsettings>
	
	(aBuilder setting: #allowStartupScript)
		label: 'Allow the preferences to be loaded at startup';
		parent: #pharoSystem;
		default: true;
		target: self;
		description: 'If true, the preferences will be loaded' .! !

!StartupPreferencesLoader class methodsFor: 'cleanup' stamp: ''!
cleanUp: aggressive
	self reset! !

!StartupPreferencesLoader class methodsFor: 'private' stamp: ''!
preferencesVersionFolder

	^ self preferencesGeneralFolder 
		ifNotNil: [ :folder | folder / SystemVersion current dottedMajorMinor ]! !

!StartupPreferencesLoader class methodsFor: 'private' stamp: ''!
startupScriptName

	^ 'startup.st'! !

!StartupPreferencesLoader class methodsFor: 'private' stamp: ''!
startupGeneralPreferencesFolderScriptName

	^ 'startupPharo.st'! !

!StartupPreferencesLoader class methodsFor: '*System-Settings-Browser' stamp: ''!
startupGeneralPrefererencesFolderMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #SystemStartupFolder)
		action: [ self preferencesGeneralFolder inspect ];
		label: 'General Preferences folder';
		parent: #SystemStartup;
		order: 3;
		help: 'Open the folder with general preferences.';
		iconName: #smallOpenIcon! !

!StartupPreferencesLoader class methodsFor: 'instance creation' stamp: ''!
default

	^ UniqueInstance ifNil: [ UniqueInstance := super basicNew initialize ]! !

!StartupPreferencesLoader class methodsFor: 'accessing' stamp: ''!
allowStartupScript: aBoolean

	AllowStartupScript := aBoolean! !

!StartupPreferencesLoader class methodsFor: 'accessing' stamp: ''!
allowStartupScript

	^ AllowStartupScript ifNil: [ AllowStartupScript := true ]! !

!StartupPreferencesLoader class methodsFor: '*System-Settings-Browser' stamp: ''!
systemStartupMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #SystemStartup)
		label: 'Startup';
		parent: #Startup;
		order: 2;
		help: 'System startup related.';
		iconName: #scriptManagerIcon! !

!StartupPreferencesLoader class methodsFor: 'class initialization' stamp: ''!
reset

	UniqueInstance := nil! !

!StartupPreferencesLoader class methodsFor: 'private' stamp: ''!
startupPreferencesVersionFolderScriptName

	^ 'startupPharo', SystemVersion current dottedMajorMinor,'.st'! !

!StartupPreferencesLoadingError commentStamp: ''!
I represent an unrecoverable exceptional event while trying to load preferences during startup. I should be handled by the public methods of StartupPreferencesLoader.!
!StartupUIManager commentStamp: ''!
I am a non interactive UI manager that is used only during image startup, where parts of the system are not fully initialized yet.!
!StartupUIManager methodsFor: 'ui requests' stamp: ''!
inform: aString
	(ProvideAnswerNotification signal: aString) 
		ifNotNil: [:answer | ^true].
	self sessionManager 
		addDeferredStartupAction: [ UIManager default inform: aString ].! !

!StartupUIManager methodsFor: 'error handling' stamp: ''!
sessionManager
	^ SessionManager default! !

!StartupUIManager methodsFor: 'private' stamp: ''!
activate
	"override to exclude the superclass' behavior"! !

!StartupUIManager methodsFor: 'error handling' stamp: ''!
handleError: anError log: shouldLog
	"We should log only the first time that the error is handled. Then, the deferred startup action never asks to log: either we never were asked to log (shouldLog=true) or we logged in the super send."

	self flag: #pharoTodo. "Maybe we should only catch Errors and not Exceptions in WorkingSession>>#runList:do:"
	
	super handleError: anError log: shouldLog.
	(anError isKindOf: Notification) 
		ifTrue:  [ anError resume ] 
		ifFalse: [ anError freeze.
						self sessionManager
						addDeferredStartupAction: [ self uiManager handleError: anError log: false ]].! !

!StartupUIManager class methodsFor: 'testing' stamp: ''!
isValidForCurrentSystemConfiguration

	^ false! !

!Stdio commentStamp: ''!
I am a facade class to access standard output streams:

- standard input
- standard output
- standard error

I initialize standard streams in a lazy fashion, asking to the VM for the #stdioHandles. I cache those standard streams and release them on shutdown.

The possible scenarios, i.e. for each of stdin, stderr and stdout:

    the stream is attached to a terminal (default on posix platforms, PharoConsole.exe on Windows (see below for Pharo.exe))
    the stream is redirected to a normal file, e.g. pharo pharo.image > output.txt
    the stream is redirected to a pipe, e.g. pharo pharo.image | tee output.txt

To know exactly which kind of stream you are using, you can use File >> #fileDescriptorType: (args are 0 1 2 for the stdios).


Windows Subtleties
=====================

If launched as a desktop app (not from the console), Pharo.exe will not be linked to external streams because none is created. To overcome that, the default behavior of this class is to create a normal file for the three stdio. This can be modified to:
	not create a file (execute #useNullStreams)
	use a memory stream (execute #useMemoryStreams).!
!Stdio class methodsFor: 'stdio' stamp: 'nil'!
useDefaultStreams
	<script>
	self createWriteStreamBlock: [ :aName | (File named: aName asString) writeStream ]! !

!Stdio class methodsFor: '*FileSystem-Memory' stamp: ''!
useMemoryStreams
	<script>
	self createWriteStreamBlock: [ :aName | (FileSystem memory / aName asString) writeStream ]! !

!Stdio class methodsFor: 'stdio' stamp: 'nil'!
useNullStreams
	<script>
	self createWriteStreamBlock: [ NullStream new ]! !

!Stdio class methodsFor: 'class initialization' stamp: 'nil'!
initialize
	SessionManager default
		registerSystemClassNamed: self name! !

!Stdio class methodsFor: 'private' stamp: 'nil'!
createStdioFileFor: moniker
	^ [[ self createWriteStreamBlock cull: moniker asString ]
		on: CannotDeleteFileException
		do:
			[ "HACK: if the image is opened a second time windows barks about the already opened locked file"
			 self createWriteStreamBlock
				cull: moniker asString , '_' , (Random new nextInteger: SmallInteger maxVal) asString ]
	 ] on: FileException do: [ NullStream new ]! !

!Stdio class methodsFor: 'accessing' stamp: 'nil'!
stdout

	^ Stdout ifNil: [ Stdout := self standardIOStreamNamed: #stdout forWrite: true ].! !

!Stdio class methodsFor: 'accessing' stamp: 'nil'!
createWriteStreamBlock: aBlock
	"Can be changed to any block that returns a writeStream"

	CreateWriteStreamBlock := aBlock.
	self cleanStdioHandles! !

!Stdio class methodsFor: 'accessing' stamp: 'nil'!
createWriteStreamBlock

	^ CreateWriteStreamBlock
		ifNil: [ self useDefaultStreams.
			CreateWriteStreamBlock ]! !

!Stdio class methodsFor: 'stdio' stamp: 'nil'!
standardIOStreamNamed: moniker forWrite: forWrite
	"Create the requested stdio (#stdin, #stdout, #stderr) if possible.
	On Windows, if stdio is not available, create a regular file instead."

	| handle streamIndex |

	streamIndex := #(stdin stdout stderr) identityIndexOf: moniker.
	handle := File stdioHandles at: streamIndex.
	(handle isNil or: [ (File fileDescriptorIsAvailable: streamIndex-1) not ]) ifTrue: [ 
		"On windows, create a file for stdio, error on other platforms"
		Smalltalk os isWindows 
			ifTrue: [ ^ self createStdioFileFor: moniker ]
			ifFalse: [ self error: moniker , ' is unavailable' ] ].
	^ StdioStream handle: handle file: (File named: moniker) forWrite: forWrite! !

!Stdio class methodsFor: 'accessing' stamp: 'nil'!
stdin

	^ Stdin ifNil: [ Stdin := self standardIOStreamNamed: #stdin forWrite: false ].! !

!Stdio class methodsFor: 'accessing' stamp: 'nil'!
stderr
	^ Stderr ifNil: [ Stderr := self standardIOStreamNamed: #stderr forWrite: true ]! !

!Stdio class methodsFor: 'private' stamp: 'nil'!
cleanStdioHandles

	Stderr := Stdin := Stdout := nil! !

!Stdio class methodsFor: 'system startup' stamp: 'nil'!
startUp: resuming

	resuming ifTrue: [ self cleanStdioHandles ].! !

!StdioStream commentStamp: ''!
I am a concrete subclass of AbstractBinaryFileStream for stdio streams.

StdioStreams map to one of three types of underlying file: 

- Terminal input/output.
- Piped input/output and named pipes (FIFO files) such as created with the shell pipe character "|".
- A file mounted on the file system.
  This includes all the files that can be opened with a FileReference, including sysfs files such as /proc/cpuinfo and character devices such as /dev/urandom.

The operations that can be performed on these vary, e.g. it is possible to position the stream for a regular file, but not for piped input.  Currently it is up to the user of StdioStream to know which type of input they are dealing with.

As pipes can't be positioned and FilePlugin doesn't provide a peek primitive, simulate #peek by reading the next character and holding on to it until it is consumed.

Despite providing both input and output methods, StdioStreams are either read-only or write-only.  Currently it is up to the user to know which type of stream they are dealing with.

Normally instances of StdioStream are not created directly but via Stdio, e.g: 

Stdio stdin.
Stdio stdout.
Stdio stderr.


Instance Variables:

- peekBuffer     <SmallInteger or nil> The next character to be read from the stream or nil.!
!StdioStream methodsFor: 'accessing' stamp: 'nil'!
next: n
	"Return a string with the next n characters of the filestream in it."
	| readBuffer read startingAt |
	readBuffer := ByteArray new: n.
	startingAt := 1.
	peekBuffer ifNotNil: [ 
		readBuffer at: 1 put: peekBuffer.
		startingAt := startingAt + 1.
		peekBuffer := nil ].
	read := File read: handle into: readBuffer startingAt: startingAt count: n - startingAt + 1.
	^read = (n - startingAt + 1)
		ifTrue: [ readBuffer ]
		ifFalse: [ readBuffer copyFrom: 1 to: read ]! !

!StdioStream methodsFor: 'accessing' stamp: 'nil'!
peek
	"Answer the next element of the stream, but do not advance the stream pointer. 
	If the receiver is at the end, answer nil."

	self atEnd ifTrue: [ ^ nil ].
	peekBuffer ifNotNil: [ ^ peekBuffer ].
	^ peekBuffer := self next! !

!StdioStreamTest commentStamp: ''!
Automated tests for StdioStream


Public API and Key Messages

- StdioStreamTest is a subclass of TestCase and has the same public api
 
Internal Representation and Key Implementation Points.

StdioStreamTest relies on a test stream constructed by StdioStreamTestResource.!
!StdioStreamTest methodsFor: 'tests' stamp: ''!
testContents

	self assert: self stdioStream contents equals: self resource contents asByteArray! !

!StdioStreamTest methodsFor: 'accessing' stamp: ''!
stdioStream

	^self resource stdioStream! !

!StdioStreamTest methodsFor: 'tests' stamp: ''!
testPeek

	| stream |

	stream := self stdioStream.
	self assert: stream peek equals: $0 asciiValue.
	self assert: stream peek equals: stream next! !

!StdioStreamTest methodsFor: 'tests' stamp: ''!
testUpToEnd

	| stream contents |

	stream := self stdioStream.
	contents := self resource contents.
	"Position stream (zero based)"
	stream position: 5.
	"Copy from contents (one based)"
	self assert: stream upToEnd 
		equals: (contents copyFrom: 6 to: contents size) asByteArray! !

!StdioStreamTest methodsFor: 'tests' stamp: ''!
testAtEnd
	"Test that #atEnd isn't incorrectly answering true"

	self deny: self stdioStream atEnd! !

!StdioStreamTest methodsFor: 'accessing' stamp: ''!
resource
	"Answer the receiver's resource object"

	^StdioStreamTestResource current! !

!StdioStreamTest methodsFor: 'tests' stamp: ''!
testSize

	self assert: self stdioStream size equals: self resource contents size! !

!StdioStreamTest methodsFor: 'tests' stamp: ''!
testChangePosition
	"The shared stream should be put back to the start for each test"

	| stream |
	
	stream := self stdioStream.
	stream position: 5.
	self assert: stream position equals: 5.
	self assert: stream next equals: $5 asciiValue! !

!StdioStreamTest methodsFor: 'tests' stamp: ''!
testPosition
	"The shared stream should be put back to the start for each test"
	
	self assert: self stdioStream position equals: 0! !

!StdioStreamTest methodsFor: 'running' stamp: ''!
setUp
	"A stream is shared amongst all the tests to reduce file create, write, delete cycles.
	Ensure the stream is in the expected state."

	super setUp.
	self resource stdioStream position: 0.! !

!StdioStreamTest class methodsFor: 'tests - manual' stamp: ''!
manualStdinTest
	"This test can be run headless to manually to check actual stdin.
	It reads the input and confirms that #atEnd answers as expected and the number of characters read.
	
	Example execution (from the shell prompt):

		echo 'hello world' | pharo --headless Pharo.image eval 'StdioStreamTest manualStdinTest'
		
		pharo --headless Pharo.image eval 'StdioStreamTest manualStdinTest' < /proc/cpuinfo
		
		pharo --headless Pharo.image eval 'StdioStreamTest manualStdinTest'
		# Type some text, enter and Ctrl-D"

	| stdin stdout atEndBefore atEndAfter contents |

	stdin := Stdio stdin.
	stdout := ZnNewLineWriterStream on: Stdio stdout.
	atEndBefore := stdin atEnd.
	contents := stdin upToEnd.
	atEndAfter := stdin atEnd.
	stdout
		<< '#atEnd (before): ';
		<< atEndBefore displayString;
		cr;
		<< '#atEnd (after): ';
		<< atEndAfter displayString;
		cr;
		<< 'Size: ';
		<< contents size displayString;
		cr;
		<< 'Contents:';
		cr; cr.
	contents hexDumpOn: stdout max: 128.
	stdout cr.
	SmalltalkImage current snapshot: false andQuit: true.! !

!StdioStreamTest class methodsFor: 'accessing' stamp: ''!
resources

	^{ StdioStreamTestResource }.! !

!StdioStreamTestResource commentStamp: ''!
StdioStreamTestResource provides a StdioStream to test for StdioStreamTest.

As redirecting stdio during testing isn't practical a normal file is opened and an instance StdioStream attached to it.  This provides the same result as: 

	pharo test.image < tmpfile.binary 
	pharo test.image > tmpfile.binary

StdioStreams normally cannot be both read and written, and the tests must take that into account.

Public API and Key Messages

- message one   
- message two 
- (for bonus points) how to create instances.

   One simple example is simply gorgeous.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	fileReference:		<Object>
	stdioStream:		<Object>


    Implementation Points!
!StdioStreamTestResource methodsFor: 'accessing' stamp: ''!
fileStream

	^ fileStream! !

!StdioStreamTestResource methodsFor: 'running' stamp: ''!
tearDown
	"Close the receiver's resources"
	
	stdioStream := nil.
	fileStream close.
	fileReference ensureDelete! !

!StdioStreamTestResource methodsFor: 'accessing' stamp: ''!
stdioStream
	^ stdioStream! !

!StdioStreamTestResource methodsFor: 'accessing' stamp: ''!
fileReference

	^ fileReference! !

!StdioStreamTestResource methodsFor: 'accessing' stamp: ''!
contents

	^ contents! !

!StdioStreamTestResource methodsFor: 'running' stamp: ''!
setUp
	"Create the temporary file and StdioStream"

	| handle |

	fileReference := FileReference newTempFilePrefix: 'StdioStreamTest.' suffix: '.bin'.
	contents := '01234567890123456789'.
	
	fileStream := (File named: fileReference pathString) openForWrite.
	fileStream
		nextPutAll: contents;
		position: 0.
	"NOTE: This makes assumptions about the internal structure of BinaryFileStream.
	This shouldn't be done in general."
	handle := fileStream instVarNamed: 'handle'.
	stdioStream := StdioStream handle: handle file: (File named: #stdio) forWrite: true! !

!StepIntoDebugAction commentStamp: ''!
A StepIntoDebugAction the current context.
!
!StepIntoDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 15! !

!StepIntoDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Step in the highlighted message, i.e. follow the sent message, taking debugger control in the method invoked.'! !

!StepIntoDebugAction methodsFor: 'actions' stamp: ''!
executeAction

	self session stepInto: self currentContext! !

!StepIntoDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #stepInto! !

!StepIntoDebugAction methodsFor: 'accessing' stamp: ''!
defaultKeymap

	^ PharoShortcuts current stepIntoShortcut! !

!StepIntoDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Step into'! !

!StepIntoDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<debuggingAction>
	<contextMenuDebuggingAction>! !

!StepIntoTest methodsFor: 'helper' stamp: ''!
callQuickMethodWithoutReturningItsResult
	self quickMethod.! !

!StepIntoTest methodsFor: 'helper' stamp: ''!
returnQuickMethodResult
	^ self quickMethod.! !

!StepIntoTest methodsFor: 'tests' stamp: ''!
testStepIntoQuickMethodCallNotReturnedShouldLeaveTheValueStackEmpty
	"Stepping into a quick method whose result is not used should leave the value stack empty"
	self settingUpSessionAndProcessAndContextForBlock: [ self callQuickMethodWithoutReturningItsResult].
	[session interruptedContext method == (self class>>#callQuickMethodWithoutReturningItsResult)] 
		whileFalse: [ session stepInto ].

	session stepInto.
	self
		assert: process suspendedContext method
		equals: self class >> #callQuickMethodWithoutReturningItsResult.
	self
		assert: process suspendedContext size
		equals: 0.! !

!StepIntoTest methodsFor: 'tests' stamp: ''!
testStepIntoQuickMethodCallReturnedShouldPushReturnValueToTheStack
	"Stepping into a call to a quick method whose result is used should push its return value to the stack"
	self settingUpSessionAndProcessAndContextForBlock: [ self returnQuickMethodResult].
	[session interruptedContext method == (self class>>#returnQuickMethodResult)] 
		whileFalse: [ session stepInto ].

	session stepInto.
	self
		assert: process suspendedContext method
		equals: self class >> #returnQuickMethodResult.
	self
		assert: process suspendedContext top
		equals: 1.! !

!StepIntoTest methodsFor: 'helper' stamp: ''!
stepA1
	^42! !

!StepIntoTest methodsFor: 'helper' stamp: ''!
quickMethod
	^1.! !

!StepIntoTest methodsFor: 'tests' stamp: ''!
testStepIntoDeadContextShouldRaiseException
	self settingUpSessionAndProcessAndContextForBlock: [  ].
	session stepInto. "The first step into executes the (empty) body of the block and returns from it. From this point on, the context is dead since it returned."
	
	"We should be able to call stepInto.
	However, calling it provokes infinite exceptions and non recuperable images."
	"session stepInto."
	
	"We have found that the debugSession calls stepToSendOrReturn after step: which could be the cause of the issue.
	This test is green if we avoid calling that part and just call step:"
	session interruptedProcess step: session interruptedContext.
	
	self assert: context isDead! !

!StepIntoTest methodsFor: 'tests' stamp: ''!
testStepIntoMethodCallShouldActivateIt
	"Stepping into a method call should create a context for it at the top of the context stack"
	self settingUpSessionAndProcessAndContextForBlock: [ self stepA1 ].
	[session interruptedContext method == (self class>>#stepA1)] 
		whileFalse: [ session stepInto ].

	self
		assert: process suspendedContext method
		equals: self class >> #stepA1! !

!StepIntoTest methodsFor: 'tests' stamp: ''!
testStepIntoUntilTermination 
	"Stepping over a message node brings the execution to the next node in the same method."
	self settingUpSessionAndProcessAndContextForBlock: [ #test ].

	[ session interruptedProcess isTerminated ] whileFalse: [ session stepInto ].

	self assert: session interruptedProcess isTerminated! !

!StepMessage commentStamp: ''!
I'm a MorphicAlarm to be queued in WorldState list of stepping actions. I hold the stepTime (refresh period) of my receiver / Morph (if nil, the #stepTime value of my receiver is used).

See 
- WordState>>runLocalStepMethodsIn:   (where the stepping actions are sent).
- WorldState>>startStepping:at:selector:arguments:stepTime:  (to queue a new StepMessage)

Example:

MorphicUIManager currentWorld
        startStepping: (Morph new openInWorld)
        at: Time millisecondClockValue
        selector: #toggleVisible
        arguments: nil
        stepTime: 500.!
!StepMessage methodsFor: 'stepping' stamp: ''!
stepTime: aNumber
	"Set the step time for this message. If nil, the receiver of the message will be asked for its #stepTime."
	stepTime := aNumber! !

!StepMessage methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream 
		nextPut: $(;
		print: receiver;
		space;
		print: selector;
		space;
		print: scheduledTime;
		nextPut: $).! !

!StepMessage methodsFor: 'stepping' stamp: ''!
stepTime
	"Return the step time for this message. If nil, the receiver of the message will be asked for its #stepTime."
	^stepTime! !

!StepMessage class methodsFor: 'instance creation' stamp: ''!
scheduledAt: scheduledTime stepTime: stepTime receiver: aTarget selector: aSelector arguments: argArray
	^(self receiver: aTarget selector: aSelector arguments: argArray)
		scheduledTime: scheduledTime;
		stepTime: stepTime! !

!StepOverDebugAction commentStamp: ''!
A StepOverDebugAction the current context.
!
!StepOverDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 20! !

!StepOverDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Step over the highlighted message, i.e. do not follow the sent message, taking debugger control after the method invoked returns.'! !

!StepOverDebugAction methodsFor: 'actions' stamp: ''!
executeAction

	self session stepOver: self currentContext! !

!StepOverDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #stepOver! !

!StepOverDebugAction methodsFor: 'accessing' stamp: ''!
defaultKeymap

	^ PharoShortcuts current stepOverShortcut! !

!StepOverDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Step over'! !

!StepOverDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<debuggingAction>
	<contextMenuDebuggingAction>! !

!StepOverTest methodsFor: 'tests' stamp: ''!
testStepOverLastNodeOfContext
	"Stepping over the last node of a method brings the execution to the method node of that method."
	| node |
	self settingUpSessionAndProcessAndContextForBlock: [ self stepB1 ].
	[session interruptedContext method == (self class>>#stepB1)] 
		whileFalse: [ session stepInto ].

	"Reached stepB1"
	session stepInto.
	"Reached stepB2"
	"Checking that the execution is at the 'self stepB3' node of the stepB2 method"
	self assert: session interruptedContext method equals: self class >>#stepB2.
	node := self class >>#stepB2 sourceNodeForPC: session interruptedContext pc.
	self assert: node receiver isSelfVariable.
	self assert: node selector equals: #stepB3.
	session stepOver.
	"Checking that after the stepOver, the execution is at the method node of the stepB2 method"
	self assert: session interruptedContext method equals: self class >>#stepB2.
	node := self class >>#stepB2 sourceNodeForPC: session interruptedContext pc.
	self assert: node isMethod.! !

!StepOverTest methodsFor: 'helper' stamp: ''!
stepB1
	self stepB2.
	^42.! !

!StepOverTest methodsFor: 'helper' stamp: ''!
stepA2
	^ True! !

!StepOverTest methodsFor: 'tests' stamp: ''!
stepC2
	1+1.
	^ 2! !

!StepOverTest methodsFor: 'tests' stamp: ''!
testStepOver
	"Stepping over a message node brings the execution to the next node in the same method."
	| node |
	self settingUpSessionAndProcessAndContextForBlock: [ self stepA1 ].
	[session interruptedContext method == (self class>>#stepA1)] 
		whileFalse: [ session stepInto ].

	"Reached stepA1"
	"Checking that the execution is at the 'self stepA2' node of the stepA1 method"
	self assert: session interruptedContext method equals: self class >>#stepA1.
	node := self class >>#stepA1 sourceNodeForPC: session interruptedContext pc.
	self assert: node receiver isSelfVariable.
	self assert: node selector equals: #stepA2.
	session stepOver.
	"Checking if the stepOver stepped over the call to stepA2 and brought the execution to the return node of stepA1"
	self assert: session interruptedContext method equals: self class >>#stepA1.
	self assert: (self class>>#stepA1 sourceNodeForPC: session interruptedContext pc) isReturn.! !

!StepOverTest methodsFor: 'helper' stamp: ''!
stepA1
	self stepA2.
	^ 42.! !

!StepOverTest methodsFor: 'tests' stamp: ''!
testErrorSignalledDuringStepOverShouldBeCaught
	"An Error signaled while being steppedOver should not be unhandled"
	self settingUpSessionAndProcessAndContextForBlock: [ Error signal: 'hey'. ].
	self shouldnt: [[ session interruptedProcess isTerminated ] whileFalse: [ session stepOver. ]] raise: Error.! !

!StepOverTest methodsFor: 'tests' stamp: ''!
stepC1
	self stepC2.! !

!StepOverTest methodsFor: 'tests' stamp: ''!
testStepOverComputedReturn
	"When doing a stepOver on a return node whose return value is already computed, the current context returns and the session goes to the message node responsible for the context that just returned" 
	"<-> indicates the node being executed
	Initial situation:
		#stepC2
			1+1
			<^2> 
		#stepC1
			<self stepC2>
	After a StepOver:
		#stepC1
			<self stepC2>
	"
	| node |
	self settingUpSessionAndProcessAndContextForBlock: [ self stepC1 ].
	self settingUpSessionAndProcessAndContextForBlock: [ self stepC1 ].
	[session interruptedContext method == (self class>>#stepC1)] 
		whileFalse: [ session stepInto ].

	"Reached stepC1"
	self assert: session interruptedContext method equals: self class >>#stepC1.
	session stepInto.
	"Reached stepC2"
	self assert: session interruptedContext method equals: self class >>#stepC2.
	session stepInto.
	"Reached ^2 node of stepC2"
	self assert: session interruptedContext method equals: self class >>#stepC2.
	self assert: (self class>>#stepC2 sourceNodeForPC: session interruptedContext pc) isReturn.
	session stepOver.
	"The initial step done by stepOver should return the stepC2 context, ending the stepOver in the stepC1 context, on the 'self stepC2' node"
	self assert: session interruptedContext method equals: self class >>#stepC1.
	node := self class >>#stepC1 sourceNodeForPC: session interruptedContext pc.
	self assert: node receiver isSelfVariable.
	self assert: node selector equals: #stepC2.! !

!StepOverTest methodsFor: 'tests' stamp: ''!
testSimulatedProcessIsInCorrectState
	"This test verifies that simulated process is created correctly using given block.
	Step over should execute first block instruction when it is correct"
	| executed |
	executed := false.
	self settingUpSessionAndProcessAndContextForBlock: [executed := true ].

	session stepOver.
	session stepOver.
	
	self assert: executed! !

!StepOverTest methodsFor: 'tests' stamp: ''!
testStepOverDoesNotUnderstand
	"Stepping over a message not understood should not raise an unhandled exception"
	self settingUpSessionAndProcessAndContextForBlock: [ self messageNotUnderstood].
	self shouldnt: [[ session interruptedProcess isTerminated ] whileFalse: [ session stepOver. ]] raise: Exception.! !

!StepOverTest methodsFor: 'helper' stamp: ''!
stepB3
	^ 42! !

!StepOverTest methodsFor: 'tests' stamp: ''!
testStepOverReturnInUnwindBlock
	"methodWithUnwindReturn
		[ #body ] ensure: [ ^#unwindReturn ]
	"
	| rootBlock |
	rootBlock := [ self methodWithUnwindReturn ].
	self settingUpSessionAndProcessAndContextForBlock: rootBlock. 
	[session interruptedContext selector = #methodWithUnwindReturn] whileFalse: [ session stepInto ].
	"Reached methodWithUnwindReturn"
	[session interruptedContext sender selector = #ensure: ] whileFalse: [ session stepThrough ].	
	session stepThrough.
	self 
		assert: session interruptedContext closure 
		identicalTo: session interruptedContext sender unwindBlock.
	[session interruptedContext home selector == #methodWithUnwindReturn] 
		whileTrue: [ session stepOver ].
	self assert: session interruptedContext closure identicalTo: rootBlock! !

!StepOverTest methodsFor: 'helper' stamp: ''!
step1
	self step2.! !

!StepOverTest methodsFor: 'helper' stamp: ''!
step2
	[ self step3 ] on: Notification do: [ ^2 ].! !

!StepOverTest methodsFor: 'helper' stamp: ''!
stepB2
	self stepB3! !

!StepOverTest methodsFor: 'helper' stamp: ''!
step3
	self step4.
	^4! !

!StepOverTest methodsFor: 'tests' stamp: ''!
testStepOverUntilTermination 
	"Stepping over a message node brings the execution to the next node in the same method."
	self settingUpSessionAndProcessAndContextForBlock: [ self stepA1 ].

	[ session interruptedProcess isTerminated ] whileFalse: [ session stepOver ].

	self assert: session interruptedProcess isTerminated! !

!StepOverTest methodsFor: 'tests' stamp: ''!
testStepOverHalt
	<haltOrBreakpointForTesting>
	"Stepping over a self halt should not raise an unhandled exception"
	self settingUpSessionAndProcessAndContextForBlock: [ self halt. ].
	self shouldnt: [[ session interruptedProcess isTerminated ] whileFalse: [ session stepOver. ]] raise: Exception.! !

!StepOverTest methodsFor: 'helper' stamp: ''!
step4
	self notify: 'hey'! !

!StepOverTest methodsFor: 'tests' stamp: ''!
testStepOverNonErrorExceptionSignalWithHandlerDeeperInTheContextStack
	"Context stack (from top to bottom) of the execution:
	self step4 | signal a Notification exception
	self step3 | just calls step 4. Point at which this test performs the stepOver
	self step2 | has a handler for Notification exceptions
	self step1 | just calls step2
	
	When doing a stepOver at step3, the session jumps to step1.
	The Notification exception was used because it is an exception that is not a subclass of Error, and iis therefore not caught by the handler context stepOver inserts between step2 and 3 (which handles Error)
	"
	self settingUpSessionAndProcessAndContextForBlock: [ self step1 ].
	session stepInto.
	session stepInto.
	session stepInto.
	session stepInto.
	session stepInto.
	session stepInto.
	session stepInto.
	"Reached the beginning of the step3 method call. Now doing a stepOver"
	session stepOver.
	"The DebugSession jumped to the step1 method call"
	self assert: session interruptedContext method equals: self class >>#step1! !

!StepOverTest methodsFor: 'helper' stamp: ''!
methodWithUnwindReturn
	[ #body ] ensure: [ ^#unwindReturn ]! !

!StepThroughDebugAction commentStamp: ''!
A StepThroughDebugAction through the execution until control returns to the current method.
!
!StepThroughDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 25! !

!StepThroughDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Step over the highlighted message, i.e. do not follow the sent message, taking debugger control after the method invoked returns or whenever execution should return inside a block used as an argument before that.'! !

!StepThroughDebugAction methodsFor: 'actions' stamp: ''!
executeAction

	self session stepThrough: self currentContext! !

!StepThroughDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #stepThrough! !

!StepThroughDebugAction methodsFor: 'accessing' stamp: ''!
defaultKeymap

	^ PharoShortcuts current stepThroughShortcut! !

!StepThroughDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Step through'! !

!StepThroughDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<debuggingAction>
	<contextMenuDebuggingAction>! !

!StepThroughTest methodsFor: 'helper' stamp: ''!
stepB1
	self stepB2.
	self stepB3.! !

!StepThroughTest methodsFor: 'helper' stamp: ''!
stepA2
	^ 2+2! !

!StepThroughTest methodsFor: 'tests' stamp: ''!
testStepThroughDoesTheSameThingAsStepOverWhenNoBlockIsInvolved
	"Testing that when no block is involved, a step through moves the execution to the same point a step over would"
	| node |

	self settingUpSessionAndProcessAndContextForBlock: [ self stepB1 ].
	[session interruptedContext method == (self class>>#stepB1)] 
		whileFalse: [ session stepInto ].

	"Reached node 'self stepB2' of method stepB1"
	self assert: session interruptedContext method equals: self class>>#stepB1.
	session stepOver.
	self assert: (session interruptedContext method) equals: (self class>>#stepB1).
	"Checking that after the step over, we reached the node 'self stepB3' of method stepB1"
	node := self class>>#stepB1 sourceNodeForPC: session interruptedContext pc.
	self assert: node isMessage.
	self assert: node receiver isSelfVariable.
	self assert: node selector equals: #stepB3.
	
	"Set up the debugged execution again"
	self settingUpSessionAndProcessAndContextForBlock: [ self stepB1 ].
	[session interruptedContext method == (self class>>#stepB1)] 
		whileFalse: [ session stepInto ].

	"Reached node 'self stepB2' of method stepB1"
	self assert: session interruptedContext method equals: self class>>#stepB1.
	session stepThrough.
	"Checking that after the step through, we reached the node 'self stepB3' of method stepB1 (the same node that was reached with the step over"
	node := self class>>#stepB1 sourceNodeForPC: session interruptedContext pc.
	self assert: node isMessage.
	self assert: node receiver isSelfVariable.
	self assert: node selector equals: #stepB3.! !

!StepThroughTest methodsFor: 'tests' stamp: ''!
testStepThrough
	"In a context c, define a block b, send a message to another method to get b evaluated.
	Testing that a step through on this message send moves the execution to the point where the block b is about to be evaluated."
	| node expectedMethod |
	self settingUpSessionAndProcessAndContextForBlock: [ self stepA1 ].
	session stepInto.
	session stepInto.
	"Reached node 'self evalBlockThenReturnOne: [self stepA2]' of method stepA1"
	"Checking that the execution is indeed at this node"
	self assert: (session interruptedContext method) equals: (self class>>#stepA1).
	node := self class>>#stepA1 sourceNodeForPC: session interruptedContext pc.
	self assert: node isMessage.
	self assert: node receiver isSelfVariable.
	self assert: node selector equals: #evalBlockThenReturnOne:.
	session stepThrough.

	"With fullblocks the method of the suspended context is a compiledBlock, not the method having it"
	expectedMethod := (self class >> #stepA1) literalAt: 1 .

	"Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method"
	self assert: (session interruptedContext method) equals: expectedMethod.
	node := expectedMethod sourceNodeForPC: session interruptedContext pc.
	self assert: node isMessage.
	self assert: node receiver isSelfVariable.
	self assert: node selector equals: #stepA2.! !

!StepThroughTest methodsFor: 'tests' stamp: ''!
testStepThroughUntilTermination 
	"Stepping over a message node brings the execution to the next node in the same method."
	self settingUpSessionAndProcessAndContextForBlock: [ self stepA1 ].

	[ session interruptedProcess isTerminated ] whileFalse: [ session stepThrough ].

	self assert: session interruptedProcess isTerminated! !

!StepThroughTest methodsFor: 'helper' stamp: ''!
stepA1
	self evalBlockThenReturnOne: [ self stepA2 ]! !

!StepThroughTest methodsFor: 'helper' stamp: ''!
evalBlockThenReturnOne: aBlock
	aBlock value.
	^1.! !

!StepThroughTest methodsFor: 'helper' stamp: ''!
stepB3
	^ 43! !

!StepThroughTest methodsFor: 'helper' stamp: ''!
stepB2
	^ 42! !

!Stopwatch commentStamp: ''!
A Stopwatch maintains a collection of timespans.!
!Stopwatch methodsFor: 'testing' stamp: ''!
isActive

	^ self state = #active! !

!Stopwatch methodsFor: 'actions' stamp: ''!
suspend

	| ts |
	self isActive ifTrue:
		[ ts := self timespans last.
		ts duration: (DateAndTime now - ts start).
		self state: #suspended]! !

!Stopwatch methodsFor: 'accessing' stamp: ''!
duration

	| ts last |
	self isSuspended 
		ifTrue:
			[ (ts := self timespans) isEmpty ifTrue: 
				[ ts := { Timespan starting: DateAndTime now duration: Duration zero } ] ]
		ifFalse:
			[ last := self timespans last.
			ts := self timespans allButLast
				add: (last duration: (DateAndTime now - last start); yourself);
				yourself ].
		
	^ (ts collect: [ :t | t duration ]) sum! !

!Stopwatch methodsFor: 'private' stamp: ''!
state: aSymbol

	state := aSymbol! !

!Stopwatch methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self state;
		nextPut: $:;
		print: self duration;
		nextPut: $).! !

!Stopwatch methodsFor: 'accessing' stamp: ''!
state

	^ state ifNil: [ state := #suspended ]! !

!Stopwatch methodsFor: 'actions' stamp: ''!
start

	^ self timespans first start! !

!Stopwatch methodsFor: 'accessing' stamp: ''!
timespans

	^ timespans ifNil: [ timespans := OrderedCollection new ]! !

!Stopwatch methodsFor: 'accessing' stamp: ''!
end

	^ self timespans last next! !

!Stopwatch methodsFor: 'actions' stamp: ''!
reActivate

	self 
		suspend;
		activate.! !

!Stopwatch methodsFor: 'actions' stamp: ''!
activate

	self isSuspended ifTrue:
		[self timespans add: 
			(Timespan starting: DateAndTime now duration: Duration zero).
		self state: #active]! !

!Stopwatch methodsFor: 'testing' stamp: ''!
isSuspended

	^ self state = #suspended! !

!Stopwatch methodsFor: 'initialization' stamp: ''!
reset

	self suspend.
	timespans := nil.! !

!StopwatchTest commentStamp: ''!
SUnit tests for the stopwatch !
!StopwatchTest methodsFor: 'tests' stamp: ''!
testPrintOn
	self assert: (String streamContents: [ :str | aStopwatch printOn: str ]) equals: 'a Stopwatch(suspended:0:00:00:00)'! !

!StopwatchTest methodsFor: 'tests' stamp: ''!
testReset
	| sw |
	sw := Stopwatch new.
	sw activate.

	sw reset.
	self
		assert: sw isSuspended;
		assertEmpty: sw timespans! !

!StopwatchTest methodsFor: 'tests' stamp: ''!
testStartStop
	| sw t1 t2 t3 t4 |
	sw := Stopwatch new.
	t1 := DateAndTime now.
	(Delay forMilliseconds: 10) wait.
	sw
		activate;
		activate.
	(Delay forMilliseconds: 10) wait.
	t2 := DateAndTime now.

	self
		deny: sw isSuspended;
		assert: sw isActive;
		assert: sw timespans size equals: 1;
		assert: t1 <= sw start;
		assert: sw start <= t2.

	(Delay forMilliseconds: 10) wait.
	t3 := DateAndTime now.
	(Delay forMilliseconds: 10) wait.
	sw
		suspend;
		suspend.
	(Delay forMilliseconds: 10) wait.
	t4 := DateAndTime now.

	self
		assert: sw isSuspended;
		deny: sw isActive;
		assert: sw timespans size equals: 1;
		assert: (sw end between: t3 and: t4);
		assert: t3 <= sw end;
		assert: sw end <= t4! !

!StopwatchTest methodsFor: 'tests' stamp: ''!
testSingleTiming
	| timeBefore |
	timeBefore := DateAndTime now.
	aStopwatch activate.
	aDelay wait.
	aStopwatch suspend.
	self assert: aStopwatch timespans size equals: 1.
	self assert: aStopwatch timespans first asDateAndTime >= timeBefore.
	self assert: aStopwatch timespans first asDateAndTime <= aStopwatch end! !

!StopwatchTest methodsFor: 'tests' stamp: ''!
testInitialStatus
	self assert: aStopwatch isSuspended.
	self deny: aStopwatch isActive.
	self assert: aStopwatch duration equals: 0 seconds! !

!StopwatchTest methodsFor: 'coverage' stamp: ''!
selectorsToBeIgnored

	| private | 
	private := #( #printOn: #state: ).

	^ super selectorsToBeIgnored, private! !

!StopwatchTest methodsFor: 'tests' stamp: ''!
testChangingStatus
	aStopwatch activate.
	self assert: aStopwatch isActive.
	self assert: aStopwatch timespans size equals: 1.
	aStopwatch suspend.
	self assert: aStopwatch isSuspended.
	self assert: aStopwatch timespans size equals: 1.
	aStopwatch activate.
	aStopwatch reActivate.
	self assert: aStopwatch isActive.
	self assert: aStopwatch timespans size equals: 3.
	aStopwatch reset.
	self assert: aStopwatch isSuspended.
	self assert: aStopwatch timespans size equals: 0! !

!StopwatchTest methodsFor: 'tests' stamp: ''!
testReActivate

	| sw |
	sw := Stopwatch new.
	sw 
		activate;
		suspend;
		reActivate.
	
	self 
		assert: (sw isActive).! !

!StopwatchTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ Stopwatch! !

!StopwatchTest methodsFor: 'tests' stamp: ''!
testMultipleTimings
	aStopwatch activate.
	aDelay wait.
	aStopwatch suspend.
	aStopwatch activate.
	aDelay wait.
	aStopwatch suspend.
	self assert: aStopwatch timespans size equals: 2.
	self assert: aStopwatch timespans first asDateAndTime <= aStopwatch timespans last asDateAndTime! !

!StopwatchTest methodsFor: 'tests' stamp: ''!
testNew
	| sw |
	sw := Stopwatch new.

	self
		assert: sw isSuspended;
		assert: sw state equals: #suspended;
		deny: sw isActive;
		assertEmpty: sw timespans! !

!StopwatchTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	aStopwatch := Stopwatch new.
	aDelay := Delay forMilliseconds: 1.! !

!StopwatchTest class methodsFor: 'testing' stamp: ''!
isUnitTest
	^false! !

!StoredSetting commentStamp: ''!
I represent a part of SettingNode that can be stored to a preference file.

Responsibility: I keep SettingNode's stored value and I know to which SettingNode I belong.

Collaborators: 
 - SystemSettings manages all my instances, stores, load, and gives an appropriate stored value for any SettingNode.
 - StoredSettingBuilder creates instances of me.
 - I represent stored value of #realValue of a SettingNode object.

Public API and Key Messages
- realValue returns SettingNode's stored value.
- isForSettingNode: returns true if my instance belongs to a given SettingNode.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	methodClass:		<Class>
	selector:			<Symbol>
	realValue:		<Object>
!
!StoredSetting methodsFor: 'accessing' stamp: ''!
realValue: anObject
	realValue := anObject! !

!StoredSetting methodsFor: 'accessing' stamp: ''!
realValue
	^ realValue! !

!StoredSettingsFactory commentStamp: ''!
I am responsible for creating new StoredSetting objects from existing SettingNodes. I know how to create a StoredSetting from a SettingNode.

Collaborators: SystemSettingsPersistence

Public API and Key Messages

- from:
- fromSettingNodes:
 
Internal Representation and Key Implementation Points.

    Instance Variables
	storedSetting:		<StoredSettings>
	storedSettings:		<Collection of StoredSettings>
!
!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitStrikeFont: aStrikeFont 
	self newStrikeFontStoredSetting 
			fontClassName: aStrikeFont class name;
			familyName: aStrikeFont familyName;
			pointSize: aStrikeFont pointSize;
			emphasized: aStrikeFont emphasis! !

!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitThemeIcons: aThemeIcons 
	self newThemeIconsStoredSetting 
			name: aThemeIcons name;
			url: aThemeIcons url! !

!StoredSettingsFactory methodsFor: '*Commander-Activators-Shortcut' stamp: ''!
visitCmdShortcutSetting: aCmdShortcutSetting
	self newStoredSetting realValue: aCmdShortcutSetting shortcutActivation! !

!StoredSettingsFactory methodsFor: 'instance creation' stamp: ''!
newAbsolutePathStoredSetting
	^ storedSetting := AbsolutePathStoredSetting new! !

!StoredSettingsFactory methodsFor: 'instance creation' stamp: ''!
newFileReferenceStoredSetting
	^ storedSetting := AbsolutePathStoredSetting new! !

!StoredSettingsFactory methodsFor: 'building' stamp: ''!
from: aSettingNode 
	storedSetting := nil.
	aSettingNode item acceptSettings: self. 
	storedSetting ifNotNil: [ 
		storedSetting settingNodeIdentifier: aSettingNode settingNodeIdentifier ].
	^ storedSetting! !

!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitAbstractFileReference: aFileReference 
	aFileReference path acceptSettings: self.! !

!StoredSettingsFactory methodsFor: 'instance creation' stamp: ''!
newRelativePathStoredSetting
	^ storedSetting := RelativePathStoredSetting new! !

!StoredSettingsFactory methodsFor: 'building' stamp: ''!
fromSettingNodes: aCollectionOfSettingNodes 
	storedSettings := OrderedCollection new.
	
	aCollectionOfSettingNodes 
		select: [ :eachSettingNode | 
			eachSettingNode item hasValue ] 
		thenDo: [ :eachSettingNode |
			(self from: eachSettingNode) ifNotNil: [ :aStoredNode | storedSettings add: aStoredNode ] ].
	
	^ storedSettings! !

!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitFileLocator: aFileLocator 
	self newFileLocatorStoreSetting 
			origin: aFileLocator origin;
			pathSegments: aFileLocator path segments ! !

!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitSettingDeclaration: aSettingDeclaration 

	aSettingDeclaration realValue acceptSettings: self.

	storedSetting hasDefaultValue: aSettingDeclaration hasDefaultValue
	! !

!StoredSettingsFactory methodsFor: 'instance creation' stamp: ''!
newStoredSetting
	^ storedSetting := StoredSetting new.! !

!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitLogicalFont: aLogicalFont 
	self newLogicalFontStoredSetting
		fontClassName: aLogicalFont class name;
		familyName: aLogicalFont familyName;
		fallbackFamilyNames: aLogicalFont fallbackFamilyNames;
		pointSize: aLogicalFont pointSize;
		stretchValue: aLogicalFont stretchValue;
		weightValue: aLogicalFont weightValue;
		slantValue: aLogicalFont slantValue.! !

!StoredSettingsFactory methodsFor: 'instance creation' stamp: ''!
newClassStoredSetting
	^ storedSetting := ClassStoredSetting new.! !

!StoredSettingsFactory methodsFor: 'instance creation' stamp: ''!
newThemeIconsStoredSetting
	^ storedSetting := ThemeIconsStoredSetting new! !

!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitObject: anObject 
	self newStoredSetting realValue: anObject! !

!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitAbsolutePath: anAbsolutePath 
	self newAbsolutePathStoredSetting realValue: anAbsolutePath segments! !

!StoredSettingsFactory methodsFor: 'instance creation' stamp: ''!
newFileLocatorStoreSetting
	^ storedSetting := FileLocatorStoredSetting new! !

!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitClass: aClass 
	self newClassStoredSetting realValue: aClass name.! !

!StoredSettingsFactory methodsFor: 'instance creation' stamp: ''!
newLogicalFontStoredSetting
	^ storedSetting := LogicalFontStoredSetting new! !

!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitPragmaSetting: aPragmaSetting 
	"do nothing"! !

!StoredSettingsFactory methodsFor: 'visitor' stamp: ''!
visitRelativePath: aRelativePath 
	self newRelativePathStoredSetting realValue: aRelativePath segments! !

!StoredSettingsFactory methodsFor: 'instance creation' stamp: ''!
newStrikeFontStoredSetting
	^ storedSetting := StrikeFontStoredSetting new! !

!StoredSettingsMerger commentStamp: ''!
I merge several stored settings together. If you ask me twice to store same stored settings, the last one wins. 

Collaborators: SystemSettingsPersistence

Public API and Key Messages

- addStoredSetting:
- addStoredSettings:
- storedSettings

   One simple example is simply gorgeous.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	storedSettings:		<Collection of StoredSetting>
!
!StoredSettingsMerger methodsFor: 'accessing' stamp: ''!
storedSettings
	^ storedSettings! !

!StoredSettingsMerger methodsFor: 'adding' stamp: ''!
addStoredSetting: aSettingNode 
	self storedSettings withIndexDo: [ :eachStoredNode :index | 
		eachStoredNode = aSettingNode ifTrue: [ ^ self storedSettings at: index put: aSettingNode ] ].
	^ self storedSettings add: aSettingNode! !

!StoredSettingsMerger methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	storedSettings := OrderedCollection new.! !

!StoredSettingsMerger methodsFor: 'adding' stamp: ''!
addStoredSettings: aCollectionOfStoredSettings
	aCollectionOfStoredSettings do: [ :eachStoredSetting |
		self addStoredSetting: eachStoredSetting ].
	^ aCollectionOfStoredSettings! !

!StoredSettingsMergerTest commentStamp: ''!
A StoredSettingsMergerTest is a test class for testing the behavior of StoredSettingsMerger!
!StoredSettingsMergerTest methodsFor: 'tests' stamp: ''!
testEmpty
	self assertEmpty: merger storedSettings! !

!StoredSettingsMergerTest methodsFor: 'tests' stamp: ''!
testStoredSettings
	| numberOfNodeSettings |
	numberOfNodeSettings := MockSettings nodeSettings size.
	merger addStoredSettings: MockSettings storedSettings.
	self assert: merger storedSettings size equals: numberOfNodeSettings.
	merger addStoredSettings: MockSettings storedSettings.
	self assert: merger storedSettings size equals: numberOfNodeSettings.
! !

!StoredSettingsMergerTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	merger := StoredSettingsMerger new.! !

!Stream commentStamp: ''!
I am an abstract class that represents an accessor for a sequence of objects. This sequence is referred to as my "contents".!
!Stream methodsFor: 'private' stamp: ''!
basicNextPut: anObject 

	^ self nextPut: anObject! !

!Stream methodsFor: 'accessing' stamp: ''!
next: anInteger 
	"Answer the next anInteger number of objects accessible by the receiver."
	
	| aCollection |
	aCollection := OrderedCollection new.
	anInteger timesRepeat: [aCollection addLast: self next].
	^aCollection! !

!Stream methodsFor: 'accessing' stamp: ''!
upToEnd
	"answer the remaining elements in the string"
	| elements |
	elements := OrderedCollection new.
	[ self atEnd ] whileFalse: [ 
		elements add: self next ].
	^elements! !

!Stream methodsFor: 'testing' stamp: ''!
isBinary
	^false! !

!Stream methodsFor: 'accessing' stamp: ''!
next: anInteger putAll: aCollection startingAt: startIndex
	"Store the next anInteger elements from the given collection."
	(startIndex = 1 and:[anInteger = aCollection size])
		ifTrue:[^self nextPutAll: aCollection].
	^self nextPutAll: (aCollection copyFrom: startIndex to: startIndex+anInteger-1)! !

!Stream methodsFor: 'private' stamp: ''!
basicNext

	^ self next.! !

!Stream methodsFor: 'accessing' stamp: ''!
nextPut: anObject 
	"Insert the argument, anObject, as the next object accessible by the 
	receiver. Answer anObject."
	
	self subclassResponsibility! !

!Stream methodsFor: 'enumerating' stamp: ''!
do: aBlock 
	"Evaluate aBlock for each of the objects accessible by receiver."

	[self atEnd]
		whileFalse: [aBlock value: self next]! !

!Stream methodsFor: 'private' stamp: ''!
nextWordsPutAll: aCollection
	"Write the argument a word-like object in big endian format on the receiver.
	May be used to write other than plain word-like objects (such as ColorArray)."
	
	(aCollection class isPointers or: [ aCollection class isWords not ])
		ifTrue: [ ^ self error: aCollection class name,' is not word-like'].
	1 to: aCollection basicSize do: [ :i |
		self nextNumber: 4 put: (aCollection basicAt: i) ].
	^ aCollection! !

!Stream methodsFor: 'open/close' stamp: ''!
close
	"Presumably sets the status of the receiver to be closed. This message does 
	nothing at this level, but is included for FileStream compatibility."

	^self! !

!Stream methodsFor: 'accessing' stamp: ''!
contents
	"Answer all of the contents of the receiver."

	self subclassResponsibility! !

!Stream methodsFor: 'flushing' stamp: ''!
flush
	"Do nothing by default"! !

!Stream methodsFor: 'testing' stamp: ''!
atEnd
	"Answer whether the receiver can access any more objects."

	self subclassResponsibility! !

!Stream methodsFor: 'private' stamp: ''!
basicNextPutAll: aCollection 

	^ self nextPutAll: aCollection.! !

!Stream methodsFor: 'accessing' stamp: ''!
localName
	^'a stream'! !

!Stream methodsFor: 'accessing' stamp: ''!
next: anInteger put: anObject 
	<compilerOptions: #(+ optionInlineTimesRepeat)>
	
	"Make anObject be the next anInteger number of objects accessible by the 
	receiver. Answer anObject."
	
	anInteger timesRepeat: [ self nextPut: anObject ].
	^ anObject! !

!Stream methodsFor: 'testing' stamp: ''!
isStream
	"Return true if the receiver responds to the stream protocol"
	^true! !

!Stream methodsFor: 'modes' stamp: ''!
readOnly
	"do nothing"
	^self! !

!Stream methodsFor: 'private' stamp: ''!
basicNext: anAmount putAll: aCollection startingAt: startIndex

	^ self next: anAmount putAll: aCollection startingAt: startIndex.! !

!Stream methodsFor: 'modes' stamp: ''!
binary
	"do nothing"
	^self! !

!Stream methodsFor: 'accessing' stamp: ''!
next
	"Answer the next object accessible by the receiver."

	self subclassResponsibility! !

!Stream methodsFor: 'testing' stamp: ''!
closed
	^ false! !

!Stream methodsFor: 'open/close' stamp: ''!
openReadOnly
	^self! !

!Stream methodsFor: 'accessing' stamp: ''!
<< anObject
	"Write anObject to the receiver, dispatching using #putOn:
	This is a shortcut for both nextPut: and nextPutAll: since anObject can be both
	the element type of the receiver as well as a collection of those elements.
	No further conversions of anObject are applied.
	Return self to accomodate chaining."

 	anObject putOn: self! !

!Stream methodsFor: '*Fuel-Core' stamp: ''!
nextBytesPutAll: aCollection
	"Append the bytes of aCollection to the sequence of bytes accessible 
	by the receiver. Answer aCollection."

	^self nextPutAll: aCollection! !

!Stream methodsFor: 'accessing' stamp: ''!
nextMatchFor: anObject 
	"Gobble the next object and answer whether it is equal to the argument, 
	anObject."

	^anObject = self next! !

!Stream methodsFor: 'accessing' stamp: ''!
nextPutAll: aCollection 
	"Append the elements of aCollection to the sequence of objects accessible 
	by the receiver. Answer aCollection."
	
	aCollection do: [:v | self nextPut: v].
	^aCollection! !

!Stream methodsFor: 'printing' stamp: ''!
print: anObject
	"Have anObject print itself on the receiver."

	anObject printOn: self! !

!Stream methodsFor: 'accessing' stamp: ''!
nextMatchAll: aColl
    "Answer true if next N objects are the ones in aColl,
     else false.  Advance stream of true, leave as was if false."
    | save |
    save := self position.
    aColl do: [:each |
       (self next) = each ifFalse: [
            self position: save.
            ^ false]
        ].
    ^ true! !

!Stream class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Streams are created with on: and with:'! !

!StreamBugsTest commentStamp: ''!
SUnit test for stream bugs!
!StreamBugsTest methodsFor: 'tests' stamp: ''!
testReadWriteStreamNextNBug
	| aStream |
	aStream := ReadWriteStream on: String new.
	aStream nextPutAll: 'Hello World'.
	aStream next: 5! !

!StrikeFont commentStamp: ''!
I represent a compact encoding of a set of Forms corresponding to characters in the ASCII character set. All the forms are placed side by side in a large form whose height is the font height, and whose width is the sum of all the character widths. The xTable variable gives the left-x coordinates of the subforms corresponding to the glyphs. Characters are mapped to glyphs by using the characterToGyphMap.

Subclasses can have non-trivial mapping rules as well as different representations for glyphs sizes (e.g., not using an xTable). If so, these classes should return nil when queried for xTable and/or the characterToGlyphMap. This will cause the CharacterScanner primitive to fail and query the font for the width of a character (so that a more programatical approach can be implemented).

For display, fonts need to implement two messages:
	#installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
This method installs the receiver (a font) on the given DisplayContext (which may be an instance of BitBlt or Canvas (or any of it's subclasses). The font should take the appropriate action to initialize the display context so that further display operations can be optimized.
	#displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta
This method is called for each subsequent run of characters in aString which is to be displayed with the (previously installed) settings.
!
!StrikeFont methodsFor: 'accessing' stamp: ''!
ascentKern
	"Return the kern delta for ascenders."
	(emphasis noMask: 2) ifTrue: [^ 0].
	^ (self ascent-5+4)//4 max: 0  "See makeItalicGlyphs"! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
makeUnderlinedGlyphs
	"Make an underlined set of glyphs with same widths"
	| g |
	g := glyphs deepCopy.
	g fillBlack: (0 @ (self ascent + 1) extent: g width @ 1).
	glyphs := g.
	self isSynthetic: true.
	fallbackFont ifNotNil: [ fallbackFont := fallbackFont emphasized: 4 ]! !

!StrikeFont methodsFor: 'displaying' stamp: ''!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) BitBlt."
	
	"Somewhat of a hack:
	The scanner seem to only pass in runs of either all ASCII or all non-ASCII characters. If all characters are ascii, then it's safe to use basic rendering-method."
	(aString hasWideCharacterFrom: startIndex to: stopIndex) ifTrue: [^self displayMultiString: aString 
						on: aBitBlt 
						from: startIndex 
						to: stopIndex 
						at: aPoint 
						kern: kernDelta 
						baselineY: baselineY.].

	^ aBitBlt displayString: aString 
			from: startIndex 
			to: stopIndex
			at: aPoint 
			strikeFont: self
			kern: kernDelta.! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
pointSize: anInteger 
	pointSize := anInteger! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
makeStruckOutGlyphs
	"Make a struck-out set of glyphs with same widths"
	| g |
	g := glyphs deepCopy.
	g fillBlack: (0 @ (self ascent - (self ascent // 3)) extent: g width @ 1).
	glyphs := g.
	self isSynthetic: true.
	fallbackFont ifNotNil: [ fallbackFont := fallbackFont emphasized: 16 ]! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
isSynthetic: aBoolean 
	type := aBoolean 
		ifTrue: [ 3 ]
		ifFalse: [ 0 ]! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
ascent
	"Answer the receiver's maximum extent of characters above the baseline."

	^ascent! !

!StrikeFont methodsFor: '*Athens-Text' stamp: ''!
asAthensFontDescription
	^ AthensFontDescription new family: self familyName; fontSize: self pointSize.! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
descent
	"Answer the receiver's maximum extent of characters below the baseline."

	^pointSize < 9
		ifTrue: [descent-1]
		ifFalse: [descent]! !

!StrikeFont methodsFor: 'file in/out' stamp: ''!
readFromBitFont: fileName 
	"This builds a StrikeFont instance by reading the data file format
	produced by BitFont, a widely available font conversion utility
	written by Peter DiCamillo at Brown University"
	"StrikeFont new readFromBitFont: 'Palatino10.BF' "
	| f lastAscii charLine width ascii charForm line missingForm tempGlyphs iRect p rectLine left tokens right |
	f := File openForReadFileNamed: fileName.
	self readBFHeaderFrom: f.

	"NOTE: if font has been scaled (and in any case),
	the REAL bitmap dimensions come after the header."
	self 
		restOfLine: 'Extent information for entire font'
		from: f.
	"Parse the following line (including mispelling!!)"
	"Image rectange: left = -2, right = 8, bottom = -2, top = 7"
	tokens := f nextLine findTokens: ' '.
	iRect := Rectangle 
		left: (tokens at: 5) asNumber
		right: (tokens at: 8) asNumber
		top: (tokens at: 14) asNumber
		bottom: (tokens at: 11) asNumber.
	ascent := iRect top.
	descent := iRect bottom negated.
	tempGlyphs := Form extent: (maxWidth * 257) @ self height.
	xTable := (Array new: 258) atAllPut: 0.
	xTable 
		at: 1
		put: 0.

	"Read character forms and blt into tempGlyphs"
	lastAscii := -1.
	
	[ charLine := self 
		restOfLine: 'Character: '
		from: f.
	charLine == nil ifFalse: 
		[ p := f position.
		rectLine := f nextLine.
		(rectLine beginsWith: 'Image rectange: left = ') 
			ifTrue: 
				[ tokens := rectLine findTokens: ' '.
				left := (tokens at: 5) asNumber.
				right := (tokens at: 8) asNumber ]
			ifFalse: 
				[ left := right := 0.
				f position: p ].
		width := (self 
			restOfLine: 'Width (final pen position) = '
			from: f) asNumber - left max: right - left + 1.
		(charLine beginsWith: 'Missing character') ifTrue: [ ascii := 256 ].
		('x''*' match: charLine) ifTrue: 
			[ ascii := Number 
				readFrom: (charLine 
					copyFrom: 3
					to: 4) asUppercase
				base: 16 ].
		charForm := Form extent: width @ self height.
		('*[all blank]' match: charLine) ifFalse: 
			[ self 
				restOfLine: '  +'
				from: f.
			1 
				to: self height
				do: 
					[ :y | 
					line := f nextLine.
					4 
						to: (width + 3 min: line size + iRect left - left)
						do: 
							[ :x | 
							(line at: x - iRect left + left) = $* ifTrue: 
								[ charForm 
									pixelValueAt: (x - 4) @ (y - 1)
									put: 1 ] ] ] ] ].
	charLine == nil ] whileFalse: 
		[ self 
			displayChar: ascii
			form: charForm.
		ascii = 256 
			ifTrue: [ missingForm := charForm deepCopy ]
			ifFalse: 
				[ minAscii := minAscii min: ascii.
				maxAscii := maxAscii max: ascii.
				lastAscii + 1 
					to: ascii - 1
					do: 
						[ :a | 
						xTable 
							at: a + 2
							put: (xTable at: a + 1) ].
				tempGlyphs 
					copy: ((xTable at: ascii + 1) @ 0 extent: charForm extent)
					from: 0 @ 0
					in: charForm
					rule: Form over.
				xTable 
					at: ascii + 2
					put: (xTable at: ascii + 1) + width.
				lastAscii := ascii ] ].
	f close.
	lastAscii + 1 
		to: maxAscii + 1
		do: 
			[ :a | 
			xTable 
				at: a + 2
				put: (xTable at: a + 1) ].
	missingForm == nil ifFalse: 
		[ tempGlyphs 
			copy: missingForm boundingBox
			from: missingForm
			to: (xTable at: maxAscii + 2) @ 0
			rule: Form over.
		xTable 
			at: maxAscii + 3
			put: (xTable at: maxAscii + 2) + missingForm width ].
	glyphs := Form extent: (xTable at: maxAscii + 3) @ self height.
	glyphs 
		copy: glyphs boundingBox
		from: 0 @ 0
		in: tempGlyphs
		rule: Form over.
	xTable := xTable 
		copyFrom: 1
		to: maxAscii + 3.
	characterToGlyphMap := nil! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
superscript
	"Answer an integer that is the further vertical offset relative to the 
	baseline for positioning characters as superscripts."

	^superscript! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
fontNameWithPointSize
	^self name withoutTrailingDigits, ' ', self pointSize printString! !

!StrikeFont methodsFor: 'displaying' stamp: ''!
displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 
	| nextWide destX leftX rightX glyphInfo char destY gfont charIndex |
	destX := aPoint x.
	charIndex := startIndex.
	glyphInfo := Array new: 5.
	[ charIndex <= stopIndex ] whileTrue: 
		[ nextWide := aString indexOfWideCharacterFrom: charIndex to: stopIndex.
		nextWide = 0 ifTrue: [nextWide := stopIndex +1].
		nextWide > charIndex ifTrue: [ destX := (aBitBlt displayString: aString 
			from: charIndex 
			to: nextWide -1
			at: destX @ aPoint y
			strikeFont: self
			kern: kernDelta) x.
			charIndex := nextWide]. 
		nextWide > stopIndex ifFalse: [
		char := aString at: charIndex.
		(self hasGlyphOf: char)
			ifTrue: 
				[ self 
					glyphInfoOf: char
					into: glyphInfo.
				leftX := glyphInfo at: 2.
				rightX := glyphInfo at: 3.
				destY := glyphInfo at: 4.
				gfont := glyphInfo at: 5.
				(gfont == aBitBlt lastFont) ifFalse: [gfont installOn: aBitBlt].
				aBitBlt displayGlyph: (glyphInfo at: 1) at: (destX @ (baselineY - destY)) left: leftX right: rightX font: self.
				destX := destX + (rightX - leftX + kernDelta).
				 ] 
			ifFalse: 
				[fallbackFont displayString: aString on: aBitBlt from: charIndex to: charIndex at: destX@destY kern: kernDelta baselineY: baselineY.
				destX := destX + (fallbackFont widthOf: char) + kernDelta.
				charIndex := charIndex + 1]]].
	^ Array 
		with: charIndex
		with: aPoint + (destX @ 0)! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
useUnderscoreIfOver1bpp

	glyphs depth = 1 ifTrue: [
		characterToGlyphMap ifNotNil: [	
			characterToGlyphMap at: 96 put: 95.
			characterToGlyphMap at: 95 put: 94 ].
		^self ].
	
	self characterToGlyphMap.
	characterToGlyphMap at: 96 put: 129.
	characterToGlyphMap at: 95 put: 128! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
makeLfVisible
	| glyph |
	self characterToGlyphMap.
	glyph := self characterFormAt: (Character value: 163).
	glyph 
		border: glyph boundingBox
		width: 1
		fillColor: Color blue.
	"	glyph := glyph reverse."
	self 
		characterFormAt: (Character value: 132)
		put: glyph.
	characterToGlyphMap 
		at: 11
		put: 132! !

!StrikeFont methodsFor: 'copying' stamp: ''!
deepCopy
 " there is a circular reference from the derivative fonts back to the receiver. It is therefore not possible to make a deep copy. We make a sahllow copy. The method postCopy can be used to modify the shallow copy. " 
  ^self copy! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
fallbackFont: aFontSetOrNil 
	fallbackFont := aFontSetOrNil! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
isSyntheticItalic: aBoolean 
	aBoolean 
		ifTrue: [type :=  5]! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
fallbackFont
	^ fallbackFont ifNil: [ fallbackFont := FixedFaceFont new errorFont fontSize: self height ]! !

!StrikeFont methodsFor: 'file in/out' stamp: ''!
newFromStrike: fileName 
	"Build an instance from the strike font file name. The '.strike' extension
	is optional."
	| strike startName raster16  |
	name := fileName copyUpTo: $..	"assumes extension (if any) is '.strike'"
	strike := File openForReadFileNamed: name , '.strike.'.

	"strip off direcory name if any"
	startName := name size.
	
	[ startName > 0 and: [ (name at: startName) ~= $> & ((name at: startName) ~= $]) ] ] whileTrue: [ startName := startName - 1 ].
	name := name 
		copyFrom: startName + 1
		to: name size.
	type := strike nextWord.	"type is ignored now -- simplest
												assumed.  Kept here to make
												writing and consistency more
												straightforward."
	minAscii := strike nextWord.
	maxAscii := strike nextWord.
	maxWidth := strike nextWord.
	strike nextWord. "strikeLength"
	ascent := strike nextWord.
	descent := strike nextWord.
	strike nextWord. "xOffset"
	raster16 := strike nextWord.
	superscript := (ascent - descent) // 3.
	subscript := (descent - ascent) // 3.
	emphasis := 0.
	glyphs := Form 
		extent: (raster16 * 16) @ self height
		offset: 0 @ 0.
	glyphs bits fromByteStream: strike.
	xTable := (Array new: maxAscii + 3) atAllPut: 0.
	(minAscii + 1 to: maxAscii + 3) do: 
		[ :index | 
		xTable 
			at: index
			put: strike nextWord ].

	"Set up space character"
	((xTable at: Space asciiValue + 2) = 0 or: [ (xTable at: Space asciiValue + 2) = (xTable at: Space asciiValue + 1) ]) ifTrue: 
		[ Space asciiValue + 2 
			to: xTable size
			do: 
				[ :index | 
				xTable 
					at: index
					put: (xTable at: index) + DefaultSpace ] ].
	strike close.
	characterToGlyphMap := nil! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
characterToGlyphMap
	^ characterToGlyphMap ifNil: [ characterToGlyphMap := self createCharacterToGlyphMap ]! !

!StrikeFont methodsFor: 'testing' stamp: ''!
checkCharacter: character
	"Answer a Character that is within the ascii range of the receiver--either 
	character or the last character in the receiver."

	| ascii |
	ascii := character asciiValue.
	^ (ascii < minAscii or: [ ascii > maxAscii ])
		ifTrue: [ maxAscii asCharacter ]
		ifFalse: [ character ]! !

!StrikeFont methodsFor: '*Athens-Text' stamp: ''!
getPreciseAscent
	^ self ascent! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
makeCondensedGlyphs
	"Make a condensed set of glyphs with same widths.
	NOTE: this has been superceded by kerning -- should not get called"
	| g newXTable x x1 w |
	g := glyphs deepCopy.
	newXTable := Array new: xTable size.
	newXTable 
		at: 1
		put: (x := xTable at: 1).
	1 
		to: xTable size - 1
		do: 
			[ :i | 
			x1 := xTable at: i.
			w := (xTable at: i + 1) - x1.
			w > 1 ifTrue: [ w := w - 1 ].	"Shrink every character wider than 1"
			g 
				copy: (x @ 0 extent: w @ g height)
				from: x1 @ 0
				in: glyphs
				rule: Form over.
			newXTable 
				at: i + 1
				put: (x := x + w) ].
	xTable := newXTable.
	glyphs := g.
	self isSynthetic: true.
	fallbackFont ifNotNil: [ fallbackFont emphasized: 8 ]

	"
(TextStyle default fontAt: 1) copy makeCondensedGlyphs
	displayLine: 'The quick brown fox jumps over the lazy dog'
	at: Sensor cursorPoint
"! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
makeLfInvisible
	self characterToGlyphMap.
	characterToGlyphMap at: 11 put: (11 < minAscii ifFalse: [11] ifTrue: [maxAscii+1])! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
textStyle
	^ TextStyle actualTextStyles detect:
		[:aStyle | aStyle fontArray includes: self] ifNone: [nil]! !

!StrikeFont methodsFor: 'displaying' stamp: ''!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
	^aDisplayContext 
		installStrikeFont: self
		foregroundColor: foregroundColor 
		backgroundColor: backgroundColor! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
fillZeroWidthSlots
	"Note: this is slow because it copies the font once for every replacement."
	| nullGlyph |
	nullGlyph := (Form extent: 1 @ glyphs height) fillGray.
	"Now fill the empty slots with narrow box characters."
	minAscii 
		to: maxAscii
		do: 
			[ :i | 
			(self widthOf: (Character value: i)) = 0 ifTrue: 
				[ self 
					characterFormAt: (Character value: i)
					put: nullGlyph ] ]! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
extendMaxAsciiTo: newMax 
	"Extend the range of this font so that it can display glyphs up to newMax."
	newMax + 3 <= xTable size ifTrue: [ ^ self ].	"No need to extend."
	xTable size = (maxAscii + 3) ifFalse: [ ^ self error: 'This font is not well-formed.' ].

	"Insert a bunch of zero-width characters..."
	xTable := (xTable 
		copyFrom: 1
		to: maxAscii + 2) , ((maxAscii + 1 to: newMax) collect: [ :i | xTable at: maxAscii + 2 ]) , {  (xTable at: maxAscii + 3)  }.
	maxAscii := newMax.
	self fillZeroWidthSlots.
	characterToGlyphMap := nil! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: ''!
fixXTable
	| newXTable val |
	xTable size >= 258 ifTrue: [ ^ self ].
	newXTable := Array new: 258.
	1 
		to: xTable size
		do: 
			[ :i | 
			newXTable 
				at: i
				put: (xTable at: i) ].
	val := xTable at: xTable size.
	xTable size + 1 
		to: 258
		do: 
			[ :i | 
			newXTable 
				at: i
				put: val ].
	minAscii := 0.
	maxAscii := 255.
	xTable := newXTable! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: ''!
readCharacter: aBits from: aStream 
	| pos |
	pos := 0.
	12 timesRepeat: 
		[ 1 
			to: 2
			do: 
				[ :w | 
				aBits 
					byteAt: pos + w
					put: aStream next ].
		pos := pos + 4 ]! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
maxWidth
	"Answer the integer that is the width of the receiver's widest character."

	^maxWidth! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
emphasized: code 
	"Answer a copy of the receiver with emphasis set to include code."
	| derivative addedEmphasis base safeCode |
	code = 0 ifTrue: [ ^ self ].
	(derivativeFonts == nil or: [ derivativeFonts size = 0 ]) ifTrue: [ ^ self ].
	derivative := derivativeFonts at: (safeCode := code min: derivativeFonts size).
	derivative == nil ifFalse: [ ^ derivative ].	"Already have this style"

	"Dont have it -- derive from another with one with less emphasis"
	addedEmphasis := 1 bitShift: safeCode highBit - 1.
	base := self emphasized: safeCode - addedEmphasis.	"Order is Bold, Ital, Under, Narrow"
	addedEmphasis = 1 ifTrue: 
		[ "Compute synthetic bold version of the font"
		derivative := (base copy ensureCleanBold name: base name , 'B') makeBoldGlyphs ].
	addedEmphasis = 2 ifTrue: 
		[ "Compute synthetic italic version of the font"
		derivative := (base copy name: base name , 'I') makeItalicGlyphs ].
	addedEmphasis = 4 ifTrue: 
		[ "Compute underlined version of the font"
		derivative := (base copy name: base name , 'U') makeUnderlinedGlyphs ].
	addedEmphasis = 8 ifTrue: 
		[ "Compute narrow version of the font"
		derivative := (base copy name: base name , 'N') makeCondensedGlyphs ].
	addedEmphasis = 16 ifTrue: 
		[ "Compute struck-out version of the font"
		derivative := (base copy name: base name , 'X') makeStruckOutGlyphs ].
	derivative emphasis: safeCode.
	derivativeFonts 
		at: safeCode
		put: derivative.
	^ derivative! !

!StrikeFont methodsFor: 'initialization' stamp: ''!
reset
	"Reset the cache of derivative emphasized fonts"
	fallbackFont class = FixedFaceFont ifTrue: [ fallbackFont := nil ].
	derivativeFonts notNil ifTrue: 
		[ derivativeFonts withIndexDo: 
			[ :f :i | 
			(f notNil and: [ f isSynthetic ]) ifTrue: 
				[ derivativeFonts 
					at: i
					put: nil ] ] ]
	"
	derivativeFonts := Array new: 32.
	#('B' 'I' 'BI') doWithIndex:
		[:tag :index | 
		(style := TextStyle named: self familyName) ifNotNil:
			[(font := style fontArray
				detect: [:each | each name = (self name , tag)]
				ifNone: [nil]) ifNotNil: [derivativeFonts at: index put: font]]]
	"! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: ''!
fixAscent: a andDescent: d head: h 
	"(a + d) = (ascent + descent) ifTrue: ["
	| bb newGlyphs |
	ascent := a.
	descent := d.
	newGlyphs := Form extent: glyphs width @ (h + glyphs height).
	bb := BitBlt toForm: newGlyphs.
	bb 
		copy: (0 @ h extent: glyphs extent)
		from: 0 @ 0
		in: glyphs
		fillColor: nil
		rule: Form over.
	glyphs := newGlyphs
	"]."! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
isSyntheticItalic
	^type = 5! !

!StrikeFont methodsFor: 'file in/out' stamp: ''!
readFromStrike2: fileName 
	"StrikeFont new readFromStrike2: 'Palatino14.sf2'"
	"Build an instance from the strike font stored in strike2 format.
	fileName is of the form: <family name><pointSize>.sf2"
	| file |
	self assert:['*.sf2' match: fileName]. "likely incompatible"
	name := fileName copyUpTo: $..	"Drop filename extension"
	file := File openForReadFileNamed: fileName.
	[ self readFromStrike2Stream: file ] ensure: [ file close ]! !

!StrikeFont methodsFor: '*Athens-Text' stamp: ''!
glyphRendererOn: anAthensSurface

	^ anAthensSurface getStrikeFontRendererFor: self! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
emphasis
	"Answer the integer code for synthetic bold, italic, underline, and 
	strike-out."

	^emphasis! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
derivativeFont: aStrikeFont at: index

	| newDeriv |
	(aStrikeFont isNil and: [ index = 0 ]) 
		ifTrue: [derivativeFonts := nil. ^ self].
	derivativeFonts ifNil: [derivativeFonts := Array new: 32].
	derivativeFonts size < 32 ifTrue: [
		newDeriv := Array new: 32.
		newDeriv replaceFrom: 1 to: derivativeFonts size with: derivativeFonts.
		derivativeFonts := newDeriv.
	].
	derivativeFonts at: index put: aStrikeFont.! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
setGlyphs: newGlyphs 
	"Replace the glyphs form.  Used to make a synthetic bold or italic font quickly."
	glyphs := newGlyphs! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
name
	"Answer the receiver's name."

	^name ifNil: ['(unnamed)']! !

!StrikeFont methodsFor: 'building' stamp: ''!
stripHighGlyphs
	"Remove glyphs for characters above 128"
	| i |
	maxAscii := 127.
	xTable := xTable 
		copyFrom: 1
		to: maxAscii + 3.
	i := xTable at: maxAscii + 1.
	xTable 
		at: maxAscii + 2
		put: i.
	xTable 
		at: maxAscii + 3
		put: i.
	glyphs := glyphs copy: (0 @ 0 extent: i @ glyphs height).
	maxWidth := 0.
	2 
		to: xTable size
		do: [ :ii | maxWidth := maxWidth max: (xTable at: ii) - (xTable at: ii - 1) - 1 ].
	characterToGlyphMap := nil.
	self reset! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
characterFormAt: character 
	"Answer a Form copied out of the glyphs for the argument, character."
	| ascii leftX rightX |
	ascii := character charCode.
	(ascii 
		between: minAscii
		and: maxAscii) ifFalse: [ ascii := maxAscii + 1 ].
	leftX := xTable at: ascii + 1.
	rightX := xTable at: ascii + 2.
	leftX < 0 ifTrue: [ ^ glyphs copy: (0 @ 0 corner: 0 @ self height) ].
	^ glyphs copy: (leftX @ 0 corner: rightX @ self height)! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
makeCarriageReturnsWhite
	"Some larger fonts have a gray carriage return (from the zero wide fixup) make it white so it doesn't show"
	| crForm |
	crForm := self characterFormAt: 13 asCharacter.
	crForm fillWhite.
	self 
		characterFormAt: 13 asCharacter
		put: crForm! !

!StrikeFont methodsFor: 'building' stamp: ''!
buildFromForm: allGlyphs data: data name: aString 
	| x |
	pointSize := data first.
	ascent := data second.
	descent := data third.
	minAscii := 32.
	maxAscii := 255.
	name := aString.
	type := 0.	"ignored for now"
	superscript := (ascent - descent) // 3.
	subscript := (descent - ascent) // 3.
	emphasis := 0.
	xTable := (Array new: 258) atAllPut: 0.
	maxWidth := 0.
	glyphs := allGlyphs.
	x := 0.
	minAscii 
		to: maxAscii + 1
		do: 
			[ :i | 
			x := data at: i - minAscii + 4.
			xTable 
				at: i + 1
				put: x ].
	xTable 
		at: 258
		put: x.
	self reset.
	derivativeFonts := Array new: 32! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
ensureCleanBold
	"This ensures that all character glyphs have at least one pixel of white space on the right
	so as not to cause artifacts in neighboring characters in bold or italic."
	| wider glyph |
	emphasis = 0 ifFalse: [ ^ self ].
	minAscii 
		to: maxAscii
		do: 
			[ :i | 
			glyph := self characterFormAt: (Character value: i).
			(glyph copy: (glyph boundingBox topRight - (1 @ 0) corner: glyph boundingBox bottomRight)) isAllWhite ifFalse: 
				[ wider := Form 
					extent: (glyph width + 1) @ glyph height
					depth: glyph depth.
				glyph depth > 1 ifTrue: [ wider fillWhite ].
				glyph displayOn: wider.
				self 
					characterFormAt: (Character value: i)
					put: wider ] ]
	"
StrikeFont allInstancesDo: [:f | f ensureCleanBold].
(StrikeFont familyName: 'NewYork' size: 21) ensureCleanBold.
StrikeFont shutDown.  'Flush synthetic fonts'.
"! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
characterToGlyphMap: anArray 
	characterToGlyphMap := anArray! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
characterFormAtMulti: character 
	"Answer a Form copied out of the glyphs for the argument, character."
	| ascii leftX rightX |
	ascii := character charCode.
	(ascii 
		between: minAscii
		and: maxAscii) ifFalse: [ ascii := maxAscii + 1 ].
	leftX := xTable at: ascii + 1.
	rightX := xTable at: ascii + 2.
	^ glyphs copy: (leftX @ 0 corner: rightX @ self height)! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
glyphInfoOf: aCharacter into: glyphInfoArray
	"Answer the width of the argument as a character in the receiver."

	| code |
	(self hasGlyphOf: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont glyphInfoOf: aCharacter into: glyphInfoArray.
		].
		code := 0.
	] ifTrue: [
		code := characterToGlyphMap 
				ifNotNil: [:map | map at: aCharacter charCode +1] 
				ifNil: [aCharacter charCode].
	].
	glyphInfoArray at: 1 put: glyphs;
		at: 2 put: (xTable at: code + 1);
		at: 3 put: (xTable at: code + 2);
		at: 4 put: (self ascentOf: aCharacter);
		at: 5 put: self.
	^ glyphInfoArray.! !

!StrikeFont methodsFor: 'displaying' stamp: ''!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) BitBlt."
	
		"Somewhat of a hack:
	The scanner seem to only pass in runs of either all ASCII or all non-ASCII characters. If all characters are ascii, then it's safe to use basic rendering-method."
	(aString hasWideCharacterFrom: startIndex to: stopIndex) ifTrue:  [^ self displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent.].

	^ aBitBlt displayString: aString 
			from: startIndex 
			to: stopIndex 
			at: aPoint 
			strikeFont: self
			kern: kernDelta.! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
makeTabVisible
	self characterToGlyphMap.
	characterToGlyphMap at: 10 put: 172! !

!StrikeFont methodsFor: 'file in/out' stamp: ''!
readFromStrike2Stream: file 
	"Build an instance from the supplied binary stream on data in strike2 format"
	type := file nextInt32.
	type = 2 ifFalse: 
		[ file close.
		self error: 'not strike2 format' ].
	minAscii := file nextInt32.
	maxAscii := file nextInt32.
	maxWidth := file nextInt32.
	ascent := file nextInt32.
	descent := file nextInt32.
	pointSize := file nextInt32.
	superscript := (ascent - descent) // 3.
	subscript := (descent - ascent) // 3.
	emphasis := file nextInt32.
	xTable := (Array new: maxAscii + 3) atAllPut: 0.
	(minAscii + 1 to: maxAscii + 3) do: 
		[ :index | 
		xTable 
			at: index
			put: file nextInt32 ].
	glyphs := Form new readFrom: file.

	"Set up space character"
	((xTable at: Space asciiValue + 2) = 0 or: [ (xTable at: Space asciiValue + 2) = (xTable at: Space asciiValue + 1) ]) ifTrue: 
		[ Space asciiValue + 2 
			to: xTable size
			do: 
				[ :index | 
				xTable 
					at: index
					put: (xTable at: index) + DefaultSpace ] ].
	characterToGlyphMap := nil! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
widen: char by: delta 
	
	^ self 
		alter: char
		formBlock: 
			[ :charForm | | newForm | 
			"Make a new form, wider or narrower..."
			newForm := Form extent: charForm extent + (delta @ 0).
			charForm displayOn: newForm.	"Copy this image into it"
			newForm	"and substitute it in the font" ]! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: ''!
hasGlyphOf: aCharacter
	| code |
	code := aCharacter charCode.
	(code between: self minAscii and: self maxAscii)
		ifFalse: [ ^ false ].
	characterToGlyphMap ifNotNil: [ :map | code := map at: code + 1 ].
	(xTable at: code + 1) < 0
		ifTrue: [ ^ false ].
	^ true! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
ascentOf: aCharacter

	(self hasGlyphOf: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont ascentOf: aCharacter.
		].
	].
	^ self ascent.! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
makeItalicGlyphs
	"Make an italic set of glyphs with same widths by skewing left and right.
	In the process, characters would overlap, so we widen them all first.
	"
	| extraWidth newGlyphs newXTable x newX w extraOnLeft |
	extraOnLeft := (self height - 1 - self ascent + 4) // 4 max: 0.
	extraWidth := ((self ascent - 5 + 4) // 4 max: 0) + extraOnLeft.
	newGlyphs := Form 
		extent: (glyphs width + ((maxAscii + 1 - minAscii) * extraWidth)) @ glyphs height
		depth: glyphs depth.
	newGlyphs fillWhite.
	newXTable := xTable copy.

	"Copy glyphs into newGlyphs with room on left and right for overlap."
	minAscii 
		to: maxAscii + 1
		do: 
			[ :ascii | 
			x := xTable at: ascii + 1.
			w := (xTable at: ascii + 2) - x.
			newX := newXTable at: ascii + 1.
			newGlyphs 
				copy: ((newX + extraOnLeft) @ 0 extent: w @ glyphs height)
				from: x @ 0
				in: glyphs
				rule: Form over.
			newXTable 
				at: ascii + 2
				put: newX + w + extraWidth ].
	glyphs := newGlyphs.
	xTable := newXTable.
	"Slide the bitmaps left and right for synthetic italic effect."
	4 
		to: self ascent - 1
		by: 4
		do: 
			[ :y | 
			"Slide ascenders right..."
			glyphs 
				copy: (1 @ 0 extent: glyphs width @ (self ascent - y))
				from: 0 @ 0
				in: glyphs
				rule: Form over ].
	self ascent 
		to: self height - 1
		by: 4
		do: 
			[ :y | 
			"Slide descenders left..."
			glyphs 
				copy: (0 @ y extent: glyphs width @ glyphs height)
				from: 1 @ y
				in: glyphs
				rule: Form over ].
	self isSyntheticItalic: true.
	fallbackFont ifNotNil: [ fallbackFont := fallbackFont emphasized: 2 ]! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
useLeftArrow
	self characterToGlyphMap.
	characterToGlyphMap at: 96 put: 95.
	characterToGlyphMap at: 95 put: 94! !

!StrikeFont methodsFor: 'file in/out' stamp: ''!
buildfontNamed: nm fromForms: forms startingAtAscii: startAscii ascent: a descent: d maxWid: m 
	"This builds a StrikeFont instance from existing forms."
	| lastAscii width ascii charForm missingForm tempGlyphs |
	name := nm.
	ascent := 11.
	descent := 3.
	maxWidth := 16.
	pointSize := 8.
	name := (name copyWithout: Character space) , (pointSize < 10 
			ifTrue: [ '0' , pointSize printString ]
			ifFalse: [ pointSize printString ]).
	minAscii := 258.
	maxAscii := 0.
	superscript := (ascent - descent) // 3.
	subscript := (descent - ascent) // 3.
	emphasis := 0.
	type := 0.	"ignored for now"
	tempGlyphs := Form extent: (maxWidth * 257) @ self height.
	xTable := (Array new: 258) atAllPut: 0.
	xTable 
		at: 1
		put: 0.

	"Read character forms and blt into tempGlyphs"
	lastAscii := -1.
	1 
		to: forms size
		do: 
			[ :i | 
			charForm := forms at: i.
			width := charForm width.
			ascii := startAscii - 1 + i.
			self 
				displayChar: ascii
				form: charForm.
			ascii = 256 
				ifTrue: [ missingForm := charForm deepCopy ]
				ifFalse: 
					[ minAscii := minAscii min: ascii.
					maxAscii := maxAscii max: ascii.
					lastAscii + 1 
						to: ascii - 1
						do: 
							[ :as | 
							xTable 
								at: as + 2
								put: (xTable at: as + 1) ].
					tempGlyphs 
						copy: ((xTable at: ascii + 1) @ 0 extent: charForm extent)
						from: 0 @ 0
						in: charForm
						rule: Form over.
					xTable 
						at: ascii + 2
						put: (xTable at: ascii + 1) + width.
					lastAscii := ascii ] ].
	lastAscii + 1 
		to: maxAscii + 1
		do: 
			[ :as | 
			xTable 
				at: as + 2
				put: (xTable at: as + 1) ].
	missingForm == nil ifFalse: 
		[ tempGlyphs 
			copy: missingForm boundingBox
			from: missingForm
			to: (xTable at: maxAscii + 2) @ 0
			rule: Form over.
		xTable 
			at: maxAscii + 3
			put: (xTable at: maxAscii + 2) + missingForm width ].
	glyphs := Form extent: (xTable at: maxAscii + 3) @ self height.
	glyphs 
		copy: glyphs boundingBox
		from: 0 @ 0
		in: tempGlyphs
		rule: Form over.
	xTable := xTable 
		copyFrom: 1
		to: maxAscii + 3.
	characterToGlyphMap := nil! !

!StrikeFont methodsFor: 'displaying' stamp: ''!
characters: anInterval in: sourceString displayAt: aPoint clippedBy: clippingRectangle rule: ruleInteger fillColor: aForm kernDelta: kernDelta on: aBitBlt 
	"Simple, slow, primitive method for displaying a line of characters.
	No wrap-around is provided."
	| destPoint |
	destPoint := aPoint.
	anInterval do: 
		[ :i | | rightX sourceRect leftX ascii | 
		self flag: #yoDisplay.
		"if the char is not supported, fall back to the specified fontset."
		ascii := (sourceString at: i) charCode.
		(ascii < minAscii or: [ ascii > maxAscii ]) ifTrue: [ ascii := maxAscii ].
		leftX := xTable at: ascii + 1.
		rightX := xTable at: ascii + 2.
		sourceRect := leftX @ 0 extent: (rightX - leftX) @ self height.
		aBitBlt 
			copyFrom: sourceRect
			in: glyphs
			to: destPoint.
		destPoint := destPoint + ((rightX - leftX + kernDelta) @ 0)
		"destPoint printString displayAt: 0@(i*20)" ].
	^ destPoint! !

!StrikeFont methodsFor: 'make arrows' stamp: ''!
makeReturnArrow
	"Replace the caret character with an arrow"
	| arrowForm arrowCanvas arrowHeadLength arrowX arrowTop arrowBottom |
	arrowForm := (self characterFormAt: $^) copy.
	arrowCanvas := arrowForm getCanvas.
	arrowCanvas fillColor: Color white.
	arrowHeadLength := (arrowForm width - 2) // 2.
	arrowX := arrowHeadLength max: arrowForm width // 2.
	arrowTop := arrowForm height // 4.
	arrowBottom := arrowTop + (arrowForm width * 4 // 5).
	arrowBottom := (arrowBottom min: arrowForm height) max: arrowForm height * 2 // 3.

	"Draw the lines"
	arrowCanvas 
		line: arrowX @ arrowTop
		to: arrowX @ arrowBottom
		color: Color black.
	arrowCanvas 
		line: arrowX @ arrowTop
		to: (arrowX - arrowHeadLength) @ (arrowTop + arrowHeadLength)
		color: Color black.
	arrowCanvas 
		line: arrowX @ arrowTop
		to: (arrowX + arrowHeadLength) @ (arrowTop + arrowHeadLength)
		color: Color black.

	"Replace the glyph"
	self 
		characterFormAt: $^
		put: arrowForm! !

!StrikeFont methodsFor: '*System-Settings-Core' stamp: ''!
acceptSettings: aVisitor
	^ aVisitor visitStrikeFont: self! !

!StrikeFont methodsFor: 'copying' stamp: ''!
postCopy
 " the receiver is a just created shallow copy. This method gives it the final touch. " 
 
    glyphs := glyphs copy.
    xTable := xTable copy.
    characterToGlyphMap := characterToGlyphMap copy.
 
    self reset.  " takes care of the derivative fonts "! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
useUnderscore
	self characterToGlyphMap.
	characterToGlyphMap at: 96 put: 129.
	characterToGlyphMap at: 95 put: 128! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
raster
	"Answer an integer that specifies the layout of the glyphs' form."

	^raster! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
bonk: glyphForm with: bonkForm 
	"Bonking means to run through the glyphs clearing out black pixels
	between characters to prevent them from straying into an adjacent
	character as a result of, eg, bolding or italicizing"
	"Uses the bonkForm to erase at every character boundary in glyphs."
	| bb offset x |
	offset := bonkForm offset x.
	bb := BitBlt toForm: glyphForm.
	bb
		sourceForm: bonkForm;
		sourceRect: bonkForm boundingBox;
		combinationRule: Form erase;
		destY: 0.
	x := self xTable.
	(x isMemberOf: SparseLargeTable) 
		ifTrue: 
			[ x base 
				to: x size - 1
				do: 
					[ :i | 
					bb
						destX: (x at: i) + offset;
						copyBits ] ]
		ifFalse: 
			[ 1 
				to: x size - 1
				do: 
					[ :i | 
					bb
						destX: (x at: i) + offset;
						copyBits ] ]! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
heightOf: aCharacter

	(self hasGlyphOf: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont heightOf: aCharacter.
		].
	].
	^ self height.! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
makeControlCharsVisible
	| glyph |
	self characterToGlyphMap.
	glyph := self characterFormAt: Character space.
	glyph 
		border: glyph boundingBox
		width: 1
		fillColor: Color blue.
	self 
		characterFormAt: (Character value: 133)
		put: glyph.

	"Keep tab(9), lf(10), cr(13) and space(32) transparent or whatever the user chose"
	#(
		0
		1
		2
		3
		4
		5
		6
		7
		8
		11
		12
		14
		15
		16
		17
		18
		19
		20
		21
		22
		23
		24
		25
		26
		27
		28
		29
		30
		31
	) do: 
		[ :ascii | 
		characterToGlyphMap 
			at: ascii + 1
			put: 133 ]! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
height
	"Answer the height of the receiver, total of maximum extents of 
	characters above and below the baseline."

	^self ascent + self descent! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
makeTabInvisible
	self characterToGlyphMap.
	characterToGlyphMap at: 10 put: (10 < minAscii ifFalse: [10] ifTrue:[maxAscii+1])! !

!StrikeFont methodsFor: 'displaying' stamp: ''!
installOn: aDisplayContext

	^aDisplayContext installStrikeFont: self.! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
glyphOf: aCharacter 
	"Answer the width of the argument as a character in the receiver."
	| code |
	(self hasGlyphOf: aCharacter) ifFalse: 
		[ fallbackFont ifNotNil: [ ^ fallbackFont glyphOf: aCharacter ].
		^ (Form extent: 1 @ self height) fillColor: Color white ].
	code := aCharacter charCode.
	^ glyphs copy: ((xTable at: code + 1) @ 0 corner: (xTable at: code + 2) @ self height)! !

!StrikeFont methodsFor: 'building' stamp: ''!
setGlyphsDepthAtMost: aNumber 
	glyphs depth > aNumber ifTrue: [ glyphs := glyphs asFormOfDepth: aNumber ]! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
xTable
	"Answer an Array of the left x-coordinate of characters in glyphs."

	^xTable! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
derivativeFonts
	^derivativeFonts copyWithout: nil! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
minAscii
	"Answer the integer that is the first Ascii character value of the receiver."

	^minAscii! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
familySizeFace
	"Answer an array with familyName, a String, pointSize, an Integer, and
	faceCode, an Integer."

	^Array with: name
		with: self height
		with: emphasis

	"(1 to: 12) collect: [:x | (TextStyle default fontAt: x) familySizeFace]"! !

!StrikeFont methodsFor: 'file in/out' stamp: ''!
restOfLine: leadString from: file 
	"Utility method to assist reading of BitFont data files"
	| line |
	
	[ line := file nextLine.
	line size < leadString size or: [ leadString ~= (line 
			copyFrom: 1
			to: leadString size) ] ] whileTrue: [ file atEnd ifTrue: [ ^ nil ] ].
	^ line 
		copyFrom: leadString size + 1
		to: line size! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
xTable: anObject 
	xTable := anObject! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
emphasis: code 
	"Set the integer code for synthetic bold, itallic, underline, and strike-out, 
	where bold=1, italic=2, underlined=4, and struck out=8."
	emphasis := code! !

!StrikeFont methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self name;
		space;
		print: self height;
		nextPut: $)! !

!StrikeFont methodsFor: 'make arrows' stamp: ''!
makeAssignArrow
	"Replace the underline character with an arrow for this font"
	| arrowForm arrowCanvas arrowY arrowLeft arrowRight arrowHeadLength |
	arrowForm := (self characterFormAt: $_) copy.
	arrowCanvas := arrowForm getCanvas.
	arrowCanvas fillColor: Color white.
	arrowY := arrowForm height // 2.
	arrowLeft := 0.
	arrowRight := arrowForm width - 2.
	arrowHeadLength := (arrowRight - arrowLeft) * 2 // 5.
	"Draw the lines"
	arrowCanvas 
		line: arrowLeft @ arrowY
		to: arrowRight @ arrowY
		color: Color black.
	arrowCanvas 
		line: arrowLeft @ arrowY
		to: (arrowLeft + arrowHeadLength) @ (arrowY - arrowHeadLength)
		color: Color black.
	arrowCanvas 
		line: arrowLeft @ arrowY
		to: (arrowLeft + arrowHeadLength) @ (arrowY + arrowHeadLength)
		color: Color black.

	"Replace the glyph"
	self 
		characterFormAt: $_
		put: arrowForm! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
name: aString 
	"Set the receiver's name."
	name := aString! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
fixOneWideChars
	"This fixes all 1-wide characters to be 2 wide with blank on the right
	so as not to cause artifacts in neighboring characters in bold or italic."
	| twoWide |
	minAscii 
		to: maxAscii
		do: 
			[ :i | 
			(self widthOf: (Character value: i)) = 1 ifTrue: 
				[ twoWide := Form extent: 2 @ glyphs height.
				(self characterFormAt: (Character value: i)) 
					displayOn: twoWide
					at: 0 @ 0.
				self 
					characterFormAt: (Character value: i)
					put: twoWide ] ]
	"
StrikeFont allInstancesDo: [:f | f fixOneWideChars].
StrikeFont shutDown.  'Flush synthetic fonts'.
"! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
characterForm: char pixelValueAt: pt put: val 
	| f |
	f := self characterFormAt: char.
	f 
		pixelAt: pt
		put: val.
	self 
		characterFormAt: char
		put: val! !

!StrikeFont methodsFor: 'file in/out' stamp: ''!
readBFHeaderFrom: f 
	name := self 
		restOfLine: 'Font name = '
		from: f.
	ascent := (self 
		restOfLine: 'Ascent = '
		from: f) asNumber.
	descent := (self 
		restOfLine: 'Descent = '
		from: f) asNumber.
	maxWidth := (self 
		restOfLine: 'Maximum width = '
		from: f) asNumber.
	pointSize := (self 
		restOfLine: 'Font size = '
		from: f) asNumber.
	name := (name copyWithout: Character space) , (pointSize < 10 
			ifTrue: [ '0' , pointSize printString ]
			ifFalse: [ pointSize printString ]).
	minAscii := 258.
	maxAscii := 0.
	superscript := (ascent - descent) // 3.
	subscript := (descent - ascent) // 3.
	emphasis := 0.
	type := 0	"ignored for now"! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
glyphs
	"Answer a Form containing the bits representing the characters of the 
	receiver."

	^glyphs! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
releaseCachedState

	self reset.! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
lineGrid
	^ ascent + descent! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
subscript
	"Answer an integer that is the further vertical offset relative to the 
	baseline for positioning characters as subscripts."

	^subscript! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
maxAscii
	"Answer the integer that is the last Ascii character value of the receiver."

	^maxAscii! !

!StrikeFont methodsFor: 'private' stamp: ''!
createCharacterToGlyphMap
        "Private. Create the character to glyph mapping for a font that didn't have any before. This is basically equivalent to what the former setStopCondition did, only based on indexes."

        maxAscii < 256 ifTrue: [^ (1 to: 256) collect: [:i | i - 1]].
        ^ nil.! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
makeBoldGlyphs
	"Make a bold set of glyphs with same widths by ORing 1 bit to the right
		(requires at least 1 pixel of intercharacter space)"
	| g bonkForm |
	g := glyphs deepCopy.
	bonkForm := (Form extent: 1 @ 16) fillBlack offset: -1 @ 0.
	self 
		bonk: g
		with: bonkForm.
	glyphs depth = 1 
		ifTrue: 
			[ g 
				copyBits: g boundingBox
				from: g
				at: 1 @ 0
				clippingBox: g boundingBox
				rule: Form under
				fillColor: nil ]
		ifFalse: 
			[ 0 
				to: g width - 2
				do: 
					[ :x | 
					0 
						to: g height - 1
						do: 
							[ :y | 
							(glyphs colorAt: x @ y) = Color white ifFalse: 
								[ g 
									colorAt: (x + 1) @ y
									put: ((glyphs colorAt: (x + 1) @ y) = Color white 
											ifTrue: [ glyphs colorAt: x @ y ]
											ifFalse: [ Color black ]) ] ] ] ].
	glyphs := g.
	self isSynthetic: true.
	fallbackFont ifNotNil: [ fallbackFont := fallbackFont emphasized: 1 ]! !

!StrikeFont methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  I am shared.  Do not record me."! !

!StrikeFont methodsFor: '*Athens-Text' stamp: ''!
asFreetypeFont

		self error: 'not supported yet. and ever'! !

!StrikeFont methodsFor: 'file in/out' stamp: ''!
displayChar: ascii form: charForm 
	"Convenience utility used during conversion of BitFont files"
	| m bigForm |
	Display fillBlack: (0 @ 0 extent: 20 @ 14).
	ascii printString displayAt: 0 @ 2.
	charForm width > 0 ifTrue: 
		[ m := 5.
		bigForm := charForm 
			magnify: charForm boundingBox
			by: m @ m.
		Display 
			border: ((bigForm boundingBox expandBy: m) translateBy: 50 @ 2)
			width: m.
		bigForm displayAt: 50 @ 2.
		Display fillBlack: (50 @ 2 + ((m * charForm width) @ 0) extent: 1 @ (m * self height)) ]! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
alter: char formBlock: formBlock
	self characterFormAt: char 
		put: (formBlock value: (self characterFormAt: char))! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
descentOf: aCharacter

	(self hasGlyphOf: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont descentOf: aCharacter.
		].
	].
	^ self descent.! !

!StrikeFont methodsFor: 'displaying' stamp: ''!
displayLine: aString at: aPoint 
	"Display the characters in aString, starting at position aPoint."

	self characters: (1 to: aString size)
		in: aString
		displayAt: aPoint
		clippedBy: Display boundingBox
		rule: Form over
		fillColor: nil
		kernDelta: 0
		on: (BitBlt toForm: Display).! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
descentKern
	"Return the kern delta for descenders."
	(emphasis noMask: 2) ifTrue: [^ 0].
	^ (self height-1-self ascent+4)//4 max: 0  "See makeItalicGlyphs"! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
baseKern
	"Return the base kern value to be used for all characters."
	
	| italic |

	italic := emphasis allMask: 2.	
	"Are we a bitmapped font with alpha, whose italic property is not synthetic?"
	(self isSyntheticItalic not and: [ glyphs depth > 1 ]) ifTrue: [
		^(italic or: [ pointSize < 9 ])
			ifTrue: [ 1 ]
			ifFalse: [ 0] ].
	
	italic ifFalse: [^ 0].
	^ ((self height-1-self ascent+4)//4 max: 0)  "See makeItalicGlyphs"
		+ (((self ascent-5+4)//4 max: 0))! !

!StrikeFont methodsFor: '*System-Settings-Browser' stamp: ''!
settingStoreOn: aStream 
	aStream nextPut: $(.
	aStream nextPutAll: self class name.
	aStream nextPut: Character space.
	aStream nextPutAll: 'familyName: ''', self familyName, ''' pointSize: ', self pointSize asString, ' emphasized: ', self emphasis asString.
	aStream nextPut: $)
! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
familyName
	| nameString firstDigit |
	nameString := self name.
	firstDigit := nameString findFirst: [ :m | m isDigit ].
	^ firstDigit > 0
		ifTrue: [ (nameString copyFrom: 1 to: firstDigit - 1) trimRight ]
		ifFalse: [ nameString ]! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
pointSize
	^ pointSize! !

!StrikeFont methodsFor: 'accessing' stamp: ''!
widthOf: aCharacter 
	"Answer the width of the argument as a character in the receiver."
	| code |
	code := aCharacter charCode.
	self characterToGlyphMap size > code ifTrue: [
		code := characterToGlyphMap at: code + 1 ].
	((code < minAscii or: [maxAscii < code]) 
		or: [(xTable at: code + 1) < 0])
			ifTrue: [^ self fallbackFont widthOf: aCharacter].
	^ (xTable at: code + 2) - (xTable at: code + 1)! !

!StrikeFont methodsFor: 'emphasis' stamp: ''!
isSynthetic
	^type > 0! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: ''!
setupDefaultFallbackFont
	| fonts f |
	fonts := TextStyle default fontArray.
	f := fonts first.
	1 
		to: fonts size
		do: [ :i | self height > (fonts at: i) height ifTrue: [ f := fonts at: i ] ].
	self fallbackFont: f.
	self reset! !

!StrikeFont methodsFor: 'character shapes' stamp: ''!
characterFormAt: character put: characterForm 
	"Copy characterForm over the glyph for the argument, character."
	| ascii leftX rightX widthDif newGlyphs |
	ascii := character asciiValue.
	ascii < minAscii ifTrue: [ ^ self error: 'Cant store characters below min ascii' ].
	ascii > maxAscii ifTrue: 
		[ (self confirm: 'This font does not accomodate ascii values higher than ' , maxAscii printString , '.
Do you wish to extend it permanently to handle values up to ' , ascii printString) 
			ifTrue: [ self extendMaxAsciiTo: ascii ]
			ifFalse: [ ^ self error: 'No change made' ] ].
	leftX := xTable at: ascii + 1.
	rightX := xTable at: ascii + 2.
	widthDif := characterForm width - (rightX - leftX).
	widthDif ~= 0 ifTrue: 
		[ "Make new glyphs with more or less space for this char"
		newGlyphs := Form 
			extent: (glyphs width + widthDif) @ glyphs height
			depth: glyphs depth.
		newGlyphs 
			copy: (0 @ 0 corner: leftX @ glyphs height)
			from: 0 @ 0
			in: glyphs
			rule: Form over.
		newGlyphs 
			copy: ((rightX + widthDif) @ 0 corner: newGlyphs width @ glyphs height)
			from: rightX @ 0
			in: glyphs
			rule: Form over.
		glyphs := newGlyphs.
		"adjust further entries on xTable"
		xTable := xTable copy.
		ascii + 2 
			to: xTable size
			do: 
				[ :i | 
				xTable 
					at: i
					put: (xTable at: i) + widthDif ] ].
	glyphs 
		copy: (leftX @ 0 extent: characterForm extent)
		from: 0 @ 0
		in: characterForm
		rule: Form over
	"
| f |  f := TextStyle defaultFont.
f characterFormAt: $  put: (Form extent: (f widthOf: $ )+10@f height)
"! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
primitiveFontDescent: fontHandle
	<primitive:'primitiveFontDescent' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'character shapes' stamp: ''!
makeLfInvisible
	"
	Make line feed characters invisible
	StrikeFont makeLfInvisible
	"
	self allInstances do: [ :font | font makeLfInvisible ]! !

!StrikeFont class methodsFor: 'accessing' stamp: ''!
defaultFallbackFontKeys
	^ Array with: self defaultFontKey! !

!StrikeFont class methodsFor: 'instance creation' stamp: ''!
familyName: aName pointSize: aSize emphasized: emphasisCode
	"Create the font with this emphasis"

	^ (self familyName: aName pointSize: aSize) emphasized: emphasisCode! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
primitiveFont: fontHandle glyphOfChar: charIndex into: glyphForm
	<primitive:'primitiveFontGlyphOfChar' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
localeChanged
	self setupDefaultFallbackFont! !

!StrikeFont class methodsFor: 'accessing' stamp: ''!
defaultFontSize
	^ 9! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
fromStrike: fileName 
	"Read a font from disk in the old ST-80 'strike' format.
	Note: this is an old format; use strike2 format instead"

	^self new newFromStrike: fileName! !

!StrikeFont class methodsFor: 'accessing' stamp: ''!
familyNames
	^ (TextSharedInformation select: [:each | each isKindOf: TextStyle]) keys asSortedCollection! !

!StrikeFont class methodsFor: 'removing' stamp: ''!
limitTo16Bits
	"Limit glyph depth to 16 bits (it is usually 16 or 32).
	
	StrikeFont limitTo16Bits
	"
	StrikeFont allInstances do: [ :f | f
		setGlyphsDepthAtMost: 16 ].! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
primitiveFont: fontHandle widthOfChar: charIndex
	<primitive:'primitiveFontWidthOfChar' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'character shapes' stamp: ''!
makeTabVisible
	"
	Make tab characters visible
	StrikeFont makeTabVisible
	"
	self allInstances do: [ :font | font makeTabVisible ]! !

!StrikeFont class methodsFor: 'accessing' stamp: ''!
actualFamilyNames
	"Answer a sorted list of actual family names, without the Default aliases"

	^(self familyNames copyWithoutAll: TextStyle defaultFamilyNames) asOrderedCollection! !

!StrikeFont class methodsFor: '*Text-Edition' stamp: ''!
fromUser: priorFont
	
	^ UIManager default fontFromUser: priorFont.! !

!StrikeFont class methodsFor: 'examples' stamp: ''!
readStrikeFont2Family: familyName fromDirectory: aDirectory 
	"StrikeFont readStrikeFont2Family: 'Lucida' fromDirectory: FileDirectory default"
	"This utility reads all available .sf2 StrikeFont files for a given family from  
	the current directory. It returns an Array, sorted by size, suitable for handing 
	to TextStyle newFontArray: ."
	"For this utility to work as is, the .sf2 files must be named 'familyNN.sf2'."
	| files strikeFonts fontArray |
	files := aDirectory filesMatching: familyName , '##.sf2'.
	strikeFonts := files collect: [ :file | StrikeFont new readFromStrike2: file basename ].
	strikeFonts do: [ :font | font reset ].
	strikeFonts := strikeFonts asSortedCollection: [ :a :b | a height < b height ].
	fontArray := strikeFonts asArray.
	^ fontArray

	"TextConstants at: #Lucida put: (TextStyle fontArray: (StrikeFont 
	readStrikeFont2Family: 'Lucida'))."! !

!StrikeFont class methodsFor: '*Text-Edition' stamp: ''!
fromUser
	"StrikeFont fromUser"
	^self fromUser: TextStyle defaultFont! !

!StrikeFont class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default registerGuiClassNamed: self name! !

!StrikeFont class methodsFor: 'character shapes' stamp: ''!
useUnderscoreIfOver1bpp
	"Sets underscore and caret glyphs for chars 95 and 94. 
	Only for enhanced StrikeFonts, i.e. those with glyphs of more than 1bpp.
	ASCII standard glyphs"
	"
	StrikeFont useUnderscoreIfOver1bpp
	"
	self allInstances do: [ :font | font useUnderscoreIfOver1bpp ]! !

!StrikeFont class methodsFor: 'instance creation' stamp: ''!
familyName: aName size: aSize emphasized: emphasisCode
	"Create the font with this emphasis"

	^ (self familyName: aName size: aSize) emphasized: emphasisCode! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
hostFontFromUser
	"StrikeFont hostFontFromUser"
	| fontNames index labels |
	fontNames := self listFontNames asSortedCollection.
	labels := (String new: 100) writeStream.
	fontNames 
		do: [ :fn | labels nextPutAll: fn ]
		separatedBy: [ labels cr ].
	index := UIManager default 
		chooseFrom: labels contents substrings
		title: 'Choose your font'.
	index = 0 ifTrue: [ ^ nil ].
	^ fontNames at: index! !

!StrikeFont class methodsFor: 'accessing' stamp: ''!
defaultFontKey
	^ self dejaVuKey! !

!StrikeFont class methodsFor: 'character shapes' stamp: ''!
makeLfVisible
	"
	Make line feed characters visible
	StrikeFont makeLfVisible
	"
	self allInstances do: [ :font | font makeLfVisible ]! !

!StrikeFont class methodsFor: 'instance creation' stamp: ''!
passwordFontSize: aSize 
	^ FixedFaceFont new passwordFont fontSize: aSize! !

!StrikeFont class methodsFor: 'examples' stamp: ''!
readStrikeFont2Family: familyName 
	"StrikeFont readStrikeFont2Family: 'Lucida'"
	^self readStrikeFont2Family: familyName fromDirectory: FileSystem workingDirectory! !

!StrikeFont class methodsFor: 'cleanup' stamp: ''!
cleanUp: aggressive
	"Flush synthesized strike fonts"

	self allInstancesDo: [:sf| sf reset].! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
listFontNames
	"StrikeFont listFontNames"
	"List all the OS font names"
	| font fontNames index |
	fontNames := Array new writeStream.
	index := 0.
	
	[ font := self listFont: index.
	font == nil ] whileFalse: 
		[ fontNames nextPut: font.
		index := index + 1 ].
	^ fontNames contents! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
primitiveCreateFont: fontName size: fontSize flags: fontFlags weight: fontWeight
	<primitive:'primitiveCreateFont' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'accessing' stamp: ''!
familyName: aName pointSize: aSize
	"Answer a font (or the default font if the name is unknown) in the specified size."

	^ ((TextStyle named: aName asSymbol) ifNil: [TextStyle default]) fontOfPointSize: aSize! !

!StrikeFont class methodsFor: '*Text-Edition' stamp: ''!
fromUser: priorFont allowKeyboard: aBoolean 
	"Present a menu of available fonts, and if one is chosen, return it. Otherwise return nil."
	"StrikeFont fromUser"
	| fontList fontMenu spec font style |
	fontList := StrikeFont actualFamilyNames.
	fontMenu := UIManager default newMenuIn: self for: self.
	fontList do: 
		[ :fontName | | label active ptMenu | 
		style := TextStyle named: fontName.
		active := priorFont familyName sameAs: fontName.
		ptMenu := UIManager default newMenuIn: self for: self.
		style pointSizes do: 
			[ :pt | 	
			ptMenu 
				add: (active and: [ pt = priorFont pointSize ]) ->  (pt printString , ' pt')
				target: fontMenu
				selector: #modalSelection:
				argument: {  fontName . pt  } ].
		style isTTCStyle ifTrue: 
			[ ptMenu 
				add: 'new size'
				target: style
				selector: #addNewFontSizeDialog:
				argument: {  fontName. fontMenu  } ].
		label := active -> fontName.
		fontMenu 
			add: label
			subMenu: ptMenu ].
	spec := fontMenu invokeModal.
	spec ifNil: [ ^ nil ].
	style := TextStyle named: spec first.
	style ifNil: [ ^ self ].
	font := style fonts 
		detect: [ :any | any pointSize = spec last ]
		ifNone: [ nil ].
	^ font! !

!StrikeFont class methodsFor: 'character shapes' stamp: ''!
makeControlCharsVisible
	"
	Make normally not visible characters, visible
	StrikeFont makeControlCharsVisible
	"
	self allInstances do: [ :font | font makeControlCharsVisible ]! !

!StrikeFont class methodsFor: 'character shapes' stamp: ''!
makeTabInvisible
	"
	Make tab characters invisible
	StrikeFont makeTabInvisible
	"
	self allInstances do: [ :font | font makeTabInvisible ]! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
primitiveDestroyFont: fontHandle
	<primitive:'primitiveDestroyFont' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'accessing' stamp: ''!
default
	^TextStyle default defaultFont! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
primitiveFontAscent: fontHandle
	<primitive:'primitiveFontAscent' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
fromHostFont: fontName size: fontSize flags: fontFlags weight: fontWeight 
	"
		^StrikeFont fromHostFont: (StrikeFont hostFontFromUser)
					size: 12 flags: 0 weight: 4.
	"
	| fontHandle glyphs xTable xStart maxWidth w glyphForm ascent descent fontHeight |
	fontHandle := self 
		primitiveCreateFont: fontName
		size: fontSize
		flags: fontFlags
		weight: fontWeight.
	ascent := self primitiveFontAscent: fontHandle.
	descent := self primitiveFontDescent: fontHandle.
	fontHeight := ascent + descent.
	xTable := Array new: 258.
	xStart := maxWidth := 0.
	0 
		to: 255
		do: 
			[ :i | 
			xTable 
				at: i + 1
				put: xStart.
			w := self 
				primitiveFont: fontHandle
				widthOfChar: i.
			w > maxWidth ifTrue: [ maxWidth := w ].
			xStart := xStart + w ].
	xTable 
		at: 256
		put: xStart.
	xTable 
		at: 257
		put: xStart.
	xTable 
		at: 258
		put: xStart.
	glyphs := Form 
		extent: xTable last @ fontHeight
		depth: 1.
	glyphForm := Form 
		extent: maxWidth @ fontHeight
		depth: 1.
	0 
		to: 255
		do: 
			[ :i | 
			glyphForm fillWhite.
			self 
				primitiveFont: fontHandle
				glyphOfChar: i
				into: glyphForm.
			xStart := xTable at: i + 1.
			glyphForm 
				displayOn: glyphs
				at: xStart @ 0.
			glyphForm 
				displayOn: Display
				at: xStart @ 0 ].
	self primitiveDestroyFont: fontHandle.
	^ Array 
		with: glyphs
		with: xTable! !

!StrikeFont class methodsFor: 'accessing' stamp: ''!
familyName: aName size: aSize
	"Answer a font (or the default font if the name is unknown) in the specified size."
	| style |
	style := TextStyle named: aName asSymbol.
	style ifNil: [^(FontSubstitutionDuringLoading forFamilyName: aName pixelSize: aSize)
			signal: 'missing font' ].
	^style fontOfSize: aSize! !

!StrikeFont class methodsFor: 'removing' stamp: ''!
saveSpace
	"Removes glyphs over 128, leaving only lower ascii.
	Also limit glyph depth to 4 bits (it is usually 16 or 32).
	This effectively turns off subpixel rendering, as glyphs will only have 16 shades of gray.
	
	StrikeFont saveSpace
	"
	StrikeFont allInstances do: [ :f | f
		stripHighGlyphs;
		setGlyphsDepthAtMost: 4 ].! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
primitiveFontEncoding: fontHandle
	<primitive:'primitiveFontEncoding' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'accessing' stamp: ''!
dejaVuKey
	^ 'Bitmap DejaVu Sans'! !

!StrikeFont class methodsFor: 'font creation' stamp: ''!
listFont: index
	<primitive:'primitiveListFont' module:'FontPlugin'>
	^nil! !

!StrikeFont class methodsFor: 'system startup' stamp: ''!
shutDown
	"StrikeFont shutDown"
	"Deallocate synthetically derived copies of base fonts to save space"
	self allSubInstancesDo: [ :sf | sf reset ].
	StrikeFontSet allSubInstancesDo: [ :sf | sf reset ].! !

!StrikeFont class methodsFor: 'accessing' stamp: ''!
setupDefaultFallbackFont
	"
	StrikeFont setupDefaultFallbackFont
	"
	(self defaultFallbackFontKeys
		collect: [:e | TextStyle named: e])
		do: [:style | style fontArray
				do: [:e | 
					e reset.
					(e respondsTo: #fontArray)
						ifTrue: [e fontArray 
								do: [:f | f setupDefaultFallbackFont]]]].! !

!StrikeFontSet commentStamp: ''!
I am something acts like a font out of collection of fonts. First font in me is used as representative font to answer many messages.

Examples:
- display a font: StrikeFontSet allInstances first fontDisplay 
- calculate pixels width of a string for a font: StrikeFontSet allInstances first widthOfString: 'Pharo'!
!StrikeFontSet methodsFor: 'accessing' stamp: ''!
ascentKern

	^ (fontArray  at: 1) ascentKern.! !

!StrikeFontSet methodsFor: 'emphasis' stamp: ''!
makeUnderlinedGlyphs
	"Make an underlined set of glyphs with same widths"

	| g font |
	1 to: fontArray size do: [:i |
		font := (fontArray at: i).
		font ifNotNil: [
			g := font glyphs deepCopy.
			g fillBlack: (0 @ (font ascent+1) extent: g width @ 1).
			font setGlyphs: g
		].
	].! !

!StrikeFontSet methodsFor: 'displaying' stamp: ''!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) BitBlt."
	
	"Look for an excuse to use the fast primitive"
 	(aString hasWideCharacterFrom: startIndex to: stopIndex) ifTrue:[
		^ self displayMultiString: aString 
				on: aBitBlt 
				from: startIndex 
				to: stopIndex 
				at: aPoint 
				kern: kernDelta 
				baselineY: baselineY].

	^ aBitBlt displayString: aString 
			from: startIndex 
			to: stopIndex 
			at: aPoint 
			strikeFont: self
			kern: kernDelta! !

!StrikeFontSet methodsFor: 'emphasis' stamp: ''!
makeStruckOutGlyphs
	"Make a struck-out set of glyphs with same widths"

	| g font |
	1 to: fontArray size do: [:i |
		font := (fontArray at: i).
		font ifNotNil: [
			g := font glyphs deepCopy.
			g fillBlack: (0 @ (font ascent - (font ascent//3)) extent: g width @ 1).
			font setGlyphs: g
		].
	].! !

!StrikeFontSet methodsFor: 'private' stamp: ''!
xTableEncoding: anInteger
	"Answer an Array of the left x-coordinate of characters in glyphs."

	^(fontArray at: anInteger + 1) xTable.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
ascent

	^ (fontArray  at: 1) ascent.! !

!StrikeFontSet methodsFor: 'private' stamp: ''!
glyphInfoOf: aCharacter into: glyphInfoArray
	| index f code leftX |
	index := 1.
	fontArray size < index
		ifTrue: [ ^ self questionGlyphInfoInto: glyphInfoArray ].
	(f := fontArray at: index) ifNil: [ ^ self questionGlyphInfoInto: glyphInfoArray ].
	code := aCharacter charCode.
	(code between: f minAscii and: f maxAscii)
		ifFalse: [ ^ self questionGlyphInfoInto: glyphInfoArray ].
	leftX := f xTable at: code + 1.
	leftX < 0
		ifTrue: [ ^ self questionGlyphInfoInto: glyphInfoArray ].
	glyphInfoArray
		at: 1 put: f glyphs;
		at: 2 put: leftX;
		at: 3 put: (f xTable at: code + 2);
		at: 4 put: (f ascentOf: aCharacter);
		at: 5 put: self.
	^ glyphInfoArray! !

!StrikeFontSet methodsFor: 'displaying' stamp: ''!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 

	^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
descent

	^ (fontArray  at: 1) descent.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
ascentOf: aCharacter
	^(self fontOf: aCharacter) ascent! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
bonk: glyphForm with: bonkForm at: j
	"Bonking means to run through the glyphs clearing out black pixels
	between characters to prevent them from straying into an adjacent
	character as a result of, eg, bolding or italicizing"
	"Uses the bonkForm to erase at every character boundary in glyphs."

	| bb offset font x |
	font := (fontArray at: j).
	offset := bonkForm offset x.
	bb := BitBlt toForm: glyphForm.
	bb sourceForm: bonkForm; sourceRect: bonkForm boundingBox;
		combinationRule: Form erase; destY: 0.
	x := font xTable.
	(x isMemberOf: SparseLargeTable) ifTrue: [
		x base to: x size-1 do: [:i | bb destX: (x at: i) + offset; copyBits].
	] ifFalse: [
		1 to: x size-1 do: [:i | bb destX: (x at: i) + offset; copyBits].
	].! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
fontOf: aCharacter
	"Answer the actual font to use for aCharacter"
	^self fontOf: aCharacter ifAbsent:[fontArray at: 1]! !

!StrikeFontSet methodsFor: 'emphasis' stamp: ''!
makeItalicGlyphs
	"Make an italic set of glyphs with same widths by skewing left and right
		(may require more intercharacter space)"

	| g bonkForm bc font |
	1 to: fontArray size do: [:j |
		font := (fontArray at: j).
		font ifNotNil: [
			g := font glyphs deepCopy.
			"BonkForm will have bits where slanted characters overlap their neighbors."
			bonkForm := Form extent: (self height//4+2) @ self height.
			bc := font descent//4 + 1.  "Bonker x-coord corresponding to char boundary."
			bonkForm fill: (0 @ 0 corner: (bc+1) @ font ascent) fillColor: Color black.
			4 to: font ascent-1 by: 4 do:
				[:y | 		"Slide ascenders right..."
				g copy: (1@0 extent: g width @ (font ascent - y))
					from: 0@0 in: g rule: Form over.
				bonkForm copy: (1@0 extent: bonkForm width @ (font ascent - y))
					from: 0@0 in: bonkForm rule: Form over].
			bonkForm fill: (0 @ 0 corner: (bc+1) @ font ascent) fillColor: Color white.
			bonkForm fill: (bc @ font ascent corner: bonkForm extent) fillColor: Color black.
			font ascent to: font height-1 by: 4 do:
				[:y | 		"Slide descenders left..."
				g copy: (0@y extent: g width @ g height)
					from: 1@y in: g rule: Form over.
				bonkForm copy: (0@0 extent: bonkForm width @ bonkForm height)
					from: 1@0 in: bonkForm rule: Form over].
			bonkForm fill: (bc @ font ascent corner: bonkForm extent) fillColor: Color white.
			"Now use bonkForm to erase at every character boundary in glyphs."
			bonkForm offset: (0-bc) @ 0.
			font bonk: g with: bonkForm.
			font setGlyphs: g
		].
	].! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
superscript

	^ (fontArray  at: 1) superscript! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
fontNameWithPointSize

	^ (fontArray at: 1) fontNameWithPointSize.! !

!StrikeFontSet methodsFor: 'displaying' stamp: ''!
displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY

	| destPoint leftX rightX glyphInfo g destY |
	destPoint := aPoint.
	glyphInfo := Array new: 5.
	startIndex to: stopIndex do: [:charIndex |
		self glyphInfoOf: (aString at: charIndex) into: glyphInfo.
		g := glyphInfo at:1.
		leftX := glyphInfo at:2.
		rightX := glyphInfo at:3.
		((glyphInfo at:5) ~= aBitBlt lastFont) ifTrue: [
			(glyphInfo at:5) installOn: aBitBlt.
		].
		aBitBlt sourceForm: g.
		destY := baselineY - (glyphInfo at:4).
		aBitBlt destX: (destPoint x) destY: destY width: (rightX - leftX) height: (self height).
		aBitBlt sourceOrigin: leftX @ 0.
		aBitBlt copyBits.
		destPoint := destPoint x + (rightX - leftX + kernDelta) @ destPoint y.
	].
	^ destPoint.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
fontOf: aCharacter ifAbsent: aBlock
	"Answer the actual font to use for aCharacter"
	| encoding font |
	encoding := 1.
	encoding <= fontArray size 
		ifTrue:[font := fontArray at: encoding].
	font ifNil:[^aBlock value].
	^font! !

!StrikeFontSet methodsFor: 'testing' stamp: ''!
isFontSet

	^ true.! !

!StrikeFontSet methodsFor: 'displaying' stamp: ''!
characters: anInterval in: sourceString displayAt: aPoint clippedBy: clippingRectangle rule: ruleInteger fillColor: aForm kernDelta: kernDelta on: aBitBlt
	"Simple, slow, primitive method for displaying a line of characters.
	No wrap-around is provided."

	^anInterval inject: aPoint into: 
		[:destPoint :i |
		| f xTable leftX noFont sourceRect ascii rightX |
		noFont := false.
		f := [fontArray at: 1 "encoding"]
			on: Exception do: [:ex | nil].
		f ifNil: [noFont := true. f := fontArray at: 1].
		ascii := (noFont ifTrue: [$?] ifFalse: [sourceString at: i]) charCode.
		(ascii < f minAscii
			or: [ascii > f maxAscii])
			ifTrue: [ascii := f maxAscii].
		xTable := f xTable.
		leftX := xTable at: ascii + 1.
		rightX := xTable at: ascii + 2.
		sourceRect := leftX @ 0 extent: (rightX - leftX) @ self height.
		aBitBlt copyFrom: sourceRect in: f glyphs to: destPoint.
		destPoint x + (rightX - leftX + kernDelta) @ destPoint y.
	].! !

!StrikeFontSet methodsFor: '*System-Settings-Core' stamp: ''!
acceptSettings: aVisitor
	^ aVisitor visitStrikeFontSet: self! !

!StrikeFontSet methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self reset.
	fontArray := fontArray copy! !

!StrikeFontSet methodsFor: 'copying' stamp: ''!
copy

	| s a |
	s := self class new.
	s name: self name.
	s emphasis: self emphasis.
	s reset.
	a := Array new: fontArray size.
	1 to: a size do: [:i |
		a at: i put: (fontArray at: i) copy.
	].
	s fontArray: a.
	^ s.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
heightOf: aCharacter
	^(self fontOf: aCharacter) height! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
height

	^ (fontArray  at: 1) height.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
latin1
	"Answer primary font"
	^ fontArray at: 1! !

!StrikeFontSet methodsFor: 'displaying' stamp: ''!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont baselineY: baselineY

	| destPoint leftX rightX glyphInfo g char destY rIndex| 
	destPoint := aPoint.
	rIndex := startIndex.
	glyphInfo := Array new: 5.
	[rIndex <= stopIndex] whileTrue: [
		char := aString at: rIndex.
		(fromFont hasGlyphOf: char) ifTrue: [^ Array with: rIndex with: destPoint].
		self glyphInfoOf: char into: glyphInfo.
		g := glyphInfo at: 1.
		leftX := glyphInfo at: 2.
		rightX := glyphInfo at: 3.
		(glyphInfo fifth ~= aBitBlt lastFont) ifTrue: [
			glyphInfo fifth installOn: aBitBlt.
		].
		aBitBlt sourceForm: g.
		destY := baselineY - (glyphInfo at: 4). 
		aBitBlt destX: destPoint x.
		aBitBlt destY: destY.
		aBitBlt sourceOrigin: leftX @ 0.
		aBitBlt width: rightX - leftX.
		aBitBlt height: self height.
		aBitBlt copyBits.
		destPoint := destPoint + (rightX - leftX + kernDelta @ 0).
		rIndex := rIndex + 1.
	].
	^ Array with: rIndex with: destPoint.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
characterToGlyphMap
	"used in 
	primDisplayString: aString from: startIndex to: stopIndex
			map: font characterToGlyphMap xTable: font xTable
			kern: kernDelta.
	
	Since 'font xTable' using a first font xtable, we could use the same glyph mapping for it'
	
	This should allow a primitive to not fail, because of characterToGlyphMap == nil
	"
	^ (fontArray at: 1) characterToGlyphMap! !

!StrikeFontSet methodsFor: 'displaying' stamp: ''!
installOn: aDisplayContext

	^ aDisplayContext installStrikeFont: self.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
xTable
	"Answer an Array of the left x-coordinate of characters in glyphs."

	^ (fontArray  at: 1) xTable.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
glyphsEncoding: anInteger

	^ (fontArray at: (anInteger+1)) glyphs.! !

!StrikeFontSet methodsFor: 'measuring' stamp: ''!
widthOfString: aString

	aString ifNil:[^0].
	"Optimizing"
	(aString isByteString) ifTrue: [
		^ (self fontArray  at: 1) widthOfString: aString from: 1 to: aString size].
	^ self widthOfString: aString from: 1 to: aString size.
"
	TextStyle default defaultFont widthOfString: 'zort' 21
"! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
derivativeFonts
	^derivativeFonts copyWithout: nil! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
familySizeFace

	^ Array
		with: (fontArray  at: 1) name
		with: self height
		with: (fontArray  at: 1) emphasis! !

!StrikeFontSet methodsFor: 'displaying' stamp: ''!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor 

	^ aDisplayContext
		installStrikeFont: self
		foregroundColor: foregroundColor
		backgroundColor: backgroundColor.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
textStyle

	^ TextStyle actualTextStyles detect: [:aStyle | (aStyle fontArray collect: [:s | s name]) includes: self name]
		ifNone: [].! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
emphasis: code 
	"Set the integer code for synthetic bold, itallic, underline, and strike-out, 
	where bold=1, italic=2, underlined=4, and struck out=8."

	emphasis := code.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
fontArray: anArray

	fontArray := anArray.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
maxAsciiFor: encoding

	| f |
	f := (fontArray at: encoding+1).
	f ifNotNil: [^ f maxAscii].
	^ 0.! !

!StrikeFontSet methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '(' , self name.
	aStream space.
	self height printOn: aStream.
	aStream nextPut: $).! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
maxWidth

	^ (fontArray at: 1) maxWidth.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
name: aString

	name := aString! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
emphasized: code 

	"Answer a copy of the receiver with emphasis set to include code."
	| derivative addedEmphasis base safeCode |
	code = 0 ifTrue: [^ self].
	derivativeFonts isEmptyOrNil ifTrue: [^ self].
	derivative := derivativeFonts at: (safeCode := code min: derivativeFonts size).
	derivative ifNotNil: [^ derivative].  "Already have this style"

	"Dont have it -- derive from another with one with less emphasis"
	addedEmphasis := 1 bitShift: safeCode highBit - 1.
	base := self emphasized: safeCode - addedEmphasis.  "Order is Bold, Ital, Under, Narrow"
	addedEmphasis = 1 ifTrue:   "Compute synthetic bold version of the font"
		[derivative := (base copy name: base name , 'B') makeBoldGlyphs].
	addedEmphasis = 2 ifTrue:   "Compute synthetic italic version of the font"
		[ derivative := (base copy name: base name , 'I') makeItalicGlyphs].
	addedEmphasis = 4 ifTrue:   "Compute underlined version of the font"
		[derivative := (base copy name: base name , 'U') makeUnderlinedGlyphs].
	addedEmphasis = 8 ifTrue:   "Compute narrow version of the font"
		[derivative := (base copy name: base name , 'N') makeCondensedGlyphs].
	addedEmphasis = 16 ifTrue:   "Compute struck-out version of the font"
		[derivative := (base copy name: base name , 'X') makeStruckOutGlyphs].
	derivative emphasis: safeCode.
	derivativeFonts at: safeCode put: derivative.
	^ derivative! !

!StrikeFontSet methodsFor: 'initialization' stamp: ''!
reset
	"Reset the cache of derivative emphasized fonts"

	derivativeFonts := Array new: 32.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
glyphs

	^ (fontArray  at: 1) glyphs! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
lineGrid

	| f |
	f := fontArray at: 1.
	^ f ascent + f descent.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
subscript

	^ (fontArray  at: 1) subscript! !

!StrikeFontSet methodsFor: 'emphasis' stamp: ''!
makeBoldGlyphs
	"Make a bold set of glyphs with same widths by ORing 1 bit to the right
		(requires at least 1 pixel of intercharacter space)"

	| g bonkForm font |
	1 to: fontArray size do: [:i |
		font := fontArray at: i.
		font ifNotNil: [
			g := font glyphs deepCopy.
			bonkForm := (Form extent: 1@16) fillBlack offset: -1@0.
			self bonk: g with: bonkForm at: i.
			g copyBits: g boundingBox from: g at: (1@0)
				clippingBox: g boundingBox rule: Form under fillColor: nil.
			(fontArray at: i) setGlyphs: g.
		].
	].! !

!StrikeFontSet methodsFor: 'private - initialization' stamp: ''!
initializeWithFontArray: anArray 
	"Initialize with given font array, the ascent of primary font is modified 
	if another font has higher size"
	| primaryFont maxHeight newFont |
	fontArray := anArray.
	primaryFont := anArray at: 1.
	emphasis := 0.
	name := primaryFont name.
	maxHeight := anArray
				inject: 0
				into: [:theHeight :font | (font notNil
							and: [theHeight < font height])
						ifTrue: [font height]
						ifFalse: [theHeight]].
	primaryFont height < maxHeight
		ifTrue: [newFont := primaryFont copy
						fixAscent: primaryFont ascent + (maxHeight - primaryFont height)
						andDescent: primaryFont descent
						head: 0.
			fontArray at: 1 put: newFont].
	self reset! !

!StrikeFontSet methodsFor: 'private' stamp: ''!
addNewFont: aFont at: encodingIndex

	| newArray |
	encodingIndex > fontArray size ifTrue: [
		newArray := Array new: encodingIndex.
		newArray replaceFrom: 1 to: fontArray size with: fontArray startingAt: 1.
	] ifFalse: [
		newArray := fontArray.
	].

	newArray at: encodingIndex put: aFont.

	self initializeWithFontArray: newArray.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
emphasis
	"Answer the integer code for synthetic bold, italic, underline, and 
	strike-out."

	^ emphasis.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
maxEncoding

	^ fontArray size.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
fontArray

	^ fontArray! !

!StrikeFontSet methodsFor: 'private' stamp: ''!
questionGlyphInfoInto: glyphInfoArray

	| f ascii |
	f := fontArray at: 1.
	ascii := $? asciiValue.
	glyphInfoArray at: 1 put: f glyphs;
		at: 2 put: (f xTable at: ascii + 1);
		at: 3 put: (f xTable at: ascii + 2);
		at: 4 put: (self ascentOf: $?);
		at: 5 put: self.
	^ glyphInfoArray.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
descentOf: aCharacter
	^(self fontOf: aCharacter) descent! !

!StrikeFontSet methodsFor: 'testing' stamp: ''!
name

	^ name! !

!StrikeFontSet methodsFor: 'displaying' stamp: ''!
displayLine: aString at: aPoint 
	"Display the characters in aString, starting at position aPoint."

	self characters: (1 to: aString size)
		in: aString
		displayAt: aPoint
		clippedBy: Display boundingBox
		rule: Form over
		fillColor: nil
		kernDelta: 0
		on: (BitBlt toForm: Display).! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
descentKern

	^ (fontArray at: 1) descentKern.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
baseKern

	^ (fontArray  at: 1) baseKern.! !

!StrikeFontSet methodsFor: '*System-Settings-Browser' stamp: ''!
settingStoreOn: aStream 
	aStream nextPut: $(.
	aStream nextPutAll: self class name.
	aStream nextPut: Character space.
	aStream nextPutAll: 'familyName: ''', self familyName, ''' size: ', self pointSize asString, ' emphasized: ', self emphasis asString.
	aStream nextPut: $)
! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
familyName

	^ (fontArray at: 1) familyName.! !

!StrikeFontSet methodsFor: 'character shapes' stamp: ''!
characterFormAt: character 

	| encoding ascii xTable leftX rightX |
	encoding := 1.
	ascii := character charCode.
	(ascii < (fontArray at: encoding) minAscii or: [ascii > (fontArray at: encoding) maxAscii])
		ifTrue: [ascii := (fontArray at: encoding) maxAscii].
	xTable := (fontArray at: encoding) xTable.
	leftX := xTable at: ascii + 1.
	rightX := xTable at: ascii + 2.
	^ (fontArray at: encoding) glyphs copy: (leftX @ 0 corner: rightX @ self height).! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
pointSize

	^ (fontArray  at: 1) pointSize.! !

!StrikeFontSet methodsFor: 'accessing' stamp: ''!
widthOf: aCharacter 
	"Answer the width of the argument as a character in the receiver."
	^(self fontOf: aCharacter) widthOf: aCharacter! !

!StrikeFontSet methodsFor: 'testing' stamp: ''!
isSynthetic

	^ fontArray first isSynthetic! !

!StrikeFontSet methodsFor: 'character shapes' stamp: ''!
characterFormAt: character put: characterForm 

	| ascii leftX rightX widthDif newGlyphs encoding xTable glyphs |
	encoding := 1.
	ascii := character charCode.
	ascii < (fontArray at: encoding) minAscii ifTrue: [
		^ self error: 'Cant store characters below min ascii'
	].
	ascii > (fontArray at: encoding) maxAscii ifTrue: [
		^ self error: 'No change made'
	].
	xTable := (fontArray at: encoding) xTable.
	leftX := xTable at: ascii + 1.
	rightX := xTable at: ascii + 2.
	glyphs := (fontArray at: encoding) glyphs.
	widthDif := characterForm width - (rightX - leftX).
	widthDif ~= 0 ifTrue: [
		newGlyphs := Form extent: glyphs width + widthDif @ glyphs height.
		newGlyphs copy: (0 @ 0 corner: leftX @ glyphs height) from: 0 @ 0
			in: glyphs rule: Form over.
		newGlyphs
				copy: (rightX + widthDif @ 0 corner: newGlyphs width @ glyphs height)
				from: rightX @ 0 in: glyphs rule: Form over.
		glyphs := newGlyphs.
		"adjust further entries on xTable"
		xTable := xTable copy.
		ascii + 2 to: xTable size do: [:i |
			xTable at: i put: (xTable at: i) + widthDif]].
	glyphs copy: (leftX @ 0 extent: characterForm extent) from: 0 @ 0 in: characterForm rule: Form over.! !

!StrikeFontSet class methodsFor: 'instance creation' stamp: ''!
familyName: aName size: aSize emphasized: emphasisCode
	"Create the font with this emphasis"

	^ (self familyName: aName size: aSize) emphasized: emphasisCode! !

!StrikeFontSet class methodsFor: 'utilities' stamp: ''!
findMaximumLessThan: f in: array

	array size to: 1 by: -1 do: [:i |
		f height >= (array at: i) height ifTrue: [^ array at: i].
	].
	^ array first.! !

!StrikeFontSet class methodsFor: 'file in/out' stamp: ''!
installNewFontAtIndex: newIndex fromOld: oldIndex

	
	self allInstances do: [:set | | newArray fontArray |
		fontArray := set fontArray.
		newIndex + 1 > fontArray size ifTrue: [
			newArray := Array new: newIndex + 1.
			newArray replaceFrom: 1 to: fontArray size with: fontArray startingAt: 1.
			newArray at: newIndex + 1 put: (fontArray at: oldIndex + 1).
			set initializeWithFontArray: newArray.
		] ifFalse: [
			fontArray at: newIndex + 1 put: (fontArray at: oldIndex + 1).
		].
	].

"
StrikeFontSet installNewFontAtIndex: UnicodeSimplifiedChinese leadingChar fromOld: UnicodeJapanese leadingChar
StrikeFontSet installNewFontAtIndex: UnicodeKorean leadingChar fromOld: UnicodeJapanese leadingChar
"! !

!StrikeFontSet class methodsFor: 'file in/out' stamp: ''!
removeFontsForEncoding: leadingChar encodingName: encodingSymbol

	| insts |
	leadingChar = 0 ifTrue: [^ self error: 'you cannot delete the intrinsic fonts'].
	insts := self allInstances.
	insts do: [:inst | | index fonts newFonts |
		fonts := inst fontArray.
		fonts size >= (leadingChar + 1) ifTrue: [
			leadingChar + 1 = fonts size ifTrue: [
				newFonts := fonts copyFrom: 1 to: fonts size - 1.
				index := newFonts indexOf: nil.
				index > 0 ifTrue: [newFonts := newFonts copyFrom: 1 to: index - 1].
				inst initializeWithFontArray: newFonts.
			] ifFalse: [
				fonts at: leadingChar + 1 put: nil.
			].
		].
	].

	TextSharedInformation removeKey: encodingSymbol asSymbol ifAbsent: [].! !

!StrikeFontSet class methodsFor: 'instance creation' stamp: ''!
familyName: aName size: aSize
	"Answer a font (or the default font if the name is unknown) in the specified size."

	| collection |
	collection :=  self allInstances select: [:inst | (inst name beginsWith: aName) and: [inst emphasis = 0]].
	collection isEmpty ifTrue: [
		(aName = 'DefaultMultiStyle') ifTrue: [
			collection := (TextSharedInformation at: #DefaultMultiStyle) fontArray.
		] ifFalse: [
			^ TextStyle defaultFont
		]
	].
	collection := collection asSortedCollection: [:a :b | a pointSize <= b pointSize].
	collection do: [:s | (s pointSize >= aSize) ifTrue: [^ s]].
	^ TextStyle defaultFont.! !

!StrikeFontSet class methodsFor: 'instance creation' stamp: ''!
newFontArray: anArray
 
	^super new initializeWithFontArray: anArray! !

!StrikeFontSetStoredSetting commentStamp: ''!
I am responsible for storing information about StrikeFontSet objects.!
!StrikeFontSetStoredSetting methodsFor: 'accessing' stamp: ''!
realValue
	^ (self class environment at: self fontClassName)
				familyName: self familyName 
				size: self pointSize
				emphasized: self emphasized! !

!StrikeFontStoredSetting commentStamp: ''!
I am responsible for storing information about StrikeFont objects.!
!StrikeFontStoredSetting methodsFor: 'accessing' stamp: ''!
realValue
	^ (self class environment at: self fontClassName)
			familyName: self familyName
			pointSize: self pointSize
			emphasized: self emphasized! !

!String commentStamp: ''!
A String is an indexed collection of Characters. Class String provides the abstract super class for ByteString (that represents an array of 8-bit Characters) and WideString (that represents an array of  32-bit characters).  In the similar manner of LargeInteger and SmallInteger, those subclasses are chosen accordingly for a string; namely as long as the system can figure out so, the String is used to represent the given string.

Strings support a vast array of useful methods, which can best be learned by browsing and trying out examples as you find them in the code.

## Substrings and slicing

A number of selectors can be used to get substrings. `String>>#lines` will return a colection containing substrings separated by `\\n`, `\\r`, or `\\r\\n`; `String>>#trim` will return a substring with whitespace removed from the beginning and end. 

Obtaining parts of a string can also be achieved using numbered indices, also known as slicing. There are shortcut methods for some common operations that are often inherited from `SequenceableCollection` inclusing `allButFirst`, `allButLast`, `first`, or `last`.

```
s := 'abcdefg'.

s first. "$a"
s allButFirst.  "bcdefg"

s last.  "$g"
s allButLast.  "abcdef"

"pass a number argument to change the number of characters removed/kept"

s first: 2.  "ab"  
s allButFirst: 2.  "cdefg"

s last: 2.  "fg"
s allButLast: 2.  "abcde"
```

To get the middle of a string use `SequenceableCollection>>#copyFrom:to:`

```
s := 'abcdefg'.
s copyFrom: 2 to: 6. "bcdef"
```

To count back from the end of the string use the `size` selector
```
s := 'abcdefg'
s copyFrom: 2 to: s size - 1 
```

## Formatting

Strings have a `String>>#format:` selector that can be used for interpolating other objects.
The "string template" can either have numbers between curly bracket characters (`{` and `}`)
where the argument to format is a collection where values are indexed by number. Or pass in
a `HashedCollection` where the placeholders are the keys of the collection
```
'ab {1} ef {2}' format: {'cd'. 'gh'}.  "ab cd ef gh"

'ab {one} ef {two}' format: 
    (Dictionary with: #one -> 'cd' with: #two -> 'gh').
```

`String>>#contractTo:` is also useful for shortening strings to a particular length by replacing 
middle characters.

## Copying and Streaming
As well as the `format:` selector it is possible to build up a string using contatenation with
`SequenceableCollection>>#,` 

```
a := 'abc'.
b := ' easy as '.
c := '123'.
a , b , c.  "abc easy as 123"
```
Or alternatively, construct a string from a stream using `SequenceableCollection class>>#streamContents:`.

```
s := String streamContents: [ :stream |
	  stream nextPutAll: 'abcdefg';
	  space;
	  nextPutAll: '123456';
	  space.
	  '7890' putOn: stream. ].  "abcdefg 123456 7890"
```

## Finding/Searching

Simple reqular expression type searching can be performed using `String>>#match:`, which has similar
symantics as "globbing" in a shell. The reciever is a template string where the `#` character matches any single character and the `*` character matches any number of characters. A `Boolean` object is returned. 
```
'#abb*cdch' match: '4abbadskfakjdfadiadfnvcdch'  "true"
```

For more complex matching use `String>>#matchesRegex:` which is an extension method implmented by `RxMatcher`. See the help documentation on regular expressions `HelpBrowser openOn: RegexHelp.`
!
!String methodsFor: 'converting' stamp: ''!
withoutSuffix: suffix
	"Remove the given suffix, if present."

	^(self endsWith: suffix) ifTrue: [ self copyFrom: 1 to: self size - suffix size ] ifFalse: [ self ]! !

!String methodsFor: '*ScriptingExtensions' stamp: ''!
asClassInEnvironment: anEnvironment ifAbsent: absentBlock
	^  anEnvironment 
			at: self asSymbol 
			ifPresent: [ :aClass| 
				self 
					assert: aClass isBehavior 
					description: [ self printString, ' is not a Class but an instance of a ', aClass class name ].
				aClass ]
			ifAbsent: absentBlock
	! !

!String methodsFor: 'converting' stamp: ''!
uncapitalized
	"Return a copy with the first letter downShifted (in lower case)"
	
	| answer |
	self ifEmpty: [ ^ self copy ].
	answer := self copy.
	answer at: 1 put: answer first asLowercase.
	^ answer! !

!String methodsFor: 'converting' stamp: ''!
asFourCode
	"'abcd' asFourCode >>> -513645724"
	"'1111' asFourCode >>> 825307441"
	"'1234' asFourCode >>> 825373492"
	| result |
	self size = 4 
		ifFalse: [^self error: 'must be exactly four characters'].
		
	result := self inject: 0 into: [:val :each | 256 * val + each asciiValue ].
	(result bitAnd: 16r80000000) = 0 
		ifFalse: [ Error signal: 'cannot resolve fourcode' ].
		
	(result bitAnd: 16r40000000) = 0 
		ifFalse: [ ^ result - 16r80000000 ].
	^ result! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setDescriptionInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setDescriptionWithString: self! !

!String methodsFor: 'formatting' stamp: ''!
expandMacros
	"'<t>' expandMacros >>> String tab"
	"'<r>' expandMacros >>> String cr"
	"'<n>' expandMacros >>> OSPlatform current lineEnding"
	
	^self expandMacrosWithArguments: #()! !

!String methodsFor: '*Spec2-Core' stamp: ''!
localizedForPresenter: aPresenter

	"This message serves for the string modification for the purpose of a given Spec presenter. It may, for example, convert it to a presenter's locale. The implementation here (in the String) serves as fallback for regular strings."

	^ self! !

!String methodsFor: '*RPackage-Core' stamp: ''!
asPackage
	^ self asPackageIfAbsent: [ NotFound new messageText: 'There is no package named ', self; object: self; signal ]! !

!String methodsFor: '*Network-UUID' stamp: ''!
asAlphaNumeric: totalSize extraChars: additionallyAllowed mergeUID: minimalSizeOfRandomPart 
	"Generates a String with unique identifier ( UID ) qualities, the difference to a
	 UUID is that its beginning is derived from the receiver, so that it has a meaning
	 for a human reader.

	 Answers a String of totalSize, which consists of 3 parts
	 1.part: the beginning of the receiver only consisting of
		a-z, A-Z, 0-9 and extraChars in Collection additionallyAllowed ( which can be nil )
	 2.part: a single _
	 3.part: a ( random ) UID of size >= minimalSizeOfRandomPart consisting of
		a-z, A-Z, 0-9

	 Starting letters are capitalized. 
	 TotalSize must be at least 1.
	 Exactly 1 occurrence of $_ is guaranteed ( unless additionallyAllowed includes $_ ).
	 The random part has even for small sizes good UID qualitites for many practical purposes.
	 If only lower- or uppercase letters are demanded, simply convert the answer with
	 say #asLowercase. The probability of a duplicate will rise only moderately ( see below ).

	 Example: 
		size of random part = 10
		in n generated UIDs the chance p of having non-unique UIDs is
			n = 10000 ->  p < 1e-10		if answer is reduced to lowerCase: p < 1.4 e-8
			n = 100000 -> p < 1e-8
		at the bottom is a snippet for your own calculations  
		Note: the calculated propabilites are theoretical,
			for the actually used random generator they may be much worse"
	| stream out sizeOfFirstPart index ascii ch skip array random |
	totalSize > minimalSizeOfRandomPart ifFalse: [ self errorOutOfBounds ].
	stream := self readStream.
	out :=  (String new: totalSize) writeStream.
	index := 0.
	skip := true.
	sizeOfFirstPart := totalSize - minimalSizeOfRandomPart - 1.
	[ stream atEnd or: [ index >= sizeOfFirstPart ] ] whileFalse: 
		[ (((ascii := (ch := stream next) asciiValue) between: 65 and: 90) or: 
			[ (ascii between: 97 and: 122) or: 
				[ ch isDigit or: [ additionallyAllowed notNil and: [ additionallyAllowed includes: ch ] ] ] ]) 
			ifTrue: 
				[ skip 
					ifTrue: [ out nextPut: ch asUppercase ]
					ifFalse: [ out nextPut: ch ].
				index := index + 1.
				skip := false ]
			ifFalse: [ skip := true ] ].
	out nextPut: $_.
	array := Array new: 62.
	1 
		to: 26
		do: 
			[ :i | 
			array 
				at: i
				put: (i + 64) asCharacter.
			array 
				at: i + 26
				put: (i + 96) asCharacter ].
	53 
		to: 62
		do: 
			[ :i | 
			array 
				at: i
				put: (i - 5) asCharacter ].
	random := UUIDGenerator default randomGenerator.
	totalSize - index - 1 timesRepeat: [ out nextPut: (array atRandom: random) ].
	^ out contents

	"	calculation of probability p for failure of uniqueness in n UIDs
		Note: if answer will be converted to upper or lower case replace 62 with 36
	| n i p all |
	all := 62 raisedTo: sizeOfRandomPart.
	i := 1.
	p := 0.0 .
	n := 10000.
	[ i <= n ]
	whileTrue: [
		p := p + (( i - 1 ) / all ).
		i := i + 1 ].
	p   

	approximation formula: n squared / ( 62.0 raisedTo: sizeOfRandomPart ) / 2 
	"

	"'Crop SketchMorphs and Grab Screen Rect to JPG' 
			asAlphaNumeric: 31 extraChars: nil mergeUID: 10  
	 			'CropSketchMorphsAndG_iOw94jquN6'
	 'Monticello' 
			asAlphaNumeric: 31 extraChars: nil mergeUID: 10    
				'Monticello_kp6aV2l0IZK9uBULGOeG' 
	 'version-', ( '1.1.2' replaceAll: $. with: $- )
			asAlphaNumeric: 31 extraChars: #( $- ) mergeUID: 10    
				'Version-1-1-2_kuz2tMg2xX9iRLDVR'"! !

!String methodsFor: '*ScriptingExtensions' stamp: ''!
asClass
	"returns a global class with my name"
	^ self asClassInEnvironment: Smalltalk globals! !

!String methodsFor: '*Regex-Core' stamp: ''!
asRegex
	"Compile the receiver as a regex matcher. May raise RxParser>>syntaxErrorSignal
	or RxParser>>compilationErrorSignal.
	This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov.
	Refer to `documentation' protocol of RxParser class for details."

	^RxParser preferredMatcherClass for: (RxParser new parse: self)! !

!String methodsFor: '*Regex-Core' stamp: ''!
copyWithRegex: rxString matchesReplacedWith: aString

	^rxString asRegex
		copy: self replacingMatchesWith: aString! !

!String methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
withAccentuatedCharacter: aKey

	| text index | 
	text := self asText.
	aKey ifNil: [ ^ text ].
	index := self asLowercase indexOf: aKey name asLowercase.
	index isZero
		ifTrue: [ ^ text ].

	^ text
		addAttribute: TextEmphasis underlined from: index to: index;
		yourself! !

!String methodsFor: '*Metacello-Core' stamp: ''!
asMetacelloVersionNumber

	^MetacelloVersionNumber fromString: self! !

!String methodsFor: 'converting' stamp: ''!
withBlanksCondensed
	"Return a copy of the receiver with leading/trailing blanks (separators) removed
	 and consecutive white spaces (separators) condensed to the first one."

	| trimmed lastBlank |
	trimmed := self trimBoth.
	^ String streamContents: [ :stream | 
			lastBlank := false.
			trimmed
				do: [ :eachChar | 
					(eachChar isSeparator and: [ lastBlank ])
						ifFalse: [ stream nextPut: eachChar ].
					lastBlank := eachChar isSeparator ] ]

	" ' abc  d   ' withBlanksCondensed"! !

!String methodsFor: 'accessing' stamp: ''!
lineNumber: anIndex
	"Answer a string containing the characters in the given line number."

	| lineCount |
	lineCount := 0.
	self lineIndicesDo: [:start :endWithoutDelimiters :end |
		(lineCount := lineCount + 1) = anIndex ifTrue: [^self copyFrom: start to: endWithoutDelimiters]].
	^nil! !

!String methodsFor: '*Morphic-Base' stamp: ''!
asDraggableMorph

	^ self asStringMorph! !

!String methodsFor: 'comparing' stamp: ''!
alike: aString 
	"Answer some indication of how alike the receiver is to the argument,  0 is no match, twice aString size is best score (but see example with 7).  Case is ignored. This method is used to help find mistyped variable names in methods."
	"('abc' alike: 'abc') >>> 7."
	"('action' alike: 'actions') >>> 7."
	"('action' alike: 'caption') >>> 5."
	"('action' alike: 'name') >>> 0."	

	| i j k minSize bonus |
	minSize := (j := self size) min: (k := aString size).
	bonus := (j - k) abs < 2 ifTrue: [ 1 ] ifFalse: [ 0 ].
	i := 1.
	[(i <= minSize) and: [((self at: i) asInteger bitAnd: 16rDF)  = ((aString at: i) asciiValue bitAnd: 16rDF)]]
		whileTrue: [ i := i + 1 ].
	[(j > 0) and: [(k > 0) and:
		[((self at: j) asInteger bitAnd: 16rDF) = ((aString at: k) asciiValue bitAnd: 16rDF)]]]
			whileTrue: [ j := j - 1.  k := k - 1. ].
	^ i - 1 + self size - j + bonus! !

!String methodsFor: '*Text-Core' stamp: ''!
encompassParagraph: anInterval
	"Return an interval that includes anInterval, and that comprises one or several whole paragraphs in the receiver.
	Answer starts at the position following a cr (or eventually 1) and ends at a cr (or eventually at self size).
	See also #encompassLine:"
	| left right |
	left := (self lastIndexOf: Character cr startingAt: anInterval first - 1 ifAbsent:[0]) + 1.
	right := (self indexOf: Character cr startingAt: (anInterval last max: anInterval first) ifAbsent: [self size]).
	^left to: right! !

!String methodsFor: 'testing' stamp: ''!
beginsWith: prefix caseSensitive: aBoolean 
	"Answer whether the receiver begins with the given prefix string"

	"IMPLEMENTATION NOTE:
	following algorithm is optimized in primitive only in case self and prefix are bytes like.
	Otherwise, if self or prefix are wide strings, then slow version with asLowercase convertation,
	(primitive is not correct for wide strings)"
	
	"('pharo' beginsWith: '' caseSensitive: false) >>> false"
	"('pharo' beginsWith: 'pharo-project' caseSensitive: false) >>> false"
	"('pharo' beginsWith: 'phuro' caseSensitive: false) >>> false"
	"('pharo' beginsWith: 'Pha' caseSensitive: false) >>> true"

	aBoolean ifTrue: [ ^self beginsWith: prefix ].
	self size < prefix size ifTrue: [^ false].
	(self class isBytes and: [prefix class isBytes]) ifTrue: [
		"Optimized version based on primitive"
		^ (self findSubstring: prefix in: self startingAt: 1 matchTable: CaseInsensitiveOrder) = 1 ].
	prefix withIndexDo: [ :each :index | 
		(self at: index) asLowercase = each asLowercase ifFalse: [ ^false ]
	].
	^true! !

!String methodsFor: '*Regex-Core' stamp: ''!
matchesRegexIgnoringCase: regexString
	"Test if the receiver matches a regex.  May raise RxParser>>regexErrorSignal or
	child signals.
	This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov.
	Refer to `documentation' protocol of RxParser class for details."

	^regexString asRegexIgnoringCase matches: self! !

!String methodsFor: '*Metacello-Core' stamp: ''!
removeFromMetacelloPackages: aMetacelloPackagesSpec

	aMetacelloPackagesSpec addMember: 
		(aMetacelloPackagesSpec removeMember 
			name: self;
			yourself)! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setBlessingInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setBlessing: 
		(aMetacelloVersionSpec project valueHolderSpec
			value: self;
			yourself)! !

!String methodsFor: 'comparing' stamp: ''!
>= aString 
	"Answer whether the receiver sorts after or equal to aString.
	The collation order is simple ascii (with case differences)."
	" 'def' >= 'abc' >>> true"
	" 'def' >= 'def' >>> true"
	" 'abc' >= 'def' >>> false"

	^ (self compare: self with: aString collated: AsciiOrder) >= 2! !

!String methodsFor: 'testing' stamp: ''!
isString
	^ true! !

!String methodsFor: 'formatting' stamp: ''!
withCRs
	"Return a copy of the receiver in which backslash (\) characters have been replaced with carriage returns. For example '-hello\-hi' will be
	'-hello
	 -hi'"

	^ self collect: [ :c | c = $\ ifTrue: [ Character cr ] ifFalse: [ c ]].! !

!String methodsFor: '*Metacello-Core-version comparison' stamp: ''!
metacelloStringLessThanSelf: aString

	^aString < self! !

!String methodsFor: '*Network-MIME' stamp: ''!
asMIMEType
	^ self asZnMimeType! !

!String methodsFor: 'converting' stamp: ''!
asUnsignedInteger
	"Returns the first integer it can find or nil."
	| start stream |
	start := self findFirst: [ :char | char isDigit ].
	start isZero ifTrue: [ ^ nil ].
	stream := self readStream position: start - 1.
	^ Integer readFrom: stream! !

!String methodsFor: 'comparing' stamp: ''!
caseInsensitiveLessOrEqual: aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is case insensitive."
	^(self compare: aString caseSensitive: false) <= 2! !

!String methodsFor: 'finding/searching' stamp: ''!
findString: key startingAt: start caseSensitive: caseSensitive 
	"Answer the index in this String at which the substring key first occurs,
	at or beyond start. The match can be case-sensitive or not. If no match
	is found, zero will be returned."
	
	"IMPLEMENTATION NOTE: do not use CaseSensitiveOrder because it is broken for WideString
	This is a temporary work around until Wide CaseSensitiveOrder search is fixed
	Code should revert to:
	caseSensitive
		ifTrue: [^ self findSubstring: key in: self startingAt: start matchTable: CaseSensitiveOrder]
		ifFalse: [^ self findSubstring: key in: self startingAt: start matchTable: CaseInsensitiveOrder]"
		
	^caseSensitive
		ifTrue: [
			(self class isBytes and: [key class isBytes])
				ifTrue: [self
						findSubstring: key
						in: self
						startingAt: start
						matchTable: CaseSensitiveOrder]
				ifFalse: [WideString new
						findSubstring: key
						in: self
						startingAt: start
						matchTable: nil]]
		ifFalse: [
			(self class isBytes and: [key class isBytes])
				ifTrue: [self
						findSubstring: key
						in: self
						startingAt: start
						matchTable: CaseInsensitiveOrder]
				ifFalse: [WideString new
						findSubstring: key
						in: self
						startingAt: start
						matchTable: CaseInsensitiveOrder]]! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setPackage: aString withInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setPackage: aString withString: self! !

!String methodsFor: 'converting' stamp: ''!
asDuration
 	"Convert from [-]D:HH:MM:SS[.S] format. What is between [] implies optional elements"
 
 	^ Duration fromString: self! !

!String methodsFor: 'comparing' stamp: ''!
= aString 
	"Answer whether the receiver sorts equally as aString.
	The collation order is simple ascii (with case differences)."
	" 'abc' = 'def' >>> false"
	" 'abc' = 'abc' >>> true"
	" 'def' = 'abc' >>> false"
	
	(aString isString and: [self size = aString size]) ifFalse: [^false].
	^ (self compare: self with: aString collated: AsciiOrder) = 2! !

!String methodsFor: 'converting' stamp: ''!
asByteString
	"Convert the receiver into a ByteString, if possible"
	"Do not raise an error if it's not possible, since my use case is usually one in which WideStrings may or may not have been mutated to something representable in a ByteString, and we mostly do this to save space if possible. If the percentage of such cases are small, it may be better to use isOctetString check first to avoid creating String instances"	
	^self asOctetString! !

!String methodsFor: 'comparing' stamp: ''!
sameAs: aString 
	"Answer whether the receiver sorts equal to aString. The 
	collation sequence is ascii with case differences ignored."
	^(self compare: aString caseSensitive: false) = 2! !

!String methodsFor: 'converting' stamp: ''!
asValidSelector
	"Returns a symbol that is a valid selector by removing any space or forbidden characters"
	"'234znak ::x43 ''åå) _ : 2' asValidSelector >>> #'v234znak:x43:v2'"
	"'234znak ::x43 åå) :2' asValidSelector >>> #v234znak:x43:v2"
	
^(((
	$: join: (	
		(
			$: split: (
				self select: [ :char |
					(char charCode < 128) and: [ 
						char isAlphaNumeric or: [ 
							char = $:	
						]	
					]	
				]
			)
		)  
		select: [ :split | split isNotEmpty ]
		thenCollect: [ :nonEmptyString |
			nonEmptyString first isLetter
				ifTrue: [ nonEmptyString uncapitalized ]
				ifFalse: [ 'v' , nonEmptyString ]
		]
	)
) ifEmpty: [ 'v' ]), ((self isNotEmpty and: [ self last = $: ]) ifTrue: [ ':' ] ifFalse: [ #() ]) )asSymbol! !

!String methodsFor: 'accessing' stamp: ''!
indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock
	| index |
	index := self findString: sub startingAt: start.
	index = 0 ifTrue: [^ exceptionBlock value].
	^ index! !

!String methodsFor: 'converting' stamp: ''!
truncateWithElipsisTo: maxLength
	"Return myself or a copy suitably shortened but with elipsis added"

	^ self size <= maxLength
		ifTrue:
			[self]
		ifFalse:
			[(self copyFrom: 1 to: (maxLength - 3)), '...']


	"'truncateWithElipsisTo:' truncateWithElipsisTo: 20"! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setIncludesInMetacelloPackage: aMetacelloPackageSpec

	aMetacelloPackageSpec setIncludes: { self }.! !

!String methodsFor: '*Polymorph-Widgets' stamp: ''!
heightToDisplayInTree: aTree

	^ aTree fontToUse height! !

!String methodsFor: 'converting' stamp: ''!
repeat: aNumber
	"Returns a new string concatenated by itself repeated n times"
	"('abc' repeat: 3) >>> 'abcabcabc'"

	aNumber < 0 ifTrue: [ self error: 'aNumber cannot be negative' ].	
	^ self species 
		new: self size * aNumber 
		streamContents: [ :stringStream |
			1 to: aNumber do: [ :idx | stringStream nextPutAll: self ] ]! !

!String methodsFor: '*Metacello-MC' stamp: ''!
resolvePackageSpecsNamedForMetacelloMCVersion: aMetacelloMCVersion visited: visited ifAbsent: aBlock
    ^ aMetacelloMCVersion
        allPackagesForSpecs: {(aMetacelloMCVersion packageNamed: self ifAbsent: aBlock)}
        visited: visited! !

!String methodsFor: '*Morphic-Base' stamp: ''!
indentationIfBlank: aBlock 
	"Answer the number of leading tabs in the receiver.  If there are
	 no visible characters, pass the number of tabs to aBlock and return its value."
	| reader leadingTabs lastSeparator cr tab ch |
	cr := Character cr.
	tab := Character tab.
	reader := self readStream.
	leadingTabs := 0.
	[ reader atEnd not and: [ (ch := reader next) = tab ] ] whileTrue: [ leadingTabs := leadingTabs + 1 ].
	lastSeparator := leadingTabs + 1.
	[ reader atEnd not and: [ ch isSeparator and: [ ch ~= cr ] ] ] whileTrue: 
		[ lastSeparator := lastSeparator + 1.
		ch := reader next ].
	(lastSeparator = self size or: [ ch = cr ]) ifTrue: [ ^ aBlock value: leadingTabs ].
	^ leadingTabs! !

!String methodsFor: '*NewTools-Spotter' stamp: ''!
spotterPreview: aBuilder

	^ aBuilder newText
		beNotEditable;
		text: self;
		yourself! !

!String methodsFor: 'copying' stamp: ''!
trimRight: aBlock
	"Trim characters satisfying the condition given in aBlock from the right side of the receiving string."

	^ self trimLeft: [ :char | false ] right: aBlock! !

!String methodsFor: 'testing' stamp: ''!
isByteString
	"Answer whether the receiver is a ByteString"
	^false! !

!String methodsFor: 'comparing' stamp: ''!
> aString 
	"Answer whether the receiver sorts after aString.
	The collation order is simple ascii (with case differences)."
	" 'def' > 'abc' >>> true"
	" 'def' > 'def' >>> false"
	" 'abc' > 'def' >>> false"


	^ (self compare: self with: aString collated: AsciiOrder) = 3! !

!String methodsFor: 'converting' stamp: ''!
asInteger 
	"Return the integer present in the receiver, or nil. In case of float, returns the integer part."
	"'1' asInteger >>> 1"
	"'-1' asInteger >>> -1"
	"'10' asInteger >>> 10"
	"'a' asInteger >>> nil"
	"'1.234' asInteger >>> 1"
	^self asSignedInteger! !

!String methodsFor: 'comparing' stamp: ''!
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."
	| index c1 c2 |
	matchTable == nil ifTrue: [
		key size = 0 ifTrue: [^ 0].
		start to: body size - key size + 1 do:
			[:startIndex |
			index := 1.
				[(body at: startIndex+index-1)
					= (key at: index)]
					whileTrue:
					[index = key size ifTrue: [^ startIndex].
					index := index+1]].
		^ 0
	].

	key size = 0 ifTrue: [^ 0].
	start to: body size - key size + 1 do:
		[:startIndex |
		index := 1.
		[c1 := body at: startIndex+index-1.
		c2 := key at: index.
		((c1 leadingChar = 0 and: [ c1 asciiValue < matchTable size ]) 
			ifTrue: [ matchTable at: c1 asciiValue + 1 ]
			ifFalse: [ c1 asciiValue + 1 ]) = 
			((c2 leadingChar = 0 and: [ c2 asciiValue < matchTable size ])
				ifTrue: [ matchTable at: c2 asciiValue + 1 ]
				ifFalse: [c2 asciiValue + 1 ]) ]
			whileTrue:
				[index = key size ifTrue: [^ startIndex].
				index := index+1]].
	^ 0! !

!String methodsFor: 'converting' stamp: ''!
asHex
	"'A' asHex >>> '16r41'"
	"'AA' asHex >>> '16r4116r41'"
	^ self species new: self size * 4 streamContents: [ :stream |
		self do: [ :ch | stream nextPutAll: ch hex ]]! !

!String methodsFor: '*Deprecated10' stamp: ''!
beginsWithEmpty: prefix caseSensitive: aBoolean 
	self 
		deprecated:  'Please use #beginsWith:caseSensitive: and check for empty prefix explicitly' 
		transformWith:  '`@receiver beginsWithEmpty: `@args1 caseSensitive: `@args2' 
						-> ' `@args1 
									ifEmpty: [ true ] 
									ifNotEmpty: [ `@receiver beginsWith: `@args1 caseSensitive: `@args2 ]'.
	^prefix 
		ifEmpty: [ true ]
		ifNotEmpty: [ self beginsWith: prefix caseSensitive: aBoolean ]! !

!String methodsFor: '*Filesystem-Core-converting' stamp: ''!
asFileLocatorOrReference

	^ FileLocator fromString: self ifNone: [ self asFileReference ]! !

!String methodsFor: 'testing' stamp: ''!
isLiteral

	^true! !

!String methodsFor: 'testing' stamp: ''!
isPatternVariable

	 ^self keywords anySatisfy: [:each | each first = $`]! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setPostLoadDoItInMetacelloSpec: aMetacelloSpec
    self asSymbol setPostLoadDoItInMetacelloSpec: aMetacelloSpec! !

!String methodsFor: 'converting' stamp: ''!
asTime
	"Many allowed forms, see Time>>readFrom:"

	^ Time fromString: self.! !

!String methodsFor: 'accessing' stamp: ''!
typeTable
	^ self class typeTable! !

!String methodsFor: '*Slot-Core' stamp: ''!
asSlot
	^ InstanceVariableSlot named: self! !

!String methodsFor: 'converting' stamp: ''!
withoutTrailingNewlines
	"Return a copy of the receiver with any combination of cr/lf characters at the end removed"

	^ self trimRight: [ :char | char = Character cr or: [ char = Character lf ] ]! !

!String methodsFor: '*Morphic-Base' stamp: ''!
asStringMorph 
	"Answer the receiver as a StringMorph"

	^ StringMorph contents: self

"'bugs black blood' asStringMorph openInHand"! !

!String methodsFor: '*Regex-Core' stamp: ''!
search: aString
	"compatibility method to make regexp and strings work polymorphicly"
	^ aString includesSubstring: self! !

!String methodsFor: 'converting' stamp: ''!
withoutTrailingDigits
	"Answer the portion of the receiver that precedes any leading series of digits and separators.
	If the receiver consists entirely of digits and separators, return an empty string"

	^ self trimRight: [ :char | char isDigit or: [ char isSeparator ] ]! !

!String methodsFor: 'finding/searching' stamp: ''!
allRangesOfSubstring: aSubstring
	"('Ab cd ef Ab cd' allRangesOfSubstring: 'cd') >>> {(4 to: 5). (13 to: 14)}"
	"('Ab cd ef Ab cd' allRangesOfSubstring: 'zz') >>> #()"
	
	^ Array streamContents: [:s | | start subSize |
		start := 1.
		subSize := aSubstring size.
		[start isZero]
			whileFalse: [ start := self findString: aSubstring startingAt: start.
				start > 0 
					ifTrue: [s nextPut: (start to: start + subSize - 1).
						start := start + subSize]]]! !

!String methodsFor: 'copying' stamp: ''!
trimLeft
	"Trim separators from the left side of the receiving string."
	
	^ self trimLeft: [ :char | char isSeparator ]! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setBlessingInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setBlessingWithString: self! !

!String methodsFor: 'comparing' stamp: ''!
howManyMatch: string 
	"Count the number of characters in a substring that matches up in self and aString."
	"('ab ab ac de' howManyMatch: 'ab') >>> 2"
	"('abab ac de' howManyMatch: 'abab') >>> 4"
	"('ab ab ac de' howManyMatch: 'a') >>> 1"
	"('ab ab ac de' howManyMatch: 'z') >>> 0"
	
	| count shorterLength |
	count := 0.
	shorterLength := self size min: string size.
	1 to: shorterLength do: [:index |
		(self at: index) = (string at: index )
			ifTrue: [ count := count + 1 ]].
	^  count! !

!String methodsFor: '*Morphic-Base-Widgets' stamp: ''!
listRenderOn: aCanvas atRow: aRow bounds: bounds color: color backgroundColor: backgroundColor from: aMorph

	aCanvas
		drawString: self
		in: bounds
		font: aMorph font
		color: color! !

!String methodsFor: '*Zinc-Character-Encoding-Core' stamp: ''!
asZnCharacterEncoder
	"Return a ZnCharacterEncoder instance using the receiver as identifier"
	
	" 'UTF-8' asZnCharacterEncoder "
	
	^ ZnCharacterEncoder newForEncoding: self! !

!String methodsFor: '*Filesystem-Core-converting' stamp: ''!
asPath
	"convert myself to a path"
	"Examples:
		'.' asPath
		'~/Desktop' asPath
		'/home/foo' asPath
		'../../foo.bar' asPath"
	^ FileSystem disk resolve: self! !

!String methodsFor: 'comparing' stamp: ''!
match: text
	"Answer whether text matches the pattern in this string.
	Matching ignores upper/lower case differences.
	Where this string contains #, text may contain any character.
	Where this string contains *, text may contain any sequence of characters."
	
	"('*' match: 'zort') >>> true"
	"('*baz' match: 'mobaz') >>> true"
	"('*baz' match: 'mobazo') >>>false"
	"('*baz*' match: 'mobazo') >>> true"
	"('*baz*' match: 'mozo') >>> false"
	"('foo*' match: 'foozo') >>> true"
	"('foo*' match: 'bozo') >>> false"
	"('foo*baz' match: 'foo23baz') >>> true"
	"('foo*baz' match: 'foobaz') >>> true"
	"('foo*baz' match: 'foo23bazo') >>> false"
	"('foo' match: 'Foo') >>> true"
	"('foo*baz*zort' match: 'foobazort') >>> false"
	"('foo*baz*zort' match: 'foobazzort') >>> true"
	"('*foo#zort' match: 'afoo3zortthenfoo3zort') >>> true"
	"('*foo*zort' match: 'afoodezortorfoo3zort') >>> true"

	^ self startingAt: 1 match: text startingAt: 1! !

!String methodsFor: 'comparing' stamp: ''!
findIn: body startingAt: start matchTable: matchTable
	
	^ self findSubstringViaPrimitive: self in: body startingAt: start matchTable: matchTable! !

!String methodsFor: 'converting' stamp: ''!
substrings
	"Answer an array of non-empty substrings from the receiver separated by
	one or more whitespace characters."
	
	"'let us make seperate strings' substrings >>>  #('let' 'us' 'make' 'seperate' 'strings')"

	^ self substrings: CSSeparators! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setLoadsInMetacelloProject: aMetacelloPackageSpec

	aMetacelloPackageSpec setLoads: { self }.! !

!String methodsFor: 'accessing' stamp: ''!
indexOf: aCharacter startingAt: start
	"Return the index of the argument in the receiver, only elements after the start of the element are considered zero if not present."
	
	"('abcdf abcedf' indexOf: $a startingAt: 4) >>> 7"
	"('abddf bcdef' indexOf: $a startingAt: 100 ) >>> 0"
	
	(aCharacter isCharacter) ifFalse: [^ 0].
	^ self class indexOfAscii: aCharacter asciiValue inString: self startingAt: start! !

!String methodsFor: '*System-Localization' stamp: ''!
translatedTo: localeID 
	"answer the receiver translated to the given locale id"
	^ NaturalLanguageTranslator translate: self toLocale: localeID! !

!String methodsFor: 'accessing' stamp: ''!
skipAnySubstring: delimiters startingAt: start 
	"Answer the index of the last character within the receiver, starting at start, that does NOT match one of the delimiters. delimiters is a Array of substrings (Characters also allowed).  If the receiver is all delimiters, answer size + 1."

	| any this ind ii |
	ii := start-1.
	[(ii := ii + 1) <= self size] whileTrue: [ "look for char that does not match"
		any := false.
		delimiters do: [:delim |
			delim isCharacter 
				ifTrue: [(self at: ii) == delim ifTrue: [any := true]]
				ifFalse: ["a substring"
					delim size > (self size - ii + 1) ifFalse: "Here's where the one-off error was."
						[ind := 0.
						this := true.
						delim do: [:dd | 
							dd == (self at: ii+ind) ifFalse: [this := false].
							ind := ind + 1].
						this ifTrue: [ii := ii + delim size - 1.  any := true]]
							ifTrue: [any := false] "if the delim is too big, it can't match"]].
		any ifFalse: [^ ii]].
	^ self size + 1! !

!String methodsFor: 'comparing' stamp: ''!
startingAt: keyStart match: text startingAt: textStart
	"Answer whether text matches the pattern in this string.
	Matching ignores upper/lower case differences.
	Where this string contains #, text may contain any character.
	Where this string contains *, text may contain any sequence of characters."
	
	| anyMatch matchStart matchEnd i matchStr j ii jj |
	i := keyStart.
	j := textStart.
	
	"Process consecutive *s and #s at the beginning."
	anyMatch := false.
	[ i <= self size and: [
		(self at: i)
			caseOf: {
				[ $* ] -> [ 
					anyMatch := true.
					i := i + 1.
					true ].
				[ $# ] -> [
					i := i + 1.
					j := j + 1.
					true ] }
			otherwise: [ false ] ] ] whileTrue.
	i > self size ifTrue: [
		^j - 1 = text size or: [ "We reached the end by matching the character with a #."
			anyMatch and: [ j <= text size ] "Or there was a * before the end." ] ].
	matchStart := i.

	"Now determine the match string"
	matchEnd := self size.
	(ii := self indexOf: $* startingAt: matchStart) > 0 ifTrue: [ matchEnd := ii-1 ].
	(ii := self indexOf: $# startingAt: matchStart) > 0 ifTrue: [ matchEnd := matchEnd min: ii-1 ].
	matchStr := self copyFrom: matchStart to: matchEnd.

	"Now look for the match string"
	[jj := text findString: matchStr startingAt: j caseSensitive: false.
	anyMatch ifTrue: [jj > 0] ifFalse: [jj = j]]
		whileTrue:
		["Found matchStr at jj.  See if the rest matches..."
		(self startingAt: matchEnd+1 match: text startingAt: jj + matchStr size) ifTrue:
			[^ true "the rest matches -- success"].
		"The rest did not match."
		anyMatch ifFalse: [^ false].
		"Preceded by * -- try for a later match"
		j := j+1].
	^ false "Failed to find the match string"! !

!String methodsFor: '*Zinc-Character-Encoding-Core' stamp: ''!
urlEncoded
	"URL Encode the receiver and return the resulting String.
	This is an encoding where characters that are illegal in a URL are escaped."

    ^ ZnPercentEncoder new encode: self
! !

!String methodsFor: 'converting' stamp: ''!
asByteArray
	"Convert to a ByteArray with the ascii values of the string."
	"'a' asByteArray >>> #[97]"
	"'A' asByteArray >>> #[65]"
	"'ABA' asByteArray >>> #[65 66 65]"
	self subclassResponsibility! !

!String methodsFor: 'converting' stamp: ''!
squeezeOutNumber
	"Try to find a number somewhere in this string, as explained in Number>readFrom:
	
	this method returns the first number found"
	
	"'th is is29 a stRI4' squeezeOutNumber >>> 29"
	"'th is is2 9 a stRI4' squeezeOutNumber >>> 2"
	
	^ Number squeezeNumberOutOfString: self! !

!String methodsFor: '*Morphic-Base-Widgets' stamp: ''!
widthToDisplayInList: aList

	^ aList font widthOfStringOrText: self contents! !

!String methodsFor: 'system primitives' stamp: ''!
numArgs
	"Answer either the number of arguments that the receiver would take if considered a selector.  Answer -1 if it couldn't be a selector. It is intended mostly for the assistance of spelling correction."

	| firstChar numColons start ix |
	self size = 0 ifTrue: [ ^ -1 ].
	firstChar := self at: 1.
	(firstChar isLetter or: [ firstChar = $_ ])
		ifTrue: [ "Fast reject if any chars are non-alphanumeric
		NOTE: fast only for Byte things - Broken for Wide"
			self class isBytes
				ifTrue: [ (self
						findSubstring: '~'
						in: self
						startingAt: 1
						matchTable: Tokenish) > 0 ifTrue: [ ^ -1 ] ]
				ifFalse: [ 2 to: self size do: [ :i | (self at: i) tokenish ifFalse: [ ^ -1 ] ] ].
			"Fast colon count"
			numColons := 0.
			start := 1.
			[ (ix := self indexOf: $: startingAt: start) > 0 ]
				whileTrue: [ (ix = start or: [ (self at: start) isDigit ]) ifTrue: [ ^ -1 ].
					numColons := numColons + 1.
					start := ix + 1 ].
			numColons = 0 ifTrue: [ ^ 0 ].
			^ self last = $:
				ifTrue: [ numColons ]
				ifFalse: [ -1 ] ].
	"Test case of binary selector, if self allSatisfy: #isSpecial (inlined for speed)"
	1 to: self size do: [ :i | (self at: i) isSpecial ifFalse: [ ^ -1 ] ].
	^ 1! !

!String methodsFor: '*Metacello-Core' stamp: ''!
mergeIntoMetacelloPackages: aMetacelloPackagesSpec

	| spec |
	spec := 
		(aMetacelloPackagesSpec project packageSpec)
			file: self;
			yourself.
	aMetacelloPackagesSpec addMember: 
		(aMetacelloPackagesSpec mergeMember 
			name: spec name;
			spec: spec;
			yourself)! !

!String methodsFor: 'accessing' stamp: ''!
byteSize
	^self subclassResponsibility! !

!String methodsFor: '*Filesystem-Core-converting' stamp: ''!
asResolvedBy: aFileSystem
	^ aFileSystem resolveString: self! !

!String methodsFor: '*EpiceaBrowsers' stamp: ''!
asInstanceSideBehaviorName

	^ (self splitOn: Character space) first! !

!String methodsFor: 'testing' stamp: ''!
occursInWithEmpty: prefix caseSensitive: aBoolean 
	"Answer whether the receiver begins with the given prefix string. 
	The comparison is case-sensitive." 
	| matchTable |
	prefix isEmpty ifTrue: [ ^ true ].
	self size < prefix size ifTrue: [ ^ false ].
	matchTable := aBoolean 
		ifTrue: [ CaseSensitiveOrder ]
		ifFalse: [ CaseInsensitiveOrder ].
	^ (self 
		findSubstring: prefix
		in: self
		startingAt: 1
		matchTable: matchTable) > 0! !

!String methodsFor: 'converting' stamp: ''!
asUncommentedCode
	"this string reprensent a commented code, let's uncomment it"
	
	^String streamContents:  [ :str |
		
		|doubleQuoteAlreadyFound|
		doubleQuoteAlreadyFound := false.
		
		self withoutQuoting do: [ :char |
			char = $"
				ifTrue: [ 
					doubleQuoteAlreadyFound 	ifTrue: [ 
							str nextPut: $" ].
					doubleQuoteAlreadyFound := doubleQuoteAlreadyFound not.
				]
				ifFalse: [ 
					str nextPut: char
				]
		 ]
	]! !

!String methodsFor: 'converting' stamp: ''!
onlyLetters
	"answer the receiver with only letters"
	^ self select:[:each | each isLetter]! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setProject: aString withInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setProject: aString withString: self! !

!String methodsFor: 'testing' stamp: ''!
endsWithAColon 
	"Answer whether the final character of the receiver is a colon"
	"'displayStringOn:' endsWithAColon >>> true"
	"'displayStringOn:foo' endsWithAColon >>> false"
	
	^ self notEmpty and: [ self last == $: ]! !

!String methodsFor: 'converting' stamp: ''!
translateToUppercase
	"Translate all characters to lowercase, in place"

	self translateWith: UppercasingTable! !

!String methodsFor: '*Zinc-Character-Encoding-Core' stamp: ''!
urlDecoded
	"URL Decode the receiver and return the resulting String.
	This is an encoding where characters that are illegal in a URL are escaped."

    ^ ZnPercentEncoder new decode: self! !

!String methodsFor: '*Morphic-Base-Widgets' stamp: ''!
heightToDisplayInList: aList

	^ aList font height! !

!String methodsFor: '*RPackage-Core' stamp: ''!
asPackageIfAbsent: aBlock
	^ RPackageOrganizer default packageNamed: self ifAbsent: aBlock! !

!String methodsFor: '*Zinc-Resource-Meta-Core' stamp: 'nil'!
addedToZnUrl: url
	| segments |
	segments := self findTokens: '/'.
	^ url withPathSegments: segments! !

!String methodsFor: 'accessing' stamp: ''!
lineCount
	"Answer the number of lines represented by the receiver, where every line delimiter CR, LF or CRLF pair adds one line."

	| lineCount |
	lineCount := 0.
	self lineIndicesDo: [:start :endWithoutDelimiters :end |
		lineCount := lineCount + 1].
	^lineCount! !

!String methodsFor: 'converting' stamp: ''!
asDate
	"Many allowed forms, see Date>>#readFrom:"

	^ Date fromString: self! !

!String methodsFor: 'converting' stamp: ''!
translateWith: table
	"translate the characters in the string by the given table, in place"
	^ self translateFrom: 1 to: self size table: table! !

!String methodsFor: 'finding/searching' stamp: ''!
findTokens: delimiters escapedBy: quoteDelimiters 
	"Answer a collection of Strings separated by the delimiters, where  
	delimiters is a Character or collection of characters. Two delimiters in a  
	row produce an empty string (compare this to #findTokens, which  
	treats sequential delimiters as one).  
	 
	The characters in quoteDelimiters are treated as quote characters, such  
	that any delimiter within a pair of matching quoteDelimiter characters  
	is treated literally, rather than as a delimiter.  
	 
	The quoteDelimiter characters may be escaped within a quoted string.  
	Two sequential quote characters within a quoted string are treated as  
	a single character.  
	 
	This method is useful for parsing comma separated variable strings for  
	spreadsheet import and export."
	| tokens rs activeEscapeCharacter ts char token delimiterChars quoteChars |
	delimiterChars := (delimiters 
		ifNil: [ '' ]
		ifNotNil: [ delimiters ]) asString.
	quoteChars := (quoteDelimiters 
		ifNil: [ '' ]
		ifNotNil: [ quoteDelimiters ]) asString.
	tokens := OrderedCollection new.
	rs := self readStream.
	activeEscapeCharacter := nil.
	ts := String new writeStream.
	[ rs atEnd ] whileFalse: 
		[ char := rs next.
		activeEscapeCharacter 
			ifNil: 
				[ (quoteChars includes: char) 
					ifTrue: [ activeEscapeCharacter := char ]
					ifFalse: 
						[ (delimiterChars includes: char) 
							ifTrue: 
								[ token := ts contents.
								tokens add: token.
								ts := String new writeStream ]
							ifFalse: [ ts nextPut: char ] ] ]
			ifNotNil: 
				[ char == activeEscapeCharacter 
					ifTrue: 
						[ rs peek == activeEscapeCharacter 
							ifTrue: [ ts nextPut: rs next ]
							ifFalse: [ activeEscapeCharacter := nil ] ]
					ifFalse: [ ts nextPut: char ] ] ].
	token := ts contents.
	(tokens isEmpty and: [ token isEmpty ]) ifFalse: [ tokens add: token ].
	^ tokens! !

!String methodsFor: 'platform conventions' stamp: ''!
withUnixLineEndings
	"Answer a new instance where all occurrences of CRLF and LF are substituted with LF."
	"(('asa' , String cr , 'asa') withUnixLineEndings at: 4) >>> Character lf"

	^ self withLineEndings: String lf! !

!String methodsFor: 'splitjoin' stamp: ''!
join: aCollection
	"Append the elements of the argument, aSequenceableCollection, separating them by the receiver."
	"('*' join: #('WWWWW' 'W  EW' 'zzzz')) >>> 'WWWWW*W  EW*zzzz'"
	
	^ self species new: (aCollection size * self size) streamContents: [:stream | 
			aCollection
				do: [:each | stream nextPutAll: each asString] 
				separatedBy: [stream nextPutAll: self]]! !

!String methodsFor: '*Metacello-Core' stamp: ''!
execute: projectSpecBlock against: aScriptExecutor
    aScriptExecutor executeString: self do: projectSpecBlock! !

!String methodsFor: 'copying' stamp: ''!
trimBoth
	"Trim separators from both sides of the receiving string."
	
	^ self trimBoth: [ :char | char isSeparator ]! !

!String methodsFor: 'converting' stamp: ''!
surroundedBySingleQuotes
	"Answer the receiver with leading and trailing quotes."
	"'hello' surroundedBySingleQuotes >>>  '''hello'''"
	"'he''llo' surroundedBySingleQuotes >>> '''he''llo'''"
	"'  hello  ' surroundedBySingleQuotes >>>  '''  hello  '''"
	
	^ self surroundedBy: ($' asString)! !

!String methodsFor: '*UnifiedFFI' stamp: ''!
packToArity: arity
	"WARNING: Here applies the same rules as in ByteArray>>#rollToArity:, check there!!"
	arity = 1 ifTrue: [ ^ self ].
	self error: 'Use ExternalAddress instead!!'! !

!String methodsFor: 'copying' stamp: ''!
padRightTo: length with: char
	^ self, (String new: (length - self size max: 0) withAll: char)! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setTimestampInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setTimestamp: 
		(aMetacelloVersionSpec project valueHolderSpec
			value: self;
			yourself)! !

!String methodsFor: 'converting' stamp: ''!
translateToLowercase
	"Translate all characters to lowercase, in place"

	self translateWith: LowercasingTable! !

!String methodsFor: 'converting' stamp: ''!
asPluralBasedOn: aNumberOrCollection
	"Append an 's' to this string based on whether aNumberOrCollection is 1 or of size 1."

	^ (aNumberOrCollection = 1 or:
		[aNumberOrCollection isCollection and: [aNumberOrCollection size = 1]])
			ifTrue: [self]
			ifFalse: [self, 's']! !

!String methodsFor: 'finding/searching' stamp: ''!
findTokens: delimiters
	"Answer the collection of tokens that result from parsing self.  Return strings between the delimiters.  Any character in the Collection delimiters marks a border.  Several delimiters in a row are considered as just one separation.  Also, allow delimiters to be a single character."

	| tokens keyStart keyStop separators |

	tokens := OrderedCollection new.
	separators := delimiters isCharacter 
		ifTrue: [Array with: delimiters]
		ifFalse: [delimiters].
	keyStop := 1.
	[keyStop <= self size] whileTrue:
		[keyStart := self skipDelimiters: separators startingAt: keyStop.
		keyStop := self findDelimiters: separators startingAt: keyStart.
		keyStart < keyStop
			ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
	^tokens! !

!String methodsFor: 'testing' stamp: ''!
isWideString
	"Answer whether the receiver is a WideString"
	^false! !

!String methodsFor: '*Graphics-Canvas' stamp: ''!
displayOn: aDisplayMedium at: aPoint 
	"Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, using black-colored text."

	self displayOn: aDisplayMedium at: aPoint textColor: Color black! !

!String methodsFor: 'copying' stamp: ''!
padLeftTo: length with: char
	^ (String new: (length - self size max: 0) withAll: char) , self.! !

!String methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionString
	<inspectorPresentationOrder: -10 title: 'String'>
	
	^ SpTextPresenter new
		text: (self truncateWithElipsisTo: 100000);
		yourself! !

!String methodsFor: 'testing' stamp: ''!
includesSubstring: substring
	"Returns whether the receiver contains the argument."
	"('abcdefgh' includesSubstring: 'de') >>> true"
	
	^ substring isEmpty or: [ (self findString: substring startingAt: 1) > 0 ]! !

!String methodsFor: 'printing' stamp: ''!
printOn: aStream 
	"Print inside string quotes, doubling inbedded quotes."
 
	self storeOn: aStream! !

!String methodsFor: '*Compression' stamp: 'nil'!
zipped
	| gzstream |

	^ String streamContents: [ :stream |
		gzstream := GZipWriteStream on: stream.
		gzstream nextPutAll: self.
		gzstream close.
 	]! !

!String methodsFor: 'finding/searching' stamp: ''!
findDelimiters: delimiters startingAt: start 
	"Answer the index of the character within the receiver, starting at start, that matches one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1."

	start to: self size do: [:i |
		delimiters do: [:delim | 
			delim = (self at: i) 
				ifTrue: [^ i]]].
	^ self size + 1! !

!String methodsFor: 'accessing' stamp: ''!
indexOf: aCharacter startingAt: start ifAbsent: aBlock
	| ans |
	aCharacter isCharacter ifFalse: [ ^ aBlock value ].
	ans := self class indexOfAscii: aCharacter asciiValue inString: self startingAt: start.
	^ ans = 0
		ifTrue: [ aBlock value ]
		ifFalse: [ ans ]! !

!String methodsFor: 'enumerating' stamp: ''!
flattenOn: aStream
		aStream nextPut: self! !

!String methodsFor: '*UnifiedFFI' stamp: ''!
asFFILibrary 
	^ FFIUnknownLibrary name: self! !

!String methodsFor: 'testing' stamp: ''!
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)"
	1 to: self size do: [:pos |
		(self at: pos) asInteger >= 256 ifTrue: [^ false].
	].
	^ true.! !

!String methodsFor: '*ScriptingExtensions' stamp: ''!
asClassInEnvironment: anEnvironment
	"I return class named after myself from anEnvironment"
	^ self 
		asClassInEnvironment: anEnvironment 
		ifAbsent: [ NotFound signalFor: self in: anEnvironment ]! !

!String methodsFor: '*Metacello-MC' stamp: ''!
removeFromMetacelloRepositories: aMetacelloRepositoriesSpec

	aMetacelloRepositoriesSpec addMember: 
		(aMetacelloRepositoriesSpec removeMember 
			name: self;
			yourself)! !

!String methodsFor: 'testing' stamp: ''!
endsWithDigit
	"Answer whether the receiver's final character represents a digit."
	"'foo10' endsWithDigit >>> true"
	"'foo10foo' endsWithDigit >>> false"
	"'foo1' endsWithDigit >>> true"
	
	^ self notEmpty and: [self last isDigit]! !

!String methodsFor: 'converting' stamp: ''!
asWideString 

	^ WideString from: self! !

!String methodsFor: '*Spec2-Core' stamp: ''!
asPresenterOn: aPresenter

	^ SpLabelPresenter new 
		label: self;
		yourself! !

!String methodsFor: '*UIManager' stamp: ''!
displayProgressFrom: minVal to: maxVal during: workBlock 
	"Display this string as a caption over a progress bar while workBlock is evaluated.

EXAMPLE (Select next 6 lines and Do It)
'Now here''s some real progress'
	displayProgressFrom: 0 to: 10
	during: [:bar |
	1 to: 10 do: [:x | bar value: x.
			(Delay forMilliseconds: 500) wait]].
"
	^ UIManager default 
		displayProgress: self 
		from: minVal 
		to: maxVal 
		during: workBlock! !

!String methodsFor: 'finding/searching' stamp: ''!
findWordStart: key startingAt: start
	| ind |
	"HyperCard style searching.  Answer the index in self of the substring key, when that key is preceeded by a separator character.  Must occur at or beyond start.  The match is case-insensitive.  If no match is found, zero will be returned."

	ind := start.
	[ind := self findString: key startingAt: ind caseSensitive: false.
	ind = 0 ifTrue: [^ 0].	"not found"
	ind = 1 ifTrue: [^ 1].	"First char is the start of a word"
	(self at: ind-1) isSeparator] whileFalse: [ind := ind + 1].
	^ ind	"is a word start"! !

!String methodsFor: '*Morphic-Base-Pluggable Widgets' stamp: ''!
beginsWith: aString fromList: aMorph

	^ self trimBoth asLowercase beginsWith: aString! !

!String methodsFor: '*Text-Core' stamp: ''!
encompassLine: anInterval
	"Return an interval that includes anInterval, and that comprises one or several whole paragraphs in the receiver.
	Answer starts at the position following a cr (or eventually 1) and ends before a cr (or eventually at self size)
	See also encompassParagraph:"
	| left right |
	left := (self lastIndexOf: Character cr startingAt: anInterval first - 1 ifAbsent:[0]) + 1.
	right := (self indexOf: Character cr startingAt: (anInterval last max: anInterval first) ifAbsent: [self size+1])-1.
	^left to: right! !

!String methodsFor: 'comparing' stamp: ''!
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 |
	<primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
	<var: #key declareC: 'unsigned char *key'>
	<var: #body declareC: 'unsigned char *body'>
	<var: #matchTable declareC: 'unsigned char *matchTable'>

	key size = 0 ifTrue: [^ 0].
	(start max: 1) to: body size - key size + 1 do:
		[:startIndex |
		index := 1.
			[(matchTable at: (body basicAt: startIndex+index-1) + 1)
				= (matchTable at: (key basicAt: index) + 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
"! !

!String methodsFor: '*ScriptingExtensions' stamp: ''!
asClassIfAbsent: absentBlock
	"returns a global class with my name"
	^ self asClassInEnvironment: Smalltalk globals ifAbsent: absentBlock! !

!String methodsFor: 'copying' stamp: ''!
trimLeft: aLeftBlock right: aRightBlock
	"Trim characters satisfying the condition given in aLeftBlock from the left side and aRightBlock from the right sides of the receiving string."

	| left right |
	left := 1.
	right := self size.
	
	[ left <= right and: [ aLeftBlock value: (self at: left) ] ]
		whileTrue: [ left := left + 1 ].
		
	[ left <= right and: [ aRightBlock value: (self at: right) ] ]
		whileTrue: [ right := right - 1 ].
		
	^ self copyFrom: left to: right! !

!String methodsFor: 'copying' stamp: ''!
padRightTo: length
	^ self padRightTo: length with: Character space! !

!String methodsFor: 'converting' stamp: ''!
asOctetString
	"Convert the receiver into an octet string, if possible"
	"(IE, I am a WideString containing only character with codePoints < 255, so all of them fit in a latin1-string)."
	| string |
	string := String new: self size.
	1 to: self size do: [:i | string at: i put: (self at: i)].
	^string! !

!String methodsFor: '*Filesystem-Core-converting' stamp: ''!
asFileReference

	^ FileSystem disk referenceTo: self! !

!String methodsFor: 'copying' stamp: ''!
copyUpToSubstring: aSubstring

	aSubstring ifEmpty: [ 
		"preserve compatiblity with `readStream upToAll:`"
		^ String new ].
	
	^ (self findString: aSubstring)
		in: [ :index | index > 0 ifTrue: [ self copyFrom: 1 to: index-1 ] ifFalse: [ self ] ]! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setPreLoadDoItInMetacelloSpec: aMetacelloSpec
    self asSymbol setPreLoadDoItInMetacelloSpec: aMetacelloSpec! !

!String methodsFor: '*Text-Scanning' stamp: ''!
encodedCharSetAt: index
	"return the character encoding in place at index; the actual EncodedCharSet, not just a number. A bad index is an Error"
	^EncodedCharSet charsetAt: 0 "previous leadingChar"! !

!String methodsFor: 'finding/searching' stamp: ''!
findString: substring startingAt: start 
	"Answer the index of the first substring within the receiver, starting at start. If the receiver does not contain substring, answer 0."
	"('salkjsdlkgfee' findString: 'ee'startingAt: 3) >>> 12"
	"('salkjsdlkgfee' findString: 'al'startingAt: 3) >>> 0"
	"('salkjsdlkgfeeal' findString: 'al' startingAt: 1) >>> 2"
	
	^self findString: substring startingAt: start caseSensitive: true! !

!String methodsFor: 'converting' stamp: ''!
withSeparatorsCompacted
    "Returns a copy of the receiver with each sequence of whitespace (separator) 
    characters replaced by a single space character"
    "' test ' withSeparatorsCompacted >>> ' test '"
    "' test  test' withSeparatorsCompacted >>> ' test test'"
    "'test  test      ' withSeparatorsCompacted >>> 'test test '"

    self isEmpty ifTrue: [ ^ self ].
    ^ self species new: self size streamContents: [:stream | 
        | lastBlank |
        lastBlank := false.
        self do: [ :eachChar | 
            lastBlank 
                ifTrue: [
                    (lastBlank := eachChar isSeparator)
                        ifFalse: [ stream nextPut: eachChar ] ] 
                ifFalse: [
                    (lastBlank := eachChar isSeparator)
                        ifTrue: [ stream nextPut: $  ]
                        ifFalse: [ stream nextPut: eachChar ] ] ] ]! !

!String methodsFor: '*Spec2-Core' stamp: ''!
asPresenter 

	^ SpLabelPresenter new 
		label: self;
		yourself! !

!String methodsFor: 'comparing' stamp: ''!
compare: aString 
	"Answer a comparison code telling how the receiver sorts relative to aString:
		1 - before
		2 - equal
		3 - after.
	The collation sequence is ascii with case differences ignored.
	To get the effect of a <= b, but ignoring case, use (a compare: b) <= 2."
	"('aa' compare: 'ab') >>> 1"
	"('aa' compare: 'aa') >>> 2"
	"('ab' compare: 'aa') >>> 3"
	
	^self compare: aString caseSensitive: false! !

!String methodsFor: 'formatting' stamp: ''!
expandMacrosWithArguments: anArray
	"Interpret the receiver pattern (<1p>, <1s>, <t>...) with argument passed in anArray."
	
	"<Np> writes the N-th argument using #printString, but without trancating it."
	"('<1p>: <2p>' expandMacrosWith: 'Number' with: 5 with: nil) >>> '''Number'': 5'"
	
	"<Ns> writes the N-th argument, which should be a String, or a collection of printable objects.
	Note also important distinction for single-quotes inside the argument; with <p> they will be doubled."
	"('<1s> vs <1p>' expandMacrosWith: 'it''em') >>> 'it''em vs ''it''''em'''"
	
	"Whitespace characters:"
	"'<t>' expandMacros >>> String tab"
	"'<r>' expandMacros >>> String cr"
	"'<n>' expandMacros >>> OSPlatform current lineEnding"
	"'<l>' expandMacros >>> String lf"
	
	"Writing '<' character:
	To write '<', prepend it with a percent sign."
	"'%<n>' expandMacros >>> '<n>'"
	
	"Ternary operator:
	An if-else string can be written with <N?yes-string:no-string>.
	The N-th argument must be a Boolean.
	Yes-string cannot contain colon ':', as it terminates the yes-string.
	No-string cannot contain closing angle bracket '>', as it terminates the no-string."
	"('<1?success:error>' expandMacrosWith: true) >>> 'success'"
	"('<1?success:is error>' expandMacrosWith: false) >>> 'is error'"
	
	| readStream char index |
	^ self species
		new: self size
		streamContents:
			[ :newStream | 
			readStream := self readStream.
			[ readStream atEnd ]
				whileFalse:
					[ char := readStream next.
					char == $<
						ifTrue:
							[ | nextChar |
							nextChar := readStream next asUppercase.
							nextChar == $R
								ifTrue: [ newStream cr ].
							nextChar == $L
								ifTrue: [ newStream lf ].
							nextChar == $T
								ifTrue: [ newStream tab ].
							nextChar == $N
								ifTrue: [ newStream nextPutAll: OSPlatform current lineEnding ].
							nextChar isDigit
								ifTrue:
									[ index := nextChar digitValue.
									[ readStream atEnd or: [ (nextChar := readStream next asUppercase) isDigit not ] ]
										whileFalse: [ index := index * 10 + nextChar digitValue ] ].
							nextChar == $?
								ifTrue:
									[ | trueString falseString |
									trueString := readStream upTo: $:.
									falseString := readStream upTo: $>.
									readStream position: readStream position - 1.
									newStream
										nextPutAll:
											((anArray at: index)
												ifTrue: [ trueString ]
												ifFalse: [ falseString ]) ].
							nextChar == $P
								ifTrue: [ (anArray at: index) printOn: newStream  ].
							nextChar == $S
								ifTrue: [ newStream nextPutAll: (anArray at: index) ].
							readStream skipTo: $> ]
						ifFalse: [ newStream
								nextPut:
									(char == $%
										ifTrue: [ readStream next ]
										ifFalse: [ char ]) ] ] ]! !

!String methodsFor: 'copying' stamp: ''!
trim
	"Trim separators from both sides of the receiving string."
	"' this string will be trimmed   ' trim >>> 'this string will be trimmed'"
	
	^ self trimBoth! !

!String methodsFor: '*Polymorph-Widgets' stamp: ''!
widthToDisplayInTree: aTree

	^ aTree fontToUse widthOfStringOrText: self contents! !

!String methodsFor: '*Zinc-Character-Encoding-Core' stamp: ''!
utf8Encoded
	"Produce a ByteArray encoding the receiver using UTF-8,
	the recommended encoding for Strings, unless you know what you are doing."
	
	" 'Les élèves français' utf8Encoded "
	
	^ self encodeWith: ZnCharacterEncoder utf8! !

!String methodsFor: 'converting' stamp: ''!
asLowercase
	"Answer a String made up from the receiver whose characters are all lowercase."
	"'PhaRo' asLowercase >>> 'pharo'"
	"'' asLowercase >>> ''"
	"' ' asLowercase >>> ' '"	
	^ self copy asString translateToLowercase! !

!String methodsFor: '*Files' stamp: 'nil'!
asVmPathName
	"This method returns self encoded in the encoding the system expects.
	We default to utf8 as this is the most common encoding, but we should ask the system the current encoding instead.
	
	Also, note the method name is wrong, this should be fixed"
	self flag: #TODO.
	^ self utf8Encoded! !

!String methodsFor: '*Regex-Core' stamp: ''!
matchesRegex: regexString
	"Test if the receiver matches a regex.  May raise RxParser>>regexErrorSignal or
	child signals.
	This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov.
	Refer to `documentation' protocol of RxParser class for details."

	^regexString asRegex matches: self! !

!String methodsFor: '*Graphics-Canvas' stamp: ''!
displayOn: aDisplayMedium at: aPoint textColor: aColor
	"Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, rendering the text in the designated color"
	aDisplayMedium getCanvas drawString: self from: 1 to: self size at: aPoint font: nil color: aColor! !

!String methodsFor: 'converting' stamp: ''!
withNoLineLongerThan: aNumber
	"Answer a string with the same content as receiver, but rewrapped so that no line has more characters than the given number"
	(aNumber isNumber not or: [ aNumber < 1 ]) ifTrue: [self error: 'too narrow'].
	^self species
		new: self size * (aNumber + 1) // aNumber "provision for supplementary line breaks"
		streamContents: [ :stream |
			self lineIndicesDo: [ :start :endWithoutDelimiters :end |
				| pastEnd lineStart |
				pastEnd := endWithoutDelimiters + 1.
				"eliminate spaces at beginning of line"
				lineStart := (self indexOfAnyOf: CSNonSeparators startingAt: start ifAbsent: [pastEnd]) min: pastEnd.
				[| lineStop lineEnd spacePosition |
				lineEnd := lineStop  := lineStart + aNumber min: pastEnd.
				spacePosition := lineStart.
				[spacePosition < lineStop] whileTrue: [
					spacePosition := self indexOfAnyOf: CSSeparators startingAt: spacePosition + 1 ifAbsent: [pastEnd].
					spacePosition <= lineStop ifTrue: [lineEnd := spacePosition].
				].
				"split before space or before lineStop if no space"
				stream nextPutAll: (self copyFrom: lineStart to: lineEnd - 1).
				"eliminate spaces at beginning of next line"
				lineStart := self indexOfAnyOf: CSNonSeparators startingAt: lineEnd ifAbsent: [pastEnd].
				lineStart <= endWithoutDelimiters ]
					whileTrue: [stream cr].
				stream nextPutAll: (self copyFrom: pastEnd to: end) ] ]! !

!String methodsFor: '*Metacello-Core' stamp: ''!
addToMetacelloPackages: aMetacelloPackagesSpec

	| spec |
	spec := 
		(aMetacelloPackagesSpec project packageSpec)
			file: self;
			yourself.
	aMetacelloPackagesSpec addMember: 
		(aMetacelloPackagesSpec addMember 
			name: spec name;
			spec: spec;
			yourself)! !

!String methodsFor: '*OSWindow-Core' stamp: ''!
asUTF8Bytes
	^ ZnUTF8Encoder new encodeString: self! !

!String methodsFor: 'copying' stamp: ''!
trimRight
	"Trim separators from the right side of the receiving string."
	
	^ self trimRight: [ :char | char isSeparator ]! !

!String methodsFor: 'finding/searching' stamp: ''!
findBetweenSubstrings: delimiters
	"Answer the collection of String tokens that result from parsing self.  Tokens are separated by 'delimiters', which can be a collection of Strings, or a collection of Characters.  Several delimiters in a row are considered as just one separation."

	| tokens keyStart keyStop |
	tokens := OrderedCollection new.
	keyStop := 1.
	[keyStop <= self size] whileTrue:
		[keyStart := self skipAnySubstring: delimiters startingAt: keyStop.
		keyStop := self findAnySubstring: delimiters startingAt: keyStart.
		keyStart < keyStop
			ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
	^tokens! !

!String methodsFor: '*Monticello' stamp: 'nil'!
extractNumber
	^ ('0', self select: [:ea | ea isDigit]) asNumber! !

!String methodsFor: '*SortFunctions-Core' stamp: ''!
threeWayCompareTo: aString
	"Do a three-way comparison between the receiver and anotherObject, returning
	-1 if self < anotherObject
	0 if self = anotherObject
	1 if self > anotherObject
	This assumes a total order in accordance with the mathematical law of trichotomy.
	See also:  http://en.wikipedia.org/wiki/Three-way_comparison"

	 ^ (self compare: self with: aString collated: AsciiOrder) - 2! !

!String methodsFor: 'copying' stamp: ''!
copyReplaceTokens: oldSubstring with: newSubstring 
	"Replace all occurrences of oldSubstring that are surrounded by non-alphanumeric characters"
	"('File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick') >>> 'Snick asFile Files Snick''s Snick'"
	
	^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true! !

!String methodsFor: 'testing' stamp: ''!
isValidGlobalName

	self ifEmpty: [ ^ false ].
	
	"reserverd default names"
	self = 'NameOfSubclass' ifTrue: [ ^ false ].
	self = 'TNameOfTrait' ifTrue: [ ^ false ].
	
	^ (self first isLetter 
				and: [self first isUppercase]) 
				and: [ self allSatisfy: [:character | 
						character isAlphaNumeric or: [ character = $_ ]]]! !

!String methodsFor: 'converting' stamp: ''!
numericSuffix
	"'abc98' numericSuffix >>> 98"
	"'98abc' numericSuffix >>> 0"
	^ self stemAndNumericSuffix last! !

!String methodsFor: '*Regex-Core' stamp: ''!
regex: rxString matchesCollect: aBlock

	^rxString asRegex matchesIn: self collect: aBlock! !

!String methodsFor: '*Metacello-Core' stamp: ''!
asMetacelloSemanticVersionNumber
    ^ MetacelloSemanticVersionNumber fromString: self! !

!String methodsFor: '*UnifiedFFI' stamp: ''!
nullTerminatedEncodeWith: encoding
	"Produce a ByteArray that encodes the receiver, using a specified encoding and adding a null terminator.
	Encoding is either a ZnCharacterEncoder instance or an identifier for one.
	Useful extension for FFI and C integration"
	
	" 'Les élèves français' nullTerminatedEncodeWith: #utf8 "
	
	^ ByteArray streamContents: [ :stream |
		encoding asZnCharacterEncoder next: self size putAll: self startingAt: 1 toStream: stream.
		stream nextPut: 0 "Null terminator" ]! !

!String methodsFor: 'comparing' stamp: ''!
compare: string1 with: string2 collated: order
	
	"'abc' = 'abc' asWideString >>> true"
	"'abc' asWideString = 'abc' >>> true"
	"(ByteArray with: 97 with: 0 with: 0 with: 0) asString ~= 'a000' asWideString >>> true"
	"('abc' sameAs: 'aBc' asWideString) >>> true"
	"('aBc' asWideString sameAs: 'abc') >>> true"
	"('a000' asWideString ~= (ByteArray with: 97 with: 0 with: 0 with: 0) asString) >>> true"
	"((ByteArray with: 97 with: 0 with: 0 with: 0) asString sameAs: 'Abcd' asWideString) >>> false"
	"('a000' asWideString sameAs: (ByteArray with: 97 with: 0 with: 0 with: 0) asString) >>> false"
	
	(string1 isByteString and: [string2 isByteString]) ifTrue: [
		^ ByteString compare: string1 with: string2 collated: order].
     "Primitive does not fail properly right now"
	^ String compare: string1 with: string2 collated: order! !

!String methodsFor: 'converting' stamp: ''!
withoutPeriodSuffix
	"Return a copy of the receiver up to, but not including, the first period.  If the receiver's *first* character is a period, then just return the entire receiver. "

	| likely |
	likely := self copyUpTo: $..
	^ likely size = 0
		ifTrue: [ self ]
		ifFalse: [ likely ]! !

!String methodsFor: 'converting' stamp: ''!
correctAgainst: wordList continuedFrom: oldCollection
	"Like correctAgainst:.  Use when you want to correct against several lists, give nil as the first oldCollection, and nil as the last wordList."

	^ wordList 
		ifNil: [ self correctAgainstEnumerator: nil
					continuedFrom: oldCollection ]
		ifNotNil: [ self correctAgainstEnumerator: [ :action | wordList do: action without: nil]
					continuedFrom: oldCollection ]! !

!String methodsFor: '*Regex-Core' stamp: ''!
regex: rxString matchesDo: aBlock

	^rxString asRegex matchesIn: self do: aBlock! !

!String methodsFor: 'private' stamp: ''!
correctAgainstEnumerator: wordBlock continuedFrom: oldCollection

	"The guts of correction, instead of a wordList, there is a block that should take another block and enumerate over some list with it."

	| choices results maxChoices scoreMin |

	scoreMin := self size // 2 min: 3.
	maxChoices := 10.
	oldCollection
		ifNil: [ choices := SortedCollection sortBlock: [ :x :y | x value > y value ] ]
		ifNotNil: [ choices := oldCollection ].
	wordBlock
		ifNil: [ results := OrderedCollection new.
			1 to: ( maxChoices min: choices size ) do: [ :i | results add: ( choices at: i ) key ]
			]
		ifNotNil: [ wordBlock
				value: [ :word | 
					| score |

					( score := self alike: word ) >= scoreMin
						ifTrue: [ choices add: ( Association key: word value: score ).
							choices size >= maxChoices
								ifTrue: [ scoreMin := ( choices at: maxChoices ) value ]
							]
					].
			results := choices
			].
	^ results! !

!String methodsFor: 'accessing' stamp: ''!
indexOf: aCharacter
	"Return the index starting at 1 of the argument in the receiver, zero if not present."
	"('abcdf' indexOf: $a) >>> 1"
	"('abddf' indexOf: $k) >>> 0"
	
	aCharacter isCharacter ifFalse: [^ 0].
	^ self class
		indexOfAscii: aCharacter asciiValue
		inString: self
		startingAt: 1.! !

!String methodsFor: 'converting' stamp: ''!
stemAndNumericSuffix
	"Parse the receiver into a string-valued stem and a numeric-valued suffix."
	"'Fred2305' stemAndNumericSuffix"

	| stem suffix position |

	stem := self.
	suffix := 0.
	position := 1.
	[stem endsWithDigit and: [stem size > 1]] whileTrue:
		[suffix :=  stem last digitValue * position + suffix.
		position := position * 10.
		stem := stem copyFrom: 1 to: stem size - 1].
	^ Array with: stem with: suffix! !

!String methodsFor: '*ScriptingExtensions' stamp: ''!
asClassIfPresent: presentBlock
	"returns a global class with my name"
	^ presentBlock cull: (self asClassIfAbsent: [ ^ nil ])! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setTimestampInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setTimestampWithString: self! !

!String methodsFor: '*Zinc-Resource-Meta-Core' stamp: 'nil'!
asZnMimeType
	^ ZnMimeType fromString: self! !

!String methodsFor: '*Slot-Core' stamp: ''!
asSlotCollection
	"Parse as slots. Use space, tab and cr as separators
	Example: 
	  'a b' asSlotCollection --> {a => Slot. b => Slot}
	"
	
	^(self substrings: Character separators) collect: [ :substring | substring asSymbol asSlot ]! !

!String methodsFor: '*Regex-Core' stamp: ''!
copyWithRegex: rxString matchesTranslatedUsing: aBlock

	^rxString asRegex
		copy: self translatingMatchesUsing: aBlock! !

!String methodsFor: 'accessing' stamp: ''!
lineIndicesDo: aBlock
	"execute aBlock with 3 arguments for each line:
	- start index of line
	- end index of line without line delimiter
	- end index of line including line delimiter(s) CR, LF or CRLF"
	
	| cr lf start sz nextLF nextCR |
	start := 1.
	sz := self size.
	cr := Character cr.
	nextCR := self indexOf: cr startingAt: 1.
	lf := Character lf.
	nextLF := self indexOf: lf startingAt: 1.
	[ start <= sz ] whileTrue: [
		(nextLF = 0 and: [ nextCR = 0 ])
			ifTrue: [ "No more CR, nor LF, the string is over"
					aBlock value: start value: sz value: sz.
					^self ].
		(nextCR = 0 or: [ 0 < nextLF and: [ nextLF < nextCR ] ])
			ifTrue: [ "Found a LF"
					aBlock value: start value: nextLF - 1 value: nextLF.
					start := 1 + nextLF.
					nextLF := self indexOf: lf startingAt: start ]
			ifFalse: [ 1 + nextCR = nextLF
				ifTrue: [ "Found a CR-LF pair"
					aBlock value: start value: nextCR - 1 value: nextLF.
					start := 1 + nextLF.
					nextCR := self indexOf: cr startingAt: start.
					nextLF := self indexOf: lf startingAt: start ]
				ifFalse: [ "Found a CR"
					aBlock value: start value: nextCR - 1 value: nextCR.
					start := 1 + nextCR.
					nextCR := self indexOf: cr startingAt: start ]]]! !

!String methodsFor: 'converting' stamp: ''!
contractTo: smallSize
	"return myself or a copy shortened by ellipsis to smallSize"
	"('abcd' contractTo: 10) >>> 'abcd'"
	"('Pharo is really super cool' contractTo: 10) >>> 'Phar...ool'"
	"('A clear but rather long-winded summary' contractTo: 18) >>> 'A clear ...summary'"
	
	| leftSize |
	self size <= smallSize
		ifTrue: [^ self].  "short enough"
	smallSize < 5
		ifTrue: [^ self copyFrom: 1 to: smallSize].    "First N characters"
	leftSize := smallSize-2//2.
	^ self copyReplaceFrom: leftSize+1		"First N/2 ... last N/2"
		to: self size - (smallSize - leftSize - 3)
		with: '...'! !

!String methodsFor: 'private' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !

!String methodsFor: 'copying' stamp: ''!
deepCopy
	"DeepCopy would otherwise mean make a copy of the character;  since 
	characters are unique, just return a shallowCopy."

	^self shallowCopy! !

!String methodsFor: 'converting' stamp: ''!
asSymbol
	"Answer the unique Symbol whose characters are the characters of the 
	string."
	^Symbol intern: self! !

!String methodsFor: 'copying' stamp: ''!
trimLineSpaces
	"Trim the spaces from the right side of each line. Useful for code"
	
	^ self species streamContents: [ :str |
		self lines 
			do: [ :line | str nextPutAll: line trimRight]
			separatedBy: [str cr]]! !

!String methodsFor: '*Metacello-MC' stamp: ''!
packageFileSpecFor: aMetacelloPackagesSpec

	^(aMetacelloPackagesSpec project packageSpec)
			file: self;
			yourself! !

!String methodsFor: '*Text-Core' stamp: ''!
asText
	"Answer a Text whose string is the receiver."

	^Text fromString: self! !

!String methodsFor: 'platform conventions' stamp: ''!
withInternetLineEndings
	"change line endings from CR's and LF's to CRLF's.  This is probably in prepration for sending a string over the Internet"
	
	^self withLineEndings: String crlf! !

!String methodsFor: 'comparing' stamp: ''!
charactersExactlyMatching: aString
	"Do a character-by-character comparison between the receiver and aString.  Return the index of the final character that matched exactly."
	"('s' charactersExactlyMatching: 'abc') >>> 0"
	"('fear is the little death that the.' charactersExactlyMatching: 'the') >>> 0"
	"('fear is the little death that the.' charactersExactlyMatching: 'fear is') >>> 7"
	
	| count |
	count := self size min: aString size.
	1 to: count do: [:i | 
		(self at: i) = (aString at: i) ifFalse: [
			^ i - 1]].
	^ count! !

!String methodsFor: 'converting' stamp: ''!
translateFrom: start  to: stop  table: table
	"translate the characters in the string by the given table, in place"
	self class translate: self from: start to: stop table: table! !

!String methodsFor: '*Network-Mail' stamp: ''!
asEmailHeaderString
	^ self! !

!String methodsFor: '*Metacello-Core-version comparison' stamp: ''!
metacelloVersionComponentLessThan: aMetacelloVersonComponent

	^aMetacelloVersonComponent metacelloStringLessThanSelf: self! !

!String methodsFor: 'finding/searching' stamp: ''!
findTokens: delimiters keep: keepers
	"Answer the collection of tokens that result from parsing self.  The tokens are seperated by delimiters, any of a string of characters.  If a delimiter is also in keepers, make a token for it.  (Very useful for carriage return.  A sole return ends a line, but is also saved as a token so you can see where the line breaks were.)"

	| tokens keyStart keyStop |
	tokens := OrderedCollection new.
	keyStop := 1.
	[keyStop <= self size] whileTrue:
		[keyStart := self skipDelimiters: delimiters startingAt: keyStop.
		keyStop to: keyStart-1 do: [:ii | 
			(keepers includes: (self at: ii)) ifTrue: [
				tokens add: (self copyFrom: ii to: ii)]].	"Make this keeper be a token"
		keyStop := self findDelimiters: delimiters startingAt: keyStart.
		keyStart < keyStop
			ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
	^tokens! !

!String methodsFor: 'accessing' stamp: ''!
lines
    "Answer an array of lines composing this receiver without the line ending delimiters"
    ^Array new: (self size // 60 max: 16)
            streamContents: [:lines | self linesDo: [:aLine | lines nextPut: aLine]]! !

!String methodsFor: 'testing' stamp: ''!
hasWideCharacterFrom: start to: stop
	"Return true if one of my character in the range does not fit in a single byte"
	
	"Implementation note: inline #anySatisfy: here for efficiency reasons"
	^(self indexOfWideCharacterFrom: start to: stop) ~= 0! !

!String methodsFor: '*AST-Core-Parser' stamp: ''!
asNumber 
	"Answer the Number created by interpreting the receiver as the string 
	representation of a number."

	^Number readFromString: self! !

!String methodsFor: '*Regex-Core' stamp: ''!
allRangesOfRegexMatches: rxString

	^rxString asRegex matchingRangesIn: self! !

!String methodsFor: 'converting' stamp: ''!
asUppercase
	"Answer a String made up from the receiver whose characters are all uppercase."

	^self copy asString translateToUppercase! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setAuthorInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setAuthorWithString: self! !

!String methodsFor: 'accessing' stamp: ''!
byteAt: index
	^self subclassResponsibility! !

!String methodsFor: 'finding/searching' stamp: ''!
findAnySubstring: aCollection startingAt: start 
	"Answer the index where an element of aCollection begins. If none are found, answer size + 1. aCollection is an Array of Strings or Characters."

	^aCollection inject: 1 + self size into: [:min :searchTerm |
		| ind |
		ind := searchTerm isCharacter 
			ifTrue: [self indexOf: searchTerm startingAt: start ifAbsent: [min]]
			ifFalse: [self indexOfSubCollection: searchTerm startingAt: start ifAbsent: [min]].
		min min: ind]! !

!String methodsFor: 'converting' stamp: ''!
romanNumber
	| value v1 v2 |
	value := v1 := v2 := 0.
	self
		reverseDo: [ :each | 
			each = $-
				ifTrue: [ ^ value negated ].
			v1 := #(1 5 10 50 100 500 1000) at: ('IVXLCDM' indexOf: each).
			value := v1 >= v2
				ifTrue: [ value + v1 ]
				ifFalse: [ value - v1 ].
			v2 := v1 ].
	^ value! !

!String methodsFor: 'finding/searching' stamp: ''!
findLastOccurrenceOfString: substring startingAt: start 
	"Answer the index of the last occurrence of substring within the receiver, starting at start. If 
	the receiver does not contain substring, answer 0.  Case-sensitive match used."

	| last now |
	last := self findString: substring startingAt: start.
	last = 0 ifTrue: [^ 0].
	[last > 0] whileTrue:
		[now := last.
		last := self findString: substring startingAt: last + 1].

	^ now! !

!String methodsFor: 'converting' stamp: ''!
initialIntegerOrNil
	"Answer the integer represented by the leading digits of the receiver, or nil if the receiver does not begin with a digit"
	"'234Whoopie' initialIntegerOrNil >>> 234"
	"'wimpy' initialIntegerOrNil >>> nil"
	"'234' initialIntegerOrNil >>> 234"
	"'2N' initialIntegerOrNil >>> 2"
	"'2' initialIntegerOrNil >>> 2"
	"'  89Ten ' initialIntegerOrNil >>> nil"
	"'78 92' initialIntegerOrNil >>> 78"
	"'3.1415' initialIntegerOrNil >>> 3"
	
	| firstNonDigit |
	(self size = 0 or: [ self first isDigit not ]) 
		ifTrue: [ ^ nil ].
	firstNonDigit := (self findFirst: [ :m | m isDigit not ]).
	firstNonDigit = 0 ifTrue: [ firstNonDigit := self size + 1 ].
	^ (self copyFrom: 1  to: (firstNonDigit - 1)) asNumber! !

!String methodsFor: 'converting' stamp: ''!
withoutLeadingDigits
	"Answer the portion of the receiver that follows any leading series of digits and separators.
	If the receiver consists entirely of digits and separators, return an empty string"

	^ self trimLeft: [ :char | char isDigit or: [ char isSeparator ] ]! !

!String methodsFor: '*Metacello-MC' stamp: ''!
loadRequiredForMetacelloMCVersion: aMetacelloMCVersion

	^aMetacelloMCVersion doLoadRequiredFromArray: (Array with: self).! !

!String methodsFor: 'formatting' stamp: ''!
expandMacrosWith: anObject with: anotherObject 
	^self 
		expandMacrosWithArguments: (Array with: anObject with: anotherObject)! !

!String methodsFor: 'platform conventions' stamp: ''!
withLineEndings: lineEndingString
	"Answer a new instance where all occurrences of CRLF, CR, and LF are substituted with the specified line ending string."
	
	^ self species streamContents: [ :out |
		| in c |
		in := self readStream.
		[ in atEnd ] whileFalse: [
			c := in next.
			"CR"
			c == Character cr ifTrue: [
				c := in peek.
				"CR LF"
				c == Character lf ifTrue: [
					in next.
				].
				out nextPutAll: lineEndingString
			] ifFalse: [
				"LF"
				c == Character lf ifTrue: [
					out nextPutAll: lineEndingString
				] ifFalse: [
					out nextPut: c
				]
			]
		]
	]! !

!String methodsFor: 'accessing' stamp: ''!
string
	^self! !

!String methodsFor: 'testing' stamp: ''!
isAsciiString

	^ self allSatisfy: [ :each | each asciiValue <= 127 ]! !

!String methodsFor: 'converting' stamp: ''!
withoutPrefix: prefix
	"Remove the given prefix, if present."

	^(self beginsWith: prefix) ifTrue: [ self copyFrom: 1 + prefix size to: self size ] ifFalse: [ self ]! !

!String methodsFor: 'testing' stamp: ''!
indexOfWideCharacterFrom: start to: end
	"Return the index of the first wide character following anIndex"
	"Implementation note: inline #anySatisfy: here for efficiency reasons"
	
	start to: end do: [:ix | 
		(self basicAt: ix) > 255 ifTrue: [ ^ix ]].
	^ 0! !

!String methodsFor: 'accessing' stamp: ''!
startsWithDigit
	"Answer whether the receiver's first character represents a digit"
	"'abc' startsWithDigit >>> false"
	"'0abc' startsWithDigit >>> true"
	"'1abc' startsWithDigit >>> true"
	"'11abc' startsWithDigit >>> true"
	
	^ self size > 0 and: [self first isDigit]! !

!String methodsFor: 'copying' stamp: ''!
padLeftTo: length
	^ self padLeftTo: length with: Character space! !

!String methodsFor: 'copying' stamp: ''!
trimBoth: aBlock
	"Trim characters satisfying the condition given in aBlock from both sides of the receiving string."

	^ self trimLeft: aBlock right: aBlock! !

!String methodsFor: 'accessing' stamp: ''!
wordBefore: anIndex 
	"('word before index' wordBefore: 4) >>> 'word'"
	"('word before index' wordBefore: 16) >>> 'inde'"
	
	| sep tok |
	tok := false.
	sep := anIndex.
	[ sep > 0 and: [ (self at: sep) tokenish ] ] whileTrue: 
		[ tok := true.
		sep := sep - 1 ]. 
	^ tok 
		ifTrue: 
			[ self 
				copyFrom: sep + 1
				to: anIndex ]
		ifFalse: [ String new ]! !

!String methodsFor: '*AST-Core' stamp: ''!
isValidSelector
	"check I could be a valid selector (name of method). 
	 For checking if there is symbol like me used as a selector, see #isSelectorSymbol on Symbol"
	^ RBScanner isSelector: self! !

!String methodsFor: 'platform conventions' stamp: ''!
withInternalLineEndings
	"Answer a new instance where all occurrences of CRLF and LF are substituted with CR. Pharo internally uses CR for carriage return."

	^ self withLineEndings: String cr! !

!String methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter writeString: self! !

!String methodsFor: '*Metacello-Core-version comparison' stamp: ''!
metacelloSemanticVersionComponentLessThan: aMetacelloVersonComponent
    ^ aMetacelloVersonComponent metacelloSemanticStringLessThanSelf: self! !

!String methodsFor: 'platform conventions' stamp: ''!
withoutQuoting
	"remove the initial and final quote marks (single quote for string, or double quotes for comments), if present (and if matches nesting quotes). Have a look at testWithoutQuoting. If you want to remove single/double quotes not in first and last positions of the strings, have a look at copyWithout: $' "

	"'''h''' withoutQuoting >>> 'h'"

	"' ''h'' ' withoutQuoting >>>  ' ''h'' '"

	| quote |
	self size < 2 ifTrue: [ ^ self ].
	quote := self first.
	^ (quote = self last and: [ quote = $' or: [ quote = $" ] ])
		ifTrue: [ self copyFrom: 2 to: self size - 1 ]
		ifFalse: [ self ]! !

!String methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects 
	^ false! !

!String methodsFor: 'formatting' stamp: ''!
expandMacrosWith: anObject with: anotherObject with: thirdObject with: fourthObject 
	^self expandMacrosWithArguments: (Array 
				with: anObject
				with: anotherObject
				with: thirdObject
				with: fourthObject)! !

!String methodsFor: '*Tool-FileList' stamp: ''!
asFileName
	"Answer a String made up from the receiver that is an acceptable file 
	name."

	| string checkedString |
	string := FileSystem disk checkName: self fixErrors: true.
	checkedString := FilePathEncoder encode: string.
	^ FilePathEncoder decode: checkedString! !

!String methodsFor: 'accessing' stamp: ''!
byteAt: index put: value
	^self subclassResponsibility! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setAuthorInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setAuthor: 
		(aMetacelloVersionSpec project valueHolderSpec
			value: self;
			yourself)! !

!String methodsFor: '*UnifiedFFI' stamp: ''!
asExternalTypeOn: generator
	^ generator resolveType: self! !

!String methodsFor: 'converting' stamp: ''!
substrings: separators
	"Answer an array of non-empty substrings from the receiver separated by
	one or more characters from the 'separators' argument collection."

	| substrings substringStart |
	substrings := (Array new: 10) writeStream.
	1 to: self size do: [ :i | 
		| nextChar |
		nextChar := self at: i.
		(separators includes: nextChar)
			ifTrue: [
				substringStart
					ifNotNil: [
						substrings nextPut: (self copyFrom: substringStart to: i - 1).
						substringStart := nil ] ]
			ifFalse: [ substringStart ifNil: [ substringStart := i ] ] ].
	substringStart
		ifNotNil: [ substrings nextPut: (self copyFrom: substringStart to: self size) ].
	^ substrings contents! !

!String methodsFor: 'finding/searching' stamp: ''!
findString: substring
	"Answer the index of the first substring within the receiver. If the receiver does not contain substring, answer 0."
	"('salkjsdlkgfee' findString: 'al') >>> 2"
	"('salkjsdlkgfeesd' findString: 'sd') >>> 6"
	
	^self findString: substring startingAt: 1.! !

!String methodsFor: '*Zinc-Resource-Meta-Core' stamp: 'nil'!
asUrl
	^ self asZnUrl ! !

!String methodsFor: '*LibGit-Core' stamp: ' 1/5/2022 21:01:26'!
asLGitExternalString
	| data |
	data := ExternalData
		fromHandle: (ExternalAddress allocate: self size + 1)
		type: ExternalType char asPointerType.
	LibC memCopy: self to: data size: self size.
	data getHandle byteAt: self size + 1 put: 0.
	^ data! !

!String methodsFor: '*Regex-Core' stamp: ''!
allRegexMatches: rxString

	^rxString asRegex matchesIn: self! !

!String methodsFor: 'comparing' stamp: ''!
caseSensitiveLessOrEqual: aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is case sensitive."
	^(self compare: aString caseSensitive: true) <= 2! !

!String methodsFor: 'converting' stamp: ''!
asString
	"Answer this string."

	^ self! !

!String methodsFor: '*Regex-Core' stamp: ''!
prefixMatchesRegex: regexString
	"Test if the receiver's prefix matches a regex.	
	May raise RxParser class>>regexErrorSignal or child signals.
	This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov.
	Refer to `documentation' protocol of RxParser class for details."

	^regexString asRegex matchesPrefix: self! !

!String methodsFor: '*Metacello-MC' stamp: ''!
addToMetacelloRepositories: aMetacelloRepositoriesSpec

	| spec |
	spec := 
		(aMetacelloRepositoriesSpec project repositorySpec)
			description: self;
			yourself.
	aMetacelloRepositoriesSpec addMember: 
		(aMetacelloRepositoriesSpec addMember 
			name: spec name;
			spec: spec;
			yourself)! !

!String methodsFor: 'accessing' stamp: ''!
lineNumberCorrespondingToIndex: anIndex
	"Answer a lineNumber for the line at the given character position."
	|lineNumber|
	
	lineNumber := 0.
	
	self lineIndicesDo: [:start :endWithoutDelimiters :end |
		lineNumber := lineNumber + 1.
		anIndex <= end ifTrue: [^lineNumber]].
	^lineNumber! !

!String methodsFor: 'printing' stamp: ''!
storeOn: aStream
	"Print inside string quotes, doubling inbedded quotes."

	"(String streamContents: [ :s | 'Foo''Bar' storeOn: s ]) >>> '''Foo''''Bar'''"

	| x |
	aStream nextPut: $'.
	1 to: self size do: [ :i | 
		aStream nextPut: (x := self at: i).
		x = $' ifTrue: [ aStream nextPut: x ] ].
	aStream nextPut: $'! !

!String methodsFor: 'comparing' stamp: ''!
<= aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is simple ascii (with case differences)."
	" 'abc' <= 'def' >>> true"
	" 'abc' <= 'abc' >>> true"
	" 'def' <= 'abc' >>> false"
	
	^ (self compare: self with: aString collated: AsciiOrder) <= 2! !

!String methodsFor: 'converting' stamp: ''!
surroundedBy: aString
	"Answer the receiver with leading and trailing aString."
	"('hello' surroundedBy: 'abd') >>> 'abdhelloabd'"
	"('hello' surroundedBy: ' abd ') >>> ' abd hello abd '"
	
	^ self species streamContents: [ :s|
		s nextPutAll: aString.
		s nextPutAll: self.
		s nextPutAll: aString ].! !

!String methodsFor: 'comparing' stamp: ''!
< aString 
	"Answer whether the receiver sorts before aString.
	The collation order is simple ascii (with case differences)."
	" 'abc' < 'def' >>> true"
	" 'abc' < 'abc' >>> false"
	" 'def' < 'abc' >>> false"
	
	
	^ (self compare: self with: aString collated: AsciiOrder) = 1! !

!String methodsFor: 'testing' stamp: ''!
endsWith: suffix caseSensitive: aBoolean 
	"Answer whether the tail end of the receiver is the same as suffix"

	"IMPLEMENTATION NOTE:
	following algorithm is optimized in primitive only in case self and suffix are bytes like.
	Otherwise, if self or suffix are wide strings, then slow version with asLowercase convertation,
	(primitive is not correct for wide strings)"
	
	"('pharo' endsWith: '' caseSensitive: false) >>> false"
	"('pharo' endsWith: 'project-pharo' caseSensitive: false) >>> false"
	"('pharo' endsWith: 'phuro' caseSensitive: false) >>> false"
	"('pharo' endsWith: 'aRo' caseSensitive: false) >>> true"
	aBoolean ifTrue: [ ^self endsWith: suffix ].
	self size < suffix size ifTrue: [^ false].
	(self class isBytes and: [suffix class isBytes]) ifTrue: [
		"Optimized version based on primitive"
		^ (self findSubstring: suffix in: self startingAt: self size - suffix size + 1
				  matchTable: CaseInsensitiveOrder) = (self size - suffix size + 1) ].
	suffix withIndexDo: [ :each :index | 
		(self at: self size - suffix size + index) asLowercase = each asLowercase ifFalse: [ ^false ]
	].
	^true! !

!String methodsFor: 'comparing' stamp: ''!
hash
	"#hash is implemented, because #= is implemented"
	"ar 4/10/2005: I had to change this to use ByteString hash as initial 
	hash in order to avoid having to rehash everything and yet compute
	the same hash for ByteString and WideString."
	^ self class stringHash: self initialHash: ByteString hash! !

!String methodsFor: '*Metacello-Core-version comparison' stamp: ''!
metacelloSemanticStringLessThanSelf: aString
    ^ aString < self! !

!String methodsFor: 'copying' stamp: ''!
copyReplaceAll: oldSubstring with: newSubstring asTokens: ifTokens
	"Answer a copy of the receiver in which all occurrences of oldSubstring have been replaced by newSubstring. ifTokens (valid for Strings only) specifies that the characters surrounding the replacement must not be alphanumeric (space). When ifTokens is set, it means that the replacement will not occur inside word."

	"('test te string' copyReplaceAll: 'te' with: 'longone' asTokens: true) >>> 'test longone string'"
	"('test te string' copyReplaceAll: 'te' with: 'longone' asTokens: false) >>> 'longonest longone string'"

	| aString startSearch currentIndex endIndex |

	aString := self.
	startSearch := 1.
	[(currentIndex := aString indexOfSubCollection: oldSubstring startingAt: startSearch)
			 > 0]
		whileTrue: 
		[endIndex := currentIndex + oldSubstring size - 1.
		(ifTokens not
			or: [(currentIndex = 1
					or: [(aString at: currentIndex-1) isAlphaNumeric not])
				and: [endIndex = aString size
					or: [(aString at: endIndex+1) isAlphaNumeric not]]])
			ifTrue: [aString := aString
					copyReplaceFrom: currentIndex
					to: endIndex
					with: newSubstring.
				startSearch := currentIndex + newSubstring size]
			ifFalse: [
				ifTokens 
					ifTrue: [startSearch := currentIndex + 1]
					ifFalse: [startSearch := currentIndex + newSubstring size]]].
	^ aString! !

!String methodsFor: 'accessing' stamp: ''!
skipDelimiters: delimiters startingAt: start 
	"Answer the index of the character within the receiver, starting at start, that does NOT match one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1.  Assumes the delimiters to be a non-empty string."

	start to: self size do: [:i |
		delimiters detect: [:delim | delim = (self at: i)]
				ifNone: [^ i]].
	^ self size + 1! !

!String methodsFor: '*Polymorph-Widgets' stamp: ''!
treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph

	aCanvas
		drawString: self
		in: drawBounds 
		font: aMorph font
		color: drawColor! !

!String methodsFor: '*Slot-Core' stamp: ''!
asClassVariable
	^ ClassVariable named: self! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setDescriptionInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setDescription: 
		(aMetacelloVersionSpec project valueHolderSpec
			value: self;
			yourself)! !

!String methodsFor: '*Network-MIME' stamp: ''!
decodeMimeHeader
	"See RFC 2047, MIME Part Three: Message Header Extension for Non-ASCII  
	Text. Text containing non-ASCII characters is encoded by the sequence  
	=?character-set?encoding?encoded-text?=  
	Encoding is Q (quoted printable) or B (Base64), handled by  
	Base64MimeConverter / RFC2047MimeConverter.

	Thanks to Yokokawa-san, it works in m17n package.  Try the following:

	'=?ISO-2022-JP?B?U1dJS0lQT1AvGyRCPUJDKyVpJXMlQRsoQi8=?= =?ISO-2022-JP?B?GyRCJVElRiUjJSobKEIoUGF0aW8p?=' decodeMimeHeader.
"
	| input |
	input := self readStream.
	^String streamContents: [ :output | | temp |
		[ output nextPutAll: (input upTo: $=).
		"ASCII Text"
		input atEnd ] whileFalse: 
		[ (temp := input next) = $? 
			ifTrue: 
				[ | pos charset mimeEncoding mimeDecoder charsetStream  |
				charset := input upTo: $?.
				(charset isNil or: [ charset isEmpty ]) ifTrue: [ charset := 'LATIN-1' ].
				mimeEncoding := (input upTo: $?) asUppercase.
				temp := input upTo: $?.
				"Skip final ="
				input next.
				pos := input position.
				input skipSeparators.
				"Delete spaces if followed by ="
				input peek = $= ifFalse: [ input position: pos ]. 
					
				charsetStream := String new writeStream.
				mimeDecoder := mimeEncoding = 'B' 
					ifTrue: [ Base64MimeConverter new ]
					ifFalse: [ RFC2047MimeConverter new ].
				mimeDecoder
					mimeStream: temp readStream;
					dataStream: charsetStream;
					mimeDecode.
				output nextPutAll: (charsetStream contents asByteArray decodeWith: charset).
				]
			ifFalse: 
				[ output
					nextPut: $=;
					nextPut: temp ] ] ]! !

!String methodsFor: 'formatting' stamp: ''!
expandMacrosWith: anObject with: anotherObject with: thirdObject 
	^self expandMacrosWithArguments: (Array 
				with: anObject
				with: anotherObject
				with: thirdObject)! !

!String methodsFor: '*System-Localization' stamp: ''!
translated
"answer the receiver translated to the default language"
	^ NaturalLanguageTranslator translate: self
! !

!String methodsFor: '*NewTools-Spotter-Processors' stamp: ''!
splitCamelCase
	
	| results accum previousIsLower |
	
	results := OrderedCollection new.
	accum := 	self first asString.
	previousIsLower := self first isLowercase.
	
	2 to: self size do: [ :index | | currentCharacter |
		currentCharacter := self at: index.
		(currentCharacter isUppercase and: [ previousIsLower ])
			ifTrue: [ results add: accum. accum := '' ].
			
		accum := accum copyWith: currentCharacter.
		previousIsLower := currentCharacter isLowercase.
	].	
	
	results add: accum.
	
	^ results.! !

!String methodsFor: 'converting' stamp: ''!
unescapeCharacter: aCharacter
	"Unescape an escaped string. Assume the string has all occurrences of aCharacter are escaped. That is, they are in pairs.
	This method returns a copy of the string replacing all pairs of aCharacter by a single appearance of it."
	
	"('''''' unescapeCharacter: $') >>> ''''"
	"('''' unescapeCharacter: $') >>> ''"
	
	| result stream |
	result := WriteStream with: ''.
	stream := ReadStream on: self.
	[ stream atEnd ] whileFalse: 
			[ result nextPutAll: (stream upTo: aCharacter).
			  stream peek ifNotNil: [result nextPut: stream next]].
	^result contents! !

!String methodsFor: 'converting' stamp: ''!
capitalized
	"Return a copy with the first letter capitalized"
	| cap |
	self isEmpty ifTrue: [ ^self copy ].
	cap := self copy.
	cap at: 1 put: (cap at: 1) asUppercase.
	^ cap! !

!String methodsFor: 'formatting' stamp: ''!
format: collection
	"Format the receiver by interpolating elements from collection, as in the following examples:" 
	"('Five is {1}.' format: { 1 + 4}) >>> 'Five is 5.'"
	"('Five is {five}.' format: (Dictionary with: #five -> 5)) >>>  'Five is 5.'"
	"('In {1} you can escape \{ by prefixing it with \\' format: {'strings'}) >>> 'In strings you can escape { by prefixing it with \' "
	"('In \{1\} you can escape \{ by prefixing it with \\' format: {'strings'}) >>> 'In {1} you can escape { by prefixing it with \' "

	^ self species
		new: self size
		streamContents: [ :result | 
			| stream |
			stream := self readStream.
			[ stream atEnd ]
				whileFalse: [ | currentChar |
					(currentChar := stream next) == ${
						ifTrue: [ | expression index |
							expression := stream upTo: $}.
							index := Integer readFrom: expression ifFail: [ expression ].
							result nextPutAll: (collection at: index) asString ]
						ifFalse: [ currentChar == $\
								ifTrue: [ stream atEnd
										ifFalse: [ result nextPut: stream next ] ]
								ifFalse: [ result nextPut: currentChar ] ] ] ]! !

!String methodsFor: '*Graphics-Canvas' stamp: ''!
displayAt: aPoint 
	"Display the receiver as a DisplayText at aPoint on the display screen."

	self displayOn: Display at: aPoint! !

!String methodsFor: 'accessing' stamp: ''!
linesDo: aBlock
	"Execute aBlock with each line in this string. The terminating line delimiters CR, LF or CRLF pairs are not included in what is passed to aBlock"

	self lineIndicesDo: [:start :endWithoutDelimiters :end |
		aBlock value: (self copyFrom: start to: endWithoutDelimiters)]! !

!String methodsFor: '*Morphic-Base' stamp: ''!
asMorph 
	"Answer the receiver as a StringMorph"

	^ StringMorph contents: self

"'bugs black blood' asMorph openInHand"! !

!String methodsFor: 'converting' stamp: ''!
correctAgainst: wordList
	"Correct the receiver: assume it is a misspelled word and return the (maximum of five) nearest words in the wordList.  Depends on the scoring scheme of alike:"
	| results |
	results := self correctAgainst: wordList continuedFrom: nil.
	results := self correctAgainst: nil continuedFrom: results.
	^ results! !

!String methodsFor: 'accessing' stamp: ''!
indexOfSubCollection: sub 
	""

	^ self
		indexOfSubCollection: sub
		startingAt: 1
		ifAbsent: [0]! !

!String methodsFor: 'accessing' stamp: ''!
lineCorrespondingToIndex: anIndex
	"Answer a string containing the line at the given character position."

	self lineIndicesDo: [:start :endWithoutDelimiters :end |
		anIndex <= end ifTrue: [^self copyFrom: start to: endWithoutDelimiters]].
	^''! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setRequiresInMetacelloPackage: aMetacelloPackageSpec

	aMetacelloPackageSpec setRequires: { self }.! !

!String methodsFor: 'testing' stamp: ''!
isAllAlphaNumerics
	"Returns whether the receiver is composed entirely of alphanumerics (i.e., letters or digits)."
	"'3.123' isAllAlphaNumerics >>> false"
	"'a3123abc' isAllAlphaNumerics >>> true"
	"'3123' isAllAlphaNumerics >>> true"
	"'3,123' isAllAlphaNumerics >>> false"
	"'a''b' isAllAlphaNumerics >>> false"
	
	self do: [:c | c isAlphaNumeric ifFalse: [^ false]].
	^ true! !

!String methodsFor: '*Compression' stamp: 'nil'!
unzipped
	| magic1 magic2 |
	magic1 := (self at: 1) asInteger.
	magic2 := (self at: 2) asInteger.
	(magic1 = 16r1F and:[magic2 = 16r8B]) ifFalse:[^self].
	^(GZipReadStream on: self) upToEnd! !

!String methodsFor: 'testing' stamp: ''!
isAllSeparators
	"Returns whether the receiver is composed entirely of separators i.e., a space, tab, lf, cr, and newPage"
	"(Character space asString, Character space asString) isAllSeparators >>> true"
	"(Character space asString, 'a') isAllSeparators >>> false"
	self do: [ :c | c isSeparator ifFalse: [ ^false ] ].
	^true! !

!String methodsFor: 'accessing' stamp: ''!
indexOfFirstUppercaseCharacter
	"Returns the index of the first Uppercase character.
	'uouFauhZ ' indexOfFirstUppercaseCharacter2 -> 4
	New implementation much faster than older one.
	"
	| size |
	size := self size.
	1 to: size do: [:i| 
		(self at: i) isUppercase 
			ifTrue: [^ i ]].
	^ 0! !

!String methodsFor: '*Metacello-MC' stamp: ''!
fetchRequiredForMetacelloMCVersion: aMetacelloMCVersion

	^aMetacelloMCVersion doFetchRequiredFromArray: (Array with: self).! !

!String methodsFor: 'converting' stamp: ''!
asSignedInteger 
	"Returns the first signed integer it can find or nil."

	| start stream |
	start := self findFirst: [:char | char isDigit].
	start isZero ifTrue: [^ nil].
	stream := self readStream position: start - 1.
	((stream position ~= 0) and: [stream peekBack = $-])
		ifTrue: [stream back].
	^ Integer readFrom: stream! !

!String methodsFor: '*Metacello-Core' stamp: ''!
setImportInVersionSpec: aMetacelloVersionSpec
  aMetacelloVersionSpec setImport: {self}! !

!String methodsFor: '*Metacello-MC' stamp: ''!
mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec

	| spec |
	spec := 
		(aMetacelloRepositoriesSpec project repositorySpec)
			description: self;
			yourself.
	aMetacelloRepositoriesSpec addMember: 
		(aMetacelloRepositoriesSpec mergeMember 
			name: spec name;
			spec: spec;
			yourself)! !

!String methodsFor: 'converting' stamp: ''!
asCamelCase
	"Convert to CamelCase, i.e, remove spaces, and convert starting lowercase to uppercase."
   "'A man, a plan, a canal, panama' asCamelCase >>> 'AMan,APlan,ACanal,Panama'"
 	"'Here 123should % be 6 the name6 of the method' asCamelCase  >>> 'Here123should%Be6TheName6OfTheMethod'"
		^ self species streamContents: [:stream |
               self substrings do: [:sub |
                       stream nextPutAll: sub capitalized]]! !

!String methodsFor: '*Text-Core' stamp: ''!
asStringOrText
	"Answer this string."

	^ self
! !

!String methodsFor: 'testing' stamp: ''!
includesSubstring: aString caseSensitive: caseSensitive
	"Returns whether the receiver contains the argument."
	"('abcdefgh' includesSubstring: 'de' caseSensitive: false) >>> true"
	"('abcdefgh' includesSubstring: 'DE' caseSensitive: false) >>> true"
	"('abcDefgh' includesSubstring: 'De' caseSensitive: true) >>> true"
	"('abcDefgh' includesSubstring: 'DE' caseSensitive: true) >>> false"
	
	^ (self findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0! !

!String methodsFor: 'testing' stamp: ''!
isAllDigits
	"Return whether the receiver is composed entirely of digits and has at least one digit"
	"'2345' isAllDigits >>> true"
	"'0002345' isAllDigits >>> true"
	"'2345.88' isAllDigits >>> false"
	
	self do: [:c | c isDigit ifFalse: [^ false]].
	self ifEmpty: [^false].
	^ true! !

!String methodsFor: 'streaming' stamp: ''!
putOn: aStream
	"Write the receiver onto aStream by iterating over its elements.
	In general we assume aStream accepts the receiver's elements as element type.
	This is an optimisation.
	Return self."

	aStream nextPutAll: self! !

!String methodsFor: '*Filesystem-Core-converting' stamp: ''!
asPathWith: anObject 
	^ anObject pathFromString: self! !

!String methodsFor: '*System-Platforms-Windows' stamp: 'nil'!
asWin32WideString

	^ Win32WideString fromString: self! !

!String methodsFor: '*OpalCompiler-Core' stamp: ''!
parseLiterals
	^ self class compiler parseLiterals: self! !

!String methodsFor: 'converting' stamp: ''!
findSelector
	"Extract a selector with keyword parts from the receiver. While this doesn't give a true parse, in most cases it does what we want, in where it doesn't, we're none the worse for it."
	
	"'isSymbol' findSelector >>> #isSymbol"
	"'x isSymbol' findSelector >>> nil"
	"'x isSymbol: 33' findSelector >>> #isSymbol:"
	"'between:and:' findSelector >>> #'between:and:'"
	"'2 between: 0 and: 4' findSelector >>> #'between:and:'"
	"'2 between: ( 1 and: 4)' findSelector >>> #between:"
	"'( 1 and: 4)' findSelector >>> nil"
	
	| sel possibleParens |
	sel := self trimBoth.
	sel := sel copyReplaceAll: '#' with: ''.
	sel := sel copyReplaceAll: '[' with: ' [ '.
	(sel includes: $:) ifTrue:
		[sel := sel copyReplaceAll: ':' with: ': '.	"for the style (aa max:bb) with no space"
		possibleParens := sel findTokens: Character separators.
		sel := self species streamContents:
			[:s | | level | level := 0.
			possibleParens do:
				[:token | | n |
				(level = 0 and: [token endsWith: ':'])
					ifTrue: [s nextPutAll: token]
					ifFalse: [(n := token occurrencesOf: $( ) > 0 ifTrue: [level := level + n].
							(n := token occurrencesOf: $[ ) > 0 ifTrue: [level := level + n].
							(n := token occurrencesOf: $] ) > 0 ifTrue: [level := level - n].
							(n := token occurrencesOf: $) ) > 0 ifTrue: [level := level - n]]]]].

	sel isEmpty ifTrue: [^ nil].
	sel isOctetString ifTrue: [sel := sel asOctetString].
	Symbol hasInterned: sel ifTrue:
		[:aSymbol | ^ aSymbol].
	^ nil! !

!String methodsFor: 'converting' stamp: ''!
truncateTo: smallSize
	"return myself or a copy shortened to smallSize."

	^ self size <= smallSize
		ifTrue: [ self ]
		ifFalse: [ self copyFrom: 1 to: smallSize ]! !

!String methodsFor: 'printing' stamp: ''!
displayStringOn: aStream
	"Make sure that this is not printOn: because we do not want to have multiple quotes."
	aStream nextPutAll: self! !

!String methodsFor: '*Graphics-Canvas' stamp: ''!
displayOn: aDisplayMedium
	"Display the receiver on the given DisplayMedium."

	self displayOn: aDisplayMedium at: 0 @ 0! !

!String methodsFor: 'testing' stamp: ''!
includesUnifiedCharacter
	^false! !

!String methodsFor: '*Compression' stamp: 'nil'!
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! !

!String methodsFor: 'copying' stamp: ''!
trimLeft: aBlock
	"Trim characters satisfying the condition given in aBlock from the left side of the receiving string."
	
	^ self trimLeft: aBlock right: [ :char | false ]! !

!String methodsFor: 'testing' stamp: ''!
lastSpacePosition
	"Answer the character position of the final space or other separator character in the receiver, and 0 if none"
	"'fred the bear' lastSpacePosition >>> 9"
	"'ziggie' lastSpacePosition >>> 0"
	"'elvis ' lastSpacePosition >>> 6"
	"'elvis  ' lastSpacePosition >>> 7"
	"'' lastSpacePosition >>> 0"

	self size to: 1 by: -1 do:
		[:i | ((self at: i) isSeparator) ifTrue: [^ i]].
	^ 0! !

!String methodsFor: 'formatting' stamp: ''!
expandMacrosWith: anObject 
	"('Pharo is <1s>' expandMacrosWith: 'cool') >>> 'Pharo is cool'"
	"('Pharo is <1p>' expandMacrosWith: 'cool') >>> 'Pharo is ''cool'''"

	^self expandMacrosWithArguments: (Array with: anObject)! !

!String methodsFor: 'copying' stamp: ''!
copyReplaceAll: oldSubstring with: newSubstring
	"Answer a copy of the receiver in which all occurrences of oldSubstring have been replaced by newSubstring"
	"('ab cd ab ef ab' copyReplaceAll: 'ab' with: 'zk') >>> 'zk cd zk ef zk'"
    | idx |        
    self = oldSubstring ifTrue: [ ^ newSubstring copy ].
    oldSubstring isEmpty ifTrue: [ ^ self copy ].
    idx := 1.
    ^ self species new: self size streamContents: [ :stream | | foundIdx |
        [ (foundIdx := self findString: oldSubstring startingAt: idx) isZero ] whileFalse: [ 
            stream 
                next: (foundIdx - idx) putAll: self startingAt: idx;
                nextPutAll: newSubstring.
            idx := foundIdx + oldSubstring size ].
        idx <= self size ifTrue: [ 
            stream next: (self size - idx + 1) putAll: self startingAt: idx ] ]! !

!String methodsFor: '*Metacello-Core-version comparison' stamp: ''!
metacelloIntegerLessThanSelf: anInteger
	"integer version components are always '>' string component"

	^false! !

!String methodsFor: 'converting' stamp: ''!
asDateAndTime
 	"Convert from UTC format" 	
	
	^ DateAndTime fromString: self! !

!String methodsFor: 'copying' stamp: ''!
trimmed
	^ self trimBoth! !

!String methodsFor: '*Metacello-MC' stamp: ''!
recordRequiredForMetacelloMCVersion: aMetacelloMCVersion

	^aMetacelloMCVersion doRecordRequiredFromArray: (Array with: self).! !

!String methodsFor: 'converting' stamp: ''!
asComment
	"return this string, munged so that it can be treated as a comment in Smalltalk code.  Quote marks are added to the beginning and end of the string, and whenever a solitary quote mark appears within the string, it is doubled"

	^String streamContents:  [ :str |
		| quoteCount first |

		str nextPut: $".
	
		quoteCount := 0.
		first := true.
		self do: [ :char |
			char = $"
				ifTrue: [
					first ifFalse: [
						str nextPut: char.
						quoteCount := quoteCount + 1 ] ]
				ifFalse: [
					quoteCount odd ifTrue: [
						"add a quote to even the number of quotes in a row"
						str nextPut: $" ].
					quoteCount := 0.
					str nextPut: char ].
			first := false ]. 

		quoteCount odd ifTrue: [
			"check at the end"
			str nextPut: $". ].

		str nextPut: $".
	]! !

!String methodsFor: '*Regex-Core' stamp: ''!
asRegexIgnoringCase
	"Compile the receiver as a regex matcher. May raise RxParser>>syntaxErrorSignal
	or RxParser>>compilationErrorSignal.
	This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov.
	Refer to `documentation' protocol of RxParser class for details."

	^RxParser preferredMatcherClass
		for: (RxParser new parse: self)
		ignoreCase: true! !

!String methodsFor: 'converting' stamp: ''!
correctAgainstDictionary: wordDict continuedFrom: oldCollection
	"Like correctAgainst:continuedFrom:.  Use when you want to correct against a dictionary."

	^ wordDict 
		ifNil: [ self correctAgainstEnumerator: nil
					continuedFrom: oldCollection ]
		ifNotNil: [ self correctAgainstEnumerator: [ :action | wordDict keysDo: action ]
					continuedFrom: oldCollection ]! !

!String methodsFor: 'converting' stamp: ''!
asHTMLString
	"substitute the < & > into HTML compliant elements"
	"'<a>' asHTMLString"
	^ self species new: self size streamContents: [ :s| 
		self do: [:c | s nextPutAll: c asHTMLString ]]! !

!String methodsFor: '*Metacello-Core-version comparison' stamp: ''!
metacelloSemanticIntegerLessThanSelf: anInteger
    "integer version components are always '>' string component"

    ^ true! !

!String methodsFor: '*CodeExport' stamp: ''!
writeLeadingCharRunsOn: stream

	self isEmpty ifTrue: [^ self].

	stream nextPut: $(.
	stream print: self size.
	stream skip: -1; nextPut: $).
	stream print: 0 "was leading char".
	stream skip: -1! !

!String methodsFor: '*Zinc-Resource-Meta-Core' stamp: 'nil'!
asZnUrl
	^ ZnUrl fromString: self! !

!String methodsFor: '*Text-Core' stamp: ''!
endOfParagraphBefore: aNumber
	"Return the index of the last Character cr before position aNumber, or zero if this is the first paragraph.
	'ddd' endOfParagraphBefore: 3
	'dd
	d' endOfParagraphBefore: 4
	"
	^ self lastIndexOf: Character cr startingAt: aNumber - 1 ifAbsent: [ 0 ]! !

!String methodsFor: 'converting' stamp: ''!
keywords
	"Answer an array of the keywords that compose the receiver."
	| keywords |
	keywords := Array streamContents:
		[:kwds | | char kwd | kwd := (String new: 16) writeStream.
		1 to: self size do:
			[:i |
			kwd nextPut: (char := self at: i).
			char = $: ifTrue: 
					[kwds nextPut: kwd contents.
					kwd reset]].
		(kwd position = 0) ifFalse: [kwds nextPut: kwd contents]].
	(keywords size >= 1 and: [(keywords at: 1) = ':']) ifTrue:
		["Has an initial keyword, as in #:if:then:else:"
		keywords := keywords allButFirst].
	(keywords size >= 2 and: [(keywords at: keywords size - 1) = ':']) ifTrue:
		["Has a final keyword, as in #nextPut::andCR"
		keywords := keywords copyReplaceFrom: keywords size - 1
								to: keywords size with: {':' , keywords last}].
	^ keywords! !

!String methodsFor: '*Zinc-Character-Encoding-Core' stamp: ''!
encodeWith: encoding
	"Produce a ByteArray that encodes the receiver, using a specified encoding.
	Encoding is either a ZnCharacterEncoder instance or an identifier for one."
	
	" 'Les élèves français' encodeWith: #utf8 "
	
	^ encoding asZnCharacterEncoder encodeString: self! !

!String methodsFor: 'testing' stamp: ''!
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"
	
	"('pharo' beginsWith: '') >>> false"
	"('pharo' beginsWith: 'pharo-project') >>> false"
	"('pharo' beginsWith: 'phuro') >>> false"
	"('pharo' beginsWith: 'pha') >>> true"
	
	(self class isBytes and: [ prefix class isBytes ]) ifFalse: [^super beginsWith: prefix].
	
	self size < prefix size ifTrue: [^ false].
	^ (self findSubstring: prefix in: self startingAt: 1 
			  matchTable: CaseSensitiveOrder) = 1! !

!String methodsFor: 'comparing' stamp: ''!
compare: aString caseSensitive: aBool
	"Answer a comparison code telling how the receiver sorts relative to aString:
		1 - before
		2 - equal
		3 - after.
	"
	| map |
	map := aBool ifTrue:[CaseSensitiveOrder] ifFalse:[CaseInsensitiveOrder].
	^self compare: self with: aString collated: map! !

!String methodsFor: 'testing' stamp: ''!
endsWith: suffix
	"Answer whether the receiver ends 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"
	
	"('pharo' endsWith: '') >>> false"
	"('pharo' endsWith: 'project-pharo') >>> false"
	"('pharo' endsWith: 'phuro') >>> false"
	"('pharo' endsWith: 'aro') >>> true"
	"('pharo' endsWith: 'aRo') >>> false"
	
	| requiredStart |
	(self class isBytes and: [ suffix class isBytes ]) ifFalse: [^super endsWith: suffix].	
	requiredStart := self size - suffix size + 1.
	requiredStart <= 0 ifTrue: [  ^false ].
	
	^ (self findSubstring: suffix in: self startingAt: requiredStart
			  matchTable: CaseSensitiveOrder) = requiredStart! !

!String methodsFor: 'finding/searching' stamp: ''!
findCloseParenthesisFor: startIndex
	"assume (self at: startIndex) is $(.  Find the matching $), allowing parentheses to nest."
	" '(1+(2-3))-3.14159' findCloseParenthesisFor: 1 "
	" '(1+(2-3))-3.14159' findCloseParenthesisFor: 4 "
	| pos nestLevel |
	pos := startIndex+1.
	nestLevel := 1.
	[ pos <= self size ] whileTrue: [
		(self at: pos) = $( ifTrue: [ nestLevel := nestLevel + 1 ].
		(self at: pos) = $) ifTrue: [ nestLevel := nestLevel - 1 ].
		nestLevel = 0 ifTrue: [ ^pos ].
		pos := pos + 1.
	].
	^self size + 1! !

!String methodsFor: 'private' stamp: ''!
stringhash

	^ self hash.! !

!String methodsFor: 'finding/searching' stamp: ''!
findTokens: delimiters includes: substring
	"Divide self into pieces using delimiters.  Return the piece that includes substring anywhere in it.  Is case sensitive (say asLowercase to everything beforehand to make insensitive)."

^ (self findTokens: delimiters) 
	detect: [:str | (str includesSubstring: substring)] 
	ifNone: [nil]! !

!String methodsFor: '*Network-MIME' stamp: ''!
base64Decoded
	"Decode the receiver assuming it was encoded using Base64, returning a ByteArray.
	Base64 encoding is a technique to represent binary data as ASCII text.
	The inverse operation is ByteArray>>#base64Encoded"
	
	"'AgMFBwsNERMXHR8lKSsvNTs9Q0dJT1NZYWVna21xf4OJi5WXnaOnrbO1v8HFx9Pf4+Xp7/H7' base64Decoded"
	"'SGVsbG8gV29ybGQh' base64Decoded utf8Decoded"
	
	^ ZnBase64Encoder new decode: self! !

!String methodsFor: '*Network-MIME' stamp: ''!
decodeQuotedPrintable
	"Assume receiver is in MIME 'quoted-printable' encoding, and decode it."
  
	^QuotedPrintableMimeConverter mimeDecode: self as: self class! !

!String methodsFor: 'testing' stamp: ''!
isLiteralSymbol
	"Test whether a symbol can be stored as # followed by its characters.  
	Symbols created internally with asSymbol may not have this property, 
	e.g. '3' asSymbol."

	| i ascii type next last |
	self flag: 'reuse a parser for this'.
	
	i := self size.
	i = 0 ifTrue: [^ false].

	"TypeTable should have been origined at 0 rather than 1 ..."
	ascii := (self at: 1) asciiValue.
	type := self typeTable at: ascii ifAbsent: [^false].
	type == #xLetter ifTrue: [
		next := last := nil.
		[i > 1]
				whileTrue: 
					[ascii := (self at: i) asciiValue.
					type := self typeTable at: ascii ifAbsent: [^false].
					(type == #xLetter or: [type == #xDigit or: [type == #xColon
							and: [
								next == nil
									ifTrue: [last := #xColon. true] 
									ifFalse: [last == #xColon and: [next ~~ #xDigit and: [next ~~ #xColon]]]]]])
						ifFalse: [^ false].
					next := type.
					i := i - 1].
			^ true].	
	type == #xBinary ifTrue: [^i = 1]. "Here we could extend to
		^(2 to: i) allSatisfy: [:j |
			ascii := (self at: j) asciiValue.
			(self typeTable at: ascii ifAbsent: []) == #xBinary]"
	type == #verticalBar ifTrue: [^i = 1].
	^false! !

!String methodsFor: '*Regex-Core' stamp: ''!
prefixMatchesRegexIgnoringCase: regexString
	"Test if the receiver's prefix matches a regex.	
	May raise RxParser class>>regexErrorSignal or child signals.
	This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov.
	Refer to `documentation' protocol of RxParser class for details."

	^regexString asRegexIgnoringCase matchesPrefix: self! !

!String class methodsFor: 'instance creation' stamp: ''!
value: anInteger

	^ self with: (Character value: anInteger)! !

!String class methodsFor: 'primitives' stamp: ''!
findFirstInString: aString inCharacterSet: aCharacterSet startingAt: start 
	"Trivial, non-primitive version"
	
	start
		to: aString size
		do: [:i | (aCharacterSet
					includes: (aString at: i))
				ifTrue: [^ i]].
	^ 0! !

!String class methodsFor: 'private - accessing' stamp: ''!
newAsciiOrder
	^ (0 to: 255) as: ByteArray! !

!String class methodsFor: 'instance creation' stamp: ''!
lf
	"Answer a string containing a single carriage return character."

	^ self with: Character lf! !

!String class methodsFor: 'primitives' stamp: ''!
translate: aString from: start  to: stop  table: table
	"Trivial, non-primitive version"
	| char |
	start to: stop do: [:i |
		(char := aString basicAt: i) < 256 ifTrue: [
			aString at: i put: (table at: char+1)].
	]! !

!String class methodsFor: 'formatting' stamp: ''!
expandMacro: macroType argument: argument withExpansions: expansions 
	macroType = $s ifTrue: [^expansions at: argument].
	macroType = $p ifTrue: [^(expansions at: argument) printString].
	macroType = $n ifTrue: [^String cr].
	macroType = $t ifTrue: [^String tab].
	self error: 'unknown expansion type'! !

!String class methodsFor: 'private - accessing' stamp: ''!
newUppercasingTable
	"a table for translating to upper case"
	^ String withAll: (Character allByteCharacters collect: [:c | c asUppercase])! !

!String class methodsFor: 'instance creation' stamp: ''!
fromByteArray: aByteArray

	^ aByteArray asString! !

!String class methodsFor: 'instance creation' stamp: ''!
empty
	"A canonicalized empty String instance."
	^ ''! !

!String class methodsFor: 'primitives' stamp: ''!
findFirstInString: aString inSet: inclusionMap startingAt: start
	"Trivial, non-primitive version"
	
	| i stringSize ascii more |
	inclusionMap size ~= 256 ifTrue: [^ 0].
	stringSize := aString size.
	more := true.
	i := start - 1.
	[more and: [(i := i + 1) <= stringSize]] whileTrue: [
		ascii := (aString basicAt: i).
		more := ascii < 256 ifTrue: [(inclusionMap at: ascii + 1) = 0] ifFalse: [true].
	].

	i > stringSize ifTrue: [^ 0].
	^ i! !

!String class methodsFor: 'primitives' stamp: ''!
stringHash: aString initialHash: speciesHash
	| stringSize hash low |
	stringSize := aString size.
	hash := speciesHash bitAnd: 16rFFFFFFF.
	1 to: stringSize do: [:pos |
		hash := hash + (aString basicAt: pos).
		"Begin hashMultiply"
		low := hash bitAnd: 16383.
		hash := (16r260D * low + ((16r260D * (hash // 16384) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF.
	].
	^ hash! !

!String class methodsFor: 'instance creation' stamp: ''!
tab
	"Answer a string containing a single tab character."

	^ self with: Character tab! !

!String class methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
systemIconName

	^ #stringIcon! !

!String class methodsFor: 'primitives' stamp: ''!
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 |
	order
		ifNil: [ len1 := string1 size.
			len2 := string2 size.
			1 to: (len1 min: len2) do: [ :i | 
				c1 := string1 basicAt: i.
				c2 := string2 basicAt: i.
				c1 = c2
					ifFalse: [ ^ c1 < c2
							ifTrue: [ 1 ]
							ifFalse: [ 3 ] ] ].
			len1 = len2 ifTrue: [ ^ 2 ].
			^ len1 < len2
				ifTrue: [ 1 ]
				ifFalse: [ 3 ] ].
	len1 := string1 size.
	len2 := string2 size.
	1 to: (len1 min: len2) do: [ :i | 
		c1 := string1 basicAt: i.
		c2 := string2 basicAt: i.
		c1 < 256 ifTrue: [ c1 := order at: c1 + 1 ].
		c2 < 256 ifTrue: [ c2 := order at: c2 + 1 ].
		c1 = c2
			ifFalse: [ ^ c1 < c2
					ifTrue: [ 1 ]
					ifFalse: [ 3 ] ] ].
	len1 = len2 ifTrue: [ ^ 2 ].
	^ len1 < len2
		ifTrue: [ 1 ]
		ifFalse: [ 3 ]! !

!String class methodsFor: '*System-Settings-Browser' stamp: ''!
settingInputWidgetForNode: aSettingNode
	^ aSettingNode inputWidgetForString! !

!String class methodsFor: 'instance creation' stamp: ''!
readFrom: inStream
	"Answer an instance of me that is determined by reading the stream, 
	inStream. Embedded double quotes become the quote Character."

	| char done |
	^ self streamContents: [ :outStream | 
		"go to first quote"
		inStream skipTo: $'.
		done := false.
		[ done or: [ inStream atEnd ] ]
			whileFalse: [ 
				char := inStream next.
				char = $'
					ifTrue: [ 
						char := inStream next.
						char = $'
							ifTrue: [ outStream nextPut: char ]
							ifFalse: [ done := true ] ]
					ifFalse: [ outStream nextPut: char ] ] ]! !

!String class methodsFor: 'instance creation' stamp: ''!
loremIpsum
	"Return a constant string with one paragraph of text, the famous Lorem ipsum filler text.
	The result is pure ASCII (Latin words) and contains no newlines."
	
	^ 'Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.'! !

!String class methodsFor: 'instance creation' stamp: ''!
loremIpsum: size
	"Return a mostly random multi-paragraph filler string of the specified size.
	The result is pure ASCII, uses CR for newlines and ends with a dot and newline."
	
	"self loremIpsum: 2048"
	
	| words out |
	words := (self loremIpsum findTokens: ' ,.') collect: [:each | each asLowercase].
	(out := LimitedWriteStream on: (self new: size))
		limit: size - 2;
		limitBlock: [
			^ out originalContents 
				at: size - 1 put: $.; 
				at: size put: Character cr; 
				yourself ].
	[ 
		out << self loremIpsum; cr; cr.
		5 atRandom timesRepeat: [
			15 atRandom timesRepeat: [
	 			out << words atRandom capitalized.
				20 atRandom timesRepeat: [ out space; << words atRandom ].
				out nextPut: $.; space ].
			out cr; cr ] ] repeat! !

!String class methodsFor: 'instance creation' stamp: ''!
fromString: aString 
	"Answer an instance of me that is a copy of the argument, aString."
	
	^ aString copyFrom: 1 to: aString size! !

!String class methodsFor: 'class initialization' stamp: ''!
initialize   
	
	self initializeTypeTable.
	
	AsciiOrder := self newAsciiOrder.
	CaseInsensitiveOrder := self newCaseInsensitiveOrder.
	CaseSensitiveOrder := self newCaseSensitiveOrder.
	LowercasingTable := self newLowercasingTable.
	UppercasingTable := self newUppercasingTable.
	Tokenish := self newTokenish.
	CSLineEnders := self newCSLineEnders.

 	"separators and non-separators"
	CSSeparators := CharacterSet separators.
	CSNonSeparators := CSSeparators complement! !

!String class methodsFor: 'accessing' stamp: ''!
typeTable
	TypeTable ifNil: [self initializeTypeTable].
	^ TypeTable! !

!String class methodsFor: '*UnifiedFFI' stamp: ''!
asExternalTypeOn: generator 
	^ generator resolveType: #FFIExternalString! !

!String class methodsFor: '*Debugger-Model' stamp: ''!
canonicalArgumentName

	^ 'aString'! !

!String class methodsFor: 'primitives' stamp: ''!
indexOfAscii: anInteger inString: aString startingAt: start	
	start to: aString size do: [ :index |
		(aString basicAt: index) = anInteger ifTrue: [ ^index ] ].
	^0! !

!String class methodsFor: 'instance creation' stamp: ''!
new: sizeRequested
	"Return a new instance with the number of indexable variables specified by the argument."

	^ self == String
		ifTrue: [ ByteString new: sizeRequested ]
		ifFalse: [ self basicNew: sizeRequested ]! !

!String class methodsFor: 'private - accessing' stamp: ''!
newTokenish
	"a table for testing tokenish (for fast numArgs)"
	^ String withAll: (Character allByteCharacters 
		collect: [:c | c tokenish ifTrue: [ c ] ifFalse: [ $~ ]])! !

!String class methodsFor: 'instance creation' stamp: ''!
space
	"Answer a string containing a single space character."

	^ self with: Character space! !

!String class methodsFor: 'private - accessing' stamp: ''!
newCSLineEnders
	"CR and LF--characters that terminate a line"
	^ CharacterSet crlf! !

!String class methodsFor: 'private - accessing' stamp: ''!
newCaseInsensitiveOrder
	"map char and char asLower (Lowercase Latin1 stays in the Latin1 range, uppercase not.)"
	| newCollection |
	newCollection := AsciiOrder copy.
    (0 to: 255) do:[ :v |
            | char lower |
            char := v asCharacter.
            lower := char asLowercase.
            newCollection at: lower asciiValue + 1 put: (newCollection at: char asciiValue + 1) ].
	^ newCollection! !

!String class methodsFor: 'private - accessing' stamp: ''!
newCaseSensitiveOrder
	"Case-sensitive compare sorts space, digits, letters, all the rest..."
	
	| newTab order |
	newTab := ByteArray new: 256 withAll: 255.
	order := -1.
	' 0123456789' do:  "0..10"
		[:c | newTab at: c asciiValue + 1 put: (order := order+1)].
	($a to: $z) do:     "11-64"
		[:c | newTab  at: c asUppercase asciiValue + 1 put: (order := order+1).
		newTab  at: c asciiValue + 1 put: (order := order+1)].
	1 to: newTab  size do:
		[:i | (newTab  at: i) = 255 ifTrue:
			[newTab  at: i put: (order := order+1)]].
	order = 255 ifFalse: [self error: 'order problem'].
	^ newTab! !

!String class methodsFor: 'private - initialization' stamp: ''!
initializeTypeTable

	| newTable |
	newTable := Array new: 256 withAll: #xBinary. "default"
	newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space"
	newTable atAll: ($0 asciiValue to: $9 asciiValue) put: #xDigit.

	1 to: 255
		do: [:index |
			(Character value: index) isLetter
				ifTrue: [newTable at: index put: #xLetter]].

	newTable at: 30 put: #doIt.
	newTable at: $" asciiValue put: #xDoubleQuote.
	newTable at: $# asciiValue put: #xLitQuote.
	newTable at: $$ asciiValue put: #xDollar.
	newTable at: $' asciiValue put: #xSingleQuote.
	newTable at: $: asciiValue put: #xColon.
	newTable at: $( asciiValue put: #leftParenthesis.
	newTable at: $) asciiValue put: #rightParenthesis.
	newTable at: $. asciiValue put: #period.
	newTable at: $; asciiValue put: #semicolon.
	newTable at: $[ asciiValue put: #leftBracket.
	newTable at: $] asciiValue put: #rightBracket.
	newTable at: ${ asciiValue put: #leftBrace.
	newTable at: $} asciiValue put: #rightBrace.
	newTable at: $^ asciiValue put: #upArrow.
	newTable at: $_ asciiValue put: #xLetter. "by default, do not accept _ as assignement"
	newTable at: $| asciiValue put: #verticalBar.
	TypeTable := newTable! !

!String class methodsFor: 'private - accessing' stamp: ''!
newLowercasingTable
	"a table for translating to lower case"
	^ String withAll: (Character allByteCharacters collect: [:c | c asLowercase])! !

!String class methodsFor: 'instance creation' stamp: ''!
with: aCharacter
	| newCollection |
	newCollection := aCharacter asInteger < 256
		ifTrue:[ ByteString new: 1]
		ifFalse:[ WideString new: 1].
	newCollection at: 1 put: aCharacter.
	^newCollection! !

!String class methodsFor: 'instance creation' stamp: ''!
crlf
	"Answer a string containing a carriage return and a linefeed."

	^ self with: Character cr with: Character lf! !

!String class methodsFor: 'instance creation' stamp: ''!
crlfcrlf
	^self crlf , self crlf.! !

!String class methodsFor: 'instance creation' stamp: ''!
cr
	"Answer a string containing a single carriage return character."

	^ self with: Character cr! !

!StringInitializationTest commentStamp: ''!
SUnit tests for String initialization!
!StringInitializationTest methodsFor: 'tests' stamp: ''!
testTokenish
	self
		assert: (String newTokenish collect: #codePoint as: Array)
		equals:  #(126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 48 49 50 51 52 53 54 55 56 57 58 126 126 126 126 126 126 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 126 126 126 126 95 126 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 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 126 170 126 126 126 126 126 126 126 126 126 126 181 126 126 126 126 186 126 126 126 126 126 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 126 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 126 248 249 250 251 252 253 254 255)! !

!StringInitializationTest methodsFor: 'tests' stamp: ''!
testLowercasingTable
	self
		assert: (String newLowercasingTable collect: #codePoint as: Array)
		equals:   #(0 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 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 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 215 248 249 250 251 252 253 254 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)! !

!StringInitializationTest methodsFor: 'tests' stamp: ''!
testAsciiOrder
	self
		assert: String newAsciiOrder
		equals: #[0 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]! !

!StringInitializationTest methodsFor: 'tests' stamp: ''!
testUppercasingTable
	self
		assert: (String newUppercasingTable collect: #codePoint as: Array)
		equals: #(0 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 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 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 924 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 7838 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 247 216 217 218 219 220 221 222 376)! !

!StringInitializationTest methodsFor: 'tests' stamp: ''!
testCaseInsensitiveOrder
	self
		assert: String newCaseInsensitiveOrder
		equals:  #[0 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 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 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 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 247 216 217 218 219 220 221 222 255]! !

!StringInitializationTest methodsFor: 'tests' stamp: ''!
testCSLineEnders
	self
		assert: String newCSLineEnders asArray
		equals: { Character lf . Character cr }! !

!StringLineEndingsTest methodsFor: 'tests' stamp: ''!
testOriginStringCanBeProducedFromTargetStringAndOriginalLineEnding
	
	" This test is for testing that we can tranform a string with certain line ending to a another line ending, and then transform it back to the original line ending. "
	
	| testingSubjectWithTargetLineEndingTransformedWithOriginalLineEnding |
	testingSubjectWithTargetLineEndingTransformedWithOriginalLineEnding := testingSubjectWithTargetLineEnding withLineEndings: originLineEnding .
	self assert: testingSubjectWithTargetLineEndingTransformedWithOriginalLineEnding equals: testingSubjectWithOriginLineEnding! !

!StringLineEndingsTest methodsFor: 'tests' stamp: ''!
testLineEndinglessStringShouldBeEquals
	| originWithoutLineEnding targetWithoutLineEnding |
	originWithoutLineEnding := testingSubjectWithOriginLineEnding
		copyReplaceAll: originLineEnding with: ''.
	targetWithoutLineEnding := testingSubjectWithTargetLineEnding
		copyReplaceAll: targetLineEnding with: ''.
	self assert: originWithoutLineEnding equals: targetWithoutLineEnding! !

!StringLineEndingsTest methodsFor: 'accessing' stamp: ''!
targetLineEnding: aString 
	targetLineEnding := aString! !

!StringLineEndingsTest methodsFor: 'accessing' stamp: ''!
originLineEnding: aString 
	originLineEnding := aString! !

!StringLineEndingsTest methodsFor: 'running' stamp: ''!
newTestingSubject
	^ templateString format: {originLineEnding}! !

!StringLineEndingsTest methodsFor: 'running' stamp: ''!
templateString: aString
	templateString := aString! !

!StringLineEndingsTest methodsFor: 'tests' stamp: ''!
testTargetLineEndingStringWithoutOriginLineEnding
	self
		assert:
			((targetLineEnding includesSubstring: originLineEnding) 
				xor: [ (testingSubjectWithTargetLineEnding
						includesSubstring: originLineEnding) not ])! !

!StringLineEndingsTest methodsFor: 'running' stamp: ''!
setUp
	
	super setUp.
	testingSubjectWithOriginLineEnding := self newTestingSubject. 
	testingSubjectWithTargetLineEnding := testingSubjectWithOriginLineEnding withLineEndings: targetLineEnding.! !

!StringLineEndingsTest class methodsFor: 'building suites' stamp: ''!
testParameters
	^ ParametrizedTestMatrix new
		forSelector: #targetLineEnding
			addOptions:
			{String cr.
			String lf.
			String crlf};
		forSelector: #originLineEnding
			addOptions:
			{String cr.
			String lf.
			String crlf};
		forSelector: #templateString
			addOptions:
			{'I am a String{1}' . '{1}I am a String' . 'I am a{1}String'.
			'{1}I am{1}a String{1}'};
		yourself! !

!StringMorph commentStamp: ''!
StringMorph is a "lightweight" Morph to display a String. It supports only a single font, color, and emphasis combination. For multiple text styles, use TextMorph.

Structure:
instance var    	Type              Description 
font 			StrikeFont 		(normally nil; then the accessor #font gives back TextStyle 
				or nil			defaultFont) 
emphasis 		SmallInteger	bitmask determining character attributes (underline, bold, 								italics, narrow, struckout) 
contents 		String 			The text that will be displayed. 
hasFocus 		Boolean 		Do I have the keyboard focus or not? 

A StringMorph may also be used like a SimpleButtonMorph to do an action when clicked. Use the menu 'extras' / 'add mouseUpAction'.

The following propery will be defined:
aStringMorph valueOfProperty: #mouseUpCodeToRun!
!StringMorph methodsFor: 'editing' stamp: ''!
lostFocusWithoutAccepting
	"The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus -- typically by clicking on some editable text somewhere else -- without having accepted the current edits."

	self acceptContents! !

!StringMorph methodsFor: 'accessing' stamp: ''!
fontToUse
	| fontToUse |
	fontToUse := font
		ifNil: [ TextStyle defaultFont ]
		ifNotNil: [ font ].
	^ (emphasis isNil or: [ emphasis = 0 ])
		ifTrue: [ fontToUse ]
		ifFalse: [ fontToUse emphasized: emphasis ]! !

!StringMorph methodsFor: 'accessing' stamp: ''!
paneColor
	"Answer the window's pane color or our owner's color otherwise."

	^self paneColorOrNil ifNil: [self owner ifNil: [Color transparent] ifNotNil: [self owner color]]! !

!StringMorph methodsFor: 'editing' stamp: ''!
acceptValue: aValue
	| val |
	self contents: (val := aValue asString).
	^ val! !

!StringMorph methodsFor: 'accessing' stamp: ''!
setWidth: width
	"Round up in case fractional."
	
	self extent: (width @ (font ifNil: [TextStyle defaultFont]) height) ceiling! !

!StringMorph methodsFor: 'initialization' stamp: ''!
themeChanged
	self color: self defaultColor.
	super themeChanged! !

!StringMorph methodsFor: 'editing' stamp: ''!
wantsKeyboardFocusOnShiftClick
	^ owner topRendererOrSelf wantsKeyboardFocusFor: self! !

!StringMorph methodsFor: 'accessing' stamp: ''!
contents

	^ contents! !

!StringMorph methodsFor: '*Morphic-Base-Widgets' stamp: ''!
heightToDisplayInList: aList

	^ self contents heightToDisplayInList: aList! !

!StringMorph methodsFor: 'accessing' stamp: ''!
editorProvider: aValuable
	self setProperty: #editorProvider toValue: aValuable! !

!StringMorph methodsFor: 'menu' stamp: ''!
changeEmphasis

	| reply |
	reply := UIManager default 
				chooseFrom: (self emphasisChoices collect: [:t | t translated]) 
				values: self emphasisChoices.
	reply ifNotNil: [ self emphasis: (TextEmphasis perform: reply) emphasisCode ].! !

!StringMorph methodsFor: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!StringMorph methodsFor: 'editing' stamp: ''!
acceptContents
	"The message is sent when the user hits enter or Cmd-S. Accept the current contents and end editing. This default implementation does nothing."! !

!StringMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!StringMorph methodsFor: 'accessing' stamp: ''!
backgroundColor: aColor

	backgroundColor := aColor! !

!StringMorph methodsFor: 'drawing' stamp: ''!
drawDropShadowOn: aCanvas

	| bnd gap |
	bnd := self bounds translateBy: self shadowOffset.
	gap := self layoutInset.
	bnd := (bnd topLeft + gap) corner: (bnd bottomRight + gap).
	aCanvas drawString: contents in: bnd font: self fontToUse color: self shadowColor.! !

!StringMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!StringMorph methodsFor: 'drawing' stamp: ''!
imageForm: depth forRectangle: rect
	| canvas |
	canvas := Display defaultCanvasClass extent: rect extent depth: depth.
	
	backgroundColor isTransparent ifTrue: [ 
		canvas form fillColor: self theme backgroundColor.
	].
	canvas translateBy: rect topLeft negated
		during:[:tempCanvas| tempCanvas fullDrawMorph: self].
	^ canvas form offset: rect topLeft! !

!StringMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"

	super initialize.
	emphasis := 0.
	hasFocus := false.
	backgroundColor := Color transparent! !

!StringMorph methodsFor: '*FreeType-Morphic' stamp: ''!
changeFont
	| newFont chooser |
	chooser := FontChooser 
		windowTitle: 'Choose a Font' 
		for: self 
		setSelector: #font: 
		getSelector: self fontToUse.
	chooser openModal.
	newFont := chooser result.
	newFont ifNotNil: [self font: newFont].! !

!StringMorph methodsFor: 'printing' stamp: ''!
font: aFont 
	"Set the font my text will use. The emphasis remains unchanged."

	font := aFont.
	^ self font: font emphasis: emphasis! !

!StringMorph methodsFor: 'initialization' stamp: ''!
initWithContents: aString font: aFont emphasis: emphasisCode 
	super initialize.
	
	font := aFont.
	emphasis := emphasisCode.
	hasFocus := false.
	self contents: aString! !

!StringMorph methodsFor: 'menu' stamp: ''!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'change font' selector: #changeFont.
	aCustomMenu add: 'change emphasis' selector: #changeEmphasis.! !

!StringMorph methodsFor: 'accessing' stamp: ''!
fontName: fontName size: fontSize

	^ self font: (StrikeFont familyName: fontName size: fontSize) 
			emphasis: 0! !

!StringMorph methodsFor: 'accessing' stamp: ''!
measureContents
	"Round up in case fractional."
	
	| f |
	f := self fontToUse.
	^((((f widthOfString: contents) max: self minimumWidth)  @ f height) + (self layoutInset * 2)) ceiling! !

!StringMorph methodsFor: 'accessing' stamp: ''!
minimumWidth
	"Answer the minimum width that the receiver can have.  A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!!  Obeyed by fitContents."

	^ 3! !

!StringMorph methodsFor: 'private' stamp: ''!
privateSetContents: newContents 
	| scanner |
	contents := newContents isText
				ifTrue: [scanner := StringMorphAttributeScanner new initializeFromStringMorph: self.
					(newContents attributesAt: 1 forStyle: self font textStyle)
						do: [:attr | attr emphasizeScanner: scanner].
					emphasis := scanner emphasis.
					font := scanner font emphasis: emphasis.
					color := scanner textColor.
					newContents string]
				ifFalse: [contents = newContents
						ifTrue: [^ self].
					"no substantive change"
					newContents].! !

!StringMorph methodsFor: 'accessing' stamp: ''!
strikethroughColor

	^ self stringColor! !

!StringMorph methodsFor: 'accessing' stamp: ''!
stringColor

	^ self color! !

!StringMorph methodsFor: 'accessing' stamp: ''!
fitContents

	| newBounds boundsChanged |
	newBounds := self measureContents.
	boundsChanged := bounds extent ~= newBounds.
	self extent: newBounds.		"default short-circuits if bounds not changed"
	boundsChanged ifFalse: [self changed]! !

!StringMorph methodsFor: 'editing' stamp: ''!
doneWithEdits

	hasFocus := false! !

!StringMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!StringMorph methodsFor: 'drawing' stamp: ''!
areasRemainingToFill: aRectangle

	^ Array with: aRectangle! !

!StringMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ self theme textColor! !

!StringMorph methodsFor: 'editing' stamp: ''!
cancelEdits

	self doneWithEdits! !

!StringMorph methodsFor: 'accessing' stamp: ''!
editorProvider
	^ self valueOfProperty: #editorProvider ifAbsent: []! !

!StringMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	"If the shift key is pressed then yes.
	As normal if StringMorph class>> editableStringMorph  returns false."
	
	^ (self isEditable: evt)
		ifTrue: [true]
		ifFalse: [super handlesMouseDown: evt]! !

!StringMorph methodsFor: 'event handling' stamp: ''!
hasFocus
	^ hasFocus! !

!StringMorph methodsFor: '*Morphic-Base-MorphTreeWidget' stamp: ''!
rowMorphForNode: aNode inColumn: aColumn
	| hasIcon |
	hasIcon := (aColumn container iconBlock value: aNode) notNil.
	(aColumn isFirstColumn and: [hasIcon]) 
		ifTrue: [^ super rowMorphForNode: aNode inColumn: aColumn].
	self layoutInset: aColumn container columnInset @ aColumn container rowInset.
	self fitContents.
	^ self! !

!StringMorph methodsFor: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!StringMorph methodsFor: 'accessing' stamp: ''!
userString
	"Do I have a text string to be searched on?"

	^ contents! !

!StringMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	
	aCanvas
	
		fillRectangle: self bounds 
		fillStyle: self backgroundColor;
		
		drawString: self contents 
		in: self stringBounds 
		font: self fontToUse 
		color: self stringColor
		underline: (emphasis bitAnd: 2r100) ~~ 0
		underlineColor: self underlineColor 
		strikethrough: (emphasis bitAnd: 2r10000) ~~ 0
		strikethroughColor: self strikethroughColor! !

!StringMorph methodsFor: 'accessing' stamp: ''!
backgroundColor
	
	^backgroundColor! !

!StringMorph methodsFor: 'event handling' stamp: ''!
wouldAcceptKeyboardFocus
	^ self isLocked not! !

!StringMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!StringMorph methodsFor: 'accessing' stamp: ''!
font
	"who came up with #fontToUse rather than font?!!"
	^self fontToUse! !

!StringMorph methodsFor: 'accessing' stamp: ''!
isEditable
	^ self editorProvider notNil! !

!StringMorph methodsFor: 'accessing' stamp: ''!
emphasis: aCodeOrTextEmphasis
	"Set my emphasis to aCodeOrTextEmphasis, which is either a TextEmphasis object,
	or a numeric code that is treated as a bitmask.   In the case of a TextEmphasis,
	sending the message value will return the code number.  
	
	The bits have the following significance (see also the class comment for TextEmphasis)
	
	bit 			attribute
	2r1	 (1) 		bold 
	2r10 (2)	 	italic 
	2r100 (4) 	underlined 
	2r1000	 (8) 	narrow 
	2r10000	 (16) 	strikethrough 
			
	examples: 
		2r0 -> plain.  
		2r1 -> bold. 
		2r11 -> bold + italic.  
		2r1101 -> bold + underlined + strikethrough.
	etc...
	"

	emphasis := aCodeOrTextEmphasis value.
	^ self font: font emphasis: emphasis! !

!StringMorph methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream print: contents.! !

!StringMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!StringMorph methodsFor: 'accessing' stamp: ''!
underlineColor

	^ self stringColor! !

!StringMorph methodsFor: '*Calypso-Browser' stamp: ''!
clyAddEmphasis: aTextEmphasis
	"For compatibility between Pharo 6 and Pharo 7 and to not produce overrides"
	self emphasis: (emphasis bitOr: aTextEmphasis emphasisCode)! !

!StringMorph methodsFor: 'menu' stamp: ''!
emphasisChoices
	"Returns the emphasis selectors that are sent to a TextEmphasis."
	
	^ #(normal bold italic narrow underlined struckOut)! !

!StringMorph methodsFor: 'accessing' stamp: ''!
stringBounds

	| bnd gap |
	
	bnd := self bounds.
	gap := self layoutInset.
	
	^ (bnd topLeft + gap) corner: (bnd bottomRight + gap)! !

!StringMorph methodsFor: 'accessing' stamp: ''!
contentsClipped: aString
	"Change my text, but do not change my size as a result"
	contents = aString ifTrue: [^ self].  "No substantive change"
	contents := aString.
	self changed! !

!StringMorph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean

	aBoolean 
		ifTrue: [ self color: self defaultColor ]
		ifFalse: [ self color: self theme disabledTextColor ]! !

!StringMorph methodsFor: 'accessing' stamp: ''!
contents: newContents 
	self privateSetContents: newContents.
	self fitContents! !

!StringMorph methodsFor: 'layout' stamp: ''!
fullBounds
	self contents ifNil: [ self contents: 'String Morph' ].
	^super fullBounds! !

!StringMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: canvas
	| bnd |
"	bnd := self bounds.
	gap := self layoutInset.
"	bnd := self bounds topLeft + self layoutInset.
	 
	font := self fontToUse.
	
	canvas pathTransform restoreAfter: [
		canvas pathTransform translateBy: bnd.
		canvas pathTransform translateX: 0 Y: font getPreciseAscent.
		
		canvas 
			setPaint: color;
			setFont: self fontToUse;
			drawString: contents.
	]! !

!StringMorph methodsFor: 'accessing' stamp: ''!
font: aFont emphasis: emphasisCode
	font := aFont.
	emphasis := emphasisCode.
	self fitContents.
"
in inspector say,
	 self font: (TextStyle default fontAt: 2) emphasis: 1
"! !

!StringMorph methodsFor: 'halos and balloon help' stamp: ''!
boundsForBalloon
	"Some morphs have bounds that are way too big.  This is a contorted way of making things work okay in PluggableListMorphs, whose list elements historically have huge widths"

	| ownerOwner |
	^ ((owner notNil and: [(ownerOwner := owner owner) notNil]) and:
			[ownerOwner isKindOf: PluggableListMorph])
		ifTrue:
			[self boundsInWorld intersect: ownerOwner boundsInWorld ifNone: [self boundsInWorld] ]
		ifFalse:
			[super boundsForBalloon]! !

!StringMorph methodsFor: 'accessing' stamp: ''!
interimContents: aString
	"The receiver is under edit and aString represents the string the user sees as she edits, which typically will not have been accepted and indeed may be abandoned"

	self contents: aString! !

!StringMorph methodsFor: 'testing' stamp: ''!
isEditable: evt
	"If the shift key is pressed then yes.
	As normal if StringMorph class>> editableStringMorph  returns false."
	
	^(self isEditable and: [evt shiftPressed])! !

!StringMorph methodsFor: 'accessing' stamp: ''!
isTranslucentButNotTransparent
	"Answer true if this any of this morph is translucent but not transparent."
	^ true! !

!StringMorph methodsFor: 'accessing' stamp: ''!
contrastingBackgroundColor
	"sets the backgroundColor to either black or white, which ever makes the string simplest to read"
	backgroundColor := self color contrastingBlackAndWhiteColor! !

!StringMorph methodsFor: 'private - editing' stamp: ''!
launchEditor: evt
	" Launch an editor to edit my contents "
	self editorProvider ifNil: [ ^self ].
	self editorProvider openEditorForStringMorph: self! !

!StringMorph methodsFor: 'accessing' stamp: ''!
valueFromContents
	"Return a new value from the current contents string."
	^ contents! !

!StringMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	"If the shift key is pressed, make this string the keyboard input focus.
	Process as normal if StringMorph class>> editableStringMorph  returns false."

	(self isEditable: evt)
		ifTrue: [self launchEditor: evt]
		ifFalse: [super mouseDown: evt].! !

!StringMorph methodsFor: '*Morphic-Base-Widgets' stamp: ''!
widthToDisplayInList: aList

	^ self contents widthToDisplayInList: aList! !

!StringMorph methodsFor: 'accessing' stamp: ''!
minHeight
	"Answer the minimum height of the receiver."
	
	^self fontToUse height max: super minHeight! !

!StringMorph methodsFor: 'accessing' stamp: ''!
addEmphasis: aCodeOrTextEmphasis
	self emphasis: (emphasis bitOr: aCodeOrTextEmphasis value)! !

!StringMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!StringMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!StringMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!StringMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!StringMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!StringMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!StringMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!StringMorph class methodsFor: 'examples' stamp: ''!
exampleFullEmphaisedString
	<sampleInstance>
	| font |
	font := LogicalFont familyName: StandardFonts defaultFont familyName pointSize: 42. 
	^ (self contents: 'This is a StringMorph with emphasis 2r11111' font: font emphasis: 2r11111) 
			position: 100@100;
			backgroundColor: Color orange;
			openInWorld! !

!StringMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!StringMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!StringMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!StringMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!StringMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!StringMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!StringMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!StringMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!StringMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!StringMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!StringMorph class methodsFor: 'instance creation' stamp: ''!
contents: aString font: aFont
	^ self contents: aString font: aFont emphasis: 0! !

!StringMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!StringMorph class methodsFor: 'examples' stamp: ''!
exampleBoldAndItalic
	<sampleInstance>
	
	| font |
	font := LogicalFont familyName: StandardFonts defaultFont familyName pointSize: 42. 
	^ (self contents: 'This is a StringMorph with emphasis bold and italic' font: font emphasis: TextEmphasis bold)
			addEmphasis: TextEmphasis italic;
			position: 100@100;
			backgroundColor: Color orange;
			openInWorld! !

!StringMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!StringMorph class methodsFor: 'setting' stamp: ''!
editableStringMorph
	^ EditableStringMorph ifNil: [EditableStringMorph := false]! !

!StringMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!StringMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!StringMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!StringMorph class methodsFor: 'instance creation' stamp: ''!
contents: aString
	" 'StringMorph contents: str' is faster than 'StringMorph new contents: str' "
	^ self contents: aString font: nil! !

!StringMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!StringMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!StringMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!StringMorph class methodsFor: 'instance creation' stamp: ''!
contents: aString font: aFont emphasis: aCodeOrTextEmphasis
	^ self new initWithContents: aString font: aFont emphasis: aCodeOrTextEmphasis value! !

!StringMorph class methodsFor: 'examples' stamp: ''!
exampleManyStringMorphs
	"Return a morph with lots of strings for testing display speed."
	<sampleInstance>
	
	| c |
	c := AlignmentMorph newColumn.
	self class environment organization categories do:
		[:cat | c addMorph: (StringMorph new contents: cat)].
	^ c position: 100@50;
			openInWorld! !

!StringMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!StringMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!StringMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!StringMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!StringMorph class methodsFor: 'setting' stamp: ''!
editableStringMorph: aBoolean
	EditableStringMorph := aBoolean! !

!StringMorphAttributeScanner commentStamp: ''!
A StringMorphAttributeScanner provides the interface of a CharacterScanner so that text attributes may be collected from a Text and used elsewhere, like in setting the attributes of a StringMorph.
!
!StringMorphAttributeScanner methodsFor: 'scanning' stamp: ''!
setAlignment: aSymbol
	"Set the value of alignment"

	alignment := aSymbol! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: ''!
actualFont
	"Answer the value of actualFont"

	^ actualFont ifNil: [ TextStyle defaultFont ]! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: ''!
addKern: kernDelta
	"Set the current kern amount."

	kern := kern + kernDelta! !

!StringMorphAttributeScanner methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	emphasis := 0.
	indent := 0.
	kern := 0.
	fontNumber := 1.
	actualFont := TextStyle defaultFont! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: ''!
textColor: anObject
	"Set the value of textColor"

	textColor := anObject! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: ''!
indent
	"Answer the value of indent"

	^ indent! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: ''!
textStyle

	^ self actualFont textStyle ifNil: [ TextStyle default ]! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: ''!
font
	"Answer the value of font"

	^(self textStyle fontAt: self fontNumber) copy! !

!StringMorphAttributeScanner methodsFor: 'string morph' stamp: ''!
initializeFromStringMorph: aStringMorph

	fontNumber := 1.
	self setActualFont: (aStringMorph font ifNil: [ TextStyle defaultFont ]).
	
	emphasis := actualFont emphasis.
	textColor := aStringMorph color.! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: ''!
emphasis
	"Answer the value of emphasis"

	^ emphasis! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: ''!
indentationLevel: anInteger
	"Set the value of indent"

	indent := anInteger! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: ''!
textColor
	"Answer the value of textColor"

	^ textColor! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: ''!
kern
	"Answer the value of kern"

	^ kern! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: ''!
setActualFont: aFont
	"Set the value of actualFont, from a TextFontReference"

	actualFont := aFont.
	aFont textStyle ifNotNil: [ :ts | fontNumber := ts fontIndexOf: aFont ]! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: ''!
alignment
	"Answer the value of alignment"

	^ alignment! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: ''!
fontNumber
	"Answer the value of font"

	^ fontNumber! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: ''!
addEmphasis: anInteger
	"Set the value of emphasis"

	emphasis := emphasis bitOr: anInteger! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: ''!
setFont: fontNum
	"Set the value of font"

	fontNumber := fontNum! !

!StringSignal commentStamp: ''!
This is a simple signal that holds a message.

###Usage:
```
	(StringSignal emit: 'This is a message') message
```	

	
!
!StringSignal methodsFor: 'accessing' stamp: ''!
message: anObject

	message := anObject! !

!StringSignal methodsFor: 'printing' stamp: ''!
printOneLineContentsOn: stream

	stream nextPutAll: self message! !

!StringSignal methodsFor: 'accessing' stamp: ''!
message

	^ message! !

!StringSignal class methodsFor: 'instance creation' stamp: ''!
emit: aString
	^ self new 
		message: aString;
		emit! !

!StringTest commentStamp: ''!
This is the unit test for the class String. 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!
!StringTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne).! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testWithFirstCharacterDownshifted
	| uc lc empty |
	uc := 'MElViN'.
	lc := 'mElViN'.
	empty := ' '.
	self assert: uc uncapitalized equals: lc.
	self assert: lc uncapitalized equals: lc.
	"the string gets copied"
	self deny: lc uncapitalized identicalTo: lc.
	self deny: empty uncapitalized identicalTo: empty! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy24

	| tokens |
	string := 'this, is, a"," test'.
	tokens := string findTokens: $, escapedBy: $".
	self assert: tokens size equals: 3.
	self assert: tokens third equals: ' a, test'! !

!StringTest methodsFor: 'requirements' stamp: ''!
elementInForElementAccessing
	"Return an element included in 'moreThan4Elements'"
	
	^ self moreThan4Elements anyOne! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSubcollectionAccessTest

	self moreThan3Elements.
	self assert: self moreThan3Elements size > 2! !

!StringTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirstNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!StringTest methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index between bounds of 'nonEmpty'"

	^ 2! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!StringTest methodsFor: 'tests - streaming' stamp: ''!
testWriteStreamDo
	emptyString
		writeStreamDo: [ :stream | 
			stream nextPutAll: string.
			self assert: stream contents equals: string ].
	self assert: (emptyString writeStreamDo: [ :stream | true ])! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testWithBlanksCondensed
	#( 
		'foo' 'foo'
		'foo bar' 'foo bar'
		'' ''
		' ' ''
		'foo  bar  !!' 'foo bar !!'
		' foo  bar  !! ' 'foo bar !!'
		'  foo  bar  !!  ' 'foo bar !!'
		'		tabs		tabs	!!		' 'tabs	tabs	!!'
		'space followed by tab 	!!' 'space followed by tab !!'
	) pairsDo: [ :input :output |
		self assert: input withBlanksCondensed equals: output ]! !

!StringTest methodsFor: 'tests - sorting' stamp: ''!
testSort
	| result tmp |
	result := self unsortedCollection sort.
	tmp := result at: 1.
	result do:
		[:each | self assert: each>=tmp. tmp:= each. ].! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDoEmpty
	| result |
	result := OrderedCollection new.
	self empty reverseDo: [ :each | result add: each ].

	self assertEmpty: result! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
testOFixtureReplacementSequencedTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.

	self elementInForReplacement.
	self assert: (self nonEmpty includes: self elementInForReplacement).

	self newElement.

	self firstIndex.
	self assert: (self firstIndex >= 1 & self firstIndex) <= self nonEmpty size.

	self secondIndex.
	self assert: (self secondIndex >= 1 & self secondIndex) <= self nonEmpty size.

	self assert: self firstIndex <= self secondIndex.

	self replacementCollection.

	self replacementCollectionSameSize.
	self assert: self secondIndex - self firstIndex + 1 equals: self replacementCollectionSameSize size! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLastNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
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! !

!StringTest methodsFor: 'tests' stamp: ''!
testNumArgs
	"This is about http://code.google.com/p/pharo/issues/detail?id=237"
	
	| binary |
	binary := '*+-/\~=<>&@%,|'.
	self assert: (binary allSatisfy: [:char1 |
			(String with: char1) numArgs = 1 and: [binary allSatisfy: [:char2 |
				(String with: char1 with: char2) numArgs = 1 and: [binary allSatisfy: [:char3 |
					(String with: char1 with: char2 with: char3) numArgs = 1]]]]])
		description: 'binary selectors have 1 argument'.
		
	self assert: 'x' numArgs = 0
		description: 'unary selectors have 0 arguments'.
	self assert: 'x0' numArgs = 0
		description: 'unary selectors have 0 arguments'.
	self assert: 'yourself' numArgs = 0
		description: 'unary selectors have 0 arguments'.
		
	self assert: 'x:' numArgs = 1
		description: 'keyword selectors have as many elements as colons characters'.
	self assert: 'x:y:' numArgs = 2
		description: 'keyword selectors have as many elements as colons characters'.
	self assert: 'at:put:' numArgs = 2
		description: 'keyword selectors have as many elements as colons characters'.
			
	self assert: 'x_y_z' numArgs = 0
		description: 'selectors can contain underscores'.
	self assert: '_x' numArgs = 0
		description: 'selectors can begin with an underscore'.
	self assert: '_:_:' numArgs = 2
		description: 'keyword selectors can contain underscores'.
		
	self assert: 'at:withoutTrailingColon' numArgs = -1
		description: 'keyword selectors should have a trailing colon character'.
		
	self assert: ':x' numArgs = -1
		description: 'keyword selectors cannot begin with a colon character'.
		
	self assert: 'x::y:' numArgs = -1
		description: 'keyword selectors cannot have two consecutive colon characters'.
		
	self assert: '0x' numArgs = -1
		description: 'selectors cannot begin with a digit'.
		
	self assert: 'x::0y:' numArgs = -1
		description: 'keyword selectors cannot have any key beginning with a digit'.! !

!StringTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', '.
	
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString withIndexDo: 
		[:el :i |  self assert: el equals: ((self nonEmpty at:i)asString)]! !

!StringTest methodsFor: 'tests' stamp: ''!
testCharactersExactlyMatching

	self assert: 5 equals: ('voiture' charactersExactlyMatching: 'voituze').
	self assert: 0 equals: ('voiture' charactersExactlyMatching: '').
	self assert: 1 equals: ('voiture' charactersExactlyMatching: 'v').
	self assert: 0 equals: ('voiture' charactersExactlyMatching: 'abcdef')! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!StringTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printElementsOn: aStream.
	allElementsAsString:=(result findBetweenSubstrings: ' ').
	allElementsAsString withIndexDo: 
		[:el :i | self assert: el equals: ((self nonEmpty at: i)asString) ]! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testAtRandom

	| result |
	result := self nonEmpty atRandom.
	self assert: (self nonEmpty includes: result)! !

!StringTest methodsFor: 'tests' stamp: ''!
testCaseInsensitiveLessOrEqual

	self assert: ('EEA' caseInsensitiveLessOrEqual: 'fgh').
	self deny: ('éèàôüößäóñíá' caseInsensitiveLessOrEqual: 'éèàôüöß').
	self assert: ('éèàôüößäóñíá' caseInsensitiveLessOrEqual: 'éèàôüößäóñíá').
	self deny: ('ÉÈÀÔÜÖ' caseInsensitiveLessOrEqual: 'èàôüö').
	self assert: ('eea' caseInsensitiveLessOrEqual: 'ÉÈÀ')! !

!StringTest methodsFor: 'tests' stamp: ''!
testIsAllDigits

	self assert: '' isAllDigits equals: false.
	self assert: '1.23' isAllDigits equals: false.
	self assert: '12 3' isAllDigits equals: false.
	self assert: '-123' isAllDigits equals: false.
	self assert: '0123456789' isAllDigits equals: true! !

!StringTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllIndexesPut
	
	self nonEmpty atAllPut: self aValue.
	self nonEmpty do:[ :each| self assert: each = self aValue].! !

!StringTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringOne
	
	"self assert: self oneItemCol asCommaString = '1'.
	self assert: self oneItemCol asCommaStringAnd = '1'."

	self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString).
	self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString)! !

!StringTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!StringTest methodsFor: 'tests' stamp: ''!
testTranslateToUppercase

	self assert: 'test this string' copy translateToUppercase equals: 'TEST THIS STRING'.
	self assert: ' Test THIS sTRing' copy translateToUppercase equals: ' TEST THIS STRING'.
	self assert: '' copy translateToUppercase equals: ''.
	self assert: 'ÔÜÖ' copy translateToUppercase equals: 'ÔÜÖ'.
	self assert: '123éàôüÖẞ' copy translateToUppercase equals: '123ÉÀÔÜÖẞ'! !

!StringTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!StringTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterEmpty
	| result |
	result := self empty copyAfter: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
collectionClass
	"Return the class to be used to create instances of the class tested"

	^ String! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy08

	| tokens |
	string := 'this, is, ##a, test'.
	tokens := string findTokens: ',' escapedBy: '#'.
	self assert: tokens size equals: 4.
	self assert: tokens third equals: ' a'.
	self assert: tokens fourth equals: ' test'! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testMiddle

	self assert: self moreThan4Elements middle equals: (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! !

!StringTest methodsFor: 'tests - copying same contents' stamp: ''!
testReverse

	| result |
	result := self nonEmpty reversed.	
	"verify content of 'result: '"
	1 to: result size do:
		[:i | self assert: ((result at: i) 
			= (self nonEmpty at: (self nonEmpty size - i + 1)))].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testBeforeIfAbsent

	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)! !

!StringTest methodsFor: '*FileSystem-Tests-Core' stamp: ''!
testAsFileLocatorOrReferenceReturnsALocatorWhenStringRefersToAKnownOrigin
	| pathString locator |
	pathString := (FileLocator home / 'foo') fullName.
	
	locator := pathString asFileLocatorOrReference.
		
	self
		assert: locator origin
		equals: #home.
	self
		assert: locator fullName
		equals: pathString.! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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) ]! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButFirstDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButFirstDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i +1))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element size-1)! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testTrimLeft
	self assert: '' trimLeft equals: ''.
	self assert: ' ' trimLeft equals: ''.
	self assert: '	' trimLeft equals: ''.
	self assert: 'foo' trimLeft equals: 'foo'.
	self assert: ' foo ' trimLeft equals: 'foo '.
	self assert: '  foo  ' trimLeft equals: 'foo  '.
	
	self assert: ('aabbaa' trimLeft: [ :each | each = $a ]) equals: 'bbaa'.
	self assert: ('bbaabb' trimLeft: [ :each | each = $a ]) equals: 'bbaabb'! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!StringTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWithManyOccurrence
	| result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff |
	" testing fixture here as this method may be not used for collection that can't contain equals element :"
	self collectionWith2TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection) = 2.	" test :"
	diff := self replacementCollection size - self oldSubCollection size.
	result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection.	"detecting indexes of olSubCollection"
	firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection.	" verifying that replacementCollection has been put in places of oldSubCollections "
	firstIndexesOfOccurrence
		do: [ :each | 
			(firstIndexesOfOccurrence indexOf: each) = 1
				ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ]
				ifFalse: [ each + diff to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ].	" verifying that the 'between' parts correspond to the initial collection : "
	1 to: firstIndexesOfOccurrence size do: [ :i | 
		i = 1
			ifTrue: [ 1 to: (firstIndexesOfOccurrence at: i) - 1 do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ]
			ifFalse: [ 
				resultBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self replacementCollection size.
				collectionBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self oldSubCollection size.
				1 to: (firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | 
					self
						assert:
							(result at: resultBetweenPartIndex + i - 1)
								= (self collectionWith2TimeSubcollection at: collectionBetweenPartIndex + i - 1) ] ]	" specific comportement for the begining of the collection :"	" between parts till the end : " ].	"final part :"
	1 to: self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size) do: [ :i | 
		self
			assert:
				(result at: firstIndexesOfOccurrence last + self replacementCollection size - 1 + i)
					= (self collectionWith2TimeSubcollection at: firstIndexesOfOccurrence last + self oldSubCollection size - 1 + i) ]! !

!StringTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOf

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection lastIndexOf: element) = 1.
	self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDoError
	
	self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error! !

!StringTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignForSequenceableCollections

	self deny: (self nonEmpty = self nonEmpty asSet). 
	self deny: (self nonEmpty reversed = self nonEmpty).
	self deny: (self nonEmpty = self nonEmpty reversed)! !

!StringTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForEmptyButNonIdenticalCollections
	
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy! !

!StringTest methodsFor: 'tests' stamp: ''!
testEndsWithCaseSensitive
	| w1 w2 |
	self deny: ('abc' endsWith: '' caseSensitive: true). "consistent to #beginsWith:"
	self deny: ('abc' endsWith: '' caseSensitive: false). "consistent to #beginsWith:"
	self deny: ('abc' endsWith: 'qabc' caseSensitive: false).
	self deny: ('abc' endsWith: 'qabc' caseSensitive: true).
	self deny: ('abc' endsWith: 'a' caseSensitive: true).
	self deny: ('abc' endsWith: 'a' caseSensitive: false).
	
	self assert: ('abc' endsWith: 'bc' caseSensitive: true).
	self assert: ('abc' endsWith: 'bc' caseSensitive: false).
	self assert: ('abc' endsWith: 'bC' caseSensitive: false).
	self assert: ('abc' endsWith: 'Bc' caseSensitive: false). 
	self deny: ('abc' endsWith: 'Bc' caseSensitive: true).
	self assert: ('abcd' asWideString endsWith: 'Bcd' caseSensitive: false). 

	w1 := WideString with: (Unicode value: 400) with: $a with: $b with: (Unicode value: 402).
	w2 := WideString with: (Unicode value: 402).
	self assert: (w1 endsWith: w2 caseSensitive: true).
	self deny: (w1 endsWith: w2 asUppercase caseSensitive: true).
	self assert: (w1 endsWith: w2 asUppercase caseSensitive: false).! !

!StringTest methodsFor: 'tests' stamp: ''!
testEndsWithDigit

	self deny: ('éèàôüößäóñíá' endsWithDigit).
	self assert: ('éèàôüößäóñíá9' endsWithDigit).
	self deny: ('99test' endsWithDigit).
	self assert: ('  999' endsWithDigit).! !

!StringTest methodsFor: 'tests - streaming' stamp: ''!
testReadStreamDo
	string readStreamDo: [ :stream | self assert: stream contents equals: string ]! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
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)]]! !

!StringTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithSequenceable

	| result index element |
	index := self indexInNonEmpty.
	element := self nonEmpty at: index.
	result := self nonEmpty copyWith: (element ).
	
	self assert: result size equals: (self nonEmpty size + 1).
	self assert: result last equals: element.
	
	1 to: (result size - 1) do:
		[ :i | self assert: (result at: i) equals: ( self nonEmpty at: i)]! !

!StringTest methodsFor: 'tests' stamp: ''!
testIsWideString

	self assert: '€₤' isWideString.
	self deny: 'test this string' isWideString. 
	self assert: ' test ₤' isWideString.
	self deny: '' isWideString. 
	self assert: 'éàôüÖẞ' isWideString.
	self deny: 'éàôüÖ' isWideString! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy23

	| tokens |
	string := 'this, is, a, test'.
	tokens := string findTokens: $, escapedBy: $".
	self assert: tokens size equals: 4! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDetectSequenced
	"Testing that detect keep the first element returning true for sequenceable collections"

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element  detect: [:each | each notNil ].
	self assert: result equals: element! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!StringTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection last.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: 99! !

!StringTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWithInsertion
	| result  indexOfSubcollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: ( indexOfSubcollection - 1 ) with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'' : '"
	
	1 to: (indexOfSubcollection -1) do: 
		[
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i)=(result at: i)
		].
	
	" middle part containing replacementCollection : "
	indexOfSubcollection  to: (indexOfSubcollection  + self replacementCollection size-1) do: 
		[
		:i |
		self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 ))
		].
	
	" end part :"
	(indexOfSubcollection  + self replacementCollection size) to: (result size) do:
		[:i|
		self assert: (result at: i)=(self collectionWith1TimeSubcollection  at: (i-self replacementCollection size))].
	
	" verify size: "	
	self assert: result size=(self collectionWith1TimeSubcollection  size + self replacementCollection size).! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan5Elements
" return a collection including at least 5 elements"
	
	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testAsCamelCase

	self assert: 'A man, a plan, a canal, panama' asCamelCase equals: 'AMan,APlan,ACanal,Panama'.
	self assert: 'Here 123should % be 6 the name6 of the method' asCamelCase equals: 'Here123should%Be6TheName6OfTheMethod'.! !

!StringTest methodsFor: 'tests' stamp: ''!
testLessThan

	self assert: ('@' < 'A').
	self assert: ('abcd' < 'à ô ü').
	self assert: ('xyz' < 'ß').
	self assert: ('ß t e s t' < 'à ô ü').
	self assert: ('' < 'a').
	self deny: ('à ô ü' < 'à ô ü').
	self deny: ('aaa' < 'AAA')! !

!StringTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!StringTest methodsFor: 'requirements' stamp: ''!
secondCollection
	"Return a collection that will be the second part of the concatenation"
	
	^ nonEmpty1element! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy21

	| tokens |
	string := 'this, is, "a, test"'.
	tokens := string findTokens: $, escapedBy: $".
	self assert: tokens size equals: 3! !

!StringTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests' stamp: ''!
testInitialIntegerOrNil

	self assert: '234Whoopie' initialIntegerOrNil equals: 234.
	self assert: 'wimpy' initialIntegerOrNil isNil.
	self assert: '234' initialIntegerOrNil equals: 234.
	self assert: '2N' initialIntegerOrNil equals: 2.
	self assert: '  89Ten ' initialIntegerOrNil isNil.
	self assert: '78 92' initialIntegerOrNil equals: 78.
	self assert: '123éàôüÖẞ' initialIntegerOrNil equals: 123! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testCollectFromTo
	
	| result |
	result:=self nonEmptyMoreThan1Element 
		collect: [ :each | each ]
		from: 1
		to: (self nonEmptyMoreThan1Element size - 1).
		
	1 to: result size
		do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ].
	self assert: result size = (self nonEmptyMoreThan1Element size - 1)! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
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 ]! !

!StringTest methodsFor: 'requirements' stamp: ''!
replacementCollectionSameSize
	"Return a collection of size (secondIndex - firstIndex + 1)"
	
	^nonEmpty1element! !

!StringTest methodsFor: 'requirements' stamp: ''!
anotherValue
	"Return a value (not equal to 'aValue') to put into nonEmpty"
	
	^ self nonEmpty anyOne! !

!StringTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	^ String! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfForMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFromToDo
	
	| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each].
	
	1 to: (self nonEmptyMoreThan1Element  size -1) do:
		[:i | self assert: (self nonEmptyMoreThan1Element at:i) = (result at:i) ].

	self assert: result size = (self nonEmptyMoreThan1Element size - 1).! !

!StringTest methodsFor: 'tests - internet' stamp: ''!
testWithUnixLineEndings

	| original newString |
	{
		'abc' -> 'abc'.
		'abc', String cr -> ('abc', String lf).
		'abc', String lf -> ('abc', String lf).
		'abc', String crlf -> ('abc', String lf).
		String cr, 'abc' -> (String lf, 'abc').
		String lf, 'abc' -> (String lf, 'abc').
		String crlf, 'abc' -> (String lf, 'abc').
		'abc', String cr, String cr, 'abc' -> ('abc', String lf, String lf, 'abc').
		'abc', String lf, String lf, 'abc' -> ('abc', String lf, String lf, 'abc').
		'abc', String crlf, String crlf, 'abc' -> ('abc', String lf, String lf, 'abc').
		String cr, 'abc', String cr, String crlf, 'abc', String lf -> (String lf, 'abc', String lf, String lf, 'abc', String lf).
		String lf, 'abc', String lf, String crlf, 'abc', String cr -> (String lf, 'abc', String lf, String lf, 'abc', String lf).
		(WideString with: 403 asCharacter with: Character cr) -> (WideString with: 403 asCharacter with: Character lf).
	} do: [ :each |
		self assert: each key withUnixLineEndings equals: each value ].
	
	original :='asa' , String cr , 'asa'.
	self assert: (original at: 4) equals: Character cr.
	newString := original withUnixLineEndings.
	self assert: (original at: 4) equals: Character cr.
	self assert: (newString at: 4) equals: Character lf.! !

!StringTest methodsFor: 'tests - lines' stamp: ''!
testLineCorrespondingToIndex
	| sampleCRString sampleLFString sampleCRLFString anIndex |
	sampleCRString := 'Fred', String cr, 'the', String cr, 'Bear'.
	sampleLFString := 'Fred', String lf, 'the', String lf, 'Bear'.
	sampleCRLFString := 'Fred', String crlf, 'the', String crlf, 'Bear'.
	
	anIndex := sampleCRString indexOf: $h.
	self assert: (sampleCRString lineCorrespondingToIndex: anIndex) equals: 'the'.
	anIndex := sampleLFString indexOf: $h.
	self assert: (sampleLFString lineCorrespondingToIndex: anIndex) equals: 'the'.
	anIndex := sampleCRLFString indexOf: $h.
	self assert: (sampleCRLFString lineCorrespondingToIndex: anIndex) equals: 'the'.
	
	anIndex := sampleCRString indexOf: $B.
	self assert: (sampleCRString lineCorrespondingToIndex: anIndex) equals: 'Bear'.
	anIndex := sampleLFString indexOf: $B.
	self assert: (sampleLFString lineCorrespondingToIndex: anIndex) equals: 'Bear'.
	anIndex := sampleCRLFString indexOf: $B.
	self assert: (sampleCRLFString lineCorrespondingToIndex: anIndex) equals: 'Bear'.
	
	anIndex := sampleCRString indexOf: $d.
	self assert: (sampleCRString lineCorrespondingToIndex: anIndex) equals: 'Fred'.
	anIndex := sampleLFString indexOf: $d.
	self assert: (sampleLFString lineCorrespondingToIndex: anIndex) equals: 'Fred'.
	anIndex := sampleCRLFString indexOf: $d.
	self assert: (sampleCRLFString lineCorrespondingToIndex: anIndex) equals: 'Fred'.! !

!StringTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0TSequencedStructuralEqualityTest

	self nonEmpty at: 1	"Ensures #nonEmpty is sequenceable"! !

!StringTest methodsFor: 'tests' stamp: ''!
testAsString 

	self assert: 123 asString equals: '123'.
	self assert: #(1 2 3) asString equals: '#(1 2 3)'.
	self assert: (OrderedCollection new) asString equals: 'an OrderedCollection()'.
	self assert: (1 < 3) asString equals: 'true'.
	self assert: 'é è à ô ü ö ß ä ó ñ í á' asString equals: 'é è à ô ü ö ß ä ó ñ í á'.
	self assert: '' asString equals: ''! !

!StringTest methodsFor: 'requirements' stamp: ''!
elementInForIncludesTest
	"Return an element included in nonEmpty"
	
	^ elementInNonEmpty! !

!StringTest methodsFor: 'tests' stamp: ''!
testNumericSuffix

	self assert: 'abc98' numericSuffix equals: 98.
	self assert: '98abc' numericSuffix equals: 0.
	self assert: '  123abc456' numericSuffix equals: 456.
	self assert: 'abc456 789' numericSuffix equals: 789.
	self assert: '012éà ôüÖ ẞ123' numericSuffix equals: 123! !

!StringTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfStartingAtDuplicate

	| 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 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 55 ]) equals: 1! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan1NoDuplicates
	" return a collection of size > 1 without equal elements"
	^ withoutEqualElements! !

!StringTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButFirstNElements

	| allButFirst collection |
	collection := self moreThan3Elements.
	allButFirst := collection allButFirst: 2.
	allButFirst withIndexDo: 
		 [:el :i | self assert: el equals: (collection at: i + 2) ].
	self assert: allButFirst size + 2 equals: collection size! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindStringStartingAt

	self assert: ('éèàôüößäóñíá' findString: 'ÉÈ' startingAt: 1) equals: 0.
	self assert: ('éèàôüößäóñíá' findString: 'éè' startingAt: 10) equals: 0.
	self assert: ('éèàôüößäóñíá' findString: 'ß' startingAt: 5) equals: 7.
	self assert: ('salkjsdlkgfee' findString: 'lke' startingAt: 1) equals: 0.
	self assert: ('salkjsdlkgfee' findString: 'ee'startingAt: 3) equals: 12.
	self assert: (' ' findString: '' startingAt: 1) equals: 0! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy26

	| tokens |
	string := 'this, is, "a, test'.
	tokens := string findTokens: $, escapedBy: $".
	self assert: tokens size equals: 3.
	self assert: tokens third equals: ' a, test'! !

!StringTest methodsFor: 'tests - lines' stamp: ''!
testLinesDo
	| sampleCRString sampleLFString sampleCRLFString lines |
	sampleCRString := 'Fred', String cr , 'the' , String cr , 'Bear'.
	sampleLFString := 'Fred', String lf , 'the' , String lf , 'Bear'.
	sampleCRLFString := 'Fred', String crlf , 'the' , String crlf , 'Bear'.
	
	lines := OrderedCollection new.
	sampleCRString linesDo: [:aLine |
		self deny: (aLine includes: Character cr).
		self deny: (aLine includes: Character lf).
		lines add: aLine].
	self assert: lines asArray equals: #('Fred' 'the' 'Bear').
	
	lines := OrderedCollection new.
	sampleLFString linesDo: [:aLine |
		self deny: (aLine includes: Character cr).
		self deny: (aLine includes: Character lf).
		lines add: aLine].
	self assert: lines asArray equals: #('Fred' 'the' 'Bear').

	lines := OrderedCollection new.
	sampleCRLFString linesDo: [:aLine |
		self deny: (aLine includes: Character cr).
		self deny: (aLine includes: Character lf).
		lines add: aLine].
	self assert: lines asArray equals: #('Fred' 'the' 'Bear').! !

!StringTest methodsFor: 'tests - instance creation' stamp: ''!
testSpace
		
	string := String new.
	self assert: string size equals: 0. 
	
	string := String space.
	self assert: string size equals: 1.
	self assert: string equals: ' '! !

!StringTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
	"Return a collection of size 1 including one element"
	
	^ nonEmpty1element! !

!StringTest methodsFor: 'requirements' stamp: ''!
indexArray
	"Return a Collection including indexes between bounds of 'nonEmpty'"

	^ indexInNonEmptyArray! !

!StringTest methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWith
	
	self assert: (self nonEmpty beginsWith: (self nonEmpty copyUpTo: self nonEmpty last)).
	self assert: (self nonEmpty beginsWith: self nonEmpty).
	self deny: (self nonEmpty beginsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesForMultiplinessTest
	| cpt |
	self collectionWithEqualElements.
	self collectionWithEqualElements.
	self elementTwiceInForOccurrences.
	self elementTwiceInForOccurrences.
	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! !

!StringTest methodsFor: 'tests' stamp: ''!
testAsLowercase 

	self assert: '1 2 3 É È À Ô Ü Ö ẞ t e s T' asLowercase equals: '1 2 3 é è à ô ü ö ß t e s t'.
	self assert: '!!@#$' asLowercase equals: '!!@#$'.
	self assert: '' asLowercase equals: ''! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest

	self nonEmpty! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsDo

	| index |
	index:=1.
	
	self nonEmptyMoreThan1Element  pairsDo: 
		[:each1 :each2 | 
		self assert: (self nonEmptyMoreThan1Element at:index) equals: each1.
		self assert: (self nonEmptyMoreThan1Element at:(index+1)) equals: each2.
		index := index + 2 ].
	
	self nonEmptyMoreThan1Element size odd
		ifTrue:[ self assert: index equals: self nonEmptyMoreThan1Element size ]
		ifFalse:[ self assert: index equals: (self nonEmptyMoreThan1Element size+1) ]! !

!StringTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopy

	| result |
	result := self nonEmpty shallowCopy.
	
	"Verfy content"
	self nonEmpty withIndexDo:
		[:el :i | self assert: (result at:i) equals: (self nonEmpty at:i)].
	
	"Verify size"
	self assert: result size equals: self nonEmpty size.! !

!StringTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLast

	| abf col |
	col := self moreThan3Elements.
	abf := col allButLast.
	self deny: abf last = col last.
	self assert: abf size + 1 equals: col size! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexDo

	|  indexes elements |
	indexes:= OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:value :i  |
			indexes  add: (i).
			elements add: value ].
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:el :i |
			self assert: (indexes at: i) equals: i.
			self assert: (elements at: i) equals: el ].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindStringStartingAtCaseSensitive

	self assert: ('éèàôüößäóñíá' findString: 'Á' startingAt: 1 caseSensitive: false) equals: 12.
	self assert: ('éèàôüößäóñíá' findString: 'Á' startingAt: 1 caseSensitive: true) equals: 0.
	self assert: ('suiehl5tlr' findString: 'r' startingAt:  5 caseSensitive: true) equals: 10.
	self assert: ('test' findString: 'T' startingAt: 3 caseSensitive: false) equals: 4.
	self assert: ('test' findString: '' startingAt: 1 caseSensitive: false) equals: 0! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastIfAbsent

	self assert: (self moreThan4Elements 
			atLast: 1
			ifAbsent: [ nil ]) = self moreThan4Elements last.
	self assert: (self moreThan4Elements 
			atLast: self moreThan4Elements size + 1
			ifAbsent: [ 222 ]) = 222! !

!StringTest methodsFor: 'tests' stamp: ''!
testReadFrom
	self 
		assert: (String readFrom: ($' asString, 'foo', $' asString) readStream)
		equals: 'foo'.
	self 
		assert: (String readFrom: ($' asString, 'this ', $' asString, $' asString, ' is embedded', $' asString) readStream)
		equals: 'this '' is embedded'.
	self 
		assert: (String readFrom: ('<whitespace>', $' asString, 'foo', $' asString, '<whitespace>') readStream)
		equals: 'foo'.
	self
		assert: (String readFrom: 'this '' is embedded' printString readStream)
		equals: 'this '' is embedded'! !

!StringTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithOrWithoutSpecificElementsTest

	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self indexInNonEmpty.
	self assert: self indexInNonEmpty > 0.
	self assert: self indexInNonEmpty <= self nonEmpty size! !

!StringTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithFirst

	| index element result |
	index:= self indexInNonEmpty .
	element:= self nonEmpty at: index.
	
	result := self nonEmpty copyWithFirst: element.	
	
	self assert: result size = (self nonEmpty size + 1).
	self assert: result first = element .
	
	2 to: result size do:
	[ :i |
	self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testTrimBoth
	self assert: '' trimBoth equals: ''.
	self assert: ' ' trimBoth equals: ''.
	self assert: '	' trimBoth equals: ''.
	self assert: 'foo' trimBoth equals: 'foo'.
	self assert: ' foo ' trimBoth equals: 'foo'.
	self assert: '  foo  ' trimBoth equals: 'foo'.
	self assert: ((String with: Character cr), '   foo  ') trimBoth equals: 'foo'.
	
	self assert: ('aabbaa' trimBoth: [ :each | each = $a ]) equals: 'bb'.
	self assert: ('bbaabb' trimBoth: [ :each | each = $a ]) equals: 'bbaabb'! !

!StringTest methodsFor: 'tests - printing' stamp: ''!
testDisplayString

	| actual |
	actual := 'some string' displayString.
	self assert: actual equals: 'some string'! !

!StringTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLast

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection copyUpToLast: (collection at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at: i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!StringTest methodsFor: 'requirements' stamp: ''!
otherCollection
	"Returns a collection that does not include what is returned by #element."
	
	^ collectionNotIncluded! !

!StringTest methodsFor: 'tests - internet' stamp: ''!
testWithInternalLineEndings

	{
		'abc' -> 'abc'.
		'abc', String cr -> ('abc', String cr).
		'abc', String lf -> ('abc', String cr).
		'abc', String crlf -> ('abc', String cr).
		String cr, 'abc' -> (String cr, 'abc').
		String lf, 'abc' -> (String cr, 'abc').
		String crlf, 'abc' -> (String cr, 'abc').
		'abc', String cr, String cr, 'abc' -> ('abc', String cr, String cr, 'abc').
		'abc', String lf, String lf, 'abc' -> ('abc', String cr, String cr, 'abc').
		'abc', String crlf, String crlf, 'abc' -> ('abc', String cr, String cr, 'abc').
		String cr, 'abc', String cr, String crlf, 'abc', String lf -> (String cr, 'abc', String cr, String cr, 'abc', String cr).
		String lf, 'abc', String lf, String crlf, 'abc', String cr -> (String cr, 'abc', String cr, String cr, 'abc', String cr).
		(WideString with: 403 asCharacter with: Character lf) -> (WideString with: 403 asCharacter with: Character cr).
	} do: [ :each |
		self assert: each key withInternalLineEndings equals: each value ]! !

!StringTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			lastIndexOf: element
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 99 ]) equals: 99! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
	"Return a collection for wich each element is not included in 'nonEmpty'"

	^ collectionNotIncluded! !

!StringTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToLastWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyUpToLast:' should copy until the last occurrence :"
	result := collection copyUpToLast: (element ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (collection at: i) ].
	
	self assert: result size equals: (collection size - 1)! !

!StringTest methodsFor: 'tests' stamp: ''!
testPadRightTo

	self assert: ('a' padRightTo: 3) equals: 'a  '. 
	self assert: ('a' padRightTo: 1) equals: 'a'. 
	self assert: ('a' padRightTo: 0) equals: 'a'! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testTrimRight
	self assert: '' trimRight equals: ''.
	self assert: ' ' trimRight equals: ''.
	self assert: '	' trimRight equals: ''.
	self assert: 'foo' trimRight equals: 'foo'.
	self assert: ' foo ' trimRight equals: ' foo'.
	self assert: '  foo  ' trimRight equals: '  foo'.
	
	self assert: ('aabbaa' trimRight: [ :each | each = $a ]) equals: 'aabb'.
	self assert: ('bbaabb' trimRight: [ :each | each = $a ]) equals: 'bbaabb'! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0SortingArrayedTest
	| tmp sorted |
	" an unsorted collection of number "
	self unsortedCollection.
	self unsortedCollection do: [ :each | each isNumber ].
	sorted := true.
	self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ].
	self deny: sorted.	" a collection of number sorted in an ascending order"
	self sortedInAscendingOrderCollection.
	self sortedInAscendingOrderCollection do: [ :each | each isNumber ].
	tmp := self sortedInAscendingOrderCollection at: 1.
	self sortedInAscendingOrderCollection
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!StringTest methodsFor: 'tests' stamp: ''!
testCompare

	self assert: ('EEA' compare: 'fgh') equals: 1.
	self assert: ('ABCDEFGH' compare: 'ABCDEFGH') equals: 2.
	self assert: ('fgh' compare: 'fg') equals: 3.
	self assert: ('éèàôüöß' compare: 'ÉÈÀÔÜÖẞ') equals: 1.
	self assert: ('éèàôüößäóñíá' compare: 'éèàôüößäóñíá') equals: 2.
	self assert: ('ÉÈÀÔÜ' compare: 'ÔÜÖ') equals: 1.
	self assert: ('eeao' compare: 'éèàô') equals: 1.
	self assert: ('!!@#' compare: '123') equals: 1! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindAnySubstringStartingAt

	self assert: ('tester12345' findAnySubstring: #('st' $1) startingAt: 1) equals: 3.
	self assert: ('éèàôüößäóñíá1234' findAnySubstring: #('st' '' 'óñ' '123') startingAt:  1) equals: 9.
	self assert: ('éèàôüößäóñíá' findAnySubstring: #('') startingAt: 2) equals: 13.
	self assert: ('éèàôüößäóñíá' findAnySubstring: #('óñ') startingAt: 3) equals: 9.
	self assert: ('éèàôüößäóñíá' findAnySubstring: #() startingAt: 3) equals: 13.
	self assert: ('test12345' findAnySubstring: #('"' '@') startingAt: 12) equals: 10! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	firstCollection  with: secondCollection do:
		[:a :b |
		index := index + 1.
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals: b ]! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy13

	| tokens |
	string := 'one, two# three; four. five'.
	tokens := string findTokens: ',#;.' escapedBy: nil.
	self assert: tokens size equals: 5.
	self assert: tokens third equals: ' three'! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testGroupsOfAtATimeCollect
	| groupsOf2 |
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: [ :x | x ]).
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: #yourself).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 2 atATimeCollect: [ :x | x ].
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 2.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 2 ]).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 3 atATimeCollect: #yourself.
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 3.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 3 ]).! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
elementToAdd
	^ $u! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!StringTest methodsFor: 'tests' stamp: ''!
testBeginsWithCaseSensitive
	| w1 w2 |
	self deny: ('abc' beginsWith: '' caseSensitive: true). "consistent to #beginsWith:"
	self deny: ('abc' beginsWith: '' caseSensitive: false). "consistent to #beginsWith:"
	self deny: ('abc' beginsWith: 'abcd' caseSensitive: true).
	self deny: ('abc' beginsWith: 'abcd' caseSensitive: false).
	self deny: ('abc' beginsWith: 'c' caseSensitive: true).
	self deny: ('abc' beginsWith: 'c' caseSensitive: false).
	
	self assert: ('abc' beginsWith: 'ab' caseSensitive: true).
	self assert: ('abc' beginsWith: 'ab' caseSensitive: false).
	self assert: ('abc' beginsWith: 'Ab' caseSensitive: false).
	self assert: ('abc' beginsWith: 'aB' caseSensitive: false).
	self deny: ('abc' beginsWith: 'aB' caseSensitive: true).
	self assert: ('abcd' asWideString beginsWith: 'abC' caseSensitive: false).

	w1 := WideString with: (Unicode value: 402) with: $a with: (Unicode value: 400) with: $b.
	w2 := WideString with: (Unicode value: 402).
	self assert: (w1 beginsWith: w2 caseSensitive: true).
	self deny: (w1 beginsWith: w2 asUppercase caseSensitive: true).
	self assert: (w1 beginsWith: w2 asUppercase caseSensitive: false).! !

!StringTest methodsFor: 'tests - at put' stamp: ''!
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.! !

!StringTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLast

	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection copyAfterLast: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!StringTest methodsFor: 'tests - at put' stamp: ''!
testAtPut
	
	self nonEmpty at: self anIndex put: self aValue.
	self assert: (self nonEmpty at: self anIndex) = self aValue.! !

!StringTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testindexOfstartingAt

	self assert: ('aa aa éé aa aa' indexOf: $a startingAt: 8) equals: 10.
	self assert: ('aa aa éé aa aa' indexOf: $z startingAt: 8) equals: 0.! !

!StringTest methodsFor: 'tests - formatting' stamp: ''!
testFormatFailures

	self
		should: [ 'This is {foo} !!' format: Dictionary new ]
		raise: KeyNotFound.
		
	self
		should: [ 'This is {1} !!' format: Array new ]
		raise: SubscriptOutOfBounds.! !

!StringTest methodsFor: 'tests - creation' stamp: ''!
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 ) equals: (collection occurrencesOf: element1).
	self assert: (aCol occurrencesOf: element2 ) equals: (collection occurrencesOf: element2)! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy01

	| tokens |
	string := 'this, is, "a, test"'.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens size equals: 3! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy12

	| tokens |
	string := 'one, two# three; four. five'.
	tokens := string findTokens: ',#;.' escapedBy: '"'.
	self assert: tokens size equals: 5.
	self assert: tokens third equals: ' three'! !

!StringTest methodsFor: 'tests - includes' stamp: ''!
elementNotInForOccurrences
	^ $z! !

!StringTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceAllWith
	| result collection oldElement newElement oldOccurrences |
	collection := self nonEmpty.
	result := collection copy.
	oldElement := self elementInForReplacement.
	newElement := self newElement.
	oldOccurrences := (result occurrencesOf: oldElement) + (result occurrencesOf: newElement).
	result replaceAll: oldElement with: newElement.
	
	self assert: oldOccurrences equals: (result occurrencesOf: newElement)! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testRomanNumber

	self assert: 'I' romanNumber equals: 1.
	self assert: 'V' romanNumber equals: 5.
	self assert: 'XVI' romanNumber equals: 16.
	self assert: 'XIV' romanNumber equals: 14.
	self assert: 'MDCLXXXVII' romanNumber equals: 1687.
	self assert: 'MCMXLII' romanNumber equals: 1942.
	self assert: 'DCLXVI' romanNumber equals: 666.
	self assert: '-V' romanNumber equals: -5.
	self assert: '-MDCCCXCV' romanNumber equals: -1895.! !

!StringTest methodsFor: 'requirements' stamp: ''!
anIndex
	"Return an index in nonEmpty bounds"
	
	^ 2! !

!StringTest methodsFor: 'tests' stamp: ''!
testSorted
	| result tmp unsorted |
	unsorted := self unsortedCollection.
	result := unsorted sorted.
	self deny: unsorted == result.
	tmp := result at: 1.
	result
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!StringTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!StringTest methodsFor: 'tests' stamp: ''!
testCompareCaseSensitive

	self assert: ('EEA' compare: 'fgh' caseSensitive: true) equals: 1.
	self assert: ('ABCDEFGH' compare: 'abcdefgh' caseSensitive: false) equals: 2.
	self assert: ('fgh' compare: 'fg' caseSensitive: false) equals: 3.
	self assert: ('éèàôüößäóñíá' compare: 'éèàôüößäóñíá' caseSensitive: false) equals: 2.
	self assert: ('ÉÈÀÔÜ' compare: 'ÔÜÖ' caseSensitive: true) equals: 1.
	self assert: ('éèàôüöß' compare: 'ÉÈÀÔÜÖẞ' caseSensitive: false) equals: 1! !

!StringTest methodsFor: 'tests - sorting' stamp: ''!
testIsSortedBy
	self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]).
	self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]).! !

!StringTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result:= self empty,self secondCollection .
	
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:i).
		].
	"size : "
	self assert: result size = ( self secondCollection size).! !

!StringTest methodsFor: 'tests' stamp: ''!
testAsTime 

	self assert: '1:00:00' asTime asString equals: '1:00 am'.
	self assert: '1:00' asTime asString equals: '1:00 am'.
	self assert: '1' asTime asString equals: '1:00 am'.
	self assert: '13' asTime asString equals: '1:00 pm'! !

!StringTest methodsFor: 'tests - at put' stamp: ''!
testAtPutOutOfBounds
	
	self should: [self empty at: self anIndex put: self aValue] raise: Error! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testWriteStreamConvertsToWideString
	| oldWideString newString ws |
	"test that a write stream on a ByteString is autoconverted into a WideString if a Wide character is inserted into it"
	oldWideString := (WideString new: 1) wordAt: 1 
										put: 20984060; 
										yourself.
	newString := (String new: oldWideString size).
	ws := newString writeStream.
	oldWideString do: [:each | ws nextPut: each].
	self assert: newString equals: oldWideString.! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!StringTest methodsFor: 'tests - puting with indexes' stamp: ''!
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).! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testAsInteger

	self assert: '1796exportFixes-tkMX' asInteger equals: 1796.
	self assert: 'donald' asInteger isNil.
	self assert: 'abc234def567' asInteger equals: 234.
	self assert: '-94' asInteger equals: -94.
	self assert: 'foo-bar-92' asInteger equals: -92! !

!StringTest methodsFor: 'tests - creation' stamp: ''!
testWith
	
	| aCol anElement |
	anElement := self collectionMoreThan5Elements anyOne.
	aCol := self collectionClass with: anElement.
	self assert: (aCol includes: anElement).! !

!StringTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation
	| result index |
	result:= self firstCollection,self secondCollection .
	"first part : "
	index := 1.
	self firstCollection do: 
		[:each | 
		self assert: (self firstCollection at: index)=each.
		index := index+1.].
	"second part : "
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:index).
		index:=index+1].
	"size : "
	self assert: result size = (self firstCollection size + self secondCollection size).! !

!StringTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContentsSized
	| result |
	result:= self collectionClass new: 1 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.
	
	result:= self collectionClass new: 1000 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertAsSetForMultiplinessTest
	"a collection  with equal elements:"

	| res |
	self withEqualElements.
	res := true.
	self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res = true! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateSequencedReadableTest
	| res |
	self nonEmptyMoreThan1Element.
	self assert: self nonEmptyMoreThan1Element size > 1.

	self empty.
	self assertEmpty: self empty.

	res := true.
	self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDo! !

!StringTest methodsFor: 'tests - as set tests' stamp: ''!
testAsIdentitySetWithEqualsElements
	| result collection |
	collection := self withEqualElements .
	result := collection asIdentitySet.
	collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = IdentitySet.! !

!StringTest methodsFor: 'requirements' stamp: ''!
aValue
	"Return a value to put into nonEmpty"
	
	^ elementInNonEmpty! !

!StringTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty ).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
	"Return a collection of elements included in 'nonEmpty'"

	^ subcollection3ElementsSorted! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!StringTest methodsFor: 'tests - comparing' stamp: ''!
testComparing
	self assert: 'foo' < 'foo:'.
	self assert: 'foo' < 'fooBar'.
	self assert: 'foo' <= 'foo:'.
	self assert: 'foo' <= 'fooBar'.
	self assert: 'foo:' > 'foo'.
	self assert: 'fooBar' > 'foo'.
	self assert: 'foo:' >= 'foo'.
	self assert: 'fooBar' >= 'foo'! !

!StringTest methodsFor: 'tests' stamp: ''!
testIndexOfFirstUppercaseCharacter

	self assert: 'test thiS strIng' indexOfFirstUppercaseCharacter equals: 9.
	self assert: 'test this string' indexOfFirstUppercaseCharacter equals: 0.
	self assert: '123éàôüöß' indexOfFirstUppercaseCharacter equals: 0.
	self assert: '123éàôüÖẞ' indexOfFirstUppercaseCharacter equals: 8! !

!StringTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyFromTo
	| result  index collection |
	collection := self collectionWithoutEqualElements .
	index :=self indexInForCollectionWithoutDuplicates .
	result := collection   copyFrom: index  to: collection  size .
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at:i) equals: (collection  at: (i + index - 1))].
	
	"Verify size"
	self assert: result size equals: (collection  size - index + 1)! !

!StringTest methodsFor: 'tests' stamp: ''!
testIndexOfWideCharacterFromTo

	self assert: ('123éàôüÖẞ' indexOfWideCharacterFrom: 1 to: 9) equals: 9.
	self assert: ('te€st' indexOfWideCharacterFrom: 1 to: 5) equals: 3.
	self assert: ('te€st this string' indexOfWideCharacterFrom: 4 to: 10) equals: 0.
	self assert: ('€₤' indexOfWideCharacterFrom: 1 to: 2) equals: 1! !

!StringTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the first occurrence:"
	result := collection   copyAfter: (element ).
	
	"Verifying content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + 1 )) equals: (result at: (i)) ].

	"Verify size"
	self assert: result size equals: (collection size - 1).! !

!StringTest methodsFor: 'tests - instance creation' stamp: ''!
testLoremIpsum
	| fillerText |
	fillerText := String loremIpsum.
	self denyEmpty: fillerText.
	self assert: (fillerText beginsWith: 'Lorem ipsum').
	self assert: (fillerText endsWith: 'laborum.').
	self assert: fillerText lines first equals: fillerText.
	self assert: fillerText isAsciiString.
	self assert: (Character space split: fillerText) size > 10! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
	"Return a collection that doesn't include a nil element and that doesn't include equal elements'"

	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests' stamp: ''!
testOccursInWithEmptyCaseSensitive

	self assert: ('abc98def' occursInWithEmpty: 'abc' caseSensitive: true). 
	self deny: ('abc98def' occursInWithEmpty: 'Abc' caseSensitive: true). 
	self assert: ('abc98def' occursInWithEmpty: 'Abc' caseSensitive: false).
	self assert: ('012éà ôüÖ ẞ345' occursInWithEmpty: '012' caseSensitive: true).
	self deny: ('012éàôüÖ ẞ345' occursInWithEmpty: 'ÉÀÔÜÖ' caseSensitive: true)! !

!StringTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString |
	result:=''.
	aStream:= ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ').
	allElementsAsString withIndexDo: 
		[:el :i | 
		i<(allElementsAsString size-1 )
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:i)asString)].
		i=(allElementsAsString size-1)
			ifTrue:[ self deny: (allElementsAsString at:i) equals: ('and')asString].
		i=(allElementsAsString size)
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:(i-1))asString)]]! !

!StringTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!StringTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy03

	| tokens |
	string := 'this, is, a, test'.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens size equals: 4! !

!StringTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfStartingAtDuplicate

	| 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 ]) equals: 1.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 55 ]) equals: collection size! !

!StringTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfDuplicate

	| 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) equals: 1! !

!StringTest methodsFor: 'tests - sorting' stamp: ''!
testSortUsingSortBlock
	| result tmp |
	result := self unsortedCollection sort: [:a :b | a>b].
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!StringTest methodsFor: 'requirements' stamp: ''!
subCollectionNotIn
	"Return a collection for which at least one element is not included in 'moreThan4Elements'"
	
	^ collectionNotIncluded! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindWordStartStartingAt

	self assert: ('test this string' findWordStart: 'th' startingAt: 1) equals: 6.
	self assert: ('test this string' findWordStart: 'st' startingAt: 1) equals: 11.
	self assert: ('test this string' findWordStart: 'st' startingAt: 12) equals: 0.
	self assert: ('test this string' findWordStart: '' startingAt: 1) equals: 0! !

!StringTest methodsFor: 'tests' stamp: ''!
testPadRightToWith

	self assert: ('a' padRightTo: 3 with: $#) equals: 'a##'. 
	self assert: ('a' padRightTo: 1 with: $#) equals: 'a'. 
	self assert: ('a' padRightTo: 0 with: $#) equals: 'a'! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy07

	| tokens |
	string := 'a:b::c'.
	tokens := string findTokens: ':' escapedBy: '"'.
	self assert: tokens size equals: 4.
	self assert: tokens first equals: 'a'.
	self assert: tokens second equals: 'b'.
	self assert: tokens third equals: ''.
	self assert: tokens fourth equals: 'c'! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastError

	self 
		should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ]
		raise: Error! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLast

	| element result |
	element := self nonEmptyMoreThan1Element at: self nonEmptyMoreThan1Element size.
	result := self nonEmptyMoreThan1Element findLast: [:each | each =element].
	
	self assert: result equals: self nonEmptyMoreThan1Element size! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy10

	| tokens |
	string := 'this, is, ###a, test'.
	tokens := string findTokens: ',' escapedBy: '#'.
	self assert: tokens size equals: 3.
	self assert: tokens third equals: ' #a, test'! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testWithoutPrefix
	self assert: ('UMLClass' withoutPrefix: 'UML') equals: 'Class'.
	self assert: ('UMLClass' withoutSuffix: 'Class') equals: 'UML'.
	
	self assert: ('UMLClass' withoutPrefix: 'Class') equals: 'UMLClass'.
	self assert: ('UMLClass' withoutSuffix: 'UML') equals: 'UMLClass'.! !

!StringTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceFromToWith
	| result collection replacementCollec firstInd secondInd |
	collection := self nonEmpty .
	replacementCollec := self replacementCollectionSameSize.
	firstInd := self firstIndex.
	secondInd := self secondIndex.
	result := collection copy.
	result replaceFrom: firstInd to: secondInd with: replacementCollec.
	
	"Verify content of 'result'"

	"First part of 'result'"	
	1 to: (firstInd - 1) do: [:i | self assert: (collection at:i) equals: (result at: i) ].
	
	"Middle part containing replacementCollection"	
	firstInd to: (firstInd + replacementCollec size - 1) do: 
		[:i | self assert: (result at: i) equals: (replacementCollec at: (i - firstInd + 1)) ].
	
	"End part"
	(firstInd + replacementCollec size) to: (result size) do:
		[:i|
		self assert: (result at: i) equals: (collection at: (secondInd + 1 - (firstInd + replacementCollec size) + i)) ]! !

!StringTest methodsFor: '*ScriptingExtensions-Tests' stamp: ''!
testAsClass
	self 
		assert: 'String' asClass
		equals: String! !

!StringTest methodsFor: 'tests - indexof' stamp: ''!
findFirstInString: aString fromString: searchString

	^ String findFirstInString: aString inSet: (CharacterSet newFrom: searchString) byteArrayMap startingAt: 1! !

!StringTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!StringTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllPutAll

	| aValueArray |
	aValueArray := self valueArray .
	self nonEmpty atAll: self indexArray putAll: aValueArray  .
	
	self indexArray withIndexDo: [:element :index |
		self assert: (self nonEmpty at: element) equals: (aValueArray  at: index) ]! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy25

	| tokens |
	string := 'this, /is, a"," test/'.
	tokens := string findTokens: $, escapedBy: $/.
	self assert: tokens size equals: 2.
	self assert: tokens first equals: 'this'.
	self assert: tokens second equals: ' is, a"," test'.! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := firstCollection size.
	
	firstCollection  reverseWith: secondCollection do:
		[:a :b |
	
		self assert: (firstCollection at: index) equals: a. 
		self assert: (secondCollection at: index) equals: b.
			(index := index - 1)]! !

!StringTest methodsFor: 'tests - lines' stamp: ''!
testWthNoLineLongerThan
	| phrases |
	phrases := {
		'Fred the bear went down to the brook to read his book in silence'.
		'Fred the bear went down' , String cr , ' to the brook to ' , String cr , 'read his book in silence'.
		'Fred the bear went down' , String lf , '  to the brook to ' , String lf , 'read his book in silence'.
		'Fred the bear went down' , String crlf , '  to the brook to ' , String crlf , 'read his book in silence'.
		}.
	#(5 7 9) do: [:length |
		phrases do: [:phrase |
			| split |
			split := phrase withNoLineLongerThan: length.
			self
				assert: (split copyWithoutAll: CharacterSet separators) = (phrase copyWithoutAll: CharacterSet separators)
				description: 'no information should be lost'.
			split linesDo: [:line |
				self assert: line size <= length description: 'lines should not be longer than prescribed'].
			phrase lineCount = 1 ifTrue: [| lastLineSize |
				lastLineSize := length.
				split linesDo: [:line |
					line isEmpty ifFalse: [| firstWordSize |
						firstWordSize := line indexOfAnyOf: CharacterSet separators startingAt: 1 ifAbsent: [line size + 1].
						self assert: (lastLineSize + firstWordSize) > length description: 'split was too short'.
						lastLineSize := line size]]]]]! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!StringTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOf
	| collection |
	collection := self collectionWithoutEqualElements .
	
	collection do: [ :each | self assert: (collection occurrencesOf: each) equals: 1 ]! !

!StringTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWith1Occurrence
	| 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 ) ).
		].! !

!StringTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyEmptyMethod
	| result |
	result := self collectionWithoutEqualElements copyEmpty.
	self assertEmpty: result.
	self assert: result class equals: self nonEmpty class! !

!StringTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfter
	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection   copyAfter: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!StringTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!StringTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsNotThere
	
	self deny: (self nonEmpty includes: self elementNotInForOccurrences).
	self assert: (self nonEmpty includes: self nonEmpty anyOne).
	self deny: (self empty includes: self elementNotInForOccurrences)! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirst

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element findFirst: [:each | each = element].
	
	self assert: result equals: 1! !

!StringTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButFirst

	| abf col |
	col := self moreThan3Elements.
	abf := col allButFirst.
	self deny: abf first = col first.
	self assert: abf size + 1 = col size! !

!StringTest methodsFor: 'tests - formatting' stamp: ''!
testExpandMacrosSkip
	self assert: '%<' expandMacros equals: '<'! !

!StringTest methodsFor: 'tests - lines' stamp: ''!
testLineNumber
	| sampleCRString sampleLFString sampleCRLFString |
	sampleCRString := 'Fred', String cr , 'the', String cr, 'Bear'.
	sampleLFString := 'Fred', String lf , 'the', String lf, 'Bear'.
	sampleCRLFString := 'Fred', String crlf, 'the', String crlf, 'Bear'.
	
	self assert: (sampleCRString lineNumber: 2) equals: 'the'.
	self assert: (sampleLFString lineNumber: 2) equals: 'the'.
	self assert: (sampleCRLFString lineNumber: 2) equals: 'the'.! !

!StringTest methodsFor: 'tests - equality' stamp: ''!
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)! !

!StringTest methodsFor: 'tests' stamp: ''!
testIndexOf

	self assert: ('test this string' indexOf: $k) equals: 0.
	self assert: ('test this string' indexOf: 't') equals: 0.
	self assert: ('test this string' indexOf: $t) equals: 1.
	self assert: ('123éàôüöß' indexOf: $ß) equals: 9.
	self assert: ('123éàôüöß' indexOf: $E) equals: 0! !

!StringTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	 
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
	"Return a collection not including equal elements"
	
	^ withoutEqualElements! !

!StringTest methodsFor: 'tests - includes' stamp: ''!
collection
	^ 'ghj'! !

!StringTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutFirst

	| result |
	result := self nonEmpty copyWithoutFirst.
	
	self assert: result size equals: (self nonEmpty size - 1).
	
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (self nonEmpty at: (i + 1))]! !

!StringTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtLastPut

	| index |
	index := self indexArray anyOne.	
	self nonEmpty atLast: index put: self aValue.	

	self assert: (self nonEmpty at: (self nonEmpty size + 1 - index)) equals: self aValue! !

!StringTest methodsFor: 'requirements' stamp: ''!
oldSubCollection
	"Return a subCollection included in collectionWith1TimeSubcollection.
		Example:  subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)"
		
	^ subcollection3ElementsSorted! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedConcatenationTest
	self empty.
	self assertEmpty: self empty.
	self firstCollection.
	self secondCollection! !

!StringTest methodsFor: 'tests' stamp: ''!
testEquality
	
	self assert: 'abc' equals: 'abc' asWideString.
	self assert: 'abc' asWideString equals: 'abc'.
	self assert: ( #[97 0 0 0] asString ~= 'a000' asWideString).
	self assert: ('a000' asWideString ~=  #[97 0 0 0] asString).

	self assert: ('abc' sameAs: 'aBc' asWideString).
	self assert: ('aBc' asWideString sameAs: 'abc').
	self assert: ( #[97 0 0 0] asString 
						sameAs: 'Abcd' asWideString) not.
	self assert: ('a000' asWideString sameAs: #[97 0 0 0] asString) not.! !

!StringTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAt

	| subcollection index collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 1.
	self assert: index equals: 1.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 2.
	self assert: index equals: 0! !

!StringTest methodsFor: 'tests' stamp: ''!
testPadLeftToWith

	self assert: ('a' padLeftTo: 3 with: $#) equals: '##a'. 
	self assert: ('a' padLeftTo: 1 with: $#) equals: 'a'. 
	self assert: ('a' padLeftTo: 0 with: $#) equals: 'a'! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessFotMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!StringTest methodsFor: 'requirements' stamp: ''!
elementInForReplacement
	"Return an element included in 'nonEmpty'"

	^ self nonEmpty anyOne! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testWithoutPeriodSuffix
	#( 
		'foo' 'foo'
		'foo.' 'foo'
		'foo.bar' 'foo'
		'foo.bar.txt' 'foo'
		'' ''
		'.' '.'
	) pairsDo: [ :input :output |
		self assert: input withoutPeriodSuffix equals: output ]! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!StringTest methodsFor: 'requirements' stamp: ''!
moreThan3Elements
	"Return a collection including at least 3 elements"
	
	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollect
	
	| result firstCollection secondCollection index  |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	result := firstCollection  with: secondCollection collect:
		[:a :b |
		( index := index + 1).
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals:  b.
		b].
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (secondCollection  at: i)].
	self assert: result size = secondCollection size! !

!StringTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!StringTest methodsFor: 'requirements' stamp: ''!
moreThan4Elements
	"Return a collection including at least 4 elements"

	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testCapitalized
	| uc lc empty |
	uc := 'MElViN'.
	lc := 'mElViN'.
	empty := ' '.
	self assert: lc capitalized equals: uc.
	self assert: uc capitalized equals: uc.
	"the string gets copied"
	self deny: uc capitalized identicalTo: uc.
	self deny: empty capitalized identicalTo: empty! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testAsSmalltalkComment
	| exampleStrings |
	exampleStrings := #('' ' ' '"' '""' '"""' 'abc"abc' 'abc""abc' 'abc"hello"abc' 'abc"' '"abc').

	"check that the result of scanning the comment is empty"
	exampleStrings
		do: [ :s | 
			| tokens |
			tokens := s asComment parseLiterals.
			self assertEmpty: tokens ].

	"check that the result has the same non-quote characters as the original"
	exampleStrings do: [ :s | self assert: (s copyWithout: $") equals: (s asComment copyWithout: $") ].

	"finnaly, test for some common kinds of inputs"
	self assert: 'abc' asComment equals: '"abc"'.
	self assert: 'abc"abc' asComment equals: '"abc""abc"'.
	self assert: 'abc""abc' asComment equals: '"abc""abc"'! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!StringTest methodsFor: 'tests - formatting' stamp: ''!
testFormatExtended

	self
		assert: ('This is {foo} !!' format: (Dictionary with: #foo->'a test'))
		equals: 'This is a test !!'.

 	{ 
 		[ '\{ \} \\ foo {foo} bar {bar}' format: { #foo->12. #bar->'string' } asDictionary ] -> '{ } \ foo 12 bar string'. 
 		[ '\{ \} \\ foo {bar} bar {foo}' format: { 'bar'->12. 'foo'->'string' } asDictionary ] -> '{ } \ foo 12 bar string'. 
 		[ '\{x}' format: {} ] -> '{x}'. 
 		[ '\{x}{x}' format: { #x->$a } asDictionary ] -> '{x}a'. 
 	} do: [ :each | 
		self assert: each key value equals: each value ]! !

!StringTest methodsFor: 'tests - copying' stamp: ''!
testCopyUpToSubstring 

	self assert: ('abcdef' copyUpToSubstring: '') equals: ''.
	self assert: ('abcdef' copyUpToSubstring: 'a') equals: ''.
	self assert: ('abcdef' copyUpToSubstring: 'b') equals: 'a'.
	self assert: ('abcdef' copyUpToSubstring: 'de') equals: 'abc'.
	self assert: ('abcdef' copyUpToSubstring: 'ef') equals: 'abcd'.
	self assert: ('abcdef' copyUpToSubstring: 'f') equals: 'abcde'.
	self assert: ('abcdef' copyUpToSubstring: 'fg') equals: 'abcdef'.
	self assert: ('' copyUpToSubstring: 'abc') equals: ''.
	self assert: ('abcdef' copyUpToSubstring: 'g') equals: 'abcdef'.
	self assert: ('abcdef' copyUpToSubstring: 'gh') equals: 'abcdef'.! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsCollect
	| index result |
	index := 0.

	result := self nonEmptyMoreThan1Element
		pairsCollect: [ :each1 :each2 | 
			self assert: (self nonEmptyMoreThan1Element indexOf: each2) equals: (index := index + 2).
			(self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1) ].

	result do: [ :each | self assert: each ]! !

!StringTest methodsFor: 'tests - indexof' stamp: ''!
testFindFirstInString	
	"These tests are more specific than those in testIndexOf."
	
	"more boundary tests"
	self assert: (self findFirstInString: '' fromString: '') equals: 0.
	self assert: (self findFirstInString: 'x' fromString: '') equals: 0.
	self assert: (self findFirstInString: '' fromString: 'x') equals: 0.
	
	self assert: (self findFirstInString: 'x' fromString: 'x') equals: 1.
	
	self assert: (self findFirstInString: 'hello' fromString: 'hello') equals: 1.
	self assert: (self findFirstInString: 'hello' fromString: 'ello') equals: 2.
	self assert: (self findFirstInString: 'hello' fromString: 'llo') equals: 3.
	self assert: (self findFirstInString: 'hello' fromString: 'o') equals: 5.
	self assert: (self findFirstInString: 'hello' fromString: 'x') equals: 0.! !

!StringTest methodsFor: 'tests' stamp: ''!
testHasWideCharacterFromTo

	self assert: ('te€st' hasWideCharacterFrom: 1 to: 3).
	self deny: ('test' hasWideCharacterFrom: 1 to: 4).  
	self assert: ('€₤' hasWideCharacterFrom: 1 to: 2).  
	self assert: ('test this string €₤' hasWideCharacterFrom: 18 to: 19)! !

!StringTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOf

	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element) equals: (collection indexOf: element)! !

!StringTest methodsFor: 'tests - testing' stamp: ''!
testIsValidSelector
	self assert: 'class' isValidSelector.
	self deny: '0class' isValidSelector! !

!StringTest methodsFor: 'requirements' stamp: ''!
nonEmptyMoreThan1Element
	"Return a collection that don't includes equal elements'"
	
	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!StringTest methodsFor: 'tests - copying' stamp: ''!
testTrimmed
	self assert: '  a  ' trimmed equals: 'a'.! !

!StringTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testUpTo
	
	self assert: #up:to: keywords equals: #(up: to:).
	self assert: #copy:from:to: keywords equals: #(copy: from: to:).
	self assert: #up keywords equals: #(up).
	self assert: #at: keywords equals: #(at:).! !

!StringTest methodsFor: 'tests' stamp: ''!
testAsUppercase 

	self assert: ('éèàôütest' asUppercase) equals: 'ÉÈÀÔÜTEST'.
	self assert: ('123éàôüößTEST' asUppercase) equals: '123ÉÀÔÜÖẞTEST'.
	self assert: ('' asUppercase) equals: ''! !

!StringTest methodsFor: 'tests' stamp: ''!
testLastSpacePosition

	self assert: 'fred the bear' lastSpacePosition equals: 9.
	self assert: 'ziggie' lastSpacePosition equals: 0.
	self assert: 'elvis ' lastSpacePosition equals: 6.
	self assert: 'wimpy  ' lastSpacePosition equals: 7.
	self assert: '' lastSpacePosition equals: 0.
	self assert: ' 123  éà ôüÖ ẞ' lastSpacePosition equals: 13! !

!StringTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	^ notIn! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
testCopyNonEmptyWithoutAllNotIncluded! !

!StringTest methodsFor: 'tests - line breaking' stamp: ''!
testLinesDoWithCr

	| myString  |
	myString := 'This is a test of line breaking', String cr.
	myString linesDo: [ :line |
		self assert: (line size + 1) equals: myString size]! !

!StringTest methodsFor: 'tests - includes' stamp: ''!
anotherElementNotIn
	^ $k! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy22

	| tokens |
	string := ''.
	tokens := string findTokens: $, escapedBy: $".
	self assert: tokens size equals: 0! !

!StringTest methodsFor: 'tests' stamp: ''!
testAsSignedInteger

	self assert: 'test' asSignedInteger isNil.
	self assert: 'é è à ô ü ö ß ä ó ñ í á' asSignedInteger isNil.
	self assert: 'test-10test' asSignedInteger equals: -10.
	self assert: ('' asSignedInteger) equals: nil.
	self assert: '1234567890-1234567890' asSignedInteger equals: 1234567890.
	self assert: '--12345' asSignedInteger equals: -12345! !

!StringTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfIfAbsentDuplicate

	| 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 ]) equals: 1! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testFirstSecondThird

	self assert: self moreThan4Elements first equals: (self moreThan4Elements at: 1).
	self assert: self moreThan4Elements second equals: (self moreThan4Elements at: 2).
	self assert: self moreThan4Elements third equals: (self moreThan4Elements at: 3).
	self assert: self moreThan4Elements fourth equals: (self moreThan4Elements at: 4)! !

!StringTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfIfAbsentDuplicate

	| 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 ]) equals: collection size! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureBeginsEndsWithTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self assert: self nonEmpty size > 1.
	self empty.
	self assertEmpty: self empty! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testAtIfAbsent

	| 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! !

!StringTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterLastWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the last occurrence of element :"
	result := collection copyAfterLast: element.

	"Verify content"
	self assertEmpty: result! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy02
	| tokens |
	string := ''.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assertEmpty: tokens! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!StringTest methodsFor: 'requirements' stamp: ''!
elementNotIn
	"Return an element not included in 'nonEmpty'"

	^notIn! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!StringTest methodsFor: 'requirements' stamp: ''!
firstIndex
	"Return an index between 'nonEmpty' bounds that is < to 'second index'"

	^3! !

!StringTest methodsFor: 'tests - sorting' stamp: ''!
testIsSorted
	self assert: self sortedInAscendingOrderCollection isSorted.
	self deny: self unsortedCollection isSorted! !

!StringTest methodsFor: 'tests - subcollections access' stamp: ''!
testLastNElements

	| result |
	result := self moreThan3Elements last: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i + 1) ].
	self assert: result size equals: (self moreThan3Elements size - 1).
	self 
		should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ]
		raise: Error! !

!StringTest methodsFor: 'requirements' stamp: ''!
valueArray
" return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty'  at indexes in 'indexArray' "
	| result |
	result := Array new: self indexArray size.
	1 to: result size do:
		[:i |
		result at:i put: (self aValue ).
		].
	^ result.! !

!StringTest methodsFor: 'tests - creation' stamp: ''!
testWithAll

	| aCol collection |
	collection := self collectionMoreThan5Elements asOrderedCollection.
	aCol := self collectionClass withAll: collection.
	
	collection do: [ :each | self assert: (aCol occurrencesOf: each ) equals: ( collection occurrencesOf: each ) ].
	
	self assert: aCol size equals: collection size! !

!StringTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printNameOn: aStream.

	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents equals: ('an ',self nonEmpty class name ) ]
		ifFalse:[ self assert: aStream contents equals: ('a ',self nonEmpty class name)].! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutTest
	self aValue.
	self anotherValue.

	self anIndex.
	self nonEmpty isDictionary ifFalse: [ self assert: (self anIndex >= 1 & self anIndex) <= self nonEmpty size ].

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
	"Return a collection only including elements that can be sorted (understanding '<')"

	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests - equality' stamp: ''!
testHasEqualElementsOfIdenticalCollectionObjects
	
	self assert: (self empty hasEqualElements: self empty). 
	self assert: (self nonEmpty hasEqualElements: self nonEmpty)! !

!StringTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLastEmpty
	| result |
	result := self empty copyUpToLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!StringTest methodsFor: 'tests - formatting' stamp: ''!
testExpandMacrosTernary
	self assert: ('<1?success:error>' expandMacrosWith: true) equals: 'success'.
	self assert: ('<1?success:error>' expandMacrosWith: false) equals: 'error'! !

!StringTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAtIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!StringTest methodsFor: 'tests - internet' stamp: ''!
testWithoutQuoting

 	#( '"foo"' 'foo'
		'''foo''' 'foo'
		'"foo''' '"foo'''
		'''foo"' '''foo"'
		'"foo' '"foo'
		'foo"' 'foo"'
		'foo' 'foo') 
	pairsDo: [ :before :after |
		self assert: before withoutQuoting equals: after ]! !

!StringTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutOneOrMoreElementsTest
	self aValue.


	self indexArray.
	self indexArray
		do: [ :each | 
			self assert: each class = SmallInteger.
			self assert: (each >= 1 & each) <= self nonEmpty size ].

	self assert: self indexArray size = self valueArray size.

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!StringTest methodsFor: '*FileSystem-Tests-Core' stamp: ''!
testAsFileLocatorOrReferenceReturnsAReferenceWhenStringDoesNotReferToAKnownOrigin
	| fileRef result |
	fileRef := '/foo' asFileReference.
	
	result := fileRef fullName asFileLocatorOrReference.
	
	self
		assert: result
		equals: fileRef.! !

!StringTest methodsFor: 'tests - comparing' stamp: ''!
testCorrectAgainst

	| coll |
	coll := OrderedCollection new addAll: #('nest' 'temperature' 'text' 'Jupiter' 'denial' 'nest' 'tttt' 'e' 'alpha' 'beautest'); yourself.

	self assert: ('test' correctAgainst: coll) asArray equals: #('beautest' 'nest' 'text' 'nest' 'tttt' 'temperature').
	self assert: ('123' correctAgainst: coll) asArray equals: #('tttt' 'nest' 'text' 'nest').

	coll := OrderedCollection new.
	self assert: ('test' correctAgainst: coll) asArray equals: #().! !

!StringTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingStartWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty .
	result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ).
	
	"verify content of 'result' : "
	1 to: 2   do:
		[:i | self assert: ( element ) = ( result at:(i) ) ].
	
	3 to: result size do:
		[:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ].

	"verify size of 'result' :"
	self assert: result size = (self nonEmpty size + 2).! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDoEmpty
	| result |
	result := OrderedCollection new.

	self empty keysAndValuesDo: [ :i :value | result add: value + i ].

	self assertEmpty: result! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexCollect
	
	| result index collection |
	index := 0.
	collection := self nonEmptyMoreThan1Element .
	result := collection  withIndexCollect: [:each :i | 
		self assert: i equals: (index := index + 1).	
		self assert: i equals: (collection  indexOf: each).
		each ]. 
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (collection at: i)].
	self assert: result size equals: collection size! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy16

	| tokens |
	string := 'one, "two# three"; &four. five&'.
	tokens := string findTokens: nil escapedBy: nil.
	self assert: tokens size equals: 1.
	self assert: tokens first equals: string! !

!StringTest methodsFor: 'requirements' stamp: ''!
elementInForIndexAccessing
" return an element included in 'accessCollection' "
	^ withoutEqualElements anyOne! !

!StringTest methodsFor: 'requirements' stamp: ''!
secondIndex
	"Return an index between 'nonEmpty' bounds that is > to 'second index'"
	
	^ self firstIndex! !

!StringTest methodsFor: 'tests' stamp: ''!
testEndsWith 

	self deny: ('éèàôüößäóñíá' endsWith: 'ia').
	self deny: ('éèàôüößäóñíá' endsWith: '').
	self assert: ('éèàôüößäóñíá' endsWith: 'éèàôüößäóñíá').
	self deny: ('test' endsWith: 'ST').
	self assert: ('test' endsWith: 'st').
	self deny: ('ÉÈÀÔÜÖẞÄÓÑÍÁ' endsWith: 'íá').
	self deny: ('test' endsWith: 'tester').! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopySameContentsTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionWith2TimeSubcollection
	"Return a collection including 'oldSubCollection' two or many time"
	
	^ nonEmpty5ElementsSorted, subcollection3ElementsSorted! !

!StringTest methodsFor: 'tests' stamp: ''!
testAsSymbol
	self assert: 'hel' , 'lo' asSymbol equals: #hello.
	self assert: 'é è à ô ü' asSymbol equals: #'é è à ô ü'.
	self assert: '' asSymbol equals: #''.
	self assert: 'test' asSymbol identicalTo: #test! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLast

	| index |
	self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last.

	index := self moreThan4Elements indexOf: self elementInForElementAccessing.
	self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! !

!StringTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self collection  anyOne! !

!StringTest methodsFor: 'requirements' stamp: ''!
elementNotInForIndexAccessing
	"Return an element not included in 'accessCollection'"
	
	^ notIn! !

!StringTest methodsFor: 'tests' stamp: ''!
testIsAllAlphaNumerics

	self assert: '123dwef890' isAllAlphaNumerics.
	self deny: '12 34 top &^' isAllAlphaNumerics. 
	self assert: '' isAllAlphaNumerics.
	self deny: ' 234 ' isAllAlphaNumerics.
	self deny: '()' isAllAlphaNumerics. 
	self assert: '123éàôüÖẞ' isAllAlphaNumerics! !

!StringTest methodsFor: 'tests - lines' stamp: ''!
testLineCount
	| sampleCRString sampleLFString sampleCRLFString |
	sampleCRString := 'Fred', String cr, 'the', String cr, 'Bear'.
	sampleLFString := 'Fred', String lf, 'the', String lf, 'Bear'.
	sampleCRLFString := 'Fred', String crlf, 'the', String crlf, 'Bear'.
	
	self assert: sampleCRString lineCount equals: 3.
	self assert: sampleLFString lineCount equals: 3.
	self assert: sampleCRLFString lineCount equals: 3.! !

!StringTest methodsFor: 'tests' stamp: ''!
testAllRangesOfSubstring

	self assert: ('aabbccbb' allRangesOfSubstring: 'bb' ) equals: {(3 to: 4). (7 to: 8)}.
	self assert: ('é è à ô ü ö ß ä ó ñ í á' allRangesOfSubstring: 'ö ß ä') equals: {(11 to: 15)}.
	self assert: ('test' allRangesOfSubstring: '') equals: #()! !

!StringTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfIfAbsent

	| collection |
	collection := self collectionMoreThan1NoDuplicates.
	self assert: (collection 
			indexOf: collection first
			ifAbsent: [ 33 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 33 ]) equals: 33! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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.! !

!StringTest methodsFor: 'tests - copying same contents' stamp: ''!
testReversed

	| result |
	result := self nonEmpty reversed.
	
	"Verify content"
	result withIndexDo:
		[:el :i | self assert: el equals: (self nonEmpty at: (self nonEmpty size - i + 1))].

	"Verify size"
	self assert: result size=self nonEmpty size.! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindSelector
	self assert: #isSymbol equals: 'isSymbol' findSelector.
	self assert: #between:and: equals: 'between:and:' findSelector .
	self assert: #+ equals: '+' findSelector .
	self assert: #isSymbol equals: '#isSymbol' findSelector.
	self assert: #between:and: equals: '#between:and:' findSelector .
	self assert:#+ equals: '#+' findSelector! !

!StringTest methodsFor: 'requirements' stamp: ''!
empty
	^ emptyString! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDo
	| result |
	result := OrderedCollection new.
	self nonEmpty reverseDo: [: each | result add: each].
	
	1 to: result size do:
		[:i|
		self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))]! !

!StringTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty

	| result |
	result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne).
	self assert: result equals: 0! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionWith1TimeSubcollection
	"Return a collection including 'oldSubCollection' only one time"
	
	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests - sorting' stamp: ''!
testSortedUsingBlock
	| result tmp |
	result := self unsortedCollection sorted:  [:a :b | a>b]..
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!StringTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	self deny: (self nonEmpty includesAny: self empty).
	self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }).
	self assert: (self nonEmpty includesAny: self nonEmpty).! !

!StringTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWith
	
	self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst).
	self assert: (self nonEmpty endsWith: self nonEmpty).
	self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCreationWithTest

	self collectionMoreThan5Elements.
	self assert: self collectionMoreThan5Elements size >= 5! !

!StringTest methodsFor: 'requirements' stamp: ''!
element
	"Returns an object that can be added to the collection returned by #collection."
	
	^ elementInNonEmpty! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
testCopyReplaceAllWith
	self assert: ('--A--' copyReplaceAll: 'A' with: 'ABC') equals: '--ABC--'.
	self assert: ('--A--' copyReplaceAll: 'A' with: 'X') equals: '--X--'.
	self assert: ('--ABC--' copyReplaceAll: 'ABC' with: 'X') equals: '--X--'.
	self assert: ('--A--' copyReplaceAll: 'A' with: '') equals: '----'.
	self assert: ('' copyReplaceAll: 'A' with: 'ABC') equals: ''.
	self assert: ('A--A--A' copyReplaceAll: 'A' with: 'ABC') equals: 'ABC--ABC--ABC'.
	self assert: ('A--A--A' copyReplaceAll: 'A' with: 'X') equals: 'X--X--X'.
	self assert: ('ABC--ABC--ABC' copyReplaceAll: 'ABC' with: 'X') equals: 'X--X--X'.
	self assert: ('A--A--A' copyReplaceAll: 'A' with: '') equals: '----'.
	self assert: ('A--ABC--A' copyReplaceAll: 'ABC' with: 'X') equals: 'A--X--A'.
	self assert: ('AB--ABC--AB' copyReplaceAll: 'ABC' with: 'X') equals: 'AB--X--AB'.
	self assert: ('--A--' copyReplaceAll: '' with: '') equals: '--A--'.
	self assert: ('AAAA-' copyReplaceAll: 'AA' with: 'X') equals: 'XX-'! !

!StringTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLastEmpty
	| result |
	result := self empty copyAfterLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!StringTest methodsFor: 'requirements' stamp: ''!
withEqualElements
	" return a collection  including equal elements (classic equality)"
	^ sameAtEndAndBegining! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
testCopyReplaceAllWithAsTokens

	self assert: ('test te str' copyReplaceAll: 'te' with: 'longone' asTokens: true) equals: 'test longone str'.
	self assert: ('test te str' copyReplaceAll: 'te' with: 'longone' asTokens: false) equals: 'longonest longone str'.
	self assert: ('123 test xyz' copyReplaceAll: 'st' with: 'mper' asTokens: true) equals: '123 test xyz'.
	self assert: ('éèàôüößäóñíá' copyReplaceAll: 'àôüö' with: 'A' asTokens: false) equals: 'éèAßäóñíá'.
	self assert: ('éèàôü éèàôüt éèàôü' copyReplaceAll: ' ' with:  'ß' asTokens: false) equals: 'éèàôüßéèàôütßéèàôü'.! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
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) ]! !

!StringTest methodsFor: 'tests - formatting' stamp: ''!
testExpandMacrosWithArguments
	self assert: ('<1s>' expandMacrosWithArguments: {'str''ing'}) equals: 'str''ing'.
	self assert: ('<1p>' expandMacrosWithArguments: {'str''ing'}) equals: '''str''''ing'''.
	self assert: ('<1p>: <2p>' expandMacrosWith: 'Number' with: 5) equals: '''Number'': 5'! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionWithSameAtEndAndBegining
	"Return a collection with elements at end and begining equals
	 (other elements of the collection are not equal to those elements)"

	^ sameAtEndAndBegining! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testTrimLineSpaces
	self assert: 'test     \do' withCRs trimLineSpaces equals: 'test\do' withCRs.
	self assert: 'test     \  do' withCRs trimLineSpaces equals: 'test\  do' withCRs.
	self assert: 'test \do\' withCRs trimLineSpaces equals: 'test\do' withCRs.
	self assert: 'test \do' withCRs trimLineSpaces equals: 'test\do' withCRs.
	self assert: 'test do' withCRs trimLineSpaces equals: 'test do' withCRs.
	self assert: 'test\ \ ' withCRs trimLineSpaces equals: 'test\\' withCRs.! !

!StringTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!StringTest methodsFor: 'tests - copying' stamp: ''!
testWithoutTrailingNewlines

	self assert: ('123',String cr) withoutTrailingNewlines equals: '123'.
	self assert: ('123',String lf) withoutTrailingNewlines equals: '123'.
	self assert: ('123',String cr, String lf) withoutTrailingNewlines equals: '123'.! !

!StringTest methodsFor: 'tests - line breaking' stamp: ''!
testLinesDoWithCrLfBetween

	| aString |
	aString := '-This is a test-', String crlf, 'of line breaking'.
	aString linesDo: [:line | 
		self assert: line size equals: 16 ]! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindString

	self assert: ('éèàôüößäóñíá' findString: 'ÉÈ') equals: 0.
	self assert: ('éèàôüößäóñíá' findString: 'éè') equals: 1.
	self assert: ('salkjsdlkgfee' findString: 'EE') equals: 0.
	self assert: ('salkjsdlkgfee' findString: 'ee') equals: 12.
	self assert: (' ' findString: '') equals: 0! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!StringTest methodsFor: 'requirements' stamp: ''!
sortedInAscendingOrderCollection
" return a collection sorted in an acsending order"
	^nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindDelimitersStartingAt

	self assert: ('this is a string' findDelimiters: ' ' startingAt: 1) equals: 5.
	self assert: ('this is a string' findDelimiters: 'i' startingAt: 1) equals: 3.
	self assert: ('this is a string' findDelimiters: #($a $e $s) startingAt: 5) equals: 7.
	self assert: ('éèàôüöß éèàôüöß' findDelimiters: 'ß' startingAt: 2) equals: 7! !

!StringTest methodsFor: 'tests - comparing' stamp: ''!
testComparingCaseInsensitiveLatin1

	"ascii-letter"
	self assert: ('e' compare: 'E' caseSensitive: false) equals: 2.
	self assert: ('E' compare: 'e' caseSensitive: false) equals: 2.
	self assert: ('e' compare: 'E' caseSensitive: true) equals: 3.
	self assert: ('E' compare: 'e' caseSensitive: true) equals: 1.
	
	"ascii-number (no difference between number chars and number chars asUppercase "
	self assert: ('1' compare: '1' asUppercase caseSensitive: false) equals: 2.
	self assert: ('1' asUppercase compare: '1' caseSensitive: false) equals: 2.
	self assert: ('1' compare: '1' asUppercase caseSensitive: true) equals: 2.
	self assert: ('1' asUppercase compare: '1' caseSensitive: true) equals: 2.
	
	"non-ascii"
	self assert: ('é' compare: 'É' caseSensitive: false) equals: 2.
	self assert: ('É' compare: 'é' caseSensitive: false) equals: 2.
	self assert: ('é' compare: 'É' caseSensitive: true) equals: 3.
	self assert: ('É' compare: 'é' caseSensitive: true) equals: 1! !

!StringTest methodsFor: 'tests' stamp: ''!
testIsAsciiString
	"Non-regression for https://pharo.manuscript.com/f/cases/15232 "
	
	self assert: '' isAsciiString equals: true.
	self assert: 'abcdefGHIJKL 98765,./@#%$' isAsciiString equals: true.
	self assert: 'éÀ' isAsciiString equals: false! !

!StringTest methodsFor: 'requirements' stamp: ''!
indexInForCollectionWithoutDuplicates
	"Return an index between 'collectionWithoutEqualsElements' bounds"
	
	^ 2! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testAtWrap
	"
	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)! !

!StringTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty.
	result := self nonEmpty forceTo: (self nonEmpty size + 2) paddingWith: element.
	
	"Verify content of 'result'"
	self nonEmpty withIndexDo:
		[:el :index | self assert: el equals: (result at: index) ].
	
	(result size - 1) to: result size do:
		[:i | self assert: (result at:i) equals: element ].

	"Verify size of 'result'"
	self assert: result size equals: self nonEmpty size + 2! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testWithoutLeadingDigits
	#( 
		'foo' 'foo'
		'123foo' 'foo'
		'123 bar7' 'bar7'
		' 123 	bar7' 'bar7'
		'foo.123.txt' 'foo.123.txt'
		'' ''
		'1' ''
		'1 2 3 ' ''
	) pairsDo: [ :input :output |
		self assert: input withoutLeadingDigits equals: output ]! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindBetweenSubstrings
 
	self assert: ('éèà ôüößäó ñíá' findBetweenSubstrings: #(' ')) asArray equals: #('éèà' 'ôüößäó' 'ñíá').
	self assert: ('ieaoftaaka' findBetweenSubstrings: #($a)) asArray equals: #('ie' 'oft' 'k').
	self assert: ('this is an issue is it not' findBetweenSubstrings: #('is' 'not')) asArray 
                                               equals: #('th' ' ' ' an ' 'sue ' ' it ').! !

!StringTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testUncapitalized
	| uc lc empty |
	uc := 'MElViN'.
	lc := 'mElViN'.
	empty := ' '.
	self assert: uc uncapitalized equals: lc.
	self assert: lc uncapitalized equals: lc.
	"the string gets copied"
	self deny: lc uncapitalized identicalTo: lc.
	self deny: empty uncapitalized identicalTo: empty! !

!StringTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLastNElements

	| allButLast collection |
	collection := self moreThan3Elements.
	allButLast := collection allButLast: 2.
	allButLast withIndexDo: [:el :i | self assert: el equals: (collection at: i) ].
	self assert: allButLast size + 2 equals: collection size! !

!StringTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	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)]]! !

!StringTest methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWithEmpty
	
	self deny: (self nonEmpty beginsWith:(self empty)).
	self deny: (self empty beginsWith:(self nonEmpty))! !

!StringTest methodsFor: 'tests - lines' stamp: ''!
testLines
	| sampleCRString sampleLFString sampleCRLFString sampleMixedString sampleMixedString2 |
	sampleCRString := 'Fred', String cr, 'the', String cr, 'Bear'.
	sampleLFString := 'Fred', String lf, 'the', String lf, 'Bear'.
	sampleCRLFString := 'Fred', String crlf, 'the', String crlf, 'Bear'.
	sampleMixedString := 'Fred', String lf, 'the', String cr, 'Bear'.
	sampleMixedString2 := 'Fred', String crlf, 'the', String cr, 'Bear'.
	
	self assert: sampleCRString lines equals: #('Fred' 'the' 'Bear').
	self assert: sampleLFString lines equals: #('Fred' 'the' 'Bear').
	self assert: sampleCRLFString lines equals: #('Fred' 'the' 'Bear').
	self assert: sampleMixedString lines equals: #('Fred' 'the' 'Bear').
	self assert: sampleMixedString2 lines equals: #('Fred' 'the' 'Bear').! !

!StringTest methodsFor: 'tests' stamp: ''!
testEndsWithAnyOf

	self deny: ('éèàôüößäóñíá' endsWithAnyOf: #('ia' 'ñí' '' 'áß')).
	self assert: ('éèàôüößäóñíá' endsWithAnyOf: #('test' 'ÉÈÀ' 'äóñíá')).
	self assert: ('test' endsWithAnyOf: #('tests' 'tester' 'testing' 't')).! !

!StringTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfDuplicate

	| 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) equals: collection size! !

!StringTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpTo

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection   copyUpTo: (collection  at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at:i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!StringTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllPut
 
	self nonEmpty atAll: self indexArray put: self aValue.
	
	self indexArray do:
		[:i | self assert: (self nonEmpty at: i) equals: self aValue ]! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindTokensEscapedBy

	|s|
	s := OrderedCollection withAll: #('éèà' 'üößä' 'íá').
	self assert: ('éèàôüößäóñíá' findTokens: #($ô $ó) escapedBy:'ñí') equals: s.

	s := OrderedCollection withAll: #('ths,').
	self assert: ('this,is' findTokens: ',' escapedBy: 'is' ) equals: s.

	s := OrderedCollection withAll: #('this,is').
	self assert: ('this , is' findTokens: ',' escapedBy: ' ') equals: s.

	s := OrderedCollection withAll: #('ths , s').
	self assert: ('this , is' findTokens: ' ' escapedBy: $i) equals: s! !

!StringTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testWithoutTrailingDigits
	#( 
		'foo' 'foo'
		'foo123' 'foo'
		'bar 123 ' 'bar'
		'foo.123.txt' 'foo.123.txt'
		'' ''
		'1' ''
		'1 2 3 ' ''
	) pairsDo: [ :input :output |
		self assert: input withoutTrailingDigits equals: output ]! !

!StringTest methodsFor: 'tests' stamp: ''!
testCaseSensitiveLessOrEqual

	self assert: ('EEA' caseSensitiveLessOrEqual: 'fgh').
	self deny: ('éèàôüößäóñíá' caseSensitiveLessOrEqual: 'éèàôüöß'). 
	self assert: ('éèàôüößäóñíá' caseSensitiveLessOrEqual: 'éèàôüößäóñíá').
	self assert: ('ÉÈÀÔÜÖ' caseSensitiveLessOrEqual: 'èàôüö').
	self assert: ('eea' caseSensitiveLessOrEqual: 'ÉÈÀ')! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testWithSeparatorsCompacted
	#( 
		'foo' 'foo'
		'foo bar' 'foo bar'
		'' ''
		' ' ' '
		'foo  bar  !!' 'foo bar !!'
		' foo  bar  !! ' ' foo bar !! '
		'  foo  bar  !!  ' ' foo bar !! '
		'		tabs		tabs	!!		' ' tabs tabs !! '
		'space followed by tab 	!!' 'space followed by tab !!'
	) pairsDo: [ :input :output |
		self assert: input withSeparatorsCompacted equals: output ]! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy15

	| tokens |
	string := 'one, "two# three"; &four. five&'.
	tokens := string findTokens: nil escapedBy: '"&'.
	self assert: tokens size equals: 1.
	self assert: tokens first equals: 'one, two# three; four. five'! !

!StringTest methodsFor: 'tests - formatting' stamp: ''!
testExpandMacrosWithArgumentsLongText
	"printString truncates strings"
	self assert: ('<1p>' expandMacrosWith: ('a' repeat: 10)) size equals: 12.
	self assert: ('<1p>' expandMacrosWith: ('a' repeat: 100000)) size equals: 100002! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithReplacementTest
	self replacementCollection.
	self oldSubCollection.
	self collectionWith1TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! !

!StringTest methodsFor: 'tests - comparing' stamp: ''!
testMatch

	#('**' 'f**'  'f**o' 'f*' '*f*' 'f#*' 'f##' '*oo' '#oo' '*o*' '#o#' '#o*' '*o#' 'fo*' 'fo#' '*foo*' '###' '*#'  'f*#' 'f*#o')
		do: [ :each | self assert: (each match: 'foo') ].
	#('bar' 'foo#' '#foo' '*foo#' '#foo*' '*bar*') do: [ :each |
		self deny: (each match: 'foo') ]! !

!StringTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAtIfAbsent
	| absent subcollection collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ].
	self deny: absent.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ].
	self assert: absent! !

!StringTest methodsFor: 'tests - instance creation' stamp: ''!
testLoremIpsum2048
	| fillerText |
	fillerText := String loremIpsum: 2048.
	self assert: fillerText size equals: 2048.
	self assert: (fillerText beginsWith: 'Lorem ipsum').
	self assert: (fillerText includesSubstring: 'laborum.').
	self assert: (fillerText endsWith: ('.', String cr)).
	self assert: fillerText lines size > 2.
	self assert: fillerText isAsciiString.
	self assert: (Character space split: fillerText) size > 75! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testAsSet
 	"Test with a collection without equal elements"
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testRepeat

	self 
	assert: ('123' repeat: 1) equals: '123';
	assert: ('123' repeat: 2) equals: '123123';
	assert: ('123' repeat: 0) equals: '';
	should: [ '123' repeat: -1 ] raise: Error.! !

!StringTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWithEmpty
	
	self deny: (self nonEmpty endsWith: self empty).
	self deny: (self empty endsWith: self nonEmpty)! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testWithNoLineLongerThan

	self assert: ('Hello World' withNoLineLongerThan: 5) equals: ('Hello' , String cr , 'World').

	self assert: ('Sample text to line break at some point' withNoLineLongerThan: 28)
		  equals: ('Sample text to line break at' , String cr , 'some point').
		
	self assert: ('Sample text' , String cr , 'to line break' , String cr , 'at some point' withNoLineLongerThan: 28)
		  equals: ('Sample text' , String cr , 'to line break' , String cr , 'at some point')! !

!StringTest methodsFor: 'tests - line breaking' stamp: ''!
testLinesDoWithCrLf

	| aString |
	aString := 'This is a test of line breaking', String crlf.
	aString linesDo: [ :line |
		self assert: (line size + 2) equals: aString size ]! !

!StringTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''!
testOccurrencesOfForMultipliness

	| collection elem |
	collection := self collectionWithEqualElements.
	elem := self elementTwiceInForOccurrences.

	self assert: (collection occurrencesOf: elem ) equals: 2.! !

!StringTest methodsFor: 'tests - internet' stamp: ''!
testWithInternetLineEndings

	{
		'abc' -> 'abc'.
		'abc', String cr -> ('abc', String crlf).
		'abc', String lf -> ('abc', String crlf).
		'abc', String crlf -> ('abc', String crlf).
		String cr, 'abc' -> (String crlf, 'abc').
		String lf, 'abc' -> (String crlf, 'abc').
		String crlf, 'abc' -> (String crlf, 'abc').
		'abc', String cr, String cr, 'abc' -> ('abc', String crlf, String crlf, 'abc').
		'abc', String lf, String lf, 'abc' -> ('abc', String crlf, String crlf, 'abc').
		'abc', String crlf, String crlf, 'abc' -> ('abc', String crlf, String crlf, 'abc').
		String cr, 'abc', String cr, String crlf, 'abc', String lf -> (String crlf, 'abc', String crlf, String crlf, 'abc', String crlf).
		String lf, 'abc', String lf, String crlf, 'abc', String cr -> (String crlf, 'abc', String crlf, String crlf, 'abc', String crlf).
	} do: [ :each |
		self assert: each key withInternetLineEndings equals: each value ]! !

!StringTest methodsFor: 'requirements' stamp: ''!
integerCollectionWithoutEqualElements
	"Return a collection of integer without equal elements"	
		
	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtWrapPut
	 
	| index |
	index := self indexArray anyOne.
	
	self nonEmpty atWrap: 0 put: self aValue.
	self assert: self nonEmpty last equals: self aValue.
	
	self nonEmpty atWrap: (self nonEmpty size + 1) put: self aValue.
	self assert: self nonEmpty first equals: self aValue.
	
	self nonEmpty atWrap: index put: self aValue.
	self assert: (self nonEmpty at: index) equals: self aValue.
	
	self nonEmpty atWrap: (self nonEmpty size + index) put: self aValue .
	self assert: (self nonEmpty at: index) equals: self aValue.! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionWithElement
	"Returns a collection that already includes what is returned by #element."
	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutIndex

	| result index |	
	index := self indexInNonEmpty.
	result := self nonEmpty copyWithoutIndex: index.
	
	"Verify content of result"
	result withIndexDo: 
		[:element :i | 
		 i <  index ifTrue: [ self assert: element equals: (self nonEmpty at: i) ].
		 i >= index ifTrue: [ self assert: element equals: (self nonEmpty at: (i + 1)) ]].
	
	"Verify size of result"
	self assert: result size equals: (self nonEmpty size - 1)! !

!StringTest methodsFor: 'requirements' stamp: ''!
newElement
	"Return an element that will be put in the collection in place of another"
	
	^ elementInNonEmpty! !

!StringTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceFromToWithStartingAt
	| result repStart collection replacementCollec firstInd secondInd |
	collection := self nonEmpty.
	result := collection copy.
	replacementCollec := self replacementCollectionSameSize.
	firstInd := self firstIndex.
	secondInd := self secondIndex.
	repStart := replacementCollec size - (secondInd - firstInd + 1) + 1.
	result replaceFrom: firstInd to: secondInd with: replacementCollec startingAt: repStart.
	
	"Verify content of 'result'"
	
	"First part of 'result'" 	
	1 to: (firstInd - 1) do: [:i | self assert: (collection at:i) equals: (result at: i) ].
	
	"Middle part containing replacementCollection"	
	firstInd to: (replacementCollec size - repStart +1) do: 
		[:i| self assert: (result at: i) equals: (replacementCollec at: (repStart + (i - firstInd))) ].
	
	"End part"
	(firstInd + replacementCollec size) to: (result size) do:
		[ :i | self assert: (result at: i) equals: (collection at: (secondInd + 1 - (firstInd + replacementCollec size) + i)) ]! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindTokens

	|s |
	s := OrderedCollection withAll: #( 'i' 'd toke' 's').
	self assert: ('find tokens' findTokens: #($a $f $n)) equals: s.

	s := OrderedCollection withAll: #('éèàôüößäóñí').
	self assert: ('éèàôüößäóñíá' findTokens: $á) equals: s.

	s := OrderedCollection withAll: #().
	self assert: ('' findTokens: '') equals: s.

	s := OrderedCollection withAll: #('es' ' ' 'his').
	self assert: ('test this' findTokens: 't') equals: s! !

!StringTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	string := 'Hi, I am a String'.
	emptyString := ''.
	subcollection3ElementsSorted := 'bcd'.
	nonEmpty5ElementsSorted := 'a' , subcollection3ElementsSorted , 'e'.
	unsortedCollection := 'azsbe' copy.
	indexInNonEmptyArray := #(1 3 2 ).
	arrayWithCharacters := #($a $b $c ).
	nonEmpty1element := 'a'.
	withoutEqualElements := 'abcde'.
	
	sameAtEndAndBegining := 'abca'.
	elementInNonEmpty := $c.
	collectionNotIncluded := notIn asString , notIn asString.
	notIn := $z! !

!StringTest methodsFor: 'tests' stamp: ''!
testIncludesSubstringCaseSensitive

	self deny: ('test this string' includesSubstring: 'Ring' caseSensitive: true ). 
	self assert: ('test this string' includesSubstring: 'Ring' caseSensitive: false). 
	self deny: ('123éàôüöß' includesSubstring: '' caseSensitive: false). 
	self assert: ('123éàôüöß' includesSubstring: 'öß' caseSensitive: true).
	self assert: ('123éàôüöß' includesSubstring: 'ÀÔ' caseSensitive: false)! !

!StringTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringMore

	"self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'.
	self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3'"

	| result resultAnd index allElementsAsString |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
 
	index := 1.
	(result findBetweenSubstrings: ',' )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 findBetweenSubstrings: ',' ).
	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 )]
				].
		
		
			].! !

!StringTest methodsFor: 'tests - accessing' stamp: ''!
testAt
	self assert: (string at: 1) equals: $H.! !

!StringTest methodsFor: 'tests' stamp: ''!
testOnlyLetters

	self assert: 'abc98def' onlyLetters equals: 'abcdef'.
	self assert: 'abc 98 12 def' onlyLetters equals: 'abcdef'.
	self assert: '012éà ôüÖ ẞ345' onlyLetters equals: 'éàôüÖẞ'.
	self assert: '123 456' onlyLetters equals: ''.
	self assert: '' onlyLetters equals: ''! !

!StringTest methodsFor: '*ScriptingExtensions-Tests' stamp: ''!
testAsClassIfPresent
	
	'String' asClassIfPresent: [ :class | 
		self assert: class equals: String ].
	
	'+' asClassIfPresent: [ ^ self fail ].! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testLast

	self assert: self moreThan4Elements last equals: (self moreThan4Elements at: self moreThan4Elements size)! !

!StringTest methodsFor: 'tests' stamp: ''!
testStoreOn
	self assert: (String streamContents: [ :s | 'Foo''Bar' storeOn: s ]) equals: '''Foo''''Bar'''! !

!StringTest methodsFor: 'tests - formatting' stamp: ''!
testFormat

	self
		assert: ('This is {1} !!' format: #('a test'))
		equals: 'This is a test !!'.

 	{ 
 		[ '\{ \} \\ foo {1} bar {2}' format: { 12. 'string' } ] -> '{ } \ foo 12 bar string'. 
 		[ '\{ \} \\ foo {2} bar {1}' format: { 'string'. 12 } ] -> '{ } \ foo 12 bar string'. 
 		[ '\{1}' format: {} ] -> '{1}'. 
 		[ '\{1}{1}' format: { $a } ] -> '{1}a'. 
 	} do: [ :each | 
		self assert: each key value equals: each value ]! !

!StringTest methodsFor: 'tests - creation' stamp: ''!
testOfSize
	
	| aCol |
	aCol := self collectionClass ofSize: 3.
	self assert: aCol size equals: 3.! !

!StringTest methodsFor: 'requirements' stamp: ''!
replacementCollection
	"Return a collection that will be used to replace 'oldSubcollection' in ' 	 collectionWith1TimeSubcollection'" 
	^ string! !

!StringTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopyEmpty
	| result |
	result := self empty shallowCopy.
	self assertEmpty: result! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy09

	| tokens |
	string := 'this, is, ###a, test#'.
	tokens := string findTokens: ',' escapedBy: '#'.
	self assert: tokens size equals: 3.
	self assert: tokens third equals: ' #a, test'! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
howMany: aSubCollection in: collection
" return an integer representing how many time 'subCollection'  appears in 'collection'  "
	| tmp nTime |
	tmp := collection.
	nTime:= 0.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				nTime := nTime + 1.
				1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.]
				]
			ifFalse: [tmp := tmp copyWithoutFirst.]
		 ].
	
	^ nTime.! !

!StringTest methodsFor: 'requirements' stamp: ''!
firstCollection
	"Return a collection that will be the first part of the concatenation"
	
	^ nonEmpty5ElementsSorted! !

!StringTest methodsFor: 'requirements' stamp: ''!
unsortedCollection
	^ unsortedCollection! !

!StringTest methodsFor: 'tests' stamp: ''!
testIsLiteralSymbol

	self assert: ('*+-/\~=<>&@%,|' allSatisfy: [:char | (Symbol with: char) isLiteralSymbol])
		description: 'single letter binary symbols can be printed without string quotes'.
		
	self assert: (#('x' 'x:' 'x:y:' 'from:to:by:' 'yourself') allSatisfy: [:str | str asSymbol isLiteralSymbol])
		description: 'valid ascii selector symbols can be printed without string quotes'! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessTest
	| res |
	self collectionMoreThan1NoDuplicates.
	self assert: self collectionMoreThan1NoDuplicates size > 1.
	res := true.
	self collectionMoreThan1NoDuplicates
		detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self elementInForIndexAccessing.
	self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing).
	self elementNotInForIndexAccessing.
	self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! !

!StringTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy05

	| tokens |
	string := 'this, /is, a"," test/'.
	tokens := string findTokens: ',#' escapedBy: '"/'.
	self assert: tokens size equals: 2.
	self assert: tokens first equals: 'this'.
	self assert: tokens second equals: ' is, a"," test'.! !

!StringTest methodsFor: 'tests' stamp: ''!
testIsPatternVariable

	self assert: '`pattern' isPatternVariable.
	self assert: '`pattern:' isPatternVariable.
	self assert: '`pattern:`varible:' isPatternVariable.
	self assert: 'pattern:`varible:' isPatternVariable.
	
	self deny: 'notAPattern:varible:' isPatternVariable.
	self deny: 'notAPattern' isPatternVariable! !

!StringTest methodsFor: 'tests - line breaking' stamp: ''!
testLinesDoWithCrBetween

	| aString |
	aString := ' This is a test ', String cr, 'of line breaking'.
	aString linesDo: [:line |
		self assert: line size equals: 16 ]! !

!StringTest methodsFor: 'tests - copying with replacement' stamp: ''!
firstIndexesOf: aSubCollection in: collection
" return an OrderedCollection with the first indexes of the occurrences of subCollection in  collection "
	| tmp result currentIndex |
	tmp:= collection.
	result:= OrderedCollection new.
	currentIndex := 1.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				result add: currentIndex.
				1 to: aSubCollection size do: 
					[:i | 
					tmp := tmp copyWithoutFirst.
					currentIndex := currentIndex + 1]
				]
			ifFalse: [
				tmp := tmp copyWithoutFirst.
				currentIndex := currentIndex +1.
				]
		 ].
	
	^ result.! !

!StringTest methodsFor: '*ScriptingExtensions-Tests' stamp: ''!
testAsClassIfAbsent

	self 
		assert: ('String' asClassIfAbsent: [ self fail ])
		equals: String.
	
	'+' asClassIfAbsent: [ ^ self "success" ].
	self fail.! !

!StringTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	allElementsAsString withIndexDo: 
		[:el :i | 
		i=1
			ifTrue:[
				self accessCollection class name first isVowel 
					ifTrue:[self assert: el equals: 'an' ]
					ifFalse:[self assert: el equals: 'a'].].
		i=2
			ifTrue:[self assert: el equals: self accessCollection class name].
		i>2
			ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]]! !

!StringTest methodsFor: 'tests - subcollections access' stamp: ''!
testFirstNElements

	| result |
	result := self moreThan3Elements first: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i) ].
	
	self assert: result size equals: (self moreThan3Elements size - 1).
	self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: SubscriptOutOfBounds! !

!StringTest methodsFor: 'tests - testing' stamp: ''!
testEndsWithAColon

	self assert: 'fred:' endsWithAColon.

	self deny: 'fred' endsWithAColon! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy04

	| tokens |
	string := 'this, is, a"," test'.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens size equals: 3.
	self assert: tokens third equals: ' a, test'! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy11

	| tokens |
	string := 'this, is, """a, test"'.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens size equals: 3.
	self assert: tokens third equals: ' "a, test'! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindTokensIncludes

	self assert: ('test this' findTokens: 't' includes: 'his') equals: 'his'.
	self assert: ('test this' findTokens: 's' includes: 'HI') isNil.
	self assert: ('test this' findTokens: 's' includes: 'hi') equals: 't thi'.
	self assert: ('test that' findTokens: 't' includes: 'that') isNil.
	self assert: ('éèàôüößäóñíá' findTokens: #($ô $ó) includes:'ñí') equals: 'ñíá'! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	difference := self collectionWithoutEqualElements difference: self empty.
	self assert: difference size = self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each) ]! !

!StringTest methodsFor: 'requirements' stamp: ''!
elementNotInForElementAccessing
	"Return an element not included in 'moreThan4Elements'"

	^ notIn! !

!StringTest methodsFor: 'tests - converting' stamp: ''!
testSubstrings
	| allByteCharacters substring separators |

	allByteCharacters := Character allByteCharacters asString.
	substring := allByteCharacters select: [:each | each isLetter].
	separators := allByteCharacters reject: [:each | each isLetter].
	{'' -> {}.
		separators -> {}.
		substring -> {substring}.
		(substring, separators) -> {substring}.
		(separators, substring) -> {substring}.
		(separators, substring, separators) -> {substring}.
		(substring, separators, substring) -> {substring. substring}.
		(substring, separators, substring, separators) -> {substring. substring}.
		(separators, substring, separators, substring) -> {substring. substring}}
		do: [:each | self assert: (each key substrings: separators) equals: each value].

	"test the unary version"
	substring := allByteCharacters reject: [:each | each isSeparator].
	separators := allByteCharacters select: [:each | each isSeparator].
	{'' -> {}.
		separators -> {}.
		substring -> {substring}.
		(substring, separators) -> {substring}.
		(separators, substring) -> {substring}.
		(separators, substring, separators) -> {substring}.
		(substring, separators, substring) -> {substring. substring}.
		(substring, separators, substring, separators) -> {substring. substring}.
		(separators, substring, separators, substring) -> {substring. substring}}
		do: [:each | self assert: each key substrings equals: each value].! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDo
	"| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		result add: (value+i)].
	
	1 to: result size do:
		[:i|
		self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]"
	|  indexes elements |
	indexes := OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		indexes  add: (i).
		elements add: value].
	
	(1 to: self nonEmptyMoreThan1Element size )do:
		[ :i |
		self assert: (indexes at: i) equals: i.
		self assert: (elements at: i) equals: (self nonEmptyMoreThan1Element at: i).	
		].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!StringTest methodsFor: 'tests - puting with indexes' stamp: ''!
testFromToPut
	
	| collection index |
	index := self indexArray anyOne.
	collection := self nonEmpty copy.
	collection from: 1 to: index  put: self aValue..
	1 to: index do:
		[:i | self assert: (collection at: i)= self aValue].
	(index +1) to: collection size do:
		[:i | self assert: (collection at:i)= (self nonEmpty at:i)].! !

!StringTest methodsFor: 'tests' stamp: ''!
testAsDate

	self assert: 'Jan 1 2015' asDate asString equals: '1 January 2015'. 
	self assert: '1/1/2015' asDate asString equals: '1 January 2015'.
	self assert: '1 1 1' asDate asString equals: '1 January 2001'.
	self assert: '1 J 1' asDate asString equals: '1 January 2001'.
	self should: [ '' asDate ] raise: Error.
	self should: [ '1234' asDate ] raise: Error! !

!StringTest methodsFor: 'tests' stamp: ''!
testPadLeftTo

	self assert: ('a' padLeftTo: 3) equals: '  a'. 
	self assert: ('a' padLeftTo: 1) equals: 'a'. 
	self assert: ('a' padLeftTo: 0) equals: 'a'! !

!StringTest methodsFor: 'tests' stamp: ''!
testAsPluralBasedOn

	self assert: ('test' asPluralBasedOn: #(1)) equals: 'test'.
	self assert: ('test' asPluralBasedOn: #(1 2 3)) equals: 'tests'.
	self assert: ('test' asPluralBasedOn: 1) equals: 'test'.
	self assert: ('test' asPluralBasedOn: false) equals: 'tests'.
	self assert: ('é è à ô ü ö ß ä ó ñ í á' asPluralBasedOn: 10) equals: 'é è à ô ü ö ß ä ó ñ í ás'.
	self assert: ('' asPluralBasedOn: 1) equals: ''.
	self assert: ('%' asPluralBasedOn: 10) equals: '%s'! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfSequenceableTest
	self collectionWithoutEqualElements.
	self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ].
	self indexInForCollectionWithoutDuplicates.
	self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size.
	self empty.
	self assertEmpty: self empty! !

!StringTest methodsFor: 'tests' stamp: ''!
testAlike

	self assert: ('test' alike: 'test') >= 8.   "twice second argument size is the best score"
	self assert: ('TEST' alike: 'test') >= 8.   "case is ignored"
	self assert: ('é è à ô ü ö ß ä ó ñ í á' alike: 'test') equals: 0. 
	self assert: ('é è à ô ü ö' alike: 'é è à ô ü ö ß ä ó ñ í á') >= 10. 
	self assert: ('eeeee' alike: 'ééééé') <= 1  "evaluation based on ascii value"! !

!StringTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!StringTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result index |
	delim := ', '.
	result := ''.
	multiItemStream := ReadWriteStream on: result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	index:=1.
	(result findBetweenSubstrings: delim)do:
		[:each |
			self assert: each= ((self nonEmpty at:index) asString).
			index:=index+1 ]! !

!StringTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!StringTest methodsFor: 'tests - equality' stamp: ''!
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)! !

!StringTest methodsFor: 'tests - formatting' stamp: ''!
testExpandMacros

	self
		assert: '<t><n><r><l>' expandMacros
		equals:
			(String
				streamContents: [ :stream | 
					stream
						nextPut: Character tab;
						nextPutAll: OSPlatform current lineEnding;
						nextPut: Character cr;
						nextPut: Character lf ])! !

!StringTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContents
	| result |
	result:= self collectionClass streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!StringTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedElementAccessTest

	self moreThan4Elements.
	self assert: self moreThan4Elements size >= 4.
	self subCollectionNotIn.
	self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ].
	self elementNotInForElementAccessing.
	self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing).
	self elementInForElementAccessing.
	self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! !

!StringTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWith
	| result  indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1.
	lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection  size -1.
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: lastIndexOfOldSubcollection   with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'  "
	
	1 to: (indexOfSubcollection  - 1) do: 
		[ 
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i) = (result at: i)
		].
	
	" middle part containing replacementCollection : "
	
	(indexOfSubcollection ) to: ( lastIndexOfReplacementCollection  ) do: 
		[
		:i |
		self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1))
		].
	
	" end part :"
	1 to: (result size - lastIndexOfReplacementCollection   ) do:
		[ 
		:i |
		self assert: (result at: ( lastIndexOfReplacementCollection  + i  ) ) = (self collectionWith1TimeSubcollection  at: ( lastIndexOfOldSubcollection  + i  ) ).
		].! !

!StringTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOfIAbsent
	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) 
	     equals: 1.

	self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) 
		  equals: 55! !

!StringTest methodsFor: 'tests - copying same contents' stamp: ''!
testShuffled
	| result |
	result := self nonEmpty shuffled .
	
	"verify content of 'result: '"
	result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size.! !

!StringTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToEmpty
	| result |
	result := self empty copyUpTo: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!StringTest methodsFor: 'tests - streaming' stamp: ''!
testNewStreamContentsReturnsCollectionOfCorrectSize
	| result item originalSize |
	originalSize := 10.
	item := self firstCollection first.
	result := self collectionClass
		new: originalSize
		streamContents: [ :stream | 
			1 to: originalSize + 1 do: [ :each | stream nextPut: item ].
			stream position: originalSize ].
	self assert: result size equals: originalSize! !

!StringTest methodsFor: 'tests' stamp: ''!
testAsHTMLString

	self assert: '<a>' asHTMLString equals: '&lt;a&gt;'.
	self assert: '<!!DOCTYPE html>' asHTMLString equals: '&lt;!!DOCTYPE html&gt;'. 
	self assert: 'é è à ô ü ö ß ä ó ñ í á' asHTMLString equals: 'é è à ô ü ö ß ä ó ñ í á'.
	self assert: '' asHTMLString equals: ''! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButLastDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButLastDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i ))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element  size-1)! !

!StringTest methodsFor: 'requirements' stamp: ''!
collectionWithEqualElements
	"Return a collecition including atLeast two elements equal"

	^ sameAtEndAndBegining! !

!StringTest methodsFor: 'requirements' stamp: ''!
elementTwiceInForOccurrences
" return an element included exactly two time in # collectionWithEqualElements"
^ sameAtEndAndBegining first .! !

!StringTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollectError

	self should: [ self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindLastOccurrenceOfStringStartingAt

	self assert: ('Smalltalk' findLastOccurrenceOfString: 'al' startingAt: 2) equals: 7.
	self assert: ('aaa' findLastOccurrenceOfString: 'aa' startingAt: 1) equals: 2.
	self assert: ('Smalltalk' asWideString findLastOccurrenceOfString: 'al' startingAt: 2) equals: 7.
	self assert: ('Smalltalk' asWideString findLastOccurrenceOfString: 'al' asWideString startingAt: 2) equals: 7.
	self assert: (('Smalltalk' copyWith: 835 asCharacter) findLastOccurrenceOfString: 'al' asWideString startingAt: 2) equals: 7! !

!StringTest methodsFor: 'tests - element accessing' stamp: ''!
testAtOutOfBounds

	self 
		should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ]
		raise: Error.
	self 
		should: [ self moreThan4Elements at: -1 ]
		raise: Error! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy14

	| tokens |
	string := 'one, "two# three"; &four. five&'.
	tokens := string findTokens: ',#;.' escapedBy: '"&'.
	self assert: tokens size equals: 3.
	self assert: tokens second equals: ' two# three'.
	self assert: tokens third equals: ' four. five'! !

!StringTest methodsFor: 'tests - copy' stamp: ''!
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) ] ]! !

!StringTest methodsFor: 'tests' stamp: ''!
testTranslateToLowercase
	
	self assert: 'test this string' copy translateToLowercase equals: 'test this string'.
	self assert: ' Test THIS sTRing' copy translateToLowercase equals: ' test this string'.
	self assert: '' copy translateToLowercase equals: ''.
	self assert: 'ÔÜÖ' copy translateToLowercase equals: 'ôüö'.
	self assert: '123éàôüÖẞ' copy translateToLowercase equals: '123éàôüöẞ'! !

!StringTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!StringTest methodsFor: 'tests' stamp: ''!
testFindCloseParenthesisFor

	self assert: ('(1 + 3(2 * 9) - 15)' findCloseParenthesisFor: 1) equals: 19.
	self assert: ('(1+(2-3))-3.14159' findCloseParenthesisFor: 1) equals: 9.
	self assert: ('(1+(2-3))-3.14159' findCloseParenthesisFor: 4) equals: 8.
	self assert: ('()' findCloseParenthesisFor: 10) equals: 3! !

!StringTest methodsFor: 'tests' stamp: ''!
testIncludesSubstring

	self assert: ('testing this string' includesSubstring: 'ring'). 
	self assert: ('éèàôüößäóñíá' includesSubstring: '').
	self deny: ('éèàôüößäóñíá' includesSubstring: 'a'). 
	self assert: ('éèàôüößäóñíá' includesSubstring: 'ßä').
	self deny: ('kjdsnlksjdf' includesSubstring: 'K')! !

!StringTest methodsFor: 'tests - tokenizing' stamp: ''!
testFindTokensEscapedBy06

	| tokens |
	string := 'this, is, "a, test'.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens size equals: 3.
	self assert: tokens third equals: ' a, test'! !

!StringTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
 	 'copyUpTo:' should copy until the first occurrence"
	result := collection copyUpTo: element.

	"Verify content"
	self assertEmpty: result! !

!StringTest methodsFor: 'tests - as set tests' stamp: ''!
testAsSetWithEqualsElements
	| result |
	result := self withEqualElements asSet.
	self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = Set! !

!StringTest methodsFor: 'requirements' stamp: ''!
sizeCollection
	"Answers a collection whose #size is 4"
	^ 'abcd'! !

!StringTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |
	delim := ', '.
	result := ''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!StubFixedFont commentStamp: ''!
I am font that provides no real glyphs nor displaying possibilities. I server only as a stub font that provides measurements on texts.!
!StubFixedFont methodsFor: 'accessing' stamp: ''!
lineGrid

	^ 17! !

!StubFixedFont methodsFor: 'displaying' stamp: ''!
displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY
	"Ignore"! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
familySizeFace 

	^ #('Stub Fixed Font' 10 0)! !

!StubFixedFont methodsFor: 'displaying' stamp: ''!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
	"Ignore"! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
maxAscii

	^ SmallInteger maxVal! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
baseFont

	^ baseFont! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
ascent

	^ 13! !

!StubFixedFont methodsFor: 'displaying' stamp: ''!
displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta 
	"Ignore"! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
height

	^ 17! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
descent

	^ 4! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
descentKern

	^ 0! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
emphasized: emph! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
familyName

	^ 'Stub Fixed Font'! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
pointSize

	^ 10! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
fontSize: aNumber 
	"Ignore"! !

!StubFixedFont methodsFor: 'measuring' stamp: ''!
widthOf: aCharacter

	^ 5.4! !

!StubFixedFont methodsFor: 'accessing' stamp: ''!
baseFont: aFont

	baseFont := aFont! !

!StyleChunk commentStamp: ''!
I'm the declaration of a style stuff into a file.  I'm not really used, but I'm here to make parsing an homogeneous process and backwards compatibility.

Sending me the #import message does nothing :).!
!StyleChunk methodsFor: 'importing' stamp: ''!
importFor: aRequestor logSource: logSource
	"Nothing to do with style declarations"! !

!StyleChunk methodsFor: 'accessing' stamp: ''!
description

	^ 'Style'! !

!StyleChunk methodsFor: 'visiting' stamp: ''!
accept: aVisitor

	^ aVisitor visitStyleChunk: self! !

!SubclassPoolUser commentStamp: ''!
I should be able to access the pool variables defined in my superclass.!
!SubclassResponsibility commentStamp: ''!
I am SubclassResponsibility, an exception signaled when an inherited method should have been implemented in a subclass but was not.!
!SubclassResponsibility methodsFor: 'printing' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		stream print: self signaler class.
		stream << ' had the subclass responsibility to implement '.
		stream print: self selector ]! !

!SubclassResponsibilityDebugAction commentStamp: ''!
A SubclassResponsabilityDebugAction is a debugging action that can create a method if the debugger was opened as a result of a #subclassResponsibility mesage send.

!
!SubclassResponsibilityDebugAction methodsFor: 'private' stamp: ''!
askForSuperclassOf: aClass to: aSuperclass toImplement: aSelector ifCancel: cancelBlock
	| classes currentSuperclass chosenClassIndex |
	
	classes := OrderedCollection new.
	classes add: aClass.
	currentSuperclass := aClass superclass.
	[ currentSuperclass == nil or: [ currentSuperclass == aSuperclass ] ]
		whileFalse: [
			classes add: currentSuperclass.
			currentSuperclass := currentSuperclass superclass ].
	classes := classes addAll: (aClass traits sort: [ :t1 :t2 | t1 asString < t2 asString ]); yourself.
	
	classes size = 1 ifTrue: [ ^ classes at: 1 ].
	chosenClassIndex := UIManager default 
		chooseFrom: (classes collect: [:c | c name])
		title: 'Define #', aSelector, ' in which class?'.
	chosenClassIndex = 0 ifTrue: [^ cancelBlock value].
	^ classes at: chosenClassIndex! !

!SubclassResponsibilityDebugAction methodsFor: 'testing' stamp: ''!
appliesToDebugger: aDebugger
	| interruptedContext |
	
	interruptedContext := aDebugger session interruptedContext.
	^ (interruptedContext selector == #subclassResponsibility) and: [ 
		"If we work with an instance of the abstract class (shouldn't normally happen) do not add this action, 
		as the abstract class alredy contains the the method."
		interruptedContext sender receiver class ~~ interruptedContext sender methodClass  ]! !

!SubclassResponsibilityDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 1! !

!SubclassResponsibilityDebugAction methodsFor: 'actions' stamp: ''!
executeAction
	| senderContext msg msgCategory chosenClass |
	
	senderContext := self interruptedContext sender.
	msg := Message 
		selector: senderContext selector
		arguments: senderContext arguments.
	msgCategory := senderContext methodClass organization categoryOfElement: msg selector.
	
	chosenClass := self 
		askForSuperclassOf: senderContext receiver class 
		to: senderContext methodClass 
		toImplement: senderContext selector 
		ifCancel: [ ^ self ].

	self session 
		implement: msg 
		classified: msgCategory 
		inClass: chosenClass 
		forContext: senderContext.! !

!SubclassResponsibilityDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Create a method in a class having the responsibility to implement it.'! !

!SubclassResponsibilityDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #subclassResponsibility! !

!SubclassResponsibilityDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^  'Create'! !

!SubclassResponsibilityDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<debuggingAction>! !

!SubclassWithOverridenAnnotation class methodsFor: 'annotations' stamp: ''!
annotationExample
	<classAnnotation>
	
	^ClassAnnotationExample2 new! !

!SubscriptOutOfBounds commentStamp: ''!
I am SubscriptOutOfBounds, an exception indicating that some operation attempted to use a subscript outside allowed bounds.

Normally, I hold the offending subscript and/or the allowed lowerBound and upperBound (inclusive).

SubscriptOutOfBounds 
	signalFor: 10 
	lowerBound: 1 
	upperBound: 5 
	in: (Array new: 5)!
!SubscriptOutOfBounds methodsFor: 'accessing' stamp: ''!
lowerBound
	^ lowerBound! !

!SubscriptOutOfBounds methodsFor: 'accessing' stamp: ''!
upperBound: anObject
	upperBound := anObject! !

!SubscriptOutOfBounds methodsFor: 'accessing' stamp: ''!
subscript
	^ subscript! !

!SubscriptOutOfBounds methodsFor: 'printing' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		self subscript 
			ifNil: [
				stream << 'subscript' ]
			ifNotNil: [ 
				stream print: self subscript ].
		(self lowerBound notNil and: [ self upperBound notNil])
			ifTrue: [
				stream << ' is not between '.
				stream print: self lowerBound.
				stream << ' and '.
				stream print: self upperBound ] ]! !

!SubscriptOutOfBounds methodsFor: 'accessing' stamp: ''!
upperBound
	^ upperBound! !

!SubscriptOutOfBounds methodsFor: 'accessing' stamp: ''!
lowerBound: anObject
	lowerBound := anObject! !

!SubscriptOutOfBounds methodsFor: 'accessing' stamp: ''!
subscript: anObject
	subscript := anObject! !

!SubscriptOutOfBounds methodsFor: 'accessing' stamp: ''!
messageText
	"Overwritten to initialiaze the message text to a standard text if it has not yet been set"
	
	^ messageText ifNil: [ messageText := self standardMessageText ]! !

!SubscriptOutOfBounds class methodsFor: 'signaling' stamp: ''!
signalFor: subscript
	^ self 
		signalFor: subscript 
		lowerBound: nil 
		upperBound: nil! !

!SubscriptOutOfBounds class methodsFor: 'signaling' stamp: ''!
signalFor: subscript lowerBound: lowerBound upperBound: upperBound in: object
	^ self new
		signaler: object;
		subscript: subscript;
		lowerBound: lowerBound;
		upperBound: upperBound;
		signal! !

!SubscriptOutOfBounds class methodsFor: 'signaling' stamp: ''!
signalFor: subscript lowerBound: lowerBound upperBound: upperBound
	^ self 
		signalFor: subscript 
		lowerBound: lowerBound 
		upperBound: upperBound 
		in: nil! !

!SubscriptionRegistry commentStamp: ''!
The subscription registry is a threadsafe storage for the subscriptions to an Announcer.

In Pharo, subscriptionsFor: protocol is not implemented.
This is because Announcer does not provide public access to its registery for encapsulation reasons.
(We do not want access to the announcer from action blocks to break encapsulation to other subscribers)!
!SubscriptionRegistry methodsFor: 'announcing' stamp: ''!
deliver: anAnnouncement
	|  interestedSubscriptions |
	"using a copy, so subscribers can unsubscribe from announcer "
	
	subscriptions isEmpty ifTrue: [ ^ self ].
	self protected: [ 
		interestedSubscriptions := self subscriptionsHandling: anAnnouncement ].
	interestedSubscriptions isEmpty ifTrue: [ ^self ].
	
	anAnnouncement prepareForDelivery.
	self deliver: anAnnouncement to: interestedSubscriptions! !

!SubscriptionRegistry methodsFor: 'add/remove' stamp: ''!
add: subscription
	^ self protected: [
		subscriptions add: subscription  ]! !

!SubscriptionRegistry methodsFor: 'private' stamp: ''!
deliver: anAnnouncement to: subs
	^ self deliver: anAnnouncement to: subs startingAt: 1! !

!SubscriptionRegistry methodsFor: 'initialization' stamp: ''!
initialize
	monitor := Semaphore forMutualExclusion.
	self reset! !

!SubscriptionRegistry methodsFor: 'accessing' stamp: ''!
subscriptionsForClass: subscriberClass
	"Return the list of subscription for a given class"
	^ Array streamContents: [ :s|
			subscriptions do: [:each| 
				(each subscriber class == subscriberClass 
				 or: [each subscriber class includesBehavior: subscriberClass])
					ifTrue: [ s nextPut: each subscriber ]]]! !

!SubscriptionRegistry methodsFor: 'add/remove' stamp: ''!
removeSubscriber: subscriber
	
	^ self protected: [
		subscriptions removeAllSuchThat: [:subscription | subscription subscriber == subscriber ]]! !

!SubscriptionRegistry methodsFor: '*Roassal3' stamp: ''!
handleEventClass: eventClass
	"Return true if the receiver has a callback subscripbed for the event class"
	^ subscriptions
		anySatisfy: [ :sub | sub announcementClass includesBehavior: eventClass ]! !

!SubscriptionRegistry methodsFor: 'accessing' stamp: ''!
numberOfSubscriptions
	^ subscriptions size! !

!SubscriptionRegistry methodsFor: 'iterating' stamp: ''!
subscriptionsOf: aSubscriber do: aBlock
	| copy |
	
	self protected: [ copy := subscriptions copy ].
	
	copy do: 
		[:subscription | 
			subscription subscriber == aSubscriber 
				ifTrue: [ aBlock value: subscription ]	]! !

!SubscriptionRegistry methodsFor: 'add/remove' stamp: ''!
replace: subscription with: newOne

	" Note that it will signal an error if subscription is not there "
	self protected: [
		subscriptions remove: subscription.
		subscriptions add: newOne 
	].
	^ newOne! !

!SubscriptionRegistry methodsFor: '*Roassal3' stamp: ''!
getInteractionsForClass: eventClass
	"Return the list of subscription for a given Event class"
	| answer |
	answer := OrderedCollection new.
	subscriptions do: [ :sub | 
		((sub subscriber class == eventClass) or: 
			[ sub subscriber class inheritsFrom: eventClass ]) ifTrue: [ answer add: sub subscriber ] ].
	^ answer! !

!SubscriptionRegistry methodsFor: 'add/remove' stamp: ''!
remove: subscription
	^ self protected: [
		subscriptions remove: subscription ifAbsent: nil ]! !

!SubscriptionRegistry methodsFor: 'private' stamp: ''!
deliver: anAnnouncement to: subs startingAt: startIndex
	
	startIndex to: subs size do: [ :index| | subscription |
		subscription := subs at: index.
		[ subscription deliver: anAnnouncement ] 
			"Ensure delivery to remaining announcements"
			ifCurtailed: [
				self deliver: anAnnouncement to: subs startingAt: index + 1 ]]! !

!SubscriptionRegistry methodsFor: 'testing' stamp: ''!
handleSubscriberClass: eventClass
	"Return true if the receiver has a callback subscripbed for the event class"
	^ subscriptions anySatisfy: [ :sub | 
		(sub subscriber class == eventClass) or: 
			[ sub subscriber class includesBehavior: eventClass ] ]! !

!SubscriptionRegistry methodsFor: 'private' stamp: ''!
protected: aBlock
	^ monitor critical: [ aBlock value ]! !

!SubscriptionRegistry methodsFor: 'accessing' stamp: ''!
subscriptions
	^ subscriptions! !

!SubscriptionRegistry methodsFor: 'initialization' stamp: ''!
reset
	"subscriber -> subscriptions"
	
	subscriptions := IdentitySet new! !

!SubscriptionRegistry methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionSubscriptions
	<inspectorPresentationOrder: 0 title: 'Subscriptions'>

	^ SpTablePresenter new
		items: self subscriptions asOrderedCollection;
		addColumn: (SpStringTableColumn title: 'Class' evaluated: [ :each | each announcementClass ]);
		addColumn: (SpStringTableColumn title: 'Subscriber' evaluated: [ :each | each subscriber ]);
		yourself! !

!SubscriptionRegistry methodsFor: 'accessing' stamp: ''!
subscriptionsHandling: anAnnouncement
	^ Array streamContents: [ :s|
			subscriptions do: [:each| 
				(each handlesAnnouncement: anAnnouncement)
					ifTrue: [ s nextPut: each ]]]! !

!SuperClassUsedInInstructionStreamTest methodsFor: 'examples' stamp: ''!
aSuperMethod: anInteger with: anotherInteger

	^ 42! !

!SuperVariable commentStamp: ''!
I model "super" keyword!
!SuperVariable methodsFor: 'testing' stamp: ''!
isSuperVariable
	^true! !

!SuperVariable methodsFor: 'emitting' stamp: ''!
emitValue: methodBuilder
	"super references the receiver, send that follows is a super send (the message lookup starts in the superclass)"
	methodBuilder pushReceiver! !

!SuperVariable methodsFor: 'debugging' stamp: ''!
readInContext: aContext
	^aContext receiver! !

!SuperVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitSuperNode: aNode! !

!SuperVariable methodsFor: 'queries' stamp: ''!
usingMethods
	"as super is just a push Self, this detects real super sends, not accesses to super which 
	should never happen"
	^ environment allMethods select: [ :method | 
		  method sendsToSuper ]! !

!SuperVariable class methodsFor: 'accessing' stamp: ''!
variableName
	^'super'! !

!SupplyAnswerTest commentStamp: ''!
A test for supplying answer !
!SupplyAnswerTest methodsFor: 'tests' stamp: ''!
testChooseDirectory
	| tmpDirectory answer |
	tmpDirectory := FileSystem / 'tmp'.

	answer := [ MorphicUIManager new chooseDirectory ] valueSupplyingAnswer: {'Choose Directory' . tmpDirectory}.

	self assert: answer equals: tmpDirectory! !

!SupplyAnswerTest methodsFor: 'tests' stamp: ''!
testFillInTheBlank
	| answer |
	answer := [ MorphicUIManager new request: 'Your favorite color?' ] valueSupplyingAnswer: #('Your favorite color?' 'blue').

	self assert: answer equals: 'blue'! !

!SupplyAnswerTest methodsFor: 'tests' stamp: ''!
testInform
	| answer |
	[ MorphicUIManager new inform: 'blah' ]
		on: Exception
		do: [ :ex | answer := ex messageText ].
	self assert: answer equals: 'blah'! !

!SycAbstractAllInstVarAccessorsCommand commentStamp: ''!
I command to launch the Abstract refactorings: create accessors and abstract the direct instance variable uses into accessors. !
!SycAbstractAllInstVarAccessorsCommand methodsFor: 'accessing' stamp: ''!
asRefactorings
	| refactorings env |
	refactorings := classes flatCollect: [:each |
		each value collect: [:var | | refactoring |
			env ifNil: [ refactoring := var createRefactoring: RBAbstractInstanceVariableRefactoring for: each key.
				env := refactoring model ]
				ifNotNil: [refactoring := var createRefactoring: RBAbstractInstanceVariableRefactoring for: each key in: env ].
			refactoring ]].
	^ refactorings! !

!SycAbstractAllInstVarAccessorsCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring 
	^ true! !

!SycAbstractAllInstVarAccessorsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Abstract instance variables'! !

!SycAbstractAllInstVarAccessorsCommand methodsFor: 'execution' stamp: ''!
selectVariables 
	classes := classes collect: [:aClass | | vars dialog |
		vars := aClass slots asOrderedCollection.
		dialog := RBVariablesSelectionPresenter 
		   label: aClass name,' - Select all variables to convert abstract'
			withItems: vars 
			selecting: vars. 
		dialog cancelled ifTrue: [ CmdCommandAborted signal ].
		aClass -> dialog presenter selectedItems
		]! !

!SycAbstractAllInstVarAccessorsCommand methodsFor: 'testing' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	classes := classes collect: [:each | aToolContext currentMetaLevelOf: each].
	self selectVariables.! !

!SycAbstractAllInstVarAccessorsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallAdd! !

!SycAbstractAllInstVarAccessorsCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
browserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation  by: $a meta, $a meta for: ClyClass asCalypsoItemContext! !

!SycAbstractAllInstVarAccessorsCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 2.1 for: ClyFullBrowserClassContext! !

!SycAddClassesScopeCommand commentStamp: ''!
I am a command to add classes scope to listScopes!
!SycAddClassesScopeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Add class(es) to scope list'! !

!SycAddClassesScopeCommand methodsFor: 'execution' stamp: ''!
execute
	| scope |
	scope := RBBrowserEnvironment new forClasses: classes.
	RefactoringSettings addScope: scope! !

!SycAddClassesScopeCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext! !

!SycAddClassesScopeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^ #add! !

!SycAddClassesScopeCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
browserContextMenuActivation
	<classAnnotation>

	^ CmdContextMenuActivation byRootGroupItemOrder: 1.5 for: ClyClass asCalypsoItemContext! !

!SycAddHierarchyScopeCommand commentStamp: ''!
I am a command to add class hierarchy scope to listScopes!
!SycAddHierarchyScopeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Add hierarchy to scope list'! !

!SycAddHierarchyScopeCommand methodsFor: 'execution' stamp: ''!
execute
	| scope |
	scope :=  RBBrowserEnvironment new forClassHierarchy: targetClass.
	RefactoringSettings addScope: scope! !

!SycAddHierarchyScopeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^ #add! !

!SycAddHierarchyScopeCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>

	^ SycSourceCodeMenuActivation byRootGroupItemOrder: 1.2 for: ClySourceCodeContext! !

!SycAddHierarchyScopeCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
browserContextMenuActivation
	<classAnnotation>

	^ CmdContextMenuActivation byRootGroupItemOrder: 1.5 for: ClyClass asCalypsoItemContext! !

!SycAddMessageArgumentCommand commentStamp: ''!
I am a command to add new argument into the message.

Internal Representation and Key Implementation Points.

    Instance Variables
	argumentDefaultValue:		<Object>
	newSelector:		<Symbol>!
!SycAddMessageArgumentCommand methodsFor: 'requesting' stamp: ''!
canRemoveArgs 
	^ false! !

!SycAddMessageArgumentCommand methodsFor: 'accessing' stamp: ''!
newSelector
	^ newSelector! !

!SycAddMessageArgumentCommand methodsFor: 'accessing' stamp: ''!
newSelector: anObject
	newSelector := anObject! !

!SycAddMessageArgumentCommand methodsFor: 'testing' stamp: ''!
canEditName
	^ false! !

!SycAddMessageArgumentCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Add argument'! !

!SycAddMessageArgumentCommand methodsFor: 'execution' stamp: ''!
createRefactoring

	^(RBAddParameterRefactoring
		model: model
		addParameterToMethod: originalMessage selector
		in: (SycMessageOriginHack of: originalMessage) "look at SycMessageOriginHack comment"
		newSelector: newSelector selector
		permutation: newSelector permutation
		newArgs: newSelector newArgs)
		renameMap: newSelector renameMap! !

!SycAddMessageArgumentCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	newSelector := self requestNewMessageIn: aToolContext.! !

!SycAddMessageArgumentCommand methodsFor: 'execution' stamp: ''!
resultMessageSelector
	^newSelector! !

!SycAddMessageArgumentCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallAdd
! !

!SycAddMessageArgumentCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation
		byRootGroupItemOrder: 30 for: ClyMethod asCalypsoItemContext! !

!SycAddMessageArgumentCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext

	"This method overrides the superclass definition to make appear this option only for methods.

	Using the refactor from the method selection panel works fine.
	Otherwise createValidNameArgument creates an argument name that is not already in use (for example: if anObject is used then it return anObject1).
	However when we ask this refactoring from a message we don't know the method and cannot do those checks. (If there is only one)"
	^aToolContext isMethodSelected! !

!SycAddNewClassTagCommand commentStamp: ''!
I am a command to add new class tag into the package.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	package:		<RPackage>
	tagName:		<String>
!
!SycAddNewClassTagCommand methodsFor: 'accessing' stamp: ''!
tagName
	^ tagName! !

!SycAddNewClassTagCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	aToolContext showPackage: package atClassTag: tagName! !

!SycAddNewClassTagCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'New tag'! !

!SycAddNewClassTagCommand methodsFor: 'execution' stamp: ''!
execute
	
	package addClassTag: tagName! !

!SycAddNewClassTagCommand methodsFor: 'accessing' stamp: ''!
tagName: anObject
	tagName := anObject! !

!SycAddNewClassTagCommand methodsFor: 'accessing' stamp: ''!
package: anObject
	package := anObject! !

!SycAddNewClassTagCommand methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!SycAddNewClassTagCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#add! !

!SycAddNewClassTagCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	package := aToolContext lastSelectedPackage.
	
	tagName := UIManager default 
		request: ('New class tag in ' , package name) 
		initialAnswer: '' 
		title: 'Create a new class tag'.
	tagName isEmptyOrNil ifTrue: [ CmdCommandAborted signal ]! !

!SycAddNewClassTagCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserPackageMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: ClyFullBrowserPackageContext! !

!SycAddNewClassTagCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserClassGroupMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: ClyFullBrowserClassGroupContext! !

!SycAddNewClassTagCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isPackageSelected! !

!SycAddNewMethodTagCommand commentStamp: ''!
I am a command to add new method tag (protocol) top the class 

Internal Representation and Key Implementation Points.

    Instance Variables
	tagName:		<String>
	targetClass:		<Class>!
!SycAddNewMethodTagCommand methodsFor: 'accessing' stamp: ''!
tagName
	^ tagName! !

!SycAddNewMethodTagCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	aToolContext showMethodTag: tagName! !

!SycAddNewMethodTagCommand methodsFor: 'accessing' stamp: ''!
targetClass: anObject
	targetClass := anObject! !

!SycAddNewMethodTagCommand methodsFor: 'execution' stamp: ''!
requestClassInContext: aToolContext
	| classes |
	classes := aToolContext selectedClasses.
	classes size = 1 ifTrue: [ ^classes first ].
	
	^aToolContext  
		requestSingleClass: 'In what class you want a protocol?' 
		from: classes! !

!SycAddNewMethodTagCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'New protocol'! !

!SycAddNewMethodTagCommand methodsFor: 'execution' stamp: ''!
execute
	
	targetClass addMethodTag: tagName asSymbol! !

!SycAddNewMethodTagCommand methodsFor: 'accessing' stamp: ''!
targetClass
	^ targetClass! !

!SycAddNewMethodTagCommand methodsFor: 'accessing' stamp: ''!
tagName: anObject
	tagName := anObject! !

!SycAddNewMethodTagCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	tagName := aToolContext requestSingleMethodTag: 'New protocol name'.
	
	targetClass := self requestClassInContext: aToolContext.
	targetClass := aToolContext currentMetaLevelOf: targetClass! !

!SycAddNewMethodTagCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#add! !

!SycAddNewMethodTagCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 2 for: ClyFullBrowserMethodGroupContext! !

!SycAddNewPackageCommand commentStamp: ''!
I am a command to add new package into the system.

I should be created on particular system environment which allow create packages:

 	resultPackage := systemEnvironment createPackageNamed: packageName
	
Currently only Calypso provide such compatible environment (ClySystemEnvironment)	
 
Internal Representation and Key Implementation Points.

    Instance Variables
	packageName:		<String>
	resultPackage:		<RPackage>
	systemEnvironment:		<Object>!
!SycAddNewPackageCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	aToolContext showPackage: resultPackage! !

!SycAddNewPackageCommand methodsFor: 'accessing' stamp: ''!
resultPackage
	^ resultPackage! !

!SycAddNewPackageCommand methodsFor: 'accessing' stamp: ''!
packageName: anObject
	packageName := anObject! !

!SycAddNewPackageCommand methodsFor: 'accessing' stamp: ''!
resultPackage: anObject
	resultPackage := anObject! !

!SycAddNewPackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'New package'! !

!SycAddNewPackageCommand methodsFor: 'execution' stamp: ''!
execute

	resultPackage := systemEnvironment createPackageNamed: packageName! !

!SycAddNewPackageCommand methodsFor: 'accessing' stamp: ''!
packageName
	^ packageName! !

!SycAddNewPackageCommand methodsFor: 'accessing' stamp: ''!
systemEnvironment
	^ systemEnvironment! !

!SycAddNewPackageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
		
	systemEnvironment := aToolContext systemEnvironment.		
	packageName := ''.
	aToolContext isPackageSelected ifTrue: [ 
		packageName := aToolContext lastSelectedPackage name].
	
	packageName := UIManager default 
		request: 'Name of the new package:' initialAnswer: packageName title: 'Create a new package'.
	packageName isEmptyOrNil ifTrue: [ ^CmdCommandAborted signal]! !

!SycAddNewPackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#add! !

!SycAddNewPackageCommand methodsFor: 'accessing' stamp: ''!
systemEnvironment: anObject
	systemEnvironment := anObject! !

!SycAddNewPackageCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: ClyFullBrowserPackageContext! !

!SycAddNewPackageCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $k meta, $p meta for: ClyFullBrowserGlobalContext! !

!SycAddPackagesScopeCommand commentStamp: ''!
I am a command to add packages scope to listScopes!
!SycAddPackagesScopeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Add to scope list'! !

!SycAddPackagesScopeCommand methodsFor: 'execution' stamp: ''!
execute
	| scope |
	scope := RBBrowserEnvironment new forPackages: packages.
	RefactoringSettings addScope: scope! !

!SycAddPackagesScopeCommand methodsFor: 'accessing' stamp: ''!
packages

	^ packages! !

!SycAddPackagesScopeCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aBrowserContext

	super prepareFullExecutionInContext: aBrowserContext.
	packages := aBrowserContext selectedPackageItems collect: [:e | e actualObject ].! !

!SycAddPackagesScopeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^ #add! !

!SycAddPackagesScopeCommand methodsFor: 'accessing' stamp: ''!
packages: anObject

	packages := anObject! !

!SycAddPackagesScopeCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>

	^ CmdContextMenuActivation byRootGroupItemFor: ClyFullBrowserPackageContext! !

!SycAddProtocolScopeCommand commentStamp: ''!
I am a command to add protocol scope to listScopes!
!SycAddProtocolScopeCommand methodsFor: 'execution' stamp: ''!
prepareFullExecution
	super prepareFullExecution.
	class := context lastSelectedClass.! !

!SycAddProtocolScopeCommand methodsFor: 'execution' stamp: ''!
execute
	| scope protocols |
	self prepareFullExecution.
	protocols := methodGroups select: [:each | each isKindOf: ClyTaggedMethodGroup] 
		thenCollect: [ :each | each tag].
	scope := RBBrowserEnvironment new forClass: class protocols: protocols.
	RefactoringSettings addScope: scope! !

!SycAddProtocolScopeCommand methodsFor: 'accessing' stamp: ''!
name
	^ 'Add protocols to scope list'! !

!SycAddProtocolScopeCommand methodsFor: 'accessing' stamp: ''!
icon 
	^ self iconNamed: #add! !

!SycBrowseClassCommand commentStamp: ''!
I am a command to open browser on given class!
!SycBrowseClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Browse'! !

!SycBrowseClassCommand methodsFor: 'execution' stamp: ''!
execute
	targetClass browse! !

!SycBrowseClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#glamorousBrowse! !

!SycBrowseClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byItemOf: ClyQueryMenuGroup for: ClySourceCodeContext! !

!SycBrowseVariableCommand commentStamp: ''!
I am a command to browse given variable.
For instance or class variable I just open browser on defining class.
For global variable I open browser of class of variable value!
!SycBrowseVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Browse'! !

!SycBrowseVariableCommand methodsFor: 'execution' stamp: ''!
execute

	variables last openBrowser! !

!SycBrowseVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#glamorousBrowse! !

!SycBrowseVariableCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byItemOf: ClyQueryMenuGroup for: ClySourceCodeContext! !

!SycCMakeAbstractCommand commentStamp: ''!
I am a command to make a class abstract by adding a method that returns whether the class is abstract!
!SycCMakeAbstractCommand methodsFor: 'testing' stamp: ''!
order
	^ 40! !

!SycCMakeAbstractCommand methodsFor: 'executing' stamp: ''!
executeRefactoring

	| transformation |
	transformation := (RBAddMethodTransformation
		                   sourceCode: 'isAbstract
		
	^ self == ' , targetClass asString
		                   in: targetClass classSide
		                   withProtocols: #( #testing )) execute! !

!SycCMakeAbstractCommand methodsFor: 'accessing' stamp: ''!
isApplicable 

	^ context lastSelectedClass isAbstract not! !

!SycCMakeAbstractCommand methodsFor: 'testing' stamp: ''!
name
	^ 'Make Abstract'! !

!SycCMakeAbstractCommand methodsFor: 'accessing' stamp: ''!
icon

	^ self iconNamed: #smallLoadProject! !

!SycCategorizeAllUnclassifiedMethodsCommand commentStamp: ''!
I am a command to categorize all unclassified methods of given classes!
!SycCategorizeAllUnclassifiedMethodsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Categorize all uncategorized'! !

!SycCategorizeAllUnclassifiedMethodsCommand methodsFor: 'execution' stamp: ''!
execute
	| classifier |
	"MethodClassifier should not be hardcoded and should be based on Smalltalk tools"
	classifier := MethodClassifier new.
	
	classes do: [ :each | 
		each uncategorizedSelectors do: [ :selector| 
			classifier classify: each >> selector ]]! !

!SycCategorizeAllUnclassifiedMethodsCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext

	super prepareFullExecutionInContext: aToolContext.
	classes := classes collect: [:each | aToolContext currentMetaLevelOf: each]! !

!SycCategorizeAllUnclassifiedMethodsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#glamorousBrowse! !

!SycCategorizeAllUnclassifiedMethodsCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 10000 for: ClyFullBrowserMethodGroupContext! !

!SycChangeMessageSignatureCommand commentStamp: ''!
I am a base class for commands which modify signature of given message.

My subclasse should implement two methods: 

- createRefactoring 
It should return refactoring instance which will perform actual change.

- resultMessageSelector 
it should return target selector of the message after modification.

Internal Representation and Key Implementation Points.

    Instance Variables
	originalMessage:		<ClyMessageDescription>!
!SycChangeMessageSignatureCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.

	aToolContext showMessage: originalMessage renamedTo: self resultMessageSelector asSymbol! !

!SycChangeMessageSignatureCommand methodsFor: 'requesting' stamp: ''!
canRemoveArgs
	^ true! !

!SycChangeMessageSignatureCommand methodsFor: 'execution' stamp: ''!
asRefactorings
	^{self createRefactoring}! !

!SycChangeMessageSignatureCommand methodsFor: 'initialization' stamp: ''!
initializeDefaultOptionsOf: refactoring

	NautilusRefactoring new refactoringOptions: refactoring! !

!SycChangeMessageSignatureCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	^true! !

!SycChangeMessageSignatureCommand methodsFor: 'accessing' stamp: ''!
originalMessage: anObject
	originalMessage := anObject! !

!SycChangeMessageSignatureCommand methodsFor: 'requesting' stamp: ''!
canAddArgs
	^ true! !

!SycChangeMessageSignatureCommand methodsFor: 'testing' stamp: ''!
canEditName
	^ true! !

!SycChangeMessageSignatureCommand methodsFor: 'execution' stamp: ''!
execute
	
	self executeRefactorings! !

!SycChangeMessageSignatureCommand methodsFor: 'requesting' stamp: ''!
canRenameArgs
	^ true! !

!SycChangeMessageSignatureCommand methodsFor: 'initialization' stamp: ''!
setUpModelFromContext: aContext
	| browser scope |
	browser := aContext browser.
	scope := browser defaultNavigationScope.
	scope isCurrentImage ifTrue: [ scope := RefactoringSettings scopeRefactoring ].
	model := RBClassModelFactory rbNamespace onEnvironment: scope asRBEnvironment! !

!SycChangeMessageSignatureCommand methodsFor: 'execution' stamp: ''!
createRefactoring
	self subclassResponsibility! !

!SycChangeMessageSignatureCommand methodsFor: 'actions' stamp: ''!
computeInvalidArgNamesForSelector: aSymbol
	| invalidArgNames |
	invalidArgNames := Set new.
	(model allImplementorsOf: aSymbol) do: [ :e | | cm | 
		cm:=(e realClass >> aSymbol).
		invalidArgNames addAll: cm argumentNames;
			addAll: cm origin instVarNames ].
	^ invalidArgNames! !

!SycChangeMessageSignatureCommand methodsFor: 'accessing' stamp: ''!
originalMessage
	^ originalMessage! !

!SycChangeMessageSignatureCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	self setUpModelFromContext: aToolContext.
	originalMessage := aToolContext lastSelectedMessage! !

!SycChangeMessageSignatureCommand methodsFor: 'requesting' stamp: ''!
requestNewMessageIn: aToolContext
	| methodName dialog invalidArgNames |
	invalidArgNames := self computeInvalidArgNamesForSelector: originalMessage selector.
	methodName := RBMethodName selector: originalMessage selector arguments: originalMessage argumentNames.
	dialog := SycMethodNameEditorPresenter openOn: methodName withInvalidArgs: invalidArgNames
		canRenameArgs: self canRenameArgs
		canRemoveArgs: self canRemoveArgs
		canAddArgs: self canAddArgs
		canEditName: self canEditName .
	dialog cancelled ifTrue: [  CmdCommandAborted signal ].
	
	originalMessage selector = methodName selector & (originalMessage argumentNames = methodName arguments)
		ifTrue: [ CmdCommandAborted signal].	
	^methodName! !

!SycChangeMessageSignatureCommand methodsFor: 'execution' stamp: ''!
resultMessageSelector
	self subclassResponsibility ! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SycChangeMessageSignatureCommand class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SycChangeMessageSignatureCommand class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SycChangeMessageSignatureCommand class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SycChangeMessageSignatureCommand class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SycChangeMessageSignatureCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isMessageSelected | aToolContext isMethodSelected! !

!SycChangeMessageSignatureCommand class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SycChangeMessageSignatureCommand class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SycChangeMessageSignatureCommand class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SycChangeMessageSignatureCommand class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SycChangeMessageSignatureCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = SycChangeMessageSignatureCommand ! !

!SycChangeMessageSignatureCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
browserMenuOrder
	<classAnnotationDependency>
	^2.1! !

!SycChangeMessageSignatureCommand class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SycChangeMessageSignatureCommand class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SycChangeMessageSignatureCommand class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SycChangeMessageSignatureCommand class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SycChangeMessageSignatureCommand class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SycChangeMessageSignatureCommand class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SycChangeMessageSignatureCommand class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SycChangeMessageSignatureCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.3 for: ClyMethodSourceCodeContext! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SycChangeMessageSignatureCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SycChangeMessageSignatureCommand class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SycChangeMessageSignatureCommand class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SycClassCmCommand commentStamp: ''!
This class is an extension so we can mix command of Commander2 with Commander.!
!SycClassCmCommand methodsFor: 'preparation' stamp: ''!
prepareFullExecution
	super prepareFullExecution.
	targetClass := context lastSelectedClass.! !

!SycClassCmCommand class methodsFor: 'adding' stamp: ''!
activationStrategy 
	^ SycClassMenuActivation! !

!SycClassCommand commentStamp: ''!
I am a base class for commands which perform operations with collection of classes
 
Internal Representation and Key Implementation Points.

    Instance Variables
	classes:		<Colletion of<Class>>!
!SycClassCommand methodsFor: 'initialization' stamp: ''!
initializeDefaultOptionsOf: refactoring

	NautilusRefactoring new refactoringOptions: refactoring! !

!SycClassCommand methodsFor: 'accessing' stamp: ''!
classes: anObject
	classes := anObject! !

!SycClassCommand methodsFor: 'initialization' stamp: ''!
setUpModelFromContext: aContext
	| browser scope |
	browser := aContext browser.
	scope := browser defaultNavigationScope.
	scope isCurrentImage ifTrue: [ scope := RefactoringSettings scopeRefactoring ].
	model := RBClassModelFactory rbNamespace onEnvironment: scope asRBEnvironment! !

!SycClassCommand methodsFor: 'activation - drag and drop' stamp: ''!
prepareExecutionInDragContext: aToolContext
	super prepareExecutionInDragContext: aToolContext.
	
	classes := aToolContext selectedClasses! !

!SycClassCommand methodsFor: 'actions' stamp: ''!
computeInvalidArgNamesForSelector: aSymbol
	| invalidArgNames |
	invalidArgNames := Set new.
	(model allImplementorsOf: aSymbol) do: [ :e | | cm | 
		cm:=(e realClass >> aSymbol).
		invalidArgNames addAll: cm argumentNames;
			addAll: cm origin instVarNames ].
	^ invalidArgNames! !

!SycClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	classes := aToolContext selectedClasses! !

!SycClassCommand methodsFor: 'accessing' stamp: ''!
classes
	^ classes! !

!SycClassCommand class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SycClassCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SycClassCommand class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SycClassCommand class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SycClassCommand class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SycClassCommand class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SycClassCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isClassSelected! !

!SycClassCommand class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SycClassCommand class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SycClassCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SycClassCommand class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SycClassCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SycClassCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SycClassCommand class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SycClassCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = SycClassCommand ! !

!SycClassCommand class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SycClassCommand class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SycClassCommand class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SycClassCommand class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SycClassCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SycClassCommand class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SycClassCommand class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SycClassCommand class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SycClassCommand class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SycClassCommand class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SycClassCommand class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SycClassCommand class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SycClassCommand class methodsFor: 'instance creation' stamp: ''!
for: classes
	^self new 
		classes: classes! !

!SycClassCommand class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SycClassCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SycClassCommand class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SycClassCommand class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SycClassMenuActivation commentStamp: ''!
I am a root of command activation hierarchy which supposed to represent commands in kind of menu.!
!SycCmAddSubclassCommand commentStamp: ''!
I am a command to create new subclass og given class (my targetClass)!
!SycCmAddSubclassCommand methodsFor: 'accessing' stamp: ''!
order 	
	^ 10100.1! !

!SycCmAddSubclassCommand methodsFor: 'executing' stamp: ''!
executeRefactoring
	
	| refactoring |
	refactoring := RBAddClassRefactoring
		addClass: newClassName
		superclass: targetClass
		subclasses: #()
		category: targetClass category.
	refactoring execute! !

!SycCmAddSubclassCommand methodsFor: 'testing' stamp: ''!
isApplicable
	
	^ true! !

!SycCmAddSubclassCommand methodsFor: 'accessing' stamp: ''!
name
	^'New subclass'! !

!SycCmAddSubclassCommand methodsFor: 'accessing' stamp: ''!
icon
	^self iconNamed:#add! !

!SycCmCommand commentStamp: ''!
This class is an extension so we can mix command of Commander2 with Commander.!
!SycCmCommand methodsFor: 'preparation' stamp: ''!
prepareFullExecution
	! !

!SycCmCommand methodsFor: 'accessing' stamp: ''!
parentGroup: aCmdRootMenuGroup 
	
	parentGroup := aCmdRootMenuGroup! !

!SycCmCommand methodsFor: 'testing' stamp: ''!
isEnabled

	^ true! !

!SycCmCommand methodsFor: 'initialization' stamp: ''!
initializeDefaultOptionsOf: refactoring

	NautilusRefactoring new refactoringOptions: refactoring! !

!SycCmCommand methodsFor: 'accessing' stamp: ''!
order
	
	^ 10100! !

!SycCmCommand methodsFor: 'context menu' stamp: ''!
registerContextMenuItemsWithBuilder: aBuilder 

	(aBuilder item: self name)
		parent: self parentGroup name;
		order: self parentGroup order + (self order / 100);
		help: self description;
		action: [self execute];
		icon: self icon.! !

!SycCmCommand methodsFor: 'executing' stamp: ''!
executeRefactoring! !

!SycCmCommand methodsFor: 'testing' stamp: ''!
isApplicable
	
	^ true! !

!SycCmCommand methodsFor: 'executing' stamp: ''!
execute 
	[self prepareFullExecution.
	self executeRefactoring.
	self applyCommandResult] 
		on: Exception do: [ :exc | self processCommandFailure: exc ]! !

!SycCmCommand methodsFor: 'initialization' stamp: ''!
setUpModelFromContext: aContext
	| browser scope |
	browser := aContext browser.
	scope := browser defaultNavigationScope.
	scope isCurrentImage ifTrue: [ scope := RefactoringSettings scopeRefactoring ].
	model := RBClassModelFactory rbNamespace onEnvironment: scope asRBEnvironment! !

!SycCmCommand methodsFor: 'accessing' stamp: ''!
icon

	^ nil! !

!SycCmCommand methodsFor: 'execution' stamp: ''!
processCommandFailure: anException
	
	context processFailure: anException of: self! !

!SycCmCommand methodsFor: 'actions' stamp: ''!
computeInvalidArgNamesForSelector: aSymbol
	| invalidArgNames |
	invalidArgNames := Set new.
	(model allImplementorsOf: aSymbol) do: [ :e | | cm | 
		cm:=(e realClass >> aSymbol).
		invalidArgNames addAll: cm argumentNames;
			addAll: cm origin instVarNames ].
	^ invalidArgNames! !

!SycCmCommand methodsFor: 'execution' stamp: ''!
applyCommandResult! !

!SycCmCommand methodsFor: 'accessing' stamp: ''!
parentGroup

	^ parentGroup! !

!SycCmCommand class methodsFor: 'adding' stamp: ''!
addMenuItemsTo: menuMorph onContext: context 

	| commands |
	
	commands := self allSubclasses collect: [:aClass | 
		aClass new 
			context: context;
			yourself] thenSelect: [:aCommand | aCommand isApplicable ].

	commands do: [ :aCommand | | anItem |
		anItem := menuMorph add: aCommand name target: aCommand selector: #execute.
		anItem enabled: aCommand isEnabled.
		anItem setBalloonText: aCommand description.
		aCommand icon ifNotNil: [ anItem icon: aCommand icon ].
	].

	^ menuMorph
! !

!SycCmCommand class methodsFor: 'adding' stamp: ''!
activationStrategy
	self subclassResponsibility! !

!SycCmCommand class methodsFor: 'adding' stamp: ''!
addItemsToSubmenu: aCmdMenu forContext: aClyMethodContext

	| commands |

	aCmdMenu activationStrategyClass = self activationStrategy ifFalse: [ ^ self ].

	commands := self subclasses
		            collect: [ :e | 
			            e new
				            context: aClyMethodContext;
				            yourself ]
		            thenSelect: [ :e | e isApplicable ].

	commands do: [ :e | aCmdMenu rootGroup addItem: e ]! !

!SycCmInsertSubclassCommand commentStamp: ''!
I am a command to insert new subclass into my target class hierarchy.
All current subclasses of targetClass will become subclasses of new created class!
!SycCmInsertSubclassCommand methodsFor: 'accessing' stamp: ''!
order 
	^ 20! !

!SycCmInsertSubclassCommand methodsFor: 'executing' stamp: ''!
executeRefactoring
	
	| refactoring |
	refactoring := RBAddClassRefactoring
		addClass: newClassName
		superclass: targetClass
		subclasses: targetClass subclasses
		category: targetClass category.
	refactoring execute! !

!SycCmInsertSubclassCommand methodsFor: 'testing' stamp: ''!
isApplicable
	
	^ true! !

!SycCmInsertSubclassCommand methodsFor: 'accessing' stamp: ''!
name
	^'Insert subclass'! !

!SycCmInsertSubclassCommand methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #smallLoadProject! !

!SycCmInsertSuperclassCommand commentStamp: ''!
I am a command to insert new superclass into my target class.
I create new class using supeclass of my target class. And I replace superclass of target class with new created class!
!SycCmInsertSuperclassCommand methodsFor: 'accessing' stamp: ''!
order 
	^ 30! !

!SycCmInsertSuperclassCommand methodsFor: 'executing' stamp: ''!
executeRefactoring
	
	| refactoring |
	refactoring := RBAddClassRefactoring
		addClass: newClassName
		superclass: targetClass superclass
		subclasses: {targetClass}
		category: targetClass category.
	refactoring execute! !

!SycCmInsertSuperclassCommand methodsFor: 'testing' stamp: ''!
isApplicable
	
	^ true! !

!SycCmInsertSuperclassCommand methodsFor: 'accessing' stamp: ''!
name
	^'Insert superclass'! !

!SycCmInsertSuperclassCommand methodsFor: 'accessing' stamp: ''!
icon
	^ self iconNamed: #smallLoadProject! !

!SycCmNewClassCreationCommand commentStamp: ''!
I am a base class for commands which create new class.
They all needs new class name

Internal Representation and Key Implementation Points.

    Instance Variables
	newClassName:		<String>!
!SycCmNewClassCreationCommand methodsFor: 'preparation' stamp: ''!
prepareFullExecution
	super prepareFullExecution.
	newClassName := UIManager default request: 'Name of new class'.	
	newClassName isEmptyOrNil | (newClassName = targetClass name) ifTrue: [ CmdCommandAborted signal].! !

!SycCmNewClassCreationCommand methodsFor: 'testing' stamp: ''!
isApplicable
	
	^ false! !

!SycCmNewClassCreationCommand methodsFor: 'execution' stamp: ''!
applyCommandResult
	
	| newClass |
	newClass := context system classNamed: newClassName.
	
	context showClass: newClass! !

!SycConvertTempToInstVarCommand commentStamp: ''!
I am a command to convert a temp variable in instance variable.!
!SycConvertTempToInstVarCommand methodsFor: 'execution' stamp: ''!
asRefactorings 
	^ { RBTemporaryToInstanceVariableRefactoring 
		class: method origin
		selector: method selector
		variable: sourceNode name }! !

!SycConvertTempToInstVarCommand methodsFor: 'execution' stamp: ''!
defaultMenuItemName
	^'Convert to Instance Var'! !

!SycConvertTempToInstVarCommand methodsFor: 'execution' stamp: ''!
defaultMenuIconName 
	^ #smallRedo! !

!SycConvertTempToInstVarCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aSourceCodeContext
	super canBeExecutedInContext: aSourceCodeContext.
	
	^aSourceCodeContext isTempVariableSelected  ! !

!SycCopyClassCommand commentStamp: ''!
I am a command to copy given class using given name.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	newClassName:		<String>
	originalClass:		<Class>
	resultClass:		<Class>
!
!SycCopyClassCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	aToolContext showClass: resultClass! !

!SycCopyClassCommand methodsFor: 'accessing' stamp: ''!
originalClass
	^ originalClass! !

!SycCopyClassCommand methodsFor: 'accessing' stamp: ''!
newClassName: anObject
	newClassName := anObject! !

!SycCopyClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Copy'! !

!SycCopyClassCommand methodsFor: 'execution' stamp: ''!
execute
	
	resultClass := originalClass duplicateClassWithNewName: newClassName! !

!SycCopyClassCommand methodsFor: 'accessing' stamp: ''!
newClassName
	^ newClassName! !

!SycCopyClassCommand methodsFor: 'accessing' stamp: ''!
originalClass: anObject
	originalClass := anObject! !

!SycCopyClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	originalClass := aToolContext lastSelectedClass.
	
	newClassName := UIManager default request: 'Input new class name' initialAnswer: originalClass name.
	
	newClassName isEmptyOrNil | (newClassName = originalClass name) 
		ifTrue: [ CmdCommandAborted signal ]! !

!SycCopyClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallCopy! !

!SycCopyClassCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: ClyFullBrowserClassContext! !

!SycCopyClassCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isClassSelected! !

!SycCopyClassCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $c meta for: ClyFullBrowserClassContext! !

!SycCopyMethodNameToClypboardCommand methodsFor: 'accessing' stamp: ''!
description
	^'Copy selected methods into Clipboard as class>>selector'! !

!SycCopyMethodNameToClypboardCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Copy name(s) to Clipboard'! !

!SycCopyMethodNameToClypboardCommand methodsFor: 'execution' stamp: ''!
execute
	| text |
	text := (methods collect: [ :each | each displayString ]) joinUsing: String cr.
	Clipboard clipboardText: text.
	self inform: 'Copied methods:', String cr, text! !

!SycCopyMethodNameToClypboardCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallCopy! !

!SycCopyMethodNameToClypboardCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClyMethod asCalypsoItemContext! !

!SycCopyMethodNameToClypboardCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodTabIconActivation
	<classAnnotation>
	
	^ClyBrowserTabCommandActivation for: ClyMethod asCalypsoItemContext! !

!SycCopyPackageCommand commentStamp: ''!
I am a command to copy given package.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	newName:		<String>
	package:		<RPackage>!
!SycCopyPackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Copy all package'! !

!SycCopyPackageCommand methodsFor: 'execution' stamp: ''!
execute

	(RBCopyPackageRefactoring copyPackage: package name in: newName) execute! !

!SycCopyPackageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	package := aToolContext lastSelectedPackage.	
	newName := UIManager default 
		request: 'New name of copied package' 
		initialAnswer: package name 
		title: 'Copy package'.
	newName isEmptyOrNil | (newName = package name) ifTrue: [ ^ CmdCommandAborted signal ]! !

!SycCopyPackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallCopy! !

!SycCopyPackageCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 1.1 for: ClyFullBrowserPackageContext! !

!SycCopyPackageCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	"^aToolContext isPackageSelected"
	^ false! !

!SycCopyPackageCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $c meta for: ClyFullBrowserPackageContext! !

!SycCopyTestMethodNameToClypboardCommand commentStamp: ''!
Copy selected methods selector into Clipboard as testOriginalSelector!
!SycCopyTestMethodNameToClypboardCommand methodsFor: 'accessing' stamp: ''!
description
	^'Copy selected methods selector into Clipboard as testXXX'! !

!SycCopyTestMethodNameToClypboardCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Copy test method selector(s) to Clipboard'! !

!SycCopyTestMethodNameToClypboardCommand methodsFor: 'execution' stamp: ''!
execute
	| text |
	text := (methods collect: [ :each | each selector asTestSelector ]) joinUsing: String cr.
	Clipboard clipboardText: text.
	self inform: 'Copied methods:', String cr, text! !

!SycCopyTestMethodNameToClypboardCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallCopy! !

!SycCopyTestMethodNameToClypboardCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClyMethod asCalypsoItemContext! !

!SycDebuggingMenuActivation commentStamp: ''!
I represent an activation of debugging commands using a separate debugging menu.!
!SycDemoteToPackageWithTagCommand commentStamp: ''!
I am a command to demote given packages into the package with tag!
!SycDemoteToPackageWithTagCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aBrowserContext
			
	| lastPackage newPackage tag |
	lastPackage := packages detect: [ :each | each name includes: $- ] ifNone: [ ^self ].

	newPackage := (lastPackage name copyUpToLast: $-) asPackage.
	tag := lastPackage name last: lastPackage name size - newPackage name size - 1.
	aBrowserContext showPackage: newPackage atClassTag: tag asSymbol! !

!SycDemoteToPackageWithTagCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Demote to package with tag'! !

!SycDemoteToPackageWithTagCommand methodsFor: 'execution' stamp: ''!
execute
			
	packages 
		select: [ :each | each name includes: $- ]
		thenDo: [ :each | each demoteToTagInPackageNamed: (each name copyUpToLast: $-) ]! !

!SycDemoteToPackageWithTagCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: RPackage asCalypsoItemContext! !

!SycDeprecateClassCommand commentStamp: ''!
I am a command to deprecate given class.

Internal Representation and Key Implementation Points.

    Instance Variables
	newName:		<String>!
!SycDeprecateClassCommand methodsFor: 'converting' stamp: ''!
asRefactorings
	| refactoring |
	refactoring := RBDeprecateClassRefactoring deprecate: targetClass in: newName name.
	^ { refactoring }! !

!SycDeprecateClassCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring 
	^ true! !

!SycDeprecateClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Deprecate'! !

!SycDeprecateClassCommand methodsFor: 'execution' stamp: ''!
execute
	
	self asRefactorings do: [ :ref | ref execute ]! !

!SycDeprecateClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	newName := aToolContext requestSingleClass: 'Choose new class'.		
	newName ifNil: [ CmdCommandAborted signal]! !

!SycDeprecateClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #bug! !

!SycDeprecateClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	"disabled for now, see https://github.com/pharo-project/pharo/issues/9551"
	"<classAnnotation>"
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.3 for: ClySourceCodeContext! !

!SycDeprecateClassCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext

	^ (super canBeExecutedInContext: aToolContext) and: [ 
		  aToolContext lastSelectedClass isDeprecated not ]! !

!SycDeprecateClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
browserContextMenuActivation
	"disabled for now, see https://github.com/pharo-project/pharo/issues/9551"
	"<classAnnotation>"
	
	^CmdContextMenuActivation byRootGroupItemOrder: 1.4 for: ClyClass asCalypsoItemContext! !

!SycDeprecateMessageCommand commentStamp: ''!
I am a command to depracate a message selector.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	newSelector:		<ByteSymbol>!
!SycDeprecateMessageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Deprecate'! !

!SycDeprecateMessageCommand methodsFor: 'execution' stamp: ''!
createRefactoring

	^ RBDeprecateMethodRefactoring
		model: model 
		deprecateMethod: originalMessage selector  
		in: originalMessage contextUser origin
		using: newSelector! !

!SycDeprecateMessageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	| oldSelector |
	super prepareFullExecutionInContext: aToolContext.
	
	oldSelector := originalMessage selector.
	newSelector := UIManager default 
		request: 'Method to replace ', oldSelector  
		initialAnswer: oldSelector
		title: 'New selector'.
	newSelector isEmptyOrNil | (newSelector = oldSelector) ifTrue: [ CmdCommandAborted signal ]! !

!SycDeprecateMessageCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^ aToolContext isMethodSelected! !

!SycDeprecateMessageCommand class methodsFor: 'accessing' stamp: ''!
browserMenuOrder
	^ 2.5! !

!SycDeprecateMessageCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodMenuActivation
	<classAnnotation>

	^CmdContextMenuActivation 
		byRootGroupItemOrder: self browserMenuOrder for: ClyMethod asCalypsoItemContext! !

!SycExtractMethodCommand commentStamp: ''!
I am a command to extract selected ast node into separate method !
!SycExtractMethodCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aSourceCodeContext
	super readParametersFromContext: aSourceCodeContext.
	self setUpModelFromContext: aSourceCodeContext.
	selectedTextInterval := aSourceCodeContext selectedTextInterval.! !

!SycExtractMethodCommand methodsFor: 'execution' stamp: ''!
setUpOptionToChangeExtractionClass: refactoring

	refactoring setOption: #extractionClass toUse: [ :ref | | cls superclasses |
		cls := ref methodClass realClass.
		superclasses := cls allSuperclasses reversed copyWithoutAll: { Object . ProtoObject }.
		superclasses ifNotEmpty: [ 
			cls := UIManager default
				chooseFrom: ((superclasses, {cls}) collect: #name)
				values: superclasses, {cls}
				title: 'Choose the class where you want to extract the method'
		].
		cls ifNil: [ 
			self inform: 'Command aborted, you must select a class.'.
			CmdCommandAborted signal ].
		cls ]! !

!SycExtractMethodCommand methodsFor: 'converting' stamp: ''!
asRefactorings

	| selectedInterval refactoring |
	selectedInterval := selectedTextInterval ifEmpty: [ 
		                    sourceNode sourceInterval ].
	refactoring := RBExtractMethodAndOccurrences
		               extract: selectedInterval
		               from: method selector
		               in: method origin.
	self setUpOptionsOf: refactoring.
	^ { refactoring }! !

!SycExtractMethodCommand methodsFor: 'initialization' stamp: ''!
initializeDefaultOptionsOf: refactoring

	NautilusRefactoring new refactoringOptions: refactoring! !

!SycExtractMethodCommand methodsFor: 'execution' stamp: ''!
setUpOptionToUseExistingMethodDuring: aRefactoring

	aRefactoring setOption: #useExistingMethod toUse:  [ :ref :selector | 
		UIManager default 
			confirm: 'Do you want to use existing method ', selector printString, '?'
			label: 'Warninig']. 	
	! !

!SycExtractMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Extract method'! !

!SycExtractMethodCommand methodsFor: 'initialization' stamp: ''!
setUpModelFromContext: aContext
	| browser scope |
	browser := aContext browser.
	scope := browser defaultNavigationScope.
	scope isCurrentImage ifTrue: [ scope := RefactoringSettings scopeRefactoring ].
	model := RBClassModelFactory rbNamespace onEnvironment: scope asRBEnvironment! !

!SycExtractMethodCommand methodsFor: 'execution' stamp: ''!
setUpOptionsOf: refactoring

	self initializeDefaultOptionsOf: refactoring.
	self setUpOptionToChangeExtractionClass: refactoring.
	self setUpOptionToUseExistingMethodDuring: refactoring.
	self setUpOptionToOverrideExistingMethodDuring: refactoring.
	self setUpOptionToChangeMethodNameDuring: refactoring! !

!SycExtractMethodCommand methodsFor: 'execution' stamp: ''!
setUpOptionToChangeMethodNameDuring: refactoring

	| dialog |
	refactoring setOption: #methodName toUse: [ :methodName :ref | | invalidArgs |
		invalidArgs := self computeInvalidArgNamesForSelector: method selector.
		dialog := SycMethodNameEditorPresenter
			openOn: methodName
			withInvalidArgs: invalidArgs
			canRenameArgs: true
			canRemoveArgs: false
			canAddArgs: false.
		dialog cancelled ifTrue: [ CmdCommandAborted signal ].
		methodName ]! !

!SycExtractMethodCommand methodsFor: 'actions' stamp: ''!
computeInvalidArgNamesForSelector: aSymbol
	| invalidArgNames |
	invalidArgNames := Set new.
	(model allImplementorsOf: aSymbol) do: [ :e | | cm | 
		cm:=(e realClass >> aSymbol).
		invalidArgNames addAll: cm argumentNames;
			addAll: cm origin instVarNames ].
	^ invalidArgNames! !

!SycExtractMethodCommand methodsFor: 'execution' stamp: ''!
setUpOptionToOverrideExistingMethodDuring: aRefactoring

	aRefactoring setOption: #alreadyDefined toUse:  [ :ref :class :selector | 
		ref refactoringWarning: 'Method ', selector printString, ' will override method in ', class name]. ! !

!SycExtractMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #glamorousRestart! !

!SycExtractMethodCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aSourceCodeContext
	super canBeExecutedInContext: aSourceCodeContext.
	
	^aSourceCodeContext isMethodSelected not ! !

!SycExtractSetUpRefactoring commentStamp: ''!
I am a command to extract setUp method and then replaces its occurrences!
!SycExtractSetUpRefactoring methodsFor: 'preparation' stamp: ''!
readParametersFromContext: aSourceCodeContext
	super readParametersFromContext: aSourceCodeContext.
	
	selectedTextInterval := aSourceCodeContext selectedTextInterval.! !

!SycExtractSetUpRefactoring methodsFor: 'executing' stamp: ''!
asRefactorings 
	| selectedInterval refactoring |
	selectedInterval := selectedTextInterval ifEmpty: [ 
		                    sourceNode sourceInterval ].
	refactoring := RBExtractSetUpMethodAndOccurrences 
		extract: selectedInterval
		from: method selector
		in: method origin.
	self initializeDefaultOptionsOf: refactoring.
	^ { refactoring }! !

!SycExtractSetUpRefactoring methodsFor: 'executing' stamp: ''!
executeRefactoring 
	| selectedInterval refactoring |
	selectedInterval := selectedTextInterval ifEmpty: [ 
		                    sourceNode sourceInterval ].
	refactoring := RBExtractSetUpMethodAndOccurrences 
		extract: selectedInterval
		from: method selector
		in: method origin.
	self initializeDefaultOptionsOf: refactoring.
	refactoring execute! !

!SycExtractSetUpRefactoring methodsFor: 'accessing' stamp: ''!
defaultMenuItemName 	
	^ 'Extract setUp'! !

!SycExtractSetUpRefactoring methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #glamorousRestart! !

!SycExtractSetUpRefactoring class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	super canBeExecutedInContext: aToolContext.
	
	^aToolContext isMethodSelected not and: [aToolContext lastSelectedMethod selector isTestSelector]! !

!SycExtractTempCommand commentStamp: ''!
I am a command to extract selected ast node into temp variable using assignment. 

Internal Representation and Key Implementation Points.

    Instance Variables
	tempName:		<String>
!
!SycExtractTempCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aSourceCodeContext
	super applyResultInContext: aSourceCodeContext.
	
	aSourceCodeContext showVariableNamed: tempName! !

!SycExtractTempCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	^ {RBExtractToTemporaryTransformation
		  extract: sourceNode sourceInterval
		  to: tempName
		  from: method selector
		  in: method origin}! !

!SycExtractTempCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Extract temp'! !

!SycExtractTempCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aSourceCodeContext
	super prepareFullExecutionInContext: aSourceCodeContext.
	
	tempName := UIManager default 
		request: 'New temp name' 
		initialAnswer: ''
		title: 'Extract code to temp variable'.
	tempName isEmptyOrNil ifTrue: [ CmdCommandAborted signal ]! !

!SycExtractTempCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ ##smallUpdateIcon! !

!SycExtractTempCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aSourceCodeContext
	super canBeExecutedInContext: aSourceCodeContext.
	
	^aSourceCodeContext isMethodSelected not ! !

!SycFindAndReplaceMethodCommand commentStamp: ''!
I am a command to find and replace selector in a range of methods, with a call to itself!
!SycFindAndReplaceMethodCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext! !

!SycFindAndReplaceMethodCommand methodsFor: 'testing' stamp: ''!
searchInTheWholeHierarchy

	^ originalMessage contextUser origin subclasses 
		ifEmpty: [ false ]
		ifNotEmpty: [ self confirm: 'Do you want to search occurrences in the whole hierarchy?' ]! !

!SycFindAndReplaceMethodCommand methodsFor: 'execution' stamp: ''!
defaultMenuItemName
	^'Find and replace'! !

!SycFindAndReplaceMethodCommand methodsFor: 'testing' stamp: ''!
createRefactoring

	^ RBFindAndReplaceRefactoring
		model: model
		find: originalMessage selector
		of: originalMessage contextUser origin
		inWholeHierarchy: self searchInTheWholeHierarchy! !

!SycFindAndReplaceMethodCommand methodsFor: 'execution' stamp: ''!
resultMessageSelector
	^ nil! !

!SycFindAndReplaceMethodCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation
		byRootGroupItemOrder: 25 for: ClyMethod asCalypsoItemContext! !

!SycFindAndReplaceMethodCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^ aToolContext isMethodSelected! !

!SycFindAndReplaceMethodCommand class methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallFindIcon! !

!SycFindAndReplaceSetUpCommand commentStamp: ''!
I am a command to find and replace setUp method in owner class and its subclasses if apply!
!SycFindAndReplaceSetUpCommand methodsFor: 'preparation' stamp: ''!
prepareFullExecution
	super prepareFullExecution.
	method := context lastSelectedMethod.! !

!SycFindAndReplaceSetUpCommand methodsFor: 'executing' stamp: ''!
executeRefactoring
	| refactoring |
	refactoring := RBFindAndReplaceSetUpRefactoring 
		model: model
		of: method origin
		inWholeHierarchy: self searchInTheWholeHierarchy.
	refactoring execute! !

!SycFindAndReplaceSetUpCommand methodsFor: 'testing' stamp: ''!
isApplicable 
	^ context lastSelectedMethod selector = #setUp! !

!SycFindAndReplaceSetUpCommand methodsFor: 'executing' stamp: ''!
searchInTheWholeHierarchy

	^ method origin subclasses 
		ifEmpty: [ false ]
		ifNotEmpty: [ self confirm: 'Do you want to search occurrences in the whole hierarchy?' ]! !

!SycFindAndReplaceSetUpCommand methodsFor: 'accessing' stamp: ''!
name
	^ 'Find and replace setUp'! !

!SycFormatSourceCodeCommand commentStamp: ''!
I am a command to format source code in given code editor.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	sourceCodeEditor:		<Object>!
!SycFormatSourceCodeCommand methodsFor: 'accessing' stamp: ''!
sourceCodeEditor
	^ sourceCodeEditor! !

!SycFormatSourceCodeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Format code'! !

!SycFormatSourceCodeCommand methodsFor: 'execution' stamp: ''!
execute
	
	sourceCodeEditor formatSourceCode! !

!SycFormatSourceCodeCommand methodsFor: 'accessing' stamp: ''!
sourceCodeEditor: anObject
	sourceCodeEditor := anObject! !

!SycFormatSourceCodeCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	sourceCodeEditor := aToolContext methodEditor! !

!SycFormatSourceCodeCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^ #smallJustified! !

!SycFormatSourceCodeCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 100000 for: ClyMethodSourceCodeContext! !

!SycGenerateAllInstVarAccessorsCommand commentStamp: ''!
I am a command to generate accessors for all inst vars of given classes!
!SycGenerateAllInstVarAccessorsCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	| refactorings |
	refactorings := classes flatCollect: [:eachClass |
		eachClass	 slots collect: [:var | 
			var createRefactoring: RBCreateAccessorsForVariableRefactoring for: eachClass]].
	refactorings do: [ :each | 
		each classVariable: false].
	^refactorings! !

!SycGenerateAllInstVarAccessorsCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	^true! !

!SycGenerateAllInstVarAccessorsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Generate accessors'! !

!SycGenerateAllInstVarAccessorsCommand methodsFor: 'execution' stamp: ''!
execute

	self executeRefactorings! !

!SycGenerateAllInstVarAccessorsCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext

	super prepareFullExecutionInContext: aToolContext.
	classes := classes collect: [:each | aToolContext currentMetaLevelOf: each]! !

!SycGenerateAllInstVarAccessorsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallAdd! !

!SycGenerateAllInstVarAccessorsCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
browserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation  by: $g meta, $a meta for: ClyClass asCalypsoItemContext! !

!SycGenerateAllInstVarAccessorsCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 2.1 for: ClyFullBrowserClassContext! !

!SycGenerateEqualAndHashCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	^{
		RBGenerateEqualHashRefactoring 
			className: targetClass name
			variables: (variables collect: [:each | each name])
	}! !

!SycGenerateEqualAndHashCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Generate equal and hash'! !

!SycGenerateEqualAndHashCommand methodsFor: 'execution' stamp: ''!
execute
	self executeRefactorings! !

!SycGenerateEqualAndHashCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	variables := aToolContext 
		requestMultipleVariables: 'Choose variables for equality' 
		from: {targetClass}! !

!SycGenerateEqualAndHashCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClyFullBrowserClassContext! !

!SycGeneratePrintStringCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	^{
		RBGeneratePrintStringRefactoring 
			className: targetClass name
			variables: (variables collect: [:each | each name])
	}! !

!SycGeneratePrintStringCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Generate print string'! !

!SycGeneratePrintStringCommand methodsFor: 'execution' stamp: ''!
execute
	self executeRefactorings! !

!SycGeneratePrintStringCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	variables := aToolContext 
		requestMultipleVariables: 'Choose variables for print string' 
		from: {targetClass}! !

!SycGeneratePrintStringCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClyFullBrowserClassContext! !

!SycGenerateVariableAccessorCommand commentStamp: ''!
I am a command to generate accessors for given variables!
!SycGenerateVariableAccessorCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	^self
		createRefactorings: RBCreateAccessorsForVariableRefactoring 
		using: [ :refactoring :var |
			refactoring classVariable: var isClassVariable ]! !

!SycGenerateVariableAccessorCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Generate accessors'! !

!SycGenerateVariableAccessorCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallAdd! !

!SycGenerateVariableAccessorCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemFor: ClySourceCodeContext! !

!SycGenerateVariableAccessorCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: ClyFullBrowserVariableContext! !

!SycGenerateVariableAccessorsWithLazyInitializationCommand methodsFor: 'converting' stamp: ''!
asRefactorings

	^ { (RBCreateAccessorsWithLazyInitializationForVariableRefactoring 
		variable: variable name
		class: variable definingClass 
		classVariable: variable isClassVariable
		defaultValue: value) }! !

!SycGenerateVariableAccessorsWithLazyInitializationCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	^true! !

!SycGenerateVariableAccessorsWithLazyInitializationCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Generate accessors (lazy)'! !

!SycGenerateVariableAccessorsWithLazyInitializationCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext

	super prepareFullExecutionInContext: aToolContext.
	variable := aToolContext lastSelectedVariable.
	value := self uiManager
		           request: 'Default value of variable accessor'
		           initialAnswer: 'nil'
		           title: 'Default variable''s value'.
	value isEmptyOrNil ifTrue: [ CmdCommandAborted signal ]! !

!SycGenerateVariableAccessorsWithLazyInitializationCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallAdd! !

!SycGenerateVariableAccessorsWithLazyInitializationCommand class methodsFor: 'activation' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 2 for: ClyFullBrowserVariableContext ! !

!SycGenerateVariableAccessorsWithLazyInitializationCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isVariableSelected and: [ aToolContext isGlobalVariableSelected not ]! !

!SycInlineAllSendersMessageCommand commentStamp: ''!
I am a command to launch the Inline All Senders Refactoring: the call to this method in all other methods of this class is replaced by its implementation. !
!SycInlineAllSendersMessageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Inline senders'! !

!SycInlineAllSendersMessageCommand methodsFor: 'execution' stamp: ''!
createRefactoring
	| refactoring methodOrigin |
	
	"Extract the method origin from the context.
	The contextUser can be
	  - a method (if selected from the method list)
	  - an AST (if selected from the text editor).
	Ask #method to resolve to the method, and then ask the origin, i.e. the class or trait where it is defined"
	methodOrigin := originalMessage contextUser method origin.
	refactoring := RBInlineAllSendersRefactoring
		model: model
		sendersOf: originalMessage selector 
		in: methodOrigin.
	refactoring setOption: #inlineExpression toUse: [ :ref :aString | self confirm: ('Do you want to inline the expression ''<1s>'' in the current method?' expandMacrosWith: aString) ] .
	^ refactoring ! !

!SycInlineAllSendersMessageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallRightFlushIcon
! !

!SycInlineAllSendersMessageCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation
		byRootGroupItemOrder: 35 for: ClyMethod asCalypsoItemContext! !

!SycInlineAllSendersMessageCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^ aToolContext isMethodSelected! !

!SycInlineMethodCommand commentStamp: ''!
I am a command to inline "self send" method directly into sender method!
!SycInlineMethodCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	^ { ((RBInlineMethodRefactoring
		    inline: sourceNode sourceInterval
		    inMethod: method selector
		    forClass: method origin)
		   setOption: #inlineExpression toUse: [ :ref :aString | 
			   self confirm:
					   ('Do you want to inline the expression ''<1s>'' in the current method?' 
						    expandMacrosWith: aString) ];
		   yourself) }! !

!SycInlineMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Inline method'! !

!SycInlineMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallRightFlushIcon! !

!SycInlineMethodCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aSourceCodeContext
	super canBeExecutedInContext: aSourceCodeContext.
	
	^aSourceCodeContext isMethodSelected not and: [ aSourceCodeContext isMessageSelected ]! !

!SycInlineTempCommand commentStamp: ''!
I am a command to inline selected temp variable (represented by source node)!
!SycInlineTempCommand methodsFor: 'execution' stamp: ''!
asRefactorings
	| assignment |
	assignment := sourceNode methodNode assignmentNodes 
		detect: [:each | each variable = sourceNode ].

	^ { RBInlineTemporaryRefactoring	
		inline: assignment sourceInterval
		from: method selector
		in: method origin}! !

!SycInlineTempCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Inline temp'! !

!SycInlineTempCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ ##smallRightFlushIcon! !

!SycInlineTempCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aSourceCodeContext
	super canBeExecutedInContext: aSourceCodeContext.
	
	^aSourceCodeContext isTempVariableSelected  ! !

!SycInspectVariableCommand commentStamp: ''!
I am a command to inspect given variable.
For live variables lile globals or class variables I open inspector on variable value.
Also I open inspector on instance variable of class side because they also have live values.
For instance side instance variable I inspect slot definition instance.!
!SycInspectVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Inspect'! !

!SycInspectVariableCommand methodsFor: 'execution' stamp: ''!
execute

	variables last openInspector! !

!SycInspectVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#glamorousInspect! !

!SycInspectVariableCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byItemOf: ClyQueryMenuGroup for: ClySourceCodeContext! !

!SycInspectVariableCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserDoubleClickActivation
	<classAnnotation>
	
	^(CmdDoubleClickActivation for: ClyFullBrowserVariableContext)
		priority: 10000! !

!SycInspectVariableCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyFullBrowserVariableContext! !

!SycInspectVariableCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	(super canBeExecutedInContext: aToolContext) ifFalse: [ ^false ].
	
	^aToolContext lastSelectedVariable isLive! !

!SycInspectVariableCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^(CmdShortcutActivation 
		by: PharoShortcuts current inspectItShortcut for: ClyFullBrowserVariableContext)
			priority: 100000! !

!SycInspectVariableCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation 
		by: PharoShortcuts current inspectItShortcut for: ClySourceCodeContext! !

!SycMergeVariableCommand commentStamp: ''!
I am a command to merge given variable into another!
!SycMergeVariableCommand methodsFor: 'execution' stamp: ''!
newVariableName

	^ newName name! !

!SycMergeVariableCommand methodsFor: 'execution' stamp: ''!
classRefactoring
	^ RBMergeInstanceVariableIntoAnother! !

!SycMergeVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Merge into another'! !

!SycMergeVariableCommand methodsFor: 'execution' stamp: ''!
requestNewNameIn: aToolContext
	newName := aToolContext
		           requestSimpleVariable: 'Select a variable'
		           from: (Array with: variable definingClass).! !

!SycMergeVariableCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation! !

!SycMergeVariableCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 1.1 for: ClyFullBrowserVariableContext! !

!SycMergeVariableCommand class methodsFor: 'activation' stamp: ''!
fullBrowserShortcutActivation
	! !

!SycMergeVariableCommand class methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #merge! !

!SycMergeVariableCommand class methodsFor: 'activation' stamp: ''!
sourceCodeShortcutActivation
	! !

!SycMessageCommand commentStamp: ''!
I am a base class for commands which perform operations on collection of messages.

Messages are instances of SycMessageDescription which is a pair of selector and arguments.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	messages:		<Collection of<SycMessageDescription>>
!
!SycMessageCommand methodsFor: 'accessing' stamp: ''!
messages: anObject
	messages := anObject! !

!SycMessageCommand methodsFor: 'accessing' stamp: ''!
messages
	^ messages! !

!SycMessageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	messages := aToolContext selectedMessages! !

!SycMessageCommand class methodsFor: 'instance creation' stamp: ''!
for: messages
	^self new 
		messages: messages! !

!SycMessageCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = SycMessageCommand! !

!SycMessageCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isMessageSelected | aToolContext isMethodSelected! !

!SycMessageCommand class methodsFor: 'instance creation' stamp: ''!
forMethods: methods
	^self for: (methods collect: [:each | SycMessageDescription ofMethod: each])! !

!SycMessageDescription commentStamp: ''!
I represent message description which includes selector and argument names.

In addition I keep reference to so named contextUser. It is an object which uses given message, which was used to retrieve message instance.
The #contextUser is either a method or RBMessageNode.

To create my instance use following expressions: 

	SycMessageDescription ofMethod: Magnitude >> #between:and:.
	SycMessageDescription ofMessageNode: (SycRenameMessageCommand >> #createRefactoring) ast sendNodes first.

I implement suitable method for commands to request new signature: 

	aMessage requestNewSignature

It returns new message instance.

Also I provide a method to compute argument permutations comparing to another message: 

	aMessage1 computeArgumentPermutationsFor: aMessage2
	
It is required for rename method refactoring.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	argumentNames:		<Array of<String>>
	contextUser:		<Object>
	selector:		<Symbol>!
!SycMessageDescription methodsFor: 'accessing' stamp: ''!
methodClass

	^ contextUser methodClass! !

!SycMessageDescription methodsFor: 'accessing' stamp: ''!
contextUser: anObject
	contextUser := anObject! !

!SycMessageDescription methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!SycMessageDescription methodsFor: 'testing' stamp: ''!
describesSelector: someSelector withArguments: someArgumentNames 
	^selector = someSelector & (argumentNames = someArgumentNames) ! !

!SycMessageDescription methodsFor: 'accessing' stamp: ''!
selector: anObject
	selector := anObject! !

!SycMessageDescription methodsFor: 'operations' stamp: ''!
computeArgumentPermutationsFor: modifiedMessageDescription
	^modifiedMessageDescription argumentNames 
		collect: [ :each | argumentNames indexOf: each ]! !

!SycMessageDescription methodsFor: 'accessing' stamp: ''!
argumentNames
	^ argumentNames! !

!SycMessageDescription methodsFor: 'accessing' stamp: ''!
contextUser
	^ contextUser! !

!SycMessageDescription methodsFor: 'operations' stamp: ''!
requestNewSignature
	| methodName dialog |
	methodName := RBMethodName selector: selector arguments: argumentNames copy.
	dialog := SycMethodNameEditorPresenter openOn: methodName.
	dialog cancelled ifTrue: [  CmdCommandAborted signal ].
	
	selector = methodName selector & (argumentNames = methodName arguments)
		ifTrue: [ CmdCommandAborted signal].
	
	^(SycMessageDescription fromContextOf: contextUser)
		selector: methodName selector;
		argumentNames: methodName arguments! !

!SycMessageDescription methodsFor: 'accessing' stamp: ''!
argumentNames: anObject
	argumentNames := anObject! !

!SycMessageDescription class methodsFor: 'instance creation' stamp: ''!
fromContextOf: messageUserObject
	^self new 
		contextUser: messageUserObject! !

!SycMessageDescription class methodsFor: 'instance creation' stamp: ''!
ofMethod: aMethod
	^(self fromContextOf: aMethod)
		selector: aMethod selector;
		argumentNames: aMethod argumentNames! !

!SycMessageDescription class methodsFor: 'instance creation' stamp: ''!
ofMessageNode: astMessageNode
	^(self fromContextOf: astMessageNode) 
		selector: astMessageNode selector;
		argumentNames: (astMessageNode arguments collect: [:each | each formattedCode])! !

!SycMessageOriginHack commentStamp: ''!
I represent class of message implementor for method refactorings.
Implementing class is required for current method refactorings but it should be removed in future because it should be always message refactoring. For example RBRenameMethodRefactoring renames any selectors in image which is not restrited by any existing method. Probably reason of such restriction was how browser implements rename of methods when user activated it on selected methods.
Same is valid for add/remove method parameter.
So now these  refactorings check that given class defines given selector which is not needed actually because we modify message.
I used in place of class for all such refactorings to allow them work on messages!
!SycMessageOriginHack methodsFor: 'accessing' stamp: ''!
message: anObject
	message := anObject! !

!SycMessageOriginHack methodsFor: 'hacked methods' stamp: ''!
parseTreeFor: aSelector
	^message! !

!SycMessageOriginHack methodsFor: 'hacked methods' stamp: ''!
directlyDefinesMethod: aSymbol
	^message selector == aSymbol! !

!SycMessageOriginHack methodsFor: 'hacked methods' stamp: ''!
name
	^message contextUser printString! !

!SycMessageOriginHack methodsFor: 'accessing' stamp: ''!
message
	^ message! !

!SycMessageOriginHack methodsFor: 'hacked methods' stamp: ''!
storeOn: aStream

	^ message methodClass storeOn: aStream! !

!SycMessageOriginHack class methodsFor: 'instance creation' stamp: ''!
of: aMessageDescription

	^self new 
		message: aMessageDescription ! !

!SycMethodCmCommand commentStamp: ''!
This class is an extension so we can mix command of Commander2 with Commander.!
!SycMethodCmCommand methodsFor: 'preparation' stamp: ''!
prepareFullExecution
	super prepareFullExecution.
	self setUpModelFromContext: context! !

!SycMethodCmCommand class methodsFor: 'execution' stamp: ''!
activationStrategy 
	^ SycMethodMenuActivation! !

!SycMethodCommand commentStamp: ''!
I am a base class for commands which perform operations with collection of methods.

Internal Representation and Key Implementation Points.

    Instance Variables
	methods:		<Colletion of<CompiledMethod>>!
!SycMethodCommand methodsFor: 'initialization' stamp: ''!
initializeDefaultOptionsOf: refactoring

	NautilusRefactoring new refactoringOptions: refactoring! !

!SycMethodCommand methodsFor: 'accessing' stamp: ''!
methods: anObject
	methods := anObject! !

!SycMethodCommand methodsFor: 'categories' stamp: ''!
newTagFor: aMethod
	^ self asCommandActivator context requestSingleMethodTag: 'New protocol name for: ', aMethod name
		 suggesting: (MethodClassifier suggestProtocolFor: aMethod)! !

!SycMethodCommand methodsFor: 'categories' stamp: ''!
tagMethod: aMethod
	aMethod tagWith: (self newTagFor: aMethod) asSymbol! !

!SycMethodCommand methodsFor: 'initialization' stamp: ''!
setUpModelFromContext: aContext
	| browser scope |
	browser := aContext browser.
	scope := browser defaultNavigationScope.
	scope isCurrentImage ifTrue: [ scope := RefactoringSettings scopeRefactoring ].
	model := RBClassModelFactory rbNamespace onEnvironment: scope asRBEnvironment! !

!SycMethodCommand methodsFor: 'activation - drag and drop' stamp: ''!
prepareExecutionInDragContext: aToolContext
	super prepareExecutionInDragContext: aToolContext.
	
	methods := aToolContext selectedMethods! !

!SycMethodCommand methodsFor: 'accessing' stamp: ''!
methods
	^ methods! !

!SycMethodCommand methodsFor: 'actions' stamp: ''!
computeInvalidArgNamesForSelector: aSymbol
	| invalidArgNames |
	invalidArgNames := Set new.
	(model allImplementorsOf: aSymbol) do: [ :e | | cm | 
		cm:=(e realClass >> aSymbol).
		invalidArgNames addAll: cm argumentNames;
			addAll: cm origin instVarNames ].
	^ invalidArgNames! !

!SycMethodCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	methods := aToolContext selectedMethods! !

!SycMethodCommand class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SycMethodCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SycMethodCommand class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SycMethodCommand class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SycMethodCommand class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SycMethodCommand class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SycMethodCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isMethodSelected! !

!SycMethodCommand class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SycMethodCommand class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SycMethodCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SycMethodCommand class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SycMethodCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SycMethodCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SycMethodCommand class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SycMethodCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = SycMethodCommand ! !

!SycMethodCommand class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SycMethodCommand class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SycMethodCommand class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SycMethodCommand class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SycMethodCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SycMethodCommand class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SycMethodCommand class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SycMethodCommand class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SycMethodCommand class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SycMethodCommand class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SycMethodCommand class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SycMethodCommand class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SycMethodCommand class methodsFor: 'instance creation' stamp: ''!
for: methods
	^self new 
		methods: methods! !

!SycMethodCommand class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SycMethodCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SycMethodCommand class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SycMethodCommand class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SycMethodMenuActivation commentStamp: ''!
I represent activation of commands using method browser!
!SycMethodNameEditorPresenter commentStamp: ''!
I am an UI used to rename methods.

HOW TO RUN

SycMethodNameEditor
		openOn:
			(RBMethodName
				selector: (UseOnlyForTest >> #bug:) selector
				arguments: ((UseOnlyForTest >> #bug:) ast arguments collect: #name))
				

My jobs is to:
	- display a preview of your future method name or '(invalid)' when the name is incorrect  (with a LabelPresenter previewResult an instance variable)
	- display the arguments list of your method and let you modified the order 

Public API and Key Messages

See class side 'example' script to know how to use me.
  
Internal Representation and Key Implementation Points.

    Instance Variables
	selectorInput: 		<TextInputFieldPresenter>	An input field containing the new name of the method.
	argumentsList: 		<ListPresenter>					A list containing the arguments of the method.
	previewResult: 		<LabelPresenter>				A label to preview the new name of the method with the arguments.
	upButton: 			<ButtonPresenter>				A button update the order of the arguments.
	downButton: 			<ButtonPresenter>  			A button update the order of the arguments.
	methodName 		 	<RBMethod>						A RBMethodName to ensure the validity of the new name.!
!SycMethodNameEditorPresenter methodsFor: 'services' stamp: ''!
getParametersOrder
	^ argumentsList items collect: [ :arg | arg newName ]
	! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
canAddArgs: aBoolean
	canAddArgs := aBoolean.
	addButton enabled: canAddArgs.! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
removeArgument: anItem
	| selectedIndex |
	selectedIndex := argumentsList selection selectedIndex.
	argumentsList items: (argumentsList items copyUpTo: anItem), (argumentsList items copyAfter: anItem).
	argumentsList selectIndex: selectedIndex - 1.
	self updateLabel.! !

!SycMethodNameEditorPresenter methodsFor: 'accessing - ui' stamp: ''!
upButton
	^ upButton! !

!SycMethodNameEditorPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets
	selectorInput := self newTextInput.
	selectorInput editable: self canEditName.
	argumentsList := self newList.
	previewResult := self newLabel.
	upButton := self newButton.
	downButton := self newButton.
	addButton := self newButton.
	
	selectorInput autoAccept: true.
	upButton label: 'Up'.
	downButton label: 'Dn'.
	addButton label: '+'.
	selectorInput text: methodName selector.
	previewResult label: methodName methodName.
	"selectorInput beNotEditable."
	
	self setFocus! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
newArgs
	^ argumentsList items select: [ :e | (args includes: e name) not ]! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
canEditName
	^canEditName  ifNil: [ canEditName := true ]! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
getDefaultValue

	^ self uiManager
		  request: 'Enter default value for argument'
		  initialAnswer: 'nil'! !

!SycMethodNameEditorPresenter methodsFor: 'accessing - ui' stamp: ''!
downButton
	^ downButton! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
updateLabel
	"Update the new method name to display to the user when the user change its name or order of the arguments."

	previewResult
		label:
			(RBMethodName
				selector: (self selectorInput text ifNil: [''])
				arguments: (argumentsList items collect: #newName) ) methodName! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
computePermutation
	| index |
	index := 0.
	^ argumentsList items collect: [ :e | 
		args indexOf: e name ifAbsent: [ index := index -1. index ]
	 ]! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
canRemoveArgs: anObject

	argumentsList items do: [ :arg | arg canBeRemoved: anObject ]! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
addArgumentAfter: anItem

	| newArg argValue selectedIndex newKeyword |
	newKeyword := self getNewKeywordName.
	newKeyword isEmptyOrNil ifTrue: [ CmdCommandAborted signal ].
	selectedIndex := argumentsList selection selectedIndex.
	newArg := self newArgName asSymbol.
	argValue := self getDefaultValue.
	argValue isEmptyOrNil ifTrue: [ CmdCommandAborted signal ].
	newArg := RBArgumentName name: newArg value: argValue.
	argumentsList items:
		(argumentsList items copyUpThrough: anItem) , { newArg }
		, (argumentsList items copyAfter: anItem).
	self selectorInput text: self selectorInput text , newKeyword, ':'.
	argumentsList selectIndex: selectedIndex + 1.
	self canEditName: true.
	self updateLabel! !

!SycMethodNameEditorPresenter methodsFor: 'accessing - ui' stamp: ''!
previewResult
	^ previewResult! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
canRenameArgs: anObject

	argumentsList items do: [ :arg | arg canBeRenamed: anObject ]! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
pushDownSelectedArgument
	| selectedIndex |
	selectedIndex := argumentsList selection selectedIndex.
	selectedIndex = 0
		ifTrue: [ ^ self inform: 'There is not argument selected.' ].
	selectedIndex = argumentsList items size
		ifTrue: [ ^ self inform: 'The argument is already the last of the list.' ].
	argumentsList items swap: selectedIndex with: selectedIndex + 1.
	argumentsList selectIndex: selectedIndex + 1.
	self updateLabel.! !

!SycMethodNameEditorPresenter methodsFor: 'services' stamp: ''!
renameMap
	^ argumentsList items select: [ :arg | arg hasNewName ]! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
renameMethodAndClose: presenter
	^ self previewResult label = '(invalid)'
		ifTrue: [ self inform: 'Invalid method name' ]
		ifFalse: [
			methodName
				arguments: self getParametersOrder;
				selector: selectorInput text;
				newArgs: self newArgs;
				renameMap: self renameMap;
				permutation: self computePermutation.
			presenter
				beOk;
				close ]! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
invalidArgNames
	^ invalidArgNames ifNil: [ invalidArgNames := { } ]! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
getNewKeywordName

	^ self uiManager
		  request: 'Enter name for new keyword'
		  initialAnswer: 'arg'! !

!SycMethodNameEditorPresenter methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aRBMethodName
	methodName := aRBMethodName.
	args := methodName arguments copy.! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
addButton
	^ addButton! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
argumentsList
	^ argumentsList! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
setFocus
	self focusOrder
		add: selectorInput;
		add: argumentsList;
		add: upButton;
		add: downButton;
		add: addButton! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
renameArgument: anItem

	| argName selectedIndex |
	selectedIndex := argumentsList selection selectedIndex.
	argName := self uiManager
		request: 'Enter default name of argument' initialAnswer: anItem.
	argName ifNil: [ CmdCommandAborted signal ].
	(self invalidArgNames includes: argName) ifTrue: [ 
		self inform: 'It''s a invalid name'.
		CmdCommandAborted signal ].
	anItem newName: argName.
	argumentsList items: (argumentsList items copyUpTo: anItem), {anItem}, (argumentsList items copyAfter: anItem).
	argumentsList selectIndex: selectedIndex.
	self updateLabel.! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
canEditName: aBoolean
	canEditName := aBoolean.
	selectorInput enabled: canEditName .! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
canAddArgs
	^canAddArgs ifNil: [ canAddArgs := false ]! !

!SycMethodNameEditorPresenter methodsFor: 'services' stamp: ''!
alert: aString
	"Display a message for the user to read and then dismiss."

	aString isEmptyOrNil
		ifFalse: [ self uiManager alert: aString ]! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
pushUpSelectedArgument
	| selectedIndex |
	selectedIndex := argumentsList selection selectedIndex.
	selectedIndex = 0
		ifTrue: [ ^ self inform: 'There is not argument selected.' ].
	selectedIndex = 1
		ifTrue: [ ^ self inform: 'The argument is already the first of the list.' ].
	argumentsList items swap: selectedIndex with: selectedIndex - 1.
	argumentsList selectIndex: selectedIndex - 1.
	self updateLabel.! !

!SycMethodNameEditorPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aModalPresenter
	aModalPresenter
		addButton: 'Rename' do: [ :presenter | self renameMethodAndClose: presenter ];
		addButton: 'Cancel' do: [ :presenter | presenter beCancel; close ];
		initialExtent: 600 @ 300 ;
		title: 'Method name editor : "', methodName selector ,'"'! !

!SycMethodNameEditorPresenter methodsFor: 'accessing - ui' stamp: ''!
selectorInput
	^ selectorInput! !

!SycMethodNameEditorPresenter methodsFor: 'action' stamp: ''!
addArgument

	| newArg argValue newKeyword |
	newKeyword := self getNewKeywordName.
	newKeyword isEmptyOrNil ifTrue: [ CmdCommandAborted signal ].
	newArg := self newArgName asSymbol.
	argValue := self getDefaultValue.
	argValue isEmptyOrNil ifTrue: [ CmdCommandAborted signal ].
	newArg := RBArgumentName name: newArg value: argValue.
	argumentsList items: { newArg }.
	self selectorInput text: self selectorInput text , newKeyword ,':' .
	argumentsList selectIndex: 1.
	self canEditName: true.
	self updateLabel! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
argumentsListMenu
	^ self newMenu
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Rename';
						visibleIf: [ argumentsList selectedItem canBeRenamed ];
						iconName: #edit;
						action: [ self renameArgument: argumentsList selectedItem ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Add';
						visibleIf: [ self canAddArgs ];
						iconName: #add;
						action: [ self addArgumentAfter: argumentsList selectedItem ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Remove';
						visibleIf: [ argumentsList selectedItem canBeRemoved ];
						shortcut: $x meta;
						iconName: #remove;
						description: 'Remove argument';
						action: [ self removeArgument: argumentsList selectedItem ] ] ]! !

!SycMethodNameEditorPresenter methodsFor: 'instance creation' stamp: ''!
newArgName
	| baseString index newString |
	newString := baseString := 'anObject'.
	index := 0.
	[ self invalidArgNames, (self newArgs collect: #name) includes: newString ] 
		whileTrue: 
			[index := index + 1.
			newString := baseString , index printString].
	^ newString! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
connectPresenters 
	
	selectorInput 
		bindKeyCombination: Character cr asKeyCombination 
		toAction: [ :p | self renameMethodAndClose: self owner ];
	
		bindKeyCombination: Character escape asKeyCombination 
			toAction: [ self owner triggerCancelAction; close ]! !

!SycMethodNameEditorPresenter methodsFor: 'accessing' stamp: ''!
invalidArgNames: aSet
	invalidArgNames := aSet! !

!SycMethodNameEditorPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	selectorInput whenTextChangedDo: [ :text | self updateLabel ].
	selectorInput editable: self canEditName.
	upButton action: [ self pushUpSelectedArgument ].
	downButton action: [ self pushDownSelectedArgument ].
	addButton action: [ argumentsList items 
		ifEmpty: [ self addArgument ] 
		ifNotEmpty: [ self addArgumentAfter: argumentsList items last ] ].

	argumentsList
		whenModelChangedDo: [ :model | 
			model
				ifEmpty: [ upButton disable.
					downButton disable ] ].

	argumentsList items: (methodName arguments collect: [:arg | RBArgumentName name: arg]);
		contextMenu: self argumentsListMenu.
	argumentsList items ifNotEmpty: [ argumentsList selectIndex: 1 ]
! !

!SycMethodNameEditorPresenter class methodsFor: 'specs' stamp: ''!
openOn: aMethod canRenameArgs: aBoolean1 canRemoveArgs: aBoolean2 canAddArgs: aBoolean3
	"I take a RBMethodName as parameter and open the refactoring UI in a modal to rename it."
	|temp|
	temp := self on: aMethod.
	temp canRenameArgs: aBoolean1.
	temp canRemoveArgs: aBoolean2.
	temp canAddArgs: aBoolean3.
	^ temp openBlockedDialogWithSpec! !

!SycMethodNameEditorPresenter class methodsFor: 'specs' stamp: ''!
openOn: aMethod
	"I take a RBMethodName as parameter and open the refactoring UI in a modal to rename it."
	|temp|
	temp := self on: aMethod.
	^ temp openBlockedDialogWithSpec! !

!SycMethodNameEditorPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	^ SpBoxLayout newTopToBottom
		add:
			(SpBoxLayout newLeftToRight
				add: 'Selector'
					withConstraints: [ :aConstraints | aConstraints width: 80 ];
				add: #selectorInput;
				yourself);
		add:
			(SpBoxLayout newLeftToRight
				add: 'Arguments'
					withConstraints: [ :aConstraints | aConstraints width: 80 ];
				add: #argumentsList;
				add:
					(SpBoxLayout newTopToBottom
						add: #upButton
							withConstraints: [ :aConstraints | aConstraints height: 30 ];
						add: #downButton
							withConstraints: [ :aConstraints | aConstraints height: 30 ];
						add: #addButton
							withConstraints: [ :aConstraints | aConstraints height: 30 ];
						yourself)
					withConstraints: [ :aConstraints | aConstraints width: 30 ];
				yourself);
		add:
			(SpBoxLayout newLeftToRight
				add: 'Preview'
					withConstraints: [ :aConstraints | aConstraints width: 80 ];
				add: #previewResult yourself);
		yourself! !

!SycMethodNameEditorPresenter class methodsFor: 'examples' stamp: ''!
example2
	<script>
	self
		openOn:
			(RBMethodName
				selector: (RBExtractMethodRefactoring >> #validateRenameOf:to:) selector
				arguments: ((RBExtractMethodRefactoring >> #validateRenameOf:to:) ast arguments collect: [:each | each name]))
		canRenameArgs: true
		canRemoveArgs: true
		canAddArgs: true! !

!SycMethodNameEditorPresenter class methodsFor: 'specs' stamp: ''!
openOn: aMethod withInvalidArgs: aSet canRenameArgs: aBoolean1 canRemoveArgs: aBoolean2 canAddArgs: aBoolean3
	"I take a RBMethodName as parameter and open the refactoring UI in a modal to rename it."
	|temp|
	temp := self on: aMethod.
	temp invalidArgNames: aSet. 
	temp canRenameArgs: aBoolean1.
	temp canRemoveArgs: aBoolean2.
	temp canAddArgs: aBoolean3.
	^ temp openBlockedDialogWithSpec! !

!SycMethodNameEditorPresenter class methodsFor: 'specs' stamp: ''!
openOn: aMethod withInvalidArgs: aSet canRenameArgs: aBoolean1 canRemoveArgs: aBoolean2 canAddArgs: aBoolean3 canEditName: aBoolean4
	"I take a RBMethodName as parameter and open the refactoring UI in a modal to rename it."
	|temp|
	temp := self on: aMethod.
	temp invalidArgNames: aSet. 
	temp canRenameArgs: aBoolean1.
	temp canRemoveArgs: aBoolean2.
	temp canAddArgs: aBoolean3.
	temp canEditName: aBoolean4.
	^ temp openBlockedDialogWithSpec! !

!SycMethodNameEditorTest commentStamp: ''!
This class tests MethodNameEditor 
	
	I group method in Tag/Protocol:
		* action : all method in kind of Tag/Protocol are test of interacting with the widget for example (what will append if i click on button ...)
		* initialize-test : in this Tag/Protocol there are methods who test the initial configuration of a widget 
	
	!
!SycMethodNameEditorTest methodsFor: 'tests - up/down buttons' stamp: ''!
testButtonDownClickShouldModifiedArgumentsList
	| arrayBeforeClick arrayAfterClick |
	methodNameEditor argumentsList selectIndex: 2.
	arrayBeforeClick := methodNameEditor argumentsList items.
	self assert: (arrayBeforeClick collect: [ :each | each newName ]) asArray equals: #(a b c).
	methodNameEditor downButton click.
	arrayAfterClick := methodNameEditor argumentsList items.
	self assert: (arrayAfterClick collect: [ :each | each newName ]) asArray equals: #(a c b).! !

!SycMethodNameEditorTest methodsFor: 'running' stamp: ''!
tearDown
	methodNameEditor ifNotNil: [ :x | x application close ].
	super tearDown! !

!SycMethodNameEditorTest methodsFor: 'tests' stamp: ''!
testChangeInInputSelectorWithToMuchAccessorThanArgumentsShouldChangePreviewLabelFinalWithFailedText
	methodNameEditor selectorInput text: 'd:e:f:g:'.
	self assert: methodNameEditor previewResult label equals: '(invalid)'! !

!SycMethodNameEditorTest methodsFor: 'tests - initial state' stamp: ''!
testInitialArgumentListAutoSelection
	
	self assert: methodNameEditor argumentsList selection selectedIndexes equals: #(1)! !

!SycMethodNameEditorTest methodsFor: 'tests - initial state' stamp: ''!
testInitialButtonUpIsDisable
	methodNameEditor := SycMethodNameEditorPresenter on: (self methodNamedFor: #a).
	self deny: methodNameEditor upButton isEnabled! !

!SycMethodNameEditorTest methodsFor: 'tests - up/down buttons' stamp: ''!
testButtonUpClickShouldModifiedPreviewFinal
	methodNameEditor argumentsList selectIndex: 2.
	methodNameEditor upButton click.
	self assert: methodNameEditor previewResult label equals: 'a: b b: a c: c'! !

!SycMethodNameEditorTest methodsFor: 'tests - up/down buttons' stamp: ''!
testButtonUpClickWithoutSelectOption
	self assert: (methodNameEditor argumentsList items collect: [ :each | each newName ]) asArray 
		equals: #(a b c).
	methodNameEditor downButton click.
	self assert: (methodNameEditor argumentsList items collect: [ :each | each newName ]) asArray
		equals: #(b a c)! !

!SycMethodNameEditorTest methodsFor: 'tests - argument selection' stamp: ''!
testAddArgument
	
	methodNameEditor := SycMethodNameEditorPresenter on: (self methodNamedFor: #a:b:c:).
	methodNameEditor canAddArgs: false.
	(methodNameEditor argumentsList contextMenu menuGroups first menuItems do: [ :e | 
		(e name = 'Add') ifTrue: [ self deny: e isVisible ] ]).
	
	methodNameEditor := SycMethodNameEditorPresenter on: (self methodNamedFor: #a:b:c:).
	methodNameEditor canAddArgs: true.
	(methodNameEditor argumentsList contextMenu menuGroups first menuItems do: [ :e | 
		(e name = 'Add') ifTrue: [ self assert: e isVisible ] ]).! !

!SycMethodNameEditorTest methodsFor: 'tests' stamp: ''!
testChangeInInputSelectorShouldChangePreviewLabelFinal
	methodNameEditor selectorInput text: 'd:e:f:'.
	self assert: methodNameEditor previewResult label equals: 'd: a e: b f: c'! !

!SycMethodNameEditorTest methodsFor: 'tests - argument selection' stamp: ''!
testRemoveArguments
	
	methodNameEditor := SycMethodNameEditorPresenter on: (self methodNamedFor: #a:b:c:).
	methodNameEditor canRemoveArgs: false.
	(methodNameEditor argumentsList contextMenu menuGroups first menuItems do: [ :e | 
		(e name = 'Remove') ifTrue: [ self deny: e isVisible ] ]).
	
	methodNameEditor := SycMethodNameEditorPresenter on: (self methodNamedFor: #a:b:c:).
	methodNameEditor canRemoveArgs: true.
	(methodNameEditor argumentsList contextMenu menuGroups first menuItems do: [ :e | 
		(e name = 'Remove') ifTrue: [ self assert: e isVisible ] ]).! !

!SycMethodNameEditorTest methodsFor: 'accessing' stamp: ''!
a 
	 ! !

!SycMethodNameEditorTest methodsFor: 'tests' stamp: ''!
testChangeInInputSelectorWithNothingShouldChangePreviewLabelFinalWithFailedText
	methodNameEditor selectorInput text: ''.
	self assert: methodNameEditor previewResult label equals: '(invalid)'! !

!SycMethodNameEditorTest methodsFor: 'running' stamp: ''!
methodNamedFor: aSymbol
	^ RBMethodName 
		selector: (self class >> aSymbol) selector 
		arguments: ((self class >> aSymbol) ast arguments collect: [:each | each name])! !

!SycMethodNameEditorTest methodsFor: 'tests - up/down buttons' stamp: ''!
testButtonUpClickShouldModifiedArgumentsList
	methodNameEditor argumentsList selectIndex: 2.
	self assert: (methodNameEditor argumentsList items collect: [ :each | each newName ]) asArray 
		equals: #(a b c).
	methodNameEditor downButton click.
	self assert: (methodNameEditor argumentsList items collect: [ :each | each newName ]) asArray 
		equals: #(a c b)! !

!SycMethodNameEditorTest methodsFor: 'tests - up/down buttons' stamp: ''!
testButtonDownClickShouldModifiedPreviewFinal
	methodNameEditor argumentsList selectIndex: 1.
	methodNameEditor downButton click.
	self assert: methodNameEditor previewResult label equals: 'a: b b: a c: c'! !

!SycMethodNameEditorTest methodsFor: 'tests - up/down buttons' stamp: ''!
testButtonDownClickShouldSelectionIndexBeDecremented
	methodNameEditor argumentsList selectIndex: 1.
	methodNameEditor downButton click.
	self assert: methodNameEditor argumentsList selection selectedIndex equals: 2! !

!SycMethodNameEditorTest methodsFor: 'accessing' stamp: ''!
a: a b: b c: c
	 ! !

!SycMethodNameEditorTest methodsFor: 'tests - up/down buttons' stamp: ''!
testButtonDownClickWithoutSelectOption
	| arrayBeforeClick arrayAfterClick |
	arrayBeforeClick := methodNameEditor argumentsList items.
	self assert: (arrayBeforeClick collect: [ :each | each newName ]) asArray equals: #(a b c).
	methodNameEditor downButton click.
	arrayAfterClick := methodNameEditor argumentsList items.
	self assert: (arrayAfterClick collect: [ :each | each newName ]) asArray equals: #(b a c).! !

!SycMethodNameEditorTest methodsFor: 'tests - up/down buttons' stamp: ''!
testButtonUpClickShouldSelectionIndexBeDecremented
	methodNameEditor argumentsList selectIndex: 2.
	methodNameEditor upButton click.
	self assert: methodNameEditor argumentsList selection selectedIndex equals: 1! !

!SycMethodNameEditorTest methodsFor: 'tests - initial state' stamp: ''!
testInitialButtonDownIsDisable
	methodNameEditor := SycMethodNameEditorPresenter on: (self methodNamedFor: #a).
	self deny: methodNameEditor downButton isEnabled! !

!SycMethodNameEditorTest methodsFor: 'tests - argument selection' stamp: ''!
testRenameArgument
	
	methodNameEditor := SycMethodNameEditorPresenter on: (self methodNamedFor: #a:b:c:).
	methodNameEditor canRenameArgs: false.
	(methodNameEditor argumentsList contextMenu menuGroups first menuItems do: [ :e | 
		(e name = 'Rename') ifTrue: [ self deny: e isVisible ] ]).
	
	methodNameEditor := SycMethodNameEditorPresenter on: (self methodNamedFor: #a:b:c:).
	methodNameEditor canRenameArgs: true.
	(methodNameEditor argumentsList contextMenu menuGroups first menuItems do: [ :e | 
		(e name = 'Rename') ifTrue: [ self assert: e isVisible ] ]).! !

!SycMethodNameEditorTest methodsFor: 'tests' stamp: ''!
testChangeInInputSelectorWithFewAccessorThanArgumentsShouldChangePreviewLabelFinalWithFailedText
	methodNameEditor selectorInput text: 'd:'.
	self assert: methodNameEditor previewResult label equals: '(invalid)'! !

!SycMethodNameEditorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	methodNameEditor := SycMethodNameEditorPresenter on: (self methodNamedFor: #a:b:c:)! !

!SycMethodRepackagingCommand commentStamp: ''!
I am a base class for commands which repackage given methods.

I provide suitable methods for subclasses to move methods to package: 

- moveMethod: aMethod toPackage: aPackage

Subclasses should just decide what package it should be. !
!SycMethodRepackagingCommand methodsFor: 'execution' stamp: ''!
moveMethod: aMethod toPackage: aPackage
	| existingPackage wasExtension willBeExtension |
	existingPackage := aMethod package.
	existingPackage == aPackage ifTrue: [ ^ self ].
	wasExtension := aMethod isExtension.
	willBeExtension := aPackage ~~ aMethod origin package.
	aPackage addMethod: aMethod.
	willBeExtension ifTrue: [ 
		aMethod tagWith: ('*' , aPackage name) asSymbol ].
	wasExtension ifFalse: [ ^ self ].
	aMethod untagFrom: ('*' , existingPackage name) asSymbol.
	self tagMethod: aMethod! !

!SycMethodRepackagingCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = SycMethodRepackagingCommand ! !

!SycMigrateReferencesOfClassCommand commentStamp: ''!
I am a command to migrate references of a given class to another.

Internal Representation and Key Implementation Points.

Instance Variables
newName:  <String>!
!SycMigrateReferencesOfClassCommand methodsFor: 'converting' stamp: ''!
asRefactorings
	| refactoring |
	refactoring :=  RBDeprecateClassRefactoring deprecate: targetClass in: newName name.
	refactoring shouldFixSubclasses: false.
	refactoring shouldCopyExtensions: false.
	refactoring shouldRemoveExtensions: false.
	^ { refactoring }! !

!SycMigrateReferencesOfClassCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring 
	^ true! !

!SycMigrateReferencesOfClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Migrate references'! !

!SycMigrateReferencesOfClassCommand methodsFor: 'execution' stamp: ''!
execute
	
	self asRefactorings do: [ :ref | ref execute ]! !

!SycMigrateReferencesOfClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext

	super prepareFullExecutionInContext: aToolContext.
	newName := aToolContext browser searchDialog 
		requestSingleObject: 'Choose new class' 
		from: ClyAllClassesQuery sorted.
	newName ifNil: [ CmdCommandAborted signal]! !

!SycMigrateReferencesOfClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #source! !

!SycMigrateReferencesOfClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.3 for: ClySourceCodeContext! !

!SycMigrateReferencesOfClassCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 1.4 for: ClyFullBrowserClassContext! !

!SycMockRBRefactoring methodsFor: 'accessing' stamp: ''!
environment: anEnvironement
	^ self! !

!SycMockRBRefactoring methodsFor: 'accessing' stamp: ''!
environment
	^ self! !

!SycMockRBRefactoring methodsFor: 'accessing' stamp: ''!
whatToDisplayIn: aBrowser 
	^ aBrowser scopeDropList selectedItem content! !

!SycMockRBRefactoring methodsFor: 'accessing' stamp: ''!
model: aRBNamespace 
	^ self 	! !

!SycMockRBRefactoring methodsFor: 'accessing' stamp: ''!
model
	^ self! !

!SycMockRBRefactoring methodsFor: 'accessing' stamp: ''!
primitiveExecute 
	^self ! !

!SycMockScope commentStamp: ''!
I am a mock to emulate a refactoring scope.!
!SycMockScope methodsFor: 'accessing' stamp: ''!
content: anObject
	content := anObject! !

!SycMockScope methodsFor: 'accessing' stamp: ''!
content
	^ content! !

!SycMockScope class methodsFor: 'accessing' stamp: ''!
content: aCollection
	^ self new
		content: aCollection;
		yourself! !

!SycMoveMethodsToClassCommand commentStamp: ''!
I am a command to move methods to given class
 
Internal Representation and Key Implementation Points.

    Instance Variables
	targetClass:		<Class>!
!SycMoveMethodsToClassCommand methodsFor: 'accessing' stamp: ''!
targetClass: anObject
	targetClass := anObject! !

!SycMoveMethodsToClassCommand methodsFor: 'drag and drop support' stamp: ''!
prepareExecutionInDropContext: aToolContext
	super prepareExecutionInDropContext: aToolContext.
	targetClass := aToolContext lastSelectedClass.
	targetClass := aToolContext currentMetaLevelOf: targetClass! !

!SycMoveMethodsToClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Move to another class'! !

!SycMoveMethodsToClassCommand methodsFor: 'execution' stamp: ''!
execute
	methods 
		collect: [ :each | RBMoveMethodToClassRefactoring model: model method: each class: targetClass ]
		thenDo: [ :each | each execute ].
	methods do: [ :each | each origin organization removeEmptyCategories ].! !

!SycMoveMethodsToClassCommand methodsFor: 'accessing' stamp: ''!
targetClass
	^ targetClass! !

!SycMoveMethodsToClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	targetClass := aToolContext requestSingleClass: 'Choose class'.
	targetClass := aToolContext currentMetaLevelOf: targetClass! !

!SycMoveMethodsToClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallRedo! !

!SycMoveMethodsToClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 60 for: ClyMethod asCalypsoItemContext! !

!SycMoveMethodsToClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodBrowserDragAndDropActivation
	<classAnnotation>
	
	^CmdDragAndDropActivation 
		for: ClyMethod asCalypsoItemContext toDropIn: ClyClass asCalypsoItemContext! !

!SycMoveMethodsToClassCommand class methodsFor: 'instance creation' stamp: ''!
methods: methods class: targetClass
	^(self for: methods)
		targetClass: targetClass
		! !

!SycMoveMethodsToClassSideCommand commentStamp: ''!
I am a command to move method to the class side of defining class!
!SycMoveMethodsToClassSideCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Move to class side'! !

!SycMoveMethodsToClassSideCommand methodsFor: 'execution' stamp: ''!
execute
	
	methods 
		collect: [ :each | RBMoveMethodToClassRefactoring model: model method: each class: each origin classSide]
		thenDo: [ :each | each execute ]! !

!SycMoveMethodsToClassSideCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallRedo! !

!SycMoveMethodsToClassSideCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 50 for: ClyMethod asCalypsoItemContext! !

!SycMoveMethodsToClassSideCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $t meta, $c meta for: ClyMethod asCalypsoItemContext! !

!SycMoveMethodsToClassSideCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^(super canBeExecutedInContext: aToolContext)
		and: [ aToolContext isInstanceSideMethodSelected ]! !

!SycMoveMethodsToInstanceSideCommand commentStamp: ''!
I am a command to move method to the instance side of defining class!
!SycMoveMethodsToInstanceSideCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Move to instance side'! !

!SycMoveMethodsToInstanceSideCommand methodsFor: 'execution' stamp: ''!
execute
	
	methods 
		collect: [ :each | RBMoveMethodToClassRefactoring model: model method: each class: each origin instanceSide]
		thenDo: [ :each | each execute ]! !

!SycMoveMethodsToInstanceSideCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallRedo! !

!SycMoveMethodsToInstanceSideCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 50 for: ClyMethod asCalypsoItemContext! !

!SycMoveMethodsToInstanceSideCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $t meta, $i meta for: ClyMethod asCalypsoItemContext! !

!SycMoveMethodsToInstanceSideCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^(super canBeExecutedInContext: aToolContext)
		and: [ aToolContext isClassSideMethodSelected ]! !

!SycMoveMethodsToPackageCommand commentStamp: ''!
I am a command to move method to another package.

I am used to convert method to extension.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	package:		<RPackage>!
!SycMoveMethodsToPackageCommand methodsFor: 'execution' stamp: ''!
prepareExecutionInDropContext: aToolContext
	super prepareExecutionInDropContext: aToolContext.
	package := aToolContext lastSelectedPackage! !

!SycMoveMethodsToPackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Move to package'! !

!SycMoveMethodsToPackageCommand methodsFor: 'execution' stamp: ''!
execute
	
	methods do: [ :each | 
		self moveMethod: each toPackage: package.
		each origin organization removeEmptyCategories ]! !

!SycMoveMethodsToPackageCommand methodsFor: 'accessing' stamp: ''!
package: anObject
	package := anObject! !

!SycMoveMethodsToPackageCommand methodsFor: 'accessing' stamp: ''!
package
	^ package! !

!SycMoveMethodsToPackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallRedo! !

!SycMoveMethodsToPackageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	package := aToolContext requestSinglePackage: 'Choose package'! !

!SycMoveMethodsToPackageCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 70 for: ClyMethod asCalypsoItemContext! !

!SycMoveMethodsToPackageCommand class methodsFor: 'instance creation' stamp: ''!
for: methods to: aPackage
	^(self for: methods) 
		package: aPackage! !

!SycMoveMethodsToPackageCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodBrowserDragAndDropActivation
	<classAnnotation>
	
	^CmdDragAndDropActivation 
		for: ClyMethod asCalypsoItemContext 
		toDropIn: RPackage asCalypsoItemContext! !

!SycMoveMethodsToPackageDefiningClassCommand commentStamp: ''!
I am a command to move method to the package of defining class.

I am used to convert extension method to normal one!
!SycMoveMethodsToPackageDefiningClassCommand methodsFor: 'accessing' stamp: ''!
targetTagName
	^ targetTagName! !

!SycMoveMethodsToPackageDefiningClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Move to package defining the class'! !

!SycMoveMethodsToPackageDefiningClassCommand methodsFor: 'execution' stamp: ''!
execute

	| classPackage |
	methods do: [ :each | 
		classPackage := each origin package.
		self moveMethod: each toPackage: classPackage.
		each tagWith: targetTagName]! !

!SycMoveMethodsToPackageDefiningClassCommand methodsFor: 'accessing' stamp: ''!
targetTagName: anObject
	targetTagName := anObject! !

!SycMoveMethodsToPackageDefiningClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	targetTagName := aToolContext requestSingleMethodTag: 'Choose protocol for methods'! !

!SycMoveMethodsToPackageDefiningClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #smallRedo! !

!SycMoveMethodsToPackageDefiningClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 80 for: ClyMethod asCalypsoItemContext! !

!SycMoveMethodsToPackageDefiningClassCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isExtensionMethodSelected! !

!SycNewMoveToClassSideCommand commentStamp: ''!
I am a command to move method to the class side of defining class!
!SycNewMoveToClassSideCommand methodsFor: 'preparation' stamp: ''!
prepareFullExecution
	super prepareFullExecution.
	methods := context selectedMethods.! !

!SycNewMoveToClassSideCommand methodsFor: 'accessing' stamp: ''!
isEnabled

	^ context isInstanceSideMethodSelected! !

!SycNewMoveToClassSideCommand methodsFor: 'accessing' stamp: ''!
executeRefactoring
	
	methods 
		collect: [ :each | RBMoveMethodToClassSideRefactoring 
			model: model
			method: each 
			class: each origin ]
		thenDo: [ :each | each execute ]! !

!SycNewMoveToClassSideCommand methodsFor: 'accessing' stamp: ''!
name 
	^ 'New move to class side'! !

!SycNewMoveToClassSideCommand methodsFor: 'accessing' stamp: ''!
icon 
	^ self iconNamed: #smallRedo! !

!SycNotRemoveClassStrategy commentStamp: ''!
I am the strategy to be used when a user cancels a class removal. !
!SycNotRemoveClassStrategy methodsFor: 'execution' stamp: ''!
orderForBrowser
	"Cancelling the remove of command should be at the end of list"
	^super orderForBrowser + 1.! !

!SycNotRemoveClassStrategy methodsFor: 'execution' stamp: ''!
execute: aSycRemoveClassCommand! !

!SycNotRemoveClassStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	^'Forget it -- do nothing -- sorry I asked'! !

!SycNotRemoveClassStrategy class methodsFor: 'testing' stamp: ''!
canExecuteWithReferences: hasReferences subclasses: hasSubclasses users: hasUsers
	^true! !

!SycNotRemoveMethodStrategy commentStamp: ''!
I am simple cancel method remove operation by doing nothing!
!SycNotRemoveMethodStrategy methodsFor: 'execution' stamp: ''!
removeMethods: methods
! !

!SycNotRemoveMethodStrategy methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
orderForBrowser
	"Cancelling the remove of command should be at the end of list"
	^super orderForBrowser + 1.! !

!SycNotRemoveMethodStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	^'Forget it -- do nothing -- sorry I asked'! !

!SycOpenClassMenuCommand commentStamp: ''!
I am a command to open special class menu.
I show in menu all commands annotated by SycClassMenuActivation class!
!SycOpenClassMenuCommand methodsFor: 'execution' stamp: ''!
defaultMenuItemName
	^'Refactorings'! !

!SycOpenClassMenuCommand methodsFor: 'execution' stamp: ''!
activationStrategy 
	^ SycClassMenuActivation! !

!SycOpenClassMenuCommand methodsFor: 'context menu' stamp: ''!
cmCommandClass 
	^ SycClassCmCommand! !

!SycOpenClassMenuCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserTabActivation
	<classAnnotation>
	
	^ClyBrowserTabCommandActivation for: ClyFullBrowserClassContext! !

!SycOpenClassMenuCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 10100 
		for: ClyClass asCalypsoItemContext! !

!SycOpenClassMenuCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $t meta for: ClyClass asCalypsoItemContext! !

!SycOpenContextMenuCommand commentStamp: ''!
I am a command to open special context menu.
I show in menu all commands annotated by activationStrategy class!
!SycOpenContextMenuCommand methodsFor: 'context menu' stamp: ''!
registerContextMenuItemsFor: aCommandItem withBuilder: aBuilder

	"Here we need to take care because this command itself is added to menu of same context.
	So we will always enter into this method during submenu generation. 
	We catch this recursion using RecursionStopper. 
	It is easier than adding extra logic to menu registration process"

	| submenu |
	RecursionStopper during: [ 
		submenu := self activationStrategy buildMenuInContext: context.
		submenu isActive ifTrue: [ 
			self
				doRegisterContextMenuItemsFor: aCommandItem
				withBuilder: aBuilder.
			self cmCommandClass addItemsToSubmenu: submenu forContext: context.

			"Registration builder uses #name to bind children to parent"
			submenu rootGroup name: aCommandItem name.
			submenu registerContextMenuItemsWithBuilder: aBuilder ] ]! !

!SycOpenContextMenuCommand methodsFor: 'context menu' stamp: ''!
cmCommandClass
	self subclassResponsibility ! !

!SycOpenContextMenuCommand methodsFor: 'execution' stamp: ''!
createContextMenu

	| menuMorph |
	menuMorph := super createContextMenu.
	self cmCommandClass addMenuItemsTo: menuMorph onContext: self context.
	^ menuMorph! !

!SycOpenDebuggingMenuCommand commentStamp: ''!
I am a command to open the debugging menu after a right click on the source code.
I show in the menu all commands annotated by SycDebuggingMenuActivation!
!SycOpenDebuggingMenuCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Debugging'! !

!SycOpenDebuggingMenuCommand methodsFor: 'execution' stamp: ''!
activationStrategy
	^SycDebuggingMenuActivation ! !

!SycOpenDebuggingMenuCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallDebugIcon ! !

!SycOpenDebuggingMenuCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: -1 for: ClySourceCodeContext! !

!SycOpenDebuggingMenuCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodEditorShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $g meta shift for: ClySourceCodeContext! !

!SycOpenMethodMenuCommand commentStamp: ''!
I am a command to open special method menu.
I show in menu all commands annotated by SycMethodMenuActivation!
!SycOpenMethodMenuCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Refactorings'! !

!SycOpenMethodMenuCommand methodsFor: 'execution' stamp: ''!
execute

	context selectedTextInterval ifEmpty: [ 
		context showSourceNode].
	
	super execute! !

!SycOpenMethodMenuCommand methodsFor: 'execution' stamp: ''!
activationStrategy 
	^ SycMethodMenuActivation! !

!SycOpenMethodMenuCommand methodsFor: 'context menu' stamp: ''!
cmCommandClass 
	^ SycMethodCmCommand! !

!SycOpenMethodMenuCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 10100 for: ClyMethod asCalypsoItemContext! !

!SycOpenMethodMenuCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodEditorShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $t meta for: ClyMethod asCalypsoItemContext! !

!SycOpenProtocolMenuCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Scope'! !

!SycOpenProtocolMenuCommand methodsFor: 'execution' stamp: ''!
activationStrategy 
	^ SycProtocolMenuActivation! !

!SycOpenProtocolMenuCommand methodsFor: 'context menu' stamp: ''!
cmCommandClass 
	^ SycProtocolCmCommand! !

!SycOpenProtocolMenuCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMethodGroupMenuActivation
	<classAnnotation>

	^ CmdContextMenuActivation byRootGroupItemOrder: 10002 for: ClyFullBrowserMethodGroupContext! !

!SycOpenSourceCodeMenuCommand commentStamp: ''!
I am a command to open special source code menu.
I show in menu all commands annotated by SycSourceCodeMenuActivation!
!SycOpenSourceCodeMenuCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Source code'! !

!SycOpenSourceCodeMenuCommand methodsFor: 'execution' stamp: ''!
execute

	context selectedTextInterval ifEmpty: [ 
		context showSourceNode].
	
	super execute! !

!SycOpenSourceCodeMenuCommand methodsFor: 'execution' stamp: ''!
activationStrategy
	^SycSourceCodeMenuActivation ! !

!SycOpenSourceCodeMenuCommand methodsFor: 'context menu' stamp: ''!
cmCommandClass

	^ SycSourceCodeCmCommand! !

!SycOpenSourceCodeMenuCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#smallAuthoringTools! !

!SycOpenSourceCodeMenuCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: -10 for: ClySourceCodeContext! !

!SycOpenSourceCodeMenuCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodEditorShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $t meta for: ClySourceCodeContext! !

!SycPackageCommand commentStamp: ''!
I am a base class for commands which perform operations with given packages.

Internal Representation and Key Implementation Points.

    Instance Variables
	packages:		<Collection of<RPackage>>!
!SycPackageCommand methodsFor: 'accessing' stamp: ''!
packages
	^ packages! !

!SycPackageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	packages := aToolContext selectedPackages! !

!SycPackageCommand methodsFor: 'accessing' stamp: ''!
packages: anObject
	packages := anObject! !

!SycPackageCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = SycPackageCommand ! !

!SycPackageCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isPackageSelected! !

!SycPromotePackageFromTagCommand commentStamp: ''!
I am a command to promote given package and tag to be separate package.

Internal Representation and Key Implementation Points.

    Instance Variables
	classTag:		<Symbol>
	package:		<RPackage>
!
!SycPromotePackageFromTagCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aBrowserContext

	| newPackage |
	newPackage := (package name, '-', classTag) asPackage.
	aBrowserContext showPackage: newPackage! !

!SycPromotePackageFromTagCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Promote as package'! !

!SycPromotePackageFromTagCommand methodsFor: 'execution' stamp: ''!
execute

	| packageTag |
	packageTag := package classTagNamed: classTag.
	packageTag promoteAsRPackage! !

!SycPromotePackageFromTagCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	package := aToolContext lastSelectedPackage.
	classTag := aToolContext lastSelectedClassTag! !

!SycPromotePackageFromTagCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: ClyTaggedClassGroup asCalypsoItemContext! !

!SycPromotePackageFromTagCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isPackageSelected and: [aToolContext isClassTagSelected]! !

!SycProtectVariableCommand commentStamp: ''!
I am a command to protect given variables!
!SycProtectVariableCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	^self 
		createRefactorings: RBProtectInstanceVariableRefactoring 
		using: [ :refactoring :var |
			refactoring variable: var name class: var definingClass ]! !

!SycProtectVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Protect'! !

!SycProtectVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #group! !

!SycProtectVariableCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.2 for: ClySourceCodeContext ! !

!SycProtectVariableCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 2000 for: ClyFullBrowserVariableContext! !

!SycProtocolCmCommand commentStamp: ''!
This class is an extension so we can mix command of Commander2 with Commander.!
!SycProtocolCmCommand methodsFor: 'preparation' stamp: ''!
prepareFullExecution
	super prepareFullExecution.
	methodGroups := context selectedMethodGroups! !

!SycProtocolCmCommand class methodsFor: 'execution' stamp: ''!
activationStrategy 
	^ SycProtocolMenuActivation! !

!SycPushDownMethodCommand commentStamp: ''!
I am a command to push down given methods!
!SycPushDownMethodCommand methodsFor: 'execution' stamp: ''!
asRefactorings
	"Return push down method refactoring using method"
	| refactoring |
	refactoring := RBPushDownMethodRefactoring 
		model: model
		pushDown: (methods collect: [ :each | each selector ])
		from: methods first origin.
	^ OrderedCollection with: refactoring ! !

!SycPushDownMethodCommand methodsFor: 'execution' stamp: ''!
selectMethods
	| dialog class|
	class := methods first origin.
	dialog := RBMethodsSelectionPresenter 
		   label: 'Push down methods from ', class name
			withItems: (class methods sort: [ :a :b | a asString < b asString ]) asOrderedCollection
			selecting: methods asOrderedCollection. 
	dialog cancelled ifTrue: [ CmdCommandAborted signal ].
	methods := dialog presenter selectedItems.! !

!SycPushDownMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Push down'! !

!SycPushDownMethodCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	self selectMethods.! !

!SycPushDownMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #down! !

!SycPushDownMethodCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 20 for: ClyMethod asCalypsoItemContext! !

!SycPushDownMethodCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $p meta, $d meta for: ClyMethod asCalypsoItemContext! !

!SycPushDownMethodInSomeClassesCommand methodsFor: 'converting' stamp: ''!
asRefactorings
	"Return push down method refactoring using method"
	| refactoring |
	refactoring := RBPushDownMethodRefactoring 
		model: model
		pushDown: (methods collect: [ :each | each selector ])
		from: methods first origin
		in: self classes.
	^ OrderedCollection with: refactoring ! !

!SycPushDownMethodInSomeClassesCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Push down in some classes'! !

!SycPushDownMethodInSomeClassesCommand methodsFor: 'execution' stamp: ''!
selectMethodsAndClasses
	| dialog class|
	class := methods first origin.
	dialog := RBMethodsSelectionPresenter 
		   label: 'Push down methods from ', class name
			withItems: (class methods sort: [ :a :b | a asString < b asString ]) asOrderedCollection
			selecting: methods asOrderedCollection. 
	dialog cancelled ifTrue: [ CmdCommandAborted signal ].
	methods := dialog presenter selectedItems.
	dialog := RBVariablesSelectionPresenter 
		   label: 'Push down in classes: '
			withItems: (class subclasses sort: [ :a :b | a name < b name ]) asOrderedCollection
			selecting: class subclasses. 
	dialog cancelled ifTrue: [ CmdCommandAborted signal ].
	classes := (dialog presenter selectedItems) collect: [ :each | each name ]! !

!SycPushDownMethodInSomeClassesCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	self selectMethodsAndClasses.! !

!SycPushDownMethodInSomeClassesCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #down! !

!SycPushDownMethodInSomeClassesCommand methodsFor: 'converting' stamp: ''!
classes
	^ classes ifNil: [ classes := #() ]! !

!SycPushDownMethodInSomeClassesCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 21 for: ClyMethod asCalypsoItemContext! !

!SycPushDownVariableCommand commentStamp: ''!
I am a command to push down given variables!
!SycPushDownVariableCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	^self 
		createRefactorings: RBPushDownInstanceVariableRefactoring! !

!SycPushDownVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Push down'! !

!SycPushDownVariableCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	| noUsers |
	super prepareFullExecutionInContext: aToolContext.
	
	noUsers := aToolContext confirmUnusedVariablesInDefiningClass: variables.
	noUsers ifFalse: [ CmdCommandAborted signal ]! !

!SycPushDownVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #down! !

!SycPushDownVariableCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.4 for: ClySourceCodeContext! !

!SycPushDownVariableCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 2001 for: ClyFullBrowserVariableContext! !

!SycPushUpMethodCommand commentStamp: ''!
I am a command to push up given methods!
!SycPushUpMethodCommand methodsFor: 'execution' stamp: ''!
asRefactorings
	| refactoring |
	refactoring :=  RBPullUpMethodRefactoring 
		model: model
		pullUp: (methods collect: [ :each | each selector ])
		from: methods first origin.
	refactoring superClass: superclass.
	^ OrderedCollection with: refactoring ! !

!SycPushUpMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Push up'! !

!SycPushUpMethodCommand methodsFor: 'execution' stamp: ''!
selectMethodsAndSuperclass
	| dialog class classes |
	class := methods first origin.
	classes := class allSuperclasses removeAllSuchThat: [ :each | each == Object or: [ each == ProtoObject ] ].
	dialog := RBSelectClassAndMethodsPresenter 
			label: 'Methods to be pull up'
			dropLabel: 'Pull up methods of ', class name, ' to:'
			withItems: (class methods sort: [ :a :b | a asString < b asString ]) asOrderedCollection
			selecting: methods asOrderedCollection
			dropItems: classes
			acceptBlock: [ :item :items | superclass := item.
				methods := items ].
	dialog cancelled ifTrue: [ CmdCommandAborted signal ].! !

!SycPushUpMethodCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	self selectMethodsAndSuperclass.! !

!SycPushUpMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #up! !

!SycPushUpMethodCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 10 for: ClyMethod asCalypsoItemContext! !

!SycPushUpMethodCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation by: $p meta, $u meta for: ClyMethod asCalypsoItemContext! !

!SycPushUpVariableCommand commentStamp: ''!
I am a command to push up given variables!
!SycPushUpVariableCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	^self 
		createRefactorings: RBPullUpInstanceVariableRefactoring 
		using: [ :refactoring :var |
			refactoring variable: var name class: var definingClass superclass]! !

!SycPushUpVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Push up'! !

!SycPushUpVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #up! !

!SycPushUpVariableCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.3 for: ClySourceCodeContext! !

!SycPushUpVariableCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 2000 for: ClyFullBrowserVariableContext! !

!SycRealizeClassCommand commentStamp: ''!
I am a command to generate all unimplemented methods of the given classes!
!SycRealizeClassCommand methodsFor: 'execution' stamp: ''!
asRefactorings
	
	^classes collect: [ :each | RBRealizeClassRefactoring className: each]! !

!SycRealizeClassCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	^true! !

!SycRealizeClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Realize'! !

!SycRealizeClassCommand methodsFor: 'execution' stamp: ''!
execute

	self executeRefactorings! !

!SycRealizeClassCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 2.1 for: ClyFullBrowserClassContext! !

!SycRecompilePackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Recompile'! !

!SycRecompilePackageCommand methodsFor: 'execution' stamp: ''!
execute
	packages 
		do: [ :eachPackage | 
			eachPackage methods do: [ :eachMethod | eachMethod recompile ] ]
		displayingProgress: [:eachPackage | 'Recompiling ', eachPackage name]! !

!SycRecompilePackageCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: CmdExtraMenuGroup for: RPackage asCalypsoItemContext! !

!SycRefactorVariableCommand commentStamp: ''!
I am a base class for command which perform particular kind refactoring on given variables.

I provide suitable method to create refactoring instances: 

- createRefactorings: variableRefactoringClass
- createRefactorings: variableRefactoringClass using: initBlock

Subclasses use this methods to create refactoring instances.

I delegate actual refactoring instantiation to the each variable. It allows abstract difference between different kind of variables and to have single command for same kind of class variable refactoring and instance variable refactoring:

	eachVar createVariableRefactoring: variableRefactoringClass
	
Look at #createVariableRefactoring: implementors for details.!
!SycRefactorVariableCommand methodsFor: 'execution' stamp: ''!
createRefactorings: variableRefactoringClass
	^self createRefactorings: variableRefactoringClass using: [ ]! !

!SycRefactorVariableCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	^true! !

!SycRefactorVariableCommand methodsFor: 'execution' stamp: ''!
execute

	self executeRefactorings! !

!SycRefactorVariableCommand methodsFor: 'execution' stamp: ''!
createRefactorings: variableRefactoringClass using: initBlock
	| refactoring |
	^variables collect: [ :eachVar |
		refactoring := eachVar createVariableRefactoring: variableRefactoringClass.
		initBlock cull: refactoring cull: eachVar.
		refactoring]! !

!SycRefactorVariableCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = SycRefactorVariableCommand ! !

!SycRefactorVariableCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^(super canBeExecutedInContext: aToolContext)
		and: [ aToolContext isGlobalVariableSelected not ]! !

!SycRefactoringPreviewMockCommand methodsFor: 'converting' stamp: ''!
asRefactorings 
	^ { SycMockRBRefactoring new  } ! !

!SycRefactoringPreviewPresenter commentStamp: ''!
I am a GUI used to preview the impact of a refactoring and select the changes to apply.

Examples

	scopePackage := ClyPackageScope of: 'Stage' asPackage in: ClyNavigationEnvironment currentImage.
	scopeClass := ClyClassScope of: 'SycRefactoringPreview' in: ClyNavigationEnvironment currentImage.
	
	SycRefactoringPreview2 for:  scope: { scopePackage . scopeClass } 



Instance Variables
	changes:						<ArrayOfRBRefactroring>	The collection of changes that can be applied with the refactoring.
	scopeDropList:				<DropListPresenter>		A drop list to let the user chose the scope of the refactoring to apply. (All image, current package, current class...)				
	selectedRefactorings:		<Dictionary>					A dictionary remembering for all refactorings if they should be applied.	
	table:							<TablePresenter>			A table to display the possible refactorings.
	diffPresenter				<DiffPresenter>				A diff presenter to show the users the consequences of the refactorings.
	!
!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
existChanges
	^ existsChanges ifNil: [ existsChanges := false ]! !

!SycRefactoringPreviewPresenter methodsFor: 'update' stamp: ''!
selectectAllCheckBox
	selectedRefactorings := Dictionary new.
	table items do: [ :refactoring | selectedRefactorings at: refactoring put: true ]! !

!SycRefactoringPreviewPresenter methodsFor: 'initialization' stamp: ''!
columns

	^ { (SpCompositeTableColumn new
		   addColumn:
			   ((SpCheckBoxTableColumn evaluated: [ :x | selectedRefactorings at: x ])
				    onActivation: [ :class | self toggleSelectionOf: class ];
				    onDeactivation: [ :class | self toggleSelectionOf: class ];
				    width: 20);
		   addColumn: (SpStringTableColumn evaluated: #name);
		   yourself) }! !

!SycRefactoringPreviewPresenter methodsFor: 'initialization' stamp: ''!
initializeWidgets

	diffPresenter := self newDiff.
	scopeDropList := self newDropList.
	table := self newTable.
	
	table columns: self columns;
		hideColumnHeaders.

	diffPresenter disable.
	scopeDropList display: [ :scope | scope description capitalized ].

	self
		selectectAllCheckBox;
		setFocus! !

!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
pickedChanges
	^ table items select: [ :item | selectedRefactorings at: item ]! !

!SycRefactoringPreviewPresenter methodsFor: 'update' stamp: ''!
generateChanges

	| rbEnvironment |
	changes := command asRefactorings.
	rbEnvironment := changes first model environment.
	changes do: [ :each | 
		each model environment: rbEnvironment.
		each primitiveExecute ]! !

!SycRefactoringPreviewPresenter methodsFor: 'controlling' stamp: ''!
accept
	self okToChange ifFalse: [ ^ self ].
	[ self pickedChanges do: [ :change | 
		RBRefactoryChangeManager instance 
			performChange: change; 
			addUndoPointer: (RBRefactoryChangeManager nextCounter) ] ] asJob
		title: 'Refactoring';
		run! !

!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
changes
	^ changes! !

!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
changes: aCollection
	changes := aCollection.
	self generateChanges ! !

!SycRefactoringPreviewPresenter methodsFor: 'private' stamp: ''!
toggleSelectionOf: aRefactoring
	"it's normal it's impossible that anItem doesn't store in dictionary because at initialize I fill the dictionary and at each scope change"
	selectedRefactorings at: aRefactoring put: (selectedRefactorings at: aRefactoring) not.
	self selectItemBelow: aRefactoring ! !

!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
table
	^ table! !

!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
title
	^ self class title! !

!SycRefactoringPreviewPresenter methodsFor: 'initialization' stamp: ''!
setFocus
	self focusOrder
		add: table;
		add: scopeDropList;
		add: diffPresenter! !

!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
activeRBEnvironment
	^ self activeScope asRBEnvironment! !

!SycRefactoringPreviewPresenter methodsFor: 'epicea support' stamp: ''!
asEpiceaEvent
	"thanks to this method epicia know that is a refactoring"
	
	self flag: #todo. "This is a workaround for a problem found by RewriteTool"
	(changes allSatisfy: [ :each | each respondsTo: #asEpiceaEvent ])
		ifFalse: [ ^ EpCompositeRefactoring withAll: #() ].

	^ changes size > 1
		ifTrue: [ EpCompositeRefactoring withAll: changes ]
		ifFalse: [ changes anyOne asEpiceaEvent ].! !

!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
command: aCommand
	command := aCommand! !

!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
scopeDropList
	^ scopeDropList! !

!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
activeScope
	^ scopeDropList selectedItem! !

!SycRefactoringPreviewPresenter methodsFor: 'private' stamp: ''!
selectItemBelow: aRefactoring 

	| nextIndex |
	nextIndex := (self table items indexOf: aRefactoring) + 1.
	self table selectIndex: nextIndex scrollToSelection: true! !

!SycRefactoringPreviewPresenter methodsFor: 'services' stamp: ''!
alert: aString
	"Display a message for the user to read and then dismiss."

	aString isEmptyOrNil ifFalse: [ self uiManager alert: aString ]! !

!SycRefactoringPreviewPresenter methodsFor: 'initialization' stamp: ''!
initializeDialogWindow: aDialogWindowPresenter
	aDialogWindowPresenter
		title: self title;
		initialExtent: 500 @ 500;
		addButton: 'Apply'
			do: [ :presenter | 
			self accept.
			presenter close ];
		addButton: 'Cancel' do: [ :presenter | presenter close ]! !

!SycRefactoringPreviewPresenter methodsFor: 'epicea support' stamp: ''!
isEpiceaInterestingJobOwner

	^ true! !

!SycRefactoringPreviewPresenter methodsFor: 'accessing' stamp: ''!
scopes: aCollectionOfScopes
	scopeDropList items: aCollectionOfScopes "It also sets up first item as selection"! !

!SycRefactoringPreviewPresenter methodsFor: 'update' stamp: ''!
updateChanges
	self generateChanges.
	self updateTablePresenter.
	self selectectAllCheckBox! !

!SycRefactoringPreviewPresenter methodsFor: 'update' stamp: ''!
updateTablePresenter
	| aCompositeChange anEnvironment |
	"We get the environment to apply the changes from any element in the changes instance variable"
	anEnvironment := changes
		ifEmpty: [ nil ]
		ifNotEmpty: [ changes anyOne model environment ].
	aCompositeChange := RBCompositeRefactoryChange new onSystemDictionary: anEnvironment.
	changes do: [ :each | aCompositeChange addChange: each ].
	table items: (aCompositeChange whatToDisplayIn: self).
	table items
		ifNotEmpty: [ table selectIndex: 1.
			existsChanges := true ]! !

!SycRefactoringPreviewPresenter methodsFor: 'initialization' stamp: ''!
connectPresenters
	table bindKeyCombination: Character backspace asShortcut 
		toAction: [ self toggleSelectionOf: table selectedItem ].
	
	{ table . scopeDropList . diffPresenter } do: [ :each | 
		each bindKeyCombination: Character cr asKeyCombination 
			toAction: [ self owner triggerOkAction; close ];
		bindKeyCombination: Character escape asKeyCombination 
			toAction: [ self owner triggerCancelAction; close ] ]! !

!SycRefactoringPreviewPresenter methodsFor: 'private' stamp: ''!
buildDiffFor: aChange
	^ diffPresenter
		leftText: aChange oldVersionTextToDisplay;
		rightText: aChange textToDisplay! !

!SycRefactoringPreviewPresenter methodsFor: 'initialization' stamp: ''!
initializePresenter
	super initializePresenter.
	table
		whenSelectionChangedDo: [ :selection | 
			selection selectedItem ifNotNil: [ 
				self buildDiffFor: selection selectedItem ] ].
	
	table
		whenActivatedDo: [ :selectedElement | 
			self toggleSelectionOf: selectedElement widget selection selectedItem ].
	
	scopeDropList
		whenSelectedItemChangedDo: [ :scope | self updateChanges ]! !

!SycRefactoringPreviewPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	^ SpBoxLayout newTopToBottom
		add: #table;
		add: #scopeDropList withConstraints: [ :constraints | constraints height: 30 ];
		add: #diffPresenter;
		yourself! !

!SycRefactoringPreviewPresenter class methodsFor: 'instance creation' stamp: ''!
for: aCommand scopes: scopes
	^ self new
		command: aCommand;
		scopes: scopes! !

!SycRefactoringPreviewPresenter class methodsFor: 'specs' stamp: ''!
title
	^ 'Refactoring changes'! !

!SycRefactoringPreviewTest commentStamp: ''!
A SycRefactoringPreview2Test is a test class for testing the behavior of SycRefactoringPreview2!
!SycRefactoringPreviewTest methodsFor: 'tests' stamp: ''!
testFirstItemIsSelected
	self initializeForInitializeTest.
	self assert: sycRefactoringPreview table selection selectedIndex equals: 1! !

!SycRefactoringPreviewTest methodsFor: 'running' stamp: ''!
fillTableWith3MockItem
	sycRefactoringPreview table
		items:
			{MockTreeTableItem new.
			MockTreeTableItem new.
			MockTreeTableItem new}! !

!SycRefactoringPreviewTest methodsFor: 'tests' stamp: ''!
testDropListChangeShouldChangeTableItems
	self initializeForInitializeTest.
	sycRefactoringPreview scopeDropList selectIndex: 2.
	self assertCollection: sycRefactoringPreview table items hasSameElements: {'banane' . 'Tournai Triple'}! !

!SycRefactoringPreviewTest methodsFor: 'tests' stamp: ''!
testInitializationAllCheckBoxDictionarySetTrue
	self initializeForInitializeTest.
	self assert: sycRefactoringPreview selectedRefactorings size equals: 3.
	self
		assert:
			(sycRefactoringPreview selectedRefactorings
				allSatisfy: [ :key | key ])
			! !

!SycRefactoringPreviewTest methodsFor: 'running' stamp: ''!
initializeForInitializeTest
	| scopeClass scopePackage |
	scopePackage := SycMockScope content: {'welsh' . 'banane' . 'paix dieu'}.
	scopeClass := SycMockScope content: {'banane' . 'Tournai Triple'}.
	sycRefactoringPreview := MockSycRefactoringPreviewPresenter for: SycRefactoringPreviewMockCommand new scopes: {scopePackage . scopeClass}! !

!SycRefactoringPreviewTest methodsFor: 'tests' stamp: ''!
testPickedChanges
	self fillTableWith3MockItem.
	sycRefactoringPreview selectectAllCheckBox.
	sycRefactoringPreview table selectIndex: 2.
	sycRefactoringPreview table doActivateAtIndex: 2.
	self deny: (sycRefactoringPreview selectedRefactorings includesKey: sycRefactoringPreview table selection selectedIndex)! !

!SycRefactoringPreviewTest methodsFor: 'tests' stamp: ''!
testDoubleClickAnTableItemShouldChangeTheValueAssociateToKey
	| mock2 |
	mock2 := MockTreeTableItem new title: 'mockTable2'.
	sycRefactoringPreview table
		items:
			{(MockTreeTableItem new title: 'mockTable1').
			mock2}.
	sycRefactoringPreview selectectAllCheckBox.
	sycRefactoringPreview selectedRefactorings at: mock2 put: true.
	sycRefactoringPreview table selectIndex: 2.
	sycRefactoringPreview table doActivateAtIndex: 2.
	self deny: (sycRefactoringPreview selectedRefactorings at: mock2)! !

!SycRefactoringPreviewTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."

	super setUp.
	sycRefactoringPreview := MockSycRefactoringPreviewPresenter new! !

!SycRefactoringStoreOnTest methodsFor: 'tests' stamp: ''!
testSSycRenameMessageCommandIsProperlyStoreOn

	| refactorings node |
	
	node := (MockTreeTableItem >> #title:) ast.
	
	refactorings := SycRenameMessageCommand new
		originalMessage: (SycMessageDescription ofMessageNode: node);
		newSignature: (RBMethodName selector: #title: arguments: #('anObject')) ;
		asRefactorings.
	
	self 
		assert: (String streamContents: [ :s | refactorings storeOn: s ])
		equals: '((Array new: 1) at: 1 put: (RBRenameMethodRefactoring renameMethod: #title: in: MockTreeTableItem to: #title: permutation: (1 to: 1)); yourself)'! !

!SycRefactoringStoreOnTest methodsFor: 'tests' stamp: ''!
testSycAddMessageArgumentCommandIsProperlyStoreOn

	| refactorings node newSelector |
	
	node := (MockTreeTableItem >> #title:) ast.
	newSelector := (RBMethodName selector: #title:lala: arguments: #(#anObject #anObject1))
		newArgs: (Array with: (RBArgumentName name: 'anObject1' value: 'nil'));
		permutation: #(1 -1).
	refactorings := SycAddMessageArgumentCommand new
		originalMessage: (SycMessageDescription ofMessageNode: node);
		newSelector: newSelector;
		asRefactorings.
	
	self 
		assert: (String streamContents: [ :s | refactorings storeOn: s ])
		equals: '((Array new: 1) at: 1 put: (RBAddParameterRefactoring addParameterToMethod: #title: in: MockTreeTableItem newSelector: #title:lala: permutation: #(1 -1) newArgs: ''((Array new: 1) at: 1 put: ; yourself)''); yourself)'! !

!SycRefactoringStoreOnTest methodsFor: 'tests' stamp: ''!
testRemoveMessageArgumentCommandIsProperlyStoreOn

	| refactorings |
	refactorings := SycRemoveMessageArgumentCommand new
		originalMessage: (MockTreeTableItem >> #title:) ast;
		argumentName: 'anObject';
		asRefactorings.
	
	self 
		assert: (String streamContents: [ :s | refactorings storeOn: s ])
		equals: '((Array new: 1) at: 1 put: (RBRemoveParameterRefactoring removeParameter: ''anObject'' in: MockTreeTableItem selector: #title:); yourself)'! !

!SycRemoveAllSendersCommand commentStamp: ''!
I am a command to launch the Remove All Senders Refactoring: the call to this method in all senders is removed (as long as possible)!
!SycRemoveAllSendersCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Remove all senders'! !

!SycRemoveAllSendersCommand methodsFor: 'execution' stamp: ''!
createRefactoring
	|refactoring options|
	refactoring := RBRemoveAllSendersRefactoring
		model: model
		removeSendersOf: originalMessage selector.
	options := refactoring options copy.
	options at: #inlineExpression put: [:ref :string | false].
	refactoring options: options.
	^ refactoring! !

!SycRemoveAllSendersCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^#remove
! !

!SycRemoveAllSendersCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation
		byRootGroupItemOrder: 35 for: ClyMethod asCalypsoItemContext! !

!SycRemoveAllSendersCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^ aToolContext isMethodSelected! !

!SycRemoveClassCommand commentStamp: ''!
I am a command to remove all given classes!
!SycRemoveClassCommand methodsFor: 'execution' stamp: ''!
asRefactorings

	^self asRefactoringsOfClass: RBRemoveClassRefactoring! !

!SycRemoveClassCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	^removeStrategy isComplexRefactoring ! !

!SycRemoveClassCommand methodsFor: 'execution' stamp: ''!
confirmRefactoringInContext: aToolContext by: aCommandActivator
	"All refactoring errors here are related to existance of removed class users.
	All these cases are handled on the level of #confirmUnusedClasses
	and here we need to ignore RB signals.
	Notice that existing logic of RB engine for class removal 
	does not allow correctly handle class users like show them in browser 
	because there is no information about kind of users in #openBrowser option"
	
	[super confirmRefactoringInContext: aToolContext by: aCommandActivator ]
		on: RBRefactoringError do: [ :err | err resume: true ]! !

!SycRemoveClassCommand methodsFor: 'execution' stamp: ''!
asRefactoringsOfClass: aClass

	^{aClass classNames: (classes collect: [:each | each name])}! !

!SycRemoveClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Remove'! !

!SycRemoveClassCommand methodsFor: 'execution' stamp: ''!
execute

	removeStrategy execute: self.! !

!SycRemoveClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext

	super prepareFullExecutionInContext: aToolContext.
	
	removeStrategy := aToolContext requestRemoveClassStrategyFor: classes.! !

!SycRemoveClassCommand methodsFor: 'execution' stamp: ''!
executeRefactoringsAs: aClass

	(self asRefactoringsOfClass: aClass) do: [ :each | each execute ]! !

!SycRemoveClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#removeIcon! !

!SycRemoveClassCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 10000 for: ClyFullBrowserClassContext! !

!SycRemoveClassCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation removalFor: ClyFullBrowserClassContext! !

!SycRemoveClassStrategy commentStamp: ''!
I am the abstract strategy used to remove classes from the system.

My concrete subclasses handle the possible actions when a user attempts to remove a class:
	- remove the class
	- remove the class, keeping the subclasses
	- Don't remove the class, but browse references/subclasses/users
	- Cancel the action!
!SycRemoveClassStrategy methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	^false! !

!SycRemoveClassStrategy methodsFor: 'execution' stamp: ''!
orderForBrowser
	"by default any new strategy will be at the end"
	^1000! !

!SycRemoveClassStrategy methodsFor: 'execution' stamp: ''!
execute: aSycRemoveClassCommand
	self subclassResponsibility ! !

!SycRemoveClassStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	self subclassResponsibility ! !

!SycRemoveClassStrategy class methodsFor: '*Calypso-SystemQueries' stamp: ''!
createForBrowser: aBrowser classes: aCollection

	| hasReferences hasSubclasses hasUsers |
	hasReferences := (ClyClassExternalReferencesQuery
		                  toAny: aCollection
		                  from: aBrowser systemScope) execute notEmpty.
	hasSubclasses := ((aCollection flatCollect: [ :each | 
		                   each subclasses ]) copyWithoutAll: aCollection)
		                 notEmpty.
	hasUsers := ((aCollection flatCollect: [ :each | each users ]) 
		             copyWithoutAll: aCollection) notEmpty.

	hasReferences | hasSubclasses | hasUsers ifFalse: [ 
		^ { SycSilentlyRemoveClassStrategy new } ].

	^ self
		  createForBrowser: aBrowser
		  references: hasReferences
		  subclasses: hasSubclasses
		  users: hasUsers! !

!SycRemoveClassStrategy class methodsFor: 'testing' stamp: ''!
canExecuteWithReferences: hasReferences subclasses: hasSubclasses users: hasUsers
	self subclassResponsibility ! !

!SycRemoveClassStrategy class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == SycRemoveClassStrategy ! !

!SycRemoveClassStrategy class methodsFor: 'instance creation' stamp: ''!
createForBrowser: aBrowser references: hasReferences subclasses: hasSubclasses users: hasUsers

	| strategies |
	strategies := SortedCollection sortBlock: #orderForBrowser ascending.
	
	self allSubclassesDo: [ :each |
		(each isAbstract not and: [
			each canExecuteWithReferences: hasReferences subclasses: hasSubclasses users: hasUsers])
				ifTrue: [ strategies add: (each newForBrowser: aBrowser) ]].
	
	^strategies! !

!SycRemoveClassStrategy class methodsFor: 'instance creation' stamp: ''!
newForBrowser: aBrowser

	^self new! !

!SycRemoveClassStrategyTest commentStamp: ''!
A SycRemoveClassStrategyTest is a test class for testing the behavior of SycRemoveClassStrategy!
!SycRemoveClassStrategyTest methodsFor: 'tests' stamp: ''!
testCreateStrategiesForReferencedClass

	| browser strategies |
	browser := ClyFullBrowserMorph onDefaultEnvironment.
	strategies := SycRemoveClassStrategy
		              createForBrowser: browser
		              classes: { ClyFullBrowserMorph }.
	self
		assert: strategies size equals: 3;
		assert: strategies first userRequestString
		equals: SycSilentlyRemoveClassStrategy new userRequestString;
		assert: strategies second userRequestString
		equals:
			ClyNotRemoveAndShowReferencesClassStrategy new userRequestString;
		assert: strategies last userRequestString
		equals: SycNotRemoveClassStrategy new userRequestString! !

!SycRemoveClassStrategyTest methodsFor: 'running' stamp: ''!
tearDown

	factory cleanUp.
	super tearDown.! !

!SycRemoveClassStrategyTest methodsFor: 'tests' stamp: ''!
testCreateStrategiesForParentClass

	| browser strategies |
	browser := ClyFullBrowserMorph onDefaultEnvironment.
	strategies := SycRemoveClassStrategy
		              createForBrowser: browser
		              classes: { ClyBrowserMorph }.
	self
		assert: strategies size > 2;
		assert: (strategies anySatisfy: [ :each | 
					 each userRequestString
					 =
						 ClyNotRemoveAndShowSubclassesClassStrategy new
							 userRequestString ]);
		assert: strategies last userRequestString
		equals: SycNotRemoveClassStrategy new userRequestString! !

!SycRemoveClassStrategyTest methodsFor: 'tests' stamp: ''!
testCreateStrategiesForUsedTrait

	| browser strategies |
	browser := ClyFullBrowserMorph onDefaultEnvironment.
	strategies := SycRemoveClassStrategy
		              createForBrowser: browser
		              classes: { TRBProgramNodeVisitor }.
	self
		assert: strategies size > 2;
		assert: (strategies anySatisfy: [ :each | 
					 each userRequestString
					 = ClyNotRemoveAndShowUsersClassStrategy new userRequestString ]);
		assert: strategies last userRequestString
		equals: SycNotRemoveClassStrategy new userRequestString! !

!SycRemoveClassStrategyTest methodsFor: 'tests' stamp: ''!
testCreateStrategiesForRemovableClass

	| browser class strategies |
	browser := ClyFullBrowserMorph onDefaultEnvironment.
	class := factory newClass.
	strategies := SycRemoveClassStrategy
		              createForBrowser: browser
		              classes: { class }.
	self
		assert: strategies size equals: 1;
		assert: strategies first userRequestString
		equals: SycSilentlyRemoveClassStrategy new userRequestString! !

!SycRemoveClassStrategyTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	
	factory := ClassFactoryForTestCase new.! !

!SycRemoveEmptyMethodTagsCommand commentStamp: ''!
I am a command to clean all unused method tags (empty protocols) of given classes!
!SycRemoveEmptyMethodTagsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Remove empty protocols'! !

!SycRemoveEmptyMethodTagsCommand methodsFor: 'execution' stamp: ''!
execute
	
	classes do: [ :each | 
		each organization removeEmptyCategories]! !

!SycRemoveEmptyMethodTagsCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext

	super prepareFullExecutionInContext: aToolContext.
	classes := classes collect: [:each | aToolContext currentMetaLevelOf: each]! !

!SycRemoveEmptyMethodTagsCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#delete! !

!SycRemoveEmptyMethodTagsCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 10001 for: ClyFullBrowserMethodGroupContext! !

!SycRemoveHierarchyMethodCommand commentStamp: ''!
I am a command to remove given methods and the ones in the subclasses.
!
!SycRemoveHierarchyMethodCommand methodsFor: 'converting' stamp: ''!
asRefactorings
	| refactoring |
	refactoring :=  RBRemoveHierarchyMethodRefactoring  
		removeMethods: (methods collect: [:each | each selector]) 
		from: methods first origin.
	^ OrderedCollection with: refactoring ! !

!SycRemoveHierarchyMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Remove and the ones in subclasses'! !

!SycRemoveHierarchyMethodCommand methodsFor: 'initialization' stamp: ''!
setUpModelFromContext: aToolContext! !

!SycRemoveHierarchyMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #remove! !

!SycRemoveHierarchyMethodCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 100 for: ClyMethod asCalypsoItemContext! !

!SycRemoveKeepingSubclassesClassStrategy methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	"Class removals are always complex refactorings"
	^true! !

!SycRemoveKeepingSubclassesClassStrategy methodsFor: 'execution' stamp: ''!
orderForBrowser
	^3! !

!SycRemoveKeepingSubclassesClassStrategy methodsFor: 'execution' stamp: ''!
execute: aSycRemoveClassCommand

	aSycRemoveClassCommand executeRefactoringsAs: RBRemoveClassKeepingSubclassesRefactoring! !

!SycRemoveKeepingSubclassesClassStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	^'Remove it, keeping subclasses'! !

!SycRemoveKeepingSubclassesClassStrategy class methodsFor: 'testing' stamp: ''!
canExecuteWithReferences: hasReferences subclasses: hasSubclasses users: hasUsers
	^hasSubclasses & hasReferences not & hasUsers not! !

!SycRemoveMessageArgumentCommand commentStamp: ''!
I am a command to remove existing argument from the message.

Internal Representation and Key Implementation Points.

    Instance Variables
	argumentName:		<String>!
!SycRemoveMessageArgumentCommand methodsFor: 'accessing' stamp: ''!
argumentName
	^ argumentName! !

!SycRemoveMessageArgumentCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Remove argument'! !

!SycRemoveMessageArgumentCommand methodsFor: 'accessing' stamp: ''!
argumentName: anObject
	argumentName := anObject! !

!SycRemoveMessageArgumentCommand methodsFor: 'execution' stamp: ''!
createRefactoring

	^RBRemoveParameterRefactoring
		model: model
		removeParameter: argumentName
		in: (SycMessageOriginHack of: originalMessage) "look at SycMessageOriginHack comment"
		selector: originalMessage selector! !

!SycRemoveMessageArgumentCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	argumentName := originalMessage argumentNames size = 1 
		ifTrue: [ originalMessage argumentNames first]
		ifFalse: [ UIManager default
						chooseFrom: originalMessage argumentNames 
						values: originalMessage argumentNames 
						message: 'Choose an argument to remove:'].
					
	(originalMessage argumentNames includes: argumentName) 
		ifFalse: [ CmdCommandAborted signal ].! !

!SycRemoveMessageArgumentCommand methodsFor: 'execution' stamp: ''!
resultMessageSelector
	| argIndex keywords |
	argIndex := originalMessage argumentNames indexOf: argumentName.
	keywords := originalMessage selector keywords asOrderedCollection.
	keywords size = 1
		ifTrue: [ ^ (keywords first copyWithout: $:) asSymbol ].
	keywords removeAt: argIndex.
	^(keywords joinUsing: '') asSymbol! !

!SycRemoveMessageArgumentCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^#remove
! !

!SycRemoveMessageArgumentCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 40 for: ClyMethod asCalypsoItemContext! !

!SycRemoveMessageArgumentCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^(super canBeExecutedInContext: aToolContext)
		and: [ aToolContext lastSelectedMessage argumentNames notEmpty]! !

!SycRemoveMessageArgumentCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
browserMenuOrder
	^2.2! !

!SycRemoveMethodCommand commentStamp: ''!
I am a command to remove given methods.

I use special remove strategy to define what to do when given methods are in use.

So I delegate actual remove operation to the strategy: 

	removeStrategy removeMethods: methods
 
Internal Representation and Key Implementation Points.

    Instance Variables
	removeStrategy:		<SycRemoveMethodStrategy>!
!SycRemoveMethodCommand methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	removeStrategy := SycSilentlyRemoveMethodStrategy new! !

!SycRemoveMethodCommand methodsFor: 'accessing' stamp: ''!
removeStrategy
	^ removeStrategy! !

!SycRemoveMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Remove'! !

!SycRemoveMethodCommand methodsFor: 'execution' stamp: ''!
execute
	
	removeStrategy removeMethods: methods! !

!SycRemoveMethodCommand methodsFor: 'accessing' stamp: ''!
removeStrategy: anObject
	removeStrategy := anObject! !

!SycRemoveMethodCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	removeStrategy := aToolContext requestRemoveMethodStrategyFor: methods.! !

!SycRemoveMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#removeIcon! !

!SycRemoveMethodCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation removalFor: ClyMethod asCalypsoItemContext! !

!SycRemoveMethodCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodMenuActivation
	<classAnnotation>
	
	^ CmdContextMenuActivation byRootGroupItemOrder: 10000 for: ClyMethod asCalypsoItemContext! !

!SycRemoveMethodStrategy commentStamp: ''!
I am a strategy on how remove methods.
You can see my subclasses when you try remove method in the browser which is still in use.
Usually you see four options what to do:
- just remove 
- remove and show senders
- do not remove and show senders
- cancel  

My subclasses represent this choices using following method: 

- removeMethods: methods 

And they implement supporting methods to be shown in this dialog nicely: 

- orderForBrowser 
Strategy selection dialog orders collected strategy using this message. 

- userRequestString 
It is a string which should be displayed in strategy selection dialog.!
!SycRemoveMethodStrategy methodsFor: 'execution' stamp: ''!
removeMethods: methods
	self subclassResponsibility ! !

!SycRemoveMethodStrategy methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
orderForBrowser
	"by default any new strategy will be at the end"
	^1000! !

!SycRemoveMethodStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	self subclassResponsibility ! !

!SycRemoveMethodStrategy class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
createAllForBrowser: aBrowser

	| result |
	result := SortedCollection sortBlock: #orderForBrowser ascending.
	
	self allSubclassesDo: [ :each | 
		each hasSubclasses ifFalse: [ 
			result add: (each newForBrowser: aBrowser) ]].
	
	^result! !

!SycRemoveMethodStrategy class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
newForBrowser: aBrowser

	^self new! !

!SycRemovePackageCommand commentStamp: ''!
I am a command to remove given packages!
!SycRemovePackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Remove'! !

!SycRemovePackageCommand methodsFor: 'execution' stamp: ''!
execute
			
	packages do: [ :each | each removeFromSystem ]! !

!SycRemovePackageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext

	| packagesWithClasses names answer |
	super prepareFullExecutionInContext: aToolContext.	
	packagesWithClasses := packages reject: [ :each | each isEmpty].
	packagesWithClasses ifNotEmpty: [ 	
		names := (packagesWithClasses collect: [:package | package name ]) joinUsing: ', '.
		answer := UIManager default confirm: (
			'Are you sure you want to delete the selection(s)?', String cr, names, ' still contains classes.').
		answer ifFalse: [ CmdCommandAborted signal ]]! !

!SycRemovePackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#removeIcon! !

!SycRemovePackageCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 10000 for: ClyFullBrowserPackageContext! !

!SycRemovePackageCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation removalFor: ClyFullBrowserPackageContext! !

!SycRemovePackageCommand class methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #delete! !

!SycRemoveVariableCommand commentStamp: ''!
I am a command to remove given variables!
!SycRemoveVariableCommand methodsFor: 'execution' stamp: ''!
asRefactorings
	
	^self createRefactorings: RBRemoveInstanceVariableRefactoring! !

!SycRemoveVariableCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring

	^false! !

!SycRemoveVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Remove'! !

!SycRemoveVariableCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	| noUsers |
	super prepareFullExecutionInContext: aToolContext.

	noUsers := aToolContext confirmUnusedVariables: variables.
	noUsers ifFalse: [CmdCommandAborted signal]! !

!SycRemoveVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#removeIcon! !

!SycRemoveVariableCommand class methodsFor: 'activation' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.5 for: ClySourceCodeContext! !

!SycRemoveVariableCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 10000 for: ClyFullBrowserVariableContext! !

!SycRemoveVariableCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation removalFor: ClyFullBrowserVariableContext! !

!SycRenameArgOrTempCommand commentStamp: ''!
I am a command to rename temp variable in given method.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	newName:		<String>!
!SycRenameArgOrTempCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aSourceCodeContext
	super applyResultInContext: aSourceCodeContext.
	
	aSourceCodeContext showVariableNamed: newName! !

!SycRenameArgOrTempCommand methodsFor: 'execution' stamp: ''!
asRefactorings 
	^ {RBRenameArgumentOrTemporaryRefactoring	
		renameTemporaryFrom: sourceNode sourceInterval
		to: newName
		in: method origin
		selector: method selector}! !

!SycRenameArgOrTempCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Rename temp'! !

!SycRenameArgOrTempCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aSourceCodeContext
	super prepareFullExecutionInContext: aSourceCodeContext.
	
	newName := UIManager default 
		request: 'New name of the variable' 
		initialAnswer: sourceNode name
		title: 'Rename a temp variable'.
	newName isEmptyOrNil | (newName = sourceNode name) ifTrue: [ CmdCommandAborted signal ]! !

!SycRenameArgOrTempCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #edit! !

!SycRenameArgOrTempCommand class methodsFor: 'execution' stamp: ''!
canBeExecutedInContext: aSourceCodeContext
	super canBeExecutedInContext: aSourceCodeContext.
	
	^ aSourceCodeContext isArgOrTempVariableSelected ! !

!SycRenameArgOrTempCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.2 for: ClyMethodSourceCodeContext! !

!SycRenameArgOrTempCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation renamingFor: ClyMethodSourceCodeContext! !

!SycRenameClassCommand commentStamp: ''!
I am a command to rename given class.

Internal Representation and Key Implementation Points.

    Instance Variables
	newName:		<String>!
!SycRenameClassCommand methodsFor: 'accessing' stamp: ''!
newName
	^ newName! !

!SycRenameClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Rename'! !

!SycRenameClassCommand methodsFor: 'execution' stamp: ''!
execute
	
	| refactoring |
	refactoring := RBRenameClassRefactoring
		rename: targetClass name
		to: newName.
	refactoring execute! !

!SycRenameClassCommand methodsFor: 'accessing' stamp: ''!
newName: anObject
	newName := anObject! !

!SycRenameClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	newName := UIManager default 
		request: 'New name of the class' initialAnswer: targetClass name title: 'Rename a class'.
		
	newName isEmptyOrNil | (newName = targetClass name) ifTrue: [ CmdCommandAborted signal]! !

!SycRenameClassCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #edit! !

!SycRenameClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.2 for: ClySourceCodeContext! !

!SycRenameClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
browserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation renamingFor: ClyClass asCalypsoItemContext! !

!SycRenameClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 1 for: ClyClass asCalypsoItemContext! !

!SycRenameClassCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation renamingFor: ClySourceCodeContext! !

!SycRenameMessageCommand commentStamp: ''!
I am a command to rename message selector.
In addition I allow to swap arguments in signature.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	newSignature:		<SycMessageDescription>!
!SycRenameMessageCommand methodsFor: 'requesting' stamp: ''!
canRemoveArgs 
	^ false! !

!SycRenameMessageCommand methodsFor: 'requesting' stamp: ''!
canAddArgs 
	^false! !

!SycRenameMessageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Rename'! !

!SycRenameMessageCommand methodsFor: 'accessing' stamp: ''!
newSignature
	^ newSignature! !

!SycRenameMessageCommand methodsFor: 'execution' stamp: ''!
createRefactoring

	^ (RBRenameMethodRefactoring
		model: model
		renameMethod: originalMessage selector 
		in: (SycMessageOriginHack of: originalMessage) "look at SycMessageOriginHack comment"
		to: newSignature selector 
		permutation: newSignature permutation)
		renameMap: newSignature renameMap! !

!SycRenameMessageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.

	newSignature := self requestNewMessageIn: aToolContext
	
! !

!SycRenameMessageCommand methodsFor: 'execution' stamp: ''!
resultMessageSelector
	^newSignature selector! !

!SycRenameMessageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#edit
! !

!SycRenameMessageCommand methodsFor: 'accessing' stamp: ''!
newSignature: anObject
	newSignature := anObject! !

!SycRenameMessageCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation renamingFor: ClyMethod asCalypsoItemContext! !

!SycRenameMessageCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
browserMenuOrder
	^2! !

!SycRenameMessageCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodMenuActivation
	<classAnnotation>

	^CmdContextMenuActivation 
		byRootGroupItemOrder: self browserMenuOrder for: ClyMethod asCalypsoItemContext! !

!SycRenameMessageCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.2 for: ClyMethodSourceCodeContext! !

!SycRenameMessageCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation renamingFor: ClyMethodSourceCodeContext! !

!SycRenamePackageCommand commentStamp: ''!
I am a command to rename given package.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	newName:		<String>
	package:		<RPackage>!
!SycRenamePackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Rename'! !

!SycRenamePackageCommand methodsFor: 'execution' stamp: ''!
execute
	
	(RBRenamePackageRefactoring rename: package name to: newName) execute! !

!SycRenamePackageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	package := aToolContext lastSelectedPackage.	
	newName := UIManager default 
		request: 'New name of the package' 
		initialAnswer: package name 
		title: 'Rename a package'.
	newName isEmptyOrNil | (newName = package name) ifTrue: [ ^ CmdCommandAborted signal ]! !

!SycRenamePackageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #edit! !

!SycRenamePackageCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 1 for: ClyFullBrowserPackageContext! !

!SycRenamePackageCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isPackageSelected! !

!SycRenamePackageCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation renamingFor: ClyFullBrowserPackageContext! !

!SycRenameVariableCommand commentStamp: ''!
I am a command to remove given variable.

My #variable should be compatible variable object like ClassVariable or Slot. Or Calypso provide ClyVariable subclasses.

Internal Representation and Key Implementation Points.

    Instance Variables
	newName:		<String>
	variable:		<Variable>
!
!SycRenameVariableCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	aToolContext showVariableNamed: newName! !

!SycRenameVariableCommand methodsFor: 'execution' stamp: ''!
newVariableName

	^ newName asSymbol! !

!SycRenameVariableCommand methodsFor: 'execution' stamp: ''!
classRefactoring

	^ RBRenameInstanceVariableRefactoring! !

!SycRenameVariableCommand methodsFor: 'accessing' stamp: ''!
variable
	^ variable! !

!SycRenameVariableCommand methodsFor: 'accessing' stamp: ''!
newName
	^ newName! !

!SycRenameVariableCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Rename'! !

!SycRenameVariableCommand methodsFor: 'execution' stamp: ''!
execute

	| refactoring |
	refactoring := variable createVariableRefactoring:
		               self classRefactoring.
	refactoring newName: self newVariableName.

	refactoring execute! !

!SycRenameVariableCommand methodsFor: 'accessing' stamp: ''!
newName: anObject
	newName := anObject! !

!SycRenameVariableCommand methodsFor: 'execution' stamp: ''!
requestNewNameIn: aToolContext

	newName := UIManager default
		           request: 'New name of the variable'
		           initialAnswer: variable name
		           title: 'Rename a variable'.
	newName isEmptyOrNil | (newName = variable name) ifTrue: [ 
		CmdCommandAborted signal ]! !

!SycRenameVariableCommand methodsFor: 'accessing' stamp: ''!
variable: anObject
	variable := anObject! !

!SycRenameVariableCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext

	super prepareFullExecutionInContext: aToolContext.
	variable := aToolContext lastSelectedVariable.
	self requestNewNameIn: aToolContext! !

!SycRenameVariableCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.1 for: ClySourceCodeContext! !

!SycRenameVariableCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemOrder: 1 for: ClyFullBrowserVariableContext! !

!SycRenameVariableCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isVariableSelected and: [ aToolContext isGlobalVariableSelected not ]! !

!SycRenameVariableCommand class methodsFor: '*Calypso-SystemTools-FullBrowser' stamp: ''!
fullBrowserShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation renamingFor: ClyFullBrowserVariableContext! !

!SycRenameVariableCommand class methodsFor: 'accessing' stamp: ''!
defaultMenuIconName 
	^ #edit! !

!SycRenameVariableCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeShortcutActivation
	<classAnnotation>
	
	^CmdShortcutActivation renamingFor: ClySourceCodeContext! !

!SycReplaceMessageCommand commentStamp: ''!
I am a command to replace senders of message selector.!
!SycReplaceMessageCommand methodsFor: 'execution' stamp: ''!
replaceInAllClasses
	^ self confirm: 'Do you want replace senders of method in the whole classes?'! !

!SycReplaceMessageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^ 'Replace senders'! !

!SycReplaceMessageCommand methodsFor: 'execution' stamp: ''!
createRefactoring
	self flag: 'TODO'."Improve preview to add args when change the sender with empty args"
	^ (RBReplaceMethodRefactoring
		model: model
		replaceMethod: originalMessage selector 
		in: originalMessage contextUser origin
		to: newSelector selector
		permutation: newSelector permutation
		inAllClasses: self replaceInAllClasses)
		initializers: newSelector newArgs values! !

!SycReplaceMessageCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	
	| methodName dialog |
	super prepareFullExecutionInContext: aToolContext.
	
	methodName := RBMethodName selector: originalMessage selector arguments: originalMessage argumentNames copy.
	dialog := SycMethodNameEditorPresenter openOn: methodName.
	dialog cancelled ifTrue: [  CmdCommandAborted signal ].
	
	originalMessage selector = methodName selector ifTrue: [ CmdCommandAborted signal].
	newSelector := methodName.! !

!SycReplaceMessageCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#edit! !

!SycReplaceMessageCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodContextMenuActivation
	<classAnnotation>
	
	^ SycMethodMenuActivation byRootGroupItemOrder: 1100 for: ClyMethod asCalypsoItemContext! !

!SycShowMethodVersionCommand commentStamp: ''!
I am a command to show local method version.

Local version has not relation to actual source code system. Versions are retrieved form changes file.

Internal Representation and Key Implementation Points.

    Instance Variables
	method:		<CompiledMethod>!
!SycShowMethodVersionCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Versions'! !

!SycShowMethodVersionCommand methodsFor: 'execution' stamp: ''!
execute
	Smalltalk tools versionBrowser browseVersionsForMethod: method! !

!SycShowMethodVersionCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	method := aToolContext lastSelectedMethod! !

!SycShowMethodVersionCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#history! !

!SycShowMethodVersionCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodBrowserTabActivation
	<classAnnotation>
	
	^ClyBrowserTabCommandActivation for: ClyMethod asCalypsoItemContext! !

!SycShowMethodVersionCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isMethodSelected! !

!SycShowMethodVersionCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byItemOf: ClyQueryMenuGroup for: ClyMethod asCalypsoItemContext! !

!SycSilentlyRemoveClassStrategy commentStamp: ''!
I am the strategy to use when a user attempts to delete a class that has no references, subclasses, or users.!
!SycSilentlyRemoveClassStrategy methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	"Class removals are always complex refactorings"
	^true! !

!SycSilentlyRemoveClassStrategy methodsFor: 'execution' stamp: ''!
orderForBrowser
	^1! !

!SycSilentlyRemoveClassStrategy methodsFor: 'execution' stamp: ''!
execute: aSycRemoveClassCommand

	aSycRemoveClassCommand executeRefactorings! !

!SycSilentlyRemoveClassStrategy methodsFor: 'execution' stamp: ''!
userRequestString
	^'Remove it'! !

!SycSilentlyRemoveClassStrategy class methodsFor: 'testing' stamp: ''!
canExecuteWithReferences: hasReferences subclasses: hasSubclasses users: hasUsers
	^(hasSubclasses | hasUsers) not ! !

!SycSilentlyRemoveMethodStrategy commentStamp: ''!
I am simple perform method remove operation without any extra logic!
!SycSilentlyRemoveMethodStrategy methodsFor: 'removing' stamp: ''!
removeMethods: methods
	
	| methodTags |
	methodTags := self collectMethodTagsFrom: methods. "we will remove empty tags of removed methods".
	
	methods do: [ :each | each removeFromSystem ].
	
	methodTags keysAndValuesDo: [:class :tags | tags do: [ :eachTag | 
		(class methodsTaggedWith: eachTag) 
			ifEmpty: [class removeMethodTag: eachTag] ]]! !

!SycSilentlyRemoveMethodStrategy methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
orderForBrowser
	^1! !

!SycSilentlyRemoveMethodStrategy methodsFor: 'removing' stamp: ''!
collectMethodTagsFrom: methods
	"It will return map class->tags where tags are related to given methods"
	| result tags |
	result := IdentityDictionary new.
	methods do: [ :each | 
		tags := result at: each origin ifAbsentPut: [IdentitySet new].
		tags addAll: each tags].
	^result! !

!SycSilentlyRemoveMethodStrategy methodsFor: 'removing' stamp: ''!
userRequestString
	^'Remove it'! !

!SycSingleClassCommand commentStamp: ''!
I am a base class for commands which perform operations with single class
 
Internal Representation and Key Implementation Points.

    Instance Variables
	targetClass:		<Class>!
!SycSingleClassCommand methodsFor: 'accessing' stamp: ''!
targetClass: anObject
	targetClass := anObject! !

!SycSingleClassCommand methodsFor: 'accessing' stamp: ''!
targetClass
	^ targetClass! !

!SycSingleClassCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	targetClass := aToolContext lastSelectedClass.! !

!SycSingleClassCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = SycSingleClassCommand ! !

!SycSingleClassCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isClassSelected ! !

!SycSourceCodeCmCommand commentStamp: ''!
This class is an extension so we can mix command of Commander2 with Commander.!
!SycSourceCodeCmCommand methodsFor: 'accessing' stamp: ''!
order
	
	^ 100! !

!SycSourceCodeCmCommand class methodsFor: 'execution' stamp: ''!
activationStrategy 
	^ SycSourceCodeMenuActivation! !

!SycSourceCodeCommand commentStamp: ''!
I am a base class for commands which perform operations with particular ast-node of given method.
  
Internal Representation and Key Implementation Points.

    Instance Variables
	method:		<CompiledMethod>
	sourceNode:		<RBProgramNode>!
!SycSourceCodeCommand methodsFor: 'execution' stamp: ''!
readParametersFromContext: aSourceCodeContext
	super readParametersFromContext: aSourceCodeContext.
	
	method := aSourceCodeContext lastSelectedMethod.
	sourceNode := aSourceCodeContext lastSelectedSourceNode! !

!SycSourceCodeCommand methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!SycSourceCodeCommand methodsFor: 'execution' stamp: ''!
asRefactorings
	self subclassResponsibility! !

!SycSourceCodeCommand methodsFor: 'initialization' stamp: ''!
initializeDefaultOptionsOf: refactoring

	NautilusRefactoring new refactoringOptions: refactoring! !

!SycSourceCodeCommand methodsFor: 'accessing' stamp: ''!
sourceNode
	^ sourceNode! !

!SycSourceCodeCommand methodsFor: 'execution' stamp: ''!
execute

	self executeRefactoring: self asRefactorings! !

!SycSourceCodeCommand methodsFor: 'initialization' stamp: ''!
setUpModelFromContext: aContext
	| browser scope |
	browser := aContext browser.
	scope := browser defaultNavigationScope.
	scope isCurrentImage ifTrue: [ scope := RefactoringSettings scopeRefactoring ].
	model := RBClassModelFactory rbNamespace onEnvironment: scope asRBEnvironment! !

!SycSourceCodeCommand methodsFor: 'accessing' stamp: ''!
method: anObject
	method := anObject! !

!SycSourceCodeCommand methodsFor: 'actions' stamp: ''!
computeInvalidArgNamesForSelector: aSymbol
	| invalidArgNames |
	invalidArgNames := Set new.
	(model allImplementorsOf: aSymbol) do: [ :e | | cm | 
		cm:=(e realClass >> aSymbol).
		invalidArgNames addAll: cm argumentNames;
			addAll: cm origin instVarNames ].
	^ invalidArgNames! !

!SycSourceCodeCommand methodsFor: 'private' stamp: ''!
executeRefactoring: refactoring

	self initializeDefaultOptionsOf: refactoring.
	[ refactoring execute ]
		on: RBRefactoringError
		do: [ :e | UIManager default alert: e messageText ]! !

!SycSourceCodeCommand methodsFor: 'accessing' stamp: ''!
sourceNode: anObject
	sourceNode := anObject! !

!SycSourceCodeCommand class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SycSourceCodeCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SycSourceCodeCommand class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SycSourceCodeCommand class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SycSourceCodeCommand class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SycSourceCodeCommand class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SycSourceCodeCommand class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SycSourceCodeCommand class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SycSourceCodeCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SycSourceCodeCommand class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SycSourceCodeCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SycSourceCodeCommand class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SycSourceCodeCommand class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SycSourceCodeCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = SycSourceCodeCommand ! !

!SycSourceCodeCommand class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SycSourceCodeCommand class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SycSourceCodeCommand class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SycSourceCodeCommand class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SycSourceCodeCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SycSourceCodeCommand class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SycSourceCodeCommand class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SycSourceCodeCommand class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SycSourceCodeCommand class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SycSourceCodeCommand class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SycSourceCodeCommand class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SycSourceCodeCommand class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SycSourceCodeCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
sourceCodeMenuActivation
	<classAnnotation>
	
	^SycSourceCodeMenuActivation byRootGroupItemOrder: 1.4 for: ClyMethodSourceCodeContext! !

!SycSourceCodeCommand class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SycSourceCodeCommand class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SycSourceCodeCommand class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SycSourceCodeCommand class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SycSourceCodeCommand class methodsFor: 'instance creation' stamp: ''!
method: aMethod node: aRBProgramNode
	^self new 
		method: aMethod;
		sourceNode: aRBProgramNode! !

!SycSourceCodeMenuActivation commentStamp: ''!
I represent activation of commands using separate source code menu.
In Nautilus I was implemented as Suggestions menu!
!SycSourceCodeRefactoringCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	^ true! !

!SycSourceCodeRefactoringCommand class methodsFor: 'testing' stamp: ''!
isAbstract 

	^ self == SycSourceCodeRefactoringCommand! !

!SycTagMethodCommand commentStamp: ''!
I am a command to classify given methods with given tag.

Internal Representation and Key Implementation Points.

    Instance Variables
	targetTag:		<Symbol>!
!SycTagMethodCommand methodsFor: 'execution' stamp: ''!
applyResultInContext: aToolContext
	super applyResultInContext: aToolContext.
	aToolContext showMethodTag: targetTag! !

!SycTagMethodCommand methodsFor: 'accessing' stamp: ''!
targetTag: anObject
	targetTag := anObject! !

!SycTagMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuItemName
	^'Classify methods'! !

!SycTagMethodCommand methodsFor: 'execution' stamp: ''!
execute
	
	methods do: [ :aMethod | 
		| oldTags |
		oldTags := aMethod tags.
		aMethod tagWith: targetTag asSymbol.
		oldTags do: [:old | aMethod untagFrom: old ]]! !

!SycTagMethodCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	targetTag := aToolContext requestSingleMethodTag: 'New protocol name'! !

!SycTagMethodCommand methodsFor: 'accessing' stamp: ''!
targetTag
	^ targetTag! !

!SycTagMethodCommand methodsFor: 'accessing' stamp: ''!
defaultMenuIconName
	^#glamorousBrowse
! !

!SycTagMethodCommand class methodsFor: 'instance creation' stamp: ''!
for: methods tag: aString

	^(self for: methods)
		targetTag: aString! !

!SycTagMethodCommand class methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
methodMenuActivation
	<classAnnotation>
	
	^CmdContextMenuActivation byRootGroupItemFor: ClyMethod asCalypsoItemContext! !

!SycVariableAccessBreakpointCommand commentStamp: ''!
I break on all variable accesses in the selected class!
!SycVariableAccessBreakpointCommand methodsFor: 'execution' stamp: ''!
installVariableBreakpointInTargetClass
	VariableBreakpoint watchVariablesInClass: targetClass! !

!SycVariableAccessBreakpointCommand methodsFor: 'execution' stamp: ''!
defaultMenuItemName
	^'Break on all variable accesses'! !

!SycVariableAccessBreakpointCommand class methodsFor: 'activation' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	^ CmdContextMenuActivation
		byItemOf: ClyDebuggingMenuGroup
		order: 99
		for: ClyClass asCalypsoItemContext! !

!SycVariableBreakpointCommand commentStamp: ''!
Commands to install a variable breakpoint on all instances variables of the selected class.!
!SycVariableBreakpointCommand methodsFor: 'execution' stamp: ''!
installVariableBreakpointInTargetClass
	self subclassResponsibility! !

!SycVariableBreakpointCommand methodsFor: 'execution' stamp: ''!
execute
	self installVariableBreakpointInTargetClass! !

!SycVariableBreakpointCommand methodsFor: 'execution' stamp: ''!
defaultMenuIconName 
	^ #smallDebug! !

!SycVariableBreakpointCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self == SycVariableBreakpointCommand! !

!SycVariableBreakpointCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^ self isAbstract not
		and: [ super canBeExecutedInContext: aToolContext ]! !

!SycVariableBreakpointCommand class methodsFor: 'activation' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	^ CmdContextMenuActivation
		byItemOf: ClyDebuggingMenuGroup
		order: 99
		for: ClyClass asCalypsoItemContext! !

!SycVariableCommand commentStamp: ''!
I am a base class for command which perform operations with given collection of variables.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	variables:		<Collection of<Variable>>
!
!SycVariableCommand methodsFor: 'accessing' stamp: ''!
variables
	^ variables! !

!SycVariableCommand methodsFor: 'accessing' stamp: ''!
variables: anObject
	variables := anObject! !

!SycVariableCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	
	variables := aToolContext selectedVariables! !

!SycVariableCommand class methodsFor: 'testing' stamp: ''!
isAbstract
	^self = SycVariableCommand ! !

!SycVariableCommand class methodsFor: 'testing' stamp: ''!
canBeExecutedInContext: aToolContext
	^aToolContext isVariableSelected! !

!SycVariableReadBreakpointCommand commentStamp: ''!
I break on all variable reads in the selected class!
!SycVariableReadBreakpointCommand methodsFor: 'execution' stamp: ''!
installVariableBreakpointInTargetClass
	VariableBreakpoint watchVariablesReadsInClass: targetClass! !

!SycVariableReadBreakpointCommand methodsFor: 'execution' stamp: ''!
defaultMenuItemName
	^'Break on all variable reads'! !

!SycVariableReadBreakpointCommand class methodsFor: 'activation' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	^ CmdContextMenuActivation
		byItemOf: ClyDebuggingMenuGroup
		order: 99
		for: ClyClass asCalypsoItemContext! !

!SycVariableWriteBreakpointCommand commentStamp: ''!
I break on all variable writes in the selected class!
!SycVariableWriteBreakpointCommand methodsFor: 'execution' stamp: ''!
installVariableBreakpointInTargetClass
	VariableBreakpoint watchVariablesWritesInClass: targetClass! !

!SycVariableWriteBreakpointCommand methodsFor: 'execution' stamp: ''!
defaultMenuItemName
	^'Break on all variable writes'! !

!SycVariableWriteBreakpointCommand class methodsFor: 'activation' stamp: ''!
browserContextMenuActivation
	<classAnnotation>
	^ CmdContextMenuActivation
		byItemOf: ClyDebuggingMenuGroup
		order: 99
		for: ClyClass asCalypsoItemContext! !

!Symbol commentStamp: ''!
I represent Strings that are created uniquely. Thus, someString asSymbol == someString asSymbol.

To see the difference between Symbol and Strings look at this example:

```
| s1 s2 |
s1 := 1234 asString.
s2 := 1234 asString.

"Strings are not unique, while Symbols are"
s1 = s2. "true"
s1 == s2. "false"

s1 asSymbol = s2 asSymbol. "true"
s1 asSymbol == s2 asSymbol. "true"

(s1 class allInstances select: [:s | s = s1 ]) size. "2"
(s1 asSymbol class allInstances select: [:s | s = s1 asSymbol ]) size. "1"
```

Comparing Symbols takes less time than comparing Strings.

```
[ #stringA = #stringB ] bench. "26,812,864 per second"
[ 'StringA' = 'StringB' ] bench. "3,492,987 per second"
```!
!Symbol methodsFor: 'printing' stamp: ''!
isOrientedFill
	"Needs to be implemented here because symbols can occupy 'color' slots of morphs."

	^ false! !

!Symbol methodsFor: 'converting' stamp: ''!
asAnnouncement

	^ self! !

!Symbol methodsFor: 'evaluating' stamp: ''!
value: anObject 
	^anObject perform: self.! !

!Symbol methodsFor: 'testing' stamp: ''!
isInfix
	"Answer whether the receiver is an infix message selector."

	^ self precedence = 2! !

!Symbol methodsFor: '*Metacello-Core' stamp: ''!
asMetacelloAttributePath
    ^ MetacelloMethodSectionPath with: {self}! !

!Symbol methodsFor: 'converting' stamp: ''!
uncapitalized
	"Answer an object like the receiver but with first character downshifted if necessary"

	^ self asString uncapitalized asSymbol! !

!Symbol methodsFor: 'converting' stamp: ''!
separateKeywords
	"#'foo:zork:' separateKeywords -> 'foo:  zork:'"

	self isKeyword
		ifFalse: [ ^ self ].
	^ String streamContents: [ :stream | 
			(self findTokens: $:) 
				do: [ :each | 
					stream
						nextPutAll: each;
						nextPut: $: ]
				separatedBy: [ stream nextPutAll: '  ' ] ]! !

!Symbol methodsFor: '*Metacello-Core' stamp: ''!
setForDo: aBlock withInMetacelloConfig: aMetacelloConstructore
    aMetacelloConstructore setFor: {self} do: aBlock! !

!Symbol methodsFor: '*Clap-Core' stamp: ''!
identifiesClapParameter: aClapParameter
	^ self = aClapParameter identifier! !

!Symbol methodsFor: '*OpalCompiler-Core' stamp: ''!
asMethodPreamble
	self numArgs = 0
		ifTrue: [ ^ self asString ].
	^ String
		streamContents: [ :str | 
			| keywords |
			keywords := self keywords.
			keywords
				doWithIndex: [ :each :index | 
					str
						nextPutAll: each;
						nextPutAll: ' var';
						nextPutAll: index asString.
					index = keywords size ifFalse: [ str space ] ] ]! !

!Symbol methodsFor: 'system primitives' stamp: ''!
numArgs: n
	"Answer a string that can be used as a selector with n arguments.
	 TODO: need to be extended to support shrinking and for selectors like #+ " 

	| selector numArgs offs |
	
	selector := self.
	(numArgs := selector numArgs) >= n 
		ifTrue: [ ^ self ].
	
	^ self class new: 16 streamContents: [ :stream|
		stream nextPutAll: self.
		(numArgs = 0) 
			ifTrue: [ stream nextPut: $:. offs := 0] 
			ifFalse: [ offs := 1 ].
		2 to: n - numArgs + offs do: [:i | 
			stream nextPutAll: 'with:' ]].! !

!Symbol methodsFor: 'testing' stamp: ''!
isUnary
	"Answer whether the receiver is an unary message selector."

	^ self precedence = 1! !

!Symbol methodsFor: '*SortFunctions-Core-converting' stamp: ''!
descending
	"Return a SortFunction around the receiver, where the receiver will be used as a unary message to send to both a and b during sorting, and then the result of said send will be collated in descending order using the <=> method."
	"(#('abc' 'de' 'fghi') sorted: #size descending) >>> #('fghi' 'abc' 'de')"

	^self asSortFunction reversed! !

!Symbol methodsFor: 'evaluating' stamp: ''!
cull: anObject 
	^anObject perform: self.! !

!Symbol methodsFor: 'converting' stamp: ''!
capitalized
	^ self asString capitalized asSymbol! !

!Symbol methodsFor: 'announcements' stamp: ''!
handlesAnnouncement: anAnnouncement 
	"Anything else than the announcement identifier (in the case of symbol i.e. #foo for ... on: #foo send: #bar to: nil) will not 
	be handled."
	
	"Announcer new 
		on: #FOO send: #bar to: nil;
		announce: #FOO should raise DNU bar"
	
	^ anAnnouncement == self! !

!Symbol methodsFor: 'testing' stamp: ''!
isDoIt

	^ (self == #DoIt) or: [self == #DoItIn:].! !

!Symbol methodsFor: '*SUnit-Core' stamp: ''!
isTestSelector

	^ self isUnary and: [ 
		  (self beginsWith: 'test') or: [ self beginsWith: 'should' ] ]! !

!Symbol methodsFor: 'converting' stamp: ''!
asMutator
	"Return a setter message from a getter message.
	Return self if it is already a setter. 
	Pay attention the implementation should be improved to return valid selector."
	
	"#name asMutator >>> #name:"
	"#name: asMutator >>> #name:"

	"#_ asMutator >>> #_:"
	"#foo:: asMutator >>> #'foo::'"
	
	self endsWithAColon ifTrue:[ ^ self ].
	^ (self copyWith: $:) asSymbol! !

!Symbol methodsFor: '*System-Support' stamp: ''!
implementors
	^SystemNavigation new allImplementorsOf: self! !

!Symbol methodsFor: 'sorting' stamp: ''!
sorted: aSortBlockOrNil
	"Return a new sequenceable collection which contains the same elements as self but its elements are sorted by aSortBlockOrNil. The block should take two arguments and return true if the first element should preceed the second one. If aSortBlock is nil then <= is used for comparison. We convert the symbol to an array because symbols can't be changed."
	
	^self asArray sort: aSortBlockOrNil! !

!Symbol methodsFor: '*SUnit-Core' stamp: ''!
asTestSelector

	"Converts a method selector into a test selector in form of #testOriginalSelector"

	"#+ asTestSelector >>> #testPlus"
	"#+-<> asTestSelector >>>  #testPlusMinusLessThanGreaterThan"
	"#message asTestSelector  >>> #testMessage"
	"#mySelector asTestSelector >>> #testMySelector"
	"#at:putNext: asTestSelector >>> #testAtPutNext"

	self isBinary ifTrue: [ 
		^ (#test, (self flatCollect: [ :each | (((Character specialCharacterNames at: each) copyReplaceAll: '-' with: ' ') substrings collect: #capitalized) joinUsing: ''])) asSymbol ].
	
	^ (#test, (((self copyReplaceAll: ':' with: ' ') substrings collect: #capitalized) joinUsing: '')) asSymbol! !

!Symbol methodsFor: 'accessing' stamp: ''!
at: anInteger put: anObject 
	"You cannot modify the receiver."

	self errorNoModification! !

!Symbol methodsFor: 'accessing' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart

	self errorNoModification! !

!Symbol methodsFor: '*Roassal3' stamp: ''!
rsValue: anObject 
	^ anObject perform: self! !

!Symbol methodsFor: 'copying' stamp: ''!
copy
	"Answer with the receiver, because Symbols are unique."! !

!Symbol methodsFor: 'converting' stamp: ''!
asSymbol 
	"Refer to the comment in String|asSymbol."! !

!Symbol methodsFor: '*Metacello-Core' stamp: ''!
setForVersion: aString withInMetacelloConfig: aMetacelloConstructore
    aMetacelloConstructore setFor: {self} version: aString! !

!Symbol methodsFor: 'testing' stamp: ''!
isSelectorSymbol
	^ (self class selectorTable like: self) notNil! !

!Symbol methodsFor: 'private' stamp: ''!
errorNoModification

	self error: 'symbols can not be modified.'! !

!Symbol methodsFor: 'accessing' stamp: ''!
precedence
	"Answer the receiver's precedence, assuming it is a valid Smalltalk
	message selector or 0 otherwise.  The numbers are 1 for unary,
	2 for binary and 3 for keyword selectors."

	self size = 0 ifTrue: [^ 0].
	(self first isLetter or: [ self first = $_ ]) ifFalse: [^ 2].
	self last = $: ifTrue: [^ 3].
	^ 1! !

!Symbol methodsFor: 'testing' stamp: ''!
includesKey: sym
	^self == sym.! !

!Symbol methodsFor: 'private' stamp: ''!
string: aString

	1 to: aString size do: [:j | super at: j put: (aString at: j)].
	^self! !

!Symbol methodsFor: 'system primitives' stamp: ''!
flushCache
	"Tell the virtual machine to remove all entries with this symbol as a selector from its method lookup caches, if it has any.  This 	must be done whenever a method is added, redefined or removed, so that message lookups reflect the revised organization.  c.f. 	Behavior>>flushCache & CompiledMethod>>flushCache.  Essential. See MethodDictionary class comment."

	<primitive: 119>! !

!Symbol methodsFor: 'comparing' stamp: ''!
= aSymbol
	"Compare the receiver and aSymbol." 
	self == aSymbol ifTrue: [^ true].
	self class == aSymbol class ifTrue: [^ false].
	"Use String comparison otherwise"
	^ super = aSymbol! !

!Symbol methodsFor: '*SortFunctions-Core-converting' stamp: ''!
asSortFunction
	"Return a SortFunction around the receiver, where the receiver will be used as a unary message to send to both a and b during sorting, and then the result of said send will be collated in ascending order using the <=> method."
	"(#('abc' 'de' 'fghi') sorted: #size ascending) >>> #('de' 'abc' 'fghi')"

	^PropertySortFunction property: self! !

!Symbol methodsFor: 'announcements' stamp: ''!
prepareForDelivery
	"somehow symbol can be announcemnt"! !

!Symbol methodsFor: 'copying' stamp: ''!
shallowCopy
	"Answer with the receiver, because Symbols are unique."! !

!Symbol methodsFor: 'testing' stamp: ''!
isKeyword
	"Answer whether the receiver is a message keyword."

	^ self precedence = 3! !

!Symbol methodsFor: 'testing' stamp: ''!
isBinary
	"Answer whether the receiver is a binary message selector."

	^ self precedence = 2! !

!Symbol methodsFor: '*Slot-Core' stamp: ''!
=> aVariable
	"If the slot we give as argument is not present in the image, we create an UndefinedSlot with the AST of the slot definition"

	^ aVariable 
		ifNil: [ UndefinedSlot named: self ast: thisContext sender sourceNodeExecuted]
		ifNotNil: [ aVariable named: self ]! !

!Symbol methodsFor: '*Metacello-Core' stamp: ''!
asMetacelloAttributeList
    ^ {self}! !

!Symbol methodsFor: '*Spec2-Core' stamp: ''!
asPresenterOn: aPresenter

	self flag: #TODO. "The additionalSubpresentersMap is a functionality that needs to 
	be removed, but for now we need to take it into account"
	^ [ aPresenter presenterAt: self ]
		on: SlotNotFound 
		do: [ :e |
			aPresenter additionalSubpresentersMap 
				at: self
				ifAbsent: [ e pass ] ]! !

!Symbol methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter writeSymbol: self! !

!Symbol methodsFor: '*SortFunctions-Core-converting' stamp: ''!
ascending
	"Return a SortFunction around the receiver, where the receiver will be used as a unary message to send to both a and b during sorting, and then the result of said send will be collated in ascending order using the <=> method."
	"(#('abc' 'de' 'fghi') sorted: #size ascending) >>> #('de' 'abc' 'fghi')"

	^self asSortFunction ! !

!Symbol methodsFor: '*System-Support' stamp: ''!
senders
	^ SystemNavigation default allSendersOf: self! !

!Symbol methodsFor: 'testing' stamp: ''!
isSymbol
	^ true! !

!Symbol methodsFor: '*Clap-Core' stamp: ''!
asClapIdentifier
	^ self! !

!Symbol methodsFor: '*Metacello-Core' stamp: ''!
setPostLoadDoItInMetacelloSpec: aMetacelloSpec
    self precedence == 0
        ifTrue: [ self error: 'Invalid selector' ].
    aMetacelloSpec
        setPostLoadDoIt:
            (aMetacelloSpec project valueHolderSpec
                value: self;
                yourself)! !

!Symbol methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."! !

!Symbol methodsFor: '*Metacello-Core' stamp: ''!
setPreLoadDoItInMetacelloSpec: aMetacelloSpec
    self precedence == 0
        ifTrue: [ self error: 'Invalid selector' ].
    aMetacelloSpec
        setPreLoadDoIt:
            (aMetacelloSpec project valueHolderSpec
                value: self;
                yourself)! !

!Symbol methodsFor: '*SortFunctions-Core-converting' stamp: ''!
collatedBy: aSortFunction
	"Return a SortFunction around the receiver, where the receiver will be used as a unary message to send to both a and b during sorting, and then the result of said send will be collated iusing aSortFunction."
	"(#('abc' 'de' 'fghi') sorted: (#size collatedBy: [:e|e bitAnd: 1]) , #size) >>> #( 'de' 'fghi' 'abc')"

	^PropertySortFunction property: self collatedWith: aSortFunction asSortFunction! !

!Symbol methodsFor: 'converting' stamp: ''!
asString 
	"Refer to the comment in String|asString."
	| newString |
	newString := self species new: self size.
	newString replaceFrom: 1 to: newString size with: self startingAt: 1.
	^newString! !

!Symbol methodsFor: 'copying' stamp: ''!
, otherSymbolOrString
	"Concatenate the receiver with otherSymbolOrString and return the result.
	Overwritten to always return Symbol results,
	whether the argument is a Symbol or a String"
	
	^ (super , otherSymbolOrString) asSymbol! !

!Symbol methodsFor: 'printing' stamp: ''!
storeOn: aStream 

	aStream nextPut: $#.
	(self isLiteralSymbol)
		ifTrue: [aStream nextPutAll: self]
		ifFalse: [super storeOn: aStream]! !

!Symbol class methodsFor: 'accessing' stamp: ''!
compactSymbolTable
	"Reduce the size of the symbol table so that it holds all existing symbols + 25% (changed from 1000 since sets like to have 25% free and the extra space would grow back in a hurry)"

	| oldSize |

	Smalltalk garbageCollect.
	oldSize := SymbolTable array size.
	SymbolTable growTo: SymbolTable size * 4 // 3 + 100.
	^oldSize printString,'  ',(oldSize - SymbolTable array size) printString, ' slot(s) reclaimed'! !

!Symbol class methodsFor: 'stream creation' stamp: ''!
new: size streamContents: aBlock
	^ (super new: size streamContents: aBlock) asSymbol! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
findInternedSelector: aString
	| symbol |
	symbol := self findInterned: aString.
	"if it isn't found or not a SelectorSymbol - return nil"
	(symbol isNil or: [ symbol isSelectorSymbol not ])
		ifTrue: [ ^ nil ].
	"otherwise, return this symbol"
	^ symbol! !

!Symbol class methodsFor: 'accessing' stamp: ''!
thatStartsCaseSensitive: leadingCharacters skipping: skipSym
	"Same as thatStarts:skipping: but caseSensitive"
	| size firstMatch key |

	size := leadingCharacters size.
	size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]].
	firstMatch := leadingCharacters at: 1.
	size > 1 ifTrue: [key := leadingCharacters copyFrom: 2 to: size].
	self allSymbolTablesDo: [:each |
			each size >= size ifTrue:
				[
					((each at: 1) == firstMatch and:
						[key == nil or:
							[(each findString: key startingAt: 2 caseSensitive: true) = 2]])
								ifTrue: [^each]
				]
		] after: skipSym.

	^nil! !

!Symbol class methodsFor: 'accessing' stamp: ''!
allSymbolTablesDo: aBlock

	NewSymbols do: aBlock.
	SymbolTable do: aBlock.! !

!Symbol class methodsFor: 'private' stamp: ''!
possibleSelectorsFor: misspelled 
	"Answer an ordered collection of possible corrections
	for the misspelled selector in order of likelyhood"

	| numArgs candidates lookupString best binary short long first |
	lookupString := misspelled asLowercase. "correct uppercase selectors to lowercase"
	numArgs := lookupString numArgs.
	(numArgs < 0 or: [lookupString size < 2]) ifTrue: [^ OrderedCollection new: 0].
	first := lookupString first.
	short := lookupString size - (lookupString size // 4 max: 3) max: 2.
	long := lookupString size + (lookupString size // 4 max: 3).

	"First assemble candidates for detailed scoring"
	candidates := OrderedCollection new.
	self allSymbolTablesDo: [:s | | ss | (((ss := s size) >= short	"not too short"
			and: [ss <= long			"not too long"
					or: [(s at: 1) = first]])	"well, any length OK if starts w/same letter"
			and: [s numArgs = numArgs])	"and numArgs is the same"
			ifTrue: [candidates add: s]].

	"Then further prune these by correctAgainst:"
	best := lookupString correctAgainst: candidates.
	((misspelled last ~~ $:) and: [misspelled size > 1]) ifTrue: [
		binary := misspelled, ':'.		"try for missing colon"
		Symbol hasInterned: binary ifTrue: [:him | best addFirst: him]].
	^ best! !

!Symbol class methodsFor: 'private' stamp: ''!
selectorTable
	^SelectorTable ifNil: [self initSelectorTable]! !

!Symbol class methodsFor: 'accessing' stamp: ''!
thatStarts: leadingCharacters skipping: skipSym
	"Answer a selector symbol that starts with leadingCharacters.
	Symbols beginning with a lower-case letter handled directly here.
	Ignore case after first char.
	If skipSym is not nil, it is a previous answer; start searching after it.
	If no symbols are found, answer nil.
	Used by Alt-q (Command-q) routines"

	| size firstMatch key |

	size := leadingCharacters size.
	size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]].

	firstMatch := leadingCharacters at: 1.
	size > 1 ifTrue: [key := leadingCharacters copyFrom: 2 to: size].

	self allSymbolTablesDo: [:each |
			each size >= size ifTrue:
				[
					((each at: 1) == firstMatch and:
						[key == nil or:
							[(each findString: key startingAt: 2 caseSensitive: false) = 2]])
								ifTrue: [^each]
				]
		] after: skipSym.

	^nil

"Symbol thatStarts: 'sf' skipping: nil"
"Symbol thatStarts: 'sf' skipping: #sfpGetFile:with:with:with:with:with:with:with:with:"
"Symbol thatStarts: 'candidate' skipping: nil"! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
internSelector: aStringOrSymbol
	| selector |
	selector := (self selectorTable like: aStringOrSymbol)
		ifNil: [ self selectorTable add: aStringOrSymbol asSymbol ].
	^ selector! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
readFrom: strm  
	"Symbol readFromString: '#abc'"

	strm peek = $# ifFalse: [self error: 'Symbols must be introduced by #'].
    	^ strm contents parseLiterals first.! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
internCharacter: aCharacter
	aCharacter asciiValue > 256 ifTrue:[^self intern: aCharacter asString].
	OneCharacterSymbols ifNil: [^self intern: aCharacter asString].
	^OneCharacterSymbols at: aCharacter asciiValue + 1! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
findInterned: aString

	self hasInterned:aString ifTrue:[:symbol| ^symbol].
	^nil.! !

!Symbol class methodsFor: 'class initialization' stamp: ''!
initialize
	self rehash.
	OneCharacterSymbols := nil.
	OneCharacterSymbols := (1 to: 256) collect: [ :i | (i - 1) asCharacter asSymbol].

	SessionManager default
		registerSystemClassNamed: #Symbol! !

!Symbol class methodsFor: 'private' stamp: ''!
hasInterned: aString ifTrue: symBlock
	"Answer with false if aString hasnt been interned (into a Symbol),  
	otherwise supply the symbol to symBlock and return true."

	^ (self lookup: aString)
		ifNil: [ false ]
		ifNotNil: [ :symbol | 
			symBlock value: symbol.
			true ]! !

!Symbol class methodsFor: 'accessing' stamp: ''!
selectorsContaining: aString
	"Answer a list of selectors that contain aString within them. Case-insensitive.  Does return symbols that begin with a capital letter."

	| size selectorList ascii |

	selectorList := OrderedCollection new.
	(size := aString size) = 0 ifTrue: [^selectorList].

	aString size = 1 ifTrue:
		[
			ascii := aString first asciiValue.
			ascii < 128 ifTrue: [selectorList add: (OneCharacterSymbols at: ascii+1)]
		].

	(aString first isAlphaNumeric) ifFalse:
		[
			aString size = 2 ifTrue: 
				[Symbol hasInterned: aString ifTrue:
					[:s | selectorList add: s]].
			^selectorList
		].

	selectorList := selectorList copyFrom: 2 to: selectorList size.

	self allSymbolTablesDo: [:each |
		each size >= size ifTrue:
			[(each findSubstring: aString in: each startingAt: 1 
				matchTable: CaseInsensitiveOrder) > 0
						ifTrue: [selectorList add: each]]].

	^selectorList reject: [:each | "reject non-selectors, but keep ones that begin with an uppercase"
		each numArgs < 0 and: [each asString uncapitalized numArgs < 0]].

"Symbol selectorsContaining: 'scon'"! !

!Symbol class methodsFor: 'system startup' stamp: ''!
shutDown: aboutToQuit

	SymbolTable addAll: NewSymbols.
	NewSymbols := WeakSet new.! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
new: aSize

	self shouldNotImplement .! !

!Symbol class methodsFor: 'accessing' stamp: ''!
allSymbolTablesDo: aBlock after: aSymbol

	NewSymbols do: aBlock after: aSymbol.
	SymbolTable do: aBlock after: aSymbol.! !

!Symbol class methodsFor: 'accessing' stamp: ''!
selectorThatStartsCaseSensitive: leadingCharacters skipping: skipSym
	"Same as thatStartsCaseSensitive:skipping: but on the SelectorTable only"
	| size firstMatch key |

	size := leadingCharacters size.
	size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]].
	firstMatch := leadingCharacters at: 1.
	size > 1 ifTrue: [key := leadingCharacters copyFrom: 2 to: size].
	self selectorTable do: [:each |
			(each notNil and: [each size >= size]) ifTrue:
				[
					((each at: 1) == firstMatch and:
						[key == nil or:
							[(each findString: key startingAt: 2 caseSensitive: true) = 2]])
								ifTrue: [^each]
				]
		] after: skipSym.

	^nil! !

!Symbol class methodsFor: 'accessing' stamp: ''!
allSymbols
	"Answer all interned symbols"
	^Array streamContents:[:s|
		s nextPutAll: NewSymbols.
		s nextPutAll: OneCharacterSymbols.
		s nextPutAll: SymbolTable.
	].! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
withAll: aCollection
	^ self newFrom: aCollection! !

!Symbol class methodsFor: '*Tool-Finder' stamp: ''!
forbiddenSelectorsForMethodFinder

	^ #(string: privateAt:put:)! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
lookup: aStringOrSymbol

	^(SymbolTable like: aStringOrSymbol) ifNil: [
		NewSymbols like: aStringOrSymbol
	]! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
intern: aStringOrSymbol 

	^(self lookup: aStringOrSymbol) ifNil:[
		| aClass aSymbol |
		aStringOrSymbol isSymbol ifTrue:[
			aSymbol := aStringOrSymbol.
		] ifFalse:[
			aClass := aStringOrSymbol isOctetString ifTrue:[ByteSymbol] ifFalse:[WideSymbol].
			aSymbol := aClass basicNew: aStringOrSymbol size.
			aSymbol string: aStringOrSymbol.
		].
		NewSymbols add: aSymbol.
		aSymbol].! !

!Symbol class methodsFor: 'cleanup' stamp: ''!
rebuildSelectorTable
	self initSelectorTable.
	CompiledMethod
		allInstancesDo: [ :method | 
			| selector |
			selector := method selector.
			selector ifNotNil: [ SelectorTable add: selector ] ]! !

!Symbol class methodsFor: 'private' stamp: ''!
initSelectorTable
	^ SelectorTable := WeakSet new! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	^ (aCollection as: String) asSymbol

"	Symbol newFrom: {$P. $e. $n}
	{$P. $e. $n} as: Symbol
"! !

!Symbol class methodsFor: 'accessing' stamp: ''!
streamSpecies
	^ String! !

!Symbol class methodsFor: 'cleanup' stamp: ''!
cleanUp
	"Flush caches"

	self compactSymbolTable.
	self rebuildSelectorTable! !

!Symbol class methodsFor: 'instance creation' stamp: ''!
with: aCharacter
	^self newFrom: aCharacter asOrderedCollection! !

!Symbol class methodsFor: 'private' stamp: ''!
rehash
   "Symbol rehash"
	"Rebuild the hash table, reclaiming unreferenced Symbols."

	SymbolTable := WeakSet withAll: self allSubInstances.
	NewSymbols := WeakSet new.
	self rebuildSelectorTable.! !

!SymbolTest commentStamp: ''!
This is the unit test for the class Symbol. 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!
!SymbolTest methodsFor: 'requirements' stamp: ''!
collection

	^ nonEmptySymbol5ElementsNoDuplicates! !

!SymbolTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne).! !

!SymbolTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutFirst

	| result |
	result := self nonEmpty copyWithoutFirst.
	
	self assert: result size equals: (self nonEmpty size - 1).
	
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (self nonEmpty at: (i + 1))]! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
sizeCollection
	"Answers a collection whose #size is 4"
	^ collectionSize4! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedConcatenationTest
	self empty.
	self assertEmpty: self empty.
	self firstCollection.
	self secondCollection! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
oldSubCollection
" return a subCollection included in collectionWith1TimeSubcollection .
ex :   subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)"
	^ subcollection3ElementsSorted! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
elementInForElementAccessing
" return an element inculded in 'moreThan4Elements'"
	^ self moreThan4Elements anyOne! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAt

	| subcollection index collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 1.
	self assert: index equals: 1.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 2.
	self assert: index equals: 0! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSubcollectionAccessTest

	self moreThan3Elements.
	self assert: self moreThan3Elements size > 2! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
testCopyReturnsIdentity
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: self nonEmpty == copy.! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirstNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!SymbolTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessFotMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!SymbolTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index between bounds of 'nonEmpty'"

	^ 2! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
moreThan3Elements
	" return a collection including atLeast 3 elements"
	^ nonEmptySymbol5ElementsNoDuplicates! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDoEmpty
	| result |
	result := OrderedCollection new.
	self empty reverseDo: [ :each | result add: each ].

	self assertEmpty: result! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollect
	
	| result firstCollection secondCollection index  |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	result := firstCollection  with: secondCollection collect:
		[:a :b |
		( index := index + 1).
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals:  b.
		b].
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (secondCollection  at: i)].
	self assert: result size = secondCollection size! !

!SymbolTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
moreThan4Elements

" return a collection including at leat 4 elements"
	^ nonEmptySymbol5ElementsNoDuplicates! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLastNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testCapitalized
	| uc lc |
	uc := #MElViN.
	lc := #mElViN.
	self assert: lc capitalized equals: uc.
	self assert: uc capitalized equals: uc! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
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! !

!SymbolTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!SymbolTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', '.
	
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString withIndexDo: 
		[:el :i |  self assert: el equals: ((self nonEmpty at:i)asString)]! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsCollect
	| index result |
	index := 0.

	result := self nonEmptyMoreThan1Element
		pairsCollect: [ :each1 :each2 | 
			self assert: (self nonEmptyMoreThan1Element indexOf: each2) equals: (index := index + 2).
			(self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1) ].

	result do: [ :each | self assert: each ]! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOf

	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element) equals: (collection indexOf: element)! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
nonEmptyMoreThan1Element
" return a collection that don't includes equal elements'" 
	^nonEmptySymbol5ElementsNoDuplicates! !

!SymbolTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printElementsOn: aStream.
	allElementsAsString:=(result findBetweenSubstrings: ' ').
	allElementsAsString withIndexDo: 
		[:el :i | self assert: el equals: ((self nonEmpty at: i)asString) ]! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testAtRandom

	| result |
	result := self nonEmpty atRandom.
	self assert: (self nonEmpty includes: result)! !

!SymbolTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!SymbolTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!SymbolTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringOne
	
	"self assert: self oneItemCol asCommaString = '1'.
	self assert: self oneItemCol asCommaStringAnd = '1'."

	self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString).
	self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString)! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
testCopyNonEmptyWithoutAllNotIncluded! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	^ notIn! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
anotherElementNotIn
	^ notIn! !

!SymbolTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfIfAbsentDuplicate

	| 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 ]) equals: 1! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testFirstSecondThird

	self assert: self moreThan4Elements first equals: (self moreThan4Elements at: 1).
	self assert: self moreThan4Elements second equals: (self moreThan4Elements at: 2).
	self assert: self moreThan4Elements third equals: (self moreThan4Elements at: 3).
	self assert: self moreThan4Elements fourth equals: (self moreThan4Elements at: 4)! !

!SymbolTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!SymbolTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfIfAbsentDuplicate

	| 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 ]) equals: collection size! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterEmpty
	| result |
	result := self empty copyAfter: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
collectionClass
	"Return the class to be used to create instances of the class tested"
	
	^ Symbol! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureBeginsEndsWithTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self assert: self nonEmpty size > 1.
	self empty.
	self assertEmpty: self empty! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testAtIfAbsent

	| 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! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterLastWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the last occurrence of element :"
	result := collection copyAfterLast: element.

	"Verify content"
	self assertEmpty: result! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testMiddle

	self assert: self moreThan4Elements middle equals: (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! !

!SymbolTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
elementNotIn
"return an element not included in 'nonEmpty' "

	^ notIn! !

!SymbolTest methodsFor: 'tests - copying same contents' stamp: ''!
testReverse

	| result |
	result := self nonEmpty reversed.	
	"verify content of 'result: '"
	1 to: result size do:
		[:i | self assert: ((result at: i) 
			= (self nonEmpty at: (self nonEmpty size - i + 1)))].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testBeforeIfAbsent

	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)! !

!SymbolTest methodsFor: 'tests - sorting' stamp: ''!
testIsSorted
	self assert: self sortedInAscendingOrderCollection isSorted.
	self deny: self unsortedCollection isSorted! !

!SymbolTest methodsFor: 'tests - subcollections access' stamp: ''!
testLastNElements

	| result |
	result := self moreThan3Elements last: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i + 1) ].
	self assert: result size equals: (self moreThan3Elements size - 1).
	self 
		should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ]
		raise: Error! !

!SymbolTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printNameOn: aStream.

	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents equals: ('an ',self nonEmpty class name ) ]
		ifFalse:[ self assert: aStream contents equals: ('a ',self nonEmpty class name)].! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
	" return a collection only including elements that can be sorted (understanding '<' )"
	^ nonEmptySymbol5ElementsNoDuplicates .! !

!SymbolTest methodsFor: 'tests - equality' stamp: ''!
testHasEqualElementsOfIdenticalCollectionObjects
	
	self assert: (self empty hasEqualElements: self empty). 
	self assert: (self nonEmpty hasEqualElements: self nonEmpty)! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButFirstDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButFirstDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i +1))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element size-1)! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLastEmpty
	| result |
	result := self empty copyUpToLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAtIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!SymbolTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWithManyOccurrence
	| result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff |
	" testing fixture here as this method may be not used for collection that can't contain equals element :"
	self collectionWith2TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection) = 2.	" test :"
	diff := self replacementCollection size - self oldSubCollection size.
	result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection.	"detecting indexes of olSubCollection"
	firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection.	" verifying that replacementCollection has been put in places of oldSubCollections "
	firstIndexesOfOccurrence
		do: [ :each | 
			(firstIndexesOfOccurrence indexOf: each) = 1
				ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ]
				ifFalse: [ each + diff to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ].	" verifying that the 'between' parts correspond to the initial collection : "
	1 to: firstIndexesOfOccurrence size do: [ :i | 
		i = 1
			ifTrue: [ 1 to: (firstIndexesOfOccurrence at: i) - 1 do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ]
			ifFalse: [ 
				resultBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self replacementCollection size.
				collectionBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self oldSubCollection size.
				1 to: (firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | 
					self
						assert:
							(result at: resultBetweenPartIndex + i - 1)
								= (self collectionWith2TimeSubcollection at: collectionBetweenPartIndex + i - 1) ] ]	" specific comportement for the begining of the collection :"	" between parts till the end : " ].	"final part :"
	1 to: self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size) do: [ :i | 
		self
			assert:
				(result at: firstIndexesOfOccurrence last + self replacementCollection size - 1 + i)
					= (self collectionWith2TimeSubcollection at: firstIndexesOfOccurrence last + self oldSubCollection size - 1 + i) ]! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOf

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection lastIndexOf: element) = 1.
	self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! !

!SymbolTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDoError
	
	self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error! !

!SymbolTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignForSequenceableCollections

	self deny: (self nonEmpty = self nonEmpty asSet). 
	self deny: (self nonEmpty reversed = self nonEmpty).
	self deny: (self nonEmpty = self nonEmpty reversed)! !

!SymbolTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForEmptyButNonIdenticalCollections
	
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy! !

!SymbolTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingStartWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty .
	result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ).
	
	"verify content of 'result' : "
	1 to: 2   do:
		[:i | self assert: ( element ) = ( result at:(i) ) ].
	
	3 to: result size do:
		[:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ].

	"verify size of 'result' :"
	self assert: result size = (self nonEmpty size + 2).! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
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)]]! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDoEmpty
	| result |
	result := OrderedCollection new.

	self empty keysAndValuesDo: [ :i :value | result add: value + i ].

	self assertEmpty: result! !

!SymbolTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithSequenceable

	| result index element |
	index := self indexInNonEmpty.
	element := self nonEmpty at: index.
	result := self nonEmpty copyWith: (element ).
	
	self assert: result size equals: (self nonEmpty size + 1).
	self assert: result last equals: element.
	
	1 to: (result size - 1) do:
		[ :i | self assert: (result at: i) equals: ( self nonEmpty at: i)]! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexCollect
	
	| result index collection |
	index := 0.
	collection := self nonEmptyMoreThan1Element .
	result := collection  withIndexCollect: [:each :i | 
		self assert: i equals: (index := index + 1).	
		self assert: i equals: (collection  indexOf: each).
		each ]. 
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (collection at: i)].
	self assert: result size equals: collection size! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testAsMutator
	self assert: #x asMutator equals: #x:.
	"return receiver if it is already a mutator"
	self assert: #x: asMutator equals: #x:.
	self assert: #x asMutator isSymbol! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
elementInForIndexAccessing
" return an element included in 'collectionMoreThan1NoDuplicates' "
	^ self collectionMoreThan1NoDuplicates anyOne.! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDetectSequenced
	"Testing that detect keep the first element returning true for sequenceable collections"

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element  detect: [:each | each notNil ].
	self assert: result equals: element! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection last.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: 99! !

!SymbolTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWithInsertion
	| result  indexOfSubcollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: ( indexOfSubcollection - 1 ) with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'' : '"
	
	1 to: (indexOfSubcollection -1) do: 
		[
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i)=(result at: i)
		].
	
	" middle part containing replacementCollection : "
	indexOfSubcollection  to: (indexOfSubcollection  + self replacementCollection size-1) do: 
		[
		:i |
		self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 ))
		].
	
	" end part :"
	(indexOfSubcollection  + self replacementCollection size) to: (result size) do:
		[:i|
		self assert: (result at: i)=(self collectionWith1TimeSubcollection  at: (i-self replacementCollection size))].
	
	" verify size: "	
	self assert: result size=(self collectionWith1TimeSubcollection  size + self replacementCollection size).! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopySameContentsTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
collectionWith2TimeSubcollection
" return a collection including 'oldSubCollection'  two or many time "
	^ with2timeSubcollection! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLast

	| index |
	self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last.

	index := self moreThan4Elements indexOf: self elementInForElementAccessing.
	self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! !

!SymbolTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self collection anyOne! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
secondCollection
" return a collection that will be the second part of the concatenation"
	^ collectionSize4! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	^ nonEmptySymbol5ElementsNoDuplicates! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
elementNotInForIndexAccessing
" return an element not included in 'collectionMoreThan1NoDuplicates' "
	^ notIn! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testCollectFromTo
	
	| result |
	result:=self nonEmptyMoreThan1Element 
		collect: [ :each | each ]
		from: 1
		to: (self nonEmptyMoreThan1Element size - 1).
		
	1 to: result size
		do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ].
	self assert: result size = (self nonEmptyMoreThan1Element size - 1)! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
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 ]! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfIfAbsent

	| collection |
	collection := self collectionMoreThan1NoDuplicates.
	self assert: (collection 
			indexOf: collection first
			ifAbsent: [ 33 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 33 ]) equals: 33! !

!SymbolTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ Symbol! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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.! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfForMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFromToDo
	
	| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each].
	
	1 to: (self nonEmptyMoreThan1Element  size -1) do:
		[:i | self assert: (self nonEmptyMoreThan1Element at:i) = (result at:i) ].

	self assert: result size = (self nonEmptyMoreThan1Element size - 1).! !

!SymbolTest methodsFor: 'tests - copying same contents' stamp: ''!
testReversed

	| result |
	result := self nonEmpty reversed.
	
	"Verify content"
	result withIndexDo:
		[:el :i | self assert: el equals: (self nonEmpty at: (self nonEmpty size - i + 1))].

	"Verify size"
	self assert: result size=self nonEmpty size.! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
empty
	^ emptySymbol! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDo
	| result |
	result := OrderedCollection new.
	self nonEmpty reverseDo: [: each | result add: each].
	
	1 to: result size do:
		[:i|
		self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))]! !

!SymbolTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
collectionWith1TimeSubcollection
" return a collection including 'oldSubCollection'  only one time "
	^ nonEmptySymbol5ElementsNoDuplicates! !

!SymbolTest methodsFor: 'tests - sorting' stamp: ''!
testSortedUsingBlock
	| result tmp |
	result := self unsortedCollection sorted:  [:a :b | a>b]..
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!SymbolTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	self deny: (self nonEmpty includesAny: self empty).
	self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }).
	self assert: (self nonEmpty includesAny: self nonEmpty).! !

!SymbolTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWith
	
	self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst).
	self assert: (self nonEmpty endsWith: self nonEmpty).
	self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0TSequencedStructuralEqualityTest

	self nonEmpty at: 1	"Ensures #nonEmpty is sequenceable"! !

!SymbolTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty

	| result |
	result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne).
	self assert: result equals: 0! !

!SymbolTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfStartingAtDuplicate

	| 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 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 55 ]) equals: 1! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan1NoDuplicates
	" return a collection of size > 1 without equal elements"
	^ nonEmptySymbol5ElementsNoDuplicates! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLastEmpty
	| result |
	result := self empty copyAfterLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
withEqualElements
	" return a collection  including equal elements (classic equality)"
	^ sameAtEndAndBegining! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
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) ]! !

!SymbolTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButFirstNElements

	| allButFirst collection |
	collection := self moreThan3Elements.
	allButFirst := collection allButFirst: 2.
	allButFirst withIndexDo: 
		 [:el :i | self assert: el equals: (collection at: i + 2) ].
	self assert: allButFirst size + 2 equals: collection size! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
collectionWithSameAtEndAndBegining
	" return a collection with elements at end and begining equals .
(others elements of the collection are not equal to those elements)"
	^ sameAtEndAndBegining! !

!SymbolTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
" return a collection of size 1 including one element"
	^collection1Element! !

!SymbolTest methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWith
	
	self assert: (self nonEmpty beginsWith: (self nonEmpty copyUpTo: self nonEmpty last)).
	self assert: (self nonEmpty beginsWith: self nonEmpty).
	self deny: (self nonEmpty beginsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesForMultiplinessTest
	| cpt |
	self collectionWithEqualElements.
	self collectionWithEqualElements.
	self elementTwiceInForOccurrences.
	self elementTwiceInForOccurrences.
	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! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
sortedInAscendingOrderCollection
	"Return a collection sorted in ascending order"
	^ collectionSize4! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testNumArgs2
	"TODO: need to be extended to support shrinking and for selectors like #+ "

	self assert: (#test numArgs: 0) equals: #test.
	self assert: (#test numArgs: 1) equals: #test:.
	self assert: (#test numArgs: 2) equals: #test:with:.
	self assert: (#test numArgs: 3) equals: #test:with:with:.


	self assert: (#test: numArgs: 0) equals: #test:.
	self assert: (#test: numArgs: 1) equals: #test:.
	self assert: (#test: numArgs: 2) equals: #test:with:.
	self assert: (#test: numArgs: 3) equals: #test:with:with:.

	self assert: (#test:with: numArgs: 0) equals: #test:with:.
	self assert: (#test:with: numArgs: 1) equals: #test:with:.
	self assert: (#test:with: numArgs: 2) equals: #test:with:.
	self assert: (#test:with: numArgs: 3) equals: #test:with:with:.
	self assert: (#test:with: numArgs: 4) equals: #test:with:with:with:.

	self assert: (#test:with:with: numArgs: 0) equals: #test:with:with:.
	self assert: (#test:with:with: numArgs: 1) equals: #test:with:with:.
	self assert: (#test:with:with: numArgs: 2) equals: #test:with:with:.
	self assert: (#test:with:with: numArgs: 3) equals: #test:with:with:.
	self assert: (#test:with:with: numArgs: 4) equals: #test:with:with:with:! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest

	self nonEmpty! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
indexInForCollectionWithoutDuplicates
" return an index between 'collectionWithoutEqualsElements'  bounds"
	^ 2! !

!SymbolTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopy

	| result |
	result := self nonEmpty shallowCopy.
	
	"Verfy content"
	self nonEmpty withIndexDo:
		[:el :i | self assert: (result at:i) equals: (self nonEmpty at:i)].
	
	"Verify size"
	self assert: result size equals: self nonEmpty size.! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsDo

	| index |
	index:=1.
	
	self nonEmptyMoreThan1Element  pairsDo: 
		[:each1 :each2 | 
		self assert: (self nonEmptyMoreThan1Element at:index) equals: each1.
		self assert: (self nonEmptyMoreThan1Element at:(index+1)) equals: each2.
		index := index + 2 ].
	
	self nonEmptyMoreThan1Element size odd
		ifTrue:[ self assert: index equals: self nonEmptyMoreThan1Element size ]
		ifFalse:[ self assert: index equals: (self nonEmptyMoreThan1Element size+1) ]! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testAtWrap
	"
	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)! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!SymbolTest methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty.
	result := self nonEmpty forceTo: (self nonEmpty size + 2) paddingWith: element.
	
	"Verify content of 'result'"
	self nonEmpty withIndexDo:
		[:el :index | self assert: el equals: (result at: index) ].
	
	(result size - 1) to: result size do:
		[:i | self assert: (result at:i) equals: element ].

	"Verify size of 'result'"
	self assert: result size equals: self nonEmpty size + 2! !

!SymbolTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLast

	| abf col |
	col := self moreThan3Elements.
	abf := col allButLast.
	self deny: abf last = col last.
	self assert: abf size + 1 equals: col size! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexDo

	|  indexes elements |
	indexes:= OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:value :i  |
			indexes  add: (i).
			elements add: value ].
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:el :i |
			self assert: (indexes at: i) equals: i.
			self assert: (elements at: i) equals: el ].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastIfAbsent

	self assert: (self moreThan4Elements 
			atLast: 1
			ifAbsent: [ nil ]) = self moreThan4Elements last.
	self assert: (self moreThan4Elements 
			atLast: self moreThan4Elements size + 1
			ifAbsent: [ 222 ]) = 222! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testReadFrom
	self expectedBehavior do: [ :association | self assert: association key value identicalTo: association value ]! !

!SymbolTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!SymbolTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testUncapitalized
	| uc lc |
	uc := #MElViN.
	lc := #mElViN.
	self assert: uc uncapitalized equals: lc.
	self assert: lc uncapitalized equals: lc! !

!SymbolTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLastNElements

	| allButLast collection |
	collection := self moreThan3Elements.
	allButLast := collection allButLast: 2.
	allButLast withIndexDo: [:el :i | self assert: el equals: (collection at: i) ].
	self assert: allButLast size + 2 equals: collection size! !

!SymbolTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	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)]]! !

!SymbolTest methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWithEmpty
	
	self deny: (self nonEmpty beginsWith:(self empty)).
	self deny: (self empty beginsWith:(self nonEmpty))! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithOrWithoutSpecificElementsTest

	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self indexInNonEmpty.
	self assert: self indexInNonEmpty > 0.
	self assert: self indexInNonEmpty <= self nonEmpty size! !

!SymbolTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithFirst

	| index element result |
	index:= self indexInNonEmpty .
	element:= self nonEmpty at: index.
	
	result := self nonEmpty copyWithFirst: element.	
	
	self assert: result size = (self nonEmpty size + 1).
	self assert: result first = element .
	
	2 to: result size do:
	[ :i |
	self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! !

!SymbolTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfDuplicate

	| 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) equals: collection size! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpTo

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection   copyUpTo: (collection  at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at:i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testDisplayString

	| actual |
	actual := #'some symbol' displayString.
	self assert: actual equals: 'some symbol'! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLast

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection copyUpToLast: (collection at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at: i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			lastIndexOf: element
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 99 ]) equals: 99! !

!SymbolTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
" return a collection for wich each element is not included in 'nonEmpty' "
	^ collectionNotIncluded! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToLastWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyUpToLast:' should copy until the last occurrence :"
	result := collection copyUpToLast: (element ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (collection at: i) ].
	
	self assert: result size equals: (collection size - 1)! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0SortingArrayedTest
	| tmp sorted |
	" an unsorted collection of number "
	self unsortedCollection.
	self unsortedCollection do: [ :each | each isNumber ].
	sorted := true.
	self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ].
	self deny: sorted.	" a collection of number sorted in an ascending order"
	self sortedInAscendingOrderCollection.
	self sortedInAscendingOrderCollection do: [ :each | each isNumber ].
	tmp := self sortedInAscendingOrderCollection at: 1.
	self sortedInAscendingOrderCollection
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	firstCollection  with: secondCollection do:
		[:a :b |
		index := index + 1.
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals: b ]! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testNumArgsKeyword2
	self assert: 'name:with:' numArgs equals: 2.

	self assert: '_name:with:' numArgs equals: 2.
	self assert: 'na_me:with:' numArgs equals: 2.
	self assert: 'name_:with:' numArgs equals: 2.

	self assert: 'name:_with:' numArgs equals: 2.
	self assert: 'name:wi_th:' numArgs equals: 2.
	self assert: 'name:with_:' numArgs equals: 2.

	self assert: 'name:with: ' numArgs equals: -1.
	self assert: 'name: with:' numArgs equals: -1.
	self assert: ' name:with:' numArgs equals: -1.

	self assert: 'name+:with:' numArgs equals: -1.
	self assert: '+name:with:' numArgs equals: -1.
	self assert: 'na+me:with:' numArgs equals: -1.

	self assert: '123name:with:' numArgs equals: -1.
	self assert: 'name123:with:' numArgs equals: 2.
	self assert: 'name:123with:' numArgs equals: -1.
	self assert: 'name:with123:' numArgs equals: 2! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"There is only one symbol, the copy is the same"

	| copy |
	copy := self nonEmpty copy.
	self assert: copy identicalTo: self nonEmpty! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testGroupsOfAtATimeCollect
	| groupsOf2 |
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: [ :x | x ]).
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: #yourself).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 2 atATimeCollect: [ :x | x ].
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 2.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 2 ]).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 3 atATimeCollect: #yourself.
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 3.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 3 ]).! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithReplacementTest
	self replacementCollection.
	self oldSubCollection.
	self collectionWith1TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! !

!SymbolTest methodsFor: 'tests - copying' stamp: ''!
elementToAdd
	^ $u! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
testNew
	
	self should: [Symbol new: 5 ] raise: self defaultTestError.! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAtIfAbsent
	| absent subcollection collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ].
	self deny: absent.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ].
	self assert: absent! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SymbolTest methodsFor: 'tests - converting' stamp: ''!
testAsSet
 	"Test with a collection without equal elements"
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set! !

!SymbolTest methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWithEmpty
	
	self deny: (self nonEmpty endsWith: self empty).
	self deny: (self empty endsWith: self nonEmpty)! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLast

	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection copyAfterLast: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!SymbolTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''!
testOccurrencesOfForMultipliness

	| collection elem |
	collection := self collectionWithEqualElements.
	elem := self elementTwiceInForOccurrences.

	self assert: (collection occurrencesOf: elem ) equals: 2.! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testNumArgsBinary
	self assert: '-' numArgs equals: 1.
	self assert: '++' numArgs equals: 1.
	self assert: '*&@' numArgs equals: 1.

	self assert: ' ++' numArgs equals: -1.
	self assert: '+ +' numArgs equals: -1.
	self assert: '++ ' numArgs equals: -1.

	self assert: '_++' numArgs equals: -1.
	self assert: '+_+' numArgs equals: -1.
	self assert: '++_' numArgs equals: -1.

	self assert: '1' numArgs equals: -1.
	self assert: '*a' numArgs equals: -1! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
elementNotInForOccurrences
	^ notIn! !

!SymbolTest methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutIndex

	| result index |	
	index := self indexInNonEmpty.
	result := self nonEmpty copyWithoutIndex: index.
	
	"Verify content of result"
	result withIndexDo: 
		[:element :i | 
		 i <  index ifTrue: [ self assert: element equals: (self nonEmpty at: i) ].
		 i >= index ifTrue: [ self assert: element equals: (self nonEmpty at: (i + 1)) ]].
	
	"Verify size of result"
	self assert: result size equals: (self nonEmpty size - 1)! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testConcatenationIsSymbol
	"Concatenating 2 symbols results in another symbol"

	self assert: (#foo , #bar) isSymbol.
	self assert: #foo , #bar identicalTo: #foobar.

	"Concatenating the empty Symbol does not change a Symbol"
	self assert: #foo , emptySymbol identicalTo: #foo.
	self assert: emptySymbol , #foo identicalTo: #foo.

	"Strings and Symbols can still be mixed, the receiver determines the result type"
	"Symbol receiver gives Symbol result"
	self assert: (#foo , 'bar') isSymbol.
	self assert: #foo , 'bar' identicalTo: #foobar.
	"String receiver gives String result"
	self assert: ('foo' , #bar) isString.
	self assert: 'foo' , #bar equals: 'foobar'.
	"Strings and Symbols still compare content-wise"
	self assert: 'foo' , #bar equals: #foobar.
	"But Strings and Symbols are not identical"
	self deny: 'foo' , #bar identicalTo: #foobar! !

!SymbolTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	emptySymbol := #''.
	collectionSize4 := #abcd.
	collection1Element := #a.
	subcollection3ElementsSorted := #bcd.
	with2timeSubcollection := #abcdebcda.
	nonEmptySymbol5ElementsNoDuplicates := #abcde.
	sameAtEndAndBegining := #abcda.
	notIn := $z.
	collectionNotIncluded := #zz.! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testSorted
	| result tmp unsorted |
	unsorted := self unsortedCollection.
	result := unsorted sorted.
	self deny: unsorted == result.
	tmp := result at: 1.
	result
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!SymbolTest methodsFor: 'tests - sorting' stamp: ''!
testIsSortedBy
	self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]).
	self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]).! !

!SymbolTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result:= self empty,self secondCollection .
	
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:i).
		].
	"size : "
	self assert: result size = ( self secondCollection size).! !

!SymbolTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringMore

	"self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'.
	self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3'"

	| result resultAnd index allElementsAsString |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
 
	index := 1.
	(result findBetweenSubstrings: ',' )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 findBetweenSubstrings: ',' ).
	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 )]
				].
		
		
			].! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!SymbolTest methodsFor: '*ScriptingExtensions-Tests' stamp: ''!
testAsClassIfPresent
	
	#Symbol asClassIfPresent: [ :class | 
		self assert: class equals: Symbol ].
	
	#'+' asClassIfPresent: [ ^ self fail ].! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testLast

	self assert: self moreThan4Elements last equals: (self moreThan4Elements at: self moreThan4Elements size)! !

!SymbolTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation
	| result index |
	result:= self firstCollection,self secondCollection .
	"first part : "
	index := 1.
	self firstCollection do: 
		[:each | 
		self assert: (self firstCollection at: index)=each.
		index := index+1.].
	"second part : "
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:index).
		index:=index+1].
	"size : "
	self assert: result size = (self firstCollection size + self secondCollection size).! !

!SymbolTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContentsSized
	| result |
	result:= self collectionClass new: 1 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.
	
	result:= self collectionClass new: 1000 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
replacementCollection
" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection'  " 
	^ collection1Element! !

!SymbolTest methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopyEmpty
	| result |
	result := self empty shallowCopy.
	self assertEmpty: result! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertAsSetForMultiplinessTest
	"a collection  with equal elements:"

	| res |
	self withEqualElements.
	res := true.
	self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res = true! !

!SymbolTest methodsFor: 'accessing' stamp: ''!
expectedBehavior
	^ { 
		  ([ Symbol readFromString: '#''abc''' ] -> #abc).
		  ([ Symbol readFromString: '#ab-C' ] -> #ab).
		  ([ Symbol readFromString: '#abC' ] -> #abC).
		  ([ Symbol readFromString: '#ab@c' ] -> #ab) }! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
howMany: aSubCollection in: collection
" return an integer representing how many time 'subCollection'  appears in 'collection'  "
	| tmp nTime |
	tmp := collection.
	nTime:= 0.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				nTime := nTime + 1.
				1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.]
				]
			ifFalse: [tmp := tmp copyWithoutFirst.]
		 ].
	
	^ nTime.! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateSequencedReadableTest
	| res |
	self nonEmptyMoreThan1Element.
	self assert: self nonEmptyMoreThan1Element size > 1.

	self empty.
	self assertEmpty: self empty.

	res := true.
	self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
firstCollection
" return a collection that will be the first part of the concatenation"
	^ nonEmptySymbol5ElementsNoDuplicates! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
unsortedCollection
" retur a collection that is not yat sorted"
	^ with2timeSubcollection! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDo! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessTest
	| res |
	self collectionMoreThan1NoDuplicates.
	self assert: self collectionMoreThan1NoDuplicates size > 1.
	res := true.
	self collectionMoreThan1NoDuplicates
		detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self elementInForIndexAccessing.
	self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing).
	self elementNotInForIndexAccessing.
	self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! !

!SymbolTest methodsFor: 'tests - as set tests' stamp: ''!
testAsIdentitySetWithEqualsElements
	| result collection |
	collection := self withEqualElements .
	result := collection asIdentitySet.
	collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = IdentitySet.! !

!SymbolTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testIsLiteralSymbol

	self assert: ('*+-/\~=<>&@%,|' allSatisfy: [:char | (Symbol with: char) isLiteralSymbol])
		description: 'single letter binary symbols can be printed without string quotes'.
		
	self assert: (#('x' 'x:' 'x:y:' 'from:to:by:' 'yourself') allSatisfy: [:str | str asSymbol isLiteralSymbol])
		description: 'valid ascii selector symbols can be printed without string quotes'.! !

!SymbolTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty ).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
" return a collection of elements included in 'nonEmpty'  "
	^ subcollection3ElementsSorted! !

!SymbolTest methodsFor: 'tests - copying with replacement' stamp: ''!
firstIndexesOf: aSubCollection in: collection
" return an OrderedCollection with the first indexes of the occurrences of subCollection in  collection "
	| tmp result currentIndex |
	tmp:= collection.
	result:= OrderedCollection new.
	currentIndex := 1.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				result add: currentIndex.
				1 to: aSubCollection size do: 
					[:i | 
					tmp := tmp copyWithoutFirst.
					currentIndex := currentIndex + 1]
				]
			ifFalse: [
				tmp := tmp copyWithoutFirst.
				currentIndex := currentIndex +1.
				]
		 ].
	
	^ result.! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!SymbolTest methodsFor: '*ScriptingExtensions-Tests' stamp: ''!
testAsClassIfAbsent

	self 
		assert: (#Symbol asClassIfAbsent: [ self fail ])
		equals: Symbol.
		
	#+ asClassIfAbsent: [ ^ self "success" ].
	self fail.! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyFromTo
	| result  index collection |
	collection := self collectionWithoutEqualElements .
	index :=self indexInForCollectionWithoutDuplicates .
	result := collection   copyFrom: index  to: collection  size .
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at:i) equals: (collection  at: (i + index - 1))].
	
	"Verify size"
	self assert: result size equals: (collection  size - index + 1)! !

!SymbolTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	allElementsAsString withIndexDo: 
		[:el :i | 
		i=1
			ifTrue:[
				self accessCollection class name first isVowel 
					ifTrue:[self assert: el equals: 'an' ]
					ifFalse:[self assert: el equals: 'a'].].
		i=2
			ifTrue:[self assert: el equals: self accessCollection class name].
		i>2
			ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]]! !

!SymbolTest methodsFor: 'tests - subcollections access' stamp: ''!
testFirstNElements

	| result |
	result := self moreThan3Elements first: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i) ].
	
	self assert: result size equals: (self moreThan3Elements size - 1).
	self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: SubscriptOutOfBounds! !

!SymbolTest methodsFor: 'tests - testing' stamp: ''!
testEndsWithAColon
	 
	self assert: #fred: endsWithAColon.

	self deny: #'fred' endsWithAColon.

	self deny: #fred endsWithAColon.! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the first occurrence:"
	result := collection   copyAfter: (element ).
	
	"Verifying content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + 1 )) equals: (result at: (i)) ].

	"Verify size"
	self assert: result size equals: (collection size - 1).! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	difference := self collectionWithoutEqualElements difference: self empty.
	self assert: difference size = self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each) ]! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
elementNotInForElementAccessing
" return an element not included in 'moreThan4Elements' "
	^ notIn! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDo
	"| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		result add: (value+i)].
	
	1 to: result size do:
		[:i|
		self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]"
	|  indexes elements |
	indexes := OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		indexes  add: (i).
		elements add: value].
	
	(1 to: self nonEmptyMoreThan1Element size )do:
		[ :i |
		self assert: (indexes at: i) equals: i.
		self assert: (elements at: i) equals: (self nonEmptyMoreThan1Element at: i).	
		].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	^nonEmptySymbol5ElementsNoDuplicates! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testNumArgsKeyword1
	self assert: 'name:' numArgs equals: 1.

	self assert: 'name_:' numArgs equals: 1.
	self assert: '_name:' numArgs equals: 1.
	self assert: 'na_me:' numArgs equals: 1.

	self assert: 'name: ' numArgs equals: -1.
	self assert: ' name:' numArgs equals: -1.
	self assert: 'na me:' numArgs equals: -1.

	self assert: 'name+:' numArgs equals: -1.
	self assert: '+name:' numArgs equals: -1.
	self assert: 'na+me:' numArgs equals: -1.

	self assert: 'name123:' numArgs equals: 1.
	self assert: 'na123me:' numArgs equals: 1.
	self assert: '123name:' numArgs equals: -1! !

!SymbolTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString |
	result:=''.
	aStream:= ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ').
	allElementsAsString withIndexDo: 
		[:el :i | 
		i<(allElementsAsString size-1 )
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:i)asString)].
		i=(allElementsAsString size-1)
			ifTrue:[ self deny: (allElementsAsString at:i) equals: ('and')asString].
		i=(allElementsAsString size)
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:(i-1))asString)]]! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!SymbolTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!SymbolTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''! !

!SymbolTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfStartingAtDuplicate

	| 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 ]) equals: 1.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 55 ]) equals: collection size! !

!SymbolTest methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfDuplicate

	| 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) equals: 1! !

!SymbolTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!SymbolTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result index |
	delim := ', '.
	result := ''.
	multiItemStream := ReadWriteStream on: result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	index:=1.
	(result findBetweenSubstrings: delim)do:
		[:each |
			self assert: each= ((self nonEmpty at:index) asString).
			index:=index+1 ]! !

!SymbolTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfSequenceableTest
	self collectionWithoutEqualElements.
	self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ].
	self indexInForCollectionWithoutDuplicates.
	self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size.
	self empty.
	self assertEmpty: self empty! !

!SymbolTest methodsFor: 'tests - equality' stamp: ''!
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)! !

!SymbolTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContents
	| result |
	result:= self collectionClass streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
subCollectionNotIn
" return a collection for which at least one element is not included in 'moreThan4Elements' "
	^ collectionNotIncluded! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedElementAccessTest

	self moreThan4Elements.
	self assert: self moreThan4Elements size >= 4.
	self subCollectionNotIn.
	self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ].
	self elementNotInForElementAccessing.
	self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing).
	self elementInForElementAccessing.
	self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! !

!SymbolTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWith
	| result  indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1.
	lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection  size -1.
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: lastIndexOfOldSubcollection   with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'  "
	
	1 to: (indexOfSubcollection  - 1) do: 
		[ 
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i) = (result at: i)
		].
	
	" middle part containing replacementCollection : "
	
	(indexOfSubcollection ) to: ( lastIndexOfReplacementCollection  ) do: 
		[
		:i |
		self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1))
		].
	
	" end part :"
	1 to: (result size - lastIndexOfReplacementCollection   ) do:
		[ 
		:i |
		self assert: (result at: ( lastIndexOfReplacementCollection  + i  ) ) = (self collectionWith1TimeSubcollection  at: ( lastIndexOfOldSubcollection  + i  ) ).
		].! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOfIAbsent
	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) 
	     equals: 1.

	self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) 
		  equals: 55! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastError

	self 
		should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ]
		raise: Error! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLast

	| element result |
	element := self nonEmptyMoreThan1Element at: self nonEmptyMoreThan1Element size.
	result := self nonEmptyMoreThan1Element findLast: [:each | each =element].
	
	self assert: result equals: self nonEmptyMoreThan1Element size! !

!SymbolTest methodsFor: 'tests - streaming' stamp: ''!
testNewStreamContentsReturnsCollectionOfCorrectSize
	| result item originalSize |
	originalSize := 10.
	item := self firstCollection first.
	result := self collectionClass
		new: originalSize
		streamContents: [ :stream | 
			1 to: originalSize + 1 do: [ :each | stream nextPut: item ].
			stream position: originalSize ].
	self assert: result size equals: originalSize! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToEmpty
	| result |
	result := self empty copyUpTo: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!SymbolTest methodsFor: '*ScriptingExtensions-Tests' stamp: ''!
testAsClass
	self 
		assert: #Symbol asClass
		equals: Symbol! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButLastDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButLastDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i ))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element  size-1)! !

!SymbolTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
collectionWithEqualElements
" return a collecition including atLeast two elements equal"

^ sameAtEndAndBegining .! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
elementTwiceInForOccurrences
" return an element included exactly two time in # collectionWithEqualElements"
^ sameAtEndAndBegining first! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollectError

	self should: [ self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := firstCollection size.
	
	firstCollection  reverseWith: secondCollection do:
		[:a :b |
	
		self assert: (firstCollection at: index) equals: a. 
		self assert: (secondCollection at: index) equals: b.
			(index := index - 1)]! !

!SymbolTest methodsFor: 'tests' stamp: ''!
testNumArgsUnary
	self assert: 'name' numArgs equals: 0.

	self assert: 'name_' numArgs equals: 0.
	self assert: '_name' numArgs equals: 0.
	self assert: 'na_me' numArgs equals: 0.

	self assert: 'name ' numArgs equals: -1.
	self assert: ' name' numArgs equals: -1.
	self assert: 'na me' numArgs equals: -1.

	self assert: 'name+' numArgs equals: -1.
	self assert: '+name' numArgs equals: -1.
	self assert: 'na+me' numArgs equals: -1.

	self assert: 'name123' numArgs equals: 0.
	self assert: 'na123me' numArgs equals: 0.
	self assert: '123name' numArgs equals: -1! !

!SymbolTest methodsFor: 'tests - element accessing' stamp: ''!
testAtOutOfBounds

	self 
		should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ]
		raise: Error.
	self 
		should: [ self moreThan4Elements at: -1 ]
		raise: Error! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!SymbolTest methodsFor: 'tests - copy' stamp: ''!
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) ] ]! !

!SymbolTest methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWith1Occurrence
	| 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 ) ).
		].! !

!SymbolTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOf
	| collection |
	collection := self collectionWithoutEqualElements .
	
	collection do: [ :each | self assert: (collection occurrencesOf: each) equals: 1 ]! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfter
	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection   copyAfter: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!SymbolTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!SymbolTest methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!SymbolTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsNotThere
	
	self deny: (self nonEmpty includes: self elementNotIn).
	self assert: (self nonEmpty includes: self nonEmpty anyOne).
	self deny: (self empty includes: self elementNotIn)! !

!SymbolTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
 	 'copyUpTo:' should copy until the first occurrence"
	result := collection copyUpTo: element.

	"Verify content"
	self assertEmpty: result! !

!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirst

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element findFirst: [:each | each = element].
	
	self assert: result equals: 1! !

!SymbolTest methodsFor: 'tests - subcollections access' stamp: ''!
testAllButFirst

	| abf col |
	col := self moreThan3Elements.
	abf := col allButFirst.
	self deny: abf first = col first.
	self assert: abf size + 1 = col size! !

!SymbolTest methodsFor: 'tests - equality' stamp: ''!
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)! !

!SymbolTest methodsFor: 'tests - index access' stamp: ''!
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) equals: index! !

!SymbolTest methodsFor: 'tests - as set tests' stamp: ''!
testAsSetWithEqualsElements
	| result |
	result := self withEqualElements asSet.
	self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = Set! !

!SymbolTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements

" return a collection not including equal elements "
	^ nonEmptySymbol5ElementsNoDuplicates! !

!SymbolTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |
	delim := ', '.
	result := ''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!SymbolTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!SymbolicBytecode commentStamp: ''!
I model a single bytecode. I know my value and my offset in the compiledMethod and know the compiledMethod I come from

I am a relatively heavyweight object, I am created on demand for inspecting bytecodes.

See #symbolicBytecode.!
!SymbolicBytecode methodsFor: 'mapping' stamp: ''!
sourceInterval
	^self sourceNode sourceInterval! !

!SymbolicBytecode methodsFor: 'comparing' stamp: ''!
= anObject

	self == anObject
		ifTrue: [^ true].

	(self class == anObject class)
		ifFalse: [^ false].

	^ (self bytes = anObject bytes) and: [ 
		(self description = anObject description) and: [ 
			(self method = anObject method) and: [ 
				self offset = anObject offset ] ] ]! !

!SymbolicBytecode methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!SymbolicBytecode methodsFor: 'comparing' stamp: ''!
hash

	^ ((self bytes hash bitXor: self description hash) bitXor: 
			self method hash) bitXor: self offset hash! !

!SymbolicBytecode methodsFor: 'accessing' stamp: ''!
offset: anObject
	offset := anObject! !

!SymbolicBytecode methodsFor: 'accessing' stamp: ''!
description: anObject
	description := anObject! !

!SymbolicBytecode methodsFor: 'mapping' stamp: ''!
sourceNode
	^self method sourceNode sourceNodeForPC: self offset! !

!SymbolicBytecode methodsFor: 'accessing' stamp: ''!
description
	^ description! !

!SymbolicBytecode methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream print: offset; space.
	aStream nextPut: $<.
	bytes do: [:each | | code |
		code := each radix: 16.
			aStream nextPut: (code size < 2
				ifTrue: [$0]
				ifFalse: [code at: 1]).
			aStream nextPut: code last] separatedBy: [ aStream space].
	aStream nextPut: $>;space.
	aStream nextPutAll: description! !

!SymbolicBytecode methodsFor: 'accessing' stamp: ''!
bytes: anObject
	bytes := anObject! !

!SymbolicBytecode methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionSourceCode
	<inspectorPresentationOrder: 30 title: 'Source'>

	^ SpCodePresenter new 
		beForBehavior: self method methodClass;
		text: self method sourceCode;
		selectionInterval: self sourceInterval;
		yourself! !

!SymbolicBytecode methodsFor: 'accessing' stamp: ''!
offset
	^ offset! !

!SymbolicBytecode methodsFor: 'accessing' stamp: ''!
method: anObject
	method := anObject! !

!SymbolicBytecode methodsFor: 'accessing' stamp: ''!
bytes
	^ bytes! !

!SymbolicBytecodeBuilder commentStamp: ''!
I parse a method and create a collection of SymbolicBytecode objects for introspection.

!
!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex

	self addBytecode: 'storeIntoTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushConsArrayWithElements: numElements

	self addBytecode: 'pop ', numElements printString, ' into (Array new: ', numElements printString, ')'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex

	self addBytecode: 'popIntoTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushClosureTemps: numTemps
	"Push on stack nil numTemps times for the closure temps."
	
	self addBytecode: 'pushClosureTemps:' , numTemps printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
trap 
	"send the class trap message to the current context."
	
	self addBytecode: 'trap'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushConstant: obj
	"Print the Push Constant, obj, on Top Of Stack bytecode."

	self addBytecode: (String streamContents:
				[:s |
				s nextPutAll: 'pushConstant: '.
				obj isVariableBinding
					ifFalse: [obj printOn: s]
					ifTrue: [obj key
						ifNotNil: [s nextPutAll: '##'; nextPutAll: obj key]
						ifNil: [s nextPutAll: '###'; nextPutAll: obj value soleInstance name]]])! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
popIntoLiteralVariable: anAssociation 
	"Print the Remove Top Of Stack And Store Into Literal Variable bytecode."

	self addBytecode: 'popIntoLit: ', anAssociation key! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
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 addBytecode: (supered ifTrue: ['superSend: '] ifFalse: ['send: ']), selector! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushActiveProcess

	self addBytecode: 'pushThisProcess'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
doPop
	"Print the Remove Top Of Stack bytecode."

	self addBytecode: 'pop'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushReceiver
	"Print the Push Active Context's Receiver on Top Of Stack bytecode."

	self addBytecode: 'self'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
blockReturnConstant: cst

	self addBytecode: 'blockReturn: ' , cst printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
methodReturnConstant: value 
	"Print the Return Constant bytecode."

	self addBytecode: 'return: ', value printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushLiteralVariable: anAssociation
	"Print the Push Contents Of anAssociation On Top Of Stack bytecode."

	self addBytecode: 'pushLit: ' , (anAssociation key 
		ifNil: [ anAssociation value ] 
		ifNotNil: [ anAssociation key ]) asString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushNewArrayOfSize: numElements
 
	self addBytecode: 'push: (Array new: ', numElements printString, ')'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
doDup
	"Print the Duplicate Top Of Stack bytecode."

	self addBytecode: 'dup'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
storeIntoTemporaryVariable: offset 
	"Print the Store Top Of Stack Into Temporary Variable Of Method 
	bytecode."

	self addBytecode: 'storeIntoTemp: ', offset printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
jump: offset if: condition 
	"Print the Conditional Jump bytecode."

	self addBytecode: 
		(condition
			ifTrue: ['jumpTrue: ']
			ifFalse: ['jumpFalse: '])
			, (scanner pc + offset) printString! !

!SymbolicBytecodeBuilder methodsFor: 'accessing' stamp: ''!
method
	^method! !

!SymbolicBytecodeBuilder methodsFor: 'api' stamp: ''!
decode
	
	| end |
	symbolicBytecodes := OrderedCollection new.
	scanner := InstructionStream on: method.
	end := method endPC.
	oldPC := scanner pc.
	scanner interpretWithClient: self.
	^symbolicBytecodes! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
methodReturnReceiver
	"Print the Return Self bytecode."

	self addBytecode: 'returnSelf'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushActiveContext
	"Print the Push Active Context On Top Of Its Own Stack bytecode."

	self addBytecode: 'pushThisContext'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
directedSuperSend: selector numArgs: numberArguments
	"Print the Directed Super Send Message With Selector, selector, bytecode. 
	The current class is located in the stack, then the arguments of the message and the receiver just 
	below them."

	self addBytecode: 'directedSuperSend: ', selector printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
popIntoReceiverVariable: offset 
	"Print the Remove Top Of Stack And Store Into Instance Variable 
	bytecode."

	self addBytecode: 'popIntoRcvr: ', offset printString! !

!SymbolicBytecodeBuilder methodsFor: 'private' stamp: ''!
addBytecode: description 
	"Append to the receiver a description of the bytecode, instruction." 

	| bytes symbolic |
	
	bytes := ByteArray new: (scanner pc - oldPC).
	
	(oldPC to: scanner pc - 1) doWithIndex: [:each :index | 
		bytes at: index put: (method at: each)].
	
	 symbolic := SymbolicBytecode new 
		method: method;
		bytes: bytes;
	 	description: description;
		offset: oldPC.
	symbolicBytecodes add: symbolic.
	oldPC := scanner pc! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
methodReturnTop
	"Print the Return Top Of Stack bytecode."

	self addBytecode: 'returnTop'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
callPrimitive: primNumber
	"Print the callPrimitive bytecode."
	| isInlined |
	isInlined := primNumber >= (1 << 15) ifTrue: [ 'Inlined' ] ifFalse: [ '' ].
	self addBytecode: 'call', isInlined, 'Primitive: ', primNumber printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
storeIntoLiteralVariable: anAssociation 
	"Print the Store Top Of Stack Into Literal Variable Of Method bytecode."

	self addBytecode: 'storeIntoLit: ', anAssociation key! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushTemporaryVariable: offset
	"Print the Push Contents Of Temporary Variable Whose Index Is the 
	argument, offset, On Top Of Stack bytecode."

	self addBytecode: 'pushTemp: ', offset printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
popIntoTemporaryVariable: offset 
	"Print the Remove Top Of Stack And Store Into Temporary Variable 
	bytecode."

	self addBytecode: 'popIntoTemp: ', offset printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
blockReturnTop
	"Print the Return Top Of Stack bytecode."

	self addBytecode: 'blockReturn'! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushFullClosure: lit numCopied: numCopied receiverOnStack: rcvr ignoreOuterContext: ignore

	self addBytecode: 'fullClosure:' , lit printString , ' NumCopied: ', numCopied printString! !

!SymbolicBytecodeBuilder methodsFor: 'accessing' stamp: ''!
method: aMethod
	method :=  aMethod! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
storeIntoReceiverVariable: offset 
	"Print the Store Top Of Stack Into Instance Variable Of Method bytecode."

	self addBytecode: 'storeIntoRcvr: ', offset printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushReceiverVariable: offset
	"Print the Push Contents Of the Receiver's Instance Variable Whose Index 
	is the argument, offset, On Top Of Stack bytecode."

	self addBytecode: 'pushRcvr: ' , offset printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
jump: offset
	"Print the Unconditional Jump bytecode."

	self addBytecode: 'jumpTo: ', (scanner pc + offset) printString! !

!SymbolicBytecodeBuilder methodsFor: 'instruction decoding' stamp: ''!
pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex

	self addBytecode: 'pushTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! !

!SymbolicBytecodeBuilder class methodsFor: 'decoding' stamp: ''!
decode: aMethod

	^(self new method: aMethod) decode! !

!SyntaxErrorDebugger commentStamp: ''!
I am a special Debugger for syntax errors encountered when filing in class descriptions from a non-interactive source such as an external file. As a StringHolder, the string to be viewed is the method code or expression containing the error.

The user may fix the error and accept the method to continue the fileIn.
!
!SyntaxErrorDebugger methodsFor: 'other' stamp: ''!
contentsSelection
	"Return the interval of text in the code pane to select when I set the pane's contents"

	^ location 
		ifNil: [1 to: 0]  "null selection"
		ifNotNil: [ location to: location + self sourceErrorString size - 1 ] ! !

!SyntaxErrorDebugger methodsFor: 'text menu support' stamp: ''!
selectedMessageName
	"Answer the selector of the method being compiled."

	^ selector
! !

!SyntaxErrorDebugger methodsFor: 'text menu support' stamp: ''!
selectedClass
	"Answer the class in which the syntax error occurred."

	^ class
! !

!SyntaxErrorDebugger methodsFor: 'initialization' stamp: ''!
highlightError
	"copy in the error message"
	contents := contents
					copyReplaceFrom: location
					to: location - 1
					with: self sourceErrorString.
	"convert to Text that we can add Attributes"
	contents := contents asText.
	"use the ST80Styler"
	location ifNil: [ ^ self ].	
	contents addAttribute: TextColor red from: location to: location + self sourceErrorString size - 1.
	contents addAttribute: TextEmphasis bold from: location to: location + self sourceErrorString size - 1.! !

!SyntaxErrorDebugger methodsFor: 'initialization' stamp: ''!
syntaxError: aSyntaxError
	"extract the instance properties from a SyntaxErrorNotification"
	
	syntaxError := aSyntaxError.
	class :=  aSyntaxError errorClass.
	errorMessage := aSyntaxError errorMessage.
	location := aSyntaxError location.	
	debugSession := (Processor activeProcess newDebugSessionNamed: 'Stack of the Syntax Error' startedAt: aSyntaxError signalerContext).
	contents := self checkForUnprintableCharacters: aSyntaxError errorCode.
	selector := class compiler parseSelector: contents.	
	self highlightError! !

!SyntaxErrorDebugger methodsFor: 'accessing' stamp: ''!
codePaneMenu: aMenu shifted: shifted
	"Note that unless we override perform:orSendTo:, 
	PluggableTextController will respond to all menu items in a 
	text pane"

	| donorMenu |
	donorMenu := (PragmaMenuBuilder pragmaKeyword: RubSmalltalkCodeMode menuKeyword model: editor)
		menu.
	^ aMenu addAllFrom: donorMenu! !

!SyntaxErrorDebugger methodsFor: 'menu' stamp: ''!
browseMethodFull
	"Create and schedule a full Browser and then select the current class and message."

	| myClass |
	(myClass := self selectedClassOrMetaClass) ifNotNil:
		[Smalltalk tools browser
			openOnClass: myClass selector: self selectedMessageName]! !

!SyntaxErrorDebugger methodsFor: 'menu' stamp: ''!
listMenu: aMenu
	^aMenu addList: {
		{'Proceed' . #proceed}.
		{'Debug calling process' . #debug}.
		{'Browse full' . #browseMethodFull}}.! !

!SyntaxErrorDebugger methodsFor: 'menu' stamp: ''!
proceed
	"The user has has edited and presumably fixed the syntax error and the filein can now proceed."

	debugSession 
			resume;
			clear! !

!SyntaxErrorDebugger methodsFor: 'accessing' stamp: ''!
contents
	^contents ! !

!SyntaxErrorDebugger methodsFor: 'accessing' stamp: ''!
contents: stringOrText
	contents := stringOrText! !

!SyntaxErrorDebugger methodsFor: 'accessing' stamp: ''!
model
	^ self! !

!SyntaxErrorDebugger methodsFor: 'message list' stamp: ''!
list
	"Answer an array of one element made up of the class name, message category, and message selector in which the syntax error was found. This is the single item in the message list of a view/browser on the receiver."

	selector ifNil: [^ Array with: (class name, '  ', (self category ifNil: ['']), '  ', '<none>')].
	self category ifNil: [^ Array with: (class name, '    ', '<none>')].
	^ Array with: (class name, '  ', self category, '  ', selector)
! !

!SyntaxErrorDebugger methodsFor: 'accessing' stamp: ''!
errorMessage
	^ errorMessage! !

!SyntaxErrorDebugger methodsFor: 'accessing' stamp: ''!
announcer
	^ announcer ifNil: [ announcer := Announcer new ]! !

!SyntaxErrorDebugger methodsFor: 'other' stamp: ''!
closeWindow
	debugSession ifNotNil: [ debugSession terminate ].
	window close
! !

!SyntaxErrorDebugger methodsFor: 'accessing' stamp: ''!
editor: anEditor
	editor := anEditor! !

!SyntaxErrorDebugger methodsFor: 'other' stamp: ''!
contents: aString notifying: aController
	"Compile the code in aString and proceed. Do not notify anybody of errors, because nobody would have been notified of errors if this syntax error had not arisen"

	aController hasUnacceptedEdits: false.
	
	syntaxError doitFlag
		ifTrue: [ self class compiler evaluate: aString ]
		ifFalse: [ self resume: aString ].
	self closeWindow! !

!SyntaxErrorDebugger methodsFor: 'other' stamp: ''!
shoutAboutToStyle: aPluggableShoutMorphOrView
	^ true! !

!SyntaxErrorDebugger methodsFor: 'accessing' stamp: ''!
sourceErrorString
	^ errorMessage , ' -> '! !

!SyntaxErrorDebugger methodsFor: 'accessing' stamp: ''!
window
	^window! !

!SyntaxErrorDebugger methodsFor: 'text menu support' stamp: ''!
selectedClassOrMetaClass
	"Answer the class of the method being compiled."

	^ class
! !

!SyntaxErrorDebugger methodsFor: 'menu' stamp: ''!
resume: aValue

	debugSession 
			resume: aValue;
			clear! !

!SyntaxErrorDebugger methodsFor: 'other' stamp: ''!
category
	^(class organization categoryOfElement: selector) ifNil: [ Protocol unclassified ]! !

!SyntaxErrorDebugger methodsFor: 'message list' stamp: ''!
listDoubleClick
	self debug! !

!SyntaxErrorDebugger methodsFor: 'initialization' stamp: ''!
checkForUnprintableCharacters: aString
	| types printables |
	types := String typeTable.
	printables := '!!@#$%&*-_=+<>{}?/\,·£¢§¶ªº–—“‘”’…Úæگ׿«»`~`' asSet.
	^ aString
		detect: [ :aChar | (types at: aChar asciiValue ifAbsent: [ #xLetter ]) == #xBinary and: [ (printables includes: aChar) not ] ]
		ifFound: [ :badChar | 
			'<<<This string contains a character (ascii value ' , badChar asciiValue printString
				, ') that is not normally used in code>>> ' , aString ]
		ifNone: [ aString ]! !

!SyntaxErrorDebugger methodsFor: 'menu' stamp: ''!
debug

	"Show the stack of the process leading to this syntax editor, typically showing the stack of the compiler as called from fileIn."

	(OupsDebugRequest newForContext: debugSession interruptedContext)
		process: debugSession interruptedProcess;
		submit! !

!SyntaxErrorDebugger methodsFor: 'message list' stamp: ''!
listIndex
	"There is always exactly one element in my list and it is always selected."

	^ 1
! !

!SyntaxErrorDebugger methodsFor: 'accessing' stamp: ''!
window: aWindow
	window := aWindow! !

!SyntaxErrorDebugger class methodsFor: 'instance creation' stamp: ''!
syntaxError: aSyntaxError
	
	^ self new
		syntaxError: aSyntaxError;
		yourself
		! !

!SyntaxErrorDebugger class methodsFor: 'instance creation' stamp: ''!
buildMorphicViewOn: aSyntaxErrorDebugger
	"Answer an Morphic view on the given SyntaxError."

	| window editor |
	window := (SystemWindow labelled: 'Syntax Error: ' , aSyntaxErrorDebugger errorMessage)
		model: aSyntaxErrorDebugger.
	window
		addMorph:
			((PluggableListMorph
				on: aSyntaxErrorDebugger
				list: #list
				selected: #listIndex
				changeSelected: nil
				menu: #listMenu:) doubleClickSelector: #listDoubleClick)
		frame: (0 @ 0 corner: 1 @ 0.15).
	window
		addMorph:
			(editor := RubScrolledTextMorph new
				on: aSyntaxErrorDebugger
				text: #contents
				accept: #contents:notifying:
				readSelection: #contentsSelection
				menu: #codePaneMenu:shifted:)
		frame: (0 @ 0.15 corner: 1 @ 1).
	aSyntaxErrorDebugger window: window.
	aSyntaxErrorDebugger editor: editor.
	window extent: 380 @ 220.
	^ window openInWorld! !

!SyntaxErrorDebugger class methodsFor: 'instance creation' stamp: ''!
open: aSyntaxErrorDebugger
	"Answer a standard system view whose model is an instance of me."
	<primitive: 19>
	"Simulation guard"
	| process |
	process := Processor activeProcess.
	UIManager default spawnNewProcessIfThisIsUI: process.
	UIManager default defer: [
		self buildMorphicViewOn: aSyntaxErrorDebugger.
	].
	^ process suspend! !

!SyntaxErrorDebugger class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]" 
	registry register: self as: #syntaxErrorDebugger
! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: ''!
messageText
	^ super messageText
		ifNil: [messageText := code]! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: ''!
errorClass
	^inClass! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: ''!
setClass: aClass code: codeString doitFlag: aBoolean errorMessage: errorString location: anInteger
	inClass := aClass.
	code := codeString.
	doitFlag := aBoolean.
	messageText := errorString.
	location := anInteger! !

!SyntaxErrorNotification methodsFor: 'exceptiondescription' stamp: ''!
defaultAction

	^ UIManager default syntaxErrorNotificationDefaultAction: self! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: ''!
location
	^location! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: ''!
doitFlag
	^doitFlag! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: ''!
errorCode
	^code! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: ''!
errorMessage
	^messageText! !

!SyntaxErrorNotification class methodsFor: 'exceptionInstantiator' stamp: ''!
inClass: aClass withCode: codeString doitFlag: doitFlag errorMessage: errorString location: location
	| sourceCode |
	sourceCode := (self new
		setClass: aClass
		code: codeString
		doitFlag: doitFlag
		errorMessage: errorString
		location: location) signal.
	^sourceCode ifNil: [ self error: 'source nil, should not happen' ].! !

!SysRefactoringMethodCommand methodsFor: 'testing' stamp: ''!
isComplexRefactoring
	^true! !

!SysRefactoringMethodCommand methodsFor: 'execution' stamp: ''!
execute

	self executeRefactorings! !

!SysRefactoringMethodCommand methodsFor: 'execution' stamp: ''!
prepareFullExecutionInContext: aToolContext
	super prepareFullExecutionInContext: aToolContext.
	self setUpModelFromContext: aToolContext.! !

!SystemAnnouncement commentStamp: ''!
The root announcement for the events coming from the Pharo system.

Currently, it wraps the event that comes from the SystemChangeNotifier.!
!SystemAnnouncement methodsFor: 'accessing' stamp: ''!
timeStamp: aTimeStamp

	timeStamp := aTimeStamp! !

!SystemAnnouncement methodsFor: 'properties' stamp: ''!
propertyAt: aKey put: aValue 
	
	self properties at: aKey put: aValue! !

!SystemAnnouncement methodsFor: 'properties' stamp: ''!
properties

	^ properties ifNil: [ properties := Dictionary new ]! !

!SystemAnnouncement methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self setTimeStamp.! !

!SystemAnnouncement methodsFor: 'accessing' stamp: ''!
timeStamp

	^ timeStamp! !

!SystemAnnouncement methodsFor: 'properties' stamp: ''!
propertyAt: aString ifPresent: aBlockClosure 
	
	properties ifNil: [ ^ self ].
	^ properties at: aString ifPresent: aBlockClosure! !

!SystemAnnouncement methodsFor: 'private' stamp: ''!
setTimeStamp

	timeStamp := DateAndTime current! !

!SystemAnnouncer commentStamp: ''!
This class plays the role of the announcer for events raised by the Pharo system.

BEWARE: You should not need to subclass me. Think about just using me to send your announces (if you need system behavior) or using your own announcers as instance or class  variables.!
!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
class: aClass recategorizedFrom: oldCategory to: newCategory 
	self announce: (ClassRecategorized 
						class: aClass
						recategorizedFrom: oldCategory
						to: newCategory)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
traitDefinitionChangedFrom: oldTrait to: newTrait
	self announce: (ClassModifiedClassDefinition classDefinitionChangedFrom: oldTrait to: newTrait)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classRemoved: aClass fromCategory: aCategoryName 
	self announce: (ClassRemoved class: aClass category: aCategoryName)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
protocolRenamedFrom: oldName to: newName inClass: aClass
	self
		announce:
			(ProtocolRenamed new
				classReorganized: aClass;
				oldProtocolName: oldName;
				newProtocolName: newName;
				yourself)! !

!SystemAnnouncer methodsFor: 'announce' stamp: ''!
suspendAllWhileStoring: aBlock
	| reentring |
	" Suspend all the announcements, storing them in an OrderedCollection, then returns this collection"
	
	reentring := storedAnnouncements isNotNil.
	
	reentring ifFalse:[
		storedAnnouncements := OrderedCollection new.
	].

	[ 
		self suspendAllWhile: aBlock.
		^ storedAnnouncements.
	] ensure:[
		reentring ifFalse:[
			storedAnnouncements := nil.
		]
	]! !

!SystemAnnouncer methodsFor: 'subscription' stamp: ''!
unsubscribe: anObject
	self private unsubscribe: anObject.	
	super unsubscribe: anObject.
! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
class: aClass oldComment: oldComment newComment: newComment oldStamp: oldStamp newStamp: newStamp
	"A class was commented in the system."

	self announce: (ClassCommented class: aClass oldComment: oldComment newComment: newComment oldStamp: oldStamp newStamp: newStamp)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classModificationAppliedTo: aClassOrTrait
	self announce: (ClassModificationApplied toClass: aClassOrTrait)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
methodRepackaged: aMethod from: aPackage to: anotherPackage
	self announce: (MethodRepackaged
						methodRepackaged: aMethod
						oldPackage: aPackage 
						newPackage: anotherPackage)! !

!SystemAnnouncer methodsFor: 'announce' stamp: ''!
announce: anAnnouncement
	self isSuspended 
		ifFalse: [ 
			self private announce: anAnnouncement.
			super announce: anAnnouncement ]
		ifTrue:[
			storedAnnouncements ifNotNil:[ storedAnnouncements add: anAnnouncement ]
		].! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
methodAdded: aMethod 
	"A method with the given selector was added to aClass, but not put in a protocol."

	^ self methodAdded: aMethod configuredWith: [ :method | ]! !

!SystemAnnouncer methodsFor: 'accessing' stamp: ''!
private
	^private ifNil: [ private := Announcer new ]! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
protocolAdded: aString inClass: aClass
	self announce: (ProtocolAdded new 
		classReorganized: aClass;
		protocol: aString;
		yourself)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
evaluated: textOrStream
	^ self evaluated: textOrStream context: nil.! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classCommented: aClass
	"A class with the given name was commented in the system."

	self announce: (ClassCommented classCommented: aClass)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classDefinitionChangedFrom: oldClass to: newClass
	self announce: (ClassModifiedClassDefinition classDefinitionChangedFrom: oldClass to: newClass)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
protocolRemoved: aString inClass: aClass
	self announce: (ProtocolRemoved new 
		classReorganized: aClass;
		protocol: aString;
		yourself)! !

!SystemAnnouncer methodsFor: 'testing' stamp: ''!
isSuspended
	^suspended ifNil: [ suspended := false ]! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classRepackaged: aClass from: aPackage to: anotherPackage
	self announce: (ClassRepackaged
						classRepackaged: aClass
						oldPackage: aPackage 
						newPackage: anotherPackage)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
methodRemoved: aMethod protocol: protocol origin: aBehavior
	"A method with the given selector was removed from the class."

	self announce: (MethodRemoved methodRemoved: aMethod protocol: protocol origin: aBehavior)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
methodRecategorized: method oldProtocol: oldProtocol

	self announce: (MethodRecategorized method: method oldProtocol: oldProtocol)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classTagRemoved: tagName fromPackage: aPackage

	self announce: (ClassTagRemoved in: aPackage tag: tagName)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classCategoryRemoved: aClassCategoryName

	self announce: (CategoryRemoved categoryName: aClassCategoryName)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classTagAdded: tagName inPackage: aPackage

	self announce: (ClassTagAdded in: aPackage tag: tagName)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classCategoryRenamedFrom: anOldClassCategoryName to: aNewClassCategoryName

	self announce: (CategoryRenamed
					classCategoryRenamedFrom: anOldClassCategoryName 
					to: aNewClassCategoryName)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classTagRenamed: tagName inPackage: aPackage to: newTagName

	self announce: (ClassTagRenamed in: aPackage tag: tagName to: newTagName)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
methodChangedFrom: oldMethod to: newMethod oldProtocol: oldProtocol

	self announce: (MethodModified methodChangedFrom: oldMethod to: newMethod oldProtocol: oldProtocol)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classParentOf: aClass renamedFrom: oldName to: newName
	self announce: (ClassParentRenamed classParentOf: aClass renamedFrom: oldName to: newName)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
snapshotDone: isNewImage

	self announce: (SnapshotDone isNewImage: isNewImage)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classAdded: aClass inCategory: aCategoryName 
	self announce: (ClassAdded class: aClass category: aCategoryName)! !

!SystemAnnouncer methodsFor: 'announce' stamp: ''!
suspendAllWhile: aBlock
	| oldSuspended |
	oldSuspended := self isSuspended.
	suspended := true.
	^aBlock ensure: [ suspended := oldSuspended ]! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName 
	self announce: (ClassRenamed 
				class: aClass
				category: aCategoryName
				oldName: oldClassName
				newName: newClassName)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classReorganized: aClass
	self announce: (ClassReorganized class: aClass)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
methodAdded: aMethod configuredWith: aBlock
	"A method with the given selector was added to aClass, but not put in a protocol."

	| event |
	event := MethodAdded method: aMethod.
	aBlock value: event.
	self announce: event.! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
evaluated: expression context: aContext
	self announce: (ExpressionEvaluated 
				expression: expression
				context: aContext)! !

!SystemAnnouncer methodsFor: 'triggering' stamp: ''!
classCategoryAdded: aClassCategoryName

	self announce: (CategoryAdded categoryName: aClassCategoryName)! !

!SystemAnnouncer class methodsFor: 'initialization' stamp: ''!
unload
	self uniqueInstance unsubscribe: self! !

!SystemAnnouncer class methodsFor: 'instance creation' stamp: ''!
uniqueInstance
	"Answer a system annoncer."
	
	^ announcer ifNil: [ announcer := self new ]! !

!SystemAnnouncer class methodsFor: 'accessing' stamp: ''!
announcer: anAnnouncer
	announcer := anAnnouncer! !

!SystemAnnouncer class methodsFor: 'class initialization' stamp: ''!
reset

	"unregister all current weak subscriptions because it can cause a memory leak"
	announcer subscriptions subscriptions
 		select: [:each | each isKindOf: WeakAnnouncementSubscription] 
		thenDo: [:each | each weakRegistry remove: each subscriber ifAbsent: []]. 
	Smalltalk garbageCollect.
		
	self announcer: nil.! !

!SystemAnnouncer class methodsFor: 'initialization' stamp: ''!
restoreAllNotifications

	"self restoreAllNotifications"

	self reset.
	(Pragma allNamed: #systemEventRegistration) do: [ :pragma | 
		pragma methodClass instanceSide perform: pragma methodSelector ]! !

!SystemAnnouncerLiveTest commentStamp: ''!
Tests verifiying the behaviour of the default SystemAnnouncer instance.!
!SystemAnnouncerLiveTest methodsFor: 'tests' stamp: ''!
testSaneSubscriptionSize
	
	"self flag: 'this should be a release test, not a regular one'"
	"self assert: SystemAnnouncer uniqueInstance subscriptions numberOfSubscriptions < 75."! !

!SystemAnnouncerLiveTest methodsFor: 'tests' stamp: ''!
testNoDeadSubscriptions
	| dead |
	
	"we skip this on the ci as it impact all other ci checks, open issue https://github.com/pharo-project/pharo/issues/2471"
	
	self skipOnPharoCITestingEnvironment.

	3 timesRepeat: [ Smalltalk garbageCollect ].
	
	dead := SystemAnnouncer uniqueInstance 
		subscriptions subscriptions select: [ :sub | 
			sub subscriber isNil 
		].
	
	self assert: dead asArray equals: #()! !

!SystemAnnouncerLiveTest methodsFor: 'tests' stamp: ''!
testOnlyWeakSubscriptions

	| strong |

	"only weak subscriptions should be allowed to be added to the SystemAnnouncer..."
	
	strong := SystemAnnouncer uniqueInstance 
		subscriptions subscriptions reject: [ :each |
			each isKindOf: WeakAnnouncementSubscription
		].
	
	self assert: strong asArray equals: #()! !

!SystemAnnouncerTest methodsFor: 'running' stamp: ''!
tearDown

	SystemAnnouncer announcer: oldSystemAnnouncer.	
	factory cleanUp.
	super tearDown.! !

!SystemAnnouncerTest methodsFor: 'tests' stamp: ''!
testSuspendAllWhileStoringNested
	|  stored |
	
	stored := SystemAnnouncer uniqueInstance suspendAllWhileStoring: [ 
		SystemAnnouncer uniqueInstance suspendAllWhileStoring:[SystemAnnouncer uniqueInstance announce: ClassAdded ]
	].
		
	self assert: stored size equals: 1.
	self assert: (stored at:1) equals: ClassAdded. ! !

!SystemAnnouncerTest methodsFor: 'tests' stamp: ''!
testSuspendAllWhile
	| value |
	
	value := 42.	
	
	SystemAnnouncer uniqueInstance suspendAllWhile: [ 
		SystemAnnouncer uniqueInstance 
			when: ClassAdded do: [ value := value + 1 ];
			announce: ClassAdded ].
		
	self assert: value equals: 42. "The answer is always 42 :)"
	
	SystemAnnouncer uniqueInstance announce: ClassAdded.
	
	self assert: value equals: 43.! !

!SystemAnnouncerTest methodsFor: 'tests' stamp: ''!
testSuspendAllWhileStoring

	| stored |

	stored := SystemAnnouncer uniqueInstance suspendAllWhileStoring: [ SystemAnnouncer uniqueInstance announce: ClassAdded ].

	self assert: stored size equals: 1.
	self assert: ( stored at: 1 ) equals: ClassAdded! !

!SystemAnnouncerTest methodsFor: 'tests' stamp: ''!
testProtocolAdded
	| pass class classReorganized protocolAdded |
	
	pass := false.
	
	SystemAnnouncer uniqueInstance 
		when: ProtocolAdded do: [ :ann | 
			pass := true.
			classReorganized := ann classReorganized.
			protocolAdded := ann protocol ].
		
	class := factory newClass.
	class organization addCategory: 'shiny-new-category'.
		
	self assert: pass.
	self assert: classReorganized equals: class.
	self assert: protocolAdded equals: 'shiny-new-category'! !

!SystemAnnouncerTest methodsFor: 'tests' stamp: ''!
testProtocolRemoved
	| pass class classRemoved protocolRemoved |
	
	pass := false.
	
	SystemAnnouncer uniqueInstance 
		when: ProtocolRemoved do: [ :ann | 
			pass := true.
			classRemoved := ann classReorganized.			
			protocolRemoved := ann protocol ].
		
	class := factory newClass.
	class organization addCategory: 'shiny-new-category'.
	
	class organization removeCategory: 'shiny-new-category'.
		
	self assert: pass.
	self assert: classRemoved equals: class.
	self assert: protocolRemoved equals: 'shiny-new-category'! !

!SystemAnnouncerTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp. 
	
	oldSystemAnnouncer := SystemAnnouncer uniqueInstance.
	SystemAnnouncer announcer: nil.
	
	factory := ClassFactoryForTestCase new.! !

!SystemDependenciesTest commentStamp: ''!
This test checks dependencies in the image and proves that there are no new unknown dependencies between packages.

It is not a standard unit test because to compute dependencies takes a lot of time. It uses cached version of the dependenices report.
!
!SystemDependenciesTest methodsFor: 'accessing' stamp: ''!
dependenciesReport

	^ self class dependenciesReport
! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownMorphicDependencies
	"ideally this list should be empty"

	^ #(#'Fonts-Chooser' #'Refactoring-Critics' #'Refactoring-Environment' #Shout #'Spec-Core' "Spec-Core should be removed later." #'Spec2-Core' #'Tool-Diff' #'Tool-FileList' #'Tool-Profilers'
	#'Athens-Morphic' #'Tools-CodeNavigation' "Rubric has a dependency on It" 'Debugger-Oups')! !

!SystemDependenciesTest methodsFor: 'utilities' stamp: ''!
longTestCase

	self timeLimit: 60 seconds.
! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalFileSystemDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: (
		BaselineOfPharoBootstrap kernelPackageNames,
		BaselineOfPharoBootstrap multilingualPackageNames,
		BaselineOfPharoBootstrap kernelAdditionalPackagesNames,		
		BaselineOfPharoBootstrap compilerPackageNames,
		BaselineOfPharoBootstrap fileSystemPackageNames).
	
	self assert: dependencies isEmpty.! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownUIDependencies

	"ideally this list should be empty"	

	^ #('AST-Core-Tests'  'Athens-Cairo' 'Athens-Core' 
	#'Athens-Morphic' #'Refactoring-Critics' #'Refactoring-Environment' 'Reflectivity-Tools' #Shout #'Tool-Diff' #'Tool-FileList' #'Tool-Profilers' #'HeuristicCompletion-Model' 'NECompletion-Morphic' #VariablesLibrary #'Tools-CodeNavigation' #'Spec2-CommonWidgets') ! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownMorphicCoreDependencies

	"ideally this list should be empty"	

	^ #(#'Keymapping-KeyCombinations' #'Refactoring-Critics' #'Refactoring-Environment')! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownSUnitDependencies

	"ideally this list should be empty"	

	^ #(#'Refactoring-Critics' #'Refactoring-Environment')! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalLocalMonticelloDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: (
		BaselineOfTraits corePackages,	
		BaselineOfPharoBootstrap kernelPackageNames,
		BaselineOfPharoBootstrap compilerPackageNames,
		BaselineOfPharoBootstrap multilingualPackageNames,
		BaselineOfPharoBootstrap fileSystemPackageNames,
		BaselineOfPharoBootstrap kernelAdditionalPackagesNames,
		BaselineOfMonticello corePackageNames).
	
	self assert: dependencies isEmpty.! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownIDEDependencies

	"ideally this list should be empty"	
	
	^ #('Spec2-CommonWidgets' #'Calypso-SystemPlugins-Traits-Queries-Tests-PWithTraits')! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownSUnitKernelDependencies

	"ideally this list should be empty"	

	^ #(#'FileSystem-Core')! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownUFFIDependencies

	"ideally this list should be empty"	

	^ #(#'Refactoring-Critics' #'Refactoring-Environment')! !

!SystemDependenciesTest methodsFor: 'accessing' stamp: ''!
externalDependendiesOf: packagesCollection

	| dependencies | 
	
	dependencies := packagesCollection flatCollect: [ :aPackage | self dependenciesReport dependenciesOf: aPackage ] as: Set.
	
	dependencies := dependencies copyWithoutAll: packagesCollection.
	
	^ dependencies sorted! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalSUnitKernelDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: (
		BaselineOfPharoBootstrap compilerPackageNames,
		BaselineOfTraits corePackages,
		BaselineOfPharoBootstrap kernelPackageNames,
		BaselineOfPharoBootstrap multilingualPackageNames,
		BaselineOfPharoBootstrap kernelAdditionalPackagesNames,
		BaselineOfPharoBootstrap sUnitPackageNames).
	
	self assertCollection: dependencies hasSameElements: self knownSUnitKernelDependencies.! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalSUnitDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: (
		BaselineOfTraits corePackages,			
		self metacelloPackageNames,
		self tonelCorePackageNames,
		BaselineOfSUnit defaultPackageNames).
	
	self assertCollection: dependencies hasSameElements: self knownSUnitDependencies.! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalKernelDependencies

"
If you will break or weaken this test, a puppy will die!!!!!! 
     _ _      _
    o'')}____//
     `_/      )
     (_(_/-(_/
" 
	| dependencies |
	self longTestCase.

	dependencies := self
		externalDependendiesOf: BaselineOfPharoBootstrap kernelPackageNames , BaselineOfPharoBootstrap multilingualPackageNames, BaselineOfPharoBootstrap kernelAdditionalPackagesNames.

	self assertCollection: dependencies hasSameElements: self knownKernelDependencies! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownKernelDependencies

	"ideally this list should be empty"	

	^ #(#'FileSystem-Core')! !

!SystemDependenciesTest methodsFor: 'accessing' stamp: ''!
metacelloPackageNames

	^ BaselineOfPharoBootstrap kernelPackageNames,
	  BaselineOfPharoBootstrap compilerPackageNames,
	  BaselineOfPharoBootstrap fileSystemPackageNames,
	  BaselineOfPharoBootstrap multilingualPackageNames,
	  BaselineOfPharoBootstrap kernelAdditionalPackagesNames,
	  BaselineOfMonticello corePackageNames,
	  BaselineOfMonticello remoteRepositoriesPackageNames,
	  (BaselineOfMetacello packagesOfGroupNamed: 'Core')! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalMetacelloDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: self metacelloPackageNames, BaselineOfTraits corePackages.
	
	self assert: dependencies isEmpty! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownSpec2Dependencies
	
	^ #(
		'WebBrowser-Core' "Spec's Link adapter"
		)! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalBasicToolsDependencies

	| dependencies | 
	
	self longTestCase.

	dependencies := self externalDependendiesOf: (
		self metacelloPackageNames,
		self tonelCorePackageNames,
		BaselineOfTraits corePackages,
		{ BaselineOfSUnit name }, BaselineOfSUnit allPackageNames, "ALL"
		{ BaselineOfDisplay name }, BaselineOfDisplay allPackageNames,
		{ BaselineOfUnifiedFFI name }, BaselineOfUnifiedFFI allPackageNames,
		{ BaselineOfFreeType name }, (BaselineOfFreeType deepPackagesOfGroupNamed: #ui),
		{ BaselineOfKeymapping name }, (BaselineOfKeymapping deepPackagesOfGroupNamed: #ui),
		{ BaselineOfMorphicCore name }, BaselineOfMorphicCore allPackageNames,
		{ BaselineOfMorphic name }, BaselineOfMorphic allPackageNames,
		{ BaselineOfMenuRegistration name }, BaselineOfMenuRegistration allPackageNames,
		{ BaselineOfUI name }, BaselineOfUI allPackageNames,
		{ BaselineOfSpec name }, BaselineOfSpec allPackageNames,
		{ BaselineOfCommander2 name }, (BaselineOfCommander2 deepPackagesOfGroupNamed: #default),
		{ BaselineOfSpecCore name }, (BaselineOfSpecCore deepPackagesOfGroupNamed: #default),
		{ BaselineOfSpec2 name }, (BaselineOfSpec2 deepPackagesOfGroupNamed: #default),
		{ BaselineOfBasicTools name }, BaselineOfBasicTools allPackageNames,
		{ BaselineOfNewTools name }, (BaselineOfNewTools deepPackagesOfGroupNamed: 'Methods'),
		{ BaselineOfFuel name }, (BaselineOfFuel packagesOfGroupNamed: #Core),
		{ BaselineOfFuelPlatform name }, BaselineOfFuelPlatform allPackageNames,
		BaselineOfThreadedFFI corePackageNames ).
	
	self assertCollection: dependencies hasSameElements: self knownBasicToolsDependencies.! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalMonticelloDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: (
		BaselineOfTraits corePackages,		
		BaselineOfPharoBootstrap kernelPackageNames,
		BaselineOfPharoBootstrap multilingualPackageNames,
		BaselineOfPharoBootstrap compilerPackageNames,
		BaselineOfPharoBootstrap fileSystemPackageNames,
		BaselineOfPharoBootstrap kernelAdditionalPackagesNames,
		BaselineOfMonticello corePackageNames,
		BaselineOfMonticello remoteRepositoriesPackageNames).
	
	self assert: dependencies isEmpty.! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalMorphicDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: (
		self metacelloPackageNames,
		self tonelCorePackageNames,
		BaselineOfTraits corePackages,
		BaselineOfSUnit defaultPackageNames,
		BaselineOfDisplay allPackageNames,
		BaselineOfUnifiedFFI allPackageNames,
		(BaselineOfKeymapping deepPackagesOfGroupNamed: #morphic),
		(BaselineOfFreeType deepPackagesOfGroupNamed: #ui),
		BaselineOfMorphicCore allPackageNames,
		BaselineOfMorphic allPackageNames,
		BaselineOfMenuRegistration allPackageNames,
		(BaselineOfFuel packagesOfGroupNamed: #Core),
		BaselineOfFuelPlatform allPackageNames,
		BaselineOfThreadedFFI corePackageNames ).
	
	self assertCollection: dependencies hasSameElements: self knownMorphicDependencies.! !

!SystemDependenciesTest methodsFor: 'accessing' stamp: ''!
tonelCorePackageNames

	^ { BaselineOfTonel name }, (BaselineOfTonel packagesOfGroupNamed: #core)! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownBasicToolsDependencies
 
	"ideally this list should be empty"	
	^ #('AST-Core-Tests' 'Athens-Cairo' 'Athens-Core' 
	#'Athens-Morphic' #'Refactoring-Critics' #'Reflectivity' #'Reflectivity-Tools' #Shout 'ParametrizedTests' 'HeuristicCompletion-Model' #VariablesLibrary #'Spec2-CommonWidgets')! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalSpec2Dependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := (self externalDependendiesOf: (
		"Language"
		self metacelloPackageNames,
		self tonelCorePackageNames,
		BaselineOfTraits corePackages,
		BaselineOfUnifiedFFI allPackageNames,

		"Morphic - for Morphic backend"
		BaselineOfDisplay allPackageNames,
		(BaselineOfKeymapping deepPackagesOfGroupNamed: #ui),
		(BaselineOfFreeType deepPackagesOfGroupNamed: #ui),
		BaselineOfMorphicCore allPackageNames,
		BaselineOfMorphic allPackageNames,
		BaselineOfMenuRegistration allPackageNames,
		(BaselineOfFuel packagesOfGroupNamed: #Core),
		BaselineOfFuelPlatform allPackageNames,

		(BaselineOfCommander2 deepPackagesOfGroupNamed: #default),
		
		(BaselineOfSpecCore deepPackagesOfGroupNamed: #default),
		(BaselineOfSpec2 deepPackagesOfGroupNamed: #default),
		BaselineOfThreadedFFI corePackageNames,
	
		"Tests"
		BaselineOfSUnit defaultPackageNames,
		BaselineOfParametrizedTests allPackageNames))
			copyWithoutAll: self knownMorphicDependencies, self knownBasicToolsDependencies, self knownUIDependencies.

	self assertCollection: dependencies hasSameElements: self knownSpec2Dependencies! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalIDEDependencies
	| dependencies packages |
	self longTestCase.
	packages := self metacelloPackageNames , self tonelCorePackageNames , { BaselineOfPharoBootstrap name. BaselineOfMonticello name. BaselineOfMetacello name}.

	{BaselineOfAthens.
	BaselineOfBasicTools.
	BaselineOfDisplay.
	BaselineOfFlashback.
	BaselineOfIDE.
	BaselineOfMenuRegistration.
	BaselineOfMorphic.
	BaselineOfMorphicCore.
	BaselineOfSlot.
	BaselineOfSpec.
	BaselineOfParametrizedTests.
	BaselineOfSUnit.
	BaselineOfTraits.
	BaselineOfUI.
	BaselineOfUnifiedFFI.
	BaselineOfClassAnnotation.
	BaselineOfSystemCommands.
	BaselineOfClassParser.
	BaselineOfRefactoring2.
	BaselineOfReferenceFinder.
	BaselineOfSortFunctions.
	BaselineOfGeneralTests.
	BaselineOfMisc.
	BaselineOfEpicea.
	BaselineOfRefactoring.
	BaselineOfOSWindow.
	BaselineOfQA.
	BaselineOfManifest.
	BaselineOfDependencyAnalyzer.
	BaselineOfQualityAssistant.
	BaselineOfReflectivity.
	BaselineOfFuzzyMatcher.
	BaselineOfZodiac.
	BaselineOfReflectionMirrors.
	BaselineOfGeneralHelp.
	BaselineOfShout.
	BaselineOfKernelTests.
	BaselineOfHeuristicCompletion.
	 } do: [ :baseline | packages := packages , {baseline name} , baseline allPackageNames ].

	packages := packages ,  { BaselineOfFreeType name }, (self packagesOfGroupNamed: 'ui' on: BaselineOfFreeType ).
	packages := packages ,  { BaselineOfKeymapping name }, (self packagesOfGroupNamed: 'ui' on: BaselineOfKeymapping ).
	packages := packages ,  { BaselineOfSpecCore name }, (self packagesOfGroupNamed: 'default' on: BaselineOfSpecCore ).
	packages := packages ,  { BaselineOfSpec2 name }, (self packagesOfGroupNamed: 'default' on: BaselineOfSpec2 ).
	packages := packages ,  { BaselineOfNewTools name }, (self packagesOfGroupNamed: 'Methods' on: BaselineOfNewTools ).
	packages := packages ,  { BaselineOfCommander name} , (self packagesOfGroupNamed: 'default' on: BaselineOfCommander).
	packages := packages ,  { BaselineOfCommander2 name} , (self packagesOfGroupNamed: 'default' on: BaselineOfCommander2).
	packages := packages ,  { BaselineOfIceberg name. BaselineOfLibGit name. BaselineOfCalypso name}.

	packages := packages ,  (self packagesOfGroupNamed: 'FullEnvironment' on: BaselineOfCalypso ).
	packages := packages ,  (self packagesOfGroupNamed: 'SystemBrowser' on: BaselineOfCalypso ).
	packages := packages ,  (self packagesOfGroupNamed: 'CoreBrowser' on: BaselineOfCalypso ).
	packages := packages ,  (self packagesOfGroupNamed: 'CoreEnvironment' on: BaselineOfCalypso ).
	packages := packages ,  #('Calypso-SystemTools-Core').
	packages := packages ,  (BaselineOfMetacello packagesOfGroupNamed: 'Tests').

	packages := packages ,  (self packagesOfGroupNamed: 'default' on: BaselineOfIceberg ).
	packages := packages ,  (self packagesOfGroupNamed: 'default' on: BaselineOfLibGit ).
	packages := packages , {BaselineOfThreadedFFI name} ,  
		(self packagesOfGroupNamed: 'default' on: BaselineOfThreadedFFI ).
	packages := packages ,  #('TaskIt').
	packages := packages , { BaselineOfFuel name } , (BaselineOfFuel packagesOfGroupNamed: #Core).
	packages := packages , {BaselineOfFuelPlatform name } , BaselineOfFuelPlatform allPackageNames.

	dependencies := self externalDependendiesOf: packages.
	self assertCollection: dependencies hasSameElements: self knownIDEDependencies! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownDisplayDependencies

	"ideally this list should be empty"	

	^ #(#'Graphics-Canvas' #'Graphics-Files' #'Polymorph-Widgets')! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalCompilerDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: (
		BaselineOfPharoBootstrap kernelPackageNames,
		BaselineOfPharoBootstrap multilingualPackageNames,
		BaselineOfPharoBootstrap kernelAdditionalPackagesNames,				
		BaselineOfPharoBootstrap compilerPackageNames).
	
	self assertCollection: dependencies hasSameElements: self knownCompilerDependencies.! !

!SystemDependenciesTest methodsFor: 'known dependencies' stamp: ''!
knownCompilerDependencies

	"ideally this list should be empty"	

	^ #(#'FileSystem-Core')! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalUFFIDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: (
		self metacelloPackageNames,
		self tonelCorePackageNames,
		BaselineOfTraits corePackages,				
		BaselineOfSUnit defaultPackageNames,
		BaselineOfUnifiedFFI allPackageNames,
		BaselineOfThreadedFFI corePackageNames).
	
	self assertCollection: dependencies hasSameElements: self knownUFFIDependencies.! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalUIDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := (self externalDependendiesOf: (
		self metacelloPackageNames,
		self tonelCorePackageNames,
		BaselineOfTraits corePackages,
		BaselineOfParametrizedTests allPackageNames,
		BaselineOfSUnit defaultPackageNames,
		BaselineOfDisplay allPackageNames,
		BaselineOfUnifiedFFI allPackageNames,
		(BaselineOfKeymapping deepPackagesOfGroupNamed: #ui),
		(BaselineOfFreeType deepPackagesOfGroupNamed: #ui),
		BaselineOfMorphicCore allPackageNames,
		BaselineOfMorphic allPackageNames,
		BaselineOfSpec allPackageNames,
		(BaselineOfCommander2 deepPackagesOfGroupNamed: #default),
		(BaselineOfSpecCore deepPackagesOfGroupNamed: #default),
		(BaselineOfSpec2 deepPackagesOfGroupNamed: #default),
		(BaselineOfNewTools deepPackagesOfGroupNamed: 'Methods'),
		BaselineOfUI allPackageNames,
		BaselineOfMenuRegistration allPackageNames,
		(BaselineOfFuel packagesOfGroupNamed: #Core),
		BaselineOfFuelPlatform allPackageNames,
		BaselineOfThreadedFFI corePackageNames )).
	
	self assertCollection: dependencies hasSameElements: self knownUIDependencies.! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalDisplayDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: (
		self metacelloPackageNames,
		self tonelCorePackageNames,
		BaselineOfTraits corePackages,		
		BaselineOfDisplay allPackageNames).
	
	self assert: dependencies isEmpty.! !

!SystemDependenciesTest methodsFor: 'tests' stamp: ''!
testExternalMorphicCoreDependencies

	| dependencies | 
	
	self longTestCase.
	
	dependencies := self externalDependendiesOf: (
		self metacelloPackageNames,
		self tonelCorePackageNames,
		BaselineOfTraits corePackages,			
		BaselineOfSUnit defaultPackageNames,
		BaselineOfDisplay allPackageNames,
		BaselineOfUnifiedFFI allPackageNames,
		BaselineOfMorphicCore allPackageNames,
		BaselineOfThreadedFFI corePackageNames ).
	
	self assertCollection: dependencies hasSameElements: self knownMorphicCoreDependencies.! !

!SystemDependenciesTest methodsFor: 'accessing' stamp: ''!
packagesOfGroupNamed: aGroupName on: aBaseline 
	| allMembers allPackagesInBaseline packages groups |
	
	allMembers := aBaseline version groups 
		detect: [ :g | g name = aGroupName ]
		ifNone: [ ^#() ].
	allPackagesInBaseline := aBaseline version packages collect: [:each | each name].
	packages := allMembers includes select: [ :aName | allPackagesInBaseline includes: aName ].
	groups := allMembers includes reject: [ :aName | allPackagesInBaseline includes: aName ].
	^ packages , (groups flatCollect: [:aInnerGroupName | self packagesOfGroupNamed: aInnerGroupName on: aBaseline ]).
! !

!SystemDependenciesTest class methodsFor: 'accessing' stamp: ''!
dependenciesReport

	^ dependenciesReport ifNil: [ self rebuildDependenciesReport ]
! !

!SystemDependenciesTest class methodsFor: 'accessing' stamp: ''!
rebuildDependenciesReport

	dependenciesReport := DADependencyChecker new computeImageDependencies.
	^ dependenciesReport! !

!SystemDependenciesTest class methodsFor: 'accessing' stamp: ''!
resetDependenciesReport
	<script>
	"self resetDependenciesReport"

	dependenciesReport := nil! !

!SystemDictionary commentStamp: ''!
I represent a special dictionary used as global namespace for class names :

	Smalltalk globals classNames.

and for traits too:

	Smalltalk globals traitNames.
	
and a few other globals:

	(Smalltalk globals keys
		reject: [ :k | 
			| g |
			g := Smalltalk globals at: k.
			g isBehavior or: [ g isTrait ] ]) collect: [ :k | k -> (Smalltalk globals at: k) class ].

As the above example let you guess, the global namespace of Smalltalk system is accessed through:

	Smalltalk globals.!
!SystemDictionary methodsFor: 'removing' stamp: ''!
removeFromCaches: aKey
	"In case we remove a key from the system dictionary, we do not need to flush all the caches. We can just remove it from the class name and non class name caches."

	cachedClassNames ifNotNil: [ :cache | cache remove: aKey ifAbsent: [  ] ].
	cachedNonClassNames ifNotNil: [ :cache | cache remove: aKey ifAbsent: [  ] ].
	cachedBehaviors := nil! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
allBehaviorsDo: aBlock
	"Execute a block on each class, metaclass, trait and trait class"

	self allBehaviors do: aBlock! !

!SystemDictionary methodsFor: 'accessing - system attributes' stamp: ''!
maxIdentityHash
	"Answer the maximum identityHash value supported by the VM."
	<primitive: 176>
	
	^self primitiveFailed! !

!SystemDictionary methodsFor: 'renaming' stamp: ''!
renameClass: aClass as: newName
	"Rename the class, aClass, to have the title newName."

	^ self renameClass: aClass from: aClass name to: newName! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
allClasses  
	"Return all the class defines in the Smalltalk SystemDictionary"

	^ self classNames collect: [:name | self at: name ]! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
allBehaviors
	"Return all the classes and traits defined in the Smalltalk SystemDictionary"

	^ cachedBehaviors ifNil: [ 
		  cachedBehaviors := self allClassesAndTraits flatCollect: [ :each | { each. each classSide } ] ]! !

!SystemDictionary methodsFor: 'accessing - variable lookup' stamp: ''!
bindingOf: varName
	"SystemDictionaries includes symbols only"
	
	^ super bindingOf: varName asSymbol! !

!SystemDictionary methodsFor: 'accessing' stamp: ''!
environment
	"For conversion from SmalltalkImage to SystemDictionary"
	
	^ self! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
classNamed: className

	^ self classOrTraitNamed: className! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
classOrTraitNamed: aString
	"aString is either a class or trait name or a class or trait name followed by ' class' or 'classTrait' 
	respectively. Answer the class or metaclass it names."

	| meta baseName |
	(aString endsWith: ' class')
		ifTrue: [ 
			meta := true.
			baseName := aString copyFrom: 1 to: aString size - 6 ]
		ifFalse: [ 
			(aString endsWith: ' classTrait')
				ifTrue: [ 
					meta := true.
					baseName := aString copyFrom: 1 to: aString size - 11 ]
				ifFalse: [ 
					meta := false.
					baseName := aString ] ].
	^ self at: baseName asSymbol ifPresent: [ :global | 
		  (global isBehavior or: [ global isTrait ]) ifTrue: [ 
			  meta
				  ifFalse: [ global ]
				  ifTrue: [ global classSide ] ] ]! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
allClassesAndTraits
	"Return all the classes and traits defined in the Smalltalk SystemDictionary"

	^ self classAndTraitNames collect: [:each | self at: each ]! !

!SystemDictionary methodsFor: '*Slot-Core' stamp: ''!
declare: key from: aDictionary 
	"Add key to the receiver. If key already exists, do nothing. If aDictionary 
	includes key, then remove it from aDictionary and use its association as 
	the element of the receiver."
	"overridden here to add a Global, not just an association"

	(self includesKey: key) ifTrue: [^ self].
	(aDictionary includesKey: key)
		ifTrue: 
			[self add: ((aDictionary associationAt: key) primitiveChangeClassTo: GlobalVariable new).
			aDictionary removeKey: key]
		ifFalse: 
			[self add: (GlobalVariable key: key)]! !

!SystemDictionary methodsFor: 'testing' stamp: ''!
hasBindingThatBeginsWith: aString
	"Use the cached class and non-class names for better performance."

	| name searchBlock |
	(self reservedVariables hasBindingThatBeginsWith: aString) ifTrue: [ 
		^ true ].
	searchBlock := [ :element | 
	               (element beginsWith: aString)
		               ifTrue: [ 0 ]
		               ifFalse: [ 
			               aString < element
				               ifTrue: [ -1 ]
				               ifFalse: [ 1 ] ] ].
	name := self classNames findBinary: searchBlock ifNone: [ nil ].
	name ifNotNil: [ ^ true ].
	name := self nonClassNames findBinary: searchBlock ifNone: [ nil ].
	^ name notNil! !

!SystemDictionary methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper
	"serialize all instances except for <Smalltalk globals>"
	^ self == Smalltalk globals 
		ifFalse: [ super fuelAccept: aGeneralMapper ]
		ifTrue: [ aGeneralMapper visitHookPrimitive: self ]! !

!SystemDictionary methodsFor: 'accessing - class and trait names' stamp: ''!
classAndTraitNames
	"Answer a sorted collection of all class and trait (not including class-traits) names. 
	Now traits are normal classes. So they are in same class list.
	Do not bother to sort"
	
	^self classNames
	! !

!SystemDictionary methodsFor: 'accessing' stamp: ''!
organization: anOrganization
	"Return the organizer for the receiver"

	anOrganization environment: self.
	^ self at: #SystemOrganization put: anOrganization! !

!SystemDictionary methodsFor: 'renaming' stamp: ''!
renameClass: aClass from: oldName to: newName
	"Rename the class, aClass, to have the title newName."

	| oldref category |
	category := self organization categoryOfElement: oldName.
	self organization classify: newName under: category.
	self organization removeElement: oldName.
	oldref := self associationAt: oldName.
	self removeKey: oldName.
	oldref key: newName.
	self add: oldref. "Old association preserves old refs"
	SessionManager default renamedClass: aClass from: oldName to: newName.
	self flushClassNameCache.
	SystemAnnouncer uniqueInstance
		classRenamed: aClass
		from: oldName
		to: newName
		inCategory: category.
	aClass subclassesDo: [ :subclass | 
		SystemAnnouncer uniqueInstance
			classParentOf: subclass
			renamedFrom: oldName
			to: newName ]! !

!SystemDictionary methodsFor: 'renaming' stamp: ''!
renameClassNamed: oldName as: newName
	"Invoked from fileouts: if there is currently a class in the system named oldName, then rename it to newName. If anything untoward happens, report it in the Transcript."

	| oldClass |
	(oldClass := self at: oldName asSymbol ifAbsent: [ nil ]) ifNil: [ 
		SystemNotification signal:
			'Class-rename for ' , oldName , ' ignored because ' , oldName
			, ' does not exist.'.
		^ self ].
	oldClass rename: newName! !

!SystemDictionary methodsFor: 'accessing - dictionary access' stamp: ''!
removeKey: key ifAbsent: aBlock

	self removeFromCaches: key.
	^ super removeKey: key ifAbsent: aBlock! !

!SystemDictionary methodsFor: 'renaming' stamp: ''!
renameClass: aClass from: oldName
	"Rename the class, aClass, to have the title newName."

	^ self renameClass: aClass from: oldName to: aClass name! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
allTraits
	"Return all traits defined in the Smalltalk SystemDictionary"

	^ self traitNames collect: [:each | self at: each ]! !

!SystemDictionary methodsFor: '*Fuel-Core' stamp: ''!
serializeOn: anEncoder
	"Do nothing"! !

!SystemDictionary methodsFor: 'removing' stamp: ''!
defineClass: aDefinition withController: aController

	^ self class compiler
		source: aDefinition;
		requestor: aController;
		logged: true;
		evaluate! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
allClassesDo: aBlock
	"Evaluate the argument, aBlock, for each class in the system."

	^self classNames do: [:name | aBlock value: (self at: name) ]! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
allMethods

	^ self allBehaviors flatCollect: [ :behavior | behavior methods ]! !

!SystemDictionary methodsFor: 'printing' stamp: ''!
printElementsOn: aStream

	aStream nextPutAll: '(lots of globals)'! !

!SystemDictionary methodsFor: 'accessing - variable lookup' stamp: ''!
reservedVariables
	"We cache the variables for speed"

	^ reservedVariables ifNil: [ 
		  reservedVariables := ReservedVariable lookupDictionary ]! !

!SystemDictionary methodsFor: 'accessing - dictionary access' stamp: ''!
at: aKey put: anObject
	"Override from Dictionary to check Undeclared and fix up
	references to undeclared variables."

	(self includesKey: aKey) ifFalse: [ 
		self declare: aKey from: Undeclared.
		self flushClassNameCache ].
	super at: aKey put: anObject.
	^ anObject! !

!SystemDictionary methodsFor: 'accessing' stamp: ''!
organization
	"Return the organizer for the receiver"
	
	^ self at: #SystemOrganization ifAbsent: nil! !

!SystemDictionary methodsFor: 'accessing - class and trait names' stamp: ''!
classNames
	"Answer a sorted collection of all class names. Use the return value of #fillCaches to avoid concurrency issues."
	
	^cachedClassNames ifNil: [ self fillCaches at: 1 ]! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
allClassesAndTraitsDo: aBlock
	"Evaluate the argument, aBlock, for each class and trait in the system."
	
	^self classAndTraitNames do: [:each | aBlock value: (self at: each) ]
	
	
! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
hasClassOrTraitNamed: aString
	"Answer whether there is a class of the given name, but don't intern aString if it's not already interned."

	Symbol
		hasInterned: aString
		ifTrue: [ :aSymbol | 
		^ (self at: aSymbol ifAbsent: [ nil ]) isClassOrTrait ].
	^ false! !

!SystemDictionary methodsFor: 'accessing - class and trait names' stamp: ''!
nonClassNames
	"Answer a sorted collection of all non-class names. Use the return value of #fillCaches to avoid concurrency issues."
	
	^ cachedNonClassNames ifNil: [ self fillCaches at: 2 ]! !

!SystemDictionary methodsFor: 'accessing' stamp: ''!
poolUsers
	"Answer a dictionary of pool name -> classes that refer to it.
	Also includes any globally know dictionaries (such as
	Smalltalk, Undeclared etc) which although not strictly
	accurate is potentially useful information"
	
	<script: 'Smalltalk globals poolUsers inspect'>

	| poolUsers |
	poolUsers := Dictionary new.
	self
		keysDo: [ :k | 
			| pool refs |
			(((pool := self at: k) isKindOf: Dictionary) or: [ pool isKindOf: SharedPool class ])
				ifTrue: [ 
					refs := self systemNavigation allClasses
						select: [ :c | c sharedPools identityIncludes: pool ]
						thenCollect: [ :c | c name ].
					refs add: (self systemNavigation allReferencesTo: (self associationAt: k)).
					poolUsers at: k put: refs ] ].
	^ poolUsers! !

!SystemDictionary methodsFor: 'accessing - variable lookup' stamp: ''!
resetReservedVariables
	"Lazy init in the accessor, resetting it will take new subclasses on ReservedVariable into account"

	^ reservedVariables := nil! !

!SystemDictionary methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self. I can't be copied. Do not record me."! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
hasClassNamed: aString
	"Answer whether there is a class of the given name, but don't intern aString if it's not already interned."

	Symbol
		hasInterned: aString
		ifTrue: [ :aSymbol | ^ (self at: aSymbol ifAbsent: [ nil ]) isClass ].
	^ false! !

!SystemDictionary methodsFor: 'accessing - variable lookup' stamp: ''!
outerScope

	^ nil! !

!SystemDictionary methodsFor: 'accessing - class and trait names' stamp: ''!
flushClassNameCache
	"Force recomputation of the cached list of class names and non-class names."

	<script: 'Smalltalk flushClassNameCache'>
	cachedClassNames := cachedNonClassNames := cachedBehaviors := nil! !

!SystemDictionary methodsFor: 'accessing - class and trait names' stamp: ''!
traitNames
	"Answer a SortedCollection of all traits (not including class-traits) names."

	^ self classNames select: [ :name | 
		  self
			  at: name
			  ifPresent: [ :global | 
			  global isTrait and: [ global isObsolete not ] ]
			  ifAbsent: [ false ] ]! !

!SystemDictionary methodsFor: 'accessing - class and trait names' stamp: ''!
fillCaches
	"Fill cachedClassNames and cachedNonClassNames. Return an array with the calculated values."

	| classNames nonClassNames |
	classNames := OrderedCollection new: self size.
	nonClassNames := OrderedCollection new.
	self keysAndValuesDo: [ :key :value |
		"The key == value name test below addresses two separate issues:
			1) Obsolete classes, where key = #Foo and value name = 'AnObsoleteFoo'
			2) Aliases, i.e., Smalltalk at: #OtherName put: aClass"
		((value isKindOf: (self class environment at: #Class)) and: [ key == value name ])
			ifTrue: [ classNames add: key ]
			ifFalse: [ nonClassNames add: key ] ].
		"The expression (self class environment at: #Class) deserves some explanation.
		For bootstrapping we need to have a different Class when executing value isKindOf: Class :
		In such expression Class represents a kind of fixed point: the class of the class of the system. 
		When bootstrapping we want the class Class of the current kernel defined in the current namespace.
		Since the current namespace should contains the class that describes itself as well as a new Class class.
		we are done :)."
	
	
	"The cached names are sorted to allow for a very efficient hasBindingThatBeginsWith: check"	
	cachedClassNames := classNames sort.
	cachedNonClassNames := nonClassNames sort.
	^{ classNames. nonClassNames }! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
forgetClass: aClass logged: aBool
	"Delete the class, aClass, from the system.
	Note that this doesn't do everything required to dispose of a class - to do that use Class>>removeFromSystem."

	self organization removeElement: aClass name.
	SessionManager default unregisterClassNamed: aClass name.
	self removeKey: aClass name ifAbsent: [  ]! !

!SystemDictionary methodsFor: 'accessing - variable lookup' stamp: ''!
lookupVar: name
	"Return a var with this name.  Return nil if none found"
	^self reservedVariables at: name ifAbsent: [self bindingOf: name]! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
removeClassNamed: aName
	"Invoked from fileouts: if there is currently a class in the system named aName, then remove it"

	self
		at: aName asSymbol
		ifPresent: [ :oldClass | oldClass removeFromSystem ]! !

!SystemDictionary methodsFor: 'accessing - variable lookup' stamp: ''!
lookupVar: name declare: aBoolean
	^ self lookupVar: name! !

!SystemDictionary methodsFor: 'accessing - classes and traits' stamp: ''!
allTraitsDo: aBlock
	"Evaluate the argument, aBlock, for each trait in the system."

	^ self traitNames do: [ :name | aBlock value: (self at: name) ]! !

!SystemDictionary class methodsFor: '*Fuel-Core' stamp: ''!
materializeFrom: aDecoder
	"Answer my well-known instance"

	^ Smalltalk globals! !

!SystemDictionary class methodsFor: 'instance creation' stamp: ''!
withOrganizer: anOrganizer

	| dictionary |
	dictionary := self new.
	dictionary organization: anOrganizer. "update too the back pointer"
	^ dictionary! !

!SystemDictionaryTest commentStamp: ''!
SUnit tests for SystemDictionary!
!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testClassOrTraitNamedReturnsNilForGlobals

	self assert: nil equals: (testingEnvironment classOrTraitNamed: 'Undeclared').
	self assert: nil equals: (testingEnvironment classOrTraitNamed: #Undeclared)! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testSmalltalkAsString

	self assert: Smalltalk asString equals: 'Smalltalk'! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testOtherInstancesOfSystemDictionarySelfEvaluating

	self deny: SystemDictionary new isSelfEvaluating! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testSmalltalkSelfEvaluating

	self assert: Smalltalk isSelfEvaluating! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testOtherInstancesOfSystemDictionaryPrintString

	self deny: SystemDictionary new printString equals: 'Smalltalk'! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testUnCategorizedMethods

	| categories slips |
	categories := self categoriesForClass: self targetClass.
	slips := categories select: [ :each | each = #'as yet unclassified' ].
	self assertEmpty: slips! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testSetOrganizationSetBackPointer

	| sd so |
	sd := SystemDictionary new.
	so := SystemOrganizer new.
	sd organization: so.
	self assert: so environment identicalTo: sd.
	self assert: sd organization identicalTo: so! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testSmalltalkPrintString

	self assert: Smalltalk printString equals: 'Smalltalk'! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testOtherInstancesOfSystemDictionaryAsString

	self deny: SystemDictionary new asString equals: 'Smalltalk'! !

!SystemDictionaryTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ SystemDictionary! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testEnvironmentOfOrganization
	
	| aDictionary |	
	aDictionary := SystemDictionary withOrganizer: SystemOrganizer new.
	self assert: aDictionary organization environment equals: aDictionary
	! !

!SystemDictionaryTest methodsFor: 'requirements' stamp: ''!
canBeUnhealthy
	"uses GlobalVariables instead of associations"
	
	^ false! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testHasBindingThatBeginsWith

	super testHasBindingThatBeginsWith.
	self assert: (Smalltalk globals hasBindingThatBeginsWith: 'Obje').
	self deny: (Smalltalk globals hasBindingThatBeginsWith: 'NOTHEREIope')! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testOrganizationPerInstance

	| aDictionary otherDictionary |
	aDictionary := SystemDictionary withOrganizer: SystemOrganizer new.
	otherDictionary := SystemDictionary withOrganizer: SystemOrganizer new.
	self deny: aDictionary organization equals: otherDictionary organization! !

!SystemDictionaryTest methodsFor: 'tests' stamp: ''!
testClassOrTraitNamedReturnsClassForClasses

	self assert: Object identicalTo: (testingEnvironment classOrTraitNamed: 'Object').
	self assert: Object identicalTo: (testingEnvironment classOrTraitNamed: #Object)! !

!SystemDictionaryTest class methodsFor: 'building suites' stamp: ''!
shouldInheritSelectors

^true! !

!SystemHelp commentStamp: ''!
This class defines Help for the system in front of you. It defines the default contents when you open a help browser.
So `HelpBrowser open` is the same as `HelpBrowser openOn: SystemHelp`.

It identifies the help to be included in the system based on the fact that the class method should be named `asHelpTopic` and that it is tagged with the pragma `<systemHelp>` 

```
asHelpTopic 
	<systemHelp>

```!
!SystemHelp class methodsFor: 'private - accessing' stamp: ''!
allSystemHelpPragmas
	^ Pragma allNamed: self pragmaKeyword! !

!SystemHelp class methodsFor: 'instance creation' stamp: ''!
asHelpTopic 

	|topic helpOnHelp sortedTopics |
	
	topic := HelpTopic named: 'Help'.
	self allSystemHelpPragmas do: [:each | 
		topic subtopics addAll: each method methodClass instanceSide asHelpTopic subtopics
	].
	topic sortSubtopicsByTitle.
	helpOnHelp := topic subtopics detect: [:t | t key = 'HelpOnHelp'] ifNone: [self error: 'Help for the help system is removed'].
	sortedTopics := topic subtopics.
	sortedTopics remove: helpOnHelp.
	sortedTopics addLast: helpOnHelp.
	topic subtopics: sortedTopics.
	^topic! !

!SystemHelp class methodsFor: 'private - accessing' stamp: ''!
pragmaKeyword

	^#systemHelp! !

!SystemHelp2 commentStamp: ''!
This class defines Help for the system in front of you. It defines the default contents when you open a help browser.
So `SpHelpBrowserPresenter open` is the same as `SpHelpBrowserPresenter openOn: SystemHelp2`.

It identifies the help to be included in the system based on the fact that the class method should be named `asHelpTopic` and that it is tagged with the pragma `<newSystemHelp>` 

```
asHelpTopic 
	<newSystemHelp>

```!
!SystemHelp2 class methodsFor: 'private - accessing' stamp: ''!
allSystemHelpPragmas
	^ Pragma allNamed: self pragmaKeyword! !

!SystemHelp2 class methodsFor: 'instance creation' stamp: ''!
asHelpTopic 

	|topic helpOnHelp sortedTopics |
	
	topic := HelpTopic named: 'Help'.
	self allSystemHelpPragmas do: [:each | 
		topic subtopics addAll: each method methodClass instanceSide asHelpTopic subtopics
	].
	topic sortSubtopicsByTitle.
	helpOnHelp := topic subtopics detect: [:t | t key = 'HelpOnHelp'] ifNone: [nil].
	helpOnHelp ifNotNil: [  
		sortedTopics := topic subtopics.
		sortedTopics remove: helpOnHelp.
		sortedTopics addLast: helpOnHelp.
		topic subtopics: sortedTopics].
	^topic! !

!SystemHelp2 class methodsFor: 'private - accessing' stamp: ''!
pragmaKeyword

	^#newSystemHelp! !

!SystemNavigation commentStamp: ''!
I support the navigation of the system. 
I act as a facade but as I could require some state or different way of navigating the system all my behavior are on the instance side.
I should (it is not complety done yet) be parametrized by an environment (aSystemDictionary) that scopes my queries.!
!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseClassVarRefs: aClass
	"Put up a menu offering all class variable names; if the user chooses one, open up a message-list browser on all methods 
	that refer to the selected class variable"
	| lines labelStream allVars index owningClasses |
	
	"This method should be split into two -- one part that can be tested, and a wrapper that does the UI stuff."
	lines := OrderedCollection new.
	allVars := OrderedCollection new.
	owningClasses := OrderedCollection new.
	labelStream := (String new: 200) writeStream. "Why the heck is a writeStream needed?"
	aClass withAllSuperclasses reverseDo:
		[:class | | vars |
		vars := class classVarNames.
		vars do:
			[:var |
			labelStream nextPutAll: var; cr.
			allVars add: var.
			owningClasses add: class].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream contents isEmpty ifTrue: [^self inform: 'No class variables found']. "handle nil superclass better"
	labelStream skip: -1 "cut last CR".
	index := (UIManager default chooseFrom: (labelStream contents substrings) lines: lines).
	index = 0 ifTrue: [^ self].
	^ self browseAllReferencesTo:
		((owningClasses at: index) classPool associationAt: (allVars at: index))! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allObjects
	"Answer an Array of all objects in the system.  Fail if there isn't enough memory to instantiate the result."
	
	<primitive: 178>
	^ self primitiveFailed! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
confirmRemovalOf: aSelector on: aClass 
	"Determine if it is okay to remove the given selector. Answer 1 if it  
	should be removed, 2 if it should be removed followed by a senders  
	browse, and 3 if it should not be removed."
	
	| count answer caption allCalls |
	allCalls := self allCallsOn: aSelector.
	(count := allCalls size) = 0
		ifTrue: [^ 1].
	"no senders -- let the removal happen without warning"
	count = 1
		ifTrue: [(allCalls first actualClass == aClass
					and: [allCalls first selector == aSelector])
				ifTrue: [^ 1]].
	"only sender is itself"
	caption := 'The message ', aSelector printString ,' has ' , count printString , ' sender' asPluralBasedOn: count.
	
	answer := UIManager default 
		chooseFrom: #('Remove it'
				'Remove, then browse senders'
				'Don''t remove, but show me those senders'
				'Forget it -- do nothing -- sorry I asked') title: caption.
	answer = 3
		ifTrue: [self
				browseMessageList: allCalls
				name: 'Senders of ' , aSelector
				autoSelect: aSelector keywords first].
	answer = 0
		ifTrue: [answer := 3].
	"If user didn't answer, treat it as cancel"
	^ answer min: 3! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseObsoleteReferences
	<script>
	"Open a browser on all referenced behaviors that are obsolete"
	"SystemNavigation new browseObsoleteReferences"

	| list |
	list := self methodsReferencingObsoleteClasses.
	^ self 
		browseMessageList: list
		name: 'Method referencing obsoletes'! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allClasses
	"Returns all the classes in the current environment."

	^ self environment allClasses

	! !

!SystemNavigation methodsFor: 'message sends' stamp: ''!
isUnsentMessage: selector
	^ self allBehaviors
		noneSatisfy: [ :behavior | behavior thoroughHasSelectorReferringTo: selector ]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseMessageList: messageList name: label 
	"Create and schedule a MessageSet browser on messageList."

	^ self   
		browseMessageList: messageList 
		name: label 
		autoSelect: nil! !

!SystemNavigation methodsFor: 'accessing' stamp: ''!
environment
	^ environment ! !

!SystemNavigation methodsFor: 'query' stamp: ''!
methodsWithUnboundGlobals
	"This says that for any global, it should match either the class's notion of what bindingOf: the key is, or bindingOf: should be nil and the binding should be in Undeclared. If the class answers a different binding through bindingOf: or answers no binding and the binding is not in Undeclared then the variable in the method is wrong.
	For a clean image the result should be empty. If it is not empty, evaluating Compiler recompileAll probably solves the problem. However, we should investigate why the method gets an incorrect state."

	"SystemNavigation new methodsWithUnboundGlobals"

	^self allMethodsSelect:
		[:m|
		m allLiterals anySatisfy:
			[:l|
			l isVariableBinding
			and: [l key isSymbol "avoid class-side methodClass literals"
			and: [ (l isKindOf: AdditionalBinding) not
			and: [(m methodClass classBindingOf: l key)
					ifNil: [(Undeclared associationAt: l key ifAbsent: []) ~~ l]
					ifNotNil: [:b| b ~~ l]]]]]]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allUnsentMessagesIn: selectorSet 
	"Answer the subset of selectorSet which are not sent anywhere in the system. As allSentMessages does not recurse into nested Arrays, filter with #allCallsOn, which does"
	
	^ (selectorSet copyWithoutAll: self allSentMessages) 
			select: [ :each | (self allCallsOn: each) isEmpty ]   ! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allClassesAndTraits
	"Answer all the classes and traits present in the image. Note that metaclasses are not part of the answer"
	
	^ self environment allClassesAndTraits! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allImplementorsOf: aSelector
	"Answer all the methods that implement the message aSelector."

	^ self allBehaviors
		select: [ :class | class includesSelector: aSelector ]
		thenCollect: [ :class | class >> aSelector ]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
allMethodsWithSourceString: aString matchCase: caseSensitive
	"Answer a SortedCollection of all the methods that contain, in source code, aString as a substring.  Search the class comments also"

	| list addMethod addComment |
	list := OrderedCollection new.
	addMethod := [ :mrClass :mrSel | list add: (mrClass>>mrSel)].									
	addComment := [ :mrClass | list add: (RGCommentDefinition realClass: mrClass)].										
	self allBehaviorsDo: [:each |
		each selectorsDo: [:sel | 
			((each sourceCodeAt: sel) includesSubstring: aString caseSensitive: caseSensitive) 
					ifTrue: [ addMethod value: each value: sel ]].
			(each organization classComment asString includesSubstring: aString caseSensitive: caseSensitive) ifTrue: [ addComment value: each]	].
	^ list ! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseAllSendersOf: aLiteral 
	"Create and schedule a message browser on each method that refers to 
	aLiteral. For example, SystemNavigation new browseAllSendersOf: #printOn:."

	^ self openBrowserFor: aLiteral withMethods: (self allCallsOn: aLiteral) ! !

!SystemNavigation methodsFor: '*HeuristicCompletion-Model' stamp: ''!
allSentMessagesInClass: aClass
	"Answer the set of selectors which are sent somewhere in the system."
	| sent |
	sent := IdentitySet new.
	self allSentMessagesInClass: aClass do: [ :e | sent add: e ].
	^ sent! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseClassCommentsWithString: aString matchCase: caseSensitive
	"Smalltalk browseClassCommentsWithString: 'my instances' "
	"Launch a message list browser on all class comments containing aString as a substring."

	|  suffix list |
	suffix := caseSensitive 
		ifTrue: [' (case-sensitive)']
		ifFalse: [' (case-insensitive)'].
	list := Set new.
	Cursor wait showWhile: [
		self environment allClassesDo: [:class | 
			(class organization classComment asString 
							includesSubstring: aString caseSensitive: caseSensitive) ifTrue: [
								list add: (RGCommentDefinition realClass: class)
							]
		]
	].
	^ self 
		browseMessageList: list asSortedCollection
		name: 'Class comments containing ' , aString printString , suffix
		autoSelect: aString! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseHierarchy: aClass selector: aSelector

	"Open a browser"

	aClass ifNil: [ ^ self ].
	^ Smalltalk tools browser new
		spawnHierarchyForClass: aClass selector: aSelector;
		yourself! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allClassesImplementing: aSelector  
	"Answer all classes that implement the message aSelector."
	^self allBehaviors select: [:class | class includesSelector: aSelector]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allSentMessages
	"Answer the set of selectors which are sent somewhere in the system."
	| sent |
	sent := IdentitySet new.
	self allBehaviorsDo: [:each | 
				each selectors
					do: [:sel | "Include all sels, but not if sent by self"
						(each compiledMethodAt: sel) literalsDo: [:m | 
								(m isSymbol) ifTrue: ["might be sent"
										m == sel ifFalse: [sent add: m]].
								(m isMemberOf: Array) ifTrue: ["might be performed"
										m do: [:x | (x isSymbol) ifTrue: [x == sel ifFalse: [sent add: x]]]]]]].
		"The following may be sent without being in any literal frame"
		1
			to: Smalltalk specialSelectorSize
			do: [:index | sent
					add: (Smalltalk specialSelectorAt: index)].
	^ sent! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allCallsOn: aSymbol 
	"Answer a Collection of all the methods that call on the provided symbol even deeply embedded in literal array."
	"self new allCallsOn: #allCallsOn:"
	
	^ self allReferencesTo: aSymbol! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseAllStoresInto: instVarName from: aClass
    "Create and schedule a Message Set browser for all the receiver's methods 
    or any methods of a subclass/superclass that refer to the instance variable name."

    "self new browseAllStoresInto: 'x' from: Point."

	| methods slot |
	slot := aClass slotNamed: instVarName.
	methods := aClass allMethodsWritingSlot: slot.
	
	^ self
		browseMessageList: methods
		name: 'Stores into ' , instVarName
		autoSelect: instVarName
		refreshingBlock: [ :method | slot isWrittenIn: method ]
! !

!SystemNavigation methodsFor: 'identifying obsoletes' stamp: ''!
obsoleteClasses
	"SystemNavigation new obsoleteClasses inspect"
	"NOTE:  Also try inspecting comments below"

	| obs |
	obs := OrderedCollection new.
	Smalltalk garbageCollect.
	Metaclass
		allInstancesDo: [ :m | 
			| c |
			c := m soleInstance.
			(c notNil and: [ c isObsolete ])
				ifTrue: [ obs add: c ] ].
	^ obs asArray	
		
"Likely in a ClassDict or Pool...
(Association allInstances select: [:a | (a value isKindOf: Class) and: [a value isObsolete]]) asArray
"	
	
"Obsolete class refs or super pointer in last lit of a method...
| n l found |
SystemNavigation new browseAllSelect:
	[:m | found := false.
	1 to: m numLiterals do:
		[:i | (((l := m literalAt: i) isMemberOf: Association)
				and: [(l value isKindOf: Behavior)
				and: [l value isObsolete]])
			ifTrue: [found := true]].
	found]
"! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allMethodsSelect: aBlock 
	"Answer a SortedCollection of each method that, when used as the block  argument to aBlock, gives a true result."
	
	| aCollection |
	aCollection := OrderedCollection new.
	self allBehaviorsDo: [:class | 
		class	methodsDo: [:m | 
			(aBlock value: m) ifTrue: [aCollection add: m]]].
	^ aCollection! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseAllUsersOfTrait: aTrait
	"Launch a class-list list browser on all classes or traits which import aTrait"
	
	^Smalltalk tools messageList browseClasses: aTrait traitUsers! !

!SystemNavigation methodsFor: '*Spec2-Code-Commands' stamp: ''!
browse: anObject

	anObject browse! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allClassesDo: aBlock

	^ self environment allClassesDo: aBlock

	! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allMethods
	^ self environment allMethods
! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allExistingProtocolsFor: instanceSide
	"Answer all protocols on instance or class side"

	^self allClasses flatCollectAsSet: [ :class | instanceSide ifTrue: [class protocols] ifFalse: [ class class protocols ] ]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allObjectsDo: aBlock 
	"Evaluate the argument, aBlock, for each object in the system, excluding immediates such as SmallInteger and Character."
	
	self allObjectsOrNil
		ifNotNil: [ :allObjects| allObjects do: aBlock ]
		ifNil: [ self error:'Error allocating a big enough array for all objects' ]! !

!SystemNavigation methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	self environment: Smalltalk globals! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseClassesWithNamesContaining: aString caseSensitive: caseSensitive 
	"Launch a class-list list browser on all classes whose names containg aString as a substring."
	"SystemNavigation default browseClassesWithNamesContaining: 'Morph' caseSensitive: true "
	
	|  classes |
	classes :=  self environment allClasses select: [:class | (class name includesSubstring: aString caseSensitive: caseSensitive)].				
	^Smalltalk tools messageList browseClasses: classes! !

!SystemNavigation methodsFor: '*HeuristicCompletion-Model' stamp: ''!
allSentMessagesInPackage: aPackage
	| sent |
	sent := IdentitySet new.
	self allSentMessagesInPackage: aPackage do: [ :e | sent add: e ].
	^ sent! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseAllImplementorsOf: selector
	"Create and schedule a message browser on each method that implements 
	the message whose selector is the argument, selector. For example,  
	Smalltalk browseAllImplementorsOf: #at:put:."

	"Create and schedule a senders browser for aSelector."	

	^ self
		browseMessageList: (self allImplementorsOf: selector)
		name: 'Implementors of ' , selector asString
		autoSelect: selector
		refreshingBlock: [:message | message selector = selector ].! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseHierarchy: aBehavior

	^ self browseHierarchy: aBehavior selector: nil! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allClassNamesStartingWith: aString do: aBlock

	self allClassesDo: [ :e |
		(e name beginsWith: aString)
			ifTrue: [ aBlock value: e name ] ]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
installedMethodsWithIncorrectTrailerKind

	^ self allMethodsSelect:
		[ :each | (#(#SourcePointer #VarLengthSourcePointer #NativeCodeTrailer) 
							includes: each trailer kind) not and: [ each isInstalled ] ]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseUndeclaredReferences
	"
	SystemNavigation new browseUndeclaredReferences
	"
	
	Undeclared removeUnreferencedKeys.
	Undeclared associations do: [:binding |
		self
			browseMessageList: (self allReferencesTo: binding )
			name: 'References to Undeclared: ', binding key printString ]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allReferencesTo: aLiteral in: classes
	"Answer all the methods that refer to aLiteral even deeply embedded in literal array."

	^ classes flatCollect: [ :class | class thoroughWhichMethodsReferTo: aLiteral]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
openBrowserFor: aLiteral withMethods: aCollection
	"Create and schedule a message sender browser for aCollection which normally should come from a query based on aLiteral (senders, implementors...). This method is usefull to avoid to call twice allCallsOn: in certain occasion.
	For example, 
		| sys |
		sys := SystemNavigation new.
		sys 
			openBrowserFor: #printOn: 
			withMethods: (sys allCallsOn: #printOn:) asSortedCollection"

	^ self headingAndAutoselectForLiteral: aLiteral do:
		[:label :autoSelect|
		self
			browseMessageList: aCollection
			name: label
			autoSelect: autoSelect
			refreshingBlock: [ :method | method hasSelector: aLiteral ] ]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allReferencesTo: aLiteral do: aBlock
	"Perform aBlock on all the references to aLiteral."
	
	| symbol |
	symbol := aLiteral isSymbol.
	self allBehaviorsDo: [ :class |
		symbol
			ifFalse: [ class withMethodsReferTo: aLiteral do: aBlock ]
			ifTrue: [ class withThorougMethodsReferTo: aLiteral do: aBlock ] ]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseInstVarDefs: aClass

	^ self chooseInstVarFrom: aClass thenDo: 
		[:aVar | self browseAllStoresInto: aVar from: aClass]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allBehaviorsDo: aBlock
	"Execute a block on each class, metaclass, trait and trait class"

	self environment allBehaviorsDo: aBlock! !

!SystemNavigation methodsFor: 'accessing' stamp: ''!
environment: aSystemDictionary
	
	environment := aSystemDictionary! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseMessageList: messageList name: labelString autoSelect: autoSelectString refreshingBlock: aBlock
	"Create and schedule a MessageSet browser on the message list."
	| methods |
	
	"Do not show trait methods"
	methods := messageList reject: [ :each| each isFromTrait ].
	methods isEmpty ifTrue: 
		[^ self inform: 'There are no ', String cr, labelString].
	
	^ Smalltalk tools messageList new
		messages: methods; 
		title: labelString; 
		autoSelect: autoSelectString;
		refreshingBlock: aBlock;
		open! !

!SystemNavigation methodsFor: 'private' stamp: ''!
headingAndAutoselectForLiteral: aLiteral do: binaryBlock
	"Evaluate aBlock with either Users of ... or Senders of ... plus the auto-select string for the given literal.  aLiteral can be a Symbol, a VariableBinding or an arbitrary object."

	| autoSelect |
	^ aLiteral isSymbol
		ifTrue: [ binaryBlock value: 'Senders of ', aLiteral value: aLiteral ]
		ifFalse:
			[ autoSelect := aLiteral isVariableBinding
							ifTrue: [ aLiteral key ]
							ifFalse: [ aLiteral printString ].
			binaryBlock value: 'Users of ', autoSelect value: autoSelect ]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allObjectsOrNil
	"Answer an Array of all objects in the system.  Fail if there isn't enough memory to instantiate the result and answer nil."
	
	<primitive: 178>
	^ nil! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseSendersOf: aSelector name: labelString autoSelect: autoSelectString
	
	^ self
		browseMessageList: (self allCallsOn: aSelector)
		name: labelString
		autoSelect: autoSelectString
		refreshingBlock: [ :method | method hasSelector: aSelector ]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allBehaviors
	^ self environment allBehaviors! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allImplementedMessages
	"Answer a Collection of all the messages that are implemented in the system."
	
	^Symbol selectorTable! !

!SystemNavigation methodsFor: '*NewTools-Debugger-Extensions' stamp: ''!
allHalts

	^ self allBehaviors
		flatCollect:
			[ :class | class methods select: [ :method | method containsHalt ] ]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseMethodsWithSourceString: aString matchCase: caseSensitive
	"SystemNavigation new browseMethodsWithSourceString: 'SourceString'"
	"Launch a browser on all methods whose source code, inluding string literals and comments, contains aString as a substring."
	| suffix |

	suffix := caseSensitive
				ifTrue: [' (case-sensitive)']
				ifFalse: [' (case-insensitive)'].
	^ self
		browseMessageList: (self allMethodsWithSourceString: aString matchCase: caseSensitive)
		name: 'Methods containing ' , aString printString , suffix
		autoSelect: aString! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseAllSelect: aBlock name: aName autoSelect: autoSelectString 
	"Create and schedule a message browser on each method that, when used 
	as the block argument to aBlock gives a true result."
	"self new browseAllSelect: [:method | method numLiterals > 10] name:  
	'Methods with more than 10 literals' autoSelect: 'isDigit'"
	
	^ self
		browseMessageList: (self allMethodsSelect: aBlock)
		name: aName
		autoSelect: autoSelectString! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
classFromPattern: pattern withCaption: aCaption
	"If there is a class whose name exactly given by pattern, return it.
	If there is only one class in the system whose name matches pattern, return it.
	Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen.
	This method ignores tab, space, & cr characters in the pattern"

	| toMatch potentialClassNames classNames exactMatch index |
	(toMatch := pattern
		copyWithoutAll:
			{(Character space).
			(Character cr).
			(Character tab)}) isEmpty
		ifTrue: [ ^ nil ].
	Symbol
		hasInterned: toMatch
		ifTrue: [ :patternSymbol | 
			self environment
				at: patternSymbol
				ifPresent: [ :maybeClass | 
					^ maybeClass isClassOrTrait 
						ifTrue: [ maybeClass ]
						ifFalse: [ maybeClass class ]
					]].
	toMatch := (toMatch copyWithout: $.) asLowercase.
	potentialClassNames := (self environment classNames , self environment traitNames) asOrderedCollection.
	classNames := pattern last = $.
		ifTrue: [ potentialClassNames select: [ :nm | nm asLowercase = toMatch ] ]
		ifFalse: [ potentialClassNames select: [ :n | n includesSubstring: toMatch caseSensitive: false ] ].
	classNames isEmpty
		ifTrue: [ ^ nil ].
	exactMatch := classNames detect: [ :each | each asLowercase = toMatch ] ifNone: [ nil ].
	index := classNames size = 1
		ifTrue: [ 1 ]
		ifFalse: [ 
			exactMatch
				ifNil: [ UIManager default chooseFrom: classNames lines: #() title: aCaption ]
				ifNotNil: [ 
					classNames addFirst: exactMatch.
					UIManager default chooseFrom: classNames lines: #(1) title: aCaption ] ].
	index = 0
		ifTrue: [ ^ nil ].
	^ self environment at: (classNames at: index) asSymbol	"
	self default classFromPattern: 'znak' withCaption: ''
	self default classFromPattern: 'orph' withCaption: ''
	self default classFromPattern: 'TCompil' withCaption: ''
"! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allReferencesToBinding: aVariablesBinding
	"Answer all the methods that refer to aVariableBinding, do not go into nested Arrays"

	^ self allBehaviors flatCollect: [ :class | class whichMethodsReferTo: aVariablesBinding ]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseAllSelect: aBlock 
	"Create and schedule a message browser on each method that, when used 
	as the block argument to aBlock gives a true result. For example,  
	SystemNavigation new browseAllSelect: [:method | method numLiterals >  
	10]."

	^ self
		browseMessageList: (self allMethodsSelect: aBlock)
		name: 'selected messages'! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseAllReferencesTo: aLiteral 
	"Create and schedule a message browser on each method that refers to 
	aLiteral. For example, SystemNavigation new browseAllSendersOf: #printOn:."

	^ self openBrowserFor: aLiteral withMethods: (self allCallsOn: aLiteral) ! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allReferencesTo: aLiteral
	"Answer all the methods that refer to aLiteral even deeply embedded in literal array."


	| specialIndex |
	"for speed we check the special selectors here once per class"
	specialIndex := Smalltalk specialSelectorIndexOrNil: aLiteral.
	^ self allBehaviors flatCollect: [ :class | class thoroughWhichMethodsReferTo: aLiteral specialIndex: specialIndex ]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allPrimitiveMethods
	"Answer all the methods that are implemented by primitives."

	^self allMethods
		select: [ :method | method isPrimitive ]
		thenCollect: [ :method | method methodClass name , ' ' , 
			     method selector , ' ', method primitive printString ]! !

!SystemNavigation methodsFor: 'identifying obsoletes' stamp: ''!
methodsReferencingObsoleteClasses
	"Returns all methods that reference obsolete behaviors"
	
	| obsClasses |
	obsClasses := self obsoleteClasses.
	
	^Array streamContents: [ :methods |
		obsClasses keysAndValuesDo: 
			[ :index :each | | obsRefs | 
			obsRefs := each pointersToExcept: obsClasses.
			obsRefs do: [ :ref | 
				"Figure out if it may be a global"
				(ref isVariableBinding and: [ref key isString	"or Symbol"]) 
					ifTrue: [
						(ref pointersTo) do: [ :meth | 
							meth isCompiledMethod
								ifTrue: [methods nextPut: meth]]]]]]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseInstVarRefs: aClass
	
	^ self chooseInstVarFrom: aClass thenDo: 
		[:aVar | self browseAllAccessesTo: aVar from: aClass]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseAllCallsOnClass: aClass
	"Create and schedule a message browser on each method that refers to 
	aClass. For example, SystemNavigation new browseAllCallsOnClass: Object."

	^ self
		browseMessageList: (aClass allCallsOnIn: self)
		name: 'Users of class ' , aClass instanceSide name
		autoSelect: aClass instanceSide name! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseAllAccessesTo: instVarName from: aClass
	"Create and schedule a Message Set browser for all the receiver's methods 
	or any methods of a subclass/superclass that refer to the instance variable name."

	"self new browseAllAccessesTo: 'x' from: Point."

	| methods slot |
	slot := aClass slotNamed: instVarName.
	methods := aClass allMethodsAccessingSlot: slot.
	
	^ self
		browseMessageList: methods
		name: 'Accesses to ' , instVarName
		autoSelect: instVarName
		refreshingBlock: [ :method | slot isAccessedIn: method ]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseMessageList: messageList name: labelString autoSelect: autoSelectString
	"By default it never refreshes"
	^self browseMessageList: messageList name: labelString autoSelect: autoSelectString refreshingBlock: [ :method | false ]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
instanceSideMethodsWithNilKeyInLastLiteral
	"This answers all the instance side methods that has NIL as the key in their last literal. There should be none (only class side methods have this)"

	^ self
		allMethodsSelect: [ :each | 
			(((each literalAt: each numLiterals) key isNil 
					and: [ (each literalAt: each numLiterals) value isMeta not ])
						and: [ each methodClass ~= UndefinedObject ]) and: [ each isInstalled ] ]! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
methodHierarchyBrowserForClass: aClass selector: sel
	"Create and schedule a message set browser on all implementors of the 
	currently selected message selector. Do nothing if no message is selected."
	
	| list |
	aClass ifNil: [^ self].
	aClass isTrait ifTrue: [^ self].
	sel ifNil: [^ self].
	list := OrderedCollection new.

	aClass allSuperclasses reverseDo: [:cl |
		(cl includesSelector: sel) ifTrue: [
			list addLast: (cl>>sel)]].
	aClass allSubclassesDo: [:cl | 
		(cl includesSelector: sel) ifTrue: [
			list addLast: (cl>>sel) ]].

	list addLast: (aClass>>sel).
	^ self browseMessageList: list name: 'Inheritance of ' , sel

! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
chooseInstVarFrom: aClass thenDo: aBlock 
	"Put up a menu of all the instance variables in the receiver, and when
the user chooses one, evaluate aBlock with the chosen variable as its
parameter.  If the list is 6 or larger, then offer an alphabetical
formulation as an alternative. triggered by a 'show alphabetically' item
at the top of the list."

	| lines labelStream allVars index count offerAlpha |
	(count := aClass allInstVarNames size) = 0 ifTrue: 
		[^ self inform: 'There are no 
instance variables.'].

	allVars := OrderedCollection new.
	lines := OrderedCollection new.
	labelStream := (String new: 200) writeStream.
	(offerAlpha := count > 5)
		ifTrue:
			[lines add: 1.
			allVars add: 'show alphabetically'.
			labelStream nextPutAll: allVars first; cr].
	aClass withAllSuperclasses reverseDo:
		[:class | | vars |
		vars := class instVarNames.
		vars do:
			[:var |
			labelStream nextPutAll: var; cr.
			allVars add: var].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream skip: -1 "cut last CR".
	(lines notEmpty and: [lines last = allVars size]) ifTrue:
		[lines removeLast].  "dispense with inelegant line beneath last item"
	index := (UIManager default chooseFrom: (labelStream contents substrings: {Character cr}) lines: lines
title: 'Instance variables in ', aClass name).
	index = 0 ifTrue: [^ self].
	(index = 1 and: [offerAlpha]) ifTrue: [^ self
chooseInstVarAlphabeticallyFrom: aClass thenDo: aBlock].
	aBlock value: (allVars at: index)! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
chooseInstVarAlphabeticallyFrom: aClass thenDo: aBlock
	| allVars index |
	"Put up a menu of all the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter."

	allVars := aClass allInstVarNames sort.
	allVars isEmpty ifTrue: [^ self inform: 'There are no instance variables'].

	index := (UIManager default chooseFrom: allVars lines: #() title: 'Instance variables in ', aClass name).
	index = 0 ifTrue: [^ aClass].
	aBlock value: (allVars at: index)! !

!SystemNavigation methodsFor: 'private' stamp: ''!
allGlobalRefsOn: aSymbol
	"Answer all references to globals"
	"self new allGlobalRefsOn: #ActiveWorld"
	
	| binding|
	binding := self environment bindingOf: aSymbol.
	binding ifNil: [ ^ #() ].
	^ self allReferencesTo: binding	
	! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseMethodsWhoseNamesContain: aString
	"Launch a tool which shows all methods whose names contain the given 	string; case-insensitive."

	^ self browseAllSelect: [ :e | e selector includesSubstring: aString caseSensitive: false ].! !

!SystemNavigation methodsFor: 'message sends' stamp: ''!
allSendersOf: selector 
	^self allReferencesTo: selector! !

!SystemNavigation methodsFor: '*HeuristicCompletion-Model' stamp: ''!
allSentMessagesInPackage: aPackage do: aBlock
	"Answer the set of selectors which are sent somewhere in the system."
	aPackage definedClassesDo: [ :className | | class |
		class := Smalltalk globals at: className.
		self allSentMessagesInClass: class do: aBlock ]! !

!SystemNavigation methodsFor: 'query' stamp: ''!
allUnimplementedCalls
	"Answer an Array of each message that is sent by an expression in a  
	method but is not implemented by any object in the system."
	| aStream all |
	all := self allImplementedMessages.
	aStream := (Array new: 50) writeStream.
	self
		allBehaviorsDo: [:cl | cl
				selectorsAndMethodsDo: [:sel :meth |
					| secondStream ignored | 
					secondStream := (String new: 5) writeStream.
					ignored := (meth pragmaAt: #ignoreUnimplementedCalls:) 
						ifNotNil: [ :pragma | (pragma argumentAt: 1)  ] 
						ifNil: [ #() ].
					meth messages
						do: [:m | ((all includes: m) not and: [ (ignored includes: m) not])
								ifTrue: [ secondStream nextPutAll: m; space ]].
					secondStream position = 0
						ifFalse: [aStream nextPut: cl name , ' ' , sel , ' calls: ' , secondStream contents]]].
	^ aStream contents! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseClassVariables: aClass

	^ aClass classPool inspectWithLabel: 'Class Variables in ' , aClass name! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseAllSendersOrUsersOf: aLiteralOrClass 
	"Create and schedule a message browser on each method that refers to 
	a literal or class name"
   | senders globalRefs |
   senders := self allCallsOn: aLiteralOrClass.
   globalRefs := self allGlobalRefsOn: aLiteralOrClass.
	^ self openBrowserFor: aLiteralOrClass withMethods: (senders, globalRefs)! !

!SystemNavigation methodsFor: '*HeuristicCompletion-Model' stamp: ''!
allSentMessagesInClass: aClass do: aBlock
	"Answer the set of selectors which are sent somewhere in the system."
	aClass methodsDo: [:method | "Include all sels, but not if sent by self"
		method literalsDo: [:literal | 
			(literal isSymbol) ifTrue: ["might be sent"
				literal == method selector ifFalse: [ aBlock value: literal ]].
			(literal isMemberOf: Array) ifTrue: ["might be performed"
				literal do: [:x | (x isSymbol) ifTrue: [ x == method selector ifFalse: [ aBlock value: x ]]]]]].
	"The following may be sent without being in any literal frame"
	1
		to: Smalltalk specialSelectorSize
		do: [:index | aBlock value: (Smalltalk specialSelectorAt: index)].! !

!SystemNavigation methodsFor: '*Tool-Base' stamp: ''!
browseMethodsWithString: aString matchCase: caseSensitive
	"Launch a browser on all methods that contain string literals with aString as a substring. Make the search case-sensitive or insensitive as dictated by the caseSensitive boolean parameter"

	^ self browseAllSelect:
			[:method |
				method  hasLiteralSuchThat: [:lit |
					lit isString and: [lit isSymbol not and: [  
					lit includesSubstring: aString caseSensitive: caseSensitive]]]]
		name:  'Methods with string ', aString printString, (caseSensitive ifTrue: [' (case-sensitive)'] ifFalse: [' (case-insensitive)'])
		autoSelect: aString.
! !

!SystemNavigation class methodsFor: 'accessing' stamp: ''!
default
	^ self new! !

!SystemNavigationTest commentStamp: ''!
I am an sunit test for SystemNavigation with the default value for its environment (Smalltalk globals).

!
!SystemNavigationTest methodsFor: 'utilities' stamp: ''!
createClassFactory

	^ ClassFactoryWithOrganization newWithOrganization: self systemNavigationToTest environment organization! !

!SystemNavigationTest methodsFor: 'running' stamp: ''!
tearDown
	
	self classFactory cleanUp. 
	SystemAnnouncer announcer: oldSystemAnnouncer.
	super tearDown
	! !

!SystemNavigationTest methodsFor: 'accessing' stamp: ''!
classFactory

	^classFactory! !

!SystemNavigationTest methodsFor: 'tests' stamp: ''!
testAllExistingProtocolsFor

	| instSideProtocols classSideProtocols |

	instSideProtocols := self systemNavigationToTest allExistingProtocolsFor: true. 
	classSideProtocols := self systemNavigationToTest allExistingProtocolsFor: false.
	 
	self assert: (instSideProtocols allSatisfy: #isSymbol).	
	self assert: (classSideProtocols allSatisfy: #isSymbol).
	self assert: (instSideProtocols includesAll: (Object protocols)).
	self assert: (classSideProtocols includesAll: (Object class protocols))! !

!SystemNavigationTest methodsFor: 'tests' stamp: ''!
testIsMessageSentInSystemWithClassesActuallySendngTheMessage

	| classesSendingMessage sentMessageSelector |
	sentMessageSelector := 'MessageSentOnlyByTestClassesXXXShouldNotBeRealyDefined' asSymbol.
	5 timesRepeat: [ self classFactory newClassInCategory: #One ].
	5 timesRepeat: [ self classFactory newClassInCategory: #Two ].
	classesSendingMessage := (self classFactory createdClasses asArray first: 2) , (self classFactory createdClasses asArray last: 3).
	classesSendingMessage do: [ :class | class compileSilently: 'meth self ' , sentMessageSelector ].
	self assert: (self systemNavigationToTest allSendersOf: sentMessageSelector) size equals: 5! !

!SystemNavigationTest methodsFor: 'tests' stamp: ''!
testAllSendersOfASelector

	| senders selector class otherClass callers |
	selector := ('aMethod' , 'WithSenders') asSymbol.
	class := self classFactory newClass.
	class compileSilently: selector asString , ' ^ self'.
	class compileSilently: 'anotherMethod ^self ' , selector asString.
	otherClass := self classFactory newClass.
	otherClass
		compileSilently: 'yetAnotherMethod ^self ' , selector asString.
	senders := self systemNavigationToTest allSendersOf: selector.
	self assert: senders size equals: 2.
	callers := senders collect: [ :methodRef | methodRef selector ].
	self
		assert: (callers includesAll: #(#anotherMethod #yetAnotherMethod))! !

!SystemNavigationTest methodsFor: 'tests' stamp: ''!
testSenderOfASelectorInBlock

	| senders selector class otherClass callers |
	selector := ('aMethod' , 'WithSenders') asSymbol.
	class := self classFactory newClass.
	class compileSilently: selector asString , ' ^ self'.
	class compileSilently: 'anotherMethod ^ [self ' , selector asString , ']'.

	otherClass := self classFactory newClass.
	otherClass
		compileSilently: 'yetAnotherMethod ^[[self ' , selector asString , ']]'.

	senders := self systemNavigationToTest allSendersOf: selector.
	self assert: senders size equals: 2.
	callers := senders collect: [ :methodRef | methodRef selector ].
	self
		assert: (callers includesAll: #(#anotherMethod #yetAnotherMethod))! !

!SystemNavigationTest methodsFor: 'tests' stamp: ''!
testIsUnsentMessage

	| class |
	class := self classFactory newClass.
	class compileSilently: 'messageNeverSentInTheSystemXXXXThisIsForTest ^self'.
	self assert: (self systemNavigationToTest isUnsentMessage: class selectors anyOne)! !

!SystemNavigationTest methodsFor: 'tests' stamp: ''!
testReferencesToAClassInBlock

	| referencingMethods class otherClass callers |

	class := self classFactory newClass.
	class compileSilently: 'aMethod ^ 42'.

	otherClass := self classFactory newClass.
	otherClass
		compileSilently: 'anotherMethod ^[[' , class name asString ,  ']]'.

	referencingMethods := self systemNavigationToTest allReferencesTo: class binding.
	self assert: referencingMethods size equals: 1.
	callers := referencingMethods collect: [ :methodRef | methodRef selector ].
	self
		assert: (callers includesAll: #(#anotherMethod))! !

!SystemNavigationTest methodsFor: 'accessing' stamp: ''!
systemNavigationToTest

	^SystemNavigation new
	! !

!SystemNavigationTest methodsFor: 'tests' stamp: ''!
testAllClassesImplementing

	| implementingClasses |
	implementingClasses := self systemNavigationToTest
		allClassesImplementing: #isSymbol.
	self
		assertCollection: implementingClasses
		hasSameElements: {Object. Symbol}! !

!SystemNavigationTest methodsFor: 'tests' stamp: ''!
testIsMessageSentInSystemWithTheSelectorInsideAnArray

	| classesSendingMessage sentMessageSelector |
	sentMessageSelector := 'MessageSentOnlyByTestClassesXXXShouldNotBeRealyDefined' asSymbol.
	5 timesRepeat: [ self classFactory newClassInCategory: #One ].
	5 timesRepeat: [ self classFactory newClassInCategory: #Two ].
	classesSendingMessage := (self classFactory createdClasses asArray first: 2) , (self classFactory createdClasses asArray last: 3).
	classesSendingMessage do: [ :class | class compileSilently: 'meth ^#(a b ' , sentMessageSelector , ' c)' ].
	self assert: (self systemNavigationToTest allSendersOf: sentMessageSelector) size equals: 5! !

!SystemNavigationTest methodsFor: 'running' stamp: ''!
setUp

	super setUp. 	
	oldSystemAnnouncer := SystemAnnouncer uniqueInstance.
	SystemAnnouncer announcer: nil.	
	classFactory := self createClassFactory! !

!SystemNavigationTest class methodsFor: 'testing' stamp: ''!
isUnitTest
	^false! !

!SystemNotification commentStamp: ''!
I am a notification that informs user aboout some important operation that the system did. !
!SystemNotification methodsFor: 'exceptiondescription' stamp: ''!
defaultAction
	
	UIManager default systemNotificationDefaultAction: self! !

!SystemOrganizer commentStamp: ''!
My instances provide an organization for the classes in the system, just as a ClassOrganizer organizes the messages within a class. The only difference is the methods for fileIn/Out.!
!SystemOrganizer methodsFor: 'queries' stamp: ''!
categoriesMatching: matchString
	"Return all matching categories"
	
	self categories ifNil: [ ^#() ].
	^ self categories select: [:c | matchString match: c]! !

!SystemOrganizer methodsFor: 'accessing' stamp: ''!
environment: aSystemDictionary
	 environment := aSystemDictionary.
! !

!SystemOrganizer methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	categoryArray := Array new.
	categoryStops := Array new.
	elementArray := Array new! !

!SystemOrganizer methodsFor: 'accessing' stamp: ''!
removeCategory: category
	| r |
	r := super removeCategory: category.
	
	"If the category we try to remove is the default one, due to cleansing, we don't have to announce it since it is not a valid category for a Class"
	category = Default ifFalse: [
		SystemAnnouncer uniqueInstance classCategoryRemoved: category.
	].

	^ r! !

!SystemOrganizer methodsFor: 'removing' stamp: ''!
removeSystemCategory: category
	"remove all the classes and traits associated with the category"

	 (self orderedTraitsIn: category) , (self superclassOrder: category)
		reverseDo: [:each | each removeFromSystem].

	self removeCategory: category.
! !

!SystemOrganizer methodsFor: 'testing' stamp: ''!
includesCategory: aString
	"Tests if a category is already included."
	
	^ self categories 
		ifNil: [ false ]
		ifNotNil: [ :categories | categories includes: aString ]! !

!SystemOrganizer methodsFor: '*CodeExport' stamp: ''!
fileOutCategory: category on: aFileStream initializing: aBool
	"Store on the file associated with aFileStream, all the traits and classes associated 
	with the category and any requested shared pools in the right order."

	| poolSet tempClass classes traits |
	traits := self orderedTraitsIn: category.
	classes := self superclassOrder: category.
	poolSet := Set new.
	classes do:  [:class | class sharedPools do: [:eachPool | poolSet add: eachPool]].
	poolSet notEmpty ifTrue: [
		tempClass := Class new.
		tempClass shouldFileOutPools ifTrue: [
			poolSet := poolSet select: [:aPool |
				tempClass shouldFileOutPool: (self environment keyAtIdentityValue: aPool)].
			poolSet do: [:aPool | tempClass fileOutPool: aPool onFileStream: aFileStream]]].
	traits, classes
		do: [:each | 
			each
				fileOutOn: aFileStream
				initializing: false ]
		separatedBy: [ aFileStream cr; nextPut: Character newPage; cr ].
	aBool ifTrue: [classes do: [:cls | cls fileOutInitializerOn: aFileStream]].! !

!SystemOrganizer methodsFor: '*CodeExport' stamp: ''!
fileOutCategory: category on: aFileStream 
	"Store on the file associated with aFileStream, all the classes associated 
	with the category and any requested shared pools."
	^self fileOutCategory: category on: aFileStream initializing: true! !

!SystemOrganizer methodsFor: 'accessing' stamp: ''!
addCategory: newCategory
	(self includesCategory: newCategory) ifTrue: [ ^ self ].

	super addCategory: newCategory.

	SystemAnnouncer uniqueInstance classCategoryAdded: newCategory.! !

!SystemOrganizer methodsFor: 'accessing' stamp: ''!
environment
	 ^ environment ifNil: [ environment := Smalltalk globals]! !

!SystemOrganizer methodsFor: '*CodeExport' stamp: ''!
fileOutCategory: category 
	"Store on the file named category (a string) concatenated with '.st' all the 
	classes associated with the category."
	
	| internalStream |
	internalStream := (String new: 1000) writeStream.
	self fileOutCategory: category on: internalStream.
	^ CodeExporter writeSourceCodeFrom: internalStream baseName: category isSt: true! !

!SystemOrganizer methodsFor: 'queries' stamp: ''!
classesInCategory: category
	^ (self listAtCategoryNamed: category) collect: [ :className | self environment at: className ] ! !

!SystemOrganizer methodsFor: 'queries' stamp: ''!
orderedTraitsIn: category
	"Answer an OrderedCollection containing references to the traits in the 
	category whose name is the argument, category (a string). The traits 
	are ordered so they can be filed in." 

	| behaviors traits |
	behaviors := (self listAtCategoryNamed: category asSymbol) collect: [ :title | self environment at: title ].
	traits := behaviors select: [ :each | each isTrait ].
	traits := traits
		asSortedCollection: [ :t1 :t2 | (t2 traitComposition allTraits includes: t1) or: [ (t1 traitComposition allTraits includes: t2) not ] ].
	^ traits asArray! !

!SystemOrganizer methodsFor: 'accessing' stamp: ''!
renameCategory: oldCatString toBe: newCatString
	| r |
	r := super renameCategory: oldCatString toBe: newCatString.
	SystemAnnouncer uniqueInstance 
		classCategoryRenamedFrom: oldCatString to: newCatString.
	^ r! !

!SystemOrganizer methodsFor: '*CodeExport' stamp: ''!
fileOut  
	"SystemOrganization fileOut"

	| internalStream |
	internalStream := (String new: 30000) writeStream.
	internalStream nextPutAll: 'SystemOrganization changeFromCategorySpecs: #('; cr;
		print: SystemOrganization;  "ends with a cr"
		nextPutAll: ')!!'; cr.

	CodeExporter 
		writeSourceCodeFrom: internalStream 
		baseName: 'SystemOrganization.st' asFileReference nextVersion basenameWithoutExtension 
		isSt: true! !

!SystemOrganizer methodsFor: 'removing' stamp: ''!
removeCategoriesMatching: matchString
	"Remove all matching categories with their classes"
	(self categoriesMatching: matchString) do:
		[:c | self removeSystemCategory: c]! !

!SystemOrganizer methodsFor: 'queries' stamp: ''!
superclassOrder: category
	"Answer an OrderedCollection containing references to the classes in the 
	category whose name is the argument, category (a string). The classes 
	are ordered with superclasses first so they can be filed in."

	| behaviors classes |
	behaviors := (self listAtCategoryNamed: category asSymbol) collect: [ :title | self environment at: title ].
	classes := behaviors select: [ :each | each isBehavior ].
	^ Class superclassOrder: classes ! !

!SystemOrganizer class methodsFor: 'cleanup' stamp: ''!
cleanUp: agressive
	"Remove empty categories when cleaning aggressively"

	agressive ifTrue: [SystemOrganization removeEmptyCategories].
! !

!SystemOrganizer class methodsFor: 'instance creation' stamp: ''!
default
	"look in the environment that the receiver organizes for the associated organization" 
	
	^ self environment organization.! !

!SystemOrganizerTest commentStamp: ''!
SUnit tests for SystemOrganizer!
!SystemOrganizerTest methodsFor: 'tests' stamp: ''!
testDefault

	self assert: SystemOrganizer default identicalTo: self class environment organization! !

!SystemOrganizerTest methodsFor: 'tests' stamp: ''!
testThatExistingPackagenamesDoesNotContainIllegalCharacters
	| illegalCharacters | 
	
	illegalCharacters := #( $\ $/ $: $* $? $" $< $> $| ).
	
	self class environment organization categories do: [ :aPackageName |
		self deny: (aPackageName includesAnyOf: illegalCharacters) ]! !

!SystemOrganizerTest methodsFor: 'tests' stamp: ''!
testDefaultEnvironment
	"When no environment is specified, point to the default one"

	self assert: SystemOrganizer new environment identicalTo: Smalltalk globals! !

!SystemProgressItemMorph commentStamp: ''!
A SystemProgressItemMorph is 'bar' in a SystemProgressMorph. 
!
!SystemProgressItemMorph methodsFor: 'API' stamp: ''!
changed

	| msRefreshRate isTimeForRefresh |
	msRefreshRate := 25.
	isTimeForRefresh := Time millisecondClockValue - lastRefresh >= msRefreshRate.
	super changed.
	(self isInWorld and: [ isTimeForRefresh ]) ifTrue: [ self refresh ].! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
labelMorph

	^ labelMorph.! !

!SystemProgressItemMorph methodsFor: 'API' stamp: ''!
decrement

	bar decrement.! !

!SystemProgressItemMorph methodsFor: 'API' stamp: ''!
current

	^ bar value.! !

!SystemProgressItemMorph methodsFor: 'API' stamp: ''!
current: aNumber

	bar value: aNumber.
	self changed.! !

!SystemProgressItemMorph methodsFor: 'API' stamp: ''!
label: aString

	self label isEmpty ifTrue: [ self forceRefreshOnNextChange ].
	self labelMorph contents: aString.
	self changed.! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
refresh

	lastRefresh := Time millisecondClockValue.
	UIManager default uiProcess == Processor activeProcess
		ifTrue: [ self currentWorld doOneCycleNow ]! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
result

	^ result.! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
startAt: aNumber
 
	startValue := aNumber.! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
result: anObject

	lock critical: [ 
		hasResult := true.
		result := anObject ].! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
forceRefreshOnNextChange

	lastRefresh := 0.! !

!SystemProgressItemMorph methodsFor: 'API' stamp: ''!
increment

	bar increment.! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
initializeLabel: aString start: startNumber end: endNumber
	
	lock := Semaphore forMutualExclusion.
	hasResult := false.
	lastRefresh := 0.
	
	self
		color: Color transparent;
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		cellPositioning: #center;
		cellInset: 5;
		listCentering: #center;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
		
	labelMorph := StringMorph contents: aString font: StandardFonts windowTitleFont.
	self addMorphBack: labelMorph.

	bar := ProgressBarMorph from: startNumber to: endNumber.
	self addMorphBack: bar.! !

!SystemProgressItemMorph methodsFor: 'API' stamp: ''!
beComplete

	self close.! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
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 ].! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
close

	SystemProgressMorph uniqueInstance close: self.! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
start: aNumber

	startValue := aNumber.! !

!SystemProgressItemMorph methodsFor: 'API' stamp: ''!
label
	
	^ self labelMorph contents.! !

!SystemProgressItemMorph methodsFor: 'private' stamp: ''!
max: aNumber
 
	endValue := aNumber.! !

!SystemProgressItemMorph class methodsFor: 'instance creation' stamp: ''!
labeled: aString from: startValue to: endValue

	^ self new initializeLabel: aString start: startValue end: endValue.! !

!SystemProgressMorph commentStamp: ''!
I display a set of progress indicator in a list.
Special care is taken to update the view while the rest of the UI process is blocked.

Reset.
SystemProgressMorph reset.

Examples.
self show: 'Doing...' from: 500 to: 600 during: [ :bar |
	500 to: 600 do: [ :x | 
		bar current: x.
		(Delay forMilliseconds: 20) wait 
		"Just to slow it down so we can see what's going on" ] ].

self show: 'Doing...' from: 0 to: 50 during: [ :bar |
	0 to: 50 do: [ :x | 
		bar increment.
		bar label: x asString.
		(Delay forMilliseconds: 20) wait "Just to slow it down so we can see what's going on" ] ].!
!SystemProgressMorph methodsFor: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!SystemProgressMorph methodsFor: 'private' stamp: ''!
show: aString from: startNumber to: endNumber
	| progressMorph |
	self flag: #pharoFixMe.	"When we go from Exceptions to announcements, delete this and use show:from:to:during:"
	self openInWorld.
	progressMorph := self addItemShowing: aString from: startNumber to: endNumber.
	self
		refresh;
		reposition.
	^ progressMorph! !

!SystemProgressMorph methodsFor: 'private' stamp: ''!
addItemShowing: aString from: startNumber to: endNumber
	
	lock critical: [ | item items |
		item := SystemProgressItemMorph labeled: aString from: startNumber to: endNumber.
		items := self bars size.
		items < 10 ifTrue: [ 
			self addMorphBack: item.
			self recenter ].
		^ item ].! !

!SystemProgressMorph methodsFor: 'accessing' stamp: ''!
lastRefresh

        ^ lastRefresh ifNil: [ lastRefresh := 0 ]! !

!SystemProgressMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!SystemProgressMorph methodsFor: 'updating' stamp: ''!
refresh
	"We may be blocking the UI thread, and thus have to draw the world ourselves when necessary"
	lastRefresh := Time millisecondClockValue.
	UIManager default uiProcess == Processor activeProcess
		ifTrue: [ self currentWorld doOneCycleNow]! !

!SystemProgressMorph methodsFor: 'updating' stamp: ''!
update: aSymbol
	
	| msRefreshRate isTimeForRefresh |
	
	aSymbol == #width
		ifTrue: [ self updateWidth ].
		
	
	msRefreshRate := 60 "roughly 16 times per second".
	isTimeForRefresh := Time millisecondClockValue - self lastRefresh >= msRefreshRate.
	(self isInWorld and: [ isTimeForRefresh ]) ifFalse: [ ^ self ].
	
	self refresh! !

!SystemProgressMorph methodsFor: 'private' stamp: ''!
maxBarWidth

	^ self bars inject: 0 into: [ :max :next | next minExtent x max: max ].! !

!SystemProgressMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!SystemProgressMorph methodsFor: 'updating' stamp: ''!
updateProgressValue! !

!SystemProgressMorph methodsFor: 'private' stamp: ''!
show: aJob
	| progressMorph |
	self flag: #pharoFixMe.	"When we go from Exceptions to announcements, delete this and use show:from:to:during:"

	progressMorph := self addItemShowing: aJob.

	self openInWorld.
	self updateWidth.

	^ progressMorph! !

!SystemProgressMorph methodsFor: 'private' stamp: ''!
bars
	
	^ self submorphs.! !

!SystemProgressMorph methodsFor: 'private' stamp: ''!
reposition
	"Calculate the proper position.
	Pay attention this repositioning only works when the morph is already been displayed."
	
	| xPos yPos margin |
	margin := 20.
	xPos := Display boundingBox width - self fullBounds width - (2*margin).
	xPos := xPos * self class horizontalPosition + margin.
	yPos := Display boundingBox height - self fullBounds height - (2*margin).
	yPos := yPos * self class verticalPosition + margin.
	self align: self fullBounds topLeft with: Display boundingBox topLeft + (5@20) + (xPos @ yPos).
	self refresh.! !

!SystemProgressMorph methodsFor: 'private' stamp: ''!
addItemShowing: aJob
	
	lock critical: [ | item items |
		item := JobProgressMorph job: aJob.
		items := self bars size.
		items < 10 ifTrue: [ 
			self addMorphBack: item.
			self resize ].
		^ item ].! !

!SystemProgressMorph methodsFor: 'submorphs - add/remove' stamp: ''!
dismissViaHalo

	self class reset.! !

!SystemProgressMorph methodsFor: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!SystemProgressMorph methodsFor: 'updating' stamp: ''!
resize

	| newWidth |
	newWidth := self maxBarWidth + 50 max: self width.
	self width: newWidth.! !

!SystemProgressMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!SystemProgressMorph methodsFor: 'private' stamp: ''!
close: aSystemProgressItemMorph

	self bars isEmpty ifTrue: [ ^ self ].
	
	lock critical: [
		aSystemProgressItemMorph delete.
		self bars size = 0 ifTrue: [ 
			self width: 0.
			self delete ] ].

	self refresh.! !

!SystemProgressMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	lock := Semaphore forMutualExclusion.
	lastRefresh := 0.
	self
		setDefaultParameters;
		setProperty: #morphicLayerNumber toValue: self morphicLayerNumber;
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		cellPositioning: #topCenter;
		cellInset: 5;
		listCentering: #center;
		hResizing: #rigid;
		vResizing: #shrinkWrap;
		layoutInset: 10@6;
		minWidth: 150.
	self position: 10@20! !

!SystemProgressMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!SystemProgressMorph methodsFor: 'opening' stamp: ''!
preOpenInWorld: aWorld

	self width: 200.
	self resize.! !

!SystemProgressMorph methodsFor: 'updating' stamp: ''!
recenter
	self reposition! !

!SystemProgressMorph methodsFor: 'initialization' stamp: ''!
setDefaultParameters

	self theme setSystemProgressMorphDefaultParameters: self! !

!SystemProgressMorph methodsFor: 'private' stamp: ''!
show: aString from: startNumber to: endNumber during: aBlock

	| progressMorph result |
	self openInWorld.
	progressMorph := self addItemShowing: aString from: startNumber to: endNumber.
		
	self 
		refresh;
		reposition.

	[ result := progressMorph do: aBlock ] ensure: [ self close: progressMorph ].
	^ result.! !

!SystemProgressMorph methodsFor: 'updating' stamp: ''!
updateColor
	"Callback from theme"
	
	self theme preferGradientFill ifFalse: [^ self].
	self fillStyle: (self theme progressFillStyleFor: self)! !

!SystemProgressMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!SystemProgressMorph methodsFor: 'updating' stamp: ''!
updateWidth

	self resize! !

!SystemProgressMorph methodsFor: 'initialization' stamp: ''!
morphicLayerNumber
	"progress morphs are behind menus and balloons, but in front of most other stuff"
	^self valueOfProperty: #morphicLayerNumber ifAbsent: [ 12 ].! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!SystemProgressMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!SystemProgressMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!SystemProgressMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!SystemProgressMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!SystemProgressMorph class methodsFor: 'instance creation' stamp: ''!
show: aJob

	^ self uniqueInstance show: aJob.! !

!SystemProgressMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!SystemProgressMorph class methodsFor: 'settings' stamp: ''!
settingOn: aBuilder
	<systemsettings>
	"By returning only numbers, the settings do not give enough information so that we can reposition well the the progres bar. For now we tweak the number."
	(aBuilder group: #progress)
		label: 'Progress Bar';
		description: 'Progress Bar settings';
		parent: #morphic;
		with: [
			(aBuilder pickOne: #horizontalPosition)
				target: self;
				getSelector: #horizontalPosition;
				setSelector: #horizontalPosition:;
				label: 'Horizontal progress indicator position';
				domainValues: {'left'->0 . 'middle'->0.5 . 'right'->0.88}.
							
			(aBuilder pickOne: #verticalPosition)
				target: self;
				getSelector: #verticalPosition;
				setSelector: #verticalPosition:;
				default: 0;
				label: 'Vertical progress indicator position';
				domainValues: {'bottom'->0.95 . 'middle'->0.5 . 'top'->0}]! !

!SystemProgressMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
verticalPosition: fraction
	"0.0: top ... 1.0: bottom"
	verticalPosition := fraction.
	self uniqueInstance reposition.! !

!SystemProgressMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!SystemProgressMorph class methodsFor: 'class initialization' stamp: ''!
initialize
	"SystemProgressMorph initialize"

	self reset.! !

!SystemProgressMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SystemProgressMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!SystemProgressMorph class methodsFor: 'enabling/disabling' stamp: ''!
enable

	Job jobAnnouncer when: JobStart send: #startJob: to: self.
	Job jobAnnouncer when: JobEnd send: #endJob: to: self.
	Job jobAnnouncer when: JobChange send: #updateJob: to: self.! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!SystemProgressMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!SystemProgressMorph class methodsFor: 'instance creation' stamp: ''!
show: aString from: startNumber to: endNumber during: aBlock
	self flag: #pharoFixMe.	
	"When we go from Exceptions to announcements, this will be the primary entry point"

	^ self uniqueInstance
		show: aString
		from: startNumber
		to: endNumber
		during: aBlock! !

!SystemProgressMorph class methodsFor: 'instance creation' stamp: ''!
uniqueInstance

	^ UniqueInstance ifNil: [ UniqueInstance := self new ].! !

!SystemProgressMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!SystemProgressMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!SystemProgressMorph class methodsFor: 'instance creation' stamp: ''!
show: aString from: startNumber to: endNumber
	self flag: #pharoFixMe.	
	"When we go from Exceptions to announcements, delete this and use show:from:to:during:"

	^ self uniqueInstance show: aString from: startNumber to: endNumber! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
horizontalPosition
	^ horizontalPosition ifNil: [ horizontalPosition := 0 ]! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
verticalPosition
	^ verticalPosition ifNil: [ verticalPosition := 0 ]! !

!SystemProgressMorph class methodsFor: 'examples' stamp: ''!
example
	"SystemProgressMorph example"
	'Progress' 
		displayProgressFrom: 0 to: 1000
		during: [:bar | 0 to: 1000 do: [:i | bar current: i. (Delay forMilliseconds: 2) wait]]! !

!SystemProgressMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
horizontalPosition: aFloat
	"0.0: left ... 1.0: right"
	horizontalPosition := aFloat.
	self uniqueInstance reposition.! !

!SystemProgressMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!SystemProgressMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!SystemProgressMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!SystemProgressMorph class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	UniqueInstance ifNotNil: [ UniqueInstance delete ].
	UniqueInstance := nil! !

!SystemProgressMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!SystemProgressMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!SystemProgressMorph class methodsFor: 'job subscription' stamp: ''!
endJob: aJobEnd

	self uniqueInstance bars ifNotEmpty: [ :bars | self uniqueInstance close: bars last ]! !

!SystemProgressMorph class methodsFor: 'job subscription' stamp: ''!
startJob: aJobStart

	self show: aJobStart job! !

!SystemProgressMorph class methodsFor: 'enabling/disabling' stamp: ''!
disable

	Job jobAnnouncer unsubscribe: self.! !

!SystemProgressMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!SystemProgressMorph class methodsFor: 'examples' stamp: ''!
exampleLabelOnly
	"SystemProgressMorph exampleLabelOnly"
	| words |
	words := #(zero one two three four five six seven eight nine ten) reversed.
	UIManager default informUserDuring: [:bar |
		words do: [:each|
			bar label: 'Countdown: ', each.
			(Delay forSeconds: 0.2) wait]].! !

!SystemProgressMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!SystemProgressMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!SystemProgressMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!SystemProgressMorph class methodsFor: 'job subscription' stamp: ''!
updateJob: aJobChange
	| bars |
	bars := self uniqueInstance bars.
	bars isEmpty 
		ifFalse: [ 
			bars last 
				label: aJobChange title;
				progress: aJobChange progress ]! !

!SystemProgressMorph class methodsFor: 'examples' stamp: ''!
exampleChangeLabel
	"SystemProgressMorph exampleChangeLabel"
	| classes |
	classes := self environment allClasses copyFrom: 1 to: 100.
	'InitialLabel' 
		displayProgressFrom: 0 to: classes size
		during: [:bar | 1 to: classes size do: [:i |
				bar current: i.
				bar label: i printString, '/', classes size printString, ' ', (classes at: i) printString.
				(Delay forMilliseconds: 100) wait]]! !

!SystemProgressMorph class methodsFor: 'cleanup' stamp: ''!
cleanUp
	self reset! !

!SystemReference commentStamp: ''!
This class defines the full reference help for the system.
(contents for the full API Help).

Just run "HelpBrowser openOn: SystemReference".



!
!SystemReference class methodsFor: 'help topic creation' stamp: ''!
asHelpTopic 
	"HelpBrowser openOn: SystemReference"
	
	^self hierarchyFor: ProtoObject! !

!SystemReference class methodsFor: 'help topic creation' stamp: ''!
classAPIHelpBuilderClass: aClass
	ClassAPIHelpBuilderClass := aClass! !

!SystemReference class methodsFor: 'help topic creation' stamp: ''!
hierarchyWithMethodsFor: aClass
	 
	|root topic |
	root := HelpTopic named: 'System reference for ', aClass name.
	topic := (self classAPIHelpBuilderClass new)
					rootToBuildFrom: aClass;
					addSubclasses: true;
					addMethods: true;
					subclassesAsSeparateTopic: true;
					build;
					topicToBuild.
	root addSubtopic: topic.
	^root! !

!SystemReference class methodsFor: 'help topic creation' stamp: ''!
hierarchyFor: aClass
	 
	|root topic |
	root := HelpTopic named: 'System reference for ', aClass name.
	topic := self classAPIHelpBuilderClass new
					rootToBuildFrom: aClass;
					addSubclasses: true;
					addMethods: false;
					subclassesAsSeparateTopic: false;
					build;
					topicToBuild.
	root addSubtopic: topic.
	^root! !

!SystemReference class methodsFor: 'help topic creation' stamp: ''!
classAPIHelpBuilderClass

	ClassAPIHelpBuilderClass ifNil: [ ClassAPIHelpBuilderClass := ClassAPIHelpBuilder ].
	^ ClassAPIHelpBuilderClass! !

!SystemReference class methodsFor: 'help topic creation' stamp: ''!
forClass: aClass
	|root topic |
	root := HelpTopic named: 'System reference for ', aClass name.
	topic := self classAPIHelpBuilderClass buildHelpTopicFrom: aClass.
	root addSubtopic: topic.
	^root! !

!SystemReference class methodsFor: 'help topic creation' stamp: ''!
all
	"HelpBrowser openOn: self all "
	
	^(self classAPIHelpBuilderClass new)
		rootToBuildFrom: ProtoObject;
		addSubclasses: true;
		addMethods: true;
		subclassesAsSeparateTopic: false;
		build;
		topicToBuild! !

!SystemResolver commentStamp: ''!
I resolve origins that are related to the currently running Smalltalk system, using primitives provided by the VM. !
!SystemResolver methodsFor: 'origins' stamp: ''!
vmDirectory
	<origin>
	^ self resolveString: Smalltalk vm directory! !

!SystemResolver methodsFor: 'origins' stamp: ''!
vmBinary
	<origin>
	^ self resolveString: Smalltalk vm fullPath! !

!SystemResolver methodsFor: 'origins' stamp: ''!
image
	<origin>
	^ self resolveString: Smalltalk imagePath! !

!SystemResolver methodsFor: 'origins' stamp: ''!
changes
	<origin>
	^ self image withExtension: Smalltalk changesSuffix! !

!SystemResolver methodsFor: 'origins' stamp: ''!
localDirectory 
	<origin>
	^ self class userLocalDirectory 
		ifNil: [ (self imageDirectory / self class defaultLocalDirectoryName) ensureCreateDirectory ]! !

!SystemResolver methodsFor: 'origins' stamp: ''!
imageDirectory
	<origin>
	^ self image parent! !

!SystemResolver class methodsFor: 'accessing' stamp: ''!
defaultLocalDirectory
	^ (FileLocator imageDirectory / self defaultLocalDirectoryName)
		resolve! !

!SystemResolver class methodsFor: 'accessing' stamp: ''!
defaultLocalDirectoryName
	^ 'pharo-local'! !

!SystemResolver class methodsFor: 'accessing' stamp: ''!
userLocalDirectory

	^ UserLocalDirectory ifNil: [ self defaultLocalDirectory ]! !

!SystemResolver class methodsFor: 'accessing' stamp: ''!
userLocalDirectory: aFileReferenceOrPathName
	|aDirReference| 
	aDirReference := aFileReferenceOrPathName asFileReference.
	aDirReference isDirectory ifTrue: [UserLocalDirectory := aDirReference ]! !

!SystemResolver class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>  

	(aBuilder setting: #userLocalDirectory)
		parent: #pharoSystem;
		type: #Directory;
		target: self;
		default: self defaultLocalDirectory;
		description: 'The path of a directory where Pharo will store local files' ;
		label: 'Local directory'.! !

!SystemResolverTest commentStamp: ''!
SUnit tests for SystemResolver!
!SystemResolverTest methodsFor: 'running' stamp: ''!
tearDown 
	
	self resetToOriginalUserLocalDirectory.
	super tearDown.! !

!SystemResolverTest methodsFor: 'testing' stamp: ''!
testImage
	self assertOriginResolves: #image! !

!SystemResolverTest methodsFor: 'testing' stamp: ''!
testUserLocalDirectory
	| newReference originalReference |
	originalReference := resolver class userLocalDirectory.
	
	"test if setting to invalid directory reference is ignored"
	newReference	 := 'someRandomString345239' asFileReference.
	resolver class userLocalDirectory: newReference.	
	self assert: resolver class userLocalDirectory equals: originalReference.
	
	"test on VM path if setting to existing directory is properly assigned"
	newReference := resolver vmDirectory.
	resolver class userLocalDirectory:  newReference.
	self assert: resolver class userLocalDirectory equals: newReference.! !

!SystemResolverTest methodsFor: 'testing' stamp: ''!
testVmBinary
	self assertOriginResolves: #vmBinary! !

!SystemResolverTest methodsFor: 'testing' stamp: ''!
testLocalDirectory
	| reference |
	reference := resolver resolve: #localDirectory.
	self assert: (reference isKindOf: FileReference)! !

!SystemResolverTest methodsFor: 'testing' stamp: ''!
testImageDirectory
	self assertOriginResolves: #imageDirectory! !

!SystemResolverTest methodsFor: 'testing' stamp: ''!
testChanges
	self assertOriginResolves: #changes! !

!SystemResolverTest methodsFor: 'running' stamp: ''!
resetToOriginalUserLocalDirectory

	resolver class userLocalDirectory: originalUserLocalDir! !

!SystemResolverTest methodsFor: 'running' stamp: ''!
createResolver
	^ SystemResolver new! !

!SystemResolverTest methodsFor: 'testing' stamp: ''!
testVmDirectory
	self assertOriginResolves: #vmDirectory! !

!SystemResolverTest methodsFor: 'running' stamp: ''!
setUp 
	
	super setUp.
	originalUserLocalDir := resolver class userLocalDirectory.! !

!SystemSettingLauncher commentStamp: ''!
Used to launch a setting!
!SystemSettingLauncher methodsFor: 'accessing' stamp: ''!
inputWidget
	^ (self theme
		newButtonIn: self
		for: self
		getState: nil
		action: #launch
		arguments: {}
		getEnabled: nil
		getLabel: nil
		help: self description)
		label:
			(self theme
				newRowIn: self
				for:
					{(AlphaImageMorph new
						image: (self iconNamed: #smallRedoIcon)).
					(self theme buttonLabelForText: 'Launch' translated)});
		yourself! !

!SystemSettingLauncher methodsFor: 'accessing' stamp: ''!
launch
	self script 
			ifNotNil: [:s | s isSymbol 
				ifTrue: [s numArgs = 0 
					ifTrue: [self settingReceiver perform: s]
					ifFalse: [self settingReceiver perform: s with: self]]
				ifFalse: [s numArgs = 0 
					ifTrue: [s value]
					ifFalse: [s value: self]]]! !

!SystemSettingLauncher methodsFor: 'accessing' stamp: ''!
script
	^ script ifNil: [script := []]! !

!SystemSettingLauncher methodsFor: 'accessing' stamp: ''!
script: aValuableOrSymbol
	script := aValuableOrSymbol! !

!SystemSettingLauncher methodsFor: 'accessing' stamp: ''!
defaultIcon
	^ self iconNamed: #smallDoItIcon! !

!SystemSettingsPersistence commentStamp: ''!
I am a singleton responsible for storing and loading settings on a disk. I can handle a collection of settings or one setting in particular. I know where settings are stored.

External Collaborators (those that use me): SettingNode, SettingBrowser.

Internal Collaborators (those I use): SettingsStonReader, SettingsStonWriter, StoredSettingsFactory, StoredSettingsMerger

Public API and Key Messages

- updateSettingNodes:
- storeSettingNodes:
- storedValueForSettingNode:
- accessing instance: SystemSettingsPersistence default

Internal Representation and Key Implementation Points.

    Instance Variables
	fileReference:		<FileReference>
	settingTree:		<SettingTree>
!
!SystemSettingsPersistence methodsFor: 'deleting' stamp: ''!
deleteSettingNode: aSettingNode 
	self deleteSettingNodes: (Array with: aSettingNode)! !

!SystemSettingsPersistence methodsFor: 'accessing' stamp: ''!
fileReference: aFileReference
	"Reference to a file with preferences."
	fileReference := aFileReference! !

!SystemSettingsPersistence methodsFor: 'storing' stamp: ''!
storeExactStoredSettings: allStoredSettings
	| stream |
	self removeFileReference.
	stream := self writeStream.
	[ self storeExactStoredSettings: allStoredSettings on: stream ]
		ensure: [ stream close ]! !

!SystemSettingsPersistence methodsFor: 'storing' stamp: ''!
storeStoredSettings: aCollectionOfStoredSettings
	"It stores a collection of settings on the disk."
	| allStoredSettings |
	allStoredSettings := self mergeStoredSettings: aCollectionOfStoredSettings.
	self storeExactStoredSettings: allStoredSettings! !

!SystemSettingsPersistence methodsFor: 'enumerating' stamp: ''!
storedSettingsForSettingNodes: aCollectionOfSettingNodes
	"It returns stored settings for the setting nodes."
	^ self allStoredSettings 
				select: [ :eachStoredSetting | 
					aCollectionOfSettingNodes anySatisfy: [ :eachSettingNode |
						eachStoredSetting isForSettingNode: eachSettingNode ] ]! !

!SystemSettingsPersistence methodsFor: 'loading' stamp: ''!
storedValueForSettingNode: aSettingNode
	"It returns a stored value for the setting node.
	It returns nil value when there is no stored value."
	^ (self storedSettingForSettingNode: aSettingNode) ifNotNil: #realValue! !

!SystemSettingsPersistence methodsFor: 'accessing' stamp: ''!
nodeNamed: aString 
	^ self settingTree nodeNamed: aString! !

!SystemSettingsPersistence methodsFor: 'storing' stamp: ''!
storeSettingNode: aSettingNode
	"It stores one setting on the disk."
	self storeSettingNodes: (Array with: aSettingNode)! !

!SystemSettingsPersistence methodsFor: 'loading' stamp: ''!
updateSettingNodes
	self updateSettingNodes: self settingTree nodeList! !

!SystemSettingsPersistence methodsFor: 'accessing' stamp: ''!
ensureFileReference
	"It ensures that the parent directory exists."
	self fileReference parent ensureCreateDirectory.
	^ self fileReference! !

!SystemSettingsPersistence methodsFor: 'streams' stamp: ''!
readStream
	^ self fileReference readStream! !

!SystemSettingsPersistence methodsFor: 'storing' stamp: ''!
storeSettingNodes: aCollectionOfSettingNodes
	"It stores a collection of settings on the disk."
	| storedNodes |
	storedNodes := StoredSettingsFactory new fromSettingNodes: aCollectionOfSettingNodes.
	self storeStoredSettings: storedNodes.! !

!SystemSettingsPersistence methodsFor: 'storing' stamp: ''!
mergeStoredSettings: aCollectionOfStoredSettings
	^ StoredSettingsMerger new
		addStoredSettings: self allStoredSettings;
		addStoredSettings: aCollectionOfStoredSettings;
		storedSettings! !

!SystemSettingsPersistence methodsFor: 'storing' stamp: ''!
storeExactStoredSettings: allStoredSettings on: aStream
	SettingsStonWriter new
		stream: aStream;
		addSettings: allStoredSettings;
		store! !

!SystemSettingsPersistence methodsFor: 'storing' stamp: ''!
storeIdentifiers: aCollectionOfSettingNodeIdentifiers
	"It stores one setting, identifier by settingNodeIdentifierString, on the disk."
	| settingNodes |
	settingNodes := self settingsNodesFromIdentifiers: aCollectionOfSettingNodeIdentifiers.
	self storeSettingNodes: settingNodes! !

!SystemSettingsPersistence methodsFor: 'accessing' stamp: ''!
allStoredSettings
	"Load all stored settings from the file preference."
	(self fileReference exists) 
		ifFalse: [ ^ #() ].
	^ SettingsStonReader new stream: self readStream; secureLoad.! !

!SystemSettingsPersistence methodsFor: 'storing' stamp: ''!
storeSettingNodes
	self storeSettingNodes: self settingTree nodeList.! !

!SystemSettingsPersistence methodsFor: 'accessing' stamp: ''!
settingTree: aSettingTree 
	settingTree := aSettingTree ! !

!SystemSettingsPersistence methodsFor: 'loading' stamp: ''!
updateSettingNode: aSettingNode
	self updateSettingNodes: (Array with: aSettingNode)! !

!SystemSettingsPersistence methodsFor: 'streams' stamp: ''!
writeStream
	^ self ensureFileReference writeStream! !

!SystemSettingsPersistence methodsFor: 'enumerating' stamp: ''!
settingsNodesFromIdentifiers: aCollection 
	^ aCollection 
			collect: [ :eachIdentifier |
				self settingTree deeplyDetect: [ :eachSettingNode |
					eachSettingNode settingNodeIdentifier = eachIdentifier ] ]
			thenReject: #isNil! !

!SystemSettingsPersistence methodsFor: 'deleting' stamp: ''!
deleteSettingNodes: aCollection 
	| storedSettings reducedStoredSettings |
	storedSettings := self storedSettingsForSettingNodes: aCollection.
	reducedStoredSettings := self allStoredSettings difference: storedSettings . 
	self storeExactStoredSettings: reducedStoredSettings! !

!SystemSettingsPersistence methodsFor: 'accessing' stamp: ''!
fileReference
	"Reference to a file with preferences."
	^ fileReference! !

!SystemSettingsPersistence methodsFor: 'loading' stamp: ''!
updateSettingNodes: aCollectionOfSettingNodes
	| storedSettings |
	storedSettings := self allStoredSettings.
	aCollectionOfSettingNodes do: [ :eachSettingNode |
		storedSettings 
			detect: [ :eachStoredSetting | eachStoredSetting isForSettingNode: eachSettingNode ]
			ifFound: [ :storedSetting | storedSetting updateSettingNode: eachSettingNode ]
			ifNone: [ "ignore it" ] ]! !

!SystemSettingsPersistence methodsFor: 'enumerating' stamp: ''!
settingNodeForStoredSetting: aStoredSetting
	^ self settingTree nodeList detect: [ :eachSettingNode |
		aStoredSetting isForSettingNode: eachSettingNode ]! !

!SystemSettingsPersistence methodsFor: 'storing' stamp: ''!
removeFileReference
	"We have to remove the file before writing new settings."

	| newFileReference |
	fileReference ifAbsent: [ ^ self ].
	newFileReference := fileReference withExtension: 'old.txt'.
	newFileReference ensureDelete.
	fileReference copy renameTo: newFileReference basename! !

!SystemSettingsPersistence methodsFor: 'enumerating' stamp: ''!
storedSettingForSettingNode: aSettingNode
	"It returns a stored setting for the setting node."
	^ self allStoredSettings 
				detect: [ :eachStoredSetting | 
					eachStoredSetting isForSettingNode: aSettingNode ]
				ifNone: [ nil ]! !

!SystemSettingsPersistence methodsFor: 'storing' stamp: ''!
storeIdentifier: settingNodeIdentifierString
	"It stores one setting, identifier by settingNodeIdentifierString, on the disk."
	self storeIdentifiers: (Array with: settingNodeIdentifierString)! !

!SystemSettingsPersistence methodsFor: 'accessing' stamp: ''!
settingTree
	^ settingTree! !

!SystemSettingsPersistence class methodsFor: 'deleting' stamp: ''!
deleteSettingNode: aSettingNode 
	self default deleteSettingNode: aSettingNode ! !

!SystemSettingsPersistence class methodsFor: 'class initialization' stamp: ''!
initialize
	"in order to update settings at startup.
	should be registered at the end of standard classes but before user classes"
	
	"IMPORTANT: do not uncomment the registration to the session manager!!
	For now, SystemSettingsPersistence is handled directly by the command line handler startup.
	We should define a startup action parsing command line arguments and able to provide them to other startup actions. Then, SystemSettingsPersistence as well as StartupPreferencesLoader, could be independent startup actions."
	"SessionManager default
		registerBeforeUserClass: self"! !

!SystemSettingsPersistence class methodsFor: 'accessing' stamp: ''!
defaultPreferenceFileReference
	^ StartupPreferencesLoader preferencesVersionFolder / 'system-settings.ston'! !

!SystemSettingsPersistence class methodsFor: 'storing' stamp: ''!
storeSettingNodes
	self default storeSettingNodes! !

!SystemSettingsPersistence class methodsFor: 'instance creation' stamp: ''!
settingTree: aSettingTree 
	^ self new
		fileReference: self defaultPreferenceFileReference;
		settingTree: aSettingTree;
		yourself! !

!SystemSettingsPersistence class methodsFor: 'loading' stamp: ''!
updateSettingNode: aSettingNode
	self default updateSettingNode: aSettingNode! !

!SystemSettingsPersistence class methodsFor: 'accessing' stamp: ''!
storedValueForSettingNode: aSettingNode 
	^ self default storedValueForSettingNode: aSettingNode! !

!SystemSettingsPersistence class methodsFor: 'storing' stamp: ''!
storeSettingNode: aSettingNode 
	self default storeSettingNode: aSettingNode! !

!SystemSettingsPersistence class methodsFor: 'loading' stamp: ''!
updateSettingNodes: aSettingNode
	self default updateSettingNodes: aSettingNode! !

!SystemSettingsPersistence class methodsFor: 'accessing' stamp: ''!
default
	^ self new
		fileReference: self defaultPreferenceFileReference;
		settingTree: SettingBrowser new treeHolder;
		yourself! !

!SystemSettingsPersistence class methodsFor: 'system startup' stamp: ''!
resumeSystemSettings
	"Load persisted settings if the last settings were not loaded from this machine"
	| thisComputerID |
	
	thisComputerID := GlobalIdentifier uniqueInstance computerUUID.
	lastSettingsComputerID ~= thisComputerID ifTrue: [ 
		lastSettingsComputerID := thisComputerID.
		self updateSettingNodes ]! !

!SystemSettingsPersistence class methodsFor: 'system startup' stamp: ''!
startUp: resuming
	resuming ifTrue: [ self resumeSystemSettings ]! !

!SystemSettingsPersistence class methodsFor: 'loading' stamp: ''!
updateSettingNodes
	self default updateSettingNodes! !

!SystemSettingsPersistence class methodsFor: 'storing' stamp: ''!
storeIdentifier: settingNodeIdentifierString
	self default storeIdentifier: settingNodeIdentifierString! !

!SystemSettingsPersistence class methodsFor: 'cleanup' stamp: ''!
cleanUp
	lastSettingsComputerID := nil.! !

!SystemSettingsPersistence class methodsFor: 'storing' stamp: ''!
storeSettingNodes: aCollectionOfSettingNodes 
	self default storeSettingNodes: aCollectionOfSettingNodes! !

!SystemSettingsPersistenceTest commentStamp: ''!
A SystemSettingsTest is a test class for testing the behavior of SystemSettings!
!SystemSettingsPersistenceTest methodsFor: 'tests - storing - defaults' stamp: ''!
testDefaultSettingValueIsNotIncludedInTheStoredFile

	MockSettings booleanSettingWithDefault: false.

	systemSettings storeSettingNodes: MockSettings settingTree nodeList.
	
	self assertStoredSettingsDoNotInclude: #booleanSettingWithDefault.! !

!SystemSettingsPersistenceTest methodsFor: 'asserting' stamp: ''!
assertStoredSettingsInclude: aIdentifier withValue: aValue 

	| nodes |
	self assert: preferences exists.	
	
	nodes := preferences readStreamDo: [ :stream | STON fromStream: stream ].
	
	nodes detect: [ :aNode | aNode settingNodeIdentifier = aIdentifier printString ]  
		ifFound: [ :aNode | self assert: aNode realValue equals: aValue ] 
		ifNone: [ self fail: 'Node with identifier ', aIdentifier printString, ' not found' ]! !

!SystemSettingsPersistenceTest methodsFor: 'tests - storing' stamp: ''!
testStoreIdentifier
	self deny: preferences exists.
	systemSettings storeIdentifier: MockSettings booleanSettingNode settingNodeIdentifier.
	self assert: preferences exists.
	self assert: preferences size > 0.
	! !

!SystemSettingsPersistenceTest methodsFor: 'tests - storing' stamp: ''!
testStoreSettingNode
	self deny: preferences exists.
	systemSettings storeSettingNode: MockSettings booleanSettingNode.
	self assert: preferences exists.
	self assert: preferences size > 0.
	! !

!SystemSettingsPersistenceTest methodsFor: 'tests - storing - defaults' stamp: ''!
testStoringNonDefaultValueAndThenStoringTheDefaultRemovesTheNode

	"Store with a non default value"
	MockSettings booleanSettingWithDefault: true.
	systemSettings storeSettingNodes: MockSettings settingTree nodeList.

	"Store with a default value"
	MockSettings booleanSettingWithDefault: false.
	systemSettings storeSettingNodes: MockSettings settingTree nodeList.
	
	self assertStoredSettingsDoNotInclude: #booleanSettingWithDefault.! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testAllStoredSettings
	"There is no preference file. It should not generate an error."

	self assertEmpty: systemSettings allStoredSettings.
	systemSettings writeStream
		nextPutAll: 'random string';
		close.
	self assert: systemSettings fileReference contents equals: 'random string'.
	self assertEmpty: systemSettings allStoredSettings! !

!SystemSettingsPersistenceTest methodsFor: 'tests - storing' stamp: ''!
testStoreSettingNodes
	self deny: preferences exists.
	self testRealValueModification.
	systemSettings storeSettingNodes: { 
		MockSettings booleanSettingNode.
		MockSettings rangeSettingNode }.
	self assert: preferences exists.
	self assert: preferences size > 0.
	self assert: preferences contents equals: MockSettings twoStoredSettingsSTONString
! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testAccessRealValues
	"Ensure we can access all setting real values."
	self systemSettingNodeList do: [ :eachSettingNode | 
				eachSettingNode item hasValue and: [ eachSettingNode item realValue ] ].! !

!SystemSettingsPersistenceTest methodsFor: 'tests - loading' stamp: ''!
testStoreAndLoadAllSystemSettings
	| searchCompiledMethod |
	systemSettings settingTree: SettingBrowser new treeHolder.
	systemSettings storeSettingNodes.
	systemSettings allStoredSettings do: #realValue.
	searchCompiledMethod := [ :aClass :aBlock | aClass compiledMethodAt: #= ifAbsent: [ aBlock value: aClass superclass value: aBlock ] ].
	systemSettings allStoredSettings do: [ :eachStoredSetting | | settingNode compiledMethod |
		settingNode := systemSettings settingNodeForStoredSetting: eachStoredSetting.
		self assert: eachStoredSetting realValue class equals: settingNode realValue class.
		compiledMethod := searchCompiledMethod value: eachStoredSetting realValue class value: searchCompiledMethod.
		compiledMethod methodClass == Object ifFalse: [ 
			self assert: eachStoredSetting realValue equals: settingNode realValue ] ].! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testRealValues
	self assert: (systemSettings nodeNamed: #booleanSetting) realValue equals: true.
	self assert: (systemSettings nodeNamed: #rangeSetting) realValue equals: 10.
	! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testStoreBooleanToSton
	| node stored string stored2 |
	node := MockSettings booleanSettingNode.
	stored := StoredSettingsFactory new from: node.
	self assert: stored notNil.
	string := String streamContents: [ :aStream | | writer |
		writer := STON writer on: aStream; prettyPrint: true; yourself.
		writer writeObject: stored.
	].
	self assert: string notNil.
	stored2 := STON fromString: string. 
	self assert: stored2 notNil.
	self assert: stored2 equals: stored.! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testAccessibleRealValues
	"Ensure we can access all setting real values."
	self systemSettingNodeList do: [ :eachSettingNode |
		eachSettingNode settingDeclaration hasValue and: [ eachSettingNode settingDeclaration realValue ] ]! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testUniqueIdentifiers
	| names |
	names := self systemSettingNodeList collect: [:each | each settingNodeIdentifier].
	self assert: names size equals: names asSet size.! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testWriteStream
	| writeStream |
	self deny: preferences exists.
	self deny: preferences parent exists.
	writeStream := systemSettings writeStream.
	self assert: writeStream isStream.
	writeStream close.! !

!SystemSettingsPersistenceTest methodsFor: 'tests - loading' stamp: ''!
testWriteAndReadBoolean
	| node stored string stored2 |
	node := MockSettings booleanSettingNode.
	stored := StoredSettingsFactory new from: node.
	self assert: stored notNil.
	string := String streamContents: [ :aStream | | writer |
		writer := STON writer on: aStream; prettyPrint: true; yourself.
		writer writeObject: stored.
	].
	self assert: string notNil.
	stored2 := STON fromString: string. 
	self assert: stored2 notNil.
	self assert: stored2 equals: stored.! !

!SystemSettingsPersistenceTest methodsFor: 'tests - storing - defaults' stamp: ''!
testNonDefaultSettingValueIsIncludedInTheStoredFile

	MockSettings booleanSettingWithDefault: true.

	systemSettings storeSettingNodes: MockSettings settingTree nodeList.
	
	self assertStoredSettingsInclude: #booleanSettingWithDefault withValue: true.! !

!SystemSettingsPersistenceTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	MockSettings cleanUp.
	memory := FileSystem memory.
	preferences := memory root / 'pharo' / 'pharoX.Y' / 'preferences.ston.txt'.
	systemSettings := SystemSettingsPersistence new.
	systemSettings
		fileReference: preferences;
		settingTree: MockSettings settingTree! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testStoredValueForSetting
	| value |
	self testStoreSettingNode.
	value := systemSettings storedValueForSettingNode: MockSettings booleanSettingNode.
	self assert: value.! !

!SystemSettingsPersistenceTest methodsFor: 'tests - storing - defaults' stamp: ''!
testDefaultImageDoesNotStoreAnySetting
	| nodesToStore |
	"An image with all default values should not save any setting.
	The settings only should be saved if changed from default value"

	Author
		useAuthor: ''
		during: [ 
			nodesToStore := StoredSettingsFactory new fromSettingNodes: SettingBrowser currentTree nodeList.
			nodesToStore := nodesToStore reject: [ :aNode | aNode hasDefaultValue ] ].

	self assertCollection: nodesToStore hasSameElements: #()! !

!SystemSettingsPersistenceTest methodsFor: 'running' stamp: ''!
tearDown
	
	MockSettings cleanUp.
	super tearDown.
! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testSettingNodeIdentifierForChildNode
	self assert: MockSettings cacheDirectorySettingNode settingNodeIdentifier equals: '#monticello#cacheDirectory'.
	! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testRealValueModification
	self booleanSettingNode realValue: false.
	self rangeSettingNode realValue: 55.
	self assert: self booleanSettingNode realValue equals: false.
	self assert: self rangeSettingNode realValue equals: 55.
! !

!SystemSettingsPersistenceTest methodsFor: 'tests - storing' stamp: ''!
testStoreSettingNodeTwice
	| fileSize fullPath |
	self deny: preferences exists.
	fullPath := preferences fullPath.
	systemSettings storeSettingNode: MockSettings booleanSettingNode.
	self assert: preferences fullPath equals: fullPath.
	self assert: preferences exists.
	fileSize := preferences size.
	self assert: fileSize > 0.
	systemSettings storeSettingNode: MockSettings booleanSettingNode.
	self assert: preferences fullPath equals: fullPath.
	self assert: preferences size equals: fileSize.! !

!SystemSettingsPersistenceTest methodsFor: 'asserting' stamp: ''!
assertStoredSettingsDoNotInclude: aIdentifier

	| nodes |
	self assert: preferences exists.	
	
	nodes := preferences readStreamDo: [ :stream | STON fromStream: stream ].
	
	nodes detect: [ :aNode | aNode settingNodeIdentifier = aIdentifier printString ]  
		ifFound: [ :aNode | self fail: 'The node has been found, it should not be there' ] 
		ifNone: [ ^ self ]! !

!SystemSettingsPersistenceTest methodsFor: 'accessing' stamp: ''!
rangeSettingNode
	^ systemSettings nodeNamed: #rangeSetting! !

!SystemSettingsPersistenceTest methodsFor: 'tests - storing' stamp: ''!
testWritingStoredSettingNodesShouldNotCloseFileStream
	| writeStream storedSettings |
	writeStream := preferences ensureCreateFile writeStream.
	storedSettings := StoredSettingsFactory new
		fromSettingNodes: (Array with: MockSettings booleanSettingNode).
	systemSettings storeExactStoredSettings: storedSettings on: writeStream.
	self deny: writeStream closed! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testSettingNodeIdentifierForRootNode
	self assert: MockSettings rangeSettingNode settingNodeIdentifier equals: '#rangeSetting'.	! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testUniqueNames
	| names |
	names := self systemSettingNodeList collect: [ :eachNode | 
						eachNode parentName printString, eachNode item name ].
	self assert: names size equals: names asSet size.! !

!SystemSettingsPersistenceTest methodsFor: 'tests - storing' stamp: ''!
testStoreTwoSettingNodeSeparately
	| fileSize |
	self deny: preferences exists.
	systemSettings storeSettingNode: MockSettings booleanSettingNode.
	self assert: preferences exists.
	fileSize := preferences size.
	self assert: fileSize > 0.
	systemSettings storeSettingNode: MockSettings rangeSettingNode.
	self assert: preferences size > fileSize.! !

!SystemSettingsPersistenceTest methodsFor: 'accessing' stamp: ''!
booleanSettingNode
	^ systemSettings nodeNamed: #booleanSetting! !

!SystemSettingsPersistenceTest methodsFor: 'accessing' stamp: ''!
systemSettingNodeList
	^ SettingBrowser new treeHolder nodeList.! !

!SystemSettingsPersistenceTest methodsFor: 'tests' stamp: ''!
testStoredValueForSettingNoStoredValue
	| value |
	value := systemSettings storedValueForSettingNode: MockSettings booleanSettingNode.
	self assert: value equals: nil.! !

!SystemSettingsPersistenceTest methodsFor: 'tests - loading' stamp: ''!
testUpdateAllSettings
	self testRealValues.
	self testRealValueModification.
	systemSettings storeSettingNodes.
	MockSettings cleanUp.
	self testRealValues.
	systemSettings updateSettingNodes.
	self assert: self booleanSettingNode realValue equals: false.
	self assert: self rangeSettingNode realValue equals: 55! !

!SystemSystemSettings commentStamp: ''!
Settings for the system itself!
!SystemSystemSettings class methodsFor: 'settings' stamp: ''!
systemSettingOn: aBuilder
	<systemsettings>
	
	(aBuilder group: #tools)
		label: 'Tools';
		description: 'Settings related to Tools'.
	
	(aBuilder group: #SCM)
		label: 'Software Configuration Management';
		parent: #tools;
		description: 'Settings related to version management and code sharing'.
	
	(aBuilder group: #pharoSystem) 
		label: 'System';
		description: 'General system settings' ;
		with: [
			(aBuilder setting: #serverMode)
				label: 'Server mode';
				target: WorldState;
				default: false;
				description: 'If enabled, then each main rendering loop will always wait a complete delay of 50 ms' .
			(aBuilder setting: #useLocale)
				label: 'Use locale';
				default: false;
				target: Locale;
				selector: #activated;
				description: 'Use the system locale to set the system language at startup.']
! !

!SystemVersion commentStamp: ''!
I am responsible for maintaining what version of Pharo and the VM is running.  I also track all of the update items that have been included in the image.

I'm invoked at auto start to get the latest plugins, etc.

Some queries are
	SystemVersion current major
	SystemVersion current minor
	SystemVersion current suffix
	SystemVersion current	highestUpdate!
!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
build: aBuildNumber

	build := aBuildNumber! !

!SystemVersion methodsFor: 'private' stamp: ''!
calculateHighestUpdate 
	|result|
	result := (major * 10000) + (minor * 1000).
	self hasValidBuildNumber ifTrue: [ result := result + build ].
	^result 
	
! !

!SystemVersion methodsFor: 'accessing' stamp: ''!
patch: anObject
	patch := anObject! !

!SystemVersion methodsFor: 'accessing - version strings' stamp: ''!
imageVersionString
	"Print the version compatible with naming the image."
	
	^String streamContents: [:str |
		str nextPutAll: self type;
			 nextPut: $-;
			 nextPutAll: (self majorMinorPatch: '.').
			
		self hasMetadataIdentifiers ifTrue: [ str nextPut: $+ ].		
		self suffix ifNotEmpty: [ str nextPutAll: self suffix ].
		self hasValidBuildNumber ifTrue: [ 
			self suffix ifNotEmpty: [ str nextPut: $.].
			str nextPutAll: 'build.'; nextPutAll: self build asString ].	
		self commitHash ifNotEmpty: [ str nextPutAll: '.sha.'; nextPutAll: self commitHash ].
		
		Smalltalk vm is32bit ifTrue: [ str nextPutAll: ' (32 Bit)' ]
								   ifFalse: [ str nextPutAll: ' (64 Bit)' ].					
	]! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
commitHash
	"Answer the hash of a Git commit from which the image was bootstrapped, e.g. '9ce829e86f978a84fa68df20008a3c1ee52e1fae'"

	^ commitHash! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
date: newDate
	date := newDate! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
suffix: anObject
	"Set the value of suffix"

	suffix := anObject! !

!SystemVersion methodsFor: 'accessing - version strings' stamp: ''!
datedVersion
	" E.g. 'Pharo2.0a of ''18 April 2012''' "

	^ self version asString , ' of ' , self date printString.! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
type: anObject
	"Set the value of type"

	type := anObject! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
major
	"Answer the major number of a version. 1 in '1.2'"

	^ major! !

!SystemVersion methodsFor: 'printing' stamp: ''!
printOn: stream
	stream nextPutAll: self imageVersionString! !

!SystemVersion methodsFor: 'accessing' stamp: ''!
version
	"Answer the short version string. If the receiver needs upgrading, do it."
	
	^self shortVersionString! !

!SystemVersion methodsFor: 'accessing' stamp: ''!
versionWithoutPatch
	
	^ self type , (self majorMinor: '.')! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
build

	 ^build! !

!SystemVersion methodsFor: 'accessing - version strings' stamp: ''!
shortVersionString
	"Print a short version string."
	
	self type ifNil: [^'No version set'].
	^String streamContents: [:str |
		str 
			nextPutAll: self type;
			nextPutAll: self major printString;
			nextPut: $.;
			nextPutAll: self minor printString;
			nextPut: $.;
			nextPutAll: self patch printString;
			nextPutAll: self suffix ]! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
suffix
	"Answer the suffix (alpha, beta, rc  of a version. beta in '1.2beta'"

	^ suffix! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
date
	^date! !

!SystemVersion methodsFor: 'accessing' stamp: ''!
commitHashShort
	"Answer the shorten hash of a Git commit from which the image was bootstrapped, e.g. '9ce829e"

	^ commitHash ifNotNil: [ commitHash first: (7 min: commitHash size) ]! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
type
	"Answer the value of type"

	^ type! !

!SystemVersion methodsFor: 'utilities' stamp: ''!
majorMinorPatch: aSeparatingString
	"Return the major/minor/patch version number of the form XaSeparatingStringY, without any 'alpha' or 'beta' or other suffix."
	"SystemVersion current majorMinorPatch: '-'"
	"SystemVersion current majorMinorPatch: ''"

	^String streamContents: [:str |
		str 
			nextPutAll: self major printString; 
			nextPutAll: aSeparatingString;
			nextPutAll: self minor printString;
			nextPutAll: aSeparatingString;
			nextPutAll: self patch printString ]! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
minor: anInteger
	"Set the minor part of the receiver"

	minor := anInteger! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
minor
	"Answer the minor number of a version. 2 in '1.2'"

	^ minor! !

!SystemVersion methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	type := 'Pharo'.
	major := 0.
	minor := 0.
	patch := 0.
	suffix := ''.
	build := self class invalidBuildNumber.
	commitHash := ''.
	date := Date today.! !

!SystemVersion methodsFor: 'utilities' stamp: ''!
majorMinor: aSeparatingString
	"Return the major/minor version number of the form XaSeparatingStringY, without any 'alpha' or 'beta' or other suffix."
	"SystemVersion current majorMinor: '-'"
	"SystemVersion current majorMinor: ''"

	^String streamContents: [:str |
		str 
			nextPutAll: self major printString; 
			nextPutAll: aSeparatingString;
			nextPutAll: self minor printString ]! !

!SystemVersion methodsFor: 'accessing' stamp: ''!
majorMinorVersion
	
	^ self type, self dottedMajorMinorPatch! !

!SystemVersion methodsFor: 'compatibility' stamp: ''!
highestUpdate: anInteger
	highestUpdate := anInteger! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
major: anInteger
	"Set the major part of the receiver"

	major := anInteger! !

!SystemVersion methodsFor: 'accessing' stamp: ''!
dottedMajorMinorPatch
	
	^ self majorMinorPatch: '.'.! !

!SystemVersion methodsFor: 'testing' stamp: ''!
hasMetadataIdentifiers
	"Return true if we have metadata identifiers (see rule 10 on semver.org) that need to be separated with a + sign"
	
	^self suffix notEmpty | self hasValidBuildNumber | self commitHash notEmpty ! !

!SystemVersion methodsFor: 'accessing' stamp: ''!
patch
	^ patch! !

!SystemVersion methodsFor: 'testing' stamp: ''!
hasValidBuildNumber
	"Return true if we have a valid build number"
	
	 ^self build ~= self class invalidBuildNumber! !

!SystemVersion methodsFor: 'accessing - properties' stamp: ''!
commitHash: aString

	"Set the hash of a Git commit from which the image was bootstrapped"

	commitHash := aString! !

!SystemVersion methodsFor: 'compatibility' stamp: ''!
highestUpdate
	 ^highestUpdate ifNil: [ highestUpdate := self calculateHighestUpdate ].

	
! !

!SystemVersion methodsFor: 'accessing' stamp: ''!
dottedMajorMinor
	
	^ self majorMinor: '.'! !

!SystemVersion class methodsFor: 'private - accessing' stamp: ''!
invalidBuildNumber
	"Return -1 to depict an invalid build number (allows to also accept 0 as build number)"
	
	^ -1
! !

!SystemVersion class methodsFor: 'instance creation' stamp: ''!
major: major minor: minor patch: patch suffix: aString 
	"Create a new instance of the receiver with the given major minor number and suffix.

	 	SystemVersion major: 6 minor: 1 patch: 199 suffix: 'alpha'     
	"
	
	^self major: major minor: minor patch: patch suffix: aString build: self invalidBuildNumber! !

!SystemVersion class methodsFor: 'accessing' stamp: ''!
current
	^Current ifNil: [Current := self new]! !

!SystemVersion class methodsFor: 'instance creation' stamp: ''!
major: major minor: minor patch: patch suffix: aString build: build
	"Create a new instance of the receiver with the given major minor number and suffix.

	 	SystemVersion major: 6 minor: 1 patch: 199 suffix: 'alpha' build: 148
	"

	^ self new
		major: major;
		minor: minor;
		patch: patch;
		suffix: aString;
		build: build;
		yourself! !

!SystemVersion class methodsFor: '*Tests' stamp: ''!
fromVersionString: aString
	| matcher instance minor major patch |
	
	matcher := '(([A-Z][a-zA-Z]*)[-]*([0-9]+)(\.([0-9]+))?(\.([0-9]+))?)(([+](([a-zA-Z]*)([.]*build.([0-9]+)(.sha.([0-9a-z]+))*)*))*)' asRegex.
	(matcher matches: aString)
		ifFalse: [ ^ self error: 'Not a version string' ].
	
	major := 	(matcher subexpression: 4) asNumber.
	minor := (matcher subexpression: 6) isString ifTrue: [ (matcher subexpression: 6) asNumber ] ifFalse: [ 0 ].
	patch := (matcher subexpression: 8) isString ifTrue: [ (matcher subexpression: 8) asNumber ] ifFalse: [ 0 ].
	instance := self major: major minor: minor patch: patch.
	instance type: (matcher subexpression: 3).
	(matcher subexpression: 12) isString ifTrue: [ instance suffix: (matcher subexpression: 12) ].
	(matcher subexpression: 14) isString ifTrue: [ instance build: (matcher subexpression:  14) asNumber ].
	(matcher subexpression: 16) isString ifTrue: [ instance commitHash: (matcher subexpression:  16) ].
	^ instance! !

!SystemVersion class methodsFor: 'instance creation' stamp: ''!
major: major minor: minor patch: patch suffix: aString build: build commitHash: hashString
	"Create a new instance of the receiver with the given major minor number and suffix.

	 	SystemVersion major: 6 minor: 1 suffix: 'alpha'     
	"
	
	^(self new)
		major: major;
		minor: minor;
		patch: patch;
		suffix: aString;
		build: build;
		commitHash: hashString;
		yourself! !

!SystemVersion class methodsFor: 'instance creation' stamp: ''!
major: major minor: minor patch: patch
	"Create a new instance of the receiver with the given major minor number.

		SystemVersion major: 6 minor: 1 patch: 199
	"

	^self major: major minor: minor patch: patch suffix: ''! !

!SystemVersionTest commentStamp: ''!
SUnit tests for SystemVersion.!
!SystemVersionTest methodsFor: 'utilities' stamp: ''!
checkIsCompatibleWithResultOfVersionMessage: aString
	"Checks whether a string is compatible with the result of the existing #version message who returned 
	   Pharomajor.minor.patch[suffix]
	"
	
	| rx |
	rx := '(Pharo)([0-9]+)[.]([0-9]+)[.]([0-9]+)([a-zA-Z0-9]+)*' asRegex.
	self 
		assert: (rx matches: aString);
		assert: (rx subexpression: 2) equals: 'Pharo';
		assert: (rx subexpression: 3) asNumber > 0;
		assert: (rx subexpression: 4) asNumber >= 0;
		assert: (rx subexpression: 5) asNumber >= 0! !

!SystemVersionTest methodsFor: 'tests - compatibility' stamp: ''!
testSmalltalkVersionEqualsCurrentVersion
	"TODO: This one might be yellow when we still set the suffix with build nr and hash from the outside."
	
	self assert: Smalltalk version equals: SystemVersion current version! !

!SystemVersionTest methodsFor: 'tests' stamp: ''!
testMajorMinorWithSeparatingString 
	
	self assert: ((SystemVersion fromVersionString: 'RPharo3.7+alpha') majorMinorPatch: '-') equals: '3-7-0'.
	self assert: ((SystemVersion fromVersionString: 'Pharo1.0+ALPHA') majorMinorPatch: '') equals: '100'.
	self assert: ((SystemVersion fromVersionString: 'Pharo1.1') majorMinorPatch: '.') equals: '1.1.0'.
	self assert: ((SystemVersion fromVersionString: 'Pharo1.1.7') majorMinorPatch: '.') equals: '1.1.7'! !

!SystemVersionTest methodsFor: 'tests - parsing' stamp: ''!
testParsingFromVersionString
	"Test that each of the keys are parsable and return a printString giving as value of the associations"

	{'RPharo3.7+alpha' 		  -> 'RPharo-3.7.0+alpha'.
	 'Pharo1.0+ALPHA'  		  -> 'Pharo-1.0.0+ALPHA'.
	 'MyKillerApp-4.0+beta'    -> 'MyKillerApp-4.0.0+beta'.			
	 'Pharo0'           		  -> 'Pharo-0.0.0'.
	 'Pharo5'           		  -> 'Pharo-5.0.0'.
	 'Pharo6.0'         		  -> 'Pharo-6.0.0'.
	 'Pharo6.0.78'         		  -> 'Pharo-6.0.78'.
	 'Pharo-7'          		  -> 'Pharo-7.0.0'.
	 'Pharo-7.0'        		  -> 'Pharo-7.0.0'.
	 'Pharo-7.0.89'        		  -> 'Pharo-7.0.89'.
	 'Pharo-7.0+alpha'  		  -> 'Pharo-7.0.0+alpha'.
	 'Pharo-7.0.89+alpha'  		  -> 'Pharo-7.0.89+alpha'.
	 'Pharo-7.0+alpha.build.0' -> 'Pharo-7.0.0+alpha.build.0'.
	 'Pharo-7.0+alpha.build.2' -> 'Pharo-7.0.0+alpha.build.2'.
	 'Pharo-7.0.89+alpha.build.2' -> 'Pharo-7.0.89+alpha.build.2'.
	 'Pharo-7.0+alpha.build.2.sha.368dcda1b1ba81215fb7355cfc1e901d45395bd8' -> 'Pharo-7.0.0+alpha.build.2.sha.368dcda1b1ba81215fb7355cfc1e901d45395bd8'.
	 'Pharo-7.0.89+alpha.build.2.sha.368dcda1b1ba81215fb7355cfc1e901d45395bd8' -> 'Pharo-7.0.89+alpha.build.2.sha.368dcda1b1ba81215fb7355cfc1e901d45395bd8'.
	  } 
	do: [:each | self assert: ((SystemVersion fromVersionString: each key) printString beginsWith: each value) ]! !

!SystemVersionTest methodsFor: 'tests - instance creation' stamp: ''!
testInstanceCreationMajorMinorSuffixBuildCommitHash

	| version |
	version := (SystemVersion major: 7 minor: 0 patch: 199 suffix: 'alpha' build: 148 commitHash: '368dcda1b1ba81215fb7355cfc1e901d45395bd8').
	self 
		assert: version type equals: 'Pharo';	
		assert: version major equals: 7;
		assert: version minor equals: 0;
		assert: version patch equals: 199;
		assert: version suffix equals: 'alpha';
		assert: version build equals: 148;
		assert: version commitHash equals: '368dcda1b1ba81215fb7355cfc1e901d45395bd8';
		assert: version commitHashShort equals: '368dcda';
		assert: version date notNil; 	
		assert: (version printString beginsWith: 'Pharo-7.0.199+alpha.build.148.sha.368dcda1b1ba81215fb7355cfc1e901d45395bd8')! !

!SystemVersionTest methodsFor: 'tests' stamp: ''!
testSystemVersion

	self assert: SystemVersion current notNil! !

!SystemVersionTest methodsFor: 'tests - instance creation' stamp: ''!
testInstanceCreationMajorMinorSuffixBuild

	| version |
	version := SystemVersion
		major: 7
		minor: 0
		patch: 199
		suffix: 'alpha'
		build: 142.
	self
		assert: version type equals: 'Pharo';
		assert: version major equals: 7;
		assert: version minor equals: 0;
		assert: version patch equals: 199;
		assert: version suffix equals: 'alpha';
		assert: version build equals: 142;
		assertEmpty: version commitHash;
		assertEmpty: version commitHashShort;
		assert: version date notNil;
		assert: (version printString beginsWith: 'Pharo-7.0.199+alpha.build.142')! !

!SystemVersionTest methodsFor: 'tests - instance creation' stamp: ''!
testInstanceCreation

	| version |
	version := SystemVersion new.
	self
		assert: version type equals: 'Pharo';
		assert: version major equals: 0;
		assert: version minor equals: 0;
		assertEmpty: version suffix;
		assert: version build equals: SystemVersion invalidBuildNumber;
		assertEmpty: version commitHash;
		assertEmpty: version commitHashShort;
		assertEmpty: version commitHashShort;
		assert: version date notNil;
		assert: (version printString beginsWith: 'Pharo-0.0')! !

!SystemVersionTest methodsFor: 'tests - instance creation' stamp: ''!
testInstanceCreationMajorMinorSuffixBuildWithoutSuffix

	| version |
	version := SystemVersion
		major: 7
		minor: 0
		patch: 199
		suffix: ''
		build: 142.
	self
		assert: version type equals: 'Pharo';
		assert: version major equals: 7;
		assert: version minor equals: 0;
		assert: version patch equals: 199;
		assertEmpty: version suffix;
		assert: version build equals: 142;
		assertEmpty: version commitHash;
		assertEmpty: version commitHashShort;
		assert: version date notNil;
		assert: (version printString beginsWith: 'Pharo-7.0.199+build.142')! !

!SystemVersionTest methodsFor: 'tests' stamp: ''!
testMajorMinorVersion 
	 	
	self assert: (SystemVersion fromVersionString: 'RPharo3.7+alpha') majorMinorVersion equals: 'RPharo3.7.0'.
	self assert: (SystemVersion fromVersionString: 'Pharo1.0+ALPHA') majorMinorVersion equals: 'Pharo1.0.0'.
	self assert: (SystemVersion fromVersionString: 'Pharo1.1') majorMinorVersion equals: 'Pharo1.1.0'.
	self assert: (SystemVersion fromVersionString: 'Pharo1.1.7') majorMinorVersion equals: 'Pharo1.1.7'! !

!SystemVersionTest methodsFor: 'tests' stamp: ''!
testVersion
	"Check that the #version method returns without a $- between Pharo and the major number."

	| version |
	version := SystemVersion fromVersionString: 'Pharo-7.0+alpha.build.2.sha.368dcda1b1ba81215fb7355cfc1e901d45395bd8'.
	self assert: version version equals: 'Pharo7.0.0alpha'! !

!SystemVersionTest methodsFor: 'tests' stamp: ''!
testCalculationOfHighestUpdate

	self assert: (SystemVersion fromVersionString: 'Pharo-6.0+alpha.build.510') highestUpdate equals: 60510 ! !

!SystemVersionTest methodsFor: 'tests' stamp: ''!
testCommitHashShort

	| version |
	version := SystemVersion fromVersionString: 'Pharo-7.0+alpha.build.2.sha.368dcda1b1ba81215fb7355cfc1e901d45395bd8'.
	self assert: version commitHashShort equals: '368dcda'! !

!SystemVersionTest methodsFor: 'tests - instance creation' stamp: ''!
testInstanceCreationMajorMinorSuffix

	| version |
	version := SystemVersion
		major: 7
		minor: 0
		patch: 199
		suffix: 'alpha'.
	self
		assert: version type equals: 'Pharo';
		assert: version major equals: 7;
		assert: version minor equals: 0;
		assert: version patch equals: 199;
		assert: version suffix equals: 'alpha';
		assert: version build equals: SystemVersion invalidBuildNumber;
		assertEmpty: version commitHash;
		assertEmpty: version commitHashShort;
		assert: version date notNil;
		assert: (version printString beginsWith: 'Pharo-7.0.199+alpha')! !

!SystemVersionTest methodsFor: 'tests - compatibility' stamp: ''!
testDoNotBreakSmalltalkVersion
	"TODO: This one might be yellow when we still set the suffix with build nr and hash from the outside."
	
	self checkIsCompatibleWithResultOfVersionMessage: Smalltalk version! !

!SystemVersionTest methodsFor: 'tests' stamp: ''!
testDottedMajorMinorPatch 
	 
	self assert: (SystemVersion fromVersionString: 'RPharo3.7+alpha') dottedMajorMinorPatch equals: '3.7.0'.
	self assert: (SystemVersion fromVersionString: 'Pharo1.0+ALPHA') dottedMajorMinorPatch equals: '1.0.0'.
	self assert: (SystemVersion fromVersionString: 'Pharo1.1') dottedMajorMinorPatch equals: '1.1.0'! !

!SystemVersionTest methodsFor: 'tests - instance creation' stamp: ''!
testInstanceCreationMajorMinor

	| version |
	version := SystemVersion major: 6 minor: 1 patch: 199.
	self
		assert: version type equals: 'Pharo';
		assert: version major equals: 6;
		assert: version minor equals: 1;
		assert: version patch equals: 199;
		assertEmpty: version suffix;
		assert: version build equals: SystemVersion invalidBuildNumber;
		assertEmpty: version commitHash;
		assertEmpty: version commitHashShort;
		assert: version date notNil;
		assert: (version printString beginsWith: 'Pharo-6.1.199')! !

!SystemVersionTest methodsFor: 'tests - compatibility' stamp: ''!
testVersionIsCompatible
	"Test that the result of the #version method follows the historic pattern (e.g. Pharo7.0alpha)
	 and is not broken"
	 
	self checkIsCompatibleWithResultOfVersionMessage: (SystemVersion major: 7 minor: 0 patch: 199 suffix: 'alpha' build: 148) version! !

!SystemWindow commentStamp: ''!
SystemWindow is the Morphic equivalent of StandardSystemView -- a labelled container for rectangular views, with iconic facilities for close, collapse/expand, and resizing.

The attribute onlyActiveOnTop, if set to true (and any call to activate will set this), determines that only the top member of a collection of such windows on the screen shall be active.  To be not active means that a mouse click in any region will only result in bringing the window to the top and then making it active.!
!SystemWindow methodsFor: 'keymapping' stamp: ''!
closeWindowAction
"closed by a shortcut action. 
 subclasses may overwrite this to do a different action (for example, cancel edits)"
	self close! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
deleteCloseBox
	closeBox ifNotNil:
		[closeBox delete.
		closeBox := nil]! !

!SystemWindow methodsFor: 'testing' stamp: ''!
isCloseable
	^ self mustNotClose not and: [ model ifNotNil: [ model okToChange ] ifNil: [ true ] ]! !

!SystemWindow methodsFor: 'menu building' stamp: ''!
fallbackMenuOn: menu
	"Build the menu that is put up if something is going wrong with the menubuilder"
	
	menu
		addToggle: 'Close' translated
		target: self
		selector: #closeBoxHit
		getStateSelector: nil
		enablementSelector: #allowedToClose.
	menu lastItem icon: self theme windowCloseForm.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
playMaximizeSound
	"Play the themed sound for maximizing."
	
	self theme windowMaximizeSound play! !

!SystemWindow methodsFor: 'open/close' stamp: ''!
toggleClosable
	"Reinstate the close box. Go via theme to maintain box order."
	
	mustNotClose 
	ifTrue: [ self makeClosable ]
	ifFalse: [ self makeUnclosable ]! !

!SystemWindow methodsFor: 'controls' stamp: ''!
isResizeable: aBoolean

	aBoolean = isResizeable ifTrue: [ ^ self ].
	aBoolean
		ifTrue: [ self beResizeable ]
		ifFalse: [ self beUnresizeable ]! !

!SystemWindow methodsFor: 'label' stamp: ''!
setLabelFont: aFont

	label ifNil: [^ self].
	label font: aFont.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
beWithoutGrips
	"Remove the grips and set a property to
	indicate that grips are not wanted."

	self setProperty: #noGrips toValue: true.
	self removeGrips! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
isMaximized
	"Answer whether we are maximised."

	^self unexpandedFrame notNil! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
removeBoxes
	"Remove all label area boxes."

	closeBox ifNotNil: [closeBox delete. closeBox := nil].
	menuBox ifNotNil: [menuBox delete. menuBox := nil].
	expandBox ifNotNil: [expandBox delete. expandBox := nil].
	collapseBox ifNotNil: [collapseBox delete. collapseBox := nil]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
layoutChanged
	"No need to propagate to the world.
	Fixed to always flush layout cache."

	(self owner isNil or: [self owner isWorldMorph not])
		ifTrue: [^super layoutChanged].
	fullBounds := nil.
	self layoutPolicy ifNotNil: [:layout | layout flushLayoutCache]! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarButtonClicked
	"The taskbar button for the receiver has been clicked.
	If minimised then restore.
	If active then minimize.
	Otherwise make active."

	self isMinimized
		ifTrue: [self restore]
		ifFalse: [self isActive
					ifTrue: [self minimize]
					ifFalse: [self activate]]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
allowedToClose
	"Answer whether the window is currently allowed to close."

	^self mustNotClose not and: [
		self modalChild isNil]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
playCloseSound
	"Play the themed sound for closing."
	
	self theme windowCloseSound play! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
createMenuBox
	"Answer a button for the window menu."
	
	^self theme createMenuBoxFor: self! !

!SystemWindow methodsFor: 'modal-windows' stamp: ''!
modalLockTo: aSystemWindow
	"Lock the receiver as a modal owner of the given window."

	aSystemWindow setProperty: #modalOwner toValue: self.
	self setProperty: #modalChild toValue: aSystemWindow.
	
	closeBox ifNotNil: [ 
		self setProperty: #preModalCloseEnabled toValue: closeBox enabled.
		closeBox enabled: false
	].! !

!SystemWindow methodsFor: 'geometry' stamp: ''!
paneMorphs
	"Nominally private but a need for obtaining this from the outside arose"
	
	^ paneMorphs! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
hasExpandBox
	"Answer whether the receiver currently has an expand box."

	^expandBox notNil! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
restoreAndActivate
	"Restore the window if minimised then activate."

	self isMinimized
		ifTrue: [self restore].
	self isActive
		ifFalse: [self activate]! !

!SystemWindow methodsFor: 'open/close' stamp: ''!
delete
	"Should activate window before asking model if okToChange
	since likely that a confirmation dialog will be requested.
	Don't if not owned by the world though."

	"in case we add some panes and reopen!!"
	self isCloseable
		ifFalse: [ ^ self ].
	self deleteDiscardingChanges! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarButtonEntered: aButton event: evt in: aMorph
	"The mouse has entered out taskbar button.
	Show a thumbnail."

	aButton owner ifNotNil: [:buttonBar | |thumb|
		buttonBar showWindowPreview ifFalse: [^self].
		thumb := self valueOfProperty: #taskbarThumbnail.
		thumb
			ifNil: [thumb := self theme newTaskbarThumbnailIn: self for: self]
			ifNotNil: [^self].
		self setProperty: #taskbarThumbnail toValue: thumb.
		thumb bottomLeft: ((aButton left min: aButton owner right - thumb width)@ (aButton owner top - 4)).
		thumb openInWorld]! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
boxExtent
	"answer the extent to use in all the buttons.  
	The label height is used to be proportional to the standard window label font"
	
	label ifNil: [^(14 @ 14) * self displayScaleFactor].
	^ (((14 @ 14) * self displayScaleFactor) max: label height @ label height)! !

!SystemWindow methodsFor: 'controls' stamp: ''!
isResizeable
	"Answer whether we are not we can be resized."

	^ isResizeable ifNil: [ isResizeable := self defaultIsResizeable ]! !

!SystemWindow methodsFor: 'top window' stamp: ''!
updatePanesFromSubmorphs
	"Having removed some submorphs, make sure this is reflected in my paneMorphs."
	paneMorphs := paneMorphs select: [ :pane | submorphs includes: pane ].! !

!SystemWindow methodsFor: 'layout' stamp: ''!
layoutBounds
	"Bounds of pane area only."
	| box |

	box := super layoutBounds.
	^box withTop: box top + self labelHeight! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
fullscreen
	"Zoom Window to Full World size with possible DeskMargins"
	"SystemWindow fullscreen"

	self bounds: self fullscreenBounds! !

!SystemWindow methodsFor: 'controls' stamp: ''!
defaultIsResizeable

	^ true! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
minimizeAfterGeneratingThumbnail
	"Minimize the window after thumbnail generation."
	
	self isMinimized ifTrue: [^self].
	isCollapsed := true.
	paneMorphs
		do: [:m | m delete; releaseCachedState].
	self setBoundsWithFlex: (-10 @ -10 extent: 2 @ 2).
	self hide.
	self layoutChanged! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
getBoundsWithFlex
	"Return the lastest bounds rectangle with origin forced to global coordinates"

	^ self isFlexed
		ifTrue: [ (owner transform localPointToGlobal: bounds topLeft) extent: bounds extent ]
		ifFalse: [ self bounds ]! !

!SystemWindow methodsFor: 'activation' stamp: ''!
navigateFocus

	self rememberedKeyboardFocus
		ifNil: [self navigateFocusForward]
		ifNotNil: [ :keyboardFocus |
			keyboardFocus world
				"ifNil: [self rememberKeyboardFocus: nil]" "deleted"
				ifNotNil: [
					keyboardFocus wantsKeyboardFocus
						ifTrue: [keyboardFocus takeKeyboardFocus]
						ifFalse: [self navigateFocusForward]
					]
		].! !

!SystemWindow methodsFor: 'geometry' stamp: ''!
setPaneRectsFromBounds
	"Reset proportional specs from actual bounds, eg, after reframing panes"
	| layoutBounds |
	layoutBounds := self layoutBounds.
	paneMorphs do:[:m| | frame right top box bottom left |
		frame := m layoutFrame.
		box := m bounds.
		frame ifNotNil:[
			left := box left - layoutBounds left - (frame leftOffset ifNil:[0]).
			right := box right - layoutBounds left - (frame rightOffset ifNil:[0]).
			top := box top - layoutBounds top - (frame topOffset ifNil:[0]).
			bottom := box bottom - layoutBounds top - (frame bottomOffset ifNil:[0]).
			frame leftFraction: (left / layoutBounds width asFloat).
			frame rightFraction: (right / layoutBounds width asFloat).
			frame topFraction: (top / layoutBounds height asFloat).
			frame bottomFraction: (bottom / layoutBounds height asFloat).
		].
	].! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ #raised.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
inactiveLabelFillStyle
	"Return the inactive label fillStyle for the receiver."
	
	^self theme windowInactiveLabelFillStyleFor: self! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
makeClosable
	"Reinstate the close box. Go via theme to maintain box order."
	
	mustNotClose := false.
	closeBox
		ifNil: [closeBox := self createCloseBox.
				self replaceBoxes]! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
maximumExtent: aPoint
	"This returns the maximum extent that the morph may be expanded to.
	Return nil if this property has not been set."

	^ self setProperty: #maximumExtent toValue: aPoint! !

!SystemWindow methodsFor: 'events' stamp: ''!
handlesMouseDown: evt 
	"If I am not the topWindow, then I will only respond to dragging by the title bar.
	Any other click will only bring me to the top"
	
	^ self isEmbedded not! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
menuBox
	"Answer the receiver's menu box."

	^menuBox! !

!SystemWindow methodsFor: 'settings' stamp: ''!
fullscreenMargin
	^ self class fullscreenMargin! !

!SystemWindow methodsFor: 'activation' stamp: ''!
beTopWindow
	
	| oldTopWindow |
	
	oldTopWindow := TopWindow.
	TopWindow := self.
	
	oldTopWindow ifNotNil: [ oldTopWindow privateBePassive ].
	
	self announceActivated.! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
restoreBeforeGeneratingThumbnail
	"Restore the window without activating unlocking or stepping."
	
	self isMinimized ifFalse: [^self].
	isCollapsed := false.
	self show.
	self setBoundsWithFlex: fullFrame.
	paneMorphs reverseDo: [:m | 
		self addMorph: m].
	self layoutChanged! !

!SystemWindow methodsFor: 'layout' stamp: ''!
putLabelItemsInLabelArea
	"Put label items into the label area, if there is one"

	labelArea ifNotNil:
		[stripes ifNotNil: [stripes do: [:stripe | labelArea addMorph: stripe]].
		closeBox ifNotNil: [labelArea addMorph: closeBox].
		menuBox ifNotNil: [labelArea addMorph: menuBox].
		collapseBox ifNotNil: [labelArea addMorph: collapseBox].
		label ifNotNil: [labelArea addMorph: label]]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
setLabelWidgetAllowance
	"Set the extra space required, in general, apart from the label.
	Should make theme based (for centered titles), leave enough room
	for the moment."
	
	^labelWidgetAllowance :=  (self boxExtent x * 7) 
	"allow for three on one side and centering plus a bit"! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
expand
	self isCollapsed ifTrue:[self collapseOrExpand].! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
keyDown: evt
	"Check for close window."
	super keyDown: evt.
	(self navigationKey: evt) ifTrue: [^true].
	^false! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
previousMorphInWindow
	"Answer the previous morph in the window. This will be the
	last submorph recursively of the first pane morph."

	^self hasSubmorphs
		ifTrue: [self lastSubmorphRecursive]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
removeLabelArea
	"Remove the entire label area."

	self removeGrips.
	labelArea delete.
	label := nil.	
	(self isCollapsed not or: [self isTaskbarPresent]) ifTrue: [
		self addGripsIfWanted]! !

!SystemWindow methodsFor: 'panes' stamp: ''!
updatablePanes
	"Answer the list of panes, in order, which should be sent the #verifyContents message"
	^ updatablePanes ifNil: [updatablePanes := #()]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
labelHeight
	"Answer the height for the window label.  The standard behavior is at bottom; a hook is provided so that models can stipulate other heights, in support of various less-window-looking demos.
	If no label answer the class border width instead."

	label ifNil: [^self isEmbedded ifTrue: [0] ifFalse: [self class borderWidth]].
	^(label height + (self class borderWidth * 2)) max:
		(collapseBox ifNotNil: [collapseBox height] ifNil: [10])! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
changeColor
	"Change the color of the receiver -- triggered, e.g. from a menu.  This variant allows the recolor triggered from the window's halo recolor handle to have the same result as choosing change-window-color from the window-title menu"
	self setWindowColor! !

!SystemWindow methodsFor: 'open/close' stamp: ''!
positionSubmorphs
	"Feels like overkill, but effect needed"
	super positionSubmorphs.
	self submorphsDo:
		[:aMorph | aMorph positionSubmorphs]! !

!SystemWindow methodsFor: 'events' stamp: ''!
mouseMove: evt
	"Handle a mouse-move event"

	self basicIsSticky ifFalse:[
		self fastFramingOn 
			ifTrue: [self doFastFrameDrag: evt startPoint ]
			ifFalse: [ self grabSelfOrTopRenderer: evt	]
	].! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
wantsExpandBox
	"Answer whether I'd like an expand box"

	^ true! !

!SystemWindow methodsFor: 'menu building' stamp: ''!
discoveredMenuPragmaKeyword

	^ 'windowMenu'.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
animateMaximize
	"Animate maximizing from restored."
	
	|expandedRect restoredRect rects steps|
	expandedRect := self fullscreenBounds.
	restoredRect := self bounds.
	steps := self theme numberOfStepsForAnimations.
	rects := (1/steps to: 1 by: 1/steps) collect: [:x |
		restoredRect interpolateTo: expandedRect at: (20 raisedTo: x) - 1 / 19].
	self fastAnimateRectangles: rects! !

!SystemWindow methodsFor: 'events' stamp: ''!
handlesMouseOverDragging: evt
	^true! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
fullscreenBounds
	"Answer the bounds that the receiver would take if expanded to fullscreen."
	
	^ (RealEstateAgent maximumUsableAreaInWorld: self world) insetBy: self fullscreenMargin! !

!SystemWindow methodsFor: 'controls' stamp: ''!
beResizeable

	isResizeable := true.
	
	"If isResizable is overriden to always return false, then it would break the invariant"
	self isResizeable ifTrue: [ self addGripsIfWanted ]! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
createWindowGroup
	| group pos ext |
	pos := self position.
	ext := self extent.
	group := GroupWindowMorph new.
	group addWindow: self.
	(group openInWindowLabeled: 'Group: ' translated , self label)
		extent: ext;
		position: pos;
		model: group! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
hasCollapseBox
	"Answer whether the receiver currently has a collapse box."

	^collapseBox notNil! !

!SystemWindow methodsFor: 'opening' stamp: ''!
preOpenInWorld: aWorld
	"This msg and its callees result in the window being activeOnlyOnTop"
	self bounds: (RealEstateAgent
		initialFrameFor: self
		initialExtent: self initialExtent
		world: aWorld).
	self playOpenSound.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
initializeLabelArea
	"Initialize the label area (titlebar) for the window."
	
	label := self theme windowLabelFor: self.
	"Add default inital boxes"
	collapseBox := self createCollapseBox. "Add collapse box so #labelHeight will work"
	closeBox := self createCloseBox.
	self wantsExpandBox ifTrue: [
		expandBox := self createExpandBox.
		self setExpandBoxBalloonText].
	menuBox := self createMenuBox.
	stripes := Array
						with: (Morph newBounds: bounds)
						with: (Morph newBounds: bounds).
	self addLabelArea.
	labelArea
		goBehind.
	self replaceBoxes.
	labelArea fillStyle: self activeTitleFillStyle.! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu"
	^ false! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
linkSplittersToSplitters
	"The pane morphs are already linked. Cross link the splitters as appropriate."
	
	self splitters do: [:each |
		each splitsTopAndBottom
			ifTrue: [self splitters do: [:eachMorph |
					eachMorph splitsTopAndBottom ~= each splitsTopAndBottom ifTrue: [
						eachMorph layoutFrame bottomFraction = each layoutFrame topFraction
							ifTrue: [each addLeftOrTop: eachMorph].
						eachMorph layoutFrame topFraction = each layoutFrame bottomFraction
							ifTrue: [each addRightOrBottom: eachMorph]]]]
			ifFalse: [self splitters do: [:eachMorph |
					eachMorph splitsTopAndBottom ~= each splitsTopAndBottom ifTrue: [
						eachMorph layoutFrame rightFraction = each layoutFrame leftFraction
							ifTrue: [each addLeftOrTop: eachMorph].
						eachMorph layoutFrame leftFraction = each layoutFrame rightFraction
							ifTrue: [each addRightOrBottom: eachMorph]]]]]! !

!SystemWindow methodsFor: 'events' stamp: ''!
mouseDown: evt
	"Changed to properly process the mouse down event if passing to
	submorphs."
		
	self isEmbedded ifTrue: [^self].
	
	self isTopWindow
		ifTrue: [self comeToFront] "rise above non-window morphs"
		ifFalse:[	self activate].

	evt hand waitForClicksOrDrag: self event: evt.  "allow double-click/drag response"
	
	evt wasHandled: false.
	self submorphsDo: [ :morph | "but allow a submorph to process and override double-click/drag response."
		(morph containsPoint: evt cursorPoint) ifTrue: [ morph processEvent: evt ]
	].
	evt wasHandled: true.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
handlesKeyboard: evt
	"Return true if the receiver wishes to handle the given keyboard event"

	(super handlesKeyboard: evt) ifTrue: [^true].
	^evt anyModifierKeyPressed and: [
		evt keyCharacter = Character arrowLeft or: [
		evt keyCharacter = Character arrowRight or: [
		evt keyCharacter = Character delete or: [
		evt keyCharacter = $w or: [
		evt keyCharacter = Character tab ]]]]]! !

!SystemWindow methodsFor: 'stepping' stamp: ''!
wantsStepsWhenCollapsed
	"Default is not to bother updating collapsed windows"

	^ false! !

!SystemWindow methodsFor: 'events' stamp: ''!
grabSelfOrTopRenderer: evt

	| renderer |
	
	renderer := self topRendererOrSelf.

	evt hand grabMorph: renderer.
	
	(renderer isKindOf: SystemWindow) ifTrue: [ 
		renderer position: evt hand position + (renderer position - evt startPoint)
	]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
aboutText
	"Answer the text to use for the About dialog."

	^self model
		ifNil: ['This is a system window without a model' translated]
		ifNotNil: [self model class instanceSide organization classComment
					ifEmpty: ['The model of this window has no class comment']
					ifNotEmpty: [:comment | comment]]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addExpandBox
	"If I have a labelArea, add a close box to it"
	labelArea
		ifNil: [^ self].
	expandBox := self createExpandBox.
	self setExpandBoxBalloonText.
	expandBox layoutFrame: (LayoutFrame new leftFraction: 1; leftOffset: (self boxExtent x * 2 + 3) negated).
	labelArea addMorphBack: expandBox! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addPaneVSplitters
	"Add the vertical pane splitters."

	|remaining targetRight sameRight sameLeft |
	remaining := paneMorphs reject: [:each |
			each layoutFrame rightFraction = 1 or: [
				each layoutFrame rightFraction = 0]].
	[remaining notEmpty] whileTrue: [
		targetRight := remaining first layoutFrame rightFraction.
		sameRight := remaining select: [:each |
			each layoutFrame rightFraction = targetRight].
		sameLeft := paneMorphs select: [:each |
			each layoutFrame leftFraction = targetRight and: [
				each layoutFrame rightFraction ~= targetRight]].
		remaining := remaining
			copyWithoutAll: (self addPaneVSplitterBetween: sameRight and: sameLeft)]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
makeBordered
	"Add the border and border width offsets."

	|b|
	self borderWidth = 0 ifFalse: [^self].
	b  := self class borderWidth.
	self submorphsDo: [:m | | l |
		l := m layoutFrame.
		l ifNotNil: [
			l rightFraction = 1 ifTrue: [l rightOffset: l rightOffset - b].
			l leftFraction = 0 ifTrue: [l leftOffset: l leftOffset + b].
			l bottomFraction = 1 ifTrue: [l bottomOffset: l bottomOffset - b]]].
	self theme configureWindowBorderFor: self! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
restore
	"Restore the receiver's normal size."

	self isMinimized
		ifTrue: [self collapseBoxHit]
		ifFalse: [self isMaximized ifTrue: [self expandBoxHit]]! !

!SystemWindow methodsFor: 'geometry' stamp: ''!
labelRect
	^ self innerBounds withHeight: self labelHeight.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
minimize
	"Minimise the receiver."

	self isMinimized ifFalse: [self collapseBoxHit]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
getRawLabel
	"Answer a shallowCopy of the label with the contents fitted."
	
	|contentsFit|
	contentsFit := label shallowCopy fitContents.
	contentsFit extent: (label extent x min: contentsFit extent x) @ contentsFit extent y.
	^contentsFit! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
paneColor

	"Answer the basic pane color that should be used."
	
	^self theme paneColorFor: self! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
fillStyleToUse
	"Answer the basic fill style for the receiver."

	^self isActive 
		ifTrue: [self activeFillStyle] 
		ifFalse: [self inactiveFillStyle]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
handlesDropShadowInHand
	"Answer whether the receiver will handle drop shadow drawing when picked up in the hand."

	^self theme handlesWindowDropShadowInHandFor: self! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
showAbout

	self theme  
		longMessageIn: self
		text: self aboutText
		title: self aboutTitle! !

!SystemWindow methodsFor: 'panes' stamp: ''!
addMorph: aMorph frame: rectangle
	
	^ self addMorph: aMorph fullFrame: rectangle! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
sendToBack
    "Relies on #submorphs array being ordered top to bottom."
	| otherSystemWindows |
	otherSystemWindows := self world submorphs select: [ :morph | morph isSystemWindow and: morph ~~ self ].
	otherSystemWindows ifNotEmpty: 
	[	otherSystemWindows first activate.
		self world addMorph: self behind: otherSystemWindows last. 
	].! !

!SystemWindow methodsFor: 'testing' stamp: ''!
canBeMaximized
	"Answer whether we are not we can be maximised."

	^ self isResizeable and: [ self isNotMaximized ]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
activeFillStyle
	"Return the active fillStyle for the receiver."
	
	^self theme windowActiveFillStyleFor: self! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
setWindowColor: incomingColor
	"Removed existing color check - looked useless!!"
	
	| aColor |
	incomingColor ifNil: [^ self].  "it happens"
	aColor := incomingColor.
	self setProperty: #paneColor toValue: aColor.
	self setStripeColorsFrom: aColor.
	self theme fadedBackgroundWindows 
		ifFalse: [self adoptPaneColor: aColor]. "reverse optimisation"
	self changed.! !

!SystemWindow methodsFor: 'label' stamp: ''!
labelWidgetAllowance
	^ labelWidgetAllowance ifNil: [self setLabelWidgetAllowance]! !

!SystemWindow methodsFor: 'panes' stamp: ''!
existingPaneColor
	"Answer the existing pane color for the window, obtaining it from the first paneMorph if any, and fall back on using the second stripe color if necessary."

	| aColor |
	aColor := self valueOfProperty: #paneColor.
	aColor ifNil: [self setProperty: #paneColor toValue: (aColor := self paneColor)].
	^aColor.! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarCloseAllLikeThis

	(SystemWindow allSubInstances select: [ :w | w labelString = self labelString]) do: [ :w | w delete ].! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
maximumExtent
	"This returns the maximum extent that the morph may be expanded to.
	Return nil if this property has not been set."

	^ self valueOfProperty: #maximumExtent! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
createExpandBox
	"Answer a button for maximising/restoring the window."
	
	^self theme createExpandBoxFor: self! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
theme
	"Answer the ui theme that provides controls.
	Don't call super since that implementation may delegate here."

	(self valueOfProperty: #theme) ifNotNil: [:t | ^ t].
	^self class theme! !

!SystemWindow methodsFor: 'label' stamp: ''!
externalName
	"Answer the name by which the receiver is known in the UI"

	^ labelString! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
labelString

	"Answer the actual label string."

	^ label ifNil: [ labelString ] ifNotNil: [ label contents asString ]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
collapsedFrame
	^ collapsedFrame! !

!SystemWindow methodsFor: 'open/close' stamp: ''!
mustNotClose
	^ mustNotClose == true! !

!SystemWindow methodsFor: 'events' stamp: ''!
doFastFrameDrag: grabPoint
	"Do fast frame dragging from the given point"

	(FastDraggingFrameMorph forDragging: self clickedAt: grabPoint) openInWorld! !

!SystemWindow methodsFor: 'events' stamp: ''!
mouseUp: evt
	| cp |
	cp := evt cursorPoint.
	submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseUp: evt]]! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ self theme backgroundColor! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addGripsIfWanted
	"Add the edge and corner grips if the window wants them."
	
	self wantsGrips ifTrue: [self addGrips]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
unexpandedFrame
	"Return the frame size of an unexpanded window"

	^ self valueOfProperty: #unexpandedFrame! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
preferredCornerStyle
	"Answer the preferred corner style."

	^self theme windowPreferredCornerStyleFor: self! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
addLabelArea

	labelArea :=self theme newWindowHeaderFor: self.
	self addMorph: labelArea.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
doubleClick: event
	"Handle a double click. Maximize/restore the window.
	Works in title bar area."

	self isResizeable ifFalse: [ ^ self ].
	
	(labelArea containsPoint: event position)
		ifTrue: [self expandBoxHit]! !

!SystemWindow methodsFor: 'panes' stamp: ''!
restoreDefaultPaneColor
	"Useful when changing from monochrome to color display"

	self setStripeColorsFrom: self paneColor.! !

!SystemWindow methodsFor: 'events' stamp: ''!
mouseEnterDragging: evt
	"unlock children for drop operations"
	(self isTopWindow not and:[evt hand hasSubmorphs]) ifTrue:[
		self submorphsDo:[:m| m unlock].
		evt hand addMouseListener: self. "for drop completion on submorph"
	].! !

!SystemWindow methodsFor: 'opening' stamp: ''!
postOpenInWorld: aWorld

	self activate.
	super postOpenInWorld: aWorld! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
justDroppedInto: aMorph event: anEvent
	"Release the mouse focus as well."
	
	isCollapsed
		ifTrue: [
			self position: ((self position max: 0@0) grid: 8@8).
			collapsedFrame := self bounds
		]
		ifFalse: [
			fullFrame := self bounds.
			self isTopWindow ifFalse: [self activate]
		].
	
	anEvent hand releaseMouseFocus.
	
	^super justDroppedInto: aMorph event: anEvent! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarButtonFor: aTaskbar
	"Answer a new task bar button for the receiver.
	Answer nil if not required."

	^aTaskbar theme
		newTaskbarButtonIn: aTaskbar
		for: self! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
doFastWindowReframe: aSideOrCornerName
	"Do fast frame resizing  from the given corner or side"

	(FastDraggingFrameMorph forResizing: self fromLocation: aSideOrCornerName) openInWorld! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
playRestoreUpSound
	"Play the themed sound for restoring from minimized."
	
	self theme windowRestoreUpSound play! !

!SystemWindow methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream. 
	label ifNotNil: [ aStream nextPutAll: ' named: ', self labelString  ]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
activeLabelFillStyle
	"Return the active label fillStyle for the receiver."
	
	^self theme windowActiveLabelFillStyleFor: self! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addMenuControl
	"If I have a label area, add a menu control to it."

	labelArea ifNil: [^ self]. "No menu if no label area"
	menuBox
		ifNotNil: [menuBox delete].
	labelArea addMorphBack: (menuBox := self createMenuBox)! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
gradientWithColor: aColor

	| ramp |
	ramp := {0.0 -> Color white. 1.0 -> aColor}.

	^ (GradientFillStyle ramp: ramp)
		radial: true;
		origin: self bounds origin;
		direction: 0 @ 223;
		normal: 223 @ 0.! !

!SystemWindow methodsFor: 'thumbnail' stamp: ''!
icon
	"Answer a form with an icon to represent the receiver"

	^ self iconNamed: #windowIcon! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
setWindowColor
	"Allow the user to select a new basic color for the window"

	(UIManager default chooseColor: self paneColor)
		ifNotNil: [:nc | self setWindowColor: nc].! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
isEmbedded
	"Answer whether the receiver is embedded, i.e.
	has an owner that is not the world or the hand."

	^self owner isNotNil and: [self owner ~= self world and: [self owner ~= self activeHand]]! !

!SystemWindow methodsFor: 'panes' stamp: ''!
replacePane: oldPane with: newPane
	"Make newPane exactly occupy the position and extent of oldPane"

	| aLayoutFrame hadDep |
	hadDep := model dependents includes: oldPane.
	oldPane owner replaceSubmorph: oldPane by: newPane.
	newPane
		position: oldPane position;
		extent: oldPane extent.
	aLayoutFrame := oldPane layoutFrame.
	paneMorphs := paneMorphs collect:
		[:each |
		each == oldPane ifTrue: [newPane] ifFalse: [each]].
	aLayoutFrame ifNotNil: [newPane layoutFrame: aLayoutFrame].
	newPane color: Color transparent.
	hadDep ifTrue: [model removeDependent: oldPane. model addDependent: newPane].

	self changed! !

!SystemWindow methodsFor: 'activation' stamp: ''!
positionModalOwner

	self modalOwner ifNotNil: [ :modalOwner |
		(modalOwner isKindOf: SystemWindow) ifTrue: [ 
			modalOwner bringBehind: self.
		]
   ]! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarButtonLeft: aButton event: evt in: aMorph
	"The mouse has left our taskbar button.
	Remove our thumbnail."

	self
		valueOfProperty: #taskbarThumbnail
		ifPresentDo: [:thumb |
			thumb delete.
			self removeProperty: #taskbarThumbnail]! !

!SystemWindow methodsFor: 'modal-windows' stamp: ''!
modalOwner
	"Answer the modal owner of the receiver, if any."

	^self valueOfProperty: #modalOwner! !

!SystemWindow methodsFor: 'geometry' stamp: ''!
removeMenuBox
	menuBox ifNotNil:
		[menuBox delete.
		menuBox := nil].! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
isNotMaximized
	"Answer whether we are not maximised."

	^self unexpandedFrame isNil! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
setFramesForLabelArea
	"Set the layout for the label area."
	
	self theme configureWindowLabelAreaFrameFor: self! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarCloseAllToLeft
	| wasFound |
	wasFound := false.
	self worldTaskbar ifNotNil: [ :worldTaskbar |
		worldTaskbar orderedTasks copy do: [ :task | 
			(task morph == self) ifTrue: [ ^ self ].
			task morph delete ] ].! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
isTaskbarPresent
	"Answer whether there is a taskbar in the world."

	^self worldTaskbar notNil! !

!SystemWindow methodsFor: 'drawing' stamp: ''!
scrollBarColor
	^self paneColor! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
closeBoxHit
	"The user clicked on the close-box control in the window title.
	For Mac users only, the Mac convention of option-click-on-close-box is obeyed if the mac option key is down.
	If we have a modal child then don't delete.
	Play the close sound now since this is the only time we know that the close is user-initiated."

	self allowedToClose ifFalse: [^self].
	self playCloseSound.
	self close! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addMorph: aMorph fullFrame: aLayoutFrame
	"Add a morph to the receiver with the given layout frame."
	
	| left right bottom top windowBorderWidth frame |
	frame := aLayoutFrame asLayoutFrame.
	windowBorderWidth := self class borderWidth.

	left := frame leftOffset.
	right := frame rightOffset.

	bottom := frame bottomOffset.
	top := frame topOffset.
	
	frame rightFraction = 1 ifTrue: [frame rightOffset: right - windowBorderWidth - self theme windowRightOffset].
	frame leftFraction = 0
		ifTrue: [frame leftOffset: left + windowBorderWidth + self theme windowLeftOffset]
		ifFalse: [frame leftFraction = 1 ifFalse: [
					frame leftOffset: left + ProportionalSplitterMorph splitterWidth]].

	frame bottomFraction = 1 ifTrue: [frame bottomOffset: bottom - windowBorderWidth - self theme windowBottomOffset].
	frame topFraction = 0
		ifTrue: [frame topOffset: top+ self theme windowTopOffset]
		ifFalse: [frame topFraction = 1 ifFalse: [
					frame topOffset: top + ProportionalSplitterMorph splitterWidth]].
	
	super addMorph: aMorph fullFrame: frame.

	paneMorphs := paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph).
	"aMorph adoptPaneColor: self paneColor."
	aMorph
		borderStyle: (self theme windowPaneBorderStyleFor: aMorph in: self).
	self addMorphBack: aMorph. "reorder panes so flop-out right-side scrollbar is visible"
		
	self owner ifNotNil: [self addPaneSplitters] "do when opened for performance"! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
collapseOrExpand
	"Collapse or expand the window, depending on existing state.
	Use the taskbar if present, otherwise do as normal."
	
	| cf |
	self isTaskbarPresent ifTrue: [^self minimizeOrRestore].
	isCollapsed
		ifTrue: 
			["Expand -- restore panes to morphics structure"
			isCollapsed := false.
			self activate.  "Bring to frint first"
			collapsedFrame := self getBoundsWithFlex.
			collapseBox ifNotNil: [collapseBox setBalloonText: 'Collapse this window'].
			self setBoundsWithFlex: fullFrame.
			paneMorphs reverseDo: 
					[:m |  self addMorph: m unlock.
					self world startSteppingSubmorphsOf: m].
			self
				addPaneSplitters;
				addGripsIfWanted]
		ifFalse: 
			["Collapse -- remove panes from morphics structure"
			isCollapsed := true.
			fullFrame := self getBoundsWithFlex.
			"First save latest fullFrame"
			paneMorphs do: [:m | m delete; releaseCachedState].
			self removePaneSplitters.
			self removeGrips.
			cf := self getCollapsedFrame.
			collapsedFrame ifNil: [collapsedFrame := cf].
			self setBoundsWithFlex: cf.
			collapseBox ifNotNil: [collapseBox setBalloonText: 'expand this window'].
			expandBox ifNotNil: [expandBox setBalloonText: 'expand to full screen']].
	self layoutChanged.
	
	"This gets invoked only if the taskbar is not present, if it is, then minimizeOrRestore is invoked (cf beginning of this method)"
	self announce: 
		(WindowCollapsed new
			window: self;
			yourself).! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
basicTaskThumbnailOfSize: thumbExtent
	"Answer a new task thumbnail for the receiver."
	
	^super taskThumbnailOfSize: thumbExtent! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
addCloseBox
	"If I have a labelArea, add a close box to it"
	| frame |
	labelArea
		ifNil: [^ self].
	closeBox := self createCloseBox.
	frame := LayoutFrame identity leftOffset: 2.
	closeBox layoutFrame: frame.
	labelArea addMorphBack: closeBox! !

!SystemWindow methodsFor: 'accessing' stamp: ''!
embeddable
	^ embeddable ifNil: [embeddable := false]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
removeCollapseBox
	"Remove the collapse box."

	collapseBox ifNotNil: [collapseBox delete. collapseBox := nil]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
replaceBoxes
	"Rebuild the various boxes."
	
	labelArea removeAllMorphs.
	self setLabelWidgetAllowance.
	self theme configureWindowLabelAreaFor: self.
	self setFramesForLabelArea.
	self isActive ifFalse: [labelArea passivate]! !

!SystemWindow methodsFor: 'stepping' stamp: ''!
stepAt: millisecondClockValue
	"If the receiver is not collapsed, step it, after first stepping the model."

	(isCollapsed not or: [self wantsStepsWhenCollapsed]) ifTrue:
		[model ifNotNil: [model stepAt: millisecondClockValue in: self].
		super stepAt: millisecondClockValue "let player, if any, step"]

"Since this method ends up calling step, the model-stepping logic should not be duplicated there."! !

!SystemWindow methodsFor: 'testing' stamp: ''!
wantsToBeCachedByHand
	"Return true if the receiver wants to be cached by the hand when it is dragged around."

	self isTranslucentButNotTransparent
		ifTrue: [ ^ false ].
	self clipSubmorphs
		ifTrue: [ ^ true ].
	self bounds = self fullBounds
		ifTrue: [ ^ true ].
	self
		submorphsDo: [ :m | 
			(self bounds containsRect: m fullBounds)
				ifFalse: [ 
					m wantsToBeCachedByHand
						ifFalse: [ ^ false ] ] ].
	^ true! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
model: anObject
	"Set the model."
	
	super model: anObject.
	self paneColorTracksModel ifTrue: [
		self
			setProperty: #paneColor toValue: self defaultBackgroundColor;
			fillStyle: self fillStyleToUse;
			setStripeColorsFrom: self paneColorToUse.
		self theme fadedBackgroundWindows ifFalse: [ "since not done in stripes"
			self adoptPaneColor: self paneColor]].
	self minimumExtent: (
		(anObject respondsTo: #minimumExtent)
			ifTrue: [anObject minimumExtent]).
	menuBox ifNotNil: [
		menuBox
			labelGraphic: (self theme windowMenuIconFor: self);
			height: self boxExtent y]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
navigationKey: event
	"Check for tab key activity and change focus as appropriate.
	Check for menu key to do popup.
	Check for active window naviagation."

	(self world navigationKey: event) ifTrue: [^true].
	(self tabKey: event) ifTrue: [^true].
	(event keyCharacter = Character escape and: [
			event anyModifierKeyPressed]) ifTrue: [
		^ self yellowButtonActivity: false].
	^false! !

!SystemWindow methodsFor: 'panes' stamp: ''!
paneColorToUse
	^ Display depth <= 2
		ifTrue:
			[Color white]
		ifFalse:
			[self paneColor]! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
applyModelExtent
	self extent: model initialExtent! !

!SystemWindow methodsFor: 'controls' stamp: ''!
buildWindowMenu
  
	^ self menu.! !

!SystemWindow methodsFor: 'activation' stamp: ''!
basicActivate
	"Bring me to the front and make me able to respond to mouse and keyboard."

	| outerMorph |
	
	outerMorph := self topRendererOrSelf.
	outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"].
	self isTopWindow ifTrue: [^self].
	
	self beTopWindow.
	
	outerMorph owner firstSubmorph == outerMorph
		ifFalse: ["Bring me (with any flex) to the top if not already"
				outerMorph owner addMorphFront: outerMorph
		].
			
	self submorphsDo: [:m | m unlock].
	
	labelArea ifNotNil: [
		labelArea submorphsDo: [:m | m unlock].
		self setStripeColorsFrom: self paneColorToUse
	].

	self isCollapsed ifFalse: [ 
		model modelWakeUpIn: self.
		self positionSubmorphs.
		labelArea ifNil: [ self adjustBorderUponActivationWhenLabeless ]
	].

	self privateFullBounds: nil; changed "ensure fullBounds computed for active drop shadow"! !

!SystemWindow methodsFor: 'geometry' stamp: ''!
position: newPos
	| oldPos |
	isCollapsed
		ifTrue: [ oldPos := collapsedFrame origin ]
		ifFalse: [ oldPos := fullFrame origin ].

	super position: newPos.
	isCollapsed
		ifTrue: [collapsedFrame := self bounds]
		ifFalse: [fullFrame := self bounds].

	(oldPos ~= newPos)
		ifTrue: [ self announce: 
					(WindowMoved new 
						oldPosition: oldPos;
						newPosition: newPos;
						window: self)]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
makeBorderless
	"Remove the border and border width offsets.."

	|b|
	b  := self class borderWidth.
	self submorphsDo: [:m | | l |
		l := m layoutFrame.
		l ifNotNil: [
			l rightFraction = 1 ifTrue: [l rightOffset: l rightOffset + b].
			l leftFraction = 0 ifTrue: [l leftOffset: l leftOffset - b].
			l bottomFraction = 1 ifTrue: [l bottomOffset: l bottomOffset + b]]].
	self borderWidth: 0! !

!SystemWindow methodsFor: 'panes' stamp: ''!
setUpdatablePanesFrom: getSelectors
	| aList possibles |
	"Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors.  Order is important here!!  Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case"
	aList := OrderedCollection new.
	possibles := OrderedCollection new.
	self
		allMorphsDo: [ :pane | 
			(pane isKindOf: PluggableListMorph)
				ifTrue: [ possibles add: pane ] ].
	getSelectors
		do: [ :sel | possibles detect: [ :pane | pane getListSelector == sel ] ifFound: [ :aPane | aList add: aPane ] ].
	updatablePanes := aList asArray! !

!SystemWindow methodsFor: 'panes' stamp: ''!
updatePaneColors
	"Useful when changing from monochrome to color display"

	self setStripeColorsFrom: self paneColorToUse.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
activeTitleFillStyle
	"Return the active title fillStyle for the receiver."
	
	^self theme windowActiveTitleFillStyleFor: self! !

!SystemWindow methodsFor: 'top window' stamp: ''!
isTopWindow

	^self == TopWindow! !

!SystemWindow methodsFor: 'controls' stamp: ''!
beUnresizeable

	isResizeable := false.
	
	"If isResizable is overriden to always return true, then it would break the invariant"
	self isResizeable ifFalse: [ self removeGrips ]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
isNotRestored
	"Answer whether we are maximised or minimised."

	^self isMinimized or: [self isMaximized]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addCollapseBox
	"If I have a labelArea, add a collapse box to it."
	
	labelArea
		ifNil: [^ self].
	collapseBox := self createCollapseBox.
	collapseBox layoutFrame: (self theme windowCollapseBoxLayoutFor: self).
	labelArea addMorphBack: collapseBox! !

!SystemWindow methodsFor: 'testing' stamp: ''!
isSystemWindow
"answer whatever the receiver is a SystemWindow"
	^ true! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
fastFramingOn

	^self theme settings fastDragging and: [self isFlexed not]! !

!SystemWindow methodsFor: 'activation' stamp: ''!
privateBePassive
	"private"
	self isInWorld ifFalse: [ ^self ].
	
	self 
	rememberKeyboardFocus: self activeHand keyboardFocus;
	passivate;
	announceDeActivated! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
isActive
	"Answer active if no owner too to avoid color flickering."
	
	^self isWindowActive: self! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
labelArea
	"Answer the label area."

	^labelArea! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
navigateFocusForward
	"Change the keyboard focus to the next morph or the receiver
	in none are interested."

	self nextMorphWantingFocus
		ifNil: [self takeKeyboardFocus]
		ifNotNil: [super navigateFocusForward]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
collapseBoxHit
	"The user has clicked on the collapse box.
	Collapse or expand the receiver as appropriate."
	
	self isCollapsed
		ifTrue: [self playRestoreUpSound]
		ifFalse: [self playMinimizeSound].
	self collapseOrExpand! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
removeEdgeGrips
	"Remove the window edge grips."
	
	|edges|
	edges := self submorphsSatisfying: [:each | each isKindOf: WindowEdgeGripMorph].
	edges do: [:each | each delete]! !

!SystemWindow methodsFor: 'testing' stamp: ''!
shouldDropOnMouseUp
	"Return true for consistency with fastdrag"
	^true! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarLabel
	"Answer the label to use for a taskbar button for the receiver."

	self model ifNotNil: [self model taskbarLabel ifNotNil: [:str | ^str]].
	^self labelString! !

!SystemWindow methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
stWindowsFor: aStep
	<stSpotterOrder: 100>

	aStep listProcessor
			title: 'Windows';
			allCandidates: [ self class allSubInstances ];
			itemName: [ :window | '**', window label, '**' ];
			filter: StFilterSubstring! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
"template..."
	aCustomMenu addLine.
	aCustomMenu add: 'Edit label...' selector: #relabel.! !

!SystemWindow methodsFor: 'api' stamp: ''!
menu

	^(PragmaMenuBuilder 
		pragmaKeyword: self discoveredMenuPragmaKeyword 
		model: self) menu! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
createBox
	"create a button with default to be used in the label area"
	"Transcript show: self paneColor asString;  
	cr."
	| box |
	box := IconicButtonMorph new.
	box color: Color transparent;
		 target: self;
		 useSquareCorners;
		 borderWidth: 0.

	^ box! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
createCollapseBox
	"Answer a button for minimising the window."
	
	^self theme createCollapseBoxFor: self! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
collapse
	self isCollapsed ifFalse:[self collapseOrExpand].! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
worldTaskbar
	"Answer the world taskbar or nil if none."

	^self world ifNotNil: [ :world | 
		world 
		submorphThat: [ :morph | morph isTaskbar ] 
		ifNone: [ nil ]
	]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
unexpandedFrame: aRectangle
	"Set the frame size of an unexpanded window"

	^ self setProperty: #unexpandedFrame toValue: aRectangle! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
reframePanesAdjoining: growingPane along: side to: aDisplayBox 
	| delta newRect minDim theMin horiz |
	growingPane ifNil: [^ self].  "As from click outside"
	newRect := aDisplayBox.
	horiz := #(left right) includes: side.
	theMin := horiz ifTrue: [40] ifFalse: [20].

	"First check that this won't make any pane smaller than theMin screen dots"
	minDim := (((paneMorphs select: [:pane | pane bounds bordersOn: growingPane bounds along: side])
		collect: [:pane | pane bounds adjustTo: newRect along: side]) copyWith: aDisplayBox)
			inject: 999 into:
				[:was :rect | was min: (horiz ifTrue: [rect width] ifFalse: [rect height])].
	"If so, amend newRect as required"
	minDim > theMin ifFalse:
		[delta := minDim - theMin.
		newRect := newRect withSide: side setTo: 
				((newRect perform: side) > (growingPane bounds perform: side)
					ifTrue: [(newRect perform: side) + delta]
					ifFalse: [(newRect perform: side) - delta])].

	"Now adjust all adjoining panes for real"
	paneMorphs do:
		[:pane | (pane bounds bordersOn: growingPane bounds along: side) ifTrue:
			[pane bounds: (pane bounds adjustTo: newRect along: side)]].
	"And adjust the growing pane itself"
	growingPane bounds: newRect.

	"Finally force a recomposition of the whole window"
	self setPaneRectsFromBounds.
	self extent: self extent! !

!SystemWindow methodsFor: 'top window' stamp: ''!
adjustBorderUponActivationWhenLabeless
	"Adjust the border upon, um, activation when, um, labelless"

	| aWidth |
	(aWidth := self valueOfProperty: #borderWidthWhenActive) ifNotNil:
		[self acquireBorderWidth: aWidth]! !

!SystemWindow methodsFor: 'testing' stamp: ''!
isDisplayed
	" Answer true if I am currently displayed in the World"
	
	^ self world notNil! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
getCollapsedFrame

	^RealEstateAgent assignCollapseFrameFor: self.! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
minimizeOrRestore
	"Collapse or expand the window, depending on existing state"
	
	|mc windowEvent |
	isCollapsed
		ifTrue: ["Expand -- restore panes to morphics structure"
			self theme shouldUseAnimations 
				ifTrue: [self animateRestoreFromMinimized].
			isCollapsed := false.
			"Bring to front first"
			self
				setBoundsWithFlex: fullFrame;
				comeToFront;
				show.
			mc := self modalChild.
			paneMorphs reverseDo: [:m | 
				mc ifNil: [m unlock].
				self addMorph: m.
				self world startSteppingSubmorphsOf: m].
			self activate]
		ifFalse: ["Collapse -- remove panes from morphics structure"
			isCollapsed := true.
			fullFrame := self getBoundsWithFlex.
			"First save latest fullFrame"
			paneMorphs
				do: [:m | m delete; releaseCachedState].
			self
				setBoundsWithFlex: (-100 @ -100 extent: 2 @ 2); "place offscreen"
				hide.
			self theme shouldUseAnimations  
				ifTrue: [self animateMinimize].
			self isActive ifTrue: [
				self world navigateVisibleWindowForward]].
	self layoutChanged.
	
	"This gets invoked only if the taskbar is present, see sender of minimizeOrRestore"
	windowEvent := 
		self isMinimized 
			ifTrue: [ WindowCollapsed new ]
			ifFalse: [ WindowExpanded new ].

	windowEvent window: self.
	self announce: windowEvent.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
inactiveFillStyle
	"Return the active fillStyle for the receiver."
	
	^self theme windowInactiveFillStyleFor: self! !

!SystemWindow methodsFor: 'announcement' stamp: ''!
announceDeActivated

	self announce: (
		WindowDeActivated new 
			window: self; 
			yourself
	).! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
setStripeColorsFrom: paneColor 
	"Set the stripe color based on the given paneColor.
	Removed box color update for Pharo compatability."

	stripes ifNil: [^self].
	self fillStyle: self fillStyleToUse.
	self isActive 
		ifTrue: [label ifNotNil: [label color: self activeLabelFillStyle].
				labelArea fillStyle: self activeTitleFillStyle] 
		ifFalse: [label ifNotNil: [label color: self inactiveLabelFillStyle].
				labelArea fillStyle: self inactiveTitleFillStyle].
	self adoptPaneColor: self paneColor! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarThumbnailExtent
	"Answer the size of a taskbar thumbnail for the receiver."

	^self isMinimized
		ifTrue: [self fullFrame extent min: self defaultTaskbarThumbnailExtent]
		ifFalse: [super taskbarThumbnailExtent]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
playMinimizeSound
	"Play the themed sound for maximizing."
	
	self theme windowMinimizeSound play! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarState
	"Answer one of #minimized, #restored, #maximized or #active."

	^self isMinimized
		ifTrue: [#minimized]
		ifFalse: [self isMaximized
			ifTrue: [#maximized]
			ifFalse: [self isActive
						ifTrue: [#active]
						ifFalse: [#restored]]]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
animateRestore
	"Animate restoring from maximised."
	
	|expandedRect restoredRect rects steps|
	expandedRect := self bounds.
	restoredRect := self unexpandedFrame.
	steps := self theme numberOfStepsForAnimations.
	rects := ((steps - 1)/steps to: 0 by: -1/steps) collect: [:x |
		restoredRect interpolateTo: expandedRect at: (20 raisedTo: x) - 1 / 19].
	self fastAnimateRectangles: rects! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
paneColorTracksModel
	"Answer true if the colour of the window should be taken from the model."
	
	^true! !

!SystemWindow methodsFor: 'drawing' stamp: ''!
raisedColor
	^self paneColor raisedColor! !

!SystemWindow methodsFor: 'stepping' stamp: ''!
stepTime
	^ model
		ifNotNil: [model stepTimeIn: self]
		ifNil: [200] "milliseconds"! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
beWithGrips
	"Add the grips and set a property to
	indicate that grips are wanted."

	self removeProperty: #noGrips.
	(self isCollapsed not or: [self isTaskbarPresent]) ifTrue: [
		self addGripsIfWanted]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
hasMenuBox
	"Answer whether the receiver currently has a menu box."

	^menuBox notNil! !

!SystemWindow methodsFor: '*NewTools-Spotter-Extensions' stamp: ''!
stActDefault

	^ self isTopWindow
		ifTrue: [ self comeToFront ] "rise above non-window morphs"
		ifFalse:[ self activate ]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
fullFrame
	^ fullFrame! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
createCloseBox
	"Answer a button for closing the window."
	
	^self theme createCloseBoxFor: self! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
configureForEmbedding
	"Set up the window so it can be embedded into another morph."

	labelArea owner notNil ifTrue: [
		self
			hasDropShadow: false;
			beWithoutGrips;
			removeLabelArea;
			makeBorderless.
		self submorphsDo: [:m | m unlock]]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
indicateModalChild
	"Make the user aware that this is the topmost modal child
	by flashing."

	(self isMinimized and: [self isTaskbarPresent])
		ifTrue: [self worldTaskbar ifNotNil: [:tb |
					tb indicateModalChildForMorph: self]]
		ifFalse: [self flash]! !

!SystemWindow methodsFor: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher 
	"Where we may attach keymaps or even on:do: local shortcuts if needed."

	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #WindowShortcuts! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
isNotMinimized
	"Answer whether we are not minimised."

	^self isCollapsed not! !

!SystemWindow methodsFor: 'label' stamp: ''!
widthOfFullLabelText
	^StandardFonts windowTitleFont widthOfString: labelString! !

!SystemWindow methodsFor: '*Morphic-Widgets-Windows' stamp: ''!
openModal: aSystemWindow
	"Open the given window locking the receiver until it is dismissed.
	Answer the system window.
	Restore the original keyboard focus when closed."

	| keyboardFocus |
	
	keyboardFocus := self activeHand keyboardFocus.
	self modalLockTo: aSystemWindow.
	[ aSystemWindow openModal ] ensure: [
		self modalUnlockFrom: aSystemWindow.
		self activeHand newKeyboardFocus: keyboardFocus ].
	^aSystemWindow! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
basicIsSticky
	"Answer the super isSticky."

	^super isSticky! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
setExpandBoxBalloonText
	"Set the expand box balloon help text as appropriate."

	expandBox ifNil: [^self].
	self unexpandedFrame
		ifNil: [expandBox setBalloonText: 'Expand to full screen' translated]
		ifNotNil: [expandBox setBalloonText: 'Contract to original size' translated]! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarCloseAllToRight
	| wasFound |
	wasFound := false.
	self worldTaskbar ifNotNil: [ :worldTaskbar |
		worldTaskbar orderedTasks copy do: [ :task | 
			wasFound 
				ifTrue:  [ task morph delete ] 
				ifFalse: [ wasFound := task morph == self ].
			]. 
		].! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
nextMorphInWindow
	"Answer the next morph in the window. Traverse
	from the receiver to its first pane."

	^self hasSubmorphs
		ifTrue: [self submorphs first]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
maximize
	"Maximise the receiver. If collapsed the uncollapse first."

	self isMinimized ifTrue: [self collapseOrExpand].
	self isMaximized ifFalse: [self expandBoxHit]! !

!SystemWindow methodsFor: 'accessing' stamp: ''!
embeddable: aBoolean
	embeddable := aBoolean! !

!SystemWindow methodsFor: 'announcement' stamp: ''!
announceActivated

	self announce: (
		WindowActivated new 
			window: self; 
			yourself
	).! !

!SystemWindow methodsFor: 'geometry' stamp: ''!
panelRect
	"Answer the area below the title bar which is devoted to panes."

	^ self innerBounds insetBy: (0 @ self labelHeight corner: 0 @ 0)! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
passivate
	"Make me unable to respond to mouse and keyboard"

	super passivate.
	self setStripeColorsFrom: self paneColorToUse.
	self isEmbedded ifTrue: [^self].
	"Control boxes remain active, except in novice mode"
	self lockInactivePortions.
	labelArea ifNil: "i.e. label area is nil, so we're titleless"
		[self adjustBorderUponDeactivationWhenLabeless]! !

!SystemWindow methodsFor: 'label' stamp: ''!
copyTitle
	Clipboard clipboardText: self label.
	self inform: 'Window title copied.'! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
isMinimized
	"Answer whether we are minimised."

	^self isCollapsed! !

!SystemWindow methodsFor: 'stepping' stamp: ''!
amendSteppingStatus
	"Circumstances having changed, find out whether stepping is wanted and assure that the new policy is carried out"

	self wantsSteps
		ifTrue:
			[self arrangeToStartStepping]
		ifFalse:
			[self stopStepping]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
nextMorphAcrossInWindow
	"Answer the next morph in the window. Traverse
	from the receiver to its next sibling or owner's next sibling etc.
	Make sure we behave like a normal Morph, if we aren't a toplevel window ( or not visible) "

	^ (self owner notNil and: [ self owner isWorldMorph ])
		ifTrue: [ self ]
		ifFalse: [ super nextMorphAcrossInWindow ]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
paneWithLongestSide: sideBlock near: aPoint 
	| thePane theSide theLen |
	theLen := 0.
	paneMorphs do:
		[:pane | | box | box := pane bounds.
		box forPoint: aPoint closestSideDistLen:
			[:side :dist :len |
			(dist <= 5 and: [len > theLen]) ifTrue:
				[thePane := pane.
				theSide := side.
				theLen := len]]].
	sideBlock value: theSide.
	^ thePane! !

!SystemWindow methodsFor: 'compatibility' stamp: ''!
hasUnacceptedEdits 

	^ (self submorphs select: [:e | e respondsTo: #hasUnacceptedEdits ]) anySatisfy: [:e | e hasUnacceptedEdits ]! !

!SystemWindow methodsFor: 'events' stamp: ''!
handleListenEvent: evt
	"Make sure we lock our contents after DnD has finished"
	evt isMouse ifFalse:[^self].
	evt hand hasSubmorphs ifTrue:[^self]. "still dragging"
	self isTopWindow ifFalse:[self lockInactivePortions].
	evt hand removeMouseListener: self.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
themeChanged
	"Update the window colour and control boxes."

	self labelArea delete.
	self removeGrips.
	self theme
		configureWindowBorderFor: self;
		configureWindowDropShadowFor: self.
	self paneColor: self defaultBackgroundColor.
	label ifNotNil: [ "don't if label area removed"
		self initializeLabelArea].
	self setStripeColorsFrom: self paneColor.
	(self isCollapsed not or: [self isTaskbarPresent]) ifTrue: [
		self addGripsIfWanted].
	
	self isEmbedded ifTrue: [ self borderWidth: 0 ].
	
	super themeChanged! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
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! !

!SystemWindow methodsFor: 'announcement' stamp: ''!
announce: anAnnouncement
	"announcer is lazy initialized. If announcer is not set, this means that there is no listener, no need to propagate the announcement therefore"
	self doAnnounce: anAnnouncement! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
isRestored
	"Answer whether we are neither expanded or collapsed."

	^(self isMinimized or: [self isMaximized]) not! !

!SystemWindow methodsFor: 'panes' stamp: ''!
paneMorphSatisfying: aBlock
	^ paneMorphs detect: aBlock ifNone: [ nil ]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
animateMinimize
	"Animate minimizing."
	
	|tb buttonRect restoredRect rects steps|
	tb := self worldTaskbar ifNil: [^self].
	buttonRect := ((tb taskButtonOf: self) ifNil: [^self]) bounds.
	restoredRect := self isFlexed
		ifTrue: [(owner transform
					globalPointToLocal: fullFrame topLeft)
					extent: fullFrame extent]
		ifFalse: [fullFrame].
	steps := self theme numberOfStepsForAnimations.
	rects := ((steps - 1)/steps to: 0 by: -1/steps) collect: [:x |
		buttonRect interpolateTo: restoredRect at: (20 raisedTo: x) - 1 / 19].
	self fastAnimateRectangles: rects! !

!SystemWindow methodsFor: 'activation' stamp: ''!
activate
	"Activate the owner too."
	
	self activatedModalChild ifTrue: [ ^self ].
	
	self addPaneSplittersIfNeeded.
		
	super activate.
	
	self isEmbedded ifFalse: [
		self basicActivate
	].	
	
	self navigateFocus.
	
	self positionModalOwner.! !

!SystemWindow methodsFor: 'label' stamp: ''!
label
	^ labelString! !

!SystemWindow methodsFor: 'icons' stamp: ''!
taskbarIcon
	"Answer the icon for the receiver in a task bar."

	self model ifNotNil: [self model taskbarIcon ifNotNil: [:ico | ^ico]].
	^super taskbarIcon! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
wantsGrips
	"Answer whether the window wants edge and corner grips."
	
	^self isResizeable! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
fastAnimateRectangles: rects
	"Animate the given rectangles using the fast method."
	
	|delay col merged|
	rects ifEmpty: [^self].
	delay := Delay forMilliseconds: (self theme animationSettings delay).
	col := Color gray alpha: 0.5.
	merged := rects first.
	rects withIndexDo: [:r :i |
		Display
			border: r rounded
			width: 1
			rule: Form blend
			fillColor: col.
		merged := merged merge: r.
		delay wait].
	merged := merged expandBy: 1.
	self currentWorld invalidRect: merged from: self! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
paneColorOrNil
	"Answer the window's pane color or nil otherwise."

	^self paneColor! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
drawDropShadowOn: aCanvas
	"Get the theme to draw the drop shawdow for the receiver."
	
	|dropAreas|
	dropAreas := self areasRemainingToFill: (self bounds expandBy: self shadowMargins).
	(dropAreas anySatisfy: [:rect | aCanvas isVisible: rect])
		ifFalse: [^self]. "no need to draw since no intersection"
	self isActive
		ifTrue: [self theme
					drawWindowActiveDropShadowFor: self
					on: aCanvas]
		ifFalse: [self theme
					drawWindowInactiveDropShadowFor: self
					on: aCanvas]! !

!SystemWindow methodsFor: 'open/close' stamp: ''!
initialExtent
	^ (self model respondsTo: #initialExtent)
		ifTrue: [self model initialExtent]
		ifFalse: [ self extent ]! !

!SystemWindow methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize a system window. Add label, stripes, etc., if desired"
	
	super initialize.
	labelString ifNil: [labelString := 'Untitled Window'].
	isCollapsed := false.
	paneMorphs := Array new.
	self layoutPolicy: ProportionalLayout new.
	self clipSubmorphs: true.
	self theme
		configureWindowBorderFor: self;
		configureWindowDropShadowFor: self.	
	self initializeLabelArea.

	self cellPositioning: #topLeft. "make the offsets easy to calculate!!"
	self addGripsIfWanted.
	
	self extent: (300 @ 200) scaledByDisplayScaleFactor.
	mustNotClose := false.
	updatablePanes := Array new! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarTask
	"Answer a new taskbar task for the receiver.
	Answer nil if not required."

	(self valueOfProperty: #noTaskbarTask ifAbsent: [false]) ifTrue: [^nil].
	^TaskbarTask
		morph: self
		state: self taskbarState
		icon: self taskbarIcon
		label: self taskbarLabel! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
window
	"Answer the receiver's window."

	^self! !

!SystemWindow methodsFor: 'top window' stamp: ''!
adjustBorderUponDeactivationWhenLabeless
	"Adjust the border upon deactivation when, labelless"

	| aWidth |
	(aWidth := self valueOfProperty: #borderWidthWhenInactive) ifNotNil:
		[self acquireBorderWidth: aWidth]! !

!SystemWindow methodsFor: 'announcement' stamp: ''!
announceOpened

	super announceOpened.
	self currentWorld announcer
		announce: (WindowOpened new
						window: self;
						yourself).! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
rememberedKeyboardFocus
	"Answer the remembered keyboard focus for the receiver."
	
	^self valueOfProperty: #rememberedFocus! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
removeExpandBox
	"Remove the expand box."

	expandBox ifNotNil: [expandBox delete. expandBox := nil]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addCornerGrips
	"Should add these to the front!!"
	
	|tl tr lh|
	lh := self labelHeight.
	tl  := TopLeftGripMorph new target: self; position: self position.
	tl layoutFrame topOffset: lh negated.
	tr  := TopRightGripMorph new target: self; position: self position.
	tr layoutFrame topOffset: lh negated.
	self
		addMorph: tl;
		addMorph: tr;
		addMorph: (BottomLeftGripMorph new target: self;position: self position);
		addMorph: (BottomRightGripMorph new target: self;position: self position)! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
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 ;
									topOffset: offset;
									rightOffset: rightFrame rightOffset;
									bottomOffset: 4 + offset).
	topGroup := topGroup, fixed.
	topGroup do: [:m | splitter addLeftOrTop: m].
	bottomGroup do: [:m | splitter addRightOrBottom: m].
	self addMorphBack: splitter.
	^topGroup! !

!SystemWindow methodsFor: 'events' stamp: ''!
wantsHalo
	^ false! !

!SystemWindow methodsFor: 'modal-windows' stamp: ''!
modalUnlockFrom: aSystemWindow
	"Unlock the receiver as a modal owner of the given window."

	aSystemWindow removeProperty: #modalOwner.
	self removeProperty: #modalChild.
	closeBox ifNotNil: [:cl | cl enabled: (self valueOfProperty: #preModalCloseEnabled ifAbsent: [true])].
	self removeProperty: #preModalCloseEnabled.
	self activate! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
expandBoxHit
	"The fullscreen expand box has been hit"

	self isCollapsed
		ifTrue: [self playRestoreUpSound.
				self
					hide;
					collapseOrExpand.
				self unexpandedFrame ifNil: [self unexpandedFrame: fullFrame].
				self
					fullscreen;
					setExpandBoxBalloonText.
				^self show].
	self unexpandedFrame
		ifNil: [self playMaximizeSound.
				self theme shouldUseAnimations ifTrue: [self animateMaximize].
				self
					unexpandedFrame: fullFrame;
					fullscreen]
		ifNotNil: [self playRestoreDownSound.
				self theme shouldUseAnimations ifTrue: [self animateRestore].
				self
					bounds: self unexpandedFrame;
					unexpandedFrame: nil].
	self setExpandBoxBalloonText! !

!SystemWindow methodsFor: 'modal-windows' stamp: ''!
modalChild
	"Answer the modal child of the receiver, if any."

	^self valueOfProperty: #modalChild! !

!SystemWindow methodsFor: 'stepping' stamp: ''!
wantsSteps
	"Return true if the model wants its view to be stepped.  For an open system window, we give the model to offer an opinion"

	^ isCollapsed not and: [model wantsStepsIn: self]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
configureForUnembedding

	"Set up the window so it can be unembedded and placed in the world."

	labelArea owner
		ifNil: [ self
				makeBordered;
				initializeLabelArea;
				themeChanged;
				addGrips
			]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
aboutTitle
	"Answer the title to use for the About dialog."

	|title|
	title := self model
		ifNil: ['SystemWindow']
		ifNotNil: [(self model respondsTo: #aboutTitle)
					ifTrue: [self model aboutTitle]
					ifFalse: [self model class name]].
	^'About {1}' translated format: {title}! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
toggleVisibleAndRaise
	"Toggle the visibility of the receiver, bringing to
	the front if becoming visible. Activate or passivate here."

	self isActive ifTrue: [self world navigateVisibleWindowForward].
	super toggleVisibleAndRaise.
	self visible ifTrue: [self activate]! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
makeUnclosable
	mustNotClose := true.
	self deleteCloseBox! !

!SystemWindow methodsFor: 'activation' stamp: ''!
activatedModalChild

	self modalChild ifNotNil: [ :modalChild |
		modalChild owner ifNotNil: [ 
				modalChild activate.
				modalChild modalChild ifNil: [ modalChild indicateModalChild ].
				^true.			
		]
	].
	^false! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
bringBehind: aMorph
	"Make the receiver be directly behind the given morph.
	Take into account any modal owner and propagate."

	|outerMorph|
	outerMorph := self topRendererOrSelf.
	outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"].
	outerMorph owner addMorph: outerMorph after: aMorph topRendererOrSelf.
	self modalOwner ifNotNil: [:mo | mo bringBehind: self]! !

!SystemWindow methodsFor: 'label' stamp: ''!
relabel
	| newLabel |
	newLabel := UIManager default 
		request: 'New title for this window' translated
		initialAnswer: labelString.
	newLabel isEmptyOrNil ifTrue: [^self].
	self setLabel: newLabel! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
resetCollapsedFrame
	"Reset the collapsed frame."

	collapsedFrame := nil! !

!SystemWindow methodsFor: 'top window' stamp: ''!
activateAndForceLabelToShow
	self activate.
	bounds top < 0 ifTrue:
		[self position: (self position x @ 0)]! !

!SystemWindow methodsFor: 'panes' stamp: ''!
paneColor: aColor
	self setProperty: #paneColor toValue: aColor.

	self adoptPaneColor: aColor.! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addEdgeGrips
	"Should add these to the front!!"
	
	|t l r lh|
	lh := self labelHeight.
	t  := WindowEdgeGripMorph new target: self; position: self position; edgeName: #top.
	t layoutFrame
		topOffset: lh negated;
		bottomOffset: lh negated + self class borderWidth.
	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: t;
		addMorph: l;
		addMorph: r;
		addMorph: (WindowEdgeGripMorph new target: self;position: self position; edgeName: #bottom)! !

!SystemWindow methodsFor: 'top window' stamp: ''!
topWindow
	^ self class topWindow! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskThumbnailOfSize: thumbExtent
	"Answer a new task thumbnail for the receiver."
	
	|min thumb|
	min := self isMinimized
		ifTrue: [self restoreBeforeGeneratingThumbnail.
				true]
		ifFalse: [false].
	thumb := self basicTaskThumbnailOfSize: thumbExtent.
	min ifTrue: [self minimizeAfterGeneratingThumbnail].
	^thumb! !

!SystemWindow methodsFor: 'drawing' stamp: ''!
makeMeVisible 

	self world extent > (0@0) ifFalse: [^ self].

	((self world bounds insetBy: (0@0 corner: self labelHeight asPoint))
		containsPoint: self position) ifTrue: [^ self "OK -- at least my top left is visible"].

	"window not on screen (probably due to reframe) -- move it now"
	self isCollapsed
		ifTrue: [self position: (RealEstateAgent assignCollapsePointFor: self)]
		ifFalse: [self position: (RealEstateAgent initialFrameFor: self initialExtent: self extent world: self world) topLeft].! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
animateRestoreFromMinimized
	"Animate restoring from minimised."
	
	|tb buttonRect restoredRect rects steps|
	tb := self worldTaskbar ifNil: [^self].
	buttonRect := ((tb taskButtonOf: self) ifNil: [^self]) bounds.
	restoredRect := self isFlexed
		ifTrue: [(owner transform
					globalPointToLocal: fullFrame topLeft)
					extent: fullFrame extent]
		ifFalse: [fullFrame].
	steps := self theme numberOfStepsForAnimations.
	rects := (1/steps to: 1 by: 1/steps) collect: [:x |
		buttonRect interpolateTo: restoredRect at: (20 raisedTo: x) - 1 / 19].
	self fastAnimateRectangles: rects! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
playRestoreDownSound
	"Play the themed sound for restoring from maximized."
	
	self theme windowRestoreDownSound play! !

!SystemWindow methodsFor: 'accessing' stamp: ''!
embeddedWindowOrNil

	"answer nil for common morphs, yourself from system windows and first submorph for transformation morphs"
	
	^ self! !

!SystemWindow methodsFor: 'label' stamp: ''!
update: aSymbol
	aSymbol = #relabel
		ifTrue: [^ model ifNotNil: [ self setLabel: model labelString ] ].
	aSymbol = #close
		ifTrue: [self delete]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
setBoundsWithFlex: newFrame
	"Set bounds from newFrame with origin preserved from global coordinates"

	self isFlexed
		ifTrue: [super bounds: ((owner transform globalPointToLocal: newFrame topLeft)
										extent: newFrame extent)]
		ifFalse: [super bounds: newFrame].! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
wantsRoundedCorners
	"Answer whether rounded corners are wanted."
	
	^(self theme windowPreferredCornerStyleFor: self) == #rounded! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
basicLabel
	"Answer the actual label morph."

	^label! !

!SystemWindow methodsFor: 'open/close' stamp: ''!
close
	^ self delete! !

!SystemWindow methodsFor: 'drawing' stamp: ''!
colorForInsets
	^self paneColor colorForInsets! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addPaneSplitters
	"Add the vertical and horizontal pane splitters."
	
	self removePaneSplitters.
	self addPaneVSplitters.
	self addPaneHSplitters.
	self linkSplittersToSplitters! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
rememberKeyboardFocus: aMorph
	"Record the current keyboard focus for the receiver."
	
	(aMorph isNil or: [(aMorph hasOwner: self) not]) ifFalse: [
		self setProperty: #rememberedFocus toValue: aMorph]! !

!SystemWindow methodsFor: 'events' stamp: ''!
wantsToBeDroppedInto: aMorph
	"Return true if it's okay to drop the receiver into aMorph"
	^ aMorph isWorldMorph or: [self embeddable]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
removeCloseBox
	"Remove the close box."

	closeBox ifNotNil: [closeBox delete. closeBox := nil]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
animateClose
	"Animate closing."
	
	| smallRect restoredRect rects steps|
	self isMinimized ifTrue: [^self].
	restoredRect := self bounds.
	smallRect := restoredRect scaledAndCenteredIn: (0@0 extent: 20@20).
	smallRect := smallRect align: smallRect center with: restoredRect center.
	steps := self theme numberOfStepsForAnimations.
	rects := ((steps - 1)/steps to: 0 by: -1/steps) collect: [:x |
		smallRect interpolateTo: restoredRect at: (20 raisedTo: x) - 1 / 19].
	self currentWorld displayWorldSafely.
	self fastAnimateRectangles: rects! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
extent: aPoint 
	"Set the receiver's extent to value provided. Respect my minimumExtent."

	| newExtent w oldExtent|
	newExtent := self isCollapsed
		ifTrue: [aPoint max: (self labelWidgetAllowance @ 0)]
		ifFalse: [aPoint max: self minimumExtent].
	newExtent = self extent ifTrue: [^ self].

	oldExtent := self extent.	
	isCollapsed
		ifTrue: [super extent: newExtent x @ self labelHeight]
		ifFalse: [super extent: newExtent].
	isCollapsed
		ifTrue: [collapsedFrame := self bounds]
		ifFalse: [fullFrame := self bounds].
	(self isCollapsed or: [label isNil]) "shrink the label if insufficient space"
		ifFalse: [
				label minWidth: nil.
				label fitContents.

				"Add a tooltip on the label with the full content in case there is not enough space"
				(label width > (bounds width - labelWidgetAllowance))
					ifTrue: [ label setBalloonText: label contents ]
					ifFalse: [ label setBalloonText: nil ].

				w := (label width min: bounds width - labelWidgetAllowance).
				label setWidth: w; minWidth: w.
				label align: label bounds topCenter with: bounds topCenter + (0@borderWidth).
				collapsedFrame ifNotNil:
					[collapsedFrame := collapsedFrame withWidth: label width + labelWidgetAllowance]].
	self theme windowExtentChangedFor: self.

	self announce: (WindowResizing new 
						oldSize: oldExtent; 
						newSize: newExtent; 
						window: self; 
						yourself).! !

!SystemWindow methodsFor: 'activation' stamp: ''!
addPaneSplittersIfNeeded

	(isCollapsed not 
		and: [ self paneMorphs isNotEmpty and: [self splitters isEmpty]])
			ifTrue: [self addPaneSplitters].! !

!SystemWindow methodsFor: 'open/close' stamp: ''!
openModal
	self openInWorld.
	MorphicRenderLoop new doOneCycleWhile: [ self isInWorld ]! !

!SystemWindow methodsFor: 'label' stamp: ''!
setLabel: aString
	| frame announcement |
	labelString := aString.
	announcement := (WindowLabelled new 
						window: self;
						label: aString;
						yourself).
	self announce: announcement.
	self currentWorld announcer announce: announcement.
	label ifNil: [^ self].
	label contents: aString.
	self labelWidgetAllowance.  "Sets it if not already"
	self isCollapsed
		ifTrue: [self extent: (label width + labelWidgetAllowance) @ (self labelHeight + 2)]
		ifFalse: [
				"Add a tooltip on the label with the full content in case there is not enough space"
				(label width > (bounds width - labelWidgetAllowance))
					ifTrue: [ label setBalloonText: label contents ]
					ifFalse: [ label setBalloonText: nil ].

				label fitContents; setWidth: (label width min: bounds width - labelWidgetAllowance).
				label align: label bounds topCenter with: bounds topCenter + (0@borderWidth).
				collapsedFrame ifNotNil:
					[collapsedFrame := collapsedFrame withWidth: label width + labelWidgetAllowance]].
	frame := LayoutFrame new.
	frame leftFraction: 0.5;
		 topFraction: 0.5;
		 leftOffset: label width negated // 2;
		 topOffset: label height negated // 2.
	label layoutFrame: frame.! !

!SystemWindow methodsFor: 'open/close' stamp: ''!
deleteDiscardingChanges
	| thisWorld announcement animateClose |
	animateClose := self visible
		and: [ self world notNil
				and: [ self theme shouldUseAnimations
						and: [ self theme animationSettings animateClosing ] ] ].
	self removePaneSplitters.	"in case we add some panes and reopen!!"
	thisWorld := self world.
	self isFlexed
		ifTrue: [ owner delete ]
		ifFalse: [ super delete ].
	model
		ifNotNil: [ model
				windowIsClosing;
				releaseActionMap ].
	model := nil.
	animateClose
		ifTrue: [ self animateClose ].
	SystemWindow noteTopWindowIn: thisWorld.
	announcement := WindowClosed new
		window: self;
		yourself.
	self announce: announcement.
	self currentWorld announcer announce: announcement! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
hasCloseBox
	"Answer whether the receiver currently has a close box."

	^closeBox notNil! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addGrips
	"Add the edge and corner grips."
	
	self
		addCornerGrips;
		addEdgeGrips! !

!SystemWindow methodsFor: 'resize/collapse' stamp: ''!
isCollapsed
	^ isCollapsed! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
offerWindowMenu
	| aMenu |
	aMenu := self buildWindowMenu.
	model ifNotNil:
		[model addModelItemsToWindowMenu: aMenu].
	aMenu popUpEvent: self currentEvent in: self world! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
lockInactivePortions
	"Make me unable to respond to mouse and keyboard.  Control boxes remain active."

	self isEmbedded ifTrue: [^self].
	self submorphsDo: [:m | m == labelArea ifFalse: [m lock]]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
addPaneHSplitters
	"Add the horizontal pane splitters."

	|remaining targetBottom sameBottom sameTop|
	remaining := paneMorphs reject: [:each |
			each layoutFrame bottomFraction = 1 or: [
				each layoutFrame bottomFraction = 0]].
	[remaining notEmpty] whileTrue: [
		targetBottom := remaining first layoutFrame bottomFraction.
		sameBottom := remaining select: [:each |
			each layoutFrame bottomFraction = targetBottom].
		sameTop := paneMorphs select: [:each |
			each layoutFrame topFraction = targetBottom].
		remaining := remaining
			copyWithoutAll: (self addPaneHSplitterBetween: sameBottom and: sameTop)]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
playOpenSound
	"Play the themed sound for opening."
	
	self theme windowOpenSound play! !

!SystemWindow methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
taskbarButtonMenu: aMenu
	"Answer the menu for the task bar button."

	| menu theme submenu  |
	theme :=  self theme.	
	menu := theme newMenuIn: self for: self.
	
	menu
		addToggle: 'Restore' translated
		target: self
		selector: #restore
		getStateSelector: nil
		enablementSelector: #isNotRestored.
	menu lastItem
		icon: self theme windowMaximizeForm;
		font: theme menuFont.
		
	menu
		addToggle: 'Minimize' translated
		target: self
		selector: #minimize
		getStateSelector: nil
		enablementSelector: #isNotMinimized.
	menu lastItem
		icon: self theme windowMinimizeForm;
		font: theme menuFont.
		
	menu
		addToggle: 'Maximize' translated
		target: self
		selector: #maximize
		getStateSelector: nil
		enablementSelector: #canBeMaximized.
	menu lastItem
		icon: self theme windowMaximizeForm;
		font: theme menuFont.
		
	menu addLine.

	submenu := theme newMenuIn: self for: self.
	menu
		add: 'Close all'
		icon: self theme windowCloseForm
		subMenu: submenu.
	submenu
		addToggle: 'windows to left' translated
		target: self
		selector: #taskbarCloseAllToLeft
		getStateSelector: nil
		enablementSelector: true.
	submenu
		addToggle: 'windows to right' translated
		target: self
		selector: #taskbarCloseAllToRight
		getStateSelector: nil
		enablementSelector: true.
	submenu
		addToggle: 'windows like this' translated
		target: self
		selector: #taskbarCloseAllLikeThis
		getStateSelector: nil
		enablementSelector: true.
	submenu
		addToggle: 'unchanged windows' translated
		target: self currentWorld
		selector: #closeAllUnchangedWindows
		getStateSelector: nil
		enablementSelector: true.
	submenu
		addToggle: 'close all debuggers' translated
		target: OupsDebuggerSystem
		selector: #closeAllDebuggers
		getStateSelector: nil
		enablementSelector: true.

	menu
		addToggle: 'Close' translated
		target: self
		selector: #closeBoxHit
		getStateSelector: nil
		enablementSelector: #allowedToClose.
	menu lastItem
		icon: self theme windowCloseForm;
		font: theme menuFont.

	^menu! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
removeGrips
	"Remove the edge and corner grips."
	
	self
		removeCornerGrips;
		removeEdgeGrips! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
doubleClickTimeout: event
	"Forget the #inactiveDoubleClick property.
	The property is set if an inactive window was double-clicked."
	
 	self removeProperty: #inactiveDoubleClick! !

!SystemWindow methodsFor: 'menu actions' stamp: ''!
makeSecondTopmost
	| aWorld |
	aWorld := self world.
	aWorld submorphs
		detect: [ :m | m isSystemWindow and: [ m ~~ self ] ]
		ifFound: [ :nextWindow | 
			nextWindow activate.
			aWorld addMorph: self behind: nextWindow ]! !

!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: ''!
inactiveTitleFillStyle
	"Return the inactive title fillStyle for the receiver."
	
	^self theme windowInactiveTitleFillStyleFor: self! !

!SystemWindow methodsFor: 'events' stamp: ''!
mouseLeaveDragging: evt
	"lock children after drop operations"
	(self isTopWindow not and:[evt hand hasSubmorphs]) ifTrue:[
		self lockInactivePortions.
		evt hand removeMouseListener: self.
	].! !

!SystemWindow class methodsFor: 'settings' stamp: ''!
fullscreenMargin
	^ FullscreenMargin ifNil: [FullscreenMargin := 0]! !

!SystemWindow class methodsFor: 'top window' stamp: ''!
windowsIn: aWorld satisfying: windowBlock
	| windows |

	windows := OrderedCollection new.
	aWorld ifNil: [^windows].	"opening MVC in Morphic - WOW!!"
	aWorld 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! !

!SystemWindow class methodsFor: 'instance creation' stamp: ''!
labelled: labelString
	^self new setLabel: labelString! !

!SystemWindow class methodsFor: 'accessing' stamp: ''!
borderWidth

	"Making changes to this for some reason requires repositioning of CornerGripMorphs.
	Edit BorderedMorph#addCornerGrip and play with offsets to get them right if you increase
	border width. For instance, going from 4 to 6 here and you should updated offsets to
	(-23@-23 corner: 0@0) for the right placement of corner grips."

	^ self theme windowBorderWidthFor: self! !

!SystemWindow class methodsFor: 'accessing' stamp: ''!
closeBoxImage
	"Supplied here because we don't necessarily have ComicBold"

	^ CloseBoxImage ifNil: [CloseBoxImage := (Form
	extent: 10@10
	depth: 32
	fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 3326099520 3330310272 0 0 0 0 0 0 0 0 4144038145 3326099520 3330310272 0 0 0 4144038145 3326099520 0 0 0 4227924225 3326099520 3330310272 0 4144038145 3326099520 3330310272 0 0 0 0 4144038145 3326099520 4144038145 3326099520 3330310272 3336494814 0 0 0 0 0 4227924225 3326099520 3330310272 3336494814 0 0 0 0 0 4144038145 3326099520 4144038145 3326099520 3330310272 3336494814 0 0 0 4144038145 3326099520 3330310272 3336494814 4144038145 3326099520 3330310272 0 0 4144038145 3326099520 3330310272 3336494814 0 0 4144038145 3326099520 0 0 0 3330310272 3336494814 0 0 0 0 0 0)
	offset: 0@0)]! !

!SystemWindow class methodsFor: 'menu items - tiling' stamp: ''!
tilingMenuOn: aBuilder

	<windowMenu>

	(aBuilder item: #Tile)
		order: 10.5.! !

!SystemWindow class methodsFor: 'top window' stamp: ''!
topWindow
	^ TopWindow! !

!SystemWindow class methodsFor: 'top window' stamp: ''!
closeTopWindow
	"Try to close the top window.  It may of course decline"
	TopWindow ifNotNil: [ :window | 
		TopWindow := nil. 
		window delete.
	]! !

!SystemWindow class methodsFor: 'menu items - tiling' stamp: ''!
tilingMenuItemsOn: aBuilder

	<windowMenu>
		
	(aBuilder item: #tileLeft)
		action: [ :target | target tileLeft ];
		label: 'Left';
		parent: #Tile;
		icon: (self iconNamed: #blank); 
		order: 1;
		help: 'Move the window to the left half of the display'.

	(aBuilder item: #tileRight)
		action: [ :target | target tileRight ];
		label: 'Right';
		parent: #Tile;
		help: 'Move the window to the right half of the display'.

	(aBuilder item: #tileTop)
		action: [ :target | target tileTop ];
		label: 'Top';
		parent: #Tile;
		help: 'Move the window to the top half of the display'.

	(aBuilder item: #tileBottom)
		action: [ :target | target tileBottom ];
		label: 'Bottom';
		parent: #Tile;
		help: 'Move the window to the bottom half of the display'.

	(aBuilder item: #tileTopLeft)
		action: [ :target | target tileTopLeft ];
		label: 'Top left';
		parent: #Tile;
		help: 'Move the window to the top left corner of the display'.
		
	(aBuilder item: #tileTopRight)
		action: [ :target | target tileTopRight ];
		label: 'Top right';
		parent: #Tile;
		help: 'Move the window to the top right corner of the display'.

	(aBuilder item: #tileBottomLeft)
		action: [ :target | target tileBottomLeft ];
		label: 'Bottom left';
		parent: #Tile;
		help: 'Move the window to the bottom left corner of the display'.

	(aBuilder item: #tileBottomRight)
		action: [ :target | target tileBottomRight ];
		label: 'Bottom right';
		parent: #Tile;
		help: 'Move the window to the right bottom corner of the display'.

	(aBuilder item: #tileFull)
		action: [ :target | target tileFull ];
		label: 'Full';
		parent: #Tile;
		help: 'Maximize the window'.

	(aBuilder item: #tileCenter)
		action: [ :target | target tileCenter ];
		label: 'Center';
		parent: #Tile;
		help: 'Center the window with a default extent'.! !

!SystemWindow class methodsFor: 'accessing' stamp: ''!
collapseBoxImage
	"Supplied here because we don't necessarily have ComicBold"

	^ CollapseBoxImage ifNil: [ CollapseBoxImage := (Form
	extent: 10@10
	depth: 32
	fromArray: #( 0 0 4127260929 4127260929 4127260929 4127260929 4127260929 0 0 0 0 3875602689 3212869760 3212869760 3212869760 3212869760 3212869760 4227924225 0 0 4127260929 3212869760 3212869760 0 0 0 0 3212869760 4127260929 0 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4128708375 3212869760 0 0 0 0 0 0 4127260929 3212869760 0 4127260929 3212869760 0 0 0 0 4127260929 3208659008 3212869760 0 3208659008 4127260929 4127260929 4127260929 4127260929 4127260929 3208659008 3212869760 0 0 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 0 0)
	offset: 0@0)]! !

!SystemWindow class methodsFor: '*Polymorph-Widgets' stamp: ''!
passivateTopWindow
	"Make no window the top window."

	TopWindow ifNotNil: [ :window | 
		TopWindow := nil.
		window privateBePassive.
	]! !

!SystemWindow class methodsFor: 'private-menu building' stamp: ''!
icons

	^ Smalltalk ui icons.! !

!SystemWindow class methodsFor: 'keymapping' stamp: ''!
buildWindowMovingShortcutsOn: aBuilder
	<keymap>

	(aBuilder shortcut: #windowMoveLeft)
		category: #WindowShortcuts
		default: PharoShortcuts current windowMoveLeftShortcut
		do: [ :target | 
			| movement |
			movement := ((target bounds width / 2) negated)@0.
			target bounds: ((target bounds topLeft + (movement)) corner: (target bounds bottomRight + (movement)))]
		description: 'Move window left by half of its extent'.
		
	(aBuilder shortcut: #windowMoveRight)
		category: #WindowShortcuts
		default: PharoShortcuts current windowMoveRightShortcut
		do: [ :target | 
			| movement |
			movement := ((target bounds width /2))@0.
			target bounds: ((target bounds topLeft + (movement)) corner: (target bounds bottomRight + (movement)))]
		description: 'Move window right by half of its extent'.

	(aBuilder shortcut: #windowMoveUp)
		category: #WindowShortcuts
		default: PharoShortcuts current windowMoveUpShortcut
		do: [ :target | 
			| movement |
			movement := 0@((target bounds height / 2) negated).
			target bounds: ((target bounds topLeft + (movement)) corner: (target bounds bottomRight + (movement)))]
		description: 'Move window up by half of its extent'.
		
	(aBuilder shortcut: #windowMoveDown)
		category: #WindowShortcuts
		default: PharoShortcuts current windowMoveDownShortcut
		do: [ :target | 
			| movement |
			movement := 0@(target bounds height / 2).
			target bounds: ((target bounds topLeft + (movement)) corner: (target bounds bottomRight + (movement)))]
		description: 'Move window down by half of its extent'.! !

!SystemWindow class methodsFor: 'keymapping' stamp: ''!
buildWindowBottomEdgeShortcutsOn: aBuilder
	<keymap>

	(aBuilder shortcut: #windowBottomEdgeUp)
		category: #WindowShortcuts
		default: PharoShortcuts current windowBottomEdgeUpShortcut
		do: [ :target | 
			| movement |
			movement := 0@(target bounds height / 2) negated.
			target bounds: ((target bounds topLeft) corner: (target bounds bottomRight + movement))]
		description: 'Move bottom edge of the window up by half of the window extent'.
		
	(aBuilder shortcut: #windowBottomEdgeDown)
		category: #WindowShortcuts
		default: PharoShortcuts current windowBottomEdgeDownShortcut
		do: [ :target | 
			| movement |
			movement := 0@(target bounds height / 2).
			target bounds: ((target bounds topLeft) corner: (target bounds bottomRight + movement))]
		description: 'Move bottXX edge of the window up by half of the window extent'.! !

!SystemWindow class methodsFor: 'class initialization' stamp: ''!
initialize

	CollapseBoxImage := nil.
	CloseBoxImage := nil! !

!SystemWindow class methodsFor: 'accessing' stamp: ''!
menuBoxImage

	^ (Form
	extent: 10@10
	depth: 32
	fromArray: #( 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4227858432 0 4127195136 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4227858432 3212869760 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760)
	offset: 0@0)! !

!SystemWindow class methodsFor: '*Polymorph-Widgets' stamp: ''!
resetForms
	"Set the box forms to nil so that they will be taken from the current theme.
	Don't touch the expand or menu ones, delegated to theme anyway."

	CloseBoxImage := nil.
	CollapseBoxImage := nil! !

!SystemWindow class methodsFor: 'top window' stamp: ''!
wakeUpTopWindowUponStartup
	TopWindow ifNotNil:
		[TopWindow isCollapsed ifFalse:
			[TopWindow model ifNotNil:
				[TopWindow model modelWakeUpIn: TopWindow]]]! !

!SystemWindow class methodsFor: 'menu items' stamp: ''!
windowMenuOn: aBuilder
	"To inject your custom items in a specific place, note that each item increases in order by 1. For example, if you wanted your item to be the second item, you could give it an #order: 1.5"

	<windowMenu>
	| closableLabel draggableLabel maximizeLabel |
	(aBuilder item: #Close)
		order: 1.0;
		action: [ aBuilder model closeBoxHit ];
		iconName: #windowCloseForm;
		enabledBlock: [ aBuilder model allowedToClose ];
		withSeparatorAfter.
	(aBuilder item: #About)
		action: [ aBuilder model showAbout ];
		iconName: #smallHelpIcon;
		withSeparatorAfter.
	(aBuilder item: #'Change title')
		action: [ aBuilder model relabel ].
	(aBuilder item: #'Copy title')
		action: [ aBuilder model copyTitle ];
		withSeparatorAfter.
	(aBuilder item: #'Send to back')
		action: [ aBuilder model sendToBack ].
	(aBuilder item: #'Make next-to-topmost')
		action: [ aBuilder model makeSecondTopmost ];
		withSeparatorAfter.
	(aBuilder item: #'Create window group')
		action: [ aBuilder model createWindowGroup ];
		withSeparatorAfter.
	closableLabel := aBuilder model mustNotClose
		ifFalse: [ #'Make unclosable' ]
		ifTrue: [ #'Make closable' ].
	(aBuilder item: closableLabel)
		action: [ 
			(closableLabel = #'Make unclosable')
				ifTrue: [ aBuilder model makeUnclosable ] 
				ifFalse:[ aBuilder model makeClosable] ].
	draggableLabel := aBuilder model isSticky
		ifTrue: [ #'Make draggable' ]
		ifFalse: [ #'Make undraggable' ].
	(aBuilder item: draggableLabel)
		action: [ aBuilder model toggleStickiness ];
		withSeparatorAfter.
	maximizeLabel := aBuilder model isMaximized
		ifTrue: [ #Restore ]
		ifFalse: [ #Maximize ].
	(aBuilder item: maximizeLabel)
		action: [ aBuilder model expandBoxHit ];
		iconName: #windowMaximizeForm! !

!SystemWindow class methodsFor: 'keymapping' stamp: ''!
buildShortcutsOn: aBuilder
	<keymap>

	(aBuilder shortcut: #close)
		category: #WindowShortcuts
		default: PharoShortcuts current closeWindowShortcut
		do: [ :target | SystemWindow closeTopWindow ]
		description: 'Close this window'.! !

!SystemWindow class methodsFor: 'keymapping' stamp: ''!
buildWindowLeftEdgeShortcutsOn: aBuilder
	<keymap>

	(aBuilder shortcut: #windowLeftEdgeLeft)
		category: #WindowShortcuts
		default: PharoShortcuts current windowLeftEdgeLeftShortcut
		do: [ :target | 
			| movement |
			movement := (target bounds width / 2) negated @0.
			target bounds: ((target bounds topLeft + movement) corner: (target bounds bottomRight ))]
		description: 'Move left edge of the window left by half of the window extent'.
		
	(aBuilder shortcut: #windowLeftEdgeRight)
		category: #WindowShortcuts
		default: PharoShortcuts current windowLeftEdgeRightShortcut
		do: [ :target | 
			| movement |
			movement := (target bounds width / 2)@0.
			target bounds: ((target bounds topLeft + movement) corner: (target bounds bottomRight))]
		description: 'Move left edge of the window right by half of the window extent'.! !

!SystemWindow class methodsFor: 'top window' stamp: ''!
noteTopWindowIn: aWorld
	"Clear the current top window and activate the topmost visible window"
	
	TopWindow := nil.
	
	aWorld ifNil: [^ self].
	aWorld submorphsDo: [:m |
		(m isSystemWindow and: [m isCollapsed not]) ifTrue: [
			^m activate]]! !

!SystemWindow class methodsFor: 'keymapping' stamp: ''!
buildWindowTilingShortcutsOn: aBuilder
	<keymap>

	(aBuilder shortcut: #windowTopLeft)
		category: #WindowShortcuts
		default: PharoShortcuts current windowTopLeftShortcut
		do: [ :target | target tileTopLeft]
		description: 'Move the window to the top left corner of the display'.

	(aBuilder shortcut: #windowLeft)
		category: #WindowShortcuts
		default: PharoShortcuts current windowLeftShortcut
		do: [ :target | target tileLeft ]
		description: 'Move the window to the left half of the display'.
	
	(aBuilder shortcut: #windowBottomLeft)
		category: #WindowShortcuts
		default: PharoShortcuts current windowBottomLeftShortcut
		do: [ :target | target tileBottomLeft ]
		description: 'Move the window to the bottom left corner of the display'.

	(aBuilder shortcut: #windowTop)
		category: #WindowShortcuts
		default: PharoShortcuts current windowTopShortcut
		do: [ :target | target tileTop ]
		description: 'Move the window to the top half of the display'.

	(aBuilder shortcut: #windowTopRight)
		category: #WindowShortcuts
		default: PharoShortcuts current windowTopRightShortcut
		do: [ :target | target tileTopRight ]
		description: 'Move the window to the top right corner of the display'.

	(aBuilder shortcut: #windowRight)
		category: #WindowShortcuts
		default: PharoShortcuts current windowRightShortcut
		do: [ :target | target tileRight ]
		description: 'Move the window to the right half of the display'.

	(aBuilder shortcut: #windowRightBottom)
		category: #WindowShortcuts
		default: PharoShortcuts current windowRightBottomShortcut
		do: [ :target | target tileBottomRight ]
		description: 'Move the window to the right bottom corner of the display'.

	(aBuilder shortcut: #windowBottom)
		category: #WindowShortcuts
		default: PharoShortcuts current windowBottomShortcut
		do: [ :target | target tileBottom ]
		description: 'Move the window to the bottom half of the display'.

	(aBuilder shortcut: #windowMaximize)
		category: #WindowShortcuts
		default: PharoShortcuts current windowMaximizeShortcut
		do: [ :target | target tileFull ]
		description: 'Maximize the window'.

	(aBuilder shortcut: #windowMinimize)
		category: #WindowShortcuts
		default: PharoShortcuts current windowMinimizeShortcut
		do: [ :target | target minimize]
		description: 'Miminimze the window'.

	(aBuilder shortcut: #windowCenter)
		category: #WindowShortcuts
		default: PharoShortcuts current windowCenterShortcut
		do: [ :target | target tileCenter]
		description: 'Center the window with a default extent'.! !

!SystemWindow class methodsFor: 'settings' stamp: ''!
fullscreenMargin: anInteger
	FullscreenMargin := anInteger! !

!SystemWindow class methodsFor: 'keymapping' stamp: ''!
buildWindowRightEdgeShortcutsOn: aBuilder
	<keymap>

	(aBuilder shortcut: #windowRightEdgeLeft)
		category: #WindowShortcuts
		default: PharoShortcuts current windowRightEdgeLeftShortcut
		do: [ :target | 
			| movement |
			movement := (target bounds width / 2) negated @0.
			target bounds: ((target bounds topLeft) corner: (target bounds bottomRight + movement))]
		description: 'Center the window with a default extent'.
		
	(aBuilder shortcut: #windowRightEdgeRight)
		category: #WindowShortcuts
		default: PharoShortcuts current windowRightEdgeRightShortcut
		do: [ :target | 
			| movement |
			movement := (target bounds width / 2)@0.
			target bounds: ((target bounds topLeft) corner: (target bounds bottomRight + movement))]
		description: 'Center the window with a default extent'.! !

!SystemWindow class methodsFor: 'accessing' stamp: ''!
expandBoxImage

	^ (Form
	extent: 10@10
	depth: 32
	fromArray: #( 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 0 0 0 0 3875602689 0 0 0 0 4127260929 3877181721 3877181721 3875602689 0 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 4127260929 3875602689 3875602689 3875602689 3875602689 3212869760 0 3875602689 3212869760 0 3877181721 3212869760 3212869760 3212869760 3212869760 3212869760 0 3875602689 3212869760 0 3877181721 0 0 0 0 0 0 3875602689 3212869760 0 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3212869760 0 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760)
	offset: 0@0)! !

!SystemWindow class methodsFor: 'top window' stamp: ''!
sendTopWindowToBack
 	"Send the top window of the world to the back. Relies on #submorphs array being ordered top to bottom. "
	self currentWorld submorphs 
		detect: [ :morph | morph isSystemWindow ] 
		ifFound: [ :morph | morph sendToBack ].! !

!SystemWindow class methodsFor: 'keymapping' stamp: ''!
buildWindowTopEdgeShortcutsOn: aBuilder
	<keymap>

	(aBuilder shortcut: #windowTopEdgeUp)
		category: #WindowShortcuts
		default: PharoShortcuts current windowTopEdgeUpShortcut
		do: [ :target | 
			| movement |
			movement := 0@(target bounds height / 2) negated.
			target bounds: ((target bounds topLeft + movement) corner: (target bounds bottomRight))]
		description: 'Move top edge of the window up by half of the window extent'.
		
	(aBuilder shortcut: #windowTopEdgeDown)
		category: #WindowShortcuts
		default: PharoShortcuts current windowTopEdgeDownShortcut
		do: [ :target | 
			| movement |
			movement := 0@(target bounds height / 2).
			target bounds: ((target bounds topLeft + movement) corner: (target bounds bottomRight))]
		description: 'Move top edge of the window down by half of the window extent'.! !

!T2AbstractTest commentStamp: ''!
Abstract Test of all the TraitsV2 tests!
!T2AbstractTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	createdClasses := OrderedCollection new! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newClass: aName superclass: aSuperclass with: slots trait: aComposition
	
	^ self newClass: aName superclass: aSuperclass with: slots uses: aComposition category: 'TraitsV2-Tests-TestClasses' ! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newTrait: aName with: slots uses: aComposition category: category
	| class |
	class := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: aName;
			traitComposition: aComposition asTraitComposition;
			slots: slots;
			package: category;
			beTrait ].			
	
	createdClasses add:class.
	
	^class.! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newTrait: aName with: slots uses: aComposition
	^ self newTrait: aName with: slots trait: aComposition category: 'TraitsV2-Tests-TestClasses'! !

!T2AbstractTest methodsFor: 'running' stamp: ''!
tearDown
	createdClasses reverseDo: #removeFromSystem.
	createdClasses := nil.

	super tearDown! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newClass: aName superclass: aSuperclass with: slots uses: aComposition
	
	^ self newClass: aName superclass: aSuperclass with: slots uses: aComposition category: 'TraitsV2-Tests-TestClasses' ! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newClass: aName with: slots trait: aComposition
	^ self newClass: aName superclass: Object with: slots trait: aComposition! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newTrait: aName with: slots
	^ self newTrait: aName with: slots trait: TEmpty! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newTrait: aName with: slots trait: aComposition category: category
	| class |
	class := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: aName;
			traitComposition: aComposition asTraitComposition;
			slots: slots;
			package: category;
			beTrait ].			
	
	createdClasses add:class.
	
	^class.! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newClass: aName superclass: aSuperclass with: slots uses: aComposition category: category
	
	| class |

	class := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: aName;
			superclass: aSuperclass;
			slots: slots;
			traitComposition: aComposition asTraitComposition;
			package: category ].
	
	createdClasses add:class.
	
	^class.! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newClass: aName with: slots uses: aComposition
	^ self newClass: aName superclass: Object with: slots uses: aComposition! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newClass: aName 
	^self newClass: aName with: #() trait: TEmpty! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newTrait: aName with: slots trait: aComposition
	^ self newTrait: aName with: slots trait: aComposition category: 'TraitsV2-Tests-TestClasses'! !

!T2AbstractTest methodsFor: 'instance creation' stamp: ''!
newClass: aName superclass: aSuperclass with: slots trait: aComposition category: category
	
	| class |

	class := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: aName;
			superclass: aSuperclass;
			slots: slots;
			traitComposition: aComposition asTraitComposition;
			package: category ].
	
	createdClasses add:class.
	
	^class.! !

!T2AbstractTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^self == T2AbstractTest! !

!T2CommonClassDefinitionPrinterTest methodsFor: 'running' stamp: ''!
tearDown

	ClassDefinitionPrinter displayEmptySlots: emptySlots.
	ClassDefinitionPrinter showFluidClassDefinition: slotuse.
	super tearDown! !

!T2CommonClassDefinitionPrinterTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	slotuse := ClassDefinitionPrinter showFluidClassDefinition.
	emptySlots := ClassDefinitionPrinter displayEmptySlots.
	ClassDefinitionPrinter displayEmptySlots: false! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTUses

	self
		assert: ((Trait << #TTUses)
				 traits: TBehavior;
				 package: 'Fake') build definitionString
		equals: 'Trait << #TTUses
	traits: {TBehavior};
	package: ''_UnpackagedPackage'''! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'helpers' stamp: ''!
expandedForClass: aClass
	^ (FluidClassDefinitionPrinter for: aClass) expandedDefinitionString 
! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - expanded' stamp: ''!
testExpandedMetaclassWithTrait
	
	self assert: (self expandedForClass: MOPTestClassD class) equals: 'Object class << MOPTestClassD class
	traits: {Trait2 classTrait};
	slots: {}' ! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - complex slots' stamp: ''!
testClassDefinitionWithComplexSlotShouldBeDisplayedAsFluid

	ClassDefinitionPrinter showFluidClassDefinition: false.
	self assert: TMockWithComplexSlot needsSlotClassDefinition.

	self 
		assert: (self forClass: TMockWithComplexSlot) 
		equals: 'Trait << #TMockWithComplexSlot
	slots: { #complexSlot => ObservableSlot };
	package: ''TraitsV2-Tests''' ! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTBehavior

	self 
		assert: (self forClass: TBehavior) 
		equals: 'Trait << #TBehavior
	tag: ''Traits'';
	package: ''TraitsV2-Compatibility'''! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - template' stamp: ''!
testCompactTraitFullTemplate 

	self 
		assert: (FluidClassDefinitionPrinter new compactTraitDefinitionTemplateInPackage: 'TraitsV2') equals: 'Trait << #TMyTrait
	traits: {};
	slots: {};
	package: ''TraitsV2'''! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - expanded' stamp: ''!
testExpandedEpTEventVisitorTrait

	self 
		assert: (self expandedForClass: EpTEventVisitor)   
		equals: 'Trait << #EpTEventVisitor
	traits: {EpTCodeChangeVisitor};
	slots: {};
	tag: ''Visitors'';
	package: ''Epicea'''! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testMultiPools

	self assert: (self forClass: ClassMultiplePoolUser) equals: 'Object << #ClassMultiplePoolUser
	sharedPools: { PoolDefiner . PoolDefiner2 };
	tag: ''Classes'';
	package: ''Kernel-Tests''' ! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - expanded' stamp: ''!
testExpandedClySubclassWithTraitsOfClassWithTraits

	self 
		assert: (self expandedForClass: ClySubclassWithTraitsOfClassWithTraits)   
		equals: 'ClyClassWithTraits << #ClySubclassWithTraitsOfClassWithTraits
	layout: FixedLayout;
	traits: {ClyTraitChild3};
	slots: {};
	sharedVariables: {};
	sharedPools: {};
	tag: '''';
	package: ''Calypso-SystemPlugins-Traits-Queries-Tests-PWithTraits'''! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - expanded' stamp: ''!
testExpandedTComparableClassTrait

	self 
		assert:  (self expandedForClass: TComparable classTrait) 
		equals:  'Trait << TComparable classTrait
	traits: {};
	slots: {}'
	! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTrait
	
	self assert: (self forClass: RubScrolledTextModel) equals: 'Object << #RubScrolledTextModel
	traits: {TViewModel};
	slots: { #hasUnacceptedEdits . #announcer . #text . #primarySelectionInterval . #interactionModel };
	tag: ''Editing-Widgets'';
	package: ''Rubric''' ! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - expanded' stamp: ''!
testExpandedTrait3ClassTrait

	self 
		assert: (self expandedForClass: Trait3 classTrait) 
		equals:  'Trait << Trait3 classTrait
	traits: {Trait2 classTrait};
	slots: {}'
		! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testComplexTrait

	self assert: (self forClass: MOPTestClassD) equals: 'Object << #MOPTestClassD
	traits: {Trait2 @ {#c3->#c2}};
	tag: ''Traits-MOP'';
	package: ''Tests''' ! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testMetaclassWithTrait
	
	self assert: (self forClass: MOPTestClassD class) equals: 'Object class << MOPTestClassD class
	traits: {Trait2 classTrait}' ! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTEventVisitorClassTrait

	self 
		assert: (self forClass: EpTEventVisitor classTrait) 
		equals: 'Trait << EpTEventVisitor classTrait
	traits: {EpTCodeChangeVisitor classTrait}'! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testAlignmentMorphClass

	self 
		assert: (self forClass: AlignmentMorph class) 
		equals: 'BorderedMorph class << AlignmentMorph class
	traits: {TAbleToRotate classTrait}' ! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTComparableClassTrait

	self assert: (self forClass: TComparable classTrait) equals: 'Trait << TComparable classTrait' ! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - expanded' stamp: ''!
testExpandedEpTEventVisitorClassTrait

	self 
		assert: (self expandedForClass: EpTEventVisitor classTrait)   
		equals: 'Trait << EpTEventVisitor classTrait
	traits: {EpTCodeChangeVisitor classTrait};
	slots: {}'! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTSlot

	self 
		assert: (Trait << #TTUses slots: {  #x . #y }; package: 'Fake') build definitionString 
		equals: 
	'Trait << #TTUses
	slots: { #x . #y };
	package: ''_UnpackagedPackage''' ! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	ClassDefinitionPrinter showFluidClassDefinition: true! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - template' stamp: ''!
testFullTraitTemplate

	self 
		assert: (FluidClassDefinitionPrinter new traitDefinitionTemplateInPackage: 'TraitsV2') equals: 'Trait << #TMyTrait
	traits: {};
	slots: {};
	tag: '''' ;
	package: ''TraitsV2'''! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'helpers' stamp: ''!
forClass: aClass
	^ (FluidClassDefinitionPrinter for: aClass) definitionString 

! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - metaclasses' stamp: ''!
testClassSideDoesNotShowPackage

	self assert: (self forClass: MOPTraitTest class) equals: 'TestCase class << MOPTraitTest class'! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTrait3

	self assert: (self forClass: Trait3 classTrait) equals: 'Trait << Trait3 classTrait
	traits: {Trait2 classTrait}'! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTrait3AndTag

	self 
		assert: (self forClass: Trait3) 
		equals: 'Trait << #Trait3
	traits: {Trait2};
	tag: ''Traits-MOP'';
	package: ''Tests''' ! !

!T2FluidClassDefinitionPrinterTest methodsFor: 'tests - complex slots' stamp: ''!
testDefinitionWithComplexSlot
	"Fluid definition support complex slots."
	
	self assert: (self forClass: TMockWithComplexSlot) equals: 'Trait << #TMockWithComplexSlot
	slots: { #complexSlot => ObservableSlot };
	package: ''TraitsV2-Tests''' ! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testAlignmentMorphClass

	self 
		assert: (self forClass: AlignmentMorph class) equals: 'AlignmentMorph class
	instanceVariableNames: '''''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTComparableClassTrait

	self assert: (self forClass: TComparable classTrait) equals: 'TComparable classTrait
	instanceVariableNames: '''''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTSortable

	self assert: (self forClass: TSortable classTrait) equals: 'TSortable classTrait
	instanceVariableNames: '''''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTBehavior
	"to me this looks strange to have empty uses here when empty instancevariablenames are not displayed."
	self 
		assert: (self forClass: TBehavior)  equals: 'Trait named: #TBehavior
	 uses: {}
	 package: ''TraitsV2-Compatibility-Traits'''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testMultiPools

	self
		assert: (self forClass: ClassMultiplePoolUser)
		equals: 'Object subclass: #ClassMultiplePoolUser
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''PoolDefiner PoolDefiner2''
	category: ''Kernel-Tests-Classes'''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testClassUsingComplexTrait

	self
		assert: (self forClass: MOPTestClassD)
		equals: 'Object subclass: #MOPTestClassD
	uses: Trait2 @ {#c3->#c2}
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''Tests-Traits-MOP'''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'helpers' stamp: ''!
forClass: aClass
	^ (ClassDefinitionPrinter legacy for: aClass) definitionString 

! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTrait
	
	self assert: (self forClass: RubScrolledTextModel) equals: 'Object subclass: #RubScrolledTextModel
	uses: TViewModel
	instanceVariableNames: ''hasUnacceptedEdits announcer text primarySelectionInterval interactionModel''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''Rubric-Editing-Widgets'''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTrait3

	self assert: (self forClass: Trait3 classTrait) equals: 'Trait3 classTrait
	instanceVariableNames: '''''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTrait3AndTag

	self 
		assert: (self forClass: Trait3) 
		equals: 'Trait named: #Trait3
	 uses: Trait2
	 package: ''Tests-Traits-MOP'''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testComplexTrait

	self
		assert: (self forClass: Trait4)
		equals: 'Trait named: #Trait4
	 uses: Trait1 + (Trait2 - {#c})
	 package: ''Tests-Traits-MOP'''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTEventVisitorClassTrait

	self assert: (self forClass: EpTEventVisitor classTrait) equals: 'EpTEventVisitor classTrait
	instanceVariableNames: '''''! !

!T2LegacyPharoClassDefinitionPrinterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	ClassDefinitionPrinter showFluidClassDefinition: false! !

!T2ObsoleteClassTest commentStamp: ''!
Unit test for trait handling when classes are removed!
!T2ObsoleteClassTest methodsFor: 'tests' stamp: ''!
testObsoleteTraitIsRemovedFromUsers
	| t1 t2 t3 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	t3 := self newTrait: #T3 with: #()  uses:  t1 + t2.
		
	self assert: (t1 users includes: t3).
	self assert: (t2 users includes: t3).	
	
	t3 removeFromSystem.
	createdClasses remove: t3.
	
	self deny: (t1 users includes: t3).
	self deny: (t2 users includes: t3).	
! !

!T2ObsoleteClassTest methodsFor: 'tests' stamp: ''!
testObsoleteClassIsRemovedFromUsersClassSide
	| t1 t2 c1 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #()  uses: {}.
	c1 class setTraitComposition: t1 + t2. 
		
	self assert: (t1 users includes: c1 class).
	self assert: (t2 users includes: c1 class).	
	
	c1 removeFromSystem.
	createdClasses remove: c1.
	
	self deny: (t1 users includes: c1 class).
	self deny: (t2 users includes: c1 class).	
! !

!T2ObsoleteClassTest methodsFor: 'tests' stamp: ''!
testObsoleteClassIsRemovedFromUsers
	| t1 t2 c1 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #()  uses:  t1 + t2.
		
	self assert: (t1 users includes: c1).
	self assert: (t2 users includes: c1).	
	
	c1 removeFromSystem.
	createdClasses remove: c1.
	
	self deny: (t1 users includes: c1).
	self deny: (t2 users includes: c1).	
! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testAlignmentMorphClass

	self 
		assert: (self forClass: AlignmentMorph class) equals: 'AlignmentMorph class
	uses: TAbleToRotate classTrait
	instanceVariableNames: '''''! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTComparableClassTrait

	self assert: (self forClass: TComparable classTrait) equals: 'TComparable classTrait
	instanceVariableNames: '''''! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTSortable

	self assert: (self forClass: TSortable classTrait) equals: 'TSortable classTrait
	instanceVariableNames: '''''! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testClassDefinitionWithComplexSlotShouldBeDisplayedAsFluid

	ClassDefinitionPrinter showFluidClassDefinition: false.
	self assert: TMockWithComplexSlot needsSlotClassDefinition.

	self 
		assert: (self forClass: TMockWithComplexSlot) 
		equals: 'Trait << #TMockWithComplexSlot
	slots: { #complexSlot => ObservableSlot };
	package: ''TraitsV2-Tests''' ! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTBehavior
	"to me this looks strange to have empty uses here when empty instancevariablenames are not displayed."
	self 
		assert: (self forClass: TBehavior)  equals:  'Trait named: #TBehavior
	instanceVariableNames: ''''
	package: ''TraitsV2-Compatibility-Traits'''! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testMultiPools

	self assert: (self forClass: ClassMultiplePoolUser) equals: 'Object subclass: #ClassMultiplePoolUser
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''PoolDefiner PoolDefiner2''
	package: ''Kernel-Tests-Classes'''! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'helpers' stamp: ''!
forClass: aClass
	^ (OldPharoClassDefinitionPrinter for: aClass) definitionString 

! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTrait
	
	self assert: (self forClass: RubScrolledTextModel) equals: 'Object subclass: #RubScrolledTextModel
	uses: TViewModel
	instanceVariableNames: ''hasUnacceptedEdits announcer text primarySelectionInterval interactionModel''
	classVariableNames: ''''
	package: ''Rubric-Editing-Widgets'''
	 ! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTrait3

	self assert: (self forClass: Trait3 classTrait) equals: 'Trait3 classTrait
	uses: Trait2 classTrait
	instanceVariableNames: '''''! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTMockWithUseAndSlot

	ClassDefinitionPrinter showFluidClassDefinition: false.
	self deny: TMockWithUseAndSlot needsSlotClassDefinition.
	"if the slot would be complex automatically the class def would switch to the fluid one
	So the test really test that the class creation API of the old syntax is correct. 
	Even if we should push for using the fluid one."

	self 
		assert: (self forClass: TMockWithUseAndSlot) 
		equals: 'Trait named: #TMockWithUseAndSlot
	uses: Trait3
	instanceVariableNames: ''simpleSlot''
	package: ''TraitsV2-Tests''' ! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testComplexTrait

	self assert: (self forClass: MOPTestClassD) equals: 'Object subclass: #MOPTestClassD
	uses: Trait2 @ {#c3->#c2}
	instanceVariableNames: ''''
	classVariableNames: ''''
	package: ''Tests-Traits-MOP'''
! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTrait3AndTag

	self 
		assert: (self forClass: Trait3) 
		equals: 
 'Trait named: #Trait3
	uses: Trait2
	instanceVariableNames: ''''
	package: ''Tests-Traits-MOP'''	! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'tests - traits' stamp: ''!
testTEventVisitorClassTrait

	self assert: (self forClass: EpTEventVisitor classTrait) equals: 'EpTEventVisitor classTrait
	uses: EpTCodeChangeVisitor classTrait
	instanceVariableNames: '''''! !

!T2OldPharoClassDefinitionPrinterTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	ClassDefinitionPrinter showFluidClassDefinition: false! !

!T2OverloadingOfMethodsInTraitedClassTest methodsFor: 'running' stamp: ''!
tearDown
	TraitedClass
		removeSelector: #isTrueForUsersOfTheTraitForT2OverloadingOfMethodsInTraitedClassTest.
	Behavior
		removeSelector: #isTrueForUsersOfTheTraitForT2OverloadingOfMethodsInTraitedClassTest.
	super tearDown! !

!T2OverloadingOfMethodsInTraitedClassTest methodsFor: 'tests' stamp: ''!
createT2
	^ self newTrait: #T2 with: '' asSlotCollection! !

!T2OverloadingOfMethodsInTraitedClassTest methodsFor: 'tests' stamp: ''!
testIndirectTraitSubclassing
	| t1 t2 superclass subclass |
	t1 := self createT1.
	t2 := self createT2.
	superclass := self
		newClass: #C2Superclass
		with: '' asSlotCollection
		uses: t2.
		
	subclass := self
		newClass: #C1Subclass
		superclass: superclass
		with: '' asSlotCollection
		uses: t1.
	self
		deny:
			superclass
				isTrueForUsersOfTheTraitForT2OverloadingOfMethodsInTraitedClassTest.
	self
		assert:
			subclass
				isTrueForUsersOfTheTraitForT2OverloadingOfMethodsInTraitedClassTest! !

!T2OverloadingOfMethodsInTraitedClassTest methodsFor: 'tests' stamp: ''!
createT1
	| t1 |
	t1 := self newTrait: #T1 with: '' asSlotCollection.
	t1 classTrait
		compile:
			'isTrueForUsersOfTheTraitForT2OverloadingOfMethodsInTraitedClassTest
		"Should be removed at the end of the test"
		^true
	'.
	TraitedClass
		compile:
			'isTrueForUsersOfTheTraitForT2OverloadingOfMethodsInTraitedClassTest
		"Should be removed at the end of the test"
		^false
	'.
	Behavior
		compile:
			'isTrueForUsersOfTheTraitForT2OverloadingOfMethodsInTraitedClassTest
		"Should be removed at the end of the test"
		^false
	'.
	^ t1! !

!T2OverloadingOfMethodsInTraitedClassTest methodsFor: 'tests' stamp: ''!
testDirectTraitSubclassing
	| t1 c1 |
	t1 := self createT1.
	c1 := self newClass: #C1 with: '' asSlotCollection uses: t1.
	self
		assert:
			c1 isTrueForUsersOfTheTraitForT2OverloadingOfMethodsInTraitedClassTest! !

!T2PrecedenceCompositionTest methodsFor: 'tests' stamp: ''!
testClassCompositionOnPrecedenceKeepsPreference

	| t1 t2 original copy |

	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #().

	t2 := self newTrait: #T2 with: #() uses: #().
	t2 classTrait uses: {} slots: #().

	t1 compile: 'm1 ^ 42'.
	t2 compile: 'm1 ^ 33'.
	
	original := (t2 + t1) withPrecedenceOf: t2.
	copy := original classComposition.
	
	self 
		assert: original preferedTrait innerClass 
		equals: copy preferedTrait innerClass instanceSide.
! !

!T2PrecedenceCompositionTest methodsFor: 'tests' stamp: ''!
testPrecedencesAreGeneratedInClassDefinition
	| t1 t2 t3 c1 |
	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #().

	t2 := self newTrait: #T2 with: #() uses: #().
	t2 classTrait uses: {} slots: #().

	t3 := self newTrait: #T3 with: #() uses: #().
	t3 classTrait uses: {} slots: #().

	t1 compile: 'm1 ^ 42'.
	t2 compile: 'm1 ^ 33'.
	t3 compile: 'm2 ^ 11'.

	c1 := self newClass: #C1 with: #() uses: (t2 + t1 + t3 withPrecedenceOf: t2).

	self
		assert: (ClassDefinitionPrinter oldPharo for: c1) definitionString
		equals:
		
			'Object subclass: #C1
	uses: (T2 + T1 + T3 withPrecedenceOf: T2)
	instanceVariableNames: ''''
	classVariableNames: ''''
	package: ''TraitsV2-Tests-TestClasses'''
				! !

!T2PrecedenceCompositionTest methodsFor: 'tests' stamp: ''!
testWithPrecedenceUsesThePreferedOneWithoutCaringOrderOfSequence

	| t1 t2 c1 |

	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #().

	t2 := self newTrait: #T2 with: #() uses: #().
	t2 classTrait uses: {} slots: #().

	t1 compile: 'm1 ^ 42'.
	t2 compile: 'm1 ^ 33'.
	
	c1 := self newClass: #C1 with: #() uses: ((t2 + t1) withPrecedenceOf: t2).

	self assert: (c1 new m1) equals: 33.! !

!T2PrecedenceCompositionTest methodsFor: 'tests' stamp: ''!
testPrecedencesAreGeneratedInClassDefinitionWithAlias
	| t1 t2 t3 c1 |
	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #().

	t2 := self newTrait: #T2 with: #() uses: #().
	t2 classTrait uses: {} slots: #().

	t3 := self newTrait: #T3 with: #() uses: #().
	t3 classTrait uses: {} slots: #().

	t1 compile: 'm1 ^ 42'.
	t2 compile: 'm1 ^ 33'.
	t3 compile: 'm2 ^ 11'.

	c1 := self newClass: #C1 with: #() uses: (t2 + (t1 -- #aSlot) + t3 withPrecedenceOf: t2).

	self
		assert: (ClassDefinitionPrinter oldPharo for: c1) definitionString
		equals: 'Object subclass: #C1
	uses: (T2 + (T1 -- #aSlot) + T3 withPrecedenceOf: T2)
	instanceVariableNames: ''''
	classVariableNames: ''''
	package: ''TraitsV2-Tests-TestClasses''' 
				! !

!T2PrecedenceCompositionTest methodsFor: 'tests' stamp: ''!
testWithPrecedenceIsNonAConflict

	| t1 t2 c1 |

	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #().

	t2 := self newTrait: #T2 with: #() uses: #().
	t2 classTrait uses: {} slots: #().

	t1 compile: 'm1 ^ 42'.
	t2 compile: 'm1 ^ 33'.
	
	c1 := self newClass: #C1 with: #() uses: ((t1 + t2) withPrecedenceOf: t2).

	self deny: (c1 >> #m1) isConflict! !

!T2PrecedenceCompositionTest methodsFor: 'tests' stamp: ''!
testWithoutPrecedenceIsAConflict

	| t1 t2 c1 |

	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #().

	t2 := self newTrait: #T2 with: #() uses: #().
	t2 classTrait uses: {} slots: #().

	t1 compile: 'm1 ^ 42'.
	t2 compile: 'm1 ^ 33'.
	
	c1 := self newClass: #C1 with: #() uses: t1 + t2.

	self assert: (c1 >> #m1) isConflict! !

!T2PrecedenceCompositionTest methodsFor: 'tests' stamp: ''!
testPrecedencesCanBeCombined

	| t1 t2 t3 c1 |

	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #().

	t2 := self newTrait: #T2 with: #() uses: #().
	t2 classTrait uses: {} slots: #().

	t3 := self newTrait: #T3 with: #() uses: #().
	t3 classTrait uses: {} slots: #().

	t1 compile: 'm1 ^ 42'.
	t2 compile: 'm1 ^ 33'.

	t3 compile: 'm2 ^ 11'.

	c1 := self newClass: #C1 with: #() uses: (((t2 + t1) withPrecedenceOf: t2) + t3).
	
	self assert: (c1 new m1) equals: 33.	
	self assert: (c1 new m2) equals: 11.! !

!T2PrecedenceCompositionTest methodsFor: 'tests' stamp: ''!
testCopyingAPrecedenceKeepsPreference

	| t1 t2 original copy |

	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #().

	t2 := self newTrait: #T2 with: #() uses: #().
	t2 classTrait uses: {} slots: #().

	t1 compile: 'm1 ^ 42'.
	t2 compile: 'm1 ^ 33'.
	
	original := (t2 + t1) withPrecedenceOf: t2.
	copy := original copyTraitExpression.
	
	self assert: original preferedTrait equals: copy preferedTrait
! !

!T2PrecedenceCompositionTest methodsFor: 'tests' stamp: ''!
testWithPrecedenceUsesThePreferedOne

	| t1 t2 c1 |

	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #().

	t2 := self newTrait: #T2 with: #() uses: #().
	t2 classTrait uses: {} slots: #().

	t1 compile: 'm1 ^ 42'.
	t2 compile: 'm1 ^ 33'.
	
	c1 := self newClass: #C1 with: #() uses: ((t1 + t2) withPrecedenceOf: t2).

	self assert: (c1 new m1) equals: 33.! !

!T2SubclassingTraitedClassTest methodsFor: 'tests' stamp: ''!
testCreatingMethodInSubclass
	| t1 c1 c2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	c1 := self newClass: #C1 with: #()  uses: t1.

	c2 := self newClass: #C2 superclass: c1 with: #() uses: {}.

	c2 compile: 'asd'.

	self shouldnt: [c2 >> #asd] raise: Error.
	self assert: (c2 >> #asd) package name equals: 'TraitsV2-Tests'.
	self assert: (c2 >> #asd) package equals: c2 package.! !

!T2SubclassingTraitedClassTest methodsFor: 'tests' stamp: ''!
testCreatingMethodInSubclass2
	| t1 c1 c2 |
	c1 := self newClass: #C1 with: #() uses: {}.
	c2 := self newClass: #C2 superclass: c1 with: #() uses: {}.

	t1 := self newTrait: #T1 with: #() uses: {}.
	c1 := self newClass: #C1 with: #() uses: t1.

	c2 compile: 'asd'.

	self shouldnt: [c2 >> #asd] raise: Error.
	self assert: (c2 >> #asd) package name equals: 'TraitsV2-Tests'.
	self assert: (c2 >> #asd) package equals: c2 package.! !

!T2SubclassingTraitedClassTest methodsFor: 'tests' stamp: ''!
testCreatingMethodInTraitClassSide
	| t1 c1 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t1 class compile: 'someObject ^#executingOverridenMethod'.	
	c1 := self newClass: #C1 with: #() uses: t1.
	self assert: c1 someObject equals: #executingOverridenMethod.! !

!T2TraitAnnouncementsTest commentStamp: ''!
Unit test for announcement handling when dealing with traits!
!T2TraitAnnouncementsTest methodsFor: 'tests' stamp: ''!
testRPackageIsUpdatedInInstanceSide
	
	| c1 t1 |
	
	t1 := self newTrait: #T1 with: #() uses: #() category: self packageName.
	t1 compile: 'msg ^ 1'.

	c1 := self newClass: #C1 superclass: Object with: #() uses: t1 category: self packageName.
	c1 compile: 'msg ^ 12'.
	
	self assert: (c1 >> #msg) origin equals: c1.
	
	self assert: self packageName asPackage methods size equals: 2.
	(c1 >> #msg) removeFromSystem.
	self assert: self packageName asPackage methods size equals: 1.! !

!T2TraitAnnouncementsTest methodsFor: 'tests' stamp: ''!
testRPackageIsUpdatedInClassSide
	
	| c1 t1 |
	
	t1 := self newTrait: #T1 with: #() trait: TEmpty category: self packageName.
	t1 class compile: 'msg ^ 1'.

	c1 := self newClass: #C1 superclass: Object with: #() trait: t1 category: self packageName.
	c1 class compile: 'msg ^ 12'.
	
	self assert: self packageName asPackage methods size equals: 2.
	(c1 class >> #msg) removeFromSystem.
	self assert: self packageName asPackage methods size equals: 1.! !

!T2TraitAnnouncementsTest methodsFor: 'tests' stamp: ''!
packageName
	^ 'TestPackage'! !

!T2TraitChangesTest methodsFor: 'tests' stamp: ''!
testGeneratingTheSameTraitDoesNotProduceChanges
	
	| t1 builder | 
	
	t1 := self newTrait: #T1 with: {}. 
	
	builder := ShiftClassBuilder new.
	builder buildEnvironment: ShSmalltalkGlobalsEnvironment new.

	Trait configureBuilder: builder withName: #T1 traitComposition: TEmpty slots: {}  packageName: 'TraitsV2-Tests-TestClasses'.
				
	builder tryToFillOldClass.
	builder detectBuilderEnhancer.
	builder builderEnhancer validateRedefinition: builder oldClass. 
	
	builder validateSuperclass.
	builder compareWithOldClass.
	
	self assertEmpty: builder changes.! !

!T2TraitChangesTest methodsFor: 'tests' stamp: ''!
testconfigureBuilderWithNameTraitCompositionInstanceVariableNamesPackageName
	
	| builder | 
		
	builder := ShiftClassBuilder new.
	builder buildEnvironment: ShSmalltalkGlobalsEnvironment new.
	Trait configureBuilder: builder withName: #T1 traitComposition: {} instanceVariableNames: 'a b'  packageName: 'TraitsV2-Tests-TestClasses'.
				
	self assert: builder slots size equals: 2.
	self assert: builder slots first name equals: 'a'.
	self assert: builder slots second name equals: 'b'.! !

!T2TraitChangesTest methodsFor: 'tests' stamp: ''!
testUpdatingTheSameTraitDoesNotProduceChanges
	
	| t1 builder | 
	
	t1 := self newTrait: #T1 with: {}. 
	
	builder := ShiftClassBuilder new.
	builder buildEnvironment: ShSmalltalkGlobalsEnvironment new.

	Trait configureBuilder: builder withName: #T1 traitComposition: TEmpty slots: {}  packageName: 'TraitsV2-Tests-TestClasses'.

	builder oldClass: t1.
				
	builder tryToFillOldClass.
	builder detectBuilderEnhancer.
	builder builderEnhancer validateRedefinition: builder oldClass. 
	
	builder validateSuperclass.
	builder compareWithOldClass.
	
	self assertEmpty: builder changes.! !

!T2TraitInTraitClassTest methodsFor: 'tests' stamp: ''!
testAddingSlotToClassSide
	
	| t1 |
	
	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #(aSlot).
	
	self assert: t1 classTrait slots size equals: 1.
	self assert: t1 classTrait slots anyOne name equals: #aSlot.	! !

!T2TraitInTraitClassTest methodsFor: 'tests' stamp: ''!
testAddingSpecialSlotToClassSide
	
	| t1 |
	
	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: {#aSlot => WeakSlot}.
	
	self assert: t1 classTrait slots size equals: 1.
	self assert: t1 classTrait slots anyOne name equals: #aSlot.	
	self assert: t1 classTrait slots anyOne species equals: WeakSlot.		! !

!T2TraitMCDefinitionsTest commentStamp: ''!
Unit test for correct handling of MC class definitions!
!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfNormalClass
	| c1 definition |
	c1 := self newClass: #C1 with: #(a b c) uses: {}.
	definition := c1 asClassDefinition.
	
	self assert: definition instanceVariablesString equals: 'a b c'.
	self assert: definition instanceVariables size equals: 3.
	self assert: definition traitComposition equals: '{}'.	
	self assert: (definition instanceVariables allSatisfy: [ :e | e species = InstanceVariableSlot ])! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfTrait
	| t1 definition |
	t1 := self newTrait: #T1 with: #(a b c) uses: {}.
	definition := t1 asClassDefinition.
	
	self assert: definition instanceVariablesString equals: 'a b c'.
	self assert: definition instanceVariables size equals: 3.
	self assert: definition traitComposition equals: '{}'.
	self assert: (definition instanceVariables allSatisfy: [ :e | e species = InstanceVariableSlot ])! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testEqualityOfTraitDefinitionWithDifferentSlotTypes
	| t1 definition1 definition2 |
	t1 := self newTrait: #T1 with: #(a) uses: {}.
	definition1 := t1 asClassDefinition.

	t1 := self newTrait: #T1 with: {(#a => PropertySlot)} uses: {}.
	definition2 := t1 asClassDefinition.

	self deny: definition1 equals: definition2! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfClassSideTrait
	
	| t1 definition |
	
	t1 := self newTrait: #T1 with: #() uses: #().
	t1 classTrait uses: {} slots: #(aSlot).

	definition := t1 asClassDefinition.
	
	self assert: definition classInstanceVariables equals: {#aSlot => InstanceVariableSlot}.
! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfTraitedClassWithSlots
	| c1 definition t1 |
	t1 := self newTrait: #T1 with: {#x => PropertySlot. #y => PropertySlot }. 
	c1 := self newClass: #C1 with: {#a => PropertySlot. #b => PropertySlot } uses: t1.

	definition := c1 asClassDefinition.	
	
	self assert: definition instanceVariablesString equals: '#a => PropertySlot #b => PropertySlot'.
	self assert: definition instanceVariables size equals: 2.
	self assert: definition traitComposition equals: 'T1'.	
	self assert: (definition instanceVariables allSatisfy: [ :e | e species = PropertySlot ])! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfTraitUsingTrait
	| t2 definition t1 |
	t1 := self newTrait: #T1 with: #(x y z). 
	t2 := self newTrait: #T2 with: #(a b c) uses: t1.
	definition := t2 asClassDefinition.
		
	self assert: definition instanceVariablesString equals: 'a b c'.
	self assert: definition instanceVariables size equals: 3.
	self assert: definition traitComposition equals: 'T1'.
	self assert: (definition instanceVariables allSatisfy: [ :e | e species = InstanceVariableSlot ])! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfClassSideTraitWithSpecialSlotHasCorrectString
	
	| t1 definition |
	
	t1 := self newTrait: #T1 with: #() trait: {}.
	t1 classTrait trait: { } slots: {#aSlot => WeakSlot.}.

	definition := t1 asClassDefinition.
	
	self assert: (definition classDefinitionString reject: [ :each | each isSeparator ]) equals: 'T1classTraitinstanceVariableNames:''#aSlot=>WeakSlot'''! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionHasCorrectStringWithoutSlots
	| t2 definition t1 definitionString |
	t1 := self newTrait: #T1 with: {}. 
	t2 := self newTrait: #T2 with: {#a. #b } uses: t1.

	definition := t2 asClassDefinition.				
	definitionString := String streamContents: [ :s | definition printDefinitionOn: s ].
		
	self assert: (definitionString reject: [ :each | each isSeparator ]) equals: 'Traitnamed:#T2uses:T1instanceVariableNames:''ab''package:''TraitsV2-Tests-TestClasses'''
	
	
	"We cannot use ((ClassDefinitionPrinter oldPharo for: t2) definitionString reject: [ :each | each isSeparator ])
	because slots is still used in the oldPharo printer implementation and this should change."
! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testEqualityOfTraitDefinitionInUses
	| t1 t2 definition1 definition2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	definition1 := t2 asClassDefinition.

	t2 := self newTrait: #T2 with: #() uses: {t1}.
	definition2 := t2 asClassDefinition.

	self deny: definition1 equals: definition2! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testEqualityOfTraitDefinition
	| t1 definition1 definition2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	definition1 := t1 asClassDefinition.

	t1 := self newTrait: #T1 with: #(a b c) uses: {}.
	definition2 := t1 asClassDefinition.

	self deny: definition1 equals: definition2! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfTraitWithSlots
	| t1  definition |
	t1 := self newClass: #C1 with: { #a => PropertySlot. #b => PropertySlot } uses: {}.

	definition := t1 asClassDefinition.
	
	self assert: definition instanceVariablesString equals: '#a => PropertySlot #b => PropertySlot'.
	self assert: definition instanceVariables size equals: 2.
	self assert: (definition instanceVariables allSatisfy: [ :e | e species = PropertySlot ])! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfClassSideTraitHasCorrectString
	
	| t1 definition |
	t1 := self newTrait: #T1 with: #() trait: {}.
	t1 classTrait trait: { } slots: #(aSlot).

	definition := t1 asClassDefinition.
	
	self assert: definition classDefinitionString equals: 'T1 classTrait instanceVariableNames: ''aSlot'''
	
	"We cannot use the class printer because this is a mix between instancevariableNames and complex slot."
	"(ClassDefinitionPrinter oldPharo for: t1 class) definitionString "
! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfNormalClassWithSlots
	| c1 definition |
	c1 := self newClass: #C1 with: { #a => PropertySlot. #b => PropertySlot } uses: {}.
	definition := c1 asClassDefinition.
		
	self assert: definition instanceVariablesString equals: '#a => PropertySlot #b => PropertySlot'.
	self assert: definition instanceVariables size equals: 2.
	self assert: definition traitComposition equals: '{}'.	
	self assert: (definition instanceVariables allSatisfy: [ :e | e species = PropertySlot ])! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfTraitUsingTraitWithSlots
	| t2 definition t1 |
	t1 := self newTrait: #T1 with: {#x => PropertySlot. #y => PropertySlot }. 
	t2 := self newTrait: #T2 with: {#a => PropertySlot. #b => PropertySlot } uses: t1.

	definition := t2 asClassDefinition.	
				
	self assert: definition instanceVariablesString equals: '#a => PropertySlot #b => PropertySlot'.
	self assert: definition instanceVariables size equals: 2.
	self assert: definition traitComposition equals: 'T1'.	
	self assert: (definition instanceVariables allSatisfy: [ :e | e species = PropertySlot ])! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionOfTraitedClass
	| c1 definition t1 |
	t1 := self newTrait: #T1 with: #(x y z). 
	c1 := self newClass: #C1 with: #(a b c) uses: t1.
	definition := c1 asClassDefinition.
	
	self assert: definition instanceVariablesString equals: 'a b c'.
	self assert: definition instanceVariables size equals: 3.
	self assert: definition traitComposition equals: 'T1'.
	self assert: (definition instanceVariables allSatisfy: [ :e | e species = InstanceVariableSlot ])! !

!T2TraitMCDefinitionsTest methodsFor: 'tests' stamp: ''!
testDefinitionHasCorrectString
	| t2 definition t1 definitionString |
	t1 := self newTrait: #T1 with: {#x => PropertySlot. #y => PropertySlot }. 
	t2 := self newTrait: #T2 with: {#a => PropertySlot. #b => PropertySlot } uses: t1.

	definition := t2 asClassDefinition.				
	definitionString := String streamContents: [ :s | definition printDefinitionOn: s ].
 	
 	self assert: (definitionString reject: [ :each | each isSeparator]) equals: 'Traitnamed:#T2uses:T1instanceVariableNames:''#a=>PropertySlot#b=>PropertySlot''package:''TraitsV2-Tests-TestClasses'''
	"We cannot use the class printer because this is a mix between instancevariableNames and complex slot."! !

!T2TraitPropagatingSlotChangesTest commentStamp: ''!
Unit test for correct propogation of slot changes for traits!
!T2TraitPropagatingSlotChangesTest methodsFor: 'tests' stamp: ''!
testRemovingSlotToTrait
	| t1 c1 |
	t1 := self newTrait: #T1 with: #(aSlot) uses: {}.
	c1 := self newClass: #C1 with: #() uses: t1.

	self assert: c1 classLayout slotScope parentScope identicalTo: c1 superclass classLayout slotScope.
	self assert: c1 class classLayout slotScope parentScope identicalTo: c1 class superclass classLayout slotScope.
	self assertCollection: (c1 allSlots collect: [:each | each name]) hasSameElements: #(aSlot).

	t1 := self newTrait: #T1 with: #() uses: {}.

	self assert: c1 classLayout slotScope parentScope identicalTo: c1 superclass classLayout slotScope.
	self assert: c1 class classLayout slotScope parentScope identicalTo: c1 class superclass classLayout slotScope.
	self assertCollection: c1 allSlots hasSameElements: #()! !

!T2TraitPropagatingSlotChangesTest methodsFor: 'tests' stamp: ''!
testAddingSlotToTrait
	| t1 c1 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	c1 := self newClass: #C1 with: #() uses: t1.

	self assert: c1 classLayout slotScope parentScope identicalTo: c1 superclass classLayout slotScope.
	self assert: c1 class classLayout slotScope parentScope identicalTo: c1 class superclass classLayout slotScope.
	self assertCollection: c1 slots equals: #().

	t1 := self newTrait: #T1 with: #(aSlot) uses: {}.

	self assert: c1 classLayout slotScope parentScope identicalTo: c1 superclass classLayout slotScope.
	self assert: c1 class classLayout slotScope parentScope identicalTo: c1 class superclass classLayout slotScope.
	self assertCollection: (c1 allSlots collect: [:each | each name]) hasSameElements: #(aSlot)! !

!T2TraitSlotScopeTest commentStamp: ''!
Unit test for trait related slot scopes!
!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testSubClassWithComplexTraitsAfterModificationOfParent
	| t1 c1 c2 t2 t3 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.
	t3 := self newTrait: #T3 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1 + t3.
	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot)
		uses: t2.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.
	self assert: c2 class classLayout slotScope parentScope identicalTo: c2 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testSubClassWithTraitsAfterModificationOfParentSharedPools
	| t1 c1 c2 t2 x1 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1.
	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot)
		uses: t2.

	x1 := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: #X1;
			superclass: SharedPool ].


	c1 := self class classInstaller make: [ :aClassBuilder | 
		aClassBuilder 
			name: #C1;
			traitComposition: t1 asTraitComposition;
			sharedPools: 'X1';
			package: 'TraitsV2-Tests-TestClasses' ].

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.
	self assert: c2 class classLayout slotScope parentScope identicalTo: c2 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testClassWithComplexTraits
	| t1 t2 c1 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1 + t2.

	self assert: c1 classLayout slotScope parentScope identicalTo: c1 superclass classLayout slotScope.
	self assert: c1 class classLayout slotScope parentScope identicalTo: c1 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testSubClassWithTraitsAfterModificationOfParent
	| t1 c1 c2 t2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1.
	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot)
		uses: t2.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.
	self assert: c2 class classLayout slotScope parentScope identicalTo: c2 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testSubClassAndAddComplexTraitAfter
	| t1 c1 c2 t2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: {}.
	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot)
		uses: {}.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.

	c2 := self newClass: #C2 with: #(aSlot otherSlot) uses: t1 + t2.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.
	self assert: c2 class classLayout slotScope parentScope identicalTo: c2 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testSubClassWithTraitsAfterModificationOfParentSharedvariables
	| t1 c1 c2 t2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1.
	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot)
		uses: t2.

	c1 := Object
		subclass: #C1
		uses: t1
		slots: #(aSlot)
		classVariables: #(ClassVar)
		poolDictionaries: ''
		category: 'TraitsV2-Tests-TestClasses'.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.
	self assert: c2 class classLayout slotScope parentScope identicalTo: c2 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testSubClassWithComplexTraitsAfterModification
	| t1 c1 c2 t2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1 + t2.
	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot)
		uses: {}.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.

	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot another)
		uses: {}.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.
	self assert: c2 class classLayout slotScope parentScope identicalTo: c2 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testSubClassWithTraits
	| t1 c1 c2 t2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1.
	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot)
		uses: t2.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.
	self assert: c2 class classLayout slotScope parentScope identicalTo: c2 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testClassWithTraits
	| t1 c1 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	c1 := self newClass: #C1 with: #(aSlot) uses: t1.

	self assert: c1 classLayout slotScope parentScope identicalTo: c1 superclass classLayout slotScope.
	self assert: c1 class classLayout slotScope parentScope identicalTo: c1 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testSubClassWithTraitsAfterModification
	| t1 c1 c2 t2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1.
	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot)
		uses: t2.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.

	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot another)
		uses: t2.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.
	self assert: c2 class classLayout slotScope parentScope identicalTo: c2 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testSubClassAndAddTraitAfter
	| t1 c1 c2 t2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: {}.
	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot)
		uses: {}.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.
	self assert: c2 class classLayout slotScope parentScope identicalTo: c2 class superclass classLayout slotScope! !

!T2TraitSlotScopeTest methodsFor: 'tests' stamp: ''!
testSubClassWithComplexTraits
	| t1 c1 c2 t2 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1 + t2.
	c2 := self
		newClass: #C2
		superclass: c1
		with: #(otherSlot)
		uses: {}.

	self assert: c2 classLayout slotScope parentScope identicalTo: c2 superclass classLayout slotScope.
	self assert: c2 class classLayout slotScope parentScope identicalTo: c2 class superclass classLayout slotScope! !

!T2TraitTest commentStamp: ''!
Unit test for trait handling!
!T2TraitTest methodsFor: 'tests' stamp: ''!
testTraitHaveUsersInstanceVariable
	| t1 aClass |

	t1 := self newTrait: #T1 with: #(users).

	aClass := self newClass: #C1 superclass: Object with: #() uses: {t1}.
	
	self assert: (aClass allSlots anySatisfy: [:e | e name = #users]).
	self assert: (aClass slotNamed: #users) definingClass equals: t1
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
createT3
	| t3 |
	
	"This is a trait with a method with a pragma"
	t3 := self newTrait: #T3 with: #().
	t3
		compile:
			'aMethod
			<aPragma>
			
			^ 42
				'.

	t3 class
		compile:
			'aClassMethod
			<aPragma>
			
			^ 42
				'.

	^ t3! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
createT2
	| t2 |
	t2 := self newTrait: #T2 with: 'd e f' asSlotCollection.
	t2
		compile:
			'setValues2
		d := 1.
		e := 2.
		f := 3.
	'.
	t2
		compile:
			'getValues2
		^ d + e + f + self getValues
	'.
	^ t2! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testUsingTraitInAnonymousSubClassAndRedefiningIt
	| t1 aClass |

	t1 := self newTrait: #T1 with: #().

	aClass := Smalltalk anonymousClassInstaller make: [ :builder |
		builder superclass: Object.
		builder traitComposition: t1.
	].

	self deny: (Object subclasses includes: aClass).
	
	t1 := self newTrait: #T1 with: #(aSlot).
	self assert: (aClass hasSlotNamed: #aSlot).
	
	self deny: (Object subclasses includes: aClass).
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testIndirectSequence
	| t1 t2 t3 c1 obj |
	
	t1 := self createT1.
	t2 := self createT2.
	t3 := self newTrait: #T3 with: #() uses: t1 + t2.
		
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t3.

	obj := c1 new.
	obj setValues.
	obj setValues2.
	
	self assert: (TraitedClass basicUsers includesAll:  { t1 class. t2 class. t3 class. c1 class}).
	
	self assert: obj getValues equals: 6.
	self assert: obj getValues2 equals: 12! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testMethodsAddedInMetaclassPresentInSubclassesAfterChangingSuperclass
	| t1 c1 c2 t2 |
	
	t1 := self createT1.
	t2 := self createT2.
	
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t1.
	c2 := self newClass: #C2 superclass: c1 with: #() uses: {t2}.
	
	self assertCollection: c2 class selectors sorted equals: #().
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: {}.

	self assertCollection: c2 class selectors sorted equals: TraitedClass selectors sorted.
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
createT1
	| t1 |
	t1 := self newTrait: #T1 with: 'a b c' asSlotCollection.
	t1
		compile:
			'setValues
		a := 1.
		b := 2.
		c := 3.
	'.
	t1
		compile:
			'getValues
		^ a + b + c
	'.
	^ t1! !

!T2TraitTest methodsFor: 'tests - empty' stamp: ''!
testEmptyCompositionManagesTEmpty
	
	| t1 |
	t1 := self newTrait: #T1 with: {} trait: TEmpty.
	
	self assert: t1 hasEmptyComposition
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testTraitThatHasAPragmaHasCorrectTraitSourceAfterRecompile
	| t3 aClass |

	t3 := self createT3.

	aClass := self newClass: #C1 superclass: Object with: #() uses: {t3}.
	
	self assert: (aClass >> #aMethod) traitSource equals: t3 asTraitComposition.
	
	(aClass >> #aMethod) recompile.
	
	self assert: (aClass >> #aMethod) traitSource equals: t3 asTraitComposition.! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testSequence
	| t1 t2 c1 obj |
	
	t1 := self createT1.
	t2 := self createT2.
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t1 + t2.

	obj := c1 new.
	obj setValues.
	obj setValues2.
	
	
	self assert: (TraitedClass basicUsers includesAll:  { t1 class. t2 class. c1 class}).
	
	self assert: obj getValues equals: 6.
	self assert: obj getValues2 equals: 12! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testRemovingTraitsUpdatesCategories
	| t1 t2 c1 |
	
	t1 := self createT1.
	t2 := self createT2.
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t1 + t2.
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: {}.		

	c1 organization allMethodSelectors do: [:each | self assert: (c1 includesSelector: each) ].
	c1 class organization allMethodSelectors do: [:each | 
		self assert: (c1 class includesSelector: each) ]! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testClassHavingAnInstanceVariableUsersDifferenThanUsers
	| t1 aClass |

	t1 := self newTrait: #T1 with: #(users).

	aClass := self newClass: #C1 superclass: Object with: #() uses: {}.
	aClass class setTraitComposition: { t1 }.
	
	self assert: (aClass class allSlots anySatisfy: [:e | e name = #users]).
	self assert: (aClass class slotNamed: #users) definingClass equals: t1
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testMethodsAddedInMetaclass
	| t1 c1 |
	
	t1 := self createT1.
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t1.
	
	self assertCollection: c1 class selectors sorted equals: TraitedClass selectors sorted.
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testSelectorsWithExplicitOriginNoTrait
	"Obtain the subset of selectors that are defined either locally or inherited from traits. But, exclude selectors of methods from implicit traits such as TraitedClass"
	| c1 |	
	c1 := self newClass: #C1.
	c1 compile: 'instanceSideMethod'.
	c1 class compile: 'classSideMethod'.
	self assertCollection: c1 selectorsWithExplicitOrigin hasSameElements: #(instanceSideMethod).
	self assertCollection: c1 class selectorsWithExplicitOrigin hasSameElements: #(classSideMethod).
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testRedefiningAClassAsTraitShouldRaiseError

	self newClass: #C1.
	self should: [ self newTrait: #C1 with: #() ] raise: Error ! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testSubclasses
	| t1 t2 |
		
	t1 := self createT1.
	t2 := self newTrait: #T2 with: #(aa bb) uses: t1.

	self deny: t1 hasSubclasses.
	self deny: t2 hasSubclasses.	

	self assert: t1 subclasses isEmpty.
	self assert: t2 subclasses isEmpty.	
		
	self deny: t1 hasSubclasses.
	self deny: t2 hasSubclasses.	

! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testMethodsAddedInMetaclassPresentInSubclassesAfterRemovingSuperclass
	| t1 c1 c2 t2 |
	
	t1 := self createT1.
	t2 := self createT2.
	
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t1.
	c2 := self newClass: #C2 superclass: c1 with: #() uses: {t2}.
	
	self assertCollection: c2 class selectors sorted equals: #().
	c1 removeFromSystem.

	self assertCollection: c2 class selectors sorted equals: TraitedClass selectors sorted.
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testRedefiningATraitAsAClassShouldRaiseError
	
	self newTrait: #C1 with: #().
	self should: [ 	self newClass: #C1 ] raise: Error ! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testRemovingTraitsRemoveTraitedClassMethods
	| t1 t2 c1 |
	
	t1 := self createT1.
	t2 := self createT2.
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t1 + t2.

	self assert: (c1 class includesSelector: #traits).

	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: {}.		

	self deny: (c1 class includesSelector: #traits)! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testSettingAClassInAClassTraitCompositionShouldRaiseAnError

	| t1 c1 |
	t1 :=  self newTrait: #T1 with: 'a' asSlotCollection.
	c1 := self newClass: #C1 with: '' asSlotCollection uses: #().

	self should: [ t1 traitComposition: c1 ] raise: Error.
	self should: [ t1 classTrait traitComposition: c1 ] raise: Error.	! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testClassTraits
	| t1 t2 aClass |

	t1 := self newTrait: #T1 with: #().
	t2 := self newTrait: #T2 with: #().

	t1 classTrait compile: 'aSelector ^ 21'.
	t1 classTrait compile: 'otherSelector ^ 42'.
	
	t2 classTrait compile: 'otherSelector2 ^ 42'.

	aClass := self newClass: #C1 superclass: Object with: #() uses: {}.
	aClass class setTraitComposition: t1 classSide - { #aSelector }. 
	
	self assert: aClass otherSelector equals: 42.	

	aClass := self newClass: #C1 superclass: Object with: #() uses: {}.
	aClass class setTraitComposition: t1 classSide + t2 classSide. 
	
	self assert: aClass otherSelector equals: 42.
	self assert: aClass otherSelector2 equals: 42.
	self assert: aClass aSelector equals: 21.
	

	aClass := self newClass: #C1 superclass: Object with: #() uses: {}.
	aClass class setTraitComposition: t1 classSide @ {#anAlias -> #aSelector}. 
	
	self assert: aClass anAlias equals: 21.
	self assert: aClass aSelector equals: 21.! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testMethodsAddedInMetaclassNotPresentInSubclasses
	| t1 c1 c2 |
	
	t1 := self createT1.
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t1.
	c2 := self newClass: #C2 superclass: c1 with: #() uses: {}.
	
	self assertCollection: c2 class selectors sorted equals: #().
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testClassUsingTraitsDoesNotHaveUsers
	| t1 aClass |

	t1 := self newTrait: #T1 with: #().

	aClass := self newClass: #C1 superclass: Object with: #() uses: {t1}.
	
	self assert: (aClass class allSlots noneSatisfy: [:e | e name = #users])
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testClassTraitThatHasAPragmaHasCorrectTraitSourceAfterRecompile
	| t3 aClass |

	t3 := self createT3.

	aClass := self newClass: #C1 superclass: Object with: #() uses: {t3}.
	
	self assert: (aClass class >> #aClassMethod) traitSource equals: t3 class asTraitComposition.
	
	(aClass class >> #aClassMethod) recompile.
	
	self assert: (aClass class >> #aClassMethod) traitSource equals: t3 class asTraitComposition.
! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testSlotsAreNotDuplicated
	| t1 t2 c1 |
	t1 :=  self newTrait: #T1 with: 'a' asSlotCollection.
	t2 :=  self newTrait: #T2 with: '' asSlotCollection uses: t1.
	c1 := self newClass: #C1 with: '' asSlotCollection uses: t1 + t2.

	self assert: c1 traitComposition slots size equals: c1 traitComposition slots asSet size.
	self assert: c1 traitComposition slots size equals: 1! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testRemovingTraitsRemoveTraitedClassMethodsWithSubclasses
	| t1 t2 c2 c1 |
	
	t1 := self createT1.
	t2 := self createT2.
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t1.
	c2 := self newClass: #C2 superclass: c1 with: '' asSlotCollection uses: t2.

	self assert: (c1 class includesSelector: #traits).
	self deny: (c2 class includesSelector: #traits).
	
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: {}.		

	self deny: (c1 class includesSelector: #traits).
	self assert: (c2 class includesSelector: #traits).
	! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testClassUsesTrait
	| t1 superclass subclass |
	t1 := self newTrait: #T1 with: {}.
	superclass := self newClass: #Superclass with:#() uses: t1.
	subclass := self newClass: #Subclass superclass: superclass with: #() uses: {}.
	
	self assert: (superclass usesTrait: t1).
	self assert: (superclass usesTraitLocally: t1).
	self assert: (subclass usesTrait: t1).
	self assert: (subclass usesTraitLocally: t1) not.! !

!T2TraitTest methodsFor: 'tests' stamp: ''!
testSelectorsWithExplicitOrigin
	"Obtain the subset of selectors that are defined either locally or inherited from traits. But, exclude selectors of methods from implicit traits such as TraitedClass"
	| t1 c1 |
	
	t1 := self newTrait: #T1 with: #().	
	t1 compile: 'instanceSideMethod'.
	t1 class compile: 'classSideMethod'.
	c1 := self newClass: #C1 with: #() uses: t1.
	self assertCollection: c1 selectorsWithExplicitOrigin hasSameElements: #(instanceSideMethod).
	self assertCollection: c1 class selectorsWithExplicitOrigin hasSameElements: #(classSideMethod).
! !

!T2TraitWithAliasTest methodsFor: 'tests' stamp: ''!
testChangingAnAliasedMethodIsIncludedInClass

	| t1 c1 |
	
	t1 := self newTrait: #T1 with: #().
	t1 compile: 'm1 ^ 1'.
	
	c1 := self newClass: #C1 with: #() uses: t1 @ { #m2 -> #m1 }.

	self assert: (c1 includesSelector: #m1).	
	self assert: (c1 includesSelector: #m2).! !

!T2TraitWithAliasTest methodsFor: 'tests' stamp: ''!
testChangingDeleteSlot

	| t1 c1 |
	
	t1 := self newTrait: #T1 with: #(ivar).
	t1 compile: 'ivar ^ ivar'.
	
	c1 := self newClass: #C1 with: #() uses: t1 -- {#ivar}.

	"we got the method #ivar from the Trait"
	self assert: (c1 includesSelector: #ivar).
	"the slot that we got from the trait is now removed"
	self assert: c1 slotNames equals: #().
	"make sure to not modify the Trait"
	self assert: t1 slotNames equals: #(ivar).! !

!T2TraitWithAliasTest methodsFor: 'tests' stamp: ''!
testChangingDeleteSlotAndAlias
	"we can remove a slot from one trait, then rename from the other trait and the class has one var"
	| t1 t2 c1 |
	
	t1 := self newTrait: #T1 with: #(name).
	t2 := self newTrait: #T2 with: #(personName).

	c1 := self newClass: #C1 with: #() uses: (t1 -- #name) + (t2 @@ {#personName-> #name}).

	"In the class we have just name"
	self assert: c1 slotNames equals: #(name).
	"make sure to not modify the Trait"
	self assert: t1 slotNames equals: #(name).
	self assert: t2 slotNames equals: #(personName)! !

!T2TraitWithAliasTest methodsFor: 'tests' stamp: ''!
testChangingRenamedSlot2Slots

	| t1 c1 |
	
	t1 := self newTrait: #T1 with: #(ivar1 ivar2).
	t1 compile: 'ivar2 ^ ivar2'.
	t1 compile: 'ivar1 ^ ivar1'.
	
	c1 := self newClass: #C1 with: #() uses: t1 @@ {  #ivar1 -> #rvar1 . #ivar2 -> #rvar2 }.

	"we got the methods from the Trait"
	self assert: (c1 includesSelector: #ivar1).
	self assert: (c1 includesSelector: #ivar2).
	"but the code got rewritten to access the renamed variable"
	self assert: (c1>>#ivar1) decompile printString equals: 'ivar1

	^ rvar1'.
	
	self assert: (c1>>#ivar2) decompile printString equals: 'ivar2

	^ rvar2'.! !

!T2TraitWithAliasTest methodsFor: 'tests' stamp: ''!
testChangingAnAliasedMethodIsUpdated

	| t1 c1 obj |
	
	t1 := self newTrait: #T1 with: #().
	t1 compile: 'm1 ^ 1'.
	
	c1 := self newClass: #C1 with: #() uses: t1 @ { #m2 -> #m1 }.
	obj := c1 new.

	self assert: obj m1 equals: 1.
	self assert: obj m2 equals: 1.
	
	t1 compile: 'm1 ^ 2'.
	
	self assert: obj m1 equals: 2.
	self assert: obj m2 equals: 2.
! !

!T2TraitWithAliasTest methodsFor: 'tests' stamp: ''!
testChangingDeleteSlotAddVar

	| t1 c1 |
	
	t1 := self newTrait: #T1 with: #(ivar).
	t1 compile: 'ivar ^ ivar'.
	
	c1 := self newClass: #C1 with: #(ivar) uses: t1 -- {#ivar}.

	"we got the method #ivar from the Trait"
	self assert: (c1 includesSelector: #ivar).
	"the slot that we got from the trait is now removed"
	self assert: c1 slotNames equals: #(ivar).
	"make sure to not modify the Trait"
	self assert: t1 slotNames equals: #(ivar).! !

!T2TraitWithAliasTest methodsFor: 'tests' stamp: ''!
testChangingRenamedSlot

	| t1 c1 |
	
	t1 := self newTrait: #T1 with: #(ivar).
	t1 compile: 'ivar ^ ivar'.
	
	c1 := self newClass: #C1 with: #() uses: t1 @@ { #ivar -> #ivar2 }.

	"we got the method #ivar from the Trait"
	self assert: (c1 includesSelector: #ivar).
	"the slot that we got from the trait is now called ivar2"
	self assert: c1 slotNames equals: #(ivar2).
	"was the code rewritten?"
	self assert: (c1>>#ivar) decompile printString equals: 'ivar

	^ ivar2'.
	
	"make sure to not modify the Trait"
	self assert: t1 slotNames equals: #(ivar).! !

!T2TraitWithAliasTest methodsFor: 'tests' stamp: ''!
testChangingDeleteSlot2Slots
	"we can add a slot in the class that we removed from the trait"
	| t1 c1 |
	
	t1 := self newTrait: #T1 with: #(ivar1 ivar2).
	t1 compile: 'ivar2 ^ ivar2'.
	t1 compile: 'ivar1 ^ ivar1'.
	
	c1 := self newClass: #C1 with: #() uses: t1 -- {  #ivar1 . #ivar2 }.

	"we got the methods from the Trait"
	self assert: (c1 includesSelector: #ivar1).
	self assert: (c1 includesSelector: #ivar2).
	
	"the slot that we got from the trait is now removed"
	self assert: c1 slotNames equals: #().
	"make sure to not modify the Trait"
	self assert: t1 slotNames equals: #(ivar1 ivar2).
	! !

!T2TraitWithCategoriesTest commentStamp: ''!
Unit test for categorization of traits!
!T2TraitWithCategoriesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraits
	| t1 t2 |
	
	t1 := self newTrait: #T1 with: #() uses: {}.
	t1 compile: 'm1 ^42.' classified: 'aProtocol'.
	
	t2 := self newTrait: #T2 with: #() uses: t1.	

	self assert: (t1 >> #m1) protocol equals: 'aProtocol'.
	self assert: (t2 >> #m1) protocol equals: 'aProtocol'.
	! !

!T2TraitWithCategoriesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsChanged
	| t1 t2 |
	
	t1 := self newTrait: #T1 with: #() uses: {}.
	t1 compile: 'm1 ^42.' classified: 'aProtocol'.
	
	t2 := self newTrait: #T2 with: #() uses: t1.	

	t1 compile: 'm1 ^42.' classified: 'anotherProtocol'.

	self assert: (t1 >> #m1) protocol equals: 'anotherProtocol'.
	self assert: (t2 >> #m1) protocol equals: 'anotherProtocol'.
	! !

!T2TraitWithCategoriesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsRenamedCategory
	| t1 t2 |
	
	t1 := self newTrait: #T1 with: #() uses: {}.
	t1 compile: 'm1 ^42.' classified: 'aProtocol'.
	t1 compile: 'm2 ^42.' classified: 'aProtocol'.
	
	t2 := self newTrait: #T2 with: #() uses: t1.	
	
	t1 organization renameCategory: 'aProtocol' toBe: 'anotherProtocol'.
	
	self assert: (t1 >> #m1) protocol equals: 'anotherProtocol'.
	self assert: (t2 >> #m1) protocol equals: 'anotherProtocol'.
	self assert: (t1 >> #m2) protocol equals: 'anotherProtocol'.
	self assert: (t2 >> #m2) protocol equals: 'anotherProtocol'.
	! !

!T2TraitWithCategoriesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsAfterCreation
	| t1 t2 |
	
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: t1.	
	t1 compile: 'm1 ^42.' classified: 'aProtocol'.
	
	self assert: (t1 >> #m1) protocol equals: 'aProtocol'.
	self assert: (t2 >> #m1) protocol equals: 'aProtocol'.
	! !

!T2TraitWithCategoriesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsChangedWithoutCompile
	| t1 t2 |
	
	t1 := self newTrait: #T1 with: #() uses: {}.
	t1 compile: 'm1 ^42.' classified: 'aProtocol'.
	
	t2 := self newTrait: #T2 with: #() uses: t1.	

	t1 organization classify: #m1 under: 'anotherProtocol'.

	self assert: (t1 >> #m1) protocol equals: 'anotherProtocol'.
	self assert: (t2 >> #m1) protocol equals: 'anotherProtocol'.
	! !

!T2TraitWithCategoriesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsOverriden
	| t1 t2 |
	
	t1 := self newTrait: #T1 with: #() uses: {}.
	t1 compile: 'm1 ^42.' classified: 'aProtocol'.
	
	t2 := self newTrait: #T2 with: #() uses: t1.	
	t2 compile: 'm1 ^42.' classified: 'anotherProtocol'.
	
	self assert: (t1 >> #m1) protocol equals: 'aProtocol'.
	self assert: (t2 >> #m1) protocol equals: 'anotherProtocol'.
	! !

!T2TraitWithComplexSlotsTest commentStamp: ''!
Unit test for traits with complex slots!
!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
testTraitWithComplexSlotAddClassSlot
	| t1 c1 |
	self createSlotClass.
	t1 := self newTrait: #T1 with: { #ivar }.
	c1 := self newClass: #C1 with: { #aSlot } uses: { t1 }.
	self assert: (c1 traitComposition includesTrait: t1).
	c1 addClassSlot:  #ivar2 => InstanceVariableSlot.
	self assert: c1 instVarNames equals: #( aSlot ivar ).
	self assert: c1 class instVarNames equals: #( ivar2 ).
	self assert: (c1 traitComposition includesTrait: t1)! !

!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
testTraitWithComplexSlotAddSlot
	| t1 c1 |
	self createSlotClass.
	t1 := self newTrait: #T1 with: { #ivar }.
	c1 := self newClass: #C1 with: { #aSlot } uses: { t1 }.
	self assert: (c1 traitComposition includesTrait: t1).
	c1 addSlot: #ivar2 => InstanceVariableSlot.
	self assert: c1 instVarNames equals: #( aSlot ivar2 ivar ).
	self assert: (c1 traitComposition includesTrait: t1)! !

!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
testTraitWithComplexSlotInSuperclass
	| t1 c1 c2 obj |
	
	self createSlotClass.
	t1 := self newTrait: #T1 with: { #otherSlot => (slotClass associatedSlotName: #aSlot) }. 
	c1 := self newClass: #C1 with: { #aSlot. } uses: {t1}.
	c2 := self newClass: #C2 superclass: c1 with: #() uses: #().

	c1 compile: 'initialize
		aSlot := 0'.
	t1 compile: 'doSomething
		otherSlot := ''a'''.
	
	obj := c2 new.
	self assert: (obj instVarNamed: #aSlot) equals: 0.
	obj doSomething.
	self assert: (obj instVarNamed: #aSlot) equals: 1.
! !

!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
createSlotClass
	slotClass := self newClass: #TestSlot superclass: IndexedSlot with: #(associatedSlotName) uses: #().
	slotClass class compile: 'associatedSlotName: aName
		^ self new
			associatedSlotName: aName;
			yourself'.
			
	slotClass compile: 'associatedSlotName: aName
		associatedSlotName:=aName'.
	
	slotClass compile: 'write: aValue to: anObject
		super write: aValue to: anObject.
		anObject instVarNamed: associatedSlotName put: (anObject instVarNamed: associatedSlotName) + 1.
		'! !

!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
testTraitWithComplexSlot
	| t1 c1 obj |
	
	self createSlotClass.
	t1 := self newTrait: #T1 with: { #otherSlot => (slotClass associatedSlotName: #aSlot) }. 
	c1 := self newClass: #C1 with: { #aSlot. } uses: {t1}.

	c1 compile: 'initialize
		aSlot := 0'.
	c1 compile: 'doSomething
		otherSlot := ''a'''.
	
	obj := c1 new.
	self assert: (obj instVarNamed: #aSlot) equals: 0.
	obj doSomething.
	self assert: (obj instVarNamed: #aSlot) equals: 1.
! !

!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
testTraitWithComplexSlotUsedInOtherSlotInSuperclass
	| t1 t2 c1 c2 obj |
	
	self createSlotClass.
	t1 := self newTrait: #T1 with: { #otherSlot => (slotClass associatedSlotName: #aSlot) }. 
	t2 := self newTrait: #T2 with: { #otherSlot }.
	c1 := self newClass: #C1 with: { #aSlot. } uses: {t1. t2 asTraitComposition -- #otherSlot}.

	c1 compile: 'initialize
		aSlot := 0'.
	
	t2 compile: 'doSomething
		otherSlot := ''a'''.
	
	c2 := self newClass: #C2 superclass: c1 with: #() uses: #().
	
	obj := c2 new.
	self assert: (obj instVarNamed: #aSlot) equals: 0.
	obj doSomething.
	self assert: (obj instVarNamed: #aSlot) equals: 1.
! !

!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
testTraitWithComplexSlotAfter
	| t1 c1 obj |
	
	self createSlotClass.
	t1 := self newTrait: #T1 with: {}. 
	c1 := self newClass: #C1 with: { #aSlot. } uses: {t1}.

	c1 compile: 'initialize
		aSlot := 0'.

	t1 := self newTrait: #T1 with: { #otherSlot => (slotClass associatedSlotName: #aSlot) }. 

	c1 compile: 'doSomething
		otherSlot := ''a'''.
	
	obj := c1 new.
	self assert: (obj instVarNamed: #aSlot) equals: 0.
	obj doSomething.
	self assert: (obj instVarNamed: #aSlot) equals: 1.
! !

!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
testTraitWithComplexSlotUsedInOtherSlot
	| t1 t2 c1 obj |
	
	self createSlotClass.
	t1 := self newTrait: #T1 with: { #otherSlot => (slotClass associatedSlotName: #aSlot) }. 
	t2 := self newTrait: #T2 with: { #otherSlot }.
	c1 := self newClass: #C1 with: { #aSlot. } uses: {t1. t2 asTraitComposition -- #otherSlot}.

	c1 compile: 'initialize
		aSlot := 0'.
	
	t2 compile: 'doSomething
		otherSlot := ''a'''.
	
	obj := c1 new.
	self assert: (obj instVarNamed: #aSlot) equals: 0.
	obj doSomething.
	self assert: (obj instVarNamed: #aSlot) equals: 1.
! !

!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
testTraitWithComplexSlotUsedInOtherSlotWithoutTraitComposition
	| t1 t2 c1 obj |
	
	self createSlotClass.
	t1 := self newTrait: #T1 with: { #otherSlot => (slotClass associatedSlotName: #aSlot) }. 
	t2 := self newTrait: #T2 with: { #otherSlot }.
	c1 := self newClass: #C1 with: { #aSlot. } uses: {t1. t2 -- #otherSlot}.

	c1 compile: 'initialize
		aSlot := 0'.
	
	t2 compile: 'doSomething
		otherSlot := ''a'''.
	
	obj := c1 new.
	self assert: (obj instVarNamed: #aSlot) equals: 0.
	obj doSomething.
	self assert: (obj instVarNamed: #aSlot) equals: 1.
! !

!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
testTraitWithComplexSlotUpdatedAfter
	| t1 c1 obj |
	
	self createSlotClass.
	t1 := self newTrait: #T1 with: {}. 
	c1 := self newClass: #C1 with: { #aSlot. } uses: {t1}.

	t1 := self newTrait: #T1 with: { #otherSlot => (slotClass associatedSlotName: #aSlot) }. 

	c1 compile: 'initialize
		aSlot := 0'.
	c1 compile: 'doSomething
		otherSlot := ''a'''.
	
	obj := c1 new.
	self assert: (obj instVarNamed: #aSlot) equals: 0.
	obj doSomething.
	self assert: (obj instVarNamed: #aSlot) equals: 1.
! !

!T2TraitWithComplexSlotsTest methodsFor: 'instance creation' stamp: ''!
testNormalClassWithComplexSlot
	| c1 obj |
	
	self createSlotClass.
	c1 := self newClass: #C1 with: { #aSlot. #otherSlot => (slotClass associatedSlotName: #aSlot) } uses: #().
	c1 compile: 'initialize
		aSlot := 0'.
	c1 compile: 'doSomething
		otherSlot := ''a'''.
	
	obj := c1 new.
	self assert: (obj instVarNamed: #aSlot) equals: 0.
	obj doSomething.
	self assert: (obj instVarNamed: #aSlot) equals: 1.
! !

!T2TraitWithConflictsTest commentStamp: ''!
Unit test for trait conflict scenarios!
!T2TraitWithConflictsTest methodsFor: 'tests' stamp: ''!
testComplexDependencyIsNotConflict
	| t1 t2 c1 t3 t4 t5 t6|
	
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {t1}.
	t3 := self newTrait: #T3 with: #() uses: {t1}.
	t4 := self newTrait: #T4 with: #() uses: {t2 + t3}.
	t5 := self newTrait: #T5 with: #() uses: {t3}.
	t6 := self newTrait: #T6 with: #() uses: {t5 + t4}.

	t1 compile: 'm1 ^42'.

	c1 := self newClass: #C1 with: #(aSlot) uses: t6 + t1.
	
	self assert:c1 new m1 equals: 42.
! !

!T2TraitWithConflictsTest methodsFor: 'tests' stamp: ''!
testDiamonProblemIsNotConflict
	| t1 t2 c1 t3 |
	
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {t1}.
	t3 := self newTrait: #T3 with: #() uses: {t1}.

	t1 compile: 'm1 ^42'.

	c1 := self newClass: #C1 with: #(aSlot) uses: t2 + t3.
		
	self assert: (c1 new perform: #m1) equals: 42.
! !

!T2TraitWithConflictsTest methodsFor: 'tests' stamp: ''!
testNonConflictingTraitsAreNotConflict
	| t1 t2 c1 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	t1 compile: 'm1 ^42'.
	t2 compile: 'm2 ^43'.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1 + t2.
	
	self assert: (c1 new perform: #m1) equals: 42.
	self assert: (c1 new perform: #m2) equals: 43.
! !

!T2TraitWithConflictsTest methodsFor: 'tests' stamp: ''!
testAddingSameDependencyIsNotConflict
	| t1 t2 c1 |
	
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {t1}.

	t1 compile: 'm1 ^42'.

	c1 := self newClass: #C1 with: #(aSlot) uses: t2 + t1.
	
	self assert:c1 new m1 equals: 42.
! !

!T2TraitWithConflictsTest methodsFor: 'tests' stamp: ''!
testDifferentMethodsAreConflict
	| t1 t2 c1 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	t1 compile: 'm1 ^42'.
	t2 compile: 'm1 ^43'.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1 + t2.
	
	self should: [ c1 new m1 ] raise: Error
! !

!T2TraitWithConflictsTest methodsFor: 'tests' stamp: ''!
testSameSourceButDifferentMethodsAreConflict
	| t1 t2 c1 |
	t1 := self newTrait: #T1 with: #() uses: {}.
	t2 := self newTrait: #T2 with: #() uses: {}.

	t1 compile: 'm1 ^42'.
	t2 compile: 'm1 ^42'.

	c1 := self newClass: #C1 with: #(aSlot) uses: t1 + t2.
	
	self should: [c1 new m1] raise: Error
! !

!T2TraitWithPackagesTest commentStamp: ''!
Unit test for trait packaging!
!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraits
	| t1 t2 |
	t1 := self newTrait: #T1 with: #() uses: {} category: self packageName.

	t1 compile: 'm1 ^42.'.

	t2 := self newTrait: #T2 with: #() uses: t1 category: self packageName2.

	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest
	! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
packageName2
	^ 'TestPackage2'! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsAfterCreationOverriden
	| t1 t2 |
	t1 := self newTrait: #T1 with: #() uses: {} category: self packageName.
	t2 := self newTrait: #T2 with: #() uses: t1 category: self packageName2.

	t1 compile: 'm1 ^42.'.

	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest.

	t2 compile: 'm1 ^42.'.

	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest2.
	! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsAfterCreation
	| t1 t2 |
	t1 := self newTrait: #T1 with: #() uses: {} category: self packageName.
	t2 := self newTrait: #T2 with: #() uses: t1 category: self packageName2.

	t1 compile: 'm1 ^42.'.

	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest	
	! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsOverridenModifiedKeepPackage
	| t1 t2 |
	t1 := self newTrait: #T1 with: #() uses: {} category: self packageName.

	t1 compile: 'm1 ^42.'.

	t2 := self newTrait: #T2 with: #() uses: t1 category: self packageName2.

	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest.

	t2 compile: 'm1 ^27.'.
	
	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest2.

	t2 compile: 'm1 ^26.'.

	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest2.
! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
testTraitPackage
	| t1 testPackage |
	t1 := self newTrait: #T1 with: #() uses: {} category: self packageName.
	testPackage := self packageUnderTest.

	self assert: t1 package equals: testPackage! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
testTraitMethodPackage
	| t1 testPackage |
	t1 := self newTrait: #T1 with: #() uses: {} category: self packageName.
	testPackage := self packageUnderTest.

	t1 compile: 'm1 ^42.'.

	self assert: (t1 >> #m1) package equals: testPackage! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
packageUnderTest
	^ RPackageOrganizer default packageNamed: self packageName! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsOverridenAndRemoved
	| t1 t2 |
	t1 := self newTrait: #T1 with: #() uses: {} category: self packageName.

	t1 compile: 'm1 ^42.'.

	t2 := self newTrait: #T2 with: #() uses: t1 category: self packageName2.

	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest.

	t2 compile: 'm1 ^27.'.
	
	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest2.

	t2 removeSelector: #m1.

	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest.
! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
packageName
	^ 'TestPackage'! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsOverriden
	| t1 t2 |
	t1 := self newTrait: #T1 with: #() uses: {} category: self packageName.

	t1 compile: 'm1 ^42.'.

	t2 := self newTrait: #T2 with: #() uses: t1 category: self packageName2.

	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest.

	t2 compile: 'm1 ^27.'.
	
	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest2
! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
testPackageOfMethodFromTraitsRemoved
	| t1 t2 |
	t1 := self newTrait: #T1 with: #() uses: {} category: self packageName.

	t1 compile: 'm1 ^42.'.

	t2 := self newTrait: #T2 with: #() uses: t1 category: self packageName2.

	self assert: (t1 >> #m1) package equals: self packageUnderTest.
	self assert: (t2 >> #m1) package equals: self packageUnderTest.

	self assert: (RPackageOrganizer default packageDefiningOrExtendingSelector: #m1 inClassNamed: #T1) equals: self packageUnderTest.

	t1 removeSelector: #m1.
	
	self assert: (t1 organization categoryOfElement: #m1) isNil.
	self assert: (t2 organization categoryOfElement: #m1) isNil.	
	
	self assert: (RPackageOrganizer default packageDefiningOrExtendingSelector: #m1 inClassNamed: #T1) isNil.
	self assert: (RPackageOrganizer default packageDefiningOrExtendingSelector: #m1 inClassNamed: #T2) isNil.	! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
packageUnderTest2
	^ RPackageOrganizer default packageNamed: self packageName2! !

!T2TraitWithPackagesTest methodsFor: 'tests' stamp: ''!
testPackageOfRemovedTrait
	| t1 t2 |
	t1 := self newTrait: #T1 with: #() uses: {} category: self packageName.
	t2 := self newTrait: #T2 with: #() uses: t1 category: self packageName2.

	self assert: t1 package equals: self packageUnderTest.
	self assert: t2 package equals: self packageUnderTest2.

	self assert: (RPackageOrganizer default packageOfClassNamed: #T1) equals: self packageUnderTest.
	self assert: (RPackageOrganizer default packageOfClassNamed: #T2) equals: self packageUnderTest2.

	t2 removeFromSystem.

	self assert: (RPackageOrganizer default packageOfClassNamed: #T1) equals: self packageUnderTest.
	self assert: (RPackageOrganizer default packageOfClassNamed: #T2) isNil.
	
	t1 removeFromSystem.
	
	self assert: (RPackageOrganizer default packageOfClassNamed: #T1) isNil.
	self assert: (RPackageOrganizer default packageOfClassNamed: #T2) isNil.
! !

!T2TraitWithSlotsTest commentStamp: ''!
Unit test for traits with slots!
!T2TraitWithSlotsTest methodsFor: 'tests' stamp: ''!
testHavingASlotAlreadyInTheHierarchy
	| t1 t2 c1 |
	
	t1 := self newTrait: #T1 with: #(anSlot) uses: {}.
	t2 := self newTrait: #T2 with: #(s2) uses: {t1}.

	t1 compile: 'm1 ^ anSlot:=42'.

	c1 := self newClass: #C1 with: #(aSlot s2) uses: t2 + t1.
		
	self assert: (c1 new perform: #m1) equals: 42.
! !

!T2TraitWithSlotsTest methodsFor: 'tests' stamp: ''!
testClassUsingStatefulTraits

	| t1 c1 |

	t1 := self newTrait: #T1 with: #(aSlot).
	c1 := self newClass: #C1 superclass: Object with: #() uses: { t1 }. 

	self assertCollection: c1 slots hasSameElements: { c1 slotNamed: #aSlot }.! !

!T2TraitWithSlotsTest methodsFor: 'tests' stamp: ''!
testClassUsingStatefulTraitsAndLocalSlots

	| t1 c1 |

	t1 := self newTrait: #T1 with: #(aSlot).
	c1 := self newClass: #C1 superclass: Object with: #(anotherSlot) uses: { t1 }. 

	self assertCollection: c1 slots hasSameElements: { c1 slotNamed: #aSlot. c1 slotNamed: #anotherSlot }! !

!T2TraitWithSlotsTest methodsFor: 'tests' stamp: ''!
testDefiningClass

	| t1 c1 |
	
	t1 := self createT1.
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t1.
	
	self assert: (t1 slotNamed: #a) definingClass equals: t1.
	self assert: (t1 slotNamed: #b) definingClass equals: t1.	
	self assert: (t1 slotNamed: #c) definingClass equals: t1.

	self assert: (c1 slotNamed: #a) definingClass equals: t1.
	self assert: (c1 slotNamed: #b) definingClass equals: t1.	
	self assert: (c1 slotNamed: #c) definingClass equals: t1.
	self assert: (c1 slotNamed: #g) definingClass equals: c1.
	self assert: (c1 slotNamed: #h) definingClass equals: c1.
! !

!T2TraitWithSlotsTest methodsFor: 'tests' stamp: ''!
createT1
	| t1 |
	t1 := self newTrait: #T1 with: 'a b c' asSlotCollection.
	t1
		compile:
			'setValues
		a := 1.
		b := 2.
		c := 3.
	'.
	t1
		compile:
			'getValues
		^ a + b + c
	'.
	^ t1! !

!T2TraitWithSlotsTest methodsFor: 'tests' stamp: ''!
testDiamonProblemIsNotConflict
	| t1 t2 c1 t3 t4 |
	
	t1 := self newTrait: #T1 with: #(anSlot) uses: {}.
	t2 := self newTrait: #T2 with: #(s2) uses: {t1}.
	t3 := self newTrait: #T3 with: #(s3) uses: {t1}.
	t4 := self newTrait: #T4 with: #(s4) uses: {t1}.

	t1 compile: 'm1 ^ anSlot:=42'.

	c1 := self newClass: #C1 with: #(aSlot s2) uses: t2 + t3.
	c1 traitComposition: c1 traitComposition + t4.
		
	self assert: (c1 new perform: #m1) equals: 42.
! !

!T2TraitWithSlotsTest methodsFor: 'tests' stamp: ''!
testOwningClass

	| t1 c1 |
	
	t1 := self createT1.
	c1 := self newClass: #C1 with: 'g h' asSlotCollection uses: t1.
	
	self assert: (t1 slotNamed: #a) owningClass equals: t1.
	self assert: (t1 slotNamed: #b) owningClass equals: t1.	
	self assert: (t1 slotNamed: #c) owningClass equals: t1.

	self assert: (c1 slotNamed: #a) owningClass equals: c1.
	self assert: (c1 slotNamed: #b) owningClass equals: c1.	
	self assert: (c1 slotNamed: #c) owningClass equals: c1.
	self assert: (c1 slotNamed: #g) owningClass equals: c1.
	self assert: (c1 slotNamed: #h) owningClass equals: c1.
	

! !

!T2TraitWithSlotsTest methodsFor: 'tests' stamp: ''!
testRedefiningSuperclass

	| t1 c1 t2 c2 |
	
	t1 := self newTrait: #T1 with: #(a b).
	t2 := self newTrait: #T2 with: #(g h).

	c1 := self newClass: #C1 with: #(c d) uses: t1.
	c2 := self newClass: #C2 superclass: c1 with: #(e) uses: t2.
	
	self assert: (c2 localSlots collect: [:each | each name]) equals: #(e).
	self assert: (c1 localSlots collect: [:each | each name]) equals: #(c d).
	self assertCollection: (c2 allSlots collect: [:each | each name]) hasSameElements: #(c d a b e g h).
	self assertCollection: (c1 allSlots collect: [:each | each name]) hasSameElements: #(c d a b).	

	c1 := self newClass: #C1 with: #(c d) uses: t1.	

	self assert: (c2 localSlots collect: [:each | each name]) equals: #(e).
	self assert: (c1 localSlots collect: [:each | each name]) equals: #(c d).
	self assertCollection: (c2 allSlots collect: [:each | each name]) hasSameElements: #(c d a b e g h).
	self assertCollection: (c1 allSlots collect: [:each | each name]) hasSameElements: #(c d a b).	! !

!T2TraitWithSlotsTest methodsFor: 'tests' stamp: ''!
testRedefiningTrait

| t1 |

t1 := self newTrait: #T1 with: #().
t1 := self newTrait: #T1 with: #(aSlot).

self deny: t1 slots isEmpty.

! !

!T2UsingTraitsWithSlotsTest methodsFor: 'tests' stamp: ''!
testRedefinitionKeepsSlots
	| t1 c1 |
	t1 := self newTrait: #T1 with: #(a b c).
	t1 classTrait slots: #(aSlot).
	c1 := self newClass: #C1 with: {} uses: {t1}.

	self assertEmpty: c1 localSlots.
	self assertEmpty: c1 class localSlots.

	c1 addSlot: #d.

	self assertCollection: (c1 localSlots collect: [:each | each name]) hasSameElements: {#d}.
	self assertEmpty: c1 class localSlots! !

!TAbleToRotate commentStamp: ''!
A trait for morphs able to rotate!
!TAbleToRotate methodsFor: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!TAbleToRotate methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!TAbleToRotate methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!TAbleToRotate methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!TAbleToRotate methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!TAbleToRotate methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!TAbleToRotate methodsFor: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!TAbleToRotate classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TAbleToRotate classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TAbleToRotate classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TAbleToRotate classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TAbleToRotate classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TAbleToRotate classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TAbleToRotate classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TAbleToRotate classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TAbleToRotate classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAbleToRotate classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TAbleToRotate classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TAbleToRotate classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TAbleToRotate classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TAbleToRotate classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TAbleToRotate classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TAbleToRotate classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TAbleToRotate classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TAbleToRotate classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAbleToRotate classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TAbleToRotate classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TAbleToRotate classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TAbleToRotate classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TAbleToRotate classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TAbleToRotate classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TAbleToRotate classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TAbleToRotate classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TAddForIdentityCollectionsTest commentStamp: ''!
A trait for test purposes!
!TAddForIdentityCollectionsTest methodsFor: 'tests - adding for identity collections' stamp: ''!
testTAddIfNotPresentWithElementCopy
" test specific to IdentityCollections for wich #addIfNotPresent should use == check insted of =."
	| added oldSize collection element elementCopy |
	collection := self identityCollectionWithElementsCopyNotIdentical   .
	oldSize := collection  size.
	
	element := collection  anyOne .
	elementCopy := element copy.
	self deny: (collection  includes: elementCopy ).
	
	added := collection  addIfNotPresent: elementCopy  .
	self assert: added == elementCopy . "test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection  size = (oldSize + 1)).! !

!TAddForIdentityCollectionsTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAddForIdentityCollectionsTest
	
	self identityCollectionWithElementsCopyNotIdentical.
	self identityCollectionWithElementsCopyNotIdentical  do: [ : each | self deny: each == each copy ].! !

!TAddForIdentityCollectionsTest methodsFor: 'requirements' stamp: ''!
identityCollectionWithElementsCopyNotIdentical
	"Returns a collection including elements for which #copy doesn't return the same object."
	^ self explicitRequirement! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TAddForIdentityCollectionsTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TAddForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TAddForUniquenessTest commentStamp: ''!
A trait for test purposes!
!TAddForUniquenessTest methodsFor: 'tests - adding uniquely' stamp: ''!
testAddNewElementIncrementsSize
	| added oldSize |
	oldSize := self collectionWithoutElement size.
	self deny: (self collectionWithoutElement includes: self element).
	added := self collectionWithoutElement add: self element.
	self assert: added = self element.
	self assert: (self collectionWithoutElement includes: self element).
	self assert: self collectionWithoutElement size = (oldSize + 1)! !

!TAddForUniquenessTest methodsFor: 'requirements' stamp: ''!
collectionWithoutElement
	" return a collection that does not include 'element' "
	^ self explicitRequirement! !

!TAddForUniquenessTest methodsFor: 'tests - adding uniquely' stamp: ''!
testTAddIfNotPresentWithNewElement
	| added oldSize |
	oldSize := self collectionWithoutElement size.
	self deny: (self collectionWithoutElement includes: self element).
	added := self collectionWithoutElement addIfNotPresent: self element.
	self assert: added = self element.
	self assert: (self collectionWithoutElement includes: self element).
	self assert: self collectionWithoutElement size = (oldSize + 1)! !

!TAddForUniquenessTest methodsFor: 'tests - adding uniquely' stamp: ''!
testAddAlreadyThereDoesNotCount

	| added oldSize |
	oldSize := self collectionWithElement size.
	self assert: (self collectionWithElement includes: self element).

	added := self collectionWithElement add: self element.
	
	self assert: added = self element.
	self assert: (self collectionWithElement includes: self element).
	self assert: self collectionWithElement size = oldSize.! !

!TAddForUniquenessTest methodsFor: 'requirements' stamp: ''!
element
	^ self explicitRequirement! !

!TAddForUniquenessTest methodsFor: 'tests - adding uniquely' stamp: ''!
testTAddIfNotPresentWithElementAlreadyIn

	| added oldSize |
	oldSize := self collectionWithElement size.
	self assert: (self collectionWithElement includes: self element).

	added := self collectionWithElement addIfNotPresent: self element.
	
	self assert: added = self element.
	self assert: (self collectionWithElement includes: self element).
	self assert: self collectionWithElement size = oldSize.! !

!TAddForUniquenessTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAddForUniquenessTest
	self element.
	self collectionWithElement.
	self assert: (self collectionWithElement includes: self element).
	self collectionWithoutElement.
	self deny: (self collectionWithoutElement includes: self element)! !

!TAddForUniquenessTest methodsFor: 'requirements' stamp: ''!
collectionWithElement
" return a collection already including 'element'    "
	^ self explicitRequirement! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TAddForUniquenessTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TAddForUniquenessTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TAddForUniquenessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TAddForUniquenessTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TAddForUniquenessTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TAddForUniquenessTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAddForUniquenessTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TAddForUniquenessTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TAddForUniquenessTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TAddForUniquenessTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAddForUniquenessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TAddForUniquenessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TAddForUniquenessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TAddForUniquenessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TAddForUniquenessTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TAddForUniquenessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TAddTest commentStamp: ''!
A trait for test purposes!
!TAddTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRequirementsOfTAddTest

	self collectionWithElement.
	self otherCollection.
	self element.
	self assert: (self collectionWithElement includes: self element).
	self deny: (self otherCollection includes: self element)! !

!TAddTest methodsFor: 'requirements' stamp: ''!
otherCollection
	"Returns a collection that does not include what is returned by #element."
	^ self explicitRequirement! !

!TAddTest methodsFor: 'tests - adding' stamp: ''!
testTAddAll

	| added collection toBeAdded |
	collection := self collectionWithElement.
	toBeAdded := self otherCollection.
	added := collection addAll: toBeAdded.
	self assert: added == toBeAdded .	"test for identiy because #addAll: has not reason to copy its parameter."
	self assert: (collection includesAll: toBeAdded )! !

!TAddTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithNewElement

	| added oldSize collection elem |
	collection := self otherCollection.
	oldSize := collection size.
	elem := self element.
	self deny: (collection includes: elem ).
	
	added := collection  addIfNotPresent: elem .
	self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: (oldSize + 1).! !

!TAddTest methodsFor: 'requirements' stamp: ''!
element
	"Returns an object that can be added to the collection returned by #collection."
	^ self explicitRequirement! !

!TAddTest methodsFor: 'tests - adding' stamp: ''!
testTAddIfNotPresentWithElementAlreadyIn

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	oldSize := collection size.
	anElement := self element.
	self assert: (collection includes: anElement).
	
	added := collection addIfNotPresent: anElement.
	
	self assert: added == anElement .	"test for identiy because #add: has not reason to copy its parameter."
	self assert: collection size equals: oldSize! !

!TAddTest methodsFor: 'requirements' stamp: ''!
collectionWithElement
	"Returns a collection that already includes what is returned by #element."
	^ self explicitRequirement! !

!TAddTest methodsFor: 'tests - adding' stamp: ''!
testTAdd
	| added collection |
	collection := self otherCollection.
	added := collection add: self element.
	
	self assert: added == self element.	"test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection includes: self element)	.
	self assert: (self collectionWithElement includes: self element).! !

!TAddTest methodsFor: 'tests - adding' stamp: ''!
testTAddTwice

	| added oldSize collection anElement |
	collection := self collectionWithElement.
	anElement := self element.
	oldSize := collection size.
	added := collection 
		add: anElement;
		add: anElement.
	self assert: added == anElement.	"test for identiy because #add: has not reason to copy its parameter."
	self assert: (collection includes: anElement).
	self assert: collection size equals: (oldSize + 2)! !

!TAddTest methodsFor: 'tests - adding' stamp: ''!
testTAddWithOccurrences
	| 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 equals: (oldSize + 5)! !

!TAddTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TAddTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TAddTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TAddTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TAddTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TAddTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TAddTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TAddTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TAddTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAddTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TAddTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TAddTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TAddTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TAddTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TAddTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TAddTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TAddTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TAddTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAddTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TAddTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TAddTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TAddTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TAddTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TAddTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TAddTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TAddTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TApplyingOnClassSide commentStamp: ''!
Kernel trait for applying on the class side!
!TApplyingOnClassSide methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper
	^self explicitRequirement.! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TApplyingOnClassSide classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TApplyingOnClassSide classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TApplyingOnClassSide classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TApplyingOnClassSide classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TApplyingOnClassSide classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TApplyingOnClassSide classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TApplyingOnClassSide classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TApplyingOnClassSide classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TApplyingOnClassSide classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TApplyingOnClassSide classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: arg1 on: arg2

	| tmp1 |
	arg2 cr.
	tmp1 := self selectorsToFileOutCategory: arg1.
	tmp1 do: [ :arg3 | 
		((self isLocalSelector: arg3) or: [ 
			 (self traitComposition selectors includes: arg3) not ]) ifTrue: [ 
			self printMethodChunk: arg3 on: arg2 ] ]! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TApplyingOnClassSide classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TApplyingOnClassSide classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TApplyingOnClassSide classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TApplyingOnClassSide classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TApplyingOnClassSide classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TApplyingOnClassSide classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TAsStringCommaAndDelimiterSequenceableTest commentStamp: ''!
A trait for test purposes!
!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringMore

	"self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'.
	self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3'"

	| result resultAnd index allElementsAsString |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
 
	index := 1.
	(result findBetweenSubstrings: ',' )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 findBetweenSubstrings: ',' ).
	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 )]
				].
		
		
			].! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
" return a collection of size 1 including one element"
	^ self explicitRequirement! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'requirements' stamp: ''!
empty

	^ self explicitRequirement! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'requirements' stamp: ''!
nonEmpty

	^ self explicitRequirement! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	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)]]! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsCommaStringOne
	
	"self assert: self oneItemCol asCommaString = '1'.
	self assert: self oneItemCol asCommaStringAnd = '1'."

	self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString).
	self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString)! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result index |
	delim := ', '.
	result := ''.
	multiItemStream := ReadWriteStream on: result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	index:=1.
	(result findBetweenSubstrings: delim)do:
		[:each |
			self assert: each= ((self nonEmpty at:index) asString).
			index:=index+1 ]! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty

	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |
	delim := ', '.
	result := ''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TAsStringCommaAndDelimiterSequenceableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TAsStringCommaAndDelimiterTest commentStamp: ''!
A trait for test purposes!
!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringMore

	| result resultAnd allElementsAsString tmp |
	result:= self nonEmpty asCommaString .
	resultAnd:= self nonEmpty asCommaStringAnd .
	tmp :=OrderedCollection new. 
	self nonEmpty do: [ :each | tmp add: each asString].

	"verifying result  :"
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString do:
		[:each |
		self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each).
		].
	
	"verifying esultAnd :"
	allElementsAsString:=(resultAnd findBetweenSubstrings: ', ' ).
	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')].
			].! !

!TAsStringCommaAndDelimiterTest methodsFor: 'requirements' stamp: ''!
nonEmpty1Element
" return a collection of size 1 including one element"
	^ self explicitRequirement! !

!TAsStringCommaAndDelimiterTest methodsFor: 'requirements' stamp: ''!
empty

	^ self explicitRequirement! !

!TAsStringCommaAndDelimiterTest methodsFor: 'requirements' stamp: ''!
nonEmpty

	^ self explicitRequirement! !

!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastOne

	| delim oneItemStream result |
	
	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim last: 'and'.
	oneItemStream  do:
		[:each1 |
		self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ]
		 ].! !

!TAsStringCommaAndDelimiterTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsStringCommaAndDelimiterTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty.
	self nonEmpty1Element.
	self assert: self nonEmpty1Element size = 1! !

!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastMore

	| delim multiItemStream result last allElementsAsString tmp |
	
	delim := ', '.
	last := ' and '.
	result:=''.
	tmp := self nonEmpty collect: [:each | each asString].
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim last: last.
	result := multiItemStream contents.
	allElementsAsString:=(result findBetweenSubstrings: delim ).
	tmp do:[:each |
		self assert: (tmp occurrencesOf: each) = (allElementsAsString occurrencesOf: each)].
	self assert: ((allElementsAsString at: (allElementsAsString size - 1))=('and'))! !

!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterEmpty
	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' ]) equals: ''! !

!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringEmpty

	self assert: self empty asCommaString = ''.
	self assert: self empty asCommaStringAnd = ''.! !

!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsCommaStringOne
	
	self nonEmpty1Element do: 
		[:each | 
		self assert: each asString =self nonEmpty1Element  asCommaString.
		self assert: each asString=self nonEmpty1Element  asCommaStringAnd.].! !

!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterMore

	| delim multiItemStream result allElementsAsString tmp |
	
	
	delim := ', '.
	result:=''.
	tmp:= self nonEmpty collect:[:each | each asString].
	multiItemStream := ReadWriteStream on:result.
	self nonEmpty  asStringOn: multiItemStream delimiter: delim.
	result := multiItemStream contents.
	allElementsAsString := (result findBetweenSubstrings: delim ).
	tmp do:
		[:each |
		self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each).
		].! !

!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterLastEmpty
	self assert: (String streamContents: [ :emptyStream | self empty asStringOn: emptyStream delimiter: ', ' last: 'and' ]) equals: ''! !

!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''!
testAsStringOnDelimiterOne

	| delim oneItemStream result |

	delim := ', '.
	result:=''.
	oneItemStream := ReadWriteStream on: result.
	self nonEmpty1Element  asStringOn: oneItemStream delimiter: delim.
	oneItemStream  do:
		[:each1 |
		self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ]
		 ].! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TAsStringCommaAndDelimiterTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TAssertable commentStamp: ''!
I think it is not used yet. I think it is a Trait so that we can make things assertable and not need to subclass from TestCase for example. I may expect that TestCase uses such Trait instead of implementing all those methods,  but it is not the case. Even more, TAssertable users size -> 0. 

So...seems a work half done. Adrian Kuhn introduce it. Check
http://forum.world.st/template/NamlServlet.jtp?macro=search_page&node=1294837&query=TAssertable!
!TAssertable methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: (ex description includesSubstring: aString) ]
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
assertEmpty: aCollection
	^ self assert: aCollection isEmpty description: aCollection asString , ' should have been empty'! !

!TAssertable methodsFor: 'asserting' stamp: ''!
assert: aBooleanOrBlock description: aStringOrBlock resumable: resumableBoolean 
	| exception |
	aBooleanOrBlock value
		ifFalse: 
			[|aString|
			aString := aStringOrBlock value.
			exception := resumableBoolean
						ifTrue: [self classForTestResult resumableFailure]
						ifFalse: [self classForTestResult failure].
			exception signal: aString]
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
deny: actual equals: expected
	^ self
		deny: expected = actual
		description: [self unexpectedEqualityStringBetween: actual and: expected]! !

!TAssertable methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
skipUnless: aBooleanOrBlock
	" If the assumption in aBooleanOrBlock is not true, abandon the running test
	and mark it as passed. "
	aBooleanOrBlock value ifFalse:
			[ TestSkipped signal: 'Assumption in #skipUnless: failed' ]! !

!TAssertable methodsFor: 'asserting' stamp: ''!
assert: actualNumber closeTo: expectedNumber
	^ self
		assert: (actualNumber closeTo: expectedNumber)
		description: [self comparingStringBetween: actualNumber and: expectedNumber]! !

!TAssertable methodsFor: 'asserting' stamp: ''!
assert: aBooleanOrBlock description: aStringOrBlock
	aBooleanOrBlock value ifFalse: [
		| message |
		message := aStringOrBlock value.
		self classForTestResult failure signal: message]
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
assert: actual identicalTo: expected
	^ self
		assert: expected == actual
		description: [self comparingIdentityStringBetween: actual and: expected]! !

!TAssertable methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anExceptionalEvent 
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: true]
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
fail: aDescriptionString

	^self assert: false description: aDescriptionString! !

!TAssertable methodsFor: 'asserting' stamp: ''!
signalFailure: aString
	self classForTestResult failure signal: aString! !

!TAssertable methodsFor: 'asserting' stamp: ''!
assertCollection: actual equals: expected
	"Specialized test method that generates a proper error message for collection"
	^ self
		assert: expected = actual
		description: [ self comparingCollectionBetween: actual and: expected ]! !

!TAssertable methodsFor: 'asserting' stamp: ''!
deny: aBooleanOrBlock

	self assert: aBooleanOrBlock value not
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
shouldFix: aBlock 
	"Run the block expecting an Exception. Throw an assertion failure if the block does NOT throw an exception."
	^self should: aBlock raise: Exception! !

!TAssertable methodsFor: 'private' stamp: ''!
unexpectedEqualityStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: 'Unexpected equality of ';
				nextPutAll: actual fullPrintString;
				nextPutAll: ' and ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!TAssertable methodsFor: 'asserting' stamp: ''!
assert: actual equals: expected
	^ self
		assert: actual = expected
		description: [self comparingStringBetween: actual and: expected]! !

!TAssertable methodsFor: 'asserting' stamp: ''!
skip
	"Don't run this test, and don't mark it as failure"
	TestSkipped signal! !

!TAssertable methodsFor: 'private' stamp: ''!
unexpectedIdentityEqualityStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: 'Unexpected identity equality of ';
				nextPutAll: actual fullPrintString;
				nextPutAll: ' and ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!TAssertable methodsFor: 'asserting' stamp: ''!
denyCollection: actual equals: expected
	"Specialized test method that generates a proper error message for collection"
	^ self
		deny: expected = actual
		description: [ self unexpectedEqualityStringBetween: actual and: expected ]! !

!TAssertable methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock
	self deny: aBlock value
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: substring description: aString 
	 
	^self
		assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: substring) not
		description: aString
! !

!TAssertable methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent description: aString  
 
	^self
		assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not
		description: aString
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
deny: aBooleanOrBlock description: aString resumable: resumableBoolean 
	self
		assert: aBooleanOrBlock value not
		description: aString
		resumable: resumableBoolean
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
deny: actual identicalTo: expected
	^ self
		deny: expected == actual
		description: [self unexpectedIdentityEqualityStringBetween: actual and: expected]! !

!TAssertable methodsFor: 'asserting' stamp: ''!
should: aBlock notTakeMoreThan: aDuration
    "Evaluate aBlock and if it takes more than given duration
    to run we report a test failure. "

	^ aBlock valueWithin: aDuration onTimeout: [
		self 
			assert: false 
			description: ['Block evaluation took more than the expected <1p>' expandMacrosWith: aDuration]
	]
	
! !

!TAssertable methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent  
	 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: substring description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: substring)
		description: aString
! !

!TAssertable methodsFor: 'asserting' stamp: ''!
assertCollection: actual hasSameElements: expected
	"Assert that a collection contains the same elements as the given collection. Order is not checked, only the presence/absence of elements."
	| missingElements additionalElements |
	
	additionalElements := actual difference: expected.
	missingElements := expected difference: (actual intersection: expected).
	self 
		assert: (additionalElements isEmpty and: [ missingElements isEmpty ])
		description: (String streamContents: 
			[:stream |
			stream
				nextPutAll: 'Given Collections do not match!!'; lf;
				tab; nextPutAll: 'additions : '; print: additionalElements asArray; lf;
				tab; nextPutAll: 'missing: '; print: missingElements asArray; lf ])! !

!TAssertable methodsFor: 'asserting' stamp: ''!
denyEmpty: aCollection
	^ self assert: aCollection isNotEmpty description: aCollection asString , ' should not have been empty'! !

!TAssertable methodsFor: 'private' stamp: ''!
comparingStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: 'Got ';
				nextPutAll: actual fullPrintString;
				nextPutAll: ' instead of ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!TAssertable methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: substring description: aString  
	 
	^self 
		assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: substring) not
		description: aString
! !

!TAssertable methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: substring description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: substring)
		description: aString
! !

!TAssertable methodsFor: 'asserting' stamp: ''!
deny: aBooleanOrBlock description: aString
	self assert: aBooleanOrBlock value not description: aString
			! !

!TAssertable methodsFor: 'private' stamp: ''!
comparingIdentityStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: actual fullPrintString;
				nextPutAll: ' is not identical to ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!TAssertable methodsFor: 'asserting' stamp: ''!
should: aBlock description: aString
	self assert: aBlock value description: aString
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: (ex description includesSubstring: aString) not ]
			! !

!TAssertable methodsFor: 'extensions' stamp: ''!
skip: aComment
	"Don't run this test, and don't mark it as failure"
	TestSkipped signal: aComment! !

!TAssertable methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock description: aString
	self deny: aBlock value description: aString
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
should: aBlock
	self assert: aBlock value
			! !

!TAssertable methodsFor: 'asserting' stamp: ''!
should: aBlock notTakeMoreThanMilliseconds: anInteger
    "For compatibility with other Smalltalks"

   self should: aBlock notTakeMoreThan: (Duration milliSeconds: anInteger).! !

!TAssertable methodsFor: 'asserting' stamp: ''!
fail

	^self assert: false! !

!TAssertable methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)
		description: aString
			! !

!TAssertable methodsFor: 'private' stamp: ''!
comparingCollectionBetween: left and: right
	| additionalLeft additionalRight sortBlock|
	
	"use a very slow sort block"
	sortBlock := [ :a :b | a asString <= b asString ].
	additionalLeft := (left difference: right) sorted: sortBlock.
	additionalRight := (right difference: left) sorted: sortBlock. 
	
	^ String streamContents: [:stream |
		stream
			nextPutAll: 'Given Collections do not match. Got '; lf;
			tab; nextPutAll: 'left := '; print: left; nextPut: $.; lf;
			nextPutAll: ' instead of ';
			tab; nextPutAll: ' right :='; print: left; nextPut: $.; lf.
		left size = right size
			ifFalse: [ 
				stream 
					nextPutAll: 'Collection size does not match: left='; 
					print: left size;
					nextPutAll: ' vs. right=';
					print: right size; lf ].
		additionalLeft isEmpty
			ifFalse: [ 
				stream 
					nextPutAll: 'Got ';
					print: additionalLeft size;
					nextPutAll: ' additional element(s) in the left collection: ';
					tab; print: additionalLeft  ].
		additionalRight isEmpty
			ifFalse: [ 
				stream 
					nextPutAll: 'Got ';
					print: additionalRight size;
					nextPutAll: ' additional element(s) in the right collection: ';
					tab; print: additionalRight  ]]! !

!TAssertable methodsFor: 'asserting' stamp: ''!
classForTestResult
	"Returns the class of the test result"
	^ TestResult! !

!TAssertable methodsFor: 'asserting' stamp: ''!
denyCollection: actual hasSameElements: expected
	"Deny that a collection contains the same elements as the given collection. Order is not checked, only the presence/absence of elements."

	self
		deny: ((actual difference: expected) isEmpty and: [ (expected difference: actual) isEmpty ])
		description: 'Given collections match!!'! !

!TAssertable methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock

	^[aBlock value.
 	false] 
		on: anException
		do: [:exception | 
			anotherBlock value: exception.
			exception return: true]! !

!TAssertable methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anException withExceptionDo: anotherBlock 

	^self assert: (self executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock)! !

!TAssertable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TAssertable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TAssertable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TAssertable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TAssertable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TAssertable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TAssertable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TAssertable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TAssertable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAssertable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TAssertable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TAssertable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TAssertable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TAssertable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TAssertable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TAssertable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TAssertable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TAssertable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TAssertable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TAssertable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TAssertable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TAssertable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TAssertable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TAssertable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TAssertable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TAssertable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TBeginsEndsWith commentStamp: ''!
A trait for test purposes!
!TBeginsEndsWith methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWithEmpty
	
	self deny: (self nonEmpty endsWith: self empty).
	self deny: (self empty endsWith: self nonEmpty)! !

!TBeginsEndsWith methodsFor: 'requirements' stamp: ''!
empty
	self explicitRequirement.! !

!TBeginsEndsWith methodsFor: 'requirements' stamp: ''!
nonEmpty
	self explicitRequirement.! !

!TBeginsEndsWith methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWith
	
	self assert: (self nonEmpty beginsWith: (self nonEmpty copyUpTo: self nonEmpty last)).
	self assert: (self nonEmpty beginsWith: self nonEmpty).
	self deny: (self nonEmpty beginsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!TBeginsEndsWith methodsFor: 'tests - fixture' stamp: ''!
test0FixtureBeginsEndsWithTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self assert: self nonEmpty size > 1.
	self empty.
	self assertEmpty: self empty! !

!TBeginsEndsWith methodsFor: 'tests - begins ends with' stamp: ''!
testsEndsWith
	
	self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst).
	self assert: (self nonEmpty endsWith: self nonEmpty).
	self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first))! !

!TBeginsEndsWith methodsFor: 'tests - begins ends with' stamp: ''!
testsBeginsWithEmpty
	
	self deny: (self nonEmpty beginsWith:(self empty)).
	self deny: (self empty beginsWith:(self nonEmpty))! !

!TBeginsEndsWith classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TBeginsEndsWith classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TBeginsEndsWith classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TBeginsEndsWith classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TBeginsEndsWith classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TBeginsEndsWith classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TBeginsEndsWith classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TBeginsEndsWith classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TBeginsEndsWith classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TBeginsEndsWith classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TBeginsEndsWith classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TBeginsEndsWith classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TBeginsEndsWith classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TBeginsEndsWith classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TBeginsEndsWith classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TBeginsEndsWith classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TBeginsEndsWith classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TBeginsEndsWith classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TBeginsEndsWith classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TBeginsEndsWith classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TBeginsEndsWith classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TBeginsEndsWith classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TBeginsEndsWith classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TBeginsEndsWith classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TBeginsEndsWith classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TBeginsEndsWith classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TBehavior commentStamp: ''!
Kernel trait for Behavior!
!TBehavior classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TBehavior classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TBehavior classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TBehavior classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TBehavior classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TBehavior classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TBehavior classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TBehavior classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TBehavior classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TBehavior classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TBehavior classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TBehavior classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TBehavior classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TBehavior classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TBehavior classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TBehavior classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: arg1 on: arg2

	| tmp1 |
	arg2 cr.
	tmp1 := self selectorsToFileOutCategory: arg1.
	tmp1 do: [ :arg3 | 
		((self isLocalSelector: arg3) or: [ 
			 (self traitComposition selectors includes: arg3) not ]) ifTrue: [ 
			self printMethodChunk: arg3 on: arg2 ] ]! !

!TBehavior classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TBehavior classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TBehavior classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TBehavior classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TBehavior classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TBehavior classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TBehavior classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TBehavior classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TBehavior classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TBehavior classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TBehaviorCategorization commentStamp: ''!
Kernel trait for Behavior categorization!
!TBehaviorCategorization classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TBehaviorCategorization classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TBehaviorCategorization classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TBehaviorCategorization classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TBehaviorCategorization classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TBehaviorCategorization classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TBehaviorCategorization classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TBehaviorCategorization classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TBehaviorCategorization classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TBehaviorCategorization classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TBehaviorCategorization classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TBehaviorCategorization classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TBehaviorCategorization classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TBehaviorCategorization classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TBehaviorCategorization classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TBehaviorCategorization classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: arg1 on: arg2

	| tmp1 |
	arg2 cr.
	tmp1 := self selectorsToFileOutCategory: arg1.
	tmp1 do: [ :arg3 | 
		((self isLocalSelector: arg3) or: [ 
			 (self traitComposition selectors includes: arg3) not ]) ifTrue: [ 
			self printMethodChunk: arg3 on: arg2 ] ]! !

!TBehaviorCategorization classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TBehaviorCategorization classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TBehaviorCategorization classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TBehaviorCategorization classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TBehaviorCategorization classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TBehaviorCategorization classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TBehaviorCategorization classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TBehaviorCategorization classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TBehaviorCategorization classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TBehaviorCategorization classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TCPSocketEchoTest commentStamp: ''!
TCPSocketEchoTest is both a unit test and an example.
It implements and tests a TCP echo service.
Input is read and send back in response.

You can also run the example manually,
by inspecting each expression separately.

  TCPSocketEchoTest new runServer.
  TCPSocketEchoTest new clientSend: 'Hello @ ', Time now asString.
  TCPSocketEchoTest new clientSend: #quit.

Each TCP client connection creates a worker process on the server handling the connection until it is closed. Each worker process reads input one time and sends it back.

The server runs until it receives quit as input. If necessary, use the Process Browser to terminate a running server.

Note: this example deliberately does not use SocketStream to show how to use Socket directly. In practice however, you should use SocketStream.!
!TCPSocketEchoTest methodsFor: 'private' stamp: ''!
withTCPEchoServer: block
	"Run a local TCP echo server on localhost:port and execute block.
	Optionally pass the new process to block. When quit is received, stop the server"
	
	| serverSocket serverLoop process |
	serverSocket := Socket newTCP.
	serverSocket listenOn: self port backlogSize: 10.
	serverLoop := true.
	process := [ 
		[ [ serverLoop ] whileTrue: [ 
			(serverSocket waitForAcceptFor: 60) 
				ifNotNil: [ :clientSocket | | result |
					[ [ 
						result := clientSocket receiveData.
						result asLowercase = #quit
							ifTrue: [ clientSocket sendData: 'Quiting'. serverLoop := false ]
							ifFalse: [ clientSocket sendData: result ] ]
						ensure: [ clientSocket closeAndDestroy ] ] 
							forkAt: Processor lowIOPriority named: 'TCP echo connection' ] ] ]
				ensure: [ serverSocket closeAndDestroy ] ] 
					forkAt: Processor highIOPriority named: 'TCP echo server'.
	^ block cull: process! !

!TCPSocketEchoTest methodsFor: 'testing' stamp: ''!
testEcho
	| socket message result |
	socket := Socket newTCP.
	[ 
		self withTCPEchoServer: [ :process |
			message := 'Testing ', 99 atRandom asString. 
			socket connectTo: self localhost port: self port.
			socket sendData: message.
			result := socket receiveData.
			self assert: result equals: message ]  
	] ensure: [ socket closeAndDestroy ].
	"At this point the server is still running, ask it to kill itself"
	self clientSend: #quit! !

!TCPSocketEchoTest methodsFor: 'testing' stamp: ''!
runServer
	"Run and return a local TCP echo server"
	
	^ self withTCPEchoServer: [ :process | process ]! !

!TCPSocketEchoTest methodsFor: 'accessing' stamp: ''!
port
	"Return the port where the TCP echo service runs"

	^ 6666! !

!TCPSocketEchoTest methodsFor: 'accessing' stamp: ''!
localhost
	"Return the host address where the TCP echo service runs, the local host address"
	
	^ NetNameResolver localHostAddress! !

!TCPSocketEchoTest methodsFor: 'testing' stamp: ''!
clientSend: message
	"Send message to the local TCP echo service and return the result"
	
	| socket |
	socket := Socket newTCP.
	^ [ 
		socket connectTo: self localhost port: self port.
		socket sendData: message.
		socket receiveData ] 
			ensure: [ socket closeAndDestroy ]! !

!TCPSocketTest commentStamp: ''!
SUnit tests for sockets!
!TCPSocketTest methodsFor: 'tests' stamp: ''!
testLocalAddress
	"Tests the various localAddress values for sockets"

	self testServerAccept.
	self assert: listenerSocket localAddress asSocketAddress equals: self listenerAddress.
	self assert: clientSocket localAddress asSocketAddress equals: self listenerAddress.
	self assert: serverSocket localAddress asSocketAddress equals: self listenerAddress! !

!TCPSocketTest methodsFor: 'setup' stamp: ''!
listenerAddress
	^NetNameResolver loopBackAddress! !

!TCPSocketTest methodsFor: 'running' stamp: ''!
tearDown

	listenerSocket ifNotNil:[listenerSocket destroy].
	clientSocket ifNotNil:[clientSocket destroy].
	serverSocket ifNotNil:[serverSocket destroy].
	super tearDown! !

!TCPSocketTest methodsFor: 'tests' stamp: ''!
testRemotePort
	"Tests the various remoteAddress values for sockets"

	self testServerAccept.
	self assert: listenerSocket remotePort equals: 0.
	self assert: clientSocket remotePort equals: self listenerPort.
	self assert: serverSocket remotePort > 0! !

!TCPSocketTest methodsFor: 'tests' stamp: ''!
testClientConnect
	"Tests a client socket connection"

	clientSocket := Socket newTCP.
	clientSocket connectTo: self listenerAddress port: self listenerPort.
	clientSocket waitForConnectionFor: 2.
	self assert: clientSocket isConnected! !

!TCPSocketTest methodsFor: 'tests' stamp: ''!
testLocalPort
	"Tests the various localPort values for sockets"

	self testServerAccept.
	self assert: listenerSocket localPort equals: self listenerPort.
	self assert: clientSocket localPort > 0.
	self assert: serverSocket localPort > 0! !

!TCPSocketTest methodsFor: 'tests' stamp: ''!
testRemoteAddress
	"Tests the various remoteAddress values for sockets"

	self testServerAccept.
	self assert: listenerSocket remoteAddress equals: #[0 0 0 0].
	self assert: clientSocket remoteAddress asSocketAddress equals: self listenerAddress.
	self assert: serverSocket remoteAddress asSocketAddress equals: self listenerAddress! !

!TCPSocketTest methodsFor: 'tests' stamp: ''!
testServerAccept
	"Tests a server-side accept"

	self testClientConnect.
	serverSocket := listenerSocket waitForAcceptFor: 2.
	self assert: serverSocket notNil.
	self assert: serverSocket isConnected! !

!TCPSocketTest methodsFor: 'setup' stamp: ''!
listenerPort
	^42324! !

!TCPSocketTest methodsFor: 'tests' stamp: ''!
testDataSending
	"Test data transfer and related methods"

	self testServerAccept.
	clientSocket sendData: 'Hello World'.
	clientSocket waitForSendDoneFor: 2.
	self assert: clientSocket sendDone! !

!TCPSocketTest methodsFor: 'tests' stamp: ''!
testDataReceive
	"Test data transfer and related methods"

	self testDataSending.
	"It can take a tad for the status change to be visible"
	(Delay forMilliseconds: 200) wait.
	self assert: serverSocket dataAvailable.
	self assert: serverSocket receiveData equals: 'Hello World'.
	self deny: serverSocket dataAvailable! !

!TCPSocketTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	listenerSocket := Socket newTCP listenOn: self listenerPort backlogSize: 4 interface: self listenerAddress! !

!TCairoLibrary commentStamp: ''!
a simple trait used for NB callouts to cairo library functions!
!TCairoLibrary methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ self class ffiLibraryName! !

!TCairoLibrary classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCairoLibrary classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCairoLibrary classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCairoLibrary classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCairoLibrary classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCairoLibrary classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCairoLibrary classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCairoLibrary classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCairoLibrary classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCairoLibrary classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCairoLibrary classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCairoLibrary classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCairoLibrary classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCairoLibrary classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCairoLibrary classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCairoLibrary classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCairoLibrary classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCairoLibrary classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCairoLibrary classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCairoLibrary classTrait methodsFor: 'library path' stamp: ''!
ffiLibraryName
	^ CairoLibrary! !

!TCairoLibrary classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCairoLibrary classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCairoLibrary classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCairoLibrary classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCairoLibrary classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCairoLibrary classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCairoLibrary classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TChunkVisitor commentStamp: ''!
I am a trait defining the basic methods for visiting a chunk object.!
!TChunkVisitor methodsFor: 'visitor' stamp: ''!
visitClassOrganizationChunk: aChunk

	self visitCodeChunk: aChunk! !

!TChunkVisitor methodsFor: 'visitor' stamp: ''!
visitDoItChunk: aChunk

	self visitCodeChunk: aChunk! !

!TChunkVisitor methodsFor: 'visitor' stamp: ''!
visitStyleChunk: aChunk

	self visitCodeChunk: aChunk! !

!TChunkVisitor methodsFor: 'visitor' stamp: ''!
visitCodeChunk: aChunk

	"Base method called from every other visit*"! !

!TChunkVisitor methodsFor: 'visitor' stamp: ''!
visitMethodChunk: aChunk

	self visitCodeChunk: aChunk! !

!TChunkVisitor methodsFor: 'visitor' stamp: ''!
visitClassCommentChunk: aChunk

	self visitCodeChunk: aChunk! !

!TChunkVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TChunkVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TChunkVisitor classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TChunkVisitor classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TChunkVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TChunkVisitor classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TChunkVisitor classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TChunkVisitor classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TChunkVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TChunkVisitor classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TChunkVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TChunkVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TChunkVisitor classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TChunkVisitor classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TChunkVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TChunkVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TChunkVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TChunkVisitor classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TChunkVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TChunkVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TChunkVisitor classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TChunkVisitor classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TChunkVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TChunkVisitor classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TChunkVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TClass commentStamp: ''!
Kernel trait for Class!
!TClass methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper
	^self explicitRequirement.! !

!TClass classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TClass classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TClass classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TClass classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TClass classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TClass classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TClass classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TClass classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TClass classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TClass classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TClass classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TClass classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TClass classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TClass classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TClass classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TClass classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: arg1 on: arg2

	| tmp1 |
	arg2 cr.
	tmp1 := self selectorsToFileOutCategory: arg1.
	tmp1 do: [ :arg3 | 
		((self isLocalSelector: arg3) or: [ 
			 (self traitComposition selectors includes: arg3) not ]) ifTrue: [ 
			self printMethodChunk: arg3 on: arg2 ] ]! !

!TClass classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TClass classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TClass classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TClass classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TClass classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TClass classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TClass classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TClass classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TClass classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TClass classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TClassDescription commentStamp: ''!
Kernel trait for ClassDescription!
!TClassDescription classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TClassDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TClassDescription classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TClassDescription classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TClassDescription classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TClassDescription classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TClassDescription classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TClassDescription classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TClassDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TClassDescription classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TClassDescription classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TClassDescription classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TClassDescription classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TClassDescription classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TClassDescription classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TClassDescription classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: arg1 on: arg2

	| tmp1 |
	arg2 cr.
	tmp1 := self selectorsToFileOutCategory: arg1.
	tmp1 do: [ :arg3 | 
		((self isLocalSelector: arg3) or: [ 
			 (self traitComposition selectors includes: arg3) not ]) ifTrue: [ 
			self printMethodChunk: arg3 on: arg2 ] ]! !

!TClassDescription classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TClassDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TClassDescription classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TClassDescription classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TClassDescription classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TClassDescription classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TClassDescription classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TClassDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TClassDescription classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TClassDescription classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TCloneTest commentStamp: ''!
A trait for test purposes!
!TCloneTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!TCloneTest methodsFor: 'helper' stamp: ''!
empty

	^ self explicitRequirement! !

!TCloneTest methodsFor: 'helper' stamp: ''!
nonEmpty

	^ self explicitRequirement! !

!TCloneTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!TCloneTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!TCloneTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	 
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!TCloneTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCloneTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCloneTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCloneTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCloneTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCloneTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCloneTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCloneTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCloneTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCloneTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCloneTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCloneTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCloneTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCloneTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCloneTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCloneTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCloneTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCloneTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCloneTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCloneTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCloneTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCloneTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCloneTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCloneTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCloneTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCloneTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TClyGenerateTestClass commentStamp: ''!
Description
--------------------

I am a trait containing the behavior or retrieving the test class of a class.

If the test class does not exists I am able to generate it.!
!TClyGenerateTestClass methodsFor: 'action' stamp: ''!
addNewCommentForTestClass: aClass basedOn: baseClass
	aClass
		comment:
			(String
				streamContents: [ :stream | 
					| name |
					name := aClass name.
					name first isVowel
						ifTrue: [ stream nextPutAll: 'An ' ]
						ifFalse: [ stream nextPutAll: 'A ' ].
					stream
						nextPutAll: name;
						nextPutAll: ' is a test class for testing the behavior of ';
						nextPutAll: baseClass name ])! !

!TClyGenerateTestClass methodsFor: 'accessing' stamp: ''!
testClassFor: inputClass
	| className resultClass |
	className := self testClassNameFor: inputClass.
	self systemEnvironment
		classNamed: className
		ifPresent: [ :class | resultClass := class ]
		ifAbsent: [
			(self isValidClass: inputClass) ifFalse: [ ClyInvalidClassForTestClassGeneration signalFor: inputClass ].
			self systemEnvironment ensureExistAndRegisterPackageNamed: inputClass package name asString , '-Tests'.
			
			resultClass := self class classInstaller make: [ :aBuilder |
				aBuilder name: className;
					superclass: TestCase;
					package: (self newTestClassCategoryFor: inputClass) ].

			self addNewCommentForTestClass: resultClass basedOn: inputClass ].
	^ resultClass! !

!TClyGenerateTestClass methodsFor: 'accessing' stamp: ''!
testClassNameFor: inputClass
	^ (inputClass name , 'Test') asSymbol! !

!TClyGenerateTestClass methodsFor: 'action' stamp: ''!
newTestClassCategoryFor: aClass
	| tag |
	tag := aClass package classTagForClass: aClass.
	^ String
		streamContents: [ :s | 
			s
				nextPutAll: aClass package name;
				nextPutAll: '-Tests'.
			tag isRoot
				ifFalse: [ s
						nextPut: $-;
						nextPutAll: tag name ] ]! !

!TClyGenerateTestClass methodsFor: 'accessing' stamp: ''!
systemEnvironment
	^ self explicitRequirement! !

!TClyGenerateTestClass methodsFor: 'testing' stamp: ''!
isValidClass: inputClass
	^ (inputClass isTestCase or: [ inputClass isMeta ]) not! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TClyGenerateTestClass classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TClyGenerateTestClass classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TClyGenerateTestClass classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TClyGenerateTestClass classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TClyGenerateTestClass classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TClyGenerateTestClass classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TClyGenerateTestClass classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TClyGenerateTestClass classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TClyGenerateTestClass classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TClyGenerateTestClass classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TClyGenerateTestClass classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TClyGenerateTestClass classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TClyGenerateTestClass classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TClyGenerateTestClass classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TClyGenerateTestClass classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TClyGenerateTestClass classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TComparable commentStamp: ''!
This trait is a protocol for comparable objects. Classes using it must implement #<, #=, and #hash.!
!TComparable methodsFor: 'comparing' stamp: ''!
< aComparable
	"Answer whether the receiver is less than the argument."

	^self subclassResponsibility! !

!TComparable methodsFor: 'comparing' stamp: ''!
>= aComparable 
	"Answer whether the receiver is greater than or equal to the argument."

	^aComparable <= self! !

!TComparable methodsFor: 'comparing' stamp: ''!
= aComparable 
	"Compare the receiver with the argument and answer with true if the 
	receiver is equal to the argument. Otherwise answer false."

	^self subclassResponsibility! !

!TComparable methodsFor: 'comparing' stamp: ''!
hash
	"Hash must be redefined whenever = is redefined."

	^self subclassResponsibility! !

!TComparable methodsFor: 'comparing' stamp: ''!
min: aComparable 
	"Answer the receiver or the argument, whichever is lesser."

	self < aComparable
		ifTrue: [^self]
		ifFalse: [^aComparable]! !

!TComparable methodsFor: 'comparing' stamp: ''!
min: aMin max: aMax 

	^ (self min: aMin) max: aMax! !

!TComparable methodsFor: 'comparing' stamp: ''!
> aComparable 
	"Answer whether the receiver is greater than the argument."

	^aComparable < self! !

!TComparable methodsFor: 'comparing' stamp: ''!
between: min and: max 
	"Answer whether the receiver is less than or equal to the argument, max, 
	and greater than or equal to the argument, min."

	^self >= min and: [self <= max]! !

!TComparable methodsFor: 'comparing' stamp: ''!
<= aComparable 
	"Answer whether the receiver is less than or equal to the argument."

	^(self > aComparable) not! !

!TComparable methodsFor: 'comparing' stamp: ''!
max: aComparable 
	"Answer the receiver or the argument, whichever is greater."

	self > aComparable
		ifTrue: [^self]
		ifFalse: [^aComparable]! !

!TComparable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TComparable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TComparable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TComparable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TComparable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TComparable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TComparable classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TComparable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TComparable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TComparable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TComparable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TComparable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TComparable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TComparable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TComparable classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TComparable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TComparable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TComparable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TComparable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TComparable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TComparable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TComparable classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TComparable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TComparable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TComparable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TComposingDescription commentStamp: ''!
Kernel trait for ComposingDescription!
!TComposingDescription classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TComposingDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TComposingDescription classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TComposingDescription classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TComposingDescription classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TComposingDescription classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TComposingDescription classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TComposingDescription classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TComposingDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TComposingDescription classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TComposingDescription classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TComposingDescription classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TComposingDescription classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TComposingDescription classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TComposingDescription classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TComposingDescription classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: arg1 on: arg2

	| tmp1 |
	arg2 cr.
	tmp1 := self selectorsToFileOutCategory: arg1.
	tmp1 do: [ :arg3 | 
		((self isLocalSelector: arg3) or: [ 
			 (self traitComposition selectors includes: arg3) not ]) ifTrue: [ 
			self printMethodChunk: arg3 on: arg2 ] ]! !

!TComposingDescription classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TComposingDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TComposingDescription classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TComposingDescription classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TComposingDescription classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TComposingDescription classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TComposingDescription classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TComposingDescription classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TComposingDescription classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TComposingDescription classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TConcatenationEqualElementsRemovedTest commentStamp: ''!
A trait for test purposes!
!TConcatenationEqualElementsRemovedTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result := self firstCollection , self empty.
	self assert: result = self firstCollection! !

!TConcatenationEqualElementsRemovedTest methodsFor: 'requirements' stamp: ''!
secondCollection
" return a collection that will be the second part of the concatenation"
	self explicitRequirement! !

!TConcatenationEqualElementsRemovedTest methodsFor: 'requirements' stamp: ''!
empty
	self explicitRequirement.! !

!TConcatenationEqualElementsRemovedTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithDuplicate


| collection1 collection2 result |
collection1 := self firstCollection .
collection2 := self firstCollection  .
result := collection1 , collection2.

collection1 do:[ :each | self assert: (result includes: each)].
self assert: result size = collection1 size.! !

!TConcatenationEqualElementsRemovedTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation

| collection1 collection2 result |
collection1 := self firstCollection .
collection2 := self secondCollection .
result := collection1 , collection2.

collection1 do:[ :each | self assert: (result includes: each)].
collection2 do:[ :each | self assert: (result includes: each)].! !

!TConcatenationEqualElementsRemovedTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConcatenationTest
	self firstCollection.
	self denyEmpty: self firstCollection.
	self firstCollection.
	self denyEmpty: self firstCollection.
	self empty.
	self assertEmpty: self empty! !

!TConcatenationEqualElementsRemovedTest methodsFor: 'requirements' stamp: ''!
firstCollection
" return a collection that will be the first part of the concatenation"
	self explicitRequirement! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TConcatenationEqualElementsRemovedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TConcatenationTest commentStamp: ''!
A trait for test purposes!
!TConcatenationTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result := self firstCollection , self empty.
	self assert: result = self firstCollection! !

!TConcatenationTest methodsFor: 'requirements' stamp: ''!
secondCollection
" return a collection that will be the second part of the concatenation"
	self explicitRequirement! !

!TConcatenationTest methodsFor: 'requirements' stamp: ''!
empty
	self explicitRequirement.! !

!TConcatenationTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithDuplicate


| collection1 collection2 result |
collection1 := self firstCollection .
collection2 := self firstCollection .
result := collection1 , collection2.

result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ].
self assert: result size = (collection1 size * 2)! !

!TConcatenationTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation

"| collection1 collection2 result |
collection1 := self firstCollection .
collection2 := self secondCollection .
result := collection1 , collection2.

collection1 do:[ :each | self assert: (result includes: each)].
collection2 do:[ :each | self assert: (result includes: each)]."

| collection1 collection2 result |
collection1 := self firstCollection .
collection2 := self secondCollection .
result := collection1 , collection2.

result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ].
self assert: result size = (collection1 size + collection2 size)! !

!TConcatenationTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConcatenationTest
	self firstCollection.
	self denyEmpty: self firstCollection.
	self firstCollection.
	self denyEmpty: self firstCollection.
	self empty.
	self assertEmpty: self empty! !

!TConcatenationTest methodsFor: 'requirements' stamp: ''!
firstCollection
" return a collection that will be the first part of the concatenation"
	self explicitRequirement! !

!TConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TConcatenationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TConcatenationTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TConcatenationTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TConcatenationTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TConcatenationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConcatenationTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TConcatenationTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TConcatenationTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TConcatenationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TConcatenationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TConcatenationTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TConvertAsSetForMultiplinessIdentityTest commentStamp: ''!
A trait for test purposes!
!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'requirements' stamp: ''!
collectionWithIdentical
	"Return a collection of type: 'self collectionWIithoutEqualsElements class containing two elements equals (with identity equality)."

	| result collection anElement |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := collection first.
	collection add: anElement.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - as set tests' stamp: ''!
testAsIdentitySetWithEqualsElements

	| result collection |
	collection := self withEqualElements .
	result := collection asIdentitySet.
	collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = IdentitySet! !

!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - as identity set' stamp: ''!
testAsIdentitySetWithIdentityEqualsElements

	| result |
	result := self collectionWithIdentical asIdentitySet.
	" Only one element should have been removed as two elements are equals with Identity equality"
	self assert: result size = (self collectionWithIdentical size - 1).
	self collectionWithIdentical do: 
		[ :each | 
		(self collectionWithIdentical occurrencesOf: each) > 1 
			ifTrue: 
				[ "the two elements equals only with classic equality shouldn't 'have been removed"
				self assert: (result asOrderedCollection occurrencesOf: each) = 1
				" the other elements are still here" ]
			ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ].
	self assert: result class = IdentitySet! !

!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertAsSetForMultiplinessTest
	"a collection  with equal elements:"

	| res |
	self withEqualElements.
	res := true.
	self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res = true! !

!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'requirements' stamp: ''!
collectionWithCopy
	"Return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals (with identity equality)
	but 2 elements only equals with classic equality"
	
	| result collection |
	collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements.
	collection add: collection first copy.
	result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection.
	^ result! !

!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'requirements' stamp: ''!
withEqualElements
	" return a collection  including equal elements (classic equality)"
	^ self explicitRequirement! !

!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'requirements' stamp: ''!
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  "
	^ self explicitRequirement! !

!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - as set tests' stamp: ''!
testAsSetWithEqualsElements

	| result |
	result := self withEqualElements asSet.
	self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = Set! !

!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureAsSetForIdentityMultiplinessTest
	"A collection (of elements for which copy is not identical ) without equal elements:"

	| anElement res |
	self elementsCopyNonIdenticalWithoutEqualElements.
	anElement := self elementsCopyNonIdenticalWithoutEqualElements anyOne.
	self deny: anElement copy == anElement.
	res := true.
	self elementsCopyNonIdenticalWithoutEqualElements
		detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - as identity set' stamp: ''!
testAsIdentitySetWithoutIdentityEqualsElements

	| result collection |
	collection := self collectionWithCopy.
	result := collection asIdentitySet.
	" no elements should have been removed as no elements are equels with Identity equality"
	self assert: result size = collection size.
	collection do: 
		[ :each | 
		(collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ].
	self assert: result class = IdentitySet! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TConvertAsSetForMultiplinessIdentityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TConvertAsSetForMultiplinessTest commentStamp: ''!
A trait for test purposes!
!TConvertAsSetForMultiplinessTest methodsFor: 'tests - as set tests' stamp: ''!
testAsIdentitySetWithEqualsElements
	| result collection |
	collection := self withEqualElements .
	result := collection asIdentitySet.
	collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = IdentitySet.! !

!TConvertAsSetForMultiplinessTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertAsSetForMultiplinessTest
	"a collection  with equal elements:"

	| res |
	self withEqualElements.
	res := true.
	self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self assert: res = true! !

!TConvertAsSetForMultiplinessTest methodsFor: 'requirements' stamp: ''!
withEqualElements
	" return a collection  including equal elements (classic equality)"
	^ self explicitRequirement! !

!TConvertAsSetForMultiplinessTest methodsFor: 'tests - as set tests' stamp: ''!
testAsSetWithEqualsElements
	| result |
	result := self withEqualElements asSet.
	self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ].
	self assert: result class = Set! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TConvertAsSetForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TConvertAsSortedTest commentStamp: ''!
A trait for test purposes!
!TConvertAsSortedTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedArray

	| result collection |
	collection := self collectionWithSortableElements .
	result := collection  asArray sort.
	self assert: (result class includesBehavior: Array).
	self assert: result isSorted.
	self assert: result size = collection size! !

!TConvertAsSortedTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollection

	| aCollection result |
	aCollection := self collectionWithSortableElements .
	result := aCollection asSortedCollection.
	
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ].
	
	self assert: result size = aCollection size! !

!TConvertAsSortedTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureConverAsSortedTest
	self collectionWithSortableElements.
	self denyEmpty: self collectionWithSortableElements! !

!TConvertAsSortedTest methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
" return a collection elements that can be sorte ( understanding message ' < '  or ' > ')"
	^ self explicitRequirement! !

!TConvertAsSortedTest methodsFor: 'tests - as sorted collection' stamp: ''!
testAsSortedCollectionWithSortBlock

	| result tmp |
	result := self collectionWithSortableElements  asSortedCollection: [:a :b | a > b ].
	self assert: (result class includesBehavior: SortedCollection).
	result do: 
		[ :each | 
		self assert: (self collectionWithSortableElements occurrencesOf: each) equals: (result occurrencesOf: each) ].
	self assert: result size equals: self collectionWithSortableElements  size.
	tmp:=result at: 1.
	result do: [:each| self assert: tmp >= each. tmp := each ]! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TConvertAsSortedTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TConvertAsSortedTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TConvertAsSortedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TConvertAsSortedTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TConvertAsSortedTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TConvertAsSortedTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConvertAsSortedTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TConvertAsSortedTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TConvertAsSortedTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TConvertAsSortedTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConvertAsSortedTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TConvertAsSortedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TConvertAsSortedTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TConvertAsSortedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TConvertAsSortedTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TConvertAsSortedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TConvertTest commentStamp: ''!
A trait for test purposes!
!TConvertTest methodsFor: 'tests - converting' stamp: ''!
testAsSet
 	"Test with a collection without equal elements"
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set! !

!TConvertTest methodsFor: 'tests - converting' stamp: ''!
testAsOrderedCollection
	
	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! !

!TConvertTest methodsFor: 'asserting' stamp: ''!
assertNoDuplicates: aCollection whenConvertedTo: aClass

	| result |
	result := self collectionWithEqualElements asIdentitySet.
	self assert: (result class includesBehavior: IdentitySet).
	self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) equals: 1 ]! !

!TConvertTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTConvertTest
	"A collection of number without equal elements:"

	| res |
	self collectionWithoutEqualElements.
	res := true.
	self collectionWithoutEqualElements
		detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false! !

!TConvertTest methodsFor: 'asserting' stamp: ''!
assertNonDuplicatedContents: aCollection whenConvertedTo: aClass

	| result |
	result := aCollection perform: ('as' , aClass name) asSymbol.
	self assert: (result class includesBehavior: aClass).
	result do: 
		[ :each | 
		self assert: (aCollection occurrencesOf: each) equals: (result occurrencesOf: each) ].
	^ result! !

!TConvertTest methodsFor: 'tests - converting' stamp: ''!
testAsBag

	self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! !

!TConvertTest methodsFor: 'requirements' stamp: ''!
integerCollectionWithoutEqualElements
" return a collection of integer without equal elements"
	^ self explicitRequirement! !

!TConvertTest methodsFor: 'tests - converting' stamp: ''!
testAsArray

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: Array! !

!TConvertTest methodsFor: 'asserting' stamp: ''!
assertSameContents: aCollection whenConvertedTo: aClass

	| result |
	result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass.
	self assert: result size equals: aCollection size! !

!TConvertTest methodsFor: 'tests - converting' stamp: ''!
testAsIdentitySet
	"Test with a collection without equal elements :"

	self 
		assertSameContents: self collectionWithoutEqualElements
		whenConvertedTo: IdentitySet! !

!TConvertTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
" return a collection without equal elements"
	^ self explicitRequirement! !

!TConvertTest methodsFor: 'tests - converting' stamp: ''!
testAsByteArray

	| res |
	self integerCollectionWithoutEqualElements.
	self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ].
	res := true.
	self integerCollectionWithoutEqualElements
		detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! !

!TConvertTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TConvertTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TConvertTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TConvertTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TConvertTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TConvertTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TConvertTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TConvertTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TConvertTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConvertTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TConvertTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TConvertTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TConvertTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TConvertTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TConvertTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TConvertTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TConvertTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TConvertTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TConvertTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TConvertTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TConvertTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TConvertTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TConvertTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TConvertTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TConvertTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TConvertTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TCopyPartOfSequenceable commentStamp: ''!
A trait for test purposes!
!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLast

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection copyUpToLast: (collection at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at: i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLast

	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection copyAfterLast: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!TCopyPartOfSequenceable methodsFor: 'requirements' stamp: ''!
empty
	self explicitRequirement! !

!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterEmpty
	| result |
	result := self empty copyAfter: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyEmptyMethod
	| result |
	result := self collectionWithoutEqualElements copyEmpty.
	self assertEmpty: result.
	self assert: result class equals: self nonEmpty class! !

!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfter
	| result index collection |
	collection := self collectionWithoutEqualElements .
	index:= self indexInForCollectionWithoutDuplicates .
	result := collection   copyAfter: (collection  at:index ).
	
	"Verify content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + index )) equals: (result at: i)].

	"Verify size"
	self assert: result size equals: (collection size - index)! !

!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToEmpty
	| result |
	result := self empty copyUpTo: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpToLastEmpty
	| result |
	result := self empty copyUpToLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyAfterLastEmpty
	| result |
	result := self empty copyAfterLast: self collectionWithoutEqualElements first.
	self assertEmpty: result! !

!TCopyPartOfSequenceable methodsFor: 'requirements' stamp: ''!
indexInForCollectionWithoutDuplicates
" return an index between 'collectionWithoutEqualsElements'  bounds"
	self explicitRequirement! !

!TCopyPartOfSequenceable methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfSequenceableTest
	self collectionWithoutEqualElements.
	self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ].
	self indexInForCollectionWithoutDuplicates.
	self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size.
	self empty.
	self assertEmpty: self empty! !

!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyFromTo
	| result  index collection |
	collection := self collectionWithoutEqualElements .
	index :=self indexInForCollectionWithoutDuplicates .
	result := collection   copyFrom: index  to: collection  size .
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at:i) equals: (collection  at: (i + index - 1))].
	
	"Verify size"
	self assert: result size equals: (collection  size - index + 1)! !

!TCopyPartOfSequenceable methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements

" return a collection not including equal elements "
	self explicitRequirement! !

!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: ''!
testCopyUpTo

	| result index collection |
	collection := self collectionWithoutEqualElements.
	index:= self indexInForCollectionWithoutDuplicates.
	result := collection   copyUpTo: (collection  at:index).
	
	"Verify content"
	result withIndexDo: [:el :i| self assert: (collection at:i) equals: (result at:i)].
	
	"Verify size"
	self assert: result size equals: (index-1)! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCopyPartOfSequenceable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCopyPartOfSequenceable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCopyPartOfSequenceable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCopyPartOfSequenceable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCopyPartOfSequenceable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCopyPartOfSequenceable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopyPartOfSequenceable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCopyPartOfSequenceable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCopyPartOfSequenceable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCopyPartOfSequenceable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopyPartOfSequenceable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCopyPartOfSequenceable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCopyPartOfSequenceable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCopyPartOfSequenceable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCopyPartOfSequenceable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCopyPartOfSequenceable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TCopyPartOfSequenceableForMultipliness commentStamp: ''!
A trait for test purposes!
!TCopyPartOfSequenceableForMultipliness methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the first occurrence:"
	result := collection   copyAfter: (element ).
	
	"Verifying content"
	result withIndexDo: 
		[:e :i | self assert: (collection at: (i + 1 )) equals: (result at: (i)) ].

	"Verify size"
	self assert: result size equals: (collection size - 1).! !

!TCopyPartOfSequenceableForMultipliness methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToLastWithDuplicate

	| result element  collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.
	
	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyUpToLast:' should copy until the last occurrence :"
	result := collection copyUpToLast: (element ).
	
	"Verify content"
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (collection at: i) ].
	
	self assert: result size equals: (collection size - 1)! !

!TCopyPartOfSequenceableForMultipliness methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyUpToWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection last.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
 	 'copyUpTo:' should copy until the first occurrence"
	result := collection copyUpTo: element.

	"Verify content"
	self assertEmpty: result! !

!TCopyPartOfSequenceableForMultipliness methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''!
testCopyAfterLastWithDuplicate
	| result element collection |
	collection := self collectionWithSameAtEndAndBegining.
	element := collection first.

	"collectionWithSameAtEndAndBegining first and last elements are equals.
	'copyAfter:' should copy after the last occurrence of element :"
	result := collection copyAfterLast: element.

	"Verify content"
	self assertEmpty: result! !

!TCopyPartOfSequenceableForMultipliness methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyPartOfForMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!TCopyPartOfSequenceableForMultipliness methodsFor: 'requirements' stamp: ''!
collectionWithSameAtEndAndBegining
" return a collection with elements at end and begining equals .
(others elements of the collection are not equal to those elements)"
	self explicitRequirement! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCopyPartOfSequenceableForMultipliness classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TCopyPreservingIdentityTest commentStamp: ''!
A trait for test purposes!
!TCopyPreservingIdentityTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	self explicitRequirement! !

!TCopyPreservingIdentityTest methodsFor: 'tests - copy' stamp: ''!
testCopyReturnsIdentity
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: self nonEmpty == copy.! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCopyPreservingIdentityTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCopyPreservingIdentityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TCopySequenceableSameContents commentStamp: ''!
A trait for test purposes!
!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: ''!
testReversed

	| result |
	result := self nonEmpty reversed.
	
	"Verify content"
	result withIndexDo:
		[:el :i | self assert: el equals: (self nonEmpty at: (self nonEmpty size - i + 1))].

	"Verify size"
	self assert: result size=self nonEmpty size.! !

!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: ''!
testReverse

	| result |
	result := self nonEmpty reversed.	
	"verify content of 'result: '"
	1 to: result size do:
		[:i | self assert: ((result at: i) 
			= (self nonEmpty at: (self nonEmpty size - i + 1)))].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size! !

!TCopySequenceableSameContents methodsFor: 'requirements' stamp: ''!
empty
	self explicitRequirement! !

!TCopySequenceableSameContents methodsFor: 'requirements' stamp: ''!
nonEmpty
	self explicitRequirement! !

!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: ''!
testShuffled
	| result |
	result := self nonEmpty shuffled .
	
	"verify content of 'result: '"
	result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)].
	"verify size of 'result' :"
	self assert: result size=self nonEmpty size.! !

!TCopySequenceableSameContents methodsFor: 'requirements' stamp: ''!
collectionWithSortableElements
	" return a collection only including elements that can be sorted (understanding '<' )"
	self explicitRequirement! !

!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopyEmpty
	| result |
	result := self empty shallowCopy.
	self assertEmpty: result! !

!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: ''!
testShallowCopy

	| result |
	result := self nonEmpty shallowCopy.
	
	"Verfy content"
	self nonEmpty withIndexDo:
		[:el :i | self assert: (result at:i) equals: (self nonEmpty at:i)].
	
	"Verify size"
	self assert: result size equals: self nonEmpty size.! !

!TCopySequenceableSameContents methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopySameContentsTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCopySequenceableSameContents classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCopySequenceableSameContents classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCopySequenceableSameContents classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCopySequenceableSameContents classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCopySequenceableSameContents classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCopySequenceableSameContents classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopySequenceableSameContents classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCopySequenceableSameContents classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCopySequenceableSameContents classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCopySequenceableSameContents classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopySequenceableSameContents classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCopySequenceableSameContents classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCopySequenceableSameContents classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCopySequenceableSameContents classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCopySequenceableSameContents classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCopySequenceableSameContents classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TCopySequenceableWithOrWithoutSpecificElements commentStamp: ''!
A trait for test purposes!
!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutFirst

	| result |
	result := self nonEmpty copyWithoutFirst.
	
	self assert: result size equals: (self nonEmpty size - 1).
	
	result withIndexDo: 
		[:el :i | self assert: (result at: i) equals: (self nonEmpty at: (i + 1))]! !

!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingStartWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty .
	result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ).
	
	"verify content of 'result' : "
	1 to: 2   do:
		[:i | self assert: ( element ) = ( result at:(i) ) ].
	
	3 to: result size do:
		[:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ].

	"verify size of 'result' :"
	self assert: result size = (self nonEmpty size + 2).! !

!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithSequenceable

	| result index element |
	index := self indexInNonEmpty.
	element := self nonEmpty at: index.
	result := self nonEmpty copyWith: (element ).
	
	self assert: result size equals: (self nonEmpty size + 1).
	self assert: result last equals: element.
	
	1 to: (result size - 1) do:
		[ :i | self assert: (result at: i) equals: ( self nonEmpty at: i)]! !

!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'requirements' stamp: ''!
nonEmpty
	self explicitRequirement! !

!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'requirements' stamp: ''!
indexInNonEmpty
	"Return an index between bounds of 'nonEmpty'"

	^self explicitRequirement! !

!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithOrWithoutSpecificElementsTest

	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self indexInNonEmpty.
	self assert: self indexInNonEmpty > 0.
	self assert: self indexInNonEmpty <= self nonEmpty size! !

!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithFirst

	| index element result |
	index:= self indexInNonEmpty .
	element:= self nonEmpty at: index.
	
	result := self nonEmpty copyWithFirst: element.	
	
	self assert: result size = (self nonEmpty size + 1).
	self assert: result first = element .
	
	2 to: result size do:
	[ :i |
	self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! !

!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: ''!
testCopyWithoutIndex

	| result index |	
	index := self indexInNonEmpty.
	result := self nonEmpty copyWithoutIndex: index.
	
	"Verify content of result"
	result withIndexDo: 
		[:element :i | 
		 i <  index ifTrue: [ self assert: element equals: (self nonEmpty at: i) ].
		 i >= index ifTrue: [ self assert: element equals: (self nonEmpty at: (i + 1)) ]].
	
	"Verify size of result"
	self assert: result size equals: (self nonEmpty size - 1)! !

!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: ''!
testForceToPaddingWith

	| result element |
	element := self nonEmpty at: self indexInNonEmpty.
	result := self nonEmpty forceTo: (self nonEmpty size + 2) paddingWith: element.
	
	"Verify content of 'result'"
	self nonEmpty withIndexDo:
		[:el :index | self assert: el equals: (result at: index) ].
	
	(result size - 1) to: result size do:
		[:i | self assert: (result at:i) equals: element ].

	"Verify size of 'result'"
	self assert: result size equals: self nonEmpty size + 2! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCopySequenceableWithOrWithoutSpecificElements classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TCopySequenceableWithReplacement commentStamp: ''!
A trait for test purposes!
!TCopySequenceableWithReplacement methodsFor: 'requirements' stamp: ''!
collectionWith2TimeSubcollection
" return a collection including 'oldSubCollection'  two or many time "
	self explicitRequirement! !

!TCopySequenceableWithReplacement methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWith
	| result  indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1.
	lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection  size -1.
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: lastIndexOfOldSubcollection   with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'  "
	
	1 to: (indexOfSubcollection  - 1) do: 
		[ 
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i) = (result at: i)
		].
	
	" middle part containing replacementCollection : "
	
	(indexOfSubcollection ) to: ( lastIndexOfReplacementCollection  ) do: 
		[
		:i |
		self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1))
		].
	
	" end part :"
	1 to: (result size - lastIndexOfReplacementCollection   ) do:
		[ 
		:i |
		self assert: (result at: ( lastIndexOfReplacementCollection  + i  ) ) = (self collectionWith1TimeSubcollection  at: ( lastIndexOfOldSubcollection  + i  ) ).
		].! !

!TCopySequenceableWithReplacement methodsFor: 'requirements' stamp: ''!
oldSubCollection
" return a subCollection included in collectionWith1TimeSubcollection .
ex :   subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)"
	self explicitRequirement! !

!TCopySequenceableWithReplacement methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWith1Occurrence
	| 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 ) ).
		].! !

!TCopySequenceableWithReplacement methodsFor: 'tests - copying with replacement' stamp: ''!
firstIndexesOf: aSubCollection in: collection
" return an OrderedCollection with the first indexes of the occurrences of subCollection in  collection "
	| tmp result currentIndex |
	tmp:= collection.
	result:= OrderedCollection new.
	currentIndex := 1.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				result add: currentIndex.
				1 to: aSubCollection size do: 
					[:i | 
					tmp := tmp copyWithoutFirst.
					currentIndex := currentIndex + 1]
				]
			ifFalse: [
				tmp := tmp copyWithoutFirst.
				currentIndex := currentIndex +1.
				]
		 ].
	
	^ result.! !

!TCopySequenceableWithReplacement methodsFor: 'requirements' stamp: ''!
collectionWith1TimeSubcollection
" return a collection including 'oldSubCollection'  only one time "
	self explicitRequirement! !

!TCopySequenceableWithReplacement methodsFor: 'requirements' stamp: ''!
replacementCollection
" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection'  " 
	self explicitRequirement! !

!TCopySequenceableWithReplacement methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceFromToWithInsertion
	| result  indexOfSubcollection |
	
	indexOfSubcollection := (self firstIndexesOf: self oldSubCollection  in:  self collectionWith1TimeSubcollection) at: 1. 
	
	result := self collectionWith1TimeSubcollection  copyReplaceFrom: indexOfSubcollection  to: ( indexOfSubcollection - 1 ) with: self replacementCollection .
	
	"verify content of 'result' : "
	"first part of 'result'' : '"
	
	1 to: (indexOfSubcollection -1) do: 
		[
		:i | 
		self assert: (self collectionWith1TimeSubcollection  at:i)=(result at: i)
		].
	
	" middle part containing replacementCollection : "
	indexOfSubcollection  to: (indexOfSubcollection  + self replacementCollection size-1) do: 
		[
		:i |
		self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 ))
		].
	
	" end part :"
	(indexOfSubcollection  + self replacementCollection size) to: (result size) do:
		[:i|
		self assert: (result at: i)=(self collectionWith1TimeSubcollection  at: (i-self replacementCollection size))].
	
	" verify size: "	
	self assert: result size=(self collectionWith1TimeSubcollection  size + self replacementCollection size).! !

!TCopySequenceableWithReplacement methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithReplacementTest
	self replacementCollection.
	self oldSubCollection.
	self collectionWith1TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! !

!TCopySequenceableWithReplacement methodsFor: 'tests - copying with replacement' stamp: ''!
testCopyReplaceAllWithManyOccurrence
	| result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff |
	" testing fixture here as this method may be not used for collection that can't contain equals element :"
	self collectionWith2TimeSubcollection.
	self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection) = 2.	" test :"
	diff := self replacementCollection size - self oldSubCollection size.
	result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection.	"detecting indexes of olSubCollection"
	firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection.	" verifying that replacementCollection has been put in places of oldSubCollections "
	firstIndexesOfOccurrence
		do: [ :each | 
			(firstIndexesOfOccurrence indexOf: each) = 1
				ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ]
				ifFalse: [ each + diff to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ].	" verifying that the 'between' parts correspond to the initial collection : "
	1 to: firstIndexesOfOccurrence size do: [ :i | 
		i = 1
			ifTrue: [ 1 to: (firstIndexesOfOccurrence at: i) - 1 do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ]
			ifFalse: [ 
				resultBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self replacementCollection size.
				collectionBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self oldSubCollection size.
				1 to: (firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | 
					self
						assert:
							(result at: resultBetweenPartIndex + i - 1)
								= (self collectionWith2TimeSubcollection at: collectionBetweenPartIndex + i - 1) ] ]	" specific comportement for the begining of the collection :"	" between parts till the end : " ].	"final part :"
	1 to: self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size) do: [ :i | 
		self
			assert:
				(result at: firstIndexesOfOccurrence last + self replacementCollection size - 1 + i)
					= (self collectionWith2TimeSubcollection at: firstIndexesOfOccurrence last + self oldSubCollection size - 1 + i) ]! !

!TCopySequenceableWithReplacement methodsFor: 'tests - fixture' stamp: ''!
howMany: aSubCollection in: collection
" return an integer representing how many time 'subCollection'  appears in 'collection'  "
	| tmp nTime |
	tmp := collection.
	nTime:= 0.
	
	[tmp isEmpty ]whileFalse:
		[
		(tmp beginsWith: aSubCollection)
			ifTrue: [ 	
				nTime := nTime + 1.
				1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.]
				]
			ifFalse: [tmp := tmp copyWithoutFirst.]
		 ].
	
	^ nTime.! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCopySequenceableWithReplacement classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCopySequenceableWithReplacement classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TCopySequenceableWithReplacementForSorted commentStamp: ''!
A trait for test purposes!
!TCopySequenceableWithReplacementForSorted methodsFor: 'requirements' stamp: ''!
empty
self explicitRequirement.! !

!TCopySequenceableWithReplacementForSorted methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCopyWithReplacementForSorted
	self collectionOfSize5.
	self assert: self collectionOfSize5 size = 5.
	self replacementCollection.
	self denyEmpty: self replacementCollection.
	self empty.
	self assertEmpty: self empty! !

!TCopySequenceableWithReplacementForSorted methodsFor: 'tests - copying with replacement for sorted' stamp: ''!
testCopyReplaceAllWithForSorted
	| collection result |
	collection := self collectionOfSize5.

	"Testing that elements to be replaced are removed from the copy :"
	result := collection copyReplaceAll: collection with: self empty.
	self assertEmpty: result.

	"Testing that replacement elements  are all put into the copy :"
	result := collection copyReplaceAll: collection with: self replacementCollection.
	self replacementCollection do: [ :each | self assert: (result occurrencesOf: each) equals: (self replacementCollection occurrencesOf: each) ].

	self assert: result size equals: self replacementCollection size! !

!TCopySequenceableWithReplacementForSorted methodsFor: 'requirements' stamp: ''!
replacementCollection
" return a collection including elements of type 'collectionOfSize5' elements'type"
self explicitRequirement! !

!TCopySequenceableWithReplacementForSorted methodsFor: 'requirements' stamp: ''!
collectionOfSize5
" return a collection of size 5"
self explicitRequirement! !

!TCopySequenceableWithReplacementForSorted methodsFor: 'tests - copying with replacement for sorted' stamp: ''!
testCopyFromToWithForSorted
	| collection result |
	collection := self collectionOfSize5.

	"Testing that elements to be replaced are removed from the copy :"
	result := collection copyReplaceFrom: 1 to: collection size with: self empty.
	self assertEmpty: result.

	"Testing that replacement elements  are all put into the copy :"
	result := collection copyReplaceFrom: 1 to: collection size with: self replacementCollection.
	self replacementCollection do: [ :each | self assert: (result occurrencesOf: each) equals: (self replacementCollection occurrencesOf: each) ].

	self assert: result size equals: self replacementCollection size! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCopySequenceableWithReplacementForSorted classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TCopyTest commentStamp: ''!
Tests whether a copied object contains the same elements than its source.
Note that the order is not garanteed -- see TEqualityTest for that. 

!
!TCopyTest methodsFor: 'tests - copy' stamp: ''!
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! !

!TCopyTest methodsFor: 'requirements' stamp: ''!
collectionNotIncluded
" return a collection for wich each element is not included in 'nonEmpty' "
	^ self explicitRequirement! !

!TCopyTest methodsFor: 'tests - copy' stamp: ''!
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)]]! !

!TCopyTest methodsFor: 'requirements' stamp: ''!
empty
	^ self explicitRequirement! !

!TCopyTest methodsFor: 'requirements' stamp: ''!
collectionWithElementsToRemove
" return a collection of elements included in 'nonEmpty'  "
	^ self explicitRequirement! !

!TCopyTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	^ self explicitRequirement! !

!TCopyTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithoutAll

	| res |
	res := self empty copyWithoutAll: self collectionWithElementsToRemove.
	self assert: res size equals: self empty size.
	self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! !

!TCopyTest methodsFor: 'tests - copy' stamp: ''!
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) ] ]! !

!TCopyTest methodsFor: 'tests - copy' stamp: ''!
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 ]! !

!TCopyTest methodsFor: 'tests - copy' stamp: ''!
testCopyNotSame
	"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! !

!TCopyTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWith

	| res anElement |
	anElement := self elementToAdd.
	res := self empty copyWith: anElement.
	self assert: res size equals: (self empty size + 1).
	self assert: (res includes: (anElement value))! !

!TCopyTest methodsFor: 'tests - copy' stamp: ''!
testCopyEmptyWithout

	| res |
	res := self empty copyWithout: self elementToAdd.
	self assert: res size equals: self empty size.
	self deny: (res includes: self elementToAdd)! !

!TCopyTest methodsFor: 'tests - copy' stamp: ''!
testCopyEquals
	"A copy should be equivalent to the things it's a copy of."
	
	| copy | 
	copy := self nonEmpty copy.
	self assert: copy equals: self nonEmpty! !

!TCopyTest methodsFor: 'tests - fixture' stamp: ''!
test0CopyTest
	self empty.
	self assertEmpty: self empty.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self collectionWithElementsToRemove.
	self denyEmpty: self collectionWithElementsToRemove.
	self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ].
	self elementToAdd.
	self deny: (self nonEmpty includes: self elementToAdd).
	self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! !

!TCopyTest methodsFor: 'requirements' stamp: ''!
elementToAdd
" return an element of type 'nonEmpy' elements'type'  not  yet included in nonEmpty" 
	^ self explicitRequirement! !

!TCopyTest methodsFor: 'tests - copy' stamp: ''!
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) ]! !

!TCopyTest methodsFor: 'tests - copy' stamp: ''!
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) ]! !

!TCopyTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCopyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCopyTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCopyTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCopyTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCopyTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCopyTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCopyTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCopyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopyTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCopyTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCopyTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCopyTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCopyTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCopyTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCopyTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCopyTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCopyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCopyTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCopyTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCopyTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCopyTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCopyTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCopyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCopyTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCopyTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TCreationWithTest commentStamp: ''!
A trait for test purposes!
!TCreationWithTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!TCreationWithTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!TCreationWithTest methodsFor: 'tests - creation' stamp: ''!
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)) equals: (collection occurrencesOf: (collection at: i)) ]! !

!TCreationWithTest methodsFor: 'tests - creation' stamp: ''!
testWithAll

	| aCol collection |
	collection := self collectionMoreThan5Elements asOrderedCollection.
	aCol := self collectionClass withAll: collection.
	
	collection do: [ :each | self assert: (aCol occurrencesOf: each ) equals: ( collection occurrencesOf: each ) ].
	
	self assert: aCol size equals: collection size! !

!TCreationWithTest methodsFor: 'requirements' stamp: ''!
collectionClass 
	"Return the class to be used to create instances of the class tested"
	
	^ self explicitRequirement! !

!TCreationWithTest methodsFor: 'tests - creation' stamp: ''!
testWith
	
	| aCol anElement |
	anElement := self collectionMoreThan5Elements anyOne.
	aCol := self collectionClass with: anElement.
	self assert: (aCol includes: anElement).! !

!TCreationWithTest methodsFor: 'tests - creation' stamp: ''!
testOfSize
	
	| aCol |
	aCol := self collectionClass ofSize: 3.
	self assert: aCol size equals: 3.! !

!TCreationWithTest methodsFor: 'tests - creation' stamp: ''!
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 ) equals: (collection occurrencesOf: element1).
	self assert: (aCol occurrencesOf: element2 ) equals: (collection occurrencesOf: element2)! !

!TCreationWithTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCreationWithTest

	self collectionMoreThan5Elements.
	self assert: self collectionMoreThan5Elements size >= 5! !

!TCreationWithTest methodsFor: 'requirements' stamp: ''!
collectionMoreThan5Elements
" return a collection including at least 5 elements"
	
	^ self explicitRequirement! !

!TCreationWithTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TCreationWithTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TCreationWithTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TCreationWithTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TCreationWithTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TCreationWithTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TCreationWithTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TCreationWithTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TCreationWithTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCreationWithTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TCreationWithTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TCreationWithTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TCreationWithTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TCreationWithTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TCreationWithTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TCreationWithTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TCreationWithTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TCreationWithTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TCreationWithTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TCreationWithTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TCreationWithTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TCreationWithTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TCreationWithTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TCreationWithTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TCreationWithTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TCreationWithTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDebugger commentStamp: ''!
Use me if you want to be recognized as a debugger.
I specify the interface that all debuggers must implement to be used as debuggers.
Conversely, classes recognized as debuggers are all able to start debugging from a given debug session.

The API that all debuggers will expose by using me is:

`availableAutomatically:` a boolean telling if the debugger is (de)activated.
`rank:` an integer giving a priority to the debugger (against other debuggers priorities). A high priority debugger will be preferably opened by the system rather than a low priority debugger.

`handlesContext: aContext`: returns a boolean, tells if the debugger can handle the given context (e.g., a SUnit debugger will be able to handle test cases contexts). By default, any context is handleable.

`debugSession: aDebugSession`: Explicit requirement that must be implemented by all debuggers.
This API method is the entry point to open a debugger on a DebugSession instance.
It is the preferred debugger opening entry point used by the system to open a debugger.!
!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDebugger classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDebugger classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDebugger classTrait methodsFor: 'instance creation' stamp: ''!
debugSession: aDebugSession
	self explicitRequirement! !

!TDebugger classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDebugger classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDebugger classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDebugger classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDebugger classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDebugger classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDebugger classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDebugger classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDebugger classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDebugger classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
rank
	^rank ifNil:[rank := self defaultDebuggerRank]! !

!TDebugger classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
closeAllDebuggers
	^ self explicitRequirement! !

!TDebugger classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDebugger classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
availableAutomatically: anObject
	availableAutomatically := anObject! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
defaultDebuggerRank

	^ DebuggerSettings defaultDebuggerRank! !

!TDebugger classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
availableAutomatically
	^ availableAutomatically ifNil: [ 
		  availableAutomatically := DebuggerSettings defaultAvailability ]! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDebugger classTrait methodsFor: 'debugging' stamp: ''!
handlesContext: aContext
	^true! !

!TDebugger classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDebugger classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDebugger classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDebugger classTrait methodsFor: 'accessing' stamp: ''!
rank: anInteger
	rank := anInteger! !

!TDebuggerTest methodsFor: 'tests' stamp: ''!
testDebugSession
	self assert: (self class debugSession: nil)! !

!TDebuggerTest methodsFor: 'tests' stamp: ''!
testSystemDebuggers

	| debuggers traitUsersWithSubclasses |
	debuggers := DebuggerSettings systemDebuggers.
	traitUsersWithSubclasses := TDebugger users flatCollect: [ :class | 
		                            class withAllSubclasses ].
	self assert: (debuggers allSatisfy: [ :dbg | 
			 traitUsersWithSubclasses includes: dbg ]).
	self deny: (debuggers anySatisfy: [ :dbg | dbg isTestCase ])! !

!TDebuggerTest methodsFor: 'tests' stamp: ''!
testRank
	self class rank: nil.
	self assert: self class rank equals: DebuggerSettings defaultDebuggerRank.
	self class rank: 1.
	self assert: self class rank equals: 1! !

!TDebuggerTest methodsFor: 'tests' stamp: ''!
testAvailableAutomatically
	self class availableAutomatically: nil.
	self
		assert: self class availableAutomatically
		equals: DebuggerSettings defaultAvailability.
	self class availableAutomatically: true.
	self assert: self class availableAutomatically.
	self class availableAutomatically: false.
	self deny: self class availableAutomatically! !

!TDebuggerTest methodsFor: 'tests' stamp: ''!
testHandlesContext
	"By default handles any context"
	self assert: (self class handlesContext: nil)! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDebuggerTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDebuggerTest class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDebuggerTest class methodsFor: 'instance creation' stamp: ''!
debugSession: aDebugSession
	^true! !

!TDebuggerTest class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDebuggerTest class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDebuggerTest class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDebuggerTest class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDebuggerTest class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDebuggerTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDebuggerTest class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDebuggerTest class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDebuggerTest class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDebuggerTest class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
rank
	^rank ifNil:[rank := self defaultDebuggerRank]! !

!TDebuggerTest class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
closeAllDebuggers
	"Do nothing. This class is a test class, not a real debugger, so it cannot stay open like real debugger. Therefore, it has nothing to do to 'close all of its debuggers'"

	^ self! !

!TDebuggerTest class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDebuggerTest class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
availableAutomatically: anObject
	availableAutomatically := anObject! !

!TDebuggerTest class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!TDebuggerTest class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
defaultDebuggerRank

	^ DebuggerSettings defaultDebuggerRank! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!TDebuggerTest class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
availableAutomatically
	^ availableAutomatically ifNil: [ 
		  availableAutomatically := DebuggerSettings defaultAvailability ]! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDebuggerTest class methodsFor: 'debugging' stamp: ''!
handlesContext: aContext
	^true! !

!TDebuggerTest class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDebuggerTest class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDebuggerTest class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDebuggerTest class methodsFor: 'accessing' stamp: ''!
rank: anInteger
	rank := anInteger! !

!TDictionaryAddingTest commentStamp: ''!
A trait for test purposes!
!TDictionaryAddingTest methodsFor: 'tests - adding' stamp: ''!
testAddAll
	
	| collectionToAdd collection result oldSize |
	collection := self nonEmptyDict .
	oldSize := collection size.
	collectionToAdd := self collectionClass new 
		add: self associationWithKeyAlreadyInToAdd ; 
		add: self associationWithKeyNotInToAdd ; 
		yourself.
	
	result := collection addAll: collectionToAdd .
	
	self assert: result = collectionToAdd .
	"  the association with the key already in should have replaced the oldest :"
	self assert: collection  size = (oldSize + 1).
	
	result associationsDo: [:assoc | self assert: (collection at:  (assoc key) ) = assoc value].! !

!TDictionaryAddingTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryAddingTest
	self nonEmptyDict.
	self denyEmpty: self nonEmptyDict.
	self associationWithKeyNotInToAdd.
	self deny: (self nonEmptyDict keys includes: self associationWithKeyNotInToAdd key).
	self associationWithKeyAlreadyInToAdd.
	self assert: (self nonEmptyDict keys includes: self associationWithKeyAlreadyInToAdd key)! !

!TDictionaryAddingTest methodsFor: 'tests - adding' stamp: ''!
testAddWithKeyNotIn
	| dictionary result association oldSize |
	dictionary := self nonEmptyDict.
	oldSize := dictionary size.
	association := self associationWithKeyNotInToAdd.
	result := dictionary add: association.

	self assert: result equals: association.
	self assert: (dictionary at: association key) equals: association value.
	self assert: dictionary size equals: oldSize + 1! !

!TDictionaryAddingTest methodsFor: 'requirements' stamp: ''!
nonEmptyDict
	self explicitRequirement! !

!TDictionaryAddingTest methodsFor: 'requirements' stamp: ''!
associationWithKeyNotInToAdd
	" return an association that will be used to add to nonEmptyDict (the key of this association is not included in nonEmptyDict)"
	self explicitRequirement! !

!TDictionaryAddingTest methodsFor: 'tests - adding' stamp: ''!
testAddWithKeyAlreadyIn
	| dictionary result association oldSize |
	dictionary := self nonEmptyDict.
	oldSize := dictionary size.
	association := self associationWithKeyAlreadyInToAdd.
	result := dictionary add: association.

	self assert: result = association.
	self assert: (dictionary at: association key) = association value.
	self assert: dictionary size equals: oldSize! !

!TDictionaryAddingTest methodsFor: 'tests - adding' stamp: ''!
testDeclareFrom
	| newDict v dictionary keyIn associationKeyNotIn |
	dictionary := self nonEmptyDict.
	keyIn := dictionary keys anyOne.
	associationKeyNotIn := self associationWithKeyNotInToAdd.
	newDict := self collectionClass new
		add: associationKeyNotIn;
		yourself.

	"if the key already exist, nothing changes"
	v := dictionary at: keyIn.
	dictionary declare: keyIn from: newDict.
	self assert: (dictionary at: keyIn) equals: 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) equals: associationKeyNotIn value.
	self assert: newDict size equals: 0! !

!TDictionaryAddingTest methodsFor: 'requirements' stamp: ''!
associationWithKeyAlreadyInToAdd
	" return an association that will be used to add to nonEmptyDict (the key of this association is already included in nonEmptyDict)"
	self explicitRequirement! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryAddingTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryAddingTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryAddingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryAddingTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryAddingTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryAddingTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryAddingTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryAddingTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryAddingTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryAddingTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryAddingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryAddingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryAddingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryAddingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryAddingTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryAddingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryAssociationAccessTest commentStamp: ''!
A trait for test purposes!
!TDictionaryAssociationAccessTest methodsFor: 'tests - dictionary assocition access' stamp: ''!
testAssociationAtIfPresent

	| collection keyIn result |
	collection := self nonEmpty.
	keyIn := collection keys anyOne.

	result := collection associationAt: keyIn ifPresent: [:assoc | {#present. assoc}].
	self
		assert: result isArray;
		assert: result size = 2;
		assert: result first = #present;
		assert: result second key = keyIn;
		assert: result second value = (collection at: keyIn).

	"test that cull: is used to support zero-arg blocks"
	result := collection associationAt: keyIn ifPresent: [#present].
	self assert: result = #present.

	result := collection associationAt: self keyNotIn ifPresent: [:assoc | {#present. assoc}].
	self assert: result isNil.! !

!TDictionaryAssociationAccessTest methodsFor: 'requirements' stamp: ''!
nonEmpty
^ self explicitRequirement! !

!TDictionaryAssociationAccessTest methodsFor: 'tests - dictionary assocition access' stamp: ''!
testAssociationAtIfAbsent

	| collection keyIn result |
	collection := self nonEmpty.
	keyIn := collection keys anyOne.

	result := collection associationAt: keyIn ifAbsent: [888]. 

	self assert: (result key) = keyIn.
	self assert: (result value ) = (collection at: keyIn ).

	self assert: (collection associationAt: self keyNotIn  ifAbsent: [888] ) = 888! !

!TDictionaryAssociationAccessTest methodsFor: 'tests - dictionary assocition access' stamp: ''!
testAssociationAtError

	| collection nonExistantKey |
	collection := self nonEmpty.
	nonExistantKey := self keyNotIn .

	self should: [collection associationAt: nonExistantKey] raise: Error.! !

!TDictionaryAssociationAccessTest methodsFor: 'requirements' stamp: ''!
keyNotIn
" return a key not included in nonEmpty"
self explicitRequirement! !

!TDictionaryAssociationAccessTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryAssocitionAccess
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self keyNotIn.
	self deny: (self nonEmpty keys includes: self keyNotIn)! !

!TDictionaryAssociationAccessTest methodsFor: 'tests - dictionary assocition access' stamp: ''!
testAssociationAt
	| collection keyIn result |
	collection := self nonEmpty.
	keyIn := collection keys anyOne.

	result := collection associationAt: keyIn.

	self assert: result key equals: keyIn.
	self assert: result value equals: (collection at: keyIn)! !

!TDictionaryAssociationAccessTest methodsFor: 'tests - dictionary assocition access' stamp: ''!
testAssociationAtIfPresentifAbsent
	| collection keyIn found |
	found := false.
	collection := self nonEmpty.
	keyIn := collection keys anyOne.
	collection associationAt: keyIn ifPresent: [ found := true ] ifAbsent: [ 888 ].
	self assert: found.

	self assert: (collection associationAt: self keyNotIn ifAbsent: [ 888 ]) = 888.

	self assert: (collection associationAt: self keyNotIn ifPresent: [ 666 ] ifAbsent: [ 888 ]) = 888! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryAssociationAccessTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryAssociationAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryComparingTest commentStamp: ''!
A trait for test purposes!
!TDictionaryComparingTest methodsFor: 'tests - comparing' stamp: ''!
testEquality
	| nonEmptyDict2 |
	nonEmptyDict2 := self nonEmpty class new.
	self nonEmpty keysAndValuesDo:  [ :key :value | nonEmptyDict2 at: key put: value  ].
	
	self assert: (self nonEmptyDict = nonEmptyDict2)! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryComparingTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryComparingTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryComparingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryComparingTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryComparingTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryComparingTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryComparingTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryComparingTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryComparingTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryComparingTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryComparingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryComparingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryComparingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryComparingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryComparingTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryComparingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryCopyingTest commentStamp: ''!
A trait for test purposes!
!TDictionaryCopyingTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyEmpty
	self assertEmpty: self empty copy! !

!TDictionaryCopyingTest methodsFor: 'tests - copying' stamp: ''!
testDictionaryConcatenationWithCommonKeys

	| dictionary1 dictionary2 result |
	dictionary1 := self nonEmptyDict.
	dictionary2 := self nonEmptyDict.
	result := dictionary1 , dictionary2.
	self assert: result size = ( dictionary2 size).
	
	dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! !

!TDictionaryCopyingTest methodsFor: 'tests - copying' stamp: ''!
testDictionaryConcatenationWithCommonKeysDifferentValues

	| dictionary1 dictionary2 result value |
	
	dictionary1 := self nonEmptyDict.
	value := self nonEmptyDifferentFromNonEmptyDict   values anyOne.
	dictionary2 := dictionary1 copy.
	dictionary2 keys do: [ :key | dictionary2 at: key put: value ].
	
	
	result := dictionary1 , dictionary2.
	self assert: result size = ( dictionary2 size).
	
	dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! !

!TDictionaryCopyingTest methodsFor: 'requirements' stamp: ''!
nonEmptyDict
	self explicitRequirement! !

!TDictionaryCopyingTest methodsFor: 'helper' stamp: ''!
empty

	^ self explicitRequirement! !

!TDictionaryCopyingTest methodsFor: 'helper' stamp: ''!
nonEmpty

	^ self explicitRequirement! !

!TDictionaryCopyingTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureCloneTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!TDictionaryCopyingTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryCopyingTest
	| duplicateKey |
	self nonEmptyDict.
	self denyEmpty: self nonEmptyDict.
	self nonEmptyDifferentFromNonEmptyDict.
	self denyEmpty: self nonEmptyDifferentFromNonEmptyDict.
	duplicateKey := true.
	self nonEmptyDict keys detect: [ :key | self nonEmptyDifferentFromNonEmptyDict includes: key ] ifNone: [ duplicateKey := false ].
	self deny: duplicateKey! !

!TDictionaryCopyingTest methodsFor: 'requirements' stamp: ''!
newEmptyDict
	self explicitRequirement! !

!TDictionaryCopyingTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyNonEmpty
	| copy |
	copy := self nonEmpty copy.
	self denyEmpty: copy.
	self assert: copy size = self nonEmpty size.
	self nonEmpty do: [ :each | copy includes: each ]! !

!TDictionaryCopyingTest methodsFor: 'requirements' stamp: ''!
emptyDict
	self explicitRequirement! !

!TDictionaryCopyingTest methodsFor: 'tests - copy - clone' stamp: ''!
testCopyCreatesNewObject
	
	| copy | 
	copy := self nonEmpty copy.
	self deny: self nonEmpty == copy.! !

!TDictionaryCopyingTest methodsFor: 'requirements' stamp: ''!
nonEmptyDifferentFromNonEmptyDict
" return a dictionary for which all keys are not included in nonEmptyDict"
self explicitRequirement.! !

!TDictionaryCopyingTest methodsFor: 'tests - copying' stamp: ''!
testDictionaryConcatenationWithoutCommonKeys

	| dictionary1 dictionary2 result |
	dictionary1 := self nonEmptyDict.
	dictionary2 := self nonEmptyDifferentFromNonEmptyDict.
	result := dictionary1 , dictionary2.
	self assert: result size = (dictionary1 size + dictionary2 size).
	dictionary1 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ].
	dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryCopyingTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryCopyingTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryCopyingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryCopyingTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryCopyingTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryCopyingTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryCopyingTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryCopyingTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryCopyingTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryCopyingTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryCopyingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryCopyingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryCopyingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryCopyingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryCopyingTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryCopyingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryEnumeratingTest commentStamp: ''!
A trait for test purposes!
!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testReject
	"Ensure that Dictionary>>reject: answers a dictionary not something else"
	
	| collection result |
	collection := self nonEmptyDict .
	result := collection reject: [ :each | false].
	
	self assert: result = collection.! !

!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testDo
	| t collection |
	collection := self nonEmptyDict .
	t := OrderedCollection new.
	collection do: [:
		value | t add: value
		].
	
	t do: [ :each | self assert: (t occurrencesOf: each ) = ( collection values occurrencesOf: each) ].! !

!TDictionaryEnumeratingTest methodsFor: 'requirements' stamp: ''!
nonEmptyDict
	self explicitRequirement! !

!TDictionaryEnumeratingTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryEnumeratingTest
	self nonEmptyDict.
	self denyEmpty: self nonEmptyDict! !

!TDictionaryEnumeratingTest methodsFor: 'requirements' stamp: ''!
newEmptyDict
	self explicitRequirement! !

!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testKeysAndValuesDo

	
	| collection keys |
	collection := self nonEmptyDict .
	keys := OrderedCollection new.
	collection keysAndValuesDo: [ :key :value | 
		keys add: key.
		self assert: (collection at: key) = value ].
	
	collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]! !

!TDictionaryEnumeratingTest methodsFor: 'requirements' stamp: ''!
emptyDict
	self explicitRequirement! !

!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testSelect
	| collection values result |
	collection := self nonEmptyDict .
	values := OrderedCollection new.
	result := collection select: [ :value  | 
		values add: value.
		true].
	
	collection values do: [ :value| self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)].
	self assert: result = collection.! !

!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testKeysDo
	| collection keys |
	collection := self nonEmptyDict .
	keys := OrderedCollection new.
	collection keysDo: [ :key  | 
		keys add: key.
		].
	
	collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]! !

!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testValuesDo
	| collection values |
	collection := self nonEmptyDict .
	values := OrderedCollection new.
	collection valuesDo: [ :value  | 
		values add: value.
		].
	
	collection values do: [ :value | self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]! !

!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testAssociationsSelect
	| collection keys result |
	collection := self nonEmptyDict .
	keys := OrderedCollection new.
	result := collection associationsSelect: [ :assoc  | 
		keys add: assoc key.
		true].
	
	collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)].
	self assert: result = collection.! !

!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testCollect
	| collection values result |
	collection := self nonEmptyDict .
	values := OrderedCollection new.
	result := collection collect: [ :value  | 
		values add: value.
		].
	
	collection values do: [ :value | self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)].
	self assert: result = collection.! !

!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: ''!
testAssociationsDo

	| collection keys |
	collection := self nonEmptyDict .

	keys := OrderedCollection new.
	
	collection associationsDo: [ :assoc | 
		keys add: assoc key.
		self assert: ( collection at: assoc key ) = assoc value.		
		].
	
	collection keys do: [:key | self assert: ( keys occurrencesOf: key ) = (collection keys occurrencesOf: key)].! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryEnumeratingTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryImplementationTest commentStamp: ''!
A trait for test purposes!
!TDictionaryImplementationTest methodsFor: 'tests - implementation' stamp: ''!
testPseudo
	"(self run: #testPseudo)"

	"true and false are valid keys"

	| dict1 |
	dict1 := self emptyDict.
	dict1 at: true put: #true.
	self assert: (dict1 at: true) = #true.
	dict1 at: false put: #false.
	self assert: (dict1 at: false) = #false! !

!TDictionaryImplementationTest methodsFor: 'tests - implementation' stamp: ''!
testScanFor
	"Set>>scanFor: return an integer "
	| assoc indexForG |
	assoc := #g -> 100.
	self assert: (self nonEmptyDict scanFor: assoc) = (self nonEmptyDict array indexOf: nil).

	indexForG := (#g hash \\ self emptyDict array size) + 1.
	self assert: (self emptyDict scanFor: assoc) = ((self emptyDict array indexOf: nil) max: indexForG).! !

!TDictionaryImplementationTest methodsFor: 'tests - implementation' stamp: ''!
testPseudoVariablesAreValidKeys
	"(self run: #testPseudoVariablesAreValidKeys)"

	"true and false are valid keys"

	| dict1 |
	dict1 := self emptyDict.
	dict1 at: true put: #true.
	self assert: (dict1 at: true) = #true.
	dict1 at: false put: #false.
	self assert: (dict1 at: false) = #false! !

!TDictionaryImplementationTest methodsFor: 'tests - implementation' stamp: ''!
testFindElementOrNil
	"Set>>findElementOrNil: takes an associaiton (when called on a dictionary) an integer, the index of the first
	position at is either equal to the assocation or which is nil"
	| assoc indexForG |
	assoc := #g -> 100.
	self assert: (self nonEmptyDict findElementOrNil: assoc key) = (self nonEmptyDict array indexOf: nil).
	
	indexForG := (#g hash \\ self emptyDict array size) + 1.
	self assert: (self emptyDict findElementOrNil: assoc key) = ((self emptyDict array indexOf: nil) max: indexForG).! !

!TDictionaryImplementationTest methodsFor: 'tests - implementation' stamp: ''!
testNew
	| d |
	d := self classToBeTested new: 10.
	self assert: d size = 0.
	
	"Why 14? Mysterious"
	self assert: d capacity = 14! !

!TDictionaryImplementationTest methodsFor: 'tests - implementation' stamp: ''!
testAtNil
	"(self run: #testAtNil)"

	"nil is a valid key in Pharo. In VW nil is not a valid key"

	"Ansi 1.9 p, 168
    		5.7.2.5 Message: at: key put: newElement
    		Synopsis
    			Store newElement at key in the receiver. Answer newElement.
    		Definition: <abstractDictionary>
    		If lookup succeeds for key, then newElement replaces the element previously stored at key.
    		Otherwise, the newElement is stored at the new key. In either case, subsequent successful
    		lookups for key will answer newElement.  Answer newElement.

    		The result is undefined if the key is nil.

		This clearly indicates that different smalltalks where doing different assumptions."

	| dict1 |
	dict1 := self emptyDict.
	dict1 at: nil put: #none.
	self assert: (dict1 at: nil) = #none! !

!TDictionaryImplementationTest methodsFor: 'tests - implementation' stamp: ''!
testSpecies
	self assert: self nonEmptyDict species == self nonEmptyDict class.
	self assert: self emptyDict species == self emptyDict class! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryImplementationTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryImplementationTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryImplementationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryImplementationTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryImplementationTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryImplementationTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryImplementationTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryImplementationTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryImplementationTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryImplementationTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryImplementationTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryImplementationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryImplementationTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryImplementationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryImplementationTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryImplementationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryIncludesTest commentStamp: ''!
A trait for test purposes!
!TDictionaryIncludesTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryIncludes
	| in |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self valueNotInNonEmpty.
	in := false.
	self nonEmpty valuesDo: [ :assoc | assoc = self valueNotInNonEmpty ifTrue: [ in := true ] ].
	self deny: in.
	self keyNotInNonEmpty.
	in := false.
	self nonEmpty keysDo: [ :assoc | assoc = self keyNotInNonEmpty ifTrue: [ in := true ] ].
	self deny: in! !

!TDictionaryIncludesTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesComportementForDictionnary
	| valueIn collection keyIn |
	collection := self nonEmpty.
	valueIn := collection values anyOne.
	keyIn := collection keys anyOne.
	self assert: (collection includes: valueIn).
	self deny: (collection includes: self valueNotInNonEmpty).
	" testing that includes take only care of values :"
	self deny: (collection includes: keyIn)! !

!TDictionaryIncludesTest methodsFor: 'requirements' stamp: ''!
keyNotInNonEmpty
	" return a key not included in nonEmpty"
	^ self explicitRequirement! !

!TDictionaryIncludesTest methodsFor: 'requirements' stamp: ''!
nonEmpty

^self explicitRequirement! !

!TDictionaryIncludesTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesIdentityBasicComportement

| valueIn collection |
collection := self nonEmpty .
valueIn := collection  values anyOne.

self assert: (collection includesIdentity: valueIn ) .
self deny: (collection includesIdentity: self valueNotInNonEmpty ).! !

!TDictionaryIncludesTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesKey

	| collection keyIn nonExistantKey |

	collection := self nonEmpty .
	keyIn := collection keys anyOne.
	nonExistantKey := self keyNotInNonEmpty. 

	self assert: ( collection includesKey: keyIn ).
	self deny: ( collection includesKey: nonExistantKey ).! !

!TDictionaryIncludesTest methodsFor: 'requirements' stamp: ''!
valueNotInNonEmpty
	" return a value not included in nonEmpty"
	^ self explicitRequirement! !

!TDictionaryIncludesTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesAssociation

	|  nonExistantAssociation associationIn keyIn valueIn |

	keyIn := self nonEmpty keys anyOne.
	valueIn := self nonEmpty values anyOne. 
	nonExistantAssociation := self keyNotInNonEmpty -> self valueNotInNonEmpty .
	associationIn := self nonEmpty associations anyOne.	

	self assert:  (self nonEmpty includesAssociation: associationIn ).
	self deny:  (self nonEmpty includesAssociation: nonExistantAssociation ).
	" testing the case where key is included but not with the same value :"
	self deny: (self nonEmpty includesAssociation: (keyIn-> self valueNotInNonEmpty )).
	" testing the case where value is included but not corresponding key :"
	self deny: (self nonEmpty includesAssociation: (self keyNotInNonEmpty -> valueIn  )).! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryIncludesTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryIncludesTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryIncludesTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryIncludesTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryIncludesTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryIncludesTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryIncludesTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryIncludesTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryIncludesTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryIncludesTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryIncludesTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryIncludesTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryIncludesTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryIncludesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryIncludesTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryIncludesTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryIncludesWithIdentityCheckTest commentStamp: ''!
A trait for test purposes!
!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryIncludes
	| in |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self valueNotInNonEmpty.
	in := false.
	self nonEmpty valuesDo: [ :assoc | assoc = self valueNotInNonEmpty ifTrue: [ in := true ] ].
	self deny: in.
	self keyNotInNonEmpty.
	in := false.
	self nonEmpty keysDo: [ :assoc | assoc = self keyNotInNonEmpty ifTrue: [ in := true ] ].
	self deny: in! !

!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesComportementForDictionnary
	| valueIn collection keyIn |
	collection := self nonEmpty.
	valueIn := collection values anyOne.
	keyIn := collection keys anyOne.
	self assert: (collection includes: valueIn).
	self deny: (collection includes: self valueNotInNonEmpty).
	" testing that includes take only care of values :"
	self deny: (collection includes: keyIn)! !

!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: ''!
keyNotInNonEmpty
	" return a key not included in nonEmpty"
	^ self explicitRequirement! !

!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: ''!
nonEmpty

^self explicitRequirement! !

!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesIdentityBasicComportement

| valueIn collection |
collection := self nonEmpty .
valueIn := collection  values anyOne.

self assert: (collection includesIdentity: valueIn ) .
self deny: (collection includesIdentity: self valueNotInNonEmpty ).! !

!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithCopyNonIdentical
" return a collection including elements for wich copy is not identical to the initial element ( this is not the cas of Integer )"
^self explicitRequirement! !

!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesIdentitySpecificComportement

| valueIn collection |
collection := self nonEmptyWithCopyNonIdentical  .
valueIn := collection  values anyOne.

self assert: (collection includesIdentity: valueIn ) .
self deny: (collection includesIdentity: valueIn copy ) .! !

!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesKey

	| collection keyIn nonExistantKey |

	collection := self nonEmpty .
	keyIn := collection keys anyOne.
	nonExistantKey := self keyNotInNonEmpty. 

	self assert: ( collection includesKey: keyIn ).
	self deny: ( collection includesKey: nonExistantKey ).! !

!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: ''!
valueNotInNonEmpty
	" return a value not included in nonEmpty"
	^ self explicitRequirement! !

!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - dictionary including' stamp: ''!
testIncludesAssociation

	|  nonExistantAssociation associationIn keyIn valueIn |

	keyIn := self nonEmpty keys anyOne.
	valueIn := self nonEmpty values anyOne. 
	nonExistantAssociation := self keyNotInNonEmpty -> self valueNotInNonEmpty .
	associationIn := self nonEmpty associations anyOne.	

	self assert:  (self nonEmpty includesAssociation: associationIn ).
	self deny:  (self nonEmpty includesAssociation: nonExistantAssociation ).
	" testing the case where key is included but not with the same value :"
	self deny: (self nonEmpty includesAssociation: (keyIn-> self valueNotInNonEmpty )).
	" testing the case where value is included but not corresponding key :"
	self deny: (self nonEmpty includesAssociation: (self keyNotInNonEmpty -> valueIn  )).! !

!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryIncludesIdentity
	self nonEmptyWithCopyNonIdentical.
	self denyEmpty: self nonEmptyWithCopyNonIdentical.
	self nonEmptyWithCopyNonIdentical do: [ :each | self deny: each == each copy ]! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryKeyAccessTest commentStamp: ''!
A trait for test purposes!
!TDictionaryKeyAccessTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithoutEqualsValues
" return a dictionary that doesn't include equal values'"
^self explicitRequirement! !

!TDictionaryKeyAccessTest methodsFor: 'tests - dictionary key access' stamp: ''!
testKeyAtIdentityValue
	
	
	| dict value result |
	dict := self nonEmpty .
	value := dict values anyOne.
	
	result := dict keyAtIdentityValue: value.
	self assert: (dict at: result) = value.
		
	self should: [dict keyAtIdentityValue: self valueNotIn ] raise: Error! !

!TDictionaryKeyAccessTest methodsFor: 'tests - dictionary key access' stamp: ''!
testKeyAtValue
	"self run: #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! !

!TDictionaryKeyAccessTest methodsFor: 'requirements' stamp: ''!
valueNotIn
" return a value not included in nonEmptyWithoutEqualValues "
^self explicitRequirement! !

!TDictionaryKeyAccessTest methodsFor: 'tests - dictionary key access' stamp: ''!
testKeyAtIdentityValueIfAbsent
	"self run: #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] ) = nil.! !

!TDictionaryKeyAccessTest methodsFor: 'tests - dictionary key access' stamp: ''!
testKeyAtValueIfAbsent
	"self run: #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] ) = nil.! !

!TDictionaryKeyAccessTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryKeyAccess
	| collection equals |
	self nonEmptyWithoutEqualsValues.
	self denyEmpty: self nonEmptyWithoutEqualsValues.
	equals := true.
	collection := self nonEmptyWithoutEqualsValues values.
	collection detect: [ :each | (collection occurrencesOf: each) > 1 ] ifNone: [ equals := false ].
	self deny: equals.
	self valueNotIn.
	self deny: (self nonEmptyWithoutEqualsValues values includes: self valueNotIn)! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryKeyAccessTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryKeyAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryKeysValuesAssociationsAccess commentStamp: ''!
A trait for test purposes!
!TDictionaryKeysValuesAssociationsAccess methodsFor: 'requirements' stamp: ''!
nonEmpty

self explicitRequirement.! !

!TDictionaryKeysValuesAssociationsAccess methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testValues
	
	| collection result |
	collection := self nonEmpty .
	result := collection values.
	
	self assert: result size = collection size.
	result do: [:each | self assert: (collection occurrencesOf:each ) = (result occurrencesOf: each) ].! !

!TDictionaryKeysValuesAssociationsAccess methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testKeys
	| collection result |
	collection := self nonEmpty.
	result := collection keys.
	result do: [ :key | collection at: key ].
	self assert: result size = collection size.
	self should: [ result detect: [ :each | (result occurrencesOf: each) > 1 ] ] raise: Error! !

!TDictionaryKeysValuesAssociationsAccess methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryKeysValuesAssociationsAccess
	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!TDictionaryKeysValuesAssociationsAccess methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testKeysSortedSafely
	| collection result |
	collection := self nonEmpty.
	result := collection keysSortedSafely.
	result do: [ :key | collection at: key ].
	self assert: result size = collection size.
	self should: [ result detect: [ :each | (result occurrencesOf: each) > 1 ] ] raise: Error.
	self assert: result asArray isSorted! !

!TDictionaryKeysValuesAssociationsAccess methodsFor: 'tests - dictionary keys values associations access' stamp: ''!
testAssociations

	| collection result  |
	collection := self nonEmpty .
	result := collection associations.
	
	self assert: result size = collection size.
	result do: [:assoc | self assert: (assoc value) = (collection at: assoc key) ].
	"keys do: [ :key | self assert: ( result at: key ) = ( collection at: key )] ."! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryKeysValuesAssociationsAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryPrintingTest commentStamp: ''!
A trait for test purposes!
!TDictionaryPrintingTest methodsFor: 'requirements' stamp: ''!
nonEmptyDict
	self explicitRequirement! !

!TDictionaryPrintingTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn
	| str |
	str := String new writeStream.
	self nonEmptyDict printElementsOn: str.
	self assert: (str contents = '(#a->1 #b->30 #c->1 #d->-2 )')! !

!TDictionaryPrintingTest methodsFor: 'tests - printing' stamp: ''!
testStoreOn
	| str |
	str := String new writeStream.
	self nonEmptyDict storeOn: str.
	self assert: str contents = '((Dictionary new) add: (#b->30); add: (#c->1); add: (#d->-2); add: (#a->1); yourself)'! !

!TDictionaryPrintingTest methodsFor: 'requirements' stamp: ''!
newEmptyDict
	self explicitRequirement! !

!TDictionaryPrintingTest methodsFor: 'requirements' stamp: ''!
emptyDict
	self explicitRequirement! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryPrintingTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryPrintingTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryPrintingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryPrintingTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryPrintingTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryPrintingTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryPrintingTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryPrintingTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryPrintingTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryPrintingTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryPrintingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryPrintingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryPrintingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryPrintingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryPrintingTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryPrintingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryRemovingTest commentStamp: ''!
A trait for test purposes!
!TDictionaryRemovingTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryRemovingTest
	self nonEmptyDict.
	self denyEmpty: self nonEmptyDict.
	self keyNotInNonEmptyDict.
	self deny: (self nonEmptyDict keys includes: self keyNotInNonEmptyDict)! !

!TDictionaryRemovingTest methodsFor: 'requirements' stamp: ''!
nonEmptyDict
	self explicitRequirement! !

!TDictionaryRemovingTest methodsFor: 'requirements' stamp: ''!
newEmptyDict
	self explicitRequirement! !

!TDictionaryRemovingTest methodsFor: 'requirements' stamp: ''!
emptyDict
	self explicitRequirement! !

!TDictionaryRemovingTest methodsFor: 'tests - removing' stamp: ''!
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! !

!TDictionaryRemovingTest methodsFor: 'requirements' stamp: ''!
keyNotInNonEmptyDict
" return a key not included in nonEmptyDict"
	self explicitRequirement! !

!TDictionaryRemovingTest methodsFor: 'tests - removing' stamp: ''!
testRemoveKeyIfAbsent
	
	| collection oldSize keyIn value result |
	collection := self nonEmptyDict .
	oldSize := collection size.
	keyIn := collection  keys anyOne.
	value := collection at: keyIn .
	
	result := collection removeKey: keyIn ifAbsent: [888].
	
	self assert: result = value.
	self assert: (collection  size = (oldSize - 1)).
	self should: [ (collection  at: keyIn )] raise: Error.
	
	self assert: (collection removeKey: self keyNotInNonEmptyDict ifAbsent: [888] ) = 888.! !

!TDictionaryRemovingTest methodsFor: 'tests - removing' stamp: ''!
testRemove

	self should: [self nonEmptyDict remove: nil] raise: Error.
	self should: [self nonEmptyDict remove: nil ifAbsent: ['What ever here']] raise: Error.! !

!TDictionaryRemovingTest methodsFor: 'tests - removing' stamp: ''!
testKeysAndValuesRemove
	| oldSize collection keyIn |
	
	collection := self nonEmptyDict .
	oldSize := collection  size.
	keyIn := collection keys anyOne.
	
	collection  keysAndValuesRemove: [:key :value | key == self keyNotInNonEmptyDict ].
	self assert: (collection  size = (oldSize )).
	
	collection  keysAndValuesRemove: [:key :value | key == keyIn ].
	self assert: (collection  size = (oldSize - 1)).
	self should: [ collection at: keyIn  ] raise: Error.! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryRemovingTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryRemovingTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryRemovingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryRemovingTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryRemovingTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryRemovingTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryRemovingTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryRemovingTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryRemovingTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryRemovingTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryRemovingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryRemovingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryRemovingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryRemovingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryRemovingTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryRemovingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TDictionaryValueAccessTest commentStamp: ''!
A trait for test purposes!
!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAt
	"self run: #testAt"

	| collection association |
	collection := self nonEmpty.
	association := collection associations anyOne.
	self assert: (collection at: association key) = association value.
	self should: [ collection at: self keyNotIn ] raise: Error! !

!TDictionaryValueAccessTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureDictionaryElementAccess
	| in |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self keyNotIn.
	in := true.
	self nonEmpty keys detect: [ :key | key = self keyNotIn ] ifNone: [ in := false ].
	self deny: in! !

!TDictionaryValueAccessTest methodsFor: 'requirements' stamp: ''!
nonEmpty

^ self explicitRequirement! !

!TDictionaryValueAccessTest methodsFor: 'requirements' stamp: ''!
valueNotIn
	self explicitRequirement! !

!TDictionaryValueAccessTest methodsFor: 'requirements' stamp: ''!
supportsNilKey
	^ true! !

!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtIfAbsentPut
	"self run: #testAtIfAbsentPut"

	| collection association |
	collection := self nonEmpty.
	association := collection associations anyOne.
	self
		assert:
			(collection at: association key ifAbsentPut: [ Error signal ])
				= association value.
	self assert: (collection at: association key) = association value.
	self
		assert:
			(collection at: self keyNotIn ifAbsentPut: [ self valueNotIn ])
				= self valueNotIn.
	self assert: (collection at: self keyNotIn) = self valueNotIn! !

!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtIfPresent
	"self run: #testAtIfPresent"

	| collection association arg |
	collection := self nonEmpty.
	association := collection associations anyOne.
	arg := nil.
	self
		assert:
			(collection
				at: association key
				ifPresent: [ :value | 
					arg := value.
					#present ]) = #present.
	self assert: arg = association value.

	"ensure cull: is used to support blocks that take no args"
	self
		assert: (collection at: association key ifPresent: [ #present ]) = #present.
	self
		assert:
			(collection
				at: self keyNotIn
				ifPresent: [ :value | Error signal ]) isNil! !

!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtPutDict
	"Do not rename to testAtPut, will conflict with TPutBasicTest>>#testAtPut"

	"self run: #testAtPutDict"

	| collection keyIn newValue |
	collection := self nonEmpty.
	keyIn := collection keys anyOne.
	newValue := self valueNotIn.

	"use == to ensure the exact object argument to put: is stored and returned"
	self assert: (collection at: keyIn put: newValue) == newValue.
	self assert: (collection at: keyIn) == newValue.

	newValue := self valueNotIn -> self valueNotIn.
	self assert: (collection at: keyIn put: newValue) == newValue.
	self assert: (collection at: keyIn) == newValue.

	newValue := {self valueNotIn.
	self valueNotIn.
	self valueNotIn}.
	self assert: (collection at: self keyNotIn put: newValue) == newValue.
	self assert: (collection at: self keyNotIn) == newValue! !

!TDictionaryValueAccessTest methodsFor: 'requirements' stamp: ''!
keyNotIn
" return a key not included in nonEmpty"
^ self explicitRequirement! !

!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtIfAbsent
	"self run: #testAtIfAbsent"

	| collection association |
	collection := self nonEmpty.
	association := collection associations anyOne.
	self
		assert:
			(collection at: association key ifAbsent: [ Error signal ])
				= association value.
	self
		assert:
			(collection at: self keyNotIn ifAbsent: [ self valueNotIn ])
				= self valueNotIn! !

!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtIfPresentIfAbsent
	"self run: #testAtIfPresentIfAbsent"

	| collection association arg |
	collection := self nonEmpty.
	association := collection associations anyOne.
	arg := nil.
	self
		assert:
			(collection
				at: association key
				ifPresent: [ :value | 
					arg := value.
					#present ]
				ifAbsent: [ Error signal ]) = #present.
	self assert: arg = association value.

	"ensure cull: is used to support blocks that take no args"
	self
		assert:
			(collection
				at: association key
				ifPresent: [ #present ]
				ifAbsent: [ Error signal ]) = #present.
	self
		assert:
			(collection
				at: self keyNotIn
				ifPresent: [ :value | Error signal ]
				ifAbsent: [ self valueNotIn ]) = self valueNotIn! !

!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtPutNil
	"self run: #testAtPutNil"

	| collection keyIn newValue |
	collection := self nonEmpty.
	keyIn := collection keys anyOne.
	newValue := self valueNotIn.
	self assert: (collection at: nil put: newValue) == newValue.
	self supportsNilKey
		ifTrue: [ self assert: (collection at: nil) == newValue ]
		ifFalse: [ self deny: (collection includesKey: nil) ].
	self assert: (collection at: keyIn put: nil) isNil.
	self assert: (collection at: keyIn) isNil.
	self assert: (collection at: self keyNotIn put: nil) isNil.
	self assert: (collection at: self keyNotIn) isNil.
	self assert: (collection at: nil put: nil) isNil.
	self supportsNilKey
		ifTrue: [ self assert: (collection at: nil) isNil ]
		ifFalse: [ self deny: (collection includesKey: nil) ]! !

!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''!
testAtIfPresentIfAbsentPut
	"self run: #testAtIfPresentIfAbsentPut"

	| collection association arg |
	collection := self nonEmpty.
	association := collection associations anyOne.
	arg := nil.
	self
		assert:
			(collection
				at: association key
				ifPresent: [ :value | 
					arg := value.
					#present ]
				ifAbsentPut: [ Error signal ]) = #present.
	self assert: arg = association value.

	"ensure cull: is used to support blocks that take no args"
	self
		assert:
			(collection
				at: association key
				ifPresent: [ #present ]
				ifAbsentPut: [ Error signal ]) = #present.
	self
		assert:
			(collection
				at: self keyNotIn
				ifPresent: [ :value | Error signal ]
				ifAbsentPut: [ self valueNotIn ]) = self valueNotIn.
	self assert: (collection at: self keyNotIn) = self valueNotIn! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TDictionaryValueAccessTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TDictionaryValueAccessTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TDictionaryValueAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TDictionaryValueAccessTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TDictionaryValueAccessTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TDictionaryValueAccessTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryValueAccessTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TDictionaryValueAccessTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TDictionaryValueAccessTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TDictionaryValueAccessTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TDictionaryValueAccessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TDictionaryValueAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TDictionaryValueAccessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TDictionaryValueAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TDictionaryValueAccessTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TDictionaryValueAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TEasilyThemed commentStamp: ''!
Trait providing useful theme-related methods.!
!TEasilyThemed methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		icon: iconSelector
		getEnabled: enabledSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newAlphaImage: aForm help: helpText
	"Answer an alpha image morph."

	^self theme
		newAlphaImageIn: self
		image: aForm
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText
	"Answer a morph list for the given model."

	^self
		newMorphListFor: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: nil
		help: helpText! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
deny: aStringOrText title: aString
	"Open a denial dialog."

	^self theme
		denyIn: self
		text: aStringOrText
		title: aString! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
question: aStringOrText
	"Open a question dialog."

	^self question: aStringOrText title: 'Question' translated! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel
	"Answer a text editor for the given model."

	^self
		newTextEditorFor: aModel
		getText: getSel
		setText: setSel
		getEnabled: nil! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
message: aStringOrText title: aString
	"Open a message dialog."

	^self theme
		messageIn: self
		text: aStringOrText
		title: aString! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: aModel
		label: aString
		offset: offset
		alpha: alpha
		getEnabled: enabledSel! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newString: aStringOrText style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: aStyle! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newColorPresenterFor: aModel getColor: getSel help: helpText
	"Answer a color presenter with the given selectors."

	^self theme
		newColorPresenterIn: self
		for: aModel
		getColor: getSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: #bottomLeft! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newImage: aForm
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newSeparator
	"Answer an horizontal separator."

	^self theme
		newSeparatorIn: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newScrollPaneFor: aMorph
	"Answer a new scroll pane morph to scroll the given morph."
	
	^self theme
		newScrollPaneIn: self
		for: aMorph! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newStack: controls
	"Answer a morph laid out with a stack of controls."

	^self theme
		newStackIn: self
		for: controls! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newLabelGroup: labelsAndControls
	"Answer a morph laid out with a column of labels and a column of associated controls.
	Controls having a vResizing value of #spaceFill will
	cause their row to use #spaceFill also, otherwise #shrinkWrap."

	^self theme
		newLabelGroupIn: self
		for: labelsAndControls! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newGroupboxForAll: controls
	"Answer a plain groupbox with the given controls."

	^self theme
		newGroupboxIn: self
		forAll: controls! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
message: aStringOrText
	"Open a message dialog."

	^self message: aStringOrText title: 'Information' translated! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newCancelButton
	"Answer a new cancel button."

	^self newCancelButtonFor: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newVerticalSeparator
	"Answer a vertical separator."

	^self theme
		newVerticalSeparatorIn: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText
	"Answer a list for the given model."

	^self
		newListFor: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: nil
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newNoButton
	"Answer a new No button."

	^self newNoButtonFor: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newYesButtonFor: aModel
	"Answer a new yes button."

	^self theme
		newYesButtonIn: self
		for: aModel! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
textEntry: aStringOrText
	"Open a text entry dialog."

	^self textEntry: aStringOrText title: 'Entry' translated! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title for: contentMorph
	"Answer a new pluggable dialog with the given content."

	^self theme
		newPluggableDialogWindowIn: self
		title: title
		for: contentMorph! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newToolbar
	"Answer a toolbar."

	^self theme
		newToolbarIn: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText
	"Answer a bracket slider with the given selectors."

	^self
		newBracketSliderFor: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum 
		getEnabled: nil
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: aClass
		default: defaultValue
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseColor
	"Answer the result of a color selector dialog ."

	^self chooseColor: Color black! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText
		entryCompletion: anEntryCompletion! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newGroupbox: aString
	"Answer a groupbox with the given label."

	^self theme
		newGroupboxIn: self
		label: aString! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow: title
	"Answer a new pluggable dialog with the given content."

	^self
		newPluggableDialogWindow: title
		for: nil! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel help: helpText
	"Answer a text entry for the given model."

	^self
		newTextEntryFor: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: nil 
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a bracket slider with the given selectors."

	^self theme
		newBracketSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: minValue
		max: maxValue
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseFont
	"Answer the result of a font selector dialog."

	^self chooseFont: nil! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newExpander: aString forAll: controls
	"Answer an expander with the given label and controls."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: controls! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		label: (AlphaImageMorph new image: aForm)
		help: helpText! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseExistingFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseExistingFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText
	"Open a question dialog."

	^self questionWithoutCancel: aStringOrText title: 'Question' translated! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseColor: aColor 
	"Answer the result of a color selector dialog with the given color."

	^self theme
		chooseColorIn: self
		title: 'Colour Selector' translated
		color: aColor! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseDirectory: title 
	"Answer the result of a file dialog with the given title, answer a directory."

	^self
		chooseDirectory: title
		path: nil! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText list: aList
	"Open a drop list chooser dialog."

	^self
		chooseDropList: aStringOrText
		title: 'Choose' translated
		list: aList! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel ghostText: ghostText getEnabled: enabledSel help: helpText
	"Answer an editable drop list for the given model."

	^self theme
		newEditableDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		addToList: addSel
		class: String
		default: ''
		ghostText: ghostText
		getEnabled: enabledSel
		useIndex: false
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel 
		help: helpText! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseForSaveFileReference: 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
		chooseForSaveFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector
	"Answer a new tree morph."
	
	^self theme
		newTreeIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newWindowFor: aModel title: titleString
	"Answer a new window morph."
	
	^self theme
		newWindowIn: self
		for: aModel
		title: titleString! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newToolbar: controls
	"Answer a toolbar with the given controls."

	^self theme
		newToolbarIn: self
		for: controls! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newOKButtonFor: aModel getEnabled: enabledSel
	"Answer a new OK button."

	^self theme
		newOKButtonIn: self
		for: aModel
		getEnabled: enabledSel! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newStack
	"Answer a morph laid out as a stack."

	^self theme
		newStackIn: self
		for: #()! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newToolSpacer
	"Answer a tool spacer."

	^self theme
		newToolSpacerIn: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newTitle: aString for: control
	"Answer a morph laid out with a column with a title."

	^self theme
		newTitleIn: self
		label: aString
		for: control! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion

	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel 
		help: helpText
		entryCompletion: anEntryCompletion! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText
	"Answer an inremental slider with the given selectors."

	^self theme
		newIncrementalSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: min
		max: max
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText
	"Answer a slider with the given selectors."

	^self theme
		newSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: 0
		max: 1
		quantum: nil
		getEnabled: enabledSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newOKButtonFor: aModel
	"Answer a new OK button."

	^self
		newOKButtonFor: aModel
		getEnabled: nil! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newCancelButtonFor: aModel
	"Answer a new cancel button."

	^self theme
		newCancelButtonIn: self
		for: aModel! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector
	"Answer a text editor for the given model."

	^self theme
		newTextEditorIn: self
		for: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: menuSelector! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newSVSelector: aColor help: helpText
	"Answer a saturation-volume selector with the given color."

	^self theme
		newSVSelectorIn: self
		color: aColor
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newButtonLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new button text label."

	^self theme
		newButtonLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseFont: aFont 
	"Answer the result of a font selector dialog with the given initial font."

	^self theme
		chooseFontIn: self
		title: 'Font Selector' translated
		font: aFont! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString
	"Open an alert dialog."

	^self
		alert: aStringOrText
		title: aString
		configure: [:d | ]! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newString: aStringOrText
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: self theme labelFont
		style: #plain! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newTabGroup: labelsAndPages
	"Answer a tab group with the given tab labels associated with pages."

	^self theme
		newTabGroupIn: self
		for: labelsAndPages! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newButtonLabel: aString
	"Answer a new button text label."

	^self
		newButtonLabelFor: nil
		label: aString
		getEnabled: nil! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString entryText: defaultEntryText
	"Open a text entry dialog."

	^self theme
		textEntryIn: self
		text: aStringOrText
		title: aString
		entryText: defaultEntryText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a slider with the given selectors."

	^self theme
		newSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: min
		max: max
		quantum: quantum
		getEnabled: enabledSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol
	"Answer a new balloon help with the given contents for aMorph
	at a given corner."

	^self theme
		newBalloonHelpIn: self
		contents: aTextStringOrMorph
		for: aMorph
		corner: cornerSymbol! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newLabelGroup: labelsAndControls font: aFont labelColor: aColor
	"Answer a morph laid out with a column of labels and a column of associated controls.
	Controls having a vResizing value of #spaceFill will
	cause their row to use #spaceFill also, otherwise #shrinkWrap."

	^self theme
		newLabelGroupIn: self
		for: labelsAndControls
		font: aFont
		labelColor: aColor! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseForSaveFileReference: title extensions: exts path: path
	"Answer the result of a file name chooser dialog with the given title, extensions
	to show, path and preview type."

	^self
		chooseForSaveFileReference: title
		extensions: exts
		path: path
		preview: nil! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newPluggableDialogWindow
	"Answer a new pluggable dialog."

	^self
		newPluggableDialogWindow: 'Dialog'! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newExpander: aString for: aControl
	"Answer an expander with the given label and control."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: {aControl}! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newExpander: aString
	"Answer an expander with the given label."

	^self theme
		newExpanderIn: self
		label: aString
		forAll: #()! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseExistingFileReference: 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
		chooseExistingFileReferenceIn: self
		title: title
		extensions: exts
		path: path
		preview: preview! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self theme
		newRadioButtonIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		font: aFont
		help: helpText! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
question: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionIn: self
		text: aStringOrText
		title: aString! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^self theme
		newListIn: self
		for: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newCloseButtonFor: aModel
	"Answer a new close button."

	^self theme
		newCloseButtonIn: self
		for: aModel! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newFuzzyLabel: aString
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: nil
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: nil! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newRow
	"Answer a morph laid out as a row."

	^self theme
		newRowIn: self
		for: #()! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
abort: aStringOrText title: aString
	"Open an error dialog."

	^self theme
		abortIn: self
		text: aStringOrText
		title: aString! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
alert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		alertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		font: aFont
		help: helpText
		entryCompletion: anEntryCompletion! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newNoButtonFor: aModel
	"Answer a new No button."

	^self theme
		newNoButtonIn: self
		for: aModel! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newOverflowRowForAll: aCollectionOfMorphs
	"Answer a new overflow row morph that provides a drop down for
	the given contents that are unable to fit the bounds."
	
	^self theme
		newOverflowRowIn: self
		forAll: aCollectionOfMorphs! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a morph list for the given model."

	^self theme
		newMorphListIn: self
		for: aModel
		list: listSelector
		getSelected: getSelector
		setSelected: setSelector
		getEnabled: enabledSel
		help: helpText! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseDropList: aStringOrText title: aString list: aList
	"Open a drop list chooser dialog."

	^self theme
		chooseDropListIn: self
		text: aStringOrText
		title: aString
		list: aList! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		label: aString
		getEnabled: enabledSel! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newYesButton
	"Answer a new Yes button."

	^self newYesButtonFor: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newHSVSelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVSelectorIn: self
		color: aColor
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: nil
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		getLabel: labelSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newPanel
	"Answer a new panel."

	^self theme
		newPanelIn: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newGroupbox: aString forAll: controls
	"Answer a groupbox with the given label and controls."

	^self theme
		newGroupboxIn: self
		label: aString
		forAll: controls! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
proceed: aStringOrText
	"Open a proceed dialog."

	^self proceed: aStringOrText title: 'Proceed' translated! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a drop list for the given model."

	^self theme
		newDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newToolbarHandle
	"Answer a toolbar handle."

	^self theme
		newToolbarHandleIn: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newLabel: aString
	"Answer a new text label."

	^self
		newLabelFor: nil
		label: aString
		getEnabled: nil! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
longMessage: aStringOrText title: aString
	"Open a (long) message dialog."

	^self theme
		longMessageIn: self
		text: aStringOrText
		title: aString! !

!TEasilyThemed methodsFor: 'theme' stamp: ''!
theme
	"Answer the ui theme that provides controls."

	^ Smalltalk ui theme! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
centeredAlert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	Configure the dialog with the 1 argument block
	before opening modally."

	^self theme
		centeredAlertIn: self
		text: aStringOrText
		title: aString
		configure: aBlock! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newToolDockingBar
	"Answer a tool docking bar."

	^self theme
		newToolDockingBarIn: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		label: stringOrText
		help: helpText! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseColor: aColor title: title
	"Answer the result of a color selector dialog with the given title and initial colour."

	^self theme
		chooseColorIn: self
		title: title
		color: aColor! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newMultistateButton
	"Answer a new multistate button morph.
	To be usable it needs to have fill styles assigned to various states along
	with mouse-up/down actions."
	
	^self theme
		newMultistateButtonIn: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newOKButton
	"Answer a new OK button."

	^self newOKButtonFor: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newHueSelector: aModel getHue: getSel setHue: setSel help: helpText
	"Answer a hue selector with the given selectors."

	^self theme
		newHueSelectorIn: self
		for: aModel
		getHue: getSel
		setHue: setSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel
	"Answer a new text label."

	^self theme
		newLabelIn: self
		for: aModel
		getLabel: labelSel
		getEnabled: enabledSel! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a morph drop list for the given model."

	^self theme
		newMorphDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: String
		getEnabled: enabledSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newGroupbox
	"Answer a plain groupbox."

	^self theme
		newGroupboxIn: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newEmbeddedMenu
	"Answer a new menu."

	^self theme
		newEmbeddedMenuIn: self
		for: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newHSVASelector: aColor help: helpText
	"Answer a hue-saturation-volume selector with the given color."

	^self theme
		newHSVASelectorIn: self
		color: aColor
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 
	"Answer a text editor for the given model."

	^self 
		newTextEditorFor: aModel
		getText: getSel
		setText: setSel
		getEnabled: enabledSel
		menu: nil! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newGroupboxFor: control
	"Answer a plain groupbox with the given control."

	^self theme
		newGroupboxIn: self
		for: control! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newDialogPanel
	"Answer a new main dialog panel."

	^self theme
		newDialogPanelIn: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newImageFor: aModel get: getSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newImageIn: self
		for: aModel
		get: getSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newGroupbox: aString for: control
	"Answer a groupbox with the given label and control."

	^self theme
		newGroupboxIn: self
		label: aString
		for: control! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newMenuFor: aModel
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: aModel! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newString: aStringOrText font: aFont style: aStyle
	"Answer a new embossed string."

	^self theme
		newStringIn: self
		label: aStringOrText
		font: aFont
		style: aStyle! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	^self theme
		newTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel 
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newMenu
	"Answer a new menu."

	^self theme
		newMenuIn: self
		for: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText
	"Answer an alpha channel selector with the given selectors."

	^self theme
		newAlphaSelectorIn: self
		for: aModel
		getAlpha: getSel
		setAlpha: setSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	^self theme
		newAutoAcceptTextEntryIn: self
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		font: aFont
		help: helpText
		entryCompletion: anEntryCompletion! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText
	"Answer a color chooser with the given selectors."

	^self theme
		newColorChooserIn: self
		for: aModel
		getColor: getSel
		setColor: setSel
		getEnabled: enabledSel
		help: helpText! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
deny: aStringOrText
	"Open a denial dialog."

	^self deny: aStringOrText title: 'Access Denied' translated! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel
	"Answer a new fuzzy label."

	^self theme
		newFuzzyLabelIn: self
		for: aModel
		label: aString
		offset: 1
		alpha: 0.5
		getEnabled: enabledSel! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
questionWithoutCancel: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	false if no and nil if cancelled."

	^self theme
		questionWithoutCancelIn: self
		text: aStringOrText
		title: aString! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
textEntry: aStringOrText title: aString
	"Open a text entry dialog."

	^self
		textEntry: aStringOrText
		title: aString
		entryText: ''! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox with the given label."

	^self theme
		newCheckboxIn: self
		for: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newText: aStringOrText
	"Answer a new text."

	^self theme
		newTextIn: self
		text: aStringOrText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText
	"Answer a checkbox (radio button appearance) with the given label."

	^self
		newRadioButtonFor: aModel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		label: stringOrText
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText
	"Answer a drop list for the given model."

	^self
		newDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		useIndex: true
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newRow: controls
	"Answer a morph laid out with a row of controls."

	^self theme
		newRowIn: self
		for: controls! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a new button."

	^self theme
		newButtonIn: self for: aModel
		getState: stateSel
		action: actionSel
		arguments: args
		getEnabled: enabledSel 
		getLabel: labelSel
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newColumn: controls
	"Answer a morph laid out with a column of controls."

	^self theme
		newColumnIn: self
		for: controls! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newSliderFor: aModel getValue: getSel setValue: setSel help: helpText
	"Answer a slider with the given selectors."

	^self theme
		newSliderIn: self
		for: aModel
		getValue: getSel
		setValue: setSel
		min: 0
		max: 1
		quantum: nil
		getEnabled: nil
		help: helpText! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
chooseDirectory: title path: path
	"Answer the result of a file dialog with the given title, answer a directory."

	^self theme
		chooseDirectoryIn: self
		title: title
		path: path! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
alert: aStringOrText
	"Open an alert dialog."

	^self alert: aStringOrText title: 'Alert' translated! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
proceed: aStringOrText title: aString
	"Open a proceed dialog and answer true if not cancelled, false otherwise."

	^self theme
		proceedIn: self
		text: aStringOrText
		title: aString! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newCloseControlFor: aModel action: aValuable help: helpText
	"Answer a new cancel button."

	^self theme
		newCloseControlIn: self
		for: aModel
		action: aValuable
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newButtonFor: aModel action: actionSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: nil 
		label: stringOrText
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText
	"Answer a new button."

	^self
		newButtonFor: aModel
		getState: nil
		action: actionSel
		arguments: nil
		getEnabled: enabledSel 
		label: stringOrText
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newCloseButton
	"Answer a new close button."

	^self newCloseButtonFor: self! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newImage: aForm size: aPoint
	"Answer a new image."

	^self theme
		newImageIn: self
		form: aForm
		size: aPoint! !

!TEasilyThemed methodsFor: 'services' stamp: ''!
abort: aStringOrText
	"Open an error dialog."

	^self abort: aStringOrText title: 'Error' translated! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText
	"Answer a morph drop list for the given model."

	^self 
		newMorphDropListFor: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: nil
		useIndex: true
		help: helpText! !

!TEasilyThemed methodsFor: 'controls' stamp: ''!
newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a drop list for the given model."

	^self theme
		newDropListIn: self
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: useIndex
		help: helpText! !

!TEasilyThemed classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TEasilyThemed classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TEasilyThemed classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TEasilyThemed classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TEasilyThemed classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TEasilyThemed classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TEasilyThemed classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TEasilyThemed classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TEasilyThemed classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TEasilyThemed classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TEasilyThemed classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TEasilyThemed classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TEasilyThemed classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TEasilyThemed classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TEasilyThemed classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TEasilyThemed classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TEasilyThemed classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TEasilyThemed classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TEasilyThemed classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TEasilyThemed classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TEasilyThemed classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TEasilyThemed classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TEasilyThemed classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TEasilyThemed classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TEasilyThemed classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TEasilyThemed classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TEmpty commentStamp: ''!
I'm a really empty trait.
I'm used for trait template creation.

```
Trait << #TMyTrait
	trait: TEmpty;
	slots: {};
	tag: '' ;
	package: 'TraitsV2'
```
!
!TEmpty classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TEmpty classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TEmpty classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TEmpty classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TEmpty classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TEmpty classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TEmpty classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TEmpty classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TEmpty classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TEmpty classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TEmpty classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TEmpty classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TEmpty classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TEmpty classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TEmpty classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TEmpty classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TEmpty classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TEmpty classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TEmpty classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TEmpty classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TEmpty classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TEmpty classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TEmpty classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TEmpty classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TEmpty classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TEmptySequenceableTest commentStamp: ''!
A trait for test purposes!
!TEmptySequenceableTest methodsFor: 'parameters' stamp: ''!
accessValuePutIn
	"return access the element put in the non-empty collection"
	
	^ self perform: self selectorToAccessValuePutIn! !

!TEmptySequenceableTest methodsFor: 'parameters' stamp: ''!
valuePutIn
	"the value that we will put in the non empty collection"
	
	^ #x! !

!TEmptySequenceableTest methodsFor: 'requirements' stamp: ''!
empty
	
	^ self explicitRequirement! !

!TEmptySequenceableTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	
	^ self explicitRequirement! !

!TEmptySequenceableTest methodsFor: 'tests - sequence isempty' stamp: ''!
testSequenceIfNotEmptyifEmpty

	self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! !

!TEmptySequenceableTest methodsFor: 'parameters' stamp: ''!
accessValuePutInOn: s

	"return access the element put in the non-empty collection"
	
	^ s perform: self selectorToAccessValuePutIn! !

!TEmptySequenceableTest methodsFor: 'tests - sequence isempty' stamp: ''!
testSequenceIfNotEmpty

	self assert: (self nonEmpty 
					ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! !

!TEmptySequenceableTest methodsFor: 'requirements' stamp: ''!
selectorToAccessValuePutIn
	"return the selector of the method that should be invoked to access an element"
	
	^ self explicitRequirement! !

!TEmptySequenceableTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureEmptySequenceableTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TEmptySequenceableTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TEmptySequenceableTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TEmptySequenceableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TEmptySequenceableTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TEmptySequenceableTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TEmptySequenceableTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TEmptySequenceableTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TEmptySequenceableTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TEmptySequenceableTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TEmptySequenceableTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TEmptySequenceableTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TEmptySequenceableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TEmptySequenceableTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TEmptySequenceableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TEmptySequenceableTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TEmptySequenceableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TEmptyTest commentStamp: ''!
I group a set of tests testing whether a collection is empty.
I do not do any assymption on the elements being added since it would
bind me to know how to access it. 
!
!TEmptyTest methodsFor: 'tests - empty' stamp: ''!
testIfEmptyifNotEmpty
	self assert: (self empty ifEmpty: [ true ] ifNotEmpty: [ false ]).
	self assert: (self nonEmpty ifEmpty: [ false ] ifNotEmpty: [ true ])! !

!TEmptyTest methodsFor: 'tests - empty' stamp: ''!
testNotEmpty
	self assert: self nonEmpty notEmpty.
	self deny: self empty notEmpty! !

!TEmptyTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureEmptyTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self empty.
	self assertEmpty: self empty! !

!TEmptyTest methodsFor: 'tests - empty' stamp: ''!
testIfNotEmptyifEmpty
	self assert: (self empty ifNotEmpty: [ false ] ifEmpty: [ true ]).
	self assert: (self nonEmpty ifNotEmpty: [ true ] ifEmpty: [ false ])! !

!TEmptyTest methodsFor: 'requirements' stamp: ''!
empty
	
	^ self explicitRequirement! !

!TEmptyTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	
	^ self explicitRequirement! !

!TEmptyTest methodsFor: 'tests - empty' stamp: ''!
testIfNotEmpty
	self empty ifNotEmpty: [ self assert: false ].
	self nonEmpty ifNotEmpty: [ self assert: true ].
	self assert: (self nonEmpty ifNotEmpty: [ :s | s ]) = self nonEmpty! !

!TEmptyTest methodsFor: 'tests - empty' stamp: ''!
testIsEmptyOrNil
	self assert: self empty isEmptyOrNil.
	self deny: self nonEmpty isEmptyOrNil! !

!TEmptyTest methodsFor: 'tests - empty' stamp: ''!
testIfEmpty
	self nonEmpty ifEmpty: [ self assert: false ].
	self empty ifEmpty: [ self assert: true ]! !

!TEmptyTest methodsFor: 'tests - empty' stamp: ''!
testIsEmpty
	self assert: self empty isEmpty.
	self deny: self nonEmpty isEmpty! !

!TEmptyTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TEmptyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TEmptyTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TEmptyTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TEmptyTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TEmptyTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TEmptyTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TEmptyTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TEmptyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TEmptyTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TEmptyTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TEmptyTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TEmptyTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TEmptyTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TEmptyTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TEmptyTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TEmptyTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TEmptyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TEmptyTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TEmptyTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TEmptyTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TEmptyTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TEmptyTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TEmptyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TEmptyTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TEmptyTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TEnableOnHaloMenu commentStamp: ''!
Trait providing an "enabled" option on the halo menu.!
!TEnableOnHaloMenu methodsFor: 'enablement' stamp: ''!
enabledString
	"Answer the string to be shown in a menu to represent the 'enabled' status"
	
	^ (self enabled) -> 'enabled' translated! !

!TEnableOnHaloMenu methodsFor: 'menu & halo' stamp: ''!
addToggleItemsToHaloMenu: aCustomMenu 
	"Add toggle-items to the halo menu"
	
	super addToggleItemsToHaloMenu: aCustomMenu.
	aCustomMenu
		addUpdating: #enabledString
		target: self
		selector: #toggleEnabled! !

!TEnableOnHaloMenu methodsFor: 'accessing' stamp: ''!
enabled
	"Answer the enabled state of the receiver."

	self explicitRequirement! !

!TEnableOnHaloMenu methodsFor: 'enablement' stamp: ''!
toggleEnabled
	"Toggle the enabled state."

	self enabled: self enabled not! !

!TEnableOnHaloMenu methodsFor: 'accessing' stamp: ''!
enabled: aBoolean
	"Set the enabled state of the receiver."

	self explicitRequirement! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TEnableOnHaloMenu classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TEnableOnHaloMenu classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TEnableOnHaloMenu classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TEnableOnHaloMenu classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TEnableOnHaloMenu classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TEnableOnHaloMenu classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TEnableOnHaloMenu classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TEnableOnHaloMenu classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TEnableOnHaloMenu classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TEnableOnHaloMenu classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TEnableOnHaloMenu classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TEnableOnHaloMenu classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TEnableOnHaloMenu classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TEnableOnHaloMenu classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TEnableOnHaloMenu classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TEnableOnHaloMenu classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TEnumeratingTest commentStamp: ''!
Test of basic functions in Collections that are in the protocol enumerating
!
!TEnumeratingTest methodsFor: 'requirements' stamp: ''!
collectionOfCollectionsOfStrings
	^self explicitRequirement.! !

!TEnumeratingTest methodsFor: 'requirements' stamp: ''!
simpleCollection
	^self explicitRequirement.! !

!TEnumeratingTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollect

	self assert: (self simpleCollection flatCollect: [ :x | { x } ]) equals: self simpleCollection.
	self assert: (self simpleCollection flatCollect: [ :x | { x } ]) species = self simpleCollection species.
	
	self 
		assert: (self collectionOfCollectionsOfInts flatCollect: [ :x | { x } ]) 
		equals: self collectionOfCollectionsOfInts.
	self 
		assert: (self collectionWithCharacters flatCollect: [ :x | { x } ]) 
		equals: self collectionWithCharacters.
	self 
		assert: (self collectionOfCollectionsOfStrings flatCollect: [ :x | { x } ]) 
		equals: self collectionOfCollectionsOfStrings! !

!TEnumeratingTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollectAs

	self 
		assert: (self simpleCollection flatCollect: [ :x | { x }, { x } ] as: IdentitySet) 
		equals: self simpleCollection asIdentitySet.
	self
		assert: (#(foo bar baz) flatCollect: #yourself as: String)
		equals: 'foobarbaz'.
	self 
		assert: (#(#(1 2) #(4 3)) flatCollect: #yourself as: Array)
		equals: #(1 2 4 3)! !

!TEnumeratingTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollectAsWithEmptyCollection

	self 
		assert: (self empty flatCollect: [ :x | { x }, { x } ] as: IdentitySet) 
		equals: self empty asIdentitySet! !

!TEnumeratingTest methodsFor: 'tests - enumerating' stamp: ''!
testFlatCollectAsSet

	self 
		assert: (self simpleCollection flatCollectAsSet: [ :x | { x }, { x } ]) 
		equals: self simpleCollection asSet! !

!TEnumeratingTest methodsFor: 'tests - enumerating' stamp: ''!
testFlattened

	self assert: self simpleCollection flattened equals: #(1 8 3).
	self assert: self collectionOfCollectionsOfInts flattened equals: #( 1 2 3 4 5 6 ).
	self assert: self collectionWithCharacters flattened equals: #($a $x $d $c $m).
	self assert: self collectionOfCollectionsOfStrings flattened equals: #('foo' 'bar' 'zorg').! !

!TEnumeratingTest methodsFor: 'requirements' stamp: ''!
collectionOfCollectionsOfInts
	^self explicitRequirement.! !

!TEnumeratingTest methodsFor: 'requirements' stamp: ''!
collectionWithCharacters
	^self explicitRequirement.! !

!TEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TEnumeratingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TEnumeratingTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TEnumeratingTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TEnumeratingTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TEnumeratingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TEnumeratingTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TEnumeratingTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TEnumeratingTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TEnumeratingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TEnumeratingTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TEnumeratingTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TEnumeratingTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TEnumeratingTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TFAbiTypes commentStamp: ''!
I represent all possible ABI Types!
!TFAbiTypes class methodsFor: 'class initialization' stamp: ''!
initialize

	"The default ABI is marked with a nil. The primitive will use the correct ABI depending on the platform"
	DEFAULT_ABI := nil.

	WIN_X86_64_WIN64 := 1.
	WIN_X86_64_GNUW64 := 2.

	DARWIN_X86_64_UNIX64 := 2.
	DARWIN_X86_64_WIN64 := 3.
	DARWIN_X86_64_GNUW64 := 4.

	UNIX_X86_64_UNIX64 := 2.
	UNIX_X86_64_WIN64 := 3.
	UNIX_X86_64_GNUW64 := 4.


	WIN_X86_32_SYSV      := 1.
	WIN_X86_32_STDCALL   := 2.
	WIN_X86_32_THISCALL  := 3.
	WIN_X86_32_FASTCALL  := 4.
	WIN_X86_32_MS_CDECL  := 5.
	WIN_X86_32_PASCAL   := 6.
	WIN_X86_32_REGISTER  := 7.

	UNIX_X86_32_SYSV      := 1.
	UNIX_X86_32_THISCALL  := 3.
	UNIX_X86_32_FASTCALL  := 4.
	UNIX_X86_32_STDCALL   := 5.
	UNIX_X86_32_PASCAL    := 6.
	UNIX_X86_32_REGISTER  := 7.
	UNIX_X86_32_MS_CDECL  := 8.
	
! !

!TFAbstractType commentStamp: ''!
I am an abstract class with the common behavior of the TFTypes.
A TFType knows how to marshall / unmarshall in a normal call and in a callback.!
!TFAbstractType methodsFor: 'writing' stamp: ''!
callbackWrite: aNumber into: anExternalAddress

	self write: aNumber into: anExternalAddress! !

!TFAbstractType methodsFor: 'writing' stamp: ''!
write: aNumber into: anExternalAddress

	self subclassResponsibility! !

!TFAbstractType methodsFor: 'reading' stamp: ''!
callbackReadValue: anExternalAddress

	^ self readValue: anExternalAddress offset: 1! !

!TFAbstractType methodsFor: 'reading' stamp: ''!
readReturnValue: anExternalAddress

	^ self subclassResponsibility! !

!TFAbstractType methodsFor: 'size' stamp: ''!
byteSize
	
	^ self subclassResponsibility! !

!TFAbstractType methodsFor: 'private' stamp: ''!
validate
	
	^ self subclassResponsibility! !

!TFAbstractType methodsFor: 'reading' stamp: ''!
readValue: anExternalAddress offset: offset

	^ self subclassResponsibility! !

!TFAbstractType methodsFor: 'accessing' stamp: ''!
isValid 

	^ handle isNull not! !

!TFAbstractType methodsFor: 'reading' stamp: ''!
readValue: anExternalAddress

	^ self readValue: anExternalAddress offset: 1! !

!TFBasicType commentStamp: ''!
I am an abstract class representing a type in the C world.
I have a name and a code that corresponds to a type code in libffi.
From this information I:
 - calculate my size in memory for the current platform
 - provide marshalling from/to Pharo objets to their corresponding C representation.

My class side contains a set of accessors for well known types that are cached in class side variables.

!!!! Public API

- #byteSize
  returns the size in bytes
- #readValue: anExternalAddress
  reads a value of my type from an external address containing a pointer
- #readValue: anExternalAddress offset: anOffset
  reads a value of my type from an external address containing a pointer but starting reading at the given offset. Offsets are Pharo-like, 1-based
- #write: aValue into: anExternalAddress
  writes a value of my corresponding type into an external address
- #isVoid
  returns true if it is a void type
- #isValid
  returns true if the type is initialized

!!!! Implementation Details

At my first usage in a session, any of my instances will use this information to ask the ThreadedFFI plugin for the correct representation in the current platform.

See #validate and #primFillType.

My subclasses should redefine #readValue:offset: to provide correct type marshalling from C values to Pharo values!
!TFBasicType methodsFor: 'primitives' stamp: ''!
primitiveByteSize
	<primitive: 'primitiveTypeByteSize'>

	^ self primitiveFailed	! !

!TFBasicType methodsFor: 'marshalling' stamp: ''!
emitMarshallFromPrimitive: aBuilder

	! !

!TFBasicType methodsFor: 'marshalling' stamp: ''!
emitMarshallToPrimitive: builder
	
	"Nothing to do in this case"! !

!TFBasicType methodsFor: 'marshalling' stamp: ''!
emitFreeIfNeededOfIndex: argIndex argumentsArrayTempName: argumentsArrayTempName withBuilder: anIRBuilder 	! !

!TFBasicType methodsFor: 'accessing' stamp: ''!
isVoid

	^ typeName = #void! !

!TFBasicType methodsFor: 'marshalling' stamp: ''!
marshallFromPrimitive: aValue
	
	^ aValue
	! !

!TFBasicType methodsFor: 'reading' stamp: ''!
readReturnValue: anExternalAddress

	^ self readValue: anExternalAddress! !

!TFBasicType methodsFor: 'accessing' stamp: ''!
typeCode: anObject
	typeCode := anObject! !

!TFBasicType methodsFor: 'primitives' stamp: ''!
primFillType
	<primitive: 'primitiveFillBasicType'>

	^ self primitiveFailed	! !

!TFBasicType methodsFor: 'accessing' stamp: ''!
typeName: anObject
	typeName := anObject! !

!TFBasicType methodsFor: 'size' stamp: ''!
byteSize
	
	self validate.
	^ byteSize ifNil: [ self primitiveByteSize ]! !

!TFBasicType methodsFor: 'validating' stamp: ''!
validate 
	
	self isValid ifTrue: [ ^ self ].
	self primFillType.
	byteSize := self primitiveByteSize! !

!TFBasicType methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream 
		nextPut: $[;
		print: typeName;
		space;
		print: typeCode;
		nextPut: $]! !

!TFBasicType methodsFor: 'accessing' stamp: ''!
typeCode
	^ typeCode! !

!TFBasicType methodsFor: 'accessing' stamp: ''!
typeName
	^ typeName! !

!TFBasicType methodsFor: 'marshalling' stamp: ''!
marshallToPrimitive: aValue
	
	^ aValue
	! !

!TFBasicType methodsFor: 'writing' stamp: ''!
freeValueIfNeeded: aValue 
	
	"Do nothing. Basic types do not need to be free'd"! !

!TFBasicType methodsFor: 'accessing' stamp: ''!
basicType
	
	^ self! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
slong
	^SLONG! !

!TFBasicType class methodsFor: 'instance creation' stamp: ''!
createBasicTypes

	^ { 	
			"Platform independent types"
			VOID := self newTypeName: #void code: 1.
		 	FLOAT := self newFloatTypeName: #float code: 2.
		 	DOUBLE := self newDoubleName: #double code: 3.

			UINT8 := self newIntTypeName: #uint8 code: 4 signed: false.
			UINT16 := self newIntTypeName: #uint16 code: 5 signed: false.
			UINT32 := self newIntTypeName: #uint32 code: 6 signed: false.
			UINT64 := self newIntTypeName: #uint64 code: 7 signed: false.
			
			SINT8 := self newIntTypeName: #sint8 code: 8 signed: true.
			SINT16 := self newIntTypeName: #sint16 code: 9 signed: true.
			SINT32 := self newIntTypeName: #sint32 code: 10 signed: true.
			SINT64 := self newIntTypeName: #sint64 code: 11 signed: true.

			"Aliased types, these depends of the architecture"
			POINTER := self newPointerTypeName: #pointer code: 12.

			UCHAR := self newCharTypeName: #uchar code: 13 signed: false.
			SCHAR := self newCharTypeName: #schar code: 14 signed: true.
			
			USHORT := self newIntTypeName: #ushort code: 15 signed: false.
			SSHORT := self newIntTypeName: #sshort code: 16 signed: true.

			UINT := self newIntTypeName: #uint code: 17 signed: false.
			SINT := self newIntTypeName: #sint code: 18 signed: true.

			ULONG := self newIntTypeName: #ulong code: 19 signed: false.
			SLONG := self newIntTypeName: #slong code: 20 signed: true.	
			}! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
types 
	^ Types! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
uint32 
	^ UINT32! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
float 
	^ FLOAT! !

!TFBasicType class methodsFor: 'instance creation' stamp: ''!
newDoubleName: aName code: aCode

	^ TFDoubleType new 
		typeName: aName;
		typeCode: aCode;
		yourself! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
uint16 
	^ UINT16! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
uint
	^UINT! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
typemap 
	^ TypeMap! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
ushort
	^USHORT! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
void 
	^ VOID! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
double 
	^ DOUBLE! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
sizeT

	^ Smalltalk wordSize = 8
		ifTrue: [ self uint64 ]
		ifFalse: [ self uint32 ]! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
sint
	^SINT! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
sint32 
	^ SINT32! !

!TFBasicType class methodsFor: 'instance creation' stamp: ''!
newTypeName: aName code: aCode
	
	^ self new 
		typeName: aName;
		typeCode: aCode;
		yourself! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
sint16 
	^ SINT16! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
uchar
	^UCHAR! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
uint64 
	^ UINT64! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
ulong
	^ULONG! !

!TFBasicType class methodsFor: 'class initialization' stamp: ''!
initialize 	
	
	Types := self createBasicTypes.
	TypeMap := (Types collect: [ :t | t typeName -> t ]) asDictionary.! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
uint8 
	^ UINT8! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
sint8 
	^ SINT8! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
sint64 
	^ SINT64! !

!TFBasicType class methodsFor: 'instance creation' stamp: ''!
newIntTypeName: aName code: aCode signed: signed
	
	^ TFIntType new 
		typeName: aName;
		typeCode: aCode;
		signed: signed;
		yourself! !

!TFBasicType class methodsFor: 'instance creation' stamp: ''!
newPointerTypeName: aName code: aCode

	^ TFPointerType new 
		typeName: aName;
		typeCode: aCode;
		yourself! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
pointer 
	^ POINTER! !

!TFBasicType class methodsFor: 'instance creation' stamp: ''!
newCharTypeName: aName code: aCode signed: signed
	
	^ TFCharType new 
		typeName: aName;
		typeCode: aCode;
		signed: signed;
		yourself! !

!TFBasicType class methodsFor: 'instance creation' stamp: ''!
newFloatTypeName: aName code: aCode

	^ TFFloatType new 
		typeName: aName;
		typeCode: aCode;
		yourself! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
sshort
	^SSHORT! !

!TFBasicType class methodsFor: 'accessing' stamp: ''!
schar
	^SCHAR! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testFloat

	| received |
	received := self call: 'float' type: TFBasicType float value: 2.7.
	self assert: (received between: 2.6999 and: 2.7001)! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedInt

	self assertSignedIntType: TFBasicType sint named: 'int'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
call: typeName type: type value: aValue

	| callback fun received |

	callback := TFCallback 
		forCallback: [ :a | received := a. ] 
		parameters: { type } 
		returnType: TFBasicType void
		runner: runner.

	fun := TFExternalFunction
		name: 'simple_callback_f_', typeName
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: { TFBasicType pointer. type }
			returnType: TFBasicType void).

	runner invokeFunction: fun withArguments: { callback getHandle . aValue}.
	^ received! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedLong

	self assertSignedIntType: TFBasicType slong named: 'long'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedShort

	self assertSignedIntType: TFBasicType sshort named: 'short'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
assertIntType: aType named: name value: aValue

	| callbackGotValue |
	callbackGotValue := self call: name type: aType value: aValue.
	self assert: callbackGotValue equals: aValue.! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedInt64

	self assertSignedIntType: TFBasicType sint64 named: 'int64_t'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedInt16

	self assertUnsignedIntType: TFBasicType uint16 named: 'uint16_t'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedLong

	self assertUnsignedIntType: TFBasicType ulong named: 'ulong'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
assertCharType: aType named: name

	| callbackGotValue |
	callbackGotValue := self call: name type: aType value: $A asInteger.
	self assert: callbackGotValue equals: $A.! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedInt32

	self assertUnsignedIntType: TFBasicType uint32 named: 'uint32_t'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testPointer

	| bytes received |
	[
	bytes := ExternalAddress allocate: 2 "bytes".
	received := self call: 'pointer' type: TFBasicType pointer value: bytes.
	self assert: received getHandle equals: bytes getHandle
	] ensure: [ bytes free ]! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedInt8

	self assertUnsignedIntType: TFBasicType uint8 named: 'uint8_t'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedInt16

	self assertSignedIntType: TFBasicType sint16 named: 'int16_t'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedInt32

	self assertSignedIntType: TFBasicType sint32 named: 'int32_t'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testChar

	self assertCharType: TFBasicType schar named: 'char'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedInt8

	self assertSignedIntType: TFBasicType sint8 named: 'int8_t'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testDouble

	| received |
	received := self call: 'double' type: TFBasicType double value: 2.7.
	self assert: received equals: 2.7! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedInt

	self assertUnsignedIntType: TFBasicType uint named: 'uint'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedShort

	self assertUnsignedIntType: TFBasicType ushort named: 'ushort'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
assertUnsignedIntType: aType named: name

	self assertIntType: aType named: name value: 65! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedInt64

	self assertUnsignedIntType: TFBasicType uint64 named: 'uint64_t'! !

!TFBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
assertSignedIntType: aType named: name

	self assertIntType: aType named: name value: -65! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedInt64

	| function |
	function := self externalFunction: 'sum_int64_t' ofType: TFBasicType sint64.
	self assertSignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedInt8

	| function |
	function := self externalFunction: 'sum_int8_t' ofType: TFBasicType sint8.
	self assertSignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedInt16

	| function |
	function := self externalFunction: 'sum_uint16_t' ofType: TFBasicType uint16.
	self assertUnsignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedLong

	| function |
	function := self externalFunction: 'sum_long' ofType: TFBasicType slong.
	self assertSignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testUnrefPointer

	| function holder pointerToHolder return |
	function := TFExternalFunction
		name: 'unref_pointer'
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: {TFBasicType pointer}
			returnType: TFBasicType pointer).
	
	holder := ExternalAddress allocate: TFBasicType sshort byteSize.
	TFBasicType sshort write: 17 into: holder.
	
	pointerToHolder := ExternalAddress allocate: TFBasicType pointer byteSize.
	TFBasicType pointer write: holder into: pointerToHolder.
	
	return := runner invokeFunction: function withArguments: { pointerToHolder }.
	self assert: return equals: holder.
	self assert: (TFBasicType sshort readValue: return) equals: 17.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedChar

	| function |
	function := self externalFunction: 'sum_char' ofType: TFBasicType schar.
	self assertSignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedInt32

	| function |
	function := self externalFunction: 'sum_int32_t' ofType: TFBasicType sint32.
	self assertSignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumCharEnum

	| function |
	function := self externalFunction: 'sum_charenum' ofType: TFBasicType sint.
	self assertUnsignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedInt16

	| function |
	function := self externalFunction: 'sum_int16_t' ofType: TFBasicType sint16.
	self assertSignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedInt8

	| function |
	function := self externalFunction: 'sum_uint8_t' ofType: TFBasicType uint8.
	self assertUnsignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedShort

	| function |
	function := self externalFunction: 'sum_ushort' ofType: TFBasicType ushort.
	self assertUnsignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumFloat

	| function return |
	function := self externalFunction: 'sum_float' ofType: TFBasicType float.
				
	return := runner invokeFunction: function withArguments: { 3.1 . 2.7 }.
	self assert: (return between: 5.79999999 and: 5.80001)! !

!TFBasicTypeMarshallingTest methodsFor: 'accessing' stamp: ''!
externalFunction: name ofType: type

	^ TFExternalFunction
		name: name
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: {type. type}
			returnType: type)
! !

!TFBasicTypeMarshallingTest methodsFor: 'accessing' stamp: ''!
assertUnsignedIntsWithFunction: function

	| return |
	return := runner invokeFunction: function withArguments: { 3 . 2 }.
	self assert: return equals: 5! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedChar

	| function |
	function := self externalFunction: 'sum_uchar' ofType: TFBasicType uchar.
	self assertUnsignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'accessing' stamp: ''!
assertSignedIntsWithFunction: function

	| return |
	return := runner invokeFunction: function withArguments: { -3 . 2 }.
	self assert: return equals: -1! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedLong

	| function |
	function := self externalFunction: 'sum_ulong' ofType: TFBasicType ulong.
	self assertUnsignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedIntEnum

	| function |
	function := self externalFunction: 'sum_sintenum' ofType: TFBasicType sint.
	self assertSignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedInt

	| function |
	function := self externalFunction: 'sum_int' ofType: TFBasicType sint.
	self assertSignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedInt32

	| function |
	function := self externalFunction: 'sum_uint32_t' ofType: TFBasicType uint32.
	self assertUnsignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedInt64

	| function |
	function := self externalFunction: 'sum_uint64_t' ofType: TFBasicType uint64.
	self assertUnsignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedShort

	| function |
	function := self externalFunction: 'sum_short' ofType: TFBasicType sshort.
	self assertSignedIntsWithFunction: function.! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumDouble

	| function return |
	function := self externalFunction: 'sum_double' ofType: TFBasicType double.
				
	return := runner invokeFunction: function withArguments: { 3.1 . 2.7 }.
	self assert: (return between: 5.79999999 and: 5.80001)! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedInt

	| function |
	function := self externalFunction: 'sum_uint' ofType: TFBasicType uint.
	self assertUnsignedIntsWithFunction: function! !

!TFBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedIntEnum

	| function |
	function := self externalFunction: 'sum_uintenum' ofType: TFBasicType sint.
	self assertUnsignedIntsWithFunction: function.! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedInt16

	self assertType: 'int16_t' equals: 2! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeUnsignedLongLong

	self assertType: 'ulonglong' equals: 8! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizePointer

	self assertType: 'pointer' equals: Smalltalk wordSize! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeUnsignedShort

	self assertType: 'ushort' equals: 2! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeUnsignedLongUnix

	OSPlatform current isWindows ifTrue: [ 
		"Check #testSizeUnsignedLongWindows"
		^ self skip ].
	self assertType: 'ulong' equals: Smalltalk wordSize! !

!TFBasicTypeSizeTest methodsFor: 'accessing' stamp: ''!
externalFunction: name

	^ TFExternalFunction
		name: name
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: {}
			returnType: TFBasicType sizeT)
! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeUnsignedInt16

	self assertType: 'uint16_t' equals: 2! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedInt8

	self assertType: 'int8_t' equals: 1! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedShort

	self assertType: 'short' equals: 2! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeUnsignedInt8

	self assertType: 'uint8_t' equals: 1! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeUnsignedIntEnum

	self assertType: 'uintenum' equals: 4.! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedLongUnix

	OSPlatform current isWindows ifTrue: [ 
		"Check #testSizeSignedLongWindows"
		^ self skip ].
	self assertType: 'long' equals: Smalltalk wordSize! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeUnsignedInt

	self assertType: 'uint' equals: 4.! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedLongWindows

	OSPlatform current isWindows ifFalse: [ 
		"Check #testSizeSignedLongUnix"
		^ self skip ].
	self assertType: 'long' equals: 4! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedIntEnum

	self assertType: 'sintenum' equals: 4.! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedInt

	self assertType: 'int' equals: 4.! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeUnsignedLongWindows

	OSPlatform current isWindows ifFalse: [ 
		"Check #testSizeUnsignedLongUnix"
		^ self skip ].
	self assertType: 'ulong' equals: 4! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedInt32

	self assertType: 'int32_t' equals: 4! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeFloat

	self assertType: 'float' equals: 4.! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeLongLong

	self assertType: 'longlong' equals: 8! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedInt64

	self assertType: 'int64_t' equals: 8! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedChar

	self assertType: 'char' equals: 1.! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeUnsignedInt64

	self assertType: 'uint64_t' equals: 8! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeDouble

	self assertType: 'double' equals: 8.! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeCharEnum

	self assertType: 'charenum' equals: 4.! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeSignedLongLong

	self assertType: 'longlong' equals: 8! !

!TFBasicTypeSizeTest methodsFor: 'accessing' stamp: ''!
assertType: typename equals: aSize

	| function |
	function := self externalFunction: 'sizeof_', typename.
	self assert: (runner invokeFunction: function) equals: aSize! !

!TFBasicTypeSizeTest methodsFor: 'tests' stamp: ''!
testSizeUnsignedChar

	self assertType: 'uchar' equals: 1.! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testPointerSize

	self assert: TFBasicType pointer byteSize equals: Smalltalk wordSize ! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testIntSize

	self assert: TFBasicType uint byteSize equals: 4 ! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testWriteFloat

	| aByteArray |

	aByteArray := ByteArray new: 4.
	TFBasicType float write: 1.5 into: aByteArray.
	
	self assert: (aByteArray floatAt: 1) equals: 1.5. 
	self assert: (TFBasicType float readValue: aByteArray) equals: 1.5.! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testWriteSINT32

	| aByteArray |

	aByteArray := ByteArray new: 4.
	TFBasicType sint32 write: -42 into: aByteArray.
	
	self assert: (aByteArray integerAt: 1 size: 4 signed: true) equals: -42. 
	self assert: (TFBasicType sint32 readValue: aByteArray) equals: -42.! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testWriteUINT32

	| aByteArray |

	aByteArray := ByteArray new: 4.
	TFBasicType uint32 write: 42 into: aByteArray.
	
	self assert: (aByteArray integerAt: 1 size: 4 signed: false) equals: 42. 
	self assert: (TFBasicType uint32 readValue: aByteArray) equals: 42.! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testWriteDouble

	| aByteArray |

	aByteArray := ByteArray new: 8.
	TFBasicType double write: 1.5 into: aByteArray.
	
	self assert: (aByteArray doubleAt: 1) equals: 1.5. 
	self assert: (TFBasicType double readValue: aByteArray) equals: 1.5.! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testUnsignedLongWindows

	OSPlatform current isWindows ifFalse: [ 
		"Check #testUnsignedLongUnix"
		^ self skip ].
	self assert: TFBasicType ulong byteSize equals: 4! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testSInt32Size

	self assert: TFBasicType sint32 byteSize equals: 4! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testSIntSize

	self assert: TFBasicType sint byteSize equals: 4 ! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testUnsignedLongUnix

	OSPlatform current isWindows ifTrue: [ 
		"Check #testUnsignedLongWindows"
		^ self skip ].
	self assert: TFBasicType ulong byteSize equals: Smalltalk wordSize! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testSignedLongUnix

	OSPlatform current isWindows ifTrue: [ 
		"Check #testSignedLongWindows"
		^ self skip ].
	self assert: TFBasicType slong byteSize equals: Smalltalk wordSize! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testSignedLongWindows

	OSPlatform current isWindows ifFalse: [ 
		"Check #testSignedLongUnix"
		^ self skip ].
	self assert: TFBasicType slong byteSize equals: 4! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testCharSize

	self assert: TFBasicType uchar byteSize equals: 1! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testUInt32Size

	self assert: TFBasicType uint32 byteSize equals: 4! !

!TFBasicTypeTest methodsFor: 'tests' stamp: ''!
testBasicTypesAreValid

	TFBasicType types do: #validate.
	self assert: (TFBasicType types allSatisfy: #isValid)! !

!TFBoolean32Type commentStamp: ''!
I define the TFFI type for FFIBoolean32!
!TFBoolean32Type methodsFor: 'accessing' stamp: ''!
basicType
	
	^ TFBasicType uint32! !

!TFBooleanType commentStamp: ''!
I know how to handle the booleans when stored in a int8!
!TFBooleanType methodsFor: 'reading-writing' stamp: ''!
write: aBoolean into: aCollection 
	
	self basicType 
		write: aBoolean asBit 
		into: aCollection! !

!TFBooleanType methodsFor: 'reading-writing' stamp: ''!
callbackReadValue: anExternalAddress

	^ (self readValue: anExternalAddress) ~= 0! !

!TFBooleanType methodsFor: 'marshalling' stamp: ''!
emitMarshallFromPrimitive: anIRBuilder 
	
	anIRBuilder pushLiteral: 0.
	anIRBuilder send: #~=.! !

!TFBooleanType methodsFor: 'marshalling' stamp: ''!
emitMarshallToPrimitive: builder 
		
	builder pushLiteral: true.
	builder send: #==.
	builder jumpAheadTo: #falseLabel if: false.
	builder pushLiteral: 1.
	builder jumpAheadTo: #endLabel.	
	builder jumpAheadTarget: #falseLabel.
	builder pushLiteral: 0.
	builder jumpAheadTarget: #endLabel.
! !

!TFBooleanType methodsFor: 'accessing' stamp: ''!
basicType
	
	^ TFBasicType uint8! !

!TFBooleanType methodsFor: 'reading-writing' stamp: ''!
readValue: anExternalAddress
	" Returns 0 or 1, the conversion to false or true is done in the generated method"
	^ self basicType readValue: anExternalAddress! !

!TFCallback commentStamp: ''!
I am the Backend implementation of callbacks for UFFI. I use TFFI as a backend!
!TFCallback methodsFor: 'accessing' stamp: ''!
parameterTypes: anObject
	parameterTypes := anObject! !

!TFCallback methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	success := true.
	callbackData := ExternalAddress new.
	parameterHandlers := #()! !

!TFCallback methodsFor: 'accessing' stamp: ''!
beFailed

	success := false! !

!TFCallback methodsFor: 'accessing' stamp: ''!
beSuccess

	success := true! !

!TFCallback methodsFor: 'accessing' stamp: ''!
runner: anObject
	runner := anObject! !

!TFCallback methodsFor: 'accessing' stamp: ''!
frontendCallback

	^ frontendCallback! !

!TFCallback methodsFor: 'accessing' stamp: ''!
returnType
	^ returnType! !

!TFCallback methodsFor: 'registering' stamp: ''!
registerCallback: debugString

	<primitive: 'primitiveRegisterCallback'>
	^ self primitiveFailed ! !

!TFCallback methodsFor: 'accessing' stamp: ''!
beNull

	self setHandle: ExternalAddress null
! !

!TFCallback methodsFor: 'accessing' stamp: ''!
frontendCallback: anObject
	frontendCallback := anObject! !

!TFCallback methodsFor: 'accessing' stamp: ''!
parameterTypes
	^ parameterTypes! !

!TFCallback methodsFor: 'registering' stamp: ''!
register
	
	handle isNull ifFalse: [ ^ self error: 'Callback already registered' ].
	
	self validateTypes.
	self runner ensureInitialized.
	self registerCallback: frontendCallback tfPrintString.
	TFCallbackQueue uniqueInstance registerCallback: self.! !

!TFCallback methodsFor: 'accessing' stamp: ''!
runStrategy
	^ runStrategy ifNil: [ TFCallbackForkRunStrategy new ]! !

!TFCallback methodsFor: 'accessing' stamp: ''!
runner
	^ runner! !

!TFCallback methodsFor: 'accessing' stamp: ''!
thunk
	^ self getHandle ! !

!TFCallback methodsFor: 'private - operations' stamp: ''!
validateTypes

	parameterTypes do: [ :each | each validate ].
	returnType validate.

	parameterHandlers := parameterTypes collect: [ :e | e basicType ] as: Array.
	returnTypeHandler := returnType basicType.! !

!TFCallback methodsFor: 'accessing' stamp: ''!
callbackData
	^ callbackData! !

!TFCallback methodsFor: 'testing' stamp: ''!
isSuccess

	^ success == true! !

!TFCallback methodsFor: 'registering' stamp: ''!
registerCallback
	"TODO: This is still here to allow updating. We need to remove it soon!!"
	<primitive: 'primitiveRegisterCallback'>
	^ self primitiveFailed ! !

!TFCallback methodsFor: 'accessing' stamp: ''!
resourceData

	^ self callbackData.
! !

!TFCallback methodsFor: 'accessing' stamp: ''!
returnType: anObject
	returnType := anObject! !

!TFCallback methodsFor: 'invoking' stamp: ''!
invokeAsFunctionWithArguments: aCollection 
	
	| definition function preparedArguments |

	definition := TFFunctionDefinition
		parameterTypes: self parameterTypes
		returnType: self returnType.

	function := TFExternalFunction 
		fromAddress: self getHandle 
		definition: definition.

	preparedArguments := aCollection 
		with: self parameterTypes 
		collect: [ :anArgument :aType | aType marshallToPrimitive: anArgument ].

	^ self returnType marshallFromPrimitive: (self runner invokeFunction: function withArguments: preparedArguments)! !

!TFCallback methodsFor: 'accessing' stamp: ''!
runStrategy: anObject
	runStrategy := anObject! !

!TFCallback methodsFor: 'accessing' stamp: ''!
callbackData: anObject
	callbackData := anObject! !

!TFCallback class methodsFor: 'private - primitives' stamp: ''!
primUnregister: callbackHandle
	<primitive: 'primitiveUnregisterCallback'>

	^ self primitiveFailed! !

!TFCallback class methodsFor: 'finalization' stamp: ''!
finalizeResourceData: aCallbackDataHandler

	aCallbackDataHandler isNull ifTrue: [ ^ self ].
	
	self primUnregister: aCallbackDataHandler.
	aCallbackDataHandler beNull! !

!TFCallback class methodsFor: 'instance creation' stamp: ''!
forCallback: aCallback parameters: parameterTypes returnType: returnType runner: aRunner

	^ self new
		frontendCallback: aCallback;
		parameterTypes: parameterTypes;
		returnType: returnType;
		runner: aRunner;
		autoRelease;
		register;
		yourself! !

!TFCallbackCannotReturn commentStamp: ''!
I am an error produced when the callback cannot return correctly.!
!TFCallbackCannotReturn methodsFor: 'accessing' stamp: ''!
callback
	^ self callbackInvocation callback! !

!TFCallbackCannotReturn methodsFor: 'accessing' stamp: ''!
callbackInvocation
	^ callbackInvocation! !

!TFCallbackCannotReturn methodsFor: 'accessing' stamp: ''!
callbackInvocation: anObject
	callbackInvocation := anObject! !

!TFCallbackForkRunStrategy commentStamp: ''!
I am a simple strategy to run the callbacks in a new process every time.!
!TFCallbackForkRunStrategy methodsFor: 'executing' stamp: ''!
executeCallback: aCallbackInvocation on: aTFRunner

	[ aTFRunner handleExceptionDuring: [ aCallbackInvocation execute ] ]
		forkAt: Processor highIOPriority - 1! !

!TFCallbackInvocation commentStamp: ''!
I represent the callback invocation.
I have information about the activation of a given callback.!
!TFCallbackInvocation methodsFor: 'accessing' stamp: ''!
callback 
	
	^ callback! !

!TFCallbackInvocation methodsFor: 'accessing' stamp: ''!
argumentsAddress

	^ TFBasicType pointer 
		readValue: handle 
		offset: 1 + (TFBasicType pointer byteSize * 2)! !

!TFCallbackInvocation methodsFor: 'accessing' stamp: ''!
returnHolder

	^ TFBasicType pointer readValue: handle offset: 1 + TFBasicType pointer byteSize! !

!TFCallbackInvocation methodsFor: 'operations' stamp: ''!
arguments
	| parameterTypes argumentsAddress |
	
	parameterTypes := self callback parameterTypes.
	argumentsAddress := self argumentsAddress.
	
	^ parameterTypes withIndexCollect: [ :type :idx |
		type callbackReadValue: (argumentsAddress pointerAt: 1 + ((idx - 1) * Smalltalk wordSize)) ]! !

!TFCallbackInvocation methodsFor: 'accessing' stamp: ''!
runner

	^ self callback runner! !

!TFCallbackInvocation methodsFor: 'operations' stamp: ''!
execute 
	| returnValue transformedArguments |

	transformedArguments := [ self arguments 
		with: callback parameterTypes 
		collect: [ :anArgument :aType | aType marshallFromPrimitive: anArgument ] ] 
	on: Exception 
	fork: [ :e | e debug ] 
	return: [ self arguments ].

	[ returnValue := callback frontendCallback valueWithArguments: transformedArguments ] 
	ensure: [ 
		returnValue := callback returnType marshallToPrimitive: (callback isSuccess 
			ifTrue: [ returnValue ]
			ifFalse: [ callback frontendCallback returnOnError ]).

		self isNull ifFalse: [ 
			callback returnType isVoid 
				ifFalse: [ self writeReturnValue: returnValue ].
			self runner returnCallback: self ] ]! !

!TFCallbackInvocation methodsFor: 'operations' stamp: ''!
writeReturnValue: aValue

	self callback returnType 
		callbackWrite: aValue 
		into: self returnHolder! !

!TFCallbackInvocation methodsFor: 'operations' stamp: ''!
returnExecution

	"It returns true if the callback can return, and false if the order is not correct and should retry later"

	^ self primCallbackReturn
		ifTrue: [ handle beNull. true ]
		ifFalse: [ false ]
! !

!TFCallbackInvocation methodsFor: 'accessing' stamp: ''!
callbackData

	^ TFBasicType pointer callbackReadValue: handle! !

!TFCallbackInvocation methodsFor: 'accessing' stamp: ''!
callback: aTFCallback 
	callback := aTFCallback! !

!TFCallbackInvocation methodsFor: 'private' stamp: ''!
primCallbackReturn
	<primitive: 'primitiveCallbackReturn'>

	"It returns true if the callback can return, and false if the order is not correct and should
 	retry later"
	
	^ self primitiveFailed! !

!TFCallbackQueue commentStamp: ''!
I'm a callback queue associated to a worker.
I handle all callbacks defined in the context of a worker.!
!TFCallbackQueue methodsFor: 'accessing' stamp: ''!
callbackProcess
	^ callbackProcess! !

!TFCallbackQueue methodsFor: 'system startup' stamp: ''!
startUp

	[self initializeQueue.
	self forkCallbackProcess] 
		onErrorDo: [ self inform: 'The current VM does not support TFFI Callbacks. It will use the old implementation' ]! !

!TFCallbackQueue methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	
	mutex := Mutex new.
	semaphore := Semaphore new.
	callbacksByAddress := WeakValueDictionary new.
	pendingQueue := OrderedCollection new.
	self forkCallbackProcess! !

!TFCallbackQueue methodsFor: 'initialization' stamp: ''!
forkCallbackProcess
	
	(callbackProcess notNil and: [ callbackProcess isTerminated not ])
		ifTrue: [ ^ self ].

	callbackProcess := [
		[ true ] whileTrue: [
			semaphore wait.
			[self executeCallback: self nextPendingCallback]
				on: Exception fork:  [:ex | ex pass ] ] ] 
		forkAt: Processor highIOPriority
		named: 'Callback queue'! !

!TFCallbackQueue methodsFor: 'private' stamp: ''!
lookupCallback: anExternalAddress
	"#registerCallback: and #lookupCallback: are protected by a mutex because I need to prevent 
	 the execution of a collection grow while performing the lookup (this will move the elements 
	 and may cause the lookup to fail).
	 Still, I am keeping a second lookup to ensure if a movement was done, I have another oportunity 
	 to find the callback (just in case, I was not able to verify is actually needed)."

	^ mutex critical: [ 
		callbacksByAddress 
			at: anExternalAddress 
			ifAbsent: [ 
				callbacksByAddress 
					at: anExternalAddress
					ifAbsent: [ nil ] ] ]! !

!TFCallbackQueue methodsFor: 'primitives' stamp: ''!
primitiveInitializeQueueWith: anInteger 

	<primitive: 'primitiveInitilizeCallbacks'>

	^ self primitiveFailed ! !

!TFCallbackQueue methodsFor: 'private' stamp: ''!
nextPendingCallback
	| externalAddress |
	
	externalAddress := self primNextPendingCallback.
	externalAddress ifNil: [ ^ nil ].
	
	^ TFCallbackInvocation fromHandle: externalAddress! !

!TFCallbackQueue methodsFor: 'operations' stamp: ''!
registerCallback: aCallback
	"#registerCallback: and #lookupCallback: are protected by a mutex because I need to prevent 
	 the execution of a collection grow while performing the lookup (this will move the elements 
	 and may cause the lookup to fail)."

	mutex critical: [ 
		callbacksByAddress 
			at: aCallback callbackData 
			put: aCallback ]! !

!TFCallbackQueue methodsFor: 'initialization' stamp: ''!
initializeQueue
	
	| semaphoreIndex |
	
	[	semaphoreIndex := Smalltalk registerExternalObject: semaphore.
		self primitiveInitializeQueueWith: semaphoreIndex ] 
			onErrorDo: [ :e |
				semaphoreIndex ifNotNil: [ Smalltalk unregisterExternalObject: semaphoreIndex ].
				e pass]! !

!TFCallbackQueue methodsFor: 'system startup' stamp: ''!
shutDown

	self terminateProcess.
	callbacksByAddress removeAll.
	pendingQueue removeAll! !

!TFCallbackQueue methodsFor: 'operations' stamp: ''!
executeCallback: aCallbackInvocation
	
	aCallbackInvocation ifNil: [ ^self ].
	aCallbackInvocation getHandle isNull ifTrue: [ ^self ].
	
	aCallbackInvocation callback: ((self lookupCallback: aCallbackInvocation callbackData) 
		ifNil: [
			Stdio stdout << 'INV: ' << aCallbackInvocation getHandle printString; lf.
			self error: 'Callback not found.' ]).
	aCallbackInvocation runner executeCallback: aCallbackInvocation! !

!TFCallbackQueue methodsFor: 'initialization' stamp: ''!
terminateProcess
	
	callbackProcess ifNil: [ ^ self ].
	callbackProcess terminate. 
	callbackProcess := nil! !

!TFCallbackQueue methodsFor: 'private - primitives' stamp: ''!
primNextPendingCallback
	<primitive: 'primitiveReadNextCallback'>

	^ self primitiveFailed! !

!TFCallbackQueue class methodsFor: 'class initialization' stamp: ''!
initialize

	SessionManager default
		registerSystemClassNamed: self name
		atPriority: 70.	
		
	self startUp: true! !

!TFCallbackQueue class methodsFor: 'system startup' stamp: ''!
shutDown: inANewImageSession

	inANewImageSession ifFalse: [ ^ self ].
	self uniqueInstance shutDown.
	UniqueInstance := nil! !

!TFCallbackQueue class methodsFor: 'instance creation' stamp: ''!
uniqueInstance 
	
	^ UniqueInstance ifNil: [ UniqueInstance := self new ]! !

!TFCallbackQueue class methodsFor: 'system startup' stamp: ''!
startUp: inANewImageSession

	inANewImageSession ifFalse: [ ^ self ].
	self uniqueInstance startUp! !

!TFCallbackSameProcessRunStrategy commentStamp: ''!
I am a simple strategy to run the callbacks always in the same process.!
!TFCallbackSameProcessRunStrategy methodsFor: 'private' stamp: ''!
callbackProcess

	(callbackProcess isNotNil and: [ callbackProcess isTerminated not ])
		ifTrue: [ ^ callbackProcess ].
		
	callbackProcess := [ self waitForever ] newProcess.
	callbackProcess priority: Processor highIOPriority - 1.
	callbackProcess resume.
	^ callbackProcess.! !

!TFCallbackSameProcessRunStrategy methodsFor: 'private' stamp: ''!
waitForever

	[ true ] whileTrue: [ Processor activeProcess suspend ]! !

!TFCallbackSameProcessRunStrategy methodsFor: 'executing' stamp: ''!
executeCallback: aCallbackInvocation on: aTFRunner

	| process newContext methodToUse |
	process := self callbackProcess.
		
	"I will reuse the same process if it is not used already. Reentrant callbacks should fork a new process"
	(process isSuspended and: [ process suspendedContext compiledCode method = (self class >> #waitForever) ])
		ifFalse: [ ^ super executeCallback: aCallbackInvocation on: aTFRunner ].	

	methodToUse := self class >> #doExecuteCallback:on:.
	
	newContext := Context 
		sender: process suspendedContext 
		receiver: self 
		method: methodToUse
		arguments: {aCallbackInvocation. aTFRunner}.

	process suspendedContext: newContext.
	process resume! !

!TFCallbackSameProcessRunStrategy methodsFor: 'private' stamp: ''!
doExecuteCallback: aCallbackInvocation on: aTFRunner

	aTFRunner handleExceptionDuring: [ aCallbackInvocation execute ]! !

!TFCallbackSameProcessRunStrategy class methodsFor: 'instance creation' stamp: ''!
new

	self error: 'Use uniqueInstance'! !

!TFCallbackSameProcessRunStrategy class methodsFor: 'instance creation' stamp: ''!
uniqueInstance 

	^ Instance ifNil: [ Instance := self basicNew initialize; yourself]! !

!TFCallbacksTest methodsFor: 'utilities' stamp: ''!
callCallback: aCallback
	
	| functionDefinition function |
	functionDefinition := TFFunctionDefinition
		parameterTypes: {}
		returnType: TFBasicType void.
	function := TFExternalFunction fromAddress: aCallback getHandle 
		definition: functionDefinition.

	runner invokeFunction: function withArguments: {}! !

!TFCallbacksTest methodsFor: 'tests' stamp: ''!
testReentrantCalloutsDuringCallbackUsingSameProcessForCallbacks

	| callback fun returnValue |
	"Avoid running this test before the image side support handles this case.
	Otherwise both the UI thread and the callback management thread will get blocked in a deadlock."
	"true ifTrue: [ ^ self skip ]."
	
	fun := TFExternalFunction
		name: 'singleCallToCallback'
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: {TFBasicType pointer. TFBasicType sint}
			returnType: TFBasicType sint).

	callback := TFCallback 
		forCallback: [ :times | 
			times = 7
				ifTrue: [ times ]
				ifFalse: [ 
					runner invokeFunction: fun withArguments: {callback getHandle. times + 1} ] ] 
		parameters: { TFBasicType sint. } 
		returnType: TFBasicType sint
		runner: runner.

	callback runStrategy: TFCallbackSameProcessRunStrategy uniqueInstance.

	returnValue := runner invokeFunction: fun withArguments: {callback getHandle. 0}.
	self assert: returnValue equals: 7! !

!TFCallbacksTest methodsFor: 'running' stamp: ''!
tearDown 

	runner exceptionHandler: oldExceptionHandler.
	super tearDown! !

!TFCallbacksTest methodsFor: 'tests' stamp: ''!
testCallbackFromOldSessionFailsReturn
	"If a callback survives a session (e.g., an image is saved and reopened), returning it will fail.
	This test validates a surviving callback throws a meaningful exception when trying to return in this case."
	
	| smain s1 c1 |
	smain := Semaphore new.

	s1 := Semaphore new.
	c1 := self newTestCallbackDoing: [ smain signal. s1 wait ].

	[ self callCallback: c1 ] fork.

	"wait until callback starts"
	smain wait.

	"Release the runner as if a new session started"
	runner release.

	"make callback finish and wait until it fails"
	s1 signal.
	runner exceptionHandler wait.

	self assert: runner exceptionHandler lastException class equals: TFInvalidSessionCallbackReturn.
	self assert: runner exceptionHandler lastException callback equals: c1.! !

!TFCallbacksTest methodsFor: 'tests' stamp: ''!
testReentrantCalloutsDuringCallback

	| callback fun returnValue |
	"Avoid running this test before the image side support handles this case.
	Otherwise both the UI thread and the callback management thread will get blocked in a deadlock."
	"true ifTrue: [ ^ self skip ]."
	
	fun := TFExternalFunction
		name: 'singleCallToCallback'
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: {TFBasicType pointer. TFBasicType sint32}
			returnType: TFBasicType sint32).

	callback := TFCallback 
		forCallback: [ :times | 
			times = 7
				ifTrue: [ times ]
				ifFalse: [ runner invokeFunction: fun withArguments: {callback getHandle. times + 1} ] ] 
		parameters: { TFBasicType sint32. } 
		returnType: TFBasicType sint32
		runner: runner.

	returnValue := runner invokeFunction: fun withArguments: {callback getHandle. 0}.
	self assert: returnValue equals: 7! !

!TFCallbacksTest methodsFor: 'tests' stamp: ''!
testCallbackNotRespectingLIFOOrderFailsReturn

	| smain s1 c1 s2 c2 returned |
	smain := Semaphore new.

	true ifTrue: [ 	^ self skip ].

	returned := false.

	s1 := Semaphore new.
	c1 := self newTestCallbackDoing: [ smain signal. s1 wait ].

	s2 := Semaphore new.
	c2 := self newTestCallbackDoing: [ smain signal. s2 wait ].
	
	[ self callCallback: c1. returned := true ] fork.
	[ self callCallback: c2 ] fork.

	"wait until both callbacks arrive"
	smain wait; wait.
	
	"make callback 1 to finish while callback 2 is suspended"
	s1 signal.
	"Wait until C1 tries to return"
	100 milliSecond wait.
	"It should not return until C2 returns"
	self deny: returned.
	"Signal s2 to make c2 return"
	s2 signal.	
	"Wait until C1 tries to return"
	100 milliSecond wait.

	self assert: returned.! !

!TFCallbacksTest methodsFor: 'tests' stamp: ''!
testSingleCalloutDuringCallback

	| callback fun returnValue |

	callback := TFCallback 
		forCallback: [ :a | self shortCallout ] 
		parameters: { TFBasicType sint. } 
		returnType: TFBasicType sint
		runner: runner.

	fun := TFExternalFunction
		name: 'singleCallToCallback'
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: {TFBasicType pointer. TFBasicType sint}
			returnType: TFBasicType sint).

	returnValue := runner invokeFunction: fun withArguments: {callback getHandle. 3}.
	self assert: returnValue equals: 42! !

!TFCallbacksTest methodsFor: 'instance creation' stamp: ''!
newTestCallbackDoing: aBlock
	
	^ TFCallback 
		forCallback: aBlock 
		parameters: {} 
		returnType: TFBasicType void
		runner: runner.! !

!TFCallbacksTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	
	oldExceptionHandler := runner exceptionHandler.
	runner exceptionHandler: TFTestCallbackExceptionHandler new! !

!TFCalloutAPI commentStamp: ''!
I am a TFCalloutAPI implementation that overrides the builder to use the one needed to generate TFFI code!
!TFCalloutAPI methodsFor: 'action' stamp: ''!
newBuilder

	^ TFCalloutMethodBuilder calloutAPI: self! !

!TFCalloutAPI class methodsFor: 'tracing' stamp: ''!
resetTrace
	<script>
	
	TraceBlock := nil.
	FFIMethodRegistry resetAll! !

!TFCalloutAPI class methodsFor: 'tracing' stamp: ''!
isTracing

	^ TraceBlock notNil! !

!TFCalloutAPI class methodsFor: 'instance creation' stamp: ''!
newCallbackBackendFor: aCallback

	^ (TFCallback
		forCallback: aCallback
		parameters: (aCallback functionSpec arguments collect: #tfExternalTypeWithArity) asArray
		returnType: aCallback functionSpec returnType tfExternalTypeWithArity
		runner: aCallback ffiLibrary runner)
			runStrategy: aCallback ffiLibrary callbackRunningStrategy;
			yourself! !

!TFCalloutAPI class methodsFor: 'tracing' stamp: ''!
activateTrace

	self activateTraceWith: [ :sender | sender crTrace ]! !

!TFCalloutAPI class methodsFor: 'tracing' stamp: ''!
trace: sender
	"This method is not to be used directly, it is called by TFFI when #activateTrace was called."

	TraceBlock ifNil: [ ^ self ].
	TraceBlock value: sender! !

!TFCalloutAPI class methodsFor: 'tracing' stamp: ''!
activateTraceWith: aBlock

	TraceBlock := aBlock.
	FFIMethodRegistry resetAll! !

!TFCalloutMethodBuilder commentStamp: ''!
I override some methods to correctly generate TFFI methods when using UFFI.!
!TFCalloutMethodBuilder methodsFor: 'private' stamp: ''!
generateFFICallout: builder spec: functionSpec ffiLibrary: ffiLibrary

	TFCalloutAPI isTracing ifTrue: [ 
		TFCalloutAPI trace: sender. 
		builder 
			pushLiteral: TFCalloutAPI;
			pushLiteral: sender;
			send: #trace: ].
	
	builder 
		pushLiteral: (ffiLibrary uniqueInstance runner).
			
	"save ffi call as literal"
	builder pushLiteral: (self createFFICalloutLiteralFromSpec: functionSpec).
	"iterate arguments in order (in the function) to create the function call"
	
	functionSpec arguments 
		do: [ :each | 
			each emitArgument: builder context: sender inCallout: self requestor.
			each resolvedType tfExternalTypeWithArity emitMarshallToPrimitive: builder ].
	
	"create the array"
	builder pushConsArray: functionSpec arguments size.
	builder addTemp: #argumentsArray.
	builder storeTemp: #argumentsArray.
	
	"send call and store into result"
	builder send: #invokeFunction:withArguments:.

	functionSpec arguments withIndexDo: [ :each :index| 
		each emitReturnArgument: builder context: sender.
		each resolvedType tfExternalTypeWithArity 
			emitFreeIfNeededOfIndex: index
			argumentsArrayTempName: #argumentsArray
			withBuilder: builder  ].
	
	"Additional marshall in the case of TFFI"	
	functionSpec returnType resolvedType tfExternalTypeWithArity emitMarshallFromPrimitive: builder.

	"convert in case return type needs it. And return reseult"	
	
	^ functionSpec returnType
		emitReturn: builder
		resultTempVar: #result
		context: sender
		inCallout: self requestor! !

!TFCalloutMethodBuilder methodsFor: 'calling convention' stamp: ''!
abiConstantFor: aSelector

	^ self class abiConstantFor: aSelector
	
	! !

!TFCalloutMethodBuilder methodsFor: 'private' stamp: ''!
createFFICalloutLiteralFromSpec: functionSpec

	^ TFExternalFunction
		  name: functionSpec functionName
		  moduleName: self libraryName
		  parameterTypes:
		  (functionSpec arguments collect: #tfExternalTypeWithArity)
		  returnType: functionSpec returnType tfExternalTypeWithArity
		  fixedArgumentCount: fixedArgumentCount
		  abi: (self abiConstantFor: calloutAPI callingConvention)! !

!TFCalloutMethodBuilder class methodsFor: 'calling conventions' stamp: ''!
abiConstantFor: aString

	| key |
	aString = OSPlatform current ffiCallingConvention ifTrue: [ 
		^ DEFAULT_ABI ].
	key := { 
		       Smalltalk vm operatingSystemName asSymbol.
		       Smalltalk vm architectureName asSymbol.
		       aString asSymbol }.

	^ self abiConstantMapping at: key ifAbsent: [ 
		  self error: 'The requested ABI is not available for this architecture:'
		  , key printString ]! !

!TFCalloutMethodBuilder class methodsFor: 'initialization - private' stamp: ''!
initializeABIMapping

	"self initializeABIMapping"

	^ ABI_MAPPING := { 
		  ({ #Win32. #x86_64. #win64 } -> WIN_X86_64_WIN64).
		  ({ #Win32. #x86_64. #gnuw64 } -> WIN_X86_64_GNUW64).
		  ({ #Win32. #x86_64. #cdecl } -> WIN_X86_64_GNUW64).

		  ({ #'Mac OS'. #x86_64. #unix64 } -> DARWIN_X86_64_UNIX64).
		  ({ #'Mac OS'. #x86_64. #win64 } -> DARWIN_X86_64_WIN64).
		  ({ #'Mac OS'. #x86_64. #gnuw64 } -> DARWIN_X86_64_GNUW64).

		  ({ #unix. #x86_64. #unix64 } -> UNIX_X86_64_UNIX64).
		  ({ #unix. #x86_64. #win64 } -> UNIX_X86_64_WIN64).
		  ({ #unix. #x86_64. #gnuw64 } -> UNIX_X86_64_GNUW64).

		  ({ #Win32. #i686. #cdecl } -> WIN_X86_32_SYSV).
		  ({ #Win32. #i686. #sysv } -> WIN_X86_32_SYSV).
		  ({ #Win32. #i686. #stdcall } -> WIN_X86_32_STDCALL).
		  ({ #Win32. #i686. #thisCall } -> WIN_X86_32_THISCALL).
		  ({ #Win32. #i686. #fastCall } -> WIN_X86_32_FASTCALL).
		  ({ #Win32. #i686. #ms_cdecl } -> WIN_X86_32_MS_CDECL).
		  ({ #Win32. #i686. #pascal } -> WIN_X86_32_PASCAL).
		  ({ #Win32. #i686. #register } -> WIN_X86_32_REGISTER).

		  ({ #unix. #i686. #cdecl } -> UNIX_X86_32_SYSV).
		  ({ #unix. #i686. #sysv } -> UNIX_X86_32_SYSV).
		  ({ #unix. #i686. #thisCall } -> UNIX_X86_32_THISCALL).
		  ({ #unix. #i686. #fastCall } -> UNIX_X86_32_FASTCALL).
		  ({ #unix. #i686. #stdcall } -> UNIX_X86_32_STDCALL).
		  ({ #unix. #i686. #ms_cdecl } -> UNIX_X86_32_MS_CDECL).
		  ({ #unix. #i686. #pascal } -> UNIX_X86_32_PASCAL).
		  ({ #unix. #i686. #register } -> UNIX_X86_32_REGISTER).
		
		} asDictionary! !

!TFCalloutMethodBuilder class methodsFor: 'calling convention' stamp: ''!
abiConstantMapping
	
	^ ABI_MAPPING ifNil: [ self initializeABIMapping ]! !

!TFCharType commentStamp: ''!
I extend TFIntType to support Characters.!
!TFCharType methodsFor: 'marshalling' stamp: ''!
emitMarshallFromPrimitive: builder
	
	builder send: #asCharacter! !

!TFCharType methodsFor: 'marshalling' stamp: ''!
marshallFromPrimitive: aValue
	
	^ aValue asCharacter
	! !

!TFCharType methodsFor: 'marshalling' stamp: ''!
marshallToPrimitive: aValue
	
	^ aValue asInteger
	! !

!TFDerivedType commentStamp: ''!
TFFI supports complex types. I am the representation of those. I have a basic type and I handle the marshalling delegating to the basic type and doing the little adjustements needed for me.!
!TFDerivedType methodsFor: 'reading-writing' stamp: ''!
callbackWrite: anObject into: anExternalAddress
	
	self write: anObject into: anExternalAddress! !

!TFDerivedType methodsFor: 'reading-writing' stamp: ''!
write: anObject into: anExternalAddress
	
	self basicType write: anObject into: anExternalAddress! !

!TFDerivedType methodsFor: 'reading-writing' stamp: ''!
callbackReadValue: anExternalAddress
	
	^ self readValue: anExternalAddress ! !

!TFDerivedType methodsFor: 'accessing' stamp: ''!
getHandle
	
	^ self basicType getHandle! !

!TFDerivedType methodsFor: 'marshalling' stamp: ''!
emitFreeIfNeededOfIndex: argIndex argumentsArrayTempName: argumentsArrayTempName withBuilder: anIRBuilder
! !

!TFDerivedType methodsFor: 'testing' stamp: ''!
isVoid
	
	^ self basicType isVoid! !

!TFDerivedType methodsFor: 'marshalling' stamp: ''!
marshallFromPrimitive: aValue
	
	^ aValue
	! !

!TFDerivedType methodsFor: 'reading-writing' stamp: ''!
readReturnValue: anExternalAddress

	^ self readValue: anExternalAddress! !

!TFDerivedType methodsFor: 'accessing' stamp: ''!
byteSize
	
	^ self basicType byteSize! !

!TFDerivedType methodsFor: 'validating' stamp: ''!
validate
	
	self basicType validate! !

!TFDerivedType methodsFor: 'marshalling' stamp: ''!
marshallToPrimitive: aValue
	
	^ aValue
	! !

!TFDerivedType methodsFor: 'freeing' stamp: ''!
freeValueIfNeeded: aCHeapValueHolder 
	
	"Hook into me if you want to free some value sent previously to a C function"! !

!TFDerivedType methodsFor: 'accessing' stamp: ''!
basicType
	
	^ TFBasicType pointer! !

!TFDerivedType methodsFor: 'reading-writing' stamp: ''!
readValue: anExternalAddress
	
	self subclassResponsibility! !

!TFDerivedType class methodsFor: 'accessing' stamp: ''!
boolean
	
	^ BOOLEAN ifNil: [ BOOLEAN := TFBooleanType new ]! !

!TFDerivedType class methodsFor: 'accessing' stamp: ''!
boolean32
	
	^ BOOLEAN32 ifNil: [ BOOLEAN32 := TFBoolean32Type new ]! !

!TFDerivedType class methodsFor: 'accessing' stamp: ''!
string
	
	^ STRING ifNil: [ STRING := TFStringType new ]! !

!TFDerivedType class methodsFor: 'accessing' stamp: ''!
objectPointer
	
	^ OOP ifNil: [ OOP := TFOOPType new ]! !

!TFDoubleType commentStamp: ''!
I represent a double type in libffi.
I override the marshalling methods from/to C doubles to pharo objects.

See my superclass for more details.!
!TFDoubleType methodsFor: 'writing' stamp: ''!
write: aNumber into: anExternalAddress 

	anExternalAddress doubleAt: 1 put: aNumber asFloat! !

!TFDoubleType methodsFor: 'writing' stamp: ''!
emitMarshallToPrimitive: builder
	
	builder send: #asFloat! !

!TFDoubleType methodsFor: 'reading' stamp: ''!
readValue: anExternalAddress offset: offset
	
	^ anExternalAddress doubleAt: offset! !

!TFExternalAsyncCall commentStamp: ''!
I am an asynchronous call to an external function. I reference the function to call and the arguments of the call.
The function execution will happen in a separate thread, and meanwhile the current Pharo process is suspended without suspending the entire VM thread.

For this purpose, I have a semaphore that is handed out to the primitive that executes the function.
Upon the return of the primitive (i.e., when the function execution finished is scheduled), I wait at the semaphore.
When the function execution is managed and finishes, the threaded FFI plugin will signal the semaphore and the calling Pharo process will be re-scheduled to be run.!
!TFExternalAsyncCall methodsFor: 'initialization' stamp: ''!
initialize
	semaphore := Semaphore new.! !

!TFExternalAsyncCall methodsFor: 'private - semaphore' stamp: ''!
registerSemaphore
	
	index := Smalltalk registerExternalObject: self semaphore! !

!TFExternalAsyncCall methodsFor: 'accessing' stamp: ''!
semaphoreIndex
	^ index! !

!TFExternalAsyncCall methodsFor: 'operations' stamp: ''!
doExecuteOn: aRunner
	
	| aTaskAddress | 
	
	aTaskAddress := aRunner
		executeFunction: function
		withArguments: parameterArray
		usingSemaphore: self semaphoreIndex.
	
	"I check if the semaphore is already signaled, because doing it in this way 
	is thousands of times faster than just executing the wait. 
	I think is a bug in the VM"
	
	self semaphore isSignaled 
		ifFalse: [ self semaphore wait ].
	
	^ aRunner readReturnValueFromTask: aTaskAddress! !

!TFExternalAsyncCall methodsFor: 'accessing' stamp: ''!
parameters
	^ arguments! !

!TFExternalAsyncCall methodsFor: 'accessing' stamp: ''!
parameters: anObject
	arguments := anObject! !

!TFExternalAsyncCall methodsFor: 'accessing' stamp: ''!
semaphore

	^ semaphore! !

!TFExternalAsyncCall methodsFor: 'operations' stamp: ''!
executeOn: aRunner
	"Performs a callout using the asynchronous threaded FFI plugin.
	 This method schedules the execution of a function in the threaded FFI plugin and 
	 then waits for its result in a semaphore.
	 When the semaphore is signaled, the result is available in an external value holder
	 from where the value is read.
	 This method contains some boilerplate code to allocate and release external 
	 value holders for the arguments and the return value."

	^ [
			self prepareExecution.
			self doExecuteOn: aRunner ]
		ensure: [
			self cleanUp ]! !

!TFExternalAsyncCall methodsFor: 'accessing' stamp: ''!
function
	^ function! !

!TFExternalAsyncCall methodsFor: 'accessing' stamp: ''!
function: anObject
	function := anObject! !

!TFExternalAsyncCall methodsFor: 'private - validation' stamp: ''!
validateFunction
	
	function validate! !

!TFExternalAsyncCall methodsFor: 'operations' stamp: ''!
prepareExecution
	self validateFunction.

	parameterArray := arguments asArray.

	self registerSemaphore.
! !

!TFExternalAsyncCall methodsFor: 'operations' stamp: ''!
cleanUp
	self deregisterSemaphore.! !

!TFExternalAsyncCall methodsFor: 'private - semaphore' stamp: ''!
deregisterSemaphore
	
	Smalltalk unregisterExternalObject: self semaphore! !

!TFExternalAsyncCall class methodsFor: 'instance creation' stamp: ''!
forFunction: aTFExternalFunction 
	
	^ self basicNew
		function: aTFExternalFunction;
		initialize;
		yourself! !

!TFExternalFunction commentStamp: ''!
I represent an external function from a library.
I have a name, a TFFunctionDefinition type signature and I am fetched from an external library.

TFExternalFunction
	name: 'functionName'
	moduleName: 'pathToLibrary'
	definition: (TFFunctionDefinition
		parameterTypes: { TFBasicType pointer }
		returnType: TFBasicType sint).

To execute myself you can call my #execute and #executeWithArguments: method.
These will create an async function call and block the current pharo process while waiting for its finish.

!!!! Examples

((TFExternalFunction
	name: 'getenv'
	moduleName: LibC uniqueInstance moduleName
	parameterTypes: { TFBasicType pointer }
	returnType: TFBasicType pointer)
		executeWithArguments: { ExternalAddress fromString: 'HOME' utf8Encoded }) readString asByteArray utf8Decoded.!
!TFExternalFunction methodsFor: 'accessing' stamp: ''!
address: anObject
	handle := anObject! !

!TFExternalFunction methodsFor: 'accessing' stamp: ''!
functionName: anObject
	functionName := anObject! !

!TFExternalFunction methodsFor: 'operations' stamp: ''!
validate
	definition validate.
	handle isNull
		ifTrue: [ handle := ExternalAddress loadSymbol: functionName module: moduleName ]! !

!TFExternalFunction methodsFor: 'accessing' stamp: ''!
moduleName: anObject
	moduleName := anObject! !

!TFExternalFunction methodsFor: 'accessing' stamp: ''!
definition: anObject
	definition := anObject! !

!TFExternalFunction methodsFor: 'accessing' stamp: ''!
address
	^ handle! !

!TFExternalFunction methodsFor: 'accessing' stamp: ''!
definition
	^ definition! !

!TFExternalFunction methodsFor: 'accessing' stamp: ''!
moduleName
	^ moduleName! !

!TFExternalFunction methodsFor: 'accessing' stamp: ''!
functionName
	^ functionName! !

!TFExternalFunction class methodsFor: 'instance creation' stamp: ''!
name: aName moduleName: aModuleName parameterTypes: parameterTypes returnType: returnType

	^ self
		  name: aName
		  moduleName: aModuleName
		  parameterTypes: parameterTypes
		  returnType: returnType
		  fixedArgumentCount: 0
		  abi: nil! !

!TFExternalFunction class methodsFor: 'instance creation' stamp: ''!
name: aName moduleName: aModuleName parameterTypes: parameterTypes returnType: returnType fixedArgumentCount: fixedArgumentCount abi: abiType

	| definition |

	definition := fixedArgumentCount = 0 
		ifTrue:[	
			TFFunctionDefinition 
				parameterTypes: parameterTypes
				returnType: returnType
				abi: abiType]
		ifFalse:[	
			TFVariadicFunctionDefinition 
				parameterTypes: parameterTypes
				returnType: returnType
				fixedArgumentCount: fixedArgumentCount
				abi: abiType].

	^ self
		name: aName
		moduleName: aModuleName
		definition: definition! !

!TFExternalFunction class methodsFor: 'instance creation' stamp: ''!
fromAddress: anExternalAddress definition: aFunctionDefinition

	^ self new
		address: anExternalAddress;
		definition: aFunctionDefinition;
		yourself! !

!TFExternalFunction class methodsFor: 'instance creation' stamp: ''!
name: aName moduleName: aModuleName definition: aFunctionDefinition

	^ self new
		address: ExternalAddress new;
		moduleName: aModuleName;
		functionName: aName;
		definition: aFunctionDefinition;
		yourself! !

!TFExternalFunction class methodsFor: 'instance creation' stamp: ''!
name: aName moduleName: aModuleName parameterTypes: parameterTypes returnType: returnType type: aFunctionCallType

	^ (self name: aName moduleName: aModuleName parameterTypes: parameterTypes returnType: returnType)
		type: aFunctionCallType;
		yourself
! !

!TFExternalSemaphore commentStamp: ''!
I am container for a semaphore which will be automatically registered as external on initialization.
This is to be used as part of the external semaphores pool.
Inside me you can find: 

- semaphore 
- index 

index is the external semaphore index to be used on primitive calls.
!
!TFExternalSemaphore methodsFor: 'initialization' stamp: ''!
initialize
	
	super initialize.
	semaphore := Semaphore new.
	index := Smalltalk registerExternalObject: semaphore! !

!TFExternalSemaphore methodsFor: 'accessing' stamp: ''!
semaphore

	^ semaphore! !

!TFExternalSemaphore methodsFor: 'initialization' stamp: ''!
release

	super release.
	Smalltalk unregisterExternalObject: semaphore.
! !

!TFExternalSemaphore methodsFor: 'initialization' stamp: ''!
reset

	semaphore consumeAllSignals! !

!TFExternalSemaphore methodsFor: 'accessing' stamp: ''!
index

	^ index! !

!TFFIBackend commentStamp: ''!
I am the FFI backend implemented by using TFFI!
!TFFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float32At: offset put: value

	value isFloat ifFalse: [ 
		^ anObject float32AtOffset: offset - 1 put: value asFloat ].

	self isReadOnlyObject ifTrue: [ 
		^ self
			  modificationForbiddenFor: #on:float32At:put:
			  index: offset
			  value: value ].

	^ self primitiveFailed! !

!TFFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float64At: offset put: value

	value isFloat ifFalse: [ 
		^ anObject float64AtOffset: offset - 1 put: value asFloat ].

	self isReadOnlyObject ifTrue: [ 
		^ self
			  modificationForbiddenFor: #on:float64At:put:
			  index: offset
			  value: value ].
		
	^ self primitiveFailed! !

!TFFIBackend methodsFor: 'instance creation' stamp: ''!
allocate: byteSize

	"Primitive. Allocate an object on the external heap."

	<primitive: 'primitiveFFIAllocate'>
	^ self primitiveFailed! !

!TFFIBackend methodsFor: 'instance creation' stamp: ''!
free: anExternalAddress

	<primitive:'primitiveFFIFree'>
	^self primitiveFailed! !

!TFFIBackend methodsFor: 'accessing' stamp: ''!
integerOfObject: anObject at: byteOffset size: nBytes signed: aBoolean
	"Primitive. Return an integer of nBytes size from the receiver.
	Note: This primitive will access memory in the outer space if
	invoked from ExternalAddress."
	<primitive: 'primitiveFFIIntegerAt'>
	^self primitiveFailed! !

!TFFIBackend methodsFor: 'instance creation' stamp: ''!
primLoadSymbol: moduleSymbol module: module 

	<primitive: 'primitiveLoadSymbolFromModule'>

	^ self primitiveFailed! !

!TFFIBackend methodsFor: 'callbacks' stamp: ''!
lookupCallbackByAddress: address 
	
	^ (TFCallbackQueue uniqueInstance lookupCallback: address) frontendCallback! !

!TFFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float32At: offset

	^ self primitiveFailed! !

!TFFIBackend methodsFor: 'testing' stamp: ''!
isAvailable

	^ [ self loadSymbol: #primitiveLoadSymbolFromModule module: nil. true ] onErrorDo: [ false ]! !

!TFFIBackend methodsFor: 'instance creation' stamp: ''!
calloutAPIClass
	
	^ TFCalloutAPI ! !

!TFFIBackend methodsFor: 'accessing' stamp: ''!
on: anObject float64At: offset

	^ self primitiveFailed! !

!TFFIBackend methodsFor: 'accessing' stamp: ''!
integerOfObject: anObject at: byteOffset put: value size: nBytes signed: aBoolean
	"Primitive. Store the given value as integer of nBytes size
	in the receiver. Fail if the value is out of range.
	Note: This primitive will access memory in the outer space if
	invoked from ExternalAddress."
	<primitive: 'primitiveFFIIntegerAtPut'>
	^self primitiveFailed! !

!TFFIBackend methodsFor: 'instance creation' stamp: ''!
loadSymbol: moduleSymbol module: module 
	
	| encodedString |
	encodedString := module ifNotNil: [ module utf8Encoded asString ].
	
	"The primitive is expected the module to be a utf8Encoded String."
	^ self primLoadSymbol: moduleSymbol module: encodedString! !

!TFFIBackend class methodsFor: 'accessing' stamp: ''!
priority

	^ 10! !

!TFFIBackend class methodsFor: 'detecting' stamp: ''!
isAvailable
	
	^ self new isAvailable ! !

!TFFloatType commentStamp: ''!
I represent a float type in libffi.
I override the marshalling methods from/to C floats to pharo objects.

See my superclass for more details.!
!TFFloatType methodsFor: 'writing' stamp: ''!
write: aNumber into: anExternalAddress 
	
	anExternalAddress floatAt: 1 put: aNumber asFloat! !

!TFFloatType methodsFor: 'reading' stamp: ''!
emitMarshallToPrimitive: builder
	
	builder send: #asFloat! !

!TFFloatType methodsFor: 'reading' stamp: ''!
readValue: anExternalAddress offset: offset

	^ anExternalAddress floatAt: offset! !

!TFForkCallbackExceptionHandler commentStamp: ''!
I am a callback error handler that forks a process with the callback error.
I execute the given block and handle it with #on:fork:.

I collaborate with TFRunner instances that centralize the callback execution and return per runner.!
!TFForkCallbackExceptionHandler methodsFor: 'errors' stamp: ''!
handleExceptionDuring: aBlock

	aBlock on: Exception fork: [ :e | e pass ]! !

!TFFunctionCallTest methodsFor: 'tests' stamp: ''!
testCallbackInLoop

	| callback fun returnValue |

	callback := TFCallback 
		forCallback: [ :a | a + 1 ] 
		parameters: { TFBasicType sint. } 
		returnType: TFBasicType sint
		runner: runner.

	fun := TFExternalFunction
		name: 'callbackInALoop'
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: {TFBasicType pointer}
			returnType: TFBasicType sint).

	returnValue := runner invokeFunction: fun withArguments: {callback getHandle}.

	self assert: returnValue equals: 42
! !

!TFFunctionCallTest methodsFor: 'tests' stamp: ''!
testWithoutArguments
	
	self assert: self shortCallout equals: 42.! !

!TFFunctionCallTest methodsFor: 'tests' stamp: ''!
testVariadicFunctionWithOneFixedAndTwoOptional

	| fun return buffer aString |

	self skipOnAppleARM.

	fun := TFExternalFunction
		name: 'sprintf'
		moduleName: LibC uniqueInstance ffiLibraryName
		definition: (TFVariadicFunctionDefinition
			parameterTypes: { TFBasicType pointer. TFBasicType pointer.  TFBasicType sint. TFBasicType sint }
			returnType: TFBasicType sint
			fixedArgumentCount: 2).
	
	buffer := ByteArray new: 50.
	buffer pinInMemory.

	aString := '%d %d' utf8Encoded.
	aString pinInMemory.
	
	return := runner invokeFunction: fun withArguments: {PointerUtils oopForObject: buffer. PointerUtils oopForObject: aString . 5 . 5}.
	
	self assert: return equals: 3! !

!TFFunctionCallTest methodsFor: 'tests' stamp: ''!
testCallbackInSingleFunction

	| callback fun returnValue |

	callback := TFCallback 
		forCallback: [ :a | a + 1 ] 
		parameters: { TFBasicType sint. } 
		returnType: TFBasicType sint
		runner: runner.

	fun := TFExternalFunction
		name: 'singleCallToCallback'
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: {TFBasicType pointer. TFBasicType sint}
			returnType: TFBasicType sint).
			
	returnValue := runner invokeFunction: fun withArguments: {callback getHandle. 3}.

	self assert: returnValue equals: 5
! !

!TFFunctionCallTest methodsFor: 'tests' stamp: ''!
testWithTwoInts

	| fun return |

	fun := TFExternalFunction
		name: 'sumTwoNumbers'
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: { TFBasicType sint. TFBasicType sint }
			returnType: TFBasicType sint).
				
	return := runner invokeFunction: fun withArguments: {3. 2}.
	
	self assert: return equals: 5! !

!TFFunctionCallTest methodsFor: 'tests' stamp: ''!
testCallingFunctionWithW64CallingConvention

	| fun returnValue |
	
	"This test is only valid in OSX and X86_64, as calling conventions constants are heavily dependant on the OS & Architecture"
	(OSPlatform current isMacOS and: [ Smalltalk vm architectureName = 'x86_64']) 
		ifFalse: [ self skip ].

	fun := TFExternalFunction
		name: 'w64Convention'
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: {TFBasicType sint. TFBasicType sint. TFBasicType sint. TFBasicType sint. TFBasicType sint. TFBasicType sint. TFBasicType sint. TFBasicType sint. TFBasicType sint. TFBasicType sint}
			returnType: TFBasicType sint
			abi: DARWIN_X86_64_WIN64).
			
	returnValue := runner invokeFunction: fun withArguments: (1 to: 10) asArray.

	self assert: returnValue equals: 55
! !

!TFFunctionCallTest methodsFor: 'tests' stamp: ''!
testWithFloatAndDouble
	| fun return |

	fun := TFExternalFunction
		name: 'sumAFloatAndADouble'
		moduleName: self libraryPath
		definition: (TFFunctionDefinition
			parameterTypes: { TFBasicType float. TFBasicType double }
			returnType: TFBasicType float).
			
	return := runner invokeFunction: fun withArguments: #(1.0 2.5).
		
	self assert: return equals: 3.5! !

!TFFunctionCallTest methodsFor: 'tests' stamp: ''!
testCallbackAsFunction

	| callback fun definition returnValue |

	callback := TFCallback 
		forCallback: [ :a :b | a + b ] 
		parameters: { TFBasicType sint. TFBasicType float } 
		returnType: TFBasicType float
		runner: runner.

	definition := TFFunctionDefinition
		parameterTypes: {TFBasicType sint. TFBasicType float.}
		returnType: TFBasicType float.

	fun := TFExternalFunction 
		fromAddress: callback getHandle 
		definition: definition.
	
	returnValue := runner invokeFunction: fun withArguments: {1. 2.0}.
			
	self assert: returnValue equals: 3.0! !

!TFFunctionDefinition commentStamp: ''!
I represent a function type signature. I am used for both defining named functions and anonymous callbacks.
I am created using an array of parameter types and a single return type, all TFBasicType (sub)instances.

TFFunctionDefinition
	parameterTypes: {TFBasicType sint. TFBasicType float.}
	returnType: TFBasicType float.
	
I am not meant to be used from outside of this plugin, so my main users are TFCallback and TFExternalFunction

As we maybe keep the function definition when we are saving the image, we cannot put a default value to the ABI, as the default value changes from platform to platform.
That is why the ABI is initialized to nil and then different primitives are used.
!
!TFFunctionDefinition methodsFor: 'accessing' stamp: ''!
parameterTypes: anObject
	parameterTypes := anObject! !

!TFFunctionDefinition methodsFor: 'private' stamp: ''!
doValidate: parameterHandlers

	"As we maybe keep the function definition when we are saving the image, we cannot put a default value to the ABI, as the default value changes from platform to platform"
	
	abi
		ifNil: [ 
			self
				primDefineFunctionWith: parameterHandlers
				returnType: returnType getHandle ]
		ifNotNil: [ 
			self
				primDefineFunctionWith: parameterHandlers
				returnType: returnType getHandle
				abi: abi asInteger ]! !

!TFFunctionDefinition methodsFor: 'accessing' stamp: ''!
returnType
	^ returnType! !

!TFFunctionDefinition methodsFor: 'accessing' stamp: ''!
parameterTypes
	^ parameterTypes! !

!TFFunctionDefinition methodsFor: 'accessing' stamp: ''!
abi

	^ abi! !

!TFFunctionDefinition methodsFor: 'accessing' stamp: ''!
abi: anObject

	abi := anObject! !

!TFFunctionDefinition methodsFor: 'accessing' stamp: ''!
validate
	| parameterHandlers |

	handle isNull ifFalse: [ ^self ].

	"First, we get valid parameter handles."
	parameterTypes do: [ :e | e validate ].
	returnType validate.
	
	parameterHandlers := parameterTypes collect: [ :e | e getHandle ] as: Array.
	
	self doValidate: parameterHandlers.
! !

!TFFunctionDefinition methodsFor: 'primitives' stamp: ''!
primDefineFunctionWith: parameterHandlers returnType: returnTypeHandler abi: abiType
	
	<primitive: 'primitiveDefineFunction' error: ec>

	^ self primitiveFailed	! !

!TFFunctionDefinition methodsFor: 'primitives' stamp: ''!
primDefineFunctionWith: parameterHandlers returnType: returnTypeHandler 
	
	<primitive: 'primitiveDefineFunction' error: ec>

	^ self primitiveFailed	! !

!TFFunctionDefinition methodsFor: 'primitives' stamp: ''!
primFreeDefinition
	
	<primitive: 'primitiveFreeDefinition'>

	^ self primitiveFailed	! !

!TFFunctionDefinition methodsFor: 'accessing' stamp: ''!
returnType: anObject
	returnType := anObject! !

!TFFunctionDefinition class methodsFor: 'instance creation' stamp: ''!
parameterTypes: someParameters returnType: returnType

	^ self parameterTypes: someParameters returnType: returnType abi: nil! !

!TFFunctionDefinition class methodsFor: 'instance creation' stamp: ''!
finalizeResourceData: handle

	handle isNull ifTrue: [ ^ self ].

	self new
		setHandle: handle;
		primFreeDefinition.! !

!TFFunctionDefinition class methodsFor: 'instance creation' stamp: ''!
parameterTypes: someParameters returnType: returnType abi: abi

	^ self new
		parameterTypes: someParameters;
		returnType: returnType;
		abi: abi;
		autoRelease;
		yourself! !

!TFFunctionDefinition class methodsFor: 'instance creation' stamp: ''!
fromHandle: aHandle
	
	^ self error: 'should not be used'! !

!TFIncorrectOrderCallbackReturn commentStamp: ''!
I am an error indicating a callback tries to return in an incorrect order.
I notify the user with the problematic callback and the list of callbacks that should have returned before.!
!TFIncorrectOrderCallbackReturn methodsFor: 'accessing' stamp: ''!
previousCallbacks
	^ previousCallbacks! !

!TFIncorrectOrderCallbackReturn methodsFor: 'accessing' stamp: ''!
previousCallbacks: anObject
	previousCallbacks := anObject! !

!TFInnerTestStruct commentStamp: ''!
I am an struct used for testing.
I am the inner struct of a bigger one.!
!TFInnerTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
b: anObject
	"This method was automatically generated"
	handle pointerAt: OFFSET_B put: anObject getHandle.! !

!TFInnerTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
a
	"This method was automatically generated"
	^handle unsignedCharAt: OFFSET_A! !

!TFInnerTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
a: anObject
	"This method was automatically generated"
	handle unsignedCharAt: OFFSET_A put: anObject! !

!TFInnerTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
b
	"This method was automatically generated"
	^ExternalData fromHandle: (handle pointerAt: OFFSET_B) type: ExternalType void asPointerType! !

!TFInnerTestStruct class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	
	"self rebuildFieldAccessors"
	
	^ #(
	char a;
	void* b;
	)! !

!TFIntType commentStamp: ''!
I represent a int type in libffi, and I augment basic types with a sign.
I override the marshalling methods from/to C doubles to pharo objects.

See my superclass for more details.!
!TFIntType methodsFor: 'writing' stamp: ''!
write: anInteger into: anExternalAddress

	anExternalAddress integerAt: 1 put: anInteger asInteger size: self byteSize signed: signed! !

!TFIntType methodsFor: 'marshalling' stamp: ''!
emitMarshallToPrimitive: builder
	
	builder send: #asInteger! !

!TFIntType methodsFor: 'accessing' stamp: ''!
signed: anObject
	signed := anObject! !

!TFIntType methodsFor: 'accessing' stamp: ''!
signed
	^ signed! !

!TFIntType methodsFor: 'reading' stamp: ''!
readValue: anExternalAddress offset: offset
	
	^ anExternalAddress integerAt: offset size: self byteSize signed: signed! !

!TFInvalidSessionCallbackReturn commentStamp: ''!
I am an error that indicates the callback cannot return because the session where it was created it does not exist anymore.
The image has been saved and continue in a new session. The callback cannot return.!
!TFLongTestStruct commentStamp: ''!
I am a test structure fill with longs!
!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
c
	"This method was automatically generated"
	^handle doubleAt: OFFSET_C! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
d: anObject
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_D put: anObject! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
b: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_B put: anObject! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
a
	"This method was automatically generated"
	^(FFITypeArray ofType: #FFICharacterType size: 100) fromHandle: (handle copyFrom: OFFSET_A to: OFFSET_A + 99)! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
e
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_E! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
e: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_E put: anObject! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
f: anObject
	"This method was automatically generated"
	handle signedShortAt: OFFSET_F put: anObject! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
d
	"This method was automatically generated"
	^handle platformLongAt: OFFSET_D! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
a: anObject
	"This method was automatically generated"
	handle replaceFrom: OFFSET_A to: OFFSET_A + 99 with: anObject getHandle startingAt: 1! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
b
	"This method was automatically generated"
	^handle floatAt: OFFSET_B! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
f
	"This method was automatically generated"
	^handle signedShortAt: OFFSET_F! !

!TFLongTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
c: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_C put: anObject! !

!TFLongTestStruct class methodsFor: 'class initialization' stamp: ''!
initialize
	Char100 := FFITypeArray ofType: 'char' size: 100! !

!TFLongTestStruct class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	
	"self rebuildFieldAccessors"
	
	^ #(
	Char100 a;
	float b;
	double c;
	long d;
	int e;
	short f;
	)! !

!TFMainThreadRunner commentStamp: ''!
I run the callouts and callbacks in the main thread of the process.
It can be or not the VM thread. It depends how the VM has been started.!
!TFMainThreadRunner methodsFor: 'private' stamp: ''!
primitivePerformWorkerCall: aTFExternalFunction withArguments: argumentHolder withReturnHolder: aReturnHolder usingSemaphore: anInteger 
	
	<primitive: 'primitivePerformWorkerCall'>

	^ self primitiveFailed ! !

!TFMainThreadRunner methodsFor: 'private' stamp: ''!
workerAddress

	^ (ExternalAddress loadSymbol: 'mainThreadWorker') pointerAt: 1! !

!TFMainThreadRunner methodsFor: 'private' stamp: ''!
doInitialize
	
	super doInitialize.
	MainThreadHandle := self workerAddress.
	handle := MainThreadHandle! !

!TFMainThreadRunner methodsFor: 'executing' stamp: ''!
executeFunction: aTFExternalFunction withArguments: arguments usingSemaphore: anInteger 
	<primitive: 'primitiveWorkerCallout' error: ec>
	
	self primitiveFailed ! !

!TFMainThreadRunner methodsFor: 'executing' stamp: ''!
readReturnValueFromTask: anExternalAddress
	<primitive: 'primitiveWorkerExtractReturnValue' error: ec>

	self primitiveFailed! !

!TFMainThreadRunner class methodsFor: 'accessing' stamp: ''!
uniqueInstance

	^ uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! !

!TFNestedTestStruct commentStamp: ''!
I am an struct with another inside.!
!TFNestedTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
inner: anObject
	"This method was automatically generated"
	handle structAt: OFFSET_INNER put: anObject getHandle length: TFInnerTestStruct byteSize! !

!TFNestedTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle doubleAt: OFFSET_Y put: anObject! !

!TFNestedTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle floatAt: OFFSET_X! !

!TFNestedTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle floatAt: OFFSET_X put: anObject! !

!TFNestedTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
inner
	"This method was automatically generated"
	^ TFInnerTestStruct fromHandle: (handle referenceStructAt: OFFSET_INNER length: TFInnerTestStruct byteSize)! !

!TFNestedTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle doubleAt: OFFSET_Y! !

!TFNestedTestStruct class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	
	"self rebuildFieldAccessors"
		
	^ #(
	TFInnerTestStruct inner;
	float x;
	double y;
	)! !

!TFOOPType commentStamp: ''!
I know how to handle the case when we want to send a Pharo object to the FFI.
!
!TFOOPType methodsFor: 'marshalling' stamp: ''!
emitMarshallFromPrimitive: anIRBuilder 
	
	anIRBuilder addTemp: #__marshall_temp.
	anIRBuilder storeTemp: #__marshall_temp.
	anIRBuilder popTop.
	anIRBuilder pushLiteral: PointerUtils.
	anIRBuilder pushTemp: #__marshall_temp.
	anIRBuilder send: #objectForOop:! !

!TFOOPType methodsFor: 'marshalling' stamp: ''!
emitMarshallToPrimitive: anIRBuilder 
	
	anIRBuilder addTemp: #__marshall_temp.
	anIRBuilder storeTemp: #__marshall_temp.
	anIRBuilder popTop.
	anIRBuilder pushLiteral: PointerUtils.
	anIRBuilder pushTemp: #__marshall_temp.
	anIRBuilder send: #oopForObjectForcePinInMemory:
	! !

!TFOOPType methodsFor: 'reading-writing' stamp: ''!
readValue: anExternalAddress
	^ self basicType readValue: anExternalAddress! !

!TFPointTestStruct commentStamp: ''!
I am a point like structure used for test!
!TFPointTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_Y put: anObject! !

!TFPointTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
x
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_X! !

!TFPointTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: OFFSET_X put: anObject! !

!TFPointTestStruct methodsFor: 'accessing - structure variables' stamp: ''!
y
	"This method was automatically generated"
	^handle signedLongAt: OFFSET_Y! !

!TFPointTestStruct class methodsFor: 'field definition' stamp: ''!
fieldsDesc
	
	"self rebuildFieldAccessors"
	
	^ #(
		int x
		int y
	)! !

!TFPointerToStructType commentStamp: ''!
I am a pointer to an Struct. I know how to reconstruct the struct from the received pointer and how to extract the pointer.
The pointer maybe is in the heap of Pharo (it is a ByteArray)!
!TFPointerToStructType methodsFor: 'reading-writing' stamp: ''!
callbackReadValue: anExternalAddress

	^ self basicType callbackReadValue: anExternalAddress! !

!TFPointerToStructType methodsFor: 'marshalling' stamp: ''!
emitMarshallFromPrimitive: anIRBuilder 
	
	anIRBuilder addTemp: #__structHandler.
	anIRBuilder storeTemp: #__structHandler.
	anIRBuilder popTop.
	anIRBuilder pushLiteral: targetClass.
	anIRBuilder pushTemp: #__structHandler.
	anIRBuilder send: #fromHandle:
	! !

!TFPointerToStructType methodsFor: 'marshalling' stamp: ''!
emitMarshallToPrimitive: anIRBuilder 
	
	self basicType emitMarshallToPrimitive: anIRBuilder.! !

!TFPointerToStructType methodsFor: 'accessing' stamp: ''!
targetClass: anObject
	targetClass := anObject! !

!TFPointerToStructType methodsFor: 'accessing' stamp: ''!
targetClass
	^ targetClass! !

!TFPointerToStructType methodsFor: 'reading-writing' stamp: ''!
readValue: anExternalAddress
	
	^ self basicType readValue: anExternalAddress! !

!TFPointerType commentStamp: ''!
I represent a pointer type in libffi.
I override the marshalling methods to allow reading/writing C pointers from/to C pointers.

See my superclass for more details.!
!TFPointerType methodsFor: 'writing' stamp: ''!
write: anExternalAddress into: targetAddress

	targetAddress 
		pointerAt: 1 
		put: anExternalAddress tfPointerAddress! !

!TFPointerType methodsFor: 'marshalling' stamp: ''!
emitMarshallToPrimitive: builder
	
	builder send: #tfPointerAddress! !

!TFPointerType methodsFor: 'reading' stamp: ''!
readValue: anExternalAddress offset: offset

	^ anExternalAddress pointerAt: offset! !

!TFPool commentStamp: ''!
I am a generic pool to be used whith TFFI. 
My main usage will be to keep a pool of external semaphores, avoiding the creation/registration/unregistration of an external semaphore each external call.!
!TFPool methodsFor: 'initialization' stamp: ''!
initializeProvider: aBlock size: aNumber releaseBlock: aReleaseBlock

	self initialize.
	provider := aBlock.
	initialSize := aNumber.
	releaseBlock := aReleaseBlock.
	pointer := 1.
	elements := self populate: (Array new: initialSize)! !

!TFPool methodsFor: 'testing' stamp: ''!
isEmpty
	
	^ elements allSatisfy: #isNil! !

!TFPool methodsFor: 'private' stamp: ''!
growBy: aNumber

	elements := elements, (self populate: (Array new: aNumber)).! !

!TFPool methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	mutex := Mutex new! !

!TFPool methodsFor: 'accessing' stamp: ''!
returnOne: anObject

	mutex critical: [ 
		| index |
		index := pointer - 1. 
		index > 0 ifFalse: [ 
			"This can happen if a new session starts in middle of a call."
			'Returning an object but pool is full' crTrace.
			releaseBlock value:anObject. 
			^ self  ]. 
		elements at: index put: anObject.
		pointer := index ]! !

!TFPool methodsFor: 'private' stamp: ''!
populate: anArray

	1 to: anArray size do: [ :index |
		anArray at: index put: provider value ].
	
	^ anArray! !

!TFPool methodsFor: 'accessing' stamp: ''!
elements

	^ elements copy! !

!TFPool methodsFor: 'accessing' stamp: ''!
growRate
 
	^ initialSize // 2! !

!TFPool methodsFor: 'printing' stamp: ''!
printOn: stream

	super printOn: stream.
	stream 
		nextPut: $( ; 
		print: self size  ; 
		nextPutAll: ' elements)'! !

!TFPool methodsFor: 'accessing' stamp: ''!
size

	^ elements size! !

!TFPool methodsFor: 'initialization' stamp: ''!
release

	super release.

	releaseBlock ifNotNil: [ elements do: releaseBlock ].
	elements := nil.
! !

!TFPool methodsFor: 'testing' stamp: ''!
isOverflown

	^ pointer > elements size! !

!TFPool methodsFor: 'accessing' stamp: ''!
takeOne
	| element |

	^ mutex critical: [ 
		| index |
		
		self isOverflown
			ifTrue: [ self growBy: self growRate ].
		
		index := pointer.
		pointer := pointer + 1.
		element := elements at: index.
		elements at: index put: nil.
		element ]! !

!TFPool class methodsFor: 'instance creation' stamp: ''!
newProvider: aBlock size: aNumber releaseBlock: aReleaseBlock

	^ self basicNew 
		initializeProvider: aBlock size: aNumber releaseBlock: aReleaseBlock;
		yourself! !

!TFPoolTest methodsFor: 'tests' stamp: ''!
testTakeOne
	| pool i |
	
	i := 0.
	pool := TFPool newProvider: [ i := i + 1 ] size: 2 releaseBlock: [:x | ].
	
	self assert: pool takeOne equals: 1.
	self assert: pool takeOne equals: 2.
	self assert: pool takeOne equals: 3
! !

!TFPoolTest methodsFor: 'tests' stamp: ''!
testGrowBy
	| pool |
	
	pool := TFPool newProvider: [ 1 ] size: 5 releaseBlock: [:x | ].
	
	5 timesRepeat: [ pool takeOne ].
	self assert: pool size equals: 5.
	pool takeOne. 
	self assert: pool size equals: 7.! !

!TFPoolTest methodsFor: 'tests' stamp: ''!
testReturnOne
	| pool |
	
	pool := TFPool newProvider: [ 1 ] size: 2 releaseBlock: [:x | ].
	
	pool takeOne; takeOne.
	self assert: pool isEmpty.
	self assert: pool size equals: 2.
	pool returnOne: 42.
	self deny: pool isEmpty.
	self assert: pool takeOne equals: 42.
	self assert: pool size equals: 2! !

!TFPoolTest methodsFor: 'tests' stamp: ''!
testPopulate
	| pool |
	
	pool := TFPool newProvider: [ 1 ] size: 5 releaseBlock: [:x | ].
	
	self assert: pool elements equals: #(1 1 1 1 1).
	pool growBy: 5.
	self assert: pool elements equals: #(1 1 1 1 1 1 1 1 1 1).! !

!TFPooledExternalAsyncCall commentStamp: ''!
I am a callout who uses the external semaphore pool you can find in each runner.
Intead creating and registering a semaphore each time, I take one from the ones available in the pool.
I return the semaphore to the list as soon as I will not use it anymore.!
!TFPooledExternalAsyncCall methodsFor: 'initialization' stamp: ''!
initialize
! !

!TFPooledExternalAsyncCall methodsFor: 'private - semaphore' stamp: ''!
registerSemaphore! !

!TFPooledExternalAsyncCall methodsFor: 'accessing' stamp: ''!
semaphoreIndex

	^ semaphore index! !

!TFPooledExternalAsyncCall methodsFor: 'accessing' stamp: ''!
semaphore

	^ semaphore semaphore! !

!TFPooledExternalAsyncCall methodsFor: 'operations' stamp: ''!
executeOn: aRunner
	"Performs a callout using the asynchronous threaded FFI plugin.
	 This method schedules the execution of a function in the threaded FFI plugin and 
	 then waits for its result in a semaphore.
	 When the semaphore is signaled, the result is available in an external value holder
	 from where the value is read.
	 This method contains some boilerplate code to allocate and release external 
	 value holders for the arguments and the return value."
	
	^ [
			semaphore := aRunner semaphorePool takeOne.
			self prepareExecution.
			self doExecuteOn: aRunner ]
		ensure: [
			self cleanUp.
			semaphore ifNotNil: [  
				semaphore reset.
				aRunner semaphorePool returnOne: semaphore] ]! !

!TFPooledExternalAsyncCall methodsFor: 'accessing' stamp: ''!
reset

	self semaphore signalAll! !

!TFPooledExternalAsyncCall methodsFor: 'private - semaphore' stamp: ''!
deregisterSemaphore! !

!TFProcessLocalWorker commentStamp: ''!
This worker executes the function within the worker defined in a `ProcessLocalVariable`, allowing the user to execute the same function in two different native threads (this is very useful for executing functions that wait for some signal to return, e.g. reading from a socket or a piped file descriptor).

It is important to define a `TFProcessLocalWorker>>defaultWorker` (even if by default it will take the `TFSameThreadRunner`.

Example: 

You define it like this: 
```
MyLibrary>>runner 

	^ TFProcessLocalWorker new
		defaultWorker: super runner;
		yourself
```

Then you can execute a function like this: 
```
worker := TFWorker named: 'QUEUE'.
[
	TFProcessLocalWorker worker: worker.
	channel readLineFromSocketInSeparatedWorker.
]
!
!TFProcessLocalWorker methodsFor: 'private' stamp: ''!
primitivePerformWorkerCall: aTFExternalFunction
		withArguments: argumentHolder
		withReturnHolder: aReturnHolder
		usingSemaphore: anInteger
		
	self error: 'Should not arrive here'! !

!TFProcessLocalWorker methodsFor: 'accessing' stamp: ''!
defaultWorker: aWorker

	defaultWorker := aWorker! !

!TFProcessLocalWorker methodsFor: 'accessing' stamp: ''!
defaultWorker

	^ defaultWorker ifNil: [ TFSameThreadRunner uniqueInstance ]! !

!TFProcessLocalWorker methodsFor: 'executing' stamp: ''!
invokeFunction: aTFExternalFunction withArguments: aCollection 

	^ self worker
		invokeFunction: aTFExternalFunction 
		withArguments: aCollection ! !

!TFProcessLocalWorker methodsFor: 'executing' stamp: ''!
worker
		
	^ self class worker ifNil: [ self defaultWorker ]! !

!TFProcessLocalWorker class methodsFor: 'initialization' stamp: ''!
initialize
	
	worker := ProcessLocalVariable new! !

!TFProcessLocalWorker class methodsFor: 'accessing' stamp: ''!
worker: aWorker

	worker value: aWorker! !

!TFProcessLocalWorker class methodsFor: 'accessing' stamp: ''!
worker

	^ worker value! !

!TFRunner commentStamp: ''!
When executing a callout or a callback the invocation pass all through a runner.
There are different kinds of runners.
Each has different policies to run the FFI calls and callbacks.!
!TFRunner methodsFor: 'private' stamp: ''!
primitivePerformWorkerCall: aTFExternalFunction
		withArguments: argumentHolder
		withReturnHolder: aReturnHolder
		usingSemaphore: anInteger
		
	^ self subclassResponsibility! !

!TFRunner methodsFor: 'errors' stamp: ''!
cannotReturnCallbackInWrongOrder: aCallbackInvocation

	^ TFIncorrectOrderCallbackReturn new
		callbackInvocation: aCallbackInvocation;
		previousCallbacks: (callbackInvocationStack copyUpTo: aCallbackInvocation);
		signal! !

!TFRunner methodsFor: 'private' stamp: ''!
newSemaphorePool

	^ TFPool
		newProvider: (MessageSend receiver: TFExternalSemaphore selector: #new) 
		size: self semaphorePoolSize
		releaseBlock: #release "This is ugly... but do not change it to a block, if you change it to a block it will have a reference to self. Creating a loop in the references and leaking memory"! !

!TFRunner methodsFor: 'accessing' stamp: ''!
semaphorePoolSize

	^ 5! !

!TFRunner methodsFor: 'executing' stamp: ''!
doInitialize

	callbackInvocationStack := Stack new.
	stackProtect := Semaphore forMutualExclusion.
	semaphorePool ifNotNil: [ semaphorePool release ].
	semaphorePool := self newSemaphorePool! !

!TFRunner methodsFor: 'errors' stamp: ''!
exceptionHandler

	^ exceptionHandler ifNil: [ 
		exceptionHandler := TFForkCallbackExceptionHandler new ]! !

!TFRunner methodsFor: 'accessing' stamp: ''!
semaphorePool
	
	self ensureInitialized.
	^ semaphorePool! !

!TFRunner methodsFor: 'executing' stamp: ''!
ensureInitialized
	"Only initialize if the image has been restarted and thus I have no handle"
	self isNull ifTrue: [ self doInitialize ]! !

!TFRunner methodsFor: 'executing' stamp: ''!
invokeFunction: aTFExternalFunction withArguments: aCollection

	^ (TFPooledExternalAsyncCall forFunction: aTFExternalFunction)
		parameters: aCollection;
		executeOn: self! !

!TFRunner methodsFor: 'errors' stamp: ''!
exceptionHandler: anExceptionHandler 
	
	exceptionHandler := anExceptionHandler! !

!TFRunner methodsFor: 'errors' stamp: ''!
handleExceptionDuring: aBlock

	self exceptionHandler handleExceptionDuring: aBlock! !

!TFRunner methodsFor: 'executing' stamp: ''!
release 
	
	semaphorePool ifNotNil: [ 
		semaphorePool release.
		semaphorePool := nil ].
	
	handle beNull.
	"If the stack is not initialized it means this worker was never used for callbacks"
	stackProtect ifNil: [ ^ self ].
	stackProtect critical: [
		callbackInvocationStack := nil ]! !

!TFRunner methodsFor: 'errors' stamp: ''!
cannotReturnCallbackFromOldSession: aCallbackInvocation

	^ TFInvalidSessionCallbackReturn new
		callbackInvocation: aCallbackInvocation;
		signal! !

!TFRunner methodsFor: 'executing' stamp: ''!
executeCallback: aCallbackInvocation
	"Entry point to execute a callback invocation.
	Runs the callback in a separate green thread and stack it.
	The stack gives information about the order in which callbacks should return.
	If a callback does not return in the right order, an exception is thrown.
	
	To guarantee the stack is not modified while this method runs, this method should be called from a high priority process.
	  => no callbacks should finish while this method runs."

	stackProtect critical: [ callbackInvocationStack push: aCallbackInvocation ].
	aCallbackInvocation callback runStrategy executeCallback: aCallbackInvocation on: self.
! !

!TFRunner methodsFor: 'executing' stamp: ''!
returnCallback: aCallbackInvocation
	"Entry point to return a callback invocation.
	Check the callbackInvocation stack to see if the given invocation is the last one.
	If so, it can return safely.
	Otherwise, throw an exception as returning means a bug in your application.
	The user must guarantee callbacks return in the correct order"

	callbackReturnSemaphore ifNil: [ 
		callbackReturnSemaphore := Semaphore new ].

	aCallbackInvocation isNull 
		ifTrue: [ ^ self ].

	callbackInvocationStack isEmptyOrNil ifTrue: [ 
		^ self cannotReturnCallbackFromOldSession: aCallbackInvocation].

	stackProtect critical: [
		(callbackInvocationStack top == aCallbackInvocation) 
			ifTrue: [
				aCallbackInvocation returnExecution
					ifTrue: [
						"If we are starting a session and an execution was executed, it 
						 may happen that the stack is empty."
						callbackInvocationStack ifEmpty: [ ^ self ].
						callbackInvocationStack pop.
						[ callbackReturnSemaphore signalAll ] valueUnpreemptively.
						^ self ]] ].
	"failed"
	callbackReturnSemaphore wait.
	self returnCallback: aCallbackInvocation! !

!TFRunner methodsFor: 'executing' stamp: ''!
invokeFunction: aTFExternalFunction 
	
	^ self invokeFunction: aTFExternalFunction withArguments: #()! !

!TFSameThreadCall commentStamp: ''!
I implement a Callout for the TFSameThreadRunner!
!TFSameThreadCall methodsFor: 'executing' stamp: ''!
executeOn: runner withArguments: aCollection

	function validate.	
	^ self invokeFunction: function withArguments: aCollection
	! !

!TFSameThreadCall methodsFor: 'accessing' stamp: ''!
parameters: aCollection 
	self shouldBeImplemented.! !

!TFSameThreadCall methodsFor: 'accessing' stamp: ''!
function
	^ function! !

!TFSameThreadCall methodsFor: 'toto' stamp: ''!
invokeFunction: aTFExternalFunction withArguments: aCollection
	
	<primitive: 'primitiveSameThreadCallout' error: ec>

	self primitiveFailed ! !

!TFSameThreadCall methodsFor: 'accessing' stamp: ''!
function: anObject
	function := anObject! !

!TFSameThreadCall class methodsFor: 'instance creation' stamp: ''!
forFunction: aTFExternalFunction 
	
	^ self new
		function: aTFExternalFunction;
		yourself! !

!TFSameThreadRunner commentStamp: ''!
I run the callouts in the same thread of the VM.
This runner blocks the current execution of the VM to run the callout.!
!TFSameThreadRunner methodsFor: 'private' stamp: ''!
primitivePerformWorkerCall: aTFExternalFunction withArguments: argumentHolder withReturnHolder: aReturnHolder usingSemaphore: anInteger 

	<primitive: 'primitiveSameThreadCallout'>

	self primitiveFailed 	! !

!TFSameThreadRunner methodsFor: 'executing' stamp: ''!
doInitialize

	super doInitialize.
	handle := self primitiveGetRunnerAddress.! !

!TFSameThreadRunner methodsFor: 'executing' stamp: ''!
invokeFunction: aTFExternalFunction withArguments: aCollection 

	^ (	TFSameThreadCall forFunction: aTFExternalFunction) executeOn: self withArguments: aCollection! !

!TFSameThreadRunner methodsFor: 'private' stamp: ''!
primitiveGetRunnerAddress

	<primitive: 'primitiveGetSameThreadRunnerAddress'>

	self primitiveFailed 	! !

!TFSameThreadRunner class methodsFor: 'accessing' stamp: ''!
uniqueInstance

	^ uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! !

!TFStringType commentStamp: ''!
I represent a String type in uffi that gets marshalled to a pointer type in libffi.
I override the marshalling methods to allow reading/writing strings from/to C pointers.

See my superclass for more details.!
!TFStringType methodsFor: 'writing' stamp: ''!
write: aStringOrExternalAddress into: targetAddress

	"If the argument is a aString I have to allocate it and later free it"
	| anAddress |
	anAddress := self prepareStringForMarshalling: aStringOrExternalAddress.
	
	self basicType
		write: anAddress
		into: targetAddress! !

!TFStringType methodsFor: 'writing' stamp: ''!
callbackReadValue: anExternalAddress

	^ (self readValue: anExternalAddress) readStringUTF8! !

!TFStringType methodsFor: 'marshalling' stamp: ''!
emitMarshallFromPrimitive: anIRBuilder 

	anIRBuilder send: #readStringUTF8! !

!TFStringType methodsFor: 'marshalling' stamp: ''!
emitFreeIfNeededOfIndex: argIndex argumentsArrayTempName: argumentsArrayTempName withBuilder: anIRBuilder

	"I will send the message #freeValueIfNeeded: to myself with the argument from the argumentArray at the position passed as parameter.
	It is important that I do not leave nothing in the stack"

	anIRBuilder pushLiteral: self.
	anIRBuilder pushTemp: argumentsArrayTempName.
	anIRBuilder pushLiteral: argIndex.
	anIRBuilder send: #at:.
	anIRBuilder send: #freeValueIfNeeded:.
	anIRBuilder popTop! !

!TFStringType methodsFor: 'marshalling' stamp: ''!
emitMarshallToPrimitive: anIRBuilder 

	anIRBuilder addTemp: #__marshall_temp.
	anIRBuilder storeTemp: #__marshall_temp.
	anIRBuilder popTop.
	anIRBuilder pushLiteral: self.
	anIRBuilder pushTemp: #__marshall_temp.
	anIRBuilder send: #prepareStringForMarshalling:
! !

!TFStringType methodsFor: 'writing' stamp: ''!
prepareStringForMarshalling: aStringOrExternalAddress

	"The TFString type supports four possible parameters.
	
	- A String: this is allocated as an external string, encoded and passed the pointer to the allocated space. 
	- A ByteArray: this will be passed as a pointer to the external call. It should be pinned and dereferenced to get the address.
	- An ExternalAddress: this is directly passed to the external call.
	- nil: An ExternalAddress null is passed in this case "
	
	"Maybe this code should be implemented delegating to the objects to handle the different cases"

	"Handling Strings"
	aStringOrExternalAddress isString
		ifTrue: [ ^ self allocateString: aStringOrExternalAddress ].
	
	"Handling nil"	
		aStringOrExternalAddress 
			ifNil: [ ^ ExternalAddress null ].

	"Handling ExternalAddress"
		aStringOrExternalAddress isExternalAddress
			ifTrue: [ ^ aStringOrExternalAddress ].
	
	"Handling ByteArray - We have to first check for ExternalAddress, as ExternalAddress are ByteArray"
		(aStringOrExternalAddress isKindOf: ByteArray) 
			ifTrue: [ aStringOrExternalAddress pinInMemory.
            ^ PointerUtils oopForObject: aStringOrExternalAddress ].
	
	"Handling ExternalAddress"
		^ self error: 'Could not handle this object'! !

!TFStringType methodsFor: 'marshalling' stamp: ''!
marshallToPrimitive: aValue
	
	^ self prepareStringForMarshalling: aValue
	! !

!TFStringType methodsFor: 'writing' stamp: ''!
freeValueIfNeeded: aCHeapValueHolder
	| pointer |

	aCHeapValueHolder isNull ifTrue: [ ^ self ].
	pointer := aCHeapValueHolder pointerAt: 1.
	(self allocatedStrings includes: pointer) ifFalse: [ ^ self ].
	self allocatedStrings remove: pointer.
	pointer isNull ifFalse: [ 
		pointer free ]! !

!TFStringType methodsFor: 'accessing' stamp: ''!
allocatedStrings

	^ AllocatedStrings ifNil: [ AllocatedStrings := Set new ]! !

!TFStringType methodsFor: 'writing' stamp: ''!
allocateString: aString
	| anExternalAddress |
	
	anExternalAddress := (ExternalAddress fromString: aString utf8Encoded).
	self allocatedStrings add: anExternalAddress.
	^ anExternalAddress ! !

!TFStringType methodsFor: 'writing' stamp: ''!
readValue: anExternalAddress

	^ self basicType readValue: anExternalAddress! !

!TFStructTest methodsFor: 'tests' stamp: ''!
testLongStructSize
	| pointType |
	pointType := TFStructType
		forClass: TFLongTestStruct
		withMembers:
			(Array new: 100 withAll: TFBasicType schar)
				,	{TFBasicType float.
					TFBasicType double.
					TFBasicType slong.
					TFBasicType sint.
					TFBasicType sshort}.
	self assert: pointType byteSize equals: self longStructSize.
	self assert: TFLongTestStruct byteSize equals: self longStructSize! !

!TFStructTest methodsFor: 'tests' stamp: ''!
testReturnsAnStruct
	| pointType fun aPoint |
	
	pointType := TFStructType 
		forClass: TFPointTestStruct 
		withMembers: { 
			TFBasicType sint. 
			TFBasicType sint }.
	
	fun := TFExternalFunction
		name: 'newPoint' moduleName: self libraryPath
		parameterTypes:	{TFBasicType sint. TFBasicType sint}
		returnType: pointType.
		
	aPoint := TFPointTestStruct fromHandle: (runner invokeFunction: fun withArguments: #(1 5)).

	self assert: aPoint x equals: 1.
	self assert: aPoint y equals: 5.	! !

!TFStructTest methodsFor: 'tests' stamp: ''!
longStructSize 

	^ TFWorker default
		invokeFunction:
			(TFExternalFunction
				name: 'sizeOfLongStruct'
				moduleName: self libraryPath
				definition:
					(TFFunctionDefinition parameterTypes: {} returnType: TFBasicType uint))
		withArguments: #()
! !

!TFStructTest methodsFor: 'tests' stamp: ''!
testPointStructSize

	| pointType |
	pointType := TFStructType forClass: TFPointTestStruct withMembers: { TFBasicType sint. TFBasicType sint. }.
	
	self assert: pointType byteSize equals: self pointSize.
	self assert: pointType byteSize equals: TFPointTestStruct byteSize.
	! !

!TFStructTest methodsFor: 'tests' stamp: ''!
pointSize

	^ self runner
		invokeFunction:
			(TFExternalFunction
				name: 'sizeOfPoint'
				moduleName: self libraryPath
				definition:
					(TFFunctionDefinition parameterTypes: {} returnType: TFBasicType uint))
		withArguments: #()! !

!TFStructType commentStamp: ''!
I know how to handle the marshalling and unmarshalling of structs.!
!TFStructType methodsFor: 'primitives' stamp: ''!
free
	<primitive: 'primitiveFreeStruct'>

	^ self primitiveFailed	! !

!TFStructType methodsFor: 'writing' stamp: ''!
callbackWrite: aNumber into: anExternalAddress

	self write: aNumber getHandle into: anExternalAddress! !

!TFStructType methodsFor: 'primitives' stamp: ''!
primitiveByteSize
	<primitive: 'primitiveStructByteSize'>

	^ self primitiveFailed	! !

!TFStructType methodsFor: 'reading' stamp: ''!
callbackReadValue: anExternalAddress

	^ targetClass fromHandle: anExternalAddress.! !

!TFStructType methodsFor: 'marshalling' stamp: ''!
emitMarshallFromPrimitive: anIRBuilder 
	
	anIRBuilder addTemp: #__structHandler.
	anIRBuilder storeTemp: #__structHandler.
	anIRBuilder popTop.
	anIRBuilder pushLiteral: targetClass.
	anIRBuilder pushTemp: #__structHandler.
	anIRBuilder send: #fromHandle:
	! !

!TFStructType methodsFor: 'marshalling' stamp: ''!
emitFreeIfNeededOfIndex: anInteger argumentsArrayTempName: aString withBuilder: anIRBuilder 
! !

!TFStructType methodsFor: 'marshalling' stamp: ''!
emitMarshallToPrimitive: anIRBuilder 

	anIRBuilder send: #getHandle! !

!TFStructType methodsFor: 'testing' stamp: ''!
isVoid
	^ false! !

!TFStructType methodsFor: 'marshalling' stamp: ''!
marshallFromPrimitive: aValue
	
	(aValue isKindOf: targetClass) 
		ifTrue: [ ^ aValue ].

	^ targetClass fromHandle: aValue! !

!TFStructType methodsFor: 'accessing' stamp: ''!
members: anObject
	members := anObject! !

!TFStructType methodsFor: 'reading' stamp: ''!
readReturnValue: anExternalAddress
	
	| newHandle |
	newHandle := ByteArray new: self byteSize.
	self copyFrom: anExternalAddress to: newHandle size: self byteSize.
	^ newHandle! !

!TFStructType methodsFor: 'accessing' stamp: ''!
targetClass: anObject
	targetClass := anObject! !

!TFStructType methodsFor: 'size' stamp: ''!
byteSize 
	
	self validate.
	^ byteSize ifNil: [ self primitiveByteSize ]! !

!TFStructType methodsFor: 'utilities' stamp: ''!
copyFrom: from to: to size: size 
	"Copy from the from an externalAdress or a ByteArray or to a ByteArray or an External Address"

	<primitive: 'primitiveCopyFromTo'>
	self primitiveFail ! !

!TFStructType methodsFor: 'validating' stamp: ''!
validate
	self isValid
		ifTrue: [ ^ self ].

	members do: [ :m | m validate ].
	offsets := Array new: members size.
	
	self primitiveInitializeStructType.
	
	byteSize := self primitiveByteSize	! !

!TFStructType methodsFor: 'writing' stamp: ''!
write: anExternalStructure into: anExternalAddress

	self copyFrom: anExternalStructure to: anExternalAddress size: self byteSize! !

!TFStructType methodsFor: 'reading' stamp: ''!
readValue: anExternalAddress offset: offset 

	| address |

	address := anExternalAddress pointerAt: offset.
	^ targetClass fromHandle: address.! !

!TFStructType methodsFor: 'accessing' stamp: ''!
members
	^ members! !

!TFStructType methodsFor: 'accessing' stamp: ''!
targetClass
	^ targetClass! !

!TFStructType methodsFor: 'marshalling' stamp: ''!
marshallToPrimitive: aValue 

	^ aValue getHandle! !

!TFStructType methodsFor: 'accessing' stamp: ''!
offsets
	self validate.
	
	^ offsets! !

!TFStructType methodsFor: 'utilities' stamp: ''!
freeValueIfNeeded: anExternalAddress 
	
	"Nothing to free"! !

!TFStructType methodsFor: 'primitives' stamp: ''!
primitiveInitializeStructType
	<primitive: 'primitiveInitializeStructType'>

	^ self primitiveFailed	! !

!TFStructType methodsFor: 'types' stamp: ''!
basicType

	^ self! !

!TFStructType class methodsFor: 'instance creation' stamp: ''!
forClass: aClass withMembers: aCollectionOfMembers
	
	^ self new
		members: aCollectionOfMembers asArray;
		targetClass: aClass;
		autoRelease;
		yourself! !

!TFStructType class methodsFor: 'instance creation' stamp: ''!
finalizeResourceData: handle

	handle isNull ifTrue: [ ^ self ].

	(self fromHandle: handle)
		free.
		
	handle beNull.! !

!TFTestCallbackExceptionHandler commentStamp: ''!
I am a test callback exception handler.
I keep the exception so it can be asserted in the test.!
!TFTestCallbackExceptionHandler methodsFor: 'handling' stamp: ''!
wait

	available wait! !

!TFTestCallbackExceptionHandler methodsFor: 'accessing' stamp: ''!
lastException

	^ lastException! !

!TFTestCallbackExceptionHandler methodsFor: 'handling' stamp: ''!
initialize

	super initialize.
	available := Semaphore new.! !

!TFTestCallbackExceptionHandler methodsFor: 'handling' stamp: ''!
handleExceptionDuring: aBlockClosure 
	
	aBlockClosure on: Exception do: [ :e |
		lastException := e freeze.
		available signal ]! !

!TFTestCase methodsFor: 'accessing' stamp: ''!
libraryPath

	Smalltalk os isUnix ifTrue: [ ^ 'libTestLibrary.so' ].
	Smalltalk os isMacOS ifTrue: [ ^ 'libTestLibrary.dylib' ].
	Smalltalk os isWindows ifTrue: [ ^ 'TestLibrary.dll' ].

	self error: 'Unsupported Platform'! !

!TFTestCase methodsFor: 'accessing' stamp: ''!
runner: anObject
	runner := anObject! !

!TFTestCase methodsFor: 'running' stamp: ''!
runCaseManaged 
	
	"Skipping in running on an old VM"
	TFFIBackend isAvailable ifFalse: [ ^ self skip ].
	
	super runCaseManaged.! !

!TFTestCase methodsFor: 'accessing' stamp: ''!
runner
	^ runner! !

!TFTestCase methodsFor: 'tests' stamp: ''!
shortCallout
	| fun |
	fun := TFExternalFunction
		name: 'shortCallout'
		moduleName: self libraryPath
		definition:
			(TFFunctionDefinition
				parameterTypes: {}
				returnType: TFBasicType sint32).

	^ runner invokeFunction: fun ! !

!TFTestCase class methodsFor: 'building suites' stamp: ''!
testParameters 

	^ ParametrizedTestMatrix new
		forSelector: #runner addOptions: { [ TFSameThreadRunner uniqueInstance ]. [ TFWorker named: 'fortest' ]. }! !

!TFTestLibraryUsingSameThreadRunner commentStamp: ''!
I am a test library using the SameThread runner!
!TFTestLibraryUsingSameThreadRunner methodsFor: 'accessing - platform' stamp: ''!
unixModuleName

	^ 'libTestLibrary.so'! !

!TFTestLibraryUsingSameThreadRunner methodsFor: 'accessing - platform' stamp: ''!
win32LibraryName
 
	^ 'TestLibrary.dll'! !

!TFTestLibraryUsingSameThreadRunner methodsFor: 'accessing - platform' stamp: ''!
calloutAPIClass

	^ TFCalloutAPI ! !

!TFTestLibraryUsingSameThreadRunner methodsFor: 'accessing - platform' stamp: ''!
macLibraryName 

	^ 'libTestLibrary.dylib'! !

!TFTestLibraryUsingWorker commentStamp: ''!
I am a test library using a worker runner!
!TFTestLibraryUsingWorker methodsFor: 'accessing' stamp: ''!
runner 
	
	^ TFWorker default! !

!TFUFFIAbstractCallback commentStamp: ''!
I am an abstract callback using TFFI. Used by tests!
!TFUFFIAbstractCallback methodsFor: 'accessing' stamp: ''!
calloutAPIClass

	^ TFCalloutAPI ! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testFloat

	| received |
	received := self call: 'float' value: 2.7.
	self assert: (received between: 2.6999 and: 2.7001)! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedInt

	self assertSignedIntType: 'int'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedLong

	self assertSignedIntType: 'long'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedShort

	self assertSignedIntType: 'short'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedInt64

	self assertSignedIntType: 'int64'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedInt16

	self assertUnsignedIntType: 'uint16'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedLong

	self assertUnsignedIntType: 'ulong'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedInt32

	self assertUnsignedIntType: 'uint32'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testPointer

	| bytes received |
	[
	bytes := ExternalAddress allocate: 2 "bytes".
	received := self call: 'pointer' type: #(void* name) value: bytes.
	self assert: received getHandle equals: bytes getHandle
	] ensure: [ bytes free ]! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedInt8

	self assertUnsignedIntType: 'uint8'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedInt16

	self assertSignedIntType: 'int16'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedInt32

	self assertSignedIntType: 'int32'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testChar

	self assertCharType: 'char'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testSignedInt8

	self assertSignedIntType: 'int8'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testDouble

	| received |
	received := self call: 'double' value: 2.7.
	self assert: received equals: 2.7! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedInt

	self assertUnsignedIntType: 'uint'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedShort

	self assertUnsignedIntType: 'ushort'! !

!TFUFFIBasicTypeMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
testUnsignedInt64

	self assertUnsignedIntType: 'uint64'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_uint64_t:a with: b
	^ self ffiCall: #(uint64 sum_uint64_t(uint64 a, uint64 b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedInt64

	self assertSignedIntsWithFunction: 'sum_int64_t'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedInt8

	self assertSignedIntsWithFunction: 'sum_int8_t'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_char:a with: b
	^ self ffiCall: #(char sum_char(char a, char b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_uint:a with: b
	^ self ffiCall: #(uint sum_uint(uint a, uint b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedInt16

	self assertUnsignedIntsWithFunction: 'sum_uint16_t'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_float:a with: b
	^ self ffiCall: #(float sum_float(float a, float b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedLong

	self assertSignedIntsWithFunction: 'sum_long'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_uint8_t:a with: b
	^ self ffiCall: #(uint8 sum_uint8_t(uint8 a, uint8 b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_uint16_t:a with: b
	^ self ffiCall: #(uint16 sum_uint16_t(uint16 a, uint16 b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_int64_t:a with: b
	^ self ffiCall: #(int64 sum_int64_t(int64 a, int64 b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testUnrefPointer

	| holder pointerToHolder return |
	holder := ExternalAddress allocate: TFBasicType sshort byteSize.
	TFBasicType sshort write: 17 into: holder.
	
	pointerToHolder := ExternalAddress allocate: TFBasicType pointer byteSize.
	TFBasicType pointer write: holder into: pointerToHolder.
	
	return := self unrefPointer: pointerToHolder.
	self assert: return equals: holder.
	self assert: (TFBasicType sshort readValue: return) equals: 17.! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedInt32

	self assertSignedIntsWithFunction: 'sum_int32_t'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedInt16

	self assertSignedIntsWithFunction: 'sum_int16_t'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_int:a with: b
	^ self ffiCall: #(int sum_int(int a, int b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedInt8

	self assertUnsignedIntsWithFunction: 'sum_uint8_t'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedShort

	self assertUnsignedIntsWithFunction: 'sum_ushort'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
unrefPointer: aPointer
	^ self ffiCall: #(void *unref_pointer(void *aPointer))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumFloat

	| return |
	return := self sum_float: 3.1 with: 2.7.
	self assert: (return between: 5.79999999 and: 5.80001)! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'accessing' stamp: ''!
externalFunction: name ofType: type

	^ TFExternalFunction
		name: name
		moduleName: self ffiLibrary libraryName
		definition: (TFFunctionDefinition
			parameterTypes: {type. type}
			returnType: type).
! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_int16_t:a with: b
	^ self ffiCall: #(int16 sum_int16_t(int16 a, int16 b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_ushort:a with: b
	^ self ffiCall: #(ushort sum_ushort(ushort a, ushort b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'accessing' stamp: ''!
assertUnsignedIntsWithFunction: functionName

	| return |
	return := self perform: (functionName , ':with:') asSymbol withArguments: { 3 . 2 }.
	self assert: return equals: 5! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_ulong:a with: b
	^ self ffiCall: #(ulong sum_ulong(ulong a, ulong b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_int8_t:a with: b
	^ self ffiCall: #(int8 sum_int8_t(int8 a, int8 b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedChar

	self assertUnsignedIntsWithFunction: 'sum_uchar'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'accessing' stamp: ''!
assertSignedIntsWithFunction: functionName

	| return |
	return := self perform: (functionName , ':with:') asSymbol withArguments: { -3 . 2 }.
	self assert: return equals: -1! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedLong

	self assertUnsignedIntsWithFunction: 'sum_ulong'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_short:a with: b
	^ self ffiCall: #(short sum_short(short a, short b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_uint32_t:a with: b
	^ self ffiCall: #(uint32 sum_uint32_t(uint32 a, uint32 b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedInt

	self assertSignedIntsWithFunction: 'sum_int'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedInt32

	self assertUnsignedIntsWithFunction: 'sum_uint32_t'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_long:a with: b
	^ self ffiCall: #(long sum_long(long a, long b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_double:a with: b
	^ self ffiCall: #(double sum_double(double a, double b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_uchar:a with: b
	^ self ffiCall: #(uchar sum_uchar(uchar a, uchar b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedInt64

	self assertUnsignedIntsWithFunction: 'sum_uint64_t'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedShort

	self assertSignedIntsWithFunction: 'sum_short'! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumDouble

	| return |
	return := self sum_double: 3.1 with: 2.7.
	self assert: (return between: 5.79999999 and: 5.80001)! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_int32_t:a with: b
	^ self ffiCall: #(int32 sum_int32_t(int32 a, int32 b))! !

!TFUFFIBasicTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumUnsignedInt

	self assertUnsignedIntsWithFunction: 'sum_uint'! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_char
	self ffiCall: #(size_t sizeof_char())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_uintenum
	self ffiCall: #(size_t sizeof_uintenum())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_short
	self ffiCall: #(size_t sizeof_short())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_ulong
	self ffiCall: #(size_t sizeof_ulong())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_ushort
	self ffiCall: #(size_t sizeof_ushort())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_uint16_t
	self ffiCall: #(size_t sizeof_uint16_t())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_pointer
	self ffiCall: #(size_t sizeof_pointer())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_uint32_t
	self ffiCall: #(size_t sizeof_uint32_t())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'accessing' stamp: ''!
ffiLibraryName

	^ self libraryPath! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_sintenum
	self ffiCall: #(size_t sizeof_sintenum())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_long
	self ffiCall: #(size_t sizeof_long())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_float
	self ffiCall: #(size_t sizeof_float())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_size_t
	self ffiCall: #(size_t sizeof_size_t())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_int
	self ffiCall: #(size_t sizeof_int())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_ulonglong
	self ffiCall: #(size_t sizeof_ulonglong())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_uint
	self ffiCall: #(size_t sizeof_uint())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_int16_t
	self ffiCall: #(size_t sizeof_int16_t())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_charenum
	self ffiCall: #(size_t sizeof_charenum())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_longlong
	self ffiCall: #(size_t sizeof_longlong())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_uchar
	self ffiCall: #(size_t sizeof_uchar())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_int32_t
	self ffiCall: #(size_t sizeof_int32_t())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_int8_t
	self ffiCall: #(size_t sizeof_int8_t())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_int64_t
	self ffiCall: #(size_t sizeof_int64_t())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_uint8_t
	self ffiCall: #(size_t sizeof_uint8_t())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'accessing' stamp: ''!
assertType: typename equals: aSize

	self assert: (self perform: ('sizeof_', typename) asSymbol) equals: aSize! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_double
	self ffiCall: #(size_t sizeof_double())! !

!TFUFFIBasicTypeSizeTest methodsFor: 'ffi-calls' stamp: ''!
sizeof_uint64_t
	self ffiCall: #(size_t sizeof_uint64_t())! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
sumInt:a andInt: b

	^ self ffiCall: #(int sumTwoNumbers(int a, int b))! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
sumFloat: a andDouble: b

	^ self ffiCall: #(float sumAFloatAndADouble(float a, double b))! !

!TFUFFICallbackTest methodsFor: 'running' stamp: ''!
tearDown
	
	self ffiLibrary uniqueInstance runner exceptionHandler: oldExceptionHandler.
	super tearDown.
! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
callbackFromAnotherThread: callback

	^ self ffiCall: #(void callbackFromAnotherThread(void* callback))! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
testCallbackInLoop

	| callback |

	callback := self
		newCallbackWithSignature: #(int (int a))
		block: [ :a | a + 1 ].

	self assert: (self callbackInALoop: callback) equals: 42
! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
testCallbackInSingleFunctionUsingSubclassOfFFICallback

	| callback |

	callback := TFUFFIIncrementCallback new
		ffiLibrary: self ffiLibrary;
		yourself.

	self assert: (self singleCallToCallback: callback value: 3) equals: 5
! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
testCallbackWithErrorHanlded

	| callback fun definition runner |

	runner := self ffiLibrary uniqueInstance runner.

	callback := TFUFFIFailingCallbackWithDefault new
			ffiLibrary: self ffiLibrary;
			yourself.

	definition := TFFunctionDefinition
		parameterTypes: {TFBasicType sint.}
		returnType: TFBasicType sint.

	fun := TFExternalFunction 
		fromAddress: callback getHandle 
		definition: definition.

	UIManager nonInteractiveDuring: [
		self assert: (runner invokeFunction: fun withArguments: {1}) equals: -1]
! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
getValue

	^ self ffiCall: #(int getValue())! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
testCallbacksInOtherThread

	| callback semaphore|

	"Using same thread runner with callbacks from other threads produce a segmentation fault"
	ffiLibrary = TFTestLibraryUsingSameThreadRunner ifTrue: [ ^ self skip ].

	semaphore := Semaphore new.

	callback := self newCallbackWithSignature: #(int (int a)) block: [ :a | semaphore signal. a + 1 ].
	self callbackFromAnotherThread: callback.
	semaphore wait.
	
	1 second wait.
	self assert: self getValue equals: 43	
! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
returnAnswer

	^ self ffiCall: #(int32 returnAnswer())! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
shortCallout
	
	^ self ffiCall: #(int shortCallout())! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
testCallbackInLoopUsingSubclassOfFFICallback

	| callback |

	callback := TFUFFIIncrementCallback new
		ffiLibrary: self ffiLibrary;
		yourself.

	self assert: (self callbackInALoop: callback) equals: 42
! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
testCallbackInSingleFunction

	| callback |

	callback := self newCallbackWithSignature: #(int (int a)) block: [ :a | a + 1 ].
	self assert: (self singleCallToCallback: callback value: 3) equals: 5
! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
callbackInALoop: callback

	^ self ffiCall: #(int callbackInALoop(void* callback))! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
singleCallToCallback: callback value: value

	^ self ffiCall: #(int singleCallToCallback(void* callback, int value))! !

!TFUFFICallbackTest methodsFor: 'tests' stamp: ''!
testCallbackAsFunction
	| callback fun definition runner |
	
	runner := self ffiLibrary uniqueInstance runner.
	
	callback := self
		newCallbackWithSignature: #(float (int a, float b))
		block: [ :a :b | a + b ].

	definition := TFFunctionDefinition
		parameterTypes: {TFBasicType sint. TFBasicType float.}
		returnType: TFBasicType float.

	fun := TFExternalFunction 
		fromAddress: callback getHandle 
		definition: definition.

	self assert: (runner invokeFunction: fun withArguments: {1. 2.0}) equals: 3.0! !

!TFUFFICallbackTest methodsFor: 'running' stamp: ''!
setUp 
	
	super setUp.
	oldExceptionHandler := self ffiLibrary uniqueInstance runner exceptionHandler.
	self ffiLibrary uniqueInstance runner exceptionHandler: TFTestCallbackExceptionHandler new.! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'tests' stamp: ''!
testMarshallingStringArgument

	self assertType: 'String' value: 'áèïô å∫'! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_Boolean: callback value: aValue

	^ self ffiCall: #(void simple_callback_f_int(void *callback, Boolean aValue))! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_String: callback value: aValue

	^ self ffiCall: #(void simple_callback_f_pointer(void *callback, String aValue))! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_longlong: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_longlong(void *callback, longlong aValue))! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'tests' stamp: ''!
testMarshallingFalseArgument

	self assertType: 'Boolean' value: false! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'tests' stamp: ''!
testSignedLongLong

	self assertType: 'longlong' value: -188! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_size_t: callback value: aValue

	^ self ffiCall: #(void simple_callback_f_size_t(void *callback, size_t aValue))! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'tests' stamp: ''!
testUnsignedLongLong

	self assertType: 'ulonglong' value: 188! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'tests' stamp: ''!
testMarshallingTrueArgument

	self assertType: 'Boolean' value: true! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_ulonglong: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_ulonglong(void *callback, ulonglong aValue))! !

!TFUFFIDerivedTypeMarshallingInCallbackTest methodsFor: 'tests' stamp: ''!
testMarshallingSize_t

	self assertType: 'size_t' value: 17! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
pointerToString: cString

	^ self ffiCall: #(String dup_string(char *cString))! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
pointerToStringWithAlias: cString

	^ self ffiCall: #(String dup_string(gchar *cString))! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
intToBoolean: int

	^ self ffiCall: #(Boolean id_int(int int))! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testUnsignedSumLongLong

	| return |
	return := self sum_longlong: -3 with: 2.
	self assert: return equals: -1! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingFalseArgument

	self assert: (self booleanToInt: false) equals: 0! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testSumSignedLongLong

	| return |
	return := self sum_longlong: 3 with: 2.
	self assert: return equals: 5! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingByteArrayWillPinTheObject
	| aByteArray |
	
	aByteArray := ByteArray new: 10.
	
	self fillByteArray: aByteArray size: aByteArray size.
	
	self assert: aByteArray equals: #[1 2 3 4 5 6 7 8 9 10].
	
	self assert: aByteArray isPinnedInMemory! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
stringToPointer: aString

	^ self ffiCall: #(void *dup_string(String aString))! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingTrueArgument

	self assert: (self booleanToInt: true) equals: 1! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingFalseReturnValue

	self assert: (self intToBoolean: 0) equals: false! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
returnSameByteArray: aByteArray

	^ self ffiCall: #(oop id_pointer(oop aByteArray))! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingSize_t

	self assert: (self size_t_identity: 1788) equals: 1788! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
	super setUp.
	gchar := 'char'! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
booleanToInt: boolean

	^ self ffiCall: #(int id_int(Boolean boolean))! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingTrueReturnValue

	self assert: (self intToBoolean: 17) equals: true! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingStringArgument

	| stringToMarshall cString |
	[
	stringToMarshall := 'áèïô å∫'.
	cString := self stringToPointer: stringToMarshall.
	self assert: cString readStringUTF8 equals: stringToMarshall.
	] ensure: [ cString free ]! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
size_t_identity: aSize

	^ self ffiCall: #(size_t id_size_t(size_t aSize))! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingSmalltalkStringReturnValueWithAlias

	| originalString returnedString |

	originalString := 'áèïô å∫'.
	returnedString := self pointerToStringWithAlias: originalString.
	self assert: returnedString equals: originalString.
! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_longlong:a with: b

	^ self ffiCall: #(longlong sum_longlong(longlong a, longlong b))! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingOOPIsSameObject
	| aByteArray otherByteArray |
	aByteArray := ByteArray new: 2300000.
	aByteArray pinInMemory.
	
	otherByteArray := self returnSameByteArray: aByteArray.
	
	self assert: aByteArray == otherByteArray.
	
	aByteArray unpinInMemory.! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingOOP
	| aByteArray |
	aByteArray := ByteArray new: 10.
	aByteArray pinInMemory.
	
	self fillByteArray: aByteArray size: aByteArray size.
	
	self assert: aByteArray equals: #[1 2 3 4 5 6 7 8 9 10].
	
	aByteArray unpinInMemory.! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingStringReturnValueWithAlias

	| cString originalString returnedString |
	[
	originalString := 'áèïô å∫'.
	cString := ExternalAddress fromString: originalString utf8Encoded asString.
	returnedString := self pointerToStringWithAlias: cString.
	self assert: returnedString equals: originalString.
	] ensure: [ cString free ]! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingByteArrayAsStringArgument

	| stringToMarshall byteArray cString |
	[	stringToMarshall := 'áèïô å∫'.
		byteArray := stringToMarshall utf8Encoded.
		cString := self stringToPointer: byteArray.
		self assert: cString readStringUTF8 equals: stringToMarshall.
	] ensure: [ cString free ]! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'tests' stamp: ''!
testMarshallingStringReturnValue

	| cString originalString returnedString |
	[
	originalString := 'áèïô å∫'.
	cString := ExternalAddress fromString: originalString utf8Encoded asString.
	returnedString := self pointerToString: cString.
	self assert: returnedString equals: originalString.
	] ensure: [ cString free ]! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
sum_ulonglong:a with: b

	^ self ffiCall: #(ulonglong sum_ulonglong(ulonglong a, ulonglong b))! !

!TFUFFIDerivedTypeMarshallingTest methodsFor: 'ffi-calls' stamp: ''!
fillByteArray: aByteArray size: size

	^ self ffiCall: #(void fillByteArray(oop aByteArray, int size))! !

!TFUFFIDerivedTypeSizeTest methodsFor: 'helpers' stamp: ''!
assertType: typename equals: aSize

	self assert: (self perform: ('sizeof_', typename) asSymbol) equals: aSize! !

!TFUFFIDerivedTypeSizeTest methodsFor: 'helpers' stamp: ''!
sizeof_size_t
	self ffiCall: #(size_t sizeof_size_t())! !

!TFUFFIDerivedTypeSizeTest methodsFor: 'helpers' stamp: ''!
testSizeSizeT

	self assertType: 'size_t' equals: Smalltalk wordSize! !

!TFUFFIDifferentCallingConventionFunctionCallTest methodsFor: 'private' stamp: ''!
ffiCallingConvention 

	^ #win64! !

!TFUFFIDifferentCallingConventionFunctionCallTest methodsFor: 'tests' stamp: ''!
calloutWithManyArguments: arg1 and: arg2 and: arg3 and: arg4 and: arg5 and: arg6 and: arg7 and: arg8 and: arg9 and: arg10
	^ self
		ffiCall:
			#(int w64Convention #(int arg1 , int arg2 , int arg3 , int arg4 , int arg5 , int arg6 , int arg7 , int arg8 , int arg9 , int arg10))! !

!TFUFFIDifferentCallingConventionFunctionCallTest methodsFor: 'tests' stamp: ''!
testCallingFunctionWithW64CallingConvention

	| result |
	
	"This test is only valid in OSX and X86_64, as calling conventions constants are heavily dependant on the OS & Architecture"
	(OSPlatform current isMacOS and: [ Smalltalk vm architectureName = 'x86_64']) 
		ifFalse: [ self skip ].
			
	result := self
			calloutWithManyArguments: 1
			and: 2
			and: 3
			and: 4
			and: 5
			and: 6
			and: 7
			and: 8
			and: 9
			and: 10.
			
	self assert: result equals: 55! !

!TFUFFIFailingCallbackWithDefault commentStamp: ''!
I am a failing callback with default value for test usage only!
!TFUFFIFailingCallbackWithDefault methodsFor: 'initialization' stamp: ''!
returnOnError

	^ -1! !

!TFUFFIFailingCallbackWithDefault methodsFor: 'initialization' stamp: ''!
initialize 
	
	self signature: #(int (int)) block: [ :a | self error: 'An error in a callback' ]! !

!TFUFFIFailingCallbackWithDefault methodsFor: 'initialization' stamp: ''!
shouldDebugExceptions

	^ false! !

!TFUFFIFunctionCallTest methodsFor: 'tests' stamp: ''!
testShortCallout
	
	| semaphore result |
	semaphore := Semaphore new.
	
	[ 	result := self shortCallout.
		semaphore signal ] fork.
	semaphore wait.
	
	self assert: result equals: 42! !

!TFUFFIFunctionCallTest methodsFor: 'tests' stamp: ''!
shortCallout
	
	^ self ffiCall: #(int shortCallout())! !

!TFUFFIFunctionCallTest methodsFor: 'tests' stamp: ''!
calloutWithManyArguments: arg1 and: arg2 and: arg3 and: arg4 and: arg5 and: arg6 and: arg7 and: arg8 and: arg9 and: arg10
	^ self
		ffiCall:
			#(int multipleArgumentCallout #(int arg1 , int arg2 , int arg3 , int arg4 , int arg5 , int arg6 , int arg7 , int arg8 , int arg9 , int arg10))! !

!TFUFFIFunctionCallTest methodsFor: 'tests' stamp: ''!
testLongCalloutDoesNotBlockImage
	
	"Tricky test.
	This tests checks that during a callout the image is not completely suspended.
	To do that, we do a 1 second long callout in a separate Pharo process.
	When that process starts executing (signals the calloutEnter semaphore), we wait for half a second to let the callback really start executing and then do something before the callback returns."
	| calloutEnter calloutExit orderOfFinishing |

	"If we are running in the same thread execution, it will block the interpreter. So the test is skipped."
	(self ffiLibrary = TFTestLibraryUsingSameThreadRunner)
		ifTrue: [ ^ self skip ]. 
	
	calloutEnter := Semaphore new.
	calloutExit := Semaphore new.
	orderOfFinishing := OrderedCollection new.	
	[
		calloutEnter signal. 	
		self longCallout: 1.
		orderOfFinishing add: #finishedCallout.
		calloutExit signal ] fork.
	calloutEnter wait.
	0.3 seconds wait.
	orderOfFinishing add: #waitingForCallout.
	calloutExit wait.
	
	self assert: orderOfFinishing first equals: #waitingForCallout! !

!TFUFFIFunctionCallTest methodsFor: 'tests' stamp: ''!
longCallout: seconds
	
	^ self ffiCall: #(int longCallout(int seconds))! !

!TFUFFIFunctionCallTest methodsFor: 'tests' stamp: ''!
testCalloutWithManyArguments
	
	| result |
	result := self
			calloutWithManyArguments: 1
			and: 2
			and: 3
			and: 4
			and: 5
			and: 6
			and: 7
			and: 8
			and: 9
			and: 10.
	self assert: result equals: 55! !

!TFUFFIIncrementCallback commentStamp: ''!
I am a simple callback used by the tests!
!TFUFFIIncrementCallback methodsFor: 'initialization' stamp: ''!
initialize 
	
	self signature: #(int (int)) block: [ :a | a + 1 ]! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_float: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_float(void *callback, float aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_short: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_short(void *callback, short aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
call: aName type: aType value: aValue

	| callback received |

	callback := self
		newCallbackWithSignature: { #void . aType }
		block: [ :a | received := a ].
	self
		perform: ('simple_callback_f_', aName, ':value:') asSymbol
		withArguments: { callback . aValue}.
	^ received! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_ulong: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_ulong(void *callback, ulong aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_int64: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_int64_t(void *callback, int64 aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
assertType: aType value: aValue

	| callbackGotValue |
	callbackGotValue := self call: aType value: aValue.
	self assert: callbackGotValue equals: aValue.! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_long: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_long(void *callback, long aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_uint32: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_uint32_t(void *callback, uint32 aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
assertUnsignedIntType: name

	self assertType: name value: 65! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_int32: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_int32_t(void *callback, int32 aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_int8: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_int8_t(void *callback, int8 aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_uint64: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_uint64_t(void *callback, uint64 aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_pointer: aCallback value: aValue 

	^ self ffiCall: #(void simple_callback_f_ulonglong(void *aCallback, void* aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_char: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_char(void *callback, char aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_uchar: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_uchar(void *callback, uchar aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_uint: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_uint(void *callback, uint aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
assertSignedIntType: name

	self assertType: name value: -65! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_uint16: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_uint16_t(void *callback, uint16 aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
call: aName value: aValue

	^ self call: aName type: { aName asSymbol } value: aValue! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'tests' stamp: ''!
assertCharType: name

	self assertType: name value: $A! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_int: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_int(void *callback, int aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_double: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_double(void *callback, double aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_int16: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_int16_t(void *callback, int16 aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_uint8: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_uint8_t(void *callback, uint8 aValue))! !

!TFUFFIMarshallingInCallbacksTest methodsFor: 'ffi-calls' stamp: ''!
simple_callback_f_ushort: callback value: aValue
	^ self ffiCall: #(void simple_callback_f_ushort(void *callback, ushort aValue))! !

!TFUFFIMarshallingInCallbacksTest class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == TFUFFIMarshallingInCallbacksTest! !

!TFUFFIStructuresTest methodsFor: 'private - ffi' stamp: ''!
passingLongStructByCopy: st b: b c: c d: d

	^ self ffiCall: #(int passingLongStruct(TFLongTestStruct st, float b, double c, long d))! !

!TFUFFIStructuresTest methodsFor: 'tests' stamp: ''!
testReturningAnStruct

	| aPoint |
	aPoint := self returnNewPointX: 1 Y: 2.

	self assert: aPoint x equals: 1.
	self assert: aPoint y equals: 2.	! !

!TFUFFIStructuresTest methodsFor: 'tests' stamp: ''!
testPassingByParameterAStructInPharo

	| aPoint return |
	aPoint := TFPointTestStruct new.
	
	aPoint x: 21.
	aPoint y: 33.
	
	return := self passStructByParameter: aPoint x: 21 y: 33.
	self assert: return equals: 1.
! !

!TFUFFIStructuresTest methodsFor: 'tests' stamp: ''!
testPassingNestedStructByCopyInC

	| st return |
	st := TFNestedTestStruct externalNew
					autoRelease;
					yourself.
	
	st inner a: $a.
	st y: 1.0.
	
	return := self passingNestedStructByCopy: st a: $a y: 1.0.
	self assert: return equals: 1.
! !

!TFUFFIStructuresTest methodsFor: 'tests' stamp: ''!
testPassingLongStructByCopyInC

	| aPoint return |
	aPoint := TFLongTestStruct externalNew
					autoRelease;
					yourself.
	
	aPoint b: 1.0.
	aPoint c: 2.0.
	aPoint d: 42.
	
	return := self passingLongStructByCopy: aPoint b: 1.0 c: 2.0 d: 42.
	self assert: return equals: 1.
! !

!TFUFFIStructuresTest methodsFor: 'private - ffi' stamp: ''!
returnNewPointX: x Y: y

	^ self ffiCall: #(TFPointTestStruct newPoint(int x, int y))! !

!TFUFFIStructuresTest methodsFor: 'tests' stamp: ''!
testPassingByParameterAStructInC

	| aPoint return |
	aPoint := TFPointTestStruct externalNew
					autoRelease;
					yourself.
	
	aPoint x: 21.
	aPoint y: 33.
	
	return := self passStructByParameter: aPoint x: 21 y: 33.
	self assert: return equals: 1.
! !

!TFUFFIStructuresTest methodsFor: 'tests' stamp: ''!
testPassingByReferenceAStructInC

	| aPoint return |
	aPoint := TFPointTestStruct externalNew
					autoRelease;
					yourself.
	
	aPoint x: 21.
	aPoint y: 33.
	
	return := self passStructByReference: aPoint.
	self assert: return asInteger equals: aPoint getHandle asInteger.
! !

!TFUFFIStructuresTest methodsFor: 'tests' stamp: ''!
testNestedStructSize

	self assert: TFNestedTestStruct byteSize equals: self sizeOfNestedStruct! !

!TFUFFIStructuresTest methodsFor: 'private - ffi' stamp: ''!
passStructByReference: aPoint

	^ self ffiCall: #(void* id_pointer(TFPointTestStruct* aPoint))! !

!TFUFFIStructuresTest methodsFor: 'private - ffi' stamp: ''!
passStructByParameter: aPoint x: x y: y

	^ self ffiCall: #(int assertCorrectPoint(TFPointTestStruct aPoint, int x, int y))! !

!TFUFFIStructuresTest methodsFor: 'private - ffi' stamp: ''!
passingLongStructByReference: st b: b c: c d: d

	^ self ffiCall: #(int passingLongStructByRef(TFLongTestStruct* st, float b, double c, long d))! !

!TFUFFIStructuresTest methodsFor: 'private - ffi' stamp: ''!
passingNestedStructByCopy: st a: a y: y
 
	^ self ffiCall: #(int passingNestedStruct(TFNestedTestStruct st, char a, double y))! !

!TFUFFIStructuresTest methodsFor: 'private - ffi' stamp: ''!
sizeOfNestedStruct

	^ self ffiCall: #(int sizeOfNestedStruct())! !

!TFUFFIStructuresTest methodsFor: 'tests' stamp: ''!
testPassingLongStructByReferenceInC

	| aPoint return |
	aPoint := TFLongTestStruct externalNew
					autoRelease;
					yourself.
	
	aPoint b: 1.0.
	aPoint c: 2.0.
	aPoint d: 42.
	
	return := self passingLongStructByReference: aPoint b: 1.0 c: 2.0 d: 42.
	self assert: return equals: 1.
! !

!TFUFFIStructuresTest methodsFor: 'tests' stamp: ''!
testPassingLongStructByCopyInPharo

	| aPoint return |
	aPoint := TFLongTestStruct new.
	
	aPoint b: 1.0.
	aPoint c: 2.0.
	aPoint d: 42.
	
	return := self passingLongStructByCopy: aPoint b: 1.0 c: 2.0 d: 42.
	self assert: return equals: 1.
! !

!TFUFFITestCase methodsFor: 'accessing' stamp: ''!
ffiLibrary
	^ ffiLibrary! !

!TFUFFITestCase methodsFor: 'running' stamp: ''!
tearDown

	"I have to reset the FFI callout methods to be recompiled using the test runner"
	self class withAllSuperclassesDo: [:each | FFIMethodRegistry uniqueInstance resetSingleClass: each].

	super tearDown! !

!TFUFFITestCase methodsFor: 'running' stamp: ''!
runCaseManaged 
	
	"Skipping in running on an old VM"
	TFFIBackend isAvailable ifFalse: [ ^ self skip ].
	
	super runCaseManaged.! !

!TFUFFITestCase methodsFor: 'accessing' stamp: ''!
ffiLibrary: anObject
	ffiLibrary := anObject! !

!TFUFFITestCase class methodsFor: 'testing' stamp: ''!
isAbstract

	^ self == TFUFFITestCase! !

!TFUFFITestCase class methodsFor: 'building suites' stamp: ''!
testParameters 

	^ ParametrizedTestMatrix new
		forSelector: #ffiLibrary addOptions: { TFTestLibraryUsingSameThreadRunner. TFTestLibraryUsingWorker. }! !

!TFVariadicFunctionDefinition commentStamp: ''!
I represent Variadic Argument Functions.
I work the same as my superclass, with the difference that I use a different primitive. 
This primitive uses the libFFI API for variadic functions.

For compatibility reason with older VMs, If the new primitive fails, the old primitive is used instead.!
!TFVariadicFunctionDefinition methodsFor: 'private' stamp: ''!
initialize 
	
	super initialize.
	fixedArgumentCount := 0! !

!TFVariadicFunctionDefinition methodsFor: 'private' stamp: ''!
doValidate: parameterHandlers

	abi
		ifNil: [ 
			self
				primDefineFunctionWith: parameterHandlers
				returnType: returnType getHandle
				fixedArgumentsCount: fixedArgumentCount ]
		ifNotNil: [ 
			self
				primDefineFunctionWith: parameterHandlers
				returnType: returnType getHandle
				fixedArgumentsCount: fixedArgumentCount
				abi: abi ]! !

!TFVariadicFunctionDefinition methodsFor: 'accessing' stamp: ''!
fixedArgumentCount: anObject

	fixedArgumentCount := anObject! !

!TFVariadicFunctionDefinition methodsFor: 'accessing' stamp: ''!
fixedArgumentCount

	^ fixedArgumentCount! !

!TFVariadicFunctionDefinition methodsFor: 'primitives' stamp: ''!
primDefineFunctionWith: parameterHandlers returnType: returnTypeHandler fixedArgumentsCount: aFixedArgumentCount abi: abiType
	
	<primitive: 'primitiveDefineVariadicFunction' error: ec>

	"If the VM does not have an implementation of this primitive, we try with the non variadic version"
	^ self primDefineFunctionWith: parameterHandlers returnType: returnTypeHandler! !

!TFVariadicFunctionDefinition methodsFor: 'primitives' stamp: ''!
primDefineFunctionWith: parameterHandlers returnType: returnTypeHandler fixedArgumentsCount: aFixedArgumentCount
	
	<primitive: 'primitiveDefineVariadicFunction' error: ec>

	"If the VM does not have an implementation of this primitive, we try with the non variadic version"
	^ self primDefineFunctionWith: parameterHandlers returnType: returnTypeHandler! !

!TFVariadicFunctionDefinition class methodsFor: 'instance creation' stamp: ''!
parameterTypes: someParameters returnType: returnType

	^ self error: 'You should use #parameterTypes:returnType:fixedArgumentCount:'! !

!TFVariadicFunctionDefinition class methodsFor: 'instance creation' stamp: ''!
parameterTypes: someParameters returnType: returnType fixedArgumentCount: fixedArgumentCount abi: abiType

	^ self new
		parameterTypes: someParameters;
		returnType: returnType;
		fixedArgumentCount: fixedArgumentCount;
		abi: abiType;
		autoRelease;
		yourself! !

!TFVariadicFunctionDefinition class methodsFor: 'instance creation' stamp: ''!
parameterTypes: someParameters returnType: returnType fixedArgumentCount: fixedArgumentCount

	^ self
		  parameterTypes: someParameters
		  returnType: returnType
		  fixedArgumentCount: fixedArgumentCount
		  abi: nil! !

!TFVariadicFunctionDefinition class methodsFor: 'instance creation' stamp: ''!
parameterTypes: someParameters returnType: returnType abi: abiType

	^ self error: 'You should use #parameterTypes:returnType:fixedArgumentCount:abi:'! !

!TFWorker commentStamp: ''!
I'm a threaded ffi worker. 
A worker handles callouts/callbacks in a real thread of the system.

Creating a worker has several consquences both in image and in VM: 

Image side, it creates a process responsible to handle all callback requests from vm.
VM side, it creates a thread and installs a worker there, responsible to collect callouts and callbacks.

!
!TFWorker methodsFor: 'private' stamp: ''!
primitiveCreateWorker

	<primitive: 'primitiveCreateWorker'>

	^ self primitiveFailed ! !

!TFWorker methodsFor: 'private' stamp: ''!
primitiveReleaseWorker

	<primitive: 'primitiveReleaseWorker'>

	^ self primitiveFailed ! !

!TFWorker methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	semaphorePoolHolder := Array new: 1! !

!TFWorker methodsFor: 'private' stamp: ''!
newSemaphorePool 

	"We need to keep a reference to the semaphorePool in an array. Because the array is passed to the finalization registry.
	Like this the semaphorePool can be created lazy."
	semaphorePoolHolder ifNil: [ semaphorePoolHolder := Array new: 1 ].
	semaphorePoolHolder at: 1 put: super newSemaphorePool.
	^ semaphorePoolHolder at: 1! !

!TFWorker methodsFor: 'accessing' stamp: ''!
doInitialize

	super doInitialize.
	self primitiveCreateWorker! !

!TFWorker methodsFor: 'private' stamp: ''!
semaphorePool: aValue

	semaphorePool := aValue! !

!TFWorker methodsFor: 'executing' stamp: ''!
executeFunction: aTFExternalFunction withArguments: arguments usingSemaphore: anInteger 
	
	<primitive: 'primitiveWorkerCallout' error: ec>
	
	self primitiveFailed ! !

!TFWorker methodsFor: 'accessing' stamp: ''!
name

	^ name! !

!TFWorker methodsFor: 'accessing' stamp: ''!
name: aName

	name := aName! !

!TFWorker methodsFor: 'executing' stamp: ''!
release 
	
	"We need to ensure the semaphorePool is always released"
	semaphorePool ifNotNil: [ 
		semaphorePool release.
		semaphorePoolHolder at: 1 put: nil.
		semaphorePool := nil ].	
	
	self isNull ifTrue: [ ^ self ].
	
	self primitiveReleaseWorker.
	super release.! !

!TFWorker methodsFor: 'external resource management' stamp: ''!
resourceData

	^ { handle. semaphorePoolHolder }! !

!TFWorker methodsFor: 'executing' stamp: ''!
readReturnValueFromTask: anExternalAddress

	<primitive: 'primitiveWorkerExtractReturnValue' error: ec>

	self primitiveFailed! !

!TFWorker class methodsFor: 'private' stamp: ''!
named: aName

	^ self new 
		name: aName;
		autoRelease;
		yourself! !

!TFWorker class methodsFor: 'accessing' stamp: ''!
default

	^ Default ifNil: [ Default := self named: 'default' ]! !

!TFWorker class methodsFor: 'private' stamp: ''!
finalizeResourceData: anArray

	| handle semaphorePool |
	handle := anArray first.
	semaphorePool := anArray second first.

	(self fromHandle: handle)
		semaphorePool: semaphorePool;
		release.
		
	handle beNull.! !

!TFinalizable methodsFor: 'starting' stamp: ''!
noteNeedsToBeFinalized
	WeakRegistry default add: self! !

!TFinalizable methodsFor: 'starting' stamp: ''!
noteDoesNotNeedToBeFinalized
	WeakRegistry default remove: self ifAbsent: [  ]! !

!TFinalizable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TFinalizable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TFinalizable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TFinalizable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TFinalizable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TFinalizable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TFinalizable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TFinalizable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TFinalizable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TFinalizable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TFinalizable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TFinalizable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TFinalizable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TFinalizable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TFinalizable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TFinalizable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TFinalizable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TFinalizable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TFinalizable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TFinalizable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TFinalizable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TFinalizable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TFinalizable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TFinalizable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TFinalizable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TFinalizable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TGWithCoordinates methodsFor: 'accessing' stamp: ''!
coordinates: gCoordinates
	^ self explicitRequirement! !

!TGWithCoordinates methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	self coordinates: self coordinates copy! !

!TGWithCoordinates methodsFor: 'accessing' stamp: ''!
y: aNumber 
	self coordinates y: aNumber! !

!TGWithCoordinates methodsFor: 'enumerating' stamp: ''!
coordinatesWith: aCollection do: aBlock
	self coordinates coordinatesWith: aCollection coordinates do: aBlock! !

!TGWithCoordinates methodsFor: 'accessing' stamp: ''!
x
	^ self coordinates x! !

!TGWithCoordinates methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	self coordinates printCoordinatesOn: aStream! !

!TGWithCoordinates methodsFor: 'accessing' stamp: ''!
x: aNumber 
	self coordinates x: aNumber! !

!TGWithCoordinates methodsFor: 'accessing' stamp: ''!
y
	^ self coordinates y! !

!TGWithCoordinates methodsFor: 'accessing' stamp: ''!
coordinates
	^ self explicitRequirement! !

!TGWithCoordinates methodsFor: 'enumerating' stamp: ''!
coordinatesWith: aCollection collect: aBlock
	^ self coordinates coordinatesWith: aCollection coordinates collect: aBlock! !

!TGWithCoordinates classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TGWithCoordinates classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TGWithCoordinates classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TGWithCoordinates classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TGWithCoordinates classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TGWithCoordinates classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TGWithCoordinates classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TGWithCoordinates classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TGWithCoordinates classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TGWithCoordinates classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TGWithCoordinates classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TGWithCoordinates classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TGWithCoordinates classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TGWithCoordinates classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TGWithCoordinates classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TGWithCoordinates classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TGWithCoordinates classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TGWithCoordinates classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TGWithCoordinates classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TGWithCoordinates classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TGWithCoordinates classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TGWithCoordinates classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TGWithCoordinates classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TGWithCoordinates classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TGWithCoordinates classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TGWithCoordinates classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TGrowableTest commentStamp: ''!
A trait for test purposes!
!TGrowableTest methodsFor: 'requirements' stamp: ''!
elementNotIn
	
	^ self explicitRequirement! !

!TGrowableTest methodsFor: 'tests - growable' stamp: ''!
testAddEmptyGrows
	
	| oldSize |
	oldSize := self empty size.
	self empty add: self element.
	self assert: (self empty size) = (oldSize + 1).! !

!TGrowableTest methodsFor: 'requirements' stamp: ''!
empty 

	^ self explicitRequirement! !

!TGrowableTest methodsFor: 'requirements' stamp: ''!
element

	^ self explicitRequirement! !

!TGrowableTest methodsFor: 'requirements' stamp: ''!
nonEmpty 

	^ self explicitRequirement! !

!TGrowableTest methodsFor: 'tests - growable' stamp: ''!
testAddNonEmptyGrowsWhenNewElement
	
	| oldSize |
	oldSize := self nonEmpty size.
	
	self nonEmpty add: self elementNotIn.
	self assert: (self nonEmpty size) > oldSize.! !

!TGrowableTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRequirementsOfTGrowableTest
	self empty.
	self nonEmpty.
	self element.
	self elementNotIn.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty.
	self assert: (self nonEmpty includes: self element).
	self deny: (self nonEmpty includes: self elementNotIn)! !

!TGrowableTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TGrowableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TGrowableTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TGrowableTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TGrowableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TGrowableTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TGrowableTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TGrowableTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TGrowableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TGrowableTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TGrowableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TGrowableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TGrowableTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TGrowableTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TGrowableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TGrowableTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TGrowableTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TGrowableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TGrowableTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TGrowableTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TGrowableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TGrowableTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TGrowableTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TGrowableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TGrowableTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TGrowableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIceCopyCommitId commentStamp: ''!
Description
--------------------

I am a simple Trait allowing to copy a commit ID to the clipboard without duplicating the code in Iceberg.!
!TIceCopyCommitId methodsFor: 'copying' stamp: ''!
copyToClipboardId: id
	Clipboard clipboardText: id informing: ('Commitish ID copied to clipboard ({1})' format: {id})! !

!TIceCopyCommitId methodsFor: 'copying' stamp: ''!
copyCommitIDToClipboard
	<noCache>
	self copyToClipboardId: self commitId! !

!TIceCopyCommitId classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIceCopyCommitId classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIceCopyCommitId classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIceCopyCommitId classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIceCopyCommitId classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIceCopyCommitId classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIceCopyCommitId classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIceCopyCommitId classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIceCopyCommitId classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIceCopyCommitId classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIceCopyCommitId classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIceCopyCommitId classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIceCopyCommitId classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIceCopyCommitId classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIceCopyCommitId classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIceCopyCommitId classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIceCopyCommitId classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIceCopyCommitId classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIceCopyCommitId classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIceCopyCommitId classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIceCopyCommitId classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIceCopyCommitId classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIceCopyCommitId classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIceCopyCommitId classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIceCopyCommitId classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIceCopyCommitId classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIceRepositoryReader commentStamp: ''!
I indicate when a clas is reader for iceberg !
!TIceRepositoryReader classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIceRepositoryReader classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIceRepositoryReader classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIceRepositoryReader classTrait methodsFor: 'testing' stamp: ''!
isLegacyDefault
	^ false! !

!TIceRepositoryReader classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIceRepositoryReader classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIceRepositoryReader classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIceRepositoryReader classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIceRepositoryReader classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIceRepositoryReader classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIceRepositoryReader classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIceRepositoryReader classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIceRepositoryReader classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIceRepositoryReader classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIceRepositoryReader classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIceRepositoryReader classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIceRepositoryReader classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIceRepositoryReader classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIceRepositoryReader classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIceRepositoryReader classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIceRepositoryReader classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIceRepositoryReader classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIceRepositoryReader classTrait methodsFor: 'accessing' stamp: ''!
id
	^ self required! !

!TIceRepositoryReader classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIceRepositoryReader classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIceRepositoryReader classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIceRepositoryReader classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIceRepositoryReader classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIceRepositoryWriter commentStamp: ''!
I indicate when a class is writer for iceberg !
!TIceRepositoryWriter classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIceRepositoryWriter classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIceRepositoryWriter classTrait methodsFor: 'testing' stamp: ''!
isLegacyDefault
	"Indicates when repository is default as legacy (when there is no properties file indicating 
	 a specific format type)"
	^ false! !

!TIceRepositoryWriter classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIceRepositoryWriter classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIceRepositoryWriter classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIceRepositoryWriter classTrait methodsFor: 'testing' stamp: ''!
isDefault
	"Indicates when this is default when create new repositories"
	^ false! !

!TIceRepositoryWriter classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIceRepositoryWriter classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIceRepositoryWriter classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIceRepositoryWriter classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIceRepositoryWriter classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIceRepositoryWriter classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIceRepositoryWriter classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIceRepositoryWriter classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing' stamp: ''!
id
	^ self required! !

!TIceRepositoryWriter classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIceRepositoryWriter classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIceRepositoryWriter classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIceRepositoryWriter classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIdentityAddTest commentStamp: ''!
A trait for test purposes!
!TIdentityAddTest methodsFor: 'requirements' stamp: ''!
collection
	^ self explicitRequirement! !

!TIdentityAddTest methodsFor: 'requirements' stamp: ''!
element
	^ self explicitRequirement! !

!TIdentityAddTest methodsFor: 'tests - identity adding' stamp: ''!
testIdentityAdd
	| added |
	self collection add: self element.
	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)! !

!TIdentityAddTest methodsFor: 'tests - identity adding' stamp: ''!
equalNotIdenticalElement
	^ self element copy! !

!TIdentityAddTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIdentityAddTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIdentityAddTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIdentityAddTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIdentityAddTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIdentityAddTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIdentityAddTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIdentityAddTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIdentityAddTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIdentityAddTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIdentityAddTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIdentityAddTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIdentityAddTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIdentityAddTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIdentityAddTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIdentityAddTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIdentityAddTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIdentityAddTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIdentityAddTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIdentityAddTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIdentityAddTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIdentityAddTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIdentityAddTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIdentityAddTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIdentityAddTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIdentityAddTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIncludesForIdentityCollectionsTest commentStamp: ''!
A trait for test purposes!
!TIncludesForIdentityCollectionsTest methodsFor: 'tests - including for identity collections' stamp: ''!
testIncludesForIdentityCollections

	| collection element elementCopy |
	collection := self identityCollectionWithElementsCopyNotIdentical .
	element := collection anyOne.
	elementCopy := element copy.
	self assert: (collection includes: element).
	self deny: (collection includes: elementCopy)! !

!TIncludesForIdentityCollectionsTest methodsFor: 'tests - including for identity collections' stamp: ''!
testIncludesAllOfForIdentityCollections

	| collection copyCollection |
	collection := self identityCollectionWithElementsCopyNotIdentical .
	copyCollection := OrderedCollection new.
	collection do: [ :each | copyCollection add: each copy ].
	self assert: (collection includesAll: collection).
	self deny: (collection includesAll: copyCollection).
	self deny: (collection includesAll: {  (copyCollection anyOne)  })! !

!TIncludesForIdentityCollectionsTest methodsFor: 'tests - including for identity collections' stamp: ''!
testIdentityIncludesForIdentityCollections
	" 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 |
	collection := self identityCollectionWithElementsCopyNotIdentical .
	element := collection anyOne copy.
	self deny: (collection identityIncludes: element)! !

!TIncludesForIdentityCollectionsTest methodsFor: 'requirements' stamp: ''!
identityCollectionWithElementsCopyNotIdentical
	" return a collection including elements for which #copy return a new object "
	^ self explicitRequirement! !

!TIncludesForIdentityCollectionsTest methodsFor: 'tests - including for identity collections' stamp: ''!
testIncludesAnyOfForIdentityCollections

	| collection copyCollection |
	collection := self identityCollectionWithElementsCopyNotIdentical .
	copyCollection := OrderedCollection new.
	collection do: [ :each | copyCollection add: each copy ].
	self deny: (collection includesAny: copyCollection).
	self assert: (collection includesAny: {  (collection anyOne)  })! !

!TIncludesForIdentityCollectionsTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureInludesForIdentityCollectionsTest
	self identityCollectionWithElementsCopyNotIdentical.
	self identityCollectionWithElementsCopyNotIdentical do: [ :each | self deny: each == each copy ]! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIncludesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIncludesTest commentStamp: ''!
A trait for test purposes!
!TIncludesTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne).! !

!TIncludesTest methodsFor: 'requirements' stamp: ''!
anotherElementNotIn
" return an element different of 'elementNotIn'  not included in 'nonEmpty' "
	^ self explicitRequirement! !

!TIncludesTest methodsFor: 'requirements' stamp: ''!
elementNotIn
"return an element not included in 'nonEmpty' "

	^ self explicitRequirement! !

!TIncludesTest methodsFor: 'requirements' stamp: ''!
empty
	^ self explicitRequirement! !

!TIncludesTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	^ self explicitRequirement! !

!TIncludesTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty ).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!TIncludesTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!TIncludesTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	self deny: (self nonEmpty includesAny: self empty).
	self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }).
	self assert: (self nonEmpty includesAny: self nonEmpty).! !

!TIncludesTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsNotThere
	
	self deny: (self nonEmpty includes: self elementNotIn).
	self assert: (self nonEmpty includes: self nonEmpty anyOne).
	self deny: (self empty includes: self elementNotIn)! !

!TIncludesTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!TIncludesTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!TIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIncludesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIncludesTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIncludesTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIncludesTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIncludesTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIncludesTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIncludesTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIncludesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIncludesTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIncludesTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIncludesTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIncludesTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIncludesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIncludesTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIncludesTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIncludesTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIncludesTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIncludesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIncludesTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIncludesTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIncludesWithIdentityCheckTest commentStamp: ''!
A trait for test purposes!
!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsThere
	
	self assert: (self nonEmpty includes: self nonEmpty anyOne)! !

!TIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: ''!
anotherElementNotIn
" return an element different of 'elementNotIn'  not included in 'nonEmpty' "
	^ self explicitRequirement! !

!TIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: ''!
elementNotIn
"return an element not included in 'nonEmpty' "

	^ self explicitRequirement! !

!TIncludesWithIdentityCheckTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeWithIdentityTest

	| anElement |
	self collectionWithCopyNonIdentical.
	anElement := self collectionWithCopyNonIdentical anyOne.
	self deny: anElement == anElement copy! !

!TIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: ''!
empty
	^ self explicitRequirement! !

!TIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: ''!
nonEmpty
	^ self explicitRequirement! !

!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAllNoneThere

	self deny: (self empty includesAll: self nonEmpty).
	self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! !

!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyNoneThere
	
	self deny: (self nonEmpty includesAny: self empty).
	self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! !

!TIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: ''!
collectionWithCopyNonIdentical
	" return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)"
	^ self explicitRequirement! !

!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes' stamp: ''!
testIncludesAnyAllThere

	self deny: (self nonEmpty includesAny: self empty).
	self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }).
	self assert: (self nonEmpty includesAny: self nonEmpty)! !

!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes' stamp: ''!
testIncludesElementIsNotThere
	
	self deny: (self nonEmpty includes: self elementNotIn).
	self assert: (self nonEmpty includes: self nonEmpty anyOne).
	self deny: (self empty includes: self elementNotIn)! !

!TIncludesWithIdentityCheckTest methodsFor: 'tests - including with identity' stamp: ''!
testIdentityIncludes
	" test the comportement in presence of elements 'includes' but not 'identityIncludes' "
	" can not be used by collections that can't include elements for wich copy doesn't return another instance "
	| collection anElement |
	
	collection := self collectionWithCopyNonIdentical.
	anElement := collection anyOne copy.

	self deny: (collection identityIncludes: anElement)! !

!TIncludesWithIdentityCheckTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIncludeTest
	| anElementIn |
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self elementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self anotherElementNotIn.
	anElementIn := true.
	self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ].
	self deny: anElementIn.
	self empty.
	self assertEmpty: self empty! !

!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes' stamp: ''!
testIdentityIncludesNonSpecificComportement
	"Test the same comportement than #includes:"
	
	| collection |	
	collection := self nonEmpty.
	
	self deny: (collection identityIncludes: self elementNotIn).
	self assert: (collection identityIncludes: collection anyOne)! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIncludesWithIdentityCheckTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIndexAccess commentStamp: ''!
A trait for test purposes!
!TIndexAccess methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessTest
	| res |
	self collectionMoreThan1NoDuplicates.
	self assert: self collectionMoreThan1NoDuplicates size > 1.
	res := true.
	self collectionMoreThan1NoDuplicates
		detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ]
		ifNone: [ res := false ].
	self assert: res = false.
	self elementInForIndexAccessing.
	self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing).
	self elementNotInForIndexAccessing.
	self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOfIAbsent
	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) 
	     equals: 1.

	self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) 
		  equals: 55! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
testIdentityIndexOf

	| collection element |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection identityIndexOf: element) equals: (collection indexOf: element)! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAt

	| subcollection index collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 1.
	self assert: index equals: 1.
	index := collection 
		indexOfSubCollection: subcollection
		startingAt: 2.
	self assert: index equals: 0! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			lastIndexOf: element
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 99 ]) equals: 99! !

!TIndexAccess methodsFor: 'requirements' stamp: ''!
elementNotInForIndexAccessing
" return an element not included in 'collectionMoreThan1NoDuplicates' "
	self explicitRequirement! !

!TIndexAccess methodsFor: 'requirements' stamp: ''!
elementInForIndexAccessing
" return an element included in 'collectionMoreThan1NoDuplicates' "
	self explicitRequirement! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!TIndexAccess methodsFor: 'requirements' stamp: ''!
collectionMoreThan1NoDuplicates
	" return a collection of size > 1 without equal elements"
	self explicitRequirement! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
testIndexOfIfAbsent

	| collection |
	collection := self collectionMoreThan1NoDuplicates.
	self assert: (collection 
			indexOf: collection first
			ifAbsent: [ 33 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			ifAbsent: [ 33 ]) equals: 33! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
testIndexOfStartingAtIfAbsent

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			indexOf: element
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 1.
	self assert: (collection 
			indexOf: self elementNotInForIndexAccessing
			startingAt: 1
			ifAbsent: [ 99 ]) equals: 99! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
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) equals: index! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
testLastIndexOfStartingAt

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection last.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 99 ]) equals: 99.
	self assert: (collection 
			lastIndexOf: self elementNotInForIndexAccessing
			startingAt: collection size
			ifAbsent: [ 99 ]) equals: 99! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
testLastIndexOf

	| element collection |
	collection := self collectionMoreThan1NoDuplicates.
	element := collection first.
	self assert: (collection lastIndexOf: element) = 1.
	self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! !

!TIndexAccess methodsFor: 'tests - index access' stamp: ''!
testIndexOfSubCollectionStartingAtIfAbsent
	| absent subcollection collection |
	collection := self collectionMoreThan1NoDuplicates.
	subcollection := self collectionMoreThan1NoDuplicates.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ].
	self deny: absent.
	absent := false.
	collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ].
	self assert: absent! !

!TIndexAccess classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIndexAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIndexAccess classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIndexAccess classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIndexAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIndexAccess classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIndexAccess classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIndexAccess classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIndexAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIndexAccess classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIndexAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIndexAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIndexAccess classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIndexAccess classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIndexAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIndexAccess classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIndexAccess classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIndexAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIndexAccess classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIndexAccess classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIndexAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIndexAccess classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIndexAccess classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIndexAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIndexAccess classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIndexAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIndexAccessForMultipliness commentStamp: ''!
A trait for test purposes!
!TIndexAccessForMultipliness methodsFor: 'requirements' stamp: ''!
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)"
	self explicitRequirement! !

!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfIfAbsentDuplicate

	| 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 ]) equals: 1! !

!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfIfAbsentDuplicate

	| 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 ]) equals: collection size! !

!TIndexAccessForMultipliness methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIndexAccessFotMultipliness

	self collectionWithSameAtEndAndBegining.
	self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last.
	self assert: self collectionWithSameAtEndAndBegining size > 1.
	1 to: self collectionWithSameAtEndAndBegining size do: [ :i | 
		i > 1 & (i < self collectionWithSameAtEndAndBegining size)
			ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! !

!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIdentityIndexOfIAbsentDuplicate

	| collection element elementCopy |
	collection := self collectionWithNonIdentitySameAtEndAndBegining.
	element := collection last.
	elementCopy := element copy.
	self deny: element == elementCopy.
	self assert: (collection 
			identityIndexOf: element
			ifAbsent: [ 0 ]) equals: collection size.
	self assert: (collection 
			identityIndexOf: elementCopy
			ifAbsent: [ 55 ]) equals: 55! !

!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfStartingAtDuplicate

	| 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 ]) equals: collection size.
	self assert: (collection 
			lastIndexOf: element
			startingAt: collection size - 1
			ifAbsent: [ 55 ]) equals: 1! !

!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfStartingAtDuplicate

	| 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 ]) equals: 1.
	self assert: (collection 
			indexOf: element
			startingAt: 2
			ifAbsent: [ 55 ]) equals: collection size! !

!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIndexOfDuplicate

	| 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) equals: 1! !

!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testIdentityIndexOfDuplicate

	| collection element |
	"testing fixture here as this method may not be used by some collections testClass"
	self collectionWithNonIdentitySameAtEndAndBegining.
	collection := self collectionWithNonIdentitySameAtEndAndBegining.
	self assert: collection first equals: collection last.
	self deny: collection first == collection last.
	collection withIndexDo: [:el :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) equals: collection size! !

!TIndexAccessForMultipliness methodsFor: 'requirements' stamp: ''!
collectionWithSameAtEndAndBegining
	" return a collection with elements at end and begining equals .
(others elements of the collection are not equal to those elements)"
	self explicitRequirement! !

!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: ''!
testLastIndexOfDuplicate

	| 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) equals: collection size! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIndexAccessForMultipliness classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIndexAccessForMultipliness classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIndexAccessForMultipliness classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIndexAccessForMultipliness classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIndexAccessForMultipliness classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIndexAccessForMultipliness classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIndexAccessForMultipliness classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIndexAccessForMultipliness classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIndexAccessForMultipliness classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIndexAccessForMultipliness classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIndexAccessForMultipliness classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIndexAccessForMultipliness classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIndexAccessForMultipliness classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIndexAccessForMultipliness classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIndexAccessForMultipliness classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIndexAccessForMultipliness classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIterateSequencedReadableTest commentStamp: ''!
A trait for test purposes!
!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDoError
	
	self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error! !

!TIterateSequencedReadableTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateSequencedReadableTest
	| res |
	self nonEmptyMoreThan1Element.
	self assert: self nonEmptyMoreThan1Element size > 1.

	self empty.
	self assertEmpty: self empty.

	res := true.
	self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexDo

	|  indexes elements |
	indexes:= OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:value :i  |
			indexes  add: (i).
			elements add: value ].
	
	self nonEmptyMoreThan1Element withIndexDo: 
		[:el :i |
			self assert: (indexes at: i) equals: i.
			self assert: (elements at: i) equals: el ].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDo! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDoEmpty
	| result |
	result := OrderedCollection new.

	self empty keysAndValuesDo: [ :i :value | result add: value + i ].

	self assertEmpty: result! !

!TIterateSequencedReadableTest methodsFor: 'requirements' stamp: ''!
empty
	^self explicitRequirement.! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirstNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDo
	| result |
	result := OrderedCollection new.
	self nonEmpty reverseDo: [: each | result add: each].
	
	1 to: result size do:
		[:i|
		self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))]! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLast

	| element result |
	element := self nonEmptyMoreThan1Element at: self nonEmptyMoreThan1Element size.
	result := self nonEmptyMoreThan1Element findLast: [:each | each =element].
	
	self assert: result equals: self nonEmptyMoreThan1Element size! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithIndexCollect
	
	| result index collection |
	index := 0.
	collection := self nonEmptyMoreThan1Element .
	result := collection  withIndexCollect: [:each :i | 
		self assert: i equals: (index := index + 1).	
		self assert: i equals: (collection  indexOf: each).
		each ]. 
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (collection at: i)].
	self assert: result size equals: collection size! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testDetectSequenced
	"Testing that detect keep the first element returning true for sequenceable collections"

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element  detect: [:each | each notNil ].
	self assert: result equals: element! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseDoEmpty
	| result |
	result := OrderedCollection new.
	self empty reverseDo: [ :each | result add: each ].

	self assertEmpty: result! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollect
	
	| result firstCollection secondCollection index  |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	result := firstCollection  with: secondCollection collect:
		[:a :b |
		( index := index + 1).
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals:  b.
		b].
	
	result withIndexDo: [:el :i | self assert: (result at:i) equals: (secondCollection  at: i)].
	self assert: result size = secondCollection size! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButLastDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButLastDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i ))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element  size-1)! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindLastNotIn

	| result |	
	result := self empty findFirst: [:each | true ].
	
	self assert: result equals: 0! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithCollectError

	self should: [ self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testReverseWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := firstCollection size.
	
	firstCollection  reverseWith: secondCollection do:
		[:a :b |
	
		self assert: (firstCollection at: index) equals: a. 
		self assert: (secondCollection at: index) equals: b.
			(index := index - 1)]! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsCollect
	| index result |
	index := 0.

	result := self nonEmptyMoreThan1Element
		pairsCollect: [ :each1 :each2 | 
			self assert: (self nonEmptyMoreThan1Element indexOf: each2) equals: (index := index + 2).
			(self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1) ].

	result do: [ :each | self assert: each ]! !

!TIterateSequencedReadableTest methodsFor: 'requirements' stamp: ''!
nonEmptyMoreThan1Element
" return a collection that doesn't includes equal elements' and doesn't include nil elements'" 
	^self explicitRequirement.! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testCollectFromTo
	
	| result |
	result:=self nonEmptyMoreThan1Element 
		collect: [ :each | each ]
		from: 1
		to: (self nonEmptyMoreThan1Element size - 1).
		
	1 to: result size
		do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ].
	self assert: result size = (self nonEmptyMoreThan1Element size - 1)! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testKeysAndValuesDo
	"| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		result add: (value+i)].
	
	1 to: result size do:
		[:i|
		self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]"
	|  indexes elements |
	indexes := OrderedCollection new.
	elements := OrderedCollection new.
	
	self nonEmptyMoreThan1Element  keysAndValuesDo: 
		[:i :value|
		indexes  add: (i).
		elements add: value].
	
	(1 to: self nonEmptyMoreThan1Element size )do:
		[ :i |
		self assert: (indexes at: i) equals: i.
		self assert: (elements at: i) equals: (self nonEmptyMoreThan1Element at: i).	
		].
	
	self assert: indexes size equals: elements size. 
	self assert: indexes size equals: self nonEmptyMoreThan1Element size! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testWithDo
	
	| firstCollection secondCollection index |

	firstCollection := self nonEmptyMoreThan1Element.
	secondCollection := firstCollection copy.
	index := 0.
	
	firstCollection  with: secondCollection do:
		[:a :b |
		index := index + 1.
		self assert: (firstCollection at: index) equals:  a. 
		self assert: (secondCollection at: index) equals: b ]! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testAllButFirstDo
	
	| result |
	result:= OrderedCollection  new.
	
	self nonEmptyMoreThan1Element  allButFirstDo: [:each | result add: each].
	
	1 to: (result size) do:
		[:i|
		self assert: (self nonEmptyMoreThan1Element  at:(i +1))=(result at:i)].
	
	self assert: result size=(self nonEmptyMoreThan1Element size-1)! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testGroupsOfAtATimeCollect
	| groupsOf2 |
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: [ :x | x ]).
	self assertEmpty: (self empty groupsOf: 2 atATimeCollect: #yourself).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 2 atATimeCollect: [ :x | x ].
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 2.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 2 ]).
	
	groupsOf2 := self nonEmptyMoreThan1Element groupsOf: 3 atATimeCollect: #yourself.
	
	self assert: groupsOf2 size equals: self nonEmptyMoreThan1Element size // 3.
	self assert: (groupsOf2 allSatisfy: [ :array | array size = 3 ]).! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFindFirst

	| element result |
	element := self nonEmptyMoreThan1Element at: 1.
	result := self nonEmptyMoreThan1Element findFirst: [:each | each = element].
	
	self assert: result equals: 1! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testPairsDo

	| index |
	index:=1.
	
	self nonEmptyMoreThan1Element  pairsDo: 
		[:each1 :each2 | 
		self assert: (self nonEmptyMoreThan1Element at:index) equals: each1.
		self assert: (self nonEmptyMoreThan1Element at:(index+1)) equals: each2.
		index := index + 2 ].
	
	self nonEmptyMoreThan1Element size odd
		ifTrue:[ self assert: index equals: self nonEmptyMoreThan1Element size ]
		ifFalse:[ self assert: index equals: (self nonEmptyMoreThan1Element size+1) ]! !

!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''!
testFromToDo
	
	| result |
	result:= OrderedCollection new.
	
	self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each].
	
	1 to: (self nonEmptyMoreThan1Element  size -1) do:
		[:i | self assert: (self nonEmptyMoreThan1Element at:i) = (result at:i) ].

	self assert: result size = (self nonEmptyMoreThan1Element size - 1).! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIterateSequencedReadableTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIterateSequencedReadableTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIterateSequencedReadableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIterateSequencedReadableTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIterateSequencedReadableTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIterateSequencedReadableTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIterateSequencedReadableTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIterateSequencedReadableTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIterateSequencedReadableTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIterateSequencedReadableTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIterateSequencedReadableTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIterateSequencedReadableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIterateSequencedReadableTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIterateSequencedReadableTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIterateSequencedReadableTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIterateSequencedReadableTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TIterateTest commentStamp: ''!
I'm testing that high-order iterators are working.
Note however that I do not pay attention to the order of the elements.
Hence, my doTest is designed to not checking that. 
TIterateSequenceableTest is about this distinction and as such will not be applicable to test
Set, Bag, Dictionary. 


!
!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testAllSatisfy

	| element |
	" when all element  satisfy the condition, should return true : "
	self assert: ( self collectionWithoutNilElements  allSatisfy: [:each | (each notNil) ] ).
	
	" when all element don't satisfy the condition, should return false : "
	self deny: ( self collectionWithoutNilElements  allSatisfy: [:each | (each notNil) not ] ).
	
	" when only one element doesn't satisfy the condition' should return false'"
	element := self collectionWithoutNilElements anyOne.
	self deny: ( self collectionWithoutNilElements  allSatisfy: [:each | (each = element) not] ).! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testBasicCollectThenDo

	| result index |
	index := 0.
	result := self collectionWithoutNilElements 
		collect: [ :each | nil ]
		thenDo: [ :each | 
			self assert: each isNil.
			index := index + 1]	.
			
	self assert: result equals: self collectionWithoutNilElements.
	self assert: index equals: self collectionWithoutNilElements size.! !

!TIterateTest methodsFor: 'requirements' stamp: ''!
empty

	self explicitRequirement! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testBasicCollect

	| res index |
	index := 0.
	res := self collectionWithoutNilElements collect: [ :each | 
		index := index + 1.
		each ].
	
	res do: [ :each | 
		self assert: (self collectionWithoutNilElements occurrencesOf: each) = (res occurrencesOf: each)].
	self assert: index equals: self collectionWithoutNilElements size.! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testRejectEmpty

	| res |
	res := self empty reject: [:each | each odd].
	self assert: res size = self empty size! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testSelectNoneThenDo
	| result |
	
	result := self collectionWithoutNilElements 
		select: [ :each | each isNil ] 
		thenDo: [ self fail ].
	
	self assert: result equals: self collectionWithoutNilElements! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenCollectEmpty
	self assertEmpty: (self empty reject: [ :e | self fail ] thenCollect: [ :each | self fail ])! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testInjectInto
	|result|
	result:= self collectionWithoutNilElements 
		inject: 0
		into: [:inj :ele | ele notNil ifTrue: [ inj + 1 ]].
	
	self assert: self collectionWithoutNilElements size = result .! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testSelect

	| result element |
	result := self collectionWithoutNilElements select: [ :each | each notNil].
	self assert: result size equals: self collectionWithoutNilElements size.
	
	element := self collectionWithoutNilElements anyOne.
	result := self collectionWithoutNilElements select: [ :each | (each = element) not].
	self assert: result size equals: (self collectionWithoutNilElements size - 1).! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
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 ) ].! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testCollectThenDoOnEmpty
	self assertEmpty: (self empty collect: [ :e | self fail ] thenDo: [ self fail ])! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testDoSeparatedBy
	| string expectedString beforeFirst |
	
	string := ''.
	self collectionWithoutNilElements  
		do: [ :each | string := string , each asString ]
		separatedBy: [ string := string , '|' ].
		
	expectedString := ''.
	beforeFirst := true.
	self collectionWithoutNilElements  do: 
		[ :each | 
		beforeFirst = true 
			ifTrue: [ beforeFirst := false ]
			ifFalse: [ expectedString := expectedString , '|' ].
		expectedString := expectedString , each asString ].
	self assert: expectedString = string! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenDoOnEmpty
	self assertEmpty: (self empty reject: [ :e | self fail ] thenDo: [ self fail ])! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenCollect

	| result index selectIndex pivot |
	
	index := 0.
	selectIndex := 0.
	pivot := self collectionWithoutNilElements anyOne.
	
	result := self collectionWithoutNilElements 
		select: [ :each | 
			selectIndex := selectIndex + 1.
			"reject the first element"
			selectIndex > 1 ]
		thenCollect: [ :each | 
			self assert: each notNil.
			index := index + 1.
			pivot ].
			
	self assert: result ~= self collectionWithoutNilElements.
	self assert: selectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.
	
	self assert: (self collectionWithoutNilElements occurrencesOf: pivot) equals: 1.
	"should be > 1 for standard collection and = 1 for those that do not allow exact duplicates"
	self assert: (result occurrencesOf: pivot) >= 1.! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testRejectAllThenDo
	| result |
	
	result := self collectionWithoutNilElements 
		reject: [ :each | each notNil ] 
		thenDo: [ :each | self fail ].
	
	self assert: result equals: self collectionWithoutNilElements! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testCollectOnEmpty
	self assertEmpty: (self empty collect: [ :e | self fail ])! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testDo2
	"dc: Bad test, it assumes that a new instance of #speciesClass allows addition with #add:. This is not the case of Interval for which species is Array."
	"res := self speciesClass new.  
	self collection do: [:each | res add: each class].
	self assert: res = self result. "
	| collection cptElementsViewed cptElementsIn |
	collection := self collectionWithoutNilElements.
	cptElementsViewed := 0.
	cptElementsIn := OrderedCollection new.
	collection do: 
		[ :each | 
		cptElementsViewed := cptElementsViewed + 1.
		" #do doesn't iterate with the same objects than those in the collection for FloatArray( I don' t know why ) . That's why I use #includes: and not #identityIncludes:  '"
		(collection includes: each) ifTrue: [
			" the collection used doesn't include equal elements. Therefore each element viewed should not have been viewed before "
			( cptElementsIn includes: each ) ifFalse: [ cptElementsIn add: each ] .
			]. 
		].
	self assert: cptElementsViewed = collection size.
	self assert: cptElementsIn size  = collection size.! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testNoneSatisfyEmpty

	self assert: ( self empty noneSatisfy: [:each | false]).! !

!TIterateTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureIterateTest
	| res |
	self collectionWithoutNilElements.
	self assert: (self collectionWithoutNilElements occurrencesOf: nil) = 0.
	res := true.
	self collectionWithoutNilElements detect: [ :each | (self collectionWithoutNilElements occurrencesOf: each) > 1 ] ifNone: [ res := false ].
	self deny: res! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testReject

	| res element |
	res := self collectionWithoutNilElements reject: [:each | each notNil not].
	self assert: res size = self collectionWithoutNilElements size.
	
	element := self collectionWithoutNilElements anyOne.
	res := self collectionWithoutNilElements  reject: [:each | each = element].
	self assert: res size = (self collectionWithoutNilElements size - 1).! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testRejectNoReject

	| res |
	res := self collectionWithoutNilElements  reject: [:each | each notNil not].
	self assert: res size = self collectionWithoutNilElements size.! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testAllSatisfyEmpty

	self assert: ( self empty allSatisfy: [:each | false]).! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenCollect

	| result index selectIndex pivot |
	
	index := 0.
	selectIndex := 0.
	pivot := self collectionWithoutNilElements anyOne.
	
	result := self collectionWithoutNilElements 
		reject: [ :each | 
			selectIndex := selectIndex + 1.
			"reject the first element"
			selectIndex = 1 ]
		thenCollect: [ :each | 
			self assert: each notNil.
			index := index + 1.
			pivot ].
			
	self assert: result ~= self collectionWithoutNilElements.
	self assert: selectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.
	
	self assert: (self collectionWithoutNilElements occurrencesOf: pivot) equals: 1.
	"should be > 1 for standard collection and = 1 for those that do not allow exact duplicates"
	self assert: (result occurrencesOf: pivot) >= 1.! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testRejectThenDo

	| result index rejectIndex |
	
	index := 0.
	rejectIndex := 0.
	
	result := self collectionWithoutNilElements 
		reject: [ :each | 
			rejectIndex := rejectIndex + 1.
			"reject the first element"
			rejectIndex = 1 ]
		thenDo: [ :each | 
			self assert: each notNil.
			index := index + 1]	.
			
	self assert: result equals: self collectionWithoutNilElements.
	self assert: rejectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testSelectOnEmpty
	self assertEmpty: (self empty select: [ :e | self fail ])! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testNoneSatisfy

	| element |
	self assert: ( self collectionWithoutNilElements  noneSatisfy: [:each | each notNil not ] ).
	element := self collectionWithoutNilElements anyOne.
	self deny: ( self collectionWithoutNilElements  noneSatisfy: [:each | (each = element)not ] ).! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testCollectThenSelectOnEmpty
	self assertEmpty: (self empty collect: [ :e | self fail ] thenSelect: [ :e | self fail ])! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenCollectOnEmpty
	self assertEmpty: (self empty select: [ :e | self fail ] thenCollect: [ self fail ])! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenDoOnEmpty
	self assertEmpty: (self empty select: [ :e | self fail ] thenDo: [ self fail ])! !

!TIterateTest methodsFor: 'requirements' stamp: ''!
collectionWithoutNilElements
" return a collection that doesn't includes a nil element  and that doesn't includes equal elements'"
	self explicitRequirement! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testSelectThenDo

	| result index selectIndex |
	
	index := 0.
	selectIndex := 0.
	
	result := self collectionWithoutNilElements 
		select: [ :each | 
			selectIndex := selectIndex + 1.
			"reject the first element"
			selectIndex > 1 ]
		thenDo: [ :each | 
			self assert: each notNil.
			index := index + 1]	.
			
	self assert: result equals: self collectionWithoutNilElements.
	self assert: selectIndex equals: self collectionWithoutNilElements size.
	self assert: index equals: self collectionWithoutNilElements size - 1.! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testBasicCollectEmpty
	| res |
	res := self empty collect: [ :each | each class ].
	self assertEmpty: res! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testDetect

	| res element |
	element := self collectionWithoutNilElements anyOne .
	 
	res := self collectionWithoutNilElements  detect: [:each | each = element].
	self assert: (res  = element).! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testDetectIfNone

	| res element |
	res := self collectionWithoutNilElements  detect: [:each | each notNil not] ifNone: [100].
	self assert: res  = 100.
	
	element := self collectionWithoutNilElements anyOne.
	res := self collectionWithoutNilElements  detect: [:each | each = element] ifNone: [100].
	self assert: res  = element.! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testSelectNoneThenCollect
	| result |
	result := self collectionWithoutNilElements select: [ :each | each isNil ] thenCollect: [ :each | self fail ].

	self assertEmpty: result! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testSumNumbers
	|result|
	result:= self collectionWithoutNilElements 
		sumNumbers: [ :ele | ele notNil ifTrue: [ 1 ] ifFalse: [ 0 ]].
	
	self assert: self collectionWithoutNilElements size = result! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testAnySastify

	| element |
	" when all elements satisty the condition, should return true :"
	self assert: ( self collectionWithoutNilElements anySatisfy: [:each | each notNil ]).
	
	" when only one element satisfy the condition, should return true :"
	element := self collectionWithoutNilElements anyOne.
	self assert: ( self collectionWithoutNilElements  anySatisfy: [:each | (each = element)  ]   ).
	
	" when all elements don't satisty the condition, should return false :"
	self deny: ( self collectionWithoutNilElements anySatisfy: [:each | (each notNil) not ]).! !

!TIterateTest methodsFor: 'tests - iterating' stamp: ''!
testRejectAllThenCollect
	| result |
	result := self collectionWithoutNilElements reject: [ :each | each notNil ] thenCollect: [ :each | self fail ].

	self assertEmpty: result! !

!TIterateTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TIterateTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TIterateTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TIterateTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TIterateTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TIterateTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TIterateTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TIterateTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TIterateTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIterateTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TIterateTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TIterateTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TIterateTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TIterateTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TIterateTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TIterateTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TIterateTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TIterateTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TIterateTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TIterateTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TIterateTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TIterateTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TIterateTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TIterateTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TIterateTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TIterateTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TKTAbstractExecutor commentStamp: ''!
I am an abstract class defining the basic behaviour and state to execute a task:
  - the basic executeTask: method
  - an exception handler meant to manage unhandled exception!
!TKTAbstractExecutor methodsFor: 'polymorphism' stamp: ''!
stop
! !

!TKTAbstractExecutor methodsFor: 'accessing' stamp: ''!
noteFree

	busy := false! !

!TKTAbstractExecutor methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	busy := false.
	exceptionHandler := TKTConfiguration errorHandler! !

!TKTAbstractExecutor methodsFor: 'executing' stamp: ''!
executeTask: aTaskExecution
	[ self noteBusy.
	aTaskExecution noteRunningOn: self.
	aTaskExecution value.
	self noteFree ]
		on: Error
		do: [ :error | self exceptionHandler handleException: error ]! !

!TKTAbstractExecutor methodsFor: 'testing' stamp: ''!
isBusy

	^ busy! !

!TKTAbstractExecutor methodsFor: 'accessing' stamp: ''!
exceptionHandler
	^ exceptionHandler! !

!TKTAbstractExecutor methodsFor: 'testing' stamp: ''!
isFree

	^ busy not! !

!TKTAbstractExecutor methodsFor: 'accessing' stamp: ''!
exceptionHandler: aHandler
	
	exceptionHandler := aHandler! !

!TKTAbstractExecutor methodsFor: 'accessing' stamp: ''!
noteBusy

	busy := true! !

!TKTAbstractExecutor methodsFor: 'polymorphism' stamp: ''!
start
 " nothing to do "! !

!TKTAbstractExecutor methodsFor: 'testing' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTAbstractExecutor class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TKTAbstractExecutor class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TKTAbstractExecutor class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TKTAbstractExecutor class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TKTAbstractExecutor class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TKTAbstractExecutor class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TKTAbstractExecutor class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TKTAbstractExecutor class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TKTAbstractExecutor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TKTAbstractExecutor class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TKTAbstractExecutor class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TKTAbstractExecutor class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TKTAbstractExecutor class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TKTAbstractExecutor class methodsFor: 'testing' stamp: ''!
isAbstract

	^self == TKTAbstractExecutor ! !

!TKTAbstractExecutor class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TKTAbstractExecutor class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TKTAbstractExecutor class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TKTAbstractExecutor class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TKTAbstractExecutor class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TKTAbstractExecutor class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TKTAbstractExecutor class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TKTAbstractExecutor class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TKTAbstractExecutor class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!TKTAbstractExecutor class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!TKTAbstractExecutor class methodsFor: 'testing' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTAbstractExecutor class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!TKTAbstractExecutor class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TKTAbstractExecutor class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TKTAbstractExecutor class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TKTAbstractExecutor class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TKTAbstractExecutor class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TKTBasicTaskTest methodsFor: 'tests' stamp: ''!
testFutureExecutesConcurrently
	| results future1 future2 |
	results := OrderedCollection new.
	future1 := [ 100 milliSeconds wait.
	results addLast: 1 ] future.
	TKTConfiguration runner privateSpawnWorkerIfNeeded.
	future2 := [ 10 milliSeconds wait.
	results addLast: 2 ] future.
	TKTConfiguration runner privateSpawnWorkerIfNeeded.
	future1 waitForCompletion: 2 seconds.
	future2 waitForCompletion: 2 seconds.
	self assert: results asArray equals: #(2 1)! !

!TKTBasicTaskTest methodsFor: 'tests' stamp: ''!
testFutureExecutesByDefaultInGlobalWorkerPool
	| future |
	future := [ TKTConfiguration runner ] future.
	self assert: (future synchronizeTimeout: 1 second) equals: TKTConfiguration runner! !

!TKTBasicTaskTest methodsFor: 'tests' stamp: ''!
testFutureExecutes

	| done sema |
	done := false.
	sema := Semaphore new.
	[ done := true.
	sema signal ] future.
	sema wait.
	
	self assert: done
	
	! !

!TKTBasicTaskTest methodsFor: 'tests' stamp: ''!
testFutureWithFutureInsideSchedulesOk

	| future |

	future := [ [TKTConfiguration runner] schedule ] future.

	self shouldnt: (future synchronizeTimeout: 1 second) raise: UnhandledError.! !

!TKTBasicTaskTest methodsFor: 'tests' stamp: ''!
testScheduleExecutes
	| done sema |
	done := false.
	sema := Semaphore new.
	[ done := true.
	sema signal ] schedule.
	sema wait.
	self assert: done! !

!TKTBasicTaskTest methodsFor: 'tests' stamp: ''!
testFutureReturnsAssociatedFutureObject
	| done sema |
	done := false.
	sema := Semaphore new.
	[ done := true.
	done ] future onSuccessDo: [ :value | sema signal ].
	sema wait.
	self assert: done! !

!TKTCancelledTaskException commentStamp: ''!
I am an exception used to represent the cancellation of a task.!
!TKTCancelledTaskState commentStamp: ''!
I represent a cancelled task state. A cancelled task will fail to execute with an exception!
!TKTCancelledTaskState methodsFor: 'executing' stamp: ''!
performTaskExecution: aTaskExecution

	self signalCancelledException! !

!TKTCancelledTaskState methodsFor: 'cancelling' stamp: ''!
cancelTaskExecution: aTaskExecution reason: aReason

	self error: 'Task already cancelled'! !

!TKTCancelledTaskState methodsFor: 'executing' stamp: ''!
signalCancelledException

	TKTCancelledTaskException signal: reason! !

!TKTCancelledTaskState methodsFor: 'accessing' stamp: ''!
reason: aString 
	reason := aString! !

!TKTCancelledTaskState class methodsFor: 'instance creation' stamp: ''!
reason: aString 
	
	^ self new
		reason: aString;
		yourself! !

!TKTCommonQueueWorkerPool commentStamp: ''!
Common queue worker pool has in common queue. This makes that all the workers wait over the same queue !
!TKTCommonQueueWorkerPool methodsFor: 'schedulling' stamp: ''!
future: aTask
	^ aTask asTask future: self! !

!TKTCommonQueueWorkerPool methodsFor: 'public - mutexed' stamp: ''!
poolMaxSize: anInteger
	mutex critical: [ poolMaxSize := anInteger ]! !

!TKTCommonQueueWorkerPool methodsFor: 'schedulling' stamp: ''!
isWorker
	^ false ! !

!TKTCommonQueueWorkerPool methodsFor: 'public - mutexed' stamp: ''!
stop
	TKTConfiguration watchDog stopWatching: self.
	mutex
		critical: [ workers do: #stop.
			workers removeAll ]! !

!TKTCommonQueueWorkerPool methodsFor: 'public' stamp: ''!
purge
	taskQueue removeAll! !

!TKTCommonQueueWorkerPool methodsFor: 'private' stamp: ''!
privateManageWorkersBefore
	| free |
	free := self privateFreeWorkers.
	free size * 100 / (workers size max: 1) > 50
		ifTrue: [ self privateRemoveIdleWorkerIfNeeded ]! !

!TKTCommonQueueWorkerPool methodsFor: 'private' stamp: ''!
privateSpawnWorkerIfNeeded
	workers size < poolMaxSize
		ifTrue: [ self privateNewWorker ]! !

!TKTCommonQueueWorkerPool methodsFor: 'private' stamp: ''!
privateRemoveIdleWorkerIfNeeded
	| removing free |
	free := self privateFreeWorkers.
	free size < taskQueue size
		ifTrue: [ ^ self ].
	removing := free anyOne.
	workers remove: removing.
	removing stop.
	! !

!TKTCommonQueueWorkerPool methodsFor: 'public - mutexed' stamp: ''!
printOn: aStream
	| freeWorkers |
	freeWorkers := self privateFreeWorkers.
	aStream
		nextPutAll: 'TKTCommonQueueWorkerPool(';
		nextPutAll: 'name:';
		nextPutAll: name;
		nextPutAll: 'poolMaxSize: ';
		print: poolMaxSize;
		nextPutAll: '; busyWorkers: ';
		print: workers size - freeWorkers size;
		nextPutAll: '; freeWorkers: ';
		print: freeWorkers size;
		nextPutAll: ')'! !

!TKTCommonQueueWorkerPool methodsFor: 'public - mutexed' stamp: ''!
cleanUpImageToStart
	self stop.
	taskQueue removeAll.
	failedTasks removeAll.
	self start.! !

!TKTCommonQueueWorkerPool methodsFor: 'public' stamp: ''!
name: aString
	name := aString! !

!TKTCommonQueueWorkerPool methodsFor: 'schedulling' stamp: ''!
privateTimeout: timeout on: aTaskExecution
	timeout wait.
	aTaskExecution isFinished
		ifFalse: [ aTaskExecution cancelWithReason: 'Timeout after: ' , timeout asString ]! !

!TKTCommonQueueWorkerPool methodsFor: 'private' stamp: ''!
privateNewWorker
	workers
		add:
			(TKTWorker new
				name: self name , ' Worker #' , (self size + 1) asString;
				taskQueue: taskQueue;
				start)! !

!TKTCommonQueueWorkerPool methodsFor: 'private' stamp: ''!
privateFreeWorkers
	^ workers select: [ :each | each isFree ]! !

!TKTCommonQueueWorkerPool methodsFor: 'public - mutexed' stamp: ''!
reset
	mutex
		critical: [ self purge.
			workers do: #restart ]! !

!TKTCommonQueueWorkerPool methodsFor: 'accessing' stamp: ''!
taskQueueSize
	^ taskQueue size! !

!TKTCommonQueueWorkerPool methodsFor: 'configuration' stamp: ''!
isDebuggingCompatible
	^ true! !

!TKTCommonQueueWorkerPool methodsFor: 'private' stamp: ''!
privateManageWorkersAfter
	| free toremove |
	toremove := workers reject: #isRunning.
	toremove do: [ :w | w stop ].
	free := self privateFreeWorkers.
	taskQueue size > free size
		ifTrue: [ self privateSpawnWorkerIfNeeded ]! !

!TKTCommonQueueWorkerPool methodsFor: 'schedulling' stamp: ''!
privateSchedule: aTask
	| execution |
	execution := aTask asTask scheduleTaskExecutionFor: self.
	self scheduleTaskExecution: execution
	! !

!TKTCommonQueueWorkerPool methodsFor: 'public - mutexed' stamp: ''!
privateScheduleTaskExecutionFromCriticalArea: aTaskExecution
	taskQueue nextPut: aTaskExecution! !

!TKTCommonQueueWorkerPool methodsFor: 'public' stamp: ''!
workers
	^ workers copy! !

!TKTCommonQueueWorkerPool methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	workers := Set new.
	failedTasks := OrderedCollection new.
	taskQueue := AtomicSharedQueue new.
	mutex := Mutex new.
	self name: 'Worker' , self identityHash asString.
	! !

!TKTCommonQueueWorkerPool methodsFor: 'public' stamp: ''!
failedTasks
	^ failedTasks copy! !

!TKTCommonQueueWorkerPool methodsFor: 'public' stamp: ''!
ensureIsBeingWatched
	TKTConfiguration watchDog ensureIsWatching: self! !

!TKTCommonQueueWorkerPool methodsFor: 'schedulling' stamp: ''!
schedule: aTask timeout: aTimeout

	| execution |
	execution := TKTTimeoutableTaskExecution new.
	execution runner: self.
	execution task: aTask.
	execution timeout: aTimeout.
	
	self scheduleTaskExecution: execution.! !

!TKTCommonQueueWorkerPool methodsFor: 'schedulling' stamp: ''!
schedule: aTask
	aTask asTask schedule: self! !

!TKTCommonQueueWorkerPool methodsFor: 'schedulling' stamp: ''!
scheduleTimeout: timeout on: aTaskExecution
	TKTConfiguration processProvider
		createProcessDoing:
			(MessageSend
				receiver: self
				selector: #privateTimeout:on:
				arguments:
					{timeout.
					aTaskExecution})! !

!TKTCommonQueueWorkerPool methodsFor: 'public - mutexed' stamp: ''!
scheduleTaskExecution: aTaskExecution
	mutex
		critical: [ self ensureIsBeingWatched.
			self privateManageWorkersBefore.
			self privateScheduleTaskExecutionFromCriticalArea: aTaskExecution.
			self privateManageWorkersAfter ]! !

!TKTCommonQueueWorkerPool methodsFor: 'public - mutexed' stamp: ''!
ensureIsWorking
	mutex
		critical: [ failedTasks
				addAll:
					((self workers reject: #isRunning thenCollect: #currentTaskExecution)
						reject: #isNil).
			(workers reject: #isRunning)
				do: [ :w | 
					[ w stop ]
						on: Error
						do: [  ].
					workers remove: w ].
			self privateManageWorkersBefore.
			self privateManageWorkersAfter ]! !

!TKTCommonQueueWorkerPool methodsFor: 'public' stamp: ''!
size
	^ workers size! !

!TKTCommonQueueWorkerPool methodsFor: 'public' stamp: ''!
name
	^ name! !

!TKTCommonQueueWorkerPool methodsFor: 'schedulling' stamp: ''!
privateFuture: aTask
	| execution |
	execution := aTask asTask futureTaskExecutionFor: self.
	self scheduleTaskExecution: execution.
	^ execution future! !

!TKTCommonQueueWorkerPool methodsFor: 'public - mutexed' stamp: ''!
start
	self ensureIsBeingWatched! !

!TKTCommonQueueWorkerPool methodsFor: 'schedulling' stamp: ''!
isUIRunner
	^ false ! !

!TKTCommonQueueWorkerPool methodsFor: 'schedulling' stamp: ''!
isLocalThreadRunner
	^ false ! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TKTCommonQueueWorkerPool class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TKTCommonQueueWorkerPool class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TKTCommonQueueWorkerPool class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TKTCommonQueueWorkerPool class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TKTCommonQueueWorkerPool class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TKTCommonQueueWorkerPool class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TKTCommonQueueWorkerPool class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TKTCommonQueueWorkerPool class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TKTCommonQueueWorkerPool class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TKTCommonQueueWorkerPool class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TKTCommonQueueWorkerPool class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TKTCommonQueueWorkerPool class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TKTCommonQueueWorkerPool class methodsFor: 'current' stamp: ''!
createDefault
	^ self new
		name: 'CommonPool-' , UUID new asString;
		poolMaxSize: 4;
		yourself! !

!TKTCommonQueueWorkerPool class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!TKTCommonQueueWorkerPool class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!TKTCommonQueueWorkerPool class methodsFor: 'testing' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!TKTCommonQueueWorkerPool class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TKTCommonQueueWorkerPool class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TKTCommonQueueWorkerPool class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TKTCommonQueueWorkerPool class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TKTCommonQueueWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolDoesNotExceedPoolSizeWhenSchedulingTasksInParallel
	| pool totalTasks futures |
	pool := TKTCommonQueueWorkerPool new.
	pool poolMaxSize: 10.
	pool start.
	totalTasks := 0.
	futures := AtomicSharedQueue new.
	1 to: 10 do: [ :i | futures nextPut: (pool future: [ 10 timesRepeat: [ futures nextPut: (pool future: [ totalTasks := totalTasks + 1 ]) ] ]) ].
	[ futures isEmpty ] whileFalse: [ futures next waitForCompletion: 100 milliSeconds ].
	self assert: totalTasks equals: 100.
	self assert: pool size <= 10! !

!TKTCommonQueueWorkerPoolTest methodsFor: 'testing' stamp: ''!
expectedFailures

	"This tests fail on P7"
	SystemVersion current major <= 7 ifTrue: [ 
		^ #(
		testWorkerPoolWorkersAreStoppedAfterPoolsCollection
		testWorkerPoolWorkersProcessesAreStoppedAfterPoolsCollection
		) ].
	^ #()! !

!TKTCommonQueueWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolWorkersProcessesAreTerminatedAfterPoolsCollection

	| pool workerProcess |
	pool := TKTCommonQueueWorkerPool createDefault.
	(pool future: (MessageSend receiver: self selector: #yourself)) 
		waitForCompletion: 1 second.
	workerProcess := pool workers anyOne process process.
	pool := nil.
	self assertWithGarbageCollect: [ workerProcess isTerminated ].
! !

!TKTCommonQueueWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolWorkersProcessesAreStoppedAfterPoolsCollection

	| pool workerProcess |
	pool := TKTCommonQueueWorkerPool new.
	pool name: 'Test pool' , UUID new asString.
	pool poolMaxSize: 4.
	pool start.
	(pool future: (MessageSend receiver: self selector: #yourself)) 
		waitForCompletion: 1 second.
	workerProcess := WeakArray with: pool workers anyOne process process.
	pool := nil.
	self assertWithGarbageCollect: [ workerProcess first isNil ].
! !

!TKTCommonQueueWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolCretesWorkersWhenExecutingATask
	| pool |
	pool := TKTCommonQueueWorkerPool new.
	pool name: 'test pool'.
	pool poolMaxSize: 4.
	pool start.
	(pool future: [ 1 ]) waitForCompletion: 1 second.
	self assert: pool workers notEmpty! !

!TKTCommonQueueWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolWorkersAreStoppedAfterPoolsCollection

	| pool workerProcess |
	pool := TKTCommonQueueWorkerPool new.
	pool name: 'test pool' , UUID new asString.
	pool poolMaxSize: 4.
	pool start.
	(pool future: (MessageSend receiver: self selector: #yourself)) 
		waitForCompletion: 1 second.
	self assert: pool workers notEmpty.
	workerProcess := WeakArray with: pool workers anyOne process.
	pool := nil.
	
	self assertWithGarbageCollect: [ workerProcess first isNil ].! !

!TKTCommonQueueWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolDoesNotExceedPoolSize
	| pool |
	pool := TKTCommonQueueWorkerPool new.
	pool poolMaxSize: 4.
	pool start.
	((1 to: 100) collect: [ :i | pool future: [ 1 + 1 ] ]) do: [ :future | future waitForCompletion: 1 second ].
	1 second wait.
	self assert: pool size <=  4! !

!TKTCommonQueueWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolStopStopsWorkers

	| pool |
	pool := TKTCommonQueueWorkerPool new.
	pool poolMaxSize: 4.
	pool start.
		
	((1 to: 10) collect: [:i | pool future: [ 1 + 1 ] ])
		do: [ :future | future waitForCompletion: 500 milliSeconds. ].
	
	pool stop.
	
	pool workers do: [ :worker | self deny: worker isRunning ].! !

!TKTConfiguration commentStamp: ''!
TKTConfiguration is a dynamic variable thread local and thread safe. 

This configuration works as a global configuration for the TaskIt library.

The current value is always pointing a TKTProfile entity. 

For changing the actual profile, go to the settings browser, Taskit group

For defining profiles, add a class method in TKTProfile

!
!TKTConfiguration methodsFor: 'accessing' stamp: ''!
value: aValue
	value := aValue! !

!TKTConfiguration methodsFor: 'accessing' stamp: ''!
basicValue 
	^ value! !

!TKTConfiguration methodsFor: 'accessing' stamp: ''!
default
	
	^ value ifNil: [ 
			self class profile: TKTProfile defaultProfile.
			value ifNil: [ 
				self error: 'No default profile available.' ] ]! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
process: anObject during: aBlock
	^ self optionAt: #process value: anObject during: aBlock! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
watchDog
	^ self optionAt: #watchDog! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
profile
	^ #Hola! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
profiles
	^ TKTProfile profiles! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
optionAt: aKey
	^ self value value at: aKey! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
optionAt: aKey value: aValue during: aBlock
	| copy |
	copy := self value copy.
	copy value at: aKey put: aValue.
	^ self value: copy during: aBlock! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
poolWorkerProcess
	^ self optionAt: #poolWorkerProcess! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
resetSoleInstance 

	TKTWatchDog reset.
	super resetSoleInstance.! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
runner: aRunner during: aBlock
	^ self optionAt: #runner value: aRunner during: aBlock! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
runner
	^ self optionAt: #runner! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
profileNamed: aProfileName
	| profile |

	profile := (self profiles detect: [ :ass | ass key = aProfileName ]) value value.
	profile name: aProfileName.
	self profile: profile! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
serviceManager: aManager during: aBlock
	^ self optionAt: #serviceManager value: aManager during: aBlock! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
processProvider: aProcessProvider during: aBlock

	^ self 
		optionAt: #processProvider 
		value: aProcessProvider 
		during: aBlock! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
errorHandler: anErrorHandler during: aBlock
	^ self optionAt: #errorHandler value: anErrorHandler during: aBlock! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
profileNamed: aProfileName during: aBlock
	| return profile |
	profile := (self profiles detect: [ :ass | ass key = aProfileName ]) value value .
	profile name: aProfileName.
	return := self
		value: profile
		during: [ profile activateProfile.
			aBlock value ].
	profile finalizeProfile.
	^ return! !

!TKTConfiguration class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>

	(aBuilder group: #taskitExecution)
		label: 'Task it execution profile';
		with: [ 
			(aBuilder pickOne: #profileNamed)
				label: 'Exeucting Profile';
				target: self;
				parent: #taskitExecution;
				default: TKTProfile defaultProfileName;
				order: 1;
				domainValues: (self profiles collect: #key) ]! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
profile: aProfile
	self soleInstance basicValue ifNotNil: [ :p | p finalizeProfile ].
	self soleInstance value: aProfile.
	aProfile activateProfile! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
profile: aProfile during: aBlock
	| return |
	
	return := self value: aProfile during: [aProfile activateProfile. aBlock value].
	aProfile finalizeProfile.
	^ return! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
errorHandler
	^ self optionAt: #errorHandler! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
poolWorkerProcess: anObject during: aBlock
	^ self optionAt: #poolWorkerProcess value: anObject during: aBlock! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
process
	^ self optionAt: #process! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
profileNamed
	^ self value value name! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
processProvider
	^ self optionAt: #processProvider! !

!TKTConfiguration class methodsFor: 'accessing' stamp: ''!
serviceManager
	^ self optionAt: #serviceManager! !

!TKTExceptionHandler commentStamp: ''!
I am an abstract exception handler. When an unhandled error happens in a runner, it is forwarded to an exception handler using the #handleException: message.

Subclasses of me are meant to define different exception handling behaviours such as debugging or logging.!
!TKTExceptionHandler methodsFor: 'handling' stamp: ''!
handleException: anError 
	
	anError debug ! !

!TKTExceptionHandler class methodsFor: 'handling' stamp: ''!
handleException: anError
	^ self new handleException: anError! !

!TKTExceptionHandler class methodsFor: 'handling' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTFinishedTaskState commentStamp: ''!
I represent an already finished task state.  Both cancelling and performing a task that is already finished results in an exception.!
!TKTFinishedTaskState methodsFor: 'testing' stamp: ''!
isFinished

	^ true! !

!TKTFinishedTaskState methodsFor: 'executing' stamp: ''!
performTaskExecution: aTaskExecution

	self error: 'Task already finished'! !

!TKTFinishedTaskState methodsFor: 'cancelling' stamp: ''!
cancelTaskExecution: aTaskExecution reason: aReason

	self error: 'Task already finished'! !

!TKTFuture commentStamp: ''!
!! TKTFuture

In TaskIT we differentiate two different kind of tasks: some tasks are just scheduled for execution, they produce some side-effect and no result, some other tasks will produce (generally) a side-effect free value. When the result of a task is important for us, TaskIT provides us with a future object. A future is no other thing than an object that represents the future value of the task's execution. We can schedule a task with a future by using the future message on a block closure, as follows.

[[[language=smalltalk
aFuture := [ 2 + 2 ] future.
]]]

One way to see futures is as placeholders. When the task is finished, it deploys its result into the corresponding future. A future then provides access to its value, but since we cannot know when this value will be available, we cannot access it right away. Instead, futures provide an asynchronous way to access it's value by using callbacks. A callback is an object that will be executed when the task execution is finished.

In general terms, we do not want to force a future to retrieve his value in a synchronous way. By doing so, we would be going back to the synchronous world, blocking a process' execution, and not exploiting concurrency. Later sections will discuss about synchronous (blocking) retrieval of a future's value.
A future can provide two kind of results: either the task execution was a success or a failure. A success happens when the task completes in a normal way, while a failure happens when an uncatched exception is risen in the task. Because of these distinction, futures allow the subscription of two different callbacks using the methods onSuccessDo: and onFailureDo:.

In the example below, we create a future and subscribe to it a success callback. As soon as the task finishes, the value gets deployed in the future and the callback is called with it.

[[[language=smalltalk
aFuture := [ 2 + 2 ] future.
aFuture onSuccessDo: [ :result | result logCr ].
]]]

We can also subscribe callbacks that handle a task's failure using the onFailureDo: message. If an exception occurs and the task cannot finish its execution as expected, the corresponding exception will be passed as argument to the failure callback, as in the following example.

[[[language=smalltalk
aFuture := [ Error signal ] future.
aFuture onFailureDo: [ :error | error sender method selector logCr ].
]]]

Futures accept more than one callback. When its associated task is finished, all its callbacks will be scheduled for execution. In other words, the only guarantee that callbacks give us is that they will be all eventually executed. However, the future itself cannot guarantee neither when will the callbacks be executed, nor in which order. The following example shows how we can subscribe several success callbacks for the same future.

[[[language=smalltalk
future := [ 2 + 2 ] future.
future onSuccessDo: [ :v | FileStream stdout nextPutAll: v asString; cr ].
future onSuccessDo: [ :v | 'Finished' logCr ].
future onSuccessDo: [ :v | [ v factorial logCr ] schedule ].
future onFailureDo: [ :error | error logCr ].
]]]

Callbacks work wether the task is still running or already finished. If the task is running, callbacks are registered and wait for the completion of the task. If the task is already finished, the callback will be immediately scheduled with the already deployed value. See below a code examples that illustrates this: we first create a future and subscribes a callback before it is finished, then we wait for its completion and subscribe a second callback afterwards. Both callbacks are scheduled for execution.

[[[language=smalltalk
future := [ 1 second wait. 2 + 2 ] future.
future onSuccessDo: [ :v | v logCr ].

2 seconds wait.
future onSuccessDo: [ :v | v logCr ].
]]]

!!!! Combinators

Futures are a nice asynchronous way to obtain the results of our eventually executed tasks. However, as we do not know when tasks will finish, processing that result will be another asynchronous task that needs to start as soon as the first one finishes. To simplify the task of future management, TaskIT futures come along with some combinators.

!!!!!! Value combinators

- The collect: combinator
The collect: combinator does, as its name says, the same than the collection's API: it transforms a result using a transformation.

[[[language=smalltalk
future := [ 2 + 3 ] future.
(future collect: [ :number | number factorial ])
    onSuccessDo: [ :result | result logCr ].
]]]

The collect: combinator returns a new future whose value will be the result of transforming the first future's value.

- The select: combinator
The select: combinator does, as its name says, the same than the collection's API: it filters a result satisfying a condition.

[[[language=smalltalk
future := [ 2 + 3 ] future.
(future select: [ :number | number even ])
    onSuccessDo: [ :result | result logCr ];
    onFailureDo: [ :error | error logCr ].
]]]

The select: combinator returns a new future whose result is the result of the first future if it satisfies the condition. Otherwise, its value will be a NotFound exception.

- The flatCollect:combinator
The flatCollect: combinator is similar to the collect: combinator, as it transforms the result of the first future using the given transformation block. However, flatCollect: excepts as the result of its transformation block a future.

[[[language=smalltalk
future := [ 2 + 3 ] future.
(future flatCollect: [ :number | [ number factorial ] future ])
    onSuccessDo: [ :result | result logCr ].
The flatCollect: combinator returns a new future whose value will be the result the value of the future yielded by the transformation.
]]]

- The zip:combinator
The zip: combinator combines two futures into a single future that returns an array with both results.

[[[language=smalltalk
future1 := [ 2 + 3 ] future.
future2 := [ 18 factorial ] future.
(future1 zip: future2)
    onSuccessDo: [ :result | result logCr ].
]]]

zip: works only on success: the resulting future will be a failure if any of the futures is also a failure.

- The on:do:combinator
The on:do: allows us to transform a future that fails with an exception into a future with a result.

[[[language=smalltalk
future := [ Error signal ] future
    on: Error do: [ :error | 5 ].
future onSuccessDo: [ :result | result logCr ].
]]]

!!!!!! Synchronization Combinators

- The fallbackTo: combinator
The fallbackTo: combinator combines two futures in a way such that if the first future fails, it is the second one that will be taken into account.

[[[language=smalltalk
failFuture := [ Error signal ] future.
successFuture := [ 1 + 1 ] future.
(failFuture fallbackTo: successFuture)
    onSuccessDo: [ :result | result logCr ].
]]]

In other words, fallbackTo: produces a new future whose value is the first's future value if success, or it is the second future's value otherwise.

- The firstCompleteOf: combinator
The firstCompleteOf: combinator combines two futures resulting in a new future whose value is the value of the future that finishes first, wether it is a success or a failure.

[[[language=smalltalk
failFuture := [ 1 second wait. Error signal ] future.
successFuture := [ 1 second wait. 1 + 1 ] future.
(failFuture firstCompleteOf: successFuture)
    onSuccessDo: [ :result | result logCr ];
    onFailureDo: [ :error | error logCr ].
]]]

In other words, fallbackTo: produces a new future whose value is the first's future value if success, or it is the second future's value otherwise.

- The andThen: combinator
The andThen: combinator allows to chain several futures to a single future's value. All futures chained using the andThen: combinator are guaranteed to be executed sequenceally (in contrast to normal callbacks), and all of them will receive as value the value of the first future (instead of the of of it's preceeding future).

[[[language=smalltalk
[ 1 + 1 ] future
    andThen: [ :result | result logCr ];
    andThen: [ :result | FileStream stdout nextPutAll: result ]. 
]]]

This combinator is meant to enforce the order of execution of several actions, and this it is mostly for side-effect purposes where we want to guarantee such order.!
!TKTFuture methodsFor: 'combinators' stamp: ''!
flatCollect: aBlockClosure 
	
	| future |
	future := TKTFuture new.
	future runner: runner.
	self onSuccessDo: [ :got | [(aBlockClosure value: got)
		onSuccessDo: [ :got2 | future deploySuccess: got2 ];
		onFailureDo: [ :error | future deployFailure: error freeze ]]
				on: Error do: [ :e | future deployFailure: e freeze ] ].
	self onFailureDo: [ :error | future deployFailure: error freeze ].
	^ future! !

!TKTFuture methodsFor: 'callbacks' stamp: ''!
scheduleCallbackTask: aCallbackTask
	runner schedule: aCallbackTask! !

!TKTFuture methodsFor: 'accessing' stamp: ''!
runner: aRunner

	runner := aRunner! !

!TKTFuture methodsFor: 'combinators' stamp: ''!
andThen: aBlockClosure 
	
	| future |
	future := TKTFuture new.
	self onSuccessDo: [ :got | 
		[ aBlockClosure value: got ]
			on: Error do: [ :e | "Nothing?" ].
		future deploySuccess: got ].
	self onFailureDo: [ :error | future deployFailure: error freeze ].
	^ future! !

!TKTFuture methodsFor: 'combinators' stamp: ''!
recoverWith: aBlock
	
	| future |
	future := TKTFuture new.
	future runner: runner.
	self onSuccessDo: [ :value | future deploySuccess: value ].
	self onFailureDo: [ :error | | recoverFuture |
		recoverFuture := aBlock value: error.
		recoverFuture onSuccessDo: [ :value | future deploySuccess: value ].
		recoverFuture onFailureDo: [ :value | future deployFailure: value freeze ] ].	
	^ future! !

!TKTFuture methodsFor: 'combinators' stamp: ''!
select: aBlockClosure 
	
	^ self collect: [ :r | (aBlockClosure value: r) ifTrue: [ r ] ifFalse: [ NotFound signalFor: aBlockClosure ] ].
	! !

!TKTFuture methodsFor: 'callbacks' stamp: ''!
onSuccessDo: aCallback

	result onSuccessDo: aCallback inFuture: self! !

!TKTFuture methodsFor: 'synchronization' stamp: ''!
waitForCompletion: aTimeout

	self isFinished ifFalse: [ | expired |
		expired := valueSemaphore waitTimeoutMSecs: aTimeout asMilliSeconds.
		expired ifTrue: [ TKTTimeoutException signal ] ]! !

!TKTFuture methodsFor: 'deployment' stamp: ''!
deployFailure: aValue
	self installResult: (TKTFutureFailure new value: aValue).
	exceptionCallbacks
		do: [ :each | self scheduleCallbackTask: [ each value: aValue ] ].
	valueSemaphore signal! !

!TKTFuture methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream
		nextPutAll: '(finished=';
		nextPutAll: self isFinished asString;
		nextPutAll: ';value=';
		nextPutAll: result asString;
		nextPutAll: ')'! !

!TKTFuture methodsFor: 'private' stamp: ''!
installResult: aResult

	result isFinished
		ifTrue: [ self error: 'cannot deploy twice in same future' ].
	result := aResult! !

!TKTFuture methodsFor: 'combinators' stamp: ''!
collect: aBlockClosure
	| future |
	future := TKTFuture new.
	future runner: runner.
	self
		onSuccessDo: [ :got | 
			[ future deploySuccess: (aBlockClosure value: got) ]
				on: Error
				do: [ :e | future deployFailure: e freeze ] ].
	self onFailureDo: [ :error | future deployFailure: error freeze ].
	^ future! !

!TKTFuture methodsFor: 'combinators' stamp: ''!
fallbackTo: aFallbackFuture 
	
	^ self recoverWith: [ :error | aFallbackFuture ]! !

!TKTFuture methodsFor: 'testing' stamp: ''!
isFinished

	^ result isFinished! !

!TKTFuture methodsFor: 'testing' stamp: ''!
isFailure

	^ result isFailure! !

!TKTFuture methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	result := TKTFutureNotFinished new.
	runner := TKTConfiguration runner.

	valueSemaphore := Semaphore new.

	exceptionCallbacks := OrderedCollection new.
	resultCallbacks := OrderedCollection new.! !

!TKTFuture methodsFor: 'callbacks' stamp: ''!
addFailureCallback: aBlockClosure

	exceptionCallbacks add: aBlockClosure! !

!TKTFuture methodsFor: 'combinators' stamp: ''!
on: anError do: aBlockClosure 
	
	| future |
	future := TKTFuture new.
	future runner: runner.
	self onSuccessDo: [ :got | future deploySuccess: got ].
	self onFailureDo: [ :error | 
		(anError handles: error)
			ifTrue: [ [future deploySuccess: (aBlockClosure value: error)]
							on: Error do: [ :e | future deployFailure: e freeze ]  ]
			ifFalse: [ future deployFailure: error freeze ] ].
	^ future! !

!TKTFuture methodsFor: 'callbacks' stamp: ''!
onFailureDo: aBlockClosure 
	
	result onFailureDo: aBlockClosure inFuture: self! !

!TKTFuture methodsFor: 'callbacks' stamp: ''!
addSuccessCallback: aBlockClosure 
	
	resultCallbacks add: aBlockClosure! !

!TKTFuture methodsFor: 'combinators' stamp: ''!
zip: secondFuture
	
	^ self zip: secondFuture with: [ :a :b | Array with: a with: b ]! !

!TKTFuture methodsFor: 'combinators' stamp: ''!
zip: secondFuture with: aBlock
	
	^ self flatCollect: [ :result1 | secondFuture collect: [ :result2 | aBlock value: result1 value: result2 ] ]! !

!TKTFuture methodsFor: 'testing' stamp: ''!
isSuccess

	^ result isSuccess! !

!TKTFuture methodsFor: 'combinators' stamp: ''!
firstCompleteOf: anotherFuture
	
	| finished future |
	finished := false.
	future := TKTFuture new.
	future runner: runner.
	self onSuccessDo: [ :v |
		finished ifFalse: [
			finished := true.
			future deploySuccess: v ]].
	self onFailureDo: [ :v |
		finished ifFalse: [
			finished := true.
			future deployFailure: v freeze ]].
	anotherFuture onSuccessDo: [ :v |
		finished ifFalse: [
			finished := true.
			future deploySuccess: v ]].
	anotherFuture onFailureDo: [ :v |
		finished ifFalse: [
			finished := true.
			future deployFailure: v freeze ]].
	^ future! !

!TKTFuture methodsFor: 'synchronization' stamp: ''!
synchronizeTimeout: aTimeout
	
	self waitForCompletion: aTimeout.
	^ result valueForFuture: self! !

!TKTFuture methodsFor: 'deployment' stamp: ''!
deploySuccess: aValue
	self installResult: (TKTFutureSuccess new value: aValue).
	resultCallbacks
		do: [ :each | self scheduleCallbackTask: [ each value: aValue ] ].
	valueSemaphore signal! !

!TKTFuture class methodsFor: 'instance creation' stamp: ''!
fromCollectionOfFutures: aCollectionOfFutures

	^ self
		reduceCollectionOfFutures: aCollectionOfFutures
		with: [ :acum :each | acum add: each. acum ] ! !

!TKTFuture class methodsFor: 'instance creation' stamp: ''!
reduceCollectionOfFutures: aCollectionOfFutures with: aBlock

	^ aCollectionOfFutures
		inject: (TKTFuture of: OrderedCollection new)
		into: [ :facum :feach | facum flatCollect: [ :acum | 
				feach collect: [ :each | aBlock value: acum value: each ] ] ]! !

!TKTFuture class methodsFor: 'instance creation' stamp: ''!
of: aValue

	^ self new deploySuccess: aValue! !

!TKTFuture class methodsFor: 'instance creation' stamp: ''!
doing: aBlock

	^ TKTConfiguration runner future: aBlock! !

!TKTFutureExecution commentStamp: ''!
I represent a task execution with a result: I have an associated future where I will deploy my result, as either a success or a failure.!
!TKTFutureExecution methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	future := TKTFuture new.
	! !

!TKTFutureExecution methodsFor: 'accessing' stamp: ''!
runner: aRunner

	super runner: aRunner.
	future runner: aRunner.! !

!TKTFutureExecution methodsFor: 'evaluating' stamp: ''!
doExecuteTask
	[ future deploySuccess: super doExecuteTask ]
		on: Error
		do: [ :error | future deployFailure: error freeze ]! !

!TKTFutureExecution methodsFor: 'accessing' stamp: ''!
future

	^ future! !

!TKTFutureFailure commentStamp: ''!
I represent a the result of a failured task.

I ignore success callbacks and schedule for execution failure callbacks!
!TKTFutureFailure methodsFor: 'accessing' stamp: ''!
value: aValue

	value := aValue! !

!TKTFutureFailure methodsFor: 'testing' stamp: ''!
isFailure

	^ true! !

!TKTFutureFailure methodsFor: 'accessing' stamp: ''!
value
	
	value signal! !

!TKTFutureFailure methodsFor: 'accessing' stamp: ''!
valueForFuture: aFuture
	
	 value signal! !

!TKTFutureFailure methodsFor: 'accessing' stamp: ''!
onFailureDo: aBlockClosure inFuture: aFuture
	
	aFuture scheduleCallbackTask: [ aBlockClosure value: value ]! !

!TKTFutureNotFinished commentStamp: ''!
I represent a not yet finished future. Not yet finished futures cannot really schedule callbacks: they will add the callbacks in the given future to be executed when the value is deployed.!
!TKTFutureNotFinished methodsFor: 'testing' stamp: ''!
isFinished

	^ false! !

!TKTFutureNotFinished methodsFor: 'callbacks' stamp: ''!
onSuccessDo: aBlockClosure inFuture: aFuture
	
	aFuture addSuccessCallback: aBlockClosure! !

!TKTFutureNotFinished methodsFor: 'callbacks' stamp: ''!
onFailureDo: aBlockClosure inFuture: aFuture
	
	aFuture addFailureCallback: aBlockClosure! !

!TKTFutureState commentStamp: ''!
I represent the state of a future. A future can be in three different states represented by my subclasses:

 - Not yet finished
 - Success
 - Failure

A future starts in a Not yet finished state and goes either to the Failure or Success state depending on how the executed task finishes.
I am a stateless implementation of the state pattern. Thus, my messages receive the corresponding future as argument.

My main messages are:

 - #isFinished 
    testing if a future is indeed finished
 - onSuccessDo:inFuture:
    scheduling a callback in the given future in case of success
 - onFailureDo:inFuture:
    scheduling a callback in the given future in case of failure!
!TKTFutureState methodsFor: 'testing' stamp: ''!
isFinished
	
	^ true! !

!TKTFutureState methodsFor: 'testing' stamp: ''!
isFailure

	^ false! !

!TKTFutureState methodsFor: 'testing' stamp: ''!
isSuccess

	^ false! !

!TKTFutureState methodsFor: 'callbacks' stamp: ''!
onSuccessDo: aBlockClosure inFuture: aFuture
	
	"nothing"! !

!TKTFutureState methodsFor: 'callbacks' stamp: ''!
onFailureDo: aBlockClosure inFuture: aFuture

	"nothing"! !

!TKTFutureSuccess commentStamp: ''!
I represent a the result of a success task.

I ignore failure callbacks and schedule for execution success callbacks!
!TKTFutureSuccess methodsFor: 'accessing' stamp: ''!
value: aValue

	value := aValue! !

!TKTFutureSuccess methodsFor: 'accessing' stamp: ''!
basicValue

	^ value! !

!TKTFutureSuccess methodsFor: 'accessing' stamp: ''!
value

	^ value! !

!TKTFutureSuccess methodsFor: 'testing' stamp: ''!
isSuccess

	^ true! !

!TKTFutureSuccess methodsFor: 'callbacks' stamp: ''!
onSuccessDo: aBlockClosure inFuture: aFuture
	
	aFuture scheduleCallbackTask: [ aBlockClosure value: value ]! !

!TKTFutureSuccess methodsFor: 'accessing' stamp: ''!
valueForFuture: aFuture

	^ value! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFlatCollectSuccessOnMappedFutureSuccess

	| future got innerFuture |
	future := TKTFuture new.	
	innerFuture := TKTFuture new.
	(future flatCollect: [ :v | innerFuture ]) onSuccessDo: [ :v | got := v ].
	
	future deploySuccess: 2.
	innerFuture deploySuccess: 42.
	50 milliSecond wait.
	
	self assert: got equals: 42! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureAndThenFailsIfFirstFails
	| future collection thenFuture got error |
	future := TKTFuture new.
	collection := OrderedCollection new.
	thenFuture := future
		andThen: [ :v | collection add: v + 1 ];
		andThen: [ :v | collection add: v + 2 ];
		andThen: [ :v | collection add: v + 3 ].
	thenFuture onFailureDo: [ :e | got := e ].
	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | future deployFailure: e ].
	50 milliSecond wait.
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureZipSuccessIfBothSuccess

	| future zipFuture got |
	future := TKTFuture new.
	zipFuture := TKTFuture new.
	
	(future zip: zipFuture) onSuccessDo: [ :tuple | got := tuple ].

	future deploySuccess: 2.
	zipFuture deploySuccess: 5.
	50 milliSecond wait.
	
	self assert: got equals: #(2 5)! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureSuccessCallbackIsNotCalledIfFailureWasAlreadyDeployed

	| future got |
	future := TKTFuture new.
	future deployFailure: Error new.
		
	future onSuccessDo: [ :value | got := value ].

	self assert: got equals: nil! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureSuccessCallbackIsCalledIfValueWasAlreadyDeployed

	| future got |
	future := TKTFuture new.
	future deploySuccess: 2.
		
	future onSuccessDo: [ :value | got := value ].

	50 milliSeconds wait.

	self assert: got equals: 2! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureExecutesInNewProcessRunner
	| runner future currentRunner |
	runner := TKTNewProcessTaskRunner new.
	future := runner future: [ currentRunner := TKTConfiguration runner ].
	future waitForCompletion: 1 second.
	self assert: currentRunner equals: runner! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFlatCollectFailsOnFailingMapFunction

	| future got error |
	future := TKTFuture new.	
	error := Error new.
	(future flatCollect: [ :v | error signal ]) onFailureDo: [ :v | got := v ].
	
	future deploySuccess: 2.
	50 milliSecond wait.

	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureOnDoSucceedsOnTrappingCorrectException
	| future got error |
	future := TKTFuture new.
	(future
		on: Error
		do: [ :v | 5 ]) onSuccessDo: [ :v | got := v ].
	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | future deployFailure: e ].
	50 milliSecond wait.
	self assert: got equals: 5! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureAndThenExecutesInOrder

	| future collection |
	future := TKTFuture new.
	collection := OrderedCollection new.
	
	future
		andThen: [ :v | collection add: v + 1 ];
		andThen: [ :v | collection add: v + 2 ];
		andThen: [ :v | collection add: v + 3 ].

	future deploySuccess: 0.
	50 milliSecond wait.
	
	self assert: collection asArray equals: #( 1 2 3)! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureFailureCallbackExecutesInSameLocalProcessRunner
	| runner future currentRunner |
	runner := TKTLocalProcessTaskRunner new.
	future := runner future: [ Error signal ].
	future onFailureDo: [ :r | currentRunner := TKTConfiguration runner ].
	future waitForCompletion: 1 second.
	50 milliSecond wait.
	self assert: currentRunner equals: runner! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureSuccessCallbackExecutesInSameWorker
	| runner future currentRunner |
	runner := TKTWorker new start.
	future := runner future: [ 1 + 1 ].
	future onSuccessDo: [ :r | currentRunner := TKTConfiguration runner ].
	future waitForCompletion: 1 second.
	self assert: currentRunner equals: runner! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureSuccessCallbackExecutesInSameWorkerRunner
	| runner future currentRunner |
	runner := TKTWorker new start.
	future := runner future: [ 1 + 1 ].
	future onSuccessDo: [ :r | currentRunner := TKTConfiguration runner ].
	future waitForCompletion: 1 second.
	self assert: currentRunner equals: runner! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureSuccessCallbackIsCalledAfterValueIsDeployed

	| future got |
	future := TKTFuture new.
	future onSuccessDo: [ :value | got := value ].
	
	future deploySuccess: 2.
	50 milliSecond wait.
	
	self assert: got equals: 2! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureSelectFailsOnNonSatisfyingCondition

	| future got |
	future := TKTFuture new.	
	(future select: [ :v | v even ]) onFailureDo: [ :v | got := v ].
	
	future deploySuccess: 3.
	50 milliSecond wait.
	
	self assert: (got isKindOf: NotFound)! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFirstCompleteOfSuccessIfFirstSuccessFaster
	| future got secondFuture error |
	future := TKTFuture new.
	secondFuture := TKTFuture new.
	(future firstCompleteOf: secondFuture) onSuccessDo: [ :v | got := v ].
	future deploySuccess: 5.
	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | secondFuture deployFailure: e ].
	50 milliSecond wait.
	self assert: got equals: 5! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureOnDoFailsOnFailingExceptionHandler
	| future got error error2 |
	future := TKTFuture new.
	error := Error new.
	(future
		on: Error
		do: [ :v | error signal ]) onFailureDo: [ :v | got := v ].
	error2 := Error new.
	[ error2 signal ]
		on: Error
		do: [ :e | future deployFailure: e ].
	50 milliSecond wait.
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFallbackToHasFirstValueIfFirstSuccess

	| future got fallbackFuture |
	future := TKTFuture new.
	fallbackFuture := TKTFuture new.	

	(future fallbackTo: fallbackFuture) onSuccessDo: [ :v | got := v ].
	
	future deploySuccess: 2.
	50 milliSecond wait.

	self assert: got equals: 2! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFlatCollectFailsOnMappedFutureFailure
	| future got error innerFuture |
	future := TKTFuture new.
	innerFuture := TKTFuture new.
	(future flatCollect: [ :v | innerFuture ]) onFailureDo: [ :v | got := v ].
	future deploySuccess: 2.
	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | innerFuture deployFailure: e ].
	50 milliSecond wait.
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFirstCompleteOfFailsIfFirstFailsFaster

	| future got secondFuture error |
	future := TKTFuture new.
	secondFuture := TKTFuture new.
	
	(future firstCompleteOf: secondFuture) onFailureDo: [ :v | got := v ].

	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | future deployFailure: e ].
	secondFuture deploySuccess: 1.
	50 milliSecond wait.

	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testCannotDeployFailureTwiceIntoFuture

	| future |
	future := TKTFuture new.
	future deployFailure: Error new.
	self should: [future deployFailure: Error new] raise: Error.! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureSuccessCallbackExecutesInSameNewProcessRunner
	| runner future currentRunner |
	runner := TKTNewProcessTaskRunner new.
	future := runner future: [ 1 + 1 ].
	future onSuccessDo: [ :r | currentRunner := TKTConfiguration runner ].
	future waitForCompletion: 1 second.
	self assert: currentRunner equals: runner! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFallbackToHasSecondValueIfFirstFailsAndSecondSuccess

	| future got fallbackFuture |
	future := TKTFuture new.
	fallbackFuture := TKTFuture new.	

	(future fallbackTo: fallbackFuture) onSuccessDo: [ :v | got := v ].

	fallbackFuture deploySuccess: 2.
	future	 deployFailure: Error new.
	50 milliSecond wait.

	self assert: got equals: 2! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureSelectFailsOnFailingPredicate

	| future got error |
	future := TKTFuture new.	
	error := Error new.

	(future select: [ :v | error signal ]) onFailureDo: [ :v | got := v ].

	future deploySuccess: 2.
	50 milliSecond wait.
	
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureOnDoSucceedsOnSuccess

	| future got |
	future := TKTFuture new.	
	(future on: Error do: [ :v | 5 ]) onSuccessDo: [ :v | got := v ].

	future deploySuccess: 2.
	50 milliSecond wait.
	
	self assert: got equals: 2! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureSuccessCallbackExecutesInNewProcess

	| runner future processIds processIdsSet |
	processIds := AtomicSharedQueue new.
	
	runner := TKTNewProcessTaskRunner new.
	future := runner future: [ 1 + 1 ].
	
	30 timesRepeat: [
		future onSuccessDo: [ :r | processIds nextPut: Processor activeProcess identityHash ] ].
	
	1 second wait.
	
	processIdsSet := Set new.
	[processIds isEmpty] whileFalse: [ processIdsSet add: processIds next ].
	
	self assert: processIdsSet size equals: 30.! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureZipFailsIfFirstFails

	| future zipFuture got error |
	future := TKTFuture new.
	zipFuture := TKTFuture new.
	
	(future zip: zipFuture) onFailureDo: [ :tuple | got := tuple ].

	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | future deployFailure: e ].
	zipFuture deploySuccess: 5.
	50 milliSecond wait.
	
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testCannotDeployTwiceIntoFuture

	| future |
	future := TKTFuture new.
	future deploySuccess: 2.
	self should: [future deploySuccess: 3] raise: Error.! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureAndThenThenFailuresAreJustSkipped

	| future collection thenFuture |
	future := TKTFuture new.
	collection := OrderedCollection new.
	
	thenFuture := future
		andThen: [ :v | collection add: v + 1 ];
		andThen: [ :v | self error ];
		andThen: [ :v | collection add: v + 3 ].

	future deploySuccess: 2.
	50 milliSecond wait.
	
	self assert: collection asArray equals: #(3 5)! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFlatCollectFailsOnSelfFailure
	| future got error innerFuture |
	future := TKTFuture new.
	innerFuture := TKTFuture new.
	(future flatCollect: [ :v | innerFuture ]) onFailureDo: [ :v | got := v ].
	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | future deployFailure: e ].
	50 milliSecond wait.
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - termination' stamp: ''!
testNewFutureIsNotFinished

	| future |
	future := TKTFuture new.	
	self assert: future isFinished not! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFallbackToFailsIfBothFail
	| future got fallbackFuture error |
	future := TKTFuture new.
	fallbackFuture := TKTFuture new.
	(future fallbackTo: fallbackFuture) onFailureDo: [ :v | got := v ].
	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | fallbackFuture deployFailure: e ].
	future deployFailure: Error new.
	50 milliSecond wait.
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureFailureCallbackExecutesInSameWorker
	| runner future currentRunner |
	runner := TKTWorker new start.
	future := runner future: [ Error signal ].
	future onFailureDo: [ :r | currentRunner := TKTConfiguration runner ].
	future waitForCompletion: 1 second.
	100 milliSeconds wait.
	self assert: currentRunner equals: runner! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureFailureCallbackIsCalledIfFailureWasAlreadyDeployed

	| future got deployedError |
	future := TKTFuture new.
	future onFailureDo: [ :error | got := error ].
	
	deployedError := Error new.
	future deployFailure: deployedError.
	50 milliSecond wait.
	
	self assert: got equals: deployedError! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureFailureCallbackExecutesInSameNewProcessRunner
	| runner future currentRunner |
	runner := TKTNewProcessTaskRunner new.
	future := runner future: [ Error signal ].
	future onFailureDo: [ :r | currentRunner := TKTConfiguration runner ].
	future waitForCompletion: 1 second.
	50 milliSecond wait.
	self assert: currentRunner equals: runner! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureCollectFailsOnFailingMapFunction
	| future got error |
	future := TKTFuture new.
	error := Error new.
	(future collect: [ :v | error signal ]) onFailureDo: [ :v | got := v ].
	future deploySuccess: 2.
	50 milliSecond wait.
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureOnDoFailsOnTrappingWrongException
	| future got error |
	future := TKTFuture new.
	(future
		on: NotFound
		do: [ :v | 5 ]) onFailureDo: [ :v | got := v ].
	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | future deployFailure: e ].
	50 milliSecond wait.
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	TKTConfiguration runner reset! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureSelectFailsOnFailure
	| future got error |
	future := TKTFuture new.
	(future select: [ :v | v even ]) onFailureDo: [ :v | got := v ].
	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | future deployFailure: e ].
	50 milliSecond wait.
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureExecutesInSameLocalProcessRunner

	| runner future currentRunner |
	runner := TKTLocalProcessTaskRunner new.
	future := runner future: [ currentRunner := TKTConfiguration runner].	
	future waitForCompletion: 1 second.
	
	self assert: currentRunner equals: runner! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureCollectFailsOnFailure
	| future got error |
	future := TKTFuture new.
	(future collect: [ :v | v * 5 ]) onFailureDo: [ :v | got := v ].
	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | future deployFailure: e ].
	50 milliSecond wait.
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureFailureCallbackIsCalledAfterFailureIsDeployed

	| future got deployedError |
	future := TKTFuture new.	
	deployedError := Error new.
	future deployFailure: deployedError.
	
	future onFailureDo: [ :error | got := error ].
	50 milliSeconds wait.
	
	self assert: got equals: deployedError! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureCollectSuccessOnSuccess

	| future got |
	future := TKTFuture new.	

	(future collect: [ :v | v * 5 ]) onSuccessDo: [ :v | got := v ].
	
	future deploySuccess: 2.
	50 milliSecond wait.
	
	self assert: got equals: 10! !

!TKTFutureTest methodsFor: 'tests - callbacks' stamp: ''!
testFutureSuccessCallbackExecutesInSameLocalProcessRunner
	| runner future currentRunner |
	runner := TKTLocalProcessTaskRunner new.
	future := runner future: [ 1 + 1 ].
	future onSuccessDo: [ :r | currentRunner := TKTConfiguration runner ].
	future waitForCompletion: 1 second.
	self assert: currentRunner equals: runner! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureAndThenSuccessIfAndThenFails

	| future collection thenFuture got |
	future := TKTFuture new.
	collection := OrderedCollection new.
	
	thenFuture := future
		andThen: [ :v | collection add: v + 1 ];
		andThen: [ :v | self error ];
		andThen: [ :v | collection add: v + 3 ].

	thenFuture onSuccessDo: [ :e | got := e ].
	
	future deploySuccess: 2.
	50 milliSecond wait.
	
	self assert: got equals: 2! !

!TKTFutureTest methodsFor: 'tests - termination' stamp: ''!
testFutureIsFinishedIfValueWasAlreadyDeployed

	| future |
	future := TKTFuture new.
	future deploySuccess: 2.
		
	self assert: future isFinished! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFirstCompleteOfSuccessIfSecondSuccessFaster

	| future got secondFuture |
	future := TKTFuture new.
	secondFuture := TKTFuture new.
	
	(future firstCompleteOf: secondFuture) onSuccessDo: [ :v | got := v ].

	secondFuture deploySuccess: 5.
	future deployFailure: Error new.
	50 milliSecond wait.
	
	self assert: got equals: 5! !

!TKTFutureTest methodsFor: 'tests - termination' stamp: ''!
testFutureIsFinishedIfFailureWasAlreadyDeployed
	| future error |
	
	future := TKTFuture new.
	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | future deployFailure: e ].
	self assert: future isFinished! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureZipFailsIfSecondFails

	| future zipFuture got error |
	future := TKTFuture new.
	zipFuture := TKTFuture new.
	
	(future zip: zipFuture) onFailureDo: [ :tuple | got := tuple ].

	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | zipFuture deployFailure: e ].

	future deploySuccess: 5.
	50 milliSecond wait.
	
	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureFirstCompleteOfFailsIfSecondFailsFaster

	| future got secondFuture error |
	future := TKTFuture new.
	secondFuture := TKTFuture new.
	
	(future firstCompleteOf: secondFuture) onFailureDo: [ :v | got := v ].

	error := Error new.
	[ error signal ]
		on: Error
		do: [ :e | secondFuture deployFailure: e ].
	future deploySuccess: 1.
	50 milliSecond wait.

	self assert: got equals: error! !

!TKTFutureTest methodsFor: 'tests - combinators' stamp: ''!
testFutureSelectSuccessOnSatisfyingCondition

	| future got |
	future := TKTFuture new.	
	(future select: [ :v | v even ]) onSuccessDo: [ :v | got := v ].
	
	future deploySuccess: 2.
	50 milliSecond wait.
	
	self assert: got equals: 2! !

!TKTGenericTask commentStamp: ''!
I am a generic task that can be created from a valuable!
!TKTGenericTask methodsFor: 'executing' stamp: ''!
evaluateOn: aTaskExecution
	^ valuable value! !

!TKTGenericTask methodsFor: 'accessing' stamp: ''!
valuable: aValuable
	valuable := aValuable! !

!TKTGenericTask methodsFor: 'accessing' stamp: ''!
valuable
	^ valuable! !

!TKTLocalProcessTaskRunner commentStamp: ''!
!! TKTLocalProcessTaskRunner

The local process runner, instance of TKTLocalProcessTaskRunner, is a task runner that executes a task in the caller process. In other words, this task runner does not run concurrently. Executing the following piece of code:

[[[language=smalltalk
aRunner := TKTLocalProcessTaskRunner new.
future := aRunner schedule: [ 1 second wait ].
]]]

is equivalent to the following piece of code:

[[[language=smalltalk
[ 1 second wait ] value.
]]]

or even:

[[[language=smalltalk
1 second wait.
]]]

While this runner may seem a bit naive, it may also come in handy to control and debug task executions. Besides, the power of task runners is that they offer a polymorphic API to execute tasks.!
!TKTLocalProcessTaskRunner methodsFor: 'scheduling' stamp: ''!
scheduleTaskExecution: aTaskExecution
	self executeTask: aTaskExecution! !

!TKTLocalProcessTaskRunner methodsFor: 'scheduling' stamp: ''!
isLocalThreadRunner
	^ true! !

!TKTLocalProcessTaskRunnerTest methodsFor: 'tests' stamp: ''!
testLocalProcessTaskRunnerRunsInLocalProcess

	| runner future got |
	runner := TKTLocalProcessTaskRunner new.
	future := runner future: [ Processor activeProcess identityHash ].
	
	future onSuccessDo: [ :value | got := value ].
	future waitForCompletion: 2 seconds.
	
	self assert: got equals: Processor activeProcess identityHash.! !

!TKTLocalProcessTaskRunnerTest methodsFor: 'tests' stamp: ''!
testLocalProcessTaskRunnerExceptionIsHandledByExceptionHandler

	| runner error |
	runner := TKTLocalProcessTaskRunner new.
	runner exceptionHandler: (TKTTestExceptionHandler new).
	
	error := Error new.
	runner schedule: [ error signal ].
	
	self assert: runner exceptionHandler error equals: error! !

!TKTMemoryLeakTest methodsFor: 'helpers' stamp: ''!
trackInstancesOf: aClass during: aBlock

	| before |
	before := aClass allInstances size.

	aBlock value.

	self assertWithGarbageCollect: [ before >= aClass allInstances size ].! !

!TKTMockService commentStamp: ''!
I am a mock service used for testing purposes.!
!TKTMockService methodsFor: 'stepping' stamp: ''!
tearDown

	isShutDown := true! !

!TKTMockService methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	isStarted := false.
	isShutDown := false.
	hasRun := false! !

!TKTMockService methodsFor: 'accessing' stamp: ''!
hasRun

	^ hasRun! !

!TKTMockService methodsFor: 'accessing' stamp: ''!
isStarted

	^ isStarted! !

!TKTMockService methodsFor: 'stepping' stamp: ''!
stepService

	hasRun := true! !

!TKTMockService methodsFor: 'accessing' stamp: ''!
name

	^ 'Mock service'! !

!TKTMockService methodsFor: 'accessing' stamp: ''!
isShutDown

	^ isShutDown! !

!TKTMockService methodsFor: 'stepping' stamp: ''!
setUp

	isStarted := true! !

!TKTNewProcessTaskRunner commentStamp: ''!
!! TKTNewProcessTaskRunner

A new process task runner, instance of TKTNewProcessTaskRunner, is a task runner that runs each task in a new separate Pharo process.

[[[language=smalltalk
aRunner := TKTNewProcessTaskRunner new.
aRunner schedule: [ 1 second wait. 'test' logCr ].
]]]

Moreover, since new processes are created to manage each task, scheduling two different tasks will be executed concurrently. For example, in the code snippet below, we schedule twice a task that printing the identity hash of the current process.

[[[language=smalltalk
aRunner := TKTNewProcessTaskRunner new.
task := [ 10 timesRepeat: [ 10 milliSeconds wait.
                ('Hello from: ', Processor activeProcess identityHash asString) logCr ] ].
aRunner schedule: task.
aRunner schedule: task.
]]]

The generated output will look something like this:

[[[
'Hello from: 887632640'
'Hello from: 949846528'
'Hello from: 887632640'
'Hello from: 949846528'
'Hello from: 949846528'
'Hello from: 887632640'
'Hello from: 949846528'
'Hello from: 887632640'
'Hello from: 949846528'
'Hello from: 887632640'
'Hello from: 949846528'
'Hello from: 887632640'
'Hello from: 949846528'
'Hello from: 887632640'
'Hello from: 949846528'
'Hello from: 887632640'
'Hello from: 949846528'
'Hello from: 887632640'
'Hello from: 949846528'
'Hello from: 887632640'
]]]

First, you'll see that a different processes is being used to execute each task. Also, their execution is concurrent, as we can see the messages interleaved.!
!TKTNewProcessTaskRunner methodsFor: 'scheduling' stamp: ''!
scheduleTaskExecution: aTaskExecution
	TKTConfiguration processProvider
		createProcessDoing:
			(MessageSend
				receiver: self
				selector: #executeTask:
				arguments: {aTaskExecution})! !

!TKTNewProcessTaskRunnerTest methodsFor: 'tests' stamp: ''!
testNewProcessTaskRunnerRunsNeverInLocalProcess

	| runner hashes futures |
	runner := TKTNewProcessTaskRunner new.
	hashes := AtomicSharedQueue new.
	
	futures := (1 to: 10) collect: [ :i | (runner future: [ Processor activeProcess identityHash ]) onSuccessDo: [ :v | hashes nextPut: v ] ].
	
	futures do: [ :each | each waitForCompletion: 2 seconds ].
	
	[ hashes isEmpty ] whileFalse: [ 
		self assert: hashes next ~= Processor activeProcess identityHash ].! !

!TKTNewProcessTaskRunnerTest methodsFor: 'tests' stamp: ''!
testNewProcessTaskRunnerRunsInNewProcessEveryTime

	| runner hashes futures hashesSet |
	runner := TKTNewProcessTaskRunner new.
	hashes := AtomicSharedQueue new.
	
	futures := (1 to: 10) collect: [ :i | (runner future: [ Processor activeProcess identityHash ]) onSuccessDo: [ :v | hashes nextPut: v ] ].
	
	futures do: [ :each | each waitForCompletion: 2 seconds ].
	
	hashesSet := Set new.
	[ hashes isEmpty ] whileFalse: [ hashesSet add: hashes next ].
	self assert: hashesSet size equals: 10.! !

!TKTNewProcessTaskRunnerTest methodsFor: 'tests' stamp: ''!
testNewProcessTaskRunnerExceptionIsHandledByExceptionHandler
	| runner error |
	
	runner := TKTNewProcessTaskRunner new.
	runner exceptionHandler: (TKTTestExceptionHandler new).
	
	error := Error new.
	runner schedule: [ error signal ].
	
	"We wait until the error is signaled, trapped and we have it."
	100 milliSeconds wait.
	self assert: runner exceptionHandler error equals: error! !

!TKTParameterizableService commentStamp: ''!
Additionally, TaskIt provides an alternative means to create services through blocks (or valuables actually) using `TKTParameterizableService`. An alternative implementation of the file watcher could be done as follows.

```smalltalk
service := TKTParameterizableService new.
service name: 'Generic watcher service'.
service onSetUpDo: [ Transcript show: 'File watcher started' ].
service onTearDownDo: [ Transcript show: 'File watcher finished' ].
service step: [
  'temp.txt' asFileReference exists
    ifFalse: [ Transcript show: 'file does not exist!!' ] ].

service start.
```!
!TKTParameterizableService methodsFor: 'stepping' stamp: ''!
tearDown
	
	super tearDown.
	tearDownTask value! !

!TKTParameterizableService methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self step: [ 100 milliSeconds wait ].! !

!TKTParameterizableService methodsFor: 'parameterization' stamp: ''!
onTearDownDo: aBlockClosure 

	tearDownTask := aBlockClosure.! !

!TKTParameterizableService methodsFor: 'stepping' stamp: ''!
stepService
	task value.! !

!TKTParameterizableService methodsFor: 'accessing' stamp: ''!
step: aBlockClosure 
	task := aBlockClosure! !

!TKTParameterizableService methodsFor: 'parameterization' stamp: ''!
onSetUpDo: aBlockClosure 

	startUpTask := aBlockClosure.! !

!TKTParameterizableService methodsFor: 'accessing' stamp: ''!
name
	
	^ name! !

!TKTParameterizableService methodsFor: 'accessing' stamp: ''!
name: aString 
	name := aString! !

!TKTParameterizableService methodsFor: 'starting' stamp: ''!
restart
	self stop.
	stopRequested := false.
	stopCallbacks := Set new.
	self start! !

!TKTParameterizableService methodsFor: 'stepping' stamp: ''!
setUp
	
	super setUp.
	startUpTask value! !

!TKTParameterizedServiceTest methodsFor: 'running' stamp: ''!
tearDown

	(service notNil and: [service isRunning]) ifTrue: [
		(service stop) waitForCompletion: 1 second ].
	super tearDown	! !

!TKTParameterizedServiceTest methodsFor: 'tests' stamp: ''!
testServiceExecutesStartUpOnStart

	| started |
	started := false.
	service := TKTParameterizableService new.
	service name: 'test service'.
	service onSetUpDo: [ started := true ].
	service start.
	
	100 milliSeconds wait.
	
	self assert: started.! !

!TKTParameterizedServiceTest methodsFor: 'tests' stamp: ''!
testServiceExecutesTearDownOnStop

	| stopped |
	stopped := false.
	service := TKTParameterizableService new.
	service name: 'test service'.
	service onTearDownDo: [ stopped := true ].
	service start.
	(service stop) waitForCompletion: 2 second.

	self assert: stopped.! !

!TKTParameterizedServiceTest methodsFor: 'tests' stamp: ''!
testServiceRunsAfterStart

	| run |
	run := false.
	service := TKTParameterizableService new.
	service name: 'test service'.
	service step: [ run := true ].
	service start.
	
	10 milliSeconds wait.
	
	self assert: run.! !

!TKTPharoProcessProvider commentStamp: ''!
I am a process provider that creates Pharo processes using the standard #fork message!
!TKTPharoProcessProvider methodsFor: 'instance creation' stamp: ''!
createProcessDoing: aValuable
	| toFork |
	toFork := aValuable isBlock
		ifTrue: [ aValuable ]
		ifFalse: [ [ aValuable value ] ].
	^ toFork fork! !

!TKTPharoProcessProvider methodsFor: 'instance creation' stamp: ''!
createProcessDoing: aValuable named: aName
	| block |
	block := aValuable isMessageSend
		ifTrue: [ [ aValuable value ] ]
		ifFalse: [ aValuable ].
	^ block forkNamed: aName! !

!TKTPharoProcessProviderTest methodsFor: 'tests' stamp: ''!
testNewProcessIsPharoProcess
	self assert: ((TKTPharoProcessProvider new createProcessDoing: (MessageSend receiver: [ 1 + 1 ] selector: #value)) isKindOf: Process)! !

!TKTProcessProvider commentStamp: ''!
I am a process provider. I define how processes are created and provide a hook for those how would like to have more control on how it is done.!
!TKTProcessProvider methodsFor: 'instance creation' stamp: ''!
createProcessDoing: aValuable

	self subclassResponsibility! !

!TKTProcessProvider methodsFor: 'instance creation' stamp: ''!
createProcessDoing: aValuable named: aName

	self subclassResponsibility! !

!TKTProcessProvider methodsFor: 'instance creation' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTProcessProvider class methodsFor: 'accessing' stamp: ''!
current

	^ self error: 'Use TKTConfiguration processProvider createProcessDoing: aValuable '! !

!TKTProcessProvider class methodsFor: 'accessing' stamp: ''!
current: aProcessProvider
	^ self error: 'Use a configuration'! !

!TKTProcessProvider class methodsFor: 'instance creation' stamp: ''!
createProcessDoing: aValuable
	^ self error: 'Use TKTConfiguration processProvider createProcessDoing: aValuable '! !

!TKTProcessProvider class methodsFor: 'instance creation' stamp: ''!
createProcessDoing: aValuable named: aName
	^ self error: 'Use TKTConfiguration processProvider createProcessDoing: aValuable named: aName'! !

!TKTProductionProfile commentStamp: ''!
The production profile. 
Deployed applications should use this.!
!TKTProductionProfile class methodsFor: 'accessing' stamp: ''!
profileName
	
	^ #production! !

!TKTProductionProfile class methodsFor: 'private' stamp: ''!
priority

	^ 0! !

!TKTProductionProfile class methodsFor: 'private' stamp: ''!
profileValues

	^ {(#debugging -> false) .
		(#runner -> TKTCommonQueueWorkerPool createDefault).
		(#poolWorkerProcess -> TKTWorkerProcess).
		(#process -> Process).
		(#watchDog -> TKTWatchDog onDuty) .
		(#errorHandler -> TKTExceptionHandler).
		(#processProvider -> TKTPharoProcessProvider new).
		(#serviceManager -> TKTServiceManager new)} asDictionary! !

!TKTProfile commentStamp: ''!
The profile is a class that represents sets of configurations. 

For adding a new profile, we have to add a class method with the pragma <profile: #name>, this method should return a TKTProfile object with it configuration.

The profile building process ensures that the profile is properly setted from the debugging point of view. 

For setting the currently working profile see in the TKTConfiguration class.!
!TKTProfile methodsFor: 'accessing' stamp: ''!
debugging
	^ debugging! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
processProvider
	^ processProvider! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
watchDog
	^ watchDog! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
processProvider: anObject
	processProvider := anObject! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
runner: anObject
	runner := anObject! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
poolWorkerProcess: anObject
	poolWorkerProcess := anObject! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
at: anEntry put: aValue
	^ self instVarNamed: anEntry asSymbol put: aValue! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
errorHandler: anObject
	errorHandler := anObject! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
finalizeProfile
	self options do: [ :option | (self at: option) finalize ]! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
poolWorkerProcess
	^ poolWorkerProcess! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
serviceManager: anObject
	serviceManager := anObject! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
runner
	^ runner! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
process: anObject
	process := anObject! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
at: anEntry
	^ self instVarNamed: anEntry asSymbol! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
debugging: anObject
	debugging := anObject! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
values: aDictionary
	aDictionary keysAndValuesDo: [ :k :v | self perform: ('{1}:' format: {k}) asSymbol withArguments: {v} ]! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
errorHandler
	^ errorHandler! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
serviceManager
	^ serviceManager! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
process
	^ process! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
watchDog: aWatchDog
	watchDog := aWatchDog! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
activateProfile
	self debugging
		ifTrue: [ self options
				do: [ :option | self assert: (self at: option) isDebuggingCompatible description: ('The option{1} is not debugging compatible!! ' format: {option}) ].
				(self at: #process) enableDebugger ]
		ifFalse: [ (self at: #process) disableDebugger ].
	self runner start! !

!TKTProfile methodsFor: 'accessing' stamp: ''!
options
	^ #(runner process poolWorkerProcess errorHandler processProvider serviceManager)! !

!TKTProfile class methodsFor: 'accessing profiles' stamp: ''!
defaultProfileName

	^ self defaultProfileClass profileName! !

!TKTProfile class methodsFor: 'instance creation' stamp: ''!
new

	^ self on: self profileValues! !

!TKTProfile class methodsFor: 'accessing profiles' stamp: ''!
production
	<profile: #production>

	^ TKTProductionProfile new! !

!TKTProfile class methodsFor: 'accessing' stamp: ''!
profiles
	^ (Pragma allNamed: #profile: from: self class to: ProtoObject) asOrderedCollection
		collect: [ :c | c arguments first -> (MessageSend receiver: self selector: c method selector) ]! !

!TKTProfile class methodsFor: 'accessing' stamp: ''!
profileName
	
	^ self subclassResponsibility! !

!TKTProfile class methodsFor: 'instance creation' stamp: ''!
on: aDictionary
	^ self basicNew
		initialize;
		values: aDictionary;
		yourself! !

!TKTProfile class methodsFor: 'accessing profiles' stamp: ''!
defaultProfile

	^ self defaultProfileClass new! !

!TKTProfile class methodsFor: 'private' stamp: ''!
priority

	^ self subclassResponsibility! !

!TKTProfile class methodsFor: '*TaskIt-Tests' stamp: ''!
test
	<profile: #test>
	
	^ TKTTestProfile new! !

!TKTProfile class methodsFor: 'private' stamp: ''!
profileValues

	^ self subclassResponsibility! !

!TKTProfile class methodsFor: 'accessing profiles' stamp: ''!
defaultProfileClass

	^ (self allSubclasses sorted: [ :a | a priority ] descending) first! !

!TKTPromise commentStamp: ''!
A promis represents a computation.
A promise is an object that allow us to interact with the result of a computation strictly in asynchronic way.
A promise is registered and kept up to the end of the computation and application of the callbacks.!
!TKTQueueTaskScheduler commentStamp: ''!
I am an abstract task scheduler that schedules tasks inside a queue to be consumed afterwards!
!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
future: aTask
	^ aTask asTask future: self! !

!TKTQueueTaskScheduler methodsFor: 'testing' stamp: ''!
isEmpty

	^ queue isEmpty! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
isWorker
	^ false ! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
isLocalThreadRunner
	^ false ! !

!TKTQueueTaskScheduler methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	queue := AtomicSharedQueue new! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
purge

	queue removeAll! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
schedule: aTask timeout: aTimeout

	| execution |
	execution := TKTTimeoutableTaskExecution new.
	execution runner: self.
	execution task: aTask.
	execution timeout: aTimeout.
	
	self scheduleTaskExecution: execution.! !

!TKTQueueTaskScheduler methodsFor: 'accessing' stamp: ''!
queue: aTaskQueue

	queue := aTaskQueue! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
schedule: aTask
	aTask asTask schedule: self! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
scheduleTimeout: timeout on: aTaskExecution
	TKTConfiguration processProvider
		createProcessDoing:
			(MessageSend
				receiver: self
				selector: #privateTimeout:on:
				arguments:
					{timeout.
					aTaskExecution})! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
scheduleTaskExecution: aTask
	
	queue nextPut: aTask! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
privateFuture: aTask
	| execution |
	execution := aTask asTask futureTaskExecutionFor: self.
	self scheduleTaskExecution: execution.
	^ execution future! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
privateTimeout: timeout on: aTaskExecution
	timeout wait.
	aTaskExecution isFinished
		ifFalse: [ aTaskExecution cancelWithReason: 'Timeout after: ' , timeout asString ]! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
isUIRunner
	^ false ! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTQueueTaskScheduler methodsFor: 'schedulling' stamp: ''!
privateSchedule: aTask
	| execution |
	execution := aTask asTask scheduleTaskExecutionFor: self.
	self scheduleTaskExecution: execution
	! !

!TKTQueueTaskScheduler class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TKTQueueTaskScheduler class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TKTQueueTaskScheduler class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TKTQueueTaskScheduler class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TKTQueueTaskScheduler class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TKTQueueTaskScheduler class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TKTQueueTaskScheduler class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TKTQueueTaskScheduler class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TKTQueueTaskScheduler class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TKTQueueTaskScheduler class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TKTQueueTaskScheduler class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TKTQueueTaskScheduler class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TKTQueueTaskScheduler class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TKTQueueTaskScheduler class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TKTQueueTaskScheduler class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TKTQueueTaskScheduler class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TKTQueueTaskScheduler class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TKTQueueTaskScheduler class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TKTQueueTaskScheduler class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TKTQueueTaskScheduler class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TKTQueueTaskScheduler class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TKTQueueTaskScheduler class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!TKTQueueTaskScheduler class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!TKTQueueTaskScheduler class methodsFor: 'testing' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTQueueTaskScheduler class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!TKTQueueTaskScheduler class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TKTQueueTaskScheduler class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TKTQueueTaskScheduler class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TKTQueueTaskScheduler class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TKTQueueTaskScheduler class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TKTReadyTaskState commentStamp: ''!
I represent a ready to run task. A ready task will start running when asked, or be cancelled immediately if cancelled.!
!TKTReadyTaskState methodsFor: 'cancelling' stamp: ''!
performTaskExecution: aTaskExecution
	aTaskExecution setRunningState.
	aTaskExecution doExecuteTask.
	aTaskExecution setFinishedState! !

!TKTReadyTaskState methodsFor: 'cancelling' stamp: ''!
cancelTaskExecution: aTaskExecution reason: aReason

	aTaskExecution setCancelStateWithReason: aReason! !

!TKTRunner commentStamp: ''!
!! TKTRunner

So far we created and executed tasks without caring too much on the form they were executed. Indeed, we knew that they were run concurrently because they were non-blocking. We also said already that the difference between a schedule message and a fork message is that scheduled messages are run by a task runner.

A task runner is an object in charge of executing tasks eventually. Indeed, the main API of a task runner is the schedule: message that allows us to tell the task runner to schedule a task.

[[[language=smalltalk
aRunner schedule: [ 1 + 1 ]
]]]

A nice extension built on top of schedule is the future: message that allows us to schedule a task but obtain a future of its eventual execution.

[[[language=smalltalk
future := aRunner future: [ 1 + 1 ]
]]]

Indeed, the messages schedule and future we have learnt before are only syntax-sugar extensions that call these respective ones on a default task runner. See TKTRunner subclasses for details on specific runners.

!!!! Managing Runner Exceptions

As we stated before, in TaskIT the result of a task can be interesting for us or not. In case we do not need a task's result, we will schedule it usign the schedule or schedule: messages. This is a kind of fire-and-forget way of executing tasks. On the other hand, if the result of a task execution interests us we can get a future on it using the future and future: messages. These two ways to execute tasks require different ways to handle exceptions during task execution.

First, when an exception occurs during a task execution that has an associated future, the exception is forwarded to the future. In the future we can subscribe a failure callback using the onFailureDo: message to manage the exception accordingly.

However, on a fire-and-forget kind of scheduling, the execution and results of a task is not anymore under our control. If an exception happens in this case, it is the responsibility of the task runner to catch the exception and manage it gracefully. For this, each task runners is configured with an exception handler in charge of it. TaskIT exception handler classes are subclasses of the abstract TKTExceptionHandler that defines a handleException: method. Subclasses need to override the handleException: method to define their own way to manage exceptions.

TaskIt provides by default a TKTDebuggerExceptionHandler that will open a debugger on the raised exception. The handleException: method is defined as follows:

[[[language=smalltalk
handleException: anError 
    anError debug
]]]

Changing a runner's exception handler can be done by sending it the exceptionHandler: message, as follows:

[[[language=smalltalk
aRunner exceptionHandler: TKTDebuggerExceptionHandler new.
]]]!
!TKTRunner methodsFor: 'schedulling' stamp: ''!
future: aTask
	^ aTask asTask future: self! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
isLocalThreadRunner
	^ false ! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
isWorker
	^ false ! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
schedule: aTask timeout: aTimeout

	| execution |
	execution := TKTTimeoutableTaskExecution new.
	execution runner: self.
	execution task: aTask.
	execution timeout: aTimeout.
	
	self scheduleTaskExecution: execution.! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
schedule: aTask
	aTask asTask schedule: self! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
scheduleTimeout: timeout on: aTaskExecution
	TKTConfiguration processProvider
		createProcessDoing:
			(MessageSend
				receiver: self
				selector: #privateTimeout:on:
				arguments:
					{timeout.
					aTaskExecution})! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
scheduleTaskExecution: aTaskExecution

	self requirement! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
privateFuture: aTask
	| execution |
	execution := aTask asTask futureTaskExecutionFor: self.
	self scheduleTaskExecution: execution.
	^ execution future! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
privateTimeout: timeout on: aTaskExecution
	timeout wait.
	aTaskExecution isFinished
		ifFalse: [ aTaskExecution cancelWithReason: 'Timeout after: ' , timeout asString ]! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
isUIRunner
	^ false ! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTRunner methodsFor: 'schedulling' stamp: ''!
privateSchedule: aTask
	| execution |
	execution := aTask asTask scheduleTaskExecutionFor: self.
	self scheduleTaskExecution: execution
	! !

!TKTRunner class methodsFor: 'testing' stamp: ''!
isAbstract

	^self == TKTRunner ! !

!TKTRunner class methodsFor: 'testing' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTRunningTaskState commentStamp: ''!
I represent a running task. A running task cannot be asked to be executed while it is running. Cancelling a running task will throw an exception and interrupt its execution.!
!TKTRunningTaskState methodsFor: 'testing' stamp: ''!
isRunning

	^ true! !

!TKTRunningTaskState methodsFor: 'executing' stamp: ''!
performTaskExecution: aTaskExecution

	self error: 'task is already running'! !

!TKTRunningTaskState methodsFor: 'cancelling' stamp: ''!
cancelTaskExecution: aTaskExecution reason: aReason

	| cancelState activeContext timeoutContext |

	cancelState := TKTCancelledTaskState reason: aReason.
	
	activeContext := aTaskExecution executionProcess suspendedContext.
	timeoutContext := [ cancelState signalCancelledException ] asContext.
	timeoutContext privSender: activeContext.
	aTaskExecution executionProcess suspendedContext: timeoutContext.
	aTaskExecution setCancelStateWithReason: aReason! !

!TKTService commentStamp: ''!
A service is a process that executes a task over and over again. You can think about a web server, or a database server that needs to be up and running and listening to new connections all the time.

Each TaskIt service may define a `setUp`, a `tearDown` and a `stepService`. `setUp` is run when a service is being started, `shutDown` is run when the service is being shutted down, and `stepService` is the main service action that will be executed repeateadly.

Creating a new service is as easy as creating a subclass of `TKTService`. For example, let's create a service that watches the existence of a file. If the file does not exists it will log it to the transcript. It will also log when the service starts and stops to the transcript.

```smalltalk
TKTService subclass: #TKTFileWatcher
  instanceVariableNames: 'file'
  classVariableNames: ''
  package: 'TaskItServices-Tests'
```

Hooking on the service's `setUp` and `tearDown` is as easy as overriding such methods:

```smalltalk
TKTFileWatcher >> setUp
  super setUp.
  Transcript show: 'File watcher started'.

TKTFileWatcher >> tearDown
  super tearDown.
  Transcript show: 'File watcher finished'.
```

Finally, setting the watcher action is as easy as overriding the `stepService` message.

```smalltalk
TKTFileWatcher >> stepService
  1 second wait.
  file asFileReference exists
    ifFalse: [ Transcript show: 'file does not exist!!' ]
```

Making the service work requires yet an additional method: the service name. Each service should provide a unique name through the `name` method. TaskIt verifies that service names are unique and prevents the starting of two services with the same name.

```smalltalk
TKTFileWatcher >> name
  ^ 'Watcher file: ', file asString
```

Once your service is finished, starting it is as easy as sending it the `start` message.

```smalltalk
watcher := TKTFileWatcher new.
watcher file: 'temp.txt'.
watcher start.
```

Requesting the stop of a service is done by sending it the `stop` message. Know that sending the `stop` message will not stop the service right away. It will actually request it to stop, which will schedule the tear down of the service and kill its process after that. 

```smalltalk
watcher stop.
```

Stopping the process in an unsafe way is also supported by sending it the `kill` message. Killing a service will stop it right away, interrupting whatever task it was executing.

```smalltalk
watcher kill.
```!
!TKTService methodsFor: 'starting' stamp: ''!
stop
	| futureStop |
	futureStop := TKTFuture new.
	self onStoppedDo: [ :v | futureStop deploySuccess: self ].
	stopRequested := true.
	TKTConfiguration serviceManager removeService: self.
	currentDelay ifNotNil: [:delay | delay delaySemaphore signal ].
	^ futureStop! !

!TKTService methodsFor: 'stepping' stamp: ''!
tearDown

	"Hook"! !

!TKTService methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self stepDelay: 500 milliSeconds.
! !

!TKTService methodsFor: 'starting' stamp: ''!
scheduleRecursiveTask
	stopRequested
		ifTrue: [ worker schedule: [ self doStop ] ]
		ifFalse: [ worker schedule: recursiveTask ]! !

!TKTService methodsFor: 'stepping' stamp: ''!
iterateService
	self stepService.
	currentDelay := stepDelay asDelay.
	currentDelay wait! !

!TKTService methodsFor: 'stepping' stamp: ''!
stepService

	self subclassResponsibility! !

!TKTService methodsFor: 'testing' stamp: ''!
isRunning
	worker ifNil: [ ^ false ].
	^ worker isRunning! !

!TKTService methodsFor: 'private' stamp: ''!
launch

	self name ifNil: [ self error: 'A name should be provided for a service' ].
	
	worker name: self name.
	worker start.
	worker schedule: [ self setUp ].
	self scheduleRecursiveTask.! !

!TKTService methodsFor: 'accessing' stamp: ''!
priority
	^ self worker priority! !

!TKTService methodsFor: 'starting' stamp: ''!
stepDelay: aTimeDelay
	stepDelay := aTimeDelay ! !

!TKTService methodsFor: 'accessing' stamp: ''!
name
	
	self subclassResponsibility! !

!TKTService methodsFor: 'accessing' stamp: ''!
priority: anInteger 
	self worker priority: anInteger! !

!TKTService methodsFor: 'starting' stamp: ''!
onStoppedDo: aCallback

	stopCallbacks add: aCallback! !

!TKTService methodsFor: 'starting' stamp: ''!
start
	stopRequested := false.
	stopCallbacks := Set new.
	self worker taskQueue: AtomicSharedQueue new.
	recursiveTask := [ 
			self iterateService.
			self scheduleRecursiveTask ] asTask.
	TKTConfiguration serviceManager startService: self! !

!TKTService methodsFor: 'starting' stamp: ''!
restart
	self stop.
	0.5 second wait.
	stopRequested := false.
	stopCallbacks := Set new.
	self start! !

!TKTService methodsFor: 'starting' stamp: ''!
doStop
	self tearDown.
	(TKTNewProcessTaskRunner new 
		future: [ self kill ]) 
		flatCollect: [ :r | 
			stopCallbacks do: [ :each | each value: r ] ]! !

!TKTService methodsFor: 'accessing' stamp: ''!
process
	^worker process! !

!TKTService methodsFor: 'accessing' stamp: ''!
worker
	^ worker ifNil: [ worker :=  TKTWorker new]! !

!TKTService methodsFor: 'private' stamp: ''!
kill
	TKTConfiguration serviceManager removeService: self.
	worker stop! !

!TKTService methodsFor: 'accessing' stamp: ''!
stepDelay
	^ stepDelay ! !

!TKTService methodsFor: 'stepping' stamp: ''!
setUp

	"Hook"! !

!TKTServiceManager commentStamp: ''!
The service manager keeps a list of the currently installed tests and their state.!
!TKTServiceManager methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	services := Set new.! !

!TKTServiceManager methodsFor: 'purging' stamp: ''!
purge
	
	services := services select: [ :each | each isRunning ]! !

!TKTServiceManager methodsFor: 'accessing' stamp: ''!
services
	^ services! !

!TKTServiceManager methodsFor: 'start-stop' stamp: ''!
stopService: aService

	aService requestStop! !

!TKTServiceManager methodsFor: 'start-stop' stamp: ''!
startService: aService
	services
		detect: [ :any | any name = aService name ]
		ifFound: [ :s | 
			s = aService
				ifFalse: [ self
						error:
							('A service named "{name}" is already registered'
								format: {('name' -> aService name)} asDictionary) ] ]
		ifNone: [ aService launch.
			services add: aService ]! !

!TKTServiceManager methodsFor: 'purging' stamp: ''!
removeService: aService

	services remove: aService ifAbsent: [  ].! !

!TKTServiceManager methodsFor: 'configuration' stamp: ''!
isDebuggingCompatible
	^ true! !

!TKTServiceManagerTest methodsFor: 'tests' stamp: ''!
testStopServiceStopsUnderlyingWorker

	| executed service |
	executed := 0.
	
	service := TKTParameterizableService new.
	service name: 'test'.
	service step: [ executed := executed + 1 ].
	service start.
	service stop.
	(service stepDelay * 3) wait.
	
	self deny: service worker isRunning! !

!TKTServiceManagerTest methodsFor: 'tests' stamp: ''!
testCannotStartTwoServicesWithSameName
	| executed service newService |
	executed := 0.
	[ service := TKTParameterizableService new.
	service name: 'test'.
	service step: [ 100 milliSeconds wait ].
	service start.
	newService := TKTParameterizableService new.
	newService name: 'test'.
	newService step: [ 100 milliSeconds wait ].
	self should: [ newService start ] raise: Error ]
		ensure: [ service stop.
			[ newService stop ] onErrorDo: [  ].
			200 milliSeconds wait ]! !

!TKTServiceManagerTest methodsFor: 'tests' stamp: ''!
testServiceIsExecutedMultipleTimes

	| executed service |
	executed := 0.
	
	service := TKTParameterizableService new.
	service name: 'test'.
	service step: [ executed := executed + 1 ].
	service start.
	
	(service stepDelay * 2) wait.
	service stop.
	200 milliSeconds wait.
	
	self assert: executed > 1! !

!TKTServiceMemoryLeakTest methodsFor: 'tests - worker' stamp: ''!
testWorkerPoolInstancesAreCollectedAfterStartingAndStoppingService

	self
		trackInstancesOf: TKTWorkerPool
		during: [ TKTParameterizableService new name: 'test'; start; stop  ]! !

!TKTServiceMemoryLeakTest methodsFor: 'tests - worker' stamp: ''!
testWorkerInstancesAreCollectedAfterStartingAndStoppingService

	self
		trackInstancesOf: TKTWorker
		during: [ TKTParameterizableService new
				name: 'test';
				start;
				stop ]! !

!TKTServiceMemoryLeakTest methodsFor: 'tests - worker' stamp: ''!
testWorkerProcessInstancesAreCollectedAfterStartingAndStoppingService

	self
		trackInstancesOf: TKTWorkerProcess
		during: [ TKTParameterizableService new name: 'test'; start; stop  ]! !

!TKTServiceMemoryLeakTest methodsFor: 'tests - worker' stamp: ''!
testServiceInstancesAreCollectedAfterStartingAndStoppingService

	self
		trackInstancesOf: TKTParameterizableService
		during: [ TKTParameterizableService new name: 'test'; start; stop  ]! !

!TKTServiceTest methodsFor: 'running' stamp: ''!
tearDown

	(service notNil and: [service isRunning]) ifTrue: [
		(service stop) waitForCompletion: 1 second ].
	super tearDown! !

!TKTServiceTest methodsFor: 'tests' stamp: ''!
testPrioritySetBeforeStart
	|initialPriority|
	service := TKTParameterizableService new.
	service name: 'test service'.
	initialPriority := 35.
	service priority: initialPriority.
	self assert: service priority equals: initialPriority.
	service start.
	self assert: service process priority equals: initialPriority.
! !

!TKTServiceTest methodsFor: 'tests' stamp: ''!
testPrioritySetAfterStart
	|newPriority|
	service := TKTParameterizableService new.
	service name: 'test service'.
	newPriority := 32.
	self deny: service priority equals: newPriority.
	service start.
	service priority: newPriority.
	self assert: service priority equals: newPriority.
	self assert: service process priority equals: newPriority.
! !

!TKTServiceTest methodsFor: 'tests' stamp: ''!
testServiceShouldHaveAName

	self should: [TKTService new start] raise: Error! !

!TKTServiceTest methodsFor: 'tests' stamp: ''!
testServiceIsKilledAfterStop

	service := TKTParameterizableService new.
	service name: 'test service'.
	service start.
	(service stop) waitForCompletion: 2 second.
	
	self deny: service isRunning.! !

!TKTSubclassServiceTest methodsFor: 'running' stamp: ''!
tearDown

	(service notNil and: [service isRunning]) ifTrue: [
		(service stop) waitForCompletion: 1 second ].
	super tearDown! !

!TKTSubclassServiceTest methodsFor: 'tests' stamp: ''!
testServiceExecutesStartUpOnStart

	service := TKTMockService new.
	service start.
	
	10 milliSeconds wait.
	
	self assert: service isStarted.! !

!TKTSubclassServiceTest methodsFor: 'tests' stamp: ''!
testServiceExecutesTearDownOnStop

	service := TKTMockService new.
	service start.
	(service stop) waitForCompletion: 1 second.

	self assert: service isShutDown.! !

!TKTSubclassServiceTest methodsFor: 'tests' stamp: ''!
testServiceRunsAfterStart

	service := TKTMockService new.
	service start.
	
	10 milliSeconds wait.
	
	self assert: service hasRun.! !

!TKTTask commentStamp: ''!
!! TKTTask

TaskIT's main abstraction are, as the name indicates it, tasks. A task is a unit of execution. By splitting the execution of a program in several tasks, TaskIT can run those tasks concurrently, synchronize their access to data, or order even help in ordering and synchronizing their execution.

!!!! First Example

Launching a task is as easy as sending the message schedule to a block closure, as it is used in the following first code example:

[[[language=smalltalk
[ 1 + 1 ] schedule.
]]]

The selector name schedule is chosen in purpose instead of others such as run, launch or execute. TaskIT promises you that a task will be eventually executed, but this is not necessarilly right away. In other words, a task is scheduled to be executed at some point in time in the future.
This first example is however useful to clarify the first two concept but it remains too simple. We are schedulling a task that does nothing useful, and we cannot even observe it's result (yet). Let's explore some other code snippets that may help us understand what's going on.

The following code snippet will schedule a task that prints to the Transcript. Just evaluating the expression below will make evident that the task is actually executed. However, a so simple task runs so fast that it's difficult to tell if it's actually running concurretly to our main process or not.

[[[language=smalltalk
[ 'Happened' logCr ] schedule.
]]]

The real acid test is to schedule a long-running task. The following example schedules a task that waits for a second before writing to the transcript. While normal synchronous code would block the main thread, you'll notice that this one does not.

[[[language=smalltalk
[ 1 second wait.
'Waited' logCr ] schedule.
]]]

!! Valuables as Tasks

We have been using so far block closures as tasks. Block closures are a handy way to create a task since they implictly capture the context: they have access to self and other objects in the scope. However, blocks are not always the wisest choice for tasks. Indeed, when a block closure is created, it references the current context with all the objects in it and its sender contexts, being a potential source of memory leaks.

The good news is that TaskIt tasks can be represented by almost any object. A task, in TaskIT's domain are valuable objects i.e., objects that will do some computation when they receive the value message. Actually, the messages schedule and future we just used are a syntax sugar for:

[[[language=smalltalk
(TKTTask valuable: [ 1 logCr ]) schedule.
]]]

We can then create tasks using message sends or weak message sends:

[[[language=smalltalk
TKTTask valuable: (WeakMessageSend receiver: Object new selector: #yourself).
TKTTask valuable: (MessageSend receiver: 1 selector: #+ arguments: { 7 }).
]]]

Or even create our own task object:

[[[language=smalltalk
Object subclass: #MyTask
    instanceVariableNames: ''
    classVariableNames: ''
    package: 'MyPackage'.

MyTask >> value
    ^ 100 factorial
]]]

and use it as follows:

[[[language=smalltalk
TKTTask valuable: MyTask new.
]]]!
!TKTTask methodsFor: 'running' stamp: ''!
future: executor
	^ executor privateFuture: self! !

!TKTTask methodsFor: 'executing' stamp: ''!
configureTaskExecution: execution with: aRunner
	execution runner: aRunner.
	execution task: self.
	^ execution! !

!TKTTask methodsFor: 'executing' stamp: ''!
scheduleTaskExecutionFor: aRunner
	^ self configureTaskExecution: TKTTaskExecution new with: aRunner! !

!TKTTask methodsFor: 'running' stamp: ''!
evaluateOn: anExecution
	self subclassResponsibility! !

!TKTTask methodsFor: 'executing' stamp: ''!
futureTaskExecutionFor: aRunner
	^ self configureTaskExecution: TKTFutureExecution new with: aRunner! !

!TKTTask methodsFor: 'running' stamp: ''!
schedule: executor
	executor privateSchedule: self ! !

!TKTTask methodsFor: 'running' stamp: ''!
asTask
	^ self! !

!TKTTask methodsFor: 'running' stamp: ''!
schedule
	
	self schedule: TKTConfiguration runner! !

!TKTTask methodsFor: 'running' stamp: ''!
future
	^ self future: TKTConfiguration runner! !

!TKTTask class methodsFor: 'instance creation' stamp: ''!
valuable: aValuable

	^ TKTGenericTask new
		valuable: aValuable;
		yourself! !

!TKTTaskExecution commentStamp: ''!
I represent the execution of a given task. I know if the task is finished or not and I can cancel it while it is being executed.!
!TKTTaskExecution methodsFor: 'evaluating' stamp: ''!
cancel

	self cancelWithReason: ''! !

!TKTTaskExecution methodsFor: 'testing' stamp: ''!
isFinished

	^ state isFinished! !

!TKTTaskExecution methodsFor: 'testing' stamp: ''!
noteRunningOn: aRunner 
	" Some times is needed to know the real runner. By default we do nothing :) "! !

!TKTTaskExecution methodsFor: 'states' stamp: ''!
setRunningState

	state := TKTRunningTaskState new! !

!TKTTaskExecution methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	state := TKTReadyTaskState new.
! !

!TKTTaskExecution methodsFor: 'accessing' stamp: ''!
runner: aRunner

	runner := aRunner! !

!TKTTaskExecution methodsFor: 'states' stamp: ''!
setCancelStateWithReason: aReason

	state := TKTCancelledTaskState new! !

!TKTTaskExecution methodsFor: 'evaluating' stamp: ''!
executeTask 
	^ state performTaskExecution: self ! !

!TKTTaskExecution methodsFor: 'testing' stamp: ''!
isRunning

	^ state isRunning! !

!TKTTaskExecution methodsFor: 'evaluating' stamp: ''!
doExecuteTask
	^ task evaluateOn: self! !

!TKTTaskExecution methodsFor: 'evaluating' stamp: ''!
cancelWithReason: reason

	state cancelTaskExecution: self reason: reason! !

!TKTTaskExecution methodsFor: 'evaluating' stamp: ''!
value
	executionProcess := Processor activeProcess.
	TKTConfiguration runner: runner during: [ self executeTask ].! !

!TKTTaskExecution methodsFor: 'evaluating' stamp: ''!
task: aTask

	task := aTask! !

!TKTTaskExecution methodsFor: 'accessing' stamp: ''!
executionProcess

	^ executionProcess! !

!TKTTaskExecution methodsFor: 'states' stamp: ''!
setReadyState
	state := TKTReadyTaskState new! !

!TKTTaskExecution methodsFor: 'states' stamp: ''!
setFinishedState

	state := TKTFinishedTaskState new! !

!TKTTaskState commentStamp: ''!
I represent the state of a scheduled task. A task can be either be ready to be run,  cancelled, running or finished.!
!TKTTaskState methodsFor: 'testing' stamp: ''!
isFinished

	^ false! !

!TKTTaskState methodsFor: 'testing' stamp: ''!
isRunning

	^ false! !

!TKTTaskState methodsFor: 'executing' stamp: ''!
performTaskExecution: aTaskExecution

	self subclassResponsibility! !

!TKTTaskState methodsFor: 'cancelling' stamp: ''!
cancelTaskExecution: aTaskExecution reason: aReason

	self subclassResponsibility! !

!TKTTaskTimeoutTest methodsFor: 'tests' stamp: ''!
testTaskDoesNotTimeoutIfTaskExecutionIsShorter

	| runner finished |
	
	finished := false.
	runner := TKTLocalProcessTaskRunner new.
	runner exceptionHandler: (TKTTestExceptionHandler new).
	
	runner schedule: [ 10 milliSeconds wait. finished := true ] asTask timeout: 50 milliSeconds.
	
	self assert: runner exceptionHandler error equals: nil.
	self assert: finished! !

!TKTTaskTimeoutTest methodsFor: 'tests' stamp: ''!
testTaskTimeoutIfTaskExecutionIsLonger
	| runner |
	runner := TKTLocalProcessTaskRunner new.
	runner exceptionHandler: TKTTestExceptionHandler new.
	runner schedule: [ 50 milliSeconds wait ] asTask timeout: 10 milliSeconds.
	self assert: (runner exceptionHandler error isKindOf: TKTCancelledTaskException)! !

!TKTTestCase commentStamp: ''!
It only defines a teardown for ensure that the current pool is properly clean after executing tests.!
!TKTTestCase methodsFor: 'running' stamp: ''!
tearDown

	TKTConfiguration resetSoleInstance.
	super tearDown	! !

!TKTTestCase methodsFor: 'running' stamp: ''!
waitGarbageCollect

	5 timesRepeat: [ Smalltalk garbageCollect. 100 milliSecond wait ]! !

!TKTTestCase methodsFor: 'running' stamp: ''!
runCaseManaged
	^ self runCase! !

!TKTTestCase methodsFor: 'running' stamp: ''!
assertWithGarbageCollect: aBlock

	| waitingPeriod timesToRun |
	
	waitingPeriod := 100 milliSeconds.
	timesToRun := self defaultTimeLimit / waitingPeriod.

	timesToRun timesRepeat: [ 
		aBlock value ifTrue: [ ^ self ].

		Smalltalk garbageCollect.
		waitingPeriod wait	].

	self fail: 'Timeout waiting for ' , aBlock printString	! !

!TKTTestCase methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	TKTConfiguration
		resetSoleInstance;
		profileNamed: #test.! !

!TKTTestExceptionHandler commentStamp: ''!
I am a mock exception handler used for testing purposes!
!TKTTestExceptionHandler methodsFor: 'handling' stamp: ''!
handleException: anError 
	error := anError! !

!TKTTestExceptionHandler methodsFor: 'handling' stamp: ''!
error

	^ error! !

!TKTTestProfile commentStamp: ''!
A profile for testing!
!TKTTestProfile class methodsFor: 'accessing' stamp: ''!
profileName

	^ #test! !

!TKTTestProfile class methodsFor: 'private' stamp: ''!
priority

	^ -1! !

!TKTTestProfile class methodsFor: 'private' stamp: ''!
profileValues

	^ {(#debugging -> false).
		(#runner -> TKTCommonQueueWorkerPool createDefault).
		(#poolWorkerProcess -> TKTWorkerProcess).
		(#process -> Process).
		(#errorHandler -> TKTExceptionHandler).
		(#watchDog -> TKTWatchDog onDuty).
		(#processProvider -> TKTPharoProcessProvider new).
		(#serviceManager -> TKTServiceManager new)} asDictionary! !

!TKTTimeoutException commentStamp: ''!
I am an exception thrown when there is a timeout while waiting for the synchronization of a future.!
!TKTTimeoutableTaskExecution commentStamp: ''!
I am a task execution that is automatically cancelled with a timeout.!
!TKTTimeoutableTaskExecution methodsFor: 'accessing' stamp: ''!
timeout: aTimeout

	timeout := aTimeout! !

!TKTTimeoutableTaskExecution methodsFor: 'evaluating' stamp: ''!
doExecuteTask
	TKTConfiguration runner scheduleTimeout: timeout on: self.
	^ super doExecuteTask! !

!TKTUIProcessTaskRunner methodsFor: 'scheduling' stamp: ''!
scheduleTaskExecution: aTaskExecution
	WorldState addDeferredUIMessage: [ self executeTask: aTaskExecution ]! !

!TKTUIProcessTaskRunner methodsFor: 'scheduling' stamp: ''!
isUIRunner
	^ true ! !

!TKTWatchDog commentStamp: ''!
Watchdog watches the common queue worker pool to ensure the good working of this pool!
!TKTWatchDog methodsFor: 'initialization' stamp: ''!
stop
	started := false.
	super stop! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
delay
	^ 10 seconds! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	values := WeakSet new.
	id := UUID new.
	started := false! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
privateStart
	stopRequested := false.
	stopCallbacks := Set new.
	" A worker normally needs to be watched. But the watchdog process cannot be watched, because the watchdog do not yet exists. 
	 This is a hacky workaround. Think a better solution.
	"
	worker := TKTWorker basicNew.
	worker initialize.
	worker taskQueue: AtomicSharedQueue new.
	recursiveTask := [ self iterateService.
	self scheduleRecursiveTask ] asTask.
	TKTConfiguration serviceManager startService: self! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
ensureIsAwake
	self isRunning
		ifFalse: [ self restart ]! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
ensureIsWatching: aValue
	worker = aValue ifTrue: [ ^ self ].
	(values includes: aValue)
		ifFalse: [ self watch: aValue ].
	self ensureIsAwake! !

!TKTWatchDog methodsFor: 'accessing' stamp: ''!
pharoProcess
	^ worker process process! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
stepService
	self watchedValues
		ifEmpty: [ self stop ]
		ifNotEmpty: [ values do: [ :v | self watchDog: v ].
			self delay wait ]! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
name
	^ 'WatchDog (' , id asString , ')'! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
cleanUpImageToStart
	values removeAll! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
start
	started
		ifFalse: [ started := true.
			self privateStart ]! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
watch: aValue
	values add: aValue! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
watchedValues
	
	^  values! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
stopWatching: aValue
	values remove: aValue ifAbsent: [  ]! !

!TKTWatchDog methodsFor: 'initialization' stamp: ''!
watchDog: aParameterPool
	[ aParameterPool ensureIsWorking ]
		on: UnhandledError 
		do: [ :err | 
			self traceCr: err printString.
			self
				log:
					'Watch dog is not watching anymore the value: '
						,
							(values remove: aParameterPool ifAbsent: [ aParameterPool ])
								printString ]! !

!TKTWatchDog class methodsFor: 'accessing' stamp: ''!
onDuty
	^ onDuty
		ifNil: [ onDuty := self new.
			onDuty start.
			onDuty ]! !

!TKTWatchDog class methodsFor: 'class initialization' stamp: ''!
reset
	
	onDuty ifNotNil: [ onDuty stop ].
	onDuty := nil.! !

!TKTWorker commentStamp: ''!
!! TKTWorker

The worker runner, instance of TKTWorker, is a task runner that uses a single process to execute tasks from a queue. The worker's single process removes one-by-one the tasks from the queue and executes them sequenceally. Then, schedulling a task into a worker means to add the task inside the queue.

A worker manages the life-cycle of its process and provides the messages start and stop to control when the worker thread will begin and end.

[[[language=smalltalk
worker := TKTWorker new.
worker start.
worker schedule: [ 1 + 5 ].
worker stop.
]]]

By using workers, we can control the amount of alive processes and how tasks are distributed amongst them. For example, in the following example three tasks are executed sequenceally in a single separate process while still allowing us to use an asynchronous style of programming.

[[[language=smalltalk
worker := TKTWorker new start.
future1 := worker future: [ 2 + 2 ].
future2 := worker future: [ 3 + 3 ].
future3 := worker future: [ 1 + 1 ].
]]]

Workers can be combined into worker pools.!
!TKTWorker methodsFor: 'starting' stamp: ''!
stop
	process
		ifNotNil: [ process stop.
			process := nil ].
	TKTConfiguration watchDog stopWatching: self.
	self noteDoesNotNeedToBeFinalized.! !

!TKTWorker methodsFor: 'schedulling' stamp: ''!
isWorker
	^ true! !

!TKTWorker methodsFor: 'accessing' stamp: ''!
taskQueue: anAtomicSharedQueue
	queue := anAtomicSharedQueue.
	process ifNotNil: [ process taskQueue: queue ]! !

!TKTWorker methodsFor: 'starting' stamp: ''!
privateStart
	process start! !

!TKTWorker methodsFor: 'start-stop' stamp: ''!
currentTaskExecution
	^ process ifNotNil: [ process currentTaskExecution ] ifNil: [ nil ]! !

!TKTWorker methodsFor: 'testing' stamp: ''!
isBusy
	^ self isFree not! !

!TKTWorker methodsFor: 'testing' stamp: ''!
isRunning
	^ process isNotNil and: [ process isRunning ]! !

!TKTWorker methodsFor: 'testing' stamp: ''!
isFree
	^ process ifNil: [ true ] ifNotNil: [ process isFree ]! !

!TKTWorker methodsFor: 'accessing' stamp: ''!
priority
	^ priority! !

!TKTWorker methodsFor: 'accessing' stamp: ''!
priority: anInteger
	priority := anInteger.
	self isRunning ifTrue: [self process priority: anInteger]! !

!TKTWorker methodsFor: 'accessing' stamp: ''!
exceptionHandler: aHandler
	exceptionHandler := aHandler.
	process ifNotNil: [ process exceptionHandler: aHandler ]! !

!TKTWorker methodsFor: 'accessing' stamp: ''!
name: aString
	name := aString.
	process ifNotNil: [ process name: aString ]! !

!TKTWorker methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self name: ('Worker-{ID}' format: {(#ID -> UUID new)} asDictionary).
	self ensureIsBeingWatched
	! !

!TKTWorker methodsFor: 'initialization' stamp: ''!
ensureIsBeingWatched
	TKTConfiguration watchDog ensureIsWatching: self! !

!TKTWorker methodsFor: 'accessing' stamp: ''!
exceptionHandler
	
	^ process exceptionHandler! !

!TKTWorker methodsFor: 'starting' stamp: ''!
ensureIsWorking
	self isRunning
		ifFalse: [ self restart ]! !

!TKTWorker methodsFor: 'starting' stamp: ''!
noteNeedsToBeFinalized
	WeakRegistry default add: self! !

!TKTWorker methodsFor: 'accessing' stamp: ''!
name
	^ process ifNil: [ name ] ifNotNil: [ process name ]! !

!TKTWorker methodsFor: 'starting' stamp: ''!
start
	self privatePrepareProcess: TKTConfiguration poolWorkerProcess new.
	self privateStart.
	self priority ifNotNil: [self process priority: self priority].
! !

!TKTWorker methodsFor: 'starting' stamp: ''!
noteDoesNotNeedToBeFinalized
	WeakRegistry default remove: self ifAbsent: [  ]! !

!TKTWorker methodsFor: 'starting' stamp: ''!
restart
	self stop.
	self start.! !

!TKTWorker methodsFor: 'finalization' stamp: ''!
executor

	"The finalization scheme runs in another object (the executor) that does not have 
	all the state, if it has all the state a loop is generated and never GCed"

	^ TKTWorkerExecutor new
		processToKill: process;
		yourself.! !

!TKTWorker methodsFor: 'accessing' stamp: ''!
process

	^ process! !

!TKTWorker methodsFor: 'starting' stamp: ''!
privatePrepareProcess: aWorkerProcess
	process := aWorkerProcess.
	process
		taskQueue: queue;
		name: name;
		yourself.
	exceptionHandler
		ifNotNil: [ process exceptionHandler: exceptionHandler ].
	self noteNeedsToBeFinalized! !

!TKTWorker methodsFor: 'accessing' stamp: ''!
queue
	^ queue! !

!TKTWorker class methodsFor: 'current' stamp: ''!
createDefault
	^ self new
		queue: AtomicSharedQueue new;
		yourself! !

!TKTWorkerExecutor commentStamp: ''!
I am an object that will be used as executor of the TKTWorker. 
In that way I don't need to copy the TKTWorker and nilling its instance variables.!
!TKTWorkerExecutor methodsFor: 'accessing' stamp: ''!
processToKill: anObject
	processToKill := WeakArray with: anObject! !

!TKTWorkerExecutor methodsFor: 'finalization' stamp: ''!
finalize

	(processToKill at: 1) ifNotNil: [:e | e kill]! !

!TKTWorkerMemoryLeakTest methodsFor: 'tests - worker' stamp: ''!
testWorkerInstancesAreCollectedAfterStartingAndStoppingWorkerPool

	self
		trackInstancesOf: TKTWorker
		during: [ TKTWorkerPool new start stop ]! !

!TKTWorkerMemoryLeakTest methodsFor: 'tests - workerprocess' stamp: ''!
testWorkerProcessInstancesAreCollectedAfterStartingAndStoppingWorker

	self
		trackInstancesOf: TKTWorkerProcess
		during: [ TKTWorker new start stop ]! !

!TKTWorkerMemoryLeakTest methodsFor: 'tests - workerprocess' stamp: ''!
testWorkerProcessInstancesAreCollectedAfterStartingAndStoppingWorkerPool

	self
		trackInstancesOf: TKTWorkerProcess
		during: [ TKTWorkerPool new start stop ]! !

!TKTWorkerMemoryLeakTest methodsFor: 'tests - worker' stamp: ''!
testWorkerInstancesAreCollectedAfterStartingAndStoppingWorker
	self trackInstancesOf: TKTWorker during: [ TKTWorker new start stop ]! !

!TKTWorkerMemoryLeakTest methodsFor: 'tests - workerpool' stamp: ''!
testWorkerPoolInstancesAreCollectedAfterStartingAndStoppingWorker

	self
		trackInstancesOf: TKTWorkerPool
		during: [ TKTWorkerPool new start stop ]! !

!TKTWorkerPool commentStamp: ''!
!! TKTWorkerPool

A TaskIT worker pool is pool of worker runners, equivalent to a ThreadPool from other programming languages. Its main purpose is to provide several worker runners and decouple us from the management of threads/processes. A worker pool is a runner in the sense we use the schedule: message to schedule tasks in it. Internally, all runners inside a worker pool share a single task queue.

Different applications may have different concurrency needs, thus, TaskIT worker pools do not provide a default amount of workers. Before using a pool, we need to specify the maximum number of workers in the pool using the poolMaxSize: message. A worker pool will create new workers on demand.

[[[language=smalltalk
pool := TKTWorkerPool new.
pool poolMaxSize: 5.
]]]

TaskIT worker pools use internally an extra worker to synchronize the access to its task queue. Because of this, a worker pool has to be manually started using the start message before scheduled messages start to be executed.

[[[language=smalltalk
pool := TKTWorkerPool new.
pool poolMaxSize: 5.
pool start.
pool schedule: [ 1 logCr ].
]]]

Once we are done with the worker pool, we can stop it by sending it the stop message.

[[[language=smalltalk
pool stop.
]]]!
!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
future: aTask
	^ aTask asTask future: self! !

!TKTWorkerPool methodsFor: 'accessing' stamp: ''!
poolMaxSize: anInteger 
	
	poolMaxSize := anInteger! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
isWorker
	^ false ! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
returnWorker: aTKTWorker 

	freeWorkers nextPut: aTKTWorker! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
purge

	poolWorker purge! !

!TKTWorkerPool methodsFor: 'starting' stamp: ''!
stop

	poolWorker stop.
	
	workers do: #stop.
	workers removeAll.
	
	"Empty the free workers queue"
	[freeWorkers isEmpty]
		whileFalse: [ freeWorkers next ]! !

!TKTWorkerPool methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: 'TKTWorkerPool(';
		nextPutAll: 'poolMaxSize: ';
		print: poolMaxSize;
		nextPutAll: '; busyWorkers: ';
		print: workers size - freeWorkers size;
		nextPutAll: '; freeWorkers: ';
		print: freeWorkers size;
		nextPutAll: ')'! !

!TKTWorkerPool methodsFor: 'testing' stamp: ''!
isFree

	^ workers allSatisfy: [ :each | each isFree ]! !

!TKTWorkerPool methodsFor: 'accessing' stamp: ''!
priority
	^priority! !

!TKTWorkerPool methodsFor: 'accessing' stamp: ''!
priority: anInteger 
	priority := anInteger.
	workers do: [ : each | each priority: anInteger ]! !

!TKTWorkerPool methodsFor: 'accessing' stamp: ''!
name: aString 
	
	poolWorker name: aString! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
newWorker	
	| newWorker |
	newWorker := TKTWorker new.
	newWorker
		priority: self priority;
		name: self name, ' Worker #', (self size + 1) asString;
		start.
	^ workers add: newWorker! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
privateTimeout: timeout on: aTaskExecution
	timeout wait.
	aTaskExecution isFinished
		ifFalse: [ aTaskExecution cancelWithReason: 'Timeout after: ' , timeout asString ]! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
privateSchedule: aTask
	| execution |
	execution := aTask asTask scheduleTaskExecutionFor: self.
	self scheduleTaskExecution: execution
	! !

!TKTWorkerPool methodsFor: 'accessing' stamp: ''!
workers
	
	^ workers copy! !

!TKTWorkerPool methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	workers := Set new.
	freeWorkers := AtomicSharedQueue new.

	poolWorker := TKTWorker new.
	self name: 'Worker' , self identityHash asString.! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
schedule: aTask timeout: aTimeout

	| execution |
	execution := TKTTimeoutableTaskExecution new.
	execution runner: self.
	execution task: aTask.
	execution timeout: aTimeout.
	
	self scheduleTaskExecution: execution.! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
schedule: aTask
	aTask asTask schedule: self! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
scheduleTimeout: timeout on: aTaskExecution
	TKTConfiguration processProvider
		createProcessDoing:
			(MessageSend
				receiver: self
				selector: #privateTimeout:on:
				arguments:
					{timeout.
					aTaskExecution})! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
scheduleTaskExecution: aTaskExecution
	
	poolWorker schedule: [ | worker |
		worker := self getAvailableWorker.
		worker schedule: [
			aTaskExecution value.
			self returnWorker: worker ] ]! !

!TKTWorkerPool methodsFor: 'accessing' stamp: ''!
size
	
	^ workers size! !

!TKTWorkerPool methodsFor: 'accessing' stamp: ''!
name
	
	^ poolWorker name! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
privateFuture: aTask
	| execution |
	execution := aTask asTask futureTaskExecutionFor: self.
	self scheduleTaskExecution: execution.
	^ execution future! !

!TKTWorkerPool methodsFor: 'starting' stamp: ''!
start 
	poolWorker start! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
isUIRunner
	^ false ! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
getAvailableWorker

	| worker |
	worker := freeWorkers nextIfNone: [
			self size < poolMaxSize
				ifTrue: [ self newWorker ]
				ifFalse: [ freeWorkers next ] ].
	^ worker! !

!TKTWorkerPool methodsFor: 'schedulling' stamp: ''!
isLocalThreadRunner
	^ false ! !

!TKTWorkerPool class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TKTWorkerPool class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TKTWorkerPool class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TKTWorkerPool class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TKTWorkerPool class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TKTWorkerPool class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TKTWorkerPool class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TKTWorkerPool class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TKTWorkerPool class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TKTWorkerPool class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TKTWorkerPool class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TKTWorkerPool class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TKTWorkerPool class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TKTWorkerPool class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TKTWorkerPool class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TKTWorkerPool class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TKTWorkerPool class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TKTWorkerPool class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TKTWorkerPool class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TKTWorkerPool class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TKTWorkerPool class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TKTWorkerPool class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!TKTWorkerPool class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!TKTWorkerPool class methodsFor: 'testing' stamp: ''!
isDebuggingCompatible
	^ false! !

!TKTWorkerPool class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!TKTWorkerPool class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TKTWorkerPool class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TKTWorkerPool class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TKTWorkerPool class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TKTWorkerPool class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TKTWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolDoesNotExceedPoolSizeWhenSchedulingTasksInParallel

	| pool totalTasks futures |
	pool := TKTWorkerPool new.
	pool poolMaxSize: 10.
	pool start.
	totalTasks := 0.
		
	futures := AtomicSharedQueue new.
	1 to: 10 do: [:i | 
		futures nextPut: (pool future: [ 
			10 timesRepeat: [ futures nextPut: (pool future: [
					totalTasks := totalTasks + 1 ]) ] ]) ].
	
	[ futures isEmpty ] whileFalse: [ futures next waitForCompletion: 1 second ].
	
	self assert: totalTasks equals: 100.
	self assert: pool size equals: 10! !

!TKTWorkerPoolTest methodsFor: 'tests' stamp: ''!
testPriorityAfterStart
	| pool workerProcess newPriority doneSemaphore|
	newPriority := 32.
	pool := TKTWorkerPool new.
	pool name: 'Test pool'.
	pool poolMaxSize: 4.
	pool start.
	pool schedule: (TKTTask valuable: [Semaphore new wait]).
	doneSemaphore := Semaphore new.
	pool schedule: (TKTTask valuable: [doneSemaphore signal]).
	doneSemaphore wait: 500 milliSeconds.
	pool priority: newPriority.
	self assert: pool priority equals: newPriority.
	pool workers do: [: each | 
		workerProcess :=  each process process.
		self assert: workerProcess priority equals: newPriority].
	! !

!TKTWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolWorkersProcessesAreTerminatedAfterPoolsCollection

	| pool workerProcess |
	pool := TKTWorkerPool new.
	pool name: 'Test pool'.
	pool poolMaxSize: 4.
	pool start.
	(pool future: [ 1 ]) waitForCompletion: 1 second.
	workerProcess := pool workers anyOne process process.
	pool := nil.
	self assertWithGarbageCollect: [ workerProcess isTerminated ].
! !

!TKTWorkerPoolTest methodsFor: 'tests' stamp: ''!
testPrioritySetBeforeStart
	| pool workerProcess initialPriority doneSemaphore |
	initialPriority := 32.
	pool := TKTWorkerPool new.
	pool name: 'Test pool'.
	pool poolMaxSize: 4.
	pool priority: initialPriority.
	self assert: pool priority equals: initialPriority.
	pool start.
	pool schedule: (TKTTask valuable: [Semaphore new wait]).
	doneSemaphore := Semaphore new.
	pool schedule: (TKTTask valuable: [doneSemaphore signal]).
	doneSemaphore wait: 500 milliSeconds.
	pool workers do: [: each | 
		workerProcess :=  each process process.
		self assert: workerProcess priority equals: initialPriority].
	! !

!TKTWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolWorkersProcessesAreStoppedAfterPoolsCollection

	| pool workerProcess |
	pool := TKTWorkerPool new.
	pool name: 'test pool'.
	pool poolMaxSize: 4.
	pool start.

	(pool future: [ 1 ]) waitForCompletion: 1 second.

	workerProcess := WeakArray with: pool workers anyOne process process.

	pool := nil.
	self assertWithGarbageCollect: [ workerProcess first isNil ].! !

!TKTWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolCretesWorkersWhenExecutingATask
	| pool |
	pool := TKTWorkerPool new.
	pool name: 'test pool'.
	pool poolMaxSize: 4.
	pool start.
	(pool future: [ 1 ]) waitForCompletion: 1 second.
	self assert: pool workers notEmpty! !

!TKTWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolWorkersAreStoppedAfterPoolsCollection

	| pool workerProcess |
	pool := TKTWorkerPool new.
	pool name: 'test pool'.
	pool poolMaxSize: 4.
	pool start.

	(pool future: [ 1 ]) waitForCompletion: 1 second.

	self assert: pool workers notEmpty.

	workerProcess := WeakArray with: pool workers anyOne process.

	pool := nil.
	self assertWithGarbageCollect: [ workerProcess first isNil ].! !

!TKTWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolDoesNotExceedPoolSize
	| pool |
	pool := TKTWorkerPool new.
	pool poolMaxSize: 4.
	pool start.
	((1 to: 10) collect: [ :i | pool future: [ 1 + 1 ] ])
		do: [ :future | future waitForCompletion: 1 second ].
	self assert: pool size <= 4! !

!TKTWorkerPoolTest methodsFor: 'tests' stamp: ''!
testWorkerPoolStopStopsWorkers

	| pool |
	pool := TKTWorkerPool new.
	pool poolMaxSize: 4.
	pool start.
		
	((1 to: 10) collect: [:i | pool future: [ 1 + 1 ] ])
		do: [ :future | future waitForCompletion: 500 milliSeconds. ].
	
	pool stop.
	
	pool workers do: [ :worker | self deny: worker isRunning ].! !

!TKTWorkerProcess commentStamp: ''!
I am a task executer paired with a worker. A worker-workerProcess pair shares the same taskQueue so the worker can schedule on it and I can execute them.

The reason I exist is that if the Pharo process executing the worker's task has a reference to the worker, then the worker may never be collected. If this happens, a memory leak could occur if we lose every other reference to the worker, since the worker nor the process will ever be collected.

We avoid this problem by only sharing the task queue. Then, the process does not have a strong reference to the worker and:
  - the worker can be garbage collected
  - if the worker (and all its associated futures) are garbage collected, since the worker process is unreachable we can schedule a #stop task. See method TKTWorker>> #finalize.!
!TKTWorkerProcess methodsFor: 'start-stop' stamp: ''!
stop
	process ifNotNil: [
		process terminate.
		process := nil ]! !

!TKTWorkerProcess methodsFor: 'accessing' stamp: ''!
taskQueue: aQueue
	taskQueue := aQueue! !

!TKTWorkerProcess methodsFor: 'accessing' stamp: ''!
taskQueue
	^ taskQueue! !

!TKTWorkerProcess methodsFor: 'start-stop' stamp: ''!
currentTaskExecution
	^ currentTaskExecution! !

!TKTWorkerProcess methodsFor: 'start-stop' stamp: ''!
executeTask: aTaskExecution
	currentTaskExecution := aTaskExecution.
	super executeTask: aTaskExecution.
	currentTaskExecution := nil! !

!TKTWorkerProcess methodsFor: 'testing' stamp: ''!
isRunning
	
	^ process notNil and: [ process isTerminated not ]! !

!TKTWorkerProcess methodsFor: 'start-stop' stamp: ''!
isFree
	^ currentTaskExecution isNil! !

!TKTWorkerProcess methodsFor: 'accessing' stamp: ''!
priority
	^self process priority! !

!TKTWorkerProcess methodsFor: 'accessing' stamp: ''!
name 
	
	^ name! !

!TKTWorkerProcess methodsFor: 'accessing' stamp: ''!
name: aString 
	
	name := aString! !

!TKTWorkerProcess methodsFor: 'accessing' stamp: ''!
priority: anInteger 
	self process priority: anInteger .! !

!TKTWorkerProcess methodsFor: 'start-stop' stamp: ''!
privateNextTask
	^ taskQueue next! !

!TKTWorkerProcess methodsFor: 'start-stop' stamp: ''!
start
	process := TKTConfiguration processProvider
		createProcessDoing: (MessageSend receiver: self selector: #workerLoop)
		named: name! !

!TKTWorkerProcess methodsFor: 'testing' stamp: ''!
process

	^ process! !

!TKTWorkerProcess methodsFor: 'start-stop' stamp: ''!
kill
	self stop.
	taskQueue := nil. ! !

!TKTWorkerProcess methodsFor: 'start-stop' stamp: ''!
workerLoop
	[ self executeTask: self privateNextTask ] repeat! !

!TKTWorkerTest methodsFor: 'tests' stamp: ''!
testWorkerRunsInSeparateProcess

	| worker hash future |
	worker := TKTWorker new.
	worker start.
	
	future := worker future: [ hash := Processor activeProcess identityHash ].
	future waitForCompletion: 1 hour.
	
	self assert: hash ~= Processor activeProcess identityHash.! !

!TKTWorkerTest methodsFor: 'tests' stamp: ''!
testWorkerProcessIsWorkingUntilAllTasksAreDone

	| worker process waitFuture |
	worker := TKTWorker new.
	worker start.
	process := worker process.
	waitFuture := TKTFuture doing: [ 
		              [ process isRunning ] whileTrue: [ 
			              50 milliSeconds wait ] ].
	worker schedule: [ 100 milliSeconds wait ].
	self assert: process taskQueue size equals: 1.
	50 milliSeconds wait.
	self assert: process taskQueue size equals: 0.
	worker := nil.
	self assert: process taskQueue size equals: 0.
	self assert: process isRunning.
	self waitGarbageCollect.
	waitFuture waitForCompletion: 100 second.
	self deny: process isRunning! !

!TKTWorkerTest methodsFor: 'tests' stamp: ''!
testWorkerExceptionIsHandledByExceptionHandler

	| error worker |
	worker := TKTWorker new.
	worker exceptionHandler: (TKTTestExceptionHandler new).
	worker start.
	
	error := Error new.
	worker schedule: [ error signal ].
	
	"We wait until the error is signaled, trapped and we have it."
	100 milliSeconds wait.
	self assert: worker exceptionHandler error equals: error! !

!TKTWorkerTest methodsFor: 'tests' stamp: ''!
testWorkerRunsAlwaysInSameProcess

	| worker hash futures hashes |
	worker := TKTWorker new.
	worker start.
	
	futures := (1 to: 10) collect: [ :i | worker future: [ hash := Processor activeProcess identityHash ] ].
	hashes := futures collect: [ :each | each synchronizeTimeout: 1 hour ].
	
	self assert: hashes asSet size equals: 1! !

!TKTWorkerTest methodsFor: 'tests' stamp: ''!
testWorkerProcessDiesAfterWorkerIsCollected

	| worker future process |
	worker := TKTWorker new.
	worker start.
	process := worker process.
	worker := nil.
	self waitGarbageCollect.
	future := TKTFuture doing: [ 
		          [ process isRunning ] whileTrue: [ 50 milliSeconds wait ] ].
	future synchronizeTimeout: 2 seconds.
	self deny: process isRunning! !

!TKTWorkerTest methodsFor: 'tests' stamp: ''!
testWorkerProcessDiesAfterStop

	| worker future |
	worker := TKTWorker new.
	worker start.
	worker stop.
	future := TKTFuture doing: [ [ worker isRunning ] whileTrue: [ 50 milliSeconds wait ] ].
	future synchronizeTimeout: 2 seconds.
	self deny: worker isRunning! !

!TKTWorkerTest methodsFor: 'tests' stamp: ''!
testWorkerProcessDiesAfterWorkerAndAllFuturesAreCollected

	| worker future process waitFuture1 waitFuture2 |
	worker := TKTWorker new.
	worker start.
	process := worker process.
	waitFuture1 := TKTFuture doing: [ 
		               [ process isRunning ] whileTrue: [ 
			               50 milliSeconds wait ] ].
	waitFuture2 := TKTFuture doing: [ 
		               [ process isRunning ] whileTrue: [ 
			               50 milliSeconds wait ] ].
	future := worker future: [ 10 milliSeconds wait ].
	worker := nil.
	self waitGarbageCollect.
	self
		should: [ waitFuture1 synchronizeTimeout: 200 milliSeconds ]
		raise: TKTTimeoutException.
	self assert: process isRunning.
	future := nil.
	self waitGarbageCollect.
	self waitGarbageCollect.
	waitFuture2 synchronizeTimeout: 400 milliSeconds.
	self deny: process isRunning! !

!TLGitCalloutTrait commentStamp: 'TorstenBergmann 6/2/2021 21:09'!
Trait to bundle callout functionality!
!TLGitCalloutTrait methodsFor: 'signalling' stamp: ' 1/5/2022 21:01:26'!
signalIfNotReady

	self ifNotReady: [ self signalNotReady ]! !

!TLGitCalloutTrait methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibrary

	^ self class ffiLibrary! !

!TLGitCalloutTrait methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiNull

	^ FFIExternalObject null! !

!TLGitCalloutTrait methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibraryName

	^ self class ffiLibraryName! !

!TLGitCalloutTrait methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
ifNotReady: aBlock
	"Use extra block so compiler can optimize"

	self isReady ifFalse: [ aBlock value ]! !

!TLGitCalloutTrait methodsFor: 'argument validation' stamp: ' 1/5/2022 21:01:26'!
validate: anObject shouldBe: aClass

	self class validate: anObject shouldBe: aClass! !

!TLGitCalloutTrait methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
isReady

	^ true! !

!TLGitCalloutTrait methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec options: options
	<ffiCalloutTranslator>

	^ self ffiCall: fnSpec options: options! !

!TLGitCalloutTrait methodsFor: 'signalling' stamp: ' 1/5/2022 21:01:26'!
signalNotReady

	LGitObjectNotInitialized signalWith: self! !

!TLGitCalloutTrait methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec
	<ffiCalloutTranslator>
	
	^ self ffiCall: fnSpec! !

!TLGitCalloutTrait methodsFor: 'exit code handling' stamp: ' 1/5/2022 21:01:26'!
withReturnHandlerDo: callBlock

	^ callBlock value handleLGitReturnCode! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TLGitCalloutTrait classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TLGitCalloutTrait classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TLGitCalloutTrait classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TLGitCalloutTrait classTrait methodsFor: 'argument validation' stamp: ' 1/5/2022 21:01:26'!
validate: anObject shouldBe: aClass
	"I allow for nil values."
	(anObject isNil or: [ anObject isKindOf: aClass ])
		ifFalse: [ LGitIllegalArgument signalWith: anObject shouldBe: aClass ]! !

!TLGitCalloutTrait classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TLGitCalloutTrait classTrait methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec
	<ffiCalloutTranslator>
	
	^ self ffiCall: fnSpec! !

!TLGitCalloutTrait classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TLGitCalloutTrait classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibrary
	^LGitLibrary uniqueInstance! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TLGitCalloutTrait classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TLGitCalloutTrait classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TLGitCalloutTrait classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TLGitCalloutTrait classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TLGitCalloutTrait classTrait methodsFor: 'exit code handling' stamp: ' 1/5/2022 21:01:26'!
withReturnHandlerDo: callBlock
	^ callBlock value handleLGitReturnCode! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TLGitCalloutTrait classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
ffiLibraryName
	^self ffiLibrary libraryName! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TLGitCalloutTrait classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TLGitCalloutTrait classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TLGitCalloutTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TLGitCalloutTrait classTrait methodsFor: 'ffi-calls' stamp: ' 1/5/2022 21:01:26'!
ffiCallSafely: fnSpec options: options
	<ffiCalloutTranslator>

	^ self ffiCall: fnSpec options: options! !

!TLGitCalloutTrait classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TLGitCalloutTrait classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TLGitPrintingTrait commentStamp: 'TorstenBergmann 6/2/2021 21:09'!
Trait to bundle printout functionality!
!TLGitPrintingTrait methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
printOn: aStream

	| title |
	title := self class name.
	aStream
		nextPutAll: (title first isVowel ifTrue: [ 'an ' ] ifFalse: [ 'a ' ]);
		nextPutAll: title.
		
	(self shouldContinuePrintingOn: aStream) ifFalse: [ ^ self ].
	
	aStream nextPutAll: ' ('.
	self objectPrintOn: aStream.
	aStream nextPut: $)! !

!TLGitPrintingTrait methodsFor: 'testing' stamp: ' 1/5/2022 21:01:26'!
shouldContinuePrintingOn: aStream

	^ true! !

!TLGitPrintingTrait methodsFor: 'printing' stamp: ' 1/5/2022 21:01:26'!
objectPrintOn: aStream! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TLGitPrintingTrait classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TLGitPrintingTrait classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TLGitPrintingTrait classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TLGitPrintingTrait classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TLGitPrintingTrait classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TLGitPrintingTrait classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TLGitPrintingTrait classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TLGitPrintingTrait classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TLGitPrintingTrait classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TLGitPrintingTrait classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TLGitPrintingTrait classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TLGitPrintingTrait classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TLGitPrintingTrait classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TLGitPrintingTrait classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TLGitPrintingTrait classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TLGitPrintingTrait classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TMockWithComplexSlot commentStamp: ''!
A trait mock with a complex slot to be used in tests!
!TMockWithComplexSlot methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.	
	self class initializeSlots: self
! !

!TMockWithComplexSlot methodsFor: 'accessing' stamp: ''!
complexSlot

	^ complexSlot! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TMockWithComplexSlot classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TMockWithComplexSlot classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TMockWithComplexSlot classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TMockWithComplexSlot classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TMockWithComplexSlot classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TMockWithComplexSlot classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TMockWithComplexSlot classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TMockWithComplexSlot classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TMockWithComplexSlot classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TMockWithComplexSlot classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TMockWithComplexSlot classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TMockWithComplexSlot classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TMockWithComplexSlot classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TMockWithComplexSlot classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TMockWithComplexSlot classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TMockWithComplexSlot classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TMockWithUseAndSlot commentStamp: ''!
A trait mock using another trait and a simple slot slot to be used in tests!
!TMockWithUseAndSlot methodsFor: 'local' stamp: ''!
c

	^ 'Trait3>>c'! !

!TMockWithUseAndSlot methodsFor: 'accessing' stamp: ''!
simpleSlot

	^ simpleSlot! !

!TMockWithUseAndSlot methodsFor: 'local' stamp: ''!
c3

	^ 'Trait3>>c3'! !

!TMockWithUseAndSlot methodsFor: 'trait2 - c' stamp: ''!
c2

	^ 'Trait2>>c2'! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TMockWithUseAndSlot classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TMockWithUseAndSlot classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TMockWithUseAndSlot classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TMockWithUseAndSlot classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TMockWithUseAndSlot classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TMockWithUseAndSlot classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TMockWithUseAndSlot classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TMockWithUseAndSlot classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TMockWithUseAndSlot classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TMockWithUseAndSlot classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TMockWithUseAndSlot classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TMockWithUseAndSlot classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TMockWithUseAndSlot classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TMockWithUseAndSlot classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TMockWithUseAndSlot classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TMockWithUseAndSlot classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TModelBuilder commentStamp: ''!
A trait to build models for tests purposes!
!TModelBuilder methodsFor: 'mocking' stamp: ''!
extractMethodTestData
	| newModel classEnvironment classes |
	classes := #(#MyClassA #MyClassB #MyClassC ) 
		inject: OrderedCollection new 
		into: [ :sum :each | 
			self environmentOfTest at: each ifPresent: [ :class | 
				sum add: class; add: class class ].
			sum ].
	classEnvironment := RBClassEnvironment classes: classes.
	newModel := self defaultNamespace onEnvironment: classEnvironment not.
	newModel name: 'Test'.
	
	#('Object subclass: #MyClassA
		instanceVariableNames: ''instVarName1 instVarName2''
		classVariableNames: ''ClassVarName1 ClassVarName2 ''
		poolDictionaries: ''''
		category: ''Testing'' '
	'MyClassA subclass: #MyClassB
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Testing'' '
	'MyClassB subclass: #MyClassC
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Testing'' '
	) do: [ :each | 
		newModel defineClass: each ].
	
	#(#(#MyClassA #(
		#('bar
			^ self' #tests)
		#('name
			^ ''SomeString''' #tests)
		#('methodWithArg: anArg
			^ anArg not' #tests) 
		#('methodWithArg: anArg1 andArg: anArg2
			^ (anArg1 > anArg2) not' #tests) 
		#('problemCount
			^ 435' #tests)
		#('string: aString stream: aStream
			nil')
		#('myMethod
			| token |
			token := (String new: 100) writeStream.
			[ currentChar isLetter ] whileTrue: [ 
				token nextPut: currentChar.
				self methodWithArg: currentChar isLetter.
				self bar ].
			currentChar isLetter.
			$3 isLetter.
	 		currentChar isLetter.
			token :=  currentChar isLetter.
			token := ( currentChar isLetter) example.
			^ token contents' #tests)
		#('displayName
			| nameStream string|
			string := self name.
			nameStream := WriteStream on: (String new: 64).
		nameStream nextPutAll: string;
			nextPutAll: '' (''.
		self problemCount printOn: nameStream.
		nameStream nextPut: $).
		^nameStream contents' #tests)))
	#(#MyClassB #(
		#('someMethod
			^ instVarName2 := 3' #tests)
		#('exampleMethod
			^ (currentChar isLetter) not' #tests) 
		#('dummyMethod
			(3 > self someMethod) not' #tests)
		#('anotherMethod
			|aStream|
			aStream := WriteStream on: (String new: 128).
			aStream nextPutAll: ''dfgdf'';
				nextPutAll: '' (''.
			self problemCount printOn: aStream.
			aStream nextPut: $).' #tests)))
	#(#MyClassC #(
		#('methodWithArg: anArg
			(currentChar isLetter and: [anArg isDecimal])
			ifTrue: [^ self].
			^ nil' #tests)
		#('visitMonospace: aFormat
			aFormat children do: [ :each | each accept: self ].
			self fixBlockWithoutMicText: aFormat' #tests)
		#('visitStrike: aFormat
			aFormat children do: [ :each | each accept: self ].
			self fixBlockWithoutMicText: aFormat.
			#( 4 5 2 ) do: [ :val | val children do: [ :each | each accept: self ] ]' #tests)
		#('visitParagraph: aParagraph
			^ aParagraph children do: [:each | each accept: self ]' #tests)
		)))
		do: [:each | 
			| class |
			class := newModel classNamed: each first.
			each last do: [ :methodPair | 
				class 
					compile: methodPair first
					classified: methodPair last]].
	^ newModel! !

!TModelBuilder methodsFor: 'mocking' stamp: ''!
abstractVariableTestData

	| newModel classEnvironment classes |
	classes := #(#Bar #Foo) 
		inject: OrderedCollection new 
		into: [ :sum :each | 
			self environmentOfTest at: each ifPresent: [ :class | 
				sum add: class; add: class class ].
			sum ].
	classEnvironment := RBClassEnvironment classes: classes.
	newModel := self defaultNamespace onEnvironment: classEnvironment not.
	newModel name: 'Test'.
	
	#('Object subclass: #Foo
		instanceVariableNames: ''instVarName1 instVarName2''
		classVariableNames: ''ClassVarName1 ClassVarName2 ''
		poolDictionaries: ''''
		category: ''Testing'' '
	'Foo subclass: #Bar
		instanceVariableNames: ''''
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''Testing'' '
	) do: [ :each | newModel defineClass: each ].
	
	#(#(#Bar #(
		#('instVarName1
			^1242321' #tests) 
		#('foo
			instVarName1 := instVarName1 + instVarName2 + ClassVarName1' #tests))) 
	#(#Foo #(
		#('foo
			^instVarName2 := 3' #tests)
		#('bar
			"Add one to instVarName1"
			instVarName1 := instVarName1 + 1' #tests) 
		#('classVarName1
			^ClassVarName1' #tests)
		#('instVarName1: anObject
			^anObject' #tests)
		#('asdf
			^self classVarName1: (ClassVarName1 := ClassVarName1 + 1)' #tests) 
		#('instVarName2
			^instVarName2' #tests)
		#('instVarName2: anObject
			instVarName2 := anObject' #tests)
		#('classVarName1: anObject
			^ClassVarName1 := anObject' #tests)))
	
	#('Bar class' #(
		#('classVarName2: anObject
			ClassVarName2 := anObject' #tests) 
		#('classVarName2
			^ClassVarName2' #tests))) 
	#('Foo class' #(
		#('foo
			^ClassVarName1 := ClassVarName1 * ClassVarName1 * ClassVarName1' #tests)))) 
		do: [:each | 
			| class |
			class := newModel classNamed: each first.
			each last do: [ :methodPair | 
				class 
					compile: methodPair first
					classified: methodPair last]].
	^ newModel! !

!TModelBuilder methodsFor: 'mocking' stamp: ''!
inlineMethodTestData
	^ Smalltalk compiler evaluate: '
		| 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
'! !

!TModelBuilder methodsFor: 'accessing' stamp: ''!
defaultNamespace
	^RBNamespace! !

!TModelBuilder methodsFor: 'mocking' stamp: ''!
childrenToSiblingTestData
	^ Smalltalk compiler evaluate: '
	| 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
'! !

!TModelBuilder classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TModelBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TModelBuilder classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TModelBuilder classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TModelBuilder classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TModelBuilder classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TModelBuilder classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TModelBuilder classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TModelBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TModelBuilder classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TModelBuilder classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TModelBuilder classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TModelBuilder classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TModelBuilder classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TModelBuilder classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TModelBuilder classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TModelBuilder classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TModelBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TModelBuilder classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TModelBuilder classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TModelBuilder classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TModelBuilder classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TModelBuilder classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TModelBuilder classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TModelBuilder classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TModelBuilder classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TObservable commentStamp: ''!
I am a trait allowing one to interact with an ObservableSlot. 

An ObservableSlot allows one to register actions that will be executed when the content of a variable change.

Public API and Key Messages
--------------------

- #property:whenChangedDo: 		With this method one can declare than when the value in a given observable slot change, an action must be executed. 
- #property:rawValue: 			With this method a value can be writen without launching any action.

Examples
--------------------

	| count |
	count := 0.
	point := ObservablePoint new.
	point property: #x whenChangedDo: [ count := count + 1 ].

	point x: 17.

	self assert: count equals: 1

!
!TObservable methodsFor: 'events' stamp: ''!
property: aName rawValue: anObject
	"Write in the slot without announcing it."

	(self observablePropertyNamed: aName) rawValue: anObject! !

!TObservable methodsFor: 'events' stamp: ''!
observablePropertyNamed: aName
	| slot |
	slot := self class slotNamed: aName.
	(slot class == ObservableSlot) ifFalse: [ NonObservableSlotError signal: aName ].

	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	^ slot rawRead: self! !

!TObservable methodsFor: 'events' stamp: ''!
notifyPropertyChanged: aName
	self flag: #pharoTodo.	"This is used for collections but collections should be managed in a better way and this method removed."
	(self observablePropertyNamed: aName) valueChanged! !

!TObservable methodsFor: 'events' stamp: ''!
property: aName whenChangedDo: aBlockClosure 
	
	"Obtain the raw value.
	We need to access the underlying value holder to subscribe to it"
	(self observablePropertyNamed: aName) whenChangedDo: aBlockClosure! !

!TObservable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TObservable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TObservable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TObservable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TObservable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TObservable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TObservable classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TObservable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TObservable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TObservable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TObservable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TObservable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TObservable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TObservable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TObservable classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TObservable classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TObservable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TObservable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TObservable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TObservable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TObservable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TObservable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TObservable classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TObservable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TObservable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TObservable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TOccurrencesForIdentityCollectionsTest commentStamp: ''!
A trait for test purposes!
!TOccurrencesForIdentityCollectionsTest methodsFor: 'tests - occurrencesOf for identity collections' stamp: ''!
testOccurrencesOfForIdentityCollections

| collection element elementCopy |
collection := self identityCollectionWithElementsCopyNotIdentical .
element := collection anyOne.
elementCopy := element copy.

self assert: (collection occurrencesOf: elementCopy ) = 0.! !

!TOccurrencesForIdentityCollectionsTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesForIdentityCollectionsTest
	self identityCollectionWithElementsCopyNotIdentical.
	self identityCollectionWithElementsCopyNotIdentical do: [ :each | self deny: each copy == each ]! !

!TOccurrencesForIdentityCollectionsTest methodsFor: 'requirements' stamp: ''!
identityCollectionWithElementsCopyNotIdentical
" return a collection including elements for which #copy return a new object "
^ self explicitRequirement! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TOccurrencesForIdentityCollectionsTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TOccurrencesForMultiplinessTest commentStamp: ''!
A trait for test purposes!
!TOccurrencesForMultiplinessTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!TOccurrencesForMultiplinessTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOf
	| collection |
	collection := self collectionWithoutEqualElements .
	
	collection do: [ :each | self assert: (collection occurrencesOf: each) equals: 1 ]! !

!TOccurrencesForMultiplinessTest methodsFor: 'requirements' stamp: ''!
empty
	self explicitRequirement! !

!TOccurrencesForMultiplinessTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty

	| result |
	result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne).
	self assert: result equals: 0! !

!TOccurrencesForMultiplinessTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesForMultiplinessTest
	| cpt |
	self collectionWithEqualElements.
	self collectionWithEqualElements.
	self elementTwiceInForOccurrences.
	self elementTwiceInForOccurrences.
	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! !

!TOccurrencesForMultiplinessTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''!
testOccurrencesOfForMultipliness

	| collection elem |
	collection := self collectionWithEqualElements.
	elem := self elementTwiceInForOccurrences.

	self assert: (collection occurrencesOf: elem ) equals: 2.! !

!TOccurrencesForMultiplinessTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!TOccurrencesForMultiplinessTest methodsFor: 'requirements' stamp: ''!
elementNotInForOccurrences
" return an element notIncluded in #collectionWithoutEqualElements"
	self explicitRequirement! !

!TOccurrencesForMultiplinessTest methodsFor: 'requirements' stamp: ''!
collectionWithEqualElements
" return a collecition including atLeast two elements equal"

^ self explicitRequirement.! !

!TOccurrencesForMultiplinessTest methodsFor: 'requirements' stamp: ''!
elementTwiceInForOccurrences
" return an element included exactly two time in # collectionWithEqualElements"
^ self explicitRequirement! !

!TOccurrencesForMultiplinessTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
	self explicitRequirement! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TOccurrencesForMultiplinessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TOccurrencesTest commentStamp: ''!
A trait for test purposes!
!TOccurrencesTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureOccurrencesTest
	| tmp |
	self empty.
	self assertEmpty: self empty.
	self collectionWithoutEqualElements.
	self denyEmpty: self collectionWithoutEqualElements.
	tmp := OrderedCollection new.
	self collectionWithoutEqualElements
		do: [ :each | 
			self deny: (tmp includes: each).
			tmp add: each ].
	self elementNotInForOccurrences.
	self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! !

!TOccurrencesTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOf
	| collection |
	collection := self collectionWithoutEqualElements .
	
	collection do: [ :each | self assert: (collection occurrencesOf: each) equals: 1 ]! !

!TOccurrencesTest methodsFor: 'requirements' stamp: ''!
empty
	self explicitRequirement! !

!TOccurrencesTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfEmpty
	| result |
	result := self empty occurrencesOf: self collectionWithoutEqualElements anyOne.
	self assert: result equals: 0! !

!TOccurrencesTest methodsFor: 'tests - occurrencesOf' stamp: ''!
testOccurrencesOfNotIn

	| result |
	result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences.
	self assert: result equals: 0! !

!TOccurrencesTest methodsFor: 'requirements' stamp: ''!
elementNotInForOccurrences
" return an element notIncluded in #collectionWithoutEqualElements"
	self explicitRequirement! !

!TOccurrencesTest methodsFor: 'requirements' stamp: ''!
collectionWithoutEqualElements
	self explicitRequirement! !

!TOccurrencesTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TOccurrencesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TOccurrencesTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TOccurrencesTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TOccurrencesTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TOccurrencesTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TOccurrencesTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TOccurrencesTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TOccurrencesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TOccurrencesTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TOccurrencesTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TOccurrencesTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TOccurrencesTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TOccurrencesTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TOccurrencesTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TOccurrencesTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TOccurrencesTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TOccurrencesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TOccurrencesTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TOccurrencesTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TOccurrencesTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TOccurrencesTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TOccurrencesTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TOccurrencesTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TOccurrencesTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TOccurrencesTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TOne commentStamp: ''!
I am a trait used for testing.!
!TOne methodsFor: 'testing' stamp: ''!
one
	^ 1! !

!TOne classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TOne classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TOne classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TOne classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TOne classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TOne classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TOne classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TOne classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TOne classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TOne classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TOne classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TOne classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TOne classTrait methodsFor: 'testing' stamp: ''!
classOne
	^ 1! !

!TOne classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TOne classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TOne classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TOne classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TOne classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TOne classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TOne classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TOne classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TOne classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TOne classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TOne classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TOne classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TOne classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TOne classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TPointAccess commentStamp: ''!
Contains methods for accessing points stored in variable word classes.
Initially used by PointArray & ShortPointArray!
!TPointAccess methodsFor: 'accessing' stamp: ''!
bounds
	| min max |
	min := max := self at: 1.
	self do:[:pt|
		min := min min: pt.
		max := max max: pt].
	^min corner: max! !

!TPointAccess methodsFor: 'accessing' stamp: ''!
at: index put: aPoint

	super at: index * 2 - 1 put: aPoint x asInteger.
	super at: index * 2 put: aPoint y asInteger.
	^aPoint! !

!TPointAccess methodsFor: 'accessing' stamp: ''!
defaultElement 

	"Return the default element of the receiver"
	^0@0! !

!TPointAccess methodsFor: 'accessing' stamp: ''!
at: index

	^(super at: index * 2 - 1) @ (super at: index * 2)! !

!TPointAccess classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TPointAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TPointAccess classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TPointAccess classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TPointAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TPointAccess classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TPointAccess classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TPointAccess classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TPointAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TPointAccess classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TPointAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TPointAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TPointAccess classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TPointAccess classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TPointAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TPointAccess classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TPointAccess classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TPointAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TPointAccess classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TPointAccess classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TPointAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TPointAccess classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TPointAccess classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TPointAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TPointAccess classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TPointAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TPrintOnSequencedTest commentStamp: ''!
A trait for test purposes!
!TPrintOnSequencedTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', '.
	
	allElementsAsString := (result findBetweenSubstrings: ', ' ).
	allElementsAsString withIndexDo: 
		[:el :i |  self assert: el equals: ((self nonEmpty at:i)asString)]! !

!TPrintOnSequencedTest methodsFor: 'requirements' stamp: ''!
nonEmpty
 self explicitRequirement! !

!TPrintOnSequencedTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printElementsOn: aStream.
	allElementsAsString:=(result findBetweenSubstrings: ' ').
	allElementsAsString withIndexDo: 
		[:el :i | self assert: el equals: ((self nonEmpty at: i)asString) ]! !

!TPrintOnSequencedTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printNameOn: aStream.

	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents equals: ('an ',self nonEmpty class name ) ]
		ifFalse:[ self assert: aStream contents equals: ('a ',self nonEmpty class name)].! !

!TPrintOnSequencedTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString |
	result:=''.
	aStream:= ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ').
	allElementsAsString withIndexDo: 
		[:el :i | 
		i<(allElementsAsString size-1 )
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:i)asString)].
		i=(allElementsAsString size-1)
			ifTrue:[ self deny: (allElementsAsString at:i) equals: ('and')asString].
		i=(allElementsAsString size)
			ifTrue: [self assert: (allElementsAsString at:i) equals: ((self nonEmpty at:(i-1))asString)]]! !

!TPrintOnSequencedTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest

	self nonEmpty! !

!TPrintOnSequencedTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn

	| aStream result allElementsAsString |
	result := ''.
	aStream := ReadWriteStream on: result.
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	allElementsAsString withIndexDo: 
		[:el :i | 
		i=1
			ifTrue:[
				self accessCollection class name first isVowel 
					ifTrue:[self assert: el equals: 'an' ]
					ifFalse:[self assert: el equals: 'a'].].
		i=2
			ifTrue:[self assert: el equals: self accessCollection class name].
		i>2
			ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]]! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TPrintOnSequencedTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TPrintOnSequencedTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TPrintOnSequencedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TPrintOnSequencedTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TPrintOnSequencedTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TPrintOnSequencedTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TPrintOnSequencedTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TPrintOnSequencedTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TPrintOnSequencedTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TPrintOnSequencedTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TPrintOnSequencedTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TPrintOnSequencedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TPrintOnSequencedTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TPrintOnSequencedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TPrintOnSequencedTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TPrintOnSequencedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TPrintTest commentStamp: ''!
A trait for test purposes!
!TPrintTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiter
	
	| result allElementsAsString tmp |
	
	result := String streamContents: [ :aStream |
		tmp := OrderedCollection new.
		self nonEmpty do: [:each | tmp add: each asString].
		self nonEmpty printOn: aStream delimiter: ', ' ].
	
	allElementsAsString := (result findBetweenSubstrings: ', ').
	
	1 to: allElementsAsString size do:
		[:i | 
		self assert: (tmp occurrencesOf:(allElementsAsString at:i)) equals: (allElementsAsString  occurrencesOf:(allElementsAsString at:i)) ].! !

!TPrintTest methodsFor: 'requirements' stamp: ''!
nonEmpty
 self explicitRequirement! !

!TPrintTest methodsFor: 'tests - printing' stamp: ''!
testPrintElementsOn

	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printElementsOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	1 to: allElementsAsString size do:
		[:i | 
		self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString  occurrencesOf:(allElementsAsString at:i)).
			].! !

!TPrintTest methodsFor: 'tests - printing' stamp: ''!
testPrintNameOn

	| aStream result |
	result:=''.
	aStream:= ReadWriteStream on: result.
	self nonEmpty printNameOn: aStream.
	self nonEmpty class name first isVowel
		ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ]
		ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! !

!TPrintTest methodsFor: 'tests - printing' stamp: ''!
testPrintOnDelimiterLast

	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printOn: aStream delimiter: ', ' last: 'and'.
	
	allElementsAsString:=(result findBetweenSubstrings: ', ' ).
	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))].
			].! !

!TPrintTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePrintTest
	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!TPrintTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn
	| aStream result allElementsAsString tmp |
	result:=''.
	aStream:= ReadWriteStream on: result.
	tmp:= OrderedCollection new.
	self nonEmpty do: [:each | tmp add: each asString].
	
	self nonEmpty printOn: aStream .
	allElementsAsString:=(result findBetweenSubstrings: ' ' ).
	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)).].	
			].! !

!TPrintTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TPrintTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TPrintTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TPrintTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TPrintTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TPrintTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TPrintTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TPrintTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TPrintTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TPrintTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TPrintTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TPrintTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TPrintTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TPrintTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TPrintTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TPrintTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TPrintTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TPrintTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TPrintTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TPrintTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TPrintTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TPrintTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TPrintTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TPrintTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TPrintTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TPrintTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TPutBasicTest commentStamp: ''!
A trait for test purposes!
!TPutBasicTest methodsFor: 'tests - at put' stamp: ''!
testAtPutOutOfBounds
	
	self should: [self empty at: self anIndex put: self aValue] raise: Error! !

!TPutBasicTest methodsFor: 'requirements' stamp: ''!
aValue
" return a value to put into nonEmpty"
	^ self explicitRequirement! !

!TPutBasicTest methodsFor: 'tests - at put' stamp: ''!
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.! !

!TPutBasicTest methodsFor: 'requirements' stamp: ''!
empty
	^self explicitRequirement.! !

!TPutBasicTest methodsFor: 'requirements' stamp: ''!
nonEmpty

	^ self explicitRequirement! !

!TPutBasicTest methodsFor: 'tests - at put' stamp: ''!
testAtPut
	
	self nonEmpty at: self anIndex put: self aValue.
	self assert: (self nonEmpty at: self anIndex) = self aValue.! !

!TPutBasicTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutTest
	self aValue.
	self anotherValue.

	self anIndex.
	self nonEmpty isDictionary ifFalse: [ self assert: (self anIndex >= 1 & self anIndex) <= self nonEmpty size ].

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!TPutBasicTest methodsFor: 'requirements' stamp: ''!
anotherValue
" return a value ( not eual to 'aValue' ) to put into nonEmpty "
	^ self explicitRequirement! !

!TPutBasicTest methodsFor: 'requirements' stamp: ''!
anIndex
" return an index in nonEmpty bounds"
	^ self explicitRequirement! !

!TPutBasicTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TPutBasicTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TPutBasicTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TPutBasicTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TPutBasicTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TPutBasicTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TPutBasicTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TPutBasicTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TPutBasicTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TPutBasicTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TPutBasicTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TPutBasicTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TPutBasicTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TPutBasicTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TPutBasicTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TPutBasicTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TPutBasicTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TPutBasicTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TPutBasicTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TPutBasicTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TPutBasicTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TPutBasicTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TPutBasicTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TPutBasicTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TPutBasicTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TPutBasicTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TPutTest commentStamp: ''!
A trait for test purposes!
!TPutTest methodsFor: 'requirements' stamp: ''!
aValue
" return a value to put into nonEmpty"
	^ self explicitRequirement! !

!TPutTest methodsFor: 'requirements' stamp: ''!
indexArray
" return a Collection including indexes between bounds of 'nonEmpty' "

	self explicitRequirement.! !

!TPutTest methodsFor: 'requirements' stamp: ''!
nonEmpty

	^ self explicitRequirement! !

!TPutTest methodsFor: 'tests - puting with indexes' stamp: ''!
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).! !

!TPutTest methodsFor: 'requirements' stamp: ''!
valueArray
" return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty'  at indexes in 'indexArray' "
	| result |
	result := Array new: self indexArray size.
	1 to: result size do:
		[:i |
		result at:i put: (self aValue ).
		].
	^ result.! !

!TPutTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtWrapPut
	 
	| index |
	index := self indexArray anyOne.
	
	self nonEmpty atWrap: 0 put: self aValue.
	self assert: self nonEmpty last equals: self aValue.
	
	self nonEmpty atWrap: (self nonEmpty size + 1) put: self aValue.
	self assert: self nonEmpty first equals: self aValue.
	
	self nonEmpty atWrap: index put: self aValue.
	self assert: (self nonEmpty at: index) equals: self aValue.
	
	self nonEmpty atWrap: (self nonEmpty size + index) put: self aValue .
	self assert: (self nonEmpty at: index) equals: self aValue.! !

!TPutTest methodsFor: 'tests - puting with indexes' stamp: ''!
testFromToPut
	
	| collection index |
	index := self indexArray anyOne.
	collection := self nonEmpty copy.
	collection from: 1 to: index  put: self aValue..
	1 to: index do:
		[:i | self assert: (collection at: i)= self aValue].
	(index +1) to: collection size do:
		[:i | self assert: (collection at:i)= (self nonEmpty at:i)].! !

!TPutTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllIndexesPut
	
	self nonEmpty atAllPut: self aValue.
	self nonEmpty do:[ :each| self assert: each = self aValue].! !

!TPutTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllPutAll

	| aValueArray |
	aValueArray := self valueArray .
	self nonEmpty atAll: self indexArray putAll: aValueArray  .
	
	self indexArray withIndexDo: [:element :index |
		self assert: (self nonEmpty at: element) equals: (aValueArray  at: index) ]! !

!TPutTest methodsFor: 'tests - fixture' stamp: ''!
test0FixturePutOneOrMoreElementsTest
	self aValue.


	self indexArray.
	self indexArray
		do: [ :each | 
			self assert: each class = SmallInteger.
			self assert: (each >= 1 & each) <= self nonEmpty size ].

	self assert: self indexArray size = self valueArray size.

	self empty.
	self assertEmpty: self empty.

	self nonEmpty.
	self denyEmpty: self nonEmpty! !

!TPutTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtAllPut
 
	self nonEmpty atAll: self indexArray put: self aValue.
	
	self indexArray do:
		[:i | self assert: (self nonEmpty at: i) equals: self aValue ]! !

!TPutTest methodsFor: 'tests - puting with indexes' stamp: ''!
testAtLastPut

	| index |
	index := self indexArray anyOne.	
	self nonEmpty atLast: index put: self aValue.	

	self assert: (self nonEmpty at: (self nonEmpty size + 1 - index)) equals: self aValue! !

!TPutTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TPutTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TPutTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TPutTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TPutTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TPutTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TPutTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TPutTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TPutTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TPutTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TPutTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TPutTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TPutTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TPutTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TPutTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TPutTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TPutTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TPutTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TPutTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TPutTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TPutTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TPutTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TPutTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TPutTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TPutTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TPutTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TRBProgramNodeVisitor commentStamp: ''!
A TRBProgramNodeVisitor is a simple Trait that define visitor methods. !
!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitArgumentNodes: aNodeCollection 
	"Sent *once* when visiting method and block nodes"
	^aNodeCollection do: [ :each | self visitArgumentNode: each ]! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitTemporaryNodes: aNodeCollection
	"This is triggered when defining the temporaries between the pipes"

	^ aNodeCollection
		do: [ :each | self visitTemporaryDeclarationNode: each ]! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralValueNode: aNode
	"Redirect the message by default to #visitLiteralNode: for retrocompatibility (pharo 8)"

	^ self visitLiteralNode: aNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode 
	self 
		visitArgumentNodes: aBlockNode arguments;
		visitNode: aBlockNode body! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitSequenceNode: aSequenceNode 
	self visitTemporaryNodes: aSequenceNode temporaries.
	aSequenceNode statements do: [:each | self visitNode: each]! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitArgumentVariableNode: anArgumentNode

	^ self visitLocalVariableNode: anArgumentNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitTemporaryVariableNode: aNode
	
	^ self visitLocalVariableNode: aNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitGlobalNode: aSelfNode
	^ self visitVariableNode: aSelfNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitReturnNode: aReturnNode 
	^ self visitNode: aReturnNode value! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitClassVariableNode: aNode
	^ self visitLiteralVariableNode: aNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: anAssignmentNode

	self 
		visitNode: anAssignmentNode variable;
		visitNode: anAssignmentNode value! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitCascadeNode: aCascadeNode 
	aCascadeNode messages do: [:aMessage | self visitNode: aMessage]! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralVariableNode: aNode
	"to be backward compatible, we visit for Gloabls here (there used to be no difference)"

	^ self visitGlobalNode: aNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitMethodNode: aMethodNode 
	self visitArgumentNodes: aMethodNode arguments.
	aMethodNode pragmas
		do: [:each | self visitNode: each ].
	self visitNode: aMethodNode body! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralNode: aLiteralNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitNode: aNode 
	^aNode acceptVisitor: self! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitUnreachableStatement: anUnreachableStatement
	
	^ self visitEnglobingErrorNode: anUnreachableStatement! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitLocalVariableNode: aNode
	"call visitTemporaryNode: for backward compatibility"
	^ self visitTemporaryNode: aNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitPragmaNode: aPragmaNode
	aPragmaNode arguments do: [ :each | self visitNode: each ]! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitThisContextNode: aThisContextNode
	^ self visitVariableNode: aThisContextNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitParseErrorNode: anErrorNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitPatternWrapperBlockNode: aRBPatternWrapperBlockNode 
	self 
		visitNode: aRBPatternWrapperBlockNode wrappedNode;
		visitArgumentNodes: aRBPatternWrapperBlockNode arguments;
		visitNode: aRBPatternWrapperBlockNode body! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitPatternBlockNode: aRBPatternBlockNode 
	self 
		visitArgumentNodes: aRBPatternBlockNode arguments;
		visitNode: aRBPatternBlockNode body! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitTemporaryNode: aNode 
	"Sent *each time* a temporary node is found"
	^ self visitVariableNode: aNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitGlobalVariableNode: aNode

	^ self visitLiteralVariableNode: aNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitEnglobingErrorNode: anEnglobingErrorNode
	anEnglobingErrorNode content do: [ :each | self visitNode: each ]! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitTemporaryDeclarationNode: aTemporaryDeclarationNode
	"| temp |
	temp is a temporary node as we can find in the body of methods, but it can't be visited the same way.
	IT redirects the message on argumentNodeVisitor as a way to keep retrocompatibility"

	^ self visitArgumentNode: aTemporaryDeclarationNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aRBLiteralArrayNode 
	aRBLiteralArrayNode contents do: [:each | self visitNode: each]! !

!TRBProgramNodeVisitor methodsFor: 'visiting - reflectivity' stamp: ''!
visitStorePopIntoTempNode: aNode
	^ aNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitArgumentNode: anArgumentNode
	"Sent *each time* an argument node is found"
	^ self visitVariableNode: anArgumentNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting - reflectivity' stamp: ''!
visitStoreIntoTempNode: aNode
	^ aNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitSuperNode: aSuperNode
	^ self visitVariableNode: aSuperNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitArrayNode: anArrayNode 

	anArrayNode children do: [:each | self visitNode: each]! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitSelfNode: aSelfNode
	^ self visitVariableNode: aSelfNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitMessageNode: aMessageNode 
	(aMessageNode isCascaded not or: [aMessageNode isFirstCascaded]) 
		ifTrue: [self visitNode: aMessageNode receiver].
	aMessageNode arguments do: [:each | self visitNode: each]! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitVariableNode: aVariableNode
	^ aVariableNode! !

!TRBProgramNodeVisitor methodsFor: 'visiting' stamp: ''!
visitInstanceVariableNode: aSelfNode
	^ self visitVariableNode: aSelfNode! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TRBProgramNodeVisitor classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TRBProgramNodeVisitor classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TRBProgramNodeVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TRBProgramNodeVisitor classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TRBProgramNodeVisitor classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TRBProgramNodeVisitor classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TRBProgramNodeVisitor classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TRBProgramNodeVisitor classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TRBProgramNodeVisitor classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TRBProgramNodeVisitor classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TRBProgramNodeVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TRBProgramNodeVisitor classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TRBProgramNodeVisitor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TRBProgramNodeVisitor classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TRBProgramNodeVisitor classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testHasMethods
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self deny: newBehavior hasMethods.
	1 to: 10 do: [ :i | 
		| m |
		m := RGMethod
			named: 'method' , i asString
			parent: newBehavior.
		newBehavior addLocalMethod: m ].
	self assert: newBehavior hasMethods.	
	newBehavior cleanLocalMethods.
	self deny: newBehavior hasMethods.
! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testProtocols

	| newBehavior |
	newBehavior := self behaviorClass unnamed.
	
	self assert: newBehavior asYetUnclassifiedProtocolName isSymbol.

	! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testBehavior
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self deny: (newBehavior includesSelector: #method).
	method := RGMethod named: #method parent: newBehavior.
	newBehavior addLocalMethod: method.
	self deny: method isBehavior.
	self assert: (newBehavior includesSelector: #method).
	self assert: (newBehavior allInstVarNames isEmpty).
	self assert: (newBehavior allSlots isEmpty).
	self assert: (newBehavior bindingOf: #someVariable) isNil.
	self assert: (newBehavior classVariablesBindings isEmpty).
	
	self deny: (newBehavior isRingFullyUnresolved).

	self deny: newBehavior hasTraitComposition.	
	
! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testIsBehavior

	| newBehavior |
	newBehavior := self behaviorClass unnamed.
	
	self assert: newBehavior isBehavior

	! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testMakeReslolvedResolvesEverything

	| behavior |

	behavior := self behaviorClass unnamed.
	behavior makeResolved.
	self assert: behavior unresolvedProperties isEmpty.! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testBehaviorWithCategorizedMethods
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior ask methods isEmpty.
	self assert: newBehavior ask protocols isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	newBehavior addLocalMethod: method.
	self assert: (newBehavior hasResolved: #tagsForMethods).
! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testBehaviorWithProtocols
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods tagsForMethods)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior methods isEmpty.
	1 to: 10 do: [ :i | 
		newBehavior addProtocol: ('protocol' , i asString) asSymbol ].
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: (newBehavior protocols allSatisfy: #isSymbol).
	self assert: newBehavior protocols size equals: 10.
	(newBehavior protocols first: 4)
		do: [ :each | newBehavior removeProtocol: each ].
	self assert: newBehavior protocols size equals: 6.
	newBehavior cleanProtocols.
	self assert: newBehavior protocols isEmpty! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testNewBehavior
	| newBehavior newSuperclass |
	newBehavior := self behaviorClass unnamed.
	self assert: newBehavior isRingResolved.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	newBehavior name: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self assert: (newBehavior hasResolvedName).
	self deny: (newBehavior hasUnresolved: #name).
	newBehavior isTrait
		ifFalse: [ self assert: newBehavior superclass isRingResolved not ].
	"	self assert: (newBehavior superclass environment == newBehavior environment).
"
	newSuperclass := RGClass
		named: #MySuperclass
		parent: newBehavior environment.
	self assert: newSuperclass environment == newBehavior environment.
	self
		assert: (newSuperclass hasUnresolvedAll: #(superclass localMethods protocols))! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testBehaviorWithUnategorizedMethod
	| newBehavior method |
	
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait ifFalse: [  
		self assert: (newBehavior hasUnresolved: #superclass).].
	self assert: (newBehavior methods isEmpty).
	self assert: (newBehavior protocols isEmpty).

	method := RGMethod named: #someMethod parent: newBehavior. 
	newBehavior addLocalMethod: method.
	
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanProtocols.

	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	
	newBehavior cleanLocalMethods.
	self assert: (newBehavior protocols isEmpty).
	
! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testBehaviorWithUnategorizedMethods
	| newBehavior method1 method2 |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods tagsForMethods)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior methods isEmpty.
	self assert: newBehavior protocols isEmpty.
	method1 := RGMethod named: #method1 parent: newBehavior.
	method2 := RGMethod named: #method2 parent: newBehavior.
	newBehavior addLocalMethod: method1.
	newBehavior addLocalMethod: method2.
	self assert: (newBehavior hasResolved: #tagsForMethods).
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanProtocols.
	self assert: newBehavior protocols size equals: 1.
	self assert: newBehavior protocols first equals: 'as yet unclassified'.
	newBehavior cleanLocalMethods.
	self assert: newBehavior protocols isEmpty! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testBehaviorWithOneMethod
	| newBehavior method |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior localMethods isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	self assert: method environment == newBehavior environment.
	self assert: newBehavior localMethods isEmpty.	"we do not add the method to the behavior"
	newBehavior := self behaviorClass named: #SomeClass.
	newBehavior cleanLocalMethods.
	self assert: (newBehavior hasResolved: #localMethods).
	self assert: newBehavior localMethods isEmpty.
	method := RGMethod named: #someMethod parent: newBehavior.
	newBehavior addLocalMethod: method.
	self assert: method environment == newBehavior environment.
	self assert: (newBehavior hasResolved: #localMethods).
	self assert: newBehavior localMethods anyOne name equals: #someMethod.
	newBehavior removeLocalMethod: method.
	self assert: newBehavior localMethods isEmpty.
	self assert: (newBehavior hasResolved: #localMethods)! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testCopyForBehaviorDefinition
	
	| env aClass copy |
	
	env := RGEnvironment new.
	aClass := env ensureClassNamed: #SomeClass.
	aClass superclass: (env ensureClassNamed: #SomeSuperclass).
	aClass tagWith: #tag1.
	aClass tagWith: #tag2.
		
	copy := aClass copyForBehaviorDefinition.
	
	self deny: copy == aClass. 
	self deny: copy superclass == aClass superclass. 
	self assert: copy superclass name equals: #SomeSuperclass.
	self assert: copy tags sorted equals: #(tag1 tag2).! !

!TRGBehaviorTest methodsFor: 'tests' stamp: ''!
testBehaviorWithMethods
	| newBehavior |
	newBehavior := self behaviorClass named: #SomeClass.
	self assert: newBehavior name equals: #SomeClass.
	self
		assert: (newBehavior hasUnresolvedAll: #(localMethods protocols)).
	newBehavior isTrait
		ifFalse: [ self assert: (newBehavior hasUnresolved: #superclass) ].
	self assert: newBehavior localMethods isEmpty.
	1 to: 10 do: [ :i | 
		| m |
		m := RGMethod
			named: 'method' , i asString
			parent: newBehavior.
		newBehavior addLocalMethod: m ].
	self assert: (newBehavior hasResolved: #localMethods).
	self
		assert:
			(newBehavior localMethods
				allSatisfy: [ :each | each environment = newBehavior environment ]).
	self assert: newBehavior localMethods size equals: 10.
	(newBehavior localMethods first: 4)
		do: [ :each | newBehavior removeLocalMethod: each ].
	self assert: newBehavior localMethods size equals: 6.
	newBehavior cleanLocalMethods.
	self assert: newBehavior localMethods isEmpty! !

!TRGBehaviorTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TRGBehaviorTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TRGBehaviorTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TRGBehaviorTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TRGBehaviorTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TRGBehaviorTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TRGBehaviorTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TRGBehaviorTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TRGBehaviorTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRGBehaviorTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TRGBehaviorTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TRGBehaviorTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TRGBehaviorTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TRGBehaviorTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TRGBehaviorTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TRGBehaviorTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TRGBehaviorTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TRGBehaviorTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRGBehaviorTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TRGBehaviorTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TRGBehaviorTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TRGBehaviorTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TRGBehaviorTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TRGBehaviorTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TRGBehaviorTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TRGBehaviorTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TRGClassDescriptionTest methodsFor: 'tests' stamp: ''!
testTypes

	| newBehavior |
	newBehavior := self behaviorClass unnamed.
	
	self deny: newBehavior isBytes.
	self deny: newBehavior isCompiledMethod.
	self deny: newBehavior isEphemeron.
	self deny: newBehavior isWeak.
	self deny: newBehavior isWords.

	! !

!TRGClassDescriptionTest methodsFor: 'tests' stamp: ''!
testCopyForBehaviorDefinitionForClassDescription
	
	| env aClass copy |
	
	env := RGEnvironment new.
	aClass := env ensureClassNamed: #SomeClass.
	aClass layout: (RGByteLayout parent: aClass).
		
	copy := aClass copyForBehaviorDefinition.
	
	self deny: copy == aClass. 
	self deny: copy layout == aClass layout. 
	self assert: copy layout isByteLayout.
	self assert: (copy layout parent == copy).! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TRGClassDescriptionTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TRGClassDescriptionTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TRGClassDescriptionTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TRGClassDescriptionTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TRGClassDescriptionTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TRGClassDescriptionTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRGClassDescriptionTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TRGClassDescriptionTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TRGClassDescriptionTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TRGClassDescriptionTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRGClassDescriptionTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TRGClassDescriptionTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TRGClassDescriptionTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TRGClassDescriptionTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TRGClassDescriptionTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TRGClassDescriptionTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TRGReadOnlyTest methodsFor: 'tests' stamp: ''!
testReadOnlyErrors

	| selectors backend |
	
	selectors := #(#addAlias:to: #addBehavior:to: #addClassTag:to: #addClassVariable:to: #addDefinedBehavior:to: #addExclusion:to: #addExtensionMethod:to: #addGlobalVariable:to: #addInstanceVariable:to: #addLocalMethod:to: #addMethodTag:to: #addPackage:to: #addSharedPool:to: #addSlot:to: #addTransformation:to: #cleanAliasesFor: #cleanBehaviorsFor: #cleanClassTagsFor: #cleanClassVariablesFor: #cleanDefinedBehaviorsFor: #cleanExclusionsFor: #cleanExtensionMethodsFor: #cleanGlobalVariablesFor: #cleanInstanceVariablesFor: #cleanLocalMethodsFor: #cleanMethodTagsFor: #cleanPackagesFor: #cleanSharedPoolsFor: #cleanSlotsFor: #cleanTagsForClassesFor: #cleanTagsForMethodsFor: #cleanTransformationsFor: #createNewUnresolvedClass #createNewUnresolvedMetaclassFor: #createNewUnresolvedMetaclassMetaclassFor: #readOnlyError #removeAlias:from: #removeBehavior:from: #removeClassTag:from: #removeClassVariable:from: #removeDefinedBehavior:from: #removeExclusion:from: #removeExtensionMethod:from: #removeGlobalVariable:from: #removeInstanceVariable:from: #removeLocalMethod:from: #removeMethodTag:from: #removePackage:from: #removeSharedPool:from: #removeSlot:from: #removeTransformation:from: #setBaseClassFor:to: #setClassCommentAuthorFor:to: #setClassCommentContentFor:to: #setClassCommentTimeFor:to: #setClassTraitFor:to: #setCommentFor:to: #setExpressionFor:to: #setLayoutFor:to: #setMetaClassFor:to: #setMethodPackageFor:to: #setNameFor:to: #setPackageFor:to: #setProtocolFor:to: #setSourceCodeFor:to: #setSubjectFor:to: #setSuperclassFor:to: #setTraitCommentFor:to: #setTraitPackageFor:to: #tagClass:with: #tagMethod:with: #untagClass:from: #untagMethod:from: cleanProtocolsFor: removeProtocol:from: addProtocol:to:).
	
	backend := self backendClass new.
	
	selectors do: [:selector |
		self should: [backend perform: selector withEnoughArguments: #() ] raise: Error]
! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TRGReadOnlyTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TRGReadOnlyTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TRGReadOnlyTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TRGReadOnlyTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TRGReadOnlyTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TRGReadOnlyTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRGReadOnlyTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TRGReadOnlyTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TRGReadOnlyTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TRGReadOnlyTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRGReadOnlyTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TRGReadOnlyTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TRGReadOnlyTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TRGReadOnlyTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TRGReadOnlyTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TRGReadOnlyTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TRefactoringCommandSupport methodsFor: 'initialization' stamp: ''!
initializeDefaultOptionsOf: refactoring

	NautilusRefactoring new refactoringOptions: refactoring! !

!TRefactoringCommandSupport methodsFor: 'initialization' stamp: ''!
setUpModelFromContext: aContext
	| browser scope |
	browser := aContext browser.
	scope := browser defaultNavigationScope.
	scope isCurrentImage ifTrue: [ scope := RefactoringSettings scopeRefactoring ].
	model := RBClassModelFactory rbNamespace onEnvironment: scope asRBEnvironment! !

!TRefactoringCommandSupport methodsFor: 'actions' stamp: ''!
computeInvalidArgNamesForSelector: aSymbol
	| invalidArgNames |
	invalidArgNames := Set new.
	(model allImplementorsOf: aSymbol) do: [ :e | | cm | 
		cm:=(e realClass >> aSymbol).
		invalidArgNames addAll: cm argumentNames;
			addAll: cm origin instVarNames ].
	^ invalidArgNames! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TRefactoringCommandSupport classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TRefactoringCommandSupport classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TRefactoringCommandSupport classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TRefactoringCommandSupport classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TRefactoringCommandSupport classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TRefactoringCommandSupport classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRefactoringCommandSupport classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TRefactoringCommandSupport classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TRefactoringCommandSupport classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TRefactoringCommandSupport classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRefactoringCommandSupport classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TRefactoringCommandSupport classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TRefactoringCommandSupport classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TRefactoringCommandSupport classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TRefactoringCommandSupport classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TRefactoringCommandSupport classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TRemoveByIndexTest commentStamp: ''!
A trait for test purposes!
!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveLastNotPresent

	self should: [self empty removeLast] raise: Error! !

!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveAt

	| collection element result oldSize |
	collection := self collectionWith5Elements .
	element := collection at: 3.
	oldSize := collection size.

	result := collection removeAt: 3.
	self assert: result equals: element.
	self assert: collection size equals: (oldSize - 1).! !

!TRemoveByIndexTest methodsFor: 'requirements' stamp: ''!
empty
" return an empty collection"
self explicitRequirement! !

!TRemoveByIndexTest methodsFor: 'requirements' stamp: ''!
collectionWith5Elements
" return a collection of size 5 including 5 elements"
self explicitRequirement! !

!TRemoveByIndexTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureRemoveByIndexTest

	self collectionWith5Elements.
	self assert: self collectionWith5Elements size = 5! !

!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveFirstNotPresent

	self should: [self empty removeFirst] raise: Error! !

!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveLastNElements

	| collection result oldSize elements |
	collection := self collectionWith5Elements .
	elements := { collection at: 4. collection last }.
	oldSize := collection size.

	result := (collection removeLast: 2).
	self assert: result equals: elements.
	self assert: collection size equals: (oldSize - 2)! !

!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveLast

	| collection element result oldSize |
	collection := self collectionWith5Elements .
	element := collection last.
	oldSize := collection size.

	result := collection removeLast.
	self assert: result equals: element .
	self assert: collection size equals: (oldSize - 1)! !

!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveAtNotPresent

	self should: [self empty removeAt: 2] raise: Error! !

!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveLastNElementsNElements

	self should: [self empty removeLast: 2] raise: Error! !

!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveFirstNElements

	| collection elements result oldSize |
	collection := self collectionWith5Elements .
	elements := { collection first. collection at:2 }.
	oldSize := collection size.

	result := collection removeFirst: 2.
	self assert: result equals: elements .
	self assert: collection size equals: (oldSize - 2)! !

!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveFirst

	| collection element result oldSize |
	collection := self collectionWith5Elements.
	element := collection first.
	oldSize := collection size.

	result := collection removeFirst.
	self assert: result equals: element .
	self assert: collection size equals: (oldSize - 1)! !

!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: ''!
testRemoveFirstNElementsNotPresent

	self should: [self empty removeFirst: 2] raise: Error! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TRemoveByIndexTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TRemoveByIndexTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TRemoveByIndexTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TRemoveByIndexTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TRemoveByIndexTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TRemoveByIndexTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRemoveByIndexTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TRemoveByIndexTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TRemoveByIndexTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TRemoveByIndexTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRemoveByIndexTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TRemoveByIndexTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TRemoveByIndexTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TRemoveByIndexTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TRemoveByIndexTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TRemoveByIndexTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TRemoveForMultiplenessTest commentStamp: ''!
A trait for test purposes!
!TRemoveForMultiplenessTest methodsFor: 'requirements' stamp: ''!
elementNotIn
" return an element not included in nonEmptyWithoutEqualElements"
	self explicitRequirement! !

!TRemoveForMultiplenessTest methodsFor: 'requirements' stamp: ''!
elementTwiceIn
	^ self explicitRequirement! !

!TRemoveForMultiplenessTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTRemoveTest
	| duplicate |
	self empty.
	self nonEmptyWithoutEqualElements.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	duplicate := true.
	self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ].
	self assert: duplicate = false.
	self elementNotIn.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! !

!TRemoveForMultiplenessTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementReallyRemovesElement
 
	| size |
	size := self nonEmptyWithoutEqualElements size.
	self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne.
	self assert: size - 1 = self nonEmptyWithoutEqualElements size! !

!TRemoveForMultiplenessTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExists
 
	| el res |
	el := self nonEmptyWithoutEqualElements anyOne.
	res := self nonEmptyWithoutEqualElements remove: el.
	self assert: res == el! !

!TRemoveForMultiplenessTest methodsFor: 'tests - remove' stamp: ''!
testRemoveIfAbsent
	| res |
	res := self nonEmptyWithoutEqualElements remove: self elementNotIn ifAbsent: [ 33 ].
	self assert: res equals: 33! !

!TRemoveForMultiplenessTest methodsFor: 'requirements' stamp: ''!
empty
	self explicitRequirement! !

!TRemoveForMultiplenessTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExistsTwice

	| 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! !

!TRemoveForMultiplenessTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithoutEqualElements
" return a collection without equal elements "
	self explicitRequirement! !

!TRemoveForMultiplenessTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllFoundIn
	| el aSubCollection |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn.
	self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection.
	self assert: self nonEmptyWithoutEqualElements size = 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! !

!TRemoveForMultiplenessTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllSuchThat

	| 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 ]! !

!TRemoveForMultiplenessTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllError
	| el aSubCollection |
	el := self elementNotIn.
	aSubCollection := self nonEmptyWithoutEqualElements copyWith: el.
	self should: [ self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! !

!TRemoveForMultiplenessTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAll
	| el aSubCollection collection |
	collection := self nonEmptyWithoutEqualElements.
	el := collection anyOne.
	aSubCollection := collection copyWithout: el.
	collection removeAll: aSubCollection.
	self assert: collection size = 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! !

!TRemoveForMultiplenessTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementFromEmpty
	 
	self 
		should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ]
		raise: Error! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TRemoveForMultiplenessTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TRemoveForMultiplenessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TRemoveTest commentStamp: ''!
A trait for test purposes!
!TRemoveTest methodsFor: 'requirements' stamp: ''!
elementNotIn
" return an element not included in nonEmptyWithoutEqualElements"
	self explicitRequirement! !

!TRemoveTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureTRemoveTest
	| duplicate |
	self empty.
	self nonEmptyWithoutEqualElements.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	duplicate := true.
	self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ].
	self deny: duplicate.
	self elementNotIn.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmptyWithoutEqualElements.
	self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! !

!TRemoveTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementReallyRemovesElement

	| size |
	size := self nonEmptyWithoutEqualElements size.
	self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne.
	self assert: size - 1 equals: self nonEmptyWithoutEqualElements size! !

!TRemoveTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementThatExists

	| el res |
	el := self nonEmptyWithoutEqualElements anyOne.
	res := self nonEmptyWithoutEqualElements remove: el.
	self assert: res == el! !

!TRemoveTest methodsFor: 'tests - remove' stamp: ''!
testRemoveIfAbsent
 
	| el res |
	el := self elementNotIn.
	res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ].
	self assert: res equals: 33! !

!TRemoveTest methodsFor: 'requirements' stamp: ''!
empty
	self explicitRequirement! !

!TRemoveTest methodsFor: 'requirements' stamp: ''!
nonEmptyWithoutEqualElements
" return a collection without equal elements "
	self explicitRequirement! !

!TRemoveTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllFoundIn

	| el aSubCollection   |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn.
	self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection.
	
	self assert: self nonEmptyWithoutEqualElements size equals: 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each equals: el ]! !

!TRemoveTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllSuchThat

	| el aSubCollection |
	el := self nonEmptyWithoutEqualElements anyOne.
	aSubCollection := self nonEmptyWithoutEqualElements copyWithout: el.
	self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | aSubCollection includes: each ].
	
	self assert: self nonEmptyWithoutEqualElements size equals: 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each equals: el ]! !

!TRemoveTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAllError
	| el aSubCollection |
	el := self elementNotIn.
	aSubCollection := self nonEmptyWithoutEqualElements copyWith: el.

	self should: [ self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! !

!TRemoveTest methodsFor: 'tests - remove' stamp: ''!
testRemoveAll
	| el aSubCollection collection |
	collection := self nonEmptyWithoutEqualElements.
	el := collection anyOne.
	aSubCollection := collection copyWithout: el.
	collection removeAll: aSubCollection.
	self assert: collection size = 1.
	self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! !

!TRemoveTest methodsFor: 'tests - remove' stamp: ''!
testRemoveElementFromEmpty

	self 
		should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ]
		raise: Error! !

!TRemoveTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TRemoveTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TRemoveTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TRemoveTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TRemoveTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TRemoveTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TRemoveTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TRemoveTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TRemoveTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRemoveTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TRemoveTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TRemoveTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TRemoveTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TRemoveTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TRemoveTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TRemoveTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TRemoveTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TRemoveTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRemoveTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TRemoveTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TRemoveTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TRemoveTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TRemoveTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TRemoveTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TRemoveTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TRemoveTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TReplacementSequencedTest commentStamp: ''!
A trait for test purposes!
!TReplacementSequencedTest methodsFor: 'requirements' stamp: ''!
firstIndex
	"Return an index between 'nonEmpty' bounds that is < to 'second index'"
	
	^self explicitRequirement! !

!TReplacementSequencedTest methodsFor: 'requirements' stamp: ''!
nonEmpty

	^self explicitRequirement! !

!TReplacementSequencedTest methodsFor: 'requirements' stamp: ''!
elementInForReplacement
	"Return an element included in 'nonEmpty'"

	^ self nonEmpty anyOne! !

!TReplacementSequencedTest methodsFor: 'requirements' stamp: ''!
replacementCollection
	"Return a collection that will be put into 'nonEmpty'"
	
	^ self replacementCollectionSameSize, self 	replacementCollectionSameSize! !

!TReplacementSequencedTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceFromToWith
	| result collection replacementCollec firstInd secondInd |
	collection := self nonEmpty .
	replacementCollec := self replacementCollectionSameSize.
	firstInd := self firstIndex.
	secondInd := self secondIndex.
	result := collection copy.
	result replaceFrom: firstInd to: secondInd with: replacementCollec.
	
	"Verify content of 'result'"

	"First part of 'result'"	
	1 to: (firstInd - 1) do: [:i | self assert: (collection at:i) equals: (result at: i) ].
	
	"Middle part containing replacementCollection"	
	firstInd to: (firstInd + replacementCollec size - 1) do: 
		[:i | self assert: (result at: i) equals: (replacementCollec at: (i - firstInd + 1)) ].
	
	"End part"
	(firstInd + replacementCollec size) to: (result size) do:
		[:i|
		self assert: (result at: i) equals: (collection at: (secondInd + 1 - (firstInd + replacementCollec size) + i)) ]! !

!TReplacementSequencedTest methodsFor: 'requirements' stamp: ''!
replacementCollectionSameSize
	"Return a collection of size (secondIndex - firstIndex + 1)"
	
	^self explicitRequirement! !

!TReplacementSequencedTest methodsFor: 'tests - fixture' stamp: ''!
testOFixtureReplacementSequencedTest
	self nonEmpty.
	self denyEmpty: self nonEmpty.

	self elementInForReplacement.
	self assert: (self nonEmpty includes: self elementInForReplacement).

	self newElement.

	self firstIndex.
	self assert: (self firstIndex >= 1 & self firstIndex) <= self nonEmpty size.

	self secondIndex.
	self assert: (self secondIndex >= 1 & self secondIndex) <= self nonEmpty size.

	self assert: self firstIndex <= self secondIndex.

	self replacementCollection.

	self replacementCollectionSameSize.
	self assert: self secondIndex - self firstIndex + 1 equals: self replacementCollectionSameSize size! !

!TReplacementSequencedTest methodsFor: 'requirements' stamp: ''!
newElement
	"Return an element that will be put in the collection in place of another"

	self explicitRequirement! !

!TReplacementSequencedTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceAllWith
	| result collection oldElement newElement oldOccurrences |
	collection := self nonEmpty.
	result := collection copy.
	oldElement := self elementInForReplacement.
	newElement := self newElement.
	oldOccurrences := (result occurrencesOf: oldElement) + (result occurrencesOf: newElement).
	result replaceAll: oldElement with: newElement.
	
	self assert: oldOccurrences equals: (result occurrencesOf: newElement)! !

!TReplacementSequencedTest methodsFor: 'tests - replacing' stamp: ''!
testReplaceFromToWithStartingAt
	| result repStart collection replacementCollec firstInd secondInd |
	collection := self nonEmpty.
	result := collection copy.
	replacementCollec := self replacementCollectionSameSize.
	firstInd := self firstIndex.
	secondInd := self secondIndex.
	repStart := replacementCollec size - (secondInd - firstInd + 1) + 1.
	result replaceFrom: firstInd to: secondInd with: replacementCollec startingAt: repStart.
	
	"Verify content of 'result'"
	
	"First part of 'result'" 	
	1 to: (firstInd - 1) do: [:i | self assert: (collection at:i) equals: (result at: i) ].
	
	"Middle part containing replacementCollection"	
	firstInd to: (replacementCollec size - repStart +1) do: 
		[:i| self assert: (result at: i) equals: (replacementCollec at: (repStart + (i - firstInd))) ].
	
	"End part"
	(firstInd + replacementCollec size) to: (result size) do:
		[ :i | self assert: (result at: i) equals: (collection at: (secondInd + 1 - (firstInd + replacementCollec size) + i)) ]! !

!TReplacementSequencedTest methodsFor: 'requirements' stamp: ''!
secondIndex
	"Return an index between 'nonEmpty' bounds that is > to 'first index'"
	
	^self explicitRequirement! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TReplacementSequencedTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TReplacementSequencedTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TReplacementSequencedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TReplacementSequencedTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TReplacementSequencedTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TReplacementSequencedTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TReplacementSequencedTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TReplacementSequencedTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TReplacementSequencedTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TReplacementSequencedTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TReplacementSequencedTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TReplacementSequencedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TReplacementSequencedTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TReplacementSequencedTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TReplacementSequencedTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TReplacementSequencedTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TRubWithLineNumber commentStamp: ''!
I am a Trait that can be used by subclasses of RubScrolledTextExtra wanting to display or not line numbers.!
!TRubWithLineNumber methodsFor: 'accessing' stamp: ''!
fontToUse
	^ RubAbstractTextArea lineNumbersFont ! !

!TRubWithLineNumber methodsFor: 'managing line numbers' stamp: ''!
changeLineNumbersDisplay
	self paragraphProvider lineNumbersRuler 
		ifNil: [ self paragraphProvider withLineNumbers ]
		ifNotNil: [ self paragraphProvider withoutLineNumbers ].
	self paragraphProvider manageLayout.
	self updateContents! !

!TRubWithLineNumber methodsFor: 'managing line numbers' stamp: ''!
lineNumbersDisplayLabelMorph
	^ StringMorph contents: self lineNumbersDisplayLabel font: self fontToUse! !

!TRubWithLineNumber methodsFor: 'managing line numbers' stamp: ''!
lineNumbersDisplayLabel
	^ self paragraphProvider lineNumbersRuler  
		ifNil: [ '+L' ]
		ifNotNil: [ 'L' ]! !

!TRubWithLineNumber methodsFor: 'event handling' stamp: ''!
updateContents
	self explicitRequirement! !

!TRubWithLineNumber classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TRubWithLineNumber classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TRubWithLineNumber classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TRubWithLineNumber classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TRubWithLineNumber classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TRubWithLineNumber classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TRubWithLineNumber classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TRubWithLineNumber classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TRubWithLineNumber classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRubWithLineNumber classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TRubWithLineNumber classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TRubWithLineNumber classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TRubWithLineNumber classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TRubWithLineNumber classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TRubWithLineNumber classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TRubWithLineNumber classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TRubWithLineNumber classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TRubWithLineNumber classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRubWithLineNumber classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TRubWithLineNumber classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TRubWithLineNumber classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TRubWithLineNumber classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TRubWithLineNumber classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TRubWithLineNumber classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TRubWithLineNumber classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TRubWithLineNumber classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TRubWithWrapPolicy commentStamp: ''!
I am a Trait that can be used by subclasses of RubScrolledTextExtra wanting a WrapPolicy.!
!TRubWithWrapPolicy methodsFor: 'accessing' stamp: ''!
fontToUse
	^ RubAbstractTextArea lineNumbersFont ! !

!TRubWithWrapPolicy methodsFor: 'managing wrapping policy' stamp: ''!
changeWrappingPolicy
	self paragraphProvider wrapped
		ifTrue: [ self paragraphProvider beNotWrapped ]
		ifFalse: [ self paragraphProvider beWrapped ].
	self updateContents.
	self paragraphProvider changed! !

!TRubWithWrapPolicy methodsFor: 'managing wrapping policy' stamp: ''!
wrappingPolicyLabel
	^ self paragraphProvider wrapped
		ifTrue: [ 'W' ]
		ifFalse: [ 'NW' ]! !

!TRubWithWrapPolicy methodsFor: 'event handling' stamp: ''!
updateContents
	self explicitRequirement! !

!TRubWithWrapPolicy methodsFor: 'managing wrapping policy' stamp: ''!
wrappingPolicyLabelMorph
	^ StringMorph contents: self wrappingPolicyLabel font: self fontToUse! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TRubWithWrapPolicy classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TRubWithWrapPolicy classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TRubWithWrapPolicy classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TRubWithWrapPolicy classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TRubWithWrapPolicy classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TRubWithWrapPolicy classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRubWithWrapPolicy classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TRubWithWrapPolicy classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TRubWithWrapPolicy classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TRubWithWrapPolicy classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TRubWithWrapPolicy classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TRubWithWrapPolicy classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TRubWithWrapPolicy classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TRubWithWrapPolicy classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TRubWithWrapPolicy classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TRubWithWrapPolicy classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TSequencedConcatenationTest commentStamp: ''!
A trait for test purposes!
!TSequencedConcatenationTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContents
	| result |
	result:= self collectionClass streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!TSequencedConcatenationTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenationWithEmpty
	| result |
	result:= self empty,self secondCollection .
	
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:i).
		].
	"size : "
	self assert: result size = ( self secondCollection size).! !

!TSequencedConcatenationTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedConcatenationTest
	self empty.
	self assertEmpty: self empty.
	self firstCollection.
	self secondCollection! !

!TSequencedConcatenationTest methodsFor: 'requirements' stamp: ''!
secondCollection
" return a collection that will be the second part of the concatenation"
	self explicitRequirement! !

!TSequencedConcatenationTest methodsFor: 'requirements' stamp: ''!
empty
	self explicitRequirement! !

!TSequencedConcatenationTest methodsFor: 'tests - concatenation' stamp: ''!
testConcatenation
	| result index |
	result:= self firstCollection,self secondCollection .
	"first part : "
	index := 1.
	self firstCollection do: 
		[:each | 
		self assert: (self firstCollection at: index)=each.
		index := index+1.].
	"second part : "
	1 to: self secondCollection size do:
		[:i | 
		self assert: (self secondCollection at:i)= (result at:index).
		index:=index+1].
	"size : "
	self assert: result size = (self firstCollection size + self secondCollection size).! !

!TSequencedConcatenationTest methodsFor: 'tests - streaming' stamp: ''!
testNewStreamContentsReturnsCollectionOfCorrectSize
	| result item originalSize |
	originalSize := 10.
	item := self firstCollection first.
	result := self collectionClass
		new: originalSize
		streamContents: [ :stream | 
			1 to: originalSize + 1 do: [ :each | stream nextPut: item ].
			stream position: originalSize ].
	self assert: result size equals: originalSize! !

!TSequencedConcatenationTest methodsFor: 'tests - streaming' stamp: ''!
testStreamContentsSized
	| result |
	result:= self collectionClass new: 1 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.
	
	result:= self collectionClass new: 1000 streamContents: [ :s|
		s 
			nextPutAll: self firstCollection;
			nextPutAll: self secondCollection ].
	self assert: result equals: self firstCollection, self secondCollection.! !

!TSequencedConcatenationTest methodsFor: 'requirements' stamp: ''!
firstCollection
" return a collection that will be the first part of the concatenation"
	self explicitRequirement! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TSequencedConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TSequencedConcatenationTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TSequencedConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TSequencedConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TSequencedConcatenationTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TSequencedConcatenationTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSequencedConcatenationTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TSequencedConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TSequencedConcatenationTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TSequencedConcatenationTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSequencedConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TSequencedConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TSequencedConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TSequencedConcatenationTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TSequencedConcatenationTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TSequencedConcatenationTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TSequencedElementAccessTest commentStamp: ''!
A trait for test purposes!
!TSequencedElementAccessTest methodsFor: 'requirements' stamp: ''!
subCollectionNotIn
" return a collection for which at least one element is not included in 'moreThan4Elements' "
	self explicitRequirement! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!TSequencedElementAccessTest methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSequencedElementAccessTest

	self moreThan4Elements.
	self assert: self moreThan4Elements size >= 4.
	self subCollectionNotIn.
	self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ].
	self elementNotInForElementAccessing.
	self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing).
	self elementInForElementAccessing.
	self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastIfAbsent

	self assert: (self moreThan4Elements 
			atLast: 1
			ifAbsent: [ nil ]) = self moreThan4Elements last.
	self assert: (self moreThan4Elements 
			atLast: self moreThan4Elements size + 1
			ifAbsent: [ 222 ]) = 222! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLast

	| index |
	self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last.

	index := self moreThan4Elements indexOf: self elementInForElementAccessing.
	self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testBeforeIfAbsent

	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)! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testAtOutOfBounds

	self 
		should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ]
		raise: Error.
	self 
		should: [ self moreThan4Elements at: -1 ]
		raise: Error! !

!TSequencedElementAccessTest methodsFor: 'requirements' stamp: ''!
elementInForElementAccessing
" return an element inculded in 'moreThan4Elements'"
	self explicitRequirement! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testAtRandom

	| result |
	result := self nonEmpty atRandom.
	self assert: (self nonEmpty includes: result)! !

!TSequencedElementAccessTest methodsFor: 'requirements' stamp: ''!
elementNotInForElementAccessing
" return an element not included in 'moreThan4Elements' "
	self explicitRequirement! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testAtLastError

	self 
		should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ]
		raise: Error! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testFirstSecondThird

	self assert: self moreThan4Elements first equals: (self moreThan4Elements at: 1).
	self assert: self moreThan4Elements second equals: (self moreThan4Elements at: 2).
	self assert: self moreThan4Elements third equals: (self moreThan4Elements at: 3).
	self assert: self moreThan4Elements fourth equals: (self moreThan4Elements at: 4)! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testLast

	self assert: self moreThan4Elements last equals: (self moreThan4Elements at: self moreThan4Elements size)! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testAtIfAbsent

	| 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! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testAtWrap
	"
	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)! !

!TSequencedElementAccessTest methodsFor: 'requirements' stamp: ''!
moreThan4Elements

" return a collection including at leat 4 elements"
	self explicitRequirement! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
testMiddle

	self assert: self moreThan4Elements middle equals: (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! !

!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: ''!
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! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TSequencedElementAccessTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TSequencedElementAccessTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TSequencedElementAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TSequencedElementAccessTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TSequencedElementAccessTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TSequencedElementAccessTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSequencedElementAccessTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TSequencedElementAccessTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TSequencedElementAccessTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TSequencedElementAccessTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSequencedElementAccessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TSequencedElementAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TSequencedElementAccessTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TSequencedElementAccessTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TSequencedElementAccessTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TSequencedElementAccessTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TSequencedStructuralEqualityTest commentStamp: ''!
A trait for test purposes!
!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignForSequenceableCollections

	self deny: (self nonEmpty = self nonEmpty asSet). 
	self deny: (self nonEmpty reversed = self nonEmpty).
	self deny: (self nonEmpty = self nonEmpty reversed)! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForEmptyButNonIdenticalCollections
	
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
empty
	
	^ self explicitRequirement! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
nonEmpty
	
	^ self explicitRequirement! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - fixture' stamp: ''!
test0TSequencedStructuralEqualityTest

	self nonEmpty at: 1	"Ensures #nonEmpty is sequenceable"! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
testHasEqualElementsOfIdenticalCollectionObjects
	
	self assert: (self empty hasEqualElements: self empty). 
	self assert: (self nonEmpty hasEqualElements: self nonEmpty)! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
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)! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
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)! !

!TSequencedStructuralEqualityTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TSequencedStructuralEqualityTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TSequencedStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TSetArithmetic commentStamp: ''!
A trait for test purposes!
!TSetArithmetic methodsFor: 'requirements' stamp: ''!
collection

	^ self explicitRequirement! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionBasic
	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self denyEmpty: inter.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithSeparateCollection
	"Answer the set theoretic difference of two collections."

	| res separateCol |	
	separateCol := self collectionClass with: self anotherElementOrAssociationNotIn.
	res := self collectionWithoutEqualElements difference: separateCol.
	
	self deny: (res includes: self anotherElementOrAssociationNotIn).
	self assert: res size equals: self collectionWithoutEqualElements size.
	
	self collectionWithoutEqualElements do: [ :each|
		self assert: (res includes: each)].
	
	res := separateCol difference: self collection.
	self deny: (res includes: self collection anyOne).
	self assert: res equals: separateCol! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionItself
	
	| result |
	result := self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements.
	self assert: result size equals: self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each|
		self assert: (result includes: each) ].! !

!TSetArithmetic methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationIn
	" return an element (or an association for Dictionary ) present  in 'collection' "
	^ self explicitRequirement! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
testDifferenceWithNonNullIntersection
	"Answer the set theoretic difference of two collections. 
	 	#(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) ]! !

!TSetArithmetic methodsFor: 'requirements' stamp: ''!
nonEmpty

	^ self explicitRequirement! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
numberOfSimilarElementsInIntersection

	^ self collection occurrencesOf: self anotherElementOrAssociationIn! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
testDifference
	"Answer the set theoretic difference of two collections."

	| difference |
	self assertEmpty: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements).
	self assertEmpty: (self empty difference: self collectionWithoutEqualElements).
	difference := self collectionWithoutEqualElements difference: self empty.
	self assert: difference size = self collectionWithoutEqualElements size.
	self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each) ]! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionEmpty
	| inter |
	inter := self empty intersection: self empty.
	self assertEmpty: inter.
	inter := self empty intersection: self collection.
	self assert: inter equals: self empty! !

!TSetArithmetic methodsFor: 'requirements' stamp: ''!
collectionClass
	"Return the class to be used to create instances of the class tested"
	
	^ self explicitRequirement! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
testIntersectionTwoSimilarElementsInIntersection

	| inter |
	inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn).
	self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) equals: self numberOfSimilarElementsInIntersection.
	self assert: (inter includes: self anotherElementOrAssociationIn value)! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
testUnionOfEmpties
	self assertEmpty: (self empty union: self empty)! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
testUnion
	
	| 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.! !

!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: ''!
containsAll: union of: one andOf: another
			
	self assert: (one allSatisfy: [:each | union includes: each]).
	self assert: (another allSatisfy: [:each | union includes: each])! !

!TSetArithmetic methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSetAritmeticTest
	self collection.
	self denyEmpty: self collection.
	self nonEmpty.
	self denyEmpty: self nonEmpty.
	self anotherElementOrAssociationNotIn.
	self collection isDictionary
		ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ]
		ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ].
	self collectionClass! !

!TSetArithmetic methodsFor: 'requirements' stamp: ''!
anotherElementOrAssociationNotIn
	" return an element (or an association for Dictionary )not present  in 'collection' "
	^ self explicitRequirement! !

!TSetArithmetic classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TSetArithmetic classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TSetArithmetic classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TSetArithmetic classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TSetArithmetic classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TSetArithmetic classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TSetArithmetic classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TSetArithmetic classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TSetArithmetic classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSetArithmetic classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TSetArithmetic classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TSetArithmetic classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TSetArithmetic classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TSetArithmetic classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TSetArithmetic classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TSetArithmetic classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TSetArithmetic classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TSetArithmetic classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSetArithmetic classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TSetArithmetic classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TSetArithmetic classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TSetArithmetic classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TSetArithmetic classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TSetArithmetic classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TSetArithmetic classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TSetArithmetic classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TSetUpRefactorings commentStamp: ''!
A trait to setUp refactorings for tests purposes!
!TSetUpRefactorings methodsFor: 'set up' stamp: ''!
setupMethodNameFor: aRefactoring toReturn: aSelector 
	| options |
	options := aRefactoring options copy.
	options at: #methodName
		put: 
			[:aMethodName :ref | 
			aMethodName
				selector: aSelector;
				yourself].
	aRefactoring options: options! !

!TSetUpRefactorings methodsFor: 'set up' stamp: ''!
setupExtractionClassFor: aRefactoring toReturn: aClass 
	| options |
	options := aRefactoring options copy.
	options at: #extractionClass
		put: [:ref | aClass].
	aRefactoring options: options! !

!TSetUpRefactorings methodsFor: 'set up' stamp: ''!
setupSearchInAllHierarchyFor: aRefactoring toReturn: aBoolean 
	| options |
	options := aRefactoring options copy.
	options at: #searchInWholeHierarchy put: [ :ref :cls | aBoolean ].
	aRefactoring options: options! !

!TSetUpRefactorings methodsFor: 'set up' stamp: ''!
setupImplementorToInlineFor: aRefactoring toReturn: anObject 
	| options |
	options := aRefactoring options copy.
	options at: #implementorToInline put: [:ref :imps | anObject].
	aRefactoring options: options! !

!TSetUpRefactorings methodsFor: 'set up' stamp: ''!
setupSelfArgumentNameFor: aRefactoring toReturn: aString 
	| options |
	options := aRefactoring options copy.
	options at: #selfArgumentName put: [:ref | aString].
	aRefactoring options: options! !

!TSetUpRefactorings methodsFor: 'set up' stamp: ''!
setupVariableToMoveToFor: aRefactoring toReturn: aString 
	| options |
	options := aRefactoring options copy.
	options at: #selectVariableToMoveTo put: [:ref :class :selector | aString].
	aRefactoring options: options! !

!TSetUpRefactorings methodsFor: 'set up' stamp: ''!
setupInlineExpressionFor: aRefactoring toReturn: aBoolean 
	| options |
	options := aRefactoring options copy.
	options at: #inlineExpression put: [:ref :string | aBoolean].
	aRefactoring options: options! !

!TSetUpRefactorings methodsFor: 'set up' stamp: ''!
setupShouldUseExistingMethodFor: aRefactoring toReturn: aBoolean 
	| options |
	options := aRefactoring options copy.
	options at: #useExistingMethod put: [ :ref :cls | aBoolean ].
	aRefactoring options: options! !

!TSetUpRefactorings methodsFor: 'set up' stamp: ''!
setupVariableTypesFor: aRefactoring toReturn: anObject 
	| options |
	options := aRefactoring options copy.
	options at: #variableTypes put: [:ref :ignore1 :ignore2 | anObject].
	aRefactoring options: options! !

!TSetUpRefactorings methodsFor: 'set up' stamp: ''!
setupMethodNameFor: aRefactoring toReturn: aSelector withArguments: stringCollection 
	| options |
	options := aRefactoring options copy.
	options at: #methodName
		put: 
			[ :aMethodName :ref | 
			aMethodName
				selector: aSelector;
				arguments: stringCollection;
				yourself].
	aRefactoring options: options! !

!TSetUpRefactorings classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TSetUpRefactorings classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TSetUpRefactorings classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TSetUpRefactorings classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TSetUpRefactorings classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TSetUpRefactorings classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TSetUpRefactorings classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TSetUpRefactorings classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TSetUpRefactorings classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSetUpRefactorings classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TSetUpRefactorings classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TSetUpRefactorings classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TSetUpRefactorings classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TSetUpRefactorings classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TSetUpRefactorings classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TSetUpRefactorings classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TSetUpRefactorings classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TSetUpRefactorings classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSetUpRefactorings classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TSetUpRefactorings classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TSetUpRefactorings classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TSetUpRefactorings classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TSetUpRefactorings classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TSetUpRefactorings classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TSetUpRefactorings classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TSetUpRefactorings classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TShowInTaskbar commentStamp: ''!
TShowInTaskbar is a trait to enable any morph to be shown in the taskbar. It implements the required parts so that the taskbar can build a button showing the given morph. 

A morph implementing this trait must implement the methods located under "taskbar-required".

Adding a menu when the taskbarbutton is right clicked can be done by implemenenting  #taskbarButtonMenu: to return a custom menu.

For mouseOver action, #taskbarCanShowThumbnail must be implemented to return true, and the behaviour when the mouse enters and leaves the taskbar button in their respective methods.!
!TShowInTaskbar methodsFor: 'taskbar-private' stamp: ''!
taskbarTask

	^ TaskbarTask
		morph: self
		state: self taskbarState
		icon: self taskbarIcon
		label: self taskbarLabel! !

!TShowInTaskbar methodsFor: 'taskbar-thumbnail' stamp: ''!
taskbarButtonEntered: aButton event: evt in: aMorph
	"The mouse has entered out taskbar button.
	Show a thumbnail."! !

!TShowInTaskbar methodsFor: 'taskbar-required' stamp: ''!
taskbarLabel
	"Answer the label to use for a taskbar button for the receiver."
	
	^self explicitRequirement! !

!TShowInTaskbar methodsFor: 'taskbar-private' stamp: ''!
taskbarButtonFor: aTaskbar
	"Answer a new task bar button for the receiver.
	Answer nil if not required."
	
	| taskbarButton |
	
	taskbarButton := aTaskbar theme
		newBasicTaskbarButtonIn: aTaskbar
		for: self.
		
	self customizeTaskbarButton: taskbarButton.
	
	^ taskbarButton! !

!TShowInTaskbar methodsFor: 'taskbar-required' stamp: ''!
taskbarButtonIsActive

	"true/false"
	
	^self explicitRequirement! !

!TShowInTaskbar methodsFor: 'taskbar-public' stamp: ''!
taskbarButtonMenu: aMenu

	"default is to show no menu"
		
	^aMenu! !

!TShowInTaskbar methodsFor: 'taskbar-thumbnail' stamp: ''!
taskbarCanShowThumbnail

	^ false! !

!TShowInTaskbar methodsFor: 'taskbar-required' stamp: ''!
taskbarState
	"Answer one of #minimized, #restored, #maximized or #active."
	
	^self explicitRequirement! !

!TShowInTaskbar methodsFor: 'taskbar-private' stamp: ''!
customizeTaskbarButton: aButton

	self taskbarCanShowThumbnail ifFalse: [ ^ self ].
	
	aButton 
	
		on: #mouseEnter 
		send: #taskbarButtonEntered:event:in: 
		to: self 
		withValue: aButton;
		
		on: #mouseLeave 
		send: #taskbarButtonLeft:event:in: 
		to: self  
		withValue: aButton.! !

!TShowInTaskbar methodsFor: 'taskbar-public' stamp: ''!
taskbarButtonClicked

	"Do something"! !

!TShowInTaskbar methodsFor: 'taskbar-thumbnail' stamp: ''!
taskbarButtonLeft: aButton event: evt in: aMorph
	"The mouse has left our taskbar button.
	Remove our thumbnail."! !

!TShowInTaskbar classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TShowInTaskbar classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TShowInTaskbar classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TShowInTaskbar classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TShowInTaskbar classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TShowInTaskbar classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TShowInTaskbar classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TShowInTaskbar classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TShowInTaskbar classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TShowInTaskbar classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TShowInTaskbar classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TShowInTaskbar classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TShowInTaskbar classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TShowInTaskbar classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TShowInTaskbar classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TShowInTaskbar classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TShowInTaskbar classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TShowInTaskbar classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TShowInTaskbar classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TShowInTaskbar classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TShowInTaskbar classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TShowInTaskbar classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TShowInTaskbar classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TShowInTaskbar classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TShowInTaskbar classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TShowInTaskbar classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TSizeTest commentStamp: ''!
A trait for test purposes!
!TSizeTest methodsFor: 'requirements' stamp: ''!
empty

	^ self explicitRequirement! !

!TSizeTest methodsFor: 'tests - size capacity' stamp: ''!
testSize

	| size |
	self assert: self empty size = 0.
	size := 0.
	self sizeCollection do: [ :each | size := size + 1].
	
	self assert: self sizeCollection size = size.! !

!TSizeTest methodsFor: 'tests - fixture' stamp: ''!
test0TSizeTest
	self empty.
	self sizeCollection.
	self assertEmpty: self empty.
	self denyEmpty: self sizeCollection! !

!TSizeTest methodsFor: 'requirements' stamp: ''!
sizeCollection
	"Answers a collection not empty"
	^ self explicitRequirement! !

!TSizeTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TSizeTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TSizeTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TSizeTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TSizeTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TSizeTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TSizeTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TSizeTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TSizeTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSizeTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TSizeTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TSizeTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TSizeTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TSizeTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TSizeTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TSizeTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TSizeTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TSizeTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSizeTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TSizeTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TSizeTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TSizeTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TSizeTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TSizeTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TSizeTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TSizeTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TSortTest commentStamp: ''!
A trait for test purposes!
!TSortTest methodsFor: 'tests' stamp: ''!
testSorted
	| result tmp unsorted |
	unsorted := self unsortedCollection.
	result := unsorted sorted.
	self deny: unsorted == result.
	tmp := result at: 1.
	result
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!TSortTest methodsFor: 'requirements' stamp: ''!
unsortedCollection
"Return a collection that is not yet sorted"
	^self explicitRequirement! !

!TSortTest methodsFor: 'tests - sorting' stamp: ''!
testIsSortedBy
	self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]).
	self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]).! !

!TSortTest methodsFor: 'tests - sorting' stamp: ''!
testIsSorted
	self assert: self sortedInAscendingOrderCollection isSorted.
	self deny: self unsortedCollection isSorted! !

!TSortTest methodsFor: 'tests - fixture' stamp: ''!
test0SortingArrayedTest
	| tmp sorted |
	" an unsorted collection of number "
	self unsortedCollection.
	self unsortedCollection do: [ :each | each isNumber ].
	sorted := true.
	self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ].
	self deny: sorted.	" a collection of number sorted in an ascending order"
	self sortedInAscendingOrderCollection.
	self sortedInAscendingOrderCollection do: [ :each | each isNumber ].
	tmp := self sortedInAscendingOrderCollection at: 1.
	self sortedInAscendingOrderCollection
		do: [ :each | 
			self assert: each >= tmp.
			tmp := each ]! !

!TSortTest methodsFor: 'requirements' stamp: ''!
sortedInAscendingOrderCollection
	"Return a collection sorted in ascending order"
	^ self explicitRequirement! !

!TSortTest methodsFor: 'tests - sorting' stamp: ''!
testSortedUsingBlock
	| result tmp |
	result := self unsortedCollection sorted:  [:a :b | a>b]..
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!TSortTest methodsFor: 'tests - sorting' stamp: ''!
testSort
	| result tmp |
	result := self unsortedCollection sort.
	tmp := result at: 1.
	result do:
		[:each | self assert: each>=tmp. tmp:= each. ].! !

!TSortTest methodsFor: 'tests - sorting' stamp: ''!
testSortUsingSortBlock
	| result tmp |
	result := self unsortedCollection sort: [:a :b | a>b].
	tmp := result at: 1.
	result do:
		[:each | self assert: each<=tmp. tmp:= each. ].! !

!TSortTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TSortTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TSortTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TSortTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TSortTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TSortTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TSortTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TSortTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TSortTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSortTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TSortTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TSortTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TSortTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TSortTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TSortTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TSortTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TSortTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TSortTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSortTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TSortTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TSortTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TSortTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TSortTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TSortTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TSortTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TSortTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TSortable commentStamp: ''!
I represent a set of methods related to element sorting. 

My public api is composed of the messages:
        #sort, #isSorted, #isSortedBy:, and #sort: 

To get the behavior I define, my users should implement:
	#isEmpty, #size, #first, and #at: !
!TSortable methodsFor: 'sorting' stamp: ''!
sorted: aSortBlockOrNil
	"Return a new sequenceable collection which contains the same elements as self but its 
elements are sorted by aSortBlockOrNil. The block should take two arguments and return true if 
the first element should preceed the second one. If aSortBlock is nil then <= is used for 
comparison."
	
	^self copy sort: aSortBlockOrNil! !

!TSortable methodsFor: 'sorting' stamp: ''!
mergeFirst: first middle: middle last: last into: dst by: aBlock
	"Private. Merge the sorted ranges [first..middle] and [middle+1..last] 
	of the receiver into the range [first..last] of dst."

	| i1 i2 val1 val2 out |
	i1 := first.
	i2 := middle + 1.
	val1 := self at: i1.
	val2 := self at: i2.
	out := first - 1.  "will be pre-incremented"

	"select 'lower' half of the elements based on comparator"
	[(i1 <= middle) and: [i2 <= last]] whileTrue:
		[(aBlock value: val1 value: val2)
			ifTrue: [dst at: (out := out + 1) put: val1.
					val1 := self at: (i1 := i1 + 1)]
			ifFalse: [dst at: (out := out + 1) put: val2.
					i2 := i2 + 1.
					i2 <= last ifTrue: [val2 := self at: i2]]].

	"copy the remaining elements"
	i1 <= middle
		ifTrue: [dst replaceFrom: out + 1 to: last with: self startingAt: i1]
		ifFalse: [dst replaceFrom: out + 1 to: last with: self startingAt: i2]! !

!TSortable methodsFor: 'sorting' stamp: ''!
mergeSortFrom: first to: last src: src dst: dst by: aBlock
	"Private. Split the range to be sorted in half, sort each half, and 
	merge the two half-ranges into dst."

	| middle |
	first = last ifTrue: [^ self].
	middle := (first + last) // 2.
	self mergeSortFrom: first to: middle src: dst dst: src by: aBlock.
	self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock.
	src mergeFirst: first middle: middle last: last into: dst by: aBlock! !

!TSortable methodsFor: 'sorting' stamp: ''!
isSortedBy: aBlock
	"Return true if the receiver is sorted by the given criterion."

	| lastElm elm |
	self isEmpty ifTrue: [^ true].
	lastElm := self first.
	2 to: self size do: 
		[:index | 
		elm := self at: index.
		(aBlock value: lastElm value: elm) ifFalse: [^ false].
		lastElm := elm].
	^ true! !

!TSortable methodsFor: 'sorting' stamp: ''!
sort: aSortBlock 
	"Sort this array using aSortBlock. The block should take two arguments
	and return true if the first element should preceed the second one."

	self
		mergeSortFrom: 1
		to: self size
		by: aSortBlock! !

!TSortable methodsFor: 'sorting' stamp: ''!
isSorted
	"Return true if the receiver is sorted by the given criterion.
	Optimization for isSortedBy: [:a :b | a <= b]."

	| lastElm elm |
	self isEmpty ifTrue: [^ true].
	lastElm := self first.
	2 to: self size do: 
		[:index | 
		elm := self at: index.
		lastElm <= elm ifFalse: [^ false].
		lastElm := elm].
	^ true! !

!TSortable methodsFor: 'sorting' stamp: ''!
sorted
	"Return a new sequenceable collection which contains the same elements as self but its 
elements are sorted in ascending order using the #'<=' operator."
	
	^self sorted: [ :a :b| a <= b ]! !

!TSortable methodsFor: 'sorting' stamp: ''!
sort
	"Sort this collection into ascending order using the '<=' operator."

	self sort: [:a :b | a <= b]! !

!TSortable methodsFor: 'sorting' stamp: ''!
mergeSortFrom: startIndex to: stopIndex by: aBlock
	"Sort the given range of indices using the mergesort algorithm.
	Mergesort is a worst-case O(N log N) sorting algorithm that usually
	does only half as many comparisons as heapsort or quicksort."

	"Details: recursively split the range to be sorted into two halves,
	mergesort each half, then merge the two halves together. An extra 
	copy of the data is used as temporary storage and successive merge 
	phases copy data back and forth between the receiver and this copy.
	The recursion is set up so that the final merge is performed into the
	receiver, resulting in the receiver being completely sorted."

	self size <= 1 ifTrue: [^ self].  "nothing to do"
	startIndex = stopIndex ifTrue: [^ self].
	[startIndex >= 1 and: [startIndex < stopIndex]] assert. "bad start index"
	[stopIndex <= self size] assert. "bad stop index"
	self
		mergeSortFrom: startIndex
		to: stopIndex 
		src: self copy 
		dst: self 
		by: aBlock! !

!TSortable classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TSortable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TSortable classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TSortable classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TSortable classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TSortable classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TSortable classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TSortable classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TSortable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TSortable classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TSortable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TSortable classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TSortable classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TSortable classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TSortable classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TSortable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TSortable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TSortable classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TSortable classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TSortable classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TSortable classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TSortable classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TSortable classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TSortable classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TSortable classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TStDebuggerExtension methodsFor: 'debugger extension' stamp: ''!
debuggerExtensionToolName
	^self explicitRequirement ! !

!TStDebuggerExtension methodsFor: 'debugger extension' stamp: ''!
displayOrder
	^self class displayOrder! !

!TStDebuggerExtension classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TStDebuggerExtension classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TStDebuggerExtension classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TStDebuggerExtension classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TStDebuggerExtension classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TStDebuggerExtension classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TStDebuggerExtension classTrait methodsFor: 'debugger extension' stamp: ''!
displayOrder: anInteger
	debuggerExtensionDisplayOrder := anInteger! !

!TStDebuggerExtension classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TStDebuggerExtension classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TStDebuggerExtension classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TStDebuggerExtension classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TStDebuggerExtension classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TStDebuggerExtension classTrait methodsFor: 'debugger extension' stamp: ''!
showInDebugger: aBoolean
	showDebuggerExtension := aBoolean! !

!TStDebuggerExtension classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TStDebuggerExtension classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TStDebuggerExtension classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TStDebuggerExtension classTrait methodsFor: 'debugger extension' stamp: ''!
displayOrder

	^ debuggerExtensionDisplayOrder ifNil: [ 
		  debuggerExtensionDisplayOrder := self defaultDisplayOrder ]! !

!TStDebuggerExtension classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TStDebuggerExtension classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TStDebuggerExtension classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TStDebuggerExtension classTrait methodsFor: 'debugger extension' stamp: ''!
defaultDisplayOrder

	^ 1! !

!TStDebuggerExtension classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TStDebuggerExtension classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TStDebuggerExtension classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TStDebuggerExtension classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TStDebuggerExtension classTrait methodsFor: 'debugger extension' stamp: ''!
showInDebugger
	^showDebuggerExtension ifNil: [showDebuggerExtension := false]! !

!TStDebuggerExtension classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TStDebuggerExtension classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TStDebuggerExtension classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TStDebuggerExtension classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TStDebuggerExtension classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TStDebuggerExtensionTest methodsFor: 'tests' stamp: ''!
testExtensionToolNameIsExplicitRequirement

	self assert: (TStDebuggerExtension>>#debuggerExtensionToolName) isExplicitlyRequired ! !

!TStDebuggerExtensionTest methodsFor: 'running' stamp: ''!
tearDown
	traitUser := nil.
	StDebuggerExtensionGeneratorForTests removeTestClass.
	super tearDown! !

!TStDebuggerExtensionTest methodsFor: 'tests' stamp: ''!
testDefaultDisplayOrder
	self assert: TStDebuggerExtension defaultDisplayOrder equals: 1! !

!TStDebuggerExtensionTest methodsFor: 'tests' stamp: ''!
testDisplayOrder

	self
		assert: TStDebuggerExtension displayOrder
		equals: TStDebuggerExtension defaultDisplayOrder.
	self
		assert: traitUser displayOrder
		equals: TStDebuggerExtension displayOrder.
	traitUser class displayOrder: 10.
	self assert: traitUser displayOrder equals: 10! !

!TStDebuggerExtensionTest methodsFor: 'tests' stamp: ''!
testShowInDebugger

	self deny: TStDebuggerExtension showInDebugger.
	traitUser class showInDebugger: true.
	self assert: traitUser class showInDebugger! !

!TStDebuggerExtensionTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	StDebuggerExtensionGeneratorForTests generateTestClass.
	traitUser := StDebuggerExtensionGeneratorForTests testClass new! !

!TStructuralEqualityTest commentStamp: ''!
Tests whether two objects are equals: they contain the same objects in the same order.!
!TStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignOfIdenticalCollectionObjects
	
	self assert: self empty equals: self empty. 
	self assert: self nonEmpty equals: self nonEmpty! !

!TStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
empty
	
	^ self explicitRequirement! !

!TStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
nonEmpty
	
	^ self explicitRequirement! !

!TStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
testEqualSign
 
	self deny: (self empty = self nonEmpty)! !

!TStructuralEqualityTest methodsFor: 'tests - equality' stamp: ''!
testEqualSignIsTrueForNonIdenticalButEqualCollections
		
	self assert: self empty equals: self empty copy. 
	self assert: self empty copy equals: self empty.
	self assert: self empty copy equals: self empty copy.
		
	self assert: self nonEmpty equals: self nonEmpty copy. 
	self assert: self nonEmpty copy equals: self nonEmpty.
	self assert: self nonEmpty copy equals: self nonEmpty copy! !

!TStructuralEqualityTest methodsFor: 'tests - fixture' stamp: ''!
test0TStructuralEqualityTest
	self empty.
	self nonEmpty.
	self assertEmpty: self empty.
	self denyEmpty: self nonEmpty! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TStructuralEqualityTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TStructuralEqualityTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TStructuralEqualityTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TStructuralEqualityTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TStructuralEqualityTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TStructuralEqualityTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TStructuralEqualityTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TStructuralEqualityTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TStructuralEqualityTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TSubCollectionAccess commentStamp: ''!
A trait for test purposes!
!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLast

	| abf col |
	col := self moreThan3Elements.
	abf := col allButLast.
	self deny: abf last = col last.
	self assert: abf size + 1 equals: col size! !

!TSubCollectionAccess methodsFor: 'tests - fixture' stamp: ''!
test0FixtureSubcollectionAccessTest

	self moreThan3Elements.
	self assert: self moreThan3Elements size > 2! !

!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: ''!
testLastNElements

	| result |
	result := self moreThan3Elements last: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i + 1) ].
	self assert: result size equals: (self moreThan3Elements size - 1).
	self 
		should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ]
		raise: Error! !

!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: ''!
testAllButLastNElements

	| allButLast collection |
	collection := self moreThan3Elements.
	allButLast := collection allButLast: 2.
	allButLast withIndexDo: [:el :i | self assert: el equals: (collection at: i) ].
	self assert: allButLast size + 2 equals: collection size! !

!TSubCollectionAccess methodsFor: 'requirements' stamp: ''!
moreThan3Elements
	" return a collection including atLeast 3 elements"
	self explicitRequirement! !

!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: ''!
testAllButFirst

	| abf col |
	col := self moreThan3Elements.
	abf := col allButFirst.
	self deny: abf first = col first.
	self assert: abf size + 1 = col size! !

!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: ''!
testAllButFirstNElements

	| allButFirst collection |
	collection := self moreThan3Elements.
	allButFirst := collection allButFirst: 2.
	allButFirst withIndexDo: 
		 [:el :i | self assert: el equals: (collection at: i + 2) ].
	self assert: allButFirst size + 2 equals: collection size! !

!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: ''!
testFirstNElements

	| result |
	result := self moreThan3Elements first: self moreThan3Elements size - 1.
	result withIndexDo: [:el :i | self assert: el equals: (self moreThan3Elements at: i) ].
	
	self assert: result size equals: (self moreThan3Elements size - 1).
	self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: SubscriptOutOfBounds! !

!TSubCollectionAccess classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TSubCollectionAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TSubCollectionAccess classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TSubCollectionAccess classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TSubCollectionAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TSubCollectionAccess classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TSubCollectionAccess classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TSubCollectionAccess classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TSubCollectionAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSubCollectionAccess classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TSubCollectionAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TSubCollectionAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TSubCollectionAccess classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TSubCollectionAccess classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TSubCollectionAccess classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TSubCollectionAccess classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TSubCollectionAccess classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TSubCollectionAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TSubCollectionAccess classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TSubCollectionAccess classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TSubCollectionAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TSubCollectionAccess classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TSubCollectionAccess classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TSubCollectionAccess classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TSubCollectionAccess classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TSubCollectionAccess classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TTLAssociation commentStamp: ''!
I am TTLAssociation. 
I am an Association.

I maintain a timestamp that gets updated each time my value changes.

I decide myself when I am stale, using a cache defined default time to live.!
!TTLAssociation methodsFor: 'accessing' stamp: ''!
value: anObject
	super value: anObject.
	timestamp := self now! !

!TTLAssociation methodsFor: 'accessing' stamp: ''!
key: aKey value: anObject 
	super key: aKey value: anObject.
	timestamp := self now! !

!TTLAssociation methodsFor: 'accessing' stamp: ''!
now
	^ Time totalSeconds! !

!TTLAssociation methodsFor: 'accessing' stamp: ''!
timestamp
	^ timestamp! !

!TTLAssociation methodsFor: 'testing' stamp: ''!
isStale: timeToLive
	^ self now - timestamp >= timeToLive! !

!TTLCache commentStamp: ''!
I am TTLCache. 
I am an LRUCache.

I record a timestamp when I store a value for a key.

Upon a cache hit, I check if the timestamp of the stored value does not exceed the allowed time to live duration - if so, the value has become stale and I will retrieve the value again.

The default timeToLive is 1 hour.

Note that eviction, making room in a full cache, still happens according to the LRU algorithm from my superclass - stale entries to not get evicted automatically.

I can remove all my stale values in O(n), see #removeStaleValues.

Implementation Notes

I extend my superclass by storing TTLAssociations (which also hold a timestamp) instead of Associations in the DoubleLinkedList, lruList, ordered from least to most recently used.

In case of a hit, there is now an additional check to see if the value has become stale (exceeded its time to live). If so, the value is computed again.

Timestamps are implemented using Integer seconds (Time totalSeconds) for performance reasons.!
!TTLCache methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self timeToLive: 1 hour! !

!TTLCache methodsFor: 'printing' stamp: ''!
printElementsOn: stream
	super printElementsOn: stream.
	stream space; print: timeToLive asDuration! !

!TTLCache methodsFor: 'removing' stamp: ''!
removeStaleValues
	"Go over all cached values and remove those that are stale.
	Remove a collection of the keys that were removed."

	^ self critical: [
		| keysToRemove |
		keysToRemove := OrderedCollection new.
		lruList do: [ :association |
			 (self isStale: association) 
				ifTrue: [ keysToRemove add: association key ] ].
		keysToRemove do: [ :each | self removeKey: each ].
		keysToRemove ]! !

!TTLCache methodsFor: 'initialize' stamp: ''!
timeToLive: duration
	"Set how old computed values can be before they become stale.
	When stale, a value will be computed again based on the block passed in.
	Specify either an Integer or a Duration, both will be converted to seconds."
	
	timeToLive := duration asDuration asSeconds! !

!TTLCache methodsFor: 'accessing' stamp: ''!
now
	^ Time totalSeconds! !

!TTLCache methodsFor: 'accessing' stamp: ''!
at: key ifAbsentPut: block
	"Overwritten - see the comment of the method that I overwrite.
	In case of a hit, the cached value's timestamp is checked to see if its age
	does not exceed the allowed timeToLive. If so, the stale value is recomputed."
	
	self critical: [ | association |
		association := keyIndex 
			associationAt: key 
			ifAbsent: [ | value |
				value := block cull: key.
				"Sadly we have to check the presence of key again 
				in case of the block execution already added the entry"
				keyIndex 
					associationAt: key 
					ifAbsent: [ | newAssociation | 
						newAssociation := self newAssociationKey: key value: value.
						^ self handleMiss: newAssociation ] ].
		^ self handleHit: association ifStale: block ]! !

!TTLCache methodsFor: 'private' stamp: ''!
handleHit: association ifStale: block
	"In case of a hit, the cached value's timestamp is check to see if its age
	does not exceed the allowed timeToLive. If so, the stale value is recomputed."

	| link newValue |
	statistics addHit.
	link := association value.
	self promote: link.
	(self isStale: link value)
		ifTrue: [
			newValue := block cull: association key.
			link value value: newValue ].
	^ link value value! !

!TTLCache methodsFor: 'private' stamp: ''!
newAssociationKey: key value: value
	"Override this method in a subclass to customise expiration behavior"
	
	^ TTLAssociation key: key value: value! !

!TTLCache methodsFor: 'private' stamp: ''!
isStale: association
	"Delegate the decision to the association itself 
	with our time to live as default"
	
	^ association isStale: timeToLive! !

!TTLCacheTest methodsFor: 'testing' stamp: ''!
testExpiring
	| cache didComputeValue |
	cache := self newCache.
	cache timeToLive: 1 second.
	didComputeValue := false.
	cache at: #foo ifAbsentPut: [ didComputeValue := true. 100 ].
	self assert: didComputeValue.
	self assert: (cache includesKey: #foo).
	self assert: (cache at: #foo ifAbsentPut: [ self fail ]) equals: 100.
	1 second asDelay wait.
	didComputeValue := false.
	cache at: #foo ifAbsentPut: [ didComputeValue := true. 101 ].
	self assert: didComputeValue.
	self assert: (cache includesKey: #foo).
	self assert: (cache at: #foo ifAbsentPut: [ self fail ]) equals: 101.
	cache validateInvariantWith: self 
	! !

!TTLCacheTest methodsFor: 'testing' stamp: ''!
testRemoveStaleValues
	| cache keys |
	cache := self newCache.
	cache timeToLive: 1 second.
	cache at: #foo ifAbsentPut: [ 100 ].
	cache at: #bar ifAbsentPut: [ 200 ].
	self deny: cache isEmpty.
	1 second asDelay wait.
	keys := cache removeStaleValues.
	self assertEmpty: cache.
	self assert: keys asArray sorted equals: #(bar foo).
	cache validateInvariantWith: self! !

!TTLCacheTest methodsFor: 'accessing' stamp: ''!
newCache
	^ TTLCache new! !

!TTLCacheTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!TTaskExecutor commentStamp: ''!
I am a trait implementing the main behavior of a task executor. That is, an object that knows how to execute a task and handle its unhandled exceptions using an exception handler!
!TTaskExecutor methodsFor: 'accessing' stamp: ''!
noteFree

	self shouldBeImplemented! !

!TTaskExecutor methodsFor: 'executing' stamp: ''!
executeTask: aTaskExecution
	[ self noteBusy.
	aTaskExecution noteRunningOn: self.
	aTaskExecution value.
	self noteFree ]
		on: Error
		do: [ :error | self exceptionHandler handleException: error ]! !

!TTaskExecutor methodsFor: 'accessing' stamp: ''!
exceptionHandler

	self shouldBeImplemented ! !

!TTaskExecutor methodsFor: 'accessing' stamp: ''!
noteBusy

	self shouldBeImplemented! !

!TTaskExecutor methodsFor: 'testing' stamp: ''!
isDebuggingCompatible
	^ false! !

!TTaskExecutor classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TTaskExecutor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TTaskExecutor classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TTaskExecutor classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TTaskExecutor classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TTaskExecutor classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TTaskExecutor classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TTaskExecutor classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TTaskExecutor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TTaskExecutor classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TTaskExecutor classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TTaskExecutor classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TTaskExecutor classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TTaskExecutor classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TTaskExecutor classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TTaskExecutor classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TTaskExecutor classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TTaskExecutor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TTaskExecutor classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TTaskExecutor classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TTaskExecutor classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TTaskExecutor classTrait methodsFor: 'testing' stamp: ''!
isDebuggingCompatible
	^ false! !

!TTaskExecutor classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TTaskExecutor classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TTaskExecutor classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TTaskExecutor classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TTaskExecutor classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TTaskScheduler commentStamp: ''!
I am a trait implementing the main behavior of a task scheduler. That is, I define as requirement a #schedule: message and I define #future: on top of #schedule:.!
!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
future: aTask
	^ aTask asTask future: self! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
isLocalThreadRunner
	^ false ! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
isWorker
	^ false ! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
schedule: aTask timeout: aTimeout

	| execution |
	execution := TKTTimeoutableTaskExecution new.
	execution runner: self.
	execution task: aTask.
	execution timeout: aTimeout.
	
	self scheduleTaskExecution: execution.! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
schedule: aTask
	aTask asTask schedule: self! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
scheduleTimeout: timeout on: aTaskExecution
	TKTConfiguration processProvider
		createProcessDoing:
			(MessageSend
				receiver: self
				selector: #privateTimeout:on:
				arguments:
					{timeout.
					aTaskExecution})! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
scheduleTaskExecution: aTaskExecution

	self requirement! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
privateFuture: aTask
	| execution |
	execution := aTask asTask futureTaskExecutionFor: self.
	self scheduleTaskExecution: execution.
	^ execution future! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
privateTimeout: timeout on: aTaskExecution
	timeout wait.
	aTaskExecution isFinished
		ifFalse: [ aTaskExecution cancelWithReason: 'Timeout after: ' , timeout asString ]! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
isUIRunner
	^ false ! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
isDebuggingCompatible
	^ false! !

!TTaskScheduler methodsFor: 'schedulling' stamp: ''!
privateSchedule: aTask
	| execution |
	execution := aTask asTask scheduleTaskExecutionFor: self.
	self scheduleTaskExecution: execution
	! !

!TTaskScheduler classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TTaskScheduler classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TTaskScheduler classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TTaskScheduler classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TTaskScheduler classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TTaskScheduler classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TTaskScheduler classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TTaskScheduler classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TTaskScheduler classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TTaskScheduler classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TTaskScheduler classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TTaskScheduler classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TTaskScheduler classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TTaskScheduler classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TTaskScheduler classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TTaskScheduler classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TTaskScheduler classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TTaskScheduler classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TTaskScheduler classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TTaskScheduler classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TTaskScheduler classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TTaskScheduler classTrait methodsFor: 'testing' stamp: ''!
isDebuggingCompatible
	^ false! !

!TTaskScheduler classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TTaskScheduler classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TTaskScheduler classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TTaskScheduler classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TTaskScheduler classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TTranscript commentStamp: ''!
I define the API of Transcript, which is quite similar to stream.

A Transcript acts like a character write stream, accumulating output send to it. Some operations buffer output without necessarily showing it (like #nextPut: nextPutAll: #print: #cr #space and #tab), while others add their output and show any buffered output (like #show: #crShow: and <<). Use #flush or #endEntry to force buffered output to be shown.

Clients are required to implement #critical: #flush: #nextPut: and #nextPutAll: 

Note that #critical: should serialize multithreaded access

Client can optionally implement #close or #clear themselves

Historical note: #ensureCr and #reset were removed since they were not used!
!TTranscript methodsFor: 'streaming' stamp: ''!
endEntry
	"Show the currently buffered output"

	self flush! !

!TTranscript methodsFor: 'streaming' stamp: ''!
crShow: anObject
	"Output anObject asString on the receiver preceded by a cr and show the output"
	
	self critical: [ self cr; show: anObject ]! !

!TTranscript methodsFor: 'streaming' stamp: ''!
space
	"Output a space on the receiver, buffered and not yet shown"

	self nextPut: Character space! !

!TTranscript methodsFor: 'streaming' stamp: ''!
tab
	"Output a tab on the receiver, buffered and not yet shown"

	self nextPut: Character tab! !

!TTranscript methodsFor: 'streaming' stamp: ''!
<< anObject
	"Write anObject to the receiver, dispatching using #putOn:
	This is a shortcut for both nextPut: and nextPutAll: since anObject can be both
	the element type of the receiver as well as a collection of those elements.
	No further conversions of anObject are applied.
	Return self to accomodate chaining."

 	anObject putOn: self! !

!TTranscript methodsFor: 'streaming' stamp: ''!
nextPut: character
	"Output character on the receiver, buffered, not yet shown"

	self explicitRequirement! !

!TTranscript methodsFor: 'streaming' stamp: ''!
show: anObject
	"Output anObject asString on the receiver and show the output"
	
	self critical: [ self print: anObject; endEntry ]! !

!TTranscript methodsFor: 'streaming' stamp: ''!
clear
	"Clear the receiver, removing all existing output"! !

!TTranscript methodsFor: 'streaming' stamp: ''!
close
	"Close the receiver, indicating it is not longer needed"! !

!TTranscript methodsFor: 'streaming' stamp: ''!
flush
	"Show the currently buffered output"

	self explicitRequirement! !

!TTranscript methodsFor: 'streaming' stamp: ''!
critical: block
	"Execute block making sure only one thread accesses the receiver"
	
	self explicitRequirement! !

!TTranscript methodsFor: 'streaming' stamp: ''!
nextPutAll: string
	"Output string on the receiver, buffered, not yet shown"

	self explicitRequirement! !

!TTranscript methodsFor: 'streaming' stamp: ''!
print: anObject
	"Output anObject asString on the receiver, buffered, not yet shown"
	
	self nextPutAll: anObject asString! !

!TTranscript methodsFor: 'streaming' stamp: ''!
cr
	"Output a cr on the receiver, buffered and not yet shown"
	
	self nextPut: Character cr! !

!TTranscript classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString

	^ self traitComposition asString! !

!TTranscript classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3

	self localMethodDict at: arg1 put: arg2.
	super addAndClassifySelector: arg1 withMethod: arg2 inProtocol: arg3.
	TraitChange addSelector: arg1 on: self! !

!TTranscript classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: arg1

	^ self isLocalSelector: arg1! !

!TTranscript classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary

	| tmp1 tmp2 tmp3 tmp5 |
	tmp5 := false.
	self methodDict valuesDo: [ :arg1 | 
		| tmp7 |
		tmp7 := arg1 traitSource.
		tmp7
			ifNil: [ self localMethodDict at: arg1 selector put: arg1 ]
			ifNotNil: [ tmp7 ] ].
	tmp1 := self traitComposition selectors reject: [ :arg2 | 
		        self localMethodDict includesKey: arg2 ].
	tmp1 do: [ :arg3 | 
		tmp5 := tmp5 | (self traitComposition
			         installSelector: arg3
			         into: self
			         replacing: false) ].
	tmp2 := self methodDict keys reject: [ :arg4 | 
		        (tmp1 includes: arg4) or: [ 
			        self localMethodDict includesKey: arg4 ] ].
	tmp5 := tmp5 | tmp2 isNotEmpty.
	tmp2 do: [ :arg5 | self methodDict removeKey: arg5 ].
	tmp3 := self organization allMethodSelectors reject: [ :arg6 | 
		        self methodDict includesKey: arg6 ].
	tmp3 do: [ :arg7 | self organization removeElement: arg7 ].
	^ tmp5! !

!TTranscript classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: arg1

	^ self localMethodDict includesKey: arg1! !

!TTranscript classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: arg1

	^ self traitComposition isAliasSelector: arg1! !

!TTranscript classTrait methodsFor: 'querying' stamp: ''!
allTraits

	^ self traitComposition allTraits! !

!TTranscript classTrait methodsFor: 'removing' stamp: ''!
removeSelector: arg1

	super removeSelector: arg1.
	self localMethodDict removeKey: arg1 ifAbsent: [  ].
	TraitChange removeSelector: arg1 on: self! !

!TTranscript classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withRecompiledMethod: arg2

	arg2 isFromTrait ifTrue: [ 
		^ super addSelector: arg1 withRecompiledMethod: arg2 ].
	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withRecompiledMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TTranscript classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: arg1

	self setTraitComposition:
		(self traitComposition copyWithoutTrait: arg1 asTraitComposition)! !

!TTranscript classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: arg1

	^ self class baseLocalMethods: arg1! !

!TTranscript classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict

	^ self class baseLocalMethods! !

!TTranscript classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition

	^ self traitComposition isEmpty not! !

!TTranscript classTrait methodsFor: 'recompilation' stamp: ''!
recompile: arg1 from: arg2

	| tmp1 tmp2 tmp4 |
	tmp1 := arg2 compiledMethodAt: arg1.
	tmp4 := self compiler.
	tmp4
		source: (arg2 sourceCodeAt: arg1);
		class: self;
		failBlock: [ ^ self ];
		compiledMethodTrailer: tmp1 trailer.
	tmp2 := tmp4 compile.
	arg1 == tmp2 selector ifFalse: [ self error: 'selector changed!!' ].
	tmp1 properties
		at: #traitSource
		ifPresent: [ :arg3 | tmp2 propertyAt: #traitSource put: arg3 ].
	self addSelector: arg1 withRecompiledMethod: tmp2! !

!TTranscript classTrait methodsFor: 'accessing' stamp: ''!
localMethods

	^ self localMethodDict values! !

!TTranscript classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: arg1

	arg1 asTraitComposition allTraits do: [ :arg2 | 
		arg2 isTrait ifFalse: [ 
			self error:
				'All the members of the trait composition should be traits' ] ].
	self class baseComposition: arg1! !

!TTranscript classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: arg1 withMethod: arg2

	self localMethodDict at: arg1 put: arg2.
	super addSelector: arg1 withMethod: arg2.
	TraitChange addSelector: arg1 on: self! !

!TTranscript classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: arg1

	(arg1 hasProperty: #traitSource) ifTrue: [ 
		^ arg1 traitSource innerClass ].
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ self ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ ^ self ]) innerClass! !

!TTranscript classTrait methodsFor: 'accessing' stamp: ''!
traitComposition

	^ self class baseComposition! !

!TTranscript classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: arg1

	^ self traitComposition isLocalAliasSelector: arg1! !

!TTranscript classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: arg1

	| tmp1 |
	(self includesLocalSelector: arg1 selector) ifTrue: [ ^ arg1 ].
	(arg1 hasProperty: #traitSource) ifTrue: [ 
		tmp1 := self traitComposition originSelectorOf: arg1 selector.
		^ arg1 traitSource compiledMethodAt: tmp1 ifAbsent: [ arg1 ] ].
	^ (self traitComposition
		   traitDefining: arg1 selector
		   ifNone: [ self ])
		  compiledMethodAt: arg1 selector
		  ifAbsent: [ ^ arg1 ]! !

!TTranscript classTrait methodsFor: 'accessing' stamp: ''!
traits

	^ self traitComposition traits! !

!TTranscript classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors

	^ self localMethodDict keys! !

!TTranscript classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: arg1 from: arg2 to: arg3

	| tmp1 |
	tmp1 := self organization
		        categoryOfElement: arg1
		        ifAbsent: [ ^ self ].
	arg3 ifNil: [ ^ self ].
	tmp1 = arg2 ifTrue: [ 
		self organization classify: arg1 under: arg3 suppressIfDefault: true ].
	(self traitComposition reverseAlias: arg1) do: [ :arg4 | 
		self
			recategorizeSelector: arg4 from: arg2 to: arg3;
			notifyOfRecategorizedSelector: arg4 from: arg2 to: arg3 ].
	self organization removeEmptyCategories! !

!TTranscript classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: arg1

	arg1 methodSelectors ifEmpty: [ ^ true ].
	^ arg1 methodSelectors anySatisfy: [ :arg2 | 
		  self isLocalSelector: arg2 ]! !

!TTutorialTest commentStamp: ''!
Trait for testing tutorials!
!TTutorialTest methodsFor: 'tests' stamp: ''!
testEachSelectorReturnsALesson
	| answer |
	self testedTutorial tutorial do: [:aSelector|
		answer := (self testedTutorial perform: aSelector).
		self assert: (answer isKindOf: Lesson).
	]! !

!TTutorialTest methodsFor: 'tests' stamp: ''!
testNotEmpty
	self assert: self testedTutorial tutorial notEmpty.! !

!TTutorialTest methodsFor: 'tests' stamp: ''!
testSizeReturnsNumberOfSelectors
	self assert: (self testedTutorial tutorial size) equals: self testedTutorial size.! !

!TTutorialTest methodsFor: 'requirements' stamp: ''!
testedTutorial
	"Returns an instance of an AbstractTutorial subclass"
	^ self explicitRequirement! !

!TTutorialTest methodsFor: 'tests' stamp: ''!
testEachSelectorExists
	self testedTutorial tutorial do: [:aSelector|
		self assert: (self tutorial respondsTo: aSelector) 
	]! !

!TTutorialTest methodsFor: 'tests' stamp: ''!
testLessonAtReturnsCorrespondingLesson
	| answer |
	1 to: (self testedTutorial tutorial size) do: [:index|
		answer := self testedTutorial lessonAt: index.
		self assert: (answer isKindOf: Lesson)
	]! !

!TTutorialTest classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TTutorialTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TTutorialTest classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TTutorialTest classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TTutorialTest classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TTutorialTest classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TTutorialTest classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TTutorialTest classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TTutorialTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TTutorialTest classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TTutorialTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TTutorialTest classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TTutorialTest classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TTutorialTest classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TTutorialTest classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TTutorialTest classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TTutorialTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TTutorialTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TTutorialTest classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TTutorialTest classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TTutorialTest classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TTutorialTest classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TTutorialTest classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TTutorialTest classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TTutorialTest classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TTutorialTest classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TTwo commentStamp: ''!
I am a trait used for testing.!
!TTwo methodsFor: 'testing' stamp: ''!
two
	^ 2! !

!TTwo classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TTwo classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TTwo classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TTwo classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TTwo classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TTwo classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TTwo classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TTwo classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TTwo classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TTwo classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TTwo classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TTwo classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TTwo classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TTwo classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TTwo classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TTwo classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TTwo classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TTwo classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TTwo classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TTwo classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TTwo classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TTwo classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TTwo classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TTwo classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TTwo classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TTwo classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TViewModel commentStamp: ''!
This trait contains the necessary methods to manipulate correctly a RubScrolledTextMorph via a model.
Should be use in the model class of the architecture. 

The interactionModel can represents your model or a model of the higher level (AbstractNautilusUI for the text area of Nautilus for example).
!
!TViewModel methodsFor: 'accessing' stamp: ''!
interactionModel
	^ self! !

!TViewModel methodsFor: 'accessing' stamp: ''!
announcer
	"Define #announcer if needed"! !

!TViewModel classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TViewModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TViewModel classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TViewModel classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TViewModel classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TViewModel classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TViewModel classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TViewModel classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TViewModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TViewModel classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TViewModel classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TViewModel classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TViewModel classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TViewModel classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TViewModel classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TViewModel classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TViewModel classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TViewModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TViewModel classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TViewModel classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TViewModel classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TViewModel classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TViewModel classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TViewModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TViewModel classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TViewModel classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TViewModelMock commentStamp: ''!
A trait to use as a mock in test classes like `FluidClassBuilderTest` and class `FluidTraitBuilderTest`!
!TViewModelMock classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TViewModelMock classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TViewModelMock classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TViewModelMock classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TViewModelMock classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TViewModelMock classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TViewModelMock classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TViewModelMock classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TViewModelMock classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TViewModelMock classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TViewModelMock classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TViewModelMock classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TViewModelMock classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TViewModelMock classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TViewModelMock classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TViewModelMock classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TViewModelMock classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TViewModelMock classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TViewModelMock classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TViewModelMock classTrait methodsFor: 'accessing' stamp: ''!
a

	^ a! !

!TViewModelMock classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TViewModelMock classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TViewModelMock classTrait methodsFor: 'accessing' stamp: ''!
a: anObject

	a := anObject! !

!TViewModelMock classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TViewModelMock classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TViewModelMock classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TViewModelMock classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TViewModelMock classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TViewModelMock2 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TViewModelMock2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TViewModelMock2 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TViewModelMock2 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TViewModelMock2 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TViewModelMock2 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TViewModelMock2 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TViewModelMock2 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TViewModelMock2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TViewModelMock2 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TViewModelMock2 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TViewModelMock2 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TViewModelMock2 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TViewModelMock2 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TViewModelMock2 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TViewModelMock2 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TViewModelMock2 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TViewModelMock2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TViewModelMock2 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TViewModelMock2 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TViewModelMock2 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TViewModelMock2 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TViewModelMock2 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TViewModelMock2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TViewModelMock2 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TViewModelMock2 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TViewModelMock3 methodsFor: 'accessing' stamp: ''!
b: anObject

	b := anObject! !

!TViewModelMock3 methodsFor: 'accessing' stamp: ''!
a

	^ a! !

!TViewModelMock3 methodsFor: 'accessing' stamp: ''!
a: anObject

	a := anObject! !

!TViewModelMock3 methodsFor: 'accessing' stamp: ''!
b

	^ b! !

!TViewModelMock3 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TViewModelMock3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TViewModelMock3 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TViewModelMock3 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TViewModelMock3 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TViewModelMock3 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TViewModelMock3 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TViewModelMock3 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TViewModelMock3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TViewModelMock3 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TViewModelMock3 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TViewModelMock3 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TViewModelMock3 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TViewModelMock3 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TViewModelMock3 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TViewModelMock3 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TViewModelMock3 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TViewModelMock3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TViewModelMock3 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TViewModelMock3 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TViewModelMock3 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TViewModelMock3 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TViewModelMock3 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TViewModelMock3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TViewModelMock3 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TViewModelMock3 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TWithBranchModel methodsFor: 'accessing' stamp: ''!
repositoryModel 
	^ self explicitRequirement! !

!TWithBranchModel methodsFor: 'testing' stamp: ''!
hasBranches 
	^ self branches isNotEmpty! !

!TWithBranchModel methodsFor: 'accessing' stamp: ''!
defaultBranchSelection
	^ self branchModels
		detect: #isHead
		ifNone: [ self hasBranches
				ifTrue: [ self branchModels ifNotEmpty: #anyOne ] ]! !

!TWithBranchModel methodsFor: 'branches' stamp: ''!
branches
	^ self explicitRequirement! !

!TWithBranchModel methodsFor: 'branches' stamp: ''!
branchModels
	^ self branches collect: [ :each | (IceTipBranchModel repositoryModel: self repositoryModel on: each) beCached ]! !

!TWithBranchModel classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TWithBranchModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TWithBranchModel classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TWithBranchModel classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TWithBranchModel classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TWithBranchModel classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TWithBranchModel classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TWithBranchModel classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TWithBranchModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TWithBranchModel classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TWithBranchModel classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TWithBranchModel classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TWithBranchModel classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TWithBranchModel classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TWithBranchModel classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TWithBranchModel classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TWithBranchModel classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TWithBranchModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TWithBranchModel classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TWithBranchModel classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TWithBranchModel classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TWithBranchModel classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TWithBranchModel classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TWithBranchModel classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TWithBranchModel classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TWithBranchModel classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TaAbstractComposition commentStamp: ''!
I represent a trait composition.
All the trait compositions are represented by operations. 
My subclasses are the possible operations. 

I know how to resolve the methods and slots included in a trait or traited class.

Also I and my subclasses control how the new methods are compiled.!
!TaAbstractComposition methodsFor: 'operations' stamp: ''!
copyMethod: aSelector into: aClass replacing: replacing

	"When the included method does not need to be source rewritten or recompiled, 
	it is query by using #changesSourceCode:, the method is inserted in aClass' method dictionary.
	The compiled method is just copied and the source is stored in the change file
	
	I check that the method is not already in the class
	The method is only replaced if replacing is true. 
	"

	| aCompiledMethod source newMethod traitDefining sourceHasChanged |
	
	traitDefining := self traitDefining: aSelector.
	aCompiledMethod := self compiledMethodAt: aSelector.
	source := self getSourceCodeOf: aCompiledMethod usingSelector: aSelector.
	
	"If the selectors are not the same I have to save the new source code"
	sourceHasChanged := aSelector ~= aCompiledMethod selector.
	
	"Check if the method should be replaced. It is replaced if:
	 - replacing is true.
	 - The trait defining the method is not the same.
	 - If both methods have source code and if the source codes are not the same.
	"
	aClass methodDict at: aSelector ifPresent:[ :originalMethod | 
		((replacing not and: [(originalMethod traitSource = traitDefining) and: [originalMethod hasSourceCode]]) and: [ source isNotNil and: [ source = originalMethod sourceCode ] ]) ifTrue: [ ^ false ]].
	
	newMethod := aCompiledMethod copy.
	newMethod selector: aSelector.
	newMethod methodClass: aClass.
			
	newMethod setSourcePointer: aCompiledMethod sourcePointer.	

	aClass addSelectorSilently: aSelector withMethod: newMethod.

	aClass organization protocolOrganizer
		classify: aSelector
		inProtocolNamed: aCompiledMethod category asSymbol.		
	
	aClass organization removeEmptyCategories.
	
	aClass >> aSelector propertyAt: #traitSource put: traitDefining.
		
	^ true! !

!TaAbstractComposition methodsFor: 'transforming selectors' stamp: ''!
aliasSelector: anOldSelector
	"I return the new selector for the old selector passed as parameter"
	^ self shouldBeImplemented! !

!TaAbstractComposition methodsFor: 'comparing' stamp: ''!
hash
	^ self subclassResponsibility ! !

!TaAbstractComposition methodsFor: 'accessing' stamp: ''!
sourceCodeAt: selector
	| method |
	"Returns the source code for a given selector. Handling the rewriting if it is an alias"
	method := self compiledMethodAt: selector.
	^ method selector = selector
		ifTrue: [ method sourceCode ]
		ifFalse: [ method getSourceReplacingSelectorWith: selector ]! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
addToSequence: sequence
	
	"I basically add myself to the sequence passed as parameter. For sure you want to use #+ or #,"
	sequence addMember: self.
	^ sequence! !

!TaAbstractComposition methodsFor: '*TraitsV2-Compatibility' stamp: ''!
includesElement: anElement
	"It checks if the composition includes the given element in the trait composition. It is used for compatibility, it should not be used as it is comparing by identity."
	^ self subclassResponsibility ! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
getSourceCodeOf: aCompiledMethod usingSelector: aSelector 
	
	^ aCompiledMethod getSourceReplacingSelectorWith: aSelector! !

!TaAbstractComposition methodsFor: '*TraitsV2-Compatibility' stamp: ''!
isTraitAlias
	^ false! !

!TaAbstractComposition methodsFor: 'testing' stamp: ''!
isAliasSelector: aSelector

	"Tests if aSelector is alias to another selector"
	self subclassResponsibility  
	! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
initializeObject: anObject
	
	"Handles the custom initialization of a class using stateful talents. 
	When using stateful traits the initialize method in the resulting class 
	includes the initializaton of the included traits."

	| selector |
	selector := self initializeSelectorForMe.

	(anObject class allSelectors includes: selector)
		ifTrue: [ selector value: anObject ]! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
installSelector: aSelector into: aClass
	"
	This method tryies to install a selector in a given class. 
	If the method is already installed it does not perform nothing.
	This may fail because this is used when recalculating the method dictionary. 
	It is probable the aliased method does not exists any more in the trait composition. This situation is checked when creating the trait composition."

	^ self installSelector: aSelector into: aClass replacing: true! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
installSelector: aSelector into: aClass replacing: replacing
	"
	This method tryies to install a selector in a given class. 
	If the method is already installed it does not perform nothing.
	This may fail because this is used when recalculating the method dictionary. 
	It is probable the aliased method does not exists any more in the trait composition. This situation is checked when creating the trait composition."


	[ 	
		^ (self needsRecompilation: aSelector) 
			ifTrue:[ self compile: aSelector into: aClass	]
			ifFalse:[ self copyMethod: aSelector into: aClass replacing: replacing ].	
	 ] on: NotFound
		do: [ ^ true ].
		
	^ true! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
- anArrayOrASymbol
	| anArray |
	
	"I create a remove method on me. Removing the symbol or array of symbols"
	
	anArray := anArrayOrASymbol isArray
		ifTrue: [ anArrayOrASymbol ]
		ifFalse: [ {anArrayOrASymbol} ].
		
	^ TaRemoveMethod remove: anArray to: self! !

!TaAbstractComposition methodsFor: 'comparing' stamp: ''!
syntacticallyEquals: another
	"This is not 100% true, but it is kept for compatibility with the old implementation.
	If two trait composition are syntaticallyEquals they should be semanticallyEquals, however the inverse may not be true."
	^ self semanticallyEquals: another! !

!TaAbstractComposition methodsFor: 'accessing' stamp: ''!
selectors
	self subclassResponsibility ! !

!TaAbstractComposition methodsFor: 'querying' stamp: ''!
originSelectorOf: aSelector 
	"The original selector for a given selector. It is overriden by the alias."
	^ aSelector! !

!TaAbstractComposition methodsFor: 'querying' stamp: ''!
allTraits
	"I should return all the traits in the trait composition and the traits refered by the traits in the trait composition. It is recursive!! #traits is the non recursive version"

	^ self subclassResponsibility! !

!TaAbstractComposition methodsFor: 'printing' stamp: ''!
traitCompositionExpressionWithParens
	"I give my expression, having always parens "

	^ '(' , self traitCompositionExpression , ')'! !

!TaAbstractComposition methodsFor: 'copying' stamp: ''!
copySlot: aSlot
	"This is a utitlity method to handle the copy of a slot. It is used for instance side and class side slots."
	| newOne |
	newOne := aSlot copy.
	newOne isVirtual ifFalse: [ newOne index: nil ].
	newOne definingClass: aSlot definingClass.
	^ newOne! !

!TaAbstractComposition methodsFor: 'compiling' stamp: ''!
compile: selector into: aClass
	"Compile the method associated with selector in aClass's method dictionary.
	This version classify the method in the class passed as parameter"

	| method newMethod sourceCode trailer traitDefining |
	
	traitDefining := self traitDefining: selector.

	method := self compiledMethodAt: selector.
	sourceCode := self sourceCodeAt: selector.
	trailer := method trailer.
	
	newMethod := aClass compiler
				source: sourceCode;
				class: aClass ;
				failBlock: [^ false];
				compiledMethodTrailer: trailer;
				compile.   "Assume OK after proceed from SyntaxError"

	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].

	(selector ~= method selector or: [self changesSourceCode: selector]) 
		ifTrue: [ self saveSourceCode: sourceCode ofMethod: newMethod ]
		ifFalse: [ newMethod setSourcePointer: method sourcePointer ].
		
	aClass addSelectorSilently: selector withMethod: newMethod.

	aClass organization protocolOrganizer
		classify: selector
		inProtocolNamed: (self categoryOfMethod: method withSelector: method selector).
	
	aClass >> selector propertyAt: #traitSource put: traitDefining.
	^ true! !

!TaAbstractComposition methodsFor: 'querying' stamp: ''!
traitDefining: aSelector ifNone: aBlockClosure 
	"I return the trait that is used to find the definition of this selector. If none the block is evaluated"
	
	[ ^ self traitDefining: aSelector ] on: NotFound do: [ ^ aBlockClosure value ]! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
isSourcesPresentInSystem

	^ ((Smalltalk globals includesKey: #SourceFiles) and: [ (Smalltalk globals at: #SourceFiles) notNil])! !

!TaAbstractComposition methodsFor: 'accessing' stamp: ''!
compiledMethodAt: aSelector
	"Access the compiledMethod to use for a given selector. It should handle aliases, sequences and removals.
	It signals NotFound"
	self subclassResponsibility ! !

!TaAbstractComposition methodsFor: 'querying' stamp: ''!
includesTrait: aTrait
	"Checks if the trait is used in the trait composition"
	^ self allTraits includes: aTrait! !

!TaAbstractComposition methodsFor: 'comparing' stamp: ''!
semanticallyEquals: another
	"Checks if I have the same effect that another traitComposition. 
	I have the same effect if I expose the same selectors and the methods have the same source code.
	The comparison is done using the source code to handle the aliasing and the rewriting of methods"
	^ self selectors = another selectors
		and: [ self methods = another methods
				and: [ self selectors
						allSatisfy: [ :e | (self sourceCodeAt: e) = (another sourceCodeAt: e) ] ] ]! !

!TaAbstractComposition methodsFor: 'accessing' stamp: ''!
allSelectors
	"I return all the selectors exported by the trait composition"
	^ self selectors! !

!TaAbstractComposition methodsFor: 'transforming selectors' stamp: ''!
initializeSelectorForMe
	"Calculates the name of the artificial selector added when a stateful trait includes a initialize method"

	^ self shouldBeImplemented! !

!TaAbstractComposition methodsFor: 'printing' stamp: ''!
traitCompositionExpression
	"I give my expression, having parens if they are needed"
	^ self subclassResponsibility! !

!TaAbstractComposition methodsFor: 'querying' stamp: ''!
reverseAlias: aSelector
	"Returns all the aliases that point to this old selector"
	self subclassResponsibility! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
without: anotherTrait
	"Creates a copy of it self without the given trait"

	^ self shouldBeImplemented! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
-- anArrayOfSlotNames
	
	"I create a new trait composition element, from me but without the slot named as the parameter"

	^ TaRemoveSlot remove: anArrayOfSlotNames from: self.! !

!TaAbstractComposition methodsFor: 'accessing' stamp: ''!
compiledMethodAt: aSelector ifAbsent: aValuable

	"It handles the NotFound in a graceful way"

	^ [ self compiledMethodAt: aSelector ]
		on: NotFound
		do: [ ^ aValuable value ]! !

!TaAbstractComposition methodsFor: 'accessing' stamp: ''!
categoryOfMethod: method withSelector: selector
	"I return the category of the method with the selector. 
	This is useful when the method is aliased or the method came from different traits or it is a conflicting category. 
	The basic implementation returns the category of the method"
	^ method category! !

!TaAbstractComposition methodsFor: 'testing' stamp: ''!
needsRecompilation: aSelector
	"Checks if a selector should be compiled because it uses new slots or if its code has been rewritten."

	^ self slots isNotEmpty or: [ self changesSourceCode: aSelector ]! !

!TaAbstractComposition methodsFor: 'comparing' stamp: ''!
= anotherTrait
	^ self shouldBeImplemented! !

!TaAbstractComposition methodsFor: 'testing' stamp: ''!
isEmpty
	^ false! !

!TaAbstractComposition methodsFor: 'accessing' stamp: ''!
hasMethod: aSelector
	^ [ self compiledMethodAt: aSelector.
	true ]
		on: NotFound
		do: [ ^ false ]! !

!TaAbstractComposition methodsFor: 'testing' stamp: ''!
isNotEmpty
	^ self isEmpty not! !

!TaAbstractComposition methodsFor: 'querying' stamp: ''!
traitDefining: selector
	"I return the trait that is used to find the definition of this selector
	It signals NotFound if it is not found"
	^ self shouldBeImplemented.! !

!TaAbstractComposition methodsFor: '*TraitsV2-Compatibility' stamp: ''!
isTraitExclusion
	^ false! !

!TaAbstractComposition methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: self traitCompositionExpression! !

!TaAbstractComposition methodsFor: 'compiling' stamp: ''!
saveSourceCode: sourceCode ofMethod: newMethod

	"I have to check because during bootstrap there is no SouceFiles"
	(sourceCode isNotNil and: [((Smalltalk globals includesKey: #SourceFiles) 
		and: [ (Smalltalk globals at: #SourceFiles) notNil])]) ifTrue: [ 
			newMethod putSource: sourceCode
					withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]].	
! !

!TaAbstractComposition methodsFor: 'converting' stamp: ''!
asTraitComposition
	^ self! !

!TaAbstractComposition methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias I define."
	^ false! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
@ anArrayOfAssociations
	"I return a new trait composition with the aliases passed as parameters. It is an array of associations, the keys are the new selectors and the values are the original selectors"
	^ TaAliasMethod alias: anArrayOfAssociations to: self.! !

!TaAbstractComposition methodsFor: '*Ring-TraitsV2Support' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment
	| def |
	^ anRGEnvironment backend
		definitionFor: self
		ifAbsentRegister: [ | definingClass |
			definingClass := Smalltalk environment allBehaviors detect: [ :b | b traitComposition == self or: [b traitComposition transformations includes: self]].

			def := RGTraitComposition parent: (definingClass asRingMinimalDefinitionIn: anRGEnvironment).

			def propertyNamed: #realObject put: self.

			"we need to set real object because we cannot simply identify the real object from the model data"
			def ]! !

!TaAbstractComposition methodsFor: 'copying' stamp: ''!
copyWithoutTrait: aTrait 
	"Returns a copy without the aTrait"
	self subclassResponsibility ! !

!TaAbstractComposition methodsFor: 'accessing' stamp: ''!
slots
	self subclassResponsibility ! !

!TaAbstractComposition methodsFor: '*TraitsV2-Compatibility' stamp: ''!
transformations
	"For compatibility with old code, does not use!! 
	It returns all the elements in the trait composition"
	self subclassResponsibility! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
@@ anArrayOfAssociations

	"This operation creates a new trait composition element with a slot renamed.
	The parameter is an array of association, where the key is the old name and the value the new name."
	
	^ TaRenameSlot rename: anArrayOfAssociations on: self! !

!TaAbstractComposition methodsFor: 'querying' stamp: ''!
traits
	"Returns the traits directly used in the trait composition. #allTraits returns all the traits used and the ones referenced recursively."

	^ self subclassResponsibility! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
@= anAssociation
	"This performs a deep alias, rewriting all the sendings of this message. The association has its key as the new alias selector and the value as the original selector."
	^ TaDeepAliasMethod alias:anAssociation to: self.! !

!TaAbstractComposition methodsFor: 'copying' stamp: ''!
slotsCopy

	^ self slots collect: [ :each | self copySlot: each ]! !

!TaAbstractComposition methodsFor: 'accessing' stamp: ''!
classComposition
	"This is used to access to the classSide of the traitComposition. Used when creating a traited class without class side traitComposition"
	^ self subclassResponsibility ! !

!TaAbstractComposition methodsFor: 'accessing' stamp: ''!
name
	self subclassResponsibility ! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
, anotherTrait
	"I create another TaSequence with me and then I concatenate anotherTrait to it. The new sequence includes both elements, me and the anotherTrait.
	This operation creates a new sequence with copies. Does not affect the existing one."
	^ (TaSequence with: self) , anotherTrait asTraitComposition! !

!TaAbstractComposition methodsFor: 'testing' stamp: ''!
changesSourceCode: aSelector
	"Checks if a selector should be compiled because its code has been rewritten."
	self subclassResponsibility.! !

!TaAbstractComposition methodsFor: 'copying' stamp: ''!
copyTraitExpression
	"I should copy all the elements in the traitComposition"
	^ self subclassResponsibility ! !

!TaAbstractComposition methodsFor: 'operations' stamp: ''!
+ anotherTrait
	"I create another TaSequence with me and then I concatenate anotherTrait to it. The new sequence includes both elements, me and the anotherTrait.
	This operation creates a new sequence with copies. Does not affect the existing one."
	^ (TaSequence with: self) + anotherTrait asTraitComposition! !

!TaAbstractComposition class methodsFor: 'testing' stamp: ''!
isAbstract

	^self == TaAbstractComposition! !

!TaAliasMethod commentStamp: ''!
I aliases a method in a trait.
As a result, the new trait includes both methods, the original and the newone with the new selector.
I implement the #@ operator.!
!TaAliasMethod methodsFor: 'accessing' stamp: ''!
aliases: anObject
	aliases := anObject! !

!TaAliasMethod methodsFor: 'accessing' stamp: ''!
aliases
	^ aliases! !

!TaAliasMethod methodsFor: 'testing' stamp: ''!
hasAliasForNew: aSelector
	"Check if there is a alias for a new selector"
	^ aliases includesKey: aSelector! !

!TaAliasMethod methodsFor: 'instance creation' stamp: ''!
newSelectorFor: aSelector
	^ aliases keyAtValue: aSelector! !

!TaAliasMethod methodsFor: 'transforming selectors' stamp: ''!
aliasSelector: aSelector
	^ (self hasAliasForOld: aSelector)
		ifTrue: [ self newSelectorFor: aSelector ]
		ifFalse: [ inner aliasSelector: aSelector ]! !

!TaAliasMethod methodsFor: 'printing' stamp: ''!
traitCompositionExpression
	
	^ self inner traitCompositionExpressionWithParens , ' @ ' , aliases associations printString! !

!TaAliasMethod methodsFor: 'querying' stamp: ''!
originSelectorOf: aSelector

	^ aliases at: aSelector ifAbsent: [ aSelector ]
	
	! !

!TaAliasMethod methodsFor: 'accessing' stamp: ''!
sourceCodeAt: aSelector
	^ (self hasAliasForNew: aSelector)
		ifTrue: [ (inner compiledMethodAt: (self oldSelectorFor: aSelector))
				getSourceReplacingSelectorWith: aSelector ]
		ifFalse: [ super sourceCodeAt: aSelector ]! !

!TaAliasMethod methodsFor: '*Ring-TraitsV2Support' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment
	^ anRGEnvironment backend
		definitionFor: self
		ifAbsentRegister: [ | definingClass def |
			definingClass := Smalltalk environment allBehaviors detect: [ :b | b traitComposition transformations includes: self ].

			definingClass traitComposition == self
				ifTrue: [ def := RGTraitAlias parent: (definingClass asRingMinimalDefinitionIn: anRGEnvironment) ]
				ifFalse: [ def := RGTraitAlias parent: (definingClass traitComposition asRingMinimalDefinitionIn: anRGEnvironment) ].


			"we need to set real object because we cannot simply identify the real object from the model data"
			def propertyNamed: #realObject put: self.
			def ]! !

!TaAliasMethod methodsFor: 'querying' stamp: ''!
traitDefining: aSelector
	^ (self hasAliasForNew: aSelector)
		ifTrue: [ inner traitDefining: (self oldSelectorFor: aSelector) ]
		ifFalse: [ inner traitDefining: aSelector ]! !

!TaAliasMethod methodsFor: 'accessing' stamp: ''!
compiledMethodAt: aSelector

	^ (self hasAliasForNew: aSelector)
		ifTrue: [ inner compiledMethodAt: (self oldSelectorFor: aSelector) ]
		ifFalse: [ inner compiledMethodAt: aSelector ]! !

!TaAliasMethod methodsFor: 'aliasing' stamp: ''!
oldSelectorFor: aSelector
	^ aliases at: aSelector! !

!TaAliasMethod methodsFor: '*TraitsV2-Compatibility' stamp: ''!
isTraitAlias
	^ true! !

!TaAliasMethod methodsFor: 'testing' stamp: ''!
isAliasSelector: aSelector

	^ (self aliases includesKey: aSelector) or: [ inner isAliasSelector: aSelector ]! !

!TaAliasMethod methodsFor: 'validation' stamp: ''!
checkAssociations
	"I check the validity of the associations used for aliasing"
	self aliases
		associationsDo: [ :assoc | 
			| old new |
			new := assoc key.
			old := assoc value.
			new = old ifTrue: [ self error: 'The alias and the alieased are the same' ].
			(self aliases includesKey: old) ifTrue: [ self error: 'An alias is refering other alias' ].
			new numArgs = old numArgs ifFalse: [ self error: 'Number of parameters in aliases should be the same.' ].
			"For now I am not checking that the aliased method exists, 
			this is the same behavior than before.
			(inner compiledMethodAt: old) ifNil: [ NotFound signalFor: old ]" ]! !

!TaAliasMethod methodsFor: 'accessing' stamp: ''!
existingAliasedSelectors
	| innerSelectors |
	"I calculate the new aliases selectors"
	innerSelectors := inner selectors.

	^ self aliases associations
		select: [ :a | innerSelectors includes: a value ]
		thenCollect: [ :a | a key ]! !

!TaAliasMethod methodsFor: 'transforming selectors' stamp: ''!
changesSourceCode: aSelector 
	
	^ self hasAliasForNew: aSelector
! !

!TaAliasMethod methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	^ (self hasAliasForNew: aSymbol) or: [ inner isLocalAliasSelector: aSymbol ]! !

!TaAliasMethod methodsFor: 'copying' stamp: ''!
copyTraitExpression
	^ self class alias: aliases to: inner
! !

!TaAliasMethod methodsFor: 'testing' stamp: ''!
hasAliasForOld: aSelector
	"Check if there is a alias for a old selector"
	^ aliases values includes: aSelector! !

!TaAliasMethod methodsFor: 'copying' stamp: ''!
copyWithoutTrait: aTrait
 
	^ self inner = aTrait ifTrue: [ TaEmptyComposition new ] ifFalse: [ self copy ]! !

!TaAliasMethod methodsFor: 'querying' stamp: ''!
reverseAlias: aSelector
	^ (inner reverseAlias: aSelector) , (aliases associations select: [ :a | a value = aSelector ] thenCollect: #key)! !

!TaAliasMethod methodsFor: 'accessing' stamp: ''!
selectors
	^ inner selectors , self existingAliasedSelectors. ! !

!TaAliasMethod class methodsFor: 'instance creation' stamp: ''!
alias:anArrayOfAssociations to: aTrait
	^ self new
		aliases: anArrayOfAssociations asDictionary;
		inner: aTrait;
		checkAssociations;
		yourself.! !

!TaClassCompositionElement commentStamp: ''!
I represent the root element in a TraitComposition.
I wrap a metaclass or classTrait to be used as a trait in a trait composition.!
!TaClassCompositionElement methodsFor: 'accessing' stamp: ''!
slots
	^ innerClass allSlots
		reject: [ :e | 
			(Trait slots , 
			TraitedClass allSlots) anySatisfy: [ :x | x name = e name ] ]
		! !

!TaClassCompositionElement methodsFor: 'accessing' stamp: ''!
methods
	"As I am representing a ClassTrait I have to filter the methods that are in all the class traits"
	| innerClassLocalMethods |
	innerClassLocalMethods := innerClass localMethods collect: [:each | each selector].
	^ super methods reject: [ :e | (innerClassLocalMethods includes: e selector) not and: [TraitedClass selectors anySatisfy: [ :x | x = e selector ]] ]! !

!TaClassCompositionElement methodsFor: 'printing' stamp: ''!
traitCompositionExpression
	
	^ innerClass instanceSide name , ' classTrait'! !

!TaClassCompositionElement methodsFor: 'accessing' stamp: ''!
selectors
	"As I am representing a ClassTrait I have to filter the methods that are in all the class traits"

	| innerClassLocalMethods |
	innerClassLocalMethods := innerClass localMethods collect: [:each | each selector].
	^ super selectors
		reject: [ :e | 
			(innerClassLocalMethods includes: e) not
				and: [ TraitedClass selectors includes: e ] ]! !

!TaCompositionElement commentStamp: ''!
I represent the root element in a TraitComposition.
I wrap a class or Trait to be used as a trait in a trait composition.!
!TaCompositionElement methodsFor: 'comparing' stamp: ''!
= aTrait
	^ (aTrait species = self species)
		ifTrue: [ aTrait innerClass = self innerClass ]
		ifFalse: [ ^ false ]! !

!TaCompositionElement methodsFor: 'transforming selectors' stamp: ''!
aliasSelector: selector
	^ selector = #initializeTalent
		ifTrue: [ self initializeSelectorForMe ]
		ifFalse: [ selector ]! !

!TaCompositionElement methodsFor: 'comparing' stamp: ''!
hash
	^ self innerClass hash! !

!TaCompositionElement methodsFor: '*TraitsV2-Compatibility' stamp: ''!
isTrait
	^ true! !

!TaCompositionElement methodsFor: 'querying' stamp: ''!
traitDefining: selector
	| newSelector |
	newSelector := self dealiasSelector: selector.
	
	^ innerClass localMethods
		detect: [ :e | e selector = newSelector ]
		ifFound: [ :e | self ]
		ifNone: [ innerClass traitComposition traitDefining: newSelector ]! !

!TaCompositionElement methodsFor: 'users' stamp: ''!
removeUser: aClass 
	"When a user is removed from me I propagate to the real Trait, as I am the root of the TraitComposition"	
	innerClass removeUser: aClass! !

!TaCompositionElement methodsFor: '*TraitsV2-Compatibility' stamp: ''!
includesElement: anElement
 
	^ self == anElement! !

!TaCompositionElement methodsFor: 'testing' stamp: ''!
isAliasSelector: aString 
	
	^ innerClass traitComposition isAliasSelector: aString! !

!TaCompositionElement methodsFor: 'accessing' stamp: ''!
methods
	^innerClass methods! !

!TaCompositionElement methodsFor: 'transforming selectors' stamp: ''!
dealiasSelector: oldSelector
	"Usefule to dealias the initialize selector. Used mostly with stateful Talents"

	^ oldSelector = self initializeSelectorForMe
		ifTrue: [ #initializeTalent ]
		ifFalse: [ oldSelector ]! !

!TaCompositionElement methodsFor: '*Ring-TraitsV2Support' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment
	| def |
	^ anRGEnvironment backend
		definitionFor: self
		ifAbsentRegister: [ | definingClass |
			definingClass := Smalltalk environment allBehaviors detect: [ :b | b traitComposition == self or: [b traitComposition includesElement: self]].

			def := RGTraitComposition named: self name parent: (definingClass asRingMinimalDefinitionIn: anRGEnvironment).

			def propertyNamed: #realObject put: self.

			"we need to set real object because we cannot simply identify the real object from the model data"
			def ]! !

!TaCompositionElement methodsFor: 'accessing' stamp: ''!
innerClass: anObject
	innerClass := anObject! !

!TaCompositionElement methodsFor: 'copying' stamp: ''!
copyWithoutTrait: aTrait 
	
	"If you want to remove a trait that is equivalent to me, I return an empty composition.
	If not a copy is returned"
	^ self = aTrait ifTrue: [ TaEmptyComposition new ] ifFalse: [ self copy ]! !

!TaCompositionElement methodsFor: 'querying' stamp: ''!
allTraits
	^ { innerClass } , innerClass traitComposition allTraits.! !

!TaCompositionElement methodsFor: 'accessing' stamp: ''!
selectors
	" I get all the selectors of the methods in this talent, if there is a #initializeTalent selector I rename it to #initializeTalent_NameOfTalent"

	| originals |
	originals := self methods collect: [:each | each selector].
	^ (originals includes: #initializeTalent)
		ifTrue: [ (originals reject: [ :e | e = #initializeTalent ]) copyWith: self initializeSelectorForMe ]
		ifFalse: [ originals ]! !

!TaCompositionElement methodsFor: 'printing' stamp: ''!
traitCompositionExpressionWithParens

	^ self traitCompositionExpression! !

!TaCompositionElement methodsFor: 'accessing' stamp: ''!
slots
	^ innerClass allSlots ! !

!TaCompositionElement methodsFor: 'accessing' stamp: ''!
innerClass
	^ innerClass! !

!TaCompositionElement methodsFor: '*TraitsV2-Compatibility' stamp: ''!
transformations
	^ { self innerClass }! !

!TaCompositionElement methodsFor: 'querying' stamp: ''!
traits
	^ { innerClass }! !

!TaCompositionElement methodsFor: 'accessing' stamp: ''!
classComposition

	^ TaClassCompositionElement for: innerClass class! !

!TaCompositionElement methodsFor: 'accessing' stamp: ''!
name
	^ innerClass name! !

!TaCompositionElement methodsFor: 'accessing' stamp: ''!
compiledMethodAt: selector
	| newSelector |
	newSelector := self dealiasSelector: selector.
	^ innerClass methods detect: [ :e | e selector = newSelector ] ifNone: [ innerClass traitComposition compiledMethodAt: newSelector ]! !

!TaCompositionElement methodsFor: 'users' stamp: ''!
addUser: aClass 
	"When a user is added to me I propagate to the real Trait, as I am the root of the TraitComposition"
	innerClass addUser: aClass! !

!TaCompositionElement methodsFor: 'testing' stamp: ''!
changesSourceCode: aSelector

	^ false 
	
! !

!TaCompositionElement methodsFor: 'copying' stamp: ''!
copyTraitExpression
	"I can be just shallowCopy, because I have only a reference to the real Trait"
	^ self shallowCopy.! !

!TaCompositionElement methodsFor: 'operations' stamp: ''!
without: anotherTrait
	^ self = anotherTrait ifTrue:[nil] ifFalse:[self].! !

!TaCompositionElement methodsFor: 'printing' stamp: ''!
traitCompositionExpression
	
	^ innerClass name! !

!TaCompositionElement methodsFor: 'transforming selectors' stamp: ''!
initializeSelectorForMe
	^ ('initializeTalent_' , self name) asSymbol! !

!TaCompositionElement methodsFor: 'testing' stamp: ''!
needsRecompilation: aSelector

	"We need to recompile if there is a supersend"

	^ (innerClass >> aSelector) sendsToSuper or: [ 
		  super needsRecompilation: aSelector ]! !

!TaCompositionElement methodsFor: 'querying' stamp: ''!
reverseAlias: aSelector
	
	^ #()! !

!TaCompositionElement class methodsFor: 'instance creation' stamp: ''!
for: aClass
	^ self new
		innerClass: aClass;
		yourself! !

!TaDeepAliasMethod commentStamp: ''!
I extend my superclass not only aliasing the method but also rewriting all the users of the method in my methods.
I am useful when you want to rename a method. You alias deeply with me and then remove it.

I implement the #@=  operator.!
!TaDeepAliasMethod methodsFor: 'rewriting' stamp: ''!
rewriteText: aSelector
	| stream |
	stream := WriteStream on: String new.
	stream nextPutAll: 'self '.

	aSelector numArgs == 0
		ifTrue: [ 
			stream nextPutAll: aSelector asString.
			^ stream contents ].

	aSelector keywords
		withIndexDo: [ :each :i | 
			stream
				nextPutAll: each;
				nextPutAll: ' ``@arg';
				nextPutAll: i printString;
				nextPut: Character space ].
	^ stream contents! !

!TaDeepAliasMethod methodsFor: 'accessing' stamp: ''!
sourceCodeAt: aSelector
	| originalSourceCode parseTree rewriter |
	originalSourceCode := super sourceCodeAt: aSelector.
	parseTree := RBParser parseMethod: originalSourceCode.
	rewriter := RBParseTreeRewriter new.
	
	self aliases
		associationsDo:
			[ :assoc | rewriter replace: (self rewriteText: assoc value) with: (self rewriteText: assoc key) ].
	
	^ (rewriter
			executeTree: parseTree;
			tree) formattedCode! !

!TaDeepAliasMethod methodsFor: 'testing' stamp: ''!
changesSourceCode: aSelector 
	
	^ true! !

!TaEmptyComposition commentStamp: ''!
I am an empty composition
I have no methods or slots :(!
!TaEmptyComposition methodsFor: 'testing' stamp: ''!
isEmpty
	^ true! !

!TaEmptyComposition methodsFor: 'comparing' stamp: ''!
= anotherTrait
	^ self class = anotherTrait class! !

!TaEmptyComposition methodsFor: 'comparing' stamp: ''!
hash
	^ 1! !

!TaEmptyComposition methodsFor: 'querying' stamp: ''!
traitDefining: aSelector
	NotFound signalFor: aSelector! !

!TaEmptyComposition methodsFor: 'users' stamp: ''!
removeUser: aClass 

	"Nothing to do.... I am empty"! !

!TaEmptyComposition methodsFor: 'operations' stamp: ''!
addToSequence: sequence
	"I am empty I will not add my self to anybody"
	^ sequence! !

!TaEmptyComposition methodsFor: '*TraitsV2-Compatibility' stamp: ''!
includesElement: aTaCompositionElement 
	^ false! !

!TaEmptyComposition methodsFor: 'testing' stamp: ''!
isAliasSelector: aString 
	
	^ false! !

!TaEmptyComposition methodsFor: 'accessing' stamp: ''!
methods
	^ #()! !

!TaEmptyComposition methodsFor: 'operations' stamp: ''!
@ anAssociation
	self error:'Could not perform on empty composition'! !

!TaEmptyComposition methodsFor: 'operations' stamp: ''!
- anArrayOfSelectors
	self error:'Could not remove a selector from an empty composition'.! !

!TaEmptyComposition methodsFor: 'copying' stamp: ''!
copyWithoutTrait: aTrait
	^ self
	! !

!TaEmptyComposition methodsFor: 'querying' stamp: ''!
allTraits
	^ #()! !

!TaEmptyComposition methodsFor: 'accessing' stamp: ''!
selectors
	^#()! !

!TaEmptyComposition methodsFor: 'printing' stamp: ''!
traitCompositionExpressionWithParens
	^ self traitCompositionExpression! !

!TaEmptyComposition methodsFor: 'accessing' stamp: ''!
slots
	^ #()! !

!TaEmptyComposition methodsFor: '*TraitsV2-Compatibility' stamp: ''!
transformations
	^ #()! !

!TaEmptyComposition methodsFor: 'operations' stamp: ''!
@@ anAssociation
	self error:'Could not perform on empty composition'! !

!TaEmptyComposition methodsFor: 'querying' stamp: ''!
traits
	^ #()! !

!TaEmptyComposition methodsFor: 'accessing' stamp: ''!
compiledMethodAt: aSelector
	NotFound signalFor: aSelector! !

!TaEmptyComposition methodsFor: 'accessing' stamp: ''!
classComposition
	^ self class new.! !

!TaEmptyComposition methodsFor: 'operations' stamp: ''!
@= anAssociation
	self error:'Could not perform on empty composition'! !

!TaEmptyComposition methodsFor: 'operations' stamp: ''!
, anotherTrait
	^ anotherTrait! !

!TaEmptyComposition methodsFor: 'users' stamp: ''!
addUser: aClass 

	"Nothing to do.... I am empty"! !

!TaEmptyComposition methodsFor: 'testing' stamp: ''!
changesSourceCode: aString 
	
	^ false! !

!TaEmptyComposition methodsFor: 'copying' stamp: ''!
copyTraitExpression
	^ self
	! !

!TaEmptyComposition methodsFor: 'querying' stamp: ''!
reverseAlias: aSelector
	
	^ #()! !

!TaEmptyComposition methodsFor: 'printing' stamp: ''!
traitCompositionExpression
	
	^ '{}'! !

!TaPrecedenceComposition methodsFor: 'accessing' stamp: ''!
memberForSelector: aSelector

	"I look first in the prefered trait if not in the other member"
	((preferedTrait selectors includes: aSelector) and: [ (preferedTrait compiledMethodAt: aSelector) isRequired not ]) ifTrue: [ ^ preferedTrait ].
	
	^ super memberForSelector: aSelector.
! !

!TaPrecedenceComposition methodsFor: 'accessing' stamp: ''!
preferedTrait
	^ preferedTrait! !

!TaPrecedenceComposition methodsFor: 'accessing' stamp: ''!
classComposition
	^ (self class withAll: (members collect: [:each | each classComposition]))
		preferedTrait: preferedTrait classComposition;
		yourself! !

!TaPrecedenceComposition methodsFor: 'accessing' stamp: ''!
copyTraitExpression

	^ (self class withAll: (members collect: [:each | each copyTraitExpression]))
		preferedTrait: preferedTrait copyTraitExpression;
		yourself! !

!TaPrecedenceComposition methodsFor: 'accessing' stamp: ''!
traitCompositionExpression
		
	^  '(' , (super traitCompositionExpression) , ' withPrecedenceOf: ' , preferedTrait traitCompositionExpression , ')'! !

!TaPrecedenceComposition methodsFor: 'accessing' stamp: ''!
copyWithoutTrait: aTrait
	| newMembers |

	newMembers := members collect: [ :e | e copyWithoutTrait: aTrait ] thenReject: #isEmpty.

	newMembers ifEmpty: [ ^ (self class withAll: newMembers) ].	

	^ (self class withAll: newMembers)
		preferedTrait: (preferedTrait copyWithoutTrait: aTrait);
		yourself
	
! !

!TaPrecedenceComposition methodsFor: 'testing' stamp: ''!
isConflictingSelector: aSelector

	"If the method is in the preferedTrait it is not a conflict"
	
	(preferedTrait methods anySatisfy: [ :each | each selector = aSelector and: [ each isRequired not ] ])
		ifTrue: [ ^ false ].
		
	^ super isConflictingSelector: aSelector.! !

!TaPrecedenceComposition methodsFor: 'accessing' stamp: ''!
preferedTrait: anObject
	preferedTrait := anObject! !

!TaRemoveMethod commentStamp: ''!
I can remove a method from a trait.
I implement the #- operator.!
!TaRemoveMethod methodsFor: 'accessing' stamp: ''!
removedSelectors
	^ removedSelectors! !

!TaRemoveMethod methodsFor: 'querying' stamp: ''!
traitDefining: aSelector
	(removedSelectors includes: aSelector ) ifTrue:[NotFound signalFor: aSelector].
	^ inner traitDefining: aSelector! !

!TaRemoveMethod methodsFor: '*TraitsV2-Compatibility' stamp: ''!
isTraitExclusion
	^ true! !

!TaRemoveMethod methodsFor: 'accessing' stamp: ''!
compiledMethodAt: aSelector
	(removedSelectors includes: aSelector ) ifTrue:[NotFound signalFor: aSelector].
	^ inner compiledMethodAt: aSelector.! !

!TaRemoveMethod methodsFor: 'accessing' stamp: ''!
removedSelectors: anObject
	removedSelectors := anObject! !

!TaRemoveMethod methodsFor: 'accessing' stamp: ''!
methods
	^ inner methods reject: [ :e | removedSelectors includes: e selector ]! !

!TaRemoveMethod methodsFor: 'copying' stamp: ''!
copyTraitExpression
	^ self class remove: removedSelectors to: inner! !

!TaRemoveMethod methodsFor: '*Ring-TraitsV2Support' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		| definingClass def |
	
		definingClass := Smalltalk environment allBehaviors detect: [ :b | b traitComposition transformations includes: self ].

		def := RGTraitExclusion
			parent: (definingClass traitComposition asRingMinimalDefinitionIn: anRGEnvironment).
			
		"we need to set real object because we cannot simply identify the real object from the model data"
		def propertyNamed: #realObject put: self.
		def ]! !

!TaRemoveMethod methodsFor: 'printing' stamp: ''!
traitCompositionExpression
	^ String
		streamContents: [ :s | 
			s
				nextPutAll: self inner traitCompositionExpressionWithParens;
				nextPutAll: ' - '.
			removedSelectors printAsSelfEvaluatingFormOn: s ]! !

!TaRemoveMethod methodsFor: '*TraitsV2-Compatibility' stamp: ''!
exclusions
	"For compatibility, does not use it!!!!!!"
	^ removedSelectors! !

!TaRemoveMethod methodsFor: 'accessing' stamp: ''!
selectors
	^ inner selectors reject: [ :e | removedSelectors includes: e ]! !

!TaRemoveMethod class methodsFor: 'instance creation' stamp: ''!
remove: anArrayOfSelectors to: aTrait
	^ self new
		removedSelectors: anArrayOfSelectors;
		inner: aTrait;
		yourself! !

!TaRemoveSlot commentStamp: ''!
I remove a Slot from a trait.
I implement the #--  operator.
!
!TaRemoveSlot methodsFor: 'accessing' stamp: ''!
removedSlots: anObject
	"we support both a symbol and an array of symbols"
	removedSlots := anObject isSymbol
		                ifTrue: [ { anObject } ]
		                ifFalse: [ anObject ]! !

!TaRemoveSlot methodsFor: 'accessing' stamp: ''!
slots
	^ inner slots reject: [ :e | removedSlots includes: e name ]! !

!TaRemoveSlot methodsFor: 'accessing' stamp: ''!
removedSlots

	^ removedSlots! !

!TaRemoveSlot methodsFor: 'copying' stamp: ''!
copyTraitExpression
	^ self class remove: removedSlots from: inner! !

!TaRemoveSlot methodsFor: 'printing' stamp: ''!
traitCompositionExpression

	removedSlots size = 1
		           ifTrue: [^ self inner traitCompositionExpressionWithParens , ' -- ' , removedSlots first printString].
			
	^ String streamContents: [ :s | 
		  s
			  nextPutAll: self inner traitCompositionExpressionWithParens;
			  nextPutAll: ' -- '.
		  removedSlots printAsSelfEvaluatingFormOn: s ]! !

!TaRemoveSlot class methodsFor: 'instance creation' stamp: ''!
remove: anArrayOfSlotNames from: aTrait
	^ self new
		removedSlots: anArrayOfSlotNames;
		inner: aTrait;
		yourself.! !

!TaRenameSlot commentStamp: ''!
I am able to rename a slot in a trait, so it does not conflict with the ones in the class.
Also I rename all the uses of this slot in my methods.
I implement the #>> operator in traits.!
!TaRenameSlot methodsFor: 'accessing' stamp: ''!
slots

	^ inner slots collect: [ :slot | 
		  (renames asDictionary includesKey: slot name)
			  ifTrue: [ 
				  (TaRenamedSlotWrapper for: slot) name: (renames asDictionary at: slot name) ]
			  ifFalse: [ slot ] ]! !

!TaRenameSlot methodsFor: 'accessing' stamp: ''!
sourceCodeAt: aSelector
	| originalSourceCode parseTree rewriter |
	originalSourceCode := super sourceCodeAt: aSelector.

	parseTree := RBParser parseMethod: originalSourceCode.
	rewriter := RBParseTreeRewriter new.
	
	renames do: [:rename |
		rewriter replace: rename key asString with: rename value asString ].
	
	^(rewriter	
		executeTree: parseTree;
		tree) formattedCode.! !

!TaRenameSlot methodsFor: 'copying' stamp: ''!
copyTraitExpression
	^ self class rename: renames on: inner! !

!TaRenameSlot methodsFor: 'accessing' stamp: ''!
renames

	^ renames! !

!TaRenameSlot methodsFor: 'accessing' stamp: ''!
renames: anObject

	renames := anObject! !

!TaRenameSlot methodsFor: 'printing' stamp: ''!
traitCompositionExpression
	
	^ self inner traitCompositionExpressionWithParens , ' @@ ' , renames printString! !

!TaRenameSlot class methodsFor: 'instance creation' stamp: ''!
from:oldName to: newName on: aTrait
	^ self new 
		oldName: oldName;
		newName: newName;
		inner: aTrait;
		yourself.! !

!TaRenameSlot class methodsFor: 'instance creation' stamp: ''!
rename: anArrayOfAssociations on: aTrait
	^ self new 
		renames: anArrayOfAssociations;
		inner: aTrait;
		yourself.! !

!TaRenamedSlotWrapper commentStamp: ''!
When renaming Slots in a trait composition, we want to give the trait a new name but else keep the orginal semantics.

This wrapper does exactly that: as a Slot subclass, it has a name. It forwards anything else to the original slot as defined
in the trait.!
!TaRenamedSlotWrapper methodsFor: 'accessing' stamp: ''!
originalSlot

	^ originalSlot! !

!TaRenamedSlotWrapper methodsFor: 'accessing' stamp: ''!
index
	^ originalSlot index! !

!TaRenamedSlotWrapper methodsFor: 'meta-object-protocol' stamp: ''!
wantsInitialization
	^ originalSlot wantsInitialization! !

!TaRenamedSlotWrapper methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	^ originalSlot read: anObject! !

!TaRenamedSlotWrapper methodsFor: 'printing' stamp: ''!
printOn: aStream
	originalSlot printOn: aStream! !

!TaRenamedSlotWrapper methodsFor: 'testing' stamp: ''!
isVirtual
	^originalSlot isVirtual! !

!TaRenamedSlotWrapper methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
	^ originalSlot write: aValue to: anObject! !

!TaRenamedSlotWrapper methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	originalSlot emitValue: aMethodBuilder! !

!TaRenamedSlotWrapper methodsFor: 'code generation' stamp: ''!
emitStore: aMethodBuilder
	originalSlot emitStore: aMethodBuilder! !

!TaRenamedSlotWrapper methodsFor: 'accessing' stamp: ''!
index: anInteger
	originalSlot index: anInteger! !

!TaRenamedSlotWrapper methodsFor: 'accessing' stamp: ''!
originalSlot: anObject

	originalSlot := anObject! !

!TaRenamedSlotWrapper methodsFor: 'testing' stamp: ''!
isVisible
	^originalSlot isVisible! !

!TaRenamedSlotWrapper class methodsFor: 'instance creation' stamp: ''!
for: aSlot
	^self new originalSlot: aSlot! !

!TaSequence commentStamp: ''!
I represent a sequence of traits in a trait composition.
When two traits are operated with + I appear.
The methods and slots are the union of my inner members.
I solve when there are conflicts.!
!TaSequence methodsFor: 'operations' stamp: ''!
+ anotherTrait
	^ anotherTrait asTraitComposition addToSequence: self copyTraitExpression.
	! !

!TaSequence methodsFor: 'accessing' stamp: ''!
categoryOfMethod: method withSelector: selector
	| categories |
	
	categories := (self methods select: [ :e | e selector = selector ] thenCollect: #category) asSet.

	^ categories size = 1
		ifTrue: [ ^ categories anyOne ]
		ifFalse: [ Protocol ambiguous ]! !

!TaSequence methodsFor: 'comparing' stamp: ''!
= anotherTrait
	^ anotherTrait species = self species and: [ self members = anotherTrait members ]! !

!TaSequence methodsFor: 'transforming selectors' stamp: ''!
aliasSelector: aSelector
	^ members inject: aSelector into:[:acc :each | each aliasSelector: acc]. ! !

!TaSequence methodsFor: 'comparing' stamp: ''!
hash
	^ self class hash! !

!TaSequence methodsFor: 'accessing' stamp: ''!
sourceCodeAt: selector
	(self isConflictingSelector: selector) 
		ifTrue: [ ^ self sourceCodeForConflictFor: selector ].

	^ (self memberForSelector: selector) sourceCodeAt: selector! !

!TaSequence methodsFor: 'accessing' stamp: ''!
selectorForConflict: selector
	| args keywords |
	
	"I calculate the selector to use when there is a conflict. 
	I have to reimplement a similar code that is in RBParser, as the parser cannot be available when this code is executed in a bootstraped image"
	
	args := selector numArgs.

	args = 0
		ifTrue: [ ^ selector ].

	selector isBinary ifTrue: [ ^ String streamContents: 
		[ :s | s nextPutAll: selector; nextPutAll: ' anObject' ] ].

	^ String
		streamContents: [ :stream | 
					keywords := selector keywords.
					1 to: args do: [ :argumentNumber | 
						stream
							nextPutAll: (keywords at: argumentNumber);
							space;
							nextPutAll: 'arg';
							nextPutAll: argumentNumber asString;
							space ] ] ! !

!TaSequence methodsFor: 'querying' stamp: ''!
traitDefining: aSelector
	^ (self memberForSelector: aSelector) traitDefining: aSelector! !

!TaSequence methodsFor: 'validations' stamp: ''!
validateSlots: anElement
	self slots
		do: [ :e | 
			anElement slots
				do: [ :other | 
					(e name = other name and: [ e definingClass ~= other definingClass ])
						ifTrue: [ self error: 'The added trait duplicates an existing slot ' , e name printString , '. Duplication between ' , e definingClass asString , ' and ' , other definingClass asString ] ] ]! !

!TaSequence methodsFor: 'accessing' stamp: ''!
sourceCodeForConflictFor: selector

	"I return the method body for a conflicting selector"

	^ String
		streamContents: [ :s | 
			s
				nextPutAll: (self selectorForConflict: selector);
				cr;
				tab;
				nextPutAll: 'self traitConflict' ]! !

!TaSequence methodsFor: 'users' stamp: ''!
removeUser: aClass 
	"I propagate to my members the removal of an user"
	self members do: [ :m | m removeUser: aClass] ! !

!TaSequence methodsFor: 'operations' stamp: ''!
addToSequence: sequence
	"I add my self to another sequence. When adding I add all my members, not myself"
	members do:[:e |sequence addMember: e].
	^ sequence
! !

!TaSequence methodsFor: '*TraitsV2-Compatibility' stamp: ''!
includesElement: anElement 
	^ members anySatisfy: [ :e | e includesElement: anElement ]! !

!TaSequence methodsFor: 'operations' stamp: ''!
members
	^ members! !

!TaSequence methodsFor: 'accessing' stamp: ''!
memberForSelector: aSelector

	"I return the member that defines a given selector.
	I first look for a valid member, if not, I will return the first"
	^ members
		detect:
			[ :e | (e selectors includes: aSelector) and: [ (e compiledMethodAt: aSelector) isRequired not ] ]
		ifNone: [ members detect: [ :e | e selectors includes: aSelector ] ]! !

!TaSequence methodsFor: 'validations' stamp: ''!
validateMethods: aTrait
	| newMethods myMethods|
	myMethods := self methods.
	newMethods := aTrait methods reject: [ :e | myMethods includes: e ].

	(self selectors
		noneSatisfy: [ :e | newMethods anySatisfy: [ :x | x selector = e ] ])
		ifFalse: [ self error: 'The added trait duplicates an existing selector' ]! !

!TaSequence methodsFor: 'testing' stamp: ''!
isAliasSelector: aSelector
 
	^ self members anySatisfy: [ :e | e isAliasSelector: aSelector ]! !

!TaSequence methodsFor: 'operations' stamp: ''!
initializeObject: anObject
	members do: [ :e | e initializeObject: anObject ]! !

!TaSequence methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	^ members anySatisfy: [ :e | e isLocalAliasSelector: aSymbol ]! !

!TaSequence methodsFor: 'accessing' stamp: ''!
methods
	^ members flatCollect: #methods! !

!TaSequence methodsFor: 'precedence' stamp: ''!
withPrecedenceOf: aTrait 
	
	| aTraitComposition |
	aTraitComposition := aTrait asTraitComposition.
	
	(members includes: aTraitComposition)
		ifFalse: [ self error: 'A trait cannot be marked with precedence if it is not in the sequence' ].
		
	^ (TaPrecedenceComposition withAll: members)
			preferedTrait: aTraitComposition;
			yourself! !

!TaSequence methodsFor: 'copying' stamp: ''!
copyWithoutTrait: aTrait
	| newMembers |

	newMembers := members collect: [ :e | e copyWithoutTrait: aTrait ] thenReject: #isEmpty.

	^ self class withAll: newMembers
	
! !

!TaSequence methodsFor: 'querying' stamp: ''!
allTraits
	^ members flatCollect: #allTraits! !

!TaSequence methodsFor: 'accessing' stamp: ''!
selectors
	^ members flatCollect: #selectors! !

!TaSequence methodsFor: 'querying' stamp: ''!
originSelectorOf: aSelector

	^ (self traitDefining: aSelector ifNone: [ ^aSelector ]) originSelectorOf: aSelector
! !

!TaSequence methodsFor: 'adding' stamp: ''!
addMember: aTrait
	"Adds a single trait to me"
	self validateDuplications: aTrait.
	self validateSlots: aTrait.
	
	members add: aTrait! !

!TaSequence methodsFor: 'accessing' stamp: ''!
slots
	^ (members flatCollect: #slots)
		removeDuplicates;
		yourself! !

!TaSequence methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	members := OrderedCollection new.! !

!TaSequence methodsFor: '*TraitsV2-Compatibility' stamp: ''!
transformations
	^ members flatCollect: #transformations! !

!TaSequence methodsFor: 'querying' stamp: ''!
traits
	^ members flatCollect: #traits! !

!TaSequence methodsFor: 'accessing' stamp: ''!
classComposition
	^ self class withAll: (members collect: [:each | each classComposition])! !

!TaSequence methodsFor: 'accessing' stamp: ''!
name
	^ '_' join: (members collect: [:each | each name]) ! !

!TaSequence methodsFor: 'accessing' stamp: ''!
compiledMethodAt: aSelector
	
	^ (self memberForSelector: aSelector) compiledMethodAt: aSelector! !

!TaSequence methodsFor: 'operations' stamp: ''!
, anotherTrait
	^ anotherTrait addToSequence: self copy.
! !

!TaSequence methodsFor: 'users' stamp: ''!
addUser: aClass 
	"I propagate the users to all my members"
	members do: [ :m | m addUser: aClass ]! !

!TaSequence methodsFor: 'testing' stamp: ''!
changesSourceCode: aSelector
	"If the selector has conflicts it should be recompiled"
	^ (self isConflictingSelector: aSelector)
		or: [ self members anySatisfy: [ :e | e changesSourceCode: aSelector ] ]! !

!TaSequence methodsFor: 'validations' stamp: ''!
validateDuplications: anElement
	(members noneSatisfy: [ :e | e = anElement ])
		ifFalse:[self error:'Could not include the same traits twice'].! !

!TaSequence methodsFor: 'adding' stamp: ''!
addAll: aCollection
	"Adds all the members in the othe sequence"
	aCollection do:[:e | self addMember: e].! !

!TaSequence methodsFor: 'operations' stamp: ''!
without: aTrait
	| newMembers |
	newMembers := members collect:[:e | e without: aTrait] thenSelect:#isNotNil.
	
	newMembers ifEmpty: [ ^ nil ].
	
	^ self class withAll: newMembers.! !

!TaSequence methodsFor: 'querying' stamp: ''!
reverseAlias: aSelector
	
	^ self members flatCollect: [ :e | e reverseAlias: aSelector ]! !

!TaSequence methodsFor: 'printing' stamp: ''!
traitCompositionExpression
	self isEmpty
		ifTrue: [ ^ '{}' ].

	^ {members first traitCompositionExpression}
		, (members allButFirst collect: [:each | each traitCompositionExpressionWithParens]) joinUsing: ' + '! !

!TaSequence methodsFor: 'copying' stamp: ''!
copyTraitExpression
	^ self class withAll: (members collect: [:each | each copyTraitExpression])! !

!TaSequence methodsFor: 'testing' stamp: ''!
isConflictingSelector: aSelector
	"I test if a given selector is defined in more than one of my members.
	Two or more members can have the same method. 
	They are a conflict if these members came from different origins or if they are different.
	If they came from the same origin, it is not a conflict. Because solving one or the other is the same result."

	| possibleConflicts |
	possibleConflicts := self methods select: [ :each | each selector = aSelector and: [ each isRequired not ] ].
	possibleConflicts size = 1 ifTrue: [ ^ false ].
	
	^ (possibleConflicts collect: [:each | each originMethod ] as: Set) size > 1.! !

!TaSequence class methodsFor: 'instance creation' stamp: ''!
withAll: initialMembers

	initialMembers ifEmpty: [ ^ TaEmptyComposition new ].

	^ self new 
		addAll: initialMembers;
		yourself.! !

!TaSequence class methodsFor: 'instance creation' stamp: ''!
with: initialValue
	^ self new 
		addMember: initialValue;
		yourself.! !

!TaSingleComposition commentStamp: ''!
I am the superclass of all the operations that modifies a single trait.!
!TaSingleComposition methodsFor: 'comparing' stamp: ''!
= another
	^ (another class = self class) and: [ another inner = inner ]! !

!TaSingleComposition methodsFor: 'transforming selectors' stamp: ''!
aliasSelector: aSelector
	^ inner aliasSelector: aSelector.! !

!TaSingleComposition methodsFor: 'comparing' stamp: ''!
hash
	^ inner hash! !

!TaSingleComposition methodsFor: 'querying' stamp: ''!
traitDefining: selector
	^ inner traitDefining: selector! !

!TaSingleComposition methodsFor: 'users' stamp: ''!
removeUser: aClass 
	"I propagate to the inner trait"
	inner removeUser: aClass! !

!TaSingleComposition methodsFor: '*TraitsV2-Compatibility' stamp: ''!
includesElement: anElement 
	^ self == anElement or: [ inner == anElement ]! !

!TaSingleComposition methodsFor: 'accessing' stamp: ''!
inner
	^ inner! !

!TaSingleComposition methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	^ inner isAliasSelector: aSymbol ! !

!TaSingleComposition methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	^ inner isLocalAliasSelector: aSymbol ! !

!TaSingleComposition methodsFor: 'accessing' stamp: ''!
methods
	^ inner methods! !

!TaSingleComposition methodsFor: 'copying' stamp: ''!
copyWithoutTrait: aTrait
	(self = aTrait or: [ inner = aTrait ])
		ifTrue: [ ^ inner copyWithoutTrait: aTrait ].
		
	^ self copy! !

!TaSingleComposition methodsFor: 'querying' stamp: ''!
allTraits
	^ inner allTraits! !

!TaSingleComposition methodsFor: 'accessing' stamp: ''!
selectors
	^ inner selectors! !

!TaSingleComposition methodsFor: 'accessing' stamp: ''!
inner: anObject
	inner := anObject! !

!TaSingleComposition methodsFor: 'querying' stamp: ''!
originSelectorOf: aSelector

	^ inner originSelectorOf: aSelector
! !

!TaSingleComposition methodsFor: 'accessing' stamp: ''!
slots
	^ inner slots. ! !

!TaSingleComposition methodsFor: '*TraitsV2-Compatibility' stamp: ''!
transformations
	^ { self }! !

!TaSingleComposition methodsFor: 'querying' stamp: ''!
traits
	^ inner traits! !

!TaSingleComposition methodsFor: '*TraitsV2-Compatibility' stamp: ''!
subject
	"Do not use... do not access directly to the subject. Kept for compatibility"
	^ inner! !

!TaSingleComposition methodsFor: 'accessing' stamp: ''!
compiledMethodAt: aSelector
	^ inner compiledMethodAt: aSelector.! !

!TaSingleComposition methodsFor: 'accessing' stamp: ''!
classComposition
	^ inner classComposition! !

!TaSingleComposition methodsFor: 'accessing' stamp: ''!
name 
	^ inner name! !

!TaSingleComposition methodsFor: 'users' stamp: ''!
addUser: aClass 
	"I propagate to the inner trait"
	inner addUser: aClass! !

!TaSingleComposition methodsFor: 'testing' stamp: ''!
changesSourceCode: aSelector 
	
	^ inner changesSourceCode: aSelector! !

!TaSingleComposition methodsFor: 'transforming selectors' stamp: ''!
initializeSelectorForMe
	^ inner initializeSelectorForMe.! !

!TaSingleComposition methodsFor: 'operations' stamp: ''!
without: anotherTrait
	"Returns a single composition without the trait passed as parameter"
	^ (anotherTrait = self or: [ inner = anotherTrait ])
		ifTrue: [ nil ]
		ifFalse: [ self ]! !

!TaSingleComposition methodsFor: 'querying' stamp: ''!
reverseAlias: aSelector
	
	^ inner reverseAlias: aSelector! !

!TabAction commentStamp: ''!
I am a data object representing an action associated to a tab.

I contains
	- an action to be performed when clicked
	- an icon to be rendered
	- a label to add indication about what I am supposed to do!
!TabAction methodsFor: 'accessing' stamp: ''!
action: anObject

	action := anObject.
	icon on: #click send: #value to: action! !

!TabAction methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	icon := ImageMorph new! !

!TabAction methodsFor: 'accessing' stamp: ''!
label: aLabel

	label := aLabel.
	icon setBalloonText: label maxLineLength: 100! !

!TabAction methodsFor: 'accessing' stamp: ''!
action
	^ action! !

!TabAction methodsFor: 'accessing' stamp: ''!
icon
	^ icon! !

!TabAction methodsFor: 'accessing' stamp: ''!
icon: aForm

	icon image: aForm.
	label 
		ifNotNil: [ icon setBalloonText: label maxLineLength: 100 ].
	action ifNotNil: [ icon on: #click send: #value to: action ]! !

!TabAction methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!TabAction class methodsFor: 'instance creation' stamp: ''!
action: action icon: icon label: label

	^ self new
		action: action;
		icon: icon;
		label: label;
		yourself! !

!TabActionButtonMorph commentStamp: ''!
I am a multi state button supporting icon.

I am used to render tab actions!
!TabActionButtonMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas

	super drawOn: aCanvas.
	icon ifNil: [ ^ self ].
	icon form ifNil: [ ^ self ].
	aCanvas
		translucentImage: icon form
		at: self topLeft! !

!TabActionButtonMorph methodsFor: 'instance creation' stamp: ''!
forAction: anAction
	| baseColor |
	
	baseColor := self theme baseColor.
	self extent: anAction icon extent.
	
	self activeEnabledNotOverUpFillStyle: baseColor.
	
	self activeDisabledNotOverUpFillStyle: (self theme buttonDisabledFillStyleFor: self).
	self passiveEnabledNotOverUpFillStyle: baseColor.
	self passiveDisabledNotOverUpFillStyle: baseColor.
	
	self
		activeEnabledOverUpFillStyle: (self theme buttonMouseOverFillStyleFor: self);
		passiveEnabledOverUpFillStyle: (self theme buttonMouseOverFillStyleFor: self).
	
	self
		activeEnabledOverDownFillStyle: (self theme buttonPressedFillStyleFor: self);
		passiveEnabledOverDownFillStyle: (self theme buttonPressedFillStyleFor: self);
		addUpAction: [ anAction action value ];
		setBalloonText: anAction label;
		extent: 16@16.
		
	icon := anAction icon.
		
	^ self! !

!TabActionButtonMorph methodsFor: 'accessing' stamp: ''!
icon: anObject
	
	icon := anObject! !

!TabActionButtonMorph class methodsFor: 'instance creation' stamp: ''!
forAction: anAction

	^ self new
		forAction: anAction;
		yourself! !

!TabBarMorph commentStamp: ''!
I am a bar gathering tabs. I am the one managing the selected tab and related bahavior (unselecting the last one, updating the layout to make the selected tab on top of the other)!
!TabBarMorph methodsFor: 'protocol' stamp: ''!
tabs: aCollection

	tabs do: [ :e | e silentlySelected: false ].
	tabs := aCollection.
	selectionHistory removeAll.
	
	aCollection do: [ :aTab |
		self registerActionsFor: aTab.
		self selectedTab ifNil: [ aTab selected: true ].
		self addFirstInHistory: aTab ].
	
	self adjustLayout.
	self changed.
	self triggerEvent: #tabsChanged! !

!TabBarMorph methodsFor: 'accessing' stamp: ''!
tabs
	^ tabs! !

!TabBarMorph methodsFor: 'private - constants' stamp: ''!
actionOffset
	^ 4 * self displayScaleFactor! !

!TabBarMorph methodsFor: 'private - constants' stamp: ''!
menuButtonHeight
	^ 16 * self displayScaleFactor! !

!TabBarMorph methodsFor: 'private - history' stamp: ''!
addFirstInHistory: aTab

	self removeFromHistory: aTab.
	selectionHistory addFirst: aTab! !

!TabBarMorph methodsFor: 'drawing' stamp: ''!
selectedColor
	^ self theme selectionColor! !

!TabBarMorph methodsFor: 'protocol' stamp: ''!
addTab: aTab
	
	(tabs includes: aTab) ifTrue: [ ^ self ].

	tabs add: aTab.

	self registerActionsFor: aTab.
	self selectedTab ifNil: [ aTab selected: true ].
	self addFirstInHistory: aTab.
	self adjustLayout.
	self changed.
	self triggerEvent: #tabAdded with: aTab! !

!TabBarMorph methodsFor: 'private - history' stamp: ''!
removeFromHistory: aTab

	selectionHistory remove: aTab ifAbsent: [  ].! !

!TabBarMorph methodsFor: 'initialization' stamp: ''!
addMenuButton
	| topOffset rightOffset |
	
	rightOffset := self actionOffset.
	topOffset := (self height - 16 * self displayScaleFactor) // 2.
	self
		addMorph: menuButton
		fullFrame:
			(LayoutFrame identity
				bottomFraction: 0;
				leftFraction: 1;
				rightOffset: rightOffset negated;
				leftOffset: rightOffset negated - self menuButtonWidth;
				topOffset: topOffset;
				bottomOffset: topOffset + self menuButtonHeight)! !

!TabBarMorph methodsFor: 'drawing' stamp: ''!
drawLinesOn: canvas
	"This method draws the line below the tab-label, to make it look as 'behind' (when there is one 
	 selected, it draws that line except on the corresponding selected tab."
	self selectedTab 
		ifNotNil: [ self drawWithSelectionOn: canvas ]	
		ifNil: [ self drawWithoutSelectedOn: canvas ]! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
tabEmptyContents: aTab

	self selectedTab = aTab ifFalse: [ ^ self ].

	(selectionHistory last: numberOfSelectedTabs) do: [ :each | each == aTab ifFalse: [ each silentlySelected: false ] ].	
	numberOfSelectedTabs := 1.
	self adjustLayout.
	
	self triggerEvent: #tabEmptyContents with: aTab! !

!TabBarMorph methodsFor: 'initialization' stamp: ''!
themeChanged
	super themeChanged.
	tabs do:#themeChanged.! !

!TabBarMorph methodsFor: 'protocol' stamp: ''!
selectLastTab
	
	tabs ifEmpty: [ ^self ].
	tabs last selected: true! !

!TabBarMorph methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: canvas
	super drawSubmorphsOn: canvas.
	self drawLinesOn: canvas! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
removeTab: aTab
	| nextSelection |

	(aTab selected and: [selectionHistory size > 1])
		ifTrue: [ 
			nextSelection := selectionHistory at: selectionHistory size - 1.
			nextSelection selected: true ].
		
	self removeFromHistory: aTab.
	tabs remove: aTab.

	self adjustLayout! !

!TabBarMorph methodsFor: 'private' stamp: ''!
needSpaceForActions 
	| tab |
	
	tab := self selectedTab.
	tab ifNil: [ ^ false ].

	^ self selectedTab hasMenu or: [ self selectedTab hasActions ]! !

!TabBarMorph methodsFor: 'protocol' stamp: ''!
delete

	super delete.
	self triggerEvent: #barDeleted with: self! !

!TabBarMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	tabs := OrderedCollection new.
	selectionHistory := OrderedCollection new.
	menuButton := self createMenuButton.
	numberOfSelectedTabs := 1.
	
	self changeProportionalLayout.
	self addMenuButton.! !

!TabBarMorph methodsFor: 'menu' stamp: ''!
popUpMenu
	| menu |
	
	menu := self selectedTab menu.
	menu popUpAt: menuButton bottomRight forHand: self activeHand in: self currentWorld! !

!TabBarMorph methodsFor: 'protocol' stamp: ''!
orderedSelectedTabs
	
	^ tabs select: [ :e | e selected ]! !

!TabBarMorph methodsFor: 'protocol' stamp: ''!
selectedTabs

	^ (selectionHistory last: numberOfSelectedTabs) reversed! !

!TabBarMorph methodsFor: 'protocol' stamp: ''!
isMultiSelection

	^ numberOfSelectedTabs > 1! !

!TabBarMorph methodsFor: 'private' stamp: ''!
extraSpace

	^ tabs max: [ :each | each extraSpaceForActions ]! !

!TabBarMorph methodsFor: 'protocol' stamp: ''!
canBeClosed

	^ tabs allSatisfy: [ :tab | tab closeable ]! !

!TabBarMorph methodsFor: 'protocol' stamp: ''!
closeAllTabs

	tabs copy do: [ :tab | tab close ]! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
tabRemovedFromSelection: aTab

	numberOfSelectedTabs == 1 ifTrue: [ ^ self ].
	numberOfSelectedTabs := numberOfSelectedTabs - 1.

	"Insert the remove tab just before the selected ones to preserve order"
	selectionHistory remove: aTab.
	selectionHistory add: aTab afterIndex: (selectionHistory size - numberOfSelectedTabs).
	
	aTab silentlySelected: false.
	self adjustLayout.
	
	self triggerEvent: #tabRemovedFromSelection with: aTab! !

!TabBarMorph methodsFor: 'private' stamp: ''!
createActionButtonFor: anAction

	^ TabActionButtonMorph forAction: anAction! !

!TabBarMorph methodsFor: 'accessing' stamp: ''!
useSortedTabsBy: sortBlock
	tabs := SortedCollection sortBlock: sortBlock! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
selectNext
	| index nextSelection |
	
	index := tabs indexOf: self selectedTab.
	nextSelection := tabs at: index + 1 ifAbsent: [ ^ self ].

	nextSelection selected: true.! !

!TabBarMorph methodsFor: 'private' stamp: ''!
actionsChanged: aTab

	self selectedTab = aTab ifFalse: [ ^ self ].
	self adjustLayout.! !

!TabBarMorph methodsFor: 'private - constants' stamp: ''!
menuButtonWidth
	^ 16 * self displayScaleFactor! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
tabAddedToSelection: aTab

	aTab selected ifTrue: [ ^ self ].
	numberOfSelectedTabs := numberOfSelectedTabs + 1.
	self addInHistory: aTab.
	aTab silentlySelected: true.
	self adjustLayout.
	
	self triggerEvent: #tabAddedToSelection with: aTab! !

!TabBarMorph methodsFor: 'private' stamp: ''!
addActionsFor: aTab
	| rightOffset |
	
	"This check should maybe not be there but without it the CI fails a lot. Maybe it is due to a race condition?"
	aTab ifNil: [ ^ self ].

	rightOffset := self actionOffset.
	
	aTab hasMenu
		ifTrue: [ 
			rightOffset := 2 * rightOffset + self menuButtonWidth.
			self addMenuButton ].
		
	aTab actions reverseDo: [ :each || topOffset |
		topOffset := self height - each icon height // 2.
		self 
			addMorph: (self createActionButtonFor: each)
			fullFrame: (LayoutFrame identity
				bottomFraction: 0;
				leftFraction: 1;
				topOffset: topOffset;
				bottomOffset: topOffset + each icon height;
				rightOffset: rightOffset negated ;
				leftOffset: rightOffset negated - each icon width ).
				
		rightOffset := rightOffset + each icon width + self actionOffset]! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
selectPrevious
	| index nextSelection |
	
	index := tabs indexOf: self selectedTab.
	nextSelection := tabs at: index - 1 ifAbsent: [ ^ self ].

	nextSelection selected: true.! !

!TabBarMorph methodsFor: 'accessing' stamp: ''!
bounds: b

	super bounds: b.
	self adjustLayout! !

!TabBarMorph methodsFor: 'change reporting' stamp: ''!
ownerChanged

	super ownerChanged.
	self adjustLayout! !

!TabBarMorph methodsFor: 'accessing' stamp: ''!
selectedTab

	  ^selectionHistory ifEmpty: [ nil ] ifNotEmpty: [ selectionHistory last ]! !

!TabBarMorph methodsFor: 'drawing' stamp: ''!
drawWithoutSelectedOn: canvas
	canvas
		line: self bottomLeft + (0 @ -1)
		to: self bottomRight + (0 @ -1)
		width: 1
		color: self borderColor! !

!TabBarMorph methodsFor: 'drawing' stamp: ''!
adjustLayout
	| length overlap |
	
	length := self computeLength.
	self removeAllMorphs.
	length isZero ifTrue: [ ^ self ].
	overlap := self overlap.	
	
	selectionHistory do: [ :tab || index |
		index := (tabs indexOf: tab) - 1.
		self 
			addMorph: tab
			fullFrame: (LayoutFrame identity
				rightFraction: 0;
				leftOffset: (index*(length-overlap));
				rightOffset: (index*(length-overlap)) + length;
				bottomOffset: -1;
				yourself ).
		tab updateShowIcon ].
	
	self addActionsFor: self selectedTab.! !

!TabBarMorph methodsFor: 'private' stamp: ''!
computeLength
	| width size length |

	size := tabs size.
	size isZero ifTrue: [ ^ 0 ].
	width := self width - self extraSpace + ((size-1) * self overlap).
	
	length := width / size.
	length := length min: 150 * self displayScaleFactor.
	length := length max: 33 * self displayScaleFactor.

	^ length! !

!TabBarMorph methodsFor: 'private' stamp: ''!
overlap

	^ 8 * self displayScaleFactor! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
tabRefreshed: aTab

	self selectedTab = aTab ifFalse: [ ^ self ].

	self triggerEvent: #tabRefreshed with: aTab! !

!TabBarMorph methodsFor: 'drawing' stamp: ''!
borderColor
	"I do not use #borderColor because I want a light border"
	^ self theme lightBackgroundColor! !

!TabBarMorph methodsFor: 'private - history' stamp: ''!
addInHistory: aTab

	self removeFromHistory: aTab.
	selectionHistory addLast: aTab! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
tabSelected: aTab

	self isMultiSelection
		ifTrue: [ self tabResetSelection: aTab ]
		ifFalse: [ 
			self selectedTab ifNotNil: [ self selectedTab selected: false ].
			self addInHistory: aTab.	
			self adjustLayout.
			self triggerEvent: #tabSelected with: aTab ]! !

!TabBarMorph methodsFor: 'protocol' stamp: ''!
reversedSelectedTabs

	^ selectionHistory last: numberOfSelectedTabs! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
tabSelectTo: aTab
	| index selectedIndex |
	
	index := tabs indexOf: aTab. "If absent, then the system must be in a curious shape"
	selectedIndex := tabs indexOf: self selectedTab ifAbsent: [ ^ self ]. "No currently selected tab"
	
	index compareWith: selectedIndex
		ifLesser: [ 
			selectedIndex to: index by: -1 do: [ :i | 
				(tabs at: i) addToSelection	] ]
		ifEqual: [  ]
		ifGreater: [ 
			selectedIndex to: index do: [ :i | 
				(tabs at: i) addToSelection	] ].
			
	self addInHistory: aTab.
	self adjustLayout.! !

!TabBarMorph methodsFor: 'drawing' stamp: ''!
drawWithSelectionOn: canvas
	canvas
		line: self bottomLeft + (0 @ -1)
		to: self selectedTab bottomLeft
		width: 1
		color: self borderColor.
	canvas
		line: self selectedTab bottomLeft
		to: self selectedTab  bottomRight
		width: 1
		color: self selectedColor.
	canvas
		line: self selectedTab  bottomRight
		to: self bottomRight + (0 @ -1)
		width: 1
		color: self borderColor! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
tabDeleted: aTab

	self removeTab: aTab! !

!TabBarMorph methodsFor: 'protocol' stamp: ''!
selectTabAt: index ifAbsent: aBlock
	| tab |
	
	tab := tabs at: index ifAbsent: [ ^ aBlock value ].
	tab selected: true! !

!TabBarMorph methodsFor: 'private' stamp: ''!
registerActionsFor: aTab

	aTab 
		when: #tabSelected send: #tabSelected: to: self;
		when: #tabDeleted send: #tabDeleted: to: self;
		when: #rightKeyPressed send: #rightKeyPressed: to: self;
		when: #leftKeyPressed send: #leftKeyPressed: to: self;
		when: #tabRefreshed send: #tabRefreshed: to: self;
		when: #actionsChanged send: #actionsChanged: to: self;
		when: #tabResetSelection send: #tabResetSelection: to: self;
		when: #tabAddedToSelection send: #tabAddedToSelection: to: self;
		when: #tabRemovedFromSelection send: #tabRemovedFromSelection: to: self;
		when: #tabSelectTo send: #tabSelectTo: to: self;
		when: #tabEmptyContents send: #tabEmptyContents: to: self! !

!TabBarMorph methodsFor: 'private' stamp: ''!
createMenuButton
	"Answer a button for the window menu."
	| form msb |
	
	form := self theme windowMenuForm.
	msb := MultistateButtonMorph new extent: form extent.
	msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form).
	
	form := self theme windowMenuPassiveForm.
	msb extent: form extent.
	msb activeDisabledNotOverUpFillStyle: (ImageFillStyle form: form).
	msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form).
	msb passiveDisabledNotOverUpFillStyle: (ImageFillStyle form: form).
	
	form := self theme windowMenuForm.
	msb extent: form extent.
	msb
		activeEnabledOverUpFillStyle: (ImageFillStyle form: form);
		passiveEnabledOverUpFillStyle: (ImageFillStyle form: form).
	
	form := self theme windowMenuPassiveForm.
	msb
		extent: form extent;
		activeEnabledOverDownFillStyle: (ImageFillStyle form: form);
		passiveEnabledOverDownFillStyle: (ImageFillStyle form: form);
		addUpAction: [ self popUpMenu ];
		setBalloonText: 'tab menu' translated;
		extent: 16@16.
		
	^ msb! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
tabResetSelection: aTab
	"Clicked on an already clicked tab, since it can happened after a multi selection, I have to clear the selection except for this tab"
	
	selectionHistory ifNotEmpty: [
		(selectionHistory last: numberOfSelectedTabs) do: [ :each | each == aTab ifFalse: [ each silentlySelected: false ] ] ].
	
	numberOfSelectedTabs := 1.
	
	self addInHistory: aTab.
	self adjustLayout.
	
	self triggerEvent: #tabResetSelection with: aTab! !

!TabBarMorph methodsFor: 'private - actions' stamp: ''!
deleteSelectedTabs
	
	self selectedTabs do: [:e | e close ].! !

!TabBuildingIconMorph commentStamp: ''!
I implement rotated icon to animate background tab building. 
I use stepping mechanizm for animation.

Just create my instance with #new message to use in other morphs.

Internal Representation and Key Implementation Points.

    Instance Variables
	progress:		<Integer>
	progressIconMorph:		<ImageMorph>


    Implementation Points!
!TabBuildingIconMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self 
		clipLayoutCells: true;
		color: Color transparent.
	progress := 1.
	progressIconMorph := self currentIcon asMorph.
	self addMorphBack: progressIconMorph.
	self extent: progressIconMorph extent.! !

!TabBuildingIconMorph methodsFor: 'stepping' stamp: ''!
step
	progress := progress + 1.
	progress > 10 ifTrue: [ progress := 1 ].
	
	progressIconMorph form: self currentIcon! !

!TabBuildingIconMorph methodsFor: 'accessing' stamp: ''!
currentIcon
	^TabMorph perform: (#refreshIcon, progress asString) asSymbol! !

!TabBuildingIconMorph methodsFor: 'stepping' stamp: ''!
stepTime
	
	^ 100 "milliseconds"! !

!TabDisabled commentStamp: ''!
I am the state corresponding to a tab being disabled.!
!TabDisabled class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!TabDisabledState commentStamp: ''!
I am the state corresponding to a tab being disabled.!
!TabDisabledState methodsFor: 'protocol' stamp: ''!
backgroundColor
	^ Smalltalk ui theme disabledColor! !

!TabDisabledState methodsFor: 'protocol' stamp: ''!
newStateForSelected: aBoolean
	"An disabled tab can not be selected"
	
	^ self! !

!TabDisabledState methodsFor: 'protocol' stamp: ''!
isSelectedMatchingTheState: aBoolean

	^ aBoolean not! !

!TabDisabledState methodsFor: 'protocol' stamp: ''!
newStateForEnabled: aBoolean

	^ TabEnabledState tab: self tab! !

!TabDisabledState methodsFor: 'protocol' stamp: ''!
isEnabledMatchingTheState: aBoolean

	^ aBoolean not! !

!TabEnabled commentStamp: ''!
I am the state of a tab enabled but not yet selected!
!TabEnabled class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!TabEnabledState commentStamp: ''!
I am the state of a tab enabled but not yet selected!
!TabEnabledState methodsFor: 'protocol' stamp: ''!
backgroundColor
	^ Smalltalk ui theme darkBaseColor! !

!TabEnabledState methodsFor: 'protocol' stamp: ''!
newStateForSelected: aBoolean
	self assert: aBoolean.
	
	^ TabSelectedState tab: self tab! !

!TabEnabledState methodsFor: 'protocol' stamp: ''!
enabled

	^ true! !

!TabEnabledState methodsFor: 'protocol' stamp: ''!
isSelectedMatchingTheState: aBoolean

	^ aBoolean not! !

!TabEnabledState methodsFor: 'protocol' stamp: ''!
newStateForEnabled: aBoolean
	"aBoolean here must be false"
	self deny: aBoolean.
	
	^ TabDisabledState tab: self tab! !

!TabEnabledState methodsFor: 'protocol' stamp: ''!
isEnabledMatchingTheState: aBoolean

	^ aBoolean! !

!TabExample commentStamp: ''!
I am an example of how to:
	- instanciate tabs (#tabs)
	- use a tab manager
	
Nothing really complicated here.

self open!
!TabExample methodsFor: 'private' stamp: ''!
addTabs

	self tabs do: [ :tab | manager addTab: tab ]! !

!TabExample methodsFor: 'private' stamp: ''!
delete

	window ifNotNil: [ window delete ]! !

!TabExample methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	manager := TabManagerMorph new.
	manager
		when: #tabManagerDeleted send: #delete to: self.
	listModel := SpListPresenter new.
	listModel items: ((1 to: 1000) asOrderedCollection)! !

!TabExample methodsFor: 'tabs creation' stamp: ''!
storedListTab
	^ TabMorph
		label: 'Stored List Model'
		icon: (self iconNamed: #smallHelpIcon)
		retrievingBlock: [ listModel buildWithSpec ]! !

!TabExample methodsFor: 'private' stamp: ''!
tabs
	
	^ OrderedCollection new
		add: self storedListTab;
		add: self freshListTab;
		add: self blueMorphTab;
		add: self redMorphTab;
		yourself! !

!TabExample methodsFor: 'instance creation' stamp: ''!
open
	window := manager openInWindow.
	window extent: 400 @ 300.

	self addTabs! !

!TabExample methodsFor: 'accessing' stamp: ''!
window

	^ window! !

!TabExample methodsFor: 'tabs creation' stamp: ''!
redMorphTab
	^ (LockableTabMorph
		label: 'Red Morph'
		icon: (self iconNamed: #smallBackIcon)
		morph:
		(Morph new
		color: Color red;
		yourself))
		closeable: false;
		yourself! !

!TabExample methodsFor: 'tabs creation' stamp: ''!
blueMorphTab
	| tab |
	tab := TabMorph
		label: 'Blue Morph'
		icon: (self iconNamed: #smallBackIcon)
		morph: Morph new.
	tab
		actions:
			{(TabAction
				action: [ tab morph color: Color random ]
				icon: (self iconNamed: #smallConfigurationIcon)
				label: 'Randomize color')}.
	tab
		closeable: false;
		menu: [ :menu | menu add: 'Fubu' target: self selector: #halt ].
	^ tab! !

!TabExample methodsFor: 'tabs creation' stamp: ''!
freshListTab
	<haltOrBreakpointForTesting>
	^ (TabMorph
		label: 'Fresh List'
		icon: nil
		retrievingBlock: [ 1 second asDelay wait.
			SpListPresenter new
				items: (1 to: 50) asOrderedCollection;
				buildWithSpec ]
		actions:
		{(TabAction
				action: [ self halt ]
				icon: (self iconNamed: #smallConfigurationIcon)
				label: 'Halt!!')})
		menu: [ :menu | menu add: 'Fubu' target: self selector: #halt ];
		yourself! !

!TabExample class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	^ self new open! !

!TabGroupMorph commentStamp: ''!
Organises a set of pages sharing the same space and selected through the use of tabs along the top.!
!TabGroupMorph methodsFor: 'accessing' stamp: ''!
page: aMorph
	"Select the give page."

	self selectedPageIndex: (self pages indexOf: aMorph)! !

!TabGroupMorph methodsFor: 'updating' stamp: ''!
update: aSymbol with: anObject
	"Handle tab changes."

	super update: aSymbol with: anObject.
	aSymbol == #selectedIndex ifTrue: [
			anObject > 0 & (anObject <= self pages size) 
				ifTrue: [ "the old selected page is available"					
					self updatePageIndex: self selectedPageIndex oldIndex: anObject]
				ifFalse: [ self updatePageIndex: self selectedPageIndex ]]! !

!TabGroupMorph methodsFor: 'rounding' stamp: ''!
cornerStyle: aSymbol
	"Pass on to selector and content too."

	super cornerStyle: aSymbol.
	self tabSelectorMorph cornerStyle: aSymbol.
	self contentMorph cornerStyle: aSymbol! !

!TabGroupMorph methodsFor: 'building' stamp: ''!
newContentMorph
	"Answer a new content morph"

	|p|
	p := PanelMorph new
		roundedCorners: #(2 3 4);
		changeTableLayout; 
		layoutInset: 4;
		cellInset: 8;
		vResizing: #spaceFill;
		hResizing: #spaceFill.
	p borderStyle: (self theme tabPanelBorderStyleFor: self).
	^p! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
pageMorphs: anObject
	"Set the value of pageMorphs"

	pageMorphs := anObject! !

!TabGroupMorph methodsFor: 'page' stamp: ''!
selectedPageIndex: index
	"Set the selected page index."

	self tabSelectorMorph selectedIndex: index! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
contentMorph
	"Answer the value of contentMorph"

	^ contentMorph! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
font
	"Answer the label font"

	^self tabSelectorMorph font! !

!TabGroupMorph methodsFor: 'drawing' stamp: ''!
minExtent
	"Calculate the min extent of the receiver based on all pages."

	|extra|
	self page ifNil: [^super minExtent max: self tabSelectorMorph minExtent].
	extra := 0@(self tabSelectorMorph minExtent y) + (self contentMorph borderWidth * 2).
	extra := extra + (self contentMorph layoutInset * 2).
	^super minExtent max: (((self pages inject: 0 @ 0 into: [:mw :pm | mw max: pm minExtent]) + extra)
		max: self tabSelectorMorph minExtent)! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
selectedTab
	"Answer the tab of the selected page."
	
 	^self tabSelectorMorph selectedTab! !

!TabGroupMorph methodsFor: 'page' stamp: ''!
selectedPageIndex
	"Answer the selected page index."

	^self tabSelectorMorph selectedIndex! !

!TabGroupMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
themeChanged
	"Update the corner style."

	self cornerStyle: (self theme tabGroupCornerStyleIn: self window).
	self pageMorphs do: [ :morph | morph themeChanged ].
	super themeChanged! !

!TabGroupMorph methodsFor: 'adding' stamp: ''!
addPage: aMorph label: aStringOrMorph
	"Add a page and its tab."

	aMorph
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	self pages add: aMorph.
	self tabSelectorMorph addTab: aStringOrMorph! !

!TabGroupMorph methodsFor: 'page' stamp: ''!
updatePageIndex: index
	"Change to the given page index."

	self pageMorph ifNotNil: [:p | self contentMorph removeMorph: p].
	index > 0 ifTrue: [self contentMorph addMorph: (self pages at: index)].
	self pageMorph ifNotNil: [:pm | pm layoutChanged].
	self adoptPaneColor: self paneColor! !

!TabGroupMorph methodsFor: 'page' stamp: ''!
removePageIndex: anInteger
	"Remove the page at index anInteger page and its tab."

	self pages removeAt: anInteger.
	self tabSelectorMorph removeTabIndex: anInteger! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
paneColorOrNil
	"Answer the window's pane color or nil otherwise."

	^super paneColorOrNil ifNotNil: [:c | self theme subgroupColorFrom: c]! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
tabSelectorMorph: anObject
	"Set the value of tabSelectorMorph"

	tabSelectorMorph := anObject! !

!TabGroupMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		borderWidth: 0;
		changeTableLayout;
		cellPositioning: #topLeft;
		cellInset: 0 @ -1;
		reverseTableCells: true;
		pageMorphs: OrderedCollection new;
		tabSelectorMorph: self newTabSelectorMorph;
		contentMorph: self newContentMorph;
		addMorph: self tabSelectorMorph;
		addMorph: self contentMorph.
	self tabSelectorMorph addDependent: self! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
pageMorphs
	"Answer the value of pageMorphs"

	^ pageMorphs! !

!TabGroupMorph methodsFor: 'adding' stamp: ''!
addPage: aMorph label: aStringOrMorph selected: selectedStringOrMorph
	"Add a page and its tab with alternate label when selected."

	aMorph
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	self pages add: aMorph.
	self tabSelectorMorph addTab: aStringOrMorph selected: selectedStringOrMorph! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
contentMorph: anObject
	"Set the value of contentMorph"

	contentMorph := anObject! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
font: aFont
	"Set the label font"

	self tabSelectorMorph font: aFont! !

!TabGroupMorph methodsFor: 'page' stamp: ''!
labelsAndPages: assocs
	"Replace the tabs and the associated pages."

	self contentMorph removeAllMorphs.
	self tabSelectorMorph removeAllMorphs.
	assocs do: [:a | self addPage: a value label: a key]! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
pages
	"Answer the pages."

	^self pageMorphs! !

!TabGroupMorph methodsFor: 'drawing' stamp: ''!
fullDrawOn: aCanvas
	"Patch up the selected tab visuals if required."
	
	super fullDrawOn: aCanvas.
	self theme drawTabGroupFinishingFor: self on: aCanvas! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
pageMorph
	"Answer the current page morph if any."

	^self contentMorph hasSubmorphs
		ifTrue: [self contentMorph submorphs first]! !

!TabGroupMorph methodsFor: 'adding' stamp: ''!
removePage: aMorph
	"Remove the given page and its tab."

	|index|
	index := self pages indexOf: aMorph.
	self pages remove: aMorph.
	self tabSelectorMorph removeTabIndex: index! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Pass on to the content morph a little lighter."
	
	paneColor ifNil: [^super adoptPaneColor: paneColor].
	super adoptPaneColor: (self theme subgroupColorFrom: paneColor).
	self contentMorph borderStyle: (self theme tabPanelBorderStyleFor: self)! !

!TabGroupMorph methodsFor: 'page' stamp: ''!
updatePageIndex: index oldIndex: oldSelectedIndex 
	self updatePageIndex: index! !

!TabGroupMorph methodsFor: 'page' stamp: ''!
relabelPage: aMorph with: aStringOrMorph
	"Relabel the tab associated with the given page and
	update tabs."

	self tabSelectorMorph
		relabelTab: (self tabOfPage: aMorph) with: aStringOrMorph! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
page
	"Answer the current page morph if any."

	^self pageMorph! !

!TabGroupMorph methodsFor: 'building' stamp: ''!
newTabSelectorMorph
	"Answer a new tab selector morph"

	^TabSelectorMorph new
		vResizing: #shrinkWrap;
		hResizing: #spaceFill! !

!TabGroupMorph methodsFor: 'page' stamp: ''!
tabOfPage: aMorph
	"Answer the tab associated with the given page."

	^self tabSelectorMorph tabs at: (self pages indexOf: aMorph)! !

!TabGroupMorph methodsFor: 'accessing' stamp: ''!
tabSelectorMorph
	"Answer the value of tabSelectorMorph"

	^ tabSelectorMorph! !

!TabGroupMorph class methodsFor: 'examples' stamp: ''!
example
	| builder window page1 page2 label1 label2 tabs content okButton cancelButton |
	builder := self theme builder.
	okButton := builder newOKButton.
	cancelButton := builder newCancelButton.
	page1 := (builder
		newStack:
		{((builder
		newAlphaImage: (self iconNamed: #warningIcon)
		help: nil) alpha: 0.5).
	(CircleMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill)})
		fillStyle: Color red;
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	page2 := builder newPanel
		fillStyle: Color green;
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	label1 := builder
		newRow:
			{(builder newButtonLabel: 'First page').
			(builder
				newCloseControlFor: nil
				action: [ tabs removePage: page1 ]
				help: 'Close this tab')}.
	label2 := builder
		newRow:
			{(builder newButtonLabel: 'Second page').
			(builder
				newCloseControlFor: nil
				action: [ tabs removePage: page2 ]
				help: 'Close this tab')}.
	label1 cellInset: 0.
	label2 cellInset: 0.
	tabs := builder
		newTabGroup:
			{(label1 -> page1).
			(label2 -> page2)}.
	content := builder
		newColumn:
			{tabs.
			((builder
				newRow:
					{okButton.
					cancelButton}) listCentering: #bottomRight)}.
	window := content
		extent: 250 @ 300;
		openInWindow.
	okButton
		model: window;
		action: #delete.
	cancelButton
		model: window;
		action: #delete! !

!TabLabelItemMorph commentStamp: ''!
I am a special label morph for tabs.

This way I can control which of my submorphs to show according to the tab size!
!TabLabelItemMorph methodsFor: 'accessing' stamp: ''!
tab: anObject
	
	tab := anObject! !

!TabLabelItemMorph methodsFor: 'drawing' stamp: ''!
clippingBounds
	"Return the bounds to which any submorphs should be clipped if the property is set"
	^ tab modifyClippingBounds: super clippingBounds! !

!TabLabelItemMorph methodsFor: 'private - drawing' stamp: ''!
computeSubmorphsToDraw

	owner width < tab showIconTreshold 
		ifTrue: [ 
			(storedIcon isNil and: [ icon notNil ]) ifTrue: [
				storedIcon := icon.
				self removeMorph: icon ].
			^ { morph } ].
		
	storedIcon 
		ifNotNil: [ 
			self addMorphFront: storedIcon.
			storedIcon := nil ].
		
	^ self submorphs! !

!TabLabelItemMorph methodsFor: 'accessing' stamp: ''!
themeChanged
	super themeChanged.
	morph color: morph defaultColor.
	morph changed! !

!TabLabelItemMorph methodsFor: 'drawing' stamp: ''!
clipSubmorphs 

	^ true! !

!TabLabelItemMorph methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas
	"Display submorphs back to front"

	| drawBlock submorphsToDraw |
	submorphs isEmpty
		ifTrue: [ ^ self ].
	
	submorphsToDraw := self computeSubmorphsToDraw.
	
	drawBlock := [ :canvas | submorphsToDraw do: [ :m | canvas fullDrawMorph: m ] ].
	
	self clipSubmorphs
		ifTrue: [ aCanvas clipBy: (aCanvas clipRect intersect: self clippingBounds ifNone: [ ^ self ]) during: drawBlock ]
		ifFalse: [ drawBlock value: aCanvas ]! !

!TabLabelItemMorph methodsFor: 'accessing' stamp: ''!
icon: anObject

	icon ifNotNil: [ self removeMorph: icon ].
	
	icon := anObject.
	icon ifNotNil: [ 	self addMorphFront: icon ]! !

!TabLabelItemMorph class methodsFor: 'instance creation' stamp: ''!
tab: tab

	^ self new
		tab: tab;
		yourself! !

!TabLabelMorph commentStamp: ''!
Specially themed label used for tab selector items. !
!TabLabelMorph methodsFor: 'accessing' stamp: ''!
tabSelector

	^ tabSelector! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
label
	"Answer the label contents."

	^self isSelected
		ifTrue: [self selectedLabel userString ifNil: [self firstSubmorph]]
		ifFalse: [self normalLabel userString ifNil: [self firstSubmorph]]! !

!TabLabelMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."
	
	super initialize.
	self fillStyle: self fillStyleToUse.
	self borderStyle: self borderStyleToUse! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
label: aStringOrMorph
	"Change the label contents"

	|l|
	l := aStringOrMorph isMorph
		ifTrue: [aStringOrMorph]
		ifFalse: [(self theme buttonLabelForText: aStringOrMorph)
					vResizing: #shrinkWrap;
					hResizing: #shrinkWrap].
	self
		normalLabel: l;
		selectedLabel: l;
		selected: self isSelected! !

!TabLabelMorph methodsFor: 'layout' stamp: ''!
minWidth
	"Consult the theme also."

	^super minWidth max: self theme buttonMinWidth! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
selectedLabel

	^ selectedLabel! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
selected: aBoolean
	"Use the appropriate label."

	self removeAllMorphs.
	self isSelected
		ifTrue: [self addMorph: self selectedLabel]
		ifFalse: [self addMorph: self normalLabel]! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
fillStyleToUse
	"Answer the basic fill style for the receiver."

	^self isSelected
		ifTrue: [self selectedFillStyle] 
		ifFalse: [self normalFillStyle]! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
font: aFont
	"Set the label font"

	self normalLabel allMorphsDo: [:m |
		(m respondsTo: #font:) ifTrue: [m font: aFont]].
	self selectedLabel allMorphsDo: [:m |
		(m respondsTo: #font:) ifTrue: [m font: aFont]]! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
label: aStringOrMorph selected: selectedStringOrMorph
	"Change the label contents"

	|l s|
	l := aStringOrMorph isMorph
		ifTrue: [aStringOrMorph]
		ifFalse: [(self theme buttonLabelForText: aStringOrMorph)
					vResizing: #shrinkWrap;
					hResizing: #shrinkWrap].
	s:= selectedStringOrMorph isMorph
		ifTrue: [selectedStringOrMorph]
		ifFalse: [(self theme buttonLabelForText: selectedStringOrMorph)
					vResizing: #shrinkWrap;
					hResizing: #shrinkWrap].
	self
		normalLabel: l;
		selectedLabel: s;
		selected: self isSelected! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
borderStyleToUse
	"Answer the borderStyle that should be used for the receiver."
	
	^self isSelected
		ifTrue: [self theme tabLabelSelectedBorderStyleFor: self]
		ifFalse: [self theme tabLabelNormalBorderStyleFor: self]! !

!TabLabelMorph methodsFor: 'testing' stamp: ''!
isSelected
	"Answer whether the tab is selected."

	^self tabSelector
		ifNil: [false]
		ifNotNil: [:selector | selector selectedTab == self]! !

!TabLabelMorph methodsFor: 'style' stamp: ''!
selectedFillStyle
	"Return the selected fillStyle of the receiver."
	
	^self theme tabLabelSelectedFillStyleFor: self! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
selectedLabel: anObject

	selectedLabel := anObject! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
focusBounds
	"Answer the bounds for drawing the focus indication."

	^(self bounds width < 6 or: [self bounds height < 6])
		ifTrue: [super focusBounds]
		ifFalse: [super focusBounds insetBy: (2@2 corner: 2@0)]! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
tabSelector: anObject

	tabSelector := anObject! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Use the theme for fillStyle and border."
	
	super adoptPaneColor: paneColor.
	paneColor ifNil: [^self].
	self fillStyle: self fillStyleToUse.
	self borderStyle: self borderStyleToUse! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
normalLabel

	^ normalLabel! !

!TabLabelMorph methodsFor: 'accessing' stamp: ''!
normalLabel: anObject

	normalLabel := anObject! !

!TabLabelMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	"Set the extent of the receiver.
	Update the pane color for size dependent fill/border styles."

	super extent: aPoint.
	self adoptPaneColor! !

!TabLabelMorph methodsFor: 'testing' stamp: ''!
isVisible
	"Answer whether the tab is currently visible."

	^self tabSelector
		ifNil: [false]
		ifNotNil: [:selector | selector visibleTabs includes: self]! !

!TabLabelMorph methodsFor: 'style' stamp: ''!
normalFillStyle
	"Return the normal fillStyle of the receiver."
	
	^self theme tabLabelNormalFillStyleFor: self! !

!TabManagerMorph commentStamp: ''!
I am the entry point for tabs.

I am composed of a TabBar and a Morph used as a canvas to render the morph represented by the selected tab.

I am very stupid (as you can see only four methods). I just listen to selected tab, and render it!
!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
deleteSelectedTabs
	toolbar selectedTab 
		ifNotNil: [ toolbar deleteSelectedTabs ] 
		ifNil: [ self owner takeKeyboardFocus ]! !

!TabManagerMorph methodsFor: 'protocol' stamp: ''!
tabs: aCollection

	toolbar tabs: aCollection! !

!TabManagerMorph methodsFor: 'compatbility' stamp: ''!
setTabs: aBlock
	self tabs: aBlock value! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
tabAddedToSelection: aTab

	self setMultipleContents! !

!TabManagerMorph methodsFor: 'protocol' stamp: ''!
addTab: aTab
	toolbar addTab: aTab! !

!TabManagerMorph methodsFor: 'initialization' stamp: ''!
minExtent

	^ (100@50) * self displayScaleFactor! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
selectPrevious

	toolbar selectPrevious! !

!TabManagerMorph methodsFor: 'private' stamp: ''!
setMultipleContents
	| tabs size delta |

	contentsWrapper removeAllMorphs.
	self cleanProcesses.
	
	tabs := toolbar orderedSelectedTabs.
	size := tabs size.
	delta := 1 / size.
	
	tabs allButLast keysAndValuesDo: [ :index :tab | self addTabContents: tab at: index delta: delta ].
	self addLastTabContents: tabs last among: size delta: delta.
	self addSplitterOn: tabs delta: delta! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
selectTabAt: index

	toolbar selectTabAt: index ifAbsent: [].! !

!TabManagerMorph methodsFor: 'drawing' stamp: ''!
drawLinesOn: aCanvas
	self flag: #pharoTodo. "this method, I don't know what's is for."
	"aCanvas
		line: self topLeft
		to: self bottomLeft
		width: 1
		color: self borderColor.
	aCanvas
		line: self bottomLeft
		to: self bottomRight
		width: 1
		color: self borderColor.
	aCanvas
		line: self topRight
		to: self bottomRight
		width: 1
		color: self borderColor"! !

!TabManagerMorph methodsFor: 'protocol' stamp: ''!
selectedTab

	^ toolbar selectedTab! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
tabEmptyContents: aTab
	"My bar already filtered the tab, so here I am sure the tab is the selected tab"
	
	contentsWrapper removeAllMorphs! !

!TabManagerMorph methodsFor: 'initialization' stamp: ''!
themeChanged
	super themeChanged.
	toolbar themeChanged.
	
	container
		color: self theme lightBaseColor;
		changed.
	contentsWrapper
		color: self theme lightBaseColor;
		changed! !

!TabManagerMorph methodsFor: 'initialization' stamp: ''!
registerShortcuts

	self 
		bindKeyCombination: $] meta shift toAction: [ self selectNext ];
		bindKeyCombination: $[ meta shift toAction: [ self selectPrevious ];
		bindKeyCombination: $w command toAction: [ self deleteSelectedTabs ];
		bindKeyCombination: $w command shift toAction: [ self closeAllTabs ].
		
	1 to: 9 do: [ :index |
		self bindKeyCombination: index asString first meta toAction: [ self selectTabAt: index ] ].
	
	self bindKeyCombination: $0 meta toAction: [ self selectLastTab ]! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
selectLastTab

	toolbar selectLastTab! !

!TabManagerMorph methodsFor: 'protocol' stamp: ''!
close

	self canBeClosed ifFalse: [ ^ self ].
	self delete.! !

!TabManagerMorph methodsFor: 'private - contents' stamp: ''!
addLastTabContents: aTab among: size delta: delta
	| process |
	
	process := aTab retrieveMorph: [ :contents | 
		contents ifNil: [ TabWithNoContentsMorph signalTab: aTab ].
		contentsWrapper
			addMorph: contents
			fullFrame:
				(LayoutFrame identity
					leftFraction: (size - 1) * delta;
					leftOffset: 2;
					rightFraction: 1).
		"contents takeKeyboardFocus" "it should be managed better and not stale focus from another active windows/widgets. It should only forse focus on content when user focused on tabs but it is not clean how to detect it"].
	
	process ifNotNil: [ processes add: process ]! !

!TabManagerMorph methodsFor: 'private - drawing' stamp: ''!
containerColor
	^ self theme lightBaseColor! !

!TabManagerMorph methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas
	super drawSubmorphsOn: aCanvas.
	self drawLinesOn: aCanvas! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
tabRefreshed: aTab
	"Here we know that aTab is the selected tab"

	self setMultipleContents! !

!TabManagerMorph methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!TabManagerMorph methodsFor: 'private - drawing' stamp: ''!
borderColor
	^ self theme borderColor! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
tabSelected: aTab

	self setTabContentFrom: aTab.
	self triggerEvent: #tabSelected with: aTab! !

!TabManagerMorph methodsFor: 'initialization' stamp: ''!
registerBarActions
	
	toolbar 
		when: #tabSelected send: #tabSelected: to: self;
		when: #barDeleted send: #barDeleted: to: self;
		when: #tabsChanged send: #tabsChanged to: self;
		when: #tabRefreshed send: #tabRefreshed: to: self;
		when: #tabAddedToSelection send: #tabAddedToSelection: to: self;
		when: #tabRemovedFromSelection send: #tabRemovedFromSelection: to: self;
		when: #tabResetSelection send: #tabResetSelection: to: self;
		when: #tabEmptyContents send: #tabEmptyContents: to: self! !

!TabManagerMorph methodsFor: 'protocol' stamp: ''!
delete
	
	super delete.
	self triggerEvent: #tabManagerDeleted with: self! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
tabsChanged
	"Nothing to do"! !

!TabManagerMorph methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	toolbar := TabBarMorph new.
	processes := OrderedCollection new.
	self registerBarActions.
	self registerShortcuts.
	
	container := Morph new
		color: self containerColor;
		changeProportionalLayout;
		yourself.
		
	contentsWrapper := Morph new
		color: self containerColor;
		changeProportionalLayout;
		yourself.
		
	self changeProportionalLayout.
	self addMorphs! !

!TabManagerMorph methodsFor: 'private' stamp: ''!
setTabContentFrom: aTab
	| process |
	
	contentsWrapper removeAllMorphs.
	self cleanProcesses.

	process := aTab retrieveMorph: [ :contents |
		contents ifNil: [ TabWithNoContentsMorph signalTab: aTab ].
		contentsWrapper addMorph: contents fullFrame: LayoutFrame identity.
		"contents takeKeyboardFocus" "it should be managed better and not stale focus from another active windows/widgets. It should only forse focus on content when user focused on tabs but it is not clean how to detect it"
	].
	process ifNotNil: [ processes add: process ].! !

!TabManagerMorph methodsFor: 'private - contents' stamp: ''!
addTabContents: tab at: index delta: delta
	| process |
	process := tab
		retrieveMorph:
			[ :contents | 
			| leftOffset |
			contents ifNil: [ TabWithNoContentsMorph signalTab: tab ].
			leftOffset := index = 1
				ifTrue: [ 0 ]
				ifFalse: [ 2 ].
			contentsWrapper
				addMorph: contents
				fullFrame:
					(LayoutFrame identity
						leftFraction: (index - 1) * delta;
						leftOffset: leftOffset;
						rightOffset: -2;
						rightFraction: index * delta) ].
	process ifNotNil: [ processes add: process ]! !

!TabManagerMorph methodsFor: 'accessing' stamp: ''!
emptyTabColor: aColor

	contentsWrapper color: aColor! !

!TabManagerMorph methodsFor: 'protocol' stamp: ''!
canBeClosed
	^ toolbar canBeClosed! !

!TabManagerMorph methodsFor: 'private - contents' stamp: ''!
addSplitterOn: tabs delta: delta
	| leftProcess rightProcess |
	tabs overlappingPairsWithIndexDo: [ :left :right :index | 
		leftProcess := left retrieveMorph: [ :leftContents | 
			leftContents ifNil: [ TabWithNoContentsMorph signalTab: left ].
			rightProcess := right retrieveMorph: [ :rightContents || splitter |
				rightContents ifNil: [ TabWithNoContentsMorph signalTab: right ].
				
				splitter := ProportionalSplitterMorph new
					addLeftOrTop: leftContents;
					addRightOrBottom: rightContents;
					yourself.

				contentsWrapper
					addMorph: splitter
					fullFrame:
						(LayoutFrame identity
							leftFraction: index * delta;
							rightFraction: index * delta;
							leftOffset: -2;
							rightOffset: 2) ] ] ].
				
	leftProcess ifNotNil: [ processes add: leftProcess ].
	rightProcess ifNotNil: [ processes add: rightProcess ].! !

!TabManagerMorph methodsFor: 'protocol' stamp: ''!
closeAllTabs
	toolbar closeAllTabs! !

!TabManagerMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: aColor
	"Prevent submorphs to be polluted by window color"
	
	self color: aColor! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
tabRemovedFromSelection: aTab

	self setMultipleContents! !

!TabManagerMorph methodsFor: 'private' stamp: ''!
addMorphs

	self 
		addMorph: toolbar
		fullFrame: (LayoutFrame identity
			bottomFraction: 0;
			bottomOffset: TabMorph defaultHeight + (2* self displayScaleFactor);
			yourself).
			
	self 
		addMorph: container
		fullFrame: (LayoutFrame identity
			topOffset: TabMorph defaultHeight + 2;
			yourself).
			
	container
		addMorph: contentsWrapper
		fullFrame:
			(LayoutFrame identity
				topOffset: 2;
				rightOffset: -1;
				bottomOffset: -1;
				leftOffset: 2;
				yourself).! !

!TabManagerMorph methodsFor: 'accessing' stamp: ''!
model: aModel

	model := aModel! !

!TabManagerMorph methodsFor: 'private' stamp: ''!
cleanProcesses
	
	processes do: [ :each | each terminate ].
	processes removeAll.! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
selectNext

	toolbar selectNext! !

!TabManagerMorph methodsFor: 'initialization' stamp: ''!
useSortedTabsBy: sortBlock
	toolbar useSortedTabsBy: sortBlock! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
tabResetSelection: aTab

	self setTabContentFrom: aTab! !

!TabManagerMorph methodsFor: 'private - actions' stamp: ''!
barDeleted: aBar

	self close! !

!TabManagerPresenter commentStamp: ''!
I am a spec presenter representing a tab manager. My role is to gather multiple tabs, and make them work together

You can also have a look at TabsExample for another example.
!
!TabManagerPresenter methodsFor: 'api' stamp: ''!
selectTabModel: tabModel

	tabSelectedAction value cull: tabModel cull: self! !

!TabManagerPresenter methodsFor: 'initialization' stamp: ''!
initialize
	"Initialization code for TabManagerPresenter"

	super initialize.
	tabs := OrderedCollection new asValueHolder.
	tabSelectedAction := [  ] asValueHolder.
	selectedTab := nil asValueHolder.
	self myDependents: WeakSet new.

	tabs whenChangedDo: [ :new | self widget ifNotNil: [ :w | w tabs: self getTabs value ] ].
	selectedTab whenChangedDo: [ :newTab | tabSelectedAction value cull: newTab cull: self ]! !

!TabManagerPresenter methodsFor: 'accessing' stamp: ''!
tabs

	^ tabs value! !

!TabManagerPresenter methodsFor: 'api' stamp: ''!
tabs: aCollection

	tabs value: aCollection! !

!TabManagerPresenter methodsFor: 'api' stamp: ''!
tabSelectedAction

	^ tabSelectedAction value! !

!TabManagerPresenter methodsFor: 'private' stamp: ''!
basicRemoveTab: aTab
	"BEWARE: this code is an exception. One should never access directly a value holder contents"

	"I do this here for optimisation. No need to trigger the whole collection changed. Only the added element is interesting "

	"This method simply removes the tab from the collection without triggering further updates. It is useful for Adapters if there are different mechanisms of tab removal."

	(tabs value remove: aTab ifAbsent: [ ^ self ]) owner: nil! !

!TabManagerPresenter methodsFor: 'api' stamp: ''!
addTab: aTab

	"BEWARE: this code is an exception. One should never access directly a value holder contents"
	"I do this here for optimisation. No need to trigger the whole collection changed. Only the added element is interesting "
	tabs value add: aTab.
	aTab owner: self.
	self selectedTab ifNil: [ selectedTab value: aTab ].
	self changed: #addTab: with: { aTab }! !

!TabManagerPresenter methodsFor: 'dependents' stamp: ''!
addDependent: aMorph

	self myDependents add: aMorph! !

!TabManagerPresenter methodsFor: 'api' stamp: ''!
selectedTab

	^ selectedTab value! !

!TabManagerPresenter methodsFor: 'api' stamp: ''!
removeTabNumber: anIndex

	self removeTab: (tabs at: anIndex)! !

!TabManagerPresenter methodsFor: 'api - events' stamp: ''!
whenTabSelected: aBlock

	tabSelectedAction value: aBlock! !

!TabManagerPresenter methodsFor: 'api' stamp: ''!
removeTab: aTab
	self basicRemoveTab: aTab.
	self changed: #removeTab: with: {aTab}! !

!TabManagerPresenter methodsFor: 'api' stamp: ''!
selectedTab: aTab

	selectedTab value: aTab! !

!TabManagerPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(TabManagerAdapter
		adapt: #(model))! !

!TabManagerPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TabManagerAdapter! !

!TabMorph commentStamp: ''!
I represent a simple tab
I have a IconicListItem which wrap my label and my icon.
I also have a morph to display when selected.
This morph can in fact be anything responding to #asMorph. Moreover it could be a block for lazy initialization.

I also have a state representing if I am selecting or not, enabled or not, etc!
!TabMorph methodsFor: 'protocol' stamp: ''!
hasActions

	^ actions notEmpty! !

!TabMorph methodsFor: 'protocol' stamp: ''!
menu: aMenu
	
	menu := aMenu! !

!TabMorph methodsFor: 'private - constants' stamp: ''!
actionOffset

	^ 4 * self displayScaleFactor! !

!TabMorph methodsFor: 'private' stamp: ''!
refreshContent
	
	morph := nil.
	self triggerEvent: #tabEmptyContents with: self.
	
	"Trigger the update"
	self softRetrieveMorph.! !

!TabMorph methodsFor: 'private' stamp: ''!
buildLabel: text withIcon: icon
	
	^ (TabLabelItemMorph tab: self)
		morph:	text asMorph;
		icon: (AlphaImageMorph new image: icon);
		yourself! !

!TabMorph methodsFor: 'private - constants' stamp: ''!
labelRightOffset

	^ 12 * self displayScaleFactor! !

!TabMorph methodsFor: 'accessing' stamp: ''!
morph

	^ morph! !

!TabMorph methodsFor: 'protocol' stamp: ''!
themeChanged
	super themeChanged.
	morph ifNotNil: #themeChanged! !

!TabMorph methodsFor: 'protocol' stamp: ''!
addActions: aCollection

	actions addAll: aCollection! !

!TabMorph methodsFor: 'accessing' stamp: ''!
model

	^ model! !

!TabMorph methodsFor: 'private' stamp: ''!
addLabel

	self
		addMorph: label 
		fullFrame: (LayoutFrame identity
			topFraction: 1;
			leftOffset: self labelRightOffset;
			topOffset: (label height negated - self labelBottomOffset) + 2;
			yourself)! !

!TabMorph methodsFor: 'protocol' stamp: ''!
icon: anIcon

	anIcon 
		ifNil: [ label icon: nil ]
		ifNotNil: [ label icon: (AlphaImageMorph new image: anIcon) ]! !

!TabMorph methodsFor: 'accessing' stamp: ''!
label
	^ label! !

!TabMorph methodsFor: 'protocol' stamp: ''!
softRetrieveMorph
	| oldIcon |
	"Like retrieveMorph but done in a separated process"	
	morph ifNotNil: [ ^ self ].	
	retrievingProcess 
		ifNotNil: [ 
			"The retrieving process is already running, let's wait for its result"
			retrievingProcess isTerminated 
				ifFalse: [ ^ self ] ].
	
	oldIcon := self icon ifNotNil: [ :i | i form ].
	label icon: TabBuildingIconMorph new.
	retrievingProcess := [ [
		morph := retrievingBlock value]
	ensure: [		
		UIManager default defer: [
			self icon: oldIcon.
			self triggerEvent: #tabRefreshed with: self].
		"I should signal all waiters here"
		[retrievingSemaphore isEmpty] whileFalse: [ retrievingSemaphore signal].
	] ] forkAt: Processor activePriority - 2! !

!TabMorph methodsFor: 'protocol' stamp: ''!
hasMenu

	^ menu notNil or: [ retrievingBlock notNil ]! !

!TabMorph methodsFor: 'protocol' stamp: ''!
actions: aCollection

	actions := aCollection.
	self triggerEvent: #actionsChanged with: self! !

!TabMorph methodsFor: 'protocol' stamp: ''!
delete

	super delete.
	morph ifNotNil: [morph delete].
	retrievingProcess ifNotNil: [ retrievingProcess terminate ].
	self triggerEvent: #tabDeleted with: self! !

!TabMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	self changeProportionalLayout.

	state := TabEnabledState tab: self.
	closeable := true.
	label := self buildLabel: 'tab' withIcon: self defaultIcon.
	closeIcon := AlphaImageMorph withForm: self class closeIcon scaledByDisplayScaleFactor.
	actions := OrderedCollection new.
	retrievingSemaphore := Semaphore new.

	self addLabel.
	self addIcon.
	self addActionsToIcon! !

!TabMorph methodsFor: 'protocol' stamp: ''!
label: aString

	label morph: aString asMorph! !

!TabMorph methodsFor: 'protocol' stamp: ''!
okToClose
	model ifNil: [ ^true ].
	^model okToClose! !

!TabMorph methodsFor: 'icons - actions' stamp: ''!
addActionsToIcon

	closeIcon 
		on: #mouseEnter send: #mouseEnterIcon to: self;
		on: #click send: #close to: self;
		on: #mouseLeave send: #mouseLeaveIcon to: self! !

!TabMorph methodsFor: 'protocol' stamp: ''!
selected: aBoolean

	(state isSelectedMatchingTheState: aBoolean) 
		ifTrue: [ ^ self triggerEvent: #tabResetSelection with: self ].
	
	state := state newStateForSelected: aBoolean.
	aBoolean
		ifTrue: [ 
			self triggerEvent: #tabSelected with: self.
			self showCloseIcon ].
	
	"No need to change here since the toolbar Ibelong to will do it"! !

!TabMorph methodsFor: 'private' stamp: ''!
toggleSelection

	self selected
		ifTrue: [ self removeFromSelection ]
		ifFalse: [ self addToSelection ]! !

!TabMorph methodsFor: 'icons - actions' stamp: ''!
mouseEnterIcon

	closeable ifFalse: [ ^ self ].
	fadeOut ifNotNil: [ fadeOut terminate ].
	closeIcon image: self class closeOverIcon! !

!TabMorph methodsFor: 'protocol' stamp: ''!
closeable: anObject

	closeable := anObject.
	anObject 
		ifTrue: [ self showCloseIcon ]
		ifFalse: [ self hideCloseIcon ]! !

!TabMorph methodsFor: 'accessing' stamp: ''!
menu
	| newMenu |
	
	newMenu := MenuMorph new defaultTarget: self.
	menu ifNotNil: [ menu cull: newMenu ].
	
	self addRefreshMenuItemOn: newMenu.
	
	^ newMenu! !

!TabMorph methodsFor: 'protocol' stamp: ''!
morph: anObject

	morph := anObject.
	self triggerEvent: #tabRefreshed with: self! !

!TabMorph methodsFor: 'private - tab label' stamp: ''!
showIconTreshold

	^ (closeIcon visible
		ifTrue: [ 54 ]
		ifFalse: [ 40 ]) * self displayScaleFactor! !

!TabMorph methodsFor: 'accessing' stamp: ''!
enabled
	
	^ state enabled! !

!TabMorph methodsFor: 'private' stamp: ''!
addToSelection

	self triggerEvent: #tabAddedToSelection with: self.
	
	"No need to change here since the toolbar I belong to will do it"! !

!TabMorph methodsFor: 'protocol' stamp: ''!
waitReadyMorphFor: timeoutDuration
	"This method allow wait some small duration until morph will be ready.
	Clients could use it to not show loading progress if it is really fast process.
	Instead some blinking could happen"

	morph ifNotNil: [ ^self].
	retrievingSemaphore wait: timeoutDuration! !

!TabMorph methodsFor: 'private - icons' stamp: ''!
defaultIcon
	^ self iconNamed: #blankIcon! !

!TabMorph methodsFor: 'private - constants' stamp: ''!
labelBottomOffset

	^ 5 * self displayScaleFactor! !

!TabMorph methodsFor: 'events - handling' stamp: ''!
handlesMouseDown: event

	^ true! !

!TabMorph methodsFor: 'events - handling' stamp: ''!
mouseUp: event

	(event commandKeyPressed or: [ event controlKeyPressed ])
		ifTrue: [ self toggleSelection ]
		ifFalse: [ 
			event shiftPressed
				ifTrue: [ self selectToMe ]
				ifFalse: [ self selected: true ] ]! !

!TabMorph methodsFor: 'private' stamp: ''!
addRefreshMenuItemOn: aMenu
	"I have a block for retrieving my contents, so I install a menu action for this"
	
	retrievingBlock ifNil: [ ^ self ].
	aMenu addLine.
	aMenu
		add: 'Refresh content'
		target: self
		selector: #refreshContent! !

!TabMorph methodsFor: 'private - tab label' stamp: ''!
modifyClippingBounds: clippingBounds
	| rightOffset |

	rightOffset := -10.
	closeIcon visible ifTrue: [ rightOffset := rightOffset - 14 ].

	^ clippingBounds withRight: (clippingBounds right + rightOffset) * self displayScaleFactor! !

!TabMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	| borderVertices vertices |
	
	borderVertices := self buildBorderVertices.
	vertices := self buildVerticesFrom: borderVertices.
	
	aCanvas
		drawPolygon: vertices
		color: self backgroundColor
		borderWidth: 0
		borderColor: Color transparent.
		
	borderVertices overlappingPairsDo: [ :start :end | 
		aCanvas
			line: start
			to: end
			width: 1
			color: self borderColor ]! !

!TabMorph methodsFor: 'private - drawing' stamp: ''!
backgroundColor
	^ state backgroundColor! !

!TabMorph methodsFor: 'protocol' stamp: ''!
silentlySelected: aBoolean

	(state isSelectedMatchingTheState: aBoolean) 
		ifTrue: [ ^ self ].
	
	state := state newStateForSelected: aBoolean.
	aBoolean
		ifTrue: [ self showCloseIcon ].
	
	"No need to change here since the toolbar Ibelong to will do it"! !

!TabMorph methodsFor: 'private - drawing' stamp: ''!
buildVerticesFrom: borderVertices
	
	^ state buildVerticesFrom: borderVertices! !

!TabMorph methodsFor: 'events - processing' stamp: ''!
handleMouseUp: anEvent
	anEvent blueButtonChanged
		ifTrue: [ self blueButtonUp: anEvent ]
		ifFalse: [ super handleMouseUp: anEvent ]! !

!TabMorph methodsFor: 'accessing' stamp: ''!
selected
	
	^ state selected! !

!TabMorph methodsFor: 'protocol' stamp: ''!
extraSpaceForActions
	| space offsets |
	
	space := 0.
	offsets := 1.
	
	self hasMenu ifTrue: [ 
		offsets := offsets +1.
		space := space + self menuIcon width ].
	
	self actions do: [ :each | 
		space := space + each icon width.
		offsets := offsets +1 ].
	
	^ space + (offsets * self actionOffset)! !

!TabMorph methodsFor: 'protocol' stamp: ''!
showCloseIcon

	closeable
		ifTrue: [ closeIcon show ]! !

!TabMorph methodsFor: 'protocol' stamp: ''!
retrieveMorph: aBlock
	"This is a hard request. The result is blocking contrary to softRetrieveMorph.
	Late binding so the morph may be built only on demand"

	morph ifNotNil: [ 
		aBlock value: morph.
		^ nil ].
	retrievingSemaphore isSignaled
		ifFalse: [ self softRetrieveMorph ].

	^ [ retrievingSemaphore wait.
		morph ifNotNil: [ 
			UIManager default defer: [aBlock value: morph ]]] 
				fork! !

!TabMorph methodsFor: 'protocol' stamp: ''!
addAction: anAction

	actions add: anAction! !

!TabMorph methodsFor: 'protocol' stamp: ''!
icon

	^ label icon! !

!TabMorph methodsFor: 'private - constants' stamp: ''!
iconRightOffset

	^ 10 * self displayScaleFactor! !

!TabMorph methodsFor: 'protocol' stamp: ''!
close

	closeable ifFalse: [ ^ self ].
	self okToClose ifFalse: [ ^self ].
	self delete! !

!TabMorph methodsFor: '*Calypso-Browser' stamp: ''!
markDirty: aBoolean
	| currentLabel |
	
	"we want escape getting label from actual model because it simplified things 
	and in remote scenario it will not make any request to server"
	currentLabel := self label morph contents.
	
	aBoolean 
		ifTrue: [ 
			self label: '*', currentLabel ]
		ifFalse: [ 
			(currentLabel beginsWith: '*') 
				ifTrue: [ self label: currentLabel allButFirst ] ]! !

!TabMorph methodsFor: 'protocol' stamp: ''!
enabled: aBoolean

	(state isEnabledMatchingTheState: aBoolean) ifTrue: [ ^ self ].
	
	state := state newStateForEnabled: aBoolean.
	label enabled: aBoolean.
	self changed! !

!TabMorph methodsFor: 'private - icons' stamp: ''!
menuIcon
	
	^ self class menuIcon! !

!TabMorph methodsFor: 'private - drawing' stamp: ''!
borderColor
	"I do not use #borderColor because I want a light border"
	^ self theme lightBackgroundColor! !

!TabMorph methodsFor: 'private' stamp: ''!
selectToMe

	self triggerEvent: #tabSelectTo with: self.
	
	"No need to change here since the toolbar I belong to will do it"! !

!TabMorph methodsFor: 'meta-actions' stamp: ''!
blueButtonUp: anEvent
	super blueButtonUp: anEvent.
	self close! !

!TabMorph methodsFor: 'accessing - defaults' stamp: ''!
defaultBounds
	^ 0@0 corner: (100@(self class defaultHeight)) * self displayScaleFactor! !

!TabMorph methodsFor: 'protocol' stamp: ''!
hideCloseIcon

	closeIcon hide! !

!TabMorph methodsFor: 'accessing' stamp: ''!
actions

	^ actions! !

!TabMorph methodsFor: 'accessing' stamp: ''!
retrievingBlock: anObject

	retrievingBlock := anObject.
	retrievingBlock ifNotNil: [ self softRetrieveMorph ].! !

!TabMorph methodsFor: 'private - icons' stamp: ''!
addIcon

	self
		addMorph: closeIcon 
		fullFrame: (LayoutFrame identity
			bottomFraction: 0;
			leftFraction: 1;
			topOffset: 6 * self displayScaleFactor; 
			leftOffset: self iconRightOffset negated - (12 * self displayScaleFactor);
			rightOffset: self iconRightOffset negated;
			bottomOffset: (18 * self displayScaleFactor); 
			yourself)! !

!TabMorph methodsFor: 'icons - actions' stamp: ''!
mouseLeaveIcon

	closeable ifFalse: [ ^ self ].
	fadeOut ifNotNil: [ fadeOut terminate ].
	fadeOut := [ 
		closeIcon image: self class closeHalfOverIcon.
		50 milliSeconds asDelay wait.
		closeIcon image: self class closeIcon ] fork! !

!TabMorph methodsFor: 'private - drawing' stamp: ''!
buildBorderVertices
	
	^ state buildBorderVertices! !

!TabMorph methodsFor: 'events - handling' stamp: ''!
mouseDown: event
	self flag: #pharoTodo. "Add drag"! !

!TabMorph methodsFor: 'private' stamp: ''!
removeFromSelection

	self triggerEvent: #tabRemovedFromSelection with: self.
	
	"No need to change here since the toolbar I belong to will do it"! !

!TabMorph methodsFor: 'accessing' stamp: ''!
model: aModel

	model := aModel! !

!TabMorph methodsFor: 'protocol' stamp: ''!
updateShowIcon

	(self selected not and: [ self width < 100 ])
		ifTrue: [ self hideCloseIcon ]
		ifFalse: [ self showCloseIcon ]! !

!TabMorph methodsFor: 'accessing' stamp: ''!
setActionsFrom: aBlock

	self actions: aBlock value! !

!TabMorph methodsFor: 'accessing' stamp: ''!
closeable
	^ closeable! !

!TabMorph class methodsFor: 'icons' stamp: ''!
refreshIcon1

	^ Icons 
		at: #refreshIcon1
		ifAbsentPut: [ self refreshIcon1Contents ]! !

!TabMorph class methodsFor: 'icons' stamp: ''!
closeOverIcon

	^ Icons
		at: #closeOverIcon
		ifAbsentPut: [ self closeOverIconContents ]! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
closeHalfOverIconContents

	^ Form
		extent: 12@12
		depth: 32
		fromArray: #(16777215 16777215 16777216 869400576 1523908608 1943339008 1943339008 1523908608 869400576 16777216 16777215 16777215 16777215 232259584 1624571904 2161311744 2161311744 2161311744 2161311744 2161311744 2161311744 1624571904 232259584 16777215 16777216 1624571904 3262657845 3429841466 2161311744 2161311744 2161311744 2161311744 3429841466 3262657845 1624571904 16777216 869400576 2161311744 3429841466 4283256141 3413129529 2161311744 2161311744 3413129529 4283256141 3429841466 2161311744 869400576 1523908608 2161311744 2161311744 3413129529 4283256141 3396352313 3396352313 4283256141 3413129529 2161311744 2161311744 1523908608 1943339008 2161311744 2161311744 2161311744 3396352313 4283256141 4283256141 3396352313 2161311744 2161311744 2161311744 1943339008 1943339008 2161311744 2161311744 2161311744 3396352313 4283256141 4283256141 3396352313 2161311744 2161311744 2161311744 1943339008 1523908608 2161311744 2161311744 3413129529 4283256141 3396352313 3396352313 4283256141 3413129529 2161311744 2161311744 1523908608 869400576 2161311744 3429841466 4283256141 3413129529 2161311744 2161311744 3413129529 4283256141 3429841466 2161311744 869400576 16777216 1624571904 3262657845 3429841466 2161311744 2161311744 2161311744 2161311744 3429841466 3262657845 1624571904 16777216 16777215 232259584 1624571904 2161311744 2161311744 2161311744 2161311744 2161311744 2161311744 1624571904 232259584 16777215 16777215 16777215 16777216 869400576 1523908608 1943339008 1943339008 1523908608 869400576 16777216 16777215 16777215)
		offset: 0@0! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
refreshIcon9Contents

	^ 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 289575996 440372534 155686977 0 0 0 0 0 0 0 0 36936489 67128576 67528960 0 323524927 1396738360 2218755126 1196134469 371815206 33575424 0 0 0 0 89638474 223059779 809798206 1211595570 573009187 67124992 575906634 2672398658 3746731595 3109262669 1665304126 219965722 0 0 0 157664086 928161864 1817615695 2656870230 3008533837 2017493820 540507697 1029089356 2925504599 4285246819 4201820524 2824510035 1077048877 118840593 0 0 409253207 1901699919 3126961753 4117868907 4083919974 3243414605 1396277044 1296669248 2925504854 4068260979 4286758522 3697517148 1950384955 321021983 0 0 139703111 1078893636 3261574496 4269653366 4269060973 3612447564 1898934828 909147433 1868342866 3632053619 4287021950 3983256163 2303100992 488924704 0 0 0 1214032211 3144988267 4270112891 3933253225 2722333759 1293901597 335556864 1062379337 3178148454 4236427643 4016876389 2336852803 488991521 0 0 223787853 1684780641 3800022645 4236492411 3177752417 1262124853 167776000 0 1046063183 3228677481 4286692986 3765415529 1816627777 253648920 0 0 291422802 2323432049 3985426563 4186489472 2909054558 658082099 46332305 678544995 2003876453 3766205554 4270113149 3362302305 1246005823 83890432 0 0 661702499 2625685109 4170304648 4203661190 3160909921 1379567156 744470611 1853409644 3565012083 4204055948 4186555010 2942937441 892896305 35016724 0 0 511103337 2273429879 3952529805 4288138895 3681923693 2152238657 1061130039 1971178099 3700412293 4288270481 4152935041 3109986390 1346341177 153255454 0 0 308922717 1652476530 3633237636 4287810441 4151751789 2723058502 1043496236 1182123370 2827669377 3817786501 3548101491 2455741272 1212123705 254903339 0 0 0 846645864 2692793717 3867460732 4151226471 2639304264 640317220 277145719 1568393586 2172372081 1802680424 844275274 273588554 54040627 0 0 0 208264538 1131594088 2708322149 3579553363 1867619657 289311798 31260606 275698785 494127719 276287082 73979227 0 0 0 0 0 0 224640601 844869458 1431610443 760259400 0 0 0 0 0 0 0 0 0)
		offset: 0@0! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
closeOverIconContents

	^ Form
		extent: 12@12
		depth: 32
		fromArray: #(16777215 16777215 33488896 1708392448 3017015296 3872653312 3872653312 3017015296 1708392448 33488896 16777215 16777215 16777215 450363392 3218341888 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 3218341888 450363392 16777215 33488896 3218341888 4289940556 4290339683 4292018176 4292083712 4292083712 4292018176 4290339683 4289940556 3218341888 33488896 1708392448 4292083712 4290339683 4294704123 4290339683 4292018176 4292018176 4290339683 4294704123 4290339683 4292083712 1708392448 3017015296 4292083712 4292018176 4290339683 4294704123 4290338912 4290338912 4294704123 4290339683 4292018176 4292083712 3017015296 3872653312 4292083712 4292083712 4292018176 4290338912 4294704123 4294704123 4290338912 4292018176 4292083712 4292083712 3872653312 3872653312 4292083712 4292083712 4292018176 4290338912 4294704123 4294704123 4290338912 4292018176 4292083712 4292083712 3872653312 3017015296 4292083712 4292018176 4290339683 4294704123 4290338912 4290338912 4294704123 4290339683 4292018176 4292083712 3017015296 1708392448 4292083712 4290339683 4294704123 4290339683 4292018176 4292018176 4290339683 4294704123 4290339683 4292083712 1708392448 33488896 3218341888 4289940556 4290339683 4292018176 4292083712 4292083712 4292018176 4290339683 4289940556 3218341888 33488896 16777215 450363392 3218341888 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 3218341888 450363392 16777215 16777215 16777215 33488896 1708392448 3017015296 3872653312 3872653312 3017015296 1708392448 33488896 16777215 16777215)
		offset: 0@0! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
closeIconContents

	^ 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 2219658573 2555202893 16777216 16777215 16777215 16777216 2555202893 2219658573 16777215 16777215 16777215 16777215 2555202893 4283256141 2538359884 16777216 16777216 2538359884 4283256141 2555202893 16777215 16777215 16777215 16777215 16777216 2538359884 4283256141 2488159822 2488159822 4283256141 2538359884 16777216 16777215 16777215 16777215 16777215 16777215 16777216 2488159822 4283256141 4283256141 2488159822 16777216 16777215 16777215 16777215 16777215 16777215 16777215 16777216 2488159822 4283256141 4283256141 2488159822 16777216 16777215 16777215 16777215 16777215 16777215 16777216 2538359884 4283256141 2488159822 2488159822 4283256141 2538359884 16777216 16777215 16777215 16777215 16777215 2555202893 4283256141 2538359884 16777216 16777216 2538359884 4283256141 2555202893 16777215 16777215 16777215 16777215 2219658573 2555202893 16777216 16777215 16777215 16777216 2555202893 2219658573 16777215 16777215 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! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
refreshIcon10Contents

	^ Form
		extent: 16@16
		depth: 32
		fromArray: #(0 0 0 0 0 24965223 0 0 0 0 0 0 0 0 0 0 0 0 0 0 142401386 508995915 575841097 172795971 171609395 0 0 0 0 0 0 0 0 0 0 0 509259086 1935320144 2153357393 1918409809 1296271422 539520547 50431232 0 0 21606215 0 0 0 0 0 0 776641344 2573182807 3714821476 3664292451 2907804748 1144486963 67118080 106278475 356683834 323196477 88120119 0 0 0 87740209 861909334 2037101154 3497244267 4269653366 4285706860 3428424532 1463714105 289443895 676569674 1799588924 1799193396 574721081 0 0 191092052 980796521 2390409071 3766402420 4186226811 4252743795 4033259104 3209531208 1329168179 1028563268 2237310290 3495073867 3175911493 1162711879 119633438 91416929 846777708 2558576501 3800943236 4270507393 3917265012 3194398047 2722333759 2033218350 1143632933 1817354569 3362172510 4285312612 3814826587 1934002754 304509477 275369308 1652410738 3415199366 4287876234 4052206207 2925897567 1296534849 740581665 621232135 573074978 1885251668 3732651122 4286692985 3832458600 1984859975 186083605 477416806 2223361402 3969175947 4288204688 3614880623 1917818442 287276055 0 0 675714877 2439622753 3967926649 4286758521 3663962716 1749124155 287139352 594857318 2659305334 4069510022 4287021437 3295258721 1614710839 727693651 896978024 1164688223 2003481184 3463689836 4236427643 4168200297 2941621838 1261861682 100683264 493996646 2339881070 4001152372 4084248680 2790364488 1278640687 1416346977 2591869041 3246179186 3749494131 4219649914 4168660594 3361841499 1950516540 455238686 34165767 291223121 1751429979 3663570773 2958597968 1581287480 792431412 1719717238 3633303685 4237741966 4287613063 4001217398 3160844128 1766296129 623998507 83905280 0 90095955 810788938 1565762379 1196399687 304839716 243131760 1921372028 3650146183 4271164556 4085628798 2993334626 1431147334 472870955 16777216 0 0 0 89504329 274249039 40821860 0 210300795 1501153391 2843920249 3531390068 3228084576 2102301767 522614559 0 0 0 0 0 0 0 0 0 39777866 443994473 1165278825 1533521502 1700109134 1144751925 187403302 0 0 0 0 0 0 0 0 0 0 41145701 75955315 206613319 240495952 272141619 52661788 0 0 0 0)
		offset: 0@0! !

!TabMorph class methodsFor: 'icons' stamp: ''!
refreshIcon9

	^ Icons 
		at: #refreshIcon9
		ifAbsentPut: [ self refreshIcon9Contents ]! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
refreshIcon1Contents

	^ 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 1918411854 0 0 0 0 0 0 0 0 0 74170463 224573016 358395218 425108812 424581958 424120639 3796998729 2219545155 0 0 0 0 0 0 0 258785377 1483455585 3077815657 4033919079 4285248097 4284787292 4284326485 4285837932 4150568029 1949990196 84164352 0 0 0 0 141673060 2036971870 3984639095 4288007307 4288598421 4288992667 4288664983 4288336274 4287679624 4286298997 3846341437 924803099 0 0 0 0 1248311133 4017798768 4288729751 4288664215 4287152768 4284917343 4284193876 4283733070 4285048929 4216887635 2368696107 269899029 0 0 0 0 2774576726 4287613062 4288664471 4235966323 3528233285 1480558136 1026585898 1042836516 3929042988 2536270631 0 0 0 0 0 0 3948323406 4283800909 4283405639 3510995518 1044021042 0 0 0 2216779550 408331084 1465887829 1347788876 1330550598 1413909823 0 0 1632474693 1631948094 1631487032 1698134833 556164899 1685243238 225625702 0 0 475571792 3075645002 4148991300 4165241661 4114448694 0 0 0 0 0 0 1769128807 3815685475 761508440 424779592 642816840 3126041931 4151225958 4288139152 4286626937 3208346934 0 0 0 0 73578836 1567670373 4001810556 4287613573 4285576806 4284919134 4284655450 4286364020 4287678856 4287219330 4267285075 1798336811 0 0 0 0 560380762 3530866026 4288270224 4289255071 4289058461 4288664728 4288270738 4287350659 4285970287 4200373590 2637131819 371089436 0 0 0 0 157332566 1919332444 4084906610 4286824059 4284917599 4284325462 4283864913 4216295241 3494151486 2133749289 538729239 0 0 0 0 0 0 35359503 2102697036 3947729734 1312786232 1043626541 1026322727 891709472 572415514 169367061 0 0 0 0 0 0 0 0 39363658 1950056501 188581687 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! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
refreshIcon6Contents

	^ 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 238519345 35020813 0 0 0 0 0 0 0 0 0 0 34619404 67128832 50331648 455899943 1446741045 608670018 0 0 0 0 0 0 0 34147080 286544913 1009544488 1144354607 1329299253 1245743161 2219479363 2908133967 2052891221 593275729 0 0 0 0 0 0 908289567 2084536634 3041758791 3545930580 3680740446 3664620903 3782718319 4135631737 3766205299 2004204651 308921436 0 0 0 0 640775725 2336589632 3898383446 4235440492 4286561656 4286955903 4287218817 4288007053 4288532885 4069707401 2759640179 862633824 0 0 0 220753701 1983478836 3697846113 4286692986 4287087487 4035035257 3715084903 3463624298 3917266546 4153593480 3565997443 1820314741 209575792 0 0 0 458068297 2722860613 4251428705 4286496118 3950623089 2640554586 1364566092 911779661 1701558879 3010773352 1786431343 693545037 83886080 154961973 90425688 18831128 876249651 2990572856 3847197768 3579683925 2740560976 1145608255 167783680 0 343463274 947572844 1112316484 1244427559 1698399028 1850381635 1347394887 0 256546115 1429963572 1598657345 1532602192 1263377987 959345706 1260215579 385890048 0 457018420 1479900462 3058734408 3814695512 4099843414 3260457806 0 0 123843675 91934319 33554407 825259563 2335931703 2989914163 1999992625 993953592 1950649150 3009323352 4001085299 4287087231 4085498492 2473243746 0 0 0 0 488727837 2118288445 3898120530 4217742687 3798377568 3547048292 3815944299 4136092031 4271821205 4288205199 3531851128 1567669606 0 0 0 101733130 908815654 3192425284 4151291753 4286759035 4286955901 4287153023 4270967176 4287875979 4069707145 3448491137 2071446124 392807517 0 0 0 0 489253666 1968017479 3664226402 4134711914 3647844710 3530864234 3497507437 3263349881 2843328879 1551352940 527156831 53856803 0 0 0 0 0 625709637 2186451274 2891489360 1431412041 978493513 979086675 778614622 594199136 225431905 0 0 0 0 0 0 0 53183778 693214791 1515889999 222733371 0 0 0 0 0 0 0)
		offset: 0@0! !

!TabMorph class methodsFor: 'instance creation' stamp: ''!
label: label icon: icon morph: morph

	^ self new
		label: label;
		icon: icon;
		morph: morph;
		yourself! !

!TabMorph class methodsFor: 'icons' stamp: ''!
closeIcon

	^ Icons
		at: #closeIcon
		ifAbsentPut: [ self closeIconContents ]! !

!TabMorph class methodsFor: 'instance creation' stamp: ''!
label: label icon: icon retrievingBlock: morph

	^ self new
		label: label;
		icon: icon;
		retrievingBlock: morph;
		yourself! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
refreshIcon7Contents

	^ 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 33561088 0 0 0 0 0 0 0 0 0 0 0 0 0 287730978 607287342 1127051304 1227977773 841903913 471818779 16784128 0 0 0 0 0 0 0 71471676 441357130 1899658805 2773915472 3260388943 3377829199 3008204359 1967556672 909079337 169762073 0 20350256 37198896 0 0 0 507217460 2168489272 3528890448 4252020586 4269915770 4286232434 4168463470 3865421151 2774178900 1279363642 993625395 1026916656 305694770 0 0 0 591366456 2453702200 3947926857 4218598250 4269981818 4119184253 4236427386 4286955903 4101617522 3446582374 2975571539 2253230918 592090181 0 0 0 173649746 1011257918 2169806412 3076236626 3043470686 2657397595 2993336162 3799365485 4253861508 4220569481 4135697786 3010244196 844735824 0 0 0 0 0 559722066 1313775684 1128502074 608473147 726309440 1953149792 3900555123 4288401810 4237676173 3279863925 1114750054 0 0 0 101932045 404578841 825390638 1446411058 1294494245 553926148 0 845659738 2960572779 3784166787 3566063236 2658977139 829342052 0 0 0 505307416 2067562296 2974650184 3478032457 2973136947 1142906909 0 361228663 1618200167 1702545518 1467861875 779997810 291816536 0 0 0 758808116 2857341514 4100894312 4285509481 3781140057 1967425087 472348961 456952884 976980274 1077379889 506032931 0 0 0 0 0 575377989 2757665112 4168266348 4286890620 4219320693 3563825508 2572786771 2286719559 2387382596 2638777921 1832879928 843091001 41418599 0 0 0 508336195 2253560650 3412306011 3664621926 4169318265 4270572674 4118854777 3900750969 4001216885 4084314217 3915227733 2404556106 776970055 58061673 0 0 274049353 1532667215 1263508550 1499112786 3044128103 3934569082 4271098763 4288336018 4288467347 4287481989 4051155312 3310921040 894608202 89699664 0 0 0 208323932 0 221942066 928623697 2256125807 3330459000 3616263042 3683634821 3481585273 2490809965 1315025240 257142088 0 0 0 0 0 0 0 72724301 392215381 1198703463 1517732971 1584973421 1198768743 661439073 33604352 0 0)
		offset: 0@0! !

!TabMorph class methodsFor: 'icons' stamp: ''!
refreshIcon5

	^ Icons 
		at: #refreshIcon5
		ifAbsentPut: [ self refreshIcon5Contents ]! !

!TabMorph class methodsFor: 'icons' stamp: ''!
menuIcon

	^ self theme windowMenuForm! !

!TabMorph class methodsFor: 'accessing' stamp: ''!
defaultHeight
	^ 22! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
refreshIcon5Contents

	^ 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 36733993 288717871 0 33571840 0 0 0 0 0 0 0 0 0 0 0 0 54034738 1413055027 1900909896 1298312025 1064024160 258591069 0 0 0 0 0 0 0 0 0 0 218126080 2135395904 3479414108 3782916722 3179135348 1718533476 124705120 0 40555870 273719368 0 0 0 0 0 371617057 1228900153 3059588949 4186357631 4288269969 3885026951 1954531957 16842496 170619686 1112250179 1615961673 626173001 0 0 0 472672807 1715240758 3428621911 4118723191 4287941260 4288467603 3968584577 1551747698 589788450 1547206706 3075578186 4250510417 1751034965 0 0 219368721 2084141620 3613039444 4286298230 4270441858 4101355629 3396713578 3061105000 1449769310 1194161192 3158871617 4201557863 4118855801 2389949546 0 50331648 1210871335 3125842250 4285575017 4253664897 3715019110 1784851033 811446096 880135016 762299490 1446280237 3496322653 4287349890 4153855885 2926886249 0 184566016 1714780208 3932003671 4286955902 4135500918 2573116757 372344104 0 0 167789824 1816299835 3782258537 4288532628 4254256777 2306721138 0 0 2084470841 3983584873 4287219330 3917002864 1817683022 405171231 789663504 538465812 977044534 3143146578 4119380608 4287941772 3616328578 1618396011 0 151341316 2000321845 4016284509 4285706859 3663570261 1917688899 976056617 2469162281 2839182390 3311312216 4017796722 4287744392 4019112325 2843000427 712033637 0 0 994609987 3527904064 3763180358 2337710158 978691915 1043626031 3561392194 4217808480 4286495351 4236887424 4185438574 2490349414 862500446 34530304 0 0 456884788 2100985907 1899988791 542417739 39843158 1345483566 3696793938 4286298740 4286824827 3614290278 1952557400 659333188 0 0 0 0 0 189832265 290100547 33554431 16777216 1160671530 3309997126 3865684324 4016679522 2656476750 254117662 0 0 0 0 0 0 0 0 0 16790528 505241111 1194883634 1901172043 2270337354 2287510094 458926927 0 0 0 0 0 0 0 0 0 0 0 33570304 0 440964160 391621196 141676900 0 0 0)
		offset: 0@0! !

!TabMorph class methodsFor: 'class initialization' stamp: ''!
initialize

	Icons := Dictionary new.! !

!TabMorph class methodsFor: 'icons' stamp: ''!
refreshIcon10

	^ Icons 
		at: #refreshIcon10
		ifAbsentPut: [ self refreshIcon10Contents ]! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
refreshIcon2Contents

	^ Form
		extent: 16@16
		depth: 32
		fromArray: #(0 0 0 0 0 0 0 74831464 0 0 0 0 0 0 0 0 0 0 0 0 375502935 1013430619 1500298594 1433124192 963493219 0 0 0 0 0 0 0 0 0 0 1112975436 2574170212 3950690160 4102539134 3951675263 3849829998 2540221279 357737288 0 0 157067857 0 0 0 0 475439950 3998720847 4286364532 4288796057 4288992411 4288598677 4288598421 4286627702 3630279257 810851916 843749186 1884923215 0 0 0 0 894211396 2504890181 4132411207 4285575016 4236032116 4202346354 4286363765 4288532885 4287219329 4284392278 3982402390 2521535555 34755853 22126153 0 0 0 624854583 1799325241 3191768375 2420673856 2302576183 2588906569 4284193876 4286823804 4287810954 4285969519 2992151121 0 0 0 0 0 0 167784448 1060139819 438988836 0 420501771 1396342324 3998520654 4286167154 4269324659 3209070400 405170464 0 0 0 71615025 610843741 981191535 1651622758 2372779873 578474350 0 740056601 3928977196 3846801732 3376645183 2452911407 369510403 0 0 0 627686494 3413359977 3951741568 4136159614 3178347878 87208481 0 1075533848 1395222820 1093430566 285753864 185486606 34230791 0 0 0 811576660 3564813425 4288598421 4288795544 4252022374 1885251669 33576192 157861469 493140058 1532996693 409120856 0 0 0 0 0 390698305 3295128415 4270178429 4288006542 4288467605 4285378917 3143476053 3142884940 3277562707 3612055363 2051708226 777034312 71930178 0 0 0 28374419 3058011455 3042154572 3831209556 4286034800 4288270738 4286890364 4253467006 4287021439 4286692985 4266102080 3024127545 440831295 0 0 0 154367789 1295613747 354842143 1043692590 3058404934 4284193622 4286232690 4286627448 4287153537 4286363765 3948320592 2553970227 0 0 0 0 0 0 0 101601033 605445393 2017230134 3460597054 3629158730 3645541188 3108275775 1814916904 23188057 0 0 0 0 0 0 0 0 0 167781888 589785122 1075731994 907960090 337535772 136076824 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
		offset: 0@0! !

!TabMorph class methodsFor: 'icons' stamp: ''!
refreshIcon8

	^ Icons 
		at: #refreshIcon8
		ifAbsentPut: [ self refreshIcon8Contents ]! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
refreshIcon3Contents

	^ Form
		extent: 16@16
		depth: 32
		fromArray: #(0 0 0 0 0 0 0 592553543 660648789 341949526 190297161 0 0 0 0 0 0 0 0 0 0 290297413 1414569032 4032406865 3128146282 3010706536 1701887589 727891288 44105614 0 0 0 0 0 0 0 0 56474195 1665897795 4048919885 4287350148 4288139406 4035496062 2424030065 778682206 22654542 0 0 0 0 0 0 0 0 893157942 3242823746 4285772395 4288335249 4288664470 4186359421 2473507429 0 0 0 0 0 0 140494417 375898459 124311385 218511878 2301917998 3142686026 3983913837 4287349891 4288532628 3530930795 610053202 0 0 0 0 155625272 1231862114 3279142249 1837288311 1013365595 876381237 909014055 2336196408 3698043748 4288138639 4286167663 1868014415 16843010 0 0 0 373856064 2977085033 4170173062 4287614085 3112159092 2305671009 162594719 505703967 2857144646 4286166129 4287087999 2505810515 389779508 324709455 0 0 1867223877 3782061926 4288138383 4288795544 3916807530 1131265889 114294716 100663296 1413185333 4050496103 4287547783 4284852573 2941820751 1901700431 0 490175793 2218690104 3142949454 4219451768 4288467349 3681465444 625909317 0 588337167 2939055915 4284062291 4287088000 4269192303 3059063374 709267774 0 54033970 185162499 1144948535 3764297815 4287415685 4268667494 1398382929 0 991977244 2351655720 3746072643 4133856864 3797654870 1733201991 0 0 0 0 471951643 2991361863 4286692475 4237019011 3445729113 1968217415 510114652 994282554 858483239 2369288499 2352313904 371287323 0 0 0 0 83886080 1799126838 4150173272 4286824827 4270244222 3849302375 3259996998 1616356942 40819295 100674560 370694932 33554432 0 0 0 0 0 892169000 3376710974 4151159910 4287219330 4287284611 4100763492 2202703170 341683540 0 0 0 0 0 0 0 0 83891200 1311731754 3192424770 4032929882 4252809589 4284128339 3544221497 877171009 0 0 0 0 0 0 0 0 0 268451840 874274328 2067365173 2789311036 3058338884 2587524915 491163199 23776609 0 0 0 0 0 0 0 0 0 33569792 16777216 488464665 0 221411115 0 0 0 0 0)
		offset: 0@0! !

!TabMorph class methodsFor: 'instance creation' stamp: ''!
label: label icon: icon retrievingBlock: morph actions: aCollection

	^ self new
		label: label;
		icon: icon;
		retrievingBlock: morph;
		addActions: aCollection;
		yourself! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
refreshIcon8Contents

	^ 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 121476406 490769208 424580170 640578858 236610840 102324245 0 0 0 0 0 0 0 0 0 39634005 658475576 2168357685 2739703622 2639105864 1951174214 1093431335 337733150 0 0 0 0 0 0 0 0 44105625 960663098 3074854207 4149976404 4235309163 3731334752 2974781513 1429896245 303520019 0 0 0 0 0 0 17466368 0 491954761 2287312717 3865685345 4286627448 4286824315 4016876132 2941095495 1060469040 33563904 0 0 0 0 101208064 438462237 337009682 323590977 1381344843 2875041620 3614881901 4119250046 4286495862 3781600864 1850182209 303059978 0 0 0 54894397 708345138 2034205242 2135065918 1312455989 1178043441 1145476668 1851565651 3161371238 4169318523 4152014708 2740624468 640777003 0 0 0 273126975 1817549135 3462307928 3831669597 3394080840 1949266476 739727124 355040032 1734453848 3799365485 4286824572 3446582630 1531613506 556563239 70550575 89504327 978295622 2774311253 4134711916 4286167154 3999244121 2503309106 621233415 0 1113764439 3396975727 4287744393 4018388348 3042811733 1698859836 473269295 174242644 1549444431 2623316819 3899502950 4253336188 3933253225 2000979519 252401416 83886046 1450164835 3615343475 4271624594 4287613064 3446780265 1683200332 289969988 46202788 358395728 994876227 2590486111 4152541049 4068259700 2589695317 641239090 358266957 1567868519 2844118139 3918647175 3868117893 2843196014 828090450 56409427 0 0 205297460 1885777756 3833577077 4287349890 3581063532 2320339784 1346078003 1061261625 1315946596 2022035324 2558313843 1366737515 292405089 0 0 0 54508600 1013298780 3145777782 4254256010 4220372613 3715741297 2891422287 1916568886 539389728 327343990 561368681 308988255 0 0 0 0 0 342016086 2239546481 3784034945 4238070419 4287875722 4118000235 3042154571 1060865588 16777216 56081483 0 0 0 0 0 0 107733085 997245796 2340538487 3650080389 4136684679 4269850489 3781141847 1699715911 106808146 0 0 0 0 0 0 0 0 110034812 863028837 1736230768 2743059572 2977348718 3344607058 1414635593 257406030 0 0 0 0)
		offset: 0@0! !

!TabMorph class methodsFor: 'icons' stamp: ''!
refreshIcon6

	^ Icons 
		at: #refreshIcon6
		ifAbsentPut: [ self refreshIcon6Contents ]! !

!TabMorph class methodsFor: 'icons' stamp: ''!
refreshIcon7

	^ Icons 
		at: #refreshIcon7
		ifAbsentPut: [ self refreshIcon7Contents ]! !

!TabMorph class methodsFor: 'icons' stamp: ''!
refreshIcon4

	^ Icons 
		at: #refreshIcon4
		ifAbsentPut: [ self refreshIcon4Contents ]! !

!TabMorph class methodsFor: 'icons' stamp: ''!
closeHalfOverIcon

	^ Icons
		at: #closeHalfOverIcon
		ifAbsentPut: [ self closeHalfOverIconContents ]! !

!TabMorph class methodsFor: 'instance creation' stamp: ''!
label: label icon: icon morph: morph actions: aCollection

	^ self new
		label: label;
		icon: icon;
		morph: morph;
		addActions: aCollection;
		yourself! !

!TabMorph class methodsFor: 'icons' stamp: ''!
refreshIcon2

	^ Icons 
		at: #refreshIcon2
		ifAbsentPut: [ self refreshIcon2Contents ]! !

!TabMorph class methodsFor: 'icons - contents' stamp: ''!
refreshIcon4Contents

	^ Form
		extent: 16@16
		depth: 32
		fromArray: #(0 0 0 0 0 0 0 0 0 0 89234760 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 759994436 1381278284 592619592 122466366 0 0 0 0 0 0 0 156416323 308789596 71948342 0 239308347 1850513220 4166492751 2959716960 913029984 0 0 0 0 0 0 507481656 1651357027 2473835625 1819328102 73397069 405169955 2739310143 4285378406 3951806595 2943663465 744930394 0 0 0 255295281 1547469878 2790825554 3816405361 4153330309 2928135037 829539942 1009348388 3091565374 4285969518 4288401554 3968518528 1618198888 206683720 0 0 0 1362854965 3243744080 4237017988 4288730007 4035693441 2088223852 859472692 2151843643 3933384810 4288532628 4187279243 2340144241 342870883 0 0 0 471756567 3025968724 4287349636 4254847122 3866475882 2305933925 795787617 1093103904 3311313239 4270638468 4287876234 2910174828 476495964 0 0 0 1194818610 3663502934 4270704262 4118067052 1784983641 410110307 0 522613025 3126303569 4187080841 4220504454 2507061348 0 0 0 119556892 1765572406 4000230505 4287284611 3446386787 558536770 0 83886080 808153381 3344867159 4287021181 4235836015 1532996438 34968584 0 0 286872086 2537587002 4284983136 4253664897 3462571866 860724292 369376770 1528848670 2822405174 4067273319 4287350659 3161437031 1045141827 0 0 0 269962772 2453569336 4134316901 4287284610 3866473837 1784062797 557548084 2284546856 4031417157 4286298740 4286824827 3512574805 507745595 38385723 0 0 251741185 1949858354 3965558103 4287219074 4185898359 3327171655 1230283593 1110800432 3478097994 4285706860 4252349295 3529220179 2237178446 459255892 0 0 67120128 924803868 3058601800 4236032373 4285575529 3025904467 1045997903 151009792 2201384753 3410792008 2790758737 1817023558 793680965 59043444 0 0 0 17958931 1697739821 3360591688 4065235527 2906753337 425306448 0 471950109 1261136934 490241073 0 0 0 0 0 0 0 167787008 1028098369 2637922356 1430292537 223716686 0 33564416 16777216 0 0 0 0 0 0 0 0 0 0 288849456 156607054 0 0 0 0 0 0 0 0)
		offset: 0@0! !

!TabMorph class methodsFor: 'icons' stamp: ''!
refreshIcon3

	^ Icons 
		at: #refreshIcon3
		ifAbsentPut: [ self refreshIcon3Contents ]! !

!TabPanelBorder commentStamp: ''!
Specialist border for a TabGroup panel. Does not draw border beneath selected tab.!
!TabPanelBorder class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!TabPanelBorderStyle commentStamp: ''!
Specialist border for a TabGroup panel. Does not draw border beneath selected tab.!
!TabPanelBorderStyle methodsFor: 'accessing' stamp: ''!
style
	"Answer #tabbed."
	
	^#tabbed! !

!TabPanelBorderStyle methodsFor: 'accessing' stamp: ''!
tabSelector: anObject
	"Set the value of tabSelector"

	tabSelector := anObject! !

!TabPanelBorderStyle methodsFor: 'accessing' stamp: ''!
selectedTab
	"Answer the currently selected tab."
	
	^(self tabSelector ifNil: [^nil]) selectedTab! !

!TabPanelBorderStyle methodsFor: 'drawing' stamp: ''!
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].
	r := aRectangle topLeft extent: w@aRectangle height.
	aCanvas fillRectangle: r color: self color. "left"
	r := aRectangle topRight - (w@0) extent: w@aRectangle height.
	aCanvas fillRectangle: r color: self color. "right"
	r := aRectangle bottomLeft + (w@h negated) extent: aRectangle width - w - w@h.
	aCanvas fillRectangle: r color: self color. "bottom"
	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"! !

!TabPanelBorderStyle methodsFor: 'accessing' stamp: ''!
tabSelector
	"Answer the value of tabSelector"

	^ tabSelector! !

!TabPresenter commentStamp: ''!
I am a spec presenter representing a single tab.

I should not be used without being contained into a TabManagerPresenter.

You can also have a look at TabsExample for another example.

!!!! #retrievingBlock: warning

If you specify #retrievingBlock: directly, you should also set the ownership of the appropriate. (See TabPresenter>>#model:)!
!TabPresenter methodsFor: 'api - valueHolder' stamp: ''!
iconHolder

	^ iconHolder! !

!TabPresenter methodsFor: 'api' stamp: ''!
menu: aBlock

	menuHolder value: aBlock! !

!TabPresenter methodsFor: 'api' stamp: ''!
iconName: aSymbol

	iconHolder value: (self iconNamed: aSymbol)! !

!TabPresenter methodsFor: 'api' stamp: ''!
tabSelectedAction

	^ tabSelectedActionHolder value! !

!TabPresenter methodsFor: 'api - valueHolder' stamp: ''!
morphHolder

	^ morphHolder! !

!TabPresenter methodsFor: 'api' stamp: ''!
retrievingBlock

	^ retrievingBlockHolder value! !

!TabPresenter methodsFor: 'api - valueHolder' stamp: ''!
retrievingBlockHolder

	^ retrievingBlockHolder! !

!TabPresenter methodsFor: 'api' stamp: ''!
icon

	^ iconHolder value! !

!TabPresenter methodsFor: 'api - valueHolder' stamp: ''!
labelHolder

	^ labelHolder! !

!TabPresenter methodsFor: 'api - valueHolder' stamp: ''!
closeableHolder

	^ closeableHolder! !

!TabPresenter methodsFor: 'api' stamp: ''!
contents

	^ morphHolder value! !

!TabPresenter methodsFor: 'api - events' stamp: ''!
whenTabSelected: aBlock

	tabSelectedActionHolder value: aBlock! !

!TabPresenter methodsFor: 'api' stamp: ''!
contents: aMorph

	morphHolder value: aMorph! !

!TabPresenter methodsFor: 'api' stamp: ''!
icon: aForm

	iconHolder value: aForm! !

!TabPresenter methodsFor: 'api' stamp: ''!
label

	^ labelHolder value! !

!TabPresenter methodsFor: 'api' stamp: ''!
actions: aCollection

	actionsHolder value: aCollection! !

!TabPresenter methodsFor: 'initialization' stamp: ''!
initialize
	"Initialization code for TabPresenter"

	super initialize.

	labelHolder := '' asValueHolder.
	iconHolder := self defaultIcon asValueHolder.
	morphHolder := nil asValueHolder.
	retrievingBlockHolder := nil asValueHolder.
	menuHolder := nil asValueHolder.
	actionsHolder := OrderedCollection new asValueHolder.
	closeableHolder := true asValueHolder.
	tabSelectedActionHolder := [  ] asValueHolder.
	selectedHolder := false asValueHolder! !

!TabPresenter methodsFor: 'initialization' stamp: ''!
initialExtent

	^ 200@25! !

!TabPresenter methodsFor: 'api' stamp: ''!
label: aString

	labelHolder value: aString! !

!TabPresenter methodsFor: 'api' stamp: ''!
actions

	^ actionsHolder value! !

!TabPresenter methodsFor: 'api' stamp: ''!
retrievingBlock: aBlock

	retrievingBlockHolder value: aBlock! !

!TabPresenter methodsFor: 'api' stamp: ''!
selected: aBoolean

	selectedHolder value: aBoolean! !

!TabPresenter methodsFor: 'api - valueHolder' stamp: ''!
tabSelectedActionHolder

	^ tabSelectedActionHolder! !

!TabPresenter methodsFor: 'api' stamp: ''!
closeable: aBoolean

	closeableHolder value: aBoolean! !

!TabPresenter methodsFor: 'api' stamp: ''!
menu

	^ menuHolder value! !

!TabPresenter methodsFor: 'api' stamp: ''!
presenter: aComposablePresenter
	aComposablePresenter owner: self.
	self retrievingBlock: [ aComposablePresenter buildWithSpec asWidget ]! !

!TabPresenter methodsFor: 'api - valueHolder' stamp: ''!
selectedHolder

	^ selectedHolder! !

!TabPresenter methodsFor: 'api - valueHolder' stamp: ''!
actionsHolder

	^ actionsHolder! !

!TabPresenter methodsFor: 'api' stamp: ''!
tabSelected 

	tabSelectedActionHolder value cull: self! !

!TabPresenter methodsFor: 'private' stamp: ''!
defaultIcon

	^ self iconNamed: #blankIcon! !

!TabPresenter methodsFor: 'api - valueHolder' stamp: ''!
menuHolder

	^ menuHolder! !

!TabPresenter methodsFor: 'api' stamp: ''!
closeable

	^ closeableHolder value! !

!TabPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(TabAdapter
		adapt: #(model))! !

!TabPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TabAdapter! !

!TabSelected commentStamp: ''!
I am the state of a selected tab!
!TabSelected class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!TabSelectedState commentStamp: ''!
I am the state of a selected tab!
!TabSelectedState methodsFor: 'protocol' stamp: ''!
backgroundColor
	^ Smalltalk ui theme selectionColor! !

!TabSelectedState methodsFor: 'protocol' stamp: ''!
newStateForSelected: aBoolean

	^ TabEnabledState tab: self tab! !

!TabSelectedState methodsFor: 'protocol' stamp: ''!
selected

	^ true! !

!TabSelectedState methodsFor: 'protocol' stamp: ''!
isSelectedMatchingTheState: aBoolean

	^ aBoolean! !

!TabSelectorMorph commentStamp: ''!
Row of tabs for a TabGroupMorph.!
!TabSelectorMorph methodsFor: 'operations' stamp: ''!
newEndSpacer
	"Answer a spacer to pad when rounded."

	^Morph new
		borderWidth: 0;
		color: Color transparent;
		extent: 6@0! !

!TabSelectorMorph methodsFor: 'tabs' stamp: ''!
tabsAndControls
	"Answer the tabs and scrolling controls that should be visible given the space."

	|visibleTabs firstIndex|
	self tabs ifEmpty: [
		self visibleTabRange: (1 to: 0).
		^#()].
	visibleTabs := self calculateVisibleTabs.
	visibleTabs ifEmpty: [
		self visibleTabRange: (1 to: 0).
		^#()].
	firstIndex := self tabs indexOf: visibleTabs first.
	self visibleTabRange: (firstIndex to: firstIndex + visibleTabs size - 1).
	visibleTabs size = self tabs size ifFalse: [
		visibleTabs
			add: self newSpacer;
			addAll: self controls.
		self cornerStyle = #rounded
			ifTrue: [visibleTabs add: self newEndSpacer]].
	^visibleTabs! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
tabs: anObject

	tabs := anObject! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
tabs

	^ tabs! !

!TabSelectorMorph methodsFor: 'event handling' stamp: ''!
keyboardFocusChange: aBoolean
	"The message is sent to a morph when its keyboard focus changes.
	Update for focus feedback."
	super keyboardFocusChange: aBoolean.
	self focusChanged! !

!TabSelectorMorph methodsFor: 'adding' stamp: ''!
addTab: aStringOrMorph selected: selectedStringOrMorph
	"Add a new tab with the given text or morph and alternate for when selected."
	
	self tabs add: (self newLabelMorph: aStringOrMorph selected: selectedStringOrMorph).
	self updateTabs! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
passivate
	"Update the non visible tabs too."

	super passivate.
	self nonVisibleTabs do: [:t | t passivate]! !

!TabSelectorMorph methodsFor: 'tabs' stamp: ''!
visibleTabs
	"Answer the tabs that are currently visible."

	^self tabs select: [:t | t owner notNil]! !

!TabSelectorMorph methodsFor: 'adding' stamp: ''!
addTab: aStringOrMorph
	"Add a new tab with the given text."
	
	self tabs add: (self newLabelMorph: aStringOrMorph).
	self updateTabs! !

!TabSelectorMorph methodsFor: 'geometry' stamp: ''!
minExtent
	"Add a bit for the round corner of the group."

	^self theme tabSelectorMorphMinExtentFor: self! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
newLabelMorph: aStringOrMorph selected: selectedStringOrMorph
	"Answer a new label morph with the given label text or morph and
	alternate when selected."

	^TabLabelMorph new
		roundedCorners: #(1 4);
		cornerStyle: self cornerStyle;
		changeTableLayout;
		listDirection: #leftToRight;
		listCentering: #center;
		layoutInset: (self theme tabLabelInsetFor: self);
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		label: aStringOrMorph selected: selectedStringOrMorph;
		font: self font;
		on: #mouseDown send: #tabClicked:with: to: self;
		tabSelector: self! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
newLabelMorph: aStringOrMorph
	"Answer a new label morph with the given label text."

	^TabLabelMorph new
		roundedCorners: #(1 4);
		cornerStyle: self cornerStyle;
		changeTableLayout;
		listDirection: #leftToRight;
		listCentering: #center;
		layoutInset: (self theme tabLabelInsetFor: self);
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		label: aStringOrMorph;
		font: self font;
		on: #mouseDown send: #tabClicked:with: to: self;
		tabSelector: self! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
tabClicked: evt with: aMorph 
	"A tab has been clicked."
	
	self selectedIndex: (self tabs indexOf: aMorph)! !

!TabSelectorMorph methodsFor: 'geometry' stamp: ''!
basicMinExtent
	"Answer the unadjusted min extent."

	|minTabExtent controlExtent controlsExtent|
	controlsExtent := 0@0.
	self controls do: [:control |
		controlExtent := control minExtent.
		controlsExtent := controlsExtent x + controlExtent x @ (controlsExtent y max: controlExtent y)].
	self tabs ifEmpty: [^controlsExtent].
	minTabExtent := 0@0.
	self tabs do: [:tab | minTabExtent := minTabExtent max: tab minExtent].
	^minTabExtent x + controlsExtent x @ (minTabExtent y max: controlsExtent y)! !

!TabSelectorMorph methodsFor: 'drawing' stamp: ''!
drawSubmorphsOn: aCanvas 
	"Display submorphs back to front.
	Draw the focus here since we are using inset bounds
	for the focus rectangle."

	|tab|
	super drawSubmorphsOn: aCanvas.
	(self hasKeyboardFocus and: [(tab := self selectedTab) notNil
			and: [tab owner notNil]])
		ifTrue: [self clipSubmorphs 
				ifTrue: [aCanvas
							clipBy: (aCanvas clipRect intersect: self clippingBounds ifNone:["done here" ^ self ])
							during: [:c | tab drawKeyboardFocusOn: c]]
				ifFalse: [tab drawKeyboardFocusOn: aCanvas]]! !

!TabSelectorMorph methodsFor: 'tabs' stamp: ''!
calculateVisibleTabs
	"Answer the tabs that should be visible given the space."

	| widths answer availableWidth accumulatedWidth tabStr widthStr width |
	widths := self tabs collect: [ :t | t minExtent x ].
	availableWidth := self layoutBounds width.
	self cornerStyle = #rounded ifTrue: [ availableWidth := availableWidth - 6 ].
	widths sum <= availableWidth ifTrue: [ ^ self tabs ].
	availableWidth := availableWidth - self controlsExtent x.
	answer := OrderedCollection new.
	accumulatedWidth := 0.
	^ self visibleTabRange last = 0
		ifTrue: [ tabStr := (self tabs copyFrom: self visibleTabRange first to: self tabs size) readStream.
			widthStr := (widths copyFrom: self visibleTabRange first to: widths size) readStream.
			[ accumulatedWidth <= availableWidth and: [ tabStr atEnd not ] ]
				whileTrue: [ answer add: tabStr next.
					accumulatedWidth := accumulatedWidth + widthStr next ].
			accumulatedWidth > availableWidth ifTrue: [ answer removeLast ].
			answer ]
		ifFalse: [ tabStr := (self tabs copyFrom: 1 to: (self visibleTabRange last min: self tabs size)) reversed readStream.
			widthStr := (widths copyFrom: 1 to: (self visibleTabRange last min: self tabs size)) reversed readStream.
			[ accumulatedWidth <= availableWidth and: [ tabStr atEnd not ] ]
				whileTrue: [ answer addFirst: tabStr next.
					accumulatedWidth := accumulatedWidth + (width := widthStr next) ].
			accumulatedWidth > availableWidth
				ifTrue: [ answer removeFirst.
					accumulatedWidth := accumulatedWidth - width ].
			tabStr := (self tabs copyFrom: self visibleTabRange last + 1 to: self tabs size) readStream.
			widthStr := (widths copyFrom: self visibleTabRange last + 1 to: widths size) readStream.
			[ accumulatedWidth <= availableWidth and: [ tabStr atEnd not ] ]
				whileTrue: [ answer add: tabStr next.
					accumulatedWidth := accumulatedWidth + widthStr next ].
			accumulatedWidth > availableWidth ifTrue: [ answer removeLast ].
			answer ]! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
activate
	"Update the non visible tabs too."

	super activate.
	self nonVisibleTabs do: [:t | t activate]! !

!TabSelectorMorph methodsFor: 'tabs' stamp: ''!
selectPreviousTab
	"Select the previous tab, or the last if none selected."
	
	self selectedIndex: (self selectedIndex < 2
		ifTrue: [self tabs size]
		ifFalse: [self selectedIndex - 1])! !

!TabSelectorMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	selectedIndex := 0.
	self
		tabs: OrderedCollection new;
		wrapScrolling: false;
		visibleTabRange: (1 to: 0);
		controls: self newControls;
		roundedCorners: #(1 4);
		borderWidth: 0;
		changeTableLayout;
		listDirection: #leftToRight;
		cellInset: (self theme tabSelectorCellInsetFor: self)! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
selectedIndex
	"Answer the value of selectedIndex"

	^ selectedIndex! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
font: aFont
	"Set the label font"

	font == aFont ifTrue: [^self].
	font := aFont.
	self updateFont! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
leftButtonEnabled
	"Answer whether the button for scrolling left should be enabled."

	^self wrapScrolling or: [self visibleTabRange first > 1]! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
visibleTabRange: anInterval
	"Record the range of tabs that are visible.
	Also used when scrolling to determine starting index."
	
	visibleTabRange := anInterval.
	self
		changed: #leftButtonEnabled;
		changed: #rightButtonEnabled! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
selectNextTab
	"Select the next tab, or the first if none selected."
	
	self selectedIndex: self selectedIndex \\ self tabs size + 1! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
newRightButton
	"Answer a new button for scrolling right."

	^(ControlButtonMorph
			on: self
			getState: nil
			action: #scrollTabsRight
			label: #rightButtonLabel)
		getEnabledSelector: #rightButtonEnabled;
		hResizing: #rigid;
		vResizing: #spaceFill;
		cornerStyle: #square;
		extent: self controlButtonWidth asPoint! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
controlsExtent
	"Answer the min extent of the controls."

	^self controls first minExtent + (self controls last minExtent x @ 0)! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
controlButtonWidth
	"Answer the width for a scroll button."

	^self theme scrollbarThickness + (3 * self displayScaleFactor)! !

!TabSelectorMorph methodsFor: 'rounding' stamp: ''!
cornerStyle: aSymbol
	"Pass to tabs also."

	super cornerStyle: aSymbol.
	self tabs do: [:t | t cornerStyle: aSymbol]! !

!TabSelectorMorph methodsFor: 'tabs' stamp: ''!
nonVisibleTabs
	"Answer the tabs that are not currently visible."

	^self tabs select: [:t | t owner isNil]! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
newControls
	"Answer the scrolling controls."
	
	^{self newLeftButton. self newRightButton}! !

!TabSelectorMorph methodsFor: 'adding' stamp: ''!
addTab: aStringOrMorph beforeIndex: index

	self tabs add: (self newLabelMorph: aStringOrMorph) beforeIndex: index.
	selectedIndex >= index ifTrue: [ 
		"there is now new tab before selected tab"
		self selectedIndex: selectedIndex + 1 ]. 
	self updateTabs! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
controls

	^ controls! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
font
	"Answer the label font"

	^font! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
selectedIndex: index
	"Set the value of selectedIndex"

	|oldIndex|
	selectedIndex == index ifTrue: [^self].
	oldIndex := selectedIndex.
	selectedIndex := (index min: self tabs size).
	self visibleTabRange first > index
		ifTrue: [self visibleTabRange: ((index max: 1) to: 0)]
		ifFalse: [self visibleTabRange last < index
				ifTrue: [self visibleTabRange: (0 to: index)]].
	self updateTabs.
	self changed: #selectedIndex with: oldIndex! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
wrapScrolling: aBoolean
	"Set whether tab scrolling wraps around at each end."

	wrapScrolling := aBoolean.
	self
		changed: #leftButtonEnabled;
		changed: #rightButtonEnabled! !

!TabSelectorMorph methodsFor: 'tabs' stamp: ''!
selectedTab
	"Answer the selected tab."
	
	^self selectedIndex = 0
		ifFalse: [self tabs at: self selectedIndex ifAbsent: [nil]]! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
focusBounds
	"Answer the bounds for drawing the focus indication."

	^self selectedTab
		ifNil: [super focusBounds]
		ifNotNil: [:tab | tab focusBounds]! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
ensureSelectedTabIsVisible
	"Update the tabs if the seleted tab is not in the visible range."

	(self selectedIndex > 0 and: [(self visibleTabRange includes: self selectedIndex) not])
		ifTrue: [self visibleTabRange: (self selectedIndex to: 0).
				self updateTabs]! !

!TabSelectorMorph methodsFor: 'event handling' stamp: ''!
keyDown: event 
	"Process keys navigation and space to toggle."

	(self navigationKey: event) ifTrue: [^self].
	event keyCharacter = Character arrowLeft
		ifTrue: [self selectPreviousTab].
	event keyCharacter = Character arrowRight
		ifTrue: [self selectNextTab]! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
rightButtonEnabled
	"Answer whether the button for scrolling right should be enabled."

	^self wrapScrolling or: [self visibleTabRange last < self tabs size]! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
rightButtonLabel
	"Answer the label for a button for scrolling right."

	^AlphaImageMorph new image: (
		ScrollBarMorph
			arrowOfDirection: #right
			size: self controlButtonWidth - (3 * self displayScaleFactor)
			color: self paneColor darker)! !

!TabSelectorMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	"Set the extent of the receiver.
	Update the tabs."

	self extent = aPoint ifTrue: [^self].
	super extent: aPoint.
	self
		updateTabs;
		ensureSelectedTabIsVisible! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
newLeftButton
	"Answer a new button for scrolling left."

	^(ControlButtonMorph
			on: self
			getState: nil
			action: #scrollTabsLeft
			label: #leftButtonLabel)
		getEnabledSelector: #leftButtonEnabled;
		hResizing: #rigid;
		vResizing: #spaceFill;
		cornerStyle: #square;
		extent: self controlButtonWidth asPoint! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
wrapScrolling

	^ wrapScrolling! !

!TabSelectorMorph methodsFor: 'tabs' stamp: ''!
updateTabs
	"Update the submorphs based on visible tabs."

	|tabsAndControls selectedTab|
	tabsAndControls := self tabsAndControls.
	self removeAllMorphs.
	tabsAndControls ifEmpty: [^self].
	selectedTab := self selectedTab.
	self tabs do: [:t |
		t selected: (t == selectedTab)].
	self
		addAllMorphs: self tabsAndControls;
		adoptPaneColor! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
removeTabIndex: anInteger
	"Remove the tab at the given index and
	adjust any selected (next or first if was last)."
	
	self tabs removeAt: anInteger.
	self selectedIndex: 0.
	self tabs ifNotEmpty: [
		self selectedIndex: self selectedIndex - 1 \\ self tabs size + 1]! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
updateFont
	"Update the label font."

	self tabs do: [:t | t font: self font].
	self updateTabs! !

!TabSelectorMorph methodsFor: 'tabs' stamp: ''!
relabelTab: aTab with: aStringOrMorph
	"Relabel the tab update tab layout."

	aTab label: aStringOrMorph.
	aTab owner ifNotNil: [
		self updateTabs.
		(aTab isSelected and: [aTab isVisible not])
			ifTrue: [self ensureSelectedTabIsVisible]]! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
scrollTabsRight
	"Scroll right through the tabs."
	
	self visibleTabRange: (self visibleTabRange last \\ self tabs size + 1 to: 0).
	self updateTabs! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
scrollTabsLeft
	"Scroll left through the tabs."
	
	self visibleTabRange: (self visibleTabRange first < 2
		ifTrue: [0 to: self tabs size]
		ifFalse: [0 to: self visibleTabRange first - 1]).
	self updateTabs! !

!TabSelectorMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	"Yes, we do it here."
	
	^true! !

!TabSelectorMorph methodsFor: 'keymapping' stamp: ''!
initializeShortcuts: aKMDispatcher
	super initializeShortcuts: aKMDispatcher.
	aKMDispatcher attachCategory: #MorphFocusNavigation.
	aKMDispatcher attachCategory: #TabMorphsNavigation.! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
newSpacer
	"Answer a spacer to place the controls to the right."

	^Morph new
		borderWidth: 0;
		color: Color transparent;
		extent: 0@0;
		minWidth: 0;
		hResizing: #spaceFill! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
visibleTabRange

	^ visibleTabRange! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
leftButtonLabel
	"Answer the label for a button for scrolling left."

	^AlphaImageMorph new image: (
		ScrollBarMorph
			arrowOfDirection: #left
			size: self controlButtonWidth - (3* self displayScaleFactor)
			color: self paneColor darker)! !

!TabSelectorMorph methodsFor: 'operations' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!TabSelectorMorph methodsFor: 'accessing' stamp: ''!
controls: anObject

	controls := anObject! !

!TabState commentStamp: ''!
I represent the current state of a tab.

This class is abstract so have a look at my subclasses to have a better overview.

I have tree responsibilities:
	- influence the rendering (color, border)
	- point out if the state changement asked on my tab is relevant (trying to enable an enabled tab by example)
	- provide the next state for each change (disable, enable, selected)!
!TabState methodsFor: 'protocol' stamp: ''!
backgroundColor
	
	^ self subclassResponsibility! !

!TabState methodsFor: 'accessing' stamp: ''!
tab: anObject
	
	tab := anObject! !

!TabState methodsFor: 'protocol' stamp: ''!
newStateForSelected: aBoolean

	^ self subclassResponsibility! !

!TabState methodsFor: 'protocol' stamp: ''!
buildVerticesFrom: borderVertices

	^ borderVertices! !

!TabState methodsFor: 'protocol' stamp: ''!
selected

	^ false! !

!TabState methodsFor: 'protocol' stamp: ''!
buildBorderVertices
	| borderVertices |
	
	borderVertices := OrderedCollection new.
	borderVertices
		add: tab bottomLeft;
		add: tab topLeft" + (7 @ 0)";
		add: tab topRight" + (-8 @ 0)";
		add: tab bottomRight" + (-1@0)".

	^ borderVertices! !

!TabState methodsFor: 'accessing' stamp: ''!
tab
	^ tab! !

!TabState methodsFor: 'protocol' stamp: ''!
enabled

	^ false! !

!TabState methodsFor: 'protocol' stamp: ''!
isSelectedMatchingTheState: aBoolean

	^ self subclassResponsibility! !

!TabState methodsFor: 'protocol' stamp: ''!
newStateForEnabled: aBoolean

	^ self subclassResponsibility! !

!TabState methodsFor: 'protocol' stamp: ''!
isEnabledMatchingTheState: aBoolean

	^ self subclassResponsibility! !

!TabState class methodsFor: 'instance creation' stamp: ''!
tab: tab

	^ self new
		tab: tab;
		yourself! !

!TabWithNoContents commentStamp: ''!
Error raised when a tab is asked its contents but have no morph and no retrieving block, or the retrieving block is returning nil.!
!TabWithNoContents class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!TabWithNoContentsMorph commentStamp: ''!
Error raised when a tab is asked its contents but have no morph and no retrieving block, or the retrieving block is returning nil.!
!TabWithNoContentsMorph methodsFor: 'accessing' stamp: ''!
tab: aTab 

	tab := aTab! !

!TabWithNoContentsMorph methodsFor: 'accessing' stamp: ''!
tab
	^tab! !

!TabWithNoContentsMorph class methodsFor: 'instance creation' stamp: ''!
signalTab: aTab 
	
	^ self new
		tab: aTab;
		signal! !

!TableContainerPresenter commentStamp: ''!
I am a model for a container with table layout. My purpose is to hold multiple subwidgets to glue them together.


I should not be used directly
!
!TableContainerPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	^ #(MorphicTableContainerAdapter
		adapt: #(model))! !

!TableContainerPresenter class methodsFor: 'specs' stamp: ''!
adapterName
	^ #MorphicTableContainerAdapter! !

!TableLayout commentStamp: ''!
The layout process:
For computing the new layout for the children of any morph, we start with an initial rectangle which is provided as a reference.

Step 1: The first step of layout computation is to compute the minimum extent each of our children can have. The minimum extent is mapped through both the local layout frame of the morph (for relative positioning) and the global layout frame (for insets, such as cursor indication) to obtain the minimal size required for each cell.

Step 2: Based on the cell sizes, the number of cells we can put into each row and column is computed. For equal spacing, the maximum size of the cells is taken into account here.

Step 3: Based on the row/column sizes, we compute the extra space which should be added to each row/column. For 
	#leftFlush/#topFlush - we add all extra space add the end
	#rightFlush/#bottomFlush - we add all extra space at the start
	#centering - we add 1/2 of the extra space at start and end
	#justified - we distribute the space evenly between the morphs
[NOTE: If any #spaceFill morphs are encountered during this step, #justified is implied and the space is exclusively and equally distributed between those #spaceFill morphs. This is for backward compatibility and should *never* be necessary in the new regime].

Step 4: The morphs are placed in the computed cells and the extra space is distributed as necessary. Placing the submorphs is done by mapping through the global and the local layout frame as requested.

Start point:
=> bounds: new rectangle for the morph.

Compute basic arrangement of morphs:
=> For each submorph compute minExtent
	- if global layout frame inset in global layout frame
	- if local layout frame inset in local layout frame
=> Compute number of morphs per, width and height of row/column
	- if equal spacing based on max size
=> Compute extra space per row/column
	- if centering = #justified; distribute space equally
	- if centering #leftFlush/#topFlush (-1) add start extra
	- if centering #rightFlush/#bottomFlush (1) add end extra
	- if centering #centered add 1/2 extra to start/end
	<extra space must be float and rounded accordingly!!>
=> Place morphs in appropriate cells
	- if global layout frame inset in global layout frame
	- if local layout frame inset in local layout frame
	<will likely cause #layoutChanged by submorphs>

Distribute morphs in row/column:

=> Compute the max length of each row/column
!
!TableLayout methodsFor: 'layout' stamp: ''!
layout: aMorph in: box 
	"Compute the layout for the given morph based on the new bounds"

	| cells arrangement horizontal newBounds |
	aMorph hasSubmorphs ifFalse: [^self].
	properties := aMorph assureTableProperties.
	newBounds := box origin asIntegerPoint corner: box corner asIntegerPoint.
	(properties wrapDirection == #none and: [properties cellSpacing == #none]) 
		ifTrue: 
			["get into the fast lane"

			properties listCentering == #justified 
				ifFalse: 
					["can't deal with that"

					properties listDirection == #leftToRight 
						ifTrue: [^self layoutLeftToRight: aMorph in: newBounds].
					properties listDirection == #topToBottom 
						ifTrue: [^self layoutTopToBottom: aMorph in: newBounds]]].
	horizontal := (properties listDirection == #topToBottom 
				or: [properties listDirection == #bottomToTop]) not. 
	"Step 1: Compute the minimum extent for all the children of aMorph"
	cells := self 
				computeCellSizes: aMorph
				in: (0 @ 0 corner: newBounds extent)
				horizontal: horizontal.
	"Step 2: Compute the arrangement of the cells for each row and column"
	arrangement := self 
				computeCellArrangement: cells
				in: newBounds
				horizontal: horizontal
				target: aMorph.
	"Step 3: Compute the extra spacing for each cell"
	self 
		computeExtraSpacing: arrangement
		in: newBounds
		horizontal: horizontal
		target: aMorph.
	"Step 4: Place the children within the cells accordingly"
	self 
		placeCells: arrangement
		in: newBounds
		horizontal: horizontal
		target: aMorph! !

!TableLayout methodsFor: 'layout' stamp: ''!
computeCellSizes: aMorph in: newBounds horizontal: aBool
	"Step 1: Compute the minimum extent for all the children of aMorph"
	| cells block minSize maxSize maxCell |
	cells := (Array new: aMorph submorphCount) writeStream.
	minSize := properties minCellSize asPoint.
	maxSize := properties maxCellSize asPoint.
	aBool ifTrue:[
		minSize := minSize transposed.
		maxSize := maxSize transposed].
	maxCell := 0@0.
	block := [:m| | cell size |
		m disableTableLayout ifFalse:[
			size := m minExtent asIntegerPoint.
			cell := LayoutCell new target: m.
			aBool ifTrue:[
				cell hSpaceFill: m hResizing == #spaceFill.
				cell vSpaceFill: m vResizing == #spaceFill.
			] ifFalse:[
				cell hSpaceFill: m vResizing == #spaceFill.
				cell vSpaceFill: m hResizing == #spaceFill.
				size := size transposed.
			].
			size := (size min: maxSize) max: minSize.
			cell cellSize: size.
			maxCell := maxCell max: size.
			cells nextPut: cell]].
	properties reverseTableCells
		ifTrue:[aMorph submorphsReverseDo: block]
		ifFalse:[aMorph submorphsDo: block].
	^maxCell -> cells contents! !

!TableLayout methodsFor: 'nil' stamp: ''!
computeCellArrangement: cellHolder in: newBounds horizontal: aBool target: aMorph
	"Compute number of cells we can put in each row/column. The returned array contains a list of all the cells we can put into the row/column at each level.
	Note: The arrangement is so that the 'x' value of each cell advances along the list direction and the 'y' value along the wrap direction. The returned arrangement has an extra cell at the start describing the width and height of the row."
	| cells wrap spacing output maxExtent n sum index max cell first last w cellMax maxCell hFill vFill inset |
	maxCell := cellHolder key.
	cells := cellHolder value.
	properties wrapDirection == #none 
		ifTrue:[wrap := SmallInteger maxVal]
		ifFalse:[wrap := aBool ifTrue:[newBounds width] ifFalse:[newBounds height].
				wrap < maxCell x ifTrue:[wrap := maxCell x]].
	spacing := properties cellSpacing.
	(spacing == #globalRect or:[spacing = #globalSquare]) ifTrue:[
		"Globally equal spacing is a very special case here, so get out fast and easy"
		^self computeGlobalCellArrangement: cells 
			in: newBounds horizontal: aBool 
			wrap: wrap spacing: spacing].

	output := Array new writeStream.
	inset := properties cellInset asPoint.
	aBool ifFalse:[inset := inset transposed].
	first := last := nil.
	maxExtent := 0@0.
	sum := 0.
	index := 1.
	n := 0.
	hFill := vFill := false.
	[index <= cells size] whileTrue:[
		w := sum.
		cell := cells at: index.
		cellMax := maxExtent max: cell cellSize. "e.g., minSize"
		(spacing == #localRect or:[spacing == #localSquare]) ifTrue:[
			"Recompute entire size of current row"
			spacing == #localSquare 
				ifTrue:[max := cellMax x max: cellMax y]
				ifFalse:[max := cellMax x].
			sum := (n + 1) * max.
		] ifFalse:[
			sum := sum + (cell cellSize x).
		].
		((sum + (n * inset x)) > wrap and:[first notNil]) ifTrue:[
			"It doesn't fit and we're not starting a new line"
			(spacing == #localSquare or:[spacing == #localRect]) ifTrue:[
				spacing == #localSquare 
					ifTrue:[maxExtent := (maxExtent x max: maxExtent y) asPoint].
				first do:[:c| c cellSize: maxExtent]].
			w := w + ((n - 1) * inset x).
			"redistribute extra space"
			first nextCell ifNotNil:[first nextCell do:[:c| c addExtraSpace: inset x@0]].
			last := LayoutCell new.
			last cellSize: w @ (maxExtent y).
			last hSpaceFill: hFill.
			last vSpaceFill: vFill.
			last nextCell: first.
			output position = 0 ifFalse:[last addExtraSpace: 0@inset y].
			output nextPut: last.
			first := nil.
			maxExtent := 0@0.
			sum := 0.
			n := 0.
			hFill := vFill := false.
		] ifFalse:[
			"It did fit; use next item from input"
			first ifNil:[first := last := cell] ifNotNil:[last nextCell: cell. last := cell].
			index := index+1.
			n := n + 1.
			maxExtent := cellMax.
			hFill := hFill or:[cell hSpaceFill].
			vFill := vFill or:[cell vSpaceFill].
		].
	].
	first ifNotNil:[
		last := LayoutCell new.
		sum := sum + ((n - 1) * inset x).
		first nextCell ifNotNil:[first nextCell do:[:c| c addExtraSpace: inset x@0]].
		last cellSize: sum @ maxExtent y.
		last hSpaceFill: hFill.
		last vSpaceFill: vFill.
		last nextCell: first.
		output position = 0 ifFalse:[last addExtraSpace: 0@inset y].
		output nextPut: last].
	output := output contents.
	properties listSpacing == #equal ifTrue:[
		"Make all the heights equal"
		max := output inject: 0 into:[:size :c| size max: c cellSize y].
		output do:[:c| c cellSize: c cellSize x @ max].
	].
	^output! !

!TableLayout methodsFor: 'layout' stamp: ''!
flushLayoutCache
	"Flush any cached information associated with the receiver"
	minExtentCache := nil.! !

!TableLayout methodsFor: 'layout' stamp: ''!
layoutLeftToRight: aMorph in: newBounds
	"An optimized left-to-right list layout"
	| inset extent block posX posY centering extraPerCell amount minX minY maxX maxY n width extra last cell size height sum vFill first |
	size := properties minCellSize asPoint. minX := size x. minY := size y.
	size := properties maxCellSize asPoint. maxX := size x. maxY := size y.
	inset := properties cellInset asPoint x.
	extent := newBounds extent.
	n := 0. vFill := false. sum := 0.
	width := height := 0.
	first := last := nil.
	block := [:m| | sizeY sizeX props |
		props := m layoutProperties ifNil:[m].
		props disableTableLayout ifFalse:[
			n := n + 1.
			cell := LayoutCell new target: m.
			(props hResizing == #spaceFill) ifTrue:[
				cell hSpaceFill: true.
				extra := m spaceFillWeight.
				cell extraSpace: extra.
				sum := sum + extra.
			] ifFalse:[cell hSpaceFill: false].
			(props vResizing == #spaceFill) ifTrue:[vFill := true].
			size := m minExtent. sizeX := size x. sizeY := size y.
			sizeX < minX
				ifTrue:[sizeX := minX]
				ifFalse:[sizeX > maxX ifTrue:[sizeX := maxX]].
			sizeY < minY
				ifTrue:[sizeY := minY]
				ifFalse:[sizeY > maxY ifTrue:[sizeY := maxY]].
			cell cellSize: sizeX.
			last ifNil:[first := cell] ifNotNil:[last nextCell: cell].
			last := cell.
			width := width + sizeX.
			sizeY > height ifTrue:[height := sizeY].
		].
	].
	properties reverseTableCells
		ifTrue:[aMorph submorphsReverseDo: block]
		ifFalse:[aMorph submorphsDo: block].

	n > 1 ifTrue:[width := width + (n-1 * inset)].

	(properties hResizing == #shrinkWrap and:[properties rubberBandCells or:[sum isZero]])
		ifTrue:[extent := width @ (extent y max: height)].
	(properties vResizing == #shrinkWrap and:[properties rubberBandCells or:[vFill not]])
		ifTrue:[extent := (extent x max: width) @ height].

	posX := newBounds left.
	posY := newBounds top.

	"Compute extra vertical space"
	extra := extent y - height.
	extra < 0 ifTrue:[extra := 0].
	extra > 0 ifTrue:[
		vFill ifTrue:[
			height := extent y.
		] ifFalse:[
			centering := properties wrapCentering.
			centering == #bottomRight ifTrue:[posY := posY + extra].
			centering == #center ifTrue:[posY := posY + (extra // 2)]
		].
	].


	"Compute extra horizontal space"
	extra := extent x - width.
	extra < 0 ifTrue:[extra := 0].
	extraPerCell := 0.
	extra > 0 ifTrue:[
		sum isZero ifTrue:["extra space but no #spaceFillers"
			centering := properties listCentering.
			centering == #bottomRight ifTrue:[posX := posX + extra].
			centering == #center ifTrue:[posX := posX + (extra // 2)].
		] ifFalse:[extraPerCell := extra asFloat / sum asFloat].
	].

	n := 0.
	extra := last := 0.
	cell := first.
	[cell == nil] whileFalse:[
		n := n + 1.
		width := cell cellSize.
		(extraPerCell > 0 and:[cell hSpaceFill]) ifTrue:[
			extra := (last := extra) + (extraPerCell * cell extraSpace).
			amount := extra truncated - last truncated.
			width := width + amount.
		].
		cell target layoutInBounds: (posX @ posY extent: width @ height).
		posX := posX + width + inset.
		cell := cell nextCell.
	].! !

!TableLayout methodsFor: 'nil' stamp: ''!
minExtentVertical: aMorph
	"Return the minimal size aMorph's children would require given the new bounds"
	| inset minX minY maxX maxY n size width height |
	size := properties minCellSize asPoint. minX := size x. minY := size y.
	size := properties maxCellSize asPoint. maxX := size x. maxY := size y.
	inset := properties cellInset asPoint.
	n := 0.
	width := height := 0.
	aMorph submorphsDo:[:m| | sizeX sizeY |
		m disableTableLayout ifFalse:[
			n := n + 1.
			size := m minExtent. sizeX := size x. sizeY := size y.
			sizeX < minX
				ifTrue:[sizeX := minX]
				ifFalse:[sizeX > maxX ifTrue:[sizeX := maxX]].
			sizeY < minY
				ifTrue:[sizeY := minY]
				ifFalse:[sizeY > maxY ifTrue:[sizeY := maxY]].
			height := height + sizeY.
			sizeX > width ifTrue:[width := sizeX].
		].
	].
	n > 1 ifTrue:[height := height + (n-1 * inset y)].
	^minExtentCache := width @ height! !

!TableLayout methodsFor: 'nil' stamp: ''!
layoutTopToBottom: aMorph in: newBounds
	"An optimized top-to-bottom list layout"
	| inset extent block posX posY centering extraPerCell amount minX minY maxX maxY n height extra last cell size width sum vFill first |
	size := properties minCellSize asPoint. minX := size x. minY := size y.
	size := properties maxCellSize asPoint. maxX := size x. maxY := size y.
	inset := properties cellInset asPoint y.
	extent := newBounds extent.
	n := 0. vFill := false. sum := 0.
	width := height := 0.
	first := last := nil.
	block := [:m| | sizeX props sizeY |
		props := m layoutProperties ifNil:[m].
		props disableTableLayout ifFalse:[
			n := n + 1.
			cell := LayoutCell new target: m.
			(props vResizing == #spaceFill) ifTrue:[
				cell vSpaceFill: true.
				extra := m spaceFillWeight.
				cell extraSpace: extra.
				sum := sum + extra.
			] ifFalse:[cell vSpaceFill: false].
			(props hResizing == #spaceFill) ifTrue:[vFill := true].
			size := m minExtent. sizeX := size x. sizeY := size y.
			sizeX < minX
				ifTrue:[sizeX := minX]
				ifFalse:[sizeX > maxX ifTrue:[sizeX := maxX]].
			sizeY < minY
				ifTrue:[sizeY := minY]
				ifFalse:[sizeY > maxY ifTrue:[sizeY := maxY]].
			cell cellSize: sizeY.
			first ifNil:[first := cell] ifNotNil:[last nextCell: cell].
			last := cell.
			height := height + sizeY.
			sizeX > width ifTrue:[width := sizeX].
		].
	].
	properties reverseTableCells
		ifTrue:[aMorph submorphsReverseDo: block]
		ifFalse:[aMorph submorphsDo: block].

	n > 1 ifTrue:[height := height + (n-1 * inset)].

	(properties vResizing == #shrinkWrap and:[properties rubberBandCells or:[sum isZero]])
		ifTrue:[extent := (extent x max: width) @ height].
	(properties hResizing == #shrinkWrap and:[properties rubberBandCells or:[vFill not]])
		ifTrue:[extent := width @ (extent y max: height)].

	posX := newBounds left.
	posY := newBounds top.

	"Compute extra horizontal space"
	extra := extent x - width.
	extra < 0 ifTrue:[extra := 0].
	extra > 0 ifTrue:[
		vFill ifTrue:[
			width := extent x.
		] ifFalse:[
			centering := properties wrapCentering.
			centering == #bottomRight ifTrue:[posX := posX + extra].
			centering == #center ifTrue:[posX := posX + (extra // 2)]
		].
	].


	"Compute extra vertical space"
	extra := extent y - height.
	extra < 0 ifTrue:[extra := 0].
	extraPerCell := 0.
	extra > 0 ifTrue:[
		sum isZero ifTrue:["extra space but no #spaceFillers"
			centering := properties listCentering.
			centering == #bottomRight ifTrue:[posY := posY + extra].
			centering == #center ifTrue:[posY := posY + (extra // 2)].
		] ifFalse:[extraPerCell := extra asFloat / sum asFloat].
	].

	n := 0.
	extra := last := 0.
	cell := first.
	[cell == nil] whileFalse:[
		n := n + 1.
		height := cell cellSize.
		(extraPerCell > 0 and:[cell vSpaceFill]) ifTrue:[
			extra := (last := extra) + (extraPerCell * cell extraSpace).
			amount := extra truncated - last truncated.
			height := height + amount.
		].
		cell target layoutInBounds: (posX @ posY extent: width @ height).
		posY := posY + height + inset.
		cell := cell nextCell.
	].! !

!TableLayout methodsFor: 'utilities' stamp: ''!
indexForInserting: aMorph at: aPoint in: owner 
	"Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion."

	| horizontal morphList index |
	owner hasSubmorphs ifFalse: [^1].
	aMorph disableTableLayout ifTrue: [^1].
	horizontal := (owner listDirection == #topToBottom 
				or: [owner listDirection == #bottomToTop]) not .
	morphList := owner submorphs.
	owner reverseTableCells ifTrue: [morphList := morphList reversed].
	index := self 
				indexForInserting: aPoint
				inList: morphList
				horizontal: horizontal
				target: owner.
	owner reverseTableCells ifTrue: [index := morphList size - index + 2].
	^index ifNil: [1]! !

!TableLayout methodsFor: 'layout' stamp: ''!
placeCells: arrangement in: newBounds horizontal: aBool target: aMorph 
	"Place the morphs within the cells accordingly"

	| xDir yDir anchor yDist place cell xDist cellRect corner inset |
	inset := properties cellInset.
	(inset isNumber and: [inset isZero]) ifTrue: [inset := nil].
	aBool 
		ifTrue: 
			["horizontal layout"

			properties listDirection == #rightToLeft 
				ifTrue: 
					[xDir := -1 @ 0.
					properties wrapDirection == #bottomToTop 
						ifTrue: 
							[yDir := 0 @ -1.
							anchor := newBounds bottomRight]
						ifFalse: 
							[yDir := 0 @ 1.
							anchor := newBounds topRight]]
				ifFalse: 
					[xDir := 1 @ 0.
					properties wrapDirection == #bottomToTop 
						ifTrue: 
							[yDir := 0 @ -1.
							anchor := newBounds bottomLeft]
						ifFalse: 
							[yDir := 0 @ 1.
							anchor := newBounds topLeft]]]
		ifFalse: 
			["vertical layout"

			properties listDirection == #bottomToTop 
				ifTrue: 
					[xDir := 0 @ -1.
					properties wrapDirection == #rightToLeft 
						ifTrue: 
							[yDir := -1 @ 0.
							anchor := newBounds bottomRight]
						ifFalse: 
							[yDir := 1 @ 0.
							anchor := newBounds bottomLeft]]
				ifFalse: 
					[xDir := 0 @ 1.
					anchor := properties wrapDirection == #rightToLeft 
								ifTrue: 
									[yDir := -1 @ 0.
									newBounds topRight]
								ifFalse: 
									[yDir := 1 @ 0.
									newBounds topLeft]]].
	1 to: arrangement size
		do: 
			[:i | 
			cell := arrangement at: i.
			cell extraSpace ifNotNil: [anchor := anchor + (cell extraSpace y * yDir)].
			yDist := cell cellSize y * yDir.	"secondary advance direction"
			place := anchor.
			cell := cell nextCell.
			[cell isNil] whileFalse: 
					[cell extraSpace ifNotNil: [place := place + (cell extraSpace x * xDir)].
					xDist := cell cellSize x * xDir.	"primary advance direction"
					corner := place + xDist + yDist.
					cellRect := Rectangle origin: (place min: corner)
								corner: (place max: corner).
					inset ifNotNil: [cellRect := cellRect insetBy: inset].
					cell target layoutInBounds: cellRect.
					place := place + xDist.
					cell := cell nextCell].
			anchor := anchor + yDist]! !

!TableLayout methodsFor: 'nil' stamp: ''!
minExtentHorizontal: aMorph
	"Return the minimal size aMorph's children would require given the new bounds"
	| inset minX minY maxX maxY n size width height |
	size := properties minCellSize asPoint. minX := size x. minY := size y.
	size := properties maxCellSize asPoint. maxX := size x. maxY := size y.
	inset := properties cellInset asPoint.
	n := 0.
	width := height := 0.
	aMorph submorphsDo:[:m| | sizeY sizeX |
		m disableTableLayout ifFalse:[
			n := n + 1.
			size := m minExtent. sizeX := size x. sizeY := size y.
			sizeX < minX
				ifTrue:[sizeX := minX]
				ifFalse:[sizeX > maxX ifTrue:[sizeX := maxX]].
			sizeY < minY
				ifTrue:[sizeY := minY]
				ifFalse:[sizeY > maxY ifTrue:[sizeY := maxY]].
			width := width + sizeX.
			sizeY > height ifTrue:[height := sizeY].
		].
	].
	n > 1 ifTrue:[width := width + (n-1 * inset x)].
	^minExtentCache := width @ height! !

!TableLayout methodsFor: 'layout' stamp: ''!
computeExtraSpacing: arrangement in: newBounds horizontal: aBool target: aMorph 
	"Compute the required extra spacing for laying out the cells"

	"match newBounds extent with arrangement's orientation"

	| extent extra centering n extraPerCell cell last hFill vFill max amount allow |
	extent := newBounds extent.
	aBool ifFalse: [extent := extent transposed].

	"figure out if we have any horizontal or vertical space fillers"
	hFill := vFill := false.
	max := 0 @ 0.
	arrangement do: 
			[:c | 
			max := (max x max: c cellSize x) @ (max y + c cellSize y).
			max := max max: c cellSize.
			hFill := hFill or: [c hSpaceFill].
			vFill := vFill or: [c vSpaceFill]].

	"Take client's shrink wrap constraints into account.
	Note: these are only honored when there are no #spaceFill children,
	or when #rubberBandCells is set."
	allow := properties rubberBandCells not.
	aMorph hResizing == #shrinkWrap 
		ifTrue: 
			[aBool 
				ifTrue: [allow & hFill ifFalse: [extent := max x @ (max y max: extent y)]]
				ifFalse: [allow & vFill ifFalse: [extent := (max x max: extent x) @ max y]]].
	aMorph vResizing == #shrinkWrap 
		ifTrue: 
			[aBool 
				ifFalse: [allow & hFill ifFalse: [extent := max x @ (max y max: extent y)]]
				ifTrue: [allow & vFill ifFalse: [extent := (max x max: extent x) @ max y]]].

	"Now compute the extra v space"
	extra := extent y 
				- (arrangement inject: 0 into: [:sum :c | sum + c cellSize y]).
	extra > 0 
		ifTrue: 
			["Check if we have any #spaceFillers"

			vFill 
				ifTrue: 
					["use only #spaceFillers"

					n := arrangement inject: 0
								into: [:sum :c | c vSpaceFill ifTrue: [sum + 1] ifFalse: [sum]].
					n isZero ifFalse: [extraPerCell := extra asFloat / n asFloat].
					extra := last := 0.
					arrangement do: 
							[:c | 
							c vSpaceFill 
								ifTrue: 
									[extra := (last := extra) + extraPerCell.
									amount := 0 @ (extra truncated - last truncated).
									c do: [:cc | cc cellSize: cc cellSize + amount]]]]
				ifFalse: 
					["no #spaceFillers; distribute regularly"

					centering := properties wrapCentering.
					"centering == #topLeft ifTrue:[]."	"add all extra space to the last cell; e.g., do nothing"
					centering == #bottomRight 
						ifTrue: 
							["add all extra space to the first cell"

							arrangement first addExtraSpace: 0 @ extra].
					centering == #center 
						ifTrue: 
							["add 1/2 extra space to the first and last cell"

							arrangement first addExtraSpace: 0 @ (extra // 2)].
					centering == #justified 
						ifTrue: 
							["add extra space equally distributed to each cell"

							n := arrangement size - 1 max: 1.
							extraPerCell := extra asFloat / n asFloat.
							extra := last := 0.
							arrangement do: 
									[:c | 
									c addExtraSpace: 0 @ (extra truncated - last truncated).
									extra := (last := extra) + extraPerCell]]]].

	"Now compute the extra space for the primary direction"
	centering := properties listCentering.
	1 to: arrangement size
		do: 
			[:i | 
			cell := arrangement at: i.
			extra := extent x - cell cellSize x.
			extra > 0 
				ifTrue: 
					["Check if we have any #spaceFillers"
					cell := cell nextCell.
					cell hSpaceFill 
						ifTrue: 
							["use only #spaceFillers"

							
							n := cell inject: 0
										into: [:sum :c | c hSpaceFill ifTrue: [sum + c target spaceFillWeight] ifFalse: [sum]].
							n isZero ifFalse: [extraPerCell := extra asFloat / n asFloat].
							extra := last := 0.
							cell do: 
									[:c | 
									c hSpaceFill 
										ifTrue: 
											[extra := (last := extra) + (extraPerCell * c target spaceFillWeight).
											amount := extra truncated - last truncated.
											c cellSize: c cellSize + (amount @ 0)]]]
						ifFalse: 
							["no #spaceFiller; distribute regularly"

						
							"centering == #topLeft ifTrue:[]"	"add all extra space to the last cell; e.g., do nothing"
							centering == #bottomRight 
								ifTrue: 
									["add all extra space to the first cell"

									cell addExtraSpace: extra @ 0].
							centering == #center 
								ifTrue: 
									["add 1/2 extra space to the first and last cell"

									cell addExtraSpace: (extra // 2) @ 0].
							centering == #justified 
								ifTrue: 
									["add extra space equally distributed to each cell"

									n := cell size - 1 max: 1.
									extraPerCell := extra asFloat / n asFloat.
									extra := last := 0.
									cell do: 
											[:c | 
											c addExtraSpace: (extra truncated - last truncated) @ 0.
											extra := (last := extra) + extraPerCell]]]]]! !

!TableLayout methodsFor: 'layout' stamp: ''!
computeGlobalCellArrangement: cells in: newBounds horizontal: aBool wrap: wrap spacing: spacing
	"Compute number of cells we can put in each row/column. The returned array contains a list of all the cells we can put into the row/column at each level.
	Note: The arrangement is so that the 'x' value of each cell advances along the list direction and the 'y' value along the wrap direction. The returned arrangement has an extra cell at the start describing the width and height of the row."
	| output maxExtent n cell first last hFill vFill |
	output := Array new writeStream.
	first := last := nil.
	maxExtent := cells inject: 0@0 into:[:size :c| size max: c cellSize "e.g., minSize"].
	spacing == #globalSquare ifTrue:[maxExtent := (maxExtent x max: maxExtent y) asPoint].
	n := (wrap // maxExtent x) max: 1.
	hFill := vFill := false.
	1 to: cells size do:[:i|
		cell := cells at: i.
		hFill := hFill or:[cell hSpaceFill].
		vFill := vFill or:[cell vSpaceFill].
		cell cellSize: maxExtent.
		first ifNil:[first := last := cell] ifNotNil:[last nextCell: cell. last := cell].
		(i \\ n) = 0 ifTrue:[
			last := LayoutCell new.
			last cellSize: (maxExtent x * n) @ (maxExtent y).
			last hSpaceFill: hFill.
			last vSpaceFill: vFill.
			hFill := vFill := false.
			last nextCell: first.
			output nextPut: last.
			first := nil]].
	first ifNotNil:[
		last := LayoutCell new.
		last cellSize: (maxExtent x * n) @ (maxExtent y). self flag: #pharoFixMe."@@@: n is not correct!!"
		last nextCell: first.
		output nextPut: last].
	^output contents! !

!TableLayout methodsFor: 'layout' stamp: ''!
minExtentOf: aMorph in: box

	"Return the minimal size aMorph's children would require given the new bounds"

	| cells arrangement horizontal newBounds minX minY dir |

	minExtentCache ifNotNil: [ ^ minExtentCache ].
	aMorph hasSubmorphs
		ifFalse: [ ^ 0 @ 0 ].
	properties := aMorph assureTableProperties.
	( properties wrapDirection == #none and: [ properties cellSpacing == #none ] )
		ifTrue: [ "Get into the fast lane"
			dir := properties listDirection.
			( dir == #leftToRight or: [ dir == #rightToLeft ] )
				ifTrue: [ ^ self minExtentHorizontal: aMorph ].
			( dir == #topToBottom or: [ dir == #bottomToTop ] )
				ifTrue: [ ^ self minExtentVertical: aMorph ]
			].
	newBounds := box origin asIntegerPoint corner: box corner asIntegerPoint.
	horizontal := ( properties listDirection == #topToBottom
		or: [ properties listDirection == #bottomToTop ] ) not.	"Step 1: Compute the minimum extent for all the children of aMorph"
	cells := self
		computeCellSizes: aMorph
		in: ( 0 @ 0 corner: newBounds extent )
		horizontal: horizontal.	"Step 2: Compute the arrangement of the cells for each row and column"
	arrangement := self
		computeCellArrangement: cells
		in: newBounds
		horizontal: horizontal
		target: aMorph.	"Step 3: Extract the minimum size out of the arrangement"
	minX := minY := 0.
	arrangement
		do: [ :cell | 
			minX := minX max: cell cellSize x + cell extraSpace x.
			minY := minY + cell cellSize y + cell extraSpace y
			].
	minExtentCache := horizontal
		ifTrue: [ minX @ minY ]
		ifFalse: [ minY @ minX ].
	^ minExtentCache! !

!TableLayout methodsFor: 'utilities' stamp: ''!
indexForInserting: aPoint inList: morphList horizontal: aBool target: aMorph 
	| cmp1 cmp2 cmp3 noWrap |
	properties := aMorph layoutProperties.
	noWrap := properties wrapDirection == #none.
	aBool 
		ifTrue: 
			["horizontal"

			properties listDirection == #rightToLeft 
				ifTrue: [cmp1 := [:rect | aPoint x > rect left]]
				ifFalse: [cmp1 := [:rect | aPoint x < rect right]].
			properties wrapDirection == #bottomToTop 
				ifTrue: 
					[cmp2 := [:rect | aPoint y > rect top].
					cmp3 := [:rect | aPoint y > rect bottom]]
				ifFalse: 
					[cmp2 := [:rect | aPoint y < rect bottom].
					cmp3 := [:rect | aPoint y < rect top]]]
		ifFalse: 
			["vertical"

			properties listDirection == #bottomToTop 
				ifTrue: [cmp1 := [:rect | aPoint y > rect top]]
				ifFalse: [cmp1 := [:rect | aPoint y < rect bottom]].
			properties wrapDirection == #rightToLeft 
				ifTrue: 
					[cmp2 := [:rect | aPoint x > rect left].
					cmp3 := [:rect | aPoint x > rect right]]
				ifFalse: 
					[cmp2 := [:rect | aPoint x < rect right].
					cmp3 := [:rect | aPoint x < rect left]]]. 
	morphList keysAndValuesDo: 
			[:index :m | | box | 
			self flag: #pharoFixMe.	"it is not quite clear if we can really use #fullBounds here..."
			box := m fullBounds.
			noWrap 
				ifTrue: 
					["Only in one direction"

					(cmp1 value: box) ifTrue: [^index]]
				ifFalse: 
					["Check for inserting before current row"

					(cmp3 value: box) ifTrue: [^index].
					"Check for inserting before current cell"
					((cmp1 value: box) and: [cmp2 value: box]) ifTrue: [^index]]].
	^morphList size + 1! !

!TableLayout methodsFor: 'testing' stamp: ''!
isTableLayout
	^true! !

!TableLayoutProperties commentStamp: ''!
Properties for Table layouts like inset, spacing, ...!
!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
wrapCentering
	^wrapCentering! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
layoutInset: aNumber
	layoutInset := aNumber! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
cellInset: aNumber
	cellInset := aNumber! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
cellSpacing: aSymbol
	cellSpacing := aSymbol.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
rubberBandCells: aBool
	rubberBandCells := aBool.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
cellPositioning: aSymbol
	cellPositioning := aSymbol! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
listCentering: aSymbol
	listCentering := aSymbol! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
rubberBandCells
	^rubberBandCells! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
cellPositioning
	^cellPositioning! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
wrapCentering: aSymbol
	wrapCentering := aSymbol! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
maxCellSize: aNumber
	maxCellSize := aNumber.! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
cellInset
	^cellInset! !

!TableLayoutProperties methodsFor: 'testing' stamp: ''!
includesTableProperties
	^true! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
listDirection
	^listDirection! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
listSpacing: aSymbol
	listSpacing := aSymbol! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
maxCellSize
	^maxCellSize! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
wrapDirection
	^wrapDirection! !

!TableLayoutProperties methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	cellSpacing := listSpacing := wrapDirection := #none.
	cellPositioning := #center.
	listCentering := wrapCentering := #topLeft.
	listDirection := #topToBottom.
	reverseTableCells := rubberBandCells := false.
	layoutInset := cellInset := minCellSize := 0.
	maxCellSize := 1073741823. "SmallInteger maxVal"! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
cellSpacing
	^cellSpacing! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
wrapDirection: aSymbol
	wrapDirection := aSymbol! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
layoutInset
	^layoutInset! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
listCentering
	^listCentering! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
minCellSize
	^minCellSize! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
reverseTableCells
	^reverseTableCells! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
minCellSize: aNumber
	minCellSize := aNumber.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
listDirection: aSymbol
	listDirection := aSymbol.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: ''!
reverseTableCells: aBool
	reverseTableCells := aBool! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: ''!
listSpacing
	^listSpacing! !

!TaskListMorph commentStamp: ''!
Themed task list/switcher to select the topmost window. Use cmd + left or right arrows (not ideal but the os typically handles cmd + tab/shift-tab).
On Linux, release of the command key is not detected (vm issue), so press and release cmd again or move the mouse!!!
!TaskListMorph methodsFor: 'initialization' stamp: ''!
initializeAppearance
	"Initialize the appearance."

	self
		color: (Color black alpha: 0.15);
		fillStyle: (self theme taskListFillStyleFor: self);
		borderStyle: (self theme taskbarThumbnailNormalBorderStyleFor: self);
		cornerStyle: (self theme taskbarThumbnailCornerStyleFor: self)! !

!TaskListMorph methodsFor: 'accessing' stamp: ''!
tasks: anObject
	"Set the value of tasks"

	tasks := anObject! !

!TaskListMorph methodsFor: 'accessing' stamp: ''!
taskList: anObject
	"Set the value of taskList"

	taskList := anObject! !

!TaskListMorph methodsFor: 'stepping' stamp: ''!
step
	"Check the sensor for the command key to see if we're done."

	(self keepOpen not and: [self activeHand anyModifierKeyPressed not])
		ifTrue: [self done]! !

!TaskListMorph methodsFor: 'initialization' stamp: ''!
initializeLayout
	"Initialize the layout."

	self
		changeTableLayout;
		layoutInset: 16;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		extent: self minimumExtent! !

!TaskListMorph methodsFor: 'open/close' stamp: ''!
postOpenInWorld: aWorld
	"Update the layout after opening."

	self allMorphs do: [:m | m layoutChanged].
	super postOpenInWorld: aWorld! !

!TaskListMorph methodsFor: 'open/close' stamp: ''!
doOpenInWorld: aWorld
	"Update the layout after opening."

	aWorld addMorphCentered: self! !

!TaskListMorph methodsFor: 'private' stamp: ''!
defaultPreviewExtent
	"Answer the default extent of the preview holder."

	^(320@320) scaledByDisplayScaleFactor! !

!TaskListMorph methodsFor: 'initialization' stamp: ''!
initializeTasks
	"Set up the current tasks."
	
	self tasks: ((self currentWorld submorphs
		collect: [:m | m taskbarTask])
		select: [:m | m notNil]) asOrderedCollection! !

!TaskListMorph methodsFor: 'private' stamp: ''!
updatePreview
	"Update the preview.."
	
	self preview removeAllMorphs.
	self preview addMorphCentered: ( 
		self activeTask 
				ifNil: [ 'No tasks...' asMorph	]
				ifNotNil: [:t | t morph taskThumbnailOfSize: self preview extent])! !

!TaskListMorph methodsFor: 'cycling' stamp: ''!
selectNextTask
	"Make the next task active."
	
	self selectTask: (self tasks
		after: self activeTask
		ifAbsent: [self tasks isEmpty
					ifFalse: [self tasks first]])! !

!TaskListMorph methodsFor: 'instance creation' stamp: ''!
newPreviewMorph
	"Answer a new preview holder."
	^ Morph new
		color: Color transparent;
		extent: self defaultPreviewExtent;
		yourself.! !

!TaskListMorph methodsFor: 'private' stamp: ''!
activeTask
	"Answer the active task"
	
	^self tasks detect: [:t | t isActive] ifNone: []! !

!TaskListMorph methodsFor: 'accessing' stamp: ''!
preview
	"Answer the value of preview"

	^ preview! !

!TaskListMorph methodsFor: 'private' stamp: ''!
taskClicked: aTask
	"A button for a task has been pressed.
	Close after selecting."
	
	self selectTask: aTask.
	self done! !

!TaskListMorph methodsFor: 'stepping' stamp: ''!
stepTime
	"Check quickly."

	^100! !

!TaskListMorph methodsFor: 'running' stamp: ''!
done
	"Close the tasklist and make the active task current."
	
	self delete.
	self activeTask ifNotNil: [ :t | t activate ]! !

!TaskListMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		initializeTasks;
		initializeLayout;
		initializeAppearance;
		addMorphs;
		updateButtonsAndPreview;
		adoptPaneColor: self color! !

!TaskListMorph methodsFor: 'open/close' stamp: ''!
preOpenInWorld: aWorld

	"Do nothing"! !

!TaskListMorph methodsFor: 'private' stamp: ''!
selectTask: aTask
	"Make the given task active and update the buttons."
	
	self tasks do: [:t | t state: #restored].
	aTask ifNotNil: [ aTask state: #active ].
	self updateButtonsAndPreview! !

!TaskListMorph methodsFor: 'instance creation' stamp: ''!
newTasksMorph
	"Answer a new task list."

	^Morph new
		changeTableLayout;
		listDirection: #leftToRight;
		wrapDirection: #topToBottom;
		cellInset: 1;
		color: Color transparent;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		yourself.! !

!TaskListMorph methodsFor: 'geometry' stamp: ''!
minimumExtent
	"Answer the minimum extent."

	^self defaultPreviewExtent + 64! !

!TaskListMorph methodsFor: 'accessing' stamp: ''!
taskList
	"Answer the value of taskList"

	^ taskList! !

!TaskListMorph methodsFor: 'private' stamp: ''!
updateTaskButtons
	"Make buttons for the ordered tasks."
	
	
	self taskList removeAllMorphs.
	self tasks do: [:t | | button |
		button := t taskListButtonFor: self.
		button ifNotNil: [self taskList addMorphBack: button]]! !

!TaskListMorph methodsFor: 'accessing' stamp: ''!
tasks
	"Answer the value of tasks"

	^ tasks! !

!TaskListMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	"Yes, we do it here."
	
	^true! !

!TaskListMorph methodsFor: 'open/close' stamp: ''!
openInWorld: aWorld

	super openInWorld: aWorld.	
	self wantsKeyboardFocus
		ifTrue: [self takeKeyboardFocus]! !

!TaskListMorph methodsFor: 'accessing' stamp: ''!
preview: anObject
	"Set the value of preview"

	preview := anObject! !

!TaskListMorph methodsFor: 'settings' stamp: ''!
keepOpen
	^ self class keepOpen! !

!TaskListMorph methodsFor: 'private' stamp: ''!
addMorphs
	"Add our morphs."

	| mainColumn |
	self preview: self newPreviewMorph.
	self taskList: self newTasksMorph.
	mainColumn := self theme newColumnIn: self for: {
		self preview.
		self taskList }.
	mainColumn
		vResizing: #shrinkWrap;
		cellInset: 8;
		cellPositioning: #center.
	self addMorph: mainColumn.
	self layoutChanged! !

!TaskListMorph methodsFor: 'cycling' stamp: ''!
selectPreviousTask
	"Make the previous task active."
	
	self selectTask: (self tasks
		before: self activeTask
		ifAbsent: [self tasks isEmpty
					ifFalse: [self tasks last]])! !

!TaskListMorph methodsFor: 'private' stamp: ''!
updateButtonsAndPreview
	"Update the buttons and the preview.."
	
	self
		updateTaskButtons;
		updatePreview.
	self world ifNotNil: 
		[self center: self world center]! !

!TaskListMorph methodsFor: 'open/close' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!TaskListMorph class methodsFor: 'instance creation' stamp: ''!
from: aKeyboardEvent 

	| instance |
	instance := self new.
	aKeyboardEvent shiftPressed
		ifTrue: [ instance selectNextTask ]
		ifFalse: [ instance selectPreviousTask ].
	^ instance.! !

!TaskListMorph class methodsFor: 'testing' stamp: ''!
isNavigationEvent: aKeyboardEvent

	^ aKeyboardEvent asKeyCombination = Character tab alt or: [ aKeyboardEvent asKeyCombination = Character tab alt shift ].! !

!TaskListMorph class methodsFor: 'settings' stamp: ''!
keepOpen: aBoolean
	KeepOpen := aBoolean! !

!TaskListMorph class methodsFor: 'settings' stamp: ''!
keepOpen
	^ KeepOpen ifNil: [KeepOpen := false]! !

!TaskListMorph class methodsFor: 'settings' stamp: ''!
taskListSettingOn: aBuilder
	<systemsettings> 
	(aBuilder setting: #keepTaskListOpen)
		label: 'Keep task list open';
		description: 'Whether the tasklist is closed (and the selected window activated) when the command key is released';
		default: false;
		parent: #morphic;
		selector: #keepOpen;
		target: self.! !

!TaskbarItemMorph commentStamp: ''!
Description
--------------------

A TaskbarItemMorph is a Morph representing a unique item of the taskbar. 

It can be customized via the current theme for its border and fill style.

Examples
--------------------

	(TaskbarItemMorph on: aWindow getState: #isActive action: #taskbarButtonClicked)
		initializeFor: aTaskbar;
		yourself!
!TaskbarItemMorph methodsFor: 'customization' stamp: ''!
addEmphaseTo: lab
	"1 -> bold"
	
	self model isActive ifFalse: [ ^ self ].
	
	lab emphasis: 1! !

!TaskbarItemMorph methodsFor: 'style - border' stamp: ''!
mouseOverBorderStyle
	"Return the mouse over borderStyle of the receiver."
	
	^ self theme taskbarItemMouseOverBorderStyleFor: self! !

!TaskbarItemMorph methodsFor: 'style - filling' stamp: ''!
selectedDisabledFillStyle
	"Return the selected disabled fillStyle of the receiver."
	
	^ self theme taskbarItemSelectedDisabledFillStyleFor: self! !

!TaskbarItemMorph methodsFor: 'style - filling' stamp: ''!
selectedPressedFillStyle
	"Return the selected pressed fillStyle of the receiver."
	
	^ self theme taskbarItemSelectedPressedFillStyleFor: self! !

!TaskbarItemMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self borderStyle: (self theme taskbarItemNormalBorderStyleFor: self)! !

!TaskbarItemMorph methodsFor: 'style - border' stamp: ''!
normalBorderStyle
	"Return the normal borderStyle of the receiver."
	
	^ self theme taskbarItemNormalBorderStyleFor: self! !

!TaskbarItemMorph methodsFor: 'accessing' stamp: ''!
labelSizeIn: aTaskbar
	^ (150 // (aTaskbar tasks size + 1) max: 10) min: 30! !

!TaskbarItemMorph methodsFor: 'style - border' stamp: ''!
pressedBorderStyle
	"Return the pressed borderStyle of the receiver."
	
	^ self theme taskbarItemPressedBorderStyleFor: self! !

!TaskbarItemMorph methodsFor: 'initialization' stamp: ''!
initializeAnnouncements
	self 
		on: #mouseEnter send: #taskbarButtonEntered:event:in: to: self model withValue: self;
		on: #mouseLeave send: #taskbarButtonLeft:event:in: to: self model withValue: self! !

!TaskbarItemMorph methodsFor: 'initialization' stamp: ''!
initializeFor: aTaskbar
	| lm lab labSize |
	labSize := self labelSizeIn: aTaskbar.
	lab := self labelOfSize: labSize.
	self addEmphaseTo: lab.
	lm := self theme
		newRowIn: aTaskbar
		for:
			{(self model taskbarIcon ifNil: [ ^ nil ]) asMorph.
			lab}.
	lm cellInset: 2.
	self
		label: lm font: self theme buttonFont;
		extent: self minExtent;
		hResizing: #rigid;
		vResizing: #rigid;
		useSquareCorners;
		getMenuSelector: #taskbarButtonMenu:.
	self initializeAnnouncements.
	lab
		color:
			(self model isCollapsed
				ifTrue: [ self theme taskbarItemLabelColorForCollapsed: self ]
				ifFalse: [ self theme taskbarItemLabelColorForExpanded: self ])! !

!TaskbarItemMorph methodsFor: 'style - filling' stamp: ''!
mouseOverFillStyle
	"Return the mouse over fillStyle of the receiver."
	
	^ self theme taskbarItemMouseOverFillStyleFor: self! !

!TaskbarItemMorph methodsFor: 'style - border' stamp: ''!
selectedDisabledBorderStyle
	"Return the selected disabled borderStyle of the receiver."
	
	^ self theme taskbarItemSelectedDisabledBorderStyleFor: self! !

!TaskbarItemMorph methodsFor: 'style - border' stamp: ''!
selectedBorderStyle
	"Return the selected borderStyle of the receiver."
	
	^ self theme taskbarItemSelectedBorderStyleFor: self! !

!TaskbarItemMorph methodsFor: 'style - filling' stamp: ''!
selectedFillStyle
	"Return the selected fillStyle of the receiver."
	
	^ self theme taskbarItemSelectedFillStyleFor: self! !

!TaskbarItemMorph methodsFor: 'style - border' stamp: ''!
selectedMouseOverBorderStyle
	"Return the selected mouse over borderStyle of the receiver."
	
	^ self theme taskbarItemSelectedMouseOverBorderStyleFor: self! !

!TaskbarItemMorph methodsFor: 'menu' stamp: ''!
wantsYellowButtonMenu
	^ true! !

!TaskbarItemMorph methodsFor: 'style - filling' stamp: ''!
normalFillStyle
	"Return the normal fillStyle of the receiver."
	
	^ self theme taskbarItemNormalFillStyleFor: self! !

!TaskbarItemMorph methodsFor: 'style - filling' stamp: ''!
disabledFillStyle
	"Return the disabled fillStyle of the receiver."
	
	^ self theme taskbarItemDisabledFillStyleFor: self! !

!TaskbarItemMorph methodsFor: 'accessing' stamp: ''!
labelOfSize: labSize
	^ self theme	buttonLabelForText: (self model taskbarLabel truncateWithElipsisTo: labSize)! !

!TaskbarItemMorph methodsFor: 'style - filling' stamp: ''!
pressedFillStyle
	"Return the pressed fillStyle of the receiver."
	
	^ self theme taskbarItemPressedFillStyleFor: self! !

!TaskbarItemMorph methodsFor: 'style - border' stamp: ''!
disabledBorderStyle
	"Return the disabled borderStyle of the receiver."
	
	^ self theme taskbarItemDisabledBorderStyleFor: self! !

!TaskbarItemMorph methodsFor: 'style - border' stamp: ''!
selectedPressedBorderStyle
	"Return the selected pressed borderStyle of the receiver."
	
	^ self theme taskbarItemSelectedPressedBorderStyleFor: self! !

!TaskbarItemMorph methodsFor: 'style - filling' stamp: ''!
selectedMouseOverFillStyle
	"Return the selected mouse over fillStyle of the receiver."
	
	^ self theme taskbarItemSelectedMouseOverFillStyleFor: self! !

!TaskbarMorph commentStamp: ''!
Themed synchronous taskbar (not using #step to poll windows). The buttons provide visual feedback as to whether a window is active or minimised (collapsed) plus a popup menu with options to restore, minimise, maximise and close the associated window. Optional (via settings) preview of the window while mouse is over a taskbar button.
!
!TaskbarMorph methodsFor: 'accessing' stamp: ''!
tasks: anObject
	"Set the value of tasks"

	tasks := anObject! !

!TaskbarMorph methodsFor: 'private - accessing' stamp: ''!
edgeToAdhereTo
	"Must implement. Answer #bottom."
	
	^#bottom! !

!TaskbarMorph methodsFor: 'initialization' stamp: ''!
initializeLayout
	"Initialize the layout."

	self
		changeTableLayout;
		layoutInset: 2;
		cellInset: 2;
		listDirection: #leftToRight;
		wrapDirection: #topToBottom;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		extent: self minimumExtent! !

!TaskbarMorph methodsFor: 'accessing' stamp: ''!
orderedTasks: anObject
	"Set the value of orderedTasks"

	orderedTasks := anObject! !

!TaskbarMorph methodsFor: 'testing' stamp: ''!
isAdheringToTop
	"Must implement. Answer false."
	
	^false! !

!TaskbarMorph methodsFor: 'testing' stamp: ''!
isAdheringToBottom
	"Must implement. Answer true."
	
	^true! !

!TaskbarMorph methodsFor: 'testing' stamp: ''!
isAdheringToRight
	"Must implement. Answer false."
	
	^false! !

!TaskbarMorph methodsFor: 'change reporting' stamp: ''!
ownerChanged
	"The receiver's owner has changed its layout.
	Since this method is called synchronously in the
	ui, delete the receiver if there are any excpetions."
	
	self owner ifNil: [^self].
	[self updateBounds.
	self updateTasks]
		on: Exception
		do: [:ex | self delete. ex pass].
	super ownerChanged! !

!TaskbarMorph methodsFor: 'testing' stamp: ''!
isTaskbar
	"Answer true."

	^true! !

!TaskbarMorph methodsFor: 'theme' stamp: ''!
themeChanged
	"The theme has changed. Update our appearance."

	self initializeAppearance.
	self removeAllMorphs.
	super themeChanged.
	self updateTaskButtons! !

!TaskbarMorph methodsFor: 'taskbar' stamp: ''!
taskOf: aMorph
	"Answer the task of the given morph or nil if none."

	^self orderedTasks detect: [:t | t morph = aMorph] ifNone: []! !

!TaskbarMorph methodsFor: 'private' stamp: ''!
updateOrderedTasksFrom: tasksThatShouldBeUpdated
	| deadTasks |
	deadTasks := OrderedCollection new.
	self orderedTasks
		do: [ :aTaskbarTask | 
			tasksThatShouldBeUpdated
				detect:
					[ :aTaskThatShouldBeUpdated | aTaskThatShouldBeUpdated morph = aTaskbarTask morph ]
				ifFound: [ :foundTask | tasksThatShouldBeUpdated remove: foundTask ]
				ifNone: [ deadTasks add: aTaskbarTask ] ].
	(deadTasks isEmpty and: [ tasksThatShouldBeUpdated isEmpty ])
		ifTrue: [ ^ self ].
	self orderedTasks: (self orderedTasks 
		removeAll: deadTasks;
		addAll: tasksThatShouldBeUpdated;
		yourself)! !

!TaskbarMorph methodsFor: 'taskbar' stamp: ''!
indicateModalChildForMorph: aMorph
	"Flash the button corresonding to the given morph ."
	
	(self buttonForMorph: aMorph) ifNotNil: [:b |
		b indicateModalChild]! !

!TaskbarMorph methodsFor: 'initialization' stamp: ''!
intoWorld: aWorld
	"Stick to the bottom left now."
	
	self
		setToAdhereToEdge: #bottomLeft;
		updateBounds.
	super intoWorld: aWorld! !

!TaskbarMorph methodsFor: 'taskbar' stamp: ''!
updateTasks
	"Check for changes in the world's submorphs.
	Note that if the task attributes change then a
	task will be considered dead along with a new replacement."

	| wm deadTasks newTasks taskbarTasksFromWorldMorph |
	wm := self worldMorphs asOrderedCollection.
	taskbarTasksFromWorldMorph := (wm collect: [ :m | m taskbarTask ])
		reject: [ :m | m isNil ].
	self tasks: taskbarTasksFromWorldMorph.
	deadTasks := self orderedTasks difference: self tasks.
	newTasks := self tasks difference: self orderedTasks.
	(newTasks isEmpty and: [ deadTasks isEmpty ])
		ifTrue: [ ^ self ].	"no changes"
	newTasks copy
		do: [ :t | 
			self orderedTasks
				detect: [ :ot | ot morph = t morph ]
				ifFound: [ :ot | 
					self orderedTasks replaceAll: ot with: t.
					deadTasks remove: ot.
					newTasks remove: t ] ].	"replace in order any changed tasks."
	self orderedTasks
		removeAll: deadTasks;
		addAll: newTasks reversed.
	self updateTaskButtons.
	self
		defer: [ "may have a different number of rows" self layoutChanged ]! !

!TaskbarMorph methodsFor: 'recategorized' stamp: ''!
rejectsEvent: anEvent
	(anEvent isMouse and: [ anEvent isMouseDown ]) ifTrue: [ ^ (self submorphs anySatisfy: [ :each | each containsPoint: anEvent cursorPoint ]) not ].
	
	^ super rejectsEvent: anEvent! !

!TaskbarMorph methodsFor: 'private - layout' stamp: ''!
updateBounds
	"Update the receiver's bounds to fill the world."

	self
		width: self owner width;
		snapToEdgeIfAppropriate! !

!TaskbarMorph methodsFor: 'taskbar' stamp: ''!
buttonForMorph: aMorph
	"Answer the button corresonding to the given
	morph or nil if none."
	
	|index|
	index := (self orderedTasks collect: [:t | t morph]) indexOf: aMorph.
	^index = 0 ifTrue: [nil] ifFalse: [self submorphs at: index ifAbsent: []]! !

!TaskbarMorph methodsFor: 'testing' stamp: ''!
isAdheringToLeft
	"Must implement. Answer false."
	
	^false! !

!TaskbarMorph methodsFor: 'accessing' stamp: ''!
wantsToBeTopmost
	"Answer if the receiver want to be one of the topmost
	objects in its owner."
	
	^ true! !

!TaskbarMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		initializeLayout;
		initializeAppearance;
		tasks: #();
		orderedTasks: OrderedCollection new! !

!TaskbarMorph methodsFor: 'taskbar' stamp: ''!
removeFromWorld
	"Delete the receiver from its world after restoring minimized tasks.
	Collapse those that were minimized after removal.
	Turn window animation off for the duration."

	|mins animation|
	mins := self tasks select: [:t | t isMinimized].
	animation := self theme shouldUseAnimations.
	animation ifTrue: [self theme useAnimation: false].
	[mins do: [:t | t morph restore; resetCollapsedFrame].
	self delete.
	mins do: [:t | t morph minimize]]
		ensure: [animation ifTrue: [self theme useAnimation: true]]! !

!TaskbarMorph methodsFor: 'taskbar' stamp: ''!
taskButtonOf: aMorph
	"Answer the task button of the given morph or nil if none."

	^self submorphs detect: [:t | t model = aMorph] ifNone: []! !

!TaskbarMorph methodsFor: 'geometry' stamp: ''!
minimumExtent
	"Answer the minimum extent."

	^40@25! !

!TaskbarMorph methodsFor: 'testing' stamp: ''!
isDockingBar
	"Answer yes so we get updated when the Display is resized."

	^true! !

!TaskbarMorph methodsFor: 'accessing' stamp: ''!
orderedTasks
	"Answer the value of orderedTasks"

	^ orderedTasks! !

!TaskbarMorph methodsFor: 'theme' stamp: ''!
preferredButtonCornerStyle
	"Answer the preferred button corner style
	for submorphs."

	^#square! !

!TaskbarMorph methodsFor: 'change reporting' stamp: ''!
displayExtentChanged

	self updateBounds! !

!TaskbarMorph methodsFor: 'accessing' stamp: ''!
tasks
	"Answer the value of tasks"

	^ tasks! !

!TaskbarMorph methodsFor: 'private' stamp: ''!
updateTaskButtons
	"Make buttons for the ordered tasks."
	
	| oldButtons size |
	oldButtons := self submorphs copy.
	self removeAllMorphs.
	self defer: [oldButtons do: [:b | b model: nil]]. "release dependency after event handling"
	
	size := self orderedTasks size.
	(self orderedTasks copyFrom: ( size - self class maximumButtons + 1 max: 1 ) to: size) do: [:t | | button |
		button := t taskbarButtonFor: self.
		button ifNotNil: [self addMorphBack: button]]! !

!TaskbarMorph methodsFor: 'drawing' stamp: ''!
clipSubmorphs 

	^ true! !

!TaskbarMorph methodsFor: 'setting' stamp: ''!
showWindowPreview
	^ self class showWindowPreview! !

!TaskbarMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	"Best to say we will to avoid being grabbed."
	
	^true! !

!TaskbarMorph methodsFor: 'wiw support' stamp: ''!
morphicLayerNumber
	"Helpful for ensuring some morphs always appear in front of or 
	behind others. Smaller numbers are in front"
	
	^11! !

!TaskbarMorph methodsFor: 'initialization' stamp: ''!
initializeAppearance
	"Initialize the appearance."

	self
		color: (self theme textColor alpha: 0.3);
		fillStyle: (self theme taskbarFillStyleFor: self)! !

!TaskbarMorph methodsFor: 'taskbar' stamp: ''!
worldMorphs
	"Answer the world's submorphs plus those in hand.
	Nasty case since hand removes the morph before dropping"
	
	^self world submorphs, 
		((self tasks
			select: [:t | t morph owner = self world activeHand])
				collect: [:t | t morph])! !

!TaskbarMorph class methodsFor: 'setting' stamp: ''!
maximumButtons: anInteger
	(anInteger isKindOf: Integer) ifFalse: [ ^ self ].
	anInteger > 0 ifFalse: [ ^ self ].
	MaximumButtons := anInteger.! !

!TaskbarMorph class methodsFor: 'class initialization' stamp: ''!
initialize
	"Initialize the receiver."
	self showTaskbarPreferenceChanged! !

!TaskbarMorph class methodsFor: 'setting' stamp: ''!
maximumButtonsDefault
	^100! !

!TaskbarMorph class methodsFor: 'setting' stamp: ''!
showTaskbar
	^ ShowTaskbar ifNil: [ShowTaskbar := true]! !

!TaskbarMorph class methodsFor: 'setting' stamp: ''!
showTaskbar: aBoolean
	ShowTaskbar ~= aBoolean
		ifTrue: [ShowTaskbar := aBoolean.
			self showTaskbarPreferenceChanged]! !

!TaskbarMorph class methodsFor: 'setting' stamp: ''!
showWindowPreview
	^ ShowWindowPreview ifNil: [ShowWindowPreview := true]! !

!TaskbarMorph class methodsFor: 'setting' stamp: ''!
showWindowPreview: aBoolean
	ShowWindowPreview := aBoolean! !

!TaskbarMorph class methodsFor: 'setting' stamp: ''!
taskbarSettingOn: aBuilder
	<systemsettings>
	(aBuilder setting: #showTaskbar)
		target: self;
		parent: #morphic;
		label: 'Taskbar';
		default: true;
		description: 'Whether the world''s taskbar should be shown or not.';
		with: [
			(aBuilder setting: #showWindowPreview)
				label: 'Window preview' ;
				default: true;
				description: 'Whether the world''s taskbar buttons should show previews of the associated window while the mouse is over them.'.
			(aBuilder setting: #maximumButtons)
				label: 'Maximum number of tasks to show';
				default: 100;
				description: ('By default, the value is ', self maximumButtonsDefault printString).

		]! !

!TaskbarMorph class methodsFor: 'setting' stamp: ''!
showTaskbarPreferenceChanged
	"Add or remove the taskbar as appropriate.
	Delegate to the current World."
	
	self currentWorld showWorldTaskbar:  self showTaskbar! !

!TaskbarMorph class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	"Remove the taskbar and add a new one." 
	
	(self currentWorld submorphs select: [:m | m isKindOf: self])
		do: [:tb | tb delete].
	self currentWorld createTaskbarIfNecessary! !

!TaskbarMorph class methodsFor: 'setting' stamp: ''!
maximumButtons
	^ MaximumButtons ifNil: [MaximumButtons := self maximumButtonsDefault]! !

!TaskbarMorphTest commentStamp: ''!
A TaskbarMorphTest is a test class for testing the behavior of TaskbarMorph!
!TaskbarMorphTest methodsFor: 'tests' stamp: ''!
testEmptyTaskBarList
	taskbar := self.
	world := self.
	taskbar updateTasks.
	self assert: taskbar tasks size equals: 0! !

!TaskbarMorphTest methodsFor: 'tests' stamp: ''!
testUpdateTaskBarShouldContainsTaskbarTasks
	taskbar := self.
	world := self.
	world addWindow.
	taskbar updateTasks.
	self assert: (taskbar tasks first isKindOf: TaskbarTask)! !

!TaskbarMorphTest methodsFor: 'tests' stamp: ''!
testUpdateEmptyTaskBarWithNewWindow
	taskbar := self.
	world := self.
	world addWindow.
	taskbar updateTasks.
	self assert: taskbar tasks size equals: 1! !

!TaskbarMorphTest methodsFor: 'mocking world' stamp: ''!
removeWindow: aMorph 
	windows remove: aMorph! !

!TaskbarMorphTest methodsFor: 'tests' stamp: ''!
testUpdateTaskBarShouldContainsTaskbarTasksForEachWindow
	| window1 window2 |
	taskbar := self.
	world := self.
	window1 := world addWindow.
	window2 := world addWindow.
	taskbar updateTasks.
	self assert: taskbar tasks first morph equals: window1.
	self assert: taskbar tasks second morph equals: window2! !

!TaskbarMorphTest methodsFor: 'mocking taskbar' stamp: ''!
orderedTasks: aCollection 
	tasks:= aCollection! !

!TaskbarMorphTest methodsFor: 'the real thing - aka: the test subject' stamp: ''!
theMethodInProdThatShouldBeTested
	^ TaskbarMorph >> #updateOrderedTasksFrom:! !

!TaskbarMorphTest methodsFor: 'mocking taskbar' stamp: ''!
orderedTasks
	^tasks! !

!TaskbarMorphTest methodsFor: 'mocking taskbar' stamp: ''!
tasks
	^tasks! !

!TaskbarMorphTest methodsFor: 'mocking world' stamp: ''!
addWindow
	^world addWindowToWorld! !

!TaskbarMorphTest methodsFor: 'mocking world' stamp: ''!
addWindowToWorld
	| morph |
	morph := Morph new.
	windows add: morph. 
	^morph! !

!TaskbarMorphTest methodsFor: 'the real thing - aka: the test subject' stamp: ''!
updateOrderedTasksFrom: tasksThatShouldBeUpdated
	| deadTasks |
	deadTasks := OrderedCollection new.
	self orderedTasks
		do: [ :aTaskbarTask | 
			tasksThatShouldBeUpdated
				detect:
					[ :aTaskThatShouldBeUpdated | aTaskThatShouldBeUpdated morph = aTaskbarTask morph ]
				ifFound: [ :foundTask | tasksThatShouldBeUpdated remove: foundTask ]
				ifNone: [ deadTasks add: aTaskbarTask ] ].
	(deadTasks isEmpty and: [ tasksThatShouldBeUpdated isEmpty ])
		ifTrue: [ ^ self ].
	self orderedTasks: (self orderedTasks 
		removeAll: deadTasks;
		addAll: tasksThatShouldBeUpdated;
		yourself)! !

!TaskbarMorphTest methodsFor: 'mocking taskbar' stamp: ''!
newTaskFor: window
	^ TaskbarTask
		morph: window
		state: #aNilState
		icon: nil
		label: 'a Label'! !

!TaskbarMorphTest methodsFor: 'mocking taskbar' stamp: ''!
updateTasks
	| tasksThatShouldBeUpdated  |
	tasksThatShouldBeUpdated := windows
		collect: [ :window | self newTaskFor: window ].
	self updateOrderedTasksFrom: tasksThatShouldBeUpdated! !

!TaskbarMorphTest methodsFor: 'tests' stamp: ''!
testWhenRemovingWindowInWorldListTaskListShouldUpdateConsequently
	| window1 window2 |
	taskbar := self.
	world := self.
	window1 := world addWindow.
	window2 := world addWindow.
	taskbar updateTasks.
	world removeWindow: window1.
	taskbar updateTasks.
	self assert: taskbar tasks size equals: 1.
	self assert: taskbar tasks first morph equals: window2.! !

!TaskbarMorphTest methodsFor: 'mocking world' stamp: ''!
putOnTop: aMorph 
	windows remove: aMorph.
	windows addLast: aMorph! !

!TaskbarMorphTest methodsFor: 'tests' stamp: ''!
testIfTheTestedMethodIstheSameThatTheOneUsedInProd

	self assert: self theMethodInProdThatShouldBeTested bytecode equals: (self class >> #updateOrderedTasksFrom:) bytecode! !

!TaskbarMorphTest methodsFor: 'tests' stamp: ''!
testWhenChangingOrderInWorldListTaskOrderShouldRemains
	| window1 window2 |
	taskbar := self.
	world := self.
	window1 := world addWindow.
	window2 := world addWindow.
	taskbar updateTasks.
	world putOnTop: window1.
	taskbar updateTasks.
	self assert: taskbar tasks first morph equals: window1.
	self assert: taskbar tasks second morph equals: window2! !

!TaskbarMorphTest methodsFor: 'running' stamp: ''!
setUp 
	super setUp.
	windows := OrderedCollection new.
	tasks := OrderedCollection new.
	self theMethodInProdThatShouldBeTested.! !

!TaskbarTask commentStamp: ''!
Holds the state of a taskbar/tasklist entry.!
!TaskbarTask methodsFor: 'testing' stamp: ''!
isActive
	"Answer whether the task is active."

	^self state == #active! !

!TaskbarTask methodsFor: 'comparing' stamp: ''!
= aTaskbarTask
	"Answer whether equal."

	^self species = aTaskbarTask species
		and: [self morph == aTaskbarTask morph
		and: [self state == aTaskbarTask state
		and: [self icon = aTaskbarTask icon
		and: [self label = aTaskbarTask label]]]]! !

!TaskbarTask methodsFor: 'comparing' stamp: ''!
hash
	"Hash is implemented because #= is implemented."
	
	^self morph hash
		bitXor: (self state hash
		bitXor: (self icon hash
		bitXor: self label hash))! !

!TaskbarTask methodsFor: 'testing' stamp: ''!
isMinimized
	"Answer whether the task is minimized."

	^self state == #minimized! !

!TaskbarTask methodsFor: 'accessing' stamp: ''!
label: anObject
	"Set the value of label"

	label := anObject! !

!TaskbarTask methodsFor: 'user-interface' stamp: ''!
taskbarButtonFor: aTaskBar
	"Answer a button for the task."
	
	^self morph taskbarButtonFor: aTaskBar! !

!TaskbarTask methodsFor: 'accessing' stamp: ''!
state: anObject
	"Set the value of state"

	state := anObject! !

!TaskbarTask methodsFor: 'accessing' stamp: ''!
theme
	^ Smalltalk ui theme! !

!TaskbarTask methodsFor: 'accessing' stamp: ''!
morph
	"Answer the value of morph"

	^ morph! !

!TaskbarTask methodsFor: 'accessing' stamp: ''!
morph: anObject
	"Set the value of morph"

	morph := anObject! !

!TaskbarTask methodsFor: 'accessing' stamp: ''!
state
	"Answer the value of state"

	^ state! !

!TaskbarTask methodsFor: 'user-interface' stamp: ''!
taskListButtonFor: aTasklist
	"Answer a button for the task."
	
	^self theme
		newTaskListButtonIn: aTasklist
		for: self! !

!TaskbarTask methodsFor: 'accessing' stamp: ''!
icon
	"Answer the value of icon"

	^ icon! !

!TaskbarTask methodsFor: 'user-interface' stamp: ''!
buttonClickedForTaskList: aTasklist
	"Notify the tasklist."
	
	aTasklist taskClicked: self! !

!TaskbarTask methodsFor: 'activation' stamp: ''!
activate
	"Activate the task."
	
	(self morph respondsTo: #restoreAndActivate)
		ifTrue: [self morph restoreAndActivate]! !

!TaskbarTask methodsFor: 'accessing' stamp: ''!
icon: anObject
	"Set the value of icon"

	icon := anObject! !

!TaskbarTask methodsFor: 'accessing' stamp: ''!
label
	"Answer the value of label"

	^ label! !

!TaskbarTask class methodsFor: 'intance creation' stamp: ''!
morph: aMorph state: aSymbol icon: aForm label: aString
	"Answer a new instance of the receiver with the given parameters."

	^self new
		morph: aMorph;
		state: aSymbol;
		icon: aForm;
		label: aString! !

!TelnetProtocolClient commentStamp: ''!
Abstract super class for protocol clients based on the generic telnet protocol "<response code> <response>"

Structure:
	responseCode	the numerical (integer) value of the last response code
!
!TelnetProtocolClient methodsFor: 'private - testing' stamp: ''!
responseIsContinuation: response
	^(response size > 3
		and: [(response at: 4) == $-])! !

!TelnetProtocolClient methodsFor: 'private' stamp: ''!
determineResponseCode
	self lastResponse size >= 3
		ifFalse: [^0].
	^[SmallInteger readFromString: (self lastResponse copyFrom: 1 to: 3)]
		on: Error
		do: [:ex | ex return: 0]! !

!TelnetProtocolClient methodsFor: 'private - protocol' stamp: ''!
fetchNextResponse
	"The FTP and similar protocols allow multi-line responses.
	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."

	| response result firstLine |
	result := '' writeStream.
	firstLine := self stream nextLine.
	result nextPutAll: firstLine.
	(self responseIsContinuation: firstLine) 
		ifTrue: 
			["continued over multiple lines. Discard continuation lines."

			
			[response := self stream nextLine.
			response ifNil: [^nil].
			response size > 3 and: 
					[(response copyFrom: 1 to: 3) = (firstLine copyFrom: 1 to: 3) 
						and: [(response at: 4) = Character space]]] 
					whileFalse: 
						[result
							cr;
							nextPutAll: response]].
	self lastResponse: result contents! !

!TelnetProtocolClient methodsFor: 'private - protocol' stamp: ''!
lookForCode: code ifDifferent: handleBlock
	"We are expecting a certain code next."

	self fetchNextResponse.

	self responseCode == code
		ifFalse: [handleBlock value: self lastResponse]! !

!TelnetProtocolClient methodsFor: 'private - testing' stamp: ''!
responseIsError
	^self responseCode between: 500 and: 599! !

!TelnetProtocolClient methodsFor: 'private - testing' stamp: ''!
responseIsContinuation
	^(self lastResponse size > 3
		and: [(self lastResponse at: 4) == $-])! !

!TelnetProtocolClient methodsFor: 'private - protocol' stamp: ''!
lookForCode: code
	"We are expecting a certain code next."

	self
		lookForCode: code
		ifDifferent: [:response | (TelnetProtocolError protocolInstance: self) signal: response]! !

!TelnetProtocolClient methodsFor: 'private' stamp: ''!
lastResponse: aString
	super lastResponse: aString.
	responseCode := self determineResponseCode! !

!TelnetProtocolClient methodsFor: 'accessing' stamp: ''!
responseCode
	^responseCode! !

!TelnetProtocolClient methodsFor: 'private - testing' stamp: ''!
responseIsWarning
	^self responseCode between: 400 and: 499! !

!TelnetProtocolClient class methodsFor: 'accessing' stamp: ''!
rawResponseCodes
	self subclassResponsibility! !

!TelnetProtocolError commentStamp: ''!
Abstract super class for exceptions signalled by clients based on the telnet protocol.
!
!TelnetProtocolError methodsFor: 'accessing' stamp: ''!
code
	^self protocolInstance responseCode! !

!TelnetProtocolError methodsFor: 'private' stamp: ''!
isCommandUnrecognized
	^ self code = 500! !

!TemporaryVariable commentStamp: ''!
I model temp variables. With Closures, there are two kinds: Copying and those that are stored in a so called temp vector, a heap allocated array that itself is stored in a copying temp variable.!
!TemporaryVariable methodsFor: '*NewTools-Debugger' stamp: ''!
variableTag
	^ 'temp. var'! !

!TemporaryVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitTemporaryVariableNode: aNode! !

!TemporaryVariable methodsFor: 'testing' stamp: ''!
isTempVariable

	^ true! !

!TemporaryVariable methodsFor: 'queries' stamp: ''!
definingNode
	^ scope node temporaries 
		detect: [ :each | each name = name ]
		ifNone: [ nil ]! !

!TemporaryVariable methodsFor: '*NewTools-Debugger' stamp: ''!
debuggerColor
	^(SHRBTextStyler new attributesFor: #string) first color! !

!TemporaryVariableTest commentStamp: ''!
Tests for TemporaryVariable !
!TemporaryVariableTest methodsFor: 'properties' stamp: ''!
testPropertyAtPut

	| testValue temp |
	
	testValue := Date today.
	temp := thisContext temporaryVariableNamed:  #testValue.
	
	temp propertyAt: #testKeySelector put: testValue.
	self
		assert: (temp propertyAt: #testKeySelector)
		equals: testValue.
		
	temp removeProperty: #testKeySelector.
	self assert: temp properties isNil! !

!TemporaryVariableTest methodsFor: 'tests' stamp: ''!
testScope
	| method variable |
	method := self class >> #testTemporaryVariablesMethod.
	self assert: method temporaryVariables first scope isMethodScope.
	
	variable := method temporaryVariables first.
	self assert: (variable scope lookupVar: variable name) equals: variable! !

!TemporaryVariableTest methodsFor: 'tests' stamp: ''!
testHasTemporaryVariablesBlock
	| block |
	block := [ | b | b := 2. b +2  ].
	self assert: (block hasTemporaryVariableNamed: #b)! !

!TemporaryVariableTest methodsFor: 'tests' stamp: ''!
testTemporaryVariablesMethod
	| method |
	method := self class >> #testTemporaryVariablesMethod.
	self assert: method temporaryVariables first name equals: #method.
	
	"On the level of CompiledMethod, args include temps. This needs to be fixed"
	method := OrderedCollection >> #do:.
	self assert: method temporaryVariables first name equals: #aBlock.
	self assert: (method hasTemporaryVariableNamed: #aBlock).
	self assert: (method temporaryVariableNamed: #aBlock) class equals: ArgumentVariable.! !

!TemporaryVariableTest methodsFor: 'tests' stamp: ''!
testReadTemporaryVariablesMethod
	| tempVar |
	tempVar := thisContext temporaryVariableNamed: #tempVar.

	self assert: (tempVar readInContext: thisContext) class equals: TemporaryVariable! !

!TemporaryVariableTest methodsFor: 'tests' stamp: ''!
testTemporaryVariablesBlock
	| block |
	block := [ | b | b +2  ].
	self assert: block temporaryVariables first name equals: #b! !

!TemporaryVariableTest methodsFor: 'tests' stamp: ''!
testReadNodes
	| method |
	"On the level of CompiledMethod, args include temps. This needs to be fixed"
	method := OrderedCollection >> #do:.
	self assert: (method temporaryVariableNamed: #aBlock) astNodes notEmpty! !

!TemporaryVariableTest methodsFor: 'tests' stamp: ''!
testWriteTemporaryVariablesMethod
	| tempVar |
	tempVar := thisContext temporaryVariableNamed: #tempVar.

	tempVar write: 5 inContext: thisContext.
	self assert: tempVar equals: 5! !

!TemporaryVariableTest methodsFor: 'tests' stamp: ''!
testDeclaringNode
	| method declaringNode declaringNodeViaVariable|
	method := self class >> #testTemporaryVariablesMethod.
	declaringNode := method ast body temporaries first.
	declaringNodeViaVariable := method assignmentNodes first variable variable definingNode.
	self assert: declaringNodeViaVariable equals: declaringNode.
	
	method := OrderedCollection >> #do:.
	declaringNode := method ast arguments first.
	declaringNodeViaVariable := method ast variableReadNodes third variable definingNode.
	self assert: declaringNodeViaVariable equals: declaringNode.! !

!TemporaryVariableTest methodsFor: 'tests' stamp: ''!
testHasTemporaryVariablesMethod
	| method |
	method := self class >> #testTemporaryVariablesMethod.
	self assert: (method hasTemporaryVariableNamed: #method)! !

!TemporaryVariableTest methodsFor: 'tests' stamp: ''!
testIsReferenced
	| method notReferenced |
	"The temp notReferenced is not used as we test exactly that here"
	method := self class >> #testIsReferenced.
	self assert: method temporaryVariables first isReferenced.
	self deny: method temporaryVariables second isReferenced.! !

!TermInfoCharacter commentStamp: ''!
I'm a TermCap which define the styles with the printing of characters, used when OSSubProcess is not installed in the image.
Not really powerful, better install OSSubProcess and use TermCapTput!
!TermInfoCharacter methodsFor: 'styling' stamp: ''!
setBackgroundColor: aColor

	self set: aColor asTerminfoCharacterBackground , 'm'.! !

!TermInfoCharacter methodsFor: 'term style' stamp: ''!
on: aStream
	"Define the stream where termcap will change the style, normally it's used on a terminal"

	out := aStream! !

!TermInfoCharacter methodsFor: 'styling' stamp: ''!
setFontColor: aColor 

	self set: aColor asTerminfoCharacterFont, 'm'! !

!TermInfoCharacter methodsFor: 'term style' stamp: ''!
set: aString
	self print: Character escape asString, '['   , aString! !

!TermInfoCharacter methodsFor: 'streaming' stamp: ''!
print: aString
	"Print on the outStream aString"

	out nextPutAll: aString! !

!Termcap commentStamp: ''!
I provide a simple mapping from high-level commands to low-level terminal character sequences.
!
!Termcap methodsFor: 'initialization' stamp: ''!
initializeDefaultSequences
	"Until we have decent OSProcess support we precache the most common sequences"
	| esc |
	esc := (Character escape asString), '['.
	cache at: #up put: (esc, 'A').
	cache at: #le put: (esc, 'D').
	cache at: #nd put: (esc, 'C').
	cache at: #im put: ''.
	cache at: #ei put: ''.
	cache at: #mr put: (esc, '7m').
	cache at: #me put: (esc, '0m').
	cache at: #ce put: (esc, 'K').
	cache at: #al put: (esc, 'L').
	cache at: #dl put: (esc, 'M').
	cache at: #cr put: (esc, String cr).! !

!Termcap methodsFor: 'initialization' stamp: ''!
initialize
	cache := Dictionary new.
	self initializeDefaultSequences.! !

!Termcap methodsFor: 'accessing' stamp: ''!
getent: aString
	"The tgetent routine loads the entry for name. 
	It returns 1 on success, 
	0 if there is no such entry,
	 and -1 if the terminfo database could not be found."
	
	"result := (PipeableOSProcess command: 'tput ', aString) output asInteger.
	result = 1 ifTrue: [ ^ self ].
	result = 0 ifTrue: [ Error signal: 'No such tget entry: ', aString aString ].
	result = -1 ifTrue: [ Error signal: 'Could not find terminfo database' ]."
	
	Error signal: 'Cannot interact with tput yet'.
	! !

!Termcap methodsFor: 'initialization' stamp: ''!
flush
	cache removeAll! !

!Termcap methodsFor: 'accessing' stamp: ''!
getnum: aString
	"^ (PipeableOSProcess command: 'tput ', aString) output asInteger"
	^ Error signal: 'Cannot interact with the terminal yet'.! !

!Termcap methodsFor: 'accessing' stamp: ''!
getflag: aString
	"^ (PipeableOSProcess command: 'tput ', aString) output"
	Error signal: 'Cannot interact with tput yet'! !

!Termcap methodsFor: 'initialization' stamp: ''!
reset
	self flag: 'TODO implement once we have OSProcess'.
	"self getent: (OSProcess thisOSProcess environmentAt: #TERM)"! !

!Termcap methodsFor: 'accessing' stamp: ''!
getstr: aString
	^ cache
		at: aString 
		ifAbsentPut: [ 
			"(PipeableOSProcess command: 'tput ', aString) output"
			^ Error signal: 'Terminal capability ', aString, ' not found' ]! !

!TestAnnouncement commentStamp: ''!
Notify about testing a test!
!TestAnnouncement methodsFor: 'accessing' stamp: ''!
test: aTest

	test := aTest! !

!TestAnnouncement methodsFor: 'accessing' stamp: ''!
test

	^ test! !

!TestAnnouncement class methodsFor: 'instance creation' stamp: ''!
with: aTestCase
	^self new
		test: aTestCase;
		yourself! !

!TestAsserter commentStamp: ''!
I understand methods beginning with `assert:...` and `deny:...` (and my class-side understands `TestAsserter class >>#assert:description:`).  I am the superclass of `TestCase` and `TestResource` and can also be the superclass of any test helper classes you create to factor out test behaviour.  I exist so that test code can be refactored between my subclasses without difficulty.

Send `#assert:description:` when you want to check for an expected value. For example, you might say
	`self assert: socket isOpen description: 'We requested a socket but now it is not open'.`
to test whether or not a socket is open at a point in a test.  

Use description strings both to give more information about where a test failed in debugger notifiers and logs, and to document the intent of a test.  
Other methods include `TestAsserter>>#assert:`, `TestAsserter>>#assert:description:resumable:`, `TestAsserter>>#deny:`, `TestAsserter>>#deny:description:`, `TestAsserter>>#deny:description:resumable:`, `TestAsserter>>#should:raise:`, `TestAsserter>>#should:raise:description:`, `TestAsserter>>#shouldnt:raise:`, `TestAsserter>>#shouldnt:raise:description:`.  (Any convenience assertion methods you create for general use should also be defined in my 'convenience' protocol.)

Override my class-side `TestAsserter class>>#isLogging` in subclasses to have failed assertion descriptions shown on the Transcript.  To have them appear elsewhere, also override my class-side `TestAsserter class>>#failureLog`.
!
!TestAsserter methodsFor: 'asserting' stamp: ''!
assert: aBooleanOrBlock description: aStringOrBlock resumable: resumableBoolean
	"Checks if aBooleanOrBlock evaluates to true (by sending #value message to it).
	 The message text of the assertion failure exception thrown in case aBooleanOrBlock
	 evaluates to false is determined by the evaluation of aStringOrBlock (again by
	 sending #value message to it).
	 The resumableBoolean flag is used to decide if the assertion failure signalled by
	 the source code below should be resumable or not.
	"
	<debuggerCompleteToSender>
	| exception aString |
	aBooleanOrBlock value
		ifTrue: [ ^ self ].
	
	aString := aStringOrBlock value.
	self logFailure: aString.
	exception := resumableBoolean
		ifTrue: [ self classForTestResult resumableFailure ]
		ifFalse: [ self classForTestResult failure ].
	exception signal: aString! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent
	"To test that a particular exception is raised during the execution of a Block"
	<debuggerCompleteToSender>
	^ self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)! !

!TestAsserter methodsFor: 'factory' stamp: ''!
classForTestResource
	^ TestResource! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
deny: actualNumber closeTo: expectedNumber
	"Tell whether the actualNumber and expectedNumber are NOT close to each others with a margin of
	 the default precision (see class-side method #defaultPrecisionsForCloseToComparison).
	"
	self deny: actualNumber closeTo: expectedNumber precision: self class defaultPrecisionsForCloseToComparison! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
assert: aBooleanOrBlock description: aStringOrBlock
	"This method raises an AssertionFailure with aString as #messageText if
	 aBooleanOrBlock evaluates to false.
	"
	<debuggerCompleteToSender>
	self assert: aBooleanOrBlock description: aStringOrBlock resumable: false! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anExceptionalEvent 
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: true]
			! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
assertCollection: actualCollection includesAny: subcollection
	"Raises an AssertionFailure if actualCollection does not include any of the elements of 
	 expectedCollection (using #includesAny: message).
    I also provide a specialized message for the AssertionFailure in case I fail.
 	"
	^ self
		assert: (actualCollection includesAny: subcollection)
		description: [ actualCollection asString , ' does not include any of ' , subcollection asString ]! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
skip
	"Don't run this test, and don't mark it as failure"
	TestSkipped signal! !

!TestAsserter methodsFor: 'private' stamp: ''!
unexpectedIdentityEqualityStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: 'Unexpected identity equality of ';
				nextPutAll: actual fullPrintString;
				nextPutAll: ' and ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent description: aString  
 
	^self
		assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not
		description: aString
			! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
deny: aBooleanOrBlock description: aStringOrBlock resumable: resumableBoolean
	"Checks if aBooleanOrBlock evaluates to false (by sending #value message to it).
	 aStringOrBlock and resumableBoolean parameters are used similarly as in
	 TestAsserter>>#assert:description:resumable:.
	"
	self
		assert: aBooleanOrBlock value not
		description: aStringOrBlock
		resumable: resumableBoolean
			! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
should: aBlock notTakeMoreThan: aDuration
    "Evaluate aBlock and if it takes more than given duration
    to run we report a test failure. "
	<debuggerCompleteToSender>
	^ aBlock valueWithin: aDuration onTimeout: [
		self 
			assert: false 
			description: ['Block evaluation took more than the expected <1p>' expandMacrosWith: aDuration]
	]
	
! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent  
	<debuggerCompleteToSender>
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not
			! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: substring description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: substring)
		description: aString
! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
denyEmpty: aCollection
	^ self assert: aCollection isNotEmpty description: aCollection asString , ' should not have been empty'! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
deny: actualNumber closeTo: expectedNumber precision: epsilon
	"Tell whether the actualNumber and expectedNumber are NOT close to each others with a margin of epsilon."

	^ self
		assert: (actualNumber closeTo: expectedNumber precision: epsilon) not
		description: [ self comparingStringBetween: actualNumber and: expectedNumber ]! !

!TestAsserter methodsFor: 'private' stamp: ''!
comparingStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: 'Got ';
				nextPutAll: actual fullPrintString;
				nextPutAll: ' instead of ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
deny: aBooleanOrBlock description: aString
	"This method raises an AssertionFailure with aString as #messageText if
	 aBooleanOrBlock evaluates to true."
	self deny: aBooleanOrBlock description: aString resumable: false! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
should: aBlock description: aString
	self assert: aBlock value description: aString
			! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: (ex description includesSubstring: aString) not ]
			! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock description: aString
	self deny: aBlock value description: aString
			! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
should: aBlock
	"Evaluate the Block first then execute the assertion"
	<debuggerCompleteToSender>
	self assert: aBlock value! !

!TestAsserter methodsFor: 'private' stamp: ''!
comparingCollectionBetween: left and: right
	"Returns a string that shows the size if they are different and the additional items for each left and right"

	| additionalLeft additionalRight sortBlock |
	"use a very slow sort block"
	sortBlock := [ :a :b | a asString <= b asString ].
	additionalLeft := (left difference: right) sorted: sortBlock.
	additionalRight := (right difference: left) sorted: sortBlock.
	^ String
		streamContents: [ :stream | 
			stream
				nextPutAll: 'Given Collections do not match. Got ';
				lf;
				tab;
				nextPutAll: 'left := ';
				print: left;
				nextPut: $.;
				lf;
				nextPutAll: ' instead of ';
				tab;
				nextPutAll: ' right :=';
				print: right;
				nextPut: $.;
				lf.
			left size = right size
				ifFalse: [ stream
						nextPutAll: 'Collection size does not match: left=';
						print: left size;
						nextPutAll: ' vs. right=';
						print: right size;
						lf ].
			additionalLeft isEmpty
				ifFalse: [ stream
						nextPutAll: 'Got ';
						print: additionalLeft size;
						nextPutAll: ' additional element(s) in the left collection: ';
						tab;
						print: additionalLeft ].
			additionalRight isEmpty
				ifFalse: [ stream
						nextPutAll: 'Got ';
						print: additionalRight size;
						nextPutAll: ' additional element(s) in the right collection: ';
						tab;
						print: additionalRight ] ]! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)
		description: aString
			! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
denyCollection: actual hasSameElements: expected
	"Deny that a collection contains the same elements as the given collection. Order is not checked, only the presence/absence of elements."

	self
		deny: ((actual difference: expected) isEmpty and: [ (expected difference: actual) isEmpty ])
		description: 'Given collections match!!'! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock

	^[aBlock value.
 	false] 
		on: anException
		do: [:exception | 
			anotherBlock value: exception.
			exception return: true]! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anException withExceptionDo: anotherBlock 
	<debuggerCompleteToSender>
	^self assert: (self executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock)! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
deny: actual equals: expected
	"This method raises an AssertionFailure if actual is equals (using #= message) to expected.
	 Else it does nothing and execution continues.
	"
	^ self
		deny: expected = actual
		description: [self unexpectedEqualityStringBetween: actual and: expected]! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
assert: actualNumber closeTo: expectedNumber
	"Tell whether the actualNumber and expectedNumber ARE close to each others with a margin of
	 the default precision (see class-side method #defaultPrecisionsForCloseToComparison).
	"
	self assert: actualNumber closeTo: expectedNumber precision: self class defaultPrecisionsForCloseToComparison! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
assert: actual identicalTo: expected
	"Verify whether the actual and the expected are the same object (have the same object pointer so #== returns true)."
	
	^ self
		assert: expected == actual
		description: [self comparingIdentityStringBetween: actual and: expected]! !

!TestAsserter methodsFor: 'factory' stamp: ''!
classForTestSuite
	"Returns the class of the test suite"
	
	"note that we did not name this method testSuiteClass because it is considered by tools as a test method. it could be suiteClass"
	^ self class classForTestSuite! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
fail: aDescriptionString

	^self assert: false description: aDescriptionString! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
signalFailure: aString
	self classForTestResult failure signal: aString! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
assertCollection: actualCollection equals: expectedCollection
	"Raises an AssertionFailure if actualCollection is not equal to expectedCollection (using #= message).
	 I also provide a specialized message for the AssertionFailure in case I fail.
	"

	^ self
		assert: actualCollection = expectedCollection
		description: [ self comparingCollectionBetween: actualCollection and: expectedCollection ]! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
deny: aBooleanOrBlock
	"This method raises an AssertionFailure if aBooleanOrBlock evaluates to true."
	self deny: aBooleanOrBlock description: 'Denial failed'! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
shouldFix: aBlock
	"Run the block expecting an Exception. Throw an assertion failure if the block does NOT throw an exception."
	<debuggerCompleteToSender>
	^ self should: aBlock raise: Exception! !

!TestAsserter methodsFor: 'private' stamp: ''!
unexpectedEqualityStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: 'Unexpected equality of ';
				nextPutAll: actual fullPrintString;
				nextPutAll: ' and ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
denyCollection: actualCollection includesAll: subcollection
	"Raises an AssertionFailure if actualCollection INCLUDES all the elements of expectedCollection (by negating result of #includesAll: message).
	 I also provide a specialized message for the AssertionFailure in case I fail.
	"
	
	^ self
		assert: (actualCollection includesAll: subcollection) not
		description: [ actualCollection asString , ' does not include all in ' , subcollection asString ]! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
assert: actual equals: expected
	"This method raises an AssertionFailure if actual is different (using #= message) from expected.
	 Else it does nothing and execution continues.
	"
	
	^ self
		assert: actual = expected
		description: [self comparingStringBetween: actual and: expected]! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
denyCollection: actualCollection equals: expectedCollection
	"Raises an AssertionFailure if actualCollection IS EQUAL to expectedCollection (using #= message).
	 I also provide a specialized message for the AssertionFailure in case I fail.
	"

	^ self
		deny: actualCollection = expectedCollection
		description: [ self unexpectedEqualityStringBetween: actualCollection and: expectedCollection ]! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock
	self deny: aBlock value
			! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: substring description: aString 
	 
	^self
		assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: substring) not
		description: aString
! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
deny: actual identicalTo: expected
	"Verify whether the actual and the expected are NOT the same object (have the same object pointer so #== returns false)."
	^ self
		deny: expected == actual
		description: [self unexpectedIdentityEqualityStringBetween: actual and: expected]! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
assertCollection: actualCollection includesAll: subcollection
	"Raises an AssertionFailure if actualCollection does not include all the elements of expectedCollection (using #includesAll: message).
	 I also provide a specialized message for the AssertionFailure in case I fail.
	"

	^ self
		assert: (actualCollection includesAll: subcollection)
		description: [ actualCollection asString , ' does not include all in ' , subcollection asString ]! !

!TestAsserter methodsFor: 'factory' stamp: ''!
defaultTestError

	^ self classForTestResult error! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
assertCollection: actualCollection hasSameElements: expected
	"Assert that a collection contains the same elements as the given collection. Order is not checked, only the presence/absence of elements."

	| missingElements additionalElements |
	additionalElements := actualCollection difference: expected.
	missingElements := expected difference: (actualCollection intersection: expected).
	self
		assert: (additionalElements isEmpty and: [ missingElements isEmpty ])
		description:
			(String
				streamContents: [ :stream | 
					stream
						nextPutAll: 'Given Collections do not match!!';
						lf;
						tab;
						nextPutAll: 'additions : ';
						print: additionalElements asArray;
						lf;
						tab;
						nextPutAll: 'missing: ';
						print: missingElements asArray;
						lf ])! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
assert: actualNumber closeTo: expectedNumber precision: epsilon
	"Tell whether the actualNumber and expectedNumber ARE close to each others with a margin of epsilon."

	^ self
		assert: (actualNumber closeTo: expectedNumber precision: epsilon)
		description: [ self comparingStringBetween: actualNumber and: expectedNumber ]! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: substring description: aString  
	 
	^self 
		assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: substring) not
		description: aString
! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: substring description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: substring)
		description: aString
! !

!TestAsserter methodsFor: 'private' stamp: ''!
comparingIdentityStringBetween: actual and: expected

	^ String streamContents: [:stream |
			stream
				nextPutAll: actual fullPrintString;
				nextPutAll: ' is not identical to ';
				nextPutAll: expected fullPrintString;
				nextPutAll: '.']! !

!TestAsserter methodsFor: 'factory' stamp: ''!
defaultTestFailure

	^ self classForTestResult failure! !

!TestAsserter methodsFor: 'logging' stamp: ''!
logFailure: aString
	self class logFailure: aString.! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
denyCollection: actualCollection includesAny: subcollection
	"Raises an AssertionFailure if actualCollection includes any of the elements of 
	 expectedCollection (by negating result of #includesAny: message).
    I also provide a specialized message for the AssertionFailure in case I fail.
 	"
	^ self
		assert: (actualCollection includesAny: subcollection) not
		description: [ actualCollection asString , ' includes one element of ' , subcollection asString ]! !

!TestAsserter methodsFor: 'extensions' stamp: ''!
skip: aComment
	"Don't run this test, and don't mark it as failure"
	TestSkipped signal: aComment! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
should: aBlock notTakeMoreThanMilliseconds: anInteger
    "For compatibility with other Smalltalks"

   self should: aBlock notTakeMoreThan: (Duration milliSeconds: anInteger).! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
fail

	^self assert: false! !

!TestAsserter methodsFor: 'factory' stamp: ''!
classForTestResult
	"Returns the class of the test result"
	
	"note that we did not name this method testResultClass because it is considered by tools as a test method."
	^ self class classForTestResult! !

!TestAsserter methodsFor: 'asserting' stamp: ''!
assertEmpty: aCollection
	^ self assert: aCollection isEmpty description: aCollection asString , ' should have been empty'! !

!TestAsserter class methodsFor: 'factory' stamp: ''!
methodPassed: aSelector

	^ false! !

!TestAsserter class methodsFor: 'asserting' stamp: ''!
assert: aBoolean description: aString
	"Minimal clone of the instance-side assert protocol so that class-side methods can use it."

	aBoolean ifFalse:
		[self logFailure: aString.
		self classForTestResult failure signal: aString].! !

!TestAsserter class methodsFor: 'factory' stamp: ''!
classForTestSuite
	^ TestSuite! !

!TestAsserter class methodsFor: 'logging' stamp: ''!
failureLog
	^Transcript! !

!TestAsserter class methodsFor: 'factory' stamp: ''!
suiteClass
	^TestSuite! !

!TestAsserter class methodsFor: 'accessing' stamp: ''!
defaultPrecisionsForCloseToComparison
	"This number comes from the one used in Float>>#closeTo: implementation."
	^ 0.0001! !

!TestAsserter class methodsFor: 'logging' stamp: ''!
logFailure: aString
	self isLogging ifTrue:
		[self failureLog cr; nextPutAll: aString; flush].! !

!TestAsserter class methodsFor: 'logging' stamp: ''!
isLogging
	"By default, we're not logging failures. Override in subclasses as desired."

	^false! !

!TestAsserter class methodsFor: 'asserting' stamp: ''!
classForTestResult
	"Returns the class of the test result"
	^ TestResult! !

!TestAsserterTest methodsFor: 'tests' stamp: ''!
testAssertCollectionHasSameElements
	| c1 c2 |
	c1 := { 1. 2. 3 }.
	c2 := Set with: 2 with: 3 with: 1.
	self shouldnt: [ self assertCollection: c1 hasSameElements: c2 ] raise: TestFailure.

	c2 := Set with: 2 with: 3 with: 1 with: 4.
	self should: [ self assertCollection: c1 hasSameElements: c2 ] raise: TestFailure.! !

!TestAsserterTest methodsFor: 'tests' stamp: ''!
testDenyCollectionHasSameElements
	| c1 c2 |
	c1 := { 1. 2. 3 }.
	c2 := Set with: 2 with: 3 with: 1.
	self should: [ self denyCollection: c1 hasSameElements: c2 ] raise: TestFailure.

	c2 := Set with: 2 with: 3 with: 1 with: 4.
	self shouldnt: [ self denyCollection: c1 hasSameElements: c2 ] raise: TestFailure.! !

!TestCase commentStamp: ''!
`TestCase` instances are created with the class method `TestCase class>>#selector:`, passing the symbol that names the method to be executed when the test case runs.  TestCase instances are then executed using the method `TestCase>>#run`. Now usually you do not execute your tests that primitive way
but tests are grouped in `TestSuite` (a.k.a. a composite of TestCase) and run using a test runner.
Various UIs exist to run these instances and they can also be created and run programmatically.

Each method of a `TestCase` subclass starting with 'test' acts an executable test. When you create a subclass of `TestCase`, the framework automatically builds a test suite from the test methods of such class. 
The methods `setUp` and `tearDown` are always executed before and after the execution of a test method. You use them to set a specific context in which your test methods are executed. 

### As you go...

When you discover a new fixture (context) for your test, encapsulates it in a specific TestCase subclass. 
You can create a #test... method for the first test.  As that method develops and more #test... methods are added, you will find yourself refactoring temps into instance variables for the objects in the fixture and overriding #setUp to initialize these variables.  
As required, override #tearDown to nil references, release objects and deallocate.

### Design Point

A TestCase is an implementation of the Command pattern to run a test. 

### Mini tutorial - step one

Create a specific subclass

```
TestCase << #MyExampleSetTest
	package: 'MySetTest'
```

### Mini tutorial - step two 

Define a test method

```
MyExampleSetTest >> testIncludes
	| full empty |
	full := Set with: 5 with: 6.
	empty := Set new.
	self assert: (full includes: 5).
	self assert: (full includes: 6).
	self assert: (empty includes: 5) not
```	

### Mini tutorial - step three

Execute your tests

```
MyExampleSetTest run: testIncludes 
```

See my superclass' comment for assertion and logging information.

### Mini tutorial - step four

Create a setUp method (add the empty and full instances to the class)

```
MyExampleSetTest >> setUp
	super setUp.
	empty := Set new.
	full := Set with: 5 with: 6
```

Redefine your method to avoid duplicating the setUp logic
```
MyExampleSetTest >> testIncludes

	self assert: (full includes: 5).
	self assert: (full includes: 6).
	self assert: (empty includes: 5) not
```	

Run your test!!

```
MyExampleSetTest run: testIncludes 
```

You are done. Remember tests are your best friends. 
And enjoy coding in the debugger.!
!TestCase methodsFor: '*SUnit-MockObjects' stamp: ''!
verify: aMockObject

	^ aMockObject verifyIn: self! !

!TestCase methodsFor: 'running' stamp: ''!
prepareToRunAgain 	

	"Used by the debugger when a test is restarted
	I'm not 'hidding'' possible exceptions because I think it is best to popup a new debugger
	if some one occurs and let the programmer decide what to do - Hernan"
	self 
		tearDown;
		setUp! !

!TestCase methodsFor: 'running' stamp: ''!
runCaseManaged
	CurrentExecutionEnvironment runTestCase: self! !

!TestCase methodsFor: 'accessing' stamp: ''!
nameForReport

	^ self selector! !

!TestCase methodsFor: 'private' stamp: ''!
performTest
	self perform: testSelector asSymbol! !

!TestCase methodsFor: 'events' stamp: ''!
announce: anAnnouncementClass
	^ self announce: anAnnouncementClass withResult: nil! !

!TestCase methodsFor: 'running' stamp: ''!
run
	"Execute the receiver and return a test result."
	| result |
	result := self classForTestResult new.
	[ result runCase: self]
		ensure: [ self classForTestResource resetResources: self resources ].
	^ result! !

!TestCase methodsFor: '*SUnit-Visitor' stamp: ''!
acceptSUnitVisitor: aTSUnitVisitor
	^ aTSUnitVisitor visitTestCase: self! !

!TestCase methodsFor: '*DrTests-TestsRunner' stamp: ''!
drTestsBuildContextMenu: aMenuModel 
	"Nothing to display yet."! !

!TestCase methodsFor: '*DrTests' stamp: ''!
drTestsSuite
	^ TestSuite new
		addTest: self;
		yourself! !

!TestCase methodsFor: 'dependencies' stamp: ''!
removeDependentFromHierachy: anObject 
	"an empty method. for Composite compatibility with TestSuite"! !

!TestCase methodsFor: 'running' stamp: ''!
openDebuggerOnFailingTestMethod
	<haltOrBreakpointForTesting>
	"SUnit has halted one step in front of the failing test method. Step over the 'self halt' and 
	 send into 'self perform: testSelector' to see the failure from the beginning"

	self
		halt;
		performTest! !

!TestCase methodsFor: 'accessing' stamp: ''!
defaultTimeLimit
	^self class defaultTimeLimit! !

!TestCase methodsFor: 'testing' stamp: ''!
expectedFailures
	| pragmas |
	^ expectedFails ifNil: [
		
		pragmas := Pragma allNamed: #expectedFailure from: self class to: TestCase.
		expectedFails := pragmas collect: [:each | each method selector  ].
	]	
! !

!TestCase methodsFor: 'events' stamp: ''!
shouldAnnounce
	^ self class shouldAnnounce! !

!TestCase methodsFor: 'running' stamp: ''!
tearDown
	"Hooks that subclasses may override to clean the fixture of test."! !

!TestCase methodsFor: 'accessing' stamp: ''!
selector
	^testSelector! !

!TestCase methodsFor: 'accessing' stamp: ''!
executionEnvironment
	^CurrentExecutionEnvironment value! !

!TestCase methodsFor: '*DrTests-TestsRunner' stamp: ''!
asResultForDrTest
	^ DTTestLeafNode content: self! !

!TestCase methodsFor: '*DrTests' stamp: ''!
drTestsIsAbstract
	^ false! !

!TestCase methodsFor: 'accessing' stamp: ''!
executionProcessMonitor
	^self executionEnvironment processMonitor! !

!TestCase methodsFor: 'running' stamp: ''!
runCaseAsFailure: aSemaphore
	[self resources do: [:each | each availableFor: self].
	[self setUp.
	self openDebuggerOnFailingTestMethod] ensure: [self tearDown]]
		ensure: [aSemaphore signal]! !

!TestCase methodsFor: 'running' stamp: ''!
debugAsFailure
	| semaphore |
	semaphore := Semaphore new.
	[ 
	semaphore wait.
	self classForTestResource resetResources: self resources ] fork.
	(self class selector: testSelector) runCaseAsFailure: semaphore! !

!TestCase methodsFor: 'running' stamp: ''!
debug
	| result |
	result := self classForTestResult new.
	[ result runCaseForDebug: self ]
		ensure: [ self classForTestResource resetResources: self resources.
			result updateResultsInHistory  ].
	^ result! !

!TestCase methodsFor: 'running' stamp: ''!
isLogging
	"By default, we're not logging failures. If you override this in 
	a subclass, make sure that you override #failureLog"
	^false
			! !

!TestCase methodsFor: 'accessing' stamp: ''!
timeLimit: aDuration
	^self executionEnvironment maxTimeForTest: aDuration! !

!TestCase methodsFor: 'private' stamp: ''!
cleanUpInstanceVariables
	self class allInstVarNames do: [ :name |
		(self instanceVariablesToKeep includes: name) ifFalse: [
			self instVarNamed: name put: nil ] ]! !

!TestCase methodsFor: 'printing' stamp: ''!
printTestSelectorOn: aStream
	testSelector
		ifNotNil: [ 
			| class |
			class := self class whichClassIncludesTestSelector: testSelector.
			class ~= self class
				ifTrue: [ self printTestSelectorDefiningClass: class on: aStream ].
			aStream
				nextPutAll: '>>#';
				nextPutAll: testSelector ]! !

!TestCase methodsFor: 'running' stamp: ''!
run: aResult
	aResult runCase: self! !

!TestCase methodsFor: 'testing' stamp: ''!
shouldPass
	^self isExpectedFailure not! !

!TestCase methodsFor: 'events' stamp: ''!
announce: anAnnouncementClass withResult: result
	| event |
	self shouldAnnounce ifFalse: [ ^ self ].
	
	event := anAnnouncementClass asAnnouncement.
	event testCase: self.
	event testSelector: testSelector.
	event testResult: result.
	self announcer announce: event.! !

!TestCase methodsFor: '*SUnit-Support-UITesting' stamp: ''!
simulateKeyStroke: aCharacterOrShortcut inWorld: aWorld

	aWorld activeHand simulateKeyStroke: aCharacterOrShortcut.! !

!TestCase methodsFor: 'printing' stamp: ''!
printTestSelectorDefiningClass: aClass on: aStream
	aStream << '('.
	aClass printOn: aStream.
	aStream << ')'! !

!TestCase methodsFor: 'running' stamp: ''!
failureLog	
	^Transcript

			! !

!TestCase methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: self class name asString.
	self printTestSelectorOn: aStream! !

!TestCase methodsFor: '*ThreadedFFI-Tests' stamp: ''!
skipOnAppleARM

	(self onPharoCITestingEnvironment and: [ 
		 OSPlatform current isMacOS and: [ 
			 Smalltalk vm architectureName = 'arm64' ] ]) ifTrue: [ 
		self skip ]! !

!TestCase methodsFor: 'CI support' stamp: ''!
onPharoCITestingEnvironment
	
	^ Smalltalk os environment at: 'PHARO_CI_TESTING_ENVIRONMENT' ifPresent: [ true ] ifAbsent: [ false ]! !

!TestCase methodsFor: 'accessing' stamp: ''!
resources
	"We give TestCase this instance-side method so that methods polymorphic with TestSuite can be code-identical.  Having this instance-side method also helps when writing tests of resource behaviour. Except for such tests, it is rare to override this method and should not be done without thought.  If there were a good reason why a single test case needed to share tests requiring different resources, it might be legitimate."

	^self class resources! !

!TestCase methodsFor: 'events' stamp: ''!
announcer
	^ self class announcer! !

!TestCase methodsFor: 'testing' stamp: ''!
isExpectedFailure
	^self expectedFailures includes: testSelector! !

!TestCase methodsFor: 'dependencies' stamp: ''!
addDependentToHierachy: anObject 
	"an empty method. for Composite compatibility with TestSuite"! !

!TestCase methodsFor: 'running' stamp: ''!
setUp
	"Hooks that subclasses may override to define the fixture of test."
! !

!TestCase methodsFor: '*DrTests-TestsRunner' stamp: ''!
drTestsBrowse
	Smalltalk tools browser openOnClass: self class selector: self selector! !

!TestCase methodsFor: 'CI support' stamp: ''!
skipOnPharoCITestingEnvironment
	
	self onPharoCITestingEnvironment 
		ifTrue: [ self skip ].! !

!TestCase methodsFor: 'private' stamp: ''!
setTestSelector: aSymbol
	testSelector := aSymbol! !

!TestCase methodsFor: '*SUnit-Support-UITesting' stamp: ''!
simulateKeyStrokes: aString inWorld: aWorld

	aWorld activeHand simulateKeyStrokes: aString.! !

!TestCase methodsFor: 'running' stamp: ''!
logFailure: aString
	self isLogging ifTrue: [
		self failureLog 
			cr; 
			nextPutAll: aString; 
			flush]
			! !

!TestCase methodsFor: 'private' stamp: ''!
instanceVariablesToKeep
	^ #('testSelector')! !

!TestCase methodsFor: '*DrTests-TestsRunner' stamp: ''!
drTestsName
	^ self asString! !

!TestCase methodsFor: 'running' stamp: ''!
runCase
	self resources do: [:each | each availableFor: self].
	[self setUp.
	self performTest] ensure: [
		self tearDown.
		self cleanUpInstanceVariables]! !

!TestCase methodsFor: 'private' stamp: ''!
executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: (ex description includesSubstring: aString) ]
			! !

!TestCase class methodsFor: 'testing' stamp: ''!
methodProgressed: aSelector
	^ ((self storedMethodRaisedError: aSelector) or: [self storedMethodFailed: aSelector])
		and: [self methodPassed: aSelector]
		! !

!TestCase class methodsFor: 'history' stamp: ''!
resetHistory
	history := nil! !

!TestCase class methodsFor: 'coverage' stamp: ''!
localCoverageAsString
	| cov className |
	cov := self localCoverage first asInteger. 
	"coverage already checks that the name is ends with 'Test' and if the class tested exists"
	
	className := self name copyFrom: 1 to: (self name size - 'Test' size).
	^ self name asString, ' covers ', cov asString, '% of ', className.! !

!TestCase class methodsFor: 'coverage' stamp: ''!
localCoverageForClass: cls
	
	| definedMethods testedMethods untestedMethods |
	definedMethods := cls selectors.
	"It happens for IdentityBag / IdentityBagTest"
	definedMethods size = 0
		ifTrue: [^ {0. Set new}].

	testedMethods := 
		self methods inject: Set new into: 
							[:sums :cm | sums union: cm messages].
					
	"testedMethods contains all the methods send in test methods, which probably contains methods that have nothing to do with collection"
	testedMethods := testedMethods reject: [:sel | (definedMethods includes: sel) not].

	untestedMethods := definedMethods select: [:selector | (testedMethods includes: selector) not].

	^ { (testedMethods size * 100 / definedMethods size) asFloat . untestedMethods}
! !

!TestCase class methodsFor: 'settings' stamp: ''!
defaultTimeLimitSecs: aNumber
	self defaultTimeLimit: aNumber seconds! !

!TestCase class methodsFor: 'coverage' stamp: ''!
coveragePercentage
	^ self coverage first! !

!TestCase class methodsFor: 'accessing - comment' stamp: ''!
hasComment
	^true! !

!TestCase class methodsFor: 'accessing' stamp: ''!
lookupHierarchyRoot
	^TestCase! !

!TestCase class methodsFor: 'accessing - comment' stamp: ''!
classCommentBlank
	^'This class contains tests'! !

!TestCase class methodsFor: 'testing' stamp: ''!
isUnitTest
	^true! !

!TestCase class methodsFor: 'instance creation' stamp: ''!
debug: aSymbol

	^(self selector: aSymbol) debug! !

!TestCase class methodsFor: 'testing' stamp: ''!
whichClassIncludesTestSelector: aSymbol
	^self whichClassIncludesSelector: aSymbol! !

!TestCase class methodsFor: 'history' stamp: ''!
generateLastStoredRunMethod

	self shouldGenerateLastStoredRunMethod ifTrue: [
		self class
			compile: (self lastRunMethodNamed: #lastStoredRun)
			classified: 'history' ]! !

!TestCase class methodsFor: 'accessing' stamp: ''!
sunitVersion
	^'4.0'! !

!TestCase class methodsFor: 'building suites' stamp: ''!
buildSuiteFromAllSelectors

	^self buildSuiteFromMethods: self allTestSelectors
			! !

!TestCase class methodsFor: 'history' stamp: ''!
history
	^ history ifNil: [ history := self newTestDictionary ]! !

!TestCase class methodsFor: 'history' stamp: ''!
lastStoredRun
	^ ((Dictionary new) add: (#failures->#()); add: (#passed->#()); add: (#errors->#()); yourself)! !

!TestCase class methodsFor: 'testing' stamp: ''!
methodRegressed: aSelector
	^ (self storedMethodPassed: aSelector) and: [(self methodFailed: aSelector) or: [self methodRaisedError: aSelector]]! !

!TestCase class methodsFor: 'coverage' stamp: ''!
localCoveragePercentage
	^ self localCoverage first! !

!TestCase class methodsFor: '*SUnit-Visitor' stamp: ''!
acceptSUnitVisitor: aTSUnitVisitor
	^ aTSUnitVisitor visitTestCaseClass: self! !

!TestCase class methodsFor: 'testing' stamp: ''!
hasTestSelectors

	^(self selectors anySatisfy: [ :each | 
		(each beginsWith: 'test') and: [
				each numArgs isZero 
			]
		]) or: [ 
			self superclass isTestCase and: [ 
				self shouldInheritSelectors and: [ 
						self superclass hasTestSelectors	
				]
			]
		]
	! !

!TestCase class methodsFor: '*DrTests-TestsRunner' stamp: ''!
drTestsSuite
	^ self suite! !

!TestCase class methodsFor: 'testing' stamp: ''!
storedMethodFailed: aSelector
	^ (self lastStoredRun at: #failures) includes: aSelector! !

!TestCase class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit
	^DefaultTimeLimit ifNil: [DefaultTimeLimit := 10 seconds]
! !

!TestCase class methodsFor: 'events' stamp: ''!
shouldAnnounce
	^ self announcers includesKey: self! !

!TestCase class methodsFor: 'class initialization' stamp: ''!
initialize
	SystemAnnouncer uniqueInstance unsubscribe: self.
	SystemAnnouncer uniqueInstance weak
		when: MethodAdded, MethodModified, MethodRemoved 
		send: #methodChanged: 
		to: self! !

!TestCase class methodsFor: 'testing' stamp: ''!
methodPassed: aSelector
	^ (self lastRun at: #passed) includes: aSelector! !

!TestCase class methodsFor: '*DrTests' stamp: ''!
drTestsIsAbstract
	^ self isAbstract! !

!TestCase class methodsFor: 'history' stamp: ''!
newTestDictionary

	^ Dictionary new at: #timeStamp put: DateAndTime now;
		at: #passed put: Set new;
		at: #failures put: Set new;
		at: #errors put: Set new;
		yourself
		! !

!TestCase class methodsFor: 'history' stamp: ''!
lastRun
	^ self classForTestResult historyFor: self! !

!TestCase class methodsFor: 'testing' stamp: ''!
hasFailedTest

	^ (self history at: #failures) isEmpty not ! !

!TestCase class methodsFor: 'testing' stamp: ''!
storedMethodRaisedError: aSelector
	^ (self lastStoredRun at: #errors) includes: aSelector! !

!TestCase class methodsFor: 'testing' stamp: ''!
isAbstract
	"Override to true if a TestCase subclass is Abstract and should not have
	TestCase instances built from it"

	^self name = #TestCase
			! !

!TestCase class methodsFor: 'building suites' stamp: ''!
buildSuiteFromMethods: testMethods

	^testMethods
		inject: (self suiteClass named: self name asString)
		into: [:suite :selector |
			suite
				addTest: (self selector: selector);
				yourself]! !

!TestCase class methodsFor: 'settings' stamp: ''!
defaultTimeLimitSettingOn: aBuilder
	<systemsettings>
	
	(aBuilder group: #sunit)
		label: 'SUnit';
		parent: #pharoSystem;
		description: 'SUnit';
		with: [  
			(aBuilder setting: #defaultTimeLimitSecs)
				target: self;
				default: 10.0;
				label: 'Default time limit for tests (secs)' ;
				description: 'Detault time limit in seconds for test execution']! !

!TestCase class methodsFor: 'instance creation' stamp: ''!
run: aSymbol
	"Execute a testcase name, aSymbol, and return a test result."
	
	^(self selector: aSymbol) run! !

!TestCase class methodsFor: 'events' stamp: ''!
announcers
	^ Announcers ifNil: [ Announcers := Dictionary new ] ! !

!TestCase class methodsFor: 'history' stamp: ''!
shouldGenerateLastStoredRunMethod
	| sameRun |
	
	(self class includesSelector: #lastStoredRun)
		ifFalse: [^ true].
	sameRun := #(#passed #failures #errors) inject: true into: 
		[ :ok :set | ok and: [(self lastRun at: set) = (self lastStoredRun at: set) ]].
	^ sameRun not
! !

!TestCase class methodsFor: 'building suites' stamp: ''!
addToSuite: suite fromMethods: testMethods 
	testMethods do:  [ :selector | 
			suite addTest: (self selector: selector) ].
	^suite! !

!TestCase class methodsFor: 'testing' stamp: ''!
hasErrorTest

	^ (self history at: #errors) isEmpty not ! !

!TestCase class methodsFor: 'building suites' stamp: ''!
addToSuiteFromSelectors: suite
	^self addToSuite: suite fromMethods: (self shouldInheritSelectors
		ifTrue: [ self allTestSelectors ]
		ifFalse: [self testSelectors ])! !

!TestCase class methodsFor: 'coverage' stamp: ''!
coverageAsString
	| cov className |
	cov := self coverage first asInteger. 
	"coverage already checks that the name is ends with 'Test' and if the class tested exists"
	
	className := self name copyFrom: 1 to: (self name size - 'Test' size).
	^ self name asString, ' covers ', cov asString, '% of ', className.! !

!TestCase class methodsFor: 'testing' stamp: ''!
isUsed
	"all my subclasses are used by me"
	^self name = 'TestCase'
		ifTrue: [ super isUsed ]
		ifFalse: [ true ]! !

!TestCase class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	"I should inherit from an Abstract superclass but not from a concrete one by default, unless I have no testSelectors in which case I must be expecting to inherit them from my superclass.  If a test case with selectors wants to inherit selectors from a concrete superclass, override this to true in that subclass."
	
	^self ~~ self lookupHierarchyRoot
		and: [self superclass isAbstract or: [self testSelectors isEmpty]]! !

!TestCase class methodsFor: 'history' stamp: ''!
lastRunMethodNamed: aSelector
	
	^ String streamContents: [:str |
		str nextPutAll: aSelector asString ;cr.
		str tab; nextPutAll: '^ ', (self lastRun) storeString]
! !

!TestCase class methodsFor: 'testing' stamp: ''!
storedMethodPassed: aSelector
	^ (self lastStoredRun at: #passed) includes: aSelector! !

!TestCase class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit: aDuration
	DefaultTimeLimit := aDuration! !

!TestCase class methodsFor: 'testing' stamp: ''!
isTestCase
	^ true! !

!TestCase class methodsFor: 'building suites' stamp: ''!
buildSuiteFromSelectors
	^self buildSuiteFromMethods: self allTestSelectors! !

!TestCase class methodsFor: 'accessing' stamp: ''!
resources

	^#()! !

!TestCase class methodsFor: 'events' stamp: ''!
resetAnnouncer
	self announcers removeKey: self ifAbsent: []! !

!TestCase class methodsFor: 'events' stamp: ''!
announcer 
	^ self announcers at: self ifAbsentPut: [ Announcer new ]! !

!TestCase class methodsFor: 'building suites' stamp: ''!
buildSuite
	"Returns a suite of test case. This suite can be composed of local and inherited methods if the superclass is declared as abstract."
	| suite |
	^self isAbstract
		ifTrue: 
			[suite := self suiteClass named: self name asString.
			self allSubclasses 
				do: [:each | each isAbstract ifFalse: [suite addTest: each buildSuiteFromSelectors]].
			suite]
		ifFalse: [self buildSuiteFromSelectors]! !

!TestCase class methodsFor: 'coverage' stamp: ''!
coverageForClass: cls until: aRootClass
	"returns the test coverage of all the methods included inherited ones but stopping at aRootClass included"
	
	| definedMethods testedMethods untestedMethods |
	definedMethods := cls allSelectorsAboveUntil: aRootClass.
	definedMethods size = 0
		ifTrue: [^ {0. Set new}].
	testedMethods := 
		self methods inject: Set new into: 
							[:sums :cm | sums union: cm messages].
	testedMethods := testedMethods reject: [:sel | (definedMethods includes: sel) not].
	untestedMethods := definedMethods select: [:selector | (testedMethods includes: selector) not].
	^ { (testedMethods size * 100 / definedMethods size) asFloat . untestedMethods}
! !

!TestCase class methodsFor: 'accessing' stamp: ''!
historyAnnouncer
	^ HistoryAnnouncer ifNil: [  HistoryAnnouncer := Announcer new ]! !

!TestCase class methodsFor: 'building suites' stamp: ''!
buildSuiteFromLocalSelectors

	^self buildSuiteFromMethods: self testSelectors
			! !

!TestCase class methodsFor: 'testing' stamp: ''!
hasMethodBeenRun: aSelector
	^ ((self lastRun at: #errors),
		(self lastRun at: #failures),
		(self lastRun at: #passed))
			includes: aSelector! !

!TestCase class methodsFor: 'history' stamp: ''!
history: aDictionary

	history := aDictionary.
	self historyAnnouncer announce: (TestSuiteEnded result: self)! !

!TestCase class methodsFor: '*Microdown' stamp: ''!
buildMicroDownUsing: aBuilder withComment: aString
	
	| number |
	number := self allTestSelectors size.
	aBuilder
		header: [ aBuilder text: self name ] withLevel: 1;
		horizontalLine;
		header: [ aBuilder text: 'Description' ] withLevel: 3;
		text: aString;
		newLine;
		header: [ aBuilder text: 'Tests' ] withLevel: 3;
		text: 'This test suite '.
	number isZero
		ifTrue: [ ^ aBuilder text: 'has no test methods.'].
	
	aBuilder 
		text: 'defines ', number asString, ' test method'.
	number = 1
		ifFalse: [ aBuilder text: 's'  ]. 
	aBuilder text: ':'.

	aBuilder 	
		newLine;
		unorderedListDuring: [ self testSelectors
				do: [ :each | aBuilder item: [ aBuilder monospace: (self class instanceSide name , '>>#' , each) asString ] ]]! !

!TestCase class methodsFor: 'building suites' stamp: ''!
addTestsFor: classNameString toSuite: suite
	| cls |
	cls := self environment at: classNameString ifAbsent: [ ^ suite ].
	^ cls isAbstract
		ifTrue: [ 
			cls allSubclasses
				do: [ :each | 
					each isAbstract
						ifFalse: [ each addToSuiteFromSelectors: suite ] ].
			suite ]
		ifFalse: [ cls addToSuiteFromSelectors: suite ]! !

!TestCase class methodsFor: 'coverage' stamp: ''!
localCoverage
	"returns the coverage determined by a simple static analysis of test coverage 
	made by the receiver on a class that is identified by the name of the receiver.
	We assume that SetTest test Set. The computation of the coverage takes only into
	account the methods defined locally in the tested class. See coverage for a more global 
	coverage"

	| cls className |
	(self name endsWith: 'Test')
		ifFalse: [ self error: 'Please, use #localCoverageForClass: instead' ].
	className := self name copyFrom: 1 to: self name size - 'Test' size.
	cls := self environment at: className asSymbol ifAbsent: [ self error: 'Please, use #localCoverageForClass: instead' ].
	cls isBehavior
		ifFalse: [ cls := cls class ].
	^ self localCoverageForClass: cls! !

!TestCase class methodsFor: 'accessing' stamp: ''!
allTestSelectors
	| answer pivotClass lookupRoot |
	answer := Set withAll: self testSelectors.
	self shouldInheritSelectors
		ifTrue:
			[pivotClass := self.
			lookupRoot := self lookupHierarchyRoot.
			[pivotClass == lookupRoot]
				whileFalse:
					[pivotClass := pivotClass superclass.
					answer addAll: pivotClass testSelectors]].
	^answer asSortedCollection asOrderedCollection! !

!TestCase class methodsFor: 'coverage' stamp: ''!
coverageForClass: cls
	"returns the test coverage of all the methods included inherited ones"
	^ self coverageForClass: cls until: ProtoObject! !

!TestCase class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol
	"Return a test case with aSymbol as selector but does not execute it."
	^self new setTestSelector: aSymbol! !

!TestCase class methodsFor: 'testing' stamp: ''!
hasPassedTest

	^ (self history at: #passed) isEmpty not ! !

!TestCase class methodsFor: 'testing' stamp: ''!
methodFailed: aSelector
	^ (self lastRun at: #failures) includes: aSelector! !

!TestCase class methodsFor: 'testing' stamp: ''!
methodRaisedError: aSelector
	^ (self lastRun at: #errors) includes: aSelector! !

!TestCase class methodsFor: 'updating' stamp: ''!
methodChanged: anEvent
	"Remove the changed method from the known test results."
	
	anEvent method isTestMethod ifFalse: [ ^ self ].
	self classForTestResult removeFromTestHistory: anEvent selector in: anEvent methodClass! !

!TestCase class methodsFor: 'accessing' stamp: ''!
testSelectors
	^(self selectors select: [ :each | (each beginsWith: 'test') and: [each numArgs isZero]])! !

!TestCase class methodsFor: 'utilities' stamp: ''!
runAllAndLogResult

	"runs all tests in the image"

	TestCase suite run traceCr! !

!TestCase class methodsFor: 'coverage' stamp: ''!
coverage
	"returns the coverage determined by a simple static analysis of test coverage 
	made by the receiver on a class that is identified by the name of the receiver.
	We assume that SetTest test Set."

	| cls className |
	(self name endsWith: 'Test')
		ifFalse: [ self error: 'Please, use #coverageForClass: instead' ].
	className := self name copyFrom: 1 to: self name size - 'Test' size.
	cls := self environment at: className asSymbol ifAbsent: [ self error: 'Please, use #coverageForClass: instead' ].	"May happen with Transcript"
	cls isBehavior
		ifFalse: [ cls := cls class ].
	^ self coverageForClass: cls! !

!TestCase class methodsFor: 'instance creation' stamp: ''!
suite
	"Return a test suite"
	^self buildSuite! !

!TestCase class methodsFor: 'settings' stamp: ''!
defaultTimeLimitSecs
	^self defaultTimeLimit asMilliSeconds / 1000.0! !

!TestCaseAnnouncement commentStamp: ''!
This is a common superclass for announcements related to SUnit test cases.

Instance Variables
        testCase:                       <TestCase>
        testResult:                     <TestResult>
        testSelector:           	   <Symbol>

testCase
        - The test case

testResult
        - The result of the test case

testSelector
        - The selector of the test method!
!TestCaseAnnouncement methodsFor: 'accessing' stamp: ''!
testCase: aTestCase
	"Sets the test case to the given test case."

	testCase := aTestCase! !

!TestCaseAnnouncement methodsFor: 'accessing' stamp: ''!
testSelector: aSymbol
	"Sets the test selector to the given symbol."

	testSelector := aSymbol! !

!TestCaseAnnouncement methodsFor: 'testing' stamp: ''!
hasErrors
	"Return true if the test result has errors."

	^ testResult hasErrors! !

!TestCaseAnnouncement methodsFor: 'testing' stamp: ''!
hasPassed
	"Return true if the test has passed."

	^ testResult hasPassed! !

!TestCaseAnnouncement methodsFor: 'accessing' stamp: ''!
testResult: aTestResult
	"Sets the test result to the given test result."

	testResult := aTestResult! !

!TestCaseAnnouncement methodsFor: 'testing' stamp: ''!
hasFailures
	"Return true if the test result has failures."

	^ testResult hasFailures! !

!TestCaseAnnouncement methodsFor: 'accessing' stamp: ''!
testSelector
	"Returns the test selector."

	^ testSelector! !

!TestCaseAnnouncement methodsFor: 'accessing' stamp: ''!
testResult
	"Returns the test result."

	^ testResult! !

!TestCaseAnnouncement methodsFor: 'accessing' stamp: ''!
testCase
	"Returns the test case."

	^ testCase! !

!TestCaseEnded commentStamp: ''!
This event is announced when testing a test case ends.!
!TestCaseStarted commentStamp: ''!
This event is announced when testing a test case starts.!
!TestCaseTest commentStamp: ''!
SUnit test for TestCase class!
!TestCaseTest methodsFor: 'events' stamp: ''!
testAnnouncement
	| collection oldCollection suite unitTest |
	unitTest := ClassFactoryForTestCaseTest.
	collection := OrderedCollection new.
	unitTest resetAnnouncer.

	self deny: unitTest shouldAnnounce.
	self deny: unitTest new shouldAnnounce.

	unitTest announcer when: TestCaseAnnouncement do: [ :ann | collection add: ann ].

	self assert: unitTest shouldAnnounce.
	self assert: unitTest new shouldAnnounce.

	"We run SUnitTest"
	suite := unitTest buildSuite.
	suite run.

	self assert: collection size equals: suite tests size * 2.
	self assert: (collection select: [ :c | c isKindOf: TestCaseStarted ]) size equals: collection size / 2.
	self assert: (collection select: [ :c | c isKindOf: TestCaseEnded ]) size equals: collection size / 2.
	self assert: (collection allSatisfy: #hasPassed).
	self deny: (collection anySatisfy: #hasFailures).

	oldCollection := collection copy.
	unitTest resetAnnouncer.
	unitTest debug: #testClassCreationInDifferentCategories.
	self assert: collection equals: oldCollection! !

!TestCaseTest methodsFor: 'testing' stamp: ''!
testAssertEqualsActualAndExpectedOrder
	self 
		should: [
			self assert: 'actual' equals: 'expected with fairly long print string'
		]
		raise: TestFailure 
		whoseDescriptionIncludes: 'Got ''actual'' instead of ''expected with fairly long print string''.' 
		description: 'In #assert:equals: the first argument is the actual value and the second one is the expected.'.! !

!TestCaseTest methodsFor: 'testing' stamp: ''!
testIsUnitTest

	self assert: TestCase isUnitTest! !

!TestCommandLineHandler commentStamp: ''!
Usage: test [--junit-xml-output] [--fail-on-failure] [<package> ...]
	--junit-xml-output    output the test results in a junit compatible format
	--fail-on-failure     if there is a test error or failure, it will exit with error code 1
	--fail-on-error       if there is a test error it will exit with error code 1
	--save                save after executing tests
	--stage-name=aName	
					it adds a prefix to the xml generated, this is useful 
					when running in the CI infrastructure
	 <package>            a String matching a package name
	
Examples:
	#Run all the tests in the Tests-Exceptions package
	pharo Pharo.image test Tests-Exceptions
	
	#Run all the tests in packages matching Test-.* and KernelTests
	pharo Pharo.image test "Tests-.*" "KernelTests-.*"
	
	# Run test on a Hudson/Jenkins server
	pharo Pharo.image test --junit-xml-output "Tests-.*" "KernelTests-.*"
	!
!TestCommandLineHandler methodsFor: 'accessing' stamp: ''!
addPackagesMatchingRegex: aRegex to: aSet
	RPackage organizer packageNames do: [ :packageName|
		(aRegex matches: packageName)
			ifTrue: [ aSet add: packageName ]]! !

!TestCommandLineHandler methodsFor: 'private' stamp: ''!
inform: aString
	self stdout 
		<< aString
		<< OSPlatform current lineEnding! !

!TestCommandLineHandler methodsFor: 'private' stamp: ''!
informResults: results
	self stdout 
		<< ('{1} run, {2} passes, {3} failures, {4} errors.'
			format: {
				results sum: #suiteTotal.
				results sum: #suitePassing.
				results sum: #suiteFailures.
				results sum: #suiteErrors })
		<< OSPlatform current lineEnding;
		flush! !

!TestCommandLineHandler methodsFor: 'accessing' stamp: ''!
addPackagesMatching: aString to: aSet
	| regex |
	
	[ regex := aString asRegex ] 
		on: Error do: [ ].
	regex ifNotNil: [ ^ self addPackagesMatchingRegex: regex to: aSet ].
	
	(aString includes: $*)
		ifTrue: [ ^ self addPackagesMatchingGlob: aString to: aSet ].
	
	"exact match, and just those who actually have classes inside (to avoid 
	 super-package duplications)"
	((RPackage organizer includesPackageNamed: aString) 
		and: [ (RPackage organizer packageNamed: aString) definedClasses notEmpty ])
		ifTrue: [ aSet add: aString ]! !

!TestCommandLineHandler methodsFor: 'accessing' stamp: ''!
packages
	| packages |
	packages := Set new.
	self arguments 
		reject: [ :arg| arg beginsWith: '-']
		thenDo: [ :arg| self addPackagesMatching: arg to: packages ].
	^ packages! !

!TestCommandLineHandler methodsFor: 'accessing' stamp: ''!
addPackagesMatchingGlob: aGlobString to: aSet
	RPackage organizer packageNames do: [ :packageName|
		(aGlobString match: packageName)
			ifTrue: [ aSet add: packageName ]]! !

!TestCommandLineHandler methodsFor: 'private' stamp: ''!
testRunner
	
	(self hasOption: 'junit-xml-output') ifTrue: [ 
		HDTestReport currentStageName: ((self hasOption: 'stage-name') ifTrue: [ self optionAt: 'stage-name' ] ifFalse: [ '' ]). 	
		^ HDTestReport ].
	
	self class environment at: #CommandLineTestRunner ifPresent: [ :commandLineTestRunner |
		(self hasOption: 'no-xterm') ifTrue: [ ^ commandLineTestRunner ].
		^ self class environment at: #VTermTestRunner
	] ifAbsent: [ self error: 'no tests output available, try to use the option --junit-xml-output' ]! !

!TestCommandLineHandler methodsFor: 'private' stamp: ''!
runPackages
	| packages results |
	
	packages := self packages.
	self inform: 'Running tests in ', packages size asString, ' Packages'.
	results := (self testRunner runPackages: self packages) select: #notNil.
				
	self informResults: results.
	(self hasOption: 'save') ifTrue: [ Smalltalk saveSession ].
	((self hasOption: 'fail-on-failure') 
		and: [ results anySatisfy: #hasFailuresOrErrors ])
		ifTrue: [^ self exitFailure: 'Tests do not pass!!' ].
	((self hasOption: 'fail-on-error') 
		and: [ results anySatisfy: #hasErrors ])
		ifTrue: [^ self exitFailure: 'Tests do not pass!!' ].
	
	Smalltalk snapshot: false andQuit: true.! !

!TestCommandLineHandler methodsFor: 'activation' stamp: ''!
activate
	self activateHelp
		ifTrue: [  ^ self ].
	self runPackages.! !

!TestCommandLineHandler class methodsFor: 'accessing' stamp: ''!
commandName
	^ 'test'! !

!TestCommandLineHandler class methodsFor: 'accessing' stamp: ''!
description
	^ 'A command line test runner'! !

!TestDynamicVariable commentStamp: ''!
TestDynamicVariable is a test class using in ProcessSpecificTest.

!
!TestExecutionEnvironment commentStamp: ''!
I am a special execution environment to manage the execution of tests.	
I am installed when test is running (or test suite) by

	CurrentExecutionEnvironment runTestCase: aTestCase
		
My current instance for tests can be accessed with handy method directly from the test case: 

	self executionEnvironment 
	
It simply returns the value of CurrentExecutionEnvironment.
	
Some tests requires completely clean and simplest environment. To disable me override #runCaseManaged on your test class: 

	runCaseManaged 
		^DefaultExecutionEnvironment beActiveDuring: [ self runCase]

1) Test watchdog

I implement a watchdog to ensure that tests complete in finite time and never hanged.
I give them 10 seconds by default which can be overriden by test class using method #defaultTimeLimit.
Or it can be specified directly in the test method:
	self timeLimit: 10 seconds
It can be changed at any time during the test.

To implement this logic I maintain special watchdog process which controls the execution time of tests. It is a single process for overall test suite.

2) Test services 

In addition I provide an extandable service infrastructure to monitor the test execution.
During the test I track all signaled exceptions from the test process and all forked processes.
I notify registered services about these events:

- #handleException:, it is executed for every exception signaled from the test 
- #handleCompletedTest, it is executed when test is completes (successfully or due to the error)
- #handleNewProcess:, it is executed for every process created during the test
- #cleanUpAfterTest:, it is executed as final action when test is done and the environment needs to be prepared for the next test run.

My #services are subclasses of TestExecutionService (see its comment for details).
	
I automatically register all service classes enabled by default (#registerDefaultServices). But users can enable required services manually for given tests:

	self executionEnvironment enableService: TestServiceExample

Or with configuration block: 

	self executionEnvironment enableService: TestServiceExample using: [:service | ]
	
I lookup given service class in my registered services and use the found one if it exists. Otherwise I create and register new service instance with enabled state. 	
At the end of test I disable services which were registered manually registered and which are disabled by default. So no other tests are affected by them.
	
I provide handy method to access well known service ProcessMonitorTestService:

	self executionEnvironment processMonitor 
	
Or simply:

	self executionProcessMonitor
		 
Internal Representation and Key Implementation Points.

    Instance Variables
	services:		<OrderedCollection<TestExecutionService>>
	mainTestProcess:		<Process>
	maxTimeForTest:		<Duration>
	testCase:		<TestCase>
	watchDogProcess:		<Process>
	watchDogSemaphore:		<Semaphore>
	testCompleted:		<Boolean>!
!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
forkedProcesses
	^ self processMonitor forkedProcesses! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
processMonitor
	^self findService: ProcessMonitorTestService! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
startWatchDog
	
	watchDogSemaphore := Semaphore new.
	watchDogProcess := [self watchDogLoop] newProcess.
	"Watchdog needs to run at high priority to do its job (but not at timing priority)"
	watchDogProcess 
		name: 'Tests execution watch dog';
		priority: Processor timingPriority-1;
		resume! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
prepareForNewProcess: aProcess
	| processBlock |
	watchDogProcess ifNil: [ ^self ]. "we should not catch watchDogProcess which is always the first one"
	aProcess suspendedContext sender ifNotNil: [ ^self ]. "Some existing tests in system create processes on arbitrary block and then check suspendedContext state. Without this 'if' all these tests will fail"
	processBlock := aProcess suspendedContext receiver.
	processBlock isClosure ifFalse: [ ^self ]. "same case as in previous comment"
	
	self handleNewProcess: aProcess! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
findService: aTestExecutionServiceClass ifAbsent: absentBlock
	^services detect: [:each | each isKindOf: aTestExecutionServiceClass] ifNone: absentBlock! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
maxTimeForTest: aDuration
	maxTimeForTest := aDuration.
	watchDogSemaphore ifNotNil: [ 
		"we need restart watch dog timer for new timeout"
		watchDogSemaphore signal ]. ! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
failures
	^self processMonitor testFailures! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
mainTestProcess
	^ mainTestProcess! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
services
	^ services! !

!TestExecutionEnvironment methodsFor: 'private' stamp: ''!
disableService: aTestExecutionServiceClass

	| service |
	service := self findService: aTestExecutionServiceClass ifAbsent: [^self].
	service disable ! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
handleNewProcess: aProcess

	self enabledServicesDo: [ :each | each handleNewProcess: aProcess ].! !

!TestExecutionEnvironment methodsFor: 'private' stamp: ''!
enableService: aTestExecutionServiceClass using: aBlock

	| service |
	service := self enableService: aTestExecutionServiceClass.
	aBlock value: service.
	^service! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
runTestCaseUnderWatchdog: aTestCase
	
	[
		[aTestCase runCase] ensure: [
			"Terminated test is not considered as completed (user just closed a debugger for example)"
			mainTestProcess isTerminating ifFalse: [ 
				self handleCompletedTest ]]
	] on: Exception do: [ :err | 
			self handleException: err 
	]
	! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
backgroundFailures
	^self processMonitor testBackgroundFailures! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
enabledServicesDo: aBlock
	
	services select: [ :each | each isEnabled ] thenDo: aBlock! !

!TestExecutionEnvironment methodsFor: 'testing' stamp: ''!
isTest
	^true! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
runTestsBy: aBlock

	aBlock value! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
deactivated

	watchDogProcess ifNotNil: [watchDogProcess terminate]! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
handleException: anException

	self enabledServicesDo: [ :each | each handleException: anException].
	
	anException pass! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
findService: aTestExecutionServiceClass
	^services detect: [:each | each isKindOf: aTestExecutionServiceClass]! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
handleCompletedTest
	
	self enabledServicesDo: [ :each | each handleCompletedTest].! !

!TestExecutionEnvironment methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	services := OrderedCollection new.
	testCompleted := false! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
services: anObject
	services := anObject! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
registerDefaultServices

	TestExecutionService enabledServiceClasses do: [ :each |
		self registerService: each new	
	 ]! !

!TestExecutionEnvironment methodsFor: 'testing' stamp: ''!
isMainTestProcess: aProcess
	^mainTestProcess = aProcess! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
activated

	mainTestProcess := Processor activeProcess.
	self registerDefaultServices.
	self startWatchDog! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
testCase
	^ testCase! !

!TestExecutionEnvironment methodsFor: 'private' stamp: ''!
enableService: aTestExecutionServiceClass

	| service |
	service := self findService: aTestExecutionServiceClass ifAbsent: [
		self registerService: aTestExecutionServiceClass new].
	service enable.
	^service! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
testCase: anObject
	testCase := anObject! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
runTestCase: aTestCase
	testCase := aTestCase.
	maxTimeForTest := testCase defaultTimeLimit.
	testCompleted := false.
	watchDogSemaphore signal. "signal about new test case"	
	[self runTestCaseUnderWatchdog: aTestCase] ensure: [
		testCompleted := true.
		watchDogSemaphore signal.  "signal that test case is completed"	
		self cleanUpAfterTest	].! !

!TestExecutionEnvironment methodsFor: 'testing' stamp: ''!
isMainTestProcessFailed
	^self processMonitor isMainTestProcessFailed! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
watchDogLoop

	| timeIsGone |
	[	"waiting new test case" 
		watchDogSemaphore wait. 
		"waiting while test completes"
		[timeIsGone := watchDogSemaphore wait: maxTimeForTest.
		testCompleted] whileFalse: [ 
			"this subloop allows to dynamically change time limit and restart watch dog"
			timeIsGone ifTrue: [
				"The main purpose of following condition is to ignore timeout when test is under debug.
				Test process is suspended only when it is debugged"
				mainTestProcess isSuspended ifFalse: [
					mainTestProcess signalException: TestTookTooMuchTime new]]	].
	] repeat

! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
watchDogProcess
	^ watchDogProcess! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
removeAllServices

	services removeAll! !

!TestExecutionEnvironment methodsFor: 'testing' stamp: ''!
isMainTestProcessActive
	^self isMainTestProcess: Processor activeProcess! !

!TestExecutionEnvironment methodsFor: 'controlling' stamp: ''!
cleanUpAfterTest
	"Cleanup is performed over all services (enabled and disabled) 
	because service can change its state during test execution
	(user can disable it in the middle of test)"
	
	services do: [ :each | each cleanUpAfterTest]! !

!TestExecutionEnvironment methodsFor: 'private' stamp: ''!
registerService: aTestExecutionService

	aTestExecutionService executionEnvironment: self.
	services add: aTestExecutionService.
	^aTestExecutionService ! !

!TestExecutionEnvironment methodsFor: 'accessing' stamp: ''!
maxTimeForTest
	^ maxTimeForTest! !

!TestExecutionEnvironment class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	<systemsettings>	

	TestExecutionService defaultServiceClasses do: [ :each | 
		each settingsOn: aBuilder]! !

!TestExecutionEnvironment class methodsFor: 'fuel support' stamp: ''!
fuelIgnoredInstanceVariableNames
    ^#('watchDogProcess' 'watchDogSemaphore' 'mainTestProcess')! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testDeactivation

	executionEnvironment activated.
	self deny: executionEnvironment watchDogProcess isTerminated.
	
	executionEnvironment deactivated.
	self assert: executionEnvironment watchDogProcess isTerminated.! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testDisableGivenServiceWhenItExists

	executionEnvironment disableService: TestServiceExample.

	self deny: testService isEnabled! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testNotifyTestServicesAboutHalt
	| errorPassed expectedException|
	errorPassed := false.
	expectedException := Halt new messageText: 'test halt'.
	self runWithNoHandlers: [	
		[self runTestWith: [ expectedException signal]] on: Halt do: [:actualException | 
			errorPassed := true.
			self assert: actualException equals: expectedException.
			self assert: (testService signaledExceptions includes: actualException)].
	].

	self assert: errorPassed! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testHasEmptyServicesByDefault

	executionEnvironment := TestExecutionEnvironment new.
	
	self assert: executionEnvironment services isEmpty! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testIsMainTestProcessFailed

	| processMonitor |
	processMonitor := ProcessMonitorTestService new.
	executionEnvironment registerService: processMonitor.		
	executionEnvironment activated.
	
	self deny: executionEnvironment isMainTestProcessFailed.
	
	processMonitor recordTestFailure: Error new.
	self assert: executionEnvironment isMainTestProcessFailed! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testNotifyTestServicesAboutWarning
	| errorPassed expectedException|
	errorPassed := false.
	expectedException := Warning new messageText: 'test halt'.
	self runWithNoHandlers: [	
		[self runTestWith: [ expectedException signal]] on: Warning do: [:actualException | 
			errorPassed := true.
			self assert: actualException equals: expectedException.
			self assert: (testService signaledExceptions includes: actualException)].
	].

	self assert: errorPassed! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testNotifyTestServicesAboutCompletedFailedTest

	[
		self runTestWith: [ self error: 'test error' ]
	] onErrorDo: [ self deny: testService isCompletedTestHandled ].

	self assert: testService isCompletedTestHandled! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testEnableGivenServiceWithConfigurationBlock

	| actual |
	executionEnvironment enableService: TestServiceExample using: [:service | actual := service] .

	self assert: actual identicalTo: testService ! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testActivationShouldStartWatchDog

	executionEnvironment activated.
	
	self assert: executionEnvironment watchDogProcess isTerminated not! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testCleanUpTestServicesAfterFailedTest

	[ 
		self runTestWith: [ self error: 'test error'] 
	] onErrorDo: [].

	self assert: testService isCleanUpDone! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testCleanUpTestServicesAfterTerminatedTest

	self runWithNoHandlers: [
		self runTestWith: [ Processor terminateActive]].

	self assert: testService isCleanUpDone ! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testGettingEnvironmentFromTestCase

	| actual |
	executionEnvironment beActiveDuring: [ 
		actual := self executionEnvironment.
	].

	self assert: actual identicalTo: executionEnvironment ! !

!TestExecutionEnvironmentTest methodsFor: 'helpers' stamp: ''!
runTestWith: aBlock

	| currentServices |
	ranTest := self class selector: #exampleTest.
	currentServices := executionEnvironment services copy.
	executionEnvironment activated. "activation registerrs all default services"
	executionEnvironment services: currentServices.
	
	ranTest exampleTestBlock: aBlock.
	executionEnvironment runTestCase: ranTest! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testIgnoreLongTestWhenItIsSuspendedAsUnderDebug
	| timeOutSignaled testProcess |
	timeOutSignaled := false.
	testProcess := [
		executionEnvironment activated.		
		[ self runTestWith: [ 
				executionEnvironment maxTimeForTest: 10 milliSeconds.
				Processor activeProcess suspend "it simulates the under debugger condition"]
		] on: TestTookTooMuchTime do: [ :err | timeOutSignaled := true ]		
	] forkAt: Processor activePriority + 1.

	self deny: timeOutSignaled! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testResetWatchDogTimeoutBetweenTests

	self runTestWith: [ executionEnvironment maxTimeForTest: self defaultTimeLimit + 10 seconds].
	
	self runTestWith: [ 
		self assert: executionEnvironment maxTimeForTest equals: self defaultTimeLimit]! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testIsMainTestProcess

	executionEnvironment activated.
	
	self assert: (executionEnvironment isMainTestProcess: Processor activeProcess).
	
	self deny: (executionEnvironment isMainTestProcess: [] newProcess).! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testActivationShouldRegisterDefaultServices

	[
		TestServiceExample isEnabled: true.
		executionEnvironment removeAllServices.
		
		executionEnvironment activated.
		self assert: (executionEnvironment services 
						anySatisfy: [:each | each class = TestServiceExample ])

	] ensure: [TestServiceExample isEnabled: false]! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testNotifyOnlyEnabledTestServices
	| testService2 testService3 |
	testService disable.
	testService2 := self createTestService.
	testService2 disable.
	testService3 := self createTestService.
	testService3 enable.
	executionEnvironment registerService: testService2; registerService: testService3.
	
	self runTestWith: [ #success ].
	
	self deny: testService isCompletedTestHandled.
	self deny: testService2 isCompletedTestHandled.
	self assert: testService3 isCompletedTestHandled.! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testDoesNotCleanUpTestServicesUntilTestErrorIsNotHandled

	self runWithNoHandlers: [ 
		[ self runTestWith: [ self error: 'test error'] ]
			on: UnhandledError do: [:exc | 
				self deny: testService isCleanUpDone.
	]].

	self assert: testService isCleanUpDone! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testCleanUpAlsoDisabledTestServices
	| testService2 |
	testService disable.
	testService2 := self createTestService.
	testService2 enable.
	executionEnvironment registerService: testService2.
	
	executionEnvironment cleanUpAfterTest.
	
	self assert: testService isCleanUpDone.
	self assert: testService2 isCleanUpDone! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testRegisteredServiceShouldBeBoundToEnvironment

	self assert: testService executionEnvironment equals: executionEnvironment! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testActivationShouldSetUpMainTestProcess

	executionEnvironment activated.
	
	self assert: executionEnvironment mainTestProcess equals: Processor activeProcess! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testHandleForkedProcessesByAllServices

	| process |
	executionEnvironment activated.
	
	process := [  ] newProcess name: 'test process'.
	executionEnvironment prepareForNewProcess: process.
	
	self assert: (testService forkedProcesses includes: process)! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testDisableGivenServiceWhenItIsNotRegistered

	executionEnvironment removeAllServices.
	
	executionEnvironment disableService: TestServiceExample! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testIsMainTestProcessActive

	executionEnvironment activated.
	
	self assert: (executionEnvironment isMainTestProcessActive).
	
	self runWithNoHandlers: [ 
		self deny: (executionEnvironment isMainTestProcessActive) ]! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testRunningTestShouldSetDefaultTimeLimit

	self runTestWith: [ 
		self assert: executionEnvironment maxTimeForTest equals: self defaultTimeLimit
	]! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testCleanUpTestServicesAfterSucceedTest

	self runTestWith: [ #success].

	self assert: testService isCleanUpDone! !

!TestExecutionEnvironmentTest methodsFor: 'running' stamp: ''!
createTestService
	^TestServiceExample new! !

!TestExecutionEnvironmentTest methodsFor: 'accessing' stamp: ''!
exampleTestBlock: anObject
	exampleTestBlock := anObject! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testEnableGivenServiceWhenItIsNotRegistered

	executionEnvironment removeAllServices.
	
	testService := executionEnvironment enableService: TestServiceExample.

	self assert: testService identicalTo: (executionEnvironment findService: TestServiceExample).
	self assert: testService isEnabled! !

!TestExecutionEnvironmentTest methodsFor: 'helpers' stamp: ''!
exampleTest
	"It is a test case to be used for testing how testCase is running by environment"

	exampleTestBlock cull: self! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testIgnoreWatchDogProcessAsForkedOne
	
	executionEnvironment activated.
	executionEnvironment prepareForNewProcess: executionEnvironment watchDogProcess.
	
	self deny: (testService forkedProcesses includes: executionEnvironment watchDogProcess)! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testFindService

	self assert: (executionEnvironment findService: TestServiceExample) identicalTo: testService ! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testNotifyTestServicesAboutUnhandledError
	| errorPassed expectedException|

	errorPassed := false.
	expectedException := Error new messageText: 'test error'.
	
	self runWithNoHandlers: [	
		[self runTestWith: [ expectedException signal]] on: UnhandledError do: [:actualException | 
			errorPassed := true.
			self assert: actualException exception equals: expectedException.
			self assert: (testService signaledExceptions includes: actualException)].
	].

	self assert: errorPassed! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testResetWatchDogTimeoutBetweenFailedTests

	[self runTestWith: [ 
		executionEnvironment maxTimeForTest: self defaultTimeLimit + 10 seconds. 
		self error: 'test error']
	]	onErrorDo: [].
	
	self runTestWith: [ 
		self assert: executionEnvironment maxTimeForTest equals: self defaultTimeLimit]! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testRunningTooLongTest

	self 
		should: [
			self runTestWith: [ 
				executionEnvironment maxTimeForTest: 10 milliSeconds.
				20 milliSeconds wait]]
		raise: TestTookTooMuchTime ! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testEnableGivenServiceWhenItExists

	| actual |
	testService disable.
	
	actual := executionEnvironment enableService: TestServiceExample.

	self assert: actual identicalTo: testService.
	self assert: testService isEnabled! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testNotifyTestServicesAboutCompletedTest

	self runTestWith: [
		self deny: testService isCompletedTestHandled].

	self assert: testService isCompletedTestHandled! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testDoesNotNotifyTestServicesAboutTerminatedTest

	self runWithNoHandlers: [ 
		self runTestWith: [Processor terminateActive].
	].

	self deny: testService isCompletedTestHandled! !

!TestExecutionEnvironmentTest methodsFor: 'tests' stamp: ''!
testRunningTest
	| executed |
	executed := false.
	
	self runTestWith: [ 
		self assert: executionEnvironment testCase identicalTo: ranTest.
		executed := true
	].

	self assert: executed! !

!TestExecutionEnvironmentTest class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit
	^9.1 seconds! !

!TestExecutionEnvironmentTestCase methodsFor: 'running' stamp: ''!
runWithNoHandlers: aBlock
	"Executing the given block directly would go through all handlers of SUnit machinery.
	Here we simulate the clean environment with no outer handlers for possible block errors"
	| newProcess synchSemaphore result |
	synchSemaphore := Semaphore new. 
	newProcess := self 
		newProcess: 'Test process with no error handlers' 
		toImmediatelyExecute: [result := aBlock ensure: [synchSemaphore signal]].
	newProcess resume.
	synchSemaphore wait.
	^result! !

!TestExecutionEnvironmentTestCase methodsFor: 'running' stamp: ''!
tearDown
	
	executionEnvironment deactivated. "for the case if we activated environment during test"
	processes do: [ :each | each terminate ].
	
	super tearDown.! !

!TestExecutionEnvironmentTestCase methodsFor: 'running' stamp: ''!
runCaseManaged
	"Here we are testing the test environment logic.
	So we should disable it for ourselves"
	
	^DefaultExecutionEnvironment beActiveDuring: [ self runCase]! !

!TestExecutionEnvironmentTestCase methodsFor: 'tests' stamp: ''!
testIsEnabledByDefault

	testService := self createTestService.
	
	self assert: testService isEnabled equals: testService isEnabledByDefault.
	self assert: testService isEnabledByDefault equals: testService class isEnabled! !

!TestExecutionEnvironmentTestCase methodsFor: 'running' stamp: ''!
createTestService

	self subclassResponsibility ! !

!TestExecutionEnvironmentTestCase methodsFor: 'tests' stamp: ''!
testCleanUpShouldRevertServiceToBeEnabledByDefault

	testService isEnabled: testService isEnabledByDefault not.
	
	testService cleanUpAfterTest.
	
	self assert: testService isEnabled equals: testService isEnabledByDefault! !

!TestExecutionEnvironmentTestCase methodsFor: 'running' stamp: ''!
newProcess: aName toImmediatelyExecute: aBlock
	| newProcess |
	newProcess := aBlock newProcess.
	newProcess name: aName, (processes size + 1) asString.
	newProcess priority: Processor activePriority + 1.
	processes add: newProcess.
	^newProcess! !

!TestExecutionEnvironmentTestCase methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	processes := OrderedCollection new.
	
	testService := self createTestService.	
	testService enable.
	executionEnvironment := TestExecutionEnvironment new.
	executionEnvironment registerService: testService.
! !

!TestExecutionEnvironmentTestCase class methodsFor: 'testing' stamp: ''!
isAbstract 
	^self = TestExecutionEnvironmentTestCase ! !

!TestExecutionService commentStamp: ''!
I am a root of hierarchy of services for test execution environment.

Every service registered in the environment is notified about following events:

- #handleException:, it is executed for every Exception signaled from the test 
- #handleCompletedTest, it is executed when test is completes (successfully or due to the error)
- #handleNewProcess:, it is executed for every process created during the test

I implement them as dummy methods. Subclasses can choose what exactly they need to implement.

I define another method #cleanUpAfterTest to perform full cleanup of service to be prepared for the next test.
Subclasses should extend this method to perform own specific cleanup. 
All services must recover own default state in this method.

For example every service can be enabled or disabled for concrete test: 

	- enable 
	- disable

During #cleanUpAfterTest I restore the activeness according to my default configuration (class side #isEnabled). Subclasses should do the same with their own configurations.

TestExecutionEnvironment queries all my subclasses to register them for tests execution: 

	TestExecutionService enabledServiceClasses.
	
Settings browser queries all default services to collect their parameters and allow users to enable/disable services globaly:
	
	TestExecutionService defaultServiceClasses.

Default services are not abstract classes enabled by default (#isEnabledByDefault = true).

To provide configuration for setting browser subclasses should extend class side method #settingsOn:. It does not require a pragma because the actual collection of settings from all services is performed by test environment.
		
Internal Representation and Key Implementation Points.

    Instance Variables
	executionEnvironment:		<TestExecutionEnvironment>
	isEnabled:		<Boolean>
!
!TestExecutionService methodsFor: 'accessing' stamp: ''!
isEnabled: aBoolean
	isEnabled := aBoolean ! !

!TestExecutionService methodsFor: 'controlling' stamp: ''!
handleException: anUnhandledException! !

!TestExecutionService methodsFor: 'controlling' stamp: ''!
handleCompletedTest! !

!TestExecutionService methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	
	isEnabled := self isEnabledByDefault! !

!TestExecutionService methodsFor: 'accessing' stamp: ''!
isEnabled 
	^isEnabled! !

!TestExecutionService methodsFor: 'accessing' stamp: ''!
executionEnvironment
	^ executionEnvironment! !

!TestExecutionService methodsFor: 'controlling' stamp: ''!
disable
	isEnabled := false! !

!TestExecutionService methodsFor: 'accessing' stamp: ''!
executionEnvironment: anObject
	executionEnvironment := anObject! !

!TestExecutionService methodsFor: 'controlling' stamp: ''!
enable
	isEnabled := true! !

!TestExecutionService methodsFor: 'testing' stamp: ''!
isEnabledByDefault
	^self class isEnabled! !

!TestExecutionService methodsFor: 'controlling' stamp: ''!
cleanUpAfterTest
	
	isEnabled := self isEnabledByDefault! !

!TestExecutionService methodsFor: 'controlling' stamp: ''!
handleNewProcess: aProcess! !

!TestExecutionService class methodsFor: 'accessing' stamp: ''!
isEnabled: aBoolean
	isEnabled := aBoolean! !

!TestExecutionService class methodsFor: 'accessing' stamp: ''!
isEnabled 
	^isEnabled ifNil: [ isEnabled := self isEnabledByDefault ]! !

!TestExecutionService class methodsFor: 'accessing' stamp: ''!
enabledServiceClasses

	^Array streamContents: [ :s |
		self allSubclassesDo: [ :each | 
			each isAbstract not & each isEnabled ifTrue: [s nextPut: each ]]]! !

!TestExecutionService class methodsFor: 'testing' stamp: ''!
isEnabledByDefault
	^true! !

!TestExecutionService class methodsFor: 'settings' stamp: ''!
descriptionForSettingsBrowser
	^self comment! !

!TestExecutionService class methodsFor: 'accessing' stamp: ''!
isAbstract 
	^self = TestExecutionService! !

!TestExecutionService class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder
	"No need for pragma <systemsettings>:
	TestExecutionEnvironment organizes settings for all services.
	It calls this method for every default service class.
	Subclasses should override it to provide specific configuration options"	
	(aBuilder setting: self name)
		target: self;
		parent: #sunit;
		getSelector: #isEnabled;
		setSelector: #isEnabled:;
		default: self isEnabledByDefault;
		label: self name;
		description: self descriptionForSettingsBrowser! !

!TestExecutionService class methodsFor: 'accessing' stamp: ''!
defaultServiceClasses

	^Array streamContents: [ :s |
		self allSubclassesDo: [ :each | 
			each isAbstract not & each isEnabledByDefault ifTrue: [s nextPut: each ]]]! !

!TestFailedByForkedProcess commentStamp: ''!
I notify users about failed processes which were forked during the test.
I prevent the test to complete successfully when there was no errors from the main test process but some of background activities fail.

In practice I ensure no green tests which "spawn background debuggers"!
!TestFailedByForkedProcess methodsFor: '*JenkinsTools-Core' stamp: ''!
recordResultOf: aTestCase inHDTestReport: aHDTestReport
	
	executionEnvironment backgroundFailures do: [ :each | 
		each recordBackgroundFailureOf: aTestCase inHDTestReport: aHDTestReport ]! !

!TestFailure commentStamp: ''!
The test framework distinguishes between failures and errors.  A failure is an event whose possibiity is explicitly anticipated and checked for in an assertion, whereas an error is an unanticipated problem like a division by 0 or an index out of bounds.  TestFailure is raised when the boolean parameter of an assert: ... or deny: ... call is the opposite of what the assertion claims.!
!TestFailure methodsFor: '*JenkinsTools-Core' stamp: ''!
recordResultOf: aTestCase inHDTestReport: aHDTestReport
	
	aHDTestReport recordFailure: self duringTest: aTestCase! !

!TestFailure methodsFor: 'camp smalltalk' stamp: ''!
isResumable
	
	^ false! !

!TestFailure methodsFor: 'camp smalltalk' stamp: ''!
sunitAnnounce: aTestCase toResult: aTestResult
	aTestResult addFailure: aTestCase.! !

!TestFailure class methodsFor: 'testing' stamp: ''!
captureIfSignalledWhenStepping
	^self == TestFailure! !

!TestFailureTestCase methodsFor: 'tests' stamp: ''!
testCaptureIfSignalledWhenStepping
	self assert: TestFailure captureIfSignalledWhenStepping.
	self deny: (TestFailure allSubclasses anySatisfy: [:c|c captureIfSignalledWhenStepping])! !

!TestInWorldMorph commentStamp: ''!
Helper class for MorphTest!
!TestInWorldMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	outOfWorldCount := intoWorldCount := 0.! !

!TestInWorldMorph methodsFor: 'accessing' stamp: ''!
outOfWorld: aWorld
	aWorld ifNil:[^self].
	super outOfWorld: aWorld.
	outOfWorldCount := outOfWorldCount + 1.! !

!TestInWorldMorph methodsFor: 'accessing' stamp: ''!
intoWorldCount
	^intoWorldCount! !

!TestInWorldMorph methodsFor: 'accessing' stamp: ''!
intoWorld: aWorld
	aWorld ifNil:[^self].
	super intoWorld: aWorld.
	intoWorldCount := intoWorldCount + 1.! !

!TestInWorldMorph methodsFor: 'accessing' stamp: ''!
outOfWorldCount
	^outOfWorldCount! !

!TestInheritableVariable commentStamp: ''!
I am example of inheritable process specific variable.
I implement isInheritable on class side to return true when I enabled (I become enable only in tests because existance of inheritable variables effect process instantiation performance)!
!TestInheritableVariable class methodsFor: 'testing' stamp: ''!
isInheritable
	^self enabled! !

!TestInheritableVariable class methodsFor: 'controlling' stamp: ''!
disable
	enabled := false.
	Process updateInheritableKeys! !

!TestInheritableVariable class methodsFor: 'controlling' stamp: ''!
enable
	enabled := true.
	Process updateInheritableKeys! !

!TestInheritableVariable class methodsFor: 'testing' stamp: ''!
enabled
	^enabled ifNil: [ enabled := false ]! !

!TestLeftRunningProcess commentStamp: ''!
I notify users about dirty system state when test left running background processes. 
The process left running after the test could affect the execution of other tests and generally it could break the system when test suite is complete
!
!TestLocalVariable commentStamp: ''!
TestLocalVariable is a test class using in ProcessSpecificTest.!
!TestLocalVariable methodsFor: 'defaults' stamp: ''!
default
	"My default value for a new process is 0."
	
	^0! !

!TestResource commentStamp: ''!
Normally a test will set up all the objects it needs and tear them down again after it has run.  This self-containedness makes a test more robust.  Use `TestResource` only for objects that are needed by several tests and that are too 'expensive' (in time or otherwise) to recreate and destroy for each test.  A viable approach is to develop the code in MyTestCase's `setUp` and `tearDown` methods, then at some point refactor the code into the `setUp` and `tearDown` of a `TestResource` subclass whose class is added to `MyTestCase class>>resources` method.


### TestResource design and consequence

`TestResource` uses the singleton pattern. A `TestResource` class will set up a single instance of itself when first requested and tear it down again at the end of `TestSuite>>#run` (or `TestCase>>#run`, `TestCase>>#debug` and `TestCase>>#debugAsFailure`).  Normally, a TestResource, once setUp, remains active during the running of all remaining tests and is `reset` after all tests have run.  

Users can choose to `reset` a resource in the `tearDown` of a test that alters it, sacrificing the performance gain of having a single `setUp` of the resource for the certainty that other tests using it will not see the alterations.  Generally however, this should be the exception:  if you need to reset the resource for every test that uses it, its code should just be part of your test's `setUp` and `tearDown` code.

### How to use a test resource
To use, create a subclass of `TestResource` and override the following:
- `TestCase class>>#resources`, to return a collection including the new test resources class, for all test case classes that need it a TestCase' resources are set up in the order returned and torn down in the reverse order.
- `TestResource class>>resources`, if the resource itself always needs some other resource to be present before it can set up a TestResource's resource are set up before it and torn down after it, and are set up in the order returned and torn down in the reverse order.
- `TestResource>>#setUp` and tearDown, to define initial and final behaviour (just like a test).
- `TestResource>>#isAvailable`, to return true if it is and false if it isn't (the framework calls this after setUp);  ideally, this call should not change the resource' state - that should be done in setUp.

### Implementation
`TestResource` implements the singleton pattern in its class-side `TestResource class>>#isAvailable` and `TestResource class>>#reset` methods.  Do not override these when creating specific resources;  unless you are developing a whole new pattern of use, it will always be correct to override instance-side `setUp`, `tearDown` and `isAvailable`, and dangerous to override `class>>isAvailable`, `class>>isAlreadyAvailable` and `class>>reset`.

Generally, users do not code interactions with a test's resources during the running of a test.  Code that reads a resource' values while leaving its state strictly alone is safe enough.  A test must leave a resource in a clean state:  always use `reset` if a test must protect later-running tests from unsafe changes (and review whether in such a case a resource is the right thing to use in the first place).

See my superclass' comment for assertion and logging information.
!
!TestResource methodsFor: 'running' stamp: ''!
tearDown
	"Does nothing. Subclasses should override this to tear down their resource"! !

!TestResource methodsFor: 'accessing' stamp: ''!
description: aString

	description := aString! !

!TestResource methodsFor: 'accessing' stamp: ''!
description
	^ description ifNil: [ String empty ]! !

!TestResource methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: self class name asString! !

!TestResource methodsFor: 'testing' stamp: ''!
isUnavailable
	"override to provide information on the readiness of the resource"
	
	^self isAvailable not
			! !

!TestResource methodsFor: 'accessing' stamp: ''!
name
	name ifNil: [ ^ self printString ].
	^ name! !

!TestResource methodsFor: 'accessing' stamp: ''!
name: aString
	name := aString! !

!TestResource methodsFor: 'testing' stamp: ''!
isAvailable
	"Override to provide information on the readiness of the resource.  Put state-changing behaviour in setUp and keep this a state-preserving check as far as possible.  Where setUp is guaranteed to provide a valid resource if it completes, there is no need to override this."
	
	^true! !

!TestResource methodsFor: 'accessing' stamp: ''!
resources
	^self class resources! !

!TestResource methodsFor: 'running' stamp: ''!
setUp
	"Does nothing. Subclasses should override this to initialize their resource"! !

!TestResource class methodsFor: 'testing' stamp: ''!
isAlreadyAvailable
	^current class == self! !

!TestResource class methodsFor: 'private' stamp: ''!
resetOrAddResourcesTo: aCollection
	"Add correctly set-up resources to the collection unless already there. Reset any imperfectly-set-up resources, so current isNil will return true if they are re-encountered via an indirectly self-prerequing resource;  circular references cannot be set up so will never reply true to isAlreadyAvailable, but may have correctly-set-up prereqs to add and/or imperfectly-set-up ones to reset, so do not abort the loop first time round."

	current ifNil: [^self].
	self isAlreadyAvailable
		ifFalse:
			[self reset.
			self resources do: [:each | each resetOrAddResourcesTo: aCollection]]
		ifTrue:
			[(aCollection includes: self)
				ifFalse:
					[self resources do: [:each | each resetOrAddResourcesTo: aCollection].
					aCollection add: self]]

"The cloned 'self resources do: ...' line in both blocks is, I think, the best way to write this method so that its logic is clear.  The first loop resets this resource immediately, before traversing its resources;  the second traverses before adding"! !

!TestResource class methodsFor: 'instance creation' stamp: ''!
new
	"Use #current to get the valid current instance.  Use of #new to get an instance (that should never be the current one) could be done in bizarre circumstances, so is not blocked, but will usually be inappropriate."
	
	^super new initialize.! !

!TestResource class methodsFor: 'accessing' stamp: ''!
current
	"This is a lazy accessor:  the assert of self isAvailable does no work unless current isNil.  However this method should normally be sent only to a resource that should already have been made available, e.g. in a test whose test case class has the resource class in its #resources, so should never be able to fail the assert.
	If the intent is indeed to access a possibly-unprepared or reset-in-earlier-test resource lazily, then preface the call of 'MyResource current' with 'MyResource availableFor: self'."
	
	self
		assert: self isAvailable
		description:
			'Sent #current to unavailable resource ' , self name ,
					'.  Add it to test case'' class-side #resources (recommended) or send #availableFor: beforehand'.
	^current! !

!TestResource class methodsFor: 'accessing' stamp: ''!
current: aTestResource

	current := aTestResource
			! !

!TestResource class methodsFor: 'running' stamp: ''!
availableFor: aTestAsserter
	aTestAsserter
		assert: self isAvailable
		description:
			['Unavailable resource ' , self name , ' requested by '
				, aTestAsserter printString]! !

!TestResource class methodsFor: 'running' stamp: ''!
resetResources: topLevelResources
	"Reset all imperfectly-set-up resources while gathering the rest for ordered resetting."

	| availableResources |
	availableResources := OrderedCollection new: topLevelResources size.
	topLevelResources
		do: [:each | each resetOrAddResourcesTo: availableResources].
	availableResources reverseDo: [:each | each reset]! !

!TestResource class methodsFor: 'testing' stamp: ''!
isUnavailable

	^self isAvailable not
			! !

!TestResource class methodsFor: 'testing' stamp: ''!
isAbstract
	"Override to true if a TestResource subclass is Abstract and should not have
	TestCase instances built from it"

	^self name = #TestResource
			! !

!TestResource class methodsFor: 'testing' stamp: ''!
isAvailable
	"This is (and must be) a lazy method.  If my current has a value, an attempt to make me available has already been made:  trust its result.  If not, try to make me available."

	current ifNil: [self makeAvailable].
	^self isAlreadyAvailable! !

!TestResource class methodsFor: 'accessing' stamp: ''!
resources
	^#()! !

!TestResource class methodsFor: 'class initialization' stamp: ''!
reset
	[self isAlreadyAvailable ifTrue: [current tearDown]]
		ensure: [current := nil]! !

!TestResource class methodsFor: 'private' stamp: ''!
makeAvailable
	"This method must be the _only_ way to set a notNil value for the unique instance (current).  First, obtain a candidate instance and set current to a notNil placeholder (any notNil object not an instance of me would do;  this version uses false).  Next, check any subordinate resources needed by this resource.  Lastly, setUp the candidate and put it in current if it is available, ensuring that it is torn down otherwise."
	
	| candidate |
	current := nil.
	candidate := self new.
	self resources do: [:each | each availableFor: candidate].
	
	"Execute the TestResource's #setUp method within the DefaultExecutionEnvironment to prevent
	forked processes created within #setUp from being terminated by the TestExecutionEnvironment
	(in #checkForkedProcesses) it is running in."
	DefaultExecutionEnvironment beActiveDuring: [[candidate setUp.
	candidate isAvailable ifTrue: [current := candidate]]
		ensure: [current == candidate ifFalse: [candidate tearDown]]]! !

!TestResource class methodsFor: 'running' stamp: ''!
signalInitializationError
	^ self classForTestResult signalFailureWith:  'Resource ' , self name , ' could not be initialized'! !

!TestResourceWithForkedProcessTestCase commentStamp: ''!
SUnit tests for forked processes in test resources!
!TestResourceWithForkedProcessTestCase methodsFor: 'tests' stamp: ''!
testFirst

	"Test whether the TestResource's forked process is not terminated.
	A second test method will do the same and thereby validate that forked processes
	of a TestResource do not get terminated (in between tests)."

	self
		assert: WithForkedProcessTestResource current forkedProcess isTerminated not
		description: 'A forked process within a TestResource should not be terminated'! !

!TestResourceWithForkedProcessTestCase methodsFor: 'tests' stamp: ''!
testSecond

	"Test whether the TestResource's forked process is not terminated between tests"

	"Use the other test method's implementation"
	self testFirst! !

!TestResourceWithForkedProcessTestCase class methodsFor: 'accessing' stamp: ''!
resources

	"Answer the TestResource class having a forked process"

	^ Array with: WithForkedProcessTestResource! !

!TestResult commentStamp: ''!
This implements the Collecting Parameter pattern for running a bunch of tests.  It holds tests that have run, sorted into the result categories of passed, failures and errors.

TestResult is an interesting object to subclass or substitute. #runCase: is the external protocol you need to reproduce. TestResult subclasses can  handle multi-threaded tests (see SUnitXProcPatterns) and might record coverage information or send emails when the run completes.
!
!TestResult methodsFor: 'compatibility' stamp: ''!
passed
	^ self expectedPasses, self expectedDefects! !

!TestResult methodsFor: 'testing' stamp: ''!
isFailure: aTestCase
	^self failures includes: aTestCase! !

!TestResult methodsFor: 'testing' stamp: ''!
hasErrors

	^self errors size > 0! !

!TestResult methodsFor: 'accessing' stamp: ''!
unexpectedErrorCount
	^ self unexpectedErrors size! !

!TestResult methodsFor: 'compatibility' stamp: ''!
failures
	^ self unexpectedFailures, self unexpectedPasses ! !

!TestResult methodsFor: 'accessing' stamp: ''!
unexpectedPasses
	^ passed select: [:each | each shouldPass not] ! !

!TestResult methodsFor: 'adding' stamp: ''!
addPass: aTestCase
	"We cannot use self passed as that incorporates test expectations and so does not return the stored collection."

	^passed add: aTestCase! !

!TestResult methodsFor: 'history' stamp: ''!
selectResultsForTestCase: aTestCaseClass
	| passedSelectors errorsSelectors failuresSelectors |
	passedSelectors := self passed
						select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector].
	errorsSelectors := self errors 
						select: [:testCase | testCase class == aTestCaseClass ] thenCollect:  [:testCase | testCase selector].
	failuresSelectors := self failures 
						select: [:testCase | testCase class == aTestCaseClass ] thenCollect:  [:testCase | testCase selector].
	
	^ self class newTestDictionary 
		at: #passed put: passedSelectors asSet;
		at: #failures put: failuresSelectors asSet;
		at: #errors put: errorsSelectors asSet;
		yourself
		! !

!TestResult methodsFor: 'accessing' stamp: ''!
passedCount

	^self passed size! !

!TestResult methodsFor: 'accessing' stamp: ''!
skipped
	^ skipped! !

!TestResult methodsFor: 'accessing' stamp: ''!
expectedDefectCount
	^ self expectedDefects size! !

!TestResult methodsFor: 'accessing' stamp: ''!
expectedPassCount
	^ self expectedPasses size! !

!TestResult methodsFor: 'testing' stamp: ''!
hasPassed

	^self hasErrors not and: [self hasFailures not]! !

!TestResult methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	passed := OrderedCollection new.
	failures := Set new.
	errors := OrderedCollection new.
	skipped := OrderedCollection new.
	timeStamp := DateAndTime now! !

!TestResult methodsFor: 'accessing' stamp: ''!
errors: anOrderedCollection
	errors := anOrderedCollection! !

!TestResult methodsFor: 'accessing' stamp: ''!
timeStamp: anObject
	timeStamp := anObject! !

!TestResult methodsFor: 'history' stamp: ''!
updateResultsInHistory
	|classesToNotify|
	classesToNotify:= Set new.
	#(#passed #failures #errors) do: [ :status | 
		(self perform: status) do: [ :testCase | 
			classesToNotify add:testCase class.
			self class updateTestHistoryFor: testCase status: status ] ].
	classesToNotify do:[:cl | 
		cl historyAnnouncer announce: (TestSuiteEnded result: cl)]! !

!TestResult methodsFor: 'accessing' stamp: ''!
failureCount

	^self failures size! !

!TestResult methodsFor: 'running' stamp: ''!
runCaseForDebug: aTestCase
	[
	aTestCase announce: TestCaseStarted withResult: self.
	aTestCase runCaseManaged.
	aTestCase announce: TestCaseEnded  withResult: self.
	"To not affect performance of big test suites following logic is not inside addPass: method"
	errors remove: aTestCase ifAbsent: [].
	failures remove: aTestCase ifAbsent: [].
	self addPass: aTestCase]
		on: self class failure , self class skip, self class warning, self class error
		do: [:ex | ex sunitAnnounce: aTestCase toResult: self. ex pass]! !

!TestResult methodsFor: 'testing' stamp: ''!
isPassed: aTestCase

	^self passed includes: aTestCase! !

!TestResult methodsFor: 'accessing' stamp: ''!
classesTested
	^ (self tests collect: [ :testCase | testCase class ]) asSet! !

!TestResult methodsFor: 'testing' stamp: ''!
isError: aTestCase

	^self errors includes: aTestCase! !

!TestResult methodsFor: 'accessing' stamp: ''!
failures: aSet
	failures := aSet! !

!TestResult methodsFor: 'accessing' stamp: ''!
unexpectedFailureCount
	^ self unexpectedFailures size! !

!TestResult methodsFor: 'adding' stamp: ''!
addSkip: aTestCase

	^skipped add: aTestCase! !

!TestResult methodsFor: 'accessing' stamp: ''!
expectedDefects
	^ (errors, failures asOrderedCollection) select: [:each | each shouldPass not] ! !

!TestResult methodsFor: 'history' stamp: ''!
dispatchResultsIntoHistory 

	self classesTested do: 
		[ :testClass | 
		self class
			historyAt: testClass
			put: (self selectResultsForTestCase: testClass) ].
! !

!TestResult methodsFor: 'accessing' stamp: ''!
timeStamp
	^ timeStamp! !

!TestResult methodsFor: 'accessing' stamp: ''!
unexpectedFailures
	^ failures select: [:each | each shouldPass] ! !

!TestResult methodsFor: 'accessing' stamp: ''!
expectedPasses
	^ passed select: [:each | each shouldPass] ! !

!TestResult methodsFor: 'adding' stamp: ''!
addFailure: aTestCase
	"We cannot use self failures as that incorporates test expectations and so does not return the stored collection."

	^failures add: aTestCase! !

!TestResult methodsFor: 'testing' stamp: ''!
hasFailures

	^self failures size > 0! !

!TestResult methodsFor: 'printing' stamp: ''!
printOn: aStream
	self runCount isZero ifTrue: [ ^ aStream nextPutAll: 'No tests ran' ].
	aStream
		print: self runCount;
		nextPutAll: ' ran, ';
		print: self expectedPassCount;
		nextPutAll: ' passed, ';
		print: self skippedCount;
		nextPutAll: ' skipped, ';
		print: self expectedDefectCount;
		nextPutAll: (' expected failure' asPluralBasedOn: self expectedDefectCount); 
		nextPutAll: ', ';
		print: self unexpectedFailureCount;
		nextPutAll: (' failure' asPluralBasedOn: self unexpectedFailureCount);
		nextPutAll: ', ';
		print: self unexpectedErrorCount;
		nextPutAll: (' error' asPluralBasedOn: self unexpectedErrorCount);
		nextPutAll: ', ';
		print: self unexpectedPassCount;
		nextPutAll: ' passed unexpected'! !

!TestResult methodsFor: 'accessing' stamp: ''!
defects
	^OrderedCollection new
		addAll: self errors;
		addAll: self failures; yourself! !

!TestResult methodsFor: 'diff' stamp: ''!
diff: aTestResult
	"Return a collection that contains differences"
	| passed1Selectors failed1Selectors errors1Selectors passed2Selectors failed2Selectors errors2Selectors |
	passed1Selectors := self passed collect: [:testCase | testCase selector].
	failed1Selectors := self failures collect: [:testCase | testCase selector].
	errors1Selectors := self errors collect: [:testCase | testCase selector].

	passed2Selectors := aTestResult passed collect: [:testCase | testCase selector].
	failed2Selectors := aTestResult failures collect: [:testCase | testCase selector].
	errors2Selectors := aTestResult errors collect: [:testCase | testCase selector].
	
	^ {passed1Selectors copyWithoutAll: passed2Selectors .
		failed1Selectors copyWithoutAll: failed2Selectors .
		errors1Selectors copyWithoutAll: errors2Selectors}! !

!TestResult methodsFor: 'accessing' stamp: ''!
runCount

	^self passedCount + self failureCount + self errorCount! !

!TestResult methodsFor: 'adding' stamp: ''!
addError: aTestCase
	"We cannot use self errors as that incorporates test expectations and so does not return the stored collection."

	^errors add: aTestCase! !

!TestResult methodsFor: 'accessing' stamp: ''!
tests
	^(OrderedCollection new: self runCount)
		addAll: passed;
		addAll: failures;
		addAll: errors;
		addAll: skipped;
		yourself! !

!TestResult methodsFor: 'compatibility' stamp: ''!
errors
	^ self unexpectedErrors! !

!TestResult methodsFor: 'querying' stamp: ''!
isPassedFor: class selector: selector
	^ self passed anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! !

!TestResult methodsFor: 'accessing' stamp: ''!
skippedCount

	^ self skipped size! !

!TestResult methodsFor: 'running' stamp: ''!
runCase: aTestCase
	[
	aTestCase announce: TestCaseStarted withResult: self.
	aTestCase runCaseManaged.
	aTestCase announce: TestCaseEnded  withResult: self.
	self addPass: aTestCase]
		on: self class failure , self class skip, self class warning, self class error
		do: [:ex | ex sunitAnnounce: aTestCase toResult: self]! !

!TestResult methodsFor: 'combining' stamp: ''!
mergeWith: aTestResult

	timeStamp := DateAndTime now.
	failures addAll: aTestResult failures.
	errors addAll: aTestResult errors.
	passed addAll: aTestResult passed.
	skipped addAll: aTestResult skipped! !

!TestResult methodsFor: 'querying' stamp: ''!
isErrorFor: class selector: selector
	^ self errors anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! !

!TestResult methodsFor: 'accessing' stamp: ''!
unexpectedErrors
	^ errors select: [:each | each shouldPass] ! !

!TestResult methodsFor: 'file in/out' stamp: ''!
fileOutOn: aFileStream
	"Write in aFileStream like:
	3 run, 2 passes, 0 expected failures, 1 failures, 0 errors, 0 unexpected passes
	Failures:
	SHParserST80Test>>#testNumbers
	
	Errors:"	
	| printer |
	printer := [:title :testCases | 
				aFileStream cr; nextPutAll: title; cr.
				testCases do: [:aTestCase| 
								aTestCase printOn: aFileStream.
								aFileStream cr]].
				
	self printOn: aFileStream.	
	printer value: 'Failures:' value: self failures.
	printer value: 'Errors:' value: self errors.! !

!TestResult methodsFor: 'accessing' stamp: ''!
passed: anOrderedCollection
	passed := anOrderedCollection! !

!TestResult methodsFor: 'querying' stamp: ''!
isFailureFor: class selector: selector
	^ self failures anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! !

!TestResult methodsFor: 'accessing' stamp: ''!
errorCount

	^self errors size! !

!TestResult methodsFor: 'accessing' stamp: ''!
unexpectedPassCount
	^ self unexpectedPasses size! !

!TestResult class methodsFor: 'default - color' stamp: ''!
defaultColorTextForPassingTest
	^ self defaultColorText! !

!TestResult class methodsFor: 'exceptions' stamp: ''!
signalErrorWith: aString 
	self error signal: aString
			! !

!TestResult class methodsFor: 'history' stamp: ''!
historyAt: aTestCaseClass
"I will return the last test dictionary for aTestCaseClass. If none found, I will create a new empty one and link it in the history."

	^ aTestCaseClass history ! !

!TestResult class methodsFor: 'exceptions' stamp: ''!
warning
	"Warning that should be treated as test failure"
	^Deprecation 
			! !

!TestResult class methodsFor: 'default - color' stamp: ''!
defaultColorBackGroundForFailureTest
	^ self currentTheme testColorFailure! !

!TestResult class methodsFor: 'default - color' stamp: ''!
defaultColorBackGroundForPassingTest
	^ self currentTheme testColorPassing! !

!TestResult class methodsFor: 'default - color' stamp: ''!
defaultColorText
	^ Color black! !

!TestResult class methodsFor: 'exceptions' stamp: ''!
error
	^self exError! !

!TestResult class methodsFor: 'default - color' stamp: ''!
defaultColorTextForErrorTest
	^ self defaultColorText! !

!TestResult class methodsFor: 'exceptions' stamp: ''!
failure
	^TestFailure! !

!TestResult class methodsFor: 'history' stamp: ''!
newTestDictionary

	^ Dictionary new at: #timeStamp put: DateAndTime now;
		at: #passed put: Set new;
		at: #failures put: Set new;
		at: #errors put: Set new;
		yourself
		! !

!TestResult class methodsFor: 'history' stamp: ''!
removeFromTestHistory: aSelector in: aTestCaseClass
	| lastRun |
	
	lastRun := self historyFor: aTestCaseClass.
	#(#passed #failures #errors) do:
		[ :set | (lastRun at: set) remove: aSelector ifAbsent: []].
! !

!TestResult class methodsFor: 'exceptions' stamp: ''!
signalFailureWith: aString 
	self failure signal: aString
			! !

!TestResult class methodsFor: 'default - color' stamp: ''!
defaultColorBackGroundForErrorTest
	^ self currentTheme testColorError! !

!TestResult class methodsFor: 'exceptions' stamp: ''!
currentTheme
	^ Smalltalk ui theme! !

!TestResult class methodsFor: 'history' stamp: ''!
historyAt: aTestCaseClass put: aDictionary
	aTestCaseClass history: aDictionary
	"^ self history at: aTestCaseClass put: aDictionary "! !

!TestResult class methodsFor: 'exceptions' stamp: ''!
resumableFailure
	^ResumableTestFailure! !

!TestResult class methodsFor: 'history' stamp: ''!
historyFor: aTestCaseClass
	"I return the last test dictionary for aTestCaseClass. 
	If none found, I return an empty dictionary but will not link it to the class in the history."
	
	| history |
	history := aTestCaseClass history.
	history ifNil: [ ^ self newTestDictionary ].
	^ history
	
"	^ self history at: aTestCaseClass ifAbsent: [ self newTestDictionary ]"! !

!TestResult class methodsFor: 'exceptions' stamp: ''!
skip
	^ TestSkipped! !

!TestResult class methodsFor: 'history' stamp: ''!
updateTestHistoryFor: aTestCase status: aSymbol
	| cls sel |
	
	cls := aTestCase class.
	sel := aTestCase selector.
	self removeFromTestHistory: sel in: cls.
	((self historyAt: cls) at: aSymbol ) add: sel.! !

!TestResult class methodsFor: 'default - color' stamp: ''!
defaultColorTextForFailureTest
	^ self defaultColorText! !

!TestResult class methodsFor: 'exceptions' stamp: ''!
exError
	^Error
			! !

!TestReviver commentStamp: ''!
I am a UI for test failures which have been serialized as fuel files. You can:
- materialize the failed test process to debug
- browse the test method.

self open!
!TestReviver methodsFor: 'private' stamp: ''!
browse: anAbstractFileReference

	| tokens testClass |
	anAbstractFileReference ifNil: [ ^self ].
	tokens := anAbstractFileReference base findTokens: '-'.
	testClass := Smalltalk at: tokens first asSymbol.
	Smalltalk tools browser openOnClass: testClass selector: tokens second asSymbol.! !

!TestReviver methodsFor: 'accessing' stamp: ''!
imageVersion

	^ imageVersion! !

!TestReviver methodsFor: 'private' stamp: ''!
materialize: fuelFileReference
	fuelFileReference ifNil: [ ^self ].
	FLMaterializer materializeFromFileNamed: fuelFileReference fullName! !

!TestReviver methodsFor: 'accessing' stamp: ''!
vmVersionLabel

	^ vmVersionLabel! !

!TestReviver methodsFor: 'private' stamp: ''!
initialExtent

	^ 700@500! !

!TestReviver methodsFor: 'initialization' stamp: ''!
initializeWidgets
	| serializedErrors |
	self instantiateWidgets.
	serializedErrors := self selectTestFailures.
	errorListModel
		items: serializedErrors;
		displayBlock: [ :e | e base copyReplaceAll: '-' with: '>>#' ].
	serializedErrors isEmpty
		ifFalse: [ errorListModel setSelectedIndex: 1 ].
	vmVersionLabel label: 'VM Version'.
	vmVersion
		text: '';
		enabled: false.
	timeStampLabel label: 'Timestamp'.
	timeStamp
		text: '';
		enabled: false.
	imageVersionLabel label: 'Image Version'.
	imageVersion
		text: '';
		enabled: false.
	debugButton
		label: 'Debug';
		action: [ self materialize: errorListModel selectedItem ].
	browseButton
		label: 'Browse';
		action: [ self browse: errorListModel selectedItem ].
	self focusOrder
		add: debugButton;
		add: browseButton;
		add: errorListModel! !

!TestReviver methodsFor: 'accessing' stamp: ''!
timeStamp
	^ timeStamp! !

!TestReviver methodsFor: 'private' stamp: ''!
browseButton

	^ browseButton! !

!TestReviver methodsFor: 'private' stamp: ''!
debugButton

	^ debugButton! !

!TestReviver methodsFor: 'accessing' stamp: ''!
timeStampLabel
	^ timeStampLabel! !

!TestReviver methodsFor: 'accessing' stamp: ''!
selectTestFailures	
	| files results tokens method | 
	results := OrderedCollection new.
	files := FileLocator imageDirectory filesMatching: '*.fuel'.
	files do: [:aFile |
		tokens := aFile resolve base findTokens: '-'.	
		method := (Smalltalk globals at: tokens first asSymbol ) lookupSelector:  tokens second asSymbol.
		method pragmas isEmpty
			ifTrue: [ results add: aFile ]
			ifFalse:  [
				(method pragmas first selector = #expectedFailure) 
					ifFalse: [ results add: aFile ].
				 ]
	].
	^ results! !

!TestReviver methodsFor: 'initialization' stamp: ''!
instantiateWidgets
	errorListModel := self newList.
	debugButton := self newButton.
	browseButton := self newButton.
	vmVersionLabel := self newLabel.
	vmVersion := self newText.
	timeStampLabel := self newLabel.
	timeStamp := self newText.
	imageVersionLabel := self newLabel.
	imageVersion := self newText! !

!TestReviver methodsFor: 'private' stamp: ''!
errorListModel

	^ errorListModel! !

!TestReviver methodsFor: 'accessing' stamp: ''!
vmVersion

	^ vmVersion! !

!TestReviver methodsFor: 'accessing' stamp: ''!
imageVersionLabel

	^ imageVersionLabel! !

!TestReviver methodsFor: 'initialization' stamp: ''!
initializePresenter

	errorListModel whenSelectedItemChanged: [ :item | 
		| header |
		item 
			ifNil: [ 
				vmVersion text: ''.
				imageVersion text: ''.
				timeStamp text: ''.
				]	
			ifNotNil: [
				header := FLMaterializer materializeHeaderFromFileNamed: item.
				vmVersion text: (header additionalObjectAt: #VM).
				imageVersion text: (header additionalObjectAt: #Image).
				timeStamp text: (header additionalObjectAt: #Timestamp)
				] 
	]! !

!TestReviver class methodsFor: 'opening' stamp: ''!
open
	<script>
	
	|model|
	model := self new.
	model openWithSpec model: model.
	^model! !

!TestReviver class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>

	^ SpecLayout composed
		newColumn: [:c |
			c 
				newRow: [ :spec | spec
					add: #debugButton;
					add: #browseButton ] height: 30;
				newRow: [ :spec | spec add:  #errorListModel ];
				newRow: [ :spec | spec
						add: #timeStampLabel width: 100;
						add: #timeStamp ] height: 30;
				newRow: [ :spec | spec
						add: #imageVersionLabel width: 100;
						add: #imageVersion ] height: 30;
				newRow: [ :spec | spec
						add: #vmVersionLabel width: 100;
						add: #vmVersion ] height: 75];
		yourself! !

!TestReviver class methodsFor: 'accessing' stamp: ''!
title

	^ 'Test Error Browser'! !

!TestRunner commentStamp: ''!
<lint: #ignore rule: #classNotReferenced rational: 'this view is only accessed from menus'>

Although tests can be most easily be run from a browser, I provide the ability to: 
* select sets of test suites to run. I am designed to make it easy to execute groups of tests
* obtain a more detailed log of the results 


UI Description 
___________ 

My left-most pane lists all of the categories that contain test classes (i.e., subclasses of TestCase); when some of these categories are selected, the test classes that they contain appear in the pane to the right. Abstract classes are italicized, and the test class hierarchy is shown by indentation, so subclasses of ClassTestCase are indented more than subclasses of TestCase. 

The tests that did not pass (if any) are listed in the right-hand panes of the Test Runner; if you want to debug one, to see why it failed, just click on the name.
!
!TestRunner methodsFor: 'accessing - testing' stamp: ''!
errorList
	^ errorList collect: [ :each | each printString ].! !

!TestRunner methodsFor: 'actions' stamp: ''!
debug: aTestCase
	self
		debugSuite:
			(self classForTestSuite new
				addTest: aTestCase;
				yourself)! !

!TestRunner methodsFor: 'accessing - packages' stamp: ''!
packageAt: anIndex
	^ packagesSelected includes: (packages at: anIndex ifAbsent: [ ^ false ]).! !

!TestRunner methodsFor: 'utilities' stamp: ''!
findClassesForPackages: aCollection
	| items |
	aCollection isEmpty
		ifTrue: [ ^ self baseClass withAllSubclasses asSet ].
	items := aCollection
		flatCollect: [ :category | 
			((Smalltalk organization listAtCategoryNamed: category) 
				collect: [ :each | Smalltalk globals at: each ])
				select: [ :each | each includesBehavior: self baseClass ] ].
	^ items asSet! !

!TestRunner methodsFor: 'accessing' stamp: ''!
allSelectedTestSuites
	"Return the suite for all the selected test case classes"
	
	^ classesSelected select: [ :each | each isAbstract not] thenCollect: [:each | each suite].! !

!TestRunner methodsFor: 'history saving' stamp: ''!
hasProgress

	result classesTested do: [:cls |
		(cls class includesSelector: #lastStoredRun)
			ifTrue: [^ true]].
	^ false! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
classSelected: anInteger
	classIndex := anInteger.
	self changed: #classSelected! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
classAt: anInteger
	^ classesSelected includes: (classes at: anInteger ifAbsent: [ ^ false ]).! !

!TestRunner methodsFor: 'accessing - menu' stamp: ''!
failureMenu: aMenu
	"Add the browse item only if an item is selected"
	
	failedSelected ifNotNil: [aMenu add: 'Browse test' selector: #browseSelectedFailedTest].
	^ aMenu! !

!TestRunner methodsFor: 'accessing - packages' stamp: ''!
packageMenu: aMenu
	^ aMenu
		addTitle: 'Packages';
		add: 'Select all' selector: #selectAllPackages;
		add: 'Select inversion' selector: #selectInversePackages;
		add: 'Select none' selector: #selectNoPackages;
		addLine;
		add: 'Filter...' selector: #filterPackages;
		addLine;
		add: 'Refresh' selector: #updatePackages;
		yourself.! !

!TestRunner methodsFor: 'accessing - packages' stamp: ''!
packageSelected
	^ packageIndex ! !

!TestRunner methodsFor: 'actions' stamp: ''!
runTestSuites: testSuites 
	CurrentExecutionEnvironment runTestsBy: [
		testSuites
			do: [:testSuite | self runSuite: testSuite]
			displayingProgress: 'Running Tests'
	]! !

!TestRunner methodsFor: 'accessing - testing' stamp: ''!
failedList
	^ failedList collect: [ :each | each printString ].! !

!TestRunner methodsFor: 'private' stamp: ''!
windowIsClosing
	SystemAnnouncer uniqueInstance unsubscribe: self! !

!TestRunner methodsFor: 'building' stamp: ''!
classSearchUpdate: aPattern
	classPattern := (aPattern isNil or: [ aPattern trimBoth isEmpty ])
		ifTrue: [ nil ]
		ifFalse: [ aPattern asRegexIgnoringCase ].
	self updateClasses.! !

!TestRunner methodsFor: 'accessing - testing' stamp: ''!
errorSelected
	^ errorList indexOf: errorSelected.! !

!TestRunner methodsFor: 'accessing - ui' stamp: ''!
extent
	^ 640 @ 480! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
filterClasses

	| pattern |

	pattern := UIManager default request: 'Pattern to select tests:' initialAnswer: '*'.
	pattern ifNil: [ ^ self ].
	classesSelected := ( classes select: [ :each | pattern match: each name ] ) asSet.
	self
		changed: #allSelections;
		changed: #classSelected;
		changed: #hasRunnable! !

!TestRunner methodsFor: 'building' stamp: ''!
buttonsFrame
	^LayoutFrame new topFraction: 1 offset: self buttonHeight negated
		! !

!TestRunner methodsFor: 'building' stamp: ''!
buildPackages

	^ PluggableListMorph new
		on: self
		list: #packageList 
		primarySelection: #packageSelected 
		changePrimarySelection: #packageSelected: 
		listSelection: #packageAt: 
		changeListSelection: #packageAt:put: 
		menu: #packageMenu:  
		keystroke: nil;
		yourself! !

!TestRunner methodsFor: 'history saving' stamp: ''!
previousRun

	^ previousRun ifNil: [ previousRun := OrderedCollection new ]! !

!TestRunner methodsFor: 'building' stamp: ''!
buildPackageSearch

	^ SearchMorph new
		ghostText: 'Package #1 | Package #2';
		model: self;
		updateSelector: #packageSearchUpdate:;
		yourself! !

!TestRunner methodsFor: 'building' stamp: ''!
open
	<script: 'self new open'>
	 
	^ self build openInWorld
	
! !

!TestRunner methodsFor: 'accessing - testing' stamp: ''!
errorSelected: anInteger
	errorSelected := errorList at: anInteger ifAbsent: nil.
	self changed: #errorSelected.
	errorSelected ifNotNil: [ self debug: errorSelected ].! !

!TestRunner methodsFor: 'browsing' stamp: ''!
browseSelectedErrorTest

	errorSelected ifNil: [^self].
	self browseSelectedTest: errorSelected! !

!TestRunner methodsFor: 'factory' stamp: ''!
classForTestSuite
	^ TestSuite! !

!TestRunner methodsFor: 'accessing - testing' stamp: ''!
result: aResult
	result := aResult! !

!TestRunner methodsFor: 'testing' stamp: ''!
hasFailures
	^ result hasFailures.! !

!TestRunner methodsFor: 'history saving' stamp: ''!
saveResultInHistory
	result dispatchResultsIntoHistory! !

!TestRunner methodsFor: 'actions' stamp: ''!
addDeclaredPackagesUnderTestTo: listOfPackages 
	"This method looks for #packageNamesUnderTest method in class side of classes defined packages in listOfPackages.
	 If a class defines this method, then the coverage tool knows the methods of which packages should be spied to compute the coverage.
	 Thus, it adds it to #listOfPackages collection provided as parameter."
	classesSelected
		select: [ :class | (class class includesSelector: #packageNamesUnderTest) ]
		thenDo: [ :class | 
			class packageNamesUnderTest do: [ :name | 
				listOfPackages add: (RPackage organizer packageNamed: name) ] ]! !

!TestRunner methodsFor: 'accessing - ui' stamp: ''!
buttons
	^ #(( 'Run Selected' #runAll 'Run all selected tests' #hasRunnable )
		( 'Run Profiled' #runProfiled 'Run tests and profile' #hasRunnable )
		( 'Run Coverage' #runCoverage 'Run test and check code coverage' #hasRunnable )
		( 'Run Failures' #runFailures 'Run all failures' #hasFailures )
		( 'Run Errors' #runErrors 'Run all errors' #hasErrors )
		( 'File out results' #fileOutResults 'File out test results' #hasFailuresOrErrors))! !

!TestRunner methodsFor: 'accessing - packages' stamp: ''!
packageSelected: anInteger
	packageIndex := anInteger.
	self changed: #packageSelected.! !

!TestRunner methodsFor: 'actions' stamp: ''!
generateDefaultFileOutResultsName
	
	| filename |
	filename := String
		streamContents: [ :st | 
			st nextPutAll: 'tests_'.
			st nextPutAll: SystemVersion current version.
			st nextPutAll: '_'.
			result timeStamp printYMDOn: st.
			st nextPutAll: '_'.
			result timeStamp printHMSOn: st.
			st nextPutAll: '.txt' ].
	^ filename copyReplaceAll: ':' with: '-'.! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
selectAllUnitTests
	classesSelected := classes asSet select: [ :eachClass | eachClass isUnitTest ].
	self
		changed: #allSelections;
		changed: #classSelected;
		changed: #hasRunnable! !

!TestRunner methodsFor: 'building' stamp: ''!
build
	"self new build openInWorld"
	
	| window |
	window := (SystemWindow labelled: self label) model: self; extent: self extent.
	
	window addMorph: self buildPackageSearch fullFrame: self packageSearchFrame.
	window addMorph: self buildPackages fullFrame: self packagesFrame.
	
	window addMorph: self buildClassesSearch fullFrame: self classesSearchFrame.
	window addMorph: self buildClasses fullFrame: self classesFrame.
	
	window	addMorph: self buildStatus fullFrame: self statusFrame. 
	window	addMorph: self buildFailures fullFrame: self failureListFrame. 
	window	addMorph: self buildErrors fullFrame: self errorListFrame. 
	window	addMorph: self buildButtons fullFrame: self buttonsFrame. 
	^ window
	
	
	! !

!TestRunner methodsFor: 'accessing - packages' stamp: ''!
selectInversePackages
	packagesSelected := packages asSet 
		removeAll: packagesSelected;
		yourself.
	self changed: #allSelections; changed: #packageSelected; updateClasses! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
classMenu: aMenu
	^ aMenu
		addTitle: 'Classes';
		add: 'Browse' selector: #browseClass;
		addLine;
		add: 'Select all' selector: #selectAllClasses;
		add: 'Select unit tests' selector: #selectAllUnitTests;
		add: 'Select subclasses' selector: #selectSubclasses;
		add: 'Select inversion' selector: #selectInverseClasses;
		add: 'Select none' selector: #selectNoClasses;
		add: 'Refresh' selector: #updateClasses;
		addLine;
		add: 'Filter...' selector: #filterClasses;
		addLine;
		add: 'Run selected' selector: #runAll;
		yourself.! !

!TestRunner methodsFor: 'building' stamp: ''!
packageSearchUpdate: aPattern
	packagePattern := (aPattern isNil or: [ aPattern trimBoth isEmpty ])
		ifTrue: [ nil ]
		ifFalse: [ [aPattern asRegexIgnoringCase] on: RegexSyntaxError do: [ nil ] ].
	self updatePackages.! !

!TestRunner methodsFor: 'history saving' stamp: ''!
storeResultIntoTestCases

	result classesTested do: [:testCaseCls | testCaseCls generateLastStoredRunMethod ]
! !

!TestRunner methodsFor: 'factory' stamp: ''!
baseClass
	^ TestCase! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
selectNoClasses
	"Fixed to update all selections now that the
	selection invalidation has been optimised."
	
	classesSelected := Set new.
	self
		changed: #allSelections;
		changed: #classSelected;
		changed: #hasRunnable! !

!TestRunner methodsFor: 'actions' stamp: ''!
excludeClassesNotUnderTestFrom: methods
	classesSelected
		do: [ :class | 
			(class class includesSelector: #classNamesNotUnderTest)
				ifTrue: [ 
					class classNamesNotUnderTest
						do: [ :className | 
							| theClass |
							theClass := Smalltalk globals classNamed: className.
							theClass
								ifNotNil: [ 
									theClass methods do: [ :each | methods remove: each  ifAbsent: [  ] ].
									theClass class methods do: [ :each | methods remove: each  ifAbsent: [  ] ] ] ] ] ]! !

!TestRunner methodsFor: 'accessing - packages' stamp: ''!
selectAllPackages
	packagesSelected := packages asSet.
	self changed: #allSelections; changed: #packageSelected; updateClasses! !

!TestRunner methodsFor: 'private' stamp: ''!
browserEnvironment
	^ Smalltalk globals classNamed: #BrowserEnvironment! !

!TestRunner methodsFor: 'accessing - packages' stamp: ''!
packageAt: anInteger put: aBoolean
	packagesSelected := packagesSelected
		perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ])
		with: (packages at: anInteger ifAbsent: [ ^ self ]).
	self changed: #packageSelected; updateClasses.! !

!TestRunner methodsFor: 'actions' stamp: ''!
collectCoverageFor: methods
	| suite link notExecuted |
	suite := self
		resetResult;
		suiteForAllSelected.
	
	link := MetaLink new
		selector: #tagExecuted;
		metaObject: #node.
	
	[ methods do: [ :meth | meth ast link: link].
	[ self runSuite: suite ] ensure: [ link uninstall ] ] valueUnpreemptively.

	notExecuted := methods reject: [:each | each ast hasBeenExecuted].
	notExecuted isEmpty 
		ifTrue:  [ UIManager default inform: 'Congratulations. Your tests cover all code under analysis.' ]
		ifFalse: [ 
			Smalltalk tools messageList 
				browse: notExecuted
				title: 'Not Covered Code (' , (100 - (100 * notExecuted size // methods size)) printString , '% Code Coverage)'].
	
	"cleanup the annotations"
	methods do: [ :each | each ast removeProperty: #tagExecuted ifAbsent: [ ] ].
	
	self saveResultInHistory! !

!TestRunner methodsFor: 'building' stamp: ''!
errorListFrame
	^LayoutFrame new
		leftFraction: 0.5;
		topFraction: 0.5;
		bottomOffset: self buttonHeight negated! !

!TestRunner methodsFor: 'private' stamp: ''!
label: aString forSuite: aTestSuite
	^ String streamContents: [ :stream |
		stream nextPutAll: 'Running '; print: aTestSuite tests size; space; nextPutAll: aString.
		aTestSuite tests size > 1 ifTrue: [ stream nextPut: $s ] ]. ! !

!TestRunner methodsFor: 'processing' stamp: ''!
executeSuite: aTestSuite as: aBlock
" The block defines how to interact with the suite. run with a result or debug "
	aTestSuite when:TestAnnouncement do: self updateUIBlock.
	[ aBlock cull: aTestSuite cull: result  ] ensure: [
		aTestSuite unsubscribe:TestAnnouncement.
	].


! !

!TestRunner methodsFor: 'building' stamp: ''!
buildErrors
	^ PluggableListMorph new
			on: self 
			list: #errorList
			selected: #errorSelected
			changeSelected: #errorSelected:
			menu: #errorMenu: 
			keystroke: nil.
	! !

!TestRunner methodsFor: 'browsing' stamp: ''!
browseSelectedFailedTest

	failedSelected ifNil: [^self].
	self browseSelectedTest: failedSelected! !

!TestRunner methodsFor: 'newbuilding' stamp: ''!
buildStatus

	^ (RubPluggableTextMorph
		on: self 
		text: #statusText 
		accept: nil 
		readSelection: nil 
		menu: #statusMenu:)
			beReadOnly;
			beWrapped;
			textColor: self theme textColorForNonStandardBackground;
			getColorSelector: #statusColor ; 
			yourself.
	! !

!TestRunner methodsFor: 'history saving' stamp: ''!
historyMenuList
	^ {'** save current result **'}, (self previousRun collect: [:ts | ts printString])! !

!TestRunner methodsFor: 'testing' stamp: ''!
hasErrors
	^ result hasErrors.! !

!TestRunner methodsFor: 'accessing' stamp: ''!
suiteForAllSelected
	"Return the suite for all the selected test case classes"

	^ self classForTestSuite new
		in: [ :suite | 
			classesSelected
				do: [ :each | 
					each isAbstract
						ifFalse: [ each addToSuiteFromSelectors: suite ] ].
			suite name: (self label: 'Test' forSuite: suite) ]! !

!TestRunner methodsFor: 'accessing - testing' stamp: ''!
failedSelected: anInteger
	failedSelected := failedList at: anInteger ifAbsent: nil.
	self changed: #failedSelected.
	failedSelected ifNotNil: [ self debug: failedSelected ].! !

!TestRunner methodsFor: 'accessing - packages' stamp: ''!
filterPackages

	| pattern |

	pattern := UIManager default request: 'Pattern to select package:' initialAnswer: '*'.
	pattern ifNil: [ ^ self ].
	packagesSelected := ( packages select: [ :each | pattern match: each ] ) asSet.
	self
		changed: #allSelections;
		changed: #packageSelected;
		updateClasses! !

!TestRunner methodsFor: 'history saving' stamp: ''!
hasResults

	^ result notNil! !

!TestRunner methodsFor: 'building' stamp: ''!
buttonHeight
	^ self theme buttonMinHeight + 4! !

!TestRunner methodsFor: 'updating' stamp: ''!
updateUIBlock
	^ testAnnouncementBlock ifNil: [
		testAnnouncementBlock :=  [ :announcement | self updateStatus: true ] ].! !

!TestRunner methodsFor: 'accessing - testing' stamp: ''!
statusColor
	result hasErrors 
		ifTrue: [ ^ self theme dangerBackgroundColor ].
	result hasFailures 
		ifTrue: [ ^ self theme warningBackgroundColor ].
	^ self theme successBackgroundColor! !

!TestRunner methodsFor: 'actions' stamp: ''!
runTest: aTestCase
	aTestCase run: result.
	self updateStatus: true.! !

!TestRunner methodsFor: 'history saving' stamp: ''!
showDiffWith: aTestResult
	| string diff |

	diff := result diff: aTestResult.
	string := String streamContents: [:str|
		str nextPutAll: '----------------'; cr.
		str nextPutAll: 'Diff between current result with: ', aTestResult asString; cr.
		str nextPutAll: 'New passed: '.
		diff first do: [:s| str nextPutAll: s printString, ' '].
		str cr.
		str nextPutAll: 'New failures: '.
		diff second do: [:s| str nextPutAll: s printString, ' '].
		str cr.
		
		str nextPutAll: 'New errors: '.
		diff third do: [:s| str nextPutAll: s printString, ' '].
		str cr].
	
	UIManager default edit: string label: 'SUnit Progress'. 
	! !

!TestRunner methodsFor: 'updating' stamp: ''!
updateClasses

	| classesForCategories |

	classesForCategories := self findClassesForPackages: packagesSelected.

	classPattern
		ifNotNil: [ classesForCategories := classesForCategories
				reject: [ :cls | ( classPattern matchesIn: cls name ) isEmpty ]
			].

	classes := classesForCategories asArray sort: [ :a :b | self sortClass: a before: b ].
	classIndex := 0.
	classesSelected := classesSelected
		ifNil: [ classesForCategories ]
		ifNotNil: [ classesSelected select: [ :each | classesForCategories includes: each ] ].
	self
		changed: #classList;
		changed: #classSelected;
		changed: #hasRunnable! !

!TestRunner methodsFor: 'accessing - ui' stamp: ''!
label
	^ 'Test Runner' ! !

!TestRunner methodsFor: 'building' stamp: ''!
packageSearchFrame
	^LayoutFrame new
		rightFraction: 0.25;
		bottomFraction: 0 offset: (self theme textFont height + 6)! !

!TestRunner methodsFor: 'accessing - menu' stamp: ''!
errorMenu: aMenu
	"Add the browse item only if an item is selected"

	self statusMenu: aMenu.
	errorSelected ifNotNil: [aMenu add: 'Browse test' selector: #browseSelectedErrorTest].
	^aMenu! !

!TestRunner methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	failedList := errorList := Array new.
	SystemAnnouncer uniqueInstance weak
		when: ClassAdded, CategoryAdded, ClassRemoved, CategoryRemoved, ClassRenamed, CategoryRenamed, ClassRecategorized 
			send: #update 
			to: self.
	self update; resetResult! !

!TestRunner methodsFor: 'updating' stamp: ''!
updateStatus: aBoolean
	"Update the status display, at most once a second if aBoolean is true."

	(aBoolean and: [ lastUpdate = Time totalSeconds ])
		ifTrue: [ ^ self ].
	self changed: #statusText; changed: #statusColor.
	lastUpdate := Time totalSeconds.! !

!TestRunner methodsFor: 'accessing' stamp: ''!
errorTestSuites
	^ errorList
		collect: [ :each | 
			self classForTestSuite new
				in: [ :suite | 
							suite
								addTest: each;
								name: (self label: 'Error' forSuite: suite) ];
				yourself ]! !

!TestRunner methodsFor: 'building' stamp: ''!
failureListFrame
	^LayoutFrame new
		leftFraction: 0.5;
		bottomFraction: 0.5;
		topOffset: self statusHeight! !

!TestRunner methodsFor: 'browsing' stamp: ''!
browseSelectedTest: aTest
	(aTest class lookupSelector: aTest selector) browse
! !

!TestRunner methodsFor: 'actions' stamp: ''!
resetResult

	self result: TestAsserter classForTestResult new ; updateResults.! !

!TestRunner methodsFor: 'utilities' stamp: ''!
findPackages
	| visible |
	visible := Set new.
	self baseClass withAllSubclassesDo: [ :each |
		each category ifNotNil: [ :category |
			visible add: category ] ].
	^ Array streamContents: [ :stream |
		Smalltalk organization categories do: [ :each |
			((visible includes: each) 
					and: [ packagePattern isNil or: [ (packagePattern matchesIn: each) isNotEmpty]])
				ifTrue: [ stream nextPut: each ] ] ].! !

!TestRunner methodsFor: 'updating' stamp: ''!
updatePackages

	packages := self findPackages.
	packageIndex := 0.
	packagesSelected := packagesSelected
		ifNil: [ Set new ]
		ifNotNil: [ packagesSelected select: [ :each | packages includes: each ] ].
	self
		changed: #packageList;
		changed: #packageSelected! !

!TestRunner methodsFor: 'building' stamp: ''!
buildFailures
	^ PluggableListMorph new
			on: self 
			list: #failedList
			selected: #failedSelected
			changeSelected: #failedSelected:
			menu: #failureMenu: 
			keystroke: nil.
	
		" do not know how to express
		name: 'Failure List'"! !

!TestRunner methodsFor: 'actions' stamp: ''!
runAll

	self resetResult.
	self runTestSuites: self allSelectedTestSuites.
	self saveResultInHistory! !

!TestRunner methodsFor: 'actions' stamp: ''!
runSuite: aTestSuite
	self executeSuite: aTestSuite as: [ :aSuite :aResult | aSuite run: aResult ].
	self updateResults

! !

!TestRunner methodsFor: 'building' stamp: ''!
buildClassesSearch
	
	^ SearchMorph new
		model: self;
		updateSelector: #classSearchUpdate:;
		ghostText: 'TestCase #1 | TestCase #2';
		yourself! !

!TestRunner methodsFor: 'accessing - testing' stamp: ''!
failedSelected
	^ failedList indexOf: failedSelected.! !

!TestRunner methodsFor: 'building' stamp: ''!
packagesFrame
	^LayoutFrame new
		rightFraction: 0.25;
		topOffset: (self theme textFont height + 13);
		bottomOffset: self buttonHeight negated! !

!TestRunner methodsFor: 'accessing - packages' stamp: ''!
packageList
	^ packages! !

!TestRunner methodsFor: 'updating' stamp: ''!
update
	self updatePackages; updateClasses! !

!TestRunner methodsFor: 'accessing - testing' stamp: ''!
result
	^ result! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
classList
	| offset |
	classes isEmpty ifTrue: [ ^ classes ].
	offset := classes first allSuperclasses size.
	^ classes collect: [ :each | | ident |
		ident := String 
			new: 2 * (0 max: each allSuperclasses size - offset) 
			withAll: $ .
		each isAbstract
			ifFalse: [ ident , each name ]
			ifTrue: [ 
				ident asText , each name asText 
					addAttribute: TextEmphasis italic;
					yourself ] ].! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
selectInverseClasses
	"Fixed to update all selections now that the
	selection invalidation has been optimised."
	
	classesSelected := classes asSet 
		removeAll: classesSelected;
		yourself.
	self
		changed: #allSelections;
		changed: #classSelected;
		changed: #hasRunnable! !

!TestRunner methodsFor: 'accessing - packages' stamp: ''!
selectNoPackages
	packagesSelected := Set new.
	self changed: #allSelections; changed: #packageSelected; updateClasses! !

!TestRunner methodsFor: 'building' stamp: ''!
statusFrame
	^ LayoutFrame new
		leftFraction: 0.5;
		bottomFraction: 0 offset: self statusHeight! !

!TestRunner methodsFor: 'actions' stamp: ''!
runCoverage
	| myPackages methods |
	myPackages := Set new.
	self addDeclaredPackagesUnderTestTo: myPackages.
	myPackages isEmpty ifTrue: 
		[ myPackages := self promptForPackages ].
	methods := OrderedCollection new.
	self 
		addMethodsUnderTestIn: myPackages
		to: methods.
	self excludeClassesNotUnderTestFrom: methods.
	methods isEmpty ifTrue: 
		[ ^ UIManager default inform: 'No methods found for coverage analysis.' ].
	self collectCoverageFor: methods
! !

!TestRunner methodsFor: 'testing' stamp: ''!
hasRunnable
	^ classesSelected notEmpty.! !

!TestRunner methodsFor: 'building' stamp: ''!
buildButtons
	^ PanelMorph new
		changeTableLayout;
		listDirection: #leftToRight;
		layoutInset: 0;
		color: Color transparent;
		addAllMorphs: (self buttons collect: [ :each |
			PluggableButtonMorph new
				on: self
				getState: nil
				action: each second
				label: nil
				menu: nil;
				label: each first;
				setBalloonText: each third;
				getEnabledSelector: (each at: 4);
				hResizing: #spaceFill;
				yourself ]);
		yourself.! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
classSelected
	^ classIndex! !

!TestRunner methodsFor: 'building' stamp: ''!
classesFrame
	^LayoutFrame new
		leftFraction: 0.25;
		topOffset: (self theme textFont height + 13);
		rightFraction: 0.5;
		bottomOffset: self buttonHeight negated! !

!TestRunner methodsFor: 'building' stamp: ''!
classesSearchFrame
	^LayoutFrame new
		leftFraction: 0.25;
		rightFraction: 0.5;
		bottomFraction: 0 ;
		bottomOffset: (StandardFonts defaultFont height + 6)! !

!TestRunner methodsFor: 'building' stamp: ''!
buildClasses

	^ PluggableListMorph new
		on: self
		list: #classList 
		primarySelection: #classSelected 
		changePrimarySelection: #classSelected: 
		listSelection: #classAt: 
		changeListSelection: #classAt:put: 
		menu: #classMenu:  
		keystroke: nil;
		yourself! !

!TestRunner methodsFor: 'actions' stamp: ''!
runProfiled
	MessageTally spyOn: [ self runAll ].! !

!TestRunner methodsFor: 'history saving' stamp: ''!
showProgress
	| testCaseClasses d string |
	testCaseClasses := (self suiteForAllSelected tests collect: [:testCase | testCase class]) asSet.
	
	"At the end of the algorithm, d will contains all the diff between what was saved and the current result"
	d := Dictionary new.
	d at: #passed put: OrderedCollection new.
	d at: #failures put: OrderedCollection new.
	d at: #errors put: OrderedCollection new.

	testCaseClasses do: [ :cls | | t |
		(cls class includesSelector: #lastStoredRun)
			ifTrue: [t := cls lastStoredRun.
					(t at: #passed) do: [:s | 	
											(result isErrorFor: cls selector: s)
												ifTrue: [(d at: #errors) add: {cls . s}].
											(result isFailureFor: cls selector: s)
												ifTrue: [(d at: #failures) add: {cls . s}]  ].
											
					(t at: #failures) do: [:s | (result isPassedFor: cls selector: s)
												ifTrue: [(d at: #passed) add: {cls . s}].
											(result isErrorFor: cls selector: s)
												ifTrue: [(d at: #errors) add: {cls . s}]].
											
					(t at: #errors) do: [:s | 	(result isPassedFor: cls selector: s)
												ifTrue: [(d at: #passed) add: {cls . s}].
											(result isFailureFor: cls selector: s)
												ifTrue: [(d at: #failures) add: {cls . s}]]]].
		
			
	string := String streamContents: [:str|
		str nextPutAll: '----------------'; cr.
		str nextPutAll: 'Diff between current result and saved result'; cr.
		str nextPutAll: 'New passed: '.
		(d at: #passed) do: [:s| str nextPutAll: s printString, ' '].
		str cr.
		str nextPutAll: 'New failures: '.
		(d at: #failures) do: [:s| str nextPutAll: s printString, ' '].
		str cr.
		
		str nextPutAll: 'New errors: '.
		(d at: #errors) do: [:s| str nextPutAll: s printString, ' '].
		str cr].
	
	UIManager default edit: string label: 'SUnit Progress'. 

	! !

!TestRunner methodsFor: 'actions' stamp: ''!
runFailures
	self result failures: Set new.
	self runTestSuites: self failureTestSuites! !

!TestRunner methodsFor: 'history saving' stamp: ''!
showHistoryMenu
	| selectionIndex selectedPreviousResult actionIndex |
	selectionIndex := UIManager default chooseFrom: self historyMenuList title: 'History:'.

	"We pressed outside the menu"
	selectionIndex isZero ifTrue: [ ^ self ]. 				

	"save current result is selected"
	selectionIndex = 1 ifTrue: [ self previousRun addFirst: result. ^ self ]. 			

	selectedPreviousResult := self previousRun at: (selectionIndex - 1).
 	actionIndex := (UIManager default chooseFrom: #('delete' 'show diff')  title:  'Action:').
	actionIndex = 1 ifTrue: [ self previousRun remove: selectedPreviousResult. ^ self ].
	actionIndex = 2 ifTrue: [ self showDiffWith: selectedPreviousResult].	! !

!TestRunner methodsFor: 'accessing - testing' stamp: ''!
statusText
	^ result printString.! !

!TestRunner methodsFor: 'updating' stamp: ''!
updateResults
	"<lint: #expect rule: #guardingClause>"
	"<lint: #expect rule: #longMethods>"

	self updateStatus: false.
	failedList size = result failures size ifFalse: [
		failedList := result failures asArray
			sort: [ :a :b | a printString <= b printString ].
		failedSelected := nil.
		self 
			changed: #failedList; 
			changed: #failedSelected;
			changed: #hasFailures;
			changed: #hasProgress;
			changed: #hasFailuresOrErrors  ].
	errorList size = result errors size ifFalse: [
		errorList := result errors asArray
			sort: [ :a :b | a printString <= b printString ].
		errorSelected := nil.
		self 
			changed: #errorList; 
			changed: #errorSelected;
			changed: #hasErrors;
			changed: #hasProgress;
			changed: #hasFailuresOrErrors  ].! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
browseClass
	| targetClasses |
	targetClasses := classesSelected asArray.
	targetClasses ifEmpty: [ ^ self ].
	targetClasses size > 1
		ifTrue: [ (UIManager default
				confirm: 'Do you want to open all ' , targetClasses size printString , ' classes?')
				ifTrue: [ targetClasses do: #browse ].
			^ self ].
	targetClasses anyOne browse! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
classAt: anInteger put: aBoolean
	classesSelected := classesSelected
		perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ])
		with: (classes at: anInteger ifAbsent: [ ^ self ]).
	self changed: #classSelected; changed: #hasRunnable.! !

!TestRunner methodsFor: 'actions' stamp: ''!
debugSuite: aTestSuite
	self executeSuite: aTestSuite as: [ :aSuite | aSuite debug ].! !

!TestRunner methodsFor: 'testing' stamp: ''!
hasFailuresOrErrors
	^ result hasFailures | result hasErrors.! !

!TestRunner methodsFor: 'utilities' stamp: ''!
sortClass: aFirstClass before: aSecondClass
	| first second |
	first := aFirstClass withAllSuperclasses reversed.
	second := aSecondClass withAllSuperclasses reversed.
	1 to: (first size min: second size) do: [ :index | 
		(first at: index) == (second at: index)
			ifFalse: [ ^ (first at: index) name <= (second at: index) name ] ].
	^ second includes: aFirstClass.! !

!TestRunner methodsFor: 'actions' stamp: ''!
promptForPackages
	| choosenpackages |
	choosenpackages := (RPackageOrganizer default packages
				reject: [:package | (package packageName beginsWith: 'Kernel')
						or: [(package packageName beginsWith: 'Collections')
								or: [(package packageName beginsWith: 'Exceptions')
										or: [(package packageName beginsWith: 'SUnit')
												or: [(package packageName beginsWith: 'System') ]]]]])
				sort: [:a :b | a packageName < b packageName].
	choosenpackages := Array
				with: (UIManager default
						chooseFrom: (choosenpackages
								collect: [:package | package packageName])
						values: choosenpackages
						title: 'Select Package').
	^ choosenpackages! !

!TestRunner methodsFor: 'actions' stamp: ''!
fileOutResults
	"Save current test results into text file."
	"Generate a filename like 'tests_Version_23_May_2010_9-19-20_am.txt' "

	| fileName defaultFilename stream |
	defaultFilename := self generateDefaultFileOutResultsName.
						
						
	fileName := UIManager default 
		request: 'Enter the file name' 
		initialAnswer: defaultFilename.
	fileName ifNil: [^ self].
	stream := ZnNewLineWriterStream on: (ZnCharacterWriteStream
			on: (File openForWriteFileNamed: fileName)
			encoding: 'utf8').
	[result fileOutOn: stream]
		ensure: [stream close].! !

!TestRunner methodsFor: 'accessing - menu' stamp: ''!
statusMenu: aMenu
	^ aMenu 
		defaultTarget: self;
		add: 'History' selector: #showHistoryMenu;
		add: 'Store result as progress reference' selector: #storeResultIntoTestCases;
		add: 'Show progress' selector: #showProgress; 
		yourself! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
selectAllClasses
	"Fixed to update all selections now that the
	selection invalidation has been optimised."
	
	classesSelected := classes asSet.
	self
		changed: #allSelections;
		changed: #classSelected;
		changed: #hasRunnable! !

!TestRunner methodsFor: 'actions' stamp: ''!
runErrors
	self result errors: OrderedCollection new.
	self runTestSuites: self errorTestSuites.! !

!TestRunner methodsFor: 'actions' stamp: ''!
addMethodsUnderTestIn: listOfPackages to: methods 
	listOfPackages
		reject: #isNil
		thenDo: [:package | 
			package methods
				reject: [ :method | (#(#packageNamesUnderTest #classNamesNotUnderTest ) includes: method selector)
												or: [ method  isAbstract
													or: [ (method  refersToLiteral: #ignoreForCoverage)
														or: [ method methodClass isTestCase ] ] ] ]
				thenDo: [:method | methods add: method ] ]! !

!TestRunner methodsFor: 'accessing' stamp: ''!
failureTestSuites
	^ failedList
		collect: [ :each | 
			self classForTestSuite new
				in: [ :suite | 
							suite
								addTest: each;
								name: (self label: 'Failure' forSuite: suite) ];
				yourself ]! !

!TestRunner methodsFor: 'building' stamp: ''!
statusHeight
	^ self theme textFont height * 3! !

!TestRunner methodsFor: 'accessing - classes' stamp: ''!
selectSubclasses
	"Fixed to update all selections now that the
	selection invalidation has been optimised."
	
	| classesForPackages |
	classesForPackages := self findClassesForPackages: packagesSelected.	
	classesSelected := (classesSelected flatCollect: [ :class |
		class withAllSubclasses select: [ :each |
			classesForPackages includes: each ] ])
		asSet.
	self
		changed: #allSelections;
		changed: #classSelected;
		changed: #hasRunnable! !

!TestRunner class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#testRunnerIcon! !

!TestRunner class methodsFor: 'instance creation' stamp: ''!
open
	<script>
	
	^ self new open! !

!TestRunner class methodsFor: 'initialization' stamp: ''!
registerToolsOn: registry

	"Add ourselves to registry. See [Smalltalk tools]" 
	registry register: self as: #testRunner! !

!TestRunner class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	
	(aBuilder item: #'Test Runner')
		parent: #Testing;
		action: [ Smalltalk tools openTestRunner ];
		order: 1;
		keyText: 'o, u';
		help: 'Let you run and debug SUnit tests.';
		icon: self taskbarIcon! !

!TestServiceExample commentStamp: ''!
I am an example of TestExecutionService created for tests.
I am not enabled by default. So I am not really shown to users.

I simply log in variables everything requested from me by test environment.
 
Internal Representation and Key Implementation Points.

    Instance Variables
	forkedProcesses:		<OrderedCollection<Process>>
	isCleanUpDone:		<Boolean>
	isCompletedTestHandled:		<Boolean>
	signaledExceptions:		<OrderedCollection<Exception>>
!
!TestServiceExample methodsFor: 'accessing' stamp: ''!
forkedProcesses
	^ forkedProcesses! !

!TestServiceExample methodsFor: 'controlling' stamp: ''!
handleException: anUnhandledException
	super handleException: anUnhandledException.
	
	signaledExceptions add: anUnhandledException ! !

!TestServiceExample methodsFor: 'controlling' stamp: ''!
handleCompletedTest
	super handleCompletedTest.
	
	isCompletedTestHandled := true! !

!TestServiceExample methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	
	forkedProcesses := OrderedCollection new.
	signaledExceptions := OrderedCollection new.
	isCleanUpDone := false.
	isCompletedTestHandled := false! !

!TestServiceExample methodsFor: 'accessing' stamp: ''!
signaledExceptions
	^ signaledExceptions! !

!TestServiceExample methodsFor: 'controlling' stamp: ''!
cleanUpAfterTest
	super cleanUpAfterTest.
	
	isCleanUpDone := true! !

!TestServiceExample methodsFor: 'controlling' stamp: ''!
handleNewProcess: aProcess
	super handleNewProcess: aProcess.
	
	forkedProcesses add: aProcess! !

!TestServiceExample methodsFor: 'accessing' stamp: ''!
isCleanUpDone
	^ isCleanUpDone! !

!TestServiceExample methodsFor: 'accessing' stamp: ''!
isCompletedTestHandled
	^ isCompletedTestHandled! !

!TestServiceExample class methodsFor: 'testing' stamp: ''!
isEnabledByDefault
	^false! !

!TestSessionHandler commentStamp: ''!
I'm a session handler used for tests purposes.
You can provide me blocks to be executed at startup or shutdown.!
!TestSessionHandler methodsFor: 'handlers' stamp: ''!
startup: isImageStarting
	startupHandler value! !

!TestSessionHandler methodsFor: 'handlers' stamp: ''!
shutdown: isImageQuitting
	shutdownHandler value! !

!TestSessionHandler methodsFor: 'printing' stamp: ''!
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! !

!TestSessionHandler methodsFor: 'accessing' stamp: ''!
startupHandler: aBlockClosure
	startupHandler := aBlockClosure! !

!TestSessionHandler methodsFor: 'accessing' stamp: ''!
handledId
	^ 'testSessionHandler'! !

!TestSessionHandler methodsFor: 'accessing' stamp: ''!
shutdownHandler: aBlockClosure
	shutdownHandler := aBlockClosure! !

!TestSessionHandler class methodsFor: 'instance creation' stamp: ''!
onShutdown: aBlockClosure 
	
	^ self new
		shutdownHandler: aBlockClosure;
		yourself! !

!TestSessionHandler class methodsFor: 'instance creation' stamp: ''!
onStartup: aBlockClosure 
	
	^ self new
		startupHandler: aBlockClosure;
		yourself! !

!TestSharedPool commentStamp: ''!
I am a shared pool used for testing.!
!TestSharedPool class methodsFor: 'class initialization' stamp: ''!
initialize
	One := 1! !

!TestSkipped commentStamp: ''!
I mark a test as being skipped.!
!TestSkipped methodsFor: 'handling' stamp: ''!
defaultAction
	"Nothing to do. If I am not handled I might trigger an Assertion failure later on."! !

!TestSkipped methodsFor: '*JenkinsTools-Core' stamp: ''!
recordResultOf: aTestCase inHDTestReport: aHDTestReport

	aHDTestReport recordSkip: self duringTest: aTestCase! !

!TestSkipped methodsFor: 'handling' stamp: ''!
manageTestProcessBy: aProcessMonitorTestService
	"It is special exception which do not represent the actual test failure.
	 So we just ignoring it"! !

!TestSkipped methodsFor: 'handling' stamp: ''!
sunitAnnounce: aTestCase toResult: aTestResult

	aTestResult addSkip: aTestCase! !

!TestStartupUIManager commentStamp: ''!
I'm an startup UI manager used for test purposes.
I provide a way to not use the default session manager.
!
!TestStartupUIManager methodsFor: 'accessing' stamp: ''!
sessionManager: aSessionManager
	sessionManager := aSessionManager! !

!TestStartupUIManager methodsFor: 'accessing' stamp: ''!
sessionManager
	^ sessionManager! !

!TestSuite commentStamp: ''!
I'm a Composite of tests, either `TestCase`s or other `TestSuite`s. The top-level protocol is `#run`. This creates a`TestResult` and sends `self run: aTestResult`.
Then ensures that any `TestResource`s made available during the run are reset.  These, and the dependencies protocol, are common between `TestSuite` and `TestCase`.

### Implementation
While I implement a composite I do not inherit from a common superclass such as we could expect. 
It is just like that. Newer versions of the frameworks may want to introduce a more conventional design. 
!
!TestSuite methodsFor: 'dependencies' stamp: ''!
removeDependentFromHierachy: anObject
	self removeDependent: anObject.
	self tests do: [ :each | each removeDependentFromHierachy: anObject]
			! !

!TestSuite methodsFor: 'running' stamp: ''!
setUp
	self resources do: [:each |
			each isAvailable ifFalse: [ each signalInitializationError ]].! !

!TestSuite methodsFor: 'dependencies' stamp: ''!
addDependentToHierachy: anObject
	self addDependent: anObject.
	self tests do: [ :each | each addDependentToHierachy: anObject]
			! !

!TestSuite methodsFor: 'accessing' stamp: ''!
addTests: aCollection 
	aCollection do: [:eachTest | self addTest: eachTest]! !

!TestSuite methodsFor: 'announcements' stamp: ''!
announceTest: aTest
	^ self testSuiteAnnouncer announce: (TestAnnouncement with: aTest).! !

!TestSuite methodsFor: 'running' stamp: ''!
tearDown
	self resourceClass resetResources: self resources.! !

!TestSuite methodsFor: 'running' stamp: ''!
resultClass

	^ TestAsserter classForTestResult! !

!TestSuite methodsFor: 'running' stamp: ''!
resourceClass

	^ TestResource! !

!TestSuite methodsFor: 'accessing' stamp: ''!
resources: someOrderedTestResourceClasses
	"The parameter should understand reverseDo: and should not contain duplicates."

	resources := someOrderedTestResourceClasses! !

!TestSuite methodsFor: 'accessing' stamp: ''!
addTest: aTest
	self tests add: aTest ! !

!TestSuite methodsFor: 'announcements' stamp: ''!
unsubscribe: anAnnouncementClass 
	self testSuiteAnnouncer unsubscribe: anAnnouncementClass.! !

!TestSuite methodsFor: 'announcements' stamp: ''!
when: aAnnouncement do: aBlock
	self testSuiteAnnouncer when: aAnnouncement do: aBlock! !

!TestSuite methodsFor: 'running' stamp: ''!
debug
	self setUp.
	[
		self tests do: [:each | 
					each debug.
					self announceTest: each.
					self changed: each.
		]
	] ensure:[ 
		self tearDown. 
	].

! !

!TestSuite methodsFor: 'accessing' stamp: ''!
defaultResources
	^self tests
		inject: OrderedCollection new
		into:
			[:coll :testCase |
			testCase resources do:
				[:each |
				(coll includes: each) ifFalse: [coll add: each]].
			coll]! !

!TestSuite methodsFor: 'accessing' stamp: ''!
name

	^name! !

!TestSuite methodsFor: 'composing' stamp: ''!
, aTestSuite 

		^ TestSuite new
			addTests: self tests;
			addTests: aTestSuite tests;
			yourself! !

!TestSuite methodsFor: 'accessing' stamp: ''!
name: aString

	name := aString! !

!TestSuite methodsFor: 'running' stamp: ''!
run
	| result |
	result := self resultClass new.
	self run: result.
	^result! !

!TestSuite methodsFor: 'announcements' stamp: ''!
testSuiteAnnouncer
	^ announcer ifNil: [ announcer := Announcer new. ]! !

!TestSuite methodsFor: 'accessing' stamp: ''!
resources

	^ resources ifNil: [ resources := self defaultResources ]! !

!TestSuite methodsFor: 'running' stamp: ''!
runUnmanaged: aResult
	self setUp.
	[ self tests
		do: [ :each | 
			each run: aResult.
			self announceTest: each.
			self changed: each ] ]
		ensure: [ self tearDown ]! !

!TestSuite methodsFor: 'accessing' stamp: ''!
tests

	^ tests ifNil: [ tests := OrderedCollection new ]! !

!TestSuite methodsFor: '*SUnit-Visitor' stamp: ''!
acceptSUnitVisitor: aTSUnitVisitor
	^ aTSUnitVisitor visitTestSuite: self! !

!TestSuite methodsFor: 'running' stamp: ''!
run: aResult
	CurrentExecutionEnvironment runTestsBy: [
		self runUnmanaged: aResult ]! !

!TestSuite class methodsFor: 'instance creation' stamp: ''!
named: aString

	^self new
		name: aString;
		yourself! !

!TestSuiteEnded commentStamp: ''!
This announcement is thrown when a test suite just finished (more precisely when hisoties are updated)!
!TestSuiteEnded class methodsFor: 'instance creation' stamp: ''!
result: aResult

	^ self new
		  testResult: aResult;
		  yourself! !

!TestTookTooMuchTime commentStamp: ''!
I am special error to signal that test exceed time limit.

TestCase subclass can reimplement defaultTimeLimit in its class side to specify another duration.!
!TestWorkingSession commentStamp: ''!
I'm a special working session for test purposes.
I provide a way to escape from the UIManager. !
!TestWorkingSession methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	errors := OrderedCollection new! !

!TestWorkingSession methodsFor: 'accessing' stamp: ''!
errorHandler: anErrorHandler
	errorHandler := anErrorHandler! !

!TestWorkingSession methodsFor: 'deferred startup actions' stamp: ''!
executeDeferredStartupActions: isImageStarting
	"do nothing"! !

!TestWorkingSession methodsFor: 'startup - shutdown' stamp: ''!
start: isImageStarting
	"do not modify vm parameters, external objects"
	self runStartup: isImageStarting.! !

!TestWorkingSession methodsFor: 'error handling' stamp: ''!
handleError: anError
	errors add: anError! !

!TestWorkingSession methodsFor: 'accessing' stamp: ''!
errorHandler
	^ errorHandler ifNil: [ self ]! !

!TestWorkingSession methodsFor: 'accessing' stamp: ''!
errors
	^ errors! !

!Text commentStamp: ''!
I represent a character string that has been marked with abstract changes in character appearance. Actual display is performed in the presence of a TextStyle which indicates, for each abstract code, an actual font to be used.  A Text associates a set of TextAttributes with each character in its character string.  These attributes may be font numbers, emphases such as bold or italic, or hyperling actions.  Font numbers are interpreted relative to whatever textStyle appears, along with the text, in a Paragraph.  Since most characters have the same attributes as their neighbors, the attributes are stored in a RunArray for efficiency.  Each of my instances has
	string		a String
	runs		a RunArray!
!Text methodsFor: 'emphasis' stamp: ''!
attributesAt: characterIndex do: aBlock
	"Answer the code for characters in the run beginning at characterIndex."
	"NB: no senders any more (supplanted by #attributesAt:forStyle: but retained for the moment in order not to break user code that may exist somewhere that still calls this"
	self size = 0 ifTrue:[^self].
	(runs at: characterIndex) do: aBlock! !

!Text methodsFor: 'emphasis' stamp: ''!
allBold 
	"Force this whole text to be bold."
	string size = 0 ifTrue: [^self].
	self makeBoldFrom: 1 to: string size! !

!Text methodsFor: 'emphasis' stamp: ''!
addAttribute: att 
	^ self addAttribute: att from: 1 to: self size! !

!Text methodsFor: 'comparing' stamp: ''!
hash
	"#hash is implemented, because #= is implemented.  We are now equal to a string with the same characters.  Hash must reflect that."

	^ string hash! !

!Text methodsFor: 'emphasis' stamp: ''!
runLengthFor: characterIndex 
	"Answer the count of characters remaining in run beginning with 
	characterIndex."

	^runs runLengthAt: characterIndex! !

!Text methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
localizedForPresenter: aPresenter

	^ self asString! !

!Text methodsFor: 'converting' stamp: ''!
asOctetStringText

	string class == WideString ifTrue: [
		^ self class string: string asOctetString runs: self runs copy.
	].
	^self.
! !

!Text methodsFor: 'converting' stamp: ''!
removeAttributesThat: removalBlock replaceAttributesThat: replaceBlock by: convertBlock
	"Enumerate all attributes in the receiver. Remove those passing removalBlock and replace those passing replaceBlock after converting it through convertBlock"
	| added removed |
	"Deliberately optimized for the no-op default."
	added := removed := nil.
	runs withStartStopAndValueDo: [ :start :stop :attribs | 
		attribs do: [ :attrib | | new |
			(removalBlock value: attrib) ifTrue:[
				removed ifNil:[removed := Array new writeStream].
				removed nextPut: {start. stop. attrib}.
			] ifFalse:[
				(replaceBlock value: attrib) ifTrue:[
					removed ifNil:[removed := Array new writeStream].
					removed nextPut: {start. stop. attrib}.
					new := convertBlock value: attrib.
					added ifNil:[added := Array new writeStream].
					added nextPut: {start. stop. new}.
				].
			].
		].
	].
	(added isNil and:[removed isNil]) ifTrue:[^self].
	"otherwise do the real work"
	removed ifNotNil:[removed contents do:[:spec|
		self removeAttribute: spec last from: spec first to: spec second]].
	added ifNotNil:[added contents do:[:spec|
		self addAttribute: spec last from: spec first to: spec second]].! !

!Text methodsFor: 'emphasis' stamp: ''!
find: attribute
	"Return the first interval over which this attribute applies"
	| begin end |
	begin := 0.
	runs withStartStopAndValueDo:
		[:start :stop :attributes |
		(attributes includes: attribute)
			ifTrue: [begin = 0 ifTrue: [begin := start].
					end := stop]
			ifFalse: [begin > 0 ifTrue: [^ begin to: end]]].
	begin > 0 ifTrue: [^ begin to: end].
	^ nil! !

!Text methodsFor: '*Polymorph-Widgets' stamp: ''!
treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph

	"Method extracted from LazyListMorph"
	| attrs useDefaultFont f itemBounds |
	
	attrs := self attributesAt: 1.
	useDefaultFont := true.
	attrs
		do: [:att | att
				forFontInStyle: TextStyle default
				do: [:fon | useDefaultFont := false]].
	f := useDefaultFont
				ifTrue: [ aMorph font ]
				ifFalse: [ self fontAt: 1 withStyle: TextStyle default ].
	itemBounds := drawBounds  withHeight: f height.
	itemBounds := itemBounds align: itemBounds leftCenter with: drawBounds  leftCenter.
	"center the item if the font height is different to that of our font"
	aCanvas
		drawString: self
		in: itemBounds
		font: (f emphasized: (self emphasisAt: 1))
		color: drawColor 
		underline: ((self emphasisAt: 1)
				bitAnd: 4)
				> 0
		underlineColor: drawColor 
		strikethrough: ((self emphasisAt: 1)
				bitAnd: 16)
				> 0
		strikethroughColor: drawColor! !

!Text methodsFor: 'copying' stamp: ''!
copyReplaceTokens: oldSubstring with: newSubstring 
	"Replace all occurrences of oldSubstring that are surrounded
	by non-alphanumeric characters"
	^ (self string copyReplaceAll: oldSubstring with: newSubstring asTokens: true) asText
	"'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"! !

!Text methodsFor: 'accessing' stamp: ''!
rangeOf: attribute startingAt: index
"Answer an interval that gives the range of attribute at index position  index. An empty interval with start value index is returned when the attribute is not present at position index.  "
   ^string size = 0
      ifTrue: [index to: index - 1]
	 ifFalse: [runs rangeOf: attribute startingAt: index]! !

!Text methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
withAccentuatedCharacter: aCharacter

	| text index | 
	text := self copy.
	aCharacter ifNil: [ ^ text ].
	index := self asString asLowercase indexOf: aCharacter asLowercase.
	index isZero
		ifTrue: [ ^ text ].

	^ text
		addAttribute: TextEmphasis underlined from: index to: index;
		yourself! !

!Text methodsFor: '*Iceberg-TipUI-Spec' stamp: ''!
threeWayCompareTo: anotherText
	
	^ self asString threeWayCompareTo: anotherText asString! !

!Text methodsFor: 'emphasis' stamp: ''!
makeBoldFrom: start to: stop

	^ self addAttribute: TextEmphasis bold from: start to: stop! !

!Text methodsFor: 'paragraph support' stamp: ''!
encompassParagraph: anInterval

	^string encompassParagraph: anInterval! !

!Text methodsFor: '*Morphic-Base-Widgets' stamp: ''!
heightToDisplayInList: aList

	^ aList font height! !

!Text methodsFor: 'emphasis' stamp: ''!
removeAttribute: att from: start to: stop 
	"Remove the attribute over the interval start to stop."
	self runs: (runs copyReplaceFrom: start to: stop
			with: ((runs copyFrom: start to: stop)
				mapValues:
				[:attributes | attributes copyWithout: att]))
! !

!Text methodsFor: 'emphasis' stamp: ''!
alignmentAt: characterIndex ifAbsent: aBlock
	| attributes emph |
	self size = 0 ifTrue: [^aBlock value].
	emph := nil.
	attributes := runs at: characterIndex.
	attributes do:[:att | (att isKindOf: TextAlignment) ifTrue: [emph := att]].
	^ emph ifNil: aBlock ifNotNil: [emph alignment]! !

!Text methodsFor: 'accessing' stamp: ''!
lineCount

	^ string lineCount! !

!Text methodsFor: '*Morphic-Base-Converting' stamp: ''!
asMorph
	^ self asTextMorph! !

!Text methodsFor: 'converting' stamp: ''!
asText	
	"Answer the receiver itself."

	^self! !

!Text methodsFor: 'accessing' stamp: ''!
at: index put: character

	^string at: index put: character! !

!Text methodsFor: 'converting' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
 	"This destructively replaces elements from start to stop in the receiver starting at index, repStart, in replacementCollection. Do it to both the string and the runs."
 
 	| rep newRepRuns |
 	rep := replacement asText.	"might be a string"
 	string replaceFrom: start to: stop with: rep string startingAt: repStart.
 	newRepRuns := rep runs copyFrom: repStart to: repStart + stop - start.
	runs := runs copyReplaceFrom: start to: stop with: newRepRuns! !

!Text methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	string := string copy.
	runs := runs copy! !

!Text methodsFor: 'copying' stamp: ''!
deepCopy

	^ self copy "Both string and runs are assumed to be read-only"! !

!Text methodsFor: 'converting' stamp: ''!
asStringOrText	
	"Answer the receiver itself."

	^self! !

!Text methodsFor: 'accessing' stamp: ''!
size

	^string size! !

!Text methodsFor: 'emphasis' stamp: ''!
attributesAt: characterIndex 
	"Answer the code for characters in the run beginning at characterIndex."
	"NB: no senders any more (supplanted by #attributesAt:forStyle: but retained for the moment in order not to break user code that may exist somewhere that still calls this"
	| attributes |
"	self size = 0
		ifTrue: [^ Array with: (TextFontChange new fontNumber: 1)]."
	self size = 0 ifTrue: [ ^#()].
	attributes := runs at: characterIndex.
	^ attributes! !

!Text methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionText
	<inspectorPresentationOrder: 0 title: 'Text'>

	^ SpMorphPresenter new 
		morph: (RubScrolledTextMorph new 
			setText: self;
			in: [ :this | this textArea readOnly: true ];
			yourself);
		yourself! !

!Text methodsFor: 'copying' stamp: ''!
copyFrom: start to: stop 
	"Answer a copied subrange of the receiver."

	| realStart realStop |
	stop > self size
		ifTrue: [realStop := self size]		"handle selection at end of string"
		ifFalse: [realStop := stop].
	start < 1
		ifTrue: [realStart := 1]			"handle selection before start of string"
		ifFalse: [realStart := start].
	^self class 
		string: (string copyFrom: realStart to: realStop)
		runs: (runs copyFrom: realStart to: realStop)! !

!Text methodsFor: 'comparing' stamp: ''!
isText
	^ true! !

!Text methodsFor: 'emphasis' stamp: ''!
removeAttribute: att 
	^ self removeAttribute: att from: 1 to: self size! !

!Text methodsFor: 'emphasis' stamp: ''!
makeColor: color from: start to: stop
	| attribute |
	attribute := TextColor color: color.

	^ self addAttribute: attribute from: start to: stop! !

!Text methodsFor: 'testing' stamp: ''!
includesSubstring: aString caseSensitive: caseSensitive
	
	^ (self findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0! !

!Text methodsFor: 'accessing' stamp: ''!
prepend: stringOrText

	self replaceFrom: 1 to: 0 with: stringOrText! !

!Text methodsFor: 'converting' stamp: ''!
asNumber
	"Answer the number created by interpreting the receiver as the textual 
	representation of a number."

	^string asNumber! !

!Text methodsFor: 'testing' stamp: ''!
hasWideCharacterFrom: start to: stop
	^string hasWideCharacterFrom: start to: stop! !

!Text methodsFor: 'converting' stamp: ''!
reversed
 
 	"Answer a copy of the receiver with element order reversed."
 
 	^ self class string: string reversed runs: runs reversed.
 
   "  It is assumed that  self size = runs size  holds. "! !

!Text methodsFor: 'accessing' stamp: ''!
findString: aString startingAt: start caseSensitive: caseSensitive
	"Answer the index of substring within the receiver, starting at index 
	start. If the receiver does not contain substring, answer 0."

	^string findString: aString asString startingAt: start caseSensitive: caseSensitive! !

!Text methodsFor: 'private' stamp: ''!
setString: aString setRuns: anArray

	string := aString.
	runs := anArray! !

!Text methodsFor: 'testing' stamp: ''!
unembellished 
	"Return true if the only emphases are the default font and bold"
	| font1 bold |
	font1 := TextFontChange defaultFontChange.
	bold := TextEmphasis bold.
	runs withStartStopAndValueDo:
		[:start :stop :emphArray |
		emphArray do:
			[:emph | (font1 = emph or: [bold = emph]) ifFalse: [^ false]]].
	^ true! !

!Text methodsFor: 'comparing' stamp: ''!
= other
	"Am I equal to the other Text or String?  
	***** Warning ***** Two Texts are considered equal if they have the same characters in them.  They might have completely different emphasis, fonts, sizes, text actions, or embedded morphs.  If you need to find out if one is a true copy of the other, you must do (text1 = text2 and: [text1 runs = text2 runs])."

	other isText ifTrue:	["This is designed to run fast even for megabytes"
				^ string == other string or: [string = other string]].
	other isString ifTrue: [^ string == other or: [string = other]].
	^ false! !

!Text methodsFor: '*Polymorph-Widgets' stamp: ''!
heightToDisplayInTree: aTree

	^ aTree fontToUse height! !

!Text methodsFor: '*Morphic-Base-Converting' stamp: ''!
asTextMorph
	^ TextMorph new contentsAsIs: self! !

!Text methodsFor: 'converting' stamp: ''!
copyWithoutExternalReferences

	^ self copy  
		removeAttributesThat: [:attr | attr mayHaveExternalReferences ] replaceAttributesThat: [:attr | false ] by: [:attr | ];
		yourself.! !

!Text methodsFor: 'accessing' stamp: ''!
replaceFrom: start to: stop with: aText

	| txt |
	txt := aText asText.	"might be a string"
	string := string copyReplaceFrom: start to: stop with: txt string.
	runs := runs copyReplaceFrom: start to: stop with: txt runs! !

!Text methodsFor: 'emphasis' stamp: ''!
emphasisAt: characterIndex
	"Answer the fontfor characters in the run beginning at characterIndex."
	| attributes |
	self size = 0 ifTrue: [^ 0].	"null text tolerates access"
	attributes := runs at: characterIndex.
	^attributes inject: 0 into:
		[:emph :att | emph bitOr: att emphasisCode].! !

!Text methodsFor: 'printing' stamp: ''!
displayStringOn: aStream
	self printOn: aStream! !

!Text methodsFor: 'testing' stamp: ''!
includesSubstring: substring
	^ substring isEmpty or: [ (self findString: substring startingAt: 1) > 0 ]! !

!Text methodsFor: 'printing' stamp: ''!
printOn: aStream
	self printNameOn: aStream.
	aStream nextPutAll: ' for '; print: string! !

!Text methodsFor: 'accessing' stamp: ''!
string
	"Answer the string representation of the receiver."

	^string! !

!Text methodsFor: 'accessing' stamp: ''!
at: index

	^string at: index! !

!Text methodsFor: 'emphasis' stamp: ''!
makeAllColor: color
	| attribute |
	attribute := TextColor color: color.

	^ self addAttribute: attribute from: 1 to: self size! !

!Text methodsFor: 'emphasis' stamp: ''!
fontAt: characterIndex
	^self fontAt: characterIndex withStyle: TextStyle default! !

!Text methodsFor: '*STON-Text support' stamp: ''!
stonOn: stonWriter
	"Overwritten to get back the standard object behavior"
	
	stonWriter writeObject: self! !

!Text methodsFor: 'converting' stamp: ''!
withInternalLineEndings
	"Answer a copy of myself in which all sequences of <CR><LF> or <LF> have been changed to <CR>"
	| newText |
	(string includes: Character lf) ifFalse: [ ^self copy ].
	newText := self copyReplaceAll: String crlf with: String cr.
	(newText asString includes: Character lf) ifFalse: [ ^newText ].
	^newText copyReplaceAll: String lf with: String cr.! !

!Text methodsFor: 'private' stamp: ''!
runs

	^runs! !

!Text methodsFor: 'accessing' stamp: ''!
initialStyle
	^TextStyle default! !

!Text methodsFor: '*Morphic-Base-Pluggable Widgets' stamp: ''!
beginsWith: aString fromList: aMorph

	^ self asString beginsWith: aString fromList: aMorph! !

!Text methodsFor: 'paragraph support' stamp: ''!
encompassLine: anInterval
	^string encompassLine: anInterval! !

!Text methodsFor: 'private' stamp: ''!
setString: aString setRunsChecking: aRunArray
	"Check runs and do the best you can to make them fit..."

	string := aString.
	"check the runs"
	aRunArray ifNil: [^ aString asText].
	(aRunArray isKindOf: RunArray) ifFalse: [^ aString asText].
	aRunArray runs size = aRunArray values size ifFalse: [^ aString asText].
	aRunArray size = aString size ifFalse: [^ aString asText].
	
	runs := aRunArray.! !

!Text methodsFor: 'copying' stamp: ''!
copyReplaceFrom: start to: stop with: aTextOrString

	| txt |
	txt := aTextOrString asText.	"might be a string"
	^self class 
             string: (string copyReplaceFrom: start to: stop with: txt string)
             runs: (runs copyReplaceFrom: start to: stop with: txt runs)
! !

!Text methodsFor: 'emphasis' stamp: ''!
addAttribute: att from: start to: stop 
	"Set the attribute for characters in the interval start to stop."
	self runs: (runs copyReplaceFrom: start to: stop
			with: ((runs copyFrom: start to: stop)
				mapValues:
				[:attributes | Text addAttribute: att toArray: attributes]))
! !

!Text methodsFor: 'emphasis' stamp: ''!
fontNumberAt: characterIndex 
	"Answer the fontNumber for characters in the run beginning at characterIndex."
	| attributes fontNumber |
	self size = 0 ifTrue: [^1].	"null text tolerates access"
	attributes := runs at: characterIndex.
	fontNumber := 1.
	attributes do: [:att | (att isMemberOf: TextFontChange) ifTrue: [fontNumber := att fontNumber]].
	^ fontNumber
	! !

!Text methodsFor: 'emphasis' stamp: ''!
fontAt: characterIndex withStyle: aTextStyle
	"Answer the fontfor characters in the run beginning at characterIndex."
	| attributes font |
	self size = 0 ifTrue: [^ aTextStyle defaultFont].	"null text tolerates access"
	attributes := runs at: characterIndex.
	font := aTextStyle defaultFont.  "default"
	attributes do: 
		[:att | att forFontInStyle: aTextStyle do: [:f | font := f]].
	^ font! !

!Text methodsFor: '*Morphic-Base-Converting' stamp: ''!
asStringMorph
	^ StringMorph
		contents: self string
		font: (self fontAt: 1 withStyle: TextStyle default)
		emphasis: (self emphasisAt: 1)! !

!Text methodsFor: 'accessing' stamp: ''!
findString: aString startingAt: start 
	"Answer the index of substring within the receiver, starting at index 
	start. If the receiver does not contain substring, answer 0."

	^string findString: aString asString startingAt: start! !

!Text methodsFor: '*Morphic-Base' stamp: ''!
embeddedMorphsFrom: start to: stop 
	"return the list of morphs embedded in me"

	| morphs |
	morphs := IdentitySet new.
	runs 
		runsFrom: start
		to: stop
		do: 
			[:attribs | 
			attribs 
				do: [:attr | attr anchoredMorph ifNotNil: [morphs add: attr anchoredMorph]]].
	^morphs select: [:m | m isMorph]! !

!Text methodsFor: 'converting' stamp: ''!
asString
	"Answer a String representation of the textual receiver."

	^string! !

!Text methodsFor: '*Morphic-Base-Widgets' stamp: ''!
listRenderOn: aCanvas atRow: aRow bounds: bounds color: color backgroundColor: backgroundColor from: aMorph
	"Method extracted from LazyListMorph"
	| attrs useDefaultFont f itemBounds |
	
	attrs := self attributesAt: 1.
	useDefaultFont := true.
	attrs
		do: [:att | att
				forFontInStyle: aMorph font textStyle
				do: [:fon | useDefaultFont := false]].
	f := useDefaultFont
				ifTrue: [ aMorph font]
				ifFalse: [ self fontAt: 1 withStyle: aMorph font textStyle ].
	itemBounds := bounds withHeight: f height.
	itemBounds := itemBounds align: itemBounds leftCenter with: bounds leftCenter.
	"center the item if the font height is different to that of our font"
	aCanvas
		drawString: self
		in: itemBounds
		font: (f emphasized: (self emphasisAt: 1))
		color: color
		underline: ((self emphasisAt: 1)
				bitAnd: 4)
				> 0
		underlineColor: color
		strikethrough: ((self emphasisAt: 1)
				bitAnd: 16)
				> 0
		strikethroughColor: color! !

!Text methodsFor: '*Morphic-Base-Widgets' stamp: ''!
widthToDisplayInList: aList

	^ aList font widthOfStringOrText: self contents! !

!Text methodsFor: 'comparing' stamp: ''!
howManyMatch: aString

	^ self string howManyMatch: aString! !

!Text methodsFor: 'accessing' stamp: ''!
runs: anArray
	anArray size = string size
		ifFalse:
			[^self error: 'Some code is setting text attributes length not matching the string size'].
	runs := anArray! !

!Text methodsFor: 'accessing' stamp: ''!
append: stringOrText

	self replaceFrom: string size + 1
				to: string size with: stringOrText! !

!Text methodsFor: 'emphasis' stamp: ''!
attributesAt: characterIndex forStyle: aTextStyle
	"Answer the code for characters in the run beginning at characterIndex."
	| attributes |
	self size = 0
		ifTrue: [^ Array with: (TextFontChange new fontNumber: aTextStyle defaultFontIndex)].  "null text tolerates access"
	attributes := runs at: characterIndex.
	^ attributes! !

!Text methodsFor: '*Polymorph-Widgets' stamp: ''!
widthToDisplayInTree: aTree

	^ aTree fontToUse widthOfStringOrText: self contents! !

!Text methodsFor: '*STON-Text support' stamp: ''!
fromSton: stonReader
	"Overwritten to get back the standard object behavior"
	
	stonReader parseNamedInstVarsFor: self! !

!Text methodsFor: 'printing' stamp: ''!
storeOn: aStream

	aStream nextPutAll: '(Text string: ';
		store: string;
		nextPutAll: ' runs: ';
		store: runs;
		nextPut: $)! !

!Text methodsFor: '*Morphic-Base' stamp: ''!
embeddedMorphs
	"return the list of morphs embedded in me"

	| morphs |
	morphs := IdentitySet new.
	runs withStartStopAndValueDo: 
			[:start :stop :attribs | 
			attribs 
				do: [:attrib | attrib anchoredMorph ifNotNil: [morphs add: attrib anchoredMorph]]].
	^morphs select: [:m | m isMorph]! !

!Text class methodsFor: 'private' stamp: ''!
addAttribute: att toArray: others 
	"Add a new text attribute to an existing set"
	"NOTE: The use of reset and set in this code is a specific
	hack for merging TextKerns."
	att reset.
	^ Array streamContents:
		[:strm | others do:
			[:other | (att dominates: other) ifFalse: [strm nextPut: other]].
		att set ifTrue: [strm nextPut: att]]! !

!Text class methodsFor: 'instance creation' stamp: ''!
fromString: aString 
  "Answer an instance of me whose characters are those of the argument, aString."

  ^ self
    string: aString
    attributes:{ "No default attributes" }
! !

!Text class methodsFor: 'private' stamp: ''!
string: aString runs: anArray
 
	^self basicNew setString: aString setRuns: anArray! !

!Text class methodsFor: 'instance creation' stamp: ''!
fromUser
	"Answer an instance of me obtained by requesting the user to type a string."
	"Text fromUser"

	^ self fromString:
		(UIManager default request: 'Enter text followed by carriage return')
! !

!Text class methodsFor: 'instance creation' stamp: ''!
string: aString attribute: att
	"Answer an instance of me whose characters are aString.
	att is a TextAttribute."

	^self string: aString attributes: (Array with: att)! !

!Text class methodsFor: 'instance creation' stamp: ''!
new: stringSize

	^self fromString: (String new: stringSize)! !

!Text class methodsFor: 'instance creation' stamp: ''!
string: aString attributes: atts
	"Answer an instance of me whose characters are those of aString.
	atts is an array of TextAttributes."

	^self string: aString runs: (RunArray new: aString size withAll: atts)! !

!Text class methodsFor: 'instance creation' stamp: ''!
initialFont: aStrikeFont stringOrText: aStringOrText
	"Answer an instance of me whose characters are aString."
	
	^Text string: aStringOrText asString attribute: (TextFontReference toFont: aStrikeFont)! !

!Text class methodsFor: 'instance creation' stamp: ''!
streamContents: blockWithArg 
	| stream |
	stream := TextStream on: (self new: 400).
	blockWithArg value: stream.
	^ stream contents! !

!Text class methodsFor: '*STON-Text support' stamp: ''!
fromSton: stonReader
	"Overwritten to get back the standard object behavior"
	
	^ self new
		fromSton: stonReader;
		yourself! !

!TextAction commentStamp: ''!
I attach a bloc of code to a portion of text. The bloc is executed when the user clic on this portion of text.

---- exemple 1 -----
| stream |
stream := TextStream on: (Text new: 100).
stream 
	nextPutAll:  'Start a ';
	withAttributes: {TextEmphasis underlined. TextAction new actOnClickBlock: [Smalltalk tools browser open ]}
	do: [ stream nextPutAll: 'browser' ].
TextMorph new 
	newContents: stream contents;
	openInWindow .
---- exemple 2 -----
| stream |
stream := TextStream on: (Text new: 100).
stream 
	withAttributes: {TextAction new actOnClickBlock: [:attr :event :textMorph :parag :editor | 		
		textMorph owner color: Color white.
		parag rightFlush.
		editor flash]}
	do: [ stream nextPutAll: 'Change me' ].
TextMorph new 
	newContents: stream contents;
	openInWindow .!
!TextAction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	actOnClickBlock := ActOnClickBlock.! !

!TextAction methodsFor: 'event handling' stamp: ''!
actOnMove: anEvent for: target in: aParagraph editor: anEditor
	"override in subclasses"
	^ false! !

!TextAction methodsFor: 'testing' stamp: ''!
mayActOnEvent: anEvent

	^ true! !

!TextAction methodsFor: 'accessing' stamp: ''!
actOnClickBlock: aBlock
	actOnClickBlock := aBlock! !

!TextAction methodsFor: 'testing' stamp: ''!
dominatedByCmd0
	"Cmd-0 should turn off active text"
	^ true! !

!TextAction methodsFor: '*Text-Scanning' stamp: ''!
emphasizeScanner: scanner
	"Set the emphasis for text display"
	scanner textColor: Smalltalk ui theme urlColor! !

!TextAction methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubActOnClick: anEvent for: anObject in: paragraph editor: editor
	"sent when a user clicks on a piece of text to which I am applied in an editor"

	"may be self is included in the event or an Object. "
	^ actOnClickBlock valueWithEnoughArguments: (Array with: self with: anEvent with: anObject with: paragraph with: editor)! !

!TextAction methodsFor: 'evaluating' stamp: ''!
actOnClick: anEvent for: anObject in: paragraph editor: editor
	"sent when a user clicks on a piece of text to which I am applied in an editor"
	"may be self is included in the event or an Object. "
	^ actOnClickBlock valueWithEnoughArguments: (Array with: self with: anEvent with: anObject with: paragraph with: editor)! !

!TextAction methodsFor: 'testing' stamp: ''!
analyze: aString
	"Analyze the selected text to find both the parameter to store and the text to emphesize (may be different from original selection).  Does not return self!!.  May be of the form:
3+4
<3+4>
Click Here<3+4>
<3+4>Click Here
"
	"Obtain the showing text and the instructions"
	| b1 b2 trim param show |
	b1 := aString indexOf: $<.
	b2 := aString indexOf: $>.
	(b1 < b2) & (b1 > 0) ifFalse: ["only one part"
		param := self validate: aString.
		param ifNil: [ ^{ nil. nil } ].
		^ Array with: param with: (param ifEmpty: [nil] ifNotEmpty: [param])].
	"Two parts"
	trim := aString trimBoth.
	(trim at: 1) == $< 
		ifTrue: [(trim last) == $>
			ifTrue: ["only instructions" 
				param := self validate: (aString copyFrom: b1+1 to: b2-1).
				show := param ifEmpty: [nil] ifNotEmpty: [param]]
			ifFalse: ["at the front"
				param := self validate: (aString copyFrom: b1+1 to: b2-1).
				show := param ifEmpty: [nil] ifNotEmpty: [aString copyFrom: b2+1 to: aString size]]]
		ifFalse: [(trim last) == $>
			ifTrue: ["at the end"
				param := self validate: (aString copyFrom: b1+1 to: b2-1).
				show := param ifEmpty: [nil] ifNotEmpty: [aString copyFrom: 1 to: b1-1]]
			ifFalse: ["Illegal -- <> has text on both sides"
				show := nil]].
	^ Array with: param with: show! !

!TextAction methodsFor: 'testing' stamp: ''!
validate: aString
	"any format is OK with me"
	^ aString! !

!TextAction methodsFor: 'accessing' stamp: ''!
actOnClickBlock
	^ actOnClickBlock! !

!TextAction methodsFor: 'accessing' stamp: ''!
info
	^ 'no hidden info'! !

!TextAction class methodsFor: 'class initialization' stamp: ''!
initialize
	"nil value and [] value are both nil, but sharing a block would hold on to its outer method"
	ActOnClickBlock := nil! !

!TextAction class methodsFor: 'accessing' stamp: ''!
actOnClickBlock: aBlock
	ActOnClickBlock := aBlock! !

!TextAction class methodsFor: 'accessing' stamp: ''!
actOnClickBlock
	^ ActOnClickBlock! !

!TextAlignment commentStamp: ''!
I'm a Text attribute that tells how content should be aligned.

----- exemple 1 ---------------
TextMorph new 
	newContents: (Text streamContents: [:aStream| 
		aStream
			nextPutAll: 'Left flush' asText; 
			cr;
			nextPutAll: ('Centered' asText addAttribute: TextAlignment centered); 
 			cr;
			nextPutAll: ('Right flush' asText addAttribute: TextAlignment rightFlush); 
 			cr ]);
  	openInWindowLabeled: 'TextAlignment demo'
----- exemple 2 ---------------
| stream |
stream := TextStream on: (Text new: 100).
stream 
	nextPutAll:  'Pharo';	cr;
	withAttribute: TextAlignment centered do:  [stream nextPutAll: 'is' ];  cr;
	withAttribute: TextAlignment rightFlush  do: [ stream nextPutAll: 'cool ']; cr;
	withAttribute: TextAlignment justified  do: [ stream nextPutAll: 'because it is both an interactive programming enviornment and a reflexive programming language.' ].
TextMorph new 
	newContents: stream contents;
	openInWindow .!
!TextAlignment methodsFor: 'comparing' stamp: ''!
= other 
	^ (other class == self class) 
		and: [other alignment = alignment]! !

!TextAlignment methodsFor: 'comparing' stamp: ''!
hash
	"#hash is re-implemented because #= is re-implemented"
	^ alignment hash! !

!TextAlignment methodsFor: '*Text-Scanning' stamp: ''!
emphasizeScanner: scanner
	"Set the emphasist for text scanning"
	scanner setAlignment: alignment.! !

!TextAlignment methodsFor: 'testing' stamp: ''!
dominates: other
	"There can be only one..."
	^self class == other class! !

!TextAlignment methodsFor: 'accessing' stamp: ''!
alignment: aNumber
	alignment := aNumber.! !

!TextAlignment methodsFor: 'accessing' stamp: ''!
alignment
	^alignment! !

!TextAlignment class methodsFor: 'instance creation' stamp: ''!
justified
	^self new alignment: Justified! !

!TextAlignment class methodsFor: 'instance creation' stamp: ''!
centered
	^self new alignment: Centered! !

!TextAlignment class methodsFor: 'instance creation' stamp: ''!
leftFlush
	^self new alignment: LeftFlush! !

!TextAlignment class methodsFor: 'instance creation' stamp: ''!
rightFlush
	^self new alignment: RightFlush! !

!TextAlignment class methodsFor: 'utilities' stamp: ''!
alignmentSymbol: alignmentCode
	^#(leftFlush rightFlush centered justified) at: (alignmentCode + 1)! !

!TextAlignmentTest commentStamp: ''!
SUnit tests for class TextAlignment!
!TextAlignmentTest methodsFor: 'tests' stamp: ''!
testDominates
	| text |
	self assert: (TextAlignment centered dominates: TextAlignment rightFlush).
	self assert: (TextAlignment centered  dominates: TextAlignment centered).
	self deny: (TextAlignment centered dominates: TextEmphasis bold).
	self deny: (TextAlignment centered dominates: TextFontChange font2).
	"In action"
	text := 'Pharo is cool' asText.
	text addAttribute: TextAlignment centered.
	"Only one alignement  time, the last added alignement win"
	text addAttribute: TextAlignment justified .
	self assert: (text attributesAt: 1) size equals: 1.
	self assert: (text attributesAt: 1) first equals: TextAlignment justified.
	"Can be both aligned and bold"
	text addAttribute: TextEmphasis bold.
	self assert: (text attributesAt: 1) size equals: 2.
	self assert: (text attributesAt: 1) first  equals: TextAlignment justified.
	self assert: (text attributesAt: 2) second emphasisCode equals: 1! !

!TextAlignmentTest methodsFor: 'tests' stamp: ''!
testAlignment
	| attribute |
	self assert: TextAlignment leftFlush alignment equals: TextConstants LeftFlush. 
	self assert: TextAlignment rightFlush alignment equals: TextConstants RightFlush. 
	self assert: TextAlignment centered alignment equals: TextConstants Centered . 
	self assert: TextAlignment justified  alignment equals: TextConstants Justified . 
	"We can change alignment"
	attribute := TextAlignment leftFlush.
	attribute alignment: TextConstants RightFlush.
	self assert: attribute alignment equals: TextConstants RightFlush ! !

!TextAlignmentTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	prototypes add: TextAlignment centered;
		 add: TextAlignment justified;
		 add: TextAlignment leftFlush;
		 add: TextAlignment rightFlush ! !

!TextAnchor commentStamp: ''!
TextAnchors support anchoring of images in text.  A TextAnchor exists as an attribute of a special text placeholder - "(Character value: 1) asText".  Depending on whether its anchoredMorph is a Morph or a Form, it repositions the morph, or displays the form respectively.  The coordination between composition, display and selection can best be understood by browsing the various implementations of placeEmbeddedObject:.

In the morphic world, simply embed any form or morph in text.

	| textWithForm |
	textWithForm := (Text withAll: 'Text with -->'), (Text string: (String value: 1) attribute: (TextAnchor new anchoredMorph: ThemeIcons current homeIcon)), (Text withAll: '<-- embedded Form').
	textWithForm asMorph openInHand.

	| textWithMorph |
	textWithMorph := (Text withAll: 'Text with -->'), (Text string: (String value: 1) attribute: (TextAnchor new anchoredMorph: EllipseMorph new)), (Text withAll: '<-- embedded Morph').
	textWithMorph asMorph openInHand.!
!TextAnchor methodsFor: 'comparing' stamp: ''!
= other

	^ other class == self class and: [ 
		  other anchoredMorph == anchoredMorph ]! !

!TextAnchor methodsFor: 'comparing' stamp: ''!
hash
	"#hash is re-implemented because #= is re-implemented"
	
	^anchoredMorph identityHash! !

!TextAnchor methodsFor: 'accessing' stamp: ''!
anchoredMorph: aMorph

	anchoredMorph := aMorph! !

!TextAnchor methodsFor: 'accessing' stamp: ''!
mayBeExtended
	"A textAnchor is designed to modify only a single character, and therefore must not be extended by the ParagraphEditor's emphasisHere facility"
	
	^ false! !

!TextAnchor methodsFor: 'accessing' stamp: ''!
anchoredMorph

	^ anchoredMorph! !

!TextAnchorTest methodsFor: 'running' stamp: ''!
testMorphInline

	| text morphTextAttribute |
	text := 'Hello ' asText, Morph new asText, ' world' asText.

	"Stupid assertion, but this test is mostly a usage example"
	morphTextAttribute := text attributesAt: 7.
	self assert: (morphTextAttribute first isKindOf: TextAnchor)! !

!TextAnchorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	prototypes
		add: (TextAnchor new anchoredMorph: Morph new initialize);
		
		add: (TextAnchor new anchoredMorph: EllipseMorph new initialize)! !

!TextAttribute commentStamp: ''!
I am an abstract class to represent a text attribute, the way a portion of text is graphically represented.
My sub-classes specify these representations:
- colouring (TextColor), 
- bold, italic, underlined, 
- narrow, strike out (TextEmphasis), 
- alignment (TextAlignment),
- indentation (TextIndent),
- font change (TextFontChange),
- kerning (TextKern),
- url and related action (TextAction hierarchy).
- morph (TextAnchor)

My instances are stored in the Text instance runs variable (a RunArray).

------------8<-----------------------------------------------------------------------------------------
Select text, press Command-6, choose a attribute.  If selected text is of the form 
	Hi There<Smalltalk beep>
the part in angle brackets is saved for action, and the Hi There appears in the paragraph.  If selection has no angle brackets, use the whole thing as both the text and the action.

TextDoIt  --  eval as a Smalltalk expression (the part in angle brackets)

TextLink -- Show a method, class comment, class hierarchy, or class defintion.
	<Point extent:>, <Point Comment>, <Point Hierarchy>, or <Point Defintion> are what you type.

TextURL -- Show the web page. <www.disney.com>

These attributes of text need to be stored on the disk in a regular file-out.  It is done in this form: 	Hi There   
	in the text, and a Run containing   dSmalltalk beep;;
	Click here to see the extent:   
	in the text, and a Run containing   method LPoint extent:;
See RunArray class scanFrom: where decoding is done.
!
!TextAttribute methodsFor: 'testing' stamp: ''!
mayActOnEvent: anEvent
	"Subclasses may override to provide, eg, hot-spot actions"
	^ false! !

!TextAttribute methodsFor: 'testing' stamp: ''!
dominatedByCmd0
	"Subclasses may override if cmd-0 should turn them off"
	^ false! !

!TextAttribute methodsFor: 'accessing' stamp: ''!
set
	"Respond true to include this attribute (as opposed to, eg, a bold
	emphasizer that is clearing the property"
	^ true! !

!TextAttribute methodsFor: 'accessing' stamp: ''!
dominates: another
	"Subclasses may override condense multiple attributes"
	^ false! !

!TextAttribute methodsFor: '*Text-Scanning' stamp: ''!
emphasizeScanner: scanner
	"Subclasses may override to set, eg, font, color, etc"! !

!TextAttribute methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubMayActOnEvent: anEvent
	^ self mayActOnEvent: anEvent ! !

!TextAttribute methodsFor: 'styling' stamp: ''!
forFontInStyle: aTextStyle do: aBlock
	"No action is the default.  Overridden by font specs"! !

!TextAttribute methodsFor: 'testing' stamp: ''!
isKern
	^false! !

!TextAttribute methodsFor: 'testing' stamp: ''!
mayBeExtended
	"A quality that may be overridden by subclasses, such as TextAnchors, that really only apply to a single character"
	^ true! !

!TextAttribute methodsFor: 'styling' stamp: ''!
emphasisCode
	"Subclasses may override to add bold, italic, etc"
	^ 0! !

!TextAttribute methodsFor: 'testing' stamp: ''!
mayHaveExternalReferences
	"Answer if this attribute can have references to some external objects like AST nodes"
	^ false! !

!TextAttribute methodsFor: 'initialization' stamp: ''!
reset
	"Allow subclasses to prepare themselves for merging attributes"! !

!TextAttribute methodsFor: 'accessing' stamp: ''!
anchoredMorph
	"If one hides here, return it"
	^nil! !

!TextBackgroundColor commentStamp: ''!
I am a text attribute representing background color of a text. I am used as any other TextAttribute.

!
!TextBackgroundColor methodsFor: 'accessing' stamp: ''!
color: aColor
	color := aColor! !

!TextBackgroundColor methodsFor: 'comparing' stamp: ''!
= other 
	^ (other class == self class) 
		and: [other color = color]! !

!TextBackgroundColor methodsFor: 'comparing' stamp: ''!
hash
	^ color hash! !

!TextBackgroundColor methodsFor: 'converting' stamp: ''!
asColor 

	^ color! !

!TextBackgroundColor methodsFor: 'scanning' stamp: ''!
dominates: other
"Only one background color attribute on a same portion of text."
	^ other class == self class! !

!TextBackgroundColor methodsFor: 'accessing' stamp: ''!
color
	^ color! !

!TextBackgroundColor class methodsFor: 'instance creation' stamp: ''!
color: aColor
	^ self new color: aColor! !

!TextBackgroundColor class methodsFor: 'constants' stamp: ''!
blue
	^ self new color: Color blue! !

!TextBackgroundColor class methodsFor: 'constants' stamp: ''!
black
	^ self new color: Color black! !

!TextBackgroundColor class methodsFor: 'constants' stamp: ''!
white 
	^ self new color: Color white! !

!TextBackgroundColor class methodsFor: 'constants' stamp: ''!
green
	^ self new color: Color green! !

!TextBackgroundColor class methodsFor: 'instance creation' stamp: ''!
scanFrom: strm
	"read a color in the funny format used by Text styles on files. c125000255 or cblue;"

	| r g b |
	strm peek isDigit
		ifTrue:
			[r := (strm next: 3) asNumber.
			g := (strm next: 3) asNumber.
			b := (strm next: 3) asNumber.
			^ self color: (Color r: r g: g b: b range: 255)].
	"A name of a color"
	^ self color: (Color perform: (strm upTo: $;) asSymbol)! !

!TextBackgroundColor class methodsFor: 'constants' stamp: ''!
red
	^ self new color: Color red! !

!TextBackgroundColor class methodsFor: 'constants' stamp: ''!
gray
	^ self new color: Color gray! !

!TextBackgroundColor class methodsFor: 'constants' stamp: ''!
magenta
	^ self new color: Color magenta! !

!TextBackgroundColor class methodsFor: 'constants' stamp: ''!
cyan
	^ self new color: Color cyan! !

!TextBackgroundColor class methodsFor: 'constants' stamp: ''!
yellow
	^ self new color: Color yellow! !

!TextClassLink commentStamp: ''!
An active link in a text linking to a class!
!TextClassLink methodsFor: 'comparing' stamp: ''!
= anotherObject

	^super = anotherObject and: [ className = anotherObject className ]! !

!TextClassLink methodsFor: 'comparing' stamp: ''!
hash

	^(super hash + className hash) hashMultiply ! !

!TextClassLink methodsFor: 'accessing' stamp: ''!
className: aStringOrSymbol
	className := aStringOrSymbol asSymbol! !

!TextClassLink methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubActOnClick: anEvent for: target in: aParagraph editor: anEditor
	anEvent shiftPressed
		ifFalse: [ anEditor editor browseClassFrom: self className ]
		ifTrue: [ anEditor editor referencesTo: self className ].
	^ true! !

!TextClassLink methodsFor: '*Text-Edition' stamp: ''!
actOnClick: anEvent for: target in: aParagraph editor: anEditor
	anEvent shiftPressed
		ifFalse: [ anEditor browseClassFrom: self className ]
		ifTrue: [ anEditor referencesTo: self className ].
	^ true! !

!TextClassLink methodsFor: 'system primitives' stamp: ''!
className	
	^ className! !

!TextClassLink class methodsFor: 'instance creation' stamp: ''!
className: aSymbol
	^ self new
		className: aSymbol;
		yourself! !

!TextClassLink class methodsFor: 'instance creation' stamp: ''!
class: aClass
	^ self className: aClass name! !

!TextColor commentStamp: ''!
A TextColor encodes a text color change applicable over a given range of text.!
!TextColor methodsFor: 'accessing' stamp: ''!
color: aColor
	color := aColor! !

!TextColor methodsFor: 'comparing' stamp: ''!
= other 
	^ (other class == self class) 
		and: [other color = color]! !

!TextColor methodsFor: 'comparing' stamp: ''!
hash
	^ color hash! !

!TextColor methodsFor: 'converting' stamp: ''!
asColor 

	^ color! !

!TextColor methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' code: '; print: color! !

!TextColor methodsFor: '*Text-Scanning' stamp: ''!
emphasizeScanner: scanner
	"Set the emphasis for text display"
	scanner textColor: color! !

!TextColor methodsFor: 'scanning' stamp: ''!
dominates: other
"Only one color attribute on a same portion of text."
	^ other class == self class! !

!TextColor methodsFor: 'accessing' stamp: ''!
color
	^ color! !

!TextColor class methodsFor: 'instance creation' stamp: ''!
color: aColor
	^ self new color: aColor! !

!TextColor class methodsFor: 'constants' stamp: ''!
blue
	^ self new color: Color blue! !

!TextColor class methodsFor: 'constants' stamp: ''!
black
	^ self new color: Color black! !

!TextColor class methodsFor: 'constants' stamp: ''!
white 
	^ self new color: Color white! !

!TextColor class methodsFor: 'constants' stamp: ''!
green
	^ self new color: Color green! !

!TextColor class methodsFor: 'instance creation' stamp: ''!
scanFrom: strm
	"read a color in the funny format used by Text styles on files. c125000255 or cblue;"

	| r g b |
	strm peek isDigit
		ifTrue:
			[r := (strm next: 3) asNumber.
			g := (strm next: 3) asNumber.
			b := (strm next: 3) asNumber.
			^ self color: (Color r: r g: g b: b range: 255)].
	"A name of a color"
	^ self color: (Color perform: (strm upTo: $;) asSymbol)! !

!TextColor class methodsFor: 'constants' stamp: ''!
red
	^ self new color: Color red! !

!TextColor class methodsFor: 'constants' stamp: ''!
gray
	^ self new color: Color gray! !

!TextColor class methodsFor: 'constants' stamp: ''!
magenta
	^ self new color: Color magenta! !

!TextColor class methodsFor: 'constants' stamp: ''!
cyan
	^ self new color: Color cyan! !

!TextColor class methodsFor: 'constants' stamp: ''!
yellow
	^ self new color: Color yellow! !

!TextColorTest methodsFor: 'tests' stamp: ''!
testColor
	| textColor |
	textColor := TextColor color: Color red.
	self assert: textColor color equals: Color red.
	self assert: textColor asColor equals: Color red.
	
	textColor  color: Color yellow.
	self assert: textColor color equals: Color yellow.
	self assert: textColor asColor equals: Color yellow.
	! !

!TextColorTest methodsFor: 'tests' stamp: ''!
testDominates
	| text |
	self assert: (TextColor red dominates: TextColor yellow).
	self assert: (TextColor red dominates: TextColor red).
	self deny: (TextColor red dominates: TextEmphasis bold).
	self deny: (TextColor red dominates: TextFontChange font2).
	"In action"
	text := 'Pharo is cool' asText.
	text addAttribute: TextColor red.
	"Only one color at time, the last added color win"
	text addAttribute: TextColor yellow.
	self assert: (text attributesAt: 1) size equals: 1.
	self assert: (text attributesAt: 1) first color equals: Color yellow.
	"Can be both colored and bold"
	text addAttribute: TextEmphasis bold.
	self assert: (text attributesAt: 1) size equals: 2.
	self assert: (text attributesAt: 1) first color equals: Color yellow.
	self assert: (text attributesAt: 2) second emphasisCode equals: 1! !

!TextComposer commentStamp: ''!
Utility class to compose text!
!TextComposer methodsFor: 'composition' stamp: ''!
composeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks 

	wantsColumnBreaks := argWantsColumnBreaks.
	lines := argLinesCollection.
	theTextStyle := argTextStyle.
	theText := argText.
	theContainer := argContainer.
	deltaCharIndex := argDelta.
	currCharIndex := startCharIndex := argStart.
	stopCharIndex := argStop.
	prevLines := argPriorLines.
	currentY := argStartY.
	defaultLineHeight := theTextStyle lineGrid.
	maxRightX := theContainer left.
	possibleSlide := stopCharIndex < theText size
				and: [theContainer isMemberOf: Rectangle].
	nowSliding := false.
	prevIndex := 1.
	scanner := CompositionScanner new text: theText textStyle: theTextStyle.
	scanner wantsColumnBreaks: wantsColumnBreaks.
	isFirstLine := true.
	self composeAllLines.
	isFirstLine
		ifTrue: ["No space in container or empty text"
			self
				addNullLineWithIndex: startCharIndex
				andRectangle: (theContainer left @ theContainer top extent: 0 @ defaultLineHeight)]
		ifFalse: [self fixupLastLineIfCR].
	^ {lines asArray. maxRightX}! !

!TextComposer methodsFor: 'private' stamp: ''!
fixupLastLineIfCR
"This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic."

	(theText size > 0 and: [ CharacterSet crlf includes: theText last ]) ifFalse: [ ^ self ].
	
	self addNullLineForIndex: theText size + 1.! !

!TextComposer methodsFor: 'composition' stamp: ''!
composeOneLine

	| rectangles |
	rectangles := theContainer
		              rectanglesAt: currentY
		              height: defaultLineHeight.

	rectangles notEmpty
		ifTrue: [ (self composeAllRectangles: rectangles) ifNil: [ ^ nil ] ]
		ifFalse: [ currentY := currentY + defaultLineHeight ].

	self checkIfReadyToSlide! !

!TextComposer methodsFor: 'adding' stamp: ''!
addNullLineWithIndex: index andRectangle: r

	lines addLast: (
		(
			TextLine 
				start: index 
				stop: index - 1
				internalSpaces: 0 
				paddingWidth: 0
		)
			rectangle: r;
			lineHeight: defaultLineHeight baseline: theTextStyle baseline
	)! !

!TextComposer methodsFor: 'composition' stamp: ''!
composeEachRectangleIn: rectangles

	| myLine lastChar |

	1 to: rectangles size do: [:i | 
		currCharIndex <= theText size ifFalse: [ ^ false ].
		myLine := scanner 
			composeFrom: currCharIndex 
			inRectangle: (rectangles at: i)				
			firstLine: isFirstLine 
			leftSide: i=1 
			rightSide: i=rectangles size.
		lines addLast: myLine.
		actualHeight := actualHeight max: myLine lineHeight.  "includes font changes"
		currCharIndex := myLine last + 1.
		
		"This happens if the text is just one line long"
		(myLine last = 0) ifTrue: [ ^ false ].
		
		lastChar := theText at: myLine last.
		(CharacterSet crlf includes: lastChar) ifTrue: [^#cr].
		wantsColumnBreaks ifTrue: [
			lastChar = self class characterForColumnBreak ifTrue: [^#columnBreak].
		].
	].
	^false! !

!TextComposer methodsFor: 'composition' stamp: ''!
composeAllLines

	[ currCharIndex <= theText size and: [ 
		currentY + defaultLineHeight <= theContainer bottom ] ] whileTrue: [ 
		(nowSliding
			 ifTrue: [ self slideOneLineDown ]
			 ifFalse: [ self composeOneLine ]) ifNil: [ ^ nil ] ]! !

!TextComposer methodsFor: 'private' stamp: ''!
slideOneLineDown

	| priorLine |

	"Having detected the end of rippling recoposition, we are only sliding old lines"
	prevIndex < prevLines size ifFalse: [
		"There are no more prevLines to slide."
		^nowSliding := possibleSlide := false
	].

	"Adjust and re-use previously composed line"
	prevIndex := prevIndex + 1.
	priorLine := (prevLines at: prevIndex)
				slideIndexBy: deltaCharIndex andMoveTopTo: currentY.
	lines addLast: priorLine.
	currentY := priorLine bottom.
	currCharIndex := priorLine last + 1.
	wantsColumnBreaks ifTrue: [
		priorLine first to: priorLine last do: [ :i |
			(theText at: i) = TextComposer characterForColumnBreak ifTrue: [
				nowSliding := possibleSlide := false.
				^nil
			].
		].
	].! !

!TextComposer methodsFor: 'adding' stamp: ''!
addNullLineForIndex: index
	"This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic."

	| oldLastLine r |
	oldLastLine := lines last.
	oldLastLine last - oldLastLine first >= 0 ifFalse: [ ^ self ].
	oldLastLine last = (index - 1) ifFalse: [ ^ self ].

	r := oldLastLine left @ oldLastLine bottom extent:
		     0 @ (oldLastLine bottom - oldLastLine top).
	"Even though we may be below the bottom of the container,
	it is still necessary to compose the last line for consistency..."

	self addNullLineWithIndex: index andRectangle: r! !

!TextComposer methodsFor: 'protocol' stamp: ''!
multiComposeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks 
	wantsColumnBreaks := argWantsColumnBreaks.
	lines := argLinesCollection.
	theTextStyle := argTextStyle.
	theText := argText.
	theContainer := argContainer.
	deltaCharIndex := argDelta.
	currCharIndex := startCharIndex := argStart.
	stopCharIndex := argStop.
	prevLines := argPriorLines.
	currentY := argStartY.
	defaultLineHeight := theTextStyle lineGrid.
	maxRightX := theContainer left.
	possibleSlide := stopCharIndex < theText size
				and: [theContainer isMemberOf: Rectangle].
	nowSliding := false.
	prevIndex := 1.
	scanner := CompositionScanner new text: theText textStyle: theTextStyle.
	scanner wantsColumnBreaks: wantsColumnBreaks.
	isFirstLine := true.
	self composeAllLines.
	isFirstLine
		ifTrue: ["No space in container or empty text"
			self
				addNullLineWithIndex: startCharIndex
				andRectangle: (theContainer topLeft extent: 0 @ defaultLineHeight)]
		ifFalse: [self fixupLastLineIfCR].
	^ {lines asArray. maxRightX}! !

!TextComposer methodsFor: 'testing' stamp: ''!
checkIfReadyToSlide
	"Check whether we are now in sync with previously composed lines"

	(possibleSlide and: [currCharIndex > stopCharIndex]) ifFalse: [^self].

	[prevIndex < prevLines size
		and: [(prevLines at: prevIndex) first < (currCharIndex - deltaCharIndex)]]
			whileTrue: [prevIndex := prevIndex + 1].

	(prevLines at: prevIndex) first = (currCharIndex - deltaCharIndex) ifTrue: [
		"Yes -- next line will have same start as prior line."
		prevIndex := prevIndex - 1.
		possibleSlide := false.
		nowSliding := true
	] ifFalse: [
		prevIndex = prevLines size ifTrue: [
			"Weve reached the end of prevLines, so no use to keep looking for lines to slide."
			possibleSlide := false
		]
	]! !

!TextComposer methodsFor: 'composition' stamp: ''!
composeAllRectangles: rectangles

	| charIndexBeforeLine numberOfLinesBefore reasonForStopping |

	actualHeight := defaultLineHeight.
	charIndexBeforeLine := currCharIndex.
	numberOfLinesBefore := lines size.
	reasonForStopping := self composeEachRectangleIn: rectangles.

	currentY := currentY + actualHeight.
	currentY > theContainer bottom ifTrue: [
		"Oops -- the line is really too high to fit -- back out"
		currCharIndex := charIndexBeforeLine.
		lines size - numberOfLinesBefore timesRepeat: [lines removeLast].
		^self
	].
	
	"It's OK -- the line still fits."
	maxRightX := maxRightX max: scanner rightX.
	1 to: rectangles size - 1 do: [ :i |
		"Adjust heights across rectangles if necessary"
		(lines at: lines size - rectangles size + i)
			lineHeight: lines last lineHeight
			baseline: lines last baseline
	].
	isFirstLine := false.
	reasonForStopping == #columnBreak ifTrue: [^nil].
	currCharIndex > theText size ifTrue: [
		^nil		"we are finished composing"
	].! !

!TextComposer class methodsFor: 'accessing - defaults' stamp: ''!
characterForColumnBreak

	^Character value: 12! !

!TextConstants commentStamp: ''!
A pool for Text constants for space, tab, espace, ...!
!TextConstants class methodsFor: 'accessing' stamp: ''!
BS2
	^BS2! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrla
	^Ctrla! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
RightFlush
	^RightFlush! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrly
	^Ctrly! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlz
	^Ctrlz! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlA
	^CtrlA! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlO
	^CtrlO! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Tab
	^Tab! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlW
	^CtrlW! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlN
	^CtrlN! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlK
	^CtrlK! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlY
	^CtrlY! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlu
	^Ctrlu! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
DefaultFontFamilySize
	^DefaultFontFamilySize! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlx
	^Ctrlx! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlr
	^Ctrlr! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Space
	^Space! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
DefaultTabsArray
	^DefaultTabsArray! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Enter
	^Enter! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
TextSharedInformation
	^TextSharedInformation! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlj
	^Ctrlj! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CrossedX
	^CrossedX! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlF
	^CtrlF! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
DefaultMarginTabsArray
	^DefaultMarginTabsArray! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlQ
	^CtrlQ! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrll
	^Ctrll! !

!TextConstants class methodsFor: 'class initialization' stamp: ''!
initialize

	TextSharedInformation ifNil: [ TextSharedInformation := Dictionary new].
	Ctrll := Character value: 153.
	Ctrld := Character value: 132.
	ESC := Character value: 160.
	Ctrlh := Character value: 179.
	Enter := Character value: 3.
	DefaultSpace := 4.
	LeftFlush := 0.
	DefaultRule := 3.
	CtrlX := Character value: 215.
	CtrlT := Character value: 240.
	RightFlush := 1.
	Basal := 0.
	CtrlP := Character value: 202.
	DefaultFontFamilySize := 3.
	CtrlL := Character value: 217.
	CtrlH := Character value: 243.
	Ctrlw := Character value: 145.
	CtrlD := Character value: 196.
	DefaultTab := 24.
	Ctrls := Character value: 19.
	Ctrlo := Character value: 15.
	DefaultLineGrid := 16.
	Ctrlk := Character value: 136.
	Ctrlc := Character value: 228.
	Space := Character value: 32.
	Ctrlg := Character value: 232.
	Tab := Character value: 9.
	CtrlW := Character value: 209.
	EndOfRun := 257.
	CtrlS := Character value: 211.
	Italic := 2.
	Centered := 2.
	CrossedX := 258.
	CtrlO := Character value: 216.
	DefaultMarginTabsArray := #(#(24 24) #(48 48) #(72 72) #(96 96) #(120 120) #(144 144) #(168 168) #(192 192) #(216 216) #(240 240) #(264 264) #(288 288) #(312 312) #(336 336) #(360 360) #(384 384) #(408 408) #(432 432) #(456 456) #(480 480)).
	CtrlOpenBrackets := #(201 7 218 249 219 15).
	CtrlK := Character value: 200.
	Ctrlz := Character value: 167.
	CtrlG := Character value: 241.
	LeftMarginTab := 1.
	CtrlC := Character value: 228.
	Ctrlv := Character value: 134.
	Justified := 3.
	Ctrlr := Character value: 18.
	DefaultTabsArray := #(24 48 72 96 120 144 168 192 216 240 264 288 312 336 360 384 408 432 456 480 504 528 552 576 600 624 648 672 696 720 744 768 792 816 840 864 888 912 936 960).
	Ctrln := Character value: 14.
	RightMarginTab := 2.
	Ctrlf := Character value: 12.
	Ctrlj := Character value: 165.
	Ctrlb := Character value: 166.
	CtrlZ := Character value: 231.
	CtrlV := Character value: 198.
	CtrlR := Character value: 239.
	Clear := Character value: 173.
	CtrlN := Character value: 245.
	BS := Character value: 8.
	CtrlJ := Character value: 229.
	Ctrly := Character value: 178.
	CtrlF := Character value: 226.
	BS2 := Character value: 158.
	Ctrlu := Character value: 21.
	CtrlB := Character value: 230.
	Ctrlq := Character value: 17.
	Ctrlm := Character value: 182.
	Ctrle := Character value: 130.
	CtrlDigits := #(159 144 143 128 127 129 131 180 149 135).
	Ctrli := Character value: 150.
	Ctrla := Character value: 1.
	Bold := 1.
	CtrlY := Character value: 242.
	CtrlU := Character value: 197.
	CR := Character value: 13.
	CtrlQ := Character value: 210.
	DefaultMask := Color black.
	CtrlM := Character value: 246.
	CtrlI := Character value: 214.
	Ctrlx := Character value: 151.
	CtrlE := Character value: 194.
	Ctrlt := Character value: 11.
	CtrlA := Character value: 212.
	Ctrlp := Character value: 138.
	DefaultBaseline := 12.! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Bold
	^Bold! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
DefaultBaseline
	^DefaultBaseline! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlL
	^CtrlL! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlb
	^Ctrlb! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlh
	^Ctrlh! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlv
	^Ctrlv! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrli
	^Ctrli! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Italic
	^Italic! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
DefaultSpace
	^DefaultSpace! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlH
	^CtrlH! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Clear
	^Clear! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlJ
	^CtrlJ! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlT
	^CtrlT! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrle
	^Ctrle! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrln
	^Ctrln! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlV
	^CtrlV! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrls
	^Ctrls! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
DefaultLineGrid
	^DefaultLineGrid! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
DefaultMask
	^DefaultMask! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
ESC
	^ESC! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlR
	^CtrlR! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlM
	^CtrlM! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlf
	^Ctrlf! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
DefaultRule
	^DefaultRule! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlC
	^CtrlC! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlE
	^CtrlE! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlX
	^CtrlX! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CR
	^CR! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlk
	^Ctrlk! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlG
	^CtrlG! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlw
	^Ctrlw! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlS
	^CtrlS! !

!TextConstants class methodsFor: 'backward compatibility' stamp: ''!
at: aSymbol
	
	^ self classPool at: aSymbol ifAbsent: [self TextSharedInformation at: aSymbol]! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlt
	^Ctrlt! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlD
	^CtrlD! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Centered
	^Centered! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
BS
	^BS! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlP
	^CtrlP! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlp
	^Ctrlp! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Basal
	^Basal! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlOpenBrackets
	^CtrlOpenBrackets! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlq
	^Ctrlq! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
LeftFlush
	^LeftFlush! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlm
	^Ctrlm! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlc
	^Ctrlc! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlo
	^Ctrlo! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
EndOfRun
	^EndOfRun! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlI
	^CtrlI! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
LeftMarginTab
	^LeftMarginTab! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrld
	^Ctrld! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
RightMarginTab
	^RightMarginTab! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlB
	^CtrlB! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlZ
	^CtrlZ! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlU
	^CtrlU! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Justified
	^Justified! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
Ctrlg
	^Ctrlg! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
DefaultTab
	^DefaultTab! !

!TextConstants class methodsFor: 'accessing' stamp: ''!
CtrlDigits
	^CtrlDigits! !

!TextContainer commentStamp: ''!
A TextContainer models the shape of an ownerMorph, possibly occluded by one or more occludingMorphs, and scans this shape to provide a list of rectangles suitable for layout of text.  It does this by displaying the shadow of the ownerMorph in black, and any occludingMorphs in white, on its shadowForm.  It then scans horizontal strips of appropriate height to find unbroken intervals of black, greater than minWidth in extent.  Conputation of the rectangles is done on demand, and results are cached so that text can be redisplayed without having to recompute the rectangles.!
!TextContainer methodsFor: 'container protocol' stamp: ''!
bottom

	"Note we should really check for contiguous pixels here"

	^ (self vertProfile findLast: [ :count | count >= minWidth ])
	  + shadowForm offset y! !

!TextContainer methodsFor: 'private' stamp: ''!
bounds

	| bounds theText |
	self fillsOwner ifFalse: [^ textMorph textBounds].
	theText := textMorph.
	bounds := theText owner innerBounds.
	bounds := bounds insetBy: (textMorph valueOfProperty: #margins ifAbsent: [1@1]).
	theText owner submorphsBehind: theText do:
		[:m | bounds := bounds merge: m fullBounds].
	^ bounds! !

!TextContainer methodsFor: 'container protocol' stamp: ''!
width
	"for compatibility"

	^ textMorph owner width! !

!TextContainer methodsFor: 'accessing' stamp: ''!
fillsOwner: aBoolean

	fillsOwner := aBoolean.
	self releaseCachedState! !

!TextContainer methodsFor: 'private' stamp: ''!
for: aTextMorph minWidth: wid

	textMorph := aTextMorph.
	minWidth := wid.
	fillsOwner := true.
	avoidsOcclusions := false! !

!TextContainer methodsFor: 'container protocol' stamp: ''!
left

	^ textMorph owner left! !

!TextContainer methodsFor: 'container protocol' stamp: ''!
translateBy: delta

	self releaseCachedState! !

!TextContainer methodsFor: 'private' stamp: ''!
computeShadow

	| canvas bounds theText |
	bounds := self bounds.
	theText := textMorph.
	canvas := (Display defaultCanvasClass extent: bounds extent depth: 1)
		asShadowDrawingCanvas: Color black.
	canvas translateBy: bounds topLeft negated during:[:tempCanvas| | back |
		self fillsOwner
			ifTrue: [tempCanvas fullDrawMorph: (theText owner copyWithoutSubmorph: theText)]
			ifFalse: [tempCanvas fillRectangle: textMorph bounds color: Color black].
		self avoidsOcclusions ifTrue:
			[back := tempCanvas form deepCopy.
			tempCanvas form fillWhite.
			theText owner submorphsInFrontOf: theText do:
				[:m | (textMorph isLinkedTo: m)
					ifTrue: []
					ifFalse: [tempCanvas fullDrawMorph: m]].
			back displayOn: tempCanvas form at: 0@0 rule: Form reverse].
	].
	shadowForm := canvas form offset: bounds topLeft.
	vertProfile := shadowForm  yTallyPixelValue: 1 orNot: false.
	rectangleCache := Dictionary new.
	^ shadowForm! !

!TextContainer methodsFor: 'accessing' stamp: ''!
avoidsOcclusions: aBoolean

	avoidsOcclusions := aBoolean.
	self releaseCachedState! !

!TextContainer methodsFor: 'container protocol' stamp: ''!
topLeft
	"for compatibility"

	^ textMorph owner topLeft! !

!TextContainer methodsFor: 'container protocol' stamp: ''!
rectanglesAt: lineY height: lineHeight 
	"Return a list of rectangles that are at least minWidth wide
	in the specified horizontal strip of the shadowForm.
	Cache the results for later retrieval if the owner does not change."

	| hProfile rects thisWidth thisX count pair outerWidth lineRect lineForm |
	pair := Array with: lineY with: lineHeight.
	rects := rectangleCache at: pair ifAbsent: [nil].
	rects ifNotNil: [^rects].
	outerWidth := minWidth + (2 * OuterMargin).
	self shadowForm.	"Compute the shape"
	lineRect := 0 @ (lineY - shadowForm offset y) 
				extent: shadowForm width @ lineHeight.
	lineForm := shadowForm copy: lineRect.

	"Check for a full line -- frequent case"
	(lineForm tallyPixelValues second) = lineRect area 
		ifTrue: 
			[rects := Array with: (shadowForm offset x @ lineY extent: lineRect extent)]
		ifFalse: 
			["No such luck -- scan the horizontal profile for segments of minWidth"

			hProfile := lineForm xTallyPixelValue: 1 orNot: false.
			rects := OrderedCollection new.
			thisWidth := 0.
			thisX := 0.
			1 to: hProfile size
				do: 
					[:i | 
					count := hProfile at: i.
					count >= lineHeight 
						ifTrue: [thisWidth := thisWidth + 1]
						ifFalse: 
							[thisWidth >= outerWidth 
								ifTrue: 
									[rects addLast: ((thisX + shadowForm offset x) @ lineY 
												extent: thisWidth @ lineHeight)].
							thisWidth := 0.
							thisX := i]].
			thisWidth >= outerWidth 
				ifTrue: 
					[rects addLast: ((thisX + shadowForm offset x) @ lineY 
								extent: thisWidth @ lineHeight)]].
	rects := rects collect: [:r | r insetBy: OuterMargin @ 0].
	rectangleCache at: pair put: rects.
	^rects! !

!TextContainer methodsFor: 'container protocol' stamp: ''!
top
	"Note we should really check for contiguous pixels here"

	| outerWidth |
	outerWidth := minWidth + (2 * OuterMargin).
	^ (self vertProfile findFirst: [ :count | count >= outerWidth ]) - 1
	  + shadowForm offset y! !

!TextContainer methodsFor: 'accessing' stamp: ''!
fillsOwner

	^ fillsOwner ifNil: [ true ]! !

!TextContainer methodsFor: 'accessing' stamp: ''!
releaseCachedState

	shadowForm := nil.
	vertProfile := nil.
	rectangleCache := Dictionary new! !

!TextContainer methodsFor: 'private' stamp: ''!
shadowForm

	shadowForm ifNil: [ self computeShadow ].
	^ shadowForm! !

!TextContainer methodsFor: 'accessing' stamp: ''!
textMorph

	^ textMorph! !

!TextContainer methodsFor: 'accessing' stamp: ''!
avoidsOcclusions

	^ avoidsOcclusions ifNil: [ false ]! !

!TextContainer methodsFor: 'private' stamp: ''!
vertProfile

	vertProfile ifNil: [ self computeShadow ].
	^ vertProfile! !

!TextContainer class methodsFor: 'class initialization' stamp: ''!
initialize

	OuterMargin := 2! !

!TextConverter commentStamp: ''!
The abstract class for all different type of text converters.  nextFromStream: and nextPut:toStream: are the public accessible methods.  If you are going to make a subclass for a stateful text conversion, you should override restoreStateOf:with: and saveStateOf: along the line of CompoundTextConverter.
!
!TextConverter methodsFor: 'friend' stamp: ''!
saveStateOf: aStream

	^ aStream position.
! !

!TextConverter methodsFor: 'initialization' stamp: ''!
initialize
	latin1Map := self class latin1Map.
	latin1Encodings := self class latin1Encodings.! !

!TextConverter methodsFor: 'converting' stamp: ''!
next: anInteger putAll: aString startingAt: startIndex toStream: aStream
	"Handle fast conversion if ByteString"
             
   aString class == ByteString ifFalse: [
		startIndex to: startIndex + anInteger - 1 do: [ :index | 
			self nextPut: (aString at: index) toStream: aStream ].
      ^aString ].
	aStream isBinary ifTrue: [
		aStream basicNext: anInteger putAll: aString startingAt: startIndex.
		^aString ].
        
	^self next: anInteger putByteString: aString startingAt: startIndex toStream: aStream! !

!TextConverter methodsFor: 'private' stamp: ''!
nextPutByteString: aString toStream: aStream

	"This is a reasonable default which speeds up conversion of encodings which have a partial match with latin1 encoding (for instance ascii supersets)"
	| lastIndex nextIndex |
	lastIndex := 1.
	[nextIndex := ByteString findFirstInString: aString inSet: latin1Map startingAt: lastIndex.
	nextIndex = 0] whileFalse:
		[aStream next: nextIndex-lastIndex putAll: aString startingAt: lastIndex.
		aStream basicNextPutAll: (latin1Encodings at: (aString byteAt: nextIndex)+1).
		lastIndex := nextIndex + 1].
	aStream basicNext: aString size-lastIndex+1 putAll: aString startingAt: lastIndex.! !

!TextConverter methodsFor: 'converting' stamp: ''!
convertToSystemString: aString

	| writeStream |
	writeStream := String new writeStream.
	self nextPutAll: aString toStream: writeStream.
	self emitSequenceToResetStateIfNeededOn: writeStream.
	^writeStream contents! !

!TextConverter methodsFor: 'converting' stamp: ''!
nextPutAll: aString toStream: aStream
	"Handle fast conversion if ByteString"
	
	aString class == ByteString ifFalse: [
		aString do: [:char | self nextPut: char toStream: aStream].
		^self].
	
	aStream isBinary ifTrue: [
		aStream basicNextPutAll: aString.
		^self].
	self nextPutByteString: aString toStream: aStream.
	^self
! !

!TextConverter methodsFor: 'initialization' stamp: ''!
installLineEndConvention: lineEndStringOrNil

	
	lineEndStringOrNil ifNotNil:
		[latin1Encodings := latin1Encodings copy.
		latin1Encodings at: Character cr asciiValue + 1 put: (self convertFromSystemString: lineEndStringOrNil).
		latin1Map := ByteString nonAsciiMap copy.
		latin1Map at: Character cr asciiValue + 1 put: 1]! !

!TextConverter methodsFor: 'converting' stamp: ''!
convertFromSystemString: aString

	| readStream writeStream |
	readStream := aString readStream.
	writeStream := String new writeStream.

	[readStream atEnd] whileFalse: [
		writeStream nextPut: (self nextFromStream: readStream)].
	^writeStream contents
! !

!TextConverter methodsFor: 'friend' stamp: ''!
emitSequenceToResetStateIfNeededOn: aStream
! !

!TextConverter methodsFor: 'friend' stamp: ''!
restoreStateOf: aStream with: aConverterState

	aStream position: aConverterState.
! !

!TextConverter methodsFor: 'converting' stamp: ''!
nextFromStream: aStream

	self subclassResponsibility.
! !

!TextConverter methodsFor: 'private' stamp: ''!
next: anAmount putByteString: aString startingAt: startIndex toStream: aStream

	"This is a reasonable default which speeds up conversion of encodings which have a partial match with latin1 encoding (for instance ascii supersets)"
	| lastIndex nextIndex |
	lastIndex := startIndex.
	[nextIndex := ByteString findFirstInString: aString inSet: latin1Map startingAt: lastIndex.
	nextIndex = 0 or: [nextIndex >= (startIndex + anAmount) ]] whileFalse:
		[aStream next: nextIndex-lastIndex putAll: aString startingAt: lastIndex.
		aStream basicNextPutAll: (latin1Encodings at: (aString byteAt: nextIndex)+1).
		lastIndex := nextIndex + 1].
	aStream basicNext: anAmount - lastIndex + startIndex putAll: aString startingAt: lastIndex.! !

!TextConverter methodsFor: 'converting' stamp: ''!
nextPut: aCharacter toStream: aStream

	self subclassResponsibility.
! !

!TextConverter class methodsFor: 'utilities' stamp: ''!
allEncodingNames
	"TextConverter allEncodingNames"
	| encodingNames |
	encodingNames := Set new.
	self allSubclasses
		do: [:each | 
			| names | 
			names := each encodingNames.
			names notEmpty
				ifTrue: [encodingNames add: names first asSymbol]].
	^encodingNames! !

!TextConverter class methodsFor: 'accessing' stamp: ''!
initializeLatin1MapAndEncodings
	"Initialize the latin1Map and latin1Encodings.
	These variables ensure that conversions from latin1 ByteString is reasonably fast"
	
	| latin1 utf8 |
	latin1Map := ByteArray new: 256.
	latin1Encodings := Array new: 256.
	0 to: 255 do:[:i|
		utf8 := (String new: 8) writeStream.
		latin1 := String with: (Character value: i).
		self new nextPut: latin1 first toStream: utf8.
		utf8 := utf8 contents.
		latin1 = utf8 ifTrue:[
			latin1Map at: i+1 put: 0. "no translation needed"
		] ifFalse:[
			latin1Map at: i+1 put: 1. "translation needed"
			latin1Encodings at: i+1 put: utf8.
		].
	].! !

!TextConverter class methodsFor: 'accessing' stamp: ''!
latin1Map
	"Answer a ByteArray map telling if latin1 characters needs conversion or not"

	^latin1Map ifNil:
		[self initializeLatin1MapAndEncodings.
		latin1Map]! !

!TextConverter class methodsFor: 'accessing' stamp: ''!
latin1Encodings
	"Answer an Array mapping latin1 characters to conversion string"

	^latin1Encodings ifNil:
		[self initializeLatin1MapAndEncodings.
		latin1Encodings]! !

!TextConverter class methodsFor: 'instance creation' stamp: ''!
default

	^ UTF8TextConverter new.
! !

!TextConverter class methodsFor: 'accessing' stamp: ''!
encodingNames 

	^ #() copy.
! !

!TextConverter class methodsFor: 'instance creation' stamp: ''!
defaultConverterClassForEncoding: encodingName
	"TextConverter defaultConverterClassForEncoding: 'shift-jis'"

	^ self allSubclasses
		detect: [:class | class encodingNames includes: encodingName]
		ifNone: []
! !

!TextDiffBuilder commentStamp: ''!
I implement the diff algorithm. I can show the differences between two texts. See my method comments for further information.

Instance Variables
	xLines:		<Array>
	yLines:		<Array>

xLines
	- an Array of DiffElement which is created from the first input text

yLines
	- an Array of DiffElement which is created from the second input text!
!TextDiffBuilder methodsFor: 'creating patches' stamp: ''!
buildDisplayPatch

	^Text streamContents: [ :stream |
		self 
			patchSequenceDoIfMatch: [ :string |
				self print: string withAttributes: NormalTextAttributes on: stream ]
			ifInsert: [ :string |
				self print: string withAttributes: InsertTextAttributes on: stream ]
			ifRemove: [ :string |
				self print: string withAttributes: RemoveTextAttributes on: stream ] ]! !

!TextDiffBuilder methodsFor: 'private' stamp: ''!
split: aString
	"I return an Array of strings which are the lines extracted from aString. All lines contain the line separator characters, or not depending on preference."

	^Array streamContents: [ :stream |
		self class ignoreLineEndings
			ifTrue: [aString lineIndicesDo: [ :start :endWithoutSeparators :end |
				stream nextPut: (aString copyFrom: start to: endWithoutSeparators) ] ]
			ifFalse: [aString lineIndicesDo: [ :start :endWithoutSeparators :end |
				stream nextPut: (aString copyFrom: start to: end) ] ] ]! !

!TextDiffBuilder methodsFor: 'private' stamp: ''!
print: aString withAttributes: attributes on: stream

	stream
		withAttributes: attributes 
		do: [ 
			stream nextPutAll: aString.
			(aString notEmpty and: [ 
				aString last = Character cr or: [
					aString endsWith: String crlf ] ]) 
						ifFalse: [ stream cr ] ]! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: ''!
patchSequenceDoIfMatch: matchBlock ifInsert: insertBlock ifRemove: removeBlock
	"I'm the general purpose method to iterate through the patch sequence. See my senders to learn how to use me."

	| xLine xLineStream |
	xLineStream := xLines readStream.
	yLines
		do: [ :yLine | 
			yLine hasMatch
				ifFalse: [ insertBlock value: yLine string ]
				ifTrue: [ 
					[ (xLine := xLineStream next) isNil or: [ xLine == yLine match ] ] whileFalse: [ removeBlock value: xLine string ].
					matchBlock value: yLine string ] ].
	[ (xLine := xLineStream next) isNil ] whileFalse: [ removeBlock value: xLine string ]! !

!TextDiffBuilder methodsFor: 'initialize' stamp: ''!
from: xString to: yString

	xLines := (self split: xString asString) replace: [ :each | DiffElement string: each ].
	yLines := (self split: yString asString) replace: [ :each | DiffElement string: each ].
	self findMatches! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: ''!
buildPatchSequence
	"This method is only implemented for backwards compatibility and testing."

	^Array streamContents: [ :stream |
		self 
			patchSequenceDoIfMatch: [ :string |
				stream nextPut: #match -> string ]
			ifInsert: [ :string | 
				stream nextPut: #insert -> string ]
			ifRemove: [ :string | 
				stream nextPut: #remove -> string ] ]! !

!TextDiffBuilder methodsFor: 'private' stamp: ''!
lcsFor: xFilteredLines and: yFilteredLines
	"I find one of the longest common subsequences of my the arguments. I assume that none of my arguments are empty. I return nil or an Array which represents a list. The first two elements are the matching line numbers, the last is the next node in the list or nil if there are no more elements. The list containts the longest common subsequence. I'm a modified version of the greedy lcs algorithm from the 6th page of 'An O(ND) Difference Algorithm and Its Variations (1986)' by Eugene W. Myers"

	| n m v lcss max |
	n := xFilteredLines size.
	m := yFilteredLines size.
	max := m + n.
	v := Array new: 2 * max + 1.
	v at: max + 2 put: 0.
	lcss := Array new: 2 * max + 1.
	0 to: max do: [ :d |
		d negated to: d by: 2 do: [ :k |
			| index lcs x y |
			index := max + k.
			(k + d = 0 or: [ k ~= d and: [ (v at: index) < (v at: index + 2) ] ])
				ifTrue: [ x := v at: (index := index + 2) ]
				ifFalse: [ x := (v at: index) + 1 ].
			y := x - k.
			lcs := lcss at: index.
			[ x < n and: [ y < m and: [ (xFilteredLines at: x + 1) = (yFilteredLines at: y + 1) ] ] ]
				whileTrue: [
					lcs := { x := x + 1. y := y + 1. lcs } ].
			(x >= n and: [ y >= m ]) ifTrue: [ ^lcs ].
			v at: max + k + 1 put: x.
			lcss at: max + k + 1 put: lcs ] ].
	self error! !

!TextDiffBuilder methodsFor: 'private' stamp: ''!
findMatches
	"I find the matching pairs of xLines and yLines. First I filter out all lines that can't have a pair, then I find the longest common subsequence of the remaining elements. Finally I mark the matching pairs."

	| temp lcs xFilteredLines yFilteredLines xNumbers yNumbers |
	"Filter out all lines that can't have a pair."
	temp := yLines asSet.
	xFilteredLines := xLines select: [ :each | temp includes: each ].
	xFilteredLines ifEmpty: [ ^ self ].
	temp := xLines asSet.
	yFilteredLines := yLines select: [ :each | temp includes: each ].
	yFilteredLines ifEmpty: [ ^ self ].	"Map all lines to SmallIntegers, because they can be compared faster."
	temp := Dictionary new.
	xNumbers := xFilteredLines collect: [ :each | temp at: each ifAbsentPut: [ temp size ] ].
	yNumbers := yFilteredLines collect: [ :each | temp at: each ifAbsentPut: [ temp size ] ].
	temp := nil.	"Find the longest common subsequence."
	lcs := self lcsFor: xNumbers and: yNumbers.	"Mark the matching pairs."
	[ lcs isNil ]
		whileFalse: [ 
			(xFilteredLines at: (lcs at: 1)) matches: (yFilteredLines at: (lcs at: 2)).
			lcs := lcs at: 3 ]! !

!TextDiffBuilder class methodsFor: 'settings' stamp: ''!
diffsWithPrettyPrint
	^ DiffsWithPrettyPrint ifNil: [DiffsWithPrettyPrint := false]! !

!TextDiffBuilder class methodsFor: 'class initialization' stamp: ''!
initialize

	self initializeTextAttributes! !

!TextDiffBuilder class methodsFor: 'instance creation' stamp: ''!
buildDisplayPatchFrom: sourceText to: destinationText

	^(self from: sourceText to: destinationText) buildDisplayPatch! !

!TextDiffBuilder class methodsFor: 'instance creation' stamp: ''!
buildDisplayPatchFrom: sourceText to: destinationText inClass: sourceClass 

	^self 
		buildDisplayPatchFrom: sourceText 
		to: destinationText
		inClass: sourceClass
		prettyDiffs: self diffsWithPrettyPrint
		! !

!TextDiffBuilder class methodsFor: 'instance creation' stamp: ''!
from: srcString to: dstString inClass: srcClass
	"srcClass not used when not pretty printing, but have it for polymorphism with PrettyTextDiffBuilder"

	^self new from: srcString to: dstString! !

!TextDiffBuilder class methodsFor: 'settings' stamp: ''!
ignoreLineEndings: aBoolean
	"Setting for  if line ending differences should be ignored or emphasized"
	
	IgnoreLineEndings := aBoolean! !

!TextDiffBuilder class methodsFor: 'class initialization' stamp: ''!
initializeTextAttributes

	InsertTextAttributes :=  {TextEmphasis bold. TextColor color: Color green muchDarker}.
	RemoveTextAttributes := {TextEmphasis bold. TextColor color: Color red darker} .
	NormalTextAttributes :={ TextEmphasis normal }! !

!TextDiffBuilder class methodsFor: 'instance creation' stamp: ''!
from: srcString to: dstString

	^self new from: srcString to: dstString! !

!TextDiffBuilder class methodsFor: 'settings' stamp: ''!
ignoreLineEndings
	"Answer a boolean telling if line endings differences should be ignored or emphasized"
	
	^IgnoreLineEndings ifNil: [ true ]! !

!TextDiffBuilder class methodsFor: 'settings' stamp: ''!
diffsWithPrettyPrint: aBoolean
	DiffsWithPrettyPrint := aBoolean! !

!TextDiffBuilder class methodsFor: 'instance creation' stamp: ''!
buildDisplayPatchFrom: srcString to: dstString inClass: srcClass prettyDiffs: prettyDiffs 
	"Build a display patch for mapping via diffs from srcString to dstString
	in the given class. If prettyDiffs is true, do the diffing for pretty-printed forms"

	| differ |
	differ := prettyDiffs
				ifTrue: [PrettyTextDiffBuilder]
				ifFalse: [self].
	^ (differ
		from: srcString
		to: dstString
		inClass: srcClass) buildDisplayPatch! !

!TextDiffBuilder class methodsFor: 'settings' stamp: ''!
differatorSettingsOn: aBuilder 
	<systemsettings>
	(aBuilder group: #differator) 
		label: 'Code Diffs';
		parent: #codeBrowsing; 
		description: 'All settings concerned with the computation of diffs' ;
		with: [	
			(aBuilder setting: #ignoreLineEndings) 
				label: 'Ignore line endings';
				target: self;
				default: true;
		 		description: 'When selected, line ending differences will be ignored ' ];
		with: [  
		(aBuilder setting: #diffsWithPrettyPrint)
				target: self;	
				default: false;
				label: 'Pretty print differences' ;
				description: 'If true, displays of source code differences will be pretty-printed first' 
		]! !

!TextDiffBuilderTest commentStamp: ''!
Tests for the new algorithm that is diffing changes.
Tests from L. Uzonyi (from squeak trunk System.ul207and 208)!
!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testEmptySequences
	| patch |
	patch := self patchSequenceFor: #() and: #().
	self assertEmpty: patch! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testIfSequence6

	| patch |
	patch := self patchSequenceFor: #(a b c d) and: #(d a b c).
	self assert: patch size equals: 5.	"lcs is abc"
	self assert: (patch count: [ :each | each key = #match ]) equals: 3.
	self assert: (patch count: [ :each | each key = #insert ]) equals: 1.
	self assert: (patch count: [ :each | each key = #remove ]) equals: 1.
	patch do: [ :each | 
		each key = #match 
			ifTrue: [ self assert: ('abc' includes: each value first) ]
			ifFalse: [ self assert: each value first equals: $d ] ]! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testEmptyLcs1

	| patch |
	patch := self patchSequenceFor: #(a b c) and: #().
	self assert: patch size equals: 3.
	self assert: (patch allSatisfy: [ :each | each key = #remove ])! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testIfSequence1

	| patch |
	patch := self patchSequenceFor: #(a b c d) and: #(d c b a).
	self assert: patch size equals: 7.	"lcs is any one letter sequence"
	self assert: (patch count: [ :each | each key = #match ]) equals: 1.
	self assert: (patch count: [ :each | each key = #insert ]) equals: 3.
	self assert: (patch count: [ :each | each key = #remove ]) equals: 3.
	patch do: [ :each | 
		each key = #match 
			ifTrue: [ self assert: each value first equals: $d ]
			ifFalse: [ self assert: ('abc' includes: each value first) ] ]! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testIfSequence5

	| patch matches nonMatches |
	patch := self patchSequenceFor: #(a b c d) and: #(c d a b).
	self assert: patch size equals: 6.	"lcs is ab or cd"
	matches := (patch select: [ :each | each key = #match ])
		collect: [ :each | each value first ] as: String.
	self assert: (#('ab' 'cd') includes: matches).
	self assert: (patch count: [ :each | each key = #insert ]) equals: 2.
	self assert: (patch count: [ :each | each key = #remove ]) equals: 2.
	nonMatches := #('ab' 'cd') detect: [ :each | each ~= matches ].
	patch do: [ :each | 
		each key = #match 
			ifTrue: [ self assert: (matches includes: each value first) ]
			ifFalse: [ self assert: (nonMatches includes: each value first) ] ]! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testSameSequenceWithRepetitions

	| patch |
	patch := self patchSequenceFor: #(a a b a) and: #(a a b a).
	self assert: patch size equals: 4.	
	self assert: (patch allSatisfy: [ :each | each key = #match ])! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testIfPatchIsMinimal
	| patch |
	patch := self patchSequenceFor: #(a a a b) and: #(a b a a).
	self assert: patch size equals: 5.	"lcs is aaa"
	self assert: (patch count: [ :each | each key = #match ]) equals: 3.
	self assert: (patch count: [ :each | each key = #insert ]) equals: 1.
	self assert: (patch count: [ :each | each key = #remove ]) equals: 1.
	patch do: [ :each | each key = #match ifTrue: [ self assert: each value first equals: $a ] ifFalse: [ self assert: each value first equals: $b ] ]! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testEmptyLcs3

	| patch |
	patch := self patchSequenceFor: #(a b c) and: #(d e f g).
	self assert: patch size equals: 7.	
	patch do: [ :each |
		each key = #remove ifTrue: [ self assert: ('abc' includes: each value first) ].
		each key = #insert ifTrue: [ self assert: ('defg' includes: each value first) ] ]! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testIfSequence3

	| patch |
	patch := self patchSequenceFor: #(a b c d) and: #(b d c a).
	self assert: patch size equals: 6.	"lcs is bd"
	self assert: (patch count: [ :each | each key = #match ]) equals: 2.
	self assert: (patch count: [ :each | each key = #insert ]) equals: 2.
	self assert: (patch count: [ :each | each key = #remove ]) equals: 2.
	patch do: [ :each | 
		each key = #match 
			ifTrue: [ self assert: ('bd' includes: each value first) ]
			ifFalse: [ self assert: ('ac' includes: each value first) ] ]! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testSameSequence

	| patch |
	patch := self patchSequenceFor: #(a b c) and: #(a b c).
	self assert: patch size equals: 3.	
	self assert: (patch allSatisfy: [ :each | each key = #match ])! !

!TextDiffBuilderTest methodsFor: 'private' stamp: ''!
convertToString: array

	^String streamContents: [ :stream |
		array do: [ :each |
			stream nextPutAll: each asString; cr ] ]! !

!TextDiffBuilderTest methodsFor: 'private' stamp: ''!
patchSequenceFor: x and: y

	^(TextDiffBuilder
		from: (self convertToString: x)
		to:  (self convertToString: y)) buildPatchSequence! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testEmptyLcs2

	| patch |
	patch := self patchSequenceFor: #() and: #(a b c).
	self assert: patch size equals: 3.	
	self assert: (patch allSatisfy: [ :each | each key = #insert ])! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testIfSequence2

	| patch |
	patch := self patchSequenceFor: #(a b c d) and: #(c d b a).
	self assert: patch size equals: 6.	"lcs is cd"
	self assert: (patch count: [ :each | each key = #match ]) equals: 2.
	self assert: (patch count: [ :each | each key = #insert ]) equals: 2.
	self assert: (patch count: [ :each | each key = #remove ]) equals: 2.
	patch do: [ :each | 
		each key = #match 
			ifTrue: [ self assert: ('cd' includes: each value first) ]
			ifFalse: [ self assert: ('ab' includes: each value first) ] ]! !

!TextDiffBuilderTest methodsFor: 'tests' stamp: ''!
testIfSequence4

	| patch |
	patch := self patchSequenceFor: #(a b c d) and: #(d b c a).
	self assert: patch size equals: 6.	"lcs is bc"
	self assert: (patch count: [ :each | each key = #match ]) equals: 2.
	self assert: (patch count: [ :each | each key = #insert ]) equals: 2.
	self assert: (patch count: [ :each | each key = #remove ]) equals: 2.
	patch do: [ :each | 
		each key = #match 
			ifTrue: [ self assert: ('bc' includes: each value first) ]
			ifFalse: [ self assert: ('ad' includes: each value first) ] ]! !

!TextDoIt commentStamp: ''!
A doIt action on a text. When the text is clicked the text is seen as source code and evaluated (Not really true as both 
the portion of text and its DoIt attribute need to hold the same string)

| stream |
stream := TextStream on: (Text new: 100).
stream 
	withAttribute: (TextDoIt evalString: 'Smalltalk tools browser open')
	do: [ stream nextPutAll: 'Some action...' ].
TextMorph new 
	newContents: stream contents;
	openInWindow .

!
!TextDoIt methodsFor: 'accessing' stamp: ''!
evalString: str
	evalString := str ! !

!TextDoIt methodsFor: '*Text-Edition' stamp: ''!
actOnClick: anEvent for: anObject in: paragraph editor: editor

	"Note: evalString gets evaluated IN THE CONTEXT OF anObject
	 -- meaning that self and all instVars are accessible"
	Smalltalk compiler receiver: anObject; evaluate: evalString.
	^ true ! !

!TextDoIt methodsFor: 'testing' stamp: ''!
analyze: aString

	| list |
	list := super analyze: aString.
	evalString := list at: 1.
	^ list at: 2! !

!TextDoIt methodsFor: 'accessing' stamp: ''!
info
	^ evalString! !

!TextDoIt class methodsFor: 'instance creation' stamp: ''!
evalString: str
	^ self new evalString: str! !

!TextDoIt class methodsFor: 'instance creation' stamp: ''!
scanFrom: strm
	"read a doit in the funny format used by Text styles on files. d10 factorial;;  end with two semicolons"

	| pos end doit |
	pos := strm position.
	[strm skipTo: $;. strm peek == $;] whileFalse.
	end := strm position - 1.
	strm position: pos.
	doit := strm next: end-pos.
	strm skip: 2.  ";;"
	^ self evalString: doit! !

!TextEditor commentStamp: ''!
My instances edit Text, this is, they support multiple lines and TextAttributes.
They have no specific facilities for editing Smalltalk code. Those are found in RubSmalltalkEditor.!
!TextEditor methodsFor: 'editing keys' stamp: ''!
compareToClipboard: aKeyboardEvent
	"Compare the receiver to the text on the clipboard."

	self compareToClipboard.
	^ true! !

!TextEditor methodsFor: 'typing support' stamp: ''!
closeTypeIn
	"See comment in openTypeIn. It is important to call
	closeTypeIn before executing any non-typing key, making a new selection, etc. It is
	called automatically for menu commands."
	self startOfTyping 
		ifNotNil: [self addTypeInUndoRecord.
			self doneTyping]! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
paste: aKeyboardEvent 
	"Replace the current text selection by the text in the shared buffer."

	self closeTypeIn.
	self paste.
	^true! !

!TextEditor methodsFor: 'private' stamp: ''!
getPluggableYellowButtonMenu: shiftKeyState
	| customMenu |
	^ (morph notNil and: [(customMenu := morph getMenu: shiftKeyState) notNil])
		ifTrue: [customMenu]
		ifFalse:
			[shiftKeyState
				ifTrue: [self shiftedYellowButtonMenu]
				ifFalse: [self yellowButtonMenu]]! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
cursorLeft: aKeyboardEvent 
	"Private - Move cursor left one character if nothing selected, otherwise 
	move cursor to beginning of selection. If the shift key is down, start 
	selecting or extending current selection. Don't allow cursor past 
	beginning of text"

	self closeTypeIn.
	self      
		moveCursor:[:position | 
			self class skipOverMultipleSpaces 
				ifTrue: [ self previousNonBlank: position ]
				ifFalse: [ position - 1 max: 1 ]
			 ]
		forward: false
		specialBlock:[:position | self previousWord: position]
		event: aKeyboardEvent.
	^ true! !

!TextEditor methodsFor: 'testing' stamp: ''!
isTextEditor
	^ true ! !

!TextEditor methodsFor: 'private' stamp: ''!
paragraph
	^ morph 
		ifNotNil: [morph paragraph]
		ifNil: [self error: 'paragraph is not available']! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
pointBlock
	^ self editingState pointBlock! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
selectWord: aKeyboardEvent

	self closeTypeIn.
	self selectWord.
	^ true! !

!TextEditor methodsFor: 'accessing' stamp: ''!
emphasisHere
	^ self editingState emphasisHere! !

!TextEditor methodsFor: 'new selection' stamp: ''!
selectInvisiblyMark: mark point: point
	"Select the designated characters, inclusive.  Make no visual changes."

	self markIndex: mark; pointIndex: point + 1! !

!TextEditor methodsFor: 'new selection' stamp: ''!
selectAt: characterIndex 
	"Place the caret before the character at characterIndex.
	 Be sure it is in view."

	self selectFrom: characterIndex to: characterIndex - 1! !

!TextEditor methodsFor: 'undoers - redoers' stamp: ''!
undoTypeIn: aText interval: anInterval
	self selectInterval: anInterval.
	self replace: anInterval with: aText and:
		[self selectInterval: (anInterval first to: anInterval first - 1)].
! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
setSearchString: aKeyboardEvent
	"Establish the current selection as the current search string."
	^ self setSearchString! !

!TextEditor methodsFor: 'private' stamp: ''!
encompassParagraph: anInterval
	"Return an interval that includes anInterval, and that comprises one or several whole paragraphs in the receiver.
	Answer starts at the position following a cr (or eventually 1) and ends at a cr (or eventually at self size)"
	^ self string encompassParagraph: anInterval
! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
swapChars: aKeyboardEvent
	"Triggered byCmd-Y;.  Swap two characters, either those straddling the insertion point, or the two that comprise the selection.  Suggested by Ted Kaehler.  "

	| currentSelection aString chars |
	(chars := self selection) size = 0
		ifTrue:
			[currentSelection := self pointIndex.
			self selectMark: currentSelection - 1 point: currentSelection]
		ifFalse:
			[chars size = 2
				ifFalse:
					[morph flash. ^ true]
				ifTrue:
					[currentSelection := self pointIndex - 1]].
	aString := self selection string.
	self replaceSelectionWith: (Text string: aString reversed attributes: self emphasisHere).
	self selectAt: currentSelection + 1.
	^ true! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
changeEmphasis

	|  reply code align menuList startIndex attribute choices |
	choices := self emphasisChoices.
	startIndex := self startIndex.
	align := self text alignmentAt: startIndex ifAbsent: [ 0 ].
	code := self text emphasisAt: startIndex.
	menuList := WriteStream on: Array new.
	menuList nextPut: (code isZero ->  'normal' translated).
	menuList nextPutAll: (choices  collect: [:emph|
							(code anyMask: (TextEmphasis perform: emph) emphasisCode)
								-> emph asString translated ]).
						
	menuList nextPut: ((self text attributesAt: startIndex)
							anySatisfy: [ :attr | attr isKern and: [attr kern < 0 ]]) -> 'narrow' translated.
	reply := UIManager default chooseFrom:  choices values: choices.
	reply notNil 
		ifTrue: [ attribute := TextEmphasis perform: reply.
				self applyAttribute:  attribute].
	^ true! !

!TextEditor methodsFor: 'accessing' stamp: ''!
currentAttributes
	"Redefined by subclasses that handle TextAttributes"
	^nil! !

!TextEditor methodsFor: 'private' stamp: ''!
applyAttribute: aTextAttribute
	"The user selected aTextAttribute via shortcut, menu or other means.
	If there is a selection, apply the attribute to the selection.
	In any case use the attribute for the user input (emphasisHere)"

	self editingState emphasisHere: (Text addAttribute: aTextAttribute toArray: self emphasisHere).
	self selection
		ifEmpty: [ self paragraph composeAll ]
		ifNotEmpty: [:sel | self replaceSelectionWith: (sel addAttribute: aTextAttribute).
			self paragraph composeAll.
			self recomputeSelection]! !

!TextEditor methodsFor: 'scrolling' stamp: ''!
scrollBy: ignore 
	"Ignore scroll requests."
! !

!TextEditor methodsFor: 'new selection' stamp: ''!
insertAndSelect: aString at: anInteger

	self replace: (anInteger to: anInteger - 1)
		with: (Text string: (' ' , aString)
					attributes: self emphasisHere)
		and: [self ]! !

!TextEditor methodsFor: 'new selection' stamp: ''!
selectInterval: anInterval
	"Select the specified characters inclusive.
	 Be sure the selection is in view."

	self selectFrom: anInterval first to: anInterval last! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findText: aStringOrText
	self findReplaceService findText: aStringOrText ! !

!TextEditor methodsFor: 'new selection' stamp: ''!
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
! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
chooseColor
	"Make a new Text Color Attribute, let the user pick a color, and return the attribute"

	| attribute |	
	attribute := TextColor color: Color black "default".
	UIManager default chooseColor
		ifNotNil: [:nc | attribute color: nc].
	^ attribute
! !

!TextEditor methodsFor: 'initialization' stamp: ''!
stateArrayPut: stateArray
	editingState := stateArray at: 1.
! !

!TextEditor methodsFor: 'accessing' stamp: ''!
editingStateClass
	^ EditingState! !

!TextEditor methodsFor: 'typing support' stamp: ''!
openTypeIn
	"Set up startOfTyping to keep track of the leftmost backspace.
	 You can't undo typing until after closeTypeIn."

	self startOfTyping 
		ifNil: [self editingState previousInterval: (1 to: 0) selection: self nullText.
			self startOfTyping: self startIndex]! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
chooseAlignment
	self changeAlignment! !

!TextEditor methodsFor: 'shortcuts' stamp: ''!
installKeymappingsOn: aMorph
 	aMorph attachKeymapCategory: #TextEditor.
	aMorph attachKeymapCategory: #TextMorph targetting: aMorph textMorph.
	aMorph attachKeymapCategory: #TextMorphTab! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findAll: aRegex startingAt: searchIdx 
	| ranges |
	ranges := aRegex matchingRangesIn: (self string copyFrom: searchIdx to: self string size).
	^ ranges collect: [:i | i + searchIdx - 1]
			! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findPrevious: aRegex startingAt: searchIdx 
	| allRanges |
	allRanges := self findAll: aRegex endingAt: searchIdx.
	^ allRanges notEmpty
		ifTrue: [allRanges last].
! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
unselect
	self markBlock: self pointBlock copy! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
stopBlock
	^ self editingState pointBlock max: self editingState markBlock! !

!TextEditor methodsFor: 'private' stamp: ''!
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].
	self setEmphasisHereFromTextForward: forward! !

!TextEditor methodsFor: 'private' stamp: ''!
exchangeWith: prior
	"If the prior selection is non-overlapping and legal, exchange the text of
	 it with the current selection and leave the currently selected text selected
	 in the location of the prior selection (or leave a caret after a non-caret if it was
	 exchanged with a caret).  If both selections are carets, flash & do nothing.
	 Don't affect the paste buffer.  Undoer: itself; Redoer: Undoer."

	| start stop before currSelection priorSelection delta redoArgs altInterval undoArgs |
	start := self startIndex.
	stop := self stopIndex - 1.
	(((prior first <= prior last) or: [ start <= stop]) "Something to exchange" and:
			[self isDisjointFrom: prior])
		ifTrue:
			[before := prior last < start.
			currSelection := self selection.
			priorSelection := self text copyFrom: prior first to: prior last.
			delta := before ifTrue: [0] ifFalse: [priorSelection size - currSelection size].
			self zapSelectionWith: priorSelection.
			redoArgs := { prior. start to: stop}.
						
			self selectFrom: prior first + delta to: prior last + delta.
			delta := before ifTrue: [stop - prior last] ifFalse: [start - prior first].
			self zapSelectionWith: currSelection.
			
			altInterval := prior first + delta to: prior last + delta.
			undoArgs := {altInterval. self startIndex to: self stopIndex - 1}.
			"self undoer: #exchangeWith: with: altInterval."
			prior first > prior last ifTrue: [self selectAt: self editingState previousInterval last + 1].
			self editingState
				redoArray: { morph. #undoRedoExchange:with:. redoArgs} 
				undoArray: {morph. #undoRedoExchange:with:. undoArgs}]
		ifFalse:
			[morph flash]! !

!TextEditor methodsFor: 'private' stamp: ''!
isDisjointFrom: anInterval
	"Answer true if anInterval is a caret not touching or within the current
	 interval, or if anInterval is a non-caret that does not overlap the current
	 selection."

	| fudge |
	fudge := anInterval size = 0 ifTrue: [1] ifFalse: [0].
	^(anInterval last + fudge < self startIndex or:
			[anInterval first - fudge >= self stopIndex])
! !

!TextEditor methodsFor: 'parenblinking' stamp: ''!
blinkParenAt: parenLocation 
	self text
		addAttribute: TextEmphasis bold
		from: parenLocation
		to: parenLocation.
	self editingState lastParenLocation: parenLocation.! !

!TextEditor methodsFor: 'constants' stamp: ''!
alignmentChoices
	"Return the symbols representing the TextAlignment operations to get a text aligned."
	
	^ #(leftFlush centered justified rightFlush)! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
cut: aKeyboardEvent 
	"Cut out the current text selection."

	self cut.
	^true! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
makeCapitalized: aKeyboardEvent
	"Force the current selection to uppercase.  Triggered by Cmd-z."

	| prev |
	self closeTypeIn.
	prev := $-.  "not a letter"
	self replaceSelectionWith: (Text fromString:
		(self selection string collect:
			[:c | prev := prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]])).
	^ true! !

!TextEditor methodsFor: 'constants' stamp: ''!
emphasisChoices
	"Return the list of emphasis that are possible to apply on the currently edited text morph"
	
	^  #(normal bold italic narrow underlined struckOut).	
	! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
findAgain

	"Find the text-to-find again."

	| where |

	where := self findReplaceService
		findNextSubstring: self findReplaceService findString
		inTextMorph: self morph.
	where ifNil: [ self flash ] ifNotNil: [ self selectInterval: where ].
	^ where! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
makeUppercase: aKeyboardEvent
	"Force the current selection to uppercase.  Triggered by Cmd-Y."

	self closeTypeIn.
	self replaceSelectionWith: (Text fromString: (self selection string asUppercase)).
	^ true! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
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! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
selectAll

	self selectFrom: 1 to: self string size! !

!TextEditor methodsFor: 'events' stamp: ''!
transformedFrom: uberMorph

	^ self morph transformedFrom: uberMorph! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
copySelection
	"Copy the current selection and store it in the paste buffer, unless a caret.  Undoer & Redoer: undoCutCopy"

	self lineSelectAndEmptyCheck: [^ self].
	self clipboardTextPut: self selection.
	self editingState previousInterval: self selectionInterval selection: self selection.
! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
compareToClipboard
	"Check to see if whether the receiver's text is the same as the text currently on the clipboard, and inform the user."
	| s1 s2 |
	s1 := self clipboardText string.
	s2 := self string.
	s1 = s2 ifTrue: [^ self inform: 'Exact match'].
	UIManager default  
		longMessage: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2)
		title: 'Comparison to Clipboard Text'
		! !

!TextEditor methodsFor: 'events' stamp: ''!
mouseMove: evt
	"Change the selection in response to mouse-down drag"
	| characterBlock |
	
	characterBlock := self paragraph characterBlockAtPoint: evt cursorPoint.

	self editingState pointBlock: characterBlock.
	self paragraph move: evt for: model controller: self.
	self storeSelectionInParagraph! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
changeStyle
	"Let user change styles for the current text pane."

	| names reply style current menuList |
	current := TextStyle default copy.
	names := TextStyle actualTextStyles keys.
	menuList := names collect: [ :styleName |
		(styleName = current printString) -> styleName ].
	reply := UIManager default chooseFrom:  menuList values: names.	
	reply ifNotNil: [
		(style := TextStyle named: reply) ifNil: [ ^ true].
		self text style: style.
		self paragraph textStyle: style.
		self paragraph composeAll.
		self recomputeSelection].
	^ true! !

!TextEditor methodsFor: 'private' stamp: ''!
previousNonBlank: position
	"decrement position up until any non-blank character found, or end of line"
	| string index |
	position <= 1 ifTrue: [ ^ 1 ].
	
	string := self string.
	index := position.
	index := index -1.
	(string at: index) isSeparator ifFalse: [ ^ index ]. 

	[ index > 1 and: [(string at: index-1) isSeparator and: [(string at:index-1) ~= Character cr]]]
		whileTrue: [index := index - 1].
	^ index! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
findAgainAndReplace

	"Find the text-to-find again and eventually replace it with the current replace text."

	| where |

	where := self findAgain.
	where
		ifNotNil: [ self findReplaceService replaceText ifNotEmpty: [ :rt | self replaceSelectionWith: rt ] ]! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
raiseContextMenu: aKeyboardEvent

	(morph respondsTo: #editView)
		ifTrue: [ ^ morph editView yellowButtonActivity: morph activeHand lastEvent shiftPressed].
	^ true! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
align
	"Align text according to the next greater alignment value,
	cycling among leftFlush, rightFlush, center, and justified."
	self changeAlignment.
	self recomputeInterval! !

!TextEditor methodsFor: 'accessing' stamp: ''!
replace: xoldInterval with: newText and: selectingBlock 
	"Replace the text in oldInterval with newText and
	execute selectingBlock to establish the new selection.
	Create an UndoRecord to allow perfect undoing."
	| prevSel currInterval |
	self selectInterval: xoldInterval.
	prevSel := self selection.
	currInterval := self selectionInterval.
	self editingState previousInterval: currInterval selection: self selection.
	self zapSelectionWith: newText.
	selectingBlock value.
	((prevSel isEmpty and: [newText isEmpty]) and: [currInterval size < 1]) 
		ifFalse: [self editingState
			redoArray: {morph. #redoTypeIn:interval:. {newText. currInterval}} 
			undoArray: {morph. #undoTypeIn:interval:. {prevSel. currInterval first to: currInterval first + newText size - 1}}]! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
find
	"Prompt the user for a string to search for, and search the receiver from the current selection onward for it."
	morph openFindDialog! !

!TextEditor methodsFor: 'current selection' stamp: ''!
recomputeInterval
	"The same characters are selected but their coordinates may have changed."

	self markIndex: self markIndex; pointIndex: self pointIndex! !

!TextEditor methodsFor: 'private' stamp: ''!
cut
	"Cut out the current selection and redisplay the paragraph if necessary.  Undoer & Redoer: undoCutCopy:"

	self lineSelectAndEmptyCheck: [^ self].
	self clipboardTextPut: self selection.
	self replaceSelectionWith: self nullText.
! !

!TextEditor methodsFor: 'events' stamp: ''!
mouseDown: event
	"An attempt to break up the old processRedButton code into three phases"

	"no matter what, if shift is pressed extend the selection"
	"no right/yellowbutton click just reposoition the cursor"
	(self paragraph selectionContainsPoint: event cursorPoint)
		ifTrue: [ self mouseDownOnSelectedText: event ]
		ifFalse: [ self mouseDownOnUnselectedText: event ]! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
normalCharacter: aKeyboardEvent 
	"A nonspecial character is to be added to the stream of characters."

	self hasSelection 
		ifTrue: [self addDeleteSelectionUndoRecord].
	self addString: aKeyboardEvent keyCharacter asString.
	^false
! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
search: aKeyboardEvent
	"Invoked by Ctrl-S.  Same as 'again', but always uses the existing findText
	 from current FindReplaceService"

	self closeTypeIn.
	self findAgain.
	^true! !

!TextEditor methodsFor: 'typing support' stamp: ''!
setEmphasisHereFromText

	self setEmphasisHereFromTextForward: true! !

!TextEditor methodsFor: 'typing support' stamp: ''!
startOfTyping: anIntegerIndex
	self editingState startOfTyping:  anIntegerIndex! !

!TextEditor methodsFor: 'typing support' stamp: ''!
performCmdActionsWith: aKeyboardEvent shifted: aBoolean return: return
	| asciiValue actions action|
	asciiValue := aKeyboardEvent keyValue + 1.
	actions := aBoolean
				ifTrue: [self class shiftCmdActions]
				ifFalse: [self class cmdActions].
	action := (actions at: asciiValue).
	action == #noop: ifTrue: [ ^ false ].
	return value: ( self perform: action with: aKeyboardEvent).! !

!TextEditor methodsFor: 'mvc compatibility' stamp: ''!
storeSelectionInParagraph
	self theme currentSettings haveSelectionTextColor 
		ifTrue: [
			self text removeAttribute: TextSelectionColor primarySelection.
			self text addAttribute: TextSelectionColor primarySelection from: self startIndex to: self stopIndex - 1].
	self paragraph selectionStart: self startBlock selectionStop: self stopBlock! !

!TextEditor methodsFor: 'accessing' stamp: ''!
selectionPosition: aString

	| startIndex |
	startIndex := self startIndex.
	^[
		| bottomLeft topLeft index |
		index := startIndex - aString size.
		self selectInvisiblyFrom: index to: index - 1.
		bottomLeft := self paragraph selectionRects first bottomLeft.
		topLeft := self morph owner submorphBounds topLeft.
		topLeft + bottomLeft ]
			ensure: [ self selectInvisiblyFrom: startIndex to: startIndex - 1 ]! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findReplaceService
	^ findReplaceService ifNil: [ self defaultFindReplaceServiceClass newFor: self ]! !

!TextEditor methodsFor: 'undo - redo private' stamp: ''!
exploreUndoManager: aKeyboardEvent
	^ self editingState exploreUndoManager: aKeyboardEvent! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
pasteRecent
	"Paste an item chose from RecentClippings."

	| clipping |
	(clipping := Clipboard chooseRecentClipping) ifNil: [^ self].
	Clipboard clipboardText: clipping.
	^ self paste! !

!TextEditor methodsFor: 'events' stamp: ''!
handleDownOnUnselectedText: event
	event shiftPressed
		ifTrue: [ ^ self mouseMove: event ].
	event yellowButtonPressed
		ifTrue: [ self yellowButtonDown: event ]
		ifFalse: [ 
			"no right/yellowbutton click just reposoition the cursor"
			self updateSelectionFromEvent: event ]! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
hasSelection
	^self hasCaret not! !

!TextEditor methodsFor: 'initialization' stamp: ''!
resetState 
	"Establish the initial conditions for editing the paragraph: place caret 
	before first character, set the emphasis to that of the first character,
	and save the paragraph for purposes of canceling."
 
	self editingState markBlock: self paragraph defaultCharacterBlock.
	self editingState pointBlock: self editingState markBlock copy.
	self startOfTyping: nil.
	self editingState previousInterval: (1 to: 0) selection: self nullText.
	self setEmphasisHereFromText.
	selectionShowing := true! !

!TextEditor methodsFor: 'typing support' stamp: ''!
dispatchCommandOn: aKeyboardEvent return: return
	|asciiValue honorCommandKeys|

	asciiValue := aKeyboardEvent keyValue.
	honorCommandKeys := self cmdKeysInText.
	"Special keys overwrite crtl+key combinations - at least on Windows. To resolve this
	conflict, assume that keys other than cursor keys aren't used together with Crtl." 
	((self class specialShiftCmdKeys includes: asciiValue) and: [ asciiValue < 27])
		ifTrue: [
			^ self performCmdActionsWith: aKeyboardEvent 
				shifted: aKeyboardEvent controlKeyPressed
				return: return].

	"backspace, and escape keys (ascii 8 and 27) are command keys"
	((honorCommandKeys and: [aKeyboardEvent commandKeyPressed]) or: [self class specialShiftCmdKeys includes: asciiValue]) 
		ifTrue: [
			^ self performCmdActionsWith: aKeyboardEvent 
				shifted: aKeyboardEvent shiftPressed
				return: return].

	"the control key can be used to invoke shift-cmd shortcuts"
	(honorCommandKeys and: [aKeyboardEvent controlKeyPressed])
		ifTrue: [
			^ self performCmdActionsWith: aKeyboardEvent shifted: true return: return].
			
	^ false
! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
copySelection: aKeyboardEvent
	"Copy the current text selection."

	self copySelection.
	^true! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
duplicate: aKeyboardEvent
	"Paste the current selection over the prior selection, if it is non-overlapping and
	 legal.  Undoer & Redoer: undoAndReselect."

	self closeTypeIn.
	(self hasSelection and: [self isDisjointFrom: self editingState previousInterval])
		ifTrue: "Something to duplicate"
			[self replace: self editingState previousInterval with: self selection and:
				[self selectAt: self pointIndex]]
		ifFalse:
			[morph flash].
	^true! !

!TextEditor methodsFor: 'accessing' stamp: ''!
totalTextHeight

	^self paragraph lines last bottom! !

!TextEditor methodsFor: 'parenblinking' stamp: ''!
clearParens
	| lastLocation |
	(lastLocation := self editingState lastParenLocation) 
		ifNil: [^ self].
	self text size >= lastLocation 
		ifTrue: [ self text
			removeAttribute: TextEmphasis bold
			from: lastLocation
			to: lastLocation].
	self editingState lastParenLocation: nil! !

!TextEditor methodsFor: 'typing support' stamp: ''!
dispatchOn: aKeyboardEvent
	"Carry out the action associated with this character, if any.
	Type-ahead is passed so some routines can flush or use it."
	"TODO rename to dispatch: "
	
	| char return |
 	return := [:val| ^ val].

	self acceptCR: aKeyboardEvent return: return.
	self clearParens.
	self dispatchEnterOn: aKeyboardEvent return: return.
	self dispatchCommandOn: aKeyboardEvent return: return.
			
	char := aKeyboardEvent keyCharacter.
      ( ')]}'  includes: char) 
		ifTrue: [ self blinkPrevParen: char ].
		
       ^ self normalCharacter: aKeyboardEvent.
! !

!TextEditor methodsFor: 'testing' stamp: ''!
isCaretBehindChar
	"Return true if the cursor position is after an alphanumeric character, otherwise false."

	| cursorPosition |
	^(cursorPosition := self startIndex) >= 2 and: [
		(self text at: cursorPosition - 1) isAlphaNumeric ]! !

!TextEditor methodsFor: 'private' stamp: ''!
findText: aString isRegex: isRegex caseSensitive: caseSensitive entireWordsOnly: entireWordsOnly
	self findReplaceService findText: aString isRegex: isRegex caseSensitive: caseSensitive entireWordsOnly: entireWordsOnly
! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
exchange: aKeyboardEvent
	"Exchange the current and prior selections."

	self closeTypeIn.
	self exchange.
	^true! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
noop: aKeyboardEvent 
	"Unimplemented keyboard command; just ignore it."

	^ true! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findNextString: aSubstring startingAt: searchIdx 
	| idx |
	idx := self string findString: aSubstring startingAt: searchIdx.
	^ idx isZero ifFalse: [idx to: idx + aSubstring size - 1]! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
startIndex
	^ self startBlock stringIndex! !

!TextEditor methodsFor: 'undo - redo private' stamp: ''!
addTypeInUndoRecord
	| begin stop undoText redoText |
	begin := self startOfTyping min: self stopIndex. 
	stop := self stopIndex max: self startOfTyping.
	self editingState 
		previousInterval: (begin to: stop - 1) 
		selection: (self text copyFrom: begin to: stop - 1). 
	undoText := self nullText.
	redoText := stop > begin
			ifTrue: [self text copyFrom: begin to: stop - 1]
			ifFalse: [self nullText].
	((undoText isEmpty and: [redoText isEmpty]) and: [self editingState previousInterval size < 1])
			ifFalse: [self editingState
				redoArray: { morph. #redoTypeIn:interval:.  {redoText. begin to: begin + self selection size - 1} } 
				undoArray: {morph. #undoTypeIn:interval:.  {undoText. begin to: stop - 1} }].
	
! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
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! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
escape: aKeyboardEvent
	self morph escapePressed.
	^ false  ! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
findAgain: aKeyboardEvent 
	"Find the desired text again."
	self closeTypeIn.
	self findAgain.
	^ true! !

!TextEditor methodsFor: 'accessing' stamp: ''!
findText: aString isRegex: aBoolean
	self findReplaceService findText: aString isRegex: aBoolean.
	self findReplaceService changed: #newFinding
! !

!TextEditor methodsFor: 'accessing' stamp: ''!
markBlock: aCharacterBlock 
	self editingState markBlock:  aCharacterBlock! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
selection
	"Answer the text in the paragraph that is currently selected."

	^self text copyFrom: self startIndex to: self stopIndex - 1 ! !

!TextEditor methodsFor: 'pluggable menus' stamp: ''!
pluggableYellowButtonActivity: shiftKeyState

	"Invoke the model's popup menu."

	^ (self getPluggableYellowButtonMenu: shiftKeyState)
		  ifNil: [ false ]
		  ifNotNil: [ true ]! !

!TextEditor methodsFor: 'accessing' stamp: ''!
theme
	^ Smalltalk ui theme ! !

!TextEditor methodsFor: 'accessing' stamp: ''!
nextCharacterIfAbsent: aBlock

	^ self text at: self startIndex ifAbsent: aBlock! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
cursorEnd: aKeyboardEvent 

	"Private - Move cursor end of current line."
	| string |
	self closeTypeIn.
	string := self string.
	self
		moveCursor:
			[:position | self walkAlongDisplayedLine
				ifTrue:[| targetLine |
					targetLine := self paragraph lines at: (self paragraph lineIndexOfCharacterIndex: position).
					targetLine = self paragraph lines  last 
						ifTrue:[targetLine last + 1]
						ifFalse:[targetLine last]]
				ifFalse:[
					string
						indexOf: Character cr
						startingAt: position
						ifAbsent:[string size + 1]]]
		forward: true
		specialBlock:[:dummy | string size + 1]
		event: aKeyboardEvent.
	^true! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
outdent: aKeyboardEvent
	"Remove a tab from the front of every line occupied by the selection."

	^ self inOutdent: aKeyboardEvent delta: -1! !

!TextEditor methodsFor: 'private' stamp: ''!
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! !

!TextEditor methodsFor: 'events' stamp: ''!
startDrag: event
	
	self morph startDrag: (event translatedBy: self morph editView topLeft)! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
indent: aKeyboardEvent
	"Add a tab at the front of every line occupied by the selection."

	^ self inOutdent: aKeyboardEvent delta: 1! !

!TextEditor methodsFor: 'events' stamp: ''!
mouseUp: evt
	"An attempt to break up the old processRedButton 
	code into three phases"
	| mouseDownInterval |
	
	(mouseDownInterval := self editingState mouseDownInterval)
		ifNil: [^ self]. 
		
	(self paragraph click: evt for: model controller: self ) 
		ifTrue: [
			self updateSelectionFromEvent: evt.
			evt hand releaseKeyboardFocus: self.
			^ self ].

	(evt yellowButtonChanged or: [ evt commandKeyPressed]) 
		ifTrue: [
			(self morph yellowButtonActivity: evt shiftPressed) 
				ifTrue: [ ^ self ]].
		
	(self hasCaret and: [mouseDownInterval = self selectionInterval])
		ifTrue: [self selectWord].
		
	self setEmphasisHereFromText.
	self storeSelectionInParagraph! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
selectCurrentTypeIn: aKeyboardEvent 
	"Select what would be replaced by an undo (e.g., the last typeIn)."

	self closeTypeIn.
	self selectInterval: self editingState previousInterval.
	^ true! !

!TextEditor methodsFor: 'accessing' stamp: ''!
userHasEdited
	"Note that my text is free of user edits."
	morph notNil ifTrue:[ morph hasUnacceptedEdits: true ]! !

!TextEditor methodsFor: 'settings' stamp: ''!
cmdKeysInText
	^ self class cmdKeysInText! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
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! !

!TextEditor methodsFor: 'events' stamp: ''!
doubleClick: evt

	self selectWord! !

!TextEditor methodsFor: 'initialization' stamp: ''!
initWithMorph: aMorph
	morph := aMorph.
	self resetState ! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
blankParagraph
	| blankParagraph |
	blankParagraph  := Paragraph new.
	blankParagraph 
		compose:  '' asText 
		style:  TextStyle default copy    
		from: 1
		in:  (0@0 extent: 10@10) .
	^ blankParagraph	! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
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]! !

!TextEditor methodsFor: 'private' stamp: ''!
pageHeight
	| howManyLines visibleHeight totalHeight ratio |
	howManyLines := self paragraph numberOfLines.
	visibleHeight := self visibleHeight.
	totalHeight := self totalTextHeight.
	ratio := visibleHeight / totalHeight.
	^(ratio * howManyLines) rounded - 2! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
changeStyle: aKeyboardEvent 
	"Put up the style-change menu"

	self closeTypeIn.
	self changeStyle.
	^ true! !

!TextEditor methodsFor: 'current selection' stamp: ''!
select
	"If the text selection is visible on the screen, reverse its highlight."
	^'Not doing anything'
	"screw this logic
	selectionShowing ifFalse: [self reverseSelection]"! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
selectAll: aKeyboardEvent 
	"select everything"

	self closeTypeIn.
	self selectFrom: 1 to: self string size.
	^ true! !

!TextEditor methodsFor: 'new selection' stamp: ''!
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]! !

!TextEditor methodsFor: 'pluggable menus' stamp: ''!
shiftedTextPaneMenuRequest
	"The user chose the more... branch from the text-pane menu."

	^ self pluggableYellowButtonActivity: true! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
changeAlignment
	"Interactively change the alignment of the text currently being edited."
	| reply  |
	reply := UIManager default 
				chooseFrom:  self alignmentChoices 
				values:  self alignmentChoices.	
	reply ifNil: [^self].
	self applyAttribute: (TextAlignment perform: reply).
	^ true! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
undo: aKeyboardEvent 
	"Undo the last edit."

	self undo.
	^true! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
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! !

!TextEditor methodsFor: 'new selection' stamp: ''!
selectInvisiblyFrom: start to: stop
	"Select the designated characters, inclusive.  Make no visual changes."

	self markIndex: start; pointIndex: stop + 1! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findText
	^ self findReplaceService findText! !

!TextEditor methodsFor: 'accessing' stamp: ''!
replaceSelectionWith: aText
	self replace: self selectionInterval with: aText and: []
! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
selectionAsStream
	"Answer a ReadStream on the text in the paragraph that is currently 
	selected."

	^ReadStream
		on: (self string copyFrom: self startIndex to: self stopIndex - 1)! !

!TextEditor methodsFor: 'accessing' stamp: ''!
visibleHeight

	^morph owner bounds height
! !

!TextEditor methodsFor: 'settings' stamp: ''!
caseSensitiveFinds
	^ self class caseSensitiveFinds! !

!TextEditor methodsFor: 'typing support' stamp: ''!
processKeyStroke: aKeyboardEvent
	"Key struck on the keyboard. Find out which one and, if special, carry 
	out the associated special action. Otherwise, add the character to the 
	stream of characters.  Undoer & Redoer: see closeTypeIn."
	
	^self handleKeystrokeAction: [self dispatchOn: aKeyboardEvent].! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
changeLfToCr: aKeyboardEvent
	"Replace all LFs by CRs.
	Triggered by Cmd-U -- useful when getting code from FTP sites
	jmv- Modified to als change crlf by cr"
	
	| fixed |
	fixed := self selection string.
	fixed := fixed copyReplaceAll: String crlf with: String cr.
	fixed := fixed copyReplaceAll: String lf with: String cr. 
	self replaceSelectionWith: (Text fromString: fixed).
	^ true! !

!TextEditor methodsFor: 'accessing' stamp: ''!
model: aModel 
	"Controller|model: and Controller|view: are sent by View|controller: in 
	order to coordinate the links between the model, view, and controller. In 
	ordinary usage, the receiver is created and passed as the parameter to 
	View|controller: so that the receiver's model and view links can be set 
	up by the view."

	model := aModel! !

!TextEditor methodsFor: 'current selection' stamp: ''!
recomputeSelection
	"Redetermine the selection according to the start and stop block indices; 
	do not highlight."

	self recomputeInterval! !

!TextEditor methodsFor: 'events' stamp: ''!
mouseDownOnUnselectedText: event
	self editingState mouseDown: event from: morph.
	self closeTypeIn.	"no matter what, if shift is pressed extend the selection"
	"make sure our view knows about selection change"	
	self morph handleInteraction: [ self handleDownOnUnselectedText: event ]! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
redo
	"redo previous edit"

	self editingState redo ifFalse: [morph flash]. 
! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
crlf: aKeyboardEvent
	"Append a line feed character to the stream of characters."

	self addString: String crlf.
	^false! !

!TextEditor methodsFor: 'events' stamp: ''!
focused: aBoolean
	self editingState focused: aBoolean from: morph.
! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
setSearchString
	"Make the current selection, if any, be the current search string."
	self closeTypeIn.
	self setSearch: self selection string.
	^ true! !

!TextEditor methodsFor: 'menu declaration' stamp: ''!
shiftedMenuKeyword
	^ #textEditorShiftedMenu
! !

!TextEditor methodsFor: 'new selection' stamp: ''!
afterSelectionInsertAndSelect: aString

	self insertAndSelect: aString at: self stopIndex ! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
markIndex: anIndex
	self editingState markBlock: (self paragraph characterBlockForIndex: anIndex)
! !

!TextEditor methodsFor: 'private' stamp: ''!
nullText

	^Text string: '' attributes: self emphasisHere! !

!TextEditor methodsFor: 'accessing' stamp: ''!
previousCharacterIfAbsent: aBlock

	^ self text at: self startIndex - 1 ifAbsent: aBlock! !

!TextEditor methodsFor: 'do-its' stamp: ''!
evaluateSelectionAndDo: aBlock
	"Treat the current selection as an expression; evaluate it and invoke aBlock with the result."
	| result rcvr ctxt |
	self lineSelectAndEmptyCheck: [^ nil].

	(model respondsTo: #doItReceiver) 
		ifTrue: [ rcvr := model doItReceiver.
				ctxt := model doItContext]
		ifFalse: [rcvr := ctxt := nil].
	result := rcvr class compiler
			source: self selectionAsStream;
			context: ctxt;
			receiver: rcvr;
			requestor: self;
			failBlock:  [morph flash. ^ nil];
			evaluate.		
	^aBlock value: result! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
markBlock
	^ self editingState markBlock! !

!TextEditor methodsFor: 'new selection' stamp: ''!
deselect
	"If the text selection is visible on the screen, reverse its highlight."
	self selectFrom: 1 to: 0! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
forwardDelete: aKeyboardEvent
	"Delete forward over the next character"
	self closeTypeIn.
	self hasSelection 
		ifFalse: [	| idx1 idx2 |
				idx1 := self startIndex min: self stopIndex.
				idx2 := self stopIndex max: self startIndex.
				aKeyboardEvent shiftPressed
					ifTrue: [idx2 := (self nextWord: idx1)]
					ifFalse: [idx2 := idx2 + 1].
				self selectInvisiblyFrom: idx1 to: idx2 - 1].
	self addDeleteSelectionUndoRecord.
	self zapSelectionWith: self nullText.
	^ false
! !

!TextEditor methodsFor: 'events' stamp: ''!
mouseDownOnSelectedText: event
	| selectors |
	selectors := Array
		with: #mouseDownOnUnselectedText:
		with: nil
		with: nil
		with:
			(self morph dragEnabled
				ifTrue: [ #startDrag: ]
				ifFalse: [ nil ]).
	event hand
		waitForClicksOrDrag: self
		event: event
		selectors: selectors
		threshold: 10! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
setSelectorSearch: aStringOrText 
	"Make the current selection as a selector search in current FindReplaceService."
	| regex |
	regex := aStringOrText asString trimBoth.
	regex := regex copyReplaceAll: '#' with: ''.
	regex := regex copyReplaceAll: ' ' with: ''.
	self findText: regex isRegex: false caseSensitive: true entireWordsOnly: false.
	^ true! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
changeEmphasisOrAlignment
	| aList reply  code align menuList startIndex attribute |
	startIndex := self startIndex.
	align := self text alignmentAt: startIndex ifAbsent: [ 0 ].
	code := self text emphasisAt: startIndex.
	menuList := WriteStream on: Array new.
	menuList nextPut: (code isZero -> 'normal' translated).
	menuList nextPutAll: (#(bold italic underlined struckOut) collect: [:emph|
		(code anyMask: (TextEmphasis perform: emph) emphasisCode) -> emph asString translated]).
	
	menuList nextPut: ((self text attributesAt: startIndex)
		anySatisfy: [ :attr | attr isKern and: [attr kern < 0 ]]) -> 'narrow' translated.
		
	self alignmentChoices collectWithIndex: [ :type :i |
		menuList nextPut: (align = (i-1)) -> type asString translated ].
	
	aList := #(normal bold italic underlined struckOut narrow leftFlush centered rightFlush justified).
	reply := UIManager default chooseFrom:  aList values: aList.
	reply notNil ifTrue: [
		(self alignmentChoices includes: reply)
			ifTrue: [ attribute :=TextAlignment perform: reply]
			ifFalse: [ attribute := TextEmphasis perform: reply].
		self applyAttribute:  attribute].
	^ true! !

!TextEditor methodsFor: 'private' stamp: ''!
findText: aString isRegex: isRegex entireWordsOnly: entireWordsOnly
	self findReplaceService findText: aString isRegex: isRegex entireWordsOnly: entireWordsOnly
! !

!TextEditor methodsFor: 'accessing' stamp: ''!
model
	^model! !

!TextEditor methodsFor: 'events' stamp: ''!
yellowButtonDown: anEvent
	"special case for right/yellobutton click.
	if clicking outside the current selection select the word."
	(self paragraph selectionContainsPoint: anEvent cursorPoint)
		ifFalse: [
			self mouseMove: anEvent.
			self selectWord ].! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
exchange
	"See comment in exchangeWith:"

	self exchangeWith: self editingState previousInterval! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
hasCaret
	^self editingState markBlock = self editingState pointBlock! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
clipboardTextPut: text

	^ Clipboard clipboardText: text! !

!TextEditor methodsFor: 'typing support' stamp: ''!
doneTyping
	self startOfTyping: nil! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
pointIndex: anIndex
	self editingState pointBlock: (self paragraph characterBlockForIndex: anIndex)
! !

!TextEditor methodsFor: 'private' stamp: ''!
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! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
cursorRight: aKeyboardEvent 
	"Private - Move cursor right one character if nothing selected, 
	otherwise move cursor to end of selection. If the shift key is down, 
	start selecting characters or extending already selected characters. 
	Don't allow cursor past end of text"

	self closeTypeIn.
	self
		moveCursor: [:position |
			self class skipOverMultipleSpaces 
				ifTrue: [ self nextNonBlank: position ] 
				ifFalse: [ position + 1 ]
			]
		forward: true
		specialBlock:[:position | self nextWord: position]
		event: aKeyboardEvent.
	^ true! !

!TextEditor methodsFor: 'undoers - redoers' stamp: ''!
undoRedoExchange: aninterval with: anotherInterval
	self selectInvisiblyFrom: aninterval first to: aninterval last.
	self exchangeWith: anotherInterval
! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
cursorHome: aKeyboardEvent

	"Private - Move cursor from position in current line to beginning of
	current line. If control key is pressed put cursor at beginning of text"

	| string |
	self closeTypeIn.
	string := self string.
	self
		moveCursor: [ :position | self walkAlongDisplayedLine
				ifTrue: [ (self paragraph lines at:(self paragraph lineIndexOfCharacterIndex: position)) first]
				ifFalse: [(string
						lastIndexOf: Character cr
						startingAt: position - 1
						ifAbsent:[0]) + 1]]
		forward: false
		specialBlock: [:dummy | 1]
		event: aKeyboardEvent.
	^true! !

!TextEditor methodsFor: 'typing support' stamp: ''!
dispatchEnterOn: aKeyboardEvent return: aBlock
	aKeyboardEvent keyValue = 13
		 ifFalse: [ ^ false ].
	aKeyboardEvent controlKeyPressed 
		ifTrue: [ aBlock value: (self normalCharacter: aKeyboardEvent) ].
	aKeyboardEvent shiftPressed 
		ifTrue: [  aBlock value:  (self lf: aKeyboardEvent) ].
	aKeyboardEvent commandKeyPressed 
		ifTrue: [  aBlock value:  (self crlf: aKeyboardEvent) ].
	 aBlock value:  (self crWithIndent: aKeyboardEvent)! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
enclose: aKeyboardEvent
	"Insert or remove bracket characters around the current selection."

	| left right startIndex stopIndex oldSelection which text |
	self closeTypeIn.
	startIndex := self startIndex.
	stopIndex := self stopIndex.
	oldSelection := self selection.
	which := '([<{"''' indexOf: aKeyboardEvent keyCharacter ifAbsent: [ ^true ].
	left := '([<{"''' at: which.
	right := ')]>}"''' at: which.
	text := self text.
	((startIndex > 1 and: [stopIndex <= text size])
			and: [ (text at: startIndex-1) = left and: [(text at: stopIndex) = right]])
		ifTrue: [
			"already enclosed; strip off brackets"
			self selectFrom: startIndex-1 to: stopIndex.
			self replaceSelectionWith: oldSelection]
		ifFalse: [
			"not enclosed; enclose by matching brackets"
			self replaceSelectionWith:
				(Text string: (String with: left), oldSelection string, (String with: right) attributes: self emphasisHere).
			self selectFrom: startIndex+1 to: stopIndex].
	^true! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
encloseWith: aMatchingPair
	"Insert or remove bracket characters around the current selection. Provided for protocol compatibility, but not completely sure this is ever called"
	| event |  
	event := KeyboardEvent new.
	event 
		setType: #keystroke
		buttons: nil
		position:  0@0
		keyValue: aMatchingPair key asciiValue 
		charCode: aMatchingPair key asciiValue
		hand: nil 
		stamp: Time now.
	^self enclose: event ! !

!TextEditor methodsFor: 'private' stamp: ''!
indent: delta fromStream: inStream toStream: outStream
	"Append the contents of inStream to outStream, adding or deleting delta or -delta
	 tabs at the beginning, and after every CR except a final CR.  Do not add tabs
	 to totally empty lines, and be sure nothing but tabs are removed from lines."

	| ch skip cr tab prev atEnd |
	cr := Character cr.
	tab := Character tab.
	delta > 0
		ifTrue: "shift right"
			[prev := cr.
			 [ch := (atEnd := inStream atEnd) ifTrue: [cr] ifFalse: [inStream next].
			  (prev == cr and: [ch ~~ cr]) ifTrue:
				[delta timesRepeat: [outStream nextPut: tab]].
			  atEnd]
				whileFalse:
					[outStream nextPut: ch.
					prev := ch]]
		ifFalse: "shift left"
			[skip := delta. "a negative number"
			 [inStream atEnd] whileFalse:
				[((ch := inStream next) == tab and: [skip < 0]) ifFalse:
					[outStream nextPut: ch].
				skip := ch == cr ifTrue: [delta] ifFalse: [skip + 1]]]! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
saveContentsInFile
	"Save the receiver's contents string to a file, prompting the user for a file-name. Suggest a reasonable file-name."

	| fileName stringToSave labelToUse suggestedName lastIndex |
	stringToSave := self string.
	stringToSave ifEmpty: [ ^ self inform: 'nothing to save.' ].
	labelToUse :=  model dependents detect: [ :dep | dep isKindOf: SystemWindow ] ifFound: [:parentWindow | parentWindow label] ifNone: [ 'Untitled' ].
	suggestedName := nil.
	#(#('Decompressed contents of: ' '.gz'))
		do: [ :leaderTrailer | 
			"can add more here..."
			(labelToUse beginsWith: leaderTrailer first)
				ifTrue: [ suggestedName := labelToUse copyFrom: leaderTrailer first size + 1 to: labelToUse size.
					(labelToUse endsWith: leaderTrailer last)
						ifTrue: [ suggestedName := suggestedName copyFrom: 1 to: suggestedName size - leaderTrailer last size ]
						ifFalse: [ lastIndex := suggestedName lastIndexOf: $. ifAbsent: [ 0 ].
							lastIndex > 1
								ifTrue: [ suggestedName := suggestedName copyFrom: 1 to: lastIndex - 1 ] ] ] ].
	suggestedName ifNil: [ suggestedName := labelToUse , '.text' ].
	fileName := UIManager default request: 'File name?' initialAnswer: suggestedName.
	fileName isEmptyOrNil
		ifFalse: [ fileName asFileReference writeStreamDo: [ :out | out nextPutAll: stringToSave ] ]! !

!TextEditor methodsFor: 'private' stamp: ''!
setEmphasisHere
	self editingState emphasisHere: ((self text attributesAt: (self pointIndex - 1 max: 1) forStyle: self textStyle)
					select: [:att | att mayBeExtended])! !

!TextEditor methodsFor: 'private' stamp: ''!
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! !

!TextEditor methodsFor: 'undoers - redoers' stamp: ''!
redoTypeIn: aText interval: anInterval
	self selectInterval: anInterval.
	self replace: self selectionInterval with: aText and:
		[self selectInterval: (anInterval first to: anInterval first + aText size - 1)].
! !

!TextEditor methodsFor: 'accessing' stamp: ''!
textStyle
	^ self paragraph textStyle! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findAndSelect: aRegex startingAt: anIndex searchBackwards: searchBackwards
	| oldSelectionInterval where |
	self closeTypeIn.
	oldSelectionInterval := self selectionInterval.
	self selectInvisiblyFrom: anIndex to: anIndex - 1.
	where :=  searchBackwards
		ifTrue: [self findAndSelectPreviousOccurrenceOf: aRegex]
		ifFalse: [self findAndSelectNextOccurrenceOf: aRegex].
	where ifNil: [self selectInterval: oldSelectionInterval].
	^ where! !

!TextEditor methodsFor: 'initialization' stamp: ''!
stateArray
	^ Array with: self editingState! !

!TextEditor methodsFor: 'accessing' stamp: ''!
editingState
	^ editingState ifNil: [editingState := self editingStateClass new]! !

!TextEditor methodsFor: 'accessing' stamp: ''!
string

	^self text string! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findAll: aRegex endingAt: searchIdx 
	| ranges |
	ranges := aRegex matchingRangesIn: (self string copyFrom: 1 to: searchIdx).
	^ ranges 
			! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
setSearch: aString
	"Make the current selection, if any, be the current search string."
	self findText: aString isRegex: false.
	^ true! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
accept
	"Save the current text of the text being edited as the current acceptable version for purposes of canceling.  Allow my morph to take appropriate action"
	morph canChangeText 
		ifTrue: [morph acceptContents]! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
offerFontMenu
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection.  
	Use only names of Fonts of this paragraph  "
	
	^self changeTextFont! !

!TextEditor methodsFor: 'undo - redo private' stamp: ''!
addDeleteSelectionUndoRecord
	| undoText redoText |
	undoText := self selection.
	redoText := self nullText.
	self editingState
		redoArray: { morph. #undoTypeIn:interval:.  {redoText. self selectionInterval} } 
		undoArray: {morph. #redoTypeIn:interval:.  {undoText. self selectionInterval first to: self selectionInterval first - 1} }.
! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
undo
	"Undo  previous edit."
	self closeTypeIn.
	self editingState undo ifFalse: [morph flash]. 
! !

!TextEditor methodsFor: 'testing' stamp: ''!
isSmalltalkEditor
	^ false ! !

!TextEditor methodsFor: 'settings' stamp: ''!
walkAlongDisplayedLine
	^ self class walkAlongDisplayedLine! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
inOutdent: aKeyboardEvent delta: delta
	"Add/remove a tab at the front of every line occupied by the selection. 
	Derived from work by Larry Tesler back in December 1985."

	| cr realStart realStop lines startLine stopLine start stop adjustStart indentation size numLines inStream newString outStream |
	cr := Character cr.

	"Operate on entire lines, but remember the real selection for re-highlighting later"
	realStart := self startIndex.
	realStop := self stopIndex - 1.

	"Special case a caret on a line of its own, including weird case at end of paragraph"
	(realStart > realStop and: [
				realStart < 2 or: [(self string at: realStart - 1) == cr]])
		ifTrue:
			[delta < 0
				ifTrue: [
					morph flash]
				ifFalse: [
					self replaceSelectionWith: Character tab asSymbol asText.
					self selectAt: realStart + 1].
			^true].

	lines := self paragraph lines.
	startLine := self paragraph lineIndexOfCharacterIndex: realStart.
	stopLine := self paragraph lineIndexOfCharacterIndex: (realStart max: realStop).
	start := (lines at: startLine) first.
	stop := (lines at: stopLine) last.
	
	"Pin the start of highlighting unless the selection starts a line"
	adjustStart := realStart > start.

	"Find the indentation of the least-indented non-blank line; never outdent more"
	indentation := (startLine to: stopLine) inject: 1000 into: [ :previousValue :each |
		previousValue min: (self paragraph indentationOfLineIndex: each ifBlank: [ :tabs | 1000 ])].			

	size :=  stop + 1 - start.
	numLines := stopLine + 1 - startLine.
	inStream := ReadStream on: self string from: start to: stop.

	newString := String new: size + ((numLines * delta) max: 0).
	outStream := ReadWriteStream on: newString.

	"This subroutine does the actual work"
	self indent: delta fromStream: inStream toStream: outStream.

	"Adjust the range that will be highlighted later"
	adjustStart ifTrue: [realStart := (realStart + delta) max: start].
	realStop := realStop + outStream position - size.

	"Prepare for another iteration"
	indentation := indentation + delta.
	size := outStream position.
	inStream := outStream setFrom: 1 to: size.

	outStream == nil
		ifTrue: 	"tried to outdent but some line(s) were already left flush"
			[morph flash]
		ifFalse:
			[self selectInvisiblyFrom: start to: stop.
			size = newString size ifFalse: [newString := outStream contents].
			self replaceSelectionWith: newString asText].
	self selectFrom: realStart to: realStop. 	"highlight only the original range"
	^ true! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
clipboardText

	^ Clipboard clipboardText! !

!TextEditor methodsFor: 'mvc compatibility' stamp: ''!
zapSelectionWith: aText
	| start stop |
	morph canChangeText ifFalse: [^ self].
	start := self startIndex.
	stop := self stopIndex.
	(aText isEmpty and: [stop > start]) ifTrue: [
		"If deleting, then set emphasisHere from 1st character of the deletion"
		self editingState emphasisHere: ((self text attributesAt: start) select: [:att | att mayBeExtended])].
	(start = stop and: [ aText size = 0 ]) ifFalse: [
		self paragraph replaceFrom: start to: stop - 1 with: aText.
		self markIndex: start; pointIndex: start + aText size.
		self editingState previousInterval: self selectionInterval selection: self selection.
		self userHasEdited  " -- note text now dirty" ].
! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
doAgainMany: aKeyboardEvent 
	"Do the previous thing again repeatedly."

	self closeTypeIn.
	^ true! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
accept: aKeyboardEvent 
	"Save the current text of the text being edited as the current acceptable version for purposes of canceling.  Allow my morph to take appropriate action"
	self accept.
	^ true! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
selectionInterval
	"Answer the interval that is currently selected."

	^self startIndex to: self stopIndex - 1 ! !

!TextEditor methodsFor: 'menu declaration' stamp: ''!
editorMenuKeyword
	^'textEditorMenu'
! !

!TextEditor methodsFor: 'new selection' stamp: ''!
correctFrom: start to: stop with: aString
	"Make a correction in the model that the user has authorised from somewhere else in the system (such as from the compilier).  
	The user's selection is not changed, only corrected."
	| userSelection delta |
	
	userSelection := self selectionInterval.
	self selectInvisiblyFrom: start to: stop.
	self replaceSelectionWith: aString asText.
	delta := aString size - (stop - start + 1).
	self selectInvisiblyFrom:
		userSelection first + (userSelection first > start ifFalse: [ 0 ] ifTrue: [ delta ])
		to: userSelection last + (userSelection last > start ifFalse: [ 0 ] ifTrue: [ delta ]).
! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
lf: aKeyboardEvent 
	"Append a line feed character to the stream of characters."

	self addString: Character lf asString.
	^false! !

!TextEditor methodsFor: 'accessing' stamp: ''!
wordAtCaret

	^self paragraph text asString wordBefore: self startIndex - 1
! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
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! !

!TextEditor methodsFor: 'private' stamp: ''!
sameColumn: start newLine: lineBlock forward: isForward
	"Private - Compute the index in my text
	with the line number derived from lineBlock,"
	" a one argument block accepting the old line number.
	The position inside the line will be preserved as good as possible"
	"The boolean isForward is used in the border case to determine if
	we should move to the beginning or the end of the line."
	| column currentLine offsetAtTargetLine targetEOL lines numberOfLines currentLineNumber targetLineNumber |
	self walkAlongDisplayedLine
		ifTrue: [lines := self paragraph lines.
			numberOfLines := self paragraph numberOfLines.
			currentLineNumber := self paragraph lineIndexOfCharacterIndex: start.
			currentLine := lines at: currentLineNumber]
		ifFalse: [lines := self lines.
			numberOfLines := lines size.
			currentLine := lines
				detect:[:lineInterval | lineInterval last >= start]
				ifNone:[lines last].
			currentLineNumber := currentLine second].
	column := start - currentLine first.
	targetLineNumber := ((lineBlock value: currentLineNumber) max: 1) min: numberOfLines.
	offsetAtTargetLine := (lines at: targetLineNumber) first.
	targetEOL := (lines at: targetLineNumber) last + (targetLineNumber = numberOfLines ifTrue:[1]ifFalse:[0]).
	targetLineNumber = currentLineNumber
	"No movement or movement failed. Move to beginning or end of line."
		ifTrue:[^isForward
			ifTrue:[targetEOL]
			ifFalse:[offsetAtTargetLine]].
	^offsetAtTargetLine + column min: targetEOL.! !

!TextEditor methodsFor: 'typing support' stamp: ''!
backTo: startIndex
	"Backspace typing"
	self stopIndex > startIndex ifTrue: [
		self selectFrom: startIndex to: self stopIndex - 1.
		self addDeleteSelectionUndoRecord.
		self zapSelectionWith: self nullText].
	^ false


	! !

!TextEditor methodsFor: 'parenblinking' stamp: ''!
blinkPrevParen: aCharacter
	| openDelimiter closeDelimiter level string here hereChar |
	string := self string.
	here := self editingState pointBlock stringIndex.
	openDelimiter := "aKeyboardEvent keyValue." aCharacter.
	closeDelimiter := '([{' at: (')]}' indexOf: openDelimiter).
	level := 1.
	[level > 0 and: [here > 2]]
		whileTrue: [hereChar := string at: (here := here - 1).
			hereChar = closeDelimiter
				ifTrue: [level := level - 1.
					level = 0
						ifTrue: [^ self blinkParenAt: here]]
				ifFalse: [hereChar = openDelimiter
						ifTrue: [level := level + 1]]]! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
find: aKeyboardEvent
	"Prompt the user for what to find, then find it, searching from the current selection onward."

	self closeTypeIn.
	self find.
	^ true! !

!TextEditor methodsFor: 'accessing' stamp: ''!
morph
	^ morph! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
align: aKeyboardEvent
	"Triggered by Cmd-u;  cycle through alignment alternatives."

	self align.
	^ true! !

!TextEditor methodsFor: 'typing support' stamp: ''!
handleEditionAction: anAction fromKeyboardEvent: aKeyboardEvent
	(self editingState handlesKeyboard: aKeyboardEvent from: morph)
		ifFalse: [self handleKeystrokeAction: anAction ].
	self editingState keystroke: aKeyboardEvent from: morph.! !

!TextEditor methodsFor: 'accessing' stamp: ''!
lastFont	
	"Answer the Font for to be used if positioned at the end of the text"
	| t |	
	t := self text.	
	^ t fontAt: t size + 1! !

!TextEditor methodsFor: 'new selection' stamp: ''!
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]! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
escape 
	self morph escapePressed .
	! !

!TextEditor methodsFor: 'testing' stamp: ''!
hasError
	^ false ! !

!TextEditor methodsFor: 'typing support' stamp: ''!
setEmphasisHereFromTextForward: f

	| i t forward delta prevIsSeparator nextIsSeparator |
	i := self pointIndex.
	t := self text.
	"Try to set emphasisHere correctly after whitespace.
	Most important after a cr, i.e. at the start of a new line"
	t ifEmpty: [ 
		prevIsSeparator := false.
		nextIsSeparator := false ]
	ifNotEmpty: [  
		prevIsSeparator :=  i > 1 and: [ (t at: i-1) isSeparator ].
		nextIsSeparator := i <= t size and: [ (t at: i) isSeparator ]].
	forward := prevIsSeparator = nextIsSeparator
		ifTrue: [ f ]
		ifFalse: [ nextIsSeparator ].
	delta := forward ifTrue: [ 1 ] ifFalse: [ 0 ].
	self editingState emphasisHere: ((t attributesAt: (i - delta max: 1)) select: [:att | att mayBeExtended]).
	! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
offerFontMenu: aKeyboardEvent 
	"The user typed the command key that requests a font change; Offer the font menu."

	self closeTypeIn.
	self offerFontMenu.
	^ true! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
cancel: aKeyboardEvent
	"Cancel unsubmitted changes."

	self cancel.
	^ true! !

!TextEditor methodsFor: 'parenblinking' stamp: ''!
blinkParen
	| lastParenLocation |
	(lastParenLocation := self editingState lastParenLocation) ifNotNil: [
		self text string size >= lastParenLocation ifTrue: [
			self text
				addAttribute: TextEmphasis bold
				from: lastParenLocation
				to: lastParenLocation]]! !

!TextEditor methodsFor: 'displaying' stamp: ''!
flash
	^ morph flash! !

!TextEditor methodsFor: 'find-select' stamp: ''!
replaceAll: aRegex with: aText startingAt: startIdx
	| selec ranges |
	self editingState undoManager openRecordGroup.
	selec := self selectionInterval.
	ranges := self findAll: aRegex startingAt: startIdx. 
	ranges reverseDo: [:r | self selectInvisiblyFrom: r first to: r last.
		self replaceSelectionWith: aText].
	self selectInterval: selec.
	self editingState undoManager closeRecordGroup.
! !

!TextEditor methodsFor: 'accessing' stamp: ''!
morph: aMorph
	"Install a link back to the morph being edited (esp for text links)"
	morph := aMorph ! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
backspace: aKeyboardEvent
	"Backspace over the last character."
	| result startIndex |
	self closeTypeIn.
	result := aKeyboardEvent shiftPressed 
		ifTrue: [self backWord: aKeyboardEvent keyCharacter]
		ifFalse: [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].
	self editingState keystroke: aKeyboardEvent from: morph.
	^ result! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findAndSelectNextOccurrenceOf: aRegex
	| where |
	where := self findNext: aRegex startingAt: self stopIndex.
	where ifNotNil: [self selectInterval: where].
	"(morph respondsTo: #editView) ifTrue: [morph editView selectionInterval: self selectionInterval]."
	^ where! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findAndSelectPreviousOccurrenceOf: aRegex

	| where |

	where := self findPrevious: aRegex startingAt: self startIndex.
	where ifNotNil: [ self selectInterval: where ].
	( morph respondsTo: #editView )
		ifTrue: [ morph editView selectionInterval: self selectionInterval ].
	^ where! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
markIndex
	^ self editingState markBlock stringIndex! !

!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: ''!
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! !

!TextEditor methodsFor: 'accessing' stamp: ''!
findRegex
	^ self findReplaceService findRegex! !

!TextEditor methodsFor: 'undo - redo private' stamp: ''!
clearUndoManager: aKeyboardEvent
	^ self editingState clearUndoManager: aKeyboardEvent.
! !

!TextEditor methodsFor: 'new selection' stamp: ''!
selectFrom: start to: stop
	"Select the specified characters inclusive."
	self selectInvisiblyFrom: start to: stop.
	self closeTypeIn.
	self storeSelectionInParagraph.
	"Preserve current emphasis if selection is empty"
	stop > start 
		ifTrue: [self setEmphasisHereFromTextForward: true ]! !

!TextEditor methodsFor: 'new selection' stamp: ''!
selectLine
	"Make the receiver's selection, if it currently consists of an insertion point only, encompass the current line."
	self hasSelection ifTrue:[^self].
	self selectInterval: (self encompassParagraph: self selectionInterval)! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
makeLowercase: aKeyboardEvent
	"Force the current selection to lowercase.  Triggered by Cmd-X."

	self closeTypeIn.
	self replaceSelectionWith: (Text fromString: (self selection string asLowercase)).
	^ true! !

!TextEditor methodsFor: 'binding' stamp: ''!
bindingOf: aString
	^model bindingOf: aString! !

!TextEditor methodsFor: 'typing support' stamp: ''!
addString: aString
	"Think of a better name"
	self zapSelectionWith: (Text string: aString attributes: self emphasisHere)! !

!TextEditor methodsFor: 'typing/selecting keys' stamp: ''!
crWithIndent: aKeyboardEvent
	"Replace the current text selection with CR followed by as many tabs
	as on the current line (+/- bracket count) -- initiated by Shift-Return."
	| char s i tabCount  b |
	self closeTypeIn.
	b := self paragraph characterBlockAtPoint: aKeyboardEvent cursorPoint.
	s := self string.
	i := self stopIndex.
	tabCount := 0.
	[(i := i-1) > 0 and: [(char := s at: i) ~= Character cr]]
		whileTrue:  "Count tabs and brackets (but not a leading bracket)"
		[(char = Character tab and: [i < s size and: [(s at: i+1) ~= $[ ]]) ifTrue: [tabCount := tabCount + 1].
		char = $[ ifTrue: [tabCount := tabCount + 1].
		char = $] ifTrue: [tabCount := tabCount - 1]].
	 "Now inject CR with tabCount tabs"
	self addString: (String streamContents: [ :strm | strm crtab: tabCount ]).
	^ false! !

!TextEditor methodsFor: 'menu declaration' stamp: ''!
shiftedYellowButtonMenu
	^ (PragmaMenuBuilder 
			pragmaKeyword: self shiftedMenuKeyword
			model: nil) menu.
! !

!TextEditor methodsFor: 'typing support' stamp: ''!
acceptCR: aKeyboardEvent return: return
	((aKeyboardEvent keyValue = Character cr asciiValue) and: [morph acceptOnCR])
		ifTrue: [
			self closeTypeIn.
			return value: true].! !

!TextEditor methodsFor: 'find-select' stamp: ''!
findNext: aRegex startingAt: searchIdx 
	| strm match range |
	strm := (self string copyFrom: searchIdx to: self string size) readStream.
	aRegex searchStream: strm.
	match := aRegex subexpression: 1.
	match ifNotNil: [range := (aRegex position + searchIdx - match size) to: (aRegex position + searchIdx - 1)].
	^ range! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
changeEmphasis: aKeyboardEvent
	"Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change.  Keeps typeahead."

	"control 0..9 -> 0..9"

	| keyCode attribute oldAttributes index thisSel colors |
	keyCode := ('0123456789-=' indexOf: aKeyboardEvent keyCharacter ifAbsent: [1]) - 1.
	oldAttributes := self text attributesAt: self pointIndex.
	thisSel := self selection.

	"Decipher keyCodes for Command 0-9..."
	"
	(keyCode between: 1 and: 5) 
		ifTrue: [attribute := TextFontChange fontNumber: keyCode].
	"
	keyCode = 6 
		ifTrue: [
			colors := #(#black #magenta #red #yellow #green #blue #cyan #white).
			index := UIManager default chooseFrom:  colors title: 'choose color...'.
			index = 0 ifTrue: [^true].
			index <= colors size 
				ifTrue: [attribute := TextColor color: (Color perform: (colors at: index))]
				ifFalse: [
					index := index - colors size - 1.	"Re-number!!!!!!"
					index = 0 ifTrue: [attribute := self chooseColor].
					thisSel ifNil: [^true]	"Could not figure out what to link to"]].
	(keyCode between: 7 and: 11) 
		ifTrue: [
			aKeyboardEvent shiftPressed 
				ifTrue: [
					keyCode = 10 ifTrue: [attribute := TextKern kern: -1].
					keyCode = 11 ifTrue: [attribute := TextKern kern: 1]]
				ifFalse: [
					attribute := TextEmphasis 
								perform: (#(#bold #italic #narrow #underlined #struckOut) at: keyCode - 6).
					oldAttributes 
						do: [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]].
	keyCode = 0 ifTrue: [ attribute := TextEmphasis normal ].
	attribute ifNotNil: [
		self applyAttribute: attribute].
	^true! !

!TextEditor methodsFor: 'private' stamp: ''!
updateSelectionFromEvent: event

	| clickPoint b | 

	clickPoint := event cursorPoint.
	b := self paragraph characterBlockAtPoint: clickPoint.
	
	self editingState markBlock: b.
	self editingState pointBlock: b.
	
	self storeSelectionInParagraph! !

!TextEditor methodsFor: 'typing support' stamp: ''!
startOfTyping
	^ self editingState startOfTyping  ! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
changeTextFont
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection."
	
	| curFont newFont attr startIndex |
	startIndex := self startIndex.
	curFont := self text fontAt: startIndex.
	newFont := StrikeFont fromUser: curFont.
	newFont ifNil: [ ^self ].
	attr := TextFontReference toFont: newFont.
	self applyAttribute: attr! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
stopIndex
	^ self stopBlock stringIndex! !

!TextEditor methodsFor: 'editing keys' stamp: ''!
redo: aKeyboardEvent 
	"Redo the last edit."

	self redo.
	^true! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
cancel
	"Cancel the changes made so far to this text"
	morph cancelEdits! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
yellowButtonActivity
	"This normally opens a popup menu. Determine the selected
	item and, if one is selected, then send the corresponding message
	to either the model or the receiver."

	^ self pluggableYellowButtonActivity: false! !

!TextEditor methodsFor: 'typing support' stamp: ''!
keystroke: aKeyboardEvent
	self handleEditionAction: [ self dispatchOn: aKeyboardEvent ] fromKeyboardEvent: aKeyboardEvent! !

!TextEditor methodsFor: 'accessing' stamp: ''!
caret
	"Return the index position of the caret"
	^ self startBlock stringIndex! !

!TextEditor methodsFor: 'menu declaration' stamp: ''!
yellowButtonMenu
	^ (PragmaMenuBuilder 
			pragmaKeyword: self editorMenuKeyword
			model: nil) menu.! !

!TextEditor methodsFor: 'private' stamp: ''!
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! !

!TextEditor methodsFor: 'private' stamp: ''!
nextNonBlank: position

"if current position is not separator, advance by 1, otherwise advance up until non-separator char found or new line"
	
	| string index |
	string := self string.
	index := position.
	index >= string size ifTrue: [ ^ string size+1 ].
	
	(string at: index) isSeparator ifFalse: [ ^ index + 1 ].
	index := index + 1.
	[ index <= string size and: [(string at: index) isSeparator and: [(string at:index) ~= Character cr]]]
		whileTrue: [index := index + 1].
	^ index! !

!TextEditor methodsFor: 'find-select' stamp: ''!
defaultFindReplaceServiceClass

	^ FindReplaceService! !

!TextEditor methodsFor: 'menu messages' stamp: ''!
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]! !

!TextEditor methodsFor: 'find-select' stamp: ''!
replaceAll: aRegex with: aText
	| selec ranges |
	self editingState undoManager openRecordGroup.
	selec := self selectionInterval.
	ranges := self findAll: aRegex startingAt: selec first. 
	ranges reverseDo: [:r | self selectInvisiblyFrom: r first to: r last.
		self replaceSelectionWith: aText].
	self selectInterval: selec.
	self editingState undoManager closeRecordGroup.
! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
startBlock
	^ self editingState pointBlock min: self editingState markBlock! !

!TextEditor methodsFor: 'accessing' stamp: ''!
transformFrom: owner
	^morph transformFrom: owner! !

!TextEditor methodsFor: 'accessing - selection' stamp: ''!
pointIndex
	^ self editingState pointBlock stringIndex! !

!TextEditor methodsFor: 'typing support' stamp: ''!
handleKeystrokeAction: aBlock
	(aBlock value)
			ifTrue: [self doneTyping.
			self storeSelectionInParagraph.
			^self].
	self openTypeIn.
	self hasSelection 
		ifTrue: [ "save highlighted characters"
			self editingState previousInterval: self selectionInterval selection: self selection].
	self editingState unselect.
	self storeSelectionInParagraph! !

!TextEditor methodsFor: 'accessing' stamp: ''!
text
	"Answer the text of the paragraph being edited."

	^self paragraph text! !

!TextEditor class methodsFor: 'settings' stamp: ''!
cmdKeysInText
	^ CmdKeysInText ifNil: [CmdKeysInText := true]! !

!TextEditor class methodsFor: 'accessing' stamp: ''!
shiftCmdActions
	^shiftCmdActions! !

!TextEditor class methodsFor: 'settings' stamp: ''!
cmdKeysInText: aBoolean
	CmdKeysInText := aBoolean! !

!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: ''!
initializeBasicCmdKeyShortcuts
	"Initialize the (unshifted) command-key (or alt-key) shortcut table.
	
	TextEditor initialize
	"
	| cmdMap |
	
	cmdMap := Array new: 256 withAll: #noop:.		"use temp in case of a crash"
	cmdMap at: 1 + 1 put: #cursorHome:.				"home key"
	cmdMap at: 4 + 1 put: #cursorEnd:.				"end key"
	cmdMap at: 8 + 1 put: #backspace:.				"ctrl-H or delete key"
	cmdMap at: 11 + 1 put: #cursorPageUp:.			"page up key"
	cmdMap at: 12 + 1 put: #cursorPageDown:.		"page down key"
	cmdMap at: 13 + 1 put: #crWithIndent:.			"cmd-Return"
	cmdMap at: 27 + 1 put: #escape:.		"escape key"
	cmdMap at: 28 + 1 put: #cursorLeft:.				"left arrow key"
	cmdMap at: 29 + 1 put: #cursorRight:.			"right arrow key"
	cmdMap at: 30 + 1 put: #cursorUp:.				"up arrow key"
	cmdMap at: 31 + 1 put: #cursorDown:.			"down arrow key"
	"cmdMap at: 32 + 1 put: #selectWord:."			"space bar key"
	cmdMap at: 127 + 1 put: #forwardDelete:.		"del key"
	"cmdMap at: 115 + 1 put:#accept:".	
		
	#(
		$a #selectAll: 
		"$c #copySelection:" 
		$e #exchange: 
		"$f #find: "
		"$g #findAgain: "
		"$h #setSearchString: "
		"$v #paste: "
		$w #backWord: 
		"$x #cut:" 
		$y #swapChars: 
		"$z #undo:" 
		$j #redo: 
		"$u #exploreUndoManager: ")
	pairsDo: [ :char :symbol|
		cmdMap at: char asciiValue + 1 put: symbol].
		
	cmdActions := cmdMap! !

!TextEditor class methodsFor: 'private - accessing' stamp: ''!
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"
	)! !

!TextEditor class methodsFor: 'settings' stamp: ''!
useSecondarySelection
	^ UseSecondarySelection ifNil: [UseSecondarySelection := true]! !

!TextEditor class methodsFor: 'settings' stamp: ''!
caseSensitiveFinds: aBoolean
	CaseSensitiveFinds := aBoolean! !

!TextEditor class methodsFor: 'shortcuts' stamp: ''!
buildTextEditorTabKeymapOn: aBuilder
	"This is to mask the tab or shift tab character at the system window level."
	<keymap>
	
	(aBuilder shortcut: #doTab) 
		category: #TextEditorTab
		default: Character tab asKeyCombination
		do: [ :target | target handleEdit: [ target
				handleEdit: [ 
					target replaceSelectionWith: '	'.
					target selectInvisiblyFrom: target selectionInterval last + 1 to: target selectionInterval last ] ] ]! !

!TextEditor class methodsFor: 'settings' stamp: ''!
blinkingCursor	
	^ BlinkingCursor ifNil: [ BlinkingCursor := true ]! !

!TextEditor class methodsFor: 'settings' stamp: ''!
editingSettingsOn: aBuilder 
	<systemsettings> 
	(aBuilder group: #codeEditing) 
		label: 'Text Editing';
		noOrdering;
		description: 'All settings concerned with text editing' ;
		with: [	
			(aBuilder setting: #selectionColor)
				target: UITheme;
				default: (Color r: 0.6862170087976539 g: 0.8347996089931574 b: 0.9794721407624634 alpha: 1.0);
				targetSelector: #currentSettings;
				label: 'Selection color'.
			(aBuilder setting: #unfocusedSelectionColor)
				target: UITheme;
				targetSelector: #currentSettings;
				description: 'The color of the selection for unfocused windows' ;
				default: (Color r: 0.729227761485826 g: 0.8318670576735093 b: 0.9335288367546432 alpha: 1.0);
				label: 'Unfocused selection color'.
			(aBuilder setting: #selectionTextColor)
				target: UITheme;
				targetSelector: #currentSettings;
				default: Color black;
				label: 'Selection text color';
				description: 'The color of the selection text'.
			(aBuilder setting: #useSelectionBar)
				target: TextEditor;
				default: true;
				label: 'Show the colored bar on the current line';
				with: [
					(aBuilder setting: #selectionBarColor)
						target: UITheme;
						targetSelector: #currentSettings;
						default: (Color r: 0.6862170087976539 g: 0.8347996089931574 b: 0.9794721407624634 alpha: 0.058823529411764705);
						label: 'Selection bar color'].
			(aBuilder setting: #useSecondarySelection)
				target: TextEditor;
				default: true;
				label: 'Use the secondary selection';
				with: [
					(aBuilder setting: #secondarySelectionTextColor)
						target: UITheme;
						targetSelector: #currentSettings;
						default: Color black;
						label: 'Secondary selection text color'].
			(aBuilder setting: #useFindReplaceSelection)
				target: TextEditor;
				default: true;
				label: 'Use the find and replace selection';
				with: [
					(aBuilder setting: #findReplaceSelectionColor)
						target: UITheme;
						targetSelector: #currentSettings;
						default: (Color r: 1.0 g: 0.6001955034213099 b: 0.0 alpha: 0.4);
						label: 'Find replace selection color'.
					(aBuilder setting: #findReplaceSelectionTextColor)
						target: UITheme;
						targetSelector: #currentSettings;
						default: Color black;
						label: 'Find replace selection text color'].
			(aBuilder setting: #caseSensitiveFinds) 
				label: 'Case sensitive search';
				target: TextEditor;
				default: false;
		 		description: 'If true, then the "find" command in text will always make its searches in a case-sensitive fashion'.
			(aBuilder setting: #blinkingCursor) 
				label: 'Blinking text cursor';
				target: TextEditor;
				default: true;
		 		description: 'When true, the text cursor will blink.'.
			(aBuilder setting: #dumbbellCursor) 
				label: 'Dumbbell-shaped text cursor';
				target: TextEditor;
				default: false;
		 		description: 'When true, the text cursor assumes the shape of a dumbbell, otherwise a vertical bar.'.
			(aBuilder setting: #skipOverMultipleSpaces) 
				label: 'Skip over white space';
				target: TextEditor;
				default: false;
		 		description: 'When true, the text cursor treats multiple white-space characters as a single space for navigating (moving left/right).'.
			(aBuilder setting: #walkAlongDisplayedLine) 
				label: 'Walk along displayed line';
				target: TextEditor;
				default: true;
		 		description: 'If set to true cursor movement will move along displayed lines rather than logical lines'.
		]
! !

!TextEditor class methodsFor: 'settings' stamp: ''!
useSelectionBar: aBoolean
	UseSelectionBar := aBoolean! !

!TextEditor class methodsFor: 'settings' stamp: ''!
useSecondarySelection: aBoolean
	UseSecondarySelection := aBoolean! !

!TextEditor class methodsFor: 'shortcuts' stamp: ''!
buildTextEditorShortcutsOn: aBuilder
	<keymap>
	
	(aBuilder shortcut: #toggleCommentOnSelectionOrLine)
		category: #TextEditor
		default: PharoShortcuts current toggleCommentOnSelectionOrLine
		do: [ :target  | target handleEdit: [ target toggleCommentOnSelectionOrLine ] ].
		
	(aBuilder shortcut: #selectAll) 
		category: #TextEditor
		default: PharoShortcuts current selectAllShortcut
		do: [ :target | target handleEdit: [ target selectAll ] ].

	(aBuilder shortcut: #copySelection) 
		category: #TextEditor
		default: PharoShortcuts current copySelectionShortcut
		do: [ :target | target copySelection ].
		
	(aBuilder shortcut: #find) 
		category: #TextEditor
		default: PharoShortcuts current findShortcut
		do: [ :target | target find ].
		
	(aBuilder shortcut: #findAgain) 
		category: #TextEditor
		default: PharoShortcuts current findAgainShortcut
		do: [ :target | target findAgain ].
		
	(aBuilder shortcut: #setSearchString)
		category: #TextEditor
		default: PharoShortcuts current setSearchStringShortcut
		do: [ :target | target setSearchString ].
		
	(aBuilder shortcut: #cancel) 
		category: #TextEditor
		default: PharoShortcuts current cancelShortcut
		do: [ :target | target cancelWithoutConfirmation ].
		
	(aBuilder shortcut: #paste) 
		category: #TextEditor
		default: PharoShortcuts current pasteShortcut
		do: [ :target | target paste ].
		
	(aBuilder shortcut: #cut) 
		category: #TextEditor
		default: PharoShortcuts current cutShortcut
		do: [ :target | target cut ].
				
	(aBuilder shortcut: #undo) 
		category: #TextEditor
		default: PharoShortcuts current undoShortcut
		do: [ :target | target undo ].
		
	(aBuilder shortcut: #redo) 
		category: #TextEditor
		default: PharoShortcuts current redoShortcut
		do: [ :target | target redo ].
	
	(aBuilder shortcut: #cursorHome)
		category: #TextEditor
		default: PharoShortcuts current cursorHomeShortcut
		do: [ :target :morph :event | target cursorHome: event ].
	
	(aBuilder shortcut: #cursorEnd)
		category: #TextEditor
		default: PharoShortcuts current cursorEndShortcut
		do: [ :target :morph :event | target cursorEnd: event ].! !

!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: ''!
initializeCmdKeyShortcuts
	"Initialize the (unshifted) command-key (or alt-key) shortcut table."



	"
	TextEditor initialize
	"

	| cmds |
	self initializeBasicCmdKeyShortcuts.
			
	'0123456789-=' 
		do: [:char | cmdActions at: char asciiValue + 1 put: #changeEmphasis:].
	
	cmds := #($k #offerFontMenu: $u #align: ).
	1 to: cmds size
		by: 2
		do: [:i | self cmdActions at: (cmds at: i) asciiValue + 1 put: (cmds at: i + 1)]! !

!TextEditor class methodsFor: 'settings' stamp: ''!
useFindReplaceSelection: aBoolean
	UseFindReplaceSelection := aBoolean! !

!TextEditor class methodsFor: 'menu declaration' stamp: ''!
textEditorShiftedMenuOn: aBuilder 
	"Specify the menu used when writing text. Try it with:
	(PragmaMenuBuilder 
		pragmaKeyword: 'textEditorShiftedMenu'
		model: nil) menu popUpInWorld"

	<contextMenu>
	<textEditorShiftedMenu>
	(aBuilder item: #'Set font...' translated) 
		keyText: 'k';
		selector: #offerFontMenu.
	(aBuilder item: #'Set style... (K)' translated) 
		keyText: 'K';
		selector: #changeStyle.
	(aBuilder item: #'Set alignment...' translated) 
		selector: #chooseAlignment.
	(aBuilder item: #'More...' translated) 
		selector: #yellowButtonActivity.
! !

!TextEditor class methodsFor: 'settings' stamp: ''!
skipOverMultipleSpaces
	^ SkipOverMultipleSpaces  ifNil: [ SkipOverMultipleSpaces := false ]! !

!TextEditor class methodsFor: 'settings' stamp: ''!
skipOverMultipleSpaces: aBoolean
	SkipOverMultipleSpaces := aBoolean! !

!TextEditor class methodsFor: 'settings' stamp: ''!
dumbbellCursor
	^ DumbbellCursor ifNil: [ DumbbellCursor := false ]! !

!TextEditor class methodsFor: 'settings' stamp: ''!
useFindReplaceSelection
	^ UseFindReplaceSelection ifNil: [UseFindReplaceSelection := true]! !

!TextEditor class methodsFor: 'class initialization' stamp: ''!
initialize 
	"Initialize the keyboard shortcut maps and the shared buffers
	for copying text across views and managing again and undo." 
 
	"
	TextEditor initialize
	" 

	self initializeCmdKeyShortcuts.
	self initializeShiftCmdKeyShortcuts.
! !

!TextEditor class methodsFor: 'settings' stamp: ''!
walkAlongDisplayedLine
	^ WalkAlongDisplayedLine ifNil: [WalkAlongDisplayedLine := true]! !

!TextEditor class methodsFor: 'settings' stamp: ''!
walkAlongDisplayedLine: aBoolean
	WalkAlongDisplayedLine := aBoolean! !

!TextEditor class methodsFor: 'settings' stamp: ''!
dumbbellCursor: aBoolean
	DumbbellCursor := aBoolean! !

!TextEditor class methodsFor: 'settings' stamp: ''!
useSelectionBar
	^ UseSelectionBar ifNil: [UseSelectionBar := true]! !

!TextEditor class methodsFor: 'instance creation' stamp: ''!
forMorph: aMorph

	^ self new initWithMorph: aMorph! !

!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: ''!
initializeBasicShiftCmdKeyShortcuts 
	"Initialize the shift-command-key (or control-key) shortcut table."

	"TextEditor initialize"
	
	| cmdMap |

	"shift-command and control shortcuts"
	cmdMap := Array new: 256 withAll: #noop:.  		"use temp in case of a crash"
	cmdMap at: ( 1 + 1) put: #cursorHome:.			"home key"
	cmdMap at: ( 4 + 1) put: #cursorEnd:.				"end key"
	cmdMap at: ( 8 + 1) put: #forwardDelete:.			"ctrl-H or delete key"
	cmdMap at: (11 + 1) put: #cursorPageUp:.			"page up key"
	cmdMap at: (12 + 1) put: #cursorPageDown:.		"page down key"
	cmdMap at: (13 + 1) put: #crWithIndent:.			"ctrl-Return"
	cmdMap at: (27 + 1) put: #noop:.	"escape key"
	cmdMap at: (28 + 1) put: #cursorLeft:.			"left arrow key"
	cmdMap at: (29 + 1) put: #cursorRight:.			"right arrow key"
	cmdMap at: (30 + 1) put: #cursorUp:.				"up arrow key"
	cmdMap at: (31 + 1) put: #cursorDown:.			"down arrow key"
	cmdMap at: (32 + 1) put: #selectWord:.			"space bar key"
	cmdMap at: (45 + 1) put: #changeEmphasis:.		"cmd-sh-minus"
	cmdMap at: (61 + 1) put: #changeEmphasis:.		"cmd-sh-plus"
	cmdMap at: (127 + 1) put: #forwardDelete:.		"del key"

	#(
		$c	compareToClipboard:
		$d	duplicate:
		$h	cursorTopHome:
		$j	doAgainMany:
		$k	changeStyle:
		$l	outdent:
		$m selectCurrentTypeIn:
		$r	indent:
		$s	search:
		$u	changeLfToCr:
		$x	makeLowercase:
		$y	makeUppercase:
		$z	makeCapitalized:
		"$g #findAgain:"
	) pairsDo: [ :char :symbol|
		cmdMap at: char asciiValue + 1 put: symbol.			"plain keys"
		cmdMap at: char asciiValue - 32 + 1 put: symbol.		"shifted keys"
		cmdMap at: char asciiValue - 96 + 1 put: symbol.		"ctrl keys"
	].
	shiftCmdActions := cmdMap! !

!TextEditor class methodsFor: 'shortcuts' stamp: ''!
defaultFindReplaceServiceClass

	^ defaultFindReplaceServiceClass ifNil: [ FindReplaceService ]! !

!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: ''!
initializeShiftCmdKeyShortcuts 
	"Initialize the shift-command-key (or control-key) shortcut table."
	"wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the 
	capitalized versions of the letters.
	TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values."

	"TextEditor initialize"
	
	| cmds |

	self initializeBasicShiftCmdKeyShortcuts.
	self shiftCmdActions at: (45 + 1) put: #changeEmphasis:.		"cmd-sh-minus"
	self shiftCmdActions at: (61 + 1) put: #changeEmphasis:.		"cmd-sh-plus"

	cmds := #(
		$k	changeStyle:
		"$u #clearUndoManager:	"
	).
	1 to: cmds size by: 2 do: [ :i |
		self shiftCmdActions at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1).			"plain keys"
		self shiftCmdActions at: ((cmds at: i) asciiValue - 32 + 1) put: (cmds at: i + 1).		"shifted keys"
		self shiftCmdActions at: ((cmds at: i) asciiValue - 96 + 1) put: (cmds at: i + 1).		"ctrl keys"
	].! !

!TextEditor class methodsFor: 'settings' stamp: ''!
blinkingCursor: aBoolean	
	BlinkingCursor := aBoolean! !

!TextEditor class methodsFor: 'settings' stamp: ''!
caseSensitiveFinds
	^ CaseSensitiveFinds ifNil: [CaseSensitiveFinds := false]! !

!TextEditor class methodsFor: 'accessing' stamp: ''!
cmdActions
	^cmdActions! !

!TextEditor class methodsFor: 'menu declaration' stamp: ''!
textEditorMenuOn: aBuilder
	"Specify the menu used when writing text. Try it with:
	(PragmaMenuBuilder 
		pragmaKeyword: 'textEditorMenu'
		model: nil) menu popUpInWorld"

	<contextMenu>
	<textEditorMenu>
	(aBuilder item: #'Find...' translated)
		keyText: 'f';
		selector: #find;
		iconName: #smallFindIcon.
	(aBuilder item: #'Find again' translated)
		keyText: 'g';
		selector: #findAgain;
		iconName: #smallFindIcon.
	(aBuilder item: #'Set search string' translated)
		keyText: 'h';
		selector: #setSearchString.
	(aBuilder item: #Undo translated)
		keyText: 'z';
		selector: #undo;
		iconName: #smallUndoIcon;
		withSeparatorAfter.
	(aBuilder item: #Copy translated)
		keyText: 'c';
		selector: #copySelection;
		iconName: #smallCopyIcon.
	(aBuilder item: #Cut translated)
		keyText: 'x';
		selector: #cut;
		iconName: #smallCutIcon.
	(aBuilder item: #Paste translated)
		keyText: 'v';
		selector: #paste;
		iconName: #smallPasteIcon.
	(aBuilder item: #'Paste recent' translated)
		selector: #pasteRecent;
		iconName: #smallCopyIcon;
		withSeparatorAfter.
	(aBuilder item: #'Set font...' translated)
		keyText: 'k';
		selector: #offerFontMenu.
	(aBuilder item: #'Set style...' translated)
		keyText: 'K';
		selector: #changeStyle.
	(aBuilder item: #'Set alignment...' translated)
		selector: #chooseAlignment;
		withSeparatorAfter.
	(aBuilder item: #Accept translated)
		keyText: 's';
		selector: #accept;
		iconName: #smallOkIcon.
	(aBuilder item: #Cancel translated)
		keyText: 'l';
		selector: #cancel;
		iconName: #smallCancelIcon! !

!TextEditorDialogWindow commentStamp: ''!
Multi-line text entry dialog.!
!TextEditorDialogWindow methodsFor: 'accessing' stamp: ''!
cancel
	"Cancel and close."

	self entryText: nil.
	^super cancel! !

!TextEditorDialogWindow methodsFor: 'actions' stamp: ''!
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}! !

!TextEditorDialogWindow methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self beResizeable.
	entryText := ''.
	self changed: #entryText.
	self textEditorMorph selectAll.! !

!TextEditorDialogWindow methodsFor: 'focus handling' stamp: ''!
defaultFocusMorph
	"Answer the morph that should have the keyboard
	focus by default when the dialog is opened."
	
	^self textEditorMorph textMorph! !

!TextEditorDialogWindow methodsFor: 'accessing' stamp: ''!
entryText
	"Answer the value of entryText"

	^ entryText! !

!TextEditorDialogWindow methodsFor: 'accessing' stamp: ''!
textEditorMorph: anObject
	"Set the value of textEditorMorph"

	textEditorMorph := anObject! !

!TextEditorDialogWindow methodsFor: 'accessing' stamp: ''!
entryText: anObject
	"Set the value of entryText"

	entryText := anObject.
	self changed: #entryText.
	self textEditorMorph selectAll.
	self ok.
	self textEditorMorph hasUnacceptedEdits: true.! !

!TextEditorDialogWindow methodsFor: 'private' stamp: ''!
textLines

	^ super textLines, entryText asString lines.! !

!TextEditorDialogWindow methodsFor: 'actions' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self newOKButton. self newCancelButton}! !

!TextEditorDialogWindow methodsFor: 'creation' stamp: ''!
newTextEditorMorph
	"Answer a new text entry morph."
	^(self
		newTextEditorFor: self
		getText: #entryText
		setText: #entryText:
		getEnabled: nil) 
		selectAll! !

!TextEditorDialogWindow methodsFor: 'visual properties' stamp: ''!
icon
	"Answer an icon for the receiver."

	^ self iconNamed: #questionIcon! !

!TextEditorDialogWindow methodsFor: 'private' stamp: ''!
entryHeight: aNumber
	"Set the height of the text editor morph.
	Set the width to be 2 times this also."

	self textEditorMorph
		minHeight: aNumber;
		minWidth: 500! !

!TextEditorDialogWindow methodsFor: 'accessing' stamp: ''!
textEditorMorph
	"Answer the value of textEditorMorph"

	^ textEditorMorph! !

!TextEditorDialogWindow class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#smallQuestionIcon! !

!TextEditorTest commentStamp: ''!
Unit test for text editor !
!TextEditorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.	
	editor := self createEditor! !

!TextEditorTest methodsFor: 'running' stamp: ''!
tearDown
	editor := nil.
	super tearDown ! !

!TextEditorTest methodsFor: 'private - accessing' stamp: ''!
keyboardEvent 
	| event |
	event := KeyboardEvent new.
	event 
		setType: #keystroke
		buttons: 0
		position: 0@0
		keyValue: 0
		charCode: 0
		hand: nil 
		stamp: Time now.
	^ event 	! !

!TextEditorTest methodsFor: 'tests' stamp: ''!
testCursorEnd
	
	editor cursorEnd: self keyboardEvent! !

!TextEditorTest methodsFor: 'tests' stamp: ''!
testSetSearchString
	 
	editor setSearchString! !

!TextEditorTest methodsFor: 'private - accessing' stamp: ''!
createEditor

	^TextMorph new editor! !

!TextEmphasis commentStamp: ''!
A TextEmphasis, encodes a characteristic applicable to all fonts.  The encoding is as follows:
	1	bold
	2	itallic
	4	underlined
	8	narrow
	16	struck out!
!TextEmphasis methodsFor: 'comparing' stamp: ''!
= other 
	^ other value = self value! !

!TextEmphasis methodsFor: 'combining' stamp: ''!
add: anotherCodeOrEmphasis
	"add anotherCodeOrEmphasis to me"
	emphasisCode := emphasisCode bitOr: anotherCodeOrEmphasis value! !

!TextEmphasis methodsFor: 'comparing' stamp: ''!
hash
	"#hash is re-implemented because #= is re-implemented"
	^emphasisCode hash
! !

!TextEmphasis methodsFor: 'accessing' stamp: ''!
emphasisCode: int
	emphasisCode := int.
	setMode := true! !

!TextEmphasis methodsFor: 'private' stamp: ''!
allBits
	^ self class allBits! !

!TextEmphasis methodsFor: 'testing' stamp: ''!
dominatedByCmd0
	"Cmd-0 should turn off emphasis"
	^ true! !

!TextEmphasis methodsFor: 'printing' stamp: ''!
printOn: strm
	super printOn: strm.
	strm nextPutAll: ' code: '; print: emphasisCode! !

!TextEmphasis methodsFor: 'accessing' stamp: ''!
dominates: other
	(emphasisCode = 0 and: [other dominatedByCmd0]) ifTrue: [^ true].
	^ (other class == self class)
		and: [emphasisCode = other emphasisCode]! !

!TextEmphasis methodsFor: 'accessing' stamp: ''!
set
	^ setMode and: [emphasisCode ~= 0]! !

!TextEmphasis methodsFor: 'accessing' stamp: ''!
value
	"a synonym for empahasisCode, to make me polymorphic with Numbers"
	
	^ emphasisCode! !

!TextEmphasis methodsFor: '*Text-Scanning' stamp: ''!
emphasizeScanner: scanner
	"Set the emphasis for text scanning"
	scanner addEmphasis: emphasisCode! !

!TextEmphasis methodsFor: 'combining' stamp: ''!
remove: anotherCodeOrEmphasis
	"remove anotherCodeOrEmphasis from me"
	emphasisCode := emphasisCode bitAnd: 
		((anotherCodeOrEmphasis value bitInvert) bitAnd: (self allBits))! !

!TextEmphasis methodsFor: 'accessing' stamp: ''!
emphasisCode
	^ emphasisCode! !

!TextEmphasis methodsFor: 'accessing' stamp: ''!
turnOff
	setMode := false! !

!TextEmphasis class methodsFor: 'instance creation' stamp: ''!
narrow
	^ self new emphasisCode: 8! !

!TextEmphasis class methodsFor: 'instance creation' stamp: ''!
italic
	^ self new emphasisCode: 2! !

!TextEmphasis class methodsFor: 'instance creation' stamp: ''!
bold
	^ self new emphasisCode: 1! !

!TextEmphasis class methodsFor: 'instance creation' stamp: ''!
struckOut
	^ self new emphasisCode: 16! !

!TextEmphasis class methodsFor: 'constants' stamp: ''!
allBits
	"all of the bits use in encoding my Instances"

	^2r11111! !

!TextEmphasis class methodsFor: 'instance creation' stamp: ''!
normal
	^ self new emphasisCode: 0! !

!TextEmphasis class methodsFor: 'instance creation' stamp: ''!
fromCode: anIntegerBitMask
	^ self new emphasisCode: (anIntegerBitMask bitAnd: self allBits)! !

!TextEmphasis class methodsFor: 'instance creation' stamp: ''!
underlined
	^ self new emphasisCode: 4! !

!TextEmphasisTest commentStamp: ''!
SUnit tests for TextEmphasis!
!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testNormal
	self assert: TextEmphasis normal equals: 0
! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testSet
	"Not set with normal emphasis..."
	self deny: TextEmphasis normal set.
	"...but set for the other emphasis"
	#(#bold #italic #underlined #narrow #struckOut) do: [ :anEmphasis |
		self assert: (TextEmphasis perform: anEmphasis) set].
	"and can be turned off"
	#(#bold #italic #underlined #narrow #struckOut) do: [ :anEmphasis |
		| attr |
		attr := TextEmphasis perform: anEmphasis.
		attr turnOff.
		self deny: attr set].! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testValue
	| attr |
	"asking for the value return the emphasis code"
	self assert: TextEmphasis normal value equals: 0.
	self assert: TextEmphasis bold value equals: 1.
	self assert: TextEmphasis italic value equals: 2.
	self assert: TextEmphasis underlined value equals: 4.
	self assert: TextEmphasis narrow value equals: 8.
	self assert: TextEmphasis struckOut value equals: 16.

	"We can add the emphasisCode, value should respond accordingly"
	attr := TextEmphasis new emphasisCode: 
		TextEmphasis italic emphasisCode 
		+ TextEmphasis bold emphasisCode 
		+ TextEmphasis struckOut  emphasisCode.
	self assert: attr value equals: 2r10011.
	"equality is based on the value"
	self assert: attr equals: 2r10011! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testFromCode
	| t1 |
	t1 := TextEmphasis fromCode: 2r10101.
	self assert: t1 value equals: 2r10101! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testAdd
	| t1 |
	t1 := TextEmphasis bold.
	t1 add: TextEmphasis italic.
	self assert: (t1 = 2r11) description: 'bold and italics didn''t add correctly'! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testStruckOut
	self assert: TextEmphasis struckOut equals: 16
! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testEmphasisCode
	| attr |
	"test each emphasis code value"
	self assert: TextEmphasis normal emphasisCode equals: 0.
	self assert: TextEmphasis bold emphasisCode equals: 1.
	self assert: TextEmphasis italic emphasisCode equals: 2.
	self assert: TextEmphasis underlined emphasisCode equals: 4.
	self assert: TextEmphasis narrow emphasisCode equals: 8.
	self assert: TextEmphasis struckOut emphasisCode equals: 16.
	"Turn bold to underlined"
	attr := TextEmphasis bold emphasisCode: 4.
	self assert: attr equals: 4.
	"We can add the emphasisCode"
	attr := TextEmphasis new emphasisCode: 
		TextEmphasis italic emphasisCode 
		+ TextEmphasis bold emphasisCode 
		+ TextEmphasis struckOut  emphasisCode.
	self assert: attr emphasisCode equals: 2r10011! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testNarrow
	self assert: TextEmphasis narrow  equals: 8
! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testItalic
	self assert: TextEmphasis italic equals: 2
! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testBold
	self assert: TextEmphasis bold equals: 1.
! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testDominatedByCmd0
	self assert: TextEmphasis new dominatedByCmd0! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testRemove
	| t1  |
	t1 := TextEmphasis bold.
	t1 add: TextEmphasis italic.
	t1 remove: TextEmphasis bold.
	self assert: t1 = TextEmphasis italic description: 'Removing bold didn''t leave italics'! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testDominates
	| text |
	"self domination"
	#(#bold #italic  #underlined #narrow #struckOut) do: [ :anEmphasis |
		self assert: ((TextEmphasis perform: anEmphasis) dominates: (TextEmphasis perform: anEmphasis)) ].
	"different emphasis can be mixed, no dominant attribute"
	#(#bold #italic  #underlined #narrow #struckOut) 
		with: #(#struckOut #underlined  #narrow #italic #bold) 
		do: [:emph1 :emph2 | self deny: ((TextEmphasis perform: emph1) dominates: (TextEmphasis perform: emph2)) ].
	"In action"
	text := 'Pharo is cool' asText.
	text addAttribute: TextEmphasis bold.
	"Only one bold at time"
	text addAttribute: TextEmphasis bold.
	self assert: (text attributesAt: 1) size equals: 1.
	self assert: (text attributesAt: 1) first emphasisCode equals: 1.
	"but can be both bold and underlined"
	text addAttribute: TextEmphasis underlined.
	self assert: (text attributesAt: 1) size equals: 2.
	self assert: (text attributesAt: 1) first emphasisCode equals: 1.
	self assert: (text attributesAt: 1) second emphasisCode equals: 4.
	"and even in italic"
	text addAttribute: TextEmphasis italic.
	self assert: (text attributesAt: 1) size equals: 3.
	self assert: (text attributesAt: 1) third emphasisCode equals: 2.! !

!TextEmphasisTest methodsFor: 'tests' stamp: ''!
testUnderlined
	self assert: TextEmphasis underlined equals: 4
! !

!TextEmphasisTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	prototypes add: TextEmphasis bold;
		 add: TextEmphasis italic;
		 add: TextEmphasis narrow;
		 add: TextEmphasis normal;
		 add: TextEmphasis struckOut;
		 add: TextEmphasis underlined ! !

!TextEntryDialogWindow commentStamp: ''!
Single-line text entry dialog.!
!TextEntryDialogWindow methodsFor: 'api' stamp: ''!
initialExtent
	^ self minimumWidth @ (super initialExtent y)! !

!TextEntryDialogWindow methodsFor: 'accessing' stamp: ''!
minimumWidth
	^ (super minimumWidth max: self class minimumWidth) min: (Display width)! !

!TextEntryDialogWindow methodsFor: 'accessing' stamp: ''!
withDropListButton
	self textEditorMorph withDropListButton! !

!TextEntryDialogWindow methodsFor: 'accessing' stamp: ''!
newButtons
	"Answer new buttons as appropriate."

	^{self newOKButton isDefault: true. self newCancelButton}! !

!TextEntryDialogWindow methodsFor: 'creation' stamp: ''!
newTextEditorMorph
	"Answer a new text entry morph."

	^(self
		newTextEntryFor: self
		getText: #entryText
		setText: #entryText:
		getEnabled: nil
		help: nil)
		selectAll! !

!TextEntryDialogWindow methodsFor: 'accessing' stamp: ''!
entryCompletion: anEntryCompletion
	anEntryCompletion chooseBlock: [:t | self ok].
	self textEditorMorph entryCompletion: anEntryCompletion! !

!TextEntryDialogWindow class methodsFor: 'settings' stamp: ''!
minimumWidth
	^ MinimumWidth ifNil: [MinimumWidth := 450]! !

!TextEntryDialogWindow class methodsFor: 'settings' stamp: ''!
minimumWidth: anInteger
	MinimumWidth := anInteger! !

!TextFontChange commentStamp: ''!
A TextFontChange encodes a font change applicable over a given range of text.  
The font number is interpreted relative to the textStyle governing display of this text.!
!TextFontChange methodsFor: 'comparing' stamp: ''!
= other 
	^ (other class == self class) 
		and: [other fontNumber = fontNumber]! !

!TextFontChange methodsFor: 'comparing' stamp: ''!
hash
	"#hash is re-implemented because #= is re-implemented"
	^fontNumber hash! !

!TextFontChange methodsFor: 'printing' stamp: ''!
printOn: strm
	super printOn: strm.
	strm nextPutAll: ' font: '; print: fontNumber! !

!TextFontChange methodsFor: '*Text-Scanning' stamp: ''!
emphasizeScanner: scanner
	"Set the font for text display"
	scanner setFont: fontNumber! !

!TextFontChange methodsFor: 'accessing' stamp: ''!
dominates: other
	^ other isKindOf: TextFontChange! !

!TextFontChange methodsFor: 'styling' stamp: ''!
forFontInStyle: aTextStyle do: aBlock
	aBlock value: (aTextStyle fontAt: fontNumber)! !

!TextFontChange methodsFor: 'accessing' stamp: ''!
fontNumber
	^ fontNumber! !

!TextFontChange methodsFor: 'accessing' stamp: ''!
fontNumber: int
	fontNumber := int! !

!TextFontChange class methodsFor: 'defaults' stamp: ''!
font1
	^ self new fontNumber: 1! !

!TextFontChange class methodsFor: 'private' stamp: ''!
defaultFontChange
  "Answer a TextFontChange that represents the default font"

  | defaultFontStyle fontIndex |

  defaultFontStyle := TextStyle default.
  fontIndex := defaultFontStyle ifNil: [1] ifNotNil: [defaultFontStyle defaultFontIndex].

  ^ self new fontNumber: fontIndex.
! !

!TextFontChange class methodsFor: 'defaults' stamp: ''!
font2
	^ self new fontNumber: 2! !

!TextFontChange class methodsFor: 'defaults' stamp: ''!
font3
	^ self new fontNumber: 3! !

!TextFontChange class methodsFor: 'defaults' stamp: ''!
font4
	^ self new fontNumber: 4! !

!TextFontChange class methodsFor: 'instance creation' stamp: ''!
fontNumber: n
	^ self new fontNumber: n! !

!TextFontChangeTest commentStamp: ''!
SUnit tests for class TextFontChange!
!TextFontChangeTest methodsFor: 'tests' stamp: ''!
testEquality
	"Check that different instances of the same TextFontChange are equal"
	self assert: TextFontChange defaultFontChange equals: TextFontChange defaultFontChange.
	self assert: TextFontChange font1 equals: TextFontChange font1.
	self assert: TextFontChange font2 equals: TextFontChange font2.
	self assert: TextFontChange font3 equals: TextFontChange font3.
	self assert: TextFontChange font4 equals: TextFontChange font4.
	self assert: (TextFontChange fontNumber: 6) equals: (TextFontChange fontNumber: 6)! !

!TextFontChangeTest methodsFor: 'tests' stamp: ''!
testHash
	"test that different instances of the same TextFontChange hash to the 
	same value"
	| hashes hash |
	hashes := OrderedCollection new.
	1
		to: 100
		do: [:i | hashes add: TextFontChange defaultFontChange hash].
	hash := hashes at: 1.
	2
		to: 100
		do: [:i | self assert: (hashes at: i) equals: hash]! !

!TextFontChangeTest methodsFor: 'running' stamp: ''!
setUp
	"create the prototypes for testing"
	super setUp.
	prototypes add: TextFontChange defaultFontChange.
	prototypes add: TextFontChange font1.
	prototypes add: TextFontChange font2.
	prototypes add: TextFontChange font3.
	prototypes add: TextFontChange font4.
	prototypes
		add: (TextFontChange fontNumber: 6) ! !

!TextFontReference commentStamp: ''!
A TextFontReference encodes a font change applicable over a given range of text.  
The font reference is absolute:  unlike a TextFontChange, it is independent of the textStyle governing display of this text.

-----exemple--------
| stream |
stream := TextStream on: (Text new: 100).
stream 
	nextPutAll: 'Small is ';
	withAttribute: (TextFontReference toFont: (LogicalFont familyName: 'Source Sans Pro' pointSize: 8) )
	do: [ stream nextPutAll: 'cool' ].
TextMorph new 
	newContents: stream contents;
	openInWindow!
!TextFontReference methodsFor: 'comparing' stamp: ''!
= other 
	^ (other class == self class) 
		and: [other font = font]! !

!TextFontReference methodsFor: 'comparing' stamp: ''!
hash
	"#hash is re-implemented because #= is re-implemented"
	^font hash! !

!TextFontReference methodsFor: 'accessing' stamp: ''!
font

	^ font! !

!TextFontReference methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: 'a TextFontReference(';
		print: font;
		nextPut: $)! !

!TextFontReference methodsFor: 'accessing' stamp: ''!
toFont: aFont

	font := aFont! !

!TextFontReference methodsFor: '*Text-Scanning' stamp: ''!
emphasizeScanner: scanner
	"Set the actual font for text display"
	scanner setActualFont: font! !

!TextFontReference methodsFor: 'styling' stamp: ''!
forFontInStyle: aTextStyle do: aBlock
	aBlock value: font! !

!TextFontReference class methodsFor: 'instance creation' stamp: ''!
toFont: aFont
	^ self new toFont: aFont! !

!TextFontReferenceTest commentStamp: ''!
SUnit tests for TextFontReference!
!TextFontReferenceTest methodsFor: 'accessing' stamp: ''!
testFont
	| font text |
	font := LogicalFont familyName: 'Source Sans Pro' pointSize: 8.
	text := 'Hello' asText addAttribute: (TextFontReference toFont: font).
	"Querry the font in this text"
	self assert: (text runs at: 1) first font equals: font! !

!TextFontReferenceTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	prototypes
		add: (TextFontReference
				toFont: (StrikeFont familyName: 'NewYork' size: 15)) ! !

!TextHighlightByBounds commentStamp: ''!
Definition of a clickable highlighted range of text with optional borders.!
!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
color: anObject
	"Set the value of color"

	color := anObject! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
position
	"Answer the bounds top left."
	
	^self bounds topLeft! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
bounds
	"Answer the value of bounds"

	^ bounds! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
borderWidth: anObject
	"Set the value of borderWidth"

	borderWidth := anObject! !

!TextHighlightByBounds methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		color: Color yellow;
		lineRange: (1 to: 0);
		borderWidth: 0;
		borderColor: Color transparent;
		borderSides: #(top right bottom left);
		fillWidth: false! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
borderWidth
	"Answer the value of borderWidth"

	^ borderWidth! !

!TextHighlightByBounds methodsFor: 'drawing' stamp: ''!
clicked: evt
	"The receiver has had a mouse down."

	self triggerEvent: #clicked! !

!TextHighlightByBounds methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas in: rect offset: o
	"Draw the highlight on the given canvas for the given rectangle."

	| r |
	r := self fillWidth
		ifTrue: [ rect left @ (self bounds top + rect top) corner: rect right @ (self bounds bottom + rect top) ]
		ifFalse: [ self bounds translateBy: rect topLeft ].
	r := r
		translateBy:
			(self fillWidth
				ifTrue: [ 0 @ o y negated ]
				ifFalse: [ o negated ]).
	self color isTransparent
		ifFalse: [ aCanvas fillRectangle: r color: self color ].
	(self borderWidth > 0 and: [ self borderColor isTransparent not ])
		ifTrue: [ 
			(self borderSides includes: #top)
				ifTrue: [ aCanvas fillRectangle: (r withHeight: self borderWidth) color: self borderColor ].
			(self borderSides includes: #right)
				ifTrue: [ aCanvas fillRectangle: (r withLeft: r right - self borderWidth) color: self borderColor ].
			(self borderSides includes: #bottom)
				ifTrue: [ aCanvas fillRectangle: (r withTop: r bottom - self borderWidth) color: self borderColor ].
			(self borderSides includes: #left)
				ifTrue: [ aCanvas fillRectangle: (r withWidth: self borderWidth) color: self borderColor ] ]! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
lineRange
	"Answer the value of lineRange"

	^ lineRange! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
position: aPoint
	"Set the bounds top left."
	
	self bounds: (aPoint extent: self bounds extent)! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
borderColor: anObject
	"Set the value of borderColor"

	borderColor := anObject! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
borderSides: anObject
	"Set the value of borderSides"

	borderSides := anObject! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
bounds: anObject
	"Set the value of bounds"

	bounds := anObject! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
fillWidth
	"Answer the value of fillWidth"

	^ fillWidth! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
lineRange: anObject
	"Set the value of lineRange"

	lineRange := anObject! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
fillWidth: anObject
	"Set the value of fillWidth"

	fillWidth := anObject! !

!TextHighlightByBounds methodsFor: 'testing' stamp: ''!
containsPoint: aPoint in: rect
	"Answer whther the bounds contain the given (local coordinate) point."

	|r|
	r := self bounds ifNil: [^ false ].
	r := self fillWidth
		ifTrue: [rect left @ r top corner: (rect right @ r bottom)]
		ifFalse: [r]. 
	^r containsPoint: aPoint! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
borderSides
	"Answer the value of borderSides"

	^ borderSides! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
lineNumber
	"Answer the first in the line range."

	^self lineRange first! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
borderColor
	"Answer the value of borderColor"

	^ borderColor! !

!TextHighlightByBounds methodsFor: 'accessing' stamp: ''!
color
	"Answer the value of color"

	^ color! !

!TextIndent commentStamp: ''!
An attribute to indent text at the left.

------exemple------
| stream |
stream := TextStream on: (Text new: 100).
stream 
	withAttribute: (TextIndent tabs: 1) do: [ stream nextPutAll: 'Pharo is cool'];
	cr;
	withAttribute: (TextIndent tabs: 2) do: [stream nextPutAll: 'Smalltalk is cool'].
TextMorph new 
	newContents: stream contents;
	openInWindow.!
!TextIndent methodsFor: 'accessing' stamp: ''!
amount: anInteger
	"change the number of tabs to indent by"
	amount := anInteger! !

!TextIndent methodsFor: 'printing' stamp: ''!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' amount: '.
	amount printOn: aStream! !

!TextIndent methodsFor: '*Text-Scanning' stamp: ''!
emphasizeScanner: scanner
	scanner indentationLevel: amount! !

!TextIndent methodsFor: 'accessing' stamp: ''!
amount
	"number of tab spaces to indent by"
	^amount! !

!TextIndent methodsFor: 'condensing' stamp: ''!
dominates: anAttribute
	^(self class == anAttribute class)! !

!TextIndent class methodsFor: 'instance creation' stamp: ''!
tabs: numTabs
	"create an indentation by the given number of tabs"
	^self amount: numTabs! !

!TextIndent class methodsFor: 'instance creation' stamp: ''!
amount: amount
	"create a TextIndent which will indent by the given amount.  Currently this is a number of tabs, but may change in the futur"
	^self new amount: amount! !

!TextIndentTest methodsFor: 'tests' stamp: ''!
testAmount
	| text  |
	text := 'Hello' asText addAttribute: (TextIndent amount: 2).
	self assert: text runs first first amount equals: 2! !

!TextIndentTest methodsFor: 'tests' stamp: ''!
testTabs
	| text  |
	"tabs: is a synonym for amount:"
	text := 'Hello' asText addAttribute: (TextIndent tabs: 4).
	self assert: text runs first first amount equals: 4! !

!TextIndentTest methodsFor: 'tests' stamp: ''!
testDominates
	self assert: ((TextIndent tabs: 1) dominates: (TextIndent tabs: 2)).
	self deny: ((TextIndent tabs: 1) dominates: TextEmphasis bold).
	self deny: ((TextIndent tabs: 1) dominates: TextFontChange font2).
! !

!TextInputFieldPresenter commentStamp: ''!
I handle one line of text.
See TextPresenter

self example

You can also have a look at DynamicalPopup for another example.

I handle non source code text, that's why editing shortcuts are not supported (cmd+p just print a p by example).

I provide the following variables and their accessors
- acceptOnCR is a boolean representing if the key cr trigger an accept action,  it is true by default and must be set before built the widget. (if false it will print a cr).
- encrypted is a boolean representing if the text appear like stars (it is only an appearance), beDecrypted and beEncrypted are shortcut to set it.
- entryCompletion is the object used to suggest text while typing, removeEntryCompletion is a shortcut to set it nil.
- ghostText is the ghost text to display in the text zone.

I provide getters of ValueHolder of my super class actionToPerformHolder and textHolder .


todo
- specializing accept:
- specializing eventKeyStrokesForNextFocus , eventKeyStrokesForPreviousFocus
- globalsEntryCompletion
- specializing isCodeCompletionAllowed
!
!TextInputFieldPresenter methodsFor: 'api - events' stamp: ''!
text 
	
	^ self getText asString! !

!TextInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenAcceptOnCRChanged: aBlock
	"aBlock will be performed when acceptOnCR changed"
	
	acceptOnCR whenChangedDo: aBlock! !

!TextInputFieldPresenter methodsFor: 'api' stamp: ''!
removeEntryCompletion
	"< api:#do>"
	"Remove the entry completion"
	
	self entryCompletion: nil! !

!TextInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenGhostTextChanged: aBlock
	"aBlock will be performed when ghostText changed"
	
	ghostText whenChangedDo: aBlock! !

!TextInputFieldPresenter methodsFor: 'api' stamp: ''!
beDecrypted
	"<api: #do>"
	"Decrypt the entered text"
	
	self encrypted: false! !

!TextInputFieldPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	
	ghostText := '' asValueHolder.
	acceptOnCR := true asValueHolder.
	entryCompletion := nil asValueHolder.
	isEncrypted := false asValueHolder.
	
	ghostText  whenChangedDo: [ :txt | self changed: #ghostText: with: { txt } ].
	acceptOnCR whenChangedDo: [ :bool | self changed: #acceptOnCR: with: { bool } ].
	isEncrypted whenChangedDo: [ :bool | self changed: #encrypted: with: { bool } ].! !

!TextInputFieldPresenter methodsFor: 'api' stamp: ''!
entryCompletion
	"<api: #st getter: #entryCompletion registration: #whenEntryCompletionChanged:>"
	"Return an entry completion used to suggest text while typing"

	^ entryCompletion value! !

!TextInputFieldPresenter methodsFor: 'accessing' stamp: ''!
encrypted: aBoolean

	isEncrypted value: aBoolean ! !

!TextInputFieldPresenter methodsFor: 'accessing' stamp: ''!
encrypted

	^ isEncrypted value! !

!TextInputFieldPresenter methodsFor: 'accessing' stamp: ''!
textHolder

	^ textHolder! !

!TextInputFieldPresenter methodsFor: 'api' stamp: ''!
acceptOnCR: aBoolean
	"<api: #boolean getter: #acceptOnCR registration: #whenAcceptOnCRChanged:>"
	"Set if the text is accepted when the Enter key is stroked or not"

	acceptOnCR value: aBoolean! !

!TextInputFieldPresenter methodsFor: 'accessing' stamp: ''!
ghostText: aText
	"<api: #string getter: #ghostText registration: #whenGhostTextChanged:>"
	"Set the ghost text of the text zone"

	ghostText value: aText.! !

!TextInputFieldPresenter methodsFor: 'api - events' stamp: ''!
whenEntryCompletionChanged: aBlock
	"aBlock will be performed when entryCompletion changed"
	
	entryCompletion whenChangedDo: aBlock! !

!TextInputFieldPresenter methodsFor: 'api' stamp: ''!
entryCompletion: anEntryCompletion
	"<api: #st getter: #entryCompletion registration: #whenEntryCompletionChanged:>"
	"Set an entry completion used to suggest text while typing"

	entryCompletion value: anEntryCompletion.! !

!TextInputFieldPresenter methodsFor: 'focus' stamp: ''!
eventKeyStrokesForPreviousFocus
	"String describing the keystroke to perform to jump to the previous widget"
	
	^ { Character tab shift asKeyCombination }! !

!TextInputFieldPresenter methodsFor: 'accessing' stamp: ''!
actionToPerformHolder

	^ actionToPerformHolder! !

!TextInputFieldPresenter methodsFor: 'api' stamp: ''!
beEncrypted
"	<api: #do>"
	"Encrypt the entered text"
	
	self encrypted: true! !

!TextInputFieldPresenter methodsFor: 'focus' stamp: ''!
eventKeyStrokesForNextFocus
	"String describing the keystroke to perform to jump to the next widget"	
		
	^ { Character tab asKeyCombination }! !

!TextInputFieldPresenter methodsFor: 'morphic' stamp: ''!
accept: aText

	textHolder value: aText.
	actionToPerformHolder value cull: aText.
	
	"Dummy changed to raise an announcement"
	actionPerformedHolder value: aText.
	self changed: #clearUserEdits.! !

!TextInputFieldPresenter methodsFor: 'api' stamp: ''!
acceptOnCR
	"<api: #inspect>"
	"Return true if the text is accepted when the Enter key is stroked"

	^ acceptOnCR value! !

!TextInputFieldPresenter methodsFor: 'api' stamp: ''!
ghostText
	"<api: #inspect>"
	"Return the ghost text of the text zone"

	^ ghostText value! !

!TextInputFieldPresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new
	 extent: 300 @ 25;
	 openWithSpec;
	 ghostText: 'This is a ghost';
	 text: 'This is a text'! !

!TextInputFieldPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(TextInputFieldAdapter
		adapt: #(model))! !

!TextInputFieldPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TextInputFieldAdapter! !

!TextKern commentStamp: ''!
A TextKern encodes a kerning change applicable over a given range of text.  Positive values of kern spread letters out, negative kern will cause them to overlap more.  Note that kerns other than 0 will display somewhat slower, as kerning is not yet supported in the text scanning primitive. 

-----exemple-------
| stream |
stream := TextStream on: (Text new: 100).
stream 
	withAttribute: (TextKern  kern: 1) do: [ stream nextPutAll: 'Pharo is cool'];
	cr;
	nextPutAll: 'Pharo is cool'; cr;
	withAttribute: (TextKern kern: -1) do: [stream nextPutAll: 'Pharo is cool'].
TextMorph new 
	newContents: stream contents;
	openInWindow.!
!TextKern methodsFor: 'comparing' stamp: ''!
= other 
	^ (other class == self class) 
		and: [other kern = kern]! !

!TextKern methodsFor: 'comparing' stamp: ''!
hash
	"#hash is re-implemented because #= is re-implemented"
	^kern hash! !

!TextKern methodsFor: 'accessing' stamp: ''!
kern: kernValue
	kern := kernValue.
	self reset.! !

!TextKern methodsFor: 'accessing' stamp: ''!
dominatedByCmd0
	"Cmd-0 should turn off kerning"
	^ true! !

!TextKern methodsFor: 'accessing' stamp: ''!
kern
	^ kern! !

!TextKern methodsFor: 'accessing' stamp: ''!
dominates: other
	"NOTE: The use of active in this code is specific to its use in the method
		Text class addAttribute: att toArray: others"
	(active and: [other class == self class and: [other kern + kern = 0]])
		ifTrue: [active := false.  ^ true].  "can only dominate once"
	^ false! !

!TextKern methodsFor: 'accessing' stamp: ''!
set
	^ active! !

!TextKern methodsFor: '*Text-Scanning' stamp: ''!
emphasizeScanner: scanner
	"Augment (or diminish) the kerning offset for text display"
	scanner addKern: kern! !

!TextKern methodsFor: 'testing' stamp: ''!
isKern
	^true! !

!TextKern methodsFor: 'initialization' stamp: ''!
reset
	active := true! !

!TextKern class methodsFor: 'instance creation' stamp: ''!
kern: kernValue
	^ self new kern: kernValue! !

!TextKernTest commentStamp: ''!
SUnit tests for class TextKern!
!TextKernTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	prototypes
		add: (TextKern kern: 1) ! !

!TextLine commentStamp: ''!
A TextLine embodies the layout of a line of composed text.
	left right top bottom		The full line rectangle
	firstIndex lastIndex		Starting and stopping indices in the full text
	internalSpaces		Number of spaces to share paddingWidth
	paddingWidth		Number of pixels of extra space in full line
	baseline				Distance of baseline below the top of the line
	leftMargin			Left margin due to paragraph indentation
TextLine's rather verbose message protocol is required for compatibility with the old CharacterScanners.!
!TextLine methodsFor: 'private' stamp: ''!
firstIndex: firstInteger lastIndex: lastInteger

	firstIndex := firstInteger.
	lastIndex := lastInteger! !

!TextLine methodsFor: 'comparing' stamp: ''!
= line

	^ self species = line species
		  ifTrue: [ 
			  ((firstIndex = line first and: [ lastIndex = line last ]) and: [ 
				   internalSpaces = line internalSpaces ]) and: [ 
				  paddingWidth = line paddingWidth ] ]
		  ifFalse: [ false ]! !

!TextLine methodsFor: 'comparing' stamp: ''!
hash
	"#hash is re-implemented because #= is re-implemented"

	^ firstIndex hash bitXor: lastIndex hash! !

!TextLine methodsFor: 'accessing' stamp: ''!
rectangle: lineRectangle

	left := lineRectangle left.
	right := lineRectangle right.
	top := lineRectangle top.
	bottom := lineRectangle bottom! !

!TextLine methodsFor: 'updating' stamp: ''!
moveBy: delta
	"Move my rectangle by the given delta"

	left := left + delta x.
	right := right + delta x.
	top := top + delta y.
	bottom := bottom + delta y! !

!TextLine methodsFor: 'accessing' stamp: ''!
bottomRight

	^ right @ bottom! !

!TextLine methodsFor: 'updating' stamp: ''!
slideIndexBy: delta andMoveTopTo: newTop
	"Relocate my character indices and y-values.
	Used to slide constant text up or down in the wake of a text replacement."

	firstIndex := firstIndex + delta.
	lastIndex := lastIndex + delta.
	bottom := bottom + (newTop - top).
	top := newTop! !

!TextLine methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	aStream
		space;
		print: firstIndex;
		nextPutAll: ' to: ';
		print: lastIndex! !

!TextLine methodsFor: '*FreeType-Morphic' stamp: ''!
justifiedPadFor: spaceIndex font: aFont
	"Compute the width of pad for a given space in a line of justified text."
	| pad |

	internalSpaces = 0 ifTrue: [ ^ 0 ].
	^ (aFont notNil and: [ aFont isSubPixelPositioned ])
		ifTrue: [ paddingWidth * 1.0 / internalSpaces ]
		ifFalse: [
			pad := paddingWidth // internalSpaces.
			spaceIndex <= (paddingWidth \\ internalSpaces)
				ifTrue: [ pad + 1 ]
				ifFalse: [ pad ] ]! !

!TextLine methodsFor: 'accessing' stamp: ''!
internalSpaces
	"Answer the number of spaces in the line."

	^internalSpaces! !

!TextLine methodsFor: 'accessing' stamp: ''!
rightMargin
	"This has to get fixed -- store during composition"

	^ self right! !

!TextLine methodsFor: 'private' stamp: ''!
internalSpaces: spacesInteger paddingWidth: padWidthInteger

	internalSpaces := spacesInteger.
	paddingWidth := padWidthInteger! !

!TextLine methodsFor: 'accessing' stamp: ''!
first

	^ firstIndex! !

!TextLine methodsFor: 'scanning' stamp: ''!
justifiedTabDeltaFor: spaceIndex
	"Compute the delta for a tab in a line of justified text, so tab falls 
	somewhere plausible when line is justified."

	| pad extraPad |
	internalSpaces = 0 ifTrue: [ ^ 0 ].
	pad := paddingWidth // internalSpaces.
	extraPad := paddingWidth \\ internalSpaces.
	^ spaceIndex <= extraPad
		ifTrue: [ spaceIndex * (pad + 1) ]
		ifFalse: [ extraPad * (pad + 1) + ((spaceIndex - extraPad) * pad) ]! !

!TextLine methodsFor: 'accessing' stamp: ''!
last

	^ lastIndex! !

!TextLine methodsFor: 'accessing' stamp: ''!
leftMargin
	"This has to get fixed -- store during composition"

	^ self left! !

!TextLine methodsFor: 'accessing' stamp: ''!
leftMargin: lm

	left := lm! !

!TextLine methodsFor: 'accessing' stamp: ''!
leftMarginForAlignment: alignmentCode

	alignmentCode = RightFlush ifTrue: [ ^ self left + paddingWidth ].
	alignmentCode = Centered ifTrue: [ ^ self left + (paddingWidth // 2) ].
	^ self left "leftFlush and justified"! !

!TextLine methodsFor: 'accessing' stamp: ''!
lineHeight

	^ bottom - top! !

!TextLine methodsFor: 'accessing' stamp: ''!
rectangle

	^ self topLeft corner: self bottomRight! !

!TextLine methodsFor: 'scanning' stamp: ''!
justifiedPadFor: spaceIndex
	"Compute the width of pad for a given space in a line of justified text."

	| pad |
	internalSpaces = 0 ifTrue: [ ^ 0 ].
	pad := paddingWidth // internalSpaces.
	^ spaceIndex <= (paddingWidth \\ internalSpaces)
		ifTrue: [ pad + 1 ]
		ifFalse: [ pad ]! !

!TextLine methodsFor: 'updating' stamp: ''!
slide: delta 
	"Change the starting and stopping points of the line by delta."

	firstIndex := firstIndex + delta.
	lastIndex := lastIndex + delta! !

!TextLine methodsFor: 'accessing' stamp: ''!
bottom

	^ bottom! !

!TextLine methodsFor: 'accessing' stamp: ''!
right

	^ right! !

!TextLine methodsFor: 'accessing' stamp: ''!
paddingWidth
	"Answer the amount of space to be added to the font."

	^paddingWidth! !

!TextLine methodsFor: 'private' stamp: ''!
lineHeight: height baseline: ascent

	bottom := top + height.
	baseline := ascent! !

!TextLine methodsFor: 'accessing' stamp: ''!
width

	^ right - left! !

!TextLine methodsFor: 'accessing' stamp: ''!
left

	^ left! !

!TextLine methodsFor: 'accessing' stamp: ''!
setRight: x

	right := x! !

!TextLine methodsFor: 'accessing' stamp: ''!
topLeft

	^ left @ top! !

!TextLine methodsFor: 'accessing' stamp: ''!
internalSpaces: spacesInteger 
	"Set the number of spaces in the line to be spacesInteger."

	internalSpaces := spacesInteger! !

!TextLine methodsFor: 'accessing' stamp: ''!
paddingWidth: padWidthInteger 
	"Set the amount of space to be added to the font to be padWidthInteger."

	paddingWidth := padWidthInteger! !

!TextLine methodsFor: 'accessing' stamp: ''!
top

	^ top! !

!TextLine methodsFor: 'accessing' stamp: ''!
stop: stopInteger 
	"Set the stopping point in the string of the line to be stopInteger."

	lastIndex := stopInteger! !

!TextLine methodsFor: 'accessing' stamp: ''!
baseline

	^ baseline! !

!TextLine class methodsFor: 'instance creation' stamp: ''!
start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger
	"Answer an instance of me with the arguments as the start, stop points, 
	number of spaces in the line, and width of the padding."
	
	| line |
	line := self new firstIndex: startInteger lastIndex: stopInteger.
	^ line internalSpaces: spacesInteger paddingWidth: padWidthInteger! !

!TextLineEndingsTest commentStamp: ''!
This is a test case for Text>>withSqueakLineEndings and String>>withSqueakLineEndings.

The main problem we've seen with the Text version is that it doesn't preserve formatting correctly.!
!TextLineEndingsTest methodsFor: 'tests' stamp: ''!
testStringConversionNoLF

	| string newString |
	string := 'This is a test', String cr, 'of the conversion'.
	newString := string withInternalLineEndings.
	self assert: string equals: newString! !

!TextLineEndingsTest methodsFor: 'tests' stamp: ''!
testSimpleTextConversionCrLF

	| string newText |
	string := 'This is a test', String crlf, 'of the conversion'.
	newText := string asText withInternalLineEndings.
	self assert: (string size - 1) equals: newText size.
	self assert: newText size equals: newText runs size.! !

!TextLineEndingsTest methodsFor: 'tests' stamp: ''!
testDecoratedTextConversionNoLF

	| text newText |
	text := ('123456', String cr, '901234') asText.
	text addAttribute: TextColor blue from: 4 to: 10.
	text addAttribute: TextColor red from: 6 to: 9.
	text addAttribute: TextEmphasis bold.
	newText := text withInternalLineEndings.
	self assert: (text size) equals: newText size.
	self assert: newText size equals: newText runs size.
	self assert: (newText attributesAt: 6) equals: (text attributesAt: 6).
	self assert: (newText attributesAt: 8) equals: (text attributesAt: 8).! !

!TextLineEndingsTest methodsFor: 'tests' stamp: ''!
testStringConversionCrLF

	| string newString |
	string := 'This is a test', String crlf, 'of the conversion'.
	newString := string withInternalLineEndings.
	self assert: (string size - 1) equals: newString size! !

!TextLineEndingsTest methodsFor: 'tests' stamp: ''!
testSimpleTextConversionJustLF

	| string newText |
	string := 'This is a test', String lf, 'of the conversion'.
	newText := string asText withInternalLineEndings.
	self assert: string size equals: newText size.
	self assert: newText size equals: newText runs size! !

!TextLineEndingsTest methodsFor: 'tests' stamp: ''!
testSimpleTextConversionJustCR

	| string newText |
	string := 'This is a test', String cr, 'of the conversion'.
	newText := string asText withInternalLineEndings.
	self assert: string size equals: newText size.
	self assert: newText size equals: newText runs size! !

!TextLineEndingsTest methodsFor: 'tests' stamp: ''!
testDecoratedTextConversionJustLF

	| text newText |
	text := ('123456', String lf, '901234') asText.
	text addAttribute: TextColor blue from: 4 to: 10.
	text addAttribute: TextColor red from: 6 to: 9.
	text addAttribute: TextEmphasis bold.
	newText := text withInternalLineEndings.
	self assert: (text size) equals: newText size.
	self assert: newText size equals: newText runs size.
	self assert: (newText attributesAt: 6) equals: (text attributesAt: 6).
	self assert: (newText attributesAt: 8) equals: (text attributesAt: 8)! !

!TextLineEndingsTest methodsFor: 'tests' stamp: ''!
testStringConversionJustLF

	| string newString |
	string := 'This is a test', String lf, 'of the conversion'.
	newString := string withInternalLineEndings.
	self assert: string size equals: newString size! !

!TextLineEndingsTest methodsFor: 'tests' stamp: ''!
testDecoratedTextConversionCrLF

	| text newText |
	text := ('123456', String crlf, '901234') asText.
	text addAttribute: TextColor blue from: 4 to: 10.
	text addAttribute: TextColor red from: 6 to: 9.
	text addAttribute: TextEmphasis bold.
	newText := text withInternalLineEndings.
	self assert: (text size - 1) equals: newText size.
	self assert: newText size equals: newText runs size.
	self assert: (newText attributesAt: 6) equals: (text attributesAt: 6).
	self assert: (newText attributesAt: 8) equals: (text attributesAt: 9)! !

!TextLineTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	prototypes
		add: (TextLine
				start: 1
				stop: 50
				internalSpaces: 2
				paddingWidth: 1)! !

!TextLink commentStamp: ''!
A link in text referring to class and methods. !
!TextLink methodsFor: 'comparing' stamp: ''!
= anotherObject

	^self class == anotherObject class and: [ classAndMethod = anotherObject info ]! !

!TextLink methodsFor: 'comparing' stamp: ''!
hash

	^(self class hash + classAndMethod hash) hashMultiply ! !

!TextLink methodsFor: '*Text-Edition' stamp: ''!
mayActOnEvent: anEvent
	^ anEvent isMouseUp and: [ anEvent commandKeyPressed ]! !

!TextLink methodsFor: 'accessing' stamp: ''!
classAndMethod: aString
	classAndMethod := aString! !

!TextLink methodsFor: '*Text-Scanning' stamp: ''!
emphasizeScanner: scanner
	! !

!TextLink methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubMayActOnEvent: anEvent
	^ anEvent isMouseDown and: [ anEvent commandKeyPressed ]! !

!TextLink methodsFor: 'testing' stamp: ''!
analyze: aString

	| list |
	list := super analyze: aString.
	classAndMethod := list at: 1.
	^ list at: 2! !

!TextLink methodsFor: 'testing' stamp: ''!
mayHaveExternalReferences
	"Text links can keep references to external objects like AST nodes"
	^ true! !

!TextLink methodsFor: 'testing' stamp: ''!
validate: specString
	"Can this string be decoded to be Class space Method (or Comment, Definition, Hierarchy)? If so, return it in valid format, else nil"

	| list first mid last |
	list := specString findTokens: ' 	.|'.
	list ifEmpty: [ ^ nil ].
	last := list last.
	last first isUppercase
		ifTrue: [ 
			(#('Comment' 'Definition' 'Hierarchy') includes: last)
				ifFalse: [ ^ nil ].	"Check for 'Rectangle Comment Comment' and remove last one"
			(list at: list size - 1 ifAbsent: [ ^ nil ]) = last
				ifTrue: [ list := list allButLast ] ].
	list size > 3
		ifTrue: [ ^ nil ].
	list size < 2
		ifTrue: [ ^ nil ].
	Symbol hasInterned: list first ifTrue: [ :sym | first := sym ].
	first ifNil: [ ^ nil ].
	Smalltalk globals at: first ifAbsent: [ ^ nil ].
	mid := list size = 3
		ifTrue: [ 
			(list at: 2) = 'class'
				ifTrue: [ 'class ' ]
				ifFalse: [ ^ nil ] ]
		ifFalse: [ '' ].	"OK if method name is not interned -- may not be defined yet"
	^ first , ' ' , mid , last! !

!TextLink methodsFor: 'testing' stamp: ''!
analyze: aString with: nonMethod
	"Initalize this attribute holder with a piece text the user typed into a paragraph.  Returns the text to emphesize (may be different from selection)  Does not return self!!.  nonMethod is what to show when clicked, i.e. the last part of specifier (Comment, Definition, or Hierarchy).  May be of the form:
Point
<Point>
Click Here<Point>
<Point>Click Here
"

	"Obtain the showing text and the instructions"

	| b1 b2 trim |
	b1 := aString indexOf: $<.
	b2 := aString indexOf: $>.
	b1 < b2 & (b1 > 0)
		ifFalse: [ "only one part"
			classAndMethod := self validate: aString , ' ' , nonMethod.
			^ classAndMethod ifNotNil: [ aString ] ].
	"Two parts"
	trim := aString trimBoth.
	^ (trim at: 1) == $<
		ifTrue: [ trim last == $>
				ifTrue: [ "only instructions"
					classAndMethod := self validate: (aString copyFrom: b1 + 1 to: b2 - 1) , ' ' , nonMethod.
					classAndMethod ifNotNil: [ classAndMethod ] ]
				ifFalse: [ "at the front"
					classAndMethod := self validate: (aString copyFrom: b1 + 1 to: b2 - 1) , ' ' , nonMethod.
					classAndMethod ifNotNil: [ aString copyFrom: b2 + 1 to: aString size ] ] ]
		ifFalse: [ trim last == $>
				ifTrue: [ "at the end"
					classAndMethod := self validate: (aString copyFrom: b1 + 1 to: b2 - 1) , ' ' , nonMethod.
					classAndMethod ifNotNil: [ aString copyFrom: 1 to: b1 - 1 ] ]
				ifFalse: [ "Illegal -- <> has text on both sides" nil ] ]! !

!TextLink methodsFor: 'accessing' stamp: ''!
info
	^ classAndMethod! !

!TextLink class methodsFor: 'instance creation' stamp: ''!
scanFrom: strm
	"read a link in the funny format used by Text styles on files. LPoint +;LPoint Comment;"

	^ self new classAndMethod: (strm upTo: $;)! !

!TextMessageLink commentStamp: ''!
A link to a hidden mail message.  Clicking on it allows the message to be viewed or saved to disk.!
!TextMessageLink methodsFor: 'appearance' stamp: ''!
emphasizeScanner: scanner
	scanner textColor: Color brown! !

!TextMessageLink methodsFor: 'accessing' stamp: ''!
message
	^message! !

!TextMessageLink methodsFor: 'initialization' stamp: ''!
initialize: message0
	message := message0! !

!TextMessageLink class methodsFor: 'instance creation' stamp: ''!
message: aMessage
	^self new initialize: aMessage! !

!TextMethodLink commentStamp: ''!
An active link in a text linking to a method!
!TextMethodLink methodsFor: 'comparing' stamp: ''!
= anotherObject
	^ super = anotherObject
		and: [ selector = anotherObject selector
				and: [ browseSenders = anotherObject browseSenders
						and: [ self sourceNodeInterval = anotherObject sourceNodeInterval ] ] ]! !

!TextMethodLink methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	browseSenders := false.! !

!TextMethodLink methodsFor: 'comparing' stamp: ''!
hash
	^ (((super hash + selector hash) hashMultiply + browseSenders hash) hashMultiply
		+ self sourceNodeInterval hash) hashMultiply! !

!TextMethodLink methodsFor: 'accessing' stamp: ''!
selector
	^ selector! !

!TextMethodLink methodsFor: '*Text-Edition' stamp: ''!
actOnMove: anEvent for: target in: aParagraph editor: anEditor
	anEvent shiftPressed ifFalse: [ ^ false ].
	anEditor textArea highlightMessageSend ifFalse: [ ^ false ].
	sourceNode ifNil: [ ^ false ].
	anEditor hoverHighlightInterval: self sourceNodeInterval.
	^ true! !

!TextMethodLink methodsFor: 'accessing' stamp: ''!
senders: aBoolean
	browseSenders := aBoolean! !

!TextMethodLink methodsFor: 'private' stamp: ''!
sourceNodeInterval
	sourceNode ifNil: [ ^ 1 to: 0 ].
	^ sourceNode keywordsPositions first to: sourceNode stop! !

!TextMethodLink methodsFor: 'accessing' stamp: ''!
sourceNode
	^ sourceNode! !

!TextMethodLink methodsFor: 'accessing' stamp: ''!
selector: aStringOrSymbol
	selector := aStringOrSymbol asSymbol.! !

!TextMethodLink methodsFor: 'accessing' stamp: ''!
browseSenders

	^browseSenders ! !

!TextMethodLink methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubActOnClick: anEvent for: target in: aParagraph editor: anEditor
	self flag: #pharoTodo. "Complete implementation with class".
	
	browseSenders == anEvent shiftPressed
		ifTrue: [ anEditor editor implementorsOf: self selector ]
		ifFalse: [ anEditor editor sendersOf: self selector ].
		
	^ true! !

!TextMethodLink methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubMayActOnEvent: anEvent
	^ anEvent isMouseMove or: [ super rubMayActOnEvent: anEvent ]! !

!TextMethodLink methodsFor: '*Text-Edition' stamp: ''!
actOnClick: anEvent for: target in: aParagraph editor: anEditor
	self flag: #pharoTodo. "Complete implementation with class".
	
	browseSenders == anEvent shiftPressed
		ifTrue: [ anEditor implementorsOf: self selector ]
		ifFalse: [ anEditor sendersOf: self selector ].
		
	^ true! !

!TextMethodLink methodsFor: 'accessing' stamp: ''!
sourceNode: anObject
	sourceNode := anObject! !

!TextMethodLink class methodsFor: 'instance creation' stamp: ''!
selector: aString senders: browseSenders
	^ (self selector: aString)
		senders: browseSenders;
		yourself! !

!TextMethodLink class methodsFor: 'instance creation' stamp: ''!
selector: aStringOrSymbol
	^ self new
		selector: aStringOrSymbol;
		yourself! !

!TextMethodLink class methodsFor: 'instance creation' stamp: ''!
sourceNode: aMessageNode
	^ self new
		selector: aMessageNode selector;
		sourceNode: aMessageNode 
		yourself! !

!TextMorph commentStamp: ''!
TextMorphs support display of text with emphasis.  They also support reasonable text-editing capabilities, as well as embedded hot links, and the ability to embed submorphs in the text.

Late in life, TextMorph was made a subclass of BorderedMorph to provide border and background color if desired.  In order to keep things compatible, protocols have been redirected so that color (preferably textColor) relates to the text, and backgroundColor relates to the inner fill color.

Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter.

If text has been embedded in another object, one can elect to fill the owner's shape, in which case the text will be laid out in the shape of the owner's shadow image (including any submorphs other than the text).  One can also elect to have the text avoid occlusions, in which case it will avoid the bounds of any sibling morphs that appear in front of it.  It may be necessary to update bounds in order for the text runaround to notice the presence of a new occluding shape.

The optional autoFitContents property enables the following feature:  if the text contents changes, then the bounds of the morph will be adjusted to fit the minimum rectangle that encloses the text (plus any margins specified).  Similarly, any attempt to change the size of the morph will be resisted if this parameter is set.  Except...

If the wrapFlag parameter is true, then text will be wrapped at word boundaries based on the composition width (innerBounds insetBy: margins) width.  Thus an attempt to resize the morph in autofit mode, if it changes the width, will cause the text to be recomposed with the new width, and then the bounds will be reset to the minimum enclosing rectangle.  Similarly, if the text contents are changed with the wrapFlag set to true, word wrap will be performed based on the current compostion width, after which the bounds will be set (or not), based on the autoFitcontents property.

Note that fonts can only be applied to the TextMorph as a whole.  While you can change the size, color, and emphasis of a subsection of the text and have it apply to only that subsection, changing the font changes the font for the entire contents of the TextMorph. 

Still a TextMorph can be composed of several texts of different fonts

```
| font1 font2 t1 t2 tMorph|
tMorph := TextMorph new.
font1 := (TextFontReference toFont: (StrikeFont familyName: 'Atlanta' size: 22)).
font2 := (TextFontReference toFont: (StrikeFont familyName: 'Atlanta' size: 11)).
t1 := 'this is font1' asText addAttribute: font1.
t2 := ' and this is font2' asText addAttribute: font2.
tMorph contents: (t1,t2).
tMorph openInHand.
```

Yet to do:
Make a comprehensive control for the eyedropper, with border width and color, inner color and text color, and margin widths.!
!TextMorph methodsFor: 'accessing' stamp: ''!
margins: newMargins
	"newMargins can be a number, point , as allowed by, eg, insetBy:."

	margins := newMargins asMargin.
	self composeToBounds! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
addSuccessor: evt
	| newMorph |
	newMorph := self copy predecessor: self successor: successor.
	newMorph extent: self width @ 100.
	successor ifNotNil: [successor setPredecessor: newMorph].
	self setSuccessor: newMorph.
	successor recomposeChain.
	evt hand attachMorph: newMorph! !

!TextMorph methodsFor: 'scripting access' stamp: ''!
insertCharacters: aSource
	"Insert the characters from the given source at my current cursor position"

	| aLoc |
	aLoc := self cursor max: 1.
	paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
	self updateFromParagraph! !

!TextMorph methodsFor: 'private' stamp: ''!
paragraph
	"Paragraph instantiation is lazy -- create it only when needed"
	|newParagraph|
	paragraph ifNotNil: [^ paragraph].

	self setProperty: #CreatingParagraph toValue: true.
	self setDefaultContentsIfNil.

	"...Code here to recreate the paragraph..."
	newParagraph  := (Paragraph new textOwner: self owner).
	
	newParagraph wantsColumnBreaks: successor notNil.
	newParagraph
		compose: text
		style: textStyle copy
		from: self startingIndex
		in: self container.
	wrapFlag ifFalse:
		["Was given huge container at first... now adjust"
		newParagraph adjustRightX].
	newParagraph focused: self hasFocus.
	paragraph := newParagraph.
	self fit.
	self removeProperty: #CreatingParagraph.


	^ paragraph! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
addPredecessor: evt
	| newMorph |
	newMorph := self copy predecessor: predecessor successor: self.
	newMorph extent: self width @ 100.
	predecessor ifNotNil: [predecessor setSuccessor: newMorph].
	self setPredecessor: newMorph.
	predecessor recomposeChain.
	evt hand attachMorph: newMorph! !

!TextMorph methodsFor: 'event handling' stamp: ''!
wouldAcceptKeyboardFocusUponTab
	"Answer whether the receiver might accept keyboard focus if 
	tab were hit in some container playfield"
	^ true! !

!TextMorph methodsFor: 'accessing' stamp: ''!
wrapFlag: aBoolean
	"Should contained text stay wrapped at my width?"

	aBoolean == wrapFlag ifTrue: [^ self].
	wrapFlag := aBoolean.
	self composeToBounds! !

!TextMorph methodsFor: 'private' stamp: ''!
privateOwner: newOwner
	"Nil the container when text gets extracted"
	super privateOwner: newOwner.
	container ifNotNil: [
		newOwner ifNotNil: [
			newOwner isWorldOrHandMorph ifTrue: [self setContainer: nil]]]! !

!TextMorph methodsFor: 'containment' stamp: ''!
fillsOwner
	"Answer true if I fill my owner's shape."
	^container notNil and: [container fillsOwner]! !

!TextMorph methodsFor: 'visual properties' stamp: ''!
fillStyle: aFillStyle
	"Set the current fillStyle of the receiver."
	
	backgroundColor := aFillStyle asColor.
	super fillStyle: aFillStyle! !

!TextMorph methodsFor: 'accessing' stamp: ''!
contents: stringOrText wrappedTo: width
	"Accept new text contents.  Lay it out, wrapping to width.
	Then fit my height to the result."
	self newContents: ''.
	wrapFlag := true.
	super extent: width truncated@self height.
	self newContents: stringOrText! !

!TextMorph methodsFor: 'submorphs - add/remove' stamp: ''!
delete
	predecessor ifNotNil: [predecessor setSuccessor: successor].
	successor ifNotNil: [successor setPredecessor: predecessor.
						successor recomposeChain].
	super delete! !

!TextMorph methodsFor: 'editing helpers' stamp: ''!
italic
	
	self changeEmphasis: #italic! !

!TextMorph methodsFor: 'accessing' stamp: ''!
fontName: fontName pointSize: fontSize
	| newTextStyle |
	newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy.
	newTextStyle ifNil: [self error: 'font ', fontName, ' not found.'].

	textStyle := newTextStyle.
	text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfPointSize: fontSize)).
	paragraph ifNotNil: [paragraph textStyle: newTextStyle]! !

!TextMorph methodsFor: 'containment' stamp: ''!
setContainer: newContainer
	"Adopt (or abandon) container shape"
	self changed.
	container := newContainer.
	self releaseParagraph! !

!TextMorph methodsFor: 'accessing' stamp: ''!
isWrapped
	
	^wrapFlag! !

!TextMorph methodsFor: 'editing' stamp: ''!
chooseAlignment
	"Interactively change alignment."
	
	self editor changeAlignment.
	self updateFromParagraph! !

!TextMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt
	^ self innerBounds containsPoint: evt cursorPoint! !

!TextMorph methodsFor: 'event handling' stamp: ''!
hasFocus
	^editor notNil! !

!TextMorph methodsFor: 'accessing' stamp: ''!
setCharacters: chars
	"obtain a string value from the receiver"

	(self getCharacters = chars) ifFalse:
		[self newContents: chars]! !

!TextMorph methodsFor: 'containment' stamp: ''!
avoidsOcclusions
	^container notNil and: [ container avoidsOcclusions ]! !

!TextMorph methodsFor: 'geometry' stamp: ''!
textBounds
	^ bounds! !

!TextMorph methodsFor: 'drawing' stamp: ''!
drawNullTextOn: aCanvas
	"Make null text frame visible.
	Nicer if not shaded!!"

	aCanvas fillRectangle: bounds color: (self backgroundColor ifNil: [Color transparent])! !

!TextMorph methodsFor: 'editing helpers' stamp: ''!
struckOut
	
	self changeEmphasis: #struckOut! !

!TextMorph methodsFor: 'geometry' stamp: ''!
privateMoveBy: delta 
	super privateMoveBy: delta.
	editor ifNil: [paragraph ifNotNil: [paragraph moveBy: delta]]
		ifNotNil: 
			["When moving text with an active editor, save and restore all state."

			paragraph moveBy: delta.
			self installEditorToReplace: editor]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
contentsAsIs: stringOrText
	"Accept new text contents with line breaks only as in the text.
	Fit my width and height to the result."
	wrapFlag := false.
	container ifNotNil: [container fillsOwner ifTrue: [wrapFlag := true]].
	self newContents: stringOrText! !

!TextMorph methodsFor: 'submorphs - add/remove' stamp: ''!
goBehind
	"We need to save the container, as it knows about fill and run-around"
	| cont |
	container ifNil: [^ super goBehind].
	self releaseParagraph.  "Cause recomposition"
	cont := container.  "Save the container"
	super goBehind.  "This will change owner, nilling the container"
	container := cont.  "Restore the container"
	self changed! !

!TextMorph methodsFor: 'anchors' stamp: ''!
anchorMorph: aMorph at: aPoint type: anchorType
	| relPt index newText block |
	aMorph owner == self ifTrue:[self removeMorph: aMorph].
	aMorph textAnchorType: nil.
	aMorph relativeTextAnchorPosition: nil.
	self addMorphFront: aMorph.
	aMorph textAnchorType: anchorType.
	aMorph relativeTextAnchorPosition: nil.
	anchorType == #document ifTrue:[^self].
	relPt := self transformFromWorld globalPointToLocal: aPoint.
	index := (self paragraph characterBlockAtPoint: relPt) stringIndex.
	newText := Text string: (String value: 1) attribute: (TextAnchor new anchoredMorph: aMorph).
	anchorType == #inline ifTrue:[
		self paragraph replaceFrom: index to: index-1 with: newText displaying: false.
	] ifFalse:[
		index := index min: paragraph text size.
		index := paragraph text string lastIndexOf: Character cr startingAt: index ifAbsent:[0].
		block := paragraph characterBlockForIndex: index+1.
		aMorph relativeTextAnchorPosition: (relPt x - bounds left) @ (relPt y - block top ).
		self paragraph replaceFrom: index+1 to: index with: newText displaying: false.
	].
	self fit.! !

!TextMorph methodsFor: 'editing' stamp: ''!
preferredKeyboardPosition

	| default rects |
	default  := super preferredKeyboardPosition.
	paragraph ifNil: [^ default].
	rects := paragraph selectionRects.
	rects size = 0 ifTrue: [^ default].
	^ rects first topLeft.! !

!TextMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!TextMorph methodsFor: 'event handling' stamp: ''!
mouseLeave: evt
	"Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed."
	super mouseLeave: evt.
	self hideOverEditableTextCursor! !

!TextMorph methodsFor: 'accessing' stamp: ''!
selectAll
	self editor selectFrom: 1 to: text size! !

!TextMorph methodsFor: 'event handling' stamp: ''!
keyDown: evt

	evt keyValue = 13
		ifTrue: [ | action |
			action := self crAction.
			action ifNotNil: [
				"Note: Code below assumes that this was some 
				input field reacting on CR. Break the keyboard 
				focus so that the receiver can be safely deleted."
				evt hand newKeyboardFocus: nil.
				^ action value]].
	^ super keyDown: evt! !

!TextMorph methodsFor: 'private' stamp: ''!
setDefaultContentsIfNil
	"Set the default contents"

	| toUse |
	text ifNil:
		[toUse := self valueOfProperty: #defaultContents.
		toUse ifNil: [toUse :='' asText "allBold"].	"try it plain for a while"
		text := toUse]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
newContents: stringOrText 
	"Accept new text contents."
	| newText embeddedMorphs |
	"If my text is all the same font, use the font for my new contents"
	newText := stringOrText isString ifTrue: [ | textSize |
		(text notNil
		  and: [ (textSize := text size) > 0
		    and: [ (text runLengthFor: 1) = textSize ]]) ifTrue: [ | attribs |
			attribs := text attributesAt: 1 forStyle: textStyle.
			Text string: stringOrText copy attributes: attribs.
		]
		ifFalse: [ Text fromString: stringOrText copy ]
	]
	ifFalse: [ stringOrText copy asText.	"should be veryDeepCopy?" ].

	(text = newText and: [text runs = newText runs]) ifTrue: [^ self].	"No substantive change"
	text ifNotNil: [(embeddedMorphs := text embeddedMorphs)
			ifNotNil: 
				[self removeAllMorphsIn: embeddedMorphs.
				embeddedMorphs do: [:m | m delete]]].

	text := newText.

	"add all morphs off the visible region; they'll be moved into the right 
	place when they become visible. (this can make the scrollable area too 
	large, though)"
	newText embeddedMorphs do: 
		[:m | 
		self addMorph: m.
		m position: -1000 @ 0].
	self releaseParagraph.
	"update the paragraph cache"
	self paragraph.
	"re-instantiate to set bounds"
	self world ifNotNil: [self world startSteppingSubmorphsOf: self]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
textAlignment
	"Answer 1..4, representing #leftFlush, #rightFlush, #centered, or #justified"
	^self editor textAlignment! !

!TextMorph methodsFor: 'menu' stamp: ''!
shiftedYellowButtonActivity
	"Supply the normal 'code pane' menu to use its text editing commands from a menu."

	self editor pluggableYellowButtonActivity: true.
	self changed.! !

!TextMorph methodsFor: 'event handling' stamp: ''!
getMenu: shiftKeyState 
	^ shiftKeyState not
		ifTrue: [editor yellowButtonMenu]
		ifFalse: [editor shiftedYellowButtonMenu]! !

!TextMorph methodsFor: 'private' stamp: ''!
text: t textStyle: s wrap: wrap color: c
	predecessor: pred successor: succ
	"Private -- for use only in morphic duplication"
	text := t.
	defaultColor := (t attributesAt: 1) detect: [ :e | e isKindOf: TextColor ].
	textStyle := s.
	wrapFlag := wrap.
	color := c.
	paragraph := editor := container := nil.
	self predecessor: pred successor: succ! !

!TextMorph methodsFor: 'event handling' stamp: ''!
mouseMove: event

	event redButtonPressed ifFalse: [ ^ self ].
	self handleInteraction: [ editor mouseMove: event ]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
textColor: aColor

	color = aColor ifTrue: [^ self].
	color := aColor.
	text addAttribute: (TextColor color: aColor).
	self changed.! !

!TextMorph methodsFor: 'blinking' stamp: ''!
startBlinking
	self startStepping: #onBlinkCursor 
		at: Time millisecondClockValue 
		arguments: nil stepTime: 500.
	self resetBlinkCursor.! !

!TextMorph methodsFor: 'accessing' stamp: ''!
editor
	"Return my current editor, or install a new one."
	editor ifNotNil: [^ editor].
	^ self installEditorToReplace: nil! !

!TextMorph methodsFor: 'scripting access' stamp: ''!
getAllButFirstCharacter
	"Obtain all but the first character from the receiver; if that would be empty, return a black dot"

	| aString |
	^ (aString := text string) size > 1 ifTrue: [aString copyFrom: 2 to: aString size] ifFalse: ['·']! !

!TextMorph methodsFor: 'accessing' stamp: ''!
isTranslucentButNotTransparent
	"Overridden from BorderedMorph to test backgroundColor instead of (text) color."

	backgroundColor ifNil: [ ^ true ].
	(backgroundColor isColor and: [ backgroundColor isTranslucentButNotTransparent ])
		ifTrue: [ ^ true ].
	(borderColor isColor and: [ borderColor isTranslucentButNotTransparent ])
		ifTrue: [ ^ true ].
	^ false! !

!TextMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt 
	"Make this TextMorph be the keyboard input focus, if it isn't  
	already, and repond to the text selection gesture"
	
	evt yellowButtonPressed
		ifTrue: ["First check for option (menu) click"
			(self yellowButtonActivity: evt shiftPressed) 
				ifTrue: [ ^ self ]].
	self handleInteraction: [editor mouseDown: evt].
	self hasKeyboardFocus
		ifFalse: [self takeKeyboardFocus].
	super mouseDown: evt! !

!TextMorph methodsFor: 'event handling' stamp: ''!
handlesKeyboard: evt
	^true! !

!TextMorph methodsFor: 'alignment' stamp: ''!
leftFlush 

	self changeAlignment: #leftFlush! !

!TextMorph methodsFor: 'testing' stamp: ''!
canChangeText
	^ self enabled! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
isLinkedTo: aMorph
	self firstInChain withSuccessorsDo:
		[:m | m == aMorph ifTrue: [^ true]].
	^ false! !

!TextMorph methodsFor: 'private' stamp: ''!
clippingRectangle
	^ self innerBounds! !

!TextMorph methodsFor: 'event handling' stamp: ''!
keyboardFocusChange: aBoolean

	super keyboardFocusChange: aBoolean.
	paragraph ifNotNil: [ paragraph focused: aBoolean ].
	aBoolean
		ifTrue: [ "A hand is wanting to send us characters..."
			self hasFocus
				ifFalse: [ self editor	"Forces install" ].
			self showOverEditableTextCursor
			]
		ifFalse: [ "A hand has clicked elsewhere..."
			self world
				ifNotNil: [ :w | 
					w
						handsDo: [ :h | 
							h keyboardFocus == self
								ifTrue: [ ^ self ]
							].	"Release control unless some hand is still holding on"
					self releaseEditor
					].
			self hideOverEditableTextCursor
			].
	self manageCursor.
	self focusChanged! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
startingIndex

	predecessor ifNil: [ ^ 1 ].
	^ predecessor lastCharacterIndex + 1! !

!TextMorph methodsFor: 'event handling' stamp: ''!
basicKeyStroke: evt 
	"Handle a keystroke event."
	| action |

	evt keyValue = 13
		ifTrue: [
			action := self crAction.
			action
				ifNotNil: ["Note: Code below assumes that this was some 
					input field reacting on CR. Break the keyboard 
					focus so that the receiver can be safely deleted."
					evt hand newKeyboardFocus: nil.
					^ action value]].
	self handleInteraction: [ editor keystroke: evt ].
	self updateFromParagraph.
	super keyStroke: evt.! !

!TextMorph methodsFor: 'editing' stamp: ''!
handleEdit: editBlock
	"Ensure that changed areas get suitably redrawn"
	self selectionChanged.  "Note old selection"
		editBlock value.
	self selectionChanged.  "Note new selection"
	self updateFromParagraph  "Propagate changes as necessary"! !

!TextMorph methodsFor: 'accessing' stamp: ''!
crAction
	"Return the action to perform when encountering a CR in the input"
	^self valueOfProperty: #crAction! !

!TextMorph methodsFor: 'accessing' stamp: ''!
elementCount
	"Answer how many sub-objects are within me"

	^ self text string size! !

!TextMorph methodsFor: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!TextMorph methodsFor: 'editing' stamp: ''!
acceptContents
	"The message is sent when the user hits enter or Cmd-S.
	Accept the current contents and end editing.
	This default implementation does nothing."
	self updateFromParagraph! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
predecessor
	^ predecessor! !

!TextMorph methodsFor: 'accessing' stamp: ''!
backgroundColor: newColor
	backgroundColor := newColor.
	self changed! !

!TextMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
optimalExtent
	"Create a new paragraph and answer its extent."
	
	^(Paragraph new
		compose: text
		style: textStyle copy
		from: 1
		in: (0@0 extent: 9999999@9999999);
		adjustRightX;
		extent) + (self borderWidth * 2) + (2@0) "FreeType kerning allowance"! !

!TextMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!TextMorph methodsFor: 'layout' stamp: ''!
acceptDroppingMorph: aMorph event: evt
	"This message is sent when a morph is dropped onto me."

	self addMorphFront: aMorph fromWorldPosition: aMorph position.
		"Make a TextAnchor and install it in a run."! !

!TextMorph methodsFor: 'event handling' stamp: ''!
mouseEnter: evt
	"Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed."
	super mouseEnter: evt.
	self showOverEditableTextCursor! !

!TextMorph methodsFor: 'private' stamp: ''!
selectionChanged
	"Invalidate all the selection rectangles. 
	Make sure that any drop shadow is accounted for too."
	self paragraph selectionRects
		do: [:r | | intr |
			intr := r intersect: self fullBounds ifNone: [ nil ].
			intr ifNotNil: [ self invalidRect: (self expandFullBoundsForDropShadow: intr)] ]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
selection
	^editor ifNotNil: [ editor selection ]! !

!TextMorph methodsFor: 'editing' stamp: ''!
chooseEmphasisOrAlignment
	self editor changeEmphasisOrAlignment.
	self updateFromParagraph! !

!TextMorph methodsFor: 'event handling' stamp: ''!
keyStroke: evt
	"Handle a keystroke event."

	self basicKeyStroke: evt! !

!TextMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!TextMorph methodsFor: 'drawing' stamp: ''!
areasRemainingToFill: aRectangle
	"Overridden from BorderedMorph to test backgroundColor instead of (text) color."

	(backgroundColor isNil or: [ backgroundColor isTranslucent ]) ifTrue: [ ^ Array with: aRectangle ].
	^ self wantsRoundedCorners
		ifTrue: [ (borderWidth > 0 and: [ borderColor isColor and: [ borderColor isTranslucent ] ])
				ifTrue: [ aRectangle areasOutside: (self innerBounds intersect: self boundsWithinCorners ifNone: [ self error: 'cannot happen' ]) ]
				ifFalse: [ aRectangle areasOutside: self boundsWithinCorners ] ]
		ifFalse: [ (borderWidth > 0 and: [ borderColor isColor and: [ borderColor isTranslucent ] ])
				ifTrue: [ aRectangle areasOutside: self innerBounds ]
				ifFalse: [ aRectangle areasOutside: self bounds ] ]! !

!TextMorph methodsFor: 'menu' stamp: ''!
autoFitString
	"Answer the string to put in a menu that will invite the user to 
	switch autoFit mode"
	^ (self isAutoFit
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'text auto fit' translated! !

!TextMorph methodsFor: 'initialization' stamp: ''!
defaultColor

	^ defaultColor ifNil: [ self theme textColor ]! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
lastCharacterIndex
	^ self paragraph lastCharacterIndex! !

!TextMorph methodsFor: 'accessing' stamp: ''!
mouseUp: evt
	self handleInteraction: [editor mouseUp: evt].
	(self boundsInWorld containsPoint: self currentHand position)
		ifFalse: [self hideOverEditableTextCursor]! !

!TextMorph methodsFor: 'private' stamp: ''!
releaseEditor 
	"Release the editor for my paragraph.  This morph no longer 'hasFocus'."
	editor ifNotNil:
		[self selectionChanged.
		self paragraph selectionStart: nil selectionStop: nil.
		editor := nil].! !

!TextMorph methodsFor: 'event handling' stamp: ''!
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].
	self keyStroke: anEvent.
	anEvent wasHandled: true.! !

!TextMorph methodsFor: 'accessing' stamp: ''!
backgroundColor
	^ backgroundColor! !

!TextMorph methodsFor: 'geometry' stamp: ''!
bounds
	container ifNil: [^ bounds].
	^ container bounds ifNil: [bounds]! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
firstCharacterIndex
	^ self paragraph firstCharacterIndex! !

!TextMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!TextMorph methodsFor: 'menu' stamp: ''!
changeMargins: evt
	| handle origin aHand newMargin |
	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).
			newMargin := (newPoint - origin max: 0@0) // 5.
			self margins: newMargin asMargin]
		lastPointDo:
			[:newPoint | handle deleteBalloon.
			self halo ifNotNil: [:halo | halo addHandles]].
	aHand attachMorph: handle.
	handle showBalloon:
'Move cursor down and to the right
to increase margin inset.
Click when done.' hand: evt hand.
	handle startStepping! !

!TextMorph methodsFor: 'change reporting' stamp: ''!
ownerChanged

	| priorEditor |

	super ownerChanged.
	container
		ifNotNil: [ editor
				ifNil: [ self releaseParagraph.
					( container isKindOf: TextContainer )
						ifTrue: [ "May need to recompose due to changes in owner"
							self installEditorToReplace: nil.
							self releaseParagraph
							]
					]
				ifNotNil: [ priorEditor := editor.
					self releaseParagraph.
					self installEditorToReplace: priorEditor
					]
			]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
select
	editor ifNotNil: [ editor select ]! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
withSuccessorsDo: aBlock 
	"Evaluate aBlock for each morph in my successor chain"

	| each |
	each := self.
	[each isNil] whileFalse: 
			[aBlock value: each.
			each := each successor]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
selectInvisiblyFrom: start to: stop
	editor ifNotNil: [ editor selectInvisiblyFrom: start to: stop ]! !

!TextMorph methodsFor: 'caching' stamp: ''!
releaseCachedState
 
	super releaseCachedState.
	self releaseParagraph! !

!TextMorph methodsFor: 'accessing' stamp: ''!
textAlignmentSymbol
	"Answer one of #leftFlush, #rightFlush, #centered, or #justified"
	^self editor textAlignmentSymbol! !

!TextMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	"Draw the receiver on a canvas.
	Draw keyboard focus if appropriate."

	| fauxBounds  |
	self setDefaultContentsIfNil.
	super drawOnAthensCanvas: anAthensCanvas.	"Border and background if any"	"nothing to draw?"
	self startingIndex > text size
		ifTrue: [ ^ self ].	"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.	"self paragraph drawOnAthensCanvas: aCanvas bounds: fauxBounds."
	self paragraph drawOnAthensCanvas: anAthensCanvas bounds: fauxBounds color: color! !

!TextMorph methodsFor: 'blinking' stamp: ''!
manageCursor
	(paragraph isNil or: [paragraph focused not])
		ifTrue: [^ self
				resetBlinkCursor;
				stopBlinking].
	TextEditor blinkingCursor 
		ifTrue: [self startBlinking]
		ifFalse: [self ensureCursor]! !

!TextMorph methodsFor: 'private' stamp: ''!
compositionRectangle
	| compRect |
	compRect := self innerBounds.
	compRect := compRect insetBy: margins.
	compRect width < 9 ifTrue: [compRect := compRect withWidth: 9].
	compRect height < 16 ifTrue: [compRect := compRect withHeight: 16].
	^ compRect! !

!TextMorph methodsFor: 'blinking' stamp: ''!
ensureCursor
	paragraph ifNotNil: [ :p | p showCaret: true ]! !

!TextMorph methodsFor: 'menu' stamp: ''!
autoFitOnOff
	self setProperty: #autoFitContents toValue: self isAutoFit not.
	self isAutoFit ifTrue: [self fit]! !

!TextMorph methodsFor: 'editing' stamp: ''!
enterClickableRegion: evt
	| |
	
	evt hand hasSubmorphs ifTrue:[^self].
	evt hand temporaryCursor ifNotNil:[^self].
	"paragraph ifNotNil:[
		(paragraph characterBlockAtPoint: evt position) stringIndex ].
"! !

!TextMorph methodsFor: 'alignment' stamp: ''!
centered 
	self changeAlignment: #centered! !

!TextMorph methodsFor: 'editing' stamp: ''!
handleInteraction: interactionBlock
	"Perform the changes in interactionBlock, noting any change in selection
	and possibly a change in the size of the paragraph.
	Couple ParagraphEditor to Morphic keyboard events"
	| oldEditor oldParagraph oldText |
	oldEditor := self editor.
	oldParagraph := paragraph.
	oldText := oldParagraph text copy.

	self selectionChanged.  "Note old selection"

	interactionBlock value.

	(oldParagraph == paragraph) ifTrue:[
		"this will not work if the paragraph changed"
		editor := oldEditor.     "since it may have been changed while in block"
	].
	self selectionChanged.  "Note new selection"
	(oldText = paragraph text and: [ oldText runs = paragraph text runs ])
		ifFalse:[ self updateFromParagraph ].! !

!TextMorph methodsFor: 'private' stamp: ''!
composeToBounds
	"Compose my text to fit my bounds.
	If any text lies outside my bounds, it will be clipped, or
	if I have successors, it will be shown in the successors."
	| |
	self releaseParagraph; paragraph.
	container ifNotNil:
		[self privateBounds: container bounds truncated].
	self paragraph positionWhenComposed: self position.
	successor ifNotNil:
		[successor predecessorChanged].! !

!TextMorph methodsFor: 'private' stamp: ''!
releaseParagraphReally

	"a slight kludge so subclasses can have a bit more control over whether the paragraph really 
	gets released. important for GeeMail since the selection needs to be accessible even if the 
	hand is outside me"

	"Paragraph instantiation is lazy -- it will be created only when needed"
	self releaseEditor.
	paragraph ifNotNil:
		[paragraph := nil].
	container ifNotNil:
		[container releaseCachedState]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
contentsWrapped: stringOrText
	"Accept new text contents.  Lay it out, wrapping within my current width.
	Then fit my height to the result."
	wrapFlag := true.
	self newContents: stringOrText! !

!TextMorph methodsFor: 'editing helpers' stamp: ''!
underlined
	
	self changeEmphasis: #underlined! !

!TextMorph methodsFor: 'find-replace' stamp: ''!
openFindDialog
	self flash! !

!TextMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
takesKeyboardFocus
	"Answer whether the receiver can normally take keyboard focus."

	^true! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
firstInChain
	"Return the first morph in a chain of textMorphs"

	| first |
	first := self.
	[first predecessor isNil] whileFalse: [first := first predecessor].
	^first! !

!TextMorph methodsFor: 'initialization' stamp: ''!
beAllFont: aFont

	textStyle := TextStyle fontArray: (Array with: aFont).
	self releaseCachedState; changed! !

!TextMorph methodsFor: 'editing helpers' stamp: ''!
bold
	
	self changeEmphasis: #bold! !

!TextMorph methodsFor: 'initialization' stamp: ''!
string: aString fontName: aName size: aSize wrap: shouldWrap

	shouldWrap
		ifTrue: [self contentsWrapped: aString]
		ifFalse: [self contents: aString].
	self fontName: aName size: aSize! !

!TextMorph methodsFor: 'editing' stamp: ''!
hasUnacceptedEdits: aBoolean
	"Ignored here, but noted in TextMorphForEditView"! !

!TextMorph methodsFor: 'interactive error protocol' stamp: ''!
deselect
	editor ifNotNil: [ editor deselect ]! !

!TextMorph methodsFor: 'event handling' stamp: ''!
escapePressed! !

!TextMorph methodsFor: 'alignment' stamp: ''!
rightFlush 
	
	self changeAlignment: #rightFlush! !

!TextMorph methodsFor: 'initialization' stamp: ''!
setTextStyle: aTextStyle

	textStyle := aTextStyle.
	self releaseCachedState; changed! !

!TextMorph methodsFor: 'copying' stamp: ''!
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.
	"It makes no sense to share pointers to an existing predecessor and successor"
	predecessor := deepCopier references at: predecessor ifAbsent: [nil].
	successor := deepCopier references at: successor ifAbsent: [nil]! !

!TextMorph methodsFor: 'initialization' stamp: ''!
string: aString fontName: aName size: aSize

	self string: aString fontName: aName size: aSize wrap: true! !

!TextMorph methodsFor: 'submorphs - add/remove' stamp: ''!
addMorphFront: aMorph fromWorldPosition: wp 
	"Overridden for more specific re-layout and positioning"
	aMorph textAnchorType == #document 
		ifFalse:[^self anchorMorph: aMorph at: wp type: aMorph textAnchorType].
	self addMorphFront: aMorph.! !

!TextMorph methodsFor: 'accessing' stamp: ''!
contents

	^ text! !

!TextMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
wantsKeyboardFocusNavigation
	"Answer whether the receiver wants to be navigated to.
	Answer false here (use PluggableTextMorph instead)."

	^false! !

!TextMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!TextMorph methodsFor: 'editing helpers' stamp: ''!
changeAlignment: aSymbol
	"Change the alignment of the receiver. Alignment can be #leftFlush #centered #rightFlush #justified "
	
	"| t |
t := 'khkjhjkhjkhjkh
kjhj
kjhkjhkjh
kjh
kjhkjh kjh jh jh jh jh kjh kjh ' asTextMorph.
t openInWorld.
t selectAll; changeFormatting: #rightFlush.
t inspect"
	
	self editor applyAttribute: (TextAlignment perform: aSymbol).
	self updateFromParagraph! !

!TextMorph methodsFor: 'accessing' stamp: ''!
getCharacters
	"obtain a string value from the receiver"

	^ self text string copy! !

!TextMorph methodsFor: 'accessing' stamp: ''!
asText
	^ text! !

!TextMorph methodsFor: 'accessing' stamp: ''!
font: aFont
	| newTextStyle |
	newTextStyle := aFont textStyle copy ifNil: [ TextStyle fontArray: { aFont } ].
	textStyle := newTextStyle.
	text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOf: aFont)).
	paragraph ifNotNil: [paragraph textStyle: newTextStyle]! !

!TextMorph methodsFor: 'menu' stamp: ''!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	| outer |

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addUpdating: #autoFitString target: self selector: #autoFitOnOff.
	aCustomMenu addUpdating: #wrapString target: self selector: #wrapOnOff.
	aCustomMenu add: 'text margins...' selector: #changeMargins:.
	aCustomMenu add: 'add predecessor' selector: #addPredecessor:.
	aCustomMenu add: 'add successor' selector: #addSuccessor:.
	aCustomMenu add: 'code pane menu...' selector: #yellowButtonActivity.
	aCustomMenu add: 'code pane shift menu...' selector: #shiftedYellowButtonActivity.

	outer := self owner.
	outer
		ifNotNil: [ outer isLineMorph
				ifTrue: [ container ifNotNil: [ aCustomMenu add: 'set baseline' selector: #setCurveBaseline: ] ]
				ifFalse: [ self fillsOwner
						ifFalse: [ aCustomMenu add: 'fill owner''s shape' selector: #fillingOnOff ]
						ifTrue: [ aCustomMenu add: 'rectangular bounds' selector: #fillingOnOff ].
					self avoidsOcclusions
						ifFalse: [ aCustomMenu add: 'avoid occlusions' selector: #occlusionsOnOff ]
						ifTrue: [ aCustomMenu add: 'ignore occlusions' selector: #occlusionsOnOff ]
					]
			]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
fontName: fontName size: fontSize
	| newTextStyle |
	newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy.
	textStyle := newTextStyle.
	text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfSize: fontSize)).
	paragraph ifNotNil: [paragraph textStyle: newTextStyle]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
autoFit: trueOrFalse
	"Should I automatically adjust my size to fit text as it changes?"

	self isAutoFit = trueOrFalse ifTrue: [^ self].
	self autoFitOnOff! !

!TextMorph methodsFor: 'private' stamp: ''!
editorClass
	"Answer the class used to create the receiver's editor"
	
	^TextEditor! !

!TextMorph methodsFor: 'testing' stamp: ''!
enabled

	^super enabled and: [ self isLocked not ]! !

!TextMorph methodsFor: 'editing' stamp: ''!
chooseFont
	self editor changeTextFont.
	self updateFromParagraph.! !

!TextMorph methodsFor: 'accessing' stamp: ''!
getLastCharacter
	"obtain the last character from the receiver if it is empty, return a black dot"

	| aString |
	^ (aString := text string) size > 0 ifTrue: [aString last asString] ifFalse: ['·']! !

!TextMorph methodsFor: 'blinking' stamp: ''!
onBlinkCursor
	"Blink the cursor"
	| para |
	para := self paragraph ifNil:[^nil].
	Time millisecondClockValue < self blinkStart ifTrue:[
		"don't blink yet"
		^para showCaret: para focused.
	].
	para showCaret: para showCaret not.
	para caretRect ifNotNil:[:r| self invalidRect: r].! !

!TextMorph methodsFor: 'editing helpers' stamp: ''!
narrow
	
	self changeEmphasis: #narrow! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
recomposeChain
	"Recompose this textMorph and all that follow it."
	self withSuccessorsDo:
		[:m |  m text: text textStyle: textStyle;  "Propagate new style if any"
				releaseParagraph;  "Force recomposition"
				fit  "and propagate the change"]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
userString
	"Do I have a text string to be searched on?"

	^ text string! !

!TextMorph methodsFor: 'accessing' stamp: ''!
textStyle
	^textStyle! !

!TextMorph methodsFor: 'accessing' stamp: ''!
font
	"Answer the probable font"

	self textStyle fonts ifEmpty: [^TextStyle defaultFont].
	^self textStyle defaultFont.! !

!TextMorph methodsFor: 'blinking' stamp: ''!
blinkStart: msecs
	"Reset time for blink cursor after which blinking should actually start"
	^self setProperty: #blinkStart toValue: msecs! !

!TextMorph methodsFor: 'editing helpers' stamp: ''!
normal
	
	self changeEmphasis: #normal! !

!TextMorph methodsFor: 'private' stamp: ''!
updateFromParagraph
	"A change has taken place in my paragraph, as a result of editing and I must be updated.  If a line break causes recomposition of the current paragraph, or it the selection has entered a different paragraph, then the current editor will be released, and must be reinstalled with the resulting new paragraph, while retaining any editor state, such as selection, undo state, and current typing emphasis."

	| newStyle sel oldLast oldEditor back |
	paragraph ifNil: [^self].
	wrapFlag ifNil: [wrapFlag := true].
	editor ifNotNil: 
			[oldEditor := editor.
			sel := editor selectionInterval.
			editor storeSelectionInParagraph].
	text := paragraph text.
	paragraph textStyle = textStyle 
		ifTrue: [self fit]
		ifFalse: 
			["Broadcast style changes to all morphs"

			newStyle := paragraph textStyle.
			(self firstInChain text: text textStyle: newStyle) recomposeChain.
			editor ifNotNil: [self installEditorToReplace: editor]].
	super layoutChanged.
	sel ifNil: [^self].

	"If selection is in top line, then recompose predecessor for possible ripple-back"
	predecessor ifNotNil: 
			[sel first <= (self paragraph lines first last + 1) 
				ifTrue: 
					[oldLast := predecessor lastCharacterIndex.
					predecessor paragraph 
						recomposeFrom: oldLast
						to: text size
						delta: 0.
					oldLast = predecessor lastCharacterIndex 
						ifFalse: 
							[predecessor changed.	"really only last line"
							self predecessorChanged]]].
	((back := predecessor notNil 
				and: [sel first <= self paragraph firstCharacterIndex]) or: 
				[successor notNil 
					and: [sel first > (self paragraph lastCharacterIndex + 1)]]) 
		ifTrue: 
			["The selection is no longer inside this paragraph.
		Pass focus to the paragraph that should be in control."

			back ifTrue: [predecessor recomposeChain] ifFalse: [self recomposeChain].
			self firstInChain withSuccessorsDo: 
					[:m | 
					(sel first between: m firstCharacterIndex and: m lastCharacterIndex + 1) 
						ifTrue: 
							[m installEditorToReplace: oldEditor.
							^self passKeyboardFocusTo: m]].
			self error: 'Inconsistency in text editor'	"Must be somewhere in the successor chain"].
	editor ifNil: 
			["Reinstate selection after, eg, style change"

			self installEditorToReplace: oldEditor].
	"self setCompositionWindow."! !

!TextMorph methodsFor: 'event handling' stamp: ''!
handlesMouseOver: evt 
	"Do I want to receive mouseEnter: and mouseLeave: when the button is up and the hand is empty?"
	^ self enabled! !

!TextMorph methodsFor: 'find-replace' stamp: ''!
sharesFindReplace
	^ false! !

!TextMorph methodsFor: 'private' stamp: ''!
setPredecessor: newPredecessor
	predecessor := newPredecessor! !

!TextMorph methodsFor: 'accessing' stamp: ''!
contents: stringOrText
	^ self contentsAsIs: stringOrText! !

!TextMorph methodsFor: 'accessing' stamp: ''!
isAutoFit
	^ self valueOfProperty: #autoFitContents ifAbsent: [true]! !

!TextMorph methodsFor: 'private' stamp: ''!
adjustLineIndicesBy: delta
	paragraph ifNotNil: [paragraph adjustLineIndicesBy: delta]! !

!TextMorph methodsFor: 'event handling' stamp: ''!
showOverEditableTextCursor

	| o |

	owner ifNil: [ ^ self ].
	o := owner isWorldMorph
		ifTrue: [ self ]
		ifFalse: [ owner ].
	( o boundsInWorld containsPoint: self currentHand position )
		ifTrue: [ self currentHand showTemporaryCursor: ( self theme overTextCursorFor: self ) ]! !

!TextMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
overrideExtent: newExtent
	"If autoFit is on then override to false for the duration of the extent call."
	
	self isAutoFit
		ifTrue: [self
				setProperty: #autoFitContents toValue: false;
				extent: newExtent;
				setProperty: #autoFitContents toValue: true]! !

!TextMorph methodsFor: 'editing' stamp: ''!
passKeyboardFocusTo: otherMorph
	self flag: #pharoFixMe. "Do we need this?!!"
	self world ifNotNil: [ :world | world handsDo: [ :h | h keyboardFocus == self ifTrue: [ h newKeyboardFocus: otherMorph ] ] ]! !

!TextMorph methodsFor: 'copying' stamp: ''!
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.
	textStyle := textStyle veryDeepCopyWith: deepCopier.
	text := text veryDeepCopyWith: deepCopier.
	wrapFlag := wrapFlag veryDeepCopyWith: deepCopier.
	paragraph := paragraph veryDeepCopyWith: deepCopier.
	editor := editor veryDeepCopyWith: deepCopier.
	container := container veryDeepCopyWith: deepCopier.
	predecessor := predecessor.
	successor := successor.
	backgroundColor := backgroundColor veryDeepCopyWith: deepCopier.
	margins := margins veryDeepCopyWith: deepCopier.! !

!TextMorph methodsFor: 'event handling' stamp: ''!
hideOverEditableTextCursor  
	self currentHand showTemporaryCursor: nil! !

!TextMorph methodsFor: 'drawing' stamp: ''!
debugDrawLineRectsOn: aCanvas
	"Shows where text line rectangles are"
	self paragraph lines do:
		[:line | aCanvas frameRectangle: line rectangle color: Color brown]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
wrapFlag
	^ wrapFlag! !

!TextMorph methodsFor: 'geometry' stamp: ''!
container
	"Return the container for composing this text.  There are four cases:
	1.  container is specified as, eg, an arbitrary shape,
	2.  container is specified as the bound rectangle, because
		this morph is linked to others,
	3.  container is nil, and wrap is true -- grow downward as necessary,
	4.  container is nil, and wrap is false -- grow in 2D as nexessary."

	container ifNil:
		[successor ifNotNil: [^ self compositionRectangle].
		wrapFlag ifTrue: [^ self compositionRectangle withHeight: 9999999].
		^ self compositionRectangle topLeft extent: 9999999@9999999].
	^ container! !

!TextMorph methodsFor: 'accessing' stamp: ''!
setLastCharacter: source
	"Set the last character of the receiver as indicated"

	| aChar chars |
	aChar := source asCharacter.
	(chars := self getCharacters) size > 0 
		ifFalse:
			[self newContents: (String with: aChar)]
		ifTrue:
			[(chars last = aChar) ifFalse:
				[self newContents: (String streamContents:
					[:aStream |
						aStream nextPutAll: (chars copyFrom: 1 to: (chars size - 1)).
						aStream nextPut: aChar])]]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
selectionInterval
	^editor ifNotNil: [ editor selectionInterval ]! !

!TextMorph methodsFor: 'interactive error protocol' stamp: ''!
correctFrom: start to: stop with: aString
	editor ifNotNil: [ editor correctFrom: start to: stop with: aString ]! !

!TextMorph methodsFor: 'alignment' stamp: ''!
justified 
	self changeAlignment: #justified! !

!TextMorph methodsFor: 'private' stamp: ''!
releaseParagraph

	"a slight kludge so subclasses can have a bit more control over whether the paragraph really 
	gets released. important for GeeMail since the selection needs to be accessible even if the 
	hand is outside me"

	self releaseParagraphReally.! !

!TextMorph methodsFor: 'containment' stamp: ''!
fillsOwner: aBoolean 
	self fillsOwner == aBoolean
		ifTrue: [^ self].
	self
		setContainer: (aBoolean
				ifTrue: [wrapFlag := true.
					container
						ifNil: [TextContainer new for: self minWidth: textStyle lineGrid * 2]
						ifNotNil: [container fillsOwner: true]]
				ifFalse: [self avoidsOcclusions
						ifFalse: [ nil ]
						ifTrue: [container fillsOwner: false]])! !

!TextMorph methodsFor: 'converting' stamp: ''!
asReadOnlyMorph

	^ StringMorph contents: self text! !

!TextMorph methodsFor: 'interactive error protocol' stamp: ''!
nextTokenFrom: start direction: dir
	^ self editor nextTokenFrom: start direction: dir! !

!TextMorph methodsFor: 'blinking' stamp: ''!
blinkStart
	"Reset time for blink cursor after which blinking should actually start"
	^self valueOfProperty: #blinkStart ifAbsent:[Time millisecondClockValue]! !

!TextMorph methodsFor: 'private' stamp: ''!
predecessorChanged

	| newStart oldStart |

	( self hasProperty: #CreatingParagraph )
		ifTrue: [ ^ self ].
	newStart := predecessor ifNil: [ 1 ] ifNotNil: [ predecessor lastCharacterIndex + 1 ].
	( self paragraph adjustedFirstCharacterIndex ~= newStart or: [ newStart >= text size ] )
		ifTrue: [ paragraph composeAllStartingAt: newStart.
			self fit
			]
		ifFalse: [ "If the offset to end of text has not changed, just slide"
			oldStart := self firstCharacterIndex.
			self withSuccessorsDo: [ :m | m adjustLineIndicesBy: newStart - oldStart ]
			]! !

!TextMorph methodsFor: 'blinking' stamp: ''!
stopBlinking
	self stopSteppingSelector: #onBlinkCursor.! !

!TextMorph methodsFor: 'accessing' stamp: ''!
crAction: aMessageSend
	"Return the action to perform when encountering a CR in the input"
	^self setProperty: #crAction toValue: aMessageSend! !

!TextMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	borderWidth := 0.
	textStyle := TextStyle default copy.
	wrapFlag := true.
	margins := Margin left: 0 right: 0 top: 0 bottom: 0.
	
	self attachKeymapCategory: #TextMorph.! !

!TextMorph methodsFor: 'accessing' stamp: ''!
borderWidth: newWidth
	super borderWidth: newWidth.
	paragraph ifNotNil: [self composeToBounds].! !

!TextMorph methodsFor: 'private' stamp: ''!
predecessor: pred successor: succ
	"Private -- for use only in morphic duplication"
	predecessor := pred.
	successor := succ.! !

!TextMorph methodsFor: 'linked frames' stamp: ''!
successor
	^ successor! !

!TextMorph methodsFor: 'menu' stamp: ''!
wrapOnOff
	self wrapFlag: wrapFlag not! !

!TextMorph methodsFor: 'copying' stamp: ''!
copy
	^ super copy text: text copy textStyle: textStyle copy 
		wrap: wrapFlag color: color
		predecessor: nil successor: nil! !

!TextMorph methodsFor: 'interactive error protocol' stamp: ''!
notify: aString at: anInteger in: aStream
	^ self editor notify: aString at: anInteger in: aStream! !

!TextMorph methodsFor: 'event handling' stamp: ''!
yellowButtonActivity: shiftKeyState 
	"Invoke the text-editing menu.
	Check if required first!!"
	
	self wantsYellowButtonMenu
		ifFalse: [ ^ false ].
		
	(self getMenu: shiftKeyState)
		ifNotNil: [ :menu|
			menu setInvokingView: self editor.
			menu invokeModal. self changed.
			^ true].
		
	^ true! !

!TextMorph methodsFor: 'accessing' stamp: ''!
margins

	^margins! !

!TextMorph methodsFor: 'editing' stamp: ''!
chooseEmphasis
	"Interactively change emphasis."
	
	self editor changeEmphasis.
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: ''!
cancelEdits
	"The message is sent when the user hits enter or Cmd-L.
	Cancel the current contents and end editing.
	This default implementation does nothing."
	self releaseParagraph! !

!TextMorph methodsFor: 'editing' stamp: ''!
acceptOnCR
	"Answer whether the receiver wants to accept when the Return key is hit.  Generic TextMorph has no such feature, but subclasses may."

	^ false! !

!TextMorph methodsFor: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!TextMorph methodsFor: 'menu' stamp: ''!
wrapString
	"Answer the string to put in a menu that will invite the user to 
	switch autoFit mode"
	^ (wrapFlag
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'text wrap to bounds' translated! !

!TextMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Draw the receiver on a canvas.
	Draw keyboard focus if appropriate."

	| fauxBounds |
	self setDefaultContentsIfNil.
	super drawOn: aCanvas.  "Border and background if any"
	false ifTrue: [self debugDrawLineRectsOn: aCanvas].  "show line rects for debugging"
	(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 paragraph: self paragraph bounds: fauxBounds color: color.! !

!TextMorph methodsFor: 'accessing' stamp: ''!
cursorWrapped: aNumber
	"Set the cursor as indicated"

	self setProperty: #textCursorLocation toValue: (((aNumber rounded - 1) \\  text string size) + 1)! !

!TextMorph methodsFor: 'accessing' stamp: ''!
selectFrom: a to: b
	self editor selectFrom: a to: b! !

!TextMorph methodsFor: 'classification' stamp: ''!
isTextMorph
	^true! !

!TextMorph methodsFor: 'geometry' stamp: ''!
defaultLineHeight
	^ textStyle lineGrid! !

!TextMorph methodsFor: 'private' stamp: ''!
setSuccessor: newSuccessor

	successor := newSuccessor.
	paragraph ifNotNil: [paragraph wantsColumnBreaks: successor notNil].! !

!TextMorph methodsFor: 'accessing' stamp: ''!
setFirstCharacter: source 
	"Set the first character of the receiver as indicated"
	| aChar chars |
	aChar := source asCharacter.
	(chars := self getCharacters) isEmpty
		ifTrue: [self
				newContents: (String with: aChar)]
		ifFalse: [chars first = aChar
				ifFalse: [self
						newContents: (String
								streamContents: [:aStream | 
									aStream nextPut: aChar.
									aStream
										nextPutAll: (chars copyFrom: 2 to: chars size)])]]! !

!TextMorph methodsFor: 'private' stamp: ''!
text: t textStyle: s
	"Private -- for use only in morphic duplication"
	text := t.
	defaultColor := (t attributesAt: 1) detect: [ :e | e isKindOf: TextColor ] ifNone: [ self color ].
	textStyle := s.
	paragraph ifNotNil: [paragraph textStyle: s]! !

!TextMorph methodsFor: 'private' stamp: ''!
fit
	"Adjust my bounds to fit the text.  Should be a no-op if autoFit is not specified.
	Required after the text changes,
	or if wrapFlag is true and the user attempts to change the extent."

	| newExtent para cBounds lastOfLines heightOfLast |
	self isAutoFit 
		ifTrue: 
			[newExtent := (self paragraph extent max: 9 @ textStyle lineGrid) + (0 @ 2).
			newExtent := newExtent + (2 * borderWidth).
			newExtent := ((0 @ 0 extent: newExtent) expandBy: margins) extent.
			newExtent ~= bounds extent 
				ifTrue: 
					[(container isNil and: [successor isNil]) 
						ifTrue: 
							[para := paragraph.	"Save para (layoutChanged smashes it)"
							super extent: newExtent.
							paragraph := para]].
			(container notNil and: [successor isNil])
				ifTrue: 
					[cBounds := container bounds truncated.
					"23 sept 2000 - try to allow vertical growth"
					lastOfLines := self paragraph lines last.
					heightOfLast := lastOfLines bottom - lastOfLines top.
					(lastOfLines last < text size 
						and: [lastOfLines bottom + heightOfLast >= self bottom]) 
							ifTrue: 
								[container releaseCachedState.
								cBounds := cBounds origin corner: cBounds corner + (0 @ heightOfLast)].
					self privateBounds: cBounds]].

	"These statements should be pushed back into senders"
	self paragraph positionWhenComposed: self position.
	successor ifNotNil: [successor predecessorChanged].
	self changed	"Too conservative: only paragraph composition
					should cause invalidation."! !

!TextMorph methodsFor: 'editing helpers' stamp: ''!
changeEmphasis: aSymbol
	"Change the alignment of the receiver. Alignment can be #normal, #bold,  #italic, #narrow, #underlined, or #struckOut"
	
	"| t |
t := 'khkjhjkhjkhjkh
kjhj
kjhkjhkjh
kjh
kjhkjh kjh jh jh jh jh kjh kjh ' asTextMorph.
t openInWorld.
t selectAll; changeEmphasis: #bold.
t inspect"
	
	self editor applyAttribute: (TextEmphasis perform: aSymbol).
	"this code should be moved to TextEditor but changeEmphasis: is defined there for something else
	so it should be renamed first there."
	self updateFromParagraph! !

!TextMorph methodsFor: 'events-processing' stamp: ''!
handleMouseMove: anEvent
	"Re-implemented to allow for mouse-up move events"
	anEvent wasHandled ifTrue:[^self]. "not interested"
	(anEvent hand hasSubmorphs) ifTrue:[^self].
	anEvent wasHandled: true.
	self mouseMove: anEvent.
	(anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
	(self handlesMouseStillDown: anEvent) ifTrue:[
		"Step at the new location"
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue
			arguments: {anEvent copy resetHandlerFields}
			stepTime: 1].! !

!TextMorph methodsFor: 'accessing' stamp: ''!
enabled: aBoolean

	aBoolean 
		ifTrue: [ text makeAllColor: self defaultColor ]
		ifFalse: [ text makeAllColor: self theme disabledTextColor ].
		
	self changed! !

!TextMorph methodsFor: 'accessing' stamp: ''!
cursor
	"Answer the receiver's logical cursor position"

	| loc |
	loc := self valueOfProperty: #textCursorLocation  ifAbsentPut: [1].
	loc := loc min: text string size.
	^ loc rounded! !

!TextMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint 
	| newExtent priorEditor |
	bounds extent = aPoint ifTrue: [^ self].
	priorEditor := editor.
	self isAutoFit
		ifTrue: [wrapFlag ifFalse: [^ self].  "full autofit can't change"
				newExtent := aPoint truncated max: self minimumExtent.
				newExtent x = self extent x ifTrue: [^ self].  "No change of wrap width"
				self releaseParagraphReally.  "invalidate the paragraph cache"
				super extent: newExtent.
				priorEditor
					ifNil: [self fit]  "since the width has changed..."
					ifNotNil: [self installEditorToReplace: priorEditor]]
		ifFalse: [super extent: (aPoint truncated max: self minimumExtent).
				wrapFlag ifFalse: [^ self].  "no effect on composition"
				self composeToBounds]! !

!TextMorph methodsFor: 'containment' stamp: ''!
fillingOnOff
	"Establish a container for this text, with opposite filling status"
	self fillsOwner: (self fillsOwner not)! !

!TextMorph methodsFor: 'event handling' stamp: ''!
yellowButtonActivity
	"Supply the normal 'code pane' menu to use its text editing 
	commands from a menu."
	^ self yellowButtonActivity:false! !

!TextMorph methodsFor: 'containment' stamp: ''!
occlusionsOnOff
	"Establish a container for this text, with opposite occlusion avoidance status"
	self setContainer:
	(container
	ifNil: [(TextContainer new for: self minWidth: textStyle lineGrid*2)
							fillsOwner: false; avoidsOcclusions: true]
	ifNotNil: [(container avoidsOcclusions and: [container fillsOwner not])
			ifTrue: [nil  "Return to simple rectangular bounds"]
			ifFalse: [container avoidsOcclusions: container avoidsOcclusions not]])! !

!TextMorph methodsFor: 'blinking' stamp: ''!
resetBlinkCursor
	"Reset the blinking cursor"
	| para |
	self blinkStart: Time millisecondClockValue + 500.
	para := self paragraph ifNil:[^self].
	para showCaret = para focused ifFalse:[
		para caretRect ifNotNil:[:r| self invalidRect: r].
		para showCaret: para focused.
	].! !

!TextMorph methodsFor: 'geometry' stamp: ''!
minimumExtent


	| minExt |
	textStyle ifNil: [^ 9@16].
	borderWidth ifNil: [^ 9@16].
	minExt := (9@(textStyle lineGrid+2)) + (borderWidth*2).
	^ ((0@0 extent: minExt) expandBy: margins) extent! !

!TextMorph methodsFor: 'accessing' stamp: ''!
textColor

	^ color! !

!TextMorph methodsFor: 'private' stamp: ''!
removedMorph: aMorph
	| range |
	range := text find: (TextAnchor new anchoredMorph: aMorph).
	range ifNotNil:
		[self paragraph replaceFrom: range first to: range last
				with: Text new displaying: false.
		self fit].
	aMorph textAnchorType: nil.
	aMorph relativeTextAnchorPosition: nil.
	super removedMorph: aMorph.! !

!TextMorph methodsFor: 'editing' stamp: ''!
chooseStyle
	self editor changeStyle.
	self updateFromParagraph.! !

!TextMorph methodsFor: 'menu' stamp: ''!
setCurveBaseline: evt
	| handle origin |
	origin := evt cursorPoint.
	handle := HandleMorph new forEachPointDo:
		[:newPoint | handle removeAllMorphs.
		handle addMorph:
			(PolygonMorph vertices: (Array with: origin with: newPoint)
				color: Color black borderWidth: 1 borderColor: Color black).
		container baseline: (newPoint - origin) y negated asInteger // 5.
		self paragraph composeAll].
	evt hand attachMorph: handle.
	handle startStepping! !

!TextMorph methodsFor: 'visual properties' stamp: ''!
fillStyle
	"Return the current fillStyle of the receiver."
	
	self assureExtension.
	^extension fillStyle ifNil: [
		backgroundColor
			ifNil: [Color transparent]]! !

!TextMorph methodsFor: 'accessing' stamp: ''!
getFirstCharacter
	"obtain the first character from the receiver if it is empty, return a  
	black dot"
	| aString |
	^ (aString := text string) isEmpty
		ifTrue: ['·']
		ifFalse: [aString first asString]! !

!TextMorph methodsFor: 'geometry testing' stamp: ''!
containsPoint: aPoint
	(super containsPoint: aPoint) ifFalse: [^ false].  "Not in my bounds"
	container ifNil: [^ true].  "In bounds of simple text"
	self startingIndex > text size ifTrue:
		["make null text frame visible"
		^ super containsPoint: aPoint].
	"In complex text (non-rect container), test by line bounds"
	^ self paragraph containsPoint: aPoint! !

!TextMorph methodsFor: 'private' stamp: ''!
installEditorToReplace: priorEditor
	"Install an editor for my paragraph.  This constitutes 'hasFocus'.
	If priorEditor is not nil, then initialize the new editor from its state.
	We may want to rework this so it actually uses the prior editor."

	| stateArray |
	priorEditor ifNotNil: [stateArray := priorEditor stateArray].
	editor := self editorClass forMorph: self.
	priorEditor ifNotNil: [editor stateArrayPut: stateArray].
	self selectionChanged.
	^ editor! !

!TextMorph methodsFor: 'accessing' stamp: ''!
text
	^ text! !

!TextMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TextMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TextMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TextMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TextMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TextMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TextMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TextMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TextMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TextMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TextMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TextMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TextMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TextMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TextMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TextMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TextMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TextMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TextMorph class methodsFor: 'shortcuts' stamp: ''!
buildTextEditorKeymapsOn: aBuilder
	<keymap>
	
	(aBuilder shortcut: #accept)
		category: #TextMorph
		default: PharoShortcuts current acceptShortcut
		do: [ :morph | morph acceptContents ].! !

!TextMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TextMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TextMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TextMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!TextMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!TextMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!TextMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TextMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TextMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TextMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TextMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TextMorphTest methodsFor: 'testing' stamp: ''!
testInitialize
	"For now, just make sure initialization doesn't throw exception"

	TextMorph initialize! !

!TextMorphTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ TextMorph! !

!TextPresenter commentStamp: ''!
I handle basic multi-line text.
See AbstractWidgetPresenter

self example

You can also have a look at ListSelectionPresenter and ScrollSyncExample for more examples.

My main purpose is to handle source code (I have editing shortcuts support).

I provide the following variables and their accessors
- autoAccept is a boolean representing if the text is accepted on each keystroke.
- text is the text of the text zone.

I provide the following methods
- beForCode and beForText are shortcut for configuring me.
- getSelection return the interval currently selected.
- getText is a getter of the text


todo
- aboutToStyleBlock  is the block used to know if the text must be styled, it returns a boolean. aboutToStyle: is a shortcut to set directly the boolean.
- accept , accept:notifying:
- acceptBlock should convert the text in a boolean representing if it is to be accepted.
- askBeforeDiscardingEdits
- behavior
- clearSelection
- codePaneMenu:shifted:
- doItContext
- doItReceiver
- specializing eventKeyStrokesForNextFocus , eventKeyStrokesForPreviousFocus
- getMenu
- hasEditingConflicts
- hasUnacceptedEdits
- isAboutToStyle
- isCodeCompletionAllowed
- isForSmalltalkCode
- menuHolder
- notify:at:in:
- readSelection , readSelectionBlock
- registerEvents , registerEventsForShout
- scrollValue
- selectedBehavior
- selectedClassOrMetaClass
-  setSelection: select the text in the interval in argument, selectAll is a shorcut that set the larger interval.
- setSelectionInterval:
- textArea
!
!TextPresenter methodsFor: 'api' stamp: ''!
readSelectionBlock: aBlock
	"<api: #block getter: #readSelectionBlock registration: #whenReadSelectionIsChanged:>"
	"Set the block used to calculate the text selection"

	^ readSelectionHolder value: aBlock! !

!TextPresenter methodsFor: 'api' stamp: ''!
text

	^ self getText! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenScrollValueChanged: aBlock
	"Set a block to perform when the scroll value changed"
	
	scrollValue whenChangedDo: aBlock! !

!TextPresenter methodsFor: 'api' stamp: ''!
selectedBehavior

	^ behaviorHolder value! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenBehaviorChanged: aBlock
	"Set a block to perform when the behavior class changed"
	
	behaviorHolder whenChangedDo: aBlock! !

!TextPresenter methodsFor: 'api' stamp: ''!
isCodeCompletionAllowed: aBoolean
	"<api: #boolean getter: #isCodeCompletionAllowed registration: #whenCodeCompletionAllowedChanged:>"
	"Set if code completion is allowed"
	
	isCodeCompletionAllowedHolder value: aBoolean! !

!TextPresenter methodsFor: 'api' stamp: ''!
hasEditingConflicts: aBoolean
	"Set if the text zone has editing conflicts"
	"<api:#boolean getter: #hasEditingConflicts>"
	
	^ self changed: #hasEditingConflicts: with: { aBoolean }! !

!TextPresenter methodsFor: 'api' stamp: ''!
codePaneMenu: aMenu shifted: shifted 
	"Note that unless we override perform:orSendTo:, 
	PluggableTextController will respond to all menu items in a 
	text pane"
	
	^ menuHolder value cull: aMenu cull: shifted! !

!TextPresenter methodsFor: 'api' stamp: ''!
hasUnacceptedEdits
	"<api:#inspect>"
	"Return if the text zone has unaccepted edits (orange corner)"

	hasUnacceptedEdits ifNil: [ ^ false ].
	^ hasUnacceptedEdits value! !

!TextPresenter methodsFor: 'api' stamp: ''!
hasUnacceptedEdits: aBoolean
	"Return if the text zone has unaccepted edits (orange corner)"
	"<api:#boolean getter: #hasUnacceptedEdits>"
	hasUnacceptedEdits value: aBoolean! !

!TextPresenter methodsFor: 'api' stamp: ''!
wantsVisualFeedback: aBoolean

	wantsVisualFeedback value: aBoolean! !

!TextPresenter methodsFor: 'initialization' stamp: ''!
registerEvents

	textHolder whenChangedDo: [ self changed: #getText ].
	readSelectionHolder whenChangedDo: [ self changed: #readSelection ].
	hasUnacceptedEdits whenChangedDo: [ :bool | self changed: #setHasUnacceptedEdits: with: { bool } ].
	selection whenChangedDo: [:block | self changed: #setSelectionFromModel: with: { block value } ].
	scrollValue whenChangedDo: [ :newPosition | self changed: #setScrollValue: with: { newPosition } ].
	autoAccept whenChangedDo: [:bool | self changed: #autoAccept: with: { bool } ].
	wantsVisualFeedback whenChangedDo: [ :bool | self changed: #changed with: #() ].
	askBeforeDiscardingEdits whenChangedDo: [ :bool | self changed: #askBeforeDiscardingEdits: with: { bool } ].! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenAboutToStyleBlockChanged: aBlock
	"Set a block to perform when the about to style block changed"
	
	aboutToStyleHolder whenChangedDo: aBlock! !

!TextPresenter methodsFor: 'api' stamp: ''!
autoAccept 
	"Return true if the text is accepted after ech keystroke"
	"<api:#inspect>"
	^ autoAccept value! !

!TextPresenter methodsFor: 'api' stamp: ''!
autoAccept: aBoolean
	"<api: #boolean getter: #autoAccept registration: #whenAutoAcceptChanged:>"
	"Set if the text is accepted after each keystroke or not"

	autoAccept value: aBoolean! !

!TextPresenter methodsFor: 'api' stamp: ''!
setSelection: anInterval
	"Set the text selection without changing the readSelectionBlock"
	"<api: #st getter: #getSelection>"

	selection ifNotNil: [: holder | holder value: anInterval ]! !

!TextPresenter methodsFor: 'api' stamp: ''!
askBeforeDiscardingEdits

	^ askBeforeDiscardingEdits value! !

!TextPresenter methodsFor: 'api' stamp: ''!
setSelectionInterval: anInterval
	selection rawValue: anInterval! !

!TextPresenter methodsFor: 'api - shout' stamp: ''!
behavior: aClass
	"< api: #st getter: #behavior registration: #whenBehaviorChanged:>"
	"Set the class corresponding to the method class of the source code you are editing"

	behaviorHolder value: aClass! !

!TextPresenter methodsFor: 'api' stamp: ''!
askBeforeDiscardingEdits: aBoolean

	askBeforeDiscardingEdits value: aBoolean! !

!TextPresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	textHolder := '' asValueHolder.
	behaviorHolder := nil asValueHolder.
	aboutToStyleHolder := [ false ] asValueHolder.
	actionToPerformHolder := [ :text |  ] asValueHolder.
	readSelectionHolder := [ selection value ] asValueHolder.
	actionPerformedHolder := '' asValueHolder.
	isCodeCompletionAllowedHolder := false asValueHolder.
	isForSmalltalkCodeHolder := false asValueHolder.
	doItContext := nil asValueHolder.
	doItReceiver := nil asValueHolder.
	hasUnacceptedEdits := false asValueHolder.
	selection := (1 to: 0) asValueHolder.
	scrollValue := (0 @ 0) asValueHolder.
	menuHolder := [ :menu :shifted |  ] asValueHolder.
	autoAccept := false asValueHolder.
	wantsVisualFeedback := true asValueHolder.
	askBeforeDiscardingEdits := true asValueHolder.
	self beForText.
	self registerEvents.
	self registerEventsForShout! !

!TextPresenter methodsFor: 'api' stamp: ''!
text: aText
	"<api: #string getter: #getText registration: #whenTextChanged:>"
	"Set the text of the text zone"
	
	textHolder value: aText! !

!TextPresenter methodsFor: 'NOCompletion' stamp: ''!
selectedClassOrMetaClass

	^ self behavior! !

!TextPresenter methodsFor: 'api' stamp: ''!
isForSmalltalkCode: aBoolean
	isForSmalltalkCodeHolder value: aBoolean! !

!TextPresenter methodsFor: 'api - errors' stamp: ''!
notify: errorMessage at: position in: sourceCode

	self changed: #notify:at:in: with: { errorMessage . position . sourceCode }! !

!TextPresenter methodsFor: 'api' stamp: ''!
beForCode
	self
		isCodeCompletionAllowed: true;
		menuHolder: [ self getMenu ];
		isForSmalltalkCode: true! !

!TextPresenter methodsFor: 'api' stamp: ''!
scrollValue
	"<api: #inspect>"
	"Return the current scroll position"

	^ scrollValue value! !

!TextPresenter methodsFor: 'undo - redo' stamp: ''!
clearUndoManager
	self widget ifNotNil: #clearUndoManager! !

!TextPresenter methodsFor: 'api' stamp: ''!
acceptBlock: aBlockWithOneArgument
	"<api: #block getter: #acceptBlock registration: #whenAcceptBlockChanged:>"
	"Set the block to perform when the text is accepted.
	The block must have one argument, which will be the accepted text.
	The block can return false if the candidate text is to be rejected"

	actionToPerformHolder value: aBlockWithOneArgument! !

!TextPresenter methodsFor: 'api - shout' stamp: ''!
aboutToStyleBlock
	"Return the block used to know if the text must be styled"	
	"<api:#inspect>"
	^ aboutToStyleHolder value! !

!TextPresenter methodsFor: 'api' stamp: ''!
acceptBlock
	"<api: #inspect>"
	"Return the block to perform when the text is accepted.
	The block must have one argument, which will be the accepted text"

	^ actionToPerformHolder value! !

!TextPresenter methodsFor: 'focus' stamp: ''!
eventKeyStrokesForPreviousFocus
	"String describing the keystroke to perform to jump to the previous widget"

	^ { Character arrowLeft command ctrl asKeyCombination }! !

!TextPresenter methodsFor: 'private' stamp: ''!
textArea
	^ self widget widget ! !

!TextPresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
pendingText
	"<api: #inspect>"
	"Return the current pending text"

	^ self 
		detectMorphicAdapterDo: [ :w | w pendingText ]
		ifNone: [ self getText ]! !

!TextPresenter methodsFor: 'api' stamp: ''!
isForSmalltalkCode
	^ isForSmalltalkCodeHolder value! !

!TextPresenter methodsFor: 'api - shout' stamp: ''!
aboutToStyle: aBoolean	
	"<api: #boolean getter: #isAboutToStyle registration: #whenAboutToStyleChanged:>"
	"Set if the text zone must be styled"
	
	aboutToStyleHolder value: [ aBoolean ]! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenMenuHolderChanged: aBlock
	"Set a block to perform when the block use to build menu changed"
	
	menuHolder whenChangedDo: aBlock! !

!TextPresenter methodsFor: 'initialization' stamp: ''!
registerEventsForShout

	aboutToStyleHolder whenChangedDo: [ self changed: #getText ].
	behaviorHolder
		whenChangedDo: [ :class | 
			self changed: #classOrMetaClass: with: { class }.
			self changed: #getText ]! !

!TextPresenter methodsFor: 'api' stamp: ''!
beForText
	self
		isCodeCompletionAllowed: false;
		menuHolder: [ self getMenu ];
		isForSmalltalkCode: false! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenTextChanged: aBlock
	"Set a block to perform when the text changed"
	
	textHolder whenChangedDo: aBlock! !

!TextPresenter methodsFor: 'api' stamp: ''!
hasEditingConflicts
	"<api:#inspect>"
	"Return if the text zone has editing conflicts"

	^ self widget 
		ifNil: [ false ]
		ifNotNil: [:w | w hasEditingConflicts ]! !

!TextPresenter methodsFor: 'api' stamp: ''!
accept: aText notifying: aNotifyier
	| accept newText |
	
	accept := actionToPerformHolder value cull: aText cull: aNotifyier.
	accept == false ifTrue: [ ^ false ].
	
	newText := aText copy.
	textHolder value: newText.
	
	"Dummy changed to raise an announcement"
	actionPerformedHolder value: newText.
	
	self changed: #clearUserEdits.
	^ true! !

!TextPresenter methodsFor: 'api - shout' stamp: ''!
isAboutToStyle
	"<api: #inspect>"
	"Return if the text zone is shouted or not"

	^ self aboutToStyleBlock value! !

!TextPresenter methodsFor: 'api' stamp: ''!
menuHolder: aBlock
	"<api: #block getter: #menuHolder registration: #whenMenuHolderChanged:>"
	"Set the block used to compute the menu"

	^ menuHolder value:  aBlock! !

!TextPresenter methodsFor: 'api - doIt' stamp: ''!
doItContext: anObject

	doItContext value: anObject! !

!TextPresenter methodsFor: 'private' stamp: ''!
getMenu
	^ (PragmaMenuBuilder
		pragmaKeyword: self textArea editingModeClass menuKeyword
		model: self widget) menu! !

!TextPresenter methodsFor: 'api - doIt' stamp: ''!
doItReceiver
	| receiver |
	
	receiver := doItReceiver value.
	receiver isBehavior ifTrue: [receiver  := receiver instanceSide].
	^receiver! !

!TextPresenter methodsFor: 'api - shout' stamp: ''!
aboutToStyleBlock: aBlockReturningABoolean
	"<api: #block getter: #aboutToStyleBlock registration: #whenAboutToStyleBlockChanged:>"
	"Set the block used to know if the text must be styled.
	The block must return a boolean"

	aboutToStyleHolder value: aBlockReturningABoolean! !

!TextPresenter methodsFor: 'api' stamp: ''!
selectAll
	
	self changed: #selectAll with: #()! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenReadSelectionIsChanged: aBlock
	"Set a block to perform when the read selection block changed"
	
	readSelectionHolder whenChangedDo: aBlock! !

!TextPresenter methodsFor: 'api' stamp: ''!
accept
	"<api: #do>"
	"Accep the current pendingtext"
	
	self changed: #accept with: #().
	
	"Dummy changed to raise an announcement"
	actionPerformedHolder value: self text.! !

!TextPresenter methodsFor: 'api - doIt' stamp: ''!
doItReceiver: anObject

	doItReceiver value: anObject! !

!TextPresenter methodsFor: 'api' stamp: ''!
scrollValue: aPoint
	"<api: #point getter: #scrollValue registration: #whenScrollValuehanged:>"
	"Set the scroll position"

	^ scrollValue value: aPoint! !

!TextPresenter methodsFor: 'focus' stamp: ''!
eventKeyStrokesForNextFocus
	"String describing the keystroke to perform to jump to the next widget"
	^ { Character arrowRight command ctrl asKeyCombination }! !

!TextPresenter methodsFor: 'api' stamp: ''!
getText
	"<api: #inspect>"
	^ textHolder value! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenAcceptBlockChanged: aBlock
	"Set a block to perform when the accept block changed"
	
	actionToPerformHolder whenChangedDo: aBlock! !

!TextPresenter methodsFor: '*Spec-MorphicAdapters' stamp: ''!
pendingText: aText
	"<api: #string getter: #pendingText>"
	"Set the pending text. Do no accept it"

	self 
		detectMorphicAdapterDo: [ :w | w pendingText: aText ]
		ifNone: [ self text: aText ]! !

!TextPresenter methodsFor: 'api - doIt' stamp: ''!
doItContext

	^ doItContext value! !

!TextPresenter methodsFor: 'api' stamp: ''!
readSelection
	"<api: #inspect>"
	^ readSelectionHolder value cull: self text cull: self! !

!TextPresenter methodsFor: 'api' stamp: ''!
wantsVisualFeedback

	^ wantsVisualFeedback value! !

!TextPresenter methodsFor: 'api' stamp: ''!
readSelectionBlock
	"<api: #inspect>"
	"Return the block used to calculate the text selection"

	^ readSelectionHolder value! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenCodeCompletionAllowedChanged: aBlock
	"Set a block to perform when the code completion value changed"
	
	actionPerformedHolder whenChangedDo: aBlock! !

!TextPresenter methodsFor: 'api' stamp: ''!
getSelection
	"<api:#inspect>"
	"Get the text selection"

	selection ifNil: [ ^(1 to: 0) ].
	^ selection value! !

!TextPresenter methodsFor: 'api' stamp: ''!
clearSelection
"	<api: #do>"
   "Remove selection from the text model"

	self setSelection: (0 to: 0)! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenTextIsAccepted: aBlock
	"Set a block to perform when the text is accepted"
	
	actionPerformedHolder whenChangedDo: aBlock! !

!TextPresenter methodsFor: 'api' stamp: ''!
menuHolder
	"<api: #inspect>"
	"Return the block used to calculate the text selection"

	^ menuHolder value! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenAboutToStyleChanged: aBlock
	"<api: #event>"
	"Set a block to perform when the about to style block changed"
	
	self whenAboutToStyleBlockChanged: [:block :old :announcement :anAnnouncer | 
		aBlock cull: (block value) cull: old cull: announcement cull: anAnnouncer ]! !

!TextPresenter methodsFor: 'api - events' stamp: ''!
whenAutoAcceptChanged: aBlock
	"aBlock will be performed when autoAccept changed"
	
	autoAccept whenChangedDo: aBlock! !

!TextPresenter methodsFor: 'api - shout' stamp: ''!
behavior
	"<api: #inspect>"
	"Return the class corresponding to the method class of the source code you are editing"
	
	^ behaviorHolder value! !

!TextPresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	^ self new
	 openWithSpec;
		text:
			'This is a test.
If this had been an actual emergency...'
! !

!TextPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(TextAdapter
		adapt: #(model))! !

!TextPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TextAdapter! !

!TextPresenter class methodsFor: 'specs' stamp: ''!
title

	^ 'Text'! !

!TextPrintIt commentStamp: ''!
A "Print It" action on a text. When the text is clicked the text is seen as source code and evaluated (see comment on parent). After that the result is printed in pop up message.

| stream |
stream := TextStream on: (Text new: 100).
stream 
	withAttribute: (TextPrintIt evalString: '-1 arcCos')
	do: [ stream nextPutAll: '-1 arcCos' ].
TextMorph new 
	newContents: stream contents;
	openInWindow.!
!TextPrintIt methodsFor: '*Text-Edition' stamp: ''!
actOnClick: anEvent for: anObject in: paragraph editor: editor

	| result |
	result := Smalltalk compiler receiver: anObject; evaluate: evalString.
	UIManager inform: result printString.
	^ true ! !

!TextSelectionColor commentStamp: ''!
I represent a text selection attribute that can be added to a text for a text emphazing (text color). I have a color block (colorBlock) which is evaluated in order to get the text color. 
I have three instances, one for the primary selection and the two others for the secondary selection and the find replace selection. 
PrimarySelection is used in TextEditor>>#storeSelectionInParagraph in order to emphasize the selection text if the selection text color setting is not nil.
SecondarySelection and FindReplaceSelection are manage by MultiNewParagraph if secondary selection text and find replace selection text colors are not nil.

Instance Variables
	colorBlock:		<Block>

colorBlock
	- The block which is evaluated in order to get the text color
!
!TextSelectionColor methodsFor: 'accessing' stamp: ''!
colorBlock

	^ colorBlock ifNil: [colorBlock := [self theme currentSettings selectionTextColor]]! !

!TextSelectionColor methodsFor: 'accessing' stamp: ''!
colorBlock: aBlock
	"aBlock value gives the text color"
	colorBlock := aBlock! !

!TextSelectionColor methodsFor: 'accessing' stamp: ''!
textColor
	^ self colorBlock value! !

!TextSelectionColor methodsFor: 'accessing' stamp: ''!
theme
	^ Smalltalk ui theme! !

!TextSelectionColor methodsFor: 'accessing' stamp: ''!
emphasizeScanner: scanner 
	"Set the emphasis for text display"
	scanner textColor: self textColor! !

!TextSelectionColor methodsFor: 'accessing' stamp: ''!
dominates: other
	"There can be only one..."
	^self class == other class! !

!TextSelectionColor class methodsFor: 'default accessing' stamp: ''!
findReplaceSelection
	^ FindReplaceSelection
		ifNil: [FindReplaceSelection := self new
						colorBlock: [self theme currentSettings findReplaceSelectionTextColor]]! !

!TextSelectionColor class methodsFor: 'default accessing' stamp: ''!
theme
	^ Smalltalk ui theme! !

!TextSelectionColor class methodsFor: 'default accessing' stamp: ''!
secondarySelection
	^ SecondarySelection
		ifNil: [SecondarySelection := self new
						colorBlock: [self theme currentSettings secondarySelectionTextColor]] ! !

!TextSelectionColor class methodsFor: 'cleaning' stamp: ''!
cleanUp
	PrimarySelection := nil.! !

!TextSelectionColor class methodsFor: 'default accessing' stamp: ''!
primarySelection
	^ PrimarySelection
		ifNil: [PrimarySelection := self new colorBlock: [ self theme currentSettings selectionTextColor]]! !

!TextStream commentStamp: ''!
I'm a Stream of Text objects. 

ex:

	|ts|
	ts := TextStream on: (Text new: 50).
 	ts nextPutAll: 'I ' asText.
	ts nextPutAll: 'love' asText allBold.
 	ts nextPutAll: ' Pharo'.
	TextMorph new 
		newContents: ts contents;
 		openInWindowLabeled: 'TextStream test'!
!TextStream methodsFor: 'private' stamp: ''!
withAttributes: attributes do: streamBlock 
"Add text to the stream with a block and apply its text attributes (in collection)"
	| pos1 val |
	pos1 := self position.
	val := streamBlock value.
	attributes do: [:attribute |
		collection
			addAttribute: attribute
			from: pos1 + 1
			to: self position].
	^ val! !

!TextStream methodsFor: 'accessing' stamp: ''!
applyAttribute: att beginningAt: startPos
	collection addAttribute: att from: startPos to: self position! !

!TextStream methodsFor: 'accessing' stamp: ''!
nextPutAll: aCollection 
 	"Optimized access to get around Text at:Put: overhead"
 	| n |
 	n := aCollection size.
      position + n > writeLimit
        ifTrue:
         [self growTo: position + n + 10].
 	collection 
 		replaceFrom: position+1
 		to: position + n
 		with: aCollection
 		startingAt: 1.
 	position := position + n.
	^ aCollection! !

!TextStream methodsFor: 'private' stamp: ''!
withAttribute: att do: strmBlock
"Add text to the stream with a block and apply its text attribute"
	| pos1 val |
	pos1 := self position.
	val := strmBlock value.
	collection addAttribute: att from: pos1+1 to: self position.
	^ val! !

!TextStreamTest commentStamp: ''!
A TextStreamTest is a test class for testing the behavior of TextStream!
!TextStreamTest methodsFor: 'tests' stamp: ''!
testApplyAttributeBeginningAt
	| attributes |
	stream nextPutAll: 'Pharo is cool'.
	stream applyAttribute:  TextEmphasis underlined beginningAt: 10.
	1 to: 9 do: [ :index |
		attributes := stream contents runs at: index.
		self assertEmpty: attributes].	
	10 to: 14 do: [ :index |
		attributes := stream contents runs at: index.
		self assert: attributes isArray.
		self assert: attributes first emphasisCode equals: 4].! !

!TextStreamTest methodsFor: 'tests' stamp: ''!
testNextPutAll
	stream 
		nextPutAll: 'Pharo';
		space.
	self assert: stream contents isText.
	self assert: stream contents string equals: 'Pharo '.
	"No attribute was set"
	1 to: 6 do: [:index | self assertEmpty: (stream contents runs at: index) ]! !

!TextStreamTest methodsFor: 'tests' stamp: ''!
testAddStringToTextStream
	"It is possible to add a string into a TextStream.
	 This test verifies that the created text has text attributes for all its characters."
	| ts text |
	ts := TextStream on: (Text new: 50).
	ts nextPutAll: 'abc' asText.
	ts nextPutAll: 'def' asText allBold.
	ts nextPutAll: 'ghijk'.
	text := ts contents.
   "Now, check the fundamental invariant of a text:"
	self assert: text string size equals: text runs size
! !

!TextStreamTest methodsFor: 'tests' stamp: ''!
testWithAttributesDo
	| attributes |
	stream 
		withAttributes: {TextEmphasis bold. TextColor yellow}  
		do: [stream nextPutAll: 'Pharo' ].
	stream nextPutAll: ' is cool'.
	self assert: stream contents string equals: 'Pharo is cool'.
	1 to: 5 do: [ :index  |
		attributes := stream contents runs at: index.
		self assert: attributes size equals: 2.
		self assert: attributes first emphasisCode equals:  1.
		self assert: attributes second color equals: Color yellow ].
	"No attribute for the remaining part of the text"
	6 to: 12 do: [ :index |
		self assertEmpty: (stream contents runs at: index ) ]! !

!TextStreamTest methodsFor: 'tests' stamp: ''!
testWithAttributeDo
	| attributes |
	stream 
		withAttribute: TextEmphasis bold 
		do: [stream nextPutAll: 'Pharo'  ].
	stream space.
	stream 
		withAttribute: TextEmphasis underlined 
		do: [stream nextPutAll: 'is cool'  ].
	self assert: stream contents string equals: 'Pharo is cool'.
	"part of the text underlined"
	1 to: 5 do: [ :index |
		attributes := stream contents runs at: index.
		self assert: attributes isArray.
		self assert: attributes first emphasisCode equals: 1].
	"no attribute on this space character"
	self assertEmpty: (stream contents runs at: 6).
	"part of the text bold"
	7 to: 13 do: [ :index |
		attributes := stream contents runs at: index.
		self assert: attributes isArray.
		self assert: attributes first emphasisCode equals: 4].! !

!TextStreamTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	stream := TextStream on: (Text new:100)! !

!TextStyle commentStamp: ''!
A textStyle comprises the formatting information for composing and displaying a unit (usually a paragraph) of text.  Typically one makes a copy of a master textStyle (such as TextStyle default), and then that copy may get altered in the process of editing.  Bad things can happen if you do not copy first.

Each of my instances consists of...
	fontArray		An array of StrikeFonts
	fontFamilySize	unused
	lineGrid			An integer; default line spacing for paragraphs
	baseline			An integer; default baseline (dist from line top to bottom of an 'a')
	alignment		An integer; text alignment, see TextStyle alignment:
	firstIndent		An integer; indent of first line in pixels
	restIndent		An integer; indent of remaining lines in pixels
	rightIndent		An integer; indent of right margin rel to section
	tabsArray		An array of integers giving tab offsets in pixels
	marginTabsArray	An array of margin tabs
	leading			An integer giving default vertical line separation

For a concrete example, look at TextStyle default copy inspect!
!TextStyle methodsFor: 'accessing' stamp: ''!
justified
	alignment := 3! !

!TextStyle methodsFor: 'accessing' stamp: ''!
firstIndent
	"Answer the horizontal indenting of the first line of a paragraph in the 
	style of the receiver."

	^firstIndent! !

!TextStyle methodsFor: 'tabs and margins' stamp: ''!
clearIndents
	"Reset all the margin (index) settings to be 0."

	self firstIndent: 0.
	self restIndent: 0.
	self rightIndent: 0! !

!TextStyle methodsFor: 'comparing' stamp: ''!
hash
	"#hash is re-implemented because #= is re-implemented"
	^fontArray hash
! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: ''!
fontIndexOfPointSize: desiredPointSize 
	"Returns an index in fontArray of the font with pointSize <= desiredPointSize"
	"Leading is not inluded in the comparison"
	| bestMatch bestIndex d |
	bestMatch := 9999.
	bestIndex := 1.
	1 
		to: fontArray size
		do: 
			[ :i | 
			d := desiredPointSize - (fontArray at: i) pointSize.
			d = 0 ifTrue: [ ^ i ].
			(d > 0 and: [ d < bestMatch ]) ifTrue: 
				[ bestIndex := i.
				bestMatch := d ] ].
	^ bestIndex! !

!TextStyle methodsFor: 'accessing' stamp: ''!
rightIndent: anInteger 
	"Answer the right margin indent for the lines of a paragraph in the style 
	of the receiver to be the argument, anInteger."
	rightIndent := anInteger! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: ''!
fontIndexOf: aFont
	^ fontArray indexOf: aFont ifAbsent: [nil]! !

!TextStyle methodsFor: 'accessing' stamp: ''!
leading
	"Leading (from typographers historical use of extra lead (type metal))
	is the extra spacing above and beyond that needed just to accomodate
	the various font heights in the set."
	^ leading! !

!TextStyle methodsFor: 'accessing' stamp: ''!
firstIndent: anInteger 
	"Set the horizontal indenting of the first line of a paragraph in the style 
	of the receiver to be the argument, anInteger."
	firstIndent := anInteger! !

!TextStyle methodsFor: 'accessing' stamp: ''!
rightFlush
	alignment := 1! !

!TextStyle methodsFor: '*Rubric' stamp: ''!
privateTabsArray: anArray
	"DefaultTab := anArray first.
	DefaultTabsArray := anArray."
	tabsArray := anArray.
	marginTabsArray := tabsArray collect: [ :t | Array with: t with: t ]
! !

!TextStyle methodsFor: 'tabs and margins' stamp: ''!
tabWidth
	"Answer the width of a tab."

	^DefaultTab! !

!TextStyle methodsFor: 'accessing' stamp: ''!
pointSizes
	^ fontArray collect: [:x | x pointSize]

  "TextStyle default fontNamesWithPointSizes"! !

!TextStyle methodsFor: 'accessing' stamp: ''!
leading: yDelta 
	leading := yDelta! !

!TextStyle methodsFor: 'default font' stamp: ''!
defaultFontIndex
	^ defaultFontIndex ifNil: [ defaultFontIndex := 1 ]! !

!TextStyle methodsFor: 'accessing' stamp: ''!
fontNames  "TextStyle default fontNames"
	^ fontArray collect: [:x | x familyName]! !

!TextStyle methodsFor: 'accessing' stamp: ''!
fontNamed: fontName  "TextStyle default fontNamed: 'TimesRoman10'"
	^ fontArray detect: [:x | x familyName sameAs: fontName]! !

!TextStyle methodsFor: 'tabs and margins' stamp: ''!
rightMarginTabAt: marginIndex
	"Set the 'nesting' level of right margin indents of the paragraph in the 
	style of the receiver to be marginIndex."

	^ (marginIndex > 0 and: [ marginIndex < marginTabsArray size ])
		ifTrue: [ (marginTabsArray at: marginIndex) at: 2 ]
		ifFalse: [ "The marginTabsArray is an Array of tuples.  The Array is indexed according 
	to the marginIndex, the 'nesting' level of the requestor." 0 ]! !

!TextStyle methodsFor: '*Rubric' stamp: ''!
rubTabWidth
	 ^ tabsArray first! !

!TextStyle methodsFor: 'accessing' stamp: ''!
baseline
	"Answer the distance from the top of the line to the bottom of most of the 
	characters (by convention, bottom of the letter 'A')."

	^baseline! !

!TextStyle methodsFor: 'comparing' stamp: ''!
= other

	self species == other species ifFalse: [^ false].
	1 to: self class instSize do:
		[:i | (self instVarAt: i) == (other instVarAt: i) ifFalse: [^ false]].
	^ true! !

!TextStyle methodsFor: '*Text-Edition' stamp: ''!
addNewFontSizeDialog: args
	"This is called from a modal menu and call back the menu with entered argument."
	| f n r |
	f := UIManager default request: 'Enter the point size' initialAnswer: '12'.
	f ifNil: [f := String new].
	n := f asNumber.
	r := self addNewFontSize: n.
	r ifNotNil: [
		args second ifNotNil: [args second modalSelection: {args first. n}].
	].
! !

!TextStyle methodsFor: 'tabs and margins' stamp: ''!
leftMarginTabAt: marginIndex
	"Set the 'nesting' level of left margin indents of the paragraph in the 
	style of the receiver to be the argument, marginIndex."

	^ (marginIndex > 0 and: [ marginIndex < marginTabsArray size ])
		ifTrue: [ (marginTabsArray at: marginIndex) at: 1 ]
		ifFalse: [ "The marginTabsArray is an Array of tuples.  The Array is indexed according 
	to the marginIndex, the 'nesting' level of the requestor." 0 ]! !

!TextStyle methodsFor: 'accessing' stamp: ''!
restIndent
	"Answer the indent for all but the first line of a paragraph in the style 
	of the receiver."

	^restIndent! !

!TextStyle methodsFor: 'private' stamp: ''!
consolidate
	"If this style includes any fonts that are also in the default style,
	then replace them with references to the default ones."
	"
	TextStyle allInstancesDo: [:s | s == TextStyle default ifFalse: [s consolidate]]
"
	| defFonts font |
	defFonts := TextStyle default fontArray.
	1 
		to: fontArray size
		do: 
			[ :i | 
			font := fontArray at: i.
			1 
				to: defFonts size
				do: 
					[ :j | 
					(font familyName asUppercase copyWithout: $ ) = ((defFonts at: j) familyName asUppercase copyWithout: $ ) ifTrue: 
						[ fontArray 
							at: i
							put: (defFonts at: j) ] ] ]! !

!TextStyle methodsFor: 'private' stamp: ''!
gridForFont: fontIndex withLead: leadInteger 
	"Force whole style to suit one of its fonts. Assumes only one font referred
	to by runs."
	| font |
	font := self fontAt: fontIndex.
	self lineGrid: font height + leadInteger.
	self baseline: font ascent.
	self leading: leadInteger! !

!TextStyle methodsFor: 'accessing' stamp: ''!
baseline: anInteger 
	"Set the distance from the top of the line to the bottom of most of the 
	characters."
	baseline := anInteger! !

!TextStyle methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	fontArray first isFontSet ifTrue: [
		aStream space; nextPutAll: self defaultFont familySizeFace first; nextPutAll: '(FontSet)'
	] ifFalse: [
		aStream space; nextPutAll: self defaultFont familySizeFace first
	]
! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: ''!
fontOfSize: aHeight
	"See fontIndexOfSize.
	Returns the actual font.  Leading not considered."

	^ fontArray at: (self fontIndexOfSize: aHeight)! !

!TextStyle methodsFor: 'accessing' stamp: ''!
restIndent: anInteger 
	"Set the indent for all but the first line of a paragraph in the style of the 
	receiver to be the argument, anInteger."
	restIndent := anInteger! !

!TextStyle methodsFor: 'tabs and margins' stamp: ''!
nextTabXFrom: anX leftMargin: leftMargin rightMargin: rightMargin 
	"Tab stops are distances from the left margin. Set the distance into the 
	argument, anX, normalized for the paragraph's left margin."
	| normalizedX tabX |
	normalizedX := anX - leftMargin.
	1 
		to: tabsArray size
		do: 
			[ :i | 
			(tabX := tabsArray at: i) > normalizedX ifTrue: [ ^ leftMargin + tabX min: rightMargin ] ].
	^ rightMargin! !

!TextStyle methodsFor: 'private' stamp: ''!
fontAt: index 
	"This is private because no object outside TextStyle should depend on the 
	representation of the font family in fontArray."

	^ fontArray atPin: index! !

!TextStyle methodsFor: 'accessing' stamp: ''!
fontNamesAndSizes  "TextStyle default fontNames"
	^ fontArray collect: [:x | x familyName, ' ', x height printString]! !

!TextStyle methodsFor: 'accessing' stamp: ''!
alignmentSymbol
	"Answer the symbol for the current setting of the alignment."
	alignment = LeftFlush ifTrue:[^#leftFlush].
	alignment = Centered ifTrue:[^#centered].
	alignment = RightFlush ifTrue:[^#rightFlush].
	alignment = Justified ifTrue:[^#justified].
	^#leftFlush! !

!TextStyle methodsFor: '*Text-Edition' stamp: ''!
addNewFontSize: pointSize
	"Add a font in specified size to the array of fonts."
	| f d newArray t  |
	fontArray first emphasis ~= 0 ifTrue: [
		t := TextSharedInformation at: self fontArray first familyName asSymbol.
		t fonts first emphasis = 0 ifTrue: [
			^ t addNewFontSize: pointSize.
		].
	].

	pointSize <= 0 ifTrue: [^ nil].
	fontArray do: [:s |
		s pointSize = pointSize ifTrue: [^ s].
	].
	f := fontArray first class new initialize: fontArray first.
	f pointSize: pointSize.
	fontArray first derivativeFonts do: [:proto |
			proto ifNotNil: [
				d := proto class new initialize: proto.
				d pointSize: f pointSize.
				f derivativeFont: d mainFont: proto.
			].
	].
	newArray := ((fontArray copyWith: f) asSortedCollection: [:a :b | a pointSize <= b pointSize]) asArray.
	self newFontArray: newArray.
	^ self fontOfPointSize: pointSize
! !

!TextStyle methodsFor: 'private' stamp: ''!
newFontArray: anArray 
	"Currently there is no supporting protocol for changing these arrays. If an editor wishes to implement margin setting, then a copy of the default should be stored with these instance variables.  
	, Make size depend on first font."
	fontArray := anArray.
	lineGrid := (fontArray at: 1) height + leading.	"For whole family"
	baseline := (fontArray at: 1) ascent + leading.
	alignment := 0.
	firstIndent := 0.
	restIndent := 0.
	rightIndent := 0.
	tabsArray := DefaultTabsArray.
	marginTabsArray := DefaultMarginTabsArray
	"
TextStyle allInstancesDo: [:ts | ts newFontArray: TextStyle default fontArray].
"! !

!TextStyle methodsFor: 'private' stamp: ''!
marginTabAt: marginIndex side: sideIndex
	"The marginTabsArray is an Array of tuples.  The Array is indexed
	according to the marginIndex, the 'nesting' level of the requestor.
	sideIndex is 1 for left, 2 for right."

	^ (marginIndex > 0 and: [ marginIndex < marginTabsArray size ])
		ifTrue: [ (marginTabsArray at: marginIndex) at: sideIndex ]
		ifFalse: [ 0 ]! !

!TextStyle methodsFor: '*Text-Edition' stamp: ''!
isTTCStyle

	^ fontArray first isTTCFont.
! !

!TextStyle methodsFor: 'accessing' stamp: ''!
lineGrid
	"Answer the relative space between lines of a paragraph in the style of 
	the receiver."

	^lineGrid! !

!TextStyle methodsFor: 'default font' stamp: ''!
defaultFontIndex: anIndex 
	defaultFontIndex := anIndex! !

!TextStyle methodsFor: 'accessing' stamp: ''!
rightIndent
	"Answer the right margin indent for the lines of a paragraph in the style 
	of the receiver."

	^rightIndent! !

!TextStyle methodsFor: 'accessing' stamp: ''!
defaultFont
	^ fontArray at: self defaultFontIndex! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: ''!
fontIndexOfSize: desiredHeight 
	"Returns an index in fontArray of the font with height <= desiredHeight"
	"Leading is not inluded in the comparison"
	| bestMatch bestIndex d |
	bestMatch := 9999.
	bestIndex := 1.
	1 
		to: fontArray size
		do: 
			[ :i | 
			d := desiredHeight - (fontArray at: i) height.
			d = 0 ifTrue: [ ^ i ].
			(d > 0 and: [ d < bestMatch ]) ifTrue: 
				[ bestIndex := i.
				bestMatch := d ] ].
	^ bestIndex! !

!TextStyle methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier 
	"All inst vars are meant to be shared"

	self == #veryDeepCopyWith:.	"to satisfy checkVariables"
	^deepCopier references at: self ifAbsentPut: [self shallowCopy]	"remember"! !

!TextStyle methodsFor: 'accessing' stamp: ''!
centered
	alignment := 2! !

!TextStyle methodsFor: 'private' stamp: ''!
fontArray
	"Only for writing out fonts, etc."
	^ fontArray! !

!TextStyle methodsFor: 'accessing' stamp: ''!
alignment: anInteger 
	"Set the current setting of the alignment to be anInteger:
	0=left flush, 1=right flush, 2=centered, 3=justified."
	alignment := anInteger \\ (Justified + 1)! !

!TextStyle methodsFor: 'accessing' stamp: ''!
leftFlush
	alignment := 0! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: ''!
fontOfPointSize: aPointSize
	^ fontArray at: (self fontIndexOfPointSize: aPointSize)! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: ''!
consistOnlyOf: aFont 
	fontArray := Array with: aFont.
	defaultFontIndex := 1! !

!TextStyle methodsFor: 'accessing' stamp: ''!
alignment
	"Answer the code for the current setting of the alignment."

	^alignment! !

!TextStyle methodsFor: 'private' stamp: ''!
fontAt: index put: font 
	"Automatically grow the array."
	index > fontArray size ifTrue: [ fontArray := fontArray , (Array new: index - fontArray size) ].
	fontArray 
		at: index
		put: font! !

!TextStyle methodsFor: 'accessing' stamp: ''!
fonts
	"Return a collection of fonts contained in this text style"
	^fontArray! !

!TextStyle methodsFor: 'accessing' stamp: ''!
lineGrid: anInteger 
	"Set the relative space between lines of a paragraph in the style of the 
	receiver to be the argument, anInteger."
	lineGrid := anInteger! !

!TextStyle class methodsFor: 'instance creation' stamp: ''!
new
	^ super new leading: 2! !

!TextStyle class methodsFor: 'textconstants access' stamp: ''!
fontSizesFor: aName
	"Answer the pixel sizes for all the fonts in the given text style"

	"TextStyle fontSizesFor: 'Arial'"
	"TextStyle fontSizesFor: 'NewYork'"

	^ (self fontArrayForStyle: aName) collect: [:f | f height ]
! !

!TextStyle class methodsFor: 'utilities' stamp: ''!
decodeStyleName: styleName 
	"Given a string styleName, return a collection with: 
	 
	* [1] the probable Pharo emphasis code, which is a bit combination of: 
	1	bold 
	2	italic 
	4	underlined 
	8	narrow 
	16	strikeout 
	 
	* [2] the base style name without the modifiers (can be empty)
	* [3] the modifiers in the order they were found 
	* [4] the codes for those modifiers, in the same order
	"
	| decoder keys modifiers modifierCodes baseName styleCode matchedKey |

	decoder := self styleDecoder.

	modifiers := OrderedCollection new.
	modifierCodes := OrderedCollection new.
	keys := decoder keys asArray
				sort: [:a :b | a size > b size].
	styleCode := 0.
	baseName := styleName asString.
	[matchedKey := keys
				detect: [:k | baseName endsWith: k]
				ifNone: [].
	matchedKey notNil]
		whileTrue: [| last code | 
			last := baseName size - matchedKey size.
			last > 0
				ifTrue: [('- ' includes: (baseName at: last))
						ifTrue: [last := last - 1]].
			baseName := baseName copyFrom: 1 to: last.
			code := decoder at: matchedKey.
			styleCode := styleCode + code.
			modifiers addFirst: matchedKey.
			modifierCodes addFirst: code.
	].
	^ {styleCode. baseName. modifiers. modifierCodes }! !

!TextStyle class methodsFor: 'textconstants access' stamp: ''!
pointSizesFor: aName
	"Answer all the point sizes for the given text style name"

	"TextStyle pointSizesFor: 'NewYork'"
	^ (self fontArrayForStyle: aName) collect: [:f | f pointSize]
! !

!TextStyle class methodsFor: 'instance creation' stamp: ''!
fontArray: anArray 
	"Answer an instance of me with fonts those in the argument, anArray."

	^self new newFontArray: anArray! !

!TextStyle class methodsFor: 'constants' stamp: ''!
named: familyName 
	"Answer the TextStyle with the given name, or nil."
	"TextStyle named: 'NewYork'"
	| textStyle |
	textStyle := TextSharedInformation 
		at: familyName
		ifAbsent: [ ^ nil ].
	(textStyle isKindOf: self) ifFalse: [ ^ nil ].
	^ textStyle! !

!TextStyle class methodsFor: 'private - accessing' stamp: ''!
styleDecoder
	TextSharedInformation at: #StyleDecoder ifPresent: [ :dict | dict ifNotNil: [ ^dict ]].
	^TextSharedInformation at: #StyleDecoder put: (
		Dictionary new at: 'Regular' put: 0;
				 at: 'Roman' put: 0;
				 at: 'Medium' put: 0;
				 at: 'Light' put: 0;
				 at: 'Normal' put: 0;
				 at: 'Plain' put: 0;
				 at: 'Book' put: 0;
				 at: 'Demi' put: 0;
				 at: 'Demibold' put: 0;
				 at: 'Semibold' put: 0;
				 at: 'SemiBold' put: 0;
				 at: 'ExtraBold' put: 1;
				 at: 'SuperBold' put: 1;
				 at: 'B' put: 1;
				 at: 'I' put: 2;
				 at: 'U' put: 4;
				 at: 'X' put: 16;
				 at: 'N' put: 8;
				 at: 'Bold' put: 1;
				 at: 'Italic' put: 2;
				 at: 'Oblique' put: 2;
				 at: 'Narrow' put: 8;
				 at: 'Condensed' put: 8;
				 at: 'Underlined' put: 4;
				 yourself )! !

!TextStyle class methodsFor: 'constants' stamp: ''!
setDefault: aTextStyle
	"Answer the system default text style."

	TextSharedInformation at: #DefaultTextStyle put: aTextStyle.! !

!TextStyle class methodsFor: 'textconstants access' stamp: ''!
actualTextStyles
	"TextStyle actualTextStyles"
	"Answer dictionary whose keys are the names of styles in the system and whose values are the actual styles"
	| aDict |
	aDict := TextSharedInformation select: [ :thang | thang isKindOf: self ].
	self defaultFamilyNames do: [ :sym | aDict removeKey: sym ].
	^ aDict! !

!TextStyle class methodsFor: 'accessing' stamp: ''!
changed: anAspect

	self notifier changed: anAspect! !

!TextStyle class methodsFor: 'private - initialization' stamp: ''!
initializeStyleDecoder
	TextSharedInformation at: #StyleDecoder put: nil.
	self styleDecoder! !

!TextStyle class methodsFor: 'class initialization' stamp: ''!
initialize
	self initializeStyleDecoder! !

!TextStyle class methodsFor: 'textconstants access' stamp: ''!
defaultFamilyNames
	| DefaultTextStyle DefaultFixedTextStyle DefaultMultiStyle |

	DefaultTextStyle := TextSharedInformation at: #DefaultTextStyle.
	DefaultFixedTextStyle := TextSharedInformation at: #DefaultFixedTextStyle.
	DefaultMultiStyle := TextSharedInformation at: #DefaultMultiStyle.
	
	^#(DefaultTextStyle DefaultFixedTextStyle DefaultMultiStyle)! !

!TextStyle class methodsFor: '*Graphics-Fonts' stamp: ''!
pixelsPerInch: aNumber
  "Set the nominal number of pixels per inch to aNumber."
  TextSharedInformation at: #pixelsPerInch put: aNumber asFloat.
  self changed: #textDPIChanged.! !

!TextStyle class methodsFor: 'constants' stamp: ''!
defaultFont
	"Answer the default system font"

	^ self default defaultFont! !

!TextStyle class methodsFor: 'accessing' stamp: ''!
removeDependent: anObject

	self notifier removeDependent: anObject! !

!TextStyle class methodsFor: 'accessing' stamp: ''!
addDependent: anObject

	self notifier addDependent: anObject! !

!TextStyle class methodsFor: 'utilities' stamp: ''!
pixelsToPoints: pixels
	^pixels * 72.0 / self pixelsPerInch! !

!TextStyle class methodsFor: 'utilities' stamp: ''!
pixelsPerInch
	"Answer the nominal resolution of the screen."

	^TextSharedInformation at: #pixelsPerInch ifAbsentPut: [ 96.0 ].! !

!TextStyle class methodsFor: 'utilities' stamp: ''!
pointsToPixels: points
	^points * self pixelsPerInch / 72.0! !

!TextStyle class methodsFor: 'constants' stamp: ''!
default
  "Answer the system default text style."

  ^TextSharedInformation at: #DefaultTextStyle ifAbsent: nil! !

!TextStyle class methodsFor: 'accessing' stamp: ''!
notifier

	^ notifier ifNil: [ notifier := Model new ]! !

!TextStyle class methodsFor: 'textconstants access' stamp: ''!
knownTextStylesWithoutDefault
	"Answer the names of the known text styles, sorted in alphabetical order without default"

	"TextStyle knownTextStylesWithoutDefault"
	| result |
	result := self knownTextStyles asOrderedCollection.
	^ result copyWithoutAll: self defaultFamilyNames

! !

!TextStyle class methodsFor: 'textconstants access' stamp: ''!
knownTextStyles
	"Answer the names of the known text styles, sorted in alphabetical order"

	"TextStyle knownTextStyles"
	^ (TextSharedInformation select: [:thang | thang isKindOf: TextStyle]) keys sort

! !

!TextStyle class methodsFor: 'textconstants access' stamp: ''!
fontArrayForStyle: aName
	"Answer the fonts in the style named aName,
	or an empty Array if no such named style."

	"TextStyle fontArrayForStyle: #Atlanta"
	"TextStyle fontPointSizesFor: 'NewYork'"

	^ ((self named: aName) ifNil: [ ^#() ]) fontArray
! !

!TextStyle class methodsFor: '*FreeType-Morphic' stamp: ''!
emphasisMenuForFont: font target: target selector: selector highlight: currentEmphasis
	"Offer a font emphasis menu for the given style. If one is selected, pass that font to target with a call to selector. The fonts will be displayed in that font. Answer nil if no derivatives exist"

 	| aMenu derivs |
	derivs := font derivativeFonts.
	derivs isEmpty ifTrue: [ ^nil ].
	aMenu := UIManager default newMenuIn: self for: self.
	aMenu addTitle: 'emphasis'.
	derivs := derivs asOrderedCollection.
	derivs addFirst: font.
	derivs do: [ :df | 
			aMenu 
				add: df emphasisString
				target: target 
				selector: selector
				argument: df.
                aMenu lastItem font: df.
                df emphasis == currentEmphasis ifTrue: [aMenu lastItem color: Color blue darker]].
        ^ aMenu! !

!TextStyleAsFontFamily commentStamp: ''!
Text style as font family!
!TextStyleAsFontFamily methodsFor: 'accessing' stamp: ''!
textStyle
	"Answer the value of textStyle"

	^ textStyle! !

!TextStyleAsFontFamily methodsFor: 'accessing' stamp: ''!
textStyle: anObject
	"Set the value of textStyle"

	textStyle := anObject! !

!TextStyleAsFontFamily methodsFor: 'accessing' stamp: ''!
members

	^ members ifNil: [ 
		  members := #( 'Regular' 'Italic' 'Bold' 'Bold Italic' ) collect: [ 
			             :each | 
			             TextStyleAsFontFamilyMember new
				             family: self;
				             styleName: each;
				             yourself ] ]! !

!TextStyleAsFontFamilyMember commentStamp: ''!
TextStyleAsFont Family members!
!TextStyleAsFontFamilyMember methodsFor: 'LogicalFont emphasis' stamp: ''!
weightValue

	^ (styleName includesSubstring: 'Bold')
		  ifTrue: [ LogicalFont weightBold ]
		  ifFalse: [ LogicalFont weightRegular ]! !

!TextStyleAsFontFamilyMember methodsFor: 'LogicalFont emphasis' stamp: ''!
stretchValue

	^ (styleName includesSubstring: 'Condensed')
		  ifTrue: [ LogicalFont stretchCompressed ]
		  ifFalse: [ LogicalFont stretchRegular ]! !

!TextStyleAsFontFamilyMember methodsFor: 'LogicalFont emphasis' stamp: ''!
slantValue

	^ (styleName includesSubstring: 'Italic')
		  ifTrue: [ LogicalFont slantItalic ]
		  ifFalse: [ LogicalFont slantRegular ]! !

!TextStyleAsFontFamilyMember methodsFor: 'squeak emphasis' stamp: ''!
emphasisCode
	"Answer the squeak emphasis code (1=bold, 2=italic, 3=boldItalic etc"

	| answer |
	answer := 0.
	(styleName includesSubstring: 'Italic') ifTrue: [ 
		answer := answer bitOr: LogicalFont squeakSlantItalic ].
	(styleName includesSubstring: 'Condensed') ifTrue: [ 
		answer := answer bitOr: LogicalFont squeakStretchCondensed ].
	(styleName includesSubstring: 'Bold') ifTrue: [ 
		answer := answer bitOr: LogicalFont squeakWeightBold ].
	^ answer! !

!TextStyleAsFontFamilyMember methodsFor: 'comparing' stamp: ''!
<= aTextStyleAsFontFamilyMember

	| orderedItems |
	orderedItems := #( 'Condensed' 'Condensed Italic' 'Condensed Bold'
	                   'Condensed Bold Italic' 'Regular' 'Italic'
	                   'Bold' 'Bold Italic' ).
	^ (orderedItems indexOf: self styleName)
	  <= (orderedItems indexOf: aTextStyleAsFontFamilyMember styleName)! !

!TextTest commentStamp: ''!
A TextTest is a test class for testing the behavior of Text!
!TextTest methodsFor: 'tests' stamp: ''!
testFindStringStartingAtCaseSensitive
	self assert: (text findString: 'pharo' startingAt: 1 caseSensitive: false) equals: 1.
	self assert: (text findString: 'pharo' startingAt: 1 caseSensitive: true) equals: 0.

	self assert: (text findString: 'COOL' startingAt: 1  caseSensitive: false) equals: 10.
	self assert: (text findString: 'COOL' startingAt: 1  caseSensitive: true) equals: 0.

	! !

!TextTest methodsFor: 'tests' stamp: ''!
testHowManyMatch
	self assert: (text howManyMatch: 'Pharo') equals: 5.
	self assert: (text howManyMatch: 'Pha') equals: 3.
	self assert: (text howManyMatch: 'P') equals: 1.
	self assert: (text howManyMatch: 'p') equals: 0.
	self assert: (text howManyMatch: 'is') equals: 0.
	self assert: (text howManyMatch: 'cool') equals: 0.
! !

!TextTest methodsFor: 'tests' stamp: ''!
testString
	self assert: text string equals: 'Pharo is cool'! !

!TextTest methodsFor: 'tests' stamp: ''!
testTextReplacement2
	"For a Text t, the following assertion should always hold:
     	t string size = t run size 
    This test examines the preservation of this assertion for in-place replacement.
    Here, the replacement text has trailing characters."
	| replacement startPos length startPosInRep string2 |
	text := (string := 'This is simple text' copy) asText.
	"Without the copy, we would modify a constant that the compiler attached at the compiled method."
	startPos := string findString: 'simple'. 
	length := 'simple' size.
	replacement := (string2 := 'both simple and short*************') asText.
	startPosInRep :=  string2 findString: 'short'.
	text replaceFrom: startPos to: startPos + length - 1 with: replacement startingAt: startPosInRep.
	self assert: text string size equals: text runs size! !

!TextTest methodsFor: 'tests - error' stamp: ''!
testTextReplacement3
	"For a Text t, the following assertion should always hold:
		t string size = t run size 
	This test examines the preservation of this assertion for in-place replacement 
	Here, the replacement text is shorteer than the text that is shall replace."
	self should: [ self replacementExample3 ] raise: Error! !

!TextTest methodsFor: 'tests' stamp: ''!
testAtPut
	text at: 2 put: $H.
	text at: 3 put: $A.
	text at: 4 put: $R.
	text at: 5 put: $O.
	self assert: text string equals: 'PHARO is cool'! !

!TextTest methodsFor: 'tests' stamp: ''!
testExampleText1
	"Inspired by a bug report from Tim Olson.
	Text attributes are lost when the stream collection is expanded.
	Documented BUG!!!!!!"

    | text1 text2 atts1 atts2 |
	text1 := self example1: 10. " here we will loose the attribute bold "
	text2 := self example1: 50. " here we have a larger buffer and will not loose text attributes "
	atts1 := text1 runs copyFrom: 6 to: 10. 
	atts2 := text2 runs copyFrom: 6 to: 10. 

	self assert: atts1 equals: atts2
      ! !

!TextTest methodsFor: 'tests' stamp: ''!
testAsString
	self assert: text asString equals: 'Pharo is cool'

! !

!TextTest methodsFor: 'tests' stamp: ''!
testReplaceFromToWith
	| anotherText bold|
	bold := TextEmphasis bold.
	anotherText := 'hot' asText addAttribute: bold.
	text replaceFrom: 10 to: 13 with: anotherText.
	self assert: text string equals: 'Pharo is hot'.
	self assert: text size equals: 12.
	"check attribute is has expected"
	10 to: 12 do: [ :index | 
		| attr |
		attr := text attributesAt: index.
		self assert: attr size equals: 1.
		self assert: attr first equals: bold ]! !

!TextTest methodsFor: 'tests' stamp: ''!
testRangeOfStartingAt
	self assert: (text rangeOf: TextEmphasis bold startingAt: 1) equals: (1 to: 5).
	"even an index at beginning of the range, it returns the whole interval"
	self assert: (text rangeOf: TextEmphasis bold startingAt: 2) equals: (1 to: 5).
	self assert: (text rangeOf: TextEmphasis bold startingAt: 5) equals: (1 to: 5).
	"but not when index is outside the range"
	self deny: (text rangeOf: TextEmphasis bold startingAt: 6) equals: (1 to: 5).
	"search for alternate attribute works too"
	self assert: (text rangeOf: TextColor blue startingAt: 2) equals: (1 to: 5).
	"attributes with different range"
	self assert: (text rangeOf: TextColor red startingAt: 7) equals: (7 to: 13).
	self assert: (text rangeOf: TextEmphasis underlined startingAt: 7) equals: (7 to: 8).
	self assert: (text rangeOf: TextEmphasis underlined startingAt: 8) equals: (7 to: 8).
	self deny: (text rangeOf: TextEmphasis underlined startingAt: 5) equals: (7 to: 8).! !

!TextTest methodsFor: 'tests' stamp: ''!
testSize
	self assert: text size equals: 13! !

!TextTest methodsFor: 'tests' stamp: ''!
testTextEmphasisRangeDetection3
	"This tests the detection of the range of a text attribute.
    Here the searched attribute spans three runs. The the range to be detected begins at text position 	 1. The objective of the test is whether the entire range is always found."

	| startPos searchedStyle |
	text := 'This is a text with attriute bold for some characters' asText.
	startPos := text findString: 'bold' startingAt: 1.
	text addAttribute: TextEmphasis bold from: startPos to: startPos + 3.
	text addAttribute: TextEmphasis italic from: 1 to: startPos + 5.
	searchedStyle := TextEmphasis italic.

	"Uncomment the following statement to examine failures:"
 	"-----------------------
       (1 to: text size) do:
           [:idx | | range | 
              range := text rangeOf: searchedStyle startingAt: idx.
             Transcript show: startPos;
					show: ' -- ';
					show: idx printString;
					show: '  ';
					show: range printString;
					show: range size printString;
                        show: ' ';
					 show: ((idx between: 1 and: startPos + 5)
                  					ifTrue:
                  					  [range first = 1 & (range size = (startPos + 5))]
                					ifFalse:
                   					 [range first = idx & (range size = 0)]) printString; cr.
           ].
   ----------------------- "
	self assert: 
       ((1 to: text size) allSatisfy:
           [:idx | | range |
              range := text rangeOf: searchedStyle startingAt: idx.
              (idx between: 1 and: startPos + 5)
                  ifTrue:
                    [range first = 1 & (range size = (startPos + 5))]
                  ifFalse:
                    [range first = idx & range isEmpty]])! !

!TextTest methodsFor: 'tests' stamp: ''!
testTextReplacement1
	"For a Text t, the following assertion should always hold:
     t string size = t run size 
	This test examines the preservation of this assertion for in-place replacement"
   | replacement startPos length startPosInRep string2 |
   text := (string := 'This is a simple text' copy) asText.
   "Without the copy, we would modify a constant that the compiler attached at the compiled method."
   startPos := string findString: 'simple'. 
   length  := 'simple' size.
   replacement := (string2 := 'both simple and short*') asText.
   startPosInRep :=  string2 findString: 'short'.
   text replaceFrom: startPos to: startPos + length - 1 with: replacement startingAt: startPosInRep.
   self assert: text string size equals: text runs size! !

!TextTest methodsFor: 'tests - error' stamp: ''!
testRemoveAttribute
	"Removing attribute before the beginning"
	text := Text string: 'foo' attribute: TextColor red.
	self should: [ text removeAttribute: TextColor red from: 0 to: text size ] raise: Error.
	"Removing attribute after the end"
	text := Text string: 'foo' attribute: TextColor red.
	self should: [ text addAttribute: TextColor red from: 2 to: text size + 1 ] raise: Error! !

!TextTest methodsFor: 'examples' stamp: ''!
example2
	<sampleInstance>
	^(TextStream on: (Text new: 50))
		nextPutAll: 'abc' asText;
		nextPutAll: 'def' asText allBold;
		nextPutAll: 'ghijk' asText;
		contents! !

!TextTest methodsFor: 'tests' stamp: ''!
testReplacementAtStartPos1
	"For a Text t, the following assertion should always hold:
     t string size = t run size 
	This test examines the preservation of this assertion for in-place replacement"
	| replacement  length  |
	text := 'This is a simple text' copy asText.
	"Without the copy, we would modify a constant that the compiler attached at the compiled method."
	length := 'This' size.
	replacement := 'That' asText.
	text replaceFrom: 1 to: length with: replacement startingAt: 1.
	self assert: text string size equals: text runs size! !

!TextTest methodsFor: 'tests' stamp: ''!
testAppend
	| receiver argument result expectedResult |
	"Append text without attribute"
	receiver := 'xxx' asText addAttribute: TextEmphasis bold from: 1 to: 3.
	argument := 'yyy'.
	expectedResult := 'xxxyyy' asText addAttribute: TextEmphasis bold from: 1 to: 3.
	result := receiver append: argument.
	self assert: result identicalTo: receiver.
	self assert: result string equals: expectedResult string.
	self assert: result runs equals: expectedResult runs.

	"Append text with attribute"
	receiver := 'xxx' asText addAttribute: TextEmphasis bold from: 1 to: 3.
	argument := 'yyy' asText addAttribute: TextEmphasis italic from: 1 to: 3.
	result := receiver append: argument.
	expectedResult := 'xxxyyy' asText
		addAttribute: TextEmphasis bold from: 1 to: 3;
		addAttribute: TextEmphasis italic from: 4 to: 6.
	self assert: result identicalTo: receiver.
	self assert: result string equals: expectedResult string.
	self assert: result runs equals: expectedResult runs! !

!TextTest methodsFor: 'examples' stamp: ''!
replacementExample3
  "For a Text t, the following assertion should always hold:
     t string size = t run size 
   This test examines the preservation of this assertion for in-place replacement 
   Here, the replacement text is shorteer than the text that is shall replace."
   | replacement startPos length startPosInRep string2 |
   text := (string := 'This is again simple text' copy) asText.
   "Without the copy, we would modify a constant that the compiler attached at the compiled method."
   startPos := string findString: 'simple'. 
   length  := 'simple' size.
   replacement := (string2 := 'both simple and short') asText.
   startPosInRep :=  string2 findString: 'short'.
   text replaceFrom: startPos to: startPos + length - 1 with: replacement startingAt: startPosInRep! !

!TextTest methodsFor: 'tests - error' stamp: ''!
testAddAttributeFromTo
	"Adding attributes before begining"
	text := 'foo' asText.
	self should: [ text addAttribute: TextColor red from: 0 to: text size ] raise: Error.
	"Adding attribute after the end"
	text := 'foo' asText.
	self should: [ text addAttribute: TextColor red from: 2 to: text size + 1 ] raise: Error! !

!TextTest methodsFor: 'tests' stamp: ''!
testFindStringStartingAt
	self assert: (text findString: 'Pharo' startingAt: 1) equals: 1.
	self assert: (text findString: 'cool' startingAt: 1) equals: 10.
	self assert: (text findString: 'Pharo' startingAt: 2) equals: 0.
	! !

!TextTest methodsFor: 'tests - error' stamp: ''!
testSettingRunsOfWrongSize
	|  newRuns |
	newRuns := text runs copyReplaceFrom: 2 to: 1 with: (Array with: TextColor red).
	self should: [text runs: newRuns] raise: Error! !

!TextTest methodsFor: 'tests' stamp: ''!
testIncludesSubstringCaseSensitive
	"Test that Text correctly checks that the supplied substring is present,
	 both case sensitive and case insensitive."
	self deny: ('test this string' asText includesSubstring: 'Ring' caseSensitive: true).
	self assert: ('test this string' asText includesSubstring: 'Ring' caseSensitive: false).
	self deny: ('123éàôüöß' asText includesSubstring: '' caseSensitive: false).
	self assert: ('123éàôüöß' asText includesSubstring: 'öß' caseSensitive: true).
	self assert: ('123éàôüöß' asText includesSubstring: 'ÀÔ' caseSensitive: false)! !

!TextTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	string := 'Pharo is cool'.
	text :=  string copy asText.
	text addAttribute: TextEmphasis bold from: 1 to: 5.
	text addAttribute: TextColor blue from: 1 to: 5.
	text addAttribute: TextEmphasis underlined from: 7 to: 8.
	text addAttribute: TextColor red from: 7 to: 13.! !

!TextTest methodsFor: 'tests' stamp: ''!
testTextEmphasisRangeDetection1
	"This tests the detection of the range of a text attribute."
	| startPos boldStyle |
	text := 'This is a text with attriute bold for some characters' asText.
	startPos := text findString: 'bold' startingAt: 1.
	text addAttribute: TextEmphasis bold from: startPos to: startPos + 3.
	boldStyle := TextEmphasis bold.

  "Uncomment the following statement for examine failures:"
  "-----------------
       (1 to: text size) do:
           [:idx | | range |
              range := text rangeOf: boldStyle startingAt: idx.
             Transcript show: startPos; show: ' -- '; show: idx printString; show: '  '; show: range printString; show: range size printString; show: ((idx between: startPos and: startPos + 3)
                  ifTrue:
                    [range first = startPos & (range size = 4)]
                  ifFalse:
                    [range first = idx & (range size = 0)]) printString; cr.
           ].
    ------------- "

	self assert: 
		((1 to: text size) allSatisfy:
			[:idx | | range |
				range := text rangeOf: boldStyle startingAt: idx.
				(idx between: startPos and: startPos + 3)
					ifTrue: [range first = startPos & (range size = 4)]
					ifFalse: [range first = idx & range isEmpty]])! !

!TextTest methodsFor: 'tests' stamp: ''!
testPrepend
	| receiver argument result expectedResult |
	"Prepend text without attribute"
	receiver := 'xxx' asText addAttribute: TextEmphasis bold from: 1 to: 3.
	argument := 'yyy'.
	expectedResult := 'yyyxxx' asText addAttribute: TextEmphasis bold from: 4 to: 6.
	result := receiver prepend: argument.
	self assert: result identicalTo: receiver.
	self assert: result string equals: expectedResult string.
	self assert: result runs equals: expectedResult runs.

	"Prepend text with attribute"
	receiver := 'xxx' asText addAttribute: TextEmphasis bold from: 1 to: 3.
	argument := 'yyy' asText addAttribute: TextEmphasis italic from: 1 to: 3.
	expectedResult := 'yyyxxx' asText
		addAttribute: TextEmphasis italic from: 1 to: 3;
		addAttribute: TextEmphasis bold from: 4 to: 6.
	result := receiver prepend: argument.
	self assert: result identicalTo: receiver.
	self assert: result string equals: expectedResult string.
	self assert: result runs equals: expectedResult runs! !

!TextTest methodsFor: 'tests' stamp: ''!
testAt 
	string withIndexDo: [ :char :index |
		self assert: (text at: index) equals: char]! !

!TextTest methodsFor: 'tests' stamp: ''!
testUnembellished
	| anotherText |
	self deny: text unembellished.
	anotherText := 'Hello' asText 
		addAttribute: TextEmphasis bold.
	self assert: anotherText unembellished.
	anotherText addAttribute: TextFontChange font2.
	self deny: anotherText unembellished.
! !

!TextTest methodsFor: 'tests - error' stamp: ''!
testReplacementAtStartPos3
	"For a Text t, the following assertion should always hold:
		t string size = t run size 
	This test examines the preservation of this assertion for in-place replacement 
	Here, the replacement text is shorter than the text that is shall replace."
   |  replacement  length  |
   text := 'This is a simple text' copy asText.
   "Without the copy, we would modify a constant that the compiler attached at the compiled method."
   length  := 'This' size.
   replacement := 'Thy' asText.
  self should: [ text replaceFrom: 1 to: length with: replacement startingAt: 1] raise: Error! !

!TextTest methodsFor: 'tests' stamp: ''!
testLineCount
	text := Text streamContents: [:str | str << 'Pharo' << Character cr << 'is' << Character cr << 'cool'].
	self assert: text lineCount equals: 3
	! !

!TextTest methodsFor: 'tests' stamp: ''!
testAsNumber
	self assert: '123' asText asNumber equals: 123.
	self assert: '1.23e2' asText asNumber equals: 123.
	self assert: '2r1000' asText asNumber equals: 8.

! !

!TextTest methodsFor: 'tests' stamp: ''!
testTextEmphasisRangeDetection4
	"This tests the detection of the range of a text attribute.
	 Here the searched attribute spans three runs. The the range to be detected extends to 
	 the end of the text . The objective of the test is whether the entire range is always found."

	| startPos searchedStyle |
	text := 'This is a text with attriute bold for some characters' asText.
	startPos := text findString: 'bold' startingAt: 1.
	text addAttribute: TextEmphasis bold from: startPos to: startPos + 3.	
	text addAttribute: TextEmphasis italic from: startPos - 2 to: text size.
	searchedStyle := TextEmphasis italic.

	"Uncomment the following statement to examine failures:"
 	"-----------------------------------------
       (1 to: text size) do:
           [:idx | | range | 
              range := text rangeOf: searchedStyle startingAt: idx.
             Transcript show: startPos;
					show: ' -- ';
					show: idx printString;
					show: '  ';
					show: range printString;
					show: range size printString;
                        show: ' ';
					 show: ((idx between: startPos - 2 and: text size)
                  			ifTrue:
   			                 [range first = (startPos - 2) & (range size = (text size - (startPos - 2) + 1))]
                  			ifFalse:
 			                 [range first = idx & (range size = 0)]) printString;
					cr.
           ].
   -------------------------------"

	self assert: 
       ((1 to: text size) allSatisfy:
           [:idx | | range |
              range := text rangeOf: searchedStyle startingAt: idx.
              (idx between: startPos - 2 and: text size)
                  ifTrue: [range first = (startPos - 2) & (range size = (text size - (startPos - 2) + 1))]
                  ifFalse: [range first = idx & range isEmpty]])! !

!TextTest methodsFor: 'tests' stamp: ''!
testIncludesSubstring
	"Test that Text correctly checks that the supplied substring is present (case sensitive)."
	self assert: ('testing this string' asText includesSubstring: 'ring').
	self assert: ('éèàôüößäóñíá' asText includesSubstring: '').
	self deny: ('éèàôüößäóñíá' asText includesSubstring: 'a').
	self assert: ('éèàôüößäóñíá' asText includesSubstring: 'ßä').
	self deny: ('kjdsnlksjdf' asText includesSubstring: 'K')! !

!TextTest methodsFor: 'tests' stamp: ''!
testExampleText2
	"a Text looses its attributes when it is reversed "
	
	| text1 text2 |
	text1 := self example2.
	text2 := text1 reversed reversed.
	self assert: text1 runs equals: text2 runs
 
! !

!TextTest methodsFor: 'tests' stamp: ''!
testRuns
	| attributes |
	attributes := RunArray new: 13 withAll: TextColor red.
	text runs: attributes.
	
	attributes := RunArray new: 12 withAll: TextColor red.
	self should: [ text runs: attributes ] raise: Error.

	attributes := RunArray new: 14 withAll: TextColor red.
	self should: [ text runs: attributes ] raise: Error.! !

!TextTest methodsFor: 'tests' stamp: ''!
testGtDisplayOn

	| hello exp res |
	hello := 'Hello Pharo' asText.
	exp := String streamContents: [:s | hello printOn: s].
	res := String streamContents: [:s | hello displayStringOn: s].
	self assert: res equals: exp.! !

!TextTest methodsFor: 'examples' stamp: ''!
example1: size
	<sampleInstance>
	^(TextStream on: (Text new: size))
		nextPutAll: 'xxxxx' asText;
		nextPutAll: 'yyyyy' asText allBold;
		nextPutAll: 'zzzzzzz' asText;
		contents! !

!TextTest methodsFor: 'tests' stamp: ''!
testAdjacentRunsWithIdentitcalAttributes
	"This test verifies that adjacent runs with identical attributes are coalesced."

	| ts rangeOfBold |
	ts := TextStream on: (Text new: 50).
	ts nextPutAll: 'abc' asText.
	ts nextPutAll: 'def' asText allBold.
	ts nextPutAll: 'ghijk'.
	text := ts contents.
	rangeOfBold := text find:  TextEmphasis bold.
	text removeAttribute: TextEmphasis bold from: rangeOfBold first to: rangeOfBold last. 
   "Now, check that only one run is left and that it has the correct size."
	self assert: text runs runs size = 1 & (text runs size = text string size)
! !

!TextTest methodsFor: 'tests' stamp: ''!
testReplacementAtStartPos2
  	"For a Text t, the following assertion should always hold:
     t string size = t run size 
	 This test examines the preservation of this assertion for in-place replacement."
	| replacement  length  |
	text := 'This is a simple text' copy asText.
	"Without the copy, we would modify a constant that the compiler attached at the compiled method."
	length  := 'This' size.
	replacement := 'That********' asText.
	text replaceFrom: 1 to: length with: replacement startingAt: 1.
	self assert: text string size equals: text runs size! !

!TextTest methodsFor: 'tests' stamp: ''!
testTextEmphasisRangeDetection2
	"This tests the detection of the range of a text attribute.
	 Here the searched attribute spans three runs. The objective of the test is whether the entire
	 range is always found."
	| startPos searchedStyle |
	text := 'This is a text with attriute bold for some characters' asText.
	startPos := text findString: 'bold' startingAt: 1.
	text addAttribute: TextEmphasis bold from: startPos to: startPos + 3.
	text addAttribute: TextEmphasis italic from: startPos - 2 to: startPos + 5.
	searchedStyle := TextEmphasis italic.

  "uncomment the following statement for examine failures: " 
  "-----------------------
       (1 to: text size) do:
           [:idx | | range | 
              range := text rangeOf: searchedStyle startingAt: idx.
             Transcript show: startPos; show: ' -- '; show: idx printString; show: '  '; show: range printString; show: range size printString; show: ((idx between: startPos - 2 and: startPos -2 + 7)
                  ifTrue:
                    [range first = (startPos - 2) & (range size = 8)]
                  ifFalse:
                    [range first = idx & (range size = 0)]) printString; cr.
           ].
   ----------------------- "
	self assert: 
			((1 to: text size) allSatisfy:
				[:idx | | range |
					range := text rangeOf: searchedStyle startingAt: idx.
					(idx between: startPos - 2 and: startPos -2 + 7)
						ifTrue: [range first = (startPos - 2) & (range size = 8)]
						ifFalse: [range first = idx & range isEmpty]])! !

!TextURL commentStamp: ''!
I'm a text attribute used to encode an URL.

TextMorph new 
	newContents: ('Visit Pharo' asText addAttribute: (TextURL new url: 'http://pharo.org')) ;
	openInWindow.!
!TextURL methodsFor: 'accessing' stamp: ''!
url: aString
	url := aString! !

!TextURL methodsFor: 'evaluating' stamp: ''!
actOnClick: anEvent for: anObject in: paragraph editor: editor
	self notify: 'Please configure the actOnClickBlock to invoke the computation you need. In Pharo by default there is no external web browser'.
! !

!TextURL methodsFor: 'testing' stamp: ''!
analyze: aString

	| list |
	list := super analyze: aString.
	url := list at: 1.
	^ list at: 2! !

!TextURL methodsFor: 'accessing' stamp: ''!
info
	^ url! !

!TextURL class methodsFor: 'instance creation' stamp: ''!
scanFrom: strm
	"Read a link in the funny format used by Text styles on files."

	^ self new url: (strm upTo: $;)! !

!TextVariableLink commentStamp: ''!
An active link in a text linking to a variable!
!TextVariableLink methodsFor: 'comparing' stamp: ''!
= anotherObject

	^super = anotherObject and: [ variableName = anotherObject variableName ]! !

!TextVariableLink methodsFor: 'comparing' stamp: ''!
hash

	^(super hash + variableName hash) hashMultiply ! !

!TextVariableLink methodsFor: 'accessing' stamp: ''!
variableName: aString
	variableName := aString! !

!TextVariableLink methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubActOnClick: anEvent for: aNautilusUI in: aParagraph editor: anEditor
	anEditor editor referencesTo: self variableName.
	^ true! !

!TextVariableLink methodsFor: '*Text-Edition' stamp: ''!
actOnClick: anEvent for: aNautilusUI in: aParagraph editor: anEditor
	anEditor referencesTo: self variableName.
	^ true! !

!TextVariableLink methodsFor: 'accessing' stamp: ''!
variableName
	^ variableName! !

!TextVariableLink class methodsFor: 'instance creation' stamp: ''!
variableName: aSymbol
	^ self new
		variableName: aSymbol;
		yourself! !

!TheManifestBuilder commentStamp: ''!
I'm a tool to build manifest that handles small lint false positive and other information.

My name is strange but this is to avoid to match with a Manifest class which is recognized because it starts with Manifest*.
!
!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
dateOfTruePositive: aItem onRule: ruleId version: versionId

	(self hasTruePositiveOf: ruleId version: versionId)
		ifFalse: [^ self].
	^ self dateOf: ( aItem asRingDefinition) forSelector:  (self selectorTruePositiveOf: ruleId version: versionId)! !

!TheManifestBuilder methodsFor: '*Renraku' stamp: ''!
bansRule: aRule for: anEntity
	| ruleId number |
	ruleId := aRule class uniqueIdentifierName.
	number := aRule class identifierMinorVersionNumber.
	
	^ self
		containsFalsePositive: anEntity
		onRule: ruleId
		version: number! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
packageNameOf: elem
	^ elem package name! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
toDoOf: ruleId version: versionId 

	^ self unwrap: (self manifest perform: (self selectorToDoOf: ruleId version: versionId))! !

!TheManifestBuilder methodsFor: 'comparing' stamp: ''!
hash
	^ manifestClass hash bitXor: self class hash! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
selectorToDoOf: ruleId version: versionId

	^ (self class toDoBeginningTag, ruleId ,
		self class toDoMiddleTag, versionId asString,
		self class toDoEndTag) asSymbol.! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
createManifestOf: elem

	self createManifestNamed: (self packageNameOf: elem).! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
truePositiveOf: ruleId version: versionId 

	^ self unwrap: (self manifest perform: (self selectorTruePositiveOf: ruleId version: versionId))! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
containsRejectedClass: aClass
	
	^ self rejectClasses anySatisfy: [ :cl | cl = aClass ]! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
removeItem: fp selector: selector
	self removeAllItem: {fp} selector: selector! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
hasToDoOf: ruleId version: versionId
	^ self manifest respondsTo: (self selectorToDoOf: ruleId version: versionId)! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
addAllItem: aSet selector: selector
	| set newSet arrayString |
	set := (self manifest 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.
	self compileSelector: selector returnValue: arrayString! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
rejectClasses
	^ self unwrap: (self manifest rejectClasses)! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
dateOf: ringobject forSelector: aSelector

	| critics |

	critics := self manifest perform: aSelector.
	^ ((critics detect: [:each | ((self definitionClassFor: each first first) manifestReadOn: (each first at: 2)) = ringobject ]) at: 2) asDateAndTime! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
definitionClassFor: aName

	"find Ring definition for a given name. Handle classes renamings"
	
	| finalName |
	
	finalName := (aName = #RGPackage)
		ifTrue: [ #RGPackageDefinition ]
		ifFalse: [ aName ].

	^ self browsedEnvironment at: finalName! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
falsePositiveOf: ruleId version: versionId 

	^ self unwrap: (self manifest perform: (self selectorFalsePositiveOf: ruleId version: versionId))! !

!TheManifestBuilder methodsFor: 'accessing' stamp: ''!
manifest
	^ manifestClass! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
removeObsoleteFalsePositiveOf: aMethod

	| set arrayString  |
	set := (self manifest perform: aMethod selector) asOrderedCollection.
	set := set select: [ :each | ((self definitionClassFor: each first first) manifestReadOn:  (each first at: 2)) isDefined ].
	arrayString := self buildArrayString: set.
	self compileSelector: aMethod selector returnValue: arrayString! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
addRejectRule: ruleId 

	|  nfp |	
	nfp := self manifest rejectRules asSet.
	nfp add: ruleId.
	nfp := nfp asArray.
	self compileSelector: (self class rejectRulesTag) returnValue: nfp asString! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
removeFalsePositive: fp of: ruleId version: versionId
	
	| selector |
	selector := self selectorFalsePositiveOf: ruleId version: versionId. 
	self removeItem: fp selector: selector.! !

!TheManifestBuilder methodsFor: '*Tool-DependencyAnalyser-UI' stamp: ''!
addManuallyResolvedDependency: aPackageName
	| packageNames |	
	
	packageNames := self manifest manuallyResolvedDependencies asSet.
	packageNames add: aPackageName asSymbol.
	packageNames := packageNames asArray.
	self 
		compileSelector: #manuallyResolvedDependencies
		returnValue: packageNames asString
		classified: 'meta-data - dependency analyser'! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
createManifestNamed: packageName

	manifestClass := self class classInstaller make: [ :aBuilder |
		aBuilder name: (self class manifestClassNameFor: packageName);
			superclass: PackageManifest;
			package: packageName ].
	 
	manifestClass 
		tagWith: self class manifestTag;
		comment: self class manifestClassComment.
	^ manifestClass! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
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 ]! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
removeToDo: fp of: ruleId version: versionId
	
	| selector |
	selector := self selectorToDoOf:ruleId version: versionId. 
	self removeItem: fp selector: selector.! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
resetFalsePositiveOf: ruleId version: versionId
 
	self  installFalsePositiveOf: ruleId version: versionId.! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
dateOfToDo: aItem onRule: ruleId version: versionId
	
	 (self hasToDoOf: ruleId version: versionId)
		ifFalse: [^ self].
	^ self dateOf: ( aItem asRingDefinition) forSelector:  (self selectorToDoOf: ruleId version: versionId)! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
installFalsePositiveOf: ruleId version: versionId

	self compileSelector: (self selectorFalsePositiveOf: ruleId version: versionId) returnValue: '#()'! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
compileSelector: selector returnValue: aLiteral classified: aProtocolName
	| source |
	source := String streamContents: [ :stream | 
		stream 
			nextPutAll: selector asString;
			nextPut: Character cr;
			nextPut: Character tab;
			nextPutAll: '^ ';
			nextPutAll: aLiteral ].
	manifestClass class
		compile: source
		classified: aProtocolName! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
selectorTruePositiveOf: ruleId version: versionId

	^ (self class falsePositiveBeginningTag, ruleId ,
		self class falsePositiveMiddleTag, versionId asString,
		self class truePositiveEndTag) 
		asSymbol.! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
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.
			stream  nextPutAll: ') '.].
		stream << ')']! !

!TheManifestBuilder methodsFor: 'comparing' stamp: ''!
= aObject

	^ aObject class = self class and: [ self manifest = aObject manifest ]! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
addItem: fp selector: selector
	self addAllItem: {fp} selector: selector! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
removeAllToDo: fp of: ruleId version: versionId
	
	| selector |
	selector := self selectorToDoOf: ruleId version: versionId. 
	self removeAllItem: fp selector: selector.! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
removeManifestOf: aItem
	
	(self manifestOf: aItem) ifNotNil: [ :myManifest | 
			self removeClass: myManifest  ]! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
containsToDo: aItem onRule: ruleId version: versionId

	^  (self hasToDoOf: ruleId version: versionId) 
		and: [(self toDoOf: ruleId version: versionId) 
			anySatisfy: [ :fp| fp = aItem ]]! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
dateOfFalsePositive: aItem onRule: ruleId version: versionId

	(self hasFalsePositiveOf: ruleId version: versionId)
		ifFalse: [^ self].
		
	^ self dateOf: ( aItem asRingDefinition) forSelector:  (self selectorFalsePositiveOf: ruleId version: versionId)! !

!TheManifestBuilder methodsFor: 'accessing' stamp: ''!
browsedEnvironment
	^manifestClass environment! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
containsFalsePositive: aItem onRule: ruleId version: versionId

	^  (self hasFalsePositiveOf: ruleId version: versionId) 
			and: [ (self falsePositiveOf: ruleId version: versionId) anySatisfy: [ :fp | fp = aItem ]]! !

!TheManifestBuilder methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream
		nextPutAll: 'ManifestBuilder of ';
		print: manifestClass .! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
removeAllManifest
 
	self removeClasses: (self class allManifestClasses)! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
selectorFalsePositiveOf: ruleId version: versionId

	^ (self class falsePositiveBeginningTag, ruleId,
		self class falsePositiveMiddleTag, versionId asString,
		self class falsePositiveEndTag) 
			asSymbol.! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
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].! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
removeRejectRule: ruleId 

	|  nfp |	
	nfp := self manifest rejectRules asOrderedCollection.
	nfp remove: ruleId ifAbsent: [^ self].
	nfp := nfp asArray.
	self compileSelector: (self class rejectRulesTag) returnValue:   nfp asString! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
removeAllItem: aSet selector: selector
	| set arrayString |
	set := (self manifest perform: selector) asOrderedCollection.
	set := set
		reject: [ :each | 
			| tmp |
			tmp := (self definitionClassFor: each first first) manifestReadOn: (each first at: 2).
			aSet anySatisfy: [ :fp | tmp = fp asRingDefinition ] ].
	arrayString := self buildArrayString: set.
	self compileSelector: selector returnValue: arrayString! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
isFalsePositive: anItem onRule: ruleId version: versionId
	
	^ ((self containsFalsePositive: anItem onRule: ruleId version: versionId) or:
			[(self containsRejectedRule: ruleId) or:
				[(anItem class = RPackage) not and: [self containsRejectedClass: anItem criticClass]]])! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
unwrap: aCollection

	| unwrapCollection rgobject |
	
	unwrapCollection := OrderedCollection new.
	aCollection
		do: [ :each | 
			rgobject := (self definitionClassFor: 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 ].
			(rgobject isPackage and: [ rgobject realPackage notNil ])
				ifTrue: [ unwrapCollection add: rgobject realPackage ] ].
	^ unwrapCollection! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
rejectRules
	^ self manifest rejectRules! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
hasFalsePositiveOf: ruleId version: versionId
	^ self manifest respondsTo: (self selectorFalsePositiveOf: ruleId version: versionId)! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
addAllFalsePositive: fp of: ruleId version: versionId

	| selector  |	
	selector := self selectorFalsePositiveOf: ruleId version: versionId. 
	self addAllItem: fp selector: selector.
	fp do: [:each |
		 (self containsToDo: each onRule: ruleId version: versionId)
		ifTrue: [ self removeToDo: each of:  ruleId version: versionId ]]! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
hasTruePositiveOf: ruleId version: versionId
	^ self manifest respondsTo: (self selectorTruePositiveOf: ruleId version: versionId)! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
addRejectClass: aClass

	|  falsePositives |
	falsePositives := self manifest rejectClasses asOrderedCollection .
	((self unwrap: falsePositives) anySatisfy: [:each | each = aClass])
		ifTrue: [ ^ self ].
	falsePositives add: {aClass asRingDefinition arrayStringForManifest. DateAndTime current asString}.
	self compileSelector:  (self class rejectClassesTag) returnValue: (self buildArrayString: falsePositives)! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
installToDoOf: ruleId version: versionId

	self compileSelector: (self selectorToDoOf: ruleId version: versionId) returnValue: '#()'! !

!TheManifestBuilder methodsFor: 'accessing' stamp: ''!
manifestClass: aClass
	 manifestClass := aClass! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
installTruePositiveOf: ruleId version: versionId
	
	self compileSelector: (self selectorTruePositiveOf: ruleId version: versionId) returnValue: '#()'! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
addAllToDo: aSet of: ruleId version: versionId

	| selector |
	selector := self selectorToDoOf: ruleId version: versionId. 
	self addAllItem: aSet selector: selector.! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
removeRejectClass: aClass

	|  classes |
	classes :=  self manifest rejectClasses asOrderedCollection.
	classes := classes reject: [ :each | 
			((self definitionClassFor: each first first) manifestReadOn:  (each first at: 2)) =  aClass asRingDefinition ].	
	self compileSelector: (self class rejectClassesTag) returnValue:  (self buildArrayString: classes)! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
containsRejectedRule: aRuleId
	
	^ self rejectRules anySatisfy: [ :fp | fp = aRuleId ]! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
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 ]! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
resetToDoOf: ruleId version: versionId
 	
	self installToDoOf: ruleId version: versionId.! !

!TheManifestBuilder methodsFor: 'accessing' stamp: ''!
manifestOf: elem
	^ manifestClass := elem package ifNotNil: [ :package | package packageManifestOrNil ]! !

!TheManifestBuilder methodsFor: '*Renraku' stamp: ''!
banRule: aRule for: anEntity
	| ruleId number |
	ruleId := aRule class uniqueIdentifierName.
	number := aRule class identifierMinorVersionNumber.

	(self hasFalsePositiveOf: ruleId version: number) ifFalse: [ 
		self installFalsePositiveOf: ruleId version: number ].
	
	self
		addFalsePositive: anEntity
		of: ruleId
		version: number! !

!TheManifestBuilder methodsFor: 'private' stamp: ''!
compileSelector: selector returnValue: aLiteral
	self 
		compileSelector: selector
		returnValue: aLiteral
		classified: 'code-critics'! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
cleanUp

	| tagfp |
	tagfp := self class falsePositiveBeginningTag.
	self manifest class methodsDo: [ :method |
		(method selector asString beginsWith: tagfp)
				ifTrue: [self removeObsoleteFalsePositiveOf: method] ]! !

!TheManifestBuilder methodsFor: 'manifest' stamp: ''!
containsTruePositive: aItem onRule: ruleId version: versionId

	^  (self hasTruePositiveOf: ruleId version: versionId) 
		and: [(self truePositiveOf: ruleId version: versionId) anySatisfy: [ :fp| fp = aItem ]]! !

!TheManifestBuilder methodsFor: 'adding/removing' stamp: ''!
removeAllFalsePositive: aSet of: ruleId version: versionId

	| selector |
	selector := self selectorFalsePositiveOf:ruleId version: versionId. 
	self removeAllItem: aSet selector: selector.! !

!TheManifestBuilder class methodsFor: 'instance creation' stamp: ''!
ofPackageNamed: aPackageName
	| builder |
	builder := self new.
	self allManifestClasses
		detect: [ :each | each category = aPackageName ]
		ifFound: [ :manifestClass | builder manifestClass: manifestClass ]
		ifNone: [ builder createManifestNamed: aPackageName ].
	^ builder! !

!TheManifestBuilder class methodsFor: 'instance creation' stamp: ''!
hasPackageNamed: aPackageName

	^ self allManifestClasses 
		anySatisfy: [:each | each category = aPackageName  ]! !

!TheManifestBuilder class methodsFor: 'accessing' stamp: ''!
allManifestClasses

	^ PackageManifest subclasses! !

!TheManifestBuilder class methodsFor: 'accessing - manifest' stamp: ''!
manifestTag
	"Return a string that serves as a tag within a package for Manifest classes"
	
	^ 'Manifest'! !

!TheManifestBuilder class methodsFor: 'accessing - tags' stamp: ''!
toDoMiddleTag
	"the string that identifies uniquely the middle of a selector who give  the set of TODO for a rule"
	
	^ 'V'! !

!TheManifestBuilder class methodsFor: 'instance creation' stamp: ''!
of: aItem
	| mb  |

	mb := self new. 
	(mb manifestOf: aItem) 
			ifNil: [mb createManifestOf: aItem].	
	^ mb! !

!TheManifestBuilder class methodsFor: 'accessing - tags' stamp: ''!
truePositiveEndTag
	"the string that identifies uniquely the end of a selector who give  the set of false positive for a rule"
	
	^ 'TruePositive'! !

!TheManifestBuilder class methodsFor: 'accessing - tags' stamp: ''!
falsePositiveMiddleTag
	"the string that identifies uniquely the middle of a selector who give  the set of false positive for a rule"
	
	^ 'V'! !

!TheManifestBuilder class methodsFor: 'accessing - manifest' stamp: ''!
manifestClassComment
	
	^ 'Please describe the package using the class comment of the included manifest class. The manifest class also includes other additional metadata for the package. These meta data are used by other tools such as the SmalllintManifestChecker and the critics Browser'! !

!TheManifestBuilder class methodsFor: 'accessing - tags' stamp: ''!
rejectClassesTag
	"the string that identifies uniquely the beginning of a selector who give  the set of rejected classes"
	
	^ 'rejectClasses'! !

!TheManifestBuilder class methodsFor: 'accessing - tags' stamp: ''!
rejectRulesTag
	"the string that identifies uniquely the beginning of a selector who give  the set of rejected rules"
	
	^ 'rejectRules'! !

!TheManifestBuilder class methodsFor: 'accessing - manifest' stamp: ''!
manifestClassPrefix
	"Return a string that serves as a prefix for Manifest classes (identifies uniquely the beginning of a Manifest class name)"
	
	^ 'Manifest'! !

!TheManifestBuilder class methodsFor: 'accessing - tags' stamp: ''!
toDoBeginningTag
	"the string that identifies uniquely the beginning of a selector who give  the set of TODO for a rule"
	
	^ 'rule'! !

!TheManifestBuilder class methodsFor: 'accessing - tags' stamp: ''!
falsePositiveEndTag
	"the string that identifies uniquely the end of a selector who give  the set of false positive for a rule"
	
	^ 'FalsePositive'! !

!TheManifestBuilder class methodsFor: 'accessing - manifest' stamp: ''!
manifestClassNameFor: aPackageName
	"Returns a symbol representing a suitable name for a Manifest class for the given package"
	
	^(self manifestTag, (aPackageName select: [:each | each isAlphaNumeric ])) asSymbol! !

!TheManifestBuilder class methodsFor: 'accessing - tags' stamp: ''!
toDoEndTag
	"the string that identifies uniquely the end of a selector who give  the set of TODO for a rule"
	
	^ 'TODO'! !

!TheManifestBuilder class methodsFor: 'accessing - tags' stamp: ''!
falsePositiveBeginningTag
	"the string that identifies uniquely the beginning of a selector who give  the set of false positive for a rule"
	
	^ 'rule'! !

!TheManifestBuilder class methodsFor: 'instance creation' stamp: ''!
hasManifestFor: aItem

	^  (self new manifestOf: aItem) isNil not! !

!ThemeIcons commentStamp: ''!
I'm an icon pack who retrieve icons from a remote repository (https://github.com/pharo-project/pharo-icon-packs).

You should access this icons using #iconNamed: idiom: 

Smalltalk ui icons iconNamed: #add.

Iuse an override of #doesNotUnderstand: to provide compatibility with "old way" of providing icons: 

Smalltalk ui icon addIcon. 

Installation:
----------------
ThemeIconPack new 
	name: 'idea11';
	loadIconsFromUrl;
	beCurrent.

NOTE: "name" is the branch name in the repository.
!
!ThemeIcons methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	"WARNING: This is "
	aMessage selector isUnary 
		ifTrue: [ ^ self iconNamed: aMessage selector ].	
	^ super doesNotUnderstand: aMessage! !

!ThemeIcons methodsFor: 'comparing' stamp: ''!
= anotherObject

	^ self species = anotherObject species
		and: [ self name = anotherObject name ]! !

!ThemeIcons methodsFor: 'comparing' stamp: ''!
hash 
	
	^ self name hash! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
beReportNotFound
	reportNotFound := true! !

!ThemeIcons methodsFor: 'printing' stamp: ''!
printOn: stream 
	super printOn: stream.
	stream << $( << self name << $)! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
url
	^ url ifNil: [ url := self defaultUrl ]! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
name: aName
	name := aName! !

!ThemeIcons methodsFor: 'testing' stamp: ''!
hasIcons
	^ self icons notEmpty! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
iconNamed: aSymbol
	^ (self 
		iconNamed: aSymbol 
		ifNone: [ 
			self isReportingNotFound 
				ifTrue: [ 
					self crTrace: (aSymbol, ' icon not found!!').
					self notFoundIcon ]
				ifFalse: [ self blankIcon ]]) scaledByDisplayScaleFactor! !

!ThemeIcons methodsFor: 'testing' stamp: ''!
isReportingNotFound
	^ reportNotFound ifNil: [ reportNotFound := false ]! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
blankIcon
	^ self blankIconOfWidth: 16! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
iconNamed: aSymbol ifNone: aBlock

	self icons at: aSymbol asSymbol ifPresent: [ :icon | ^ icon ].
	"Trying the old way"
	
	((aSymbol endsWith: 'Icon') or: [ (aSymbol endsWith: 'Form') ]) ifTrue: [ 
		self icons 
			at: (aSymbol allButLast: 4) asSymbol 
			ifPresent: [ :icon | ^ icon ] 
	].

	^ aBlock value! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
notFoundIcon
	^ self icons
		at: #notFoundIcon
		ifAbsentPut: [ Color red iconOrThumbnailOfSize: 16 ]! !

!ThemeIcons methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionIcons
	<inspectorPresentationOrder: 0 title: 'Icons'>
	
	^ SpListPresenter new
		items: (icons associations sorted: #key ascending);
		display: [ :each | each key ];
		displayIcon: [ :each | each value ];
		yourself! !

!ThemeIcons methodsFor: 'loading' stamp: ''!
loadIconsFromUrl
	| newIcons zipArchive |
	
	newIcons := IdentityDictionary new.
	zipArchive := self downloadFromUrl.
	((FileSystem zip: zipArchive) open workingDirectory allChildrenMatching: '*.png')
		reject: [ :each | each base beginsWith: '.' ]
		thenDo: [ :each | 
			[ newIcons 	
				at: each base asSymbol
				put: (self readPNGFrom: each) ]
			on: Error do: [ :e | self crTrace: each fullName, ' not a PNG, skipping.'  ]].
	icons := newIcons.! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
beCurrent
	self class current: self! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
icons 
	^ icons ifNil: [ icons := Dictionary new: 0 ]! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
allIconNames
	"Returns the names of all the available icons"
	^ self icons keys! !

!ThemeIcons methodsFor: 'private' stamp: ''!
defaultUrl
	^ self class baseUrl / (self name, '.zip')! !

!ThemeIcons methodsFor: 'utilities' stamp: ''!
form16x16FromContents: aByteArray 
	^ Form
	extent: 16@16
	depth: 32
	fromArray: aByteArray 
	offset: 0@0! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
url: aStringOrUrl
	url := aStringOrUrl ifNotNil: [ aStringOrUrl asUrl ]! !

!ThemeIcons methodsFor: '*System-Settings-Core' stamp: ''!
acceptSettings: aVisitor
	^ aVisitor visitThemeIcons: self! !

!ThemeIcons methodsFor: 'utilities' stamp: ''!
blankIconOfWidth: aNumber 
	^ self icons
		at: ('blank-' , aNumber asString) asSymbol
		ifAbsentPut: [Form extent: aNumber @ 1 depth: 8]! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
beNotReportNotFound
	reportNotFound := false! !

!ThemeIcons methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!ThemeIcons methodsFor: 'private' stamp: ''!
readPNGFrom: aReference
	^ aReference binaryReadStreamDo: [ :stream | 
		PNGReadWriter formFromStream: stream ]! !

!ThemeIcons methodsFor: 'loading' stamp: ''!
downloadFromUrl
	| zipArchive |
	self class destinationPath ensureCreateDirectory. 	
	zipArchive := self class destinationPath / (self name, '.zip').
	zipArchive exists 
		ifFalse: [ 
			ZnClient new
				url: self url;
				downloadTo: zipArchive ].

	^ zipArchive! !

!ThemeIcons class methodsFor: 'accessing' stamp: ''!
fetchPacks
	"Retrieve all packs available from repository"
	| jsonList |
	
	[ jsonList := ZnClient new 
		get: 'https://api.github.com/repos/pharo-project/pharo-icon-packs/branches';
		contents ] 
	on: Error do: [ :e | 
		"in case of error (no inet connection, for example) I retrieve just current icon set"
		e crTrace.
		^ { self current } ].
	^ (STON fromString: jsonList) 
		collect: [ :each | | packName |
			"Ensure we have just one instance of current pack"
			packName := each at: 'name'.
			packName = self current name
				ifTrue: [ self current ]
				ifFalse: [ self named: packName ] ]
		as: Array! !

!ThemeIcons class methodsFor: 'accessing' stamp: ''!
availablePacks
	"Retrieve all packs available in local disk"
	^ { self current }, (self destinationPath exists
		ifTrue: [  
			(self destinationPath allChildrenMatching: '*.zip') 
				select: [ :each | each base ~= self current name  ]
				thenCollect: [ :each | self named: each base ] ]
		ifFalse: [ #() ])! !

!ThemeIcons class methodsFor: 'instance creation' stamp: ''!
current 
	"WARNING: Direct access to this method is ill-adviced, use Smalltalk ui icons instead."
	^ Current ifNil: [ Current := self loadDefault ]! !

!ThemeIcons class methodsFor: 'instance creation' stamp: ''!
current: aPack
	aPack hasIcons ifFalse: [ aPack loadIconsFromUrl ].
	Current := aPack.
	SystemAnnouncer uniqueInstance announce: IconSetChanged! !

!ThemeIcons class methodsFor: 'accessing' stamp: ''!
destinationPath
	^ 'icon-packs' asFileReference! !

!ThemeIcons class methodsFor: 'settings' stamp: ''!
wrapIconPack: aPack
	^ aPack name! !

!ThemeIcons class methodsFor: 'private' stamp: ''!
loadDefault
	^ self new 
	name: 'idea11';
	loadIconsFromUrl;
	yourself.! !

!ThemeIcons class methodsFor: 'instance creation' stamp: ''!
named: aString 
	^ self new name: aString! !

!ThemeIcons class methodsFor: 'settings' stamp: ''!
createIconPackList
	^ (Smalltalk ui theme 
		newDropListIn: Morph new
		for: self
		list: #availablePacks
		getSelected: #current
		setSelected: #current:
		getEnabled: nil
		useIndex: false
		help: nil)
		wrapSelector: #name;
		hResizing: #rigid;
		width: 120;
		yourself! !

!ThemeIcons class methodsFor: 'settings' stamp: ''!
settingsOn: aBuilder 
	<systemsettings>

	(aBuilder setting: #current)
		parent: #appearance;
		order: 2;
		label: 'Icon Set';
		default: (ThemeIcons named: 'idea11');
		target: self;
		dialog: [ self createSettingRow ]! !

!ThemeIcons class methodsFor: 'accessing' stamp: ''!
baseUrl
	^ 'https://github.com/pharo-project/pharo-icon-packs/archive' asUrl! !

!ThemeIcons class methodsFor: 'settings' stamp: ''!
createFetchButtonUpdating: listMorph
	^ (Smalltalk ui theme 
		newButtonIn: self
		for: self
		getState: nil 
		action: nil
		arguments: nil
		getEnabled: nil
		getLabel: nil
		help: 'Fetch icon pack from remote repository' translated)
		label: 'Fetch from remote';
		actionBlock: [ 
			self uiFetchPacks.
			listMorph update: #availablePacks ];
		yourself! !

!ThemeIcons class methodsFor: 'class initialization' stamp: ''!
reset
	<script>
	
	Current := nil! !

!ThemeIcons class methodsFor: 'settings' stamp: ''!
createSettingRow
	| list |
	^ Smalltalk ui theme 
		newRowIn: self 
		for: {
			list := self createIconPackList.
			self createFetchButtonUpdating: list }! !

!ThemeIcons class methodsFor: 'settings' stamp: ''!
uiFetchPacks
	| choosenPacks remotePacks |

	UIManager default 
		informUser: 'Retrieving available packs from remote repository' 
		during: [ remotePacks := self fetchPacks ].
		
	choosenPacks := (TickDialogWindow 
		itemsList: remotePacks
		itemsHeaderName: nil 
		wrapBlockOrSelector: #name 
		title: 'Remote available icon packs')
		chooseFromOwner: self currentWorld.
	choosenPacks ifNil: [ ^ self ].
	UIManager default informUserDuring: [ :bar | 
		choosenPacks do: [ :each |
			bar label: 'Retrieving "', each name, '" icon set from remote repository'.
			each downloadFromUrl ]]! !

!ThemeIconsStoredSetting commentStamp: ''!
I am responsible for storing information about ThemeIcons objects.!
!ThemeIconsStoredSetting methodsFor: 'accessing' stamp: ''!
url: anObject
	url := anObject! !

!ThemeIconsStoredSetting methodsFor: 'accessing' stamp: ''!
url
	^ url! !

!ThemeIconsStoredSetting methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!ThemeIconsStoredSetting methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!ThemeIconsStoredSetting methodsFor: 'accessing' stamp: ''!
realValue
	^ ThemeIcons new 
		name: self name;
		url: self url;
		yourself! !

!ThemeSettings commentStamp: ''!
Configurable basic settings for themes.!
!ThemeSettings methodsFor: 'balloon' stamp: ''!
balloonHelpDelayTime
	^ balloonHelpDelayTime ifNil: [balloonHelpDelayTime := 800]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
findReplaceSelectionColor: anColor
	findReplaceSelectionColor := anColor! !

!ThemeSettings methodsFor: 'progressbar' stamp: ''!
progressBarColor: anObject
	"Set the value of progressBarColor"

	progressBarColor := anObject! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
preferGradientFill 
	"Answer the value of preferGradientFill "

	^preferGradientFill  ifNil: [preferGradientFill := self preferGradientFillByDefault]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
findReplaceSelectionTextColor: aColor
	"Answer the value of the selectionTextColor for find/replace"

	findReplaceSelectionTextColor := aColor! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
autoSelectionColor: anObject
	"Set the value of autoSelectionColor"

	autoSelectionColor := anObject.
	self
		changed: #autoSelectionColor;
		changed: #manualSelectionColor;
		changed: #selectionColor! !

!ThemeSettings methodsFor: 'balloon' stamp: ''!
maxBalloonHelpLineLength
	^ maxBalloonHelpLineLength ifNil: [maxBalloonHelpLineLength := 40]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
basicSelectionColor
	"Answer the recorded selection color rather than derived."

	^selectionColor! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
preferGradientFill: aBoolean
	"Set the value of preferGradientFill "

	preferGradientFill  := aBoolean! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
scrollbarColor: anObject
	"Set the value of scrollbarColor"

	scrollbarColor := anObject! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
secondarySelectionTextColor
	"Answer the value of selectionTextColor"

	^ secondarySelectionTextColor 
		ifNil: [self theme secondarySelectionColor contrastingBlackAndWhiteColor ]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
preferGradientFillByDefault
	^ true! !

!ThemeSettings methodsFor: 'balloon' stamp: ''!
maxBalloonHelpLineLength: anInteger
	maxBalloonHelpLineLength := anInteger! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
tabAmongFields: aBoolean
	tabAmongFields := aBoolean! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuBorderColor
	"Answer the value of menuColor"

	^ self flatMenu  
		ifFalse: [#raised]
		ifTrue: [self derivedMenuColor twiceDarker]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
preferRoundCornerByDefault
	^ true! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
fadedBackgroundWindows
	^ fadedBackgroundWindows ifNil: [fadedBackgroundWindows := true]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuTitleBorderColor
	^ self flatMenu
		ifFalse: [#inset]
		ifTrue: [self derivedMenuColor muchDarker]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
selectionTextColor
	"Answer the value of selectionTextColor"
	
	^selectionTextColor ifNil: [Color black ]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
fadedBackgroundWindows: aBoolean
	fadedBackgroundWindows := aBoolean! !

!ThemeSettings methodsFor: 'settings' stamp: ''!
toConfiguration: tree
	"Update the tree from the receiver."
	
	tree at: #windowColor put: self windowColor.
	tree at: #autoSelectionColor put: self autoSelectionColor.
	tree at: #selectionColor put: self basicSelectionColor! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
fastDragging 
		^ fastDragging ifNil: [fastDragging := false]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuTitleColor
	"Answer the value of menuTitleColor"

	Display depth = 1 ifTrue: [^ Color white].
	Display depth = 2 ifTrue: [^ Color gray].
	^menuTitleColor 
		ifNil: [self menuColor 
				ifNil: [Color gray] 
				ifNotNil: [:mc | self preferGradientFill 
					ifTrue: [mc]
					ifFalse: [mc twiceDarker]]]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
autoMenuColor: aBoolean
	"Answer the value of autoMenuColor"

	autoMenuColor := aBoolean! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuSelectionTextColor
	"Answer the value of menuSelectionTextColor"

	^menuSelectionTextColor ifNil: [menuSelectionTextColor := Color black]! !

!ThemeSettings methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		autoSelectionColor: true;
		windowColor: self defaultWindowColor;
		selectionColor: self defaultSelectionColor;
		buttonColor: self defaultButtonColor;
		scrollbarColor: self defaultScrollbarColor;
		standardColorsOnly: false! !

!ThemeSettings methodsFor: 'progressbar' stamp: ''!
progressBarProgressColor
	"Answer the value of progressBarProgressColor"

	^progressBarProgressColor ifNil: [self menuTitleColor]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuShadowColor
	^ Color r: 0.0 g: 0.0 b: 0.0 alpha: 0.666! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
selectionColor: anObject
	"Set the value of selectionColor"
	selectionColor := anObject! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
fastDragging: aBoolean
		fastDragging := aBoolean! !

!ThemeSettings methodsFor: 'button' stamp: ''!
defaultButtonColor
	"Answer the default button colour."

	^Color gray! !

!ThemeSettings methodsFor: 'button' stamp: ''!
buttonColor: anObject
	"Set the value of buttonColor"

	buttonColor := anObject! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
manualSelectionColor
	"Answer the inverse of autoSelectionColor."

	^self autoSelectionColor not! !

!ThemeSettings methodsFor: 'balloon' stamp: ''!
balloonHelpDelayTime: anInteger
	balloonHelpDelayTime := anInteger! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
derivedMenuColor
	"Answer a selection colour based on the window color."

	| autoColor worldColor |
	autoColor := self autoMenuColor 
				and: [Display depth > 4
						and: [(worldColor := self currentWorld color) isColor]].

	^ autoColor
				ifTrue: [worldColor luminance > 0.7
						ifTrue: [worldColor mixed: 0.85 with: Color black]
						ifFalse: [worldColor mixed: 0.4 with: Color white]]
				ifFalse: [self menuColor].! !

!ThemeSettings methodsFor: 'settings' stamp: ''!
fromConfiguration: tree
	"Update the settings from the given tree."
	
	(tree at: #windowColor ifAbsent: []) ifNotNil: [:v | self windowColor: v].
	(tree at: #autoSelectionColor ifAbsent: []) ifNotNil: [:v | self autoSelectionColor: v].
	(tree at: #selectionColor ifAbsent: []) ifNotNil: [:v | self selectionColor: v]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
fallbackMenuColor
	"Answer the value of menuColor"

	^ self preferGradientFill ifTrue: [Color lightGray] ifFalse: [Color lightGray muchLighter]! !

!ThemeSettings methodsFor: 'balloon' stamp: ''!
balloonHelpEnabled
	^ balloonHelpEnabled ifNil: [balloonHelpEnabled := true]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
scrollbarColor
	"Answer the value of scrollbarColor"

	^scrollbarColor ifNil: [self windowColor]! !

!ThemeSettings methodsFor: 'progressbar' stamp: ''!
progressBarProgressColor: anObject
	"Set the value of progressBarProgressColor"

	progressBarProgressColor := anObject! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
animationSettings
	^ animationSettings ifNil: [animationSettings := AnimationSettings new]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
derivedSelectionColor
	"Answer a selection colour based on the window color."

	^self windowColor whiter lighter! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
preferRoundCorner: aBoolean
	"Set the value of preferRoundCorner"

	preferRoundCorner := aBoolean! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
standardColorsOnly
	"Answer the value of standardColorsOnly"
 
	^standardColorsOnly ifNil: [^false]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuColor
	"Answer the value of menuColor"

	^ menuColor ifNil: [self fallbackMenuColor]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
windowColor: anObject
	"Set the value of windowColor"

	windowColor := anObject.
	self changed: #windowColor.
	self autoSelectionColor ifTrue: [self changed: #selectionColor]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
autoMenuColor
	"Answer the value of autoMenuColor"

	^autoMenuColor ifNil: [^false]! !

!ThemeSettings methodsFor: 'button' stamp: ''!
buttonColor
	"Answer the value of buttonColor"

	^buttonColor ifNil: [self windowColor]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
findReplaceSelectionTextColor
	"Answer the value of the selectionTextColor for find/replace"

	^ findReplaceSelectionTextColor 
		ifNil: [ self findReplaceSelectionColor contrastingBlackAndWhiteColor ]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
flatMenu: aBoolean
		flatMenu := aBoolean! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuBorderWidth
	"Answer the value of menuColor"

	^ 2! !

!ThemeSettings methodsFor: 'balloon' stamp: ''!
balloonHelpEnabled: aBoolean
	balloonHelpEnabled := aBoolean! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
secondarySelectionTextColor: aColor
	"set the value of selectionTextColor"

	secondarySelectionTextColor := aColor! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
selectionBarColor: aColor
	selectionBarColor := aColor! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuTitleColor: anObject
	"Set the value of menuTitleColor"

	menuTitleColor := anObject! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuSelectionColor
	"Answer the value of menuSelectionColor"

	^menuSelectionColor ifNil: [self derivedMenuColor darker]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
windowColor
	"Answer the value of windowColor"

	^ windowColor ifNil: [Color lightGray]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
flatMenu 
		^ flatMenu ifNil: [flatMenu := false]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
defaultSelectionColor
	"Answer the default selection colour."

	^self defaultWindowColor! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
haveSelectionTextColor
	
	^ selectionTextColor notNil! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
standardColorsOnly: anObject
	"Set the value of standardColorsOnly"

	standardColorsOnly := anObject! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
preferRoundCorner
	"Answer the value of preferRoundCorner"

	^preferRoundCorner  ifNil: [preferRoundCorner := self preferRoundCornerByDefault]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
desktopImageLayout: aSymbol
	"Set the layout symbol for any desktop image.
	See AlphaImageMorph>>layoutSymbols."

	desktopImageLayout := aSymbol! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
autoSelectionColor
	"Answer the value of autoSelectionColor"

	^autoSelectionColor ifNil: [^true]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
selectionColor
	"Answer the value of selectionColor"
	
	Display depth = 1 ifTrue: [^ Color veryLightGray].
	Display depth = 2 ifTrue: [^ Color gray].
	^self autoSelectionColor
		ifTrue: [self derivedSelectionColor]
		ifFalse: [selectionColor ifNil: [selectionColor := Color r: 0.0 g: 0.0 b: 0.8 alpha: 0.25]]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuColor: anObject
	"Set the value of menuColor"

	menuColor := anObject! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
defaultScrollbarColor
	"Answer the default scrollbar colour."

	^Color gray! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
unfocusedSelectionColor
	"Answer the value of selectionColor when the window have not the focus"

	^ unfocusedSelectionColor ifNil: [unfocusedSelectionColor := self selectionColor alphaMixed: 0.7 with: Color veryLightGray lighter]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
unfocusedSelectionColor: aColor
	"Answer the value of selectionColor when the window have not the focus"

	unfocusedSelectionColor := aColor! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
scrollBarThickness
	^ scrollBarThickness ifNil: [scrollBarThickness := 14]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuKeyboardFocusColor
	^ (Color r: 0.6 g: 1.0 b: 1.0)! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
defaultWindowColor
	"Answer the default window colour."

	^ Color lightGray! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
selectionBarColor
	^ selectionBarColor ifNil: [selectionBarColor := self selectionColor alpha: 0.06]! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
haveSecondarySelectionTextColor
	"Answer the value of selectionTextColor"

	^ secondarySelectionTextColor notNil! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
findReplaceSelectionColor
	"Answer the value of the selectionColor for find/replace"

	^ findReplaceSelectionColor ifNil: [findReplaceSelectionColor := Color orange alpha: 0.4]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuKeyboardControl
	^ true! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuSelectionTextColor: aColor
	"Answer the value of menuSelectionTextColor"

	menuSelectionTextColor := aColor! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
haveFindReplaceSelectionTextColor

	^ findReplaceSelectionTextColor notNil! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
selectionTextColor: aColor
	selectionTextColor := aColor! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
tabAmongFields
	^ tabAmongFields ifNil: [tabAmongFields := true]! !

!ThemeSettings methodsFor: 'menu' stamp: ''!
menuSelectionColor: aColor
	"Set the base value of menuSelectionColor.
	If nil, actual color used will be based on derived menu color."

	menuSelectionColor := aColor! !

!ThemeSettings methodsFor: 'accessing' stamp: ''!
desktopImageLayout
	"Answer the layout symbol for any desktop image.
	See AlphaImageMorph>>layoutSymbols."

	^desktopImageLayout ifNil: [desktopImageLayout := #scaled]! !

!ThemeSettings methodsFor: 'settings' stamp: ''!
applySettingsFrom: aThemeSettings
	"Change the settings to be those of aThemeSettings."
	
	self
		windowColor: aThemeSettings windowColor;
		selectionColor: aThemeSettings selectionColor;
		autoSelectionColor: aThemeSettings autoSelectionColor! !

!ThemeSettings methodsFor: 'progressbar' stamp: ''!
progressBarColor
	"Answer the value of progressBarColor"

	^progressBarColor ifNil: [progressBarColor := self derivedMenuColor muchLighter]! !

!ThirtyTwoBitRegister commentStamp: ''!
I represent a 32-bit register. An instance of me can hold any non-negative integer in the range [0..(2^32 - 1)]. Operations are performed on my contents in place, like a hardware register, and results are always modulo 2^32.

This class is primarily meant for use by the SecureHashAlgorithm class.
!
!ThirtyTwoBitRegister methodsFor: 'converting' stamp: ''!
asByteArray
	^ ByteArray with: (low bitAnd: 16rFF) with: (low bitShift: -8) with: (hi bitAnd: 16rFF) with: (hi bitShift: -8)! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: ''!
+= aThirtTwoBitRegister
	"Replace my contents with the sum of the given register and my current contents."

	| lowSum |
	lowSum := low + aThirtTwoBitRegister low.
	hi := (hi + aThirtTwoBitRegister hi + (lowSum bitShift: -16)) bitAnd: 16rFFFF.
	low := lowSum bitAnd: 16rFFFF.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: ''!
bitAnd: aThirtTwoBitRegister
	"Replace my contents with the bitwise AND of the given register and my current contents."

	hi := hi bitAnd: aThirtTwoBitRegister hi.
	low := low bitAnd: aThirtTwoBitRegister low.
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: ''!
byteAt: anInteger
	anInteger = 1 ifTrue: [^ hi bitShift: -8].
	anInteger = 2 ifTrue: [^ hi bitAnd: 16rFF].
	anInteger = 3 ifTrue: [^ low bitShift: -8].
	anInteger = 4 ifTrue: [^ low bitAnd: 16rFF]! !

!ThirtyTwoBitRegister methodsFor: 'converting' stamp: ''!
asReverseInteger
	"Answer the byte-swapped integer value of my current contents."

	^ ((low bitAnd: 16rFF) bitShift: 24) +
       ((low bitAnd: 16rFF00) bitShift: 8) +
	  ((hi bitAnd: 16rFF) bitShift: 8) +
       (hi bitShift: -8)
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: ''!
bitXor: aThirtTwoBitRegister
	"Replace my contents with the bitwise exclusive OR of the given register and my current contents."

	hi := hi bitXor: aThirtTwoBitRegister hi.
	low := low bitXor: aThirtTwoBitRegister low.
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: ''!
hi

	^ hi
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: ''!
bitOr: aThirtTwoBitRegister
	"Replace my contents with the bitwise OR of the given register and my current contents."

	hi := hi bitOr: aThirtTwoBitRegister hi.
	low := low bitOr: aThirtTwoBitRegister low.
! !

!ThirtyTwoBitRegister methodsFor: 'copying' stamp: ''!
copy
	"Use the clone primitive for speed."

	<primitive: 148>
	^ super copy
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: ''!
storeInto: aByteArray at: index
	"Store my 32-bit value into the four bytes of the given ByteArray starting at the given index. Consider the first byte to contain the most significant bits of the word (i.e., use big-endian byte ordering)."

	aByteArray at: index put: (hi bitShift: -8).
	aByteArray at: index + 1 put: (hi bitAnd: 16rFF).
	aByteArray at: index + 2 put: (low bitShift: -8).
	aByteArray at: index + 3 put: (low bitAnd: 16rFF)! !

!ThirtyTwoBitRegister methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Print my contents in hex with a leading 'R' to show that it is a register object being printed."

	aStream nextPutAll: 'R:'.
	self asInteger storeOn: aStream base: 16.
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: ''!
reverseLoadFrom: aByteArray at: index
	"Load my 32-bit value from the four bytes of the given ByteArray
starting at the given index. Consider the first byte to contain the most
significant bits of the word (i.e., use big-endian byte ordering)."

	hi := ((aByteArray at: index + 3) bitShift: 8) + ( aByteArray at: index + 2).
	low := ((aByteArray at: index + 1) bitShift: 8) + ( aByteArray at: index).
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: ''!
asInteger
	"Answer the integer value of my current contents."

	^ (hi bitShift: 16) + low
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: ''!
bitInvert
	"Replace my contents with the bitwise inverse my current contents."

	hi := hi bitXor: 16rFFFF.
	low := low bitXor: 16rFFFF.
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: ''!
load: anInteger
	"Set my contents to the value of given integer."

	low := anInteger bitAnd: 16rFFFF.
	hi := (anInteger bitShift: -16) bitAnd: 16rFFFF.
	self asInteger = anInteger
		ifFalse: [self error: 'out of range: ', anInteger printString].
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: ''!
leftRotateBy: bits
	"Rotate my contents left by the given number of bits, retaining exactly 32 bits."

	"Details: Perform this operation with as little LargeInteger arithmetic as possible."

	| bitCount s1 s2 newHi |
	"ensure bitCount is in range [0..32]"
	bitCount := bits \\ 32.
	bitCount < 0 ifTrue: [ bitCount := bitCount + 32 ].
	hi := bitCount > 16
		ifTrue: [ s1 := bitCount - 16.
			s2 := s1 - 16.
			newHi := ((low bitShift: s1) bitAnd: 16rFFFF) bitOr: (hi bitShift: s2).
			low := ((hi bitShift: s1) bitAnd: 16rFFFF) bitOr: (low bitShift: s2).
			newHi ]
		ifFalse: [ s1 := bitCount.
			s2 := s1 - 16.
			newHi := ((hi bitShift: s1) bitAnd: 16rFFFF) bitOr: (low bitShift: s2).
			low := ((low bitShift: s1) bitAnd: 16rFFFF) bitOr: (hi bitShift: s2).
			newHi ]! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: ''!
low

	^ low! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: ''!
bitShift: anInteger
	"Replace my contents with the bitShift of anInteger."
	self load: (self asInteger bitShift: anInteger). ! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: ''!
byte1: hi1 byte2: hi2 byte3: low1 byte4: low2
	hi := (hi1 bitShift: 8) + hi2.
	low := (low1 bitShift: 8) + low2.! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: ''!
loadFrom: aByteArray at: index
	"Load my 32-bit value from the four bytes of the given ByteArray starting at the given index. Consider the first byte to contain the most significant bits of the word (i.e., use big-endian byte ordering)."

	hi := ((aByteArray at: index) bitShift: 8) + ( aByteArray at: index + 1).
	low := ((aByteArray at: index + 2) bitShift: 8) + ( aByteArray at: index + 3).
! !

!ThirtyTwoBitRegister class methodsFor: 'instance creation' stamp: ''!
new
	"Answer a new instance whose initial contents is zero."

	^ super new load: 0
! !

!ThisContextVariable commentStamp: ''!
I model thisContext keyword!
!ThisContextVariable methodsFor: 'testing' stamp: ''!
isThisContextVariable
	^true! !

!ThisContextVariable methodsFor: 'emitting' stamp: ''!
emitValue: methodBuilder

	methodBuilder pushThisContext! !

!ThisContextVariable methodsFor: 'debugging' stamp: ''!
readInContext: aContext
	^aContext! !

!ThisContextVariable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitThisContextNode: aNode! !

!ThisContextVariable methodsFor: 'queries' stamp: ''!
usingMethods
	^ environment allMethods select: [ :method | 
		  method readsThisContext ]! !

!ThisContextVariable class methodsFor: 'accessing' stamp: ''!
variableName
	^'thisContext'! !

!ThreadSafeTranscript commentStamp: ''!
I'm an output device.
    Transcript show: 'hello'.

I implement TTranscript.

While ThreadSafeTranscript is threadsafe wrt stream access, the morphic code invoked by #changed: is not. So #changed: should not be sent from multiple threads (at random times) since this causes a morph's #update: method to conflict with the UI-thread running the morph's #drawOn: method in parallel. Whereas Morphic seems to assume that #update: and #drawOn: are run sequentially from the same thread.

The #step method is assumed to be invoked only from the main UI thread, so from here it is safe to send #changed: and consequently #update:. Methods #clear and #endEntry are invoked from multiple threads, so these signal to #step to call #changed: with the required parameter (#clearText and #appendEntry respectively.)

Method #contents should not directly return ==stream contents==, since even with a mutex around that, multiple calls from Morphic may unexpectedly get different results and fail.  #contents needs to return a value that is static between each #step (which is ==stepContents== that is only udpated in #step).

The ==stream reset== is left to occur from #clear being invoked from multiple threads. 

The ==stream resetContents== is moved to #step so this occurs directly after ==stepContents== is set from ==stream contents==.



!
!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
endEntry
"	
	The next #stepGlobal message (usually invoked by Morhic stepping) will raise an #appendEntry update and reset the stream.
"  
  	self critical: [ deferredEndEntry := true ].! !

!ThreadSafeTranscript methodsFor: '*Transcript-Tool' stamp: ''!
open
	<script: 'self new open'>
	
	^ self openLabel: self title
! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
crShow: anObject
	"Output anObject asString on the receiver preceded by a cr and show the output"
	
	self critical: [ self cr; show: anObject ]! !

!ThreadSafeTranscript methodsFor: '*Transcript-Tool' stamp: ''!
openLabel: aString
	| window m |
	window := (SystemWindow labelled: aString) model: self.
	m := RubPluggableTextMorph new
		getTextSelector: #contents;
		setTextSelector: #clear;
		on: self;
		beForSmalltalkScripting.
	m onAnnouncement: MorphDeleted do: [ self announcer unsubscribe: m  ].
	window addMorph: m frame: (0 @ 0 corner: 1 @ 1).
	^ window openInWorld
! !

!ThreadSafeTranscript methodsFor: 'printing' stamp: ''!
printOn: aStream

	self == Transcript ifFalse: [^super printOn: aStream].
	aStream nextPutAll: 'Transcript'! !

!ThreadSafeTranscript methodsFor: 'self evaluating' stamp: ''!
isSelfEvaluating

	^self == Transcript 
		ifTrue: [ true ]
		ifFalse: [ super isSelfEvaluating ]! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
tab
	"Output a tab on the receiver, buffered and not yet shown"

	self nextPut: Character tab! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
nextPut: value
	"Output character on the receiver, buffered, not yet shown"

	self critical: [ stream nextPut: value ].
	^ value! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
show: anObject
	"Output anObject asString on the receiver and show the output"
	
	self critical: [ self print: anObject; endEntry ]! !

!ThreadSafeTranscript methodsFor: '*Transcript-Tool' stamp: ''!
interactionModel
	^ self
! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
close
	self flush.
	self critical: [ stream close ]
	! !

!ThreadSafeTranscript methodsFor: 'protected low level' stamp: ''!
contents 
"	Cannot directly return == stream contents == since Morphic assumes multiple calls will return 
	the same value within the one cycle.  WorldState>>runStepMethodsIn:  sends #step to 
	do == stepContents := stream contents ==.
"
	^ stepContents! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
flush
	self endEntry
! !

!ThreadSafeTranscript methodsFor: 'accessing' stamp: ''!
characterLimit

	^ 20000! !

!ThreadSafeTranscript methodsFor: 'ui building' stamp: ''!
title

	^ 'Transcript'! !

!ThreadSafeTranscript methodsFor: 'accessing' stamp: ''!
variableBindings

	^ Dictionary new! !

!ThreadSafeTranscript methodsFor: 'accessing' stamp: ''!
doItContext
	^nil! !

!ThreadSafeTranscript methodsFor: 'updating' stamp: ''!
stepGlobal
"	The superclass method Model>>step indicates a convention that might be used to interoperate 
	synchronously with the UI-thread.  However when multiple Transcript windows are open, their 
	PluggableTextMorphs share a single instance, from the global Transcript.  To avoid potential trouble, 
	this method should not be named #step.  
	
	As well, we need this method to execute even when no Transcript windows are open, so the stream 
	continues to be reset periodically, otherwise it would grow indefinitely. So this method is invoked 
	from WorldState>>runStepMethodsIn:. 
"

	"Next three lines required temporarily to initialize instance variables added to existing instance"
	deferredClear ifNil: [ deferredClear := false ].
	deferredEndEntry ifNil: [ deferredEndEntry := false ].
	stepContents ifNil: [ stepContents := '' ].
	
	deferredClear ifTrue: 
	[ 	deferredClear := false.  
		stepContents := ''.
		self changed: #clearText.
	].
	deferredEndEntry ifTrue: 
	[	deferredEndEntry := false.  	
		self critical: 
		[	stepContents := stream contents.
			stream resetContents.	
		].
		self changed: #appendEntry.	
	].
	! !

!ThreadSafeTranscript methodsFor: 'initialization' stamp: ''!
initialize
 
	super initialize.
	accessSemaphore := Mutex new.
	stream := String new writeStream.
	deferredClear := false.
	deferredEndEntry := false.
	stepContents := ''.

	! !

!ThreadSafeTranscript methodsFor: 'ui building' stamp: ''!
initialExtent
	
	^447@300! !

!ThreadSafeTranscript methodsFor: 'updating' stamp: ''!
shoutAboutToStyle: aPluggableShoutMorphOrView 
	^ false! !

!ThreadSafeTranscript methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass
	^ nil! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
space
	"Output a space on the receiver, buffered and not yet shown"

	self nextPut: Character space! !

!ThreadSafeTranscript methodsFor: 'accessing' stamp: ''!
menu
	" return nil to let the editing mode build the right menu"
	^nil! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
<< anObject
	"Write anObject to the receiver, dispatching using #putOn:
	This is a shortcut for both nextPut: and nextPutAll: since anObject can be both
	the element type of the receiver as well as a collection of those elements.
	No further conversions of anObject are applied.
	Return self to accomodate chaining."

 	anObject putOn: self! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
clear 
"	Clear all characters by resetting the stream and voiding any previously flagged deferredEndEntry.
	Redisplays the view by signalling for #step to send #changed: .
"	
	self 
		critical: [ 
			deferredClear := true.
			deferredEndEntry := false.
			stream reset ]! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
critical: block
	"Execute block making sure only one thread accesses the receiver"

	^ accessSemaphore critical: block ! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
nextPutAll: value
	"Output string on the receiver, buffered, not yet shown"

	self critical: [ stream nextPutAll: value ].
	^ value! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
print: anObject
	"Output anObject asString on the receiver, buffered, not yet shown"
	
	self nextPutAll: anObject asString! !

!ThreadSafeTranscript methodsFor: 'streaming' stamp: ''!
cr
	"Output a cr on the receiver, buffered and not yet shown"
	
	self nextPut: Character cr! !

!ThreadSafeTranscript class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#transcriptIcon! !

!ThreadSafeTranscript class methodsFor: 'declare' stamp: ''!
install

	self installThreadSafeAsTranscript! !

!ThreadSafeTranscript class methodsFor: '*Transcript-Tool' stamp: ''!
open 
	<script>
	
	^ self new open 
! !

!ThreadSafeTranscript class methodsFor: 'declare' stamp: ''!
installThreadSafeAsTranscript
	<script>

	Smalltalk globals at: #Transcript put: (self new)! !

!ThreadSafeTranscript class methodsFor: '*Transcript-Tool' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #'Transcript')
		action: [ Smalltalk tools transcript open ];
		order: 2;
		parent: #InputOutput;
		help: 'Transcript';
		keyText: 'o, t';
		help: 'Window on the Transcript output stream, which is useful for writing log messages.';
		icon: self taskbarIcon.
	aBuilder withSeparatorAfter
! !

!ThreePhaseButtonMorph commentStamp: ''!
A button morph with separate images for on, off, and pressed with the mouse. 

When the event actWhen occurs, send actionSelector with 'arguments' to target.  For other events, default to my eventHandler.  The current event is not supplied in the arguments to the actionSelector.  

image (a.k.a. onImage) may not be nil.  offImage and pressedImage may be nil.  nil there means be transparent and show the underlying object.  

Tools for debugging:
Display the images momentarily under program control (for positioning) (self is an instance).
	self state: #on.  self state: #off.
	self state: #pressed.  self state: #off.
Display a rectangle where the button is.
	Display fillWithColor: bounds + (self world viewBox origin).
	self invalidRect: bounds.!
!ThreePhaseButtonMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas

	state == #off ifTrue: [
		offImage ifNotNil: [aCanvas translucentImage: offImage at: bounds origin]].
	state == #pressed ifTrue: [
		pressedImage ifNotNil: [aCanvas translucentImage: pressedImage at: bounds origin]].
	state == #on ifTrue: [
		image ifNotNil: [aCanvas translucentImage: image at: bounds origin]].! !

!ThreePhaseButtonMorph methodsFor: 'stepping' stamp: ''!
step
	(self hasProperty: #doesButtonAction) ifTrue:[
		self doButtonAction.
		self setProperty: #didButtonAction toValue: true.
	].! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
arguments: aCollection

	arguments := aCollection asArray copy.! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
pressedImage
	^ pressedImage! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
onImage
	^ image! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector := nil].

	actionSelector := aSymbolOrString asSymbol.! !

!ThreePhaseButtonMorph methodsFor: 'printing' stamp: ''!
printOn: aStream 
	| string |
	aStream nextPutAll: '3PButton'.
	arguments notEmpty 
		ifTrue: [string := arguments at: (2 min: arguments size)].
	aStream nextPutAll: '('.
	(string notNil and: [string ~~ self]) 
		ifTrue: 
			[aStream
				print: string;
				space]
		ifFalse: 
			[aStream
				print: actionSelector;
				space].
	aStream
		print: self identityHash;
		nextPutAll: ')'! !

!ThreePhaseButtonMorph methodsFor: 'balloon' stamp: ''!
helpText
	
	^self balloonText! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: ''!
mouseStillDown: evt
	actWhen == #whilePressed ifFalse:[^self].
	(self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].! !

!ThreePhaseButtonMorph methodsFor: 'copying' stamp: ''!
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 := arguments collect: [:each |
		deepCopier references at: each ifAbsent: [each]].! !

!ThreePhaseButtonMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	"Do it normally"
	
	self changed.
	bounds := bounds topLeft extent: aPoint.
	self layoutChanged.
	self changed.! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: ''!
mouseMove: evt
	(self containsPoint: evt cursorPoint)
		ifTrue: [self state: #pressed.
				super mouseMove: evt]
				"Allow on:send:to: to set the response to events other than actWhen"
		ifFalse: [self state: #off].! !

!ThreePhaseButtonMorph methodsFor: 'stepping' stamp: ''!
stepTime
	(self hasProperty: #doesButtonAction) ifTrue:[^1].
	^super stepTime! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
target: anObject

	target := anObject! !

!ThreePhaseButtonMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	| paint |
	paint := offImage.
	
	state == #pressed
		ifTrue: [ paint := pressedImage ].
	state == #on
		ifTrue: [ paint := image ].
	paint ifNil: [ ^ self ].
	
	anAthensCanvas setPaint: paint.
	anAthensCanvas paintTransform
		restoreAfter: [ 
			anAthensCanvas paintTransform translateBy: self innerBounds origin.	
			anAthensCanvas drawShape: self innerBounds ]! !

!ThreePhaseButtonMorph methodsFor: 'button' stamp: ''!
onImage: aForm
	"The main image is used when on.
	Go through ImageMorph method to set extent."
	
	self image: aForm! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
pressedImage: aForm
	pressedImage := aForm.
	self invalidRect: self bounds.! !

!ThreePhaseButtonMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	state := #off.
	actionSelector := #flash.
	arguments := EmptyArray.
	actWhen := #buttonUp

	"self on: #mouseStillDown send: #dragIfAuthoring: to: self."
	"real move should include a call on dragIfAuthoring: "! !

!ThreePhaseButtonMorph methodsFor: 'copying' stamp: ''!
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.
offImage := offImage veryDeepCopyWith: deepCopier.
pressedImage := pressedImage veryDeepCopyWith: deepCopier.
state := state veryDeepCopyWith: deepCopier.
"target := target.		Weakly copied"
"actionSelector := actionSelector.		Symbol"
"arguments := arguments.		Weakly copied"
actWhen := actWhen.		"Symbol"! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
actionSelector

	^ actionSelector! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
arguments
	^ arguments! !

!ThreePhaseButtonMorph methodsFor: 'button' stamp: ''!
doButtonAction
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	(target notNil and: [actionSelector notNil]) 
		ifTrue: 
			[Cursor normal 
				showWhile: [target perform: actionSelector withArguments: arguments].
			target isMorph ifTrue: [target changed]]! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: ''!
handlesMouseStillDown: evt
	^actWhen == #whilePressed! !

!ThreePhaseButtonMorph methodsFor: 'balloon' stamp: ''!
helpText: aString

	self setBalloonText: aString! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
state: newState
	"Change the image and invalidate the rect."

	newState == state ifTrue: [^ self].
	state := newState.
	self invalidRect: bounds.	"All three images must be the same size"! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: ''!
doButtonAction: evt
	
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	target ifNil: [^self].
	actionSelector ifNil: [^self].
	Cursor normal showWhile: [ | moreArgs |
		moreArgs := actionSelector numArgs > arguments size ifTrue: [
			arguments copyWith: evt
		] ifFalse: [
			arguments
		].
		target perform: actionSelector withArguments: moreArgs
	]! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: ''!
mouseDown: evt
	| now dt |
	self state: #pressed.
	actWhen == #buttonDown
		ifTrue:
			[self doButtonAction]
		ifFalse:
			[now := Time millisecondClockValue.
			super mouseDown: evt.
			"Allow on:send:to: to set the response to events other than actWhen"
			dt := Time millisecondClockValue - now max: 0.  "Time it took to do"
			dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
	self mouseStillDown: evt.! !

!ThreePhaseButtonMorph methodsFor: 'submorphs - add/remove' stamp: ''!
actWhen: condition
	"Accepts symbols:  #buttonDown, #buttonUp, and #whilePressed"
	actWhen := condition! !

!ThreePhaseButtonMorph methodsFor: 'stepping' stamp: ''!
wantsSteps
	^self hasProperty: #doesButtonAction! !

!ThreePhaseButtonMorph methodsFor: 'testing' stamp: ''!
isOn
	^ state == #on! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: ''!
handlesMouseDown: evt

	^ true! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: ''!
mouseUp: evt
	"Allow on:send:to: to set the response to events other than actWhen"
	actWhen == #buttonUp ifFalse: [^super mouseUp: evt].

	(self containsPoint: evt cursorPoint) ifTrue: [
		self state: #on.
		self doButtonAction: evt
	] ifFalse: [
		self state: #off.
	].
	"Allow owner to keep it selected for radio buttons"! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
offImage
	^ offImage! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
target

	^ target! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: ''!
offImage: aForm
	offImage := aForm.
	self invalidRect: self bounds.! !

!ThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: ''!
radioButton
	"Answer a button pre-initialized with radiobutton images."

	| f |
	^ self new
		onImage: (f := self iconNamed: #radioButtonOnIcon);
		pressedImage: (self iconNamed: #radioButtonPressedIcon);
		offImage: (self iconNamed: #radioButtonOffIcon);
		extent: f extent + (2 @ 0);
		yourself! !

!ThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: ''!
checkBox
	"Answer a button pre-initialized with checkbox images."

	| f |
	^ self new
		onImage: (f := self iconNamed: #checkBoxOnIcon);
		pressedImage: (self iconNamed: #checkBoxPressedIcon);
		offImage: (self iconNamed: #checkBoxOffIcon);
		extent: f extent + (2 @ 0);
		yourself! !

!ThreeWayComparisonTest commentStamp: ''!
Unit test for three way comparison!
!ThreeWayComparisonTest methodsFor: 'tests' stamp: ''!
testBooleans
	self assert: (true threeWayCompareTo: false) equals: 1.
	self assert: (false threeWayCompareTo: true) equals: -1.
	self assert: (true threeWayCompareTo: true) equals: 0.
	self assert: (false threeWayCompareTo: false) equals: 0! !

!ThreeWayComparisonTest methodsFor: 'tests' stamp: ''!
testStrings

	| a b c d |
	a := 'xc'.
	b := 'xd'.
	c := 'xd'.
	d := 'xa'.
	self assert: (b threeWayCompareTo: c) isZero.
	self assert: (a threeWayCompareTo: b) equals: -1.
	self assert: (b threeWayCompareTo: a) equals: 1.
	self assert: (a threeWayCompareTo: d) equals: 1.
	self assert: (d threeWayCompareTo: a) equals: -1! !

!ThreeWayComparisonTest methodsFor: 'tests' stamp: ''!
testFloats

	| a b c d |
	a := 13.1.
	b := 18.9.
	c := 18.9.
	d := -7.2.
	self assert: (b threeWayCompareTo: c) isZero.
	self assert: (a threeWayCompareTo: b) equals: -1.
	self assert: (b threeWayCompareTo: a) equals: 1.
	self assert: (a threeWayCompareTo: d) equals: 1.
	self assert: (d threeWayCompareTo: a) equals: -1! !

!ThreeWayComparisonTest methodsFor: 'tests' stamp: ''!
testIntegers
	self assert: (42 threeWayCompareTo: 42) equals: 0.
	self assert: (1 threeWayCompareTo: 42) equals: -1.
	self assert: (100 threeWayCompareTo: 42) equals: 1! !

!ThumbnailMorph commentStamp: ''!
A Morph that views another morph, its objectToView.!
!ThumbnailMorph methodsFor: 't - rotating' stamp: ''!
heading
	"Return the receiver's heading"
	^ self owner 
		ifNil: [self forwardDirection]
		ifNotNil: [self forwardDirection + self owner degreesOfFlex]! !

!ThumbnailMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	"Draw a small view of a morph in another place. Guard against infinite recursion if that morph has a thumbnail of itself inside."
	| time |
	time := Time millisecondClockValue.
	self drawMeOn: aCanvas.
	drawTime := Time millisecondClockValue - time.
	drawTime < 0 ifTrue:[drawTime := nil].! !

!ThumbnailMorph methodsFor: 'accessing' stamp: ''!
getSelector
	"Answer the selector I send to my target to retrieve my value"

	^ viewSelector! !

!ThumbnailMorph methodsFor: 'stepping' stamp: ''!
step
	"Optimization: Don't redraw if we're viewing some kind of SketchMorph and its rotated Form hasn't changed."

	| viewee |
	viewee := self actualViewee.
	viewee ifNil: [ self stopStepping. ^self ].
	self changed.! !

!ThumbnailMorph methodsFor: 'initialization' stamp: ''!
objectToView: objectOrNil
	(objectOrNil isMorph and: [objectOrNil allMorphs includes: self]) ifTrue:
		["cannot view a morph containing myself or drawOn: goes into infinite recursion"
		objectToView := nil.
		^ self].
	objectToView := objectOrNil! !

!ThumbnailMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!ThumbnailMorph methodsFor: 'initialization' stamp: ''!
objectToView: objectOrNil viewSelector: aSelector
	self objectToView: objectOrNil.
	viewSelector := aSelector! !

!ThumbnailMorph methodsFor: 'initialization' stamp: ''!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 1! !

!ThumbnailMorph methodsFor: 'what to view' stamp: ''!
morphToView
	"If the receiver is viewing some object, answer a morph can be thought of as being viewed;  A gesture is made toward generalizing this beyond the morph/player regime, in that a plain blue rectangle is returned rather than simply failing if the referent is not itself displayable."

	objectToView ifNil: [^ nil].
	^ objectToView isMorph
		ifTrue:
			[objectToView]
		ifFalse:
			[Morph new color: Color blue]! !

!ThumbnailMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees
	"Default implementation."

	^ 0.0! !

!ThumbnailMorph methodsFor: 'copying' stamp: ''!
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.
objectToView := deepCopier references at: objectToView ifAbsent: [objectToView].! !

!ThumbnailMorph methodsFor: 'what to view' stamp: ''!
formOrMorphToView
	"Answer the form to be viewed, or the morph to be viewed, or nil"

	| actualViewee |
	(objectToView isForm) ifTrue: [^objectToView].
	actualViewee := viewSelector ifNil: [objectToView]
				ifNotNil: [objectToView perform: viewSelector].
	^actualViewee = 0 
		ifTrue: [nil]
		ifFalse: [actualViewee]! !

!ThumbnailMorph methodsFor: 'accessing' stamp: ''!
putSelector
	"Answer the selector used  for the receiver to send a fresh value back to its target"

	^ nil! !

!ThumbnailMorph methodsFor: 'caching' stamp: ''!
releaseCachedState
	super releaseCachedState.
	lastSketchForm := lastFormShown := nil.! !

!ThumbnailMorph methodsFor: 't - rotating' stamp: ''!
prepareForRotating
	"If I require a flex shell to rotate,
	then wrap it in one and return it.
	Polygons, eg, may override to do nothing."

	^ self addFlexShell! !

!ThumbnailMorph methodsFor: 'stepping' stamp: ''!
stepTime 
	"Adjust my step time to the time it takes drawing my referent"
	drawTime ifNil:[^ 250].
	^(20 * drawTime) max: 250.! !

!ThumbnailMorph methodsFor: 'display' stamp: ''!
drawForForm: aForm on: aCanvas
	"Draw a small view of the given form on the canvas"

	| scale shrunkForm viewedObjectBox interimCanvas |
	viewedObjectBox := aForm boundingBox.
	scale :=  self scaleFor: viewedObjectBox in: self innerBounds.
	interimCanvas := Display defaultCanvasClass extent: viewedObjectBox extent depth: aCanvas depth.
	interimCanvas translateBy: viewedObjectBox topLeft negated 
				during: [:tempCanvas | tempCanvas drawImage: aForm at: 0@0].
	shrunkForm := interimCanvas form magnify: interimCanvas form boundingBox by: scale smoothing: 1.
	lastFormShown := shrunkForm.

	aCanvas paintImage: shrunkForm at: self center - shrunkForm boundingBox center! !

!ThumbnailMorph methodsFor: 't - rotating' stamp: ''!
rotationDegrees: degrees	
	"redefined in all morphs which are using myself"! !

!ThumbnailMorph methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver, obeying a #nominalExtent property if I have one"
	| anExtent |
	
	super initialize.
	anExtent := self valueOfProperty: #nominalExtent ifAbsent: [25@25].
	self extent: anExtent! !

!ThumbnailMorph methodsFor: 'copying' stamp: ''!
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.
"objectToView := objectToView.		Weakly copied"
viewSelector := viewSelector veryDeepCopyWith: deepCopier.
lastSketchForm := lastSketchForm veryDeepCopyWith: deepCopier.
lastFormShown := lastFormShown veryDeepCopyWith: deepCopier.
drawTime := drawTime veryDeepCopyWith: deepCopier.! !

!ThumbnailMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!ThumbnailMorph methodsFor: 'what to view' stamp: ''!
actualViewee
	"Return the actual morph to be viewed, or nil if there isn't an appropriate morph to view."

	| aMorph actualViewee |
	aMorph := self morphToView ifNil: [^ nil]. 
	aMorph isInWorld ifFalse: [^ nil].
	actualViewee := viewSelector ifNil: [aMorph] ifNotNil: [objectToView perform: viewSelector].
	actualViewee = 0 ifTrue: [^ nil].  
	actualViewee ifNil: [actualViewee := objectToView].
	(actualViewee isMorph and: 
		[actualViewee isFlexMorph and: [actualViewee submorphs size = 1]])
			ifTrue: [actualViewee := actualViewee firstSubmorph].
	^ actualViewee! !

!ThumbnailMorph methodsFor: 'display' stamp: ''!
drawMeOn: aCanvas 
	"Draw a small view of a morph in another place.  Guard against infinite recursion if that morph has a thumbnail of itself inside.  Now also works if the thing to draw is a plain Form rather than a morph."

	| viewedMorphBox scale c shrunkForm aWorld aFormOrMorph  |
	super drawOn: aCanvas.
	((aFormOrMorph := self formOrMorphToView) isForm) 
		ifTrue: [^self drawForForm: aFormOrMorph on: aCanvas].
	(((aFormOrMorph notNil and: [(aWorld := aFormOrMorph world) notNil]) 
		and: [aWorld ~~ aFormOrMorph or: [lastFormShown isNil]]) 
			and: [RecursionDepth + 1 < RecursionMax]) 
			ifTrue: 
				[RecursionDepth := RecursionDepth + 1.
				viewedMorphBox := aFormOrMorph fullBounds.
			scale :=  self scaleFor: viewedMorphBox in: self innerBounds.
				c := Display defaultCanvasClass extent: viewedMorphBox extent
							depth: aCanvas depth.
				c translateBy: viewedMorphBox topLeft negated
					during: 
						[:tempCanvas | 
						"recursion happens here"
						tempCanvas fullDrawMorph: aFormOrMorph].
				shrunkForm := c form 
							magnify: c form boundingBox
							by: scale
							smoothing: 1.
				lastFormShown := shrunkForm.
				RecursionDepth := RecursionDepth - 1]
			ifFalse: 
				["This branch used if we've recurred, or if the thumbnail views a World that's already been rendered once, or if the referent is not in a world at the moment"
				lastFormShown ifNotNil: [shrunkForm := lastFormShown]].
	shrunkForm ifNotNil: 
			[aCanvas paintImage: shrunkForm
				at: self center - shrunkForm boundingBox center]! !

!ThumbnailMorph methodsFor: 'accessing' stamp: ''!
getSelector: aSelector
	"Set the selector used to obtain my value"

	self objectToView: objectToView viewSelector: aSelector! !

!ThumbnailMorph methodsFor: 't - rotating' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees |
	delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!ThumbnailMorph methodsFor: 'initialization' stamp: ''!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.781
		g: 0.781
		b: 0.781! !

!ThumbnailMorph methodsFor: 'accessing' stamp: ''!
target
	"Answer the object on which I act"

	^ objectToView! !

!ThumbnailMorph methodsFor: 'display' stamp: ''!
scaleFor:  viewedMorphBox in: myBox
	"Compute the proper scale for the thumbnail."

	|   scale  scaleX scaleY ratio factor  |
scaleX := myBox width asFloat / viewedMorphBox width.
				scaleY := myBox height asFloat / viewedMorphBox height.
				ratio := scaleX / scaleY.
				factor := 1.0 / EccentricityThreshhold.
				ratio < factor
					ifTrue:
						[scale := (scaleX) @ (factor * scaleY)]
					ifFalse:
						[ratio > EccentricityThreshhold
							ifTrue:
								[scale := (factor * scaleX) @ scaleY]
							ifFalse:
								[scale := scaleX min: scaleY]].
^ scale! !

!ThumbnailMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!ThumbnailMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!ThumbnailMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!ThumbnailMorph class methodsFor: 'examples' stamp: ''!
example1
	"Create a thumbnail representing another Morph. The thumbnail is continously updated."
	"self example1"
	| t r |
	r := Morph new.
	r position: 100@200.
	t := ThumbnailMorph new objectToView: r viewSelector: #openInWorld.
	t openInWorld! !

!ThumbnailMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!ThumbnailMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!ThumbnailMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!ThumbnailMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!ThumbnailMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!ThumbnailMorph class methodsFor: 'class initialization' stamp: ''!
initialize
	"Initialize the class variables of ThumbnailMorph"

	RecursionMax := 2.
	RecursionDepth := 0.
	EccentricityThreshhold :=  Float pi

"ThumbnailMorph initialize"! !

!ThumbnailMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ThumbnailMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!ThumbnailMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!ThumbnailMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!ThumbnailMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!ThumbnailMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!ThumbnailMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!ThumbnailMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!ThumbnailMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!ThumbnailMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!ThumbnailMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!ThumbnailMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!ThumbnailMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!ThumbnailMorph class methodsFor: 'utilities' stamp: ''!
recursionReset
	"ThumbnailMorph recursionReset"
	"Reset the RecursionDepth counter in case the user interrupted
during a thumbnail being drawn.  Do this just once in a while when no
drawOn: is being called.  tk 9/8/97"

	RecursionDepth := 0.! !

!ThumbnailMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!ThumbnailMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!ThumbnailMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!ThumbnailMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!ThumbnailMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!ThumbnailMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!ThumbnailMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!ThumbnailMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TickDialogWindow commentStamp: ''!
A TickDialogWindow is a modal dialog window which contains a TickList where user can pick a list of items.

See self example!
!TickDialogWindow methodsFor: 'display' stamp: ''!
newContentMorph

	self listModel: ((self tickListClass 
						itemsList: self itemsList 
						itemsHeaderName: self itemsHeaderName 
						wrapBlockOrSelector: self wrapBlockOrSelector)
						autoMultiSelection: true;
						beCheckList;
						yourself).
	
	self listMorph: (self listModel defaultTreeMorph
								buildContents;
								vResizing: #spaceFill;
								hResizing: #spaceFill).
								
	self defaultValue ifTrue: [ self listMorph selectAll ].							
	^ self listMorph! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
wrapBlockOrSelector

	^ wrapBlockOrSelector! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
defaultValue

	^ defaultValue ifNil: [defaultValue := false]! !

!TickDialogWindow methodsFor: 'compatibility' stamp: ''!
hasUnacceptedEdits

	^ true! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
itemsHeaderName: anObject
	
	itemsHeaderName := anObject! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
resultStorage: anObject
	
	resultStorage := anObject! !

!TickDialogWindow methodsFor: 'actions' stamp: ''!
accept

	self resultStorage: self listModel selectedItems.! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
itemsList

	^ itemsList! !

!TickDialogWindow methodsFor: 'display' stamp: ''!
choose

	^ self chooseFromOwner: self currentWorld! !

!TickDialogWindow methodsFor: 'display' stamp: ''!
chooseFromOwner: aMorph

	self openModal.
	^ resultStorage! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
listMorph: anObject
	
	listMorph := anObject! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
itemsList: anObject
	
	itemsList := anObject! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
resultStorage

	^ resultStorage! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
selectItems: aCollection 
	self listModel selectItems: aCollection! !

!TickDialogWindow methodsFor: 'display' stamp: ''!
initialExtent
	
	| width |
	width := (self listMorph allNodeMorphs detectMax: [:e | e width]) width.
	width := width+ 50.
	
	^width@400! !

!TickDialogWindow methodsFor: 'focus handling' stamp: ''!
defaultFocusMorph

	^ self listMorph 
		ifNil: [ super defaultFocusMorph ]
		ifNotNil: [:morph | morph ]! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
listModel: aModel

	listModel := aModel! !

!TickDialogWindow methodsFor: 'private' stamp: ''!
isResizeable

	^ true! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
listModel

	^ listModel! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
itemsHeaderName

	^ itemsHeaderName! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
wrapBlockOrSelector: anObject
	
	wrapBlockOrSelector := anObject! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
selectedItems 
	^ self listModel selectedItems! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
listMorph

	^ listMorph! !

!TickDialogWindow methodsFor: 'private' stamp: ''!
tickListClass

	^ MorphTreeModel! !

!TickDialogWindow methodsFor: 'accessing' stamp: ''!
defaultValue: aBoolean

	defaultValue := aBoolean! !

!TickDialogWindow class methodsFor: 'examples' stamp: ''!
example
	
	(self itemsList: Morph methods itemsHeaderName: 'Plop' wrapBlockOrSelector: #selector title: 'Example') choose! !

!TickDialogWindow class methodsFor: 'instance creation' stamp: ''!
itemsList: itemsList itemsHeaderName: aName title: aTitle defaultValue: aBoolean
	^ self basicNew
		itemsList: itemsList;
		itemsHeaderName: aName;
		defaultValue: aBoolean;
		initialize;
		title: aTitle;
		yourself! !

!TickDialogWindow class methodsFor: 'instance creation' stamp: ''!
itemsList: itemsList itemsHeaderName: aName wrapBlockOrSelector: aBlockOrSelector title: aTitle defaultValue: aBoolean
	^ self basicNew
		itemsList: itemsList;
		itemsHeaderName: aName;
		wrapBlockOrSelector: aBlockOrSelector;
		defaultValue: aBoolean;
		initialize;
		title: aTitle;
		yourself! !

!TickDialogWindow class methodsFor: 'instance creation' stamp: ''!
itemsList: itemsList itemsHeaderName: aName wrapBlockOrSelector: aBlockOrSelector title: aTitle
	^ self basicNew
		itemsList: itemsList;
		itemsHeaderName: aName;
		wrapBlockOrSelector: aBlockOrSelector;
		initialize;
		title: aTitle;
		yourself! !

!TickDialogWindow class methodsFor: 'instance creation' stamp: ''!
itemsList: itemsList itemsHeaderName: aName title: aTitle

	^ self basicNew
		itemsList: itemsList;
		itemsHeaderName: aName;
		initialize;
		title: aTitle;
		yourself! !

!TickSelectionCheckboxButtonMorph commentStamp: ''!
A TickSelectionCheckboxButtonMorph is the button hidden into the TickSelectionCheckboxMorph!
!TickSelectionCheckboxButtonMorph methodsFor: 'event' stamp: ''!
mouseUp: evt
	"Handle the transitions."
	| result |
	result := super mouseUp: evt.
	self pressed: index.
	^ result! !

!TickSelectionCheckboxButtonMorph methodsFor: 'event' stamp: ''!
pressed: anIndex

	self owner pressed: anIndex! !

!TickSelectionCheckboxButtonMorph methodsFor: 'accessing' stamp: ''!
index: anIndex

	index := anIndex! !

!TickSelectionCheckboxMorph commentStamp: ''!
A TickSelectionCheckboxMorph is a checkbox which propagate a bit more the events!
!TickSelectionCheckboxMorph methodsFor: 'morph' stamp: ''!
newButtonMorph
	"Answer a new button morph"

	| instance |
	instance := TickSelectionCheckboxButtonMorph new
		target: self;
		actionSelector: #toggleSelected;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap.
		
	instance index: index.
	^ instance! !

!TickSelectionCheckboxMorph methodsFor: 'event' stamp: ''!
pressed: anIndex

	self owner owner pressed: anIndex! !

!TickSelectionCheckboxMorph methodsFor: 'accessing' stamp: ''!
index: anIndex

	index := anIndex! !

!TickSelectionListMorph commentStamp: ''!
A TickSelectionListMorph is used to render the tick list

storeValue
	- xxxxx
!
!TickSelectionListMorph methodsFor: 'event' stamp: ''!
basicKeyPressed: aCharacter

	aCharacter == Character space
		ifTrue: [ ^ self model toogleSelectionValue ].
	
	^ super basicKeyPressed: aCharacter! !

!TickSelectionListMorph methodsFor: 'accessing' stamp: ''!
storeValue: anObject
	
	storeValue := anObject! !

!TickSelectionListMorph methodsFor: 'accessing' stamp: ''!
indentingItemClass
	
	^ TickSelectionListNodeMorph! !

!TickSelectionListMorph methodsFor: 'accessing' stamp: ''!
mouseUp: event 

	self storeValue: nil.
	super mouseUp: event! !

!TickSelectionListMorph methodsFor: 'accessing' stamp: ''!
storeValue

	^ storeValue! !

!TickSelectionListNode commentStamp: ''!
A TickSelectionListNode is node for the tree used to render the tick list

selected
	- xxxxx
!
!TickSelectionListNode methodsFor: 'private' stamp: ''!
toogleSelectionValue
	
	self item toogleSelectionValue! !

!TickSelectionListNode methodsFor: 'morph' stamp: ''!
selectedMorph
	^ (TickSelectionCheckboxMorph basicNew index: (self model rootItems indexOf: self item);
		initialize;	
		model: self item;
		getStateSelector: #selected;
		setStateSelector: #selected:;
		updateSelection;
		getEnabledSelector: nil;
		font: StandardFonts defaultFont;
		label: '';
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		setBalloonText: nil) color: Color transparent; yourself! !

!TickSelectionListNode methodsFor: 'accessing' stamp: ''!
selected: aBoolean

	self item selected: aBoolean! !

!TickSelectionListNode methodsFor: 'morph' stamp: ''!
nameMorph

	^ LabelMorph new contents: self name; enabled: false; hResizing: #spaceFill;yourself! !

!TickSelectionListNode methodsFor: 'accessing' stamp: ''!
selected

	^ self item selected! !

!TickSelectionListNode methodsFor: 'private' stamp: ''!
name

	^ self item itemName asString! !

!TickSelectionListNode methodsFor: 'event' stamp: ''!
pressed: anIndex

	self model pressed: anIndex! !

!TickSelectionListNodeMorph commentStamp: ''!
A TickSelectionListNodeMorph is the morph used to render the tree used to render te tick list!
!TickSelectionListNodeMorph methodsFor: 'accessing' stamp: ''!
storeValue: aValue

	^ self owner owner storeValue: aValue! !

!TickSelectionListNodeMorph methodsFor: 'drawing' stamp: ''!
drawMouseDownHighlightOn: aCanvas
	"Draw with a dotted border."

	self highlightedForMouseDown 
		ifTrue: [
			container ifNil: [^super drawMouseDownHighlightOn: aCanvas].
			self storeValue ifNil: [ self storeValue: self complexContents selected not ].
			self complexContents selected: self storeValue.
			aCanvas 
				frameRectangle: self selectionFrame
				width: 1
				colors: {container mouseDownHighlightColor. Color transparent}
				dashes: #(1 1)]! !

!TickSelectionListNodeMorph methodsFor: 'event' stamp: ''!
pressed: anIndex 

	self complexContents pressed: anIndex! !

!TickSelectionListNodeMorph methodsFor: 'accessing' stamp: ''!
storeValue

	^ self owner owner storeValue! !

!TickingSpecWindow commentStamp: ''!
TickingSpecWindow new openInWorld!
!TickingSpecWindow methodsFor: 'stepping' stamp: ''!
step
	self model step.! !

!TickingSpecWindow methodsFor: 'stepping' stamp: ''!
wantsSteps
	^ true! !

!TickingSpecWindow methodsFor: 'stepping' stamp: ''!
stepTime

	^ self model stepTime! !

!TickingWindowPresenter commentStamp: ''!
In addition to my superclass, I provide an API to execute the #step method every #stepTime.!
!TickingWindowPresenter methodsFor: 'initialization' stamp: ''!
step
	self model step.! !

!TickingWindowPresenter methodsFor: 'stepping' stamp: ''!
stepTime
	^ self model stepTime! !

!TickingWindowPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(TickingWindowAdapter
		adapt: #(model))! !

!TickingWindowPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TickingWindowAdapter! !

!Time commentStamp: ''!
This represents a particular point in time during any given day.  For example, '5:19:45 pm'.

If you need a point in time on a particular day, use DateAndTime.  If you need a duration of time, use Duration.
!
!Time methodsFor: 'accessing' stamp: ''!
hours

	^ self hour! !

!Time methodsFor: 'comparing' stamp: ''!
< aTime

	^ self asDuration < aTime asDuration! !

!Time methodsFor: 'converting' stamp: ''!
asDuration 
	"Answer the duration since midnight"

	^ Duration seconds: seconds nanoSeconds: nanos! !

!Time methodsFor: 'comparing' stamp: ''!
= aTime

	^ [ self ticks = aTime ticks ]
		on: MessageNotUnderstood do: [false]! !

!Time methodsFor: 'converting' stamp: ''!
asMilliSeconds
	"Answer the number of milliseconds since midnight"

	^ self asDuration asMilliSeconds! !

!Time methodsFor: 'converting' stamp: ''!
asNanoSeconds
	"Answer the number of nanoseconds since midnight"

	^ self asDuration asNanoSeconds! !

!Time methodsFor: 'comparing' stamp: ''!
hash

	^ self ticks hash! !

!Time methodsFor: 'accessing' stamp: ''!
duration

	^ Duration zero! !

!Time methodsFor: 'accessing' stamp: ''!
nanoSecond 

	^ nanos! !

!Time methodsFor: 'printing' stamp: ''!
print24: hr24 on: aStream 
 	"Format is 'hh:mm:ss' or 'h:mm:ss am' "
 
 	| h m s |
	h := self hour. m := self minute. s := self second.
	hr24
		ifTrue: [ 
			h < 10 ifTrue: [ aStream nextPut: $0 ].
			h printOn: aStream ]
		ifFalse: [ 
			h > 12
				ifTrue: [ h - 12 printOn: aStream ]
				ifFalse: [
					h < 1
						ifTrue: [ 12 printOn: aStream ]
						ifFalse: [ h printOn: aStream ] ] ].
	aStream nextPutAll: (m < 10 ifTrue: [ ':0' ] ifFalse: [ ':' ]).
	m printOn: aStream.
	aStream nextPutAll: (s < 10 ifTrue: [ ':0' ] ifFalse: [ ':' ]).
	s printOn: aStream.
	hr24 ifFalse: [ aStream nextPutAll: (h < 12 ifTrue: [ ' am' ] ifFalse: [ ' pm' ]) ]! !

!Time methodsFor: 'private' stamp: ''!
seconds: secondCount nanoSeconds: nanoCount 
	"Private - only used by Time class."

	seconds := secondCount.
	nanos := nanoCount! !

!Time methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
to: anEnd
	"Answer a Timespan. anEnd must respond to #asDateAndTime"

	^ self asDateAndTime to: anEnd! !

!Time methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^ aGeneralMapper visitHookPrimitive: self
! !

!Time methodsFor: 'accessing' stamp: ''!
minute
	"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! !

!Time methodsFor: 'printing' stamp: ''!
printOn: aStream 

	self 
		print24: false
		showSeconds: (self seconds ~= 0 or: [ self nanoSecond ~= 0 ])
		on: aStream! !

!Time methodsFor: 'printing' stamp: ''!
print24
 	"Return as 8-digit string 'hh:mm:ss', with leading zeros if needed"
 
 	^ String new: 8 streamContents: [ :aStream | 
		self print24: true on: aStream ]! !

!Time methodsFor: 'adding' stamp: ''!
addTime: timeAmount
 	"Answer a Time that is timeInterval after the receiver. timeInterval is an 
 	instance of Date or Time."
 
 	^ self class seconds: self asSeconds + timeAmount asSeconds! !

!Time methodsFor: 'converting' stamp: ''!
asYear

	^ self asDateAndTime asYear! !

!Time methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	"Use an ISO style HH:MM:SS.N representation (with optional nanoseconds)"
	 
	stonWriter writeObject: self listSingleton: 
		(String streamContents: [ :stream |
			self print24: true showSeconds: true on: stream ])! !

!Time methodsFor: 'converting' stamp: ''!
asSeconds
 	"Answer the number of seconds since midnight of the receiver."
 
 	^ seconds! !

!Time methodsFor: 'accessing' stamp: ''!
second 
	"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)! !

!Time methodsFor: 'printing' stamp: ''!
printMinutes
 	"Return as string 'hh:mm pm'  "
 
 	^ String new: 8 streamContents: [ :aStream | 
		self print24: false showSeconds: false on: aStream ]! !

!Time methodsFor: 'accessing' stamp: ''!
ticks
	"Answer an Array: { seconds. nanoSeconds }"

	^ Array with: 0 with: seconds with: nanos.! !

!Time methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects 
	^ false! !

!Time methodsFor: '*Fuel-Core' stamp: ''!
serializeOn: anEncoder

	anEncoder 
		encodeUint24: self asSeconds;
		encodeUint32: self nanoSecond.
		! !

!Time methodsFor: 'converting' stamp: ''!
asDateAndTime

	^ DateAndTime today + self! !

!Time methodsFor: 'private' stamp: ''!
ticks: anArray
	"ticks is an Array: { days. seconds. nanoSeconds }"

	seconds := anArray at: 2.
	nanos := anArray at: 3! !

!Time methodsFor: 'accessing' stamp: ''!
meridianAbbreviation

	^ self hour < 12 ifTrue: ['AM'] ifFalse: ['PM'].! !

!Time methodsFor: 'converting' stamp: ''!
asDate

	^ Date today! !

!Time methodsFor: 'converting' stamp: ''!
asWeek

	^ self asDateAndTime asWeek! !

!Time methodsFor: 'converting' stamp: ''!
asTime

	^ self! !

!Time methodsFor: 'adding' stamp: ''!
subtractTime: timeAmount 
	"Answer a Time that is timeInterval before the receiver. timeInterval is  
	an instance of Date or Time."

	^ self class seconds: self asSeconds - timeAmount asSeconds! !

!Time methodsFor: 'accessing' stamp: ''!
hour

	^ self hour24! !

!Time methodsFor: 'printing' stamp: ''!
hhmm24
 	"Return a string of the form 1123 (for 11:23 am), 2154 (for 9:54 pm), of exactly 4 digits"
 
 	^ String new: 4 streamContents: [ :aStream | 
		self hour printOn: aStream base: 10 length: 2 padded: true.
		self minute printOn: aStream base: 10 length: 2 padded: true ]! !

!Time methodsFor: 'accessing' stamp: ''!
seconds

	^ self second! !

!Time methodsFor: 'accessing' stamp: ''!
hour24 
	"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! !

!Time methodsFor: 'converting' stamp: ''!
asMonth

	^ self asDateAndTime asMonth! !

!Time methodsFor: 'accessing' stamp: ''!
minutes

	^ self asDuration minutes! !

!Time methodsFor: 'printing' stamp: ''!
print24: hr24 showSeconds: showSeconds on: aStream 
	"Format is 'hh:mm:ss.nnnnnnnnn' or 'h:mm:ss.nnnnnnnnn am'  or, if showSeconds is false, 'hh:mm' or 'h:mm am'"

	| h m s |
	h := self hour. m := self minute. s := self second.
	hr24
		ifTrue: [ 
			h < 10 ifTrue: [ aStream nextPut: $0 ].
			h printOn: aStream ]
		ifFalse: [ 
			h > 12
				ifTrue: [ h - 12 printOn: aStream ]
				ifFalse: [
					h < 1
						ifTrue: [ 12 printOn: aStream ]
						ifFalse: [ h printOn: aStream ] ] ].
	aStream nextPutAll: (m < 10 ifTrue: [ ':0' ] ifFalse: [ ':' ]).
	m printOn: aStream.
	showSeconds 
		ifTrue: [
			aStream nextPutAll: (s < 10 ifTrue: [ ':0' ] ifFalse: [ ':' ]).
			s printOn: aStream.
			nanos = 0
				ifFalse: [ | 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 ] ].
	hr24 ifFalse: [ aStream nextPutAll: (h < 12 ifTrue: [ ' am' ] ifFalse: [ ' pm' ]) ]! !

!Time methodsFor: 'adding' stamp: ''!
addSeconds: nSeconds 
	"Answer a Time that is nSeconds after the receiver."

	^ self class seconds: self asSeconds + nSeconds! !

!Time methodsFor: 'accessing' stamp: ''!
hour12
 	"Answer an <integer> 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! !

!Time methodsFor: 'printing' stamp: ''!
storeOn: aStream
 
 	aStream print: self printString; nextPutAll: ' asTime'! !

!Time methodsFor: 'printing' stamp: ''!
intervalString
	"Treat the time as a difference.  Give it in hours and minutes with two digits of accuracy."

	| d |
	d := self asDuration.
	^ String streamContents: [ :s |
		d hours > 0 ifTrue: [s print: d hours; nextPutAll: ' hours'].
		d minutes > 0 ifTrue: [s space; print: d minutes; nextPutAll: ' minutes'].
		d seconds > 0 ifTrue: [s space; print: d seconds; nextPutAll: ' seconds'] ].! !

!Time methodsFor: 'private' stamp: ''!
seconds: secondCount
	"Private - only used by Time class."

	seconds := secondCount.
	nanos := 0! !

!Time class methodsFor: 'instance creation' stamp: ''!
new
	"Answer a Time representing midnight"

	^ self midnight! !

!Time class methodsFor: 'instance creation' stamp: ''!
current 

	^ self now! !

!Time class methodsFor: '*Fuel-Core' stamp: ''!
materializeFrom: aDecoder
	
	^ self 
		seconds: aDecoder nextEncodedUint24
		nanoSeconds: aDecoder nextEncodedUint32! !

!Time class methodsFor: 'instance creation' stamp: ''!
seconds: seconds nanoSeconds: nanoCount
	"Answer a Time from midnight."

	^ self basicNew
		ticks: (Duration seconds: seconds nanoSeconds: nanoCount) ticks! !

!Time class methodsFor: 'clock' stamp: ''!
secondsWhenClockTicks

	"waits for the moment when a new second begins"

	| lastSecond |

	lastSecond := self primUTCSecondsClock.
	[ lastSecond = self primUTCSecondsClock ] whileTrue: [ (Delay forMilliseconds: 1) wait ].
 
	^ lastSecond + 1! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
hour: hour minute: minute second: second
	"Answer a Time"
 
 	^ self hour: hour minute: minute second: second nanoSecond: 0! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
dateAndTimeFromSeconds: secondCountSinceEpoch
 
	| dateAndTime |
	dateAndTime := DateAndTime fromSeconds: secondCountSinceEpoch.
 	^ Array
 		with: dateAndTime asDate
 		with: dateAndTime asTime! !

!Time class methodsFor: 'primitives' stamp: ''!
primMillisecondClock
	"Primitive. Answer the number of milliseconds since the millisecond clock
	 was last reset or rolled over. Answer zero if the primitive fails.
	As an alternative you can use #primUTCMillisecondsClock which does not overflow."

	<primitive: 135>
	^ 0! !

!Time class methodsFor: 'primitives' stamp: ''!
primUTCMicrosecondsClock
	"Answer the number of micro-seconds ellapsed since epoch.
	That is since 00:00 on the morning of January 1, 1901 UTC.
	At least a 60-bit unsigned integer is used internally which is enough for dates up to year 38435.
	Essential. See Object documentation whatIsAPrimitive. "

	<primitive: 240>
	self primitiveFailed! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
milliseconds: currentTime since: lastTime
	"Answer the elapsed time since last recorded in milliseconds.
	Compensate for rollover."

	| delta |
	delta := currentTime - lastTime.
	^ delta < 0
		ifTrue: [SmallInteger maxVal + delta]
		ifFalse: [delta]! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
benchmarkMillisecondClock
	"Benchmark the time spent in a call to Time>>millisecondClockValue.
	On the VM level this tests the efficiency of calls to ioMSecs()."
	<script>
	
	"PII/400 Windows 98: 0.725 microseconds per call"	
	| temp1 temp2 temp3 delayTime nLoops time |
	delayTime := 5000. "Time to run benchmark is approx. 2*delayTime"

	"Don't run the benchmark if we have an active delay since
	we will measure the additional penalty in the primitive dispatch
	mechanism (see #benchmarkPrimitiveResponseDelay)."
	Delay anyActive ifTrue: [ 
		^ self notify: 'Some delay is currently active.
Running this benchmark will not give any useful result.' ].

	"Flush the cache for this benchmark so we will have
	a clear cache hit for each send to #millisecondClockValue below"
	Object flushCache.
	temp1 := 0.
	temp2 := self. "e.g., temp1 == Time"
	temp3 := self millisecondClockValue + delayTime.

	"Now check how often we can run the following loop in the given time"
	[ temp2 millisecondClockValue < temp3 ] whileTrue: [ 
		temp1 := temp1 + 1 ].

	nLoops := temp1. "Remember the loops we have run during delayTime"

	"Setup the second loop"
	temp1 := 0.
	temp3 := nLoops.

	"Now measure how much time we spend without sending #millisecondClockValue"
	time := Time millisecondClockValue.
	[ temp1 < temp3 ] whileTrue: [ temp1 := temp1 + 1 ].
	time := Time millisecondsSince: time.

	"And compute the number of microseconds spent per call to #millisecondClockValue"
	^ (delayTime - time * 1000.0 / nLoops truncateTo: 0.001) printString
	  , ' microseconds per call to Time>>millisecondClockValue'! !

!Time class methodsFor: 'primitives' stamp: ''!
primUTCMillisecondsClock
	"Answer the number of whole milliseconds ellapsed since epoch.
	That is since 00:00 on the morning of January 1, 1901 UTC"

	^self primUTCMicrosecondsClock // 1e3! !

!Time class methodsFor: 'accessing' stamp: ''!
microsecondsSince: lastTimeInMicroSeconds
 	"Answer the elapsed time since last recorded in microseconds"
 
 	^self microsecondClockValue - lastTimeInMicroSeconds! !

!Time class methodsFor: 'primitives' stamp: ''!
primUTCSecondsClock
	"Answer the number of whole seconds ellapsed since epoch.
	That is since 00:00 on the morning of January 1, 1901 UTC"

	^self primUTCMicrosecondsClock // 1e6! !

!Time class methodsFor: 'accessing' stamp: ''!
totalSeconds
	"Answer the total seconds ellapsed since the epoch: 1 January 1901 00:00 UTC"

	^ self primUTCSecondsClock! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
readFrom: aStream

	"Read a Time from the stream in the form:
		<hour>:<minute>:<second>.<nseconds> <am/pm>
	<minute>, <second> or <am/pm> may be omitted.  e.g. 1:59:30 pm; 8AM; 15:30"

	| hour minute second ampm nanos power |
	hour := Integer readFrom: aStream.
	minute := second := nanos := 0.
	(aStream peekFor: $:) ifTrue: [ 
		minute := Integer readFrom: aStream.
		(aStream peekFor: $:) ifTrue: [ 
			second := Integer readFrom: aStream.
			(aStream peekFor: $.) ifTrue: [ 
				power := 1.
				[ aStream atEnd not and: [ aStream peek isDigit ] ] whileTrue: [ 
					nanos := nanos * 10 + aStream next digitValue.
					power := power * 10 ].
				nanos := nanos / power * 1000000000 ] ] ].
	aStream skipSeparators.
	aStream atEnd ifFalse: [ 
		('APap' includes: aStream peek)
			ifTrue: [ 
				ampm := aStream next asLowercase.
				(ampm = $p and: [ hour < 12 ]) ifTrue: [ hour := hour + 12 ].
				(ampm = $a and: [ hour = 12 ]) ifTrue: [ hour := 0 ].
				(aStream peekFor: $m) ifFalse: [ aStream peekFor: $M ] ]
			ifFalse: [ 
				('Z+-' includes: aStream peek) ifFalse: [ 
					Error new signal: 'Trailing characters after time' ] ] ].

	aStream skipSeparators.
	aStream atEnd ifFalse: [  
	    ('Z+-' includes: aStream peek) ifFalse: [ 
					Error new signal: 'Trailing characters after time' ]].
	
	^ self
		  hour: hour
		  minute: minute
		  second: second
		  nanoSecond: nanos! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
millisecondsToRun: timedBlock 
	"Answer the number of milliseconds timedBlock takes to return its value."

	^(self microsecondsToRun: timedBlock) // 1e3! !

!Time class methodsFor: 'instance creation' stamp: ''!
nowUTC
	"Answer the time since midnight in UTC timezone"

	| microSecondsToday |
	microSecondsToday := self primUTCMicrosecondsClock \\ MicrosecondsInDay.
	^ self 
		seconds: microSecondsToday // 1000000 
		nanoSeconds: microSecondsToday \\ 1000000 * 1000! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
fromString: aString
	^ self readFrom: aString readStream.! !

!Time class methodsFor: 'primitives' stamp: ''!
microsecondClockValue
	"Answer the number of microseconds since Epoch"

	^self primUTCMicrosecondsClock! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
noon

	^ self seconds: (SecondsInDay / 2)! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
benchmarkPrimitiveResponseDelay	 
	"Benchmark the overhead for primitive dispatches with an active Delay.
	On the VM level, this tests the efficiency of ioLowResMSecs."
	<script>
	
	"PII/400 Windows98: 0.128 microseconds per prim"
	
	"ar 9/6/1999: This value is *extremely* important for stuff like sockets etc.
	I had a bad surprise when Michael pointed this particular problem out:
	Using the hardcoded clock() call for ioLowResMSecs on Win32 resulted in an overhead
	of 157.4 microseconds per primitive call - meaning you can't get no more than
	approx. 6000 primitives per second on my 400Mhz PII system with an active delay!!
	BTW, it finally explains why Squeak seemed soooo slow when running PWS or 
	other socket stuff. The new version (not using clock() but some Windows function) 
	looks a lot better (see above; approx. 8,000,000 prims per sec with an active delay)."

	| nLoops bb index baseTime actualTime delayTime |
	delayTime := 5000. "Time to run this test is approx. 3*delayTime"

	Delay anyActive ifTrue:[
		^self notify:'Some delay is currently active.
Running this benchmark will not give any useful result.'].

	bb := Array new: 1. "The object we send the prim message to"

	"Compute the # of loops we'll run in a decent amount of time"
	[(Delay forMilliseconds: delayTime) wait] 
		forkAt: Processor userInterruptPriority.

	nLoops := 0.
	[Delay anyActive] whileTrue:[
		bb basicSize; basicSize; basicSize; basicSize; basicSize; 
			basicSize; basicSize; basicSize; basicSize; basicSize.
		nLoops := nLoops + 1.
	].

	"Flush the cache and make sure #basicSize is in there"
	Object flushCache.
	bb basicSize.

	"Now run the loop without any active delay
	for getting an idea about its actual speed."
	baseTime := self millisecondClockValue.
	index := nLoops.
	[index > 0] whileTrue:[
		bb basicSize; basicSize; basicSize; basicSize; basicSize; 
			basicSize; basicSize; basicSize; basicSize; basicSize.
		index := index - 1.
	].
	baseTime := self millisecondsSince: baseTime.

	"Setup the active delay but try to never make it active"
	[(Delay forMilliseconds: delayTime + delayTime) wait] 
		forkAt: Processor userInterruptPriority.

	"And run the loop"
	actualTime := self millisecondClockValue.
	index := nLoops.
	[index > 0] whileTrue:[
		bb basicSize; basicSize; basicSize; basicSize; basicSize; 
			basicSize; basicSize; basicSize; basicSize; basicSize.
		index := index - 1.
	].
	actualTime := self millisecondsSince: actualTime.

	"And get us some result"
	^((actualTime - baseTime) * 1000 asFloat / (nLoops * 10) truncateTo: 0.001) printString,
		' microseconds overhead per primitive call'! !

!Time class methodsFor: 'instance creation' stamp: ''!
fromSeconds: secondCount
	"Answer an instance of me that is secondCount number of seconds since midnight."

	| integerSeconds nanos |
	integerSeconds := secondCount truncated.
	nanos := integerSeconds = secondCount
		ifTrue: [ 0 ]
		ifFalse: [ ((secondCount - integerSeconds) * NanosInSecond) asInteger ].
	^ self seconds: integerSeconds nanoSeconds: nanos! !

!Time class methodsFor: 'primitives' stamp: ''!
millisecondClockValue
	"Answer the number of milliseconds since the millisecond clock was last reset or rolled over.
	Answer 0 if the primitive fails."

	<primitive: 135>
	^ 0! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
midnight

	^ self seconds: 0! !

!Time class methodsFor: 'instance creation' stamp: ''!
now
	"Answer a Time representing the time right now - this is a 24 hour clock."
	
	^ self nowLocal! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
millisecondsSince: lastTime
 	"Answer the elapsed time since last recorded in milliseconds.
 	Compensate for rollover."
 
 	^self milliseconds: self millisecondClockValue since: lastTime! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
hour: hour minute: minute second: second  nanoSecond: nanoCount
	"Answer a Time - only second precision for now"
	
	hour >= HoursInDay ifTrue: [ Error new signal: ('An hour must be {1} or less' format: {HoursInDay})].
	minute >= MinutesInHour ifTrue: [ Error new signal: ('A minute must be {1} or less' format: {MinutesInHour}) ].
	second > SecondsInMinute ifTrue: [ Error new signal: ('A second must be {1} or less' format: {SecondsInMinute}) ].
	
 	^ self 
		seconds: (hour * SecondsInHour) + (minute * SecondsInMinute) + second 
		nanoSeconds: nanoCount! !

!Time class methodsFor: '*STON-Core' stamp: ''!
fromSton: stonReader
	^ self readFrom: stonReader parseListSingleton readStream! !

!Time class methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
hour: hour minute: minute second: second  nano: nano
 
	| nanoMultiplicative |
	
	nanoMultiplicative := 1000000000 / (10 ** nano numberOfDigits).	
	
 	^ self hour: hour minute: minute second: second nanoSecond: nano * nanoMultiplicative! !

!Time class methodsFor: 'instance creation' stamp: ''!
nowLocal
	"Answer the time since midnight in local timezone"

	| microSecondsToday |
	microSecondsToday := self primUTCMicrosecondsClock.
	^ self
		seconds: microSecondsToday // 1000000 + DateAndTime localTimeZone offset asSeconds \\ SecondsInDay
		nanoSeconds: microSecondsToday \\ 1000000 * 1000! !

!Time class methodsFor: 'general inquiries' stamp: ''!
microsecondsToRun: timedBlock 
	"Answer the number of milliseconds timedBlock takes to return its value."

	| initialMicroseconds |
	initialMicroseconds := self microsecondClockValue.
	timedBlock value.
	^self microsecondClockValue - initialMicroseconds! !

!Time class methodsFor: 'instance creation' stamp: ''!
seconds: seconds
	"Answer a Time from midnight."

	^ self basicNew ticks: (Duration seconds: seconds) ticks! !

!TimeMeasuringTest methodsFor: 'performance' stamp: ''!
reportPerformance
	| str |
	str := ZnNewLineWriterStream on: (ZnCharacterWriteStream
			on: (File openForWriteFileNamed: 'performanceReports.txt')
			encoding: 'utf8').
	
	str setToEnd;
		nextPutAll: ' test: ', testSelector;
		nextPutAll: ' time: ', realTime asString; 
		nextPutAll: ' version: ', self versionInformation;
		cr; 
		close! !

!TimeMeasuringTest methodsFor: 'debugging' stamp: ''!
openDebuggerOnFailingTestMethod
	shouldProfile := true! !

!TimeMeasuringTest methodsFor: 'accessing' stamp: ''!
workingCopyPredicate
	^[:e | '*Traits*' match: e package name]! !

!TimeMeasuringTest methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	shouldProfile := false.! !

!TimeMeasuringTest methodsFor: 'accessing' stamp: ''!
versionInformation
	| wcPredicate |
	wcPredicate := self workingCopyPredicate.
	^self versionInfoForWorkingCopiesThat: wcPredicate! !

!TimeMeasuringTest methodsFor: 'performance' stamp: ''!
measure: measuredBlock 
	shouldProfile 
		ifTrue: [Smalltalk tools timeProfiler onBlock: [10 timesRepeat: measuredBlock]].
	realTime := measuredBlock timeToRun! !

!TimeMeasuringTest methodsFor: 'debugging' stamp: ''!
debug
	self resources do: [:res | 
		res isAvailable ifFalse: [^res signalInitializationError]].
	[(self class selector: testSelector) setToDebug; runCase] 
		ensure: [self resources do: [:each | each reset]]
			! !

!TimeMeasuringTest methodsFor: 'private' stamp: ''!
instanceVariablesToKeep

	^ super instanceVariablesToKeep , #(shouldProfile)! !

!TimeMeasuringTest methodsFor: 'running' stamp: ''!
runCase
	[super runCase] ensure: [self reportPerformance]! !

!TimeMeasuringTest methodsFor: 'utilities' stamp: ''!
versionInfoForWorkingCopiesThat: wcPredicate 
	^(MCWorkingCopy allManagers select: wcPredicate) inject: ''
		into: [:s :e | s , e description]! !

!TimeMeasuringTest methodsFor: 'debugging' stamp: ''!
setToDebug
	shouldProfile := true
! !

!TimeProfiler commentStamp: ''!
TimeProfiler is a graphical front end of MessageTally. It gives nice facilities to navigate and browse a profile.

Use examples:
TimeProfiler new open
TimeProfiler new openOnBlock: [SimpleGridExample new open]
TimeProfiler new openOnBlock: [ClassTreeExample new openOn: Object]
 MessageTally spyAllOn: [ClassTreeExample new openOn: Object]!
!TimeProfiler methodsFor: 'ui specific' stamp: ''!
contentsSelection
	"Return the interval of text in the code pane to select when I set the pane's contents"

	^ 1 to: 0		"null selection"! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
correctFrom: start to: stop with: aString
	^ blockCodePane correctFrom: start to: stop with: aString! !

!TimeProfiler methodsFor: 'accessing' stamp: ''!
selectedClass
	^ self selectedNode 
		ifNotNil: [ :currNode | currNode methodClass ]! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
minPercentageToExpand: aPercentage
	minPercentageToExpand := aPercentage.
	self changed: #minPercentageToExpand
! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
treeMorph
	^ (self treeMorphClass on: self)
		rowInset: 2;
		columnInset: 4;
		autoDeselection: true;
		getMenuSelector:#menu:shifted:;
		keyDownActionSelector: #keyDown:from:;
		treeLineWidth: 1;
		treeLineDashes: {5. 1};
		lineColorBlock: [:node | {Color gray. Color orange. Color brown. Color magenta. Color blue} at: ((node level \\ 5) + 1)];
		doubleClickSelector: #browseItem;
		rowColorForEven: self theme lightBackgroundColor;
		yourself
! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
codePaneMenu: aMenu shifted: shifted 
	"Note that unless we override perform:orSendTo:, 
	PluggableTextController will respond to all menu items in a 
	text pane"
	| donorMenu |
   donorMenu := (PragmaMenuBuilder pragmaKeyword: RubSmalltalkCodeMode menuKeyword model: codeTabPane) menu.
	^ aMenu addAllFrom: donorMenu! !

!TimeProfiler methodsFor: 'accessing - computed' stamp: ''!
leaveItems
	| res  |
	res := OrderedCollection new.
	rootMessageTally
		ifNotNil: [ 
			| dict |
			dict := IdentityDictionary new: 100.
			rootMessageTally leavesInto: dict fromSender: nil.
			res addAll: (dict asOrderedCollection select: [ :node | node tally > self threshold ]) ].
	^ res! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
deselect
	blockCodePane deselect! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
showLeavesOnly: aBoolean
	self showLeavesOnly ~= aBoolean
		ifFalse: [ ^ self ].
	treeMorph
		treeLineWidth:
			(aBoolean
				ifTrue: [ 0 ]
				ifFalse: [ 1 ]).
	showLeavesOnly := aBoolean.
	self changed: #showLeavesOnly.
	self updateList! !

!TimeProfiler methodsFor: 'accessing' stamp: ''!
rootNodeClassFromItem: anItem
	^ TimeProfilerNode ! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
withToolBar: aBoolean
	withToolBar := aBoolean! !

!TimeProfiler methodsFor: 'configuration' stamp: ''!
helpMessage

^'You can edit some code in the top editor and accept to profile it.
The result consists in a tree of method calls shown in the middle panel.
Select a method call to see or change its implementation in the bottom editor.

Tallies building:
The tallies are built according to the time threshold value that you can change at the top right (Treshold input field).

Tree expanding:
A tree node is expanded only if its duration percentage is greater that the minimum value that you can change at the top left (Min duration percentage input field). 
'! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
runBlock: aBlock 
	^ self runBlock: aBlock pollingEvery: MessageTally defaultPollPeriod! !

!TimeProfiler methodsFor: 'accessing' stamp: ''!
selection: aSelection
	super selection: aSelection.
	self changed: #selectedMethodCode
! !

!TimeProfiler methodsFor: 'compiling' stamp: ''!
selectedMethodCode: aString notifying: aController
	"Compile the code in aString. Notify aController of any syntax errors. 
	Answer false if the compilation fails. Otherwise answer true."

	^ self selectedNode
		ifNil: [ false ]
		ifNotNil: [ :currNode | 
			| class oldSelector category newSelector |
			class := currNode methodClass.
			oldSelector := currNode selector.
			class ifNil: [ ^ false ].	"Normal method accept"
			category := class organization categoryOfElement: oldSelector.
			newSelector := class compile: aString classified: category notifying: aController.
			newSelector ifNil: [ ^ false ].
			self changed: #selectedMethodCode.
			true ]! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
whatToShow: aSymbol
	self showLeavesOnly: aSymbol = #'Leaves'! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
expandAll
	treeMorph expandAllSuchThat: [:node | node percentage > self minPercentageToExpand]! !

!TimeProfiler methodsFor: 'configuration' stamp: ''!
initialExtent
	^ 750 @ 700! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
shoutAboutToStyle: aPluggableShoutMorphOrView 
	self selectedNode
		ifNotNil: [ :currNode | 
			aPluggableShoutMorphOrView getTextSelector = #selectedMethodCode
				ifTrue: [aPluggableShoutMorphOrView classOrMetaClass: currNode methodClass.
					^ true]].
	aPluggableShoutMorphOrView getTextSelector = #summaryText
			ifTrue: [^ false].
	aPluggableShoutMorphOrView getTextSelector = #blockCode
			ifTrue: [^ true].
	 ^ false
! !

!TimeProfiler methodsFor: 'accessing' stamp: ''!
tally
	^ rootMessageTally tally! !

!TimeProfiler methodsFor: 'configuration' stamp: ''!
toolName
	^ 'Time profiler'! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
notify: aString at: anInteger in: aStream
	blockCodePane notify: aString at: anInteger - 'self runBlock: [' size in: aStream ! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
reportOtherProcesses: aBoolean
	self reportOtherProcesses ~= aBoolean
		ifFalse: [ ^ self ].
	reportOtherProcesses := aBoolean.
	self changed: #reportOtherProcesses.
	self updateList! !

!TimeProfiler methodsFor: 'accessing' stamp: ''!
threshold
	^ threshold ifNil: [threshold := 0]! !

!TimeProfiler methodsFor: 'accessing' stamp: ''!
threshold: aTreshold
	(aTreshold ~= threshold and: [ aTreshold between: 0 and: 1000 ])
		ifFalse: [ ^ self ].
	threshold := aTreshold.
	self updateList.
	self changed: #threshold! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
withBlockCodePane: aBoolean
	withBlockCodePane := aBoolean! !

!TimeProfiler methodsFor: 'public opening' stamp: ''!
openOnBlock: aBlock 
	self runBlock: aBlock pollingEvery: MessageTally defaultPollPeriod.
	self open.
	^ self! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
toolBarOn: aWindow
	| uiTheme toolBar |
	uiTheme :=self theme.
	toolBar := toolBar := aWindow
		newToolbar:
			{((uiTheme
				newButtonIn: self
				for: self
				getState: nil
				action: #profileIt
				arguments: {}
				getEnabled: nil
				getLabel: nil
				help: nil)
				label:
					(uiTheme
						newRowIn: self
						for:
							{(AlphaImageMorph new
								image: (self iconNamed: #smallDoItIcon)).
							(uiTheme buttonLabelForText: 'Profile it' translated)});
				yourself).
			aWindow newToolSpacer.
			aWindow newToolSpacer.
			(aWindow newLabel: 'Min time % ' translated).
			(uiTheme
				newTextEntryIn: aWindow
				for: self
				get: #minPercentageToExpand
				set: #minPercentageToExpand:
				class: Float
				getEnabled: nil
				help: nil).
			aWindow newToolSpacer.
			aWindow newToolSpacer.
			(aWindow newLabel: 'Threshold: ' translated).
			(uiTheme
				newTextEntryIn: aWindow
				for: self
				get: #threshold
				set: #threshold:
				class: Integer
				getEnabled: nil
				help: nil).
			aWindow newToolSpacer.
			aWindow newToolSpacer.
			(aWindow
				newDropListFor: self
				list: #whatToShowList
				getSelected: #whatToShow
				setSelected: #whatToShow:
				getEnabled: nil
				useIndex: false
				help: 'Which kind of result').
			aWindow newToolSpacer.
			aWindow newToolSpacer.
			(uiTheme
				newCheckboxIn: self
				for: self
				getSelected: #reportOtherProcesses
				setSelected: #reportOtherProcesses:
				getEnabled: nil
				label: 'All processes'
				help: nil).
			aWindow newToolSpacer}.
	^ toolBar! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
selectFrom: start to: stop
	blockCodePane  selectFrom: start to: stop! !

!TimeProfiler methodsFor: 'public opening' stamp: ''!
open
	"Public method. This method simply open a time profiler"

	| toolBar codePane vgap summaryPane blkPaneGap treeTopFraction treeTabPane fullReportPane |
	win := StandardWindow new model: self.
	win setLabel: self toolName.
	toolBar := self toolBarOn: win.
	treeMorph := self treeMorph
		buildContents;
		yourself.
	summaryPane := win
		newTextEditorFor: self
		getText: #summaryText
		setText: nil
		getEnabled: nil.
	fullReportPane := win
		newTextEditorFor: self
		getText: #fullReport
		setText: nil
		getEnabled: nil.
	fullReportPane getMenuSelector: #fullReportMenu:shift:.
	codePane := win
		newTextEditorFor: self
		getText: #selectedMethodCode
		setText: #selectedMethodCode:notifying:
		getEnabled: nil.

	codePane getMenuSelector: #codePaneMenu:shifted:.
	codePane font: StandardFonts codeFont.
	self withToolBar
		ifTrue: [ 
			vgap := toolBar minExtent y.
			win addMorph: toolBar fullFrame: ((0 @ 0 corner: 1 @ 0) asLayoutFrame bottomOffset: vgap) ]
		ifFalse: [ vgap := 0 ].
	blkPaneGap := 0.
	treeTopFraction := 0.0.
	self withBlockCodePane
		ifTrue: [ 
			blkPaneGap := 10.
			treeTopFraction := 0.15.
			blockCodePane := win
				newTextEditorFor: self
				getText: #blockCode
				setText: #blockCode:notifying:
				getEnabled: nil.
			blockCodePane getMenuSelector: #codePaneMenu:shifted:.
			blockCodePane font: StandardFonts codeFont.
			blockCodePane alwaysAccept: true.
			win
				addMorph: blockCodePane
				fullFrame:
					((0 @ 0 corner: 1 @ treeTopFraction) asLayoutFrame
						topOffset: vgap;
						bottomOffset: vgap + blkPaneGap) ].
	treeTabPane := win
		newTabGroup:
			{('Tallies Tree' -> treeMorph).
			('Full report' -> fullReportPane)}.
	win addMorph: treeTabPane fullFrame: ((0 @ treeTopFraction corner: 1 @ 0.6) asLayoutFrame topOffset: vgap + blkPaneGap).
	win
		addMorph:
			(codeTabPane := win
				newTabGroup:
					{('Code' -> codePane).
					('Statistics' -> summaryPane)})
		fullFrame: (0 @ 0.6 corner: 1 @ 1) asLayoutFrame.
	win openInWorld.
	self startState! !

!TimeProfiler methodsFor: 'accessing - computed' stamp: ''!
resultText
	^ result printString
! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
runProcess: aProcess forMilliseconds: msecDuration pollingEvery: pollPeriod 
	block := MessageSend 
				receiver: self
				selector: #runProcess:forMilliseconds:pollingEvery: 
				arguments: { 
						aProcess.
						msecDuration.
						pollPeriod}.	"so we can re-run it"
	rootMessageTally := MessageTally new.
	rootMessageTally
		reportOtherProcesses: false;
		maxClassNameSize: 1000;
		maxClassPlusSelectorSize: 1000;
		maxTabs: 100.
	result := rootMessageTally 
				spyEvery: pollPeriod
				onProcess: aProcess
				forMilliseconds: msecDuration.
	^result! !

!TimeProfiler methodsFor: 'accessing' stamp: ''!
result: anObject
	result := anObject
! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
select
	blockCodePane select! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
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! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
profileIt
	blockCodePane accept.
	! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
minPercentageToExpand
	^ minPercentageToExpand ifNil: [minPercentageToExpand := 3.0]! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
showResult: anObject
	self result: anObject.
	resultPane
		ifNil: [resultPane := win
			newTextEditorFor: self
			getText: #resultText
			setText: nil
			getEnabled: nil.
			codeTabPane addPage: resultPane label: 'Result']
		ifNotNil: [self changed: #resultText]

	! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
runBlock: aBlock pollingEvery: pollPeriod 
	block := aBlock.
	rootMessageTally := MessageTally new.
	rootMessageTally
		reportOtherProcesses: true;
		maxClassNameSize: 1000;
		maxClassPlusSelectorSize: 1000;
		maxTabs: 100.
	result := rootMessageTally spyEvery: pollPeriod on: aBlock.
	self result: result.
	^ result
! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
selectInvisiblyFrom:  first to:  last
	blockCodePane selectInvisiblyFrom: first to: last.! !

!TimeProfiler methodsFor: 'configuration' stamp: ''!
whatToShowList
	^ #(#'Full tree' #'Leaves')! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
withToolBar
	^ withToolBar ifNil: [withToolBar := true]! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
withBlockCodePane
	^ withBlockCodePane ifNil: [withBlockCodePane := true]! !

!TimeProfiler methodsFor: 'accessing - computed' stamp: ''!
fullReport
	"Return the full report of the tally "
	^ String streamContents: [:strm |
		rootMessageTally 
			ifNotNil: [ rootMessageTally report: strm ] ]! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
spyAllOn: aBlock 
	block := aBlock.
	rootMessageTally := MessageTally new.
	rootMessageTally
		reportOtherProcesses: true;
		maxClassNameSize: 1000;
		maxClassPlusSelectorSize: 1000;
		maxTabs: 100.
	result := rootMessageTally spyAllEvery: MessageTally defaultPollPeriod on: aBlock.
	self result: result.
	^ result
! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
browseItem
	self selectedNode ifNotNil: [:current | current browseItem ].
! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
doItContext
	"Answer the context in which a text selection can be evaluated."

	^nil! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
showLeavesOnly 
	^ showLeavesOnly ifNil: [showLeavesOnly := false]! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
blockCode: aString notifying: aRequestor
	"Treat the current selection as an expression; evaluate and tally it."
	|  compiledMethod |
	aString ifNil: [^ self].
	blockSource := aString.
	compiledMethod := Smalltalk compiler
		source: ('self runBlock: [', aString, ']');
		context: self doItContext;
		requestor: self;
		noPattern: true;
		failBlock: [^self];
		compile.
	self showResult: ( compiledMethod valueWithReceiver: self arguments: #()).
	self changed: #blockCode.
	self changed: #summaryText.
	self changed: #fullReport.
	self selection: nil.
	self updateList.
	self startState.
	

	! !

!TimeProfiler methodsFor: 'accessing - computed' stamp: ''!
selectedMethodCode
	| node method |
	node := self selectedNode.
	node ifNil: [ ^ self helpMessage ].
	method := (node methodClass lookupSelector: node selector) ifNil: [ ^'Method not found' ].
	^method sourceCode! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
startState
	treeMorph expandAllSuchThat: [:node | node percentage > self startMinPercentageToExpand]
	! !

!TimeProfiler methodsFor: 'accessing - computed' stamp: ''!
summaryText
	^ String streamContents: [:strm | rootMessageTally 
		ifNotNil: [rootMessageTally time > 0 
			ifTrue: [strm nextPutAll: ' - '; print: rootMessageTally tally; nextPutAll: ' tallies, ', rootMessageTally time printString, ' msec.'; cr.
				rootMessageTally reportGCStatsOn: strm]]]
! !

!TimeProfiler methodsFor: 'accessing' stamp: ''!
time
	^ rootMessageTally time! !

!TimeProfiler methodsFor: 'public opening' stamp: ''!
openPathFrom: aNode
	self expandNodePath: aNode path! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
reportOtherProcesses
	^ reportOtherProcesses ifNil: [reportOtherProcesses := true]
! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
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 addLine.
			menu
				add: 'Expand all from here'
				target: self
				selector: #expandAllFromNode:
				argument: current ].
	^ menu! !

!TimeProfiler methodsFor: 'accessing - computed' stamp: ''!
rootTallyItems
	| res sons groups |
	res := OrderedCollection new.
	rootMessageTally
		ifNotNil: [ 
			sons := rootMessageTally sonsOver: self threshold.
			groups := sons groupedBy: [ :aTally | aTally process ] having: [ :g | true ].
			groups
				do: [ :g | 
					self reportOtherProcesses
						ifTrue: [ res addAll: g ]
						ifFalse: [ res addAll: (g asSortedCollection reject: [ :gg | gg process isNil ]) ] ] ].
	^ res! !

!TimeProfiler methodsFor: 'configuration' stamp: ''!
startMinPercentageToExpand
	^ 20! !

!TimeProfiler methodsFor: 'actions' stamp: ''!
blockCode
	^ block
		ifNil: ['']
		ifNotNil: [ blockSource ifNil: [ blockSource := block asString ]]! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
whatToShow
	^ self showLeavesOnly ifTrue: [#'Leaves'] ifFalse: [#'Full tree']! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
keyDown: anEvent from: aTreeMorph 
	self selectedNode ifNotNil: [:current | current keyDown: anEvent from: aTreeMorph ]! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
fullReportMenu: aMenuMorph shift: aBoolean
	^ (PragmaMenuBuilder 
		pragmaKeyword: 'TimeProfilerFullReportMenu'
		model: self) menu ! !

!TimeProfiler methodsFor: 'accessing - computed' stamp: ''!
rootItems
	^ rootMessageTally
		ifNil: [#()]
		ifNotNil: [
			self showLeavesOnly 
				ifTrue: [ self leaveItems ]
				ifFalse: [ self rootTallyItems]]! !

!TimeProfiler methodsFor: 'ui specific' stamp: ''!
selectionInterval
	^ 1 to: 0! !

!TimeProfiler methodsFor: 'accessing' stamp: ''!
text
	^ blockSource! !

!TimeProfiler class methodsFor: 'examples' stamp: ''!
example

	[1000 timesRepeat: [3.14159 printString. Processor yield]] fork.
	[1000 timesRepeat: [20 factorial. Processor yield]] fork.
	[1000 timesRepeat: [20 factorial. Processor yield]] fork.
	self spyAllOn: [ (Delay forMilliseconds: 100) wait]! !

!TimeProfiler class methodsFor: 'examples' stamp: ''!
exampleOnBlock

	TimeProfiler onBlock: [ 20 timesRepeat: [self trace: 100 factorial printString]]! !

!TimeProfiler class methodsFor: 'world menu' stamp: ''!
menuProfilingOn: aBuilder
	<worldMenu>

	(aBuilder item: #'Start profiling all Processes')
		parent: #Profiling;
		help: 'Profile all Pharo processes.';
		order: 10;
		action: [ self currentWorld worldState startMessageTally ].
	(aBuilder item: #'Start profiling UI ')
		parent: #Profiling;
		help: 'Profile the UI process of Pharo.';
		order: 20;
		action: [ self currentWorld worldState startThenBrowseMessageTally ].! !

!TimeProfiler class methodsFor: 'opening' stamp: ''!
spyFor: seconds
	"Run the system profiler for the specified number of seconds"
 
	^self spyOn: [ (Delay forSeconds: seconds) wait ].! !

!TimeProfiler class methodsFor: 'icons' stamp: ''!
taskbarIconName
	^#smallProfileIcon! !

!TimeProfiler class methodsFor: 'opening' stamp: ''!
spyOn: aBlock 
	^ (self new withBlockCodePane: false; withToolBar: false; yourself)
		openOnBlock: aBlock ! !

!TimeProfiler class methodsFor: 'opening' stamp: ''!
onBlock: block
	"Open a profile browser on the given block, thereby running the block and 
	 collecting the message tally."

	| inst result |
	inst := self new.
	result := inst runBlock: block.
	inst open.
	inst showResult: result.
	^ result! !

!TimeProfiler class methodsFor: 'tools-registry' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]" 
	registry register: self as: #timeProfiler! !

!TimeProfiler class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder 
	<worldMenu>
	(aBuilder item: #'Time Profiler')
		parent: #Profiling;  
		order: 1;
		icon: self taskbarIcon;
		help: 'Profile the execution of a piece of code and navigate into the result.';
		action: [TimeProfiler new open]! !

!TimeProfiler class methodsFor: 'opening' stamp: ''!
fullReportMenuOn: aBuilder
	"Specify the menu with a specific pragma. Try it with:
	(PragmaMenuBuilder 
		pragmaKeyword: 'TimeProfilerFullReportMenu'
		model: nil) menu popUpInWorld"

	<contextMenu>
	<TimeProfilerFullReportMenu>
	(aBuilder item: #'Find...' translated)
		keyText: 'f';
		selector: #find;
		iconName: #smallFindIcon.
	(aBuilder item: #'Find again' translated)
		keyText: 'g';
		selector: #findAgain;
		iconNamed: #smallFindIcon.
	(aBuilder item: #'Set search string' translated)
		keyText: 'h';
		selector: #setSearchString.
	(aBuilder item: #Copy translated)
		keyText: 'c';
		selector: #copySelection;
		iconName: #smallCopyIcon! !

!TimeProfiler class methodsFor: 'opening' stamp: ''!
spyAllOn: aBlock
	"Spy on all the processes in the system"
	| inst result |
	inst := self new.
	result := inst spyAllOn: aBlock.
	inst open.
	inst showResult: result.
	^ result! !

!TimeProfiler class methodsFor: 'opening' stamp: ''!
spyOnProcess: aProcess forMilliseconds: msecDuration 
	"Run aProcess for msecDuration milliseconds, then open a TimeProfiler on the results."

	| inst |
	inst := self new.
	inst withBlockCodePane: false.
	inst runProcess: aProcess forMilliseconds: msecDuration pollingEvery: MessageTally defaultPollPeriod.
	inst open.
	^ inst! !

!TimeProfilerNode commentStamp: ''!
A TimeProfilerNode represents a node in the tally tree!
!TimeProfilerNode methodsFor: 'accessing - computed' stamp: ''!
methodClass
	^self item method methodClass 
	! !

!TimeProfilerNode methodsFor: 'actions' stamp: ''!
exploreItem
	self item inspect! !

!TimeProfilerNode methodsFor: 'accessing - computed' stamp: ''!
selector
	^self item method selector 
	! !

!TimeProfilerNode methodsFor: 'ui specific' stamp: ''!
menu: menu shifted: b 
	menu
		add: 'Browse (b)'
		target: self
		selector: #browseItem.
	menu
		add: 'Inspect (i)'
		target: self
		selector: #inspectItem.
	menu
		add: 'Explore (I)'
		target: self
		selector: #exploreItem.
! !

!TimeProfilerNode methodsFor: 'printing' stamp: ''!
asString
	^ String streamContents: [:s | self item printOn: s total: model tally totalTime: model time tallyExact: false] ! !

!TimeProfilerNode methodsFor: 'accessing - computed' stamp: ''!
childrenItems
	^ (self item sonsOver: model threshold) asSortedCollection! !

!TimeProfilerNode methodsFor: 'ui specific' stamp: ''!
keyDown: 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
! !

!TimeProfilerNode methodsFor: 'accessing - computed' stamp: ''!
percentage 
	^ self item tally asFloat / model time * 100.0 roundTo: 0.1.
! !

!TimeProfilerNode methodsFor: 'actions' stamp: ''!
browseItem
	Smalltalk tools browser
		openOnClass: self methodClass  selector: self selector! !

!TimeProfilerNode methodsFor: 'actions' stamp: ''!
inspectItem
	self item inspect! !

!TimeStampMethodConverter commentStamp: ''!
A TimeStampMessageConverter is a wrapper wich display the timestamp of the provided message!
!TimeStampMethodConverter methodsFor: 'private' stamp: ''!
internalGetText
	| list |
	list := method stamp substrings.
	list ifEmpty: [ ^ 'No information available' ].
	^ self formattedModificationTextFor:(list first) atStamp:(list allButFirst joinUsing:' ')
! !

!TimeStampMethodConverter methodsFor: 'private' stamp: ''!
formattedModificationTextFor:aUser atStamp:aTimeStampString
|stamp|
stamp:= DateAndTime fromString:aTimeStampString.
^ String streamContents:[ :s |
			s << 'Last Modification :' << Character cr.
			s << Character tab << 'date:' << Character tab << stamp asDate asString << Character space << stamp asTime asString << Character cr.
 			s << Character tab << 'by:' << Character tab << Character tab << aUser ]! !

!TimeTest commentStamp: ''!
This is the unit test for the class Time.

!
!TimeTest methodsFor: 'tests' stamp: ''!
testAsSeconds
	self assert: aTime asSeconds equals: 45296! !

!TimeTest methodsFor: 'tests - input' stamp: ''!
testReadFrom
	| string t |
	string := '4:02:47 am'.
	t := self timeClass readFrom: string readStream.
	self assert: time printString equals: t printString! !

!TimeTest methodsFor: 'setup' stamp: ''!
timeClass

	^ Time! !

!TimeTest methodsFor: 'coverage' stamp: ''!
selectorsToBeIgnored

	 | deprecated private special primitives timing benchmarks |

	deprecated := #().
	private := #( #print24:on: #print24:showSeconds:on: ).
	special := #( #< #= #new #printOn: #storeOn: ).
	primitives := #( #primMillisecondClock #primSecondsClock #primUTCSecondsClock #primUTCMicrosecondsClock #primUTCMillisecondsClock).
	timing := #( #millisecondClockValue #milliseconds:since: #millisecondsSince: ).
	benchmarks := #( #benchmarkMillisecondClock #benchmarkPrimitiveResponseDelay ). 

	^ super selectorsToBeIgnored, deprecated, private, special, primitives, timing, benchmarks.! !

!TimeTest methodsFor: 'tests - printing' stamp: ''!
testPrint24OnWithPM
	self assert: (String streamContents: [ :str | aTime print24: false on: str ]) equals: '12:34:56 pm'! !

!TimeTest methodsFor: 'tests' stamp: ''!
testComparing
	| t1 t2 t3 |
	t1 := self timeClass fromSeconds: 14567.	"4:02:47 am"
	t2 := self timeClass fromSeconds: 5000.	"1:23:20 am"
	t3 := self timeClass fromSeconds: 80000.	"10:13:20 pm"

	self
		assert: time equals: t1;
		assert: time hash equals: t1 hash;
		assert: time equals: time copy.
	self
		deny: t1 < t2;
		assert: t1 < t3! !

!TimeTest methodsFor: 'tests' stamp: ''!
testFromSeconds
	| t |
	t := self timeClass fromSeconds: 14567.
	self assert: t equals: time! !

!TimeTest methodsFor: 'tests' stamp: ''!
testSubtractTime
	self assert: (aTime subtractTime: aTime) equals: (Time readFrom: '00:00:00' readStream)! !

!TimeTest methodsFor: 'tests' stamp: ''!
testArithmetic
	| t1 t2 t3 |
	t1 := time addSeconds: 70.	"4:03:57 am"
	self
		assert: t1 hours equals: 4;
		assert: t1 minutes equals: 3;
		assert: t1 seconds equals: 57.

	t2 := t1 addTime: (self timeClass fromSeconds: 60 * 60 * 5).
	self
		assert: t2 hours equals: 9;
		assert: t2 minutes equals: 3;
		assert: t2 seconds equals: 57.

	t3 := t2 subtractTime: (self timeClass fromSeconds: 60 * 60 * 5 + 70).
	self assert: t3 equals: time! !

!TimeTest methodsFor: 'tests' stamp: ''!
testSeconds
	self assert: (Time readFrom: '20:33:14.321-05:00' readStream) asDuration seconds equals: 14! !

!TimeTest methodsFor: 'tests' stamp: ''!
testAsDuration
	self
		assert: aTime asDuration
		equals:
			(Duration
				days: 0
				hours: 12
				minutes: 34
				seconds: 56)! !

!TimeTest methodsFor: 'tests - input' stamp: ''!
testReadFromWithNanos
	#('4:02:47.5 am' '4:02:55.521 pm')
		do: [ :each | 
			| t |
			t := self timeClass readFrom: each readStream.
			self assert: t printString equals: each ]
	"there is a bug with 520 instead of 521"! !

!TimeTest methodsFor: 'tests' stamp: ''!
testMeridianAbbreviation
	self assert: aTime meridianAbbreviation equals: 'PM'! !

!TimeTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn
	self assert: (String streamContents: [ :str | aTime printOn: str ]) equals: '12:34:56 pm'! !

!TimeTest methodsFor: 'tests' stamp: ''!
testLessThan
	self assert: aTime < (Time readFrom: '12:34:57' readStream)! !

!TimeTest methodsFor: 'tests - printing' stamp: ''!
testPrintMinutes
	self assert: aTime printMinutes equals: '12:34 pm'! !

!TimeTest methodsFor: 'running' stamp: ''!
tearDown
	DateAndTime localTimeZone: localTimeZoneToRestore.
	super tearDown! !

!TimeTest methodsFor: 'tests' stamp: ''!
testHour
	self assert: aTime hour equals: 12.
	self assert: aTime hour12 equals: 12.
	self assert: aTime hour24 equals: 12.
	self assert: aTime hours equals: 12! !

!TimeTest methodsFor: 'tests - printing' stamp: ''!
testPrint24OnWithoutSeconds
	self assert: (String streamContents: [ :str | aTime print24: true showSeconds: true on: str ]) equals: '12:34:56'! !

!TimeTest methodsFor: 'tests' stamp: ''!
testSecond
	self assert: aTime second equals: 56.
	self assert: aTime seconds equals: 56! !

!TimeTest methodsFor: 'tests' stamp: ''!
testAsWeek
	self assert: aTime asWeek equals: (DateAndTime current midnight + aTime) asWeek! !

!TimeTest methodsFor: 'tests' stamp: ''!
testAsDate
	self assert: aTime asDate equals: Date current! !

!TimeTest methodsFor: 'tests' stamp: ''!
testAsNanoSeconds
	self assert: aTime asNanoSeconds equals: 45296000000000! !

!TimeTest methodsFor: 'tests' stamp: ''!
testConverting
	self assert: time asSeconds equals: 14567! !

!TimeTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ self timeClass! !

!TimeTest methodsFor: 'tests' stamp: ''!
testAsDateAndTime
	self assert: aTime asDateAndTime equals: DateAndTime current midnight + aTime! !

!TimeTest methodsFor: 'tests' stamp: ''!
testNew
	self assert: self timeClass new asSeconds equals: 0! !

!TimeTest methodsFor: 'tests' stamp: ''!
testGeneralInquiries
	| date aDateAndTime |

	self should: [ self timeClass timeWords ] raise: MessageNotUnderstood.

	date := '2 June 1973' asDate.
	time := '4:02:47 am' asTime.
	aDateAndTime := self timeClass dateAndTimeFromSeconds: (2285280000 + 14567).
	self
		assert: aDateAndTime equals: {date. time}.! !

!TimeTest methodsFor: 'tests - printing' stamp: ''!
testPrint24On
	self assert: (String streamContents: [ :str | aTime print24: true on: str ]) equals: '12:34:56'! !

!TimeTest methodsFor: 'tests' stamp: ''!
testNanoSecond
	self assert: aTime nanoSecond equals: 0
	"Right now all times all seconds"! !

!TimeTest methodsFor: 'tests - input' stamp: ''!
testReadFromWithError
		
	#('invalid' '0:invalid' '1 invalid' '1 pm is the afternoon' '1250 Fake St, New York, USA 12345' '13000 AM' '25:69:1239' '1,3,6') do: [ :each | 
	self should: [self timeClass readFrom: each readStream] raise: Error.]! !

!TimeTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testNanoConstructor
	| timeFromString timeFromNano timeFromNanoSecond |
	timeFromString := Time fromString: '01:23:45.67809'.
	timeFromNano := Time
		hour: 1
		minute: 23
		second: 45
		nano: 67809.
	timeFromNanoSecond := Time
		hour: 1
		minute: 23
		second: 45
		nanoSecond: 67809.

	self
		assert: timeFromString equals: timeFromNano;
		deny: timeFromNano equals: timeFromNanoSecond.

	timeFromString := Time fromString: '01:23:45.0'.
	timeFromNano := Time
		hour: 1
		minute: 23
		second: 45
		nano: 0.

	self assert: timeFromString equals: timeFromNano.

	timeFromString := Time fromString: '01:23:45.1234567890'.
	timeFromNano := Time
		hour: 1
		minute: 23
		second: 45
		nano: 1234567890.

	self assert: timeFromString equals: timeFromNano! !

!TimeTest methodsFor: 'tests' stamp: ''!
testPrintStringNanos
	self
		assert:
			(Time
				hour: 15
				minute: 15
				second: 15
				nanoSecond: 150 * 1000000) printString
		equals: '3:15:15.15 pm'! !

!TimeTest methodsFor: 'tests' stamp: ''!
testEqual
	self assert: aTime equals: (Time readFrom: '12:34:56' readStream).
	self assert: aTime equals: (Time readFrom: '12:34:56.00' readStream).
	self assert: aTime equals: (Time readFrom: '12:34:56.0000' readStream)! !

!TimeTest methodsFor: 'tests' stamp: ''!
testAddSeconds
	self assert: (aTime addSeconds: 1) equals: (Time readFrom: '12:34:57' readStream).
	self assert: (aTime addSeconds: 60) equals: (Time readFrom: '12:35:56' readStream).
	self assert: (aTime addSeconds: 3600) equals: (Time readFrom: '13:34:56' readStream).
	self assert: (aTime addSeconds: 24 * 60 * 60) equals: (Time readFrom: '12:34:56' readStream)! !

!TimeTest methodsFor: 'tests' stamp: ''!
testAsYear
	self assert: aTime asYear equals: (DateAndTime current midnight + aTime) asYear! !

!TimeTest methodsFor: 'tests - printing' stamp: ''!
testPrint24withNanos
	self assert: '12:34:56.1' asTime print24 equals: '12:34:56'! !

!TimeTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	localTimeZoneToRestore := DateAndTime localTimeZone.
	DateAndTime localTimeZone: TimeZone default.
	time := self timeClass fromSeconds: 14567.		"4:02:47 am"
	aTime := Time readFrom: '12:34:56 pm' readStream! !

!TimeTest methodsFor: 'tests' stamp: ''!
testAccessing
	self
		assert: time hours equals: 4;
		assert: time minutes equals: 2;
		assert: time seconds equals: 47;
		assert: time asSeconds equals: 14567! !

!TimeTest methodsFor: 'tests' stamp: ''!
testAsTime
	self assert: aTime asTime equals: aTime! !

!TimeTest methodsFor: 'tests' stamp: ''!
testMinute
	self assert: aTime minute equals: 34.
	self assert: aTime minutes equals: 34! !

!TimeTest methodsFor: 'tests - printing' stamp: ''!
testPrint24
	self assert: aTime print24 equals: '12:34:56'! !

!TimeTest methodsFor: 'tests' stamp: ''!
testStoring
	self
		assert: time storeString equals: '''4:02:47 am'' asTime';
		assert: time equals: '4:02:47 am' asTime! !

!TimeTest methodsFor: 'tests' stamp: ''!
testStoreOn
	self assert: (String streamContents: [ :str | aTime storeOn: str ]) equals: '''12:34:56 pm'' asTime'! !

!TimeTest methodsFor: 'tests - printing' stamp: ''!
testPrinting
	self
		assert: time printString equals: '4:02:47 am';
		assert: time intervalString equals: '4 hours 2 minutes 47 seconds';
		assert: time print24 equals: '04:02:47';
		assert: time printMinutes equals: '4:02 am';
		assert: time hhmm24 equals: '0402'! !

!TimeTest methodsFor: 'tests' stamp: ''!
testDuration
	self assert: aTime duration equals: 0 seconds! !

!TimeTest methodsFor: 'tests' stamp: ''!
testHhmm24
	self assert: aTime hhmm24 equals: '1234'! !

!TimeTest methodsFor: 'tests' stamp: ''!
testTicks
	self assert: aTime ticks equals: #(0 45296 0).
	self assert: aTime equals: (Time new ticks: #(0 45296 0))! !

!TimeTest methodsFor: 'tests' stamp: ''!
testAddTime
	self assert: (aTime addTime: aTime) equals: (Time readFrom: '01:09:52' readStream)! !

!TimeZone commentStamp: ''!
TimeZone is a simple class to colect the information identifying a UTC time zone.

offset			-	Duration	- the time zone's offset from UTC
abbreviation	-	String		- the abbreviated name for the time zone.
name			-	String		- the name of the time zone.

TimeZone class >> #timeZones returns an array of the known time zones
TimeZone class >> #default returns the default time zone (Grenwich Mean Time)!
!TimeZone methodsFor: 'accessing' stamp: ''!
abbreviation: aString

	abbreviation := aString! !

!TimeZone methodsFor: 'accessing' stamp: ''!
abbreviation
 
 	^ abbreviation! !

!TimeZone methodsFor: 'accessing' stamp: ''!
name
 
 	^ name! !

!TimeZone methodsFor: 'accessing' stamp: ''!
name: aString

	name := aString! !

!TimeZone methodsFor: 'accessing' stamp: ''!
offset
 
 	^ offset! !

!TimeZone methodsFor: 'accessing' stamp: ''!
offset: aDuration

	offset := aDuration! !

!TimeZone class methodsFor: 'instance creation' stamp: ''!
offset: aDuration name: aName abbreviation: anAbbreviation
 
 	^ self new
 		offset: aDuration;
 		name: aName;
 		abbreviation: anAbbreviation;
 		yourself! !

!TimeZone class methodsFor: 'accessing' stamp: ''!
offset: aDuration
 	"Return the timezone with the given offset
	
		TimeZone offset: 2 hours
	"
 	^ self timeZones 
		detect: [ :timeZone | timeZone offset = aDuration ]
		ifNone: [ self new offset: aDuration ]! !

!TimeZone class methodsFor: 'accessing' stamp: ''!
local
	^ LocalTimeZone new! !

!TimeZone class methodsFor: 'accessing' stamp: ''!
abbreviated: aString
 	"Return the timezone whose abbreviation is aString."
 	^ self timeZones detect: [ :timeZone | 
		timeZone abbreviation = aString ].! !

!TimeZone class methodsFor: 'accessing' stamp: ''!
default
 	"Answer the default time zone - GMT"
 
 	^ self timeZones detect: [ :timeZone |
		timeZone offset = Duration zero ]! !

!TimeZone class methodsFor: 'accessing' stamp: ''!
timeZones

	^ {
		self offset:  0 hours name: 'Universal Time'              abbreviation: 'UTC'.
		self offset:  0 hours name: 'Greenwich Mean Time'         abbreviation: 'GMT'.
		self offset:  1 hours name: 'British Summer Time'         abbreviation: 'BST'.
		self offset:  2 hours name: 'South African Standard Time' abbreviation: 'SAST'.
		self offset: -8 hours name: 'Pacific Standard Time'       abbreviation: 'PST'.
		self offset: -7 hours name: 'Pacific Daylight Time'       abbreviation: 'PDT'.
		self offset: -7 hours name: 'Mountain Standard Time'      abbreviation: 'MST'.
		self offset: -6 hours name: 'Mountain Daylight Time'      abbreviation: 'MDT'.
		self offset: -6 hours name: 'Central Standard Time'       abbreviation: 'CST'.
		self offset: -5 hours name: 'Central Daylight Time'       abbreviation: 'CDT'.
		self offset: -5 hours name: 'Eastern Standard Time'       abbreviation: 'EST'.
		self offset: -4 hours name: 'Eastern Daylight Time'       abbreviation: 'EDT'.
	}! !

!TimedOut commentStamp: ''!
I am signalled by #duration:timeoutDo: if the receiving block takes too long to execute.

I am signalled by a watchdog process spawned by #duration:timeoutDo: and caught in the same method. 

I am not intended to be used elsewhere.!
!Timespan commentStamp: ''!
I represent a duration starting on a specific DateAndTime.
!
!Timespan methodsFor: 'arithmetic' stamp: ''!
< comparand

	^ self start < comparand! !

!Timespan methodsFor: 'private' stamp: ''!
duration: aDuration
	"Set the Duration of this timespan"

	duration := aDuration! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
firstDayOfMonth

	^ start firstDayOfMonth! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
includesAll: aCollection
	"Answer whether all the elements of aCollection are in the receiver."

	^ aCollection allSatisfy: [ :elem | self includes: elem ]! !

!Timespan methodsFor: 'comparing' stamp: ''!
hash

	^ start hash + duration hash! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
daysInYear
 	"Answer the number of days in the month represented by the receiver."

	^ start daysInYear! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
includes: aDateAndTime 

	^ (aDateAndTime isKindOf: Timespan)
			ifTrue: [ 
				(self includes: aDateAndTime start)
					and: [ self includes: aDateAndTime end ] ]
			ifFalse: [ aDateAndTime asDateAndTime between: start and: self end ]! !

!Timespan methodsFor: 'accessing' stamp: ''!
dayOfMonth
	"Answer the day of the month represented by the receiver."

	^ start dayOfMonth! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
do: aBlock with: aFirstElement when: aConditionBlock

	| element end |
	element := aFirstElement.
	end := self end.
	[ element start <= end ] whileTrue:
	
	[(aConditionBlock value: element)
			ifTrue: [ aBlock value: element ].
		element := element next. ]! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
monthAbbreviation 

	^ start monthAbbreviation! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
dayOfWeek
	"Answer the day of the week represented by the receiver."

	^ start dayOfWeek! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
union: aTimespan
	 "Return the Timespan spanned by both"

	| aBegin anEnd |

	aBegin := self start min: aTimespan start.
	anEnd := self end max: aTimespan end.
	^ Timespan starting: aBegin ending: (anEnd + DateAndTime clockPrecision).! !

!Timespan methodsFor: 'accessing' stamp: ''!
julianDayNumberUTC
	^ start julianDayNumberUTC! !

!Timespan methodsFor: 'converting' stamp: ''!
asSeconds
 	"Answer the seconds since the epoch: 1 January 1901"
 
 	^ start asSeconds! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
isLeapYear

	^ start isLeapYear! !

!Timespan methodsFor: 'arithmetic' stamp: ''!
- operand
	"operand conforms to protocol DateAndTime or protocol Duration"

	^ (operand respondsTo: #asDateAndTime) 
	 	ifTrue: [ self start - operand ]
	 	ifFalse: [ self + (operand negated) ].! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
every: aDuration do: aBlock

	| element end |
	element := self start.
	end := self end.
	[ element <= end ] whileTrue:
	
	[ aBlock value: element.
		element := element + aDuration. ]! !

!Timespan methodsFor: 'accessing' stamp: ''!
asDate 

	^ start asDate! !

!Timespan methodsFor: 'accessing' stamp: ''!
previous 

	^ self class starting: (start - duration) duration: duration! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asWeek

	^ start asWeek! !

!Timespan methodsFor: 'accessing' stamp: ''!
next

	^ self class starting: (start + duration) duration: duration! !

!Timespan methodsFor: 'accessing' stamp: ''!
offset: anOffset
	"Answer a <Timespan> equivalent to the receiver but with its local time 
	being offset from UTC by offset.
	Unlike #translateTo: this will NOT change the absolute in UTC "

	^ self class 
		starting: (self start offset: anOffset) 
		duration: self duration! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
daysInMonth 

	^ start daysInMonth! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
years


	| years |
	years := OrderedCollection new.
	self yearsDo: [ :m | years add: m ].
	^ years asArray.! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
workDatesDo: aBlock
 	"Exclude Saturday and Sunday"

	self do: aBlock with: start asDate when: [ :d | d dayOfWeek < 6 ].! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asMonth 

	^ start asMonth! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
includesAnyOf: aCollection 
	^ self includesAny: aCollection! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
dayOfYear
	"Answer the day of the year represented by the receiver."

	^ start dayOfYear! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
translateTo: aTimeZone
	"Keep myself's representation and move it to another timezone offset.
	Note that unlike #offset: this WILL change the absolute time in UTC"
	
	^ self class
		starting: (start translateTo: aTimeZone)! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
end 

	^ self duration asNanoSeconds = 0
		ifTrue: [ self start ]
		ifFalse: [ self next start - DateAndTime clockPrecision ]! !

!Timespan methodsFor: 'converting' stamp: ''!
asDuration

	^ self duration! !

!Timespan methodsFor: 'comparing' stamp: ''!
= comparand
	^ self species = comparand species 
		and: [ self start = comparand start 
				and: [ self duration = comparand duration ]]! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
day
	"Answer the day of the year represented by the receiver."
	^ self dayOfYear! !

!Timespan methodsFor: 'accessing' stamp: ''!
duration
 	"Answer the Duration of this timespan"

	^ duration! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
dayOfWeekName
	"Answer the day of the week represented by the receiver."

	^ start dayOfWeekName! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
yearsDo: aBlock

	self do: aBlock with: start asYear.! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
to: anEnd
	"Answer an Timespan. anEnd must be aDateAndTime or a Timespan" 
	| end |
	end := (anEnd isKindOf: Timespan)
		ifTrue: [ anEnd end ]
		ifFalse: [ anEnd asDateAndTime ].
	^ Timespan starting: (self start) ending: end.! !

!Timespan methodsFor: 'printing' stamp: ''!
printOn: aStream 

	super printOn: aStream.
	aStream 
		nextPut: $(;
		print: start;
		nextPut: $D;
		print: duration;
		nextPut: $).! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
dates


	| dates |

	dates := OrderedCollection new.
	self datesDo: [ :m | dates add: m ].
	^ dates asArray.! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asYear 

	^ start asYear! !

!Timespan methodsFor: 'accessing' stamp: ''!
monthIndex

	^ self month! !

!Timespan methodsFor: 'accessing' stamp: ''!
offset
	^ start offset! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
datesDo: aBlock 

	self do: aBlock with: start asDate.! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
intersection: aTimespan

	 "Return the Timespan both have in common, or nil"

	 | aBegin anEnd |
	 aBegin := self start max: aTimespan start.
	"Use start + duration rather than end, because the latter subtracts clockPrecision."
	 anEnd := (self start + self duration) min: (aTimespan start + aTimespan duration).
	 anEnd <= aBegin ifTrue: [^nil].

	 ^ self species starting: aBegin ending: anEnd.! !

!Timespan methodsFor: 'accessing' stamp: ''!
asDateAndTime

	^ start! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
daysLeftInYear
	^ start daysLeftInYear! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
monthsDo: aBlock

 	self do: aBlock with: start asMonth.! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
do: aBlock with: aFirstElement

 	self do: aBlock with: aFirstElement when: [ :t | true ].! !

!Timespan methodsFor: 'converting' stamp: ''!
asTime

	^ start asTime! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
translateToUTC 
	" Move this represenation to UTC"
	^ self translateTo: 0! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
monthName 

	^ start monthName! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
asDosTimestamp 

	^ start asDosTimestamp! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
includesAny: aCollection
	"Answer whether any element of aCollection is included in the receiver"

	^ aCollection anySatisfy: [ :elem | self includes: elem ]! !

!Timespan methodsFor: 'accessing' stamp: ''!
year 

	^ start year! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
weeks


	| weeks |
	weeks := OrderedCollection new.
	self weeksDo: [ :m | weeks add: m ].
	^ weeks asArray.! !

!Timespan methodsFor: 'accessing' stamp: ''!
start
 	"Answer the start DateAndTime of this timespan"

	^ start! !

!Timespan methodsFor: 'accessing' stamp: ''!
start: aDateAndTime
	"Store the start DateAndTime of this timespan"

	start := aDateAndTime asDateAndTime! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
weeksDo: aBlock

	self do: aBlock with: self asWeek.! !

!Timespan methodsFor: '*Kernel-Chronology-Extras' stamp: ''!
months

	| months |
	months := OrderedCollection new: 12.
	self monthsDo: [ :m | months add: m ].
	^ months asArray.! !

!Timespan methodsFor: 'accessing' stamp: ''!
julianDayNumber 

	^ start julianDayNumber! !

!Timespan methodsFor: 'arithmetic' stamp: ''!
+ operand
	"operand conforms to protocol Duration" 	

	^ self species starting: (self start + operand) duration: self duration! !

!Timespan methodsFor: 'accessing' stamp: ''!
month

	^ start month! !

!Timespan class methodsFor: 'instance creation' stamp: ''!
new
	"Answer a Timespan starting on the epoch: 1 January 1901"

	^ self starting: DateAndTime new! !

!Timespan class methodsFor: 'instance creation' stamp: ''!
current 

	^ self starting: DateAndTime now! !

!Timespan class methodsFor: 'instance creation' stamp: ''!
starting: aDateAndTime duration: aDuration

	^ self basicNew
  		start: aDateAndTime asDateAndTime;
 		duration: aDuration;
		yourself.! !

!Timespan class methodsFor: 'instance creation' stamp: ''!
starting: aDateAndTime 

	^ self starting: aDateAndTime duration: Duration zero! !

!Timespan class methodsFor: 'instance creation' stamp: ''!
starting: startDateAndTime ending: endDateAndTime

	^ self 
		starting: startDateAndTime 
		duration: (endDateAndTime asDateAndTime - startDateAndTime).! !

!TimespanDoSpanAYearTest commentStamp: ''!
I am one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. See DateAndTimeEpochTestCase for a complete list. tlk.
My fixtures include a Timespan that crosses over a year boundary:
aDate = December 25, 2004, midnight
aDuration = 91 days
aTimeSpan= 91 days, starting December 25, 2004, midnight!
!TimespanDoSpanAYearTest methodsFor: 'tests' stamp: ''!
testYearsDo
	| yearArray |
	yearArray := Array
				with: (Year year: 2004)
				with: (Year year: 2005).
	self assert: aTimespan years equals: yearArray! !

!TimespanDoSpanAYearTest methodsFor: 'tests' stamp: ''!
testNext
	self
		assert: aTimespan next
		equals:
			(Timespan
				starting:
					(DateAndTime
						year: 2005
						month: 3
						day: 26
						hour: 0
						minute: 0
						second: 0)
				duration: aDuration)! !

!TimespanDoSpanAYearTest methodsFor: 'tests' stamp: ''!
testWeeksDo
	| weeks weekArray |
	weeks := aTimespan weeks.
	self assert: weeks size equals: (aDuration days / 7.0) ceiling + 1.

	weekArray := OrderedCollection new.
	weekArray
		addLast: (Week starting: (DateAndTime year: 2004 month: 12 day: 19) duration: 7 days);
		addLast: (Week starting: (DateAndTime year: 2004 month: 12 day: 26) duration: 7 days).

	2 to: 79 by: 7 do: [ :i | weekArray addLast: (Week starting: (DateAndTime year: 2005 day: i) duration: 7 days) ].

	weekArray := weekArray asArray.
	self assert: aTimespan weeks equals: weekArray! !

!TimespanDoSpanAYearTest methodsFor: 'tests' stamp: ''!
testMonthsDo
	| monthArray |
	monthArray := Array
		with: (Month starting: (DateAndTime year: 2004 day: 355) duration: 31 days)
		with: (Month starting: (DateAndTime year: 2005 day: 1) duration: 31 days)
		with: (Month starting: (DateAndTime year: 2005 day: 32) duration: 29 days)
		with: (Month starting: (DateAndTime year: 2005 day: 61) duration: 31 days).

	self assert: aTimespan months equals: monthArray! !

!TimespanDoSpanAYearTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	aDate := DateAndTime year: 2004 month: 12 day: 25 hour: 0 minute: 0 second: 0.
	aDuration := Duration days: 91 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0.

	aTimespan := Timespan starting: aDate duration: aDuration! !

!TimespanDoTest commentStamp: ''!
I am one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. See DateAndTimeEpochTestCase for a complete list.  tlk.
My fixtures are:
aDate = January 8, 2003, midnight
aDuration = 91 days
aTimeSpan= 91 days, starting January 8, 2003, midnight
!
!TimespanDoTest methodsFor: 'tests' stamp: ''!
testDoWithWhen
	| count |
	count := 0.
	aTimespan do: [ :each | count := count + 1 ] with: (Timespan starting: aDate duration: 7 days) when: [ :each | count < 5 ].
	self assert: count equals: 5! !

!TimespanDoTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testYearsDo
	| yearArray |
	yearArray := Array with: (Year starting: (DateAndTime year: 2003 day: 7) duration: 365 days).
	self assert: aTimespan years contents equals: yearArray contents! !

!TimespanDoTest methodsFor: 'tests' stamp: ''!
testNext
	self
		assert: aTimespan next
		equals:
			(Timespan
				starting:
					(DateAndTime
						year: 2003
						month: 4
						day: 8
						hour: 0
						minute: 0
						second: 0)
				duration: aDuration)! !

!TimespanDoTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testWeeksDo
	| weekArray |
	weekArray := OrderedCollection new.
	7 to: 98 by: 7 do: [ :each | weekArray addLast: (Week starting: (DateAndTime year: 2003 day: each) duration: 7 days) ].
	weekArray := weekArray asArray.
	self assert: aTimespan weeks equals: weekArray! !

!TimespanDoTest methodsFor: 'tests' stamp: ''!
testDoWith
	| count |
	count := 0.
	aTimespan do: [ :each | count := count + 1 ] with: (Timespan starting: aDate duration: 7 days).
	self assert: count equals: 13! !

!TimespanDoTest methodsFor: 'tests' stamp: ''!
testEveryDo
	| count duration |
	count := 0.
	duration := 7 days.
	aTimespan every: duration do: [ :each | count := count + 1 ].
	self assert: count equals: 13! !

!TimespanDoTest methodsFor: 'tests' stamp: ''!
testDatesDo
	| dateArray |
	dateArray := OrderedCollection new.
	7 to: 97 do: [ :each | dateArray addLast: (Date year: 2003 day: each) ].
	dateArray := dateArray asArray.
	self assert: aTimespan dates equals: dateArray! !

!TimespanDoTest methodsFor: '*Kernel-Tests-Extended' stamp: ''!
testMonthsDo
	| monthArray |
	monthArray := Array
		with: (Month starting: (DateAndTime year: 2003 day: 1) duration: 31 days)
		with: (Month starting: (DateAndTime year: 2003 day: 32) duration: 28 days)
		with: (Month starting: (DateAndTime year: 2003 day: 60) duration: 31 days)
		with: (Month starting: (DateAndTime year: 2003 day: 91) duration: 30 days).
	self assert: aTimespan months equals: monthArray! !

!TimespanDoTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	aDate := DateAndTime
				year: 2003
				month: 01
				day: 07
				hour: 0
				minute: 0
				second: 0.
	aDuration := Duration
				days: 91
				hours: 0
				minutes: 0
				seconds: 0
				nanoSeconds: 0.
	aTimespan := Timespan starting: aDate duration: aDuration! !

!TimespanTest commentStamp: ''!
SUnit tests for Timespan class!
!TimespanTest methodsFor: 'tests' stamp: ''!
testIntersectionWithIncluded
	self
		assert: (aTimespan intersection: anIncludedTimespan)
		equals: anIncludedTimespan! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testDaysLeftInYear
	self assert: aTimespan daysLeftInYear equals: 364
	"MessageNotUnderstood: UndefinedObject>>starting:  UndefinedObject is Year class"! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testInclusion
	| t1 t2 t3 t4 |
	t1 := timespan start.
	t2 := timespan start + (timespan duration / 2).
	t3 := timespan end.
	t4 := timespan start + timespan duration.

	self assert: (timespan includes: t1).
	self assert: (timespan includes: t2).
	self assert: (timespan includes: t3).
	self deny: (timespan includes: t4).
	self assert: (timespan includes: (t1 to: t2)).
	self assert: (timespan includes: (t1 to: t4)).
	self deny: (timespan includes: (Timespan starting: t2 duration: timespan duration * 2)).
	self assert: (timespan includesAll: { t1. t2. t3 }).
	self deny: (timespan includesAll: { t1. t2. t3. t4 }).
	self assert: (timespan includesAny: { t1. t2. t3 }).
	self deny: (timespan includesAny: { t4 })! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testFirstDayOfMonth
	self assert: aTimespan firstDayOfMonth equals: 1.
	self assert: aDisjointTimespan firstDayOfMonth equals: 1! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testPrevious
	self assert: aTimespan equals: aDisjointTimespan previous.
	self assert: aTimespan next previous equals: aTimespan! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testArithmetic
	| ts1 ts2 d |

	ts1 := timespan + 2 days.
	ts2 := ts1 - 2 days.
	d := ts1
		-
			(DateAndTime
				year: 2003
				month: 03
				day: 20).

	self
		assert: ts1 start
			equals:
			(DateAndTime
				year: 2003
				month: 03
				day: 24
				hour: 12
				minute: 0
				second: 0);
		assert: ts1 duration equals: timespan duration;
		assert: ts2 start equals: timespan start;
		assert: ts2 duration equals: timespan duration.

	self
		assert: d
		equals:
			(Duration
				days: 4
				hours: 12
				minutes: 0
				seconds: 0)! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testDayOfWeek
	self assert: aTimespan dayOfWeek equals: 7.
	self assert: aTimespan dayOfWeekName equals: 'Saturday'! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testAsDuration
	self assert: aTimespan asDuration equals: aWeek! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testWorkDatesDo
	| count |

	count := 0.
	aTimespan workDatesDo: [ :each | count := count + 1 ].
	self assert: count equals: 5! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testPrintOn
	self assert: (String streamContents: [ :str | aTimespan printOn: str ]) equals: 'a Timespan(2005-01-01T00:00:00+00:00D7:00:00:00)'! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testDoWithWhen
	| count |

	count := 0.
	aTimespan
		do: [ :each | count := count + 1 ]
		with: (Timespan starting: jan01 duration: aDay)
		when: [ :each | count < 5 ].
	self assert: count equals: 5! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testLessThan
	self assert: aTimespan  < aDisjointTimespan.
	self deny: anIncludedTimespan < aTimespan! !

!TimespanTest methodsFor: 'running' stamp: ''!
tearDown
	DateAndTime localTimeZone: localTimeZoneToRestore.
	timespan := nil.
	super tearDown! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testDayOfYear
	self assert: aTimespan dayOfYear equals: 1
	"MessageNotUnderstood: UndefinedObject>>year:, Undefined object is Year class"! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testJulianDayNumber
	self assert: aTimespan julianDayNumber equals: jan01 julianDayNumber! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testNext
	self assert: aTimespan next equals: aDisjointTimespan! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testCurrent
	self assert: (Timespan starting: DateAndTime current) <= Timespan current.
	self assert: Timespan current <= (Timespan starting: DateAndTime current)! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testUnionWithIncluded
	self assert: (aTimespan union: anIncludedTimespan) equals: aTimespan! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testSubclassArithmetic

	| timespans |
	timespans := { Year currentYear.
					 	Month current.
						(Week starting: DateAndTime now).
						Date today.
						Timespan starting: (DateAndTime now) duration: 1 hour }.
	timespans do:
		[ :ts |
			self assert: ts + aDay - ts equals: aDay.
			self assert: ts - aDay - ts equals: aDay negated.
			timespans do:
				[ :otherTs |
					self assert: (ts intersection: otherTs) equals: (otherTs intersection: ts) ] ].

	self assert: (timespans first intersection: timespans second) equals: timespans second.
	self assert: (timespans first intersection: timespans fourth) equals: timespans fourth.
	self assert: (timespans second intersection: timespans fourth) equals: timespans fourth.! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testYear
	self assert: aTimespan year equals: 2005! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testTo
	self assert: (anIncludedTimespan to: jan08) equals: aTimespan! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testAsWeek
	self assert: aTimespan asWeek equals: jan01 asWeek
	"DateAndTime new asWeek
	MessageNotUnderstood: Week class>>starting:"! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testZeroDuration
	| ts |

	ts := Timespan starting: Date today duration: Duration zero.
	self assert: ts start equals: ts end! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testAsDate
	self assert: aTimespan asDate equals: jan01 asDate
	"MessageNotUnderstood: Date class>>starting:"! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testEveryDo
	| count duration |

	count := 0.
	duration := 7 days.
	aTimespan every: duration do: [ :each | count := count + 1 ].
	self assert: count equals: 1! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testUnionWithSelf
	self assert: (aTimespan union: aTimespan) equals: aTimespan! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testMonth
	self assert: aTimespan month equals: 1.
	self assert: aTimespan monthName equals: 'January'.
	self assert: aTimespan monthIndex equals: 1! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testIntersectionWithSelf
	self
		assert: (aTimespan intersection: aTimespan)
		equals: aTimespan.
	self deny: (aTimespan intersection: anIncludedTimespan) equals: aTimespan! !

!TimespanTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ Timespan! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testAsDateAndTime
	self assert: aTimespan asDateAndTime equals: jan01
	"MessageNotUnderstood: Date class>>starting:"! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testNew
	self assert: Timespan new equals: (Timespan starting: '01-01-1901' asDate)! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testDaysInYear
	self assert: aTimespan daysInYear equals: 365
	"MessageNotUnderstood: UndefinedObject>>starting:  UndefinedObject is Year class"! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testDay
	self assert: aTimespan day equals: jan01 day! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testUnion
	| union |

	union := timespan union: timespan.

	self
		assert: union start equals: timespan start;
		assert: union duration equals: timespan duration! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testIncludesAny
	self deny: (aTimespan includesAnyOf: (Bag with: dec31)).
	self assert: (aTimespan includesAnyOf: (Bag with: jan01 with: jan08))
	"Error is due to bug in Timespan 
includesAnyOf: aCollection "
	"Answer whether any element of aCollection is included in the receiver"
	"aCollection do: [ :elem | (self includes: elem) ifTrue: [^ true]].
Shouldn't this return false if none are included?
"! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testEnd
	self assert: aTimespan end + (Duration nanoSeconds: 1) equals: aDisjointTimespan start.
	self
		assert: aTimespan end
		equals:
			(DateAndTime
				year: 2005
				month: 1
				day: 7
				hour: 23
				minute: 59
				second: 59
				nanoSecond: 999999999
				offset: 0 hours)! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testUnionWithDisjoint
	self assert: (aTimespan union: aDisjointTimespan) equals: (Timespan starting: jan01 duration: 14 days)! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testDoWith
	| count |

	count := 0.
	aTimespan do: [ :each | count := count + 1 ] with: (Timespan starting: jan01 duration: aDay).
	self assert: count equals: 7! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testPlus
	self assert: aTimespan + aWeek equals: aDisjointTimespan.
	self assert: anOverlappingTimespan + aDay equals: aTimespan! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testIntersectionWithSeparate
	self assert: (aTimespan intersection: aDisjointTimespan) isNil.
	self deny: (aTimespan intersection: anOverlappingTimespan) isNil.
	self assert: (aTimespan intersection: anIncludedTimespan) equals: anIncludedTimespan! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testAsYear
	self assert: aTimespan asYear equals: jan01 asYear! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testMinusADateAndTime
	"It appears that subtracting a date from a Timespan gives you a duration = to the difference between the start of the timespan and the date "

	self assert: aTimespan - dec31 equals: aDay.
	self assert: aDisjointTimespan - jan01 equals: aWeek! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testIncludesAll
	self assert: (aTimespan includesAll: (Bag with: jan01)).
	self deny: (aTimespan includesAll: (Bag with: jan01 with: jan08))! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testIsLeapYear
	"self assert: anOverlappingTimespan isLeapYear."
	"not sure why this fails"
	self deny: aTimespan isLeapYear! !

!TimespanTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	localTimeZoneToRestore := DateAndTime localTimeZone.
	DateAndTime localTimeZone: TimeZone default.

	"100 hours starting noon 22 March 2003"
	timespan := Timespan starting:
					(DateAndTime year: 2003 month: 03 day: 22 hour: 12 minute: 0 second: 0)
						duration: (Duration hours: 100).

	dec31 := (DateAndTime year: 2004 month: 12 day: 31 hour: 0 minute: 0 second: 0).
	jan01 := (DateAndTime year: 2005 month: 1 day: 1 hour: 0 minute: 0 second: 0).
	jan08 := (DateAndTime year: 2005 month: 1 day: 8 hour: 0 minute: 0 second:0).
	aDay := Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0.
	aWeek := Duration days: 7 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0.
	aTimespan := Timespan starting: jan01 duration: aWeek.
	anOverlappingTimespan := Timespan starting: dec31 duration: aWeek.
	anIncludedTimespan := Timespan starting: jan01 duration: aDay.
	aDisjointTimespan := Timespan starting: jan08 duration: aWeek.! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testIncludes
	self assert: (aTimespan includes: jan01).
	self deny: (aTimespan includes: jan08)! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testAccessing
	self
		assert: timespan start
			equals:
			(DateAndTime
				year: 2003
				month: 03
				day: 22
				hour: 12
				minute: 0
				second: 0);
		assert: timespan duration equals: (Duration hours: 100);
		assert: timespan month equals: 3;
		assert: timespan monthName equals: 'March';
		assert: timespan monthAbbreviation equals: 'Mar'! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testAsTime
	self assert: aTimespan asTime equals: jan01 asTime
	"MessageNotUnderstood: Time class>>seconds:nanoSeconds:"! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testStart
	self assert: aTimespan start equals: jan01.
	aTimespan start: jan08.
	self assert: aTimespan start equals: jan08! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testUnionWithOverlapping
	self assert: (aTimespan union: anOverlappingTimespan) equals: (Timespan starting: dec31 duration: 8 days)! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testUnionWithSeparate
	self
		assert: (anOverlappingTimespan union: aDisjointTimespan)
		equals: (Timespan starting: anOverlappingTimespan start ending: aDisjointTimespan end + DateAndTime clockPrecision)! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testMinusADuration
	"It appears that subtracting a duration from a Timespan gives you a Timespan shifted by the duration"

	self assert: aTimespan - aDay equals: anOverlappingTimespan.
	self assert: aDisjointTimespan - aWeek equals: aTimespan! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testClockPrecisionDuration
	| ts |

	ts := Timespan starting: Date today duration: DateAndTime clockPrecision.
	self assert: ts start equals: ts end! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testStartingEnding
	self assert: aTimespan equals: (Timespan starting: jan01 ending: jan08)! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testIntersectionWithOverlapping
	self
		assert: (aTimespan intersection: anOverlappingTimespan)
		equals:
			(Timespan
				starting: jan01
				duration:
					(Duration
						days: 6))! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testAsMonth
	self assert: aTimespan asMonth equals: jan01 asMonth! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testDaysInMonth
	self assert: aTimespan daysInMonth equals: 31
	"MessageNotUnderstood: Month class>>starting:"! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testDuration
	self assert: aTimespan duration equals: aWeek.
	aTimespan duration: aDay.
	self assert: aTimespan duration equals: aDay! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testDayOfMonth
	self assert: aTimespan dayOfMonth equals: 1! !

!TimespanTest methodsFor: 'tests' stamp: ''!
testIntersectionWithDisjoint
	self assert: (aTimespan intersection: aDisjointTimespan) isNil.! !

!ToManyRelationSlot commentStamp: ''!
I'm a relation slot  that  describes  slots that contain collections.!
!ToManyRelationSlot methodsFor: 'meta-object-protocol' stamp: ''!
wantsInitialization
	^ true! !

!ToManyRelationSlot methodsFor: 'internal' stamp: ''!
remove: oldObject from: collectionOwner

	self hasInverse
		ifTrue: [ self removeAssociationFrom: collectionOwner to: oldObject ]
! !

!ToManyRelationSlot methodsFor: 'internal' stamp: ''!
add: newObject to: collectionOwner

	self checkValue: newObject.
	self hasInverse
		ifTrue: [ self addAssociationFrom: collectionOwner to: newObject ]
! !

!ToManyRelationSlot methodsFor: 'initialization' stamp: ''!
initialize: anObject
	self write: (RelationSet owner: anObject slot: self) to: anObject. 
	! !

!ToOneRelationSlot commentStamp: ''!
I'm an relation slot  that  describes the one or zero side of an association.!
!ToOneRelationSlot methodsFor: 'internal' stamp: ''!
writeInverse: newValue to: anObject
	^anObject instVarAt: index put: newValue! !

!ToOneRelationSlot methodsFor: 'internal' stamp: ''!
updateOld: oldValue new: newValue in: anObject
	newValue 
		ifNotNil: [ self checkValue: newValue ].
	self hasInverse
		ifFalse: [ ^ newValue ].
	oldValue 
		ifNotNil: [ self removeAssociationFrom: anObject to: oldValue ].
	newValue 
		ifNotNil: [ self addAssociationFrom: anObject to: newValue ].
	^newValue! !

!ToOneRelationSlot methodsFor: 'testing' stamp: ''!
isToOneSlot

	^true! !

!ToOneRelationSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: newValue to: anObject
	self updateOld: (self read: anObject) new: newValue in: anObject.
	^super write: newValue to: anObject! !

!ToggleMenuItemMorph commentStamp: ''!
A menu item that supports on/off state (using standard icons), enablement and display of "accelerator" key text.!
!ToggleMenuItemMorph methodsFor: 'private - drawing' stamp: ''!
drawSubMenuMarker: aForm on: aCanvas in: aRectangle
	"Draw the submenu marker on the canvas within the given bounds."
	
	|markerRect| 
	markerRect := aRectangle topRight + ((aForm width * self displayScaleFactor) negated @ (aRectangle height - (aForm height * self displayScaleFactor) // 2)) extent: aForm extent * self displayScaleFactor.
	self drawIcon: aForm scaledByDisplayScaleFactor on: aCanvas in: markerRect! !

!ToggleMenuItemMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas 
	"Need to check isEnabled here."
	
	self
		isEnabled;
		basicDrawOn: aCanvas;
		drawKeyTextOn: aCanvas! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
enablementSelector
	"Answer the value of enablementSelector"

	^ enablementSelector! !

!ToggleMenuItemMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawKeyTextOnAthenCanvas: aCanvas 
	"Draw the key text on the canvas."
	
	self keyText ifNil: [^self].
	(ToggleMenuItemShortcut 
		owner: self 
		keyText: self keyText)
		drawOnAthensCanvas: aCanvas! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
isEnabled
	"Answer whether the item is enabled."
	
	|state|
	self enablementSelector ifNil: [^super isEnabled].
	state := self enablementSelector isSymbol
		ifTrue: [self target perform: self enablementSelector]
		ifFalse: [self enablementSelector value].
	self isEnabled: state.
	^state! !

!ToggleMenuItemMorph methodsFor: 'selecting' stamp: ''!
select: evt
	"Don't if not enabled."
	
	self isEnabled ifFalse: [^self].
	^super select: evt! !

!ToggleMenuItemMorph methodsFor: 'private' stamp: ''!
onImage
	"Return the form to be used for indicating an '<on>' marker."
	
	|m form|
	m := CheckboxButtonMorph new
		privateOwner: self owner;
		adoptPaneColor: self paneColor;
		selected: true.
	form := Form extent: m extent depth: 32.
	form fillColor: (Color white alpha: 0.003922).
	form getCanvas fullDrawMorph: m.
	^form! !

!ToggleMenuItemMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawText: aStringOrText onAthensCanvas: aCanvas in: aRectangle color: stringColor
	| wrapper |
	"Draw the text on the canvas within the given bounds."
	wrapper := aCanvas asCanvasWrapper.
	(self enabled not and: [ self theme disabledItemStyle = #inset ])
		ifTrue: [ 
			wrapper
				drawString: aStringOrText
					in: aRectangle
					font: self fontToUse
					color: stringColor muchLighter lighter;
				drawString: aStringOrText
					in: (aRectangle translateBy: -1)
					font: self fontToUse
					color: stringColor ]
		ifFalse: [ 
			wrapper
				drawString: aStringOrText
				in: aRectangle
				font: self fontToUse
				color: stringColor ]! !

!ToggleMenuItemMorph methodsFor: 'events' stamp: ''!
mouseLeave: evt
	"The mouse left the receiver.
	Handle the case when in an EmbeddedMenuMorph."

	super mouseLeave: evt.
	(owner notNil and: [owner isKindOf: EmbeddedMenuMorph]) ifTrue:[
		owner selectedItem == self
			ifTrue: [owner selectItem: nil event: evt]]! !

!ToggleMenuItemMorph methodsFor: 'private' stamp: ''!
selectionFillStyle
	"Answer the fill style to use with the receiver is the selected element."
	
	^ self theme menuItemSelectedFillStyleFor: self! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
icon
	"Answer the receiver's icon. Handle legacy case
	of wording-based mechanism."
	
	|state| 
	self getStateSelector ifNil: [^super icon].
	state := (MessageSend receiver: self target selector: self getStateSelector)
		valueWithEnoughArguments: self arguments .
	self flag: #pharoFixMe.
	(state isKindOf: Association)
		ifTrue: [^ state key ifTrue: [self onImage] ifFalse: [self offImage]]
		ifFalse: [
	(state = true or: [state isString and: [(state beginsWith: '<yes>') or: [state beginsWith: '<on>']]])
		ifTrue: [^self onImage].
	(state = false or: [state isString and: [(state beginsWith: '<no>') or: [state beginsWith: '<off>']]])
		ifTrue: [^self offImage]].
	^super icon! !

!ToggleMenuItemMorph methodsFor: 'private - drawing' stamp: ''!
itemShortcut

	^ ToggleMenuItemShortcut 
		owner: self 
		keyText: self keyText! !

!ToggleMenuItemMorph methodsFor: 'private' stamp: ''!
keyTextExpanded
	^ ToggleMenuItemShortcut normalize: self keyText! !

!ToggleMenuItemMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	
	super drawOnAthensCanvas: anAthensCanvas.
	self drawKeyTextOnAthenCanvas: anAthensCanvas! !

!ToggleMenuItemMorph methodsFor: 'testing' stamp: ''!
isEnabled: aBoolean

	isEnabled = aBoolean ifTrue: [^ self].
	isEnabled := aBoolean.
	self changed! !

!ToggleMenuItemMorph methodsFor: 'private - drawing' stamp: ''!
drawIcon: aForm on: aCanvas in: aRectangle
	"Draw the icon on the canvas within the given bounds."
	
	|iconForm|
	self isEnabled
		ifTrue: [iconForm := aForm]
		ifFalse: [iconForm := Form extent: aForm extent depth: 32.
				iconForm fillColor: (Color white alpha: 0.003922).
				(iconForm getCanvas asAlphaBlendingCanvas: 0.5)
					drawImage: aForm
					at: 0@0].
	aCanvas
		translucentImage: iconForm
		at: aRectangle topLeft + (0@(aRectangle height - iconForm height // 2))! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
selectionBorderStyle
	"Answer the border style to use with the receiver is the selected element."
	
	^ self theme menuItemSelectedBorderStyleFor: self! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
getStateSelector
	"Answer the value of getStateSelector"

	^ getStateSelector! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
stringColorToUse
	"Answer the state dependent color to use for drawing text."
	
	^self isEnabled
		ifTrue: [
			self isSelected
				ifTrue: [ self theme menuItemSelectedTextColorFor: self ]
				ifFalse: [ self theme menuItemNormalTextColorFor: self ] ]
		ifFalse: [
				self theme menuItemDisabledTextColorFor: self ]! !

!ToggleMenuItemMorph methodsFor: 'layout' stamp: ''!
minWidth
	"Plus the key text if any."
	
	|w|
	w := super minWidth.
	self keyText ifNotNil: [w := w + (self fontToUse widthOfString: self keyTextExpanded) + 12].
	^w! !

!ToggleMenuItemMorph methodsFor: 'events' stamp: ''!
mouseEnter: evt
	"The mouse entered the receiver.
	Handle the case when in an EmbeddedMenuMorph."

	super mouseEnter: evt.
	(owner notNil and: [owner isKindOf: EmbeddedMenuMorph]) ifTrue:[
		owner selectedItem ~~ self
			ifTrue: [owner selectItem: self event: evt]]! !

!ToggleMenuItemMorph methodsFor: 'selecting' stamp: ''!
adjacentTo

	^{self bounds topRight + (5 @ 0). self bounds topLeft + (2@0)}! !

!ToggleMenuItemMorph methodsFor: 'private - drawing' stamp: ''!
drawText: aStringOrText on: aCanvas in: aRectangle
	^ self 
		drawText: aStringOrText 
		on: aCanvas 
		in: aRectangle 
		color: self stringColorToUse.! !

!ToggleMenuItemMorph methodsFor: 'private - drawing' stamp: ''!
drawText: aStringOrText on: aCanvas in: aRectangle color: stringColor 
	"Draw the text on the canvas within the given bounds."
	
	(self enabled not and: [self theme disabledItemStyle = #inset])
		ifTrue: [
				aCanvas
					drawString: aStringOrText
					in: aRectangle 
					font: self fontToUse
					color: stringColor muchLighter lighter;
					drawString: aStringOrText
					in: (aRectangle translateBy: -1)
					font: self fontToUse
					color: stringColor]
		ifFalse: [aCanvas
					drawString: aStringOrText
					in: aRectangle 
					font: self fontToUse
					color: stringColor ]! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
enablementSelector: anObject
	"Set the value of enablementSelector"

	enablementSelector := anObject! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
stringBoundsToUse
	"Answer the bounds to use when drawing the item text."
	
	^ self bounds! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
balloonText: aText

	self assureExtension balloonText: aText! !

!ToggleMenuItemMorph methodsFor: 'private - drawing' stamp: ''!
basicDrawOn: aCanvas 
	"Draw on the canvas. Taken from MenuItemMorph for minor refactoring."
	
	| stringColor stringBounds|
	stringColor := self stringColorToUse.
	stringBounds := self stringBoundsToUse.
	(self isSelected and: [self isEnabled]) ifTrue: [
		aCanvas
			fillRectangle: self bounds
			fillStyle: self selectionFillStyle
			borderStyle: self selectionBorderStyle].
	self hasIcon ifTrue: [ |iconForm|
		iconForm := self icon.
		self drawIcon: iconForm on: aCanvas in: stringBounds.
		stringBounds := stringBounds left: stringBounds left + (iconForm width) + (2*self displayScaleFactor)].
	self hasMarker ifTrue: [
		stringBounds := stringBounds left: stringBounds left + self submorphBounds width + (8 * self displayScaleFactor)].
	stringBounds := stringBounds top: stringBounds top + stringBounds bottom - self fontToUse height // 2.
	stringBounds := stringBounds bottom: stringBounds top + self fontToUse height.
	self drawText: contents on: aCanvas in: stringBounds.
	self hasSubMenu ifTrue: [ |subMenuMarker| 
		subMenuMarker := self subMenuMarker deepCopy mapColor: Color black to: stringColor.
		self drawSubMenuMarker: subMenuMarker on: aCanvas in: stringBounds]! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
getStateSelector: anObject
	"Set the value of getStateSelector"

	getStateSelector := anObject! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
adoptPaneColor: paneColor
	"Pass on to submenu too."
	
	super adoptPaneColor: paneColor.
	self hasSubMenu ifTrue: [self subMenu adoptPaneColor: paneColor]! !

!ToggleMenuItemMorph methodsFor: 'accessing' stamp: ''!
argumentsBlock: aBlock

	self arguments: aBlock value! !

!ToggleMenuItemMorph methodsFor: 'private - drawing' stamp: ''!
drawKeyTextOn: aCanvas 
	"Draw the key text on the canvas."
	
	self keyText ifNil: [^self].
	self itemShortcut drawOn: aCanvas! !

!ToggleMenuItemMorph methodsFor: 'private' stamp: ''!
offImage
	"Return the form to be used for indicating an '<off>' marker."
	
	|m form|
	m := CheckboxButtonMorph new
		privateOwner: self owner;
		adoptPaneColor: self paneColor;
		selected: false.
	form := Form extent: m extent depth: 32.
	form fillColor: (Color white alpha: 0.003922).
	form getCanvas fullDrawMorph: m.
	^form! !

!ToggleMenuItemShortcut commentStamp: ''!
I'm a generic shortcut text to be shown in amenu item. 
I'm generic because there are different strategies to be shown: 

1) Macs want to show symbols (like those weird command and option symbols)
2) Windows wants to show  them as "Alt + Shift + Something"
3) Linux can live with windows scheme

So, my subclasses implements text and symbol strategies. 

IMPORTANT:  I'm assuming the two current existing keyText "disposition" in system: 
- the "old style": just the letters, like 'o, t' or 'b'
- the "full style" (which is in part my fault, from some years ago): something like 'cmd+shift+O+T'.
I format those imputs into something similar (check #expand: method for better explanation).!
!ToggleMenuItemShortcut methodsFor: 'accessing' stamp: ''!
color: aColor

	color := aColor! !

!ToggleMenuItemShortcut methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	self subclassResponsibility! !

!ToggleMenuItemShortcut methodsFor: 'private' stamp: ''!
boundsForKeyText: aString font: aFont
	| ktp ktw b |
	
	ktp := self owner hasSubMenu
		ifTrue: [ self owner right - self owner subMenuMarker width ]
		ifFalse: [ self owner right ].
	ktp := ktp - (ktw := aFont widthOfString: aString).
	b := ktp @ ((self owner bounds top + self owner bounds bottom - aFont height) // 2) extent: ktw @ self owner height.
	^ b! !

!ToggleMenuItemShortcut methodsFor: 'initialization' stamp: ''!
initializeOwner: aMenuItem keyText: aString
	self initialize.
	owner := aMenuItem.
	keyText := self class normalize: aString! !

!ToggleMenuItemShortcut methodsFor: 'accessing' stamp: ''!
owner
	^ owner! !

!ToggleMenuItemShortcut methodsFor: 'accessing' stamp: ''!
keyText
	^ keyText! !

!ToggleMenuItemShortcut methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
normalizedKeyText: aString
	"Pass directly a normalised keytext"

	keyText := aString! !

!ToggleMenuItemShortcut methodsFor: 'accessing' stamp: ''!
color

	^ color ifNil: [ self theme ghostTextColor ]! !

!ToggleMenuItemShortcut methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: aCanvas
	self subclassResponsibility! !

!ToggleMenuItemShortcut class methodsFor: 'private' stamp: ''!
keyTextShortcuts
	^ #('cmd'. 'alt'. 'shift'.'ctrl'. 'meta' '⌘' '⇧')! !

!ToggleMenuItemShortcut class methodsFor: 'instance creation' stamp: ''!
new 
	self error: 'Use #owner:keyText:'! !

!ToggleMenuItemShortcut class methodsFor: 'private' stamp: ''!
normalizeCondensedStyle: aString
	"Assuming a keyText 'Old Style': the menu keys will come as 'o, k'"

	^ String streamContents: [ :stream | | keys |
		keys := (aString substrings: ',') collect: [ :each | each trimBoth ].
		stream << OSPlatform current menuShortcutString capitalized << '+'.
		keys 
			do: [ :each | 
			(each first isUppercase) ifTrue: [ stream << 'Shift+' ].
			stream << each asLowercase capitalized ]
			separatedBy: [ stream << '+' ] ]! !

!ToggleMenuItemShortcut class methodsFor: 'testing' stamp: ''!
canBeUsed
	^ false! !

!ToggleMenuItemShortcut class methodsFor: 'accessing' stamp: ''!
priority
	^ self subclassResponsibility! !

!ToggleMenuItemShortcut class methodsFor: 'private' stamp: ''!
normalizeFullStyle: aString
	"Assuming is a keytext with the format: 'cmd+shift+something'"

	^ String streamContents: [ :stream | 
			((aString substrings: '+') collect: [:each | each trimBoth])
				do: [ :each | stream << (each asLowercase capitalized) ]
				separatedBy: [ stream << '+' ] ]! !

!ToggleMenuItemShortcut class methodsFor: 'instance creation' stamp: ''!
owner: aMenuItem keyText: aString
	^ self shortcutClass basicNew 
		initializeOwner: aMenuItem keyText: aString;
		yourself! !

!ToggleMenuItemShortcut class methodsFor: 'private' stamp: ''!
shortcutClass
	"Answers first class that can be used. 
	 WARNING: Note than for speed I'm using #subclasses instead #allSubclasses, avoiding the scan of 
	 the hierarchy. This will not work if we extend the hierarchy more than one level"
	^ (self subclasses sorted: [ :a :b | a priority < b priority ])
		detect: #canBeUsed! !

!ToggleMenuItemShortcut class methodsFor: 'private' stamp: ''!
normalize: aString
	"This is a hack to show better explained menu commands. 
	 WARNING: This is now really good, but is an easy and fast way to enhance accesibility of 
	 menu commands."

	self keyTextShortcuts do: [ :each |
		(aString includesSubstring: each caseSensitive: false)
			ifTrue: [ ^ self normalizeFullStyle: aString ] ].   
	^ self normalizeCondensedStyle: aString! !

!ToggleMenuItemShortcutWithSymbol class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!ToggleMenuItemShortcutWithText commentStamp: ''!
I show a menu as a text. 
I'm the simplest mechanism and then, the default.!
!ToggleMenuItemShortcutWithText class methodsFor: 'testing' stamp: ''!
isDeprecated 	
	^ true! !

!ToggleWithSymbolMenuItemShortcut commentStamp: ''!
I prepare a shortcut as a combination of symbols (the command, alt, etc. symbols... check #symbolTable to have a detail). 
We also trust in the presence of FreeType fonts (a default nowadays) and "Lucida Grande" font, the mac font used to show menus. 

If any of this conditions are not fullfilled, ToggleMenuIttemMorph with not use me but my sibling.!
!ToggleWithSymbolMenuItemShortcut methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	| text paragraph keyBounds keyFont |

	text := self text.
	keyFont := self class symbolFont.

	keyBounds := self boundsForKeyText: text string font: keyFont.
	paragraph := Paragraph new
		compose: text
			style: (TextStyle fontArray: { keyFont })
			from: 1
			in: (0@0 corner: keyBounds corner);
		yourself.
		
	aCanvas 
		paragraph: paragraph 
		bounds: keyBounds 
		color: self color! !

!ToggleWithSymbolMenuItemShortcut methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: aCanvas
	| keyParts text paragraph keyBounds keyFont |

	keyParts := (self keyText substrings: '+') collect: [:each | each trimBoth].
	
	"Ensure shift is first"
	((keyParts includes: 'Shift') and: [ (keyParts first = 'Shift') not ])
		ifTrue: [ keyParts := (keyParts copyWithout: 'Shift') copyWithFirst: 'Shift' ].

	keyFont := self class symbolFont.

	text := keyParts 
		inject: Text new
		into: [ :s :each | 
			s, (self class 
				symbolTableAt: each
				ifAbsent: [ each capitalized ] )].

	keyBounds := self boundsForKeyText: text string font: keyFont.
	paragraph := Paragraph new
		compose: text
			style: (TextStyle fontArray: { keyFont })
			from: 1
			in: (0@0 corner: keyBounds corner);
		yourself.
	aCanvas asCanvasWrapper 
		paragraph: paragraph 
		bounds: keyBounds 
		color: self color! !

!ToggleWithSymbolMenuItemShortcut methodsFor: 'drawing' stamp: ''!
text
	| keyParts |
	keyParts := (self keyText substrings: '+') collect: [:each | each trimBoth].

	"Ensure shift is first"
	((keyParts includes: 'Shift') and: [ (keyParts first = 'Shift') not ])
		ifTrue: [ keyParts := (keyParts copyWithout: 'Shift') copyWithFirst: 'Shift' ].
	^ keyParts inject: Text new into: [ :s :each | s , (self class symbolTableAt: each ifAbsent: [ each capitalized ]) ]! !

!ToggleWithSymbolMenuItemShortcut class methodsFor: 'private' stamp: ''!
createSymbolTable
	| attributes |
	attributes := {TextFontReference toFont: self symbolFont}.
	^ Dictionary newFromPairs: { 
		#Cmd. 		Text string: (Character value: 16r2318) asString attributes: attributes.
		#Alt. 		Text string: (Character value: 16r2325) asString attributes: attributes. 
		#Ctrl.  	Text string: (Character value: 16r2303) asString attributes: attributes. 
		#Shift. 	Text string: (Character value: 16r21E7) asString attributes: attributes.
		"Lucida does not have the enter key"
		"#Enter. 	Text string: (Character value: 16r23ce) asString attributes: attributes" }.! !

!ToggleWithSymbolMenuItemShortcut class methodsFor: 'accessing' stamp: ''!
symbolTable
	^ SymbolTable ifNil: [ SymbolTable := self createSymbolTable ]! !

!ToggleWithSymbolMenuItemShortcut class methodsFor: 'testing' stamp: ''!
canBeUsed
	^ OSPlatform current isMacOS 
		and: [ self symbolFont isTTCFont 
		and: [ self symbolFont familyName = self symbolFont realFont face familyName ] ]! !

!ToggleWithSymbolMenuItemShortcut class methodsFor: 'accessing' stamp: ''!
priority
	^ 0! !

!ToggleWithSymbolMenuItemShortcut class methodsFor: 'private' stamp: ''!
createSymbolFont
	^ LogicalFont 
		familyName: 'Lucida Grande' 
		pointSize: 10! !

!ToggleWithSymbolMenuItemShortcut class methodsFor: 'accessing' stamp: ''!
symbolTableAt: anObject ifAbsent: aBlock
	^ self symbolTable at: anObject ifAbsent: aBlock! !

!ToggleWithSymbolMenuItemShortcut class methodsFor: 'accessing' stamp: ''!
symbolFont
	^ SymbolFont ifNil: [ SymbolFont := self createSymbolFont ]! !

!ToggleWithTextMenuItemShortcut commentStamp: ''!
I show a menu as a text. 
I'm the simplest mechanism and then, the default.!
!ToggleWithTextMenuItemShortcut methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	| keyBounds |
	
	keyBounds := self boundsForKeyText: self keyText font: self owner fontToUse.
	self owner
		drawText: keyText
		on: aCanvas
		in: keyBounds
		color: self color! !

!ToggleWithTextMenuItemShortcut methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: aCanvas
	| keyBounds |
	
	keyBounds := self boundsForKeyText: self keyText font: self owner fontToUse.
	self owner
		drawText: keyText
		onAthensCanvas: aCanvas
		in: keyBounds
		color: self owner theme disabledTextColor! !

!ToggleWithTextMenuItemShortcut methodsFor: 'accessing' stamp: ''!
text

	^ keyText! !

!ToggleWithTextMenuItemShortcut class methodsFor: 'testing' stamp: ''!
canBeUsed
	"this is the default and is available as default to all platforms"
	^ true! !

!ToggleWithTextMenuItemShortcut class methodsFor: 'accessing' stamp: ''!
priority
	"Lowest priority... last to be choosen"
	^ 999! !

!TokenTreeFilter commentStamp: ''!
I am a filter for a token.

If a node item contains my token I accept it!
!TokenTreeFilter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	token := ''.! !

!TokenTreeFilter methodsFor: 'filtering' stamp: ''!
keepTreeNode: aNode

	^ aNode matchTokenFilter: self! !

!TokenTreeFilter methodsFor: 'accessing' stamp: ''!
token
	^ token! !

!TokenTreeFilter methodsFor: 'accessing' stamp: ''!
token: anObject
	
	token := anObject! !

!TokenTreeFilter class methodsFor: 'instance creation' stamp: ''!
token: token

	^ self new
		token: token;
		yourself! !

!TonelCommentScanner commentStamp: '<historical>'!
I scan comments.!
!TonelCommentScanner methodsFor: 'scanning' stamp: ' 1/5/2022 20:56:19'!
scan
	| result ch eatNext |
	
	result := String new writeStream.

	eatNext := false.
	stream next = $" ifFalse: [ TonelParseError signal: 'Can''t parse comment' ].	
	[ stream atEnd not 
		and: [ 
				(ch := stream next) ~= $" 
				or: [ eatNext := (stream peek = $") ] ] ]
	whileTrue: [ 
		result nextPut: ch.
		eatNext ifTrue: [ 
			stream skip: 1.
			eatNext := false ] ].
	
	self flag: #todo. "This is a hack to make my clean algoritm for bodies work also for 
	comments. I need to refactor the 'eat enter' part out to use just that."
	^ self 
		removeFrom: '"',result contents,'"' withInternalLineEndings
		enclosingStart: $" 
		end: $"! !

!TonelFileSystemUtils commentStamp: 'EstebanLorenzano 9/21/2017 19:04'!
I'm a file utils implementation who works with FileSystem framework.
Pharo should use me.!
!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryPathString: aDirectory
    ^ aDirectory pathString! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryFromPath: directoryPath relativeTo: aDirectory
    ^ aDirectory resolveString: directoryPath! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
readStreamFor: filePath in: aDirectory do: aBlock
    "temporary hack for Pharo-1.4"

    ^ (aDirectory resolveString: filePath)
        readStreamDo: [ :fileStream | 
            | stream |
            stream := ReadStream on: fileStream contents asString.
            stream reset.
            aBlock value: stream ]! !

!TonelFileSystemUtils class methodsFor: 'initialization' stamp: ' 1/5/2022 20:56:19'!
initialize
    "self initialize"

    self install! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryFromPath: directoryPath
    ^ (AbsolutePath from: directoryPath delimiter: self pathNameDelimiter) asFileReference! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
pathNameDelimiter
    ^ DiskStore activeClass delimiter! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryFromEntry: directoryEntry
    ^ directoryEntry asFileReference! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryExists: aDirectory
    ^ aDirectory isDirectory! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
ensureDirectoryExists: aDirectory
    aDirectory ensureCreateDirectory! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
fileName: aDirectory
    ^ aDirectory basename! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
default
    ^ DiskStore activeClass createDefault defaultWorkingDirectory asFileReference! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
readStreamFor: filePath do: aBlock
    ^ filePath asFileReference
        readStreamDo: [ :fileStream | 
            | stream |
            stream := ReadStream on: fileStream contents asString.
            stream reset.
            aBlock value: stream ]! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
filePathExists: filePath relativeTo: aDirectory
    ^ (aDirectory resolveString: filePath) isFile! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
resolvePath: path in: aDirectory
    ^ aDirectory resolveString: path! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
writeStreamFor: filePath in: aDirectory do: aBlock
    (aDirectory resolveString: filePath) 
		ensureDelete;
		writeStreamDo: aBlock! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
parentDirectoryOf: aDirectory
    ^ aDirectory parent! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
deleteAll: aDirectory
    ^ aDirectory deleteAll! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
ensureFilePathExists: fileNameOrPath relativeTo: aDirectory
    (aDirectory resolveString: fileNameOrPath) parent ensureCreateDirectory! !

!TonelFileSystemUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryName: aDirectory
    ^ aDirectory basename! !

!TonelFileUtils commentStamp: 'EstebanLorenzano 9/21/2017 19:03'!
I declare file operations to be used in tonel. 
I'm necesary because tonel is meant to be portable, and different dialects have different ways of dealing with file systems. !
!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryPathString: aDirectory
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryFromPath: directoryPath relativeTo: aDirectory
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
readStreamFor: filePath in: aDirectory do: aBlock
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
current
    ^ Current! !

!TonelFileUtils class methodsFor: 'initialization' stamp: ' 1/5/2022 20:56:19'!
install
    Current := self! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryFromPath: directoryPath
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
pathNameDelimiter
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
buildPathFrom: pathCollection
    ^ String
        streamContents: [ :stream | pathCollection do: [ :element | stream nextPutAll: element ] separatedBy: [ stream nextPut: self pathNameDelimiter ] ]! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryExists: aDirectory
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
ensureDirectoryExists: aDirectory
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
fileName: aDirectory
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
default
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
readStreamFor: filePath do: aBlock
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
filePathExists: filePath relativeTo: aDirectory
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
resolvePath: path in: aDirectory
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
writeStreamFor: filePath in: aDirectory do: aBlock
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
parentDirectoryOf: aDirectory
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
deleteAll: aDirectory
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
ensureFilePathExists: fileNameOrPath relativeTo: aDirectory
    self subclassResponsibility! !

!TonelFileUtils class methodsFor: 'utilities' stamp: ' 1/5/2022 20:56:19'!
directoryName: aDirectory
    self subclassResponsibility! !

!TonelMock commentStamp: 'CyrilFerlicot 10/23/2018 15:55'!
Description
--------------------

I am a simple Mock for Tonel export test!
!TonelMock methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
instanceMethod
	^ true! !

!TonelMock class methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
classMethod
	^ 8! !

!TonelParseError commentStamp: 'EstebanLorenzano 9/11/2017 11:53'!
I'm a parsing error. 
I happen whenever the parsing of a tonel file is broken in someway.!
!TonelParser commentStamp: 'EstebanLorenzano 9/11/2017 12:09'!
I'm a parser for tonel files. 
I parse a class with the following format: 

Tonel spec
====

    [comment]
    type { typeDefinition }
    (
        [{ methodMetadata }]
        method [
            methodBody ] 
    )*


comment
---
"
comment string
"
is optional (but it should be there, in good design ;)

type
---
Class|Trait|Extension

typeDefinition
---
a STON file with class/trait/extension metadata

methodMetadata
---
a STON file with method metadata
is optional (but also, recommended)

method
---
method declaration as this: 

Class[ class] >> selector

methodBody 
---
the method body (we do not parse contents, that's class builder task)!
!TonelParser methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
validateStatelessTraitIsBeingRead: metadata
	| vars |
	
	vars := Set new.
	vars 
		addAll: (metadata at: #instVars ifAbsent: [ #() ]);
		addAll: (metadata at: #classInstVars ifAbsent: [ #() ]).
	
	vars ifNotEmpty: [ 
		self error: 'Trying to load a stateful trait in a stateless version.' ]! !

!TonelParser methodsFor: 'private factory' stamp: ' 1/5/2022 20:56:19'!
definitionForType: aString 
	aString = TonelWriter classLabel ifTrue: [ ^ MCClassDefinition ].
	aString = TonelWriter traitLabel ifTrue: [ ^ MCTraitDefinition ].	
	aString = TonelWriter extensionLabel ifTrue: [ ^ nil ].
	
	TonelParseError signal: 'Unknown type declaration.'! !

!TonelParser methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
removeComments: original
	| newStream readStream inComment |
	
	newStream := original copy writeStream.
	readStream := original readStream.
	inComment := false.
	
	[ readStream atEnd ] whileFalse: [ | ch |
		
		ch := readStream next.
		
		(ch = $") ifTrue:[
			inComment := inComment not.
			ch := readStream next.
		].
		
		(inComment or:[ ch isNil]) ifFalse: [ newStream nextPut: ch	 ]
	].
	
	^ newStream contents! !

!TonelParser methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
methodDefList
	| result |
	
	self separator. "to arrive to the end of the file in case there are no methods"
	result := Array new writeStream.
	[ stream atEnd ]
	whileFalse: [ 
		result nextPut: self methodDef.
		"skip possible spaces at the end"
		self separator ].
	
	^ result contents! !

!TonelParser methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
methodDef
	^ self newMethodDefinitionFrom: { 
		self separator.
		self try: [ self metadata ]. 
		self separator. 
		self method. 
		self methodBody 
	}! !

!TonelParser methodsFor: 'private factory' stamp: ' 1/5/2022 20:56:19'!
newMethodDefinitionFrom: anArray
	| metadata className meta selector source  |
	
	metadata := anArray second ifNil: [ Dictionary new ].
	className := anArray fourth first first.
	meta := anArray fourth first second notNil.
	selector := self extractSelector: anArray fourth second trimBoth.
	source := String streamContents: [ :s | 
		s << anArray fourth second.
		anArray fifth ifNotEmpty: [ :src | s << src ] ].
	
	^ MCMethodDefinition
		className: className
		classIsMeta: meta
		selector: selector
		category: (metadata at: #category ifAbsent: [ '' ]) 
		timeStamp: nil
		source: source! !

!TonelParser methodsFor: 'private parsing' stamp: ' 1/5/2022 20:56:19'!
try: aBlock
	^ self 
		try: aBlock 
		onSuccess: [ :parsedValue | parsedValue ] 
		onFailure: [ nil ]! !

!TonelParser methodsFor: 'private parsing' stamp: ' 1/5/2022 20:56:19'!
untilExcluding: aCollection
	| result |
	result := stream upToAll: aCollection.
	stream position: stream position - aCollection size.
	^ result! !

!TonelParser methodsFor: 'private parsing' stamp: ' 1/5/2022 20:56:19'!
try: aBlock onSuccess: successBlock onFailure: failureBlock
	| pos |
	
	pos := stream position.
	[ ^ successBlock value: aBlock value ]
	on: TonelParseError 
	do: [ :e | 
		stream position: pos.
		^ failureBlock value ]. 
	! !

!TonelParser methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
methodBody
	"I read a methodbody (what is inside [ ... ])"
	^ (TonelSourceScanner on: stream) scan
		
	! !

!TonelParser methodsFor: 'private factory' stamp: ' 1/5/2022 20:56:19'!
newStatefulTraitDefinitionFrom: anArray
	| metadata |
	
	metadata := anArray sixth.

	^ MCTraitDefinition
			name: (metadata at: #name)
			traitComposition: (metadata at: #traits ifAbsent: [ '{}' ])
			category: (metadata at: #category)
			instVarNames: (metadata at: #instVars ifAbsent: [ #() ])
			classInstVarNames: (metadata at: #classInstVars ifAbsent: [ #() ])
			classTraitComposition: (metadata at: #classTraits ifAbsent: [ '{}' ])
			comment: (anArray second ifNil: [ '' ])
			commentStamp: nil! !

!TonelParser methodsFor: 'private factory' stamp: ' 1/5/2022 20:56:19'!
newClassDefinitionFrom: anArray
	| metadata |

	metadata := anArray sixth.
	^ MCClassDefinition
		name: (metadata at: #name)
		superclassName: (metadata at: #superclass)
		traitComposition: (metadata at: #traits ifAbsent: [ '{}' ])
		classTraitComposition: (metadata at: #classTraits ifAbsent: [ '{}' ])
		category: (metadata at: #category)
		instVarNames: (metadata at: #instVars ifAbsent: [ #() ])
		classVarNames: (metadata at: 'classVars' ifAbsent: [ #() ])
		poolDictionaryNames: (metadata at: 'pools' ifAbsent: [ #() ])
		classInstVarNames: (metadata at: 'classInstVars' ifAbsent: [ #() ])
		type: (metadata at: #type ifAbsent: [ #normal ]) asSymbol
		comment: (anArray second ifNil: [ '' ])
		commentStamp: nil! !

!TonelParser methodsFor: 'private testing' stamp: ' 1/5/2022 20:56:19'!
isSeparator: aCharacter 
	^ aCharacter isSeparator! !

!TonelParser methodsFor: 'private factory' stamp: ' 1/5/2022 20:56:19'!
newTraitDefinitionFrom: anArray
	| metadata traitDefs |
	
	metadata := anArray sixth.
	traitDefs := { 
		self hasStatefulTraits 
			ifTrue: [ self newStatefulTraitDefinitionFrom: anArray ]
			ifFalse: [ self newStatelessTraitDefinitionFrom: anArray ] }.
			
	metadata 
		at: #classTraits
		ifPresent: [ :classTraits |
			traitDefs := traitDefs copyWith: (MCClassTraitDefinition
 				baseTraitName: (metadata at: #name)
 				classTraitComposition: classTraits
				category: (metadata at: #category)) ].
			
	^ traitDefs! !

!TonelParser methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
type
	self try: [ self word: 'Class' ] onSuccess: [ :word | ^ word  ].
	self try: [ self word: 'Trait' ] onSuccess: [ :word | ^ word  ].
	self try: [ self word: 'Extension' ] onSuccess: [ :word | ^ word  ].
	
	"at end"
	TonelParseError signal: 'Can''t parse type.'	
! !

!TonelParser methodsFor: 'private parsing' stamp: ' 1/5/2022 20:56:19'!
try: aBlock onFailure: failureBlock
	^ self 
		try: aBlock 
		onSuccess: [ :parsedValue |  parsedValue ] 
		onFailure: failureBlock! !

!TonelParser methodsFor: 'private testing' stamp: ' 1/5/2022 20:56:19'!
hasStatefulTraits
	"Pharo has stateful traits starting on version 7"
	
	^ SystemVersion current major >= 7! !

!TonelParser methodsFor: 'private factory' stamp: ' 1/5/2022 20:56:19'!
newStatelessTraitDefinitionFrom: anArray
	| metadata |
	
	metadata := anArray sixth.
	
	self validateStatelessTraitIsBeingRead: metadata.
	
	^ MCTraitDefinition
			name: (metadata at: #name)
			traitComposition: (metadata at: #traits ifAbsent: [ '{}' ])
			classTraitComposition: (metadata at: #classTraits ifAbsent: [ '{}' ])
			category: (metadata at: #category)
			comment: (anArray second ifNil: [ '' ])
			commentStamp: nil! !

!TonelParser methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
method
	| type selector |
	
	type := self untilIncluding: '>>'.
	selector := self cleanSelector: (self untilExcluding: '[').
	type := type trimBoth substrings: ' '.
	type size = 1 ifTrue: [ type := type copyWith: nil ].
	^ { 
		type.
		selector.
	}! !

!TonelParser methodsFor: 'private parsing' stamp: ' 1/5/2022 20:56:19'!
word: aString
	| result |
	result := stream next: aString size.
	result = aString
		ifFalse: [ TonelParseError signal: 'Can''t parse ', aString ].
	^ result! !

!TonelParser methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
cleanSelector: aString
	"BEWARE: I'm doing some heave assumptions here: I'm removing just ONE space (in case there 
	 is one) because I expect this to be a file generated by tonel, and tonel adds one space 
	 before start with the method body to make the format more readable. 
	 But of course this is not very good :("
	^ (aString last = Character space
		ifTrue: [ aString allButLast ]
		ifFalse: [ aString ]) 
		trimLeft! !

!TonelParser methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
typeDef
	^ self newTypeDefinitionFrom: { 
		self separator.
		self try: [ self comment ]. 
		self separator. 
		self type. 
		self separator. 
		self try: [ self metadata ] 
	} 
	
		! !

!TonelParser methodsFor: 'private factory' stamp: ' 1/5/2022 20:56:19'!
newTypeDefinitionFrom: anArray
	| typeClass |
	
	typeClass := self definitionForType: anArray fourth.
	typeClass = MCClassDefinition ifTrue: [ ^ self newClassDefinitionFrom: anArray ].
	typeClass = MCTraitDefinition ifTrue: [ ^ self newTraitDefinitionFrom: anArray ].	
	"is extension, no type"
	^ nil! !

!TonelParser methodsFor: 'private parsing' stamp: ' 1/5/2022 20:56:19'!
untilIncluding: aCollection
	^ stream upToAll: aCollection! !

!TonelParser methodsFor: 'private parsing' stamp: ' 1/5/2022 20:56:19'!
try: aBlock onSuccess: successBlock
	^ self 
		try: aBlock 
		onSuccess: successBlock 
		onFailure: [ nil ]! !

!TonelParser methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
stream: aStream 
	stream := aStream! !

!TonelParser methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
comment
	^ (TonelCommentScanner on: stream) scan! !

!TonelParser methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
document
	^ { 
	self typeDef.
	self methodDefList.
	 } 
	flattened
	select: #notNil! !

!TonelParser methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
separator
	[ stream atEnd not and: [ self isSeparator: stream peek ] ]
	whileTrue: [ stream next ].
	^ nil! !

!TonelParser methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
extractSelector: aString
	| separators selectorStream keywords |
	
	separators := { 
		Character space. 
		Character tab. 
		Character lf. 
		Character newPage. 
		Character cr. 
		$:}.

	keywords := Array new writeStream.
	selectorStream := (self removeComments: aString) readStream.

	[ selectorStream atEnd ]
	whileFalse: [ | word ch |
		word := String new writeStream.
		[ selectorStream atEnd not and: [ (separators includes: (ch := selectorStream next)) not ] ]
		whileTrue: [ word nextPut: ch ].
		ch = $: ifTrue: [ word nextPut: ch ]. 
		word contents trimBoth ifNotEmpty: [ :v | keywords nextPut: v ] ].
	keywords := keywords contents.

	^ (keywords size <= 2 
		ifTrue: [ keywords first]
		ifFalse: [ ('' join: (keywords pairsCollect: [ :keyword :argument | keyword ])) ])
		asSymbol
! !

!TonelParser methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
start
	^ self document! !

!TonelParser methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
metadata
	| result ch count |
	
	result := String new writeStream.

	count := 0.
	stream peek = ${ ifFalse: [ TonelParseError signal: 'Can''t parse metadata' ].	
	[ stream atEnd ]
	whileFalse: [ 
		ch := stream next.
		result nextPut: ch.
		ch = ${ ifTrue: [ count := count +1 ].
		ch = $} ifTrue: [ count := count -1 ].
		count = 0 ifTrue: [ ^ STON fromString: result contents ]].

	TonelParseError signal: 'Can''t parse metadata'! !

!TonelParser class methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
parseStream: aStream 
	^ (self on: aStream) start! !

!TonelParser class methodsFor: 'instance creation' stamp: ' 1/5/2022 20:56:19'!
on: aStream 
	^ self new 
		stream: aStream;
		yourself! !

!TonelParser class methodsFor: 'parsing' stamp: ' 1/5/2022 20:56:19'!
parseString: aString 
	^ self parseStream: aString readStream! !

!TonelParserTest methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
parse: aString rule: rule
	| parser |
	
	parser := TonelParser on: aString readStream.
	 ^ parser perform: rule.
	! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMethodBodyWithSquareBracketInsideLiteralArray
    self 
        assertParse: '[ "What about this valid literal Array guys" ^#( [ )]'
        rule: #methodBody
        equals: ' "What about this valid literal Array guys" ^#( [ )'.! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testExtractSelectorWithComments
	| parser |
	
	parser := TonelParser new.
	
	self assert: (parser extractSelector: 'unary "comment"') equals: #unary.
	self assert: (parser extractSelector: '+ "comment" something') equals: #+.
	self assert: (parser extractSelector: '==> "comment" other') equals: #==>.
	self 
		assert: (parser extractSelector: 'some: arg1 "comment"  keyword: arg2  "comment" selector: arg3 "comment"') 
		equals: #some:keyword:selector:.
	self 
		assert: (parser extractSelector: 'some: 	arg1 "comment" keyword:arg2 selector: arg3') 
		equals: #some:keyword:selector:.
	self 
		assert: (parser extractSelector: 'some: arg1 "comment"
keyword: arg2 "comment"
selector: arg3') 
		equals: #some:keyword:selector:.! !

!TonelParserTest methodsFor: 'asserting' stamp: ' 1/5/2022 21:01:26'!
assertParse: aString rule: rule equals: result 
	self 
		assert: (self parse: aString rule: rule)
		equals: result! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMethodBodyWithTrickyDollarCharLiteralInLiteralArray
	self 
        assertParse: '[^#( $$''please use space before this string)(''$$"please use space before this comment or avoid putting a ] in it"$$(this really is a literal array with a ] in it))]'
        rule: #methodBody
        equals: '^#( $$''please use space before this string)(''$$"please use space before this comment or avoid putting a ] in it"$$(this really is a literal array with a ] in it))'! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testTypeDef
	self 
		assertParse: '
"
this is a test
"
Class { 
	#name: ''X'',
	#superclass: ''Y'',
	#category: ''Z'' 
}'
		rule: #typeDef
		equals: (MCClassDefinition
        name: 'X'
        superclassName: 'Y'
        traitComposition: '{}'
        classTraitComposition: '{}'
        category: 'Z'
        instVarNames: #()
        classVarNames: #()
        poolDictionaryNames: #()
        classInstVarNames: #()
        type: #normal
        comment: 'this is a test'
        commentStamp: nil)! !

!TonelParserTest methodsFor: 'asserting' stamp: ' 1/5/2022 21:01:26'!
shouldParse: aString rule: rule raise: error 
	| parser |
	
	parser := TonelParser on: aString readStream.
	self 
		should: [ parser perform: rule ]
		raise: error! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLiteralDollarCharacterAtEndOfLiteralArray
    self 
        assertParse: '[^#($$)]'
        rule: #methodBody
        equals: '^#($$)'.! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testType
	self assertParse: 'Class' rule: #type equals: 'Class'.
	self assertParse: 'Trait' rule: #type equals: 'Trait'.
	self assertParse: 'Extension' rule: #type equals: 'Extension'! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMetadata
	self 
		assertParse: '{ #vars: [ #a, #b ] }' 
		rule: #metadata 
		equals: { #vars -> #(a b) } asDictionary.
	
	self 
		assertParse: '{ 
	#vars: [ #a, #b ],
	#uses: { #someNested: 42 } 
	}' 
		rule: #metadata 
		equals: { 
			#vars -> #(a b). 
			#uses -> { #someNested -> 42 } asDictionary
		} asDictionary
! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMethodBodyWithBlockContainingDollarCharacter
	"https://github.com/pharo-vcs/tonel/issues/44"

	self assertParse: '[ $$ ]' rule: #methodBody equals: ' $$'.
	self assertParse: '[$$ ]' rule: #methodBody equals: '$$'.
	self assertParse: '[ $$]' rule: #methodBody equals: ' $$'.
	self assertParse: '[$$]' rule: #methodBody equals: '$$'! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMethod
	self 
		assertParse: 'Object>>name' 
		rule: #method
		equals: #(('Object' nil) 'name').
		
	self 
		assertParse: 'Object >> name: aString' 
		rule: #method
		equals: #(('Object' nil) 'name: aString').
		
	self 
		assertParse: 'Object >> name: aString [ I do not care ]' 
		rule: #method
		equals: #(('Object' nil) 'name: aString').
		
	self 
		assertParse: 'Object class >> name: aString' 
		rule: #method
		equals: #(('Object' 'class') 'name: aString').! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMethodBodyWithSquareBracketInsideLiteralArray2
    self 
        assertParse: '[^#( "note that we need to prefix ) with $, but this is not necessary for ] and }" '')]}'' $) ] } )]'
        rule: #methodBody
        equals: '^#( "note that we need to prefix ) with $, but this is not necessary for ] and }" '')]}'' $) ] } )'.! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMethodDefList
	| parsed |
	
	parsed := self 
		parse: '
Object class>>new [
	^ self basicNew initialize
]

{ #category: ''accessing'' }
Object>>name [
	^ self printString
]

{ #category: ''printing'' }
Object>>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

]'
		rule: #methodDefList.
		
	self assert: parsed size equals: 3
! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMethodDef
	self 
		assertParse: '
{ #category: ''accessing'' }
Object>>name [
	^ self printString
]'
		rule: #methodDef
		equals: (MCMethodDefinition
			className: #Object
			classIsMeta: false
			selector: #name
			category: 'accessing' 
			timeStamp: nil
			source: 'name
	^ self printString').
			
	self 
		assertParse: '
Object class>>name [ 
	^ self printString
]'
		rule: #methodDef
		equals: (MCMethodDefinition
			className: #Object
			classIsMeta: true
			selector: #name
			category: ''
			timeStamp: nil
			source: 'name 
	^ self printString').

	self 
		assertParse: '
TClass classSide >> template: aSystemCategoryName [ 
	"I really do not care"
]'
		rule: #methodDef
		equals: (MCMethodDefinition
			className: #TClass
			classIsMeta: true
			selector: #template:
			category: ''
			timeStamp: nil
			source: 'template: aSystemCategoryName 
	"I really do not care"').
! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testExtractSelector
	| parser |
	
	parser := TonelParser new.
	
	self assert: (parser extractSelector: 'unary') equals: #unary.
	self assert: (parser extractSelector: '+ something') equals: #+.
	self assert: (parser extractSelector: '==> other') equals: #==>.
	self 
		assert: (parser extractSelector: 'some: arg1 keyword: arg2 selector: arg3') 
		equals: #some:keyword:selector:.
	self 
		assert: (parser extractSelector: 'some: 	arg1 keyword:arg2 selector: arg3') 
		equals: #some:keyword:selector:.
	self 
		assert: (parser extractSelector: 'some: arg1 
keyword: arg2 
selector: arg3') 
		equals: #some:keyword:selector:.! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testComment
	self 
		shouldParse: 'this "should" be an error'
		rule: #comment
		raise: TonelParseError.
	
	self  
		assertParse: '"this is a comment"'
		rule: #comment
		equals: 'this is a comment'.
	
	self  
		assertParse: '"""this"" is a comment with ""nested"" colons ""also at the end"""'
		rule: #comment
		equals: '"this" is a comment with "nested" colons "also at the end"'	
		
		
! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMethodBody
	self 
		assertParse: '[ method body... I will ignore what is inside ]'
		rule: #methodBody
		equals: ' method body... I will ignore what is inside'.

	self 
		assertParse: '[
method 
	[body... [I 
		will ignore] 
what] is inside
]'
		rule: #methodBody
		equals: '
method 
	[body... [I 
		will ignore] 
what] is inside'.
		
	self 
		assertParse: '[ method body with "''", ''"'', "[", '']'' ]'
		rule: #methodBody
		equals: ' method body with "''", ''"'', "[", '']'''.
	! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMaybeReturnADollar
    self 
        assertParse: '[self testSomething ifTrue: [^$$]]'
        rule: #methodBody
        equals: 'self testSomething ifTrue: [^$$]'.! !

!TonelParserTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testMethodBodyWithCommentNextToDollarCharLiteral
	self 
        assertParse: '[^$$"what about this one]"]'
        rule: #methodBody
        equals: '^$$"what about this one]"'! !

!TonelReader commentStamp: 'GuillermoPolito 7/11/2018 11:02'!
I'm a monticello reader for tonel format repositories. I read
 - a package per directory
 - a class per file
 - a set of extensions to a single class per file (for example, all extensions of a package to String will be in a single file)

I'm created on a file reference to a directory where the package will be read and the name of the package to read.

[[[
TonelReader on: 'someDirectoryWithTonelPackages' asFileReference filename: 'MyPackageName'
]]]

My main method is
- ==#definitions== reads and parses the tonel file, returns a list of monticello definitions.
- ==#snapshot== returns a monticello snapshot with the read definitions.
- ==#version== returns a monticello version with the read snapshot.

!! Implementation details

The monticello versions I return do have artificial information. Since I'm just meant to read versions from a directory, this directory has no information such as commit message, commit time, author, or ancestors. Check the method ==#loadVersionInfo== for more information.!
!TonelReader methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
categoriesFrom: aCollection
	^ ((aCollection select: #isClassDefinition)
		collect: #category
		as: Set)
		sorted: [ :a :b | a < b ]! !

!TonelReader methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
canBeLoaded: aFileReference
	| fileName |
	fileName := self fileUtils fileName: aFileReference. 
	
	"If the file begins with a `.` then it is an hidden file and should not be loaded."
	(fileName beginsWith: '.') ifTrue: [ ^ false ].

	^ fileName ~= 'package.st' and: [ fileName endsWith: '.st' ]! !

!TonelReader methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
packageDirectory
	^ packageDirectory! !

!TonelReader methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
packageNameFromPackageDirectory
    ^ packageDirectory basename! !

!TonelReader methodsFor: 'loading' stamp: ' 1/5/2022 20:56:19'!
loadPackage
	package := MCPackage named: self packageNameFromPackageDirectory! !

!TonelReader methodsFor: 'loading' stamp: ' 1/5/2022 20:56:19'!
loadDependencies
	"There should not be dependencies"
	dependencies := #()! !

!TonelReader methodsFor: 'loading' stamp: ' 1/5/2022 20:56:19'!
loadDefinitions
	| definitionOrders newDefinitions newCategories organization |
	
	definitionOrders := self class definitionOrders.
	newDefinitions := ((self packageDirectory entries
		select: [ :each | self canBeLoaded: each ]) 
		collect: [ :each | each readStreamDo: [ :s | TonelParser parseStream: s ] ])
		flattened
		sort: [ :a :b | (definitionOrders at: a class) < (definitionOrders at: b class) ].

	newCategories := self categoriesFrom: newDefinitions.
	(newCategories includes: self package name asSymbol)
		ifFalse: [ newCategories := newCategories copyWithFirst: self package name ].
	organization := MCOrganizationDefinition categories: newCategories.
	
	definitions := (newDefinitions copyWithFirst: organization) sort! !

!TonelReader methodsFor: 'loading' stamp: ' 1/5/2022 20:56:19'!
loadVersionInfo
	info := MCVersionInfo
		name: self packageNameFromPackageDirectory, '-tonel.1'
		id: UUID new
		message: 'fabricated from a Tonel format repository'
		date: Date today
		time: Time now
		author: ''
		ancestors: #()
		stepChildren: #()! !

!TonelReader methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
fileUtils
	^ TonelFileUtils current! !

!TonelReader methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
packageDirectory: aDirectoryName
	packageDirectory := self fileUtils 
		directoryFromPath: aDirectoryName 
		relativeTo: stream! !

!TonelReader class methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
extension
	"This is needed because the implementation of MCCacheRepository assumes each package 
	 has an extension (which is a lame implementation) and then we need to provide one. 
	 Since tonel is not cached (because we have our oen cache in the form of a local repository), 
	 we put something that will not be found anyway"
	^ 'NOTUSED'
		! !

!TonelReader class methodsFor: 'reading' stamp: ' 1/5/2022 20:56:19'!
on: parentDirectoryReference fileName: packageName
	"I will anster a reader for the package stored in 
	
		[repository]/parentDirectoryReference/packageName
	
	This operation will NOT read the package, but resulting instance will be prepared
	to doit, executing: #loadDefinitions"

	^ (self on: parentDirectoryReference)
		packageDirectory: packageName;
		yourself! !

!TonelReader class methodsFor: 'testing' stamp: ' 1/5/2022 20:56:19'!
canReadFileNamed: fileName
	"We validate that fileName does not contains dot, but that's the only thing we can do 
	 at this point."
	^ fileName noneSatisfy: [ :each | each = $. ]! !

!TonelReader class methodsFor: 'testing' stamp: ' 1/5/2022 20:56:19'!
isAbstract
	^ false! !

!TonelReader class methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
definitionOrders
	"Used to sort definitions inside a snapshot"
	^ Dictionary newFromPairs: { 
		MCOrganizationDefinition. 	0.
		MCMethodDefinition. 			1.
		MCClassDefinition. 			2.
		MCTraitDefinition. 			2.
		MCClassTraitDefinition. 		3 }! !

!TonelReaderTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
assertDefinition: a and: b
	a isOrganizationDefinition ifTrue: [ ^ self assertOrganisationDefinition: a and: b ].
	a isClassDefinition ifTrue: [ ^ self assertClassDefinition: a and: b ].
	a isMethodDefinition ifTrue: [ ^ self assertMethodDefinition: a and: b ].! !

!TonelReaderTest methodsFor: 'private factory' stamp: ' 1/5/2022 21:01:26'!
newMemoryFileSystemSnapshot: aSnapshop
	"This method assumes writer works. If it is broken (the tests should show it), this tests 
	 will break too."
	| mem |
	mem := FileSystem memory root.
	(TonelWriter on: mem) writeSnapshot: aSnapshop.
	^ mem! !

!TonelReaderTest methodsFor: 'mocks' stamp: ' 1/5/2022 21:01:26'!
mockSnapshot
	"HACK: since the serialization test changes the method definition (and it does not restores to 
	 previous value), validation fails randomly. And since what I will test does not needs that 
	 method, I will just remove it."
	^ STON fromString: self class mockSnapshotSTON! !

!TonelReaderTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
assertMethodDefinition: a and: b
	self assert: a className equals: b className.
	self assert: a selector equals: b selector.
	self assert: a protocol equals: b protocol.
	self assert: a source asByteArray equals: b source asByteArray.
	self assert: a classIsMeta equals: b classIsMeta! !

!TonelReaderTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
assertOrganisationDefinition: a and: b
	self assert: a categories equals: b categories! !

!TonelReaderTest methodsFor: 'mocks' stamp: ' 1/5/2022 21:01:26'!
mockSnapshotWithCommentsInSelector
	"HACK: since the serialization test changes the method definition (and it does not restores to 
	 previous value), validation fails randomly. And since what I will test does not needs that 
	 method, I will just remove it."
	^ STON fromString: self class mockSnapshotSTONWithCommentsInSelector! !

!TonelReaderTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testHiddenFilesAreIgnored
	| snapshot mem reader |
	
	snapshot := self mockSnapshot.
	mem := self newMemoryFileSystemSnapshot: snapshot.
	(mem / 'MonticelloMocks' / '._MCMockClassG.class.st') ensureCreateFile; writeStreamDo: [ :s | s << 'This file should be ignored' ].
	reader := TonelReader on: mem fileName: 'MonticelloMocks'.
	reader loadDefinitions.
	
	self 
		assert: reader definitions size 
		equals: snapshot definitions size.
		
	reader definitions sorted 
		with: snapshot definitions sorted
		do: [ :a :b | self assertDefinition: a and: b ]! !

!TonelReaderTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadSelectorWithComments
	| snapshot mem reader |
	
	snapshot := self mockSnapshotWithCommentsInSelector.
	mem := self newMemoryFileSystemSnapshot: snapshot.
	reader := TonelReader on: mem fileName: 'MonticelloMocks'.
	reader loadDefinitions.
	
	self 
		assert: reader definitions size 
		equals: snapshot definitions size.
		
	reader definitions sorted 
		with: snapshot definitions sorted
		do: [ :a :b | self assertDefinition: a and: b ]! !

!TonelReaderTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
assertClassDefinition: a and: b
	self assert: a className equals: b className.
	self assert: a superclassName equals: b superclassName.
	self assert: a traitCompositionString equals: b traitCompositionString.
	self assert: a classTraitCompositionString equals: b classTraitCompositionString.
	self assert: a category equals: b category.	
	self assert: a instVarNames equals: b instVarNames.
	self assert: a classInstVarNames equals: b classInstVarNames.
	self assert: a classVarNames equals: b classVarNames.
	self assert: a poolDictionaries equals: b poolDictionaries.
	self assert: a type equals: b type.
	self assert: a comment equals: b comment.! !

!TonelReaderTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadDefinitions
	| snapshot mem reader |
	
	snapshot := self mockSnapshot.
	mem := self newMemoryFileSystemSnapshot: snapshot.
	reader := TonelReader on: mem fileName: 'MonticelloMocks'.
	reader loadDefinitions.
	
	self 
		assert: reader definitions size 
		equals: snapshot definitions size.
		
	reader definitions sorted 
		with: snapshot definitions sorted
		do: [ :a :b | self assertDefinition: a and: b ]! !

!TonelReaderTest class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
mockSnapshotSTON
	^ 'MCSnapshot {
	#definitions : [
		MCOrganizationDefinition {
			#categories : [
				#MonticelloMocks
			]
		},
		MCClassDefinition {
			#name : #MCMockASubclass,
			#superclassName : #MCMockClassA,
			#variables : OrderedCollection [
				MCInstanceVariableDefinition {
					#name : ''x''
				},
				MCClassVariableDefinition {
					#name : ''Y''
				}
			],
			#category : #MonticelloMocks,
			#type : #normal,
			#comment : '''',
			#commentStamp : '''',
			#traitComposition : ''{}'',
			#classTraitComposition : ''{}''
		},
		MCMethodDefinition {
			#classIsMeta : true,
			#source : ''initialize\r\r\tInitializationOrder := InitializationOrder\r\t\tifNil: [ -100 ] "let the test fail"\r\t\tifNotNil: [ InitializationOrder + 1.]'',
			#category : #''as yet unclassified'',
			#selector : #initialize,
			#className : #MCMockASubclass
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''variables\r\t^ x + Y + MCMockClassA'',
			#category : #''as yet unclassified'',
			#selector : #variables,
			#className : #MCMockASubclass
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''variables2\r\t^ ivar + CVar'',
			#category : #''as yet unclassified'',
			#selector : #variables2,
			#className : #MCMockASubclass
		},
		MCClassDefinition {
			#name : #MCMockClassA,
			#superclassName : #MCMock,
			#variables : OrderedCollection [
				MCInstanceVariableDefinition {
					#name : ''ivar''
				},
				MCClassVariableDefinition {
					#name : ''CVar''
				},
				MCClassVariableDefinition {
					#name : ''InitializationOrder''
				}
			],
			#category : #MonticelloMocks,
			#type : #normal,
			#comment : ''This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.'',
			#commentStamp : ''cwp 8/10/2003 16:43'',
			#traitComposition : ''{}'',
			#classTraitComposition : ''{}''
		},
		MCMethodDefinition {
			#classIsMeta : true,
			#source : ''cVar\r\t^ CVar'',
			#category : #''as yet unclassified'',
			#selector : #cVar,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : true,
			#source : ''initializationOrder\r\r\t^ InitializationOrder'',
			#category : #''as yet unclassified'',
			#selector : #initializationOrder,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : true,
			#source : ''initialize\r\tCVar := #initialized.\r\tInitializationOrder := 1.\r'',
			#category : #''as yet unclassified'',
			#selector : #initialize,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : true,
			#source : ''one\r\r\t^ 1'',
			#category : #''as yet unclassified'',
			#selector : #one,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : true,
			#source : ''touchCVar\r\tCVar := #touched'',
			#category : #''as yet unclassified'',
			#selector : #touchCVar,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''a\r\t^ \''a2\'''',
			#category : #numeric,
			#selector : #a,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''b\r\t^ \''b1\'''',
			#category : #numeric,
			#selector : #b,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''c\r\t^ \''c1\'''',
			#category : #numeric,
			#selector : #c,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''d\r\t^ \''d\'''',
			#category : #numeric,
			#selector : #d,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''falsehood\r\t^ false'',
			#category : #boolean,
			#selector : #falsehood,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''moreTruth\r\r\t^ true'',
			#category : #boolean,
			#selector : #moreTruth,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''one\r\t^ 1'',
			#category : #numeric,
			#selector : #one,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''q'',
			#category : #''drag\''n\''drop'',
			#selector : #q,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''truth\r\t^ true'',
			#category : #boolean,
			#selector : #truth,
			#className : #MCMockClassA
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''two\r\t^ 2'',
			#category : #numeric,
			#selector : #two,
			#className : #MCMockClassA
		},
		MCClassDefinition {
			#name : #MCMockClassB,
			#superclassName : #MCMock,
			#variables : OrderedCollection [
				MCInstanceVariableDefinition {
					#name : ''ivarb''
				},
				MCClassVariableDefinition {
					#name : ''CVar''
				},
				MCPoolImportDefinition {
					#name : ''MCMockAPoolDictionary''
				},
				MCClassInstanceVariableDefinition {
					#name : ''ciVar''
				}
			],
			#category : #MonticelloMocks,
			#type : #normal,
			#comment : ''This comment has a bang!! Bang!! Bang!!'',
			#commentStamp : '''',
			#traitComposition : ''{}'',
			#classTraitComposition : ''{}''
		},
		MCClassDefinition {
			#name : #MCMockClassD,
			#superclassName : #Object,
			#variables : OrderedCollection [ ],
			#category : #MonticelloMocks,
			#type : #normal,
			#comment : '''',
			#commentStamp : '''',
			#traitComposition : ''{}'',
			#classTraitComposition : ''{}''
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''one\r\t^ 1'',
			#category : #''as yet unclassified'',
			#selector : #one,
			#className : #MCMockClassD
		},
		MCClassDefinition {
			#name : #MCMockClassE,
			#superclassName : #Object,
			#variables : OrderedCollection [ ],
			#category : #MonticelloMocks,
			#type : #variable,
			#comment : '''',
			#commentStamp : '''',
			#traitComposition : ''{}'',
			#classTraitComposition : ''{}''
		},
		MCMethodDefinition {
			#classIsMeta : true,
			#source : ''two\r\t^ 2'',
			#category : #''as yet unclassified'',
			#selector : #two,
			#className : #MCMockClassE
		},
		MCClassDefinition {
			#name : #MCMockClassF,
			#superclassName : #Object,
			#variables : OrderedCollection [
				MCClassVariableDefinition {
					#name : ''Foo''
				}
			],
			#category : #MonticelloMocks,
			#type : #normal,
			#comment : '''',
			#commentStamp : '''',
			#traitComposition : ''{}'',
			#classTraitComposition : ''{}''
		},
		MCClassDefinition {
			#name : #MCMockClassG,
			#superclassName : #Object,
			#variables : OrderedCollection [ ],
			#category : #MonticelloMocks,
			#type : #words,
			#comment : '''',
			#commentStamp : '''',
			#traitComposition : ''{}'',
			#classTraitComposition : ''{}''
		},
		MCClassDefinition {
			#name : #MCMockClassH,
			#superclassName : #Object,
			#variables : OrderedCollection [ ],
			#category : #MonticelloMocks,
			#type : #bytes,
			#comment : '''',
			#commentStamp : '''',
			#traitComposition : ''{}'',
			#classTraitComposition : ''{}''
		},
		MCClassDefinition {
			#name : #MCMockClassI,
			#superclassName : #Object,
			#variables : OrderedCollection [ ],
			#category : #MonticelloMocks,
			#type : #weak,
			#comment : '''',
			#commentStamp : '''',
			#traitComposition : ''{}'',
			#classTraitComposition : ''{}''
		},
		MCMethodDefinition {
			#classIsMeta : false,
			#source : ''mockClassExtension\r\r\t"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. " '',
			#category : #''*MonticelloMocks'',
			#selector : #mockClassExtension,
			#className : #MCSnapshotTest
		}
	]
}'! !

!TonelReaderTest class methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
mockSnapshotSTONWithCommentsInSelector
	^ 'MCSnapshot {
	#definitions : [
		MCOrganizationDefinition {
			#categories : [
				#MonticelloMocks
			]
		},
		MCClassDefinition {
			#name : #MCMockASubclass,
			#superclassName : #MCMockClassA,
			#variables : OrderedCollection [
				MCInstanceVariableDefinition {
					#name : ''x''
				},
				MCClassVariableDefinition {
					#name : ''Y''
				}
			],
			#category : #MonticelloMocks,
			#type : #normal,
			#comment : '''',
			#commentStamp : '''',
			#traitComposition : ''{}'',
			#classTraitComposition : ''{}''
		},
		MCMethodDefinition {
			#classIsMeta : true,
			#source : ''block: aBlock "<BlockContext>" argsClass: argsProxyClass "<Alien class>" "^<Callback>"\r\t"Answer a Callback that evaluates aBlock and whose thunk should conform to the C calling convention."\r\t<legacy>\r\t^self new\r\t\tblock: aBlock\r\t\tthunk: FFICallbackThunk newCCall\r\t\targsProxyClass: argsProxyClass'',
			#category : #''as yet unclassified'',
			#selector : #''block:argsClass:'',
			#className : #MCMockASubclass
		}
	]
}'! !

!TonelReaderTraitCompositionTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadTraitWithoutClassTraitCompositionDoesNotHaveTraitComposition
	
	| classDefinition |

	classDefinition := self 
		readDefinitionOfClass: 'SomeTrait' 
		fromPackage: 'MonticelloTonel-Tests'
		whitContent: [ :s | s << 
'Trait {
	#name : #SomeTrait,
	#category : #Kernel
}' ].

	self deny: classDefinition hasClassTraitComposition.! !

!TonelReaderTraitCompositionTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadClassWithoutClassTraitCompositionDoesNotHaveTraitComposition
	
	| classDefinition |

	classDefinition := self 
		readDefinitionOfClass: 'SomeObject' 
		fromPackage: 'MonticelloTonel-Tests'
		whitContent: [ :s | s << 
'Class {
	#name : #SomeObject,
	#superclass : #Object,
	#category : #Kernel
}' ].

	self deny: classDefinition hasClassTraitComposition.! !

!TonelReaderTraitCompositionTest methodsFor: 'helper' stamp: ' 1/5/2022 21:01:26'!
readDefinitionOfClass: aClassName fromPackage: aPackageName whitContent: aBlockClosure 

	| mem reader definitions |
	mem := FileSystem memory root.	
	(mem / aPackageName / (aClassName , '.class.st')) 
		ensureCreateFile; 
		writeStreamDo: aBlockClosure.

	reader := TonelReader on: mem fileName: aPackageName.
	reader loadDefinitions.
	definitions := reader definitions.
	
	^ definitions detect: [ :aDef | aDef isOrganizationDefinition not and: [aDef className = aClassName] ].
	! !

!TonelReaderTraitCompositionTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadClassWithClassTraitCompositionDoesHaveTheCorrectTraitComposition
	| classDefinition |

	classDefinition := self 
		readDefinitionOfClass: 'SomeObject' 
		fromPackage: 'MonticelloTonel-Tests'
		whitContent: [ :s | s << 
'Class {
	#name : #SomeObject,
	#superclass : #Object,
	#traits : ''T1 + T1'',
	#classTraits : ''T1 classTrait + T2 classTrait'',	
	#category : #''MonticelloTonel-Tests''
}' ].

	self assert: classDefinition classTraitComposition equals: 'T1 classTrait + T2 classTrait'.	! !

!TonelReaderTraitCompositionTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadTraitWithClassTraitCompositionIsATrait
	| classDefinition |

	classDefinition := self 
		readDefinitionOfClass: 'SomeTrait' 
		fromPackage: 'MonticelloTonel-Tests'
		whitContent: [ :s | s << 
'Trait {
	#name : #SomeTrait,
	#traits : ''T1 + T1'',
	#classTraits : ''T1 classTrait + T2 classTrait'',	
	#category : #''MonticelloTonel-Tests''
}' ].

	self assert: classDefinition isTraitDefinition! !

!TonelReaderTraitCompositionTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadClassWithClassTraitCompositionIsAClass
	| classDefinition |

	classDefinition := self 
		readDefinitionOfClass: 'SomeObject' 
		fromPackage: 'MonticelloTonel-Tests'
		whitContent: [ :s | s << 
'Class {
	#name : #SomeObject,
	#superclass : #Object,
	#traitComposition : ''T1 + T1'',
	#classTraits : ''T1 classTrait + T2 classTrait'',	
	#category : #''MonticelloTonel-Tests''
}' ].

	self assert: classDefinition isClassDefinition! !

!TonelReaderTraitCompositionTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadTraitWithClassTraitCompositionDoesHaveTheCorrectTraitComposition
	| classDefinition |

	classDefinition := self 
		readDefinitionOfClass: 'SomeTrait' 
		fromPackage: 'MonticelloTonel-Tests'
		whitContent: [ :s | s << 
'Trait {
	#name : #SomeTrait,
	#traits : ''T1 + T1'',
	#classTraits : ''T1 classTrait + T2 classTrait'',	
	#category : #''MonticelloTonel-Tests''
}' ].

	self assert: classDefinition classTraitComposition equals: 'T1 classTrait + T2 classTrait'.	! !

!TonelReaderTraitCompositionTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadTraitWithClassTraitCompositionDoesHaveTraitComposition
	| classDefinition |

	classDefinition := self 
		readDefinitionOfClass: 'SomeTrait' 
		fromPackage: 'MonticelloTonel-Tests'
		whitContent: [ :s | s << 
'Trait {
	#name : #SomeTrait,
	#traits : ''T1 + T1'',
	#classTraits : ''T1 classTrait + T2 classTrait'',	
	#category : #''MonticelloTonel-Tests''
}' ].

	self assert: classDefinition hasClassTraitComposition.
! !

!TonelReaderTraitCompositionTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadClassWithClassTraitCompositionDoesHaveTraitComposition
	| classDefinition |

	classDefinition := self 
		readDefinitionOfClass: 'SomeObject' 
		fromPackage: 'MonticelloTonel-Tests'
		whitContent: [ :s | s << 
'Class {
	#name : #SomeObject,
	#superclass : #Object,
	#traits : ''T1 + T1'',
	#classTraits : ''T1 classTrait + T2 classTrait'',	
	#category : #''MonticelloTonel-Tests''
}' ].

	self assert: classDefinition hasClassTraitComposition.
! !

!TonelRepository commentStamp: 'EstebanLorenzano 9/11/2017 16:49'!
I'm a tonel monticello repository!
!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
filterFileNames: aCollection forVersionNamed: aString
	^ aCollection select: [:ea | (self versionNameFromFileName: ea) = aString]! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
packageDescriptionsFromReadableFileNames
    ^ ((self readableFileNames 
		collect: [ :each | self fileUtils directoryFromPath: each relativeTo: self directory ])
		select: [ :each | self fileUtils directoryExists: each ])
		collect: [ :each | self packageDescriptionFromPackageDirectory: each ]! !

!TonelRepository methodsFor: 'versions' stamp: ' 1/5/2022 20:56:19'!
versionInfoFromVersionNamed: aString
	^ self versionInfoForPackageDirectory: (self fileDirectoryOn: aString)! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
allFileNamesForVersionNamed: aString
	^ self 
		filterFileNames: self readableFileNames 
		forVersionNamed: aString! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
fileDirectoryOn: directoryPath
	^ self fileUtils 
		directoryFromPath: directoryPath 
		relativeTo: self directory! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
loadAllFileNames
	^ super loadAllFileNames 
		select: [ :each | 
			self fileUtils 
				filePathExists: each, '/package.st' 
				relativeTo: self directory ]! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
basicStoreVersion: aVersion
  TonelWriter 
	fileOut: aVersion 
	on: self directory! !

!TonelRepository methodsFor: '*Ring-Monticello' stamp: ''!
asRingEnvironmentWith: packageNames

	^ self asRingEnvironmentWith: packageNames cleaning: true! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
readableFileReferences
	^ self readableFileNames collect: [ :each | 
		self fileUtils 
			directoryFromPath: each 
			relativeTo: self directory ]! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
description
    ^ self class description, super description! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
readableFileNames
	| all cached new |

	all := self allFileNames. "in disk"
	all := all reject: [ :each | each beginsWith: '.' ].
	cached := self cachedFileNames. "in memory"
	new := all \ cached.
	^ (cached asArray, new) select: [:ea | self canReadFileNamed: ea]! !

!TonelRepository methodsFor: 'versions' stamp: ' 1/5/2022 20:56:19'!
versionNameFromFileName: aString
	| description |
	description := self packageDescriptionFromPackageDirectory: (self fileDirectoryOn: aString).
	^ description first , '-' , description second , '.' , description third printString! !

!TonelRepository methodsFor: 'versions' stamp: ' 1/5/2022 20:56:19'!
versionWithInfo: aVersionInfo ifAbsent: errorBlock
	(self allFileNamesForVersionNamed: aVersionInfo name)
		ifNotEmpty: [ :aCollection | ^ self versionFromFileNamed: aCollection first ].
	^ errorBlock value! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
versionFrom: aVersionReferenceString
    "until we no longer find .tree directories in the wild"

   	^ self readableFileReferences
		detect: [ :each | 
			(self fileUtils directoryExists: each)
			and: [ 
				each basename = aVersionReferenceString 
				or: [ (self versionInfoForPackageDirectory: each) name = aVersionReferenceString ] ] ]
		ifFound: [ :packageDirectory | 
			self loadVersionFromFileNamed: (self fileUtils directoryName: packageDirectory) ]
		ifNone: [ 
			nil ].! !

!TonelRepository methodsFor: '*Ring-Monticello' stamp: ''!
asRingEnvironmentWith: packageNames cleaning: aBoolen

	| aRG2Environment |
	aRG2Environment := RGEnvironment new.
	aRG2Environment announcer suspendAllWhile: [ 
		(packageNames) do: [ :pn | 
			| snap defs package version |
			package := aRG2Environment ensurePackageNamed: pn asSymbol.
			version := self versionWithInfo: (self versionInfoFromVersionNamed: pn).
			snap := version snapshot.

			defs := snap definitions.
			defs do: [ :each |			
				each ensureRingDefinitionIn: aRG2Environment package: package ]
			displayingProgress: 'snap'.] 
		 displayingProgress: 'version'.
		].		
			
	aBoolen ifTrue: [ 
		aRG2Environment clean ].
	
	aRG2Environment behaviorsDo: [ :beh |
		beh superclass == beh ifTrue: [ beh superclass: nil. ] ].			
	^ aRG2Environment! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
asRepositorySpecFor: aMetacelloMCProject
    ^ aMetacelloMCProject repositorySpec
        description: self description;
        type: 'tonel';
        yourself! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
packageDescriptionFromPackageDirectory: packageDirectory
    | filename |
    filename := self fileUtils directoryName: packageDirectory.
    ^ {filename. 'tonel'. 1. filename}! !

!TonelRepository methodsFor: 'versions' stamp: ' 1/5/2022 20:56:19'!
versionInfoForPackageDirectory: packageDirectory
	^ ((MCReader readerClassForFileNamed: (self fileUtils directoryName: packageDirectory))
		on: (self fileUtils parentDirectoryOf: packageDirectory)
		fileName: (self fileUtils directoryName: packageDirectory))
		loadVersionInfo;
		info! !

!TonelRepository methodsFor: 'actions' stamp: ' 1/5/2022 20:56:19'!
readStreamForFileNamed: aString do: aBlock
    ^ aBlock value: self directory! !

!TonelRepository methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
fileUtils
	^ TonelFileUtils current! !

!TonelRepository methodsFor: 'metacello support' stamp: ' 1/5/2022 20:56:19'!
goferVersionFrom: aVersionReference
	"Simillar hack than FileTree repositories."

	(self readableFileNames collect: [ :fileName | self fileDirectoryOn: fileName ])
		do: [ :packageDirectory |
			((self fileUtils directoryExists: packageDirectory )
			and: [(self versionInfoForPackageDirectory: packageDirectory) name = aVersionReference name])
				ifTrue: [ ^ self loadVersionFromFileNamed: (self fileUtils directoryName: packageDirectory) ] ].
	^nil! !

!TonelRepository class methodsFor: 'metacello support' stamp: ' 1/5/2022 20:56:19'!
createRepositoryFromSpec: aRepositorySpec on: aPlatform
	^ aPlatform createTonelRepository: aRepositorySpec! !

!TonelRepository class methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
description
    ^ 'tonel://'! !

!TonelRepository class methodsFor: 'metacello support' stamp: ' 1/5/2022 20:56:19'!
isFiletreeAlternateFormat: aRepositorySpec
	| location propRef |
	
	location := (aRepositorySpec description allButFirst: ('filetree://' size)) asFileReference.
	propRef := location / '.properties'.
	propRef exists ifFalse: [ ^ false ].
	
	^ propRef readStreamDo:[ :stream | 
		((STONJSON fromStream: stream) at: #format ifAbsent: []) = #tonel ]! !

!TonelRepository class methodsFor: 'metacello support' stamp: ' 1/5/2022 20:56:19'!
isAvailableFor: type
	^ type = 'tonel'! !

!TonelRepository class methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
urlSchemes
	^ #(tonel)! !

!TonelRepository class methodsFor: 'instance creation' stamp: ' 1/5/2022 20:56:19'!
basicFromUrl: anUrl
	"remove 'tonel://' and go"
	^ self new directory: (anUrl asString allButFirst: self description size) asFileReference! !

!TonelRepositoryTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testCanCreateTonelRepositoryFromUrl
	repository := MCRepository fromUrl: (self homeDirectoryUrl scheme: #tonel) asString.
	self assert: (repository isKindOf: TonelRepository).
	
	repository := MCRepository fromUrl: 'tonel://.'.
	self assert: (repository isKindOf: TonelRepository) ! !

!TonelRepositoryTest methodsFor: 'private factory' stamp: ' 1/5/2022 21:01:26'!
newMemoryFileSystem
	"This method assumes writer works. If it is broken (the tests should show it), this tests 
	 will break too."
	| mem |
	mem := FileSystem memory root.
	(TonelWriter on: mem) writeSnapshot: self mockSnapshot.
	^ mem! !

!TonelRepositoryTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testLoadAllFileNames
	| mem |
	
	mem := self newMemoryFileSystem.
	repository := TonelRepository new directory: mem.
	
	self 
		assert: repository allFileNames 
		equals: #('MonticelloMocks')
		! !

!TonelRepositoryTest methodsFor: 'running' stamp: ' 1/5/2022 21:01:26'!
setUp
	super setUp.
	repository := TonelRepository new directory: self directory
! !

!TonelSTONWriter commentStamp: 'EstebanLorenzano 9/11/2017 11:59'!
I'm a modified STON writer to make tonel metadata look as we want.

- it accept aliasses for classes, so I can say OrderedDictionary -> nil (then I do not have an extra information I do not want). Btw, tonel needs to use ordered dictionaries instead plain dictionaries because output needs to be deterministic, and we want to control the order of attributes we publish.
- if dictionary has just one element, it prints it in just one line, to have a more compact view.!
!TonelSTONWriter methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
aliases
	^ aliases! !

!TonelSTONWriter methodsFor: 'initialization' stamp: ' 1/5/2022 20:56:19'!
initialize
	super initialize.
	self prettyPrint: true.
	aliases := { OrderedDictionary -> nil } asDictionary! !

!TonelSTONWriter methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
encodeMap: pairs
	| first |
	first := true.
	writeStream nextPut: ${.
	pairs isEmpty
		ifTrue: [
			self prettyPrintSpace ]
		ifFalse: [
			self indentedDo: [
				pairs size = 1 
					ifTrue: [ self prettyPrintSpace ]
					ifFalse: [ self newlineIndent ].
				pairs keysAndValuesDo: [ :key :value |
					first 
						ifTrue: [ first := false ] 
						ifFalse: [ self mapElementSeparator ].
					self encodeKey: key value: value ] ].
				pairs size = 1 
					ifTrue: [ self prettyPrintSpace ]
					ifFalse: [ self newlineIndent ] ].
	writeStream nextPut: $}! !

!TonelSTONWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
isSimpleSymbol: symbol
	"Customize STON to only consider very clean symbols as literal, 
	for all others err on the safe side and quote them."
	
	symbol isEmpty ifTrue: [ ^ false ].
	('abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ' includes: symbol first)
		ifFalse: [ ^ false ].
	^ symbol allSatisfy: [ :each | 
		'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' includes: each ]! !

!TonelSTONWriter methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
writeObject: anObject do: block
	(jsonMode and: [ anObject class ~= STON listClass and: [ anObject class ~= STON mapClass ] ])
		ifTrue: [ self error: 'wrong object class for JSON mode' ].
	self with: anObject do: [
		(self stonNameFor: anObject class) ifNotNil: [ :stonName | 
			writeStream nextPutAll: stonName.
			self prettyPrintSpace ].
		block value ]! !

!TonelSTONWriter methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
stonNameFor: aClass
	^ self aliases 
		at: aClass 
		ifAbsent: [ aClass stonName ]! !

!TonelSTONWriter methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
aliases: aDictionary
	aliases := aDictionary! !

!TonelScanner commentStamp: '<historical>'!
I'm a generic scanner to help on parsing tonel files.!
!TonelScanner methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
removeFrom: aString enclosingStart: startChar end: endChar clean: cleanSymbol
	"cleanSymbol can be #left, #right and #both" 
	| nl result stop ch start end |
	
	nl := String cr.
	result := (aString trimBoth withLineEndings: nl) readStream.
	(result peek = startChar) 
		ifFalse: [ TonelParseError signal: 'I cannot remove enclosing start' ].
	result skip: 1.
	
	(#(both left) includes: cleanSymbol) 
		ifTrue: [ 
			stop := nl size.
			[ (stop > 0) and: [ self isSeparator: (ch := result peek) ] ]
			whileTrue: [ 
				(self isEnter: ch) ifTrue: [ stop := stop - 1 ].
				result skip: 1 ] ].
	start := result position.
	
	result setToEnd.
	result skip: -1.
	(result peek = endChar) 
		ifFalse: [ TonelParseError signal: 'I cannot remove enclosing end' ].
	result skip: -1.
	(#(both right) includes: cleanSymbol)
		ifTrue: [ 
			stop := nl size.
			[ (stop > 0) and: [ self isSeparator: (ch := result peek) ] ]
			whileTrue: [ 
				(self isEnter: ch) ifTrue: [ stop := stop - 1 ].
				result skip: -1. ] ].
	end := result position.
	
	^ result originalContents
		copyFrom: start + 1 
		to: end + 1! !

!TonelScanner methodsFor: 'initialization' stamp: ' 1/5/2022 20:56:19'!
initializeStream: aStream
	self initialize.
	stream := aStream! !

!TonelScanner methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
removeFrom: aString enclosingStart: startChar end: endChar
	^ self 
		removeFrom: aString 
		enclosingStart: startChar 
		end: endChar
		clean: #both! !

!TonelScanner methodsFor: 'testing' stamp: ' 1/5/2022 20:56:19'!
isEnter: aCharacter
	^ #(13 10) includes: aCharacter asciiValue! !

!TonelScanner methodsFor: 'scanning' stamp: ' 1/5/2022 20:56:19'!
scan 
	self subclassResponsibility! !

!TonelScanner methodsFor: 'testing' stamp: ' 1/5/2022 20:56:19'!
isSeparator: aCharacter
	^ aCharacter isSeparator! !

!TonelScanner class methodsFor: 'instance creation' stamp: ' 1/5/2022 20:56:19'!
new
	self error: 'Use #on:'! !

!TonelScanner class methodsFor: 'instance creation' stamp: ' 1/5/2022 20:56:19'!
on: aStream
	^ self basicNew 
		initializeStream: aStream;
		yourself! !

!TonelScannerTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testRemoveFromEnclosingStartEnd
	| scanner nl |
	
	nl := String cr.
	scanner := TonelScanner basicNew.
	self 
		assert: (scanner 
			removeFrom: '[ ^ self ]'  
			enclosingStart: $[ 
			end: $])
		equals: '^ self'.
		
	self 
		assert: (scanner 
			removeFrom: ('[ 
	^ self ]' withLineEndings: nl) 
			enclosingStart: $[ 
			end: $])
		equals: Character tab asString, '^ self'.
	
	self 
		assert: (scanner 
			removeFrom: ('[ 
	^ self
	]' withLineEndings: nl)
			enclosingStart: $[ 
			end: $])
		equals: Character tab asString, '^ self'.
		
	self 
		assert: (scanner 
			removeFrom: ('[ 

	^ self

]' withLineEndings: nl)
			enclosingStart: $[ 
			end: $])
		equals: (('
	^ self
') withLineEndings: nl)! !

!TonelShouldIgnore commentStamp: 'nice 11/12/2018 22:59'!
I'm a notification to say tonel writer that he should ignore a section. 
This typically happens on a MCClassTraitDefinition, because it will be managed on MCTraitDefinition.

(see TonelWriter>>typeOf:)!
!TonelSourceScanner commentStamp: 'nice 11/12/2018 23:01'!
I'm a scanner to get correct sources from method definitions in Tonel format.

Implementation details:
Method body is delineated by square brackets in Tonel format, thus I just have to detect enclosing square brackets [].
Since a method body can include nested blocks and ByteArray literals, I have to maintain a count of opened and closed brackets in order to correctly detect the end of method body.
But method body can also contain isolated brackets (which are not necessarily paired) in following patterns:
		- comments like "["
		- strings like ']'
		- array literals like #( [ )
		- literal characters like $] 
Therefore, I need to be aware of syntax for the four cases above, in order to correctly skip those potentially isolated brackets.!
!TonelSourceScanner methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
readNext
	prevChar := char.
	result nextPut: (char := stream next)
! !

!TonelSourceScanner methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
readUntilTermination: matchChar
	| terminationCount |
	"This is used to read sequences that start and finish with same character termination. 
	 tipically, this is for strings and comments, but who knows what comes in the future."
	terminationCount := 1.
	self readUntil: [ 
		char = matchChar ifTrue: [ terminationCount := terminationCount + 1 ].
		terminationCount even and: [ stream peek ~= matchChar ] ]! !

!TonelSourceScanner methodsFor: 'scanning' stamp: ' 1/5/2022 20:56:19'!
scanForBlock
	| match |
	match := false.
	char = $[ ifTrue: [ 
		count := count + 1.
		match := true ].
	char = $] ifTrue: [ 
		count := count - 1.
		match := true ].
	isFinished := count = 0.
	^match
! !

!TonelSourceScanner methodsFor: 'scanning' stamp: ' 1/5/2022 20:56:19'!
scanNextChunk
	self readNext.	
	self scanForBlock or: [
	self scanForComment or: [
	self scanForString or: [
	self scanForLiteralCharacter or: [
	self scanForLiteralArray ]]]]! !

!TonelSourceScanner methodsFor: 'scanning' stamp: ' 1/5/2022 20:56:19'!
scanForLiteralArray
	| literalCount |
	self isStartingLiteralArray ifFalse: [ ^ false ]. 
	literalCount := 1.
	self readUntil: [
		self scanForLiteralCharacter
			or: [ self scanForString
			or: [ self scanForComment
			or: [ char = $( ifTrue: [ literalCount := literalCount + 1 ].
					char = $) ifTrue: [ literalCount := literalCount - 1 ]]]].
		literalCount = 0 ].
	^true! !

!TonelSourceScanner methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
readUntil: aBlock
	[ stream atEnd ]
	whileFalse: [
		self readNext.
		aBlock value ifTrue: [ ^ self ] ]! !

!TonelSourceScanner methodsFor: 'scanning' stamp: ' 1/5/2022 20:56:19'!
scan
	self prepareToScan.	
	stream peek = $[ ifFalse: [ TonelParseError signal: 'Can''t parse method body' ].
	[ stream atEnd or: [ isFinished ] ]
	whileFalse: [ self scanNextChunk ].
	isFinished ifTrue: [ 
		"clean up to return"
		^ self 
			removeFrom: result contents withInternalLineEndings
			enclosingStart: $[ 
			end: $]
			clean: #right ].

	TonelParseError signal: 'Can''t parse method body'! !

!TonelSourceScanner methodsFor: 'scanning' stamp: ' 1/5/2022 20:56:19'!
scanForLiteralCharacter
	self isStartingLiteralCharacter ifFalse: [ ^ false ]. 
	self readNext.
	^true! !

!TonelSourceScanner methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
prepareToScan
	result := String new writeStream.
	isFinished := false.
	char := prevChar := nil.
	count := 0
	! !

!TonelSourceScanner methodsFor: 'testing' stamp: ' 1/5/2022 20:56:19'!
isStartingComment
	"Comment start with a double quote in Smalltalk syntax"
	^ char = $"! !

!TonelSourceScanner methodsFor: 'scanning' stamp: ' 1/5/2022 20:56:19'!
scanForComment
	self isStartingComment ifFalse: [ ^ false ]. 
	self readUntilTermination: $".
	^true! !

!TonelSourceScanner methodsFor: 'scanning' stamp: ' 1/5/2022 20:56:19'!
scanForString
	self isStartingString ifFalse: [ ^ false ].
	self readUntilTermination: $'.
	^true! !

!TonelSourceScanner methodsFor: 'testing' stamp: ' 1/5/2022 20:56:19'!
isStartingLiteralCharacter
	"A literal Character start with a dollar sign in Smalltalk syntax"  
	^ char = $$! !

!TonelSourceScanner methodsFor: 'testing' stamp: ' 1/5/2022 20:56:19'!
isStartingLiteralArray
	"Literal array starts with a sharp sign followed by parenthesis in Smalltalk syntax"
	^ char = $( and: [ prevChar = $# ]! !

!TonelSourceScanner methodsFor: 'testing' stamp: ' 1/5/2022 20:56:19'!
isStartingString
	"String start with single quote in Smalltalk syntax"
	^ char = $'! !

!TonelSourceScannerTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testScanForComment
	| scanner |
	
	scanner := TonelSourceScanner on: '""' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForComment.
	self 
		assert: ((scanner instVarNamed: 'result') contents) 
		equals: '""'.	

	scanner := TonelSourceScanner on: '"simple comment"' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForComment.
	self 
		assert: ((scanner instVarNamed: 'result') contents)
		equals: '"simple comment"'.	

	scanner := TonelSourceScanner on: '"multiline 
comment"' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForComment.
	self 
		assert: ((scanner instVarNamed: 'result') contents)
		equals: '"multiline 
comment"'.	

	scanner := TonelSourceScanner on: '"simple comment with "" colons inside"' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForComment.
	self 
		assert: ((scanner instVarNamed: 'result') contents)
		equals: '"simple comment with "" colons inside"'.	

	scanner := TonelSourceScanner on: '"simple comment with colons at the end"""' readStream.
	scanner prepareToScan.
	scanner readNext.
	scanner scanForComment.
	self 
		assert: ((scanner instVarNamed: 'result') contents)
		equals: '"simple comment with colons at the end"""'! !

!TonelSourceScannerTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testScanForString
	| scanner |

	scanner := TonelSourceScanner on: '''-.*$''' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForString.
	self 
		assert: ((scanner instVarNamed: 'result') contents)
		equals: '''-.*$'''.	
	
	scanner := TonelSourceScanner on: '''simple comment ''''with'''' colons enclosing word''' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForString.
	self 
		assert: ((scanner instVarNamed: 'result') contents)
		equals: '''simple comment ''''with'''' colons enclosing word'''.	
	
	scanner := TonelSourceScanner on: '''''' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForString.
	self 
		assert: ((scanner instVarNamed: 'result') contents) 
		equals: ''''''.	

	scanner := TonelSourceScanner on: '''simple string''' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForString.
	self 
		assert: ((scanner instVarNamed: 'result') contents)
		equals: '''simple string'''.	

	scanner := TonelSourceScanner on: '''multiline 
string''' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForString.
	self 
		assert: ((scanner instVarNamed: 'result') contents)
		equals: '''multiline 
string'''.	

	scanner := TonelSourceScanner on: '''simple string with '''' colons inside''' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForString.
	self 
		assert: ((scanner instVarNamed: 'result') contents)
		equals: '''simple string with '''' colons inside'''.	

	scanner := TonelSourceScanner on: '''simple string with colons at the end''''' readStream.
	scanner prepareToScan.
	scanner readNext. 
	scanner scanForString.
	self 
		assert: ((scanner instVarNamed: 'result') contents)
		equals: '''simple string with colons at the end'''''! !

!TonelSourceScannerTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testScanMethodWithLotsOfSpecials
	| scanner |
	
	scanner := TonelSourceScanner on: '[
	"Do not allow whitespace between # and the literal."

	"Do not allow number literals after the #"

	self step.
	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 multiple #."
	currentCharacter = $#
		ifTrue: [ ^ self scanLiteral ].
	^ self scanError: ''Expecting a literal type''
]' readStream.
	self assert: scanner scan equals: '
	"Do not allow whitespace between # and the literal."

	"Do not allow number literals after the #"

	self step.
	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 multiple #."
	currentCharacter = $#
		ifTrue: [ ^ self scanLiteral ].
	^ self scanError: ''Expecting a literal type'''! !

!TonelSourceScannerTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testScanMethodWithTerminatingBrackets
	| scanner |
	
	scanner := TonelSourceScanner on: '[[''-.*$'']]' readStream.
	self 
		assert: scanner scan 
		equals: '[''-.*$'']'! !

!TonelSourceScannerTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testScanMethodWithParserErrors
	| scanner |
	
	scanner := TonelSourceScanner on: '[#(#(''self foo. + 3'' 11) #(''#('' 3) #(''self 0'' 6) #(''self asdf;;asfd'' 11))]' readStream.
	self 
		assert: scanner scan 
		equals: '#(#(''self foo. + 3'' 11) #(''#('' 3) #(''self 0'' 6) #(''self asdf;;asfd'' 11))'! !

!TonelSourceScannerTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testScan
	| scanner |

	scanner := TonelSourceScanner on: '[^'''']' readStream.
	self assert: scanner scan equals: '^'''''.
	
	scanner := TonelSourceScanner on: '[
	self 
		at: Object1 put: ''one string'';
		at: Object2 put: ''other string'';
		yourself
]' readStream.
	self 
		assert: scanner scan 
		equals: '
	self 
		at: Object1 put: ''one string'';
		at: Object2 put: ''other string'';
		yourself'! !

!TonelSourceScannerTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testScanForLiteralArray
	| scanner |
	
	scanner := TonelSourceScanner on: '#()' readStream.
	scanner prepareToScan.
	scanner readNext; readNext. 
	scanner scanForLiteralArray.
	self 
		assert: ((scanner instVarNamed: 'result') contents) 
		equals: '#()'.	

	scanner := TonelSourceScanner on: '#(a b c)' readStream.
	scanner prepareToScan.
	scanner readNext; readNext. 
	scanner scanForLiteralArray.
	self 
		assert: ((scanner instVarNamed: 'result') contents) 
		equals: '#(a b c)'.	

	scanner := TonelSourceScanner on: '#((a b) c)' readStream.
	scanner prepareToScan.
	scanner readNext; readNext. 
	scanner scanForLiteralArray.
	self 
		assert: ((scanner instVarNamed: 'result') contents) 
		equals: '#((a b) c)'.	

	scanner := TonelSourceScanner on: '#((a (b)) c)' readStream.
	scanner prepareToScan.
	scanner readNext; readNext. 
	scanner scanForLiteralArray.
	self 
		assert: ((scanner instVarNamed: 'result') contents) 
		equals: '#((a (b)) c)'.	

	scanner := TonelSourceScanner on: '#(a (b c))' readStream.
	scanner prepareToScan.
	scanner readNext; readNext. 
	scanner scanForLiteralArray.
	self 
		assert: ((scanner instVarNamed: 'result') contents) 
		equals: '#(a (b c))'! !

!TonelWriteError commentStamp: 'PeterUhnak 10/7/2018 16:50'!
I'm a writing error.
I happen whenever an unrecoverable problem was encountered during writing of tonel.!
!TonelWriter commentStamp: 'CyrilFerlicot 10/23/2018 15:52'!
I'm a monticello writer for tonel format, writing
 - a package per directory
 - a class per file
 - a set of extensions to a single class per file (for example, all extensions of a package to String will be in a single file)

I'm created on a file reference to a directory where the package will be written.

[[[
TonelWriter on: ('someDirectory' asFileReference ensureCreateDirectory)
]]]

My main methods are
- ==#writeVersion:== that receives as argument a monticello version to write, from where I'll extract the corresponding monticello snapshot.
- ==#writeSnapshot:== that receives as argument a monticello snapshot to write, from where I'll write all the contained definitions.

I also provide a way to easily export a single class in the Tonel format to a stream. 

[[[
	TonelWriter sourceCodeOf: self.
	
	(FileSystem memory / 'test.st') writeStreamDo: [ :s | TonelWriter exportClass: self on: s ]; yourself.
]]]

!! Implementation details

Notice that while writing, if the written package/snapshot already exists in the directory I'll overwrite it (i.e., remove it and recreate it).!
!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
newLine
	 ^ OSPlatform current lineEnding! !

!TonelWriter methodsFor: 'private definitions' stamp: ' 1/5/2022 20:56:19'!
typeTraitDefinitionOf: aClassDefinition
	| definition |
	
	definition := OrderedDictionary new 
		at: #name put: aClassDefinition className; 
		yourself.

	aClassDefinition variables isEmptyOrNil ifFalse: [ 
		(aClassDefinition variables select: #isInstanceVariable thenCollect: #name)
			ifNotEmpty: [ :vars | definition at: #instVars put: vars asArray ].
		(aClassDefinition variables select: #isClassInstanceVariable thenCollect: #name)
			ifNotEmpty: [ :vars | definition at: #classInstVars put: vars asArray ] ].

	aClassDefinition hasTraitComposition ifTrue: [ 
		definition		
			at: #traits 
			put: aClassDefinition traitCompositionString ].
		
	aClassDefinition hasClassTraitComposition ifTrue: [ 
		definition		
			at: #classTraits 
			put: aClassDefinition classTraitCompositionString ].
	
	definition at: #category put: aClassDefinition category.
		
	^ self toSTON: definition! !

!TonelWriter methodsFor: 'private writing' stamp: ' 1/5/2022 20:56:19'!
writeClassDefinition: aClassDefinition on: aStream
	| nl |
	nl := self newLine.
	
	aClassDefinition hasComment 
		ifTrue: [ 
			aStream 
				<< '"' << nl
				<< (self commentOf: aClassDefinition) << nl
				<< '"' << nl ].
	aStream
		<< (self typeOf: aClassDefinition) 
		<< ' ' << (self typeDefinitionOf: aClassDefinition ) << nl! !

!TonelWriter methodsFor: 'private definitions' stamp: ' 1/5/2022 20:56:19'!
commentOf: aClassDefinition
	^ (aClassDefinition comment 
		copyReplaceAll: '"' 
		with: '""')
		withLineEndings: self newLine! !

!TonelWriter methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
writeClass: aClassDefinition on: aStream
	[ self writeClassDefinition: aClassDefinition on: aStream.
	self writeClassSideMethodDefinitions: aClassDefinition on: aStream.
	self writeInstanceSideMethodDefinitions: aClassDefinition on: aStream ]
		on: TonelShouldIgnore
		do: [ :e | self logCr: 'ignoring: ' , aClassDefinition asString ]! !

!TonelWriter methodsFor: 'private writing' stamp: ' 1/5/2022 20:56:19'!
writeInstanceSideMethodDefinitions: aClassDefinition on: aStream
	((snapshot definitions 
		select: [ :each | 
			each isMethodDefinition 
			and: [ each className = aClassDefinition className
			and: [ each classIsMeta not ] ] ])
		sorted: [ :a :b | a selector < b selector ])
		do: [ :each | 
			self writeMethodDefinition: each parent: aClassDefinition on: aStream ]

	
	! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
skipSeparators: aStream
	[ aStream peek isSeparator ]
	whileTrue: [ aStream skip: 1 ]. 
! !

!TonelWriter methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
directoryReference: aFileReference
	directoryReference := aFileReference! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
classNameFor: aMethodDefinition parent: aClassDefinition
	aClassDefinition ifNil: [ ^ aMethodDefinition fullClassName ].
	^ aMethodDefinition classIsMeta
		ifFalse: [ aMethodDefinition className ]
		ifTrue: [ 
			aClassDefinition isTraitDefinition
				ifFalse: [aMethodDefinition className, ' class']
				ifTrue: [aMethodDefinition className, ' classSide'] ]! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
createDefaultOrganizationFromDefinition: aMethodDefinition

	^ MCOrganizationDefinition categories: (self packageNameForMethodDefinition: aMethodDefinition)! !

!TonelWriter methodsFor: 'private definitions' stamp: ' 1/5/2022 20:56:19'!
typeDefinitionOf: aClassDefinition
	(self isTrait: aClassDefinition) 
		ifTrue: [ ^ self typeTraitDefinitionOf: aClassDefinition ].
	^ self typeClassDefinitionOf: aClassDefinition! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
splitMethodSource: aMethodDefinition into: aBlock
	| keywords source declaration |
	
	keywords := aMethodDefinition selector keywords.
	source := aMethodDefinition source readStream.
	"Skip spaces"
	(source peek isSeparator) ifTrue: [ self skipSeparators: source ].
	"Skip comments"
	(source peek = $") ifTrue: [ self skipComment: source ]. 
	"Parse declaration"
	declaration := String new writeStream.
	[ (self selectorIsComplete: keywords in: declaration originalContents) not 
		or: [ ':+-/\*~<>=@,%|&?!!' includes: declaration contents trimRight last ] ]
	whileTrue: [ 
		"stop infinite loop if no match was found"
		source atEnd ifTrue: [ TonelWriteError signal: 'Cannot find selector in source for ', aMethodDefinition asString ].
		"get separators"
		[ source atEnd not and: [ source peek isSeparator ] ]
			whileTrue: [ declaration nextPut: source next ].
		"take next word until we find a separator or a dot"
		[ source atEnd not and: [ source peek ~= $. and: [ source peek isSeparator not ] ] ]
			whileTrue: [ declaration nextPut: source next ] ].
	aBlock 
		value: (declaration contents trimLeft withLineEndings: self newLine)
		value: (source upToEnd withLineEndings: self newLine)! !

!TonelWriter methodsFor: 'private definitions' stamp: ' 1/5/2022 20:56:19'!
typeClassDefinitionOf: aClassDefinition
	| definition |
	
	definition := OrderedDictionary new 
		at: #name put: aClassDefinition className; 
		at: #superclass put: aClassDefinition superclassName;
		yourself.

	aClassDefinition type = #normal ifFalse: [ 
		definition at: #type put: aClassDefinition type ].
	
	aClassDefinition hasTraitComposition ifTrue: [ 
		definition at: #traits put: aClassDefinition traitCompositionString ].
	
	aClassDefinition hasClassTraitComposition ifTrue: [ 
		definition at: #classTraits put: aClassDefinition classTraitCompositionString ].
	
	(aClassDefinition variables select: #isInstanceVariable thenCollect: #name)
		ifNotEmpty: [ :vars | definition at: #instVars put: vars asArray ].

	(aClassDefinition variables select: #isClassVariable thenCollect: #name)
		ifNotEmpty: [ :vars | definition at: #classVars put: vars asArray ].
		
	(aClassDefinition variables select: #isPoolImport thenCollect: #name)
		ifNotEmpty: [ :vars | definition at: #pools put: vars asArray ].
		
	(aClassDefinition variables select: #isClassInstanceVariable thenCollect: #name)
		ifNotEmpty: [ :vars | definition at: #classInstVars put: vars asArray ].

	definition 		
		at: #category put: aClassDefinition category.
	
	^ self toSTON: definition! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
skipComment: aStream
	"I assume I'm on top of the begining of a comment"
	aStream skip: 1.
	[ aStream atEnd not 
		and: [ aStream next ~= $" or: [ aStream peek = $" ] ] ]
	whileTrue.	! !

!TonelWriter methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
writeSnapshot: aSnapshot
	snapshot := aSnapshot.
	
	"ensure package dirs exists. 
	 It has to be just one but well..."
	self writePackage: (snapshot definitions 
		detect: #isOrganizationDefinition
		ifNone: [ self createDefaultOrganizationFrom: snapshot definitions ]).
	"now export classes"
	(snapshot definitions 
		select: #isClassDefinition)
		do: [ :each | self writeClass: each ].
	"... and method extensions"
	self writeMethodExtensions! !

!TonelWriter methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
fileUtils
	^ TonelFileUtils current! !

!TonelWriter methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
packageDir
	^ packageDir 
		ifNotNil: [ self fileUtils directoryFromPath: packageDir relativeTo: self directoryReference ]
		ifNil: [ self directoryReference  ]! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
selectorIsComplete: keywords in: aString
	keywords inject: 1 into: [ :start :key | | startOfKey | 
		startOfKey := aString 
			findString: key 
			startingAt: start 
			caseSensitive: true.
		startOfKey = 0 ifTrue: [ ^ false ].
		startOfKey + key size ].
	^ true! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
typeOf: aClassDefinition
	(self isClass: aClassDefinition) ifTrue: [ ^ self class classLabel ].
	(self isTrait: aClassDefinition) ifTrue: [ ^ self class traitLabel ].

	TonelShouldIgnore signal! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
obtainPackageDir: aDefinition
	"I'm assuming first category is actually the package"
	
	^ aDefinition categories first! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
createDefaultOrganizationFrom: aCollection
	"answers a default organisation for the cases where there are none"

	"simplest case, I answer the clas definition"
	snapshot definitions 
		detect: #isClassDefinition
		ifFound: [ :each | ^ MCOrganizationDefinition categories: { each category } ].
	
	^ self createDefaultOrganizationFromDefinition: (snapshot definitions
		detect: #isMethodDefinition
		ifNone: [ self error: 'cannot determine package name from empty snapshot' ])
! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
packageNameForMethodDefinition: aMethodDefinition
	| category |
	
	self assert: aMethodDefinition category first = $*.
	category := aMethodDefinition category allButFirst.
	^(MCWorkingCopy allManagers
		detect: ((category allSatisfy: #isLowercase)
			ifTrue: [[: wc| category beginsWith: wc packageName asLowercase]]
			ifFalse: [[: wc| category beginsWith: wc packageName]])) packageName! !

!TonelWriter methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
exportClass: aClass on: aStream
	snapshot := MCSnapshot
		fromDefinitions:
			{aClass asClassDefinition} , (aClass localMethods collect: [ :each | each asRingDefinition asMCMethodDefinition ])
				, (aClass classSide localMethods collect: [ :each | each asRingDefinition asMCMethodDefinition ]).
	self writeClass: aClass asClassDefinition on: aStream.
	^ aStream! !

!TonelWriter methodsFor: 'private definitions' stamp: ' 1/5/2022 20:56:19'!
methodDefinitionOf: aMethodDefinition
	^ self toSTON: (OrderedDictionary new 
		at: #category put: aMethodDefinition category; 
		yourself)	
	! !

!TonelWriter methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
writeClass: aClassDefinition
	[ self fileUtils writeStreamFor: (self fileNameFor: aClassDefinition) in: self packageDir do: [ :aStream | self writeClass: aClassDefinition on: aStream ] ]
		on: TonelShouldIgnore
		do: [ :e | self traceCr: 'ignoring: ' , aClassDefinition asString ]! !

!TonelWriter methodsFor: 'private writing' stamp: ' 1/5/2022 20:56:19'!
writeClassSideMethodDefinitions: aClassDefinition on: aStream
	((snapshot definitions 
		select: [ :each | 
			each isMethodDefinition 
			and: [ each className = aClassDefinition className
			and: [ each classIsMeta ] ] ])
		sorted: [ :a :b | a selector < b selector ])
		do: [ :each | 
			self writeMethodDefinition: each parent: aClassDefinition on: aStream ]! !

!TonelWriter methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
writeExtensionMethods: methods className: className
	| nl |
	nl := self newLine.
	self fileUtils 
		writeStreamFor: (className, '.extension.st') 
		in: self packageDir 
		do: [ :s |
			s << 'Extension ' << (self toSTON: { #name -> className } asDictionary) << nl.
			(methods sorted: [ :a :b | a selector < b selector ])
				do: [ :each | self writeMethodDefinition: each on: s ] ]! !

!TonelWriter methodsFor: 'private testing' stamp: ' 1/5/2022 20:56:19'!
isClass: aClassDefinition
	^ aClassDefinition class = MCClassDefinition! !

!TonelWriter methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
writePackage: aDefinition

	packageDir := self obtainPackageDir: aDefinition.
	self flag: #todo. "this is lame... removing and rewriting full package needs to be rethink :)"
	(self fileUtils directoryExists: self packageDir) ifTrue: [ 
		self fileUtils deleteAll: self packageDir ].  
	self fileUtils ensureDirectoryExists: self packageDir.
	self fileUtils 
		writeStreamFor: 'package.st' 
		in: self packageDir 
		do: [ :s | 
			s 
				<< 'Package ' 
				<< (self toSTON: { #name ->  packageDir asSymbol } asDictionary) 
				<< self newLine ]! !

!TonelWriter methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
writeVersion: aVersion
	self writeSnapshot: aVersion snapshot! !

!TonelWriter methodsFor: 'private writing' stamp: ' 1/5/2022 20:56:19'!
writeMethodDefinition: aMethodDefinition on: aStream
	^ self 
		writeMethodDefinition: aMethodDefinition 
		parent: nil 
		on: aStream! !

!TonelWriter methodsFor: 'private testing' stamp: ' 1/5/2022 20:56:19'!
isTrait: aClassDefinition
	^ aClassDefinition class = MCTraitDefinition ! !

!TonelWriter methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
snapshot: anObject
	snapshot := anObject! !

!TonelWriter methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
directoryReference
	^ directoryReference! !

!TonelWriter methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
writeMethodExtensions
	| classesAndMethods |
	classesAndMethods := Dictionary new.
	snapshot definitions 
		select: [ :each | each isMethodDefinition and: [ each isExtensionMethod ] ]
		thenDo: [ :each | 
			(classesAndMethods 
				at: each className
				ifAbsentPut: [ Set new ])
				add: each ].
	classesAndMethods keysAndValuesDo: [ :className :methods | 
		self 
			writeExtensionMethods: methods 
			className: className ]
		
	! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
toSTON: anObject
	^ String streamContents: [ :outStream | 
		(TonelSTONWriter on: outStream) 
			newLine: self newLine;
			nextPut: anObject ]! !

!TonelWriter methodsFor: 'private writing' stamp: ' 1/5/2022 20:56:19'!
writeMethodDefinition: aMethodDefinition parent: aClassDefinition on: aStream
	| nl |
	
	nl := self newLine.
	self 
		splitMethodSource: aMethodDefinition 
		into: [ :methodDeclaration :methodBody | | fullClassName |
			fullClassName := self classNameFor: aMethodDefinition parent: aClassDefinition.
			aStream 
				<< nl 
				<< (self methodDefinitionOf: aMethodDefinition) << nl 
				<< fullClassName << ' >> ' << methodDeclaration 
				<< ' [' << methodBody << nl << ']' << nl ]! !

!TonelWriter methodsFor: 'private' stamp: ' 1/5/2022 20:56:19'!
fileNameFor: aClassDefinition
	^ String streamContents: [ :aStream | 
		aStream 
			<< aClassDefinition className
			<< '.' << (self typeOf: aClassDefinition) asLowercase
			<< '.st'  ]! !

!TonelWriter class methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
traitLabel
	^ 'Trait'! !

!TonelWriter class methodsFor: 'instance creation' stamp: ' 1/5/2022 20:56:19'!
on: directoryReference
	^ self new
		directoryReference: directoryReference;
		yourself! !

!TonelWriter class methodsFor: 'writing - class' stamp: ' 1/5/2022 20:56:19'!
sourceCodeOf: aClass
	"I take as a parameter a class and I return it's tonel export as a String."
	
	^ String streamContents: [ :aStream | self new exportClass: aClass on: aStream ]! !

!TonelWriter class methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
readerClass
	^ TonelReader! !

!TonelWriter class methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
classLabel
	^ 'Class'! !

!TonelWriter class methodsFor: 'accessing' stamp: ' 1/5/2022 20:56:19'!
extensionLabel
	^ 'Extension'! !

!TonelWriter class methodsFor: 'writing - class' stamp: ' 1/5/2022 20:56:19'!
exportClass: aClass on: aStream
	"I take a class and a stream as parameter and export the class in Tonel format into the stream."
	
	^ self new exportClass: aClass on: aStream! !

!TonelWriter class methodsFor: 'writing' stamp: ' 1/5/2022 20:56:19'!
fileOut: aVersion on: aStream
	(self on: aStream) writeVersion: aVersion
	
! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testSplitMethodSourceInto
	| writer declaration source definition newLine tab space |
	
	newLine := OSPlatform current lineEnding.
	tab := Character tab asString.
	space := Character space asString.
	writer := self actualClass new.

	"simplest split"
	definition := MCMethodDefinition
		className: #SomeClass 
		selector: #name 
		category: 'accessing' 
		timeStamp: nil
		source: 'name
	^ self'.		
	writer splitMethodSource: definition into: [ :d :s | declaration := d. source := s ].
	
	self assert: declaration equals: 'name'.
	self assert: source equals: newLine, tab, '^ self'.
	
	"test space at the end of method declaration (it needs to be kept)"
	definition := MCMethodDefinition
		className: #SomeClass
		selector: #name:
		category: 'accessing'
		timeStamp: nil
		source: 'name: aString 
	name := aString'.
	writer splitMethodSource: definition into: [ :d :s | declaration := d. source := s ].
	self assert: declaration equals: 'name: aString'.
	self assert: source equals: space, newLine, tab, 'name := aString'.

	"test multiline declaration"
	definition := MCMethodDefinition
		className: #SomeClass
		selector: #method:with:several:lines:
		category: 'accessing'
		timeStamp: nil
		source: 'method: var1
	with: var2
	several: var3
	lines: var4
	
	^ var1 + var2 + var3 + var4'.
	writer splitMethodSource: definition into: [ :d :s | declaration := d. source := s ].
	self assert: declaration equals: ('method: var1
	with: var2
	several: var3
	lines: var4' withLineEndings: OSPlatform current lineEnding).
	self assert: source equals: (newLine, tab, newLine, tab, '^ var1 + var2 + var3 + var4' withLineEndings: newLine).

	"test comment before declaration (it may happen, if someone copied from diffmorph)"
	definition := MCMethodDefinition
		className: #SomeClass
		selector: #name:
		category: 'accessing'
		timeStamp: nil
		source: '
"protocol: accessing"
name: aString 
	name := aString'.
	writer splitMethodSource: definition into: [ :d :s | declaration := d. source := s ].
	self assert: declaration equals: 'name: aString'.
	self assert: source equals: space, newLine, tab, 'name := aString'.

	"test source right after declaration (no enter between selector and source)"
	definition := MCMethodDefinition
		className: #SomeClass
		selector: #name:
		category: 'accessing'
		timeStamp: nil
		source: 'name: aString name := aString'.
	writer splitMethodSource: definition into: [ :d :s | declaration := d. source := s ].
	self assert: declaration equals: 'name: aString'.
	self assert: source equals: ' name := aString'.
	
	"test method name containin name of keywords in variables"
	definition := MCMethodDefinition
		className: #SomeClass
		selector: #a:b:c:
		category: 'accessing'
		timeStamp: nil
		source: 'a: b b: c c: d ^ 42'.
	writer splitMethodSource: definition into: [ :d :s | declaration := d. source := s ].
	self assert: declaration equals: 'a: b b: c c: d'.
	self assert: source equals: ' ^ 42'.! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteBinaryInstanceMethodDefinitionWithDotNextToArgument
	| writer def stream |
	
	writer := self actualClass new.

	stream := String new writeStream.
	def := MCMethodDefinition 
		className: #Object
		classIsMeta: false
		selector: #+
		category: 'accessing' 
		timeStamp: nil
		source: '+ a.
	^ 42'.
	writer writeMethodDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('
{ #category : #accessing }
Object >> + a [.
	^ 42
]
' withLineEndings: OSPlatform current lineEnding).! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testSplitMethodSourceIntoCorrupted
	| writer definition |
	writer := TonelWriter new.

	"Sometimes data loaded from old MCZs are corrupted and the selector doesn't match the source, resulting in infinite search loop."
	definition := MCMethodDefinition
		className: #SomeClass
		selector: #nameØY
		category: 'accessing'
		timeStamp: nil
		source:
			'named: aString
	^ self named: aString environment: self defaultEnvironment'.
	self
		should: [ writer splitMethodSource: definition into: [ :d :s |  ] ]
		raise: TonelWriteError! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteTraitDefinitionWithTraitCompositionFromTrait
	| writer def stream |
	
	writer := self actualClass new.

	stream := String new writeStream.
	def := self classWithTraits asClassDefinition.
	
	writer writeClassDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: (
'Class {
	#name : #SomeObject,
	#superclass : #Object,
	#traits : ''T1 + T2'',
	#classTraits : ''T1 classTrait + T2 classTrait'',
	#category : #''MonticelloTonel-Tests''
}
' withLineEndings: OSPlatform current lineEnding).
! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteKeywordInstanceMethodDefinitionWithDotNextToArgument
	| writer def stream |
	
	writer := self actualClass new.

	stream := String new writeStream.
	def := MCMethodDefinition 
		className: #Object
		classIsMeta: false
		selector: #min:max
		category: 'accessing' 
		timeStamp: nil
		source: 'min: a max: b.
	^ 42'.
	writer writeMethodDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('
{ #category : #accessing }
Object >> min: a max: b [.
	^ 42
]
' withLineEndings: OSPlatform current lineEnding).! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteSnapshot
	| writer memoryFileReference |
	
	memoryFileReference := FileSystem memory root.
	writer := self actualClass on: memoryFileReference.
	writer writeSnapshot: self mockSnapshot.
	
	self checkFilesStructureIn: memoryFileReference! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testSourceCodeOf
	self
		assert: (self actualClass sourceCodeOf: TonelMock)
		equals:
			('"
Description
--------------------

I am a simple Mock for Tonel export test
"
Class {
	#name : #TonelMock,
	#superclass : #Object,
	#category : #''MonticelloTonel-Tests''
}

{ #category : #accessing }
TonelMock class >> classMethod [
	^ 8
]

{ #category : #accessing }
TonelMock >> instanceMethod [
	^ true
]
'
				withLineEndings: OSPlatform current lineEnding)! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteMethodDefinitionOn
	| writer def stream |
	
	writer := self actualClass new.

	stream := String new writeStream.
	def := MCMethodDefinition 
		className: #Object
		classIsMeta: false
		selector: #selector
		category: 'accessing' 
		timeStamp: nil
		source: 'selector
	^ 42'.
	writer writeMethodDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('
{ #category : #accessing }
Object >> selector [
	^ 42
]
' withLineEndings: OSPlatform current lineEnding).

	stream := String new writeStream.
	def := MCMethodDefinition 
		className: #Object
		classIsMeta: true
		selector: #selector
		category: 'accessing' 
		timeStamp: nil
		source: 'selector
	^ 42'.
	writer writeMethodDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('
{ #category : #accessing }
Object class >> selector [
	^ 42
]
' withLineEndings: OSPlatform current lineEnding).


	stream := String new writeStream.
	def := MCMethodDefinition 
		className: #Object
		classIsMeta: false
		selector: #=
		category: 'comparing' 
		timeStamp: nil
		source: '= anObject
	^ self == anObject'.
	writer writeMethodDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('
{ #category : #comparing }
Object >> = anObject [
	^ self == anObject
]
' withLineEndings: OSPlatform current lineEnding).! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
checkFilesStructureIn: aFileReference

	| nl |
	
	self assert: (aFileReference / 'MonticelloMocks') exists.
	self 
		assert: ((aFileReference / 'MonticelloMocks') entries collect: #basename) 
		equals: #(
			'MCMockASubclass.class.st' 
			'MCMockClassA.class.st' 
			'MCMockClassB.class.st' 
			'MCMockClassD.class.st' 
			'MCMockClassE.class.st' 
			'MCMockClassF.class.st' 
			'MCMockClassG.class.st' 
			'MCMockClassH.class.st' 
			'MCMockClassI.class.st' 
			'MCSnapshotTest.extension.st'
			'package.st').
	
	nl := OSPlatform current lineEnding.
	self 
		assert: (aFileReference / 'MonticelloMocks' / 'MCMockClassA.class.st') contents
		equals: (self expectedMCMockClassAClassSt withLineEndings: nl).
	self 
		assert: (aFileReference / 'MonticelloMocks' / 'MCMockASubclass.class.st') contents
		equals: (self expectedMCMockASubclassClassSt withLineEndings: nl).
	self 
		assert: (aFileReference / 'MonticelloMocks' / 'MCSnapshotTest.extension.st') contents
		equals: (self expectedMCSnapshotTestExtensionSt withLineEndings: nl)! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteSnapshotWithoutOrganization
	"test if the exported code has correct structure even if the Monticello snapshot does not have
	a proper organization definition so the structure must be taken from the category names. 
	See TonelWriter>>#createDefaultOrganizationFrom:"

	| aSnapshot memoryFileReference writer |
	
	aSnapshot := self mockSnapshot copy.
	(aSnapshot definitions select: #isOrganizationDefinition) do: [ :each | 
		aSnapshot definitions remove: each ].
	
	memoryFileReference := FileSystem memory root.
	writer := self actualClass on: memoryFileReference.
	writer writeSnapshot: self mockSnapshot.
	
	self checkFilesStructureIn: memoryFileReference
	
	
! !

!TonelWriterTest methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
expectedMCMockASubclassClassSt
	^ 'Class {
	#name : #MCMockASubclass,
	#superclass : #MCMockClassA,
	#instVars : [
		''x''
	],
	#classVars : [
		''Y''
	],
	#category : #MonticelloMocks
}

{ #category : #''as yet unclassified'' }
MCMockASubclass class >> initialize [

	InitializationOrder := InitializationOrder
		ifNil: [ -100 ] "let the test fail"
		ifNotNil: [ InitializationOrder + 1.]
]

{ #category : #''as yet unclassified'' }
MCMockASubclass >> variables [
	^ x + Y + MCMockClassA
]

{ #category : #''as yet unclassified'' }
MCMockASubclass >> variables2 [
	^ ivar + CVar
]
'! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteClassDefinitionOn
	| writer def stream |
	
	writer := self actualClass new.

	stream := String new writeStream.
	def := MCClassDefinition
		name: #SomeObject
		superclassName: #Object
		traitComposition: '{}'
		classTraitComposition: '{}'
		category: #Kernel
		instVarNames: #()
		classVarNames: #()
		poolDictionaryNames: #()
		classInstVarNames: #()
		type: #normal
		comment: 'comment test'
		commentStamp: nil.
	writer writeClassDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('"
comment test
"
Class {
	#name : #SomeObject,
	#superclass : #Object,
	#category : #Kernel
}
' withLineEndings: OSPlatform current lineEnding).

	stream := String new writeStream.
	def := MCClassDefinition
		name: #SomeObject
		superclassName: #Object
		traitComposition: '{}'
		classTraitComposition: '{}'
		category: #Kernel
		instVarNames: #(a b c)
		classVarNames: #(D E)
		poolDictionaryNames: #(POOL)
		classInstVarNames: #(instVarA)
		type: #normal
		comment: 'comment test'
		commentStamp: nil.
	writer writeClassDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('"
comment test
"
Class {
	#name : #SomeObject,
	#superclass : #Object,
	#instVars : [
		''a'',
		''b'',
		''c''
	],
	#classVars : [
		''D'',
		''E''
	],
	#pools : [
		''POOL''
	],
	#classInstVars : [
		''instVarA''
	],
	#category : #Kernel
}
' withLineEndings: OSPlatform current lineEnding).
! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteClassDefinitionWithClassTraitCompositionFromRealClassShouldWriteIt
	| writer def stream |
	
	writer := self actualClass new.

	stream := String new writeStream.
	def := self classWithTraitsWithClassComposition asClassDefinition.
	
	writer writeClassDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: (
'Class {
	#name : #SomeObject2,
	#superclass : #Object,
	#traits : ''T1 + T2'',
	#classTraits : ''(T1 classTrait + T2 classTrait) - {#m1}'',
	#category : #''MonticelloTonel-Tests''
}
' withLineEndings: OSPlatform current lineEnding).

	stream := String new writeStream.
	def := MCClassDefinition
		name: #SomeObject
		superclassName: #Object
		traitComposition: '{}'
		classTraitComposition: '{}'
		category: #Kernel
		instVarNames: #(a b c)
		classVarNames: #(D E)
		poolDictionaryNames: #(POOL)
		classInstVarNames: #(instVarA)
		type: #normal
		comment: 'comment test'
		commentStamp: nil.
	writer writeClassDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('"
comment test
"
Class {
	#name : #SomeObject,
	#superclass : #Object,
	#instVars : [
		''a'',
		''b'',
		''c''
	],
	#classVars : [
		''D'',
		''E''
	],
	#pools : [
		''POOL''
	],
	#classInstVars : [
		''instVarA''
	],
	#category : #Kernel
}
' withLineEndings: OSPlatform current lineEnding).
! !

!TonelWriterTest methodsFor: 'accessing' stamp: ' 1/5/2022 21:01:26'!
actualClass
	^ TonelWriter! !

!TonelWriterTest methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
expectedMCMockClassAClassSt
	^ '"
This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.
"
Class {
	#name : #MCMockClassA,
	#superclass : #MCMock,
	#instVars : [
		''ivar''
	],
	#classVars : [
		''CVar'',
		''InitializationOrder''
	],
	#category : #MonticelloMocks
}

{ #category : #''as yet unclassified'' }
MCMockClassA class >> cVar [
	^ CVar
]

{ #category : #''as yet unclassified'' }
MCMockClassA class >> initializationOrder [

	^ InitializationOrder
]

{ #category : #''as yet unclassified'' }
MCMockClassA class >> initialize [
	CVar := #initialized.
	InitializationOrder := 1.

]

{ #category : #''as yet unclassified'' }
MCMockClassA class >> one [

	^ 1
]

{ #category : #''as yet unclassified'' }
MCMockClassA class >> touchCVar [
	CVar := #touched
]

{ #category : #numeric }
MCMockClassA >> a [
	^ ''a2''
]

{ #category : #numeric }
MCMockClassA >> b [
	^ ''b1''
]

{ #category : #numeric }
MCMockClassA >> c [
	^ ''c1''
]

{ #category : #numeric }
MCMockClassA >> d [
	^ ''d''
]

{ #category : #boolean }
MCMockClassA >> falsehood [
	^ false
]

{ #category : #boolean }
MCMockClassA >> moreTruth [

	^ true
]

{ #category : #numeric }
MCMockClassA >> one [
	^ 1
]

{ #category : #''drag\''n\''drop'' }
MCMockClassA >> q [
]

{ #category : #boolean }
MCMockClassA >> truth [
	^ true
]

{ #category : #numeric }
MCMockClassA >> two [
	^ 2
]
'! !

!TonelWriterTest methodsFor: 'private' stamp: ' 1/5/2022 21:01:26'!
expectedMCSnapshotTestExtensionSt
	^ 'Extension { #name : #MCSnapshotTest }

{ #category : #''*MonticelloMocks'' }
MCSnapshotTest >> 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. " 
]
'! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteClassDefinitionWithTraitComposition
	| writer def stream |
	
	writer := self actualClass new.

	stream := String new writeStream.
	def := MCClassDefinition
		name: #SomeObject
		superclassName: #Object
		traitComposition: 'T1 + T2'
		classTraitComposition: 'T1 classTrait + T2 classTrait'
		category: #Kernel
		instVarNames: #()
		classVarNames: #()
		poolDictionaryNames: #()
		classInstVarNames: #()
		type: #normal
		comment: 'comment test'
		commentStamp: nil.
	writer writeClassDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('"
comment test
"
Class {
	#name : #SomeObject,
	#superclass : #Object,
	#traits : ''T1 + T2'',
	#classTraits : ''T1 classTrait + T2 classTrait'',
	#category : #Kernel
}
' withLineEndings: OSPlatform current lineEnding).

	stream := String new writeStream.
	def := MCClassDefinition
		name: #SomeObject
		superclassName: #Object
		traitComposition: '{}'
		classTraitComposition: '{}'
		category: #Kernel
		instVarNames: #(a b c)
		classVarNames: #(D E)
		poolDictionaryNames: #(POOL)
		classInstVarNames: #(instVarA)
		type: #normal
		comment: 'comment test'
		commentStamp: nil.
	writer writeClassDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('"
comment test
"
Class {
	#name : #SomeObject,
	#superclass : #Object,
	#instVars : [
		''a'',
		''b'',
		''c''
	],
	#classVars : [
		''D'',
		''E''
	],
	#pools : [
		''POOL''
	],
	#classInstVars : [
		''instVarA''
	],
	#category : #Kernel
}
' withLineEndings: OSPlatform current lineEnding).
! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteClassDefinitionWithTraitCompositionFromRealClass
	| writer def stream |
	
	writer := self actualClass new.

	stream := String new writeStream.
	def := self classWithTraits asClassDefinition.
	
	writer writeClassDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: (
'Class {
	#name : #SomeObject,
	#superclass : #Object,
	#traits : ''T1 + T2'',
	#classTraits : ''T1 classTrait + T2 classTrait'',
	#category : #''MonticelloTonel-Tests''
}
' withLineEndings: OSPlatform current lineEnding).

	stream := String new writeStream.
	def := MCClassDefinition
		name: #SomeObject
		superclassName: #Object
		traitComposition: '{}'
		classTraitComposition: '{}'
		category: #Kernel
		instVarNames: #(a b c)
		classVarNames: #(D E)
		poolDictionaryNames: #(POOL)
		classInstVarNames: #(instVarA)
		type: #normal
		comment: 'comment test'
		commentStamp: nil.
	writer writeClassDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('"
comment test
"
Class {
	#name : #SomeObject,
	#superclass : #Object,
	#instVars : [
		''a'',
		''b'',
		''c''
	],
	#classVars : [
		''D'',
		''E''
	],
	#pools : [
		''POOL''
	],
	#classInstVars : [
		''instVarA''
	],
	#category : #Kernel
}
' withLineEndings: OSPlatform current lineEnding).
! !

!TonelWriterTest methodsFor: 'tests' stamp: ' 1/5/2022 21:01:26'!
testWriteUnaryInstanceMethodDefinitionWithDotNextToSelector
	| writer def stream |
	
	writer := self actualClass new.

	stream := String new writeStream.
	def := MCMethodDefinition 
		className: #Object
		classIsMeta: false
		selector: #selector
		category: 'accessing' 
		timeStamp: nil
		source: 'selector.
	^ 42'.
	writer writeMethodDefinition: def on: stream. 
	self 
		assert: stream contents 
		equals: ('
{ #category : #accessing }
Object >> selector [.
	^ 42
]
' withLineEndings: OSPlatform current lineEnding).! !

!ToolDockingBarMorph commentStamp: ''!
A non user-moveable docking bar that uses theme-based fill styles.!
!ToolDockingBarMorph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
adoptMenuItemModel: item accumulator: controls
	
	item subMenu
		ifNil: [ | button |
			button := self buildButtonFor: item.
			controls add: button ]
		ifNotNil: [ 
			self emptyAccumulator: controls.
			self addMorphBack: (self theme newToolSpacerIn: self).
			self 
				add: item name
				font: self theme menuBarFont
				icon: item icon
				help: item description
				subMenu: item subMenu buildWithSpecAsPopup.
			self addMorphBack: (self theme newToolSpacerIn: self) ]! !

!ToolDockingBarMorph methodsFor: 'menu' stamp: ''!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu."
	
	^false! !

!ToolDockingBarMorph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
adoptMenuGroupModel: aGroupModel first: aBoolean
	| controls |
	
	aBoolean ifFalse: [ 
		self 
			addMorphBack: (self theme newToolSpacerIn: self);
			addMorphBack: (self theme newToolbarHandleIn: self);
			addMorphBack: (self theme newToolSpacerIn: self) ].
			
	controls := OrderedCollection new.
	aGroupModel menuItems do: [ :item | self adoptMenuItemModel: item accumulator: controls ].
	
	self emptyAccumulator: controls! !

!ToolDockingBarMorph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
emptyAccumulator: controls
	
	controls do: [ :button | self addMorphBack: button ].
	controls removeAll! !

!ToolDockingBarMorph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
adoptMenuModel: aMenuModel

	aMenuModel menuGroups doWithIndex: [ :aGroup :index | 
		self 
			adoptMenuGroupModel: aGroup
			first: (index = 1) ]! !

!ToolDockingBarMorph methodsFor: 'accessing' stamp: ''!
gradientRamp
	"If not set answer based on orininal color."
	
	^self normalFillStyle colorRamp! !

!ToolDockingBarMorph methodsFor: 'private - layout' stamp: ''!
updateColor
	"private - update the receiver's color"
	
	self autoGradient
		ifFalse: [^ self].
	self fillStyle: self normalFillStyle! !

!ToolDockingBarMorph methodsFor: '*Spec-MorphicAdapters' stamp: ''!
buildButtonFor: item

	^ self theme
		newButtonIn: self for: item
		getState: nil
		action: #performMenuActionWith:
		arguments: { self }
		getEnabled: #enabled 
		label: (IconicListItemMorph text: item name icon: item icon)
		help: item description ! !

!ToolDockingBarMorph methodsFor: 'style' stamp: ''!
normalFillStyle
	"Return the normal fillStyle of the receiver."
	
	^self theme dockingBarNormalFillStyleFor: self! !

!ToolRegistry commentStamp: ''!
I am serving as a system-wide hub for various tools.
Instead of using direct class names for tools, which is not always nice because can introduce inter-package
dependencies, i provide a uniform way for accessing tools, via Smalltalk global:

Smalltalk tools someToolName,

where 'someToolName' is a name of the tool , under which some tool are registered.

Tools are adding themselves to registry by implementing #registerToolsOn: message at class side, for example:

MyClass>>registerToolsOn: registry
   registry register: self as: #myTool

Registers a MyClass as a tool under name #myTool, and can be accessed via:

Smalltalk tools myTool 

and avoid putting 'MyClass' reference into code.

You can add  ' self registerToolsOn: Smalltalk tools ' in class #initialize,
so your new tool(s) can be registered during package loading.

To reset tool registry to defaults , use: 
Smalltalk resetTools.

Also registry storing a map of inspector types. 
This is to replace an old scheme which using #inspectorClass , and introducing dependencies.
Now, an inspecting class dont needs to have any knowledge about its specialized inspector.
Instead, a specialized inspector could tell registry that it is available for inspecting instances of given class (see #registerInspector:for:  senders).
This allows to avoid dependency from instance class to its inspector class or using extension methods.

WARNING: The point of the tools registry is NOT to be a facade full of protocols but to be a registration for tools that get loaded. So, the tools registry should NOT hold specific tool's protocol.  the tool's client should invoke the correct methods of the tool.

----------- 
The category 'menu' is for backward compatibility with ToolSet. We should remove it.

!
!ToolRegistry methodsFor: 'menu' stamp: ''!
openMonticelloBrowser
	self monticelloBrowser open
	! !

!ToolRegistry methodsFor: 'handling DNU' stamp: ''!
doesNotUnderstand: aMessage
	"Return a tool identified by a message selector.
	We need to handle special case, when no debugger registered.
	"
	| tool |
	tool := tools at: aMessage selector ifAbsent: nil.
	tool ifNotNil: [ ^ tool value ].

	^super doesNotUnderstand: aMessage
! !

!ToolRegistry methodsFor: 'menu' stamp: ''!
openProcessBrowser
	self using: #processBrowser do: [:tool |
		tool open
		]
! !

!ToolRegistry methodsFor: 'announcer' stamp: ''!
announcer
	announcer ifNil: [ announcer := Announcer new ].
	
	^ announcer! !

!ToolRegistry methodsFor: 'initialization' stamp: ''!
initialize

	"symbols used as keys "
	tools := IdentityDictionary new.  
	
	self initDefaultToolSet! !

!ToolRegistry methodsFor: 'initialization' stamp: ''!
initDefaultToolSet
	
	"Query the system for registering tools"
	"we cannot afford to show warnings because not all tools e.g Debugger, Inspector are registered yet"
	
	[	
	Object withAllSubclassesDo: [:ea | 
	"evaluate only for classes which directly implement this message,
	not via subclassing"
		(ea isMeta  and: [
			ea includesSelector: #registerToolsOn: ]) ifTrue: [
			 ea instanceSide registerToolsOn: self  ]].
	] on: Warning do: [:ex | ex resume ]! !

!ToolRegistry methodsFor: 'menu' stamp: ''!
menuItems
	"Answer the menu items available for this tool set"

	^#(
		('System Browser' 			#openClassBrowser)
		-
		('Playground'				#openWorkspace)
		('Transcript' 				#openTranscript)
		('File Browser'				#openFileList)
		-
		('Test Runner'				#openTestRunner)
		('Process Browser' 			#openProcessBrowser)
		-
		('Monticello Browser'		#openMonticelloBrowser)
		('Change Sorter'			#openChangeSorter)
	)
! !

!ToolRegistry methodsFor: 'menu' stamp: ''!
openTestRunner
	self using: #testRunner do: [:tool | tool open ]! !

!ToolRegistry methodsFor: 'announcer' stamp: ''!
whenToolRegistered: aBlock

	self announcer weak when: ToolRegistryToolRegistered do: aBlock ! !

!ToolRegistry methodsFor: 'menu' stamp: ''!
openClassBrowser
	^ self browser open! !

!ToolRegistry methodsFor: 'misc' stamp: ''!
using: aToolName do: aBlock
	"Evaluate a block for tool found under corresponding name or silently ignore if its not found or nil"
	| tool |
	
	tool := tools at: aToolName ifAbsent: [ ^ self ].
	tool ifNotNil: [ ^ aBlock value: tool value ]! !

!ToolRegistry methodsFor: 'registration' stamp: ''!
register: anObject as: aNameSelector
	"Register a tool class under given name"
	tools at: aNameSelector put: anObject.
	self announcer announce: (ToolRegistryToolRegistered tool: anObject name: aNameSelector) ! !

!ToolRegistry methodsFor: 'tools' stamp: ''!
inspector
	"understand by Object, so we need to work around not getting a DNU"
	^self doesNotUnderstand: (Message selector: #inspector)! !

!ToolRegistry methodsFor: 'misc' stamp: ''!
browseDirectToolReferences
	"Smalltalk tools browseDirectToolReferences"
	"Browse all direct references of all of my registered tools.
	Useful for converting calls like:

		MyTool foo
	into:
		Smalltalk tools myTool foo 	"
	
	| bindings |
	
	bindings := tools values select: [:each | each value isBehavior ]
		thenCollect: [:each | each value binding ].
	bindings := bindings copyWith: (Smalltalk bindingOf: #ToolSet).

	^  SystemNavigation new
		browseMessageList: (
			SystemNavigation new allMethodsSelect: [:m |
				(m literals select: [:lit| lit isVariableBinding ]) includesAnyOf: bindings ] )
		name: 'All direct references to tools to fix'! !

!ToolRegistry methodsFor: 'registration' stamp: ''!
remove: aName

	| toolToRemove |
	
	"remove tool with given name"
	toolToRemove := tools removeKey: aName ifAbsent: [].
	self announcer announce: (ToolRegistryToolRegistered tool: toolToRemove name: aName) ! !

!ToolRegistry methodsFor: 'tools' stamp: ''!
transcript
	"No need to register transcript. But for uniformity,
	implement this method, so transcript can be accessed via
	Smalltalk tools transcript , as any other tool "
	^ Transcript! !

!ToolRegistry methodsFor: 'menu' stamp: ''!
openTranscript
	^ self transcript open! !

!ToolRegistry methodsFor: 'menu' stamp: ''!
openRecentChangesLog
	self changeList browseRecentLog! !

!ToolRegistry methodsFor: 'menu' stamp: ''!
openWorkspace
	^ self workspace open! !

!ToolRegistry methodsFor: 'announcer' stamp: ''!
resetAnnouncer

	"unregister all current weak subscriptions because it can cause a memory leak"
	announcer ifNil: [ ^self ].
	announcer subscriptions subscriptions
 		select: [:each | each isKindOf: WeakAnnouncementSubscription] 
		thenDo: [:each | each weakRegistry remove: each subscriber ifAbsent: []]. 
	Smalltalk garbageCollect.
		
	announcer := nil.! !

!ToolRegistry methodsFor: 'testing' stamp: ''!
hasToolNamed: aToolName
	^ tools includesKey: aToolName ! !

!ToolRegistry methodsFor: 'menu' stamp: ''!
openFileList
	self fileList open! !

!ToolRegistry methodsFor: 'announcer' stamp: ''!
whenToolUnregistered: aBlock

	self announcer weak when: ToolRegistryToolUnregistered do: aBlock ! !

!ToolRegistryAnnouncement commentStamp: ''!
An abstract announcement class for tool registry announcements!
!ToolRegistryAnnouncement methodsFor: 'accessing' stamp: ''!
tool: anObject
	tool := anObject! !

!ToolRegistryAnnouncement methodsFor: 'accessing' stamp: ''!
tool
	^ tool! !

!ToolRegistryAnnouncement methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!ToolRegistryAnnouncement methodsFor: 'accessing' stamp: ''!
name: anObject
	name := anObject! !

!ToolRegistryAnnouncement class methodsFor: 'instance creation' stamp: ''!
tool: aTool name: aSymbol

	^ self new 
		tool: aTool;
		name: aSymbol;
		yourself! !

!ToolRegistryToolRegistered commentStamp: ''!
This announcement will be emitted when a new tool is registered.!
!ToolRegistryToolUnregistered commentStamp: ''!
This announcement will be emitted when a tool is unregistered.!
!ToolShortcutsCategory commentStamp: ''!
ToolShortcuts defines some global keyboard shortcuts to open tools for workspaces, system browser, monticello browser, settings, transcript and also image saving. !
!ToolShortcutsCategory methodsFor: 'keymaps' stamp: ''!
openSystemBrowser
	<shortcut>
	^ KMKeymap shortcut: PharoShortcuts current openSystemBrowserShortcut action: [ Smalltalk tools openClassBrowser ]! !

!ToolShortcutsCategory methodsFor: 'keymaps' stamp: ''!
saveImage
	<shortcut>
	^ KMKeymap
		shortcut: PharoShortcuts current saveImageShortcut
		action: [ 
			(Smalltalk snapshot: true andQuit: false)
				ifFalse: [ UIManager default inform: 'Image saved' ] ]! !

!ToolShortcutsCategory methodsFor: 'keymaps' stamp: ''!
openSettings
	<shortcut>
	^ KMKeymap shortcut: PharoShortcuts current openSettingsShortcut action: [ SettingBrowser open ]! !

!ToolShortcutsCategory methodsFor: 'keymaps' stamp: ''!
openMonticelloPackageBrowser
	<shortcut>
	^ KMKeymap shortcut: PharoShortcuts current openMonticielloShortcut action: [ Smalltalk tools openMonticelloBrowser ]! !

!ToolShortcutsCategory methodsFor: '*NewTools-Spotter' stamp: ''!
openSpotter

	<shortcut>

	^ KMKeymap
			shortcut: Character cr shift
			action: [ Smalltalk tools spotter open ]! !

!ToolShortcutsCategory methodsFor: '*Iceberg-TipUI' stamp: ''!
openIceberg
	<shortcut>
	^ KMKeymap shortcut: PharoShortcuts current openIcebergShortcut action: [ IceTipRepositoriesBrowser new openWithSpec ]! !

!ToolShortcutsCategory methodsFor: 'keymaps' stamp: ''!
openUnitTestRunner
	<shortcut>
	^ KMKeymap shortcut: PharoShortcuts current openTestRunnerShortcut action: [ Smalltalk tools openTestRunner ]! !

!ToolShortcutsCategory methodsFor: 'keymaps' stamp: ''!
openTranscript
	<shortcut>
	^ KMKeymap shortcut: PharoShortcuts current openTranscriptShortcut action: [ Smalltalk tools openTranscript ]! !

!ToolShortcutsCategory methodsFor: 'keymaps' stamp: ''!
openWorkspace
	<shortcut>
	^ KMKeymap shortcut: PharoShortcuts current openPlaygroundShortcut action: [ Smalltalk tools workspace open ]! !

!ToolShortcutsCategory class methodsFor: 'testing' stamp: ''!
isGlobalCategory

	^ true ! !

!TopLeftGripMorph commentStamp: ''!
I am the handle in the left top of windows used for resizing them.!
!TopLeftGripMorph methodsFor: 'drawing' stamp: ''!
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 bottom: (dotBounds2 top + windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.
	
	dotBounds2 := dotBounds left: (dotBounds left + windowBorderWidth).
	dotBounds2 := dotBounds2 bottom: (dotBounds2 top + 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 top: (dotBounds2 top + 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! !

!TopLeftGripMorph methodsFor: 'accessing' stamp: ''!
gripLayoutFrame
	^ (0 @ 0 corner: 0 @ 0) asLayoutFrame 
			topOffset: -27;
		 	rightOffset: self defaultWidth! !

!TopLeftGripMorph methodsFor: 'target resize' stamp: ''!
apply: delta 
	| oldBounds |
	oldBounds := target bounds.
	target
		bounds: (oldBounds origin + delta corner: oldBounds corner)! !

!TopLeftGripMorph methodsFor: 'accessing' stamp: ''!
resizeCursor

	^ Cursor resizeForEdge: #topLeft! !

!TopLeftGripMorph methodsFor: 'target resize' stamp: ''!
ptName
	^#topLeft! !

!TopLeftGripMorph methodsFor: 'testing' stamp: ''!
containsPoint: aPoint
	"Answer true only if on edges."
	
	|w|
	^(super containsPoint: aPoint) and: [
		w := SystemWindow borderWidth.
		((self bounds translateBy: w@w)
			containsPoint: aPoint) not]! !

!TopRightGripMorph commentStamp: ''!
I am the handle in the right top of windows used for resizing them.!
!TopRightGripMorph methodsFor: 'drawing' stamp: ''!
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 bottom: (dotBounds2 top + windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.
	
	dotBounds2 := dotBounds right: (dotBounds right - windowBorderWidth).
	dotBounds2 := dotBounds2 bottom: (dotBounds2 top + 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 top: (dotBounds2 top + 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! !

!TopRightGripMorph methodsFor: 'accessing' stamp: ''!
gripLayoutFrame
	^ (1 @ 0 corner: 1 @ 0) asLayoutFrame 
			topLeftOffset: self defaultWidth negated @ -27! !

!TopRightGripMorph methodsFor: 'target resize' stamp: ''!
apply: delta 
	| oldBounds |
	oldBounds := target bounds.
	target
		bounds: (oldBounds origin + (0@delta y) corner: oldBounds corner + (delta x @ 0))! !

!TopRightGripMorph methodsFor: 'accessing' stamp: ''!
resizeCursor

	^ Cursor resizeForEdge: #topRight! !

!TopRightGripMorph methodsFor: 'accessing' stamp: ''!
ptName
	^#topRight! !

!TopRightGripMorph methodsFor: 'testing' stamp: ''!
containsPoint: aPoint
	"Answer true only if on edges."
	
	|w|
	^(super containsPoint: aPoint) and: [
		w := SystemWindow borderWidth.
		((self bounds translateBy: w negated@w)
			containsPoint: aPoint) not]! !

!Trait commentStamp: ''!
My instances are the traits used to create traited classes.
The traits can be combined in different ways check TaAbstractComposition to see the different possible operations.

I am a subclass of Class, and I implement the specific behavior for traits.
So, the traits are polymorphic with classes.

I support stateful traits. 
Also Traits uses other metaclass to implement the behavior, check MetaclassForTraits. 

Also a nice diagram can be seen evaluating:

((ZnEasy getPng: 'https://raw.githubusercontent.com/wiki/pharo-project/pharo/figures/traits.png') 
	asMorph resize: 800@800; openInWindow) 

!
!Trait methodsFor: 'accessing' stamp: ''!
+ anotherTrait
	"I return my self in a sequence with anotherTrait"
	^ self asTraitComposition + anotherTrait asTraitComposition! !

!Trait methodsFor: 'testing' stamp: ''!
isEmpty 
	"Since we can have potential an empty array in the fluid definition (to be revisited) 
	when the trait composition is aTrait it received the message isEmpty and would break
	traitComposition 
		ifNotNil: [ :t | t isEmpty ifFalse: [shiftClassBuilder traitComposition: traitComposition ]]."

	^ false
	! !

!Trait methodsFor: 'testing' stamp: ''!
isTrait
	^ true! !

!Trait methodsFor: 'testing' stamp: ''!
isTraitExclusion
	^ false! !

!Trait methodsFor: 'removing' stamp: ''!
removeUser: aClass 

	self users remove: aClass ifAbsent: [ ].
	
	! !

!Trait methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitTrait: self! !

!Trait methodsFor: 'users' stamp: ''!
users
	^ users ifNil: [ users := IdentitySet new ]! !

!Trait methodsFor: 'testing' stamp: ''!
isUsed

	^ super isUsed or: [ self traitUsers notEmpty ]! !

!Trait methodsFor: 'accessing' stamp: ''!
users: anObject
	users := anObject! !

!Trait methodsFor: 'accessing - parallel hierarchy' stamp: ''!
classTrait

	^ self class! !

!Trait methodsFor: 'instance creation' stamp: ''!
basicNew
	"Traits should never be instantiated.
	They are naked object: superclass = nil. 
	They not understand any Object messages 
	and any DNU crashes VM because there are no methods doesNotUnderstand: or cannotInterpret:"
	
	self error: 'Traits should not be instantiated!!'! !

!Trait methodsFor: '*Monticello' stamp: 'nil'!
classDefinitions
	| definitions |
	definitions := OrderedCollection with: self asClassDefinition.
	(self hasClassSide
		and: [self classTrait hasTraitComposition])
					ifTrue: [definitions add: self classTrait asMCDefinition].
	^definitions asArray! !

!Trait methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
systemIconName

	^ #traitIcon! !

!Trait methodsFor: 'testing' stamp: ''!
isTraitAlias
	^ false! !

!Trait methodsFor: '*Tool-CriticBrowser' stamp: ''!
populateCBMenu: aMenu
	
	super populateCBMenu: aMenu.
	aMenu
		add: 'Users of...'
		target: SystemNavigation new
		selector: #browseAllUsersOfTrait:
		argument: self! !

!Trait methodsFor: 'fileout' stamp: ''!
definitionStringFor: aConfiguredPrinter

	^ aConfiguredPrinter traitDefinitionString! !

!Trait methodsFor: 'accessing - method dictionary' stamp: ''!
rebuildMethodDictionary
	"I extend the behavior in TraitedMetaclass propagating the changes to my users"
	self doRebuildMethodDictionary ifFalse: [ ^ false ].
	self users do: [ :e | e rebuildMethodDictionary ].
	^ true! !

!Trait methodsFor: 'accessing' stamp: ''!
- anArray
	"I return myself with a removed method. Check TaAbstractComposition >> #- for more details"

	^ self asTraitComposition - anArray! !

!Trait methodsFor: 'initialization' stamp: ''!
removeFromSystem: logged
	
	"When a trait is removed from the system it should:
	
	- Remove it self from its trait compositions.
	- Remove it self from its users.
	- Remove its classTrait from its users.
	- Do what any class does."
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.
	
	self traitUsers do: [ :e | e isObsolete ifFalse: [ e removeFromComposition: self ]].
	self class traitUsers do: [ :e | e isObsolete ifFalse: [e removeFromComposition: self class ]].
	^ super removeFromSystem: logged! !

!Trait methodsFor: 'accessing' stamp: ''!
@ anArray
	"I return myself with an aliased method. Check TaAbstractComposition >> #@ for more details"
	^ self asTraitComposition @ anArray! !

!Trait methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asRingDefinitionWithMethods: methodsBoolean withSuperclasses: supersBoolean withSubclasses: subsBoolean withPackageKeys: packageKeys in: aRGSlice

	| rgClass rgMethod rgSuper sup |

	rgClass := self asRingDefinition.
	aRGSlice loadClass: rgClass using: packageKeys.

	methodsBoolean
		ifTrue: [ self
				methodsDo: [ :mth | 
					rgMethod := mth asActiveRingDefinition.
					aRGSlice loadMethod: rgMethod inClass: rgClass using: packageKeys
					].
			self classSide
				methodsDo: [ :mth | 
					rgMethod := mth asActiveRingDefinition.
					aRGSlice loadMethod: rgMethod inClass: rgClass classSide using: packageKeys
					]
			].

	supersBoolean
		ifTrue: [ rgSuper := aRGSlice classNamed: rgClass superclassName.
			rgSuper
				ifNil: [ sup := aRGSlice environment classNamed: rgClass superclassName.
					rgSuper := sup
						asRingDefinitionWithMethods: methodsBoolean
						withSuperclasses: supersBoolean
						withSubclasses: subsBoolean
						withPackageKeys: packageKeys
						in: aRGSlice
					].
			rgClass superclass: rgSuper
			].

	^ rgClass! !

!Trait methodsFor: 'accessing' stamp: ''!
traitUsers
	^ self users! !

!Trait methodsFor: '*Reflectivity' stamp: ''!
nonAnonymousClass
	^ self class isAnonymous
		ifTrue: [ self class superclass ]
		ifFalse: [ self class ]! !

!Trait methodsFor: 'testing' stamp: ''!
isClassTrait
	
	^ false! !

!Trait methodsFor: '*Ring-Tests-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGTrait named: self name asSymbol parent: anRGEnvironment]. 
	! !

!Trait methodsFor: 'testing' stamp: ''!
isClass
	
	^ false! !

!Trait methodsFor: '*Epicea-Ring' stamp: ''!
asEpiceaRingDefinition

	^ self asRingDefinition
		package: (EpPlatform current packageNameFor: self);
		yourself.! !

!Trait methodsFor: 'accessing' stamp: ''!
@@ anArray
	"I return myself with an aliased method. Check TaAbstractComposition >> #@ for more details"
	^ self asTraitComposition @@ anArray! !

!Trait methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asRingDefinition

	"A triat is converted to a ring class. Only the receiver is converted.
	Methods, superclasses, subclasses are not generated"

	| ring |
	ring := (RGTraitDefinition named: self name)
		        category: self category;
		        superclassName: #Trait;
		        traitCompositionSource: self traitCompositionString;
		        comment: self organization classComment;
		        stamp: self organization commentStamp;
		        definitionSource: self definitionString;
		        withMetaclass.

	ring classSide
		traitCompositionSource: self classSide traitCompositionString;
		definitionSource: self classSide definitionString.

	^ ring! !

!Trait methodsFor: 'organization updating' stamp: ''!
notifyOfRecategorizedSelector: selector from: oldCategory to: newCategory
	"When there is a recategorization of a selector, I propagate the changes to my users"
	super notifyOfRecategorizedSelector: selector from: oldCategory to: newCategory.
	self traitUsers do: [ :e | e recategorizeSelector: selector from: oldCategory to: newCategory ].! !

!Trait methodsFor: 'testing' stamp: ''!
isBaseTrait
	
	^ true! !

!Trait methodsFor: 'users' stamp: ''!
addUser: aClass 

	self users add: aClass! !

!Trait methodsFor: '*Renraku' stamp: ''!
reBanName

	^ self name, ' (Trait)'! !

!Trait methodsFor: 'fileout' stamp: ''!
expandedDefinitionStringFor: aPrinter

	^ aPrinter expandedTraitDefinitionString ! !

!Trait methodsFor: '*Monticello' stamp: 'nil'!
asClassDefinition
	"We do not dispatch on the printer because in fact MC only support the oldPharo syntax. 
	This syntax is hijacked to store the full definition of a slot in case of complex slots: 
				#x => PropertySlot 
				
	This is produces by definitionString on slot while x is produced simnply by invoking name.
	"
	| classTraitCompositionToUse |
	classTraitCompositionToUse := self class traitCompositionString.

	^ self needsSlotClassDefinition
		ifTrue: [ 
			MCTraitDefinition
				name: self name
				traitComposition: self traitCompositionString
				category: self category 
				instVarNames: (self localSlots collect: [:each |each definitionString])
				classInstVarNames: (self classSide localSlots collect: [:each |each definitionString])
				classTraitComposition: classTraitCompositionToUse
				comment: self organization classComment asString
				commentStamp: self organization commentStamp ]
		 ifFalse: [  
			MCTraitDefinition
				name: self name
				traitComposition: self traitCompositionString
				category: self category 
				instVarNames: (self localSlots collect: [ :each | each name ])
				classInstVarNames: (self class localSlots collect: [ :each | each name ])
				classTraitComposition: classTraitCompositionToUse
				comment: self organization classComment asString
				commentStamp: self organization commentStamp
				]
		
	
		! !

!Trait methodsFor: 'accessing' stamp: ''!
-- aSlotNameCollection

	^ self asTraitComposition -- aSlotNameCollection! !

!Trait methodsFor: '*Kernel-Traits' stamp: ''!
hasEmptyComposition
	
	^ self traitComposition isEmpty or: [ self traitComposition = TEmpty asTraitComposition ]! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aName uses: aTraitCompositionOrCollection slots: someSlots package: aPackageName

	^ self named: aName 
		uses: aTraitCompositionOrCollection 
		slots: someSlots 
		package: aPackageName 
		env: self environment ! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aSymbol uses: aTraitCompositionOrCollection package: aString
	^ self
		named: aSymbol
		uses: aTraitCompositionOrCollection
		package: aString
		env: self environment! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aName uses: aTraitCompositionOrCollection slots: someSlots package: aPackageName env: anEnvironment
	| trait |
	trait := self classInstaller
		make: [ :builder | 
			self
				configureBuilder: builder
				withName: aName
				traitComposition: aTraitCompositionOrCollection
				slots: someSlots
				packageName: aPackageName ].
	self assert: [ trait class class = MetaclassForTraits ].
	self assert: [ trait class superclass = Trait ].
	^ trait! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aSymbol package: aString
	^ self
		named: aSymbol
		uses: {}
		package: aString
		env: self environment! !

!Trait class methodsFor: 'deprecated' stamp: ''!
named: aName uses: aTraitCompositionOrCollection category: aString env: anEnvironment
	^ self
		named: aName
		uses: aTraitCompositionOrCollection
		slots: #()
		package: aString
		env: anEnvironment! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aSymbol
	^ self named: aSymbol uses: {} package: 'Unclassified'! !

!Trait class methodsFor: 'deprecated' stamp: ''!
named: aName uses: aTraitCompositionOrCollection slots: someSlots category: aCategory

	^ self named: aName 
		uses: aTraitCompositionOrCollection 
		slots: someSlots 
		package: aCategory 
		env: self environment ! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aName uses: aTraitCompositionOrCollection instanceVariableNames: aString package: aPackageName

	^ self named: aName 
		uses: aTraitCompositionOrCollection 
		instanceVariableNames: aString 
		package: aPackageName 
		env: self environment ! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aName uses: aTraitCompositionOrCollection instanceVariableNames: aString package: aPackageName env: anEnvironment
	| trait |
	trait := self classInstaller
		make: [ :builder | 
			self
				configureBuilder: builder
				withName: aName
				traitComposition: aTraitCompositionOrCollection
				slots: aString asSlotCollection
				packageName: aPackageName ].
	self assert: [ trait class class = MetaclassForTraits ].
	self assert: [ trait class superclass = Trait ].
	^ trait! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aSymbol trait: aCompositionOrArray
	^ self named: aSymbol trait: aCompositionOrArray package: 'Unclassified'! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aSymbol uses: aCompositionOrArray
	^ self named: aSymbol uses: aCompositionOrArray package: 'Unclassified'! !

!Trait class methodsFor: 'deprecated' stamp: ''!
named: aName uses: aTraitCompositionOrCollection slots: someSlots category: aCategory env: anEnvironment 
	"It is unclear that it is not use by low level library such as MC so we should not use it but we do not remove it for now."
	
	^ self named: aName uses: aTraitCompositionOrCollection slots: someSlots package: aCategory env: anEnvironment ! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aName instanceVariableNames: aString package: aPackageName

	^ self named: aName 
		uses: {} 
		instanceVariableNames: aString 
		package: aPackageName 
		env: self environment ! !

!Trait class methodsFor: '*FluidClassBuilder' stamp: ''!
<< aSymbolOrAClassSideTrait

	"Return a builder of class FluidTraitBuilder. To get a trait, this builder should be sent build. This way we can manipulate and test trait definition without be forced to get them added to the environment."

	aSymbolOrAClassSideTrait isSymbol
		ifFalse: [ 
			^ FluidClassSideTraitBuilder new
				  nameToBuild: aSymbolOrAClassSideTrait soleInstance name;
				  fillInstanceSideFromClass: aSymbolOrAClassSideTrait soleInstance;
				  yourself ].

	^ FluidTraitBuilder new
			nameToBuild: aSymbolOrAClassSideTrait;
			fillClassSideFromEnvironment: self environment;
			yourself! !

!Trait class methodsFor: 'deprecated' stamp: ''!
named: aSymbol uses: aTraitCompositionOrCollection category: aString
	^ self
		named: aSymbol
		uses: aTraitCompositionOrCollection
		package: aString
		env: self environment! !

!Trait class methodsFor: 'old pharo 8 syntax' stamp: ''!
named: aName uses: aTraitCompositionOrCollection package: aString env: anEnvironment
	^ self
		named: aName
		uses: aTraitCompositionOrCollection
		slots: #()
		package: aString
		env: anEnvironment! !

!Trait class methodsFor: 'private' stamp: ''!
configureBuilder: builder withName: aName traitComposition: aTraitCompositionOrCollection instanceVariableNames: aString packageName: aPackageName

	^ self
		  configureBuilder: builder
		  withName: aName
		  traitComposition: aTraitCompositionOrCollection
		  slots: aString asSlotCollection
		  packageName: aPackageName! !

!Trait class methodsFor: 'private' stamp: ''!
configureBuilder: builder withName: aName traitComposition: aTraitCompositionOrCollection slots: someSlots packageName: aPackageName

	^ builder
		name: aName;
		beTrait;
		slots: someSlots;
		sharedVariables: '';
		sharedPools: '';
		category: aPackageName;
		traitComposition: aTraitCompositionOrCollection asTraitComposition;
		classTraitComposition: aTraitCompositionOrCollection asTraitComposition classComposition! !

!Trait1 methodsFor: 'trait1 - c' stamp: ''!
c

	^ 'Trait1>>c'! !

!Trait1 methodsFor: 'trait1 - c' stamp: ''!
c1

	^ 'Trait1>>c1'! !

!Trait1 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!Trait1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!Trait1 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!Trait1 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!Trait1 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!Trait1 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!Trait1 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!Trait1 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!Trait1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!Trait1 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!Trait1 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!Trait1 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!Trait1 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!Trait1 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!Trait1 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!Trait1 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!Trait1 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!Trait1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!Trait1 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!Trait1 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!Trait1 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!Trait1 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!Trait1 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!Trait1 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!Trait1 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!Trait1 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!Trait2 methodsFor: 'trait2 - c' stamp: ''!
c

	^ 'Trait2>>c'! !

!Trait2 methodsFor: 'trait2 - c' stamp: ''!
c2

	^ 'Trait2>>c2'! !

!Trait2 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!Trait2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!Trait2 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!Trait2 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!Trait2 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!Trait2 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!Trait2 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!Trait2 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!Trait2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!Trait2 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!Trait2 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!Trait2 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!Trait2 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!Trait2 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!Trait2 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!Trait2 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!Trait2 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!Trait2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!Trait2 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!Trait2 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!Trait2 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!Trait2 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!Trait2 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!Trait2 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!Trait2 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!Trait2 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!Trait3 methodsFor: 'local' stamp: ''!
c

	^ 'Trait3>>c'! !

!Trait3 methodsFor: 'local' stamp: ''!
c3

	^ 'Trait3>>c3'! !

!Trait3 methodsFor: 'trait2 - c' stamp: ''!
c2

	^ 'Trait2>>c2'! !

!Trait3 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!Trait3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!Trait3 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!Trait3 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!Trait3 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!Trait3 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!Trait3 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!Trait3 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!Trait3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!Trait3 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!Trait3 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!Trait3 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!Trait3 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!Trait3 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!Trait3 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!Trait3 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!Trait3 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!Trait3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!Trait3 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!Trait3 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!Trait3 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!Trait3 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!Trait3 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!Trait3 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!Trait3 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!Trait3 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!Trait4 methodsFor: 'trait1 - c' stamp: ''!
c

	^ 'Trait1>>c'! !

!Trait4 methodsFor: 'trait1 - c' stamp: ''!
c1

	^ 'Trait1>>c1'! !

!Trait4 methodsFor: 'trait2 - c' stamp: ''!
c2

	^ 'Trait2>>c2'! !

!Trait4 classTrait methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!Trait4 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!Trait4 classTrait methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!Trait4 classTrait methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!Trait4 classTrait methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!Trait4 classTrait methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!Trait4 classTrait methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!Trait4 classTrait methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!Trait4 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!Trait4 classTrait methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!Trait4 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!Trait4 classTrait methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!Trait4 classTrait methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!Trait4 classTrait methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!Trait4 classTrait methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!Trait4 classTrait methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!Trait4 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!Trait4 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!Trait4 classTrait methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!Trait4 classTrait methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!Trait4 classTrait methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!Trait4 classTrait methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!Trait4 classTrait methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!Trait4 classTrait methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!Trait4 classTrait methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!Trait4 classTrait methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TraitAlias commentStamp: ''!
It is kept for compatibility with extension methods
Check the class TaAbstractComposition for the new implementation.!
!TraitBehavior commentStamp: ''!
This class is only kept for compatibility to load extension methods. Will be removed.
Check Trait for the new implementation of traits!
!TraitBehavior methodsFor: '*Calypso-SystemQueries' stamp: ''!
calypsoEnvironmentType
	^ClyClass! !

!TraitBehavior methodsFor: '*Calypso-SystemQueries' stamp: ''!
metaLevelScope
	^self isInstanceSide ifTrue: [ ClyInstanceSideScope ] ifFalse: [ ClyClassSideScope ]! !

!TraitBehavior methodsFor: '*Calypso-SystemQueries' stamp: ''!
includesMethodsAffectedBy: aSystemAnnouncement
	^aSystemAnnouncement affectsMethodsDefinedInClass: self! !

!TraitBuilderEnhancer commentStamp: ''!
I am here to extend the ShiftClassBuilder when creating a Trait or TraitedClass.
My class side method #isApplicableFor: is responsible of detecting if we are creating a trait or a class using a trait.

I create the new class using the TraitedMetaclass or MetaclassForTraits.
I inject the methods from TraitedClass to the generated metaclass. 

Also I add all the slots and methods in the trait composition.!
!TraitBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
configureMetaclass: newMetaclass superclass: superclass withLayoutType: aLayoutType slots: classSlots
	| resultingSlots |
	self validateTraitComposition: self classTraitComposition ofClass: builder oldMetaclass.

	resultingSlots := self
		eliminateDuplicates: classSlots , self classTraitComposition slotsCopy
		withSuperclassSlots: superclass allSlots.

	newMetaclass superclass: superclass withLayoutType: aLayoutType slots: resultingSlots! !

!TraitBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
newMetaclass: aBuilder

	(aBuilder traitComposition asTraitComposition isNotEmpty or: [ aBuilder classTraitComposition asTraitComposition isNotEmpty or: [ aBuilder superclass class class = TraitedMetaclass]])
		ifTrue: [ aBuilder metaclassClass: TraitedMetaclass ].
				
	aBuilder metaSuperclass = Trait
		ifTrue: [ aBuilder metaclassClass: MetaclassForTraits ].		
		
	^ super newMetaclass: aBuilder! !

!TraitBuilderEnhancer methodsFor: 'utilities' stamp: ''!
classTraitCompositionOfClass: aClass 
	
	^ aClass class traitComposition asTraitComposition! !

!TraitBuilderEnhancer methodsFor: 'accessing' stamp: ''!
classTraitCompositionOf: aBuilder 
	
	^ aBuilder classTraitComposition asTraitComposition! !

!TraitBuilderEnhancer methodsFor: 'utilities' stamp: ''!
eliminateDuplicates: aSlotCollection withSuperclassSlots: superclassSlots
	| resultingSlots |
	resultingSlots := OrderedCollection new.

	aSlotCollection
		do: [ :e | 
			((resultingSlots noneSatisfy: [ :x | e name = x name ]) and: [ superclassSlots noneSatisfy: [ :x | e name = x name ] ])
				ifTrue: [ resultingSlots add: e ] ].


	^ resultingSlots asArray! !

!TraitBuilderEnhancer methodsFor: 'migrating' stamp: ''!
beforeMigratingClass: aBuilder installer: anInstaller
	aBuilder oldClass ifNil: [ ^ self ].
	
	aBuilder oldClass traitComposition removeUser: aBuilder oldClass.
	aBuilder oldMetaclass traitComposition removeUser: aBuilder oldMetaclass.
	
	TraitedClass removeUser: aBuilder oldMetaclass.	
	
	"If it is a Trait we should migrate the users "
	aBuilder newClass isTrait ifFalse: [ ^ self ].	
	aBuilder newClass users: aBuilder oldClass users.
	aBuilder newMetaclass users: aBuilder oldMetaclass users.	
	! !

!TraitBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
propagateChangesToRelatedClasses: newClass installer: installer

	super propagateChangesToRelatedClasses: newClass installer: installer.

	"If the newClass is a trait I have to remake the users of it"
	newClass isTrait ifFalse: [ ^ self ].
	(builder changes noneSatisfy: 
		[ :each | each hasChangeClassSideShape or: [ each hasChangeInstanceSideShape  ] ]) 
		ifTrue: [^self].

	newClass users do: [ :each | installer remake: each instanceSide ]! !

!TraitBuilderEnhancer methodsFor: 'initialization' stamp: ''!
initializeBuilder: aBuilder
	super initializeBuilder: aBuilder.

	builder := aBuilder.

	aBuilder addChangeComparer: TraitCompositionChangedDetector.! !

!TraitBuilderEnhancer methodsFor: 'utilities' stamp: ''!
traitCompositionOfClass: aClass 
	
	^ aClass traitComposition asTraitComposition! !

!TraitBuilderEnhancer methodsFor: 'validating' stamp: ''!
validateTraitComposition: aTraitComposition ofClass: aClass 

	^ (aTraitComposition allTraits includes: aClass) ifTrue: [ self error: 'Cyclic Trait composition' ]! !

!TraitBuilderEnhancer methodsFor: 'migrating' stamp: ''!
validateRedefinition: anOldClass
	(anOldClass isNotNil and: [ anOldClass isTrait ~= builder isTrait ])
		ifTrue: [ self error: 'A class should not be redefined as a trait. First remove it from the system.' ]! !

!TraitBuilderEnhancer methodsFor: 'events' stamp: ''!
migrateInstancesTo: aClass installer: aShiftClassInstaller 

	"Traits does not have instances"
	aClass isTrait 
		ifTrue: [ ^ self ].

	super migrateInstancesTo: aClass installer: aShiftClassInstaller ! !

!TraitBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
configureClass: newClass superclass: superclass withLayoutType: layoutType slots: slots
	| resultingSlots |
	self validateTraitComposition: self traitComposition ofClass: builder oldClass.

	resultingSlots := self
		eliminateDuplicates: slots , self traitComposition slotsCopy
		withSuperclassSlots: (superclass ifNil: [#()] ifNotNil:[ :x | x allSlots]).

	newClass superclass: superclass withLayoutType: layoutType slots: resultingSlots! !

!TraitBuilderEnhancer methodsFor: 'accessing' stamp: ''!
traitComposition
	^ builder traitComposition asTraitComposition! !

!TraitBuilderEnhancer methodsFor: 'class modifications' stamp: ''!
afterMethodsCompiled: aBuilder

	"we need to remove the categories leftover after removing Traits"
	aBuilder newClass organization cleanUpCategoriesForClass: aBuilder newClass.
	aBuilder newClass class organization cleanUpCategoriesForClass: aBuilder newClass class.
	
	(self isTraitedMetaclass: aBuilder)
		ifFalse: [ ^ self ].

	builder newMetaclass rebuildMethodDictionary.
	aBuilder newClass rebuildMethodDictionary.! !

!TraitBuilderEnhancer methodsFor: 'migrating' stamp: ''!
afterMigratingClass: aBuilder installer: anInstaller

	(self isTraitedMetaclass: aBuilder)
		ifFalse: [ ^ self ].

	aBuilder newClass traitComposition addUser: aBuilder newClass.
	aBuilder newMetaclass traitComposition addUser: aBuilder newMetaclass.
	
	TraitedClass addUser: aBuilder newMetaclass.
	
	"If this is a trait I have to update the users"
	aBuilder newClass isTrait ifFalse: [ ^ self ].
	
	builder newMetaclass traitUsers do: [:e | e rebuildMethodDictionary].
	aBuilder newClass traitUsers do: [:e | e rebuildMethodDictionary].! !

!TraitBuilderEnhancer methodsFor: 'accessing' stamp: ''!
traitCompositionOf: aBuilder 
	
	^ aBuilder traitComposition asTraitComposition! !

!TraitBuilderEnhancer methodsFor: 'initialization' stamp: ''!
fillBuilder: aBuilder from: aClass 
	
	(aBuilder superclass isNil and: [ aClass superclass isNil ]) 
		ifTrue: [ aBuilder metaSuperclass: aClass class superclass ].
	
	aBuilder traitComposition: aClass traitComposition.
	aBuilder classTraitComposition: aClass class traitComposition.
	
	aBuilder metaclassClass: aClass class class.! !

!TraitBuilderEnhancer methodsFor: 'accessing' stamp: ''!
classTraitComposition
	^ builder classTraitComposition asTraitComposition! !

!TraitBuilderEnhancer methodsFor: 'testing' stamp: ''!
isTraitedMetaclass: aBuilder 
	
	^ aBuilder metaclassClass includesBehavior: TraitedMetaclass
	! !

!TraitBuilderEnhancer methodsFor: 'events' stamp: ''!
classCreated: aBuilder

	(self isTraitedMetaclass: aBuilder)
		ifFalse: [ ^ self ].

	builder newMetaclass initializeBasicMethods.
	
	builder newClass traitComposition: self traitComposition.
	builder newMetaclass traitComposition: self classTraitComposition.
! !

!TraitBuilderEnhancer class methodsFor: 'testing' stamp: ''!
isApplicableFor: aBuilder
	
	aBuilder metaSuperclass = Trait ifTrue: [ ^ true ].
	aBuilder oldClass class superclass = Trait ifTrue: [ ^ true ].
	
	aBuilder oldClass class class = TraitedMetaclass ifTrue: [ ^ true ].
	aBuilder superclass class class = TraitedMetaclass ifTrue: [ ^ true ].

	aBuilder traitComposition asTraitComposition isEmpty ifFalse: [ ^ true ].
	aBuilder classTraitComposition asTraitComposition isEmpty ifFalse: [ ^ true ].

	^ false! !

!TraitChange commentStamp: ''!
I implement the logic to propagate the changes when a trait is modified.

I am used as:

 - A new selector has been added or updated: 

    TraitChange addSelector: #aSelector on: aTrait.

- A selector has been removed from a trait
  
   TraitChange removeSelector: #aSelector on: aTrait.

I handle the removal or the addition. 
I propagate to the users of the trait.
If the removal was shadowing a method from the trait composition, the method from the trait composition is installed and the change propagated accordly. !
!TraitChange methodsFor: 'accessing' stamp: ''!
updatedSelectors
	^ updatedSelectors! !

!TraitChange methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	updatedSelectors := Set new.
	addedSelectors := Set new.
	removedSelectors := Set new! !

!TraitChange methodsFor: 'accessing' stamp: ''!
addedSelectors
	^ addedSelectors! !

!TraitChange methodsFor: 'accessing' stamp: ''!
addedSelectors: anObject
	addedSelectors := anObject! !

!TraitChange methodsFor: 'accessing' stamp: ''!
removedSelectors
	^ removedSelectors! !

!TraitChange methodsFor: 'operations' stamp: ''!
update: aSelector into: aClass changes: changes
	
	"I am the responsible of propagating a change from an used trait"
	
	"If the updated selector (from other trait) is in the local methods, nothing to do."

	aClass localMethodDict at: aSelector ifPresent: [ ^ self ].
	
	(aClass traitComposition selectors includes: aSelector)
		ifTrue: [  	aClass traitComposition installSelector: aSelector into: aClass.
						changes updatedSelectors add: aSelector ].

	"If the updated method is aliased, it should be updated also"
	(aClass traitComposition reverseAlias: aSelector)
		do: [ :aliased | 
			aClass traitComposition installSelector: aliased into: aClass.
			changes updatedSelectors add: aliased ]! !

!TraitChange methodsFor: 'accessing' stamp: ''!
updatedSelectors: anObject
	updatedSelectors := anObject! !

!TraitChange methodsFor: 'operations' stamp: ''!
add: aSelector into: aClass changes: changes 

	" After adding or updating a method, it should be added to the local MethodDictionary.
	Also the change should be propagated to the users."
	aClass localMethodDict at: aSelector put: (aClass methodDict at: aSelector).
	changes updatedSelectors add: aSelector
	
! !

!TraitChange methodsFor: 'operations' stamp: ''!
remove: aSelector into: aClass changes: results
	| isLocal inTrait priorMethod priorProtocol |

	"I handle the removal of a selector. There are many cases to check."

	isLocal := aClass localSelectors includes: aSelector.
	inTrait := aClass traitComposition traitDefining: aSelector ifNone: [ nil ].

	"This is only true when the update method is a propagation, so we have to avoid destroying a locally defined method.
	Check TraitedClass >> #removeSelector: and you will see that the method is removed from the local method dict 
	if it is local.
	As the method is propagated and is local, we don't do nothing"
	isLocal ifTrue: [ ^ self ].	
	
	"If the removed method was shadowing a method from a trait composition, the method from the trait composition
	should be installed. And the change propagated as an update, not as a removal."
	inTrait 
		ifNotNil: [ 
			inTrait installSelector: aSelector into: aClass.
			results updatedSelectors add: aSelector.
			^ self ].


	"We have to remove the method that was removed in a used trait."

	(aClass methodDict includesKey: aSelector) ifTrue:[
		priorMethod := aClass methodDict at: aSelector.
		priorProtocol := aClass whichCategoryIncludesSelector: aSelector.

		aClass methodDict removeKey: aSelector.
		aClass organization removeElement: aSelector.	
		
		SystemAnnouncer uniqueInstance methodRemoved: priorMethod protocol: priorProtocol origin: aClass	
	].

	"The change is propagated as a removal"
	results removedSelectors add: aSelector.
	
	"If the updated method is aliased (it has alias pointing to it), they should be removed also"
	(aClass traitComposition reverseAlias: aSelector)
		do: [ :aliased | 
			aClass methodDict removeKey: aliased ifAbsent: [  ].
			results removedSelectors add: aliased ]
! !

!TraitChange methodsFor: 'accessing' stamp: ''!
removedSelectors: anObject
	removedSelectors := anObject! !

!TraitChange methodsFor: 'applying' stamp: ''!
applyOn: aClass 	
	| result |
	
	"I apply all the changes in a class.
	This class is a trait or a trait user
	I produce a new trait change with the changes to be propagated to the users of aClass.
	Then the changes are propagated using the same mechanism recursively"
	
	result := TraitChange new.
	
	addedSelectors do: [ :e | self add: e into: aClass changes: result ].
	removedSelectors do: [ :e | self remove: e into: aClass changes: result ].
	updatedSelectors do: [ :e | self update: e into: aClass changes: result ].
	
	aClass traitUsers do: [ :aUser | result applyOn: aUser ].
! !

!TraitChange class methodsFor: 'instance creation' stamp: ''!
addSelector: aSelector on: aClass

	"I propagate the addition or change of a selector in aClass that is a trait or a trait user.
	 I propagate to the users"

	^ self new
		addedSelectors: {aSelector};
		applyOn: aClass! !

!TraitChange class methodsFor: 'instance creation' stamp: ''!
removeSelector: aSelector on: aClass 

	"I propagate the removal of a selector in aClass that is a trait or a trait user. 
	If the removed method has a version in the trait composition this version is used. 
	I propagate to the users"

	^ self new
		removedSelectors: {aSelector};
		applyOn: aClass! !

!TraitComposition commentStamp: ''!
It is kept for compatibility with extension methods
Check the class TaAbstractComposition for the new implementation.!
!TraitCompositionChangedDetector commentStamp: ''!
I can detect if there is a change in the Trait composition.
!
!TraitCompositionChangedDetector methodsFor: 'comparing' stamp: ''!
compareClass

	(self enhancer traitCompositionOf: builder)
		~= (self enhancer traitCompositionOfClass: builder oldClass)
		ifTrue: [ ^ {(ShClassChanged new
				builder: builder;
				yourself)} ].

	(self enhancer classTraitCompositionOf: builder)
		~= (self enhancer classTraitCompositionOfClass: builder oldClass)
		ifTrue: [ ^ {(ShMetaclassChanged new
				builder: builder;
				yourself)} ].

	^ #()! !

!TraitCompositionChangedDetector methodsFor: 'accessing' stamp: ''!
enhancer
	^ builder builderEnhancer! !

!TraitCompositionTest methodsFor: 'tests - basic' stamp: ''!
testEmptyTrait
	| composition |
	composition := {} asTraitComposition.

	self assertEmpty: composition.
	self assertEmpty: composition traits! !

!TraitCompositionTest methodsFor: 'tests - basic' stamp: ''!
testOriginSelectorOf
	
	"regular method "
	self assert: (MOPTestClassC traitComposition originSelectorOf: #c) equals: #c.	
	"non aliased trait method "
	self assert: (MOPTestClassD traitComposition originSelectorOf: #c2) equals: #c2.	
	"aliased method "
	self assert: (MOPTestClassD traitComposition originSelectorOf: #c3) equals: #c2.! !

!TraitCompositionTest methodsFor: 'tests - basic' stamp: ''!
testAliasCompositions
	"unary"

	self t2 setTraitComposition: self t1 @ {(#aliasM11 -> #m11)}.
	self should: [ self t2 setTraitComposition: self t1 @ {(#alias: -> #m11)} ] raise: Error.
	self should: [ self t2 setTraitComposition: self t1 @ {(#alias:x:y: -> #m11)} ] raise: Error.	"binary"
	self t1 compile: '= anObject'.
	self t2 setTraitComposition: self t1 @ {(#equals: -> #=)}.
	self t2 setTraitComposition: self t1 @ {(#% -> #=)}.
	self should: [ self t2 setTraitComposition: self t1 @ {(#equals -> #=)} ] raise: Error.
	self should: [ self t2 setTraitComposition: self t1 @ {(#equals:x: -> #=)} ] raise: Error.	"keyword"
	self t1 compile: 'x: a y: b z: c'.
	self should: [ self t2 setTraitComposition: self t1 @ {(#== -> #x:y:z:)} ] raise: Error.
	self should: [ self t2 setTraitComposition: self t1 @ {(#x -> #x:y:z:)} ] raise: Error.
	self should: [ self t2 setTraitComposition: self t1 @ {(#x: -> #x:y:z:)} ] raise: Error.
	self should: [ self t2 setTraitComposition: self t1 @ {(#x:y: -> #x:y:z:)} ] raise: Error.
	self t2 setTraitComposition: self t1 @ {(#myX:y:z: -> #x:y:z:)}.	"alias same as selector"
	self should: [ self t2 setTraitComposition: self t1 @ {(#m11 -> #m11)} ] raise: Error.	"same alias name used twice"
	self
		should: [ 
			self t2
				setTraitCompositionFrom:
					self t1
						@
							{(#alias -> #m11).
							(#alias -> #m12)} ]
		raise: Error.	"aliasing an alias"
	self
		should: [ 
			self t2
				setTraitCompositionFrom:
					self t1
						@
							{(#alias -> #m11).
							(#alias2 -> #alias)} ]
		raise: Error! !

!TraitCompositionTest methodsFor: 'tests - comparing' stamp: ''!
testSyntacticEqualsWithComplexCompositions

	self t3 compile: 'y ^$y'.
	self t3 compile: 'Y ^$Y'.

	self assert: ((self t1 + (self t2 - {#a. #b}) + (self t3 @ {#x -> #y})) 
		semanticallyEquals: (self t1 + (self t2 - {#a. #b}) + (self t3 @ {#x -> #y}))).
	self deny: ((self t1 + (self t2 - {#a. #b}) + (self t3 @ {#x -> #y})) 
		semanticallyEquals: (self t1 + (self t2 - {#A. #B}) + (self t3 @ {#X -> #Y}))).

	self t1 compile: 'y ^$y'.
	self t1 compile: 'w ^$w'.
	self t1 compile: 'c ^$c'.
	
	self assert: ((self t1 @ {#x -> #y} @ {#z -> #w} - {#a. #b} - {#c} + self t2) 
		semanticallyEquals: (self t1 @ {#x -> #y} @ {#z -> #w} - {#a. #b} - {#c} + self t2)).
	self deny: ((self t1 @ {#x -> #y} @ {#z -> #w} - {#a. #b} - {#c} + self t2) 
		semanticallyEquals: (self t1 @ {#x -> #y} @ {#z -> #w} - {#a. #b} - {#C} + self t2)).
! !

!TraitCompositionTest methodsFor: 'tests - basic' stamp: ''!
testCompositionFromArray
	| composition |
	composition := {self t1} asTraitComposition.
	self assert: (composition traits includes: self t1).
	self assert: composition traits size equals: 1.

	composition := {self t1 . self t2} asTraitComposition.
	self assert: (composition traits includes: self t1).
	self assert: (composition traits includes: self t2).
	self assert: composition traits size equals: 2! !

!TraitCompositionTest methodsFor: 'tests - basic' stamp: ''!
testPrinting
	| composition1 composition2 |
	composition1 := ((self t2 + self t1) @ { (#z -> #c) } - {#a. #b. #c } 
				+ self t3 - { #d. #e } 
				+ self t4).
	composition2 := self t4 @ { (#x -> #a). (#y -> #b) } + self t1 - { #a } 
				+ self t3 - { #d. #e } 
				+ self t2 - { #b. #c }.
	self assertPrints: composition1 printString
 		like:  '(((T2 + T1) @ {#z->#c}) - {#a. #b. #c} + T3) - {#d. #e} + T4'.
	self assertPrints: composition2 printString
		like:  '(((T4 @ {#x->#a. #y->#b} + T1) - {#a} + T3) - {#d. #e} + T2) - {#b. #c}'
		
		! !

!TraitCompositionTest methodsFor: 'tests - enquiries' stamp: ''!
testClassMethodsTakePrecedenceOverTraitsMethods
	| keys |
	keys := Set new.
	self t4 methodDict bindingsDo: [ :each | keys add: each key ].
	self assert: keys size equals: 6.
	self assert: (keys includesAll: #(#m12 #m13 #m13 #m21 #m22 #m11 #m42)).
	self assert: (self t4 methodDict at: #m11) sourceCode equals: 'm11 ^41'! !

!TraitCompositionTest methodsFor: 'tests - comparing' stamp: ''!
testSyntacticEqualsWithExclusion

	self t1 compile: 'a ^$a'.
	self t1 compile: 'b ^$b'.

	self assert: ((self t1 - {#a}) semanticallyEquals: (self t1 - {#a})).
	self deny: ((self t1 - {#a}) semanticallyEquals: (self t1 - {#b})).
	self assert: ((self t1 - {#a. #b}) semanticallyEquals: (self t1 - {#b. #a})).
	
	self assert: ((self t1 - {#a} - {#b}) semanticallyEquals: (self t1 - {#a} - {#b})).
	self assert: ((self t1 - {#a} - {#b}) semanticallyEquals: (self t1 - {#b} - {#a})).
! !

!TraitCompositionTest methodsFor: 'tests - comparing' stamp: ''!
testSyntacticEqualsWithAlias

	"To create a trait composition, it should be valid."
	self t1 compile: 'b ^$b'.
	self t1 compile: 'B ^$B'.
	self t1 compile: 'y ^$y'.

	self assert: ((self t1 @ {#a -> #b}) semanticallyEquals: (self t1 @ {#a -> #b})).
	self deny: ((self t1 @ {#a -> #b}) semanticallyEquals: self t1).
	self deny: ((self t1 @ {#a -> #b}) semanticallyEquals: (self t1 @ {#a -> #B})).
	self deny: ((self t1 @ {#a -> #b}) semanticallyEquals: (self t1 @ {#A -> #b})).

	self assert: ((self t1 @ {#a -> #b} @ {#x -> #y}) semanticallyEquals: (self t1 @ {#a -> #b} @ {#x -> #y})).
	self deny: ((self t1 @ {#a -> #b} @ {#x -> #y}) semanticallyEquals: (self t1 @ {#x -> #y} @ {#a -> #b})).! !

!TraitCompositionTest methodsFor: 'tests - basic' stamp: ''!
testSum
	| composition |
	composition := self t1 + self t2 + self t3.
	self assert: (composition isKindOf: TaSequence).
	self assert: (composition traits includes: self t1).
	self assert: (composition traits includes: self t2).
	self assert: (composition traits includes: self t3).
	self assert: composition traits size equals: 3! !

!TraitCompositionTest methodsFor: 'tests - basic' stamp: ''!
testInvalidComposition
	self t1 @ {(#a -> #b)} @ {(#x -> #y)}.
	self shouldnt: [ (self t1 + self t2) @ {(#a -> #b)} @ {(#x -> #y)}] raise: Error.
	self t1 - {#a} - {#b}.
	self t1 + self t2 - {#a} - {#b}.
	self shouldnt: [ (self t1 - {#x}) @ {(#a -> #b)} ] raise: Error.
	self shouldnt: [ (self t1 + self t2 - {#x}) @ {(#a -> #b)} ] raise: Error.
	self should: [ self t1 + self t1 ] raise: Error.
	self shouldnt: [ (self t1 + self t2) @ {(#a -> #b)} + self t1 ] raise: Error.
	self
		should: [ 
			self t1
				@
					{(#a -> #m11).
					(#a -> #m12)} ]
		raise: Error.
	self
		should: [ 
			self t1
				@
					{(#a -> #m11).
					(#b -> #a)} ]
		raise: Error! !

!TraitCompositionTest methodsFor: 'tests - basic' stamp: ''!
testSumWithParenthesis
	| composition |
	composition := self t1 + (self t2 + self t3).
	self assert: (composition traits includes: self t1).
	self assert: (composition traits includes: self t2).
	self assert: (composition traits includes: self t3).
	self assert: composition traits size equals: 3! !

!TraitCompositionTest methodsFor: 'tests - comparing' stamp: ''!
testSyntacticEqualsWithComposition

	self assert: ({} asTraitComposition semanticallyEquals: {} asTraitComposition).
	self deny: ({} asTraitComposition semanticallyEquals: self t1 asTraitComposition).

	self assert: (self t1 asTraitComposition semanticallyEquals: self t1 asTraitComposition).
	self deny: (self t1 asTraitComposition semanticallyEquals: self t2 asTraitComposition).
	
	self assert: ((self t1 + self t2) semanticallyEquals: (self t1 + self t2)).
	self deny: ((self t1 + self t2) semanticallyEquals: (self t1 + self t3)).
	self deny: ((self t1 + self t2) semanticallyEquals: (self t2 + self t1)).
	
	self assert: ((self t1 + self t2 + self t3) semanticallyEquals: (self t1 + self t2 + self t3)).
	self deny: ((self t1 + self t2 + self t3) semanticallyEquals: (self t3 + self t2 + self t1)).
! !

!TraitDescription commentStamp: ''!
This class is only kept for compatibility to load extension methods. Will be removed.
Check Trait for the new implementation of traits!
!TraitDescription methodsFor: '*Fuel-Tests-Core' stamp: ''!
duringTestCompileSilently: code classified: aCategory
	^ self 
		duringTestCompileSilently: code
		storeSource: true
		classified: aCategory! !

!TraitDescription methodsFor: '*Fuel-Tests-Core' stamp: ''!
duringTestCompileSilently: code storeSource: storeSource classified: aCategory
	^ FLPlatform current 
		useAuthor: 'TestsAuthor'
		during: [ [
			self 
				compile: code
				classified: (aCategory ifNil: [ '' ])
				withStamp: nil 
				notifying: nil 
				logSource: storeSource ] fuelValueWithoutNotifications ]! !

!TraitDescription methodsFor: '*Fuel-Tests-Core' stamp: ''!
duringTestCompileSilently: code
	^ self 
		duringTestCompileSilently: code 
		storeSource: true! !

!TraitDescription methodsFor: '*Fuel-Tests-Core' stamp: ''!
duringTestCompileSilently: code storeSource: storeSource
	^ self
		duringTestCompileSilently: code
		storeSource: storeSource
		classified: ''! !

!TraitExclusion commentStamp: ''!
It is kept for compatibility with extension methods
Check the class TaAbstractComposition for the new implementation.!
!TraitFileOutTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	self class environment organization addCategory: self categoryName.
	
	td := self createTraitNamed: #TD uses: {}.		
	td compile: 'd' classified: #cat1.
	tc := self createTraitNamed: #TC uses: td.		
	tc compile: 'c' classified: #cat1.
	tb := self createTraitNamed: #TB uses: td.		
	tb compile: 'b' classified: #cat1.
	ta := self createTraitNamed: #TA uses: tb + tc @ {#cc->#c} - {#c}.
	ta compile: 'a' classified: #cat1.
	
	ca := self createClassNamed: #CA superclass: Object uses: {}.
	ca compile: 'ca' classified: #cat1.
	cb := self createClassNamed: #CB superclass: ca uses: ta.
	cb compile: 'cb' classified: #cat1.
	
	"make the class of cb also use tc:"
	cb class uses: ta classTrait + tc instanceVariableNames: ''.! !

!TraitFileOutTest methodsFor: 'running' stamp: ''!
tearDown
	| dir |
	dir := FileSystem workingDirectory.
	self createdClassesAndTraits, self resourceClassesAndTraits  do: [:each |
		(dir / each asString,'st') ensureDelete ] .
	(dir / self categoryName,'st') ensureDelete.
	self class environment organization removeSystemCategory: self categoryName.
	"Ensure cleaning of obsoletes refs"
	ca := cb := ta := tb := tc := td := nil.
	super tearDown! !

!TraitFileOutTest methodsFor: 'tests' stamp: ''!
testFileOutCategory
	"File out whole system category, delete all classes and traits and then
	file them in again."

	self timeLimit: 30 seconds.
	self class environment organization fileOutCategory: self categoryName.
	self class environment organization removeSystemCategory: self categoryName.
	self deny: (testingEnvironment keys asSet includesAnyOf: #(#CA #CB #TA #TB #TC #TD)).
	
	CodeImporter evaluateFileNamed: (self categoryName , '.st').
	self assertCollection: testingEnvironment keys asSet includesAll: #(#CA #CB #TA #TB #TC #TD).
	ta := testingEnvironment at: #TA.
	self assert: ta traitComposition asString equals:  '((TB + TC) @ {#cc->#c}) - {#c}'.
	self assertCollection: ta selectors asSet includesAll: #(#a #b #cc).
	cb := testingEnvironment at: #CB.
	self assert: cb traitComposition asString equals: 'TA'.
	self assertCollection: cb selectors asSet includesAll: #(#cb #a #b #cc).	"test classSide traitComposition of CB"
	self assert: cb classSide traitComposition asString equals: 'TA classTrait + TC'.
	self assertCollection: cb classSide selectors asSet includesAll: #(#d #c)! !

!TraitFileOutTest methodsFor: 'tests' stamp: ''!
testFileOutTrait
	"fileOut trait T6, remove it from system and then file it in again"

	| fileName |
	self t6 compile: 'localMethod: argument ^argument'.
	self t6 classSide compile: 'localClassSideMethod: argument ^argument'.
	self t6 fileOut.
	fileName := self t6 asString , '.st'.
	self resourceClassesAndTraits remove: self t6.
	self t6 removeFromSystem.
	
	CodeImporter evaluateFileNamed: fileName.
	self assert: (testingEnvironment includesKey: #T6).
	TraitsResource current t6: (testingEnvironment at: #T6).
	self resourceClassesAndTraits add: self t6.
	self assert: self t6 traitComposition asString equals: 'T1 + (T2 @ {#m22Alias->#m22})'.
	self assertCollection: self t6 selectors asSet includesAll: #(#localMethod: #m11 #m12 #m13 #m21 #m22Alias).
	self assert: self t6 classSide localMethods size equals: 1.
	self assertCollection: self t6 classSide selectors asSet includesAll: #(#localClassSideMethod: #m2ClassSide:)! !

!TraitFileOutTest methodsFor: 'tests' stamp: ''!
testRecompiling

	| traitSrcPtr methodSrcPtr |
	
	traitSrcPtr := self t1 methods first sourcePointer.
	methodSrcPtr := self c1 methods first sourcePointer.
	
	self t1 recompile.
	self c1 recompile.
	
	self
		assert: traitSrcPtr equals: self t1 methods first sourcePointer;
		assert: methodSrcPtr equals: self c1 methods first sourcePointer
	! !

!TraitFileOutTest methodsFor: 'tests' stamp: ''!
testRemovingMethods
	"When removing a local method, assure that the method
	from the trait is installed instead and that the users are 
	updated."

	"Classes"
	self c2 compile: 'm12 ^0' classified: #xxx.
	self assert: (self c2 includesLocalSelector: #m12).
	self c2 removeSelector: #m12.
	self deny: (self c2 includesLocalSelector: #m12).
	self assert: (self c2 selectors includes: #m12).

	"Traits"
	self t5 compile: 'm12 ^0' classified: #xxx.
	self assert: self c2 new m12 equals: 0.
	self t5 removeSelector: #m12.
	self deny: (self t5 includesLocalSelector: #m12).
	self assert: (self t5 selectors includes: #m12).
	self assert: self c2 new m12 equals: 12! !

!TraitFileOutTest methodsFor: 'running' stamp: ''!
categoryName
	^'Traits-Tests-FileOut'! !

!TraitFileOutTest class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit
	
	^ 15 seconds! !

!TraitMethodDescription commentStamp: ''!
Used by Trait to encapsulates a collection of methods for one particular selector when querying for changes. According to the number and kind of those methods a provided method exists, there is a conflict or there are no provided nor conflicting methods at all. I provide the interface to query for those situations, e.g., effectiveMethod returns the provided method or the conflict marker method.
!
!TraitMethodDescription methodsFor: 'testing' stamp: ''!
isEmpty
	^self size = 0! !

!TraitMethodDescription methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	locatedMethods := IdentitySet new! !

!TraitMethodDescription methodsFor: 'accessing' stamp: ''!
selector
	^selector! !

!TraitMethodDescription methodsFor: 'accessing' stamp: ''!
providedLocatedMethod

	| locatedMethod aLocatedMethod refOrigin |

	locatedMethod := nil.
	self locatedMethods ifEmpty: [ ^ nil ].

	self locatedMethods size > 1
		ifTrue: [ aLocatedMethod := self locatedMethods anyOne.
			refOrigin := ( aLocatedMethod methodClass >> aLocatedMethod selector ) origin.
			( self locatedMethods allSatisfy: [ :each | each origin == refOrigin ] )
				ifTrue: [ ^ aLocatedMethod ]
			].

	self locatedMethods
		do: [ :each | 
			each isProvided
				ifTrue: [ locatedMethod ifNotNil: [ ^ nil ].
					locatedMethod := each
					]
			].
	^ locatedMethod! !

!TraitMethodDescription methodsFor: 'testing' stamp: ''!
isNotEmpty
	^self size > 0! !

!TraitMethodDescription methodsFor: 'testing' stamp: ''!
isBinarySelector
	^self locatedMethods anyOne
		isBinarySelector! !

!TraitMethodDescription methodsFor: 'accessing' stamp: ''!
locatedMethods
	^locatedMethods! !

!TraitMethodDescription methodsFor: 'private' stamp: ''!
generateMethod: aSelector withMarker: aSymbol forArgs: aNumber binary: aBoolean
	| source node keywords |
	source := String streamContents: [:stream |
		aNumber < 1
			ifTrue: [stream nextPutAll: aSelector]
			ifFalse: [aBoolean
				ifTrue: [
					stream nextPutAll: aSelector; space; nextPutAll: 'anObject']
				ifFalse: [
					keywords := aSelector keywords.
					1 to: aNumber do: [:argumentNumber |
						stream
							nextPutAll: (keywords at: argumentNumber); space;
							nextPutAll: 'arg'; nextPutAll: argumentNumber asString; space]]].
		stream cr; tab; nextPutAll: 'self '; nextPutAll: aSymbol].
	
	node := self class compiler
		source: source;
		class: self class;
		failBlock: [];
		parse.
	^(node generateWithSource) selector: aSelector; yourself! !

!TraitMethodDescription methodsFor: 'testing' stamp: ''!
isProvided
	^ self providedMethod notNil! !

!TraitMethodDescription methodsFor: 'enumeration' stamp: ''!
methodsDo: aBlock
	self locatedMethods do: [:each |
		aBlock value: each ]! !

!TraitMethodDescription methodsFor: 'accessing' stamp: ''!
addLocatedMethod: aLocatedMethod
	locatedMethods add: aLocatedMethod! !

!TraitMethodDescription methodsFor: 'accessing' stamp: ''!
providedMethod
	^self providedLocatedMethod ifNotNil: [:locatedMethod | locatedMethod method]! !

!TraitMethodDescription methodsFor: 'accessing' stamp: ''!
size
	^self locatedMethods size! !

!TraitMethodDescription methodsFor: 'accessing' stamp: ''!
selector: aSymbol 
	selector := aSymbol! !

!TraitMethodDescription methodsFor: 'testing' stamp: ''!
isLocalAliasSelector
	"Return true if the selector is an alias (if it is different
	from the original selector). Return false, if not or if we
	have a conflict."
	
	^self size = 1 and: [
		(self locatedMethods anyOne selector ~= self selector)]! !

!TraitMethodDescription methodsFor: 'accessing' stamp: ''!
conflictMethod
	| binary numberOfArguments |
	self isConflict ifFalse: [^nil].
	binary := self isBinarySelector.
	numberOfArguments := self numberOfArguments.
	
	^self
		generateMethod: self selector
		withMarker: CompiledMethod conflictMarker
		forArgs: numberOfArguments
		binary: binary! !

!TraitMethodDescription methodsFor: 'private' stamp: ''!
numberOfArguments
	^ self locatedMethods anyOne selector numArgs
		! !

!TraitMethodDescription methodsFor: 'accessing' stamp: ''!
effectiveMethodCategoryCurrent: currentCategoryOrNil new: newCategoryOrNil
	| result size isCurrent isConflict |
	size := self size.
	size = 0 ifTrue: [^ nil].
	result := self locatedMethods anyOne category.
	size = 1 ifTrue: [^ result].
	
	isCurrent := currentCategoryOrNil isNil.
	isConflict := false.
	self locatedMethods do: [:each | | cat |
		cat := each category.
		isCurrent := isCurrent or: [cat == currentCategoryOrNil].
		isConflict := isConflict or: [cat ~~ result]].
	isConflict ifFalse: [^ result].
	(isCurrent not and: [newCategoryOrNil notNil]) ifTrue: [^ newCategoryOrNil].
	
	^ Protocol ambiguous ! !

!TraitMethodDescription methodsFor: 'testing' stamp: ''!
isAliasSelector
	"Return true if the selector is an alias (if it is different
	from the original selector) or already an aliased method
	in the original location (recursively search the compositions).
	Return false, if not or if we have a conflict."
	
	| locatedMethod |
	^self size = 1 and: [
		locatedMethod := self locatedMethods anyOne.
		(locatedMethod selector ~= self selector) or: [
			locatedMethod methodClass isAliasSelector: self selector]]! !

!TraitMethodDescription methodsFor: 'testing' stamp: ''!
isConflict
	| count originMethodReferenciel |
	count := 0.

	self locatedMethods size > 1
		ifTrue: 
			["If they are more than 1 located method, then check whether these methods have the same origin"
			originMethodReferenciel := self locatedMethods anyOne  origin.
			(self locatedMethods allSatisfy: [:each | each origin == originMethodReferenciel])
				ifTrue: [ ^ false ]].

	self methodsDo: [:each |
		each isProvided ifTrue: [
			count := count + 1.
			count > 1 ifTrue: [^true]]].
	^false! !

!TraitMethodDescription methodsFor: 'testing' stamp: ''!
isRequired
	self isEmpty ifTrue: [^ false].
	^ self locatedMethods allSatisfy: [:each | each isRequired]! !

!TraitMethodDescription methodsFor: 'accessing' stamp: ''!
effectiveMethodCategory
	^ self effectiveMethodCategoryCurrent: nil new: nil! !

!TraitMethodDescription class methodsFor: 'instance creation' stamp: ''!
new
	^super new
		initialize;
		yourself! !

!TraitMethodDescription class methodsFor: 'instance creation' stamp: ''!
selector: aSymbol
	^self new
		selector: aSymbol
		yourself! !

!TraitMethodDescription class methodsFor: 'private' stamp: ''!
maxArguments
	^30! !

!TraitMethodDescriptionTest methodsFor: 'tests' stamp: ''!
testArgumentNames
	self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'.
	self t2 compile: 'zork1: myArgument zork2: somethingElse ^false'.
	self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString 
				beginsWith: 'zork1: arg1 zork2: arg2').
	self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'.
	self t2 compile: 'zork1: somethingElse zork2: myArgument ^false'.
	self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString 
				beginsWith: 'zork1: arg1 zork2: arg2')! !

!TraitMethodDescriptionTest methodsFor: 'tests' stamp: ''!
testCategories
	self assert: (self t4 organization categoryOfElement: #m21) equals: #cat1.
	self assert: (self t4 organization categoryOfElement: #m22) equals: #cat2.
	self assert: (self t4 organization categoryOfElement: #m11) equals: #catX.
	self assert: (self t4 organization categoryOfElement: #m12) equals: #cat2.
	self assert: (self t4 organization categoryOfElement: #m13) equals: #cat3.
	self assert: (self t6 organization categoryOfElement: #m22Alias) equals: #cat2.
	self t2 organization classify: #m22 under: #catX.
	self assert: (self t4 organization categoryOfElement: #m22) equals: #catX.
	self assert: (self t6 organization categoryOfElement: #m22Alias) equals: #catX.
	self t6 organization classify: #m22 under: #catY.
	self t6 organization classify: #m22Alias under: #catY.
	self t2 organization classify: #m22 under: #catZ.
	self assert: (self t6 organization categoryOfElement: #m22) equals: #catY.
	self assert: (self t6 organization categoryOfElement: #m22Alias) equals: #catY.
	self t1 compile: 'mA' classified: #catA.
	self assert: (self t4 organization categoryOfElement: #mA) equals: #catA.
	self t1 organization classify: #mA under: #cat1.
	self assert: (self t4 organization categories includes: #catA) not! !

!TraitMethodDescriptionTest methodsFor: 'tests' stamp: ''!
testConflictingCategories
	| t7 t8 |
	self t2 compile: 'm11' classified: #catY.
	self assert: (self t4 organization categoryOfElement: #m11) equals: #catX.
	self assert: (self t5 organization categoryOfElement: #m11) equals: Protocol ambiguous.
	t7 := self createTraitNamed: #T7 uses: self t1 + self t2.
	self assert: (t7 organization categoryOfElement: #m11) 
				equals: Protocol ambiguous.
	self t1 removeSelector: #m11.
	self assert: (self t4 organization categoryOfElement: #m11) equals: #catX.
	self assert: (self t5 organization categoryOfElement: #m11) equals: #catY.
	self assert: (t7 organization categoryOfElement: #m11) equals: #catY.
	self assert: (t7 organization categories includes: Protocol ambiguous) not.
	self t1 compile: 'm11' classified: #cat1.
	t8 := self createTraitNamed: #T8 uses: self t1 + self t2.
	t8 organization classify: #m11 under: #cat1.
	self t1 organization classify: #m11 under: #catZ.
	self assert: (self t4 organization categoryOfElement: #m11) equals: #catX.
	self assert: (self t5 organization categoryOfElement: #m11) equals: Protocol ambiguous.
	self assert: (t8 organization categoryOfElement: #m11) equals: #catZ! !

!TraitMethodDescriptionTest methodsFor: 'tests' stamp: ''!
testConflictMethodCreation
	"Generate conflicting methods between t1 and t2
	and check the resulting method in Trait t5 (or c2).
	Also test selectors like foo:x (without space) or selectors with CRs."

	"unary"

	self t2 compile: 'm12 ^false'.
	self assert: ((self t5 sourceCodeAt: #m12) asString beginsWith: 'm12').
	self should: [self c2 new m12] raise: Error.

	"binary"
	self t1 compile: '@ myArgument ^true'.
	self t2 compile: '@myArgument ^false'.
	self 
		assert: ((self t5 sourceCodeAt: #@) asString beginsWith: '@ anObject').
	self should: [self c2 new @ 17] raise: Error.

	"keyword"
	self t1 compile: 'zork: myArgument
		^true'.
	self t2 compile: 'zork: myArgument ^false'.
	self assert: ((self t5 sourceCodeAt: #zork:) asString 
				beginsWith: 'zork: arg1').
	self should: [self c2 new zork: 17] raise: Error.
	self t1 compile: 'zork:myArgument ^true'.
	self t2 compile: 'zork:myArgument ^false'.
	self assert: ((self t5 sourceCodeAt: #zork:) asString 
				beginsWith: 'zork: arg1').
	self should: [self c2 new zork: 17] raise: Error.
	self t1 compile: 'zork1: t1 zork2: t2 ^true'.
	self t2 compile: 'zork1: anObject zork2: anotherObject ^false'.
	self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString 
				beginsWith: 'zork1: arg1 zork2: arg2').
	self should: [self c2 new zork1: 1 zork2: 2] raise: Error! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testClassesWithTraits
	self assert: (self c1 methodDict includesKey: #foo).
	self assert: (self c2 methodDict includesKey: #bar).
	self assert: (self c2 methodDict includesKey: #m51).
	self assert: (self c2 methodDict includesKey: #m12).
	self assert: (self c2 methodDict includesKey: #m13).
	self assert: (self c2 methodDict includesKey: #m21).
	self assert: (self c2 methodDict includesKey: #m22).

	self deny: self c1 class hasTraitComposition.
	self assert: self c2 class hasTraitComposition.

	self assert: self c2 class traitComposition traits size equals: 1.
	self assert: (self c2 class traitComposition includesTrait: self t5 classTrait)! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testReshapeClass
	"Ensure that reshaping a class has no impact on its traits"

	self assert: self c2 traitCompositionString equals: 'T5 - {#m11}'.
	self assert: self c2 selectors sorted equals: #(bar foo m12 m13 m21 m22 m51 m52 m53).
	self assert: self c2 localSelectors sorted equals: #(bar foo).

	self c2 addInstVarNamed: 'foobar'.

	self assert: self c2 traitCompositionString equals: 'T5 - {#m11}'.
	self assert: self c2 selectors sorted equals: #(bar foo m12 m13 m21 m22 m51 m52 m53).
	self assert: self c2 localSelectors sorted equals: #(bar foo).

	self c2 removeInstVarNamed: 'foobar'.

	self assert: self c2 traitCompositionString equals: 'T5 - {#m11}'.
	self assert: self c2 selectors sorted equals: #(bar foo m12 m13 m21 m22 m51 m52 m53).
	self assert: self c2 localSelectors sorted equals: #(bar foo).! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testTraitCompositionWithCycles
	self should: [self t1 setTraitComposition: self t1 asTraitComposition]
		raise: Error.
	self t2 setTraitComposition: self t3 asTraitComposition.
	self should: [self t3 setTraitComposition: self t5 asTraitComposition]
		raise: Error! !

!TraitPureBehaviorTest methodsFor: 'tests' stamp: ''!
testIsLocalAliasSelector
	self deny: (self t1 isLocalAliasSelector: #m11).
	self deny: (self t1 isLocalAliasSelector: #foo).

	"directly"
	self assert: (self t6 isLocalAliasSelector: #m22Alias).
	self deny: (self t6 isLocalAliasSelector: #m22).

	"indirectly"
	self c1 setTraitComposition: self t6 asTraitComposition.
	self deny: (self c1 isLocalAliasSelector: #m22Alias).
	self deny: (self c1 isLocalAliasSelector: #m22)! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testUpdateWhenLocalMethodRemoved
	| aC2 |
	aC2 := self c2 new.
	self t5 compile: 'foo ^123'.
	self deny: aC2 foo.
	self c2 removeSelector: #foo.
	self assert: aC2 foo equals: 123! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testTraitCompositionModifications
	self assert: self t6 methodDict size equals: 6.
	self assert: (self t6 sourceCodeAt: #m22Alias) asString equals: 'm22Alias ^22'.

	self t6 setTraitComposition: self t2 asTraitComposition.
	self assert: self t6 methodDict size equals: 2.
	self deny: (self t6 methodDict includesKey: #m22Alias).

	self t6 setTraitComposition: self t1 @ {(#m13Alias -> #m13)} - {#m11 . #m12} + self t2.
	self assert: self t6 methodDict size equals: 4.
	self assert: (self t6 selectors asSet includesAll: #(#m13Alias #m21 #m22)).
	self assert: (self t6 sourceCodeAt: #m13Alias) asString equals: 'm13Alias ^self m12'! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testPropagationWhenTraitCompositionModifications
	"Test that the propagation mechanism works when
	setting new traitCompositions."

	self assert: self c2 methodDict size equals: 9.	"2 + (3+(3+2))-1"

	"removing methods"
	self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #T5;
			traitComposition: self t1 + self t2 - {#m21 . #m22};
			package: self class category;
			beTrait ].

	self assert: self c2 methodDict size equals: 7.

	"adding methods"
	self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #T2;
			traitComposition: self t3 asTraitComposition;
			package: self class category;
			beTrait ].

	self assert: self c2 methodDict size equals: 10.
	self assert: (self c2 selectors asSet includesAll: #(#m31 #m32 #m33))! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded
	"Assert that alias method is updated although
	the original method is excluded from this user."

	| anObject |
	anObject := (self createClassNamed: #AliasTestClass superclass: Object uses: self t1 @ {(#aliasM11 -> #m11)} - {#m11}) new.
	self assert: anObject aliasM11 equals: 11.
	self deny: (anObject class methodDict includesKey: #m11).
	self t1 compile: 'm11 ^17'.
	self assert: anObject aliasM11 equals: 17! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testPropagationOfChangesInTraitsToAliasMethods
	| anObject |
	anObject := (self createClassNamed: #AliasTestClass superclass: Object uses: self t6) new.
	self assert: anObject m22Alias equals: 22.

	"test update alias method"
	self t2 compile: 'm22 ^17'.
	self assert: anObject m22Alias equals: 17.

	"removing original method should also remove alias method"
	self t2 removeSelector: #m22.
	self should: [ anObject m22Alias ] raise: MessageNotUnderstood! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testSuperSends

	| aC2 |
	aC2 := self c2 new.
	self assert: aC2 m51.
	self deny: aC2 foo.
	self deny: aC2 bar! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testPropagationOfChangesInTraits
	| aC2 |
	aC2 := self c2 new.
	self assert: self c2 methodDict size equals: 9.
	self t1 compile: 'zork ^false'.
	self assert: self c2 methodDict size equals: 10.
	self deny: aC2 zork.
	self t1 removeSelector: #m12.
	self assert: self c2 methodDict size equals: 9.
	self should: [ aC2 m12 ] raise: MessageNotUnderstood.
	self assert: aC2 m21 equals: 21.
	self t2 compile: 'm21 ^99'.
	self assert: aC2 m21 equals: 99! !

!TraitPureBehaviorTest methodsFor: 'tests' stamp: ''!
testLocalSelectors

	self assert: self t3 localSelectors size equals: 3.
	self assert: (self t3 localSelectors includesAll: #(#m31 #m32 #m33 )).
	self assert: (self t3 includesLocalSelector: #m32).
	self deny: (self t3 includesLocalSelector: #inexistantSelector).
	self assert: self t5 localSelectors size equals: 3.
	self assert: (self t5 localSelectors includes: #m51).
	self assert: (self t5 includesLocalSelector: #m51).
	self deny: (self t5 includesLocalSelector: #m11).
	self t5 removeSelector: #m51.
	self deny: (self t3 includesLocalSelector: #m51).
	self deny: (self t5 includesLocalSelector: #m11).
	self assert: self t5 localSelectors size equals: 2.
	self t5 compile: 'm52 ^self'.
	self assert: self t5 localSelectors size equals: 2.
	self assert: (self t5 localSelectors includes: #m52).

	"test that propagated methods do not get in as local methods"
	self t2 compile: 'local2 ^self'.
	self deny: (self t5 includesLocalSelector: #local2).
	self assert: self t5 localSelectors size equals: 2.
	self assert: (self t5 localSelectors includes: #m52).
	self assert: self c2 localSelectors size equals: 2.
	self assert: (self c2 localSelectors includesAll: #(#foo #bar ))! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testMethodClass
	"Test sharing of compiled methods between traits and their users. Methods are installed in exactly one behavior, however, the source pointers of methods are shared (unless sources or changes have been condensed). Verify	that methodClass properties are set correctly."

	| m1 m2 |
	m1 := self t5 >> #m51.
	m2 := self c2 >> #m51.

	self assert: m1 methodClass identicalTo: self t5.
	self assert: m2 methodClass identicalTo: self c2.

	self deny: m1 identicalTo: m2.

	self assert: m1 sourcePointer equals: m2 sourcePointer! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testOwnMethodsTakePrecedenceOverTraitsMethods
	"First create a trait with no subtraits and then
	add subtrait t1 which implements m11 as well."

	| trait |
	trait := self createTraitNamed: #T uses: {}.
	trait compile: 'm11 ^999'.
	self assert: trait methodDict size equals: 1.
	self assert: (trait methodDict at: #m11) sourceCode equals: 'm11 ^999'.

	self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #T;
			traitComposition: self t1 asTraitComposition;
			package: self class category;
			beTrait ].			

	self assert: trait methodDict size equals: 3.
	self assert: (trait selectors asSet includesAll: #(#m11 #m12 #m13)).
	self assert: (trait methodDict at: #m11) sourceCode equals: 'm11 ^999'.
	self assert: (trait methodDict at: #m12) sourceCode equals: 'm12 ^12'! !

!TraitPureBehaviorTest methodsFor: 'tests' stamp: ''!
testMethodCategoryReorganization

	self t1 compile: 'm1' classified: 'category1'.
	self assert: (self t5 organization categoryOfElement: #m1) equals: #category1.
	self assert: (self c2 organization categoryOfElement: #m1) equals: #category1.
	self t1 organization 
		classify: #m1
		under: #category2
		suppressIfDefault: true.
	self assert: (self t5 organization categoryOfElement: #m1) equals: #category2.
	self assert: (self c2 organization categoryOfElement: #m1) equals: #category2! !

!TraitPureBehaviorTest methodsFor: 'tests - applying trait composition' stamp: ''!
testChangeSuperclass
	"Test that when the superclass of a class is changed the non-local methods
	of the class sending super are recompiled to correctly store the new superclass."

	| aC2 newSuperclass |
	aC2 := self c2 new.

	"C1 is current superclass of C2"
	self assert: aC2 m51.
	self assert: self c2 superclass identicalTo: self c1.
	self deny: (self c2 localSelectors includes: #m51).
	self deny: self c2 >> #m52 identicalTo: self t5 >> #m52.	"no sharing!!!!"

	self assert: self c2 traitCompositionString equals: 'T5 - {#m11}'.
	self assert: self c2 selectors sorted equals: #(bar foo m12 m13 m21 m22 m51 m52 m53).
	self assert: self c2 localSelectors sorted equals: #(bar foo).

	"change superclass of C2 from C1 to X"
	newSuperclass := self createClassNamed: #X superclass: Object uses: {}.

	self class classInstaller make: [ :aBuilder |
		aBuilder name: self c2 name;
			superclass: newSuperclass;
			traitComposition: self c2 traitComposition asTraitComposition;
			package: self c2 category ].		


	self assert: self c2 superclass identicalTo: newSuperclass.

	newSuperclass compile: 'foo ^17'.
	self assert: aC2 m51 equals: 17.
	self deny: (self c2 localSelectors includes: #m51).

	self c2 compile: 'm51 ^19'.
	self assert: aC2 m51 equals: 19.

	self deny: self c2 >> #m52 identicalTo: self t5 >> #m52.	"no sharing!!!!"

	self assert: self c2 traitCompositionString equals: 'T5 - {#m11}'.
	self assert: self c2 selectors sorted equals: #(bar foo m12 m13 m21 m22 m51 m52 m53).
	self assert: self c2 localSelectors sorted equals: #(bar foo m51).

	"change superclass of C2 back to C1"		
	self class classInstaller make: [ :aBuilder |
		aBuilder name: self c2 name;
			superclass: self c1;
			traitComposition: self c2 traitComposition asTraitComposition;
			package: self c2 category ].		

	self assert: aC2 m51 equals: 19.
	self assert: self c2 superclass identicalTo: self c1.
	self assert: (self c2 localSelectors includes: #m51).
	self deny: self c2 >> #m52 identicalTo: self t5 >> #m52.	"no sharing!!!!"

	self assert: self c2 traitCompositionString equals: 'T5 - {#m11}'.
	self assert: self c2 selectors sorted equals: #(bar foo m12 m13 m21 m22 m51 m52 m53).
	self assert: self c2 localSelectors sorted equals: #(bar foo m51)! !

!TraitPureBehaviorTest methodsFor: 'tests' stamp: ''!
testTraitsAccessor
	self assertEmpty: self c1 traits.
	self assert: (self c2 traits hasEqualElements: (Array with: self t5))! !

!TraitPureBehaviorTest methodsFor: 'tests' stamp: ''!
traitOrClassOfSelector

	"locally defined in trait or class"
	self assert: (self t1 traitOrClassOfSelector: #m12) equals: self t1.
	self assert: (self c1 traitOrClassOfSelector: #foo) equals: self c1.

	"not locally defined - simple"
	self assert: (self t4 traitOrClassOfSelector: #m21) equals: self t2.
	self assert: (self c2 traitOrClassOfSelector: #m51) equals: self t5.

	"not locally defined - into nested traits"
	self assert: (self c2 traitOrClassOfSelector: #m22) equals: self t2.

	"not locally defined - aliases"
	self assert: (self t6 traitOrClassOfSelector: #m22Alias) equals: self t2.

	"class side"
	self assert: (self t2 classSide traitOrClassOfSelector: #m2ClassSide:) 
		  equals: self t2 classSide.
	self assert: (self t6 classSide traitOrClassOfSelector: #m2ClassSide:) 
		  equals: self t2 classSide! !

!TraitPureBehaviorTest methodsFor: 'tests' stamp: ''!
testIsAliasSelector
	self deny: (self t1 isAliasSelector: #m11).
	self deny: (self t1 isAliasSelector: #foo).

	"directly"
	self assert: (self t6 isAliasSelector: #m22Alias).
	self deny: (self t6 isAliasSelector: #m22).

	"indirectly"
	self c1 setTraitComposition: self t6.
	self assert: (self c1 isAliasSelector: #m22Alias).
	self deny: (self c1 isAliasSelector: #m22)! !

!TraitPureBehaviorTest methodsFor: 'tests' stamp: ''!
testRemovingMethods
	"When removing a local method, assure that the method
	from the trait is installed instead and that the users are 
	updated."

	"Classes"
	self c2 compile: 'm12 ^0' classified: #xxx.
	self assert: (self c2 includesLocalSelector: #m12).
	self c2 removeSelector: #m12.
	self deny: (self c2 includesLocalSelector: #m12).
	self assert: (self c2 selectors includes: #m12).

	"Traits"
	self t5 compile: 'm12 ^0' classified: #xxx.
	self assert: self c2 new m12 equals: 0.
	self t5 removeSelector: #m12.
	self deny: (self t5 includesLocalSelector: #m12).
	self assert: (self t5 selectors includes: #m12).
	self assert: self c2 new m12 equals: 12! !

!TraitTest methodsFor: 'tests' stamp: ''!
testTraitRemoval
	SystemAnnouncer uniqueInstance
		suspendAllWhile: [ | aClass aTrait |
			[ aTrait := self createTrait.
			aClass := self createClassUsing: aTrait.
			self assertEmpty: aClass localSelectors.
			aClass removeFromComposition: aTrait.
			self assertEmpty: aClass localSelectors.
			self assertEmpty: aClass organization allMethodSelectors.
			self deny: aClass hasTraitComposition.
			self deny: (aTrait traitUsers includes: aClass) ]
				ensure: [ aClass removeFromSystem: false.
					aTrait removeFromSystem: false ] ]! !

!TraitTest methodsFor: 'tests' stamp: ''!
testRemoveFromSystem
	SystemAnnouncer uniqueInstance
		suspendAllWhile: [ 
			| aClass aTrait |
			[ 
			aTrait := self createTrait.
			aClass := self createClassUsing: aTrait.
			aTrait removeFromSystem: false.
			self deny: aClass hasTraitComposition.
			self assert: aTrait isObsolete. ]
				ensure: [ aClass removeFromSystem: false ] ]! !

!TraitTest methodsFor: 'tests' stamp: ''!
testAllClassVarNames
	self assertEmpty: self t1 allClassVarNames! !

!TraitTest methodsFor: 'tests' stamp: ''!
testExplicitRequirementInClassAlwaysTakesPrecedence
	"If i create an explicit requirement method on a class, and the superclass already have the method (non explicit requirement), the class should raise an exception"

	self c10 compile: 'm ^111'.
	self c11 compile: 'm ^self explicitRequirement'.
	self should: [ self c11 new m ] raise: Error! !

!TraitTest methodsFor: 'tests' stamp: ''!
testForbidInstantiation
	| tmpCategory trait |
	tmpCategory := 'TemporaryGeneratedClasses'.

	trait := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #TMyTrait;
			package: tmpCategory;
			beTrait ].

	self should: [ trait basicNew ] raise: Error ! !

!TraitTest methodsFor: 'utilities' stamp: ''!
createClassUsing: aTrait
	
	^ self class classInstaller make: [ :aBuilder |
		aBuilder name: #AClassForTests;
			traitComposition: aTrait asTraitComposition;
			package: 'AAA' ].! !

!TraitTest methodsFor: 'tests' stamp: ''!
testErrorClassCreation
    | tmpCategory trait aSubclass aClass |
	
    tmpCategory := 'TemporaryGeneratedClasses'.

	 trait := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #TMyTrait;
			package: tmpCategory;
			beTrait ].

    
    [ 
		aClass := self class classInstaller make: [ :aClassBuilder | 
			aClassBuilder 
				name: #AClass;
				superclass: nil;
				package: tmpCategory ].

	"----------------"
		aSubclass := self class classInstaller make: [ :aClassBuilder | 
			aClassBuilder 
				name: #AClass2;
				traitComposition: trait asTraitComposition;
				superclass: aClass;
				package: tmpCategory ].
 
	"----------------"

    "Change the superclass of AClass"
		aClass := self class classInstaller make: [ :aClassBuilder | 
			aClassBuilder 
				name: #AClass;
				superclass: Object;
				package: tmpCategory ].
        
    self assert: trait traitUsers asArray equals: {aSubclass}.
    self assert: aSubclass traits asArray equals: {trait}. 

    ] ensure: [
        #(AClass AClass2 TMyTrait) do: [ :aClassName |
            testingEnvironment at: aClassName ifPresent: [ :v | v removeFromSystem ]]]! !

!TraitTest methodsFor: 'tests' stamp: ''!
testExplicitRequirementWithSuperclassImplementatiosAlwaysReturnsTheCorrectValue
	"Make sure that an explicitRequirement method from a trait that is overrided by a method on a superclass always returns the value from the class defined method, even when an explict return from the trait defined method is missing."

	"C9 inherits from Object. C10 inherits from C9.  Each Ci uses the trait Ti."

	self t10 compile: 'm1 ^self explicitRequirement'.
	self t10 compile: 'm2 self explicitRequirement'.
	self t9 compile: 'm1 ^2'.
	self t9 compile: 'm2 ^2'.
	
	self assert: self c10 new m1 equals: 2.
	self assert: self c10 new m2 equals: 2.! !

!TraitTest methodsFor: 'tests' stamp: ''!
testPrintingClassSide
	
	self 
		assertPrints: (ClassDefinitionPrinter oldPharo for: self t6 classSide) definitionString like: 'T6 classTrait
	uses: T1 classTrait + T2 classTrait
	instanceVariableNames: '''''
! !

!TraitTest methodsFor: 'tests' stamp: ''!
testExplicitRequirement
	self t1 compile: 'm self explicitRequirement'.
	self t2 compile: 'm ^true'.
	self deny: self t4 >> #m identicalTo: self t2 >> #m.
	self assert: self c2 new m.
	self t2 removeSelector: #m.
	self deny: self t5 >> #m identicalTo: self t1 >> #m.
	self should: [ self c2 new m ] raise: Error! !

!TraitTest methodsFor: 'tests' stamp: ''!
testOriginWithRequiredMethod
	| tr1 c1 |
	tr1 := self createTraitNamed: #TTT1 uses: {}.

	tr1 compile: 'foo ^ self explicitRequirement'.
	self assert: (tr1 >> #foo) origin identicalTo: tr1.

	c1 := self createClassNamed: #CTT1 superclass: Object uses: tr1.
	self assert: (c1 >> #foo) origin identicalTo: tr1! !

!TraitTest methodsFor: 'tests' stamp: ''!
testIsRootInEnvironment
	self assert: self t1 isRootInEnvironment.
	self assert: self t2 isRootInEnvironment! !

!TraitTest methodsFor: 'tests' stamp: ''!
testTraitCompositionRespectsParenthesis
	self t1 compile: 'method ^1234'.
	self t2 compile: 'method ^4'.
	self c1 setTraitComposition: self t1 + self t2 - #method.
	self should: [ self c1 new method ] raise: MessageNotUnderstood.
	self c1 setTraitComposition: self t1 + (self t2 - #method).
	self c1 new method.
	self assert: self c1 new method equals: 1234! !

!TraitTest methodsFor: 'tests' stamp: ''!
testCompositionCopy
 
	self assert: (self t1 + self t2) allTraits 
				equals: (self t1 + self t2) copyTraitExpression allTraits.
	self assert: (self t1 classTrait + self t2 classTrait) allTraits 
				equals: (self t1 classTrait + self t2 classTrait) copyTraitExpression allTraits.
	self assert: self t6 traitComposition allTraits 
				equals: self t6 traitComposition copyTraitExpression allTraits.
	self assert: (self t6 asTraitComposition copyTraitExpression allTraits 
				includesAll: { (self t1). (self t2). (self t6) }).! !

!TraitTest methodsFor: 'tests' stamp: ''!
testExplicitRequirementWithSuperclassImplementationAndAnotherTrait
	"Make sure that an explicitRequirement method from a trait does not take precedence over a superclass implementation."

	"The previous should still be true even in the presence of a superclass importing another explicitRequirement method."

	"C9 inherits from Object. C10 inherits from C9. C11 inherits from C10. Each Ci uses the trait Ti."

	self t10 compile: 'm ^self explicitRequirement'.
	self t11 compile: 'm ^self explicitRequirement'.
	self should: [ self c10 new m ] raise: Error.
	self should: [ self c11 new m ] raise: Error.
	self t9 compile: 'm ^2'.
	self assert: self c9 new m equals: 2.
	self assert: self c10 new m equals: 2.
	self assert: self c11 new m equals: 2! !

!TraitTest methodsFor: 'tests' stamp: ''!
testUsers
	self assert: self t1 traitUsers size equals: 3.
	self assert: (self t1 traitUsers includesAll: {self t4 . self t5 . self t6}).
	self assertEmpty: self t3 traitUsers.
	self assert: self t5 traitUsers size equals: 1.
	self assert: self t5 traitUsers anyOne equals: self c2.
	self c2 setTraitComposition: self t1 + self t5.
	self assert: self t5 traitUsers size equals: 1.
	self assert: self t5 traitUsers anyOne equals: self c2.
	self c2 setTraitComposition: self t2 asTraitComposition.
	self assertEmpty: self t5 traitUsers! !

!TraitTest methodsFor: 'tests' stamp: ''!
testAddAndRemoveMethodsFromSubtraits
	| aC2 |
	aC2 := self c2 new.
	self assert: aC2 m51.
	self t5 removeSelector: #m51.
	self should: [ aC2 m51 ] raise: MessageNotUnderstood.
	self t1 compile: 'foo ^true'.
	self deny: aC2 foo.
	self t1 compile: 'm51 ^self'.
	aC2 m51.
	self assert: aC2 m51 identicalTo: aC2! !

!TraitTest methodsFor: 'tests' stamp: ''!
testAddAndRemoveMethodsInClassOrTrait
	| aC2 |
	aC2 := self c2 new.
	self assert: aC2 m51.
	self c2 compile: 'm51 ^123'.
	self assert: aC2 m51 equals: 123.
	self c2 removeSelector: #m51.
	aC2 m51.
	self assert: aC2 m51.
	self t4 removeSelector: #m11.
	self assert: (self t4 includesSelector: #m11)! !

!TraitTest methodsFor: 'tests' stamp: ''!
testMarkerMethods
	self t1 compile: 'm1 self foo bar'.
	self assert: (self t1 >> #m1) markerOrNil isNil.

	self t1 compile: 'm2 self explicitRequirement'.
	self assert: (self t1 >> #m2) markerOrNil identicalTo: #explicitRequirement! !

!TraitTest methodsFor: 'tests' stamp: ''!
testExplicitRequirementDoesNotTakePrecedenceEvenWhenAddingTraits
	"Make sure that an explicitRequirement method from a trait does not take precedence over a superclass implementation, even if he trait is created later."

	| tempClass tempTrait |
	self c9 compile: 'm ^100'.
	tempTrait := self createTraitNamed: #TTempTrait uses: {}.
	tempTrait compile: 'm ^self explicitRequirement.'.
	tempClass := self createClassNamed: #TempClass superclass: self c9 uses: {tempTrait}.
	self assert: tempClass new m equals: 100! !

!TraitTest methodsFor: 'tests' stamp: ''!
testExplicitRequirementDoesNotTakePrecedenceInDeepHierarchy
	"Make sure that an explicitRequirement method from a trait does not take precedence over a superclass implementation, even if the superclass implementation is not just in the direct superclass."

	"C9 inherits from Object. C10 inherits from C9. C11 inherits from C10. Each Ci uses the trait Ti."

	self t11 compile: 'm ^self explicitRequirement'.
	self should: [ self c11 new m ] raise: Error.
	self t9 compile: 'm ^2'.
	self c9 new m.
	self c10 new m.
	self c11 new m.
	self assert: self c9 new m equals: 2.
	self assert: self c10 new m equals: 2.
	self assert: self c11 new m equals: 2! !

!TraitTest methodsFor: 'tests' stamp: ''!
testTraitsUsersSanity
	"This documents bug http://code.google.com/p/pharo/issues/detail?id=443"
		
	Smalltalk allClassesAndTraits do: [ :each |
		self assert: (each traits allSatisfy: [ :t | t traitUsers includes: each  ]) ].

	Smalltalk allTraits do: [ :each |
		self assert: (each traitUsers allSatisfy: [ :b | b traits includes: each ]) ]! !

!TraitTest methodsFor: 'tests' stamp: ''!
testComposedBy
	"tests the #isComposedBy: aTrait method"
	
	self assert: (Trait3 isComposedBy: Trait2).
	self deny: (Trait2 isComposedBy: Trait3).
	self deny: (Trait3 isComposedBy: Object).
	! !

!TraitTest methodsFor: 'tests' stamp: ''!
testUsersWithClassChanges
	"This documents bug http://code.google.com/p/pharo/issues/detail?id=443"

	"self debug: #testUsersWithClassChanges"

	self c2 setTraitComposition: self t5 asTraitComposition.
	self assert: self t5 traitUsers size equals: 1.
	self assert: self t5 classSide traitUsers size equals: 1.
	self assert: self c2 traits size equals: 1.
	self assert: self c2 class traits size equals: 1.

	"Change class definition"
	self c2 addInstVarNamed: 'foo'.
	self assert: self t5 traitUsers size equals: 1.
	self assert: self t5 classSide traitUsers size equals: 1.
	self assert: self c2 traits size equals: 1.
	self assert: self c2 class traits size equals: 1.

	"Change metaclass definition"
	self c2 class instanceVariableNames: 'bar'.
	self assert: self t5 traitUsers size equals: 1.
	self assert: self t5 classSide traitUsers size equals: 1.
	self assert: self c2 traits size equals: 1.
	self assert: self c2 class traits size equals: 1! !

!TraitTest methodsFor: 'tests' stamp: ''!
testIsUsed

	self assert: Trait1 isUsed.
	self assert: Trait1 classTrait isUsed.
! !

!TraitTest methodsFor: 'tests' stamp: ''!
testExplicitRequirementTakesPrecedenceOverTraitImplementation
	"If i create an explicit requirement method on a trait, the method has to be explicit requirement "
	self t12 compile: 'm ^11'.
	self t11 compile: 'm ^self explicitRequirement'.
	
	self should: [ self c11 new m ] raise: Error.
	
	"If i create an explicit requirement method on a class, and the superclass already have the method (non explicit requirement), the class should raise an exception"
	self c10 compile: 'm ^111'.
	self c11 compile: 'm ^self explicitRequirement'.
	self should: [ self c11 new m ] raise: Error.
	
	! !

!TraitTest methodsFor: 'utilities' stamp: ''!
createTrait
	| trait |

	trait := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: #ATraitForTests;
			package: 'AAA';
			beTrait ].

	trait compile: 'm1 ^1' classified: 'test'.
	^ trait! !

!TraitTest methodsFor: 'tests' stamp: ''!
testPrinting

	self assertPrints: (ClassDefinitionPrinter oldPharo for: self t6) definitionString like: 'Trait named: #T6
	uses: T1 + (T2 @ {#m22Alias->#m22})
	instanceVariableNames:''''
	package: ''Tests-Traits'''! !

!TraitTest methodsFor: 'tests' stamp: ''!
testExplicitRequirementWithSuperclassImplementation
	"Make sure that an explicitRequirement method from a trait does not take precedence over a superclass implementation."

	self t10 compile: 'm ^self explicitRequirement'.
	self should: [ self c10 new m ] raise: Error.
	self c9 compile: 'm ^123'.
	self assert: self c10 new m equals: 123.
	self c9 removeSelector: #m.
	self t10 removeSelector: #m.	"The previous is still true even if we compile the superclass method before the trait method."
	self c9 compile: 'm ^123'.
	self t10 compile: 'm ^self explicitRequirement'.
	self c10 new m.
	self c9 removeSelector: #m.
	self should: [ self c10 new m ] raise: Error.
	self t10 removeSelector: #m! !

!TraitTest methodsFor: 'tests' stamp: ''!
testOrigin
	| tr1 tr2 tr3 tr23 |
	tr1 := self createTraitNamed: #TTT1 uses: {}.
	tr2 := self createTraitNamed: #TTT2 uses: {tr1}.
	tr3 := self createTraitNamed: #TTT3 uses: {tr1}.
	tr23 := self createTraitNamed: #TTT23 uses: {(tr3 + tr2)}.

	tr1 compile: 'foo ^ 4'.
	self assert: (tr1 >> #foo) origin identicalTo: tr1.
	self assert: (tr2 >> #foo) origin identicalTo: tr1.
	self assert: (tr3 >> #foo) origin identicalTo: tr1.

	"-----------"
	"For TR2"

	self assert: (tr2 traitComposition traitDefining: #foo) innerClass identicalTo: tr1.
	self assert: (tr2 >> #foo) origin identicalTo: tr1.
	"-----------"

	"-----------"
	"For TR23"

	self assert: (tr23 traitComposition traitDefining: #foo) innerClass identicalTo: tr1.
	self assert: (tr23 >> #foo) origin identicalTo: tr1
	"----------"! !

!TraitTest methodsFor: 'tests' stamp: ''!
testLocalMethodWithSameCodeInTrait
	"Test whether there are no unintentional overridden traits methods"

	SystemNavigation new
		allBehaviorsDo: [ :each | 
			each hasTraitComposition
				ifTrue: [ each
						selectorsDo: [ :selector | 
							(each includesLocalSelector: selector)
								ifTrue: [ (each traitComposition traitDefining: selector ifNone: [ nil ])
										ifNotNil: [ :trait | (trait selectors includes: selector) ifTrue: [ self deny: (trait compiledMethodAt: selector) equals: each >> selector ] ] ] ] ] ]! !

!TraitTest methodsFor: 'tests' stamp: ''!
testTraitsMethodClassSanity
		
	(testingEnvironment allTraits flatCollect: #traitUsers) asSet do: [ :each |
		each selectorsDo: [ :selector |
			self should: [ (each >> selector) methodClass == each ] ] ]! !

!TraitTest methodsFor: 'tests' stamp: ''!
testOriginWithRequiredMethodInTraitChain
	"check that the origin of a explicit requirement is the trait defining this method, even if we check
this from another *trait* using the first trait. Tr2 uses Tr1, Tr1 defines a explicit requirement #foo, the
origin of Tr2>>foo is Tr1"

	| tr1 tr2 |
	tr1 := self createTraitNamed: #TTT1 uses: {}.
	tr1 compile: 'foo ^ self explicitRequirement'.
	self assert: (tr1 >> #foo) origin identicalTo: tr1.
	tr2 := self createTraitNamed: #TTT2 uses: {tr1}.
	self assert: (tr2 >> #foo) origin identicalTo: tr1! !

!TraitTransformation commentStamp: ''!
It is kept for compatibility with extension methods
Check the class TaAbstractComposition for the new implementation.!
!TraitedClass commentStamp: ''!
I contain the methods that are included in a TraitedClass.
The Traits are also TraitedClass, as they share the same behavior.
These methods override the implementation in Class 
I am added during the creation of the class, if the superclass does not have them.

Check 

TraitedMetaclass >> #initializeBasicMethods 

This method is invoked during the construction of the class, and flattens my methods in the new traited class.!
!TraitedClass methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TraitedClass methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TraitedClass methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TraitedClass methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TraitedClass methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TraitedClass methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TraitedClass methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TraitedClass methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TraitedClass methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TraitedClass methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TraitedClass methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!TraitedClass methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!TraitedClass methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TraitedClass methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!TraitedClass methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TraitedClass methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TraitedClass methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TraitedClass methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TraitedClass methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TraitedClass methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TraitedClass methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TraitedClass methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TraitedClass methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TraitedClass methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TraitedClass methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TraitedClass methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TraitedClass methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TraitedClass methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TraitedClass methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TraitedClass class methodsFor: 'users' stamp: ''!
traitUsers
	^ #()! !

!TraitedClass class methodsFor: 'users' stamp: ''!
basicUsers
	^ users ifNil: [ users := WeakSet new ]! !

!TraitedClass class methodsFor: 'testing' stamp: ''!
isTrait
	^ true! !

!TraitedClass class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory

	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	self propagateChangeOf: selector.
	! !

!TraitedClass class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	super addSelector: selector withMethod: compiledMethod.
	self propagateChangeOf: selector! !

!TraitedClass class methodsFor: 'changes' stamp: ''!
propagateChangeOf: aSelector
	| change |

	change := TraitChange new
		updatedSelectors: {aSelector};
		yourself.
		
	self basicUsers do: [ :e | change applyOn: e ]! !

!TraitedClass class methodsFor: 'users' stamp: ''!
removeUser: aClass

	self basicUsers remove: aClass ifAbsent: [ ].! !

!TraitedClass class methodsFor: 'accessing' stamp: ''!
classTrait
	^ self class! !

!TraitedClass class methodsFor: 'users' stamp: ''!
addUser: aClass

	self basicUsers add: aClass.! !

!TraitedMetaclass commentStamp: ''!
All the traited class metaclasses are instances of myself.

I include all the custom behavior to implement traits.
I override a number of methods in Metaclass to implement traits.

Also I have the localMethodDict and the traitComposition of the base class.  
So it is not needed to recompile the methods from TraitedClass. Check #initializeBasicMethods for more details!
!TraitedMetaclass methodsFor: 'initialization' stamp: ''!
initializeBasicMethods
	| selectors |
	
	"When a traited class is created, the methods from TraitedClass are inserted in the classSide of the new class. 
	So this new class can have traits. The methods are filtered using #isRejectedMethod:"
	
	selectors := self class traitedClassTrait selectors reject: [ :e | self isRejectedMethod: e ].
	selectors do: [ :e | self class traitedClassTrait copyMethod: e into: self replacing: true ]! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TraitedMetaclass methodsFor: 'testing - method dictionary' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TraitedMetaclass methodsFor: 'testing' stamp: ''!
isRejectedMethod: aSelector
	"Determine if the method is not to be installed in method dictionary"

	| isFromClass isFromTraitedClass isTheTraitIUseDefinesTheSelector isMySuperclassTraitedClass |
	
	"the selector is one of the local methods"
	(self isLocalSelector: aSelector)
		ifTrue: [ ^ true ].
		
	"If a trait I used define the selector, we do not reject"	
	isTheTraitIUseDefinesTheSelector := self traitComposition traits anySatisfy: [:inTrait | 
		inTrait localMethods anySatisfy: [ :meth | meth selector = aSelector ]].
	isTheTraitIUseDefinesTheSelector ifTrue:[ ^false ].	

	
	isFromClass := Class canUnderstand: aSelector.
	isFromTraitedClass := TraitedClass methodDict includesKey: aSelector.
	isMySuperclassTraitedClass := (superclass isKindOf: TraitedMetaclass) and: [
	superclass isObsolete not].
	
	"It is from Class (we already have them) and they are not overriden in TraitedClass"
	(isFromClass and: [ isFromTraitedClass not ]) ifTrue: [ ^ true ].
	
	"If it is in TraitedClass and it is in my superclass."
	(isFromTraitedClass and: isMySuperclassTraitedClass)
		ifTrue: [ ^ true ].
	^ false! !

!TraitedMetaclass methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TraitedMetaclass methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.! !

!TraitedMetaclass methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self isLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition
		traitDefining: aMethod selector
		ifNone: [ self class traitedClassTrait traitDefining: aMethod selector ifNone: [ ^ self ] ]) innerClass! !

!TraitedMetaclass methodsFor: 'testing' stamp: ''!
isSelectorToKeep: aSelector
	"I have to keep the local methods and the methods from TraitedClass
	The methods from TraitedClass makes me a class suporting traits, without them I am a normal class"

	^ (self isLocalSelector: aSelector)
		or: [ TraitedClass methodDict includesKey: aSelector ]! !

!TraitedMetaclass methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ localMethods includesKey: aSelector! !

!TraitedMetaclass methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TraitedMetaclass methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
traitComposition
	^ composition! !

!TraitedMetaclass methodsFor: 'fileout' stamp: ''!
definitionStringFor: aConfiguredPrinter

	^ aConfiguredPrinter traitedMetaclassDefinitionString ! !

!TraitedMetaclass methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary
	| selectors removedSelectors modified |
	
		"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated.
	Check the version in TraitedClass for more details."
	
	modified := false.
	
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ localMethods at: m selector put: m ]].
	
	selectors := self traitComposition selectors reject: [ :e | self isRejectedMethod: e ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false) ].
	
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self isSelectorToKeep: aSelector ] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].
	removedSelectors do: [ :aSelector | self organization removeElement: aSelector ]. 
	
	^ modified! !

!TraitedMetaclass methodsFor: 'querying' stamp: ''!
allTraits
	
	^ self traitComposition allTraits! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
baseLocalMethods: anObject
	baseLocalMethods := anObject! !

!TraitedMetaclass methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self isLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition
		traitDefining: aMethod selector
		ifNone: [ self class traitedClassTrait traitDefining: aMethod selector ifNone: [ self ] ]) 
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
traitUsers

	^ #()! !

!TraitedMetaclass methodsFor: 'accessing - method dictionary' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TraitedMetaclass methodsFor: 'slots' stamp: ''!
slots

	^ super slots reject: [ :e | composition slots includes: e ]! !

!TraitedMetaclass methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].

	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TraitedMetaclass methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	localMethods := self emptyMethodDictionary.
	composition := TaEmptyComposition new.
	
	baseComposition := TaEmptyComposition new.
	baseLocalMethods := self emptyMethodDictionary.! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
baseComposition: anObject
	baseComposition := anObject! !

!TraitedMetaclass methodsFor: 'traits' stamp: ''!
removeFromComposition: aTrait 
	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TraitedMetaclass methodsFor: 'initialization' stamp: ''!
emptyMethodDictionary
	^ MethodDictionary new: 64.! !

!TraitedMetaclass methodsFor: '*Calypso-SystemQueries' stamp: ''!
tagsForAllMethods
	"I act as #tagsForMethods but I also takes into account methods comming from traits"

	| allProtocols selectors |

	allProtocols := self organization protocols 
		reject: [ :each | each name = Protocol unclassified | each isExtensionProtocol ].

	selectors := self visibleMethods collect: [ :each | each selector ].

	^ allProtocols
		select: [ :protocol | 
			protocol methodSelectors 
				ifEmpty: [ true ] 
				ifNotEmpty: [ :methods | methods anySatisfy: [ :method | selectors includes: method ] ] ]
		thenCollect: #name! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
baseLocalMethods
	^ baseLocalMethods! !

!TraitedMetaclass methodsFor: 'initialization' stamp: ''!
traits
	^ composition traits! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
localMethodDict
	^ localMethods! !

!TraitedMetaclass methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not ! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
localSelectors
	
	^ localMethods keys! !

!TraitedMetaclass methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |

	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TraitedMetaclass methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TraitedMetaclass methodsFor: '*Calypso-SystemQueries' stamp: ''!
visibleMethods

	^ self methods reject: [ :e | e origin = TraitedClass ]! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ localMethods values! !

!TraitedMetaclass methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
	
	selectors do: [:sel | 
		(self isLocalSelector: sel) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TraitedMetaclass methodsFor: 'fileout' stamp: ''!
expandedDefinitionStringFor: aPrinter

	^ aPrinter expandedTraitedMetaclassDefinitionString
! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
baseComposition
	^ baseComposition! !

!TraitedMetaclass methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition

	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].

	composition := aComposition! !

!TraitedMetaclass class methodsFor: 'accessing' stamp: ''!
traitedClassTrait
	^ (TaCompositionElement for: TraitedClass)! !

!TraitsResource commentStamp: ''!
I define objects to be used for testing traits.

Browsr references to myself.!
!TraitsResource methodsFor: 'accessing' stamp: ''!
c3: anObject
	^c3 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c9: anObject
	^c9 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c1
	^c1! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c5
	^c5! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c6: anObject
	^c6 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t6
	^t6! !

!TraitsResource methodsFor: 'running' stamp: ''!
setUpTrivialRequiresFixture
	self c3: (self 
				createClassNamed: #C3
				superclass: ProtoObject
				uses: { }).
	ProtoObject removeSubclass: self c3.
	self c3 superclass: nil.
	self c3 compile: 'foo ^self bla' classified: #accessing! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t10: anObject
	^t10 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c4: anObject
	^c4 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c10
	^c10.! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c5: anObject
	^c5 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t2
	^t2! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t4
	^t4! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
categoryName
	^self class category! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t5: anObject
	^t5 := anObject! !

!TraitsResource methodsFor: 'running' stamp: ''!
tearDown

	self createdClassesAndTraits reverse
		do: [ :aClassOrTrait | 
			| behaviorName |
			behaviorName := aClassOrTrait name.
			Smalltalk globals
				at: behaviorName
				ifPresent: [ :classOrTrait | classOrTrait removeFromSystem: false ] ].

	createdClassesAndTraits := self
		t1:
			(self
				t2:
					(self
						t3:
							(self
								t4:
									(self
										t5:
											(self
												t6:
													(self
														c1:
															(self
																c2: (self c3: (self c4: (self c5: (self c6: (self c7: (self c8: nil)))))))))))))! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c8
	^c8! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c6
	^c6! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t8: anObject
	^t8 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t11: anObject
	^t11 := anObject! !

!TraitsResource methodsFor: 'running' stamp: ''!
setUpTwoLevelRequiresFixture
	self c4: (self 
				createClassNamed: #C4
				superclass: ProtoObject
				uses: { }).
	ProtoObject removeSubclass: self c4.
	self c4 superclass: nil.
	self c5: (self 
				createClassNamed: #C5
				superclass: self c4
				uses: { }).
	self c4 compile: 'foo ^self blew' classified: #accessing.
	self c5 compile: 'foo ^self blah' classified: #accessing! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c2: anObject
	^c2 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c11
	^c11.! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c8: anObject
	^c8 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t9
	^t9! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t11
	^t11.! !

!TraitsResource methodsFor: 'running' stamp: ''!
setUpTranslatingRequiresFixture
	self c6: (self 
				createClassNamed: #C6
				superclass: ProtoObject
				uses: { }).
	ProtoObject removeSubclass: self c6.
	self c6 superclass: nil.
	self c7: (self 
				createClassNamed: #C7
				superclass: self c6
				uses: { }).
	self c8: (self 
				createClassNamed: #C8
				superclass: self c7
				uses: { }).
	self c6 compile: 'foo ^self x' classified: #accessing.
	self c7 compile: 'foo ^3' classified: #accessing.
	self c7 compile: 'bar ^super foo' classified: #accessing.
	self c8 compile: 'bar ^self blah' classified: #accessing! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t12: anObject
	^t12 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c1: anObject
	^c1 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c3
	^c3! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c2
	^c2! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t3
	^t3! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t4: anObject
	^t4 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t8
	^t8! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t12
	^t12.! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t9: anObject
	^t9 := anObject! !

!TraitsResource methodsFor: 'utilities' stamp: ''!
createClassNamed: aSymbol superclass: aClass uses: aTraitComposition
	| class |		

	class := self class classInstaller make: [ :aBuilder |
		aBuilder name: aSymbol;
			superclass: aClass;
			traitComposition: aTraitComposition asTraitComposition;
			package: self categoryName ].
				
	self createdClassesAndTraits add: class.
	^class! !

!TraitsResource methodsFor: 'utilities' stamp: ''!
createTraitNamed: aSymbol uses: aTraitComposition
	| trait |
	trait := Trait
		named: aSymbol
		uses: aTraitComposition
		package: self categoryName.
	self createdClassesAndTraits add: trait.
	^trait! !

!TraitsResource methodsFor: 'running' stamp: ''!
setUp
	"Please note, that most tests rely on this setup of traits and
	classes - and that especially the order of the definitions matters."
	"SetUpCount := SetUpCount + 1."

	super setUp.
	dirty := false.
	SystemAnnouncer uniqueInstance suspendAllWhile: 
			[self t1: (self createTraitNamed: #T1
						uses: { }).
			self t1 comment: 'I am the trait T1'.
			
			self t1 compile: 'm11 ^11' classified: #cat1.
			self t1 compile: 'm12 ^12' classified: #cat2.
			self t1 compile: 'm13 ^self m12' classified: #cat3.
			
			self t2: (self createTraitNamed: #T2
						uses: { }).
			self t2 compile: 'm21 ^21' classified: #cat1.
			self t2 compile: 'm22 ^22' classified: #cat2.
			self t2 classSide compile: 'm2ClassSide: a ^a'.
			
			self t3: (self createTraitNamed: #T3
						uses: { }).
			self t3 compile: 'm31 ^31' classified: #cat1.
			self t3 compile: 'm32 ^32' classified: #cat2.
			self t3 compile: 'm33 ^33' classified: #cat3.
			
			self t4: (self createTraitNamed: #T4
						uses: { (self t1). (self t2) }).
			self t4 compile: 'm11 ^41' classified: #catX.	"overrides T1>>m11"
			self t4 compile: 'm42 ^42' classified: #cat2.
			
			self t5: (self createTraitNamed: #T5 uses: self t1 + self t2).
			self t5 compile: 'm51 ^super foo' classified: #cat1.
			self t5 compile: 'm52 ^ self class bar' classified: #cat1.
			self t5 compile: 'm53 ^ self class bar' classified: #cat1.
			
			self t6: (self createTraitNamed: #T6
						uses: self t1 + (self t2 @ { (#m22Alias -> #m22) })).

			self t9: (self createTraitNamed: #T9
						uses: { }).
						
			self t10: (self createTraitNamed: #T10
						uses: { }).
						
			self t12: (self createTraitNamed: #T12
						uses: {}).
	
			self t11: (self createTraitNamed: #T11
						uses: { self t12}).
			

						
			self c1: (self 
						createClassNamed: #C1
						superclass: Object
						uses: { }).
			self c1 compile: 'foo ^true' classified: #accessing.
			self c2: (self 
						createClassNamed: #C2
						superclass: self c1
						uses: self t5 - { #m11 }).
			self c2 compile: 'foo ^false' classified: #private.
			self c2 compile: 'bar ^self foo' classified: #private.
						
			self c9: (self 
						createClassNamed: #C9
						superclass: Object
						uses: self t9 ).
						
			self c10: (self 
						createClassNamed: #C10
						superclass: self c9
						uses: self t10 ).
						
			self c11: (self 
						createClassNamed: #C11
						superclass: self c10
						uses: self t11 ).
			
			self setUpTrivialRequiresFixture.
			self setUpTwoLevelRequiresFixture.
			self setUpTranslatingRequiresFixture].! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t6: anObject
	^t6 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c7
	^c7! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t10
	^t10.! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c7: anObject
	^c7 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t5
	^t5! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t3: anObject
	^t3 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t1
	^t1! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c4
	^c4! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c10: anObject
	^c10 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
createdClassesAndTraits
	createdClassesAndTraits ifNil: [
		createdClassesAndTraits := OrderedCollection new].
	^createdClassesAndTraits! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c11: anObject
	^c11 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
c9
	^c9! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t1: anObject
	^t1 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: ''!
t2: anObject
	^t2 := anObject! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c1
	^TraitsResource current c1! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t11
	^TraitsResource current t11! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t9
	^TraitsResource current t9! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c5
	^TraitsResource current c5! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c3
	^TraitsResource current c3! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c2
	^TraitsResource current c2! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t3
	^TraitsResource current t3! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t6
	^TraitsResource current t6! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t8
	^TraitsResource current t8! !

!TraitsTestCase methodsFor: 'utilities' stamp: ''!
resourceClassesAndTraits
	^TraitsResource current createdClassesAndTraits! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t12
	^TraitsResource current t12! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c10
	^TraitsResource current c10! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t4
	^TraitsResource current t4! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t2
	^TraitsResource current t2! !

!TraitsTestCase methodsFor: 'utilities' stamp: ''!
createClassNamed: aSymbol superclass: aClass uses: aTraitComposition
	| class |
			
	class := self class classInstaller make: [ :aBuilder |
		aBuilder name: aSymbol;
			superclass: aClass;
			traitComposition: aTraitComposition asTraitComposition;
			package: self categoryName ].		
		
	self createdClassesAndTraits add: class.
	^class! !

!TraitsTestCase methodsFor: 'utilities' stamp: ''!
createTraitNamed: aSymbol uses: aTraitComposition
	| trait |

	trait := self class classInstaller make: [ :aBuilder |
		aBuilder 
			name: aSymbol;
			traitComposition: aTraitComposition asTraitComposition;
			package: self categoryName;
			beTrait ].			

	self createdClassesAndTraits add: trait.
	^trait! !

!TraitsTestCase methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	oldAnnouncer := SystemAnnouncer uniqueInstance.
	SystemAnnouncer announcer: nil.
! !

!TraitsTestCase methodsFor: 'running' stamp: ''!
categoryName
	^self class category! !

!TraitsTestCase methodsFor: 'utilities' stamp: ''!
assertPrints: aString like: anotherString
	self assert: (aString copyWithout: $ ) equals: (anotherString copyWithout: $ )! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c7
	^TraitsResource current c7! !

!TraitsTestCase methodsFor: 'running' stamp: ''!
tearDown
	TraitsResource reset.
	self createdClassesAndTraits
		do: [ :aClassOrTrait || behaviorName |
			behaviorName := aClassOrTrait name.
			testingEnvironment at: behaviorName ifPresent: [ :classOrTrait | classOrTrait removeFromSystem: false ]].
	createdClassesAndTraits := nil.
	SystemAnnouncer announcer: oldAnnouncer.
	super tearDown 
! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c8
	^TraitsResource current c8! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t10
	^TraitsResource current t10! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t5
	^TraitsResource current t5! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c6
	^TraitsResource current c6! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
t1
	^TraitsResource current t1! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c4
	^TraitsResource current c4! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c11
	^TraitsResource current c11! !

!TraitsTestCase methodsFor: 'utilities' stamp: ''!
createdClassesAndTraits
	createdClassesAndTraits ifNil: [
		createdClassesAndTraits := OrderedCollection new].
	^createdClassesAndTraits! !

!TraitsTestCase methodsFor: 'accessing' stamp: ''!
c9
	^TraitsResource current c9! !

!TraitsTestCase class methodsFor: 'testing' stamp: ''!
isUnitTest
	^false! !

!TraitsTestCase class methodsFor: 'accessing' stamp: ''!
resources
	^ super resources copyWith: TraitsResource! !

!TranscriptDebugger commentStamp: ''!
I am a debugger that will log the error in a Trascript when called.!
!TranscriptDebugger class methodsFor: 'opening api' stamp: ''!
openOn: aDebugSession withFullView: aBool andNotification: aString
	self traceCr: (self messageToPrintFrom: aDebugSession)! !

!TranscriptLogger commentStamp: ''!
This logger forwards to the Transcript all signals that it receives.

### Example:

```
TranscriptLogger new 
    runDuring: [ StringSignal emit: 'This is a message' ]
```!
!TranscriptLogger methodsFor: 'utilities' stamp: ''!
nextPut: anAnnouncement

	Transcript crShow: anAnnouncement! !

!TransferMorph commentStamp: ''!
This is a Morph that is used to visually indicate the progress of a drag operation, and also as a container for various bits of drag state information.

It polls the shift state in its step method to update its copy state (shift pressed = should copy).

And if you hit the Escape key while dragging, it aborts the drag operation.!
!TransferMorph methodsFor: 'accessing' stamp: ''!
shouldCopy: aBoolean
	copy := aBoolean.! !

!TransferMorph methodsFor: 'private' stamp: ''!
updateCopyIcon

	| copyIcon |	
	copyIcon := self submorphWithProperty: #tmCopyIcon.
	self shouldCopy ifFalse: [
		^ copyIcon ifNotNil: [ copyIcon delete ]].
	copyIcon ifNotNil: [ ^ self ].
	copyIcon := ImageMorph new form: CopyPlusIcon.
	copyIcon setProperty: #tmCopyIcon toValue: true.
	^ self addMorphFront: copyIcon.! !

!TransferMorph methodsFor: 'stepping' stamp: ''!
step
	self shouldCopy = dragHand shiftPressed
		ifTrue: [ ^ self ].
	
	self shouldCopy: dragHand shiftPressed.
	self updateCopyIcon.! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: ''!
justDroppedInto: targetMorph event: anEvent 
	"If only world wants this TransferMorph, treat it as unaccepted (see also >>delete)."
	| formerPosition |
	formerPosition := self formerPosition.
	super justDroppedInto: targetMorph event: anEvent.
	self formerPosition: formerPosition.
	accepted := targetMorph ~= self world.
	self animationForMoveSuccess: accepted.
	accepted ifTrue: [
		self dropNotifyRecipient ifNotNil: [
			self dropNotifyRecipient dropAcceptedMorph: self from: targetMorph ]].
	self delete! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
move
	copy := false! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: ''!
result: result 
	^ self result: result from: nil! !

!TransferMorph methodsFor: 'private' stamp: ''!
initDraggedMorph
	draggedMorph ifNotNil: [^self].
	draggedMorph := self passenger asDraggableMorph.
	self addMorphBack: draggedMorph.
	self updateCopyIcon.
	self changed; fullBounds! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
draggedMorph
	draggedMorph ifNil: [self initDraggedMorph].
	^draggedMorph! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
source
	^source! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
draggedMorph: aMorph
	draggedMorph := aMorph! !

!TransferMorph methodsFor: 'event handling' stamp: ''!
keyDown: evt
	"Abort the drag on an escape"
	evt keyCharacter ~= Character escape ifTrue: [ ^self ].
	self delete.! !

!TransferMorph methodsFor: 'private' stamp: ''!
privateFullMoveBy: delta 
	super privateFullMoveBy: delta.
	self changed: #position! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
source: anObject
	source := anObject! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
dragHand
	"The hand dragging this morph"
	^dragHand! !

!TransferMorph methodsFor: 'stepping' stamp: ''!
stepTime
	^100! !

!TransferMorph methodsFor: 'submorphs - add/remove' stamp: ''!
delete
	"See also >>justDroppedInto:event:."
	accepted ifFalse: [
		self dropNotifyRecipient ifNotNil: [ self dropNotifyRecipient dropRejectedMorph: self ]].
	self changed: #deleted.
	self breakDependents.
	super delete! !

!TransferMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"
	super initialize.
	self layoutPolicy: TableLayout new.
	
	self listDirection: #leftToRight;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		layoutInset: 3;
		cellInset: 3;
		wrapCentering: #center;
		cellPositioning: #leftCenter.
		
	self borderStyle: (BorderStyle
		width: 1 color: Color lightGray).
		
	accepted := false.	
	copy := false.
	self on: #keyStroke send: #keyStroke: to: self! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
dropNotifyRecipient
	^dropNotifyRecipient! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: ''!
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."
	"Since this morph has been initialized automatically with bounds origin   
	     0@0, we have to move it to aHand position."
	super aboutToBeGrabbedBy: aHand.
	self draggedMorph.
	"self align: self bottomLeft with: aHand position."
	self formerPosition: self position.
	aHand newKeyboardFocus: self.! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
dropNotifyRecipient: anObject
	dropNotifyRecipient := anObject! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
passenger: anObject
	passenger := anObject! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
shouldCopy
	^copy! !

!TransferMorph methodsFor: 'drag and drop' stamp: ''!
dragTransferType
	^transferType! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
dragHand: aHandMorph
	"The hand dragging this morph"
	dragHand := aHandMorph! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: ''!
result: aResult from: aResultGenerator 
	"Send aResult of the drop operation computed by aResultGenerator to a   
	resultRecipient, if it exists."! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
passenger
	^passenger! !

!TransferMorph methodsFor: 'testing' stamp: ''!
isTransferable

	^ true! !

!TransferMorph methodsFor: 'accessing' stamp: ''!
dragTransferType: aSymbol
	transferType := aSymbol! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: ''!
animationForMoveSuccess: success 
	| start stop slideForm |
	success
		ifTrue: [^ self]
		ifFalse: [
			start := self fullBounds origin.
			stop := self formerPosition ifNil: [ self source bounds origin ]].
	start = stop ifTrue: [^ self].
	
	slideForm := self imageForm offset: 0@0.
	slideForm
		slideWithFirstFrom: start
		to: stop
		nSteps: 12
		delay: 20! !

!TransferMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ self theme selectionColor! !

!TransferMorph class methodsFor: 'instance creation' stamp: ''!
withPassenger: anObject from: source
	^self withPassenger: anObject from: source hand: source currentHand! !

!TransferMorph class methodsFor: 'class initialization' stamp: ''!
initialize
	"TransferMorph initialize"

	self initIcons! !

!TransferMorph class methodsFor: 'instance creation' stamp: ''!
withPassenger: anObject from: source hand: dragHand
	^ self new
		passenger: anObject;
		source: source;
		dragHand: dragHand;
		shouldCopy: dragHand shiftPressed;
		position: source positionInWorld;
		yourself! !

!TransferMorph class methodsFor: 'private - initialization' stamp: ''!
initIcons
	<script>

	CopyPlusIcon := Form
		extent: 16@16
		depth: 8
		fromArray: #( 0 0 65535 0 0 0 16768220 4278190080 0 0 16768220 4278190080 0 255 4294958300 4294967040 0 65500 3705461980 3705462015 0 65500 3705461980 3705462015 0 255 4294958300 4294967295 0 0 16768220 4278190080 0 0 16768220 4278190080 0 0 65535 0 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! !

!TransferPresenter commentStamp: ''!
I am a model representing a transfer during a drag and drop operation. I keep a pointer the source of the drag, and a pointer to what is dragged!
!TransferPresenter methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.

	passenger := nil asValueHolder.
	source := nil asValueHolder.! !

!TransferPresenter methodsFor: 'accessing' stamp: ''!
from: aModel

	source value: aModel! !

!TransferPresenter methodsFor: 'accessing' stamp: ''!
source

	^ source value! !

!TransferPresenter methodsFor: 'accessing' stamp: ''!
passenger

	^ passenger value! !

!TransferPresenter methodsFor: 'accessing' stamp: ''!
transfer: anObject

	passenger value: anObject! !

!TransferPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TransferAdapter! !

!TransformMorph commentStamp: ''!
A TransformMorph introduces a 2-D transformation between its (global) coordinates and the (local) coordinates of its submorphs, while also clipping all display to its bounds.  Specifically, with no offset, angle or scaling, a submorph with coordinates (0@0) will appear exactly at the topLeft of the windowMorph (its position).  Rotation and scaling are relative to the local origin, (0@0).

instance var	type				description
 transform		MorphicTransform	The coordinate transform between my coordinates and the
									local coordinates of my submorphs.
 smoothing		anInteger in 1..3	Perform smoothing of my contents during drawing
										1 No smoothing (#smoothingOff)
										2 Smoothing w/ edge adjacent pixels (#smoothingOn)
										3 Smoothing w/ edge and corner adj pixels
			
 localBounds	Rectangle or nil		caches the value of #localSubmorphBounds for performance

TransformMorphs operate with two different display strategies, depending on whether the transformation is a pure translation or not.  If so, then they simply use a clipping canvas and display their submorphs with the appropriate offset.  If the transformation includes scaling or rotation, then a caching canvas is used, whose active area covers the fullBounds of the submorphs intersected with the source quadrilateral corresponding to the window bounds.!
!TransformMorph methodsFor: 'accessing' stamp: ''!
smoothingOff
	smoothing := 1.
	self changed! !

!TransformMorph methodsFor: 'geometry' stamp: ''!
numberOfItemsPotentiallyInView

	"Answer the number of items that could potentially be viewed in full,
	computed as my visible height divided by the average height of my submorphs.
	Ignore visibility of submorphs."

	^ self numberOfItemsPotentiallyInViewWith: self submorphCount! !

!TransformMorph methodsFor: 'geometry' stamp: ''!
localVisibleSubmorphBounds
	"Answer, in my coordinate system, the bounds of all my visible submorphs (or nil if no visible submorphs)"
	| subBounds |
	subBounds := nil.
	self submorphsDo: [:m |
		(m visible) ifTrue: [
			subBounds
				ifNil: [subBounds := m fullBounds copy]
				ifNotNil: [subBounds := subBounds quickMerge: m fullBounds]]
			].
	^subBounds! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
offset
	^ transform offset + self innerBounds topLeft! !

!TransformMorph methodsFor: 'private' stamp: ''!
privateFullMoveBy: delta
	"Private!! Relocate me, but not my subMorphs."

	self privateMoveBy: delta.
	transform :=  (transform asMorphicTransform) withOffset: (transform offset - delta).! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
scale
	^ transform scale! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
colorForInsets
	^ owner ifNil: [color] ifNotNil: [owner color]! !

!TransformMorph methodsFor: 'geometry' stamp: ''!
layoutChanged

	"A submorph could have moved, thus changing my localBounds. Invalidate the cache."
	localBounds := nil.

	^super layoutChanged! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
angle: newAngle

	self changed.
	transform := transform withAngle: newAngle.
	self layoutChanged.
	self changed! !

!TransformMorph methodsFor: 'dropping/grabbing' stamp: ''!
grabTransform
	"Return the transform for the receiver which should be applied during grabbing"
	^owner ifNil:[self transform] ifNotNil:[owner grabTransform composedWithLocal: self transform]! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
extent: aPoint
	"Changed to not cause layoutChanged on the receiver."
	
	bounds extent = aPoint ifTrue: [^ self].
	self changed.
	bounds := (bounds topLeft extent: aPoint) rounded.
	super layoutChanged. "skip submorph bounds recalculation"
	self changed.! !

!TransformMorph methodsFor: 'layout' stamp: ''!
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.
	submorphs do: [:m| m ownerChanged].
	^ fullBounds! !

!TransformMorph methodsFor: 'geometry' stamp: ''!
localSubmorphBounds
	"Answer, in my coordinate system, the bounds of all my submorphs (or nil if no submorphs). We will cache this value for performance. The value is invalidated upon recieving #layoutChanged."

	localBounds ifNil:[
		self submorphsDo:[:m |
			localBounds ifNil: [localBounds := m fullBounds]
						ifNotNil: [localBounds := localBounds quickMerge: m fullBounds]].
	].	

	^ localBounds! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
smoothing: cellSize
	smoothing := cellSize.
	self changed! !

!TransformMorph methodsFor: 'layout' stamp: ''!
submorphBounds
	"Answer, in owner coordinates, the bounds of my visible submorphs, or my bounds"
	^ (self localVisibleSubmorphBounds ifNotNil: [ :box |transform localBoundsToGlobal: box ] ifNil: [ self bounds ]) truncated.! !

!TransformMorph methodsFor: '*FreeType-Morphic' stamp: ''!
drawSubmorphsOn: aCanvas

	aCanvas transformBy: transform
		clippingTo: self innerBounds
		during: [:myCanvas |
			(self angle ~= 0.0 or: [self scale ~= 1.0])
				ifTrue:[ 
					FreeTypeSettings current forceNonSubPixelDuring:[
						submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] ]
				ifFalse:[
					submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] ] 
		smoothing: smoothing! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
transform
	^transform! !

!TransformMorph methodsFor: 'initialization' stamp: ''!
initialize
	"initialize the state of the receiver"
	super initialize.
	
	smoothing := 1.
	transform := MorphicTransform identity! !

!TransformMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawSubmorphsOnAthensCanvas: anAthensCanvas
	| clip |
	clip := self clippingBounds intersect: anAthensCanvas clipRect.
	anAthensCanvas
		transformBy: self transform
		withClip: clip
		in: self innerBounds
		during: [ :c | submorphs do: [ :m | m fullDrawOnAthensCanvas: c ] ]! !

!TransformMorph methodsFor: 'halos and balloon help' stamp: ''!
wantsHaloFromClick
	^ false! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
offset: newOffset

	transform := transform withOffset: newOffset - self innerBounds topLeft.
	self changed! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
angle
	^ transform angle! !

!TransformMorph methodsFor: '*Athens-Morphic' stamp: ''!
clipDuring: aBlock canvas: aCanvas 

	self clipSubmorphs 
		ifTrue: [ 
			aCanvas
				clipBy: self clippingBounds 
				during: aBlock ] 
		ifFalse: [ ^ aBlock value ]! !

!TransformMorph methodsFor: 'menu' stamp: ''!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	smoothing = 1
		ifTrue: [aCustomMenu add: 'turn on smoothing' selector: #smoothingOn]
		ifFalse: [aCustomMenu add: 'turn off smoothing' selector: #smoothingOff]! !

!TransformMorph methodsFor: 'geometry' stamp: ''!
numberOfItemsPotentiallyInViewWith: listSize 
	"This is a refactoring for numberOfItemsPotentiallyInView because in some cases the numberOfSubmorhps
	needs to be passed from the outside. "
	| height |
	height := self localSubmorphBounds height.
	height isZero ifTrue: [ ^ 0 ].
	^ self innerBounds height // (height / listSize)! !

!TransformMorph methodsFor: 'change reporting' stamp: ''!
invalidRect: damageRect from: aMorph
	"Translate damage reports from submorphs by the scrollOffset."
	aMorph == self
		ifTrue:[super invalidRect: damageRect from: self]
		ifFalse:[super invalidRect: (((transform localBoundsToGlobal: damageRect) intersect: bounds ifNone: [ ^ self ] ) expandBy: 1) from: self].! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
clipSubmorphs
	"Answer true since we do!!
	This avoids the senseless over-invalidation
	with lists etc."
	
	^true! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
setOffset: newOffset angle: newAngle scale: newScale

	transform := MorphicTransform offset: newOffset angle: newAngle scale: newScale.
	self changed! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
smoothing
	^smoothing! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
smoothingOn
	smoothing := 2.
	self changed! !

!TransformMorph methodsFor: 'geometry' stamp: ''!
numberOfItemsInView
	"Answer the number of my submorphs whose (transformed) bounds intersect mine.
	This includes items that are only partially visible.
	Ignore visibility of submorphs."

	^(submorphs select: [ :ea | self innerBounds intersects: (transform localBoundsToGlobal: ea bounds) ]) size! !

!TransformMorph methodsFor: 'change reporting' stamp: ''!
areasRemainingToFill: aRectangle

	^Array with: aRectangle! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
scale: newScale

	self changed.
	transform := transform withScale: newScale.
	self layoutChanged.
	self changed.! !

!TransformMorph methodsFor: 'initialization' stamp: ''!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGreen! !

!TransformMorph methodsFor: 'accessing' stamp: ''!
transform: aTransform
	transform := aTransform.! !

!TransformMorph methodsFor: 'geometry testing' stamp: ''!
containsPoint: aPoint
	(bounds containsPoint: aPoint) ifFalse: [ ^ false ].
	^ self hasSubmorphs
		ifTrue: [ | localPoint |
			localPoint := transform globalPointToLocal: aPoint.
			self submorphsDo: [ :m | (m containsPoint: localPoint) ifTrue: [ ^ true ] ].
			false ]
		ifFalse: [ true ]! !

!TransformMorph methodsFor: 'event handling' stamp: ''!
transformFrom: uberMorph 
	"Return a transform to map coorinates of uberMorph, a morph above me in my owner chain, into the coordinates of my submorphs."

	(self == uberMorph or: [owner isNil]) ifTrue: [^transform].
	^(owner transformFrom: uberMorph) composedWithLocal: transform! !

!TransformWithLayoutMorph commentStamp: ''!
A transform morph that allows the use of a layout policy to arrange submorphs.!
!TransformWithLayoutMorph methodsFor: 'layout' stamp: ''!
doLayoutIn: layoutBounds 
	"Compute a new layout based on the given layout bounds."

	"Note: Testing for #bounds or #layoutBounds would be sufficient to
	figure out if we need an invalidation afterwards but #outerBounds
	is what we need for all leaf nodes so we use that."

	| box priorBounds |
	priorBounds := self outerBounds.
	submorphs isEmpty ifTrue: [^fullBounds := priorBounds].
	"Send #ownerChanged to our children"
	submorphs do: [:m | m ownerChanged].
	self layoutPolicy ifNotNil: [:layout | layout layout: self in: (0@0 extent: layoutBounds extent // self scale)].
	self adjustLayoutBounds.
	fullBounds := self privateFullBounds.
	box := self outerBounds.
	box = priorBounds 
		ifFalse: [self invalidRect: (priorBounds quickMerge: box)]! !

!TransformWithLayoutMorph methodsFor: 'layout' stamp: ''!
fullBounds
	"Do the ordinary thing. See comment in superclass."

	^self perform: #fullBounds withArguments: #() inSuperclass: Morph! !

!TransformationMorph commentStamp: ''!
A TransformationMorph is like a transformMorph, except that it does not clip, and its bounds include its entire submorph.  TransformationMorphs are assumed to have only one submorph -- the idea is that it is a wrapper that enables its submorph to scale and rotate.  A TransformationMorph may come to have more than one submorph if, eg, a menu sprouts a sub menu, using the transformationMorph temporarily as its world, but this ability is only sparsely supported (as in layoutChanged).

See TransformationMorph class example1 method.!
!TransformationMorph methodsFor: 'geometry - etoy' stamp: ''!
heading
	"End recusion when necessary."
	| rendee |
	^ (rendee := self renderedMorph) == self 
		ifTrue: [ 0.0 ]
		ifFalse: [rendee heading]! !

!TransformationMorph methodsFor: 'drawing' stamp: ''!
drawOn: aCanvas
	submorphs isEmpty ifTrue: [super drawOn: aCanvas]! !

!TransformationMorph methodsFor: 'classification' stamp: ''!
renderedMorph
"We are a renderer. Answer appropriately."

	submorphs isEmpty ifTrue: [^self].
	^self firstSubmorph renderedMorph! !

!TransformationMorph methodsFor: 't - rotating' stamp: ''!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!TransformationMorph methodsFor: 'initialization' stamp: ''!
asFlexOf: aMorph
	"Initialize me with position and bounds of aMorph,
	and with an offset that provides centered rotation."
	| pos |
	pos := aMorph position.
	self addMorph: aMorph.
	aMorph position: (aMorph extent // 2) negated.
	self position: pos.
	transform := transform withOffset: aMorph position - pos! !

!TransformationMorph methodsFor: 'accessing' stamp: ''!
embeddedWindowOrNil

	"answer nil for common morphs, yourself from system windows and first submorph for transformation morphs"
	
	| s | 
	
	(self submorphs size = 1) ifTrue: [ 
		s := self firstSubmorph.
		s isSystemWindow ifTrue: [ ^ s ] ].
	^ nil.! !

!TransformationMorph methodsFor: 'rotate scale and flex' stamp: ''!
rotationDegrees
	^ self angle radiansToDegrees negated! !

!TransformationMorph methodsFor: 'printing' stamp: ''!
printOn: aStream 
	super printOn: aStream.
	submorphs isEmpty 
		ifTrue: [aStream nextPutAll: ' with no transformee!!']
		ifFalse: [aStream nextPutAll: ' on ' ; print: submorphs first ]! !

!TransformationMorph methodsFor: 'classification' stamp: ''!
isRenderer

	^ true! !

!TransformationMorph methodsFor: 'layout' stamp: ''!
layoutChanged
	"Recompute bounds as a result of change"
	self computeBounds.
	super layoutChanged! !

!TransformationMorph methodsFor: 'dropping/grabbing' stamp: ''!
grabTransform
	"Return the transform for the receiver which should be applied during grabbing"
	self renderedMorph isWorldMorph 
		ifTrue:[^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]].
	^owner ifNil:[self transform] ifNotNil:[owner grabTransform composedWithLocal: self transform]! !

!TransformationMorph methodsFor: 'classification' stamp: ''!
isFlexMorph

	^ true! !

!TransformationMorph methodsFor: 'geometry' stamp: ''!
extent: newExtent
	
	self adjustAfter:
		[ | scaleFactor |scaleFactor := (self scale * newExtent r / self fullBounds extent r) max: 0.1.
		self scale: (scaleFactor detentBy: 0.1 atMultiplesOf: 1.0 snap: false)]! !

!TransformationMorph methodsFor: 'rotate scale and flex' stamp: ''!
prepareForRotating! !

!TransformationMorph methodsFor: 'accessing' stamp: ''!
scaleFactor
	"Answer the scaleFactor"

	^ transform scale! !

!TransformationMorph methodsFor: 'rotate scale and flex' stamp: ''!
prepareForScaling! !

!TransformationMorph methodsFor: 'testing' stamp: ''!
isSticky
	submorphs isEmpty ifFalse: [^ submorphs first isSticky].
	^false! !

!TransformationMorph methodsFor: 'testing' stamp: ''!
stepTime
	"Answer the stepTime of my rendered morph if posible"

	| rendered |
	rendered := self renderedMorph.
	rendered = self ifTrue: [^super stepTime].	"Hack to avoid infinite recursion"
	^rendered stepTime.! !

!TransformationMorph methodsFor: 'accessing' stamp: ''!
rotationDegrees: degrees
	self adjustAfter:[self angle: degrees degreesToRadians negated]! !

!TransformationMorph methodsFor: 'geometry - etoy' stamp: ''!
referencePosition
	"Answer the  receiver's reference position, bullet-proofed against infinite recursion in the unlikely but occasionally-seen case that I am my own renderee"

	| rendered |
	^ (rendered := self renderedMorph) == self
		ifTrue:
			[super referencePosition]
		ifFalse:
			[transform localPointToGlobal: rendered referencePosition]! !

!TransformationMorph methodsFor: '*Athens-Morphic' stamp: ''!
drawOnAthensCanvas: anAthensCanvas
	submorphs isEmpty ifTrue: [super drawOnAthensCanvas: anAthensCanvas]! !

!TransformationMorph methodsFor: 'accessing' stamp: ''!
forwardDirection
	"Return the rendee's forward direction. 
	If I have no rendee then return 0.0 degrees "
	| rendee |
	^ ( rendee := self renderedMorph) == self  
		ifTrue: [0.0 ]
		ifFalse: [^ rendee forwardDirection]! !

!TransformationMorph methodsFor: 'accessing' stamp: ''!
hasNoScaleOrRotation

	^ transform isPureTranslation! !

!TransformationMorph methodsFor: 'nil' stamp: ''!
scaleToMatch: aPoint
	| scaleFactor tfm originalScale |
	tfm := transform withScale: 1.0.
	originalScale := ((tfm localBoundsToGlobal: self renderedMorph fullBounds) corner -
		(tfm localPointToGlobal: self renderedMorph referencePosition)) r.
	"Catch cases where the reference point is on fullBounds corner"
	originalScale < 1.0 ifTrue:[originalScale := 1.0].
	scaleFactor := (aPoint - self referencePosition) r / originalScale.
	scaleFactor := scaleFactor < 1.0
		ifTrue: [scaleFactor detentBy: 0.05 atMultiplesOf: 0.25 snap: false]
		ifFalse: [scaleFactor detentBy: 0.1 atMultiplesOf: 0.5 snap: false].
	self adjustAfter:[self scale: ((scaleFactor min: 8.0) max: 0.1)].! !

!TransformationMorph methodsFor: 'geometry - etoy' stamp: ''!
degreesOfFlex
	"Return any rotation due to flexing"
	^ self rotationDegrees! !

!TransformationMorph methodsFor: 'submorphs - add/remove' stamp: ''!
replaceSubmorph: oldMorph by: newMorph
	| t b |
	t := transform.
	b := bounds.
	super replaceSubmorph: oldMorph by: newMorph.
	transform := t.
	bounds := b.
	self layoutChanged! !

!TransformationMorph methodsFor: 'private' stamp: ''!
adjustAfter: changeBlock 
	"Cause this morph to remain cetered where it was before, and
	choose appropriate smoothing, after a change of scale or rotation."

	changeBlock value.
	self chooseSmoothing.
	self layoutChanged.
	owner ifNotNil: [owner invalidRect: bounds]! !

!TransformationMorph methodsFor: 'geometry' stamp: ''!
computeBounds
	self hasSubmorphs ifTrue:
		[bounds := (transform localBoundsToGlobal:
					(Rectangle merging:
						(self submorphs collect: [:m | m fullBounds]))) truncated
				expandBy: 1].
	fullBounds := bounds.! !

!TransformationMorph methodsFor: 'geometry - etoy' stamp: ''!
visible: aBoolean
	"Set the receiver's visibility property"

	super visible: aBoolean.
	submorphs isEmptyOrNil ifFalse: [submorphs first visible: aBoolean]! !

!TransformationMorph methodsFor: 'geometry - etoy' stamp: ''!
setDirectionFrom: aPoint
	| delta degrees inner |
	inner := self renderedMorph.
	inner == self ifTrue:[^self].
	delta := (inner transformFromWorld globalPointToLocal: aPoint) - inner referencePosition.
	degrees := delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.! !

!TransformationMorph methodsFor: 'geometry' stamp: ''!
transformedBy: aTransform
	self changed.
	self transform: (self transform composedWithGlobal: aTransform).
	self computeBounds.
	self changed.! !

!TransformationMorph methodsFor: 'menu' stamp: ''!
removeFlexShell
	"Remove the shell used to make a morph rotatable and scalable."

	| oldHalo unflexed myWorld refPos aPosition |
	refPos := self referencePosition.
	myWorld := self world.
	oldHalo := self halo.
	submorphs isEmpty ifTrue: [^ self delete].
	aPosition := (owner submorphIndexOf: self) ifNil: [1].
	unflexed := self firstSubmorph.
	self submorphs do: [:m |
		m position: self center - (m extent // 2).
		owner addMorph: m asElementNumber: aPosition].
	oldHalo ifNotNil: [oldHalo setTarget: unflexed].
	myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: unflexed].
	self delete.
	unflexed referencePosition: refPos.
	^ unflexed! !

!TransformationMorph methodsFor: 'private' stamp: ''!
chooseSmoothing
	"Choose appropriate smoothing, after a change of scale or rotation."

	smoothing := (self scale < 1.0 or: [self angle ~= (self angle roundTo: Float pi / 2.0)]) 
		ifTrue: [ 2]
		ifFalse: [1]! !

!TransformationMorph class methodsFor: 'accessing' stamp: ''!
traitCompositionString
	^ self traitComposition asString! !

!TransformationMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: aCategory
	
	"When a new methods is added, I add it to the localMethodDict and also propagate the changes to my users"
	self localMethodDict at: selector put: compiledMethod.
	
	super
		addAndClassifySelector: selector
		withMethod: compiledMethod
		inProtocol: aCategory.

	TraitChange addSelector: selector on: self.	! !

!TransformationMorph class methodsFor: 'testing' stamp: ''!
includesLocalSelector: aSymbol
	^ self isLocalSelector: aSymbol! !

!TransformationMorph class methodsFor: 'examples' stamp: ''!
example1
	| stringMorph transformationMorph |
	stringMorph := 'vertical text' asMorph.
	transformationMorph := TransformationMorph new asFlexOf: stringMorph.
	transformationMorph angle: Float pi / 2.
	transformationMorph position: 5@5.
	transformationMorph openInWorld.! !

!TransformationMorph class methodsFor: 'initialization' stamp: ''!
doRebuildMethodDictionary
	| selectors removedSelectors removeFromOrganization modified|

	"During the creation of the class or after a change in the traitComposition, the whole method dictionary is calculated.
	If I return true, my users should be updated"

	"1. I recreate the local methodDict"
	modified := false.
	self methodDict valuesDo: [ :m | m traitSource ifNil: [ self localMethodDict at: m selector put: m ]].

	"2. I filter the selectors from the trait composition, rejecting the ones that are locally defined.
	And then I install the methods in myself. The trait composition only install the method if it is needed."
	selectors := self traitComposition selectors reject: [ :e | (self localMethodDict includesKey: e) ].
	selectors do: [ :e | modified := modified | (self traitComposition installSelector: e into: self replacing: false)].

	"3. I handle the methods that I have and they are no more in the traitComposition."
	removedSelectors := self methodDict keys reject: [ :aSelector | (selectors includes: aSelector) or: [ self localMethodDict includesKey: aSelector] ].
	modified := modified | (removedSelectors isNotEmpty).
	removedSelectors do: [ :aSelector | self methodDict removeKey: aSelector ].

	"4. Finally, I remove these methods from my class organization"
	removeFromOrganization := self organization allMethodSelectors reject: [:e | self methodDict includesKey: e ].
	removeFromOrganization do: [ :aSelector | self organization removeElement: aSelector ].

	^ modified! !

!TransformationMorph class methodsFor: 'testing' stamp: ''!
isLocalSelector: aSelector
	
	^ self localMethodDict includesKey: aSelector! !

!TransformationMorph class methodsFor: 'testing' stamp: ''!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^ self traitComposition isAliasSelector: aSymbol! !

!TransformationMorph class methodsFor: 'querying' stamp: ''!
allTraits
	^ self traitComposition allTraits! !

!TransformationMorph class methodsFor: 'removing' stamp: ''!
removeSelector: aSelector

	"When a selector is removed it should be notified to my users.
	Check the class TraitChange for more details"
	super removeSelector: aSelector.
	self localMethodDict removeKey: aSelector ifAbsent: [  ].

	TraitChange removeSelector: aSelector on: self.! !

!TransformationMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withRecompiledMethod: compiledMethod 
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"

	compiledMethod isFromTrait 
		ifTrue: [ ^ super addSelector: selector withRecompiledMethod: compiledMethod ].
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withRecompiledMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TransformationMorph class methodsFor: 'trait-composition' stamp: ''!
removeFromComposition: aTrait

	self setTraitComposition: (self traitComposition copyWithoutTrait: aTrait asTraitComposition)! !

!TransformationMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict: aMethodDictionary
	^ self class baseLocalMethods: aMethodDictionary ! !

!TransformationMorph class methodsFor: 'accessing' stamp: ''!
localMethodDict
	"The local methodDict is in the metaclass. In this way I do not have to recompile the methods during the bootstrap when we don't have a compiler."
	^ self class baseLocalMethods! !

!TransformationMorph class methodsFor: 'testing' stamp: ''!
hasTraitComposition
	
	^ self traitComposition isEmpty not! !

!TransformationMorph class methodsFor: 'recompilation' stamp: ''!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method newMethod |
	method := oldClass compiledMethodAt: selector.
	newMethod := self compiler
				source: (oldClass sourceCodeAt: selector);
				class: self;
				failBlock: [^ self];
				compiledMethodTrailer: method trailer;
				compile.   "Assume OK after proceed from SyntaxError"
	selector == newMethod selector ifFalse: [self error: 'selector changed!!'].
	
	method properties 
		at: #traitSource 
		ifPresent: [ :aSource | newMethod propertyAt: #traitSource put: aSource].
	
	self addSelector: selector withRecompiledMethod: newMethod.! !

!TransformationMorph class methodsFor: 'accessing' stamp: ''!
localMethods
	"returns the methods of classes excluding the ones of the traits that the class uses" 
	 
	^ self localMethodDict values! !

!TransformationMorph class methodsFor: '*CodeExport-Traits' stamp: ''!
fileOutLocalMethodsInCategory: aSymbol on: aFileStream
	| selectors |
	
	aFileStream cr.
	selectors := self selectorsToFileOutCategory: aSymbol.
		
	selectors do: [:sel | 
		((self isLocalSelector: sel) or: [ (self traitComposition selectors includes: sel) not]) ifTrue: [ 
		self printMethodChunk: sel on: aFileStream ]].
	
	^ self! !

!TransformationMorph class methodsFor: 'accessing' stamp: ''!
traitComposition: aComposition
	
	aComposition asTraitComposition allTraits do: [ :aMaybeTrait |
		aMaybeTrait isTrait ifFalse: [ 
			self error: 'All the members of the trait composition should be traits' ]].
		
	self class baseComposition: aComposition! !

!TransformationMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
addSelector: selector withMethod: compiledMethod
	"When a new selector is installed in a class I insert the selector in the local methodDict and propagate the changes to my users"
	
	self localMethodDict at: selector put: compiledMethod.
	super addSelector: selector withMethod: compiledMethod.
	TraitChange addSelector: selector on: self! !

!TransformationMorph class methodsFor: 'testing' stamp: ''!
findOriginClassOf: aMethod

	"I return the myself or the trait that has the original implementation of a method.
	If the method is an alias, the returned class includes the original aliased method"

	(aMethod hasProperty: #traitSource) 
		ifTrue: [ ^ aMethod traitSource innerClass ]. 

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ self ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ ^ self ]) innerClass! !

!TransformationMorph class methodsFor: 'accessing' stamp: ''!
traitComposition
	"My trait composition is in my class. So I do not need to recompile the methods when installing them during bootstrap"
	^ self class baseComposition! !

!TransformationMorph class methodsFor: 'testing' stamp: ''!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^ self traitComposition isLocalAliasSelector: aSymbol! !

!TransformationMorph class methodsFor: 'initialization' stamp: ''!
rebuildMethodDictionary

	"Useful to be rewritten in Traits"
	^ self doRebuildMethodDictionary.
! !

!TransformationMorph class methodsFor: 'removing' stamp: ''!
removeFromSystem: logged
	
	"When a traited class is removed the traits it is using should be updated"
	| mySubclasses |
	self traitComposition removeUser: self.
	self class traitComposition removeUser: self class.

	TraitedClass removeUser: self class.
	
	mySubclasses := self subclasses.
	
	super removeFromSystem: logged.
	
	"As I am a traited class my subclasses does not have the basic traited class 
	methods, so I add them."
	mySubclasses do: [ :each | each class initializeBasicMethods ].
! !

!TransformationMorph class methodsFor: 'accessing' stamp: ''!
traitUsers
	"I am a traited class, I have no users, this is for compatibility with traits"
	^ #()! !

!TransformationMorph class methodsFor: 'testing' stamp: ''!
findOriginMethodOf: aMethod

	"I return the original method for a aMethod.
	If this is a local method, the original method is itself.
	If it cames from a trait composition I look for the method in the trait composition.
	First I try with the trait stored in the traitSource. 
	If it is an aliased or conflicting method, the method is look up in the whole trait composition"

	(self includesLocalSelector: aMethod selector)
		ifTrue: [ ^ aMethod ].

	(aMethod hasProperty: #traitSource)
		ifTrue: [ |newSelector|
			newSelector := self traitComposition originSelectorOf: aMethod selector.
			^ aMethod traitSource compiledMethodAt: newSelector ifAbsent: [aMethod] ].

	^ (self traitComposition traitDefining: aMethod selector ifNone: [ self ])
		compiledMethodAt: aMethod selector ifAbsent: [ ^ aMethod ]		
! !

!TransformationMorph class methodsFor: 'accessing' stamp: ''!
traits
	^ self traitComposition traits! !

!TransformationMorph class methodsFor: 'accessing - method dictionary' stamp: ''!
localSelectors
	
	^ self localMethodDict keys! !

!TransformationMorph class methodsFor: 'categories' stamp: ''!
recategorizeSelector: selector from: oldCategory to: newCategory
	| original |
	
	"When a method is recategorized I have to classify the method, but also recategorize the aliases pointing to it"
	
	original := self organization categoryOfElement: selector ifAbsent: [ ^ self ].

	"If it is nil is because it is a removal. It will removed when the method is removed."
	newCategory ifNil: [ ^ self ].

	original = oldCategory
		ifTrue: [ self organization classify: selector under: newCategory suppressIfDefault: true ].

	(self traitComposition reverseAlias: selector) do: [ :e | 
		self recategorizeSelector: e from: oldCategory to: newCategory. 
		self notifyOfRecategorizedSelector: e from: oldCategory to: newCategory ].
	
	self organization removeEmptyCategories! !

!TransformationMorph class methodsFor: 'testing' stamp: ''!
isLocalMethodsProtocol: aProtocol
	"Checks if the protocol has local selectors"

	aProtocol methodSelectors ifEmpty: [ ^ true ].
	^ aProtocol methodSelectors anySatisfy: [ :each | self isLocalSelector: each ]! !

!TreeChunkPagerMorph commentStamp: ''!
A chunk pager!
!TreeChunkPagerMorph methodsFor: 'navigation' stamp: ''!
lastIndex: anIndex
	lastIndex := anIndex! !

!TreeChunkPagerMorph methodsFor: 'accessing' stamp: ''!
computedHeightFromContents
	| h |
	h := 0.
	self submorphsDo: [:sm | h := h max: sm height].
	^ h max: (self preferedFont height + 8)! !

!TreeChunkPagerMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	nextPageAllowed := true! !

!TreeChunkPagerMorph methodsFor: 'accessing' stamp: ''!
atBottom
	^ atBottom ifNil: [atBottom := false]! !

!TreeChunkPagerMorph methodsFor: 'navigation' stamp: ''!
fullList
	self lastIndex < self nodeList size
		ifTrue: [self nextPage: self nodeList size]! !

!TreeChunkPagerMorph methodsFor: 'testing' stamp: ''!
notOnLastPage
	^ self onLastPage not! !

!TreeChunkPagerMorph methodsFor: 'accessing' stamp: ''!
atBottom: aBoolean
	atBottom ~= aBoolean 
		ifTrue: [atBottom := aBoolean]! !

!TreeChunkPagerMorph methodsFor: 'accessing' stamp: ''!
computedHeight 
	^ self nodeList size > self lastIndex 
		ifTrue: [super computedHeight ]
		ifFalse:[0]! !

!TreeChunkPagerMorph methodsFor: 'user interface' stamp: ''!
vScrollBarValue: scrollValue
	| old |
	old := atBottom.
	self atBottom: scrollValue >= self verticalScrollbarFrontier.
	old ~= atBottom
		ifTrue: [ self buildPanel ]! !

!TreeChunkPagerMorph methodsFor: 'navigation' stamp: ''!
chunkSizeFromString: aString
	| input newPageSize |
	input := aString asString 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! !

!TreeChunkPagerMorph methodsFor: 'navigation' stamp: ''!
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]]! !

!TreeChunkPagerMorph methodsFor: 'navigation' stamp: ''!
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 ]! !

!TreeChunkPagerMorph methodsFor: 'initialize - release' stamp: ''!
updateContents
	treeMorph vIsScrollable 
		ifFalse: [self atBottom: true].
	super updateContents! !

!TreeChunkPagerMorph methodsFor: 'user interface' stamp: ''!
verticalScrollbarFrontier
	^ 0.98! !

!TreeChunkPagerMorph methodsFor: 'navigation' stamp: ''!
lastIndex
	^ lastIndex ifNil: [lastIndex := self pageSize]! !

!TreeChunkPagerMorph methodsFor: 'accessing' stamp: ''!
currentNodelist
	^ self nodeList copyFrom: 1 to: (self lastIndex min: self nodeList size)! !

!TreeChunkPagerMorph methodsFor: 'testing' stamp: ''!
onLastPage
	^ self lastIndex = self nodeList size! !

!TreeChunkPagerMorph methodsFor: 'initialize - release' stamp: ''!
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: #pageSizeToString
				set: #chunkSizeFromString:
				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: '1000000').
			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! !

!TreeColumnButtonMorph commentStamp: ''!
A button in a morphic based tree!
!TreeColumnButtonMorph methodsFor: 'dropping/grabbing' stamp: ''!
mouseLeaveDragging: evt
	self noMorePotentialDropTarget! !

!TreeColumnButtonMorph methodsFor: 'dropping/grabbing' stamp: ''!
handlesMouseOverDragging: evt
	^ true! !

!TreeColumnButtonMorph methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self enableDragNDrop: true.
	self fillStyle: (self theme morphTreeColumnFillStyleFor: self).
	self borderStyle: (self theme morphTreeColumnBorderStyleFor: self)! !

!TreeColumnButtonMorph methodsFor: 'accessing' stamp: ''!
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.! !

!TreeColumnButtonMorph methodsFor: 'accessing' stamp: ''!
removeIcon
	
	icon ifNotNil: [ self removeMorph: icon ].! !

!TreeColumnButtonMorph methodsFor: 'dropping/grabbing' stamp: ''!
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.
		].! !

!TreeColumnButtonMorph methodsFor: 'accessing' stamp: ''!
asPotentialDropTarget 
	self model asPotentialDropTarget! !

!TreeColumnButtonMorph methodsFor: 'accessing' stamp: ''!
noMorePotentialDropTarget
	self model noMorePotentialDropTarget! !

!TreeColumnButtonMorph methodsFor: 'event handling' stamp: ''!
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! !

!TreeColumnButtonMorph methodsFor: '*Polymorph-Widgets' stamp: ''!
themeChanged
	self fillStyle: (self theme morphTreeColumnFillStyleFor: self).
	self borderStyle: (self theme morphTreeColumnBorderStyleFor: self).
	super themeChanged! !

!TreeColumnButtonMorph methodsFor: 'theme' stamp: ''!
themedFillStyle
	^ self theme morphTreeColumnFillStyleFor: self! !

!TreeColumnButtonMorph methodsFor: 'accessing' stamp: ''!
icon

	^ icon! !

!TreeColumnButtonMorph methodsFor: 'event handling' stamp: ''!
startDrag: anEvent
	| aTransferMorph |
	self dragEnabled ifFalse: [^ self].
	(anEvent hand hasSubmorphs)
		ifTrue: [^ self].
	oldColor 
		ifNotNil: [
			self fillStyle: oldColor.
			oldColor := nil].
	aTransferMorph := self model transferFor: self model from: self.
	aTransferMorph align: aTransferMorph draggedMorph center with: anEvent position.
	anEvent hand grabMorph: aTransferMorph.
	anEvent hand releaseMouseFocus: self! !

!TreeColumnButtonMorph methodsFor: 'initialization' stamp: ''!
model: anObject
	model := anObject! !

!TreeColumnButtonMorph methodsFor: 'dropping/grabbing' stamp: ''!
mouseUp: evt
	self noMorePotentialDropTarget.
	super mouseUp: evt! !

!TreeColumnButtonMorph methodsFor: 'accessing' stamp: ''!
wantsDroppedMorph: aMorph event: anEvent 
	^ model container columnDropUnabled and: [(aMorph isTransferable) and: [(aMorph passenger isKindOf: MorphTreeColumn) and: [aMorph passenger ~= self model]]]! !

!TreeColumnButtonMorph methodsFor: 'testing' stamp: ''!
isDefault
	^true! !

!TreeColumnButtonMorph methodsFor: 'accessing' stamp: ''!
icon: anIcon
	
	icon ifNotNil: [ self removeMorph: icon ].
	
	anIcon ifNotNil: [
		icon := anIcon.
		self addMorphFront: anIcon ]! !

!TreeColumnButtonMorph methodsFor: 'initialization' stamp: ''!
model
	^ model! !

!TreeColumnPresenter commentStamp: ''!
I represent a tree column. I am used to specify how to render nodes, as well as the header title, icon , action on click and properties (resizable, initial width)!
!TreeColumnPresenter methodsFor: 'api' stamp: ''!
headerAction

	^ headerAction value! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
displayBlock

	^ displayBlock value! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
headerIcon: anIcon

	headerIcon value: anIcon! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
headerFont: aFont

	headerFont value: aFont! !

!TreeColumnPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	container := nil asValueHolder.
	displayBlock := [ :node | node printString ] asValueHolder.
	initialWidth := 100 asValueHolder.
	resizable := true asValueHolder.
	headerLabel := nil asValueHolder.
	headerFont := self class defaultFont asValueHolder.
	headerIcon := nil asValueHolder.
	headerAction := nil asValueHolder.
	
	self registerEvents! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
headerFont

	^ headerFont value! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
headerLabel

	^ headerLabel value! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
resizable: aBoolean

	resizable value: aBoolean! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
headerLabel: aString

	headerLabel value: aString! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
headerAction: aBlock

	headerAction value: aBlock! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
headerIcon

	^ headerIcon value! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
initialWidth: anInteger

	initialWidth value: anInteger! !

!TreeColumnPresenter methodsFor: 'initialization' stamp: ''!
registerEvents

	displayBlock whenChangedDo: [ self changed: #displayBlockChanged ].
	resizable whenChangedDo: [ self changed: #resizableChanged ].
	headerLabel whenChangedDo: [ self changed: #headerLabelChanged ].
	headerFont whenChangedDo: [ self changed: #headerFontChanged ].
	headerIcon whenChangedDo: [ self changed: #headerIconChanged ]! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
initialWidth

	^ initialWidth value! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
container

	^ container value! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
container: aTreePresenter

	container value: aTreePresenter! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
displayBlock: aBlock

	displayBlock value: aBlock! !

!TreeColumnPresenter methodsFor: 'api' stamp: ''!
resizable

	^ resizable value! !

!TreeColumnPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(TreeColumnAdapter
		adapt: #(model))! !

!TreeColumnPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TreeColumnAdapter! !

!TreeListMorph commentStamp: ''!
A SimpleHierarchicalListMorph subclass supporting alternative fonts for all items.

This class is badly named and should be merged with its superclass - Stephane Ducasse!
!TreeListMorph methodsFor: 'accessing' stamp: ''!
font
	"Answer the value of font"

	^font ifNil: [TextStyle defaultFont]! !

!TreeListMorph methodsFor: 'accessing' stamp: ''!
font: anObject
	"Set the value of font"

	font := anObject! !

!TreeListMorph methodsFor: 'private' stamp: ''!
insertNewMorphs: morphList
	"Update the font on each morph."
	
	morphList do: [:m |
		m
			font: self font;
			extent: m minWidth @ m minHeight].
	^super insertNewMorphs: morphList! !

!TreeListMorph methodsFor: 'private' stamp: ''!
layoutBounds: aRectangle
	"Set the bounds for laying out children of the receiver.
	Update the scroller and scrollbars now since bounds set directly
	(not via #extent:)."
	
	super layoutBounds: aRectangle.
	self
		resizeScroller;
		setScrollDeltas! !

!TreeListMorph methodsFor: 'private' stamp: ''!
addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean
	"Update the font on each morph."
	
	|answer|
	answer := super addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean.
	"I commented out the following lines, because it makes this morph incredible slow.
	This is used to browse diffs from monticello which can be really big.
	I couldn't find any place where this Morph is used and needs the following lines.
	nicolai."
	self flag:#issue12027.
	"self scroller submorphsDo: [:i |
		i
			font: self font;
			extent: i minWidth @ i minHeight]."
	^answer! !

!TreeNavigationBarMorph commentStamp: ''!
I'm a pager control used to navigate in a MorphTreeMorph that has a lot of entries.

You can see one of my subclass in action using:
"May take a while to open"
ClassListExample new open!
!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
pageSearchText
	^ pageSearchText ifNil: [pageSearchText := '']! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
withSearch: aBoolean
	withSearch := aBoolean.
	self buildPanel! !

!TreeNavigationBarMorph methodsFor: 'user interface' stamp: ''!
vScrollBarValue: scrollValue! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
computedHeight
	^ computedHeight
		ifNil: [computedHeight := self computedHeightFromContents + self layoutInset asPoint y + self cellInset asPoint y]! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
nodeList
	^ treeMorph nodeList! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
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! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
updateContents
	self bounds: self computedBounds.
	self color: treeMorph pagerColor.! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
pageSizeFromString: aString
	| input |
	input := aString asString 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! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
basicIcon
	| button |
	^ (button := IconicButtonMorph 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! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
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! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
pagerColor
	^ treeMorph pagerColor! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
treeMorph: aTreeMorph 
	treeMorph := aTreeMorph.! !

!TreeNavigationBarMorph methodsFor: 'navigation' stamp: ''!
updateForNewPageSize: aPageSize
	pageSize := aPageSize max: 1.
	self changed: #pageSize! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
textEntryLabel: aLabel get: getSel set: setSel help: helpText class: aClass
	^ RubPluggableTextFieldMorph new
		on: self
		text: getSel
		accept: setSel
		readSelection: nil
		menu: nil;
		setBalloonText: helpText;
		yourself! !

!TreeNavigationBarMorph methodsFor: 'navigation' stamp: ''!
pageOfNodeIndex: anIndex
	^ (anIndex > 0 and: [anIndex <= self nodeList size])
		ifTrue: [((anIndex - 1) // pageSize) + 1]
		ifFalse: [nil]! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
buildPanel
	self subclassResponsibility! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
computedBounds
	| tb tbw yGap |
	tb := treeMorph bounds.
	tbw := treeMorph borderWidth.
	yGap := self layoutInset asPoint y + self cellInset asPoint y.
	^ (tb bottomLeft + (tbw @ (self computedHeight + yGap) negated)) corner: (tb bottomRight - ( (tbw * 2) @ yGap )).! !

!TreeNavigationBarMorph methodsFor: 'navigation' stamp: ''!
computedHeightFromContents
	| h |
	h := 0.
	self submorphsDo: [:sm | h := h max: sm height].
	^ h! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
pageSizeToString
	^ self pageSize asString! !

!TreeNavigationBarMorph methodsFor: 'initialization' stamp: ''!
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! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
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]]! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
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! !

!TreeNavigationBarMorph methodsFor: 'navigation' stamp: ''!
changePageSize: aNumberOrNil
	aNumberOrNil
		ifNotNil: [self updateForNewPageSize: aNumberOrNil]
		ifNil: [treeMorph removePager]! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
pageSize: anInteger
	pageSize := anInteger! !

!TreeNavigationBarMorph methodsFor: 'private' stamp: ''!
mouseDown: anEvent! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
pageSize
	^ pageSize! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
withSearch
	^ withSearch ifNil: [withSearch := false]! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
treeMorph: aTreeMorph pageSize: anInteger
	self treeMorph: aTreeMorph.
	self pageSize: anInteger! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
preferedFont
	^ self balloonFont! !

!TreeNavigationBarMorph methodsFor: 'private' stamp: ''!
handlesMouseDown: anEvent
	^ true! !

!TreeNavigationBarMorph methodsFor: 'accessing' stamp: ''!
spacer: hsize
	^ (Morph new) color: Color transparent; extent: hsize @ (self hasSubmorphs  ifTrue: [self computedHeight] ifFalse: [(self preferedFont height + 8)]); yourself! !

!TreeNavigationBarMorph class methodsFor: 'icons' stamp: ''!
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)! !

!TreeNavigationBarMorph class methodsFor: 'icons' stamp: ''!
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)! !

!TreeNavigationBarMorph class methodsFor: 'icons' stamp: ''!
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)! !

!TreeNavigationBarMorph class methodsFor: 'icons' stamp: ''!
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]! !

!TreeNavigationBarMorph class methodsFor: 'icons' stamp: ''!
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)! !

!TreeNavigationBarMorph class methodsFor: 'icons' stamp: ''!
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)! !

!TreeNavigationBarMorph class methodsFor: 'icons' stamp: ''!
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)! !

!TreeNavigationBarMorph class methodsFor: 'instance creation' stamp: ''!
on: aTreeMorph pageSize: aPageSize
	^ self new treeMorph: aTreeMorph  pageSize: aPageSize! !

!TreeNodePresenter commentStamp: ''!
I represent a node in a tree widget.
I hold an item, an icon and the list of my children.

In addition, I have a filtering mechanism!
!TreeNodePresenter methodsFor: 'api' stamp: ''!
childNodeClass: aBlock

	childNodeClass value: aBlock! !

!TreeNodePresenter methodsFor: 'filtering' stamp: ''!
isEmpty
	^ self contents isEmpty! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
mouseDownAction: aBlock

	mouseDownAction value: aBlock! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
hasContentToShow

	^ hasContentToShow value! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
allSelectedItems
	| result |
	
	result := OrderedCollection new.
	self selected ifTrue: [ result add: self ].
	self children value do: [ :e | 
		result addAll: e allSelectedItems ].
	^ result! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
iconName: aSelector

	icon value: (self iconNamed: aSelector)! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
children

	^ children value! !

!TreeNodePresenter methodsFor: 'filtering' stamp: ''!
updateAccordingTo: aFilter

	(aFilter keepTreeNode: self) 
		ifFalse: [
			self changed: #updateAccordingTo: with: { aFilter } ]! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
hasChildren

	^ hasChildren value! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
childNodeClass

	^ childNodeClass value! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
isExpanded
	
	^ isExpanded value! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
buildChildren

	contents := self children value collect: [ :each || node | 
		node := each isTreeNodeModel
			ifTrue: [ each ]
			ifFalse: [  (self childNodeClassFor: each) new
				content: each  ].
		node 
			parentNode: self;
			yourself ].
		
	^ contents! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
selected
	
	^ selected value! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
icon

	^ icon value! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
parentNode: aNode

	parentNode value: aNode! !

!TreeNodePresenter methodsFor: 'filtering' stamp: ''!
contents
	^ contents ifNil: [ 
		self buildChildren.
		contents ]! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
container: anObject

	container value: anObject! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
matchTokenFilterBlock: aBlock

	matchTokenFilter value: aBlock! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
icon: anIcon

	icon value: anIcon! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
hasContentToShow: aBlock

	hasContentToShow value: aBlock! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
unselectAllChildren

	self children value do: [ :e | 
		e selected: false.
		e unselectAllChildren ].	! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
matchTokenFilterBlock

	^ matchTokenFilter value! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
allUnselectedItems
	| result |
	
	result := OrderedCollection new.
	self selected ifFalse: [ result add: self ].
	self children value do: [ :e | 
		result addAll: e allUnselectedItems ].
	^ result! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
mouseDownAction

	^ mouseDownAction value! !

!TreeNodePresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	children := [ self container childrenFor: self content ] asValueHolder.
	hasChildren := [ self container hasChildrenFor: self content ] asValueHolder.
	content := nil asValueHolder.
	icon := nil asValueHolder.
	container := nil asValueHolder.
	matchTokenFilter := [ :aFilter | false ] asValueHolder.
	parentNode := nil asValueHolder.
	childNodeClass := self class asValueHolder.
	selected := false asValueHolder.
	lastClicked := false asValueHolder.
	mouseDownAction := [:event | ] asValueHolder.
	hasContentToShow := false asValueHolder.
	isExpanded := false asValueHolder.
	
	selected whenChangedDo: [ :aBoolean | self changed: #selected: with: { aBoolean } ].
	isExpanded whenChangedDo: [ :aBoolean | self changed: #isExpanded: with: { aBoolean } ].! !

!TreeNodePresenter methodsFor: 'api - events' stamp: ''!
whenContentChanged: aBlock

	content whenChangedDo: aBlock

	! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
isExpanded: aBoolean

	isExpanded value: aBoolean! !

!TreeNodePresenter methodsFor: 'converting' stamp: ''!
isTreeNodeModel

	^ true! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
selected: aBoolean

	selected value: aBoolean! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
content: anObject

	content value: anObject! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
isPartialMatch
	| result |

	result := false.
	
	self children value do: [:each | 
		(each selected or: [ each isPartialMatch ]) ifTrue: [ result := true ] ].

	^ result! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
hasChildren: aBlock

	hasChildren value: aBlock! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
lastClicked: aBoolean

	lastClicked value: aBoolean! !

!TreeNodePresenter methodsFor: 'api - events' stamp: ''!
whenIsExpandedChanged: aBlock

	isExpanded whenChangedDo: aBlock

	! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
children: aBlock

	children value: aBlock! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
content

	^ content value! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
selectAllChildren

	self children value do: [ :e | 
		e selected: true.
		e selectAllChildren ].! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
takeHighlight

	self changed: #takeHighlight with: #()! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
container

	^ container value! !

!TreeNodePresenter methodsFor: 'api - events' stamp: ''!
whenSelectedChanged: aBlock

	selected whenChangedDo: aBlock

	! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
lastClicked
	
	^ lastClicked value! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
parentNode

	^ parentNode value! !

!TreeNodePresenter methodsFor: 'api' stamp: ''!
childNodeClassFor: anItem

	^ childNodeClass value! !

!TreeNodePresenter methodsFor: 'filtering' stamp: ''!
matchTokenFilter: aFilter

	^ self matchTokenFilterBlock value: aFilter! !

!TreeNodePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(TreeNodeAdapter
		adapt: #(model))! !

!TreeNodePresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #TreeNodeAdapter! !

!TreePagerMorph commentStamp: ''!
A tree pager!
!TreePagerMorph methodsFor: 'accessing' stamp: ''!
currentPageFirstIndex
	^ currentPageFirstIndex ifNil: [currentPageFirstIndex := 1]! !

!TreePagerMorph methodsFor: 'testing' stamp: ''!
hasSeveralPages
	^ self lastPage > 1! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
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! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
setPageInterval: anInterval
	currentPageFirstIndex := anInterval first.
	self showCurrentPage.
	self changed: #currentPage! !

!TreePagerMorph methodsFor: 'testing' stamp: ''!
notOnLastPage
	^ self onLastPage not! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
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.! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
nextPage
	self currentPageLastIndex < self nodeList size
		ifTrue: [currentPageFirstIndex := (currentPageFirstIndex + pageSize) min: self nodeList size.
			self showCurrentPage]! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
nextPage: theIndexOfAnElement
	"To make sure we can go to the page of an element."

	self currentPage: (self pageOfNodeIndex: theIndexOfAnElement)! !

!TreePagerMorph methodsFor: 'testing' stamp: ''!
notOnFirstPage
	^ self onFirstPage not! !

!TreePagerMorph methodsFor: 'testing' stamp: ''!
onFirstPage
	^ self currentPageFirstIndex = 1! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
previousPage
	self currentPageFirstIndex > 1
		ifTrue: [currentPageFirstIndex := (currentPageFirstIndex - pageSize) max: 1.
			self showCurrentPage]! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
currentPageLastIndex
	^ pageSize ifNil: [self nodeList size] ifNotNil: [(self currentPageFirstIndex + pageSize - 1) min: self nodeList size]! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
showCurrentPage
	self buildPanel.
	treeMorph scroller removeAllMorphs.
	(self nodeList isNil or: [self nodeList isEmpty]) 
		ifTrue: [^ treeMorph emptySelection].
	treeMorph addSubmorphsFromNodeList.
	treeMorph updateColumnMorphs.
	treeMorph scrollSelectionIntoView! !

!TreePagerMorph methodsFor: 'private' stamp: ''!
currentNodelist
	^ self nodeList copyFrom: self currentPageFirstIndex to: self currentPageLastIndex! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
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)]]! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
currentPageToString
	^ self currentPage asString! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
lastPage
	| p |
	p := (self nodeList size / pageSize) asInteger.
	self nodeList size \\ pageSize > 0 ifTrue: [p := p + 1].
	^ p.! !

!TreePagerMorph methodsFor: 'testing' stamp: ''!
onLastPage
	^ self currentPageLastIndex = self nodeList size! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
currentPage
	^ self currentPageLastIndex \\ pageSize > 0
		ifTrue: [(self currentPageLastIndex / pageSize) asInteger + 1]
		ifFalse: [(self currentPageLastIndex / pageSize) asInteger]! !

!TreePagerMorph methodsFor: 'accessing' stamp: ''!
currentPageInput: aString
	| input currPage |
	input := aString asString trimBoth.
	input ifEmpty: [treeMorph flash.
		^ false].
	currPage := Integer readFromString: input.
	^ self currentPage: currPage! !

!TreePagerMorph methodsFor: 'user interface' stamp: ''!
updateForNewPageSize: newPageSize
	pageSize ~= newPageSize
		ifTrue: [ |  oldLast |
			oldLast := self currentPageLastIndex.
			pageSize := newPageSize max: 1.
			currentPageFirstIndex := (oldLast + 1 - pageSize) max: 1.
			self nodeList ifNotNil: [self showCurrentPage]]! !

!TreePagerMorph methodsFor: 'navigation' stamp: ''!
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: #currentPageToString set: #currentPageInput: help: 'Index of page to view' translated class: String.
			wid hResizing: #rigid.
			wid width: (self preferedFont widthOfString: '1000000').
			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: #pageSizeToString
				set: #pageSizeFromString:
				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: '1000000').
	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! !

!TreePresenter commentStamp: ''!
I am the Spec presenter of a MorphTreeMorph tree.!
!TreePresenter methodsFor: 'api' stamp: ''!
wrapItem: anItem

	^ displayBlock value cull: anItem cull: self! !

!TreePresenter methodsFor: 'api' stamp: ''!
preferedPaneColor: aColor

	preferedPaneColor value: aColor! !

!TreePresenter methodsFor: 'api' stamp: ''!
menu: aBlock
"	< api: #block getter: #menu registration: #whenMenuChanged:>"
	"Set the block used to generate the tree menu"

	menuBlockHolder value: aBlock! !

!TreePresenter methodsFor: 'api - compatibility' stamp: ''!
childrenBlock: aBlock
	"< api: #block getter: #childrenBlock registration: #whenChildrenBlockChanged:>"
	"Set the block used to retrieve the children of a node.
	The optional block arguments are:
		- the node
		- the tree"

	childrenBlockHolder value: aBlock! !

!TreePresenter methodsFor: 'api' stamp: ''!
columns
	
	^ columns value! !

!TreePresenter methodsFor: 'api' stamp: ''!
columnInset: anInteger

	columnInset value: anInteger! !

!TreePresenter methodsFor: 'api' stamp: ''!
evenRowColor: aColor

	evenRowColor value: aColor! !

!TreePresenter methodsFor: 'api' stamp: ''!
doubleClick

	doubleClick value value! !

!TreePresenter methodsFor: 'api' stamp: ''!
beCheckList

	self isCheckList: true! !

!TreePresenter methodsFor: 'api - compatibility' stamp: ''!
hasChildrenBlock: aBlock
	"< api: #block getter: #hasChildrenBlock registration: #whenHasChildrenBlockChanged:>"
	"Set the block used to  check if a node has children.
	The optional block arguments are:
		- the node
		- the tree"

	hasChildrenBlockHolder value: aBlock! !

!TreePresenter methodsFor: 'initialization' stamp: ''!
registerEvents
	
	rootsHolder whenChangedDo: [ self updateTree ].
	childrenBlockHolder whenChangedDo: [ self updateTree ].
	hasChildrenBlockHolder whenChangedDo: [ self updateTree ].
	displayBlock whenChangedDo: [ self updateTree ].
	
	iconBlock whenChangedDo: [ self updateTree ].
	autoDeselection whenChangedDo: [ :boolean | self update: {#autoDeselection:. boolean} ].
	columns whenChangedDo: [ :col | 
		col do: [ :each | each container: self ].
		self changed: #columns: with: { col } ].
	selectionHolder whenChangedDo: [:items | self changed: { #selectItems. items } ].
	rootNodeHolder whenChangedDo: [ :aBlock | self updateTree ].
	isCheckList whenChangedDo: [ :boolean | self changed: #isCheckList: with: { boolean }].
	oddRowColor whenChangedDo: [ :aColor | self changed: #oddRowColor: with: { aColor } ].
	evenRowColor whenChangedDo: [ :aColor | self changed: #evenRowColor: with: { aColor } ].
	
	menuBlockHolder  whenChangedDo: [ :aMenuModel :oldMenuModel |
		oldMenuModel ifNotNil: [ | oldMenu |
			oldMenuModel isBlock
				ifTrue: [ 
					oldMenu := MenuPresenter new.
					oldMenuModel cull: oldMenu cull: false ]
				ifFalse: [ oldMenu := oldMenuModel ].
		oldMenu applyTo: self ].
		
		aMenuModel ifNotNil: [ | newMenu |
			aMenuModel isBlock
				ifTrue: [ 
					newMenu := MenuPresenter new.
					aMenuModel cull: newMenu cull: false ]
				ifFalse: [ newMenu := aMenuModel ].
		newMenu applyTo: self ] ].

	self announcer 
		when: WidgetBuilt
		send: #onWidgetBuilt
		to: self.! !

!TreePresenter methodsFor: 'api' stamp: ''!
allowMenuOnNoItem

	^ allowMenuOnNoItem value! !

!TreePresenter methodsFor: 'api' stamp: ''!
columnInset

	^ columnInset value! !

!TreePresenter methodsFor: 'api' stamp: ''!
roots
	"< api: #inspect>"
	"Return the tree roots"

	^ rootsHolder value! !

!TreePresenter methodsFor: 'api' stamp: ''!
resizerWidth: anInteger

	resizerWidth value: anInteger! !

!TreePresenter methodsFor: 'api' stamp: ''!
selection: aSelection
 
	self changed: #selection: with: { aSelection }! !

!TreePresenter methodsFor: 'api' stamp: ''!
keyStrokeAction: aBlock

	keyStroke value: aBlock! !

!TreePresenter methodsFor: 'api - events' stamp: ''!
whenTreeUpdated: aBlock

	treeUpdated whenChangedDo: aBlock! !

!TreePresenter methodsFor: 'api - compatibility' stamp: ''!
childrenBlock
	"< api: #inspect>"
	"Return the block used to retrieve the children of a node.
	The optional block arguments are:
		- the node
		- the tree"

	^ childrenBlockHolder value! !

!TreePresenter methodsFor: 'api - events' stamp: ''!
whenMenuChanged: aBlock
	"Set a block to perform when a new menuBlock is set"

	menuBlockHolder whenChangedDo: aBlock! !

!TreePresenter methodsFor: 'api' stamp: ''!
expandAll

	self changed: #expandAll with: #()! !

!TreePresenter methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.

	childrenBlockHolder := [ {} ] asValueHolder.
	hasChildrenBlockHolder := [ :item | (self childrenFor: item) notEmpty ] asValueHolder.
	rootsHolder := {} asValueHolder.
	selectionHolder := {} asValueHolder.
	menuBlockHolder := [] asValueHolder.
	displayBlock := [:item | item asString ] asValueHolder.
	
	removeOnlyLastSelected := false asValueHolder.
	autoDeselection := true asValueHolder.
	autoMultiSelection := false asValueHolder.
	columnInset := 5 asValueHolder.
	doubleClick := [] asValueHolder.
	allowMenuOnNoItem := false asValueHolder.
	isCheckList := false asValueHolder.
	keyStroke := [ :key | ] asValueHolder.
	multiSelection := false asValueHolder.
	evenRowColor := self theme backgroundColor asValueHolder.
	oddRowColor := self theme backgroundColor asValueHolder.
	preferedPaneColor := self theme backgroundColor asValueHolder.
	resizerWidth := 2 asValueHolder.
	rowInset := 2 asValueHolder.
	iconBlock := [ :each : node | node icon ] asValueHolder.
	highlightedItem := nil asValueHolder.
	rootNodeHolder := [ :item |
		TreeNodePresenter new 
			content: item;
			children: [ self childrenFor: item ] ] asValueHolder.
	
	columns := { TreeColumnPresenter new
		displayBlock: [:node | (self wrapItem: node content) ] } asValueHolder.
	
	autoRefreshOnExpand := false asValueHolder.
	
	"Since my nodes are already morphs, dragging them will actually extract them from their owner"
	dragTransformationBlock := [ :item :source | item complexContents ] asValueHolder.

	treeUpdated := nil asValueHolder.

	self registerEvents! !

!TreePresenter methodsFor: 'api' stamp: ''!
iconBlock: aBlock

	iconBlock value: aBlock! !

!TreePresenter methodsFor: 'api' stamp: ''!
selectOnlyLastHighlighted

	^ removeOnlyLastSelected value! !

!TreePresenter methodsFor: 'api' stamp: ''!
selectedItem
	"< api: #inspect>"
	"Return the selected item"
	"In the case of a multiple selection list, it returns the last selected item"
	
	^ selectionHolder value
		ifEmpty: [ nil ]
		ifNotEmpty: [ :col | col  last ]! !

!TreePresenter methodsFor: 'api' stamp: ''!
selectionChanged
	
	self changed: #selectionChanged with: #()! !

!TreePresenter methodsFor: 'api' stamp: ''!
columns: aCollection
	
	columns value: aCollection! !

!TreePresenter methodsFor: 'api' stamp: ''!
autoRefreshOnExpand: aBoolean
	autoRefreshOnExpand value: aBoolean! !

!TreePresenter methodsFor: 'api' stamp: ''!
deselectAll
	
	self changed: #deselectAll with: #()! !

!TreePresenter methodsFor: 'api' stamp: ''!
allowMenuOnNoItem: aBoolean

	allowMenuOnNoItem value: aBoolean! !

!TreePresenter methodsFor: 'api' stamp: ''!
oddRowColor: aColor

	oddRowColor value: aColor! !

!TreePresenter methodsFor: 'api' stamp: ''!
menu
	"<api: #inspect>"
	"Return the block used to generate the tree menu"

	^ menuBlockHolder value! !

!TreePresenter methodsFor: 'api' stamp: ''!
expandRoots

	self changed: #expandRoots with: #()! !

!TreePresenter methodsFor: 'api' stamp: ''!
hasSelectedItem
	"< api: #inspect>"
	"Return true if the tree contains any selected items"
	
	^ selectionHolder value isNotEmpty! !

!TreePresenter methodsFor: 'api' stamp: ''!
isCheckList: aBoolean

	isCheckList value: aBoolean! !

!TreePresenter methodsFor: 'api' stamp: ''!
keyStroke: aKeyStroke

	keyStroke value cull: aKeyStroke! !

!TreePresenter methodsFor: 'focus' stamp: ''!
eventKeyStrokesForPreviousFocus
	"String describing the keystroke to perform to jump to the previous widget"
	
	^ { Character tab shift asKeyCombination }! !

!TreePresenter methodsFor: 'api' stamp: ''!
autoDeselection: aBoolean

	autoDeselection value: aBoolean! !

!TreePresenter methodsFor: 'api' stamp: ''!
removeOnlyLastSelected: aBoolean

	removeOnlyLastSelected value: aBoolean! !

!TreePresenter methodsFor: 'api' stamp: ''!
autoDeselection

	^ autoDeselection value! !

!TreePresenter methodsFor: 'api' stamp: ''!
rowInset

	^ rowInset value! !

!TreePresenter methodsFor: 'api' stamp: ''!
autoMultiSelection

	^ autoMultiSelection value! !

!TreePresenter methodsFor: 'initialization' stamp: ''!
selectionChanged: ann

	^ selectionHolder value: (ann selection
		ifNil: [ #() ]
		ifNotNil: [:selection | selection selectedNodes ])! !

!TreePresenter methodsFor: 'api - events' stamp: ''!
whenSelectedItemsChanged: aBlock
	"Set a block to perform when a new item is selected"

	selectionHolder whenChangedDo: [ :col | aBlock cull: (col collect: [:e | e content ]) ]! !

!TreePresenter methodsFor: 'api' stamp: ''!
oddRowColor

	^ oddRowColor value! !

!TreePresenter methodsFor: 'api' stamp: ''!
roots: aCollection
	"< api: #st getter: #roots registration: #whenRootsChanged:>"
	"Set the tree roots"

	rootsHolder value: aCollection.
	self changed: #setRoots: with: { aCollection }! !

!TreePresenter methodsFor: 'api' stamp: ''!
doubleClick: aBlock

	doubleClick value: aBlock! !

!TreePresenter methodsFor: 'api' stamp: ''!
highlightedItem
	"<api: #inspect>"
	"Return the currently highlighted item"

	^ highlightedItem value! !

!TreePresenter methodsFor: 'api' stamp: ''!
highlightedItem: anItem
	"< api: #st getter: #highlightedItem registration: #whenHighlightedItemChanged:>"
	"Set the highlightedItem item"
	"In the case of keyboard navigation with checklist, it may differ from the last selected item"
	
	highlightedItem value: anItem! !

!TreePresenter methodsFor: 'api' stamp: ''!
multiSelection: aBoolean

	multiSelection value: aBoolean! !

!TreePresenter methodsFor: 'api' stamp: ''!
isCheckList

	^ isCheckList value! !

!TreePresenter methodsFor: 'api' stamp: ''!
multiSelection

	^ multiSelection value! !

!TreePresenter methodsFor: 'api' stamp: ''!
selectedItem: anItem
	"< api: #st getter: #selectedItem registration: #whenSelectedItemsChanged:>"
	"Set the selected item"
	"In the case of a multiple selection list, it returns the last selected item"
	
	self selectedItems: { anItem }! !

!TreePresenter methodsFor: 'api' stamp: ''!
evenRowColor

	^ evenRowColor value! !

!TreePresenter methodsFor: 'api' stamp: ''!
rootNodeHolder: aBlock

	rootNodeHolder value: aBlock! !

!TreePresenter methodsFor: 'api' stamp: ''!
selectAll
	
	self changed: #selectAdd with: #()! !

!TreePresenter methodsFor: 'api' stamp: ''!
childrenFor: anItem

	^ self childrenBlock cull: anItem cull: self! !

!TreePresenter methodsFor: 'initialization' stamp: ''!
onWidgetBuilt
	^ self selectedItems: selectionHolder value! !

!TreePresenter methodsFor: 'api' stamp: ''!
collapseAll
	
	self changed: #collapseAll with: #()! !

!TreePresenter methodsFor: 'focus' stamp: ''!
eventKeyStrokesForNextFocus
	"String describing the keystroke to perform to jump to the next widget"	
		
	^ { Character tab asKeyCombination }! !

!TreePresenter methodsFor: 'api' stamp: ''!
hasChildrenFor: anItem

	^ self hasChildrenBlock cull: anItem cull: self! !

!TreePresenter methodsFor: 'api' stamp: ''!
updateTree
	"< api: #do>"
	"Force the tree to refresh"

	self changed: #updateTree with: {}.
	treeUpdated value: nil.! !

!TreePresenter methodsFor: 'api' stamp: ''!
selectedItems: aCollection
	"<api: #st getter: #selectedItems registration: #whenSelectedItemsChanged:>"
	"Set the selected item"
	"In the case of a multiple selection list, it returns the last selected item"

	"treePresenter selectNodePath: aCollection."
	selectionHolder value: aCollection.
	! !

!TreePresenter methodsFor: 'api - compatibility' stamp: ''!
hasChildrenBlock
	"<api: #inspect>"
	"Get the block used to check if a node has children.
	The optional block arguments are:
		- the node
		- the tree"

	^ hasChildrenBlockHolder value! !

!TreePresenter methodsFor: 'api - events' stamp: ''!
whenHighlightedItemChanged: aBlock

	highlightedItem whenChangedDo: aBlock! !

!TreePresenter methodsFor: 'api - events' stamp: ''!
whenRootsChanged: aBlock

	rootsHolder whenChangedDo: aBlock! !

!TreePresenter methodsFor: 'api - compatibility' stamp: ''!
displayBlock
	"< api: #inspect>"
	"Return the block used to generate the display of the items.
	The optional block arguments are:
		- the item
		- the tree"

	^ displayBlock value! !

!TreePresenter methodsFor: 'api' stamp: ''!
autoMultiSelection: aBoolean

	autoMultiSelection value: aBoolean! !

!TreePresenter methodsFor: 'api - filtering' stamp: ''!
filterWith: aFilter
	
	self selection: nil.
	self updateTree.

	self expandAll.
	self changed: #filterWith: with: {aFilter}.
	
	self expandAll.! !

!TreePresenter methodsFor: 'api - events-compatibility' stamp: ''!
whenChildrenBlockChanged: aBlock
	"Set a block to perform when a new childrenBlock is set"

	childrenBlockHolder whenChangedDo: aBlock! !

!TreePresenter methodsFor: 'api - events-compatibility' stamp: ''!
whenSelectedItemChanged: aBlock
	"Set a block to perform when a new item is selected"

	selectionHolder whenChangedDo: [ :col | 
		col 
			ifNil: [ aBlock value: nil ]
			ifNotNil: [ col isEmpty
					ifTrue: [ aBlock value: nil ]
					ifFalse: [ aBlock value: (col last lastClicked
						ifTrue: [ col last content ]
						ifFalse: [ nil ]) ] ] ]! !

!TreePresenter methodsFor: 'api' stamp: ''!
rootNodeHolder

	^ rootNodeHolder value! !

!TreePresenter methodsFor: 'api' stamp: ''!
rowInset: anInteger

	rowInset value: anInteger! !

!TreePresenter methodsFor: 'api' stamp: ''!
preferedPaneColor

	^ preferedPaneColor value! !

!TreePresenter methodsFor: 'api - events-compatibility' stamp: ''!
whenDisplayBlockChanged: aBlock
	"Set a block to perform when a new displayBlock is set"

	displayBlock whenChangedDo: aBlock! !

!TreePresenter methodsFor: 'api' stamp: ''!
autoRefreshOnExpand
	^ autoRefreshOnExpand value! !

!TreePresenter methodsFor: 'api' stamp: ''!
resetSelection

	self selectedItems: {}! !

!TreePresenter methodsFor: 'api' stamp: ''!
rootNodeFor: item
	| node |
	
	node := self rootNodeHolder cull: item.
	node container: self.
	
	^ node! !

!TreePresenter methodsFor: 'api' stamp: ''!
menu: aMenu shifted: aBoolean
	| menu |
	
	(self allowMenuOnNoItem not and: [ self selectedItems isEmpty ])
		ifTrue: [ ^ nil ].
		
	
	menuBlockHolder value ifNil: [ ^ nil ].
	menuBlockHolder value isBlock ifFalse: [ ^ menuBlockHolder value ].
	
	menu := MenuPresenter new.
	
	menuBlockHolder value cull: menu cull: aBoolean.
	
	^ menu! !

!TreePresenter methodsFor: 'api' stamp: ''!
selectedItems
	"< api: #inspect>"
	"Return the selected items"
	
	^ selectionHolder value! !

!TreePresenter methodsFor: 'api' stamp: ''!
secondSelection: anItem
	
	self widget ifNotNil: [ :w | w listManager secondSelection: anItem ]! !

!TreePresenter methodsFor: 'api' stamp: ''!
resizerWidth

	^ resizerWidth value! !

!TreePresenter methodsFor: 'api - events-compatibility' stamp: ''!
whenHasChildrenBlockChanged: aBlock
	"Set a block to perform when a new hasChildrenBlock is set"

	hasChildrenBlockHolder whenChangedDo: aBlock! !

!TreePresenter methodsFor: 'initialization' stamp: ''!
defaultNodeFor: item

	^ TreeNodePresenter new
		content: item;
		children: [ self childrenFor: item ];
		hasChildren: [ self hasChildrenFor: item ];
		yourself! !

!TreePresenter methodsFor: 'api - compatibility' stamp: ''!
displayBlock: aBlock
	"<api: #block getter: #displayBlock registration: #whenDisplayBlockChanged:>"
	"Set the block used to generate the display of the items.
	The optional block arguments are:
		- the item
		- the tree"

	displayBlock value: aBlock! !

!TreePresenter methodsFor: 'api' stamp: ''!
iconFor: aNode

	^ iconBlock value cull: aNode content cull: aNode! !

!TreePresenter class methodsFor: 'examples' stamp: ''!
exampleWithCustomColumnsAndNodesAndChildren
	<haltOrBreakpointForTesting>
	"self exampleWithCustomColumnsAndNodesAndChildren"

	| m col1 col2 |
	m := TreePresenter new.
	m roots: #(#a #b #c #d).
	m
		rootNodeHolder: [ :item | 
			TreeNodePresenter new
				content: item;
				children: [ (1 to: item asString first asciiValue) collect: [ :e | TreeNodePresenter new content: e ] ];
				icon: (m iconNamed: #smallConfigurationIcon) ].
	m openWithSpec.
	col1 := TreeColumnPresenter new
		displayBlock: [ :node | node content asString ];
		headerAction: [ self halt ].
	col2 := TreeColumnPresenter new
		displayBlock: [ :node | (Character value: node content asString first asciiValue + 1) asString ].
	m
		columns:
			{col1.
			col2};
		dragEnabled: true;
		dropEnabled: true;
		acceptDropBlock: [ :transfer :event :source :receiver | self halt ].
	col2
		displayBlock: [ :node | (Character value: node content asString first asciiValue + 2) asString ]! !

!TreePresenter class methodsFor: 'examples' stamp: ''!
example
	<sampleInstance>
	| m |
	m := self new.
	m openWithSpec.
	m roots: #(a b c d).
	m
		childrenBlock: [ :it | 
			it = #c
				ifTrue: [ {1 . 2 . 3} ]
				ifFalse: [ {} ] ].
	m
		displayBlock: [ :item | 
			item isSymbol
				ifTrue: [ item asUppercase , ' symbol' ]
				ifFalse: [ item printString ] ].
	m
		dragEnabled: true;
		dropEnabled: true;
		wantDropBlock:
				[ :draggedItem :event :source | draggedItem isTransferable and: [ draggedItem source = m ] ];
		acceptDropBlock: [ :transfer :event :source :receiver | 
			self
				traceCr:
					('Dragged node <1s> to node <2s>'
						expandMacrosWith: transfer passenger content asString
						with: receiver content asString) ].
	^ m! !

!TreePresenter class methodsFor: 'examples' stamp: ''!
exampleWithCustomColumnsAndNodes
	<haltOrBreakpointForTesting>
	"self exampleWithCustomColumnsAndNodes"
	| m col1 col2 |

	m := TreePresenter new.
	m roots: #(#a #b #c #d).
	m rootNodeHolder: [ :item | 
		TreeNodePresenter new
			content: item;
			icon: (self iconNamed: #smallConfigurationIcon)
	].
	
	m openWithSpec.
	
	col1 := TreeColumnPresenter new
		displayBlock: [ :node | node content asString ];
		headerLabel: 'Character'.
	col2 := TreeColumnPresenter new
		displayBlock: [ :node | (Character value: node content asString first asciiValue + 1) asString ];
		headerLabel: 'Character +1';
		headerIcon: (self iconNamed: #smallBackIcon).
	
	m
		columns: {col1. col2};
		dragEnabled: true;
		dropEnabled: true;
		acceptDropBlock: [ :transfer :event :source :receiver | self halt ].
		
	col2 
		headerLabel: 'Character +2';
		headerIcon: (self iconNamed: #smallBackIcon);
		displayBlock: [ :node | (Character value: node content asString first asciiValue + 2) asString ].
	
	m rootNodeHolder: [ :item | 
		TreeNodePresenter new
			content: (Character value: (item asString first asciiValue + 5)) asSymbol;
			icon: (self iconNamed: #smallFullscreenIcon)
	].

	col1 headerIcon: (self iconNamed: #nautilusIcon).! !

!TreePresenter class methodsFor: 'examples' stamp: ''!
exampleWithNoSpecifiedNodes
	"self exampleWithNoSpecifiedNodes"

	TreePresenter new
		 roots: (1 to: 5);
		 childrenBlock: [ :item | 1+item to: 5+item ];
		 openWithSpec! !

!TreePresenter class methodsFor: 'examples' stamp: ''!
exampleOfAutoRefreshOnExpand
	"Each time a node is expanded, the computation of the children is made again, instead of being cached as it is usually"

	TreePresenter new
		childrenBlock: [ :number | 
			self logCr: 'Compute children of ', number asString.
			1 to: number ];
		hasChildrenBlock: [ :number | true ];
		roots: (1 to: 10);
		autoRefreshOnExpand: true;
		openWithSpec! !

!TreePresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	
	^ #(TreeAdapter
		adapt: #(model))! !

!TreePresenter class methodsFor: 'specs' stamp: ''!
adapterName! !

!TrianglePaintPatch commentStamp: ''!
I am a patch that interpolates linearly the colors defined along the three vertices of triangle. I am equivalent to Gouraud shading.!
!TrianglePaintPatch methodsFor: '*Athens-Cairo' stamp: ''!
addToCairoMeshGradientPaint: meshGradientPaint
	meshGradientPaint
		beginPatch;
		moveTo: controlPoints first;
		lineTo: controlPoints second;
		lineTo: controlPoints third;
		setCorner: 0 color: colors first;
		setCorner: 1 color: colors second;
		setCorner: 2 color: colors third;
		endPatch! !

!True commentStamp: ''!
True defines the behavior of its single instance, true -- logical assertion. 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.!
!True methodsFor: 'logical operations' stamp: ''!
& aBoolean 
	"Evaluating conjunction -- answer aBoolean since receiver is true."

	^aBoolean! !

!True methodsFor: 'controlling' stamp: ''!
and: alternativeBlock 
	"Nonevaluating conjunction -- answer the value of alternativeBlock since
	the receiver is true."
	"(true and: [ false ]) >>> false"
	"(true and: [ true ]) >>> true"

	^ alternativeBlock value! !

!True methodsFor: 'logical operations' stamp: ''!
| aBoolean 
	"Evaluating disjunction (OR) -- answer true since the receiver is true."

	^self! !

!True methodsFor: 'printing' stamp: ''!
printOn: aStream 

	aStream nextPutAll: 'true'! !

!True methodsFor: 'controlling' stamp: ''!
ifTrue: alternativeBlock 
	"Answer the value of alternativeBlock. Execution does not actually 
	reach here because the expression is compiled in-line."

	^alternativeBlock value! !

!True methodsFor: 'logical operations' stamp: ''!
xor: alternativeBlock
	"Nonevaluating conjunction. If the receiver is true, answer the opposite of the 
	the argument, alternativeBlock; otherwise answer the value of the alternativeBlock."
	"(true xor: [ true ]) >>> false"
	
	^ alternativeBlock value not! !

!True methodsFor: 'controlling' stamp: ''!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock 
	"Answer with the value of trueAlternativeBlock. Execution does not 
	actually reach here because the expression is compiled in-line."

	^trueAlternativeBlock value! !

!True methodsFor: 'logical operations' stamp: ''!
not
	"Negation--answer false since the receiver is true."

	^false! !

!True methodsFor: 'converting' stamp: ''!
asBit

	^ 1! !

!True methodsFor: 'controlling' stamp: ''!
or: alternativeBlock 
	"Nonevaluating disjunction -- answer true since the receiver is true."
	"(true or: [ 1 error ])>>> true"
	
	^ self! !

!True methodsFor: '*UnifiedFFI' stamp: ''!
asInteger
	
	^ 1! !

!True methodsFor: 'controlling' stamp: ''!
ifFalse: alternativeBlock 
	"Since the condition is true, the value is the true alternative, which is nil. 
	Execution does not actually reach here because the expression is compiled 
	in-line."

	^nil! !

!True methodsFor: 'controlling' stamp: ''!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 
	"Answer the value of trueAlternativeBlock. Execution does not 
	actually reach here because the expression is compiled in-line."

	^trueAlternativeBlock value! !

!True class methodsFor: '*Fuel-Core' stamp: ''!
materializeFrom: aDecoder
	"Answer my unique instance"

	^ true! !

!TrueTest commentStamp: ''!
SUnit tests for true/True class!
!TrueTest methodsFor: 'tests - logical operations' stamp: ''!
testXor
	self assert: (true xor: true) equals: false.
	self assert: (true xor: false) equals: true.
	self assert: (true xor: [ true ]) equals: false.
	self assert: (true xor: [ false ]) equals: true! !

!TrueTest methodsFor: 'tests - controlling' stamp: ''!
testAnd
	self assert: (true and: [ 'alternativeBlock' ]) equals: 'alternativeBlock'! !

!TrueTest methodsFor: 'tests - converting' stamp: ''!
testAsBit

	self assert: true asBit equals: 1! !

!TrueTest methodsFor: 'tests - logical operations' stamp: ''!
testAND

	self assert: (true & true).
	self deny: (true & false).! !

!TrueTest methodsFor: 'tests - controlling' stamp: ''!
testOr

	self assert: (true or: [ 'alternativeBlock' ])! !

!TrueTest methodsFor: 'tests - controlling' stamp: ''!
testIfFalseIfTrue
	self assert: (true ifFalse: [ 'falseAlternativeBlock' ] ifTrue: [ 'trueAlternativeBlock' ]) equals: 'trueAlternativeBlock'! !

!TrueTest methodsFor: 'tests - logical operations' stamp: ''!
testNot

	self deny: (true not).! !

!TrueTest methodsFor: 'tests - logical operations' stamp: ''!
testOR

	self assert: (true | true).
	self assert: (true | false).! !

!TrueTest methodsFor: 'tests - controlling' stamp: ''!
testIfFalse
	
	self assert: ((true ifFalse: ['alternativeBlock']) isNil).! !

!TrueTest methodsFor: 'tests - controlling' stamp: ''!
testIfTrueIfFalse
	self assert: (true ifTrue: [ 'trueAlternativeBlock' ] ifFalse: [ 'falseAlternativeBlock' ]) equals: 'trueAlternativeBlock'! !

!TrueTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ True new! !

!TrueTest methodsFor: 'tests - instance creation' stamp: ''!
testNew

	self should: [True new] raise: self defaultTestError! !

!TrueTest methodsFor: 'tests - controlling' stamp: ''!
testIfTrue
	self assert: (true ifTrue: [ 'alternativeBlock' ]) equals: 'alternativeBlock'! !

!TrueTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn
	self assert: (String streamContents: [ :stream | true printOn: stream ]) equals: 'true'! !

!TutorialPlayer commentStamp: ''!
I can navigate through an AbstractTutorial subclass (which defines lessons). With #next and #previous, you can go forward and backward through the tutorial. !
!TutorialPlayer methodsFor: 'navigating' stamp: ''!
previous
	tutorialPosition >  1 ifTrue: [ tutorialPosition := tutorialPosition  - 1 ].
	^ self currentLesson! !

!TutorialPlayer methodsFor: 'accessing' stamp: ''!
tutorial
	^ tutorial  ifNil: [ tutorial := PharoSyntaxTutorial new ]! !

!TutorialPlayer methodsFor: 'accessing' stamp: ''!
tutorialPosition: aTutorialPosition 

	tutorialPosition := aTutorialPosition! !

!TutorialPlayer methodsFor: 'navigating' stamp: ''!
next
	self tutorialPosition < self size
		ifTrue: [ tutorialPosition := tutorialPosition + 1 ].
	^ self currentLesson! !

!TutorialPlayer methodsFor: 'accessing' stamp: ''!
tutorial: aTutorialInstance
	"Set on which tutorial instance the receiver is working."
	tutorial := aTutorialInstance! !

!TutorialPlayer methodsFor: 'accessing' stamp: ''!
size
	^ self tutorial size! !

!TutorialPlayer methodsFor: 'navigating' stamp: ''!
rewind
	tutorialPosition := 1! !

!TutorialPlayer methodsFor: 'navigating' stamp: ''!
first
	"Go to the first lesson of the current tutorial and return it."
	self rewind.
	^ self currentLesson! !

!TutorialPlayer methodsFor: 'navigating' stamp: ''!
last
	"Go to the last lesson of the current tutorial and return it."
		
	tutorialPosition := self size.
	^ self currentLesson! !

!TutorialPlayer methodsFor: 'accessing' stamp: ''!
tutorialPosition
	^ tutorialPosition
		ifNil: [ 
			self rewind.
			tutorialPosition ]! !

!TutorialPlayer methodsFor: 'accessing' stamp: ''!
currentLesson
	^ self tutorial lessonAt: self tutorialPosition! !

!TutorialPlayerTutorialAccessorTest commentStamp: ''!
SUnit tests for tutorial player!
!TutorialPlayerTutorialAccessorTest methodsFor: 'tests' stamp: ''!
testWithMockTutorial
	| mockTutorial player |
	mockTutorial := MockTutorial new.
	player := TutorialPlayer new tutorial: mockTutorial; yourself.
	self assert: player tutorial equals: mockTutorial.! !

!TutorialPlayerTutorialAccessorTest methodsFor: 'tests' stamp: ''!
testDefaultsToSmalltalkSyntaxTutorial
	| player |
	player := TutorialPlayer new.
	self assert: (player tutorial isKindOf: PharoSyntaxTutorial).! !

!TutorialPlayerWithMockTutorialTest commentStamp: ''!
SUnit tests for tutorial player!
!TutorialPlayerWithMockTutorialTest methodsFor: 'tests' stamp: ''!
testResetTutorialGoBackToFirstLesson
	player next; next.
	self assert: player currentLesson title equals: 'third'.
	
	player rewind.
	self assert: player currentLesson title equals: 'first'.! !

!TutorialPlayerWithMockTutorialTest methodsFor: 'tests' stamp: ''!
testCurrentLessonIsFirstOneAtCreation
	self assert: player currentLesson title equals: 'first'.! !

!TutorialPlayerWithMockTutorialTest methodsFor: 'tests' stamp: ''!
testNavigation
	self assert: player next title equals: 'second'.
	self assert: player currentLesson title equals: 'second'.
	
	self assert: player next title equals: 'third'.
	self assert: player currentLesson title equals: 'third'.
	
	self assert: player next title equals: 'third'.
	self assert: player currentLesson title equals: 'third'.
	
	self assert: player previous title equals: 'second'.
	self assert: player currentLesson title equals: 'second'.
	
	self assert: player previous title equals: 'first'.
	self assert: player currentLesson title equals: 'first'.
	
	self assert: player previous title equals: 'first'.
	self assert: player currentLesson title equals: 'first'.! !

!TutorialPlayerWithMockTutorialTest methodsFor: 'tests' stamp: ''!
testSizeReturnsThree
	self assert: player size equals: 3.! !

!TutorialPlayerWithMockTutorialTest methodsFor: 'running' stamp: ''!
setUp
	| tutorial |
	super setUp.
	tutorial := MockTutorial new.
	player := TutorialPlayer new tutorial: tutorial! !

!TwoInARowStar methodsFor: 'API' stamp: ''!
waddle: aTree
	^ (aTree isNotNil and: [ aTree isMemberOf: ValueLink ])
		ifTrue: [ | car cdr |
			car := aTree value.
			cdr := aTree nextLink.
			(car isKindOf: Link)
				ifTrue: [ self waddle: car ]
				ifFalse: [ Continuation
						currentDo: [ :rest | 
							fill := rest.
							leave value: car ] ].
			self waddle: cdr ]! !

!TwoInARowStar methodsFor: 'API' stamp: ''!
T: anObj
	| n |
	n := self getNext: anObj.
	^ n isNotNil
		ifTrue: [ n = anObj or: [ self T: n ] ]
		ifFalse: [ false ]! !

!TwoInARowStar methodsFor: 'API' stamp: ''!
getNext: previousObj
	^ Continuation
		currentDo: [ :here_again | 
			leave := here_again.
			fill value: previousObj ]! !

!TwoInARowStar methodsFor: 'API' stamp: ''!
tree: aTree
	| fst |
	fst := Continuation
		currentDo: [ :here | 
			leave := here.
			self waddle: aTree.
			leave value: nil ].
	^ fst isSymbol
		ifTrue: [ self T: fst ]
		ifFalse: [ false ]! !

!TypingVisitor commentStamp: ''!
A visitor that does the typing for better completion. No type guessing, just using the information that's already known to the system!
!TypingVisitor methodsFor: 'visiting' stamp: ''!
visitTemporaryNode: aTemporaryNode
	(typeStack top includesKey: aTemporaryNode name) ifFalse: [^self ].
	aTemporaryNode propertyAt: #type put: (typeStack top at: aTemporaryNode name)! !

!TypingVisitor methodsFor: 'visiting' stamp: ''!
initialize

	typeStack := Stack new.
	typeStack push: Dictionary new.! !

!TypingVisitor methodsFor: 'visiting' stamp: ''!
visitBlockNode: aBlockNode
	"inside a stack we push a copy of an already existing dictionary (with the state of variables before the block) because in the block we want to know the previous state of variables, and then if inside the block the type of the variable changes we update our copy. after the block exit if the variable type has changed explicitly again, then we take after-block change, otherwise we take the last before-block type and the last inside-block type and if they are the same the type stays the same, otherwise it's updated to their common superclass, because we don't know if the block executes so want suggestions from either"
	| stackTop |
	typeStack push: typeStack top copy.
	super visitBlockNode: aBlockNode.
	stackTop := typeStack pop.
	stackTop keysDo: [ :name | 
			| type1 type2 |
			type2 := stackTop at: name.
			(typeStack top includesKey: name)
				ifFalse: [ typeStack top at: name put: type2 ]
				ifTrue: [ type1 := typeStack top at: name. 
					type1 == type2 ifFalse: [ typeStack top at: name put: (type2 commonSuperclassWith: type1) ] ] ].
	aBlockNode propertyAt: #type put: BlockClosure! !

!TypingVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralArrayNode: aLiteralNode
	 aLiteralNode propertyAt: #type put: Array! !

!TypingVisitor methodsFor: 'visiting' stamp: ''!
visitGlobalNode: aGlobalNode
	aGlobalNode
		propertyAt: #type
		put: aGlobalNode binding read class! !

!TypingVisitor methodsFor: 'visiting' stamp: ''!
visitAssignmentNode: anAssignmentNode
	"if not a temporary variable - return.
	if no type return.
	add type of a variable to a dictionary with the key being the variable's name"
	
	| variableType |
	super visitAssignmentNode: anAssignmentNode.
	anAssignmentNode variable isTempVariable ifFalse: [ ^self ].
   (anAssignmentNode value hasProperty: #type) ifFalse: [ ^self ].
	variableType := anAssignmentNode value propertyAt: #type.
	typeStack top at: anAssignmentNode variable name put: variableType.! !

!TypingVisitor methodsFor: 'visiting' stamp: ''!
visitLiteralNode: aLiteralNode
	 aLiteralNode propertyAt: #type put: aLiteralNode value class! !

!TypingVisitor methodsFor: 'visiting' stamp: ''!
visitArrayNode: aLiteralNode
	 aLiteralNode propertyAt: #type put: Array! !

!TypingVisitor methodsFor: 'visiting' stamp: ''!
visitSuperNode: aSuperNode
	| class | 
	class := aSuperNode methodNode methodClass.
	"the type of super of a Trait is not known"
	class isTrait ifTrue: [ ^self ].
	aSuperNode propertyAt: #type put: class superclass! !

!TypingVisitor methodsFor: 'visiting' stamp: ''!
visitSelfNode: aSelfNode
	aSelfNode propertyAt: #type put: aSelfNode methodNode methodClass! !

!UDPSocketEchoTest commentStamp: ''!
UDPSocketEchoTest is both a unit test and an example.
It implements and tests a UDP echo service.
Each datagram sent to it is echoed back as is.

You can also run the example manually,
by inspecting each expression separately.

  UDPSocketEchoTest new runServer.
  UDPSocketEchoTest new clientSend: 'Hello @ ', Time now asString.
  UDPSocketEchoTest new clientSend: #quit.

The server runs until it receives quit as message. If necessary, use the Process Browser to terminate a running server.!
!UDPSocketEchoTest methodsFor: 'private' stamp: ''!
receiveUDPDataFrom: socket
	"Receive a UDP datagram from socket, return a 3-element array:
	{ contents. source host address. source port }
	We wait indefinitely for incoming data."
	
	| buffer result |
	buffer := String new: 256.
	socket waitForData.
	result := socket receiveUDPDataInto: buffer.
	^ { buffer copyFrom: 1 to: result first. result second asSocketAddress. result third }! !

!UDPSocketEchoTest methodsFor: 'testing' stamp: ''!
testEcho
	| socket message result |
	
	socket := Socket newUDP.
	[ 
		self withUDPEchoServer: [ :process |
			message := 'Testing ', 99 atRandom asString. 
			socket sendUDPData: message toHost: self localhost port: self port.
			result := self receiveUDPDataFrom: socket.
			self assert: result first equals: message.
			self assert: result second equals: self localhost.
			self assert: result third equals: self port.
			socket sendUDPData: #quit toHost: self localhost port: self port ]  
	] ensure: [ socket closeAndDestroy ]! !

!UDPSocketEchoTest methodsFor: 'testing' stamp: ''!
runServer
	"Run and return a local UDP echo server"
	
	^ self withUDPEchoServer: [ :process | process ]! !

!UDPSocketEchoTest methodsFor: 'accessing' stamp: ''!
port
	"Return the port where the UDP echo service runs"

	^ 6666! !

!UDPSocketEchoTest methodsFor: 'accessing' stamp: ''!
localhost
	"Return the host address where the UDP echo service runs, the local host address"
	
	^ NetNameResolver localHostAddress! !

!UDPSocketEchoTest methodsFor: 'testing' stamp: ''!
clientSend: message
	"Send message to the local UDP echo service and return the result"
	
	| socket |
	socket := Socket newUDP.
	^ [ 
		socket sendUDPData: message toHost: self localhost port: self port.
		self receiveUDPDataFrom: socket ] 
			ensure: [ socket closeAndDestroy ]! !

!UDPSocketEchoTest methodsFor: 'private' stamp: ''!
withUDPEchoServer: block
	"Run a local UDP echo server on localhost:port and execute block.
	Optionally pass the new process to block. When quit is received, stop the server"
	
	| socket loop result process |
	socket := Socket newUDP setPort: self port; yourself.
	loop := true.
	process := [ 
		[ [ loop ] whileTrue: [ 
			result := self receiveUDPDataFrom: socket.
			"echo what we received to where it came from"
			socket sendUDPData: result first toHost: result second port: result third.
			result first asLowercase = #quit ifTrue: [ loop := false ] ] ]
				ensure: [ socket closeAndDestroy ] ] 
					forkAt: Processor userBackgroundPriority named: 'UDP echo server'.
	^ block cull: process! !

!UDPSocketTest methodsFor: 'tests' stamp: ''!
testUDPBroadcastError
	"Test that we get a specific error when failure is due to sending to a broadcast address without SO_BROADCAST set"
	"Use 255.255.255.255 for testing, which in RFC 919 is defined as 'denoting a broadcast on a local hardware network, which must not be forwarded. 
	This address may be used, for example, by hosts that do not know their network number and are asking some server for it.'"

	self
		should: [ 
			Socket newUDP
				setOption: 'SO_BROADCAST' value: false;
				sendUDPData: #[] toHost: #[255 255 255 255] port: 1950 ]
		raise: NoBroadcastAllowed.
	self
		shouldnt: [ 
			Socket newUDP
				setOption: 'SO_BROADCAST' value: true;
				sendUDPData: #[] toHost: #[255 255 255 255] port: 1 ]
		raise: NoBroadcastAllowed! !

!UDPSocketTest methodsFor: 'support' stamp: ''!
faultyUDPSocket

	| cls |
	
	cls := Socket newAnonymousSubclass .
	
	"the mock socket is not sending anything, so there is nothing to wait for"
	cls compile: 'waitForSendDoneFor: aNumber ^ true'.
	
	"compile the primitive to not send, but return a 0 count for any send"
	cls compile: 'primSocket: socketID sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber startIndex: startIndex count: count ^ 0'.
	
	^ cls newUDP! !

!UDPSocketTest methodsFor: 'tests' stamp: ''!
testUDPFaultySend

	| socket host |
	
	socket := self faultyUDPSocket.	
	host := #[1 2 3 4].
	
	"Check that sending is not caught in a infinite loop"
	self should: [ 
		
		self 
			deny: (socket isBroadcastAddress: host);
			should: [socket sendUDPData: #[123] toHost: host port: 1 ] raise: NetworkError.
			
		host := #[ 255 255 255 255].
		
		self 
			assert: (socket isBroadcastAddress: host);
			should: [ socket sendUDPData: #[123] toHost: host port: 1 ] raise: NoBroadcastAllowed.
			
		socket setOption: 'SO_BROADCAST' value: true.
		
		self should: [ socket sendUDPData: #[123] toHost: host port: 1 ] raise: NetworkError.
		
	] notTakeMoreThanMilliseconds: 20.

	socket destroy! !

!UIManager commentStamp: ''!
UIManager is a dispatcher for various UI requests.!
!UIManager methodsFor: 'ui requests' stamp: ''!
multiLineRequest: queryString initialAnswer: defaultAnswer answerHeight: answerHeight
	"Create a multi-line instance of me whose question is queryString with
	 the given initial answer. Invoke it centered at the given point, and
	 answer the string the user accepts.  Answer nil if the user cancels.  An
	 empty string returned means that the ussr cleared the editing area and
	 then hit 'accept'.  Because multiple lines are invited, we ask that the user
	 use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 
	 submit; that way, the return key can be typed to move to the next line."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
deny: aStringOrText title: aString
	"Open a denial dialog."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'ui requests' stamp: ''!
merge: merger informing: aString

	self subclassResponsibility! !

!UIManager methodsFor: 'events' stamp: ''!
onPrimitiveError: aString	! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
question: aStringOrText
	"Open a question dialog."
	
	^self subclassResponsibility ! !

!UIManager methodsFor: 'ui process' stamp: ''!
spawnNewProcessIfThisIsUI: suspendedProcess

	self uiProcess == suspendedProcess ifTrue: [
		self spawnNewProcess.
		^true
	].
	^false		"no new process was created"
! !

!UIManager methodsFor: '*Iceberg-Plugin-GitHub' stamp: ''!
inform: aString actionOnClick: aBlock
	"Only the MorphicUIManager should make the growl clickable."
	
	^ self inform: aString! !

!UIManager methodsFor: 'display' stamp: ''!
restoreDisplay	
	
	self subclassResponsibility ! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseDirectory: label from: dir
	"Let the user choose a directory."

	^self subclassResponsibility! !

!UIManager methodsFor: 'non-interactive' stamp: ''!
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: self! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseDirectoryFrom: dir
	"Let the user choose a directory"

	^self chooseDirectory: nil from: dir! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFullFileNameMatching: patterns
	"Let the user choose a file matching the given patterns"
	
	^self chooseFullFileNameMatching: patterns label: nil! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: labelList values: valueList title: aString
	"Choose an item from the given list. Answer the selected item."
	
	^self chooseFrom: labelList values: valueList lines: #() title: aString! !

!UIManager methodsFor: '*Jobs' stamp: ''!
displayProgress: titleString from: minVal to: maxVal during: workBlock
	"SystemProgressMorph show: titleString from: minVal to:  during: "

	^ workBlock asJob
			title: titleString;
			min: minVal;
			max: maxVal;
			run! !

!UIManager methodsFor: 'error handling' stamp: ''!
handleError: anError log: shouldLog

	self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList
	"Choose an item from the given list. Answer the index of the selected item."
	
	^self chooseFrom: aList lines: #()! !

!UIManager methodsFor: 'ui requests' stamp: ''!
newMenuIn: aThemedMorph for: aModel
	"Answer a new menu."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
textEntry: aStringOrText
	"Open a text entry dialog."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList lines: linesArray
	"Choose an item from the given list. Answer the index of the selected item."
	
	^self chooseFrom: aList lines: linesArray title: ''! !

!UIManager methodsFor: 'private' stamp: ''!
beDefault

	self class default: self! !

!UIManager methodsFor: 'ui requests' stamp: ''!
edit: aText label: labelString accept: aBlockOrNil
	"Open an editor on the given string/text."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui process' stamp: ''!
terminateUIProcess
	"Do nothing by default."! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFullFileNameMatching: patterns label: labelString
	"Let the user choose a file matching the given patterns"
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString label: titleString
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
questionWithoutCancel: aStringOrText
	"Open a question dialog."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseDirectory: label
	"Let the user choose a directory."

	^self chooseDirectory: label from: FileSystem workingDirectory! !

!UIManager methodsFor: 'ui requests' stamp: ''!
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."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList message: messageString
	"Choose an item from the given list. Answer the index of the selected item."
	
	^self chooseFrom: aList lines: #() message: messageString! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList values: valueList lines: linesArray message: messageString
	"Choose an item from the given list. Answer the index of the selected item."
	
	^self chooseFrom: aList values: valueList lines: linesArray message: messageString title: ''! !

!UIManager methodsFor: 'display' stamp: ''!
restoreDisplayAfter: aBlock	
	
	self subclassResponsibility ! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
alert: aStringOrText title: aString
	"Open an alert dialog."
	
	^self subclassResponsibility ! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList message: messageString title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	
	^self chooseFrom: aList lines: #() message: messageString title: aString! !

!UIManager methodsFor: 'debug requests' stamp: ''!
handleWarningDebugRequest: aWarningDebugRequest fromDebuggerSystem: anOupsDebuggerSystem
	"Handle warning notification. Should be overidden by subclass."
		
	self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
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."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
request: aStringOrText initialAnswer: defaultAnswer title: aTitle
	"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 subclassResponsibility! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
textEntry: aStringOrText title: aString entryText: defaultEntryText
	"Open a text entry dialog."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'default actions' stamp: ''!
lowSpaceWatcherDefaultAction: preemptedProcess

	"When there is a signal from the VM, we signal an exception in the preempted process.
	If we don't have preemptedProcess we are in an error state. We will throw an error"

	preemptedProcess 
		ifNotNil: [ preemptedProcess signalException: OutOfMemory new.
						^ self ].

	self error: 'We have a lowSpaceWatcher signal, but there is no ctx... how we arrive here'.! !

!UIManager methodsFor: 'ui requests' stamp: ''!
request: queryString initialAnswer: defaultAnswer entryCompletion: anEntryCompletion
	"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 subclassResponsibility! !

!UIManager methodsFor: '*Files-Prompt' stamp: ''!
fileDoesNotExistsDefaultAction: anException

	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString label: title 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."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui process' stamp: ''!
defer: aBlock
	"Evaluate the given Block in the UI thread as soon as there is nothing scheduled. 
	 Evaluate immediately when there is no UI"
	
	aBlock value! !

!UIManager methodsFor: 'default actions' stamp: ''!
unhandledErrorDefaultAction: anException
	"Provide a default handling for unhandled error. 
	 We should never reach this code, because it should be overridden by subclasses. 
	 (but we can't put 'self subclassResponsibility' , because it will cause infinite loop,
	 in case if current ui manager having no override of this method).
	 This method is only for documentation purposes."
		
	Smalltalk snapshot: false andQuit: true.! !

!UIManager methodsFor: 'ui requests' stamp: ''!
request: queryString entryCompletion: anEntryCompletion
	"Create an instance of me whose question is queryString. Invoke it 
	 centered at the cursor, and answer the string the user accepts. Answer 
	 the empty string if the user cancels."
	
	^self request: queryString initialAnswer: '' entryCompletion: anEntryCompletion! !

!UIManager methodsFor: 'error handling' stamp: ''!
logError: anError

	Smalltalk
		logError: anError messageText
		inContext: anError signalerContext! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList values: valueList message: messageString title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	
	^self chooseFrom: aList values: valueList lines: #() message: messageString title: aString! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
question: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	 false if no and nil if cancelled."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'display' stamp: ''!
showWaitCursorWhile: aBlock
	| process |
	process := [ [ true ] "loop until the end of aBlock processing"
		whileTrue: [ 
			Smalltalk logStdErrorDuring: [ :stream |
				"Wait wheel in ASCII art"
				'\|/-'
					do: [ :char |
						stream << char.
						0.1 second wait.
						stream << Character backspace ] ] ] ] fork.
	[ aBlock value ]
		ensure: [ process terminate ]! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: labelList values: valueList
	"Choose an item from the given list. Answer the selected item."
	
	^self chooseFrom: labelList values: valueList lines: #()! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
abort: aStringOrText title: aString
	"Open an error dialog."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
alert: aStringOrText title: aString configure: aBlock
	"Open an alert dialog.
	 Configure the dialog with the 1 argument block before opening modally."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'ui requests' stamp: ''!
edit: aText
	"Open an editor on the given string/text."
	
	^self edit: aText label: nil! !

!UIManager methodsFor: 'default actions' stamp: ''!
onFontsChanged

	! !

!UIManager methodsFor: 'private' stamp: ''!
activate! !

!UIManager methodsFor: 'debug' stamp: ''!
debugProcess: process context: context label: title fullView: bool notification: notificationString

	self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
request: queryString initialAnswer: defaultAnswer
	"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 subclassResponsibility! !

!UIManager methodsFor: '*Regex-Core' stamp: ''!
request: aTitleString regex: initialRegexString
	"Prompt the user for a valid regex.
	 Return nil on cancel or a valid RxMatcher"
	| regex |
	regex := initialRegexString.
	"loop until we get a valid regex string back"
	[
		regex := UIManager default 
			multiLineRequest: aTitleString 
			initialAnswer: regex 
			answerHeight: 200.
		"cancelled dialog ==> nil"	
		regex ifNil: [ ^ nil ].
		
		[ ^ regex asRegex ] on: Error do: [ :regexParsingError|
			self defer: [	self inform: 'Bad Regex: ', regexParsingError asString ]].
	] repeat! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
proceed: aStringOrText
	"Open a proceed dialog."
	
	^self subclassResponsibility ! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseOrRequestFrom: labelList values: valueList lines: linesArray title: aString

	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	
	^self chooseFrom: aList lines: #() title: aString! !

!UIManager methodsFor: 'ui requests' stamp: ''!
edit: aText label: labelString
	"Open an editor on the given string/text."
	
	^self edit: aText label: labelString accept: nil! !

!UIManager methodsFor: 'ui requests' stamp: ''!
informUser: aString during: aBlock
	"Display a message above (or below if insufficient room) the cursor 
	 during execution of the given block.
		UIManager default informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait].
	"
	
	^self informUserDuring: [:bar | bar label: aString. aBlock value]! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseDirectory
	"Let the user choose a directory."
	
	^self chooseDirectoryFrom: FileSystem workingDirectory! !

!UIManager methodsFor: 'debug requests' stamp: ''!
handleDebugRequest: aDebugRequest fromDebuggerSystem: anOupsDebuggerSystem
	"Provide a default handling for unhandled error. 
	 We should never reach this code, because it should be overridden by subclasses. 
	 (but we can't put 'self subclassResponsibility' , because it will cause infinite loop,
	 in case if current ui manager having no override of this method).
	 This method is only for documentation purposes."
	self flag: 'Code smell: can someone explain why we have this code if we should never reach it? And if we do, why quitting without any information? Finally, why the self subclassResponsibility produces an infinite loop?'.
	Smalltalk snapshot: false andQuit: true! !

!UIManager methodsFor: 'default actions' stamp: ''!
systemNotificationDefaultAction: aNotification

	"by default, do nothing"
	
	aNotification resume.! !

!UIManager methodsFor: 'ui requests' stamp: ''!
confirm: queryString trueChoice: trueChoice falseChoice: falseChoice cancelChoice: cancelChoice default: aSymbol
	"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.
	Default should be one of #yes, #no or #cancel 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."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
textEntry: aStringOrText title: aString
	"Open a text entry dialog."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'ui process' stamp: ''!
spawnNewProcess
	"Do nothing by default."! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: labelList values: valueList lines: linesArray message: messageString title: aString
	"Choose an item from the given list. Answer the selected item."
	
	^self
		chooseFrom: labelList
		values: valueList 
		lines: linesArray
		title: (aString 
				ifEmpty: [ messageString ]
				ifNotEmpty: [ aString, String cr, messageString ])! !

!UIManager methodsFor: 'ui requests' stamp: ''!
informUserDuring: aBlock
	"Display a message above (or below if insufficient room) the cursor 
	during execution of the given block.
		UIManager default informUserDuring:[:bar|
			#(one two three) do:[:info|
				bar label: info.
				(Delay forSeconds: 1) wait]]"
		
	^self subclassResponsibility! !

!UIManager methodsFor: 'events' stamp: ''!
onEventSensorStartup: anEventSensor

! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
questionWithoutCancel: aStringOrText title: aString
	"Open a question dialog and answer true if yes,
	 false if no and nil if cancelled."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'ui requests' stamp: ''!
fontFromUser: priorFont	
	
	self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
openComparisionFrom: targetMethodSource to: originalMethodSource belongingTo: aClass from: aChange
					 
	^self subclassResponsibility				! !

!UIManager methodsFor: 'ui process' stamp: ''!
interruptName: labelString preemptedProcess: theInterruptedProcess
	"Create a Notifier on the active scheduling process with the given label."

	^self error: 'Cannot perform a given request'! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: labelList values: valueList lines: linesArray
	"Choose an item from the given list. Answer the selected item."
	
	^self chooseFrom: labelList values: valueList lines: linesArray title: ''! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
deny: aStringOrText
	"Open a denial dialog."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'debug requests' stamp: ''!
requestDebuggerOpeningForWarning: aWarning

	<debuggerCompleteToSender>
	
	Smalltalk logError: aWarning printString inContext: aWarning signalerContext.	
	
	self class environment
		at: #OupsWarningRequest
		ifPresent: [ :requestClass | 
			(requestClass newForException:  aWarning)			
				submit.
			^ self ].! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: labelList values: valueList lines: linesArray title: aString
	"Choose an item from the given list. Answer the selected item."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList lines: linesArray message: messageString
	"Choose an item from the given list. Answer the index of the selected item."
	
	^self chooseFrom: aList lines: linesArray message: messageString title: ''! !

!UIManager methodsFor: 'display' stamp: ''!
newDisplayDepthNoRestore: pixelSize	
	
	self subclassResponsibility ! !

!UIManager methodsFor: 'default actions' stamp: ''!
warningDefaultAction: aWarning
	"Handle warning notification. Should be overidden by subclass."
	
	self subclassResponsibility  ! !

!UIManager methodsFor: 'error handling' stamp: ''!
handleError: anError
	
	self handleError: anError log: true! !

!UIManager methodsFor: 'ui requests' stamp: ''!
request: queryString 
	"Create an instance of me whose question is queryString. Invoke it 
	 centered at the cursor, and answer the string the user accepts. Answer 
	 the empty string if the user cancels."
	
	^self request: queryString initialAnswer: ''! !

!UIManager methodsFor: 'accessing' stamp: ''!
headlessManager
	"Answer an instance of headless manager, which will be used when image runs headless 
	 and non-interactive. We put it here, so subclasses can override it."
	
	^CommandLineUIManager replacing: self! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList values: valueList message: messageString
	"Choose an item from the given list. Answer the index of the selected item."
	
	^self chooseFrom: aList values: valueList lines: #() message: messageString! !

!UIManager methodsFor: 'debug requests' stamp: ''!
requestDebuggerOpeningForProcess: aProcess named: title inContext: aContext

	<debuggerCompleteToSender>

	Smalltalk logError: aContext printString inContext: aContext.
	
	self class environment
		at: #OupsDebugRequest
		ifPresent: [ :requestClass | 
			(requestClass newForContext: aContext)
				process: aProcess;
				label: title;
				submit.
			^ self ].
! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList lines: linesArray title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
inform: aString
	"Display a message for the user to read and then dismiss."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
requestPassword: queryString
	"Create an instance of me whose question is queryString. Invoke it centered
	 at the cursor, and answer the string the user accepts. Answer the empty 
	 string if the user cancels."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
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 subclassResponsibility! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
alert: aStringOrText
	"Open an alert dialog."
	
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
proceed: aStringOrText title: aString
	"Open a proceed dialog and answer true if not cancelled, false otherwise."
	
	^self subclassResponsibility ! !

!UIManager methodsFor: 'debug requests' stamp: ''!
requestDebuggerOpeningFor: anException

	<debuggerCompleteToSender>
	Smalltalk logError: anException printString inContext: anException signalerContext.	
	
	self class environment
		at: #OupsDebugRequest
		ifPresent: [ :requestClass | 
			(requestClass newForException: anException) submit.
			^ self ].
! !

!UIManager methodsFor: 'ui requests' stamp: ''!
chooseFrom: aList lines: linesArray message: messageString title: aString
	"Choose an item from the given list. Answer the selected item."
	
	^self
		chooseFrom: aList
		lines: linesArray
		title: (aString 
				ifEmpty: [ messageString ]
				ifNotEmpty: [ aString, String cr, messageString ])! !

!UIManager methodsFor: '*Files-Prompt' stamp: ''!
fileExistsDefaultAction: anException

	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: ''!
request: aStringOrText initialAnswer: defaultAnswer title: aTitle entryCompletion: anEntryCompletion
	"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 subclassResponsibility! !

!UIManager methodsFor: 'ui TEasilyThemed' stamp: ''!
abort: aStringOrText
	"Open an error dialog."

	^self subclassResponsibility ! !

!UIManager methodsFor: 'debug requests' stamp: ''!
requestDebuggerOpeningNamed: title inContext: aContext

	<debuggerCompleteToSender>
	Smalltalk logError: aContext printString inContext: aContext.	

	self class environment
		at: #OupsDebugRequest
		ifPresent: [ :requestClass | 
			(requestClass newForContext: aContext)
				label: title;
				submit.
			^ self ].! !

!UIManager methodsFor: 'default actions' stamp: ''!
syntaxErrorNotificationDefaultAction: anException

	^ self subclassResponsibility ! !

!UIManager methodsFor: 'private' stamp: ''!
deactivate! !

!UIManager class methodsFor: 'testing' stamp: ''!
isValidForCurrentSystemConfiguration

	^false! !

!UIManager class methodsFor: 'initialization' stamp: ''!
default
	^ Default
		ifNil: [ 
			"Note: The way the following is phrased ensures that you can always make 'more specific' managers merely by subclassing a tool builder and implementing a more specific way of reacting to #isActiveManager. For example, a BobsUIManager can subclass MorphicUIManager and will be considered before the parent (generic MorphicUIManager)."
			self allSubclasses
				detect: [ :any | any isActiveManager and: [ any subclasses noneSatisfy: [ :sub | sub isActiveManager ] ] ]
				ifFound: [ :mgrClass | Default := mgrClass new ].
			Default ]! !

!UIManager class methodsFor: 'initialization' stamp: ''!
isActiveManager
	"Answer whether I should act as the active UI manager."
	
	^false! !

!UIManager class methodsFor: 'initialization' stamp: ''!
default: aUIManager

	Default ifNotNil: [ :mgr | mgr deactivate ].
	Default := aUIManager.
	Default activate! !

!UIManager class methodsFor: 'initialization' stamp: ''!
forCurrentSystemConfiguration

	^ (self allSubclasses
			detect: [ :any | 
				any isValidForCurrentSystemConfiguration
					and: [ any subclasses noneSatisfy: #isValidForCurrentSystemConfiguration ] ]
			ifNone: [ NonInteractiveUIManager ]) 
			new! !

!UIManager class methodsFor: 'utilities' stamp: ''!
nonInteractiveDuring: aBlock
	| currentManager |
	currentManager := self default.
	currentManager nonInteractiveManager.
	
	aBlock ensure: [ currentManager beDefault ]! !

!UIManagerSessionHandler commentStamp: ''!
I am a session handler that will initialize the UIManager during startup.

This session handler makes the assumption that the current UIManager is a startup UI manager when its #startup: method gets called. Then, during startup he will install a Morphic UI manager.

During shutdown we put back a startup ui manager, so we can handle startup actions during next startup without depending in the UI. (However, we shouldn't need a UI manager during the first startup actions).!
!UIManagerSessionHandler methodsFor: 'accessing' stamp: ''!
handledId
	^ self class name! !

!UIManagerSessionHandler methodsFor: 'handlers' stamp: ''!
startup: isImageStarting
	"Install the right UIManager"
	
	UIManager default: UIManager forCurrentSystemConfiguration.
		
! !

!UIManagerSessionHandler methodsFor: 'handlers' stamp: ''!
shutdown: isImageQuitting

	"Prepare the shutdown and the next startup"

	UIManager default: StartupUIManager new.
! !

!UIManagerSessionHandler class methodsFor: 'class initialization' stamp: ''!
initialize
	"has to be executed at the end of the user category"
	SessionManager default 
		register: self uniqueInstance
		inCategory: SessionManager default userCategory  
		atPriority: SmallInteger maxVal! !

!UIManagerSessionHandler class methodsFor: 'accessing' stamp: ''!
uniqueInstance
	^ UniqueInstance ifNil: [ UniqueInstance := self new ]! !

!UITheme commentStamp: ''!
Common superclass for User Interface themes. Provides methods for creating new morphs in a standard way, various "services" like a file dialog, message dialogs etc. and also methods for customising aspects of the appearance of various morphs.
Though conceptually abstract, no code is "missing". Subclasses, therefore, should override the aspects they wish to change.!
!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonPressedBorderStyleFor: aButton
	"Return the pressed button borderStyle for the given button."

	^self buttonSelectedBorderStyleFor: aButton! !

!UITheme methodsFor: 'label-styles' stamp: ''!
scrollbarArrowOfDirection: aSymbol size: finalSizeInteger color: aColor
	"Answer a new scrollbar arrow form (normally cached by Scrollbar)."
	
	^self basicCreateArrowOfDirection: aSymbol size: finalSizeInteger color: aColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newHueSelectorIn: aThemedMorph for: aModel getHue: getSel setHue: setSel help: helpText
	"Answer a hue selector ."

	^(HColorSelectorMorph
			on: aModel
			getValue: getSel
			setValue: setSel)
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		setBalloonText: helpText! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newMorphListIn: aThemedMorph for: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a morph list for the given model."

	^(PluggableMorphListMorph
			on: aModel
			list: listSelector
			selected: getSelector
			changeSelected: setSelector
			menu: nil
			keystroke: nil)
		selectionColor: self selectionColor;
		autoDeselect: false;
		cornerStyle: aThemedMorph preferredCornerStyle;
		color: Color white;
		borderStyle: (BorderStyle inset width: 1);
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		getEnabledSelector: enabledSel;
		setBalloonText: helpText! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarMouseOverButtonBorderStyleFor: aScrollbar
	"Return the mouse over button borderStyle for the given scrollbar."

	^self scrollbarNormalButtonBorderStyleFor: aScrollbar! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarMouseOverThumbBorderStyleFor: aScrollbar
	"Return the mouse over thumb borderStyle for the given scrollbar."

	^self scrollbarNormalThumbBorderStyleFor: aScrollbar! !

!UITheme methodsFor: 'border-styles' stamp: ''!
scrollPaneDisabledBorderStyleFor: aScrollPane
	"Return the disabled borderStyle for the given scroll pane."

	^self scrollPaneNormalBorderStyleFor: aScrollPane! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonMiddleLeftForm
	"Answer the form to use for the middle left of a button."

	^self forms at: #buttonMiddleLeft ifAbsent: [Form extent: 11@1 depth: Display depth]! !

!UITheme methodsFor: 'defaults' stamp: ''!
buttonFont
	"Answer the button font to use."

	^StandardFonts buttonFont! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
controlButtonDisabledFillStyleFor: aButton
	"Return the disabled control button fillStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."
	
	^self controlButtonSelectedFillStyleFor: aButton! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonColouredFillStyleFor: aButton
	"Return the coloured button fillStyle for the given button."
	
	|round roundCorners tl t tr l m r bl b br|
	round := aButton wantsRoundedCorners.
	roundCorners := aButton roundedCorners.
	tl := (round and: [roundCorners includes: 1]) ifTrue: [self buttonSelectedTopLeftForm] ifFalse: [self buttonSquareSelectedTopLeftForm].
	t := self buttonSelectedTopMiddleForm.
	tr:= (round and: [roundCorners includes: 4]) ifTrue: [self buttonSelectedTopRightForm] ifFalse: [self buttonSquareSelectedTopRightForm].
	l := self buttonSelectedMiddleLeftForm. m := self buttonColouredMiddleColor. r := self buttonSelectedMiddleRightForm.
	bl := (round and: [roundCorners includes: 2]) ifTrue: [self buttonSelectedBottomLeftForm] ifFalse: [self buttonSquareSelectedBottomLeftForm].
	b := self buttonSelectedBottomMiddleForm.
	br := (round and: [roundCorners includes: 3]) ifTrue: [self buttonSelectedBottomRightForm] ifFalse: [self buttonSquareSelectedBottomRightForm].
	^self
		multiFormFillStyleFrom: {tl. t. tr. l. m. r. bl. b. br}
		in: aButton bounds! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonPressedFillStyleFor: aButton
	"Return the button pressed fillStyle for the given button."
		
	^self buttonSelectedFillStyleFor: aButton! !

!UITheme methodsFor: 'morph creation' stamp: ''!
scrollBarDownButtonBoundsFor: aScrollbar
	
	| extent position |
	
	extent := aScrollbar buttonExtent.
	position := aScrollbar innerBounds bottomRight - extent.	

	^ position extent: extent! !

!UITheme methodsFor: 'accessing' stamp: ''!
fadedBackgroundWindows
	^ self settings fadedBackgroundWindows! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newCloseButtonIn: aThemedMorph for: aModel
	"Answer a new close button."

	^self
		newButtonIn: aThemedMorph
		for: aModel
		getState: nil
		action: #close
		arguments: nil
		getEnabled: nil
		label: 'Close' translated
		help: 'Close the window' translated! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
treeLineColorsFrom: aColor
	"Answer the colours to use for the tree lines.
	The given colour is the preferred colour."

	^{aColor. Color transparent}! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSelectedTopMiddleForm
	"Answer the form for the top middle of a selected button."

	^(Form
	extent: 1@12
	depth: 32
	fromArray: #( 3966269361 4291941599 4292994026 4292205027 4291547356 4290889943 4290297809 4289640652 4289114568 4288588740 4288128705 4286353587)
	offset: 0@0)! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
dangerTextColor
	^ Color red darker darker! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newSeparatorIn: aThemedMorph
	"Answer a new horizontal separator."

	^SeparatorMorph new
		fillStyle: Color transparent;
		borderStyle: (BorderStyle inset baseColor: Color blue; width: 1);
		extent: 2@2;
		hResizing: #spaceFill! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowCloseOverForm
	"Answer the form to use for mouse over window close buttons"

	^(self forms at: #windowCloseOver ifAbsent: [Form extent: 16@16 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonMiddleRightForm
	"Answer the form for the middle right of a button."

	^(Form
	extent: 12@1
	depth: 32
	fromArray: #( 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 3934750599)
	offset: 0@0)! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSquareTopRightForm
	"Answer the form for the top right of a square button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3954422707 3250240186 549042617 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293585642 4290690750 4289243304 2931341496 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4292598747 4289374890 3887182257 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4292664540 4289638062 3937184940 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4292532954 4289901234 3936987561 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4292467161 4290164406 3936658596 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4292401368 4290427578 3936329631 4293059298 4293059298 4293059298 4293059298 4293059298 4292993505 4292993505 4292993505 4292993505 4292335575 4290690750 3936132252 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292401368 4291019715 3935803287 4292796126 4292796126 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292401368 4291282887 3935540115 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292467161 4291546059 3935276943 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292203989 4291809231 3935013771)
	offset: 0@0)! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
checkboxButtonSelectedDisabledBorderStyleFor: aCheckboxButton
	"Return the selected disabled checkbox button borderStyle for the given button."

	^self checkboxButtonDisabledBorderStyleFor: aCheckboxButton! !

!UITheme methodsFor: 'services' stamp: ''!
longMessageIn: aThemedMorph text: aStringOrText title: aString
	"Answer the result of a (potentially long) message dialog (true) with the given label and title."

	self messageSound play.
	^((LongMessageDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: aStringOrText) openModal cancelled not! !

!UITheme methodsFor: 'initialization' stamp: ''!
newWindowMinimizeOverForm
	"Answer a new form for a window menu box."

	^ self newWindowMinimizeForm! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
dialogWindowActiveFillStyleFor: aWindow
	"Return the window active fillStyle for the given window."
	
	^self windowActiveFillStyleFor: aWindow! !

!UITheme methodsFor: 'fill-styles-menubar' stamp: ''!
menubarFillStyleFor: aMenubar
	^ self taskbarFillStyleFor: aMenubar! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newColumnIn: aThemedMorph for: controls
	"Answer a morph laid out with a column of controls."

	|answer|
	answer := PanelMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		fillStyle: Color transparent; "non pane color tracking"
		changeTableLayout;
		cellInset: 8;
		cellPositioning: #leftCenter.
	controls do: [:m | answer addMorphBack: m].
	^answer! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
createArrowOfDirection: aSymbolDirection size: finalSizeInteger color: aColor 
	"Defer to current UITheme if available."
	
	^self
		scrollbarArrowOfDirection: aSymbolDirection
		size: finalSizeInteger
		color: aColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
scrollBarUpButtonBoundsFor: aScrollbar
	^ aScrollbar innerBounds topLeft extent: aScrollbar buttonExtent! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
scrollbarThumbBottomForm
	"Answer the form to use for the bottom of a vertical scrollbar."

	^self forms at: #sbVThumbBottom ifAbsent: [Form extent: 13@7 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarFillStyleFor: aTaskbar
	^ SolidFillStyle color: Color transparent! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonMouseOverFillStyleFor: aButton
	"Return the button mouse over fillStyle for the given color."

	^self buttonNormalFillStyleFor: aButton! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
windowInactiveLabelFillStyleFor: aWindow
	"Return the window inactive label fillStyle for the given window."
	
	^ self fadedBackgroundWindows
		ifTrue: [ aWindow paneColorToUse alphaMixed: 0.6 with: Color black ]
		ifFalse: [ self windowActiveLabelFillStyleFor: aWindow ]! !

!UITheme methodsFor: 'configure' stamp: ''!
configureSystemWindow: aWindow 
	aWindow basicBorderColor: Color lightGray.
	aWindow basicBorderWidth: 1.
	aWindow color: Color lightGray lighter lighter lighter.	
	self
		configureWindowBorderFor: aWindow;
		configureWindowDropShadowFor: aWindow.! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newDialogPanelIn: aThemedMorph
	"Answer a new (main) dialog panel."

	^(self newPanelIn: aThemedMorph)
		fillStyle: (SolidFillStyle color: Color transparent) "no pane colour tracking"! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newTabGroupIn: aThemedMorph for: labelsAndControls
	"Answer a tab group morph with the given tab labels and associated pages."

	^(TabGroupMorph new
		font: self labelFont;
		cornerStyle: (self tabGroupCornerStyleIn: aThemedMorph);
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		labelsAndPages: labelsAndControls)
		selectedPageIndex: (labelsAndControls isEmpty ifTrue: [0] ifFalse: [1])! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonPlainMiddleColor
	"Return the middle area colour for a plain button fillStyle."
	
	^Color r: 211 g: 211 b: 211 range: 255! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
buttonColor 
	^ self settings buttonColor! !

!UITheme methodsFor: 'services' stamp: ''!
centeredAlertIn: aThemedMorph text: aStringOrText title: aString configure: aBlock
	"Answer the result of an alert dialog (true) with the given label and title."

	| dialog |
	SoundTheme useThemeSounds ifTrue: [ self alertSound play ].
	dialog := (AlertDialogWindow newWithTheme: aThemedMorph theme)
		textFont: self textFont;
		title: aString;
		text: aStringOrText.
	aBlock value: dialog.
	dialog left: ((self currentWorld width / 2) - (dialog width /2)).
	dialog top: ((self currentWorld height / 2) - (dialog height /2)).
	dialog openModal.
	^ dialog cancelled not! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
controlButtonSelectedDisabledFillStyleFor: aButton
	"Return the selected disabled control button fillStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."
	
	^self controlButtonSelectedFillStyleFor: aButton! !

!UITheme methodsFor: 'border-styles' stamp: ''!
drawWindowInactiveDropShadowFor: aSystemWindow on: aCanvas
	"Draw the inactive drop shadow for the given window."
	
	self drawWindowPlainDropShadowFor: aSystemWindow on: aCanvas! !

!UITheme methodsFor: 'initialization' stamp: ''!
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)! !

!UITheme methodsFor: 'private' stamp: ''!
normalFillStyleWithBaseColor: aColor for: aMorph height: anInteger	
	| top bottom |
	top := aColor darker.
	bottom := aColor.
	^(GradientFillStyle ramp: {
			0.0->top.
			0.7->bottom.})
		origin: aMorph bounds origin;
		direction: 0 @ anInteger;
		radial: false! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
checkboxSelectedForm
	"Answer the form to use for a selected checkbox."

	^ self iconNamed: #checkboxSelectedForm! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
caretColor
	^ Color blue! !

!UITheme methodsFor: 'label-styles' stamp: ''!
configureDialogWindowLabelAreaFrameFor: aWindow
	"Configure the layout frame for the label area for the given dialog window."

	|frame|
	self configureWindowLabelAreaFrameFor: aWindow.
	aWindow labelArea ifNil: [^ self].	
	frame := aWindow labelArea layoutFrame.
	frame
		leftOffset: 0;
		rightOffset: 0! !

!UITheme methodsFor: 'border-styles' stamp: ''!
textFocusBoundsFor: aPluggableTextMorph
	"Answer the bounds for drawing the focus indication."

	^aPluggableTextMorph bounds! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newRadioButtonIn: aThemedMorph for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: label help: helpText
	"Answer a checkbox (radio button appearance) with the given label ."

	| answer |
	answer := CheckboxMorph
			on: aModel selected: getSel changeSelected: setSel.
	answer
		getEnabledSelector: enabledSel;
		label: label;
		labelMorph: (self checkboxLabelFor: answer);
		font: self labelFont;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		setBalloonText: helpText;
		beRadioButton.
	^answer! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
taskbarItemLabelColorForCollapsed: aButton
	"Answer the colour for the label of the given taskbar button, given that the corresponding window is collapsed."
	
	^Color darkGray! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
listBackgroundColor
	^ self backgroundColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newImageIn: aThemedMorph for: aModel get: getSel help: helpText
	"Answer a new image morph."

	^AlphaImageMorph new
		model: aModel;
		borderStyle: (BorderStyle inset width: 0);
		getImageSelector: getSel;
		setBalloonText: helpText;
		updateImage! !

!UITheme methodsFor: 'services' stamp: ''!
messageIn: aThemedMorph text: aStringOrText title: aString
	"Answer the result of a message dialog (true) with the given label and title."

	self messageSound play.
	^((MessageDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: aStringOrText) openModal cancelled not! !

!UITheme methodsFor: 'defaults' stamp: ''!
labelFont
	"Answer the label font to use."

	^self textFont! !

!UITheme methodsFor: 'defaults' stamp: ''!
menuBarFont
	"Answer the menu bar font to use."

	^self textFont! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSquareSelectedBottomRightForm
	"Answer the form for the bottom right of a selected square button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 3931727240 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285170861 3931595651 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 3931464061 4285763767 4285763767 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 3931200888 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 3931003251 4286356417 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 3930871661 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 3930674280 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 3930476899 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 3930345054 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 4287541460 4287541460 4287541460 4286948549 3778691918 4285038229 4285038229 4285038229 4285038485 4285038485 4285038485 4285038485 4285038485 4285038485 4284841105 4232796519 2452040237 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3392025400 2351311407 622599196)
	offset: 0@0)! !

!UITheme methodsFor: 'services' stamp: ''!
chooseIn: aThemedMorph title: title message: aMessage labels: labels values: values lines: lines
	"Answer the result of a popup choice with the given title, labels, values and lines."

	|dialog|
	dialog := (PopupChoiceDialogWindowWithMessage newWithTheme: aThemedMorph theme)
		title: (title isEmpty ifTrue: ['Choose' translated] ifFalse: [title asString]);
		textFont: self textFont;
		message: aMessage;
		labels: labels;
		lines: (lines ifNil: [#()]);
		model: values.
	^dialog openModal choice! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSelectedMiddleRightForm
	"Answer the form for the middle right of a selected button."

	^(Form
	extent: 12@1
	depth: 32
	fromArray: #( 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 3931727240)
	offset: 0@0)! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
radioButtonNormalFillStyleFor: aRadioButton
	"Return the normal radio button fillStyle for the given button."
	
	^(ImageFillStyle form: self radioButtonForm) origin: aRadioButton topLeft! !

!UITheme methodsFor: 'defaults' stamp: ''!
selectionColorForFrame: frame 

	^ self selectionColor! !

!UITheme methodsFor: 'accessing' stamp: ''!
useAnimation: aBoolean
	^ self animationSettings useAnimation: aBoolean! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
controlButtonPressedFillStyleFor: aButton
	"Return the pressed button fillStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."
	
	^self controlButtonSelectedFillStyleFor: aButton! !

!UITheme methodsFor: 'accessing' stamp: ''!
focusIndicator
	"Answer the value of focusIndicator"

	^ focusIndicator! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarPressedButtonFillStyleFor: aScrollbar
	"Return the pressed scrollbar button fillStyle for the given scrollbar."
	
	^self scrollbarPressedThumbFillStyleFor: aScrollbar! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
radioButtonForm
	"Answer the form to use for a normal radio button."

	^ self iconNamed: #radioButtonUnselectedForm! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarNormalHorizontalThumbFillStyleFor: aScrollbar
	"Return the normal scrollbar horizontal thumb fillStyle for the given scrollbar."
	
	|s l m r|
	s := aScrollbar slider.
	l := self scrollbarThumbLeftForm.
	m := self scrollbarThumbHorizontalMiddleForm.
	r := self scrollbarThumbRightForm.
	^CompositeFillStyle fillStyles: {
		(ImageFillStyle form: l) origin: s topLeft.
		(AlphaInfiniteForm with: m)
			origin: s topLeft + (l width@0);
			extent: (s width - l width - r width)@m height.
		(ImageFillStyle form: r)
			origin: s topRight - (r width@0)}! !

!UITheme methodsFor: 'configure' stamp: ''!
configurePluggableTextFieldMorph: textFieldMorph! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newMultistateButtonIn: aThemedMorph
	"Answer a new multistate button morph."

	^MultistateButtonMorph new! !

!UITheme methodsFor: 'accessing' stamp: ''!
settings: anObject
	"Set the value of settings"

	settings := anObject! !

!UITheme methodsFor: 'sounds' stamp: ''!
windowMinimizeSound
	"Answer the window minimize sound."

	^self soundTheme windowMinimizeSound! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowClosePassiveForm
	"Answer the form to use for passive (background) window close buttons"

	^ self iconNamed: #windowCloseInactiveForm! !

!UITheme methodsFor: 'sounds' stamp: ''!
alertSound
	"Answer the alert sound."

	^self soundTheme alertSound! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
multiFormFillStyleFrom: anArray cornerWidths: widthArray in: aRectangle
	"Answer a composite fill style from the given forms and central colour
	in the given bounds. Use the widths specified for the portion of the
	corner forms to display."
	
	|tl tm tr ml mr bl bm br c tlw trw blw brw|
	tl := anArray first. tlw:= widthArray first.
	tm := anArray second.
	tr := anArray third. trw := widthArray second.
	ml  := anArray fourth.
	c := anArray fifth.
	mr  := anArray sixth.
	bl := anArray seventh. blw := widthArray third.
	bm := anArray eighth.
	br := anArray ninth. brw := widthArray fourth.
	^CompositeFillStyle fillStyles: {
		(ImageFillStyle form: tl)
			origin: aRectangle topLeft;
			extent: tlw@tl height.
		(AlphaInfiniteForm with: tm)
			origin: aRectangle topLeft + (tlw@0);
			extent: (aRectangle width - trw - tlw)@tm height.
		(ImageFillStyle form: tr)
			origin: aRectangle topRight - (tr width@0);
			extent: trw@tr height;
			offset: (tr width - trw)@0.
		(AlphaInfiniteForm with: ml)
			origin: aRectangle topLeft + (0@tl height);
			extent: ml width@(aRectangle height - tl height - bl height).
		(ColorFillStyle color: c)
			origin: aRectangle topLeft + (tlw@tl height);
			extent: aRectangle extent - (tlw@tl height) - (brw@br height).
		(AlphaInfiniteForm with: mr)
			origin: aRectangle topRight + (trw negated@tr height);
			extent: mr width@(aRectangle height - tr height - br height).
		(ImageFillStyle form: bl)
			origin: aRectangle bottomLeft - (0@bl height);
			extent: blw@bl height.
		(AlphaInfiniteForm with: bm)
			origin: aRectangle bottomLeft - (blw negated@bl height);
			extent: (aRectangle width - blw - brw)@bm height.
		(ImageFillStyle form: br)
			origin: aRectangle bottomRight - br extent;
			extent: brw@br height;
			offset: (br width - brw)@0}! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
lightBackgroundColor 
	^ Color veryLightGray muchLighter! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
createBoxOfSize: finalSizeInteger color: aColor 
	"PRIVATE - create a box with finalSizeInteger and aColor  
	 
	Try with:  
	(UITheme current createBoxOfSize: 32 color: Color lightGreen) 
          asMorph openInHand.  
	"
	| resizeFactor outerBox innerBox resizedForm |
	resizeFactor := 4.
	outerBox := Morph new.
	outerBox extent: finalSizeInteger asPoint * resizeFactor;
		 color: aColor.
	""
	innerBox := self createBoxIn: outerBox bounds.
	self updateScrollBarButtonAspect: innerBox color: aColor muchDarker.
	outerBox addMorphCentered: innerBox.
	""
	resizedForm := outerBox imageForm
				magnify: outerBox imageForm boundingBox
				by: 1 / resizeFactor
				smoothing: 4.
	""
	^ (resizedForm replaceColor: aColor withColor: Color transparent)
		trimBordersOfColor: Color transparent! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSelectedBottomLeftForm
	"Answer the form to use for the bottom left of a selected button."

	^self forms at: #buttonSelectedBottomLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
controlButtonSelectedDisabledBorderStyleFor: aButton
	"Return the selected disabled control button borderStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."

	^self buttonSelectedDisabledBorderStyleFor: aButton! !

!UITheme methodsFor: 'defaults' stamp: ''!
listFont
	"Answer the list font to use."

	^StandardFonts listFont! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
sliderNormalFillStyleFor: aSlider
	"Return the normal fillStyle for the given slider."
	
	^ SolidFillStyle color: Color white! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonBottomLeftForm
	"Answer the form to use for the bottom left of a button."

	^self forms at: #buttonBottomLeft ifAbsent: [Form extent: 11@11 depth: Display depth]! !

!UITheme methodsFor: 'forms' stamp: ''!
checkboxUnselectedForm
	"Answer the form to use for a selected checkbox."

	^ self iconNamed: #checkboxUnselectedForm! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
separatorFillStyleFor: aSeparator
	"Return the separator fillStyle for the given separator."
	
	^ SolidFillStyle color: (self baseColorFor: aSeparator) darker! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
desktopColor

	^(Color r: 240 g: 240 b: 240 range: 255)! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowMenuIconFor: aWindow
	"Answer the menu icon for the given window."
	
	^ self windowMenuForm! !

!UITheme methodsFor: 'defaults' stamp: ''!
buttonFocusIndicatorCornerRadiusFor: aButton
	"Answer the default corner radius preferred for the focus indicator
	for the button for themes that support this."

	^aButton wantsRoundedCorners
		ifTrue: [7]
		ifFalse: [2]! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
tabLabelSelectedFillStyleFor: aTabLabel
	^ self buttonSelectedFillStyleFor: aTabLabel! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
textEditorDisabledFillStyleFor: aTextEditor
	"Return the disabled fillStyle for the given text editor."
	
	^self basePassiveBackgroundColorFor: aTextEditor! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
lightBaseColor

	^ self class lightBaseColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newLabelIn: aThemedMorph label: aString
	"Answer a new text label."

	^self
		newLabelIn: aThemedMorph
		for: nil
		label: aString
		getEnabled: nil! !

!UITheme methodsFor: 'private' stamp: ''!
basePassiveBackgroundColorFor: aButton
	^ self class basePassiveBackgroundColor! !

!UITheme methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
configureWatcherWindowLabelAreaFor: aWindow
	"Configure the label area for the given Watcher window."

	|padding|
	padding := 0.
	aWindow labelArea
		addMorphBack: (Morph new extent: aWindow class borderWidth @ 0).
	aWindow hasCloseBox ifTrue: [aWindow addCloseBox. padding := padding + 1].
"	aWindow hasCollapseBox ifTrue: [aWindow addCollapseBox. padding := padding + 1].
	aWindow hasExpandBox ifTrue: [aWindow addExpandBox. padding := padding + 1].
	aWindow hasMenuBox ifTrue: [padding := padding - 1].
"	aWindow labelArea
		addMorphBack: (Morph new extent: aWindow class borderWidth @ 0; hResizing: #spaceFill).
	aWindow basicLabel ifNotNil: [:label | aWindow labelArea addMorphBack: label; hResizing: #shrinkWrap].
	aWindow labelArea
		addMorphBack: (Morph new extent: aWindow class borderWidth @ 0; hResizing: #spaceFill).
	padding > 0 ifTrue: [
		aWindow labelArea
			addMorphBack: (Morph new extent: (aWindow boxExtent x * padding) @ 0)].
"	aWindow hasMenuBox ifTrue: [aWindow addMenuControl]."
	aWindow labelArea
		addMorphBack: (Morph new extent: aWindow class borderWidth @ 0)! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
radioButtonSelectedDisabledBorderStyleFor: aRadioButton
	"Return the selecteddisabled radio button borderStyle for the given button."

	^self radioButtonDisabledBorderStyleFor: aRadioButton! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarNormalThumbFillStyleFor: aScrollbar
	"Return the normal scrollbar fillStyle for the given scrollbar."
	^ self normalFillStyleFor: aScrollbar height: aScrollbar height! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newImageIn: aThemedMorph form: aForm size: aPoint
	"Answer a new image morph."

	^AlphaImageMorph new
		borderStyle: (BorderStyle inset width: 0);
		image: aForm size: aPoint! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
balloonBackgroundColor

	^self lightBaseColor! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
textFieldDisabledFillStyleFor: aTextField
	"Return the disabled fillStyle for the given text field."
	
	^self textEditorDisabledFillStyleFor: aTextField! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSquareTopLeftForm
	"Answer the form for the top left of a square button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 633520834 3333994680 3954422707 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3032004792 4289243304 4290822336 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 3920736689 4289374890 4292730333 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 3970805165 4289638062 4292796126 4293783021 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 3970476200 4289901234 4292664540 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 3970278821 4290164406 4292532954 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 3970015649 4290493371 4292532954 4293190884 4293190884 4293190884 4293125091 4293125091 4293190884 4293190884 4293190884 4293190884 3969686684 4290756543 4292467161 4292993505 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 3969423512 4291019715 4292467161 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 3969160340 4291282887 4292467161 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 3968831375 4291546059 4292467161 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 3968568203 4291809231 4292203989 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575)
	offset: 0@0)! !

!UITheme methodsFor: 'copying' stamp: ''!
postCopy
	"Copy the settings too."
	
	super postCopy.
	self settings: self settings copy! !

!UITheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemNormalFillStyleFor: aButton
	"Return the normal taskbar item fillStyle for the given button."
	
	^ self buttonNormalFillStyleFor: aButton! !

!UITheme methodsFor: 'border-styles' stamp: ''!
drawWindowActiveDropShadowFor: aSystemWindow on: aCanvas
	"Draw the active drop shadow for the given window."
	
	
	^self windowActiveDropShadowStyle == #diffuse
		ifTrue: [self drawWindowDiffuseDropShadowFor: aSystemWindow on: aCanvas]
		ifFalse: [self drawWindowPlainDropShadowFor: aSystemWindow on: aCanvas]! !

!UITheme methodsFor: 'services' stamp: ''!
chooseDropListIn: aThemedMorph text: aStringOrText title: aString list: aList
	"Answer the result of a drop list chooser with the given label, title and list."

	^((ChooseDropListDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: aStringOrText;
			list: aList) openModal selectedItem! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSquareBottomRightForm
	"Answer the form for the bottom right of a square button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 3934750599 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292335575 3934421634 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 3934158462 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 3933895290 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 3933632118 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 3933368946 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 3933039981 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 3932776809 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 3932447844 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4293388263 3780400212 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289243304 4235556213 2452565807 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3393076798 2352034097 622599196)
	offset: 0@0)! !

!UITheme methodsFor: 'defaults' stamp: ''!
tabSelectorCellInsetFor: aTabSelector
	"Answer the cell inset to use for the given tab selector."

	^0! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
warningBackgroundColor
	^ Color yellow! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
splitterNormalFillStyleFor: aSplitter
	"Return the normal splitter fillStyle for the given splitter."
	
	^ SolidFillStyle color: Color transparent! !

!UITheme methodsFor: 'initialization' stamp: ''!
newWindowMaximizeForm
	"Answer a new form for a window maximize box."

	^ self iconNamed: #windowMaximizeForm! !

!UITheme methodsFor: 'initialization' stamp: ''!
newWindowMinimizeForm
	"Answer a new form for a window minimize box."

	^ self iconNamed: #windowMinimizeForm! !

!UITheme methodsFor: 'label-styles' stamp: ''!
menuPinForm
	"Answer the form to use for the pin button of a menu."

	^ self iconNamed: #menuPinForm! !

!UITheme methodsFor: 'accessing' stamp: ''!
windowActiveDropShadowStyle
	"Answer the style of drop shadow to use for active windows."
	
	^windowActiveDropShadowStyle! !

!UITheme methodsFor: '*Iceberg-TipUI' stamp: ''!
badgeTextColor
	^ Color white! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newFuzzyLabelIn: aThemedMorph for: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel
	"Answer a new fuzzy label."

	^(FuzzyLabelMorph contents: aString font: self labelFont)
		offset: offset;
		alpha: alpha;
		model: aModel;
		getEnabledSelector: enabledSel! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowMinimizeOverForm
	"Answer the form to use for mouse over window minimize buttons"

	^(self forms at: #windowMinimizeOver ifAbsent: [Form extent: 16@16 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: 'defaults' stamp: ''!
textFont
	"Answer the text font to use."

	^StandardFonts defaultFont! !

!UITheme methodsFor: 'accessing' stamp: ''!
borderWidth
	^ 1 * self displayScaleFactor! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
treeLineDashes
	"Answer the dash lengths to use for the tree lines."

	^#(1 1)! !

!UITheme methodsFor: 'sounds' stamp: ''!
windowRestoreUpSound
	"Answer the window restore up sound."

	^self soundTheme windowRestoreUpSound! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
controlButtonPressedBorderStyleFor: aButton
	"Return the pressed control button borderStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."

	^self buttonPressedBorderStyleFor: aButton! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
dialogWindowInactiveFillStyleFor: aWindow
	"Return the window active fillStyle for the given window."
	
	^self windowInactiveFillStyleFor: aWindow! !

!UITheme methodsFor: 'services' stamp: ''!
chooseFileIn: aThemedMorph title: title extensions: exts path: path preview: preview
	"Answer the result of a file open dialog with the given title, extensions path and preview type.
	Answer nil or a filename."

	| dialog |
	dialog := FileDialogWindow basicNew
		basicTheme: aThemedMorph theme;
		previewType: preview;
		initialize;
		title: title;
		answerFileEntry.
	exts ifNotNil: [ dialog validExtensions: exts ].
	path ifNotNil: [ dialog selectPath: path ].
	^ dialog openModal answer! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
controlButtonMouseOverBorderStyleFor: aButton
	"Return the mouse over control button borderStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."

	^self buttonMouseOverBorderStyleFor: aButton! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSquareSelectedBottomRightForm
	"Answer the form to use for the bottom right of a selected square button."

	^self forms at: #buttonSquareSelectedBottomRight ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'accessing' stamp: ''!
soundTheme: anObject
	"Set the sound theme specific to this instance of ui theme,"

	soundTheme := anObject! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newLabelGroupIn: aThemedMorph for: labelsAndControls
	"Answer a morph laid out with a column of labels and a column of associated controls.
	The vResizing for each row will be #spaceFill if the control for that row specifies
	this, otherwise #shrinkWrap."

	| labels labelWidth lc |
	lc := labelsAndControls collect: [:a |
		(a key isMorph
			ifTrue: [a key]
			ifFalse: [a key ifNotNil: [self newLabelIn: aThemedMorph label: a key asString]])
			-> a value].
	labels := Morph new
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		changeTableLayout.
	lc do: [:a |
		a key ifNotNil: [labels addMorphBack: a key]].
	labelWidth := labels minExtent x.
	^self newColumnIn: aThemedMorph for: (lc collect: [:a | | row |
		a key ifNotNil: [a key hResizing: #rigid; extent: labelWidth@ a key height].
		row := self newRowIn: aThemedMorph for: (a key ifNil: [{a value}] ifNotNil: [{a key. a value}]).
		row vResizing: (a value vResizing = #spaceFill ifTrue: [#spaceFill] ifFalse: [#shrinkWrap]).
		row])! !

!UITheme methodsFor: '*DrTests' stamp: ''!
testColorFailure
	"Should be in SUnit-Core extention methods, but Sunit is used in the bootstrap."
	^ Color yellow darker darker darker! !

!UITheme methodsFor: 'accessing' stamp: ''!
shStyleTable

	"Styling depends on shout. If it is not present, means there is no style 
	 table to apply"
	^ (self class environment classNamed: #SHRBTextStyler)
		ifNotNil: [ :aClass | aClass perform: self shStyleTableName ]
		ifNil: [ #() ]! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
useScrollbarThumbShadow
	"Answer whether a shadow morph should be displayed when
	dragging a scrollbar thumb."
	
	"If for some reason it's nil, reinitialice to 'false'."
	
	useScrollbarThumbShadow ifNil:[useScrollbarThumbShadow:=false].

	^useScrollbarThumbShadow! !

!UITheme methodsFor: 'services' stamp: ''!
chooseFontIn: aThemedMorph title: aString font: aFont
	"Answer the result of a font selector dialog with the given title and initial font."

	| dialog |
	dialog :=  Cursor wait showWhile: [
		self newFontSelector
			basicTheme: aThemedMorph theme;
			title: aString;
			selectedFont: aFont].
	dialog openModal.
	^ dialog cancelled ifFalse: [dialog selectedFont]! !

!UITheme methodsFor: 'initialization' stamp: ''!
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)! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newCheckboxIn: aThemedMorph for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: label help: helpText
	"Answer a checkbox with the given label ."

	| answer |
	answer := CheckboxMorph
			on: aModel selected: getSel changeSelected: setSel.
	answer
		getEnabledSelector: enabledSel;
		label: label;
		labelMorph: (self checkboxLabelFor: answer);
		font: self labelFont;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		setBalloonText: helpText.
	^answer! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
selectionColor
	"Answer the selection color to use.."

	^ self settings selectionColor! !

!UITheme methodsFor: '*Morphic-Widgets-FastTable' stamp: ''!
fastTableHeaderColor
	^ self lightBackgroundColor! !

!UITheme methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
popoverButtonColor

	^ self darkBaseColor! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
checkboxButtonNormalFillStyleFor: aCheckboxButton
	"Return the normal checkbox button fillStyle for the given checkbox button."
	
	^(ImageFillStyle form: self checkboxForm) origin: aCheckboxButton topLeft! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonSelectedPressedBorderStyleFor: aButton
	"Return the selected pressed button borderStyle for the given button."

	^self buttonNormalBorderStyleFor: aButton! !

!UITheme methodsFor: 'sounds' stamp: ''!
questionSound
	"Answer the question sound."

	^self soundTheme questionSound! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newWindowIn: aThemedMorph for: aModel title: titleString
	"Answer a new StandardWindow with given model and title."

	^StandardWindow new
		title: titleString;
		model: aModel;
		yourself! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowMenuOverForm
	"Answer the form to use for mouse over window menu buttons"

	^(self forms at: #windowMenuOver ifAbsent: [Form extent: 16@16 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: 'label-styles' stamp: ''!
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! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
createBoxImagesCache
	"Creates the cache to store the arrow forms"
	
	^ LRUCache new
		maximumWeight: 20;
		factory: [ :key |
			self createBoxOfSize: key first color: key second ];
		yourself! !

!UITheme methodsFor: 'defaults' stamp: ''!
treeLineWidth
	"Answer the width of the tree lines."

	^0! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
checkboxButtonDisabledFillStyleFor: aCheckboxButton
	"Return the disabled checkbox button fillStyle for the given button."
	
	^self checkboxButtonNormalFillStyleFor: aCheckboxButton! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newButtonIn: aThemedMorph for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: label help: helpText
	"Answer a new button."

	| button |
	^ (button := PluggableButtonMorph on: aModel getState: stateSel action: actionSel)
		theme: self;
		arguments: (args ifNil: [ {button} ]);
		cornerStyle: (self buttonCornerStyleIn: aThemedMorph);
		label: label font: self buttonFont;
		getEnabledSelector: enabledSel;
		setBalloonText: helpText;
		extent: button minExtent;
		hResizing: #rigid;
		vResizing: #rigid;
		removeProperty: #theme;
		yourself! !

!UITheme methodsFor: 'border-styles' stamp: ''!
textFieldNormalBorderStyleFor: aTextField
	"Return the normal text field borderStyle for the given text field."

	^self textEditorNormalBorderStyleFor: aTextField! !

!UITheme methodsFor: 'defaults' stamp: ''!
windowLeftOffset

	^ 0! !

!UITheme methodsFor: 'defaults' stamp: ''!
windowPreferredCornerStyleFor: aWindow
	"Answer the preferred corner style for the given window."

	aWindow isEmbedded ifTrue: [^#square].
	^(self settings preferRoundCorner  or: [
			aWindow cornerStyle == #rounded])
		ifTrue: [#rounded]
		ifFalse: [#square]! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonSelectedDisabledFillStyleFor: aButton
	"Return the button selected disabled fillStyle for the given color."
	
	^self buttonSelectedFillStyleFor: aButton! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
desktopImageLayout
	"Answer the layout symbol for any desktop image.
	See AlphaImageMorph>>layoutSymbols."

	^self settings desktopImageLayout! !

!UITheme methodsFor: 'defaults' stamp: ''!
buttonMinHeight
	"Answer the minumum height of a button for this theme."
	
	^ 18 * self displayScaleFactor! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
selectedItemListTextColor
	"Answer the color for the selected item in a list text."

	^ self textColor! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
windowColorFor: aWindowOrModel 
	"Answer the colour for the given window."

	^ self settings windowColor! !

!UITheme methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
watcherWindowActiveFillStyleFor: aWindow

	^ SolidFillStyle color: (Color veryVeryLightGray alpha: 0.6)! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
worldMainDockingBarColorFor: aDockingBar
	"Answer the base colour to use for a world main docking bar in this theme."

	^self settings derivedMenuColor! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarMouseOverButtonFillStyleFor: aScrollbar
	"Return the scrollbar mouse over button fillStyle for the given color."

	^self scrollbarNormalButtonFillStyleFor: aScrollbar! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
ghostTextColor

	^ Color lightGray! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
controlButtonNormalBorderStyleFor: aButton
	"Return the normal control button borderStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."

	^self buttonNormalBorderStyleFor: aButton! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newToolSpacerIn: aThemedMorph
	"Answer a new tool spacer."

	^Morph new
		borderWidth: 0;
		color: Color transparent;
		extent: 3@3! !

!UITheme methodsFor: 'border-styles' stamp: ''!
buttonBorderStyleFor: aButton
	aButton borderStyle: BorderStyle thinGray! !

!UITheme methodsFor: '*DrTests' stamp: ''!
testColorPassing
	"Should be in SUnit-Core extention methods, but Sunit is used in the bootstrap."
	^ Color green darker darker! !

!UITheme methodsFor: 'initialization' stamp: ''!
defaultSettings
	"Answer the default settings."

	^self class defaultSettings copy! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
menuTitleFillStyleFor: aMenuTitle
	"Return the fillStyle for the given title menu."
	| fill |

	fill := GradientFillStyle ramp: {0.0 -> aMenuTitle color twiceLighter. 1 -> aMenuTitle color twiceDarker}.
	fill
		origin: aMenuTitle topLeft;
		direction: aMenuTitle width @ 0.
	^ fill! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
checkboxButtonSelectedDisabledFillStyleFor: aCheckboxButton
	"Return the selected disabled checkbox button fillStyle for the given button."
	
	^self checkboxButtonSelectedFillStyleFor:  aCheckboxButton! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
menuBorderColor
	^  self settings menuBorderColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newScrollBarDownButtonFor: aScrollbar
	^ BorderedMorph newBounds: (self scrollBarDownButtonBoundsFor: aScrollbar)! !

!UITheme methodsFor: 'fill-styles-menubar' stamp: ''!
menubarItemSelectionFillStyleFor: aMenubarItem
	^ self menuSelectionColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newLabelIn: aThemedMorph for: aModel getLabel: labelSel getEnabled: enabledSel
	"Answer a new text label."

	^(LabelMorph contents: '' font: self labelFont)
		model: aModel;
		getEnabledSelector: enabledSel;
		getTextSelector: labelSel! !

!UITheme methodsFor: 'initialization' stamp: ''!
newWindowMenuOverForm
	"Answer a new form for a window menu box when the mouse is over it."

	^(Form
	extent: 24@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 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4293257970 4287735753 4284054189 4281884573 4281490073 4281555866 4281555866 4281555866 4281555866 4281555866 4281555866 4281555866 4281555866 4281490073 4281884573 4284054189 4287735753 4293257970 0 0 0 0 0 4293192178 4286026172 4283462312 4287538375 4289970905 4290759648 4291088354 4291022817 4291022817 4291088354 4291088354 4291022817 4291022817 4291088354 4290759648 4289970905 4287538375 4283462312 4286026172 4293192178 0 0 0 0 4287735753 4283265191 4288721616 4292074729 4293060849 4293455092 4293652469 4293652469 4293652469 4293652469 4293652469 4293652469 4293652469 4293652469 4293455092 4293060849 4292074729 4288721616 4283265191 4287801545 0 0 0 0 4284185518 4286420927 4290233820 4291877352 4292468972 4292535021 4292535021 4292535021 4292534765 4292534765 4292534765 4292534765 4292535021 4292535021 4292535021 4292468972 4291877352 4290233820 4286420927 4284185518 0 0 0 0 4282476193 4288261581 4290759648 4291351268 4291680231 4291746023 4291811559 4291811559 4291746023 4291680231 4291680231 4291746023 4291811559 4291811559 4291746023 4291680231 4291351268 4290759648 4288261581 4282476193 0 0 0 0 4282673314 4289116371 4291614438 4292403180 4292797935 4292929264 4293060849 4292929264 4292995056 4293060849 4293060849 4292995056 4292929264 4293060849 4292929264 4292797935 4292403180 4291614438 4289116371 4282607522 0 0 0 0 4284645809 4288655823 4291746023 4293323763 4294244090 4294638589 4294507004 4294638589 4294572796 4294638589 4294638589 4294572796 4294638589 4294507004 4294638589 4294244090 4293323763 4291746023 4288655823 4284645809 0 0 0 0 4287669960 4284514224 4290891232 4293323763 4294704381 4294835710 4294901503 4294901503 4294901503 4294901503 4294901503 4294901503 4294901503 4294901503 4294835710 4294704381 4293323763 4290891232 4284514224 4287669960 0 0 0 0 4292600558 4286880962 4283988397 4288392910 4291285731 4292468972 4292600558 4292600558 4292600558 4292600558 4292600558 4292600558 4292600558 4292600558 4292732143 4291811559 4288392910 4283988397 4286880962 4292600558 0 0 0 0 4292535021 4292600558 4288524495 4284777138 4281884573 4281029782 4281161367 4281161367 4281161367 4281161367 4281161367 4281161367 4281161367 4281161367 4281029782 4282015902 4284777138 4288524495 4292600558 4292535021 0 0 0 0 0 4292403180 4292403180 4292534765 4292535021 4293060849 4293060849 4293060849 4293060849 4293060849 4293060849 4293060849 4293060849 4293060849 4292797935 4292535021 4292534765 4292468972 4292403180 0 0 0 0 0 0 0 4292206058 4292535021 4292600558 4292863472 4292863472 4292863472 4292863472 4292863472 4292863472 4292863472 4292863472 4292863472 4292929264 4292600558 4292535021 4292206058 0 0 0 0 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)! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
progressFillStyleFor: aProgress
	"Return the progress fillStyle for the given progress morph."
	^ self windowActiveFillStyleFor: aProgress! !

!UITheme methodsFor: 'initialization' stamp: ''!
initializeForms
	"Initialize the receiver's image forms."

	self forms: Dictionary new.
	self forms
		at: #checkboxMarker put: self newCheckboxMarkerForm;
		at: #radioButtonMarker put: self newRadioButtonMarkerForm;
		at: #treeExpanded put: self newTreeExpandedForm;
		at: #treeUnexpanded put: self newTreeUnexpandedForm;
		at: #windowClose put: self newWindowCloseForm;
		at: #windowMinimize put: self newWindowMinimizeForm;
		at: #windowMaximize put: self newWindowMaximizeForm;
		at: #windowMenu put: self newWindowMenuForm;
		at: #windowCloseOver put: self newWindowCloseOverForm;
		at: #windowMinimizeOver put: self newWindowMinimizeOverForm;
		at: #windowMaximizeOver put: self newWindowMaximizeOverForm;
		at: #sbHThumbLeft put: self newScrollbarThumbLeftForm;
		at: #sbHThumbMiddle put: self newScrollbarThumbHorizontalMiddleForm;
		at: #sbHThumbRight put: self newScrollbarThumbRightForm;
		at: #sbVThumbTop put: self newScrollbarThumbTopForm;
		at: #sbVThumbMiddle put: self newScrollbarThumbVerticalMiddleForm;
		at: #sbVThumbBottom put: self newScrollbarThumbBottomForm;
		at: #buttonTopLeft put: self newButtonTopLeftForm;
		at: #buttonTopMiddle put: self newButtonTopMiddleForm;
		at: #buttonTopRight put: self newButtonTopRightForm;
		at: #buttonMiddleLeft put: self newButtonMiddleLeftForm;
		at: #buttonMiddleRight put: self newButtonMiddleRightForm;
		at: #buttonBottomLeft put: self newButtonBottomLeftForm;
		at: #buttonBottomMiddle put: self newButtonBottomMiddleForm;
		at: #buttonBottomRight put: self newButtonBottomRightForm;
		at: #buttonSquareTopLeft put: self newButtonSquareTopLeftForm;
		at: #buttonSquareTopRight put: self newButtonSquareTopRightForm;
		at: #buttonSquareBottomLeft put: self newButtonSquareBottomLeftForm;
		at: #buttonSquareBottomRight put: self newButtonSquareBottomRightForm;
		at: #buttonSelectedTopLeft put: self newButtonSelectedTopLeftForm;
		at: #buttonSelectedTopMiddle put: self newButtonSelectedTopMiddleForm;
		at: #buttonSelectedTopRight put: self newButtonSelectedTopRightForm;
		at: #buttonSelectedMiddleLeft put: self newButtonSelectedMiddleLeftForm;
		at: #buttonSelectedMiddleRight put: self newButtonSelectedMiddleRightForm;
		at: #buttonSelectedBottomLeft put: self newButtonSelectedBottomLeftForm;
		at: #buttonSelectedBottomMiddle put: self newButtonSelectedBottomMiddleForm;
		at: #buttonSelectedBottomRight put: self newButtonSelectedBottomRightForm;
		at: #buttonSquareSelectedTopLeft put: self newButtonSquareSelectedTopLeftForm;
		at: #buttonSquareSelectedTopRight put: self newButtonSquareSelectedTopRightForm;
		at: #buttonSquareSelectedBottomLeft put: self newButtonSquareSelectedBottomLeftForm;
		at: #buttonSquareSelectedBottomRight put: self newButtonSquareSelectedBottomRightForm;
		at: #radioButton put: self newRadioButtonForm;
		at: #radioButtonSelected put: self newRadioButtonSelectedForm;
		at: #checkbox put: self newCheckboxForm;
		at: #checkboxSelected put: self newCheckboxSelectedForm;
		at: #windowClosePassive put: self newWindowInactiveControlForm;
		at: #windowMinimizePassive put: self newWindowInactiveControlForm;
		at: #windowMaximizePassive put: self newWindowInactiveControlForm;
		at: #windowMenuPassive put: self newWindowMenuPassiveForm;
		at: #windowMenuOver put: self newWindowMenuOverForm! !

!UITheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffRemovedLinesBackgroundColor
	"Answer the color used to show removals in a diff view."
	^ Color red alpha: 0.2! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
expanderTitleControlButtonWidth
	"Answer the width of an expander title control button for this theme."
	
	^20! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
morphTreeSplitterNormalFillStyleFor: aSplitter	
	^ self splitterNormalFillStyleFor: aSplitter! !

!UITheme methodsFor: 'initialization' stamp: ''!
newRadioButtonForm
	"Answer the form for a normal radio button."

	^(Form
	extent: 14@14
	depth: 32
	fromArray: #( 16777215 16777215 16777215 198234320 2645865652 3568415153 4072521149 4055875519 3551637937 2578756788 164021958 16777215 16777215 16777215 16777215 16777215 1437906100 4038506166 4292598747 4293914607 4294111986 4294111986 4293914607 4292598747 4021728950 1303556786 16777215 16777215 16777215 1386916522 4257465283 4293388263 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293388263 4240556481 1219144362 16777215 195207842 4038177201 4293125091 4293256677 4293256677 4293256677 4293256677 4293256677 4293256677 4293256677 4293256677 4293059298 3987713967 144678815 2627640990 4291875024 4292993505 4292993505 4292993505 4292993505 4292993505 4292993505 4292993505 4292993505 4292993505 4292993505 4291743438 2459803037 3584139681 4292072403 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292006610 3500056222 3970476200 4291809231 4292467161 4292532954 4292532954 4292532954 4292532954 4292532954 4292532954 4292532954 4292532954 4292467161 4291809231 3919947173 3919749794 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 3869154974 3515846543 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 3431697291 2289333364 4291480266 4293125091 4293125091 4293125091 4293125091 4293125091 4293125091 4293125091 4293125091 4293125091 4293125091 4291151301 2154918257 189154886 3817178501 4293256677 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293059298 3766583681 189154886 16777215 960906822 4120221077 4293322470 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4293256677 4103180689 927549769 16777215 16777215 16777215 910048830 3682039671 4290756543 4293256677 4294572537 4294506744 4293190884 4273847741 3648287860 893337407 16777215 16777215 16777215 16777215 16777215 169482778 1799570243 3042202708 3681710706 3664867697 3025359699 1799636036 169482778 16777215 16777215 16777215)
	offset: 0@0)! !

!UITheme methodsFor: 'icons-utilities' stamp: ''!
icons
	^ Smalltalk ui icons! !

!UITheme methodsFor: 'services' stamp: ''!
proceedIn: aThemedMorph text: aStringOrText title: aString
	"Answer the result of a proceed dialog with the given label and title."

	self questionSound play.
	^((ProceedDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: aStringOrText) openModal cancelled not! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarPressedThumbFillStyleFor: aScrollbar
	"Return the pressed scrollbar thumb fillStyle for the given scrollbar."
	
	^self scrollbarNormalThumbFillStyleFor: aScrollbar! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newButtonIn: aThemedMorph for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a new button."

	|b|
	b := PluggableButtonMorph
			on: aModel
			getState: stateSel
			action: actionSel
			label: labelSel.
	b
		theme: self;
		label: ' ' font: self buttonFont;
		update: labelSel;
		arguments: (args ifNil: [{b}]);
		getEnabledSelector: enabledSel;
		cornerStyle: (self buttonCornerStyleIn: aThemedMorph);
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		setBalloonText: helpText;
		extent: b minExtent;
		removeProperty: #theme.
	^b! !

!UITheme methodsFor: 'initialization' stamp: ''!
newScrollbarThumbVerticalMiddleForm
	"Answer the form for the middle of a vertical scrollbar thumb."

	^(Form
	extent: 13@1
	depth: 32
	fromArray: #( 4284182411 4288326078 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4284709013 4282669690)
	offset: 0@0)! !

!UITheme methodsFor: '*Growl' stamp: ''!
growlFillColorFor: aGrowlMorph
	^ Color darkGray alpha: 0.5! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
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]]! !

!UITheme methodsFor: 'label-styles' stamp: ''!
whiteTreeUnexpandedForm
	"Answer the form to use for an unexpanded tree item when a contrasting one is needed."

	^ self forms 
		at: #whiteTreeUnexpanded
		ifAbsent: [ | f |
			f := self treeUnexpandedForm deepCopy.
			f replaceColor: Color white withColor: Color transparent.
			(f colorsUsed reject: [:c | c isTransparent]) do: [:c | f replaceColor:  c withColor: c whiter whiter whiter whiter whiter whiter].
			self forms at: #whiteTreeUnexpanded put: f.
			self whiteTreeUnexpandedForm]! !

!UITheme methodsFor: '*Polymorph-Widgets-Themes' stamp: ''!
watcherWindowInactiveFillStyleFor: aWindow

	^ SolidFillStyle color: (Color veryVeryLightGray alpha: 0.6)! !

!UITheme methodsFor: 'accessing' stamp: ''!
windowActiveDropShadowStyle: anObject
	"Set the value of windowActiveDropShadowStyle"

	windowActiveDropShadowStyle := anObject! !

!UITheme methodsFor: 'defaults' stamp: ''!
controlButtonLabelInsetFor: aButton
	"Answer the inset to use for a control button's label."

	^2! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newHSVSelectorIn: aThemedMorph color: aColor help: helpText
	"Answer a hue-saturation-volume selector."

	^HSVColorSelectorMorph new
		selectedColor: aColor;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		setBalloonText: helpText! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSelectedTopRightForm
	"Answer the form to use for the top right of a selected button."

	^self forms at: #buttonSelectedTopRight ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'defaults' stamp: ''!
windowBottomOffset

	^ 0! !

!UITheme methodsFor: 'border-styles' stamp: ''!
windowDiffuseDropShadowOffsetRectangleFor: aSystemWindow
	"Answer a rectangle describing the offsets for each corner
	of the the active window bounds for the drop shadow area
	when the difuse style is used."
	
	^8@4 corner: 8@10! !

!UITheme methodsFor: 'private' stamp: ''!
veryLightSelectionColorFor: aMorph
	^ self class veryLightSelectionColor! !

!UITheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffAdditionalTextInLineBackgroundColor
	"Answer the color used to show addition highlights in a text line."
	^ self diffAdditionalLineBackgroundColor alpha: 0.4! !

!UITheme methodsFor: 'services' stamp: ''!
chooseForSaveFileReferenceIn: aThemedMorph title: title extensions: exts path: path preview: preview
	"Answer the result of a file name chooser dialog with the given title, extensions
	path and preview type.
	Answer nil or a filename."

	| dialog pathFileReference |
	pathFileReference := path asFileReference.
	dialog := (FileDialogWindow newWithTheme: aThemedMorph theme)
		title: title;
		fileNameText: pathFileReference basename;
		answerSaveFile.
	exts ifNotNil: [ dialog validExtensions: exts ].
	path ifNotNil: [ dialog selectPath: path ].
	^ dialog openModal answer! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newScrollPaneIn: aThemedMorph for: aMorph
	"Answer a new GeneralScrollPane with given content morph."

	^GeneralScrollPaneMorph new
		scrollTarget: aMorph;
		yourself! !

!UITheme methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
openTaskListIn: world from: aKeyboardEvent

	| tasklistMorph |
	tasklistMorph := TaskListMorph from: aKeyboardEvent.
	tasklistMorph openInWorld: world.! !

!UITheme methodsFor: 'label-styles' stamp: ''!
disabledItemStyle
	"Answer either #plain or #inset to determine how
	diabled text is drawn."

	^#plain! !

!UITheme methodsFor: 'services' stamp: ''!
questionIn: aThemedMorph text: aStringOrText title: aString
	"Answer the result of a question dialog with the given label and title."

	self questionSound play.
	^((QuestionDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: aStringOrText) openModal answer! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonColouredMiddleColor
	"Return the middle area colour for a coloured button fillStyle."
	
	^Color r: 102 g: 127 b: 168 range: 255! !

!UITheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffModificatedLineBackgroundColor
	"Answer the color used to show changes."
	^ Color yellow alpha: 0.2! !

!UITheme methodsFor: 'accessing' stamp: ''!
currentSettings
	^ self class currentSettings! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
updateScrollBarButtonsAspect: aCollection color: aColor 
	"update aCollection of morphs with aColor"
	
	
	aCollection
		do: [:each | self updateScrollBarButtonAspect: each color: aColor]! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
taskbarActiveButtonColorFor: aButton
	"Answer the colour for the given active taskbar button."

	^self scrollbarColor alphaMixed: 0.7 with: Color white! !

!UITheme methodsFor: 'label-styles' stamp: ''!
buttonLabelForText: aTextOrString
	"Answer the label to use for the given text."
	^aTextOrString isString
		ifTrue: [(LabelMorph contents: aTextOrString) color: self textColor ]
		ifFalse: [|t|
				t := TextMorph new newContents: aTextOrString.
				t
					extent: t optimalExtent;
					margins: (Margin left: 0 right: 0 top: 0 bottom: 1);
					lock]! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
checkboxCornerStyleFor: aCheckbox
	"Answer the corner style for checkbox buttons."
	
	^#square! !

!UITheme methodsFor: 'services' stamp: ''!
chooseColorIn: aThemedMorph title: aString color: aColor
	"Answer the result of a color selector dialog with the given title and initial color."

	|dialog|
	dialog := (ColorSelectorDialogWindow newWithTheme: aThemedMorph theme)
		title: aString;
		selectedColor: aColor.
	dialog openModal.
	^ dialog cancelled ifFalse: [ dialog selectedColor ]! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newAutoAcceptTextEntryIn: aThemedMorph for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 
	"Answer a text entry for the given model.
	Object conversion will be automatic based on the class of
	object returned after performing the get selector, aClass
	is provided in case of initial nil returns."
	^ self
		newAutoAcceptTextEntryIn: aThemedMorph
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		help: helpText
		entryCompletion: nil! !

!UITheme methodsFor: 'initialization' stamp: ''!
newScrollbarThumbLeftForm
	"Answer the form for the left hand side of a scrollbar thumb."

	^(Form
	extent: 7@13
	depth: 32
	fromArray: #( 0 0 1149473452 2033601901 2906411633 4284182411 4284182411 0 422725477 2755548019 4284182411 4284445326 4286287012 4287142063 0 2083867754 4284050825 4285037205 4287536820 4287931577 4287931577 1345735788 2671004523 4284248204 4287339698 4287602613 4287602613 4287602613 1999981163 4283787654 4285958562 4287208113 4287208113 4287208113 4287208113 2671004523 4283656068 4286681770 4286879149 4286879149 4286879149 4286879149 2671004523 4283656325 4286484649 4286484649 4286484649 4286484649 4286484649 2671004523 4283392897 4286155685 4286155685 4286155685 4286155685 4286155685 2167753578 4283195776 4285037464 4285761185 4285761185 4285761185 4285761185 1580616556 3023786609 4283656069 4285432221 4285432221 4285432221 4285432221 171134054 2688176497 4282998397 4283919242 4285103257 4285103257 4285103257 0 926700403 3023720559 4282801275 4283261825 4284182670 4284577427 0 73298833 1262704758 2503363949 3023720303 4282669690 4282669690)
	offset: 0@0)! !

!UITheme methodsFor: 'services' stamp: ''!
textEntryIn: aThemedMorph text: aStringOrText title: aString entryText: defaultEntryText
	"Answer the result of a text entry dialog ( a string or nil if cancelled)
	with the given label and title."

	self questionSound play.
	^(TextEntryDialogWindow new
			textFont: self textFont;
			title: aString;
			text: aStringOrText;
			entryText: defaultEntryText) openModal entryText! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
windowColor
	"Answer the window color to use."

	^self settings windowColor! !

!UITheme methodsFor: 'accessing' stamp: ''!
menuBorderWidth 
	^  self settings menuBorderWidth * self displayScaleFactor! !

!UITheme methodsFor: 'sounds' stamp: ''!
windowCloseSound
	"Answer the window close sound."

	^self soundTheme windowCloseSound! !

!UITheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedPressedBorderStyleFor: aButton
	"Return the selected pressed taskbar item borderStyle for the given button."

	^ self buttonSelectedPressedBorderStyleFor: aButton! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonSelectedDisabledBorderStyleFor: aButton
	"Return the selecteddisabled button borderStyle for the given button."

	^self buttonSelectedBorderStyleFor: aButton! !

!UITheme methodsFor: 'label-styles' stamp: ''!
whiteTreeExpandedForm
	"Answer the form to use for an expanded tree item when a contrasting one is needed."

	^ self forms 
		at: #whiteTreeExpanded 
		ifAbsent: [ | f |
			f := self treeExpandedForm deepCopy.
			f replaceColor: Color white withColor: Color transparent.
			(f colorsUsed reject: [:c | c isTransparent]) do: [:c | f replaceColor:  c withColor: c whiter whiter whiter whiter whiter whiter].
			self forms at: #whiteTreeExpanded put: f.
			self whiteTreeExpandedForm]! !

!UITheme methodsFor: '*Growl' stamp: ''!
growlLabelColorFor: aGrowlMorph
	^ Color white twiceDarker! !

!UITheme methodsFor: 'border-styles' stamp: ''!
windowActiveDropShadowOffsetRectangleFor: aSystemWindow
	"Answer a rectangle describing the offsets for each corner
	of the the active window bounds for the drop shadow area."
	
	^self windowActiveDropShadowStyle == #diffuse
		ifTrue: [self windowDiffuseDropShadowOffsetRectangleFor: aSystemWindow]
		ifFalse: [self windowPlainDropShadowOffsetRectangleFor: aSystemWindow]! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowCloseForm
	"Answer the form to use for the close button of a window."

	^(self forms at: #windowClose ifAbsent: [Form extent: 10@10 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: 'accessing' stamp: ''!
flatMenu
	^ self settings flatMenu! !

!UITheme methodsFor: 'border-styles' stamp: ''!
dropListDisabledBorderStyleFor: aDropList
	"Return the disabled borderStyle for the given drop list."

	^self dropListNormalBorderStyleFor: aDropList! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarPressedFillStyleFor: aScrollbar
	"Return the pressed scrollbar fillStyle for the given scrollbar."
	
	^self scrollbarNormalFillStyleFor: aScrollbar! !

!UITheme methodsFor: 'border-styles' stamp: ''!
drawTextAdornmentFor: aPluggableTextMorph color: aColor on: aCanvas
	"Indicate edit status for the given morph."
	
	|bounds size fillStyle|
	bounds := aPluggableTextMorph innerBounds.
	size := 25.
	fillStyle := (GradientFillStyle ramp: {
			0.0->(self backgroundColor alpha: 0.01).
			0.8->aColor.
			1.0->aColor})
		origin: bounds topRight - (size@0);
		direction: (size @ size negated) // 4;
		radial: false.
	aCanvas
		drawPolygon:  {bounds topRight. bounds topRight + (0@size). bounds topRight - (size@0)}
		fillStyle: fillStyle! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowMinimizeForm
	"Answer the form to use for the minimize button of a window."

	^(self forms at: #windowMinimize ifAbsent: [Form extent: 10@10 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
baseScrollbarColorFor: aScrollbar
	"Return the scrollbar last pane colour or that of our settings if unavailable"
	
	^ aScrollbar lastPaneColor 
		ifNil: [ self scrollbarColor ]! !

!UITheme methodsFor: 'border-styles' stamp: ''!
dropListNormalListBorderStyleFor: aDropList
	"Return the normal borderStyle for the list of the given given drop list"

	^BorderStyle inset
		width: 1;
		baseColor: aDropList paneColor! !

!UITheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffJoinColor
	"Answer the color used for the join bar."
	^ Color paleBlue duller! !

!UITheme methodsFor: 'services' stamp: ''!
questionWithoutCancelIn: aThemedMorph text: aStringOrText title: aString
	"Answer the result of a question dialog with the given label and title."

	self questionSound play.
	^((QuestionWithoutCancelDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: aStringOrText) openModal answer! !

!UITheme methodsFor: 'initialization' stamp: ''!
newWindowMenuPassiveForm
	"Answer a new form for a window menu box."

	^ self iconNamed: #windowMenuInactiveForm! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
successBackgroundColor
	^ self successTextColor lighter lighter! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newFocusIndicatorMorphFor: aMorph
	"Answer a new focus indicator for the given morph."

	^ BorderedMorph new
		fillStyle: Color transparent;
		borderStyle: (SimpleBorderStyle new
			 width: 1;
			baseColor: (self baseSelectionColorFor: aMorph));
		bounds: aMorph focusBounds! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newAutoAcceptTextEntryIn: aThemedMorph for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText 
	"Answer a text entry for the given model.
	Object conversion will be automatic based on the class of
	object returned after performing the get selector, aClass
	is provided in case of initial nil returns."
	^ self
		newAutoAcceptTextEntryIn: aThemedMorph
		for: aModel
		get: getSel
		set: setSel
		class: aClass 
		getEnabled: enabledSel
		font: aFont
		help: helpText
		entryCompletion: nil! !

!UITheme methodsFor: 'border-styles' stamp: ''!
textFieldDisabledBorderStyleFor: aTextField
	"Return the disabled text field borderStyle for the given text field."

	^self textEditorDisabledBorderStyleFor: aTextField! !

!UITheme methodsFor: 'morph creation' stamp: ''!
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! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newFontSelector
	"Answer a new font selector dialog"
		^FreeTypeFontSelectorDialogWindow new! !

!UITheme methodsFor: 'defaults' stamp: ''!
windowTopOffset

	^ 0! !

!UITheme methodsFor: 'defaults' stamp: ''!
dialogWindowPreferredCornerStyleFor: aDialogWindow
	"Answer the preferred corner style for the given dialog."

	^ self windowPreferredCornerStyleFor:aDialogWindow! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
desktopImageFor: aWorld
	"Answer the desktop image for the given world.
	Look for an image file with the name of the theme.
	Answer nil for none available."

	|file|
	file := FileSystem disk workingDirectory / self class themeName , 'jpg'.
	^ file exists ifTrue: [
		ImageReadWriter formFromFileNamed: file fullName]! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newMorphDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a morph drop list for the given model."

	^(MorphDropListMorph
			on: aModel
			list: listSel
			selected: getSel
			changeSelected: setSel
			useIndex: useIndex)
		selectionColor: self selectionColor;
		getEnabledSelector: enabledSel;
		cornerStyle: aThemedMorph preferredCornerStyle;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		setBalloonText: helpText! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSquareTopRightForm
	"Answer the form to use for the top right of a square button."

	^self forms at: #buttonSquareTopRight ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
taskListFillStyleFor: aTasklist
	
	| aColor result |
	aColor := aTasklist color.
	result := GradientFillStyle ramp: {
			0.0->aColor whiter whiter. 0.2->aColor lighter.
			0.8->aColor darker. 1.0->aColor blacker}.
	^ result		
		origin: aTasklist topLeft;
		direction: 0 @ aTasklist height;
		radial: false;
		yourself.! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSelectedMiddleLeftForm
	"Answer the form to use for the middle left of a selected button."

	^self forms at: #buttonSelectedMiddleLeft ifAbsent: [Form extent: 12@1 depth: Display depth]! !

!UITheme methodsFor: 'defaults' stamp: ''!
scrollbarMinimumThumbThickness
	"Answer the minumum width or height of a scrollbar thumb 
	as appropriate to its orientation."
	
	^15 * self displayScaleFactor! !

!UITheme methodsFor: 'configure' stamp: ''!
configurePluggableListMorph: listMorph 
	self configureScrollPane: listMorph.! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSquareBottomLeftForm
	"Answer the form to use for the bottom left of a square button."

	^self forms at: #buttonSquareBottomLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarNormalBorderStyleFor: aScrollbar
	"Return the normal button borderStyle for the given scrollbar."

	^BorderStyle simple
		width: 0;
		baseColor: Color transparent! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
checkboxButtonDisabledBorderStyleFor: aCheckboxButton
	"Return the disabled checkbox button borderStyle for the given button."

	^self checkboxButtonNormalBorderStyleFor: aCheckboxButton! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarPagingAreaCornerStyleIn: aThemedMorph	
	^#square! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
worldMainDockingBarNormalFillStyleFor: aDockingBar
	"Return the world main docking bar fillStyle for the given docking bar."
	
	|aColor|
	aColor := aDockingBar originalColor alpha: 0.7.
	^(GradientFillStyle ramp: {
			0.0->(aColor alphaMixed: 0.3 with: (Color white alpha: aColor alpha)).
			0.8->aColor darker.
			1.0->aColor darker duller})
		origin: aDockingBar topLeft;
		direction: (aDockingBar isVertical
			ifTrue: [aDockingBar width @ 0]
			ifFalse: [0 @ aDockingBar height]);
		radial: false! !

!UITheme methodsFor: '*Rubric-Editing-Core' stamp: ''!
rubScrolledTextMorphThemer
	^ RubScrolledTextMorphThemer new! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarButtonCornerStyleIn: aThemedMorph
	"Allow for themes to override default behaviour."
	
	^#square! !

!UITheme methodsFor: 'label-styles' stamp: ''!
dropListButtonLabelFor: aDropList
	"Answer the label for the button of the given drop list."

	^AlphaImageMorph new
		image: (ScrollBarMorph
			arrowOfDirection: #bottom
			size: aDropList buttonWidth - 3
			color: aDropList paneColor darker);
		enabled: aDropList enabled! !

!UITheme methodsFor: 'private' stamp: ''!
normalFillStyleFor: aMorph height: anInteger
	"Return the normal button fillStyle for the given button."

	^ SolidFillStyle color: (self lightColorFor: aMorph)! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarMouseOverFillStyleFor: aScrollbar
	"Return the scrollbar mouse over fillStyle for the given color."

	^self scrollbarNormalFillStyleFor: aScrollbar! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
selectionTextColor
 ^ self settings selectionTextColor! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonBottomRightForm
	"Answer the form for the bottom right of a button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4291282887 3548216701 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4290230199 2607574124 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4238187933 1616731485 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4119365768 962156889 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4290756543 3697895785 374427985 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4292730333 4118378873 1666010445 41975936 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4254175633 2790215503 154745145 0 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4293848814 4289177511 3663288665 675299392 16777216 0 4294309365 4294309365 4294309365 4294309365 4294309365 4292467161 4253188738 3545453395 1295332661 33554432 0 0 4294572537 4294572537 4294440951 4292861919 4289309097 4066797158 2655010880 640626479 33554432 0 0 0 4288519581 4270294919 4168052591 3965081174 3477291843 1546267178 138428480 16777216 0 0 0 0 3107864126 2268016431 1511989023 941629472 338044454 33554432 0 0 0 0 0 0)
	offset: 0@0)! !

!UITheme methodsFor: 'border-styles' stamp: ''!
sliderDisabledBorderStyleFor: aSlider
	"Return the disabled slider borderStyle for the given text editor."

	^self sliderNormalBorderStyleFor: aSlider! !

!UITheme methodsFor: 'border-styles' stamp: ''!
taskbarThumbnailNormalBorderStyleFor: aWindow
	^ self buttonNormalBorderStyleFor: aWindow! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
radioButtonSelectedForm
	"Answer the form to use for a selected radio button."

	^ self iconNamed: #radioButtonSelectedForm! !

!UITheme methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
paginatorSelectionColor

	^ self darkBaseColor alpha: 0.8! !

!UITheme methodsFor: 'defaults' stamp: ''!
statusFont
	"Answer the status font to use."

	^((TextStyle named: #BitstreamVeraSansMono) ifNil: [TextStyle default])
		fontOfPointSize: 8! !

!UITheme methodsFor: 'label-styles' stamp: ''!
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! !

!UITheme methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver."

	super initialize.
	self
		initializeForms;
		settings: self defaultSettings.
	self windowActiveDropShadowStyle: #diffuse! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarNormalButtonFillStyleFor: aScrollbar
	"Return the normal scrollbar button fillStyle for the given scrollbar."
	
	^ self scrollbarNormalThumbFillStyleFor: aScrollbar! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
textFieldNormalFillStyleFor: aTextField
	"Return the normal fillStyle for the given text field."
	
	^ Color white! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSelectedBottomRightForm
	"Answer the form to use for the bottom right of a selected button."

	^self forms at: #buttonSelectedBottomRight ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonTopRightForm
	"Answer the form to use for the top right of a button."

	^self forms at: #buttonTopRight ifAbsent: [Form extent: 11@12 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
checkboxButtonLabelNormalFillStyleFor: aCheckboxButton label: aLabel
	"Return the selected disabled checkbox button fillStyle for the given button."
	
	^ aLabel color! !

!UITheme methodsFor: 'label-styles' stamp: ''!
labelDisabledColorFor: aLabel
	"Answer the color to use for a label when disabled."

	^aLabel owner
		ifNil: [aLabel paneColor muchDarker]
		ifNotNil: [aLabel owner color isTransparent
					ifTrue: [aLabel owner paneColor muchDarker]
					ifFalse: [aLabel owner color muchDarker]].! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
windowActiveTitleFillStyleFor: aWindow
	^ SolidFillStyle color: Color transparent! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
checkboxButtonSelectedFillStyleFor: aCheckboxButton
	"Return the selected checkbox button fillStyle for the given checkbox button."
	
	^(ImageFillStyle form: self checkboxSelectedForm) origin: aCheckboxButton topLeft! !

!UITheme methodsFor: 'defaults' stamp: ''!
windowBorderWidthFor: aWindow

	^ 4 * self displayScaleFactor! !

!UITheme methodsFor: 'border-styles' stamp: ''!
taskbarThumbnailCornerStyleFor: aMorph
	"Answer the corner style for the taskbar thumbnail/tasklist."
	
	^#square! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
buttonColorFor: aButton
	"Answer the colour for the given button."

	^self settings standardColorsOnly
		ifTrue: [self buttonColor]
		ifFalse: [ aButton colorToUse ]! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newMorphDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText
	"Answer a morph drop list for the given model."

	^self
		newMorphDropListIn: aThemedMorph
		for: aModel
		list: listSel
		getSelected: getSel
		setSelected: setSel
		getEnabled: enabledSel
		useIndex: true
		help: helpText! !

!UITheme methodsFor: 'border-styles' stamp: ''!
sliderNormalBorderStyleFor: aSlider
	"Return the normal slider borderStyle for the given text editor."

	^BorderStyle inset
		width: 1;
		baseColor: aSlider paneColor twiceDarker! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
scrollbarThumbLeftForm
	"Answer the form to use for the left of a horizontal scrollbar."

	^self forms at: #sbHThumbLeft ifAbsent: [Form extent: 7@13 depth: Display depth]! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
textColorForNonStandardBackground
	^ self textColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
focusIndicatorMorphFor: aMorph
	"Answer a (cached) focus indicator for the given morph."

	(self focusIndicator isNil or: [
			self focusIndicator isMorph
				ifTrue: [self focusIndicator ~~ aMorph]
				ifFalse: [self focusIndicator key ~~ aMorph]])
		ifTrue: [self focusIndicator: aMorph ->(self newFocusIndicatorMorphFor: aMorph)].
	^self focusIndicator value 
		privateBounds: aMorph focusBounds! !

!UITheme methodsFor: 'defaults' stamp: ''!
setSystemProgressMorphDefaultParameters: aProgressMorph
	"Set up the given progress morph."
	aProgressMorph color: self settings derivedMenuColor.
	self settings preferRoundCorner
		ifTrue: [aProgressMorph useRoundedCorners].
	aProgressMorph borderWidth: self menuBorderWidth * self displayScaleFactor.
	aProgressMorph borderColor: self menuBorderColor.
	aProgressMorph updateColor.! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarNormalFillStyleFor: aScrollbar
	"Return the normal scrollbar fillStyle for the given scrollbar."
	
	^ "(self glamorousBaseColorFor: aScrollbar) muchLighter"
	Color r: 245 g: 245 b: 245 range: 255! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newTaskListButtonIn: aTasklist for: aTask
	"Answer a tasklist button morph for the given task."
	
	|lm lab button |
	lab := (self buttonLabelForText: (aTask label contractTo: 40)).
	aTask isActive
		ifTrue: [ lab emphasis: 1 "1 -> bold" ].
	lm := self
		newRowIn: aTasklist
		for: {(aTask icon ifNil: [self smallWindowIcon]) asMorph. lab}.
	button := self
		newButtonIn: aTasklist
		for: aTask morph
		getState: #isActive
		action: #buttonClickedForTaskList:
		arguments: {aTasklist}
		getEnabled: nil
		label: lm
		help: nil.
	button
		useSquareCorners;
		onColor: (self taskbarMinimizedButtonColorFor: button)
		offColor: (aTask isActive
				ifTrue: [self taskbarActiveButtonColorFor: button]
				ifFalse: [self taskbarButtonColorFor: button]);
		hResizing: #spaceFill.
	lab color: (self taskbarButtonLabelColorFor: button).
	button model: aTask.
	^button! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
dangerBackgroundColor
	^ self dangerTextColor darker darker! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonDisabledBorderStyleFor: aButton
	"Return the disabled button borderStyle for the given button."

	^self buttonNormalBorderStyleFor: aButton! !

!UITheme methodsFor: 'private' stamp: ''!
baseSelectionColorFor: aButton
	^ self class baseSelectionColor! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonMiddleRightForm
	"Answer the form to use for the middle right of a button."

	^self forms at: #buttonMiddleRight ifAbsent: [Form extent: 11@1 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonDisabledFillStyleFor: aButton
	"Return the disabled button fillStyle for the given color."

	^self buttonNormalFillStyleFor: aButton! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newExpanderIn: aThemedMorph label: aString forAll: controls
	"Answer an expander with the given label and controls."

	|answer|
	answer := ExpanderMorph basicNew
		basicTheme: self;
		initialize;
		font: self menuFont;
		titleText: aString;
		basicTheme: nil.
	controls do: [:m |
		answer addMorphBack: m].
	^answer! !

!UITheme methodsFor: 'border-styles' stamp: ''!
listDisabledBorderStyleFor: aList
	"Return the disabled borderStyle for the given list."

	^self listNormalBorderStyleFor: aList! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newLabelIn: aThemedMorph for: aModel label: aString getEnabled: enabledSel
	"Answer a new text label."

	^(LabelMorph contents: aString font: self labelFont)
		model: aModel;
		getEnabledSelector: enabledSel! !

!UITheme methodsFor: 'border-styles' stamp: ''!
progressBarBorderStyleFor: aProgressBar
	"Return the progress bar borderStyle for the given progress bar."

	|c|
	c := self progressBarColorFor: aProgressBar.
	^BorderStyle simple
		width: 1;
		baseColor: c darker! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonSelectedBorderStyleFor: aButton
	"Return the selected button borderStyle for the given button."

	^self buttonNormalBorderStyleFor: aButton! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
menuItemInDockingBarSelectedFillStyleFor: aMenuItem
	"Answer the selected fill style to use for the given menu item that is in a docking bar."
	^ self buttonSelectedFillStyleFor: aMenuItem! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
errorPopperBackgroundColor
	^ Color paleRed! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newBracketSliderIn: aThemedMorph for: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a bracket slider."

	^(BracketSliderMorph
			on: aModel
			getValue: getSel
			setValue: setSel
			min: minValue
			max: maxValue
			quantum: quantum)
		getEnabledSelector: enabledSel;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		setBalloonText: helpText! !

!UITheme methodsFor: 'private' stamp: ''!
darkBaseColorFor: aButton
	^ self class darkBaseColor! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
disabledTextColor 
	^ self disabledColor! !

!UITheme methodsFor: 'border-styles' stamp: ''!
plainGroupPanelBorderStyleFor: aGroupPanel
	"Answer the normal border style for a plain group panel."

	^SimpleBorderStyle new
		width: 1;
		baseColor: Color transparent! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
warningTextColor
	^ Color yellow muchDarker! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowLabelForText: aTextOrString
	"Answer the window label to use for the given text."
	^ LabelMorph new
		contents: aTextOrString;
		font: StandardFonts windowTitleFont emphasis: 0! !

!UITheme methodsFor: 'initialization' stamp: ''!
newWindowMaximizeOverForm
	"Answer a new form for a window menu box."

	^ self newWindowMaximizeForm! !

!UITheme methodsFor: 'defaults' stamp: ''!
focusIndicatorCornerRadiusFor: aMorph
	"Answer the default corner radius preferred for the focus indicator
	for the morph for themes that support this."

	^aMorph wantsRoundedCorners
		ifTrue: [6]
		ifFalse: [2]! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
radioButtonDisabledFillStyleFor: aRadioButton
	"Return the disabled radio button fillStyle for the given button."
	
	^self radioButtonNormalFillStyleFor: aRadioButton! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
unfocusedSelectionColor
	^ self settings unfocusedSelectionColor! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
windowInactiveTitleFillStyleFor: aWindow
	"We do not want the lighting effect when the window goes inactive"
	^ SolidFillStyle color: Color transparent! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newListIn: aThemedMorph for: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText
	"Answer an icon list for the given model."

	^PluggableIconListMorph new
		selectionColor: self selectionColor;
		textColor: self listTextColor;
		font: self listFont;
		on: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		menu: nil
		keystroke: nil;
		autoDeselect: false;
		cornerStyle: aThemedMorph preferredCornerStyle;
		color: Color white;
		borderStyle: (BorderStyle inset width: 1);
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		getIconSelector: iconSelector;
		getEnabledSelector: enabledSel;
		setBalloonText: helpText! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
multiFormTopFillStyleFrom: anArray in: aRectangle
	"Answer a composite fill style from the given forms and central colour
	in the given bounds. Only top and middle sections are considered."
	
	|tl tm tr ml mr c|
	tl := anArray first.
	tm := anArray second.
	tr := anArray third.
	ml  := anArray fourth.
	c := anArray fifth.
	mr  := anArray sixth.
	^CompositeFillStyle fillStyles: {
		(ImageFillStyle form: tl) origin: aRectangle topLeft.
		(AlphaInfiniteForm with: tm)
			origin: aRectangle topLeft + (tl width@0);
			extent: (aRectangle width - tl width - tr width)@tm height.
		(ImageFillStyle form: tr)
			origin: aRectangle topRight - (tr width@0).
		(AlphaInfiniteForm with: ml)
			origin: aRectangle topLeft + (0@tr height);
			extent: ml width@(aRectangle height - tl height).
		(ColorFillStyle color: c)
			origin: aRectangle topLeft + tl extent;
			extent: aRectangle extent - tl extent - (mr width @0).
		(AlphaInfiniteForm with: mr)
			origin: aRectangle topRight + (tr width negated@tr height);
			extent: mr width@(aRectangle height - tr height)}! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonPlainFillStyleFor: aButton
	"Return the plain button fillStyle for the given button."
	
	|round roundCorners tl t tr l m r bl b br|
	round := aButton wantsRoundedCorners.
	roundCorners := aButton roundedCorners.
	tl := (round and: [roundCorners includes: 1]) ifTrue: [self buttonTopLeftForm] ifFalse: [self buttonSquareTopLeftForm].
	t := self buttonTopMiddleForm.
	tr:= (round and: [roundCorners includes: 4]) ifTrue: [self buttonTopRightForm] ifFalse: [self buttonSquareTopRightForm].
	l := self buttonMiddleLeftForm. m := self buttonPlainMiddleColor. r := self buttonMiddleRightForm.
	bl := (round and: [roundCorners includes: 2]) ifTrue: [self buttonBottomLeftForm] ifFalse: [self buttonSquareBottomLeftForm].
	b := self buttonBottomMiddleForm.
	br := (round and: [roundCorners includes: 3]) ifTrue: [self buttonBottomRightForm] ifFalse: [self buttonSquareBottomRightForm].
	^self
		multiFormFillStyleFrom: {tl. t. tr. l. m. r. bl. b. br}
		in: aButton bounds! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowMaximizeForm
	"Answer the form to use for the maximize button of a window."

	^(self forms at: #windowMaximize ifAbsent: [Form extent: 10@10 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: 'label-styles' stamp: ''!
createCloseBoxFor: aSystemWindow
	"Answer a button for closing the window."
	
	^(self
		newCloseControlIn: aSystemWindow
		for: aSystemWindow
		action: [aSystemWindow closeBoxHit]
		help: 'Close this window' translated)
		extent: aSystemWindow boxExtent! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonTopLeftForm
	"Answer the form for the top left of a button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 0 0 0 0 0 0 33554431 365151171 1270791870 2545662907 3283663032 3770004917 0 0 0 0 0 111848106 2411247800 4054954417 4272729260 4290427578 4291546059 4292796126 0 0 0 33554431 817083315 3585192369 4273058225 4292401368 4293980400 4294111986 4294111986 4294111986 0 0 33554431 1907076011 4105022893 4290953922 4293454056 4293848814 4293848814 4293848814 4293848814 4293848814 0 0 715696296 4088179884 4292269782 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 0 79675327 3584402853 4291940817 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 33554431 2392628380 4256938939 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 261724569 4020281504 4292006610 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 1099795853 4205488810 4292269782 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 2072413830 4290361785 4292006610 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 3163196042 4291217094 4291611852 4292664540 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 3784150413 4291809231 4291809231 4292006610 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575)
	offset: 0@0)! !

!UITheme methodsFor: 'initialization' stamp: ''!
newScrollbarThumbRightForm
	"Answer the form for the right hand side of a scrollbar thumb."

	^(Form
	extent: 7@13
	depth: 32
	fromArray: #( 4284182411 4284182411 2587118699 1396330353 211462590 0 0 4287010734 4285629341 4284182411 4284182411 2033601901 0 0 4287931577 4287931577 4286682026 4284313740 4284050825 1261587049 0 4287602613 4287602613 4287602613 4286418855 4283919239 2587118699 422725477 4287208113 4287208113 4287208113 4287208113 4284971669 4283787654 1345735788 4286879149 4286879149 4286879149 4286879149 4285629597 4283656068 1832209003 4286484649 4286484649 4286484649 4286484649 4285695391 4283458947 1999981163 4286155685 4286155685 4286155685 4286155685 4285169048 4283392897 1916095595 4285761185 4285761185 4285761185 4285761185 4284379535 4283195776 1345735788 4285432221 4285432221 4285432221 4285037464 4283195775 2671004523 758270315 4285103257 4285103257 4284905878 4283327362 4282998397 1664502380 0 4284380048 4283853961 4282932861 4282801275 2419477869 171134054 0 4282669690 4282669690 2755021932 2436846708 322261099 0 0)
	offset: 0@0)! !

!UITheme methodsFor: 'services' stamp: ''!
alertIn: aThemedMorph text: aStringOrText title: aString configure: aBlock
	"Answer the result of an alert dialog (true) with the given label and title."

	|dialog|
	SoundTheme useThemeSounds ifTrue: [self alertSound play].
	dialog := (AlertDialogWindow newWithTheme: aThemedMorph theme)
		textFont: self textFont;
		title: aString;
		text: aStringOrText.
	aBlock value: dialog.
	dialog openModal.
	^dialog cancelled not! !

!UITheme methodsFor: 'private' stamp: ''!
lightSelectionColorFor: aMorph
	^ self class lightSelectionColor! !

!UITheme methodsFor: 'initialization' stamp: ''!
newCheckboxMarkerForm
	"Answer a new checkbox marker form."

	^ self iconNamed: #checkboxMarkerForm! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarMouseOverThumbFillStyleFor: aScrollbar
	"Return the scrollbar mouse over thumb fillStyle for the given color."

	^self scrollbarNormalThumbFillStyleFor: aScrollbar! !

!UITheme methodsFor: 'label-styles' stamp: ''!
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! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
taskbarButtonColorFor: aButton
	"Answer the colour for the given taskbar button." 
	^ self windowColorFor: aButton model! !

!UITheme methodsFor: 'defaults' stamp: ''!
buttonLabelInsetFor: aButton
	"Answer the inset to use for a button's label."

	|left right|
	^aButton wantsRoundedCorners
		ifTrue: [left := ((aButton roundedCorners includesAnyOf: #(1 2)) ifTrue: [8] ifFalse: [4]).
				right := ((aButton roundedCorners includesAnyOf: #(3 4)) ifTrue: [8] ifFalse: [4]).
				Margin left: left top: 2 right: right bottom: 2]		
		ifFalse: [3@2]! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
taskbarItemLabelColorForExpanded: aButton
	"Answer the colour for the label of the given taskbar button, given that the corresponding window is collapsed."
	
	^ Color black! !

!UITheme methodsFor: 'label-styles' stamp: ''!
treeExpandedForm
	"Answer the form to use for an expanded tree item."

	^(self forms at: #treeExpanded ifAbsent: [Form extent: 10@9 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionColors
	<inspectorPresentationOrder: 10 title: 'Colors'>
	
	^ SpListPresenter new 
		items: ((UITheme selectors select: [ :each | 
			(each endsWith: 'Color') and: [ ((self perform: each) isKindOf: Color) ] ])
			sort: #yourself ascending);
		display: [ :each | each ];
		displayIcon: [ :each | 
			Morph new 
				color: (self perform: each);
				asFormOfSize: 20@20 ];
		yourself! !

!UITheme methodsFor: 'defaults' stamp: ''!
defaultButtonBorderColor
	"Answer the color to use for a 'default' button."

	^self settings selectionColor! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
fadeCheckboxWhenDisabled
	"Answer whether a checkbox should fade its appearance when disabled.
	If false, assumed that is covered by the relevant disabled fill styles."

	^true! !

!UITheme methodsFor: 'configure' stamp: ''!
configureLabelMorph: aMorph! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
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! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonNormalFillStyleFor: aButton
	"Return the normal button fillStyle for the given button."
	
	(aButton valueOfProperty: #noFill ifAbsent: [false]) ifTrue: [^ SolidFillStyle color: Color transparent ].
	^ self normalFillStyleFor: aButton height: aButton height! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newButtonLabelIn: aThemedMorph for: aModel label: aString getEnabled: enabledSel
	"Answer a new button text label."

	^(self buttonLabelForText: aString)
		model: aModel;
		getEnabledSelector: enabledSel! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newSVSelectorIn: aThemedMorph color: aColor help: helpText
	"Answer a saturation-volume selector."

	^SVColorSelectorMorph new
		color: aColor;
		selectedColor: aColor;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		setBalloonText: helpText! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarNormalThumbBorderStyleFor: aScrollbar
	"Return the normal thumb borderStyle for the given scrollbar."

	^ BorderStyle simple
		width: 1;
		baseColor: Color transparent! !

!UITheme methodsFor: 'defaults' stamp: ''!
expanderTitleInsetFor: aDropList
	"Answer the inset to use for expander title layout."

	^0! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
morphTreeSplitterPressedFillStyleFor: aSplitter
	"Return the pressed splitter fillStyle for the given splitter."
	
	|aColor|
	aColor := aSplitter paneColor twiceDarker.
	^(GradientFillStyle ramp: {
			0.0->Color white. 0.4-> aColor twiceLighter.
			1.0->aColor darker duller})
		origin: aSplitter topLeft;
		direction: (aSplitter splitsTopAndBottom
			ifTrue: [0 @ aSplitter height]
			ifFalse: [aSplitter width @ 0]);
		radial: false! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newCancelButtonIn: aThemedMorph for: aModel
	"Answer a new cancel button."

	^self
		newButtonIn: aThemedMorph
		for: aModel
		getState: nil
		action: #cancel
		arguments: nil
		getEnabled: nil
		label: 'Cancel' translated
		help: 'Cancel changes and close the window' translated! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSelectedBottomRightForm
	"Answer the form for the bottom right of a selected button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284775331 3545850757 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4284643228 2605931385 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4233915791 1615745901 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4116079488 961039463 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4285169827 3695858538 373704285 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286092472 4115618674 1664828245 33554560 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 4250495363 2789098069 154745173 0 4286948554 4286948554 4286948554 4286948554 4286948554 4286948554 4286882504 4284642962 3661580376 674444102 16777216 0 4287277775 4287277775 4287277775 4287277775 4287277775 4286421177 4250034292 3543876175 1294675516 33554432 0 0 4287606740 4287606740 4287540947 4286750399 4284906131 4064496988 2654025280 640165935 33554432 0 0 0 4284445576 4266943863 4165424226 3963307086 3476109119 1545872426 134234176 16777216 0 0 0 0 3106812728 2267424813 1511791647 941629472 338044454 33554432 0 0 0 0 0 0)
	offset: 0@0)! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newLabelGroupIn: aThemedMorph for: labelsAndControls font: aFont labelColor: aColor
	"Answer a morph laid out with a column of labels and a column of associated controls.
	If spaceFill is tru then each row will share available space to pad."

	| labels labelWidth lc|
	lc := labelsAndControls collect: [:a |
		(a key isMorph
			ifTrue: [a key]
			ifFalse: [(self newLabelIn: aThemedMorph label: (a key ifNil: ['']) asString)
						font: aFont;
						color: aColor])
			-> a value].
	labels := Morph new
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		changeTableLayout.
	lc do: [:a |
		labels addMorphBack: a key].
	labelWidth := labels minExtent x.
	^self newColumnIn: aThemedMorph for: (lc collect: [:a | | row |
		a key hResizing: #rigid; extent: labelWidth@ a key height.
		row := self newRowIn: aThemedMorph for: {a key. a value}.
		row vResizing: (a value vResizing = #spaceFill ifTrue: [#spaceFill] ifFalse: [#shrinkWrap]).
		row])! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
menuTitleColorFor: aThemedMorph

	"Answer the menu titlecolor to use."

	| w |

	^ self menuTitleColor
		ifNil: [ aThemedMorph ifNil: [ ^ self defaultMenuTitleColor ].
			w := aThemedMorph isSystemWindow
				ifTrue: [ aThemedMorph ]
				ifFalse: [ aThemedMorph ownerThatIsA: SystemWindow ].
			w
				ifNil: [ self defaultMenuTitleColor ]
				ifNotNil: [ ( w valueOfProperty: #paneColor ) darker ifNil: [ self defaultMenuTitleColor ] ]
			]! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
spotlightWindowColor 
	^ self selectionColor muchDarker! !

!UITheme methodsFor: 'border-styles' stamp: ''!
drawTextAdornmentsFor: aPluggableTextMorph on: aCanvas
	"Indicate edit status for the given morph."

	(aPluggableTextMorph hasEditingConflicts or: [ aPluggableTextMorph hasValidText not ])
		ifTrue: [ ^ self drawTextAdornmentFor: aPluggableTextMorph color: Color red on: aCanvas ].
	aPluggableTextMorph hasUnacceptedEdits
		ifTrue: [ aPluggableTextMorph model wantsVisualFeedback
				ifTrue: [ ^ self drawTextAdornmentFor: aPluggableTextMorph color: Color orange on: aCanvas ] ]! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newHSVASelectorIn: aThemedMorph color: aColor help: helpText
	"Answer a hue-saturation-volume-alpha selector."

	^HSVAColorSelectorMorph new
		selectedColor: aColor;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		setBalloonText: helpText! !

!UITheme methodsFor: 'private' stamp: ''!
veryLightFillStyleFor: aMorph height: anInteger
	"Return the very light button fillStyle for the given button."
	
	^ SolidFillStyle color: (self veryLightSelectionColorFor: aMorph)! !

!UITheme methodsFor: 'configure' stamp: ''!
configurePluggableTextMorph: textMorph 
	textMorph 
		color: Color white;
		borderWidth: 1.! !

!UITheme methodsFor: 'accessing' stamp: ''!
displayScaleFactor
	
	^ self currentWorld displayScaleFactor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newToolbarIn: aThemedMorph
	"Answer a new toolbar."

	|bar|
	bar := PanelMorph new
		changeTableLayout;
		layoutInset: 0@1;
		listDirection: #leftToRight;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	"bar
		addMorphBack: (self newToolSpacerIn: aThemedMorph);
		addMorphBack: (self newToolbarHandleIn: aThemedMorph);
		addMorphBack: (self newToolSpacerIn: aThemedMorph)."
	^bar! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
windowEdgeNormalFillStyleFor: anEdgeGrip
	"Return the normal window edge fillStyle for the given edge grip."
	
	^Color transparent! !

!UITheme methodsFor: '*Growl' stamp: ''!
growlBorderColorFor: aGrowlMorph
	^ Color gray! !

!UITheme methodsFor: 'services' stamp: ''!
enterOrRequestIn: aThemedMorph title: title labels: labels values: values lines: lines
	"Answer the result of a popup choice with the given title, labels, values and lines."

	| dialog choice |
	dialog := (PopupChoiceOrRequestDialogWindow newWithTheme: aThemedMorph theme)
		title: (title isEmpty ifTrue: ['Choose' translated] ifFalse: [title asString]);
		labels: labels;
		lines: (lines ifNil: [#()]);
		model: values.
	choice := dialog openModal choice.
	dialog cancelled ifTrue: [ ^nil ].
	^ choice
		ifNotNil: [ choice ]
		ifNil: [ dialog filterValue ]! !

!UITheme methodsFor: 'border-styles' stamp: ''!
tabGroupCornerStyleIn: aThemedMorph
	"Allow for themes to override default behaviour."
	
	^aThemedMorph
		ifNil: [#square]
		ifNotNil: [:tm | tm preferredCornerStyle]! !

!UITheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemPressedBorderStyleFor: aButton
	"Return the pressed taskbar item borderStyle for the given button."

	^ self buttonPressedBorderStyleFor: aButton! !

!UITheme methodsFor: 'services' stamp: ''!
textEntryIn: aThemedMorph text: aStringOrText title: aString entryText: defaultEntryText entryCompletion: anEntryCompletion
	"Answer the result of a text entry dialog ( a string or nil if cancelled)
	with the given label and title."

	self questionSound play.
	^((TextEntryDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: aStringOrText;
			entryText: defaultEntryText;
			entryCompletion: anEntryCompletion) openModal entryText! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonSelectedFillStyleFor: aButton
	"Return the normal button fillStyle for the given button."
	
	^ SolidFillStyle color: (self lightSelectionColorFor: aButton)! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
listNormalFillStyleFor: aList
	"Return the normal fillStyle for the given list."
	
	^Color white! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newMenuIn: aThemedMorph for: aModel
	"Answer a new menu."

	^MenuMorph new
		defaultTarget: aModel;
		color: (self menuColorFor: aThemedMorph)! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newTitleIn: aThemedMorph label: aString for: control
	"Answer a morph laid out with a column with the title and control aligned to the left."

	^(self newColumnIn: aThemedMorph for: {
		self newLabelIn: aThemedMorph label: aString.
		control})
		cellPositioning: #leftCenter;
		cellInset: 2! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarMouseOverBarButtonBorderStyleFor: aScrollbar
	"Return the button borderStyle for the given scrollbar when
	the mouse is over the bar."

	^self scrollbarNormalButtonBorderStyleFor: aScrollbar! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
subgroupColorFrom: paneColor
	"Answer the colour for a subgroup given the pane colour."

	^ self lightColorFor: paneColor" self class baseColor"! !

!UITheme methodsFor: 'defaults' stamp: ''!
tabSelectorMorphMinExtentFor: aTabSelectorMorph
	"Answer the min extent of the given tab selector."
	
	^aTabSelectorMorph basicMinExtent + (8 @ 1)! !

!UITheme methodsFor: 'configure' stamp: ''!
configureScrollPane: aMorph
	aMorph color: Color white.! !

!UITheme methodsFor: 'defaults' stamp: ''!
dropListInsetFor: aDropList
	"Answer the inset to use for drop-list layout."
	
	^ Margin left: 6 top: 0 right: 0 bottom: 0! !

!UITheme methodsFor: 'label-styles' stamp: ''!
buttonLabelFor: aButton
	"Answer the label to use for the given button."

	|label|
	label := self buttonLabelForText: aButton label.
	label enabled: aButton enabled.
	label font: self buttonFont.
	label extent: label optimalExtent.
	^label! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
multiFormFillStyleFrom: anArray in: aRectangle
	"Answer a composite fill style from the given forms and central colour
	in the given bounds."
	
	|tl tm tr ml mr bl bm br c|
	tl := anArray first.
	tm := anArray second.
	tr := anArray third.
	ml  := anArray fourth.
	c := anArray fifth.
	mr  := anArray sixth.
	bl := anArray seventh.
	bm := anArray eighth.
	br := anArray ninth.
	^CompositeFillStyle fillStyles: {
		(ImageFillStyle form: tl) origin: aRectangle topLeft.
		(AlphaInfiniteForm with: tm)
			origin: aRectangle topLeft + (tl width@0);
			extent: (aRectangle width - tl width - tr width)@tm height.
		(ImageFillStyle form: tr)
			origin: aRectangle topRight - (tr width@0).
		(AlphaInfiniteForm with: ml)
			origin: aRectangle topLeft + (0@tl height);
			extent: ml width@(aRectangle height - tl height - bl height).
		(ColorFillStyle color: c)
			origin: aRectangle topLeft + tl extent;
			extent: aRectangle extent - tl extent - br extent.
		(AlphaInfiniteForm with: mr)
			origin: aRectangle topRight + (tr width negated@tr height);
			extent: mr width@(aRectangle height - tr height - br height).
		(ImageFillStyle form: bl) origin: aRectangle bottomLeft - (0@bl height).
		(AlphaInfiniteForm with: bm)
			origin: aRectangle bottomLeft - (bl width negated@bl height);
			extent: (aRectangle width - bl width - br width)@bm height.
		(ImageFillStyle form: br)
			origin: aRectangle bottomRight - br extent}! !

!UITheme methodsFor: 'accessing' stamp: ''!
shStyleTableName

	^ #blueStyleTable! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
urlColor
	^ Color fromHexString: '03A9F4'! !

!UITheme methodsFor: 'label-styles' stamp: ''!
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 | 
		label color: self textColor.
		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)! !

!UITheme methodsFor: 'sounds' stamp: ''!
windowOpenSound
	"Answer the window open sound."

	^self soundTheme windowOpenSound! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
dropListNormalListFillStyleFor: aDropList
	"Return the normal fillStyle for the list of the given drop list."
	
	^Color white! !

!UITheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemNormalBorderStyleFor: aButton
	"Return the normal taskbar item borderStyle for the given button."

	^ self buttonNormalBorderStyleFor: aButton! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
windowActiveFillStyleFor: aWindow
	"We do not want the lighting effect when the window goes inactive"
	^SolidFillStyle color: self class baseColor! !

!UITheme methodsFor: 'configure' stamp: ''!
configureLazyListMorph: listMorph 
	self configureScrollPane: listMorph.! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSelectedBottomMiddleForm
	"Answer the form for the bottom middle of a selected button."

	^(Form
	extent: 1@12
	depth: 32
	fromArray: #( 4284907432 4285171117 4285500082 4285763767 4286092732 4286356417 4286685381 4286948810 4287278031 4287606996 4285038229 3442226232)
	offset: 0@0)! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newTextEditorIn: aThemedMorph for: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: aMenuSelector
	"Answer a text (Smalltalk code) editor for the given model."

	^ RubPluggableTextMorph new
		on: aModel
		text: getSel
		accept: setSel
		readSelection: nil
		menu: aMenuSelector;
		theme: self;
		getEnabledSelector: enabledSel;
		font: self textFont;
		cornerStyle: aThemedMorph preferredCornerStyle;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		borderStyle: (BorderStyle inset width: 1);
		removeProperty: #theme! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSquareBottomLeftForm
	"Answer the form for the bottom left of a square button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 3968305031 4292138196 4292138196 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 3967976066 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 3967778687 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 3967449722 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 3967252343 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 3966923378 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 3966660206 4293783021 4293783021 4293783021 4293783021 4293783021 4293783021 4293783021 4293783021 4293717228 4293717228 4293717228 3966397034 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 3966133862 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 3830929239 4293783021 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 2502963248 4252596601 4289309097 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 622599196 2352034097 3409854014 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653)
	offset: 0@0)! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newTextEntryIn: aThemedMorph for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model."

	|pt|
	pt := RubPluggableTextFieldMorph new
		convertTo: aClass;
		alwaysAccept: true;
		on: aModel
		text: getSel
		accept: setSel
		readSelection: nil
		menu: nil;
		acceptOnCR: true;
		getEnabledSelector: enabledSel;
		font: self textFont;
		cornerStyle: (self textEntryCornerStyleIn: aThemedMorph);
		hResizing: #spaceFill;
		vResizing: #rigid;
		setBalloonText: helpText;
		entryCompletion: anEntryCompletion.
	^pt! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonSelectedMouseOverBorderStyleFor: aButton
	"Return the selected mouse over button borderStyle for the given button."

	^self buttonSelectedBorderStyleFor: aButton! !

!UITheme methodsFor: 'sounds' stamp: ''!
messageSound
	"Answer the message sound."

	^self soundTheme messageSound! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonFocusBoundsFor: aButton
	"Answer the bounds for drawing the focus indication for the
	given button."

	^aButton bounds! !

!UITheme methodsFor: 'accessing' stamp: ''!
lessConspicuousColorFrom: aColor

	^	aColor alphaMixed: 0.5 with: Color white! !

!UITheme methodsFor: 'services' stamp: ''!
chooseDirectoryIn: aThemedMorph title: title path: path
	"Answer the result of a file dialog with the given title, choosing directories only."

	| dialog |
	dialog := (FileDialogWindow newWithTheme: aThemedMorph theme)
		title: title;
		answerDirectory.
	path ifNotNil: [ dialog selectPath: path ].
	^ dialog openModal answer! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
menuColor
	"Answer the menu color to use."

	^self settings menuColor! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
morphTreeColumnFillStyleFor: aMorph
	^ self buttonNormalFillStyleFor: aMorph! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSelectedMiddleRightForm
	"Answer the form to use for the middle right of a selected button."

	^self forms at: #buttonSelectedMiddleRight ifAbsent: [Form extent: 12@1 depth: Display depth]! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newAutoAcceptTextEntryIn: aThemedMorph for: aModel  get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model.
	Object conversion will be automatic based on the class of
	object returned after performing the get selector, aClass
	is provided in case of initial nil returns."

	^self
		newAutoAcceptTextEntryIn: aThemedMorph
		for: aModel
		get: getSel
		set: setSel
		class: aClass
		getEnabled: enabledSel
		font: self textFont
		help: helpText
		entryCompletion: anEntryCompletion! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonMiddleLeftForm
	"Answer the form for the middle left of a button."

	^(Form
	extent: 12@1
	depth: 32
	fromArray: #( 3968305031 4292138196 4292138196 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403)
	offset: 0@0)! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
tabLabelNormalFillStyleFor: aTabLabel
	^ self buttonNormalFillStyleFor: aTabLabel! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
windowShadowColor
	"Answer the window shadow color to use."

	^ Color gray! !

!UITheme methodsFor: 'border-style-menubar' stamp: ''!
menubarBorderWidthFor: aMenubar
	^ 0! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
menuSelectionColor
	^ self settings menuSelectionColor! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
secondarySelectionColor
	^ Color r: 0.927 g: 0.962 b: 0.995 alpha: 1.0! !

!UITheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedPressedFillStyleFor: aButton
	"Return the taskbar item selected pressed fillStyle for the given color."

	^ self buttonSelectedPressedFillStyleFor: aButton! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
borderColor 
	^ Color gray! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newIncrementalSliderIn: aThemedMorph for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a slider inrement/decrement buttons."

	^(IncrementalSliderMorph
			on: aModel
			getValue: getSel
			setValue: setSel
			min: min
			max: max
			quantum: quantum)
		getEnabledSelector: enabledSel;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		setBalloonText: helpText! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newRowIn: aThemedMorph for: controls
	"Answer a morph laid out with a row of controls."

	|answer|
	answer := PanelMorph new
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		fillStyle: Color transparent; "non pane color tracking"
		changeTableLayout;
		listDirection: #leftToRight;
		cellInset: 8;
		cellPositioning: #center.
	controls do: [:m | answer addMorphBack: m].
	^answer! !

!UITheme methodsFor: '*Iceberg-TipUI' stamp: ''!
badgeColor
	^ Color red! !

!UITheme methodsFor: 'sounds' stamp: ''!
windowRestoreDownSound
	"Answer the window restore down sound."

	^self soundTheme windowRestoreDownSound! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newTextIn: aThemedMorph text: aStringOrText
	"Answer a new text."

	^TextMorph new
		wrapFlag: true;
		contents: aStringOrText;
		font: self textFont;
		autoFit: true;
		lock;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
enabledColor

	^ Color black! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
createArrowImagesCache
	"Creates the cache to store the arrow forms"

	^ LRUCache new
		maximumWeight: 40;
		factory: [ :key |
			self
				scrollbarArrowOfDirection: key first
				size: key second
				color: key third ];
		yourself! !

!UITheme methodsFor: 'defaults' stamp: ''!
scrollbarThickness
	"Answer the width or height of a scrollbar as appropriate to
	its orientation."
	
	^13 * self displayScaleFactor! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
classExtensionColor
	^ Color gray darker! !

!UITheme methodsFor: 'fill-styles-menubar' stamp: ''!
menubarItemSelectionTextColorFor: aMenubarItem
	^ self settings menuSelectionTextColor! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
windowActiveLabelFillStyleFor: aWindow
	"Return the window active label fillStyle for the given window."
	
	^Color black! !

!UITheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffMapColor
	"Answer the color used for the mapping bar on the left side."
	^ self backgroundColor! !

!UITheme methodsFor: 'cursor' stamp: ''!
overTextCursorFor: aTextMorph
	"Answer the pointer cursor when over an active text 
	(answer nil if no particular cursor is wanted)."

	^ Cursor overEditableText! !

!UITheme methodsFor: 'sounds' stamp: ''!
denySound
	"Answer the deny sound."

	^self soundTheme denySound! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarMouseOverBorderStyleFor: aScrollbar
	"Return the mouse over borderStyle for the given scrollbar."

	^self scrollbarNormalBorderStyleFor: aScrollbar! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
selectionBarColor

	^ self settings selectionBarColor! !

!UITheme methodsFor: 'initialization' stamp: ''!
newRadioButtonSelectedForm
	"Answer the form for a selected radio button."

	^(Form
	extent: 14@14
	depth: 32
	fromArray: #( 16777215 16777215 16777215 195273727 2641329849 3563221416 4067918510 4051207088 3546444457 2574352313 160337634 16777215 16777215 16777215 16777215 16777215 1433764797 4033509543 4289442502 4292467941 4292928234 4292928234 4292467941 4289442502 4016797863 1299613120 16777215 16777215 16777215 1383498170 4252665514 4291152600 4291744478 4291744478 4291744478 4291744478 4291744478 4291744478 4291087064 4235822507 1216120505 16777215 192187321 4033181089 4290232016 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290100687 3982914979 140541887 2623959968 4286746800 4289574859 4289574859 4289574859 4289574859 4289574859 4289574859 4289574859 4289574859 4289574859 4289574859 4286549679 2456319395 3579801242 4286353071 4288654533 4288654533 4288654533 4288654533 4288654533 4288654533 4288654533 4288654533 4288654533 4288654533 4286089901 3495980954 3965612183 4284709539 4286944951 4287011000 4287011000 4287011000 4287011000 4287011000 4287011000 4287011000 4287011000 4286813622 4284643746 3915280279 3915345555 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 3864947858 3512362887 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 3428345476 2286835828 4285433514 4286026683 4286026683 4286026683 4286026683 4286026683 4286026683 4286026683 4286026683 4286026683 4286026683 4285235879 2152552048 187582022 3813958010 4286421439 4286553283 4286553283 4286553283 4286553283 4286553283 4286553283 4286553283 4286553283 4286355645 3763494776 187582022 16777215 959790667 4116343939 4286685122 4287014603 4287014603 4287014603 4287014603 4287014603 4287014603 4286619329 4099500930 926039117 16777215 16777215 16777215 908735550 3679148137 4285630628 4286882500 4287541204 4287541204 4286816707 4268787875 3645527655 892024127 16777215 16777215 16777215 16777215 16777215 169482778 1798387264 3040494156 3679082084 3662239075 3023716940 1798452800 169482778 16777215 16777215 16777215)
	offset: 0@0)! !

!UITheme methodsFor: 'initialization' stamp: ''!
newCheckboxSelectedForm
	"Answer the form for a selected checkbox."

	^(Form
	extent: 14@14
	depth: 32
	fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 591416973 3914425236 4134435746 4134435746 4134435746 4134435746 4134435746 4134435746 4134435746 4134435746 4134435746 4134435746 3914425236 591416973 2571195527 4289245124 4293125612 4293125612 4293125612 4293125612 4293125612 4293125612 4293125612 4293125612 4293125612 4293125612 4289245124 2520929417 2655015551 4289114053 4291744479 4291744479 4291744479 4291744479 4291744479 4291744479 4291744479 4291744479 4291744479 4291744479 4289114053 2604684160 2654949242 4288456640 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4288456640 2604748668 2654817654 4287799485 4289443276 4289443276 4289443276 4289443276 4289443276 4289443276 4289443276 4289443276 4289443276 4289443276 4287799485 2604486007 2654686063 4287273914 4288457669 4288457669 4288457669 4288457669 4288457669 4288457669 4288457669 4288457669 4288457669 4288457669 4287273914 2604420207 2654816618 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 2604484971 2654619492 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 2604353637 2654684509 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 2604352863 2654487128 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 2604221017 2603892560 4287146187 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287146187 2553626706 1310531626 4232599666 4284512149 4284512149 4284512149 4284512149 4284512149 4284512149 4284512149 4284512149 4284512149 4284512149 4232599666 1276977451 50331648 1210064935 1646208047 1646208047 1646208047 1646208047 1646208047 1646208047 1646208047 1646208047 1646208047 1646208047 1210064935 50331648)
	offset: 0@0)! !

!UITheme methodsFor: 'border-styles' stamp: ''!
textEditorNormalBorderStyleFor: aTextEditor
	"Return the normal text editor borderStyle for the given text editor."

	^self buttonNormalBorderStyleFor: aTextEditor! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSquareSelectedTopLeftForm
	"Answer the form to use for the top left of a selected square button."

	^self forms at: #buttonSquareSelectedTopLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarNormalVerticalThumbFillStyleFor: aScrollbar
	"Return the normal scrollbar vertical thumb fillStyle for the given scrollbar."
	
	|s t m b|
	s := aScrollbar slider.
	t := self scrollbarThumbTopForm.
	m := self scrollbarThumbVerticalMiddleForm.
	b := self scrollbarThumbBottomForm.
	^CompositeFillStyle fillStyles: {
		(ImageFillStyle form: t) origin: s topLeft.
		(AlphaInfiniteForm with: m)
			origin: s topLeft + (0@t height);
			extent: m width@(s height - t height - b height).
		(ImageFillStyle form: b)
			origin: s bottomLeft - (0@b height)}! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarMouseOverThumbButtonFillStyleFor: aScrollbar
	"Return the button fillStyle for the given scrollbar when
	the mouse is over the thumb."

	^self scrollbarMouseOverBarButtonFillStyleFor: aScrollbar! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
sliderDisabledFillStyleFor: aSlider
	"Return the disabled fillStyle for the given slider."
	
	^ self textEditorDisabledFillStyleFor: aSlider! !

!UITheme methodsFor: 'services' stamp: ''!
chooseColorIn: aThemedMorph title: aString color: aColor for: aBlock
	"execute block with result of a color selector dialog with the given title and initial color."

	|d newColor|
	d := (ColorSelectorDialogWindow newWithTheme: aThemedMorph theme)
			title: aString;
			selectedColor: aColor.
	d extent: d initialExtent.
	d announcer when: ColorChanged do: [:ann | 
		aBlock value: ann newColor].
	d openModal.
	
	newColor := d  cancelled
		ifTrue: [aColor]
		ifFalse: [d selectedColor].
				
	aBlock value: newColor.! !

!UITheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemDisabledFillStyleFor: aButton
	"Return the disabled taskbar item fillStyle for the given color."

	^ self buttonDisabledFillStyleFor: aButton! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newColorChooserIn: aThemedMorph for: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText
	"Answer a color chooser ."

	^(ColorChooserMorph
			on: aModel color: getSel changeColor: setSel)
		getEnabledSelector: enabledSel;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		setBalloonText: helpText! !

!UITheme methodsFor: 'defaults' stamp: ''!
defaultMenuTitleColor
	"Answer the default color to use for a menu title
	in the absence of an override in settings."

	^self settings menuTitleColor! !

!UITheme methodsFor: '*Calypso-Browser' stamp: ''!
calypsoFrozenItemColor
	"For Pharo 6 compatibilit reason it is not separate overrides in concrete theme classes.
	But this trick still allows override this color on external themes. 
	Idea to only cover default ones which are white and dark"
	
	^self backgroundColor lightness > 0.3
		ifTrue: [ Color blue muchDarker]
		ifFalse: [ Color cyan ]! !

!UITheme methodsFor: '*Morphic-Widgets-FastTable' stamp: ''!
fastTableColumnResizingColor
	^ self selectionColor! !

!UITheme methodsFor: 'initialization' stamp: ''!
newWindowCloseForm
	"Answer a new form for a window close box."

	^ self iconNamed: #windowCloseForm! !

!UITheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemMouseOverBorderStyleFor: aButton
	"Return the mouse over taskbar item borderStyle for the given button."
	
	^ self buttonMouseOverBorderStyleFor: aButton! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
controlButtonSelectedPressedBorderStyleFor: aButton
	"Return the selected pressed control button borderStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."

	^self buttonSelectedPressedBorderStyleFor: aButton! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
controlButtonSelectedPressedFillStyleFor: aButton
	"Return the selected pressed button fillStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."
	
	^self controlButtonNormalFillStyleFor: aButton! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newListIn: aThemedMorph for: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText
	"Answer a list for the given model."

	^PluggableListMorph new
		selectionColor: self selectionColor;
		textColor: self listTextColor;
		font: self listFont;
		on: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		menu: nil
		keystroke: nil;
		autoDeselect: false;
		cornerStyle: aThemedMorph preferredCornerStyle;
		color: Color white;
		borderStyle: (BorderStyle inset width: 1);
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		getEnabledSelector: enabledSel;
		setBalloonText: helpText! !

!UITheme methodsFor: 'label-styles' stamp: ''!
checkboxLabelForText: aTextOrString
	"Answer the label to use for the given text."

	|morph|
	morph := aTextOrString isString
		ifTrue: [(LabelMorph contents: aTextOrString)
				disabledStyle: self disabledItemStyle]
		ifFalse: [|t|
				t := TextMorph new newContents: aTextOrString.
				t extent: t optimalExtent].
	^morph 
		vResizing: #shrinkWrap;
		hResizing: #spaceFill;
		lock! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
menuItemInDockingBarSelectedBorderStyleFor: aMenuItem
	"Return the selected menu item borderStyle when in a docking bar for the given menu item."

	^self menuItemSelectedBorderStyleFor: aMenuItem! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newAutoAcceptTextEntryIn: aThemedMorph for: aModel  get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion
	"Answer a text entry for the given model.
	Object conversion will be automatic based on the class of
	object returned after performing the get selector, aClass
	is provided in case of initial nil returns."

	|pt|
	pt := RubPluggableTextFieldMorph new
		autoAccept: true;
		alwaysAccept: true;
		convertTo: aClass;
		on: aModel
		text: getSel
		accept: setSel
		readSelection: nil
		menu: nil;
		acceptOnCR: true;
		getEnabledSelector: enabledSel;
		font: aFont;
		cornerStyle: (self textEntryCornerStyleIn: aThemedMorph);
		hResizing: #spaceFill;
		vResizing: #rigid;
		borderStyle: (BorderStyle inset width: 1);
		setBalloonText: helpText;
		entryCompletion: anEntryCompletion.
	^pt! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
preferGradientFill
	^ self settings preferGradientFill! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
scrollbarThumbRightForm
	"Answer the form to use for the right of a horizontal scrollbar."

	^self forms at: #sbHThumbRight ifAbsent: [Form extent: 7@13 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
paneColorFor: aWindow
	"Answer the pane color that should be used."

	^ (self fadedBackgroundWindows
		ifTrue: [ aWindow fillStyleToUse ]
		ifFalse: [ self windowActiveFillStyleFor: aWindow ]) asColor! !

!UITheme methodsFor: '*Roassal3-UML' stamp: ''!
methodsLimitUML
	^ RSUMLCalypsoSettings methodsLimitUML! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newImageIn: aThemedMorph form: aForm
	"Answer a new text label."

	^self
		newImageIn: aThemedMorph
		form: aForm
		size: aForm extent! !

!UITheme methodsFor: 'private' stamp: ''!
lightColorFor: aButton
	^ self class lightBaseColor! !

!UITheme methodsFor: 'defaults' stamp: ''!
menuFont
	"Answer the menu font to use."

	^StandardFonts menuFont! !

!UITheme methodsFor: 'services' stamp: ''!
chooseFullFileNameIn: aThemedMorph title: title patterns: patterns path: path preview: preview
	"Answer the result of a file name chooser dialog with the given title, patterns
	path and preview type.
	Answer nil or a filename."

	| dialog |
	dialog := FileDialogWindow basicNew
		basicTheme: aThemedMorph theme;
		previewType: preview;
		initialize;
		title: title;
		answerPathName.
	patterns
		ifNotNil: [ dialog
				fileSelectionBlock: [ :de | 
					(dialog defaultFileSelectionBlock value: de)
						and: [ de isDirectory or: [ patterns anySatisfy: [ :pat | pat match: de name ] ] ] ] ].
	path ifNotNil: [ dialog selectPath: path ].
	^ dialog openModal answer! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowLabelFor: aWindow
	"Answer the label to use for the given window."

	^self windowLabelForText: aWindow labelString! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarMouseOverBarButtonFillStyleFor: aScrollbar
	"Return the button fillStyle for the given scrollbar when
	the mouse is over the bar."

	^self scrollbarNormalButtonFillStyleFor: aScrollbar! !

!UITheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffEdgeColor
	"Answer the color used to show the border of the changes."
	^ Color gray alpha: 0.3! !

!UITheme methodsFor: 'configure' stamp: ''!
configurePluggableButtonMorph: aMorph
	"This will not work because it is using the #normalFillStyle hack :(
	 So, go check the #buttonNormalFillStyleFor: method, which is the one that 
	 actually does something (he and his siblings)"! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
windowEdgePressedFillStyleFor: anEdgeGrip
	"Return the pressed window edge fillStyle for the given edge grip."
	
	^self windowEdgeNormalFillStyleFor: anEdgeGrip! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
radioButtonNormalBorderStyleFor: aRadioButton
	"Return the disabled radio button borderStyle for the given button."

	^self checkboxButtonNormalBorderStyleFor: aRadioButton! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
menuTitleColor
	"Answer the menu title color to use."
	^self settings menuTitleColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newEmbeddedMenuIn: aThemedMorph for: aModel
	"Answer a new menu."

	^EmbeddedMenuMorph new
		defaultTarget: aModel;
		color: (self menuColorFor: aThemedMorph)! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
dropListNormalFillStyleFor: aDropList
	"Return the normal fillStyle for the given drop list."
	
	^ SolidFillStyle color: Color white! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
scrollbarThumbVerticalMiddleForm
	"Answer the form to use for the middle of a vertical scrollbar."

	^self forms at: #sbVThumbMiddle ifAbsent: [Form extent: 13@1 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
progressBarFillStyleFor: aProgressBar
	^ self basePassiveBackgroundColorFor: aProgressBar! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newGroupboxIn: aThemedMorph
	"Answer a plain groupbox."

	^PlainGroupboxMorph new
		cornerStyle: aThemedMorph preferredCornerStyle;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		yourself! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
createBoxIn: aRectangle 
	"PRIVATE - create an box bounded in aRectangle"
	| box |
	box := Morph new.
	box extent: (aRectangle scaleBy: 1 / 2) extent rounded;
		 borderWidth: 0.
	""
	^ box! !

!UITheme methodsFor: 'border-styles' stamp: ''!
groupPanelBorderStyleFor: aGroupPanel
	"Answer the normal border style for a group panel."

	^ SimpleBorderStyle new
		width: 1;
		baseColor: ((self baseColorFor: aGroupPanel))! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSelectedBottomMiddleForm
	"Answer the form to use for the bottom middle of a selected button."

	^self forms at: #buttonSelectedBottomMiddle ifAbsent: [Form extent: 1@12 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSquareSelectedBottomLeftForm
	"Answer the form to use for the bottom left of a selected square button."

	^self forms at: #buttonSquareSelectedBottomLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newOKButtonIn: aThemedMorph for: aModel getEnabled: enabledSel
	"Answer a new OK button."

	^self
		newButtonIn: aThemedMorph
		for: aModel
		getState: nil
		action: #ok
		arguments: nil
		getEnabled: enabledSel
		label: 'OK' translated
		help: 'Apply changes and close the window' translated! !

!UITheme methodsFor: 'initialization' stamp: ''!
newScrollbarThumbBottomForm
	"Answer the form for the bottom of a scrollbar thumb."

	^(Form
	extent: 13@7
	depth: 32
	fromArray: #( 4284182411 4287142063 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4284577427 4282669690 4284182411 4286287012 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4284182670 4282669690 2906411633 4284445326 4287536820 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4283261825 3023720303 2033601901 4284182411 4285037205 4287339698 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4283919242 4282801275 2503363949 1149473452 2755548019 4284050825 4284248204 4285958562 4286681770 4286484649 4286155685 4285037464 4283656069 4282998397 3023720559 1262704758 0 422725477 2083867754 2671004523 4283787654 4283656068 4283656325 4283392897 4283195776 3023786609 2688176497 926700403 73298833 0 0 0 1345735788 1999981163 2671004523 2671004523 2671004523 2167753578 1580616556 171134054 0 0)
	offset: 0@0)! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
radioButtonSelectedFillStyleFor: aRadioButton
	"Return the selected radio button fillStyle for the given button."
	
	^(ImageFillStyle form: self radioButtonSelectedForm) origin: aRadioButton topLeft! !

!UITheme methodsFor: 'services' stamp: ''!
abortIn: aThemedMorph text: aStringOrText title: aString
	"Answer the result of an error dialog (true) with the given label and title."

	| window |
	self abortSound play.
	window := (ErrorDialogWindow newWithTheme: aThemedMorph theme)
		textFont: self textFont;
		title: aString;
		text: aStringOrText.
	window openModal.
	^ window cancelled not! !

!UITheme methodsFor: 'configure' stamp: ''!
configureMorphTreeMorph: aMorph
	aMorph preferedPaneColor: Color white.
	aMorph 
		rowColorForEven: Color white
		odd: Color white.! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
verticesForSimpleArrow: aRectangle 
	"PRIVATE - answer a collection of vertices to draw a simple arrow"
	| vertices |
	vertices := OrderedCollection new.
	""
	vertices add: aRectangle bottomLeft.
	vertices add: aRectangle center x @ (aRectangle top + (aRectangle width / 8)).
	vertices add: aRectangle bottomRight.
	vertices add: aRectangle bottomRight + (0@0.01).
	""
	^ vertices! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
dockingBarNormalFillStyleFor: aToolDockingBar
	^ SolidFillStyle color: Color transparent! !

!UITheme methodsFor: 'forms' stamp: ''!
checkboxForm
	"Answer the form to use for a normal checkbox."

	^self  checkboxUnselectedForm! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newEditableDropListIn: aThemedMorph for: 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."

	^(EditableDropListMorph
			on: aModel
			list: listSel
			selected: getSel
			changeSelected: setSel
			useIndex: useIndex
			addToList: addSel
			class: aClass
			getEnabled: enabledSel
			default: defaultValue)
		ghostText: ghostText;
		selectionColor: self selectionColor;
		font: self dropListFont;
		cornerStyle: aThemedMorph preferredCornerStyle;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		setBalloonText: helpText! !

!UITheme methodsFor: 'label-styles' stamp: ''!
menuCloseForm
	"Answer the form to use for the close button of a menu."

	^self windowCloseForm! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
scrollbarColor
	^ self settings scrollbarColor! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarMouseOverBarThumbFillStyleFor: aScrollbar
	"Return the thumb fillStyle for the given scrollbar when
	the mouse is over the bar."

	^self scrollbarNormalThumbFillStyleFor: aScrollbar! !

!UITheme methodsFor: 'border-styles' stamp: ''!
tabPanelBorderStyleFor: aTabGroup
	^ Pharo3TabPanelBorderStyle new 
		width: 1;
		baseColor: ((self darkBaseColorFor: aTabGroup));
		tabSelector: aTabGroup tabSelectorMorph! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
backgroundColor

	^ Color white! !

!UITheme methodsFor: 'label-styles' stamp: ''!
configureWindowLabelAreaFrameFor: aWindow
	"Configure the layout frame for the label area for the given window."

	|frame windowBorderWidth|
	aWindow labelArea ifNil: [^ self].	
	windowBorderWidth := aWindow class borderWidth.
	aWindow labelArea
		layoutPolicy: RowLayout new;
		cellPositioning: #topCenter;
		hResizing: #spaceFill;
		wrapCentering: #topLeft;
		layoutInset: (Margin left: 0 top: windowBorderWidth right: 0 bottom: 1).
	frame := LayoutFrame identity bottomFraction: 0 ; topOffset: aWindow labelHeight negated.
	aWindow labelArea layoutFrame: frame! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
progressBarColorFor: aProgressBar
	"Answer the colour for the given progress bar."

	^self settings progressBarColor! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonSelectedMouseOverFillStyleFor: aButton
	"Return the button selected mouse over fillStyle for the given color."
	
	^self buttonSelectedFillStyleFor: aButton! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
lineNumberColor 
	^ Color gray muchDarker! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
menuItemSelectedFillStyleFor: aMenuItem

	"Answer the selected fill style to use for the given menu item."

	| fill baseColor preferenced |

	Display depth <= 2
		ifTrue: [ ^ Color gray ].
	preferenced := self menuSelectionColor.
	baseColor := preferenced ifNil: [ aMenuItem owner color negated ] ifNotNil: [ preferenced ].
	self preferGradientFill
		ifFalse: [ ^ baseColor ].
	fill := GradientFillStyle
		ramp:
			{( 0.0 -> baseColor twiceLighter ).
			( 1 -> baseColor twiceDarker )}.
	fill
		origin: aMenuItem topLeft;
		direction: 0 @ aMenuItem height.
	^ fill! !

!UITheme methodsFor: 'accessing' stamp: ''!
forms: anObject
	"Set the value of forms"

	forms := anObject! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newGroupboxIn: aThemedMorph forAll: controls
	"Answer a plain groupbox."

	^self
		newGroupboxIn: aThemedMorph
		for: (self newColumnIn: aThemedMorph for: controls)! !

!UITheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedBorderStyleFor: aButton
	"Return the selected taskbar item borderStyle for the given button."

	^ self buttonSelectedBorderStyleFor: aButton! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarMouseOverBarThumbBorderStyleFor: aScrollbar
	"Return the thumb borderStyle for the given scrollbar when
	the mouse is over the bar."

	^self scrollbarNormalThumbBorderStyleFor: aScrollbar! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
useScrollbarThumbShadow: aBoolean
	"Sets whether the scrollbar must show a shadow of the original position before dragging."

	useScrollbarThumbShadow := aBoolean.! !

!UITheme methodsFor: 'defaults' stamp: ''!
windowRightOffset

	^ 0! !

!UITheme methodsFor: 'services' stamp: ''!
customQuestionIn: aThemedMorph text: labelText yesText: yesText noText: noText cancelText: cancelText default: defaultOption title: aString
	"Answer the result of a question dialog with the given label, button labels and title.
	defaultOption should be one of true, false or nil to set the default button."

	self questionSound play.
	^((CustomQuestionDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: labelText;
			yesText: yesText help: nil;
			noText: noText help: nil;
			cancelText: cancelText help: nil;
			default: defaultOption) openModal answer! !

!UITheme methodsFor: 'initialization' stamp: ''!
newWindowCloseOverForm
	"Answer a new form for a window menu box."

	^ self newWindowCloseForm! !

!UITheme methodsFor: 'initialization' stamp: ''!
newScrollbarThumbTopForm
	"Answer the form for the top of a scrollbar thumb."

	^(Form
	extent: 13@7
	depth: 32
	fromArray: #( 0 0 0 422725477 1345735788 1832209003 1999981163 1916095595 1345735788 758270315 0 0 0 0 0 1261587049 2587118699 4283787654 4283656068 4283458947 4283392897 4283195776 2671004523 1664502380 171134054 0 211462590 2033601901 4284050825 4283919239 4284971669 4285629597 4285695391 4285169048 4284379535 4283195775 4282998397 2419477869 322261099 1396330353 4284182411 4284313740 4286418855 4287208113 4286879149 4286484649 4286155685 4285761185 4285037464 4283327362 4282801275 2436846708 2587118699 4284182411 4286682026 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4284905878 4282932861 2755021932 4284182411 4285629341 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4283853961 4282669690 4284182411 4287010734 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4284380048 4282669690)
	offset: 0@0)! !

!UITheme methodsFor: 'border-styles' stamp: ''!
drawWindowPlainDropShadowFor: aSystemWindow on: aCanvas
	"Draw the plain drop shadow for the given window."
	
	|blOffset brOffset trOffset|
	(aSystemWindow owner notNil and: [aSystemWindow owner isHandMorph])
		ifTrue: [^self]. "skip if being dragged"
	blOffset := (aSystemWindow wantsRoundedCorners and: [aSystemWindow roundedCorners includes: 2])	
		ifTrue: [7] ifFalse: [1].
	brOffset := (aSystemWindow wantsRoundedCorners and: [aSystemWindow roundedCorners includes: 3])	
		ifTrue: [7] ifFalse: [1].
	trOffset := (aSystemWindow wantsRoundedCorners and: [aSystemWindow roundedCorners includes: 4])	
		ifTrue: [7] ifFalse: [1].
	aCanvas
		fillRectangle: (aSystemWindow bounds bottomLeft + (blOffset @ 0)
						corner: aSystemWindow bounds bottomRight - (brOffset @ -1))
		fillStyle: aSystemWindow shadowColor;
		fillRectangle: (aSystemWindow bounds topRight + (0 @ trOffset)
						corner: aSystemWindow bounds bottomRight + (1 @ brOffset negated))
		fillStyle: aSystemWindow shadowColor.
	aCanvas
		clipBy: (aSystemWindow bounds bottomRight - brOffset
			corner: aSystemWindow bounds bottomRight + (1@1))
			during: [:c | ((RoundedBorderStyle new
							baseColor: aSystemWindow shadowColor;
							width: 1) cornerRadius: brOffset - 1)
							frameRectangle: (aSystemWindow bounds translateBy: 1)
							on: c]! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newSliderIn: aThemedMorph for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText
	"Answer a slider. Resizing set for horizontal usage by default."

	^(PluggableSliderMorph
			on: aModel
			getValue: getSel
			setValue: setSel
			min: min
			max: max
			quantum: quantum)
		getEnabledSelector: enabledSel;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		setBalloonText: helpText;
		minHeight: 16! !

!UITheme methodsFor: 'initialization' stamp: ''!
defaultSoundTheme
	"Answer the default sound theme.
	Answer the system sound theme by default."

	^SoundTheme current! !

!UITheme methodsFor: 'border-styles' stamp: ''!
tabLabelNormalBorderStyleFor: aTabLabel
"	^SimpleBorder new
		width: 0;
		baseColor: (self buttonBaseColorFor: aTabLabel) darker
"	^ self buttonNormalBorderStyleFor: aTabLabel! !

!UITheme methodsFor: 'defaults' stamp: ''!
defaultMenuColor
	"Answer the default color to use for a menu
	in the absence of an override in settings."

	^ self settings fallbackMenuColor! !

!UITheme methodsFor: 'border-styles' stamp: ''!
windowPlainDropShadowOffsetRectangleFor: aSystemWindow
	"Answer a rectangle describing the offsets for each corner
	of the the active window bounds for the drop shadow area
	when the plain style is used."
	
	^aSystemWindow shadowOffset negated corner: aSystemWindow shadowOffset! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
listTextColor
	"Answer the list text color to use."

	^Color black! !

!UITheme methodsFor: 'accessing' stamp: ''!
focusIndicator: anObject
	"Set the value of focusIndicator"

	focusIndicator := anObject! !

!UITheme methodsFor: 'initialization' stamp: ''!
newScrollbarThumbHorizontalMiddleForm
	"Answer the form for the middle of a horizontal scrollbar thumb."

	^(Form
	extent: 1@13
	depth: 32
	fromArray: #( 4284182411 4288326078 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4284709013 4282669690)
	offset: 0@0)! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
radioButtonSelectedBorderStyleFor: aRadioButton
	"Return the selected radio button borderStyle for the given button."

	^self radioButtonNormalBorderStyleFor: aRadioButton! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarPressedButtonBorderStyleFor: aScrollbar
	"Return the pressed button borderStyle for the given scrollbar."
	^ self scrollbarNormalButtonBorderStyleFor: aScrollbar! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
progressBarProgressFillStyleFor: aProgressBar
	^ (self lightSelectionColorFor: aProgressBar)! !

!UITheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedDisabledBorderStyleFor: aButton
	"Return the selecteddisabled taskbar item borderStyle for the given button."

	^ self buttonSelectedDisabledBorderStyleFor: aButton! !

!UITheme methodsFor: 'accessing' stamp: ''!
numberOfStepsForAnimations
	^ self animationSettings numberOfSteps! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
menuKeyboardFocusColor
	^ self settings menuKeyboardFocusColor! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
checkboxButtonSelectedBorderStyleFor: aCheckboxButton
	"Return the selected checkbox button borderStyle for the given button."

	^self checkboxButtonNormalBorderStyleFor: aCheckboxButton! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newToolbarIn: aThemedMorph for: controls
	"Answer a new toolbar with the given controls."

	|answer|
	answer := self newToolbarIn: aThemedMorph.
	controls do: [:m | answer addMorphBack: m].
	^answer! !

!UITheme methodsFor: 'defaults' stamp: ''!
buttonMinWidth
	"Answer the minumum width of a button for this theme."
	
	^24! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
menuFillStyleFor: aMenu
	"Return the fillStyle for the given menu."
	
	| bc fill |
	bc := aMenu valueOfProperty: #basicColor ifAbsent: [self settings derivedMenuColor].
	fill := GradientFillStyle ramp: {0.0 -> (bc alphaMixed: 0.2 with: Color white). 1.0 -> bc}.
	fill
		radial: false;
		origin: aMenu topLeft;
		direction: 0 @ aMenu height.
	^ fill.! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newNoButtonIn: aThemedMorph for: aModel
	"Answer a new No button."

	^(self
			newButtonIn: aThemedMorph
			for: aModel
			getState: nil
			action: #no
			arguments: nil
			getEnabled: nil
			label: 'No' translated
			help: 'Answer no and close the window' translated)
		hResizing: #rigid;
		vResizing: #rigid! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
radioButtonSelectedDisabledFillStyleFor: aRadioButton
	"Return the selected disabled radio button fillStyle for the given button."
	
	^self radioButtonNormalFillStyleFor: aRadioButton! !

!UITheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedDisabledFillStyleFor: aButton
	"Return the taskbar item selected disabled fillStyle for the given color."
	
	^ self buttonSelectedDisabledFillStyleFor: aButton! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSquareTopLeftForm
	"Answer the form to use for the top left of a square button."

	^self forms at: #buttonSquareTopLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonTopMiddleForm
	"Answer the form to use for the top middle of a button."

	^self forms at: #buttonTopMiddle ifAbsent: [Form extent: 1@12 depth: Display depth]! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
darkBaseColor
	^ self class darkBaseColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newStackIn: aThemedMorph for: controls
	"Answer a morph laid out with a stack of controls."

	|answer|
	answer := PanelMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		fillStyle: Color transparent; "non pane color tracking"
		layoutPolicy: StackLayout new.
	controls do: [:m | answer addMorphBack: m].
	^answer! !

!UITheme methodsFor: '*Growl' stamp: ''!
growlDismissHandleFor: aGrowlMorph
	| form image |
	form := self windowCloseForm.
	image := ImageMorph new.
	image image: form.
	image color: Color yellow.
	^ image! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
scrollbarThumbHorizontalMiddleForm
	"Answer the form to use for the middle of a horizontal scrollbar."

	^self forms at: #sbHThumbMiddle ifAbsent: [Form extent: 1@13 depth: Display depth]! !

!UITheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffRemovalHighlightColor
	"Answer the color used to show removal highligths."
	^ self diffRemovedLinesBackgroundColor alpha: 0.4! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
splitterPressedFillStyleFor: aSplitter
	"Return the pressed splitter fillStyle for the given splitter."
	
	|aColor|
	aColor := self baseColorFor: 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! !

!UITheme methodsFor: 'services' stamp: ''!
textEditorIn: aThemedMorph text: aStringOrText title: aString entryText: defaultEntryText entryHeight: entryHeight
	"Answer the result of a text editor (multiline) dialog ( a string or nil if cancelled)
	with the given label and title."

	self questionSound play.
	^((TextEditorDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: aStringOrText;
			entryText: defaultEntryText;
			entryHeight: entryHeight) openModal entryText! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
patchworkUIThemeColorFor: aWindowOrModel
	"Answer the colour for the given window."
	^ self settings windowColor! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
baseColor
	^ self class baseColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newWindowHeaderFor: aWindow

	^ (AlignmentMorph newSpacer: Color transparent)
			vResizing: #spaceFill;
			layoutPolicy: ProportionalLayout new! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
controlButtonMouseOverFillStyleFor: aButton
	"Return the mouse over control button fillStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."
	
	^self controlButtonNormalFillStyleFor: aButton! !

!UITheme methodsFor: 'border-styles' stamp: ''!
textEditorDisabledBorderStyleFor: aTextEditor
	"Return the disabled text editor borderStyle for the given text editor."

	^self textEditorNormalBorderStyleFor: aTextEditor! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonTopLeftForm
	"Answer the form to use for the top left of a button."

	^self forms at: #buttonTopLeft ifAbsent: [Form extent: 11@12 depth: Display depth]! !

!UITheme methodsFor: 'services' stamp: ''!
textEditorIn: aThemedMorph text: aStringOrText title: aString entryText: defaultEntryText
	"Answer the result of a text editor (multiline) dialog ( a string or nil if cancelled)
	with the given label and title."

	^self
		textEditorIn: aThemedMorph
		text: aStringOrText
		title: aString
		entryText: defaultEntryText
		entryHeight: 64! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowMenuPassiveForm
	"Answer the form to use for passive (background) window menu buttons"

	^self newWindowMenuPassiveForm! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSelectedTopLeftForm
	"Answer the form to use for the top left of a selected button."

	^self forms at: #buttonSelectedTopLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSelectedTopRightForm
	"Answer the form for the top right of a selected button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 3748625849 3262810310 2441121744 1184342758 295085538 33554431 0 0 0 0 0 0 4290099916 4287271854 4284904087 4266680208 4016534958 2156237519 75464703 0 0 0 0 0 4292994026 4292994026 4292994026 4292730856 4288981953 4250297491 3463873727 646616786 16777471 0 0 0 4292270819 4292270819 4292270819 4292270819 4292270819 4291284185 4285233565 4066800809 1551994565 16777471 0 0 4291547356 4291547356 4291547356 4291547356 4291547356 4291547356 4291547356 4287929784 4016798124 545033153 0 0 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4287009457 3379658160 61516543 0 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290166480 4234639009 2003992240 33554431 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4286286508 3949425826 258373546 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4286747057 4167135387 896300710 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4285760937 4250693017 1785229980 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4287471035 4284446367 4284314268 2841668498 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4285038503 4284578211 4284578211 3663554701)
	offset: 0@0)! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonCornerStyleIn: aThemedMorph
	"Allow for themes to override default behaviour."
	
	^ #square! !

!UITheme methodsFor: 'defaults' stamp: ''!
tabLabelInsetFor: aButton
	"Answer the inset to use for a tab label."
	^ Margin left: 8 top: 2 right: 8 bottom: 2! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
listDisabledFillStyleFor: aList
	"Return the disabled fillStyle for the given list."
	
	^ self textEditorDisabledFillStyleFor: aList! !

!UITheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedMouseOverFillStyleFor: aButton
	"Return the taskbar item selected mouse over fillStyle for the given color."
	
	^ self buttonSelectedMouseOverFillStyleFor: aButton! !

!UITheme methodsFor: 'label-styles' stamp: ''!
checkboxLabelFor: aCheckbox
	"Answer the label to use for the given checkbox."

	|label|
	label := self checkboxLabelForText: aCheckbox label.
	label enabled: aCheckbox enabled.
	label font: self labelFont.
	^label! !

!UITheme methodsFor: 'morph creation' stamp: ''!
windowCollapseBoxLayoutFor: aWindow

	^ LayoutFrame new 
		leftFraction: 1; 
		leftOffset: aWindow boxExtent x negated;
		yourself! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
dropListControlButtonWidth
	"Answer the width of a drop list control button for this theme."
	
	^ 18! !

!UITheme methodsFor: 'services' stamp: ''!
denyIn: aThemedMorph text: aStringOrText title: aString
	"Answer the result of an deny dialog (true) with the given label and title."

	self denySound play.
	^((DenyDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: aStringOrText) openModal cancelled not! !

!UITheme methodsFor: 'basic-colors-diffs' stamp: ''!
diffAdditionalLineBackgroundColor
	"Answer the color used to show additions in a diff view."
	^ Color green alpha: 0.2! !

!UITheme methodsFor: 'border-styles' stamp: ''!
configureWindowBorderFor: aWindow
	"Configure the border for the given window."

	aWindow roundedCorners: #(1 2 3 4).
	aWindow borderStyle: (BorderStyle
		width: 1 color: Color lightGray)! !

!UITheme methodsFor: 'border-styles' stamp: ''!
tabLabelSelectedBorderStyleFor: aTabLabel
	"Answer the selected border style for a tab label."

	^self tabLabelNormalBorderStyleFor: aTabLabel! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
checkboxButtonNormalBorderStyleFor: aChecboxButton
	"Return the normal checkbox button borderStyle for the given button."

	^BorderStyle simple
		width: 1;
		baseColor: Color transparent! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonBottomRightForm
	"Answer the form to use for the bottom right of a button."

	^self forms at: #buttonBottomRight ifAbsent: [Form extent: 11@11 depth: Display depth]! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newGroupboxIn: aThemedMorph for: control
	"Answer a plain groupbox."

	^(self newGroupboxIn: aThemedMorph)
		addMorph: control! !

!UITheme methodsFor: 'initialization' stamp: ''!
newCheckboxForm
	"Answer the form for a normal checkbox."

	^(Form
	extent: 14@14
	depth: 32
	fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 594242411 3918960278 4138774704 4138774704 4138774704 4138774704 4138774704 4138774704 4138774704 4138774704 4138774704 4138774704 3919026071 594242411 2575072380 4292467161 4294177779 4294177779 4294177779 4294177779 4294177779 4294177779 4294177779 4294177779 4294177779 4294177779 4292467161 2524806525 2658695288 4292664540 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4292664540 2608429433 2658432116 4292532954 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4292532954 2608232054 2658366323 4292467161 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4292467161 2608100468 2658037358 4292532954 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292532954 2607771503 2657839979 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 2607639917 2657642600 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 2607442538 2657313635 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 2607113573 2657116256 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 2606850401 2606455643 4294046193 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294046193 2556255581 1311978291 4237003659 4289967027 4289967027 4289967027 4289967027 4289967027 4289967027 4289967027 4289967027 4289967027 4289967027 4237003659 1278555445 50331648 1210986030 1647917369 1647917369 1647917369 1647917369 1647917369 1647917369 1647917369 1647917369 1647917369 1647917369 1210986030 50331648)
	offset: 0@0)! !

!UITheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemSelectedFillStyleFor: aButton
	"Return the taskbar item button fillStyle for the given button."
	
	^ self buttonSelectedFillStyleFor: aButton! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
controlButtonDisabledBorderStyleFor: aButton
	"Return the disabled control button borderStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."

	^self buttonDisabledBorderStyleFor: aButton! !

!UITheme methodsFor: 'border-styles' stamp: ''!
groupLabelBorderStyleFor: aGroupPanel
	"Answer the normal border style for a group label."

	^BorderStyle simple
		width: 0;
		baseColor: Color transparent! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarMouseOverThumbButtonBorderStyleFor: aScrollbar
	"Return the button borderStyle for the given scrollbar when
	the mouse is over the thumb."

	^self scrollbarMouseOverBarButtonBorderStyleFor: aScrollbar! !

!UITheme methodsFor: 'initialization' stamp: ''!
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)! !

!UITheme methodsFor: '*Growl' stamp: ''!
growlContentsColorFor: aGrowlMorph
	^ Color white! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSquareSelectedTopRightForm
	"Answer the form for the top right of a selected square button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 3966269361 3966269361 3966269361 3966269361 3966269361 3966269105 3966269105 3966269105 3966269105 3949492146 3246098890 547072752 4291941599 4291941599 4291941599 4291941599 4291941599 4291941599 4291941599 4291941599 4291810270 4285298585 4282338943 2927923665 4292994026 4292994026 4292994026 4292994026 4292994026 4292994283 4292994283 4292994283 4292994283 4289442502 4281878647 3883238334 4292205027 4292270819 4292270819 4292270819 4292270819 4292270819 4292270819 4292270819 4292270819 4289442758 4282207868 3933503928 4291547356 4291547356 4291547356 4291547356 4291547356 4291547356 4291612893 4291612893 4291612893 4289048003 4282471297 3933240756 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4288653760 4282800518 3933043629 4290297809 4290297809 4290297809 4290297809 4290297809 4290298066 4290298066 4290298066 4290298066 4288325054 4283063947 3932911528 4289640652 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4287930812 4283393168 3932714660 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289180360 4289180360 4289180360 4287602105 4283656596 3932516765 4288588740 4288588740 4288654532 4288654532 4288654532 4288654532 4288654532 4288654532 4288654532 4287339448 4283985817 3932319385 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288194497 4288194497 4287142327 4284314782 3932187795 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4285827758 4284578467 3931924878)
	offset: 0@0)! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
balloonTextColor

	^self textColor! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonBottomMiddleForm
	"Answer the form to use for the bottom middle of a button."

	^self forms at: #buttonBottomMiddle ifAbsent: [Form extent: 1@11 depth: Display depth]! !

!UITheme methodsFor: 'services' stamp: ''!
customQuestionIn: aThemedMorph text: labelText yesText: yesText noText: noText title: aString
	"Answer the result of a question dialog with the given label, button labels and title."

	self questionSound play.
	^((CustomQuestionDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: labelText;
			yesText: yesText help: nil;
			noText: noText help: nil) dialog answer! !

!UITheme methodsFor: 'configure' stamp: ''!
configureDropListMorph: aMorph
	"This also uses the fillStyle hack :(
	 check at: #dropListNormalFillStyleFor: for changing style"! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonTopRightForm
	"Answer the form for the top right of a button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 3753227701 3266885816 2445065404 1187103169 298042307 33554431 0 0 0 0 0 0 4292796126 4291546059 4290427578 4272729260 4021334192 2159655353 75464575 0 0 0 0 0 4294111986 4294111986 4294111986 4293980400 4292401368 4256346802 3467817650 649113776 33554431 0 0 0 4293848814 4293848814 4293848814 4293848814 4293848814 4293388263 4290822336 4071534254 1554886061 33554431 0 0 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4292072403 4020873641 548055722 0 0 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4291611852 3382944675 67108863 0 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293125091 4239701172 2006686619 33554431 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4291809231 3953041054 261724569 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292072403 4171473827 898206089 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4291875024 4256215216 1787069572 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292532954 4291611852 4290822336 2843968387 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4291940817 4291809231 4291677645 3666380936)
	offset: 0@0)! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
updateScrollBarButtonAspect: aMorph color: aColor

	"update aMorph with aColor"

	aMorph ifNil: [ ^ self ].
	aMorph color: aColor! !

!UITheme methodsFor: 'border-styles' stamp: ''!
windowPaneBorderStyleFor: aMorph in: aSystemWindow
	"Answer the border style for a morph that is to be added
	as a pane in the given system window,"

	^BorderStyle simple
		color: aSystemWindow paneColor;
		width: (aMorph borderWidth = 0 ifTrue: [0] ifFalse: [1])! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
dropListDisabledFillStyleFor: aDropList
	"Return the disabled fillStyle for the given drop list."
	
	^ self textEditorDisabledFillStyleFor: aDropList! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newGroupboxIn: aThemedMorph label: aString for: control
	"Answer a groupbox with the given label and control."

	^(self newGroupboxIn: aThemedMorph label: aString)
		addContentMorph: control;
		yourself! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
textEntryCornerStyleIn: aThemedMorph
	"Answer the corner style to use for text entry morphs."
	
	^#square! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarThumbCornerStyleIn: aThemedMorph
	"Allow for themes to override default behaviour."
	
	^#square! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
controlButtonSelectedFillStyleFor: aButton
	"Return the selected control button fillStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."
	
	^self buttonNormalFillStyleFor: aButton! !

!UITheme methodsFor: 'border-styles' stamp: ''!
morphTreeColumnBorderStyleFor: aMorph
	^ self buttonNormalBorderStyleFor: aMorph! !

!UITheme methodsFor: 'defaults' stamp: ''!
editableDropListMargins
	"Answer the text margins for an editable drop list for this theme."
	^ Margin left: 0 top: 3 right: 2 bottom: 1! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
menuColorFor: aThemedMorph

	"Answer the menu color to use."

	| w |

	^ self menuColor
		ifNil: [ aThemedMorph ifNil: [ ^ self defaultMenuColor ].
			w := aThemedMorph isSystemWindow
				ifTrue: [ aThemedMorph ]
				ifFalse: [ aThemedMorph ownerThatIsA: SystemWindow ].
			w
				ifNil: [ self defaultMenuColor ]
				ifNotNil: [ ( w valueOfProperty: #paneColor ) ifNil: [ self defaultMenuColor ] ]
			]! !

!UITheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemSelectedMouseOverBorderStyleFor: aButton
	"Return the selected mouse over taskbar item borderStyle for the given button."

	^ self buttonSelectedMouseOverBorderStyleFor: aButton! !

!UITheme methodsFor: '*Roassal3-UML' stamp: ''!
classBoxBackgroundColor
	^ RSUMLCalypsoSettings lightThemeUMLClassColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newCheckboxIn: aThemedMorph for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText
	"Answer a checkbox with the given label ."

	| answer |
	answer := CheckboxMorph
			on: aModel selected: getSel changeSelected: setSel.
	answer
		getEnabledSelector: enabledSel;
		getLabelSelector: labelSel;
		labelMorph: (self checkboxLabelFor: answer);
		font: self labelFont;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		setBalloonText: helpText.
	^answer! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
disabledColor 
	^ Color gray! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newGroupboxIn: aThemedMorph label: aString forAll: controls
	"Answer a groupbox with the given label and controls."

	^(self newGroupboxIn: aThemedMorph label: aString)
		addContentMorph: (self newColumnIn: aThemedMorph for: controls);
		yourself! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newBalloonHelpIn: aThemedMorph contents: aTextStringOrMorph for: aMorph corner: cornerSymbol
	"Answer a new balloon help morph with the given text
	and positioning for aMorph."
	
	^SimpleBalloonMorph
		string: aTextStringOrMorph
		for: aMorph
		corner: cornerSymbol! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSelectedTopLeftForm
	"Answer the form for the top left of a selected button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 0 0 0 0 0 0 33554431 362719975 1268031205 2541850575 3279521477 3765271736 0 0 0 0 0 111848191 2407633100 4049957547 4266548622 4284838039 4287271854 4290099916 0 0 0 16777471 814060743 3581116602 4266877583 4288982209 4292730856 4292994026 4292994026 4292994026 0 0 16777471 1903987394 4099960739 4285430685 4291349978 4292270819 4292270819 4292270819 4292270819 4292270819 0 0 713067455 4083709352 4288259003 4291547356 4291547356 4291547356 4291547356 4291547356 4291547356 4291547356 0 75464703 3580787373 4287535542 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 33554431 2389802158 4251744930 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 258373546 4016337568 4286878386 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 1097823911 4200558234 4287207349 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 2070376603 4284182168 4286155693 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 3160435603 4284314525 4284577696 4287668413 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 3780930190 4284578211 4284578211 4285301417 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587)
	offset: 0@0)! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newPluggableDialogWindowIn: aThemedMorph title: title for: contentMorph
	"Answer a new pluggable dialog panel with the given content."

	|answer|
	answer := PluggableDialogWindow new
		setWindowColor: aThemedMorph paneColor;
		title: title;
		contentMorph: contentMorph.
	contentMorph ifNotNil: [answer model: nil].
	^answer! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newStringIn: aThemedMorph label: aStringOrText font: aFont style: aStyle
	"Answer a new string/text morph."

	^(EmbossedStringMorph contents: aStringOrText font: aFont)
		style: aStyle! !

!UITheme methodsFor: 'defaults' stamp: ''!
menuItemSelectedTextColorFor: aMenuItem
	"Answer the color to use for selected menu item text."

	^ self settings menuSelectionTextColor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newPanelIn: aThemedMorph
	"Answer a new panel."

	^PanelMorph new
		changeTableLayout;
		layoutInset: 4;
		cellInset: 8;
		cornerStyle: aThemedMorph preferredCornerStyle;
		yourself! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
scrollbarColorFor: aScrollbar
	"Answer the colour for the given scrollbar."

	^self settings standardColorsOnly
		ifTrue: [self settings scrollbarColor]
		ifFalse: [aScrollbar lastPaneColor
					 ifNil: [Color white]]! !

!UITheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemMouseOverFillStyleFor: aButton
	"Return the taskbar item mouse over fillStyle for the given color."

	^ self buttonMouseOverFillStyleFor: aButton! !

!UITheme methodsFor: 'initialization' stamp: ''!
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."

	^ self iconNamed: #radioButtonMarkerForm! !

!UITheme methodsFor: 'label-styles' stamp: ''!
checkboxMarkerForm
	"Answer the form to use for a checkbox marker."

	^self forms at: #checkboxMarker ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'private' stamp: ''!
selectedFillStyleFor: aMorph height: anInteger
	

	^ SolidFillStyle color: (self lightSelectionColorFor:  aMorph)! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSelectedMiddleLeftForm
	"Answer the form for the middle left of a selected button."

	^(Form
	extent: 12@1
	depth: 32
	fromArray: #( 3965347464 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432)
	offset: 0@0)! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newToolbarHandleIn: aThemedMorph
	"Answer a new toolbar handle."

	^PanelMorph new
		fillStyle: Color transparent; "non pane color tracking"
		borderStyle: (BorderStyle raised baseColor: Color blue; width: 1);
		extent: 4@3;
		vResizing: #spaceFill! !

!UITheme methodsFor: 'border-styles' stamp: ''!
listFocusBoundsFor: aListMorph
	"Answer the bounds for drawing the focus indication."

	^aListMorph bounds! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonMouseOverBorderStyleFor: aButton
	"Return the mouse over button borderStyle for the given button."
	
	^self buttonNormalBorderStyleFor: aButton! !

!UITheme methodsFor: 'services' stamp: ''!
chooseOrRequestIn: aThemedMorph title: title labels: labels values: values lines: lines
	"Answer the result of a popup choice with the given title, labels, values and lines."

	| dialog choice |
	dialog := (PopupChoiceOrRequestDialogWindow newWithTheme: aThemedMorph theme)
		title: (title ifEmpty: [ 'Choose' translated ] ifNotEmpty: #asString);
		labels: labels;
		lines: (lines ifNil: [ #() ]);
		model: values.
	choice := dialog openModal choice.
	dialog cancelled ifTrue: [ ^ nil ].
	^ choice ifNil: [ dialog filterValue ]! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarNormalButtonBorderStyleFor: aScrollbar
	"Return the normal button borderStyle for the given scrollbar."

	^BorderStyle simple
		width: 0! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
successTextColor
	^ Color r: 0 g: 0.5 b: 0! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonTopMiddleForm
	"Answer the form for the top middle of a button."

	^(Form
	extent: 1@12
	depth: 32
	fromArray: #( 3971199923 4293585642 4294111986 4293848814 4293585642 4293322470 4293190884 4293059298 4292927712 4292796126 4292796126 4292335575)
	offset: 0@0)! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
scrollbarThumbTopForm
	"Answer the form to use for the top of a vertical scrollbar."

	^self forms at: #sbVThumbTop ifAbsent: [Form extent: 13@7 depth: Display depth]! !

!UITheme methodsFor: 'accessing' stamp: ''!
forms
	"Answer the value of forms"

	^ forms! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newAlphaImageIn: aThemedMorph image: aForm help: helpText
	"Answer an alpha image morph."
	
	|answer|
	answer := AlphaImageMorph new
		hResizing: #rigid;
		vResizing: #rigid;
		setBalloonText: helpText.
	aForm ifNotNil: [answer image: aForm].
	^answer! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newScrollBarUpButtonFor: aScrollbar
	^ BorderedMorph newBounds: (self scrollBarUpButtonBoundsFor: aScrollbar)! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText
	"Answer a drop list for the given model."

	^(EditableDropListMorph basicNew
		basicTheme: self;
			initialize;
			useSelectionIndex: useIndex;
			on: aModel
			list: listSel
			selected: getSel
			changeSelected: setSel)
		selectionColor: self selectionColor;
		getEnabledSelector: enabledSel;
		font: self dropListFont;
		listFont: self listFont;
		cornerStyle: aThemedMorph preferredCornerStyle;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		setBalloonText: helpText;
		basicTheme: nil;
		beReadOnly;
		yourself! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSelectedTopMiddleForm
	"Answer the form to use for the top middle of a selected button."

	^self forms at: #buttonSelectedTopMiddle ifAbsent: [Form extent: 1@12 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
textEditorNormalFillStyleFor: aTextEditor
	"Return the normal fillStyle for the given text editor."
	
	^Color white! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarPressedThumbBorderStyleFor: aScrollbar
	"Return the pressed thumb borderStyle for the given scrollbar."

	^self scrollbarNormalThumbBorderStyleFor: aScrollbar! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
windowInactiveFillStyleFor: aWindow
	"We do not want the lighting effect when the window goes inactive"
	^self windowActiveFillStyleFor: aWindow! !

!UITheme methodsFor: '*DrTests' stamp: ''!
testColorError
	"Should be in SUnit-Core extention methods, but Sunit is used in the bootstrap."
	^ Color red darker darker! !

!UITheme methodsFor: 'sounds' stamp: ''!
windowMaximizeSound
	"Answer the window maximize sound."

	^self soundTheme windowMaximizeSound! !

!UITheme methodsFor: 'label-styles' stamp: ''!
radioButtonMarkerForm
	"Answer the form to use for a radio button marker."

	^(self forms at: #radioButtonMarker ifAbsent: [Form extent: 12@12 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: 'accessing' stamp: ''!
settings
	"Answer the value of settings"

	^ settings! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
basicCreateArrowOfDirection: aSymbolDirection size: finalSizeInteger color: aColor 
	"PRIVATE - create an arrow with aSymbolDirectionDirection,  
	finalSizeInteger and aColor.
	aSymbolDirectionDirection = #top, #bottom. #left or #right .
	Try with:  
	(UITheme current
		basicCreateArrowOfDirection: #top 
		size: 32 
		color: Color lightGreen) asMorph openInHand. 
	Fixed to work with translucent colours."
	
	|form resizeFactor arrow resizedForm |
	resizeFactor := 4.
	form := Form
		extent: finalSizeInteger asPoint * resizeFactor
		depth: Display depth.
	form fillColor: Color transparent.
	arrow := (self createArrowOfDirection: aSymbolDirection in: form boundingBox)
		borderWidth: 1;
		borderColor: aColor lighter.
	self
		updateScrollBarButtonAspect: arrow
		color: (aColor alphaMixed: 0.7 with: Color black).
	arrow fullDrawOn: form getCanvas.
	resizedForm := form
		magnify: form boundingBox
		by: 1 / resizeFactor
		smoothing: 4.
	^resizedForm trimBordersOfColor: Color transparent! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
expanderTitleNormalFillStyleFor: anExpanderTitle
	"Return the normal expander title fillStyle for the given expander title."
	
	^ self buttonNormalFillStyleFor: anExpanderTitle! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSquareSelectedBottomLeftForm
	"Answer the form for the bottom left of a selected square button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 3965347464 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 3965215874 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 3964952703 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 3964821113 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 3964623476 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 3964426350 4286421953 4286421953 4286421953 4286421953 4286356417 4286356417 4286356417 4286356417 4286356417 4286356417 4286356417 3964294248 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685381 4286685381 4286685381 3964097124 4287014602 4287014602 4287014602 4287014346 4287014346 4287014346 4287014346 4287014346 4287014346 4287014346 4287014346 3963833950 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 3829154896 4287211978 4287607252 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 2502502958 4249705579 4284972435 4285038229 4285038229 4285038229 4285038229 4285038229 4285038229 4285038229 4285038229 4285038229 622599196 2351311407 3408802615 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232)
	offset: 0@0)! !

!UITheme methodsFor: 'defaults' stamp: ''!
menuItemNormalTextColorFor: aMenuItem
	"Answer the color to use for normal menu item text."

	^((aMenuItem color luminance - aMenuItem owner paneColor luminance) abs < 0.3)
		ifTrue: [aMenuItem owner paneColor contrastingBlackAndWhiteColor]
		ifFalse: [aMenuItem color]! !

!UITheme methodsFor: 'accessing' stamp: ''!
dockingBarBorderWidth 
	^ 0! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
taskbarMinimizedButtonColorFor: aButton
	"Answer the colour for the given minimized taskbar button."

	^Color transparent! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
verticesForComplexArrow: aRectangle 
	"PRIVATE - answer a collection of vertices to draw a complex arrow"

	|r vertices aux b c|
	r := aRectangle origin extent: aRectangle width asPoint.
	aux := (r width / 5) rounded.
	b := (aux * aux * 2) sqrt.
	c := (b * b * 2) sqrt rounded.
	vertices := OrderedCollection new.
	vertices add: r bottomLeft - (0 @ aux).
	vertices add: r topCenter + (0 @ aux).
	vertices add: r bottomRight - (0 @ aux).
	vertices add: r bottomRight - (aux @ 0).
	vertices add: r topCenter + (0 @ (aux + c)).
	vertices add: r bottomLeft + (aux @ 0).
	^vertices! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonBottomMiddleForm
	"Answer the form for the bottom middle of a button."

	^(Form
	extent: 1@12
	depth: 32
	fromArray: #( 4292072403 4292401368 4292664540 4292927712 4293190884 4293454056 4293717228 4294046193 4294309365 4294572537 4289506476 3443342653)
	offset: 0@0)! !

!UITheme methodsFor: 'services' stamp: ''!
chooseExistingFileReferenceIn: aThemedMorph title: title extensions: exts path: path preview: preview
	"Answer the result of a file name chooser dialog with the given title, extensions
	path and preview type.
	Answer nil or a filename."

	| dialog pathFileReference |
	pathFileReference := path asFileReference.
	dialog := FileDialogWindow basicNew
		basicTheme: aThemedMorph theme;
		previewType: preview;
		fileNameText: pathFileReference basename;
		initialize;
		title: title;
		answerPathName.	
	exts ifNotNil: [ dialog validExtensions: exts ].
	path ifNotNil: [ dialog selectPath: pathFileReference pathString ].
	^ dialog openModal answer ifNotNil: #asFileReference! !

!UITheme methodsFor: 'defaults' stamp: ''!
dropListFont
	"Answer the drop list font to use."

	^self textFont! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSquareSelectedTopLeftForm
	"Answer the form for the top left of a selected square button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 630892779 3329853638 3949492146 3966269361 3966269361 3966269361 3966269361 3966269361 3966269361 3966269361 3966269361 3966269361 3028455632 4282141565 4285561500 4291744478 4291876062 4291876062 4291876062 4291876062 4291876062 4291876062 4291876062 4291876062 3916792766 4281944439 4289771209 4292928234 4292928234 4292928234 4292928234 4292928234 4292994026 4292994026 4292994026 4292994026 3966992312 4282207868 4289705673 4292139234 4292205027 4292205027 4292205027 4292205027 4292205027 4292205027 4292205027 4292205027 3966860723 4282537089 4289311174 4291481564 4291481564 4291481564 4291481564 4291481564 4291481564 4291547356 4291547356 4291547356 3966598062 4282800518 4288785346 4290889686 4290889686 4290889686 4290889686 4290889686 4290889686 4290889686 4290889686 4290889686 3966334888 4283129739 4288456639 4290232273 4290232273 4290232273 4290232273 4290232273 4290297809 4290297809 4290297809 4290297809 3966268835 4283393168 4288062397 4289640396 4289640652 4289640652 4289640652 4289640652 4289640652 4289640652 4289640652 4289640652 3966071197 4283722133 4287799227 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 3965874072 4283985818 4287405242 4288523204 4288523204 4288588740 4288588740 4288588740 4288588740 4288588740 4288588740 4288588740 3965741971 4284314782 4287208120 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 3965544845 4284578467 4285893551 4286288050 4286288050 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587)
	offset: 0@0)! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
menuShadowColor
	^ self settings menuShadowColor! !

!UITheme methodsFor: 'fill-styles-scrollbars' stamp: ''!
scrollbarImageColorFor: aScrollbar
	"Return the scrollbar image colour (on buttons) for the given scrollbar."
	
	^(self baseScrollbarColorFor: aScrollbar) darker! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newYesButtonIn: aThemedMorph for: aModel
	"Answer a new Yes button."

	^(self
			newButtonIn: aThemedMorph
			for: aModel
			getState: nil
			action: #yes
			arguments: nil
			getEnabled: nil
			label: 'Yes' translated
			help: 'Answer yes and close the window' translated)
		hResizing: #rigid;
		vResizing: #rigid! !

!UITheme methodsFor: 'initialization' stamp: ''!
newWindowMenuForm
	"Answer a new form for a window menu box."

	^ self iconNamed: #windowMenuForm! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newTextEntryIn: aThemedMorph for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText
	"Answer a text entry for the given model."

	|pt|
	pt := RubPluggableTextFieldMorph new
		convertTo: aClass;
		alwaysAccept: true;
		on: aModel
		text: getSel
		accept: setSel
		readSelection: nil
		menu: nil;
		acceptOnCR: true;
		getEnabledSelector: enabledSel;
		font: self textFont;
		cornerStyle: (self textEntryCornerStyleIn: aThemedMorph);
		hResizing: #spaceFill;
		vResizing: #rigid;
		setBalloonText: helpText.
	^pt! !

!UITheme methodsFor: 'defaults' stamp: ''!
menuItemDisabledTextColorFor: aMenuItem
	"Answer the color to use for disabled menu item text."

	^((aMenuItem color luminance - aMenuItem owner color luminance) abs < 0.3)
		ifTrue: [aMenuItem owner color contrastingBlackAndWhiteColor muchDarker]
		ifFalse: [aMenuItem owner color muchDarker]! !

!UITheme methodsFor: 'border-styles' stamp: ''!
configureWindowDropShadowFor: aWindow

	aWindow hasDropShadow: false! !

!UITheme methodsFor: 'configure' stamp: ''!
configureTextMorph: textMorph! !

!UITheme methodsFor: 'border-styles' stamp: ''!
scrollPaneNormalBorderStyleFor: aScrollPane
	"Return the normal borderStyle for the given scroll pane."

	^BorderStyle simple
		width: 1;
		baseColor: aScrollPane paneColor! !

!UITheme methodsFor: 'accessing' stamp: ''!
builder
	^ self class builder! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
createArrowOfDirection: aSymbol in: aRectangle 
	"PRIVATE - create an arrow bounded in aRectangle"

	| arrow vertices |
	vertices := self scrollBarButtonArrowVertices: aRectangle.
	""
	arrow := PolygonMorph 
				vertices: vertices
				color: Color transparent
				borderWidth: 0
				borderColor: Color black.
	""
	arrow bounds: (arrow bounds insetBy: (aRectangle width / 6) rounded).
	""
	aSymbol == #right 
		ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 90].
	aSymbol == #bottom 
		ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 180].
	aSymbol == #left 
		ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 270].
	""
	^arrow! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
dropListFocusBoundsFor: aDropList
	"Answer the bounds for drawing the focus indication for the
	given drop list."

	^aDropList bounds! !

!UITheme methodsFor: 'border-styles' stamp: ''!
windowInactiveDropShadowOffsetRectangleFor: aSystemWindow
	"Answer a rectangle describing the offsets for each corner
	of the the inactive window bounds for the drop shadow area."
	
	^self windowPlainDropShadowOffsetRectangleFor: aSystemWindow! !

!UITheme methodsFor: 'border-styles' stamp: ''!
handlesWindowDropShadowInHandFor: aSystemWindow
	"Answer whether the receiver will handle drop shadow drawing
	for a window when picked up in the hand. We will when diffuse."

	^self windowActiveDropShadowStyle == #diffuse and: [
		aSystemWindow isActive]! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newToolDockingBarIn: aThemedMorph
	"Answer a new tool docking bar."

	^ToolDockingBarMorph new
		borderWidth: 0;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		clipSubmorphs: true! !

!UITheme methodsFor: 'border-styles-scrollbars' stamp: ''!
scrollbarPressedBorderStyleFor: aScrollbar
	"Return the pressed borderStyle for the given scrollbar."

	^self scrollbarNormalBorderStyleFor: aScrollbar! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowMaximizePassiveForm
	"Answer the form to use for passive (background) window maximize/restore buttons"

	^ self iconNamed: #windowMaximizeInactiveForm! !

!UITheme methodsFor: 'border-styles' stamp: ''!
drawWindowDiffuseDropShadowFor: aSystemWindow on: aCanvas
	"Draw the diffuse drop shadow for the given window."
	
	|or b r o gc|
	or := self windowActiveDropShadowOffsetRectangleFor: aSystemWindow.
	o := or bottom.
	(aSystemWindow roundedCorners includesAnyOf: #(2 3))
		ifTrue: [o := o + 2].
	b := aSystemWindow bounds expandBy: or.
	gc := {Color black alpha: 0.6. Color transparent}.
	r := b topLeft extent: o asPoint.
	aCanvas
		fillRectangle: r
		fillStyle: ((GradientFillStyle colors: gc)
					origin: r bottomRight;
					direction: o@0;
					radial: true).
	r := b topLeft + (o@0) extent: (b width - o - o @ o).
	aCanvas
		fillRectangle: r
		fillStyle: ((GradientFillStyle colors: gc)
					origin: r bottomLeft;
					direction: 0@o negated).
	r := b topRight - (o@0) extent: o asPoint.
	aCanvas
		fillRectangle: r
		fillStyle: ((GradientFillStyle colors: gc)
					origin: r bottomLeft;
					direction: o@0;
					radial: true).
	r := b topRight + (o negated@o) extent: (o @ (b height - o - o)).
	aCanvas
		fillRectangle: r
		fillStyle: ((GradientFillStyle colors: gc)
					origin: r topLeft;
					direction: o@0).
	r := b bottomRight - o asPoint extent: o asPoint.
	aCanvas
		fillRectangle: r
		fillStyle: ((GradientFillStyle colors: gc)
					origin: r topLeft;
					direction: o@0;
					radial: true).
	r := b bottomLeft + (o@o negated) extent: (b width - o - o @ o).
	aCanvas
		fillRectangle: r
		fillStyle: ((GradientFillStyle colors: gc)
					origin: r topLeft;
					direction: 0@o).
	r := b bottomLeft - (0@o) extent: o asPoint.
	aCanvas
		fillRectangle: r
		fillStyle: ((GradientFillStyle colors: gc)
					origin: r topRight;
					direction: o@0;
					radial: true).
	r := b topLeft + (0@o) extent: (o @ (b height - o - o)).
	aCanvas
		fillRectangle: r
		fillStyle: ((GradientFillStyle colors: gc)
					origin: r topRight;
					direction: o negated@0)! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newTaskbarButtonIn: aTaskbar for: aWindow
	"Answer a taskbar button morph for the given window."

	^ (TaskbarItemMorph on: aWindow getState: #isActive action: #taskbarButtonClicked)
		initializeFor: aTaskbar;
		yourself! !

!UITheme methodsFor: 'defaults' stamp: ''!
buttonPressedLabelInsetFor: aButton
	"Answer the inset to use for a button's label when pressed."

	^self buttonLabelInsetFor: aButton! !

!UITheme methodsFor: 'accessing' stamp: ''!
animationSettings
	^ self settings animationSettings! !

!UITheme methodsFor: 'services' stamp: ''!
chooseIn: aThemedMorph title: title labels: labels values: values lines: lines
	"Answer the result of a popup choice with the given title, labels, values and lines."

	| dialog |
	dialog := (PopupChoiceDialogWindow newWithTheme: aThemedMorph theme)
		title: (title isEmpty ifTrue: ['Choose' translated] ifFalse: [title asString]);
		labels: labels;
		lines: (lines ifNil: [#()]);
		model: values.
	^ dialog openModal choice! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
windowExtentChangedFor: aWindow
	"Update any extent related visuals."! !

!UITheme methodsFor: 'accessing' stamp: ''!
autoMenuColor
	^ self settings autoMenuColor! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
buttonSelectedPressedFillStyleFor: aButton
	"Return the button selected pressed fillStyle for the given color."

	^self buttonNormalFillStyleFor: aButton! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
menuItemSelectedBorderStyleFor: aMenuItem
	"Return the selected menu item borderStyle for the given menu item."

	^BorderStyle simple
		width: 0! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newGroupboxIn: aThemedMorph label: aString
	"Answer a groupbox with the given label."

	^GroupboxMorph new
		font: self labelFont;
		cornerStyle: aThemedMorph preferredCornerStyle;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: aString;
		yourself! !

!UITheme methodsFor: 'border-styles' stamp: ''!
listNormalBorderStyleFor: aList
	"Return the normal borderStyle for the given list"

	^BorderStyle simple
		width: 1;
		baseColor: aList paneColor! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonSelectedBottomLeftForm
	"Answer the form for the bottom left of a selected button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 3713688967 4284841382 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 2840812155 4284841122 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 1783452780 4251022487 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 977750885 4166608772 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 373704285 3813365101 4285499564 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 33554560 1698382676 4166082166 4286224317 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 0 154745173 2889761365 4267668108 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 0 16777216 674444102 3762375258 4285103772 4286948554 4286948554 4286948554 4286948554 4286948554 4286948554 4286948554 0 0 33554432 1294675516 3594273360 4250231929 4286619071 4287277775 4287277775 4287277775 4287277775 4287277775 0 0 0 33554432 640165935 2687513663 4081274461 4285169818 4286882243 4287606740 4287606740 4287606740 0 0 0 0 16777216 134234176 1545872426 3509597758 3980150095 4182267235 4267009399 4284642698 0 0 0 0 0 0 33554432 338044454 941629472 1511791647 2267424813 3123524408)
	offset: 0@0)! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
radioButtonCornerStyleFor: aRadioButton
	"Answer the corner style for radio buttons.
	Answer square when not disabled since the form is rounded."
	
	^aRadioButton enabled
		ifTrue: [#square]
		ifFalse: [#rounded]! !

!UITheme methodsFor: '*Morphic-Widgets-FastTable' stamp: ''!
fastTableColumnSplitterSelectedColor
	^ self selectionColor alpha: 0.3! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newTreeIn: aThemedMorph for: aModel list: listSelector selected: getSelector changeSelected: setSelector
	"Answer a new tree morph."
	
	^TreeListMorph new
		selectionColor: self selectionColor;
		font: self listFont;
		on: aModel
		list: listSelector
		selected: getSelector
		changeSelected: setSelector
		menu: nil
		keystroke: nil;
		cornerStyle: aThemedMorph preferredCornerStyle;
		"color: Color white;"
		borderStyle: (BorderStyle inset width: 1);
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		autoDeselect: false;
		yourself! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
progressBarProgressColorFor: aProgressBar
	"Answer the colour for the progress part of the given progress bar."

	^self settings progressBarProgressColor! !

!UITheme methodsFor: 'label-styles' stamp: ''!
treeUnexpandedForm
	"Answer the form to use for an unexpanded tree item."

	^(self forms at: #treeUnexpanded ifAbsent: [Form extent: 10@9 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: 'initialization' stamp: ''!
updateWorldDockingBars
	"Update the world docking bar gradients."
	
	self currentWorld mainDockingBars do: [:d |
		d
			color: (self worldMainDockingBarColorFor: d);
			gradientRamp: (self class current
				worldMainDockingBarNormalFillStyleFor: d) colorRamp;
			borderStyle: (self worldMainDockingBarBorderStyleFor: d)]! !

!UITheme methodsFor: 'basic-colors' stamp: ''!
baseColorFor: aWidget

	^ self class baseColor! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSquareBottomRightForm
	"Answer the form to use for the bottom right of a square button."

	^self forms at: #buttonSquareBottomRight ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: '*Spec2-Adapters-Morphic' stamp: ''!
modalBackdropColor
	self flag: #pharoTodo. "This method should probably be moved to Pharo later."

	^ Color black alpha: 0.2! !

!UITheme methodsFor: 'accessing' stamp: ''!
soundTheme
	"Answer the sound theme to use, if not specified
	use the default sound theme."

	^soundTheme ifNil: [self defaultSoundTheme]! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowMinimizePassiveForm
	"Answer the form to use for passive (background) window minimize buttons"

	^ self iconNamed: #windowMinimizeInactiveForm! !

!UITheme methodsFor: 'border-styles' stamp: ''!
worldMainDockingBarBorderStyleFor: aDockingBar
	"Return the world main docking bar borderStyle for the given docking bar."

	^BorderStyle simple
		width: 0;
		color: Color transparent! !

!UITheme methodsFor: 'border-styles' stamp: ''!
drawTabGroupFinishingFor: aTabGroupMorph on: aCanvas
	"Patch up any visuals for the selected tab."! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
controlButtonNormalFillStyleFor: aButton
	"Return the normal control button fillStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."
	
	^self buttonSelectedFillStyleFor: aButton! !

!UITheme methodsFor: '*Morphic-Widgets-Taskbar' stamp: ''!
newBasicTaskbarButtonIn: aTaskbar for: aMorph
	"Answer a taskbar button morph for the given window."

	|lm lab button labSize|
	
	labSize := (150 // (aTaskbar tasks size + 1) max: 10) min: 30.
	
	lab := (self buttonLabelForText: (aMorph taskbarLabel truncateWithElipsisTo: labSize)).
	
	aMorph taskbarButtonIsActive ifTrue: [ lab emphasis: 1 ].
	
	lm := self 
		newRowIn: aTaskbar
		for: {(aMorph taskbarIcon ifNil: [^nil]) asMorph. lab}.
		
	lm cellInset: 2.
	
	button := self
		newButtonIn: aTaskbar
		for: aMorph
		getState: #taskbarButtonIsActive
		action: #taskbarButtonClicked
		arguments: #()
		getEnabled: nil
		label: lm
		help: nil.
		
	button 
		useSquareCorners;
		wantsYellowButtonMenu: true;
		getMenuSelector: #taskbarButtonMenu:.


	^button! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newVerticalSeparatorIn: aThemedMorph
	"Answer a new vertical separator."

	^SeparatorMorph new
		fillStyle: Color transparent;
		borderStyle: (BorderStyle inset baseColor: Color blue; width: 1);
		extent: 2@2;
		vResizing: #spaceFill! !

!UITheme methodsFor: 'fill-styles-taskbar' stamp: ''!
taskbarItemPressedFillStyleFor: aButton
	"Return the taskbar item pressed fillStyle for the given button."
		
	^ self buttonPressedFillStyleFor: aButton! !

!UITheme methodsFor: 'defaults' stamp: ''!
dropListFocusIndicatorCornerRadiusFor: aDropList
	"Answer the default corner radius preferred for the focus indicator
	for the drop list for themes that support this."

	^aDropList wantsRoundedCorners
		ifTrue: [7]
		ifFalse: [2]! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newColorPresenterIn: aThemedMorph for: aModel getColor: getSel help: helpText
	"Answer a color presenter."

	^(ColorPresenterMorph
			on: aModel color: getSel)
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		setBalloonText: helpText! !

!UITheme methodsFor: 'sounds' stamp: ''!
abortSound
	"Answer the abort sound."

	^self soundTheme abortSound! !

!UITheme methodsFor: 'accessing - colors' stamp: ''!
textColor 
	^ Color black! !

!UITheme methodsFor: 'fill-styles' stamp: ''!
buttonSquareSelectedTopRightForm
	"Answer the form to use for the top right of a selected square button."

	^self forms at: #buttonSquareSelectedTopRight ifAbsent: [Form extent: 12@12 depth: Display depth]! !

!UITheme methodsFor: 'fill-styles-buttons' stamp: ''!
controlButtonSelectedMouseOverFillStyleFor: aButton
	"Return the selected mouse over control button fillStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."
	
	^self controlButtonSelectedFillStyleFor: aButton! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
buttonNormalBorderStyleFor: aButton
	"Return the normal button borderStyle for the given button."

	^BorderStyle simple
		width: 0;
		baseColor: Color transparent! !

!UITheme methodsFor: 'border-styles' stamp: ''!
dropListNormalBorderStyleFor: aDropList
	"Return the normal borderStyle for the given drop list"

	^ self buttonNormalBorderStyleFor: aDropList! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newOverflowRowIn: aThemedMorph forAll: aCollectionOfMorphs
	"Answer a new overflow row morph with the given contents."

	^OverflowRowMorph new
		baseMorphs: aCollectionOfMorphs;
		yourself! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowMenuForm
	"Answer the form to use for the menu button of a window."

	^(self forms at: #windowMenu ifAbsent: [Form extent: 10@10 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newAlphaSelectorIn: aThemedMorph for: aModel getAlpha: getSel setAlpha: setSel help: helpText
	"Answer an alpha selector ."

	^(AColorSelectorMorph
			on: aModel
			getValue: getSel
			setValue: setSel)
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		setBalloonText: helpText! !

!UITheme methodsFor: 'testing' stamp: ''!
shouldUseAnimations
	^ self animationSettings useAnimation! !

!UITheme methodsFor: 'label-styles' stamp: ''!
windowMaximizeOverForm
	"Answer the form to use for mouse over window maximize buttons"

	^(self forms at: #windowMaximizeOver ifAbsent: [Form extent: 16@16 depth: Display depth]) scaledByDisplayScaleFactor! !

!UITheme methodsFor: 'scrollbars' stamp: ''!
scrollBarButtonArrowVertices: aRectangle 
	^ self verticesForComplexArrow: aRectangle! !

!UITheme methodsFor: 'initialization' stamp: ''!
newButtonBottomLeftForm
	"Answer the form for the bottom left of a button."

	^(Form
	extent: 12@12
	depth: 32
	fromArray: #( 3716317826 4291743438 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 2842718320 4290953922 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 1784635231 4255886251 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 978802519 4170157967 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 374427985 3815599469 4291611852 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 41975936 1699499084 4168973693 4293190884 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 0 154745145 2891010385 4271873951 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 0 16777216 675299392 3764280926 4290098613 4293980400 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 0 0 33554432 1295332661 3595850836 4253583496 4292993505 4294309365 4294309365 4294309365 4294309365 4294309365 0 0 0 33554432 640626479 2688433726 4083574374 4289835441 4293125091 4294506744 4294572537 4294572537 0 0 0 0 16777216 138428480 1546267178 3510780482 3981989976 4184895600 4270360712 4288651167 0 0 0 0 0 0 33554432 338044454 941629472 1511989023 2268016431 3124575549)
	offset: 0@0)! !

!UITheme methodsFor: 'morph creation' stamp: ''!
newTaskbarThumbnailIn: aThemedMorph for: aWindow
	"Answer a taskbar thumbnail morph for the given window."

	|answer thumb|
	thumb := aWindow taskbarThumbnail.
	answer := PanelMorph new
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		changeTableLayout;
		layoutInset: 8;
		cellInset: 4;
		addMorphBack: thumb;
		addMorphBack: ((self
			buttonLabelForText: (aWindow labelString truncateWithElipsisTo: 50))
				color: Color white).
	answer
		extent: answer minExtent;
		fillStyle: (self taskListFillStyleFor: answer);
		borderStyle: (self taskbarThumbnailNormalBorderStyleFor: aWindow);
		cornerStyle: (self taskbarThumbnailCornerStyleFor: answer).
	^answer! !

!UITheme methodsFor: 'services' stamp: ''!
passwordEntryIn: aThemedMorph text: aStringOrText title: aString entryText: defaultEntryText
	"Answer the result of a password entry dialog (a string or nil if cancelled)
	with the given label and title."

	^((PasswordDialogWindow newWithTheme: aThemedMorph theme)
			textFont: self textFont;
			title: aString;
			text: aStringOrText;
			entryText: defaultEntryText) openModal entryText! !

!UITheme methodsFor: 'border-styles-taskbar' stamp: ''!
taskbarItemDisabledBorderStyleFor: aButton
	"Return the disabled taskbar item borderStyle for the given button."

	^ self buttonDisabledBorderStyleFor: aButton! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
controlButtonSelectedMouseOverBorderStyleFor: aButton
	"Return the selected mouse over control button borderStyle for the given button.
	Control buttons are generally used for drop-lists and expanders."

	^self buttonSelectedMouseOverBorderStyleFor: aButton! !

!UITheme methodsFor: 'border-styles-buttons' stamp: ''!
radioButtonDisabledBorderStyleFor: aRadioButton
	"Return the disabled radio button borderStyle for the given button."

	^self checkboxButtonDisabledBorderStyleFor: aRadioButton! !

!UITheme class methodsFor: 'accessing' stamp: ''!
currentSettings
	"Answer the current ui theme settings."

	^ self current settings! !

!UITheme class methodsFor: 'accessing' stamp: ''!
newDefaultSettings
	self setPreferredPreferences.
	
	^ThemeSettings new
		buttonColor: Color gray;
		scrollbarColor: Color gray;
		menuColor: self baseColor;
		menuTitleColor: self baseColor;
		windowColor: self baseColor;
		selectionColor: self lightSelectionColor;
		menuSelectionColor: self baseSelectionColor;
		progressBarColor: self baseColor;
		standardColorsOnly: true;
		autoSelectionColor: false;
		preferRoundCorner: false;
		fadedBackgroundWindows: false;
		flatMenu: true! !

!UITheme class methodsFor: 'accessing' stamp: ''!
themeName
	"Answer the friendly name of the theme."

	self subclassResponsibility! !

!UITheme class methodsFor: 'accessing' stamp: ''!
current
	"Answer the current ui theme.
	WARNING: Direct access to this method is ill-adviced, use self theme instead."

	^Current ifNil: [
		Current := PharoLightTheme newDefault.
		Current ]! !

!UITheme class methodsFor: 'accessing' stamp: ''!
standardThemeClass
	^ PharoLightTheme! !

!UITheme class methodsFor: 'accessing' stamp: ''!
basePassiveBackgroundColor 
	^ self subclassResponsibility! !

!UITheme class methodsFor: 'settings' stamp: ''!
setPreferredPreferences 
	self subclassResponsibility! !

!UITheme class methodsFor: 'accessing' stamp: ''!
baseColor
	self subclassResponsibility! !

!UITheme class methodsFor: 'accessing' stamp: ''!
veryLightSelectionColor 
	^ self subclassResponsibility! !

!UITheme class methodsFor: 'accessing' stamp: ''!
defaultSettings
	"Answer the default settings for the theme."
	
	^defaultSettings ifNil: [
		self defaultSettings: self newDefaultSettings.
		defaultSettings]! !

!UITheme class methodsFor: 'accessing' stamp: ''!
lightBaseColor
	self subclassResponsibility! !

!UITheme class methodsFor: 'accessing' stamp: ''!
baseSelectionColor 
	^ self subclassResponsibility! !

!UITheme class methodsFor: 'query' stamp: ''!
allThemeClasses
	"Answer the subclasses of the receiver that are considered to be
	concrete (useable as a theme)."

	^(self allSubclasses reject: [:c | c isAbstract]) asSortedCollection: [:a :b |
		a themeName <= b themeName]! !

!UITheme class methodsFor: 'query' stamp: ''!
beCurrent
	"Make a new instance of the receiver be the current theme."

	self isAbstract ifTrue: [^self error: self name, ' is abstract, send #beCurrent to a subclass.'].
	self current: self newDefault! !

!UITheme class methodsFor: 'accessing' stamp: ''!
lightSelectionColor 
	^ self subclassResponsibility! !

!UITheme class methodsFor: 'class initialization' stamp: ''!
initialize
	"self initialize"
	self current class = UITheme
		ifTrue: [self current: nil
			"due to change to being abstract"].! !

!UITheme class methodsFor: 'accessing' stamp: ''!
current: aUITheme
	"Set the current ui theme."

	Current := aUITheme.
	SystemProgressMorph reset. "reset to use new fill styles"
	ScrollBarMorph initializeImagesCache. "reset to use new arrows"

	self class environment at: #SHPreferences ifPresent: [ :shPreferences |
		shPreferences setStyleTable: aUITheme shStyleTable ].

	self class environment at: #PolymorphSystemSettings ifPresent: [ :polymorphSystemSettings |
		polymorphSystemSettings desktopColor: aUITheme desktopColor ].
	
	self class environment at: #NECPreferences ifPresent: [ :necPreferences |
		necPreferences backgroundColor: aUITheme windowColor ].

	self class environment at: #Paragraph ifPresent: [ :paragraph |
		paragraph insertionPointColor: aUITheme caretColor ].

	self class environment at: #BalloonMorph ifPresent: [ :balloonMorph |
		balloonMorph setBalloonColorTo: aUITheme balloonBackgroundColor ].

	aUITheme updateWorldDockingBars.
	self currentWorld themeChanged.
	(SystemWindow allSubInstances select:[:e | e owner isNil]) do: [ :each | each themeChanged ].

	SystemAnnouncer uniqueInstance announce: UIThemeChanged! !

!UITheme class methodsFor: 'initialize-release' stamp: ''!
resetBuilder
	<script>
	
	Builder := nil! !

!UITheme class methodsFor: 'accessing' stamp: ''!
newDefault
	"Answer a new default ui theme."

	^self new! !

!UITheme class methodsFor: 'accessing' stamp: ''!
resetAllDefaultSettings
	"Reset the default settings of all themes"
	"self resetAllDefaultSettings"
	self withAllSubclassesDo: [:cls | cls defaultSettings: nil]! !

!UITheme class methodsFor: 'testing' stamp: ''!
isCurrent
	"Answer whether an instance of the receiver is the current theme."

	^Current class == self! !

!UITheme class methodsFor: 'accessing' stamp: ''!
resetDefaultSettings
	"Reset the default settings to use the original values."

	self defaultSettings: nil! !

!UITheme class methodsFor: 'accessing' stamp: ''!
defaultSettings: aThemeSettings
	"Set the default settings for the theme."
	
	defaultSettings := aThemeSettings! !

!UITheme class methodsFor: 'testing' stamp: ''!
isAbstract
	"Answer whether the receiver is considered to be abstract."

	^true! !

!UITheme class methodsFor: 'accessing' stamp: ''!
builder
	"Answer a morph that has the TEasilyThemed trait."

	^Builder ifNil: [Builder := self newBuilder. Builder]! !

!UITheme class methodsFor: 'accessing' stamp: ''!
newBuilder
	"Answer a new builder morph."

	^ComposableMorph new! !

!UITheme class methodsFor: 'cleanup' stamp: ''!
cleanUp

	"avoid old references to morphs that should be garbage-collected"
	UITheme current focusIndicator: nil.! !

!UITheme class methodsFor: 'accessing' stamp: ''!
darkBaseColor
	self subclassResponsibility! !

!UIThemeDecorator commentStamp: ''!
I decorate a UITheme allowing to override desired properties.

See #example on class side.!
!UIThemeDecorator methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	(self hasProperty: aMessage selector)
		ifTrue: [ |objOrBlock|
			objOrBlock := self objectAtProperty: aMessage selector.
			^ objOrBlock isBlock
				ifTrue: [ objOrBlock valueWithPossibleArgs: aMessage arguments ]
				ifFalse: [ objOrBlock value ] ].
	
	self theme
		ifNotNil: [ :t | ^ t perform: aMessage selector withArguments: aMessage arguments ].
	
	^ super doesNotUnderstand: aMessage! !

!UIThemeDecorator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	themeOverrideDict := Dictionary new! !

!UIThemeDecorator methodsFor: 'accessing' stamp: ''!
objectAtProperty: aSymbol
	^ themeOverrideDict at: aSymbol! !

!UIThemeDecorator methodsFor: 'accessing' stamp: ''!
theme
	^ theme! !

!UIThemeDecorator methodsFor: 'accessing' stamp: ''!
theme: anObject
	theme := anObject! !

!UIThemeDecorator methodsFor: 'accessing' stamp: ''!
property: aSymbol returnsValueOf: anObject
	themeOverrideDict
		at: aSymbol put: anObject! !

!UIThemeDecorator methodsFor: 'testing' stamp: ''!
hasProperty: aSymbol
	^ themeOverrideDict includesKey: aSymbol! !

!UIThemeDecorator class methodsFor: 'instance creation' stamp: ''!
theme: aUITheme
	^ self new
		theme: aUITheme;
		yourself! !

!UIThemeDecorator class methodsFor: 'examples' stamp: ''!
exampleDecoratorToMakePluggableButtonRed
	| normalColorBlock clickedColorBlock |
	normalColorBlock := [ :aButton |
							(aButton valueOfProperty: #noFill ifAbsent: [false]) 
								ifTrue: [ SolidFillStyle color: Color transparent ]
								ifFalse: [ SolidFillStyle color: Color red ] ].
	clickedColorBlock := [ :aButton | SolidFillStyle color: Color red muchDarker ].
	^ (UIThemeDecorator theme: Smalltalk ui theme)
			property: #buttonNormalFillStyleFor: returnsValueOf: normalColorBlock;
			property: #buttonMouseOverFillStyleFor: returnsValueOf: normalColorBlock;
			property: #buttonPressedFillStyleFor: returnsValueOf: clickedColorBlock;
			yourself! !

!UIThemeDecoratorTest commentStamp: ''!
I hold tests for UIThemeDecorator.!
!UIThemeDecoratorTest methodsFor: 'tests' stamp: ''!
testDoesNotUnderstand
	| block |
	themeDecorator
		property: #foo returnsValueOf: 42.
		
	self assert: (themeDecorator foo) equals: 42.
	
	block := [ 42 ].
	themeDecorator
		property: #fooBlock returnsValueOf: block.
	"Returns the result of the block evaluation."
	self assert: (themeDecorator fooBlock) equals: 42.
	
	block := [ :x | x + 42 ].
	
	themeDecorator
		property: #fooBlock: returnsValueOf: block.
	"Returns the result of the block evaluation."
	self assert: (themeDecorator fooBlock: 3) equals: 45.! !

!UIThemeDecoratorTest methodsFor: 'tests' stamp: ''!
testHasProperty
	self
		assert: (themeDecorator hasProperty: #buttonNormalFillStyleFor:);
		assert: (themeDecorator hasProperty: #buttonMouseOverFillStyleFor:);
		assert: (themeDecorator hasProperty: #buttonPressedFillStyleFor:);
		deny: (themeDecorator hasProperty: #controlButtonSelectedDisabledFillStyleFor:);
		deny: (themeDecorator hasProperty: #scrollbarMouseOverBorderStyleFor:);
		deny: (themeDecorator hasProperty: #scrollbarThumbCornerStyleIn:)! !

!UIThemeDecoratorTest methodsFor: 'tests' stamp: ''!
testPropertyReturnsValueOf
	| block |
	themeDecorator
		property: #foo returnsValueOf: 42.
		
	self assert: (themeDecorator objectAtProperty: #foo) equals: 42.
	
	block := [ 42 ].
	
	themeDecorator
		property: #fooBlock returnsValueOf: block.
	"Returns the block, not its value."
	self assert: (themeDecorator objectAtProperty: #fooBlock) equals: block.! !

!UIThemeDecoratorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	themeDecorator := UIThemeDecorator exampleDecoratorToMakePluggableButtonRed! !

!UIThemeRegistry commentStamp: ''!
Registry for UI themes!
!UIThemeRegistry class methodsFor: 'accessing' stamp: ''!
icons
	^ ThemeIcons current! !

!UIThemeRegistry class methodsFor: 'accessing' stamp: ''!
theme 
	^ UITheme current! !

!UNCNetworkPath commentStamp: ''!
I am a path to express UNC paths e.g.,	
	#( '\\MachineName.x.y.z\directory\file' '\\MachineName.x.y.z\directory' '\\MachineName.x.y.z' ) .

This is useful to represent files in SMB shares as used by Windows or Samba.

A NetworkPath acts as an absolute path but with a different translation to string.!
!UNCNetworkPath methodsFor: 'printing' stamp: ''!
printPathOn: aStream delimiter: aCharacter
	"Print the path elements of the receiver, without the 'Path *' part"

	aStream nextPut: aCharacter.
	aStream nextPut: aCharacter.
	super printPathOn: aStream delimiter: aCharacter! !

!UNCNetworkPath methodsFor: 'testing' stamp: ''!
isNetworkPath

	^ true! !

!UNCNetworkPath methodsFor: 'enumerating' stamp: ''!
withParents

	^ super withParents! !

!UNCNetworkPath methodsFor: 'printing' stamp: ''!
printOn: aStream delimiter: aCharacter

	aStream nextPut: aCharacter.
	aStream nextPut: aCharacter.
	super printOn: aStream delimiter: aCharacter! !

!UNCNetworkPath methodsFor: 'testing' stamp: ''!
isRoot
	
	"A network path is a root if it only has the machine name, it is of the form \\machine"
	^ self size = 1.! !

!UNCNetworkPath methodsFor: 'testing' stamp: ''!
isAbsolute
	
	^ true! !

!UNCNetworkPath methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: 'Path ''//'. 
	
	self segments do: [ :e | aStream nextPutAll: e ]
		separatedBy: [ aStream nextPutAll: '/' ].

	aStream nextPut: $'.! !

!UTF8InvalidText commentStamp: ''!
UTF8InvalidText!
!UTF8TextConverter commentStamp: ''!
Text converter for UTF-8.  Since the BOM is used to distinguish the MacRoman code and UTF-8 code, BOM is written for UTF-8 by #writeBOMOn: which is called by client.!
!UTF8TextConverter methodsFor: 'friend' stamp: ''!
leadingChar

	^ self shouldNotImplement
! !

!UTF8TextConverter methodsFor: 'converting' stamp: ''!
errorMalformedInput
	^UTF8InvalidText new signal: 'Invalid utf8 input detected'! !

!UTF8TextConverter methodsFor: 'converting' stamp: ''!
nextFromStream: aStream

	| character1 value1 character2 value2 unicode character3 value3 character4 value4 |

	aStream isBinary
		ifTrue: [ ^ aStream basicNext ].
	character1 := aStream basicNext.
	character1 ifNil: [ ^ nil ].
	value1 := character1 asciiValue.
	value1 <= 127
		ifTrue: [ "1-byte character" ^ character1 ].	"at least 2-byte character"
	character2 := aStream basicNext.
	character2 ifNil: [ ^ self errorMalformedInput ].
	value2 := character2 asciiValue.
	( value1 bitAnd: 16rE0 ) = 192
		ifTrue: [ ^ Unicode value: ( ( value1 bitAnd: 31 ) bitShift: 6 ) + ( value2 bitAnd: 63 ) ].	"at least 3-byte character"
	character3 := aStream basicNext.
	character3 ifNil: [ ^ self errorMalformedInput ].
	value3 := character3 asciiValue.
	( value1 bitAnd: 16rF0 ) = 224
		ifTrue: [ unicode := ( ( value1 bitAnd: 15 ) bitShift: 12 ) + ( ( value2 bitAnd: 63 ) bitShift: 6 )
				+ ( value3 bitAnd: 63 )
			].
	( value1 bitAnd: 16rF8 ) = 240
		ifTrue: [ "4-byte character"
			character4 := aStream basicNext.
			character4 ifNil: [ ^ self errorMalformedInput ].
			value4 := character4 asciiValue.
			unicode := ( ( value1 bitAnd: 16r7 ) bitShift: 18 ) + ( ( value2 bitAnd: 63 ) bitShift: 12 )
				+ ( ( value3 bitAnd: 63 ) bitShift: 6 ) + ( value4 bitAnd: 63 )
			].
	unicode ifNil: [ ^ self errorMalformedInput ].
	unicode > 16r10FFFD
		ifTrue: [ ^ self errorMalformedInput ].
	unicode = 16rFEFF
		ifTrue: [ ^ self nextFromStream: aStream ].
	^ Unicode value: unicode! !

!UTF8TextConverter class methodsFor: 'accessing' stamp: ''!
writeBOMOn: aStream
	"Write Byte Order Mark"
	aStream nextPut: 16rEF.
	aStream nextPut: 16rBB.
	aStream nextPut: 16rBF.
! !

!UTF8TextConverter class methodsFor: 'utilities' stamp: ''!
encodingNames

	^ #('utf-8' 'utf8') copy.
! !

!UUID commentStamp: ''!
I am UUID.
I am a ByteArray.

An RFC4122 Universally Unique Identifier (UUID) is an opaque 128-bit number that can be used for identification purposes. Concretely, a UUID is a 16 element byte array.

The intent of UUIDs is to enable distributed systems to uniquely identify information without significant central coordination. In this context the word unique should be taken to mean "practically unique" rather than "guaranteed unique".

Usage:

	UUID new.
	
Whenever you create a new UUID, the shared, default UUIDGenerator will be used to generate a new, unique UUID.

See UUIDGenerator for extensive documentation on how UUIDs are actually generated.

UUIDs have a standard string representation, like this:

	3ccb64f1-aa04-0d00-bbbc-259a0f871399
	
The representation consists of 32 lowercase hexadecimal digits, displayed in five groups separated by hyphens, in the form 8-4-4-4-12 for a total of 36 characters (32 alphanumeric characters and four hyphens).

My #printOn: #printString and #asString methods produce this representation.  My class' #fromString: or instance #readFrom: parse it.

Alternatively, my base 36 number representation is  the shortest representation still being able to work as filenames etc since it does not depend on case nor characters that might cause problems, and it is reasonably short.

See #asString36 and my class' #fromString36:

UUIDs are basically opaque (contain no interesting content) and should be treated as indivisable values. Do not use parts of them, since these will most probably no longer be unique.

See also:

  http://en.wikipedia.org/wiki/UUID
  https://tools.ietf.org/html/rfc4122!
!UUID methodsFor: 'converting' stamp: ''!
asString36
	"Return a String encoding the receiver as a base 36 number using 0-9 and lowercase a-z.
	This is the shortest representation still being able to work as
	filenames etc since it does not depend on case nor characters
	that might cause problems, and it is reasonably short."

	| num |
	num := 0.
	1 to: self size do: [ :i | num := num + ((256 raisedTo: i - 1) * (self at: i)) ].
	^ (num printStringBase: 36) asLowercase! !

!UUID methodsFor: 'comparing' stamp: ''!
< aMagnitude 
	"Answer whether the receiver is less than the argument."

	(self size = aMagnitude size) ifFalse: [ 
		^ self size < aMagnitude size ].
	1 to: self size do: [:i |
		(self at: i) = (aMagnitude at: i) ifFalse: [
			^ (self at: i) < (aMagnitude at: i) ]].			
	^false.! !

!UUID methodsFor: 'converting' stamp: ''!
asString
	"Return a String with my official representation, 32 lowercase hexadecimal digits, displayed in five groups separated by hyphens, in the form 8-4-4-4-12 for a total of 36 characters (32 alphanumeric characters and four hyphens)"
	
	^ self printString! !

!UUID methodsFor: 'comparing' stamp: ''!
>= aMagnitude 
	"Answer whether the receiver is greater than or equal to the argument."

	^(self < aMagnitude) not! !

!UUID methodsFor: 'comparing' stamp: ''!
> aMagnitude 
	"Answer whether the receiver is greater than the argument."

	^aMagnitude < self! !

!UUID methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	UUIDGenerator default placeFields: self! !

!UUID methodsFor: 'testing' stamp: ''!
isNilUUID
	"Return true when I am equal to the nilUUID, 00000000-0000-0000-0000-000000000000, false otherwise"
	
	^ self allSatisfy: [ :each | each isZero ]! !

!UUID methodsFor: 'printing' stamp: ''!
printString
	"Return a String with my official representation, 32 lowercase hexadecimal digits, displayed in five groups separated by hyphens, in the form 8-4-4-4-12 for a total of 36 characters (32 alphanumeric characters and four hyphens)"

	^ String 
		new: 36 
		streamContents: [ :stringStream | self printOn: stringStream ]! !

!UUID methodsFor: 'initialization' stamp: ''!
readFrom: aStream
	"Read my official representation, 32 lowercase hexadecimal digits, displayed in five groups separated by hyphens, in the form 8-4-4-4-12 for a total of 36 characters (32 alphanumeric characters and four hyphens) from aStream"
	
	1 to: 4 do: [ :i | self at: i put: (Integer readHexByteFrom: aStream) ].
	aStream next = $- ifFalse: [ self error: '- separator expected' ].
	5 to: 6 do: [ :i | self at: i put: (Integer readHexByteFrom: aStream) ].
	aStream next = $- ifFalse: [ self error: '- separator expected' ].
	7 to: 8 do: [ :i | self at: i put: (Integer readHexByteFrom: aStream) ].
	aStream next = $- ifFalse: [ self error: '- separator expected' ].
	9 to: 10 do: [ :i | self at: i put: (Integer readHexByteFrom: aStream) ].
	aStream next = $- ifFalse: [ self error: '- separator expected' ].
	11 to: 16 do: [ :i | self at: i put: (Integer readHexByteFrom: aStream) ]! !

!UUID methodsFor: 'comparing' stamp: ''!
<= aMagnitude 
	"Answer whether the receiver is less than or equal to the argument."

	^(self > aMagnitude) not! !

!UUID methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Print my official representation, 32 lowercase hexadecimal digits, displayed in five groups separated by hyphens, in the form 8-4-4-4-12 for a total of 36 characters (32 alphanumeric characters and four hyphens) on aStream"

	1 to: 4 do: [ :i | (self at: i) printLowercaseHexByteOn: aStream ].
	aStream nextPut: $-.
	5 to: 6 do: [ :i | (self at: i) printLowercaseHexByteOn: aStream ].
	aStream nextPut: $-.
	7 to: 8 do: [ :i | (self at: i) printLowercaseHexByteOn: aStream ].
	aStream nextPut: $-.
	9 to: 10 do: [ :i | (self at: i) printLowercaseHexByteOn: aStream ].
	aStream nextPut: $-.
	11 to: 16 do: [ :i | (self at: i) printLowercaseHexByteOn: aStream ]! !

!UUID class methodsFor: 'instance creation' stamp: ''!
fromString: aString
	"Read a UUID from aString with my official representation, 32 lowercase hexadecimal (base 16) digits, displayed in five groups separated by hyphens, in the form 8-4-4-4-12 for a total of 36 characters (32 alphanumeric characters and four hyphens)"

	| uuid |
	aString size ~= 36 ifTrue: [ self error: 'a UUID should be 36 characters' ].
	uuid := self nilUUID. 
	uuid readFrom: aString readStream.
	^ uuid! !

!UUID class methodsFor: 'instance creation' stamp: ''!
new
	"Create and return a new UUID"
	
	"self new"
	
	^ (self new: 16)! !

!UUID class methodsFor: 'instance creation' stamp: ''!
new: aSize

	(aSize == 16) ifFalse: [ self error: 'Wrong UUID size' ].
	
	^ super new: aSize! !

!UUID class methodsFor: 'instance creation' stamp: ''!
fromString36: aString
	"Decode a UUID from a base 36 string using 0-9 and lowercase a-z.
	This is the shortest representation still being able to work as
	filenames etc since it does not depend on case nor characters
	that might cause problems."

	| object num |
	object := self nilUUID.
	num := Integer readFrom: aString asUppercase readStream base: 36.
	1 to: 16 do: [:i | object at: i put: (num byteAt: i)].
	^object! !

!UUID class methodsFor: 'instance creation' stamp: ''!
nilUUID
	"Return a empty un-initialized UUID, with all zero values, 00000000-0000-0000-0000-000000000000"
	
	"self nilUUID"
	
	"Must call basicNew: here because I have a non-trivial initialize method."

	^ self basicNew: 16! !

!UUIDGenerator commentStamp: ''!
I am UUIDGenerator, I generate UUIDs.

An RFC4122 Universally Unique Identifier (UUID) is an opaque 128-bit number that can be used for identification purposes. Concretely, a UUID is a 16 element byte array.

The intent of UUIDs is to enable distributed systems to uniquely identify information without significant central coordination. In this context the word unique should be taken to mean "practically unique" rather than "guaranteed unique".
 
I generate UUIDs similar, in spirit, to those defined in RFC4122, though I use version 0 to indicate that I follow none of the defined versions. This does not matter much, if at all, in practice.

I try to conform to the following aspects:
 - each 'node' (machine, image, instance) should generate unique UUIDs
 - even when generating UUIDs at a very fast rate, they should remain unique
 - be fast and efficient

To achieve this goal, I
- take several aspects into account to generate a unique node ID
- combine a clock, a counter and some random bits
- hold a state, protected for multi user access

I can generate about 500K UUIDs per second.

Implementation:

Although a UUID should be seen as totally opaque, here is the concrete way I generate one:
- the first 8 bytes are the microsecond clock value with the smallest quantity first; this means that the later of these 8 bytes will be identical when generated with small(er) timespans; within the same clock resolution interval, the full first 8 bytes will be identical
- the next 2 bytes represent a counter with safe overflow, held as protected state inside me; after 2*16 this value will repeat; the counter initalizes with a random value
- the next 2 bytes are simply random, based on the system PRNG, Random
- the final 4 bytes represent the node ID; the node ID is unique per instance of me, across OS environments where the image might run; the node ID is the MD5 hash of a string that is the concatenation of several elements (see #computeNodeIdentifier)
 
Some bits are set to some predefined value, to indicate the variant and version (see #setVariantAndVersion:)

Usage:

  UUIDGenerator next.
  UUIDGenerator current next.
  UUIDGenerator new next.

Sharing an instance is more efficient and correct.
Instances should be reset whenever the image comes up.

See also:

  http://en.wikipedia.org/wiki/UUID
  https://tools.ietf.org/html/rfc4122
!
!UUIDGenerator methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	random := Random new.
	"This prior usage of a Semaphore has been exchanged because there are reports that
	the Semaphore did not work in concurrent situations. So the Mutex adds some extra 
	bits here for usage in multi threaded environments"
	lock := Mutex new.
	node := self computeNodeIdentifier.
	counter := self nextRandom16! !

!UUIDGenerator methodsFor: 'private' stamp: ''!
placeFields: uuid
	"Fill the fields of uuid, effectively generating a new UUID in place, see my class comment"
	
	| byteStream |
	lock critical: [ 
		byteStream := uuid writeStream.
		self clockOn: byteStream.
		byteStream
			uint16: self nextCounter16;
			uint16: self nextRandom16;
			nextPutAll: node.
		self setVariantAndVersion: uuid ]! !

!UUIDGenerator methodsFor: 'accessing' stamp: ''!
next
	"Return the next UUID, see my class comment"
	
	| uuid |
	uuid := UUID nilUUID.
	self placeFields: uuid.
	^ uuid! !

!UUIDGenerator methodsFor: 'private' stamp: ''!
computeNodeIdentifier
	"Compute and return a 'node identifier', a 16 element byte array that should be unique to this image, vm, invocation, network, machine combination"
	
	| nodeData |
	nodeData := String streamContents: [ :out |
		Smalltalk at: #NetNameResolver ifPresent: [ :netNameResolver |
			out print: netNameResolver localHostAddress.
			out print: netNameResolver localHostName].
		out print: SystemVersion current.
		out print: Smalltalk vm imagePath.
		out print: Smalltalk commandLine options.
		out print: SessionManager default currentSession hash.
		out print: self hash ].
	^ (MD5 hashMessage: nodeData) hash asByteArrayOfSize: 4! !

!UUIDGenerator methodsFor: 'private' stamp: ''!
setVariantAndVersion: uuid
	"Set the version (top four most significant bits) to 0, an undefined version in RFC 4122"
	
	uuid at: 7 put: ((uuid at: 7) bitAnd: 2r1111).
	"Set the variant (top two most significant bits) to '10', the RFC 4122 variant"
	uuid at: 9 put: (((uuid at: 9) bitAnd: 2r111111) bitOr: 2r10000000)! !

!UUIDGenerator methodsFor: 'private' stamp: ''!
clockOn: stream
	"Write 8 bytes from the microsecond clock to stream"
	
	| microseconds |
	microseconds := Time microsecondClockValue.
	1 to: 8 do: [ :each |
		stream nextPut: (microseconds byteAt: each) ]! !

!UUIDGenerator methodsFor: 'private' stamp: ''!
nextRandom16
	"Return the next 16-bit random value from my random generator"

	^ (random nextInteger: 16r10000) - 1! !

!UUIDGenerator methodsFor: 'accessing' stamp: ''!
randomGenerator
	"Return the random generator that I use"
	
	^ random! !

!UUIDGenerator methodsFor: 'private' stamp: ''!
nextCounter16
	"Return the next 16-bit counter value with safe overflow"
	
	counter := (counter + 1) \\ 16r10000.
	^ counter! !

!UUIDGenerator class methodsFor: 'system startup' stamp: ''!
startUp
	"Whenever the image comes up, reset so that a new node ID is computed."
	
	Default := nil! !

!UUIDGenerator class methodsFor: 'class initialization' stamp: ''!
initialize
	SessionManager default
		registerNetworkClassNamed: self name! !

!UUIDGenerator class methodsFor: 'accessing' stamp: ''!
next
	"Return a UUID using the shared generator"
	
	"self next"
	
	"[ UUIDGenerator next ] bench"
	
	^ self default next! !

!UUIDGenerator class methodsFor: 'accessing' stamp: ''!
default
	"Return the default UUID generator.
	Sharing an instance is more efficient and correct."
	
	^ Default ifNil: [ Default := self new ]! !

!UUIDGeneratorTest commentStamp: ''!
I test the UUID Generator!
!UUIDGeneratorTest methodsFor: 'testing' stamp: ''!
testOne
	| uuid |
	uuid := generator next.
	self assert: (uuid isKindOf: UUID).
	self deny: uuid isNilUUID! !

!UUIDGeneratorTest methodsFor: 'testing' stamp: ''!
testDefault
	self assert: UUIDGenerator default equals: UUIDGenerator default.
	self deny: UUIDGenerator next isNilUUID! !

!UUIDGeneratorTest methodsFor: 'testing' stamp: ''!
testSpeed
	self 
		should: [ 100000 timesRepeat: [ generator next ] ] 
		notTakeMoreThan: 1 second! !

!UUIDGeneratorTest methodsFor: 'testing' stamp: ''!
testTwoDifferentGenerator
	| generator1 generator2 uuid1 uuid2 time1 time2 |
	generator1 := UUIDGenerator new.
	generator2 := UUIDGenerator new.
	uuid1 := generator1 next.
	uuid2 := generator2 next.
	"different UUIDs"
	self deny: uuid1 equals: uuid2.
	"different generators, different node id"
	self deny: uuid1 reverse readStream uint32 equals: uuid2 reverse readStream uint32.
	"same generators, similar clock, within 100 milliseconds (stored time is in microseconds)"
	time1 := self timeFromUUID: uuid1.
	time2 := self timeFromUUID: uuid2.
	self assert: (time2 - time1) abs < (100 * 1000)! !

!UUIDGeneratorTest methodsFor: 'testing' stamp: ''!
testTwoSameGenerator
	| uuid1 uuid2 time1 time2 |
	uuid1 := generator next.
	uuid2 := generator next.
	"different UUIDs"
	self deny: uuid1 equals: uuid2.
	"same generator, same node id"
	self assert: uuid1 reverse readStream uint32 equals: uuid2 reverse readStream uint32.
	"same generator, consecutive counters (take roll-over into account)"
	self assert: ((uuid1 at: 10) + 1) \\ 256 equals: (uuid2 at: 10).
	"same generators, similar clock, within 100 milliseconds (stored time is in microseconds)"
	time1 := self timeFromUUID: uuid1.
	time2 := self timeFromUUID: uuid2.
	self assert: (time2 - time1) abs < (100 * 1000)! !

!UUIDGeneratorTest methodsFor: 'testing' stamp: ''!
testCounterRollover
	| previousUuid uuid |
	previousUuid := generator next.
	"the internal counter inside generator will rollover at 16r10000,
	the least significant 10th byte rolls over every 16r100,
	the internal counter starts at a random value"
	2 * 16r10000 timesRepeat: [ 
		uuid := generator next.
		"same generator, consequetive counters (take roll-over into account)"
		self assert: ((previousUuid at: 10) + 1) \\ 256 equals: (uuid at: 10).
		previousUuid := uuid ]! !

!UUIDGeneratorTest methodsFor: 'testing' stamp: ''!
testUniqueness
	| uuids count |
	count := 100000.
	uuids := Set new: count.
	count timesRepeat: [ uuids add: generator next ].
	self assert: uuids size equals: count! !

!UUIDGeneratorTest methodsFor: 'private' stamp: ''!
timeFromUUID: uuid
	| bytes in |
	in := uuid readStream.
	bytes := ByteArray streamContents: [ :out |
		8 timesRepeat: [ out nextPut: in next ] ].
	^ bytes reverse asInteger! !

!UUIDGeneratorTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	generator := UUIDGenerator new! !

!UUIDPrimitivesTest commentStamp: ''!
SUnit tests for UUIDPrimitives !
!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testCreation
	| uuid |
	uuid := UUID new.
	self assert: uuid size equals: 16.
	self deny: uuid isNilUUID.
	self assert: uuid asString size equals: 36! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testComparison
	
	|a b|
	a := UUID fromString: '0608b9dc-02e4-4dd0-9f8a-ea45160df641'.
	b := UUID fromString: 'e85ae7ba-3ca3-4bae-9f62-cc2ce51c525e'.
	self assert: a < b.
	self deny: a> b.
	
	a := UUID fromString: '0608b9dc-02e4-4dd0-9f8a-ea45160df641'.
	b := UUID fromString: '0608b9dc-02e4-4dd0-9f8a-ea45160df642'.
	self assert: a < b.
	
	a := UUID fromString: '0608b9dc-02e4-4dd0-9f8a-ea45160df641'.
	b := UUID fromString: '0608b9dc-02e4-4dd0-9f8a-ea45160df640'.
	self assert: a > b! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testOrder
	100
		timesRepeat: [ | uuid1 uuid2 |
			uuid1 := UUID new.
			uuid2 := UUID new.
			(uuid1 asString last: 12) = (uuid2 asString last: 12)
				ifTrue: [ self assert: uuid1 < uuid2.
					self assert: uuid2 > uuid1.
					self deny: uuid1 equals: uuid2 ] ]! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testCreationNil
	| uuid |
	uuid := UUID nilUUID.
	self assert: uuid size equals: 16.
	self assert: uuid isNilUUID.
	self assert: uuid asString size equals: 36.
	self assert: uuid asArray asSet size equals: 1.
	self assert: (uuid asArray asSet asArray at: 1) equals: 0! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testCreationNodeBased
	

	(UUID new asString last: 12) = (UUID new asString last: 12) ifFalse: [^self].
	1000 timesRepeat:
		[ | uuid |uuid := UUID new.
		self assert: ((uuid at: 7) bitAnd: 16rF0) equals: 16r10.
		self assert: ((uuid at: 9) bitAnd: 16rC0) equals: 16r80 ]! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testCreationFromString36With0
	| uuid |
	uuid := UUID fromString36: '0'.
	self assert: uuid isNilUUID! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testDuplicationsKinda
	| check size |

	size := 5000.
	check := Set new: size.
	size timesRepeat: 
		[ | uuid |uuid := UUID new.
		self deny: (check includes: uuid).
		check add: uuid].! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testCreationFromString36NotNil
	| uuid uuid36 |
	uuid := UUID fromString: 'fedcba98-7654-3210-0123-456789abcdef'.
	uuid36 := UUID fromString36: 'e738i8a5the1f87mrh14o6vi6'.
	self assert: uuid equals: uuid36! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testCreationFromStringNotNil
	| uuid string |
	string := UUID new asString.
	uuid := UUID fromString: string.
	self assert: uuid size equals: 16.
	self assert: uuid asString size equals: 36! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testCreationFromString36WithNillUUID
	
	UUID fromString36: UUID nilUUID asString36! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testUniqueness 
	"Test uniqueness for a given number of generated values"
	
	|maxTestValue|
	maxTestValue := 1000.
	self assert: ((1 to: maxTestValue) collect: [ :i | UUID new asString ]) asSet size equals: maxTestValue! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testCreationEquality
	| uuid1 uuid2 |
	uuid1 := UUID new.
	uuid2 := UUID new.
	self assert: uuid1 equals: uuid1.
	self assert: uuid2 equals: uuid2.
	self deny: uuid1 equals: uuid2.
	self deny: uuid1 hash equals: uuid2 hash! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: ''!
testCreationFromString
	| uuid string |
	string := UUID nilUUID asString.
	uuid := UUID fromString: string.
	self assert: uuid size equals: 16.
	self assert: uuid equals: UUID nilUUID.
	self assert: uuid isNilUUID.
	self assert: uuid asString size equals: 36.
	self assert: uuid asArray asSet size equals: 1.
	self assert: (uuid asArray asSet asArray at: 1) equals: 0! !

!UUIDTest commentStamp: ''!
SUnit tests for UUID!
!UUIDTest methodsFor: 'testing' stamp: ''!
testString36
	| uuid |
	uuid := UUID new.
	self assert: (uuid asString36 allSatisfy: [ :e | e isAlphaNumeric ]).
	self assert: (UUID fromString36: uuid asString36) equals: uuid.

	self assert: UUID nilUUID asString36 equals: 0 asString.
	self assert: (UUID fromString36: 0 asString) equals: UUID nilUUID! !

!UUIDTest methodsFor: 'testing' stamp: ''!
testComparison
	| a b |
	a := UUID fromString: '0608b9dc-02e4-4dd0-9f8a-ea45160df641'.
	b := UUID fromString: 'e85ae7ba-3ca3-4bae-9f62-cc2ce51c525e'.

	self assert: a equals: a copy.
	self assert: a <= a copy.
	self assert: a >= a copy.
	self assert: b equals: b copy.
	self assert: b <= b copy.
	self assert: b >= b copy.
	self assert: a < b.
	self assert: a <= b.
	self assert: b > a.
	self assert: b >= a.

	self deny: a > b equals: b > a.
	self deny: a >= b equals: b >= a! !

!UUIDTest methodsFor: 'testing' stamp: ''!
testBasic
	| uuid |
	uuid := UUID new.
	self assert: uuid size equals: 16.
	self deny: uuid isNilUUID.
	self deny: uuid equals: UUID new! !

!UUIDTest methodsFor: 'testing' stamp: ''!
testString

	| s1 s2 s3 |
	
	s1 := '0608b9dc-02e4-4dd0-9f8a-ea45160df641'.
	s2 := 'e85ae7ba-3ca3-4bae-9f62-cc2ce51c525e'.
	s3 := '00000000-0000-0000-0000-000000000000'.
	
	self assert: (UUID fromString: s1) printString equals: s1.
	self assert: (UUID fromString: s2) printString equals: s2.
	self assert: UUID nilUUID printString equals: s3.	

	self assert: (UUID fromString: s1) asString equals: s1.
	self assert: (UUID fromString: s2) asString equals: s2.
	self assert: UUID nilUUID asString equals: s3! !

!UUIDTest methodsFor: 'testing' stamp: ''!
testNilUUID
	| nilUUIDRepresentation |
	nilUUIDRepresentation := '00000000-0000-0000-0000-000000000000'.
	self assert: UUID nilUUID isNilUUID.
	self assert: UUID nilUUID asString equals: nilUUIDRepresentation.
	self assert: (UUID fromString: nilUUIDRepresentation) equals: UUID nilUUID.
	self deny: UUID new isNilUUID! !

!UndeclaredVariable commentStamp: ''!
I model undeclared variable bindings. I am stored as a literal inside methods which reference me.

The compiler forwards bytecode generation to me for accessing the variable. 

In future I can profice logging and user warning when evaluated code accesses undeclared variables!
!UndeclaredVariable methodsFor: 'registry' stamp: ''!
isRegistered 
	^Undeclared includesKey: name! !

!UndeclaredVariable methodsFor: 'queries' stamp: ''!
definingClass
	"Nobody defines undeclared variable"
	^nil! !

!UndeclaredVariable methodsFor: 'testing' stamp: ''!
isUndeclaredVariable

	^ true! !

!UndeclaredVariable methodsFor: 'registry' stamp: ''!
unregister 
	Undeclared removeKey: name ifAbsent: [ ]! !

!UndeclaredVariable methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder
	methodBuilder pushLiteralVariable: self! !

!UndeclaredVariable methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder

	methodBuilder storeIntoLiteralVariable: self! !

!UndeclaredVariable methodsFor: 'registry' stamp: ''!
register 
	Undeclared add: self! !

!UndeclaredVariable methodsFor: '*Calypso-SystemTools-Core' stamp: ''!
asCalypsoVariableOf: declarationClass
	
	"Undeclared variable behaves like a global. It is shared in all places in system"	
	^ClyGlobalVariable on: self! !

!UndeclaredVariable class methodsFor: 'instance creation' stamp: ''!
registeredWithName: aString
	| varName |
	varName := aString asSymbol.
	
	Undeclared associationAt: varName ifPresent: [ :found | 
		found class == Association ifTrue: [ 
			"Found undeclared var can be an association during current bootstrap process.
			So here we should convert it to real variable object otherwise the build will be broken"
			found becomeForward: (self named: varName)].
		^found	].
	
	^(self named: varName)
		register;
		yourself! !

!UndefinedClass commentStamp: ''!
I represent a class that does not exist. This can be the case when a class superclass is not available. Instead of breaking and having different behavior (putting Object, nil) now Pharo creates an UndefinedClass object. It is the pendant of Undeclared (for references to unknown classes).

 There is more details on the UndefineClass article written by S. Ducasse, G. Polito and L. Fabresse at IWST 2017 and available at https://hal.inria.fr/hal-01585305v1!
!UndefinedClass methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage
	
	UndefinedClassError signal! !

!UndefinedClass class methodsFor: 'instance creation' stamp: ''!
basicNew
	"Normally redefine basicNew is a bad idea. But here we must do it."
	UndefinedClassError signal: 'Cannot instantiate undefined class: ', self name! !

!UndefinedClass class methodsFor: 'building' stamp: ''!
createUndefinedClassNamed: aString package: aPackageName
	
	^ self
		subclass: aString
		instanceVariableNames: ''
		classVariableNames: ''
		package: aPackageName! !

!UndefinedClassClassResolver commentStamp: ''!
I am an extension to the shift class builder in charge of resolving names.
My strategy is to create an UndefinedClass in the case the resolved name doesn't exist.!
!UndefinedClassClassResolver methodsFor: 'resolving' stamp: ''!
resolve: aClassName
	"should build an undefined class instead of creating (build + install)"

	^ UndefinedClass
		createUndefinedClassNamed: aClassName
		package: RPackage defaultPackageName! !

!UndefinedClassError commentStamp: ''!
I'm an error signaled when an UndefinedClass received an unknown message or try to initialize instance.!
!UndefinedClassTest methodsFor: 'asserting' stamp: ''!
assertClassDoesNotExist: aSymbol

	self assert: (self class environment at: aSymbol ifAbsent: [ true ])! !

!UndefinedClassTest methodsFor: 'utilities' stamp: ''!
compile
	<script: 'self new compile'>
	
	self createClassFromDefinitionString: self undefinedDefinition

	! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testRemoveUndefinedClassShouldRemoveIt
	self assertClassDoesNotExist: #Foo.

	UndefinedClass createUndefinedClassNamed: #Foo package: #Foo.
	
	self assertClassExist: #Foo.
	self assert: [(ShSmalltalkGlobalsEnvironment new classNamed:#Foo) isUndefined].
	
	(ShSmalltalkGlobalsEnvironment new classNamed:#Foo) removeFromSystem.
	
	self assertClassDoesNotExist: #Foo! !

!UndefinedClassTest methodsFor: 'running' stamp: ''!
tearDown

	self class environment at: #Foo ifPresent: [ :c | c removeFromSystem ].
	self class environment at: #ColoredFoo ifPresent: [ :c | c removeFromSystem ].
	super tearDown! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testCreateUndefinedClassShouldCreateNewClassThatIsUndefined

	self assertClassDoesNotExist: #Foo.

	UndefinedClass createUndefinedClassNamed: #Foo package: #Foo.
	
	self assertClassExist: #Foo.
	self assert: [(ShSmalltalkGlobalsEnvironment new classNamed:#Foo) isUndefined]! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testUndefinedClassIsUndefined

	| undefinedClass |
	self assertClassDoesNotExist: #Foo.

	undefinedClass := UndefinedClass createUndefinedClassNamed: #Foo package: #Foo.
	self assert: undefinedClass isUndefined! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testUndefinedClassMetaclassIsDefined

	self assert: UndefinedClass class isDefined! !

!UndefinedClassTest methodsFor: 'tests - handler' stamp: ''!
testUnknowSuperclassShouldInheritFromUndefinedClass
	| newUndefinedClass |
	self assertClassDoesNotExist: #Foo.
	
	self createClassFromDefinitionString: self undefinedDefinition.
	self assertClassExist: #ColoredFoo.
	newUndefinedClass := (self class environment at: #ColoredFoo). 
	self assert: newUndefinedClass superclass equals: (self class environment at: #Foo).
	self assert: (self class environment at: #Foo) isUndefined! !

!UndefinedClassTest methodsFor: 'accessing' stamp: ''!
undefinedDefinition

	^ 'Foo subclass: #ColoredFoo
	instanceVariableNames: ''''
	classVariableNames: ''''
	package: ''UndefinedClasses'''! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testCreateTwoUndefinedClassesOfSameNameShouldBeSameClass

	| foo foo2 |
	self assertClassDoesNotExist: #Foo.

	foo := UndefinedClass createUndefinedClassNamed: #Foo package: #Foo.
	foo2 := UndefinedClass createUndefinedClassNamed: #Foo package: #Foo.

	self assert: foo identicalTo: foo2! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testUndefinedClassClassIsDefined

	self assert: UndefinedClass isDefined! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testCreateSubclassOfNilCreatesSubclassOfNil

	self assertClassDoesNotExist: #ColoredFoo.

	self createClassFromDefinitionString: 'nil subclass: #ColoredFoo
		instanceVariableNames: ''''
		classVariableNames:''''
		package: ''Box'''.
	
	self assertClassExist: #ColoredFoo.
	self assert: (self class environment at: #ColoredFoo) superclass equals: nil! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testDefinedClassIsUndefined

	self deny: Object isUndefined! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testUndefinedMetaclassIsUndefined

	| undefinedClass |
	self assertClassDoesNotExist: #Foo.

	undefinedClass := UndefinedClass createUndefinedClassNamed: #Foo package: #Foo.
	self assert: undefinedClass class isUndefined! !

!UndefinedClassTest methodsFor: 'accessing' stamp: ''!
tokens

	^ self undefinedDefinition splitOn: ' '! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testInstallClassNameWithUnknownSuperclassName

	self assertClassDoesNotExist: #Foo. 
	
	self createClassFromDefinitionString: self undefinedDefinition.
	
	self assertClassExist: #ColoredFoo.
	self assert: (self class environment at: #ColoredFoo) superclass equals: (self class environment at: #Foo).
	self assert: (self class environment at: #Foo) isUndefined
	! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testClassWithUndefinedSuperclassNameHasUndefinedSuperclass

	| class |
	self assertClassDoesNotExist: #Foo. 
	
	class := self createClassFromDefinitionString: self undefinedDefinition.
	
	self assert: class superclass isUndefined! !

!UndefinedClassTest methodsFor: 'tests' stamp: ''!
testCreateSubclassOfArbitraryExpressionReturningNilThrowsError

	self assertClassDoesNotExist: #ColoredFoo.

	self should: [
		self createClassFromDefinitionString: '(Array new: 1) first subclass: #Box2
			instanceVariableNames: ''''
			classVariableNames:''''
			package: ''Box'''. 
	] raise: Error.
	
	self assertClassDoesNotExist: #ColoredFoo! !

!UndefinedClassTest methodsFor: 'asserting' stamp: ''!
assertClassExist: aSymbol

	self assert: (self class environment includesKey: aSymbol)! !

!UndefinedClassTest methodsFor: 'utilities' stamp: ''!
createClassFromDefinitionString: aString
	<script: 'self new compile'>

	^ ShiftClassInstaller make: [ :builder | 
		builder
			useUndefinedClass;
			buildEnvironment: ShSmalltalkGlobalsEnvironment new;
			buildFromAST: (CDClassDefinitionParser parse: aString) ]! !

!UndefinedObject commentStamp: ''!
I describe the behavior of my sole instance, nil. nil represents a prior value for variables that have not been initialized, or for results which are meaningless.!
!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
addSubclass: aClass
	"Ignored -- necessary to support disjoint class hierarchies"! !

!UndefinedObject methodsFor: '*Monticello' stamp: 'nil'!
mcType
	"Answer the symbol that Monticello uses internally to encode layouts"
	"Implemented here  to support disjoint class hierarchies"
	^#normal! !

!UndefinedObject methodsFor: 'testing' stamp: ''!
notNil 
	"Refer to the comment in Object|notNil."

	^false! !

!UndefinedObject methodsFor: 'sets support' stamp: ''!
asCollectionElement
	"Since nil is a singleton, we need only a single wrapper instance to represent it in set,
	created in advance"
	^ CollectionElement withNil! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
environment
	"Necessary to support disjoint class hierarchies."

	^self class environment! !

!UndefinedObject methodsFor: '*Fuel-Core' stamp: ''!
fuelAccept: aGeneralMapper

	^aGeneralMapper visitHookPrimitive: self! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
setDescriptionInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setDescription: self! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
classBuilder
	"Answer the object responsible of creating subclasses of myself in the system."
	
		^ self classInstaller new builder! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
asMetacelloSemanticVersionNumber
    ^ MetacelloSemanticVersionNumber fromString: ''! !

!UndefinedObject methodsFor: 'testing' stamp: ''!
isNil 
	"Refer to the comment in Object|isNil."

	^true! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
asMetacelloVersionNumber

	^MetacelloVersionNumber fromString: ''! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
setProject: aString withInMetacelloConfig: aMetacelloConfig

	aMetacelloConfig setProject: aString withString: self! !

!UndefinedObject methodsFor: 'testing' stamp: ''!
ifNil: aBlock
	"A convenient test, in conjunction with Object ifNil:"
	"Might be compiled inline for speed, see RBMessageNode>>#isInlineIfNil"
	^ aBlock value! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
metacelloRegistrationHash
    ^ self hash! !

!UndefinedObject methodsFor: '*Fuel-Core' stamp: ''!
serializeOn: anEncoder
	"Do nothing"! !

!UndefinedObject methodsFor: 'testing' stamp: ''!
ifNotNil: ifNotNilBlock ifNil: nilBlock 
	"If the receiver is not nil, pass it as argument to the ifNotNilBlock block. else execute the nilBlock block"
	"Might be compiled inline for speed, see RBMessageNode>>#isInlineIfNil"

	"(nil ifNotNil: [:o | o +3 ] ifNil: [42]) >>> 42"
	"(3 ifNotNil: [:o | o +3 ] ifNil: [42]) >>> 6"
	
	^ nilBlock value! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
classInstaller
	"Answer the class responsible of creating classes in the system."
	
	^ Smalltalk classInstaller! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
setBlessingInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setBlessing: self! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
subclass: nameOfClass  
	instanceVariableNames: instVarNameList
	classVariableNames: classVarNames
	poolDictionaries: poolDictnames
	category: category
	"Calling this method is now considered an accident.  If you really want to create a class with a nil superclass, then create the class and then set the superclass using #superclass:"
	Warning signal: ('Attempt to create ', nameOfClass, ' as a subclass of nil.  Possibly a class is being loaded before its superclass.').
	^ Object
		subclass: nameOfClass
		instanceVariableNames: instVarNameList
		classVariableNames: classVarNames
		poolDictionaries: poolDictnames
		category: category! !

!UndefinedObject methodsFor: 'accessing' stamp: ''!
at: index put: anObject 
	self shouldNotImplement! !

!UndefinedObject methodsFor: 'copying' stamp: ''!
deepCopy
	"Only one instance of UndefinedObject should ever be made, so answer 
	with self."! !

!UndefinedObject methodsFor: '*OpalCompiler-Core' stamp: ''!
compiler
	"Expressions (for example DoIts) are compiled with nil as the class. If we have this method, we can easily use the compiler that the class defines for syntax highlighting and code completion (without needing to add a check for nil)"
	^self class compilerClass new class: self! !

!UndefinedObject methodsFor: '*Ring-Definitions-Core' stamp: 'nil'!
asRingDefinition
	
	^ self! !

!UndefinedObject methodsFor: 'dependents access' stamp: ''!
addDependent: ignored 
	"Refer to the comment in Object|dependents."

	self error: 'Nil should not have dependents'! !

!UndefinedObject methodsFor: '*UnifiedFFI' stamp: ''!
packToArity: aNumber
	"pointer to NULL is NULL too"
	^ self! !

!UndefinedObject methodsFor: 'dispatched' stamp: ''!
asLinkPrepend: anObject

	^ ValueLink value: anObject! !

!UndefinedObject methodsFor: 'reflective operations' stamp: ''!
findUndeclaredVariableIn: ast
	"Walk the ast of the current statment and find the undeclared variable node, or nil (if none).
	Assumes there is only one such variable in an executing statement"
	
	^ast variableNodes detect: [:node | node isUndeclaredVariable] ifNone: [ nil ]! !

!UndefinedObject methodsFor: 'testing' stamp: ''!
isNotNil 
	"Refer to the comment in Object|isNotNil."

	^false! !

!UndefinedObject methodsFor: 'testing' stamp: ''!
ifNotNil: aBlock
	"If the receiver is not nil, pass it as argument to the block."
	"Might be compiled inline for speed, see RBMessageNode>>#isInlineIfNil"

	"(2 ifNotNil: [ :o | o + 3]) >>> 5"
	"(nil ifNotNil: [:o | o +3 ]) >>> nil"

	^ self! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
setTimestampInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setTimestamp: self! !

!UndefinedObject methodsFor: 'bottom context' stamp: ''!
handleSignal: exception
	"When no more handler (on:do:) context left in sender chain this gets called.  Return from signal with default action."

	^ exception resumeUnchecked: exception defaultAction! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
registrationsCompareEqual: aMetacelloProjectSpec
    ^ self = aMetacelloProjectSpec! !

!UndefinedObject methodsFor: 'reflective operations' stamp: ''!
doesNotUnderstand: aMessage

	"Handle the fact that there was an attempt to send the given message to an Undeclared variable (nil), hence the receiver does not understand this message (typically #new)."

	"Testing: (nil activeProcess)"

	<debuggerCompleteToSender>
	| exception resumeValue node |
	[ 
	node := self findUndeclaredVariableIn:
		        thisContext outerContext sender sourceNodeExecuted ] onErrorDo: [ :ex | 
				"This is ugly, but we have a dependency with Opal compiler and 
				it should be extracted. If there is a failure during the bootstrap, this
				dependency produces an infinite loop"
		 ].
	node ifNil: [ ^ super doesNotUnderstand: aMessage ].

	(exception := VariableNotDeclared new)
		message: aMessage;
		variableNode: node;
		receiver: self.

	resumeValue := exception signal.
	^ exception reachedDefaultHandler
		  ifTrue: [ aMessage sentTo: self ]
		  ifFalse: [ resumeValue ]! !

!UndefinedObject methodsFor: 'testing' stamp: ''!
haltIfNil
	<debuggerCompleteToSender>
	Halt now! !

!UndefinedObject methodsFor: 'copying' stamp: ''!
shallowCopy
	"Only one instance of UndefinedObject should ever be made, so answer 
	with self."! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
subclasses
	"Return all the subclasses of nil"
	| classList |
	classList := Array new writeStream.
	self subclassesDo:[:class| classList nextPut: class].
	^classList contents! !

!UndefinedObject methodsFor: 'printing' stamp: ''!
printOn: aStream 
	"Refer to the comment in Object|printOn:." 

	aStream nextPutAll: 'nil'! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
subclassDefinerClass
	"For disjunct class hierarchies -- how should subclasses of nil be evaluated"
	^self class subclassDefinerClass! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
subclassesDo: aBlock
	"Evaluate aBlock with all subclasses of nil.  Others are not direct subclasses of Class."

	^ Class subclassesDo: [:cl | 
			cl isMeta ifTrue: [aBlock value: cl soleInstance]].! !

!UndefinedObject methodsFor: '*STON-Core' stamp: ''!
stonOn: stonWriter
	stonWriter writeNull! !

!UndefinedObject methodsFor: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	^ ExternalAddress null! !

!UndefinedObject methodsFor: '*STON-Core' stamp: ''!
stonContainSubObjects 
	^ false! !

!UndefinedObject methodsFor: 'testing' stamp: ''!
isLiteral
	^ true! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
setPostLoadDoItInMetacelloSpec: aMetacelloSpec

	aMetacelloSpec setPostLoadDoIt: 
		(aMetacelloSpec project valueHolderSpec
			value: self;
			yourself)! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
setAuthorInMetacelloVersion: aMetacelloVersionSpec

	aMetacelloVersionSpec setAuthor: self! !

!UndefinedObject methodsFor: '*Deprecated10' stamp: ''!
typeOfClass
	self
		deprecated: 'Should use mcType instead'
		on: '08 September 2021'
		in: #Pharo10
		transformWith: '`@rec typeOfClass' -> '`@rec mcType'.
	^ self mcType! !

!UndefinedObject methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !

!UndefinedObject methodsFor: '*Metacello-Core' stamp: ''!
setPreLoadDoItInMetacelloSpec: aMetacelloSpec

	aMetacelloSpec setPreLoadDoIt: 
		(aMetacelloSpec project valueHolderSpec
			value: self;
			yourself)! !

!UndefinedObject methodsFor: 'testing' stamp: ''!
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"
	^ true! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
commonSuperclassWith: aClass 
	^ self! !

!UndefinedObject methodsFor: '*FluidClassBuilder' stamp: ''!
<< aString

	^ FluidClassBuilder new
		  superclassToBuild: self;
		  nameToBuild: aString;
		  yourself! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
removeSubclass: aClass
	"Ignored -- necessary to support disjoint class hierarchies"! !

!UndefinedObject methodsFor: 'bottom context' stamp: ''!
canHandleSignal: exception
	"When no more handler (on:do:) context left in sender chain this gets called"

	^ false! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: ''!
allSuperclassesDo: aBlockContext 
	"Ignored -- necessary to support disjoint class hierarchies"! !

!UndefinedObject methodsFor: 'testing' stamp: ''!
ifNil: nilBlock ifNotNil: ifNotNilBlock
	"If the receiver is not nil, pass it as argument to the ifNotNilBlock block. else execute the nilBlock block"
	"Might be compiled inline for speed, see RBMessageNode>>#isInlineIfNil"

	"(nil ifNil: [42] ifNotNil: [:o | o +3 ] ) >>> 42"
	"(3  ifNil: [42] ifNotNil: [:o | o +3 ]) >>> 6"

	^ nilBlock value! !

!UndefinedObject methodsFor: 'printing' stamp: ''!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:." 

	aStream nextPutAll: 'nil'! !

!UndefinedObject class methodsFor: 'instance creation' stamp: ''!
new
	self error: 'You may not create any more undefined objects--use nil'! !

!UndefinedObject class methodsFor: '*Fuel-Core' stamp: ''!
materializeFrom: aDecoder
	"Answer my unique instance"

	^ nil! !

!UndefinedObject class methodsFor: 'accessing' stamp: ''!
allInstancesDo: aBlock
	"It is well known there is a single instance"
	
	aBlock value: nil! !

!UndefinedObject class methodsFor: 'accessing' stamp: ''!
allInstances
	"It is well known there is a single instance"
	
	^Array with: nil! !

!UndefinedObjectTest commentStamp: ''!
This is the unit test for the class UndefinedObject. 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!
!UndefinedObjectTest methodsFor: 'tests - testing' stamp: ''!
testIfNil
	<haltOrBreakpointForTesting>
	self should: [ nil ifNil: [ self error ] ] raise: Error! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: ''!
testIfNilIfNotNil
	<haltOrBreakpointForTesting>
	self should: [ nil ifNil: [ self error ] ifNotNil: [  ] ] raise: Error! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: ''!
testIfNotNil

	nil ifNotNil: [
		self fail: 'should not get here' ].! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: ''!
testIsNil

	self assert: (nil isNil).! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: ''!
testIsLiteral

	self assert: (nil isLiteral).! !

!UndefinedObjectTest methodsFor: '*Kernel-Tests-WithCompiler' stamp: ''!
testStoreOnRoundTrip
	| string |
	string := String streamContents: [ :stream | nil storeOn: stream ].
	self assert: (self class compiler evaluate: string) isNil! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: ''!
testNotNil

	self deny: (nil notNil).! !

!UndefinedObjectTest methodsFor: 'tests - copying' stamp: ''!
testDeepCopy
	self assert: nil deepCopy isNil! !

!UndefinedObjectTest methodsFor: 'tests - class methods' stamp: ''!
testAllInstances
	self assert: UndefinedObject allInstances size = 1 description: 'There should be a single instance of UndefinedObject'.
	self assert: (UndefinedObject allInstances includes: nil) description: 'nil should be an instance of UndefinedObject'.! !

!UndefinedObjectTest methodsFor: 'tests - copying' stamp: ''!
testVeryDeepCopyWith
	self assert: (nil veryDeepCopyWith: nil) isNil! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: ''!
testIfNotNilIfNil
	<haltOrBreakpointForTesting>
	self should: [ nil ifNotNil: [  ] ifNil: [ self error ] ] raise: Error! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: ''!
testIsEmptyOrNil

	self assert: (nil isEmptyOrNil).! !

!UndefinedObjectTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ UndefinedObject! !

!UndefinedObjectTest methodsFor: 'tests - copying' stamp: ''!
testShallowCopy
	self assert: nil shallowCopy isNil! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: ''!
testIfNotNilDo

	nil ifNotNil: [
		self fail: 'should not get here' ].! !

!UndefinedObjectTest methodsFor: 'tests - class methods' stamp: ''!
testNew

	self should: [ UndefinedObject new] raise: Error.! !

!UndefinedObjectTest methodsFor: 'tests - printing' stamp: ''!
testPrintOn
	| string |
	string := String streamContents: [ :stream | nil printOn: stream ].
	self assert: string equals: 'nil'! !

!UndefinedSlot commentStamp: ''!
When loading a class where a Slot is used that is not present in the System, we need to model
this slot somehow.

The UndefinedSlot ingores reads and write (it returns nil like undeclared variables). But on
access, it checks if the Slot has been loaded and if yes, it rebuilds the class definition.!
!UndefinedSlot methodsFor: 'accessing' stamp: ''!
slotClassName
	^ast arguments first variable name! !

!UndefinedSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
	"Undeclared slots ignore writes, but check if they can repair the class"
	 self checkClassRebuild.
	^ aValue! !

!UndefinedSlot methodsFor: 'private' stamp: ''!
checkClassRebuild
	"break the recursion while rebuilding"
	classIsRebuild ifTrue: [ ^ self].
	(self definingClass environment hasClassNamed: self slotClassName) ifFalse: [ ^ self ].
	classIsRebuild := true.
	"we rebuild the class, this triggers instance migration"
	(self definingClass compiler evaluate: self definingClass definitionString) install.
	"recompile all methods that access me to generat code for the loaded definition"
	self usingMethods do: [:each | each recompile].! !

!UndefinedSlot methodsFor: 'accessing' stamp: ''!
ast: aMessageNode
	classIsRebuild := false.
	ast := aMessageNode! !

!UndefinedSlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	"Undeclared slots read nil always, but check if they can repair the class"
	 self checkClassRebuild.
	^ nil! !

!UndefinedSlot methodsFor: 'printing' stamp: ''!
printOn: aStream
	"we print as the definition that could not be loaded"
	aStream nextPutAll: ast formattedCode! !

!UndefinedSlot class methodsFor: 'instance creation' stamp: ''!
named: aName ast: aSlotClassName
	^ (self named: aName) ast: aSlotClassName! !

!UndefinedSortFunction commentStamp: ''!
An  UndefinedSortFunction is a specialization useful for sorting undefined objects (nil), either first or last according to direction.
The non nil objects are sorted according to the baseSortFunction defined in superclass.

instance variables:
	direction	<Integer>	-1 for sorting nil first, 1 for sorting nil last!
!UndefinedSortFunction methodsFor: 'converting' stamp: ''!
undefinedFirst
	direction := -1! !

!UndefinedSortFunction methodsFor: 'comparing' stamp: ''!
= anObject
	"Answer whether the receiver and anObject represent the same object."

	self == anObject
		ifTrue: [ ^ true ].
	self class = anObject class
		ifFalse: [ ^ false ].
	^ baseSortFunction = anObject baseSortFunction
		and: [ direction = anObject direction ]! !

!UndefinedSortFunction methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	direction := -1! !

!UndefinedSortFunction methodsFor: 'comparing' stamp: ''!
hash
	"Answer an integer value that is related to the identity of the receiver."

	^ super hash bitXor: direction hash! !

!UndefinedSortFunction methodsFor: 'evaluating' stamp: ''!
collate: anObject with: another
	anObject ifNil: [^another ifNil: [0] ifNotNil: [direction]].
	another ifNil: [^direction negated].
	^baseSortFunction collate: anObject with: another! !

!UndefinedSortFunction methodsFor: 'converting' stamp: ''!
undefinedLast
	direction := 1! !

!UndefinedSortFunction methodsFor: 'accessing' stamp: ''!
direction
	^direction! !

!UndoRedoGroup commentStamp: ''!
An UndoRedoGroup is a composite node of an history tree. It is made to allow redoing or undoing of several commands in one shot. See for example its use to record all text replacement when a "replace all" is performed from a FindReplaceService (see TextEditor>>replaceAll: with: startingAt:)

Instance Variables
!
!UndoRedoGroup methodsFor: 'undo - undo' stamp: ''!
undo
	self history reverseDo: [:i | i undo]! !

!UndoRedoGroup methodsFor: 'undo - undo' stamp: ''!
do
	self redo! !

!UndoRedoGroup methodsFor: 'undo - undo' stamp: ''!
redo
	self history do: [:i | i redo]! !

!UndoRedoRecord commentStamp: ''!
An UndoRedoRecord is a leaf of an history tree. It  holds undo and redo commands. Such a command is represented by a MessageSend. 

Instance Variables
	redoMessage:		<MessageSend>
	undoMessage:		<MessageSend>

redoMessage
	- The command which is performed for redoing

undoMessage
	- The command which is performed for undoing
!
!UndoRedoRecord methodsFor: 'accessing' stamp: ''!
redoMessage: aMessageSend

	redoMessage := aMessageSend! !

!UndoRedoRecord methodsFor: 'redo-undo' stamp: ''!
undo
	^self undoMessage
		ifNotNil: [self undoMessage value].! !

!UndoRedoRecord methodsFor: 'compatibility' stamp: ''!
doMessage: aMessageSend
	^ self redoMessage: aMessageSend
! !

!UndoRedoRecord methodsFor: 'accessing' stamp: ''!
redoMessage

	^ redoMessage! !

!UndoRedoRecord methodsFor: 'compatibility' stamp: ''!
doMessage

	^ self redoMessage! !

!UndoRedoRecord methodsFor: 'compatibility' stamp: ''!
do
	^self redo! !

!UndoRedoRecord methodsFor: 'accessing' stamp: ''!
undoMessage

	^ undoMessage! !

!UndoRedoRecord methodsFor: 'accessing' stamp: ''!
undoMessage: aMessageSend

	undoMessage := aMessageSend! !

!UndoRedoRecord methodsFor: 'redo-undo' stamp: ''!
redo
	^self redoMessage value.! !

!UndoRedoRecord class methodsFor: 'instance creation' stamp: ''!
redoArray: doArray undoArray: undoArray
	" doArray and undoArray are constructed as follow: #(receiver selector arguments) "
	| anUndoRecord |
	anUndoRecord := self new.
	anUndoRecord redoMessage: (MessageSend 
		receiver: 	(doArray first) 
		selector: 	(doArray second) 
		arguments: 	(doArray third)).
	undoArray 
		ifNotNil: [ 
			anUndoRecord undoMessage: (MessageSend 
				receiver: 	(undoArray first) 
				selector: 	(undoArray second) 
				arguments: 	(undoArray third))].
	^anUndoRecord.! !

!UndoRedoRecord class methodsFor: 'compatibility' stamp: ''!
doArray: doArray undoArray: undoArray
	^ self redoArray: doArray undoArray: undoArray! !

!UndoRedoRecord class methodsFor: 'instance creation' stamp: ''!
redo: doMessageSend undo: undoMessageSend

	| anUndoRecord |
	anUndoRecord := self new.
	anUndoRecord redoMessage: doMessageSend.
	anUndoRecord undoMessage: undoMessageSend.
	^anUndoRecord.! !

!UndoRedoRecord class methodsFor: 'compatibility' stamp: ''!
do: doMessageSend undo: undoMessageSend
	^ self redo: doMessageSend undo: undoMessageSend! !

!UnhandledError commentStamp: ''!
I am the ultimate error. 
By default if an Exception is not handled by the code the default action is to raise an UnhandledError (#raiseUnhandledError) which in interactive mode triggers the UIManager to open a debugger.

	Error signal
	...
	UnhandledError signalForException: error
	...
	UIManager opens a debugger
	
The UI action here can be specialied for different kind of exceptions. The actual logic is implemented by exceptions themselves as #unhandledErrorAction:

	UnhandledError>>defaultAction 
		^ exception unhandledErrorAction

For example It allows to have specific debugger for Warning while it still processed through same UnhandledError machinery.

The logic behind my class name and methods: 
Not all exceptions are errors. But by default the absence of any handler for signaled exception is considered as an error. Therefore #defaultAction for Exception raises an error, an UnhandledError. And because exception should be able to specify default action for UnhandledError it implements #unhandledErrorAction!
!UnhandledError methodsFor: 'accessing' stamp: ''!
exception

	^ exception! !

!UnhandledError methodsFor: 'accessing' stamp: ''!
exception: anError

	exception := anError! !

!UnhandledError methodsFor: 'testing' stamp: ''!
isResumable

	"UnhandledError can be signaled for more than non-resumable Errors.
	If UnhandledError reflects the underlying Exception, we are able to
	resume the underlying Exception."

	^ self exception isResumable! !

!UnhandledError methodsFor: '*JenkinsTools-Core' stamp: ''!
recordBackgroundFailureOf: aTestCase inHDTestReport: aHDTestReport
	
	exception recordBackgroundFailureOf: aTestCase inHDTestReport: aHDTestReport! !

!UnhandledError methodsFor: 'handling' stamp: ''!
defaultAction
	^ exception unhandledErrorAction! !

!UnhandledError class methodsFor: 'signalling' stamp: ''!
signalForException: anError

	^ self new
		exception: anError;
		signal! !

!UnhandledException commentStamp: ''!
I am a root of hierarchy of various kinds of ultimate exceptions. 
The ultimate meaning here is that such exceptions execute the UI action to interrupt the process execution as the result of not being handled. So no other exceptions are be raisen there. 

In interactive mode whey will trigger the UIManager to open a debugger.

There are two main subclasses:
- Halt to break and debug execution.
- UnhandledError to give a last chance to handle given exception 
See comments for details!
!UnhandledException methodsFor: '*SUnit-Core' stamp: ''!
manageTestProcessBy: aProcessMonitorTestService

	aProcessMonitorTestService handleUnhandledException: self ! !

!UnhandledException methodsFor: 'handling' stamp: ''!
defaultAction
	"If none handles this either then open debugger.
	
	Note about naming here: 
	Even if not all exceptions are errors the absence of a handler for signaled exception is considered as an error by default. Therefore #defaultAction for UnhandledException performs the #unhandledErrorAction"
 	^ self unhandledErrorAction! !

!UnhandledExceptionSignalledByADebuggedExecution methodsFor: 'accessing' stamp: ''!
unhandledException

	^ unhandledException! !

!UnhandledExceptionSignalledByADebuggedExecution methodsFor: 'accessing' stamp: ''!
unhandledException: anException

	unhandledException := anException! !

!UnhandledExceptionSignalledByADebuggedExecution class methodsFor: 'signalling' stamp: ''!
signalWithException: anException

	self new
		unhandledException: anException;
		signal:
			'An execution debugged by a scriptable debugger signalled an exception that it did not handle itself. You can find this exception is in the #unhandledException instance variable of this object.'! !

!Unicode commentStamp: ''!
This class holds the entry points for the utility functions around characters.
!
!Unicode class methodsFor: 'instance creation' stamp: ''!
value: code

	^ Character value: code! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isPrivateOther: char
	^ self is: char inCategory: Co! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isEnclosingMark: char
	
	^ self is: char inCategory: Me! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isClosePunctuation: char
	^ self is: char inCategory: Pe! !

!Unicode class methodsFor: 'class methods' stamp: ''!
generalCategory

	^ GeneralCategory.! !

!Unicode class methodsFor: 'class methods' stamp: ''!
generalCategoryComment
"
Lu Letter, Uppercase 
Ll Letter, Lowercase 
Lt Letter, Titlecase 
Lm Letter, Modifier 
Lo Letter, Other 
Mn Mark, Non-Spacing 
Mc Mark, Spacing Combining 
Me Mark, Enclosing 
Nd Number, Decimal 
Nl Number, Letter 
No Number, Other 
Pc Punctuation, Connector 
Pd Punctuation, Dash 
Ps Punctuation, Open 
Pe Punctuation, Close 
Pi Punctuation, Initial quote (may behave like Ps or Pe depending on usage) 
Pf Punctuation, Final quote (may behave like Ps or Pe depending on usage) 
Po Punctuation, Other 
Sm Symbol, Math 
Sc Symbol, Currency 
Sk Symbol, Modifier 
So Symbol, Other 
Zs Separator, Space 
Zl Separator, Line 
Zp Separator, Paragraph 
Cc Other, Control 
Cf Other, Format 
Cs Other, Surrogate 
Co Other, Private Use 
Cn Other, Not Assigned (no characters in the file have this property) 
"! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isOtherNumber: char
	^ self is: char inCategory: No! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isParagraphSeparator: char
	^ self is: char inCategory: Zp! !

!Unicode class methodsFor: 'class methods' stamp: ''!
isCharset

	^ false.! !

!Unicode class methodsFor: 'testing' stamp: ''!
isUnifiedKanji: code
	^ ((((code between: 16r2E80 and: 16rA4CF)
		or: [ code between: 16rF900 and: 16rFAFF ])
			or: [ code between: 16rFE30 and: 16rFE4F ]) 
				or: [ code between: 16rFF00 and: 16rFFEF ])
					or: [ code between: 16r20000 and: 16r2FA1F ]! !

!Unicode class methodsFor: 'casing' stamp: ''!
toUppercaseString: aWideString
	"Transform a Wide String into uppercase.
	This does not handle special cases where number of characters could change.
	The algorithm would work for ByteString, however it's far from the most efficient."
	
	^aWideString collect: [:e |
		(ToUpper at: e charCode ifAbsent: [nil])
			ifNil: [e]
			ifNotNil: [:up | self value: up]]! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isUppercase: char 
	| index |
	index := char charCode + 1.
	index > GeneralCategory size
		ifTrue: [^ false].
	^ (GeneralCategory at: index) = Lu! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isOtherLetter: char 
	| index |
	index := char charCode + 1.
	index > GeneralCategory size
		ifTrue: [^ false].
	^ (GeneralCategory at: index) = Lo! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isCasedLetter: char
	"There are no Unicode Characters in this Category"
	^ false! !

!Unicode class methodsFor: 'instance creation' stamp: ''!
charFromUnicode: uniCode

	^ Character value: uniCode! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isFormatOther: char 
	^ self is: char inCategory: Cf! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isDecimalDigit: char
	^ self is: char inCategory: Nd! !

!Unicode class methodsFor: 'class initialization' stamp: ''!
initialize
	"This class should be initialized using the textual unicode definitions that can be found in
	http://www.unicode.org/Public/UNIDATA/UnicodeData.txt
	http://www.unicode.org/Public/UNIDATA/CaseFolding.txt
	
	To do that, this class posesses the class side methods:
	#parseCaseMappingFrom:
	#parseUnicodeDataFrom:
	
	The initialization order is:
	1) tag constants
	2) unicode data
	3) case mappings
	"
	"If you are in a full image, you can try the following Zinc scripts to download the file automatically:
	
	UIManager default informUserDuring: [ :bar| | result |
            bar label: 'Downloading Unicode data'.
            (result := ZnEasy get: 'http://www.unicode.org/Public/UNIDATA/UnicodeData.txt') isSuccess
                ifFalse: [ ^ self error: 'Download failed' ].
            bar label: 'Updating Case Mappings'.
            self parseUnicodeDataFrom: result contents readStream ].

	UIManager default informUserDuring: [ :bar| | result |
		bar label: 'Downloading Unicode case mappings data'.
		(result := ZnEasy get: 'http://www.unicode.org/Public/UNIDATA/CaseFolding.txt') isSuccess
			ifFalse: [ ^ self error: 'Download failed' ].
		bar label: 'Updating Case Mappings'.
		self parseCaseMappingFrom: result contents readStream ].
	"
	
	EncodedCharSet declareEncodedCharSet: self atIndex: 0+1.
	EncodedCharSet declareEncodedCharSet: self atIndex: 256.! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isOtherPunctuation: char
	^ self is: char inCategory: Po! !

!Unicode class methodsFor: 'class initialization' stamp: ''!
parseCaseMappingFrom: stream
	"Parse the Unicode casing mappings from the given stream.
	Handle only the simple mappings"

	ToCasefold := IdentityDictionary new: 2048.
	ToUpper := IdentityDictionary new: 2048.
	ToLower := IdentityDictionary new: 2048.
	[ stream atEnd ]
		whileFalse: [ 
			| fields line srcCode dstCode |
			line := stream nextLine copyUpTo: $#.
			fields := line trimBoth findTokens: $;.
			(fields size > 2 and: [ #('C' 'S') includes: (fields at: 2) trimBoth ])
				ifTrue: [ 
					srcCode := Integer readFrom: (fields at: 1) trimBoth base: 16.
					dstCode := Integer readFrom: (fields at: 3) trimBoth base: 16.
					ToCasefold at: srcCode put: dstCode ] ].
	ToCasefold
		keysAndValuesDo: [ :k :v | 
			(self isUppercase: (self value: k))
				ifTrue: [ 
					"In most cases, uppercase letter are folded to lower case"
					ToUpper at: v ifAbsentPut: k.
					ToLower at: k ifAbsentPut: v ].
			(self isLowercase: (self value: k))
				ifTrue: [ 
					"In a few cases, two lower case letters are folded to the same lower case.
				We must find an upper case letter folded to the same letter"
					ToCasefold keys
						detect: [ :e | (self isUppercase: (self value: e)) and: [ (ToCasefold at: e) = v ] ]
						ifFound: [ :up | ToUpper at: k ifAbsentPut: up ] ] ]! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isFinalQuote: char
	^ self is: char inCategory: Pf! !

!Unicode class methodsFor: 'casing' stamp: ''!
toLowercase: aCharacter
	"Transform a Wide String into lowercase.
	This does not handle special cases where number of characters could change.
	The algorithm would work for ByteString, however it's far from the most efficient."
	
	(ToLower at: aCharacter charCode ifAbsent: [ ^ aCharacter ])
			ifNotNil: [:low | ^ self value: low ]! !

!Unicode class methodsFor: 'casing' stamp: ''!
toUppercase: aCharacter
	"Transform a Wide String into uppercase.
	This does not handle special cases where number of characters could change.
	The algorithm would work for ByteString, however it's far from the most efficient."
	
	(ToUpper at: aCharacter charCode ifAbsent: [ ^ aCharacter ])
			ifNotNil: [:up | ^ self value: up]! !

!Unicode class methodsFor: 'private' stamp: ''!
is: char inCategory: cat
	| index |
	index := char charCode + 1.
	index > GeneralCategory size
		ifTrue: [ ^ false ].
	^ (GeneralCategory at: index) = cat! !

!Unicode class methodsFor: 'class initialization' stamp: ''!
parseUnicodeDataFrom: stream
	| line fieldEnd point fieldStart toNumber generalCategory decimalProperty loValue |

	toNumber := [:quad | ('16r', quad) asNumber].

	GeneralCategory := SparseLargeTable new: 16rE0080 chunkSize: 1024 arrayClass: Array base: 1 defaultValue:  (self classPool at: #Cn).
	DecimalProperty := SparseLargeTable new: 16rE0080 chunkSize: 32 arrayClass: Array base: 1 defaultValue: -1.

	loValue := (self classPool at: #Lo).
	16r3400 to: 16r4DB5 do: [:i | GeneralCategory at: i+1 put: loValue].
	16r4E00 to: 16r9FA5 do: [:i | GeneralCategory at: i+1 put: loValue].
	16rAC00 to: 16rD7FF do: [:i | GeneralCategory at: i+1 put: loValue].

	[(line := stream nextLine) notNil and: [line size > 0 ]] whileTrue: [
		fieldEnd := line indexOf: $; startingAt: 1.
		point := toNumber value: (line copyFrom: 1 to: fieldEnd - 1).
		point > 16rE007F ifTrue: [
			GeneralCategory zapDefaultOnlyEntries.
			DecimalProperty zapDefaultOnlyEntries.
			^ self].
		2 to: 3 do: [:i |
			fieldStart := fieldEnd + 1.
			fieldEnd := line indexOf: $; startingAt: fieldStart.
		].
		generalCategory := line copyFrom: fieldStart to: fieldEnd - 1.
		GeneralCategory at: point+1 put: (self classPool at: generalCategory asSymbol).
		generalCategory = 'Nd' ifTrue: [
			4 to: 7 do: [:i |
				fieldStart := fieldEnd + 1.
				fieldEnd := line indexOf: $; startingAt: fieldStart.
			].
			decimalProperty :=  line copyFrom: fieldStart to: fieldEnd - 1.
			DecimalProperty at: point+1 put: decimalProperty asNumber.
		].
	].
	GeneralCategory zapDefaultOnlyEntries.
	DecimalProperty zapDefaultOnlyEntries.! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isLineSeparator: char
	^ self is: char inCategory: Zl! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isDashPunctuation: char
	^ self is: char inCategory: Pd! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isSpaceSeparator: char
	^ self is: char inCategory: Zs! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isTitlecaseLetter: char 
	| index |
	index := char charCode + 1.
	index > GeneralCategory size
		ifTrue: [^ false].
	^ (GeneralCategory at: index) = Lt! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isSurrogateOther: char 
	| index |
	index := char charCode + 1.
	index > (GeneralCategory size)
		ifTrue: [ ^ false ].
	^ (GeneralCategory at: index) = Cs! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isSpacingCombiningMark: char
	^ self is: char inCategory: Mc! !

!Unicode class methodsFor: 'comments' stamp: ''!
blocks320Comment

"# Blocks-3.2.0.txt
# Correlated with Unicode 3.2
# Start Code..End Code; Block Name
0000..007F; Basic Latin
0080..00FF; Latin-1 Supplement
0100..017F; Latin Extended-A
0180..024F; Latin Extended-B
0250..02AF; IPA Extensions
02B0..02FF; Spacing Modifier Letters
0300..036F; Combining Diacritical Marks
0370..03FF; Greek and Coptic
0400..04FF; Cyrillic
0500..052F; Cyrillic Supplementary
0530..058F; Armenian
0590..05FF; Hebrew
0600..06FF; Arabic
0700..074F; Syriac
0780..07BF; Thaana
0900..097F; Devanagari
0980..09FF; Bengali
0A00..0A7F; Gurmukhi
0A80..0AFF; Gujarati
0B00..0B7F; Oriya
0B80..0BFF; Tamil
0C00..0C7F; Telugu
0C80..0CFF; Kannada
0D00..0D7F; Malayalam
0D80..0DFF; Sinhala
0E00..0E7F; Thai
0E80..0EFF; Lao
0F00..0FFF; Tibetan
1000..109F; Myanmar
10A0..10FF; Georgian
1100..11FF; Hangul Jamo
1200..137F; Ethiopic
13A0..13FF; Cherokee
1400..167F; Unified Canadian Aboriginal Syllabics
1680..169F; Ogham
16A0..16FF; Runic
1700..171F; Tagalog
1720..173F; Hanunoo
1740..175F; Buhid
1760..177F; Tagbanwa
1780..17FF; Khmer
1800..18AF; Mongolian
1E00..1EFF; Latin Extended Additional
1F00..1FFF; Greek Extended
2000..206F; General Punctuation
2070..209F; Superscripts and Subscripts
20A0..20CF; Currency Symbols
20D0..20FF; Combining Diacritical Marks for Symbols
2100..214F; Letterlike Symbols
2150..218F; Number Forms
2190..21FF; Arrows
2200..22FF; Mathematical Operators
2300..23FF; Miscellaneous Technical
2400..243F; Control Pictures
2440..245F; Optical Character Recognition
2460..24FF; Enclosed Alphanumerics
2500..257F; Box Drawing
2580..259F; Block Elements
25A0..25FF; Geometric Shapes
2600..26FF; Miscellaneous Symbols
2700..27BF; Dingbats
27C0..27EF; Miscellaneous Mathematical Symbols-A
27F0..27FF; Supplemental Arrows-A
2800..28FF; Braille Patterns
2900..297F; Supplemental Arrows-B
2980..29FF; Miscellaneous Mathematical Symbols-B
2A00..2AFF; Supplemental Mathematical Operators
2E80..2EFF; CJK Radicals Supplement
2F00..2FDF; Kangxi Radicals
2FF0..2FFF; Ideographic Description Characters
3000..303F; CJK Symbols and Punctuation
3040..309F; Hiragana
30A0..30FF; Katakana
3100..312F; Bopomofo
3130..318F; Hangul Compatibility Jamo
3190..319F; Kanbun
31A0..31BF; Bopomofo Extended
31F0..31FF; Katakana Phonetic Extensions
3200..32FF; Enclosed CJK Letters and Months
3300..33FF; CJK Compatibility
3400..4DBF; CJK Unified Ideographs Extension A
4E00..9FFF; CJK Unified Ideographs
A000..A48F; Yi Syllables
A490..A4CF; Yi Radicals
AC00..D7AF; Hangul Syllables
D800..DB7F; High Surrogates
DB80..DBFF; High Private Use Surrogates
DC00..DFFF; Low Surrogates
E000..F8FF; Private Use Area
F900..FAFF; CJK Compatibility Ideographs
FB00..FB4F; Alphabetic Presentation Forms
FB50..FDFF; Arabic Presentation Forms-A
FE00..FE0F; Variation Selectors
FE20..FE2F; Combining Half Marks
FE30..FE4F; CJK Compatibility Forms
FE50..FE6F; Small Form Variants
FE70..FEFF; Arabic Presentation Forms-B
FF00..FFEF; Halfwidth and Fullwidth Forms
FFF0..FFFF; Specials
10300..1032F; Old Italic
10330..1034F; Gothic
10400..1044F; Deseret
1D000..1D0FF; Byzantine Musical Symbols
1D100..1D1FF; Musical Symbols
1D400..1D7FF; Mathematical Alphanumeric Symbols
20000..2A6DF; CJK Unified Ideographs Extension B
2F800..2FA1F; CJK Compatibility Ideographs Supplement
E0000..E007F; Tags
F0000..FFFFF; Supplementary Private Use Area-A
100000..10FFFF; Supplementary Private Use Area-B


"! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isModifierSymbol: char
	^ self is: char inCategory: Sk! !

!Unicode class methodsFor: 'testing' stamp: ''!
isTraditionalChinese: code

	^ false.! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isNonspacingMark: char
	^ self is: char inCategory: Mn! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isDigit: char
	^ self is: char inCategory: Nd! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isOpenPunctuation: char
	^ self is: char inCategory: Ps! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isLetterNumber: char
	^ self is: char inCategory: Nl! !

!Unicode class methodsFor: 'class methods' stamp: ''!
compoundTextSequence

	self subclassResponsibility.! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isNonCharacter: ch
	^ self nonCharacters includes: ch codePoint! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isMathSymbol: char
	^ self is: char inCategory: Sm! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isLetter: char
	| index |
	index := char charCode + 1.
	index > GeneralCategory size
		ifTrue: [ ^ false ].
	^ (GeneralCategory at: index) between: Ll and: Lu! !

!Unicode class methodsFor: 'class methods' stamp: ''!
leadingChar
	^ 0! !

!Unicode class methodsFor: 'sizing' stamp: ''!
maxValue
	"The maximum value of a character in this character set"

	^ 16r10FFFF! !

!Unicode class methodsFor: 'casing' stamp: ''!
toCasefold: aWideString
	"Transform a Wide String into fold case.
	This is to enable case insensitive conversion."
	
	^aWideString collect: [:e |
		(ToCasefold at: e charCode ifAbsent: [nil])
			ifNil: [e]
			ifNotNil: [:low | self value: low]]! !

!Unicode class methodsFor: 'casing' stamp: ''!
toLowercaseString: aWideString
	"Transform a Wide String into lowercase.
	This does not handle special cases where number of characters could change.
	The algorithm would work for ByteString, however it's far from the most efficient."
	
	^aWideString collect: [:e |
		(ToLower at: e charCode ifAbsent: [nil])
			ifNil: [e]
			ifNotNil: [:low | self value: low]]! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isInitialQuote: char
	^ self is: char inCategory: Pi! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isConnectorPunctuation: char
	^ self is: char inCategory: Pc! !

!Unicode class methodsFor: 'class initialization' stamp: ''!
initializeTagConstants
	" Unicode initializeTagConstants "
	(self classPool keys
		select: [:sym | sym size = 2 
						and: [sym first isUppercase and: [sym last isLowercase]]]) asSortedCollection
		inject: 1
		into: [:index :sym | sym = #Cn
				ifTrue: [self classPool at: sym put: 0. index]
				ifFalse: [self classPool at: sym put: index. index + 1]]! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isLetterModifier: char 
	| index |
	index := char charCode + 1.
	index > GeneralCategory size
		ifTrue: [^ false].
	^ (GeneralCategory at: index) = Lm! !

!Unicode class methodsFor: 'class initialization' stamp: ''!
nonCharacters
	nonCharacters
		ifNil: [ nonCharacters := (16rFDD0 to: 16rFDEF) asOrderedCollection
				, #(16rFFFE 16rFFFF 16r1FFFE 16r1FFFF 16r0002FFFE 16r0002FFFF 16r0003FFFE 16r0003FFFF)
				, (16r4FFFE to: 16rFFFFE by: 16r10000) , (16r4FFFF to: 16rFFFFF by: 16r10000)
				, #(16r0010FFFE 16r0010FFFF) ].
	^ nonCharacters! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isCurrencySymbol: char
	^ self is: char inCategory: Sc! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isOtherSymbol: char
	^ self is: char inCategory: So! !

!Unicode class methodsFor: 'class methods' stamp: ''!
compoundTextFinalChar

	self shouldNotImplement.! !

!Unicode class methodsFor: 'class methods' stamp: ''!
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]].

	value > (DecimalProperty size - 1) ifTrue: [^ -1].
	^ (DecimalProperty at: value+1)! !

!Unicode class methodsFor: 'comments' stamp: ''!
blocks320Comment2

"# Blocks-3.2.0.txt
# Correlated with Unicode 3.2
# Start Code..End Code; Block Name
0000..007F; Basic Latin
0080..00FF; Latin-1 Supplement

 => Latin 1

0100..017F; Latin Extended-A
0180..024F; Latin Extended-B
0250..02AF; IPA Extensions

  => LatinExtended1

02B0..02FF; Spacing Modifier Letters
0300..036F; Combining Diacritical Marks

  => Modifiers

0370..03FF; Greek and Coptic
0400..04FF; Cyrillic
0500..052F; Cyrillic Supplementary
0530..058F; Armenian

   => EuropeanAlphabetic1

0590..05FF; Hebrew
0600..06FF; Arabic
0700..074F; Syriac
0780..07BF; Thaana

   => MiddleEastern

0900..097F; Devanagari
0980..09FF; Bengali
0A00..0A7F; Gurmukhi
0A80..0AFF; Gujarati
0B00..0B7F; Oriya
0B80..0BFF; Tamil
0C00..0C7F; Telugu
0C80..0CFF; Kannada
0D00..0D7F; Malayalam
0D80..0DFF; Sinhala

  => South Asian1


0E00..0E7F; Thai
0E80..0EFF; Lao

 => Southeastern 1

0F00..0FFF; Tibetan

  => South Asian1

1000..109F; Myanmar

 => Southeastern 1


10A0..10FF; Georgian

   => European Alphabetic 2

1100..11FF; Hangul Jamo

   => Korean

1200..137F; Ethiopic
13A0..13FF; Cherokee
1400..167F; Unified Canadian Aboriginal Syllabics

  => Additional1

1680..169F; Ogham
16A0..16FF; Runic

  => European Alphabetic 3

1700..171F; Tagalog
1720..173F; Hanunoo
1740..175F; Buhid
1760..177F; Tagbanwa
1780..17FF; Khmer

  => Southeastern2

1800..18AF; Mongolian

  => Additional2

1E00..1EFF; Latin Extended Additional
1F00..1FFF; Greek Extended

  => EuropeanAlphabetic4

2000..206F; General Punctuation
2070..209F; Superscripts and Subscripts
20A0..20CF; Currency Symbols
20D0..20FF; Combining Diacritical Marks for Symbols
2100..214F; Letterlike Symbols
2150..218F; Number Forms
2190..21FF; Arrows
2200..22FF; Mathematical Operators
2300..23FF; Miscellaneous Technical
2400..243F; Control Pictures
2440..245F; Optical Character Recognition
2460..24FF; Enclosed Alphanumerics
2500..257F; Box Drawing
2580..259F; Block Elements
25A0..25FF; Geometric Shapes
2600..26FF; Miscellaneous Symbols
2700..27BF; Dingbats
27C0..27EF; Miscellaneous Mathematical Symbols-A
27F0..27FF; Supplemental Arrows-A
2800..28FF; Braille Patterns
2900..297F; Supplemental Arrows-B
2980..29FF; Miscellaneous Mathematical Symbols-B
2A00..2AFF; Supplemental Mathematical Operators

  => Symbols2

2E80..2EFF; CJK Radicals Supplement
2F00..2FDF; Kangxi Radicals
2FF0..2FFF; Ideographic Description Characters
3000..303F; CJK Symbols and Punctuation
3040..309F; Hiragana
30A0..30FF; Katakana
3100..312F; Bopomofo
3130..318F; Hangul Compatibility Jamo
3190..319F; Kanbun
31A0..31BF; Bopomofo Extended
31F0..31FF; Katakana Phonetic Extensions
3200..32FF; Enclosed CJK Letters and Months
3300..33FF; CJK Compatibility
3400..4DBF; CJK Unified Ideographs Extension A
4E00..9FFF; CJK Unified Ideographs
A000..A48F; Yi Syllables
A490..A4CF; Yi Radicals

  => CJK

AC00..D7AF; Hangul Syllables

  => Korean

D800..DB7F; High Surrogates
DB80..DBFF; High Private Use Surrogates
DC00..DFFF; Low Surrogates
E000..F8FF; Private Use Area

F900..FAFF; CJK Compatibility Ideographs

  => CJK

FB00..FB4F; Alphabetic Presentation Forms
FB50..FDFF; Arabic Presentation Forms-A

  => Middle Eastern 2

FE00..FE0F; Variation Selectors
FE20..FE2F; Combining Half Marks

FE30..FE4F; CJK Compatibility Forms

  => CJK

FE50..FE6F; Small Form Variants

 => Symbol3

FE70..FEFF; Arabic Presentation Forms-B

  => Middle Eastern 3

FF00..FFEF; Halfwidth and Fullwidth Forms
FFF0..FFFF; Specials

  => Specials

10300..1032F; Old Italic
10330..1034F; Gothic
10400..1044F; Deseret

   => European

1D000..1D0FF; Byzantine Musical Symbols
1D100..1D1FF; Musical Symbols
1D400..1D7FF; Mathematical Alphanumeric Symbols

  => Symbols

20000..2A6DF; CJK Unified Ideographs Extension B
2F800..2FA1F; CJK Compatibility Ideographs Supplement

  => CJK

E0000..E007F; Tags
F0000..FFFFF; Supplementary Private Use Area-A
100000..10FFFF; Supplementary Private Use Area-B

  => Special

"! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isControlOther: char 
	^ self is: char inCategory: Cc! !

!Unicode class methodsFor: 'character classification' stamp: ''!
isLowercase: char 
	| index |
	index := char charCode + 1.
	index > GeneralCategory size
		ifTrue: [^ false].
	^ (GeneralCategory at: index) = Ll! !

!UnicodeTest commentStamp: ''!
Tests the character classification methods against the generalCategory table.  

Note that the correctness of the table is not checked. 
It probebably should be, but that is another task. !
!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsFinalQuote
	self checkCorrespondanceOf: #isFinalQuote: and: #Pf! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testNonCharacterNegative
	self aRandomSelectionOfCharactersDo: [  :ch |
		self deny: (Unicode isNonCharacter: ch) 
	]! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsLineSeparator
	self checkCorrespondanceOf: #isLineSeparator: and: #Zl! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsPrivateOther
	self checkCorrespondanceOf: #isPrivateOther: and: #Co! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsOtherLetter
	self checkCorrespondanceOf: #isOtherLetter: and: #Lo! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsCasedLetter
	"The Cased letter category, LC, is empty"
	self aRandomSelectionOfCharactersDo: [ :ch | 
		self deny: (Unicode isCasedLetter: ch) ]! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsSpaceSeparator
	self checkCorrespondanceOf: #isSpaceSeparator: and: #Zs! !

!UnicodeTest methodsFor: 'utilities' stamp: ''!
unicodeCategoryTableLookup: codePoint

	^self class unicodeCategoryTableLookup: codePoint! !

!UnicodeTest methodsFor: 'utilities' stamp: ''!
checkCorrespondanceOf: aSelector and: aCategoryTag
	| cat methodAnswer catFromTable |
	cat := Unicode classPool at: aCategoryTag.
	self
		aRandomSelectionOfCodePointsDo: [ :cp | 
			methodAnswer := Unicode
				perform: aSelector
				with: (Character codePoint: cp).
			catFromTable := self unicodeCategoryTableLookup: cp.
			methodAnswer = (catFromTable = cat)
				ifFalse: [ self
						assert: methodAnswer = (catFromTable = cat)
						description:
							aSelector asString , 'and category ' , aCategoryTag asString
								, 'disagree at U+' , cp asHexString ] ]! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsLetter
	| letterCategories methodAnswer catFromTable |
	letterCategories := #(Ll Lm Lo Lt Lu) collect: [ :c | Unicode classPool at: c ].
	self aRandomSelectionOfCodePointsDo: [ :cp | 
			methodAnswer := Unicode isLetter: (Character codePoint: cp).
			catFromTable := self unicodeCategoryTableLookup: cp.
			self assert: methodAnswer equals: (letterCategories includes: catFromTable) ]! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsOtherSymbol
	self checkCorrespondanceOf: #isOtherSymbol: and: #So! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsFormatOther
	self checkCorrespondanceOf: #isFormatOther: and: #Cf! !

!UnicodeTest methodsFor: 'utilities' stamp: ''!
aRandomSelectionOfCodePointsDo: aBlock
	0 to: 255 do: [ :cp | aBlock value: cp].
	500 timesRepeat: [ aBlock value: (unicodeGenerator randomCodePointAtOrAbove: 256) ].! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsDashPunctuation
	self checkCorrespondanceOf: #isDashPunctuation: and: #Pd! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsInitialQuote
	self checkCorrespondanceOf: #isInitialQuote: and: #Pi! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsOtherNumber
	self checkCorrespondanceOf: #isOtherNumber: and: #No! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsMathSymbol
	self checkCorrespondanceOf: #isMathSymbol: and: #Sm! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsOtherPunctuation
	self checkCorrespondanceOf: #isOtherPunctuation: and: #Po! !

!UnicodeTest methodsFor: 'utilities' stamp: ''!
aRandomSelectionOfCharactersDo: aBlock
	self aRandomSelectionOfCodePointsDo: [ :cp | aBlock value: (Character codePoint: cp) ]! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsEnclosingMark
	self checkCorrespondanceOf: #isEnclosingMark: and: #Me! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsSurrogateOther
	self checkCorrespondanceOf: #isSurrogateOther: and: #Cs! !

!UnicodeTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	unicodeGenerator := UnicodeTestRNG current! !

!UnicodeTest methodsFor: 'tests' stamp: ''!
testRNG
	| chars uniqueCount |
	chars := (1 to: 100)
		collect: [ :_ | unicodeGenerator randomCharacter].
	uniqueCount := chars asSet size.
	self assert: uniqueCount = 100 description: (100 - uniqueCount) asString , ' duplicates'! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsOpenPunctuation
	self checkCorrespondanceOf: #isOpenPunctuation: and: #Ps! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsDecimalDigit
	self checkCorrespondanceOf: #isDecimalDigit: and: #Nd! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsClosePunctuation
	self checkCorrespondanceOf: #isClosePunctuation: and: #Pe! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsDigit
	self checkCorrespondanceOf: #isDigit: and: #Nd! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsModifierSymbol
	self checkCorrespondanceOf: #isModifierSymbol: and: #Sk! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsLetterModifier
	self checkCorrespondanceOf: #isLetterModifier: and: #Lm! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsNonspacingMark
	self checkCorrespondanceOf: #isNonspacingMark: and: #Mn! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsTitlecaseLetter
	self checkCorrespondanceOf: #isTitlecaseLetter: and: #Lt! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsParagraphSeparator
	self checkCorrespondanceOf: #isParagraphSeparator: and: #Zp! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsCurrencySymbol
	self checkCorrespondanceOf: #isCurrencySymbol: and: #Sc! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsUppercase
	self checkCorrespondanceOf: #isUppercase: and: #Lu! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsLowercase
	self checkCorrespondanceOf: #isLowercase: and: #Ll! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsSpacingCombiningMark
	self checkCorrespondanceOf: #isSpacingCombiningMark: and: #Mc! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsConnectorPunctuation
	self checkCorrespondanceOf: #isConnectorPunctuation: and: #Pc! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testNonCharacterPositive
	| nonCps |
	nonCps := (16rFDD0 to: 16rFDEF) asSet. 
	nonCps addAll: (16r0FFFE to: 16r10FFFE by: 16r10000).
	nonCps addAll: (16r0FFFF to: 16r10FFFF by: 16r10000).
	self assert: nonCps size equals: 66.		"defined that way by the standard"
	nonCps do: [ :each | self assert: (Unicode isNonCharacter: (Character codePoint: each)) ]! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsControlOther
	self checkCorrespondanceOf: #isControlOther: and: #Cc! !

!UnicodeTest methodsFor: 'tests - categorization' stamp: ''!
testIsLetterNumber
	self checkCorrespondanceOf: #isLetterNumber: and: #Nl! !

!UnicodeTest class methodsFor: 'accessing' stamp: ''!
resources
	^ { UnicodeTestRNG }! !

!UnicodeTest class methodsFor: 'utilities' stamp: ''!
unicodeCategoryTableLookup: codePoint
	| index table |
	index := codePoint + 1.
	table := Unicode generalCategory.
	^ index > table size
		ifTrue: [ -1 ]
		ifFalse: [ table at: index ]! !

!UnicodeTestRNG commentStamp: ''!
The random number generator used by the UnicodeTest!
!UnicodeTestRNG methodsFor: 'running' stamp: ''!
randomCodePoint
	^ self randomCodePointBetween: 0 and: Unicode maxValue! !

!UnicodeTestRNG methodsFor: 'private' stamp: ''!
next
	^ generator next! !

!UnicodeTestRNG methodsFor: 'running' stamp: ''!
randomCharacterAtOrAbove: lower
	^ self randomCharacterBetween: lower and: Unicode maxValue! !

!UnicodeTestRNG methodsFor: 'running' stamp: ''!
randomCodePointAtOrAbove: lower
	^ self randomCodePointBetween: lower and: Unicode maxValue! !

!UnicodeTestRNG methodsFor: 'private' stamp: ''!
generator
	^ generator! !

!UnicodeTestRNG methodsFor: 'running' stamp: ''!
randomCodePointBetween: lower and: upper
	| max span codePoint |
	max := upper min: 16rE01EF.
	span := max - lower + 1.
	[
		codePoint := (self generator next * span) floor + lower.
		Unicode isNonCharacter: (Character codePoint: codePoint) 
	] whileTrue.
	^ codePoint! !

!UnicodeTestRNG methodsFor: 'running' stamp: ''!
randomCharacterBetween: lower and: upper
	^ Character codePoint: (self randomCodePointBetween: lower and: upper)! !

!UnicodeTestRNG methodsFor: 'running' stamp: ''!
randomCharacter
	^ self randomCharacterBetween: 0 and: Unicode maxValue! !

!UnicodeTestRNG methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	generator := Random seed: 14159265.! !

!Unix32Platform commentStamp: ''!
urce: 22651600!
!Unix32Platform methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor

	^ aVisitor visitUnix32: self! !

!Unix32Platform methodsFor: 'testing' stamp: 'nil'!
isUnix32
	^ true! !

!Unix32Platform methodsFor: '*UnifiedFFI' stamp: ''!
ffiLibraryName: aLibrary 
	^ aLibrary unix32LibraryName! !

!Unix32Platform class methodsFor: 'testing' stamp: 'nil'!
isActivePlatform

	^ (Smalltalk vm operatingSystemName = 'unix') 
		and: [ Smalltalk vm wordSize = 4 
			and: [ Smalltalk vm architectureName ~= 'armv7l' ] ] ! !

!Unix64Platform commentStamp: ''!
I am a an object representing a Unix platform (64bits). Use myself to access platform specific features.

Please keep me polymorphic to the the other platform objects.

To get the current platform, you can evaluate:

OSPlatform current.!
!Unix64Platform methodsFor: 'testing' stamp: 'nil'!
isUnix64
	^ true! !

!Unix64Platform methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor

	^ aVisitor visitUnix64: self! !

!Unix64Platform methodsFor: '*UnifiedFFI' stamp: ''!
ffiLibraryName: aLibrary 
	^ aLibrary unix64LibraryName! !

!Unix64Platform class methodsFor: 'testing' stamp: 'nil'!
isActivePlatform
	^ (Smalltalk vm operatingSystemName = 'unix') and: [ Smalltalk vm wordSize = 8 ]! !

!UnixARM32Platform commentStamp: ''!
I represent the specifics of running Unix in a ARM32 processor!
!UnixARM32Platform methodsFor: '*UnifiedFFI' stamp: ''!
ffiInt64Alignment
	
	"64 bits value are aligned to 8 bytes"
	^ 8! !

!UnixARM32Platform methodsFor: '*UnifiedFFI' stamp: ''!
ffiFloat64Alignment
	
	"64 bits value are aligned to 8 bytes"
	^ 8! !

!UnixARM32Platform class methodsFor: 'testing' stamp: 'nil'!
isActivePlatform

	^ (Smalltalk vm operatingSystemName = 'unix') 
		and: [ Smalltalk vm wordSize = 4 
			and: [ Smalltalk vm architectureName = 'armv7l' ] ] ! !

!UnixDynamicLoader commentStamp: ''!
I'm a unix platform (works in mac too) dynamic library loader.!
!UnixDynamicLoader methodsFor: 'misc' stamp: ''!
lastError
	^ self ffiCall: #(String dlerror(void))! !

!UnixDynamicLoader methodsFor: 'misc' stamp: ''!
loadSymbolFrom: handle name: symbol
	^ self ffiCall: #(void *dlsym(void *handle, String symbol))
! !

!UnixDynamicLoader methodsFor: 'misc' stamp: ''!
loadLibrary: path
	^ self loadLibrary: path flag: 0 ! !

!UnixDynamicLoader methodsFor: 'misc' stamp: ''!
loadLibrary: filename flag: flag
	^ self ffiCall: #(void *dlopen(const char *filename, int flag))! !

!UnixDynamicLoader class methodsFor: 'testing' stamp: ''!
isAvailable
	^ Smalltalk os isUnix 
		or: [ Smalltalk os isMacOS ]! !

!UnixEnvironment commentStamp: ''!
I am a specialized OSEnvironment version for *nix systems (Linux, OSX).
See my superclass to understand my common usage.

# Encoding Management

I provide a variant of the Dictionary-like API that receives an extra argument specifying an encoding.
Valid encodings are those specified by the Zinc-Character-Encoding-* packages.
The API accepts both encoding objects and symbols which are used to lookup encodings.

For example, the following usages are valid:

OSEnvironment current at: 'HOME' encoding: #utf8.
OSEnvironment current at: 'HOME' encoding: #utf8 asZnCharacterEncoder.
OSEnvironment current at: 'HOME' encoding: ZnCharacterEncoder utf8.

# Implementation Details

I try to use a primitive to get/set environment variables, and if it fails or it is not available, I use corresponding ffi calls using byteArrays with encoded strings as argument.!
!UnixEnvironment methodsFor: 'private' stamp: ''!
environ
	"Return the address of the array holding the environment variables"
	^ FFIExternalArray 
		fromPointer: (ExternalAddress loadSymbol: 'environ' from: LibC)
		type: String! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
rawAt: anEncodedKey put: someBytes
	"Sets the value of an environment variable called `anEncodedKey` to `someBytes`.
	Both arguments should be already encoded (i.e., they are byte arrays).
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."

	^ self setEnv: anEncodedKey asString value: someBytes asString! !

!UnixEnvironment methodsFor: 'private' stamp: ''!
basicGetEnvRawViaFFI: arg1

	"PRIVATE: This FFI call works on Strings, while the correct way to manage encodings is with raw data.
	Use me through #basicGetEnvRaw: to correctly marshall data."

	"This method calls the Standard C Library getenv() function.
	The name of the argument (arg1) should fit decompiled version."
	
	 ^ self ffiCall: #( String getenv (String arg1) ) module: LibC! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
rawAt: anEncodedKey
	"Gets the value of an environment variable called `anEncodedKey` that is already encoded (i.e., it is a byte array).
	Throws a KeyNotFound exception if not found.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."
	
	^ self rawAt: anEncodedKey ifAbsent: [ KeyNotFound signalFor: anEncodedKey ]! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey put: aValue
	"See super>>at:put:.
	Uses a single encoding determined dynamically"

	^ self at: aKey put: aValue encoding: self defaultEncoding! !

!UnixEnvironment methodsFor: 'private' stamp: ''!
basicGetEnvRaw: encodedVariableName

	"PRIVATE: This primitive call works on Strings, while the correct way to manage encodings is with raw data.
	Use me through #rawAt: to correctly marshall data."
	
	"Gets the value of an environment variable called `anEncodedVariableName` already encoded but in ByteString form."
	
	<primitive: 'primitiveGetenv' module: '' error: ec>
	ec ifNil: [ ^ (self basicGetEnvRawViaFFI: encodedVariableName asString) asByteArray].
	self primitiveFail! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
rawRemoveKey: anEncodedKey
	"Removes an environment variable called `anEncodedKey` that is already encoded (i.e., it is a byte array).
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."

	^ self unsetEnv: anEncodedKey asString! !

!UnixEnvironment methodsFor: 'private' stamp: ''!
setEnv: nameString value: valueString
	"This method calls the Standard C Library setenv() function"

	^ self ffiCall: #(int setenv #(String nameString , String valueString , 1)) module: LibC! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey encoding: anEncoding ifPresent: aBlock
	"Gets the value of an environment variable called `aKey` and invoke aBlock with it.
	Return nil if absent.
	Use `anEncoding` to encode the arguments and return values.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."
	
	^ aBlock value: (self at: aKey encoding: anEncoding ifAbsent: [ ^ nil ])! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
defaultEncoding

	^ OSPlatform current defaultEncoding! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
rawAt: anEncodedKey ifAbsentPut: aBlock
	"Gets the value of an environment variable called `aKey` that is already encoded (i.e., it is a byte array).
	If absent, insert the value given by aBlock.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."
	
	^ self rawAt: anEncodedKey ifAbsent: [ self rawAt: anEncodedKey put: aBlock value ]! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey encoding: anEncoding ifAbsent: aBlock
	"Gets the value of an environment variable called `aKey`.
	Execute aBlock if absent.
	Use `anEncoding` to encode the arguments and return values.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."
	
	| result |
	result := self
		rawAt: (aKey encodeWith: anEncoding)
		ifAbsent: [ ^ aBlock value].
	^ result decodeWith: anEncoding! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
rawAt: anEncodedKey ifPresent: presentBlock ifAbsent: absentBlock
	"Gets the value of an environment variable called `anEncodedKey` that is already encoded (i.e., it is a byte array).
	Call presentBlock with it if present.
	Execute absentBlock if absent.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."
	
	self rawAt: anEncodedKey ifPresent: [ :v | ^ presentBlock cull: v ].
	^absentBlock value! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey encoding: anEncoding ifPresent: presentBlock ifAbsent: absentBlock
	"Gets the value of an environment variable called `aKey`.
	Call presentBlock with it if present.
	Execute absentBlock if absent.
	Use `anEncoding` to encode the arguments and return values.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."
	
	self at: aKey encoding: anEncoding ifPresent: [ :v | ^ presentBlock cull: v ].
	^absentBlock value! !

!UnixEnvironment methodsFor: 'enumeration' stamp: ''!
keysAndValuesDo: aBlock
	| index associationString  |
	index := 1	.
	[ 
		associationString := self environAt: index.
		associationString ifNil: [ ^ self ].
		self keysAndValuesDo: aBlock withAssociationString: associationString.
		index := index + 1
	] repeat.! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey ifAbsent: aBlock
	"See super>>at:ifAbsent:.
	Uses a single encoding determined dynamically"

	^ self at: aKey encoding: self defaultEncoding ifAbsent: aBlock! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
rawAt: anEncodedKey ifAbsent: aBlock
	"Gets the value of an environment variable called `anEncodedKey` that is already encoded (i.e., it is a byte array).
	Execute aBlock if absent.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."
	
	| rawValue |
	rawValue := self basicGetEnvRaw: anEncodedKey asString.
	^ rawValue
		ifNil: [ aBlock value ]
		ifNotNil: [ rawValue asByteArray ].! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
rawAt: anEncodedKey ifPresent: aBlock
	"Gets the value of an environment variable called `anEncodedKey` that is already encoded (i.e., it is a byte array) and invoke aBlock with it.
	Return nil if absent.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."
	
	^ aBlock value: (self rawAt: anEncodedKey ifAbsent: [ ^ nil ])! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey encoding: anEncoding
	"Gets the value of an environment variable called `aKey`.
	Throws a KeyNotFound exception if not found.
	Use `anEncoding` to encode the arguments and return values.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."
	
	^ self at: aKey encoding: anEncoding ifAbsent: [ KeyNotFound signalFor: aKey ]! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey encoding: anEncoding ifAbsentPut: aBlock
	"Gets the value of an environment variable called `aKey`.
	If absent, insert the value given by aBlock.
	Use `anEncoding` to encode the arguments and return values.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."
	
	^ self at: aKey encoding: anEncoding ifAbsent: [ self at: aKey put: aBlock value encoding: anEncoding ]! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
at: aKey put: aValue encoding: anEncoding
	"Sets the value of an environment variable called `aKey` to `aValue`.
	Use `anEncoding` to encode both arguments.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."

	^ self
		rawAt: (aKey encodeWith: anEncoding)
		put: (aValue encodeWith: anEncoding)! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
removeKey: key
	"See super>>removeKey:.
	Uses a single encoding determined dynamically"
	
	^ self removeKey: key encoded: self defaultEncoding! !

!UnixEnvironment methodsFor: 'accessing' stamp: ''!
removeKey: key encoded: anEncoding
	"Removes the entry `aKey` from the environment variables.
	Use `anEncoding` to encode the arguments.
	
	This is a *nix specific API.
	Rationale: In *nix systems (compared to windows systems) environment variables are stored as raw bytes and can be encoded in different forms."

	^ self rawRemoveKey: (key encodeWith: anEncoding)! !

!UnixEnvironment methodsFor: 'private' stamp: ''!
environAt: index
	^ self environ at: index! !

!UnixEnvironment class methodsFor: 'testing' stamp: ''!
isDefaultFor: aPlatform 
	^  aPlatform isUnix 
		or: [ aPlatform isMacOSX 
		or: [ aPlatform isMacOS ] ]! !

!UnixPlatform commentStamp: ''!
I am a an object representing a Unix platform. Use myself to access platform specific features.

Please keep me polymorphic to the the other platform objects.

To get the current platform, you can evaluate:

OSPlatform current.!
!UnixPlatform methodsFor: '*FileSystem-Core' stamp: ''!
potentialLocationsOfSourcesFile
	^ { Smalltalk vm directory. FileLocator userData }! !

!UnixPlatform methodsFor: 'accessing' stamp: 'nil'!
defaultMaximumPathLength
	"This method returns the default maximum path length for the getCurrentWorkingDirectory implementation. 
Unix default PATH_MAX is 4096.  PATH_MAX is needed to avoid buffer overflow. In case PATH_MAX is not sufficient the method  currentWorkingDirectoryWithBufferSize: can be used to give desired buffer size."
	^4096
! !

!UnixPlatform methodsFor: 'accessing' stamp: 'nil'!
menuShortcutString
	^ 'ctrl'! !

!UnixPlatform methodsFor: '*Spec2-Core' stamp: ''!
configureApplication: anApplication configuration: aConfiguration
	
	aConfiguration configureUnix: anApplication! !

!UnixPlatform methodsFor: 'testing - linux' stamp: 'nil'!
isLinuxDistributionWithID: linuxOperatingSystemID
	"Check if the installed OS is a Linux with the given lowercase ID. One can
	 check for 'ubuntu', 'fedora', 'opensuse', 'rhel', 'centos' and others. 
	
	 A good list is available at: https://gist.github.com/natefoo/814c5bf936922dad97ff
	"
	
	| id |
	id := self linuxIdentificationParameters at: #ID ifAbsent: [ ^false ]. 
	^ id asLowercase = linuxOperatingSystemID asLowercase 
	! !

!UnixPlatform methodsFor: 'accessing' stamp: 'nil'!
family
	^#Unix! !

!UnixPlatform methodsFor: 'testing' stamp: 'nil'!
isUnix
	^ true! !

!UnixPlatform methodsFor: 'accessing - linux' stamp: 'nil'!
linuxIdentificationParameters
	"see https://www.freedesktop.org/software/systemd/man/os-release.html"

	| props extractor |
	props := Dictionary new.
	self isLinux ifFalse: [ ^props ].
	extractor := [ '/etc/os-release' asFileReference contents linesDo: [ :each | 
		props at: (each copyUpTo: $=) asSymbol put: (each copyAfter: $=) ]].

	"Do nothing when it does not exist"
	[ extractor value ] on: FileDoesNotExistException do: [ self error: 'Only available on distributions supporting the linux standard base (LSB)' ].
	^ props! !

!UnixPlatform methodsFor: 'accessing' stamp: 'nil'!
keyForValue: aKeyValue
	^KeyboardKey valueForUnixPlatform: aKeyValue.! !

!UnixPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiLibraryName: aLibrary 
	^ aLibrary unixLibraryName! !

!UnixPlatform methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
defaultModifier

	^ KMModifier control! !

!UnixPlatform methodsFor: 'testing' stamp: 'nil'!
isLinux
	"Some Linux versions return linux, some linux-gnu, ..."
	
	^self version beginsWith: 'linux'! !

!UnixPlatform methodsFor: 'accessing' stamp: 'nil'!
lineEnding

	^ String lf! !

!UnixPlatform methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor

	^ aVisitor visitUnix: self! !

!UnixPlatform methodsFor: 'testing - linux' stamp: 'nil'!
isLinuxDerivateOf: linuxOperatingSystemID
	"Check if the installed OS is a derivate of the given linuxOperatingSystemID.
	 It returns true if the /etc/os-release file includes an entry ID_LIKE where the given
	 ID appears in the space separated list."
	
	| derivateList |
	derivateList := self linuxIdentificationParameters at: #ID_LIKE ifAbsent: [ ^false ]. 
	^(derivateList substrings: ' ') 
			anySatisfy: [:each | each asLowercase = linuxOperatingSystemID asLowercase ]! !

!UnixResolver commentStamp: ''!
I am an expert on Unix filesystem conventions. I resolve origins according to these conventions.!
!UnixResolver methodsFor: 'helpers' stamp: ''!
xdgUserDir: userDirName
	"Read ~/.config/user-dirs.dirs to find the directory of userDirName (e.g., 'DESKTOP')"
	"http://freedesktop.org/wiki/Software/xdg-user-dirs"
	"This file is written by xdg-user-dirs-update If you want to change or add directories, just edit the line you're interested in. All local changes will be retained on the next run Format is XDG_xxx_DIR=""$HOME/yyy"", where yyy is a shell-escaped homedir-relative path, or XDG_xxx_DIR=""/yyy"", where /yyy is an absolute path. No other format is supported."
	| configFile |
	configFile := self preferences / 'user-dirs.dirs'.
	(configFile isFile and: [ configFile isReadable ]) ifFalse: [ ^ nil ].
	configFile readStreamDo: [ :stream | 
		[ stream atEnd ]
			whileFalse: [ 
				((stream peek ~= $#) and: [ (stream upTo: $=) = ('XDG_', userDirName, '_DIR') ])
							ifTrue: [ ^ self xdgParseUserDirLine: stream ]
							ifFalse: [ stream nextLine ] ] ].
	^ nil! !

!UnixResolver methodsFor: 'origins' stamp: ''!
userData
	<origin>
	^ self directoryFromEnvVariableNamed: 'XDG_DATA_HOME' or: [ self home / '.local' / 'share' ]! !

!UnixResolver methodsFor: 'origins' stamp: ''!
desktop
	^ (self xdgUserDir: 'DESKTOP') ifNil: [ super desktop ]! !

!UnixResolver methodsFor: 'origins' stamp: ''!
documents
	^ (self xdgUserDir: 'DOCUMENTS') ifNil: [ super documents ]! !

!UnixResolver methodsFor: 'origins' stamp: ''!
temp
	^ '/tmp' asFileReference! !

!UnixResolver methodsFor: 'helpers' stamp: ''!
xdgParseUserDirLine: aStream
	"Format is XDG_xxx_DIR=""$HOME/yyy"", where yyy is a shell-escaped homedir-relative path, or XDG_xxx_DIR=""/yyy"", where /yyy is an absolute path. No other format is supported."
	| path firstChar |
	(aStream next = $") ifFalse: [ ^ nil ].
	firstChar := aStream next.
	(#($$ $/) includes: firstChar) ifFalse: [ ^ nil ].
	path := firstChar = $$
				ifTrue: [ (aStream next: 5) = 'HOME/' ifFalse: [ ^ nil ].
					       self home / ((aStream upTo: $") ifEmpty: [ '.' ]) ]
				ifFalse: [ self resolveString: '/', (aStream upTo: $") ].
	^ path! !

!UnixResolver methodsFor: 'origins' stamp: ''!
cache
	"http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html"

	^ self directoryFromEnvVariableNamed: 'XDG_CACHE_HOME' or: [ self home / '.cache' ]! !

!UnixResolver methodsFor: 'origins' stamp: ''!
downloads
	^ (self xdgUserDir: 'DOWNLOADS') ifNil: [ super downloads ]! !

!UnixResolver methodsFor: 'origins' stamp: ''!
home
	^ self directoryFromEnvVariableNamed: 'HOME'! !

!UnixResolver methodsFor: 'origins' stamp: ''!
preferences
	"http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html"

	^ self directoryFromEnvVariableNamed: 'XDG_CONFIG_HOME' or: [ self home / '.config' ]! !

!UnixResolver class methodsFor: 'accessing' stamp: ''!
platformName
	^  'unix'! !

!UnixResolverTest commentStamp: ''!
SUnit tests for PlatformResolver!
!UnixResolverTest methodsFor: 'tests' stamp: ''!
testXdgParseUserDirLineNotRoot
	"Ensure that a path of the form '$HOME/' doesn't resolve to the root directory.
	Note that this test can be run on any platform."
	| stream path |

	stream := '"$HOME/"' readStream.
	path := resolver xdgParseUserDirLine: stream.
	self deny: path isRoot.! !

!UnixResolverTest methodsFor: 'tests' stamp: ''!
testXdgParseUserDirLineDocuments
	"Ensure that a path of the form '$HOME/Documents' answers the expected value.
	Note that this test can be run on any platform."
	| stream path relativePath |

	stream := '"$HOME/Documents"' readStream.
	path := resolver xdgParseUserDirLine: stream.
	relativePath := path relativeTo: resolver home.
	self assert: relativePath pathString equals: 'Documents'.! !

!UnixResolverTest methodsFor: 'running' stamp: ''!
createResolver

	^ UnixResolver new! !

!UnixStore commentStamp: ''!
I'm a specific store for Unix file systems!
!UnixStore methodsFor: 'public' stamp: ''!
checkName: aFileName fixErrors: fixing
	"Check if the file name contains any invalid characters"
	| fName |
	fName := super checkName: aFileName fixErrors: fixing.
	
	(fName includes: self delimiter) ifFalse:
		[^fName].
	
	fixing ifFalse: [self error:'Invalid file name'].
	
	^ fName copyReplaceAll: self delimiter asString with: '#'! !

!UnixStore methodsFor: 'testing' stamp: ''!
isHidden: aResolvable attributes: statAttributesArray
	"Answer a boolean indicating whether the file is hidden or not.
	On Unix, use the file naming convention that file names beginning with a dot are not displayed"

	^aResolvable basename first = $.! !

!UnixStore class methodsFor: 'public' stamp: ''!
maxFileNameLength

	^ 255! !

!UnixStore class methodsFor: 'public' stamp: ''!
delimiter
	^ $/! !

!UnixStore class methodsFor: 'public' stamp: ''!
separator 
	^ $:! !

!UnixStore class methodsFor: 'public' stamp: ''!
isCaseSensitive
	"except for OSX the default is case sensitive"
	^ Smalltalk os isMacOSX not! !

!UnixStore class methodsFor: 'current' stamp: ''!
isActiveClass
	^ Smalltalk os isUnix and: [ super isActiveClass ]! !

!UnixStore class methodsFor: 'public' stamp: ''!
readOnlyVariant

	^ ReadOnlyUnixStore! !

!UnlimitedInstanceVariableSlot commentStamp: ''!
We store state in a hidden array. Contrary to normal instance variables the number is unlimited.!
!UnlimitedInstanceVariableSlot methodsFor: 'TODO' stamp: ''!
todo
	'
    - adding a slots in between --> offsets need to be updated?
	 - removing slot in the middle	
	 - adding slot higher in the hierarchy: move baseselot (same as in TODO for DictionarySlot)
	 - instance migration?
	'! !

!UnlimitedInstanceVariableSlot methodsFor: 'class building' stamp: ''!
growBaseSlot: aClass
	baseSlot default: (baseSlot default grownBy: 1)! !

!UnlimitedInstanceVariableSlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	^(baseSlot read: anObject) at: offset
		! !

!UnlimitedInstanceVariableSlot methodsFor: 'class building' stamp: ''!
installingIn: aClass
	| unlimitedSlots |
	super installingIn: aClass.
	
	"we reuse a baseSlot if it is already there, if not, we add it"
	"TODO: this does not take into account adding BooleanSlots higher up in the Hierarchy"
	aClass classLayout 
		resolveSlot: #'_ivarArrayBaseSlot'   
		ifFound:  [: slot |  baseSlot := slot. self growBaseSlot: aClass. ]
		ifNone: [aClass addSlot: (baseSlot := #'_ivarArrayBaseSlot' => BaseSlot default: (Array new: 1))].
	
	"my offset in the base slot is defined by the order of all BooleanSlots in the Hierarchy"
	unlimitedSlots := aClass allSlots select: [ :each | each isKindOf: self class ].
	offset := unlimitedSlots indexOf: self
! !

!UnlimitedInstanceVariableSlot methodsFor: 'accessing' stamp: ''!
offset
	^offset! !

!UnlimitedInstanceVariableSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject
	^(baseSlot read: anObject) at: offset put: aValue.
	! !

!UnlimitedInstanceVariableSlot methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder
	"generate bytecode for '<baseSlot> at: offset'"
	methodBuilder
		pushInstVar: baseSlot index;
		pushLiteral: offset;
		send: #at:
			! !

!UnlimitedInstanceVariableSlot methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder
	"generate bytecode for 'baseSlot at: index put: <stackTop>'"
	| tempName |
	tempName := '0slotTempForStackManipulation'.
	methodBuilder
		addTemp: tempName;
		storeTemp: tempName;
		popTop;
		pushInstVar: baseSlot index;
		pushLiteral: offset;
		pushTemp: tempName;
		send: #at:put:! !

!UnlimitedInstanceVariableSlotTest methodsFor: 'test - unlimited ivars' stamp: ''!
testExampleIvarSlot
	| object slot |
	slot := #slot1 => UnlimitedInstanceVariableSlot.

	aClass := self make: [ :builder | builder slots: {slot} ].
	self assert: (slot instVarNamed: 'baseSlot') isNotNil.

	object := aClass new.
	"test reflective write and read"
	slot write: 5 to: object.
	self assert: (slot read: object) identicalTo: 5.

	self compileAccessorsFor: slot.

	self assert: object slot1 identicalTo: 5.
	object slot1: false.
	self deny: object slot1! !

!UnlimitedInstanceVariableSlotTest methodsFor: 'test - unlimited ivars' stamp: ''!
testExampleTwoIvarSlots
	| object slot1 slot2 |
	slot1 := #slot1 => UnlimitedInstanceVariableSlot.
	slot2 := #slot2 => UnlimitedInstanceVariableSlot.

	aClass := self make: [ :builder | builder slots: {slot1 . slot2} ].

	self assert: (slot1 instVarNamed: 'baseSlot') isNotNil.
	self assert: (slot1 instVarNamed: 'baseSlot') identicalTo: (slot2 instVarNamed: 'baseSlot').

	object := aClass new.
	"test reflective write and read"
	slot1 write: true to: object.
	self assert: (slot1 read: object).

	slot2 write: true to: object.
	self assert: (slot2 read: object).

	slot2 write: true to: object.
	slot1 write: false to: object.
	self assert: (slot2 read: object).
	slot2 write: false to: object.
	self deny: (slot2 read: object)! !

!UnreferencedSharedPool commentStamp: ''!
Just a class for testing!
!UnresolvedVariable commentStamp: ''!
The parser does not now the semantic meaning of Variables. It thus sets them all to be an UnresolvedVariable.

The Semantic Analysis (#doSemanticAnalysis) then gives meaning to Variables and sets them correctly.!
!UnresolvedVariable methodsFor: 'debugging' stamp: ''!
readInContext: aContext
	self error: 'Can not read variable, please call #doSemanticAnalysis first'! !

!UnresolvedVariable methodsFor: 'debugging' stamp: ''!
write: aValue inContext: aContext
	self error: 'Can not write variable, please call #doSemanticAnalysis first'! !

!UnresolvedVariable methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder

	self error: 'Can not generate code, please call #doSemanticAnalysis first'! !

!UnresolvedVariable methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder

	self error: 'Can not generate code, please call #doSemanticAnalysis first'! !

!UnresolvedVariable methodsFor: 'accessing' stamp: ''!
scope
	^nil! !

!UnresolvedVariable methodsFor: 'queries' stamp: ''!
usingMethods
	^#()! !

!UnresolvedVariable class methodsFor: 'accessing' stamp: ''!
instance 
	^instance ifNil: [ instance := self new ]! !

!UpdatingMenuItemMorph commentStamp: ''!
I am a menu item morph with the ability to refresh periodically all my values (name, state, enablement, icon, submenu)

Since it is not a good idea to change the shortcut, this ability is not available!
!UpdatingMenuItemMorph methodsFor: 'private' stamp: ''!
updateSubMenu

	target ifNotNil: [ subMenu := (target perform: subMenuSelector) ]! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
iconSelector
	^ iconSelector! !

!UpdatingMenuItemMorph methodsFor: 'stepping' stamp: ''!
step

	owner ifNil: [ ^ self stopStepping ].
	self updateContents.
	self changed! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
balloonTextSelector
	^ balloonTextSelector! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
balloonText

	^ self target perform: balloonTextSelector! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
subMenuSelector: anObject
	subMenuSelector := anObject.
	self updateSubMenu! !

!UpdatingMenuItemMorph methodsFor: 'private' stamp: ''!
updateIcon

	target ifNotNil: [ self icon: (target perform: iconSelector) ]! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
nameSelector: aSymbol
	nameSelector := aSymbol.
	self updateContents! !

!UpdatingMenuItemMorph methodsFor: 'private' stamp: ''!
updateContents

	target ifNotNil: [ contents := (target perform: nameSelector) ]! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
nameSelector
	^ nameSelector! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
iconSelector: anObject
	iconSelector := anObject.
	self updateIcon! !

!UpdatingMenuItemMorph methodsFor: 'private' stamp: ''!
updateBalloonText

	target ifNotNil: [ self balloonText: (target perform: balloonTextSelector) ]! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
icon

	^ (target perform: iconSelector)
		ifNil: [ super icon ]! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
contents

	^ self target perform: nameSelector! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
subMenuSelector
	^ subMenuSelector! !

!UpdatingMenuItemMorph methodsFor: 'accessing' stamp: ''!
balloonTextSelector: anObject
	balloonTextSelector := anObject.
	self updateBalloonText! !

!UpdatingMenuItemMorph methodsFor: 'stepping' stamp: ''!
stepTime
	
	^ 250! !

!UserInputEvent commentStamp: ''!
A general user input event like for keyboard or mouse!
!UserInputEvent methodsFor: 'accessing' stamp: ''!
position
	^position! !

!UserInputEvent methodsFor: 'modifier state' stamp: ''!
altKeyPressed
	"Answer true if the alt/option key on the keyboard was being held down when this event occurred."

	"00100000 is the bit that marks that option/alt has been pressed"
	^self optionKeyPressed! !

!UserInputEvent methodsFor: 'modifier state' stamp: ''!
shiftPressed
	"Answer true if the shift key on the keyboard was being held down when this event occurred."

	^ buttons anyMask: 8! !

!UserInputEvent methodsFor: 'accessing' stamp: ''!
wasHandled
	^wasHandled! !

!UserInputEvent methodsFor: 'transforming' stamp: ''!
transformBy: aMorphicTransform
	"Transform the receiver into a local coordinate system."
	position :=  aMorphicTransform globalPointToLocal: position.! !

!UserInputEvent methodsFor: 'accessing' stamp: ''!
wasHandled: aBool
	wasHandled := aBool.! !

!UserInputEvent methodsFor: 'initialize' stamp: ''!
copyHandlerState: anEvent
	"Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
	handler := anEvent handler.
	wasHandled := anEvent wasHandled.! !

!UserInputEvent methodsFor: 'accessing' stamp: ''!
handler
	^handler! !

!UserInputEvent methodsFor: 'transforming' stamp: ''!
translateBy: delta
	"add delta to cursorPoint, and return the new event"
	position := position + delta.! !

!UserInputEvent methodsFor: 'transforming' stamp: ''!
translatedBy: delta
	"add delta to cursorPoint, and return the new event"
	^self shallowCopy translateBy: delta! !

!UserInputEvent methodsFor: 'accessing' stamp: ''!
handler: anObject
	handler := anObject! !

!UserInputEvent methodsFor: 'printing' stamp: ''!
buttonString
	"Return a string identifying the currently pressed buttons"
	| string |
	string := ''.
	self redButtonPressed ifTrue:[string := string,'red '].
	self yellowButtonPressed ifTrue:[string := string,'yellow '].
	self blueButtonPressed ifTrue:[string := string,'blue '].
	^string! !

!UserInputEvent methodsFor: 'modifier state' stamp: ''!
anyModifierKeyPressed
	"ignore, however, the shift keys 'cause that's not REALLY a command key "

	^ self buttons anyMask: 2r01110000	"cmd | opt | ctrl"! !

!UserInputEvent methodsFor: 'accessing' stamp: ''!
buttons
	"Return the a word encoding the mouse and modifier buttons for this event."

	^ buttons! !

!UserInputEvent methodsFor: 'initialize' stamp: ''!
resetHandlerFields
	"Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"
	handler := nil.
	wasHandled := false.! !

!UserInputEvent methodsFor: 'modifier state' stamp: ''!
controlKeyPressed
	"Answer true if the control key on the keyboard was being held down when this event occurred."

	"The mask for control bit pressed"
	^ buttons anyMask: 2r00010000! !

!UserInputEvent methodsFor: 'private' stamp: ''!
setPosition: aPoint
	position := aPoint! !

!UserInputEvent methodsFor: 'transforming' stamp: ''!
transformedBy: aMorphicTransform
	"Return the receiver transformed by the given transform into a local coordinate system."
	^self shallowCopy transformBy: aMorphicTransform! !

!UserInputEvent methodsFor: 'modifier state' stamp: ''!
commandKeyPressed
	"Answer true if the command key on the keyboard was being held down when this event occurred."

	"The mask for command bit pressed"
	^ buttons anyMask: 2r01000000! !

!UserInputEvent methodsFor: 'printing' stamp: ''!
modifierString
	"Return a string identifying the currently pressed modifiers"
	| string |
	string := ''.
	self commandKeyPressed ifTrue:[string := string,'CMD '].
	self shiftPressed ifTrue:[string := string,'SHIFT '].
	self controlKeyPressed ifTrue:[string := string,'CTRL '].
	^string! !

!UserInputEvent methodsFor: 'modifier state' stamp: ''!
optionKeyPressed
	"Answer true if the alt/option key on the keyboard was being held down when this event occurred."

	"00100000 is the bit that marks that option/alt has been pressed"
	^ buttons anyMask: 2r00100000! !

!UserInputEvent methodsFor: 'accessing' stamp: ''!
type
	"Return a symbol indicating the type this event."

	^ type! !

!UserInterruptHandler commentStamp: ''!
An UserInterruptHandler watches incoming input events and checks for the user interrupt key.
If encountered it interrupts the current process and opens a notifier..

Instance Variables
	interruptKey:		<Object>

interruptKey
	- definition of the user interrupt key
!
!UserInterruptHandler methodsFor: 'private' stamp: ''!
handleUserInterruptKillAll
	"This will be called from the event-fetcher process. 
	Assume no system-vital processes have a lower priority than this, and are thus ok to interrupt"
	| killedProcesses |
	UserInterruptHandler cmdDotEnabled ifFalse: [ ^ self ]. 

	[
		killedProcesses := self killAllProcess.
		UIManager default spawnNewProcess.
		UIManager default inform: 'All processes killed'.
		killedProcesses inspect.
	"fork exceptions, we don't want interrupt handler to die"
	] on: Error fork: [:ex | ex pass].! !

!UserInterruptHandler methodsFor: 'private' stamp: ''!
processToInterrupt 
	"Look for best candidate to interrupt: 
		- any scheduled non-finalization process of lower priority 
		- the weak-finalization process, if scheduled 
		- the UI process 
	Never interrupt the idle process, since killing it is fatal" 

	| fallback | 
	fallback := UIManager default uiProcess. 
	Processor 
		scanSchedule: [:p | 
		 "suspendedContext sender == nil usually means that process is only scheduled but had no chance to run" 
			(p ~~ Processor backgroundProcess and: [p suspendedContext sender notNil]) ifTrue: [
				p ~~  WeakArray runningFinalizationProcess 
					ifTrue: [^p] 
					ifFalse: [fallback := p]]]
		startingAt: Processor activePriority. 
	^fallback! !

!UserInterruptHandler methodsFor: 'private' stamp: ''!
handleUserInterrupt
	"This will be called from the event-fetcher process. 
	Assume no system-vital processes have a lower priority than this, and are thus ok to interrupt"
	UserInterruptHandler cmdDotEnabled ifFalse: [ ^ self ]. 

	[
		self processToInterrupt
			ifNotNil: [ :proc | proc debugWithTitle: 'User Interrupt' ]
			ifNil: [ UIManager default inform: 'Process not interruptable' ]
	
	"fork exceptions, we don't want interrupt handler to die"
	] on: Error fork: [:ex | ex pass].! !

!UserInterruptHandler methodsFor: 'private' stamp: ''!
killAllProcess
	"Look for best candidate to interrupt: 
		- any scheduled non-finalization process of lower priority 
		- the weak-finalization process, if scheduled 
		- the UI process 
	Never interrupt the idle process, since killing it is fatal" 

	|  myself killedProcesses | 
	killedProcesses := OrderedCollection new.
	myself := Processor activeProcess.
	Processor 
		scanSchedule: [:p | 
		 "suspendedContext sender == nil usually means that process is only scheduled but had no chance to run" 
			(p ~~ Processor backgroundProcess and: [p suspendedContext sender notNil and: [p ~~ myself "fallback"]] ) ifTrue: [
				killedProcesses add: p.
				p terminate ]]
		startingAt: Processor highestPriority. 
	^killedProcesses! !

!UserInterruptHandler class methodsFor: 'setting' stamp: ''!
cmdDotEnabled 
	^ CmdDotEnabled ifNil: [CmdDotEnabled := true]! !

!UserInterruptHandler class methodsFor: 'setting' stamp: ''!
settingsOn: aBuilder
	
	<systemsettings>
	
	(aBuilder setting: #cmdDotEnabled)
		parent: #debugging;
		label: 'Enable cmd-dot interrupt key';
		target: UserInterruptHandler;
		default: true;
		description:
			'If true, it allows the user to stop currently running process by opening-up a debugger'! !

!UserInterruptHandler class methodsFor: 'setting' stamp: ''!
cmdDotEnabled: aBoolean
	CmdDotEnabled := aBoolean! !

!UserOfFooSharedPool commentStamp: ''!
I am an sunit test for SystemNavigation.!
!UserOfFooSharedPool methodsFor: 'test mock' stamp: ''!
simpleMethod
	^FooValue1! !

!VTermDefaultColor commentStamp: ''!
I represent a default color for the terminal.
I can return the default color of the background and the default color of the font for this terminal.!
!VTermDefaultColor methodsFor: 'terminfo' stamp: ''!
asTerminfoCharacterBackground
	"I give a value to the background default color"
	^ (40 "Background indicator" + 9 "default color") asString! !

!VTermDefaultColor methodsFor: 'terminfo' stamp: ''!
asTerminfoCharacterFont
	"I give a value to the font default color"
	^ (30 "Font indicator" + 9 "default color") asString! !

!VTermDefaultColor methodsFor: 'testing' stamp: ''!
isVTermDefaultColor
	"A default color is a default color in anycase"
	
	^ true! !

!VTermOutputBackground commentStamp: ''!
I'm the background style of a VTermOutputDriver
I'm characterized by the color of the background that will be printed.!
!VTermOutputBackground methodsFor: 'styling' stamp: ''!
setInDriver: aVTermOutputDriver 
	
	aVTermOutputDriver setBackgroundColor: color! !

!VTermOutputBackground methodsFor: 'comparing' stamp: ''!
hash
	^ self color hash! !

!VTermOutputBackground methodsFor: 'comparing' stamp: ''!
= aBackground
	^ self color isVTermDefaultColor and: [ aBackground color isVTermDefaultColor ]! !

!VTermOutputDriver commentStamp: ''!
I convert high-level terminal commands like moving the cursor or setting the color to characters sequences understood by the terminal.

Furthermore I do some bookkeeping to reduce the number of characters sent to the terminal.

Example of usage:

	out := VTermOutputDriver stdout.
	out << 'normal text'.
	out lf.
	'red text' do: [ :c | out color256: Color red. out << c ].
	out lf.
	'bold text' do: [ :c | out bold. out << c ].
	out clear.
	out lf.!
!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
color: aColor
	currentColor := aColor.
	self colorEscape.! !

!VTermOutputDriver methodsFor: 'writing' stamp: ''!
lf
	outStream lf! !

!VTermOutputDriver methodsFor: 'accessing' stamp: ''!
columns
	^ termcap getnum: 'co'! !

!VTermOutputDriver methodsFor: 'highlighting' stamp: ''!
bold
	" double bright mode "
	self termcap: 'md'! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
here
	self flag: #todo. "use termcap here"
	self csiEscape.
	outStream nextPut: $E! !

!VTermOutputDriver methodsFor: 'accessing' stamp: ''!
outStream
	^ outStream! !

!VTermOutputDriver methodsFor: 'highlighting' stamp: ''!
underlineOff
	self termcap: 'ue'! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
yellow: aString
	self yellow; << aString; flush; clear.! !

!VTermOutputDriver methodsFor: 'removing' stamp: ''!
clearFromBeginning
	self termcap: 'cb'! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
red
	self color: 31.! !

!VTermOutputDriver methodsFor: 'removing' stamp: ''!
deleteLine
	self termcap: 'dl'! !

!VTermOutputDriver methodsFor: 'highlighting' stamp: ''!
blinking
	self termcap: 'mb'! !

!VTermOutputDriver methodsFor: 'mode' stamp: ''!
endInsertMode
	self termcap: 'ei'! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
green: aString
	self green; << aString; flush; clear.! !

!VTermOutputDriver methodsFor: 'highlighting' stamp: ''!
underline
	self termcap: 'us'! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
home
	self termcap: 'ho'! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
up
	self termcap: 'up'! !

!VTermOutputDriver methodsFor: 'writing' stamp: ''!
overwrite: char
	self flag: #TODO. "properly implement this"
	outStream nextPut: char! !

!VTermOutputDriver methodsFor: 'cursor' stamp: ''!
cursorNormal
	self termcap: 've'! !

!VTermOutputDriver methodsFor: 'escaping' stamp: ''!
escape
	outStream nextPut: Character escape! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
right: distance
	distance < 0
		ifTrue: [ 0 - distance timesRepeat: [ self left ]]
		ifFalse: [ distance timesRepeat: [ self right ]].! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
blue
	self color: 34.! !

!VTermOutputDriver methodsFor: 'escaping' stamp: ''!
colorEscape
	self csiEscape.
	blink ifTrue: [ outStream nextPutAll: '5;' ].
	outStream print: currentColor.
	(currentBackground == 0) ifFalse: [
		outStream nextPut: $;; print: currentBackground ].
	outStream nextPut: $m.! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
black
	self color: 30.! !

!VTermOutputDriver methodsFor: 'initialization' stamp: ''!
initialize 
	super initialize.
	termcap := Termcap new.
	self reset.! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
light
	light := true.! !

!VTermOutputDriver methodsFor: 'accessing' stamp: ''!
width
	^ self columns! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
green
	self color: 32.! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
up: distance
	distance < 0
		ifTrue: [ 0 - distance timesRepeat: [ self down ]]
		ifFalse: [ distance timesRepeat: [ self up ]].! !

!VTermOutputDriver methodsFor: 'testing' stamp: ''!
closed
	^ outStream isNil or: [ outStream closed ]! !

!VTermOutputDriver methodsFor: 'removing' stamp: ''!
clearScreen
	self termcap: 'cl'! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
left
	self termcap:  'le'! !

!VTermOutputDriver methodsFor: 'removing' stamp: ''!
clearToEnd
	self termcap: 'ce'! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
topLeft
	self termcap: 'ho'! !

!VTermOutputDriver methodsFor: 'accessing' stamp: ''!
outStream: stream
	outStream := stream.! !

!VTermOutputDriver methodsFor: 'removing' stamp: ''!
deleteCharacter
	self termcap: 'dc'! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
black: aString
	self black; << aString; flush; clear.! !

!VTermOutputDriver methodsFor: 'accessing' stamp: ''!
clear
	self reset.
	self colorEscape.! !

!VTermOutputDriver methodsFor: 'removing' stamp: ''!
backspace
	outStream nextPut: Character backspace.
	self deleteCharacter ! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
blue: aString
	self blue; << aString; flush; clear.! !

!VTermOutputDriver methodsFor: 'cursor' stamp: ''!
cursorEnhanced
	self termcap: 'vs'! !

!VTermOutputDriver methodsFor: 'accessing' stamp: ''!
lines
	^ termcap getnum: 'li'! !

!VTermOutputDriver methodsFor: 'highlighting' stamp: ''!
invisible
	self termcap: 'mk'! !

!VTermOutputDriver methodsFor: 'printing' stamp: ''!
print: anObject 
	outStream print: anObject! !

!VTermOutputDriver methodsFor: 'scrolling' stamp: ''!
scrollBackward
	self termcap: 'sr'! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
left: distance
	distance < 0
		ifTrue: [ 0 - distance timesRepeat: [ self right ]]
		ifFalse: [ distance timesRepeat: [ self left ]].! !

!VTermOutputDriver methodsFor: 'highlighting' stamp: ''!
reverse
	self termcap: 'mr'! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
white
	self color: 37.! !

!VTermOutputDriver methodsFor: '*System-CommandLine-TextSupport' stamp: ''!
background256: aColor
	"output an xterm 256 color extension sequence"
	self color256: aColor background: true! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
pink
	self color: 35.! !

!VTermOutputDriver methodsFor: 'printing' stamp: ''!
store: anObject 
	outStream store: anObject! !

!VTermOutputDriver methodsFor: '*System-CommandLine-TextSupport' stamp: ''!
color256: aColor background: isBackground
	"use the resources for colors 0-15 - usually more-or-less a reproduction of the standard ANSI colors, but possibly more pleasing shades
	colors 16-231 are a 6x6x6 color cube
	colors 232-255 are a grayscale ramp, intentionally leaving out black and white"
	
	self csiEscape.

	outStream nextPutAll: (isBackground 
		ifFalse: [ '38;5;' ]
		ifTrue:  [ '48;5;' ]).
		
	outStream 
		print: aColor closestXTermPixelValue;
		nextPut: $m.! !

!VTermOutputDriver methodsFor: 'highlighting' stamp: ''!
normal
	self termcap: 'me'! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
startOfLine
	^ self cr! !

!VTermOutputDriver methodsFor: 'writing' stamp: ''!
tab
	outStream tab! !

!VTermOutputDriver methodsFor: 'printing' stamp: ''!
nextPut: aCharacter 
	outStream nextPut: aCharacter.! !

!VTermOutputDriver methodsFor: 'accessing' stamp: ''!
termcap
	^ termcap! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
down
	self termcap: 'do'! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
saveCursor
	outStream nextPutAll: (termcap getstr: 'sc')! !

!VTermOutputDriver methodsFor: 'private' stamp: ''!
termcap: termcapCapabilityIdentifier
	"Output the termcap command sequence for the identifier.
	Use #basicNextPutAll: to avoid possible conversions applied by the stream"
	outStream basicNextPutAll: (termcap getstr: termcapCapabilityIdentifier)! !

!VTermOutputDriver methodsFor: '*System-CommandLine-TextSupport' stamp: ''!
color256: aColor
	"output an xterm 256 color extension sequence."
	self color256: aColor background: false! !

!VTermOutputDriver methodsFor: 'writing' stamp: ''!
flush
	outStream flush.! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
cyan: aString
	self cyan; << aString; flush; clear.! !

!VTermOutputDriver methodsFor: 'initialization' stamp: ''!
reset
	currentColor := 0.
	currentBackground := 0.
	light := false.
	blink := false.! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
cyan
	self color: 36.! !

!VTermOutputDriver methodsFor: 'escaping' stamp: ''!
ss3Escape
	"Control Sequence Introducer escape"
	outStream nextPut: Character escape; nextPut: $O! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
red: aString
	self red; << aString; flush; clear.! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
right
	self termcap: 'nd'! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
errorColor 
	self red! !

!VTermOutputDriver methodsFor: 'escaping' stamp: ''!
csiEscape
	"Control Sequence Introducer escape"
	outStream nextPut: Character escape; nextPut: $[! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
pink: aString
	self pink; nextPutAll: aString; flush; clear.! !

!VTermOutputDriver methodsFor: 'inserting' stamp: ''!
insertCharacter
	self termcap:  'ic'! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
restoreCursor
	self termcap: 'rc'! !

!VTermOutputDriver methodsFor: 'mode' stamp: ''!
insertMode
	self termcap: 'im'! !

!VTermOutputDriver methodsFor: 'removing' stamp: ''!
erase
	"outStream nextPutAll:
		(termcap parm: '1' in:
			(termcap getstr: 'ec'))"
	self shouldBeImplemented.! !

!VTermOutputDriver methodsFor: 'writing' stamp: ''!
space
	outStream space! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
white: aString
	self white; << aString; flush; clear.! !

!VTermOutputDriver methodsFor: 'writing' stamp: ''!
<< aStringOrCharacter
	aStringOrCharacter putOn: outStream.! !

!VTermOutputDriver methodsFor: 'cursor' stamp: ''!
cursorInvisible
	self termcap: 'vi'! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
down: distance
	distance < 0
		ifTrue: [ 0 - distance timesRepeat: [ self up ]]
		ifFalse: [ distance timesRepeat: [ self down ]].! !

!VTermOutputDriver methodsFor: 'inserting' stamp: ''!
insertLine
	self termcap: 'al'.
	self lf! !

!VTermOutputDriver methodsFor: 'scrolling' stamp: ''!
scrollForward
	self termcap: 'sf'! !

!VTermOutputDriver methodsFor: 'printing' stamp: ''!
nextPutAll: aString
	outStream nextPutAll: aString! !

!VTermOutputDriver methodsFor: 'coloring' stamp: ''!
yellow
	self color: 33.! !

!VTermOutputDriver methodsFor: 'navigating' stamp: ''!
cr
	self termcap: 'cr'! !

!VTermOutputDriver class methodsFor: 'instance creation' stamp: ''!
on: anOutputStream
	^ self new
		outStream: (ZnNewLineWriterStream on:
			(ZnCharacterWriteStream on: anOutputStream encoding: 'utf8'));
		yourself! !

!VTermOutputDriver class methodsFor: 'instance creation' stamp: ''!
stdout
	^ self on: Stdio stdout! !

!VTermOutputDriver class methodsFor: '*System-CommandLine-TextSupport' stamp: ''!
printText: aText
	" Example code shows how to output formatted text"
	| out |

	out := self stdout.

	aText doWithIndex: [ :char :index| 
		aText attributesAt: index do: [ :attr| 
			(attr isKindOf: TextEmphasis )	ifTrue: [ out bold ].
			(attr isKindOf: TextColor )	ifTrue: [ out color256: attr color ]].
		(char = Character cr)
			ifTrue: [ out lf ]
			ifFalse: [ out << char ].
		out clear ].

	out lf.! !

!VTermOutputDriver class methodsFor: 'instance creation' stamp: ''!
stderr
	^ self on: Stdio stderr! !

!VTermOutputFont commentStamp: ''!
I'm the font style of a VTermOutputDriver
I'm characterized by the color of the font that will be printed.!
!VTermOutputFont methodsFor: 'styling' stamp: ''!
setInDriver: aVTermOutputDriver
	aVTermOutputDriver setFontColor: color.! !

!VTermOutputFont methodsFor: 'comparing' stamp: ''!
hash
	^ self color hash! !

!VTermOutputFont methodsFor: 'comparing' stamp: ''!
= aFont

	^self color isVTermDefaultColor and: [ aFont color isVTermDefaultColor ]! !

!VTermOutputStyle commentStamp: ''!
I'm the style of a VTermOutputDriver.
I have a font, a background and a styles and I'm able to modify them to change the color of font (for example) or to add styles
I can't delete my styles, to get a basic VTermOutputStyle you must create a new one.!
!VTermOutputStyle methodsFor: 'styling' stamp: ''!
styles
	^styles! !

!VTermOutputStyle methodsFor: 'comparing' stamp: ''!
= aStyle
	^ (self font = aStyle font and: [ self background = aStyle background ]) and: [ self styles = aStyle styles ]! !

!VTermOutputStyle methodsFor: 'styling' stamp: ''!
addStyle: aString
	self styles add:aString! !

!VTermOutputStyle methodsFor: 'initialization' stamp: ''!
initialize

	styles := Set new.
	font := VTermOutputFont new style: self.
	background := VTermOutputBackground new style: self.! !

!VTermOutputStyle methodsFor: 'accessing' stamp: ''!
font
	
	^ font! !

!VTermOutputStyle methodsFor: 'copying' stamp: ''!
postCopy
	font := self font copy.
	background := self background copy.
	styles :=  self styles copy.! !

!VTermOutputStyle methodsFor: 'styling' stamp: ''!
setInDriver: aVTermOutputDriver
	font setInDriver: aVTermOutputDriver.
	background setInDriver: aVTermOutputDriver.
	self styles do: [ :each | aVTermOutputDriver set: each ].
	aVTermOutputDriver installedStyle: self.
	! !

!VTermOutputStyle methodsFor: 'accessing' stamp: ''!
background
	^ background! !

!VTermOutputStyleElement commentStamp: ''!
I represent a style element of a VTermOutputStyle.
I can change my color!
!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
color: aColor
	"Change the current color of writing"

	color := aColor.! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
red: aString
	"Change the color of writing of aString and set it back to default color afterward"

	self print: aString withColor: Color red! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
blue
	"Change the current color of writing"

	self color: Color blue! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
cyan
	"Change the current color of writing"

	self color: Color cyan! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
black
	"Change the current color of writing"

	self color: Color black! !

!VTermOutputStyleElement methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	color := VTermDefaultColor new! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
white
	"Change the current color of writing"

	self color: Color white! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
green
	"Change the current color of writing"

	self color: Color green! !

!VTermOutputStyleElement methodsFor: 'copying' stamp: ''!
postCopy
	color := self color copy.! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
yellow: aString
	"Change the color of writing of aString and set it back to default color afterward"

	self print: aString withColor: Color yellow! !

!VTermOutputStyleElement methodsFor: 'styling' stamp: ''!
setInDriver: aVTermOutputDriver 
	self subclassResponsibility! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
red
	"Change the current color of writing"

	self color: Color red! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
white: aString
	"Change the color of writing of aString and set it back to default color afterward"

	self print: aString withColor: Color white! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
green: aString
	"Change the color of writing of aString and set it back to default color afterward"

	self print: aString withColor: Color green! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
magenta: aString
	"Change the color of writing of aString and set it back to default color afterward"

	self print: aString withColor: Color magenta! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
black: aString
	"Change the color of writing of aString and set it back to default color afterward"

	self print: aString withColor: Color black! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
blue: aString
	"Change the color of writing of aString and set it back to default color afterward"

	self print: aString withColor: Color blue! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
magenta
	"Change the current color of writing"

	self color: Color magenta! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
cyan: aString
	"Change the color of writing of aString and set it back to default color afterward"

	self print: aString withColor: Color cyan! !

!VTermOutputStyleElement methodsFor: 'text coloring' stamp: ''!
yellow
	"Change the current color of writing"

	self color: Color yellow! !

!VTermOutputStyleElement methodsFor: 'accessing' stamp: ''!
color

	^ color! !

!VTermOutputStyles commentStamp: ''!
I am a SharedPool for the style constants used by VTermOutputDriver!
!VTermOutputStyles class methodsFor: 'class initialization' stamp: ''!
initialize
	ResetStyle := '0m'.
	Bold := '1m'.
	Underline := '4m'.
	Blink := '5m'.
	Reverse := '7m'.
	Standout := '1;7m'.
	InvisibleFont := '8m'

	"Home := 'home'.
	SavePosition := 'sc'.
	RestorePosition := 'rc'.
	MoveLeft := 'cub1'.
	InvisibleCursor := 'civis'.
	VisibleCursor := 'cvvis'.
	ClearToEnd := 'e1'.
	ClearFromBegin := 'el1'.
	ClearWholeLine := 'el2'.
	Dim := 'dim'.
	Underlineoff := 'rmul'.
	ClearScreen := 'clear'"! !

!VTermTestRunner commentStamp: ''!
I am command line test runner. 
I run a TestSuite and outpout the progress in a terminal friendly way with XTerm characters.!
!VTermTestRunner methodsFor: 'private' stamp: ''!
createStdout
	^ VTermOutputDriver stdout! !

!VTermTestRunner methodsFor: 'helper' stamp: ''!
writeError: anError of: aTestCase 
	self stderr red.
	super writeError: anError of: aTestCase! !

!VTermTestRunner methodsFor: 'helper' stamp: ''!
writeFailure: anError of: aTestCase 
	self stderr yellow.
	^ super writeFailure: anError of: aTestCase ! !

!VTermTestRunner methodsFor: 'private' stamp: ''!
createStderr
	^ VTermOutputDriver stderr! !

!VTermTestRunner methodsFor: 'printing' stamp: ''!
printTestCase: aTestCase 
	self stderr 
		startOfLine; clearToEnd; green; 
		print: aTestCase; clear.
	self printProgress.! !

!VTermTestRunner methodsFor: 'helper' stamp: ''!
recordPassOf: aTestCase! !

!VTermTestRunner methodsFor: 'helper' stamp: ''!
print: aLongErrorMesssage short: aShortErrorMesssage of: aTestCase 
	| testCaseString longMessage shortMessage offset cr |
	
	cr := OSPlatform current lineEnding.
	shortMessage := aShortErrorMesssage ifNil: [ '' ].
	longMessage := aLongErrorMesssage ifNil: [ '' ].
	
	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 - longMessage size.
	offset < 1
		ifTrue: [ 
			self stdout startOfLine; right: (80 - shortMessage size); 
				nextPutAll: shortMessage ]
		ifFalse: [ 
			self stdout right: offset;
				nextPutAll: longMessage ].
		
	self stdout clear.
	self stdout << cr! !

!VTermTestRunner methodsFor: 'printing' stamp: ''!
printProgress
	| string |
	string := '[',currentTest asString, '/', maxTest asString,']'.
	self stderr 
		startOfLine; right: (80 - string size); nextPutAll: string.! !

!ValueAdded commentStamp: ''!
A ValueAdded is an announcement raised when an item (or a collection of items) was added to CollectionValueHolder.!
!ValueAdded methodsFor: 'accessing' stamp: ''!
newValue
	^ newValue! !

!ValueAdded methodsFor: 'accessing' stamp: ''!
newValue: anObject
	newValue := anObject! !

!ValueAdded class methodsFor: 'instance creation' stamp: ''!
newValue: newValue
	^ self new
		newValue: newValue;
		yourself! !

!ValueChanged commentStamp: ''!
A ValueChanged is an announcement raised when a value of a NewValueHolder is changed!
!ValueChanged methodsFor: 'accessing' stamp: 'nil'!
oldValue: anObject
	
	oldValue := anObject! !

!ValueChanged methodsFor: 'accessing' stamp: 'nil'!
newValue

	^ newValue! !

!ValueChanged methodsFor: 'accessing' stamp: 'nil'!
newValue: anObject
	
	newValue := anObject! !

!ValueChanged methodsFor: 'accessing' stamp: 'nil'!
oldValue

	^ oldValue! !

!ValueChanged class methodsFor: 'instance creation' stamp: 'nil'!
oldValue: oldContent newValue: newValue

	^ self new
		newValue: newValue;
		oldValue: oldContent;
		yourself! !

!ValueChanged class methodsFor: 'instance creation' stamp: 'nil'!
newValue: newContents

	^ self new
		newValue: newContents;
		yourself! !

!ValueHolder commentStamp: ''!
A value holder holding a value !
!ValueHolder methodsFor: 'comparing' stamp: ''!
= another

	self species = another species ifFalse: [ ^ false ].
	^ self contents = another contents! !

!ValueHolder methodsFor: 'accessing' stamp: ''!
contents
	^contents! !

!ValueHolder methodsFor: 'accessing' stamp: ''!
contents: newContents
	contents := newContents.
	self changed: #contents! !

!ValueLink commentStamp: ''!
A ValueLink is a Link containing a Value.
Adding an object to a LinkedList which is not a Link will create a ValueLink containing that object.


value - The object this link points to.!
!ValueLink methodsFor: 'accessing' stamp: ''!
value: aValue
	value := aValue! !

!ValueLink methodsFor: 'dispatched' stamp: ''!
asLinkPrepend: anObject

	^ (super asLinkPrepend: anObject)
		  value: anObject;
		  yourself! !

!ValueLink methodsFor: 'comparing' stamp: ''!
= anotherObject
	^self species == anotherObject species 
		and: [self value = anotherObject value 
				and: [self nextLink == anotherObject nextLink]]! !

!ValueLink methodsFor: 'evaluating' stamp: ''!
value
	^value! !

!ValueLink methodsFor: 'comparing' stamp: ''!
hash
	^self value hash bitXor: nextLink identityHash! !

!ValueLink methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: 'ValueLink('.
	value printOn: aStream.
	aStream nextPut: $)! !

!ValueLink class methodsFor: 'instance creation' stamp: ''!
value:	 aValue
	^self new value: aValue! !

!ValueLinkForTesting commentStamp: ''!
I am a variant of `ValueLink` to show the behavior of `Object>>#~~>`.

In particular, I will be used to test expressions of the form `a ~~> b` 
that create a link (with `a` as value) of the same class of the link `b`, 
so I don't introduce any new methods but provide myself to check that newly 
created links keep the class of the chain we are pushing on.!
!ValueLinkTest commentStamp: ''!
A ValueLinkTest is a test class for testing the behavior of ValueLink!
!ValueLinkTest methodsFor: 'tests' stamp: ''!
testPushingOnValueLinks

	| link link1 link2 link3 |
	link := 3 ~~> nil.
	link1 := 5 ~~> link.
	link2 := ValueLinkForTesting new
		         value: 8;
		         nextLink: link1;
		         yourself.
	link3 := link1 value + link2 value ~~> link2.

	self
		assert: link3 value equals: 13;
		assert: link3 class equals: ValueLinkForTesting;
		assert: link3 nextLink value equals: 8;
		assert: link3 nextLink class equals: ValueLinkForTesting;
		assert: link3 nextLink nextLink value equals: 5;
		assert: link3 nextLink nextLink class equals: ValueLink;
		assert: link3 nextLink nextLink nextLink value equals: 3;
		assert: link3 nextLink nextLink nextLink class equals: ValueLink;
		assert: link3 nextLink nextLink nextLink nextLink equals: nil! !

!ValueLinkTest methodsFor: 'tests' stamp: ''!
testPushingOnObjects

	| link o |
	o := Object new.
	link := 3 ~~> (#aSymbol ~~> o).

	self
		assert: link value equals: 3;
		assert: link nextLink value equals: #aSymbol;
		assert: link nextLink nextLink value equals: o;
		assert: link nextLink nextLink nextLink equals: nil! !

!ValueLinkTest methodsFor: 'tests' stamp: ''!
testNilAsLink

	self assert: nil asLink equals: (ValueLink value: nil)! !

!ValueNotFound commentStamp: ''!
I am ValueNotFound, an exception indicating that a value was not found in a Dictionary.!
!ValueNotFound methodsFor: 'accessing' stamp: ''!
value: aValue
	^ self object: aValue! !

!ValueNotFound methodsFor: 'private' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		stream << 'value '.
		stream print: self object.
		stream << ' not found in '.
		stream print: self collection class]! !

!ValueNotFound methodsFor: 'accessing' stamp: ''!
value
	^ self object! !

!ValueRemoved commentStamp: ''!
A ValueRemoved  is an announcement raised when an item (or a collection of items) was removed from CollectionValueHolder.!
!ValueRemoved methodsFor: 'accessing' stamp: ''!
oldValue: anObject
	oldValue := anObject! !

!ValueRemoved methodsFor: 'accessing' stamp: ''!
oldValue
	^ oldValue! !

!ValueRemoved class methodsFor: 'instance creation' stamp: ''!
oldValue: oldValue
	^ self new
		oldValue: oldValue;
		yourself! !

!ValueWithinFixTest commentStamp: ''!
SUnit tests for a fix on #valueWithin:!
!ValueWithinFixTest methodsFor: 'tests' stamp: ''!
valueWithinNonLocalReturn
	"Do a non-local return from a valueWithin: block"
	[^self] valueWithin: 20 milliSeconds onTimeout:[].! !

!ValueWithinFixTest methodsFor: 'tests' stamp: ''!
testValueWithinTimingNestedOuter
	"Test nested timing of valueWithin:onTimeout:"
	| time |
	time := [
		[
			3 timesRepeat: [
				[5 seconds asDelay wait]
					valueWithin: 100 milliSeconds onTimeout: []]
		] valueWithin: 150 milliSeconds onTimeout: []
	] durationToRun.
	self assert: time > 100 milliSeconds.
	self assert: time < 5000 milliSeconds.! !

!ValueWithinFixTest methodsFor: 'tests' stamp: ''!
testValueWithinTimingBasic
	"Test timing of valueWithin:onTimeout:"
	| time |
	time := [
		[1000 milliSeconds asDelay wait]
			valueWithin: 100 milliSeconds onTimeout: []
	] durationToRun.
	self assert: time < 1000 milliSeconds.! !

!ValueWithinFixTest methodsFor: 'tests' stamp: ''!
testValueWithinNonLocalReturnFixReal
	"The real test for the fix is just as obscure as the original problem"
	
	| startTime |
	self valueWithinNonLocalReturn.
	startTime := Time millisecondClockValue.
	[[] repeat] valueWithin: 100 milliSeconds onTimeout:[ | deltaTime |
		"This *should* timeout after 100 msecs but the pending process from
		the previous invokation will signal timeout after 20 msecs already
		which will in turn cut this invokation short."
		deltaTime := Time millisecondClockValue - startTime.
		self deny: deltaTime < 90.
	].! !

!ValueWithinFixTest methodsFor: 'tests' stamp: ''!
testValueWithinTimingRepeat
	"Test timing of valueWithin:onTimeout:"
	| time |
	time := [
		3 timesRepeat: [
			[500 milliSeconds asDelay wait]
				valueWithin: 100 milliSeconds onTimeout: []]
	] durationToRun.
	self assert: time < 500 milliSeconds.! !

!ValueWithinFixTest methodsFor: 'tests' stamp: ''!
testValueWithinNonLocalReturnFixSimply
	"The simple version to test the fix"

	self valueWithinNonLocalReturn.
	(Delay forMilliseconds: 50) wait! !

!ValueWithinFixTest methodsFor: 'tests' stamp: ''!
testValueWithinTimingNestedInner
	"Test nested timing of valueWithin:onTimeout:"
	| time |
	time := [
		[
			[5 seconds asDelay wait]
				valueWithin: 100 milliSeconds onTimeout: []
		] valueWithin: 500 milliSeconds onTimeout: []
	] durationToRun.
	self assert: time < 500 milliSeconds.! !

!Variable commentStamp: ''!
I am an abstract class. Subclasses of me model meta objects for any kind of variables: 

- slots (instance variables)
- literal variables (Class, Global, Pool) and 
- local variables of methods (temps and args). 

Being a superclass for LiteralVariable I have a restriction on my layout: I can only have a single instance variable representing the variable #name
								DO NOT ADD ANY NEW STATE TO ME.

This restriction is required because LiteralVariable encodes global references in the method literals and therefore there is an expectation from the VM on particular shape of these objects.

At this step I only pulled a duplicated protocol of properties from my subclasses. But more cleanup is comming:
- breakpoints
- metalinks
- queries
- refactoring commands

Internal Representation and Key Implementation Points.

Instance Variables
	name:		<Symbol>!
!Variable methodsFor: 'properties' stamp: ''!
propertyAt: propName
	^ self
		propertyAt: propName
		ifAbsent: [ nil ]! !

!Variable methodsFor: 'properties' stamp: ''!
removeProperty: propName ifAbsent: aBlock
	| property |
	self properties ifNil: [^aBlock value].
	property := self properties
		removeKey: propName
		ifAbsent: aBlock.
	self removePropertiesIfEmpty.
	^ property! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
preambles
	^ self propertyAt: #preambles ifAbsent: #()! !

!Variable methodsFor: 'comparing' stamp: ''!
hash
	"Every subclass that adds state must redefine this method"
	^ self species hash bitXor: self name hash! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
accessingNodesFor: option
	option = #write
		ifTrue: [ ^ self assignmentNodes ].
	option = #read
		ifTrue: [ ^ self  readNodes ].
	"else we return all accessing nodes"
	^ self accessingNodes! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
afterLinks
	^ self links select: [ :each | each control == #after ]! !

!Variable methodsFor: 'debugging' stamp: ''!
write: aValue inContext: aContext
	"write the value in aContext. All #write:inContext: methods need to return the assigned value,
	as this is the reflective version of assignment which has the assigned value as a value"
	^self subclassResponsibility! !

!Variable methodsFor: 'properties' stamp: ''!
propertyAt: propName put: propValue
	^ self ensureProperties
		at: propName
		put: propValue! !

!Variable methodsFor: '*OpalCompiler-Core' stamp: ''!
analyzeWrite: aVariableNode by: aSemanticAnalyzer 

	self isReservedVariable ifTrue: [ aSemanticAnalyzer storeIntoReservedVariable: aVariableNode ].
	
	self isWritable ifFalse: [ aSemanticAnalyzer storeIntoReadOnlyVariable: aVariableNode ]! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
afterHooks
	^self propertyAt: #afterHooks ifAbsent: #()! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
postambles
	^ self propertyAt: #postambles ifAbsent: #()! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
hasMetalinkInstead
	self hasMetalink
		ifFalse: [ ^ false ].
	^ self insteadLinks isNotEmpty! !

!Variable methodsFor: 'testing' stamp: ''!
isLocalVariable
	"temporary variables and arguments are local variables"
	^false! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
link: aMetaLink
	(aMetaLink checkForCompatibilityWith: self) ifFalse: [ self error: 'link requests reification that can not be provided by this node' ].
	(self propertyAt: #links ifAbsentPut: [ OrderedCollection new ]) add: aMetaLink.
	aMetaLink installOnVariable: self.
	self clearReflectivityAnnotations.
	self usingMethods do: [ :method |  
		method method installLink: aMetaLink ]! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
clearReflectivityAnnotations
	self removeProperty: #preambles ifAbsent: [ ].
	self removeProperty: #beforeHooks ifAbsent: [ ].
	self removeProperty: #afterHooks ifAbsent: [ ].
	self removeProperty: #insteadHooks ifAbsent: [ ].! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
astNodes
	"by default we search the usingMethods for all AST nodes"
	^self usingMethods flatCollect: [ :method | 
		method variableNodes select: [: each| each variable == self ]]! !

!Variable methodsFor: '*NewTools-Inspector-Extensions' stamp: ''!
inspectionUsingMethods
	<inspectorPresentationOrder: 920 title: 'Using Methods'>
	
	| usingMethods |
	usingMethods := self usingMethods sort: [ :x :y | x name < y name ].

	^ SpTreeTablePresenter new
		  roots: usingMethods;
		  addColumn: (SpStringTableColumn title: 'Using Methods' evaluated: #name)! !

!Variable methodsFor: 'testing' stamp: ''!
isUndeclaredVariable

	^ false! !

!Variable methodsFor: 'testing' stamp: ''!
isArgumentVariable
	^false! !

!Variable methodsFor: 'testing' stamp: ''!
isWrittenIn: aCompiledCode
	^aCompiledCode ast variableWriteNodes
		anySatisfy: [ :node | node binding == self ]! !

!Variable methodsFor: '*OpalCompiler-Core' stamp: ''!
analyzeRead: aVariableNode by: aSemanticAnalyzer

	self isUninitialized ifTrue: [ aSemanticAnalyzer uninitializedVariable: aVariableNode ]! !

!Variable methodsFor: 'testing' stamp: ''!
isDefinedByBlock
	"true if a variable node is defined by a block"
	^false! !

!Variable methodsFor: 'properties' stamp: ''!
removePropertiesIfEmpty
	^ Properties at: self ifPresent: [ :dict |
		dict ifEmpty: [ Properties removeKey: self ] ]! !

!Variable methodsFor: 'properties' stamp: ''!
ensureProperties
	^ Properties at: self ifAbsentPut: WeakKeyDictionary new! !

!Variable methodsFor: 'testing' stamp: ''!
needsFullDefinition
	"all but InstanceVariableSlot and ClassVariable need to print the full definition"
	^true! !

!Variable methodsFor: 'visiting' stamp: ''!
acceptVisitor: aProgramNodeVisitor node: aNode
	^ aProgramNodeVisitor visitVariableNode: aNode! !

!Variable methodsFor: 'testing' stamp: ''!
isThisContextVariable
	^false! !

!Variable methodsFor: 'debugging' stamp: ''!
readInContext: aContext
	self subclassResponsibility! !

!Variable methodsFor: 'properties' stamp: ''!
removeProperty: propName
	^ self
		removeProperty: propName
		ifAbsent: [ nil ]! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
assignmentNodes
	^self astNodes 
		select: [ :each | each isWrite ] 
		thenCollect: [ :each | each parent ]! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
hasMetalink
	^ self hasProperty: #links! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
invalidate
	self usingMethods do: [:method | method invalidate].! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
readNodes
	^ self astNodes select: [ :each | each isRead ]! !

!Variable methodsFor: 'converting' stamp: ''!
asDoItVariableFrom: aContext
	"Specific kind of variables may require special logic to be visible in DoIt expressions.
	For example local variables can't be accessed directly in DoIt expressions in the debugger:
		- DoIt is executed using new process where there are no temps from the original context.
	In such cases subclasses should return adapter variable here to represent receiver in DoIt method.
	DoItVariable class is implemented with this purpose (see the class comment and tests)"
	^ self! !

!Variable methodsFor: 'queries' stamp: ''!
definingNode
	^ nil! !

!Variable methodsFor: 'testing' stamp: ''!
isInstanceVariable
	"check if the var is an instance variable (a Slot)"
	^false! !

!Variable methodsFor: 'testing' stamp: ''!
isPoolVariable
	^ false! !

!Variable methodsFor: 'testing' stamp: ''!
isSuperVariable
	^false! !

!Variable methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder

	self subclassResponsibility! !

!Variable methodsFor: 'testing' stamp: ''!
isSelfOrSuperVariable
	^ self isSelfVariable or: [ self isSuperVariable ]! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
insteadLinks
	^ self links select: [ :each | each control == #instead ]! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
availableReifications
	^RFReification subclasses 
		select: [ :e | e entities includesAny: self class withAllSuperclasses ]
		thenCollect: #key! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
accessingNodes
	"return all reads and all assignments. This is different to #astNodes, which returns 
	variable nodes in case of assignment, not the assignment itself"
	^ self readNodes, self assignmentNodes! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
links
	^self propertyAt: #links ifAbsent: #()! !

!Variable methodsFor: 'comparing' stamp: ''!
= other
	"Every subclass that adds state must redefine this method"
	self == other
		ifTrue: [ ^ true ].
	^ (self species == other species) 
			and: [ name = other name ]! !

!Variable methodsFor: 'testing' stamp: ''!
isClassVariable
	^ false! !

!Variable methodsFor: 'testing' stamp: ''!
isReadIn: aCompiledCode
	^aCompiledCode ast readNodes
		 anySatisfy: [ :node | node binding == self ]! !

!Variable methodsFor: 'testing' stamp: ''!
isWorkspaceVariable
	^ false! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
hasMetalinkAfter
	self hasMetalink
		ifFalse: [ ^ false ].
	^ self afterLinks isNotEmpty! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
removeLink: aMetaLink
	"The order of operations here is critical.
	When link is removed from the method it is recompiled. But recompilation needs to look into links here in order to keep available links in the new method instance. 
	Therefore it is important to first remove the given link from the variable list and only then remove it from using methods. Otherwise the method recompilation will keep removed link in the method bytecode"	
	self links remove: aMetaLink.
	self usingMethods do: [:method | method removeLink: aMetaLink].
	
	self links ifEmpty: [ self removeProperty: #links ].
	self clearReflectivityAnnotations.! !

!Variable methodsFor: 'testing' stamp: ''!
isSelfVariable
	^false! !

!Variable methodsFor: 'testing' stamp: ''!
isUsed 
	^ self isReferenced! !

!Variable methodsFor: 'testing' stamp: ''!
isTempVariable
	^false! !

!Variable methodsFor: 'testing' stamp: ''!
isAccessedIn: aMethod
	^self usingMethods includes: aMethod! !

!Variable methodsFor: 'testing' stamp: ''!
isUninitialized

	^ false! !

!Variable methodsFor: 'accessing' stamp: ''!
name: aSymbol
	name := aSymbol! !

!Variable methodsFor: 'properties' stamp: ''!
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 ]! !

!Variable methodsFor: 'properties' stamp: ''!
propertyAt: propName ifAbsent: aBlock
	self properties ifNil: [^aBlock value].
	^ self properties
		at: propName
		ifAbsent: aBlock! !

!Variable methodsFor: 'properties' stamp: ''!
hasProperty: aKey
	"Test if the property aKey is present."
	^self properties 
		ifNil: [false]
		ifNotNil: [:prop | prop includesKey: aKey]! !

!Variable methodsFor: 'testing' stamp: ''!
isLiteralVariable
	"returns true for Global Variables, Class Variables and some others 
	(e.g. Workspace bindings and Undeclared variables, see subclasses)"
	^false! !

!Variable methodsFor: 'testing' stamp: ''!
isReferenced
	^ self usingMethods isNotEmpty! !

!Variable methodsFor: 'queries' stamp: ''!
usingMethods
	self subclassResponsibility! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
beforeLinks
	^ self links select: [ :each | each control == #before ]! !

!Variable methodsFor: 'testing' stamp: ''!
allowsShadowing
	^false! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
insteadHooks
	^self propertyAt: #insteadHooks ifAbsent: #()! !

!Variable methodsFor: 'testing' stamp: ''!
isShadowing
	"I shadow a variable if looking up my name in the outer scope returns a variable"
	^(self scope outerScope ifNotNil: [:outer | outer lookupVar: self name]) notNil! !

!Variable methodsFor: 'properties' stamp: ''!
properties
	^ Properties at: self ifAbsent: nil! !

!Variable methodsFor: 'accessing' stamp: ''!
name
	^ name! !

!Variable methodsFor: 'testing' stamp: ''!
isReservedVariable
	"thisContext, super, self are reserved variables (true, false and nil are literals)"
	^false! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
beforeHooks
	^self propertyAt: #beforeHooks ifAbsentPut: OrderedCollection new! !

!Variable methodsFor: '*Reflectivity' stamp: ''!
hasMetalinkBefore
	self hasMetalink ifFalse: [ ^ false ].
	^ self beforeLinks isNotEmpty! !

!Variable methodsFor: 'testing' stamp: ''!
isWritable
	^ true! !

!Variable methodsFor: 'testing' stamp: ''!
isGlobalVariable
	^ false! !

!Variable methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder

	self subclassResponsibility! !

!Variable methodsFor: 'accessing' stamp: ''!
scope
	^self subclassResponsibility! !

!Variable class methodsFor: 'class initialization' stamp: ''!
initialize
	Properties := Properties
		ifNil: [ WeakIdentityKeyDictionary new. ]
		ifNotNil: [ (WeakIdentityKeyDictionary newFrom: Properties) rehash]! !

!Variable class methodsFor: 'instance creation' stamp: ''!
named: aSymbol
	self checkValidName: aSymbol.
	^ self new
		name: aSymbol;
		yourself! !

!Variable class methodsFor: 'validating' stamp: ''!
checkValidName: aString! !

!Variable class methodsFor: 'testing' stamp: ''!
isAbstract 
	^self = Variable! !

!VariableBreakpoint commentStamp: ''!
I am a breakpoint installed on one or more instance variables of a class or of an object.!
!VariableBreakpoint methodsFor: 'accessing' stamp: ''!
accessStrategy: anObject
	accessStrategy := anObject! !

!VariableBreakpoint methodsFor: '*NewTools-Debugger-Breakpoints-Tools' stamp: ''!
scopeIncludes: anObject

	| classScope |
	self isObjectCentric ifTrue: [ ^ targetInstance == anObject ].
	classScope := targetClassOrMethod isCompiledMethod
		              ifTrue: [ targetClassOrMethod methodClass ]
		              ifFalse: [ targetClassOrMethod ].
	^ classScope = anObject class! !

!VariableBreakpoint methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	accessStrategy := #all.
	targetVariableNames := OrderedCollection new.
	isInstalled := false! !

!VariableBreakpoint methodsFor: '*NewTools-Debugger-Breakpoints-Tools' stamp: ''!
printContentsForBreakpointInspection

	| str |

	str := WriteStream on: String new.
	str << self class name.
	str cr.
	str << '"Break on'.
	str space.
	self isObjectCentric ifTrue: [ 
		str << 'self'.
		str space ].
	str << accessStrategy asString.
	str space.
	str << 'accesses to:"'.

	str cr.

	self targetVariableNames do: [ :varName | 
		str << varName asString.
		str << '.'.
		str space ].

	^ str contents! !

!VariableBreakpoint methodsFor: 'accessing' stamp: ''!
targetVariableNames: anObject
	targetVariableNames := anObject! !

!VariableBreakpoint methodsFor: 'install' stamp: ''!
install
	self isInstalled
		ifTrue: [ ^ self ].
	targetVariableNames
		do: [ :vName | 
			targetClassOrMethod
				link: self link
				toVariableNamed: vName
				option: self accessStrategy ].
	isInstalled := true.
	self setAsNodeProperty.
	self class addBreakpoint: self.! !

!VariableBreakpoint methodsFor: 'api' stamp: ''!
scopeTo: anInstance
	super scopeTo: anInstance.
	self condition: [ :ctx | ctx receiver == targetInstance ]! !

!VariableBreakpoint methodsFor: 'accessing' stamp: ''!
targetVariableNames
	^ targetVariableNames! !

!VariableBreakpoint methodsFor: 'install' stamp: ''!
breakLink

	^ super breakLink
		  control: #after;
		  yourself! !

!VariableBreakpoint methodsFor: 'testing' stamp: ''!
isInstalled
	^isInstalled! !

!VariableBreakpoint methodsFor: 'removing' stamp: ''!
removeFromClass: aClass

	"If we're targeting a temp var in a method,
	then we got here because we detected that method belong to the class
	passed as parameter. We need to uninstall."
	self targetClassOrMethod isCompiledMethod ifTrue: [ 
		self remove.
		^ self ].

	"If the removed class is the class we target or one of its superclasses,
	then after that class is removed we have no reason to exist. We need to uninstall."
	(self targetClassOrMethod = aClass or: [ 
		 self targetClassOrMethod allSuperclasses includes: aClass ]) 
		ifTrue: [ 
			self remove.
			^ self ].

	"We removed a aClass, but it is not our target class nor one of its superclasses.
	It is then one of its subclasses, we can continue to exist since the variable
	we target still exist in the target class.
	However, we need to remove the nodes of the removed class from our metalink"
	(self link nodes select: [ :n | n methodNode methodClass == aClass ]) 
		do: [ :n | self link removeNode: n ]! !

!VariableBreakpoint methodsFor: '*NewTools-Debugger-Breakpoints-Tools' stamp: ''!
printTargetForBreakpointInspection

	| str |
	str := WriteStream on: String new.
	str << accessStrategy asString.
	str space.
	str << 'accesses to'.
	str space.
	str << (targetClassOrMethod isCompiledMethod
		 ifTrue: [ 'temp' ]
		 ifFalse: [ 'inst' ]).
	str space.
	str << 'var(s):'.
	str space.
	self targetVariableNames do: [ :name | 
		str nextPutAll: name.
		str space ].
	^ str contents! !

!VariableBreakpoint methodsFor: 'removing' stamp: ''!
removeFromNodeProperty
	 self link nodes do: [ :n | n removeBreakpoint: self ]! !

!VariableBreakpoint methodsFor: 'install' stamp: ''!
setAsNodeProperty
	 self link nodes do: [ :n | n addBreakpoint: self ]! !

!VariableBreakpoint methodsFor: 'removing' stamp: ''!
removeFromMethod: aMethod
	(self link nodes select: [ :n | n methodNode method == aMethod ]) 
		do: [ :n | self link removeNode: n ]! !

!VariableBreakpoint methodsFor: 'removing' stamp: ''!
remove
	super remove.
	targetInstance := nil.
	isInstalled := false! !

!VariableBreakpoint methodsFor: '*NewTools-Debugger-Breakpoints-Tools' stamp: ''!
asBreakpointInspectionItemIn: aStBreakpointInspectionItem 
	^aStBreakpointInspectionItem buildVariableBreakpointItemFor: self! !

!VariableBreakpoint methodsFor: 'accessing' stamp: ''!
accessStrategy
	^ accessStrategy! !

!VariableBreakpoint methodsFor: 'testing' stamp: ''!
isVariableBreakpoint
	^true! !

!VariableBreakpoint methodsFor: 'accessing' stamp: ''!
targetClassOrMethod
	^ targetClassOrMethod! !

!VariableBreakpoint methodsFor: 'accessing' stamp: ''!
targetClassOrMethod: anObject
	targetClassOrMethod := anObject! !

!VariableBreakpoint class methodsFor: 'API' stamp: ''!
watchVariablesReadsInClass: aClass
	^ (self newForClass: aClass)
		accessStrategy: #read;
		install! !

!VariableBreakpoint class methodsFor: 'instance creation' stamp: ''!
newBreakpointForVariable: aVariableName forMethod: aCompiledMethod
	^ self new
		targetClassOrMethod: aCompiledMethod;
		targetVariableNames: (OrderedCollection with: aVariableName)! !

!VariableBreakpoint class methodsFor: 'API' stamp: ''!
watchVariablesWritesInClass: aClass
	^ (self newForClass: aClass)
		accessStrategy: #write;
		install! !

!VariableBreakpoint class methodsFor: 'API' stamp: ''!
watchVariableWrites: aVariableName inClass: aClassOrCompiledMethod
	^ (aClassOrCompiledMethod newBreakpointForVariable: aVariableName)
		accessStrategy: #write;
		install! !

!VariableBreakpoint class methodsFor: 'API - object-centric' stamp: ''!
watchVariablesInObject: anObject
	^ (self newForClass: anObject class)
		scopeTo: anObject;
		install! !

!VariableBreakpoint class methodsFor: 'API - object-centric' stamp: ''!
watchVariablesReadsInObject: anObject
	^ (self newForClass: anObject class)
		accessStrategy: #read;
		scopeTo: anObject;
		install! !

!VariableBreakpoint class methodsFor: 'API' stamp: ''!
watchVariablesInClass: aClass
	^ (self newForClass: aClass) install! !

!VariableBreakpoint class methodsFor: 'API' stamp: ''!
watchVariable: aVariableName inClass: aClassOrCompiledMethod
	^ (aClassOrCompiledMethod newBreakpointForVariable: aVariableName)
		install! !

!VariableBreakpoint class methodsFor: 'instance creation' stamp: ''!
newBreakpointForVariable: aVariableName inClass: aClass
	^ self new
		targetClassOrMethod: aClass;
		targetVariableNames: (OrderedCollection with: aVariableName)! !

!VariableBreakpoint class methodsFor: 'observers' stamp: ''!
notifyBreakpointHit: aBreakpoint inContext: aContext node: node
	| announcement |	
	announcement := BreakpointHit
		on: aBreakpoint
		nodes: {node}.
	announcement valueOrNil: (node variableValueInContext: aContext).
	SystemAnnouncer uniqueInstance announce: announcement! !

!VariableBreakpoint class methodsFor: 'API' stamp: ''!
watchVariableReads: aVariableName inClass: aClassOrCompiledMethod
	^ (aClassOrCompiledMethod newBreakpointForVariable: aVariableName)
		accessStrategy: #read;
		install! !

!VariableBreakpoint class methodsFor: 'API - object-centric' stamp: ''!
watchVariableReads: aVariableName inObject: anObject
	^ (self newBreakpointForVariable: aVariableName inClass: anObject class)
		accessStrategy: #read;
		scopeTo: anObject;
		install! !

!VariableBreakpoint class methodsFor: 'API - object-centric' stamp: ''!
watchVariable: aVariableName inObject: anObject
	^ (self newBreakpointForVariable: aVariableName inClass: anObject class)
		scopeTo: anObject;
		install! !

!VariableBreakpoint class methodsFor: 'API - object-centric' stamp: ''!
watchVariableWrites: aVariableName inObject: anObject
	^ (self newBreakpointForVariable: aVariableName inClass: anObject class)
		accessStrategy: #write;
		scopeTo: anObject;
		install! !

!VariableBreakpoint class methodsFor: 'private' stamp: ''!
allSlotNamesFor: aClass
	^ aClass allSlots collect: [ :s | s name ]! !

!VariableBreakpoint class methodsFor: 'instance creation' stamp: ''!
newForClass: aClass
	^ self new
		targetClassOrMethod: aClass;
		targetVariableNames: (self allSlotNamesFor: aClass)! !

!VariableBreakpoint class methodsFor: 'API - object-centric' stamp: ''!
watchVariablesWritesInObject: anObject
	^ (self newForClass: anObject class)
		accessStrategy: #write;
		scopeTo: anObject;
		install! !

!VariableBreakpointMockClass commentStamp: ''!
I'm just a class with inst var and accesses to it!
!VariableBreakpointMockClass methodsFor: 'accessing' stamp: ''!
v1
	^ v1! !

!VariableBreakpointMockClass methodsFor: 'initialization' stamp: ''!
initialize
	v1 := 0! !

!VariableBreakpointMockClass methodsFor: 'accessing' stamp: ''!
classVarWrite
	^ClassVar := 1! !

!VariableBreakpointMockClass methodsFor: 'accessing' stamp: ''!
v1: anObject
	v1 := anObject! !

!VariableBreakpointMockClass methodsFor: 'accessing' stamp: ''!
classVarRead
	^ClassVar! !

!VariableBreakpointMockClass methodsFor: 'accessing' stamp: ''!
methodWithTempsAndArg: arg
	| temp |
	temp := arg.
	^ temp ! !

!VariableBreakpointMockSubclass commentStamp: ''!
I have instvar accesses and I have a super class with variables that I access!
!VariableBreakpointMockSubclass methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	v2 := 0! !

!VariableBreakpointMockSubclass methodsFor: 'accessing' stamp: ''!
v2
	^ v2! !

!VariableBreakpointMockSubclass methodsFor: 'accessing' stamp: ''!
instVarWrites
	v1 := 4.
	v2 := 2! !

!VariableBreakpointMockSubclass methodsFor: 'accessing' stamp: ''!
v2: anObject
	v2 := anObject! !

!VariableBreakpointMockSubclass methodsFor: 'accessing' stamp: ''!
instVarReads
	^v1 + v2! !

!VariableBreakpointTest methodsFor: 'tests - class wide watchpoints' stamp: ''!
testWatchVariablesReadsInClass	

	wp := VariableBreakpoint watchVariablesReadsInClass: VariableBreakpointMockSubclass.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #v1 with: #v2).
	self assert: wp targetClassOrMethod identicalTo: VariableBreakpointMockSubclass.
	self assert: wp targetInstance equals: nil.
	
	self assertCollection: wp link nodes asIdentitySet 
			equals: (self allNodes select:[:n| n isVariable]) asIdentitySet.
	
	self shouldnt: [VariableBreakpointMockClass new] raise: Break.
	self should: [obj1 v1] raise: Break.	
	self shouldnt: [obj1 v1: 0] raise: Break.
	self shouldnt: [VariableBreakpointMockSubclass new ] raise: Break.
	self should: [obj2 instVarReads] raise: Break.
	self shouldnt: [obj2 instVarWrites] raise: Break.
	self should: [obj2 v2] raise: Break.	
	self shouldnt: [obj2 v2: 0] raise: Break.
	self should: [obj2 v1] raise: Break.	
	self shouldnt: [obj2 v1: 0] raise: Break.
	! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
nodesForV1InVariableBreakpointMockSubclass
	|nodes |
	nodes := OrderedCollection new.
	nodes add: (VariableBreakpointMockSubclass>>#instVarWrites) ast statements first.
	nodes add: (VariableBreakpointMockSubclass>>#instVarReads) ast statements first value receiver.
	^nodes! !

!VariableBreakpointTest methodsFor: 'tests - installation' stamp: ''!
testAccessStrategy
	
	wp := VariableBreakpoint watchVariablesInClass: VariableBreakpointMockClass.
	self assert: wp accessStrategy equals: #all.
	wp remove.
	
	wp := VariableBreakpoint watchVariable: #v1 inClass: VariableBreakpointMockClass.
	self assert: wp accessStrategy equals: #all.
	wp remove.
	
	wp := VariableBreakpoint watchVariable: #v1 inObject: obj1.
	self assert: wp accessStrategy equals: #all.
	wp remove.
	
	wp := VariableBreakpoint watchVariablesInObject: obj1.	
	self assert: wp accessStrategy equals: #all.
	wp remove.
		
	wp := VariableBreakpoint watchVariableWrites: #v1 inClass: VariableBreakpointMockClass.
	self assert: wp accessStrategy equals: #write.
	wp remove.
	
	wp := VariableBreakpoint watchVariablesWritesInClass: VariableBreakpointMockClass.
	self assert: wp accessStrategy equals: #write.
	wp remove.
	
	wp := VariableBreakpoint watchVariablesWritesInClass: VariableBreakpointMockSubclass.
	self assert: wp accessStrategy equals: #write.
	wp remove.
	
	wp := VariableBreakpoint watchVariableWrites: #v1 inObject: obj1.
	self assert: wp accessStrategy equals: #write.
	wp remove.
	
	wp := VariableBreakpoint watchVariablesReadsInObject: obj1.
	self assert: wp accessStrategy equals: #read.
	wp remove.
	
	wp := VariableBreakpoint watchVariableReads: #v1 inClass: VariableBreakpointMockClass.
	self assert: wp accessStrategy equals: #read.
	wp remove.
	
	wp := VariableBreakpoint watchVariableReads: #v1 inObject: obj1.
	self assert: wp accessStrategy equals: #read.
	wp remove.
	
	wp := VariableBreakpoint watchVariablesReadsInObject: obj1.
	self assert: wp accessStrategy equals: #read.
	wp remove.
	! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
tempReadNodes
	|nodes |
	nodes := OrderedCollection new.
	nodes add: (VariableBreakpointMockClass>>#methodWithTempsAndArg:) ast statements last value.
	^nodes! !

!VariableBreakpointTest methodsFor: 'tests - initialization' stamp: ''!
testInitialize 	
	wp := VariableBreakpoint new.
	self assert: wp accessStrategy equals: #all.
	self assertEmpty: wp targetVariableNames.
	self deny: wp isInstalled! !

!VariableBreakpointTest methodsFor: 'tests - object-centric' stamp: ''!
testWatchVariableWritesInObject 	

	wp := VariableBreakpoint watchVariableWrites: #v1 inObject: obj1.	
	self assert: wp targetInstance equals: obj1.
	self assert: wp accessStrategy equals: #write.
		
	self should: [obj1 v1: 0] raise: Break.
	self shouldnt: [obj1 v1] raise: Break.		
			
	self shouldnt: [VariableBreakpointMockClass new] raise: Break.
	self shouldnt: [obj3 v1] raise: Break.
	self shouldnt: [obj3 v1: 0] raise: Break
	
	
	
	! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
compileTestClass2

	testSubclass := testClass
		                subclass: #VariableBreakpointTestSubclass2
		                instanceVariableNames: ''
		                classVariableNames: ''
		                package: 'Reflectivity-Tests-Breakpoints'.
	testSubclass compile: 'accessingV1 ^v1'! !

!VariableBreakpointTest methodsFor: 'tests - object-centric api' stamp: ''!
testBreakOnWrite
	wp := obj2 haltOnWrite.
	self shouldnt: [ obj2 v1 ] raise: Break.
	self should: [ obj2 v1: 0 ] raise: Break.
	self shouldnt: [ obj2 v2 ] raise: Break.
	self should: [ obj2 v2: 0 ] raise: Break.
	self shouldnt: [ obj4 v1 ] raise: Break.
	self shouldnt: [ obj4 v1: 0 ] raise: Break.
	self shouldnt: [ obj4 v2 ] raise: Break.
	self shouldnt: [ obj4 v2: 0 ] raise: Break.! !

!VariableBreakpointTest methodsFor: 'tests - temp var breakpoints' stamp: ''!
testBreakpointOnArgument
	|method|
	method := (VariableBreakpointMockClass>> #methodWithTempsAndArg:).
	wp := VariableBreakpoint watchVariable: #arg inClass: method.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #arg).
	self assert: wp targetClassOrMethod identicalTo: method.
	self assert: wp targetInstance equals: nil.
	
	self assertCollection: wp link nodes asIdentitySet equals: self argNodes asIdentitySet.	
	self should: [obj1 methodWithTempsAndArg: 42] raise: Break	
	! !

!VariableBreakpointTest methodsFor: 'tests - class var breakpoints' stamp: ''!
testBreakpointOnClassVarAccesses
	|method|
	method := (VariableBreakpointMockClass>> #classVarRead).
	wp := VariableBreakpoint watchVariable: #ClassVar inClass: VariableBreakpointMockClass.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #ClassVar).
	self assert: wp targetClassOrMethod identicalTo: VariableBreakpointMockClass.
	self assert: wp targetInstance equals: nil.
	
	self assertCollection: wp link nodes asIdentitySet equals: (VariableBreakpointMockClass classVariableNamed: #ClassVar) accessingNodes asIdentitySet.
	self should: [obj1 classVarRead] raise: Break.
	self should: [obj1 classVarWrite] raise: Break	! !

!VariableBreakpointTest methodsFor: 'tests - removing' stamp: ''!
testRemoveAfterSuperclassRemoved
	"Removing the class where the target variable of a variable breakpoint is defined should uninstall the variable breakpoint"
	|testClassNodes|
	self compileTestClass.
	self compileTestClass2.
	testClassNodes := (testClass >> #accessingV1) ast allChildren.
	
	wp := VariableBreakpoint watchVariable: #v1 inClass: testClass. 
	wp install.	
	
	self should: [testSubclass basicNew accessingV1] raise: Break.
	
	testClass removeFromSystem.	
	self denyCollection: wp link nodes includesAny: testClassNodes.
	self deny: wp isInstalled.
	self shouldnt: [ testSubclass basicNew accessingV1 ] raise: Break
! !

!VariableBreakpointTest methodsFor: 'tests - object-centric api' stamp: ''!
testBreakOnWriteTo

	wp := obj2 haltOnWriteTo: #v1.
	self shouldnt: [ obj2 v1 ] raise: Break.
	self should: [ obj2 v1: 0 ] raise: Break.
	self shouldnt: [ obj2 v2 ] raise: Break.
	self shouldnt: [ obj2 v2: 0 ] raise: Break.
	self shouldnt: [ obj4 v1 ] raise: Break.
	self shouldnt: [ obj4 v1: 0 ] raise: Break.
	self shouldnt: [ obj4 v2 ] raise: Break.
	self shouldnt: [ obj4 v2: 0 ] raise: Break.! !

!VariableBreakpointTest methodsFor: 'tests - removing' stamp: ''!
testRemove

	wp := VariableBreakpoint watchVariablesInClass: VariableBreakpointMockSubclass.
	wp remove.
	
	self denyCollection: Breakpoint all includesAll: (OrderedCollection with: wp).	
	self assertEmpty: wp link nodes.
	self assertEmpty: (self allNodes asIdentitySet flatCollect:[:n| n links]).
	
	self shouldnt: [VariableBreakpointMockClass new] raise: Break.
	self shouldnt: [obj1 v1] raise: Break.	
	self shouldnt: [obj1 v1: 0] raise: Break.
	self shouldnt: [VariableBreakpointMockSubclass new ] raise: Break.
	self shouldnt: [obj2 instVarReads] raise: Break.
	self shouldnt: [obj2 instVarWrites] raise: Break.
	self shouldnt: [obj2 v2] raise: Break.	
	self shouldnt: [obj2 v2: 0] raise: Break.
	self shouldnt: [obj2 v1] raise: Break.	
	self shouldnt: [obj2 v1: 0] raise: Break.
	! !

!VariableBreakpointTest methodsFor: 'tests - object-centric api' stamp: ''!
testBreakOnAccess
	wp := obj2 haltOnAccess.
	self should: [ obj2 v1 ] raise: Break.
	self should: [ obj2 v1: 0 ] raise: Break.
	self should: [ obj2 v2 ] raise: Break.
	self should: [ obj2 v2: 0 ] raise: Break.
	self shouldnt: [ obj4 v1 ] raise: Break.
	self shouldnt: [ obj4 v1: 0 ] raise: Break.
	self shouldnt: [ obj4 v2 ] raise: Break.
	self shouldnt: [ obj4 v2: 0 ] raise: Break.! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
nodesForV2InVariableBreakpointMockSubclass
	|nodes |
	nodes := OrderedCollection new.
	nodes add: (VariableBreakpointMockSubclass>>#initialize) ast statements second.
	nodes add: (VariableBreakpointMockSubclass>>#instVarReads) ast statements first value arguments first.
	nodes add: (VariableBreakpointMockSubclass>>#instVarWrites) ast statements second.
	nodes add: (VariableBreakpointMockSubclass>>#v2) ast statements first value.
	nodes add: (VariableBreakpointMockSubclass>>#v2:) ast statements first.
	^nodes! !

!VariableBreakpointTest methodsFor: 'tests - installation' stamp: ''!
testSetAsBreakpointProperty
	 | nodes |
	 wp := VariableBreakpoint
		       watchVariable: #v1
		       inClass: VariableBreakpointMockClass.
	 nodes := wp link nodes.
	 nodes do: [ :n | 
		 self assert: n hasBreakpoint.
		 self assertCollection: n breakpoints equals: { wp } asSet ].
	 wp remove.
	 nodes do: [ :n | self deny: n hasBreakpoint ]! !

!VariableBreakpointTest methodsFor: 'tests - class wide watchpoints' stamp: ''!
testWatchVariableInClass 	

	wp := VariableBreakpoint watchVariable: #v1 inClass: VariableBreakpointMockClass.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #v1).
	self assert: wp targetClassOrMethod identicalTo: VariableBreakpointMockClass.
	self assert: wp targetInstance equals: nil.
	
	self assertCollection: wp link nodes asIdentitySet equals: self allNodesForV1 asIdentitySet.
	
	self should: [VariableBreakpointMockClass new] raise: Break.
	self should: [obj1 v1] raise: Break.	
	self should: [obj1 v1: 0] raise: Break.
	self should: [ VariableBreakpointMockSubclass new ] raise: Break.
	self should: [ obj2 instVarReads] raise: Break.
	self should: [ obj2 instVarWrites] raise: Break
	
	! !

!VariableBreakpointTest methodsFor: 'tests - object-centric' stamp: ''!
testWatchVariablesInObject	

	wp := VariableBreakpoint watchVariablesInObject: obj2.	
	self assert: wp targetInstance equals: obj2.	
	
	self should: [obj2 instVarReads] raise: Break.
	self should: [obj2 instVarWrites] raise: Break.
	self should: [obj2 v2] raise: Break.	
	self should: [obj2 v2: 0] raise: Break.
	self should: [obj2 v1] raise: Break.	
	self should: [obj2 v1: 0] raise: Break.
	
	self shouldnt: [obj4 instVarReads] raise: Break.
	self shouldnt: [obj4 instVarWrites] raise: Break.
	self shouldnt: [obj4 v2] raise: Break.	
	self shouldnt: [obj4 v2: 0] raise: Break.
	self shouldnt: [obj4 v1] raise: Break.	
	self shouldnt: [obj4 v1: 0] raise: Break.
	
	self shouldnt: [obj1 v1] raise: Break.	
	self shouldnt: [obj1 v1: 0] raise: Break.
	self shouldnt: [VariableBreakpointMockClass new] raise: Break.
	self shouldnt: [VariableBreakpointMockSubclass new ] raise: Break.
	! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
allNodesForV2
	^ OrderedCollection new
		addAll: self nodesForV2InVariableBreakpointMockSubclass;
		yourself! !

!VariableBreakpointTest methodsFor: 'tests - class wide watchpoints' stamp: ''!
testWatchVariableReadsInClass 	

	wp := VariableBreakpoint watchVariableReads: #v1 inClass: VariableBreakpointMockClass.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #v1).
	self assert: wp targetClassOrMethod identicalTo: VariableBreakpointMockClass.
	self assert: wp targetInstance equals: nil.

	self assertCollection: wp link nodes asIdentitySet 
			equals: (self allNodesForV1 select:[:n| n isVariable]) asIdentitySet.
	
	self shouldnt: [VariableBreakpointMockClass new] raise: Break.
	self should: [obj1 v1] raise: Break.	
	self shouldnt: [obj1 v1: 0] raise: Break.
	self shouldnt: [ VariableBreakpointMockSubclass new ] raise: Break.
	self should: [ obj2 instVarReads] raise: Break.
	self shouldnt: [ obj2 instVarWrites] raise: Break
	
	! !

!VariableBreakpointTest methodsFor: 'tests - class wide watchpoints' stamp: ''!
testWatchVariablesInClass	

	wp := VariableBreakpoint watchVariablesInClass: VariableBreakpointMockSubclass.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #v1 with: #v2).
	self assert: wp targetClassOrMethod identicalTo: VariableBreakpointMockSubclass.
	self assert: wp targetInstance equals: nil.

	self assertCollection: wp link nodes asIdentitySet equals: self allNodes asIdentitySet.
	
	self should: [VariableBreakpointMockClass new] raise: Break.
	self should: [obj1 v1] raise: Break.	
	self should: [obj1 v1: 0] raise: Break.
	self should: [VariableBreakpointMockSubclass new ] raise: Break.
	self should: [obj2 instVarReads] raise: Break.
	self should: [obj2 instVarWrites] raise: Break.
	self should: [obj2 v2] raise: Break.	
	self should: [obj2 v2: 0] raise: Break.
	self should: [obj2 v1] raise: Break.	
	self should: [obj2 v1: 0] raise: Break.
	! !

!VariableBreakpointTest methodsFor: 'running' stamp: ''!
tearDown
	wp
		ifNotNil: [ wp isInstalled
				ifTrue: [ wp remove ] ].
	Breakpoint unregisterObserver: observer.
	testSubclass ifNotNil:[testSubclass removeFromSystem].
	testClass ifNotNil:[testClass removeFromSystem].
	super tearDown! !

!VariableBreakpointTest methodsFor: 'tests - temp var breakpoints' stamp: ''!
testBreakpointOnTempReads
	|method|
	method := (VariableBreakpointMockClass>> #methodWithTempsAndArg:).
	wp := VariableBreakpoint watchVariableReads: #temp inClass: method.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #temp).
	self assert: wp targetClassOrMethod identicalTo: method.
	self assert: wp targetInstance equals: nil.
	
	self assertCollection: wp link nodes asIdentitySet equals: self tempReadNodes asIdentitySet.	
	self should: [obj1 methodWithTempsAndArg: 42] raise: Break	
	! !

!VariableBreakpointTest methodsFor: 'tests - object-centric' stamp: ''!
testWatchVariableReadsInObject 	

	wp := VariableBreakpoint watchVariableReads: #v1 inObject: obj1.
	self assert: wp targetInstance equals: obj1.
	self assert: wp accessStrategy equals: #read.
	
	self should: [obj1 v1] raise: Break.	
	self shouldnt: [obj1 v1: 0] raise: Break.
	
	self shouldnt: [VariableBreakpointMockClass new] raise: Break.
	self shouldnt: [obj3 v1] raise: Break.
	self shouldnt: [obj3 v1: 0] raise: Break
	
	! !

!VariableBreakpointTest methodsFor: 'tests - installation' stamp: ''!
testInstrumentedMethodIsCompiledMethod


	wp := VariableBreakpointMockClass newBreakpointForVariable: #v1.
	wp install.
	self assert: (VariableBreakpointMockClass>>#v1) isCompiledMethod ! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
allTempNodes
	^ OrderedCollection new
		addAll: self tempReadNodes;
		addAll: self tempWriteNodes;
		yourself! !

!VariableBreakpointTest methodsFor: 'tests - initialization' stamp: ''!
testAllSlotNamesFor
	self
		assertCollection: (VariableBreakpoint allSlotNamesFor: VariableBreakpointMockSubclass)
		equals: (OrderedCollection with: #v1 with: #v2)! !

!VariableBreakpointTest methodsFor: 'tests - class var breakpoints' stamp: ''!
testBreakpointOnClassVarWrites
	|method|
	method := (VariableBreakpointMockClass>> #classVarWrite).
	wp := VariableBreakpoint watchVariableWrites: #ClassVar inClass: VariableBreakpointMockClass.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #ClassVar).
	self assert: wp targetClassOrMethod identicalTo: VariableBreakpointMockClass.
	self assert: wp targetInstance equals: nil.
	
	self assertCollection: wp link nodes asIdentitySet equals: (VariableBreakpointMockClass classVariableNamed: #ClassVar) assignmentNodes asIdentitySet.
	self should: [obj1 classVarWrite] raise: Break	! !

!VariableBreakpointTest methodsFor: 'tests - removing' stamp: ''!
testRemoveAfterClassWithTempVarRemoved
	"Removing the class where the target temporary variable of a variable breakpoint is defined should uninstall the variable breakpoint"
	|testClassNodes|
	self compileTestClass.
	testClassNodes := (testClass >> #accessingtemp) ast allChildren.
	
	wp := (testClass >> #accessingtemp)  newBreakpointForVariable: #temp.
	wp install.	
	self should: [ testClass basicNew accessingtemp ] raise: Break.
		
	testClass removeFromSystem.	
	self denyCollection: wp link nodes includesAny: testClassNodes.
	self deny: wp isInstalled.
	self shouldnt: [ testClass basicNew accessingtemp ] raise: Break
! !

!VariableBreakpointTest methodsFor: 'tests - class wide watchpoints' stamp: ''!
testWatchVariableWritesInClass 	

	wp := VariableBreakpoint watchVariableWrites: #v1 inClass: VariableBreakpointMockClass.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #v1).
	self assert: wp targetClassOrMethod identicalTo: VariableBreakpointMockClass.
	self assert: wp targetInstance equals: nil.

	self assertCollection: wp link nodes asIdentitySet 
			equals: (self allNodesForV1 select:[:n| n isAssignment]) asIdentitySet.
	
	self should: [VariableBreakpointMockClass new] raise: Break.
	self shouldnt: [obj1 v1] raise: Break.	
	self should: [obj1 v1: 0] raise: Break.
	self should: [ VariableBreakpointMockSubclass new ] raise: Break.
	self shouldnt: [ obj2 instVarReads] raise: Break.
	self should: [ obj2 instVarWrites] raise: Break
	
	
	
	! !

!VariableBreakpointTest methodsFor: 'tests - object-centric api' stamp: ''!
testBreakOnReadTo
	wp := obj2 haltOnReadTo: #v1.
	self should: [ obj2 v1 ] raise: Break.
	self shouldnt: [ obj2 v1: 0 ] raise: Break.
	self shouldnt: [ obj2 v2 ] raise: Break.
	self shouldnt: [ obj2 v2: 0 ] raise: Break.
	self shouldnt: [ obj4 v1 ] raise: Break.
	self shouldnt: [ obj4 v1: 0 ] raise: Break.
	self shouldnt: [ obj4 v2 ] raise: Break.
	self shouldnt: [ obj4 v2: 0 ] raise: Break.! !

!VariableBreakpointTest methodsFor: 'tests - object-centric' stamp: ''!
testWatchVariableInObject
	wp := VariableBreakpoint watchVariable: #v1 inObject: obj1.
	self assert: wp targetInstance equals: obj1.	
	
	self should: [obj1 v1] raise: Break.	
	self should: [obj1 v1: 0] raise: Break.	
		
	self shouldnt: [VariableBreakpointMockClass new] raise: Break.
	self shouldnt: [obj3 v1] raise: Break.
	self shouldnt: [obj3 v1: 0] raise: Break
	
	! !

!VariableBreakpointTest methodsFor: 'tests - removing' stamp: ''!
testNoRemoveAfterSubclassRemoved
	"Removing the class where the target variable of a variable breakpoint is defined should uninstall the variable breakpoint"
	|testClassNode testSubclassNode|
	self compileTestClass.
	self compileTestClass2.
	testClassNode := (testClass >> #accessingV1) ast allChildren detect:[:n| n isVariable].
	testSubclassNode := (testSubclass >> #accessingV1) ast allChildren detect:[:n| n isVariable].
	
	wp := VariableBreakpoint watchVariable: #v1 inClass: testClass. 
	wp install.	
	
	self should: [testClass basicNew accessingV1] raise: Break.
	
	testSubclass removeFromSystem.	

	self deny: (wp link nodes anySatisfy:[:n| n == testSubclassNode]).
	self assert: (wp link nodes anySatisfy:[:n| n == testClassNode]).
	self assert: wp isInstalled.
	self should: [ testClass basicNew accessingV1 ] raise: Break
! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
compileTestClass

	testClass := VariableBreakpointMockClass
		             subclass: #VariableBreakpointTestSubclass
		             instanceVariableNames: 'v3'
		             classVariableNames: ''
		             package: 'Reflectivity-Tests-Breakpoints'.
	testClass compile: 'accessingV1 ^v1'.
	testClass compile: 'accessingtemp |temp| temp := 0'.! !

!VariableBreakpointTest methodsFor: 'tests - object-centric api' stamp: ''!
testBreakOnRead
	wp := obj2 haltOnRead.
	self should: [ obj2 v1 ] raise: Break.
	self shouldnt: [ obj2 v1: 0 ] raise: Break.
	self should: [ obj2 v2 ] raise: Break.
	self shouldnt: [ obj2 v2: 0 ] raise: Break.
	self shouldnt: [ obj4 v1 ] raise: Break.
	self shouldnt: [ obj4 v1: 0 ] raise: Break.
	self shouldnt: [ obj4 v2 ] raise: Break.
	self shouldnt: [ obj4 v2: 0 ] raise: Break.! !

!VariableBreakpointTest methodsFor: 'tests - temp var breakpoints' stamp: ''!
testBreakpointOnTempWrites
	|method|
	method := (VariableBreakpointMockClass>> #methodWithTempsAndArg:).
	wp := VariableBreakpoint watchVariableWrites: #temp inClass: method.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #temp).
	self assert: wp targetClassOrMethod identicalTo: method.
	self assert: wp targetInstance equals: nil.
	
	self assertCollection: wp link nodes asIdentitySet equals: self tempWriteNodes asIdentitySet.	
	self should: [obj1 methodWithTempsAndArg: 42] raise: Break	
	! !

!VariableBreakpointTest methodsFor: 'tests - installation' stamp: ''!
testIsInstalled
	
	wp := VariableBreakpoint newForClass: VariableBreakpointMockSubclass.
	self deny: wp isInstalled.
	wp install.
	self assert: wp isInstalled! !

!VariableBreakpointTest methodsFor: 'tests - object-centric' stamp: ''!
testWatchVariablesWritesInObject	

	wp := VariableBreakpoint watchVariablesWritesInObject: obj2.
	self assert: wp targetInstance equals: obj2.
	self assert: wp accessStrategy equals: #write.	
	
	self should: [obj2 instVarWrites] raise: Break.
	self should: [obj2 v1: 0] raise: Break.
	self should: [obj2 v2: 0] raise: Break.
	self shouldnt: [obj2 v2] raise: Break.		
	self shouldnt: [obj2 instVarReads] raise: Break.
	self shouldnt: [obj2 v1] raise: Break.		
	
	self shouldnt: [obj4 instVarReads] raise: Break.
	self shouldnt: [obj4 instVarWrites] raise: Break.
	self shouldnt: [obj4 v2] raise: Break.	
	self shouldnt: [obj4 v2: 0] raise: Break.
	self shouldnt: [obj4 v1] raise: Break.	
	self shouldnt: [obj4 v1: 0] raise: Break.
	
	self shouldnt: [obj1 v1] raise: Break.	
	self shouldnt: [obj1 v1: 0] raise: Break.
	self shouldnt: [VariableBreakpointMockClass new] raise: Break.
	self shouldnt: [VariableBreakpointMockSubclass new ] raise: Break.
	! !

!VariableBreakpointTest methodsFor: 'tests - initialization' stamp: ''!
testIsVariableBreakpoint
	self assert: VariableBreakpoint new isVariableBreakpoint.
	self deny: Breakpoint new isVariableBreakpoint! !

!VariableBreakpointTest methodsFor: 'tests - notifications' stamp: ''!
testNotifyInstVarBreakpointHit
	|method notification|
	obj1 v1: 0.
	method := (VariableBreakpointMockClass>> #v1).
	wp := VariableBreakpoint watchVariableReads: #v1 inClass: VariableBreakpointMockClass.
	self should: [obj1 v1] raise: Break.
	
	notification := observer tag.
	self assert: notification breakpoint identicalTo: wp.
	self assert: notification nodes size equals: 1.
	self assert: notification nodes first equals: method ast statements first value.
	self assert: notification valueOrNil equals: 0.
	
	wp remove.
	observer update: nil.
	method := (VariableBreakpointMockClass>> #v1:).
	wp := VariableBreakpoint watchVariableWrites: #v1 inClass: VariableBreakpointMockClass.	
	self should: [obj1 v1: 42] raise: Break.
	
	notification := observer tag.
	self assert: notification breakpoint identicalTo: wp.
	self assert: notification nodes size equals: 1.
	self assert: notification nodes first equals: method ast statements first.
	self assert: notification valueOrNil equals: 42.! !

!VariableBreakpointTest methodsFor: 'tests - initialization' stamp: ''!
testNewBreakpointForVariableInClass
	wp := VariableBreakpoint newBreakpointForVariable: #var inClass: #class.
	self assert: wp class identicalTo: VariableBreakpoint.
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #var).
	self assert: wp targetClassOrMethod equals: #class! !

!VariableBreakpointTest methodsFor: 'tests - object-centric api' stamp: ''!
testBreakOnAccessTo
	wp := obj2 haltOnAccessTo: #v1.
	self should: [ obj2 v1 ] raise: Break.
	self should: [ obj2 v1: 0 ] raise: Break.
	self shouldnt: [ obj2 v2 ] raise: Break.
	self shouldnt: [ obj2 v2: 0 ] raise: Break.
	self shouldnt: [ obj4 v1 ] raise: Break.
	self shouldnt: [ obj4 v1: 0 ] raise: Break.
	self shouldnt: [ obj4 v2 ] raise: Break.
	self shouldnt: [ obj4 v2: 0 ] raise: Break.! !

!VariableBreakpointTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.	
	obj1 := VariableBreakpointMockClass new.
	obj2 := VariableBreakpointMockSubclass new.
	obj3 := VariableBreakpointMockClass new.
	obj4 := VariableBreakpointMockSubclass new.
	observer := DummyBreakpointObserver new.
	Breakpoint registerObserver: observer! !

!VariableBreakpointTest methodsFor: 'tests - installation' stamp: ''!
testInstall
	
	wp := VariableBreakpoint newForClass: VariableBreakpointMockSubclass.	
	wp install.
	self assertCollection: Breakpoint all includesAll: (OrderedCollection with: wp)! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
allNodes
	^ OrderedCollection new
		addAll: self allNodesForV1;
		addAll: self allNodesForV2;
		yourself! !

!VariableBreakpointTest methodsFor: 'tests - notifications' stamp: ''!
testNotifyArgumentBreakpointHit
	|method notification|
	method := (VariableBreakpointMockClass>> #methodWithTempsAndArg:).
	wp := VariableBreakpoint watchVariable: #arg inClass: method.
	self should: [obj1 methodWithTempsAndArg: 42] raise: Break.
	notification := observer tag.
	self assert: notification breakpoint identicalTo: wp.
	self assert: notification nodes size equals: 1.
	self assert: notification nodes first equals: method ast statements first value.
	self assert: notification valueOrNil equals: 42! !

!VariableBreakpointTest methodsFor: 'tests - class var breakpoints' stamp: ''!
testBreakpointOnClassVarReads
	|method|
	method := (VariableBreakpointMockClass>> #classVarRead).
	wp := VariableBreakpoint watchVariableReads: #ClassVar inClass: VariableBreakpointMockClass.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #ClassVar).
	self assert: wp targetClassOrMethod identicalTo: VariableBreakpointMockClass.
	self assert: wp targetInstance equals: nil.
	
	self assertCollection: wp link nodes asIdentitySet equals: (VariableBreakpointMockClass classVariableNamed: #ClassVar) readNodes asIdentitySet.
	self should: [obj1 classVarRead] raise: Break	! !

!VariableBreakpointTest methodsFor: 'tests - removing' stamp: ''!
testRemoveAfterClassRemoved
	"Removing the class where the target variable of a variable breakpoint is defined should uninstall the variable breakpoint"
	|testClassNodes|
	self compileTestClass.
	testClassNodes := (testClass >> #accessingV1) ast allChildren.
	
	wp := VariableBreakpoint watchVariable: #v1 inClass: testClass. 
	wp install.	
		
	testClass removeFromSystem.	
	self denyCollection: wp link nodes includesAny: testClassNodes.
	self deny: wp isInstalled.
	self shouldnt: [ VariableBreakpointMockClass new v1 ] raise: Break
! !

!VariableBreakpointTest methodsFor: 'tests - removing' stamp: ''!
testRemoveFromMethod
	
	|ast|
	"We get the variable node one which the variable breakpoint will be installed"
	ast := (VariableBreakpointMockClass >> #v1) ast allChildren last. 
	
	"Removing a variable breakpoint should not uninstall the breakpoint"
	wp := VariableBreakpoint watchVariable: #v1 inClass: VariableBreakpointMockSubclass. 
	wp install.		
		
	"Let us recompile a method touching v1 in the super class of our test class.
	This is meant so simulate, e.g., a modification in the debugger after a break in that method."
	VariableBreakpointMockClass compile: 'v1 ^v1'.
	
	"First, the breakpoint should still be installed in that method"
	self assert: wp isInstalled.
	self should: [ VariableBreakpointMockClass basicNew v1 ] raise: Break.
	self should: [ VariableBreakpointMockSubclass basicNew v1 ] raise: Break.
	
	"Second, the old method ast's is not referenced by the breakpoint's link anymore"
	self assert: (wp link nodes noneSatisfy: [ :n| n == ast ])
	! !

!VariableBreakpointTest methodsFor: 'tests - notifications' stamp: ''!
testNotifyTempBreakpointHit
	|method notification|
	method := (VariableBreakpointMockClass>> #methodWithTempsAndArg:).
	wp := VariableBreakpoint watchVariableReads: #temp inClass: method.
	self should: [obj1 methodWithTempsAndArg: 42] raise: Break.
	
	notification := observer tag.
	self assert: notification breakpoint identicalTo: wp.
	self assert: notification nodes size equals: 1.
	self assert: notification nodes first equals: method ast statements last value.
	self assert: notification valueOrNil equals: 42.
	
	wp remove.
	observer update: nil.
	wp := VariableBreakpoint watchVariableWrites: #temp inClass: method.
	self should: [obj1 methodWithTempsAndArg: 42] raise: Break.
	
	notification := observer tag.
	self assert: notification breakpoint identicalTo: wp.
	self assert: notification nodes size equals: 1.
	self assert: notification nodes first equals: method ast statements first.
	self assert: notification valueOrNil equals: 42! !

!VariableBreakpointTest methodsFor: 'tests - initialization' stamp: ''!
testNewBreakpointForVariableInClassForMethod! !

!VariableBreakpointTest methodsFor: 'tests - class wide watchpoints' stamp: ''!
testWatchVariablesWritesInClass	

	wp := VariableBreakpoint watchVariablesWritesInClass: VariableBreakpointMockSubclass.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #v1 with: #v2).
	self assert: wp targetClassOrMethod identicalTo: VariableBreakpointMockSubclass.
	self assert: wp targetInstance equals: nil.
	
	self assertCollection: wp link nodes asIdentitySet 
			equals: (self allNodes select:[:n| n isAssignment]) asIdentitySet.
	
	self should: [VariableBreakpointMockClass new] raise: Break.
	self shouldnt: [obj1 v1] raise: Break.	
	self should: [obj1 v1: 0] raise: Break.
	self should: [VariableBreakpointMockSubclass new ] raise: Break.
	self shouldnt: [obj2 instVarReads] raise: Break.
	self should: [obj2 instVarWrites] raise: Break.
	self shouldnt: [obj2 v2] raise: Break.	
	self should: [obj2 v2: 0] raise: Break.
	self shouldnt: [obj2 v1] raise: Break.	
	self should: [obj2 v1: 0] raise: Break.
	! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
allNodesForV1
	^ OrderedCollection new
		addAll: self nodesForV1InFieldWatchpointMockClass;
		addAll: self nodesForV1InVariableBreakpointMockSubclass;
		yourself! !

!VariableBreakpointTest methodsFor: 'tests - initialization' stamp: ''!
testNewForClass
	wp := VariableBreakpoint newForClass: VariableBreakpointMockSubclass.
	self assert: wp class identicalTo: VariableBreakpoint.
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #v1 with: #v2).
	self assert: wp targetClassOrMethod equals: VariableBreakpointMockSubclass! !

!VariableBreakpointTest methodsFor: 'tests - installation' stamp: ''!
testScopeTo
	| instance testContext |
	instance := Object new.
	testContext := Context newForMethod: VariableBreakpointMockClass >> #v1.
	wp := VariableBreakpoint new.
	wp scopeTo: instance.
	self assert: wp targetInstance identicalTo: instance.
	self assert: wp link hasCondition.
	self assertCollection: wp link conditionArguments equals: #(context).
	self
		assert: (wp link condition value: (testContext receiver: instance)).
	self
		deny: (wp link condition value: (testContext receiver: Object new))! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
tempWriteNodes
	|nodes |
	nodes := OrderedCollection new.
	nodes add: (VariableBreakpointMockClass>>#methodWithTempsAndArg:) ast statements first.
	^nodes! !

!VariableBreakpointTest methodsFor: 'tests - temp var breakpoints' stamp: ''!
testBreakpointOnAllTempAccesses
	|method|
	method := (VariableBreakpointMockClass>> #methodWithTempsAndArg:).
	wp := VariableBreakpoint watchVariable: #temp inClass: method.
	
	self assertCollection: wp targetVariableNames equals: (OrderedCollection with: #temp).
	self assert: wp targetClassOrMethod identicalTo: method.
	self assert: wp targetInstance equals: nil.
	
	self assertCollection: wp link nodes asIdentitySet equals: self allTempNodes asIdentitySet.	
	self should: [obj1 methodWithTempsAndArg: 42] raise: Break	
	! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
nodesForV1InFieldWatchpointMockClass
	|nodes |
	nodes := OrderedCollection new.
	nodes add: (VariableBreakpointMockClass>>#initialize) ast statements first.
	nodes add: (VariableBreakpointMockClass>>#v1) ast statements first value.
	nodes add: (VariableBreakpointMockClass>>#v1:) ast statements first.
	^nodes! !

!VariableBreakpointTest methodsFor: 'helpers' stamp: ''!
argNodes
	|nodes |
	nodes := OrderedCollection new.
	nodes add: (VariableBreakpointMockClass>>#methodWithTempsAndArg:) ast statements first value.
	^nodes! !

!VariableBreakpointTest methodsFor: 'tests - object-centric' stamp: ''!
testWatchVariablesReadsInObject	

	wp := VariableBreakpoint watchVariablesReadsInObject: obj2.
	self assert: wp targetInstance equals: obj2.
	self assert: wp accessStrategy equals: #read.	 
	
	self should: [obj2 v2] raise: Break.		
	self should: [obj2 instVarReads] raise: Break.
	self should: [obj2 v1] raise: Break.
	self shouldnt: [obj2 instVarWrites] raise: Break.
	self shouldnt: [obj2 v1: 0] raise: Break.
	self shouldnt: [obj2 v2: 0] raise: Break.
	
	
	self shouldnt: [obj4 instVarReads] raise: Break.
	self shouldnt: [obj4 instVarWrites] raise: Break.
	self shouldnt: [obj4 v2] raise: Break.	
	self shouldnt: [obj4 v2: 0] raise: Break.
	self shouldnt: [obj4 v1] raise: Break.	
	self shouldnt: [obj4 v1: 0] raise: Break.
	
	self shouldnt: [obj1 v1] raise: Break.	
	self shouldnt: [obj1 v1: 0] raise: Break.
	self shouldnt: [VariableBreakpointMockClass new] raise: Break.
	self shouldnt: [VariableBreakpointMockSubclass new ] raise: Break.
	! !

!VariableLayout commentStamp: ''!
I am the default layout for variable sized objects such as Array.

I contain a fixed number of Slots plus.
Instances of classes using this kind of layout have only a minimum given size. Instances have a custom number of additional fields which can be accessed with an index.!
!VariableLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	^ self hasFields
		ifTrue: [ 3 ]
		ifFalse: [ 2 ]! !

!VariableLayout methodsFor: 'testing' stamp: ''!
isVariable
	^ true! !

!VariableLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGVariableLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)]
! !

!VariableLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else!!"
	^#variableSubclass:! !

!VariableLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass
	^ (superLayout extendVariable: aScope)
		host: aClass;
		yourself! !

!VariableLayout class methodsFor: '*Monticello' stamp: 'nil'!
mcTypeSymbol 
	^ #variable! !

!VariableNotDeclared commentStamp: ''!
This exception is provided to support doesNotUnderstand: on missing classes (Undeclared variables)!
!VariableNotDeclared methodsFor: 'accessing' stamp: ''!
variableNode
	^ variableNode! !

!VariableNotDeclared methodsFor: 'accessing' stamp: ''!
classSymbol
	^ self variableNode name! !

!VariableNotDeclared methodsFor: 'accessing' stamp: ''!
description

	"Returns a textual description of the exception (based on the message instance variable). If message is nil, it returns the defaultDescription instead."

	message ifNil: [ ^ self defaultDescription ].
	^ self classSymbol printString
	  , ' is missing, and does not understand '
	  , message selector printString! !

!VariableNotDeclared methodsFor: 'accessing' stamp: ''!
variableNode: anObject
	variableNode := anObject! !

!VariableNotDeclaredTest commentStamp: ''!
A VariableNotDeclaredTest is a test class for testing the behavior of VariableNotDeclared!
!VariableNotDeclaredTest methodsFor: 'tests' stamp: ''!
testDescription

	"Tests that the description of the VariableNotDeclaredTest is not the default of Exception"

	| exception defaultDescription variableNotDeclaredDescription |
	defaultDescription := ''.
	variableNotDeclaredDescription := ''.
	exception:= MyVariableNotDeclaredDummyClassForTest new. 
	defaultDescription := exception defaultDescription .
	variableNotDeclaredDescription := exception description .
	self deny: defaultDescription equals: variableNotDeclaredDescription! !

!VersionBrowser commentStamp: ''!
I am a tool made for browsing the several versions of the provided method.

I will list of the history of the method available in the sources of the image.

Examples
--------------------

	self browseVersionsForClass: self selector: #initializeWidgets
	
 
Internal Representation and Key Implementation Points.
--------------------

    Instance Variables
	isShowingDiff:			<aBoolean>		Since I can show a diff or a code presenter, I am a boolean here to know which one is currently selected.
	rgMethod:					<aRGMethod>		The method to browse the versions.
	sourcePresenter:		<aPresenter>		Either a code or diff presenter depending on the informations the user wants to know.
					
	Maybe the #sourcePreseneter management should be extracted into a Strategy design pattern later to have a cleaner code.
!
!VersionBrowser methodsFor: 'visiting' stamp: ''!
accept: text notifying: notifyer
	| message |

	message := self selectedMessage.
	message ifNil: [ ^ self ].
	
	message methodClass 
		compile: text 
		classified: message protocol
		notifying: notifyer! !

!VersionBrowser methodsFor: 'private - factory' stamp: ''!
newTextConverter

	^ DiffSideBySideChangeRecordConverter new! !

!VersionBrowser methodsFor: 'private' stamp: ''!
showDiffMorphWithConverter: aConverter
	| newSource | 

	self textConverter: aConverter.

	newSource := self newDiff.
	newSource contextClass: self selectedMessage methodClass.
	self replaceSourceWith: newSource! !

!VersionBrowser methodsFor: 'accessing' stamp: ''!
changeList
	^ messageList messages! !

!VersionBrowser methodsFor: 'private' stamp: ''!
showDiffLineWithConverter: aConverter
	| newSource |

	self textConverter: aConverter.

	newSource := self instantiate: SpPatchPresenter.
	newSource beForMethod: self selectedMessage.

	self replaceSourceWith: newSource
! !

!VersionBrowser methodsFor: 'actions' stamp: ''!
compareToCurrentVersion
	self compareTo: rgMethod withLabel: 'Current version'! !

!VersionBrowser methodsFor: 'private - factory' stamp: ''!
revert: aChangeRecord

	aChangeRecord ifNil: [ 
		^ self inform: 'nothing selected, so nothing done' ].
	
	rgMethod realClass
		compile: aChangeRecord sourceCode
		classified: aChangeRecord category
		withStamp: aChangeRecord stamp
		notifying: nil.

	"reinitialize me"
	self setRGMethodFrom: rgMethod realClass >> rgMethod selector.

	messageList
		messages: self buildChangeList;
		selectIndex: 1! !

!VersionBrowser methodsFor: 'private' stamp: ''!
replaceSourceWith: aPresenter
	
	sourceLayout children size = 1 
		ifTrue: [ 
			sourceLayout add: aPresenter ]
		ifFalse: [ 
			sourceLayout replace: sourcePresenter with: aPresenter ].
		
	sourcePresenter := aPresenter.
	messageList selectIndex: messageList selectedIndex! !

!VersionBrowser methodsFor: 'private - updating' stamp: ''!
updateDiffLine: content

	(content isText or: [ content isString ])
		ifTrue: [ 
			sourcePresenter 
				patchFrom: '' 
				to: content asString ]
		ifFalse: [ 
			sourcePresenter 
				patchFrom: content first asString
				to: content second asString ].
			
	self installIconStylerFor: self textConverter method! !

!VersionBrowser methodsFor: 'actions' stamp: ''!
browseImplementors
	SystemNavigation new browseAllImplementorsOf: rgMethod selector! !

!VersionBrowser methodsFor: 'actions' stamp: ''!
compareToOtherVersion
	| labels versions index selected |
	versions := self changeList.
	labels := versions collect: [ :each | each stamp ].
	index := UIManager default chooseFrom: labels.
	index > 0 ifFalse: [ ^ self ].
	selected := versions at: index.
	self compareTo: selected withLabel: selected stamp! !

!VersionBrowser methodsFor: 'accessing - model' stamp: ''!
setModelBeforeInitialization: aMethod

	self setRGMethodFrom: aMethod! !

!VersionBrowser methodsFor: 'private' stamp: ''!
setSourceContentWith: content

	self textConverter 
		updateContent: content 
		on: self! !

!VersionBrowser methodsFor: 'private - updating' stamp: ''!
updateDiff: content

	(content isText or: [ content isString ])
		ifTrue: [ 
			sourcePresenter 
				leftText: '';
				rightText: content ]
		ifFalse: [ 
			sourcePresenter 
				leftText: content first;
				rightText: content second ].
			
		self installIconStylerFor: self textConverter method! !

!VersionBrowser methodsFor: 'actions' stamp: ''!
compareTo: anOtherVersion withLabel: aLabel
	| versions texts |

	versions := Array with: anOtherVersion with: self selectedMessage.
	texts := (DiffVersionChangeRecordConverter 
		methodReference: anOtherVersion 
		referencesList: versions) 
		getText.

	(SpDiffPresenter newApplication: self application)
		title: ('Comparison from {1} to {2}' format: { versions second stamp. aLabel });
		leftText: texts first;
		rightText: texts second;
		openWithSpec! !

!VersionBrowser methodsFor: 'accessing' stamp: ''!
method

	^ rgMethod! !

!VersionBrowser methodsFor: 'private - factory' stamp: ''!
newSourceDiff

	^ self newDiff! !

!VersionBrowser methodsFor: 'private - updating' stamp: ''!
updateSource: content 

	sourcePresenter text: content! !

!VersionBrowser methodsFor: 'initialization' stamp: ''!
setRGMethodFrom: aMethod
"asHistorical, because active RGMethods don't always have the source pointer attached"

	rgMethod := aMethod asRingDefinition asHistorical! !

!VersionBrowser methodsFor: 'actions' stamp: ''!
browseSenders

	self systemNavigation 
		browseSendersOf: rgMethod selector 
		name: 'Senders of ', rgMethod selector 
		autoSelect: rgMethod selector! !

!VersionBrowser methodsFor: 'private' stamp: ''!
installIconStylerFor: anItem
	"icons styler are only supported for method definitions (not nil / not for comment definitions    
	 (those may occure for comment or general string searches)) and in the case the source presenter is not a diff"

	(self isMethodDefinition: anItem) ifFalse: [ ^ self ].

	IconStyler withStaticStylers 
		styleText: sourcePresenter 
		withAst: anItem ast! !

!VersionBrowser methodsFor: 'initialization' stamp: ''!
initializeWindow: aWindowPresenter

	super initializeWindow: aWindowPresenter.
	aWindowPresenter title: 'Recent versions of ' , rgMethod displayName! !

!VersionBrowser methodsFor: 'private' stamp: ''!
selectItem: item

	sourcePresenter ifNil: [ ^ self ].

	self setSourceContentWith: (self textConverter
		method: item;
		getText)! !

!VersionBrowser methodsFor: 'accessing' stamp: ''!
messageListMenu

	self flag: #TODO. "At least some of this options needs to be a command"
	^ self newMenu
		addGroup: [ :aGroup | 
			aGroup
				addItem: [ :anItem | 
					anItem
						name: 'Compare to current';
						help: 'Compare selected version to the current version';
						action: [ self compareToCurrentVersion ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Compare to version...';
						help: 'Compare selected version to another selected version';
						action: [ self compareToOtherVersion ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Revert to selected version';
						help: 'Resubmit the selected version, so that it becomes the current version';
						action: [ self revert: self selectedMessage ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Senders';
						shortcut: $n meta;
						action: [ self browseSenders ] ];
				addItem: [ :anItem | 
					anItem
						name: 'Implementors';
						shortcut: $m meta;
						action: [ self browseImplementors ] ] ];
		yourself! !

!VersionBrowser methodsFor: 'private' stamp: ''!
showSourceWithConverter: aConverter
	| newSource |

	self textConverter: aConverter.
	
	newSource := self newCode.
	newSource whenSubmitDo: [ :text | (self accept: text notifying: nil) notNil ].
	newSource beForMethod: self selectedMessage.

	self replaceSourceWith: newSource
! !

!VersionBrowser methodsFor: 'initialization' stamp: ''!
initializePresenters

	self layout: (SpPanedLayout newTopToBottom
		add: (messageList := self instantiate: MessageList on: rgMethod);
		add: ((sourceLayout := SpBoxLayout newTopToBottom)
			add: (toolbarPresenter := self instantiate: SpMethodToolbarPresenter on: rgMethod) 
				expand: false;
			yourself);
		yourself).

	messageList
		topologicSort: false;
		sortingBlock: [ :a | a annotationNamed: #versionIndex ifAbsent: [ 0 ] ] ascending;
		contextMenu: self messageListMenu.

	toolbarPresenter
		addItemLabeled: 'Side By Side' do: [
			self showDiffMorphWithConverter: (DiffSideBySideChangeRecordConverter 
				methodReference: self textConverter method 
				referencesList: self changeList) ];
		addItemLabeled: 'Source' do: [ 
			self showSourceWithConverter: (DiffSourceMethodConverter method: self textConverter method) ];
		addItemLabeled: 'Diff' do: [ 
			self showDiffLineWithConverter: (DiffLineChangeRecordConverter 
				methodReference: self textConverter method
				referencesList: self changeList) ].
		
	toolbarPresenter versionModel
		label: 'Revert';
		action: [ self revert: self selectedMessage ]! !

!VersionBrowser methodsFor: 'initialization' stamp: ''!
connectPresenters

	messageList
		whenSelectedDo: [ :item | self selectItem: item ];
		messages: self buildChangeList.
	toolbarPresenter dropListModel selectIndex: 1! !

!VersionBrowser methodsFor: 'private - factory' stamp: ''!
buildChangeList
	rgMethod sourcePointer ifNil:[ ^ #() ].

	^ (SourceFiles
		changeRecordsFrom: rgMethod sourcePointer
		className: rgMethod instanceSideParentName
		isMeta: rgMethod isMetaSide)
		collectWithIndex: [ :c :i | | rg |
			rg := c asRingDefinition.
			rg annotationNamed: #versionIndex put: i ]! !

!VersionBrowser class methodsFor: 'specs' stamp: ''!
defaultSpec
	
	^ nil! !

!VersionBrowser class methodsFor: 'api' stamp: ''!
browseVersionsForMethod: aRingMethod
	^ (self on: aRingMethod) openWithSpec! !

!VersionBrowser class methodsFor: 'tools registry' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]"

	registry register: self as: #versionBrowser! !

!VersionBrowser class methodsFor: 'api' stamp: ''!
browseVersionsForClass: aClass selector: aSelector
	^ aClass
		compiledMethodAt: aSelector
		ifPresent: [ :method | self browseVersionsForMethod: method ]
		ifAbsent: [ self
				inform:
					('No method {1} in class {2}'
						format:
							{aSelector.
							aClass printString}) ]! !

!VileFinalizer commentStamp: ''!
I am test object used for a WeakRegistry test.
I add myself to a given WeakRegistry and on finalization I modify the very same registry by removing myself from it.!
!VileFinalizer methodsFor: 'finalization' stamp: ''!
finalize
	weakRegistry remove: self ifAbsent: [].! !

!VileFinalizer methodsFor: 'initialization' stamp: ''!
initialize: registry
	weakRegistry := registry.
	weakRegistry add: self.! !

!VirtualBreakpoint methodsFor: 'accessing' stamp: ''!
setter: anObject

	setter := anObject! !

!VirtualBreakpoint methodsFor: 'API' stamp: ''!
whenHit: aBlock
	"Sets aBlock to be evaluated when this breakpoint is hit. If this method is called multiple times, all the blocks provided will be evaluated when this breakpoint is hit."

	self whenHit add: aBlock! !

!VirtualBreakpoint methodsFor: 'accessing' stamp: ''!
node: anObject

	node := anObject! !

!VirtualBreakpoint methodsFor: 'accessing' stamp: ''!
breakOnce: anObject

	breakOnce := anObject! !

!VirtualBreakpoint methodsFor: 'accessing' stamp: ''!
whenHit

	whenHit ifNil: [ whenHit := OrderedCollection new ].
	^ whenHit! !

!VirtualBreakpoint methodsFor: 'hitTest' stamp: ''!
hitTest: aNode
	"aNode is assumed to be the current node of the execution. If aNode is equal to the node on which this breakpoint has been set, evaluate all the blocks in whenHit and return true. Otherwise return false."

	self node == aNode ifTrue: [ 
		self breakOnce ifTrue: [ self remove ].
		self whenHit do: [ :block | block value ].
		^ true ].
	^ false! !

!VirtualBreakpoint methodsFor: 'accessing' stamp: ''!
node

	^ node! !

!VirtualBreakpoint methodsFor: 'accessing' stamp: ''!
breakOnce

	breakOnce ifNil: [ breakOnce := false ].
	^ breakOnce! !

!VirtualBreakpoint methodsFor: 'accessing' stamp: ''!
setter

	^ setter! !

!VirtualBreakpoint methodsFor: 'API' stamp: ''!
remove

	all remove: self! !

!VirtualBreakpoint methodsFor: 'API' stamp: ''!
once
	"Configures this breakpoint to remove itself the next time it is hit"

	breakOnce := true! !

!VirtualBreakpoint class methodsFor: 'instance creation' stamp: ''!
newOnNode: aNode
	"Used by ScriptableDebugger. Should be removed in favour of newOnNode:setBy: if the latter stays"

	^ self new
		  node: aNode;
		  yourself! !

!VirtualBreakpoint class methodsFor: 'actions' stamp: ''!
clearAll
	<script>
	all := nil! !

!VirtualBreakpoint class methodsFor: 'instance creation' stamp: ''!
all

	all ifNil: [ all := OrderedCollection new ].
	^ all! !

!VirtualBreakpoint class methodsFor: 'instance creation' stamp: ''!
newOnNode: aNode setBy: anObject

	| breakPoint |
	breakPoint := self new node: aNode; setter: anObject.
	self all add: breakPoint.
	^ breakPoint! !

!VirtualMachine commentStamp: ''!
I am exposing a various attributes of smalltalk virtual machine.


The direct use of this class is not recommended. 

All attributes are normally should be accessed via

Smalltalk vm someAttribute

instead of 

VirtualMachine someAttribute

!
!VirtualMachine methodsFor: 'testing' stamp: ''!
isAIOInterrupt
	"Answer true, if the vm is capable of being interrupted until there is an AIO event. 
	 (This means we are going idle until we have something real to process)"

	^ (self getSystemAttribute: 1010) = 'AIO'! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
optionAt: i
	"Answer the i-th option of the command line, or nil if not so many options."
	
	^self getSystemAttribute: i negated! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
hasSmallFloats
	"SmallFloats are available in 64 bits machines"
	^ self wordSize = 8! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
maxFilenameLength
	"Return the maximal filename length (only under MacOS) as a string
	 or nil for other platforms "
	"Smalltalk vm maxFilenameLength"
	^ (self getSystemAttribute: 1201) ifNotNil: [ :string | string asNumber ]! !

!VirtualMachine methodsFor: 'parameters' stamp: ''!
parameterAt: parameterIndex
	"parameterIndex is a positive integer corresponding to one of the VM's internal
	parameter/metric registers.  Answer with the current value of that register.
	Fail if parameterIndex has no corresponding register.

	VM parameters are numbered as follows:

		1	end (v3)/size(Spur) of old-space (0-based, read-only)
		2	end (v3)/size(Spur) of young/new-space (read-only)
		3	end (v3)/size(Spur) of heap (read-only)
		4	nil (was allocationCount (read-only))
		5	nil (was allocations between GCs (read-write)
		6	survivor count tenuring threshold (read-write)
		7	full GCs since startup (read-only)
		8	total milliseconds in full GCs since startup (read-only)
		9	incremental GCs (SqueakV3) or scavenges (Spur) since startup (read-only)
		10	total milliseconds in incremental GCs (SqueakV3) or scavenges (Spur) since startup (read-only)
		11	tenures of surving objects since startup or reset (read-write)
		12-20 were specific to ikp's JITTER VM, now 12-15 are open for use
		16	total microseconds at idle since start-up (if non-zero)
		17	fraction of the code zone to use (Sista only; used to control code zone use to preserve sendAndBranchData on counter tripped callback)
		18	total milliseconds in compaction phase of full GC since start-up (Spur only)
		19	scavenge threshold, the effective size of eden.  When eden fills to the threshold a scavenge is scheduled. Newer Spur VMs only.
		20	utc microseconds at VM start-up (actually at time initialization, which precedes image load).
		21	root/remembered table size (occupancy) (read-only)
		22	root table overflows since startup (read-only)
		23	bytes of extra memory to reserve for VM buffers, plugins, etc (stored in image file header).
		24	memory threshold above which shrinking object memory (rw)
		25	memory headroom when growing object memory (rw)
		26	interruptChecksEveryNms - force an ioProcessEvents every N milliseconds (rw)
		27	number of times mark loop iterated for current IGC/FGC (read-only) includes ALL marking
		28	number of times sweep loop iterated for current IGC/FGC (read-only)
		29	number of times make forward loop iterated for current IGC/FGC (read-only)
		30	number of times compact move loop iterated for current IGC/FGC (read-only)
		31	number of grow memory requests (read-only)
		32	number of shrink memory requests (read-only)
		33	number of root table entries used for current IGC/FGC (read-only)
		34	Spur: bytes allocated in total since start-up or reset (read-write) (Used to be number of allocations done before current IGC/FGC (read-only))
		35	number of survivor objects after current IGC/FGC (read-only)
		36	millisecond clock when current IGC/FGC completed (read-only)
		37	number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC (read-only)
		38	milliseconds taken by current IGC (read-only)
		39	Number of finalization signals for Weak Objects pending when current IGC/FGC completed (read-only)
		40	BytesPerOop for this image
		41	imageFormatVersion for the VM
		42	number of stack pages in use
		43	desired number of stack pages (stored in image file header, max 65535)
		44	size of eden, in bytes
		45	desired size of eden, in bytes (stored in image file header)
		46	machine code zone size, in bytes (Cog only; otherwise nil)
		47	desired machine code zone size (stored in image file header; Cog only; otherwise nil)
		48	various header flags.  See getCogVMFlags.
		49	max size the image promises to grow the external semaphore table to (0 sets to default, which is 256 as of writing)
		50-51 nil; reserved for VM parameters that persist in the image (such as eden above)
		52	root/remembered table capacity
		53	number of segments (Spur only; otherwise nil)
		54	total size of free old space (Spur only, otherwise nil)
		55	ratio of growth and image size at or above which a GC will be performed post scavenge
		56	number of process switches since startup (read-only)
		57	number of ioProcessEvents calls since startup (read-only)
		58	number of ForceInterruptCheck calls since startup (read-only)
		59	number of check event calls since startup (read-only)
		60	number of stack page overflows since startup (read-only)
		61	number of stack page divorces since startup (read-only)
		62	compiled code compactions since startup (read-only; Cog only; otherwise nil)
		63	total milliseconds in compiled code compactions since startup (read-only; Cog only; otherwise nil)
		64	the number of methods that currently have jitted machine-code
		65	whether the VM supports a certain feature, MULTIPLE_BYTECODE_SETS is bit 0, IMMUTABILITY is bit 1
		66	the byte size of a stack page
		67	the max allowed size of old space (Spur only; nil otherwise; 0 implies no limit except that of the underlying platform)
		68	the average number of live stack pages when scanned by GC (at scavenge/gc/become et al) (read-write)
		69	the maximum number of live stack pages when scanned by GC (at scavenge/gc/become et al) (read-write)
		70	the vmProxyMajorVersion (the interpreterProxy VM_MAJOR_VERSION)
		71	the vmProxyMinorVersion (the interpreterProxy VM_MINOR_VERSION)
		72 total milliseconds in full GCs Mark phase since startup (read-only)
		73 total milliseconds in full GCs Sweep phase since startup (read-only, can be 0 depending on compactors)
		74 maximum pause time due to segment allocation
		75 number of JIT compiled methods since startup (read-only)
		76 total milliseconds spent on JIT compiled methods since startup (read-only)
		77 number of JIT compiled block since startup (read-only)
		78 total milliseconds spent on JIT compiled block since startup (read-only)"

	<primitive: 254>
	self primitiveFailed! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
setGCBiasToGrowGCLimit: aNumber
	"Primitive. Indicate that the bias to grow logic should do a GC after aNumber Bytes"
	<primitive: 'primitiveSetGCBiasToGrowGCLimit'>
	^self primitiveFailed
"Example:
	Smalltalk vm setGCBiasToGrowGCLimit: 16*1024*1024.
"! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
imageFile
	"Image file "
	^ Smalltalk image imageFile! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
fullPath
	"Return the full vm path as a string"
	"Ex: '/Applications/.../Contents/MacOS/vm '"
	"SmalltalkImage current vm fullPath"

	^self getSystemAttribute: 0! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
maxExternalSemaphoresSilently: aSize 
	"Changes the size of array where external signals for semaphores in
	externalObjects are handled.. 
	The size can only grow, and will always be the next power of two
	larger than the parameter.
	
	The intended use is to set the table size to some adequate
	maximum as part of a non-resuming image startUp.
	
	Setting this at any time other than start-up can potentially result in
	lost signals during reallocation.
	i.e. Requests handled during copying og signals from old to new array
	won't be seen if they occur to indices already copied, before
	pointers to the new and old arrays are switched."
	self maxExternalSemaphores
		ifNil: [^ 0].
	"The vm-header field where the size is stored is a short, maximum
	64k entries. 
	Well, on most platforms anyways"
	(aSize < 0
			or: [aSize > 65535])
		ifTrue: [^ DomainError signalFrom: 0 to: 65535].
	^ self parameterAt: 49 put: aSize! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
version
	"Return a string of attributes representing the current VM"
	"
	Smalltalk vm version
	"
	^ String streamContents: [ :s |
			s nextPutAll: self interpreterClass; cr.
			self isRunningCogit ifTrue: [ s nextPutAll: self cogitClass; cr ].
			s nextPutAll: self interpreterSourceVersion; cr ].! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
cogitClass
	"Return the jit class that is currently executing the system (Cog VM only)"
	^self getSystemAttribute: 1008! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
freeSize
	"Return the amount of free memory of the heap in bytes."
		
	^ self freeOldSpaceSize + self edenSpaceSize - self youngSpaceSize! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
isRunningCogit
	"Returns true if we're running on the Cog JIT
	 (vmParameterAt: 46 is the size of the machine code zone)"

	^[(self parameterAt: 46) > 0] on: Error do:[:ex| ex return: false]! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
maximumPauseTimeDueToSegmentAllocation

	^ self parameterAt: 74
! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
memorySize
	"Return the memory size of the heap in bytes."
		
	^ self parameterAt: 3 "Readonly parameter for spur"! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
documentPath
	"Answer the absolute path of the document passed to the vm or nil if none."
	"Smalltalk commandLine documentPath"
	
	^self getSystemAttribute: 2! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
interpreterSourceDate
	"Return the date of changes given by `self interpreterSourceVersion`"
	| dateString parts | 
	
	dateString := (self interpreterSourceVersion splitOn: 'Date: ') second.
	
	dateString first isDigit
		ifTrue: [ 
			"most probably the date is in ISO 8601 Format" 
			^ dateString asDateAndTime ].
		
	"Otherwise assume the old format: DDD MMM DD HH:MM:SS YYYY +TTTT ..."
	parts := dateString substrings first: 6.
	"create a more reasonable string.."
	dateString := String streamContents: [ :s |
		s 
			nextPutAll: (parts at: 5 ); space; "year"
			nextPutAll: (parts at: 2 ); space; "month name"
			nextPutAll: (parts at: 3 ); space; "day of month"
			nextPutAll: (parts at: 4 ); space; "time"
			nextPutAll: (parts last); space    "timezone"].
	^ dateString asDateAndTime ! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
maxExternalSemaphores
	"The size of array in some VM's where external signals for
	semaphores in externalObjects are handled.
	Essentially, if a semaphore is registered in externalObjects outside
	its bounds, they will not be signalled."
	^ [self parameterAt: 49]
		on: PrimitiveFailed
		do: [:ex | ex return: nil]! !

!VirtualMachine methodsFor: '*Reflectivity' stamp: ''!
metaLinkOptions
	^{
	#isSpur -> #( + optionCompileOnLinkInstallation).
	#metaLinkOptions -> #( + optionCompileOnLinkInstallation)
	}! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
buildDate			
	"Return a String reflecting the build date of the VM"
	"Smalltalk buildDate"

	^self getSystemAttribute: 1006! !

!VirtualMachine methodsFor: 'modules' stamp: ''!
listBuiltinModules
	"Smalltalk vm listBuiltinModules"

	"Return a list of all builtin modules (e.g., plugins). Builtin plugins are those that are 
	compiled with the VM directly, as opposed to plugins residing in an external shared library. 	
	The list will include all builtin plugins regardless of whether they are currently loaded 
	or not. Note that the list returned is not sorted!!"

	| modules index tname |
	modules := Array new writeStream.
	index := 1.
	[ true ]
		whileTrue: [ 
			tname := self listBuiltinModule: index.
			tname ifNil: [ ^ modules contents ].
			modules nextPut: tname.
			index := index + 1 ]! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
totalIncrementalGCTime
	"Answer the total time in milliseconds spent in incremental GCs since startup (read-only)."

	^ self parameterAt: 10
! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
for32bit: aBlockFor32bit for64bit: aBlockFor64bit

	"evaluates a block or returns a provided value depending on bitness of the current VM"

	self is32bit ifTrue: [ ^ aBlockFor32bit value ].
	self is64bit ifTrue: [ ^ aBlockFor64bit value ].

	self error: 'Unknown VM bitness'! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
is32bit
	"Answers if this VM is a 32bit version"
	^ self wordSize = 4! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
flagInterpretedMethods: aBoolean
	"The Cog VM can be instructed to set the flag bit of CompiledMethods that it executes but will only interpret.  This can be used e.g. to profile startup. See CompiledMethod>>#flag & CompiledMethod>>#clearFlag. This flag persists across snapshots, stored in the image header."
	
	self parameterAt: 48 put: ((self parameterAt: 48) bitClear: 2) + (aBoolean ifTrue: [2] ifFalse: [0])! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
isSpur 
	"this value is always true but is here for backward compatibility (non Spur images should return false)"
	^ true! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
tenuringThreshold: anInteger
	"survivor count tenuring threshold (read-write).
	tenure when more than this many objects survive the GC"
	
	^ self parameterAt: 6 put: anInteger! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
processPreemptionYields: aBoolean
	"The Cog VM can be instructed not to yield on process preemption, i.e. not to put a preempted process at the back of its run queue.  By default preempting a process causes it to yield (Blue Book semantics) which can have unfortunate effects. This flag persists across snapshots, stored in the image header."
	
	self parameterAt: 48 put: ((self parameterAt: 48) bitClear: 4) + (aBoolean ifTrue: [0] ifFalse: [2r100])! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
gcBiasToGrowLimit: arg
	"Tell the VM the grow limit if the GC logic has bias to grow."
	
	<primitive: 'primitiveSetGCBiasToGrowGCLimit'>
	^self primitiveFailed! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
edenSpaceSize
	"for spur, size of eden, in bytes"
		
	^ self parameterAt: 44
! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
is64bit
	"Answers if this VM is a 64bit version"
	^ self wordSize = 8! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
supportsMultipleBytecodeSets
	"Answer whether the VM supports multiple bytecodeSets."

	^(self parameterAt: 65)
		ifNil: [false]
		ifNotNil:
			[:param| "In older VMs this is a boolean reflecting MULTIPLE_BYTECODE_SETS"
			 param isInteger "In newer VMs it is a set of integer flags, bit 0 of which is MULTIPLE_BYTECODE_SETS"
				ifTrue: [param anyMask: 1]
				ifFalse: [param]]! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
platformSourceVersion
	"The use of this primitive not recommended. Not all VMs providing that"


	"Answer a string corresponding to the version of the external platform source
	code, typically written in C and managed separately for each platform. This
	invokes an optional primitive that may not be available on all virtual machines."

	"Smalltalk vm platformSourceVersion"

	<primitive: 'primitivePlatformSourceVersion'>
	self notify: 'This virtual machine does not support the optional primitive #primitivePlatformSourceVersion'.
	^''! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
extraVMMemory
	"Answer the current setting of the 'extraVMMemory' VM parameter. See the comment in extraVMMemory: for details."

	^ self parameterAt: 23
! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
headlessOption
	"Return the default name for the headless option for this VM"
	^ self optionDash, (Smalltalk os isUnix
		ifTrue: [ 'vm-display-null' ]
		ifFalse: [ 'headless' ])! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
processHasThreadIdInstVar: aBoolean
	"The threaded VM needs to know if the 4th inst var of Process
	 is threadId which it uses to control process-to-thread binding.
	 This flag persists across snapshots, stored in the image header."
	aBoolean ifTrue: [self assert: (Process instVarNames at: 4) ='threadId'].
	self parameterAt: 48 put: ((self parameterAt: 48) bitClear: 1) + (aBoolean asBit)
	
! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
tenureCount
	"tenures of surving objects since startup (read-only)."

	^ self parameterAt: 11
! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
allocationsBetweenGC: anInteger
	"allocations between GCs (read-write)"
	^ self parameterAt: 5 put: anInteger! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
compiledBlocksCount

	^ self parameterAt: 77
! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
freeOldSpaceSize
	"for spur, total size of free old space, otherwise nil"
		
	^ self parameterAt: 54
! !

!VirtualMachine methodsFor: 'modules' stamp: ''!
listBuiltinModule: index
	"Return the name of the n-th builtin module.
	This list is not sorted!!"
	<primitive: 572>
	^self primitiveFailed! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
fullGCCount
	"Answer the total number of full GCs since startup (read-only)."

	^ self parameterAt: 7
! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
totalJITCompileTime
	
	^ self totalJITCompileMethodsTime + self totalJITCompileBlocksTime! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
isRunningCog
	"Returns true if we're running on a Cog VM (JIT or StackInterpreter)
	 (parameterAt: 42 is the number of stack pages)"

	^[(self parameterAt: 42) > 0] on: Error do:[:ex| ex return: false]! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
statisticsReport
	"Workspace openContents: (Smalltalk vm statisticsReport) label: 'VM Statistics'"

	| oldSpaceSize youngSpaceSize memorySize freeSize fullGCs fullGCTime incrGCs incrGCTime tenureCount upTime upTime2 fullGCs2 fullGCTime2 incrGCs2 incrGCTime2 tenureCount2 str |
	oldSpaceSize		:= self oldSpace.
	youngSpaceSize		:= self youngSpaceSize.
	tenureCount			:= self tenureCount.
	memorySize			:= self memorySize.
	freeSize				:= self freeSize.
	fullGCs				:= self fullGCCount.
	fullGCTime			:= self totalFullGCTime.
	incrGCs				:= self incrementalGCCount.
	incrGCTime			:= self totalIncrementalGCTime.
 
	upTime := Time millisecondClockValue.
	str := (String new: 1000) writeStream.
	str	<< 'uptime			';
		print: (upTime / 1000 / 60 // 60); nextPut: $h;
		print: (upTime / 1000 / 60 \\ 60) asInteger; nextPut: $m;
		print: (upTime / 1000 \\ 60) asInteger; nextPut: $s; cr.

	str	<< 'memory			'.
	memorySize printWithCommasOn: str.
	str << ' bytes'; cr.
	str	<<	'	old			'.
	oldSpaceSize printWithCommasOn: str.
	str << ' bytes (';
		print: ((oldSpaceSize / memorySize * 100) roundTo: 0.1); << '%)'; cr.
	str	<< '	young		'.
	(youngSpaceSize) printWithCommasOn: str.
	str << ' bytes (';
		print: ((youngSpaceSize / memorySize * 100) roundTo: 0.1); << '%)'; cr.
	str	<< '	used		'.
	youngSpaceSize + oldSpaceSize - freeSize printWithCommasOn: str.
	str << ' bytes (';
		print: ((youngSpaceSize + oldSpaceSize - freeSize / memorySize * 100) roundTo: 0.1); << '%)'; cr.
	str	<< '	free		'.
	freeSize printWithCommasOn: str.
	str << ' bytes (';
		print: ((freeSize / memorySize * 100) roundTo: 0.1); << '%)'; cr.

	str	<< 'GCs				'.
	(fullGCs + incrGCs) printWithCommasOn: str.
	fullGCs + incrGCs > 0 ifTrue: [
		str
			<< ' ('; 
			print: ((upTime / (fullGCs + incrGCs)) roundTo: 1); 
			<< 'ms between GCs)'
	].
	str cr.
	str	<< '	full			';
		print: fullGCs; << ' totalling '.
	fullGCTime printWithCommasOn: str.
	str << 'ms (';
		print: ((fullGCTime / upTime * 100) roundTo: 0.1);
		<< '% uptime)'.
	fullGCs = 0 ifFalse:
		[str	<< ', avg '; print: ((fullGCTime / fullGCs) roundTo: 0.1); << 'ms'].
	str	cr.
	str	<< '	incr		';
		print: incrGCs; << ' totalling '.
	incrGCTime printWithCommasOn: str.
	str << 'ms (';
		print: ((incrGCTime / upTime * 100) roundTo: 0.1);
		<< '% uptime), avg '; print: ((incrGCTime / incrGCs) roundTo: 0.1); << 'ms'; cr.
	str	<< '	tenures		'.
	tenureCount printWithCommasOn: str.
	tenureCount = 0 ifFalse:
		[str << ' (avg '; print: (incrGCs / tenureCount) asInteger; << ' GCs/tenure)'].
	str	cr.

LastStats ifNil: [LastStats := Array new: 6]
ifNotNil: [
	upTime2 := upTime - (LastStats at: 1).
	fullGCs2 := fullGCs - (LastStats at: 2).
	fullGCTime2 := fullGCTime - (LastStats at: 3).
	incrGCs2 := incrGCs - (LastStats at: 4).
	incrGCTime2 := incrGCTime - (LastStats at: 5).
	tenureCount2 := tenureCount - (LastStats at: 6).

	str	<<  'Since last view	'.
	(fullGCs2 + incrGCs2) printWithCommasOn: str.
	fullGCs2 + incrGCs2 > 0 ifTrue: [
		str
			<< ' ('; 
			print: ((upTime2 / (fullGCs2 + incrGCs2)) roundTo: 1); 
			<< 'ms between GCs)'.
	].
	str cr.
	str	<< '	uptime		'; print: ((upTime2 / 1000.0) roundTo: 0.1); << 's'; cr.
	str	<< '	full			';
		print: fullGCs2; << ' totalling '.
	fullGCTime2 printWithCommasOn: str.
	str << 'ms (';
		print: ((fullGCTime2 / upTime2 * 100) roundTo: 0.1);
		<< '% uptime)'.
	fullGCs2 = 0 ifFalse:
		[str	<< ', avg '; print: ((fullGCTime2 / fullGCs2) roundTo: 0.1); << 'ms'].
	str	cr.
	str	<< '	incr		';
		print: incrGCs2; << ' totalling '.
	incrGCTime2 printWithCommasOn: str.
	str << 'ms (';
		print: ((incrGCTime2 / upTime2 * 100) roundTo: 0.1);
		<< '% uptime), avg '.
	incrGCs2 > 0 ifTrue: [
		 str print: ((incrGCTime2 / incrGCs2) roundTo: 0.1); << 'ms'
	].
	str cr.
	str	<< '	tenures		'.
	tenureCount2 printWithCommasOn: str.
	tenureCount2 = 0 ifFalse:
		[str << ' (avg '; print: (incrGCs2 / tenureCount2) asInteger; << ' GCs/tenure)'].
	str	cr.
].
	LastStats at: 1 put: upTime.
	LastStats at: 2 put: fullGCs.
	LastStats at: 3 put: fullGCTime.
	LastStats at: 4 put: incrGCs.
	LastStats at: 5 put: incrGCTime.
	LastStats at: 6 put: tenureCount.

	^ str contents
! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
doGetSystemAttribute: attributeID 
	"Optional. Answer the string for the system attribute with the given 
	integer ID. Answer nil if the given attribute is not defined on this 
	platform. On platforms that support invoking programs from command 
	lines (e.g., Unix), this mechanism can be used to pass command line 
	arguments to programs written in Pharo.

	By convention, the first command line argument that is not a VM
	configuration option is considered a 'document' to be filed in. Such a
	document can add methods and classes, can contain a serialized object,
	can include code to be executed, or any combination of these.

	Currently defined attributes include: 
	-1000   1000th command line argument that specify VM options
   	...
	-1              first command line argument that specify VM options
      0               the full path name for currently executing VM
                       (or, on some platforms, just the path name of the VM's directory)
       1               full path name of this image (better use primImageName instead)
       2               a Pharo document to open, if any
       3               first command line argument for Pharo programs
       ...
       1000    1000th command line argument for Pharo programs
       1001    this platform's operating system 'Mac OS', 'Win32', 'unix', ...
       1002    operating system version
       1003    this platform's processor type
       1004    vm version
       1005    window system name
       1006    vm build id
       1007    Interpreter class (Cog VM only)
       1008    Cogit class (Cog VM only)
       1201    max filename length (Mac OS only)
       1202    file last error (Mac OS only)
       10001   hardware details (Win32 only)
       10002   operating system details (Win32 only)
       10003   graphics hardware details (Win32 only)"

	<primitive: 149>
	^ nil! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
operatingSystemName
	
	^ Smalltalk vm getSystemAttribute: 1001! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
maxExternalSemaphores: aSize
	"This method should never be called as result of normal program
    execution. If it is however, fork off the growth to keep new
    Semaphores flowing for other users, but raise an error in this thread
    indicating that something needs to change to avoid potentially
    unhandled interrupts."

	self maxExternalSemaphores ifNil: [ ^ 0 ].
	
	[ self maxExternalSemaphoresSilently: aSize.
	SystemNotification signal: ('WARNING: Had to increase size of semaphore signal handling table due to many external objects concurrently in use', String cr,
		'You should increase this size at startup using #maxExternalSemaphoresSilently:', String cr,
		'Current table size: ' , self maxExternalSemaphores printString) ] forkAt: Processor userBackgroundPriority.
	
	self error: 'Not enough space for external objects, set a larger size at startup!!'.
	^ self maxExternalSemaphores! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
directory
	
	^ self primVmPath asByteArray utf8Decoded! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
imagePath
	"Image file path
	Ex:  '/Users/foo/Pharo/Pharo-1.1.1-dev10.09.1.image'"
	^ Smalltalk image imagePath! !

!VirtualMachine methodsFor: 'primitives' stamp: ''!
primVmPath
	"Answer the path for the directory containing the Smalltalk virtual machine. Return the empty string if this primitive is not implemented."
	"Smalltalk vmPath"

	<primitive: 142>
	^ ''! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
interpreterSourceVersion
	"The use of this primitive not recommended. Not all VMs providing that"

	"Answer a string corresponding to the version of the interpreter source.
	This represents the version level of the Smalltalk source code (interpreter
	and various plugins) that is translated to C by a CCodeGenerator, as distinct
	from the external platform source code, typically written in C and managed
	separately for each platform. An optional primitive is invoked that may not
	be available on all virtual machines."

	"Smalltalk vm interpreterSourceVersion"

	<primitive: 'primitiveInterpreterSourceVersion'>
	^ self getSystemAttribute: 1009! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
architectureName
	
	^ Smalltalk vm getSystemAttribute: 1003! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
optionDash
	"VMs release in Mai 2013 use -- instead of - for VM command line options"
	^ (Smalltalk vm interpreterSourceDate > '2013-05-17' asDate)
		ifTrue: [ '--' ]
		ifFalse: [ '-' ]! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
isRunningInWorkerThread
	"Answers whether the vm is running on worker thread ot not"

	^ (self getSystemAttribute: 1011) = 'WORKER_THREAD'! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
totalJITCompileMethodsTime

	^ self parameterAt: 76
! !

!VirtualMachine methodsFor: 'parameters' stamp: ''!
imageVersionNumber
	"Image version number (6505 means the Squeak V3 format with BlockClosure support (but _without_ BlockContext support)"
		
	^ self parameterAt: 41! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
wordSize
	^ WordSize ifNil: [WordSize := [self parameterAt: 40] on: Error do: [4]]! !

!VirtualMachine methodsFor: 'modules' stamp: ''!
disableModuleLoading
	"Primitive. Disable a new module loading mechanism for the rest of current session.
	This operation is not reversible.
	Any subsequent attempts to load either external or internal module(s) will fail"

	<primitive: 'primitiveDisableModuleLoading' module: ''>! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
maxOldSpaceSize: aValue

	"the max allowed size of old space (Spur only; nil otherwise; 0 implies no limit except that of the underlying platform)"

	^ self parameterAt: 67 put: aValue! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
totalGCSweepPhaseTime

	^ self parameterAt: 73
! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
command
	"return a bash-like launch command for the vm including all arguments up to the image name "
	^ String streamContents: [ :s|
		s nextPutAll: (self optionAt: 0).
		Smalltalk commandLine options 
			do: [ :argument|
				(argument endsWith: '.image')
					ifTrue: [ ^ s contents ].
				
				s space; nextPutAll: argument]]! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
youngSpaceSize
	"for spur, size of young/new-space (read-only)"
		
	^ self parameterAt: 2
! !

!VirtualMachine methodsFor: '*FileSystem-Core' stamp: ''!
binary
	"Answer the a file reference to the virtual machine binary."
	"SmalltalkImage current vmBinary"

	^ FileLocator vmBinary! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
youngSpaceEnd
	"end of young-space"
		
	^ self parameterAt: 2
! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
interpreterClass
	"Return the interpreter class that is currently executing the system (Cog VM only)"
	^ self getSystemAttribute: 1007! !

!VirtualMachine methodsFor: 'parameters' stamp: ''!
getParameters	
	"Answer an Array containing the current values of the VM's internal
	parameter/metric registers.  Each value is stored in the array at the
	index corresponding to its VM register.  (See #vmParameterAt: and
	#vmParameterAt:put:.)"
	"Smalltalk vm getParameters"
	
	<primitive: 254>
	self primitiveFailed! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
voidCogVMState
	"Void any internal caches the VM maintains other than the method lookup caches.
	 These comprise
		- the stack zone, where method activations are stored, and
		- the machine code zone, where the machine code form of CompiledMethods is held."
	<primitive: 214>
	^self primitiveFailed! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
versionLabel
	"The use of this primitive not recommended. Not all VMs providing that"

	"Answer a string corresponding to the version of virtual machine. This
	represents the version level of the Smalltalk source code (interpreter
	and various plugins) that is translated to C by a CCodeGenerator,  in
	addition to the external platform source code, typically written in C and
	managed separately for each platform.
	
	This invokes an optional primitive that may not be available on all virtual
	machines. See also vmVersion, which answers a string identifying the image
	from which virtual machine sources were generated."

	"Smalltalk vm versionLabel"

	<primitive: 'primitiveVMVersion'>
	self notify: 'This virtual machine does not support the optional primitive #primitiveVMVersion'.
	^''! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
incrementalGCCount
	"Answer the total number of incremental GCs since startup (read-only)."

	^ self parameterAt: 9
! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
totalGCMarkPhaseTime

	^ self parameterAt: 72
! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
isPharoVM
	"Answers if this VM is a valid PharoVM (made with our sources)"
	| version |
	
	self flag: #pharoTodo. "We need a certain way of identify PharoVM, but in the mean time this ensures "
	version := self version.
	^ (version beginsWith: 'PharoVM')
		or: [ 
			(version includesSubstring: 'NBCoInterpreter')
				or: [
					(version includesSubstring: 'Commit: ') 
						and: [ 
							| pos |
							pos := (version findString: 'Commit: ') + 8.
							(version copyFrom: pos to: pos + 39) allSatisfy: [ :each | (($a to: $f), ($0 to: $9)) includes: each ] ] ] ]! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
compiledMethodsCount

	^ self parameterAt: 75
! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
supportsWriteBarrier
	"Answer whether the VM observes the per-object read-only flag and consequently
	 aborts writes to inst vars of, and fails primitives that attempt to write, to read-only objects."

	^(self parameterAt: 65)
		ifNil: [false]
		ifNotNil:
			[:param| "In older VMs this is a boolean reflecting MULTIPLE_BYTECODE_SETS"
			 param isInteger "In newer VMs it is a set of integer flags, bit 1 of which is IMMUTABILITY"
				ifTrue: [param anyMask: 2]
				ifFalse: [false]]! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
fileName
	^ self fullPath! !

!VirtualMachine methodsFor: 'modules' stamp: ''!
unloadModule: aString
	"Primitive. Unload the given module.
	This primitive is intended for development only since some
	platform do not implement unloading of DLL's accordingly.
	Also, the mechanism for unloading may not be supported
	on all platforms."
	<primitive: 571>
	^self primitiveFailed! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
setGCSemaphore: semaIndex
	"Primitive. Indicate the GC semaphore index to be signaled on GC occurance."
	<primitive: 'primitiveSetGCSemaphore'>
	^self primitiveFailed
"Example:

	| index sema process |
	sema := Semaphore new.
	index := Smalltalk registerExternalObject: sema.
	Smalltalk setGCSemaphore: index.
	process := [
		[[true] whileTrue:[
			sema wait.
			Smalltalk beep.
		]] ensure:[
			Smalltalk setGCSemaphore: 0.
			Smalltalk unregisterExternalObject: sema.
		].
	] fork.
	process inspect.
"! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
vmFileName
	^ self fileName! !

!VirtualMachine methodsFor: 'modules' stamp: ''!
forgetModule: aString
	"Primitive. If the module named aString is loaded, unloaded. If not, and it is marked an unloadable, unmark it so the VM will try to load it again next time. See comment for #unloadModule:."
	<primitive: 571>
	^self primitiveFailed! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
extraVMMemory: extraBytesToReserve
	"Request that the given amount of extra memory be reserved for use by the virtual machine to leave extra C heap space available for things like plugins, network and file buffers, and so on. This request is stored when the image is saved and honored when the image is next started up. Answer the previous value of this parameter."

	extraBytesToReserve < 0
		ifTrue: [self error: 'VM memory reservation must be non-negative'].
	^ self parameterAt: 23 put: extraBytesToReserve
! !

!VirtualMachine methodsFor: 'parameters' stamp: ''!
parameter46Documentation

"
46      size of machine code zone, in bytes

To speed-up execution, the cog uses internally a JIT compiler which translates to machine code frequently used bytecoded method and run the machine code to execute them instead of using the interpreter. The machine code zone is an executable memory zone containing all the machine code versions of methods. 

The default size should be between 1Mb and 2Mb for standard applications. If memory is a constraint, it can be lowered down to 750kb, under that you should use the stack VM else the performance starts to drastically decrease.

This setting is useful to tune your application performance. For example, on compilation-intensive benches, 750kb is the optimal machine code zone size. On large benchmarks, 2 Mb, maybe more, is better, but then one may see machine code garbage collection pauses. On small benches all the methods fit into this zone so it doesn't really matter.

Growing the machine code zone:
- increase the number of methods that can be present there, hence decreasing machine code zone garbage collection frequency and method jit compilation.
- decrease the machine code zone to cpu instruction cache mapping
- slow down machine code zone garbage collection

To set the machine code zone you need to use another parameter (47 I think) and restart the VM+image.
"! !

!VirtualMachine methodsFor: 'parameters' stamp: ''!
parameterAt: parameterIndex put: newValue
	"parameterIndex is a positive integer corresponding to one of the VM's internal
	parameter/metric registers.  Store newValue (a positive integer) into that
	register and answer with the previous value that was stored there.
	Fail if newValue is out of range, if parameterIndex has no corresponding
	register, or if the corresponding register is read-only."

	<primitive: 254>
	self primitiveFailed! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
oldSpace
	"for spur, sizeof old-space (0-based, read-only)"
		

	^ self parameterAt: 1
! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
totalJITCompileBlocksTime

	^ self parameterAt: 78
! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
totalFullGCTime
	"Answer the total time in milliseconds spent in full GCs since startup (read-only)."

	^ self parameterAt: 8
! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
allocationsBetweenGC
	"allocations between GCs (read-write)"
	^ self parameterAt: 5! !

!VirtualMachine methodsFor: 'attributes' stamp: ''!
getSystemAttribute: attributeID 
	"Optional. Answer the string for the system attribute with the given 
	integer ID. Answer nil if the given attribute is not defined on this 
	platform. On platforms that support invoking programs from command 
	lines (e.g., Unix), this mechanism can be used to pass command line 
	arguments to programs written in Pharo.

	By convention, the first command line argument that is not a VM
	configuration option is considered a 'document' to be filed in. Such a
	document can add methods and classes, can contain a serialized object,
	can include code to be executed, or any combination of these.

	Currently defined attributes include: 
	-1000   1000th command line argument that specify VM options
   	...
	-1              first command line argument that specify VM options
      0               the full path name for currently executing VM
                       (or, on some platforms, just the path name of the VM's directory)
       1               full path name of this image (better use primImageName instead)
       2               a Pharo document to open, if any
       3               first command line argument for Pharo programs
       ...
       1000    1000th command line argument for Pharo programs
       1001    this platform's operating system 'Mac OS', 'Win32', 'unix', ...
       1002    operating system version
       1003    this platform's processor type
       1004    vm version
       1005    window system name
       1006    vm build id
       1007    Interpreter class (Cog VM only)
       1008    Cogit class (Cog VM only)
       1201    max filename length (Mac OS only)
       1202    file last error (Mac OS only)
       10001   hardware details (Win32 only)
       10002   operating system details (Win32 only)
       10003   graphics hardware details (Win32 only)"

	^ (self doGetSystemAttribute: attributeID) ifNotNil: [ :aValue | aValue asByteArray utf8Decoded ]! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
memoryEnd
	"end of memory"
		
	^ self parameterAt: 3
! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
maxOldSpaceSize

	"the max allowed size of old space (Spur only; nil otherwise; 0 implies no limit except that of the underlying platform)"

	^ self parameterAt: 67! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
tenuringThreshold
	"survivor count tenuring threshold (read-write)"
	^ self parameterAt: 6! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
oldSpaceEnd
	"end of old-space (0-based, read-only)"
		

	^ self parameterAt: 1
! !

!VirtualMachine methodsFor: 'modules' stamp: ''!
listLoadedModule: index
	"Return the name of the n-th loaded module.
	This list is not sorted!!"
	<primitive: 573>
	^self primitiveFailed! !

!VirtualMachine methodsFor: 'modules' stamp: ''!
listLoadedModules
	"SmalltalkImage current listLoadedModules"
	"Return a list of all currently loaded modules (e.g., plugins). Loaded modules are those that currently in use (e.g., active). The list returned will contain all currently active modules regardless of whether they're builtin (that is compiled with the VM) or external (e.g., residing in some external shared library). Note that the returned list is not sorted!!"
	| modules index tname |
	modules := Array new writeStream.
	index := 1.
	[true] whileTrue: [
		tname := self listLoadedModule: index.
		tname ifNil:[^modules contents].
		modules nextPut: tname.
		index := index + 1.
	].! !

!VirtualMachine methodsFor: 'testing' stamp: ''!
processPreemptionYields
	"Answer whether the VM causes a process to yield on process preemption, i.e. to put a preempted process at the back of its run queue.  If the parameter is unavailable (non-Cog VMs) or bit 2 (4) is 0 then preemption yields."

	^(([self parameterAt: 48]
			on: Error
			do: [:ex| ^true]) allMask: 2r100) not! !

!VirtualMachine methodsFor: 'gc' stamp: ''!
setGCParameters
	"Adjust the VM's default GC parameters to avoid too much tenuring.
	 Maybe this should be left to the VM?"

	| proportion edenSize survivorSize averageObjectSize numObjects |
	proportion := 0.9. "tenure when 90% of pastSpace is full"
	edenSize := self edenSpaceSize.
	survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)"
	averageObjectSize := 8 * self wordSize. "a good approximation"
	numObjects := (proportion * survivorSize / averageObjectSize) rounded.
	self tenuringThreshold: numObjects  "tenure when more than this many objects survive the GC"! !

!VirtualMachine methodsFor: 'statistics' stamp: ''!
totalGCTime
	^ self totalFullGCTime + self totalIncrementalGCTime! !

!VirtualMachine methodsFor: 'accessing' stamp: ''!
options
	"return an array with all the options passed to the VM (up to the image) "
	^ Array streamContents: [ :s|
		Smalltalk commandLine options 
			do: [ :argument|
				(argument endsWith: '.image')
					ifTrue: [ ^ s contents ].
				
				s nextPut: argument ]]! !

!VisibleClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testWhenThereIsNoOne

	| annotations annotationUser |
	annotationUser := Object new. "context can be anything"
	
	annotations := ContextualClassAnnotationExample1 visibleInstancesInContext: annotationUser.
	
	self assert: annotations isEmpty! !

!VisibleClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testNotIncludeInstancesWithoutContext

	| annotations annotationUser |
	annotationUser := AnnotationUserExample new.
	annotations := ClassAnnotationExample1 visibleInstancesInContext: annotationUser.
	
	self assert: annotations isEmpty! !

!VisibleClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testIncludeInstancesDeclaredForSuperclassOfGivenUser

	| annotations annotationUser declaredContext |
	annotationUser := AnnotationUserExample new.
	annotations := ContextualClassAnnotationExample2 visibleInstancesInContext: annotationUser.
	
	self assert: annotations size equals: 1.
	declaredContext := annotations anyOne activeContext annotationUserClass.
	self assert: declaredContext equals: BaseAnnotationUserExample! !

!VisibleClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testIncludeOnlyInstancesCreatedForGivenUser

	| annotations annotationUser declaredContexts |
	annotationUser := AnnotationUserExample new.
	annotations := ContextualClassAnnotationExample1 visibleInstancesInContext: annotationUser.
	
	self assert: annotations size equals: 2.
	declaredContexts := annotations collect: [:each | each activeContext annotationUserClass].
	self assert: declaredContexts asSet equals: {AnnotationUserExample} asSet! !

!VisibleClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testCanBeEnumeratedForGivenUser

	| annotationUser actual expected |
	annotationUser := AnnotationUserExample new.
	actual := OrderedCollection new.
	ContextualClassAnnotationExample1 visibleInstancesInContext: annotationUser do: [:each | 
		actual add: each].
	expected := ContextualClassAnnotationExample1 visibleInstancesInContext: annotationUser.

	self assert: actual asSet equals: expected asSet.! !

!VisibleClassAnnotationsTest methodsFor: 'tests' stamp: ''!
testCanBeEnumeratedForGivenClassAndUser

	| annotationUser actual expected |
	annotationUser := AnnotationUserExample new.
	actual := OrderedCollection new.
	ContextualClassAnnotationExample1 
		visibleInstancesFor: ClassWithAnnotationsDefinedForUserClass inContext: annotationUser 
		do: [:each | actual add: each].
	expected := ContextualClassAnnotationExample1 visibleInstancesInContext: annotationUser.

	self assert: actual asSet equals: expected asSet! !

!WBMacWebBrowser commentStamp: ''!
Provides native access to the web browser on Mac. Do not use directly, use class WebBrowser instead.!
!WBMacWebBrowser class methodsFor: 'private - uffi' stamp: ''!
system: command

	^LibC system: command ! !

!WBMacWebBrowser class methodsFor: 'private' stamp: ''!
openNativeWebBrowserOn: anURLString

	| openCommand |
	openCommand := 'open "{1}"' format: { anURLString }.
	self system: openCommand! !

!WBMacWebBrowser class methodsFor: 'testing' stamp: ''!
isForCurrentSystem

	^Smalltalk os isMacOS ! !

!WBUnixWebBrowser commentStamp: ''!
Provides native access to the web browser on Unix. Do not use directly, use class WebBrowser instead.!
!WBUnixWebBrowser class methodsFor: 'private - uffi' stamp: ''!
system: command

	^LibC system: command ! !

!WBUnixWebBrowser class methodsFor: 'private' stamp: ''!
openNativeWebBrowserOn: anURLString

	| openCommand |
	openCommand := 'xdg-open ''{1}'' &' format: { anURLString }.
	self system: openCommand! !

!WBUnixWebBrowser class methodsFor: 'testing' stamp: ''!
isForCurrentSystem

	^Smalltalk os isUnix  ! !

!WBWindowsWebBrowser commentStamp: ''!
Provides native access to the web browser on Windows. Do not use directly, use class WebBrowser instead.!
!WBWindowsWebBrowser class methodsFor: 'private - uffi' stamp: ''!
shellExecute: lpOperation file: lpFile parameters: lpParameters directory: lpDirectory show: nShowCmd	
	
	^self ffiCall: #( 
			FFIConstantHandle ShellExecuteA(
     				0,
     				String* lpOperation,
         			String* lpFile,
     				String* lpParameters,
     				String* lpDirectory,
        			int nShowCmd)) module: #shell32! !

!WBWindowsWebBrowser class methodsFor: 'private' stamp: ''!
openNativeWebBrowserOn: anURLString

	^self shellExecute: 'open' file: anURLString parameters: '' directory: '' show: 5 "SW_SHOW"! !

!WBWindowsWebBrowser class methodsFor: 'testing' stamp: ''!
isForCurrentSystem

	^Smalltalk os isWindows   ! !

!WaitfreeQueue commentStamp: ''!
This is a thread-safe implementation of a queue with wait-free operations. 
It is guaranteed that any message sent to my instance (like adding new item, or fetching item) will not block sender, nor enter a waiting loop.

The implementation is based on atomicity of simple assignment operations, which can't be interrupted in a middle,
i.e. two assignment statements in a row, like:

x := y.
y := z.

can't be interrupted by interpreter and can be seen as a single atomic operation.


This implementation fits best for case, when multiple threads populating queue, but only single thread fetching items from it.

In given implementation, inserting new items into queue can't block the sender and insertion operation always takes constant time (if we ignore the possible GC interference here).
For reading/polling operations queue using a lock mechanism, which indicating that queue currently in the middle of extraction, and therefore, if some thread obtained a lock upon the queue, other threads must wait till one that obtained the lock will finish its operation(s) and release the lock.
All operations which may block the sender will answer the default value(s) instead. 



Implementation Notes

As mentioned above WaitfreeQueue relies on the VM treating simple assignment operations as uninterruptable.  It also ensures that reader and writer processes can't modify the same variables at the same time.

The queue consists of a linked list of AtomicQueueItems.  Each item contains a pointer to the next item and the object which is the queue entry.

An item can be:

- "circular", meaning that the next item is itself.
- a "zombie", meaning that the object points back to the queue's dummy object (more below).

Writing processes create a new item and then use atomic access to get the old tail entry and update the queue's tail variable.  They then own the old tail entry and can update its next variable at any time.  Because the queue's tail variable is updated atomically, any number of writer processes can be adding items to the queue.

A reader process uses atomic access to the get first item and make the dummy item circular.  At this point the reader process owns the linked list and can modify any item except the last one (which will be circular).  Any other process attempting to read the queue will find the dummy object is circular and return nil - meaning the queue is either empty or locked.

If the reader process wants to return the object from the last item in the linked list (which may be owned by a writer process), it will retrieve the object and then mark the item as a zombie, i.e. set the item's object to the queue's dummy item.  The zombie item will then be removed by a later reader process when it is no longer last in the linked list.

Once the reader process has retrieved the object it sets the dummy item's next variable to the first item in the linked list, making the queue avilable again to other processes.!
!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
findFirst: aBlock
	"Note, this method only for backward compatibility. It duplicating the semantics of #nextOrNilSuchThat: completely.
	Use #nextOrNilSuchThat: instead "

	
	^ self nextOrNilSuchThat: aBlock! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
isEmpty
	"Answer true if queue contains at least one element.
	Note, that answer is non-deterministic, because sender could be interrupted at any moment,
	means that even if message answers true, there is no any guarantees that consequent #nextXX messages could 
	retrieve item(s) from queue.
	
	Therefore use of this method is discouraged. 
	This test will work only if sender is the only process, which fetching items from queue. If there are two or more processes which 
	fetching items from queue, using this method makes no sense "
	
	| item |

	item := dummy next.

	[  item object == dummy ] whileTrue: [
		item isCircular ifTrue: [ ^ true ].
		item := item next.
	].
	
	^ false! !

!WaitfreeQueue methodsFor: 'initialization' stamp: ''!
initialize
	dummy := AtomicQueueItem new.
	dummy object: dummy.
	tail := dummy.! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
peek
	"Answer the object that was sent through the receiver first and has not 
	yet been received by anyone but do not remove it from the receiver. 
	If queue is empty or there are other process currently fetching object from queue, answer nil.
	
	Note: do not assume that if #peek answers non-nil object, the next message sent to queue,
	like #next or #nextOrNil will answer the same item.
	The use of this method is discouraged , it is provided only for backward compatibility.
	"

	| item result |

	item := dummy next. 

	[ (result := item object) == dummy ] whileTrue: [
		item isCircular ifTrue: [ 
			self signalNoMoreItems. 
			^ nil ].
		item := item next.
	].
	
	^ result! !

!WaitfreeQueue methodsFor: 'initialization' stamp: ''!
initializeWithAll: aCollection
	"Initialize the receiver with the supplied items (AtomicQueueItem).
	This method is not thread safe and should only be used for initialising the queue prior to normal operation (and is normally used only for testing)."

	dummy next: aCollection first.
	1 to: aCollection size - 1 do: [ :i |
		(aCollection at: i) next: (aCollection at: i+1) ].
	tail := aCollection last! !

!WaitfreeQueue methodsFor: 'private - accessing' stamp: ''!
tail
	"Answer the tail entry of the receiver.
	This is internal state and is only for automated unit testing"

	^tail! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
nextOrNil
	"Fetch next item from queue, or nil if queue is either empty or in the middle of extraction by other process.
	If queue can contain a nil as element, use #nextIfNone: instead "
	^ self nextIfNone: nil! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
itemCount
	"Answer the number of items in the queue including zombies. 
	If queue is currently in the middle of extraction by other process, give a (very) approximate answer.
	
	This method has a non-deterministic result due to the design of the concurrent shared queue. 
	"
	
	| item count |

	item := dummy.

	count := 0.
	[ item := item next. item == dummy ifFalse: [ count := count + 1 ]. item isCircular ] whileFalse.

	count = 0 ifTrue: [
		"if queue is locked by other process, check the tail and give a (very) approximate answer."
		^ tail object == dummy ifTrue: [ 0 ] ifFalse: [ 1 ]
		].	

	^ count! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
removeAll
	"
	This message makes no sense in concurrent environment. There is no way to guarantee that when this method returns to sender, the queue will remain empty,
	because at any moment other process may interrupt current process and put new item(s) to queue.

	Therefore we just flush the queue and hope for the best"
	
	self flush! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
size
	"Answer the size of queue. 
	If queue is currently in the middle of extraction by other process, give a (very) approximate answer.
	
	This method having a non-deterministic results, because of nature of concurrent shared queue. 
	"
	
	| item count |

	item := dummy.

	count := 0.
	[ item := item next. item object == dummy ifFalse: [ count := count + 1]. item isCircular ] whileFalse.

	count = 0 ifTrue: [
		"if queue is locked by other process, check the tail and give a (very) approximate answer."
		^ tail object == dummy ifTrue: [ 0 ] ifFalse: [ 1]
		].	

	^ count! !

!WaitfreeQueue methodsFor: 'private - accessing' stamp: ''!
dummy
	"Answer the dummy entry of the receiver.
	This is internal state and is only for automated unit testing"

	^dummy! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
nextPut: value
	" Add new item to queue "
	| item oldTail |
	
	item := self newItem.
	item object: value.

	" atomic swap here"
	oldTail := tail.
	tail := item.
	
	"self interrupt"
	
	oldTail next: item.

	self signalAddedNewItem.

	^ value! !

!WaitfreeQueue methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream 
		nextPutAll: self class name;
		nextPutAll: ' with ';
		print: self size;
	 	nextPutAll: ' items' .! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
flush: aFlushBlock
	"Process all currently available items, passing each item to a flush block.
	If there is another process, which currently fetching items from queue, or queue is empty,
	return immediately"
	
	| item |

	item := dummy makeCircular. 
	item == dummy ifTrue: [ ^ self  ].

	[ | object |
		object := item object.
		object == dummy ifFalse: [
			[ aFlushBlock value: object ] ifCurtailed: [ 
				item object: dummy.
				dummy next: item next ].
		].
		item object: dummy.
		
		item isCircular ifTrue: [
			"this was the last one"
			dummy next: item.
			self signalNoMoreItems.
			^ self
			].
		item := item next.
	] repeat.! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
flush
	self flush: [:ea | ]! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
flushAllSuchThat: aBlock
	"Remove from the queue all objects that satisfy aBlock.
	Note, the operation is no-op, if queue is currently in the middle of extraction by other process"
	
	| item first |

	(item := dummy makeCircular) == dummy ifTrue: [ ^ self ]. 
	first := item.
	
	[ | object |
		object := item object.
		object == dummy ifFalse: [
			( [ aBlock value: object ] ifCurtailed: [ dummy next: first ] ) ifTrue: [
				item object: dummy.
			] ].
	
		item isCircular ifTrue: [
			"this was the last one"
			dummy next: first.
			^ self
			].
		item := item next.
	] repeat.! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
nextIfNone: aBlock
	"Attempt to fetch the next item from queue. Evaluate a block if attempt is failed i.e. there is no items available or queue is locked by another process"
	
	| item result |

	(item := dummy makeCircular) == dummy ifTrue: [
		"queue is either empty or currently locked by other feeder,
		just give a quick answer that item not found"
		 ^ aBlock value  ].

	[ (result := item object) == dummy ] whileTrue: [
		item isCircular ifTrue: [ 
			self signalNoMoreItems. 
			dummy next: item. ^ aBlock value ].
		item := item next.
	].
	
	item object: dummy.

	dummy next: item next.
	^ result! !

!WaitfreeQueue methodsFor: 'accessing' stamp: ''!
nextOrNilSuchThat: aBlock
	"Fetch an object from queue that satisfies aBlock, skipping (but not removing) any intermediate objects.
	If no object has been found, answer <nil> and leave me intact.
	
	NOTA BENE:  aBlock can contain a non-local return (^).
	Found item is removed from queue.

	If queue currently in the middle of extraction by other process, don't wait and return <nil> immediately"
	
	| item first previous object |

	(first := dummy makeCircular) == dummy  ifTrue: [ ^ nil ]. 

	"Remove any zombie objects from the start of the list"
	[ (object := first object) == dummy ] whileTrue: [
		first isCircular ifTrue: [ 
			self signalNoMoreItems. 
			dummy next: first. ^ nil ].
		first := first next.
	].

	previous := nil.
	item := first.
	"Iterate over the list searching for the requested entry and removing zombies"
	[
		object := item object.
		object == dummy ifTrue: [ 
			"Remove the object unless it is the last.
			This can't happen on the first iteration, so no need to check previous"
			item isCircular ifFalse: [ 
				previous next: item next ] ]
		ifFalse: [
			( [ aBlock value: object ] ifCurtailed: [ dummy next: first ] ) ifTrue: [
				item object: dummy.
				previous ifNotNil: [ 
					previous next: item next.
					dummy next: first ]
				ifNil: 
					[ dummy next: item next ].
				^ object ]
			ifFalse:
				[ previous := item ] ].
	
		item isCircular ifTrue: [
			"this was the last one"
			dummy next: first.
			^ nil
			].

		item := item next.
	] repeat.! !

!WaitfreeQueue class methodsFor: 'instance creation' stamp: ''!
new: anInteger 
	"Just to match SharedQueue protocol"
	^self new! !

!WaitfreeQueue class methodsFor: 'instance creation' stamp: ''!
withAll: aCollection
	"Answer an instance of the receiver initialized with the supplied collection of items"

	^ self new initializeWithAll: aCollection! !

!WaitfreeQueueTest methodsFor: 'tests' stamp: ''!
testZombieMiddle
	"Check that a zombie item at the start of the queue is correctly removed"

	| items queue real |

	items := self newItems: 3.
	queue := WaitfreeQueue withAll: items.
	items first object: #real1.
	items second object: queue dummy.
	items last object: #real2.

	real := queue nextOrNil.
	self assert: real equals: #real1.
	self assert: queue size equals: 1.
	self assert: queue itemCount equals: 2.
	real := queue nextOrNil.
	self assert: real equals: #real2.
	self assert: queue size equals: 0.
	self assert: queue itemCount equals: 1.
	self assert: items last isZombie.


	items := self newItems: 3.
	queue := WaitfreeQueue withAll: items.
	items first object: #real1.
	items second object: queue dummy.
	items last object: #real2.

	real := queue nextOrNilSuchThat: [ :v | v = #real1 ].
	self assert: real equals: #real1.
	self assert: queue size equals: 1.
	self assert: queue itemCount equals: 2.
	real := queue nextOrNilSuchThat: [ :v | v = #real2 ].
	self assert: real equals: #real2.
	self assert: queue size equals: 0.
	self assert: queue itemCount equals: 1.
	self assert: items last isZombie.! !

!WaitfreeQueueTest methodsFor: 'tests' stamp: ''!
testZombieFirst
	"Check that a zombie item at the start of the queue is correctly removed"

	| items queue real |

	items := self newItems: 2.
	queue := WaitfreeQueue withAll: items.
	items first object: queue dummy.
	items last object: #real.

	real := queue nextOrNil.
	self assert: real equals: #real.
	self assert: queue size equals: 0.
	self assert: queue itemCount equals: 1.
	self assert: items last isZombie.


	items := self newItems: 2.
	queue := WaitfreeQueue withAll: items.
	items first object: queue dummy.
	items last object: #real.

	real := queue nextOrNilSuchThat: [ :v | v = #real ].
	self assert: real equals: #real.
	self assert: queue size equals: 0.
	self assert: queue itemCount equals: 1.
	self assert: items last isZombie.! !

!WaitfreeQueueTest methodsFor: 'helper methods' stamp: ''!
newItems: count
	"Answer a collection with the requested number of items"

	| collection |

	collection := OrderedCollection new.
	count timesRepeat: [ collection add: AtomicQueueItem new ].
	^collection! !

!WaitfreeQueueTest methodsFor: 'tests' stamp: ''!
testZombieLast
	"Check that a zombie item at the end of the queue is correctly left"

	| items queue real |

	items := self newItems: 2.
	queue := WaitfreeQueue withAll: items.
	items first object: #real.
	items last object: queue dummy.

	real := queue nextOrNil.
	self assert: real equals: #real.
	self assert: queue size equals: 0.
	self assert: queue itemCount equals: 1.
	self assert: items last isZombie.
	self assert: queue nextOrNil isNil.

	items := self newItems: 2.
	queue := WaitfreeQueue withAll: items.
	items first object: #real.
	items last object: queue dummy.

	real := queue nextOrNilSuchThat: [ :v | v = #real ].
	self assert: real equals: #real.
	self assert: queue size equals: 0.
	self assert: queue itemCount equals: 1.
	self assert: items last isZombie.
	real := queue nextOrNilSuchThat: [ :v | v = #real ].
	self assert: real isNil.
	self assert: queue size equals: 0.
	self assert: queue itemCount equals: 1.! !

!WaitfreeQueueTest methodsFor: 'tests' stamp: ''!
testNextOrNilSuchThat

	| queue |

	queue := WaitfreeQueue new.
	1 to: 10 do: [ :i |
		queue nextPut: i ].

	"Remove the first element"
	self assert: (queue nextOrNilSuchThat: [ :o | o = 1 ]) equals: 1.

	"Remove the last element"
	self assert: (queue nextOrNilSuchThat: [ :o | o = 10 ]) equals: 10.

	"Remove the middle elements"
	4 to: 6 do: [ :i |
		self assert: (queue nextOrNilSuchThat: [ :o | o = i ]) equals: i ].

	"There should be 5 elements left with 1 zombie (the last element)"
	self assert: queue size equals: 5.
	"But... all items removed with #nextOrNilSuchThat: leave zombie behind"
	self assert: queue itemCount equals: 6.
	self assert: queue tail isZombie.

	11 to: 13 do: [ :i |
		queue nextPut: i ].

	#(2 3 7 8 9 11 12 13) do: [ :i |
		self assert: queue nextOrNil equals: i ].

	"There should be 0 elements left with one zombie"
	self assert: queue size equals: 0.
	self assert: queue itemCount equals: 1.

	queue nextPut: 11.
	self assert: queue nextOrNil equals: 11.
	self assert: queue nextOrNil equals: nil.

	"There should be 0 elements left with one zombie"
	self assert: queue size equals: 0.
	self assert: queue itemCount equals: 1.! !

!WaitfreeQueueTest methodsFor: 'tests' stamp: ''!
testNextOrNil

	| queue |

	queue := WaitfreeQueue new.
	1 to: 3 do: [ :i |
		queue 	nextPut: i ].

	"Remove the entries"
	1 to: 3 do: [ :i |
		self assert: queue nextOrNil equals: i ].

	"There should be 0 entries left with no zombies"
	self assert: queue size equals: 0.
	"But a zombie is always left behind"
	self assert: queue itemCount equals: 1.

	"Repeat to check that the number of zombies doesn't grow"
	1 to: 3 do: [ :i |
		queue 	nextPut: i ].

	"Remove the entries"
	1 to: 3 do: [ :i |
		self assert: queue nextOrNil equals: i ].

	"There should be 0 entries left with no zombies"
	self assert: queue size equals: 0.
	"But a zombie is always left behind"
	self assert: queue itemCount equals: 1.! !

!Warning commentStamp: ''!
A Warning is a Notification which by default should be brought to the attention of the user.!
!Warning methodsFor: 'handling' stamp: ''!
defaultAction
	"No one has handled this warning, but now give them a chance to decide how to debug it. 
	If none handles this either then open debugger (see UnhandedError-defaultAction).
	
	Note about naming here: 
	Even if warnings are not errors the absence of a handler for signaled warning is considered as an error by default although it can be resumed because warnings are resumable.
	Therefore #defaultAction for Warning raises an error, an UnhandledError"

	self raiseUnhandledError! !

!Warning methodsFor: '*SUnit-Core' stamp: ''!
manageTestProcessBy: aProcessMonitorTestService
	"Warnings are considered as a test failure.
	So we are recording it in the process monitor"
	
	aProcessMonitorTestService recordTestFailure: self! !

!Warning methodsFor: '*SUnit-Core' stamp: ''!
sunitAnnounce: aTestCase toResult: aTestResult
	aTestResult addFailure: aTestCase.! !

!Warning methodsFor: 'handling' stamp: ''!
unhandledErrorAction

	"No one has handled this warning, then I gave them a chance to decide how to debug it and I raise an UnhandledError. But it was not handled by anybody so that we are here (see UnhandedError-defaultAction).
	It is the final action an exception can do which is normally a debugger in interactive image"

	<debuggerCompleteToSender>
	^UIManager default requestDebuggerOpeningForWarning: self! !

!WarpBlt commentStamp: ''!
WarpBlt is a little warp-drive added on to BitBlt.  It takes a quadrilateral as its source specification, while its destination is traversed and combined just like any other call to copyBits.

The source quadrilateral is specified as an array of points starting with the corner that wants to end up in the topLeft, and proceding to the successive points that want to follow CCW around the destination rectangle.  Note that in specifying a plain old rectangle source, its non topLeft points must be actual pixels, not outside by 1, as with rectangle bottmRight, eg.  See the method Rectangle asQuad.

WarpBlt does a fast job of rotation, reflection and scaling, and it can even produce a semblance of perspective.  Depth parameters are included for future improvements in this direction. but the primitve does not support this yet.!
!WarpBlt methodsFor: 'primitives' stamp: ''!
warpBits
	"Move those pixels!!"

	cellSize < 1 ifTrue: [ ^self error: 'cellSize must be >= 1' ].

	self warpBitsSmoothing: cellSize
		sourceMap: (sourceForm colormapIfNeededForDepth: 32).! !

!WarpBlt methodsFor: 'primitives' stamp: ''!
sourceQuad: pts destRect: aRectangle 
	| fixedPt1 |
	sourceX := sourceY := 0.
	self destRect: aRectangle.
	fixedPt1 := (pts at: 1) x isInteger 
		ifTrue: [ 16384 ]
		ifFalse: [ 16384.0 ].
	p1x := (pts at: 1) x * fixedPt1.
	p2x := (pts at: 2) x * fixedPt1.
	p3x := (pts at: 3) x * fixedPt1.
	p4x := (pts at: 4) x * fixedPt1.
	p1y := (pts at: 1) y * fixedPt1.
	p2y := (pts at: 2) y * fixedPt1.
	p3y := (pts at: 3) y * fixedPt1.
	p4y := (pts at: 4) y * fixedPt1.
	p1z := p2z := p3z := p4z := 16384	"z-warp ignored for now"! !

!WarpBlt methodsFor: 'primitives' stamp: ''!
copyQuad: pts toRect: destRect
	self sourceQuad: pts destRect: destRect.
	self warpBits! !

!WarpBlt methodsFor: 'primitives' stamp: ''!
sourceForm: srcForm destRect: dstRectangle 
	"Set up a WarpBlt from the entire source Form to the given destination rectangle."
	| w h |
	sourceForm := srcForm.
	sourceX := sourceY := 0.
	destX := dstRectangle left.
	destY := dstRectangle top.
	width := dstRectangle width.
	height := dstRectangle height.
	w := 16384 * (srcForm width - 1).
	h := 16384 * (srcForm height - 1).
	p1x := 0.
	p2x := 0.
	p3x := w.
	p4x := w.
	p1y := 0.
	p2y := h.
	p3y := h.
	p4y := 0.
	p1z := p2z := p3z := p4z := 16384	"z-warp ignored for now"! !

!WarpBlt methodsFor: 'setup' stamp: ''!
cellSize: s 
	cellSize := s.
	cellSize = 1 ifTrue: [ ^ self ].
	colorMap := Color 
		colorMapIfNeededFrom: 32
		to: destForm depth! !

!WarpBlt methodsFor: 'smoothing' stamp: ''!
rgbMap: sourcePixel from: nBitsIn to: nBitsOut
	"NOTE: This code is copied verbatim from BitBltSimulation so that it
	may be removed from the system"

	"Convert the given pixel value with nBitsIn bits for each color component to a pixel value with nBitsOut bits for each color component. Typical values for nBitsIn/nBitsOut are 3, 5, or 8."

	<inline: true>
	| mask d srcPix destPix |
	^ (d := nBitsOut - nBitsIn) > 0
		ifTrue: [ "Expand to more bits by zero-fill"
			mask := (1 << nBitsIn) - 1.	"Transfer mask"
			srcPix := sourcePixel << d.
			mask := mask << d.
			destPix := srcPix bitAnd: mask.
			mask := mask << nBitsOut.
			srcPix := srcPix << d.
			destPix + (srcPix bitAnd: mask) + (srcPix << d bitAnd: mask << nBitsOut) ]
		ifFalse: [ "Compress to fewer bits by truncation"
			d = 0 ifTrue: [ ^ sourcePixel ].	"no compression"
			sourcePixel = 0 ifTrue: [ ^ sourcePixel ].	"always map 0 (transparent) to 0"
			d := nBitsIn - nBitsOut.
			mask := (1 << nBitsOut) - 1.	"Transfer mask"
			srcPix := sourcePixel >> d.
			destPix := srcPix bitAnd: mask.
			mask := mask << nBitsOut.
			srcPix := srcPix >> d.
			destPix := destPix + (srcPix bitAnd: mask) + (srcPix >> d bitAnd: mask << nBitsOut).
			destPix = 0 ifTrue: [ ^ 1 ].	"Dont fall into transparent by truncation"
			destPix ]! !

!WarpBlt methodsFor: 'smoothing' stamp: ''!
mixPix: pix sourceMap: sourceMap destMap: destMap
	"Average the pixels in array pix to produce a destination pixel.
	First average the RGB values either from the pixels directly,
	or as supplied in the sourceMap.  Then return either the resulting
	RGB value directly, or use it to index the destination color map."

	| r g b rgb nPix bitsPerColor d |
	nPix := pix size.
	r := 0.
	g := 0.
	b := 0.
	1 to: nPix do: [ :i | 
		"Sum R, G, B values for each pixel"
		rgb := sourceForm depth <= 8
			ifTrue: [ sourceMap at: (pix at: i) + 1 ]
			ifFalse: [ sourceForm depth = 32
					ifTrue: [ pix at: i ]
					ifFalse: [ self rgbMap: (pix at: i) from: 5 to: 8 ] ].
		r := r + ((rgb bitShift: -16) bitAnd: 255).
		g := g + ((rgb bitShift: -8) bitAnd: 255).
		b := b + ((rgb bitShift: 0) bitAnd: 255) ].
	destMap
		ifNil: [ bitsPerColor := 3.	"just in case eg depth <= 8 and no map"
			destForm depth = 16 ifTrue: [ bitsPerColor := 5 ].
			destForm depth = 32 ifTrue: [ bitsPerColor := 8 ] ]
		ifNotNil: [ destMap size = 512 ifTrue: [ bitsPerColor := 3 ].
			destMap size = 4096 ifTrue: [ bitsPerColor := 4 ].
			destMap size = 32768 ifTrue: [ bitsPerColor := 5 ] ].
	d := bitsPerColor - 8.
	rgb := ((r // nPix bitShift: d) bitShift: bitsPerColor * 2) + ((g // nPix bitShift: d) bitShift: bitsPerColor) + ((b // nPix bitShift: d) bitShift: 0).
	^ destMap
		ifNil: [ rgb ]
		ifNotNil: [ destMap at: rgb + 1 ]! !

!WarpBlt methodsFor: 'primitives' stamp: ''!
warpBitsSmoothing: n sourceMap: sourceMap 
	| deltaP12 deltaP43 pA pB deltaPAB sp fixedPtOne picker poker pix nSteps |
	<primitive: 'primitiveWarpBits' module: 'BitBltPlugin'>
	(sourceForm isForm and: 
		[ "Check for compressed source, destination or halftone forms"
		sourceForm unhibernate ]) ifTrue: 
		[ ^ self 
			warpBitsSmoothing: n
			sourceMap: sourceMap ].
	(destForm isForm and: [ destForm unhibernate ]) ifTrue: 
		[ ^ self 
			warpBitsSmoothing: n
			sourceMap: sourceMap ].
	(halftoneForm isForm and: [ halftoneForm unhibernate ]) ifTrue: 
		[ ^ self 
			warpBitsSmoothing: n
			sourceMap: sourceMap ].
	width < 1 | (height < 1) ifTrue: [ ^ self ].
	fixedPtOne := 16384.	"1.0 in fixed-pt representation"
	n > 1 ifTrue: 
		[ (destForm depth < 16 and: [ colorMap == nil ]) ifTrue: 
			[ "color map is required to smooth non-RGB dest"
			^ self primitiveFailed ].
		pix := Array new: n * n ].
	nSteps := height - 1 max: 1.
	deltaP12 := (self 
		deltaFrom: p1x
		to: p2x
		nSteps: nSteps) @ (self 
			deltaFrom: p1y
			to: p2y
			nSteps: nSteps).
	pA := (self 
		startFrom: p1x
		to: p2x
		offset: nSteps * deltaP12 x) @ (self 
			startFrom: p1y
			to: p2y
			offset: nSteps * deltaP12 y).
	deltaP43 := (self 
		deltaFrom: p4x
		to: p3x
		nSteps: nSteps) @ (self 
			deltaFrom: p4y
			to: p3y
			nSteps: nSteps).
	pB := (self 
		startFrom: p4x
		to: p3x
		offset: nSteps * deltaP43 x) @ (self 
			startFrom: p4y
			to: p3y
			offset: nSteps * deltaP43 y).
	picker := BitBlt bitPeekerFromForm: sourceForm.
	poker := BitBlt bitPokerToForm: destForm.
	poker clipRect: self clipRect.
	nSteps := width - 1 max: 1.
	destY 
		to: destY + height - 1
		do: 
			[ :y | 
			deltaPAB := (self 
				deltaFrom: pA x
				to: pB x
				nSteps: nSteps) @ (self 
					deltaFrom: pA y
					to: pB y
					nSteps: nSteps).
			sp := (self 
				startFrom: pA x
				to: pB x
				offset: nSteps * deltaPAB x) @ (self 
					startFrom: pA y
					to: pB y
					offset: nSteps * deltaPAB x).
			destX 
				to: destX + width - 1
				do: 
					[ :x | 
					n = 1 
						ifTrue: 
							[ poker 
								pixelAt: x @ y
								put: (picker pixelAt: sp // fixedPtOne asPoint) ]
						ifFalse: 
							[ 0 
								to: n - 1
								do: 
									[ :dx | 
									0 
										to: n - 1
										do: 
											[ :dy | 
											pix 
												at: dx * n + dy + 1
												put: (picker pixelAt: (sp + (deltaPAB * dx // n) + (deltaP12 * dy // n)) // fixedPtOne asPoint) ] ].
							poker 
								pixelAt: x @ y
								put: (self 
										mixPix: pix
										sourceMap: sourceMap
										destMap: colorMap) ].
					sp := sp + deltaPAB ].
			pA := pA + deltaP12.
			pB := pB + deltaP43 ]! !

!WarpBlt methodsFor: 'primitives' stamp: ''!
startFrom: x1 to: x2 offset: sumOfDeltas
	"Utility routine for computing Warp increments."

	^ x2 >= x1
		ifTrue: [ x1 ]
		ifFalse: [ x2 - sumOfDeltas ]! !

!WarpBlt methodsFor: 'setup' stamp: ''!
cellSize
	^ cellSize! !

!WarpBlt methodsFor: 'primitives' stamp: ''!
deltaFrom: x1 to: x2 nSteps: n
	"Utility routine for computing Warp increments.
	x1 is starting pixel, x2 is ending pixel;  assumes n >= 1"

	| fixedPtOne |
	fixedPtOne := 16384.	"1.0 in fixed-pt representation"
	^ x2 > x1
		ifTrue: [ (x2 - x1 + fixedPtOne) // (n + 1) + 1 ]
		ifFalse: [ x2 = x1 ifTrue: [ ^ 0 ].
			0 - ((x1 - x2 + fixedPtOne) // (n + 1) + 1) ]! !

!WarpBlt class methodsFor: 'form rotation' stamp: ''!
rotate: srcForm degrees: angleInDegrees center: aPoint scaleBy: scalePoint smoothing: cellSize 
	"Rotate the given Form the given number of degrees about the given center and scale its width and height by x and y of the given scale point. Smooth using the given cell size, an integer between 1 and 3, where 1 means no smoothing. Return a pair where the first element is the rotated Form and the second is the position offset required to align the center of the rotated Form with that of the original. Note that the dimensions of the resulting Form generally differ from those of the original."
	| srcRect center radians dstOrigin dstCorner p dstRect inverseScale quad dstForm newCenter warpSrc |
	srcRect := srcForm boundingBox.
	center := srcRect center.
	radians := angleInDegrees degreesToRadians.
	dstOrigin := dstCorner := center.
	srcRect corners do: 
		[ :corner | 
		"find the limits of a rectangle that just encloses the rotated
		 original; in general, this rectangle will be larger than the
		 original (e.g., consider a square rotated by 45 degrees)"
		p := (corner - center scaleBy: scalePoint) + center.
		p := (p 
			rotateBy: radians
			about: center) rounded.
		dstOrigin := dstOrigin min: p.
		dstCorner := dstCorner max: p ].

	"rotate the enclosing rectangle back to get the source quadrilateral"
	dstRect := dstOrigin corner: dstCorner.
	inverseScale := (1.0 / scalePoint x) @ (1.0 / scalePoint y).
	quad := dstRect innerCorners collect: 
		[ :corner | 
		p := corner 
			rotateBy: radians negated
			about: center.
		(p - center scaleBy: inverseScale) + center ].

	"make a Form to hold the result and do the rotation"
	warpSrc := srcForm.
	srcForm isColorForm 
		ifTrue: 
			[ cellSize > 1 | true 
				ifTrue: 
					[ "ar 12/27/2001: Always enable - else sketches won't work"
					warpSrc := Form 
						extent: srcForm extent
						depth: 16.
					srcForm displayOn: warpSrc.
					dstForm := Form 
						extent: dstRect extent
						depth: 16	"use 16-bit depth to allow smoothing" ]
				ifFalse: 
					[ dstForm := srcForm class 
						extent: dstRect extent
						depth: srcForm depth ] ]
		ifFalse: 
			[ dstForm := srcForm class 
				extent: dstRect extent
				depth: srcForm depth ].
	(WarpBlt toForm: dstForm)
		sourceForm: warpSrc;
		colorMap: (warpSrc colormapIfNeededFor: dstForm);
		cellSize: cellSize;
		combinationRule: Form paint;
		copyQuad: quad
			toRect: dstForm boundingBox.	"installs a new colormap if cellSize > 1"
	dstForm isColorForm ifTrue: [ dstForm colors: srcForm colors copy ].
	newCenter := (center 
		rotateBy: radians
		about: aPoint) truncated.
	^ Array 
		with: dstForm
		with: dstRect origin + (newCenter - center)! !

!WarpBlt class methodsFor: 'initialization' stamp: ''!
toForm: destinationForm
	"Default cell size is 1 (no pixel smoothing)"
	^ (super toForm: destinationForm) cellSize: 1! !

!Watch commentStamp: ''!
A Watch save the change of values of expressions. 
I save them as an ordered collection of  key val association where the key is the timestamp an val is the actual value of the expression.

To install a Watch in a node: 
Watch in: aNode!
!Watch methodsFor: 'accessing' stamp: ''!
tagname
	^ tagname! !

!Watch methodsFor: 'recording' stamp: ''!
isRecording
	^recording! !

!Watch methodsFor: 'accessing' stamp: ''!
node: anObject
	node := anObject! !

!Watch methodsFor: 'recording' stamp: ''!
stop
	recording := false.
	link announceChange! !

!Watch methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	values := OrderedCollection new.
	recording := true.! !

!Watch methodsFor: 'install' stamp: ''!
install

	node hasWatch ifTrue: [ self error: 'Node already has a Watchpoint'].
	
	link := MetaLink new 
				metaObject: self;
				selector: #addValue:;
				arguments: #(value);
				control: #after;
				condition: [ recording ];
				option: #(+ optionWeakAfter +optionAnnounce).
	node link: link.
	self class allWatches at: node put: self.! !

!Watch methodsFor: 'accessing' stamp: ''!
node
	^ node! !

!Watch methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream nextPutAll: 'WP'.
	tagname isAllSeparators 
		ifFalse: [ 
			aStream nextPutAll: ' '.
			aStream nextPutAll: tagname ]. 
	aStream nextPutAll: ': '.
	aStream nextPutAll: (self printLastValue).! !

!Watch methodsFor: 'cleanup' stamp: ''!
deleteHistory
	values := OrderedCollection new.! !

!Watch methodsFor: 'adding' stamp: ''!
addValue: anObject
	values add: 
		(DateAndTime now -> anObject).
	^anObject.
! !

!Watch methodsFor: 'accessing' stamp: ''!
values
	^values.! !

!Watch methodsFor: 'printing' stamp: ''!
printLastValue
	values ifNil: [ ^''].
	values ifEmpty: [ ^'not run' ].
	^values last value printStringLimitedTo: 5.! !

!Watch methodsFor: 'recording' stamp: ''!
start
	recording := true.
	link announceChange! !

!Watch methodsFor: 'accessing' stamp: ''!
compiledMethod 
	^self node methodNode method! !

!Watch methodsFor: 'install' stamp: ''!
uninstall
	node hasWatch ifFalse: [ ^self ].
	link uninstall.
	self class allWatches removeKey: node.! !

!Watch methodsFor: 'accessing' stamp: ''!
tagname: anObject
	tagname := anObject! !

!Watch class methodsFor: 'accessing' stamp: ''!
allWatches
	^ Watches ifNil: [ Watches := WeakKeyDictionary new ]! !

!Watch class methodsFor: 'accessing' stamp: ''!
from: aNode
	^self allWatches at: aNode.! !

!Watch class methodsFor: 'cleanup' stamp: ''!
deleteHistoryFrom: aNode

	(self allWatches at: aNode ifAbsent:[^self]) deleteHistory! !

!Watch class methodsFor: 'accessing' stamp: ''!
from: aNode ifAbsent: aBlock
	^self allWatches at: aNode ifAbsent: aBlock.! !

!Watch class methodsFor: 'instance creation' stamp: ''!
in: aRBProgramNode named: aName
	aRBProgramNode hasWatch ifTrue: [ ^ aRBProgramNode watch ].
	^self new 
		node: aRBProgramNode;
		tagname: aName;
		install.! !

!Watch class methodsFor: 'cleanup' stamp: ''!
deleteAllHistory

	self allWatches valuesDo: [ :aWatch| aWatch deleteHistory].! !

!Watch class methodsFor: 'cleanup' stamp: ''!
removeAll
	self allWatches values do: [ :aWatchpoint| aWatchpoint uninstall].
	Watches := nil.! !

!Watch class methodsFor: 'cleanup' stamp: ''!
removeFrom: aNode

	(self allWatches at: aNode ifAbsent: [ ^self ]) uninstall! !

!Watch class methodsFor: 'instance creation' stamp: ''!
in: aRBProgramNode
	^self in: aRBProgramNode named: ''.! !

!WatchIconStyler commentStamp: ''!
I'm in charge to style an ast when there are watchpoints!
!WatchIconStyler methodsFor: 'defaults' stamp: ''!
iconBlock: aNode
	^[ WatchesWindow openOn: aNode watch]! !

!WatchIconStyler methodsFor: 'defaults' stamp: ''!
highlightColor
	^(Color purple alpha: 0.1)! !

!WatchIconStyler methodsFor: 'defaults' stamp: ''!
iconLabel: aNode

	^ aNode watch asString.! !

!WatchIconStyler methodsFor: 'testing' stamp: ''!
shouldStyleNode: aNode
	^aNode hasWatch! !

!WatchIconStyler methodsFor: 'defaults' stamp: ''!
iconFor: aNode
	^aNode watch isRecording
		ifTrue: [ self iconNamed: #testGreen]
		ifFalse: [ self iconNamed: #testNotRunIcon ]
	! !

!WatchTest methodsFor: 'adding' stamp: ''!
testWatchTwice
	|node watchpoint|
	
	node := (ReflectivityExamples>>#exampleAssignment) ast body statements first.
	watchpoint := Watch in: node.
	
	self should: [watchpoint install] raise: Error.
	
	watchpoint uninstall.! !

!WatchTest methodsFor: 'adding' stamp: ''!
testAddWatchSameNode
	| node watchpoint watchpoint2 |
	node := (ReflectivityExamples >> #exampleAssignment) ast body children first.
	watchpoint := Watch in: node.
	watchpoint2 := Watch in: node.

	self assert: watchpoint equals: watchpoint2.

	watchpoint uninstall.

	self deny: node hasWatch! !

!WatchTest methodsFor: 'deleting history' stamp: ''!
testDeleteHistoryFromNode
	| node watchpoint |
	node := (ReflectivityExamples >> #exampleAssignmentIvar:) ast body children first.
	watchpoint := Watch in: node.
	ReflectivityExamples new exampleAssignmentIvar: 1.
	ReflectivityExamples new exampleAssignmentIvar: 2.

	self assert: watchpoint values first value equals: 1.
	self assert: watchpoint values second value equals: 2.

	Watch deleteHistoryFrom: node.
	self assertEmpty: watchpoint values.

	watchpoint uninstall! !

!WatchTest methodsFor: 'values' stamp: ''!
testSaveOneValue
	| node watchpoint |
	node := (ReflectivityExamples >> #exampleAssignmentIvar) ast body children first.
	watchpoint := Watch in: node.
	ReflectivityExamples new exampleAssignmentIvar.

	self assert: watchpoint values first value equals: 3.

	watchpoint uninstall! !

!WatchTest methodsFor: 'adding' stamp: ''!
testAddWatch
	| node watchpoint |
	node := (ReflectivityExamples >> #exampleAssignment) ast body children first.
	watchpoint := Watch in: node.

	self assert: node hasWatch.
	self assert: (Watch allWatches at: node) equals: watchpoint.

	watchpoint uninstall.
	self deny: node hasWatch.
	self deny: (Watch allWatches includesKey: node)! !

!WatchTest methodsFor: 'adding' stamp: ''!
testAddSameWatchSameNode
	| node watchpoint watchpoint2 |
	node := (ReflectivityExamples >> #exampleAssignment) ast body children first.
	watchpoint := Watch in: node.
	watchpoint2 := Watch in: node.

	self assert: watchpoint equals: watchpoint2.

	watchpoint uninstall.

	self deny: node hasWatch! !

!WatchTest methodsFor: 'deleting history' stamp: ''!
testDeleteHistory
	| node watchpoint |
	node := (ReflectivityExamples >> #exampleAssignmentIvar:) ast body children first.
	watchpoint := Watch in: node.
	ReflectivityExamples new exampleAssignmentIvar: 1.
	ReflectivityExamples new exampleAssignmentIvar: 2.

	self assert: watchpoint values first value equals: 1.
	self assert: watchpoint values second value equals: 2.

	watchpoint deleteHistory.
	self assertEmpty: watchpoint values.

	watchpoint uninstall! !

!WatchTest methodsFor: 'values' stamp: ''!
testSendMessage
	| node watchpoint |
	node := (ReflectivityExamples >> #exampleMessageSend) ast body children first.
	watchpoint := Watch in: node.
	ReflectivityExamples new exampleMessageSend.

	self assert: watchpoint values first value class equals: ReflectivityExamples.

	watchpoint uninstall! !

!WatchTest methodsFor: 'values' stamp: ''!
testTimestamp
	|node watchpoint|
	
	node := (ReflectivityExamples>>#exampleAssignmentIvar:) ast body children first.
	watchpoint := Watch in: node.
	
	1 to: 10 do:[:i| ReflectivityExamples new exampleAssignmentIvar: i].
	1 to: 9 do: [:i|  
		|older newer|
		older := watchpoint values at: i.
		newer := watchpoint values at: i + 1.
		self assert: (older key <= newer key).
	]. 
	
	watchpoint uninstall.
	! !

!WatchTest methodsFor: 'values' stamp: ''!
testSaveValues
	| node watchpoint |
	node := (ReflectivityExamples >> #exampleAssignmentIvar:) ast body children first.
	watchpoint := Watch in: node.
	ReflectivityExamples new exampleAssignmentIvar: 1.
	ReflectivityExamples new exampleAssignmentIvar: 2.

	self assert: watchpoint values first value equals: 1.
	self assert: watchpoint values second value equals: 2.

	watchpoint uninstall! !

!WatchTest methodsFor: 'recording' stamp: ''!
testStopRecording
	| node watchpoint dummy |
	node := (ReflectivityExamples >> #exampleAssignmentIvar:) ast body children first.
	watchpoint := Watch in: node.
	dummy := ReflectivityExamples new.

	dummy exampleAssignmentIvar: 1.
	dummy exampleAssignmentIvar: 2.
	self assert: watchpoint values size equals: 2.
	self assert: watchpoint values second value equals: 2.

	watchpoint stop.
	dummy exampleAssignmentIvar: 3.
	self assert: watchpoint values size equals: 2.

	watchpoint start.
	dummy exampleAssignmentIvar: 4.
	self assert: watchpoint values size equals: 3.
	self assert: watchpoint values third value equals: 4.

	watchpoint uninstall.

	self deny: node hasWatch! !

!WatchTest methodsFor: 'deleting history' stamp: ''!
testDeleteAllHistory
	| node1 node2 watchpoint1 watchpoint2 |
	node1 := (ReflectivityExamples >> #exampleAssignmentIvar:) ast body statements first.
	watchpoint1 := Watch in: node1.
	node2 := (ReflectivityExamples >> #exampleAssignmentIvar) ast body statements first.
	watchpoint2 := Watch in: node2.

	ReflectivityExamples new exampleAssignmentIvar: 2.
	ReflectivityExamples new exampleAssignmentIvar.

	self assert: watchpoint1 values first value equals: 2.
	self assert: watchpoint2 values first value equals: 3.

	Watch deleteAllHistory.

	self assertEmpty: watchpoint1 values.
	self assertEmpty: watchpoint2 values.

	watchpoint1 uninstall.
	watchpoint2 uninstall! !

!WatchesWindow commentStamp: ''!
I am a minimal user interface that shows the last entries in the watchpoint history.!
!WatchesWindow methodsFor: 'configuration' stamp: ''!
moreItems
	numItems := numItems + 1! !

!WatchesWindow methodsFor: 'accessing' stamp: ''!
menu: anObject
	menu := anObject! !

!WatchesWindow methodsFor: 'initialization' stamp: ''!
initializeWidgets

	list := self newList.
	inspectIt := self newButton.
	
	self setupMenu.
	
	list displayBlock: [ :assoc | assoc value asString].
	numItems := 7.
	self refreshItems.
	
	inspectIt label: 'Inspect...'.
	inspectIt enabled: false.! !

!WatchesWindow methodsFor: 'updating' stamp: ''!
step
	self refreshItems ! !

!WatchesWindow methodsFor: 'accessing' stamp: ''!
inspectIt
	^ inspectIt! !

!WatchesWindow methodsFor: 'configuration' stamp: ''!
lessItems
	numItems := 0 max: (numItems - 1)! !

!WatchesWindow methodsFor: 'updating' stamp: ''!
refreshItems
	| max values |
	values := self watch values.
	max := values size.
	list items: (values copyFrom: (1 max: max - numItems) to: max) reversed. ! !

!WatchesWindow methodsFor: 'accessing' stamp: ''!
defaultWindowModelClass

	^ TickingWindowPresenter! !

!WatchesWindow methodsFor: 'api' stamp: ''!
extent
	^230@240! !

!WatchesWindow methodsFor: 'accessing' stamp: ''!
menu
	^ menu! !

!WatchesWindow methodsFor: 'initialization' stamp: ''!
setupMenu
	menu := MenuPresenter new.
	menu applyTo: self.
	menu
		addGroup: [ :group | 
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Show More Items';
						icon: (self iconNamed: #up);
						action: [ self moreItems ] ].
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Show Less Items';
						icon: (self iconNamed: #down);
						action: [ self lessItems ] ].
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Remove All Items';
						icon: (self iconNamed: #smallDelete);
						action: [ self watch deleteHistory ] ] ].
	menu
		addGroup: [ :group | 
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Stop Monitoring';
						icon: (self iconNamed: #stop);
						action: [ self watch stop ] ].
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Start Monitoring';
						icon: (self iconNamed: #smallPrintIt);
						action: [ self watch start ] ] ].
	menu
		addGroup: [ :group | 
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Inspect ...';
						icon: (self iconNamed: #smallInspectIt);
						action: [ self watch inspect ] ].
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Browse ...';
						icon: (self iconNamed: #nautilus);
						action:
								[ Smalltalk tools browser openOnMethod: self watch compiledMethod ] ].
			group
				addItem: [ :item | 
					item
						name: nil;
						description: 'Remove !!';
						icon: (self iconNamed: #delete);
						action: [ self watch uninstall ] ] ]! !

!WatchesWindow methodsFor: 'accessing' stamp: ''!
watch: anObject
	watch := anObject! !

!WatchesWindow methodsFor: 'accessing' stamp: ''!
watch
	^ watch! !

!WatchesWindow methodsFor: 'accessing' stamp: ''!
inspectIt: anObject
	inspectIt := anObject! !

!WatchesWindow methodsFor: 'accessing' stamp: ''!
list: anObject
	list := anObject! !

!WatchesWindow methodsFor: 'api' stamp: ''!
title
	| wpName |
	wpName := self watch tagname.
	^'WP: ',(wpName isAllSeparators ifTrue: [ 'Unnamed' ] ifFalse: [ wpName ]).! !

!WatchesWindow methodsFor: 'accessing' stamp: ''!
list
	^ list! !

!WatchesWindow methodsFor: 'initialization' stamp: ''!
initializePresenter 
	
	list whenSelectionChanged: [inspectIt enabled: (list getIndex = 0) not ].
	
	"have to do it this way because list selectedItem is the originally selected item"
	inspectIt action: [ |index |
		index := list getIndex.
		index = 0 ifFalse: [ (list listItems at: index) inspect ]]! !

!WatchesWindow class methodsFor: 'instance creation' stamp: ''!
new
	"use on: aWatchpoint"
	^self shouldNotImplement ! !

!WatchesWindow class methodsFor: 'instance creation' stamp: ''!
openOn: aWatchpoint
	^(self on: aWatchpoint) openWithSpec! !

!WatchesWindow class methodsFor: 'instance creation' stamp: ''!
on: aWatchpoint
	| inst |
	inst := self basicNew.
	inst watch: aWatchpoint.
	inst initialize.
	^inst! !

!WatchesWindow class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec: #default>
	^ SpecLayout composed
		newColumn: [ :col |
			col
				add: #menu height: (self toolbarHeight);
				add: #list;
				add: #inspectIt height: self toolbarHeight ]! !

!WeakActionSequence commentStamp: ''!
Weak action sequences for events!
!WeakActionSequence methodsFor: 'converting' stamp: ''!
asMinimalRepresentation

	| valid |
	valid := self select: [:e | e isValid ].
	valid size = 0
		ifTrue: [^nil].
	valid size = 1
		ifTrue: [^valid first].
	^valid! !

!WeakActionSequence methodsFor: 'converting' stamp: ''!
asActionSequence

	^self! !

!WeakActionSequence methodsFor: 'printing' stamp: ''!
printOn: aStream

	self size < 2 ifTrue: [^super printOn: aStream].
	aStream nextPutAll: '#('.
	self
		do: [:each | each printOn: aStream]
		separatedBy: [aStream cr].
	aStream nextPut: $)! !

!WeakActionSequence methodsFor: 'evaluating' stamp: ''!
value
    "Answer the result of evaluating the elements of the receiver.
	Actually, return just the last result."

    | answer |
    self do:
        [:each | each isValid ifTrue: [answer := each value]].
    ^answer! !

!WeakActionSequence methodsFor: 'evaluating' stamp: ''!
valueWithArguments: anArray

	"Return the last result"

    | answer |
    self do:
        [:each |
        	each isValid ifTrue: [answer := each valueWithArguments: anArray]].
    ^answer! !

!WeakAnnouncementSubscription commentStamp: ''!
A WeakAnnouncementSubscription is a subscription which is removed automatically when the subscriber is unreferenced.

No support for ephemerons currently prevents this from working for Block actions (blocks hold their receiver, which is the default subscriber strongly). 

To switch between subscription types, use makeStrong/makeWeak on the subscription returned when initially registering with announcer.


Note, that list and next must be first instance variables.!
!WeakAnnouncementSubscription methodsFor: 'accessing' stamp: ''!
action: anObject

	action := anObject! !

!WeakAnnouncementSubscription methodsFor: 'announcing' stamp: ''!
deliver: anAnnouncement
	" deliver an announcement to receiver. In case of failure, it will be handled in separate process"

	^ (self handlesAnnouncement: anAnnouncement ) ifTrue: [
		[action cull: anAnnouncement cull: announcer] 
			on: UnhandledError fork: [:ex | ex pass ]]! !

!WeakAnnouncementSubscription methodsFor: 'initialization' stamp: ''!
initialize
	list := self class finalizationList! !

!WeakAnnouncementSubscription methodsFor: 'accessing' stamp: ''!
next
	^ next! !

!WeakAnnouncementSubscription methodsFor: 'accessing' stamp: ''!
action

	^ action! !

!WeakAnnouncementSubscription methodsFor: 'accessing' stamp: ''!
subscriber

	^ self basicAt: 1! !

!WeakAnnouncementSubscription methodsFor: 'finalization' stamp: ''!
register
	self weakRegistry 
		add: self subscriber executor: self! !

!WeakAnnouncementSubscription methodsFor: 'accessing' stamp: ''!
valuable: aValuable
	"Used when subscriber should be extracted from valuable object"
	self action:  aValuable.
	self subscriber: aValuable receiver.! !

!WeakAnnouncementSubscription methodsFor: 'printing' stamp: ''!
printOn: stream

	super printOn: stream.
	
	stream 
		nextPut: $(;
		print: action;
		nextPut: $).! !

!WeakAnnouncementSubscription methodsFor: 'accessing' stamp: ''!
announcementClass

	^ announcementClass! !

!WeakAnnouncementSubscription methodsFor: 'accessing' stamp: ''!
announcementClass: anObject

	announcementClass := anObject! !

!WeakAnnouncementSubscription methodsFor: 'finalization' stamp: ''!
weakRegistry
	^ WeakRegistry default! !

!WeakAnnouncementSubscription methodsFor: 'accessing' stamp: ''!
announcer: anAnnouncer
	announcer := anAnnouncer! !

!WeakAnnouncementSubscription methodsFor: 'converting' stamp: ''!
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)! !

!WeakAnnouncementSubscription methodsFor: 'converting' stamp: ''!
makeWeak
	^ self! !

!WeakAnnouncementSubscription methodsFor: 'finalization' stamp: ''!
unregister

	self subscriber ifNotNil: [:sub |  self weakRegistry remove: sub ]! !

!WeakAnnouncementSubscription methodsFor: 'error handling' stamp: ''!
handlesAnnouncement: anAnnouncement

	^ announcementClass handlesAnnouncement: anAnnouncement! !

!WeakAnnouncementSubscription methodsFor: 'finalization' stamp: ''!
finalize

	announcer removeSubscription: self.! !

!WeakAnnouncementSubscription methodsFor: 'accessing' stamp: ''!
announcer

	^ announcer! !

!WeakAnnouncementSubscription methodsFor: 'accessing' stamp: ''!
subscriber: anObject

	self subscriber ifNotNil: [ self error: 'subscriber already set' ].
	self basicAt: 1 put: anObject.
	self register! !

!WeakAnnouncementSubscription class methodsFor: 'instance creation' stamp: ''!
new
	^ (self basicNew: 1) initialize! !

!WeakAnnouncementSubscription class methodsFor: 'class initialization' stamp: ''!
initialize
	"self initialize"
	
	
	WeakArray 
		removeWeakDependent: self;
		addWeakDependent: self
		
	"Make sure that it is not added twice."! !

!WeakAnnouncementSubscription class methodsFor: 'finalization' stamp: ''!
finalizationList
	
	^ FinalizationList ifNil: [ FinalizationList := WeakFinalizationList new ].! !

!WeakAnnouncementSubscription class methodsFor: 'finalization' stamp: ''!
finalizeValues
	
	| head |
	
	head := self finalizationList swapWithNil.
	
	[ head notNil ] whileTrue: [ 
		head finalize.
		head := head next
	].! !

!WeakAnnouncerTest commentStamp: ''!
SUnit tests for weak announcements!
!WeakAnnouncerTest methodsFor: 'tests' stamp: ''!
testNoDeadWeakSubscriptions
	self longTestCase.
	"we skip this on the ci as it impact all other ci checks, open issue https://github.com/pharo-project/pharo/issues/2471"
	self skipOnPharoCITestingEnvironment.

	5 timesRepeat: [ Smalltalk garbageCollect ].

	self assertEmpty: (WeakAnnouncementSubscription allInstances select: [ :sub | sub subscriber isNil ]).

	self assertEmpty: (WeakAnnouncementSubscription allInstances select: [ :sub | sub subscriber isNil ])! !

!WeakAnnouncerTest methodsFor: 'utilities' stamp: ''!
longTestCase

	self timeLimit: 60 seconds.! !

!WeakAnnouncerTest methodsFor: 'benchmarks' stamp: ''!
benchWeakSubscriptionDynamic
	"Run me to see how expensive #becomeForward: is (compared to #benchWeakSubscriptionStatic )"
	
	| object ann |
	
	object := Object new.
	ann := Announcer new.
	
	^[
		1000 timesRepeat: [ (ann when: Announcement send: #value to: object) makeWeak ].
	] timeToRun! !

!WeakAnnouncerTest methodsFor: 'tests' stamp: ''!
testNoWeakBlock
	"There is no such thing as a weak block, these things never go away."

	<expectedFailure>

	| counter |

	self longTestCase.

	counter := 0.

	(announcer when: AnnouncementMockA do: [ :ann | counter := counter + 1 ]) makeWeak.
	
	Smalltalk garbageCollect.
	announcer announce: AnnouncementMockA.
	self assert: counter equals: 1.
	
	Smalltalk garbageCollect.
	announcer announce: AnnouncementMockA.
	self assert: counter equals: 2! !

!WeakAnnouncerTest methodsFor: 'benchmarks' stamp: ''!
benchWeakSubscriptionStatic
	"Run me to see how cheap object creation is (compared to #benchWeakSubscriptionDynamic ) "

	| object ann |
	
	object := Object new.
	ann := Announcer new.
	
	^[
		1000 timesRepeat: [ (ann weak when: Announcement send: #value to: object)  ].
	] timeToRun! !

!WeakAnnouncerTest methodsFor: 'benchmarks' stamp: ''!
benchManyWeakGuys

	| object ann time |
	
	object := Object new.
	ann := Announcer new.
	
	50000 timesRepeat: [ (ann weak when: Announcement send: #value to: object) ].
	
	self assert: ann numberOfSubscriptions equals: 50000.
	
	Smalltalk garbageCollect.
	
	time := [object := nil.
		Smalltalk garbageCollect. 
		 ]timeToRun.
	
	self assert: ann numberOfSubscriptions equals: 0.
	^ time! !

!WeakAnnouncerTest methodsFor: 'tests' stamp: ''!
testWeakSubscription
	| obj subscription |
	self longTestCase.

	obj := Object new.

	subscription := (announcer when: AnnouncementMockA send: #value to: obj) makeWeak.

	self assert: obj identicalTo: subscription subscriber! !

!WeakAnnouncerTest methodsFor: 'tests' stamp: ''!
testWeakObject
	| counter collector forwarder |

	self longTestCase.

	counter := 0.
	collector := [ counter := counter + 1 ].
	forwarder := MessageSend receiver: collector selector: #value.
	(announcer when: AnnouncementMockA send: #value to: forwarder) makeWeak.
	
	" shouldn't go away, we are still holding a reference to 'forwarder': "
	Smalltalk garbageCollect.
	announcer announce: AnnouncementMockA.
	self assert: counter equals: 1.
	
	" should go away as we let the only reference to 'forwarder' go: "
	forwarder := nil.
	Smalltalk garbageCollect.
	announcer announce: AnnouncementMockA.
	self assert: counter equals: 1! !

!WeakAnnouncerTest methodsFor: 'tests' stamp: ''!
testWeakSubscriptionRelease
	"This test shows the a problem with weak registrations not garbage collected in Spur.
	 See https://pharo.manuscript.com/f/cases/17537 for more details."
	self benchManyWeakGuys! !

!WeakAnnouncerTest methodsFor: 'tests' stamp: ''!
testWeakDoubleAnnouncer

	| a1 a2 o |
	
	self longTestCase.

	a1 := Announcer new.
	a2 := Announcer new.
	
	o := Object new.
	
	self 
	assert: a1 subscriptions numberOfSubscriptions isZero;
	assert: a2 subscriptions numberOfSubscriptions isZero.
	
	a1 weak when: Announcement send: #abcdef to: o.
	a2 weak when: Announcement send: #abcdef to: o.	
	
	self 
	assert: a1 subscriptions numberOfSubscriptions equals: 1;
	assert: a2 subscriptions numberOfSubscriptions equals: 1.
	
	3 timesRepeat: [ Smalltalk garbageCollect ].
	
	self 
	assert: a1 subscriptions numberOfSubscriptions equals: 1;
	assert: a2 subscriptions numberOfSubscriptions equals: 1.	

	o := nil.
	
	3 timesRepeat: [ Smalltalk garbageCollect ].
	
	self 
	assert: a1 subscriptions numberOfSubscriptions isZero;
	assert: a2 subscriptions numberOfSubscriptions isZero.! !

!WeakArray commentStamp: ''!
WeakArray is an array which holds only weakly on its elements. This means whenever an object is only referenced by instances of WeakArray it will be garbage collected.!
!WeakArray class methodsFor: '*System-Finalization' stamp: ''!
mournLoopWith: firstMourner
	"Send mourn to all the objects available in the mourn queue, starting
	 with firstMourner which the sender has already extracted for us.  If
	 an error occurs here, it will break this loop but the sender will spawn
	 another mournLoopWith: so that finalization is not broken by errors in
	 individual cases."
	| mourner |
	mourner := firstMourner.
	[mourner mourn.
	 (mourner := self primitiveFetchMourner) notNil] whileTrue! !

!WeakArray class methodsFor: 'class initialization' stamp: ''!
initialize
	"Do we need to initialize specialObjectsArray?"
	Smalltalk specialObjectsArray size < 42 
		ifTrue: [Smalltalk recreateSpecialObjectsArray].

	SessionManager default
		registerSystemClassNamed: self name.

	FinalizationSemaphore := Smalltalk specialObjectsArray at: 42.
	FinalizationLock := Semaphore forMutualExclusion.
	FinalizationDependents ifNil: [FinalizationDependents := WeakArray new: 10].! !

!WeakArray class methodsFor: 'accessing' stamp: ''!
runningFinalizationProcess
	"Answer the FinalizationProcess I am running, if any"
	^FinalizationProcess! !

!WeakArray class methodsFor: 'private' stamp: ''!
pvtCreateTemporaryObjectIn: tempObject
	"We have to create the temporary object in a separate stack frame"
	tempObject at: 1 put: Object new! !

!WeakArray class methodsFor: '*System-Finalization' stamp: ''!
doOldFinalization
	"Process the weak registries, in the old finalization style.  Hopefully this will
	 eventually go away when all clients have adopted the new finalization scheme."
	FinalizationLock critical: [
			FinalizationDependents do: 	[:weakDependent |
				weakDependent ifNotNil: [
					[ weakDependent finalizeValues ] on: Exception fork: [:ex | ex pass ] ]]].! !

!WeakArray class methodsFor: '*System-Finalization' stamp: ''!
primitiveFetchMourner
	"Answer the next mourner in the VM's queue of objects to be finalized.
	 The queue contains weak arrays and ephemerons.  If the primitive is
	 not implemented, raise an error telling people to upgrade the VM.  If
	 implemented, the primitive fails if the queue is empty, with the error
	 code #'not found'. Primitive.  Essential."

	<primitive: 172 error: ec>
	ec ifNil: [^self error: 'The primitiveFetchMourner primitive is missing.\Please upgrade your virtual machine to one that has the primitive.' withCRs].
	^nil! !

!WeakArray class methodsFor: 'accessing' stamp: ''!
removeWeakDependent: anObject
	FinalizationLock critical:[
		1 to: FinalizationDependents size do:[:i|
			((FinalizationDependents at: i) == anObject) ifTrue:[
				FinalizationDependents at: i put: nil.
			].
		].
	] ifError: [:err | err signal].! !

!WeakArray class methodsFor: '*System-Finalization' stamp: ''!
startUp: resuming
	resuming ifFalse: [ ^self ].
	self restartFinalizationProcess.! !

!WeakArray class methodsFor: 'accessing' stamp: ''!
addWeakDependent: anObject
	
	FinalizationLock critical:[ | index finished weakDependent |
		finished := false.
		index := 0.
		[index := index + 1.
		finished not and:[index <= FinalizationDependents size]] whileTrue:[
			weakDependent := FinalizationDependents at: index.
			weakDependent ifNil: [
				FinalizationDependents at: index put: anObject.
				finished := true.
			].
		].
		finished ifFalse:[
			"Grow linearly"
			FinalizationDependents := FinalizationDependents, (WeakArray new: 10).
			FinalizationDependents at: index put: anObject.
		].
	] ifError: [:err | err signal].! !

!WeakArray class methodsFor: '*System-Finalization' stamp: ''!
restartFinalizationProcess
	"kill any old process, just in case"
	FinalizationProcess
		ifNotNil: [FinalizationProcess terminate.
			FinalizationProcess := nil].

	FinalizationSemaphore := Smalltalk specialObjectsArray at: 42.
	FinalizationDependents ifNil: [FinalizationDependents := WeakArray new: 10].
	FinalizationLock := Semaphore forMutualExclusion.
	
	FinalizationProcess := [self finalizationProcess]
		forkAt: Processor userInterruptPriority.
	FinalizationProcess name: 'WeakArray Finalization Process'.! !

!WeakArray class methodsFor: '*System-Finalization' stamp: ''!
finalizationProcess
	"The finalization process arranges to send mourn to each element of the VM's finalization queue,
	 which is accessed via primitiveFetchMourner.  The VM signals FinalizationSemaphore whenever
	 the queue is non-empty.  This process loops, waiting on the semaphore, fetches the first element
	 of the queue and then spawns a process at a higher priority to actually send the mourn messages.
	 If an error occurs in the higher priority mourn loop process then this process will simply spawn
	 another process, hence ensuring that errors in finalization methods don't break finalization.

	 In addition this process also runs the old finalization scheme, supporting clients of the older,
	 WeakRegistry based scheme.  Hopefully this will go away when all clients have moved over."
	| throttle firstMourner |
	throttle := Semaphore new.
	[true] whileTrue: [FinalizationSemaphore wait; initSignals.
	 "Support the old scheme until things have changed over..."
	 self doOldFinalization.
	 [firstMourner := self primitiveFetchMourner.
	  firstMourner notNil] whileTrue:
		[[throttle signal.
		  self mournLoopWith: firstMourner] forkAt: Processor activePriority + 1.
		 throttle wait]]! !

!WeakClassVariable commentStamp: ''!
A WeakClassVariable is a class variable that references an object weakly.

Internally it is implemented with a weak array of size one. Writing into the variable writes the only field in the array. 

weakArray at: 1 put: aValue.

Reading into the variable reads the only field in the array.

weakArray at: 1!
!WeakClassVariable methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue

	^super read at: 1 put: aValue! !

!WeakClassVariable methodsFor: 'initialization' stamp: ''!
installingIn: aClass
	"when the var gets installed, initialize it"
	super write: (WeakArray new: 1)! !

!WeakClassVariable methodsFor: 'meta-object-protocol' stamp: ''!
read

	^ super read at: 1! !

!WeakClassVariable methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	"Push the weak array at: 1 on the stack"
	aMethodBuilder pushLiteralVariable: self.
	aMethodBuilder pushLiteral: 1.
	aMethodBuilder send: #at:! !

!WeakClassVariable methodsFor: 'code generation' stamp: ''!
emitStore: aMethodBuilder
	"generate bytecode for 'varname at: 1 put: <stackTop>'"
	| temp |
	temp := '0TempForStackManipulation'.
	"Pop the value to store into a temp to push it back in the right order"
	aMethodBuilder addTemp: temp.
	aMethodBuilder storeTemp: temp.
	aMethodBuilder popTop.
	
	"Push the weak array into the stack, then the arguments, then send"
	aMethodBuilder pushLiteralVariable: self.
	aMethodBuilder pushLiteral: 1.
	aMethodBuilder pushTemp: temp.
	aMethodBuilder send: #at:put:! !

!WeakClassVariableTest methodsFor: 'tests' stamp: ''!
testWeakClassVariableReflective
	| classVar |
	classVar := #ClassVar => WeakClassVariable.
	aClass := self make: [ :builder | builder sharedVariables: {classVar} ].
	
	classVar write: 5.
	self assert: classVar read equals: 5! !

!WeakClassVariableTest methodsFor: 'tests' stamp: ''!
testWeakClassVariableIsWeak
	| classVar |
	classVar := #ClassVar => WeakClassVariable.
	aClass := self make: [ :builder | builder sharedVariables: {classVar} ].
	
	classVar write: Object new.
	Smalltalk garbageCollect.
	"the value is GCed and we get nil"
	self assert: classVar read equals: nil! !

!WeakClassVariableTest methodsFor: 'tests' stamp: ''!
testReadWriteWeakClassVarCompiled
	| classVar object valuetoTest |
	classVar := #ClassVar => WeakClassVariable.
	aClass := self make: [ :builder | builder sharedVariables: {classVar} ].
	
	object := aClass new.
	
	"now compile an accessor and read"
	self compileAccessorsFor: classVar.
	self assert: object ClassVar equals: nil.
	
	valuetoTest := Object new.
	
	object ClassVar: valuetoTest.
	self assert: object ClassVar equals: valuetoTest! !

!WeakClassVariableTest methodsFor: 'tests' stamp: ''!
testCreateClassWithWeakClassVariable
	| classVar |
	
	"Add class variable using the builder interface"
	classVar := #ClassVar => WeakClassVariable.
	aClass := self make: [ :builder | builder sharedVariables: {classVar} ].
	
	self assert: (aClass hasClassVarNamed: 'ClassVar')
	
	! !

!WeakFinalizationList commentStamp: ''!
IMPORTANT!!!!!!

This class is a special object, recognized by VM.
Its only purpose is to 
a) identify a special kind of objects who usually having a weak references but
  also having an instance of me held by first non-weak fixed slot (instance variable).

b) a 'first' instance variable points to the head of a list of items, reported by VM which has weak references which became garbage during last garbage collection

At my class side, there are some public behavior, which is used by finalization process to detect if VM supports new finalization scheme or should use the old one.
Weak registry using #hasNewFinalization for switching to correct finalization logic,
depending on VM it currently runs on.
!
!WeakFinalizationList methodsFor: 'accessing' stamp: ''!
swapWithNil

	| head |
	head := first.
	first := nil.
	^ head! !

!WeakFinalizationList methodsFor: 'accessing' stamp: ''!
first
	^ first! !

!WeakFinalizationList class methodsFor: 'vm capability test' stamp: ''!
hasNewFinalization
	"new finalization is always false"
	^ false! !

!WeakFinalizerItem commentStamp: ''!
My instances is used by weak registry to hold a single weak reference
and executor(s).

Once object, referenced weakly by my instance become garbage, a weak registry triggers its execution
by sending #finalizeValues to my instance.

Note, that a new VM finalization scheme does not implies to use this particular class
in order to implement finalization scheme. VM refers only to WeakFinalizationList class. 

In this way, my class and its implementation can serve as an example for implementing various finalization actions, which may differ from this one, provided by default for use by weak registry.

Once initialized, my instance should:
 - point to particular list (an instance of WeakFinalizationList),
 - next should be nil
 - executor or multiple executors initialized
 - weak reference slot should point to some object of interest

At the moment, when object, referenced weakly, become garbage, VM checks if its fist instance variable is an instance of WeakFinalizationList.
If it so, then it adds a given object to this list, and also links the tail of list through 'next' instance variable. 

So, as a result of garbage collection, a list will contain all objects, which had weak references to garbage collected objects. 
It is a responsibility of application to manage the instances of WeakFinalizationList's , as well as clear this list before the next garbage collection.
As a consequence of that you can:
 - use multiple different lists and manage them differently in order to react differently when some objects became garbage
 - you are not obliged to handle/clear the list(s) immediately after GC. You can clean up them periodically.
 - you can implement own kind of weak referencing object(s), which could use same finalization, provided by newer VMs.

VM requires only that an object with weak reference having at least two instance variables,
and its first instance variable points to instance of WeakFinalizationList. Everything else is optional.
!
!WeakFinalizerItem methodsFor: 'initialization' stamp: ''!
list: weakFinalizationList object: anObject executor: anExecutor
	self assert: (weakFinalizationList class == WeakFinalizationList).
	list := weakFinalizationList.
	self at: 1 put: anObject.
	executor := anExecutor! !

!WeakFinalizerItem methodsFor: 'accessing' stamp: ''!
add: newExecutor

	executor 
		ifNil: [ executor := newExecutor ]
		ifNotNil: [
			executor hasMultipleExecutors
				ifTrue: [ executor add: newExecutor]
				ifFalse: [ executor := ObjectFinalizerCollection with: executor with: newExecutor ]
		]! !

!WeakFinalizerItem methodsFor: 'accessing' stamp: ''!
clear
	list := next := nil.! !

!WeakFinalizerItem methodsFor: 'copying' stamp: ''!
copyWithList: aList

	^ self copy list: aList! !

!WeakFinalizerItem methodsFor: 'finalization' stamp: ''!
finalizeValues
	" cleanup the receiver, so it could be reused "
	| ex |
	ex := executor.
	executor := nil.
	next := nil.
	ex finalize.! !

!WeakFinalizerItem methodsFor: 'accessing' stamp: ''!
next
	^ next! !

!WeakFinalizerItem methodsFor: 'copying' stamp: ''!
postCopy
	executor hasMultipleExecutors ifTrue: [ executor := executor copy ].! !

!WeakFinalizerItem methodsFor: 'accessing' stamp: ''!
executor
	^ executor! !

!WeakFinalizerItem methodsFor: 'accessing' stamp: ''!
list: aList
	list := aList! !

!WeakFinalizerItem methodsFor: 'accessing' stamp: ''!
object
	^ self at: 1! !

!WeakFinalizerItem methodsFor: 'initialization' stamp: ''!
list: weakFinalizationList object: anObject
	self assert: (weakFinalizationList class == WeakFinalizationList).
	list := weakFinalizationList.
	self at: 1 put: anObject.
! !

!WeakFinalizerItem methodsFor: 'accessing' stamp: ''!
list
	^ list! !

!WeakFinalizerItem class methodsFor: 'instance creation' stamp: ''!
new
	^ self basicNew: 1! !

!WeakIdentityKeyDictionary commentStamp: ''!
This class represents an identity dictionary with weak keys.!
!WeakIdentityKeyDictionary methodsFor: 'private' stamp: ''!
compare: object1 to: object2
	^ object1 == object2! !

!WeakIdentityKeyDictionary methodsFor: 'private' stamp: ''!
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! !

!WeakIdentityKeyDictionary methodsFor: 'private' stamp: ''!
startIndexFor: anObject
	"Return the index at which the scan for anObject should start."
	
	^(anObject identityHash \\ array size) + 1! !

!WeakIdentityKeyDictionary methodsFor: 'enumeration' stamp: ''!
valuesDo: aBlock 
	"See comments in Dictionary>>valuesDo:.  The code keeps the key so it's
	not collected during the evaluation of aBlock"

	tally = 0 ifTrue: [ ^self ].
	1 to: array size do:
		[ :eachIndex | 
			| eachAssociation eachKey |
			eachAssociation := array at: eachIndex.
			nil == eachAssociation ifFalse:
				[
					eachKey := eachAssociation key.
					nil == eachKey ifFalse: [ aBlock value: eachAssociation value ]
				]
		]! !

!WeakIdentityKeyDictionaryTest commentStamp: ''!
SUnit tests for weak identity key dictionaries!
!WeakIdentityKeyDictionaryTest methodsFor: 'tests' stamp: ''!
testFinalizeValuesWhenLastChainContinuesAtFront
	| objectWithHashModulo dictionary capacity a b c |
	objectWithHashModulo := [ :requestedHash :modulo | 
	| object |
	[ object := Object new.
	object hash \\ modulo = requestedHash ] whileFalse.
	object ].

	dictionary := self classToBeTested new.
	capacity := dictionary capacity.
	a := objectWithHashModulo value: capacity - 2 value: capacity.
	dictionary at: a put: 1.
	b := objectWithHashModulo value: capacity - 1 value: capacity.
	dictionary at: b put: 2.
	c := objectWithHashModulo value: capacity - 2 value: capacity.
	dictionary at: c put: 3.
	self assert: dictionary capacity equals: capacity.
	self assert: (dictionary array at: capacity - 1) key identicalTo: a.
	self assert: (dictionary array at: capacity) key identicalTo: b.
	self assert: (dictionary array at: 1) key identicalTo: c.
	a := nil.
	Smalltalk garbageCollect.
	dictionary finalizeValues.
	self assert: (dictionary includesKey: b).
	self assert: (dictionary includesKey: c).
	self assert: dictionary slowSize equals: 2! !

!WeakIdentityKeyDictionaryTest methodsFor: 'tests' stamp: ''!
testNoNils
	| d |
	d := WeakIdentityKeyDictionary new
	at: 'hello' copy put: 'world';
		yourself.
	Smalltalk garbageCollect.
	self deny: (d keys includes: nil)! !

!WeakIdentityKeyDictionaryTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ WeakIdentityKeyDictionary! !

!WeakIdentityKeyDictionaryTest methodsFor: 'requirements' stamp: ''!
canBeUnhealthy
	^ false! !

!WeakIdentitySet commentStamp: ''!
I'm a IdentitySet with weak elements!
!WeakIdentitySet methodsFor: 'private' stamp: ''!
scanFor: anObject
	"Scan the key array for the first slot containing either flag (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 := anObject identityHash \\ array size + 1.
	[ 
		| element |
		((element := array at: index) == flag or: [ element enclosedElement == anObject ])
			ifTrue: [ ^index ].
		(index := index \\ array size + 1) = start ] whileFalse.
	self errorNoFreeSpace! !

!WeakIdentitySet methodsFor: 'private' stamp: ''!
scanForEmptySlotFor: aKey
	"Scan the key array for the first slot containing an empty slot (indicated by flag or 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.
	[ 
		| element |
		((element := array at: index) == flag or: [ element == nil ]) ifTrue: [ ^index ].
		(index := index \\ array size + 1) = start ] whileFalse.
	self errorNoFreeSpace! !

!WeakIdentitySetTest methodsFor: 'tests' stamp: ''!
testAddIncludesSizeReclaim
	"It is complex test in superclass to check how elements are garbage collected.
	And how #includes: behavios after that.
	The logic is based on WeakSet and it is not compatible to WeakIdentitySet.
	Adopting this test for WeakIdentitySest is not simple task"! !

!WeakIdentitySetTest methodsFor: 'tests' stamp: ''!
testAddEqualElements
	| ws o2 o3 |
	o2 := 1 / 2.
	o3 := '123' copy.
	ws := self classToBeTested new.
	ws add: o2.
	ws add: o3.
	self assert: ws size equals: 2.
	self assert: (ws includes: o2).
	self assert: (ws includes: o3).

	"inclusion test does use identity, not equality"
	self deny: (ws includes: o3 copy).

	ws add: o3 copy.
	self assert: ws size equals: 3! !

!WeakIdentitySetTest methodsFor: 'tests' stamp: ''!
testAddIdenticalElements
	| identitySet aString anOtherString |
	aString := 'hello'.
	anOtherString := aString copy.

	self assert: aString equals: anOtherString.
	self deny: aString identicalTo: anOtherString.

	identitySet := self classToBeTested new.
	identitySet add: aString.

	self assert: (identitySet occurrencesOf: aString) equals: 1.
	self assert: (identitySet occurrencesOf: anOtherString) equals: 0.

	self assert: (identitySet includes: aString).
	self deny: (identitySet includes: anOtherString) equals: 0! !

!WeakIdentitySetTest methodsFor: 'requirements' stamp: ''!
classToBeTested

	^ WeakIdentitySet! !

!WeakIdentitySetTest methodsFor: 'tests' stamp: ''!
testCollisions
	"It is complex test in superclass to check how collisions are resolved.
	The logic is based on WeakSet and it is not compatible to WeakIdentitySet.
	Adopting this test for WeakIdentitySest is not simple task"! !

!WeakIdentityValueDictionary commentStamp: ''!
This class represents an identity dictionary with weak values!
!WeakIdentityValueDictionary methodsFor: 'private' stamp: ''!
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"! !

!WeakIdentityValueDictionary methodsFor: 'private' stamp: ''!
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! !

!WeakIdentityValueDictionary methodsFor: 'private' stamp: ''!
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! !

!WeakIdentityValueDictionaryTest commentStamp: ''!
SUnit tests for WeakIdentityValueDictionaty!
!WeakIdentityValueDictionaryTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ WeakIdentityValueDictionary! !

!WeakIdentityValueDictionaryTest methodsFor: 'requirements' stamp: ''!
canBeUnhealthy
	^ false! !

!WeakIdentityValueDictionaryTest methodsFor: 'tests' stamp: ''!
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).! !

!WeakKeyAssociation commentStamp: ''!
I am an association holding only weakly on my key.!
!WeakKeyAssociation methodsFor: 'accessing' stamp: ''!
value: anObject 
	"Store the argument, anObject, as the value of the receiver."

	anObject == self ifTrue: [self error: 'Using the WeakAssociation as its own value'].
	value := anObject! !

!WeakKeyAssociation methodsFor: 'testing' stamp: ''!
< aLookupKey 
	"Refer to the comment in Magnitude|<."

	^self key < aLookupKey key! !

!WeakKeyAssociation methodsFor: 'comparing' stamp: ''!
= aLookupKey
	"XXX why doesn't this consider the value? mvl"

	^ self species = aLookupKey species
		ifTrue: [ self key = aLookupKey key ]
		ifFalse: [ false ]! !

!WeakKeyAssociation methodsFor: 'comparing' stamp: ''!
hash
	"Hash is reimplemented because = is implemented."

	^self key hash! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: ''!
key
	"Answer the lookup key of the receiver."

	^self basicAt: 1! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: ''!
key: aKey value: anObject 
	"Store the arguments as the variables of the receiver."

	self basicAt: 1 put: aKey.
	value := anObject! !

!WeakKeyAssociation methodsFor: 'printing' stamp: ''!
printOn: aStream

	self key printOn: aStream.
	aStream nextPutAll: '->'.
	value printOn: aStream! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: ''!
value
	"Answer the value of the receiver."

	^ value == self ifTrue:[nil] ifFalse:[value]! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: ''!
name

	^ self key isString
		ifTrue: [self key]
		ifFalse: [self key printString]! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: ''!
expire
    "Release the value if the key has gone. Return true if a modification was made."
	(self basicAt: 1) ifNil:[
		value == self ifTrue:[^false].
		value := self.
		^true
	].
	^false! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: ''!
expired
	^value == self! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: ''!
key: anObject 
	"Store the argument, anObject, as the lookup key of the receiver."

	self basicAt: 1 put:  anObject! !

!WeakKeyAssociation methodsFor: 'printing' stamp: ''!
storeOn: aStream
	"Store in the format (WeakKeyAssociation key: theKey value: theValue)"
	aStream 
		nextPut: $(;
		nextPutAll: self class name.
	self expired ifTrue:[
		aStream nextPutAll: ' expired'
	] ifFalse: [
		aStream nextPutAll:' key: '.
		self key storeOn: aStream.
		aStream nextPutAll: ' value:'.
		value storeOn: aStream.
	].
	aStream nextPut: $)! !

!WeakKeyAssociation class methodsFor: 'instance creation' stamp: ''!
key: newKey value: newValue
	"Answer an instance of me with the arguments as the key and value of 
	the association."

	^(self basicNew: 1) key: newKey value: newValue! !

!WeakKeyAssociation class methodsFor: 'instance creation' stamp: ''!
expired
	"Answer an object that is already expired. Used for printing"
	^(self key: nil value: nil)
		expire;
		yourself! !

!WeakKeyDictionary commentStamp: ''!
I am a dictionary holding only weakly on my keys. This is a bit dangerous since at any time my keys can go away. Clients are responsible to register my instances by WeakArray such that the appropriate actions can be taken upon loss of any keys. As key may disappear at any time, my reported size may be greater than the number of keys encountered in iterations.

See WeakRegistry for an example of use.

Implementation notes:

I am a set of WeakAssociations. Each WeakAssociation can be in one of three states: a key is present, or the key has been garbage-collected, or the association is expired (meaning that the value has also been released). During finalization, associations with no key expire, but I still keep them to avoid rehashing the entire set. When adding a new entry, the new entry can either go into a slot that is nil, or one that has an expired association. I keep a count of expired associations and rehash when there are too many (currently, if they account for more than 25% of the space).!
!WeakKeyDictionary methodsFor: 'accessing' stamp: ''!
slowSize
	"Careful!! Answer the maximum amount
	of elements in the receiver, not the
	exact amount"

	| count |
	count := 0.
	1 to: array size do: [ :index |
		(array at: index) ifNotNil: [ :object |
			object expired ifFalse: [
				count := count + 1 ] ] ].
	^count! !

!WeakKeyDictionary methodsFor: 'enumerating' stamp: ''!
associationsDo: aBlock 
	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations)."

	

	super associationsDo: [:association | | key | 
		"Hold onto the key so it won't be collected while the block is evaluated."
		key := association key.
		key ifNotNil:[aBlock value: association]].! !

!WeakKeyDictionary methodsFor: 'adding' stamp: ''!
add: anAssociation
	self at: anAssociation key put: anAssociation value.
	^ anAssociation! !

!WeakKeyDictionary methodsFor: 'accessing' stamp: ''!
overridingAt: 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.
	May override an association with key == nil"

	| index element |

	key ifNil: [ ^ anObject ].
	index := self scanForKeyOrNil: key.	"There should always be room."
	index = 0
		ifTrue: [ self error: 'No space left in dictionary' ].

	element := array at: index.
	element == nil
		ifTrue: [ self atNewIndex: index put: ( WeakKeyAssociation key: key value: anObject ) ]
		ifFalse: [ element expired
				ifTrue: [ tally := tally + 1 ].
			element key: key.
			element value: anObject.
			self fullCheck
			].
	^ anObject! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
scanForKeyOrNil: anObject
	"Same as scanFor: , but treats association with key == nil as empty slot"
	
	| element start finish |
	finish := array size.
	start := self startIndexFor: anObject.
	
	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element := array at: index) == nil or: [ element key isNil or: [self compare: element key to: anObject]])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element := array at: index) == nil or: [ element key isNil or: [self compare: element key to: anObject]])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!WeakKeyDictionary methodsFor: 'enumerating' stamp: ''!
allAssociationsDo: aBlock 
	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations). This includes associations with nil keys, except for
	the expired ones."

	super associationsDo: [:association | 
		association expired ifFalse:[aBlock value: association]].! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
noCheckAddForRehash: anAssociation
	^self noCheckAdd: anAssociation! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
scanFor: anObject
	"mvl 10/21/2007: The method has been copied to this location to indicate that whenever #scanFor: changes #scanForEmpty: must be changed in the receiver as well."
	"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. Expired associations are ignored, since callers take non-nil slots as a successful search. Subclasses should override startIndexFor: and compare:to: if they have a different semantics for matching elements."
	| element start finish |
	finish := array size.
	start := self startIndexFor: anObject.
	
	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element := array at: index) == nil or: [self compare: element key to: anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element := array at: index) == nil or: [self compare: element key to: anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
compare: object1 to: object2
	^object1 = object2! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
startIndexFor: anObject
	"Return the index at which the scan for anObject should start."
	
	^(anObject hash \\ array size) + 1! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
grow
	super grow.
	expired := 0.! !

!WeakKeyDictionary methodsFor: 'removing' stamp: ''!
removeKey: key ifAbsent: aBlock
	"Remove key (and its associated value) from the receiver. If key is not in 
	the receiver, answer the result of evaluating aBlock. Otherwise, answer 
	the value externally named by key."

	| index result assoc |
	index := self findElementOrNil: key.
	assoc := array at: index.
	(assoc == nil or: [assoc key isNil]) ifTrue: [ ^ aBlock value ].
	assoc key: nil.
	result := assoc value.
	assoc expire.
	expired := expired + 1.
	tally := tally - 1.
	^result! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
noCheckNoGrowFillFrom: anArray
	"Add the elements of anArray except nils and flag to me assuming that I don't contain any of them, they are unique and I have more free space than they require."

	tally := 0.
	1 to: anArray size do: [ :index |
		(anArray at: index) ifNotNil: [ :association |
			association key 
				ifNil: [ finalizer ifNotNil: [ finalizer value: association value ] ]
				ifNotNil: [ :key | "Don't let the key go away"
					array
						at: (self scanForEmptySlotFor: key)
						put: association.
					tally := tally + 1 ] ] ]! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
noCheckAdd: anAssociation
	"Add anAssociation to the receiver. Discard expired associations. Put nil keys at the beginning."
	
	| key |
	
	key := anAssociation key. "Hold on to the key during this method"

	anAssociation expired ifFalse:[
		key ifNotNil:[
			super noCheckAdd: anAssociation
		] ifNil: [
			1 to: array size do:[:n|
				(array at: n) ifNil:[
					array at: n put: anAssociation. 
					tally := tally + 1.
					^self
				].
			].
			self error: 'could not find an empty slot.'
		].
	].! !

!WeakKeyDictionary methodsFor: 'testing' stamp: ''!
isHealthy
	"Test that object hashes match their positions stored in the receiver,
	answer true if everything ok, false otherwise
	
	WeakKeyDictionary allInstances select: [:dict |
		dict isHealthy not ]
	Dictionary allSubInstances select: [:dict |
		dict isHealthy not ]
	"
	array withIndexDo: [:elem :i |
		(elem notNil and: [elem key notNil ])
				ifTrue:  [(self scanFor: elem key) == i ifFalse: [ ^ false ]
			]
	].
	^ true! !

!WeakKeyDictionary methodsFor: 'initialization' stamp: ''!
initialize: n
	expired := 0.
	^super initialize: n! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
fixCollisionsFrom: oldIndex
	"This is an internal method that should not be needed in WeakKeyDictionary"
	self shouldNotImplement.! !

!WeakKeyDictionary methodsFor: 'accessing' stamp: ''!
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 element |

	key ifNil: [ ^ anObject ].
	index := self scanForEmpty: key.	"There should always be room."
	index = 0
		ifTrue: [ self error: 'No space left in dictionary' ].

	element := array at: index.
	element == nil
		ifTrue: [ self atNewIndex: index put: ( WeakKeyAssociation key: key value: anObject ) ]
		ifFalse: [ element expired
				ifTrue: [ tally := tally + 1 ].
			element key: key.
			element value: anObject.
			self fullCheck
			].
	^ anObject! !

!WeakKeyDictionary methodsFor: 'finalization' stamp: ''!
expiredValuesDo: aBlock
	"Clear all associations with nil keys"
	1 to: array size do:[:i | | assoc |
		assoc := array at: i.
		(assoc notNil and: [ assoc key isNil and: [assoc expired not ]])
		ifTrue: [ 
			aBlock value: assoc value.
			assoc expire.
			expired := expired + 1.
			tally := tally - 1.	]]! !

!WeakKeyDictionary methodsFor: 'finalization' stamp: ''!
finalizeValues
	"Clear all associations with nil keys.
	Avoid using block closures, so it won't produce many garbage 
	(since pushing closure as argument requires creating its preinitialized copy)"
	1 to: array size do:[:i | | assoc |
		assoc := array at: i.
		assoc ifNotNil:[
			assoc expire ifTrue:[
				expired := expired + 1.
				tally := tally - 1.
			].
		].
	].! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
fullCheck
	"Inlined super fullCheck, since the correct + X value for rehash check depends on its implementation"
	"Keep array at least 1/4 free for decent hash behavior"
	array size - tally < (array size // 4 max: 1)
		ifTrue: [self grow].
	"Make sure we never have so many expired entries that adding might fail"
	4 * expired + 4 > array size 
		ifTrue: [self rehash].! !

!WeakKeyDictionary methodsFor: 'copying' stamp: ''!
postCopy
	"Must copy the associations, or later store will affect both the
original and the copy"

	array := array
		collect: [ :assoc | 
			assoc
				ifNotNil: [ assoc expired
						ifTrue: [ WeakKeyAssociation expired ]
						ifFalse: [ WeakKeyAssociation key: assoc key value: assoc value ] ] ]! !

!WeakKeyDictionary methodsFor: 'enumerating' stamp: ''!
valuesDo: aBlock
	"See comments in Dictionary>>valuesDo:"

	tally = 0 ifTrue: [ ^ self ].
	1 to: array size do: [ :eachIndex | 
		(array at: eachIndex) ifNotNil: [ :eachAssociation | 
			| eachKey |
			"The code keeps the key so it's not collected during the evaluation of aBlock"
			eachKey := eachAssociation key.
			aBlock value: eachAssociation value ] ]! !

!WeakKeyDictionary methodsFor: 'finalization' stamp: ''!
finalizeValues: finiObjects
	"Clear all associations with key == nil and value is in finiObjects."
	array do:[:assoc|
		(assoc notNil and:[finiObjects includes: assoc value]) ifTrue:[
			assoc expire.
			expired := expired + 1.
			tally := tally - 1.
		].
	].! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary 
	self shouldNotImplement.! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
scanForEmpty: anObject
	"Scan the key array for the first slot containing either a nil or an expired association (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found."
	| element start finish firstNil |
	finish := array size.
	start := self startIndexFor: anObject.
	firstNil := nil.
	
	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element := array at: index) == nil 
						or: [self compare: element key to: anObject])
			ifTrue: [
				"If we found no match, and have an expired slot, use that one."
				(element isNil and: [firstNil notNil]) ifTrue:[^firstNil].
				^ index 
			].
			"If this slot is expired, and we haven't seen an earlier expired slot, record it"
			(element notNil 
				and: [element expired 
						and: [firstNil isNil]]) ifTrue: [firstNil := index].
		].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element := array at: index) == nil 
					or: [self compare: element key to: anObject])
			ifTrue: [
				(element isNil and: [firstNil notNil]) ifTrue:[^firstNil].
				^ index 
			].
			(element notNil 
				and: [element expired 
						and: [firstNil isNil]]) ifTrue: [firstNil := index].
		].

	"If there is no empty slot, but an expired one, return it."	
	firstNil notNil ifTrue:[^firstNil].

	^ 0  "No match AND no empty slot"! !

!WeakKeyDictionary methodsFor: 'private' stamp: ''!
rehash
	"Rehash the receiver."
	super rehash.
	expired := 0.! !

!WeakKeyDictionaryTest commentStamp: ''!
SUnit tests for weak key dictionaries!
!WeakKeyDictionaryTest methodsFor: 'tests' stamp: ''!
testGrow
	keys := nil.
	dict at: self put: nil.
	Smalltalk garbageCollect.

	"Keys are gone but not yet finalized."
	dict grow.! !

!WeakKeyDictionaryTest methodsFor: 'tests' stamp: ''!
testClearing
	keys := nil.
	dict at: self put: nil.
	self assert: dict size equals: self size + 1.

	Smalltalk garbageCollect.

	"Keys are gone but not yet finalized."
	self assert: dict size equals: self size + 1.
	self assert: dict keys size equals: 1.

	dict finalizeValues.

	"Now the size should be adjusted."
	self assert: dict size equals: 1! !

!WeakKeyDictionaryTest methodsFor: 'accessing' stamp: ''!
size
	"Answer the number of keys that should be used in testing."
	^1000! !

!WeakKeyDictionaryTest methodsFor: 'requirements' stamp: ''!
supportsNilKey
	^ false! !

!WeakKeyDictionaryTest methodsFor: 'tests - printing' stamp: ''!
testStoreOnWithNegativeInteger
	| dictionary |
	dictionary := { 'x' -> -1 } as: self classToBeTested.
	
	self
		assert: (String streamContents: [ :s | dictionary storeOn: s ])
		equals: '((',self classToBeTested name,' new) add: (WeakKeyAssociation key: ''x'' value: -1); yourself)'! !

!WeakKeyDictionaryTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ WeakKeyDictionary! !

!WeakKeyDictionaryTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	keys := (1 to: 1000) collect:[:n| 'key', n asString].
	dict := WeakKeyDictionary new.
	keys do:[:n| dict at: n put: n,n].
	super setUp.! !

!WeakKeyDictionaryTest class methodsFor: 'examples' stamp: ''!
timingMany
	| dicts keys size loops count |
	
	size := 10.
	count := 10000.
	loops := 10.
	
	keys := (1 to: size) collect:[:n| 'foo',n asString].
	
	dicts := OrderedCollection new.
	count timesRepeat:[ | dict |
		dict := WeakKeyDictionary new.
		keys do:[:k| dict at: k put: k].
		dicts add: dict.
	].
	Smalltalk garbageCollect.
	^Time millisecondsToRun: [
			loops timesRepeat:[
				dicts do: [:d| d finalizeValues].
			]].! !

!WeakKeyDictionaryTest class methodsFor: 'examples' stamp: ''!
timingLarge
	| dict keys size loops |
	
	size := 100000.
	loops := 10.
	
	keys := (1 to: size) collect:[:n| 'foo',n asString].
	Smalltalk garbageCollect.
	dict := WeakKeyDictionary new.
	keys do:[:k| dict at: k put: k].
	Smalltalk garbageCollect.
	^Time millisecondsToRun: [
		loops timesRepeat:[
			dict at: 'bar','0' put: 100.
			Smalltalk garbageCollectMost.
			dict finalizeValues.
		]].! !

!WeakKeyDictionaryTest class methodsFor: 'building suites' stamp: ''!
shouldInheritSelectors

^true! !

!WeakKeyToCollectionDictionary commentStamp: ''!
This class represents an identity dictionary with weak keys, whose values are collections. 
Keys not in the dictionary are mapped to the empty collection.  Conversely, if a collection becomes empty, the mapping can be removed to save time and space.  However, because this requires re-hashing, it does not pay to do this to eagerly.!
!WeakKeyToCollectionDictionary methodsFor: 'finalization' stamp: ''!
finalizeValues 
	self rehash! !

!WeakKeyToCollectionDictionary methodsFor: 'private' stamp: ''!
noCheckAddForRehash: anAssociation
	| cleanedValue |
	anAssociation key ifNil:[^self].
	cleanedValue := anAssociation value copyWithout: nil.
	cleanedValue notEmpty ifTrue:[
		anAssociation value: cleanedValue.
		super noCheckAddForRehash: anAssociation.
	].! !

!WeakKeyToCollectionDictionary methodsFor: 'private' stamp: ''!
noCheckNoGrowFillFrom: anArray
	"Add the elements of anArray except nils and associations with empty collections (or with only nils) to me assuming that I don't contain any of them, they are unique and I have more free space than they require."

	tally := 0.
	1 to: anArray size do: [ :index |
		(anArray at: index) ifNotNil: [ :association |
			association key ifNotNil: [ :key | "Don't let the key go away"
				| cleanedValue |
				(cleanedValue := association value copyWithout: nil) isEmpty 
					ifFalse: [
						association value: cleanedValue.
						array
							at: (self scanForEmptySlotFor: key)
							put: association.
						tally := tally + 1 ] ] ] ]! !

!WeakKeyToCollectionDictionaryTest commentStamp: ''!
SUnit tests for weak key to collection dictionaries !
!WeakKeyToCollectionDictionaryTest methodsFor: 'errors - those methods should be tested with collection keys' stamp: ''!
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"! !

!WeakKeyToCollectionDictionaryTest methodsFor: 'errors - those methods should be tested with collection keys' stamp: ''!
testRemoveKeyIfAbsent
	
	"| collection oldSize keyIn value result |
	collection := self nonEmptyDict .
	oldSize := collection size.
	keyIn := collection  keys anyOne.
	value := collection at: keyIn .
	
	result := collection removeKey: keyIn ifAbsent: [888].
	
	self assert: result = value.
	self assert: (collection  size = (oldSize - 1)).
	self should: [ (collection  at: keyIn )] raise: Error.
	
	self assert: (collection removeKey: self keyNotInNonEmptyDict ifAbsent: [888] ) = 888."! !

!WeakKeyToCollectionDictionaryTest methodsFor: 'errors - those methods should be tested with collection keys' stamp: ''!
testKeysAndValuesRemove
	" should be tested with collection keys"
	
	"| 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."! !

!WeakKeyToCollectionDictionaryTest methodsFor: 'requirements' stamp: ''!
classToBeTested
 
	^ WeakKeyToCollectionDictionary! !

!WeakLayout commentStamp: ''!
I am a special layout for weak variable sized objects such as WeakArray.

I contain a fixed number of Slots plus.
Instances of classes using this kind of layout have only a minimum given size. Instances have a custom number of additional weak fields which can be accessed with an index.

References held in the variable part are held weakly and might be nilled out by the garbage collector at any time. References in the named section are held strongly as in the default layout.!
!WeakLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGWeakLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)]
! !

!WeakLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	^ 4! !

!WeakLayout methodsFor: 'testing' stamp: ''!
isVariable
	^ true! !

!WeakLayout methodsFor: 'testing' stamp: ''!
isWeak
	^ true! !

!WeakLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else!!"
	^#weakSubclass:! !

!WeakLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass
	^ (superLayout extendWeak: aScope)
		host: aClass;
		yourself! !

!WeakLayout class methodsFor: '*Monticello' stamp: 'nil'!
mcTypeSymbol 
	^ #weak! !

!WeakMessageSend commentStamp: ''!
Instances of WeakMessageSend encapsulate messages send to objects, like MessageSend. Unlike MessageSend it is not necessarily a valid message. A request to value only results in a send if infact it is valid. 

See also MessageSend comments. WeakMessageSend is used primarily for event registration. 

Unlike MessageSend, WeakMessageSend store receivers (object receiving the message send) as the first and only element of its array as opposed to a named ivar.
But like MessageSend, it does have
 selector		Symbol -- message selector
 arguments		Array -- bound arguments
and it also has
 shouldBeNil		Boolean --  used to ensure array of arguments is not all nils!
!WeakMessageSend methodsFor: 'evaluating' stamp: ''!
value: anObject

	| strongReceiver |
	
	strongReceiver := self receiver.

	(self ensureReceiver: strongReceiver) ifFalse: [ ^ nil ].
	
	^ strongReceiver
		perform: selector 
		with: anObject! !

!WeakMessageSend methodsFor: 'comparing' stamp: ''!
= anObject
	"Compare equal to equivalent MessageSend"
	^ anObject isMessageSend
		and: [self receiver == anObject receiver
		and: [selector == anObject selector
		and: [(Array withAll: arguments) = (Array withAll: anObject arguments)]]]! !

!WeakMessageSend methodsFor: 'comparing' stamp: ''!
hash
	"work like MessageSend>>hash"
	^self receiver hash bitXor: selector hash! !

!WeakMessageSend methodsFor: 'accessing' stamp: ''!
arguments: anArray
	arguments := WeakArray withAll: anArray.
	"no reason this should be a WeakArray"
	shouldBeNil := Array withAll: (anArray collect: [ :ea | ea isNil ]).! !

!WeakMessageSend methodsFor: 'accessing' stamp: ''!
receiver
	^self at: 1! !

!WeakMessageSend methodsFor: 'evaluating' stamp: ''!
value: anObject1 value: anObject2 

	| strongReceiver |
	
	strongReceiver := self receiver.

	(self ensureReceiver: strongReceiver) ifFalse: [ ^ nil ].
	
	^ strongReceiver 
		perform: selector 
		with: anObject1
		with: anObject2! !

!WeakMessageSend methodsFor: 'evaluating' stamp: ''!
cull: arg1 cull: arg2 cull: arg3
	^ selector numArgs < 3 
		ifTrue: [ self cull: arg1 cull: arg2 ]
		ifFalse: [ self value: arg1 value: arg2 value: arg3 ]! !

!WeakMessageSend methodsFor: 'printing' stamp: ''!
printOn: aStream

	super printOn: aStream.
	
	aStream 
		nextPut: $(;
		print: selector;
		nextPutAll: ' -> ';
		print: self receiver;
		nextPut: $).! !

!WeakMessageSend methodsFor: 'evaluating' stamp: ''!
valueWithEnoughArguments: anArray
	"call the selector with enough arguments from arguments and anArray"
	| args strongReceiver |
	
	strongReceiver := self receiver.
	
	(self ensureReceiverAndArguments: strongReceiver) ifFalse: [ ^nil ].
	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.
	].
	^ strongReceiver perform: selector withArguments: args! !

!WeakMessageSend methodsFor: 'private' stamp: ''!
ensureArguments
	"Return true if my arguments haven't gone away"
	arguments ifNotNil: [
		arguments with: shouldBeNil do: [ :arg :flag |
			arg ifNil: [ flag ifFalse: [ ^false ]]
		]
	].
	^true! !

!WeakMessageSend methodsFor: 'private' stamp: ''!
collectArguments: anArgArray
	"Private"
    | staticArgs |
    staticArgs := self arguments.
    ^(anArgArray size = staticArgs size)
        ifTrue: [ Array withAll: anArgArray ]
        ifFalse:
            [(staticArgs isEmpty
                ifTrue: [ staticArgs := Array new: selector numArgs]
                ifFalse: [ Array withAll: staticArgs ] )
                    replaceFrom: 1
                    to: (anArgArray size min: staticArgs size)
                    with: anArgArray
                    startingAt: 1]! !

!WeakMessageSend methodsFor: 'evaluating' stamp: ''!
cull: arg
	^ selector numArgs = 0 
		ifTrue: [ self value ]
		ifFalse: [ self value: arg ].! !

!WeakMessageSend methodsFor: 'private' stamp: ''!
ensureReceiver
  "Return true if my receiver hasn't gone away"
  self receiver ifNil: [^ false].
  (self receiver class isObsolete) ifTrue: [^ false].
  (self receiver isBehavior and: [self receiver isObsolete]) ifTrue: [^ false].
  ^ true.! !

!WeakMessageSend methodsFor: 'converting' stamp: ''!
asMinimalRepresentation

	self isReceiverOrAnyArgumentGarbage
		ifTrue: [^nil]
		ifFalse:[^self].! !

!WeakMessageSend methodsFor: 'accessing' stamp: ''!
selector
	^selector! !

!WeakMessageSend methodsFor: 'accessing' stamp: ''!
arguments
	^arguments ifNil: [ Array new ]! !

!WeakMessageSend methodsFor: 'private' stamp: ''!
ensureReceiverAndArguments: aReceiver

  "Return true if my receiver hasn't gone away"
  aReceiver ifNil: [^ false].
  (aReceiver class isObsolete) ifTrue: [^ false].
  (aReceiver isBehavior and: [self receiver isObsolete]) ifTrue: [^ false].

  "Make sure that my arguments haven't gone away"
  arguments ifNotNil: [
    arguments with: shouldBeNil do: [ :arg :flag |
      arg ifNil: [ flag ifFalse: [ ^false ]]
    ]
  ].

  ^true! !

!WeakMessageSend methodsFor: 'evaluating' stamp: ''!
value: anObject1 value: anObject2 value: anObject3

	| strongReceiver |
	
	strongReceiver := self receiver.

	(self ensureReceiver: strongReceiver) ifFalse: [ ^ nil ].
	
	^ strongReceiver
		perform: selector 
		with: anObject1
		with: anObject2
		with: anObject3! !

!WeakMessageSend methodsFor: 'accessing' stamp: ''!
selector: aSymbol
	selector := aSymbol! !

!WeakMessageSend methodsFor: 'private' stamp: ''!
isReceiverGarbage
	"Make sure that my receiver hasn't gone away"
	^self receiver isNil! !

!WeakMessageSend methodsFor: 'evaluating' stamp: ''!
cull: arg1 cull: arg2
	^ selector numArgs < 2 
		ifTrue: [ self cull: arg1]
		ifFalse: [ self value: arg1 value: arg2 ]! !

!WeakMessageSend methodsFor: 'testing' stamp: ''!
isMessageSend
	^true! !

!WeakMessageSend methodsFor: 'private' stamp: ''!
isReceiverOrAnyArgumentGarbage
	"Make sure that my receiver hasn't gone away"
	^self isReceiverGarbage 
		or: [self isAnyArgumentGarbage]! !

!WeakMessageSend methodsFor: 'evaluating' stamp: ''!
value

	| strongReceiver |

	strongReceiver := self receiver.

	^ arguments
		ifNil: [ ( self ensureReceiver: strongReceiver )
				ifTrue: [ strongReceiver perform: selector ]
				ifFalse: [  ]
			]
		ifNotNil: [ ( self ensureReceiverAndArguments: strongReceiver )
				ifTrue: [ strongReceiver perform: selector withArguments: ( Array withAll: arguments ) ]
				ifFalse: [  ]
			]! !

!WeakMessageSend methodsFor: 'testing' stamp: ''!
isValid
	^self isReceiverOrAnyArgumentGarbage not! !

!WeakMessageSend methodsFor: 'accessing' stamp: ''!
receiver: anObject
	self at: 1 put: anObject! !

!WeakMessageSend methodsFor: 'private' stamp: ''!
ensureReceiver: anObject
  "Return true if my receiver hasn't gone away"
  anObject ifNil: [^ false].
  (anObject class isObsolete) ifTrue: [^ false].
  (anObject isBehavior and: [anObject isObsolete]) ifTrue: [^ false].
  ^ true.! !

!WeakMessageSend methodsFor: 'private' stamp: ''!
ensureReceiverAndArguments

  "Return true if my receiver hasn't gone away"
  self receiver ifNil: [^ false].
  (self receiver class isObsolete) ifTrue: [^ false].
  (self receiver isBehavior and: [self receiver isObsolete]) ifTrue: [^ false].

  "Make sure that my arguments haven't gone away"
  arguments ifNotNil: [
    arguments with: shouldBeNil do: [ :arg :flag |
      arg ifNil: [ flag ifFalse: [ ^false ]]
    ]
  ].

  ^true! !

!WeakMessageSend methodsFor: 'evaluating' stamp: ''!
valueWithArguments: anArray

	| strongReceiver |
	
	strongReceiver := self receiver.

	(self ensureReceiverAndArguments: strongReceiver) ifFalse: [ ^nil ].
	^ strongReceiver 
		perform: selector 
		withArguments: (self collectArguments: anArray)! !

!WeakMessageSend methodsFor: 'private' stamp: ''!
isAnyArgumentGarbage
	"Make sure that my arguments haven't gone away"
	arguments ifNotNil: [
		arguments with: shouldBeNil do: [ :arg :flag |
			(flag not and: [arg isNil])
				ifTrue: [^true]
		]
	].
	^false! !

!WeakMessageSend methodsFor: 'converting' stamp: ''!
asMessageSend
	^MessageSend receiver: self receiver selector: selector arguments: (Array withAll: self arguments)! !

!WeakMessageSend class methodsFor: 'instance creation' stamp: ''!
new
	^self new: 1! !

!WeakMessageSend class methodsFor: 'instance creation' stamp: ''!
receiver: anObject selector: aSymbol
	^ self receiver: anObject selector: aSymbol arguments: #()! !

!WeakMessageSend class methodsFor: 'instance creation' stamp: ''!
receiver: anObject selector: aSymbol arguments: anArray
	^ self new
		receiver: anObject;
		selector: aSymbol;
		arguments: anArray! !

!WeakMessageSend class methodsFor: 'instance creation' stamp: ''!
receiver: anObject selector: aSymbol argument: aParameter
	^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter)! !

!WeakMessageSendTest commentStamp: ''!
SUnit tests for WeakMessageSend!
!WeakMessageSendTest methodsFor: 'tests' stamp: ''!
testOneArgument

	| m |
	m := WeakMessageSend
		receiver: Array
		selector: #with:
		argument: 1.
	Smalltalk garbageCollectMost.
	self assert: m value equals: { 1 }! !

!WeakMessageSendTest methodsFor: 'tests' stamp: ''!
testReceiverWithGC

	| m |
	m := WeakMessageSend
		receiver: Object new
		selector: #isNil.
	Smalltalk garbageCollectMost.
	self assert: (m value isNil).! !

!WeakMessageSendTest methodsFor: 'tests' stamp: ''!
testNoArguments

	| m |
	m := WeakMessageSend
			receiver: true
			selector: #yourself.
	self assert: (m value).! !

!WeakMessageSendTest methodsFor: 'tests' stamp: ''!
testOneArgumentWithGC

	| m |
	m := WeakMessageSend
		receiver: Array
		selector: #with:
		arguments: { Object new }.
	Smalltalk garbageCollectMost.
	self assert: (m value isNil)! !

!WeakMessageSendTest methodsFor: 'tests' stamp: ''!
testCollectArguments

	"Fogbugz issue 18127"
	"Test is passed if no primitive fails"
	
	| msg rcvr c|
	
	rcvr := OrderedCollection new.
	c := Color green.
	msg := WeakMessageSend receiver: rcvr selector: #add: arguments: { Color black }.
	
	msg valueWithArguments: {}.
	
	self assertCollection: rcvr asArray equals: { Color black }.
	
	msg valueWithArguments: { #a . WeakArray with: c }.
	
	self assertCollection: rcvr asArray equals: { Color black . #a }.
	
	msg valueWithArguments: (WeakArray with: c).
	
	self assertCollection: rcvr asArray equals: { Color black . #a  . Color green }.! !

!WeakMessageSendTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ WeakMessageSend! !

!WeakMessageSendTest methodsFor: 'tests' stamp: ''!
testTwoArguments
	| m |
	m := WeakMessageSend receiver: Array selector: #with:with: arguments: {1 . 2}.
	Smalltalk garbageCollectMost.
	self assert: m value equals: {1 . 2}! !

!WeakOrderedCollection commentStamp: ''!
I am just like an OrderedCollection except that I hold my objects weakly.

In use, be aware that objects only referenced by me are not "removed" (like in OrderedCollection), but merely nilled. So guard against nils when iterating/accessing, and don't expect #size to represent the number of objects I hold. 

For more details, read my tests in WeakOrderedCollectionTest. !
!WeakOrderedCollection class methodsFor: 'private' stamp: ''!
arrayType
	^ WeakArray! !

!WeakOrderedCollectionTest commentStamp: ''!
A trait for test purposes!
!WeakOrderedCollectionTest methodsFor: 'tests' stamp: ''!
testWeakOrderedCollectionSomeGarbageCollected
	| anArray anotherObject weakOrderedCollection |
	anArray := OrderedCollection new.
	anotherObject := Time new.
	anotherObject seconds: 40.
	anArray add: Duration new.
	anArray add: anotherObject.

	weakOrderedCollection := WeakOrderedCollection new.
	weakOrderedCollection
		add: anArray;
		add: anotherObject.

	"Let's add lot of stuff to be sure #grow is send."
	(1 to: 1000) do: [ :index | weakOrderedCollection add: Date today ].

	anArray := nil.

	3 timesRepeat: [ Smalltalk garbageCollect ].
	self assert: weakOrderedCollection asSet size equals: 2.
	self assert: (weakOrderedCollection asSet includes: anotherObject).
	self assertEmpty: (weakOrderedCollection asSet select: [ :each | each class = Duration ]).
	self assertEmpty: (weakOrderedCollection asSet select: [ :each | each class = OrderedCollection ])! !

!WeakOrderedCollectionTest methodsFor: 'tests' stamp: ''!
testWeakOrderedCollectionAllGarbageCollected
	| anArray anotherObject weakOrderedCollection |
	
	anArray := OrderedCollection new.
	anotherObject := Time new. 
	anotherObject seconds: 40.
	anArray add: Date today.
	anArray add: anotherObject.

	weakOrderedCollection := WeakOrderedCollection new.
	weakOrderedCollection 
		add: anArray;
		add: anotherObject.
		
	"Let's add lot of stuff to be sure #grow is send."
	(1 to: 1000) do: [:index | weakOrderedCollection add: Date today ].
	
	anotherObject := nil.
	anArray := nil.
	
	3 timesRepeat: [Smalltalk garbageCollect].
	self assert: weakOrderedCollection asSet size equals: 1.
	self assert: (weakOrderedCollection asSet includes: nil)! !

!WeakRegistry commentStamp: ''!
This kind of WeakRegistry using a new VM feature,
which allows a more robust finalization support.

In contrast to old implementation, it doesn't spending linear time , checking what elements became garbage.!
!WeakRegistry methodsFor: 'adding' stamp: ''!
add: anObject executor: anExecutor
	"With new finalization, we can simply override associations with key == nil in valueDictionary "
	self protected: [ | finItem |
		finItem := valueDictionary at: anObject ifAbsent: [
			WeakFinalizationList hasNewFinalization ifTrue: [
				valueDictionary overridingAt: anObject put: (WeakFinalizerItem new list: list object: anObject) ]
			ifFalse: [
				valueDictionary at: anObject put: (WeakFinalizerItem new list: list object: anObject) 
				]
		].
		finItem add: anExecutor ].
	^ anObject! !

!WeakRegistry methodsFor: 'adding' stamp: ''!
add: anObject
	"Add anObject to the receiver. Store the object as well as the associated executor."
	
	^self add: anObject executor: anObject executor! !

!WeakRegistry methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	valueDictionary := WeakIdentityKeyDictionary new.
	list := WeakFinalizationList new.
	sema := Semaphore forMutualExclusion.
	self installFinalizer! !

!WeakRegistry methodsFor: 'accessing' stamp: ''!
keys

	^self protected: [ valueDictionary keys ]! !

!WeakRegistry methodsFor: 'printing' stamp: ''!
printElementsOn: aStream
	sema ifNil: [ ^super printElementsOn: aStream ].
	aStream nextPutAll: '(<this WeakRegistry is locked>)'! !

!WeakRegistry methodsFor: 'finalization' stamp: ''!
finalizeValues
	"Finalize any values, which happen to stocked in our list, due to some weak references become garbage"
	
	| finalizer |

	"Do the old way, if VM don't supports us"
	WeakFinalizationList hasNewFinalization ifFalse: [ | finalizers |
		finalizers := OrderedCollection new.
		self protected: [ 
			valueDictionary expiredValuesDo: [:finItem |
				finalizers add: finItem
				].
		 ].
		finalizers do: [:each | [each finalizeValues] on: Exception fork: [:ex | ex pass ] ].
		^ self ].

	self protected: [ finalizer := list swapWithNil ].

	"We don't need to protect a following loop from concurrent access,
	because at the moment we're finalizing values, 
	only we can access this list of finalizers, because valueDictionary already see them
	as an unused slots, because they're associated with key == nil"
	
	[ finalizer notNil ] whileTrue: [
		| next |
		next := finalizer next.
		[ finalizer finalizeValues] on: Exception fork: [:ex | ex pass ].
		finalizer := next
	]! !

!WeakRegistry methodsFor: 'private' stamp: ''!
species
	^Set! !

!WeakRegistry methodsFor: 'copying' stamp: ''!
postCopy
	"should we prohibit any attempts to copy receiver?"
	self protected: [ | oldDict |
		sema := Semaphore forMutualExclusion.
		oldDict := valueDictionary.
		list := WeakFinalizationList new.
		valueDictionary := WeakIdentityKeyDictionary new.
		self installFinalizer.
	
		oldDict keysAndValuesDo: [:key :value |
			valueDictionary at: key put: (value copyWithList: list)
		].
	]! !

!WeakRegistry methodsFor: 'printing' stamp: ''!
removeAll
	"See super"
	
	self protected:[
		valueDictionary removeAll.
		list swapWithNil. "prune finalization list as well"
	]! !

!WeakRegistry methodsFor: 'accessing' stamp: ''!
size
	^ self protected: [ valueDictionary slowSize ]! !

!WeakRegistry methodsFor: 'enumerating' stamp: ''!
do: aBlock
	^self protected: [
		valueDictionary keysDo: aBlock
	]! !

!WeakRegistry methodsFor: 'private - initialization' stamp: ''!
installFinalizer
	"Do nothing, pharo does not supports it right now
	  valueDictionary finalizer: #finalizeValues
	"! !

!WeakRegistry methodsFor: 'private' stamp: ''!
protected: aBlock
	"Execute aBlock protected by the accessLock"

	^ sema
		critical: aBlock
		ifError: [ :err | err signal ]! !

!WeakRegistry methodsFor: 'printing' stamp: ''!
remove: oldObject ifAbsent: exceptionBlock
	"Remove oldObject as one of the receiver's elements."
	
	oldObject ifNil: [ ^nil ].
	^(self protected: [ valueDictionary removeKey: oldObject ifAbsent: nil ])
		ifNil: [ exceptionBlock value ]! !

!WeakRegistry class methodsFor: 'instance creation' stamp: ''!
new
	| registry |
	registry := super new.
	WeakArray addWeakDependent: registry.
	^registry! !

!WeakRegistry class methodsFor: 'instance creation' stamp: ''!
new: n
	^ self new! !

!WeakRegistry class methodsFor: 'accessing' stamp: ''!
default
	^Default ifNil: [ Default := self new ]! !

!WeakRegistryTest commentStamp: ''!
A trait for test purposes!
!WeakRegistryTest methodsFor: 'tests' stamp: ''!
testFinalizationWithOnFork
	" Test that if error occurs during finalization, the finalization process continues to run normally.
	
	We addting two executors into weak registry:
	 the faulty one, which causing an error
	 and good one, which signals semaphore
	
	test shows that both finalizers are evaluated and error doesn't prevents a good finalizer from execution
	"

	| reg obj1 obj2 sema timedOut |
	reg := WeakRegistry new.
	sema := Semaphore new.
	WeakArray removeWeakDependent: reg.
	obj1 := Array new: 1.
	obj2 := Array new: 2.

	reg add: obj1 executor: (MockFinalizerAction new finalizationAction: [ self signalMockException ]).
	reg add: obj2 executor: (MockFinalizerAction new finalizationAction: [ sema signal ]).

	errorWasHere := false.

	obj1 := obj2 := nil.
	Smalltalk garbageCollect.

	reg finalizeValues.

	timedOut := sema waitTimeoutSeconds: 1.

	self assert: errorWasHere identicalTo: true.
	self assert: timedOut identicalTo: false! !

!WeakRegistryTest methodsFor: 'tests' stamp: ''!
testRemovingDoesntLeak
	| w finalized block hash object executor |
	w := WeakRegistry new: 1.
	finalized := false.
	block := [ :v | finalized := v ].
	object := Object new.
	executor := ObjectFinalizer receiver: block selector: #value: argument: true.
	hash := object hash.
	w add: hash.
	w add: object executor: executor.
	object := nil.	"let it go"
	w remove: hash.
	Smalltalk garbageCollect.	"finalize it"
	self assertEmpty: w.
	self assert: finalized! !

!WeakRegistryTest methodsFor: 'mocketry' stamp: ''!
signalMockException
	MockExceptionWithPassAction new
		passAction: [ errorWasHere := true];
		signal! !

!WeakRegistryTest methodsFor: 'tests' stamp: ''!
testGrowingDoesntLeak
	| w finalized block object executor |
	w := WeakRegistry new: 1.
	finalized := false.
	block := [ :v | finalized := v ].
	object := Object new.
	executor := ObjectFinalizer receiver: block selector: #value: argument: true.
	w add: object executor: executor.
	object := nil.	"let it go"
	w addAll: (1 to: 1000).	"force growing"
	Smalltalk garbageCollect.	"finalize it"
	self assert: w size equals: 1000.
	self assert: finalized! !

!WeakRegistryTest methodsFor: 'tests' stamp: ''!
testRemovingByAHighPriorityProcessDoesntLeak
	| w finalized block hash object executor semaphore |
	w := WeakRegistry new: 1.
	finalized := false.
	block := [ :v | finalized := v ].
	object := Object new.
	executor := ObjectFinalizer receiver: block selector: #value: argument: true.
	hash := object hash.
	w add: hash.
	w add: object executor: executor.
	semaphore := Semaphore new.
	[ object := nil.	"let it go"
	w remove: hash.
	semaphore signal ] forkAt: WeakArray runningFinalizationProcess priority + 1.
	semaphore wait.
	Smalltalk garbageCollect.	"finalize it"
	self assertEmpty: w.
	self assert: finalized! !

!WeakRegistryTest methodsFor: 'tests' stamp: ''!
testVileFinalizer
	" this test checks that manipulation (or accessing) a weak registry 
	does not lead to deadlocks when performed from within a #finalize implementation"

	| reg villian proc locked |
	reg := WeakRegistry new.
	WeakArray removeWeakDependent: reg.	"to prevent test interference with finalization process"

	villian := VileFinalizer new initialize: reg.	"add object with vile finalization to registry"

	locked := true.

	proc := [ reg finalizeValues.
	locked := false ] newProcess.
	villian := nil.
	Smalltalk garbageCollect.

	proc resume.
	100 milliSeconds wait.	"give chance for created process to run "

	proc isTerminated ifFalse: [ proc terminate ].

	self assert: locked identicalTo: false! !

!WeakRegistryTest methodsFor: 'tests' stamp: ''!
testFinalization
	| w finalized block object |
	w := WeakRegistry new: 1.
	finalized := false.
	block := [ :v | finalized := v ].
	object := ObjectFinalizer receiver: block selector: #value: argument: true.	"an object that responds to #finalize"
	w add: object.
	object := nil.	"let it go"
	Smalltalk garbageCollect.	"finalize it"

	"This is an odd issue. It seems that in some situations the finalization
	process doesn't run 'in time' for the isEmpty assertion below to succeed.
	This really *shouldn't* happen since isEmpty is full of real sends and
	there ought to be an interrupt check in there somewhere. However,
	since there are no real-time guarantees about finalization, it's fair to
	just wait a little to ensure that the finalization process has been run."
	(Delay forMilliseconds: 100) wait.

	self assertEmpty: w.
	self assert: finalized! !

!WeakRegistryTest methodsFor: 'tests' stamp: ''!
testFinalizationWithBadFinalizer
	" Test that if error occurs during finalization, the finalization process continues to run normally.

		This test tests that if we adding a faulty finalizer to WeakArray's finalization dependants,
		its not causing troubles to the finalization process.	
	"

	| mock1 mock2 sema timedOut |
	mock1 := MockFinalizerAction new finalizationAction: [ self signalMockException ].
	mock2 := MockFinalizerAction new finalizationAction: [ sema signal ].
	sema := Semaphore new.

	WeakArray
		addWeakDependent: mock1;
		addWeakDependent: mock2.

	errorWasHere := false.

	Smalltalk garbageCollect.

	timedOut := sema waitTimeoutSeconds: 1.

	self assert: errorWasHere identicalTo: true.
	self assert: timedOut identicalTo: false! !

!WeakRegistryTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^ WeakRegistry! !

!WeakRegistryTest methodsFor: 'tests' stamp: ''!
testFinalizationWithMultipleFinalizersPerObject
	| object registry counter |
	registry := WeakRegistry new.
	object := Object new.
	counter := 0.
	5 timesRepeat: [ registry add: object executor: (ObjectFinalizer receiver: [ counter := counter + 1 ] selector: #value) ].
	self assert: registry size equals: 1.
	object := nil.
	Smalltalk garbageCollect.
	registry finalizeValues.
	self assertEmpty: registry.
	self assert: counter equals: 5! !

!WeakRegistryTest methodsFor: 'tests' stamp: ''!
testGrowingByAHighPriorityProcessDoesntLeak
	| w finalized block object executor semaphore |
	w := WeakRegistry new: 1.
	finalized := false.
	block := [ :v | finalized := v ].
	object := Object new.
	executor := ObjectFinalizer receiver: block selector: #value: argument: true.
	w add: object executor: executor.
	semaphore := Semaphore new.
	[ object := nil.	"let it go"
	w addAll: (1 to: 1000).	"force growing"
	semaphore signal ] forkAt: WeakArray runningFinalizationProcess priority + 1.
	semaphore wait.
	Smalltalk garbageCollect.	"finalize it"
	self assert: w size equals: 1000.
	self assert: finalized! !

!WeakSet commentStamp: ''!
I'm a Set with weak elements. 

Implementation.

	flag is a special object that indicates that at a given slot the set has a free entry.!
!WeakSet methodsFor: 'private' stamp: ''!
rehash
	self growTo: array size! !

!WeakSet methodsFor: 'removing' stamp: ''!
remove: oldObject ifAbsent: aBlock

	| index |
	index := self scanFor: oldObject.
	(array at: index) == flag ifTrue: [ ^ aBlock value ].
	array at: index put: flag.
	tally := tally - 1.
	self fixCollisionsFrom: index.
	^oldObject! !

!WeakSet methodsFor: 'private' stamp: ''!
scanForEmptySlotFor: aKey
	"Scan the key array for the first slot containing an empty slot (indicated by flag or 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.
	[ 
		| element |
		((element := array at: index) == flag or: [ element == nil ]) ifTrue: [ ^index ].
		(index := index \\ array size + 1) = start ] whileFalse.
	self errorNoFreeSpace! !

!WeakSet methodsFor: 'public' stamp: ''!
do: aBlock after: anElement

	| startIndex |
	tally = 0 ifTrue: [ ^self ].
	startIndex := anElement
		ifNil: [ 0 ]
		ifNotNil: [ self scanFor: anElement ].
	startIndex + 1 to: array size do: [ :index |
		(array at: index) ifNotNil: [ :object |
			object == flag ifFalse: [
				aBlock value: object enclosedElement] ] ]! !

!WeakSet methodsFor: 'adding' stamp: ''!
add: newObject
	"Include newObject as one of the receiver's elements, but only if
	not already present. Answer newObject"

	| index element |
	index := self scanFor: newObject.
	((element := array at: index) == flag or: [ element == nil ])
		ifTrue: [self atNewIndex: index put: newObject asCollectionElement].
	^newObject! !

!WeakSet methodsFor: 'testing' stamp: ''!
includes: anObject 
	
	^(array at: (self scanFor: anObject))
		ifNil: [ false ]
		ifNotNil: [ :object | object ~~ flag ]! !

!WeakSet methodsFor: 'private' stamp: ''!
growTo: anInteger
	"Grow the elements array and reinsert the old elements"

	| oldElements |
	oldElements := array.
	array := WeakArray new: anInteger withAll: flag.
	self noCheckNoGrowFillFrom: oldElements! !

!WeakSet methodsFor: 'private' stamp: ''!
fixCollisionsFrom: start
	"The element at start has been removed and replaced by flag.
	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)) == flag ] whileFalse: [
		element 
			ifNil: [ "This object is gone"
				array at: index put: flag.
				tally := tally - 1 ]
			ifNotNil: [
				| newIndex |
				(newIndex := self scanFor: element enclosedElement) = index ifFalse: [
					array 
						at: newIndex put: element;
						at: index put: flag ] ] ]! !

!WeakSet methodsFor: 'public' stamp: ''!
printElementsOn: aStream
	| oldPos |
	aStream nextPut: $(.
	oldPos := aStream position.
	self do: [:element | aStream print: element; space].
	aStream position > oldPos ifTrue: [aStream skip: -1 "remove the extra space"].
	aStream nextPut: $)! !

!WeakSet methodsFor: 'public' stamp: ''!
slowSize
	"Careful!! Answer the maximum amount
	of elements in the receiver, not the
	exact amount"

	| count |
	count := 0.
	1 to: array size do: [ :index |
		(array at: index) ifNotNil: [ :object |
			object == flag ifFalse: [
				count := count + 1 ] ] ].
	^count! !

!WeakSet methodsFor: 'copying' stamp: ''!
postCopy
	| oldFlag |
	super postCopy.
	oldFlag := flag.
	flag := Object new.
	array replaceAll: oldFlag with: flag.! !

!WeakSet methodsFor: 'initialization' stamp: ''!
initialize: n
	"Initialize array to an array size of n"

	flag := Object new.
	array := WeakArray new: n.
	array atAllPut: flag.
	tally := 0! !

!WeakSet methodsFor: 'private' stamp: ''!
scanFor: anObject
	"Scan the key array for the first slot containing either flag (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 := anObject hash \\ array size + 1.
	[ 
		| element |
		((element := array at: index) == flag or: [ element enclosedElement = anObject ])
			ifTrue: [ ^index ].
		(index := index \\ array size + 1) = start ] whileFalse.
	self errorNoFreeSpace! !

!WeakSet methodsFor: 'private' stamp: ''!
scanForLoadedSymbol: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements"

	| element start finish |

	start := (anObject hash \\ array size) + 1.
	finish := array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element := array at: index) == flag or: [element asString = anObject asString])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element := array at: index) == flag or: [element asString = anObject asString])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!WeakSet methodsFor: 'converting' stamp: ''!
asArray

	| newArray |
	
	newArray := OrderedCollection new.
	
	self do: [:each | newArray add: each].
	
	^ newArray asArray! !

!WeakSet methodsFor: 'accessing' stamp: ''!
like: anObject ifAbsent: aBlock
	"Answer an object in the receiver that is equal to anObject,
	or evaluate the block if not found. Relies heavily on hash properties"

	| element |
	^ ((element := array at: (self scanFor: anObject)) == flag or: [ element == nil ])
		ifTrue: [ aBlock value ]
		ifFalse: [ element enclosedElement ]! !

!WeakSet methodsFor: 'private' stamp: ''!
grow
	"Grow the elements array if needed.
	Since WeakSets just nil their slots, alot of the occupied (in the eyes of the set) slots are usually 	empty. Doubling size if unneeded can lead to BAD performance, therefore we see if reassigning 	the <live> elements to a Set of similiar size leads to a sufficiently (50% used here) empty set first.
	and reinsert the old elements"

	| oldTally |
	oldTally := tally.
	self growTo: array size.
	oldTally >> 1 < tally
		ifTrue: [ self growTo: (HashTableSizes atLeast: 2 * array size) ]! !

!WeakSet methodsFor: 'enumerating' stamp: ''!
do: aBlock

	tally = 0 ifTrue: [ ^self ].
	1 to: array size do: [ :index |
		(array at: index) ifNotNil: [ :object |
			object  == flag ifFalse: [
				aBlock value: object enclosedElement] ] ]! !

!WeakSet methodsFor: 'enumerating' stamp: ''!
collect: aBlock

	| newSet |
	newSet := self species new: self size.
	tally = 0 ifTrue: [ ^newSet ].
	1 to: array size do: [ :index |
		(array at: index) ifNotNil: [ :object |
			object == flag ifFalse: [
				newSet add: (aBlock value: object enclosedElement) ] ] ].
	^newSet! !

!WeakSet methodsFor: 'private' stamp: ''!
noCheckNoGrowFillFrom: anArray
	"Add the elements of anArray except nils and flag to me assuming that I don't contain any of them, they are unique and I have more free space than they require."

	tally := 0.
	1 to: anArray size do: [ :index |
		(anArray at: index) ifNotNil: [ :object |
			object == flag ifFalse: [ 
				array
					at: (self scanForEmptySlotFor: object enclosedElement)
					put: object.
				tally := tally + 1 ] ] ]! !

!WeakSet methodsFor: 'testing' stamp: ''!
isHealthy
	"Test that object hashes match their positions stored in set's array,
	answer true if everything ok, false otherwise
	
	WeakSet allSubInstances select: [:badSet |
		badSet isHealthy not ]
	"
	array withIndexDo: [ :element :index |
		(element isNotNil and: [ element ~~ flag ]) ifTrue: [
			(self scanFor: element) == index
				ifFalse: [ ^ false ]]].
	^ true! !

!WeakSet methodsFor: 'accessing' stamp: ''!
anyOne
	"First we will try to return any real object which is not garbage collected. It will skip all slots with flag. In case when everything is garbage collected we will return nil. WeakSet is not empty in this case (isEmpty will return false). So we should not signal any error"
	| result |
	result := super anyOne.
	^result == self 
		ifTrue: [ nil ] 
		ifFalse: [ result ]! !

!WeakSet methodsFor: 'accessing' stamp: ''!
like: anObject
	"Answer an object in the receiver that is equal to anObject,
	nil if no such object is found. Relies heavily on hash properties"

	| element |
	^(element  := array at: (self scanFor: anObject)) == flag
		ifFalse: [ element enclosedElement]! !

!WeakSetTest commentStamp: ''!
A trait for test purposes!
!WeakSetTest methodsFor: 'tests' stamp: ''!
testIncludesNil

	| ws |
	ws := self classToBeTested new.
	self deny: (ws includes: nil).
	
	"After reclamation, should not includes nil: nil counts for nothing"
	ws add: 1/2.
	ws add: 1/3.
	Smalltalk garbageCollect.
	self deny: (ws includes: nil).! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testIncludes	
	
	| weakSet transientFakeNilObject |
	weakSet := self classToBeTested new.
	#(true nil 1) do: [ :each | self deny: (weakSet includes: each) ].
	weakSet add: true.
	self assert: (weakSet includes: true).
 	weakSet remove: true.
	self deny: (weakSet includes: true).
	transientFakeNilObject := ((1 to: 1000) detect: [ :each | each asString hash - nil hash \\ weakSet capacity = 0 ]) asString. "this string will occupy the same slot as nil would"

	weakSet add: transientFakeNilObject.
	transientFakeNilObject := transientFakeNilObject copy.
	Smalltalk garbageCollect. "get rid of transientFakeNilObject"
	self deny: (weakSet includes: transientFakeNilObject).
	self deny: (weakSet includes: nil)! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testGrowWithNil
	"This test covers that grow take into account that nil are wrapped elements of sets"
	| set |
	set := self classToBeTested new.
	set add: nil.
	set grow.
	self assert: (set includes: nil)! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testAnyOneWhenAllContentsWasGarbaged
	| ws o |
	o := Object new.
	ws := self classToBeTested with: o.
	o := nil.
	Smalltalk garbageCollect.
	self assert: ws anyOne equals: nil! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testAddIncludesSizeReclaim
	| ws o2 o3 |
	o2 := 1 / 2.
	o3 := '123' copy.
	ws := self classToBeTested new.
	ws add: o2.
	ws add: o3.
	self assert: ws size equals: 2.
	self assert: (ws includes: o2).
	self assert: (ws includes: o3).

	"inclusion test does use equality, not identity"
	self assert: (ws includes: o3 copy) description: 'WeakSet are not WeakIdentitySet'.

	"only one copy is added"
	ws add: o3 copy.
	self assert: ws size equals: 2.

	"reclame objects so that slots of ws are nilled out"
	o2 := o3 := nil.
	Smalltalk garbageCollect.
	self deny: (ws includes: 1 / 2).
	self deny: (ws includes: '123' copy).

	"fast #size is not updated automatically by dead object reclamation
	But there is a slowSize trying to tell the truth"
	self assert: ws slowSize equals: 0! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testGrowWhenNecessary
	| ws objs initialSize |
	objs := (2 to: 20) collect: [:i | 1 / i].
	ws := self classToBeTested new: 5.
	initialSize := ws array size.
	1 to: objs size do: [:k | ws add: (objs at: k)].
	self assert: ws array size > initialSize
		description: 'The WeakSet grown because not enough room were preallocated'.! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testAddEqualElements
	| ws o2 o3 |
	o2 := 1 / 2.
	o3 := '123' copy.
	ws := self classToBeTested new.
	ws add: o2.
	ws add: o3.
	self assert: ws size equals: 2.
	self assert: (ws includes: o2).
	self assert: (ws includes: o3).

	"inclusion test does use equality, not identity"
	self assert: (ws includes: o3 copy) description: 'WeakSet is not WeakIdentitySet'.

	"only one copy is added"
	ws add: o3 copy.
	self assert: ws size equals: 2! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testAsArray
	| item set |
	set := self classToBeTested new.

	self assert: set asArray equals: #().

	item := Object new.
	set add: item.

	self assert: set asArray equals: {item}.

	item := nil.
	Smalltalk garbageCollect.

	self assert: set asArray equals: #()! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testDontGrowWhenUnecessary
	| ws objs initialSize |
	objs := (2 to: 20) collect: [:i | 1 / i].
	
	ws := self classToBeTested new: 20.
	initialSize := ws array size.
	objs do: [:k | ws add: k].
	objs do: [:k | ws remove: k].
	self assert: ws array size = initialSize
		description: 'The WeakSet did not have to grow because enough room were preallocated'.
	
	objs do: [:k | ws add: k + 1].
	Smalltalk garbageCollect.
	objs do: [:k | ws add: k].
	self assert: ws array size = initialSize
		description: 'The WeakSet did not have to grow because slots of reclaimed objects were recycled'.! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testAddNil
	| ws |
	ws := self classToBeTested new.
	ws add: nil.
	self assert: (ws includes: nil)! !

!WeakSetTest methodsFor: 'requirements' stamp: ''!
classToBeTested

	^ WeakSet! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testDoAfter
	| input weakSet array |
	input := (1 to: 11) collect: [ :each | each asString asSymbol ].	"Some symbols might be garbage collected without this variable"
	weakSet := self classToBeTested withAll: input.
	array := weakSet asArray.	"Assume that the elements will have the same order as the internal array of the weakset"
	0 to: array size do: [ :index | 
		| element result |
		element := array at: index ifAbsent: nil.
		result := Array new: weakSet size - index streamContents: [ :stream | weakSet do: [ :each | stream nextPut: each ] after: element ].
		self assert: result sort equals: (array allButFirst: index) sort ]! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testDoDontIterateOnReclaimedObjects
	| ws o1 o2 size |
	ws := self classToBeTested new.
	2 to: 20 do: [ :i | ws add: 1 / i ].

	o1 := 3.0.
	o2 := 4.0.
	ws
		add: o1;
		add: o2.

	"Reclaim memory"
	Smalltalk garbageCollect.

	size := 0.
	ws
		do: [ :each | 
			size := size + 1.
			self deny: each isNil ].

	self assert: size equals: 2! !

!WeakSetTest methodsFor: 'tests' stamp: ''!
testCollisions

	| ws o1 o2 o5 on remember forget |

	"create a weak set"
	ws := self classToBeTested new: 15.
	
	"select some fractions wanting same place in ws array"
	o1 := (2 to: 100) select: [:i | (ws scanFor: 1 / i) = 1].
	o2 := (2 to: 100) select: [:i | (ws scanFor: 1 / i) = 2].
	o5 := (2 to: 100) select: [:i | (ws scanFor: 1 / i) = 5].
	on := (2 to: 200) select: [:i | (ws scanFor: 1 / i) = (ws array size - 1)].
	
	"Add some fractions to the weak set, and remember a pointer for a few of them"
	remember := OrderedCollection new.
	forget := OrderedCollection new.
	ws add: (remember add: 1 / o1 first).
	ws add: (forget add: 1 / on second).
	ws add: (forget add: 1 / o1 second).
	ws add: (forget add: 1 / o5 second).
	ws add: (forget add: 1 / o2 second).
	ws add: (forget add: 1 / o1 third).
	ws add: (remember add: 1 / o2 first).
	ws add: (forget add: 1 / o5 third).
	ws add: (forget add: 1 / on third).
	ws add: (remember add: 1 / o2 fourth).
	ws add: (remember add: 1 / on first).
	ws add: (remember add: 1 / o5 first).
	
	"forget and reclaim all entries but those in remember"
	forget := nil.
	Smalltalk garbageCollect.
	
	remember do: [:m | self assert: (ws includes: m)].
	ws add: 1/on second.
	remember do: [:m | self assert: (ws includes: m)].
	
	ws add: (remember add: 1 / o1 fourth).
	ws add: (remember add: 1 / on fourth).
	remember remove: (ws remove: (1 / o5 first)).
	remember remove: (ws remove: (1 / on first)).
	remember remove: (ws remove: (1 / o2 first)).
	remember remove: (ws remove: (1 / o1 first)).
	remember do: [:m | self assert: (ws includes: m)].
	ws add: 1/on second.
	ws add: 1/o5 second.
	remember do: [:m | self assert: (ws includes: m)].! !

!WeakSetTest class methodsFor: 'building suites' stamp: ''!
shouldInheritSelectors

^true! !

!WeakSlot commentStamp: ''!
A WeakSlot is a slot that references weakly an object.

Internally it is implemented with a weak array of size one. Writing into the slot writes the only field in the array. 

weakArray at: 1 put: aValue.

Reading into the Slot reads the only field in the array.

weakArray at: 1 .

This slot inherits from IndexedSlot to guarantee that this slot has a real field inside an object.!
!WeakSlot methodsFor: 'meta-object-protocol' stamp: ''!
wantsInitialization

	^ true! !

!WeakSlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject

	^ (super read: anObject) at: 1.! !

!WeakSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject

	^(super read: anObject) at: 1 put: aValue! !

!WeakSlot methodsFor: 'code generation' stamp: ''!
emitValue: aMethodBuilder
	"Push the weak array at: 1 on the stack"
	aMethodBuilder pushInstVar: index.
	aMethodBuilder pushLiteral: 1.
	aMethodBuilder send: #at:! !

!WeakSlot methodsFor: 'code generation' stamp: ''!
emitStore: aMethodBuilder
	"generate bytecode for 'varname at: 1 put: <stackTop>'"
	| temp |
	temp := '0slotTempForStackManipulation'.
	"Pop the value to store into a temp to push it back in the right order"
	aMethodBuilder addTemp: temp.
	aMethodBuilder storeTemp: temp.
	aMethodBuilder popTop.
	
	"Push the weak array into the stack, then the arguments, then send"
	aMethodBuilder pushInstVar: index.
	aMethodBuilder pushLiteral: 1.
	aMethodBuilder pushTemp: temp.
	aMethodBuilder send: #at:put:! !

!WeakSlot methodsFor: 'initialization' stamp: ''!
initialize: anObject

	super write: (WeakArray new: 1) to: anObject! !

!WeakSlotTest methodsFor: 'tests' stamp: ''!
testReadWeakSlotCompiled
	| object slot |
	slot := #slot1 => WeakSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].
	self assert: (aClass hasSlotNamed: #slot1).
	
	object := aClass new.
	
	"now compile an accessor and read"
	self compileAccessorsFor: slot.
	self assert: object slot1 equals: nil! !

!WeakSlotTest methodsFor: 'tests' stamp: ''!
testReadWriteWeakSlotReflective
	| slot object |
	slot := #slot1 => WeakSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].
	self assert: (aClass hasSlotNamed: #slot1).
	object := aClass new.
	
	slot write: 5 to: object.
	self assert: (slot read: object) equals: 5! !

!WeakSlotTest methodsFor: 'tests' stamp: ''!
testWriteWeakSlotCompiled
	| slot object |
	slot := #slot1 => WeakSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].
	self assert: (aClass hasSlotNamed: #slot1).
	
	object := aClass new.
	
	"now compile an accessor and write"
	self compileAccessorsFor: slot.
	object slot1: 10.
	self assert: object slot1 equals: 10! !

!WeakSlotTest methodsFor: 'tests' stamp: ''!
testWeakSlotIsWeak
	| slot object |
	slot := #slot1 => WeakSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].
	self assert: (aClass hasSlotNamed: #slot1).
	object := aClass new.
	
	slot write: Object new to: object.
	Smalltalk garbageCollect.
	"the value is GCed and we get nil"
	self assert: (slot read: object) equals: nil! !

!WeakSubscriptionBuilder commentStamp: ''!
I am a wrapper around an Announcer, used to create weak subscriptions at subscription time.

Use me like this:

anAnnouncer weak subscribe: Announcement send: #foo to: barObject.

I raise an error for block subscriptions, as they require non-existing Ephemeron support to function correctly.!
!WeakSubscriptionBuilder methodsFor: 'wrapped protocol' stamp: ''!
when: anAnnouncementClass send: aSelector to: anObject
	^ self when: anAnnouncementClass do: (WeakMessageSend receiver: anObject selector: aSelector)! !

!WeakSubscriptionBuilder methodsFor: 'wrapped protocol' stamp: ''!
weak
	"already weak"
	^ self! !

!WeakSubscriptionBuilder methodsFor: 'initialization' stamp: ''!
announcer: anAnnouncer
	announcer := anAnnouncer! !

!WeakSubscriptionBuilder methodsFor: 'wrapped protocol' stamp: ''!
when: anAnnouncementClass do: aValuable
	"Do not use this message on weak announcer because it does not work. The block will hold strongly the receiver and more.
	 We need ephemerons for that'"
	"aValuable isBlock ifTrue: [  
		self error: 'Do not use this message on weak and block because it does not work. We need ephemerons for that']."
	^	announcer basicSubscribe: (
			WeakAnnouncementSubscription new 
				announcer: announcer;
				announcementClass: anAnnouncementClass;
				valuable: aValuable)! !

!WeakSubscriptionBuilder class methodsFor: 'instance creation' stamp: ''!
on: announcer
	^ self new announcer: announcer! !

!WeakValueAssociation commentStamp: ''!
I am a lookup key (acting like an association but) holding only weakly on my value.!
!WeakValueAssociation methodsFor: 'accessing' stamp: ''!
value: anObject
	"Store the argument, anObject, as the value of the receiver."

	self at: 1 put: anObject! !

!WeakValueAssociation methodsFor: 'accessing' stamp: ''!
key: aKey value: anObject 
	"Store the arguments as the variables of the receiver."

	key := aKey.
	self value: anObject! !

!WeakValueAssociation methodsFor: 'evaluating' stamp: ''!
value
	^ self at: 1! !

!WeakValueAssociation class methodsFor: 'instance creation' stamp: ''!
new
	^ self new: 1! !

!WeakValueAssociation class methodsFor: 'instance creation' stamp: ''!
key: anObject value: bObject
	^ self new key: anObject value: bObject! !

!WeakValueDictionary commentStamp: ''!
I am a dictionary holding only weakly on my values. This mean that as long as my values are referenced (via a strong reference) by other objects, they will stay but in case no object is referencing them during a garbage collection, then my value will vanish and I will return nil instead.
Clients may expect to get a nil value for any object they request since they can be garbaged collected.

Implementation details:

To store keys and values I am using a WeakValueAssociation. This association has a key and a value.
The key is the key the user is giving me, but if the user gives me a nil as value, I wrap it into a CollectionElement. This is explained because I need to do a distinction between nil values given by the user and nil values created by the garbage collection.
When the value of a WeakValueAssociation is a collection element wrapper on nil, then it means the user directly gave us a nil. In case the value of the WeakValueAssociation is nil, it means that we originally had a value that was garbaged collected.!
!WeakValueDictionary methodsFor: 'adding' stamp: ''!
associationAt: key ifAbsent: aBlock
	"Answer the association with the given key.
	If the key is not found, return the result of evaluating aBlock."

	^ (array at: (self findElementOrNil: key))
		ifNil: [ aBlock value ]
		ifNotNil: [ :assoc | assoc key -> assoc value enclosedElement ]! !

!WeakValueDictionary methodsFor: 'enumerating' stamp: ''!
associationsDo: aBlock
	"Evaluate aBlock for each of the receiver's elements (key/value associations)."

	tally = 0 ifTrue: [ ^ self ].
	array do: [ :each | each value ifNotNil: [ :value | aBlock value: each key -> value enclosedElement ] ]! !

!WeakValueDictionary methodsFor: 'adding' stamp: ''!
add: anAssociation
	self at: anAssociation key put: anAssociation value.
	^ anAssociation! !

!WeakValueDictionary methodsFor: '*Calypso-NavigationModel' stamp: ''!
clyCleanGarbage

	| firstFound |
	array withIndexDo: [:ass :index | 
		(ass notNil and: [ass value isNil]) ifTrue: [ 
			array at: index put: nil.
			tally := tally - 1.
			firstFound ifNil: [firstFound := index]]].
	
	firstFound ifNotNil: [ 
		self fixCollisionsFrom: firstFound]! !

!WeakValueDictionary methodsFor: 'accessing' stamp: ''!
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 |
	index := self findElementOrNil: key.
	(array at: index)
		ifNil: [ self atNewIndex: index put: (WeakValueAssociation key: key value: anObject asCollectionElement) ]
		ifNotNil: [ :element | element value: anObject asCollectionElement ].
	^ anObject! !

!WeakValueDictionary methodsFor: '*Ombu' stamp: ''!
at: key ifPresent: presentBlock ifAbsentOrNil: absentBlock

	^ self 
		at: key
		ifPresent: [:valueOrNil | 
			valueOrNil
				ifNotNil: presentBlock
				ifNil: absentBlock ]
		ifAbsent: absentBlock! !

!WeakValueDictionary methodsFor: 'adding' stamp: ''!
at: key ifPresent: aBlock
	"Lookup the given key in the receiver. If it is present, answer the
	value of evaluating the given block optionally with the value associated
	with the key.
	Otherwise, answer nil."

	^ (array at: (self findElementOrNil: key)) value ifNotNil: [ :value | aBlock cull: value enclosedElement ]! !

!WeakValueDictionary methodsFor: 'enumerating' stamp: ''!
valuesDo: aBlock
	"See comments in Dictionary>>valuesDo:.  The code keeps
	a reference to the value to facilitate debugging"

	tally = 0 ifTrue: [ ^ self ].
	1 to: array size do: [ :eachIndex | 
		(array at: eachIndex) value
			ifNotNil: [ :assocValue | aBlock value: assocValue enclosedElement ] ]! !

!WeakValueDictionary methodsFor: 'accessing' stamp: ''!
size
	| count |
	count := 0.
	self valuesDo: [ :each | count := count + 1 ].
	^ count! !

!WeakValueDictionary methodsFor: '*Calypso-NavigationModel' stamp: ''!
clyIncludesCleanedKey: key
	"Answer whether the receiver has a key which value was collected as garbage"
	
	^ (array at: (self scanFor: key)) value == nil! !

!WeakValueDictionary methodsFor: 'adding' stamp: ''!
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)) value
			ifNil: aBlock
			ifNotNil: [ :value | value enclosedElement ]! !

!WeakValueDictionary methodsFor: '*Collections-Tests' stamp: ''!
privateAssociations
	"I am a method used for test to return the WeakValueAssociations instead of Associations."

	^ array select: [ :each | each value isNotNil ]! !

!WeakValueDictionary methodsFor: 'testing' stamp: ''!
includesKey: key
	"Answer whether the receiver has a key equal to the argument and also that the value associated to this key was not garbage collected."

	^ (array at: (self scanFor: key))
		ifNil: [ false ]
		ifNotNil: [ :value | value value isNotNil ]! !

!WeakValueDictionary methodsFor: 'private' stamp: ''!
rehash
	| newSelf |
	newSelf := self species new: self size.
	array do: [ :each | each value ifNotNil: [ :asso | newSelf noCheckAdd: each ] ].
	array := newSelf array! !

!WeakValueDictionaryTest commentStamp: ''!
SUnit tests for weak value dictionaries!
!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testReturnedAssociationsAreRight
	| dictionary |
	dictionary := self classToBeTested new.
	dictionary at: 'test' put: nil.
	dictionary at: 'test2' put: 1.
	self assert: (dictionary associationAt: 'test') value isNil.
	self assert: (dictionary associationAt: 'test2') value equals: 1! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testKeysAndValuesDoWithGarbageCollectedValue

	self dictionaryWithGarbageCollectedValue keysAndValuesDo: [:key :value | self fail ]! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testAssociationsWithGarbageCollectedValue
	self assertEmpty: self dictionaryWithGarbageCollectedValue associations! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testAtIfPresentIfAbsentWithGarbageCollectedValue

	self
		assert:
			(self dictionaryWithGarbageCollectedValue
				at: self keyWithGarbageCollectedValue
				ifPresent: [ 41 ]
				ifAbsent: [ 42 ])
		equals: 42! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testAtIfPresentWithGarbageCollectedValue

	| dictionary |
	dictionary := self dictionaryWithGarbageCollectedValue.

	self
		assert:
			(dictionary
				at: self keyWithGarbageCollectedValue
				ifPresent: [ 42 ])
		equals: nil.! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testAtIfAbsentPutWithGarbageCollectedValue

	| dictionary |
	dictionary := self dictionaryWithGarbageCollectedValue.

	self
		assert:
			(dictionary
				at: self keyWithGarbageCollectedValue
				ifAbsentPut: [ 42 ])
		equals: 42.
		
	self assert: (dictionary includes: 42).! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testDoesNotIncludeNilAfterGarbageCollection

	self deny: (self dictionaryWithGarbageCollectedValue includes: nil)! !

!WeakValueDictionaryTest methodsFor: 'tests - size capacity' stamp: ''!
testSize
	| d |
	d := self classToBeTested new.
	self assert: d size equals: 0.
	d at: 1 put: 2.
	d at: 2 put: nil.
	self assert: d size equals: 2! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testAtIfPresent
	"Non regression test. Before we were sending #value on the value while giving it to the block to evaluate."

	| d block |
	d := self classToBeTested new.
	d at: 1 put: (block := [ 2 ]).

	d at: 1 ifPresent: [ :v | self assert: v identicalTo: block ]! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testRehashDoesNotTransformAssociations
	| d |
	d := self classToBeTested new.
	d at: 1 put: 2.
	self assert: (d privateAssociations anyOne isKindOf: WeakValueAssociation).
	d rehash.
	self assert: (d privateAssociations anyOne isKindOf: WeakValueAssociation)! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testAtGarbageCollectedValueRaisesNotFound

	self
		should: [ self dictionaryWithGarbageCollectedValue at: self keyWithGarbageCollectedValue ]
		raise: NotFound! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testAtIfAbsentWithGarbageCollectedValue

	self
		assert:
			(self dictionaryWithGarbageCollectedValue
				at: self keyWithGarbageCollectedValue
				ifAbsent: [ 42 ])
		equals: 42! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testSizeWithGarbageCollectedValue

	self
		assert: self dictionaryWithGarbageCollectedValue size
		equals: 0.! !

!WeakValueDictionaryTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ WeakValueDictionary! !

!WeakValueDictionaryTest methodsFor: 'accessing' stamp: ''!
dictionaryWithGarbageCollectedValue

	| dictionary |
	dictionary := self classToBeTested new.
	dictionary at: self keyWithGarbageCollectedValue put: Object new.
	Smalltalk garbageCollect.
	^ dictionary! !

!WeakValueDictionaryTest methodsFor: 'tests' stamp: ''!
testIncludesKeyAnswerFalseForGarbageCollectedValues
	"This test should not be called #testIncludesKey to not override that test of the same name in the superclass."

	self deny: (self dictionaryWithGarbageCollectedValue includesKey: self keyWithGarbageCollectedValue)! !

!WeakValueDictionaryTest methodsFor: 'accessing' stamp: ''!
keyWithGarbageCollectedValue

	^ #a! !

!WeakValueDictionaryTest class methodsFor: 'building suites' stamp: ''!
shouldInheritSelectors

^true! !

!WebBrowser commentStamp: ''!
General access to a webbrowser!
!WebBrowser class methodsFor: 'examples' stamp: ''!
example

	self openOn: 'http://pharo.org'! !

!WebBrowser class methodsFor: 'instance creation' stamp: ''!
openOn: anURLOrString
	"Open the webbrowser on the given URL or String"
	
	^self webbrowserClassForPlatform 
				openNativeWebBrowserOn: anURLOrString asString
! !

!WebBrowser class methodsFor: 'private - accessing' stamp: ''!
webbrowserClassForPlatform

  ^ self allSubclasses 
				detect: #isForCurrentSystem 
				ifNone: [ self error: 'No web browser subclass for platform provided' ]! !

!WebBrowser class methodsFor: 'testing' stamp: ''!
isUsed
	"all my subclasses are used by me"
	
	^self name = #WebBrowser
		ifTrue: [ super isUsed ]
		ifFalse: [ true ]! !

!WebBrowser class methodsFor: 'private' stamp: ''!
openNativeWebBrowserOn: aURLString

	self subclassResponsibility! !

!WebBrowser class methodsFor: 'testing' stamp: ''!
isForCurrentSystem

	^self subclassResponsibility ! !

!Week commentStamp: ''!
I represent a week.!
!Week methodsFor: 'converting' stamp: ''!
asWeek

	^ self! !

!Week methodsFor: 'private' stamp: ''!
species

	^Timespan! !

!Week methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: 'a Week starting: '.
	self start printOn: aStream.! !

!Week methodsFor: 'accessing' stamp: ''!
index

	^ self asMonth dayOfWeek + self dayOfMonth - 2  // 7 + 1! !

!Week class methodsFor: 'accessing' stamp: ''!
startDay: aSymbol

	(DayNames includes: aSymbol)
		ifTrue: [ StartDay := aSymbol ]
		ifFalse: [ self error: aSymbol, ' is not a recognised day name' ]! !

!Week class methodsFor: 'accessing' stamp: ''!
dayNames

	^ DayNames! !

!Week class methodsFor: 'instance creation' stamp: ''!
year: aYear week: weekNumber
	"Return the ISO week for the given week number and the given year. ISO 8601
	specifies that weeks start on a Monday, therefore the returned week will start
	on a Monday no matter what Week >> startDay is set to."

	"Note: we have to call starting:duration: from the superclass Timespan to make this work,
	 because the Week class enforces weeks to start on Week >> startDay."
	^ super starting: aYear asYear firstThursday + (weekNumber * 7 - 10) days duration: 1 week! !

!Week class methodsFor: 'accessing' stamp: ''!
startDay

	^ StartDay ifNil: [ StartDay := DayNames first ]! !

!Week class methodsFor: 'instance creation' stamp: ''!
starting: aDateAndTime duration: aDuration
	"Override - the duration is always one week.
	 Week will start from the Week class>>startDay"

	| midnight delta adjusted |
	midnight := aDateAndTime asDateAndTime midnight.
	delta := ((midnight dayOfWeek + 7 - (DayNames indexOf: self startDay)) rem: 7) abs.
	adjusted := midnight - (Duration days: delta seconds: 0).

	^ super
		starting: adjusted
		duration: (Duration weeks: 1).! !

!Week class methodsFor: 'instance creation' stamp: ''!
week: weekNumber
	"Return a week in this year"
	^ self year: Year current week: weekNumber! !

!Week class methodsFor: 'accessing' stamp: ''!
nameOfDay: anIndex

	^ DayNames at: anIndex! !

!Week class methodsFor: 'accessing' stamp: ''!
indexOfDay: aSymbol

	^ DayNames indexOf: aSymbol! !

!WeekTest commentStamp: ''!
SUnit tests for weeks!
!WeekTest methodsFor: 'tests' stamp: ''!
testByWeekNumber
	"Check some week dates, and check that the week starts on Monday
	 even though Week >> startDay is set to Sunday in setUp."
	week := Week year: 2013 week: 1.
	self assert: week start equals: (DateAndTime year: 2012 month: 12 day: 31).
	self assert: week start dayOfWeek equals: 2.

	week := Week year: 2013 week: 32.
	self assert: week start equals: (DateAndTime year: 2013 month: 8 day: 5).
	self assert: week start dayOfWeek equals: 2.
	
	week := Week year: 2013 week: 52.
	self assert: week start equals: (DateAndTime year: 2013 month: 12 day: 23).
	self assert: week start dayOfWeek equals: 2.
	
	week := Week year: 2014 week: 1.
	self assert: week start equals: (DateAndTime year: 2013 month: 12 day: 30).
	self assert: week start dayOfWeek equals: 2.! !

!WeekTest methodsFor: 'tests' stamp: ''!
testDayNames
	self assert: Week dayNames equals: #(#Sunday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday)! !

!WeekTest methodsFor: 'running' stamp: ''!
tearDown

	Week startDay: restoredStartDay.
	week := nil.
	super tearDown! !

!WeekTest methodsFor: 'tests' stamp: ''!
testInquiries
	self
		assert: week start asDate equals: '28 June 1998' asDate;
		assert: week end asDate equals: '4 July 1998' asDate;
		assert: week index equals: 5;
		assert: week duration equals: 7 days! !

!WeekTest methodsFor: 'tests' stamp: ''!
testPreviousNext
	self
		assert: week next equals: (Week starting: '6 July 1998' asDate);
		assert: week previous equals: (Week starting: '22 June 1998' asDate)! !

!WeekTest methodsFor: 'tests' stamp: ''!
testIndexOfDay
	| days |
	days := #(#Sunday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday).

	days withIndexDo: [ :item :index | self assert: (Week indexOfDay: item) equals: index ].

	"This should probably raise an error rather than returning 0."
	self assert: (Week indexOfDay: 0) equals: 0.
	self assert: (Week indexOfDay: 1) equals: 0.
	self assert: (Week indexOfDay: 7) equals: 0.
	self assert: (Week indexOfDay: 8) equals: 0.
	self assert: (Week indexOfDay: #Sunnyday) equals: 0! !

!WeekTest methodsFor: 'coverage' stamp: ''!
selectorsToBeIgnored

	| deprecated private special |

	deprecated := #().
	private := #( #printOn: ).
	special := #( #next #do: ).

	^ super selectorsToBeIgnored, deprecated, private, special.! !

!WeekTest methodsFor: 'tests' stamp: ''!
testOffset
	"Check that the offset is maintained when creating a new instance of Month from a DateAndTime"

	| dt newWeek |

	dt := DateAndTime fromString: '2018/01/01T00:00:00+10'.
	newWeek := Week starting: dt duration: 0. "duration is ignored"
	self assert: newWeek asDateAndTime offset equals: dt offset! !

!WeekTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ Week! !

!WeekTest methodsFor: 'tests' stamp: ''!
testNameOfDay
	| days |
	days := #(#Sunday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday).

	days withIndexDo: [ :item :index | self assert: (Week nameOfDay: index) equals: item ].

	self should: [ Week nameOfDay: 0 ] raise: self defaultTestError.
	self should: [ Week nameOfDay: 8 ] raise: self defaultTestError.
	self should: [ Week nameOfDay: #Sunday ] raise: self defaultTestError! !

!WeekTest methodsFor: 'tests' stamp: ''!
testEnumerating
	| days |
	days := OrderedCollection new.
	0 to: 6 do: [ :i | days add: ('28 June 1998' asDate addDays: i) ].

	week datesDo: [ :d | days remove: d ].

	self assertEmpty: days! !

!WeekTest methodsFor: 'tests' stamp: ''!
testByWeekNumberInCurrentYear
	week := Week week: 2.
	self assert: week year asYear equals: Year current.! !

!WeekTest methodsFor: 'running' stamp: ''!
setUp
	"June 1998, 5th week"

	super setUp.
	restoredStartDay := Week startDay.
	Week startDay: #Sunday.
	week := Week starting: '4 July 1998' asDate! !

!WelcomeHelp commentStamp: ''!
I'm the help page for welcoming new users. 
I pass through basic concepts to getting started with Pharo.!
!WelcomeHelp class methodsFor: 'defaults - actions' stamp: ''!
openNetworkSettings

	| browser window path |	
	browser := SettingBrowser new 
		changePackageSet: { 
			#'Network-Kernel' asPackage.
	 };
		yourself.		 
	window := browser open.
	path := (window submorphs detect: [ :each | (each isKindOf: MorphTreeMorph) ]) nodeList.
	browser expandNodePath: path! !

!WelcomeHelp class methodsFor: 'showing' stamp: ''!
open
	<script>
	^ (HelpBrowser openOn: self) next! !

!WelcomeHelp class methodsFor: 'pages' stamp: ''!
gettingHelp
	^ HelpTopic 
		title: 'Getting Help'
		contents: (self heading: 'Getting Help'),
		'Pharo has a vibrant community that shares knowledge in different ways: 

- The "Pharo Users" mailing list: 
	', (self url: 'https://lists.pharo.org/empathy/list/pharo-users.lists.pharo.org'), '
- The "Pharo Discord channel": 
	', 	(self url: 'https://discord.gg/QewZMZa'), '

You can find more information, lists to browse/suscribe and places to share code at: 

', (self url: 'http://pharo.org/community')! !

!WelcomeHelp class methodsFor: 'accessing' stamp: ''!
pages
	^ #(welcome changeLog learn exploreEnvironment documentation gettingHelp)! !

!WelcomeHelp class methodsFor: 'accessing' stamp: ''!
bookName
	"the character zero is a hack to display it always first"
	^ (Character value: 0) asString, 'Welcome'! !

!WelcomeHelp class methodsFor: 'pages' stamp: ''!
changeLog
	^ HelpTopic 
		title: 'Changes in Pharo 9'
		contents:
		(self heading: 'Changes in Pharo 9') , 
'Pharo 9 is a massive release of Pharo. It brings a large set of features and increases the stability, speed, and versatility of Pharo.  

Here are the key features of Pharo 9:   

- Full redesign of the Spec UI framework:
	- new logic, application, style, GTK back-end
- NewTools: new playground, new inspector, new debugger
- New error infrastructure and emergency debugger)
- New composable completion framework
- General speed up 
- Compiler optimisations
- Better Refactorings
- Better parser for error recognition
- Fluid (composable) class syntax
- Comments in Microdown format (Markdown compatible)
- Fast universal FFI (Foreign Function Interface)
- Idle VM + SDL20 and back-end 
	- Extended event handling, including trackpad support
- ARM 64 bits 
- Full block closures
- Much more more tests

Now in details. 

', 
(self heading: 'Amazing development activity'),
' Pharo 9 got an amazing development activity. It saw the raise of enhancements and bug fixes.  
- 252 forks on github
- 1437+ issues fixed.
- 2231+ Pull requests integrated, not counting separately managed projects such as:
	- ',(self url: 'http://github.com/pharo-spec/Spec'),'
	- ',(self url: 'http://github.com/pharo-spec/NewTools' ),'
	- ',(self url: 'http://github.com/pharo-spec/Iceberg'),'
	- ',(self url: 'http://github.com/pharo-spec/opensmalltalk'),
(self subheading: 'General Speed up'),
'Pharo 9 got a general speed up due to Pragma speed, compiler improvements and the simplification of the UI framework.', 
(self subheading: 'Pharo 9 generalizes executable comments'),
'You read the method and you systematically get examples to show you how to use the message.  
And you can execute the comment (they are also accesible as tests through the DrTest GUI)!! ', 
(self subheading: 'New and enhanced refactorings'),
'Pharo 9 did a large effort on refactorings.  
Pharo 9 is shipped with new refactorings (such as Extract to Setup XXX more?).  
Many refactorings got enhanced. Extract method can now extract a method out of methods in a full hierarchy in one click.  
Refactorings are now accessible inplace i.e., instance variables, class variables...', 
(self subsubheading: 'New refactorings'),
'1. Extract setUp method 
2. Remove senders of method refactoring
3. Copy package as refactoring 
4. Rename package (rename manifest)
5. Merge instance var x in y
6. Move to class side method
7. Create accessors with lazy initialization', 
(self subsubheading: 'Improved refactors'),
'1. Deprecate method (simple version)
2. Deprecate class
3. Extract method refactoring (comparing btw symbols and strings, show occurrences replaced)
4. Replace senders by another
5. Rename vars (traits)
6. Convert temporary to instance variable (check in the methods and methods of the subclasses if the same name of the temporary variable is used)
7. Push up method refactoring (improve messages)
8. Add access to pushUp and pushDown refactorings from source code
9. Permute parameters when add an argument
10. Abstract instance variable (now applies abstract methods when there is a reference to more than one variable in a method)

Migrate commands to commander2
- Change to use specific scopes (call refactorings with a selected scope as model)
	- Add previews to refactorings
- Expose variable refactoring commands
- Auto select protocol selected when rename

', (self heading: 'Amazing documentation activity'),
'A large set of new books is arriving with Pharo 9. Documenting many aspects of programming
in Pharo:
- Testing in Pharo
- Version control in Pharo
- Calling Foreign Functions with Pharo 
- Pharo with Style
- Zinc 
- Concurrent Programming in Pharo
- Commander 2.0
- Pharo by Example 9 soon out. 

', 
(self heading: 'New Interface Builder'),
'After 7 years of Spec was redesigned and drastically improved.  
Spec 2.0 is the foundation for all the tools of Pharo.  
It is faster and comes with:
- Different layouts and drop the slow interpreter design
- Application concept introduced (support groups of windows)
- New dialog builder
- Styling support
- Dynamic layouts are now simple and the norm
- Transmissions 
- Support for roassal and cairo drawings
- Tests
- Multiple back-ends: GTK and Morphic

', (self heading: 'New tools'),
'Pharo 9 comes with three redesigned tools: the inspector, the playground, and a new debugger.  
- Pharo arrives with a brand new inspector that can be extended based on Spec 2.0. Following the GTInspector, any object can have dedicated panes. Now defining advanced panes is as simple as defining a new spec presenter.
- The New playground supports variable sharing between multiple playgrounds.
- The New debugger supports
	- Unique object-centric debugging features: you can halt on only one specific object
	- A plugin architecture for scripting
	- A rewamped emergency debugger
	- Architecture to plug different debuggers
-  Pharo 9 includes a new code completion framework opening doors to statically learning. 
In addition, the Pharo parser has been enhanced to support better error handling. 
- Pharo 9 is has support for extra larges images (ones that can contain 30 millions lines of code).
Special search and completions are provided. 
- An extensible commander framework has been designed and is now in use.

', (self heading: 'Large clean up effort'),
' Pharo 9 got a large clean up effort. 
- Glamour and GTTools as well as their private widget sets got deprecated and  replaced by new tools. 
- Spec1 is still deprecated all tools are being rewrite to take advantage of Spec 2.0 new features.

', (self heading: 'Language improvement'),
'Pharo 9 comes also with a set of new language features. ', 
(self subheading: 'Slots'),
'First a continuous effort has be made to better support for first class instance variables (Slots)', 
(self subheading: 'Full block closures'),
'All the compiler chain and debugger got adapted to support the new format of block closures.
Such new format will enable to put in production dynamic optimisers such as Scorch or variations. It means that future Pharo versions will be able to have modern JIT compiler architecture with a speculative optimizers and not just a baseline JIT.', 
(self subheading: 'New class definition'),
'A new class definition has been designed as presented at ESUG in Slovenia.
It is based on a fluid API that controls combinatorial explosion of features.

',
(self sourceCode:'SpAbstractPresenter << #SpPresenter
	trait: SpTPresenterBuilder;
	slots: {
			 #application .
			 #focusOrder .
			 #contextKeyBindings => SpObservableSlot .
			 #windowIcon => SpObservableSlot .
			 #aboutText => SpObservableSlot .
			 #extent => SpObservableSlot .
			 #styles };
	tag: ''Base'';
	package: ''Spec2-Core''')
,'

This class definition is optional in Pharo 9 and will be default version of Pharo 10.', 
(self subheading: 'Microdown'),
'Class comments are now written in Microdown a retro-compatible version of Markdown
extended with Pillar features. In addition any class can customise the rendering of the comments
and enhance it.  
Future help will be take advantage of Microdown and its architecture.', 
(self subheading: '"Dynamic call rewriting of deprecated methods" is now systematically used'),
'With Dynamic call rewriting of deprecated methods Pharo offers a unique feature that supports the automatic migration of your code at runtime. You run your tests or your application and you can get it automatically migrated to the new API.

', 
(self heading: 'More robust and enhanced virtual machine'),
'Pharo 9 saw a massive investment and results on the Virtual machine side.  
It is available for Windows (Intel 64bits/ARM 64bits), Linux (Intel 64bits / ARM 32 bits / ARM 64bits), OSX (Intel 64bits / ARM 64 bits).  
A new VM with
- Idle support.
	- No more pulling of events).
	- Better support for server and preserves battery.

- Primitive speed improvements in Windows.

- Full image side events handling is now based on SDL2. 
	- The complete and total event information is managed at the image level. 
	- It supports gesture definition.

- First fully working ARM-based JIT for Windows, Raspberian and Apple Silicon. 

- Image can be now embeddable in the executable optionally.

- More stability due to active chasing of difficult to track bugs. 
	- Bugs are now all covered by regression tests, even the assembly level, and code compaction. 

- Pharo have more than 3000 tests on the VM. These tests have been developed and are run on all platforms on any commits. 

- Builds using OBS: Pharo is built on Arch, Debian 10, Debian 9, Fedora 31, 32, 33, Raspbian 10, Raspbian 90, openSuse Leap 15.1, openSuse Leap 15.2, openSuse Tumbleweed, Ubuntu 18.04, 19.04, 20.04, 21.04

- Native windows compilation
	- New UFFI based on [libFFI](https://sourceware.org/libffi/) with speed improvements
	- Clean up of code, repetible generation of VM code
	- Unification of Socket implementations on the different platform
	- Optional compilation
	- Documentation
	- Cleanup of Plugins

', 
(self heading: 'New threaded architecture'),
'Pharo 9 comes also with a new Threaded FFI support. In fact Threaded FFI is not a single architecture but a set of alternatives that can be choosen depending on the constraints of the OS. TFFI offers adaptability to the different constraints imposed by Cocoa or GTK.	
		
You can see the Pharo 10.0 changelog at: 

', (self url: 'https://github.com/pharo-project/pharo-changelogs/blob/master/Pharo100ChangeLogs.md')! !

!WelcomeHelp class methodsFor: 'pages' stamp: ''!
exploreEnvironment
	^ HelpTopic 
		title: 'Explore the Pharo Environment'
		contents: (self heading: 'Explore the Pharo Environment'), 
		
		'The best way to learn Pharo is to explore it by yourself. This is live objects all the way down: they can be inspected, browsed, changed... everything in the environment you have in your hands.
But sometimes it can be hard to get started with the tools and capabilities the environment provides.

The most complete and updated guide for the Pharo environment can be found in the "Updated Pharo by Example" free book. It is still a work in progress, but most of it is already done. You can find the book here: 

', (self url: 'https://github.com/SquareBracketAssociates/UpdatedPharoByExample'), '

One chapter of particular interest is the one that provides a quick tour of the environment: 

', (self url: 'https://ci.inria.fr/pharo-contribution/job/UpdatedPharoByExample/lastSuccessfulBuild/artifact/book-result/PharoTour/PharoTour.pdf')! !

!WelcomeHelp class methodsFor: 'pages' stamp: ''!
welcome
	^ HelpTopic 
		title: 'Welcome to ', Smalltalk version
		contents: (self heading: Smalltalk version withSubtitle: self pharoVersionString), 

'Welcome to Pharo, an immersive live programming environment.

Pharo is a pure object-oriented programming language and a powerful environment, focused on simplicity and immediate feedback (think IDE and OS rolled into one).

For more information, please visit here: ', (self url: 'http://pharo.org'),
(self subheading: 'Quick setup'),
'Choose your preferred color theme: ',
(self doItFrom: 'PharoLightTheme beCurrent' text: 'Light Theme'), ' or ',
(self doItFrom: 'PharoDarkTheme beCurrent' text: 'Dark Theme'), ' and ',
(self doItFrom: 'Display toggleFullscreen ' text: ' switch fullscreen mode')
,' 

Click if you need to ',
(self doItFrom: 'WelcomeHelp openNetworkSettings' text: 'setup a network proxy'), '.

You can also ',
(self doItFrom: 'SettingBrowser open' text: 'apply many other other settings').! !

!WelcomeHelp class methodsFor: 'pages' stamp: ''!
documentation
	^ HelpTopic 
		title: 'More Documentation'
		contents: (self heading: 'More Documentation'), 
		
	'The most important documentation is the one you can get by exploring the system, reading class comments and looking for examples. 
You can find "in image" help by clicking on the following expression:

', (self doItFrom: 'HelpBrowser open.'), '

This browser is also accessible from the World>Help>Help Browser menu (just click the desktop, select Help, and then Help Browser).

A compendium of Pharo documentation can be found at: 

', (self url: 'http://pharo.org/documentation'), '

There you can find:
- Pharo books: ', (self url: 'http://books.pharo.org'), '
- Screencasts: ', (self url: 'https://www.youtube.com/channel/UCp3mNigANqkesFzdm058bvw'), '
- Presentations: ', (self url: 'http://www.slideshare.net/pharoproject/')! !

!WelcomeHelp class methodsFor: 'pages' stamp: ''!
learn
	^ HelpTopic 
		title: 'Learn Pharo'
		contents: (self heading: 'Learn Pharo'), 		
'You can learn Pharo by clicking on the following expression: 
	
', (self doItFrom: 'ProfStef go.'), 

(self subheading: 'MOOC'), 
'Pharo has an excellent MOOC (Massive Open Online Course). You can find more information here: 

', (self url: 'http://mooc.pharo.org'), 

(self subheading: 'Books'), 
'There are several free Pharo books that can be download here: 

', (self url: 'http://books.pharo.org'), '

A very interesting starting point would be looking into the "Updated Pharo by Example" free book. It is still a work in progress, but most of it is already done. You can find the book here: 

', (self url: 'https://github.com/SquareBracketAssociates/UpdatedPharoByExample'), '
'! !

!WelcomeHelp class methodsFor: 'world menu' stamp: ''!
menuCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #'Welcome to Pharo')
		parent: #PharoHelp;
		order: 1;
		action: [ self open ];
		icon: ((self iconNamed: #pharoIcon) scaledToSize: 16@16);
		help: 'Welcome window for Pharo'! !

!WelcomeHelp class methodsFor: 'showing' stamp: ''!
openForRelease
	<script>
	| browser window findBlock |
	
	findBlock := [ :each | (each isKindOf: SystemWindow) and: [ each label = self bookName ] ]. 
	self currentWorld submorphs 
		detect: findBlock 
		ifFound: [ :oldWindow | oldWindow delete ].
	browser := self open.
	window := browser dependents detect: findBlock.
	window extent: 700@500.
	window center: Display extent / 2! !

!WelcomeHelp class methodsFor: 'pages' stamp: ''!
pharoVersionString

	| version | 
	
	version := SystemVersion current.

	^ String streamContents: [ :aStream  |
		version hasValidBuildNumber ifTrue: [ 
			aStream nextPutAll: 'build: '.
			version build printOn: aStream.
			aStream nextPutAll: ', '. ].
		aStream 
			nextPutAll: 'commit: ';
		   nextPutAll: version commitHashShort;
			nextPutAll: ', date: ';
			nextPutAll: version date asString]! !

!WhereIsDebugAction commentStamp: ''!
A WhereIsDebugAction highlights in the code editor the current instruction.
!
!WhereIsDebugAction methodsFor: 'accessing' stamp: ''!
defaultOrder

	^ 40! !

!WhereIsDebugAction methodsFor: 'accessing' stamp: ''!
help
	^ 'Highligh the next method to be executed (step) by the debugger.'! !

!WhereIsDebugAction methodsFor: 'actions' stamp: ''!
executeAction

	self debugger code setSelection: (self session 
		pcRangeForContext:  self currentContext)! !

!WhereIsDebugAction methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	"This action just updates the selection in the code editor. 
	No need to do any update or validation."
	self needsUpdate: false.
	self needsValidation: false.
	self withSeparatorAfter! !

!WhereIsDebugAction methodsFor: 'accessing' stamp: ''!
id

	^ #whereIs! !

!WhereIsDebugAction methodsFor: 'accessing' stamp: ''!
defaultLabel

	^ 'Where is?'! !

!WhereIsDebugAction class methodsFor: 'registration' stamp: ''!
actionType
	<debuggingAction>
	<contextMenuDebuggingAction>! !

!WideCharacterSet commentStamp: ''!
WideCharacterSet is used to store a Set of WideCharacter with fast access and inclusion test.

Implementation should be efficient in memory if sets are sufficently sparse.

Wide Characters are at most 32bits.
We split them into 16 highBits and 16 lowBits.

map is a dictionary key: 16 highBits value: map of 16 lowBits.

Maps of lowBits  are stored as arrays of bits in a ByteArray.
If a bit is set to 1, this indicate that corresponding character is present.
8192 bytes are necessary in each lowmap.
Empty lowmap are removed from the map Dictionary.

A byteArrayMap is maintained in parallel with map for fast handling of ByteString.
(byteArrayMap at: i+1) = 0 means that character of asciiValue i is absent, = 1 means present.!
!WideCharacterSet methodsFor: 'enumerating' stamp: ''!
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! !

!WideCharacterSet methodsFor: 'comparing' stamp: ''!
= anObject
	^self species == anObject species and: [
		self wideCharacterMap = anObject wideCharacterMap ]! !

!WideCharacterSet methodsFor: 'adding' stamp: ''!
add: aCharacter 
	| val high low lowmap |
	val := aCharacter asciiValue.
	val < 256 ifTrue: [self byteArrayMap at: val + 1 put: 1].
	high := val bitShift: -16.
	low := val bitAnd: 16rFFFF.
	lowmap := map at: high ifAbsentPut: ["create a chunk of 65536=8192*8 bits"
		ByteArray new: 8192].
	self setBitmap: lowmap at: low.
	^ aCharacter! !

!WideCharacterSet methodsFor: 'comparing' stamp: ''!
hash
	"Answer a hash code aimed at storing and retrieving the receiver in a Set or Dictionary.
	Two equal objects should have equal hash.
	Note: as the receiver can be equal to an ordinary CharacterSet,
	the hash code must reflect this"
	
	^self hasWideCharacters
		ifTrue: [map hash]
		ifFalse: [self asCharacterSet hash]! !

!WideCharacterSet methodsFor: 'converting' stamp: ''!
complement
	"return a character set containing precisely the characters the receiver does not"
	
	^CharacterSetComplement of: self copy! !

!WideCharacterSet methodsFor: 'testing' stamp: ''!
includes: aCharacter 
	| val high low |
	val := aCharacter asciiValue.
	high := val bitShift: -16.
	low := val bitAnd: 16rFFFF.
	^(self
		bitmap: (map
				at: high
				ifAbsent: [^ false])
		at: low) isZero not! !

!WideCharacterSet methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	map := Dictionary new.
	byteArrayMap := ByteArray new: 256! !

!WideCharacterSet methodsFor: 'testing' stamp: ''!
hasWideCharacters
	"Answer true if i contain any wide character"
	
	self do: [:e | e asciiValue >= 256 ifTrue: [^true]].
	^false! !

!WideCharacterSet methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	map := map collect: [:each | each copy]! !

!WideCharacterSet methodsFor: 'private' stamp: ''!
setBitmap: aMap at: shortInteger
	"set a single bit in aMap.
	shortInteger should be between: 0 and: 16rFFFF"
	
	| collecIndex bitIndex |
	collecIndex := shortInteger bitShift: -3.
	bitIndex := shortInteger bitAnd: 7.
	^aMap at: collecIndex + 1 put: ((aMap at: collecIndex + 1) bitOr: (1 bitShift: bitIndex))! !

!WideCharacterSet methodsFor: 'private' stamp: ''!
species
	^self hasWideCharacters
		ifTrue: [WideCharacterSet]
		ifFalse: [CharacterSet]! !

!WideCharacterSet methodsFor: 'removing' stamp: ''!
removeAll
	map removeAll.
	byteArrayMap := ByteArray new: 256! !

!WideCharacterSet methodsFor: 'private' stamp: ''!
bitmap: aMap do: aBlock
	"Execute a block with each value (0 based) corresponding to set bits.
	Implementation notes: this version works best for sparse maps.
	It has (byte lowBit) inlined for speed."
	
	| byte byteOffset lowBits |
	lowBits := #[1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 7 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 8 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 7 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 6 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1 5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1]. "The lowBits table gives a 1-based bitOffset"
	1 to: aMap size do: [:i | 
		(byte := aMap at: i) = 0 ifFalse: [
			byteOffset := (i bitShift: 3) - 9. "This byteOffset is -1 based"
			["Evaluate the block with 0-based (byteOffset + bitOffset)"
			aBlock value: (byteOffset + (lowBits at: byte)).
			"Eliminate the low bit and loop if some bit remain"
			(byte := byte bitAnd: byte - 1) = 0] whileFalse]]! !

!WideCharacterSet methodsFor: 'accessing' stamp: ''!
size
	| size |
	size := 0.
	map
		keysAndValuesDo: [:high :lowmap | self
				bitmap: lowmap
				do: [:low | size := size + 1]].
	^ size! !

!WideCharacterSet methodsFor: 'comparing' stamp: ''!
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. (and comparison)
	This version will answer a subset with only byte characters"
	
	| lowmap |
	byteArrayMap ifNil: [
		byteArrayMap := ByteArray new: 256.
		lowmap := map at: 0 ifAbsent: [^byteArrayMap].
		lowmap := lowmap copyFrom: 1 to: 32. "Keep first 8*32=256 bits..."
		self bitmap: lowmap do: [:code | byteArrayMap at: code + 1 put: 1]].
	^byteArrayMap! !

!WideCharacterSet methodsFor: 'enumerating' stamp: ''!
do: aBlock 
	map
		keysAndValuesDo: [:index :lowmap |
			| high16Bits |
			high16Bits := index bitShift: 16.
			self
				bitmap: lowmap
				do: [:low16Bits | aBlock value: (Character value: high16Bits + low16Bits)]]! !

!WideCharacterSet methodsFor: 'private' stamp: ''!
bitmap: aMap at: shortInteger
	"access a single bit in aMap.
	shortInteger should be between: 0 and: 16rFFFF"
	
	| collecIndex bitIndex |
	collecIndex := shortInteger bitShift: -3.
	bitIndex := shortInteger bitAnd: 7.
	^(aMap at: collecIndex + 1) bitAnd: (1 bitShift: bitIndex)! !

!WideCharacterSet methodsFor: 'removing' stamp: ''!
remove: aCharacter 
	| val high low lowmap |
	val := aCharacter asciiValue.
	val < 256 ifTrue: [self byteArrayMap at: val + 1 put: 0].
	high := val bitShift: -16.
	low := val bitAnd: 16rFFFF.
	lowmap := map
				at: high
				ifAbsent: [^ aCharacter].
	self clearBitmap: lowmap at: low.
	(lowmap allSatisfy: [:e | e = 0])
		ifTrue: [map removeKey: high].
	^ aCharacter! !

!WideCharacterSet methodsFor: 'private' stamp: ''!
clearBitmap: aMap at: shortInteger
	"clear a single bit in aMap.
	shortInteger should be between: 0 and: 16rFFFF"
	
	| collecIndex bitIndex |
	collecIndex := shortInteger bitShift: -3.
	bitIndex := shortInteger bitAnd: 7.
	^aMap at: collecIndex + 1 put: ((aMap at: collecIndex + 1) bitClear: (1 bitShift: bitIndex))! !

!WideCharacterSet methodsFor: 'comparing' stamp: ''!
wideCharacterMap
	^map! !

!WideCharacterSet methodsFor: 'removing' stamp: ''!
remove: aCharacter ifAbsent: aBlock
	(self includes: aCharacter) ifFalse: [^aBlock value].
	^self remove: aCharacter! !

!WideCharacterSet class methodsFor: 'instance creation' stamp: ''!
newFrom: aCollection
	| newCollection |
	newCollection := self new.
	newCollection addAll: aCollection.
	^newCollection! !

!WideCharacterSetTest commentStamp: ''!
WideCharacterSetTest holds tests for WideCharacterSet!
!WideCharacterSetTest methodsFor: 'tests' stamp: ''!
testCreation
	"By now, only creation method is newFrom:"

	| cs1 wcs1 cs2 wcs2 byteString wideString |
	byteString := 'aeiouy'.
	wideString := 'aeiouy' copyWith: 340 asCharacter.

	cs1 := CharacterSet newFrom: byteString.
	wcs1 := WideCharacterSet newFrom: byteString.
	self assert: wcs1 equals: cs1.
	self assert: wcs1 size equals: byteString size.
	
	cs2 := CharacterSet newFrom: wideString.
	wcs2 := WideCharacterSet newFrom: wideString.
	self assert: wcs2 equals: cs2.
	self assert: wcs2 size equals: wideString size.
	
	self should: [(byteString indexOfAnyOf: wcs1) = 1] description: 'This should used optimized byteArrayMap method'.
	self should: [(byteString indexOfAnyOf: wcs2) = 1] description: 'This should used optimized byteArrayMap method'.
	
	self should: [('bcd' indexOfAnyOf: wcs1) = 0] description: 'This should used optimized byteArrayMap method'.
	self should: [('bcd' indexOfAnyOf: wcs2) = 0] description: 'This should used optimized byteArrayMap method'.! !

!WideCharacterSetTest methodsFor: 'tests' stamp: ''!
testAddingToCharacterSet

	| cs wcs wc |
	cs := CharacterSet newFrom: 'aeiouy'.
	wcs := cs copy.
	wc := 4452 asCharacter.
	
	"adding a WideCharacter to an ordinary CharacterSet should turn it into a WideCharacterSet"
	wcs add: wc.

	self should: [wcs size = (cs size + 1)] description: 'We just added a Character, size should be increased by one'.
	self shouldnt: [wcs = cs] description: 'We just added a Character, sets should not be equal'.
	self shouldnt: [cs = wcs] description: 'We just added a Character, sets should not be equal'.
	self should: [cs allSatisfy: [:char | wcs includes: char]] description: 'Each character of the original CharacterSet should be included in the WideCharacterSet'.
	self should: [wcs hasWideCharacters] description: 'We just added a WideCharacter, so this WideCharacterSet definitely has one'.
	self should: [wcs includes: wc] description: 'We just added this WideCharacter, so this WideCharacterSet should include it'.
	
	wcs add: wc.
	self should: [wcs size = (cs size + 1)] description: 'We just added a Character already included in the set, size should be unchanged'.
	
	wcs remove: wc.
	self should: [wcs size = cs size] description: 'We added then removed a Character, now size should be equal to original'.
	self shouldnt: [wcs hasWideCharacters] description: 'We just removed the only WideCharacter, so this WideCharacterSet definitely has no WideCharacter'.
	
	self should: [wcs = cs] description: 'A WideCharacterSet can be equal to an Ordinary CharacterSet'.
	self should: [cs = wcs] description: 'An ordinary CharacterSet can be equal to a WideCharacterSet'.
	self should: [cs hash = wcs hash] description: 'If some objects are equal, then they should have same hash code'.! !

!WideCharacterSetTest methodsFor: 'tests' stamp: ''!
testCopy
    | theOriginal theCopy |
    theOriginal := WideCharacterSet newFrom: ('abc' copyWith: 300 asCharacter).
    theCopy := theOriginal copy.
    theCopy remove: $a.
    ^self should: [theOriginal includes: $a] description: 'Changing the copy should not change the original'.! !

!WideString commentStamp: ''!
This class represents the array of 32 bit wide characters.
!
!WideString methodsFor: 'converting' stamp: ''!
asUppercase
	"Answer a copy of self with all characters in an upper case.
	This might be a difficult task, ask Unicode."
	
	^ Unicode toUppercaseString: self! !

!WideString methodsFor: 'converting' stamp: ''!
asByteArray 
	"Convert to a ByteArray with the ascii values of the string."
	"'a' asByteArray >>> #[97]"
	"'A' asByteArray >>> #[65]"
	"'ABA' asByteArray >>> #[65 66 65]"
	| b |
	b := ByteArray new: self byteSize.
	1 to: self size * 4 do: [:i |
		b at: i put: (self byteAt: i)].
	^ b! !

!WideString methodsFor: 'accessing' stamp: ''!
byteAt: index

	| d r |
	d := (index + 3) // 4.
	r := (index - 1) \\ 4 + 1.
	^ (self wordAt: d) byteAt: ((4 - r) + 1).! !

!WideString methodsFor: 'accessing' stamp: ''!
byteAt: index put: aByte

	| d r w |
	d := (index + 3) // 4.
	r := (index - 1) \\ 4 + 1.
	w := (self wordAt: d) bitAnd: ((16rFF<<((4 - r)*8)) bitInvert32).
	w := w + (aByte<<((4 - r)*8)).
	self basicAt: d put: w.
	^ aByte.! !

!WideString methodsFor: '*Text-Scanning' stamp: ''!
scanCharactersFrom: startIndex to: stopIndex with: aCharacterScanner rightX: rightX  font: aFont
	"NB: strongly consider getting almost all these parameters from the scanner"
	"Since I'm a wide char string, I know that we have to scan multi-byte characters and handle encodings etc"
	| charSet |
	startIndex > stopIndex
		ifTrue: [^aCharacterScanner handleEndOfRunAt: stopIndex].
	charSet := self encodedCharSetAt: startIndex.
	^charSet scanMultibyteCharactersFrom: startIndex to: stopIndex in: self with: aCharacterScanner rightX: rightX font: aFont	! !

!WideString methodsFor: 'testing' stamp: ''!
isWideString
	"Answer whether the receiver is a WideString"
	^true! !

!WideString methodsFor: 'converting' stamp: ''!
asFourCode

	| result |
	self size = 1 ifFalse: [^ Error signal: 'must be exactly four octets' ].
	result := self basicAt: 1.
	(result bitAnd: 16r80000000) = 0 
		ifFalse: [ Error signal: 'cannot resolve fourcode' ].
	(result bitAnd: 16r40000000) = 0 
		ifFalse: [ ^ result - 16r80000000 ].
	^ result! !

!WideString methodsFor: 'accessing' stamp: ''!
at: index put: aCharacter
	"Store the Character into the field of the receiver indicated by the index.
	 Primitive.  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."

	<primitive: 64>
	aCharacter isCharacter
		ifTrue:
			[index isInteger
				ifTrue: [ ( index between: 1 and: self size )
					ifFalse: [ ^ self errorSubscriptBounds: index ] ]
				ifFalse: [ ^ self errorNonIntegerIndex ]]
		ifFalse:
			[ ^ self errorImproperStore ].
	self isReadOnlyObject 
		ifTrue: [ ^ self modificationForbiddenFor: #at:put: index: index value: aCharacter ].! !

!WideString methodsFor: 'accessing' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 

	<primitive: 105>
	replacement class == String ifTrue: [
		^ self replaceFrom: start to: stop with: (replacement asWideString) startingAt: repStart.
	]. 

	^ super replaceFrom: start to: stop with: replacement startingAt: repStart.! !

!WideString methodsFor: 'accessing' stamp: ''!
wordAt: index put: anInteger
	<primitive: 61>
	self basicAt: index put: anInteger.! !

!WideString methodsFor: 'accessing' stamp: ''!
byteSize

	^ self size * 4.! !

!WideString methodsFor: 'accessing' stamp: ''!
wordAt: index
	<primitive: 60>
	^ (self basicAt: index).! !

!WideString methodsFor: 'accessing' stamp: ''!
at: index
	"Answer the Character stored in the field of the receiver indexed by the
	 argument.  Primitive.  Fail if the index argument is not an Integer or is out
	 of bounds.  Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 63>
	^index isInteger
		ifTrue:
			[self errorSubscriptBounds: index]
		ifFalse:
			[self errorNonIntegerIndex]! !

!WideString methodsFor: 'copying' stamp: ''!
copyFrom: start to: stop

	| n |
	n := super copyFrom: start to: stop.
	n isOctetString ifTrue: [^ n asOctetString].
	^ n.! !

!WideString methodsFor: 'converting' stamp: ''!
asWideString 

	^ self.! !

!WideString methodsFor: 'comparing' stamp: ''!
findIn: body startingAt: start matchTable: matchTable
	
	^ self findSubstring: self in: body startingAt: start matchTable: matchTable! !

!WideString methodsFor: 'converting' stamp: ''!
asLowercase
	"Answer a copy of self with all characters in a lower case.
	This might be a difficult task, ask Unicode."
	
	^ Unicode toLowercaseString: self! !

!WideString class methodsFor: 'instance creation' stamp: ''!
fromString: aString 
	"Answer an instance of me that is a copy of the argument, aString."

	| inst |
	(aString isMemberOf: self) ifTrue: [
		^ aString copy.
	].
	inst := self new: aString size.
	1 to: aString size do: [:pos |
		inst basicAt: pos put: (aString basicAt: pos).
	].
	^ inst.! !

!WideString class methodsFor: 'instance creation' stamp: ''!
from: aString 

	| newString |
	(aString isMemberOf: self)
		ifTrue: [^ aString copy].
	newString := self new: aString size.
	1 to: aString size do: [:index | newString basicAt: index put: (aString basicAt: index)].
	^ newString! !

!WideString class methodsFor: 'instance creation' stamp: ''!
fromByteArray: aByteArray 

	| inst |
	aByteArray size \\ 4 = 0 ifFalse: [^ ByteString fromByteArray: aByteArray ].
	inst := self new: aByteArray size // 4.
	4 to: aByteArray size by: 4 do: [:i |
		inst basicAt: i // 4
			put: ((aByteArray at: i - 3) << 24) + 
				((aByteArray at: i - 2) << 16) +
				 ((aByteArray at: i - 1) << 8) +
				(aByteArray at: i)
	].

	^ inst! !

!WideString class methodsFor: '*Monticello' stamp: 'nil'!
newFromStream: s
	"Only meant for my subclasses that are raw bits and word-like.  For quick unpack form the disk."
	| len |

	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)! !

!WideStringTest commentStamp: ''!
This is the unit test for the class String. 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!
!WideStringTest methodsFor: 'tests - match' stamp: ''!
testCharactersExactlyMatching
	"from johnmci at http://bugs.squeak.org/view.php?id=5331"

	self assert: ('abc' charactersExactlyMatching: 'abc') equals: 3.
	self assert: ('abd' charactersExactlyMatching: 'abc') equals: 2.
	self assert: ('abc' charactersExactlyMatching: 'abc' asWideString) equals: 3.
	self assert: ('abd' charactersExactlyMatching: 'abc' asWideString) equals: 2.
	self assert: ('abc' asWideString charactersExactlyMatching: 'abc') equals: 3.
	self assert: ('abd' asWideString charactersExactlyMatching: 'abc') equals: 2.
	self assert: ('abc' asWideString charactersExactlyMatching: 'abc' asWideString) equals: 3.
	self assert: ('abd' asWideString charactersExactlyMatching: 'abc' asWideString) equals: 2.
	self assert: ('abc' charactersExactlyMatching: 'ABC') equals: 0! !

!WideStringTest methodsFor: 'testing' stamp: ''!
testAtPut
	"Non regression test for http://bugs.squeak.org/view.php?id=6998"
	
	| w1 |
	w1 := WideString with: (Unicode value: 402) with: $a with: (Unicode value: 400) with: $b.
	self assert: (w1 at: 2 put: $b) = $b description: 'at:put: should return the put-object'! !

!WideStringTest methodsFor: 'tests - substrings' stamp: ''!
testSubstrings
	"this is related to http://bugs.squeak.org/view.php?id=6367"

	| w1 w2 |
	w1 := WideString
		with: 401 asCharacter
		with: $a
		with: 402 asCharacter
		with: $b.
	w2 := WideString with: 403 asCharacter with: 404 asCharacter.

	self assert: w1 substrings first equals: w1.
	self assert: (w1 , ' ' , w2) substrings size equals: 2.
	self assert: (w1 , ' ' , w2) substrings last equals: w2! !

!WideStringTest methodsFor: 'tests - converting' stamp: ''!
testAsInteger
	self assert: '1796exportFixes-tkMX' asWideString asInteger equals: 1796.
	self assert: 'donald' asWideString asInteger isNil.
	self assert: 'abc234def567' asWideString asInteger equals: 234.
	self assert: '-94' asWideString asInteger equals: -94.
	self assert: 'foo-bar-92' asWideString asInteger equals: -92.

	self assert: '1796exportFixes-tkMX' asWideString asSignedInteger equals: 1796.
	self assert: 'donald' asWideString asSignedInteger isNil.
	self assert: 'abc234def567' asWideString asSignedInteger equals: 234.
	self assert: '-94' asWideString asSignedInteger equals: -94.
	self assert: 'foo-bar-92' asWideString asSignedInteger equals: -92.

	self assert: '1796exportFixes-tkMX' asWideString asUnsignedInteger equals: 1796.
	self assert: 'donald' asWideString asUnsignedInteger isNil.
	self assert: 'abc234def567' asWideString asUnsignedInteger equals: 234.
	self assert: '-94' asWideString asUnsignedInteger equals: 94.
	self assert: 'foo-bar-92' asWideString asUnsignedInteger equals: 92! !

!WideStringTest methodsFor: 'tests - compare' stamp: ''!
testCompare
	"from johnmci at http://bugs.squeak.org/view.php?id=5331"

	self assert: ('abc' compare: 'abc') equals: 2.
	self assert: ('abc' compare: 'abd') equals: 1.
	self assert: ('abd' compare: 'abc') equals: 3.
	self assert: ('abc' compare: 'abC') equals: 2.
	self assert: ('abc' compare: 'abD') equals: 1.
	self assert: ('abd' compare: 'abC') equals: 3.
	self assert: ('aBc' compare: 'abC') equals: 2.
	self assert: ('aBc' compare: 'abD') equals: 1.
	self assert: ('aDd' compare: 'abC') equals: 3.


	self assert: ('abc' compare: 'abc' asWideString) equals: 2.
	self assert: ('abc' compare: 'abd' asWideString) equals: 1.
	self assert: ('abd' compare: 'abc' asWideString) equals: 3.
	self assert: ('abc' compare: 'abC' asWideString) equals: 2.
	self assert: ('abc' compare: 'abD' asWideString) equals: 1.
	self assert: ('abd' compare: 'abC' asWideString) equals: 3.
	self assert: ('aBc' compare: 'abC' asWideString) equals: 2.
	self assert: ('aBc' compare: 'abD' asWideString) equals: 1.
	self assert: ('aDd' compare: 'abC' asWideString) equals: 3.

	self assert: ('abc' asWideString compare: 'abc') equals: 2.
	self assert: ('abc' asWideString compare: 'abd') equals: 1.
	self assert: ('abd' asWideString compare: 'abc') equals: 3.
	self assert: ('abc' asWideString compare: 'abC') equals: 2.
	self assert: ('abc' asWideString compare: 'abD') equals: 1.
	self assert: ('abd' asWideString compare: 'abC') equals: 3.
	self assert: ('aBc' asWideString compare: 'abC') equals: 2.
	self assert: ('aBc' asWideString compare: 'abD') equals: 1.
	self assert: ('aDd' asWideString compare: 'abC') equals: 3.

	self assert: ('abc' asWideString compare: 'abc' asWideString) equals: 2.
	self assert: ('abc' asWideString compare: 'abd' asWideString) equals: 1.
	self assert: ('abd' asWideString compare: 'abc' asWideString) equals: 3.
	self assert: ('abc' asWideString compare: 'abC' asWideString) equals: 2.
	self assert: ('abc' asWideString compare: 'abD' asWideString) equals: 1.
	self assert: ('abd' asWideString compare: 'abC' asWideString) equals: 3.
	self assert: ('aBc' asWideString compare: 'abC' asWideString) equals: 2.
	self assert: ('aBc' asWideString compare: 'abD' asWideString) equals: 1.
	self assert: ('aDd' asWideString compare: 'abC' asWideString) equals: 3.

	self assert: ('abc' compare: 'abc' caseSensitive: true) equals: 2.
	self assert: ('abc' compare: 'abC' caseSensitive: false) equals: 2.
	self assert: ('abc' compare: 'abc' asWideString caseSensitive: true) equals: 2.
	self assert: ('abc' compare: 'abC' asWideString caseSensitive: false) equals: 2.
	self assert: ('abc' asWideString compare: 'abc' caseSensitive: true) equals: 2.
	self assert: ('abc' asWideString compare: 'abC' caseSensitive: false) equals: 2.
	self assert: ('abc' asWideString compare: 'abc' asWideString caseSensitive: true) equals: 2.
	self assert: ('abc' asWideString compare: 'abC' asWideString caseSensitive: false) equals: 2! !

!WideStringTest methodsFor: 'tests - compare' stamp: ''!
testEqual
	"from johnmci at http://bugs.squeak.org/view.php?id=5331"

	self assert: 'abc' equals: 'abc'.
	self assert: 'abc' equals: 'abc' asWideString.
	self assert: 'abc' asWideString equals: 'abc'.
	self assert: 'abc' asWideString equals: 'abc' asWideString.
	self assert: ('abc' = 'ABC') not.
	self assert: ('abc' = 'ABC' asWideString) not.
	self assert: ('abc' asWideString = 'ABC') not.
	self assert: 'abc' asWideString equals: 'abc' asWideString.
	self assert: #[97 0 0 0] asString ~= 'a000' asWideString.
	self assert: 'a000' asWideString ~= #[97 0 0 0] asString! !

!WideStringTest methodsFor: 'testing' stamp: ''!
testIsAsciiString
	"Non-regression for https://pharo.manuscript.com/f/cases/15232 "

	self assert: '' asWideString isAsciiString equals: true.
	self assert: 'abcdefGHIJKL 98765,./@#%$' asWideString isAsciiString equals: true.

	self assert: 'éÀ' asWideString isAsciiString equals: false! !

!WideStringTest methodsFor: 'tests - relation order' stamp: ''!
testRelationOrder
	"from johnmci at http://bugs.squeak.org/view.php?id=5331"

	self assert: ('aa' < 'ab').
	self assert: ('aa' <= 'ab').
	self assert: ('aa' <= 'aa').
	self assert: ('ab' > 'aa').
	self assert: ('ab' >= 'aa').
	self assert: ('aa' >= 'aa').
	
	self assert: ('aa' < 'ab' asWideString).
	self assert: ('aa' <= 'ab' asWideString).
	self assert: ('aa' <= 'aa' asWideString).
	self assert: ('ab' > 'aa' asWideString).
	self assert: ('ab' >= 'aa' asWideString).
	self assert: ('aa' >= 'aa' asWideString).
	
	self assert: ('aa' asWideString < 'ab').
	self assert: ('aa' asWideString <= 'ab').
	self assert: ('aa' asWideString <= 'aa').
	self assert: ('ab' asWideString > 'aa').
	self assert: ('ab' asWideString >= 'aa').
	self assert: ('aa' asWideString >= 'aa').
	
	self assert: ('aa' asWideString< 'ab' asWideString).
	self assert: ('aa' asWideString<= 'ab' asWideString).
	self assert: ('aa' asWideString<= 'aa' asWideString).
	self assert: ('ab' asWideString> 'aa' asWideString).
	self assert: ('ab' asWideString >= 'aa' asWideString).
	self assert: ('aa' asWideString>= 'aa' asWideString).! !

!WideStringTest methodsFor: 'tests - relation order' stamp: ''!
testRelationOrderWithCase
	"from johnmci at http://bugs.squeak.org/view.php?id=5331"
		
	self assert: ('ABC' caseInsensitiveLessOrEqual: 'abc').
	self assert: ('ABC' caseInsensitiveLessOrEqual: 'abd').
	self assert: ('ABD' caseInsensitiveLessOrEqual: 'abc') not.
	self assert: ('ABC' caseInsensitiveLessOrEqual: 'abc' asWideString).
	self assert: ('ABC' caseInsensitiveLessOrEqual: 'abd' asWideString).
	self assert: ('ABD' caseInsensitiveLessOrEqual: 'abc' asWideString) not.
	self assert: ('ABC' asWideString caseInsensitiveLessOrEqual: 'abc').
	self assert: ('ABC' asWideString caseInsensitiveLessOrEqual: 'abd').
	self assert: ('ABD' asWideString caseInsensitiveLessOrEqual: 'abc') not.
	self assert: ('ABC' asWideString caseInsensitiveLessOrEqual: 'abc' asWideString).
	self assert: ('ABC' asWideString caseInsensitiveLessOrEqual: 'abd' asWideString).
	self assert: ('ABD' asWideString caseInsensitiveLessOrEqual: 'abc' asWideString) not.
	
	
	self assert: ('abc' caseSensitiveLessOrEqual: 'abc').
	self assert: ('abc' caseSensitiveLessOrEqual: 'abd').
	self assert: ('abd' caseSensitiveLessOrEqual: 'abc') not.
	self assert: ('abc' caseSensitiveLessOrEqual: 'abc' asWideString).
	self assert: ('abc' caseSensitiveLessOrEqual: 'abd' asWideString).
	self assert: ('abd' caseSensitiveLessOrEqual: 'abc' asWideString) not.
	self assert: ('abc' asWideString caseSensitiveLessOrEqual: 'abc').
	self assert: ('abc' asWideString caseSensitiveLessOrEqual: 'abd').
	self assert: ('abd' asWideString caseSensitiveLessOrEqual: 'abc') not.
	self assert: ('abc' caseSensitiveLessOrEqual: 'ABC') not.! !

!WideStringTest methodsFor: 'coverage' stamp: ''!
classToBeTested
	
	^  WideString! !

!WideStringTest methodsFor: 'tests - beginswith' stamp: ''!
testBeginsWith
	"from johnmci at http://bugs.squeak.org/view.php?id=5331"
	
	| w1 w2 |
	self assert: ('abc' beginsWith: 'ab').
	self assert: ('abc' beginsWith: 'ab' asWideString).
	self assert: ('abc' asWideString beginsWith: 'ab').
	self assert: ('abc' beginsWith: 'aX') not .
	self assert: ('abc' beginsWith: 'AB') not.
	self assert: ('abc' beginsWith: 'AB' asWideString) not .
	self assert: ('ABC' asWideString beginsWith: 'ab') not.

	w1 := WideString with: (Unicode value: 402) with: $a with: (Unicode value: 400) with: $b.
	w2 := WideString with: (Unicode value: 402).
	w1 beginsWith: w2.! !

!WideStringTest methodsFor: 'tests - substrings' stamp: ''!
testFindSubstring
	"This is related to http://bugs.squeak.org/view.php?id=6366
	finding substring in a WideString was broken because matchTable are byte-wise"

	| ws1 ws2 |
	self assert: ('abcd' findString: 'bc' startingAt: 1) equals: 2.
	self assert: ('abcd' asWideString findString: 'bc' startingAt: 1) equals: 2.
	self assert: ('abcd' findString: 'bc' asWideString startingAt: 1) equals: 2.
	self assert: ('abcd' asWideString findString: 'bc' asWideString startingAt: 1) equals: 2.

	ws1 := 'A' , (WideString with: (Unicode value: 530)) , 'BCD'.
	self assert: (ws1 findString: 'bc' startingAt: 1 caseSensitive: true) equals: 0.
	self assert: (ws1 findString: 'bc' startingAt: 1 caseSensitive: false) equals: 3.

	ws2 := (WideString with: (Unicode value: 530)) , 'b'.
	self assert: (ws1 findString: ws2 startingAt: 1 caseSensitive: true) equals: 0.
	self assert: (ws1 findString: ws2 startingAt: 1 caseSensitive: false) equals: 2.

	self assert: ('abc' findString: ws2 startingAt: 1 caseSensitive: true) equals: 0.
	self assert: ('abc' findString: ws2 startingAt: 1 caseSensitive: false) equals: 0! !

!WideStringTest methodsFor: 'tests - match' stamp: ''!
testMatch
	"from johnmci at http://bugs.squeak.org/view.php?id=5331"
	
	self assert: ('*baz' match: 'mobaz' ).
	self assert: ('*foo#zort' match: 'afoo3zortthenfoo3zort' ).
	self assert: ('*baz' match: 'mobaz' ).
	self assert: ('*foo#zort' match: 'afoo3zortthenfoo3zort' ).
	
	self assert: ('*baz' match: 'mobaz' asWideString).
	self assert: ('*foo#zort' match: 'afoo3zortthenfoo3zort' asWideString).
	self assert: ('*baz' match: 'mobaz' asWideString).
	self assert: ('*foo#zort' match: 'afoo3zortthenfoo3zort' asWideString).
	
	self assert: ('*baz' asWideString match: 'mobaz' ).
	self assert: ('*foo#zort' asWideString match: 'afoo3zortthenfoo3zort' ).
	self assert: ('*baz' asWideString match: 'mobaz' ).
	self assert: ('*foo#zort' asWideString match: 'afoo3zortthenfoo3zort' ).
	
	self assert: ('*baz' asWideString match: 'mobaz' asWideString).
	self assert: ('*foo#zort' asWideString match: 'afoo3zortthenfoo3zort' asWideString).
	self assert: ('*baz' asWideString match: 'mobaz' asWideString).
	self assert: ('*foo#zort' asWideString match: 'afoo3zortthenfoo3zort' asWideString).! !

!WideStringTest methodsFor: 'tests - compare' stamp: ''!
testSameAs
	"from johnmci at http://bugs.squeak.org/view.php?id=5331"

	self assert: ('abc' sameAs: 'aBc' asWideString).
	self assert: ('aBc' asWideString sameAs: 'abc').
	self assert: ( #[97 0 0 0] asString sameAs: 'Abcd' asWideString) not.
	self assert: ('a000' asWideString sameAs:  #[97 0 0 0] asString) not.! !

!WideStringTest methodsFor: 'tests - endswith' stamp: ''!
testEndsWith
	"from johnmci at http://bugs.squeak.org/view.php?id=5331"
	
	self assert: ('abc' endsWith: 'bc').
	self assert: ('abc' endsWith: 'bc' asWideString).
	self assert: ('abc' asWideString endsWith: 'bc').
	self assert: ('abc' endsWith: 'bX') not .
	self assert: ('abc' endsWith: 'BC') not.
	self assert: ('abc' endsWith: 'BC' asWideString) not .
	self assert: ('ABC' asWideString endsWith: 'bc') not.! !

!WideSymbol commentStamp: ''!
This class represents the symbols containing 32bit characters.!
!WideSymbol methodsFor: 'private' stamp: ''!
string: aString
	1 to: aString size do: [:j | 
		self privateAt: j put: (aString at: j) asInteger].
	^ self! !

!WideSymbol methodsFor: 'accessing' stamp: ''!
byteAt: index

	| d r |
	d := (index + 3) // 4.
	r := (index - 1) \\ 4 + 1.
	^ (self wordAt: d) byteAt: ((4 - r) + 1).! !

!WideSymbol methodsFor: 'accessing' stamp: ''!
byteAt: index put: aByte
	^ self modificationForbiddenFor: #byteAt:put: index: index value: aByte! !

!WideSymbol methodsFor: '*Text-Scanning' stamp: ''!
scanCharactersFrom: startIndex to: stopIndex with: aCharacterScanner rightX: rightX  font: aFont
	"NB: strongly consider getting almost all these parameters from the scanner"
	"Since I'm a wide char string, I know that we have to scan multi-byte characters and handle encodings etc"
	| charSet |
	startIndex > stopIndex
		ifTrue: [^aCharacterScanner handleEndOfRunAt: stopIndex].
	charSet := self encodedCharSetAt: startIndex.
	^charSet scanMultibyteCharactersFrom: startIndex to: stopIndex in: self with: aCharacterScanner rightX: rightX font: aFont	! !

!WideSymbol methodsFor: 'testing' stamp: ''!
isWideString
	"Answer whether the receiver is a WideString"
	^true! !

!WideSymbol methodsFor: 'private' stamp: ''!
species
	"Answer the preferred class for reconstructing the receiver."
	^WideString! !

!WideSymbol methodsFor: 'accessing' stamp: ''!
wordAt: index put: anInteger
	^ self modificationForbiddenFor: #wordAt:put: index: index value: anInteger! !

!WideSymbol methodsFor: 'accessing' stamp: ''!
byteSize

	^ self size * 4.! !

!WideSymbol methodsFor: 'accessing' stamp: ''!
wordAt: index
	<primitive: 60>
	^ (self basicAt: index).! !

!WideSymbol methodsFor: 'accessing' stamp: ''!
at: index 
	"Answer the Character stored in the field of the receiver indexed by the argument."
	^ Character value: (self wordAt: index).! !

!WideSymbol methodsFor: 'converting' stamp: ''!
asWideString 

	^ self.! !

!WideSymbol methodsFor: 'comparing' stamp: ''!
findIn: body startingAt: start matchTable: matchTable
	
	^ self findSubstring: self in: body startingAt: start matchTable: matchTable! !

!WideSymbol methodsFor: 'private' stamp: ''!
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."

	<primitive: 61>
	index isInteger
		ifTrue: [ (index between: 1 and: self size)
			ifFalse: [ ^ self errorSubscriptBounds: index] ]
		ifFalse: [^ self errorNonIntegerIndex].
	self isReadOnlyObject 
		ifTrue: [ ^ self modificationForbiddenFor: #privateAt:put: index: index value: aCharacter ].! !

!WidgetBuilt commentStamp: ''!
I am raised when a widget has been built!
!WidgetBuilt methodsFor: 'accessing' stamp: ''!
widget: anObject
	widget := anObject! !

!WidgetBuilt methodsFor: 'accessing' stamp: ''!
widget
	^ widget! !

!WidgetBuilt methodsFor: 'accessing' stamp: ''!
model: anObject
	model := anObject! !

!WidgetBuilt methodsFor: 'accessing' stamp: ''!
model
	^ model! !

!WidgetBuilt class methodsFor: 'instance creation' stamp: ''!
model: model widget: widget

	^ self new
		model: model;
		widget: widget;
		yourself! !

!WidgetExample commentStamp: ''!
This class provides examples on how different widgets can be made.
See the methods starting with "example" in my class side.

Examples for different widgets:

WidgetExamples exampleBasicControls.
WidgetExamples exampleOtherControls.
WidgetExamples exampleColorControls.
WidgetExamples exampleDialogs.
WidgetExamples exampleGroups.
WidgetExamples exampleTextEntryWithCompletionDialog.
WidgetExamples exampleWindowWithToolbars.!
!WidgetExample class methodsFor: 'examples' stamp: ''!
exampleBasicControls
	"Open a window with examples of each of the basic controls."
	"self exampleBasicControls"
	<script>
	|dialog builder radioModel treeModel|
	builder := self builder.
	dialog := (builder newPluggableDialogWindow: 'Example basic controls') useDefaultOKButton.
	radioModel := ExampleRadioButtonModel new.
	treeModel := Array with:(MorphWithSubmorphsWrapper with: self currentWorld).
	dialog contentMorph: ((dialog newRow: {
		dialog newLabelGroup: {
			'Normal Label'->(dialog newLabel: 'A Label').
			'Disabled Label'->(dialog newLabel: 'A Disabled Label') disable.
			'Normal Button'->(dialog newButtonFor: nil action: nil label: 'A Button' help: 'This is a button').
			'Default Button'->((dialog newButtonFor: nil action: nil label: 'Default Button' help: 'This is a default button') isDefault: true).
			'Disabled Button'->(dialog newButtonFor: nil action: nil label: 'Disabled Button'
							help: 'This is a disabled button') disable.
			'Selected Button'->(dialog newButtonFor: (NewValueHolder new value: true) getState: #value
							action: nil arguments: #() getEnabled: nil label: 'A Button' help: 'This is a selected button').
			'Selected Disabled Button'->(dialog newButtonFor: (NewValueHolder new value: true) getState: #value
							action: nil arguments: #() getEnabled: nil label: 'Disabled Button'
							help: 'This is a selected disabled button') disable.
			'Checkbox'->(dialog newCheckboxFor: (NewValueHolder new value: true)
							getSelected: #value setSelected: #value: label: 'A Checkbox' help: 'This is a checkbox').
			'Disabled Checkbox'->(dialog newCheckboxFor: (NewValueHolder new value: true)
							getSelected: #value setSelected: #value:
							label: 'A Disabled Checkbox' help: 'This is a disabled checkbox') disable.
			'Radio Buttons'->((dialog newColumn: {
								(dialog newRadioButtonFor: radioModel
									getSelected: #isLeft setSelected: #beLeft label: 'Left' help: 'This is a radio buton').
								(dialog newRadioButtonFor: radioModel
									getSelected: #isCenter setSelected: #beCenter label: 'Center' help: 'This is a radio buton').
								(dialog newRadioButtonFor: radioModel
									getSelected: #isRight setSelected: #beRight label: 'Right' help: 'This is a radio buton')})
								vResizing: #shrinkWrap).
			'Disabled Radio Button'->(dialog newRadioButtonFor: radioModel
									getSelected: #isRight setSelected: #beRight label: 'Right'
									help: 'This is a disabled radio buton') disable.
			'Text Entry'->(dialog newTextEntryFor: (NewValueHolder new value: 'Hello')
							getText: #value setText: #value: help: 'This is a text entry').
			'Disabled Text Entry'->(dialog newTextEntryFor: (NewValueHolder new value: 'Hello')
							getText: #value setText: #value: help: 'This is a disabled text entry') disable.
			'Slider'->(dialog newSliderFor: (NewValueHolder new value: 0.5)
							getValue: #value setValue: #value: help: 'This is a slider').
			'Disabled Slider'->(dialog newSliderFor: (NewValueHolder new value: 0.75)
							getValue: #value setValue: #value: help: 'This is a disabled slider') disable}.
			dialog newVerticalSeparator.
			dialog newLabelGroup: {
			'Drop List'->(dialog newDropListFor: (ListPresenter new items: #('One' 'Two' 'Three' 'Four'))
							list: #getList getSelected: #selectedIndex setSelected: #setSelectedIndex: help: 'This is a drop list').
			'Disabled Drop List'->(dialog newDropListFor: (ListPresenter new items: #('One' 'Two' 'Three' 'Four'); setSelectedIndex: 3)
							list: #getList getSelected: #selectedIndex setSelected: #setSelectedIndex:
							help: 'This is a disabled drop list') disable.
			'Editable Drop List'->(dialog newEditableDropListFor: (ListPresenter new items: SortedCollection new)
							list: #getList getSelected: #selectedIndex setSelected: #setSelectedIndex:
							addToList: #add: ghostText: 'Enter new items' getEnabled: nil help: 'This is an editable drop list').
			'Morph Drop List'->(dialog newMorphDropListFor: (ListPresenter new items: ((Color red wheel: 20)
									collect: [:c | Morph new extent: 120@12; color: c]))
							list: #getList getSelected: #selectedIndex setSelected: #setSelectedIndex:
							help: 'This is a morph drop list').
			'Normal List'->((dialog newListFor: (ListPresenter new items: #('One' 'Two' 'Three' 'Four'); setSelectedIndex: 3)
							list: #getList selected: #selectedIndex changeSelected: #setSelectedIndex:
							help: 'This is a list') minWidth: 120).
			'Disabled List'->(dialog newListFor: (ListPresenter new items: #('One' 'Two' 'Three' 'Four'); setSelectedIndex: 3)
							list: #getList selected: #selectedIndex changeSelected: #setSelectedIndex:
							help: 'This is a disabled list') disable.
			'Morph List'->(dialog newMorphListFor: (ListPresenter new items: ((Color red wheel: 20)
									collect: [:c | Morph new extent: 80@12; color: c]))
							list: #getList getSelected: #selectedIndex setSelected: #setSelectedIndex:
							help: 'This is a morph list').
			'Tree'->((dialog newTreeFor: treeModel list: #value selected: nil changeSelected: nil) minHeight: 100)}.
			dialog newVerticalSeparator.
			dialog newColumn: {
				dialog newTitle: 'Text Editor' for: (
					(dialog newTextEditorFor: (NewValueHolder new value: 'Hello')
						getText: #value setText: #value:) minWidth: 100).
				dialog newTitle: 'Disabled Text Editor' for: (
					(dialog newTextEditorFor: (NewValueHolder new value: 'Hello')
						getText: #value setText: #value:) disable)}})
			vResizing: #spaceFill);
		model: nil.
	dialog openModal! !

!WidgetExample class methodsFor: 'examples' stamp: ''!
exampleColorControls
	"Open a window with examples of each of the color controls."
	"self exampleColorControls"
	<script>
	| dialog builder|
	builder := self builder.
	dialog := (builder newPluggableDialogWindow: 'Example color controls') useDefaultOKButton.
	dialog contentMorph: (dialog newRow: {
		dialog newLabelGroup: {
			'Alpha Selector'->(dialog newAlphaSelector: (NewValueHolder new value: 0)
							getAlpha: #value setAlpha: #value: help: 'This is an alpha channel selector').
			'Hue Selector'->(dialog newHueSelector: (NewValueHolder new value: 0)
							getHue: #value setHue: #value: help: 'This is a hue selector').
			'SV Color Selector'->((dialog newSVSelector: Color yellow
									help: 'This is a saturation-volume selector') minHeight: 80).
			'HSV Color Selector'->((dialog newHSVSelector: Color green
									help: 'This is a hue-saturation-volume selector') minHeight: 80; minWidth: 120)}.
		dialog newVerticalSeparator.
		dialog newTitle: 'HSVA Color Selector' for:
			((dialog newHSVASelector: Color cyan
					help: 'This is a hue-saturation-volume-alpha selector')
					minHeight: 184; minWidth: 184)});
		model: nil.
	dialog openModal! !

!WidgetExample class methodsFor: 'examples' stamp: ''!
exampleDialogs
	"Open an example of each services dialog"
	"self exampleDialogs"
	<script>
	
	self builder
		chooseFont: TextStyle default defaultFont;
		chooseColor: (Color r: 0.529 g: 0.611 b: 0.004);
		chooseDirectory: 'Choose folder';
		textEntry: 'Choose a name for the project' title: 'Save project' entryText: 'My Project';
		chooseDropList: 'Pick one!!' list: #('One' 'Two' 'Three' 'Four');
		deny: 'Opening the safe is not possible!!';
		message: 'Hello!!';
		proceed: 'Save image?';
		alert: 'Danger!!';
		abort: 'Something has gone wrong...';
		question: 'Save the file?' title: 'Exiting application';
		questionWithoutCancel: 'Save image as well?' title: 'Exiting application'! !

!WidgetExample class methodsFor: 'examples - cleanup' stamp: ''!
closeExampleDialogs
	"Close the example dialogs."
	"self closeExampleDialogs"
	<script>
	DialogWindowMorph allSubInstances do: [:d | d cancel]! !

!WidgetExample class methodsFor: 'examples' stamp: ''!
exampleGroups
	"Open a window with examples of each of the group type morphs."
	"self exampleGroups"
	<script>
	| dialog builder |
	builder := self builder.
	dialog := (builder newPluggableDialogWindow: 'Example groups')
		useDefaultOKButton.
	dialog
		contentMorph:
			((dialog
				newRow:
					{(dialog
						newLabelGroup:
							{('Plain Groupbox'
								->
									(dialog
										newGroupboxForAll:
											{(dialog
												newButtonFor: nil
												action: nil
												label: 'A Button'
												help: 'This is a button').
											(dialog
												newButtonFor: nil
												action: nil
												label: 'A Button'
												help: 'This is a button')})).
							('Groupbox'
								->
									(dialog
										newGroupbox: 'A groupbox'
										forAll:
											{(dialog
												newButtonFor: nil
												action: nil
												label: 'A Button'
												help: 'This is a button').
											(dialog
												newButtonFor: nil
												action: nil
												label: 'A Button'
												help: 'This is a button')}))}).
					(dialog
						newLabelGroup:
							{('Tab Group'
								->
									(dialog
										newTabGroup:
											{((dialog
												newRow:
													{(dialog newImage: (self iconNamed: #smallLeftFlushIcon)).
													(dialog newLabel: 'Page 1')})
												->
													(dialog
														newGroupbox: 'A groupbox'
														forAll:
															{(dialog
																newButtonFor: nil
																action: nil
																label: 'A Button'
																help: 'This is a button').
															(dialog
																newButtonFor: nil
																action: nil
																label: 'A Button'
																help: 'This is a button')})).
											('Page 2'
												->
													(dialog
														newCheckboxFor: (NewValueHolder new value: true)
														getSelected: #value
														setSelected: #value:
														label: 'A Checkbox'
														help: 'This is a checkbox'))}))})})
				vResizing: #spaceFill);
		model: nil.
	dialog openModal! !

!WidgetExample class methodsFor: 'examples' stamp: ''!
exampleOtherControls
	"Open a window with examples of each of the other controls."
	"self exampleOtherControls"
	<script>
	| dialog builder image emboss fuzzy |
	builder := self builder.
	dialog := (builder newPluggableDialogWindow: 'Example other controls') useDefaultOKButton.
	emboss := (dialog newString: 'Hello there') trackPaneColor: false.
	fuzzy := (dialog newFuzzyLabel: 'A Fuzzy Label') minHeight: 40; minWidth: 160.
	dialog contentMorph: (dialog newRow: {
		dialog newTitle: 'Alpha Image' for: (
			dialog newColumn: {
				((image := dialog newAlphaImage: nil help: 'This is an alpha image')
					borderWidth: 1;
					extent: 160@160).
				dialog newLabelGroup: {
				'Scale'->(dialog newSliderFor: image getValue: #scale setValue: #scale:
					min: 0 max: 4 quantum: nil
					getEnabled: nil help: 'The image scale 0..1').
				'Alpha'->((dialog newAlphaSelector: image getAlpha: #alpha setAlpha: #alpha: help: 'The image alpha')
					vResizing: #shrinkWrap;
					minHeight: 16).
				'Layout'->(dialog newDropListFor: image list: #layoutSymbols
					getSelected: #layout setSelected: #layout:
					getEnabled: nil useIndex: false help: 'The image layout')}}).
		dialog newVerticalSeparator.
		dialog newLabelGroup: {
			'Color presenter'->((dialog newColorPresenterFor: (NewValueHolder new value: (Color blue alpha: 0.6))
					getColor: #value help: 'This is a color presenter')
					vResizing: #shrinkWrap).
			'Color chooser'->(dialog newColorChooserFor: emboss
					getColor: #color setColor: #color: help: 'This is a color chooser').
			'Row with dashed border'->((dialog newRow: {dialog newLabel: 'I have a dashed border!!'})
					borderStyle: (DashedBorderStyle width: 3
							dashColors: {Color red. Color green. Color blue} dashLengths: #(1 2 3))).
			'Embossed string'->emboss.
			'Style'->(dialog newDropListFor: emboss list: #styleSymbols
					getSelected: #style setSelected: #style:
					getEnabled: nil useIndex: false help: 'The embossed string style').
			'Fuzzy label'->fuzzy.
			'Offset'->(dialog newSliderFor: fuzzy getValue: #offset setValue: #offset:
					min: 0 max: 5 quantum: 1
					getEnabled: nil help: 'The fuzzy label offset').
			'Alpha'->((dialog newAlphaSelector: fuzzy getAlpha: #alpha setAlpha: #alpha:
					help: 'The fuzzy label alpha')
					vResizing: #shrinkWrap;
					minHeight: 16)}.
		dialog newVerticalSeparator.
		dialog newTitle: 'Expanders' for: (
			(dialog newColumn: {
				(dialog newExpander: 'An Expander' forAll: {
					dialog newLabel: 'Expanded!!'.
					builder newMorphListFor: (ListPresenter new items: ((Color red wheel: 15)
									collect: [:c | Morph new extent: 80@12; color: c]))
							list: #getList getSelected: #selectedIndex setSelected: #setSelectedIndex:
							help: 'This is a morph drop list'}) minWidth: 100.
				dialog newExpander: 'Another' forAll: {
					dialog newLabel: 'Expanded!!'.
					builder newMorphDropListFor: (ListPresenter new items: ((Color red wheel: 8)
									collect: [:c | Morph new extent: 80@12; color: c]))
							list: #getList getSelected: #selectedIndex setSelected: #setSelectedIndex:
							help: 'This is a morph drop list'}})
				cellInset: 0;
				borderStyle: (BorderStyle inset baseColor: dialog paneColor; width: 1))});
		model: nil.
	dialog openModal! !

!WidgetExample class methodsFor: 'examples' stamp: ''!
exampleTextEntryWithCompletionDialog
	"self exampleTextEntryWithCompletionDialog"
	<script>
	| applicants entryCompletion |
	applicants := (Array
				streamContents: [:strm | Symbol
						allSymbolTablesDo: [:each | (each notEmpty
									and: [each first canBeGlobalVarInitial
											and: [Smalltalk globals includesKey: each]])
								ifTrue: [strm nextPut: each]]]) sort.
	entryCompletion := EntryCompletion new
				dataSourceBlock: [:currText | applicants];		
				filterBlock: [:currApplicant :currText | currText size > 3
						and: [currApplicant asUppercase includesSubstring: currText asString asUppercase]].
	UIManager default
		request: 'Enter a class name fragment (at least 4 characters)'
		initialAnswer: ''
		title: 'Text entry with completion example: simple find a class'
		entryCompletion: entryCompletion! !

!WidgetExample class methodsFor: 'private - accessing' stamp: ''!
builder
	"Answer a morph that implements TEasilyThemed but without honouring modality
	for the example dialogs."
	"self exampleBuilder"
	<sampleInstance>
	^ExampleBuilderMorph new! !

!WidgetExample class methodsFor: 'examples' stamp: ''!
exampleWindowWithToolbars
	"Open an example window with toolbars."
	"self exampleWindowWithToolbars"
	<script>
	
	| win fileMenu tools dock text holder |
	win := StandardWindow new.
	fileMenu := win newMenu.
	fileMenu addToggle: 'Open' translated target: nil selector: #openFile.	"would be model"
	fileMenu lastItem
		font: win theme menuFont;
		icon: (self iconNamed: #smallOpenIcon);
		keyText: 'Ctrl+O'.
	fileMenu
		addToggle: 'Save' translated
		target: nil
		selector: #saveFile
		getStateSelector: nil
		enablementSelector: nil.
	fileMenu lastItem
		font: win theme menuFont;
		icon: (self iconNamed: #smallSaveIcon);
		keyText: 'Ctrl+S'.
	fileMenu
		addToggle: 'Print...' translated
		target: nil
		selector: #print.
	fileMenu lastItem
		font: win theme menuFont;
		icon: (self iconNamed: #smallPrintIcon);
		keyText: 'Ctrl+P'.
	tools := win
		newToolbar:
			{(win
				newButtonFor: nil
				getState: nil
				action: #openFile
				arguments: nil
				getEnabled: nil
				labelForm: (self iconNamed: #smallOpenIcon)
				help: 'Open file' translated).	"if we had a model it would go here"
			(win
				newButtonFor: nil
				getState: nil
				action: #saveFile
				arguments: nil
				getEnabled: nil
				labelForm: (self iconNamed: #smallSaveIcon)
				help: 'Save file' translated).
			(win
				newButtonFor: nil
				getState: nil
				action: #print
				arguments: nil
				getEnabled: nil
				labelForm: (self iconNamed: #smallPrintIcon)
				help: 'Print' translated)}.
	holder := NewValueHolder new.
	text := win
		newTextEditorFor: holder
		getText: #value
		setText: #value:.
	dock := win newToolDockingBar.
	dock
		add: 'File' translated
			font: win theme menuBarFont
			icon: (self iconNamed: #smallOpenIcon)
			help: 'File operations' translated
			subMenu: fileMenu;
		addMorphBack: tools.
	win
		addMorph: dock
			fullFrame: (LayoutFrame identity bottomFraction: 0;  bottomOffset: dock minExtent y);
		addMorph: text
			fullFrame: (LayoutFrame identity topOffset: dock minExtent y).
	win
		themeChanged;
		openInWorld! !

!WidgetExample class methodsFor: 'examples' stamp: ''!
colorControls
	"Open a window with examples of each of the color controls."
	"self exampleColorControls"
	<script>
	|dialog builder|
	builder := self builder.
	dialog := (builder newPluggableDialogWindow: 'Example color controls') useDefaultOKButton.
	dialog contentMorph: (dialog newRow: {
		dialog newLabelGroup: {
			'Alpha Selector'->(dialog newAlphaSelector: (NewValueHolder new value: 0)
							getAlpha: #value setAlpha: #value: help: 'This is an alpha channel selector').
			'Hue Selector'->(dialog newHueSelector: (NewValueHolder new value: 0)
							getHue: #value setHue: #value: help: 'This is a hue selector').
			'SV Color Selector'->((dialog newSVSelector: Color yellow
									help: 'This is a saturation-volume selector') minHeight: 80).
			'HSV Color Selector'->((dialog newHSVSelector: Color green
									help: 'This is a hue-saturation-volume selector') minHeight: 80; minWidth: 120)}.
		dialog newVerticalSeparator.
		dialog newTitle: 'HSVA Color Selector' for:
			((dialog newHSVASelector: Color cyan
					help: 'This is a hue-saturation-volume-alpha selector')
					minHeight: 184; minWidth: 184)});
		model: nil.
	dialog openModal! !

!WidgetExamples class methodsFor: 'testing' stamp: ''!
isDeprecated 
	^ true! !

!WikiStyleHelp commentStamp: ''!
This help type extends the system with a wiki like help descriptions!
!WikiStyleHelp class methodsFor: 'converting' stamp: ''!
asHelpTopic 
	<systemHelp>
	
	^WikiStyleHelpBuilder new build topicToBuild! !

!WikiStyleHelpBuilder commentStamp: ''!
I'm an HelpSystem builder which create an HelpSystem book from a wiki-like formatted string. 

!! Usage

- Create a class-side method on the class you want to put documentation.
- Add the pragma <wikiStyleHelp:> with the title of the book as parameter
- The method should answer the documentation as a String (using Pier syntax. See http://www.piercms.com/doc/syntax ). 

!! Example

MyClass class>>aMethod
        <wikiStyleHelp: #'The name of the book I want to write'>
        ^ '
 !! Section 1

 Some text for this section

 !!!! Subsection 1.1
 !!!!!! Subsection 1.1.1
 !!!! Subsection 1.2
 !! Section 2'!
!WikiStyleHelpBuilder methodsFor: 'private - extraction' stamp: ''!
helpTag
	^  #help! !

!WikiStyleHelpBuilder methodsFor: 'private - extraction' stamp: ''!
helpStopMarker
	^  '</', self helpTag, '>'! !

!WikiStyleHelpBuilder methodsFor: 'private - accessing' stamp: ''!
helpContentFromString: aString
	| start stop |
	start := aString findString: self helpStartMarker.
	start := start = 0
		ifTrue: [ 1 ]
		ifFalse: [ start + self helpStartMarker size ].
	stop := aString findString: self helpStopMarker startingAt: start.
	stop := stop = 0
		ifTrue: [ aString size ]
		ifFalse: [ stop - 1 ].
	^ (aString copyFrom: start to: stop) trimBoth! !

!WikiStyleHelpBuilder methodsFor: 'private - conversion' stamp: ''!
helpTopicFromFormattedString: aString title: aTitle
	| helpString currentLevel section topicStack topic |
	helpString := aString.
	topicStack := Stack new.
	topicStack push: (HelpTopic new title: aTitle).
	currentLevel := 0.
	section := ''.
	helpString 
		linesDo: [:line | 
			(line beginsWith: self sectionStartChar asString)
				ifTrue: [ |  level title |					
					section ~= ''
						ifTrue: [topicStack top contents: section trimLeft.
							section := ''].
					level := 0.
					[(level < line size) and: [(line at: level + 1) = self sectionStartChar]]
						whileTrue: [level := level + 1].
					title := (line copyFrom: level + 1 to: line size) trimLeft.
					level > currentLevel 
						ifTrue: [(level - currentLevel)
							timesRepeat: [topicStack push:  HelpTopic new].
							topicStack top title: title]
						ifFalse: [currentLevel = level
							ifTrue: [topic := topicStack pop.
								topicStack top addSubtopic: topic.
								topicStack push: (HelpTopic new title: title)]
							ifFalse: [
								(currentLevel - level) + 1 
									timesRepeat: [topic := topicStack pop.
										topicStack top addSubtopic: topic].
								topicStack push: (HelpTopic new title: title)]].
					currentLevel := level]
				ifFalse: [section := section, String cr, line]].
	section ~= ''
		ifTrue: [topicStack top contents: section trimLeft].
	[topicStack isEmpty]
		whileFalse: [topic := topicStack pop.
			topicStack isEmpty ifFalse: [topicStack top addSubtopic: topic]].
	^ topic! !

!WikiStyleHelpBuilder methodsFor: 'private - extraction' stamp: ''!
helpStartMarker
	^  '<', self helpTag, '>'! !

!WikiStyleHelpBuilder methodsFor: 'private - extraction' stamp: ''!
extractHelpContentFromString: aString
	| start stop |
	start := aString findString: self helpStartMarker.
	start := start = 0
		ifTrue: [ 1 ]
		ifFalse: [ start + self helpStartMarker size ].
	stop := aString findString: self helpStopMarker startingAt: start.
	stop := stop = 0
		ifTrue: [ aString size ]
		ifFalse: [ stop - 1 ].
	^ (aString copyFrom: start to: stop) trimBoth! !

!WikiStyleHelpBuilder methodsFor: 'building' stamp: ''!
build
	| text extract topic |
	topicToBuild title: 'Wiki style help' translated.
	self class allHelpPragmas
		do: [ :each | 
			"Its assumed that if the pragma is a single keyword only the title is given
		 and the default syntax applies, otherwise the syntax is given as last parameter
		 on the pragmas keyword message"
			text := each method methodClass instanceSide perform: each method selector.
			extract := self extractHelpContentFromString: text.
			topic := self helpTopicFromFormattedString: extract title: each arguments first.
			topicToBuild addSubtopic: topic ]! !

!WikiStyleHelpBuilder methodsFor: 'private - accessing' stamp: ''!
defaultSyntax
	^#pier! !

!WikiStyleHelpBuilder methodsFor: 'private - accessing' stamp: ''!
supportedSyntaxes
	^#(pier)! !

!WikiStyleHelpBuilder methodsFor: 'private - accessing' stamp: ''!
sectionStartChar
	^ $!!! !

!WikiStyleHelpBuilder class methodsFor: 'help' stamp: ''!
help
        <wikiStyleHelp: #'Write documentation with wiki like syntax'>
        ^ 'From WikiStyleHelpBuilder comment: ', String cr, self comment! !

!WikiStyleHelpBuilder class methodsFor: 'private - accessing' stamp: ''!
allHelpPragmas
	^ self pragmaKeywords flatCollect: [ :keyword | Pragma allNamed: keyword ]! !

!WikiStyleHelpBuilder class methodsFor: 'private - accessing' stamp: ''!
pragmaKeyword
	 ^#wikiStyleHelp:! !

!WikiStyleHelpBuilder class methodsFor: 'private - accessing' stamp: ''!
pragmaKeywords
	 ^#(wikiStyleHelp: wikiStyleHelp:syntax:)! !

!WikiStyleHelpBuilderTest commentStamp: ''!
SUnit tests for class WikiStyleHelpBuilder!
!WikiStyleHelpBuilderTest methodsFor: 'testing' stamp: ''!
testDefaultSyntaxAlwaysPier
	self assert: builder defaultSyntax identicalTo: #pier! !

!WikiStyleHelpBuilderTest methodsFor: 'accessing' stamp: ''!
defaultTestClass
	^WikiStyleHelpBuilder! !

!WikiStyleHelpBuilderTest methodsFor: 'testing' stamp: ''!
testExtractHelpContentsFromMarkedString
	| content |
	content := builder extractHelpContentFromString: 'outer<help>inner</help>outer'.
	self assert: content equals: 'inner'! !

!WikiStyleHelpBuilderTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	builder := self defaultTestClass new! !

!WikiStyleHelpTest commentStamp: ''!
SUnit tests for WikiStyleHelp!
!WikiStyleHelpTest methodsFor: 'testing' stamp: ''!
testOpenBrowserOnThisHelpType
	| browser |
	browser := HelpBrowser openOn: WikiStyleHelp.
	self currentWorld doOneCycleNow.
	browser close! !

!Win32Environment commentStamp: ''!
I am a specialized OSEnvironment for Windows.
See my superclass to understand my common usage.

# Encoding Management

Windows hides the environment variables encoding through its API, and it's not up to the user how to encode them.
Thus, I do not propose an API to specify encodings.

# Implementation Details 

I use FFI calls to manage encodings. Pharo strings are first encoded in utf8 and used to create Win32 WideStrings, whose are used in the windows function calls.
See Win32WideString!
!Win32Environment methodsFor: 'private' stamp: ''!
doGetEnvVariable: aVariableName bufferSize: aSize ifAbsent: aBlock isRetry: isRetry
	| name buffer return lastErrCode |

	name := aVariableName asWin32WideString.
	buffer := Win32WideString new: aSize.

	"This Windows API to get the environment variable has ambiguous behavior when handling environment variables with empty values.
	In the case of a empty string, the API call to get the environment variable returns 0. 
	We need to differentiate the 0 in the case of an empty string and when there is an error.
	To do so, we are clearing the last error variable, and also we are retrying.
	The retrying is needed because we can have a race condition between different API calls."

	lastErrCode := OSPlatform current setLastError: 0.
	return := OSPlatform current getEnvironmentVariable: name into: buffer size: aSize + 1.
	lastErrCode := OSPlatform current lastError.
	
	"From MSDN: If the function fails, the return value is zero. If the specified environment variable was not found in the environment block, GetLastError returns ERROR_ENVVAR_NOT_FOUND."
	return = 0 ifTrue: [ 
		lastErrCode = 0 ifTrue: [ ^ String new ].
		lastErrCode = "ERROR_ENVVAR_NOT_FOUND" 16r000000CB ifTrue: [ ^ aBlock value ].
		
		isRetry
			ifTrue: [ 
				self error: 'Error ', lastErrCode printString, 
					' occurred while fetching environment variable ', aVariableName asString ]
			ifFalse: [ ^ self doGetEnvVariable: aVariableName bufferSize: aSize ifAbsent: aBlock isRetry: true ] ].
	
	"From MSDN: If lpBuffer is not large enough to hold the data, the return value is the buffer size, in characters,
	required to hold the string and its terminating null character and the contents of lpBuffer are undefined."
	return > aSize ifTrue: [ ^ self doGetEnvVariable: aVariableName bufferSize: return ifAbsent: aBlock isRetry: false ].
	
	^ buffer asString! !

!Win32Environment methodsFor: 'private' stamp: ''!
setEnvironmentVariable: nameString value: valueString

	 ^ self ffiCall: #( int SetEnvironmentVariableW ( Win32WideString nameString, Win32WideString valueString ) )! !

!Win32Environment methodsFor: 'accessing' stamp: ''!
at: aKey put: aValue
	"The primitive on Windows currently uses the ascii version of the Windows API.
	In such chase try to set the value of the environment variable using FFI."

	| w32Key w32Value return |
	w32Key := aKey asWin32WideString.
	w32Value := aValue asWin32WideString.
	return := self setEnvironmentVariable: w32Key value: w32Value.	

	"From MSDN: If the function fails, the return value is zero."
	return = 0 ifTrue: [ 
		self error: 'An error occurred while setting environment variable ', aKey asString, ' to ', aValue asString ].! !

!Win32Environment methodsFor: 'private' stamp: ''!
setEnv: nameString value: valueString
	"This method calls the the platform specific set environment routine"

	^ self
		ffiCall: #(int SetEnvironmentVariableA #(String nameString , String valueString))
		module: #Kernel32! !

!Win32Environment methodsFor: 'private' stamp: ''!
ffiLibraryName

	^ #Kernel32! !

!Win32Environment methodsFor: 'accessing' stamp: ''!
removeKey: aKey
	"The primitive on Windows currently uses the ascii version of the Windows API.
	In such chase try to get value of the environment variable using FFI."

	| return |
	return := self removeEnvironmentVariable: aKey asWin32WideString.

	"From MSDN: If the function fails, the return value is zero."
	return = 0 ifTrue: [ 
		self error: 'An error occurred while removing environment variable ', aKey asString ].! !

!Win32Environment methodsFor: 'enumeration' stamp: ''!
keysAndValuesDo: aBlock
	"Under windows the environemtn variables are a single big String."

	"Lines starting with an equal sign are invalid per    
	  http://stackoverflow.com/questions/10431689/what-are-these-strange-environment-variables"
	| environmentStrings nextString |

	environmentStrings := self environmentStrings.
	[ 
	nextString := environmentStrings fromCString.
	nextString ifEmpty: [ ^ self ].
	nextString first = $=
		ifFalse: [ self keysAndValuesDo: aBlock withAssociationString: nextString ].
	environmentStrings := environmentStrings + nextString size + 1 ] repeat! !

!Win32Environment methodsFor: 'accessing' stamp: ''!
at: aKey ifAbsent: aBlock
	"The primitive on Windows currently uses the ascii version of the Windows API.
	In such chase try to get value of the environment variable using FFI."

	^ self getEnvVariable: aKey bufferSize: 500 ifAbsent: aBlock! !

!Win32Environment methodsFor: 'private' stamp: ''!
removeEnvironmentVariable: nameString

	 ^ self ffiCall: #( int SetEnvironmentVariableW ( Win32WideString nameString, 0 ) )! !

!Win32Environment methodsFor: 'private' stamp: ''!
environmentStrings
	 ^ self ffiCall: #( void * GetEnvironmentStrings () )! !

!Win32Environment methodsFor: 'private' stamp: ''!
getEnvVariable: aVariableName bufferSize: aSize ifAbsent: aBlock

	^ self doGetEnvVariable: aVariableName bufferSize: aSize ifAbsent: aBlock isRetry: false
! !

!Win32Environment class methodsFor: 'testing' stamp: ''!
isDefaultFor: aPlatform 
	^ aPlatform isWindows! !

!Win32EnvironmentTest methodsFor: 'tests' stamp: ''!
testExistingEnvironmentVariableShouldReturnValue

	| value |
	
	OSPlatform current isWindows 
		ifFalse: [ ^self skip ].

	OSEnvironment current at: 'ExistingNonEmpty' put: 'IamAValue'.
		
	value := OSEnvironment current at: 'ExistingNonEmpty'.
	
	self assert: value equals: 'IamAValue'! !

!Win32EnvironmentTest methodsFor: 'tests' stamp: ''!
testExistingEnvironmentVariableLongerThanBufferShouldReturnValue

	| value aExpectedValue |
	
	OSPlatform current isWindows 
		ifFalse: [ ^self skip ].

	aExpectedValue := String loremIpsum: 1500.

	OSEnvironment current at: 'ExistingNonEmpty' put: aExpectedValue.
		
	value := OSEnvironment current at: 'ExistingNonEmpty'.
	
	self assert: value equals: aExpectedValue! !

!Win32EnvironmentTest methodsFor: 'tests' stamp: ''!
testNonExistingEnvironmentVariableShouldGenerateException

	OSPlatform current isWindows 
		ifFalse: [ ^self skip ].
		
	self should: [ OSEnvironment current at: 'NonExistingVariable' ] raise: NotFound.! !

!Win32Platform commentStamp: ''!
I am a an object representing a Windows platform (32bits). 
Use myself to access platform specific features.

Please keep me polymorphic to the the other platform objects.

To get the current platform, you can evaluate:

OSPlatform current.!
!Win32Platform methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor

	^ aVisitor visitWindows32: self! !

!Win32Platform methodsFor: '*System-CommandLine' stamp: ''!
newTerminfo
	"Windows does not support the termCap"
	^ NullTermInfo new! !

!Win32Platform methodsFor: 'testing' stamp: 'nil'!
isWin32
	^ true! !

!Win32Platform class methodsFor: 'testing' stamp: 'nil'!
isActivePlatform
	"Answer whether the receiver is the active platform"
	^ Smalltalk vm operatingSystemName = 'Win32' and: [ 
		  Smalltalk vm is32bit ]! !

!Win32WideString commentStamp: ''!
I represent a Win32 wide string, supporting non-ascii characters.
I manage the conversion between Pharo strings and Windows strings.

(Win32String fromString: 'âùö') asString = 'âùö'

!! Implementation Details

I'm on purpose a subclass of ExternalObject and not FFIExternalObject.
The rationale is that the kernel should not be tied to UFFI (which depends on the compiler) to do simple ffi calls. Because of this I implement on #handle, #handle: and #asExternalTypeOn: to be compatible with UFFI external structures.!
!Win32WideString methodsFor: 'accessing' stamp: 'nil'!
size
	| size pos |
	size := 0.
	pos := 1.

	[ (handle unsignedByteAt: pos) = 0 and: [ (handle unsignedByteAt: pos + 1) = 0 ] ]
		whileFalse: [ size := size + 1.
			pos := pos + 2 ].

	^ size! !

!Win32WideString methodsFor: 'converting' stamp: 'nil'!
asString
	| out r codepage |

	(handle isNil or: [ handle isNull ])
		ifTrue: [ ^ '' ].
	
	codepage := 65001.

	r := OSPlatform current
		wideCharacterToMultiByteCodepage: codepage
		flags: 0
		input: self
		inputLen: self size + 1
		output: ExternalAddress null
		outputLen: 0.

	r = 0 ifTrue: [ self error: 'Error while transforming windows wide string using codepage ', codepage asString ].

	out := ByteArray new: r.
	out pinInMemory.

	r := OSPlatform current
		wideCharacterToMultiByteCodepage: codepage
		flags: 0
		input: self
		inputLen: self size + 1
		output: out
		outputLen: out size.
		
	r = 0 ifTrue: [ self error: 'Error while transforming windows wide string using codepage ', codepage asString ].

	^ out allButLast utf8Decoded! !

!Win32WideString methodsFor: 'converting' stamp: 'nil'!
asWin32WideString
	^ self.! !

!Win32WideString methodsFor: 'accessing' stamp: 'nil'!
byteSize
	^ handle isExternalAddress
		ifTrue: [ (self size + 1) * 2 ]
		ifFalse: [ handle size ]! !

!Win32WideString methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	aStream 
		nextPutAll: 'a ' ;
		nextPutAll: self class name;
		nextPut: $(;
		print: self asString;
		nextPut: $)! !

!Win32WideString class methodsFor: 'instance creation' stamp: 'nil'!
fromString: aString
	| requestedSize r wideString anUTF8String codepage |

	anUTF8String := aString utf8Encoded copyWith: 0.
	codepage := 65001.

	requestedSize := OSPlatform current
		multiByteToWideCharacterCodepage: codepage
		flags: 0
		input: anUTF8String
		inputLen: anUTF8String size + 1
		output: self null
		outputLen: 0.

	requestedSize = 0 
		ifTrue: [ self error: 'Error while transforming utf8 string ', 
				aString, ' using codepage ', codepage asString  ].

	wideString := self new: requestedSize.

	r := OSPlatform current
		multiByteToWideCharacterCodepage: codepage
		flags: 0
		input: anUTF8String
		inputLen: anUTF8String size + 1
		output: wideString
		outputLen: wideString byteSize.


	r = 0 ifTrue: [ self error: 'Error while transforming utf8 string ', aString, ' using codepage ', codepage asString  ].
	
	^ wideString! !

!Win32WideString class methodsFor: '*System-OSEnvironments' stamp: ''!
asExternalTypeOn: generator
	^ FFIExternalObjectType objectClass: self! !

!Win32WideString class methodsFor: 'instance creation' stamp: 'nil'!
new: size
	^ self new
		setHandle: (ByteArray new: (size + 1) * 2);
		yourself.
! !

!Win32WideString class methodsFor: 'instance creation' stamp: 'nil'!
fromByteArray: byteArray
	^ self fromHandle: byteArray! !

!Win32WideString class methodsFor: 'instance creation' stamp: 'nil'!
fromHandle: handle
	^ self new
		setHandle: handle;
		yourself! !

!Win32WideStringTest methodsFor: 'tests' stamp: ''!
testUnderlayingByteArrayIsMultipleOf2

	self isWindows 
		ifFalse: [ ^self skip ].

	self assert: (self exampleString asWin32WideString getHandle size) % 2 equals: 0! !

!Win32WideStringTest methodsFor: 'testing' stamp: ''!
isWindows

	^ OSPlatform current isWindows ! !

!Win32WideStringTest methodsFor: 'tests' stamp: ''!
testUnderlayingByteArrayEndsInTwoZeros

	self isWindows 
		ifFalse: [ ^self skip ].

	self assert: (self exampleString asWin32WideString getHandle last:2) equals: #[00 00]! !

!Win32WideStringTest methodsFor: 'tests' stamp: ''!
testCharactersAreEncodedInUnicode16Bits

	| bytes index |
	
	self isWindows 
		ifFalse: [ ^self skip ].
	
	bytes := self exampleString asWin32WideString getHandle.
	index := 1.
	
	self exampleString do: [ :aCharacter |  
		self assert: (bytes at: index) equals: (aCharacter codePoint bitAnd: 255).
		self assert: (bytes at: index+1) equals: (aCharacter codePoint >> 8).		
		index := index + 2.
	]! !

!Win32WideStringTest methodsFor: 'tests' stamp: ''!
testHandleIsAByteArray

	self isWindows 
		ifFalse: [ ^self skip ].

	self assert: (self exampleString asWin32WideString getHandle isKindOf: ByteArray)! !

!Win32WideStringTest methodsFor: 'tests' stamp: ''!
testConvertingInBothDirectionsGaveSameString

	self isWindows 
		ifFalse: [ ^self skip ].

	self assert: self exampleString asWin32WideString asString equals: self exampleString! !

!Win32WideStringTest methodsFor: 'tests' stamp: ''!
exampleString

	^ 'áéíóúñÑâîôûêèàìòù©¢ßðöäå®þü¼¡²³¤€¼½¾‘’¥'! !

!Win64Platform commentStamp: ''!
I am a an object representing a Windows platform (64bits). 
Use myself to access platform specific features.

Please keep me polymorphic to the the other platform objects.

To get the current platform, you can evaluate:

OSPlatform current.!
!Win64Platform methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor

	^ aVisitor visitWindows64: self! !

!Win64Platform methodsFor: 'testing' stamp: 'nil'!
isWin64
	^ true! !

!Win64Platform class methodsFor: 'testing' stamp: 'nil'!
isActivePlatform
	"Answer whether the receiver is the active platform"
	^ Smalltalk vm operatingSystemName = 'Win32' and: [ 
		  Smalltalk vm is64bit ]! !

!WinPlatform commentStamp: ''!
I am a an object representing a Windows platform. Use myself to access platform specific features.

Please keep me polymorphic to the the other platform objects.

To get the current platform, you can evaluate:

OSPlatform current.!
!WinPlatform methodsFor: 'environment-variables' stamp: 'nil'!
getEnvironmentVariable: lpName into: lpBuffer size: nSize
	"Primitive to obtain an environment variable using windows Wide Strings"
	^ self ffiCall: #(ulong GetEnvironmentVariableW (Win32WideString lpName, Win32WideString  lpBuffer, ulong nSize))! !

!WinPlatform methodsFor: '*System-Sources' stamp: ''!
potentialLocationsOfSourcesFile
	^ {(Smalltalk vm directory)}! !

!WinPlatform methodsFor: 'accessing' stamp: 'nil'!
defaultMaximumPathLength
		"This method returns the default maximum path length for the getCurrentWorkingDirectory implementation. Windows default PATH_MAX is 260.  PATH_MAX is needed to avoid buffer overflow.  In case PATH_MAX is not sufficient the method currentWorkingDirectoryWithBufferSize: can be used to give desired buffer size. The path can include unicode characters, so it can be longer than 260, doubling it should be enough"
		
	 ^ 260 * 2 
! !

!WinPlatform methodsFor: 'accessing' stamp: 'nil'!
lastError

	^ self ffiCall: #(ulong GetLastError())! !

!WinPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiLongAlignment
	"In Windows, sizeof(long) == 4 always."
	^ 4! !

!WinPlatform methodsFor: 'string-manipulation' stamp: 'nil'!
multiByteToWideCharacterCodepage: codepage flags: flags input: input inputLen: inputLen output: output outputLen: outputLen

	^self ffiCall: #(int MultiByteToWideChar(uint codepage, ulong flags, void* input, int inputLen, Win32WideString output, int outputLen ))! !

!WinPlatform methodsFor: 'accessing' stamp: 'nil'!
menuShortcutString
	^ 'ctrl'! !

!WinPlatform methodsFor: 'environment-variables' stamp: 'nil'!
setEnvironmentVariable: nameString value: valueString

	 ^ self ffiCall: #( int SetEnvironmentVariableW ( Win32WideString nameString, Win32WideString valueString ) )! !

!WinPlatform methodsFor: 'testing' stamp: 'nil'!
isWindows
	^ true! !

!WinPlatform methodsFor: 'accessing' stamp: 'nil'!
virtualKey: virtualKeyCode
	"Win32Platform virtualKey: $C charCode"

	(virtualKeyCode between: 65 "$A charCode" and: 90 "$Z")
		ifFalse: [^nil].
	"#($a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z)"
	
	^(#($a nil $c $d nil $f $g nil nil nil nil $l $m $n nil $p nil nil $s nil nil $v nil $x nil $z)
		at: virtualKeyCode-64) ifNotNil: [:char | char charCode]! !

!WinPlatform methodsFor: '*Spec2-Core' stamp: ''!
configureApplication: anApplication configuration: aConfiguration
	
	aConfiguration configureWindows: anApplication! !

!WinPlatform methodsFor: 'library path' stamp: 'nil'!
ffiLibraryName

	^ #Kernel32! !

!WinPlatform methodsFor: 'accessing' stamp: 'nil'!
family
	^#Windows! !

!WinPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiCallingConvention
	^ #stdcall! !

!WinPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiLibraryName: aLibrary 
	^ aLibrary win32LibraryName! !

!WinPlatform methodsFor: 'accessing' stamp: 'nil'!
keyForValue: aKeyValue
	^KeyboardKey valueForWindowsPlatform: aKeyValue.! !

!WinPlatform methodsFor: '*OSWindow-SDL2' stamp: ''!
sdlPlatform

	^ SDLWindowsPlatform new! !

!WinPlatform methodsFor: 'string-manipulation' stamp: 'nil'!
wideCharacterToMultiByteCodepage: codepage flags: flags input: input inputLen: inputLen output: output outputLen: outputLen

	^self ffiCall: #(int WideCharToMultiByte(uint codepage, ulong flags, Win32WideString input, int inputLen, void* output, int outputLen, int 0, int 0))! !

!WinPlatform methodsFor: '*Keymapping-KeyCombinations' stamp: ''!
defaultModifier

	^ KMModifier control! !

!WinPlatform methodsFor: 'accessing' stamp: 'nil'!
setLastError: aValue

	^ self ffiCall: #(void SetLastError(ulong aValue))! !

!WinPlatform methodsFor: '*UnifiedFFI' stamp: ''!
ffiFloat64Alignment
	"Windows structure double alignment is 8. 
	 Check here: https://msdn.microsoft.com/en-us/library/aa290049(v=vs.71).aspx"
	^ 8! !

!WinPlatform methodsFor: 'accessing' stamp: 'nil'!
lineEnding

	^ String crlf! !

!WinPlatform methodsFor: 'visiting' stamp: 'nil'!
accept: aVisitor

	^ aVisitor visitWindows: self! !

!WindowActivated commentStamp: ''!
Emitted when navigating between windows. !
!WindowActivated methodsFor: 'testing' stamp: ''!
isActivated

	^true! !

!WindowAnnouncement commentStamp: ''!
I am the base class for all WindowAnnouncements

I define the common interface for WindowAnnouncements. 
You can check the type of the announcement (isMoved/isScrolled ...)
My subclasses implement the specific window announcements and may provide further states.
!
!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isMovedOrResized

	^ self isMoved or: [ self isResized ]! !

!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isScrolled
	^ false! !

!WindowAnnouncement methodsFor: 'accessing' stamp: ''!
window
	^ window! !

!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isClosed
	^ false! !

!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isCollapsed
	^ false! !

!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isActivated

	^false! !

!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isMoved
	^ false! !

!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isResized
	^ false! !

!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isDeActivated

	^false! !

!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isExpanded
	^ false! !

!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isLabelled
	^ false! !

!WindowAnnouncement methodsFor: 'testing' stamp: ''!
isOpened
	^ false! !

!WindowAnnouncement methodsFor: 'accessing' stamp: ''!
window: anObject
	window := anObject! !

!WindowAnnouncementTest methodsFor: 'tests - window creation and deletion' stamp: ''!
testWindowCreationAndDeletion
	| t newWindowCreated |
	t := 0.
	self currentWorld announcer
		when: WindowOpened
		do: [ :ann | 
			t := t + 1.
			newWindowCreated := ann window ].
	self currentWorld announcer
		when: WindowClosed
		do: [ :ann | 
			t := t + 10.
			newWindowCreated := ann window ].
	window := SystemWindow labelled: 'foo'.
	window openInWorld.

	self assert: t equals: 1.
	self assert: window identicalTo: newWindowCreated.
	window delete.

	self assert: t equals: 11.
	self assert: window identicalTo: newWindowCreated! !

!WindowAnnouncementTest methodsFor: 'running' stamp: ''!
tearDown 
	window ifNotNil: [ window delete ].
	super tearDown.! !

!WindowAnnouncementTest methodsFor: 'tests - window change' stamp: ''!
testCollapsing
	| t |
	window := SystemWindow labelled: 'foo'.
	t := 0.
	window openInWorld.
	window announcer when: WindowCollapsed do: [ :ann | t := t + 1 ].
	self assert: t equals: 0.
	window collapse.
	self assert: t equals: 1! !

!WindowAnnouncementTest methodsFor: 'tests - window change' stamp: ''!
testScrolling
	"This test tests the scrolling values of a scrollpane. We create a reeeeeally big (enormous) morph, to be sure its size is bigger than the screen and therefore its enclosing window has scrollbars.
	When screen sizes become bigger, you should increase the value, or fix morphic, what happens first :).
	"

	| myMorph pane t |
	window := SystemWindow labelled: 'foo'.
	window extent: 300 @ 200.
	myMorph := Morph new.
	myMorph extent: 10000000000 @ 1000000000.
	pane := ScrollPane new.
	pane scroller addMorph: myMorph.
	window addMorph: pane fullFrame: LayoutFrame identity.
	t := 0 @ 0.
	window openInWorld.
	window announcer when: WindowScrolling do: [ :ann | t := t + ann step ].
	pane hScrollBarValue: 10.
	pane vScrollBarValue: 5.

	window delete.

	self assert: t equals: 10 @ 5.
	window := nil! !

!WindowAnnouncementTest methodsFor: 'tests - window change' stamp: ''!
testMoving
	| t oldBounds event |
	window := SystemWindow labelled: 'foo'.
	t := 0.
	event := nil.

	window openInWorld.
	oldBounds := window bounds.
	window announcer
		when: WindowMoved
		do: [ :ann | 
			t := t + 1.
			event := ann ].

	self assert: t equals: 0.
	self assert: event isNil.

	"We move the window"
	window position: 50 @ 50.
	self assert: t equals: 1.
	self assert: event oldPosition equals: oldBounds origin.
	self assert: event newPosition equals: 50 @ 50.

	"We call position: without moving it actually, nothing should happen"
	window position: 50 @ 50.
	self assert: t equals: 1.

	"If we simply resize the window, nothing should happen as well"
	window extent: 50 @ 60.
	self assert: t equals: 1! !

!WindowAnnouncementTest methodsFor: 'tests - window creation and deletion' stamp: ''!
testWindowCreation
	| t oldBounds newBounds |
	t := 0.
	self currentWorld announcer when: WindowResizing do: [ :ann | t := t + 1 ].
	window := SystemWindow labelled: 'foo'.
	window setProperty: #minimumExtent toValue: 1 @ 1.
	window openInWorld.
	oldBounds := window bounds.
	window announcer when: WindowResizing do: [ :ann | t := t + 1 ].
	self assert: t equals: 0.
	window extent: 50 @ 60.
	newBounds := window bounds.
	self assert: t equals: 1! !

!WindowAnnouncementTest methodsFor: 'tests - window change' stamp: ''!
testResizing
	| t oldBounds newBounds |
	window := SystemWindow labelled: 'foo'.
	window setProperty: #minimumExtent toValue: 1 @ 1.
	t := 0.
	window openInWorld.
	oldBounds := window bounds.
	window announcer when: WindowResizing do: [ :ann | t := t + 1 ].
	self assert: t equals: 0.
	window extent: 50 @ 60.
	newBounds := window bounds.
	self assert: t equals: 1! !

!WindowAnnouncementTest methodsFor: 'tests - window creation and deletion' stamp: ''!
testResizingClosing
	| coll |
	window := SystemWindow labelled: 'foo'.
	coll := OrderedCollection new.
	window openInWorld.
	window announcer when: WindowAnnouncement do: [ :ann | coll add: ann ].
	self assertEmpty: coll.
	window minimizeOrRestore.

	"Resizing, moving, deActivation, collapsing "
	self assert: coll size equals: 4.
	self assert: coll first isResized.
	self assert: coll second isMoved.
	self assert: coll third isDeActivated.
	self assert: coll fourth isCollapsed.

	window delete.

	self assert: coll size equals: 5.
	self assert: coll fifth isClosed.
	window := nil! !

!WindowAnnouncementTest methodsFor: 'tests - window creation and deletion' stamp: ''!
testWindowLabelling
	"Test change of label for a window."

	| labels win |
	labels := #().
	self currentWorld announcer
		when: WindowLabelled
		do: [ :ann | 
			win := ann window.
			labels := labels copyWith: ann label ].
	window := SystemWindow labelled: 'foo'.
	window openInWorld.
	self assert: win equals: window.
	self assert: labels equals: #('foo').
	window setLabel: 'bar'.
	self assert: win equals: window.
	self assert: labels equals: #('foo' 'bar')! !

!WindowClosed commentStamp: ''!
I am emitted when a window is closed.!
!WindowClosed methodsFor: 'testing' stamp: ''!
isClosed
	^ true! !

!WindowCollapsed commentStamp: ''!
This announcement is emitted when a window is collapsed, by pressing the '-' top left button of a window.!
!WindowCollapsed methodsFor: 'testing' stamp: ''!
isCollapsed
	^ true! !

!WindowDeActivated commentStamp: ''!
This announcement is emitted when the top window switches from "this" window to another. 
The new window will announce WindowActivated, while the old will announce this annoucnement.!
!WindowDeActivated methodsFor: 'testing' stamp: ''!
isDeActivated

	^true! !

!WindowEdgeGripMorph commentStamp: ''!
Window edge gripper allowing resizing of a window by a particular side.!
!WindowEdgeGripMorph methodsFor: 'event handling' stamp: ''!
mouseDown: anEvent
	"Activate the window if not currently so."
	
	(self bounds containsPoint: anEvent cursorPoint)
		ifTrue: [self window ifNotNil: [:w | w activate]].
	^super mouseDown: anEvent! !

!WindowEdgeGripMorph methodsFor: 'style' stamp: ''!
pressedFillStyle
	"Return the pressed fillStyle of the receiver."
	
	^self theme windowEdgePressedFillStyleFor: self! !

!WindowEdgeGripMorph methodsFor: 'event handling' stamp: ''!
mouseMove: anEvent
	"Track the mouse for resizing."
	
	target ifNil: [^self].
	self theme settings fastDragging
		ifTrue: [target doFastWindowReframe: self edgeName] 
		ifFalse: [super mouseMove: anEvent]! !

!WindowEdgeGripMorph methodsFor: 'style' stamp: ''!
normalFillStyle
	"Return the normal fillStyle of the receiver."
	
	^self theme windowEdgeNormalFillStyleFor: self! !

!WindowEvent commentStamp: ''!
I'm an event related to the host window, only dispatched to the World. !
!WindowEvent methodsFor: 'accessing' stamp: ''!
action: aValue
	action := aValue.! !

!WindowEvent methodsFor: 'dispatching' stamp: ''!
sentTo:anObject
	"Dispatch the receiver into anObject"
	^anObject handleWindowEvent: self.! !

!WindowEvent methodsFor: 'accessing' stamp: ''!
rectangle: aValue
	rectangle := aValue.! !

!WindowEvent methodsFor: 'accessing' stamp: ''!
action
	^action! !

!WindowEvent methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPut: $[.
	aStream nextPutAll: self type; space.
	aStream nextPut: $(; print: self rectangle; nextPut: $).
	aStream nextPut: $].! !

!WindowEvent methodsFor: 'accessing' stamp: ''!
rectangle
	^rectangle! !

!WindowEvent methodsFor: 'testing' stamp: ''!
isWindowEvent
	^true! !

!WindowEvent methodsFor: 'accessing' stamp: ''!
type
	"This should match the definitions in sq.h"
	^#(
		windowMetricChange
		windowClose
		windowIconise
		windowActivated
		windowPaint
	) at: action ifAbsent: [#windowEventUnknown]! !

!WindowExpanded commentStamp: ''!
This announcement is emitted when a window leaves a collapsed mode. This happens when you press on a window icon in the taskbar.!
!WindowExpanded methodsFor: 'testing' stamp: ''!
isExpanded
	^ true! !

!WindowLabelled commentStamp: ''!
I am emitted when a window title changed. You can ask me for the window
and the changed label (no old/new label data is provided, just the actual one).

This is usefull for window manager or window grouper that provide an overview
for the active windows. Or like the window grouper, that creates tab panes and labels
the tabs with the current window title.!
!WindowLabelled methodsFor: 'accessing' stamp: ''!
label: anObject

	label := anObject! !

!WindowLabelled methodsFor: 'testing' stamp: ''!
isLabelled

	^true! !

!WindowLabelled methodsFor: 'accessing' stamp: ''!
label

	^ label! !

!WindowMoved commentStamp: ''!
I am emitted when a window is moved.
I provide the old and new window position. 
A window position changes even when the topleft corner changed by a window resize operation 
or the windows collapses.!
!WindowMoved methodsFor: 'accessing' stamp: ''!
newPosition: anObject
	newPosition := anObject! !

!WindowMoved methodsFor: 'accessing' stamp: ''!
oldPosition: anObject
	oldPosition := anObject! !

!WindowMoved methodsFor: 'testing' stamp: ''!
isMoved
	^ true! !

!WindowMoved methodsFor: 'accessing' stamp: ''!
newPosition
	^ newPosition! !

!WindowMoved methodsFor: 'accessing' stamp: ''!
oldPosition
	^ oldPosition! !

!WindowOpened commentStamp: ''!
I am emitted when a window opened.
!
!WindowOpened methodsFor: 'testing' stamp: ''!
isOpened

	^ true! !

!WindowPresenter commentStamp: ''!
A WindowPresenter is a spec presenter for a Window!
!WindowPresenter methodsFor: 'private' stamp: ''!
defaultInitialExtent
	
	^ 400@300! !

!WindowPresenter methodsFor: 'api' stamp: ''!
askOkToClose

	^ self model askOkToClose! !

!WindowPresenter methodsFor: 'api' stamp: ''!
isDisplayed

	^ self window ifNil: [ false ] ifNotNil: [ :theWindow | theWindow isDisplayed ]! !

!WindowPresenter methodsFor: 'private' stamp: ''!
addModelIn: widget withSpec: aSpec

	self model ifNil: [ ^ self ].
	
	self changed: #addModelIn:withSpec: with: { widget . aSpec }! !

!WindowPresenter methodsFor: 'testing' stamp: ''!
isClosed
	^ isClosedHolder value! !

!WindowPresenter methodsFor: 'api' stamp: ''!
minimize

	self changed: #minimize with: #()! !

!WindowPresenter methodsFor: 'menu' stamp: ''!
addModelItemsToWindowMenu: aMenu

	self model addModelItemsToWindowMenu: aMenu! !

!WindowPresenter methodsFor: 'private' stamp: ''!
openWithSpecLayout: aSpec

	window value: (self buildWithSpecLayout: aSpec).
	self changed: #open with: #().
	self updateTitle.! !

!WindowPresenter methodsFor: 'api' stamp: ''!
triggerCancelAction
	"do nothing (ensure polymorphism with DialogWindow)"! !

!WindowPresenter methodsFor: 'menu' stamp: ''!
addMenuItemsToWindowMenu: aMenu

	self model addMenuItemsToWindowMenu: aMenu! !

!WindowPresenter methodsFor: 'focus' stamp: ''!
giveFocusToNextFrom: aModel 

	^ self model giveFocusToNextFrom: aModel! !

!WindowPresenter methodsFor: 'api' stamp: ''!
isResizeable: aBoolean

	isResizeable value: aBoolean! !

!WindowPresenter methodsFor: 'api - events' stamp: ''!
whenClosedDo: aBlock

	isClosedHolder whenChangedDo: [:value |
		value ifTrue: [ aBlock value ] ]! !

!WindowPresenter methodsFor: 'private' stamp: ''!
okToChange

	^ self model okToChange! !

!WindowPresenter methodsFor: 'api' stamp: ''!
close

	self changed: #close with: #()! !

!WindowPresenter methodsFor: 'private' stamp: ''!
rebuildWithSpec: aSpec

	self changed: #rebuildWithSpec: with: { aSpec }.! !

!WindowPresenter methodsFor: 'api' stamp: ''!
triggerOkAction
	"do nothing (ensure polymorphism with DialogWindow)"! !

!WindowPresenter methodsFor: 'accessing' stamp: ''!
model
	
	^ model value! !

!WindowPresenter methodsFor: 'api' stamp: ''!
taskbarIcon

	^ model value 
		ifNil: [ super taskbarIcon ]
		ifNotNil: [ :m |
			m windowIcon
				ifNil: [ m taskbarIcon ] ]! !

!WindowPresenter methodsFor: 'private' stamp: ''!
title

	^ self model
		ifNil: [ super title ]
		ifNotNil: [:m | m title ]! !

!WindowPresenter methodsFor: 'private' stamp: ''!
addModelIn: widget withSpecLayout: aSpec

	self model ifNil: [ ^ self ].
	
	self changed: #addModelIn:withSpecLayout: with: { widget . aSpec }! !

!WindowPresenter methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.

	model := nil asValueHolder.
	initialExtent := nil asValueHolder.
	title := self class title asValueHolder.
	isClosedHolder := false asValueHolder.
	isResizeable := true asValueHolder.
	
	model whenChangedDo: [:m | self updateTitle ].! !

!WindowPresenter methodsFor: 'api' stamp: ''!
initialExtent

	^ initialExtent value
		ifNil: [ self model 
			ifNil: [ self defaultInitialExtent ]
			ifNotNil: [:m | m extent
				ifNil: [ m initialExtent
					ifNil: [ self defaultInitialExtent ] ] ] ]! !

!WindowPresenter methodsFor: 'private' stamp: ''!
title: aString

	self changed: #title: with: { aString }! !

!WindowPresenter methodsFor: 'updating' stamp: ''!
windowIsClosing

	isClosedHolder value: true.
	
	self model windowIsClosing ! !

!WindowPresenter methodsFor: 'api' stamp: ''!
isResizeable

	^ isResizeable value! !

!WindowPresenter methodsFor: 'private' stamp: ''!
updateTitle
	"Update the window title"

	self title: self title! !

!WindowPresenter methodsFor: 'api' stamp: ''!
centered

	self changed: #centered with: #()! !

!WindowPresenter methodsFor: 'focus' stamp: ''!
giveFocusToPreviousFrom: aModel 

	^ self model giveFocusToPreviousFrom: aModel ! !

!WindowPresenter methodsFor: 'api' stamp: ''!
model: aModel

	model value: aModel! !

!WindowPresenter methodsFor: 'api' stamp: ''!
cancelled

	^ false! !

!WindowPresenter methodsFor: 'api' stamp: ''!
aboutText
	"if my aboutText has not been set the fallback is:
	  - if I do have a model, use its' about text
	  - else use the behavior defined in super
	"

	^aboutText value
		ifNil: [self model
			ifNil: [ super aboutText ]
			ifNotNil: [:m | m aboutText ]]
		ifNotNil: [ aboutText value ]! !

!WindowPresenter methodsFor: 'private' stamp: ''!
buildWithSpecLayout: aSpec
	"Build the widget using the spec name provided as argument"
	| adapter widget |
	
	(self spec notNil and: [ self needRebuild not ])
		ifTrue: [ widget := self spec instance ]
		ifFalse: [
			adapter := self privateAdapterFromModel: self withSpec: self defaultSpecSelector.
			widget := adapter widget.
			self addModelIn: widget withSpecLayout: aSpec ].

	self ensureExtentFor: widget.
	
	^ widget! !

!WindowPresenter methodsFor: 'api' stamp: ''!
centeredRelativeTo: aModel

	self changed: #centeredRelativeTo: with: { aModel }! !

!WindowPresenter methodsFor: 'api' stamp: ''!
aboutTitle
	"Answer the title of my About window"

	(self model respondsTo: #aboutTitle)
		ifTrue: [^self model aboutTitle].
	^(self model respondsTo: #toolName)
		ifTrue: [self model toolName]
		ifFalse: [self model class name].
! !

!WindowPresenter methodsFor: 'api' stamp: ''!
modalRelativeTo: aWindow

	self changed: #modalRelativeTo: with: { aWindow }! !

!WindowPresenter methodsFor: 'api' stamp: ''!
openModal: aWindow 

	self changed: #openModal: with: { aWindow }! !

!WindowPresenter methodsFor: 'private' stamp: ''!
rebuildWithSpecLayout: aSpec

	self changed: #rebuildWithSpecLayout: with: { aSpec }! !

!WindowPresenter methodsFor: 'api' stamp: ''!
maximize

	self changed: #maximize with: #()! !

!WindowPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	^ #(WindowAdapter
		adapt: #(model))! !

!WindowPresenter class methodsFor: 'specs' stamp: ''!
adapterName

	^ #WindowAdapter! !

!WindowResizing commentStamp: ''!
I am emitted when a window is resized.
Collapsing and expanding a window changes the size and therefore it may 
trigger this announcement.

I provide the old and new window size.!
!WindowResizing methodsFor: 'accessing' stamp: ''!
newSize
	^ newSize! !

!WindowResizing methodsFor: 'testing' stamp: ''!
isResized
	^ true! !

!WindowResizing methodsFor: 'accessing' stamp: ''!
oldSize: anObject
	oldSize := anObject! !

!WindowResizing methodsFor: 'accessing' stamp: ''!
newSize: anObject
	newSize := anObject! !

!WindowResizing methodsFor: 'accessing' stamp: ''!
oldSize
	^ oldSize! !

!WindowScrolling commentStamp: ''!
I am emitted when a window content pane is scrolled.
I provide the scroll step value.!
!WindowScrolling methodsFor: 'testing' stamp: ''!
isScrolled
	^ true! !

!WindowScrolling methodsFor: 'accessing' stamp: ''!
step
	^ step! !

!WindowScrolling methodsFor: 'accessing' stamp: ''!
step: anObject
	step := anObject! !

!WindowsDynamicLoader commentStamp: ''!
I'm a windows platform dynamic library loader.!
!WindowsDynamicLoader methodsFor: 'misc' stamp: ''!
lastError
	^ self ffiCall: #(int32 GetLastError(void))! !

!WindowsDynamicLoader methodsFor: 'misc' stamp: ''!
loadSymbolFrom: hModule name: lpProcName
	^ self ffiCall: #(void *GetProcAddress(void *hModule, String lpProcName))
! !

!WindowsDynamicLoader methodsFor: 'misc' stamp: ''!
loadLibrary: lpFileName
	^ self ffiCall: #(void *LoadLibrary(String lpFileName))! !

!WindowsDynamicLoader methodsFor: 'accessing - platform' stamp: ''!
win32LibraryName
	^ 'Kernel32.dll'! !

!WindowsDynamicLoader class methodsFor: 'testing' stamp: ''!
isAvailable
	^ Smalltalk os isWindows! !

!WindowsResolver commentStamp: ''!
I am an expert on Windows filesystem conventions. I resolve origins according to these conventions.!
!WindowsResolver methodsFor: 'origins' stamp: ''!
temp
	^ self directoryFromEnvVariableNamed: 'TEMP' or: [ FileLocator C / 'windows' / 'temp' ]! !

!WindowsResolver methodsFor: 'origins' stamp: ''!
cache
	"Because Windows does not define any location for putting cache files, we chose to use the preference directory. http://libertyboy.free.fr/computing/reference/envariables/"
	^ self preferences! !

!WindowsResolver methodsFor: 'origins' stamp: ''!
home
	"Value of the $USERPROFILE environment variable."

	^ self directoryFromEnvVariableNamed: 'USERPROFILE'! !

!WindowsResolver methodsFor: 'origins' stamp: ''!
preferences
	^ self directoryFromEnvVariableNamed: 'APPDATA' or: [ self home ]! !

!WindowsResolver class methodsFor: 'accessing' stamp: ''!
platformName
	^ 'Win32'! !

!WindowsStore commentStamp: ''!
I'm a specific store for Windows file systems!
!WindowsStore methodsFor: 'accessing' stamp: ''!
isExecutable: aPath
	"Answer a boolean indicating whether the supplied path is executable"

	aPath isRoot ifTrue: [ ^self rootEntry isExecutable ].
	^super isExecutable: aPath! !

!WindowsStore methodsFor: 'public' stamp: ''!
checkName: aFileName fixErrors: fixing
	"Check if the file name contains any invalid characters"
	
	| fName badChars |
	fName := super checkName: aFileName fixErrors: fixing.
	badChars := (#( $: $< $> $| $/ $\ $? $* $"), ((0 to: 31) collect: [:n | n asCharacter])) asSet.
	
	(fName includesAnyOf: badChars)
		ifFalse: [^ fName].
	
	fixing ifFalse: [^self error: 'filename contains invalid characters'].
	
	^ fName collect:
		[:char | (badChars includes: char) 
				ifTrue: [$#] 
				ifFalse: [char]]! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
modificationTimeOf: aPath
	"Answer the modification time of aPath."

	aPath isRoot ifTrue: [ ^self rootEntry modificationTime ].
	^super modificationTimeOf: aPath! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
isBlock: aPath
	"Answer a boolean indicating whether the supplied path is a Block file"

	aPath isRoot ifTrue: [ ^self rootEntry isBlock ].
	^super isBlock: aPath! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
gidOf: aPath
	"Return the gid of the file at aPath"

	aPath isRoot ifTrue: [ ^self rootEntry gid ].
	^super gidOf: aPath! !

!WindowsStore methodsFor: 'converting' stamp: ''!
currentDisk
	^ disk ifNil: [  disk := FileSystem workingDirectory path segments first ]! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
changeTimeOf: aPath
	"Answer the change time of aPath."

	aPath isRoot ifTrue: [ ^self rootEntry changeTime ].
	^super changeTimeOf: aPath! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
numberOfHardLinks: aPath
	"Return the number of hard links for the File described by aPath"

	aPath isRoot ifTrue: [ ^self rootEntry numberOfHardLinks ].
	^super numberOfHardLinks: aPath! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
inodeOf: aPath
	"Return the inode of the file at aPath"

	aPath isRoot ifTrue: [ ^self rootEntry inode ].
	^super inodeOf: aPath! !

!WindowsStore methodsFor: 'private' stamp: ''!
entryAt: aPath fileSystem: aFilesystem

	aPath isRoot ifTrue: [ ^aFilesystem store rootEntry ].
	^super entryAt: aPath fileSystem: aFilesystem! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
deviceIdOf: aPath
	"Return the device id of the file at aPath"

	aPath isRoot ifTrue: [ ^self rootEntry deviceId ].
	^super deviceIdOf: aPath! !

!WindowsStore methodsFor: 'converting' stamp: ''!
printPath: aPath on: aStream
	| hasDrive |

	aPath isNetworkPath
		ifTrue: [ ^ aPath printOn: aStream delimiter: self delimiter ].

	aPath isRoot
		ifTrue: [ ^ self ].	"effectively Windows root is empty string"

	aPath isWorkingDirectory
		ifTrue: [ ^ aPath printOn: aStream delimiter: self delimiter ].
	aPath isRelative
		ifTrue: [ ^ aPath printOn: aStream delimiter: self delimiter ].
	aPath segments first first = $:
		ifTrue: [ ^ aStream nextPut: self delimiter ].	"as tagged in #pathFromString:  "
	hasDrive := aPath segments first second = $:.
	(hasDrive not )
		ifTrue: [ aStream nextPut: self delimiter ].
	aPath printOn: aStream delimiter: self delimiter.
	(hasDrive and: [ aPath segments size = 1 ])
		ifTrue: [ aStream nextPut: self delimiter ]! !

!WindowsStore methodsFor: 'testing' stamp: ''!
isReadable: aPath
	"Answer a boolean indicating whether the supplied path is readable"

	aPath isRoot ifTrue: [ ^self rootEntry isReadable ].
	^super isReadable: aPath! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
uidOf: aPath
	"Return the uid of the File described by aPath"
	aPath isRoot ifTrue: [ ^self rootEntry uid ].
	^super uidOf: aPath.! !

!WindowsStore methodsFor: 'converting' stamp: ''!
pathFromString: aString
	"Need to distinguish '' and '/' , so tag latter with invalid character ':'  "
	| normalized pathClass pathElements |
	normalized := aString copy replaceAll: UnixStore delimiter with: self delimiter.
	pathElements := self delimiter split: normalized.
	
	
	pathClass := (normalized beginsWith: '\\')
		ifTrue: [ UNCNetworkPath ]
		ifFalse: [  
			(Path isAbsoluteWindowsPath: normalized)
				ifTrue: [ (normalized = self delimiter asString) ifTrue: [ pathElements := { ':' } ].
					AbsolutePath ]
				ifFalse: [ self stripDrive: pathElements.
					RelativePath ]].
			
	^pathClass withAll: pathElements! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
permissions: aPath
	"Answer the FileSystemPermissions for the supplied path"

	aPath isRoot ifTrue: [ ^self rootEntry permissions ].
	^super permissions: aPath! !

!WindowsStore methodsFor: 'private' stamp: ''!
directoryAt: aPath nodesDo: aBlock

	| mask drive node |

	aPath isRoot ifFalse: [ ^super directoryAt: aPath nodesDo: aBlock ].

	mask := File primLogicalDrives.
	0 to: 25 do: [ :i |
		(mask bitAnd: (1 bitShift: i)) ~= 0 ifTrue: [ 
			drive := String with: (Character value: ($A asciiValue + i)) with: $:.
			node := Array
				with: drive
				with: drive asFileReference entry statAttributes.
			aBlock value: node.
			]
		]! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
creationTimeOf: aPath
	"Answer the creation time of aPath.  If the platform doesn't support creation time, use change time"

	aPath isRoot ifTrue: [ ^self rootEntry creationTime ].
	^super creationTimeOf: aPath! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
sizeOf: aPath
	"Return the size of the File described by aPath"
	aPath isRoot ifTrue: [ ^self rootEntry size ].
	^super sizeOf: aPath.! !

!WindowsStore methodsFor: 'converting' stamp: ''!
stripDrive: pathElements
	pathElements ifNotEmpty: [ pathElements at: 1 put: ( ($: split: pathElements first) last)  ]! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
accessTimeOf: aPath
	"Answer the access time of aPath."

	aPath isRoot ifTrue: [ ^self rootEntry accessTime ].
	^super accessTimeOf: aPath! !

!WindowsStore methodsFor: 'testing' stamp: ''!
isSocket: aPath
	"Answer a boolean indicating whether the supplied path is a Socket file"

	aPath isRoot ifTrue: [ ^self rootEntry isSocket ].
	^super isSocket: aPath! !

!WindowsStore methodsFor: 'testing' stamp: ''!
isRegular: aPath
	"Answer a boolean indicating whether the supplied path is a Regular file"

	aPath isRoot ifTrue: [ ^self rootEntry isRegular ].
	^super isRegular: aPath! !

!WindowsStore methodsFor: 'testing' stamp: ''!
isHidden: aPath attributes: statAttributesArray
	"Answer a boolean indicating whether the file is hidden or not.
	statAttributesArray is optional and may be supplied for performance.  It is the result of File>>fileAttributes:mask: or nil"

	| attributesArray |
	
	attributesArray := statAttributesArray ifNil: 
		[ File fileAttributes: (self stringFromPath: aPath) mask: 1 ].

	^(attributesArray at: 13) anyMask: 16r2! !

!WindowsStore methodsFor: 'testing' stamp: ''!
isWritable: aPath
	"Answer a boolean indicating whether the supplied path can be written to"

	aPath isRoot ifTrue: [ ^self rootEntry isWritable ].
	^super isWritable: aPath! !

!WindowsStore methodsFor: 'accessing' stamp: ''!
isCharacter: aPath
	"Answer a boolean indicating whether the supplied path is a Character file"

	aPath isRoot ifTrue: [ ^self rootEntry isCharacter ].
	^super isCharacter: aPath! !

!WindowsStore methodsFor: 'testing' stamp: ''!
isFIFO: aPath
	"Answer a boolean indicating whether the supplied path is a FIFO file (pipe)"

	aPath isRoot ifTrue: [ ^self rootEntry isFIFO ].
	^super isFIFO: aPath! !

!WindowsStore class methodsFor: 'accessing' stamp: ''!
maxFileNameLength
	self flag: #pharoTodo. "More tests needed here!!".
	^ 255! !

!WindowsStore class methodsFor: 'accessing' stamp: ''!
delimiter
	^ $\! !

!WindowsStore class methodsFor: 'accessing' stamp: ''!
separator 
	^ $\! !

!WindowsStore class methodsFor: 'accessing' stamp: ''!
isCaseSensitive
	^ false! !

!WindowsStore class methodsFor: 'accessing' stamp: ''!
readOnlyVariant

	^ ReadOnlyWindowsStore! !

!WindowsStoreTest commentStamp: ''!
SUnit tests for class WindowsStore!
!WindowsStoreTest methodsFor: 'testing' stamp: ''!
testNetworkPathIsAbsolute

		#( '\\MachineName.x.y.z\directory\file' '\\MachineName.x.y.z\directory' '\\MachineName.x.y.z' )  do: [:each |
		self assert: (WindowsStore new pathFromString: each) isAbsolute ]! !

!WindowsStoreTest methodsFor: 'testing' stamp: ''!
testAbsoluteFullName
	| filesystem |
	filesystem := FileSystem store: WindowsStore new.

	"Check dropping trailing slash."	
	self assert: (filesystem referenceTo: 'C:\tmp\') fullName equals: 'C:\tmp'.

	"Check round-trip conversion from String to FileReference back to String again."
	#( 	'C:\'		'D:\'		'\'		'C:\tmp'		'D:\tmp'		'C:\tmp\xx'      ) 
		do: [ :pathString | self assert: (filesystem referenceTo: pathString) fullName equals: pathString ].! !

!WindowsStoreTest methodsFor: 'testing' stamp: ''!
testRelativeFullName

	"FIleSystem currently does not support MS Windows concept of each drive having its own working directory.
	That is too great a change during Pharo 3 Beta, so for now just drop drive from relative references. 
	Follow up in Case 13094"	

	| filesystem |
	filesystem := FileSystem store: WindowsStore new.
		
	self assert: (filesystem referenceTo: 'C:tmp') fullName equals: (filesystem referenceTo: 'tmp') fullName! !

!WindowsStoreTest methodsFor: 'testing' stamp: ''!
testNetworkPathFullName
	| filesystem |
	filesystem := FileSystem store: WindowsStore new.

	"Check dropping trailing slash."	
	self assert: (filesystem referenceTo: '\\MachineName.x.y.z\directory\file') fullName equals: '\\MachineName.x.y.z\directory\file'.

	"Check round-trip conversion from String to FileReference back to String again."
	#( '\\MachineName.x.y.z\directory\file' '\\MachineName.x.y.z\directory' '\\MachineName.x.y.z' ) 
		do: [ :pathString | self assert: (filesystem referenceTo: pathString) fullName equals: pathString ].! !

!WindowsStoreTest methodsFor: 'testing' stamp: ''!
testAbsolutePath

	#('c:\' 'C:\temp' 'A:\temp\test' '\test\bar' '\') do: [:each |
		self assert: (WindowsStore current pathFromString: each) isAbsolute ]! !

!WindowsStoreTest methodsFor: 'testing' stamp: ''!
testRelativePath

	#('a' 'bin\foo' 'temp\test' 'C:temp\test') do: [:each |
		self assert: (WindowsStore current pathFromString: each) isRelative ]! !

!WindowsStoreTest methodsFor: 'testing' stamp: ''!
testPrintString
	| filesystem |
	filesystem := FileSystem store: WindowsStore new.
	
	"path"
	self assert: (filesystem referenceTo: 'a/b') printString equals: 'File @ a\b'.
	self assert: (filesystem referenceTo: '\test.txt') printString equals: 'File @ \test.txt'.
	
	"root"
	self assert: (filesystem referenceTo: '/') printString equals: 'File @ \'.
	self assert: (filesystem referenceTo: '\') printString equals: 'File @ \'.
	
	"drive root"
	self assert: (filesystem referenceTo: 'c:\') printString equals: 'File @ c:\'.
	
	"empty"
	self assert: (filesystem referenceTo: './') printString equals: 'File @ .'.
	self assert: (filesystem referenceTo: '.\') printString equals: 'File @ .'! !

!WithForkedProcessTestResource commentStamp: ''!
I am a TestResource for testing whether my forked processes do not get terminated
between individual TestCases being executed.!
!WithForkedProcessTestResource methodsFor: 'running' stamp: ''!
tearDown

	"Terminate forked process"

	super tearDown.
	forkedProcess ifNotNil: [ forkedProcess terminate ]! !

!WithForkedProcessTestResource methodsFor: 'accessing' stamp: ''!
forkedProcess

	"Answer the receiver's forked process"

	^ forkedProcess! !

!WithForkedProcessTestResource methodsFor: 'running' stamp: ''!
setUp

	"Create a forked process which should live until the #tearDown message is received.
	The process is and should remain in suspended state."

	super setUp.
	forkedProcess := [ "empty process" ] newProcess! !

!WordArray commentStamp: ''!
WordArrays store 32-bit unsigned Integer values.


#### Using replace primitive

The array replace primitive is a generic primitive that handles the replace of arrays of objects and arrays of native values (8, 16, 32, 64bit values).
Now, for the primitive to work, both arrays should be of the same type/format.

```
a := WordArray withAll: #( 1 2 3 4 ).
b := WordArray withAll: #( 5 6 ).
a replaceFrom: 1 to: 2 with: b startingAt: 1.
```

```
a := DoubleWordArray withAll: #( 1 2 3 4 ).
b := DoubleWordArray withAll: #( 5 6 ).
a replaceFrom: 1 to: 2 with: b startingAt: 1.
```

### Not using the primitives

None of these examples do not use the primitive
```
a := DoubleWordArray withAll: #( 1 2 3 4 ).
b := ByteArray withAll: #( 5 6 ).
a replaceFrom: 1 to: 2 with: b startingAt: 1.
```

```
a := DoubleWordArray withAll: #( 1 2 3 4 ).
b := Array withAll: #( 5 6 ).
a replaceFrom: 1 to: 2 with: b startingAt: 1.
```!
!WordArray methodsFor: 'array arithmetic primitives' stamp: ''!
primSubScalar: rcvr and: other into: result

	<primitive: 'primitiveSubScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveSubScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) - other.
	].
	^ result.! !

!WordArray methodsFor: '*Collections-arithmetic' stamp: ''!
* other
	| result |
	other isNumber
		ifTrue: [ result := (other isFloat
				ifTrue: [ FloatArray ]
				ifFalse: [ WordArray ]) new: self size.
			^ self primMulScalar: self and: other into: result ].
	(other isMemberOf: WordArray)
		ifTrue: [ result := WordArray new: self size.
			^ self primMulArray: self and: other into: result ].
	(other isMemberOf: FloatArray)
		ifTrue: [ result := FloatArray new: self size.
			^ self primMulArray: self and: other into: result ].
	^ super * other! !

!WordArray methodsFor: 'accessing' stamp: ''!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	<primitive: 105>
	^super replaceFrom: start to: stop with: replacement startingAt: repStart! !

!WordArray methodsFor: '*Collections-arithmetic' stamp: ''!
/ other
	| result |
	other isNumber
		ifTrue: [ result := (other isFloat
				ifTrue: [ FloatArray ]
				ifFalse: [ WordArray ]) new: self size.
			^ self primDivScalar: self and: other into: result ].
	(other isMemberOf: WordArray)
		ifTrue: [ result := WordArray new: self size.
			^ self primDivArray: self and: other into: result ].
	(other isMemberOf: FloatArray)
		ifTrue: [ result := FloatArray new: self size.
			^ self primDivArray: self and: other into: result ].
	^ super / other! !

!WordArray methodsFor: 'accessing' stamp: ''!
byteSize
	^self size * 4! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: ''!
primDivScalar: rcvr and: other into: result

	<primitive: 'primitiveDivScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveDivScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) / other.
	].
	^ result.! !

!WordArray methodsFor: 'private' stamp: ''!
defaultElement
	"Return the default element of the receiver"
	^0! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: ''!
primSubArray: rcvr and: other into: result

	<primitive: 'primitiveSubArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveSubArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) - (other at: i)
	].
	^ result.! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: ''!
primMulScalar: rcvr and: other into: result

	<primitive: 'primitiveMulScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveMulScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) * other.
	].
	^ result.! !

!WordArray methodsFor: 'converting' stamp: ''!
asWordArray
	^self! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: ''!
primDivArray: rcvr and: other into: result

	<primitive: 'primitiveDivArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveDivArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) / (other at: i)
	].
	^ result.! !

!WordArray methodsFor: 'accessing' stamp: ''!
atAllPut: value
	"Fill the receiver with the given value"

	<primitive: 145>
	super atAllPut: value! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: ''!
primMulArray: rcvr and: other into: result

	<primitive: 'primitiveMulArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveMulArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) * (other at: i)
	].
	^ result.! !

!WordArray methodsFor: '*ThreadedFFI' stamp: ''!
tfPointerAddress

	self pinInMemory.
	^ PointerUtils oopForObject: self
! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: ''!
primAddScalar: rcvr and: other into: result

	<primitive: 'primitiveAddScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveAddScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) + other.
	].
	^ result.! !

!WordArray methodsFor: '*Collections-arithmetic' stamp: ''!
- other
	| result |
	other isNumber
		ifTrue: [ result := (other isFloat
				ifTrue: [ FloatArray ]
				ifFalse: [ WordArray ]) new: self size.
			^ self primSubScalar: self and: other into: result ].
	(other isMemberOf: WordArray)
		ifTrue: [ result := WordArray new: self size.
			^ self primSubArray: self and: other into: result ].
	(other isMemberOf: FloatArray)
		ifTrue: [ result := FloatArray new: self size.
			^ self primSubArray: self and: other into: result ].
	^ super - other! !

!WordArray methodsFor: '*Collections-arithmetic' stamp: ''!
+ other
	| result |
	other isNumber
		ifTrue: [ result := (other isFloat
				ifTrue: [ FloatArray ]
				ifFalse: [ WordArray ]) new: self size.
			^ self primAddScalar: self and: other into: result ].
	(other isMemberOf: WordArray)
		ifTrue: [ result := WordArray new: self size.
			^ self primAddArray: self and: other into: result ].
	(other isMemberOf: FloatArray)
		ifTrue: [ result := FloatArray new: self size.
			^ self primAddArray: self and: other into: result ].
	^ super + other! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: ''!
primAddArray: rcvr and: other into: result

	<primitive: 'primitiveAddArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveAddArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) + (other at: i)
	].
	^ result.! !

!WordArray class methodsFor: '*Monticello-OldDataStreamCompatibility' stamp: ''!
newFromStream: s
	"Only meant for my subclasses that are raw bits and word-like.  For quick unpack form the disk."
	| len |

	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)! !

!WordLayout commentStamp: ''!
I am a raw data layout that holds words (32 bits ).!
!WordLayout methodsFor: 'extending' stamp: ''!
extendWord
	^ WordLayout new! !

!WordLayout methodsFor: 'accessing' stamp: ''!
bytesPerSlot
	
	^ 4! !

!WordLayout methodsFor: 'format' stamp: ''!
instanceSpecification
	^ 10! !

!WordLayout methodsFor: 'testing' stamp: ''!
isWords
	^ true! !

!WordLayout methodsFor: '*Ring-Core' stamp: ''!
asRingMinimalDefinitionIn: anRGEnvironment

	^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [
		RGWordLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)]
! !

!WordLayout class methodsFor: 'description' stamp: ''!
subclassDefiningSymbol
	"Answer a keyword that describes the receiver's kind of subclass
	Note: this is for printing the ST80 style class definiton, usage makes no sense for anything
	else!!"
	^#variableWordSubclass:! !

!WordLayout class methodsFor: 'instance creation' stamp: ''!
extending: superLayout scope: aScope host: aClass
	^ superLayout extendWord
		host: aClass;
		yourself! !

!WordLayout class methodsFor: '*Monticello' stamp: 'nil'!
mcTypeSymbol 
	^ #words! !

!WorkingSession commentStamp: ''!
I am the unique object for the current smalltalk session (I.e. between a startup and a shutdown).
On each image startup the current session is invalidated and a new session is created.
I define how errors should be handled.

ps: I replace the old Session class that was only used as a session identifier  !
!WorkingSession methodsFor: 'startup - shutdown' stamp: ''!
runShutdown: isImageQuitting
	self
		runList: manager shutdownList
		do: [ :each | each shutdown: isImageQuitting ]! !

!WorkingSession methodsFor: 'testing' stamp: ''!
isDisabledAccessMode

	^ self accessMode = #disabled! !

!WorkingSession methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	deferredStartupActions := OrderedCollection new.
	creationTime := DateAndTime now.
	properties := Dictionary new.! !

!WorkingSession methodsFor: 'deferred startup actions' stamp: ''!
addDeferredStartupAction: aBlock
	"Add the block to the list of actions that we will be performed immediately after the startup list is executed."
	deferredStartupActions add: aBlock! !

!WorkingSession methodsFor: 'accessing' stamp: ''!
accessMode: anObject

	^ self properties at: #accessMode put: anObject! !

!WorkingSession methodsFor: 'accessing' stamp: ''!
creationTime
	^ creationTime! !

!WorkingSession methodsFor: 'startup - shutdown' stamp: ''!
install
	manager installSession: self! !

!WorkingSession methodsFor: 'testing' stamp: ''!
isReadWriteAccessMode

	^ self accessMode = #readWrite! !

!WorkingSession methodsFor: 'startup - shutdown' stamp: ''!
runList: aList do: aBlock
	aList do: [ :each | 
		[aBlock value: each] 
			on: Exception
			do: [ :error | self errorHandler handleError: error] ]! !

!WorkingSession methodsFor: 'startup - shutdown' stamp: ''!
runStartup: isImageStarting
	self
		runList: manager startupList
		do: [ :each | each startup: isImageStarting ].
	! !

!WorkingSession methodsFor: 'deferred startup actions' stamp: ''!
executeDeferredStartupActions: resuming
	"Execute the deferred actions which where added during startup, 
	resuming is true if the image was started fresh, false if we just saved an image"

	[ deferredStartupActions notEmpty ] 
		whileTrue: [ | action |
			action := deferredStartupActions removeFirst.
			action cull: resuming
			"We do not handle errors on deferred startup actions as there is already the environment ready to use.
			The current UI manager will handle the error." ]! !

!WorkingSession methodsFor: 'testing' stamp: ''!
isReadOnlyAccessMode

	^ self accessMode = #readOnly! !

!WorkingSession methodsFor: 'startup - shutdown' stamp: ''!
properties

	^ properties! !

!WorkingSession methodsFor: 'accessing' stamp: ''!
accessMode

	^ self properties at: #accessMode ifAbsent: [ #readWrite ]! !

!WorkingSession methodsFor: 'testing' stamp: ''!
isWriteOnlyAccessMode

	^ self accessMode = #writeOnly! !

!WorkingSession methodsFor: 'startup - shutdown' stamp: ''!
stop: isImageQuitting

	Object flushDependents.
	self runShutdown: isImageQuitting.! !

!WorkingSession methodsFor: 'startup - shutdown' stamp: ''!
start: isImageStarting
	Smalltalk vm setGCParameters.
	isImageStarting
		ifTrue: [ Smalltalk clearExternalObjects ].
	
	self runStartup: isImageStarting.! !

!WorkingSession methodsFor: 'accessing' stamp: ''!
errorHandler
	^ UIManager default! !

!WorkingSession methodsFor: 'accessing' stamp: ''!
manager: aSessionManager 
	manager := aSessionManager! !

!WorkingSession methodsFor: 'accessing' stamp: ''!
id
	^ id ifNil: [ id := UUID new ]! !

!WorkingSession methodsFor: 'startup - shutdown' stamp: ''!
uninstall
	manager uninstallSession: self! !

!Workspace commentStamp: ''!
I'm workspace: a great place to execute top-level expressions to compute something useful, and it is a great place to develop bits of a program before those bits get put into class methods.

To open a new workspace, execute one of the following expression:

[[[
	self open

	self openContents: '''Pharo is cool'''

	self openLabel: 'A cleaner workspace'
	
	self open label: 'Tutu'
]]]


!
!Workspace methodsFor: 'file support' stamp: ''!
askForFileNameToOpen
	"Ask user for file name to load content from"
	^ UIManager default
			chooseFullFileNameMatching: nil 
			label: 'Choose file to open in the workspace' translated! !

!Workspace methodsFor: 'accessing' stamp: ''!
lastContents
	^ self class lastContents ! !

!Workspace methodsFor: 'view' stamp: ''!
open
	
	self openLabel: self class title! !

!Workspace methodsFor: 'window menu' stamp: ''!
addModelItemsToWindowMenu: aMenu
	aMenu addLine.
	aMenu add: 'Open...' target: self selector: #openMenuAction.
	aMenu lastItem icon: (self iconNamed: #smallOpenIcon).
	aMenu add: 'Save as...' target: self selector: #saveAsMenuAction.
	aMenu lastItem icon: (self iconNamed: #smallSaveAsIcon).
	aMenu addLine.
	aMenu add: 'Inspect variables' target: self selector: #browseBindings.
	aMenu
		add: 'Reset variables'
		target: self
		selector: #initializeBindings.
	aMenu addLine! !

!Workspace methodsFor: 'variable definitions' stamp: ''!
bindingOf: aString 
	(bindings includesKey: aString)
		ifFalse: [ bindings add: (WorkspaceVariable key: aString asSymbol) ].
	^ bindings associationAt: aString! !

!Workspace methodsFor: 'view' stamp: ''!
textView
	^ textView ifNil:[ textView := self createTextView]! !

!Workspace methodsFor: 'accessing' stamp: ''!
fileName
	^ fileName! !

!Workspace methodsFor: 'accessing' stamp: ''!
doItReceiver
	^ nil! !

!Workspace methodsFor: 'view' stamp: ''!
openLabel: aString
	
	window := StandardWindow new model: self.
	window title: aString.
	window
		addMorph: self textView
		fullFrame: LayoutFrame identity.
	window openInWorld
	

! !

!Workspace methodsFor: 'window menu' stamp: ''!
openMenuAction
	"Open content of the file choosed by user in this workspace and associate it's name with this workspace"
	| userWarned |

	userWarned := true.
	(self fileName isNil and: [self contents isEmpty not or: [self hasUnacceptedEdits]]) ifTrue: [userWarned := self warnUser].
	(self fileName isNil not and: [self hasUnacceptedEdits]) ifTrue: [userWarned := self warnUser].
	
	userWarned ifTrue: [self openFile: self askForFileNameToOpen]! !

!Workspace methodsFor: 'file support' stamp: ''!
saveString: aString toFile: aFileName
	"Save the given string to the given file"

	| writeStream fileContent fullFilename |
	fullFilename := aFileName asFileReference fullName.
	writeStream := (File named: fullFilename) openForWrite.
	fileContent := ZnCharacterWriteStream on: writeStream encoding: encoding.
	fileContent nextPutAll: aString! !

!Workspace methodsFor: 'accessing' stamp: ''!
fileName: anObject
	fileName := anObject! !

!Workspace methodsFor: 'file support' stamp: ''!
askForFileNameToSave: suggestedFileName
	"Ask user for the name of the file to save workspace content to. Use the given file name as the initial answer"

	^ UIManager default
			request: 'Enter file name to save the workspace to' translated 
			initialAnswer: suggestedFileName! !

!Workspace methodsFor: 'file support' stamp: ''!
openFile: aFileName
	"Load file content into this workspace. If successful, associate the workspace with this file and change its label"
	
	self readStringFromFile: aFileName.
	self fileName: aFileName.
	self label: aFileName.! !

!Workspace methodsFor: '*SUnit-Support-UITesting' stamp: ''!
hasUnacceptedEdits
	"Answer true if any of the views on this model has unaccepted edits."

	self dependents
		do: [:each | 
			self flag: #pharoFixMe. "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
! !

!Workspace methodsFor: 'accessing' stamp: ''!
contents

	^ textModel getText! !

!Workspace methodsFor: 'file support' stamp: ''!
readStringFromFile: aFileName
	"Read the content of the given file."

	| readStream fileContent |
	readStream := (File named: aFileName) openForRead.
	fileContent := ZnCharacterReadStream on: readStream encoding: encoding.
	self contents: fileContent upToEnd asString! !

!Workspace methodsFor: 'accessing' stamp: ''!
contents: aString

	^ textModel setText: aString! !

!Workspace methodsFor: '*HeuristicCompletion-Morphic' stamp: ''!
bindings
	^ bindings! !

!Workspace methodsFor: 'menu' stamp: ''!
selectedMethod
	^ nil! !

!Workspace methodsFor: 'accessing' stamp: ''!
doItContext
	^ nil! !

!Workspace methodsFor: 'accessing' stamp: ''!
sourceTextArea
	^ self textView! !

!Workspace methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	textModel := self defaultTextModel.
	encoding := 'utf8'.
	self initializeBindings! !

!Workspace methodsFor: 'accessing' stamp: ''!
label: aString

	window title: aString! !

!Workspace methodsFor: 'variable definitions' stamp: ''!
browseBindings
	bindings inspect! !

!Workspace methodsFor: 'shout bindings' stamp: ''!
hasBindingOf: aString 
	^bindings includesKey: aString asSymbol! !

!Workspace methodsFor: 'accessing' stamp: ''!
selectedClassOrMetaClass
	^ nil! !

!Workspace methodsFor: 'initialization' stamp: ''!
defaultTextModel
	^ RubScrolledTextModel new interactionModel: self! !

!Workspace methodsFor: 'update' stamp: ''!
whenTextAccepted: anAnnouncement
	self lastContents size > self maxKeptContents
		ifTrue: [ self lastContents removeFirst ].
	self lastContents add: textModel getText copy! !

!Workspace methodsFor: 'initialization' stamp: ''!
initializeBindings
	
	bindings := Dictionary new! !

!Workspace methodsFor: 'accessing' stamp: ''!
setBindings: aDictionary
	"Sets the Workspace to use the specified dictionary as its namespace"

	bindings := aDictionary.
! !

!Workspace methodsFor: 'window menu' stamp: ''!
warnUser
	"Warn the user about the possible content loss"

	^ UIManager default confirm: 'This will replace the current workspace content.', String cr, 'Do you want to continue?' translated! !

!Workspace methodsFor: 'file support' stamp: ''!
suggestedFileName
	"If the workspace has an associated fileName use that, otherwise derive a reasonable file-name from the window label"
	
	self fileName ifNotNil: [ :f | ^ f ].
	^ window title, '.ws'! !

!Workspace methodsFor: 'window menu' stamp: ''!
itemForEncoding: aString
	^ encoding = aString -> aString! !

!Workspace methodsFor: 'private' stamp: ''!
createTextView
	| v |
	v := textModel newScrolledText
		withRuler: RubWorkspaceBarRuler new;
		beWrapped;
		yourself.
	v announcer when: RubTextAccepted send: #whenTextAccepted: to: self.
	^ v! !

!Workspace methodsFor: 'window menu' stamp: ''!
saveAsMenuAction
	"Save the receiver's contents string to a file, prompting the user for a file-name.  Suggest a reasonable file-name."

	| suggestedFileName |
	suggestedFileName := self askForFileNameToSave: self suggestedFileName.
	suggestedFileName ifNil: [ ^ self ].
	self fileName: suggestedFileName.
	self label: suggestedFileName.
	textModel ifNotNil: [ :model | self saveString: model getString toFile: suggestedFileName ]! !

!Workspace methodsFor: 'accessing' stamp: ''!
maxKeptContents
	^ self class maxKeptContents ! !

!Workspace methodsFor: 'window menu' stamp: ''!
useEncoding: aString
	encoding := aString.
	textModel hasUnacceptedEdits: true! !

!Workspace class methodsFor: 'accessing' stamp: ''!
lastContents
	^ LastContents ifNil: [LastContents := OrderedCollection new]! !

!Workspace class methodsFor: 'instance creation' stamp: ''!
open
	^ self new openLabel: self title ; yourself! !

!Workspace class methodsFor: 'icons' stamp: ''!
taskbarIconName
	"Answer the icon for the receiver in a task bar."

	^#workspaceIcon! !

!Workspace class methodsFor: 'instance creation' stamp: ''!
openLabel: aLabel
	^ self new openLabel: aLabel ; yourself! !

!Workspace class methodsFor: 'tool registry' stamp: ''!
registerToolsOn: registry
	"Add ourselves to registry. See [Smalltalk tools]" 
	registry register: self as: #workspace
! !

!Workspace class methodsFor: 'instance creation' stamp: ''!
openContents: aString
	"Open a new workspace with the given contents. It looks better when aString is code since the style is applied"

	^ self new
		open;
		contents: aString;
		yourself! !

!Workspace class methodsFor: 'cleaning' stamp: ''!
cleanUp
	LastContents := nil.! !

!Workspace class methodsFor: 'accessing' stamp: ''!
maxKeptContents
	^ 30! !

!Workspace class methodsFor: 'instance creation' stamp: ''!
title 
	^ 'Workspace'! !

!WorkspaceTest commentStamp: ''!
SUnit tests for Workspace!
!WorkspaceTest methodsFor: 'tests' stamp: ''!
testEmptyContent
	self assertEmpty: Workspace new contents! !

!WorkspaceVariable commentStamp: ''!
I am a binding in a Workspace. Used for non-defined temps!
!WorkspaceVariable methodsFor: 'testing' stamp: ''!
isReferenced
	^ false! !

!WorkspaceVariable methodsFor: 'testing' stamp: ''!
allowsShadowing
	^true! !

!WorkspaceVariable methodsFor: 'code generation' stamp: ''!
emitStore: methodBuilder

	methodBuilder storeIntoLiteralVariable: self.! !

!WorkspaceVariable methodsFor: 'code generation' stamp: ''!
emitValue: methodBuilder

	methodBuilder pushLiteralVariable: self! !

!WorkspaceVariable methodsFor: 'testing' stamp: ''!
isWorkspaceVariable
	^ true! !

!WorldMenuHelp commentStamp: ''!
Provide help topic for world menu!
!WorldMenuHelp class methodsFor: 'accessing' stamp: ''!
pages
	^#(overview)! !

!WorldMenuHelp class methodsFor: 'accessing' stamp: ''!
bookName 
	^'World Menu Items'! !

!WorldMenuHelp class methodsFor: 'pages' stamp: ''!
overview
	^ HelpTopic 
		title: 'Overview'
		contents: 
'The World Menu is acceesible by clicking on the background of Pharo. The menu provides shortcuts to launch tools. New menu items can be easily added. This overview gives the basic instruction how.

Consider you have a class GAPlugin. You can add a world menu item with the following _class-size_ method:
-=-=-=-=-=-=-=-=-=-=-=-=
GAPlugin class>>menuCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #GeneticAlgo) action: [ 42 inspect ]
-=-=-=-=-=-=-=-=-=-=-=-=

The code given above creates a menu entry called "GeneticAlgo". Selecting this item executes the code provided to #action:. 
Submenus can also be created:

-=-=-=-=-=-=-=-=-=-=-=-=
GAPlugin class>>menuCommandOn: aBuilder
	<worldMenu>
	aBuilder item: #GeneticAlgo.
	
	((aBuilder
		item: ''Loading Graphical Examples'';
		parent: #GeneticAlgo))
	action: [ 42 inspect ]
-=-=-=-=-=-=-=-=-=-=-=-=

The code above creates a menu in the world menu and add an entry into it.

'! !

!WorldMorph commentStamp: ''!
A WorldMorph is a special morph that represents the world.
It is a paste up and it holds active hand.

A World, the entire Smalltalk screen, is a PasteUpMorph.  A World responds true to #isWorld.!
!WorldMorph methodsFor: 'world state' stamp: ''!
displayWorld

	worldState displayWorld: self! !

!WorldMorph methodsFor: 'cursor' stamp: ''!
isCursorOwner
	^ self class cursorOwnerWorld == self! !

!WorldMorph methodsFor: '*Morphic-Base' stamp: ''!
dispatchKeystroke: anEvent
	"A keystroke was hit when no keyboard focus was set, so it is sent here to the world instead."

	|  aChar ascii |
	aChar := anEvent keyCharacter.
	(ascii := aChar asciiValue) = 27 ifTrue: "escape key"
		[^ self invokeWorldMenuFromEscapeKey].
	
	(self navigationKey: anEvent) ifTrue: [^self].

	(anEvent commandKeyPressed and: [TextEditor cmdKeysInText])
		ifTrue: [^ self dispatchCommandKeyInWorld: aChar event: anEvent].

	"It was unhandled. Remember the keystroke."
	self lastKeystroke: anEvent keyString.
	self triggerEvent: #keyStroke.
	super dispatchKeystroke: anEvent! !

!WorldMorph methodsFor: 'accessing' stamp: ''!
scaleFactor: newScaleFactor
	self setProperty: #scaleFactor toValue: newScaleFactor! !

!WorldMorph methodsFor: 'stepping' stamp: ''!
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! !

!WorldMorph methodsFor: 'world state' stamp: ''!
displayWorldSafely
	worldState displayWorldSafely: self.! !

!WorldMorph methodsFor: 'world menu' stamp: ''!
worldMenu
	^ worldState worldMenu! !

!WorldMorph methodsFor: 'project state' stamp: ''!
handsReverseDo: aBlock
	^ worldState handsReverseDo: aBlock! !

!WorldMorph methodsFor: 'menu & halo' stamp: ''!
contentsMenu: aMenu
	"Build the menu used from PopUpContentsMenu:"

	| expanded collapsed |
	expanded := self windowsSatisfying: [ :w | w isCollapsed not ].
	collapsed := self windowsSatisfying: [ :w | w isCollapsed ].
	(expanded asSortedCollection: [ :w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label ])
		do: [ :w | 
			aMenu add: (self truncatedMenuLabelFor: w label) target: w selector: #activateAndForceLabelToShow.
			aMenu lastItem icon: w taskbarIcon.
			w model canDiscardEdits 
				ifFalse: [ aMenu lastItem color: Color red ] ].
	aMenu addLine.
	(collapsed asSortedCollection: [ :w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label ])
		do: [ :w | 
			aMenu add: (self truncatedMenuLabelFor: w label) target: w selector: #collapseOrExpand.
			aMenu lastItem icon: w taskbarIcon.
			w model canDiscardEdits
				ifFalse: [ aMenu lastItem color: Color red ] ].
	aMenu addLine.
	((self submorphs reject: [ :sm | (expanded includes: sm) or: [ collapsed includes: sm ] ])
		asSortedCollection: [ :w1 :w2 | w1 class name caseInsensitiveLessOrEqual: w2 class name ])
		do: [ :w | 
			aMenu add: (self truncatedMenuLabelFor: w class name) target: w selector: #comeToFront.
			aMenu lastItem icon: w taskbarIcon ].
		
	^ aMenu! !

!WorldMorph methodsFor: 'project state' stamp: ''!
handsDo: aBlock

	^  worldState handsDo: aBlock! !

!WorldMorph methodsFor: 'menu & halo' stamp: ''!
contentsMenuTitle
	^ 'World contents' translated! !

!WorldMorph methodsFor: 'accessing' stamp: ''!
worldState
	
	^ worldState! !

!WorldMorph methodsFor: 'project state' stamp: ''!
firstHand
	^ worldState hands first! !

!WorldMorph methodsFor: 'geometry - testing' stamp: ''!
fullContainsPoint: pt
	^bounds containsPoint: pt! !

!WorldMorph methodsFor: 'geometry' stamp: ''!
displayScaleFactor

	^ self class displayScaleFactor! !

!WorldMorph methodsFor: 'stepping' stamp: ''!
startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime
	worldState startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime.! !

!WorldMorph methodsFor: 'Morphic-Base-Windows' stamp: ''!
fullRepaintNeeded

	worldState doFullRepaint.
	self windowsSatisfying: [:w | w makeMeVisible. false]! !

!WorldMorph methodsFor: 'project state' stamp: ''!
hands

	^ worldState hands! !

!WorldMorph methodsFor: 'initialization' stamp: ''!
initialize 
	worldState := WorldState new.
 	super initialize.
	
	SystemAnnouncer uniqueInstance weak when: FullscreenAnnouncement send: #fullscreenChanged: to: self! !

!WorldMorph methodsFor: 'initialization' stamp: ''!
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 |
	priorWorld := ActiveWorld.
	ActiveWorld := self.
	aBlock
		on: Error
		do: [ :ex | 
			ActiveWorld := priorWorld.
			ex pass ]! !

!WorldMorph methodsFor: 'project state' stamp: ''!
listOfSteppingMorphs
	^ worldState listOfSteppingMorphs

"self currentWorld listOfSteppingMorphs"! !

!WorldMorph methodsFor: 'world state' stamp: ''!
restoreMorphicDisplay

	worldState worldRenderer restoreMorphicDisplay! !

!WorldMorph methodsFor: 'world menu' stamp: ''!
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."
	^ worldState isEasySelecting! !

!WorldMorph methodsFor: '*Morphic-Base' stamp: ''!
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.	"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: [ 
			self inform: 'Dropped morph not in bounds'.
			aMorph position: self bounds center ].
	aMorph
		submorphsDo: [ :m | 
			(m isKindOf: HaloMorph)
				ifTrue: [ m delete ] ].
	self bringTopmostsToFront! !

!WorldMorph methodsFor: '*OSWindow-Core' stamp: ''!
clipboardText: aString
	^ self osWindow clipboardText: aString! !

!WorldMorph methodsFor: 'accessing' stamp: ''!
displayArea

	^ self worldState worldRenderer usableArea.! !

!WorldMorph methodsFor: 'event handling' stamp: ''!
fullscreenChanged: fullscreenAnnouncement

	self worldState worldRenderer fullscreenMode: fullscreenAnnouncement fullscreen! !

!WorldMorph methodsFor: 'menu & halo' stamp: ''!
deleteBalloonTarget: aMorph
	"Delete the balloon help targeting the given morph"

	self handsDo: [ :h | h deleteBalloonTarget: aMorph ]! !

!WorldMorph methodsFor: 'world state' stamp: ''!
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! !

!WorldMorph methodsFor: 'stepping' stamp: ''!
cleanseStepList
	"Remove morphs from the step list that are not in this World."

	worldState cleanseStepListForWorld: self! !

!WorldMorph methodsFor: 'cursor' stamp: ''!
beCursorOwner
	self class cursorOwnerWorld: self! !

!WorldMorph methodsFor: 'menu & halo' stamp: ''!
wantsWindowEvent: anEvent
	^ true! !

!WorldMorph methodsFor: 'project state' stamp: ''!
steppingMorphsNotInWorld
	| all |
	all := self allMorphs.
	^ self listOfSteppingMorphs reject: [ :m | all includes: m ]	"self currentWorld steppingMorphsNotInWorld do: [:m | m delete]"! !

!WorldMorph methodsFor: 'project state' stamp: ''!
isStepping: aMorph
	^ worldState isStepping: aMorph! !

!WorldMorph methodsFor: 'world state' stamp: ''!
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! !

!WorldMorph methodsFor: 'stepping' stamp: ''!
step
	owner ifNotNil: [ ^ self runLocalStepMethods ].
	^ super step! !

!WorldMorph methodsFor: 'private' stamp: ''!
privateMoveBy: delta
	super privateMoveBy: delta.! !

!WorldMorph methodsFor: '*Morphic-Base' stamp: ''!
install

	"This method should not be used. This is for backward compatibility and will be replaced
	with a newer solution"
   
	owner := nil.	"since we may have been inside another world previously"
	ActiveWorld := self.
	World := self.
	
	self hands ifEmpty: [self addHand: HandMorph new].

	self worldState worldRenderer: AbstractWorldRenderer mainWorldRenderer.
	AbstractWorldRenderer mainWorldRenderer world: self.  
	
	submorphs do: [ :ss | ss owner ifNil: [ ss privateOwner: self ] ].	
		
	worldState handsDo: [ :h | h initForEvents ].
	self borderWidth: 0.	
	SystemWindow noteTopWindowIn: self.
	self displayWorldSafely.
	self extent: self worldState worldRenderer actualScreenSize.
	self viewBox: self worldState worldRenderer viewBox.! !

!WorldMorph methodsFor: 'submorphs - add/remove' stamp: ''!
addAllMorphs: array

	super addAllMorphs: array.
	array do: [:m | self startSteppingSubmorphsOf: m]! !

!WorldMorph methodsFor: 'printing' stamp: ''!
printOn: aStream
	"Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is"

	super printOn: aStream.
	aStream nextPutAll: ' [world]'! !

!WorldMorph methodsFor: 'stepping' stamp: ''!
stopStepping: aMorph
	"Remove the given morph from the step list."

	worldState stopStepping: aMorph! !

!WorldMorph methodsFor: 'menu & halo' stamp: ''!
truncatedMenuLabelFor: aWindowLabel
	^ aWindowLabel truncateWithElipsisTo: 47! !

!WorldMorph methodsFor: '*Morphic-Widgets-Menubar' stamp: ''!
menubar

	^ self submorphs detect: #isMenubar! !

!WorldMorph methodsFor: 'meta-actions' stamp: ''!
buildMetaMenu: evt
	| menu |
	menu := UIManager default newMenuIn: self for: self.
	self addStandardHaloMenuItemsTo: menu hand: evt hand.
	^ menu! !

!WorldMorph methodsFor: 'world menu' stamp: ''!
discoveredWorldMenu
	^ worldState discoveredWorldMenu! !

!WorldMorph methodsFor: 'structure' stamp: ''!
world
	
	^self! !

!WorldMorph methodsFor: 'event handling' stamp: ''!
releaseCachedState
	super releaseCachedState.
	self cleanseStepList.! !

!WorldMorph methodsFor: 'world state' stamp: ''!
defaultWorldColor
	^ self class defaultWorldColor! !

!WorldMorph methodsFor: 'geometry' stamp: ''!
extent: aPoint
	super extent: aPoint.
	worldState viewBox ifNotNil: [ 
		worldState invalidate ]! !

!WorldMorph methodsFor: 'accessing' stamp: ''!
announcer
	WorldAnnouncer ifNil: [ WorldAnnouncer := Announcer new ].
	^ WorldAnnouncer! !

!WorldMorph methodsFor: 'halos and balloon help' stamp: ''!
wantsDirectionHandles

	^ false! !

!WorldMorph methodsFor: 'alarms - scheduler' stamp: ''!
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.! !

!WorldMorph methodsFor: 'alarms - scheduler' stamp: ''!
removeAlarm: aSelector for: aTarget
	"Remove the alarm with the given selector"
	
	worldState removeAlarm: aSelector for: aTarget! !

!WorldMorph methodsFor: 'stepping' stamp: ''!
runLocalStepMethods

	worldState runLocalStepMethodsIn: self! !

!WorldMorph methodsFor: 'submorphs - accessing' stamp: ''!
allMorphsDo: aBlock
	"Enumerate all morphs in the world, including those held in hands."

	super allMorphsDo: aBlock.
	worldState handsReverseDo: [ :h | h allMorphsDo: aBlock ]! !

!WorldMorph methodsFor: 'stepping' stamp: ''!
runStepMethods

	worldState runStepMethodsIn: self! !

!WorldMorph methodsFor: 'project state' stamp: ''!
stepListSize
	^ worldState stepListSize

"Transcript cr; show: self currentWorld stepListSize printString, ' items on steplist as of ', Date dateAndTimeNow printString"! !

!WorldMorph methodsFor: 'copying' stamp: ''!
veryDeepCopyWith: deepCopier
	"never copy the World"

	^ self! !

!WorldMorph methodsFor: 'project state' stamp: ''!
isStepping: aMorph selector: aSelector
	^ worldState isStepping: aMorph selector: aSelector! !

!WorldMorph methodsFor: 'project state' stamp: ''!
viewBox

	^ worldState viewBox! !

!WorldMorph methodsFor: 'stepping' stamp: ''!
stopStepping: aMorph selector: aSelector
	"Remove the given morph from the step list."

	worldState stopStepping: aMorph selector: aSelector! !

!WorldMorph methodsFor: 'change reporting' stamp: ''!
invalidRect: damageRect from: aMorph
	"Clip damage reports to my bounds, since drawing is clipped to my bounds."

	worldState recordDamagedRect: (damageRect intersect: self bounds ifNone: [ ^ self ])! !

!WorldMorph methodsFor: 'operations' stamp: ''!
activateCursor: aCursor withMask: maskForm

	worldState worldRenderer activateCursor: aCursor withMask: maskForm! !

!WorldMorph methodsFor: 'structure' stamp: ''!
activeHand

	^ worldState activeHand! !

!WorldMorph methodsFor: 'world state' stamp: ''!
doOneCycle
	self doOneCycleNow! !

!WorldMorph methodsFor: 'interaction loop' stamp: ''!
doOneCycleNow
	"see the comment in doOneCycleNowFor:"
	worldState doOneCycleFor: self.! !

!WorldMorph methodsFor: 'accessing' stamp: ''!
actualScreenSize

	^ self worldState worldRenderer actualScreenSize! !

!WorldMorph methodsFor: 'world state' stamp: ''!
viewBox: newViewBox
	"I am now displayed within newViewBox; react."

	(self viewBox isNil or: [ self viewBox extent ~= newViewBox extent ])
		ifTrue: [ worldState invalidate ].

	super viewBox: newViewBox.
	worldState handsDo: [ :hand | hand releaseKeyboardFocus ].
	self fullRepaintNeeded! !

!WorldMorph methodsFor: 'world state' stamp: ''!
haloMorphs

	^ self hands collect: [ :h | h halo ] thenSelect: [ :halo | halo notNil ]! !

!WorldMorph methodsFor: '*Morphic-Base' stamp: ''!
mouseDown: evt
	super mouseDown: evt.
	self currentWindow ifNotNil: [ :topWindow | SystemWindow passivateTopWindow ]! !

!WorldMorph methodsFor: '*OSWindow-Core' stamp: ''!
clipboardText
	^ self osWindow clipboardText! !

!WorldMorph methodsFor: 'classification' stamp: ''!
isWorldMorph

	^ true! !

!WorldMorph methodsFor: 'menus' stamp: ''!
addStandardHaloMenuItemsTo: aMenu hand: aHandMorph
	"Add standard halo items to the menu"

	self addWorldHaloMenuItemsTo: aMenu hand: aHandMorph! !

!WorldMorph methodsFor: 'world state' stamp: ''!
activeHand: aHandMorph
	"Temporarily retained for old main event loops"
	worldState activeHand: aHandMorph! !

!WorldMorph methodsFor: 'deferred message' stamp: ''!
defer: aValuable
	"aValuable will be executed in the next UI rendering cycle"
	worldState defer: aValuable! !

!WorldMorph methodsFor: 'event handling' stamp: ''!
wantsDropFiles: anEvent
	"We check if the WorldMorph is configured to be able to receive droped files. During the deployment of an application this option might be disabled."
	
	^ self class allowDropFiles! !

!WorldMorph methodsFor: 'private' stamp: ''!
wantsDroppedMorph: aMorph event: evt
	
	^ true! !

!WorldMorph class methodsFor: 'setting' stamp: ''!
displayScaleFactor

	^ displayScaleFactor ifNil: [ displayScaleFactor := 1 ]! !

!WorldMorph class methodsFor: 'accessing' stamp: ''!
allowDropFiles: anObject
	AllowDropFiles := anObject! !

!WorldMorph class methodsFor: 'extra worlds' stamp: ''!
addExtraWorld: aWorld
	ExtraWorldListMutex critical: [
		ExtraWorldList := self extraWorldList copyWith: aWorld
	]! !

!WorldMorph class methodsFor: 'class initialization' stamp: ''!
initialize
	ExtraWorldListMutex := Semaphore forMutualExclusion.! !

!WorldMorph class methodsFor: 'setting' stamp: ''!
scaleFactor: aValue
	
	World scaleFactor: aValue! !

!WorldMorph class methodsFor: 'updating' stamp: ''!
doOneCycle

	WorldState doDrawCycleWith: [ 
		| extraWorldsToDraw |
		extraWorldsToDraw := ExtraWorldListMutex critical: [ 
			                     self extraWorldList ].
		extraWorldsToDraw do: [ :world | world doOneCycle ].

		(self currentWorld isNotNil and: [ 
			 (extraWorldsToDraw includes: self currentWorld) not ]) ifTrue: [ 
			self currentWorld doOneCycle ] ]! !

!WorldMorph class methodsFor: 'extra worlds' stamp: ''!
cursorOwnerWorld: aWorld
	
	CursorOwnerWorld := aWorld.! !

!WorldMorph class methodsFor: 'setting' stamp: ''!
displayScaleFactorSettingsOn: aBuilder 
	<systemsettings>
	
	(aBuilder range: #scaleFactor)
		parent: #appearance;
		order: 3;
		default: 1;
		label: 'Display scale factor';
		description: 'Specify scale factor for UI elements. This setting does not affect defined font sizes.';
		target: self;
		range: (0.5 to: 5 by: 0.5)! !

!WorldMorph class methodsFor: 'accessing' stamp: ''!
allowDropFiles
	"If this option is set to false, the world morph will no longer be able to receive droped files. This help to protect private code while deploying an application."
	
	^ AllowDropFiles ifNil: [ AllowDropFiles := true ]! !

!WorldMorph class methodsFor: 'setting' stamp: ''!
displayScaleFactor: aNumber

	displayScaleFactor := aNumber! !

!WorldMorph class methodsFor: 'extra worlds' stamp: ''!
removeExtraWorld: aWorld
	ExtraWorldListMutex critical: [
		ExtraWorldList := self extraWorldList copyWithout: aWorld.
	].
	CursorOwnerWorld == aWorld ifTrue: [ CursorOwnerWorld := nil ].! !

!WorldMorph class methodsFor: 'extra worlds' stamp: ''!
cursorOwnerWorld
	^ CursorOwnerWorld ifNil: [ self currentWorld ]! !

!WorldMorph class methodsFor: 'setting' stamp: ''!
defaultWorldColor

	^ Color r: 0.937 g: 0.937 b: 0.937! !

!WorldMorph class methodsFor: 'startup - shutdown' stamp: ''!
cleanUp
	self currentWorld cleanseOtherworldlySteppers! !

!WorldMorph class methodsFor: 'extra worlds' stamp: ''!
extraWorldList
	ExtraWorldList ifNil: [ ExtraWorldList := #() ].
	^ ExtraWorldList! !

!WorldMorph class methodsFor: 'setting' stamp: ''!
scaleFactor
	
	^ World scaleFactor! !

!WorldPresenter commentStamp: ''!
I am a model representing Pharo World.

This way, every spec application can be opened as the Pharo system window as window, to simulate native a application.!
!WorldPresenter methodsFor: 'private' stamp: ''!
defaultInitialExtent
	
	^ self currentWorld extent! !

!WorldPresenter methodsFor: 'api' stamp: ''!
isDisplayed

	^ true! !

!WorldPresenter methodsFor: 'private' stamp: ''!
addModelIn: container withSpecLayout: aSpec

	self model ifNil: [ ^ self ].
	widget := self model buildWithSpecLayout: aSpec.
	
	container
		addMorph: widget
		fullFrame: LayoutFrame identity! !

!WorldPresenter methodsFor: 'private' stamp: ''!
addModelIn: container withSpec: aSpec
	
	self model ifNil: [ ^ self ].
	widget := self model buildWithSpec: aSpec.
	
	container
		addMorph: widget
		fullFrame: LayoutFrame identity! !

!WorldPresenter methodsFor: 'private' stamp: ''!
title: aString

	^ DisplayScreen hostWindowTitle: aString! !

!WorldPresenter methodsFor: 'factory' stamp: ''!
buildWidget

	^ self currentWorld asSpecAdapter! !

!WorldPresenter methodsFor: 'private' stamp: ''!
openWithSpecLayout: aSpec

	self buildWithSpecLayout: aSpec.
	self updateTitle! !

!WorldPresenter methodsFor: 'api' stamp: ''!
widget

	^ widget ! !

!WorldPresenter methodsFor: 'private' stamp: ''!
updateTitle
	"Update the window title"

	DisplayScreen hostWindowTitle: self title! !

!WorldPresenter methodsFor: 'private' stamp: ''!
openWithSpec: aSpec

	self buildWithSpec: aSpec.
	self updateTitle! !

!WorldPresenter methodsFor: 'api' stamp: ''!
ensureExtentFor: aWidget

	self extent ifNotNil: [ :ext | DisplayScreen hostWindowSize: ext ].
	self initialExtent ifNotNil: [ :ext | DisplayScreen hostWindowSize: ext ].! !

!WorldPresenter class methodsFor: 'private' stamp: ''!
setUpWorld
	self currentWorld changeProportionalLayout.
	self currentWorld submorphs do: [:e | e delete ].
 	(self environment at: #PolymorphSystemSettings) 
		perform: #desktopColor: 
		with: self theme backgroundColor.
	(self environment at: #TaskbarMorph) perform: #showTaskbar: with: false! !

!WorldPresenter class methodsFor: 'specs' stamp: ''!
defaultSpec
	<spec>
	
	self setUpWorld.
	^ self currentWorld asSpecAdapter! !

!WorldState commentStamp: ''!
The state of a Morphic world.  (This needs some serious commenting!!!!)


The MinCycleLapse variable holds the minimum amount of time that a morphic cycle is allowed to take.  If a cycle takes less than this, then interCyclePause: will wait until the full time has been used up.!
!WorldState methodsFor: 'stepping' stamp: ''!
runStepMethodsIn: aWorld
	"Perform periodic activity inbetween event cycles"
	
	| queue nextInQueue|
	"If available dispatch some deferred UI Message"
	queue := self class deferredUIMessages.
	[(nextInQueue := queue nextOrNil) isNil]
		whileFalse: [ nextInQueue value].
	self runLocalStepMethodsIn: aWorld.
	"The multi-threaded global Transcript needs to be updated periodically and synchronously with the UI."
	Transcript stepGlobal.! !

!WorldState methodsFor: 'alarms' stamp: ''!
alarms

	^alarms ifNil: [alarms := Heap sortBlock: self alarmSortBlock]! !

!WorldState methodsFor: 'update cycle' stamp: ''!
checkIfUpdateNeeded

	damageRecorder updateIsNeeded ifTrue: [ ^true ].
		
	hands do: [:h | 
		(h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]].
	^false  "display is already up-to-date"! !

!WorldState methodsFor: 'update cycle' stamp: ''!
drawWorld: aWorld submorphs: submorphs invalidAreasOn: aCanvas 
	"Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that
were redrawn."

	| rectList n morphs rects validList |
	rectList := damageRecorder invalidRectsFullBounds: aWorld viewBox.
	"sort by areas to draw largest portions first"
	rectList := rectList asArray sort: [:r1 :r2 | r1 area > r2 area].
	damageRecorder reset.
	n := submorphs size.
	morphs := OrderedCollection new: n * 2.
	rects := OrderedCollection new: n * 2.
	validList := OrderedCollection new: n * 2.
	rectList do: 
			[:dirtyRect | 
			dirtyRect allAreasOutsideList: validList
				do: 
					[:r | | mm rect i c remnantIntersects remnants rectToFill | 
					"Experimental top-down drawing --
			Traverses top to bottom, stopping if the entire area is filled.
			If only a single rectangle remains, then continue with the reduced rectangle."

					rectToFill := r.
					remnants := OrderedCollection with: r.
					i := 1.
					[remnants isEmpty or: [i > n]] whileFalse: 
							[mm := submorphs at: i.
							((remnantIntersects := remnants select: [:each | (mm fullBounds intersects: each)]) notEmpty and: [mm visible]) 
								ifTrue: 
									[morphs addLast: mm.
									
									rects addLast: (Rectangle merging: (remnantIntersects collect: [:each | mm fullBounds intersect: each])).
									remnants removeAll: remnantIntersects.
									remnantIntersects do: [:eachIntersect | remnants addAll: (mm areasRemainingToFill: eachIntersect)].
									remnants size = 1 ifTrue: [rectToFill := remnants first].
									remnants isEmpty ifTrue: [rectToFill := nil]].
							i := i + 1].
					"Now paint from bottom to top, but using the reduced rectangles."
					rectToFill 
						ifNotNil: [aWorld drawOn: (c := aCanvas copyClipRect: rectToFill)].
					[morphs isEmpty] whileFalse: 
							[(rect := rects removeLast) == rectToFill 
								ifFalse: [c := aCanvas copyClipRect: (rectToFill := rect)].
							c fullDrawMorph: morphs removeLast].
					morphs reset.
					rects reset.
					validList add: r]].
	^validList! !

!WorldState methodsFor: 'worldmenu building' stamp: ''!
fallbackMenuOn: menu
	"Build the menu that is put up if something is going wrong with the menubuilder"
	
	menu addTitle: 'Fallback menu'.
	menu commandKeyHandler: self.
	menu addLine.
	menu
		defaultTarget: Smalltalk tools;
		addList: Smalltalk tools menuItems.
	menu addLine.
	menu add: 'Save'
		target: self class
		selector: #saveSession.
	menu add: 'Save as...'
		target: self class
		selector: #saveAs.
	menu add: 'Save and quit' 
		target: self class
		selector: #saveAndQuit.
	menu add: 'Quit' 
		target: self class
		selector: #quitSession.! !

!WorldState methodsFor: 'worldmenu building' stamp: ''!
worldMenu
	^self menuBuilder menuEntitled: self discoveredMenuTitle! !

!WorldState methodsFor: 'hands' stamp: ''!
handsReverseDo: aBlock

	^ hands reverseDo: aBlock! !

!WorldState methodsFor: 'accessing' stamp: ''!
currentCursor
	^ currentCursor! !

!WorldState methodsFor: '*Morphic-Base' stamp: ''!
startThenBrowseMessageTally

	self class startThenBrowseMessageTally! !

!WorldState methodsFor: 'stepping' stamp: ''!
runLocalStepMethodsIn: aWorld 
	"Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world.
	ar 3/13/1999: Remove buggy morphs from the step list so that they don't raise repeated errors."

	| now morphToStep stepTime priorWorld |
	now := Time millisecondClockValue.
	priorWorld := ActiveWorld.
	ActiveWorld := aWorld.
	self triggerAlarmsBefore: now.
	stepList isEmpty 
		ifTrue: 
			[ActiveWorld := priorWorld.
			^self].
	(now < lastStepTime or: [now - lastStepTime > 5000]) 
		ifTrue: [self adjustWakeupTimes: now].	"clock slipped"
	[stepList isEmpty not and: [stepList first scheduledTime < now]] 
		whileTrue: 
			[lastStepMessage := stepList removeFirst.
			morphToStep := lastStepMessage receiver.
			(morphToStep shouldGetStepsFrom: aWorld) 
				ifTrue: 
					[lastStepMessage value: now.
					lastStepMessage ifNotNil: 
							[stepTime := lastStepMessage stepTime ifNil: [morphToStep stepTime].
							lastStepMessage scheduledTime: now + (stepTime max: 1).
							stepList add: lastStepMessage]].
			lastStepMessage := nil].
	lastStepTime := now.
	ActiveWorld := priorWorld! !

!WorldState methodsFor: 'hands' stamp: ''!
handsDo: aBlock

	^ hands do: aBlock! !

!WorldState methodsFor: 'object filein' stamp: ''!
convertAlarms
	
	alarms ifNotNil: [alarms sortBlock: self alarmSortBlock].	"ensure cleaner block"! !

!WorldState methodsFor: 'hands' stamp: ''!
worldRenderer

    ^ worldRenderer ifNil: [ worldRenderer := NullWorldRenderer forWorld: self currentWorld ]! !

!WorldState methodsFor: 'accessing' stamp: ''!
icon: aForm 

	worldRenderer icon: aForm! !

!WorldState methodsFor: '*Morphic-Base' stamp: ''!
startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime
	"Add the given morph to the step list. Do nothing if it is already being stepped."

	self stopStepping: aMorph selector: aSelector.
	self adjustWakeupTimesIfNecessary.
	stepList add:(
		StepMessage 
			scheduledAt: scheduledTime
			stepTime: stepTime
			receiver: aMorph
			selector: aSelector
			arguments: args)! !

!WorldState methodsFor: 'update cycle' stamp: ''!
displayWorldSafely: aWorld
	"Update this world's display and keep track of errors during draw methods."

	[aWorld displayWorld] onErrorDo: [:err |
		"Handle a drawing error"
		| errCtx errMorph |
		errCtx := thisContext.
		[
			errCtx := errCtx sender.
			"Search the sender chain to find the morph causing the problem"
			[errCtx notNil and:[(errCtx receiver isMorph) not]] 
				whileTrue:[errCtx := errCtx sender].
			"If we're at the root of the context chain then we have a fatal drawing problem"
			errCtx ifNil:[^self handleFatalDrawingError: err description].
			errMorph := errCtx receiver.
			"If the morph causing the problem has already the #drawError flag set,
			then search for the next morph above in the caller chain."
			errMorph hasProperty: #errorOnDraw
		] whileTrue.
		errMorph setProperty: #errorOnDraw toValue: true.
		"Install the old error handler, so we can re-raise the error"
		err signal.
	].! !

!WorldState methodsFor: 'hands' stamp: ''!
hands

	^ hands! !

!WorldState methodsFor: 'initialization' stamp: ''!
initialize

	super initialize.
	hands := Array new.
	damageRecorder:= DamageRecorder new.
	stepList := Heap sortBlock: self stepListSortBlock.
	lastStepTime := 0.
	lastAlarmTime := 0.! !

!WorldState methodsFor: 'hands' stamp: ''!
is: hand overlappingDamagedAreaIn: damageList
	| handBounds |
	handBounds := hand fullBounds.
	^ damageList anySatisfy: [ :r | r intersects: handBounds ]! !

!WorldState methodsFor: 'stepping' stamp: ''!
listOfSteppingMorphs
	^stepList collect:[:entry| entry receiver].! !

!WorldState methodsFor: 'update cycle' stamp: ''!
doOneCycleFor: aWorld
	"Immediately do one cycle of the interaction loop.
	This should not be called directly, but only via doOneCycleFor:"

	self worldRenderer checkForNewScreenSize.

	"process user input events"
	self handsDo: [:h |
		self activeHand: h.
		h processEvents.
		self activeHand: nil.
	].

	"the default is the primary hand"
	self activeHand: self hands first.

	aWorld runStepMethods.		"there are currently some variations here"
	self displayWorldSafely: aWorld.! !

!WorldState methodsFor: 'settings' stamp: ''!
isEasySelecting
	^ self class easySelectingWorld! !

!WorldState methodsFor: 'stepping' stamp: ''!
adjustWakeupTimesIfNecessary
	"Fix the wakeup times in my step list if necessary. This is needed after a snapshot, after a long pause (say because some other view had control or because the user was selecting from an MVC-style menu) or when the millisecond clock wraps around (a very rare occurrence with a 32-bit clock!!)."

	| now |
	now := Time millisecondClockValue.
	((now < lastStepTime) or: [(now - lastStepTime) > 5000])
		 ifTrue: [self adjustWakeupTimes: now].  "clock slipped"! !

!WorldState methodsFor: 'accessing' stamp: ''!
damageRecorder

	^ damageRecorder! !

!WorldState methodsFor: '*Morphic-Base' stamp: ''!
menuBuilder

	^ (PragmaMenuBuilder
		   pragmaKeyword: self discoveredMenuPragmaKeyword
		   model: self)
		  menuSpec;
		  yourself! !

!WorldState methodsFor: 'canvas' stamp: ''!
invalidate
	self worldRenderer invalidate.
	damageRecorder 
		ifNil: [damageRecorder := DamageRecorder new]
		ifNotNil: [damageRecorder doFullRepaint]! !

!WorldState methodsFor: 'worldmenu building' stamp: ''!
discoveredMenuOn: aBuilder

	^ aBuilder menuEntitled: self discoveredMenuTitle! !

!WorldState methodsFor: 'hands' stamp: ''!
realWindowExtent: aValue

	realWindowExtent := aValue! !

!WorldState methodsFor: 'hands' stamp: ''!
removeHand: aHandMorph
	"Remove the given hand from the list of hands for this world."

	(hands includes: aHandMorph) ifFalse: [^self].
	hands := hands copyWithout: aHandMorph.
	activeHand == aHandMorph ifTrue: [activeHand := nil].! !

!WorldState methodsFor: 'stepping' stamp: ''!
cleanseStepListForWorld: aWorld
	"Remove morphs from the step list that are not in this World"

	| deletions morphToStep |
	deletions := nil.
	stepList do: [:entry |
		morphToStep := entry receiver.
		morphToStep world == aWorld ifFalse:[
			deletions ifNil: [deletions := OrderedCollection new].
			deletions addLast: entry]].

	deletions ifNotNil:[
		deletions do: [:entry|
			self stopStepping: entry receiver]].

	self alarms copy do:[:entry|
		morphToStep := entry receiver.
		(morphToStep isMorph and:[morphToStep world == aWorld]) 
			ifFalse:[self removeAlarm: entry selector for: entry receiver]].! !

!WorldState methodsFor: 'alarms' stamp: ''!
adjustAlarmTimes: nowTime
	"Adjust the alarm times after some clock weirdness (such as roll-over, image-startup etc)"
	| deltaTime |
	deltaTime := nowTime - lastAlarmTime.
	self alarms do:[:alarm| alarm scheduledTime: alarm scheduledTime + deltaTime].! !

!WorldState methodsFor: 'events' stamp: ''!
updateToNewResolution: originalEvent

	"We need to reset the render if the resolution changes. 
	If we don't do this the image seems blocked but as it does not refresh the window"

	self doFullRepaint.
	
	self worldRenderer updateToNewResolution.
	
	self worldRenderer checkForNewScreenSize.! !

!WorldState methodsFor: 'canvas' stamp: ''!
doFullRepaint

	damageRecorder doFullRepaint! !

!WorldState methodsFor: 'update cycle' stamp: ''!
handleFatalDrawingError: errMsg
	"Handle a fatal drawing error."
	self worldRenderer deferUpdates: false. "Just in case"
	self primitiveError: errMsg.

	"Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"! !

!WorldState methodsFor: 'stepping' stamp: ''!
isStepping: aMorph
	"Return true if the given morph is in the step list."
	lastStepMessage ifNotNil:[(lastStepMessage receiver == aMorph) ifTrue:[^true]].
	stepList do:[:entry| entry receiver == aMorph ifTrue:[^true]].
	^ false! !

!WorldState methodsFor: 'hands' stamp: ''!
addHand: aHandMorph
	"Add the given hand to the list of hands for this world."

	hands := (hands copyWithout: aHandMorph) copyWith: aHandMorph.! !

!WorldState methodsFor: 'stepping' stamp: ''!
adjustWakeupTimes: now
	"Fix the wakeup times in my step list. This is necessary when this world has been restarted after a pause, say because some other view had control, after a snapshot, or because the millisecond clock has wrapped around. (The latter is a rare occurrence with a 32-bit clock!!)"
	| deltaTime |
	deltaTime := now - lastStepTime.
	stepList do:[:entry| entry scheduledTime: entry scheduledTime + deltaTime].
	lastStepTime := now.! !

!WorldState methodsFor: 'accessing' stamp: ''!
currentCursor: anObject
	currentCursor := anObject! !

!WorldState methodsFor: 'hands' stamp: ''!
realWindowExtent

	^ realWindowExtent! !

!WorldState methodsFor: 'hands' stamp: ''!
selectHandsToDrawForDamage: damageList
	"Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle."

	^ hands
		select: [ :hand | hand needsToBeDrawn and: [ hand hasChanged or: [ self is: hand overlappingDamagedAreaIn: damageList ] ] ]! !

!WorldState methodsFor: 'stepping' stamp: ''!
stopStepping: aMorph
	"Remove the given morph from the step list."
	lastStepMessage ifNotNil:[
		(lastStepMessage receiver == aMorph) ifTrue:[lastStepMessage := nil]].
	stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph]).! !

!WorldState methodsFor: '*Morphic-Base' stamp: ''!
startMessageTally

	self class startMessageTally! !

!WorldState methodsFor: 'update cycle' stamp: ''!
displayWorld: aWorld
	"Update this world's display."

	worldRenderer displayWorldState: self ofWorld: aWorld! !

!WorldState methodsFor: 'accessing' stamp: ''!
worldRenderer: anObject

	worldRenderer := anObject.
	worldRenderer activate! !

!WorldState methodsFor: 'settings' stamp: ''!
discoveredMenuTitle
	^ self class discoveredMenuTitle! !

!WorldState methodsFor: 'settings' stamp: ''!
serverMode
	^ self class serverMode! !

!WorldState methodsFor: 'cleaning' stamp: ''!
cleanStepList
	"ensure that we have a cleaner block"
	^stepList sortBlock: self stepListSortBlock! !

!WorldState methodsFor: 'canvas' stamp: ''!
resetDamageRecorder

	damageRecorder reset! !

!WorldState methodsFor: 'settings' stamp: ''!
discoveredMenuPragmaKeyword
	^ self class discoveredMenuPragmaKeyword! !

!WorldState methodsFor: 'alarms' stamp: ''!
removeAlarm: aSelector for: aTarget
	"Remove the alarm with the given selector"

	self alarms
		detect: [ :any | any receiver == aTarget and: [ any selector == aSelector ] ]
		ifFound: [ :alarm | self alarms remove: alarm ]! !

!WorldState methodsFor: '*Morphic-Base' stamp: ''!
addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime
	"Add a new alarm with the given set of parameters"
	self alarms add: 
		(MorphicAlarm 
			scheduledAt: scheduledTime
			receiver: aTarget
			selector: aSelector
			arguments: argArray).! !

!WorldState methodsFor: 'initialization' stamp: ''!
stepListSize
	^ stepList size! !

!WorldState methodsFor: 'stepping' stamp: ''!
isStepping: aMorph selector: aSelector
	"Return true if the given morph is in the step list."
	lastStepMessage ifNotNil:[
		(lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector])
			ifTrue:[^true]].
	stepList do:[:entry| (entry receiver == aMorph and:[entry selector == aSelector]) ifTrue:[^true]].
	^ false! !

!WorldState methodsFor: 'canvas' stamp: ''!
viewBox

	^ self worldRenderer viewBox! !

!WorldState methodsFor: 'stepping' stamp: ''!
stopStepping: aMorph selector: aSelector
	"Remove the given morph from the step list."
	lastStepMessage ifNotNil:[
		(lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector])
			ifTrue:[lastStepMessage := nil]].
	stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and:[stepMsg selector == aSelector]]).! !

!WorldState methodsFor: 'stepping' stamp: ''!
stepListSortBlock
	^[ :stepMsg1 :stepMsg2 | 
		stepMsg1 scheduledTime <= stepMsg2 scheduledTime
	]! !

!WorldState methodsFor: 'hands' stamp: ''!
activeHand
	^ activeHand! !

!WorldState methodsFor: 'alarms' stamp: ''!
alarmSortBlock
	^[ :alarm1 :alarm2 | 
		alarm1 scheduledTime < alarm2 scheduledTime.
	]! !

!WorldState methodsFor: 'canvas' stamp: ''!
recordDamagedRect: damageRect

	damageRecorder ifNotNil: [damageRecorder recordInvalidRect: damageRect truncated]! !

!WorldState methodsFor: 'deferred message' stamp: ''!
defer: aValuable
	"aValuable will be executed in the next UI rendering cycle"
	self class defer: aValuable! !

!WorldState methodsFor: 'hands' stamp: ''!
activeHand: aHand
	activeHand := aHand! !

!WorldState methodsFor: 'alarms' stamp: ''!
triggerAlarmsBefore: nowTime
	"Trigger all pending alarms that are to be executed before nowTime."
	| pending |
	lastAlarmTime ifNil:[lastAlarmTime := nowTime].
	(nowTime < lastAlarmTime or:[nowTime - lastAlarmTime > 10000])
		ifTrue:[self adjustAlarmTimes: nowTime].
	pending := self alarms.
	[pending isEmpty not and:[pending first scheduledTime < nowTime]]
		whileTrue:[pending removeFirst value: nowTime].
	lastAlarmTime := nowTime.! !

!WorldState class methodsFor: 'world menu items' stamp: ''!
helpOn: aBuilder
	<worldMenu>
	(aBuilder item: #Help)
		order: 99;
		help: 'Some help tools on Pharo.';
		with: [
			(aBuilder group: #HelpBrowser)
				order: 1;
				withSeparatorAfter.
			(aBuilder group: #PharoHelp)
				order: 2;
				withSeparatorAfter.
			(aBuilder item: #'About...')
				order: 99;
				iconName: #smallInfo;
				help: 'Informations about this version of Pharo.';
				action: [ Smalltalk aboutThisSystem ] ]! !

!WorldState class methodsFor: 'drawing cycle' stamp: ''!
lastDrawCycleTime
	^ LastCycleTime ifNil: [ LastCycleTime := Time millisecondClockValue ]! !

!WorldState class methodsFor: 'settings' stamp: ''!
desktopMenuPragmaKeyword: aString
	DesktopMenuPragmaKeyword := aString! !

!WorldState class methodsFor: 'settings' stamp: ''!
showUpdateOptionInWorldMenu
	^ ShowUpdateOptionInWorldMenu ifNil: [ShowUpdateOptionInWorldMenu := true]! !

!WorldState class methodsFor: 'accessing' stamp: ''!
debugShowDamage
	^ DebugShowDamage ifNil: [DebugShowDamage := false]! !

!WorldState class methodsFor: 'deferred message' stamp: ''!
deferredUIMessages

	^DeferredUIMessages ifNil: [DeferredUIMessages := WaitfreeQueue  new].! !

!WorldState class methodsFor: 'accessing' stamp: ''!
lastCycleTime

	^LastCycleTime! !

!WorldState class methodsFor: 'world menu items' stamp: ''!
mostUsedToolsOn: aBuilder

	(aBuilder item: #Tools)
		withSeparatorAfter;
		order: 1! !

!WorldState class methodsFor: 'testing os' stamp: ''!
canSurrenderToOS: aBoolean

	CanSurrenderToOS := aBoolean! !

!WorldState class methodsFor: 'settings' stamp: ''!
desktopMenuPragmaKeyword
	"For compatibility with settings"
	
	^ self discoveredMenuPragmaKeyword! !

!WorldState class methodsFor: 'settings' stamp: ''!
serverMode: aBoolean
	(aBoolean = true or: [aBoolean = false or: [aBoolean isNil]])
		ifTrue: [ServerMode := aBoolean]! !

!WorldState class methodsFor: 'settings' stamp: ''!
showUpdateOptionInWorldMenu: aBoolean
	ShowUpdateOptionInWorldMenu := aBoolean! !

!WorldState class methodsFor: 'world menu items' stamp: ''!
saveSession
	Cursor write showWhile: [
		Smalltalk
			snapshot: true
			andQuit: false.
	]! !

!WorldState class methodsFor: 'settings' stamp: ''!
desktopMenuTitle: aString
	DesktopMenuTitle := aString! !

!WorldState class methodsFor: 'settings' stamp: ''!
worldMenuSettingOn: aBuilder
	<systemsettings>
	(aBuilder setting: #desktopMenuPragmaKeyword)
		label: 'World menu pragma';
		ghostHelp: 'worldMenu';
		parent: #morphic;
		default: 'worldMenu';
		target: self;
		description: 'Define whitch pragma should be used to build the world menu. To disable the world menu, leave this input empty.'! !

!WorldState class methodsFor: 'settings' stamp: ''!
worldStateDebuggingSettingsOn: aBuilder

	<systemsettings>
	(aBuilder group: #world)
		label: 'World state';
		parent: #debugging;
		description: 'World state debugging settings';
		with: [ 
			(aBuilder setting: #debugShowDamage)
				label: 'Flash damaged morphic region';
				target: WorldState;
				default: false;
				description:
					'If true, every changed region of the morphic display will be flashed black before updating.' ]! !

!WorldState class methodsFor: '*Morphic-Base' stamp: ''!
startMessageTally

	(self confirm: 'MessageTally will start now,
and stop when the cursor goes
to the top of the screen' translated) 
		ifFalse: [ ^ self ].

	TimeProfiler spyAllOn: [
		MorphicRenderLoop new doOneCycleWhile: [ 
			self currentWorld activeHand position y > 0 ] ]! !

!WorldState class methodsFor: 'drawing cycle' stamp: ''!
doDrawCycleWith: aBlock
	aBlock ensure: [
		self doInterCycleWait
	]! !

!WorldState class methodsFor: '*Morphic-Base' stamp: ''!
startThenBrowseMessageTally
	"Tally only the UI process"
	
	(self confirm: 'MessageTally the UI process until the
mouse pointer goes to the top of the screen')
		ifFalse: [ ^ self ].

	TimeProfiler onBlock: [
		MorphicRenderLoop new doOneCycleWhile: [ 
			self currentWorld activeHand position y > 10 ] ]! !

!WorldState class methodsFor: 'accessing' stamp: ''!
debugShowDamage: aBoolean
	DebugShowDamage := aBoolean! !

!WorldState class methodsFor: '*Morphic-Base' stamp: ''!
sourcesWorldMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #Sources)
		order: 50;
		help: 'Source Management Tools';
		with: [ 
			(aBuilder group: #Versioning)
				order: 1;
				withSeparatorAfter.
			(aBuilder group: #Packaging)
				order: 2;
				withSeparatorAfter.
			(aBuilder group: #Changes)
				order: 3;
				withSeparatorAfter.
			(aBuilder group: #Refactoring)
				order: 4 ]! !

!WorldState class methodsFor: 'deferred message' stamp: ''!
addDeferredUIMessage: aValuable
	"aValuable will be executed in the next UI rendering cycle"
	self deferredUIMessages nextPut: aValuable! !

!WorldState class methodsFor: 'settings' stamp: ''!
discoveredMenuTitle
	^ DesktopMenuTitle ifNil: [DesktopMenuTitle := 'World']! !

!WorldState class methodsFor: 'world menu items' stamp: ''!
screenShotCommandOn: aBuilder
	<worldMenu>
	(aBuilder item: #Screenshot)
		parent: #System;
		target: self currentWorld;
		order: 99;
		selector: #makeAScreenshot;
		label: 'Screenshot';
		help: 'Take a screenshot';
		iconName: #smallScreenshotIcon! !

!WorldState class methodsFor: 'settings' stamp: ''!
serverMode
	^ ServerMode ifNil: [ServerMode := false]! !

!WorldState class methodsFor: 'settings' stamp: ''!
discoveredMenuPragmaKeyword
	^ DesktopMenuPragmaKeyword ifNil: [DesktopMenuPragmaKeyword := 'worldMenu']! !

!WorldState class methodsFor: '*Morphic-Base' stamp: ''!
debugWorldMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #Debug)
		order: 30;
		with: [
			(aBuilder group: #Breakpoints)
				order: 1;
				withSeparatorAfter.
			(aBuilder group: #Profiling)
				order: 2;
				withSeparatorAfter.
			(aBuilder group: #Counters)
				order: 3]! !

!WorldState class methodsFor: 'class initialization' stamp: ''!
initialize
	"WorldState initialize"

	MinCycleLapse := 16.		"allows 60 frames per second..."
	DeferredUIMessages := nil.! !

!WorldState class methodsFor: '*Morphic-Base' stamp: ''!
browseWorldMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #Browse)
		order: 10;
		help: 'Tools to explore and modify the image';
		with: [ 
			(aBuilder group: #Browsing)
				order: 1;
				withSeparatorAfter.
			(aBuilder group: #InputOutput)
				order: 2;
				withSeparatorAfter.
			(aBuilder group: #Testing)
				order: 3;
				withSeparatorAfter.
			(aBuilder group: #Searching)
				order: 4]! !

!WorldState class methodsFor: 'accessing' stamp: ''!
MinCycleLapse: milliseconds
	"set the minimum amount of time that may transpire between two calls to doOneCycle"
	MinCycleLapse := milliseconds ifNotNil: [ milliseconds rounded ].! !

!WorldState class methodsFor: 'world menu items' stamp: ''!
pharoItemsOn: aBuilder
	<worldMenu>
	(aBuilder item: #Pharo)
		label: 'Pharo';
		icon: ((self iconNamed: #pharo) scaledToSize: 16 @ 16);
		order: 0;
		with: [
			(aBuilder group: #Saving)
				order: 98;
				with: [
					(aBuilder item: #Save)
						target: self;
						selector: #saveSession;
						help: 'Save the current version of the image on disk.';
						order: 1;
						keyText: 'S';
						iconName: #smallSaveIcon.
					(aBuilder item: #'Save as...')
						target: self;
						selector: #saveAs;
						help: 'Save the current version of the image on disk under a new name.';
						order: 2;
						iconName: #smallSaveAsIcon.
					(aBuilder item: #'Save and quit')
						target: self;
						selector: #saveAndQuit;
						help: 'Save the current image on disk, and quit Pharo.';
						order: 3;
						iconName: #smallQuitIcon.
					aBuilder	withSeparatorAfter ]. 
				(aBuilder item: #Quit)
					target: self;
					selector: #quitSession;
					help: 'Quit Pharo without saving the image on disk.';
					order: 99;
					iconName: #smallQuitIcon ]! !

!WorldState class methodsFor: '*Morphic-Base' stamp: ''!
systemOn: aBuilder
	<worldMenu>
	(aBuilder item: #System)
		order: 60;
		with: [
			(aBuilder group: #SystemTools)
				order: 1;
				withSeparatorAfter.
			(aBuilder group: #Startup)
				order: 2;
				withSeparatorAfter.
			(aBuilder group: #Image)
				order: 3;
				with: [
					(aBuilder item: #'Space left')
						help: 'Do a garbage collection, and report results about the to the user.';
						order: 1;
						action: [ Smalltalk informSpaceLeftAfterGarbageCollection ].
					(aBuilder item: #'Do Image Cleanup')
						help: 'Clean out any caches and other state that should be flushed when trying to get an image into a pristine state.';
						order: 2;
						action: [ Smalltalk cleanUp: true ].
					aBuilder 	withSeparatorAfter].
			(aBuilder group: #World)
				order: 4;
				with: [
					(aBuilder item: #'Start drawing again')
						help: 'Resume the drawing after a draw error of the world.';
						order: 1;
						action: [ self currentWorld resumeAfterDrawError ].
					(aBuilder item: #'Start stepping again')
						help: 'Resume stepping of Morph after an error has occured.';
						order: 2;
						action: [ self currentWorld resumeAfterStepError ].
					(aBuilder item: #'Restore display')
						help: 'Restore Morphic display.';
						order: 3;
						action: [ self currentWorld restoreMorphicDisplay ].
					aBuilder withSeparatorAfter ] ]! !

!WorldState class methodsFor: '*Morphic-Base' stamp: ''!
windowsOn: aBuilder
	<worldMenu>
	(aBuilder item: #Windows)
		order: 90;
		with: [ (aBuilder item: #'Collapse all windows')
				action: [ self currentWorld collapseAll ];
				help: 'Reduce all open windows to collapsed forms that only show titles' translated.
			(aBuilder item: #'Expand all windows')
				iconName: #expandBoxIcon;
				action: [ self currentWorld expandAll ];
				help: 'Expand all collapsed windows back to their expanded forms' translated.
			(aBuilder item: #'Fit all windows')
				action: [ self currentWorld fitAllVisibleWindows ];
				help: 'Fit all open windows as visible in World' translated.
			(aBuilder item: #'Close all debuggers')
				help: 'Close all opened debugger in the image.';
				action: [ OupsDebuggerSystem closeAllDebuggers ].
			(aBuilder item: #'Send top window to back (\)')
				action: [ SystemWindow sendTopWindowToBack ];
				help: 'Make the topmost window become the backmost one, and activate the window just beneath it.' translated.
			(aBuilder item: #'Move windows onscreen')
				action: [ self currentWorld bringWindowsFullOnscreen ];
				help: 'Make all windows fully visible on the screen' translated.
			(aBuilder item: #'Delete unchanged windows')
				action: [ self currentWorld closeUnchangedWindows ];
				help: 'Deletes all windows that do not have unsaved text edits.' translated.
			(aBuilder item: #'Delete all windows discarding edits')
				action: [ self currentWorld closeAllWindowsDiscardingChanges ];
				help: 'Deletes all windows even if they have unsaved text edits.' translated.
			(aBuilder item: #'Toggle full screen mode')
				action: [ Display toggleFullscreen ];
				help: 'Turn full screen mode on when it is off, off when it is on.' translated ]! !

!WorldState class methodsFor: 'accessing' stamp: ''!
theme
	^ Smalltalk ui theme! !

!WorldState class methodsFor: 'drawing cycle' stamp: ''!
interCycleLapse
	^ MinCycleLapse ifNil: [ MinCycleLapse := 16 ]! !

!WorldState class methodsFor: 'world menu items' stamp: ''!
saveAndQuit
	Cursor write showWhile: [
		Smalltalk snapshot: true andQuit: true
	]! !

!WorldState class methodsFor: 'settings' stamp: ''!
easySelectingWorld: aBoolean
	EasySelectingWorld := aBoolean! !

!WorldState class methodsFor: '*Morphic-Base' stamp: ''!
libraryWorldMenuOn: aBuilder
	<worldMenu>
	(aBuilder item: #Tools)
		label: 'Library';
		order: 70;
		help: 'Third party tools and applications'! !

!WorldState class methodsFor: 'deferred message' stamp: ''!
defer: aValuable
	"aValuable will be executed in the next UI rendering cycle"
	self addDeferredUIMessage: aValuable.! !

!WorldState class methodsFor: 'drawing cycle' stamp: ''!
doInterCycleWait
	| waitTime newCycleTime |
	newCycleTime := Time millisecondClockValue.
	waitTime := self serverMode
		ifTrue: [ 50 ]
		ifFalse: [
			| expectedEndTime lapse |
			lapse := self interCycleLapse.
			expectedEndTime := self lastDrawCycleTime + self interCycleLapse.
			"This minimum is required to prevent freezing the system during startup.
			The times two in the lapse is to allow some slack due to precision issues."
			expectedEndTime - newCycleTime min: (lapse*2).
		].
	waitTime > 0 ifTrue: [ (Delay forMilliseconds: waitTime) wait ].
	LastCycleTime := newCycleTime.! !

!WorldState class methodsFor: 'settings' stamp: ''!
easySelectingWorld
	^ EasySelectingWorld ifNil: [EasySelectingWorld := false]! !

!WorldState class methodsFor: 'world menu items' stamp: ''!
quitSession
	| response |
	response := UIManager default 
						confirm: 'Save changes before quitting?' 
						trueChoice: 'Save' 
						falseChoice: 'Discard' 
						cancelChoice: 'Cancel'
						default: nil. 
	response ifNil: [ ^self ].
	response 
		ifTrue: [Smalltalk snapshot: true andQuit: true] 
		ifFalse: [Smalltalk snapshot: false andQuit: true]! !

!WorldState class methodsFor: 'world menu items' stamp: ''!
saveAs
	| reference |
	reference := UIManager default
		chooseForSaveFileReference: 'Save Image as?'
		extensions: #('image') 
		path: Smalltalk imageFile nextVersion.

	reference ifNotNil: [ Smalltalk saveAs: reference parent / (reference basenameWithoutExtension: 'image') ]! !

!WrapperSignal commentStamp: ''!
This signal is useful to log an arbitrary object.

### Example:

```
TranscriptLogger new 
   runDuring: [ 42 asBeaconSignal emit ]
```	!
!WrapperSignal methodsFor: 'accessing' stamp: ''!
name

	^ 'Wrapper on ', self target class name! !

!WrapperSignal methodsFor: 'printing' stamp: ''!
printOneLineContentsOn: stream

	self target printOn: stream ! !

!WrapperSignal methodsFor: 'accessing' stamp: ''!
target

	^ target! !

!WrapperSignal methodsFor: 'accessing' stamp: ''!
target: anObject

	target := anObject! !

!WrapperSignal class methodsFor: 'instance creation' stamp: ''!
emit: aTargetObject

	^ (self on: aTargetObject) emit! !

!WrapperSignal class methodsFor: 'instance creation' stamp: ''!
on: aTargetObject

	^ self new
		  target: aTargetObject;
		  yourself! !

!WrapperSignalTest methodsFor: 'tests' stamp: ''!
testAsBeaconSignalDoesNotAffectAnExistingSignal
	| signal |
	signal := StringSignal new.
	self assert: signal asBeaconSignal equals: signal! !

!WrapperSignalTest methodsFor: 'tests' stamp: ''!
testAsBeaconSignalTransformsIntoWrapperSignal
	self assert: (42 asBeaconSignal isKindOf: WrapperSignal).
	self assert: 42 asBeaconSignal target equals: 42.
! !

!WriteBarrierAnotherStub commentStamp: ''!
Another stub for WriteBarrier to be used by tests!
!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var10
	^ var10! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var5

	^ var5! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var2

	^ var2! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var7

	^ var7! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var10: anObject
	var10 := anObject! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var1
	^ var1! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var8

	^ var8! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var3

	^ var3! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var4

	^ var4! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var1: anObject
	var1 := anObject! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var6

	^ var6! !

!WriteBarrierAnotherStub methodsFor: 'accessing' stamp: ''!
var9

	^ var9! !

!WriteBarrierStub commentStamp: ''!
A stub for WriteBarrier to be used by tests!
!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var10
	^ var10! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var5

	^ var5! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var2

	^ var2! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var7

	^ var7! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var10: anObject
	var10 := anObject! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var1
	^ var1! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var8

	^ var8! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var3

	^ var3! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var4

	^ var4! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var1: anObject
	var1 := anObject! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var6

	^ var6! !

!WriteBarrierStub methodsFor: 'accessing' stamp: ''!
var9

	^ var9! !

!WriteBarrierTest commentStamp: ''!
My tests ensure the ReadOnly property of objects work properly.

#testMutateIVObject is a good start to understand what is going on.

The VM needs to be compiled with -DIMMUTABILTY= true for those tests to work.!
!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateWideStringUsingWordAtPut
	| guineaPig |
	guineaPig := 'hello' asWideString.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig wordAt: 1 put: 65536  ]
		raise: ModificationForbidden.
		
	[ guineaPig wordAt: 1 put: 65536 ] 
		on: ModificationForbidden 
		do: [:modification | 
			self assert: modification fieldIndex equals: 1.
			modification object beWritableObject.
			modification retryModification ].

	self assert: guineaPig first asciiValue equals: 65536! !

!WriteBarrierTest methodsFor: 'guinea pigs' stamp: ''!
maybeReadOnlyObjects
	"ByteObject, Variable object, fixed sized object"
	^ { { 1 . 2 . 3 } asByteArray . { 1 . 2 . 3 } . (MessageSend receiver: 1 selector: #+ argument: 2) }! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateObjectLastInstVarWithManyVars
	| guineaPig failure |
	guineaPig := WriteBarrierStub new.
	guineaPig beReadOnlyObject.
	failure := [ guineaPig var10: #test ] on: ModificationForbidden do: [:err | err].

	self assert: failure fieldIndex equals: 10! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateObjectInstVarUsingBasicAtPut
	| guineaPig |
	guineaPig := Array new: 5.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig basicAt: 1 put: #test  ]
		raise: ModificationForbidden.
		
	[ guineaPig at: 1 put: #test ] 
		on: ModificationForbidden 
		do: [:modification | 
			self assert: modification fieldIndex equals: 1.
			modification object beWritableObject.
			modification retryModification ].

	self assert: guineaPig first equals: #test! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateByteArrayUsingByteAtPut
	| guineaPig |
	guineaPig := ByteArray new: 5.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig byteAt: 1 put: 12  ]
		raise: ModificationForbidden.
		
	[ guineaPig byteAt: 1 put: 12 ] 
		on: ModificationForbidden 
		do: [:modification | 
			self assert: modification fieldIndex equals: 1.
			modification object beWritableObject.
			modification retryModification ].

	self assert: guineaPig first equals: 12! !

!WriteBarrierTest methodsFor: 'tests - proxy' stamp: ''!
testBasicProxyReadOnly
	self alwaysReadOnlyObjects do: [ :each |
		self assert: (MirrorPrimitives isObjectReadOnly: each) equals: true ]! !

!WriteBarrierTest methodsFor: 'tests - proxy' stamp: ''!
testBasicProxyWritable
	self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each |
		self assert: (MirrorPrimitives isObjectReadOnly: each) equals: false ]! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateByteStringyUsingAtPut
	| guineaPig |
	guineaPig := ByteString new: 5.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig at: 1 put: $h  ]
		raise: ModificationForbidden.
		
	[ guineaPig at: 1 put: $h ] 
		on: ModificationForbidden 
		do: [:modification | 
			self assert: modification fieldIndex equals: 1.
			modification object beWritableObject.
			modification retryModification ].

	self assert: guineaPig first equals: $h! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateObjectInstVarUsingInstVarAtPut
	| guineaPig |
	guineaPig := WriteBarrierStub new.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig instVarAt: 1 put: #test  ]
		raise: ModificationForbidden.
		
	[ guineaPig instVarAt: 1 put: #test ] 
		on: ModificationForbidden 
		do: [:modification | 
			self assert: modification fieldIndex equals: 1.
			modification object beWritableObject.
			modification retryModification ].

	self assert: guineaPig var1 equals: #test! !

!WriteBarrierTest methodsFor: 'tests - proxy' stamp: ''!
testSetIsReadOnlyImmediateProxy
	self alwaysReadOnlyObjects do: [ :each |
		self 
			testProxyObject: each 
			initialState: true 
			tuples: #( (true true true) (false true true) ) ]! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testReadOnlyImmediate
	"immediate objects like SmallIntegers are read only"
	self assert: 1 isReadOnlyObject.
	"we can call beReadOnlyObject on an immediate object"
	self assert: 1 beReadOnlyObject.! !

!WriteBarrierTest methodsFor: 'guinea pigs' stamp: ''!
alwaysReadOnlyObjects
	"Immediates are always immutable"
	^ { 1 }! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateByteArrayUsingDoubleAtPut
	| guineaPig |
	<expectedFailure>
	guineaPig := ByteArray new: 8.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig doubleAt: 1 put: (2 raisedTo: 65) asFloat ]
		raise: ModificationForbidden.
		
	[ guineaPig doubleAt: 1 put: (2 raisedTo: 65) asFloat ] 
		on: ModificationForbidden 
		do: [:modification | 
			self assert: modification fieldIndex equals: 1.
			modification object beWritableObject.
			modification retryModification ].

	self assert: guineaPig first equals: (2 raisedTo: 65) asFloat! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testRetryingInstVarModification
	| guineaPig |
	guineaPig := MessageSend new.
	guineaPig beReadOnlyObject.

	[ guineaPig receiver: 1 ] on: ModificationForbidden do: [:err | 
		guineaPig beWritableObject.
		err retryModification ].

	self assert: guineaPig receiver equals: 1! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateByteSymbolUsingPrivateAtPut
	| guineaPig |
	guineaPig := #hello.
	"symbol literals are read-only already, no need to call #beReadOnlyObject"
	self 
		should: [ guineaPig privateAt: 1 put: $q  ]
		raise: ModificationForbidden.
	
	self assert: guineaPig first equals: $h! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateByteStringyUsingByteAtPut
	| guineaPig |
	guineaPig := ByteString new: 5.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig byteAt: 1 put: 100  ]
		raise: ModificationForbidden.
		
	[ guineaPig byteAt: 1 put: 100 ] 
		on: ModificationForbidden 
		do: [:modification | 
			self assert: modification fieldIndex equals: 1.
			modification object beWritableObject.
			modification retryModification ].

	self assert: guineaPig first asciiValue equals: 100! !

!WriteBarrierTest methodsFor: 'tests - proxy' stamp: ''!
testSetIsReadOnlyFailureProxy
	self alwaysWritableObjects do: [ :each |
		self 
			testProxyObject: each 
			initialState: false 
			tuples: #( (true false false) (false false false) ) ]! !

!WriteBarrierTest methodsFor: 'tests - helper' stamp: ''!
testObject: object initialState: initialState tuples: tuples
	self 
		testObject: object 
		initialState: initialState 
		tuples: tuples 
		setReadOnlyBlock: [ :value | object setIsReadOnlyObject: value ]! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testSetIsReadOnlyFailure
	self alwaysWritableObjects do: [ :each |
		self 
			testObject: each 
			initialState: false 
			tuples: #( (true false false) (false false false) ) ]! !

!WriteBarrierTest methodsFor: 'tests - helper' stamp: ''!
testObject: object initialState: initialState tuples: tuples setReadOnlyBlock: setImmutabilityBlock
	self assert: object isReadOnlyObject equals: initialState.
	tuples do: [ :tuple |
		| stateToSet expectedResult expectedNewState |
		stateToSet := tuple first.
		expectedResult := tuple second.
		expectedNewState := tuple last.
		[self assert: (setImmutabilityBlock value: stateToSet) equals: expectedResult ]
				on: PrimitiveFailed 
				do: [ self assert: (self alwaysReadOnlyObjects , self alwaysWritableObjects includes: object) ].
		self assert: object isReadOnlyObject equals: expectedNewState ]! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateObjectFirstInstVarWithManyVars
	| guineaPig failure |
	guineaPig := WriteBarrierStub new.
	guineaPig beReadOnlyObject.
	failure := [ guineaPig var1: #test ] on: ModificationForbidden do: [:err | err].

	self assert: failure fieldIndex equals: 1! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateWideStringUsingAtPut
	| guineaPig |
	guineaPig := 'hello' asWideString.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig at: 1 put: $q  ]
		raise: ModificationForbidden.
		
	[ guineaPig at: 1 put: $q ] 
		on: ModificationForbidden 
		do: [:modification | 
			self assert: modification fieldIndex equals: 1.
			modification object beWritableObject.
			modification retryModification ].

	self assert: guineaPig first equals: $q! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testBasicReadOnly
	self alwaysReadOnlyObjects do: [ :each |
		self assert: each isReadOnlyObject equals: true ]! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateObjectClass
	| guineaPig |
	guineaPig := WriteBarrierStub new.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig primitiveChangeClassTo: WriteBarrierAnotherStub  new ]
		raise: ModificationForbidden.
		
	[ guineaPig primitiveChangeClassTo: WriteBarrierAnotherStub  new ]
		on: ModificationForbidden 
		do: [ :modification |
			modification object beWritableObject.
			modification retryModification  ].
	
	self assert: guineaPig class equals: WriteBarrierAnotherStub! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testSetIsReadOnlySuccess
	self maybeReadOnlyObjects do: [ :each |
		self 
			testObject: each 
			initialState: false 
			tuples: #( (true false true) (false true false) ) ]! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateObjectInstVarUsingAtPut
	| guineaPig |
	guineaPig := Array new: 5.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig at: 1 put: #test  ]
		raise: ModificationForbidden.
		
	[ guineaPig at: 1 put: #test ] 
		on: ModificationForbidden 
		do: [:modification | 
			self assert: modification fieldIndex equals: 1.
			modification object beWritableObject.
			modification retryModification ].

	self assert: guineaPig first equals: #test! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateIVObject
	| guineaPig |
	guineaPig := MessageSend new.
	guineaPig beReadOnlyObject.
	[ guineaPig receiver: 1 ]
		on: ModificationForbidden
		do: [ :modification | "Surely a NoModification error" ].
	guineaPig
		beWritableObject;
		selector: #+;
		beReadOnlyObject.
	[ guineaPig arguments: #(2) ]
		on: ModificationForbidden
		do: [ :modification | "Surely a NoModification error" ].
	self assert: guineaPig receiver isNil.
	self assert: guineaPig arguments isNil.
	self assert: guineaPig selector identicalTo: #+! !

!WriteBarrierTest methodsFor: 'tests - proxy' stamp: ''!
testSetIsReadOnlySuccessProxy
	self maybeReadOnlyObjects do: [ :each |
		self 
			testProxyObject: each 
			initialState: false 
			tuples: #( (true false true) (false true false) ) ]! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateWideSymbolUsingPrivateAtPut
	| guineaPig |
	[ guineaPig := ('hello', (Character codePoint: 8002) asString) asSymbol.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig privateAt: 1 put: 65  ]
		raise: ModificationForbidden ]
		ensure: [ guineaPig beWritableObject ].

	self assert: guineaPig first  equals: $h! !

!WriteBarrierTest methodsFor: 'guinea pigs' stamp: ''!
alwaysWritableObjects
	"Objects that currently can't be immutable"
	^ { ContextInstance . 
		Processor . 
		Processor activeProcess }! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateByteArrayUsingFloatAtPut
	<expectedFailure>
	| guineaPig |
	guineaPig := ByteArray new: 5.
	guineaPig beReadOnlyObject.
	
	self 
		should: [ guineaPig floatAt: 1 put: 1.0  ]
		raise: ModificationForbidden.
		
	[ guineaPig floatAt: 1 put: 1.0 ] 
		on: ModificationForbidden 
		do: [:modification | 
			self assert: modification fieldIndex equals: 1.
			modification object beWritableObject.
			modification retryModification ].

	self assert: guineaPig first equals: 1.0! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateObjectInstVarShouldCatchRightFailure
	| guineaPig failure |
	guineaPig := MessageSend new.
	guineaPig beReadOnlyObject.
	failure := [ guineaPig receiver: #test ]
		on: ModificationForbidden
		do: [ :err | err ].

	self assert: failure object identicalTo: guineaPig.
	self assert: failure newValue equals: #test.
	self assert: failure fieldIndex equals: 1! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testMutateVariableObject
	| guineaPigs |
	guineaPigs := {#[1 2 3] copy . #(1 2 3) copy}.
	guineaPigs
		do: [ :guineaPig | 
			guineaPig beReadOnlyObject.
			[ guineaPig at: 1 put: 4 ]
				on: ModificationForbidden
				do: [ "Surely a NoModification error" ].
			guineaPig
				beWritableObject;
				at: 2 put: 5;
				beReadOnlyObject.
			[ guineaPig at: 3 put: 6 ]
				on: ModificationForbidden
				do: [ "Surely a NoModification error" ].
			self assert: guineaPig first equals: 1.
			self assert: guineaPig second equals: 5.
			self assert: guineaPig third equals: 3 ]! !

!WriteBarrierTest methodsFor: 'tests - helper' stamp: ''!
testProxyObject: object initialState: initialState tuples: tuples
	self 
		testObject: object 
		initialState: initialState 
		tuples: tuples 
		setReadOnlyBlock: [ :value | 
			MirrorPrimitives makeObject: object readOnly: value ]! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testSetIsReadOnlyImmediate
	self alwaysReadOnlyObjects do: [ :each |
		self 
			testObject: each 
			initialState: true 
			tuples: #( (true true true) (false true true) ) ]! !

!WriteBarrierTest methodsFor: 'tests - object' stamp: ''!
testBasicWritable
	self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each |
		self assert: each isReadOnlyObject equals: false ]! !

!WriteBarrierTest class methodsFor: 'class initialization' stamp: ''!
initialize
	
	ContextInstance := Context sender: nil receiver: self new method: self >> #alwaysWritableObjects arguments: #()! !

!WriteBarrierTest class methodsFor: 'cleanup' stamp: ''!
restartMethods
   self initialize! !

!WriteOnceSlot commentStamp: ''!
A slot on which one can write only once.!
!WriteOnceSlot methodsFor: 'initialization' stamp: ''!
wantsInitialization

	^ true! !

!WriteOnceSlot methodsFor: 'meta-object-protocol' stamp: ''!
read: anObject
	^ (super read: anObject) key! !

!WriteOnceSlot methodsFor: 'testing' stamp: ''!
isWritten: anObject
	^ (super read: anObject) value! !

!WriteOnceSlot methodsFor: 'meta-object-protocol' stamp: ''!
write: aValue to: anObject

	^(self isWritten: anObject)
		ifTrue: [ (super read: anObject) key: aValue value: false. aValue ]
		ifFalse: [ self error: 'only one assignment allowed' ]! !

!WriteOnceSlot methodsFor: 'initialization' stamp: ''!
initialize: anObject
	super write: nil -> true to: anObject! !

!WriteOnceSlotTest commentStamp: ''!
Automated tests for WriteOnceSlot!
!WriteOnceSlotTest methodsFor: 'tests' stamp: ''!
testWriteAndRead
	| slot object |
	slot := #slot1 => WriteOnceSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	"now compile an accessor and read"
	self compileAccessorsFor: slot.
	object := aClass new.
	self assert: object slot1 equals: nil.
	object slot1: 3.
	self assert: object slot1 equals: 3! !

!WriteOnceSlotTest methodsFor: 'tests' stamp: ''!
testRead
	| slot |
	slot := #slot1 => WriteOnceSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	"now compile an accessor and read"
	self compileAccessorsFor: slot.
	self assert: aClass new slot1 equals: nil! !

!WriteOnceSlotTest methodsFor: 'tests' stamp: ''!
testWriteTwice
	| slot object |
	slot := #slot1 => WriteOnceSlot.
	aClass := self make: [ :builder | builder slots: {slot} ].

	"now compile an accessor and read"
	self compileAccessorsFor: slot.
	object := aClass new.
	self assert: object slot1 equals: nil.
	"write first time"
	object slot1: 3.
	self assert: object slot1 equals: 3.
	"second write is error"
	self should: [ object slot1: 27 ] raise: Error! !

!WriteStream commentStamp: ''!
I represent an accessor for a sequence of objects that can only store objects in the sequence.!
!WriteStream methodsFor: 'positioning' stamp: ''!
setToEnd 
	"Refer to the comment in PositionableStream|setToEnd."

	readLimit := readLimit max: position.
	super setToEnd.! !

!WriteStream methodsFor: 'private' stamp: ''!
pastEndPut: anObject
	"Grow the collection by doubling the size, but keeping the growth between 20 and 1000000.
	Then put <anObject> at the current write position."

	collection := collection grownBy: ((collection size max: 20) min: 1000000).
	writeLimit := collection size.
	collection at: (position := position + 1) put: anObject.
	^ anObject! !

!WriteStream methodsFor: 'accessing' stamp: ''!
peekLast
	"Return that item just put at the end of the stream"

	^ position > 0 
		ifTrue: [collection at: position]
		ifFalse: [nil]! !

!WriteStream methodsFor: 'initialization' stamp: ''!
with: aCollection from: firstIndex to: lastIndex
	self with: (aCollection copyFrom: firstIndex to: lastIndex)! !

!WriteStream methodsFor: 'character writing' stamp: ''!
lf
	"Append a line feed character to the receiver."

	self nextPut: Character lf! !

!WriteStream methodsFor: '*CodeExport' stamp: ''!
timeStamp
	"Append the current time to the receiver as a String."
	self nextChunkPut:	"double string quotes and !!s"
		(String streamContents: [:s | Smalltalk timeStamp: s]) printString.
	self cr! !

!WriteStream methodsFor: 'private' stamp: ''!
growTo: anInteger
 
    " anInteger is the required minimal new size of the collection "
 	| oldSize length |
 	oldSize := collection size.
      length := anInteger + (oldSize // 4 max: 20) - oldSize.
 	collection := collection grownBy: length.
 	writeLimit := collection size.! !

!WriteStream methodsFor: 'private' stamp: ''!
braceArray: anArray
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	collection := anArray.
	position := 0.
	readLimit := 0.
	writeLimit := anArray size.! !

!WriteStream methodsFor: 'character writing' stamp: ''!
ensureNoSpace
	"If there is not one on the end, remove it."
	| space |
	
	space := Character space.
	
	[ position > 0 and: [(collection at: position) = space ]]
		whileTrue: [ self skip: -1 ]! !

!WriteStream methodsFor: 'positioning' stamp: ''!
position: anInteger 
	"Refer to the comment in PositionableStream|position:."

	readLimit := readLimit max: position.
	super position: anInteger! !

!WriteStream methodsFor: 'printing' stamp: ''!
store: anObject 
	"Have anObject print on the receiver for purposes of rereading."

	anObject storeOn: self! !

!WriteStream methodsFor: 'accessing' stamp: ''!
next: anInteger putAll: aCollection startingAt: startIndex
	"Store the next anInteger elements from the given collection."

	| newEnd numPut |
	collection class == aCollection class ifFalse:
		[^ super next: anInteger putAll: aCollection startingAt: startIndex ].

	numPut := anInteger min: (aCollection size - startIndex + 1).
	newEnd := position + numPut.
	newEnd > writeLimit ifTrue:
		[^ super next: anInteger putAll: aCollection startingAt: startIndex "Trigger normal pastEndPut: logic"].

	collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: startIndex.
	position := newEnd.! !

!WriteStream methodsFor: 'positioning' stamp: ''!
resetToStart
	readLimit := position := 0.! !

!WriteStream methodsFor: 'character writing' stamp: ''!
tab
	"Append a tab character to the receiver."

	self nextPut: Character tab! !

!WriteStream methodsFor: 'accessing' stamp: ''!
nextPut: anObject
	"Primitive. Insert the argument at the next position in the Stream
	represented by the receiver. Fail if the collection of this stream is not an
	Array or a String. Fail if the stream is positioned at its end, or if the
	position is out of bounds in the collection. Fail if the argument is not
	of the right type for the collection. Optional. See Object documentation
	whatIsAPrimitive."

	^ position >= writeLimit
		ifTrue: [ self pastEndPut: anObject ]
		ifFalse: [ position := position + 1.
			collection at: position put: anObject ]! !

!WriteStream methodsFor: 'accessing' stamp: ''!
contents

	readLimit := readLimit max: position.
	^collection copyFrom: 1 to: position! !

!WriteStream methodsFor: 'private' stamp: ''!
braceArray
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	^ collection! !

!WriteStream methodsFor: 'initialization' stamp: ''!
on: aCollection from: firstIndex to: lastIndex

	| len |
	collection := aCollection.
	readLimit := 
		writeLimit := lastIndex > (len := collection size)
						ifTrue: [len]
						ifFalse: [lastIndex].
	position := firstIndex <= 1
				ifTrue: [0]
				ifFalse: [firstIndex - 1]! !

!WriteStream methodsFor: 'initialization' stamp: ''!
reset 
	"Refer to the comment in PositionableStream|reset."

	readLimit := readLimit max: position.
	position := 0! !

!WriteStream methodsFor: 'private' stamp: ''!
withAttribute: att do: strmBlock 
	"No-op here is overriden in TextStream for font emphasis"
	^ strmBlock value! !

!WriteStream methodsFor: 'character writing' stamp: ''!
tab: anInteger 
	"Append anInteger tab characters to the receiver."
	
	self next: anInteger put: Character tab! !

!WriteStream methodsFor: 'accessing' stamp: ''!
next

	self shouldNotImplement! !

!WriteStream methodsFor: 'private' stamp: ''!
withAttributes: attributes do: strmBlock 
	"No-op here is overriden in TextStream for font emphasis"
	^ strmBlock value! !

!WriteStream methodsFor: 'accessing' stamp: ''!
ensureEndsWith: anObject
	"Append anObject to the receiver IFF it is non-empty and there is not one on the end."

	(position == 0 or: [(collection at: position) = anObject]) ifTrue: [^self].
	self nextPut: anObject! !

!WriteStream methodsFor: 'initialization' stamp: ''!
on: aCollection

	super on: aCollection.
	readLimit := 0.
	writeLimit := aCollection size! !

!WriteStream methodsFor: 'character writing' stamp: ''!
space: anInteger 
	"Append anInteger space characters to the receiver."
	
	self next: anInteger put: Character space! !

!WriteStream methodsFor: 'character writing' stamp: ''!
space
	"Append a space character to the receiver."

	self nextPut: Character space! !

!WriteStream methodsFor: 'character writing' stamp: ''!
crtab
	"Append a return character, followed by a single tab character, to the 
	receiver."

	self cr; tab! !

!WriteStream methodsFor: 'accessing' stamp: ''!
size

	^readLimit := readLimit max: position! !

!WriteStream methodsFor: 'accessing' stamp: ''!
<< anObject
	"Write anObject to the receiver, dispatching using #putOn:
	This is a shortcut for both nextPut: and nextPutAll: since anObject can be both
	the element type of the receiver as well as a collection of those elements.
	No further conversions of anObject are applied.
	This is an optimisation.
	Return self to accomodate chaining."

 	anObject class == collection class
		ifTrue: [ self nextPutAll: anObject ]
		ifFalse: [ anObject putOn: self ]! !

!WriteStream methodsFor: 'character writing' stamp: ''!
crtab: anInteger 
	"Append a return character, followed by anInteger tab characters, to the 
	receiver."

	self cr; tab: anInteger! !

!WriteStream methodsFor: '*Fuel-Core' stamp: ''!
nextBytesPutAll: aCollection
	"Append the bytes of aCollection to the sequence of bytes accessible 
	by the receiver. Answer aCollection."
 
 	| newEnd |
 	collection class instSpec == aCollection class instSpec ifFalse:
 		[^ super nextPutAll: aCollection ].
 
 	newEnd := position + aCollection size.
 	newEnd > writeLimit ifTrue:
 		[self growTo: newEnd + 10].
 
 	collection replaceFrom: position+1 to: newEnd  with: aCollection startingAt: 1.
 	position := newEnd.
	
	^ aCollection! !

!WriteStream methodsFor: 'character writing' stamp: ''!
ensureASpace
	"Append a space character to the receiver IFF there is not one on the end."

	(position > 0 and: [(collection at: position) = Character space]) ifTrue: [^self].
	self nextPut: Character space! !

!WriteStream methodsFor: 'character writing' stamp: ''!
ensureCr
	"Append a cr character to the receiver IFF there is not one on the end."

	self ensureEndsWith: Character cr! !

!WriteStream methodsFor: 'initialization' stamp: ''!
with: aCollection

	super on: aCollection.
	position := readLimit := writeLimit := aCollection size! !

!WriteStream methodsFor: 'accessing' stamp: ''!
crlf
	"Append a line feed character to the receiver."

	self cr; lf! !

!WriteStream methodsFor: 'accessing' stamp: ''!
nextPutAll: aCollection
 
 	| newEnd |
 	collection class == aCollection class ifFalse:
 		[^ super nextPutAll: aCollection ].
 
 	newEnd := position + aCollection size.
 	newEnd > writeLimit ifTrue:
 		[self growTo: newEnd + 10].
 
 	collection replaceFrom: position+1 to: newEnd  with: aCollection startingAt: 1.
 	position := newEnd.
	
	^ aCollection! !

!WriteStream methodsFor: '*CodeExport' stamp: ''!
nextChunkPut: aString
	"Append the argument, aString, to the receiver, doubling embedded !! terminators and adding a extra one"
 
	| string start bangIndex |
	string := aString asString.
	start := 1.
	[ (bangIndex := string indexOf: $!! startingAt: start) = 0 ]
		whileFalse: [
			self next: bangIndex - start + 1 putAll: string startingAt: start.
			self nextPut: $!!. "double it"
			start := bangIndex + 1 ].
	self next: string size - start + 1 putAll: string startingAt: start.
	self nextPut: $!!. "one extra"
	self flush! !

!WriteStream methodsFor: 'character writing' stamp: ''!
cr
	"Append a return character to the receiver."

	self nextPut: Character cr! !

!WriteStream class methodsFor: 'instance creation' stamp: ''!
with: aCollection 
	"Answer an instance of me on the argument, aCollection, positioned to 
	store objects at the end of aCollection."

	^self basicNew with: aCollection! !

!WriteStream class methodsFor: 'instance creation' stamp: ''!
with: aCollection from: firstIndex to: lastIndex 
	"Answer an instance of me on the subcollection of the argument, 
	aCollection, determined by the indices firstIndex and lastIndex. Position 
	the instance to store at the end of the subcollection."

	^self basicNew
		with: aCollection
		from: firstIndex
		to: lastIndex! !

!WriteStreamTest commentStamp: ''!
A trait for test purposes!
!WriteStreamTest methodsFor: 'tests' stamp: ''!
testNextPutAll
	| stream |
	stream := self newStream.
	self
		assert: (stream nextPutAll: self string) equals: self string;
		assert: stream position equals: self stringSize;
		assert: stream contents equals: self string! !

!WriteStreamTest methodsFor: 'instance creation' stamp: ''!
newStreamOn: aCollection
	^ self streamClass on: aCollection! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testEnsureASpace
	| stream |
	stream := self newStream.
	stream nextPutAll: 'this is a test'.
	stream ensureASpace.
	stream nextPutAll: 'for WriteStreamTest'.
	self assert: stream contents equals: 'this is a test for WriteStreamTest'.

	"Manually put a space and verify there are no 2 consecutive spaces"
	stream := self newStream.
	stream nextPutAll: 'this is a test '.
	stream ensureASpace.
	stream nextPutAll: 'for WriteStreamTest'.
	self assert: stream contents equals: 'this is a test for WriteStreamTest'! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testWithFromTo
	"like with: except it paritions its argument collection first using the
	from:/to: indexes"

	| stream |
	stream := self streamClass with: self string , self string from: 1 to: self stringSize.
	self
		assert: stream originalContents equals: self string;
		assert: stream position equals: self stringSize;
		assert: stream contents equals: self string;
		assert: stream size equals: self stringSize! !

!WriteStreamTest methodsFor: 'accessing' stamp: ''!
streamClass
	^ WriteStream! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testEnsureNoSpace
	 
	| stream |
	stream := self newStream.
	stream ensureNoSpace.
	
	self assert: stream contents equals: ''.
	
	stream nextPutAll: ' a '.
	stream ensureNoSpace.
	self assert: stream contents equals: ' a'.
	
	stream nextPutAll: 'b  '.
	stream ensureNoSpace.
	self assert: stream contents equals: ' ab'.! !

!WriteStreamTest methodsFor: 'accessing' stamp: ''!
string
	^ 'testing'! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testWith
	"like on: except it starts writing at the end of its argument collection,
	and the initial position is the collection size and the initial contents
	is the collection"

	| stream |
	stream := self streamClass with: self string.
	self
		assert: stream originalContents equals: self string;
		assert: stream position equals: self stringSize;
		assert: stream contents equals: self string;
		assert: stream size equals: self stringSize! !

!WriteStreamTest methodsFor: 'accessing' stamp: ''!
stringSize
	^ self string size! !

!WriteStreamTest methodsFor: 'instance creation' stamp: ''!
newStream
	^ self newStreamOn: String new! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testSetToEnd
	| stream |
	stream := self newStream.
	self
		assert: stream setToEnd identicalTo: stream;
		assert: stream position isZero;
		assert: stream contents isEmpty.
	stream nextPutAll: self string.
	self stringSize - 1 to: 0 by: -1 do: [ :i | 
		stream position: i.
		self
			assert: stream setToEnd identicalTo: stream;
			assert: stream position equals: self stringSize;
			assert: stream contents equals: self string ]! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testOn
	| collection stream |
	collection := String new.
	stream := self streamClass on: collection.
	self
		assert: stream originalContents identicalTo: collection;
		assert: stream position isZero;
		assert: stream contents isEmpty;
		assert: stream size isZero! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testOnFromTo
	| stream |
	stream := self streamClass on: self string , self string from: self stringSize + 1 to: self stringSize * 2.
	self
		assert: stream originalContents equals: self string , self string;
		assert: stream position equals: self stringSize;
		assert: stream contents equals: self string;
		assert: stream size equals: self stringSize * 2! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testPosition
	| stream |
	stream := self newStream.
	stream nextPutAll: self string.
	0 to: self stringSize do: [ :i | 
		self
			assert: stream position equals: self stringSize;
			assert: (stream position: i) identicalTo: stream;
			assert: stream position equals: i;
			assert: stream contents equals: (self string first: i).
		stream position: self stringSize ].
	self should: [ stream position: -1 ] raise: Error.
	self should: [ stream position: self stringSize + 1 ] raise: Error! !

!WriteStreamTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ self streamClass! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testEnsureASpace2
	| stream |
	stream := self newStream.
	stream ensureASpace.
	self assert: stream contents equals: ' '! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testIsEmpty
	| stream |
	stream := self newStream.
	self assert: stream isEmpty.
	stream nextPut: $a.
	self deny: stream isEmpty.
	stream reset.
	self deny: stream isEmpty.! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testNextPut
	| stream |
	stream := self newStream.
	self string
		withIndexDo: [ :each :i | 
			self
				assert: (stream nextPut: each) equals: each;
				assert: stream position equals: i;
				assert: stream contents equals: (self string first: i) ]! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testEnsureEndsWith
	
	| stream |
	stream := self newStream.
	stream nextPutAll: 'this is a test'.
	stream ensureEndsWith: Character cr.
	stream nextPutAll: 'for WriteStreamTest'.
	self assert: stream contents equals: (('this is a test' copyWith: Character cr), 'for WriteStreamTest').
	
	"Manually put a new line and verify there are no 2 new lines"
	stream := self newStream.
	stream nextPutAll: ('this is a test' copyWith: Character cr).
	stream ensureEndsWith: Character cr.
	stream nextPutAll: 'for WriteStreamTest'.
	self assert: stream contents equals: (('this is a test' copyWith: Character cr), 'for WriteStreamTest').
	
	"Test with a empty stream"
	stream := self newStream.
	stream ensureEndsWith: Character cr.
	self assert: stream contents equals: ''.! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testNew

	self should: [self streamClass new] raise: Error.! !

!WriteStreamTest methodsFor: 'tests' stamp: ''!
testLessThanLessThan
	"Tests for #<< output operator shortcut on WriteStreams"
	
	self 
		assert: (String streamContents: [ :out | out << $a << 'bcd' << $e ])
		equals: 'abcde'.
	self 
		assert: (ByteArray streamContents: [ :out | out << 1 << #[2 3 4] << 5 ])
		equals: #[1 2 3 4 5].
	self 
		assert: (Array streamContents: [ :out | out << 1 << #(2 3 4) asOrderedCollection << 5 ])
		equals: #(1 2 3 4 5).
	"no conversions, wrong element type"
	self should: [ String streamContents: [ :out | out << 1234 ] ] raise: Error.
	self should: [ ByteArray streamContents: [ :out | out << 1234 ] ] raise: Error! !

!WriteStreamTest class methodsFor: 'testing' stamp: ''!
shouldInheritSelectors
	^ true! !

!Year commentStamp: ''!
I represent a year.!
!Year methodsFor: 'accessing' stamp: ''!
daysInYear

	^ self duration days.! !

!Year methodsFor: 'changes' stamp: ''!
previous
	"This implementation handles leap years correctly"
	
	^ self class year: (self year - 1)! !

!Year methodsFor: 'accessing' stamp: ''!
firstThursday
	"Return the year's first Thursday.
	According to the ISO 8601 definition, the first week starts with the year's first Thursday (week day number 5)"
	^ self start + ((5 - self start dayOfWeek + 7) rem: 7) days! !

!Year methodsFor: 'accessing' stamp: ''!
daysInMonth 

	^ Date daysInMonth! !

!Year methodsFor: 'private' stamp: ''!
species

	^Timespan! !

!Year methodsFor: 'printing' stamp: ''!
printOn: aStream

	aStream nextPutAll: 'a Year ('.
 	self start year printOn: aStream. 
	aStream nextPutAll: ')'.! !

!Year methodsFor: 'converting' stamp: ''!
asYear 

	^ self! !

!Year methodsFor: 'accessing' stamp: ''!
daysInMonth: aMonthNumber 
    "Returns the days in month for a given month in the context of the receiver"

    ^ (DateAndTime year: self year month: aMonthNumber day:1) asMonth daysInMonth! !

!Year class methodsFor: 'instance creation' stamp: ''!
starting: aDateAndTime duration: aDuration 
	"Return a new year, starting from the beginning the year the given DateAndTime is in."
	| aYear |
	aYear := aDateAndTime asDateAndTime year.

	^ super
		starting: (DateAndTime year: aYear month: 1 day: 1 offset: aDateAndTime offset)
		duration: (Duration days: (self daysInYear: aYear)).! !

!Year class methodsFor: 'instance creation' stamp: ''!
year: aYear

	^ self starting: (DateAndTime year: aYear month: 1 day: 1).! !

!Year class methodsFor: 'instance creation' stamp: ''!
currentYearNumber
    "Return the current year number"
    ^ Date today year! !

!Year class methodsFor: 'accessing' stamp: ''!
isLeapYear: aYearInteger


	| adjustedYear |
	adjustedYear := aYearInteger > 0
		ifTrue: [aYearInteger]
		ifFalse: [(aYearInteger + 1) negated].

	"There was no year 0"
	^ ((adjustedYear \\ 4 ~= 0) or: [(adjustedYear \\ 100 = 0) and: [adjustedYear \\ 400 ~= 0]]) not.! !

!Year class methodsFor: 'instance creation' stamp: ''!
currentYear
  "Return the current year"
  ^ Date today asYear! !

!Year class methodsFor: 'accessing' stamp: ''!
daysInYear: yearInteger

	^ 365 + ((self isLeapYear: yearInteger) ifTrue: [1] ifFalse: [0]).! !

!YearMonthWeekTest commentStamp: ''!
I am one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. See DateAndEpochTestCase for a complete list.  tlk.
I have no fixtures but do make sure to restore anything I change.!
!YearMonthWeekTest methodsFor: 'tests' stamp: ''!
testWeekPrintOn
	| aWeek cs rw |
	aWeek := Week starting: (DateAndTime year: 1900 month: 12 day: 31).
	cs := 'a Week starting: 1900-12-30T00:00:00+00:00'.
	rw := String new writeStream.
	aWeek printOn: rw.
	self assert: rw contents equals: cs! !

!YearMonthWeekTest methodsFor: 'running' stamp: ''!
tearDown
	Week startDay: restoredStartDay.
	DateAndTime localTimeZone: restoredTimeZone.
	super tearDown! !

!YearMonthWeekTest methodsFor: 'tests' stamp: ''!
testMonthPrintOn
	| aMonth |
	aMonth := Month starting: DateAndTime new duration: 31 days.
	self assert: (String streamContents: [ :str | aMonth printOn: str ]) equals: 'January 1901'! !

!YearMonthWeekTest methodsFor: 'tests' stamp: ''!
testStartDay
	Week startDay: 'Wednesday'.
	self assert: Week startDay equals: 'Wednesday'.
	Week startDay: 'Thursday'.
	self assert: Week startDay equals: 'Thursday'! !

!YearMonthWeekTest methodsFor: 'tests' stamp: ''!
testIndexOfDay
	self assert: (Week indexOfDay: 'Friday') equals: 6! !

!YearMonthWeekTest methodsFor: 'tests' stamp: ''!
testDaysInMonth
	self assert: (Month daysInMonth: 2 forYear: 2000) equals: 29.
	self assert: (Month daysInMonth: 2 forYear: 2001) equals: 28.
	self assert: (Month daysInMonth: 2 forYear: 2004) equals: 29.
	self assert: (Month daysInMonth: 2 forYear: 2100) equals: 28.

	self assert: (Month daysInMonth: 'January' forYear: 2003) equals: 31.
	self assert: (Month daysInMonth: 'February' forYear: 2003) equals: 28.
	self assert: (Month daysInMonth: 'March' forYear: 2003) equals: 31.
	self assert: (Month daysInMonth: 'April' forYear: 2003) equals: 30.
	self assert: (Month daysInMonth: 'May' forYear: 2003) equals: 31.
	self assert: (Month daysInMonth: 'June' forYear: 2003) equals: 30.
	self assert: (Month daysInMonth: 'July' forYear: 2003) equals: 31.
	self assert: (Month daysInMonth: 'August' forYear: 2003) equals: 31.
	self assert: (Month daysInMonth: 'September' forYear: 2003) equals: 30.
	self assert: (Month daysInMonth: 'October' forYear: 2003) equals: 31.
	self assert: (Month daysInMonth: 'November' forYear: 2003) equals: 30.
	self assert: (Month daysInMonth: 'December' forYear: 2003) equals: 31! !

!YearMonthWeekTest methodsFor: 'tests' stamp: ''!
testYearPrintOn
	| aYear |
	aYear := Year starting: DateAndTime new duration: 365 days.
	self assert: (String streamContents: [ :str | aYear printOn: str ]) equals: 'a Year (1901)'! !

!YearMonthWeekTest methodsFor: 'tests' stamp: ''!
testDaysInYear
	self assert: (Year daysInYear: 2000) equals: 366.
	self assert: (Year daysInYear: 2001) equals: 365.
	self assert: (Year daysInYear: 2004) equals: 366.
	self assert: (Year daysInYear: 2100) equals: 365.
	self assert: (Year daysInYear: 2003) equals: 365! !

!YearMonthWeekTest methodsFor: 'tests' stamp: ''!
testIsLeapYear
	self assert: (Year isLeapYear: 2000).
	self deny: (Year isLeapYear: 2001).
	self assert: (Year isLeapYear: 2004).
	self deny: (Year isLeapYear: 2100).
	self deny: (Year isLeapYear: 2002).! !

!YearMonthWeekTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	restoredStartDay := Week startDay.
	restoredTimeZone := DateAndTime localTimeZone.

	Week startDay: #Sunday.
	DateAndTime localTimeZone: (TimeZone timeZones detect: [:tz | tz abbreviation = 'GMT']).! !

!YearTest commentStamp: ''!
SUnit tests for year handling!
!YearTest methodsFor: 'tests' stamp: ''!
testFirstThursday
		
	1800 to: 2000 do:
		[ :y |
			| firstThursday |
			firstThursday := (Year year: y) firstThursday.
			self assert: firstThursday dayOfWeek equals: 5.
			self assert: firstThursday year equals: y.
			self assert: (firstThursday - 1 week) year equals: y - 1 ]! !

!YearTest methodsFor: 'tests' stamp: ''!
testcurrentYear
		
	| yyyy |
	yyyy := Year currentYear. 
	self assert: Date today asYear equals: yyyy! !

!YearTest methodsFor: 'tests' stamp: ''!
testStart
	| yyyy |
	yyyy := DateAndTime now year.
	self assert: Year current start equals: (DateAndTime year: yyyy month: 1 day: 1)! !

!YearTest methodsFor: 'tests' stamp: ''!
testdaysInMonth
	
	self assert: ((Year year: 2018) daysInMonth:1) equals: 31. "January"
	self assert: ((Year year: 2018) daysInMonth:2) equals: 28. "February"
	self assert: ((Year year: 2016) daysInMonth:2) equals: 29. "February Leap Year"
	self assert: ((Year year: 2018) daysInMonth:3) equals: 31. "March"
	self assert: ((Year year: 2018) daysInMonth:4) equals: 30. "April"
	self assert: ((Year year: 2018) daysInMonth:5) equals: 31. "May"
	self assert: ((Year year: 2018) daysInMonth:6) equals: 30. "June"
	self assert: ((Year year: 2018) daysInMonth:7) equals: 31. "July"
	self assert: ((Year year: 2018) daysInMonth:8) equals: 31. "August"
	self assert: ((Year year: 2018) daysInMonth:9) equals: 30. "September"
	self assert: ((Year year: 2018) daysInMonth:10) equals: 31. "October"
	self assert: ((Year year: 2018) daysInMonth:11) equals: 30. "November"
	self assert: ((Year year: 2018) daysInMonth:12) equals: 31. "December"! !

!YearTest methodsFor: 'tests' stamp: ''!
testPreviousInLeapYear
	| leap |
	leap := Year year: 2008.
	self assert: leap isLeapYear.
	self assert: (Year year: leap year - 1) equals: leap previous! !

!YearTest methodsFor: 'tests' stamp: ''!
testOffset
	"Check that the offset is maintained when creating a new instance of Month from a DateAndTime"

	| dt newYear |

	dt := DateAndTime fromString: '2018/01/01T00:00:00+10'.
	newYear := Year starting: dt duration: 0. "duration is ignored"
	self assert: newYear asDateAndTime offset equals: dt offset! !

!YearTest methodsFor: 'tests' stamp: ''!
testcurrentYearNumber
		
	| yyyy |
	yyyy := Year currentYearNumber. 
	self assert: Date today year equals: yyyy! !

!YearTest methodsFor: 'coverage' stamp: ''!
classToBeTested

	^ Year! !

!ZLibReadStream commentStamp: ''!
A ZLib read stream!
!ZLibReadStream methodsFor: 'crc' stamp: 'nil'!
verifyCrc
	| stored |
	stored := 0.
	24 to: 0 by: -8 do: [ :i |
		sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ].
		stored := stored + (self nextByte bitShift: i) ].
	stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ].
	^stored! !

!ZLibReadStream methodsFor: 'crc' stamp: 'nil'!
updateCrc: oldCrc from: start to: stop in: aCollection
	"Answer an updated CRC for the range of bytes in aCollection"
	^ Adler32 update: oldCrc from: start to: stop in: aCollection! !

!ZLibReadStream methodsFor: 'initialization' stamp: 'nil'!
on: aCollection from: firstIndex to: lastIndex
	"Check the header of the ZLib stream."
	| method byte |
	super on: aCollection from: firstIndex to: lastIndex.
	crc := 1.
	method := self nextBits: 8.
	(method bitAnd: 15) = 8 ifFalse:[^self error:'Unknown compression method'].
	(method bitShift: -4) + 8 > 15 ifTrue:[^self error:'Invalid window size'].
	byte := self nextBits: 8.
	(method bitShift: 8) + byte \\ 31 = 0 ifFalse:[^self error:'Incorrect header'].
	(byte anyMask: 32) ifTrue:[^self error:'Need preset dictionary']! !

!ZLibWriteStream commentStamp: ''!
I use the zlib implementation of the deflate algorithm to compress a ByteArray. According to Wikipedia, "this algorithm provides good compression on a wide variety of data with minimal use of system resources." See [http://en.wikipedia.org/wiki/DEFLATE](http://en.wikipedia.org/wiki/DEFLATE) for details on the deflate algorithm.

This is how you get a compressed ByteArray from your input:

```
zipStream := ZLibWriteStream on: (ByteArray new).
zipStream 
	nextPutAll: myByteArray;
	close.
compressed := zipStream encodedStream contents.
```!
!ZLibWriteStream methodsFor: 'initialization' stamp: 'nil'!
on: aCollectionOrStream
	super on: aCollectionOrStream.
	crc := 1.! !

!ZLibWriteStream methodsFor: 'initialization' stamp: 'nil'!
writeHeader
	"Write header information"
	encoder nextBits: 8 put: 120. "deflate method with 15bit window size"
	encoder nextBits: 8 put: 94. "checksum; no preset; fast (flevel=1) compression"! !

!ZLibWriteStream methodsFor: 'initialization' stamp: 'nil'!
writeFooter
	"Store the Adler32 checksum as the last 4 bytes."
	3 to: 0 by: -1 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)].! !

!ZLibWriteStream methodsFor: 'initialization' stamp: 'nil'!
updateCrc: adler from: start to: stop in: aCollection
	"Update crc using the Adler32 checksum technique from RFC1950"
	^ Adler32 update: adler from:  start to:  stop in: aCollection! !

!ZdcAbstractSSLSession commentStamp: ''!
I am ZdcAbstractSSLSession, an object managing the secure communication between two parties.

I define the abstract interface for my subclasses.

More specifically, I handle connection setup handshaking as well as the encryption
and decryption of data travelling between two parties.

Apart from instanciating and later explicitely destroying me, I am used by feeding data 
into me using the methods in my operations protocol. These might result in data that
has to be sent to the other side.

I am propably too primitive to be used directly, see ZdcSecureSocketStream for a higher level client.!
!ZdcAbstractSSLSession methodsFor: 'accessing' stamp: ''!
certificateName
	"The name of the local certificate to provide to the remote peer"

	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'operations' stamp: ''!
encrypt: srcBuf from: start to: stop into: dstBuf
	"Encrypt the input in srcBuf from start to stop into dstBuf."

	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'accessing' stamp: ''!
certificateName: aString
	"Sets the name of the local certificate to provide to the remote peer.
	OpenSSL: The name is the full path to a .pem file.
	WinSSL: The name is matched against the 'subject' of a certificate in the cert store"

	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'accessing' stamp: ''!
serverName: serverName
	"Set the Server Name Indication (SNI) to serverName, 
	the fully qualified domain name of the host to connect to.
	This should be set by a client before #connect is attempted."
	
	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'accessing' stamp: ''!
serverName
	"Get the Server Name Indication (SNI) property"
	
	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'operations' stamp: ''!
decrypt: srcBuf from: start to: stop into: dstBuf
	"Decrypt the input in srcBuf from start to stop into dstBuf."

	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'accessing' stamp: ''!
sslState
	"Returns the current state of the SSL connection:
		0 - Unused
		1 - In accept handshake
		2 - In connect handshake
		3 - Connected"
		
	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'accessing' stamp: ''!
peerCertificateName
	"Returns the certificate name of the remote peer.
	The method only returns a name if the certificate has been verified"

	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'operations' stamp: ''!
accept: srcBuf from: start to: stop into: dstBuf
	"Start or continue the server handshake using the given input token"

	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'initialization' stamp: ''!
destroy
	"Do any necessary cleanup when I am no longer needed"
	
	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'testing' stamp: ''!
isConnected
	"Returns true if the SSL handshake has been completed"

	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'accessing' stamp: ''!
certificateVerificationState
	"Returns the certificate verification bits. The returned value indicates
	whether the certificate is valid. The two standard values are:
		0   - The certificate is valid
		-1  - No certificate has been provided by the peer
	Otherwise, the result is a bit mask of the following values:
		1   - If set, there is an unspecified issue with the cert (generic error)
		2   - If set, the root CA is untrusted (usually a self-signed cert)
		4   - If set, the certificate is expired
		8   - If set, the certificate is used for the wrong purpose
		16 - If set, the CN of the certificate is invalid
		32 - If set, the certificate was revoked"

	self subclassResponsibility! !

!ZdcAbstractSSLSession methodsFor: 'operations' stamp: ''!
connect: srcBuf from: start to: stop into: dstBuf
	"Start or continue the client handshake using the given input token"

	self subclassResponsibility! !

!ZdcAbstractSSLSession class methodsFor: 'testing' stamp: ''!
isAbstract 

	^self == ZdcAbstractSSLSession! !

!ZdcAbstractSocketStream commentStamp: ''!
I am ZdcAbstractSocketStream, a binary read/write stream for socket communication.

Interally, IO is done through a read and a write ZdcIOBuffer.

I am abstract, my subclasses should implement actual IO through a delegate.!
!ZdcAbstractSocketStream methodsFor: 'stream in' stamp: ''!
nextInto: collection
	"Read the next elements of the receiver into collection,
	returning a copy if less elements are available"
	
	^ self
		next: collection size
		into: collection! !

!ZdcAbstractSocketStream methodsFor: 'private - socket' stamp: ''!
socketSendData: bytes startingAt: offset count: count
	^ socket 
		sendSomeData: bytes 
		startIndex: offset 
		count: count ! !

!ZdcAbstractSocketStream methodsFor: 'compatibility' stamp: ''!
shouldSignal: boolean
	"I always signal exceptional situations."! !

!ZdcAbstractSocketStream methodsFor: 'stream in' stamp: ''!
peek
	"Peek and return a single byte"
	
	readBuffer isEmpty ifTrue: [ self fillReadBuffer ].
	^ readBuffer isEmpty
		ifTrue: [ nil ]
		ifFalse: [ readBuffer peek]! !

!ZdcAbstractSocketStream methodsFor: 'private - socket' stamp: ''!
socketReceiveDataInto: bytes startingAt: offset count: count
	^ socket 
		primSocket: socket socketHandle 
		receiveDataInto: bytes
		startingAt: offset
		count: count! !

!ZdcAbstractSocketStream methodsFor: 'stream in' stamp: ''!
next: requestedCount 
	"Read requestedCount bytes and return them as a ByteArray.
	If less are available, a smaller ByteArray will be returned."

	^ self 
		next: requestedCount 
		into: (self collectionSpecies new: requestedCount)! !

!ZdcAbstractSocketStream methodsFor: 'private' stamp: ''!
log: object
	debug ifTrue: [
		self crTrace: object value ]
	! !

!ZdcAbstractSocketStream methodsFor: 'private - socket' stamp: ''!
socketIsDataAvailable
	^ socket dataAvailable ! !

!ZdcAbstractSocketStream methodsFor: 'stream in' stamp: ''!
upToEnd
	"Read bytes until the stream is atEnd and return them as a ByteArray.
	This is an inefficient abstract implementation reading bytes one by one.
	Note that even when #atEnd returns false, the following #next could be nil 
	or the connection could suddenly be closed"

	^ self collectionSpecies 
		streamContents: [ :writeStream |
			[ [ self atEnd or: [ self peek isNil ] ] whileFalse: [ 
				writeStream nextPut: self next ] ]
		 		on: ConnectionClosed
				do: [ :exception | exception return ] ]! !

!ZdcAbstractSocketStream methodsFor: 'private' stamp: ''!
debug: aBoolean
	debug := aBoolean ! !

!ZdcAbstractSocketStream methodsFor: 'stream in' stamp: ''!
next: requestedCount into: collection startingAt: offset
	"Read requestedCount elements into collection starting at offset,
	returning a copy if less elements are available"
	
	| read |
	read := self 
		readInto: collection 
		startingAt: offset 
		count: requestedCount.
	^ read = requestedCount 
		ifTrue: [ collection ]
		ifFalse: [ collection copyFrom: 1 to: offset + read - 1 ]     ! !

!ZdcAbstractSocketStream methodsFor: 'testing' stamp: ''!
isBinary
	"We are always binary"
	
	^ true! !

!ZdcAbstractSocketStream methodsFor: 'stream out' stamp: ''!
next: count putAll: collection startingAt: offset
	"Write count bytes from collection starting at offset.
	This is an inefficient abstract implementation writing bytes one by one."
	
	0 to: count - 1 do: [ :each | 
		self nextPut: (collection at: offset + each) ]! !

!ZdcAbstractSocketStream methodsFor: 'private - out' stamp: ''!
flushWriteBuffer
	"Ask the delegate to write all data in the write buffer. Fail if not successful"
	
	self subclassResponsibility ! !

!ZdcAbstractSocketStream methodsFor: 'compatibility' stamp: ''!
autoFlush: boolean
	"I flush when asked to, or when my buffer is full."! !

!ZdcAbstractSocketStream methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		nextPutAll: 'a '; 
		nextPutAll: self class name! !

!ZdcAbstractSocketStream methodsFor: 'stream out' stamp: ''!
nextPut: object
	"Write a single byte"
	
	writeBuffer isFull ifTrue: [ self flushWriteBuffer ].
	writeBuffer nextPut: object
	! !

!ZdcAbstractSocketStream methodsFor: 'private - socket' stamp: ''!
socketClose
	socket closeAndDestroy ! !

!ZdcAbstractSocketStream methodsFor: 'accessing' stamp: ''!
timeout
	"Return the number of seconds we wait for socket IO operations"
	
	^ timeout ! !

!ZdcAbstractSocketStream methodsFor: 'initialize-release' stamp: ''!
close
	"Close the stream, flush if necessary"

	[ self flush ] ensure: [ 
		socket ifNotNil: [ 
			self socketClose.
			socket := nil ].
		readBuffer close.
		writeBuffer close ]! !

!ZdcAbstractSocketStream methodsFor: 'testing' stamp: ''!
isConnected
	"Are we connected at the socket level ?"
	
	^ self subclassResponsibility ! !

!ZdcAbstractSocketStream methodsFor: 'stream out' stamp: ''!
flush
	"Flush all pending output that might be in the write buffer"
	
	self flushWriteBuffer ! !

!ZdcAbstractSocketStream methodsFor: 'testing' stamp: ''!
atEnd
	"I am atEnd when there is no more data to be read and there never will be.
	This means that readBuffer must be empty, 
	there must be no more unread data available at the socket,
	and the socket must be closed"
	
	^ self subclassResponsibility ! !

!ZdcAbstractSocketStream methodsFor: 'compatibility' stamp: ''!
bufferSize: numberOfBytes
	"Not yet implemented. See #initializeBuffers."! !

!ZdcAbstractSocketStream methodsFor: 'stream in' stamp: ''!
next: requestedCount into: collection
	"Read requestedCount elements into collection,
	returning a copy if less elements are available"
	
	^ self 
		next: requestedCount 
		into: collection 
		startingAt: 1   ! !

!ZdcAbstractSocketStream methodsFor: 'stream out' stamp: ''!
next: count putAll: collection
	"Write count bytes from collection"
	
	self 
		next: count 
		putAll: collection 
		startingAt: 1! !

!ZdcAbstractSocketStream methodsFor: 'testing' stamp: ''!
isStream
	^ true! !

!ZdcAbstractSocketStream methodsFor: 'accessing' stamp: ''!
socket
	"Return the underlying socket object that I delegate I/O to"
	
	^ socket! !

!ZdcAbstractSocketStream methodsFor: 'private - socket' stamp: ''!
socketConnectTo: hostAddress port: portNumber
	socket 
		connectTo: hostAddress 
		port: portNumber 
		waitForConnectionFor: self timeout        ! !

!ZdcAbstractSocketStream methodsFor: 'accessing' stamp: ''!
timeout: seconds
	"Set the number of seconds we wait for socket IO operations"
	
	timeout := seconds! !

!ZdcAbstractSocketStream methodsFor: 'initialize-release' stamp: ''!
initialize 
	timeout := 5.
	debug := false.
	self initializeBuffers ! !

!ZdcAbstractSocketStream methodsFor: 'compatibility' stamp: ''!
binary
	"I am always binary."! !

!ZdcAbstractSocketStream methodsFor: 'stream in' stamp: ''!
next
	"Read and return a single byte"
	
	readBuffer isEmpty ifTrue: [ self fillReadBuffer ].
	^ readBuffer isEmpty
		ifTrue: [ nil ]
		ifFalse: [ readBuffer next ]! !

!ZdcAbstractSocketStream methodsFor: 'initialize-release' stamp: ''!
on: object
	socket := object! !

!ZdcAbstractSocketStream methodsFor: 'private - socket' stamp: ''!
socketIsConnected
	^ socket isConnected and: [ socket isOtherEndClosed not ]! !

!ZdcAbstractSocketStream methodsFor: 'accessing' stamp: ''!
collectionSpecies
	"Fixed to ByteArray since we are binary"
	
	^ ByteArray
	! !

!ZdcAbstractSocketStream methodsFor: 'private - in' stamp: ''!
fillReadBuffer
	"Ask the delegate to fill the read buffer with data. 
	Wait for at least some data."
	
	self subclassResponsibility  ! !

!ZdcAbstractSocketStream methodsFor: 'private - socket' stamp: ''!
socketWaitForSendDone
	^ socket waitForSendDoneFor: self timeout
	! !

!ZdcAbstractSocketStream methodsFor: 'testing' stamp: ''!
isDataAvailable
	"Return true when there is data available for reading.
	This does not block."
	
	^ self subclassResponsibility ! !

!ZdcAbstractSocketStream methodsFor: 'stream in' stamp: ''!
skip: count
	"Skip over count bytes.
	This is an inefficient abstract implementation skipping bytes one by one."
	
	count timesRepeat: [ self next ]! !

!ZdcAbstractSocketStream methodsFor: 'private - socket' stamp: ''!
socketWaitForData
	^ socket waitForDataFor: self timeout
	! !

!ZdcAbstractSocketStream methodsFor: 'stream in' stamp: ''!
upTo: value 
	"Read bytes upto but not including value and return them as a ByteArray.
	If value is not found, return the entire contents of the stream.
	This is an inefficient abstract implementation reading bytes one by one."
	
	^ self collectionSpecies 
		streamContents: [ :writeStream | | element |
			[ self atEnd or: [ (element := self next) = value ] ] whileFalse: [ 
				writeStream nextPut: element ] ]! !

!ZdcAbstractSocketStream methodsFor: 'stream in' stamp: ''!
readInto: collection startingAt: offset count: requestedCount
	"Read requestedCount elements into collection starting at offset,
	returning the number of elements read, there could be less elements available.
	This is an inefficient abstract implementation, reading bytes one by one."
	
	0 to: requestedCount - 1 do: [ :count | | object |
		(object := self next) ifNil: [ ^ count ].  
		collection at: offset + count put: object ].
	^ requestedCount! !

!ZdcAbstractSocketStream methodsFor: 'initialize-release' stamp: ''!
initializeBuffers
	readBuffer := ZdcIOBuffer onByteArrayOfSize: 4096.
	writeBuffer := ZdcIOBuffer onByteArrayOfSize: 4096! !

!ZdcAbstractSocketStream methodsFor: 'stream out' stamp: ''!
nextPutAll: collection
	"Write a collection of bytes"
	
	self 
		next: collection size 
		putAll: collection 
		startingAt: 1! !

!ZdcAbstractSocketStream class methodsFor: 'instance creation' stamp: ''!
on: object
	^ (self basicNew)
		initialize;
		on: object;
		yourself! !

!ZdcAbstractSocketStream class methodsFor: 'testing' stamp: ''!
isAbstract

	^self == ZdcAbstractSocketStream ! !

!ZdcAbstractSocketStreamTest commentStamp: ''!
ZdcAbstractSocketStreamTests holds units tests for socket streams.

This is an abstract class, subclasses should implement #socketStreamClass !
!ZdcAbstractSocketStreamTest methodsFor: 'accessing' stamp: ''!
socketStreamTimeout
	"Timeout in seconds for SocketStream IO"
	
	^ ZnNetworkingUtils socketStreamTimeout! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - plain' stamp: ''!
testPlainClientRead
	| dataSent dataRead clientStream semaphore |
	dataSent := #[ 6 5 4 3 2 1 ].
	semaphore := self runServer: [ :serverSocket :mySemaphore | | clientSocket serverStream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		serverStream := self referenceSocketStreamOn: clientSocket.
		serverStream nextPutAll: dataSent.
		serverStream close.
		mySemaphore signal ].
	clientStream := self openConnectionToHost: #[ 127 0 0 1 ] port: self port.
	dataRead := clientStream upToEnd.
	clientStream close.
	semaphore wait.
	self assert: dataSent equals: dataRead.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - reverse echo' stamp: ''!
testReverseEcho10kSearch
	| dataSent dataRead clientStream semaphore |
	semaphore := self runServer: [ :serverSocket | | clientSocket stream data |
		clientSocket := serverSocket waitForAcceptFor: 10.
		stream := self socketStreamOn: clientSocket.
		data := stream upTo: 0.
		stream nextPutAll: data reverse; nextPut: 0.  
		stream close ].
	dataSent := (self bytes: 10000) replace: [ :each | each max: 1 ].
	clientStream := self openConnectionToHostNamed: 'localhost' port: self port.
	clientStream nextPutAll: dataSent; nextPut: 0; flush.
	dataRead := clientStream upTo: 0.
	clientStream close.
	self assert: dataRead equals: dataSent reverse.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'private' stamp: ''!
setReferenceSocketStreamOptions: stream
	stream
		binary;
		shouldSignal: true;
		autoFlush: false;
		bufferSize: self socketBufferSize;
		timeout: self socketStreamTimeout! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - plain' stamp: ''!
testPlainClientSkip10k
	| dataSent dataRead clientStream semaphore |
	dataSent := #[ 6 5 4 3 2 1 ].
	semaphore := self runServer: [ :serverSocket :mySemaphore | | clientSocket serverStream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		serverStream := self referenceSocketStreamOn: clientSocket.
		10000 timesRepeat: [ serverStream nextPut: 0 ].  
		serverStream nextPutAll: dataSent.
		serverStream close.
		mySemaphore signal ].
	clientStream := self openConnectionToHost: #[ 127 0 0 1 ] port: self port.
	dataRead := clientStream skip: 10000; upToEnd.
	clientStream close.
	semaphore wait.
	self assert: dataSent equals: dataRead.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'accessing' stamp: ''!
listenBacklogSize
	"Server socket backlog size (number of pending connection waiting to be accepted)"
	
	^ 32! !

!ZdcAbstractSocketStreamTest methodsFor: 'accessing' stamp: ''!
bytes: size
	| count data pattern |
	count := 0.
	pattern := (0 to: 255) asByteArray.
	data := ByteArray streamContents: [ :stream |
		[ count < size ] whileTrue: [
			stream nextPutAll: pattern.
			count := count + pattern size ] ].
	^ data copyFrom: 1 to: size     ! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - reverse echo' stamp: ''!
testReverseEcho10kFixed
	| dataSent dataRead clientStream semaphore |
	semaphore := self runServer: [ :serverSocket | | clientSocket stream data |
		clientSocket := serverSocket waitForAcceptFor: 10.
		stream := self socketStreamOn: clientSocket.
		data := stream next: 10000.
		stream nextPutAll: data reverse.  
		stream close ].
	dataSent := self bytes: 10000.
	clientStream := self openConnectionToHostNamed: 'localhost' port: self port.
	clientStream nextPutAll: dataSent; flush.
	dataRead := clientStream next: 10000.
	clientStream close.
	self assert: dataRead equals: dataSent reverse.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - plain' stamp: ''!
testPlainClientSkip
	| dataSent dataRead clientStream semaphore |
	dataSent := #[ 6 5 4 3 2 1 ].
	semaphore := self runServer: [ :serverSocket :mySemaphore | | clientSocket serverStream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		serverStream := self referenceSocketStreamOn: clientSocket.
		serverStream nextPut: 0; nextPutAll: dataSent.
		serverStream close.
		mySemaphore signal ].
	clientStream := self openConnectionToHost: #[ 127 0 0 1 ] port: self port.
	dataRead := clientStream skip: 1; upToEnd.
	clientStream close.
	semaphore wait.
	self assert: dataSent equals: dataRead.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - plain' stamp: ''!
testPlainClientRead10kInPieces2
	| dataSent dataRead clientStream semaphore |
	dataSent := self bytes: 10000.
	semaphore := self runServer: [ :serverSocket :mySemaphore | | clientSocket serverStream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		serverStream := self referenceSocketStreamOn: clientSocket.
		serverStream nextPutAll: dataSent.
		serverStream close.
		mySemaphore signal ].
	clientStream := self openConnectionToHost: #[ 127 0 0 1 ] port: self port.
	dataRead := ByteArray new: 10000.
	0 to: 9 do: [ :index | 
		clientStream next: 1000 into: dataRead startingAt: (index * 1000) + 1 ].
	clientStream close.
	semaphore wait.
	self assert: dataSent equals: dataRead.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'private' stamp: ''!
referenceSocketStreamOn: socket
	| stream |
	stream := SocketStream on: socket.
	self setReferenceSocketStreamOptions: stream.
	^ stream! !

!ZdcAbstractSocketStreamTest methodsFor: 'accessing' stamp: ''!
port 
	^ 1701! !

!ZdcAbstractSocketStreamTest methodsFor: 'private' stamp: ''!
openConnectionToHost: host port: port
	^ self socketStreamClass 
		openConnectionToHost: host port: port! !

!ZdcAbstractSocketStreamTest methodsFor: 'private' stamp: ''!
socketStreamOn: socket
	^ self socketStreamClass 
		on: socket! !

!ZdcAbstractSocketStreamTest methodsFor: 'private' stamp: ''!
runServer: block
	| serverSocket semaphore |
	serverSocket := self serverSocketOn: self port.
	self assert: serverSocket notNil.
	self assert: serverSocket localPort equals: self port.
	semaphore := Semaphore new.
	[ 
	semaphore signal.
	[ block cull: serverSocket cull: semaphore ]
		ensure: [ 
			serverSocket closeAndDestroy.
			semaphore signal ] ] forkAt: self serverPriority.
	semaphore wait.
	^ semaphore! !

!ZdcAbstractSocketStreamTest methodsFor: 'accessing' stamp: ''!
socketStreamClass
	^ self subclassResponsibility ! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - plain' stamp: ''!
testPlainClientRead10k
	| dataSent dataRead clientStream semaphore |
	dataSent := self bytes: 10000.
	semaphore := self runServer: [ :serverSocket :mySemaphore | | clientSocket serverStream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		serverStream := self referenceSocketStreamOn: clientSocket.
		serverStream nextPutAll: dataSent.
		serverStream close.
		mySemaphore signal ].
	clientStream := self openConnectionToHost: #[ 127 0 0 1 ] port: self port.
	dataRead := clientStream upToEnd.
	clientStream close.
	semaphore wait.
	self assert: dataSent equals: dataRead.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'private' stamp: ''!
serverPriority
	^ Processor userBackgroundPriority! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - plain' stamp: ''!
testPlainClientWrite10k
	| dataSent dataRead clientStream semaphore |
	semaphore := self runServer: [ :serverSocket :mySemaphore | | clientSocket serverStream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		serverStream := self referenceSocketStreamOn: clientSocket.
		dataRead := serverStream upToEnd.
		serverStream close.
		mySemaphore signal ].
	dataSent := self bytes: 10000.
	clientStream := self openConnectionToHost: #[ 127 0 0 1 ] port: self port.
	clientStream nextPutAll: dataSent.
	clientStream close.
	semaphore wait.
	self assert: dataSent equals: dataRead.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'accessing' stamp: ''!
socketBufferSize
	"Size in bytes for Sockets and SocketStream IO buffers"

	^ 4096! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - reverse echo' stamp: ''!
testReverseEcho
	| dataSent dataRead clientStream semaphore data |
	semaphore := self runServer: [ :serverSocket | | clientSocket stream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		stream := self socketStreamOn: clientSocket.
		data := stream upTo: 0.
		stream nextPutAll: data reverse; nextPut: 0.  
		stream close ].
	dataSent := #[ 1 2 3 4 5 6 ].
	clientStream := self openConnectionToHostNamed: 'localhost' port: self port.
	clientStream nextPutAll: dataSent; nextPut: 0; flush.
	dataRead := clientStream upTo: 0.
	clientStream close.
	self assert: dataRead equals: dataSent reverse.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'private' stamp: ''!
runClient: block
	| semaphore |
	semaphore := Semaphore new.
	[ block ensure: [ semaphore signal ] ] forkAt: self serverPriority - 1.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests' stamp: ''!
testAddOneEcho
	| dataSent dataRead clientStream semaphore |
	semaphore := self runServer: [ :serverSocket | | clientSocket stream data |
		clientSocket := serverSocket waitForAcceptFor: 10.
		stream := self socketStreamOn: clientSocket.
		data := stream next.
		stream nextPut: ((data + 1) bitAnd: 16rff).  
		stream close ].
	dataSent := 99.
	clientStream := self openConnectionToHostNamed: 'localhost' port: self port.
	clientStream nextPut: dataSent; flush.
	dataRead := clientStream next.
	clientStream close.
	self assert: dataRead equals: dataSent + 1.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - plain' stamp: ''!
testPlainClientRead10kInPieces1
	| dataSent dataRead clientStream semaphore |
	dataSent := self bytes: 10000.
	semaphore := self runServer: [ :serverSocket :mySemaphore | | clientSocket serverStream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		serverStream := self referenceSocketStreamOn: clientSocket.
		serverStream nextPutAll: dataSent.
		serverStream close.
		mySemaphore signal ].
	clientStream := self openConnectionToHost: #[ 127 0 0 1 ] port: self port.
	dataRead := ByteArray new: 10000 streamContents: [ :stream |
		10 timesRepeat: [ stream nextPutAll: (clientStream next: 1000) ] ].
	clientStream close.
	semaphore wait.
	self assert: dataSent equals: dataRead.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - reverse echo' stamp: ''!
testReverseEchoUpToEnd
	| dataSent dataRead clientStream semaphore data |
	semaphore := self runServer: [ :serverSocket :mySemaphore | | clientSocket stream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		stream := self socketStreamOn: clientSocket.
		"Doing #upToEnd here does not seem to work"
		data := stream next: 6.
		stream nextPutAll: data reverse.  
		stream close ].
	self runClient: [ 
		dataSent := #[ 1 2 3 4 5 6 ].
		clientStream := self openConnectionToHostNamed: 'localhost' port: self port.
		clientStream nextPutAll: dataSent; flush.
		dataRead := clientStream upToEnd.
		clientStream close.
		self assert: dataRead equals: dataSent reverse.
		semaphore wait ]! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - plain' stamp: ''!
testPlainClientWrite
	| dataSent dataRead clientStream semaphore |
	semaphore := self runServer: [ :serverSocket :mySemaphore | | clientSocket serverStream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		serverStream := self referenceSocketStreamOn: clientSocket.
		dataRead := serverStream upToEnd.
		serverStream close.
		mySemaphore signal ].
	dataSent := #[ 1 2 3 4 5 6 ].
	clientStream := self openConnectionToHost: #[ 127 0 0 1 ] port: self port.
	clientStream nextPutAll: dataSent.
	clientStream close.
	semaphore wait.
	self assert: dataSent equals: dataRead.
	semaphore wait! !

!ZdcAbstractSocketStreamTest methodsFor: 'private' stamp: ''!
serverSocketOn: port
	| socket |
	(socket := Socket newTCP)
		setOption: 'TCP_NODELAY' value: 1;
		setOption: 'SO_SNDBUF' value: self socketBufferSize;
		setOption: 'SO_RCVBUF' value: self socketBufferSize .
	socket listenOn: port backlogSize: self listenBacklogSize.
	socket isValid
		ifFalse: [ self error: 'Cannot create socket on port ', port printString ].
	^ socket! !

!ZdcAbstractSocketStreamTest methodsFor: 'private' stamp: ''!
openConnectionToHostNamed: host port: port
	^ self socketStreamClass 
		openConnectionToHostNamed: host port: port! !

!ZdcAbstractSocketStreamTest methodsFor: 'tests - plain' stamp: ''!
testPlainClientWrite10kInPieces
	| dataSent dataRead clientStream semaphore |
	semaphore := self runServer: [ :serverSocket :mySemaphore | | clientSocket serverStream |
		clientSocket := serverSocket waitForAcceptFor: 10.
		serverStream := self referenceSocketStreamOn: clientSocket.
		dataRead := serverStream upToEnd.
		serverStream close.
		mySemaphore signal ].
	dataSent := self bytes: 10000.
	clientStream := self openConnectionToHost: #[ 127 0 0 1 ] port: self port.
	0 to: 9 do: [ :index |
		clientStream next: 1000 putAll: dataSent startingAt: (1000 * index) + 1 ].
	clientStream close.
	semaphore wait.
	self assert: dataSent equals: dataRead.
	semaphore wait! !

!ZdcAbstractSocketStreamTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ true! !

!ZdcByteArrayManager commentStamp: ''!
I manage the allocation and recycling of ByteArrays. 

For each size, I maintain up to limit instances, configurable using #limit:

I never preallocate.

I am threadsafe.

My public API consists of just 2 messages: #byteArrayOfSize:zero: and #recyle:

There is one global current instance for me, but I can be used as needed.

	ZdcByteArrayManager current limit: 4.
	
	ZdcByteArrayManager current limit: 0.!
!ZdcByteArrayManager methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	limit := 0.
	access := Monitor new! !

!ZdcByteArrayManager methodsFor: 'accessing' stamp: ''!
byteArrayOfSize: size zero: zero
	"Return a ByteArray of size. If zero is true, make sure all bytes equal zero.
	When the byte array is no longer needed, #recycle can be used to return it to the reciever.
	It is possible that the byte array returned was previously recycled."
	
	limit = 0 ifTrue: [ ^ ByteArray new: size ].
	access critical: [ 
		| pool |
		pool := self poolForSize: size.
		"Look for an instance to reuse without allocation"
		pool withIndexDo: [ :value :index | 
			value ifNotNil: [ 
				pool at: index put: nil.
				zero ifTrue: [ value atAllPut: 0 ].
				^ value ] ].
		"Allocate a new instance "
		^ ByteArray new: size ]! !

!ZdcByteArrayManager methodsFor: 'accessing' stamp: ''!
totalSize
	^ resources 
		ifNil: [ 0 ] 
		ifNotNil: [ 
			(resources values collect: [ :pool | 
				pool
					inject: 0
					into: [ :sum :each | 
						sum + (each ifNil: [ 0 ] ifNotNil: [ each size ]) ] ]) sum ]! !

!ZdcByteArrayManager methodsFor: 'initialize' stamp: ''!
limit: newLimit
	access critical: [ 
		limit := newLimit.
		limit = 0 ifTrue: [ ^ resources := nil ].
		resources ifNotNil: [ resources removeAll ] ]! !

!ZdcByteArrayManager methodsFor: 'private' stamp: ''!
poolForSize: size
	^ self resources at: size ifAbsentPut: [ Array new: limit ]! !

!ZdcByteArrayManager methodsFor: 'accessing' stamp: ''!
recycle: byteArray
	"Return byteArray, which is no longer needed, to the receiver to be recyled 
	and reused when #byteArrayOfSize:zero: is called."
	
	limit = 0 ifTrue: [ ^ self ].
	access critical: [ 
		| pool |
		pool := self poolForSize: byteArray size.
		"Find an empty slot in the pool"
		pool withIndexDo: [ :value :index | 
			value ifNil: [ 
				^ pool at: index put: byteArray ] ]
		"If the pool is full, don't hold onto it" ]! !

!ZdcByteArrayManager methodsFor: 'private' stamp: ''!
resources
	^ resources ifNil: [ resources := Dictionary new ]! !

!ZdcByteArrayManager class methodsFor: 'accessing' stamp: ''!
current
	^ Current ifNil: [ Current := self new ]! !

!ZdcByteArrayManager class methodsFor: 'accessing' stamp: ''!
current: anObject
	Current := anObject! !

!ZdcByteArrayManager class methodsFor: 'cleanup' stamp: ''!
cleanUp
	self current resources removeAll! !

!ZdcByteArrayManagerTest commentStamp: ''!
ZdcByteArrayManagerTests holds unit tests for ZdcByteArrayManager!
!ZdcByteArrayManagerTest methodsFor: 'tests' stamp: ''!
testClearing
	| byteArrayManager one two |
	byteArrayManager := ZdcByteArrayManager new.
	byteArrayManager limit: 1.
	self assert: byteArrayManager totalSize equals: 0.
	one := (1 to: 10) asByteArray.
	byteArrayManager recycle: one.
	two := byteArrayManager byteArrayOfSize: 10 zero: true.
	self assert: one identicalTo: two.
	self assert: two equals: (ByteArray new: 10)! !

!ZdcByteArrayManagerTest methodsFor: 'tests' stamp: ''!
testSimple
	| byteArrayManager byteArray |
	byteArrayManager := ZdcByteArrayManager new.
	byteArrayManager limit: 1.
	self assert: byteArrayManager totalSize equals: 0.
	byteArray := byteArrayManager byteArrayOfSize: 4096 zero: false.
	byteArrayManager recycle: byteArray.
	self assert: byteArrayManager totalSize equals: 4096.
	self assert: (byteArrayManager byteArrayOfSize: 4096 zero: false) identicalTo: byteArray! !

!ZdcIOBuffer commentStamp: ''!
I am ZdcIOBuffer.

I manage a fixed SequenceableCollection buffer for simultaneous input and output.
I maintain a readPointer and a writePointer.

When data is written to me, it is stored at the end, past my writePointer.
When data is read from me, it is retrieved from the front, past my readPointer.

Invariant: readPointer <= writePointer

My valid contents for reading is defined from contentsStart to contentsEnd, from readPointer + 1 to writePointer.
Data can be added to the free space defined from freeSpaceStart to freeSpaceEnd, from writePointer + 1 to the buffer's' size.

There can be a gap at my front. Compacting moves data if necessary to make (more) room at the end.!
!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
gapAtFront
	"How many elements fit in the gap at the front ?"
	
	^ readPointer! !

!ZdcIOBuffer methodsFor: 'testing' stamp: ''!
isEmpty
	"Can something be read ?"
	
	^ self availableForReading isZero! !

!ZdcIOBuffer methodsFor: 'reading' stamp: ''!
peek
	"Peek the next readable element, fail is empty"

	^ self availableForReading > 0
		ifTrue: [
			buffer at: readPointer + 1 ]
		ifFalse: [
			self bufferEmptyError ]! !

!ZdcIOBuffer methodsFor: 'testing' stamp: ''!
isFull
	"Is there room for writing ?"
	
	^ self availableForWriting isZero! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
advanceWritePointer: count
	"Advance the write pointer as if count elements were written"
	
	self assert: count >= 0.
	count <= self availableForWriting 
		ifTrue: [  
			writePointer := writePointer + count ]
		ifFalse: [
			self bufferFullError ]  ! !

!ZdcIOBuffer methodsFor: 'writing' stamp: ''!
next: count putAll: collection startingAt: offset
	"Add count elements from collection starting at offset. Fail if there is not enough room"
	
	| writeOffset |
	count > self availableForWriting ifTrue: [ self bufferFullError ].  
	writeOffset := self freeSpaceStart.
	buffer 
		replaceFrom: writeOffset 
		to: writeOffset + count - 1 
		with: collection 
		startingAt: offset.
	self advanceWritePointer: count! !

!ZdcIOBuffer methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(.
	buffer
		ifNil: [ stream << 'closed' ]
		ifNotNil: [  
			self gapAtFront > 0 
				ifTrue: [ stream nextPut: $-; print: self gapAtFront; space ].
			stream print: self contents.
			self availableForWriting > 0
				ifTrue: [ stream space; nextPut: $+; print: self availableForWriting ] ].
	stream nextPut: $)! !

!ZdcIOBuffer methodsFor: 'private' stamp: ''!
bufferEmptyError
	^ self error: 'Buffer empty'! !

!ZdcIOBuffer methodsFor: 'writing' stamp: ''!
nextPut: anObject
	"Add another element. Fail if full"
	
	self availableForWriting > 0
		ifTrue: [
			writePointer := writePointer + 1 .
			buffer at: writePointer put: anObject ]
		ifFalse: [
			self bufferFullError ].
	^ anObject
! !

!ZdcIOBuffer methodsFor: 'initialize-release' stamp: ''!
close
	buffer ifNotNil: [  
		ZdcByteArrayManager current recycle: buffer.
		buffer := nil.
		self reset ]! !

!ZdcIOBuffer methodsFor: 'operations' stamp: ''!
contents
	"Return our readable contents"
	
	^ self isEmpty
		ifTrue: [ buffer copyEmpty ]
		ifFalse: [ buffer copyFrom: self contentsStart to: self contentsEnd ]! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
bufferSize
	"Return the raw size of the underlying buffer"
	
	buffer ifNil: [ ^ 0 ].
	^ buffer size! !

!ZdcIOBuffer methodsFor: 'initialization' stamp: ''!
reset
	"Do a hard reset"
	
	readPointer := 0.
	writePointer := 0! !

!ZdcIOBuffer methodsFor: 'operations' stamp: ''!
compact
	"Move data to the front of the buffer to make more room for writing at the end"
	
	| count |
	count := self availableForReading.
	count isZero ifTrue: [ ^ self reset ].
	readPointer isZero ifTrue: [ ^ self ].
	buffer replaceFrom: 1 to: count with: buffer startingAt: readPointer + 1.
	readPointer := 0.
	writePointer := count! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
contentsEnd
	"Return the current valid contents end index into the buffer (inclusive)"
	
	self isEmpty ifTrue: [ self bufferEmptyError ].
	^ writePointer! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
advanceReadPointer: count
	"Advance the read pointer as if count elements were read"
	
	self assert: count >= 0.
	count <= self availableForReading
		ifTrue: [  
			readPointer := readPointer + count ]
		ifFalse: [
			self bufferEmptyError ]  ! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
contentsStart
	"Return the current valid contents start index into the buffer (inclusive)"
	
	self isEmpty ifTrue: [ self bufferEmptyError ].
	^ readPointer + 1! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
availableForWriting
	"How many elements can be written at the end ?"
	
	^ buffer size - writePointer! !

!ZdcIOBuffer methodsFor: 'reading' stamp: ''!
next
	"Access the next readable element, fail is empty"

	^ self availableForReading > 0
		ifTrue: [
			readPointer := readPointer + 1.
			buffer at: readPointer ]
		ifFalse: [
			self bufferEmptyError ]! !

!ZdcIOBuffer methodsFor: 'private' stamp: ''!
bufferFullError
	^ self error: 'Buffer full'! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
freeSpaceStart
	"Return the current valid free space start index into the buffer (inclusive)"
	
	self isFull ifTrue: [ self bufferFullError ]. 
	^ writePointer + 1! !

!ZdcIOBuffer methodsFor: 'initialize-release' stamp: ''!
on: sequenceableCollection
	buffer := sequenceableCollection.
	self reset! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
size
	"Return the number of actual elements available"
	
	^ self availableForReading! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
capacity
	"How much room is there both at the front and at the end ?"
	
	^ self gapAtFront + self availableForWriting ! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
availableForReading
	"How many elements can be read ?"

	^ writePointer - readPointer! !

!ZdcIOBuffer methodsFor: 'reading' stamp: ''!
readInto: collection startingAt: offset count: requestedCount
	"Read requestedCount elements into collection starting at offset,
	returning the number of elements read, there could be less elements available."
	
	| toRead |
	toRead := requestedCount min: self availableForReading.
	collection 
		replaceFrom: offset 
		to: offset + toRead - 1 
		with: buffer 
		startingAt: self contentsStart.
	self advanceReadPointer: toRead.
	^ toRead! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
buffer
	"Return our underlying buffer"
	
	^ buffer! !

!ZdcIOBuffer methodsFor: 'accessing' stamp: ''!
freeSpaceEnd
	"Return the current valid free space end index into the buffer (inclusive)"
	
	self isFull ifTrue: [ self bufferFullError ]. 
	^ buffer size! !

!ZdcIOBuffer class methodsFor: 'instance creation' stamp: ''!
onByteArrayOfSize: size
	^ self on: (ZdcByteArrayManager current byteArrayOfSize: size zero: true)! !

!ZdcIOBuffer class methodsFor: 'instance creation' stamp: ''!
on: sequenceableCollection
	^ (self new)
		on: sequenceableCollection;
		yourself! !

!ZdcIOBufferTest commentStamp: ''!
ZdcIOBufferTests holds unit tests for ZdcIOBuffer.!
!ZdcIOBufferTest methodsFor: 'tests' stamp: ''!
testReading
	| ioBuffer |
	ioBuffer := ZdcIOBuffer on: (ByteArray new: 10).
	1 to: 6 do: [ :each | ioBuffer nextPut: each ].
	1 to: 3 do: [ :each | self assert: ioBuffer next equals: each ].
	self assert: ioBuffer contents equals: #[4 5 6].
	4 to: 6 do: [ :each | self assert: ioBuffer next equals: each ].
	self assert: ioBuffer isEmpty.
	self should: [ ioBuffer next ] raise: Error! !

!ZdcIOBufferTest methodsFor: 'tests' stamp: ''!
testBivalentWriting
	| data ioBuffer |
	data := 'some string'.
	
	ioBuffer := ZdcIOBuffer on: (String new: data size).
	ioBuffer next: data size putAll: data asByteArray startingAt: 1.
	self assert: ioBuffer contents equals: data.
	
	ioBuffer := ZdcIOBuffer on: (ByteArray new: data size).
	ioBuffer next: data size putAll: data startingAt: 1.
	self assert: ioBuffer contents equals: data asByteArray! !

!ZdcIOBufferTest methodsFor: 'tests' stamp: ''!
testNextPutAllStartingAt
	| ioBuffer |
	ioBuffer := ZdcIOBuffer on: (String new: 12).
	ioBuffer next: 4 putAll: 'abcd' startingAt: 1.
	ioBuffer next: 4 putAll: 'xxxxabcdyyyy' startingAt: 5.
	ioBuffer next: 4 putAll: '--abcd' startingAt: 3.
	self assert: ioBuffer contents equals: 'abcdabcdabcd'! !

!ZdcIOBufferTest methodsFor: 'tests - compact' stamp: ''!
testCompactDoNothing
	| ioBuffer |
	ioBuffer := ZdcIOBuffer on: (ByteArray new: 10).
	self assert: ioBuffer isEmpty.
	self assert: ioBuffer availableForReading equals: 0.
	self assert: ioBuffer availableForWriting equals: 10.
	ioBuffer compact.
	self assert: ioBuffer isEmpty.
	self assert: ioBuffer availableForReading equals: 0.
	self assert: ioBuffer availableForWriting equals: 10.	    
	1 to: 6 do: [ :each | ioBuffer nextPut: each ].	
	self deny: ioBuffer isEmpty.
	self assert: ioBuffer availableForReading equals: 6.
	self assert: ioBuffer availableForWriting equals: 4.
	ioBuffer compact.
	self deny: ioBuffer isEmpty.
	self assert: ioBuffer availableForReading equals: 6.
	self assert: ioBuffer availableForWriting equals: 4.! !

!ZdcIOBufferTest methodsFor: 'tests' stamp: ''!
testString
	| ioBuffer |
	ioBuffer := ZdcIOBuffer on: (String new: 10).
	($a to: $f) do: [ :each | ioBuffer nextPut: each ].
	self assert: ioBuffer contents equals: 'abcdef'.
	($a to: $f) do: [ :each | self assert: ioBuffer next equals: each ]
	
	! !

!ZdcIOBufferTest methodsFor: 'tests - compact' stamp: ''!
testCompact
	| ioBuffer |
	ioBuffer := ZdcIOBuffer on: (ByteArray new: 10).
	1 to: 6 do: [ :each | ioBuffer nextPut: each ].
	3 timesRepeat: [ ioBuffer next ].
	ioBuffer compact.
	self assert: ioBuffer availableForReading equals: 3.
	self assert: ioBuffer availableForWriting equals: 7.
	3 timesRepeat: [ ioBuffer next ].
	self assert: ioBuffer gapAtFront equals: 3.
	ioBuffer compact.
	self assert: ioBuffer isEmpty
	
		! !

!ZdcIOBufferTest methodsFor: 'tests' stamp: ''!
testAdvanceReadPointer
	| ioBuffer offset |
	ioBuffer := ZdcIOBuffer on: (ByteArray new: 10).
	3 timesRepeat: [ ioBuffer nextPut: 0 ].
	1 to: 6 do: [ :each | ioBuffer nextPut: each ].
	3 timesRepeat: [ ioBuffer next ].
	offset := ioBuffer contentsStart.
	self assert: ioBuffer availableForReading equals: 6.
	1 to: 6 do: [ :each | 
		self assert: (ioBuffer buffer at: offset + each - 1) equals: each ].
	ioBuffer advanceReadPointer: 6.
	self assert: ioBuffer availableForReading equals: 0.
	ioBuffer compact.
	self assert: ioBuffer isEmpty     
	! !

!ZdcIOBufferTest methodsFor: 'tests' stamp: ''!
testBivalentReading
	| data ioBuffer buffer |
	data := 'some string'.
	
	ioBuffer := ZdcIOBuffer on: data.
	ioBuffer advanceWritePointer: data size.
	buffer := ByteArray new: data size.
	ioBuffer readInto: buffer startingAt: 1 count: data size.
	self assert: buffer equals: data asByteArray.
	
	ioBuffer := ZdcIOBuffer on: data asByteArray.
	ioBuffer advanceWritePointer: data size.
	buffer := String new: data size.
	ioBuffer readInto: buffer startingAt: 1 count: data size.
	self assert: buffer equals: data.
! !

!ZdcIOBufferTest methodsFor: 'tests' stamp: ''!
testAdvanceWritePointer
	| ioBuffer offset |
	ioBuffer := ZdcIOBuffer on: (ByteArray new: 10).
	self assert: ioBuffer isEmpty.
	offset := ioBuffer freeSpaceStart.
	1 to: 6 do: [ :each |
		ioBuffer buffer at: offset + each - 1 put: each ].
	ioBuffer advanceWritePointer: 6.
	self deny: ioBuffer isEmpty.
	self assert: ioBuffer availableForReading equals: 6.
	self assert: ioBuffer contents equals: #[1 2 3 4 5 6]
	! !

!ZdcIOBufferTest methodsFor: 'tests - compact' stamp: ''!
testCompactAtEnd
	| ioBuffer |
	ioBuffer := ZdcIOBuffer on: (ByteArray new: 10).
	10 timesRepeat: [ ioBuffer nextPut: 1 ].
	self assert: ioBuffer gapAtFront isZero.
	10 timesRepeat: [ ioBuffer next ].
	self assert: ioBuffer isFull.
	self assert: ioBuffer gapAtFront equals: 10.
	ioBuffer compact.
	self assert: ioBuffer isEmpty
	
		! !

!ZdcIOBufferTest methodsFor: 'tests' stamp: ''!
testReadIntoStartingAtCount
	| data ioBuffer string |
	data := 'abcdefghijkl'.
	ioBuffer := ZdcIOBuffer on: data.
	ioBuffer advanceWritePointer: 12.
	string := String new: 12.
	ioBuffer readInto: string startingAt: 1 count: 4.
	ioBuffer readInto: string startingAt: 5 count: 4.
	ioBuffer readInto: string startingAt: 9 count: 4.
	self assert: string equals: data! !

!ZdcIOBufferTest methodsFor: 'tests' stamp: ''!
testWriting
	| ioBuffer |
	ioBuffer := ZdcIOBuffer on: (ByteArray new: 10).
	self assert: ioBuffer isEmpty.
	self assert: ioBuffer size isZero.
	self assert: ioBuffer availableForWriting equals: 10.
	1 to: 6 do: [ :each | ioBuffer nextPut: each ].
	self assert: ioBuffer contents equals: #[1 2 3 4 5 6].
	self assert: ioBuffer size equals: 6.
	self assert: ioBuffer availableForWriting equals: 4.
	7 to: 10 do: [ :each | ioBuffer nextPut: each ].
	self assert: ioBuffer isFull.
	self should: [ ioBuffer nextPut: 1 ] raise: Error! !

!ZdcIOBufferTest methodsFor: 'tests - compact' stamp: ''!
testCompactAtBeginning
	| ioBuffer |
	ioBuffer := ZdcIOBuffer on: (ByteArray new: 10).
	ioBuffer compact.
	self assert: ioBuffer isEmpty.
	self assert: ioBuffer availableForWriting equals: 10.
	1 to: 6 do: [ :each | ioBuffer nextPut: each ].
	ioBuffer compact.
	self assert: ioBuffer availableForReading equals: 6.
	self assert: ioBuffer availableForWriting equals: 4.
	self assert: ioBuffer gapAtFront isZero! !

!ZdcOptimizedSocketStream commentStamp: ''!
I am ZnOptimizedSocketStream.

I am a ZdcSimpleSocketStream.

I re-implement the critical operations dealing with bulk input and output 
more efficiently to work with buffer sized chunks, bypassing #next and #nextPut:!
!ZdcOptimizedSocketStream methodsFor: 'stream in' stamp: ''!
upToEnd
	"Read bytes until the stream is atEnd and return them as a ByteArray. Overwritten, optimized"

	^ self collectionSpecies 
		streamContents: [ :writeStream |
			[	
				readBuffer isEmpty ifFalse: [
					writeStream 
						next: readBuffer availableForReading 
						putAll: readBuffer buffer 
						startingAt: readBuffer contentsStart.
					readBuffer advanceReadPointer: readBuffer availableForReading ].   
				self atEnd ] whileFalse: [ 
					readBuffer isEmpty 
						ifTrue: [ 
							[ self fillReadBuffer ] 
								on: ConnectionClosed 
								do: [ :exception | exception return ] ] ] ]! !

!ZdcOptimizedSocketStream methodsFor: 'stream out' stamp: ''!
next: count putAll: collection startingAt: offset
	"Write count bytes from collection starting at offset. Overwritten, optimized"
	
	| totalWritten |
	totalWritten := 0.
	[ | toWrite |
		toWrite := (count - totalWritten) min: writeBuffer availableForWriting.
		writeBuffer next: toWrite putAll: collection startingAt: offset + totalWritten.
		totalWritten := totalWritten + toWrite.
		totalWritten = count ] whileFalse: [ self flushWriteBuffer ]! !

!ZdcOptimizedSocketStream methodsFor: 'stream in' stamp: ''!
skip: count
	"Skip over count bytes. Overwritten, optimized"
	
	| skipCount |
	skipCount := 0.
	[ | leftToSkip skipping |
		leftToSkip := count - skipCount.
		skipping := readBuffer availableForReading min: leftToSkip.
		readBuffer advanceReadPointer: skipping.
	     (skipCount := skipCount + skipping) = count ] whileFalse: [ self fillReadBuffer ]! !

!ZdcOptimizedSocketStream methodsFor: 'stream in' stamp: ''!
upTo: value 
	"Read bytes upto but not including value and return them as a ByteArray.
	If value is not found, return the entire contents of the stream. Overwritten, optimized"
	
	^ self collectionSpecies 
		streamContents: [ :writeStream |
			[ | position |
				position := 0.
				readBuffer isEmpty ifFalse: [ | count |
					position := readBuffer buffer indexOf: value startingAt: readBuffer contentsStart.
					count := position = 0 ifTrue: [ readBuffer availableForReading ] ifFalse: [ position - readBuffer contentsStart ].
					writeStream next: count putAll: readBuffer buffer startingAt: readBuffer contentsStart.
					readBuffer advanceReadPointer: count.
					position = 0 ifFalse: [ readBuffer advanceReadPointer: 1 ] ].   
				position ~= 0 or: [ self atEnd ] ] whileFalse: [ 
					readBuffer isEmpty ifTrue: [ self fillReadBuffer ] ] ]! !

!ZdcOptimizedSocketStream methodsFor: 'stream in' stamp: ''!
readInto: collection startingAt: offset count: requestedCount
	"Read requestedCount elements into collection starting at offset,
	returning the number of elements read. Overwritten, optimized"
	
	| totalRead |
	totalRead := 0.
	[ | read |
		(read := readBuffer availableForReading min: (requestedCount - totalRead)) > 0
			ifTrue: [  
				collection 
					replaceFrom: offset + totalRead to: offset + totalRead + read - 1 
					with: readBuffer buffer startingAt: readBuffer contentsStart.
				readBuffer advanceReadPointer: read.
				totalRead := totalRead + read ].
		totalRead = requestedCount or: [ self isConnected not ] ] whileFalse: [ self fillReadBuffer ].   
	^ totalRead! !

!ZdcOptimizedSocketStreamTest commentStamp: ''!
ZdcOptimizedSocketStreamTests tests ZdcOptimizedSocketStream!
!ZdcOptimizedSocketStreamTest methodsFor: 'accessing' stamp: ''!
socketStreamClass
	^ ZdcOptimizedSocketStream ! !

!ZdcOptimizedSocketStreamTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ false! !

!ZdcPluginMissing commentStamp: ''!
I am ZdcPluginMissing, signaled when a plugin required by Zodiac is missing.

You can find more information on Zodiac's website

	http://zdc.stfx.eu!
!ZdcPluginMissing methodsFor: 'printing' stamp: ''!
messageText
	^ 'SSL/TLS plugin initailization failed (VM plugin missing ? OS libraries missing ?)'! !

!ZdcPluginSSLSession commentStamp: ''!
I am ZdcPluginSSLSession, an object managing the secure communication between two parties.

I am a ZdcAbstractSSLSession.

I am a wrapper for the SqueakSSL plugin.

I am probably too primitive to be used directly, see ZnSecureSocketStream for a higher level client.

Ackowledgement: based on the original SqueakSSL code.!
!ZdcPluginSSLSession methodsFor: 'operations' stamp: ''!
encrypt: srcBuf from: start to: stop into: dstBuf
	"Encrypt the input in srcBuf from start to stop into dstBuf."

	^ self primitiveSSL: handle encrypt: srcBuf startingAt: start count: stop - start + 1 into: dstBuf! !

!ZdcPluginSSLSession methodsFor: 'accessing' stamp: ''!
serverName
	"Get the Server Name Indication (SNI) property"

	^ self primitiveSSL: handle getStringProperty: 2! !

!ZdcPluginSSLSession methodsFor: 'accessing' stamp: ''!
logging

	^ ((self primitiveSSL: handle getIntProperty: self constantsSQSSL_PROP_LOGLEVEL) = 0) not! !

!ZdcPluginSSLSession methodsFor: 'accessing' stamp: ''!
sslState
	"Returns the current state of the SSL connection:
		0 - Unused
		1 - In accept handshake
		2 - In connect handshake
		3 - Connected"
		
	^ self primitiveSSL: handle getIntProperty: 2
		! !

!ZdcPluginSSLSession methodsFor: 'primitives' stamp: ''!
primitiveSSL: sslHandle decrypt: srcbuf startingAt: start count: length into: dstbuf
	"Primitive. Takes incoming data for decryption and continues to decrypt data.
	Returns the number of bytes produced in the output"

	<primitive: 'primitiveDecrypt' module: 'SqueakSSL'>
	
	^ self primitiveFailed! !

!ZdcPluginSSLSession methodsFor: 'accessing' stamp: ''!
peerCertificateName
	"Returns the certificate name of the remote peer.
	The method only returns a name if the certificate has been verified"

	^ self primitiveSSL: handle getStringProperty: 0! !

!ZdcPluginSSLSession methodsFor: 'primitives' stamp: ''!
primitiveSSL: sslHandle setStringProperty: propID toValue: aString
	"Primitive. Sets a string property in an SSL session"

	<primitive: 'primitiveSetStringProperty' module: 'SqueakSSL'>
	
	^ self primitiveFailed! !

!ZdcPluginSSLSession methodsFor: 'testing' stamp: ''!
isConnected
	"Returns true if the SSL handshake has been completed"

	^ self sslState = 3! !

!ZdcPluginSSLSession methodsFor: 'initialization' stamp: ''!
destroy
	"Destroys the platform handle in the VM plugin"

	handle isNil ifTrue: [ ^ self ].  
	self primitiveSSLDestroy: handle.
	handle := nil! !

!ZdcPluginSSLSession methodsFor: 'accessing' stamp: ''!
certificateVerificationState
	"Returns the certificate verification bits. The returned value indicates
	whether the certificate is valid. The two standard values are:
		0   - The certificate is valid
		-1  - No certificate has been provided by the peer
	Otherwise, the result is a bit mask of the following values:
		1   - If set, there is an unspecified issue with the cert (generic error)
		2   - If set, the root CA is untrusted (usually a self-signed cert)
		4   - If set, the certificate is expired
		8   - If set, the certificate is used for the wrong purpose
		16 - If set, the CN of the certificate is invalid
		32 - If set, the certificate was revoked"
		
	^ self primitiveSSL: handle getIntProperty: 3! !

!ZdcPluginSSLSession methodsFor: 'accessing' stamp: ''!
certificateName
	"The name of the local certificate to provide to the remote peer"

	^ self primitiveSSL: handle getStringProperty: 1! !

!ZdcPluginSSLSession methodsFor: 'accessing' stamp: ''!
serverName: serverName
	"Set the Server Name Indication (SNI) to serverName, 
	the fully qualified domain name of the host to connect to.
	This should be set by a client before #connect is attempted."
	
	^ self primitiveSSL: handle setStringProperty: 2 toValue: (serverName ifNil: [''])! !

!ZdcPluginSSLSession methodsFor: 'accessing' stamp: ''!
certificateName: aString
	"Sets the name of the local certificate to provide to the remote peer.
	OpenSSL: The name is the full path to a .pem file.
	WinSSL: The name is matched against the 'subject' of a certificate in the cert store"

	^ self primitiveSSL: handle setStringProperty: 1 toValue: (aString ifNil: [ '' ])! !

!ZdcPluginSSLSession methodsFor: 'initialization' stamp: ''!
initialize
	"Initialize the receiver"

	[ handle := self primitiveSSLCreate ]
		on: PrimitiveFailed 
		do: [ :exception |
			"Give a more human friendly error message"
			ZdcPluginMissing signal ].
	self logging: false
! !

!ZdcPluginSSLSession methodsFor: 'accessing' stamp: ''!
logging: boolean

	self primitiveSSL: handle setIntProperty: self constantsSQSSL_PROP_LOGLEVEL toValue: (boolean ifFalse: [ 0 ] ifTrue: [ 1 ]).
! !

!ZdcPluginSSLSession methodsFor: 'primitives' stamp: ''!
primitiveSSL: sslHandle accept: srcbuf startingAt: start count: length into: dstbuf
	"Primitive. Starts or continues a server handshake using the provided data.
	Will eventually produce output to be sent to the client.
	Returns:
		> 0   Number of bytes to be sent to the server
		= 0   Success. The connection is established
		= -1  More input is required
		< -1  Other errors"
		
	<primitive: 'primitiveAccept' module: 'SqueakSSL'>
	
	^ self primitiveFailed! !

!ZdcPluginSSLSession methodsFor: 'operations' stamp: ''!
decrypt: srcBuf from: start to: stop into: dstBuf
	"Decrypt the input in srcBuf from start to stop into dstBuf."

	^ self primitiveSSL: handle decrypt: srcBuf startingAt: start count: stop - start + 1 into: dstBuf! !

!ZdcPluginSSLSession methodsFor: 'accessing' stamp: ''!
pluginVersion
	"Returns the version of the plugin"

	^ self primitiveSSL: handle getIntProperty: 0! !

!ZdcPluginSSLSession methodsFor: 'primitives' stamp: ''!
primitiveSSL: sslHandle encrypt: srcbuf startingAt: start count: length into: dstbuf
	"Primitive. Encrypts the incoming buffer into the result buffer.
	Returns the number of bytes produced as a result"

	<primitive: 'primitiveEncrypt' module: 'SqueakSSL'>
	
	^ self primitiveFailed! !

!ZdcPluginSSLSession methodsFor: 'primitives' stamp: ''!
primitiveSSL: sslHandle connect: srcbuf startingAt: start count: length into: dstbuf
	"Primitive. Starts or continues a client handshake using the provided data.
	Will eventually produce output to be sent to the server.
	Returns:
		> 0   Number of bytes to be sent to the server
		= 0   Success. The connection is established
		= -1  More input is required
		< -1  Other errors"
	
	<primitive: 'primitiveConnect' module: 'SqueakSSL'>
	
	^ self primitiveFailed! !

!ZdcPluginSSLSession methodsFor: 'primitives' stamp: ''!
primitiveSSL: sslHandle getStringProperty: propID
	"Primitive. Returns a string property from an SSL session"

	<primitive: 'primitiveGetStringProperty' module: 'SqueakSSL'>
	
	^ self primitiveFailed! !

!ZdcPluginSSLSession methodsFor: 'primitives' stamp: ''!
primitiveSSL: sslHandle setIntProperty: propID toValue: anInteger
	"Primitive. Sets an integer property in an SSL session"

	<primitive: 'primitiveSetIntProperty' module: 'SqueakSSL'>
	
	^ self primitiveFailed! !

!ZdcPluginSSLSession methodsFor: 'primitives' stamp: ''!
primitiveSSLDestroy: sslHandle
	"Primitive. Destroys the SSL session handle in the VM plugin"

	<primitive: 'primitiveDestroy' module: 'SqueakSSL'>
	
	^ self primitiveFailed! !

!ZdcPluginSSLSession methodsFor: 'private' stamp: ''!
constantsSQSSL_PROP_LOGLEVEL

	^ 1! !

!ZdcPluginSSLSession methodsFor: 'operations' stamp: ''!
accept: srcBuf from: start to: stop into: dstBuf
	"Start or continue the server handshake using the given input token"

	^ self primitiveSSL: handle accept: srcBuf startingAt: start count: stop - start + 1 into: dstBuf! !

!ZdcPluginSSLSession methodsFor: 'primitives' stamp: ''!
primitiveSSL: sslHandle getIntProperty: propID
	"Primitive. Returns a string property from an SSL session"

	<primitive: 'primitiveGetIntProperty' module: 'SqueakSSL'>
	
	^ self primitiveFailed! !

!ZdcPluginSSLSession methodsFor: 'primitives' stamp: ''!
primitiveSSLCreate
	"Primitive. Creates and returns a new SSL handle in the VM plugin"

	<primitive: 'primitiveCreate' module: 'SqueakSSL'>
	
	^ self primitiveFailed! !

!ZdcPluginSSLSession methodsFor: 'operations' stamp: ''!
connect: srcBuf from: start to: stop into: dstBuf
	"Start or continue the client handshake using the given input token"

	^ self primitiveSSL: handle connect: srcBuf startingAt: start count: stop - start + 1 into: dstBuf! !

!ZdcPluginSSLSession methodsFor: 'initialization' stamp: ''!
enableLogging
	"Enable logging of the native code inside the plugin"
	
	self logging: true! !

!ZdcPluginSSLSessionTest commentStamp: ''!
ZdcPluginSSLSession Tests tests ZdcPluginSSLSession.
!
!ZdcPluginSSLSessionTest methodsFor: 'running' stamp: ''!
tearDown

	session destroy.
	session := nil.
	super tearDown ! !

!ZdcPluginSSLSessionTest methodsFor: 'tests' stamp: ''!
testCertificateName
	
	self assert: session certificateName equals: nil.
	
	session certificateName: 'myCert.pem'.
	
	self assert: session certificateName equals: 'myCert.pem'.
	
	session certificateName: 'otherCert.pem'.
	
	self assert: session certificateName equals: 'otherCert.pem'.
	
	session certificateName: nil.
	
	self assert: session certificateName equals: nil.
! !

!ZdcPluginSSLSessionTest methodsFor: 'tests' stamp: ''!
testServerName
	
	[ session serverName; serverName: nil ] on: PrimitiveFailed do: [ ^ self skip ].
	
	self assert: session serverName equals: nil.
	
	session serverName: 'pharo.org'.
	
	self assert: session serverName equals: 'pharo.org'.
	
	session serverName: 'smalltalkhub.com'.
	
	self assert: session serverName equals: 'smalltalkhub.com'.
	
	session serverName: nil.
	
	self assert: session serverName equals: nil.
! !

!ZdcPluginSSLSessionTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	session := ZdcPluginSSLSession new! !

!ZdcReferenceSocketStreamTest commentStamp: ''!
ZdcReferenceSocketStreamTests test the reference SocketStream in the image!
!ZdcReferenceSocketStreamTest methodsFor: 'accessing' stamp: ''!
socketStreamClass
	^ SocketStream ! !

!ZdcReferenceSocketStreamTest methodsFor: 'private' stamp: ''!
openConnectionToHostNamed: host port: port
	| stream |
	stream := super openConnectionToHostNamed: host port: port.
	self setReferenceSocketStreamOptions: stream.
	^ stream! !

!ZdcReferenceSocketStreamTest methodsFor: 'private' stamp: ''!
openConnectionToHost: host port: port
	| stream |
	stream := super openConnectionToHost: host port: port.
	self setReferenceSocketStreamOptions: stream.
	^ stream! !

!ZdcReferenceSocketStreamTest methodsFor: 'private' stamp: ''!
socketStreamOn: socket
	| stream |
	stream := super socketStreamOn: socket.
	self setReferenceSocketStreamOptions: stream.
	^ stream	! !

!ZdcReferenceSocketStreamTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ false! !

!ZdcSecurePOP3Client commentStamp: ''!
I am ZdcSecurePOP3Client.

I open a ZdcSecureSocketStream to the POP3 server and connect it at the SSL level.

ZdcSecurePOP3Client
	retrieveMessagesFromGMailAccount: '<your-name>@gmail.com'
	password: '<your-password>'
	limit: 5.!
!ZdcSecurePOP3Client methodsFor: 'private' stamp: ''!
ensureConnection
	"Overwritten & refactored"
		
	self isConnected ifTrue: [ ^ self ].
	self stream ifNotNil: [ self stream close ].

	self setupStream.
	self checkResponse.
	self login! !

!ZdcSecurePOP3Client methodsFor: 'private - protocol' stamp: ''!
fetchNextResponse
	self lastResponse: self nextLineFromStream! !

!ZdcSecurePOP3Client methodsFor: 'private - protocol' stamp: ''!
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 nextLineFromStream.
		(chunk beginsWith: '.')
			ifTrue: [ response nextPutAll: (chunk copyFrom: 2 to: chunk size); cr ]
			ifFalse: [ response nextPutAll: chunk; cr ].
		done := (chunk = '.') ].
	^ response contents
! !

!ZdcSecurePOP3Client methodsFor: 'accessing' stamp: ''!
stream: aStream
	super stream: aStream.
	lineReader := ZnLineReader on: self stream! !

!ZdcSecurePOP3Client methodsFor: 'private - protocol' stamp: ''!
sendCommand: aString
	self logVerbose: aString.
	self stream 
		nextPutAll: aString;
		nextPutAll: #[13 10];
		flush
! !

!ZdcSecurePOP3Client methodsFor: 'private' stamp: ''!
logVerbose: aString
	"self log: aString; log: Character cr"! !

!ZdcSecurePOP3Client methodsFor: 'private' stamp: ''!
setupStream
	self setupStreamForSSL! !

!ZdcSecurePOP3Client methodsFor: 'private' stamp: ''!
setupStreamForSSL
	self stream: (ZdcSecureSocketStream openConnectionToHost: self host port: self port).
	self stream connect.
	self logVerbose: 'SSL Connect OK.'! !

!ZdcSecurePOP3Client methodsFor: 'private - protocol' stamp: ''!
nextLineFromStream
	| line |
	line := lineReader nextLine.
	self logVerbose: line.
	^ line! !

!ZdcSecurePOP3Client class methodsFor: 'examples' stamp: ''!
retrieveMessagesFromGMailAccount: accountAddress password: password limit: limit
	| pop3Client messages messageCount |
	(pop3Client := self openOnHostNamed: 'smtp.gmail.com' port: self defaultPortForSSL)
		loginUser: accountAddress password: password.
	messages := OrderedCollection new.
	messageCount := pop3Client messageCount.
	messageCount to: ((messageCount - limit) max: 0) + 1 by: -1 do: [ :each |
		messages add: (pop3Client retrieveMessage: each) ].
	pop3Client
		quit;
		close.
	^ messages
! !

!ZdcSecurePOP3Client class methodsFor: 'constants' stamp: ''!
defaultPortForSSL
	^ 995! !

!ZdcSecureSMTPClient commentStamp: ''!
I am ZdcSecureSMTPClient.

I open a ZdcSecureSocketStream to the SMTP server and connect it at the SSL level.

| mailMessage |
mailMessage := MailMessage empty.
mailMessage setField: 'subject' toString: 'ZdcSecureSMTPClient Test'.
mailMessage body: (MIMEDocument contentType: 'text/plain' content: 'This is test from Pharo Smalltalk').
ZdcSecureSMTPClient
	sendUsingGMailAccount: '<your-name>@gmail.com' 
	password: '<your-password>'
	to: '<email-address>' 
	message: mailMessage!
!ZdcSecureSMTPClient methodsFor: 'private' stamp: ''!
ensureConnection
	"Overwritten & refactored"
		
	self isConnected ifTrue: [ ^ self].
	self stream ifNotNil: [ self stream close ].
	self setupStream.
	"regarding RFC2487-5.2 the state after SSL negotiation is to be reset to the state after the
	220 server greeting. EHLO command is next which is issued in the following login method  "
	self login! !

!ZdcSecureSMTPClient methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self useSSL! !

!ZdcSecureSMTPClient methodsFor: 'initialize-release' stamp: ''!
useStartTLS
	variant := #startTLS! !

!ZdcSecureSMTPClient methodsFor: 'private - protocol' stamp: ''!
fetchNextResponse
	"The FTP and similar protocols allow multi-line responses.
	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."

	| response result firstLine |
	result := '' writeStream.
	firstLine := self nextLineFromStream.
	result nextPutAll: firstLine.
	(self responseIsContinuation: firstLine) 
		ifTrue: [
			"continued over multiple lines. Discard continuation lines."
			[response := self nextLineFromStream.
			response ifNil: [ ^ nil ].
			response size > 3 and: 
					[ (response copyFrom: 1 to: 3) = (firstLine copyFrom: 1 to: 3) 
						and: [ (response at: 4) = Character space ] ] ] whileFalse: [
							result cr; nextPutAll: response ] ].
	self lastResponse: result contents! !

!ZdcSecureSMTPClient methodsFor: 'private' stamp: ''!
setupStreamForStartTLS
	"See http://www.ietf.org/rfc/rfc3207.txt for how to setup a secure connection"

	self stream: (SocketStream openConnectionToHost: self host port: self port).
	self checkResponse.
	self initiateSession.
	self requireStartTLS.
	self startTLS! !

!ZdcSecureSMTPClient methodsFor: 'private - protocol' stamp: ''!
startTLS
	"Send a STARTTLS command and after the response, 
	switch to a SecureSocketStream and do the client handshake"
	
	self sendCommand: 'STARTTLS'.
	self checkResponse.	
	self stream: (ZdcSecureSocketStream on: self stream socket).
	self stream connect.
	self logVerbose: 'SSL Connect OK.'! !

!ZdcSecureSMTPClient methodsFor: 'private - protocol' stamp: ''!
alternativeLogin
	self initiateSession. "send EHLO first"
	self user ifNil: [ ^ self ].
	self sendCommand: 'AUTH LOGIN'.
	self checkResponse.
	self sendCommand: (self encodeString: self user).
	self checkResponse.
	self sendCommand: (self encodeString: self password).
	self checkResponse! !

!ZdcSecureSMTPClient methodsFor: 'accessing' stamp: ''!
stream: aStream
	super stream: aStream.
	lineReader := ZnLineReader on: self stream! !

!ZdcSecureSMTPClient methodsFor: 'initialize-release' stamp: ''!
useSSL
	variant := #ssl! !

!ZdcSecureSMTPClient methodsFor: 'private - protocol' stamp: ''!
sendCommand: aString
	self logVerbose: aString.
	self stream 
		nextPutAll: aString;
		nextPutAll: #[13 10];
		flush
! !

!ZdcSecureSMTPClient methodsFor: 'testing' stamp: ''!
isStartTLS
	^ variant = #startTLS! !

!ZdcSecureSMTPClient methodsFor: 'private' stamp: ''!
logVerbose: aString
	"self log: aString; log: Character cr"! !

!ZdcSecureSMTPClient methodsFor: 'private - protocol' stamp: ''!
requireStartTLS
	(self lastResponse includesSubstring: 'STARTTLS')
		ifFalse: [ ^ self error: 'Server does not seem to support STARTTLS' ].
! !

!ZdcSecureSMTPClient methodsFor: 'testing' stamp: ''!
isSSL
	^ variant = #ssl! !

!ZdcSecureSMTPClient methodsFor: 'private' stamp: ''!
setupStream
	variant = #ssl ifTrue: [ ^ self setupStreamForSSL ].
	variant = #startTLS ifTrue: [ ^ self setupStreamForStartTLS ]! !

!ZdcSecureSMTPClient methodsFor: 'private' stamp: ''!
setupStreamForSSL
	self stream: (ZdcSecureSocketStream openConnectionToHost: self host port: self port).
	self stream connect.
	self logVerbose: 'SSL Connect OK.'.
	"as we connect directly with SSL the first message will be a 220 server greeting"
	self checkResponse.
! !

!ZdcSecureSMTPClient methodsFor: 'private - protocol' stamp: ''!
nextLineFromStream
	| line |
	line := lineReader nextLine.
	self logVerbose: line.
	^ line! !

!ZdcSecureSMTPClient class methodsFor: 'constants' stamp: ''!
defaultPortForSSL
	^ 465! !

!ZdcSecureSMTPClient class methodsFor: 'examples' stamp: ''!
sendUsingGMailAccount: senderAddress password: password to: receiverAddress message: mailMessage
	| smtpClient |
	(smtpClient := self new)
		user: senderAddress; 
		password: password.
	smtpClient openOnHost: (NetNameResolver addressForName: 'smtp.gmail.com') port: 465.
	mailMessage setField: 'from' toString: senderAddress.
	mailMessage setField: 'to' toString: receiverAddress.
	^ smtpClient 
		mailFrom: senderAddress to: { receiverAddress } text: mailMessage text;
		quit; 
		close;
		yourself
! !

!ZdcSecureSMTPClient class methodsFor: 'constants' stamp: ''!
defaultPortForStartTLS
	^ 587! !

!ZdcSecureSocketStream commentStamp: ''!
I am ZdcSecureSocketStream, a binary read/write stream for SSL communication.

I am a ZdcOptimizedSocketStream.

When I am used as a client, call #connect on me before using me as a normal stream.

When I am used as a server, call #accept on me before using me as a normal stream.

Currently, certificate management is ignored.
!
!ZdcSecureSocketStream methodsFor: 'accessing' stamp: ''!
sslSession
	"Return the underlying ZdcAbstractSSLSession object 
	that we use for encryption and decryption, 
	as well as connection setup handshaking, connect and accept"
	
	sslSession isNil ifTrue: [ sslSession := self sslSessionClass new ].
	^ sslSession! !

!ZdcSecureSocketStream methodsFor: 'private - out' stamp: ''!
flushBytes: bytes startingAt: offset count: count
	"Ask to write count bytes starting from offset. Wait. Fail if not successful
	Overwritten: first encrypt the data, then send it to the socket using a super call."
	
	| remaining currentOffset |
	self isConnected ifFalse: [ ConnectionClosed signal: 'Cannot write data' ].  
	remaining := count.
	currentOffset := offset.
	[ remaining > 0 ] whileTrue: [ | chunkCount writeCount |
		self resetEncryptedBuffers.
		chunkCount := 4096 min: remaining.
		writeCount := self sslSession encrypt: bytes from: currentOffset to: currentOffset + chunkCount - 1 into: out.
		writeCount < 0 ifTrue: [ ^ self sslException: 'encrypt failed' code: writeCount ].
		self flushEncryptedBytes: out startingAt: 1 count: writeCount.
		remaining := remaining - chunkCount.
		currentOffset := currentOffset + chunkCount ]! !

!ZdcSecureSocketStream methodsFor: 'initialize-release' stamp: ''!
initialize 
	super initialize.
	connecting := false! !

!ZdcSecureSocketStream methodsFor: 'private - out' stamp: ''!
flushEncryptedBytes: bytes startingAt: offset count: count
	"Write encrypted bytes to the network."
	
	^ super flushBytes: bytes startingAt: offset count: count! !

!ZdcSecureSocketStream methodsFor: 'private - in' stamp: ''!
fillEncryptedBytes: bytes startingAt: offset count: count
	"Read encrypted bytes from the network. Do not wait."
	
	^ super fillBytes: bytes startingAt: offset count: count! !

!ZdcSecureSocketStream methodsFor: 'testing' stamp: ''!
isDataAvailable
	"Return true when there is data available for reading.
	This does not block."
	
	readBuffer isEmpty ifFalse: [ ^ true ].
	socket notNil
		ifTrue: [
			"Try reading (there might stil be data in the SSL session) and test again"
			[ self fillReadBufferNoWait ]
				on: ConnectionClosed 
				do: [ ^ false ].
			readBuffer isEmpty ifFalse: [ ^ true ] ].   
	^ false! !

!ZdcSecureSocketStream methodsFor: 'private' stamp: ''!
resetEncryptedBuffers
	"Not necessary, but useful for debugging"
	
	in atAllPut: 0.
	out atAllPut: 0! !

!ZdcSecureSocketStream methodsFor: 'ssl' stamp: ''!
accept
	"Do the SSL server handshake."
	
	| count result |
	self resetEncryptedBuffers.
	count := 0.
	connecting := true.
	[ self sslSession isConnected ] whileFalse: [
		count := self readEncryptedBytes: in startingAt: 1 count: in size.
		result := self sslSession accept: in from: 1 to: count into: out.
		result < -1 ifTrue: [ 
			^ self sslException: 'accept failed' code: result ].
		result > 0 ifTrue: [ 
			self flushEncryptedBytes: out startingAt: 1 count: result ] ].
	connecting := false! !

!ZdcSecureSocketStream methodsFor: 'initialize-release' stamp: ''!
close
	"Close the stream, flush if necessary. 
	Destory the SSLSession object."

	[ super close ] ensure: [ 
		sslSession ifNotNil: [
			sslSession destroy.
			sslSession := nil ].
		ZdcByteArrayManager current recycle: in; recycle: out.
		in := out := nil ]! !

!ZdcSecureSocketStream methodsFor: 'initialize-release' stamp: ''!
initializeBuffers
	"The maximum payload message length of a TLS record is 16Kb,
	add a margin for the header and trailer."
	
	readBuffer := ZdcIOBuffer onByteArrayOfSize: 16 * 1024.
	writeBuffer := ZdcIOBuffer onByteArrayOfSize: 4 * 1024.
	in := ZdcByteArrayManager current byteArrayOfSize: 4096 zero: false.
	out := ZdcByteArrayManager current byteArrayOfSize: (16 + 1) * 1024 zero: false
! !

!ZdcSecureSocketStream methodsFor: 'testing' stamp: ''!
isConnected
	"Are we connected at the socket level ?
	Has the SSL handshake been done successfully ?"

	^ super isConnected 
		and: [ sslSession notNil and: [ connecting or: [ sslSession isConnected ] ] ]! !

!ZdcSecureSocketStream methodsFor: 'testing' stamp: ''!
atEnd
	"I am atEnd when there is no more data to be read and there never will be.
	This means that readBuffer must be empty, there must be no more unread data 
	available at the socket, and the socket must be closed"
	
	readBuffer isEmpty ifFalse: [ ^ false ].
	socket notNil
		ifTrue: [
			"Try reading (there might stil be data in the SSL session) and test again"
			[ self fillReadBufferNoWait ]
				on: ConnectionClosed 
				do: [ ^ true ].
			readBuffer isEmpty ifFalse: [ ^ false ] ].   
	^ self isConnected not! !

!ZdcSecureSocketStream methodsFor: 'private - in' stamp: ''!
fillBytes: bytes startingAt: offset count: count
	"Ask to read count elements into bytes starting at offset. Do not wait. Return read count.
	Overwritten: decrypt and if necessary ask the socket for encrypted data using a super call."
	
	| processedCount inCount |
	self resetEncryptedBuffers.
	"The SSL session might contain left over state, get it"
	processedCount := self sslSession decrypt: in from: 1 to: 0 into: out.	
	"We explicitly ignore possible errors here"
	processedCount > 0
		ifTrue: [
			bytes replaceFrom: offset to: offset + processedCount - 1 with: out startingAt: 1.
			^ processedCount ].
	"Now, get new encrypted bytes and decrypt if needed"
	inCount := self fillEncryptedBytes: in startingAt: 1 count: in size.
	inCount > 0
		ifTrue: [ 
			processedCount := self sslSession decrypt: in from: 1 to: inCount into: out.
			"We explicitly ignore possible errors here"
			processedCount > 0
				ifTrue: [
					bytes replaceFrom: offset to: offset + processedCount - 1 with: out startingAt: 1.
					^ processedCount ] ].
	^ 0! !

!ZdcSecureSocketStream methodsFor: 'private' stamp: ''!
sslException: text code: code
	self error: 
		(String streamContents: [ :stream |
			stream << 'SSL Exception: ' << text << ' [code:'.
			stream print: code.
			stream << ']' ]) ! !

!ZdcSecureSocketStream methodsFor: 'ssl' stamp: ''!
connect
	"Do the SSL client handshake."
	
	| count result |
	self resetEncryptedBuffers.
	count := 0.
	connecting := true.
	[ (result := self sslSession connect: in from: 1 to: count into: out) = 0 ] whileFalse: [
		result < -1 ifTrue: [ 
			^ self sslException: 'connect failed' code: result ].
		result > 0 ifTrue: [ 
			self flushEncryptedBytes: out startingAt: 1 count: result ].
		count := self readEncryptedBytes: in startingAt: 1 count: in size ].
	connecting := false
	! !

!ZdcSecureSocketStream methodsFor: 'accessing' stamp: ''!
sslSessionClass
	^ ZdcPluginSSLSession ! !

!ZdcSecureSocketStream methodsFor: 'private - in' stamp: ''!
readEncryptedBytes: bytes startingAt: offset count: count
	"Read encrypted bytes from the network. Wait if necessary."
	
	| result |
	result := super fillBytes: bytes startingAt: offset count: count.
	^ result = 0
		ifTrue: [
			self socketWaitForData. "when successful, recurse, else signal exception"
			self readEncryptedBytes: bytes startingAt: offset count: count ]
		ifFalse: [
			result ]! !

!ZdcSecureSocketStreamTest commentStamp: ''!
ZdcSecureSocketStreamTests tests ZdcSecureSocketStream !
!ZdcSecureSocketStreamTest methodsFor: 'private' stamp: ''!
isNativeSSLPluginPresent
	"Return whether the SSL VM plugin can be instanciated and intialized."
	
	^ [ ZdcPluginSSLSession new destroy. true ]
			on: ZdcPluginMissing
			do: [ false ]! !

!ZdcSecureSocketStreamTest methodsFor: 'tests' stamp: ''!
testIsNativeSSLPluginPresent
	"This test succeeds when the SSL VM plugin can be instantiated and intialized."
	
	self 
		assert: self isNativeSSLPluginPresent 
		description: 'It seems that the native VM SSL plugin cannot be instantiated and initialized. (VM plugin missing ? OS libraries missing ?)'! !

!ZdcSecureSocketStreamTest methodsFor: 'tests' stamp: ''!
testPlain
	| query stream request response |
	self isNativeSSLPluginPresent ifFalse: [ ^ self ].
	query := 'Smalltalk'.
	stream := ZdcSecureSocketStream openConnectionToHostNamed: 'duckduckgo.com' port: 443.
	request := nil.
	response := [
		request := String streamContents: [ :out |
			out << 'GET /?q=' << query << ' HTTP/1.1' << String crlf.
			out << 'Host: duckduckgo.com' << String crlf.
			out << 'Connection: close' << String crlf.
			out << String crlf ].
		stream connect.
		stream nextPutAll: request asByteArray.
		stream flush.
		stream upToEnd asString.
	] ensure: [ stream close ].
	self assert: (response includesSubstring: '200 OK').      
	self assert: (response includesSubstring: 'Duck').
	self assert: (response includesSubstring: query).! !

!ZdcSimpleSocketStream commentStamp: ''!
I am ZdcSimpleSocketStream.

I am a ZdcAbstractSocketStream.

I do a minimal implementation of the requirements defined by my superclass.

I rely on the rather inefficient implementation of my superclass' methods, 
funneling all access through #next and #nextPut.!
!ZdcSimpleSocketStream methodsFor: 'private - out' stamp: ''!
flushBytes: bytes startingAt: offset count: count
	"Ask the socket to write count bytes starting from offset. Wait. Fail if not successful"
	
	| writeCount |
	self isConnected ifFalse: [ ConnectionClosed signal: 'Cannot write data' ].  
	writeCount := 0.
	[ | written |
		written := self socketSendData: bytes startingAt: offset + writeCount count: count - writeCount.
		(writeCount := writeCount + written) = count ] whileFalse: [
		self socketWaitForSendDone
			ifFalse: [ ConnectionTimedOut signal: 'Data send timed out.' ] ]! !

!ZdcSimpleSocketStream methodsFor: 'initialize-release' stamp: ''!
connectTo: hostAddress port: portNumber
	"Connect our socket to hostAddress:portNumber.
	Wait up to timeout for a connection"
	
	self socketConnectTo: hostAddress port: portNumber! !

!ZdcSimpleSocketStream methodsFor: 'private - in' stamp: ''!
fillReadBufferNoWait
	"Ask the socket to fill the read buffer with data. Do not wait for data."
	
	| readCount |
	readBuffer compact.
	readCount := self 
		fillBytes: readBuffer buffer 
		startingAt: readBuffer freeSpaceStart
		count: readBuffer availableForWriting .
	readBuffer advanceWritePointer: readCount.
	^ readCount! !

!ZdcSimpleSocketStream methodsFor: 'private - in' stamp: ''!
fillReadBuffer
	"Ask the socket to fill the read buffer with data. Wait for a data."
	
	self fillReadBufferNoWait.
	(readBuffer isEmpty and: [ self isConnected ])
		ifTrue: [ 
			[ self socketWaitForData ] on: ConnectionClosed do: [ ^ self ]. "when successful, recurse, else signal exception"
			self fillReadBuffer ]  ! !

!ZdcSimpleSocketStream methodsFor: 'private - out' stamp: ''!
flushWriteBuffer
	"Ask the socket to write all data in the write buffer. Fail if not successful"
	
	writeBuffer isEmpty ifTrue: [ ^ self ].  
	self 
		flushBytes: writeBuffer buffer
		startingAt: writeBuffer contentsStart
		count: writeBuffer availableForReading. 
	writeBuffer reset ! !

!ZdcSimpleSocketStream methodsFor: 'testing' stamp: ''!
isDataAvailable
	"Return true when there is data available for reading.
	This does not block."
	
	readBuffer isEmpty ifFalse: [ ^ true ].
	(socket notNil and: [ self socketIsDataAvailable ]) 
		ifTrue: [
			"Assuming there really is data available, read it and recurse"
			self fillReadBufferNoWait.
			^ self isDataAvailable ].   
	^ false! !

!ZdcSimpleSocketStream methodsFor: 'testing' stamp: ''!
isConnected
	"Are we connected at the socket level ?"
	
	^ socket notNil and: [ self socketIsConnected ]! !

!ZdcSimpleSocketStream methodsFor: 'testing' stamp: ''!
atEnd
	"I am atEnd when there is no more data to be read and there never will be.
	This means that readBuffer must be empty, there must be no more unread data 
	available at the socket, and the socket must be closed"
	
	readBuffer isEmpty ifFalse: [ ^ false ].
	(socket notNil and: [ self socketIsDataAvailable ]) 
		ifTrue: [
			"Assuming there really is data available, read it and recurse"
			self fillReadBufferNoWait.
			^ self atEnd ].   
	^ self isConnected not! !

!ZdcSimpleSocketStream methodsFor: 'private - in' stamp: ''!
fillBytes: bytes startingAt: offset count: count
	"Ask the socket to read count elements into bytes starting at offset. Do not wait. Return read count."
	
	self isConnected ifFalse: [ ConnectionClosed signal: 'Cannot read data' ].  
	^ self 
		socketReceiveDataInto: bytes 
		startingAt: offset 
		count: count! !

!ZdcSimpleSocketStream class methodsFor: 'instance creation' stamp: ''!
openConnectionToHost: hostIP port: portNumber timeout: timeout
	| platformSocket |
	platformSocket := Socket newTCP.
	^ (self on: platformSocket)
		timeout: timeout;
		connectTo: hostIP port: portNumber;
		yourself! !

!ZdcSimpleSocketStream class methodsFor: 'instance creation' stamp: ''!
openConnectionToHostNamed: hostName port: portNumber
	| platformSocket socketStream hostIP |
	platformSocket := Socket newTCP.
	socketStream := self on: platformSocket.
	hostIP := NetNameResolver addressForName: hostName timeout: socketStream timeout.
	^ socketStream 
		connectTo: hostIP port: portNumber;
		yourself! !

!ZdcSimpleSocketStream class methodsFor: 'instance creation' stamp: ''!
openConnectionToHost: hostIP port: portNumber
	| platformSocket |
	platformSocket := Socket newTCP.
	^ (self on: platformSocket)
		connectTo: hostIP port: portNumber;
		yourself! !

!ZdcSimpleSocketStreamTest commentStamp: ''!
ZdcSimpleSocketStreamTests tests ZdcSimpleSocketStream!
!ZdcSimpleSocketStreamTest methodsFor: 'accessing' stamp: ''!
socketStreamClass
	^ ZdcSimpleSocketStream ! !

!ZdcSimpleSocketStreamTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ false! !

!ZdcSocketStream commentStamp: ''!
I am ZdcSocketStream.

I am a ZdcOptimizedSocketStream.

I further optimize my superclass' methods dealing with bulk input and output
to transparently bypass the internal buffers when this makes sense.!
!ZdcSocketStream methodsFor: 'stream out' stamp: ''!
next: count putAll: collection startingAt: offset
	"Write count bytes from collection starting at offset. Overwritten, optimized"
	
	count <= (writeBuffer bufferSize / 8)  
		ifTrue: [
			count > writeBuffer availableForWriting ifTrue: [ self flushWriteBuffer ].  
			writeBuffer next: count putAll: collection startingAt: offset ]
		ifFalse: [
			self flushWriteBuffer.
			self flushBytes: collection startingAt: offset count: count ]! !

!ZdcSocketStream methodsFor: 'stream in' stamp: ''!
readInto: collection startingAt: offset count: requestedCount
	"Read requestedCount elements into collection starting at offset,
	returning the number of elements read. Overwritten, optimized"
	
	| totalRead read |
	totalRead := 0.
	(read := readBuffer availableForReading min: requestedCount) > 0
		ifTrue: [  
			collection replaceFrom: offset to: offset + read - 1 with: readBuffer buffer startingAt: readBuffer contentsStart.
			readBuffer advanceReadPointer: read.
			(totalRead := totalRead + read) = requestedCount ifTrue: [ ^ totalRead ] ].  
	[
		read := self fillBytes: collection startingAt: offset + totalRead count: requestedCount - totalRead.
		(totalRead := totalRead + read) = requestedCount or: [ self isConnected not ] ] whileFalse: [ 
			self socketWaitForData ].
	^ totalRead! !

!ZdcSocketStreamTest commentStamp: ''!
ZdcSocketStreamTests tests ZdcSocketStream!
!ZdcSocketStreamTest methodsFor: 'accessing' stamp: ''!
socketStreamClass
	^ ZdcSocketStream ! !

!ZdcSocketStreamTest class methodsFor: 'testing' stamp: ''!
isAbstract 
	^ false! !

!ZeroDivide commentStamp: ''!
I am ZeroDivide, an ArithmeticError that may be signaled when a mathematical division by 0 is attempted.!
!ZeroDivide methodsFor: 'exceptiondescription' stamp: ''!
dividend
	"Answer the number that was being divided by zero."

	^dividend! !

!ZeroDivide methodsFor: 'exceptionbuilder' stamp: ''!
dividend: argument
	"Specify the number that was being divided by zero."

	dividend := argument! !

!ZeroDivide methodsFor: 'exceptiondescription' stamp: ''!
isResumable
	"Determine whether an exception is resumable."

	^true! !

!ZeroDivide class methodsFor: 'signaling' stamp: ''!
signalWithDividend: aDividend

	^(self dividend: aDividend) signal! !

!ZeroDivide class methodsFor: 'exceptioninstantiator' stamp: ''!
dividend: argument
	^self new dividend: argument; yourself! !

!ZipArchive commentStamp: ''!
A ZipArchive represents an archive that is read and/or written using the PKZIP file format.

ZipArchive instances know how to read and write such archives; their members are subinstances of ZipArchiveMember.!
!ZipArchive methodsFor: 'accessing' stamp: 'nil'!
zipFileComment
	^zipFileComment asString! !

!ZipArchive methodsFor: 'archive operations' stamp: 'nil'!
extractAllTo: aDirectory informing: bar
	"Extract all elements to the given directory; notifying user via UI on progress and if existing files exist"

	^ self extractAllTo: aDirectory informing: bar overwrite: false! !

!ZipArchive methodsFor: 'accessing' stamp: 'nil'!
hasMemberSuchThat: aBlock
	"Answer whether we have a member satisfying the given condition"
	^self members anySatisfy: aBlock! !

!ZipArchive methodsFor: 'archive operations' stamp: 'nil'!
extractAllTo: aDirectory overwrite: overwriteAll
	"Extracts all elements to the given directory, overwriting existing entries if necessary. Does not use the UI for confirmation"

	self members do: [ :entry | entry extractInDirectory: aDirectory withoutInformingOverwrite: overwriteAll ]! !

!ZipArchive methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	writeEOCDOffset := writeCentralDirectoryOffset := 0.
	zipFileComment := ''! !

!ZipArchive methodsFor: 'archive operations' stamp: 'nil'!
addDeflateString: aString as: aFileName
	"Add a verbatim string under the given file name"

	| mbr |
	mbr := self addString: aString as: aFileName.
	mbr desiredCompressionMethod: CompressionDeflated.
	^ mbr! !

!ZipArchive methodsFor: 'private' stamp: 'nil'!
readMembersFrom: stream named: fileName
	
	[ | signature newMember |
		newMember := self memberClass newFromZipFile: stream named: fileName.
		signature := self readSignatureFrom: stream.
		signature = EndOfCentralDirectorySignature ifTrue: [ ^self ].
		signature = CentralDirectoryFileHeaderSignature
			ifFalse: [ ZipArchiveError signal: 'bad CD signature at ', (stream position - 4) printStringHex ].
		newMember readFrom: stream.
		newMember looksLikeDirectory ifTrue: [ newMember := newMember asDirectory ].
		self addMember: newMember.
	] repeat! !

!ZipArchive methodsFor: 'writing' stamp: 'nil'!
writeTo: stream
	members do: [ :member |
		member writeTo: stream.
		member endRead.
	].
	writeCentralDirectoryOffset := stream position.
	self writeCentralDirectoryTo: stream! !

!ZipArchive methodsFor: 'archive operations' stamp: 'nil'!
extractAllTo: aDirectory informing: aBar overwrite: allOverwrite
	"Extract all elements to the given directory. Informs user when a file exists and set to overwrite"

	| bar overwriteAll barValue |
	bar := aBar ifNil: [ DummySystemProgressItem new ].
	overwriteAll := allOverwrite.
	barValue := 0.
	self members
		select: #isDirectory
		thenDo: [ :entry | 
			| dir shouldUpdateInfos lastUpdate |
			lastUpdate := 0.
			(shouldUpdateInfos := (Time millisecondsSince: lastUpdate) >= 100)
				ifTrue: [ lastUpdate := Time millisecondClockValue.
					bar label: 'Creating ' , entry fileName ].
			dir := (entry fileName findTokens: '/')
				inject: aDirectory
				into: [ :base :part | base / part ].
			dir ensureCreateDirectory.
			barValue := barValue + 1.
			shouldUpdateInfos
				ifTrue: [ bar value: barValue ] ].
	self members
		reject: #isDirectory
		thenDo: [ :entry | 
			| shouldUpdateInfos lastUpdate |
			lastUpdate := 0.
			(shouldUpdateInfos := (Time millisecondsSince: lastUpdate) >= 100)
				ifTrue: [ lastUpdate := Time millisecondClockValue.
					bar label: 'Extracting ' , entry fileName ].
			entry
				extractInDirectory: aDirectory
				informingOverwrite: overwriteAll
				onSuccess: [  ]
				onRetryWithOverwrite: [ overwriteAll := true ]
				onFailedOverwrite: [ (self confirm: 'Failed to extract ' , entry fileName , '. Proceed?')
						ifFalse: [ ^ self ] ]
				onAbortOverwrite: [ ^ self ].
			barValue := barValue + 1.
			shouldUpdateInfos
				ifTrue: [ bar value: barValue.
					lastUpdate := Time millisecondClockValue ] ]! !

!ZipArchive methodsFor: 'private' stamp: 'nil'!
readSignatureFrom: stream
	"Returns next signature from given stream, leaves stream positioned afterwards."

	| signatureData | 
	signatureData := ByteArray new: 4.
	stream next: 4 into: signatureData.
	({ CentralDirectoryFileHeaderSignature . LocalFileHeaderSignature . EndOfCentralDirectorySignature }
		includes: signatureData)
			ifFalse: [ ^ ZipArchiveError signal: 'bad signature ', signatureData asString asHex, ' at position ', (stream position - 4) asString ].
	^signatureData! !

!ZipArchive methodsFor: 'writing' stamp: 'nil'!
writeTo: stream prependingFile: aFileReferenceOrFileName
	
	aFileReferenceOrFileName asFileReference binaryReadStreamDo: [ :prepended | | buffer |
	buffer := ByteArray new: (prepended size min: 32768).
	[ prepended atEnd ]
		whileFalse: [ | bytesRead |
			bytesRead := prepended
				readInto: buffer
				startingAt: 1
				count: buffer size.
			stream next: bytesRead putAll: buffer startingAt: 1 ].
		 ].
	
	self writeTo: stream! !

!ZipArchive methodsFor: 'archive operations' stamp: 'nil'!
extractAllTo: aDirectory
	"Extract all elements to the given directory; notifying user via UI on progress and if existing files exist"

	UIManager default
		informUserDuring: [:bar | 
			bar max: self numberOfMembers.
			self extractAllTo: aDirectory informing: bar ]! !

!ZipArchive methodsFor: 'private' stamp: 'nil'!
readEndOfCentralDirectoryFrom: aStream
	"Read EOCD, starting from position before signature."
	| signature zipFileCommentLength endianStream |
	signature := self readSignatureFrom: aStream.
	signature = EndOfCentralDirectorySignature ifFalse: [ ^self error: 'bad signature at ', aStream position printString ].

	endianStream := ZnEndianessReadWriteStream on: aStream.
	endianStream nextLittleEndianNumber: 2. "# of this disk"
	endianStream nextLittleEndianNumber: 2. "# of disk with central dir start"
	endianStream nextLittleEndianNumber: 2. "# of entries in central dir on this disk"
	endianStream nextLittleEndianNumber: 2. "total # of entries in central dir"
	centralDirectorySize := endianStream nextLittleEndianNumber: 4. "size of central directory"
	centralDirectoryOffsetWRTStartingDiskNumber := endianStream nextLittleEndianNumber: 4. "offset of start of central directory"
	zipFileCommentLength := endianStream nextLittleEndianNumber: 2. "zip file comment"
	zipFileComment := aStream next: zipFileCommentLength! !

!ZipArchive methodsFor: 'private' stamp: 'nil'!
writeCentralDirectoryTo: aStream
	| offset |
	offset := writeCentralDirectoryOffset.
	members do: [ :member |
		member writeCentralDirectoryFileHeaderTo: aStream.
		offset := offset + member centralDirectoryHeaderSize.
	].
	writeEOCDOffset := offset.
	self writeEndOfCentralDirectoryTo: aStream! !

!ZipArchive methodsFor: 'accessing' stamp: 'nil'!
zipFileComment: aString
	zipFileComment := aString! !

!ZipArchive methodsFor: 'initialization' stamp: 'nil'!
close
	self members do: [:m | m close ]! !

!ZipArchive methodsFor: 'accessing' stamp: 'nil'!
prependedDataSize
	"Answer the size of whatever data exists before my first member.
	Assumes that I was read from a file or stream (i.e. the first member is a ZipFileMember)"
	^members isEmpty
		ifFalse: [ members first localHeaderRelativeOffset ]
		ifTrue: [ centralDirectoryOffsetWRTStartingDiskNumber ]! !

!ZipArchive methodsFor: 'writing' stamp: 'nil'!
writeTo: stream prepending: aString
	stream nextPutAll: aString.
	self writeTo: stream! !

!ZipArchive methodsFor: 'private' stamp: 'nil'!
writeEndOfCentralDirectoryTo: aStream

	| endianStream |
	aStream nextPutAll: EndOfCentralDirectorySignature.
	
	endianStream := ZnEndianessReadWriteStream on: aStream.
	endianStream nextLittleEndianNumber: 2 put: 0. "diskNumber"
	endianStream nextLittleEndianNumber: 2 put: 0. "diskNumberWithStartOfCentralDirectory"
	endianStream nextLittleEndianNumber: 2 put: members size. "numberOfCentralDirectoriesOnThisDisk"
	endianStream nextLittleEndianNumber: 2 put: members size. "numberOfCentralDirectories"
	endianStream nextLittleEndianNumber: 4 put: writeEOCDOffset - writeCentralDirectoryOffset. "size of central dir"
	endianStream nextLittleEndianNumber: 4 put: writeCentralDirectoryOffset. "offset of central dir"
	endianStream nextLittleEndianNumber: 2 put: zipFileComment size. "zip file comment"
	
	zipFileComment isEmpty ifFalse: [ aStream nextPutAll: zipFileComment ]! !

!ZipArchive methodsFor: 'reading' stamp: 'nil'!
readFrom: aStreamOrFile
	| stream name eocdPosition |
	stream := aStreamOrFile isStream
		ifTrue: [ name := aStreamOrFile printString. aStreamOrFile ]
		ifFalse: [ name := aStreamOrFile asFileReference fullName. aStreamOrFile asFileReference binaryReadStream ].
	eocdPosition := self class findEndOfCentralDirectoryFrom: stream.
	eocdPosition <= 0 ifTrue: [ ZipArchiveError signal: 'can''t find EOCD position' ].
	self readEndOfCentralDirectoryFrom: stream.
	stream position: eocdPosition - centralDirectorySize.
	self readMembersFrom: stream named: name! !

!ZipArchive methodsFor: 'private' stamp: 'nil'!
memberClass
	^ZipArchiveMember! !

!ZipArchive class methodsFor: '*System-FileRegistry' stamp: ''!
fileReaderServicesForFile: fullName suffix: suffix 
	<fileService>
	"Answers a collection of services that can handle the file and suffixes"
	|  services |
	services := OrderedCollection new.
	({'zip'.'sar'.'pr'. 'mcz'. '*'} includes: suffix)
		ifTrue: [	services add: self serviceExtractAll].
	^services.! !

!ZipArchive class methodsFor: 'file in/out' stamp: 'nil'!
extractAllIn: aFileReferenceOrFileName
	"Service method to extract all contents of a zip."
	| directory |
	directory := (UIManager default chooseDirectoryFrom: aFileReferenceOrFileName asFileReference) ifNil: [^ self].
	^ (self new) 
		readFrom: aFileReferenceOrFileName;
		extractAllTo: directory.! !

!ZipArchive class methodsFor: 'constants' stamp: 'nil'!
validSignatures
	"Return the valid signatures for a zip file"
	^Array 
		with: LocalFileHeaderSignature
		with: CentralDirectoryFileHeaderSignature
		with: EndOfCentralDirectorySignature! !

!ZipArchive class methodsFor: 'constants' stamp: 'nil'!
compressionLevelDefault
	^CompressionLevelDefault! !

!ZipArchive class methodsFor: '*System-FileRegistry' stamp: ''!
serviceExtractAll
	"Answer a service for extracting files in a zip to a user-specified directory"

	^ FileModifyingSimpleServiceEntry 
		provider: self
		label: 'extract all to...'
		selector: #extractAllIn: 
		description: 'extract all files to a user-specified directory'
		buttonLabel: 'extract all'! !

!ZipArchive class methodsFor: 'constants' stamp: 'nil'!
compressionStored
	^CompressionStored! !

!ZipArchive class methodsFor: 'testing - file format' stamp: 'nil'!
isZipArchive: file
	"Answer whether the given file represents a valid zip file. The argument file can be a String, FileReference or an open binary read stream.
	
	See ZipArchiveTest>>testisZipArchive for examples."

	| stream eocdPosition |
	stream := file isStream
		ifTrue: [ file ]
		ifFalse: [ file asFileReference binaryReadStream ].
		
	stream size < 22 ifTrue: [ ^ false ].
	
	eocdPosition := self findEndOfCentralDirectoryFrom: stream.
	stream ~= file ifTrue: [ stream close ].
	
	^ eocdPosition > 0! !

!ZipArchive class methodsFor: 'constants' stamp: 'nil'!
findEndOfCentralDirectoryFrom: stream
	"Seek in the given stream to the end, then read backwards until we find the
	signature of the central directory record. Leave the file positioned right
	before the signature.

	Answers the file position of the EOCD, or 0 if not found."

	| data fileLength seekOffset pos maxOffset |
	stream setToEnd.
	fileLength := stream position.
	"If the file length is less than 18 for the EOCD length plus 4 for the signature, we have a problem"
	fileLength < 22 ifTrue: [^ self error: 'file is too short'].
	
	seekOffset := 0.
	pos := 0.
	data := ByteArray new: 4100.
	maxOffset := 40960 min: fileLength.	"limit search range to 40K"

	[
		seekOffset := (seekOffset + 4096) min: fileLength.
		stream position: fileLength - seekOffset.
		data := stream next: (4100 min: seekOffset) into: data startingAt: 1.
		pos := data lastIndexOfPKSignature: EndOfCentralDirectorySignature.
		pos = 0 and: [seekOffset < maxOffset]
	] whileTrue.

	^ pos > 0
		ifTrue: [ | newPos | stream position: (newPos := (stream position + pos - seekOffset - 1)). newPos]
		ifFalse: [0]! !

!ZipArchive class methodsFor: 'constants' stamp: 'nil'!
compressionDeflated
	^CompressionDeflated! !

!ZipArchive class methodsFor: 'constants' stamp: 'nil'!
compressionLevelNone
	^CompressionLevelNone! !

!ZipArchiveError commentStamp: ''!
I'm raised by ZipArchive when a trouble arrives.!
!ZipArchiveMember commentStamp: ''!
Subinstances of me are members in a ZipArchive.

They represent different data sources:
* ZipDirectoryMember -- a directory to be added to a zip file
* ZipFileMember -- a file or directory that is already in a zip file
* ZipNewFilemember -- a file that is to be added to a zip file
* ZipStringMember -- a string that is to be added to a zip file

They can write their data to another stream either copying, compressing,
or decompressing as desired.!
!ZipArchiveMember methodsFor: 'testing' stamp: 'nil'!
isEncrypted
	"Return true if this member is encrypted (this is unsupported)"
	^ (self bitFlag bitAnd: 1) ~= 0! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'nil'!
extractToFileNamed: aLocalFileName inDirectory: dir overwrite: overwrite
	| file |
	self isEncrypted
		ifTrue: [ ^ self error: 'encryption unsupported' ].
	file := dir / aLocalFileName.
	self isDirectory
		ifTrue: [ file ensureCreateDirectory ]
		ifFalse: [ (file isFile and: [ file exists ])
				ifTrue: [ overwrite
						ifTrue: [ file
								ensureDelete;
								ensureCreateFile;
								binaryWriteStreamDo: [ :stream | self extractTo: stream ] ] ]
				ifFalse: [ file
						ensureCreateFile;
						binaryWriteStreamDo: [ :stream | self extractTo: stream ] ] ]! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'nil'!
extractTo: aStream
	| oldCompression |
	self isEncrypted ifTrue: [ self error: 'encryption is unsupported' ].
	oldCompression := self desiredCompressionMethod: CompressionStored.
	self rewindData.
	self writeDataTo: aStream.
	self desiredCompressionMethod: oldCompression.
	self endRead! !

!ZipArchiveMember methodsFor: 'testing' stamp: 'nil'!
isTextFile: aBoolean
	"Set whether I am a text file.
	Note that this module does not currently do anything with this flag
	upon extraction or storage.
	That is, bytes are stored in native format whether or not they came
	from a text file."
	internalFileAttributes := aBoolean
		ifTrue: [ internalFileAttributes bitOr: 1 ]
		ifFalse: [ internalFileAttributes bitAnd: 1 bitInvert ]! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
unixFileAttributes
	"See comment at end"

	^self mapPermissionsToUnix: externalFileAttributes
	
"Per http://unix.stackexchange.com/questions/14705/the-zip-formats-external-file-attribute : These values can all be found in <sys/stat.h> - link to 4.4BSD version. These are not in the POSIX standard (which defines test macros instead); but originate from AT&T Unix and BSD. (in GNU libc / Linux, the values themselves are defined as __S_IFDIR etc in bits/stat.h, though the kernel header might be easier to read - the values are all the same pretty much everywhere.)

#define S_IFIFO  0010000  /* named pipe (fifo) */
#define S_IFCHR  0020000  /* character special */
#define S_IFDIR  0040000  /* directory */
#define S_IFBLK  0060000  /* block special */
#define S_IFREG  0100000  /* regular */
#define S_IFLNK  0120000  /* symbolic link */
#define S_IFSOCK 0140000  /* socket */
And of course, the other 12 bits are for the permissions and setuid/setgid/sticky bits, the same as for chmod:

#define S_ISUID 0004000 /* set user id on execution */
#define S_ISGID 0002000 /* set group id on execution */
#define S_ISTXT 0001000 /* sticky bit */
#define S_IRWXU 0000700 /* RWX mask for owner */
#define S_IRUSR 0000400 /* R for owner */
#define S_IWUSR 0000200 /* W for owner */
#define S_IXUSR 0000100 /* X for owner */
#define S_IRWXG 0000070 /* RWX mask for group */
#define S_IRGRP 0000040 /* R for group */
#define S_IWGRP 0000020 /* W for group */
#define S_IXGRP 0000010 /* X for group */
#define S_IRWXO 0000007 /* RWX mask for other */
#define S_IROTH 0000004 /* R for other */
#define S_IWOTH 0000002 /* W for other */
#define S_IXOTH 0000001 /* X for other */
#define S_ISVTX 0001000 /* save swapped text even after use"! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
compressedSize
	"Return the compressed size for this member.
	This will not be set for members that were constructed from strings
	or external files until after the member has been written."
	^compressedSize! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nil'!
rewindData
	readDataRemaining :=  (desiredCompressionMethod = CompressionDeflated
		and: [ compressionMethod = CompressionDeflated ])
			ifTrue: [ compressedSize ]
			ifFalse: [ uncompressedSize ]! !

!ZipArchiveMember methodsFor: 'private - writing' stamp: 'nil'!
compressDataTo: aStream
	"Copy my deflated data to the given stream."
	| encoder startPos endPos |

	encoder := ZipWriteStream on: aStream.
	startPos := aStream position.

	[ readDataRemaining > 0 ] whileTrue: [ | data |
		data := self readRawChunk: (4096 min: readDataRemaining).
		encoder nextPutAll: data asByteArray.
		readDataRemaining := readDataRemaining - data size.
	].
	encoder finish. "not close!!"
	endPos := aStream position.
	compressedSize := endPos - startPos.
	crc32 := encoder crc! !

!ZipArchiveMember methodsFor: 'private - writing' stamp: 'nil'!
writeDataDescriptorTo: aStream
	"This writes a data descriptor to the given stream.
	Assumes that crc32, writeOffset, and uncompressedSize are
	set correctly (they should be after a write).
	Further, the local file header should have the
	GPBF:=HAS:=DATA:=DESCRIPTOR:=MASK (8) bit set."

	aStream nextLittleEndianNumber: 4 put: crc32.
	aStream nextLittleEndianNumber: 4 put: compressedSize.
	aStream nextLittleEndianNumber: 4 put: uncompressedSize! !

!ZipArchiveMember methodsFor: 'private - writing' stamp: 'nil'!
writeLocalFileHeaderTo: aStream
	"Write my local header to a file handle.
	Stores the offset to the start of the header in my
	writeLocalHeaderRelativeOffset member."

	| systemFileName endianStream |
	systemFileName := fileName asVmPathName.
	aStream nextPutAll: LocalFileHeaderSignature.

	endianStream := ZnEndianessReadWriteStream on: aStream.
	endianStream nextLittleEndianNumber: 2 put: versionNeededToExtract.
	endianStream nextLittleEndianNumber: 2 put: self bitFlag.
	endianStream nextLittleEndianNumber: 2 put: desiredCompressionMethod.

	endianStream nextLittleEndianNumber: 4 put: lastModFileDateTime asDosTimestamp.
	endianStream nextLittleEndianNumber: 4 put: crc32.
	endianStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored
												ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]).
	endianStream nextLittleEndianNumber: 4 put: uncompressedSize.

	endianStream nextLittleEndianNumber: 2 put: systemFileName size.
	endianStream nextLittleEndianNumber: 2 put: localExtraField size.

	aStream nextPutAll: systemFileName asByteArray.
	aStream nextPutAll: localExtraField asByteArray.! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'nil'!
extractInDirectory: dir withoutInformingOverwrite: overwrite
	"Extract myself to dir without informing user whether to overwrite existing file"

	self extractToFileNamed: self localFileName inDirectory: dir overwrite: overwrite! !

!ZipArchiveMember methodsFor: 'private - extraction' stamp: 'nil'!
extractToFile: aFile informingOverwrite: shouldOverwrite onSuccess: successBlock onRetryWithOverwrite: retryWithOverwriteBlock onFailedOverwrite: failedBlock onAbortOverwrite: abortBlock
	"Extract this entry into the given file. Answer successBlock or call one of the other action blocks."

	| file |
	file := aFile.
	(file exists and: [ shouldOverwrite not ])
		ifTrue: [ | overwriteBlock |
			overwriteBlock := [ file := [ file
				ensureDelete;
				ensureCreateFile ]
				on: Error
				do: [ :ex | 
					failedBlock cull: ex.
					^ self ] ].
			self
				askOverwriteOptionsUsing: UIManager default
				onYes: overwriteBlock
				onNo: [ ^ #okay ]
				onRetryWithOverwrite: [ retryWithOverwriteBlock value.
					overwriteBlock value ]
				onCancel: abortBlock ].
	file binaryWriteStreamDo: [ :str | self extractTo: str ].
	^ successBlock value! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nil'!
mapPermissionsToUnix: zipPerms
	"Extract Unix permissions (the high 16 bits) from zip permissions. The low 16 bits are for DOS permissions"
	
	^ zipPerms bitShift: -16! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nil'!
mapPermissionsFromUnix: unixPerms
	"Take Unix permissions (e.g. 8r40755 for a directory) and put them in the high 16 bits. The low 16 bits are for DOS permissions"
	
	^ unixPerms bitShift: 16! !

!ZipArchiveMember methodsFor: 'reading' stamp: 'nil'!
contents
	"Answer my contents as a string."
	^ ByteArray new: self uncompressedSize streamContents: [ :s | 
		self extractTo: s ]! !

!ZipArchiveMember methodsFor: 'extraction-ui' stamp: 'nil'!
extractInDirectory: aDirectory informingOverwrite: shouldOverwrite onSuccess: successBlock onRetryWithOverwrite: retryWithOverwriteBlock onFailedOverwrite: failedBlock onAbortOverwrite: abortBlock
	"Extract this entry into the given directory. Answer successBlock or call one of the other action blocks."

	| path fileDir file localName |
	path := fileName findTokens: '/'.
	localName := path last.
	fileDir := path allButLast inject: aDirectory into: [ :base :part | base / part ].
	fileDir ensureCreateDirectory.
	file := fileDir / localName.
	^ self
		extractToFile: file
		informingOverwrite: shouldOverwrite
		onSuccess: successBlock
		onRetryWithOverwrite: retryWithOverwriteBlock
		onFailedOverwrite: failedBlock
		onAbortOverwrite: abortBlock! !

!ZipArchiveMember methodsFor: 'extraction-ui' stamp: 'nil'!
askOverwriteOptionsUsing: aUIManager onYes: yesBlock onNo: noBlock onRetryWithOverwrite: retryWithOverwriteBlock onCancel: cancelBlock
	| index |
	[ index := aUIManager chooseFrom: {'Yes, overwrite' . 'No, don''t overwrite' . 'Overwrite ALL files' . 'Cancel operation'} lines: #(2) title: fileName , ' already exists. Overwrite?'.
	index isNil ] whileTrue.
	index = 1
		ifTrue: [ yesBlock value ].
	index = 2
		ifTrue: [ noBlock value ].
	index = 3
		ifTrue: [ retryWithOverwriteBlock value ].
	index = 4
		ifTrue: [ cancelBlock value ]! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nil'!
endRead
	readDataRemaining := 0! !

!ZipArchiveMember methodsFor: 'testing' stamp: 'nil'!
isDirectory
	^false! !

!ZipArchiveMember methodsFor: 'private - writing' stamp: 'nil'!
writeDataTo: aStream from: start to: finish
	"Copy my (possibly inflated or deflated) data to the given stream.
	But only the specified byte range.
	This might do decompression, or straight copying, depending
	on the values of compressionMethod and desiredCompressionMethod"

	uncompressedSize = 0 ifTrue: [ ^self ].	"nothing to do because no data"
	start > finish ifTrue: [ ^self ].
	start > uncompressedSize ifTrue: [ ^self ].

	(compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ])
		ifTrue: [ ^self error: 'only supports uncompression or copying right now' ].

	(compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ])
		ifTrue: [ ^self uncompressDataTo: aStream from: start to: finish ].

	self copyRawDataTo: aStream from: start to: finish.! !

!ZipArchiveMember methodsFor: 'accessing - spec fields' stamp: 'nil'!
versionMadeBy
	"Per .ZIP File Format Specification Version: 6.3.2:
		2 Bytes:
		- The upper byte indicates the compatibility of the file attribute information.  If the external file attributes are compatible with MS-DOS and can be read by PKZIP for DOS version 2.04g then this value will be zero.
		- The lower byte indicates the ZIP specification version (the version of PKWARE Appnote) supported by the software used to encode the file.  The value / 10 indicates the major version number, and the value mod 10 is the minor version number"
	
	^ versionMadeBy! !

!ZipArchiveMember methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	lastModFileDateTime := DateAndTime epoch.
	fileAttributeFormat := FaUnix.
	self versionMadeBy: 20. "Dos-compatible file attributes; ZIP v. 2.0. See comment for #versionMadeBy"
	self versionNeededToExtract: 20. "ZIP v. 2.0. See comment for #versionNeededToExtract"
	self bitFlag: 0.
	compressionMethod := CompressionStored.
	desiredCompressionMethod := CompressionDeflated.
	desiredCompressionLevel := CompressionLevelDefault.
	internalFileAttributes := 0.
	externalFileAttributes := 0.
	fileName := ''.
	cdExtraField := ''.
	localExtraField := ''.
	fileComment := ''.
	crc32 := 0.
	compressedSize := 0.
	uncompressedSize := 0.
	self unixFileAttributes: DefaultFilePermissions! !

!ZipArchiveMember methodsFor: 'testing' stamp: 'nil'!
hasDataDescriptor
	^ (self bitFlag bitAnd: 8)	~= 0 "GPBF:=HAS:=DATA:=DESCRIPTOR:=MASK"! !

!ZipArchiveMember methodsFor: 'accessing - spec fields' stamp: 'nil'!
versionNeededToExtract: anInteger
	"See comment for #versionNeededToExtract"
	
	versionNeededToExtract := anInteger! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
compressionMethod
	"Returns my compression method. This is the method that is
	currently being used to compress my data.

	This will be CompressionStored for added string or file members,
	or CompressionStored or CompressionDeflated (others are possible but not handled)"

	^compressionMethod! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
splitFileName
	"Answer my name split on slash boundaries. A directory will have a trailing empty string."
	^ fileName findTokens: '/'! !

!ZipArchiveMember methodsFor: 'private - writing' stamp: 'nil'!
copyRawDataTo: aStream from: start to: finish

	readDataRemaining := readDataRemaining min: finish - start + 1.

	self readRawChunk: start - 1.

	[ readDataRemaining > 0 ] whileTrue: [ | data |
		data := self readRawChunk: (32768 min: readDataRemaining).
		aStream nextPutAll: data.
		readDataRemaining := readDataRemaining - data size ]! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
desiredCompressionLevel
	^desiredCompressionLevel! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
crc32String
	| hexString |
	hexString := crc32 storeStringHex.
	^('00000000' copyFrom: 1 to: 11 - (hexString size)) , (hexString copyFrom: 4 to: hexString size)! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nil'!
readRawChunk: n
	self subclassResponsibility! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
desiredCompressionLevel: aNumber
	"Set my desiredCompressionLevel
	This is the method that will be used to write.
	Returns prior desiredCompressionLevel.

	Valid arguments are 0 (CompressionLevelNone) through 9,
	including 6 (CompressionLevelDefault).

	0 (CompressionLevelNone) will change the desiredCompressionMethod
	to CompressionStored. All other arguments will change the
	desiredCompressionMethod to CompressionDeflated."

	| old |
	old := desiredCompressionLevel.
	desiredCompressionLevel := aNumber.
	desiredCompressionMethod := (aNumber > 0)
		ifTrue: [ CompressionDeflated ]
		ifFalse: [ CompressionStored ].
	^old! !

!ZipArchiveMember methodsFor: 'private - writing' stamp: 'nil'!
copyDataWithCRCTo: aStream
	"Copy my data to aStream. Also set the CRC-32.
	Only used when compressionMethod = desiredCompressionMethod = CompressionStored"

	uncompressedSize := compressedSize := readDataRemaining.

	crc32 := 16rFFFFFFFF.

	[ readDataRemaining > 0 ] whileTrue: [ | data |
		data := self readRawChunk: (4096 min: readDataRemaining).
		aStream nextPutAll: data.
		crc32 := ZipWriteStream updateCrc: crc32 from: 1 to: data size in: data.
		readDataRemaining := readDataRemaining - data size.
	].

	crc32 := crc32 bitXor: 16rFFFFFFFF! !

!ZipArchiveMember methodsFor: 'private - writing' stamp: 'nil'!
copyRawDataTo: aStream

	[ readDataRemaining > 0 ] whileTrue: [ | data |
		data := self readRawChunk: (4096 min: readDataRemaining).
		aStream nextPutAll: data.
		readDataRemaining := readDataRemaining - data size ]! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
fileComment
	^fileComment! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
contentStreamFromEncoding: encodingName
	"Answer my contents as a text stream.
	Interpret the raw bytes with given encodingName"

	^ ((ByteArray new: self uncompressedSize streamContents: [ :stream |
		self extractTo: stream ]) decodeWith: encodingName)
			readStream! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
crc32
	^crc32! !

!ZipArchiveMember methodsFor: 'reading' stamp: 'nil'!
contentsFrom: start to: finish
	"Answer my contents as a string."
	| s |
	s := (String new: finish - start + 1) writeStream.
	self extractTo: s from: start to: finish.
	^s contents! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
contentStream
	"Answer my contents as a text stream.
	Default is no conversion, since we don't know what the bytes mean."

	^self contentStreamFromEncoding: 'latin1'! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
desiredCompressionMethod: aNumber
	"Set my desiredCompressionMethod
	This is the method that will be used to write.
	Answers prior desiredCompressionMethod.

	Only CompressionDeflated or CompressionStored are valid arguments.

	Changing to CompressionStored will change my desiredCompressionLevel
	to CompressionLevelNone; changing to CompressionDeflated will change my
	desiredCompressionLevel to CompressionLevelDefault."

	| old |
	self flag: 'should be an error if unsupported, but valid zip compression is requested. Also, clean up test branches here'.
	old := desiredCompressionMethod.
	desiredCompressionMethod := aNumber.
	desiredCompressionLevel := (aNumber = CompressionDeflated)
			ifTrue: [ CompressionLevelDefault ]
			ifFalse: [ CompressionLevelNone ].
	compressionMethod = CompressionStored ifTrue: [ compressedSize := uncompressedSize ].
	^old! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
desiredCompressionMethod
	"Get my desiredCompressionMethod.
	This is the method that will be used to write"

	^desiredCompressionMethod! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
uncompressedSize
	"Return the uncompressed size for this member."
	^uncompressedSize! !

!ZipArchiveMember methodsFor: 'private - writing' stamp: 'nil'!
copyDataTo: aStream

	compressionMethod = CompressionStored ifTrue: [ ^self copyDataWithCRCTo: aStream ].

	self copyRawDataTo: aStream! !

!ZipArchiveMember methodsFor: 'private - writing' stamp: 'nil'!
writeDataTo: aStream
	"Copy my (possibly inflated or deflated) data to the given stream.
	This might do compression, decompression, or straight copying, depending
	on the values of compressionMethod and desiredCompressionMethod"

	"Note: Do not shortcut this method if uncompressedSize = 0. Even in this case
	data may be produced by the compressor (i.e., '' zipped size > 0) and must
	be stored in the file or else other utilities will treat the zip file as corrupt."

	(compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ])
		ifTrue: [ ^self compressDataTo: aStream ].

	(compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ])
		ifTrue: [ ^self uncompressDataTo: aStream ].

	self copyDataTo: aStream.! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
localFileName
	"Answer my fileName in terms of the local directory naming convention"
	^ fileName copyReplaceAll: '/' with: FileSystem disk delimiter asString! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'nil'!
extractToFileNamed: aFileName
	self extractToFileNamed: aFileName inDirectory: FileSystem workingDirectory overwrite: true! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'nil'!
extractTo: aStream from: start to: finish
	| oldCompression |
	self isEncrypted ifTrue: [ self error: 'encryption is unsupported' ].
	aStream binary.
	oldCompression := self desiredCompressionMethod: CompressionStored.
	self rewindData.
	self writeDataTo: aStream from: start to: finish.
	self desiredCompressionMethod: oldCompression.
	self endRead! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
centralDirectoryHeaderSize

	| systemFileName systemFileComment systemCdExtraField |
	systemFileName := fileName asVmPathName.
	systemFileComment := fileComment utf8Encoded.
	systemCdExtraField := cdExtraField.
	^ 46 + systemFileName size + systemCdExtraField size + systemFileComment size! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'nil'!
extractInDirectory: dir
	self extractToFileNamed: self localFileName inDirectory: dir overwrite: true! !

!ZipArchiveMember methodsFor: 'private - writing' stamp: 'nil'!
writeCentralDirectoryFileHeaderTo: aStream
	"C2 v3 V4 v5 V2"

	| systemFileName systemFileComment systemCdExtraField endianStream |
	systemFileName := fileName asVmPathName.
	systemFileComment := fileComment utf8Encoded.
	systemCdExtraField := cdExtraField.
	aStream nextPutAll: CentralDirectoryFileHeaderSignature.
	

	endianStream := ZnEndianessReadWriteStream on: aStream.
	endianStream nextLittleEndianNumber: 1 put: self versionMadeBy.
	endianStream nextLittleEndianNumber: 1 put: fileAttributeFormat.

	endianStream nextLittleEndianNumber: 2 put: versionNeededToExtract.
	endianStream nextLittleEndianNumber: 2 put: self bitFlag.
	endianStream nextLittleEndianNumber: 2 put: desiredCompressionMethod.

	endianStream nextLittleEndianNumber: 4 put: lastModFileDateTime asDosTimestamp.

	"These next 3 should have been updated during the write of the data"
	endianStream nextLittleEndianNumber: 4 put: crc32.
	endianStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored
												ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]).
	endianStream nextLittleEndianNumber: 4 put: uncompressedSize.

	endianStream nextLittleEndianNumber: 2 put: systemFileName size.
	endianStream nextLittleEndianNumber: 2 put: systemCdExtraField size.
	endianStream nextLittleEndianNumber: 2 put: systemFileComment size.
	endianStream nextLittleEndianNumber: 2 put: 0.		"diskNumberStart"
	endianStream nextLittleEndianNumber: 2 put: internalFileAttributes.

	endianStream nextLittleEndianNumber: 4 put: externalFileAttributes.
	endianStream nextLittleEndianNumber: 4 put: headerStartPosition.

	aStream nextPutAll: systemFileName asByteArray.
	aStream nextPutAll: systemCdExtraField asByteArray.
	aStream nextPutAll: systemFileComment! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
modifiedAt: aDateAndTime

	lastModFileDateTime := aDateAndTime! !

!ZipArchiveMember methodsFor: 'accessing - spec fields' stamp: 'nil'!
versionMadeBy: anInteger
	"See comment for #versionMadeBy"
	
	versionMadeBy := anInteger! !

!ZipArchiveMember methodsFor: 'extraction-ui' stamp: 'nil'!
extractInDirectory: aDirectory overwrite: shouldOverwrite
	"Extract this entry into the given directory. Answer #okay, #failed, #abort, or #retryWithOverwrite."

	^ self
		extractInDirectory: aDirectory
		informingOverwrite: shouldOverwrite
		onSuccess: [ ^ #okay ]
		onRetryWithOverwrite: [ ^ #retryWithOverwrite ]
		onFailedOverwrite: [ ^ #failed ]
		onAbortOverwrite: [ ^ #abort ]! !

!ZipArchiveMember methodsFor: 'testing' stamp: 'nil'!
looksLikeDirectory
	^false! !

!ZipArchiveMember methodsFor: 'accessing - spec fields' stamp: 'nil'!
bitFlag
	"Per .ZIP File Format Specification Version: 6.3.2:
		2 bytes:
		- Bit 0: If set, indicates that the file is encrypted.

		(For Method 6 - Imploding)
		- Bit 1: If the compression method used was type 6, Imploding, then this bit, if set, indicates an 8K sliding dictionary was used.  If clear, then a 4K sliding dictionary was used.
		- Bit 2: If the compression method used was type 6, Imploding, then this bit, if set, indicates 3 Shannon-Fano trees were used to encode the sliding dictionary output.  If clear, then 2 Shannon-Fano trees were used.

		(For Methods 8 and 9 - Deflating)
		Bit 2  Bit 1
		0      0    Normal (-en) compression option was used.
		0      1    Maximum (-exx/-ex) compression option was used.
		1      0    Fast (-ef) compression option was used.
		1      1    Super Fast (-es) compression option was used.

		(For Method 14 - LZMA)
		Bit 1: If the compression method used was type 14, LZMA, then this bit, if set, indicates an end-of-stream (EOS) marker is used to mark the end of the compressed data stream. If clear, then an EOS marker is not present and the compressed data size must be known to extract.

		Note:  Bits 1 and 2 are undefined if the compression method is any other.

		Bit 3: If this bit is set, the fields crc-32, compressed size and uncompressed size are set to zero in the local header.  The correct values are put in the data descriptor immediately following the compressed data.  (Note: PKZIP version 2.04g for DOS only recognizes this bit for method 8 compression, newer versions of PKZIP recognize this bit for any compression method.)

		Bit 4: Reserved for use with method 8, for enhanced deflating. 

		Bit 5: If this bit is set, this indicates that the file is compressed patched data.  (Note: Requires PKZIP version 2.70 or greater)

		Bit 6: Strong encryption.  If this bit is set, you should set the version needed to extract value to at least 50 and you must also set bit 0.  If AES encryption is used, the version needed to extract value must be at least 51.

		Bit 7: Currently unused.

		Bit 8: Currently unused.

		Bit 9: Currently unused.

		Bit 10: Currently unused.

		Bit 11: Language encoding flag (EFS).  If this bit is set, the filename and comment fields for this file must be encoded using UTF-8. (see APPENDIX D)

		Bit 12: Reserved by PKWARE for enhanced compression.

		Bit 13: Used when encrypting the Central Directory to indicate selected data values in the Local Header are masked to hide their actual values.  See the section describing the Strong Encryption Specification for details.

		Bit 14: Reserved by PKWARE.

		Bit 15: Reserved by PKWARE."
	
	^ bitFlag.! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
unixFileAttributes: perms
	"See #unixFileAttributes comment"
	
	| oldPerms newPerms |
	oldPerms := self mapPermissionsToUnix: externalFileAttributes.
	newPerms :=  self isDirectory
			ifTrue: [ (perms bitAnd: FileAttrib bitInvert) bitOr: DirectoryAttrib ]
			ifFalse: [ (perms bitAnd: DirectoryAttrib bitInvert) bitOr: FileAttrib ].
	externalFileAttributes := self mapPermissionsFromUnix: newPerms.
	^oldPerms! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'nil'!
extractToFileNamed: aLocalFileName inDirectory: dir
	self extractToFileNamed: aLocalFileName inDirectory: dir overwrite: true! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nil'!
asDirectory
	^ZipDirectoryMember new copyFrom: self! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
clearExtraFields
	cdExtraField := ''.
	localExtraField := ''! !

!ZipArchiveMember methodsFor: 'testing' stamp: 'nil'!
isTextFile
	"Returns true if I am a text file.
	Note that this module does not currently do anything with this flag
	upon extraction or storage.
	That is, bytes are stored in native format whether or not they came
	from a text file."
	^ (internalFileAttributes bitAnd: 1) ~= 0! !

!ZipArchiveMember methodsFor: 'writing' stamp: 'nil'!
writeTo: aStream
	"The header contains information about the data, including compressed size and CRC,
	 that we do not know yet!! So we leave room for the header, write the data, and go
	 back to write the header after we have the needed information."

	| headerSize headerEndPosition dataEndPosition |
	self rewindData.
	headerStartPosition := aStream position.
	headerSize := 30
		+ fileName asVmPathName asByteArray size 
		+ localExtraField asByteArray size.
	headerEndPosition := headerStartPosition + headerSize.
	aStream nextPutAll: (ByteArray new: headerSize).
	self writeDataTo: aStream.
	dataEndPosition := aStream position.
	aStream position: headerStartPosition.
	self writeLocalFileHeaderTo: aStream.
	"Verify that our calculation of the header size was correct!!"
	aStream position == headerEndPosition ifFalse: [ self error: 'Incorrect header size!!' ].
	aStream position: dataEndPosition.! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
fileComment: aString
	fileComment := aString! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nil'!
lastModTime
	"Return my last modification date"

	^ lastModFileDateTime! !

!ZipArchiveMember methodsFor: 'accessing - spec fields' stamp: 'nil'!
bitFlag: aNumber
	"See comment for #bitFlag"
	
	bitFlag := aNumber! !

!ZipArchiveMember methodsFor: 'accessing - spec fields' stamp: 'nil'!
versionNeededToExtract
	"See .ZIP File Format Specification Version: 6.3.2.
		For example, 2.0 means:
		- File is a folder (directory)
		- File is compressed using Deflate compression
		- File is encrypted using traditional PKWARE encryption"
	
	^ versionNeededToExtract! !

!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nil'!
newFromZipFile: stream named: fileName
	^ZipFileMember newFrom: stream named: fileName! !

!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nil'!
newFromString: aString named: aFileName
	^ZipStringMember newFrom: aString named: aFileName! !

!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nil'!
newFromFile: aFileReference
	^ZipNewFileMember newFromFile: aFileReference! !

!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nil'!
newFromDirectory: aFileReference localName: localName
	^ZipDirectoryMember newFromDirectory: aFileReference localName: localName! !

!ZipArchiveTest commentStamp: ''!
SUnit tests for ZIP archives!
!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testAddNonExistentFile
	
	self should: [ zip addFile: 'it_would_be_crazy_if_this_file_existed.ext' asFileReference ] raise: FileDoesNotExistException.! !

!ZipArchiveTest methodsFor: 'running' stamp: ''!
tearDown
	"Must close the zipfile before deleting all files.
	Otherwise in windows the file will not be deleted as long as the file is open."

	[ zip close ]
		ensure: [ fileToZip ensureDelete.
			subdir ensureDeleteAll.
			zipFile ensureDelete ].
	super tearDown! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testAddTreeWithSubDirectoriesShouldSucceed
	| zipOutput  extractionDir subSubDir fileInSubSubDIr | 
	extractionDir := fs root / 'extracted'.
	extractionDir ensureCreateDirectory.
	subSubDir := subdir / 'subSubDir'.
	subSubDir ensureCreateDirectory.
	fileInSubSubDIr := subdir / 'subSubDir' / 'fileInSubSubDir'.
	fileInSubSubDIr ensureCreateFile.
	
	zipOutput := zip addTree: subdir relativeTo: (subdir parent) match: [ :e | true ].
	zipOutput extractAllTo: extractionDir.
	
	self assert:	 (extractionDir / 'test-zip-dir' / 'subSubDir') asFileReference isDirectory.
	self assert:	 (extractionDir / 'test-zip-dir' / 'subSubDir' / 'fileInSubSubDir') asFileReference isFile.
	self deny: (extractionDir / 'subSubDir') asFileReference isDirectory! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testParsePharoZipTimestamp
	"Issue 6054. We're testing a private method. Eventually, the zip timestamp handling should be refactored; maybe a ZipTimestamp subclass of DosTimestamp"

	| dosTimestamp dateAndTime |
	"This was the error-causing timestamp from http://code.google.com/p/pharo/issues/detail?id=6054#c1 . It was the 'package' file inside Balloon-CamilloBruni.85.mcz"
	dosTimestamp := 1001728866.
	dateAndTime := ZipFileMember new unzipTimestamp: dosTimestamp.
	self assert: dateAndTime equals: '2011-09-29T04:01:06+00:00' asDateAndTime.! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
assertLastModificationTimeFrom: endianStream expected: fileModified
	| lastModificationTime |
	lastModificationTime := DateAndTime fromDosTimestamp: (endianStream nextLittleEndianNumber: 4).
	self assert:
			(lastModificationTime
				between: fileModified - 2 seconds
				and: fileModified + 2 seconds).! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testisZipArchive
	| nonArchive |
	zip addFile: fileToZip as: fileToZip basename.
	zip writeToFile: zipFile.
	self assert: (ZipArchive isZipArchive: zipFile).
	self assert: (zipFile binaryReadStreamDo: [ :s | ZipArchive isZipArchive: s ]).
	nonArchive := 'non_archive_file_for_test.txt' asFileReference.
	nonArchive ensureCreateFile.
	[ self deny: (ZipArchive isZipArchive: nonArchive).
	self deny: (nonArchive binaryReadStreamDo: [ :s | ZipArchive isZipArchive: s ]) ]
		ensure: [ nonArchive ensureDelete ]! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testCreateWithRelativeNames
	"Test creating a zip with a relative tree of files, so that the tree will
	be created whereever the ."
	
	| nestedFileToZip localFileHeaderSignature versionNeededToExtract bitFlag deflateCompressionMethod expectedCrc32 expectedUncompressedSize folderModified centralDirectoryOffset centralDirectoryEnd expectedCompressedSize fileModified fileStart |
	nestedFileToZip := subdir / '_test-zip-file'.
	nestedFileToZip writeStreamDo: [ :stream | stream nextPutAll: 'file contents' ].
	fileModified := nestedFileToZip entry modification.
	folderModified := subdir entry modification.
	zip
		addDirectory: subdir
		as: subdir basename.
	zip	
		addFile: nestedFileToZip
		as: nestedFileToZip basename.
		
	zip writeToFile: zipFile.
	
	zipFile binaryReadStreamDo: [ :str | | endianStream |
		
		endianStream := ZnEndianessReadWriteStream on: str.
		
		localFileHeaderSignature := 16r04034b50.
		versionNeededToExtract := 20.
		bitFlag := 0.
		deflateCompressionMethod := 8.
		expectedCrc32 := 16r2ab092ee. "I don''t know how to compute this, but OS X returned the same, so guessing it's correct"
		expectedCompressedSize := 15.
		expectedUncompressedSize := 13.
		
		"folder"
		self assert: (endianStream nextLittleEndianNumber: 4) equals: localFileHeaderSignature.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: versionNeededToExtract.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: bitFlag.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "No compression".
		self assertLastModificationTimeFrom: endianStream expected: folderModified.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 0 "expectedCrc32".
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 0 "expectedCompressedSize".
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 0 "expectedUncompressedSize".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: subdir basename size + 1.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Extra header length".
		self assert: (str next: subdir basename size + 1) asString equals: subdir basename, '/'.
		
		"Test file"
		fileStart := str position.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: localFileHeaderSignature.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: versionNeededToExtract.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: bitFlag.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: deflateCompressionMethod.
		self assertLastModificationTimeFrom: endianStream expected: fileModified.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedCrc32.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedCompressedSize.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedUncompressedSize.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: nestedFileToZip basename size.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Extra header length".
		self assert: (str next: nestedFileToZip basename size) asString equals: (nestedFileToZip basename copy replaceAll: DiskStore delimiter with: $/).
		self assert: (str next: expectedCompressedSize) isNil not "I don''t understand the compression yet".
		
		"Central directory structure"
		centralDirectoryOffset := str position.
		
		"Folder entry"
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 16r02014b50.	
		self flag: 'I think this is wrong. What is version 1.4?!!'.
		self assert: (endianStream nextLittleEndianNumber: 2) equals:  16r314.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: versionNeededToExtract.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: bitFlag.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "no compression".
		self assertLastModificationTimeFrom: endianStream expected: folderModified.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 0 "expectedCrc32".
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 0 "expectedCompressedSize".
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 0 "expectedUncompressedSize".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: subdir basename size + 1.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Extra header length".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "File comment".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Disk number start".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Internal file attributes".
		
		self flag: 'I don''t understand the attributes yet'.
		self assert: (endianStream nextLittleEndianNumber: 4) equals:  8r040755 << 16 "External file attributes".
		self assert: (endianStream nextLittleEndianNumber: 4) equals:  0 "Relative offset of local header".
		self assert: (str next: subdir basename size + 1) asString equals: subdir basename, '/'.
		
		"Nested file entry"
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 16r02014b50.
		
		self flag: 'I think this is wrong. What is version 1.4?!!'.
		self assert: (endianStream nextLittleEndianNumber: 2) equals:  16r314.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: versionNeededToExtract.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: bitFlag.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: deflateCompressionMethod.
		self assertLastModificationTimeFrom: endianStream expected: fileModified.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedCrc32.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedCompressedSize.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedUncompressedSize.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: nestedFileToZip basename size.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Extra header length".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "File comment".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Disk number start".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Internal file attributes".
		
		self flag: 'I don''t understand the attributes yet'.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 8r0100666 << 16 "External file attributes".
		self assert: (endianStream nextLittleEndianNumber: 4) equals: fileStart "Relative offset of local header".
		self assert: (str next: nestedFileToZip basename size) asString equals:  (nestedFileToZip basename copy replaceAll: DiskStore delimiter with: $/).

		centralDirectoryEnd := str position.
		
		"End of central directory record"
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 16r6054B50 "Signature".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Disk number".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Disk # where central dir started".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 2 "Total entries in central dir on this disk".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 2 "Total entries in central dir".
		self assert: (endianStream nextLittleEndianNumber: 4) equals: centralDirectoryEnd  - centralDirectoryOffset "Central directory size".
		self assert: (endianStream nextLittleEndianNumber: 4) equals: centralDirectoryOffset "from start of first disk".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "zip comment length".
		self assert: str atEnd ].! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testDate29Feb2000
	"Ensure that dates with leap years don't screw up in the conversion"

	| archive member theDate |
	theDate := Date year: 2000 month: 2 day: 29.
	archive := ZipArchive new.
	member := archive addDeflateString: 'foo' as: 'bar'.
	member modifiedAt: theDate.
	self assert: member lastModTime equals: theDate.! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testShouldUnzipAndOverwriteWithoutInforming
	| nestedFileToZip fileModificationTime fileModificationTimeBlock |
	fileModificationTimeBlock := [ (subdir / '_test-zip-file.txt') modificationTime ].
	nestedFileToZip := (subdir / '_test-zip-file.txt')
		writeStreamDo: [ :stream | stream nextPutAll: 'file contents' ];
		yourself.
	zip
		addDirectory: subdir as: subdir basename;
		addFile: nestedFileToZip as: nestedFileToZip basename;
		writeToFile: zipFile;
		close.
	ZipArchive new
		readFrom: zipFile;
		extractAllTo: subdir overwrite: true;
		close.
	fileModificationTime := fileModificationTimeBlock value.
	1 second wait.
	ZipArchive new
		readFrom: zipFile;
		extractAllTo: subdir overwrite: true;
		close.
	self assert: fileModificationTime ~= fileModificationTimeBlock value.
	fileModificationTime := fileModificationTimeBlock value.
	1 second wait.
	ZipArchive new
		readFrom: zipFile;
		extractAllTo: subdir overwrite: false;
		close.
	self deny: fileModificationTime ~= fileModificationTimeBlock value! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testCanUnzipFromStream
	| nestedFileToZip |
	nestedFileToZip := (subdir / '_test-zip-file.txt')
		writeStreamDo: [ :stream | stream nextPutAll: 'file contents' ];
		yourself.
	zipFile binaryWriteStreamDo: [ :stream |
		zip
			addDirectory: subdir as: subdir basename;
			addFile: nestedFileToZip as: nestedFileToZip basename;
			writeTo: stream;
			close. ].
	
	zipFile binaryReadStreamDo: [ :stream |
		ZipArchive new
			readFrom: stream ;
			extractAllTo: subdir overwrite: true;
			close ].! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testZip
	
	| localFileHeaderSignature versionNeededToExtract bitFlag deflateCompressionMethod realModificationStamp expectedCrc32 expectedCompressedSize expectedUncompressedSize centralDirectoryOffset centralDirectoryEnd |
	
	realModificationStamp := fileToZip entry modification.
	zip	
		addFile: fileToZip
		as: fileToZip basename.
	
	zip writeToFile: zipFile.
	
	zipFile binaryReadStreamDo: [ :str | | endianStream |
		
		endianStream := ZnEndianessReadWriteStream on: str.
		
		localFileHeaderSignature := 16r04034b50.
		versionNeededToExtract := 20.
		bitFlag := 0.
		deflateCompressionMethod := 8.
		expectedCrc32 := 16r2ab092ee. "I don''t know how to compute this, but OS X returned the same, so guessing it's correct"
		expectedCompressedSize := 15.
		expectedUncompressedSize := 13.
		
		"Test file"
		self assert: (endianStream nextLittleEndianNumber: 4) equals: localFileHeaderSignature.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: versionNeededToExtract.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: bitFlag.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: deflateCompressionMethod.
		self assertLastModificationTimeFrom: endianStream expected: realModificationStamp.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedCrc32.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedCompressedSize.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedUncompressedSize.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: fileToZip basename size.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Extra header length".
		self assert: (str next: fileToZip basename size) asString equals: fileToZip basename.
		self assert: (str next: expectedCompressedSize) isNil not "I don''t understand the compression yet".
		
		"Central directory structure"
		centralDirectoryOffset := str position.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 16r02014b50.
		
		self flag: 'I think this is wrong. What is version 1.4?!!'.
		self assert: (endianStream nextLittleEndianNumber: 2) equals:  16r314.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: versionNeededToExtract.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: bitFlag.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: deflateCompressionMethod.
		self assertLastModificationTimeFrom: endianStream expected: realModificationStamp.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedCrc32.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedCompressedSize.
		self assert: (endianStream nextLittleEndianNumber: 4) equals: expectedUncompressedSize.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: fileToZip basename size.
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Extra header length".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "File comment".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Disk number start".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Internal file attributes".
		
		self flag: 'I don''t understand the attributes yet'.
		self assert: (endianStream nextLittleEndianNumber: 4) equals:  16r81B60000 "External file attributes".
		self assert: (endianStream nextLittleEndianNumber: 4) equals:  0 "Relative offset of local header".
		self assert: (str next: fileToZip basename size) asString equals: fileToZip basename.
		centralDirectoryEnd := str position.
		
		"End of central directory record"
		self assert: (endianStream nextLittleEndianNumber: 4) equals: 16r6054B50 "Signature".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Disk number".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "Disk # where central dir started".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 1 "Total entries in central dir on this disk".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 1 "Total entries in central dir".
		self assert: (endianStream nextLittleEndianNumber: 4) equals: centralDirectoryEnd  - centralDirectoryOffset "Central directory size".
		self assert: (endianStream nextLittleEndianNumber: 4) equals: centralDirectoryOffset "from start of first disk".
		self assert: (endianStream nextLittleEndianNumber: 2) equals: 0 "zip comment length".
		self assert: str atEnd ].! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testAddTreeWithContentInFileShouldSucceed
	| zipOutput  extractionDir fileWithContentToZip fileContent extractedFile | 
	fileContent := 'some random text '.
	extractionDir := fs root / 'extracted'.
	extractionDir ensureCreateDirectory.
	fileWithContentToZip := subdir / 'fileWithContentToZip'.
	fileWithContentToZip ensureCreateFile.
	fileWithContentToZip writeStreamDo: [ :stream | stream nextPutAll: fileContent ].
	
	zipOutput := zip addTree: subdir relativeTo: (subdir parent) match: [ :e | true ].
	
	zipOutput extractAllTo: extractionDir.
	extractedFile :=  (extractionDir / (fileWithContentToZip relativeTo: fs root) fullName) asFileReference.
	self assert:	 extractedFile isFile.
	self assert:	 (extractedFile readStreamDo: [ :stream | stream contents]) equals: fileContent.! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testAddTreeWhenNoContentInFileShouldSucceed
	| zipOutput  extractionDir | 
	(subdir/'testZipFileInDir') ensureCreateFile. 
	(subdir/'testZipFileInDir2') ensureCreateFile. 
	(subdir/'DeeperDirectory') ensureCreateDirectory. 
	(subdir/'DeeperDirectory'/'testZipFileInDir3')  ensureCreateFile.
	extractionDir := fs root / 'extracted'.
	extractionDir ensureCreateDirectory.
	
	zipOutput := zip addTree: subdir relativeTo: (subdir parent) match: [ :e | true ].
	
	zipOutput extractAllTo: extractionDir.
	self assert:	 (extractionDir / 'test-zip-dir'/'testZipFileInDir') asFileReference isFile.
	self assert:	 (extractionDir / 'test-zip-dir'/'testZipFileInDir2') asFileReference isFile.
	self assert:	 (extractionDir / 'test-zip-dir'/'DeeperDirectory'/'testZipFileInDir3') asFileReference isFile! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testSetLastModification

	| aDateAndTime member |
	aDateAndTime := '15 January, 2000T13:23:55'.
	member := zip addDeflateString: 'foo' as: 'bar'.
	member modifiedAt: aDateAndTime.
	self assert: member lastModTime equals: aDateAndTime.! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testArchiveWithThousandFilesShouldWork
	
	"Smoke test showing that we can create zip archives with up to 1000 elements.
	This test was created as a regression test. Previous implementations were leaking files and reaching the open file limits from the operating system."
	
	| dir theZip |
	dir := (FileLocator temp / 'testfiles') ensureCreateDirectory.
	[
		1 to: 1000 do: [ :i | 
			(dir / ('test-' , i asString))
				writeStreamDo: [ :stream | stream nextPutAll: 'file contents' ];
				yourself ].
		
		theZip := ZipArchive new.
		dir children do: [ :eachFile | theZip addFile: eachFile resolve ].
		theZip writeToFile: FileLocator temp / 'result.zip'.	
		theZip close.
	] ensure: [ 
		dir ensureDeleteAll.
		(FileLocator temp / 'result.zip') ensureDelete. ]! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testCanUnzipFromFileName
	| nestedFileToZip subsubdir extracted |
	subsubdir := subdir /'subsubdir'.
	subsubdir ensureCreateDirectory .
	nestedFileToZip := (subdir / '_test-zip-file.txt')
		writeStreamDo: [ :stream | stream nextPutAll: 'file contents' ];
		yourself.
	zipFile := FileLocator temp / ('pharo_test_ZipArchive_testCanUnzipFromFileName' , '.zip').
	zipFile binaryWriteStreamDo: [ :stream |
		zip
			addDirectory: subdir as: subdir basename;
			addDirectory: subsubdir as: (subsubdir relativeTo: subdir parent) fullName;
			addFile: nestedFileToZip as: nestedFileToZip basename;
			writeTo: stream;
			close. ].
	
	extracted := fs root / 'extracted'. 
	extracted ensureCreateDirectory. 
	ZipArchive new
		readFrom: zipFile fullName;
		extractAllTo: extracted overwrite: true;
		close.
	zipFile ensureDelete.! !

!ZipArchiveTest methodsFor: 'tests' stamp: ''!
testFilePermissions

	| nestedFileToZip folderMember fileMember |
	nestedFileToZip := subdir / '_test-zip-file'.
	nestedFileToZip writeStreamDo: [ :stream | stream nextPutAll: 'file contents' ].
	
	folderMember := zip
		addDirectory: subdir
		as: subdir basename.
	fileMember := zip	
		addFile: nestedFileToZip
		as: nestedFileToZip basename.
	zip writeToFile: zipFile.
	
	self assert: fileMember unixFileAttributes equals: 8r100666.
	self assert: folderMember unixFileAttributes equals: 8r40755.! !

!ZipArchiveTest methodsFor: 'running' stamp: ''!
setUp

	super setUp.
	fs := FileSystem memory.
	fileToZip := fs root / 'test-zip-file'.
	fileToZip writeStreamDo: [ :stream | stream nextPutAll: 'file contents' ].
	subdir := fs root / 'test-zip-dir'.
	subdir ensureCreateDirectory.
	zipFile := fs root / ('pharo_test' , '.zip').
	zip := ZipArchive new.! !

!ZipArchiveTest class methodsFor: 'accessing' stamp: ''!
defaultTimeLimit
	^30 seconds! !

!ZipConstants commentStamp: ''!
This class defines magic numbers taken from RFC1951 [1b], and also 
possibly RFC1950 [1a] & RFC1952 [1c]. 
It presets some dictionary structures as described at [1a] 8.1. 

A class can import these bindings as 'class variables' by including the 
following in its class definition: 
   poolDictionaries: 'ZipFileConstants' 

Following are source references to these constants contained within 
several class side initialization methods. 
(These might be better spread through out those methods as time permits) 

initializeDeflateConstants 
    WindowSize [2e]"w_size", [2a]"windowBits is the base two logarithm 
of windowSize where default windowBits=15" 
    WindowMask [2e]"w_mask" 
    MaxDistance [2e]"MAX_DIST" 
    MinMatch [2c] 
    MaxMatch [2c] 
    HashBits [2e]"hash_bits" 
    HashMask [2e]"hash_mask" 
    HashShift [2e]"hash_shift" 

initializeDistanceCodes 
    BaseDistance [2f] 
    DistanceCodes [2f] 

initializeExtraBits 
    ExtraLengthBits [1]3.2.5, [2b] 
    ExtraDistanceBits [1]3.2.5, [2b] 
    ExtraBitLengthBits [2b] 
    BitLengthOrder [1]3.2.7, [2b] 

initializeFixedTrees 
    [1]3.2.6 

initializeWriteStreamConstants 
    MaxBits [2d] 
    MaxBitLengthBits [2b] 
    EndBlock [2b] 
    StoredBlock [2c] 
    FixedBlock [2c] 
    DynamicBlock [2c] [1]3.2.3"BTYPE" 
    NumLiterals 
    MaxLengthCodes [2e] 
    MaxDistCodes [2e] 
    MaxBitLengthCodes [2e] 
    MaxLiteralCodes 
    Repeat3To6 [2b] 
    Repeat3To10 [2b] 
    Repeat11To138 [2b] 

[1a]  "ZLIB Compressed Data Format Specification version 3.3" 
http://www.ietf.org/rfc/rfc1950.txt
[1b] "DEFLATE Compressed Data Format Specification version 1.3" 
http://www.ietf.org/rfc/rfc1951.txt
[1c] "GZIP file format specification version 4.3" 
http://www.ietf.org/rfc/rfc1952.txt
[2] ZLIB Source Code http://zlib.net/zlib-1.2.5.tar.gz
[2a] zlib.h 
[2b] trees.c 
[2c] zutil.h 
[2d] inftrees.c 
[2e] deflate.h 
[2f] trees.h !
!ZipConstants class methodsFor: 'class initialization' stamp: 'nil'!
initialize

	self 
		initializeDeflateConstants;
		initializeWriteStreamConstants! !

!ZipConstants class methodsFor: 'private - initialization' stamp: 'nil'!
initializeDeflateConstants

	WindowSize := 16r8000.
	WindowMask := WindowSize - 1.
	MaxDistance := WindowSize.

	MinMatch := 3.
	MaxMatch := 258.

	HashBits := 15.
	HashMask := (1 << HashBits) - 1.
	HashShift := (HashBits + MinMatch - 1) // MinMatch! !

!ZipConstants class methodsFor: 'private - initialization' stamp: 'nil'!
initializeWriteStreamConstants

	MaxBits := 15.
	MaxBitLengthBits := 7.
	EndBlock := 256.

	StoredBlock := 0.
	FixedBlock := 1.
	DynamicBlock := 2.

	NumLiterals := 256.
	MaxLengthCodes := 29.
	MaxDistCodes := 30.
	MaxBitLengthCodes := 19.
	MaxLiteralCodes := NumLiterals + MaxLengthCodes + 1. "+ End of Block"

	Repeat3To6 := 16. "Repeat previous bit length 3-6 times (2 bits repeat count)"
	Repeat3To10 := 17. "Repeat previous bit length 3-10 times (3 bits repeat count)"
	Repeat11To138 := 18. "Repeat previous bit length 11-138 times (7 bits repeat count)"

	self 
		initializeExtraBits;
		initializeLengthCodes;
		initializeDistanceCodes;
		initializeFixedTrees! !

!ZipConstants class methodsFor: 'private - initialization' stamp: 'nil'!
initializeFixedTrees
 
	| counts nodes |
	FixedLiteralTree := ZipEncoderTree new.
	FixedLiteralTree maxCode: 287.
	counts := WordArray new: MaxBits+1.
	counts at: 7+1 put: 24.
	counts at: 8+1 put: 144+8.
	counts at: 9+1 put: 112.
	nodes := Array new: 288.
	1 to: 288 do:[:i| nodes at: i put: (ZipEncoderNode value: i-1 frequency: 0 height: 0)].
	0 to: 143 do:[:i| (nodes at: i+1) setBitLengthTo: 8].
	144 to: 255 do:[:i| (nodes at: i+1) setBitLengthTo: 9].
	256 to: 279 do:[:i| (nodes at: i+1) setBitLengthTo: 7].
	280 to: 287 do:[:i| (nodes at: i+1) setBitLengthTo: 8].
	FixedLiteralTree buildCodes: nodes counts: counts maxDepth: MaxBits.
	FixedLiteralTree setValuesFrom: nodes.

	FixedDistanceTree := ZipEncoderTree new.
	FixedDistanceTree maxCode: MaxDistCodes.
	FixedDistanceTree
		bitLengths: ((WordArray new: MaxDistCodes+1) atAllPut: 5)
		codes: ((0 to: MaxDistCodes) collect:[:i| FixedDistanceTree reverseBits: i length: 5])! !

!ZipConstants class methodsFor: 'private - initialization' stamp: 'nil'!
initializeDistanceCodes
	| dist |
	BaseDistance := WordArray new: MaxDistCodes.
	DistanceCodes := WordArray new: 512.
	dist := 0.
	1 to: 16 do:[:code|
		BaseDistance at: code put: dist.
		1 to: (1 bitShift: (ExtraDistanceBits at: code)) do:[:n|
			dist := dist + 1.
			DistanceCodes at: dist put: code-1]].
	dist = 256 ifFalse:[self error:'Whoops?!!'].
	dist := dist >> 7.
	17 to: MaxDistCodes do:[:code|
		BaseDistance at: code put: dist << 7.
		1 to: (1 bitShift: (ExtraDistanceBits at: code)-7) do:[:n|
			dist := dist + 1.
			DistanceCodes at: 256 + dist put: code-1]].! !

!ZipConstants class methodsFor: 'private - initialization' stamp: 'nil'!
initializeLengthCodes
	| length |
	BaseLength := WordArray new: MaxLengthCodes.
	MatchLengthCodes := WordArray new: MaxMatch - MinMatch + 1.
	length := 0.
	1 to: MaxLengthCodes - 1 do:[:code|
		BaseLength at: code put: length.
		1 to: (1 bitShift: (ExtraLengthBits at: code)) do:[:n|
			length := length + 1.
			MatchLengthCodes at: length put: NumLiterals + code]].! !

!ZipConstants class methodsFor: 'private - initialization' stamp: 'nil'!
initializeExtraBits
	ExtraLengthBits := 
		WordArray withAll: #(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).
	ExtraDistanceBits := 
		WordArray withAll: #(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).
	ExtraBitLengthBits := 
		WordArray withAll: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 7).
	BitLengthOrder :=
		WordArray withAll: #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15)! !

!ZipCrcTest commentStamp: ''!
Tests for correct CRC handling in ZipWriteStream!
!ZipCrcTest methodsFor: 'tests' stamp: ''!
testInvalidGZipCrc
	"See that a wrong CRC raises an appropriate error"
	| reader writer bytes crcByte |
	writer := GZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	crcByte := bytes byteAt: bytes size-5. "before the length"
	bytes byteAt: bytes size-5 put: (crcByte + 1 bitAnd: 255).

	reader := GZipReadStream on: bytes.
	self should:[reader upToEnd] raise: CRCError.

	reader := GZipReadStream on: bytes.
	self should:[reader contents] raise: CRCError.

	reader := GZipReadStream on: bytes.
	self should:[reader next: 100] raise: CRCError.! !

!ZipCrcTest methodsFor: 'tests' stamp: ''!
testMissingZipCrc
	"See that the lack of a CRC does not raise an error"

	| reader writer bytes readBytes |
	writer := ZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.
	bytes := writer encodedStream contents.
	reader := ZipReadStream on: bytes.
	readBytes := reader upToEnd.
	self assert: readBytes equals: 'Hello World'.
	reader := ZipReadStream on: bytes.
	reader contents.
	reader := ZipReadStream on: bytes.
	reader next: 100! !

!ZipCrcTest methodsFor: 'tests' stamp: ''!
testValidZLibCrc
	| reader writer bytes |
	writer := ZLibWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	reader := ZLibReadStream on: bytes.
	self assert: reader upToEnd equals: 'Hello World'.
	
	bytes := writer encodedStream contents.
	reader := ZLibReadStream on: bytes.
	self assert: (reader next: 100) equals: 'Hello World'.! !

!ZipCrcTest methodsFor: 'tests' stamp: ''!
testMissingGZipCrc
	"See that the lack of a CRC raises an appropriate error"
	| reader writer bytes |
	writer := GZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	bytes := bytes copyFrom: 1 to: bytes size-6.

	reader := GZipReadStream on: bytes.
	self should:[reader upToEnd] raise: CRCError.

	reader := GZipReadStream on: bytes.
	self should:[reader contents] raise: CRCError.

	reader := GZipReadStream on: bytes.
	self should:[reader next: 100] raise: CRCError.! !

!ZipCrcTest methodsFor: 'tests' stamp: ''!
testMissingZLibCrc
	"See that the lack of a CRC raises an appropriate error"
	| reader writer bytes |
	writer := ZLibWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	bytes := bytes copyFrom: 1 to: bytes size-2.

	reader := ZLibReadStream on: bytes.
	self should:[reader upToEnd] raise: CRCError.

	reader := ZLibReadStream on: bytes.
	self should:[reader contents] raise: CRCError.

	reader := ZLibReadStream on: bytes.
	self should:[reader next: 100] raise: CRCError.! !

!ZipCrcTest methodsFor: 'tests' stamp: ''!
testInvalidZLibCrc
	"See that a wrong CRC raises an appropriate error"
	| reader writer bytes crcByte |
	writer := ZLibWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	crcByte := bytes byteAt: bytes size-2.
	bytes byteAt: bytes size-2 put: (crcByte + 1 bitAnd: 255).

	reader := ZLibReadStream on: bytes.
	self should:[reader upToEnd] raise: CRCError.

	reader := ZLibReadStream on: bytes.
	self should:[reader contents] raise: CRCError.

	reader := ZLibReadStream on: bytes.
	self should:[reader next: 100] raise: CRCError.! !

!ZipCrcTest methodsFor: 'tests' stamp: ''!
testInvalidZipCrc
	"See that a wrong CRC raises an appropriate error"
	| reader writer bytes |
	writer := ZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.

	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc - 1.
	self should:[reader upToEnd] raise: CRCError.

	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc - 1.
	self should:[reader contents] raise: CRCError.

	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc - 1.
	self should:[reader next: 100] raise: CRCError.! !

!ZipCrcTest methodsFor: 'tests' stamp: ''!
testValidGZipCrc
	| reader writer bytes |
	writer := GZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	reader := GZipReadStream on: bytes.
	self assert: reader upToEnd equals: 'Hello World'.! !

!ZipCrcTest methodsFor: 'tests' stamp: ''!
testValidZipCrc
	"See that a correct CRC does not raise an error and that we can read what we wrote."

	| reader writer bytes readBytes |
	writer := ZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.
	bytes := writer encodedStream contents.
	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc.
	readBytes := reader upToEnd.
	self assert: readBytes equals: 'Hello World'.
	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc.
	readBytes := reader contents.
	self assert: readBytes equals: 'Hello World'.
	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc.
	readBytes := reader next: 11.
	self assert: readBytes equals: 'Hello World'.
	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc.
	readBytes := reader next: 100.
	self assert: readBytes equals: 'Hello World'! !

!ZipDirectoryMember commentStamp: ''!
ZipFileMember instances represent directories inside ZipArchives.
They don't do much other than hold names and permissions (and extra fields).

You can add files in subdirectories to a ZipArchive without using any ZipDirectoryMembers.!
!ZipDirectoryMember methodsFor: 'accessing' stamp: 'nil'!
desiredCompressionMethod: aNumber! !

!ZipDirectoryMember methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	externalFileAttributes := self mapPermissionsFromUnix: DefaultDirectoryPermissions.
	super desiredCompressionMethod: CompressionStored.! !

!ZipDirectoryMember methodsFor: 'accessing' stamp: 'nil'!
localFileName: aString
	super localFileName: (aString copyWith: $/).
	externalFileName ifAbsent: [ ^ self ].
	self modifiedAt: externalFileName entry modificationTime! !

!ZipDirectoryMember methodsFor: 'private - writing' stamp: 'nil'!
writeDataTo: aStream
	"Write nothing. Directories have no contents to write."! !

!ZipDirectoryMember methodsFor: 'private' stamp: 'nil'!
rewindData! !

!ZipDirectoryMember methodsFor: 'testing' stamp: 'nil'!
usesFile: aFileReferenceOrFileName
	^false! !

!ZipDirectoryMember methodsFor: 'private' stamp: 'nil'!
asDirectory
	^self! !

!ZipDirectoryMember methodsFor: 'testing' stamp: 'nil'!
isDirectory
	^true! !

!ZipDirectoryMember class methodsFor: 'instance creation' stamp: 'nil'!
newFromDirectory: aFileReference localName: localName

	^ self new
		  externalFile: aFileReference;
		  localFileName: localName;
		  yourself! !

!ZipEncoder commentStamp: ''!
A ZIP encoder!
!ZipEncoder methodsFor: 'private' stamp: 'nil'!
pastEndPut: anObject
	"Flush the current buffer and store the new object at the beginning"
	self commit.
	^self nextBytePut: anObject asInteger! !

!ZipEncoder methodsFor: 'positioning' stamp: 'nil'!
bitPosition
	^ encodedStream position + position * 8 + bitPosition.! !

!ZipEncoder methodsFor: 'accessing' stamp: 'nil'!
nextBits: nBits put: value
	"Store a value of nBits"
	"self assert:[value >= 0 and:[(1 bitShift: nBits) > value]]."
	bitBuffer := bitBuffer bitOr: (value bitShift: bitPosition).
	bitPosition := bitPosition + nBits.
	[bitPosition >= 8] whileTrue:[
		self nextBytePut: (bitBuffer bitAnd: 255).
		bitBuffer := bitBuffer bitShift: -8.
		bitPosition := bitPosition - 8]! !

!ZipEncoder methodsFor: 'initialization' stamp: 'nil'!
on: aCollectionOrStream
	encodedStream := aCollectionOrStream isStream
		ifTrue: [ aCollectionOrStream ]
		ifFalse: [ aCollectionOrStream writeStream ].
	encodedStream isBinary
		ifTrue: [ super on: (ByteArray new: 4096) ]
		ifFalse: [ super on: (String new: 4096) ].
	bitPosition := bitBuffer := 0! !

!ZipEncoder methodsFor: 'block encoding' stamp: 'nil'!
sendBlock: literalStream with: distanceStream with: litTree with: distTree
	"Send the current block using the encodings from the given literal/length and distance tree"
	| result |
	result := 0.
	[literalStream atEnd] whileFalse:[
		result := result + (self privateSendBlock: literalStream
						with: distanceStream with: litTree with: distTree).
		self commit.
	].
	self nextBits: (litTree bitLengthAt: EndBlock) put: (litTree codeAt: EndBlock).
	^result! !

!ZipEncoder methodsFor: 'flushing' stamp: 'nil'!
flushBits
	"Flush currently unsent bits"
	[bitPosition > 0] whileTrue:[
		self nextBytePut: (bitBuffer bitAnd: 255).
		bitBuffer := bitBuffer bitShift: -8.
		bitPosition := bitPosition - 8].
	bitPosition := 0! !

!ZipEncoder methodsFor: 'accessing' stamp: 'nil'!
nextBytePut: anObject
	"Primitive. Insert the argument at the next position in the Stream
	represented by the receiver. Fail if the collection of this stream is not an
	Array or a String. Fail if the stream is positioned at its end, or if the
	position is out of bounds in the collection. Fail if the argument is not
	of the right type for the collection. Optional. See Object documentation
	whatIsAPrimitive."

	^ position >= writeLimit
		ifTrue: [ self pastEndPut: anObject ]
		ifFalse: [ position := position + 1.
			collection byteAt: position put: anObject ]! !

!ZipEncoder methodsFor: 'open/close' stamp: 'nil'!
close
	self flush.
	encodedStream close! !

!ZipEncoder methodsFor: 'private' stamp: 'nil'!
privateSendBlock: literalStream with: distanceStream with: litTree with: distTree
	"Send the current block using the encodings from the given literal/length and distance tree"
	| lit dist code extra sum |
	<primitive: 'primitiveZipSendBlock' module: 'ZipPlugin'>
	sum := 0.
	[ lit := literalStream next.
	  dist := distanceStream next.
	  lit isNil ] whileFalse:[
		dist = 0 ifTrue:["lit is a literal"
			sum := sum + 1.
			self nextBits: (litTree bitLengthAt: lit)
				put: (litTree codeAt: lit).
		] ifFalse:["lit is match length"
			sum := sum + lit + MinMatch.
			code := (MatchLengthCodes at: lit + 1).
			self nextBits: (litTree bitLengthAt: code)
				put: (litTree codeAt: code).
			extra := ExtraLengthBits at: code-NumLiterals.
			extra = 0 ifFalse:[
				lit := lit - (BaseLength at: code-NumLiterals).
				self nextBits: extra put: lit.
			].
			dist := dist - 1.
			code := dist < 256
				ifTrue:[ DistanceCodes at: dist + 1]
				ifFalse:[ DistanceCodes at: 257 + (dist bitShift: -7) ].
			"self assert:[code < MaxDistCodes]."
			self nextBits: (distTree bitLengthAt: code)
				put: (distTree codeAt: code).
			extra := ExtraDistanceBits at: code+1.
			extra = 0 ifFalse:[
				dist := dist - (BaseDistance at: code+1).
				self nextBits: extra put: dist.
			].
		].
	].
	^sum! !

!ZipEncoder methodsFor: 'initialization' stamp: 'nil'!
commit
	encodedStream next: position putAll: collection.
	position := readLimit := 0! !

!ZipEncoder methodsFor: 'flushing' stamp: 'nil'!
flush
	self flushBits.
	self commit! !

!ZipEncoder methodsFor: 'accessing' stamp: 'nil'!
encodedStream
	^encodedStream! !

!ZipEncoderNode commentStamp: ''!
ZipEncoderNode represents a node in a huffman tree for encoding ZipStreams.

Instance variables:
	value 		<Integer>	- Encoded value
	frequency	<Integer>	- Number of occurences of the encoded value
	height 		<Integer>	- Height of the node in the tree
	bitLength 	<Integer>	- bit length of the code
	code		<Integer>	- Assigned code for this node
	parent		<ZipEncoderNode>		- Parent of this node
	left			<ZipEncoderNode>		- First child of this node
	right		<ZipEncoderNode>		- Second child of this node
!
!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
right: aNode
	aNode parent: self.
	right := aNode! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
code
	^ code ifNil: [ 0 ]! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
left: aNode
	aNode parent: self.
	left := aNode! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
right
	^right! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
frequency: aNumber
	frequency := aNumber! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
left
	^left! !

!ZipEncoderNode methodsFor: 'private' stamp: 'nil'!
setValue: v frequency: f height: h
	value := v.
	frequency := f.
	height := h! !

!ZipEncoderNode methodsFor: 'testing' stamp: 'nil'!
isLeaf
	^left isNil! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
parent: aNode
	parent := aNode! !

!ZipEncoderNode methodsFor: 'printing' stamp: 'nil'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(;
		nextPutAll:'value = '; print: value;
		nextPutAll:', freq = '; print: frequency;
		nextPutAll:', bitLength = '; print: bitLength;
		nextPutAll:', code = '; print: code;
		nextPutAll:', height = '; print: height; 
	nextPut:$)! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
parent
	^parent! !

!ZipEncoderNode methodsFor: 'private' stamp: 'nil'!
computeHeight
	^ height := self isLeaf
		ifTrue: [ 0 ]
		ifFalse: [ (left computeHeight max: right computeHeight) + 1 ]! !

!ZipEncoderNode methodsFor: 'encoding' stamp: 'nil'!
encodeBitLength: blCounts from: aTree

	| index |

	"Note: If bitLength is not nil then the tree must be broken"
	bitLength ifNotNil: [ self error: 'Huffman tree is broken' ].
	parent ifNil: [ bitLength := 0 ] ifNotNil: [ bitLength := parent bitLength + 1 ].
	self isLeaf
		ifTrue: [ index := bitLength + 1.
			blCounts at: index put: ( blCounts at: index ) + 1
			]
		ifFalse: [ left encodeBitLength: blCounts from: aTree.
			right encodeBitLength: blCounts from: aTree
			]! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
height
	^height! !

!ZipEncoderNode methodsFor: 'private' stamp: 'nil'!
setBitLengthTo: bl
	bitLength := bl! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
value
	^value! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
frequency
	^frequency! !

!ZipEncoderNode methodsFor: 'private' stamp: 'nil'!
leafNodes
	^ self isLeaf
		ifTrue: [ Array with: self ]
		ifFalse: [ left leafNodes , right leafNodes ]! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
code: aCode
	[ aCode >= 0 and: [ (1 bitShift: bitLength) > aCode ] ] assert.
	code := aCode! !

!ZipEncoderNode methodsFor: 'encoding' stamp: 'nil'!
rotateToHeight: maxHeight
	"Rotate the tree to achieve maxHeight depth"
	| newParent |
	height < 4 ifTrue:[^self].
	self left: (left rotateToHeight: maxHeight-1).
	self right: (right rotateToHeight: maxHeight-1).
	height := (left height max: right height) + 1.
	height <= maxHeight ifTrue:[^self].
	(left height - right height) abs <= 2 ifTrue:[^self].
	left height < right height ifTrue:[
		right right height >= right left height ifTrue:[
			newParent := right.
			self right: newParent left.
			newParent left: self.
		] ifFalse:[
			newParent := right left.
			right left: newParent right.
			newParent right: right.
			self right: newParent left.
			newParent left: self.
		].
	] ifFalse:[
		left left height >= left right height ifTrue:[
			newParent := left.
			self left: newParent right.
			newParent right: self.
		] ifFalse:[
			newParent := left right.
			left right: newParent left.
			newParent left: left.
			self left: newParent right.
			newParent right: self.
		].
	].
	parent computeHeight.
	^parent! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'nil'!
bitLength
	^ bitLength ifNil: [ 0 ]! !

!ZipEncoderNode class methodsFor: 'instance creation' stamp: 'nil'!
value: v frequency: f height: h
	^self new setValue: v frequency: f height: h! !

!ZipEncoderTree commentStamp: ''!
ZipEncoderTree represents a huffman tree for encoding ZipStreams.

Instance variables:
	bitLengths	<WordArray>	 - Bit lengths of each generated code
	codes		<WordArray>	 - Codes for each value
	maxCode		<Integer>	- Maximum value with non-zero frequency!
!ZipEncoderTree methodsFor: 'accessing' stamp: 'nil'!
maxCode: aNumber
	maxCode := aNumber! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'nil'!
bitLengths
	"Return an array of all bitLength values for valid codes"
	^bitLengths! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'nil'!
maxCode
	^maxCode! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'nil'!
bitLengthAt: index
	^ bitLengths at: index + 1! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'nil'!
buildTreeFrom: frequencies maxDepth: depth
	"Build the receiver from the given frequency values"
	| nodeList |
	nodeList := Array new: frequencies size.
	1 to: frequencies size do:[:i|
		nodeList at: i put: (ZipEncoderNode value: i-1 frequency: (frequencies at: i) height: 0)
	].
	self buildTree: nodeList maxDepth: depth.! !

!ZipEncoderTree methodsFor: 'private' stamp: 'nil'!
setValuesFrom: nodeList
	self bitLengths: (nodeList
			collect: [:n | n bitLength]
			from: 1
			to: maxCode + 1)
		codes: (nodeList
				collect: [:n | n code]
				from: 1
				to: maxCode + 1)! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'nil'!
buildTree: nodeList maxDepth: depth
	"Build either the literal or the distance tree"
	| heap rootNode blCounts |
	heap := Heap new: nodeList size // 3.
	heap sortBlock: self nodeSortBlock.
	"Find all nodes with non-zero frequency and add to heap"
	maxCode := 0.
	nodeList do:[:dNode|
		dNode frequency = 0 ifFalse:[
			maxCode := dNode value.
			heap add: dNode]].
	"The pkzip format requires that at least one distance code exists,
	and that at least one bit should be sent even if there is only one
	possible code. So to avoid special checks later on we force at least
	two codes of non zero frequency."
	heap size = 0 ifTrue:[
		[maxCode = 0] assert.
		heap add: nodeList first.
		heap add: nodeList second.
		maxCode := 1].
	heap size = 1 ifTrue:[
		nodeList first frequency = 0
			ifTrue:[heap add: nodeList first]
			ifFalse:[heap add: nodeList second].
		maxCode := maxCode max: 1].
	rootNode := self buildHierarchyFrom: heap.
	rootNode height > depth ifTrue:[
		rootNode := rootNode rotateToHeight: depth.
		rootNode height > depth ifTrue:[self error:'Cannot encode tree']].
	blCounts := WordArray new: depth+1.
	rootNode encodeBitLength: blCounts from: self.
	self buildCodes: nodeList counts: blCounts maxDepth: depth.
	self setValuesFrom: nodeList.! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'nil'!
buildHierarchyFrom: aHeap
	"Build the node hierarchy based on the leafs in aHeap"
	| left right parent |
	[aHeap size > 1] whileTrue:[
		left := aHeap removeFirst.
		right := aHeap removeFirst.
		parent := ZipEncoderNode value: -1 
			frequency: (left frequency + right frequency)
			height: (left height max: right height) + 1.
		left parent: parent.
		right parent: parent.
		parent left: left.
		parent right: right.
		aHeap add: parent].
	^aHeap removeFirst! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'nil'!
codes
	"Return an array of all valid codes"
	^codes! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'nil'!
buildCodes: nodeList counts: blCounts maxDepth: depth
	"Build the codes for all nodes"
	| nextCode code node length |
	nextCode := WordArray new: depth+1.
	code := 0.
	1 to: depth do:[:bits|
		code := (code + (blCounts at: bits)) << 1.
		nextCode at: bits+1 put: code].
	[(code + (blCounts at: depth+1) - 1) = (1 << depth - 1)] assert.
	0 to: maxCode do:[:n|
		node := nodeList at: n+1.
		length := node bitLength.
		length = 0 ifFalse:[
			code := nextCode at: length+1.
			node code: (self reverseBits: code length: length).
			nextCode at: length+1 put: code+1.
		]
	]! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'nil'!
nodeSortBlock
	^ [ :n1 :n2 | 
	n1 frequency = n2 frequency
		ifTrue: [ n1 height <= n2 height ]
		ifFalse: [ n1 frequency <= n2 frequency ] ]! !

!ZipEncoderTree methodsFor: 'private' stamp: 'nil'!
reverseBits: code length: length
	"Bit reverse the given code"
	| result bit bits |
	result := 0.
	bits := code.
	1 to: length do:[:i|
		bit := bits bitAnd: 1.
		result := result << 1 bitOr: bit.
		bits := bits >> 1].
	^result! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'nil'!
codeAt: index
	^ codes at: index + 1! !

!ZipEncoderTree methodsFor: 'private' stamp: 'nil'!
bitLengths: blArray codes: codeArray
	bitLengths := blArray as: WordArray.
	codes := codeArray as: WordArray.
	[ (self bitLengthAt: maxCode) > 0 ] assert! !

!ZipEncoderTree class methodsFor: 'instance creation' stamp: 'nil'!
buildTreeFrom: frequencies maxDepth: depth
	^self new buildTreeFrom: frequencies maxDepth: depth! !

!ZipExtensionTest commentStamp: ''!
Test extension methods for Zip support!
!ZipExtensionTest methodsFor: 'tests' stamp: ''!
testBinaryZipped
	| data compressed |
	
	data := #[ 1 2 3 4 5 6 7 8 9 0 ].
	compressed := data zipped.
	self assert: compressed unzipped equals: data.
	
	data := #[].
	compressed := data zipped.
	self assert: compressed unzipped equals: data.
	
	data := #[ 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 ].
	compressed := data zipped.
	self assert: compressed unzipped equals: data.
	
	"next are the bytes written by 
	$ echo -n Pharo | gzip - > /tmp/foo.gz"
	compressed := #[31 139 8 0 94 254 149 93 0 3 11 200 72 44 202 7 0 144 33 178 137 5 0 0 0].
	self assert: compressed unzipped asString equals: 'Pharo'! !

!ZipExtensionTest methodsFor: 'tests' stamp: ''!
testZipped
	| compressed |
	compressed := 'hello' zipped.
	self assert: compressed unzipped equals: 'hello'! !

!ZipFileConstants commentStamp: ''!
This class defines magic numbers taken from the PKWARE ZIP Application 
Note [1] approved by ISO/IEC JTC 1/SC 34 N 1621 in July 2011 [2] to be 
the international normative reference for the zip file format.  A class 
imports these bindings as 'class variables' by including the following 
in its class definition: 
    poolDictionaries: 'ZipFileConstants' 
There is a single method on the class side to initialise the values. 

[1] http://www.pkware.com/documents/casestudies/APPNOTE.TXT
[2] http://www.itscj.ipsj.or.jp/sc34/open/1621.pdf

Following are pertinent extracts from the PKWARE ZIP Application Note.... 
All values are stored in little-endian byte order unless otherwise 
specified. 
A. local file header signature     4 bytes  (0x04034b50) 
C. Data descriptor: 
           crc-32                          4 bytes 
           compressed size                 4 bytes 
           uncompressed size               4 bytes 
F. central file header signature   4 bytes  (0x02014b50) 
I. end of central dir signature    4 bytes  (0x06054b50) 
J.  Explanation of fields: 
     * version made by (2 bytes) 
            0 - MS-DOS and OS/2 (FAT / VFAT / FAT32 file systems) 
            3 - UNIX 
            1,2,4-20 not implemented 
     * compression method: (2 bytes) 
            0 - The file is stored (no compression) 
            6 - The file is Imploded 
            8 - The file is Deflated 
            1-7,9-19,97,98 not implemented 
      * For Methods 8 and 9 - Deflating 
            Bit 2  Bit 1 
              0      0    Normal (-en) compression option was used. 
             0      1    Maximum (-exx/-ex) compression option was used. 
              1      0    Fast (-ef) compression option was used. 
             1      1    Super Fast (-es) compression option was 
used.                               
        * internal file attributes: (2 bytes) 
            Bits 1 and 2 are reserved for use by PKWARE. The lowest bit 
of this field indicates, if set, that the file is apparently an ASCII or 
text file.  If not set, that the file apparently contains binary data. 

Note the following do not appear in the PKWARE ZIP Application Note.   
Should they be defined elsewhere? 
"Unix permission bits" 
DefaultDirectoryPermissions    := 8r040755. 
DefaultFilePermissions        := 8r0100666. 
DirectoryAttrib         := 8r040000. 
FileAttrib             := 8r0100000. !
!ZipFileConstants class methodsFor: 'class initialization' stamp: 'nil'!
initialize
	
	FaMsdos		:= 0.
	FaUnix 		:= 3.
	DeflatingCompressionNormal	:= 0.
	DeflatingCompressionMaximum	:= 2.
	DeflatingCompressionFast		:= 4.
	DeflatingCompressionSuperFast	:= 6.
	CompressionStored				:= 0.
	CompressionDeflated			:= 8.
	CompressionLevelNone			:= 0.
	CompressionLevelDefault		:= 6.
	IfaTextFile						:= 1.
	IfaBinaryFile					:= 0.
	DataDescriptorLength 			:= 12.

	"Unix permission bits"
	DefaultDirectoryPermissions	:= 8r040755.
	DefaultFilePermissions		:= 8r0100666.
	DirectoryAttrib 				:= 8r040000.
	FileAttrib 						:= 8r0100000.

	"0x02014b50 little-endian i.e. #(16r50 16r4B 16r01 16r02) [1]"
	CentralDirectoryFileHeaderSignature := #[80 75 1 2].
	
	"0x04034b50 little-endian i.e. #(16r50 16r4B 16r03 16r04) [1]"
	LocalFileHeaderSignature := #[80 75 3 4].
	
	"0x06054b50 little-endian i.e. #(16r50 16r4B 16r05 16r06) [1]"
	EndOfCentralDirectorySignature := #[80 75 5 6].
	
	"[1] http://en.wikipedia.org/wiki/Zip_(file_format)#File_headers"! !

!ZipFileMember commentStamp: ''!
ZipNewFileMember instances are used to represent files that have been read from a ZipArchive.
Their data stays in the file on disk, so the original Zip file cannot be directly overwritten.!
!ZipFileMember methodsFor: 'accessing' stamp: 'nil'!
externalFile: aFileReference
	externalFileName := aFileReference! !

!ZipFileMember methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	crc32 := 0.
	localHeaderRelativeOffset := 0.
	dataOffset := 0.! !

!ZipFileMember methodsFor: 'private - reading' stamp: 'nil'!
readLocalDirectoryFileHeaderFrom: aStream 
	"Positions stream as necessary. Will return stream to its original position"

	| fileNameLength extraFieldLength xcrc32 xcompressedSize xuncompressedSize sig oldPos endianStream |

	oldPos := aStream position.

	aStream position: localHeaderRelativeOffset.

	sig := aStream next: 4.
	sig = LocalFileHeaderSignature asByteArray
		ifFalse: [ aStream position: oldPos.
				^self error: 'bad LH signature at ', localHeaderRelativeOffset printStringHex ].

	endianStream := ZnEndianessReadWriteStream on: aStream.
	versionNeededToExtract := endianStream nextLittleEndianNumber: 2.
	self bitFlag: (endianStream nextLittleEndianNumber: 2).
	compressionMethod := endianStream nextLittleEndianNumber: 2.
	lastModFileDateTime := self unzipTimestamp: (endianStream nextLittleEndianNumber: 4).
	xcrc32 := endianStream nextLittleEndianNumber: 4.
	xcompressedSize := endianStream nextLittleEndianNumber: 4.
	xuncompressedSize := endianStream nextLittleEndianNumber: 4.

	fileNameLength := endianStream nextLittleEndianNumber: 2.
	extraFieldLength := endianStream nextLittleEndianNumber: 2.

	fileName := (aStream next: fileNameLength) asString.
	localExtraField := (aStream next: extraFieldLength) asByteArray.

	dataOffset := aStream position.

	"Don't trash these fields if we already got them from the central directory"
	self hasDataDescriptor ifFalse: [
		crc32 := xcrc32.
		compressedSize := xcompressedSize.
		uncompressedSize := xuncompressedSize.
	].

	aStream position: oldPos.! !

!ZipFileMember methodsFor: 'private - writing' stamp: 'nil'!
copyDataTo: aStream

	self copyRawDataTo: aStream.! !

!ZipFileMember methodsFor: 'initialization' stamp: 'nil'!
stream: aStream externalFileName: aFileName
	stream := aStream.
	externalFileName := aFileName.! !

!ZipFileMember methodsFor: 'private - reading' stamp: 'nil'!
canonicalizeFileName
	"For security reasons, make all paths relative and remove any ../ portions"

	[fileName beginsWith: '/'] whileTrue: [fileName := fileName allButFirst].
	fileName := fileName copyReplaceAll: '../' with: ''! !

!ZipFileMember methodsFor: 'private - reading' stamp: 'nil'!
rewindData
	super rewindData.
	(stream isNil or: [ stream closed ])
		ifTrue: [ self error: 'stream missing or closed' ].
	stream position: (localHeaderRelativeOffset + 4).
	self skipLocalDirectoryFileHeaderFrom: stream.! !

!ZipFileMember methodsFor: 'private - reading' stamp: 'nil'!
unzipTimestamp: dosTimestampInteger

	^ [ DateAndTime fromDosTimestamp: dosTimestampInteger ]
		on: Error
		do: [ "Assume we're dealing with the old, incorrect format"
			DateAndTime fromSeconds: 2492992800 + dosTimestampInteger ]! !

!ZipFileMember methodsFor: 'private - reading' stamp: 'nil'!
readRawChunk: n
	^stream next: n! !

!ZipFileMember methodsFor: 'private - writing' stamp: 'nil'!
uncompressDataTo: aStream

	| decoder buffer crcErrorMessage |
	decoder := ZipReadStream on: stream.
	decoder expectedCrc: self crc32.
	buffer := ByteArray new: (32768 min: readDataRemaining).
	crcErrorMessage := nil.

	[[ readDataRemaining > 0 ] whileTrue: [
		| chunkSize |
		chunkSize := 32768 min: readDataRemaining.
		buffer := decoder next: chunkSize into: buffer startingAt: 1.
		aStream next: chunkSize putAll: buffer startingAt: 1.
		readDataRemaining := readDataRemaining - chunkSize.
	]] on: CRCError do: [ :ex | crcErrorMessage := ex messageText. ex resume ].

	crcErrorMessage ifNotNil: [ self isCorrupt: true. CRCError signal: crcErrorMessage ]! !

!ZipFileMember methodsFor: 'private - writing' stamp: 'nil'!
localHeaderRelativeOffset
	^localHeaderRelativeOffset! !

!ZipFileMember methodsFor: 'initialization' stamp: 'nil'!
close
	stream ifNotNil:[stream close].! !

!ZipFileMember methodsFor: 'private - writing' stamp: 'nil'!
uncompressDataTo: aStream from: start to: finish

	| decoder buffer chunkSize |
	decoder := FastInflateStream on: stream.
	readDataRemaining := readDataRemaining min: finish - start + 1.
	buffer := ByteArray new: (32768 min: readDataRemaining).
	decoder next: start - 1.

	[ readDataRemaining > 0 ] whileTrue: [
		chunkSize := 32768 min: readDataRemaining.
		buffer := decoder next: chunkSize into: buffer startingAt: 1.
		aStream next: chunkSize putAll: buffer startingAt: 1.
		readDataRemaining := readDataRemaining - chunkSize.
	].! !

!ZipFileMember methodsFor: 'testing' stamp: 'nil'!
looksLikeDirectory
	^fileName last = $/
		and: [ uncompressedSize = 0 ]! !

!ZipFileMember methodsFor: 'private - reading' stamp: 'nil'!
skipLocalDirectoryFileHeaderFrom: aStream 
	"Assumes that stream is positioned after signature."

	|  extraFieldLength fileNameLength endianStream |
	aStream next: 22.
	
	endianStream := ZnEndianessReadWriteStream on: aStream.
	fileNameLength := endianStream nextLittleEndianNumber: 2.
	extraFieldLength := endianStream nextLittleEndianNumber: 2.
	aStream next: fileNameLength.
	aStream next: extraFieldLength.
	dataOffset := aStream position.! !

!ZipFileMember methodsFor: 'private - reading' stamp: 'nil'!
readFrom: aStream 
	"assumes aStream positioned after CD header; leaves stream positioned after my CD entry"

	self readCentralDirectoryFileHeaderFrom: aStream.
	self readLocalDirectoryFileHeaderFrom: aStream.
	self endRead.
	self canonicalizeFileName.! !

!ZipFileMember methodsFor: 'testing' stamp: 'nil'!
usesFile: aFileReferenceOrFileName
	"Do I require aFileName? That is, do I care if it's clobbered?"
	^ externalFileName asFileReference = aFileReferenceOrFileName asFileReference! !

!ZipFileMember methodsFor: 'private - reading' stamp: 'nil'!
readCentralDirectoryFileHeaderFrom: aStream
	"Assumes aStream positioned after signature"

	| fileNameLength extraFieldLength fileCommentLength endianStream |

	endianStream := ZnEndianessReadWriteStream on: aStream.
	self versionMadeBy: (endianStream nextLittleEndianNumber: 1).
	fileAttributeFormat := endianStream nextLittleEndianNumber: 1.

	self versionNeededToExtract: (endianStream nextLittleEndianNumber: 2).
	self bitFlag: (endianStream nextLittleEndianNumber: 2).
	compressionMethod := endianStream nextLittleEndianNumber: 2.
	lastModFileDateTime := self unzipTimestamp: (endianStream nextLittleEndianNumber: 4).
	crc32 := endianStream nextLittleEndianNumber: 4.
	compressedSize := endianStream nextLittleEndianNumber: 4.
	uncompressedSize := endianStream nextLittleEndianNumber: 4.

	fileNameLength := endianStream nextLittleEndianNumber: 2.
	extraFieldLength := endianStream nextLittleEndianNumber: 2.
	fileCommentLength := endianStream nextLittleEndianNumber: 2.
	endianStream nextLittleEndianNumber: 2. 	"disk number start"
	internalFileAttributes := endianStream nextLittleEndianNumber: 2.

	externalFileAttributes := endianStream nextLittleEndianNumber: 4.
	localHeaderRelativeOffset := endianStream nextLittleEndianNumber: 4.

	fileName := (aStream next: fileNameLength) asString.
	cdExtraField := (aStream next: extraFieldLength) asByteArray asString.
	fileComment := (aStream next: fileCommentLength) asByteArray utf8Decoded.

	self desiredCompressionMethod: compressionMethod! !

!ZipFileMember class methodsFor: 'instance creation' stamp: 'nil'!
newFrom: stream named: fileName
	^(self new) stream: stream externalFileName: fileName! !

!ZipFileSystemDirectory commentStamp: ''!
I represent a zip file system entry for a directory. Together with ZipFileSystemFile I take care of lazily accessing archive members.!
!ZipFileSystemDirectory methodsFor: 'creation' stamp: ''!
ensureCreateFile: aFileName
	^ self 
		fileEntryAt: aFileName 
		put: (ZipFileSystemFile named: aFileName)! !

!ZipFileSystemFile commentStamp: ''!
I represent a zip file system entry for a file. Together with ZipFileSystemDirectory I take care of lazily accessing archive members.!
!ZipFileSystemFile methodsFor: 'accessing' stamp: ''!
member: aZipArchiveMember
	member := aZipArchiveMember! !

!ZipFileSystemFile methodsFor: 'accessing' stamp: ''!
member
	^ member! !

!ZipFileSystemFile methodsFor: 'accessing' stamp: ''!
bytes
	| uncompressed |
	uncompressed := self readFromMember.
	self updateSize: uncompressed size.
	^ uncompressed! !

!ZipFileSystemFile methodsFor: 'private' stamp: ''!
readFromMember
	^ ByteArray 
		new: self member uncompressedSize
		streamContents: [ :stream |		
			self member extractTo: stream ]! !

!ZipNewFileMember commentStamp: ''!
ZipNewFileMember instances are used to represent files that are going to be written to a ZipArchive.
Their data comes from external file streams.!
!ZipNewFileMember methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	externalFileName := ''.
	compressionMethod := CompressionStored.
	self mapPermissionsFromUnix: DefaultFilePermissions.! !

!ZipNewFileMember methodsFor: 'initialization' stamp: 'nil'!
from: aFileReference

	| entry |
	"Now get the size, attributes, and timestamps, and see if the file exists"
	self localFileName: (externalFileName := aFileReference fullName).
	reference := aFileReference.
	entry := aFileReference entry.
	compressedSize := uncompressedSize := entry size.
	desiredCompressionMethod := compressedSize > 0 ifTrue: [ CompressionDeflated ] ifFalse: [ CompressionStored ].
	self flag: 'When we replace Files with FileSystem, the following line won''t have to jump throught hoops (FS returns aDateAndTime)'.
	self modifiedAt: entry modificationTime.! !

!ZipNewFileMember methodsFor: 'private' stamp: 'nil'!
readRawChunk: n
	stream ifNil: [ stream := reference binaryReadStream ].
	^stream next: n! !

!ZipNewFileMember methodsFor: 'initialization' stamp: 'nil'!
close
	stream ifNotNil:[stream close].! !

!ZipNewFileMember methodsFor: 'testing' stamp: 'nil'!
usesFile: aFileReferenceOrFileName
	"Do I require aFileName? That is, do I care if it's clobbered?"
	^externalFileName asFileReference = aFileReferenceOrFileName asFileReference! !

!ZipNewFileMember methodsFor: 'initialization' stamp: 'nil'!
endRead
	
	super endRead.
	self close! !

!ZipNewFileMember class methodsFor: 'instance creation' stamp: 'nil'!
newFromFile: aFileReference

	^ self new from: aFileReference! !

!ZipReadStream commentStamp: ''!
ZipReadStream is intended for uncompressing the compressed contents of Zip archive members.

Since Zip archive members keep their expected CRC value separately in Zip headers, this class does not attempt to read the CRC from its input stream.

Instead, if you want the CRC verification to work you have to call #expectedCrc: with the expected CRC-32 value from the Zip member header.!
!ZipReadStream methodsFor: 'crc' stamp: 'nil'!
expectedCrc: aNumberOrNil
	"If expectedCrc is set, it will be compared against the calculated CRC32 in verifyCrc.
	This number should be the number read from the Zip header (which is the bitwise complement of my crc if all is working correctly)"
	expectedCrc := aNumberOrNil! !

!ZipReadStream methodsFor: 'crc' stamp: 'nil'!
verifyCrc
	"Verify the CRC-32 checksum calculated from the input against the expected CRC-32, if any.
	Answer the calculated CRC-32 in any case.
	Note that the CRC-32 used in Zip files is actually the bit inverse of the calculated value, so that is what is returned."

	| invertedCrc |
	invertedCrc := crc bitXor: 16rFFFFFFFF.
	(expectedCrc notNil and: [ expectedCrc ~= invertedCrc ])
		ifTrue: [ ^ self crcError: ('Wrong CRC-32 (expected {1} got {2}) (proceed to ignore)' format: { expectedCrc printStringHex. invertedCrc printStringHex }) ].
	^invertedCrc! !

!ZipReadStream methodsFor: 'crc' stamp: 'nil'!
updateCrc: oldCrc from: start to: stop in: aCollection
	^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection! !

!ZipReadStream methodsFor: 'initialization' stamp: 'nil'!
on: aCollection from: firstIndex to: lastIndex
	super on: aCollection from: firstIndex to: lastIndex.
	crc := 16rFFFFFFFF.
	expectedCrc := nil.! !

!ZipStore commentStamp: ''!
I'm a specific store for Zip file systems!
!ZipStore methodsFor: 'initialization' stamp: ''!
initializeWithReference: aReference
	self initialize.
	reference := aReference! !

!ZipStore methodsFor: 'printing' stamp: ''!
forReferencePrintOn: aStream
	aStream nextPutAll: 'zip://'! !

!ZipStore methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	root := ZipFileSystemDirectory new! !

!ZipStore methodsFor: 'public' stamp: ''!
open
	| archive |
	self reference exists
		ifFalse: [ ^ self ].
	archive := ZipArchive new.
	self reference
		binaryReadStreamDo: [ :input | 
			archive readFrom: input contents readStream.
			archive members
				do: [ :member | 
					| path |
					path := self pathFromMember: member.
					member isDirectory
						ifTrue: [ self ensureCreateDirectory: path ]
						ifFalse: [ 
							self ensureCreateDirectory: path parent.
							(self createFile: path) member: member ] ] ].
	^ self! !

!ZipStore methodsFor: 'private' stamp: ''!
pathFromMember: anArchiveMember
	| path |
	path := Path from: anArchiveMember fileName.
	^ path basename isEmpty
		ifTrue: [ path parent ]
		ifFalse: [ path ]! !

!ZipStore methodsFor: 'public' stamp: ''!
close
	| archive fs stream |
	archive := ZipArchive new.
	fs := FileSystem store: self.
	fs root allChildren do: 
		[ :each | 
		each isFile ifTrue: 
			[ each readStreamDo: 
				[ :output | 
				archive addString: output contents as: each path printString ] ] ].
	archive
		writeTo: (stream := WriteStream on: ByteArray new);
		close.
	self reference writeStreamDo: 
		[ :output | output nextPutAll: stream contents ]! !

!ZipStore methodsFor: 'public' stamp: ''!
reference
	^ reference! !

!ZipStore class methodsFor: 'instance creation' stamp: ''!
reference: aReference
	^ self basicNew
		initializeWithReference: aReference
		yourself! !

!ZipStringMember commentStamp: ''!
ZipStringMember instances are used to represent files that are going to be written to a ZipArchive.
Their data comes from in-image strings, though.!
!ZipStringMember methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	self contents: ''.
	compressionMethod := desiredCompressionMethod := CompressionStored.! !

!ZipStringMember methodsFor: 'private - writing' stamp: 'nil'!
rewindData
	super rewindData.
	stream := contents readStream.
	readDataRemaining := contents size! !

!ZipStringMember methodsFor: 'private' stamp: 'nil'!
readRawChunk: n
	^stream next: n! !

!ZipStringMember methodsFor: 'initialization' stamp: 'nil'!
contents
	^contents! !

!ZipStringMember methodsFor: 'initialization' stamp: 'nil'!
contents: aString
	contents := aString.
	compressedSize := uncompressedSize := aString size.
	"set the file date to now"
	self modifiedAt: DateAndTime now.! !

!ZipStringMember class methodsFor: 'instance creation' stamp: 'nil'!
newFrom: aString named: aFileName
	^(self new) contents: aString; localFileName: aFileName; yourself! !

!ZipWriteStream commentStamp: ''!
A ZIP write stream!
!ZipWriteStream methodsFor: 'encoding' stamp: 'nil'!
flushBlock: lastBlock
	"Send the current block"

	| lastFlag bitsRequired method bitsSent storedLength fixedLength dynamicLength blTree lTree dTree blBits blFreq |
	lastFlag := lastBlock
		ifTrue: [ 1 ]
		ifFalse: [ 0 ].

	"Compute the literal/length and distance tree"
	lTree := ZipEncoderTree buildTreeFrom: literalFreq maxDepth: MaxBits.
	dTree := ZipEncoderTree buildTreeFrom: distanceFreq maxDepth: MaxBits.

	"Compute the bit length tree"
	blBits := lTree bitLengths , dTree bitLengths.
	blFreq := WordArray new: MaxBitLengthCodes.
	self scanBitLengths: blBits into: blFreq.
	blTree := ZipEncoderTree
		buildTreeFrom: blFreq
		maxDepth: MaxBitLengthBits.

	"Compute the bit length for the current block.
	Note: Most of this could be computed on the fly but it's getting
	really ugly in this case so we do it afterwards."
	storedLength := self storedBlockSize.
	fixedLength := self fixedBlockSizeFor: lTree and: dTree.
	dynamicLength := self
		dynamicBlockSizeFor: lTree
		and: dTree
		using: blTree
		and: blFreq.
	VerboseLevel > 1
		ifTrue: [ 
			SystemNotification signal:
					(String
						streamContents: [ :stream | 
							stream
								nextPutAll: 'Block sizes (S/F/D):' space;
								print: storedLength // 8;
								nextPut: $/;
								print: fixedLength // 8;
								nextPut: $/;
								print: dynamicLength // 8;
								space;
								endEntry ]) ].

	"Check which method to use"
	method := self forcedMethod.
	method
		ifNil: [ method := (storedLength < fixedLength
				and: [ storedLength < dynamicLength ])
				ifTrue: [ #stored ]
				ifFalse: [ fixedLength < dynamicLength
						ifTrue: [ #fixed ]
						ifFalse: [ #dynamic ] ] ].
	(method == #stored and: [ blockStart < 0 ])
		ifTrue: [ "Cannot use #stored if the block is not available"
			method := fixedLength < dynamicLength
				ifTrue: [ #fixed ]
				ifFalse: [ #dynamic ] ].
	bitsSent := encoder bitPosition.	"# of bits sent before this block"
	bitsRequired := nil.
	method == #stored
		ifTrue: [ VerboseLevel > 0
				ifTrue: [ SystemNotification signal: 'S' ].
			bitsRequired := storedLength.
			encoder nextBits: 3 put: (StoredBlock << 1) + lastFlag.
			self sendStoredBlock ].
	method == #fixed
		ifTrue: [ VerboseLevel > 0
				ifTrue: [ SystemNotification signal: 'F' ].
			bitsRequired := fixedLength.
			encoder nextBits: 3 put: (FixedBlock << 1) + lastFlag.
			self sendFixedBlock ].
	method == #dynamic
		ifTrue: [ VerboseLevel > 0
				ifTrue: [ SystemNotification signal: 'D' ].
			bitsRequired := dynamicLength.
			encoder nextBits: 3 put: (DynamicBlock << 1) + lastFlag.
			self
				sendDynamicBlock: blTree
				literalTree: lTree
				distanceTree: dTree
				bitLengths: blBits ].
	bitsRequired = (encoder bitPosition - bitsSent)
		ifFalse: [ self error: 'Bits size mismatch' ].
	lastBlock
		ifTrue: [ self release ]
		ifFalse: [ self initializeNewBlock ]! !

!ZipWriteStream methodsFor: 'accessing' stamp: 'nil'!
crc
	^crc! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'nil'!
sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits
	"Send all the trees needed for dynamic huffman tree encoding"
	| lastValue lastCount value |
	encoder nextBits: 5 put: (lTree maxCode - 256).
	encoder nextBits: 5 put: (dTree maxCode).
	self sendBitLengthTree: blTree.
	bits size = 0 ifTrue:[^self].
	lastValue := bits at: 1.
	lastCount := 1.
	2 to: bits size do:[:i|
		value := bits at: i.
		value = lastValue 
			ifTrue:[lastCount := lastCount + 1]
			ifFalse:[self sendBitLength: lastValue repeatCount: lastCount tree: blTree.
					lastValue := value.
					lastCount := 1]].
	self sendBitLength: lastValue repeatCount: lastCount tree: blTree.! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'nil'!
sendBitLengthTree: blTree
	"Send the bit length tree"
	| blIndex bitLength |
	MaxBitLengthCodes to: 4 by: -1 do:[:maxIndex|
		blIndex := BitLengthOrder at: maxIndex.
		bitLength := blIndex <= blTree maxCode 
			ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0].
		(maxIndex = 4 or:[bitLength > 0]) ifTrue:[
			encoder nextBits: 4 put: maxIndex - 4.
			1 to: maxIndex do:[:j|
				blIndex := BitLengthOrder at: j.
				bitLength := blIndex <= blTree maxCode 
					ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0].
				encoder nextBits: 3 put: bitLength].
			^self]].! !

!ZipWriteStream methodsFor: 'initialization' stamp: 'nil'!
writeFooter
	"Write footer information if necessary"
	crc := crc bitXor: 16rFFFFFFFF.! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'nil'!
sendBitLength: bitLength repeatCount: repeatCount tree: aTree
	"Send the given bitLength, repeating repeatCount times"
	| count |
	count := repeatCount.
	bitLength = 0 ifTrue:[
		[count >= 11] whileTrue:[
			self sendBitLength: Repeat11To138 tree: aTree.
			encoder nextBits: 7 put: (count min: 138) - 11.
			count := (count - 138) max: 0].
		[count >= 3] whileTrue:[
			self sendBitLength: Repeat3To10 tree: aTree.
			encoder nextBits: 3 put: (count min: 10) - 3.
			count := (count - 10) max: 0].
		count timesRepeat:[self sendBitLength: bitLength tree: aTree].
	] ifFalse:[
		self sendBitLength: bitLength tree: aTree.
		count := count - 1.
		[count >= 3] whileTrue:[
			self sendBitLength: Repeat3To6 tree: aTree.
			encoder nextBits: 2 put: (count min: 6) - 3.
			count := (count - 6) max: 0].
		count timesRepeat:[self sendBitLength: bitLength tree: aTree].
	].! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'nil'!
dynamicBlockSizeFor: lTree and: dTree using: blTree and: blFreq
	"Compute the length for the current block using dynamic huffman trees"
	| bits index extra treeBits freq |
	bits := 3 "block type" + 5 "literal codes length" + 5 "distance codes length".

	"Compute the # of bits for sending the bit length tree"
	treeBits := 4. "Max index for bit length tree"
	index := MaxBitLengthCodes.
	[index >= 4] whileTrue:[
		(index = 4 or:[(blFreq at: (BitLengthOrder at: index)+1) > 0])
			ifTrue:[treeBits := treeBits + (index * 3).
					index := -1]
			ifFalse:[index := index - 1]].

	"Compute the # of bits for sending the literal/distance tree.
	Note: The frequency are already stored in the blTree"
	0 to: 15 do:[:i| "First, the non-repeating values"
		freq := blFreq at: i+1.
		freq > 0 ifTrue:[treeBits := treeBits + (freq * (blTree bitLengthAt: i))]].
	"Now the repeating values"
	(Repeat3To6 to: Repeat11To138) with: #(2 3 7) do:[:i :addl|
		freq := blFreq at: i+1.
		freq > 0 ifTrue:[
			treeBits := treeBits + (freq * ((blTree bitLengthAt: i) + addl "addl bits"))]].
	VerboseLevel > 1 ifTrue:[
		SystemNotification signal: ('[',  treeBits asString, ' bits for dynamic tree]')].
	bits := bits + treeBits.

	"Compute the size of the compressed block"
	0 to: NumLiterals do:[:i| "encoding of literals"
		freq := literalFreq at: i+1.
		freq > 0 ifTrue:[bits := bits + (freq * (lTree bitLengthAt: i))]].
	NumLiterals+1 to: lTree maxCode do:[:i| "encoding of match lengths"
		freq := literalFreq at: i+1.
		extra := ExtraLengthBits at: i-NumLiterals.
		freq > 0 ifTrue:[bits := bits + (freq * ((lTree bitLengthAt: i) + extra))]].
	0 to: dTree maxCode do:[:i| "encoding of distances"
		freq := distanceFreq at: i+1.
		extra := ExtraDistanceBits at: i+1.
		freq > 0 ifTrue:[bits := bits + (freq * ((dTree bitLengthAt: i) + extra))]].

	^bits! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'nil'!
scanBitLengths: bits into: anArray
	"Scan the trees and determine the frequency of the bit lengths.
	For repeating codes, emit a repeat count."
	| lastValue lastCount value |
	bits size = 0 ifTrue:[^self].
	lastValue := bits at: 1.
	lastCount := 1.
	2 to: bits size do:[:i|
		value := bits at: i.
		value = lastValue 
			ifTrue:[lastCount := lastCount + 1]
			ifFalse:[self scanBitLength: lastValue repeatCount: lastCount into: anArray.
					lastValue := value.
					lastCount := 1]].
	self scanBitLength: lastValue repeatCount: lastCount into: anArray.! !

!ZipWriteStream methodsFor: 'open/close' stamp: 'nil'!
close
	self deflateBlock.
	self flushBlock: true.
	encoder close.! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'nil'!
sendBitLength: bitLength tree: aTree
	"Send the given bitLength"
	encoder nextBits: (aTree bitLengthAt: bitLength) 
		put: (aTree codeAt: bitLength).! !

!ZipWriteStream methodsFor: 'accessing' stamp: 'nil'!
encodedStream
	^encoder encodedStream! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'nil'!
encodeMatch: length distance: dist
	"Encode the given match of length length starting at dist bytes ahead"
	| literal distance |
	dist > 0 
		ifFalse:[^self error:'Distance must be positive'].
	length < MinMatch 
		ifTrue:[^self error:'Match length must be at least ', MinMatch printString].
	litCount := litCount + 1.
	matchCount := matchCount + 1.
	literals at: litCount put: length - MinMatch.
	distances at: litCount put: dist.
	literal := (MatchLengthCodes at: length - MinMatch + 1).
	literalFreq at: literal+1 put: (literalFreq at: literal+1) + 1.
	dist < 257
		ifTrue:[distance := DistanceCodes at: dist]
		ifFalse:[distance := DistanceCodes at: 257 + (dist - 1 bitShift: -7)].
	distanceFreq at: distance+1 put: (distanceFreq at: distance+1) + 1.
	^self shouldFlush! !

!ZipWriteStream methodsFor: 'private' stamp: 'nil'!
updateCrc
	crcPosition <= position ifTrue:[
		bytesWritten := bytesWritten + position - crcPosition + 1.
		crc := self updateCrc: crc from: crcPosition to: position in: collection.
		crcPosition := position + 1].! !

!ZipWriteStream methodsFor: 'fixed blocks' stamp: 'nil'!
fixedBlockSizeFor: lTree and: dTree
	"Compute the length for the current block using fixed huffman trees"
	| bits extra |
	bits := 3 "block type".
	"Compute the size of the compressed block"
	0 to: NumLiterals do:[:i| "encoding of literals"
		bits := bits + ((literalFreq at: i+1) * (FixedLiteralTree bitLengthAt: i))].
	NumLiterals+1 to: lTree maxCode+1 do:[:i| "Encoding of match lengths"
		extra := ExtraLengthBits at: i-NumLiterals.
		bits := bits + ((literalFreq at: i+1) * ((FixedLiteralTree bitLengthAt: i) + extra))].
	0 to: dTree maxCode do:[:i| "encoding of distances"
		extra := ExtraDistanceBits at: i+1.
		bits := bits + ((distanceFreq at: i+1) * ((FixedDistanceTree bitLengthAt: i) + extra))].

	^bits! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'nil'!
shouldFlush
	"Check if we should flush the current block.
	Flushing can be useful if the input characteristics change."
	| nLits |
	litCount = literals size ifTrue:[^true]. "We *must* flush"
	(litCount bitAnd: 16rFFF) = 0 ifFalse:[^false]. "Only check every N kbytes"
	matchCount * 10 <= litCount ifTrue:[
		"This is basically random data. 
		There is no need to flush early since the overhead
		for encoding the trees will add to the overall size"
		^false].
	"Try to adapt to the input data.
	We flush if the ratio between matches and literals
	changes beyound a certain threshold"
	nLits := litCount - matchCount.
	nLits <= matchCount ifTrue:[^false]. "whow!! so many matches"
	^nLits * 4 <= matchCount! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'nil'!
scanBitLength: bitLength repeatCount: repeatCount into: anArray
	"Update the frequency for the aTree based on the given values"
	| count |
	count := repeatCount.
	bitLength = 0 ifTrue:[
		[count >= 11] whileTrue:[
			anArray at: Repeat11To138+1 put: (anArray at: Repeat11To138+1) + 1.
			count := (count - 138) max: 0].
		[count >= 3] whileTrue:[
			anArray at: Repeat3To10+1 put: (anArray at: Repeat3To10+1) + 1.
			count := (count - 10) max: 0].
		count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count].
	] ifFalse:[
		anArray at: bitLength+1 put: (anArray at: bitLength+1) + 1.
		count := count - 1.
		[count >= 3] whileTrue:[
			anArray at: Repeat3To6+1 put: (anArray at: Repeat3To6+1) + 1.
			count := (count - 6) max: 0].
		count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count].
	].! !

!ZipWriteStream methodsFor: 'initialization' stamp: 'nil'!
initialize
	super initialize.
	literals := ByteArray new: WindowSize.
	distances := WordArray new: WindowSize.
	literalFreq := WordArray new: MaxLiteralCodes.
	distanceFreq := WordArray new: MaxDistCodes.
	self initializeNewBlock.! !

!ZipWriteStream methodsFor: 'initialization' stamp: 'nil'!
initializeNewBlock
	"Initialize the encoder for a new block of data"
	literalFreq atAllPut: 0.
	distanceFreq atAllPut: 0.
	literalFreq at: EndBlock+1 put: 1.
	litCount := 0.
	matchCount := 0.! !

!ZipWriteStream methodsFor: 'stored blocks' stamp: 'nil'!
sendStoredBlock
	"Send an uncompressed block"
	| inBytes |
	inBytes := blockPosition - blockStart.
	encoder flushBits. "Skip to byte boundary"
	encoder nextBits: 16 put: inBytes.
	encoder nextBits: 16 put: (inBytes bitXor: 16rFFFF).
	encoder flushBits.
	1 to: inBytes do:[:i|
		encoder nextBytePut: (collection byteAt: blockStart+i)].! !

!ZipWriteStream methodsFor: 'initialization' stamp: 'nil'!
on: aCollectionOrStream
	crc := 16rFFFFFFFF.
	crcPosition := 1.
	bytesWritten := 0.
	encoder := ZipEncoder on: aCollectionOrStream.
	encoder isBinary
		ifTrue:[super on: ByteArray new]
		ifFalse:[super on: String new].
	self writeHeader.! !

!ZipWriteStream methodsFor: 'initialization' stamp: 'nil'!
writeHeader
	"Write header information if necessary"! !

!ZipWriteStream methodsFor: 'stored blocks' stamp: 'nil'!
storedBlockSize
	"Compute the length for the current block when stored as is"
	^3 "block type bits" 
		+ (8 - (encoder bitPosition + 3 bitAnd: 7) bitAnd: 7)"skipped bits to byte boundary"
			+ 32 "byte length + chksum" 
				+ (blockPosition - blockStart * 8) "actual data bits".! !

!ZipWriteStream methodsFor: 'private' stamp: 'nil'!
updateCrc: oldCrc from: start to: stop in: aCollection
	^self class updateCrc: oldCrc from: start to: stop in: aCollection! !

!ZipWriteStream methodsFor: 'fixed blocks' stamp: 'nil'!
sendFixedBlock
	"Send a block using fixed huffman trees"
	self sendCompressedBlock: FixedLiteralTree with: FixedDistanceTree.! !

!ZipWriteStream methodsFor: 'accessing' stamp: 'nil'!
forcedMethod
	"Return a symbol describing an enforced method or nil if the method should
	be chosen adaptively. Valid symbols are
		#stored	- store blocks (do not compress)
		#fixed	- use fixed huffman trees
		#dynamic	- use dynamic huffman trees."
	^nil! !

!ZipWriteStream methodsFor: 'initialization' stamp: 'nil'!
finish
	"Finish pending operation. Do not close output stream."
	self deflateBlock.
	self flushBlock: true.
	encoder flush.! !

!ZipWriteStream methodsFor: 'initialization' stamp: 'nil'!
release
	"We're done with compression. Do some cleanup."
	literals := distances := literalFreq := distanceFreq := nil.
	self updateCrc.
	encoder flushBits.
	self writeFooter.! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'nil'!
sendCompressedBlock: litTree with: distTree
	"Send the current block using the encodings from the given literal/length and distance tree"
	| sum |
	sum := encoder
			sendBlock: (ReadStream on: literals from: 1 to: litCount)
			with: (ReadStream on: distances from: 1 to: litCount)
			with: litTree
			with: distTree.
	sum = (blockPosition - blockStart) ifFalse:[self error:'Wrong number of bytes'].! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'nil'!
encodeLiteral: lit
	"Encode the given literal"
	litCount := litCount + 1.
	literals at: litCount put: lit.
	distances at: litCount put: 0.
	literalFreq at: lit+1 put: (literalFreq at: lit+1) + 1.
	^self shouldFlush! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'nil'!
sendDynamicBlock: blTree literalTree: lTree distanceTree: dTree bitLengths: bits
	"Send a block using dynamic huffman trees"
	self sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits.
	self sendCompressedBlock: lTree with: dTree.! !

!ZipWriteStream methodsFor: 'private' stamp: 'nil'!
moveContentsToFront
	"Need to update crc here"
	self updateCrc.
	super moveContentsToFront.
	crcPosition := position + 1.! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'nil'!
flushBlock
	^self flushBlock: false! !

!ZipWriteStream methodsFor: 'deflating' stamp: 'nil'!
deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch
	"^DeflatePlugin doPrimitive:#primitiveDeflateBlock"
	<primitive: 'primitiveDeflateBlock' module: 'ZipPlugin'>
	^super deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'nil'!
distanceCodes
	^DistanceCodes! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'nil'!
extraDistanceBits
	^ExtraDistanceBits! !

!ZipWriteStream class methodsFor: 'class initialization' stamp: 'nil'!
initialize
	"ZipWriteStream initialize"
	VerboseLevel := 0! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'nil'!
printRegressionStats: stats from: fd
	| raw compressed numFiles |
	raw := stats at: #rawSize ifAbsent: [ 0 ].
	raw = 0
		ifTrue: [ ^ self ].
	compressed := stats at: #compressedSize ifAbsent: [ 0 ].
	numFiles := stats at: #numFiles ifAbsent: [ 0 ].
	
	SystemNotification signal: (String streamContents: [ :aStream |
		aStream nextPutAll: fd fullName asString; cr.
		aStream tab; nextPutAll: 'Files compressed: '; nextPutAll: numFiles asStringWithCommas; cr.
		aStream tab; nextPutAll: 'Bytes compressed: '; nextPutAll: raw asStringWithCommas; cr.
		aStream tab; nextPutAll: 'Avg. compression ratio: '; nextPutAll: (compressed / raw asFloat * 100.0 truncateTo: 0.01) asString ])! !

!ZipWriteStream class methodsFor: 'crc' stamp: 'nil'!
updateCrc: oldCrc from: start to: stop in: aCollection
	^ CRC update: oldCrc from: start to: stop in: aCollection! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'nil'!
baseLength
	^BaseLength! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'nil'!
maxLiteralCodes
	^MaxLiteralCodes! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'nil'!
extraLengthBits
	^ExtraLengthBits! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'nil'!
maxDistanceCodes
	^MaxDistCodes! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'nil'!
matchLengthCodes
	^MatchLengthCodes! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'nil'!
baseDistance
	^BaseDistance! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'nil'!
regressionCompress: aFile into: tempFile notifiying: progressBar stats: stats
	"Compress aFile into tempFile"
	| zip encoded buffer |
	aFile binary.
	aFile position: 0.
	tempFile binary.
	buffer := ByteArray new: 4096.
	zip := self on: (ByteArray new: 10000).
	encoded := zip encodedStream.
	[aFile atEnd] whileFalse:[
		progressBar current: aFile position.
		zip nextPutAll: (aFile nextInto: buffer).
		encoded position > 0 ifTrue:[
			tempFile nextPutAll: encoded contents.
			encoded position: 0]].
	zip close.
	tempFile nextPutAll: encoded contents.
	^true! !

!ZipWriteStreamTest commentStamp: ''!
Unit tests for ZipWriteStream!
!ZipWriteStreamTest methodsFor: 'tests' stamp: ''!
testEmptyStrings
	| aStream zipStream |
	aStream := ByteArray new writeStream binary.
	zipStream := ZipWriteStream on: aStream.
	zipStream nextStringPut: ''.
	zipStream nextStringPut: ''.
	zipStream close.
	aStream close.
	aStream := aStream contents readStream binary.
	zipStream := ZipReadStream on: aStream.
	self assertEmpty: zipStream nextString.
	self assertEmpty: zipStream nextString.
	zipStream close.
	aStream close! !

!ZipWriteStreamTest methodsFor: 'tests' stamp: ''!
testZipped
	| compressed |
	
	compressed := 'hello' zipped.
	self assert: compressed unzipped equals: 'hello'! !

!ZnApplicationFormUrlEncodedEntity commentStamp: ''!
I am ZnApplicationFormUrlEncodedEntity, a concrete HTTP Entity 
holding a set of fields (key value pairs) that is form URL encoded.
I am a ZnEntity.

Part of Zinc HTTP Components.!
!ZnApplicationFormUrlEncodedEntity methodsFor: 'testing' stamp: ''!
isEmpty
	^ self fields isEmpty! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	self isEmpty
		ifTrue: [ ^ self ].
	stream space.
	fields printElementsOn: stream! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'enumerating' stamp: ''!
fieldsDo: block
	self fields keysAndValuesDo: block! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'accessing' stamp: ''!
add: association
	self at: association key put: association value! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	fields := ZnMultiValueDictionary new.
	self contentType: self class designatedMimeType ! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'writing' stamp: ''!
writeOn: stream
	"In most use cases, contentLength will have been asked first so that a representation is cached"
	
	representation isNil ifTrue: [ self computeRepresentation ].
	ZnUtils nextPutAll: representation on: stream! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'writing' stamp: ''!
writeRepresentationOn: stream
	self contentType charSet
		ifNotNil: [:charSet|
			ZnResourceMetaUtils
				writeQueryFields: self fields 
				withEncoder: (ZnCharacterEncoder newForEncoding: charSet)
				on: stream] 
		ifNil: [ 
			ZnResourceMetaUtils 
				writeQueryFields: self fields 
				on: stream ]! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'accessing' stamp: ''!
at: key put: value
	self invalidateRepresentation.
	^ self fields at: key put: value! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'accessing' stamp: ''!
contentLength
	contentLength isNil ifTrue: [ self computeRepresentation ].
	^ contentLength ! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'accessing' stamp: ''!
fields
	^ fields! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'accessing' stamp: ''!
at: key
	^ self fields at: key! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'accessing' stamp: ''!
at: key add: value
	self invalidateRepresentation.
	^ self fields at: key add: value! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'testing' stamp: ''!
includesField: field
	^ self fields includesKey: field! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'accessing' stamp: ''!
at: key ifAbsent: block
	^ self fields at: key ifAbsent: block! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'private' stamp: ''!
invalidateRepresentation
	representation := nil.
	contentLength := nil! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'accessing' stamp: ''!
addAll: keyedCollection
	"Note that we use #addAllMulti:"

	self invalidateRepresentation.
	self fields addAllMulti: keyedCollection.
	^ keyedCollection ! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'accessing' stamp: ''!
contents
	^ self fields! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'private' stamp: ''!
computeRepresentation
	representation := String streamContents: [ :stream | self writeRepresentationOn: stream ].
	contentLength := representation size! !

!ZnApplicationFormUrlEncodedEntity methodsFor: 'initialize-release' stamp: ''!
readFrom: stream
	"We parse from stream, limited to content length if available."
	
	| readStream |
	representation := nil.
	contentLength isNil
		ifTrue: [ readStream := ZnCharacterReadStream on: stream encoding: 'ascii' ]
		ifFalse: [ (readStream := ZnLimitedReadStream on: stream limit: contentLength) ascii ].
	fields := ZnResourceMetaUtils parseQueryFrom: readStream! !

!ZnApplicationFormUrlEncodedEntity class methodsFor: 'testing' stamp: ''!
designatedMimeType
	^ ZnMimeType applicationFormUrlEncoded ! !

!ZnApplicationFormUrlEncodedEntity class methodsFor: 'instance creation' stamp: ''!
withAll: keyedCollection
	^ self new
		addAll: keyedCollection;
		yourself ! !

!ZnBase64Encoder commentStamp: ''!
I am ZnBase64Encoder.

Base64 encoding is a technique to encode binary data as a string of characters that can be safely transported over various protocols. Basically, every 3 bytes are encoded using 4 characters from an alphabet of 64. Each encoded character represents 6 bits.

The most commonly used alphabet is 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'. One or two equal signs (= or ==) are used for padding.

  ZnBase64Encoder new encode: #[0 1 2 3 4 5].
  ZnBase64Encoder new encode: #[10 20]
  ZnBase64Encoder new decode: 'BQQDAgEA'.
  ZnBase64Encoder new decode: 'FAo='.

The encoded data can optionally be broken into lines. Characters not part of the alphabet are considered as white space and are ignored when inbetween groups of 4 characters.

My #encode: method works from ByteArray to String, while my #decode: method works from String to ByteArray.

Note that to encode a String as Base64, you first have to encode the characters as bytes using a character encoder.

See also http://en.wikipedia.org/wiki/Base64

Part of Zinc HTTP Components.!
!ZnBase64Encoder methodsFor: 'converting' stamp: ''!
decode: string
	"Decode a Base64 encoded string and return the resulting byte array"
	
	^ ByteArray 
		new: (self byteCountFor: string)
		streamContents: [ :byteStream | 
			self decode: string readStream to: byteStream ]! !

!ZnBase64Encoder methodsFor: 'converting' stamp: ''!
decode: stringStream to: byteStream
	| char1 char2 char3 char4 |
	[ stringStream atEnd ] whileFalse: [ 
		self skipWhitespace: stringStream.
		stringStream atEnd ifTrue: [ ^ self ].
		char1 := stringStream next.
		char2 := stringStream next.
		char3 := stringStream next.
		char4 := stringStream next.
		char1 isNil | char2 isNil | char3 isNil | char4 isNil
			ifTrue: [ ZnCharacterEncodingError signal: 'Illegal Base64 input' ].
		self decode: char1 and: char2 and: char3 and: char4 to: byteStream ]! !

!ZnBase64Encoder methodsFor: 'initialization' stamp: ''!
alphabet: string
	"Set the alphabet to use to string, containing 64 characters to represent 64 byte values.
	I automatically compute the inverse used for fast decoding."
	
	self assert: string size = 64 description: '64 characters are needed for a Base64 alphabet'.
	alphabet := string.
	inverse := Array new: 128.
	0 to: 127 do: [ :each | 
		| offset |
		offset := alphabet indexOf: each asCharacter ifAbsent: [ nil ].
		inverse at: each + 1 put: (offset ifNotNil: [ offset - 1 ]) ]! !

!ZnBase64Encoder methodsFor: 'converting' stamp: ''!
encode: byteStream to: stringStream
	| byte1 byte2 byte3 count |
	lineLength
		ifNil: [ 
			[ byteStream atEnd ] whileFalse: [ 
				byte1 := byteStream next.
				byte2 := byteStream next.
				byte3 := byteStream next.
				self encode: byte1 and: byte2 and: byte3 to: stringStream ] ]
		ifNotNil: [ 
			count := 0.
			[ byteStream atEnd ] whileFalse: [ 
				byte1 := byteStream next.
				byte2 := byteStream next.
				byte3 := byteStream next.
				self encode: byte1 and: byte2 and: byte3 to: stringStream.
				(count := count + 4) = lineLength
					ifTrue: [ 
						stringStream nextPutAll: lineEnd.
						count := 0 ] ] ]! !

!ZnBase64Encoder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	alphabet := DefaultAlphabet.
	inverse := DefaultInverse.
	self whitespace: #any! !

!ZnBase64Encoder methodsFor: 'private' stamp: ''!
valueForCharacter: char
	| code |
	(code := char asciiValue) < 128
		ifTrue: [ 
			(inverse at: code + 1)
				ifNotNil: [ :byteValue | ^ byteValue ] ].
	ZnCharacterEncodingError signal: 'Illegal Base64 input'! !

!ZnBase64Encoder methodsFor: 'private' stamp: ''!
byteCountFor: string	
	| n byteCount |
	"This assumes there are no line breaks in string"
	n := string size.
	byteCount := n // 4 * 3.
	(n > 1 and: [ (string at: n) = $= ])
		ifTrue: [ 
			(n > 2 and: [ (string at: n - 1) = $= ])
				ifTrue: [ byteCount := byteCount - 2 ]
				ifFalse: [ byteCount := byteCount - 1 ] ].
	^ byteCount! !

!ZnBase64Encoder methodsFor: 'private' stamp: ''!
isLegalCharacter: character
	"Return true when character is part of my alphabet"

	| code |
	^ (code := character asciiValue) < 128 
			and: [ (inverse at: code + 1) notNil ]! !

!ZnBase64Encoder methodsFor: 'private' stamp: ''!
characterForValue: value
	^ alphabet at: value + 1! !

!ZnBase64Encoder methodsFor: 'initialization' stamp: ''!
whitespace: mode
	"Set the whitespace mode: 
	nil is no whitespace allowed, 
	#separator is CR, LF, FF, SPACE, TAB allowed,
	#any is all non-alphabet characters allowed (the default)"
	
	self assert: (#(nil separator any) includes: mode).
	whitespace := mode! !

!ZnBase64Encoder methodsFor: 'initialization' stamp: ''!
lineEndConvention: symbol
	"Set the end of line convention to be used.
	Either #cr, #lf or #crlf (the default)."
	
	self assert: (#(cr lf crlf) includes: symbol).
	lineEnd := String perform: symbol! !

!ZnBase64Encoder methodsFor: 'private' stamp: ''!
decode: char1 and: char2 and: char3 and: char4 to: stream
	| v1 v2 v3 v4 |
	v1 := self valueForCharacter: char1.
	v2 := self valueForCharacter: char2.
	stream nextPut: (v1 bitShift: 2) + (v2 bitShift: -4).
	char3 == $=
		ifFalse: [ 
			v3 := self valueForCharacter: char3.
			stream nextPut: ((v2 bitAnd: 2r1111) bitShift: 4) + (v3 bitShift: -2).
			char4 == $=
				ifFalse: [ 
						v4 := self valueForCharacter: char4.
						stream nextPut: ((v3 bitAnd: 2r11) bitShift: 6) + v4 ] ]! !

!ZnBase64Encoder methodsFor: 'private' stamp: ''!
isWhitespaceCharacter: character
	"Return true when character should be considered whitespace"

	whitespace 
		ifNil: [ "No whitespace allowed" 
			^ false ].
	whitespace = #separator
		ifTrue: [ "Only separators are considered whitespace" 
			^ character isSeparator ].
	whitespace = #any
		ifTrue: [ "All non-legal (non-alphabet) characters are considered whitespace" 
			^ (self isLegalCharacter: character) not ].
	^ false! !

!ZnBase64Encoder methodsFor: 'accessing' stamp: ''!
alphabet
	"Return the alphabet that I am using to encode byte values"
	
	^ alphabet ! !

!ZnBase64Encoder methodsFor: 'initialization' stamp: ''!
breakLines
	"Configure me to break lines and insert newlines every 76 characters while encoding"

	self breakLinesAt: 76! !

!ZnBase64Encoder methodsFor: 'initialization' stamp: ''!
breakLinesAt: length
	"Configure me to break lines at lenth, a multiple of 4, and insert newlines"

	self assert: (length \\ 4) isZero description: 'line length should be a multiple of 4'.
	lineLength := length.
	lineEnd ifNil: [ self lineEndConvention: #crlf ]! !

!ZnBase64Encoder methodsFor: 'converting' stamp: ''!
encode: byteArray
	"Encode byteArray using Base64 encoding and return the resulting string"
	
	^ String 
		new: (self characterCountFor: byteArray) 
		streamContents: [ :stringStream | 
			self encode: byteArray readStream to: stringStream ]! !

!ZnBase64Encoder methodsFor: 'private' stamp: ''!
encode: byte1 and: byte2 and: byte3 to: stream
	stream nextPut: (self characterForValue: (byte1 bitShift: -2)).
	byte2
		ifNil: [ 
			stream nextPut: (self characterForValue: ((byte1 bitAnd: 2r11) bitShift: 4)).
			stream nextPutAll: '==' ]
		ifNotNil: [ 
			stream nextPut: (self characterForValue: (((byte1 bitAnd: 2r11) bitShift: 4) + (byte2 bitShift: -4))).
			byte3
				ifNil: [ 
					stream nextPut: (self characterForValue: ((byte2 bitAnd: 2r1111) bitShift: 2)).
					stream nextPut: $= ]
				ifNotNil: [ 
					stream nextPut: (self characterForValue: (((byte2 bitAnd: 2r1111) bitShift: 2) + (byte3 bitShift: -6))).
					stream nextPut: (self characterForValue: (byte3 bitAnd: 2r111111)) ] ]! !

!ZnBase64Encoder methodsFor: 'private' stamp: ''!
skipWhitespace: stream
	[ stream atEnd not and: [ (self isWhitespaceCharacter: stream peek) ] ] 
		whileTrue: [ stream next ]! !

!ZnBase64Encoder methodsFor: 'private' stamp: ''!
characterCountFor: bytes
	| n characterCount | 
	n := bytes size.
	characterCount := n // 3 + (n \\ 3) sign * 4.
	^ lineLength isNil
		ifTrue: [ characterCount ]
		ifFalse: [ characterCount + ((characterCount // lineLength ) * lineEnd size) ]! !

!ZnBase64Encoder class methodsFor: 'class initialization' stamp: ''!
initialize
	DefaultAlphabet := String withAll: ($A to: $Z) , ($a to: $z) , ($0 to: $9) , #($+ $/).
	DefaultInverse := Array new: 128.
	0 to: 127 do: [ :each | 
		| offset |
		offset := DefaultAlphabet indexOf: each asCharacter ifAbsent: [ nil ].
		DefaultInverse at: each + 1 put: (offset ifNotNil: [ offset - 1 ]) ]! !

!ZnBase64EncoderTest methodsFor: 'testing' stamp: ''!
testCustomLineBreaking
	| encoder input output charCount |
	encoder := ZnBase64Encoder new.
	encoder breakLinesAt: 16.
	input := (0 to: 255) asByteArray.
	output := encoder encode: input.
	self assert: (encoder decode: output) equals: input.
	charCount := ((256 // 3) + (256 \\ 3) sign) * 4.
	self assert: output size equals: (charCount + (charCount // 16 * String crlf size))! !

!ZnBase64EncoderTest methodsFor: 'testing' stamp: ''!
testWhitespaceAtEnd
	| encoder |
	encoder := ZnBase64Encoder new.
	"whitespace is #any non-alphabet character"
	self assert: (encoder decode: 'TQ==' , String lf) equals: 'M' asByteArray.
	encoder whitespace: #separator.
	self assert: (encoder decode: 'TQ==' , String lf) equals: 'M' asByteArray.
	encoder whitespace: nil.
	self should: [ encoder decode: 'TQ==' , String lf ] raise: ZnCharacterEncodingError ! !

!ZnBase64EncoderTest methodsFor: 'testing' stamp: ''!
testEmpty
	| encoder |
	encoder := ZnBase64Encoder new.
	self 
		assert: (encoder encode: #[])
		equals: ''.
	self
		assert: (encoder decode: '')
		equals: #[]! !

!ZnBase64EncoderTest methodsFor: 'testing' stamp: ''!
testFullSpectrum
	| encoder input output |
	encoder := ZnBase64Encoder new.
	input := (0 to: 255) asByteArray , (255 to: 0) asByteArray.
	output := encoder encode: input.
	self assert: (encoder decode: output) equals: input.
	encoder breakLines.
	output := encoder encode: input.
	self assert: (encoder decode: output) equals: input.
! !

!ZnBase64EncoderTest methodsFor: 'testing' stamp: ''!
testFullAlphabet
	| encoder input output |
	encoder := ZnBase64Encoder new.
	input := encoder alphabet.
	output := encoder decode: input.
	self assert: (encoder encode: output) equals: input.
	encoder breakLines.
	output := encoder decode: input.
	self assert: (encoder encode: output) equals: input! !

!ZnBase64EncoderTest methodsFor: 'testing' stamp: ''!
testDecodingErrors
	| encoder |
	encoder := ZnBase64Encoder new.
	self should: [ encoder decode: 'A' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: 'AB' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: 'ABC' ] raise: ZnCharacterEncodingError.
	encoder whitespace: #separator.
	self should: [ encoder decode: '*' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: '**' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: '***' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: '****' ] raise: ZnCharacterEncodingError.
	encoder whitespace: nil.
	self should: [ encoder decode: '*' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: '**' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: '***' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: '****' ] raise: ZnCharacterEncodingError.! !

!ZnBase64EncoderTest methodsFor: 'testing' stamp: ''!
testQuote
	| input output encoder break |
	encoder := ZnBase64Encoder new lineEndConvention: #cr; breakLines; yourself.
	input := 'Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure.'.
	break := String with: Character cr.
	output := 'TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz' , break 
				, 'IHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg' , break 
				, 'dGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu' , break 
				, 'dWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo' , break 
				, 'ZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4='.
	self 
		assert: (encoder encode: input asByteArray)
		equals: output.
	self 
		assert: (encoder decode: output) 
		equals: input asByteArray ! !

!ZnBase64EncoderTest methodsFor: 'testing' stamp: ''!
testPadding
	| encoder |
	encoder := ZnBase64Encoder new.
	self assert: (encoder encode: 'M' asByteArray) equals: 'TQ=='.
	self assert: (encoder decode: 'TQ==') equals: 'M' asByteArray.
	self assert: (encoder encode: 'Ma' asByteArray) equals: 'TWE='.
	self assert: (encoder decode: 'TWE=') equals: 'Ma' asByteArray! !

!ZnBase64EncoderTest methodsFor: 'testing' stamp: ''!
testSimple
	| encoder |
	encoder := ZnBase64Encoder new.
	self 
		assert: (encoder encode: 'Man' asByteArray)
		equals: 'TWFu'.
	self
		assert: (encoder decode: 'TWFu')
		equals: 'Man' asByteArray ! !

!ZnBase64EncoderTest class methodsFor: 'benchmarks' stamp: ''!
bench1kEncode
	"self bench1kEncode"
	
	| bytes |
	bytes := ByteArray new: 1024 streamContents: [ :out |
		1024 timesRepeat: [ out nextPut: 256 atRandom - 1 ] ].
	^ [ ZnBase64Encoder new encode: bytes ] bench! !

!ZnBase64EncoderTest class methodsFor: 'benchmarks' stamp: ''!
bench10kDecode
	"self bench10kDecode"
	
	| string alphabet |
	alphabet := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789'. 
	string := String new: 10240 streamContents: [ :out |
		10240 timesRepeat: [ out nextPut: alphabet atRandom ] ].
	^ [ ZnBase64Encoder new decode: string ] bench! !

!ZnBase64EncoderTest class methodsFor: 'benchmarks' stamp: ''!
bench10kEncode
	"self bench10kEncode"
	
	| bytes |
	bytes := ByteArray new: 10240 streamContents: [ :out |
		10240 timesRepeat: [ out nextPut: 256 atRandom - 1 ] ].
	^ [ ZnBase64Encoder new encode: bytes ] bench! !

!ZnBase64EncoderTest class methodsFor: 'benchmarks' stamp: ''!
bench1kDecode
	"self bench1kDecode"
	
	| string alphabet |
	alphabet := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789'. 
	string := String new: 1024 streamContents: [ :out |
		1024 timesRepeat: [ out nextPut: alphabet atRandom ] ].
	^ [ ZnBase64Encoder new decode: string ] bench! !

!ZnBase64EncoderTest class methodsFor: 'benchmarks' stamp: ''!
benchmarks
	"self benchmarks"
	
	^ (#( bench1kEncode bench1kDecode bench10kEncode bench10kDecode )
		 collect: [ :each | each -> (self perform: each) ]) asDictionary! !

!ZnBasicAuthenticator commentStamp: ''!
I am ZnBasicAuthenticator.
I help servers handle HTTP Basic Authentication.
I implement the required #authenticateRequest:do:

I have a credentials dictionary with username->password associations.

Part of Zinc HTTP Components.!
!ZnBasicAuthenticator methodsFor: 'accessing' stamp: ''!
removeUsername: username
	credentials removeKey: username! !

!ZnBasicAuthenticator methodsFor: 'initialization' stamp: ''!
initialize
	credentials := Dictionary new! !

!ZnBasicAuthenticator methodsFor: 'public' stamp: ''!
authHeader
	^ 'Basic realm=', self realm! !

!ZnBasicAuthenticator methodsFor: 'accessing' stamp: ''!
realm: anObject
	realm := anObject! !

!ZnBasicAuthenticator methodsFor: 'accessing' stamp: ''!
realm
	^ realm ifNil: [ realm := self class defaultRealm ]! !

!ZnBasicAuthenticator methodsFor: 'accessing' stamp: ''!
removeAll
	credentials removeAll! !

!ZnBasicAuthenticator methodsFor: 'public' stamp: ''!
authenticateRequest: request do: block
	^ (self isRequestAuthenticated: request)
		ifTrue: [ block value ]
		ifFalse: [ ZnResponse unauthorized: self authHeader ]! !

!ZnBasicAuthenticator methodsFor: 'accessing' stamp: ''!
atUsername: username putPassword: password
	credentials at: username put: password! !

!ZnBasicAuthenticator methodsFor: 'testing' stamp: ''!
isRequestAuthenticated: request
	| authorization username password |
	authorization := [ request basicAuthentication ] on: Error do: [ ^ false ].
	username := authorization first.
	password := authorization second.
	^ (credentials at: username ifAbsent: [ nil ]) = password
	! !

!ZnBasicAuthenticator class methodsFor: 'instance creation' stamp: ''!
new
	^ super new 
		initialize;
		yourself! !

!ZnBasicAuthenticator class methodsFor: 'instance creation' stamp: ''!
username: username password: password realm: realm
	^ self new
		atUsername: username putPassword: password;
		realm: realm;
		yourself! !

!ZnBasicAuthenticator class methodsFor: 'accessing' stamp: ''!
defaultRealm
	^ 'ZincHTTPComponents'! !

!ZnBasicAuthenticator class methodsFor: 'instance creation' stamp: ''!
username: username password: password
	^ self new
		atUsername: username putPassword: password;
		yourself! !

!ZnBasicCredential commentStamp: ''!
I am ZnBasicCredential, a concrete subclass of ZnCredential.
I implement basic HTTP authentication.
I hold a username and password.

Part of Zinc HTTP Components.!
!ZnBasicCredential methodsFor: 'testing' stamp: ''!
isComplete 
	^ username notNil & password notNil ! !

!ZnBasicCredential methodsFor: 'accessing' stamp: ''!
password: anObject
	password := anObject! !

!ZnBasicCredential methodsFor: 'accessing' stamp: ''!
password
	^ password! !

!ZnBasicCredential methodsFor: 'accessing' stamp: ''!
authTokenForUrl: urlObject method: method
	^ 'Basic ', (ZnUtils encodeBase64: (username, ':', password)) ! !

!ZnBasicCredential methodsFor: 'accessing' stamp: ''!
username: anObject
	username := anObject! !

!ZnBasicCredential methodsFor: 'accessing' stamp: ''!
username
	^ username! !

!ZnBasicCredential class methodsFor: 'accessing' stamp: ''!
authName
	^ 'Basic'! !

!ZnBivalentWriteStream commentStamp: ''!
I am ZnBivalentWriteStream, wrapping another write stream.

I allow both Characters and Strings as well as Integers (0 to: 255) and ByteArrays to be writtten to me.

The write stream that I wrap can be both binary as well as character based.

Part of Zinc HTTP Components.!
!ZnBivalentWriteStream methodsFor: 'initialize-release' stamp: ''!
on: writeStream
	stream := writeStream! !

!ZnBivalentWriteStream methodsFor: 'accessing' stamp: ''!
space
	self nextPut: Character space! !

!ZnBivalentWriteStream methodsFor: 'private' stamp: ''!
isBinary
	binary isNil
		ifTrue: [ [ binary := stream isBinary ] on: MessageNotUnderstood do: [ :err | binary := false ] ].
	^ binary! !

!ZnBivalentWriteStream methodsFor: 'accessing' stamp: ''!
next: count putAll: collection startingAt: offset
	| buffer |
	self isBinary
		ifTrue: [ 
			(collection isKindOf: ByteArray)
				ifTrue: [ stream next: count putAll: collection startingAt: offset ]
				ifFalse: [ 
					buffer := ByteArray new: count.
					buffer replaceFrom: 1 to: count with: collection startingAt: offset.
					stream nextPutAll: buffer ] ]
		ifFalse: [ 
			(collection isKindOf: ByteArray)
				ifTrue: [ 
					buffer := String new: count.
					buffer replaceFrom: 1 to: count with: collection startingAt: offset.
					stream nextPutAll: buffer ]
				ifFalse: [ stream next: count putAll: collection startingAt: offset ] ]! !

!ZnBivalentWriteStream methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		nextPutAll: 'a '; 
		nextPutAll: self class name! !

!ZnBivalentWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: object
	self isBinary
		ifTrue: [ stream nextPut: object asInteger ]
		ifFalse: [ stream nextPut: object asCharacter ]! !

!ZnBivalentWriteStream methodsFor: 'initialize-release' stamp: ''!
close
	stream close! !

!ZnBivalentWriteStream methodsFor: 'accessing' stamp: ''!
flush
	stream flush! !

!ZnBivalentWriteStream methodsFor: 'accessing' stamp: ''!
nextPutAll: collection
	self isBinary
		ifTrue: [ stream nextPutAll: collection asByteArray ]
		ifFalse: [ stream nextPutAll: collection asString ]! !

!ZnBivalentWriteStream class methodsFor: 'instance creation' stamp: ''!
on: writeStream
	"Wrap writeStream as a ZnBivalentWriteStream, unless it is already one"
	
	(writeStream isKindOf: self) ifTrue: [ ^ writeStream ].
	
	^ self basicNew
		on: writeStream;
		yourself! !

!ZnBivalentWriteStreamTest methodsFor: 'testing' stamp: ''!
testByteWriting
	| string |
	string := String
		streamContents: [ :stream | 
			| writeStream |
			writeStream := ZnBivalentWriteStream on: stream.
			writeStream
				nextPut: 97;
				nextPutAll: #(98 99) asByteArray ].
	self assert: string asByteArray equals: #(97 98 99) asByteArray! !

!ZnBivalentWriteStreamTest methodsFor: 'testing' stamp: ''!
testCharacterWriting
	| bytes |
	bytes := ByteArray
		streamContents: [ :stream | 
			| writeStream |
			writeStream := ZnBivalentWriteStream on: stream.
			writeStream
				nextPut: $a;
				space;
				nextPutAll: '123' ].
	self assert: bytes equals: 'a 123' asByteArray! !

!ZnBufferedReadStream commentStamp: ''!
I am ZnBufferedReadStream.

I wrap another ReadStream and add efficient buffering for the typical access pattern of parsers: sending lots of #next, #peek and #atEnd messages.

By design I do not implement #position and #position: or anything based on that.

I can wrap both binary or character streams and act accordingly.

Part of Zinc HTTP Components.!
!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
nextIntegerOfSize: numberOfBytes signed: signed bigEndian: bigEndian
	"Assuming the receiver is a stream of bytes, read the next integer of size numberOfBytes.
	If bigEndian is true, use network byte order, most significant byte first, 
	else use little endian order, least significant byte first.
	If signed is true, interpret as a two-complement signed value, 
	else interpret as a plain unsigned value."
	
	| value |
	value := 0.
	bigEndian
		ifTrue: [ 
			(numberOfBytes - 1) * 8 to: 0 by: -8 do: [ :shift |
				value := value + (self next bitShift: shift) ] ]
		ifFalse: [ 
			0 to: (numberOfBytes - 1) * 8 by: 8 do: [ :shift |
				value := value + (self next bitShift: shift) ] ].
	^ (signed and: [ (value bitAt: numberOfBytes * 8) = 1 ])
		ifTrue: [ value - (1 << (numberOfBytes * 8)) ]
		ifFalse: [ value ]! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
position
	
	"If the buffer advanced, we need to check the original stream position, minus what we have read.
	The -1 is because the buffer is base 1"
	^ stream position - limit + position - 1! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
nextInto: collection
	"Read the next elements of the receiver into collection,
	returning a copy if less elements are available"
	
	^ self
		next: collection size
		into: collection! !

!ZnBufferedReadStream methodsFor: 'private' stamp: ''!
shouldBufferReadOfCount: elementCount
	"For larger read requests, buffering fails to give an advantage."

	^ elementCount < (buffer size / 2)! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
peek
	"Return the next element but do not move over it"
	
	position > limit
		ifTrue: [ self nextBuffer ].
	^ position <= limit
		ifTrue: [ buffer at: position ]
		ifFalse: [ nil ]! !

!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
nextWord
	^ self nextIntegerOfSize: 2 signed: false bigEndian: true! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount 
	"Read requestedCount elements and return them as a collection.
	If less are available, a smaller collection will be returned."

	^ self 
		next: requestedCount 
		into: (self collectionSpecies new: requestedCount)! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
position: anInteger 
	
	| bufferEnd bufferStart |
	bufferEnd := stream position.
	bufferStart := bufferEnd - limit.
	(anInteger between: bufferStart and: bufferEnd)
		ifTrue: [ position := anInteger - bufferStart + 1 ]
		ifFalse: [ 
			"We reset the buffer and update the position in the underlying stream"
			limit := 0.
			position := 1.
			stream position: anInteger ]! !

!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
uint32
	^ self nextIntegerOfSize: 4 signed: false bigEndian: true ! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
upToEnd
	"Read elements until the stream is atEnd and return them as a collection."

	^ self collectionSpecies
		streamContents: [ :out | 
			[ self atEnd ] whileFalse: [ 
				position > limit
					ifTrue: [ self nextBuffer ].	
				out next: limit - position + 1 putAll: buffer startingAt: position.
				position := limit + 1 ] ]! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection startingAt: offset
	"Read requestedCount elements into collection starting at offset,
	returning a copy if less elements are available"
	
	| read |
	read := self 
		readInto: collection 
		startingAt: offset 
		count: requestedCount.
	^ read = requestedCount 
		ifTrue: [ collection ]
		ifFalse: [ collection copyFrom: 1 to: offset + read - 1 ]     ! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
isBinary
	^ stream isBinary! !

!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
uint16
	^ self nextIntegerOfSize: 2 signed: false bigEndian: true ! !

!ZnBufferedReadStream methodsFor: 'initialize-release' stamp: ''!
sizeBuffer: size
	buffer := self collectionSpecies new: size! !

!ZnBufferedReadStream methodsFor: 'initialize-release' stamp: ''!
close
	stream close! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
contents
	
	^ self upToEnd! !

!ZnBufferedReadStream methodsFor: 'testing' stamp: ''!
atEnd
	^ position > limit and: [ stream atEnd ]
	! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection
	"Read requestedCount elements into collection,
	returning a copy if less elements are available"
	
	^ self 
		next: requestedCount 
		into: collection 
		startingAt: 1   ! !

!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
nextInt32
	^ self nextIntegerOfSize: 4 signed: true bigEndian: true! !

!ZnBufferedReadStream methodsFor: 'private' stamp: ''!
discardBuffer
	limit := 0.
	position := 1! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
defaultBufferSize
	^ 2 raisedToInteger: 16! !

!ZnBufferedReadStream methodsFor: 'testing' stamp: ''!
isStream
	^ true! !

!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
int16
	^ self nextIntegerOfSize: 2 signed: true bigEndian: true ! !

!ZnBufferedReadStream methodsFor: 'private' stamp: ''!
readFromBufferInto: collection startingAt: offset count: requestedCount
	"Read up to requestedCount elements into collection starting at offset,
	from my buffer, answering the number of elements read.
	There could be fewer elements buffered."

	| read |
	read := 0.
	position <= limit
		ifTrue: [ read := limit - position + 1 min: requestedCount.
			collection
				replaceFrom: offset
				to: offset + read - 1
				with: buffer
				startingAt: position.
			position := position + read ].
	^ read! !

!ZnBufferedReadStream methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	position := 1.
	limit := 0! !

!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
int32
	^ self nextIntegerOfSize: 4 signed: true bigEndian: true! !

!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
uint8
	^ self nextIntegerOfSize: 1 signed: false bigEndian: true! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
next
	"Return the next element and move over it"
	
	position > limit
		ifTrue: [ self nextBuffer ].
	^ position <= limit
		ifTrue: [ 
			| char |
			char := buffer at: position.
			position := position + 1.
			char ]
		ifFalse: [ nil ]! !

!ZnBufferedReadStream methodsFor: 'testing' stamp: ''!
closed
	^ stream closed! !

!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
int8
	^ self nextIntegerOfSize: 1 signed: true bigEndian: true ! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
collectionSpecies
	^ stream isBinary
		ifTrue: [ ByteArray ]
		ifFalse: [ String ]! !

!ZnBufferedReadStream methodsFor: 'initialize-release' stamp: ''!
on: readStream
	stream := readStream.
	self sizeBuffer: self defaultBufferSize! !

!ZnBufferedReadStream methodsFor: 'private' stamp: ''!
nextBuffer
	limit := stream readInto: buffer startingAt: 1 count: buffer size.
	position := 1! !

!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
nextLittleEndianNumber: numberOfBytes
	^ self nextIntegerOfSize: numberOfBytes signed: false bigEndian: false! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
size

	^ stream size! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
skip: count
	"Skip over count elements.
	This could be further optimzed."
	
	count timesRepeat: [ self next ]! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
peekFor: object
	"Answer false and do not move over the next element if it is not equal to object, or if the receiver is at the end. 
	Answer true and move over the next element when it is equal to object."

	^ self peek = object
		ifTrue: [ 
			self next.
			true ]
		ifFalse: [ false ]! !

!ZnBufferedReadStream methodsFor: '*Fuel-Core' stamp: ''!
fuelNextWordsInto: aWordObject
	"This method is the same as nextWordsInto: but the restoreEndianness is only done if needed"
	| byteSize source pos blt |
	byteSize := aWordObject byteSize.
	source := self next: byteSize.
	pos := 0.

	"Now use BitBlt to copy the bytes to the bitmap."
	blt := (BitBlt
				toForm: (Form new hackBits: aWordObject))
				sourceForm: (Form new hackBits: source).
	blt combinationRule: Form over. "store"
	blt sourceX: 0;
		 sourceY: pos // 4;
		 height: byteSize // 4;
		 width: 4.
	blt destX: 0;
		 destY: 0.
	blt copyBits.
	
	^ aWordObject! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
upTo: value 
	"Read upto but not including value and return them as a collection.
	If value is not found, return the entire contents of the stream.
	This could be further optimzed."
	
	^ self collectionSpecies 
		streamContents: [ :writeStream | | element |
			[ self atEnd or: [ (element := self next) = value ] ] whileFalse: [ 
				writeStream nextPut: element ] ]! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
readInto: collection startingAt: offset count: requestedCount
	"Read requestedCount elements into collection starting at offset,
	answering the number of elements read, there could be fewer elements available."

	| countRead countYetToRead |
	"First, read from elements already in my buffer."
	countRead := self readFromBufferInto: collection startingAt: offset count: requestedCount.
	countYetToRead := requestedCount - countRead.
	countYetToRead > 0
		ifTrue: [ "See if there are more elements to be read from the underlying stream"
			| newOffset |
			newOffset := offset + countRead.
			(self shouldBufferReadOfCount: countYetToRead)
				ifTrue: [ self nextBuffer.
					limit > 0
						ifTrue:
							[ countRead := countRead + (self readInto: collection startingAt: newOffset count: countYetToRead) ] ]
				ifFalse:
					[ countRead := countRead + (stream readInto: collection startingAt: newOffset count: countYetToRead) ] ].
	^ countRead! !

!ZnBufferedReadStream methodsFor: 'accessing - bytes' stamp: ''!
nextNumber: numberOfBytes
	^ self nextIntegerOfSize: numberOfBytes signed: false bigEndian: true! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
wrappedStream
	^ stream! !

!ZnBufferedReadStream methodsFor: 'accessing' stamp: ''!
setToEnd
	
	self position: stream size! !

!ZnBufferedReadStream class methodsFor: 'convenience' stamp: ''!
on: readStream do: block
	"Execute block with as argument a ZnBufferedReadStream on readStream.
	Return the value of block."

	^ block value: (self on: readStream)! !

!ZnBufferedReadStream class methodsFor: 'instance creation' stamp: ''!
on: readStream
	^ self new
		on: readStream;
		yourself! !

!ZnBufferedReadStreamTest commentStamp: ''!
I am ZnBufferedReadStreamTests.!
!ZnBufferedReadStreamTest methodsFor: 'testing' stamp: ''!
testReadInto
	| stream buffer count |
	stream := ZnBufferedReadStream on: '0123456789' readStream.
	stream sizeBuffer: 8.
	buffer := String new: 6 withAll: Character space.
	stream skip: 1.
	stream readInto: buffer startingAt: 4 count: 3.
	self assert: buffer equals: '   123'.
	stream readInto: buffer startingAt: 1 count: 3.
	self assert: buffer equals: '456123'.
	count := stream readInto: buffer startingAt: 1 count: 100.
	self assert: count equals: 3.
	self assert: buffer equals: '789123'	 ! !

!ZnBufferedReadStreamTest methodsFor: 'testing' stamp: ''!
testReadUpTo
	| stream |
	stream := ZnBufferedReadStream on: '0123456789' readStream.
	stream sizeBuffer: 8.
	self assert: (stream upTo: $5) equals: '01234'.
	self assert: stream upToEnd equals: '6789'.
	self assert: stream atEnd! !

!ZnBufferedReadStreamTest methodsFor: 'testing' stamp: ''!
testReadUpToEnd
	| stream |
	stream := ZnBufferedReadStream on: '0123456789' readStream.
	stream sizeBuffer: 4.
	stream next: 2.
	self assert: stream upToEnd equals: '23456789'.
	self assert: stream atEnd! !

!ZnBufferedReadStreamTest methodsFor: 'testing' stamp: ''!
testPeek
	| stream |
	stream := ZnBufferedReadStream on: '0123456789' readStream.
	stream sizeBuffer: 8.
	'0123456789' do: [ :each |
		self deny: stream atEnd.
		self assert: stream peek equals: each.
		self assert: stream next equals: each ].
	self assert: stream atEnd.
	self assert: stream peek isNil.
	self assert: stream next isNil! !

!ZnBufferedReadStreamTest methodsFor: 'testing' stamp: ''!
testReadIntoLarger
	| stream buffer count |
	stream := ZnBufferedReadStream on: '0123456789' readStream.
	stream sizeBuffer: 4.
	buffer := String new: 10.
	count := stream readInto: buffer startingAt: 1 count: 10.
	self assert: count equals: 10.
	self assert: buffer equals: '0123456789'	 ! !

!ZnBufferedReadStreamTest methodsFor: 'testing' stamp: ''!
testBuffering
	| stream |
	stream := ZnBufferedReadStream on: '01234567890123456789' readStream.
	stream sizeBuffer: 8.
	self deny: stream atEnd.
	self assert: (stream next: 10) equals: '0123456789'.
	self deny: stream atEnd.
	self assert: (stream next: 10) equals: '0123456789'.
	self assert: stream atEnd	! !

!ZnBufferedReadStreamTest methodsFor: 'tests' stamp: ''!
testSetToEnd
	| stream source |
	source := '0123456789'.
	stream := ZnBufferedReadStream on: source readStream.
	stream sizeBuffer: source size.
	
	"Call setToEnd on new stream"
	self assert: stream position equals: 0.
	stream setToEnd.
	self assert: stream position equals: source size.

	"Call setToEnd without after reading some elements"
	stream position: 2.
	self assert: (stream next: 4) equals: '2345'.
	stream setToEnd.
	self assert: stream position equals: source size.! !

!ZnBufferedStreamByteTest commentStamp: ''!
Tests for bufferer read/write streams that are assumed to contain bytes.

Right now, integer encoding/decoding

References

https://en.wikipedia.org/wiki/Endianness
https://en.wikipedia.org/wiki/Two%27s_complement!
!ZnBufferedStreamByteTest methodsFor: 'testing' stamp: ''!
testNextIntegerOfSizeSignedBigEndianPut
	self integerEncodingSpec do: [ :spec |
		| input output |
		input := ByteArray readHexFrom: spec first.
		output := ByteArray streamContents: [ :out |
			ZnBufferedWriteStream on: out do: [ :bout | 
				bout 
					nextIntegerOfSize: input size 
					signed: spec third = #s 
					bigEndian: spec fourth = #be 
					put: spec second ] ].
		self assert: output equals: input ]! !

!ZnBufferedStreamByteTest methodsFor: 'testing' stamp: ''!
testNextIntegerOfSizeSignedBigEndian
	self integerEncodingSpec do: [ :spec |
		| input integer |
		input := ByteArray readHexFrom: spec first.
		integer := (ZnBufferedReadStream on: input readStream) 
			nextIntegerOfSize: input 
			size signed: spec third = #s 
			bigEndian: spec fourth = #be.
		self assert: integer equals: spec second ]! !

!ZnBufferedStreamByteTest methodsFor: 'testing' stamp: ''!
testInt16Aliases
	| input writer |
	writer := [ :block | 
		ByteArray streamContents: [ :out | 
			ZnBufferedWriteStream on: out do: block ] ].
	input := ByteArray readHexFrom: '04D2'.
	self assert: (ZnBufferedReadStream on: input readStream) int16 equals: 1234.
	self assert: (ZnBufferedReadStream on: input readStream) uint16 equals: 1234.
	self assert: (ZnBufferedReadStream on: input readStream) nextWord equals: 1234.
	self assert: ((ZnBufferedReadStream on: input readStream) nextNumber: 2) equals: 1234.
	self assert: ((ZnBufferedReadStream on: input reversed readStream) nextLittleEndianNumber: 2) equals: 1234.	
	self assert: (writer value: [ :out | out int16: 1234 ]) equals: input.
	self assert: (writer value: [ :out | out uint16: 1234 ]) equals: input.
	self assert: (writer value: [ :out | out nextWordPut: 1234 ]) equals: input.
	self assert: (writer value: [ :out | out nextNumber: 2 put: 1234 ]) equals: input.
	self assert: (writer value: [ :out | out nextLittleEndianNumber: 2 put: 1234 ]) equals: input reversed.
	input := ByteArray readHexFrom: 'FB2E'.
	self assert: (ZnBufferedReadStream on: input readStream) int16 equals: -1234.
	self assert: (writer value: [ :out | out int16: -1234 ]) equals: input! !

!ZnBufferedStreamByteTest methodsFor: 'testing' stamp: ''!
testInt8
	| bytes readStream |
	bytes := ByteArray
		streamContents: [ :out | 
			ZnBufferedWriteStream
				on: out
				do: [ :bout | 
					bout
						int8: 123;
						uint8: 123;
						int8: -123 ] ].
	readStream := ZnBufferedReadStream on: bytes readStream.
	self assert: readStream peek equals: 123.
	self assert: readStream int8 equals: 123.
	self assert: readStream peek equals: 123.
	self assert: readStream uint8 equals: 123.
	self deny: readStream peek equals: 123.
	self deny: readStream peek equals: -123.
	self assert: readStream int8 equals: -123! !

!ZnBufferedStreamByteTest methodsFor: 'accessing' stamp: ''!
integerEncodingSpec
	^ #(
"<hex-bytes> <integer> <u|s> <be|le> unsigned|signed big-endian|little-endian"
('00' 0 u be)
('00' 0 s be)
('01' 1 u be)
('01' 1 s be)
('FF' -1 s be)
('FF' 255 u be)
('7B' 123 u be)
('7B' 123 s be)
('85' -123 s be)
('7F' 127 u be)
('7F' 127 s be)
('80' -128 s be)
('00' 0 u le)
('00' 0 s le)
('01' 1 u le)
('01' 1 s le)
('FF' -1 s le)
('FF' 255 u le)
('7B' 123 u le)
('7B' 123 s le)
('85' -123 s le)
('7F' 127 u le)
('7F' 127 s le)
('80' -128 s le)
('00000000' 0 u be)
('00000000' 0 s be)
('00000000' 0 u le)
('00000000' 0 s le)
('00000001' 1 u be)
('00000001' 1 s be)
('01000000' 1 u le)
('01000000' 1 s le)
('FFFFFFFF' -1 s be)
('FFFFFFFF' -1 s le)
('000004D2' 1234 u be)
('000004D2' 1234 s be)
('FFFFFB2E' -1234 s be)
('D2040000' 1234 u le)
('D2040000' 1234 s le)
('2EFBFFFF' -1234 s le)
('FFFFFFFF' 4294967295 u be)
('FFFFFFFF' 4294967295 u le)
('7FFFFFFF' 2147483647 u be)
('7FFFFFFF' 2147483647 s be)
('80000000' -2147483648 s be)
('FFFFFF7F' 2147483647 s le)
('00000080' -2147483648 s le)
('499602D2' 1234567890 u be)
('499602D2' 1234567890 s be)
('B669FD2E' -1234567890 s be)
('D2029649' 1234567890 u le)
('D2029649' 1234567890 s le)
('2EFD69B6' -1234567890 s le)
)
! !

!ZnBufferedStreamByteTest methodsFor: 'testing' stamp: ''!
testInt32Aliases
	| input writer |
	writer := [ :block | 
		ByteArray streamContents: [ :out | 
			ZnBufferedWriteStream on: out do: block ] ].
	input := ByteArray readHexFrom: '499602D2'.
	self assert: (ZnBufferedReadStream on: input readStream) int32 equals: 1234567890.
	self assert: (ZnBufferedReadStream on: input readStream) uint32 equals: 1234567890.
	self assert: (ZnBufferedReadStream on: input readStream) nextInt32 equals: 1234567890.
	self assert: ((ZnBufferedReadStream on: input readStream) nextNumber: 4) equals: 1234567890.
	self assert: ((ZnBufferedReadStream on: input reversed readStream) nextLittleEndianNumber: 4) equals: 1234567890.	
	self assert: (writer value: [ :out | out int32: 1234567890 ]) equals: input.
	self assert: (writer value: [ :out | out uint32: 1234567890 ]) equals: input.
	self assert: (writer value: [ :out | out nextInt32Put: 1234567890 ]) equals: input.
	self assert: (writer value: [ :out | out nextNumber: 4 put: 1234567890 ]) equals: input.
	self assert: (writer value: [ :out | out nextLittleEndianNumber: 4 put: 1234567890 ]) equals: input reversed.
	input := ByteArray readHexFrom: 'B669FD2E'.
	self assert: (ZnBufferedReadStream on: input readStream) int32 equals: -1234567890.
	self assert: (ZnBufferedReadStream on: input readStream) nextInt32 equals: -1234567890.
	self assert: (writer value: [ :out | out int32: -1234567890 ]) equals: input.
	self assert: (writer value: [ :out | out nextInt32Put: -1234567890 ]) equals: input! !

!ZnBufferedWriteStream commentStamp: ''!
I am ZnBufferedWriteStream.
I wrap a write stream and add buffering.

Make sure to always send me #flush or #close when you're done,
otherwise the last buffer might not yet have been written.
My class side's #on:do: helps to ensure this.

I can wrap both binary or character streams and act accordingly.

Part of Zinc HTTP Components.!
!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
truncate: anInteger 
	
	self flushBuffer.
	stream truncate: anInteger! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
position

	^ stream position + position! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
cr
	self nextPut: Character cr! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
lf
	self nextPut: Character lf! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
int16: integer
	^ self nextIntegerOfSize: 2 signed: true bigEndian: true put: integer! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
position: anInteger 
	self flush.
	stream position: anInteger! !

!ZnBufferedWriteStream methodsFor: 'private' stamp: ''!
flushBuffer
	position = 0 ifTrue: [ ^ self ].
	position = self bufferSize
		ifTrue: [
			stream nextPutAll: buffer ]
		ifFalse: [
			(stream respondsTo: #next:putAll:startingAt:)
				ifTrue: [ stream next: position putAll: buffer startingAt: 1 ]
				ifFalse: [ stream nextPutAll: (buffer copyFrom: 1 to: position) ] ].
	position := 0! !

!ZnBufferedWriteStream methodsFor: 'testing' stamp: ''!
isBinary

	^ stream isBinary! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
next: count putAll: collection startingAt: offset
	"Write count elements from collection starting at offset."
	
	self flushBufferIfFull.
	count <= self bufferFreeSize
		ifTrue: [
			self buffer replaceFrom: position + 1 to: position + count with: collection startingAt: offset.
			position := position + count ]
		ifFalse: [
			self flushBuffer.
			count > (self bufferSize / 2)
				ifTrue: [ stream next: count putAll: collection startingAt: offset ]
				ifFalse: [ self next: count putAll: collection startingAt: offset ] ]
! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
int8: integer
	^ self nextIntegerOfSize: 1 signed: true bigEndian: true put: integer! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
nextNumber: numberOfBytes put: integer
	^ self nextIntegerOfSize: numberOfBytes signed: false bigEndian: true put: integer! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: object
	self flushBufferIfFull.
	position := position + 1.
	self buffer at: position put: object! !

!ZnBufferedWriteStream methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		nextPutAll: 'a '; 
		nextPutAll: self class name! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
sizeBuffer: size
	buffer := (stream isBinary ifTrue: [ ByteArray ] ifFalse: [ String ]) new: size! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
tab
	self nextPut: Character tab! !

!ZnBufferedWriteStream methodsFor: 'initialize-release' stamp: ''!
close
	self flushBuffer.
	stream close! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
uint16: integer
	^ self nextIntegerOfSize: 2 signed: false bigEndian: true put: integer! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
flush
	self flushBuffer.
	stream flush! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
bufferSize
	^ buffer isNil 
		ifTrue: [ self defaultBufferSize ]
		ifFalse: [ buffer size ]! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
next: count putAll: collection
	"Write count elements from collection"
	
	self 
		next: count 
		putAll: collection 
		startingAt: 1! !

!ZnBufferedWriteStream methodsFor: 'private' stamp: ''!
discardBuffer

	position := 0! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
bufferFreeSize
	^ self bufferSize - position! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
defaultBufferSize
	^ 2 raisedToInteger: 16! !

!ZnBufferedWriteStream methodsFor: 'testing' stamp: ''!
isStream

	^ true! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
uint8: integer
	^ self nextIntegerOfSize: 1 signed: false bigEndian: true put: integer! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
nextLittleEndianNumber: numberOfBytes put: integer
	^ self nextIntegerOfSize: numberOfBytes signed: false bigEndian: false put: integer! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
nextWordPut: integer
	^ self nextIntegerOfSize: 2 signed: false bigEndian: true put: integer! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
uint32: integer
	^ self nextIntegerOfSize: 4 signed: false bigEndian: true put: integer! !

!ZnBufferedWriteStream methodsFor: 'testing' stamp: ''!
closed
	
	^ stream closed! !

!ZnBufferedWriteStream methodsFor: 'initialize-release' stamp: ''!
on: writeStream
	stream := writeStream.
	position := 0! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
space
	self nextPut: Character space! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
nextIntegerOfSize: numberOfBytes signed: signed bigEndian: bigEndian put: value
	"Assuming the receiver is a stream of bytes, write value as the next integer of size numberOfBytes.
	If bigEndian is true, use network byte order, most significant byte first, 
	else use little endian order, least significant byte first.
	If signed is true, encode as a two-complement signed value, 
	else encode as a plain unsigned value."
	
	| unsignedValue |
	unsignedValue := (signed and: [ value negative ])
		ifTrue: [ (1 << (numberOfBytes * 8)) + value ] 
		ifFalse: [ value ].
	(unsignedValue between: 0 and: (2 ** (numberOfBytes * 8)) - 1)
		ifFalse: [ DomainError signalFrom: 0 to: (2 ** (numberOfBytes * 8)) - 1 ].
	bigEndian
		ifTrue: [ 
			numberOfBytes to: 1 by: -1 do: [ :index |
				self nextPut: (unsignedValue byteAt: index) ] ]
		ifFalse: [ 
			1 to: numberOfBytes do: [ :index |
				self nextPut: (unsignedValue byteAt: index) ] ].
	^ value! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
truncate
	
	stream truncate! !

!ZnBufferedWriteStream methodsFor: 'initialize-release' stamp: ''!
finish
	self flushBuffer! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
nextInt32Put: integer
	^ self nextIntegerOfSize: 4 signed: true bigEndian: true put: integer! !

!ZnBufferedWriteStream methodsFor: '*Fuel-Core' stamp: ''!
nextBytesPutAll: aCollection
	^ self nextPutAll: aCollection! !

!ZnBufferedWriteStream methodsFor: 'private' stamp: ''!
buffer
	buffer isNil 
		ifTrue: [ self sizeBuffer: self defaultBufferSize ].
	^ buffer! !

!ZnBufferedWriteStream methodsFor: 'private' stamp: ''!
flushBufferIfFull
	position = self bufferSize 
		ifTrue: [ self flushBuffer ]
! !

!ZnBufferedWriteStream methodsFor: 'accessing - bytes' stamp: ''!
int32: integer
	^ self nextIntegerOfSize: 4 signed: true bigEndian: true put: integer! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
crlf
	self cr; lf! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
nextPutAll: collection
	"Write a collection"
	
	self 
		next: collection size 
		putAll: collection 
		startingAt: 1! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
print: object
	object printOn: self! !

!ZnBufferedWriteStream methodsFor: 'accessing' stamp: ''!
setToEnd
	
	self flush.
	stream setToEnd! !

!ZnBufferedWriteStream class methodsFor: 'convenience' stamp: ''!
on: writeStream do: block
	"Execute block with as argument a ZnBufferedWriteStream on writeStream,
	making sure #flush is called at the end. Return the value of block."
	
	| bufferedWriteStream result |
	bufferedWriteStream := self on: writeStream.
	result := block value: bufferedWriteStream.
	bufferedWriteStream flush.
	^ result! !

!ZnBufferedWriteStream class methodsFor: 'instance creation' stamp: ''!
on: writeStream
	^ self basicNew
		on: writeStream;
		yourself! !

!ZnBufferedWriteStreamTest methodsFor: 'testing' stamp: ''!
testNextPutAllStartingAt
	| string |
	string := String streamContents: [ :stringStream | 
		ZnBufferedWriteStream on: stringStream do: [ : bufferedStream |
			bufferedStream sizeBuffer: 8.
			bufferedStream next: 5 putAll: '--012345--' startingAt: 3.
			bufferedStream next: 5 putAll: '0123456789XX' startingAt: 6. 
			bufferedStream next: 5 putAll: '--012345--' startingAt: 3.
			bufferedStream next: 5 putAll: '0123456789XX' startingAt: 6.] ].
	self assert: string equals: '01234567890123456789'! !

!ZnBufferedWriteStreamTest methodsFor: 'testing' stamp: ''!
testWritingOverflow
	| string |
	string := String
		streamContents: [ :stringStream | 
			| bufferedStream |
			bufferedStream := ZnBufferedWriteStream on: stringStream.
			bufferedStream sizeBuffer: 8.
			0 to: 9 do: [ :each | bufferedStream nextPut: (Character digitValue: each) ].
			bufferedStream
				nextPutAll: '0123';
				nextPutAll: '4567';
				nextPutAll: '89'.
			bufferedStream
				nextPutAll: '0123456789';
				nextPutAll: '0123456789'.
			bufferedStream flush ].
	self assert: string equals: '0123456789012345678901234567890123456789'! !

!ZnBufferedWriteStreamTest methodsFor: 'testing' stamp: ''!
testWriting
	| string |
	string := String
		streamContents: [ :stringStream | 
			| bufferedStream |
			bufferedStream := ZnBufferedWriteStream on: stringStream.
			0 to: 9 do: [ :each | bufferedStream nextPut: (Character digitValue: each) ].
			bufferedStream flush ].
	self assert: string equals: '0123456789'! !

!ZnByteArrayEntity commentStamp: ''!
I am ZnByteArrayEntity, a concrete HTTP Entity based on a ByteArray.
It is used to hold binary (non textual) data.
I am a ZnEntity.

Part of Zinc HTTP Components.!
!ZnByteArrayEntity methodsFor: 'testing' stamp: ''!
isEmpty 
	^ self bytes isNil or: [ self bytes isEmpty ]! !

!ZnByteArrayEntity methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	self bytes notNil ifTrue: [ 
		stream space; print: self bytes ]! !

!ZnByteArrayEntity methodsFor: 'comparing' stamp: ''!
= other
	^ super = other and: [ self bytes = other bytes ]! !

!ZnByteArrayEntity methodsFor: 'comparing' stamp: ''!
hash
	^ super hash bitXor: self bytes hash! !

!ZnByteArrayEntity methodsFor: 'writing' stamp: ''!
writeOn: stream
	ZnUtils nextPutAll: self bytes on: stream! !

!ZnByteArrayEntity methodsFor: 'accessing' stamp: ''!
bytes: anObject
	bytes := anObject! !

!ZnByteArrayEntity methodsFor: 'accessing' stamp: ''!
contents
	^ self bytes! !

!ZnByteArrayEntity methodsFor: 'accessing' stamp: ''!
bytes
	^ bytes! !

!ZnByteArrayEntity methodsFor: 'initialize-release' stamp: ''!
readFrom: stream
	self contentLength isNil
		ifTrue: [ 
			self bytes: (ZnUtils readUpToEnd: stream limit: ZnMaximumEntitySize value).
			self contentLength: self bytes size ]
		ifFalse: [ | byteArray |
			self contentLength > ZnMaximumEntitySize value
				ifTrue: [ ZnEntityTooLarge signal ].
			byteArray := ByteArray ofSize: self contentLength.
			self contentLength > ZnUtils streamingBufferSize 
				ifTrue: [
					ZnUtils streamFrom: stream to: byteArray writeStream size: self contentLength ]
				ifFalse: [
					stream next: self contentLength into: byteArray ]. 
			self bytes: byteArray ]! !

!ZnByteArrayEntity methodsFor: 'accessing' stamp: ''!
readStream
	^ self bytes readStream! !

!ZnByteArrayEntity class methodsFor: 'testing' stamp: ''!
designatedMimeType
	"I have no designated mime type, I can handle all binary content.
	See #concreteSubclassForType: "
	
	^ nil! !

!ZnByteArrayEntity class methodsFor: 'instance creation' stamp: ''!
bytes: byteArray
	^ (self type: ZnMimeType applicationOctetStream length: byteArray size)
		bytes: byteArray;
		yourself ! !

!ZnByteArrayEntity class methodsFor: 'testing' stamp: ''!
matches: mimeType
	"I have no designated mime type, I can handle all binary content.
	See #concreteSubclassForType: "
	
	^ false! !

!ZnByteEncoder commentStamp: ''!
I am ZnByteEncoder, a concrete subclass of ZnCharacterEncoder.
I handle single byte encodings where byte values 0 to 127 map to ASCII and 128 to 255 are a permutation to Unicode characters.

I derive my mappings by parsing official unicode.org specifications.

The list of encodings and their names/aliases was taken from http://encoding.spec.whatwg.org/#legacy-single-byte-encodings

I basically support ISO/IEC 8859 1, 2, 3, 4, 5, 6, 7, 8, 10, 13, 14, 15 and 16, Windows Codepages 866, 874, 1250, 1251, 1252, 1253, 1253, 1254, 1255, 1256, 1257, 1258, KOI8 R & U as well as Mac Roman & Cyrillic - each of these with a number of aliases like latin1, latin2, latin3, latin4, latin5, latin6, cyrillic, arabic, greek and hebrew. See #mappingToIdentifiers

Note that most/all of these encodings should be considered legacy, with UTF-8 being the preferred encoding going forward.  

Part of Zinc HTTP Components.!
!ZnByteEncoder methodsFor: 'convenience' stamp: ''!
decodeBytesIntoWideString: bytes
	"Variant of #decodeBytes: that is faster when you know upfront 
	that a WideString is probably needed"

	| byteStream |
	byteStream := bytes readStream.
	^ WideString streamContents: [ :stream |
		[ byteStream atEnd ] whileFalse: [
			stream nextPut: (self nextFromStream: byteStream) ] ] ! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
macRomanMapping
	"self 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 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
koi8rMapping
	"self 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 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp1250Mapping
	"self 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 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp1257Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1257.TXT'"

	^ #(
	16r20AC nil 16r201A nil 16r201E 16r2026 16r2020 16r2021 
	nil 16r2030 nil 16r2039 nil 16r00A8 16r02C7 16r00B8 
	nil 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 
	nil 16r2122 nil 16r203A nil 16r00AF 16r02DB nil 
	16r00A0 nil 16r00A2 16r00A3 16r00A4 nil 16r00A6 16r00A7 
	16r00D8 16r00A9 16r0156 16r00AB 16r00AC 16r00AD 16r00AE 16r00C6 
	16r00B0 16r00B1 16r00B2 16r00B3 16r00B4 16r00B5 16r00B6 16r00B7 
	16r00F8 16r00B9 16r0157 16r00BB 16r00BC 16r00BD 16r00BE 16r00E6 
	16r0104 16r012E 16r0100 16r0106 16r00C4 16r00C5 16r0118 16r0112 
	16r010C 16r00C9 16r0179 16r0116 16r0122 16r0136 16r012A 16r013B 
	16r0160 16r0143 16r0145 16r00D3 16r014C 16r00D5 16r00D6 16r00D7 
	16r0172 16r0141 16r015A 16r016A 16r00DC 16r017B 16r017D 16r00DF 
	16r0105 16r012F 16r0101 16r0107 16r00E4 16r00E5 16r0119 16r0113 
	16r010D 16r00E9 16r017A 16r0117 16r0123 16r0137 16r012B 16r013C 
	16r0161 16r0144 16r0146 16r00F3 16r014D 16r00F5 16r00F6 16r00F7 
	16r0173 16r0142 16r015B 16r016B 16r00FC 16r017C 16r017E 16r02D9 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
macCyrillicMapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/APPLE/CYRILLIC.TXT'"

	^ #(
	16r0410 16r0411 16r0412 16r0413 16r0414 16r0415 16r0416 16r0417 
	16r0418 16r0419 16r041A 16r041B 16r041C 16r041D 16r041E 16r041F 
	16r0420 16r0421 16r0422 16r0423 16r0424 16r0425 16r0426 16r0427 
	16r0428 16r0429 16r042A 16r042B 16r042C 16r042D 16r042E 16r042F 
	16r2020 16r00B0 16r0490 16r00A3 16r00A7 16r2022 16r00B6 16r0406 
	16r00AE 16r00A9 16r2122 16r0402 16r0452 16r2260 16r0403 16r0453 
	16r221E 16r00B1 16r2264 16r2265 16r0456 16r00B5 16r0491 16r0408 
	16r0404 16r0454 16r0407 16r0457 16r0409 16r0459 16r040A 16r045A 
	16r0458 16r0405 16r00AC 16r221A 16r0192 16r2248 16r2206 16r00AB 
	16r00BB 16r2026 16r00A0 16r040B 16r045B 16r040C 16r045C 16r0455 
	16r2013 16r2014 16r201C 16r201D 16r2018 16r2019 16r00F7 16r201E 
	16r040E 16r045E 16r040F 16r045F 16r2116 16r0401 16r0451 16r044F 
	16r0430 16r0431 16r0432 16r0433 16r0434 16r0435 16r0436 16r0437 
	16r0438 16r0439 16r043A 16r043B 16r043C 16r043D 16r043E 16r043F 
	16r0440 16r0441 16r0442 16r0443 16r0444 16r0445 16r0446 16r0447 
	16r0448 16r0449 16r044A 16r044B 16r044C 16r044D 16r044E 16r20AC )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso88595Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-5.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 16r0401 16r0402 16r0403 16r0404 16r0405 16r0406 16r0407 
	16r0408 16r0409 16r040A 16r040B 16r040C 16r00AD 16r040E 16r040F 
	16r0410 16r0411 16r0412 16r0413 16r0414 16r0415 16r0416 16r0417 
	16r0418 16r0419 16r041A 16r041B 16r041C 16r041D 16r041E 16r041F 
	16r0420 16r0421 16r0422 16r0423 16r0424 16r0425 16r0426 16r0427 
	16r0428 16r0429 16r042A 16r042B 16r042C 16r042D 16r042E 16r042F 
	16r0430 16r0431 16r0432 16r0433 16r0434 16r0435 16r0436 16r0437 
	16r0438 16r0439 16r043A 16r043B 16r043C 16r043D 16r043E 16r043F 
	16r0440 16r0441 16r0442 16r0443 16r0444 16r0445 16r0446 16r0447 
	16r0448 16r0449 16r044A 16r044B 16r044C 16r044D 16r044E 16r044F 
	16r2116 16r0451 16r0452 16r0453 16r0454 16r0455 16r0456 16r0457 
	16r0458 16r0459 16r045A 16r045B 16r045C 16r00A7 16r045E 16r045F )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso88598Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-8.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 nil 16r00A2 16r00A3 16r00A4 16r00A5 16r00A6 16r00A7 
	16r00A8 16r00A9 16r00D7 16r00AB 16r00AC 16r00AD 16r00AE 16r00AF 
	16r00B0 16r00B1 16r00B2 16r00B3 16r00B4 16r00B5 16r00B6 16r00B7 
	16r00B8 16r00B9 16r00F7 16r00BB 16r00BC 16r00BD 16r00BE 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 16r2017 
	16r05D0 16r05D1 16r05D2 16r05D3 16r05D4 16r05D5 16r05D6 16r05D7 
	16r05D8 16r05D9 16r05DA 16r05DB 16r05DC 16r05DD 16r05DE 16r05DF 
	16r05E0 16r05E1 16r05E2 16r05E3 16r05E4 16r05E5 16r05E6 16r05E7 
	16r05E8 16r05E9 16r05EA nil nil 16r200E 16r200F nil )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp1256Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1256.TXT'"

	^ #(
	16r20AC 16r067E 16r201A 16r0192 16r201E 16r2026 16r2020 16r2021 
	16r02C6 16r2030 16r0679 16r2039 16r0152 16r0686 16r0698 16r0688 
	16r06AF 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 
	16r06A9 16r2122 16r0691 16r203A 16r0153 16r200C 16r200D 16r06BA 
	16r00A0 16r060C 16r00A2 16r00A3 16r00A4 16r00A5 16r00A6 16r00A7 
	16r00A8 16r00A9 16r06BE 16r00AB 16r00AC 16r00AD 16r00AE 16r00AF 
	16r00B0 16r00B1 16r00B2 16r00B3 16r00B4 16r00B5 16r00B6 16r00B7 
	16r00B8 16r00B9 16r061B 16r00BB 16r00BC 16r00BD 16r00BE 16r061F 
	16r06C1 16r0621 16r0622 16r0623 16r0624 16r0625 16r0626 16r0627 
	16r0628 16r0629 16r062A 16r062B 16r062C 16r062D 16r062E 16r062F 
	16r0630 16r0631 16r0632 16r0633 16r0634 16r0635 16r0636 16r00D7 
	16r0637 16r0638 16r0639 16r063A 16r0640 16r0641 16r0642 16r0643 
	16r00E0 16r0644 16r00E2 16r0645 16r0646 16r0647 16r0648 16r00E7 
	16r00E8 16r00E9 16r00EA 16r00EB 16r0649 16r064A 16r00EE 16r00EF 
	16r064B 16r064C 16r064D 16r064E 16r00F4 16r064F 16r0650 16r00F7 
	16r0651 16r00F9 16r0652 16r00FB 16r00FC 16r200E 16r200F 16r06D2 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso885916Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-16.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 16r0105 16r0141 16r20AC 16r201E 16r0160 16r00A7 
	16r0161 16r00A9 16r0218 16r00AB 16r0179 16r00AD 16r017A 16r017B 
	16r00B0 16r00B1 16r010C 16r0142 16r017D 16r201D 16r00B6 16r00B7 
	16r017E 16r010D 16r0219 16r00BB 16r0152 16r0153 16r0178 16r017C 
	16r00C0 16r00C1 16r00C2 16r0102 16r00C4 16r0106 16r00C6 16r00C7 
	16r00C8 16r00C9 16r00CA 16r00CB 16r00CC 16r00CD 16r00CE 16r00CF 
	16r0110 16r0143 16r00D2 16r00D3 16r00D4 16r0150 16r00D6 16r015A 
	16r0170 16r00D9 16r00DA 16r00DB 16r00DC 16r0118 16r021A 16r00DF 
	16r00E0 16r00E1 16r00E2 16r0103 16r00E4 16r0107 16r00E6 16r00E7 
	16r00E8 16r00E9 16r00EA 16r00EB 16r00EC 16r00ED 16r00EE 16r00EF 
	16r0111 16r0144 16r00F2 16r00F3 16r00F4 16r0151 16r00F6 16r015B 
	16r0171 16r00F9 16r00FA 16r00FB 16r00FC 16r0119 16r021B 16r00FF )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso88592Mapping
	"self 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 )! !

!ZnByteEncoder class methodsFor: 'instance creation' stamp: ''!
newFromUrl: url
	"Instanciate a new encoder directly from a Unicode.org url"
	"self newFromUrl: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-2.TXT'"
	"self newFromUrl: 'http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/PC/CP437.TXT'"

	| mapping spec tables |
	mapping := self parseUnicodeOrgSpec: url.
	spec := self top128FromUnicodeSpec: mapping.
	tables := self tablesFromSpec: spec.
	^ self new
		identifier: url;
		byteToUnicode: tables first;
		unicodeToByte: tables second;
		yourself! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso88593Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-3.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 16r0126 16r02D8 16r00A3 16r00A4 nil 16r0124 16r00A7 
	16r00A8 16r0130 16r015E 16r011E 16r0134 16r00AD nil 16r017B 
	16r00B0 16r0127 16r00B2 16r00B3 16r00B4 16r00B5 16r0125 16r00B7 
	16r00B8 16r0131 16r015F 16r011F 16r0135 16r00BD nil 16r017C 
	16r00C0 16r00C1 16r00C2 nil 16r00C4 16r010A 16r0108 16r00C7 
	16r00C8 16r00C9 16r00CA 16r00CB 16r00CC 16r00CD 16r00CE 16r00CF 
	nil 16r00D1 16r00D2 16r00D3 16r00D4 16r0120 16r00D6 16r00D7 
	16r011C 16r00D9 16r00DA 16r00DB 16r00DC 16r016C 16r015C 16r00DF 
	16r00E0 16r00E1 16r00E2 nil 16r00E4 16r010B 16r0109 16r00E7 
	16r00E8 16r00E9 16r00EA 16r00EB 16r00EC 16r00ED 16r00EE 16r00EF 
	nil 16r00F1 16r00F2 16r00F3 16r00F4 16r0121 16r00F6 16r00F7 
	16r011D 16r00F9 16r00FA 16r00FB 16r00FC 16r016D 16r015D 16r02D9 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso885910Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-10.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 16r0112 16r0122 16r012A 16r0128 16r0136 16r00A7 
	16r013B 16r0110 16r0160 16r0166 16r017D 16r00AD 16r016A 16r014A 
	16r00B0 16r0105 16r0113 16r0123 16r012B 16r0129 16r0137 16r00B7 
	16r013C 16r0111 16r0161 16r0167 16r017E 16r2015 16r016B 16r014B 
	16r0100 16r00C1 16r00C2 16r00C3 16r00C4 16r00C5 16r00C6 16r012E 
	16r010C 16r00C9 16r0118 16r00CB 16r0116 16r00CD 16r00CE 16r00CF 
	16r00D0 16r0145 16r014C 16r00D3 16r00D4 16r00D5 16r00D6 16r0168 
	16r00D8 16r0172 16r00DA 16r00DB 16r00DC 16r00DD 16r00DE 16r00DF 
	16r0101 16r00E1 16r00E2 16r00E3 16r00E4 16r00E5 16r00E6 16r012F 
	16r010D 16r00E9 16r0119 16r00EB 16r0117 16r00ED 16r00EE 16r00EF 
	16r00F0 16r0146 16r014D 16r00F3 16r00F4 16r00F5 16r00F6 16r0169 
	16r00F8 16r0173 16r00FA 16r00FB 16r00FC 16r00FD 16r00FE 16r0138 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso88594Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-4.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 16r0138 16r0156 16r00A4 16r0128 16r013B 16r00A7 
	16r00A8 16r0160 16r0112 16r0122 16r0166 16r00AD 16r017D 16r00AF 
	16r00B0 16r0105 16r02DB 16r0157 16r00B4 16r0129 16r013C 16r02C7 
	16r00B8 16r0161 16r0113 16r0123 16r0167 16r014A 16r017E 16r014B 
	16r0100 16r00C1 16r00C2 16r00C3 16r00C4 16r00C5 16r00C6 16r012E 
	16r010C 16r00C9 16r0118 16r00CB 16r0116 16r00CD 16r00CE 16r012A 
	16r0110 16r0145 16r014C 16r0136 16r00D4 16r00D5 16r00D6 16r00D7 
	16r00D8 16r0172 16r00DA 16r00DB 16r00DC 16r0168 16r016A 16r00DF 
	16r0101 16r00E1 16r00E2 16r00E3 16r00E4 16r00E5 16r00E6 16r012F 
	16r010D 16r00E9 16r0119 16r00EB 16r0117 16r00ED 16r00EE 16r012B 
	16r0111 16r0146 16r014D 16r0137 16r00F4 16r00F5 16r00F6 16r00F7 
	16r00F8 16r0173 16r00FA 16r00FB 16r00FC 16r0169 16r016B 16r02D9 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp850Mapping
	"This is not included in the MS mappings on the Unicode site, 
	but still in modern use as the default codepage in 
	the Windows Command Shell for multilingual locales"
	"Technically, due to structure of ByteEncoder, it is incomplete, 
	as the lower range corresponds not to ASCII, but to cp437, 
	where character 0 - 31 and 127 have different meanings."
	"See also http://en.wikipedia.org/wiki/Code_page_850"
	
	^ #(
	16r00C7 16r00FC 16r00E9 16r00E2 16r00E4 16r00E0 16r00E5 16r00E7 
	16r00EA 16r00EB 16r00E8 16r00EF 16r00EE 16r00EC 16r00C4 16r00C5 
	16r00C9 16r00E6 16r00C6 16r00F4 16r00F6 16r00F2 16r00FB 16r00F9 
	16r00FF 16r00D6 16r00DC 16r00F8 16r00A3 16r00D8 16r00D7 16r0192 
	16r00E1 16r00ED 16r00F3 16r00FA 16r00F1 16r00D1 16r00AA 16r00BA 
	16r00BF 16r00AE 16r00AC 16r00BD 16r00BC 16r00A1 16r00AB 16r00BB 
	16r2591 16r2592 16r2593 16r2502 16r2524 16r00C1 16r00C2 16r00C0 
	16r00A9 16r2563 16r2551 16r2557 16r255D 16r00A2 16r00A5 16r2510 
	16r2514 16r2534 16r252C 16r251C 16r2500 16r253C 16r00E3 16r00C3 
	16r255A 16r2554 16r2569 16r2566 16r2560 16r2550 16r256C 16r00A4 
	16r00F0 16r00D0 16r00CA 16r00CB 16r00C8 16r0131 16r00CD 16r00CE 
	16r00CF 16r2518 16r250C 16r2588 16r2584 16r00A6 16r00CC 16r2580 
	16r00D3 16r00DF 16r00D4 16r00D2 16r00F5 16r00D5 16r00B5 16r00FE 
	16r00DE 16r00DA 16r00DB 16r00D9 16r00FD 16r00DD 16r00AF 16r00B4 
	16r00AD 16r00B1 16r2017 16r00BE 16r00B6 16r00A7 16r00F7 16r00B8 
	16r00B0 16r00A8 16r00B7 16r00B9 16r00B3 16r00B2 16r25A0 16r00A0 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso885915Mapping
	"self 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 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp874Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP874.TXT'"

	^ #(
	16r20AC nil nil nil nil 16r2026 nil nil 
	nil nil nil nil nil nil nil nil 
	nil 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 
	nil nil nil nil nil nil nil nil 
	16r00A0 16r0E01 16r0E02 16r0E03 16r0E04 16r0E05 16r0E06 16r0E07 
	16r0E08 16r0E09 16r0E0A 16r0E0B 16r0E0C 16r0E0D 16r0E0E 16r0E0F 
	16r0E10 16r0E11 16r0E12 16r0E13 16r0E14 16r0E15 16r0E16 16r0E17 
	16r0E18 16r0E19 16r0E1A 16r0E1B 16r0E1C 16r0E1D 16r0E1E 16r0E1F 
	16r0E20 16r0E21 16r0E22 16r0E23 16r0E24 16r0E25 16r0E26 16r0E27 
	16r0E28 16r0E29 16r0E2A 16r0E2B 16r0E2C 16r0E2D 16r0E2E 16r0E2F 
	16r0E30 16r0E31 16r0E32 16r0E33 16r0E34 16r0E35 16r0E36 16r0E37 
	16r0E38 16r0E39 16r0E3A nil nil nil nil 16r0E3F 
	16r0E40 16r0E41 16r0E42 16r0E43 16r0E44 16r0E45 16r0E46 16r0E47 
	16r0E48 16r0E49 16r0E4A 16r0E4B 16r0E4C 16r0E4D 16r0E4E 16r0E4F 
	16r0E50 16r0E51 16r0E52 16r0E53 16r0E54 16r0E55 16r0E56 16r0E57 
	16r0E58 16r0E59 16r0E5A 16r0E5B nil nil nil nil )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp1255Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1255.TXT'"

	^ #(
	16r20AC nil 16r201A 16r0192 16r201E 16r2026 16r2020 16r2021 
	16r02C6 16r2030 nil 16r2039 nil nil nil nil 
	nil 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 
	16r02DC 16r2122 nil 16r203A nil nil nil nil 
	16r00A0 16r00A1 16r00A2 16r00A3 16r20AA 16r00A5 16r00A6 16r00A7 
	16r00A8 16r00A9 16r00D7 16r00AB 16r00AC 16r00AD 16r00AE 16r00AF 
	16r00B0 16r00B1 16r00B2 16r00B3 16r00B4 16r00B5 16r00B6 16r00B7 
	16r00B8 16r00B9 16r00F7 16r00BB 16r00BC 16r00BD 16r00BE 16r00BF 
	16r05B0 16r05B1 16r05B2 16r05B3 16r05B4 16r05B5 16r05B6 16r05B7 
	16r05B8 16r05B9 nil 16r05BB 16r05BC 16r05BD 16r05BE 16r05BF 
	16r05C0 16r05C1 16r05C2 16r05C3 16r05F0 16r05F1 16r05F2 16r05F3 
	16r05F4 nil nil nil nil nil nil nil 
	16r05D0 16r05D1 16r05D2 16r05D3 16r05D4 16r05D5 16r05D6 16r05D7 
	16r05D8 16r05D9 16r05DA 16r05DB 16r05DC 16r05DD 16r05DE 16r05DF 
	16r05E0 16r05E1 16r05E2 16r05E3 16r05E4 16r05E5 16r05E6 16r05E7 
	16r05E8 16r05E9 16r05EA nil nil 16r200E 16r200F nil )! !

!ZnByteEncoder class methodsFor: 'utilties' stamp: ''!
parseUnicodeOrgSpec: url
	"Parse and return a mapping from byte to unicode values from url."
	"Basic syntax: lines starting with # are comments, else first two fields are read as 0x hex values"
	"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 size < 3 or: [ tokens last = '<control>' or: [ tokens last = '#UNDEFINED' ] ]) ifFalse: [
					mapping
						at: (hexReader value: tokens first)
						put: (hexReader value: tokens second) ] ] ].
	^ mapping ! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp866Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/PC/CP866.TXT'"

	^ #(
	16r0410 16r0411 16r0412 16r0413 16r0414 16r0415 16r0416 16r0417 
	16r0418 16r0419 16r041A 16r041B 16r041C 16r041D 16r041E 16r041F 
	16r0420 16r0421 16r0422 16r0423 16r0424 16r0425 16r0426 16r0427 
	16r0428 16r0429 16r042A 16r042B 16r042C 16r042D 16r042E 16r042F 
	16r0430 16r0431 16r0432 16r0433 16r0434 16r0435 16r0436 16r0437 
	16r0438 16r0439 16r043A 16r043B 16r043C 16r043D 16r043E 16r043F 
	16r2591 16r2592 16r2593 16r2502 16r2524 16r2561 16r2562 16r2556 
	16r2555 16r2563 16r2551 16r2557 16r255D 16r255C 16r255B 16r2510 
	16r2514 16r2534 16r252C 16r251C 16r2500 16r253C 16r255E 16r255F 
	16r255A 16r2554 16r2569 16r2566 16r2560 16r2550 16r256C 16r2567 
	16r2568 16r2564 16r2565 16r2559 16r2558 16r2552 16r2553 16r256B 
	16r256A 16r2518 16r250C 16r2588 16r2584 16r258C 16r2590 16r2580 
	16r0440 16r0441 16r0442 16r0443 16r0444 16r0445 16r0446 16r0447 
	16r0448 16r0449 16r044A 16r044B 16r044C 16r044D 16r044E 16r044F 
	16r0401 16r0451 16r0404 16r0454 16r0407 16r0457 16r040E 16r045E 
	16r00B0 16r2219 16r00B7 16r221A 16r2116 16r00A4 16r25A0 16r00A0 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp1251Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1251.TXT'"

	^ #(
	16r0402 16r0403 16r201A 16r0453 16r201E 16r2026 16r2020 16r2021 
	16r20AC 16r2030 16r0409 16r2039 16r040A 16r040C 16r040B 16r040F 
	16r0452 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 
	nil 16r2122 16r0459 16r203A 16r045A 16r045C 16r045B 16r045F 
	16r00A0 16r040E 16r045E 16r0408 16r00A4 16r0490 16r00A6 16r00A7 
	16r0401 16r00A9 16r0404 16r00AB 16r00AC 16r00AD 16r00AE 16r0407 
	16r00B0 16r00B1 16r0406 16r0456 16r0491 16r00B5 16r00B6 16r00B7 
	16r0451 16r2116 16r0454 16r00BB 16r0458 16r0405 16r0455 16r0457 
	16r0410 16r0411 16r0412 16r0413 16r0414 16r0415 16r0416 16r0417 
	16r0418 16r0419 16r041A 16r041B 16r041C 16r041D 16r041E 16r041F 
	16r0420 16r0421 16r0422 16r0423 16r0424 16r0425 16r0426 16r0427 
	16r0428 16r0429 16r042A 16r042B 16r042C 16r042D 16r042E 16r042F 
	16r0430 16r0431 16r0432 16r0433 16r0434 16r0435 16r0436 16r0437 
	16r0438 16r0439 16r043A 16r043B 16r043C 16r043D 16r043E 16r043F 
	16r0440 16r0441 16r0442 16r0443 16r0444 16r0445 16r0446 16r0447 
	16r0448 16r0449 16r044A 16r044B 16r044C 16r044D 16r044E 16r044F )! !

!ZnByteEncoder class methodsFor: 'utilties' stamp: ''!
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 generateByteToUnicodeSpec: '; print: url; << '"'; cr; cr; tab; << '^ #('.
		(self top128FromUnicodeSpec: mapping) doWithIndex: [ :each :index |
			index - 1 \\ 8 = 0 ifTrue: [ stream cr; tab ].
			each isNil
				ifTrue: [ stream print: nil; space ]  
				ifFalse: [ stream << '16r' << (each printPaddedWith: $0 to: 4 base: 16); space ] ].
		stream nextPut: $); cr ]! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso88596Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-6.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 nil nil nil 16r00A4 nil nil nil 
	nil nil nil nil 16r060C 16r00AD nil nil 
	nil nil nil nil nil nil nil nil 
	nil nil nil 16r061B nil nil nil 16r061F 
	nil 16r0621 16r0622 16r0623 16r0624 16r0625 16r0626 16r0627 
	16r0628 16r0629 16r062A 16r062B 16r062C 16r062D 16r062E 16r062F 
	16r0630 16r0631 16r0632 16r0633 16r0634 16r0635 16r0636 16r0637 
	16r0638 16r0639 16r063A nil nil nil nil nil 
	16r0640 16r0641 16r0642 16r0643 16r0644 16r0645 16r0646 16r0647 
	16r0648 16r0649 16r064A 16r064B 16r064C 16r064D 16r064E 16r064F 
	16r0650 16r0651 16r0652 nil nil nil nil nil 
	nil nil nil nil nil nil nil nil )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp1253Mapping
	"self 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 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso88597Mapping
	"self 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 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp1258Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1258.TXT'"

	^ #(
	16r20AC nil 16r201A 16r0192 16r201E 16r2026 16r2020 16r2021 
	16r02C6 16r2030 nil 16r2039 16r0152 nil nil nil 
	nil 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 
	16r02DC 16r2122 nil 16r203A 16r0153 nil nil 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 16r0102 16r00C4 16r00C5 16r00C6 16r00C7 
	16r00C8 16r00C9 16r00CA 16r00CB 16r0300 16r00CD 16r00CE 16r00CF 
	16r0110 16r00D1 16r0309 16r00D3 16r00D4 16r01A0 16r00D6 16r00D7 
	16r00D8 16r00D9 16r00DA 16r00DB 16r00DC 16r01AF 16r0303 16r00DF 
	16r00E0 16r00E1 16r00E2 16r0103 16r00E4 16r00E5 16r00E6 16r00E7 
	16r00E8 16r00E9 16r00EA 16r00EB 16r0301 16r00ED 16r00EE 16r00EF 
	16r0111 16r00F1 16r0323 16r00F3 16r00F4 16r01A1 16r00F6 16r00F7 
	16r00F8 16r00F9 16r00FA 16r00FB 16r00FC 16r01B0 16r20AB 16r00FF )! !

!ZnByteEncoder class methodsFor: 'utilties' stamp: ''!
top128FromUnicodeSpec: mapping
	"Return an array mapping the top 128 byte to unicode values from a Unicode.org specification map"

	^ Array new: 128 streamContents: [ :stream |
		128 to: 255 do: [ :each |
			stream nextPut: (mapping at: each ifAbsent: [ nil ]) ] ]! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp1252Mapping
	"self 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 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso885914Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-14.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 16r1E02 16r1E03 16r00A3 16r010A 16r010B 16r1E0A 16r00A7 
	16r1E80 16r00A9 16r1E82 16r1E0B 16r1EF2 16r00AD 16r00AE 16r0178 
	16r1E1E 16r1E1F 16r0120 16r0121 16r1E40 16r1E41 16r00B6 16r1E56 
	16r1E81 16r1E57 16r1E83 16r1E60 16r1EF3 16r1E84 16r1E85 16r1E61 
	16r00C0 16r00C1 16r00C2 16r00C3 16r00C4 16r00C5 16r00C6 16r00C7 
	16r00C8 16r00C9 16r00CA 16r00CB 16r00CC 16r00CD 16r00CE 16r00CF 
	16r0174 16r00D1 16r00D2 16r00D3 16r00D4 16r00D5 16r00D6 16r1E6A 
	16r00D8 16r00D9 16r00DA 16r00DB 16r00DC 16r00DD 16r0176 16r00DF 
	16r00E0 16r00E1 16r00E2 16r00E3 16r00E4 16r00E5 16r00E6 16r00E7 
	16r00E8 16r00E9 16r00EA 16r00EB 16r00EC 16r00ED 16r00EE 16r00EF 
	16r0175 16r00F1 16r00F2 16r00F3 16r00F4 16r00F5 16r00F6 16r1E6B 
	16r00F8 16r00F9 16r00FA 16r00FB 16r00FC 16r00FD 16r0177 16r00FF )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
iso885913Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-13.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 16r201D 16r00A2 16r00A3 16r00A4 16r201E 16r00A6 16r00A7 
	16r00D8 16r00A9 16r0156 16r00AB 16r00AC 16r00AD 16r00AE 16r00C6 
	16r00B0 16r00B1 16r00B2 16r00B3 16r201C 16r00B5 16r00B6 16r00B7 
	16r00F8 16r00B9 16r0157 16r00BB 16r00BC 16r00BD 16r00BE 16r00E6 
	16r0104 16r012E 16r0100 16r0106 16r00C4 16r00C5 16r0118 16r0112 
	16r010C 16r00C9 16r0179 16r0116 16r0122 16r0136 16r012A 16r013B 
	16r0160 16r0143 16r0145 16r00D3 16r014C 16r00D5 16r00D6 16r00D7 
	16r0172 16r0141 16r015A 16r016A 16r00DC 16r017B 16r017D 16r00DF 
	16r0105 16r012F 16r0101 16r0107 16r00E4 16r00E5 16r0119 16r0113 
	16r010D 16r00E9 16r017A 16r0117 16r0123 16r0137 16r012B 16r013C 
	16r0161 16r0144 16r0146 16r00F3 16r014D 16r00F5 16r00F6 16r00F7 
	16r0173 16r0142 16r015B 16r016B 16r00FC 16r017C 16r017E 16r2019 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
cp1254Mapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1254.TXT'"

	^ #(
	16r20AC nil 16r201A 16r0192 16r201E 16r2026 16r2020 16r2021 
	16r02C6 16r2030 16r0160 16r2039 16r0152 nil nil nil 
	nil 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 
	16r02DC 16r2122 16r0161 16r203A 16r0153 nil nil 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 
	16r011E 16r00D1 16r00D2 16r00D3 16r00D4 16r00D5 16r00D6 16r00D7 
	16r00D8 16r00D9 16r00DA 16r00DB 16r00DC 16r0130 16r015E 16r00DF 
	16r00E0 16r00E1 16r00E2 16r00E3 16r00E4 16r00E5 16r00E6 16r00E7 
	16r00E8 16r00E9 16r00EA 16r00EB 16r00EC 16r00ED 16r00EE 16r00EF 
	16r011F 16r00F1 16r00F2 16r00F3 16r00F4 16r00F5 16r00F6 16r00F7 
	16r00F8 16r00F9 16r00FA 16r00FB 16r00FC 16r0131 16r015F 16r00FF )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
koi8uMapping
	"self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MISC/KOI8-U.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 16r0454 16r2554 16r0456 16r0457 
	16r2557 16r2558 16r2559 16r255A 16r255B 16r0491 16r255D 16r255E 
	16r255F 16r2560 16r2561 16r0401 16r0404 16r2563 16r0406 16r0407 
	16r2566 16r2567 16r2568 16r2569 16r256A 16r0490 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 )! !

!ZnByteEncoder class methodsFor: 'mappings' stamp: ''!
mappingToIdentifiers
	"Return a dictionay mapping from encoding specifications to a list of encoding names."
	
	^ Dictionary newFromPairs: #(
		"#asciiMapping #('ascii')"
		"#iso88591Mapping #('iso88591' 'latin1')"
		#iso88592Mapping #('iso88592' 'latin2') 
		#iso88593Mapping #('iso88593' 'latin3') 
		#iso88594Mapping #('iso88594' 'latin4') 
		#iso88595Mapping #('iso88595' 'cyrillic') 
		#iso88596Mapping #('iso88596' 'arabic') 
		#iso88597Mapping #('iso88597' 'greek') 
		#iso88598Mapping #('iso88598' 'hebrew') 
		#iso885910Mapping #('iso885910' 'latin6') 
		#iso885913Mapping #('iso885913') 
		#iso885914Mapping #('iso885914') 
		#iso885915Mapping #('iso885915') 
		#iso885916Mapping #('iso885916') 
		#cp1250Mapping #('cp1250' 'windows1250' 'xcp1250') 
		#cp1251Mapping #('cp1251' 'windows1251' 'xcp1251') 
		#cp1252Mapping #('cp1252' 'windows1252' 'xcp1252' 'ibm819')
		#cp1253Mapping #('cp1253' 'windows1253' 'xcp1253')
		#cp1254Mapping #('cp1254' 'windows1254' 'xcp1254' 'iso88599' 'latin5')
		#cp1255Mapping #('cp1255' 'windows1255' 'xcp1255')
		#cp1256Mapping #('cp1256' 'windows1256' 'xcp1256')
		#cp1257Mapping #('cp1257' 'windows1257' 'xcp1257')
		#cp1258Mapping #('cp1258' 'windows1258' 'xcp1258')
		#cp850Mapping #('cp850' 'ibm850' 'oem850' 'doslatin1')
		#cp866Mapping #('cp866' 'ibm866')
		#cp874Mapping #('cp874' 'iso885911' 'windows874' 'dos874')
		#koi8rMapping #('koi8r' 'koi8')
		#koi8uMapping #('koi8u')
		#macRomanMapping #('macroman' 'xmacroman' 'mac' 'macintosh')
		#macCyrillicMapping #('maccyrillic' 'xmaccyrillic') )! !

!ZnByteStringBecameWideString commentStamp: ''!
I am ZnByteStringBecameWideString, a resumable Error signalled to indicate that some byteString was changed to a wideString.

Used by ZnUTF8Encoder>>#readInto:startingAt:count:fromStream: to avoid a #becomeForward: when a ByteString automagically changes into a WideString.

Part of Zinc HTTP Components.!
!ZnByteStringBecameWideString methodsFor: 'convenience' stamp: ''!
becomeForward
	"Switch the identities of byteString and wideString using #becomeForward:"

	byteString becomeForward: wideString ! !

!ZnByteStringBecameWideString methodsFor: 'testing' stamp: ''!
isResumable
	^ true! !

!ZnByteStringBecameWideString methodsFor: 'accessing' stamp: ''!
byteString
	^ byteString! !

!ZnByteStringBecameWideString methodsFor: 'accessing' stamp: ''!
wideString: anObject
	wideString := anObject! !

!ZnByteStringBecameWideString methodsFor: 'accessing' stamp: ''!
byteString: anObject
	byteString := anObject! !

!ZnByteStringBecameWideString methodsFor: 'accessing' stamp: ''!
wideString
	^ wideString! !

!ZnByteStringBecameWideString class methodsFor: 'convenience' stamp: ''!
convert: byteString
	"Convert byteString to a wideString, signalling a resumable error"
	
	| wideString |
	wideString := WideString from: byteString.
	self new
		byteString: byteString;
		wideString: wideString;
		signal.
	^ wideString! !

!ZnCharacterEncoder commentStamp: ''!
I am ZnCharacterEncoder, I encode and decode Character objects to and from a binary stream.
I am an abstract class with following protocol:

#nextFromStream:
#nextPut:toStream:
#encodedByteCountFor:
#backOnStream:

The first two are compatible with TextConverter and subclasses.

I add some convenience methods:

#encodeString:
#decodeBytes:
#encodedByteCountForString:

Contrary to older encoders, I work strictly from strings to bytes and vice versa and I will throw errors instead of silently ignoring them.

I also implement optimized bulk operations:

#next:putAll:startingAt:toStream:
#readInto:startingAt:count:fromStream:

Additionally, I can encode Integer code points to a binary stream as well as read Integer code points from a binary stream. This is in a sense a more fundamental operation that avoids instanciating Character objects.

#nextCodePointFromStream:
#nextPutCodePoint:toStream:
#encodedByteCountForCodePoint:

#decodeAsCodePoints:
#encodeCodePoints:
#encodedByteCountForCodePoints:

Part of Zinc HTTP Components.!
!ZnCharacterEncoder methodsFor: 'error handling' stamp: ''!
errorIncomplete
	^ ZnIncomplete signal: 'Incomplete input for character decoding'! !

!ZnCharacterEncoder methodsFor: 'error handling' stamp: ''!
errorOutsideRange
	^ self error: 'Character Unicode code point outside encoder range'! !

!ZnCharacterEncoder methodsFor: 'comparing' stamp: ''!
= anObject
	^ self class == anObject class! !

!ZnCharacterEncoder methodsFor: 'initialize-release' stamp: ''!
beLenient
	"Don't be strict, which is the default"! !

!ZnCharacterEncoder methodsFor: 'error handling' stamp: ''!
error: message
	^ ZnCharacterEncodingError signal: message! !

!ZnCharacterEncoder methodsFor: 'converting' stamp: ''!
encodedByteCountFor: character
	"Return how many bytes are needed to encode character"
	
	"We should use #codePoint but #asInteger is faster"
	
	^ self encodedByteCountForCodePoint: character asInteger! !

!ZnCharacterEncoder methodsFor: 'comparing' stamp: ''!
hash
	^ self class hash! !

!ZnCharacterEncoder methodsFor: 'accessing' stamp: ''!
identifier
	^ self subclassResponsibility! !

!ZnCharacterEncoder methodsFor: 'convenience' stamp: ''!
next: count putAll: string startingAt: offset toStream: stream
	"Write count characters from string starting at offset to stream."
	
	offset to: offset + count - 1 do: [ :index | 
		self nextPut: (string at: index) toStream: stream ]! !

!ZnCharacterEncoder methodsFor: 'convenience' stamp: ''!
encodedByteCountForCodePoints: codePoints
	"Return the exact number of bytes it would take to encode codePoints as a byte array"

	^ codePoints 
		inject: 0 
		into: [ :sum :each |
			sum + (self encodedByteCountForCodePoint: each) ]! !

!ZnCharacterEncoder methodsFor: 'convenience' stamp: ''!
decodeAsCodePoints: bytes
	"Decode bytes and return the resulting code points"
	
	| byteStream |
	byteStream := bytes readStream.
	^ Array streamContents: [ :stream |
		[ byteStream atEnd ] whileFalse: [
			stream nextPut: (self nextCodePointFromStream: byteStream) ] ] ! !

!ZnCharacterEncoder methodsFor: 'converting' stamp: ''!
encodedByteCountForCodePoint: codePoint
	"Return how many bytes are needed to encode integer code point"
	
	self subclassResponsibility ! !

!ZnCharacterEncoder methodsFor: 'convenience' stamp: ''!
encodedByteCountForString: string
	"Return the exact number of bytes it would take to encode string as a byte array"

	^ string 
		inject: 0 
		into: [ :sum :each |
			sum + (self encodedByteCountFor: each) ]! !

!ZnCharacterEncoder methodsFor: 'convenience' stamp: ''!
encodeCodePoints: codePoints
	"Encode codePoints and return the resulting byte array"
	
	^ ByteArray streamContents: [ :stream |
		codePoints do: [ :each | 
			self nextPutCodePoint: each toStream: stream ] ]! !

!ZnCharacterEncoder methodsFor: 'convenience' stamp: ''!
readInto: string startingAt: offset count: requestedCount fromStream: stream
	"Read requestedCount characters into string starting at offset,
	returning the number read, there could be less available when stream is atEnd"

	offset to: offset + requestedCount - 1 do: [ :index |
		stream atEnd ifTrue: [ ^ index - offset ].  
		string at: index put: (self nextFromStream: stream) ].
	^ requestedCount! !

!ZnCharacterEncoder methodsFor: 'converting' stamp: ''!
asZnCharacterEncoder
	^ self! !

!ZnCharacterEncoder methodsFor: 'converting' stamp: ''!
backOnStream: stream
	"Move back one character on stream, assuming stream understands #back"
	
	self subclassResponsibility ! !

!ZnCharacterEncoder methodsFor: 'convenience' stamp: ''!
decodeBytes: bytes
	"Decode bytes and return the resulting string"
	
	| byteStream |
	byteStream := bytes readStream.
	^ String streamContents: [ :stream |
		[ byteStream atEnd ] whileFalse: [
			stream nextPut: (self nextFromStream: byteStream) ] ] ! !

!ZnCharacterEncoder methodsFor: 'convenience' stamp: ''!
encodeString: string
	"Encode string and return the resulting byte array"
	
	^ ByteArray streamContents: [ :stream |
		self next: string size putAll: string startingAt: 1 toStream: stream ]! !

!ZnCharacterEncoder methodsFor: 'converting' stamp: ''!
nextCodePointFromStream: stream
	"Read and return the next integer code point from stream"
	
	self subclassResponsibility ! !

!ZnCharacterEncoder methodsFor: 'converting' stamp: ''!
nextFromStream: stream
	"Read and return the next character from stream"
	
	"We should use #codePoint: but #value: is faster"
	
	^ Character value: (self nextCodePointFromStream: stream)! !

!ZnCharacterEncoder methodsFor: 'converting' stamp: ''!
nextPutCodePoint: codePoint toStream: stream
	"Write the encoding for Integer code point to stream"
	
	self subclassResponsibility ! !

!ZnCharacterEncoder methodsFor: 'converting' stamp: ''!
nextPut: character toStream: stream
	"Write the encoding for character to stream"
	
	"We should use #codePoint but #asInteger is faster"
	
	self nextPutCodePoint: character asInteger toStream: stream  ! !

!ZnCharacterEncoder class methodsFor: 'accessing' stamp: ''!
knownEncodingIdentifiers
	"Return a collection of all known encoding identifiers in the system"
	
	self = ZnCharacterEncoder ifFalse: [ ^ #() ].
	^ Array streamContents: [ :all |
		self allSubclassesDo: [ :subClass |
			all nextPutAll: subClass knownEncodingIdentifiers ] ]! !

!ZnCharacterEncoder class methodsFor: 'instance creation' stamp: ''!
newForEncoding: string
	"Return a new character encoder object for an encoding described by string.
	Search for a subclass that handles it and delegate (subclassResponsibility)."
	
	| concreteSubclass |
	concreteSubclass := self allSubclasses 
		detect: [ :each | each handlesEncoding: string ] 
		ifNone: [ ^ self default ].
	^ concreteSubclass newForEncoding: string! !

!ZnCharacterEncoder class methodsFor: 'convenience' stamp: ''!
utf8
	^ ZnUTF8Encoder default! !

!ZnCharacterEncoder class methodsFor: 'accessing' stamp: ''!
canonicalEncodingIdentifier: string
	^ (string select: [ :each | each isAlphaNumeric ]) asLowercase! !

!ZnCharacterEncoder class methodsFor: 'convenience' stamp: ''!
iso88591
	^ self newForEncoding: 'iso-8859-1'! !

!ZnCharacterEncoder class methodsFor: 'accessing' stamp: ''!
handlesEncoding: string
	"Return true when my instances handle the encoding described by string"
	
	self subclassResponsibility ! !

!ZnCharacterEncoder class methodsFor: 'convenience' stamp: ''!
latin1
	^ self newForEncoding: 'latin1'! !

!ZnCharacterEncoder class methodsFor: 'accessing' stamp: ''!
default
	"Return the default ZnCharacterEncoder to be used 
	when none is otherwise specified."
	
	^ ZnDefaultCharacterEncoder value! !

!ZnCharacterEncoder class methodsFor: 'convenience' stamp: ''!
ascii
	^ self newForEncoding: 'ASCII'! !

!ZnCharacterEncoder class methodsFor: 'instance creation' stamp: ''!
detectEncoding: bytes
	"Return one of my instances capable of decoding bytes.
	This is done by successively trying known encodings in a specific order.
	If no one is found, signal ZnCharacterEncodingError.
	This is a heuristic and unreliable [https://en.wikipedia.org/wiki/Charset_detection]."
	
	| candidates |
	"Set up an ordered candidates list, 7-bit ascii and utf8 are reasonably reliable, iso88591 is a reasonable default"
	candidates := #(ascii utf8 iso88591).
	candidates := candidates , (ZnByteEncoder knownEncodingIdentifiers difference: candidates).
	candidates := candidates , (self knownEncodingIdentifiers difference: candidates).
	"Try each and return the first one that succeeeds."
	candidates do: [ :identifier | | encoder |
		encoder := self newForEncoding: identifier.
		[ ^ encoder decodeBytes: bytes; yourself ] on: ZnCharacterEncodingError do: [ ] ].
	ZnCharacterEncodingError signal: 'No suitable encoder found'! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF16EncoderByteOrderMark
	| string bytes encoder encoded |
	string := 'foo'.
	bytes := ByteArray readHexFrom: 'FEFF0066006f006f'.
	encoder := ZnUTF16Encoder new.
	self assert: encoder isBigEndian.
	encoded := ByteArray streamContents: [ :out |
		encoder nextPutByteOrderMarkToStream: out.
		encoder next: string size putAll: string startingAt: 1 toStream: out ].
	self assert: encoded equals: bytes.
	self assert: (encoder decodeBytes: bytes) equals: string.
	encoder beLittleEndian.
	self assert: encoder isLittleEndian.
	self assert: (encoder decodeBytes: bytes) equals: string.
	self assert: encoder isBigEndian.
	1 to: bytes size by: 2 do: [ :each | bytes swap: each with: each + 1 ].
	self assert: (encoder decodeBytes: bytes) equals: string.
	self assert: encoder isLittleEndian
! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF32EncoderWide
	| encoder |
	encoder := ZnUTF32Encoder new.
	{ 
		'abc'. 
		'élève en Français'. 
		'Pra-ská' copy at: 4 put: (Character value: 382); yourself. 
		(Character codePoint: 16r1d11e) asString. "MUSICAL SYMBOL G CLEF"
		'' } do: [ :each | 
			| bytes |
			bytes := self encodeString: each with: encoder. 
			self assert: (encoder decodeBytesIntoWideString: bytes) equals: each ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testDefault
	| string bytes |
	self assert: ZnCharacterEncoder default equals: ZnUTF8Encoder new.
	string := 'Der Weg zur Hölle ist mit guten Vorsätzen gepflastert.'.
	bytes := ZnUTF8Encoder new encodeString: string.
	ZnDefaultCharacterEncoder 
		value: ZnUTF8Encoder new
		during: [ 
			self 
				assert: (ZnCharacterEncoder default decodeBytes: bytes) 
				equals: string ].
	ZnDefaultCharacterEncoder 
		value: ZnUTF8Encoder new
		during: [ 
			self 
				assert: ((ZnCharacterEncoder newForEncoding: 'unknown') decodeBytes: bytes) 
				equals: string ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testLatin1Encoder
	| encoder string bytes |
	encoder := ZnCharacterEncoder newForEncoding: 'latin1'.
	string := 'élève en Français'.
	bytes := #(233 108 232 118 101 32 101 110 32 70 114 97 110 231 97 105 115) asByteArray.
	self assert: (encoder encodeString: string) equals: bytes.
	self assert: (encoder decodeBytes: bytes) equals: string! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testByteEncoderFromUrl
	| encoderFromUrl iso88592 bytes characters |
	encoderFromUrl := ZnByteEncoder newFromUrl: 'http://files.pharo.org/extra/unicode/8859-2.TXT'.
	iso88592 := ZnCharacterEncoder newForEncoding: #iso88592.
	self assert: encoderFromUrl byteDomain equals: iso88592 byteDomain.
	self assert: encoderFromUrl characterDomain equals: iso88592 characterDomain.
	bytes := encoderFromUrl byteDomain.
	self 
		assert: (encoderFromUrl decodeBytes: bytes)
		equals: (iso88592 decodeBytes: bytes).
	characters := String withAll: encoderFromUrl characterDomain asArray.
	self 
		assert: (encoderFromUrl encodeString: characters)
		equals: (iso88592 encodeString: characters).
		! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8EncoderIncomplete
	"The examples are taken from http://en.wikipedia.org/wiki/UTF-8#Description"
	
	| encoder |
	encoder := ZnUTF8Encoder new.
	#( (16rC2 16rA2) (16rE2 16r82 16rAC) (16rF0 16rA4 16rAD 16rA2) ) do: [ :each |
		2 to: each size do: [ :count |
			self 
				should: [ encoder decodeBytes: (each allButLast: count - 1) ] 
				raise: ZnIncomplete ] ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testNullEncoder
	| encoder bytes string |
	encoder := ZnNullEncoder new.
	bytes := self encodeString: 'abc' with: encoder.
	self assert: bytes equals: #(97 98 99) asByteArray.
	string := self decodeBytes: #(65 66 67) asByteArray with: encoder.
	self assert: string equals: 'ABC'! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testKnownEncodingIdentifiers
	| all minimal asciiString |
	all := ZnCharacterEncoder knownEncodingIdentifiers asSet.
	minimal := #(utf8 latin1 null ascii iso88591) asSet.
	"make sure at least a minimal set is present"
	self assert: (all intersection: minimal) equals: minimal.
	asciiString := String withAll: ($a to: $z) , ($A to: $Z) , ($0 to: $9).
	"make sure that each identifier can be used to instanciate a decoder,
	and that those decoders at least work on a ASCII string in both directions"
	all do: [ :each |
		| encoder bytes |
		encoder := ZnCharacterEncoder newForEncoding: each.
		bytes := encoder encodeString: asciiString.
		self assert: (encoder decodeBytes: bytes) equals: asciiString ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testReadIntoStartingAtCountFromStreamWithOffset
	| input encoder bytes readStream string read |
	encoder := ZnUTF8Encoder new.
	input := '_élève_'.
	bytes := encoder encodeString: input.
	readStream := bytes readStream.
	readStream next.
	string := String new: 7 withAll: $_.
	read := encoder readInto: string startingAt: 2 count: 5 fromStream: readStream.
	self assert: string equals: input.
	self assert: read equals: 5.
	input := '_Français_'.
	bytes := encoder encodeString: input.
	readStream := bytes readStream.
	readStream next.
	string := String new: 10 withAll: $_.
	read := encoder readInto: string startingAt: 2 count: 8 fromStream: readStream.
	self assert: string equals: input.
	self assert: read equals: 8! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF16EncoderLittleEndian
	| string bytes encoder |
	string := 'élève en Français'.
	bytes := ByteArray readHexFrom:
		'E9006C00E80076006500200065006E0020004600720061006E00E700610069007300'.
	encoder := ZnUTF16Encoder new.
	encoder beLittleEndian.
	self assert: encoder isLittleEndian.
	self assert: (encoder encodeString: string) equals: bytes.
	self assert: (encoder decodeBytes: bytes) equals: string! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testReadIntoStartingAtCountFromStream
	| encoder |
	encoder := ZnUTF8Encoder new.
	#( 'ccc' 'ççç' 'c' 'ç' 'çc' 'cç' 'çç' ) do: [ :each |
		#( ( '' '' ) ( 'ABC' '' ) ( '' 'ABC' ) ( 'ABC' 'ABC' ) 
			( 'AéC' '' ) ( '' 'AèC' ) ( 'AéC' 'AèC' ) 
			( 'AXC' 'AèC' ) ( 'AéC' 'AXC' ) 
			( 'PRE' 'ç' ) ) do: [ :extra |
				| prefix postfix string bytes buffer read |
				prefix := extra first.
				postfix := extra last.
				string := prefix, each.
				bytes := encoder encodeString: string, postfix.
				buffer := String new: string size.
				read := encoder readInto: buffer startingAt: 1 count: string size fromStream: bytes readStream.
				self assert: buffer equals: string.
				self assert: read equals: string size ] ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testCodePointStreams
	| string codePoints bytes result |
	string := 'Düsseldorf Königsallee'.
	codePoints := string collect: #codePoint as: Array.
	self assert: codePoints isCollection.
	self assert: (codePoints allSatisfy: #isInteger).
	#(utf8 utf16 utf32 latin1 null) do: [ :each |
		bytes := ByteArray streamContents: [ :out |
			(ZnCodePointWriteStream on: out encoding: each)
				nextPutAll: codePoints ].
		self assert: bytes equals: (each asZnCharacterEncoder encodeString: string).
		result := (ZnCodePointReadStream on: bytes readStream encoding: each) upToEnd.
		self assert: result equals: codePoints.
		self assert: (codePoints collect: #asCharacter as: String) equals: string ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testReadIntoStartingAtCountFromStreamAtEnd
	| input encoder bytes readStream string read |
	encoder := ZnUTF8Encoder new.
	input := 'élève'.
	bytes := encoder encodeString: input.
	readStream := bytes readStream.
	string := String new: 5 withAll: $_.
	read := encoder readInto: string startingAt: 1 count: 10 fromStream: readStream.
	self assert: string equals: input.
	self assert: read equals: 5! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8Encoder
	"The examples are taken from http://en.wikipedia.org/wiki/UTF-8#Description"

	| encoder inputBytes outputBytes inputString outputString |
	encoder := ZnUTF8Encoder new.
	inputString := String
		with: $$
		with: 16r00A2 asCharacter
		with: 16r20AC asCharacter
		with: 16r024B62 asCharacter.
	inputBytes := #(16r24 16rC2 16rA2 16rE2 16r82 16rAC 16rF0 16rA4 16rAD 16rA2) asByteArray.
	outputBytes := self encodeString: inputString with: encoder.
	self assert: outputBytes equals: inputBytes.
	outputString := self decodeBytes: inputBytes with: encoder.
	self assert: outputString equals: inputString! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF32EncoderExampleFromD99
	| string bytes encoder |
	string := #(16r0000004D 16r00000430 16r00004E8C 16r00010302) collect: #asCharacter as: String.
	bytes := ByteArray readHexFrom: '0000004D0000043000004E8C00010302'.
	encoder := #utf32 asZnCharacterEncoder.
	encoder beBigEndian.
	self assert: encoder isBigEndian.
	self assert: (encoder encodeString: string) equals: bytes.
	self assert: (encoder decodeBytes: bytes) equals: string! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testReadIntoStartingAtCountFromStreamWide
	| encoder |
	encoder := ZnUTF8Encoder new.
	{ 'abc', (WideString withAll: { 300 asCharacter. 400 asCharacter. 500 asCharacter}), 'xyz' } do: [ :each |
			| bytes buffer notified read |
			bytes := encoder encodeString: each.
			buffer := String new: each size.
			notified := false.
			[ read := encoder readInto: buffer startingAt: 1 count: each size fromStream: bytes readStream ]
				on: ZnByteStringBecameWideString 
				do: [ :notification |
					self deny: notified.
					notified := true.
					buffer := notification wideString.
					notification resume ].
			self assert: notified.
			self assert: buffer equals: each.
			self assert: read equals: each size ] ! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF16Back
	| encoder stream |
	encoder := ZnUTF16Encoder new.
	stream := (encoder encodeString: 'Les élèves Françaises') readStream.
	self should: [ encoder backOnStream: stream ] raise: Error.
	4 timesRepeat: [ encoder nextFromStream: stream ].
	self assert: (encoder nextFromStream: stream) equals: $é.
	encoder backOnStream: stream.
	self assert: (encoder nextFromStream: stream) equals: $é.
	10 timesRepeat: [ encoder nextFromStream: stream ].
	13 timesRepeat: [ encoder backOnStream: stream ].
	self assert: (encoder nextFromStream: stream) equals: $s! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8Back
	| encoder stream |
	encoder := ZnUTF8Encoder new.
	stream := (encoder encodeString: 'Les élèves Françaises') readStream.
	self should: [ encoder backOnStream: stream ] raise: Error.
	4 timesRepeat: [ encoder nextFromStream: stream ].
	self assert: (encoder nextFromStream: stream) equals: $é.
	encoder backOnStream: stream.
	self assert: (encoder nextFromStream: stream) equals: $é.
	10 timesRepeat: [ encoder nextFromStream: stream ].
	13 timesRepeat: [ encoder backOnStream: stream ].
	self assert: (encoder nextFromStream: stream) equals: $s! !

!ZnCharacterEncoderTest methodsFor: 'private' stamp: ''!
encodeString: string with: encoder
	^ ByteArray streamContents: [ :stream |
		string do: [ :each |
			encoder nextPut: each toStream: stream ] ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8Boundaries
	"Test encoding and decoding of the characters at the boundaries between 1, 2, 3, and 4 multi-byte sequences.
	Values taken from http://en.wikipedia.org/wiki/Utf8#Description with the new RFC 3629 limit"
	
	| utf8Encoder string encoded |
	utf8Encoder := ZnUTF8Encoder new.
	#( (0 16r7f) 
		(16r80 16r07FF) 
		(16r0800 16rFFFF) 
		(16r10000 16r10FFFF) 
	) doWithIndex: [ :boundaries :byteCount |
		boundaries do: [ :each |
			string := String with: each asCharacter.
			encoded := utf8Encoder encodeString: string. 
			self assert: (utf8Encoder decodeBytes: encoded) equals: string.
			self assert: encoded size equals: byteCount ] ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testNextPutAllStartingAtToStream
	| encoder |
	encoder := ZnUTF8Encoder new.
	#( 'ccc' 'ççç' 'c' 'ç' 'çc' 'cç' 'çç' ) do: [ :each |
		#( ( '' '' ) ( 'ABC' '' ) ( '' 'ABC' ) ( 'ABC' 'ABC' ) 
			( 'AéC' '' ) ( '' 'AèC' ) ( 'AéC' 'AèC' ) 
			( 'AXC' 'AèC' ) ( 'AéC' 'AXC' ) 
			( 'PRE' 'ç' ) ) do: [ :extra |
				| prefix postfix string bytes |
				prefix := extra first.
				postfix := extra last.
				string := prefix, each, postfix.
				bytes := ByteArray streamContents: [ :out |
					encoder next: each size putAll: string startingAt: prefix size + 1 toStream: out ].
				self assert: (encoder decodeBytes: bytes) equals: each ] ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8ByteOrderMark
	"The Unicode Byte Order Mark (BOM) should be skipped."
	
	| bom string bytes encoder decodedString |
	encoder := ZnUTF8Encoder new.
	string := 'élève en Français'.
	bytes := encoder encodeStringWithByteOrderMark: string.
	self assert: (encoder decodeBytes: bytes) equals: string.
	
	string := 'Foo'.
	bytes := encoder encodeStringWithByteOrderMark: string.
	decodedString := String new: string size.
	ZnUTF8Encoder new 
		readInto: decodedString startingAt: 1 count: string size fromStream: bytes readStream. 
	self assert: decodedString equals: string.
	
	bom := encoder encodeStringWithByteOrderMark: ''.
	self should: [ encoder decodeBytes: bom ] raise: ZnIncomplete! !

!ZnCharacterEncoderTest methodsFor: 'private' stamp: ''!
decodeBytes: bytes with: encoder
	| input |
	input := bytes readStream.
	^ String streamContents: [ :stream |
		[ input atEnd ] whileFalse: [ 
			stream nextPut: (encoder nextFromStream: input) ] ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testByteDecoding
	| encoder bytes |
	encoder := ZnUTF8Encoder new.
	bytes := encoder encodeString: 'élève en Français'.
	self assert: (bytes decodeWith: encoder) equals: (encoder decodeBytes: bytes).
	self assert: (bytes decodeWith: #utf8) equals: (encoder decodeBytes: bytes).
	self assert: bytes utf8Decoded equals: (encoder decodeBytes: bytes)! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8EncoderRandom
	#(unicodeCharacterSource latin1CharacterSource asciiCharacterSource) do: [ :source |
		| string bytes result |
		string := self class stringOfSize: 256 fromSource: source.
		bytes := string utf8Encoded.
		result := bytes utf8Decoded.
		self assert: result equals: string ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8EncoderWide
	| encoder |
	encoder := ZnUTF8Encoder new.
	{ 'abc'. 'élève en Français'. 'Pra-ská' copy at: 4 put: (Character value: 382); yourself. '' }
		do: [ :each | | bytes |
			bytes := self encodeString: each with: encoder. 
			self assert: (encoder decodeBytesIntoWideString: bytes) equals: each ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8Overlong
	"Overlong encoding, aka Non shortest form characters should be rejected.
	See http://en.wikipedia.org/wiki/UTF-8#Overlong_encodings"
	
	self 
		should: [ ZnUTF8Encoder new decodeBytes: #[ 16rF0 16r82 16r82 16rAC ] ] 
		raise: ZnInvalidUTF8.
	self 
		should: [ ZnUTF8Encoder new decodeBytes: #(193 129 193 130 193 131 ) ] 
		raise: ZnInvalidUTF8.
		
	! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8ReadFaultyInput
	"Although not recommended, it is possible to read faulty UTF-8 encoded input by resuming ZnInvalidUTF8"
	
	"illegal leading byte"
	self 
		should: [ #[102 111 111 160 102 111 111] utf8Decoded ] 
		raise: ZnInvalidUTF8.
	self 
		assert: ([ #[102 111 111 160 102 111 111] utf8Decoded ] on: ZnInvalidUTF8 do: [ :exception | exception resume ]) 
		equals: 'foo?foo'.
	self 
		assert: ([ #[102 111 111 160 102 111 111] utf8Decoded ] on: ZnInvalidUTF8 do: [ :exception | exception resume: $_ codePoint ]) 
		equals: 'foo_foo'.
	
	"illegal continuation byte"
	self 
		should: [ #[102 111 111 195 0 102 111 111] utf8Decoded ] 
		raise: ZnInvalidUTF8.
	self 
		assert: ([ #[102 111 111 195 0 102 111 111] utf8Decoded ] on: ZnInvalidUTF8 do: [ :exception | exception resume ]) 
		equals: 'foo?foo'.

	"incomplete input"
	self 
		should: [ #[102 111 111 195 ] utf8Decoded ] 
		raise: ZnIncomplete.
	self 
		assert: ([ #[102 111 111 195 ] utf8Decoded ] on: ZnInvalidUTF8 , ZnIncomplete do: [ :exception | exception resume ]) 
		equals: 'foo?'! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testLatin2Encoder
	"Example characters taken from http://en.wikipedia.org/wiki/Latin2"

	| encoder inputBytes outputBytes inputString outputString |
	encoder := ZnCharacterEncoder newForEncoding: 'latin2'.
	inputString := String
		with: 16r0154 asCharacter
		with: 16r0110 asCharacter
		with: 16r0155 asCharacter
		with: 16r0111 asCharacter.
	inputBytes := #(192 208 224 240) asByteArray.
	outputBytes := self encodeString: inputString with: encoder.
	self assert: outputBytes equals: inputBytes.
	outputString := self decodeBytes: inputBytes with: encoder.
	self assert: outputString equals: inputString! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testDetectEncoding
	| bytes |
	bytes := 'abc' asByteArray.
	self assert: (ZnCharacterEncoder detectEncoding: bytes) equals: ZnCharacterEncoder ascii.
	bytes := ZnCharacterEncoder iso88591 encodeString: 'Les élèves Français'.
	self assert: (ZnCharacterEncoder detectEncoding: bytes) equals: ZnCharacterEncoder iso88591.
	bytes := ZnCharacterEncoder utf8 encodeString: 'Les élèves Français'.
	self assert: (ZnCharacterEncoder detectEncoding: bytes) equals: ZnCharacterEncoder utf8.
! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8EncoderByteCount
	| encoder |
	encoder := ZnUTF8Encoder new.
	self assert: (encoder encodedByteCountFor: $$) equals: 1.
	self assert: (encoder encodedByteCountFor: 16r00A2 asCharacter) equals: 2.
	self assert: (encoder encodedByteCountFor: 16r20AC asCharacter) equals: 3.
	self assert: (encoder encodedByteCountFor: 16r024B62 asCharacter) equals: 4! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8EncoderAuto
	| encoder inputString bytes outputString |
	encoder := ZnUTF8Encoder new.
	inputString := String withAll: ((1 to: 3072) collect: [ :each | Character value: each ]).
	bytes := self encodeString: inputString with: encoder.
	outputString := self decodeBytes: bytes with: encoder.
	self assert: inputString equals: outputString! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF8SurrogateCodePointsShouldFail
	| encoder surrogateCodePoint |
	encoder := #utf8 asZnCharacterEncoder.
	surrogateCodePoint := 16rD801.
	self assert: (encoder isSurrogateCodePoint: surrogateCodePoint).
	self 
		should: [ encoder encodeString: surrogateCodePoint asCharacter asString ]
		raise: ZnInvalidUTF8.
	self 
		should: [ encoder decodeBytes: #[237 160 129] ]
		raise: ZnInvalidUTF8! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF32EncoderExampleFromD101
	| string encoder bytesBigEndianWithBom bytesLittleEndianWithBom |
	string := #(16r0000004D 16r00000430 16r00004E8C 16r00010302) collect: #asCharacter as: String.
	encoder := #utf32 asZnCharacterEncoder.
	encoder beLittleEndian.
	"start with the wrong endianness (LE)"
	bytesBigEndianWithBom := ByteArray readHexFrom: '0000FEFF0000004D0000043000004E8C00010302'.
	"the correct endianness (BE) should be detected"
	self assert: (encoder decodeBytes: bytesBigEndianWithBom) equals: string.
	self assert: encoder isBigEndian.
	"start with the wrong endianness (BE)"
	bytesLittleEndianWithBom := ByteArray readHexFrom: 'FFFE00004D000000300400008C4E000002030100'.
	"the correct endianness (LE) should be detected"
	self assert: (encoder decodeBytes: bytesLittleEndianWithBom) equals: string.
	self assert: encoder isLittleEndian.
! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testBeLenient
	| encoder unmapped |
	encoder := ZnCharacterEncoder newForEncoding: 'iso-8859-1'.
	unmapped := (128 to: 159) asByteArray.
	self should: [ encoder encodeString: unmapped asString ] raise: ZnCharacterEncodingError.
	self should: [ encoder decodeBytes: unmapped ] raise: ZnCharacterEncodingError.
	encoder beLenient.
	self assert: (encoder encodeString: unmapped asString) equals: unmapped.
	self assert: (encoder decodeBytes: unmapped) equals: unmapped asString.! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testStringEncoding
	| encoder string |
	encoder := ZnUTF8Encoder new.
	string := 'élève en Français'.
	self assert: (string encodeWith: encoder) equals: (encoder encodeString: string).
	self assert: (string encodeWith: #utf8) equals: (encoder encodeString: string).
	self assert: string utf8Encoded equals: (encoder encodeString: string)
! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF16EncoderWide1
	| string bytes encoder |
	string := (Character codePoint: 16r1d11e) asString. "MUSICAL SYMBOL G CLEF"
	bytes := ByteArray readHexFrom: 'D834DD1E'.
	encoder := ZnUTF16Encoder new.
	self assert: encoder isBigEndian.
	self assert: (encoder encodeString: string) equals: bytes.
	self assert: (encoder decodeBytes: bytes) equals: string! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF32EncoderSimple
	| string bytes encoder |
	string := 'élève en Français'.
	bytes := ByteArray readHexFrom: '000000e90000006c000000e8000000760000006500000020000000650000006e000000200000004600000072000000610000006e000000e7000000610000006900000073'.
	encoder := #utf32 asZnCharacterEncoder.
	self assert: encoder isBigEndian.
	self assert: (encoder encodedByteCountForString: string) equals: 17 * 4.
	self assert: (encoder encodeString: string) equals: bytes.
	self assert: (encoder decodeBytes: bytes) equals: string! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testConvencienceMethods
	| encoder string |
	encoder := ZnUTF8Encoder new.
	string := 'élève en Français'.
	self assert: (encoder decodeBytes: (encoder encodeString: string)) equals: string.
	self assert: (encoder encodedByteCountForString: string) equals: 20.

	#('ccc' 'ççç' 'c' 'ç' 'çc' 'cç') do: [ :each | self assert: (encoder decodeBytes: (encoder encodeString: each)) equals: each ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF32EncoderExampleFromD100
	| string bytes encoder |
	string := #(16r0000004D 16r00000430 16r00004E8C 16r00010302) collect: #asCharacter as: String.
	bytes := ByteArray readHexFrom: '4D000000300400008C4E000002030100'.
	encoder := #utf32 asZnCharacterEncoder.
	encoder beLittleEndian.
	self assert: encoder isLittleEndian.
	self assert: (encoder encodeString: string) equals: bytes.
	self assert: (encoder decodeBytes: bytes) equals: string! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testAllByteEncoderDomains
	| encoder characterDomain byteDomain encoded |
	ZnByteEncoder knownEncodingIdentifiers do: [ :identifier |
		encoder := ZnCharacterEncoder newForEncoding: identifier.
		self assert: encoder identifier equals: identifier.
		self assert: encoder isStrict.
		self assert: encoder isLenient not.
		self assert: (encoder encodeString: 'hello') equals: #[104 101 108 108 111] .
		self assert: (encoder decodeBytes: #[104 101 108 108 111] ) equals: 'hello'.
		characterDomain := encoder characterDomain.
		byteDomain := encoder byteDomain.
		characterDomain do: [ :each |
			self assert: (encoder encodedByteCountFor: each) equals: 1.
			encoded := ByteArray streamContents: [ :out | encoder nextPut: each toStream: out ].
			self assert: encoded size equals: 1.
			self assert: (byteDomain includes: encoded first) ].
		byteDomain do: [ :each |
			self assert: (characterDomain includes: (encoder nextFromStream: (ByteArray with: each) readStream)) ] ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testCodePointEncodingDecoding
	| encoder input output |
	input := 'Düsseldorf Königsallee' collect: #codePoint as: Array.
	self assert: input isCollection.
	self assert: (input allSatisfy: #isInteger).
	#(utf8 utf16 utf32 latin1 null) do: [ :each |
		encoder := each asZnCharacterEncoder.
		output := encoder encodeCodePoints: input.
		self assert: output isCollection.
		self assert: (output allSatisfy: [ :e | e isInteger and: [ e between: 0 and: 255 ] ] ).
		self assert: (encoder encodedByteCountForCodePoints: input) equals: output size.
		self assert: (encoder decodeAsCodePoints: output) equals: input ]! !

!ZnCharacterEncoderTest methodsFor: 'testing' stamp: ''!
testUTF16EncoderBigEndian
	| string bytes encoder |
	string := 'élève en Français'.
	bytes := ByteArray readHexFrom:
		'00E9006C00E80076006500200065006E0020004600720061006E00E7006100690073'.
	encoder := ZnUTF16Encoder new.
	self assert: encoder isBigEndian.
	self assert: (encoder encodeString: string) equals: bytes.
	self assert: (encoder decodeBytes: bytes) equals: string! !

!ZnCharacterEncoderTest class methodsFor: 'accessing' stamp: ''!
unicodeCharacterSource
	^ ($A to: $Z), ($a to: $z), ($0 to: $9), '.-_/*+=|,;?!!$&<>^%#', '         ', 'éèçüäßñα', '€∏'! !

!ZnCharacterEncoderTest class methodsFor: 'accessing' stamp: ''!
asciiCharacterSource
	^ ($A to: $Z), ($a to: $z), ($0 to: $9), '.-_/*+=|,;?!!$&<>^%#', '    '! !

!ZnCharacterEncoderTest class methodsFor: 'accessing' stamp: ''!
stringOfSize: size fromSource: source
	"self stringOfSize: 1024 fromSource: self unicodeCharacterSource"
	
	^ String new: size streamContents: [ :out | 
		size timesRepeat: [ out nextPut: source atRandom ] ]! !

!ZnCharacterEncoderTest class methodsFor: 'accessing' stamp: ''!
latin1CharacterSource
	^ ($A to: $Z), ($a to: $z), ($0 to: $9), '.-_/*+=|,;?!!$&<>^%#', '       ', 'éèçüäßñ'! !

!ZnCharacterEncodingError commentStamp: ''!
I am ZnCharacterEncodingError.
I am an Error.

I signal when something goes wrong while encoding or decoding characters.

Part of Zinc HTTP Components!
!ZnCharacterReadStream commentStamp: ''!
I am ZnCharacterReadStream.
I wrap another binary ReadStream and use a ZnCharacerEncoder to allow Characters to be read.

I am not positionable, but I do allow a one character peek using a one character internal buffer.

Part of Zinc HTTP Components.
!
!ZnCharacterReadStream methodsFor: 'accessing' stamp: ''!
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! !

!ZnCharacterReadStream methodsFor: 'private' stamp: ''!
nextElement
	^ self encoder nextFromStream: stream! !

!ZnCharacterReadStream methodsFor: 'accessing' stamp: ''!
collectionSpecies
	^ String! !

!ZnCharacterReadStream methodsFor: 'accessing' stamp: ''!
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."
	
	^ self collectionSpecies streamContents: [ :out |
		| partialMatch pattern matched |
		partialMatch := (self collectionSpecies new: aCollection size) writeStream.
		pattern := aCollection readStream.
		matched := false.
		([ matched or: [ self atEnd or: [ pattern atEnd ] ] ]) whileFalse: [
			| ch |
			(ch := self next) = pattern next
				ifTrue: [
					pattern atEnd
						ifTrue: [ matched := true ]
						ifFalse: [ partialMatch nextPut: ch ] ]
				ifFalse: [
					pattern reset.
					out nextPutAll: partialMatch contents.
					partialMatch reset.
					out nextPut: ch ] ].
		matched ifFalse: [ out nextPutAll: partialMatch contents ] ]! !

!ZnCharacterReadStream methodsFor: 'accessing' stamp: ''!
nextLine
	"Read a CR, LF or CRLF terminated line, returning the contents of the line without the EOL. Return nil when the receiver is #atEnd."
	
	self atEnd ifTrue: [ ^ nil ].
	^ self collectionSpecies streamContents: [ :out | | eol char |
		eol := false.
		[ eol ] whileFalse: [ 
			char := self next.
			(char isNil or: [ char = Character lf ])
				ifTrue: [ eol := true ]
				ifFalse: [ 
					char = Character cr 
						ifTrue: [ eol := true. self peekFor: Character lf ]
						ifFalse: [ out nextPut: char ] ] ] ]! !

!ZnCharacterReadStream methodsFor: 'accessing' stamp: ''!
readInto: collection startingAt: offset count: requestedCount 
	"Read count elements and place them in collection starting at offset.
	Return the number of elements actually read."
	
	^ peeked 
		ifNil: [ | readCount |
			[ readCount := self encoder 
					readInto: collection 
					startingAt: offset 
					count: requestedCount 
					fromStream: stream ]
				on: ZnByteStringBecameWideString 
				do: [ :byteStringBecameWideString | 
					byteStringBecameWideString becomeForward; resume ].
			readCount ]
		ifNotNil: [ 
			collection at: offset put: peeked.
			peeked := nil.
			(self 
				readInto: collection 
				startingAt: offset + 1
				count: requestedCount - 1) + 1 ]! !

!ZnCharacterStreamTest methodsFor: 'testing' stamp: ''!
testPeek
	| string bytes readStream |
	string := 'élève en Français'.
	bytes := ZnUTF8Encoder new encodeString: string.
	readStream := ZnCharacterReadStream on: bytes readStream.
	self assert: readStream peek equals: 'é' first.
	self assert: readStream peek equals: 'é' first.
	self assert: readStream next equals: 'é' first.
	readStream skip: 'lève ' size.
	self assert: readStream peek equals: $e.
	self assert: (readStream next: 'en Français' size) equals: 'en Français'! !

!ZnCharacterStreamTest methodsFor: 'testing' stamp: ''!
testUpToAllTwice
	| utf8Stream stream |
	utf8Stream := self utf8ReadStreamOn: 'eißendeße'.
	self assert: (utf8Stream upToAll: 'ße') equals: 'ei'.
	self assert: (utf8Stream upToAll: 'ße') equals: 'nde'.

	stream := 'eißendeße' readStream.
	self assert: (stream upToAll: 'ße') equals: 'ei'.
	self assert: (stream upToAll: 'ße') equals: 'nde'! !

!ZnCharacterStreamTest methodsFor: 'testing' stamp: ''!
testSimpleUTF8ReadStream
	| string bytes |
	string := 'élève en Français'.
	bytes := ZnUTF8Encoder new encodeString: string.
	self 
		assert: (ZnCharacterReadStream on: bytes readStream) upToEnd
		equals: string! !

!ZnCharacterStreamTest methodsFor: 'testing' stamp: ''!
testUTF8ReadStreamReadInto
	| string bytes stream buffer |
	string := 'élève en Français'.
	bytes := ZnUTF8Encoder new encodeString: string.
	stream := ZnCharacterReadStream on: bytes readStream.
	buffer := String new: string size.
	stream next: string size into: buffer. 
	self assert: buffer equals: string.
	self assert: stream atEnd.
	string := 'Czech in Czech is {1}e{2}tina.' format: { 269 asCharacter. 353 asCharacter }.
	bytes := ZnUTF8Encoder new encodeString: string.
	stream := ZnCharacterReadStream on: bytes readStream.
	buffer := String new: string size.
	stream next: string size into: buffer. 
	self assert: buffer equals: string.
	self assert: stream atEnd	! !

!ZnCharacterStreamTest methodsFor: 'testing' stamp: ''!
testSimpleUTF8WriteStream
	| string bytes stream |
	string := 'élève en Français'.
	bytes := ZnUTF8Encoder new encodeString: string.
	stream := (ZnCharacterWriteStream on: ByteArray new writeStream).
	stream nextPutAll: string.
	self 
		assert: stream wrappedStream contents
		equals: bytes! !

!ZnCharacterStreamTest methodsFor: 'testing' stamp: ''!
testUpToAll
	#(
		('' '' '')
		('' 'ß' '')
		('' 'ße' '')
		('ß' '' '')
		('ße' '' '')
		('ß' 'ß' '')
		('ße' 'ß' '')
		('ß' 'ße' 'ß')
		('ß' 'e' 'ß')
		('ße' 'e' 'ß')
		('ßen' 'e' 'ß')
		('ßen' 'en' 'ß')
		('ßend' 'en' 'ß')
		('iße' 'e' 'iß')
		('ißen' 'e' 'iß')
		('ißen' 'en' 'iß')
		('ißend' 'en' 'iß')
		('iß' 'ß' 'i')
		('iße' 'ß' 'i')
		('eißen' 'ßend' 'eißen')
		('abcdefgh' 'cd' 'ab')
		('a' '' '')
		('a' 'a' '')
		('a' 'b' 'a')
		('ab' '' '')
		('ab' 'a' '')
		('ab' 'b' 'a')
		('ab' 'c' 'ab')
		('ab' 'ab' '')
		('abc' '' '')
		('abc' 'a' '')
		('abc' 'b' 'a')
		('abc' 'c' 'ab')
		('abc' 'd' 'abc')
		('abc' 'ab' '')
		('abc' 'bc' 'a')
		('abc' 'cd' 'abc')
	) do: [ :array | self assertUpToAll: array ]
! !

!ZnCharacterStreamTest methodsFor: 'testing' stamp: ''!
assertUpToAll: array
	| utf8Stream |
	utf8Stream := self utf8ReadStreamOn: array first.
	self assert: (array first readStream upToAll: array second) equals: array third.
	self assert: (utf8Stream upToAll: array second) equals: array third! !

!ZnCharacterStreamTest methodsFor: 'testing' stamp: ''!
testReadStream
	| stream |
	stream := ZnCharacterReadStream on: 'ABC' asByteArray readStream.
	self deny: stream atEnd.
	self deny: stream isBinary.
	self assert: stream next equals: $A.
	self deny: stream atEnd.
	self assert: stream peek equals: $B.
	self deny: stream atEnd.
	self assert: stream peek equals: $B.
	self deny: stream atEnd.
	self assert: stream next equals: $B.
	self deny: stream atEnd.
	self assert: stream next equals: $C.
	self assert: stream atEnd.
	self assert: stream next isNil.
	self assert: stream peek isNil! !

!ZnCharacterStreamTest methodsFor: 'testing' stamp: ''!
utf8ReadStreamOn: string
	^ ZnCharacterReadStream
		on: (ZnUTF8Encoder new encodeString: string) readStream
		encoding: #utf8! !

!ZnCharacterStreamTest methodsFor: 'testing' stamp: ''!
testNextLine
	| stream |
	stream := ZnCharacterReadStream on: 'abc' asByteArray readStream.
	self assert: stream nextLine equals: 'abc'.
	self assert: stream nextLine  equals: nil.
	stream := ZnCharacterReadStream on: '' asByteArray readStream.
	self assert: stream nextLine equals: nil.
	stream := ZnCharacterReadStream on: ({ 
		$a. Character cr. 
		$b. Character lf. 
		$c } collect: [:each | each charCode]) readStream.
	self assert: stream nextLine equals: 'a'.
	self assert: stream nextLine equals: 'b'.
	self assert: stream nextLine equals: 'c'.
	self assert: stream nextLine equals: nil.
	stream := ZnCharacterReadStream on: ({ 
		$a. Character cr. Character lf.  
		$b. Character cr. Character lf. 
		$c. Character cr. Character lf } collect: #charCode) readStream.
	self assert: stream nextLine equals: 'a'.
	self assert: stream nextLine equals: 'b'.
	self assert: stream nextLine equals: 'c'.
	self assert: stream nextLine equals: nil.
	stream := ZnCharacterReadStream on: ({ 
		$a. Character cr. Character lf.  
		Character cr. Character lf. 
		$c. Character cr. Character lf } collect: #charCode) readStream.
	self assert: stream nextLine equals: 'a'.
	self assert: stream nextLine equals: ''.
	self assert: stream nextLine equals: 'c'.
	self assert: stream nextLine equals: nil.
	! !

!ZnCharacterWriteStream commentStamp: ''!
I am ZnCharacterWriteStream.
I wrap another binary WriteStream and use a ZnCharacerEncoder to allow Characters to be written.

Part of Zinc HTTP Components.!
!ZnCharacterWriteStream methodsFor: 'accessing' stamp: ''!
tab
	self nextPut: Character tab! !

!ZnCharacterWriteStream methodsFor: 'accessing' stamp: ''!
cr
	self nextPut: Character cr! !

!ZnCharacterWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: object
	self encoder 
		nextPut: object 
		toStream: stream.
	^ object! !

!ZnCharacterWriteStream methodsFor: 'accessing' stamp: ''!
lf
	self nextPut: Character lf! !

!ZnCharacterWriteStream methodsFor: 'accessing' stamp: ''!
crlf
	self cr; lf! !

!ZnCharacterWriteStream methodsFor: 'accessing' stamp: ''!
space
	self nextPut: Character space! !

!ZnCharacterWriteStream methodsFor: 'accessing' stamp: ''!
print: object
	object printOn: self! !

!ZnCharacterWriteStream methodsFor: 'accessing' stamp: ''!
next: count putAll: collection startingAt: offset
	"Write count characters from collection starting at offset."
	
	self encoder 
		next: count 
		putAll: collection 
		startingAt: offset 
		toStream: stream ! !

!ZnChunkedReadStream commentStamp: ''!
I am ZnChunkedReadStream, implementing HTTP 1.1 chunked transfer encoding on a wrapped streams.

Clients should read me until I am atEnd.

After I am completely read, I can tell you my totalSize and optional extraHeaders.

Part of Zinc HTTP Components.!
!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
position
	^ self atEnd 
		ifTrue: [ totalSize ]
		ifFalse: [ totalSize - chunk size + position ]! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
peek
	self ensureChunkOrAtEnd.
	self atEnd ifTrue: [ ^ nil ].
	^ chunk at: (position + 1)! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount 
	"Read requestedCount elements into new collection and return it,
	 it could be that less elements were available"

	^ self 
		next: requestedCount 
		into: (self collectionSpecies new: requestedCount)! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
upToEnd
	"We use our own collectionSpecies and read by chunk"

	^ self collectionSpecies streamContents: [ :out |
		[ self atEnd ] whileFalse: [ 
			out next: limit putAll: chunk.
			position := limit ] ]! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection startingAt: offset
	"Read requestedCount elements into collection starting at offset,
	returning a copy if less elements are available"
	
	| readCount |
	readCount := self 
		readInto: collection 
		startingAt: offset 
		count: requestedCount.
	^ requestedCount = readCount
		ifTrue: [ collection ]
		ifFalse: [ collection copyFrom: 1 to: offset + readCount - 1 ]! !

!ZnChunkedReadStream methodsFor: 'testing' stamp: ''!
isBinary
	^ stream isBinary
! !

!ZnChunkedReadStream methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		nextPutAll: 'a '; 
		nextPutAll: self class name! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
contents
	"This is technically not correct, but it is better than nothing"
	
	^ self upToEnd! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
chunkCount
	^ chunkCount! !

!ZnChunkedReadStream methodsFor: 'testing' stamp: ''!
atEnd
	self ensureChunkOrAtEnd.
	^ atEnd! !

!ZnChunkedReadStream methodsFor: 'private' stamp: ''!
getNextChunk
	| size |
	(size := self getNextChunkSize) = 0
		ifTrue: [
			atEnd := true.
			chunk := position := limit := nil.
			self getExtraHeaders ]
		ifFalse: [
			totalSize := totalSize + size.
			chunkCount := chunkCount + 1.
			self ensureChunkBufferOfSize: size.  
			stream next: size into: chunk.
			stream next: 2. "consume CRLF"
			limit := size.
			position := 0 ]! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection
	"Read requestedCount elements into collection,
	returning a copy if less elements are available"
	
	^ self
		next: requestedCount
		into: collection
		startingAt: 1! !

!ZnChunkedReadStream methodsFor: 'initialization' stamp: ''!
reset
	"We don't allow it"! !

!ZnChunkedReadStream methodsFor: 'initialization' stamp: ''!
initialize
	atEnd := false.
	chunkCount := 0.
	totalSize := 0! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
binary
	stream binary! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
next
	self ensureChunkOrAtEnd.
	self atEnd ifTrue: [ ^ nil ].
	^ chunk at: (position := position + 1)! !

!ZnChunkedReadStream methodsFor: 'private' stamp: ''!
ensureChunkBufferOfSize: size
	(chunk notNil and: [ size <= chunk size ]) ifTrue: [ ^ self ].  
	chunk := self collectionSpecies new: size.
! !

!ZnChunkedReadStream methodsFor: 'initialize-release' stamp: ''!
on: readStream
	stream := readStream! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
collectionSpecies
	^ self isBinary ifTrue: [ ByteArray ] ifFalse: [ String ]
	! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
totalSize
	^ totalSize! !

!ZnChunkedReadStream methodsFor: 'private' stamp: ''!
getExtraHeaders
	extraHeaders := ZnHeaders readFrom: stream! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
skip: count
	count timesRepeat: [ self next ]! !

!ZnChunkedReadStream methodsFor: 'private' stamp: ''!
ensureChunkOrAtEnd
	atEnd 
		ifTrue: [ ^ self ].
	(chunk isNil or: [ position >= limit ]) 
		ifTrue: [ self getNextChunk ]
! !

!ZnChunkedReadStream methodsFor: 'private' stamp: ''!
getNextChunkSize
	| line |
	(line := (ZnLineReader on: stream) nextLine) isEmpty ifTrue: [ ^ 0 ].
	^ Integer readFrom: (line copyUpTo: $;) base: 16! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
readInto: collection startingAt: offset count: requestedCount
	"Read requestedCount elements into collection starting at offset.
	Return the actual number of elements read."

	| read toRead |
	read := 0.
	[ read < requestedCount and: [ self atEnd not] ] whileTrue: [
		toRead := (limit - position) min: (requestedCount - read).
		collection 
			replaceFrom: offset + read 
			to: offset + read + toRead - 1 
			with: chunk 
			startingAt: position + 1.
		read := read + toRead.
		position := position + toRead ].
	^ read! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
match: subCollection
	"Try to read and match the elements of subCollection. 
	If successful return true and leave the me positioned after the match.
	If unsuccesful return false and leave me at end."
	
	| buffer pattern bufferPosition bufferLimit |
	pattern := subCollection readStream.
	"we have to use an internal buffer because we are not positionable"
	buffer := subCollection species new: subCollection size.
	bufferPosition := bufferLimit := 0.
	[ pattern atEnd ] whileFalse: [ | nextElement |
		self atEnd ifTrue: [ ^ false ].
		"get the next char to match either from the buffer or from the stream while buffering it"
		(bufferPosition < bufferLimit) 
			ifTrue: [ 
				nextElement := buffer at: bufferPosition + 1 ]
			ifFalse: [
				nextElement := buffer at: bufferPosition + 1 put: self next.
				bufferLimit := bufferLimit + 1 ].
		bufferPosition := bufferPosition + 1.
		pattern next = nextElement
			ifFalse: [
				"shift the buffer down one element and restart"
				2 to: bufferLimit do: [ :each |
					buffer at: each - 1 put: (buffer at: each) ].
				bufferLimit := bufferLimit - 1.
				bufferPosition := 0.
				pattern position: 0 ] ].
	^ true! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
upTo: anObject 
	"We use our own collectionSpecies."
	
	^ self collectionSpecies streamContents: [ :out | | element |
		[ self atEnd or: [ (element := self next) = anObject ] ]
			whileFalse: [ out nextPut: element ] ]! !

!ZnChunkedReadStream methodsFor: 'accessing' stamp: ''!
extraHeaders
	^ extraHeaders! !

!ZnChunkedReadStream class methodsFor: 'instance creation' stamp: ''!
new
	^ super new initialize! !

!ZnChunkedReadStream class methodsFor: 'instance creation' stamp: ''!
on: stream
	^ self basicNew
		initialize;
		on: stream;
		yourself! !

!ZnChunkedStreamTest methodsFor: 'testing' stamp: ''!
testReading
	| data chunked plain |
	data := String withAll: ($a to: $z), ($A to: $Z).
	chunked := String streamContents: [ :stream |
		self nextPutAll: data on: stream chunked: 16 ].
	plain := (ZnChunkedReadStream on: chunked readStream) upToEnd.
	self assert: plain equals: data! !

!ZnChunkedStreamTest methodsFor: 'testing' stamp: ''!
testReadingBuffered
	| data chunked plain buffer readStream |
	data := String withAll: ($a to: $z), ($A to: $Z).
	chunked := String streamContents: [ :stream |
		self nextPutAll: data on: stream chunked: 16 ].
	readStream := ZnChunkedReadStream on: chunked readStream.
	buffer := String new: 11.
	plain := String streamContents: [ :output | | readCount |
		[ readStream atEnd ] whileFalse: [
			readCount := readStream readInto: buffer startingAt: 1 count: buffer size.
			output next: readCount putAll: buffer ] ].
	self assert: plain equals: data! !

!ZnChunkedStreamTest methodsFor: 'testing' stamp: ''!
testReadingGzipStepped
	| data gzipped chunked unchunked ungzipped |
	data := String withAll: ($a to: $z), ($A to: $Z).
	gzipped := String streamContents: [ :stream |
		(GZipWriteStream on: stream) nextPutAll: data; close ].
	chunked := String streamContents: [ :stream |
		self nextPutAll: gzipped on: stream chunked: 16 ].
	unchunked := (ZnChunkedReadStream on: chunked readStream) upToEnd.
	ungzipped := (GZipReadStream on: unchunked) upToEnd.
	self assert: gzipped equals: unchunked.
	self assert: data equals: ungzipped ! !

!ZnChunkedStreamTest methodsFor: 'testing' stamp: ''!
testGzipWriteRead
	| data written read |
	data := String streamContents: [ :out |
		{ Collection. Stream. Exception. Magnitude } do: [ :cls |
			cls allSubclassesDo: [ :each | out nextPutAll: each comment ] ] ].
	data := data asByteArray.
	written := ByteArray streamContents: [ :out |
		| stream chunkedStream |
		stream := GZipWriteStream on: (chunkedStream := ZnChunkedWriteStream on: out).
		stream nextPutAll: data.
		stream finish.
		chunkedStream finish ].
	read := (GZipReadStream on: (ZnChunkedReadStream on: written readStream)) upToEnd.
	self assert: read equals: data! !

!ZnChunkedStreamTest methodsFor: 'testing' stamp: ''!
testBinaryWriteRead
	| data written read |
	data := ByteArray new: 1024 streamContents: [ :out |
		1024 timesRepeat: [ out nextPut: 256 atRandom - 1 ] ].
	written := ByteArray streamContents: [ :out |
		| stream |
		stream := ZnBufferedWriteStream on: (ZnChunkedWriteStream on: out).
		stream sizeBuffer: 256.
		1 to: 1024 by: 256 do: [ :each |
			stream next: 256 putAll: data startingAt: each ].
		stream close ].
	read := (ZnChunkedReadStream on: written readStream) upToEnd.
	self assert: read equals: data! !

!ZnChunkedStreamTest methodsFor: 'testing' stamp: ''!
testReadingNext
	| data chunked plain |
	data := String withAll: ($a to: $z), ($A to: $Z).
	chunked := String streamContents: [ :stream |
		self nextPutAll: data on: stream chunked: 16 ].
	plain := (ZnChunkedReadStream on: chunked readStream) next: 26 + 26.
	self assert: plain equals: data! !

!ZnChunkedStreamTest methodsFor: 'private' stamp: ''!
nextPutAll: collection on: stream chunked: size
	| written |
	written := 0.
	[ written < collection size ] whileTrue: [ | chunkSize |
		chunkSize := size min: (collection size - written).
		chunkSize printOn: stream base: 16.
		stream nextPutAll: String crlf.
		chunkSize timesRepeat: [ stream nextPut: (collection at: (written := written + 1)) ].
		stream nextPutAll: String crlf ].
	stream print: 0; nextPutAll: String crlf; nextPutAll: String crlf! !

!ZnChunkedStreamTest methodsFor: 'testing' stamp: ''!
testReadingNextInto
	| data chunked plain |
	data := String withAll: ($a to: $z), ($A to: $Z).
	chunked := String streamContents: [ :stream |
		self nextPutAll: data on: stream chunked: 16 ].
	plain := String new: 26 + 26.
	(ZnChunkedReadStream on: chunked readStream) next: 26 + 26 into: plain.
	self assert: plain equals: data! !

!ZnChunkedStreamTest methodsFor: 'testing' stamp: ''!
testWritingBuffered
	| data written read |
	data := String withAll: ($a to: $z), ($A to: $Z).
	written := String streamContents: [ :out |
		| stream |
		stream := ZnBufferedWriteStream on: (ZnChunkedWriteStream on: out).
		stream sizeBuffer: 16.
		stream nextPutAll: data.
		stream close ].
	read := (ZnChunkedReadStream on: written readStream) upToEnd.
	self assert: read equals: data! !

!ZnChunkedStreamTest methodsFor: 'testing' stamp: ''!
testReadingGzip
	| data gzipped chunked plain |
	data := String withAll: ($a to: $z), ($A to: $Z).
	gzipped := String streamContents: [ :stream |
		(GZipWriteStream on: stream) nextPutAll: data; close ].
	chunked := String streamContents: [ :stream |
		self nextPutAll: gzipped on: stream chunked: 16 ].
	plain := (GZipReadStream on: (ZnChunkedReadStream on: chunked readStream)) upToEnd.
	self assert: data equals: plain ! !

!ZnChunkedStreamTest methodsFor: 'testing' stamp: ''!
testWriting
	| chunks result reference |
	chunks := #( 'ABC' 'DEF' 'GHI' 'JKL' ).
	result := String streamContents: [ :out |
		| stream |
		stream := ZnChunkedWriteStream on: out.
		chunks do: [ :each | stream nextPutAll: each ].
		stream finish ].
	reference := String streamContents: [ :out |
		self nextPutAll: (String new join: chunks) on: out chunked: 3 ].
	self assert: result equals: reference! !

!ZnChunkedWriteStream commentStamp: ''!
I am ZnChunkedWriteStream, I wrap another write stream and add HTTP 1.1 chunked transfer encoding.

I write a chunk for each #nextPutAll: or #next:putAll:startingAt:
I should be wrapped in a ZnBufferedWriteStream for #next: to work.
When done, send #close or #finish to me.

Part of Zinc HTTP Components.
!
!ZnChunkedWriteStream methodsFor: 'accessing' stamp: ''!
position
	^ totalSize! !

!ZnChunkedWriteStream methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	totalSize := 0.
	chunkCount := 0! !

!ZnChunkedWriteStream methodsFor: 'initialize-release' stamp: ''!
binary
	stream binary! !

!ZnChunkedWriteStream methodsFor: 'initialize-release' stamp: ''!
on: writeStream
	stream := writeStream! !

!ZnChunkedWriteStream methodsFor: 'testing' stamp: ''!
isBinary
	^ stream isBinary
! !

!ZnChunkedWriteStream methodsFor: 'accessing' stamp: ''!
next: count putAll: collection startingAt: offset
	self writeChunkSize: count.
	stream next: count putAll: collection startingAt: offset.
	self crlf.
	chunkCount := chunkCount + 1.
	totalSize := totalSize + count
! !

!ZnChunkedWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: element
	self error: 'Wrap me into a buffered stream, because each #nexPut: will create a new chunk'! !

!ZnChunkedWriteStream methodsFor: 'initialize-release' stamp: ''!
finish
	self writeChunkSize: 0.
	self crlf.
	extraHeaders ifNotNil: [ extraHeaders writeOn: stream ]! !

!ZnChunkedWriteStream methodsFor: 'private' stamp: ''!
writeChunkSize: size
	stream nextPutAll: (self isBinary ifTrue: [ size printStringHex asByteArray ] ifFalse: [ size printStringHex ]).
	self crlf! !

!ZnChunkedWriteStream methodsFor: 'initialize-release' stamp: ''!
close
	self finish.
	stream close! !

!ZnChunkedWriteStream methodsFor: 'accessing' stamp: ''!
chunkCount
	^ chunkCount! !

!ZnChunkedWriteStream methodsFor: 'initialize-release' stamp: ''!
flush
	stream flush! !

!ZnChunkedWriteStream methodsFor: 'private' stamp: ''!
crlf
	stream nextPutAll: (self isBinary ifTrue: [ #[ 13 10 ] ] ifFalse: [ String crlf ])! !

!ZnChunkedWriteStream methodsFor: 'accessing' stamp: ''!
extraHeaders
	^ extraHeaders ifNil: [ extraHeaders := ZnHeaders new ]! !

!ZnChunkedWriteStream methodsFor: 'accessing' stamp: ''!
next: count putAll: collection
	self 
		next: count 
		putAll: collection 
		startingAt: 1! !

!ZnChunkedWriteStream methodsFor: 'testing' stamp: ''!
isStream
	^ true! !

!ZnChunkedWriteStream methodsFor: 'accessing' stamp: ''!
nextPutAll: collection
	self 
		next: collection size
		putAll: collection
		startingAt: 1! !

!ZnChunkedWriteStream class methodsFor: 'instance creation' stamp: ''!
on: writeStream
	^ self new
		on: writeStream;
		yourself! !

!ZnClient commentStamp: ''!
I am ZnClient, an object to build, execute and process HTTP client requests.

I have a rich protocol to construct requests and to access responses.
I have various error handling options.
I can reuse an existing connection to a specific host:port.
I handle sessions, cookies, redirects and authentication.
I have many options (settings) with sensible defaults.

Simplest possible invocation:

	ZnClient new
		get: 'http://zn.stfx.eu/zn/numbers.txt'.
	
Using some features to make a better HTTP request:

	ZnClient new
		systemPolicy;
		accept: ZnMimeType textPlain;
		http;
		host: 'zn.stfx.eu';
		path: 'zn/numbers.txt';
		contentReader: [ :entity | entity contents lines collect: [ :each | each asNumber ] ];
		ifFail: [ :exception | self inform: 'I am sorry: ', exception printString ];
		get.

Part of Zinc HTTP Components.!
!ZnClient methodsFor: 'private' stamp: ''!
newConnectionTo: url
	| initialMilliseconds |
	self signalHTTPProgress: 'Connecting to ',  url authority.
	initialMilliseconds := Time millisecondClockValue.
	(connection notNil and: [ connection isConnected ]) 
		ifTrue: [ connection close ].
	connection := ZnNetworkingUtils socketStreamToUrl: url.
	url hasSecureScheme
		ifTrue: [ self setupTLSTo: url ].
	self logConnectionEstablishedTo: url started: initialMilliseconds! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
redirectUrl
	"We support relative locations although they are not the standard (http://en.wikipedia.org/wiki/HTTP_location)"

	| redirectUrl |
	redirectUrl := response location asZnUrl.
	^ redirectUrl isAbsolute
		ifTrue: [ redirectUrl ]
		ifFalse: [ redirectUrl inContextOf: request url ]! !

!ZnClient methodsFor: 'private' stamp: ''!
withMaximumNumberOfDictionaryEntriesDo: block
	^ self maximumNumberOfDictionaryEntries = ZnMaximumNumberOfDictionaryEntries value
			ifTrue: block
			ifFalse: [ 
				ZnMaximumNumberOfDictionaryEntries 
					value: self maximumNumberOfDictionaryEntries 
					during: block ]! !

!ZnClient methodsFor: 'convenience' stamp: ''!
put: url contents: object
	"Execute an HTTP PUT request on url with object as request #contents:
	and return the response #contents."

	^ self 
		url: url; 
		contents: object; 
		put! !

!ZnClient methodsFor: 'options' stamp: ''!
maximumEntitySize
	"Return the maximum entity size in bytes that I will read from a stream before signalling ZnEntityTooLarge"
	
	^ self optionAt: #maximumEntitySize ifAbsent: [ ZnMaximumEntitySize value ]! !

!ZnClient methodsFor: 'options' stamp: ''!
enforceHttpSuccess
	"Return whether or not I enforce that the response 
	to the request is an HTTP success code."
	
	^ self optionAt: #enforceHttpSuccess ifAbsent: [ false ]! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
getConnectionAndExecute
	self canReuseConnection 
		ifTrue: [ 
			[ ^ self executeRequestResponse; cleanupConnection ] 
				on: Exception 
				do: [ :exception | self logIgnoringExceptionOnReusedConnection: exception; close ] ].
	self newConnectionTo: request url.
	[ self executeRequestResponse ]
		ensure: [ self cleanupConnection ]! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
addPathSegment: pathSegment
	"Extend the path of the current request with a single pathSegment."
	
	request url 
		ifNil: [ request url: (ZnUrl new addPathSegment: pathSegment; yourself) ]
		ifNotNil: [ request url addPathSegment: pathSegment ]  ! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
headerAddAll: keyedCollection
	"Add all key/value pairs of keyedCollection as headers.
	Note that #addAllMulti: is used"
	
	request headers 
		addAll: keyedCollection ! !

!ZnClient methodsFor: 'options' stamp: ''!
ifFail: block
	"Set the block that will be executed if the request fails.
	The exception of the failure will be passed as argument."
	
	self optionAt: #ifFailBlock put: block! !

!ZnClient methodsFor: 'options' stamp: ''!
retryDelay
	"Return the number of seconds I will delay retrying a failed request,
	provided I do retry requests. Defaults to 1 seconds."
	
	^ self optionAt: #retryDelay ifAbsent: [ 1 ]! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
executeWithRedirectsRemaining: redirectCount
	self getConnectionAndExecute.
	response isRedirect 
		ifTrue: [
			(redirectCount > 0 and: [ self followRedirects ])
				ifTrue: [
					self 
						prepareRedirect; 
						executeWithRedirectsRemaining: redirectCount - 1 ]
				ifFalse: [
					self followRedirects 
						ifTrue: [ ZnTooManyRedirects signal ] ] ].
	^ self handleResponse
	! !

!ZnClient methodsFor: 'options' stamp: ''!
certificate
	"Return the TLS/SSL certificate to be used, or nil for none."
	
	^ self optionAt: #certificate ifAbsent: [ nil ]! !

!ZnClient methodsFor: 'accessing - response' stamp: ''!
contents 
	"Answer the contents or HTTP payload of the last response, 
	assuming the current request was executed.
	If I have a contentReader, it will be used to compute the contents.
	Otherwise I delegate to ZnResponse>>#contents, unless I am #streaming,
	in which case I return the stream of the streaming entity."

	^ response ifNotNil: [ 
		self contentReader 
			ifNil: [ 
				self streaming
					ifTrue: [  response entity stream ]
					ifFalse: [ response contents ] ]
			ifNotNil: [ :reader | reader value: response entity ] ]  ! !

!ZnClient methodsFor: 'options' stamp: ''!
enforceAcceptContentType: boolean
	"Set whether or not I enforce that the content type of the
	response matches the content type specified in the accept request
	header to boolean."

	self optionAt: #enforceAcceptContentType put: boolean! !

!ZnClient methodsFor: 'testing' stamp: ''!
isConnected
	"Return true if I hold an open HTTP connection."

	^ connection notNil and: [ connection isConnected ]! !

!ZnClient methodsFor: 'options' stamp: ''!
reader
	"Return a block that when given a stream reads a response from it."
	
	^ self optionAt: #reader ifAbsentPut: [ [ :stream | ZnResponse readFrom: stream ] ]! !

!ZnClient methodsFor: 'convenience' stamp: ''!
downloadTo: path
	"Setup streaming, do a GET request and download the entity directly to a file.
	If path describes a file, use that. 
	If path describes a directory, use the last path segment of the URI to construct a file in that directory.
	The URI of the first request is used, which could make a difference when following redirects.
	Return true when successful, false otherwise."

	| target |
	target := ZnFileSystemUtils downloadPathTo: path for: self request uri lastPathSegment.
	self
		streaming: true;
		get.
	^ self isSuccess
		ifTrue: [ 
			self downloadEntityTo: target.
			true ]
		ifFalse: [ false ]! !

!ZnClient methodsFor: 'private' stamp: ''!
canReuseConnection
	self isConnected ifFalse: [ ^ false ].
	lastUsed ifNil: [ ^ false ].
	^ Time totalSeconds - lastUsed < self connectionReuseTimeout! !

!ZnClient methodsFor: 'options' stamp: ''!
maxNumberOfRedirects
	"Return the maximum number of HTTP redirect that will be followed.
	Note that when the #followsRedirect option is false, 
	no redirects will ever be followed regardless of the value of this option.
	Defaults to 5. A ZnTooManyRedirects will be signalled when the count reaches zero."

	^ self optionAt: #maxNumberOfRedirects ifAbsent: [ 5 ]! !

!ZnClient methodsFor: 'private - logging' stamp: ''!
newLogEvent: logEventClass
	^ logEventClass new
		clientId: self clientId;
		yourself! !

!ZnClient methodsFor: 'logging' stamp: ''!
loggingOff
	"Turn logging completely off - do not generate log events."
	
	self logLevel: 0! !

!ZnClient methodsFor: 'operations' stamp: ''!
delete
	"Execute a HTTP DELETE ont the request set up and return the response #contents."
	
	^ self 
		method: #DELETE; 
		execute! !

!ZnClient methodsFor: 'convenience' stamp: ''!
options: url
	"Execute an HTTP OPTIONS request on url and return the response #contents."

	^ self 
		url: url; 
		options! !

!ZnClient methodsFor: 'private - logging' stamp: ''!
logRetrying: exception
	logLevel < 3 ifTrue: [ ^ nil ].
	^ (self newLogEvent: ZnClientRetryingEvent)
		exception: exception;
		emit! !

!ZnClient methodsFor: 'private' stamp: ''!
receiveCookies
	response cookies do: [ :each |
		each defaultDomain: request url host.
		self session cookieJar add: each ]! !

!ZnClient methodsFor: 'options' stamp: ''!
timeout: seconds
	"Set the timeout for network socket stream operations
	like connecting, reading and writing to seconds."

	self optionAt: #timeout put: seconds! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
https
	"Set the scheme of the current request to HTTPS."
	
	self url: (ZnUrl new scheme: #https; yourself)! !

!ZnClient methodsFor: 'initialization' stamp: ''!
debugPolicy
	self 
		beOneShot! !

!ZnClient methodsFor: 'accessing' stamp: ''!
optionAt: key put: value
	"Set my option/setting identified by key to be value.
	This is a generic interface, see my options protocol for specific usages."
	
	options ifNil: [ options := Dictionary new ].
	options at: key put: value! !

!ZnClient methodsFor: 'options' stamp: ''!
clientId
	"Return the id for this HTTP client. Defaults to nil.
	Can be used identify different clients' log events."
	
	^ self optionAt: #clientId ifAbsent: [ nil ]! !

!ZnClient methodsFor: 'private' stamp: ''!
withDefaultCharacterEncoderDo: block
	^ self defaultEncoder = ZnDefaultCharacterEncoder value
			ifTrue: block
			ifFalse: [ 
				ZnDefaultCharacterEncoder 
					value: self defaultEncoder  
					during: block ]! !

!ZnClient methodsFor: 'options' stamp: ''!
defaultEncoder
	"The default character encoder to use when none is set in a mime-type"
	
	^ self optionAt: #defaultEncoder ifAbsent: [ ZnDefaultCharacterEncoder value ] ! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
formAdd: association
	"Add the key->value association to the application/x-www-form-urlencoded 
	entity of the current request."
	
	self applicationFormUrlEncodedEntity 
		add: association ! !

!ZnClient methodsFor: 'options' stamp: ''!
isOneShot
	"Return if I use connections only for a single request/response cycle.
	By default, I will keep HTTP connections open according to the HTTP 1.1 spec.
	When oneShot is true, I will add a Connection: close header to requests."

	^ self optionAt: #oneShot ifAbsent: [ false ]! !

!ZnClient methodsFor: 'operations' stamp: ''!
post
	"Execute a HTTP POST on the request set up and return the response #contents."

	^ self 
		method: #POST; 
		execute! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
formAt: key add: value
	"Add key equals value to the application/x-www-form-urlencoded 
	entity of the current request. This is for multi-values form fields."

	self applicationFormUrlEncodedEntity 
		at: key add: value! !

!ZnClient methodsFor: 'options' stamp: ''!
maximumEntitySize: integer
	"Set the maximum entity size in bytes that I will read from a stream before signalling ZnEntityTooLarge"
	
	^ self optionAt: #maximumEntitySize put: integer! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
method: httpMethod
	"Set the HTTP method of the current request to httpMethod.
	An uppercase symbol such as #GET is expected.
	Note that for all methods in #autoResetEntityMethods #resetEntity is called automatically,
	since you don't want the entity of a previous request to be sent again"

	(self autoResetEntityMethods includes: httpMethod)
		ifTrue: [ self resetEntity ].
	request method: httpMethod! !

!ZnClient methodsFor: 'convenience' stamp: ''!
delete: url
	"Execute an HTTP DELETE request on url and return the response #contents."
	
	^ self 
		url: url; 
		delete! !

!ZnClient methodsFor: 'options' stamp: ''!
certificate: anObject
	"Set the TLS/SSL certificate to be used to anObject, or nil for none.
	See ZdcAbstractSSLSession>>#certificateName: for more information."
	
	^ self optionAt: #certificate put: anObject! !

!ZnClient methodsFor: 'accessing' stamp: ''!
optionAt: key ifAbsentPut: block
	"Return my option/settings stored under key.
	If I have no such option/setting, store the result of evaluating block as new value and return it.
	This is a generic interface, see my options protocol for specific usages."

	options ifNil: [ options := Dictionary new ].
	^ options at: key ifAbsentPut: block! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
formAt: key put: value
	"Set key equal to value in the application/x-www-form-urlencoded 
	entity of the current request."

	self applicationFormUrlEncodedEntity 
		at: key put: value! !

!ZnClient methodsFor: 'options' stamp: ''!
prepareRequestHook
	"Return the current request preparation hook, an object conforming 
	to the #value: protocol that gets the final chance to change a request 
	right before it gets executed. Defaults to nil.
	Typically used to sign requests. See also #prepareRequest: "

	^ self optionAt: #prepareRequestHook ifAbsent: [ nil ]! !

!ZnClient methodsFor: 'logging' stamp: ''!
logLevel: integer
	"Set the log level to integer.
	0 - no logging
	1 - simplified transaction logging
	2 - detailed transaction logging
	3 - log everything"
	
	logLevel := integer! !

!ZnClient methodsFor: 'options' stamp: ''!
connectionReuseTimeout: seconds
	"Set the timeout used to determine if I should try 
	to reuse an open connection to seconds."

	self optionAt: #connectionReuseTimeout put: seconds! !

!ZnClient methodsFor: 'accessing' stamp: ''!
optionAt: key ifAbsent: block
	"Return my option/settings stored under key.
	Execute block if I have no such option/setting.
	This is a generic interface, see my options protocol for specific usages."

	options ifNil: [ ^ block value ].
	^ options at: key ifAbsent: block! !

!ZnClient methodsFor: 'options' stamp: ''!
reader: block
	"Customize how responses are read from a stream, see #reader, see #beBinary"
	
	self optionAt: #reader put: block! !

!ZnClient methodsFor: 'options' stamp: ''!
signalProgress: boolean
	"Set whether I will signal HTTPProgress notifications during execution to boolean."
	
	self optionAt: #signalProgress put: boolean! !

!ZnClient methodsFor: 'options' stamp: ''!
maxNumberOfRedirects: count
	"Set the maximum number of HTTP redirect that will be followed to count.
	Note that when the #followsRedirect option is false, 
	no redirects will ever be followed regardless of the value of this option.
	A ZnTooManyRedirects will be signalled when the count reaches zero."

	self optionAt: #maxNumberOfRedirects put: count! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
headerAt: key put: value
	"Set key equals value in the HTTP header of the current request"
	
	request headers 
		at: key put: value   ! !

!ZnClient methodsFor: 'options' stamp: ''!
contentReader
	"Return the current content reader, an object conforming 
	to the #value: protocol to convert a response entity
	as used by #contents. Defaults to nil.
	Can be used to parse incoming data."
	
	^ self optionAt: #contentReader ifAbsent: [ nil ]! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
prepareNextRequest
	"The request could be modified destructively in the next run,
	but the request can also be part of a log event, hence copy it"
	request := request copy	
! !

!ZnClient methodsFor: 'private - logging' stamp: ''!
logRequestWrittenStarted: initialMilliseconds
	^ logLevel < 3
		ifTrue: [ Time millisecondsSince: initialMilliseconds ]
		ifFalse: [ 
			(self newLogEvent: ZnRequestWrittenEvent)
				request: request;
				duration: (Time millisecondsSince: initialMilliseconds);
				emit;
				duration ]! !

!ZnClient methodsFor: 'options' stamp: ''!
connectionReuseTimeout
	"Return the timeout in seconds currently used to determine
	if I should try to reuse an open connection. Defaults to 10 seconds."

	^ self optionAt: #connectionReuseTimeout ifAbsent: [ 10 ]! !

!ZnClient methodsFor: 'options' stamp: ''!
ifFailBlock
	"Return the block that I should execute if the request fails.
	Defaults to #pass-ing the exception up. 
	Accepts an exception as argument."
	
	^ self optionAt: #ifFailBlock ifAbsentPut: [ [ :exception | exception pass ] ]! !

!ZnClient methodsFor: 'testing' stamp: ''!
isCreated
	"Return true it the last executed HTTP request returned an HTTP created response code."
	
	^ response 
		ifNil: [ self error: 'Request not yet executed' ]
		ifNotNil: [ response isCreated ]! !

!ZnClient methodsFor: 'operations' stamp: ''!
head
	"Execute a HTTP HEAD on the request set up and return nil."

	^ self 
		method: #HEAD; 
		execute! !

!ZnClient methodsFor: 'options' stamp: ''!
autoResetEntityMethods
	"Return a collection of HTTP methods for which to auto #resetEntity.
	The default is to do this only for HEAD and DELETE, although most people 
	would want it for GET too, but this can be used for forms"
	
	^ self optionAt: #autoResetEntityMethods ifAbsentPut: [ #(HEAD DELETE) ]! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
contents: object
	"Set the entity contents of the current request to object.
	I will pass this through my contentWriter if I have one.
	Otherwise I delegate to ZnEntity to convert object to a generic entity."
	
	self contentWriter 
		ifNil: [ self entity: (ZnEntity with: object) ]
		ifNotNil: [ :writer | self entity: (writer value: object) ]! !

!ZnClient methodsFor: 'initialization' stamp: ''!
interactivePolicy
	self 
		beOneShot;
		ifFail: [ :exception | 
			self inform: 'HTTP call failed with ', exception printString.
			nil ]! !

!ZnClient methodsFor: 'options' stamp: ''!
retryDelay: seconds
	"Set the delay before I will delay retrying a failed request to seconds,
	provided I do retry requests."

	self optionAt: #retryDelay put: seconds! !

!ZnClient methodsFor: 'testing' stamp: ''!
isNotFound
	"Return true it the last executed HTTP request returned an HTTP not found response code."
	
	^ response 
		ifNil: [ self error: 'Request not yet executed' ]
		ifNotNil: [ response isNotFound ]! !

!ZnClient methodsFor: 'operations' stamp: ''!
put
	"Execute a HTTP PUT on the request set up and return the response #contents."

	^ self 
		method: #PUT; 
		execute! !

!ZnClient methodsFor: 'options' stamp: ''!
prepareRequest: hook
	"Set the current request preparation hook, an object conforming 
	to the #value: protocol that gets the final chance to change a request 
	right before it gets executed. Defaults to nil.
	Typically used to sign requests. See also #prepareRequestHook "

	^ self optionAt: #prepareRequestHook put: hook! !

!ZnClient methodsFor: 'options' stamp: ''!
autoResetEntityMethods: methods
	"Set the collection of HTTP methods for which to auto #resetEntity.
	The default is to do this only for HEAD and DELETE, although most people 
	would want it for GET too, but this can be used for forms"
	
	^ self optionAt: #autoResetEntityMethods put: methods! !

!ZnClient methodsFor: 'convenience' stamp: ''!
patch: url contents: object
	"Execute an HTTP PATCH request on url with object as request #contents:
	and return the response #contents."

	^ self 
		url: url; 
		contents: object; 
		patch! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
queryAddAll: keyedCollection
	"Add all key -> value elements of keyedCollection 
	as HTTP query parameters to the current request.
	Note that #queryAt:add: is used to preserve duplicate keys."

	keyedCollection keysAndValuesDo: [ :key :value |
		self queryAt: key add: value ]! !

!ZnClient methodsFor: 'options' stamp: ''!
followRedirects: boolean
	"Set whether or not I will automatically following of HTTP redirects.
	This is still subject to #maxNumberOfRedirects. Defaults to true.
	When set to false, redirects will be returned as normal responses."

	self optionAt: #followRedirects put: boolean ! !

!ZnClient methodsFor: 'convenience' stamp: ''!
get: url
	"Execute an HTTP GET request on url and return the response #contents."

	^ self 
		url: url; 
		get! !

!ZnClient methodsFor: 'private - logging' stamp: ''!
logConnectionClosedAddress: address port: port
	logLevel < 3 ifTrue: [ ^ nil ].
	^ (self newLogEvent: ZnClientConnectionClosedEvent)
		address: address;
		port: port;
		emit! !

!ZnClient methodsFor: 'private' stamp: ''!
sendCookies
	| cookies cookiesString |
	session ifNil: [ ^ self ].
	cookies := (session cookieJar cookiesForUrl: request url).
	cookies isEmpty ifTrue: [ ^ self ]. 
	cookiesString := String streamContents: [ :stream |
		cookies
			do: [ :each | each writeNameAndValueOn: stream ]
			separatedBy: [ stream nextPutAll: '; ' ] ].
	request setCookie: cookiesString! !

!ZnClient methodsFor: 'accessing' stamp: ''!
connection
	"Return the socket stream connection that I am currently using"
	
	^ connection! !

!ZnClient methodsFor: 'operations' stamp: ''!
patch
	"Execute a HTTP PATCH on the request set up and return the response #contents."

	^ self 
		method: #PATCH; 
		execute! !

!ZnClient methodsFor: 'options' stamp: ''!
streaming: boolean
	"Set whether I will return streaming response objects (see ZnStreamingEntity) to boolean.
	If true, my users are responsible for actually reading the incoming response entity data stream.
	I cannot do streaming when #isOneShot is true because the stream would be closed too soon."

	(boolean and: [ self isOneShot ])
		ifTrue: [ self error: 'I cannot do streaming when #isOneShot is true.' ].
	self optionAt: #streaming put: boolean! !

!ZnClient methodsFor: 'options' stamp: ''!
defaultEncoder: encoder
	"Set the default character encoder to use when none is set in a mime-type"
	
	^ self optionAt: #defaultEncoder put: encoder asZnCharacterEncoder! !

!ZnClient methodsFor: 'private - logging' stamp: ''!
logClientTransactionRequestDuration: requestDuration responseDuration: responseDuration
	| logEventClass |
	logLevel < 1 ifTrue: [ ^ nil ].
	logEventClass := logLevel = 1
		ifTrue: [ ZnSimplifiedClientTransactionEvent ]
		ifFalse: [ ZnClientTransactionEvent ].
	^ (self newLogEvent: logEventClass)
		request: request;
		requestDuration: requestDuration;
		response: response; 
		responseDuration: responseDuration;
		emit;
		yourself! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
accept: mimeTypeObject
	"Set the Accept HTTP header to mimeTypeObject for the current request."

	| mimeType |
	mimeType := mimeTypeObject asZnMimeType.
	self request setAccept: mimeType! !

!ZnClient methodsFor: 'testing' stamp: ''!
isRedirect
	"Return true it the last executed HTTP request returned an HTTP redirect response code."
	
	^ response 
		ifNil: [ self error: 'Request not yet executed' ]
		ifNotNil: [ response isRedirect ]! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
queryAt: key add: value 
	"Modify the receiver by adding a query variable key=value.
	If key already exists, value is added to it."

	request url 
		ifNil: [ request url: (ZnUrl new queryAt: key add: value; yourself) ]
		ifNotNil: [ request url queryAt: key add: value ]  ! !

!ZnClient methodsFor: 'options' stamp: ''!
followRedirects
	"Return whether I will automatically following of HTTP redirects.
	This is still subject to #maxNumberOfRedirects. Defaults to true.
	When set to false, redirects will be returned as normal responses."

	^ self optionAt: #followRedirects ifAbsent: [ true ]! !

!ZnClient methodsFor: 'accessing' stamp: ''!
session
	"Return the current HTTP session object that I am using.
	This session object holds cookies among other things."

	^ session ifNil: [ session := ZnUserAgentSession new ]! !

!ZnClient methodsFor: 'convenience' stamp: ''!
head: url
	"Execute an HTTP HEAD request on url and return nil."

	^ self 
		url: url; 
		head! !

!ZnClient methodsFor: 'private' stamp: ''!
validateConnectionForHost: host port: port
	(connection isNil or: [ request url isNil ]) 
		ifTrue: [ ^ self ].
	(request url host = host and: [ request url port = port ])
		ifFalse: [ self close ]  ! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
executeWithTimeout
	^ self withTimeoutDo: [ 
		[ self executeWithRetriesRemaining: self numberOfRetries ]
			on: Error
			do: self ifFailBlock ]! !

!ZnClient methodsFor: 'accessing - response' stamp: ''!
response 
	"Answer the last response, assuming the current request was executed."

	^ response ! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
path: pathString
	"Set the path of the current request to pathString.
	The argument will be merged with of the current/previous request."
	
	self url: pathString! !

!ZnClient methodsFor: 'operations' stamp: ''!
execute
	"Execute the currently set up request to generate a response.
	Return the #contents of the response, if any."

	| result |
	self prepareRequest.
	self withProgressDo: [ result := self executeWithTimeout ].
	self prepareNextRequest.
	^ result! !

!ZnClient methodsFor: 'accessing - response' stamp: ''!
entity
	"Answer the entity or HTTP payload of the last response, 
	assuming the current request was executed."
	
	^ response ifNotNil: [ response entity ]  ! !

!ZnClient methodsFor: 'options' stamp: ''!
beBinary
	"Configure me to read HTTP responses without interpreting them further,
	their resources/entities will remain bytes."
	
	self reader: [ :stream | ZnResponse readBinaryFrom: stream ]! !

!ZnClient methodsFor: 'private - logging' stamp: ''!
logRedirect: url
	^ (self newLogEvent: ZnClientFollowingRedirectEvent)
		target: url;
		emit! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
addPath: object
	"Extend the path of the current request with object.
	Either a string or a collection of strings is allowed as argument."
	
	object isString
		ifTrue: [ self addPathSegment: object ] 
		ifFalse: [ object do: [ :each | self addPathSegment: each ] ]! !

!ZnClient methodsFor: 'options' stamp: ''!
signalProgress
	"Return true if I signal HTTPProgress notifications during execution."
	
	^ self optionAt: #signalProgress ifAbsent: [ false ]! !

!ZnClient methodsFor: 'options' stamp: ''!
contentReader: object
	"Set the content reader, an object conforming 
	to the #value: protocol to convert a response entity
	as used by #contents to object.
	Can be used to parse incoming data."

	self optionAt: #contentReader put: object! !

!ZnClient methodsFor: 'private' stamp: ''!
withTimeoutDo: block
	^ ZnConnectionTimeout value
		ifNil: [
			ZnConnectionTimeout 
				value: self timeout 
				during: [ ^ block value ] ]
		ifNotNil: [ 
			block value ]! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
formAddAll: keyedCollection
	"Add all key->value associations of keyedCollection to 
	the application/x-www-form-urlencoded entity of the current request."

	self applicationFormUrlEncodedEntity 
		addAll: keyedCollection ! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
setAcceptEncodingGzip
	"Give the server the hint that we accept gzip content encoding.
	When the server complies, important bandwidth reductions are possible."

	self request setAcceptEncodingGzip! !

!ZnClient methodsFor: 'private' stamp: ''!
signalHTTPProgress: message
	self signalProgress
		ifTrue: [ HTTPProgress signal: message ]! !

!ZnClient methodsFor: 'initialization' stamp: ''!
systemPolicy
	self 
		enforceHttpSuccess: true;
		enforceAcceptContentType: true;
		numberOfRetries: 2! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
username: username password: password
	"Set the username/password for basic authenticationfor the current request."
	
	self setBasicAuthenticationUsername: username password: password
! !

!ZnClient methodsFor: 'options' stamp: ''!
enforceHttpSuccess: boolean
	"Set whether or not I enforce that the response 
	to the request is an HTTP success code to boolean."

	self optionAt: #enforceHttpSuccess put: boolean! !

!ZnClient methodsFor: 'initialization' stamp: ''!
initialize
	request := ZnRequest empty.
	self loggingOn ! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
applicationFormUrlEncodedEntity
	"Initialize the current request to have an application/x-www-form-urlencoded entity.
	Return the existing entity if there is one. 
	Fail if another type was already set."
	
	request hasEntity
		ifTrue: [
			request entity contentType = ZnMimeType applicationFormUrlEncoded 
				ifFalse: [ self error: 'An incompatible entity was already set for the request' ] ]
		ifFalse: [
			request entity: ZnApplicationFormUrlEncodedEntity new ].
	^ request entity! !

!ZnClient methodsFor: 'convenience' stamp: ''!
uploadEntityFrom: path
	"Set up a ZnStreamingEntity from the binary contents of the file at path.
	The path extension is used to guess the content-type,
	can be overridden using #contentType: if necessary.
	Use the file's length to set the content-length.
	You can then use #put or #post to actually do an upload."
	
	| stream type length |
	stream := ZnFileSystemUtils binaryFileReadStreamFor: path.
	type := ZnMimeType forFilenameExtension: (ZnFileSystemUtils extensionFor: path).
	length := ZnFileSystemUtils fileSizeFor: path.
	self entity: (ZnStreamingEntity readFrom: stream usingType: type andLength: length)! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
setIfModifiedSince: reference
	"Tell the server that we are only interested in the currently requested URI
	if it was modified since reference, a DateAndTime.
	If the URI was not modified since reference, the response will be #isNotModified."

	self request setIfModifiedSince: reference! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
resetEntity
	"Make sure that the current request does not hold an entity from a previous request.
	This is sometimes necessary after a POST or PUT. This method will be called automatically
	by #method: for certain requests."
	
	(request notNil and: [ request hasEntity ])
		ifTrue: [ request resetEntity: nil ]! !

!ZnClient methodsFor: 'options' stamp: ''!
dontFollowRedirects
	"Disable the default automatic following of HTTP redirects.
	Redirects will be returned as normal responses."

	^ self followRedirects: false! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
headerAt: key add: value
	"Add value to key in the HTTP header of the current request.
	This is for multi-values headers."
	
	request headers 
		at: key add: value! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
readResponse
	self signalHTTPProgress: 'Reading response'.
	self withMaximumNumberOfDictionaryEntriesDo: [
		self withDefaultCharacterEncoderDo: [
			response := (#(HEAD CONNECT) includes: request method)
				ifTrue: [ ZnResponse readHeaderFrom: connection ]
				ifFalse: [ 
					self streaming
						ifTrue: [ ZnResponse readStreamingFrom: connection ]
						ifFalse: [ 
							self withMaximumEntitySizeDo: [ self reader value: connection ] ] ] ] ].
	lastUsed := Time totalSeconds! !

!ZnClient methodsFor: 'private' stamp: ''!
setupTLSTo: url
	(ZnNetworkingUtils shouldProxyUrl: url)
		ifTrue: [ | originalRequest |
			"http://www.ietf.org/rfc/rfc2817.txt (section 5)"
			"https://en.wikipedia.org/wiki/HTTP_tunnel#HTTP_CONNECT_tunneling"
			originalRequest := request copy.
			request entity: nil. "to prevent #resetEntity from being called, resulting in #close of the shared entity"
			self method: #CONNECT; writeRequest; readResponse.
			response isSuccess ifFalse: [ self error: 'Failed to CONNECT to proxy for TLS/SSL' ].
			connection := ZnNetworkingUtils secureSocketStreamOn: connection socket.
			request := originalRequest ].
	
	connection sslSession certificateName: self certificate.
	
	[ connection sslSession serverName: url host ] 
		on: PrimitiveFailed 
		do: [ :error | "log it?" ].
		
	connection connect! !

!ZnClient methodsFor: 'private' stamp: ''!
cleanupConnection
	(self isOneShot or: [ request notNil and: [ request wantsConnectionClose ] ])
		ifTrue: [
			self close ]! !

!ZnClient methodsFor: 'options' stamp: ''!
clientId: anObject
	"Set the id for this HTTP client to anObject. Defaults to nil.
	Can be used identify different clients' log events."
	
	^ self optionAt: #clientId put: anObject! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
http
	"Set the scheme of the current request to HTTP."
	
	self url: (ZnUrl new scheme: #http; yourself)! !

!ZnClient methodsFor: 'options' stamp: ''!
streaming
	"Return whether I will return streaming response objects (see ZnStreamingEntity).
	If true, my users are responsible for actually reading the incoming response entity data stream."
	
	^ self optionAt: #streaming ifAbsent: [ false ]! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
host: hostName
	"Set the host of the current request to hostName."
	
	self url: (ZnUrl new host: hostName; yourself)! !

!ZnClient methodsFor: 'options' stamp: ''!
numberOfRetries: count
	"Set the number of times I will retry a failed request to count."
	
	self optionAt: #numberOfRetries put: count! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
request
	"Return the current request that I am building,
	or the previous request that I executed."
	
	^ request ! !

!ZnClient methodsFor: 'options' stamp: ''!
enforceAcceptContentType
	"Return whether or not I enforce that the content type of the
	response matches the content type specified in the accept request header."
	
	^ self optionAt: #enforceAcceptContentType ifAbsent: [ false ]! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
handleResponse
	self receiveCookies.
	(self enforceHttpSuccess and: [ response isSuccess not ])
		ifTrue: [ 
			(self followRedirects not and: [ response isRedirect ])
				ifFalse: [ (ZnHttpUnsuccessful response: response) signal ] ].
	(self enforceAcceptContentType and: [ self isContentTypeAcceptable not ])
		ifTrue: [ 
			(ZnUnexpectedContentType 
				expected: request accept asZnMimeType 
				actual: response contentType) signal ].
	^ self contents! !

!ZnClient methodsFor: 'testing' stamp: ''!
isBadRequest
	"Return true if the last executed HTTP request returned an HTTP bad request response code."
	
	^ response 
		ifNil: [ self error: 'Request not yet executed' ]
		ifNotNil: [ response isBadRequest ]! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
multiPartFormDataEntity
	"Initialize the current request to have an multipart/form-data entity.
	Return the existing entity if there is one. 
	Fail if another type was already set."

	request hasEntity
		ifTrue: [
			(request entity contentType matches: ZnMimeType multiPartFormData)
				ifFalse: [ self error: 'An incompatible entity was already set for the request' ] ]
		ifFalse: [
			request entity: ZnMultiPartFormDataEntity new ].
	^ request entity! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
setBasicAuthenticationUsername: username password: password
	"Set the username/password for basic authenticationfor the current request."
	
	self request setBasicAuthenticationUsername: username password: password
! !

!ZnClient methodsFor: 'convenience' stamp: ''!
post: url contents: object
	"Execute an HTTP POST request on url with object as request #contents:
	and return the response #contents."

	^ self 
		url: url; 
		contents: object; 
		post! !

!ZnClient methodsFor: 'options' stamp: ''!
numberOfRetries
	"Return how many times I will retry a failed request.
	Defaults to 0."
	
	^ self optionAt: #numberOfRetries ifAbsent: [ 0 ]! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
executeRequestResponse
	| initialMilliseconds requestDuration responseDuration |
	initialMilliseconds := Time millisecondClockValue.
	self writeRequest.
	requestDuration := self logRequestWrittenStarted: initialMilliseconds.
	initialMilliseconds := Time millisecondClockValue.
	self readResponse.
	responseDuration := self logResponseReadStarted: initialMilliseconds.
	self logClientTransactionRequestDuration: requestDuration responseDuration: responseDuration! !

!ZnClient methodsFor: 'convenience' stamp: ''!
curl
	"Create and return a curl command line invocation equivalent to the current request."
	"ZnClient new url: 'http://zn.stfx.eu/zn/small.html'; method: #GET; curl."
	"ZnClient new url: 'http://zn.stfx.eu/echo'; contents: #[2 4 6 8]; method: #POST; curl."
	
	self prepareRequest.
	^ String streamContents: [ :stream |
		request hasEntity ifTrue: [ 
			 stream << 'echo ' << request entity asByteArray hex << ' | xxd -r -p | ' ].
		stream << 'curl'.
		request method = #GET ifFalse: [ stream << ' -X ' << request method ].
		stream space; print: request uri.
		request headersDo: [ :key :value |
			stream << ' -H"' << key << ':' << value << '"' ].
		request hasEntity ifTrue: [ stream << ' --data-binary @-' ] ]! !

!ZnClient methodsFor: 'options' stamp: ''!
contentWriter: object
	"Set current content writer, an object conforming 
	to the #value: protocol to convert an object to a request content entity
	as used by #contents:. Defaults to nil.
	Can be used to format data to be uploaded."

	self optionAt: #contentWriter put: object! !

!ZnClient methodsFor: 'private - logging' stamp: ''!
logIgnoringExceptionOnReusedConnection: exception
	logLevel < 3 ifTrue: [ ^ nil ].
	^ (self newLogEvent: ZnClientIgnoringExceptionOnConnectionReuseEvent)
		exception: exception;
		emit! !

!ZnClient methodsFor: 'testing' stamp: ''!
isContentTypeAcceptable
	"Return true if the contentType of the response of the last executed 
	HTTP request matches the accept header of the request."
	
	^ response 
		ifNil: [ self error: 'Request not yet executed' ]
		ifNotNil: [ 
			response hasEntity not 
				or: [ response contentType matches: request accept asZnMimeType ] ]! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
prepareRequest
	self isOneShot 
		ifTrue: [ request setConnectionClose ].
	request hasEntity
		ifTrue: [ 
			"This is necessary because entities are often modified after first being added empty,
			and a wrong content length is cached at the request level"
			request resetEntity: request entity ].
	self sendCookies.
	self prepareRequestHook 
		ifNotNil: [ :hook | hook value: request ]! !

!ZnClient methodsFor: 'options' stamp: ''!
contentWriter
	"Return the current content writer, an object conforming 
	to the #value: protocol to convert an object to a request content entity
	as used by #contents:. Defaults to nil.
	Can be used to format data to be uploaded."

	^ self optionAt: #contentWriter ifAbsent: [ nil ]! !

!ZnClient methodsFor: 'cleanup' stamp: ''!
close
	"Close any HTTP network connection that I might have kept open."

	connection
		ifNotNil: [ 
			| address port |
			address := [ connection socket remoteAddress ] on: Error do: [ nil ].
			port := [ connection socket remotePort ] on: Error do: [ nil ].
			connection close.
			connection := nil.
			self logConnectionClosedAddress: address port: port ].
	lastUsed := nil! !

!ZnClient methodsFor: 'accessing' stamp: ''!
resetCookies
	session ifNotNil: [ session resetCookies ]! !

!ZnClient methodsFor: 'private' stamp: ''!
retryExceptionSet
	^ NetworkError, ZnParseError, ZnCharacterEncodingError, ZnUnknownScheme, ZnPortNotANumber! !

!ZnClient methodsFor: 'options' stamp: ''!
timeout
	"Return the timeout in seconds for network socket stream operations
	like connecting, reading and writing. Defaults to a global setting."
	
	^ self optionAt: #timeout ifAbsent: [ ZnNetworkingUtils defaultSocketStreamTimeout ]! !

!ZnClient methodsFor: 'private' stamp: ''!
withMaximumEntitySizeDo: block
	^ self maximumEntitySize = ZnMaximumEntitySize value
			ifTrue: block
			ifFalse: [ 
				ZnMaximumEntitySize 
					value: self maximumEntitySize  
					during: block ]! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
executeWithRetriesRemaining: retryCount
	^ [ self executeWithRedirectsRemaining: self maxNumberOfRedirects ]
		on: self retryExceptionSet
		do: [ :exception |
			retryCount > 0
				ifTrue: [
					self 
						handleRetry: exception;
						executeWithRetriesRemaining: retryCount - 1 ]
				ifFalse: [
					exception pass ] ]! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
request: aRequest
	"Replace my current request with aRequest.
	This is a low level operation only needed in special cases."
	
	self validateConnectionForHost: aRequest url host port: aRequest url port.
	request := aRequest! !

!ZnClient methodsFor: 'convenience' stamp: ''!
downloadEntityTo: path
	"If I hold an entity, download it directly to a file.
	If path describes a file, use that. 
	If path describes a directory, use the last path segment of the URI to construct a file in that directory.
	The URI of the last request is used, which could make a difference when following redirects."

	| target |
	self entity ifNil: [ ^ self ].
	target := ZnFileSystemUtils downloadPathTo: path for: self request uri lastPathSegment.
	ZnFileSystemUtils
		newBinaryFileNamed: target
		do: [ :fileStream |
			self withProgressDo: [ self entity writeOn: fileStream ] ]! !

!ZnClient methodsFor: 'private' stamp: ''!
withProgressDo: block
	^ ZnSignalProgress value
		ifNil: [
			ZnSignalProgress 
				value: self signalProgress 
				during: [ ^ block value ] ]
		ifNotNil: [ 
			block value ]! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
port: portNumber
	"Set the port of the current request to portNumber."
	
	self url: (ZnUrl new port: portNumber; yourself)! !

!ZnClient methodsFor: 'logging' stamp: ''!
logToTranscript
	"Setup logging to the Transcript.
	If logging was completely off, turn it on"

	logLevel isZero ifTrue: [ self loggingOn ].
	ZnLogEvent logToTranscript ! !

!ZnClient methodsFor: 'options' stamp: ''!
beOneShot
	"Switch me to use connections only for a single request/response cycle.
	By default, I will keep HTTP connections open according to the HTTP 1.1 spec.
	When oneShot is true, I will add a Connection: close header to requests and close after one cycle.
	I cannot be one shot when #streaming is true because the stream would be closed too soon."
	
	self streaming
		ifTrue: [ self error: 'I cannot be one shot when #streaming is true.' ].
	self optionAt: #oneShot put: true   ! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
addPart: mimePart
	"Add mimePart to the multipart/form-data entity of the current request"

	self multiPartFormDataEntity 
		addPart: mimePart ! !

!ZnClient methodsFor: 'options' stamp: ''!
maximumNumberOfDictionaryEntries
	"Return the maximum number of entries allowed in ZnMutliValueDictionaries before signalling ZnTooManyDictionaryEntries. This protects us from overflow attacks."
		
	^ self
		optionAt: #maximumNumberOfDictionaryEntries
		ifAbsent: [ ZnMaximumNumberOfDictionaryEntries value ]! !

!ZnClient methodsFor: 'options' stamp: ''!
maximumNumberOfDictionaryEntries: anInteger
	"Set the maximum number of entries allowed in ZnMutliValueDictionaries before signalling ZnTooManyDictionaryEntries. This protects us from overflow attacks."
	
	^ self
		optionAt: #maximumNumberOfDictionaryEntries
		put: anInteger! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
url: urlObject
	"Modify the URL of the current request object to urlObject.
	This is done using ZnUrl>>#inContextOf: so that either scheme, 
	host, port or path are set and merged.
	Default the URL using ZnUrl>>#asZnUrlWithDefaults to fall back
	to http or the default http/https ports."
	
	| url |
	url := urlObject asZnUrl.
	request url
		ifNotNil: [ url := url inContextOf: request url ].  
	url := url asZnUrlWithDefaults.  
	self validateConnectionForHost: url host port: url port.   
	request url: url.
	url hasUsername & url hasPassword
		ifTrue: [ self setBasicAuthenticationUsername: url username password: url password ]! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
writeRequest
	self signalHTTPProgress: 'Writing request'.
	self withDefaultCharacterEncoderDo: [ request writeOn: connection ].
	connection flush! !

!ZnClient methodsFor: 'private - logging' stamp: ''!
logConnectionEstablishedTo: url started: initialMilliseconds
	| event |
	logLevel < 3 ifTrue: [ ^ nil ].
	(event := self newLogEvent: ZnConnectionEstablishedEvent)
		hostname: url host;
		port: url portOrDefault;
		address: ([ connection socket remoteAddress ] on: Error do: [ nil ]);
		duration: (Time millisecondsSince: initialMilliseconds).
	(ZnNetworkingUtils shouldProxyUrl: url)
		ifTrue: [ event proxy: ZnNetworkingUtils proxyUrl ].
	event emit! !

!ZnClient methodsFor: 'operations' stamp: ''!
get
	"Execute an HTTP GET the request set up and return the response #contents."
	
	^ self 
		method: #GET; 
		execute! !

!ZnClient methodsFor: 'logging' stamp: ''!
loggingOn
	"Turn full logging on - generate all log events"
	
	self logLevel: 3! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
handleRetry: exception
	self logRetrying: exception.
	self close.
	(Delay forSeconds: self retryDelay) wait.
! !

!ZnClient methodsFor: 'testing' stamp: ''!
isSuccess 
	"Return true it the last executed HTTP request returned an HTTP success response code."
	
	^ response 
		ifNil: [ self error: 'Request not yet executed' ]
		ifNotNil: [ response isSuccess ]! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
contentType: mimeType
	"Set the content-type of the request entity, provided we have one"
	
	request hasEntity
		ifTrue: [ 
			request entity contentType: mimeType asZnMimeType ]
		ifFalse: [ 
			self error: 'There is no request entity yet, cannot set its content-type' ]! !

!ZnClient methodsFor: 'private - protocol' stamp: ''!
prepareRedirect
	"We implement the common behavior that POST/PUT redirects turn into GET request
	and that the body data is dropped, except for a 307 or 308 where this is explicitly forbidden.
	Note the cookie handling too."

	| targetUrl |
	targetUrl := self redirectUrl.
	self logRedirect: targetUrl.
	self receiveCookies.
	self prepareNextRequest.
	(#(307 308) includes: response code)
		ifFalse: [  
			(#(POST PUT) includes: request method)
				ifTrue: [ self method: #GET ].
			request hasEntity
				ifTrue: [ request resetEntity: nil ] ].
	self url: targetUrl.
	self sendCookies! !

!ZnClient methodsFor: 'private - logging' stamp: ''!
logResponseReadStarted: initialMilliseconds
	^ logLevel < 3
		ifTrue: [ Time millisecondsSince: initialMilliseconds ]
		ifFalse: [ 
			(self newLogEvent: ZnResponseReadEvent)
				response: response;
				duration: (Time millisecondsSince: initialMilliseconds);
				emit;
				duration ]! !

!ZnClient methodsFor: 'testing' stamp: ''!
isNotModified
	"Return true it the last executed HTTP request returned an HTTP not modified response code."
	
	^ response 
		ifNil: [ self error: 'Request not yet executed' ]
		ifNotNil: [ response isNotModified ]! !

!ZnClient methodsFor: 'operations' stamp: ''!
options
	"Execute an HTTP OPTIONS on the request set up and return the response #contents."
	
	^ self 
		method: #OPTIONS; 
		execute! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
queryAt: key put: value
	"Add key equals value as an HTTP query parameter to the current request.
	If the key already exists, its value is overwritten."
	
	request url 
		ifNil: [ request url: (ZnUrl new queryAt: key put: value; yourself) ]
		ifNotNil: [ request url queryAt: key put: value ]  ! !

!ZnClient methodsFor: 'accessing - request' stamp: ''!
entity: entity
	"Set the entity of the current request to enity.
	A ZnEntity subclass or compatible object is expected."
	
	request entity: entity! !

!ZnClientConnectionClosedEvent commentStamp: ''!
ZnClientConnectionClosedEvent signals that a client side connection to address:port is closed.!
!ZnClientConnectionClosedEvent methodsFor: 'accessing' stamp: ''!
address: anObject
	address := anObject! !

!ZnClientConnectionClosedEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Connection Closed '.
	address 
		ifNil: [ 
			stream print: address ]
		ifNotNil: [ 
			address 
				do: [ :each | stream print: each ] 
				separatedBy: [ stream nextPut: $. ] ].
	stream nextPut: $:; print: port! !

!ZnClientConnectionClosedEvent methodsFor: 'accessing' stamp: ''!
port: anObject
	port := anObject! !

!ZnClientConnectionClosedEvent methodsFor: 'accessing' stamp: ''!
address
	^ address! !

!ZnClientConnectionClosedEvent methodsFor: 'accessing' stamp: ''!
port
	^ port! !

!ZnClientFollowingRedirectEvent commentStamp: ''!
ZnClientFollowingRedirectEvent signals that a redirect to target is being followed. How many redirects to follow, if any is configurable.!
!ZnClientFollowingRedirectEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Following Redirect '; print: target! !

!ZnClientFollowingRedirectEvent methodsFor: 'accessing' stamp: ''!
target
	^ target! !

!ZnClientFollowingRedirectEvent methodsFor: 'accessing' stamp: ''!
target: anObject
	target := anObject! !

!ZnClientIgnoringExceptionOnConnectionReuseEvent commentStamp: ''!
ZnClientIgnoringExceptionOnConnectionReuseEvent signals that a client connection was reused and that an exception occurred. Normally, there is one retry after that, trying to reconnect.
!
!ZnClientIgnoringExceptionOnConnectionReuseEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Ignoring Exception On Connection Reuse '; print: exception! !

!ZnClientIgnoringExceptionOnConnectionReuseEvent methodsFor: 'accessing' stamp: ''!
exception
	^ exception! !

!ZnClientIgnoringExceptionOnConnectionReuseEvent methodsFor: 'accessing' stamp: ''!
exception: anObject
	exception := anObject! !

!ZnClientLogEvent commentStamp: ''!
I am ZnClientLogEvent, a ZnLogEvent generated by ZnClient.

I hold an optional clientId attribute.
!
!ZnClientLogEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	clientId ifNotNil: [ stream space; << clientId ]! !

!ZnClientLogEvent methodsFor: 'accessing' stamp: ''!
clientId
	^ clientId! !

!ZnClientLogEvent methodsFor: 'accessing' stamp: ''!
clientId: anObject
	clientId := anObject! !

!ZnClientRetryingEvent commentStamp: ''!
ZnClientRetryingEvent signals a client is retrying is main operation. The number of retries is configurable.
!
!ZnClientRetryingEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Retrying '; print: exception! !

!ZnClientRetryingEvent methodsFor: 'accessing' stamp: ''!
exception
	^ exception! !

!ZnClientRetryingEvent methodsFor: 'accessing' stamp: ''!
exception: anObject
	exception := anObject! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetSmallHTMLBinary
	| client html bytes |
	(client := ZnClient new)
		url: self smallHtmlUrl;
		get.
	self assert: client isSuccess.
	self assert: client response contentType equals: ZnMimeType textHtml.
	self assert: (client contents includesSubstring: 'Small').
	html := client contents.
	self assert: html isString.

	client
		beBinary;
		get.
	self assert: client isSuccess.
	self assert: client response contentType equals: ZnMimeType textHtml.
	bytes := client contents.
	self deny: bytes isString.
	self assert: bytes utf8Decoded equals: html.

	client close! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testPrepareRequest
	| client |
	self withServerDo: [ :server |
		(client := ZnClient new)
			url: server localUrl;
			addPath: 'echo';
			prepareRequest: [ :request | request setAuthorization: 'my-signature' ];
			get.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'my-signature').
		client
			url: server localUrl;
			addPath: 'echo';
			get.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'my-signature').
		client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testIfFailNonExistingHost
	| client |
	"Note that when there is an HTTP proxy set, there will be no direct Error"
	(client := ZnClient new)
		beOneShot;
		url: 'http://unknown-stfx.eu';
		ifFail: [ : exception |
			^ self assert: (exception isKindOf: NetworkError) | (exception isKindOf: ZnHttpUnsuccessful) ];
		get.
	self assert: client isSuccess not.
	client
		enforceHttpSuccess: true;
		get.
	self fail! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testTimeout
	self withServerDo: [ :server |
		self 
			should: [ 
				ZnClient new 
					timeout: 1; 
					url: server localUrl;
					addPath: 'echo';
					queryAt: 'delay' put: '2'; 
					get ]
			raise: ConnectionTimedOut ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testProgress
	"[ :bar |
		bar title: 'Downloading Sources...'.
		[
			ZnClient new 
				url: 'http://files.pharo.org/sources/PharoV30.sources'; 
				signalProgress: true;	
				downloadTo: FileLocator temp ]
			on: HTTPProgress 
			do: [ :progress |
				progress isEmpty ifFalse: [ bar current: progress percentage ]. 
				progress resume ] ] asJob run."
		
	self 
		should: [ 
			ZnClient new
				beOneShot;
				signalProgress: true;
				get: self smallHtmlUrl ] 
		raise: HTTPProgress
! !

!ZnClientTest methodsFor: 'accessing' stamp: ''!
t3EasyGeoIPUrl
	^ 'http://easy.t3-platform.net/rest/geo-ip' asZnUrl! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testConnectionCloseOnReuseTimeout
	| client firstSocket secondSocket|
	client := ZnClient new.
	client connectionReuseTimeout: 0.
	self withServerDo: [ :server | 
		client 
			url: server localUrl;
			get.
		firstSocket := client connection.
		client get.
		secondSocket := client connection.		
		self assert: (firstSocket = secondSocket) not.
		self deny: firstSocket isConnected.
		firstSocket close.
		client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetAfterPost
	self
		withServerDo: [ :server | 
			| client |
			server
				onRequestRespond: [ :request | 
					request uri firstPathSegment = 'one'
						ifTrue:
							[ (request method = #POST and: [ request hasEntity ]) ifTrue: [ ZnResponse ok: (ZnEntity text: 'OK for one') ] ifFalse: [ ZnResponse badRequest: request ] ]
						ifFalse: [ request uri firstPathSegment = 'two'
								ifTrue:
									[ (request method = #GET and: [ request hasEntity not ]) ifTrue: [ ZnResponse ok: (ZnEntity text: 'OK for two') ] ifFalse: [ ZnResponse badRequest: request ] ]
								ifFalse: [ ZnResponse notFound: request uri ] ] ].
			(client := ZnClient new)
				autoResetEntityMethods: #(HEAD DELETE GET);
				url: server localUrl;
				url: 'one';
				entity: (ZnEntity text: 'One two three');
				post.
			self assert: client isSuccess.
			self assert: client contents equals: 'OK for one'.
			client
				url: 'two';
				get.
			self assert: client isSuccess.
			self assert: client contents equals: 'OK for two'.
			client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetSmallHTMLTwice
	| client |
	(client := ZnClient new)
		url: self smallHtmlUrl;
		get.
	self assert: client isSuccess.
	self assert: client response contentType equals: ZnMimeType textHtml.
	self assert: (client contents includesSubstring: 'Small').
	client
		url: self smallHtmlUrl pathPrintString;
		get.
	self assert: client isSuccess.
	self assert: client response contentType equals: ZnMimeType textHtml.
	self assert: (client contents includesSubstring: 'Small').
	client close! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testUsernamePassword
	self withServerDo: [ :server | | client |
		server authenticator: (ZnBasicAuthenticator username: 'foo' password: 'secret').
		(client := ZnClient new) 
			url: server localUrl;
			addPathSegment: 'echo';
			get.
		self deny: client isSuccess.
		self assert: client response isAuthenticationRequired.
		client 
			username: 'foo' password: 'secret'; 
			get.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'Zinc').
		client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testRedirect
	| client response target |
	target := 'http://zn.stfx.eu'.
	client := ZnClient new url: target.
	client get.
	self assert: client isSuccess.
	client
		close;
		maxNumberOfRedirects: 0;
		url: target.
	self should: [ client get ] raise: ZnTooManyRedirects.
	client close.
	response := [ 
		ZnClient new
			beOneShot;
			maxNumberOfRedirects: 0;
			get: target;
			response ] on: ZnTooManyRedirects do: [ :exception | exception resume ].
	self assert: response isRedirect! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testRedirectWithCookies
	self
		withServerDo: [ :server | 
			| client cookie |
			server
				onRequestRespond: [ :request | 
					request uri firstPathSegment = 'one'
						ifTrue: [ (ZnResponse redirect: 'two')
								addCookie: (ZnCookie name: 'session' value: '123456');
								yourself ]
						ifFalse: [ cookie := request cookies detect: [ :each | each name = 'session' ] ifNone: [ nil ].
							(request uri firstPathSegment = 'two' and: [ cookie notNil and: [ cookie value = '123456' ] ])
								ifTrue: [ ZnResponse ok: (ZnEntity text: 'OK!!') ]
								ifFalse: [ ZnResponse badRequest: request ] ] ].
			(client := ZnClient new)
				url: server localUrl;
				addPath: 'one';
				post.
			self assert: client isSuccess.
			self assert: client contents equals: 'OK!!'.
			client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetSmallHTMLStreaming
	| client result contents |
	result := (client := ZnClient new)
		url: self smallHtmlUrl;
		streaming: true;
		get.
	self assert: client isSuccess.
	self assert: client response contentType equals: ZnMimeType textHtml.
	self assert: result isStream.
	self assert: client entity stream equals: result.
	contents := ZnUTF8Encoder new decodeBytes: result upToEnd.
	self assert: (contents includesSubstring: 'Small').
	client close! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetSmallHTMLUrlConstruction
	| client |
	(client := ZnClient new)
		http;
		host: self smallHtmlUrl host;
		path: self smallHtmlUrl pathPrintString;
		get.
	self assert: client isSuccess.
	self assert: client response contentType equals: ZnMimeType textHtml.
	self assert: (client contents includesSubstring: 'Small').
	client close! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testConstruction
	| client |
	(client := ZnClient new)
		http;
		host: 'www.example.com';
		port: 8080;
		addPath: 'foo';
		addPath: 'a space';
		addPath: 'file.txt';
		queryAt: 'key' put: '123456';
		headerAt: 'X-token' put: 'ABCDEF'.
	self assert: client request url host equals: 'www.example.com'.
	self assert: client request url port equals: 8080.
	self assert: client request url pathQueryFragmentPrintString equals: '/foo/a%20space/file.txt?key=123456'.
	self assert: (client request headers at: 'X-token') equals: 'ABCDEF'! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testCookies
	| client |
	self
		withServerDo: [ :server | 
			server
				onRequestRespond: [ :request | 
					| cookie1 cookie2 response |
					cookie1 := request cookies detect: [ :each | each name = 'x' ] ifNone: [ ZnCookie name: 'x' value: '0' ].
					cookie2 := request cookies detect: [ :each | each name = 'y' ] ifNone: [ ZnCookie name: 'y' value: '100' ].
					cookie1 value: (cookie1 value asInteger + 1) asString.
					cookie2 value: (cookie2 value asInteger + 2) asString.
					response := ZnResponse ok: (ZnEntity text: 'OK').
					response
						addCookie: cookie1;
						addCookie: cookie2.
					response ].
			client := ZnClient new
				url: server localUrl;
				yourself.
			self assert: (client session cookieJar cookieAt: 'x' forUrl: client request url) isNil.
			self assert: (client session cookieJar cookieAt: 'y' forUrl: client request url) isNil.
			client get.
			self assert: client isSuccess.
			self assert: (client session cookieJar cookieAt: 'x' forUrl: client request url) value equals: '1'.
			self assert: (client session cookieJar cookieAt: 'y' forUrl: client request url) value equals: '102'.
			client get.
			self assert: client isSuccess.
			self assert: (client session cookieJar cookieAt: 'x' forUrl: client request url) value equals: '2'.
			self assert: (client session cookieJar cookieAt: 'y' forUrl: client request url) value equals: '104'.
			client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testDownloadSmallHTML
	| client |
	ZnFileSystemUtils deleteIfExists: self smallHtmlUrl pathSegments last.
	"First download to a directory"
	(client := ZnClient new)
		url: self smallHtmlUrl;
		downloadTo: ZnFileSystemUtils defaultDirectoryPath.
	self assert: client isSuccess.
	self assert: client response contentType equals: ZnMimeType textHtml.
	ZnFileSystemUtils oldFileNamed: self smallHtmlUrl pathSegments last do: [ :stream | self assert: (stream upToEnd includesSubstring: 'Small') ].
	ZnFileSystemUtils deleteIfExists: self smallHtmlUrl pathSegments last.
	"Second download to an explicitly named file"
	client
		url: self smallHtmlUrl;
		downloadTo: self smallHtmlUrl pathSegments last.
	self assert: client isSuccess.
	self assert: client response contentType equals: ZnMimeType textHtml.
	ZnFileSystemUtils oldFileNamed: self smallHtmlUrl pathSegments last do: [ :stream | self assert: (stream upToEnd includesSubstring: 'Small') ].
	client close.
	ZnFileSystemUtils deleteIfExists: self smallHtmlUrl pathSegments last! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testIfFailWrongType
	| client |
	(client := ZnClient new)
		beOneShot;
		accept: ZnMimeType imagePng;
		enforceAcceptContentType: true;
		url: self smallHtmlUrl;
		ifFail: [ :exception |
			^ self assert: (exception isKindOf: ZnUnexpectedContentType) ];
		get.
	self fail! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testQueryGoogle
	| client |
	(client := ZnClient new)
		http;
		host: 'www.google.com';
		addPath: 'search';
		queryAt: 'q' put: 'Pharo Smalltalk';
		get.
	self assert: client isSuccess.
	self assert: (client response contentType matches: ZnMimeType textHtml).
	self assert: (client contents includesSubstring: 'pharo.org').
	client close! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testUploadSmallDocument
	self
		withServerDo: [ :server | 
			| client contents path |
			path := ZnFileSystemUtils fullNameFor: 'small.txt'.
			contents := String
				streamContents: [ :stream | 
					stream
						print: DateAndTime now;
						space;
						print: 9999 atRandom ].
			ZnFileSystemUtils deleteIfExists: 'small.txt'.
			ZnFileSystemUtils newFileNamed: path do: [ :stream | stream nextPutAll: contents ].
			(client := ZnClient new)
				url: server localUrl;
				addPath: 'echo';
				uploadEntityFrom: path.
			self assert: client request entity contentType equals: ZnMimeType textPlain.
			client contentType: ZnMimeType textPlain.	"Not needed, just test the code path"
			self assert: client request entity contentType equals: ZnMimeType textPlain.
			client post.
			self assert: client isSuccess.
			self assert: client entity contentType equals: ZnMimeType textPlain.
			self assert: (client contents includesSubstring: contents).
			client close.
			ZnFileSystemUtils deleteIfExists: 'small.txt' ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetLargeWideStringHTML
	| client text |
	text := '<html>{1}<h1>Czech in Czech is {2}e{3}tina.</h1>{1}</html>' 
		format: { 
			String new: ZnUtils streamingBufferSize withAll: $X.
			269 asCharacter. 
			353 asCharacter }.
	self assert: text isWideString.
	self withServerDo: [ :server |
		server onRequestRespond: [ :request | ZnResponse ok: (ZnEntity html: text) ].
		(client := ZnClient new)
			get: server localUrl.
		self assert: client isSuccess.
		self assert: client response contents equals: text.
		client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testUsernamePasswordInUserInfo
	self withServerDo: [ :server | | url client |
		server authenticator: (ZnBasicAuthenticator username: 'foo' password: 'secret').
		url := server localUrl.
		url username: 'foo'; password: 'secret'; addPathSegment: 'echo'.
		(client := ZnClient new) 
			get: url.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'Zinc').
		client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testPatch
	| client |
	self withServerDo: [ :server |
		server onRequestRespond: [ :request | 
			request method = #PATCH
				ifTrue: [| response |
					response := ZnResponse noContent.
					response headers at: #Etag put: '"e0023aa4f"'.
					response]
				ifFalse: [ ZnResponse badRequest: request ] ].
		(client := ZnClient new)
			patch: server localUrl contents: 'Some data as text'.
		self assert: client isSuccess.
		self deny: client response hasEntity.
		self assert: (client response headers at: #Etag) equals: '"e0023aa4f"'.
		client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetForm
	| client |
	self withServerDo: [ :server |
		(client := ZnClient new)
			url: server localUrl;
			addPath: 'echo';
			formAt: 'username' put: 'john';
			formAdd: 'password' -> 'secret';
			get.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'john').
		self assert: (client contents includesSubstring: 'secret') ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testLogging
	| client logEventCollection count |
	logEventCollection := OrderedCollection new.
	ZnLogEvent announcer 
		when: ZnLogEvent do: [ :event | logEventCollection add: event ]. 
	(client := ZnClient new)
		clientId: #C1;
		beOneShot.
	client get: self smallHtmlUrl.
	client close.
	count := ZnLogEvent announcer numberOfSubscriptions.
	ZnLogEvent announcer 
		unsubscribe: self.
	self assert: ZnLogEvent announcer numberOfSubscriptions equals: count -1.
	self deny: logEventCollection isEmpty.
	self assert: logEventCollection anyOne clientId equals: #C1! !

!ZnClientTest methodsFor: 'accessing' stamp: ''!
smallHtmlUrl
	^ 'http://zn.stfx.eu/zn/small.html' asZnUrl! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testRedirectDontFollow
	| client target |
	target := 'http://zn.stfx.eu'.
	(client := ZnClient new) 
		dontFollowRedirects;
		get: target.
	self assert: client response isRedirect.
	client
		enforceHttpSuccess: true;
		get: target.
	self assert: client response isRedirect.
	client close! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testUsernamePasswordTwice
	self withServerDo: [ :server | | client |
		server authenticator: (ZnBasicAuthenticator username: 'foo' password: 'secret').
		(client := ZnClient new) 
			url: server localUrl;
			addPathSegment: 'echo';
			username: 'foo' password: 'secret'; 
			get.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'Zinc').
		client get.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'Zinc').
		client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testIfModifiedSinceNotModified
	| client  response |
	(client := ZnClient new) host: 'stfx.eu'.
	[
		response := client 
			url: '/small.html'; 
			setIfModifiedSince: (Date year: 2012 month: 9 day: 1);
			get; 
			response.
		self assert: response isNotModified.
		self assert: response hasEntity not ] ensure: [ client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testOptions
	| client |
	self withServerDo: [ :server |
		server onRequestRespond: [ :request | 
			request method = #OPTIONS
				ifTrue: [ | response |
					response := ZnResponse noContent.
					response headers at: #Allow put: 'GET, HEAD'.
					response ]
				ifFalse: [ ZnResponse badRequest: request ] ].
		(client := ZnClient new)
			options: server localUrl.
		self assert: client isSuccess.
		self deny: client response hasEntity.
		self assert: (client response headers at: #Allow) equals: 'GET, HEAD'.
		client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetWideStringHTML
	| client text |
	text := '<html><h1>Czech is in Czech {1}e{2}tina.</h1></html>' format: { 269 asCharacter. 353 asCharacter}.
	self assert: text isWideString.
	self withServerDo: [ :server |
		server onRequestRespond: [ :request | ZnResponse ok: (ZnEntity html: text) ].
		(client := ZnClient new)
			get: server localUrl.
		self assert: client isSuccess.
		self assert: client response contents equals: text.
		client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testProgressNoIfFail
	self 
		should: [ 
			ZnClient new
				beOneShot;
				signalProgress: true;
				ifFail: [ self fail ];
				get: self smallHtmlUrl ] 
		raise: HTTPProgress
! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetSmallHTML
	| client |
	(client := ZnClient new)
		url: self smallHtmlUrl;
		get.
	self assert: client isSuccess.
	self assert: client isContentTypeAcceptable.
	self assert: client response contentType equals: ZnMimeType textHtml.
	self assert: (client contents includesSubstring: 'Small').
	self assert: client isConnected.
	client close.
	self deny: client isConnected! !

!ZnClientTest methodsFor: 'private' stamp: ''!
withServerDo: block
	| server |
	server := ZnServer on: 1700 + 32 atRandom.
	[ 
		server start.
		self 
			assert: server isRunning & server isListening
			description: ('Failed to start server on port {1}. Is there one already?' format: { server port }).
		block cull: server
	] 
		ensure: [ server stop ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetSmallHTMLOneShot
	| client |
	(client := ZnClient new)
		beOneShot;
		url: self smallHtmlUrl;
		get.
	self assert: client isSuccess.
	self assert: client response contentType equals: ZnMimeType textHtml.
	self assert: (client contents includesSubstring: 'Small').
	self deny: client isConnected! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testRelativeRedirect307
	self
		withServerDo: [ :server | 
			| client |
			server
				onRequestRespond: [ :request | 
					request uri firstPathSegment = 'one'
						ifTrue: [ (ZnResponse redirect: 'two')
								statusLine: (ZnStatusLine code: 307);
								yourself ]
						ifFalse: [ (request uri firstPathSegment = 'two' and: [ request method = #POST and: [ request contents = 'BODY' ] ])
								ifTrue: [ ZnResponse ok: (ZnEntity text: 'OK!!') ]
								ifFalse: [ ZnResponse notFound: request uri ] ] ].
			(client := ZnClient new)
				url: server localUrl;
				addPath: 'one';
				entity: (ZnEntity text: 'BODY');
				post.
			self assert: client isSuccess.
			self assert: client contents equals: 'OK!!'.
			client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testIfFailNotFound
	| client |
	(client := ZnClient new)
		beOneShot;
		url: 'http://stfx.eu/non-existing';
		ifFail: [ :exception |
			^ self assert: (exception isKindOf: ZnHttpUnsuccessful) ];
		get.
	self assert: client isSuccess not.
	client
		enforceHttpSuccess: true;
		get.
	self fail! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testRelativeRedirect
	self
		withServerDo: [ :server | 
			| client |
			server
				onRequestRespond: [ :request | 
					request uri firstPathSegment = 'one'
						ifTrue: [ ZnResponse redirect: 'two' ]
						ifFalse: [ request uri firstPathSegment = 'two' ifTrue: [ ZnResponse ok: (ZnEntity text: 'OK!!') ] ifFalse: [ ZnResponse notFound: request uri ] ] ].
			(client := ZnClient new)
				url: server localUrl;
				addPath: 'one';
				post.
			self assert: client isSuccess.
			self assert: client contents equals: 'OK!!'.
			client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testPostMultipart
	| client filename |
	ZnFileSystemUtils deleteIfExists: 'testPostMultiPart.txt'.
	filename := ZnFileSystemUtils fullNameFor: 'testPostMultiPart.txt'.
	ZnFileSystemUtils newFileNamed: filename do: [ :stream | stream nextPutAll: '0123456789' ].
	self withServerDo: [ :server |
		(client := ZnClient new)
			url: server localUrl;
			addPath: 'echo';
			addPart: (ZnMimePart fieldName: 'username' value: 'john');
			addPart: (ZnMimePart fieldName: 'foo' entity: (ZnEntity text: '123'));
			addPart: (ZnMimePart fieldName: 'file' fileNamed: filename);
			post.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'multipart') ].
	ZnFileSystemUtils deleteIfExists: 'testPostMultiPart.txt'.
! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testPostTwice
	| client |
	self withServerDo: [ :server |
		(client := ZnClient new)
			url: server localUrl;
			addPath: 'echo';
			contents: 'Foo bar!!';
			post.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'Foo bar!!').
		client
			contents: 'Another one ?';
			post.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'Another one ?').
		client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testPostForm
	| client |
	self withServerDo: [ :server |
		(client := ZnClient new)
			url: server localUrl;
			addPath: 'echo';
			formAt: 'username' put: 'john';
			formAdd: 'password' -> 'secret';
			post.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'john').
		self assert: (client contents includesSubstring: 'secret') ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testSpecialPosts
	self skip.
	self withServerDo: [ :server |
		{ ZnEntity with: 'A'. ZnEntity with: #[ 42 ]. ZnEntity with: ''. ZnEntity with: #[ ] } 
			do: [ :each |
				| client |
				(client := ZnClient new)
					url: server localUrl;
					addPath: #echo;
					entity: each;
					post.
				self assert: client isSuccess.
				self assert: (each isEmpty or: [client contents includesSubstring: each printString ]).
				client close.
				(client := ZnClient new)
					beOneShot;
					url: server localUrl;
					addPath: #echo;
					entity: each;
					post.
				self assert: client isSuccess.
				self assert: (each isEmpty or: [client contents includesSubstring: each printString ]) ] ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testGetGeoIP
	| result client |
	result := (client := ZnClient new)
		systemPolicy;
		url: self t3EasyGeoIPUrl;
		queryAt: 'address' put: '81.83.7.35';
		accept: ZnMimeType applicationJson;
		contentReader:
				[ :entity | testingEnvironment at: #NeoJSONReader ifPresent: [ :parserClass | parserClass fromString: entity contents ] ifAbsent: [ ^ self ] ];
		ifFail: [ ^ self fail ];
		get.
	self assert: result isDictionary.
	self assert: (result at: #country) equals: 'BE'.
	client close! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testRedirectWithCustomHeader
	self
		withServerDo: [ :server | 
			| client cookie |
			server
				onRequestRespond: [ :request | 
					(request headers at: 'X-Custom' ifAbsent: [ nil ]) = 'The Secret'
						ifFalse: [ ZnResponse badRequest: request ]
						ifTrue: [ request uri firstPathSegment = 'one'
								ifTrue: [ ZnResponse redirect: 'two' ]
								ifFalse: [ request uri firstPathSegment = 'two' ifTrue: [ ZnResponse ok: (ZnEntity text: 'OK!!') ] ifFalse: [ ZnResponse badRequest: request ] ] ] ].
			(client := ZnClient new)
				url: server localUrl;
				addPath: 'one';
				headerAt: 'X-Custom' put: 'The Secret';
				get.
			self assert: client isSuccess.
			self assert: client contents equals: 'OK!!'.
			client close ]! !

!ZnClientTest methodsFor: 'testing' stamp: ''!
testHeadSmallHTML
	| client |
	self withServerDo: [ :server |
		(client := ZnClient new)
			url: server localUrl;
			addPath: 'echo';
			head.
		self assert: client isSuccess.
		self assert: client response contentLength > 0.
		self assert: client response hasEntity not.
		client close ]! !

!ZnClientTransactionEvent commentStamp: ''!
ZnClientTransactionEvent is a ZnClientLogEvent that notes the completion of a client side HTTP transaction (request/response).

Instance Variables
	request: a ZnRequest
	requestDuration:	 milliseconds
	response:	a ZnResponse
	responseDuration: milliseconds
	
Note that this can be quite large since it includes the entities transferred. See ZnSimplifiedClientTransactionEvent for a more compact representation.!
!ZnClientTransactionEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream space.
	request requestLine printMethodAndUriOn: stream.
	stream space; print: response code.
	response hasEntity
		ifTrue: [ 
			stream space; print: response entity contentLength; nextPut: $B ].
	stream space; print: self duration; nextPutAll: 'ms'! !

!ZnClientTransactionEvent methodsFor: 'accessing' stamp: ''!
response: anObject
	response := anObject! !

!ZnClientTransactionEvent methodsFor: 'accessing' stamp: ''!
responseDuration: anObject
	responseDuration := anObject! !

!ZnClientTransactionEvent methodsFor: 'accessing' stamp: ''!
duration
	^ requestDuration + responseDuration! !

!ZnClientTransactionEvent methodsFor: 'accessing' stamp: ''!
requestDuration
	^ requestDuration! !

!ZnClientTransactionEvent methodsFor: 'accessing' stamp: ''!
response
	^ response! !

!ZnClientTransactionEvent methodsFor: 'accessing' stamp: ''!
responseDuration
	^ responseDuration! !

!ZnClientTransactionEvent methodsFor: 'accessing' stamp: ''!
requestDuration: anObject
	requestDuration := anObject! !

!ZnClientTransactionEvent methodsFor: 'accessing' stamp: ''!
request
	^ request! !

!ZnClientTransactionEvent methodsFor: 'accessing' stamp: ''!
request: anObject
	request := anObject! !

!ZnCodePointReadStream commentStamp: ''!
I am ZnCodePointReadStream.
I wrap another binary ReadStream and use a ZnCharacerEncoder to allow Integer code points to be read.

I am not positionable, but I do allow a one code point peek using a one code point internal buffer.

Part of Zinc HTTP Components.
!
!ZnCodePointReadStream methodsFor: 'accessing' stamp: ''!
collectionSpecies
	^ Array! !

!ZnCodePointReadStream methodsFor: 'private' stamp: ''!
nextElement
	^ self encoder nextCodePointFromStream: stream! !

!ZnCodePointWriteStream commentStamp: ''!
I am ZnCodePointWriteStream.
I wrap another binary WriteStream and use a ZnCharacerEncoder to allow Integer code points to be written.

Part of Zinc HTTP Components.!
!ZnCodePointWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: object
	self encoder 
		nextPutCodePoint: object 
		toStream: stream.
	^ object! !

!ZnCommonLogFormat commentStamp: ''!
I am ZnCommonLogFormat, I can output ZnServerTransactionEvent objects using Apache Common Log Format (CLF).

https://en.wikipedia.org/wiki/Common_Log_Format
https://httpd.apache.org/docs/trunk/logs.html#common

| formatter |
formatter := ZnCommonLogFormat new.
ZnLogEvent announcer 
  when: ZnServerTransactionEvent 
  do: [ :event | 
    formatter format: event on: Transcript.
    Transcript cr; endEntry ].
!
!ZnCommonLogFormat methodsFor: 'private' stamp: ''!
formatTimestamp: timestamp on: stream
	stream nextPut: $[.
	timestamp dayOfMonth printOn: stream base: 10 length: 2 padded: true.
	stream nextPut: $/.
	stream << timestamp monthAbbreviation.
	stream nextPut: $/.
	timestamp year printOn: stream.
	stream << $:.
	timestamp printHMSOn: stream.
	stream space.
	stream nextPut: (timestamp offset positive ifTrue: [ $+ ] ifFalse: [ $- ]).
	timestamp offset hours abs printOn: stream base: 10 length: 2 padded: true.
	stream nextPut: $:.
	timestamp offset minutes abs printOn: stream base: 10 length: 2 padded: true.
	stream nextPut: $]! !

!ZnCommonLogFormat methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	combined := true.! !

!ZnCommonLogFormat methodsFor: 'accessing' stamp: ''!
combined: boolean
	"If boolean is true (the default), use the 'Combined' format, 
	adding Referer and User-Agent fields."
	
	combined := boolean! !

!ZnCommonLogFormat methodsFor: 'public' stamp: ''!
format: event on: stream
	"Output a ZnServerTransactionEvent on a text stream in Common Log Format"
	
	stream << (self clientIPAddressFrom: event); << ' - '.
	stream << (self userFrom: event); space.
	self formatTimestamp: event timestamp on: stream.
	self formatRequest: event on: stream.
	self formatResponse: event on: stream. 
	combined ifTrue: [ self formatCombinedFields: event request on: stream ]! !

!ZnCommonLogFormat methodsFor: 'private' stamp: ''!
clientIPAddressFrom: event
	^ event request headers 
		at: ZnConstants remoteAddressHeader 
		ifAbsent: [ '-' ]! !

!ZnCommonLogFormat methodsFor: 'accessing' stamp: ''!
combined
	^ combined! !

!ZnCommonLogFormat methodsFor: 'private' stamp: ''!
formatResponse: event on: stream
	| size |
	stream space.
	stream print: event response code.
	stream space.
	size := event response hasEntity 
		ifTrue: [ event response contentLength ] 
		ifFalse: [ 0 ].
	stream print: size
! !

!ZnCommonLogFormat methodsFor: 'private' stamp: ''!
userFrom: event
	^ [ event request basicAuthentication first ]
		on: Error
		do: [ '-' ]! !

!ZnCommonLogFormat methodsFor: 'private' stamp: ''!
formatCombinedFields: request on: stream
	| referer userAgent |
	referer := request headers at: 'Referer' ifAbsent: [ '-' ].
	userAgent := request headers at: 'User-Agent' ifAbsent: [ '-' ].
	stream space.
	stream nextPut: $"; << referer; nextPut: $".
	stream space.
	stream nextPut: $"; << userAgent; nextPut: $"
! !

!ZnCommonLogFormat methodsFor: 'private' stamp: ''!
formatRequest: event on: stream
	| requestLine |
	stream space.
	requestLine := event request requestLine.
	stream << $".
	requestLine printMethodAndUriOn: stream.
	stream space; << requestLine version.
	stream << $"! !

!ZnConnectionAcceptedEvent commentStamp: ''!
ZnConnectionAcceptedEvent is signalled when an HTTP server accepts an incoming connection from a client at address.!
!ZnConnectionAcceptedEvent methodsFor: 'accessing' stamp: ''!
address: anObject
	address := anObject! !

!ZnConnectionAcceptedEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Connection Accepted '.
	address do: [ :each | stream print: each ] separatedBy: [ stream nextPut: $. ]! !

!ZnConnectionAcceptedEvent methodsFor: 'accessing' stamp: ''!
address
	^ address! !

!ZnConnectionEstablishedEvent commentStamp: ''!
ZnConnectionEstablishedEvent signals that a client HTTP connection to hostname:port (address:port) was established in duration milliseconds. This time includes DNS resolving.!
!ZnConnectionEstablishedEvent methodsFor: 'accessing' stamp: ''!
address: anObject
	address := anObject! !

!ZnConnectionEstablishedEvent methodsFor: 'accessing' stamp: ''!
duration: anObject
	duration := anObject! !

!ZnConnectionEstablishedEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Connection Established '; nextPutAll: hostname; nextPut: $:; print: port; space. 
	proxy ifNotNil: [ stream << 'via proxy '; print: proxy; space ].
	address do: [ :each | stream print: each ] separatedBy: [ stream nextPut: $. ].
	stream space; print: duration; << 'ms '.! !

!ZnConnectionEstablishedEvent methodsFor: 'accessing' stamp: ''!
port: anObject
	port := anObject! !

!ZnConnectionEstablishedEvent methodsFor: 'accessing' stamp: ''!
proxy
	^ proxy! !

!ZnConnectionEstablishedEvent methodsFor: 'accessing' stamp: ''!
duration
	^ duration! !

!ZnConnectionEstablishedEvent methodsFor: 'accessing' stamp: ''!
hostname
	^ hostname! !

!ZnConnectionEstablishedEvent methodsFor: 'accessing' stamp: ''!
proxy: anObject
	proxy := anObject! !

!ZnConnectionEstablishedEvent methodsFor: 'accessing' stamp: ''!
address
	^ address! !

!ZnConnectionEstablishedEvent methodsFor: 'accessing' stamp: ''!
hostname: anObject
	hostname := anObject! !

!ZnConnectionEstablishedEvent methodsFor: 'accessing' stamp: ''!
port
	^ port! !

!ZnConnectionTimeout commentStamp: ''!
I am ZnConnectionTimeout.
I am a DynamicVariable and a ProcessSpecificVariable.

I can be used to modify the global default socket IO timeout on a per process basis, for example:

ZnConnectionTimeout 
	value: 5 
	during: [ ^ ZnClient new get: 'http://zn.stfx.eu/zn/small.html' ]!
!ZnConstants commentStamp: ''!
I am ZnConstants, holding various constants that we use.

Part of Zinc HTTP Components.!
!ZnConstants class methodsFor: 'accessing' stamp: ''!
systemVersion
	^ SystemVersion current type , '/' , SystemVersion current dottedMajorMinor ! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
knownHTTPMethods
	^ #(
		"Standard HTTP 1.1 Verbs"
		GET PUT POST DELETE HEAD 
		TRACE OPTIONS CONNECT PATCH
		"WebDAV verbs"
		PROPFIND PROPPATCH MKCOL COPY MOVE LOCK UNLOCK)! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
defaultServerString 
	^ self frameworkNameAndVersion , ' (' , self systemVersion , ')'! !

!ZnConstants class methodsFor: 'class initialization' stamp: ''!
initialize
	"Forced source code change for automatic initialization: 20170510"
	
	self initializeHTTPStatusCodes! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
httpStatusCodes
	^ HTTPStatusCodes ! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
officialHTTPStatusCodesSpec 
	"This is the official list from http://www.iana.org/assignments/http-status-codes (version 2017-04-14)"

	^ #(
		"1xx: Informational - Request received, continuing process"
		100 'Continue'
		101 'Switching Protocols'
		102 'Processing'
		"2xx: Success - The action was successfully received, understood, and accepted"
		200 'OK'
		201 'Created'
		202 'Accepted'
		203 'Non-Authoritative Information'
		204 'No Content'
		205 'Reset Content'
		206 'Partial Content'
		207 'Multi-Status'
		208 'Already Reported'
		226 'IM Used'
		"3xx: Redirection - Further action must be taken in order to complete the request"
		300 'Multiple Choices'
		301 'Moved Permanently'
		302 'Found'
		303 'See Other'
		304 'Not Modified'
		305 'Use Proxy'
		307 'Temporary Redirect'
		308 'Permanent Redirect'
		"4xx: Client Error - The request contains bad syntax or cannot be fulfilled"
		400 'Bad Request'
		401 'Unauthorized'
		402 'Payment Required'
		403 'Forbidden'
		404 'Not Found'
		405 'Method Not Allowed'
		406 'Not Acceptable'
		407 'Proxy Authentication Required'
		408 'Request Timeout'
		409 'Conflict'
		410 'Gone'
		411 'Length Required'
		412 'Precondition Failed'
		413 'Payload Too Large'
		414 'URI Too Long'
		415 'Unsupported Media Type'
		416 'Requested Range Not Satisfiable'
		417 'Expectation Failed'
		421 'Misdirected Request'
		422 'Unprocessable Entity'
		423 'Locked'
		424 'Failed Dependency'
		426 'Upgrade Required'
		428 'Precondition Required'
		429 'Too Many Requests'
		431 'Request Header Fields Too Large'
		"5xx: Server Error - The server failed to fulfill an apparently valid request"
		500 'Internal Server Error'
		501 'Not Implemented'
		502 'Bad Gateway'
		503 'Service Unavailable'
		504 'Gateway Timeout'
		505 'HTTP Version Not Supported'
		506 'Variant Also Negotiates (Experimental)'
		507 'Insufficient Storage'
		508 'Loop Detected'
		510 'Not Extended'
		511 'Network Authentication Required'
	)! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
defaultUserAgent
	^ self frameworkNameAndVersion , ' (' , self systemVersion , ')'! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
frameworkNameAndVersion
	^ self frameworkName, ' ', self frameworkVersion ! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
remoteAddressHeader
	^ 'X-Zinc-Remote-Address'! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
defaultHTTPVersion
	^ 'HTTP/1.1'! !

!ZnConstants class methodsFor: 'resource limits' stamp: ''!
maximumLineLength
	"Return the maximum line length to accept.
	Used by ZnLineReader and thus for reading request/status lines as well as headers.
	This helps to protect us from malicious content."
	
	^ 4096! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
faviconBytes
	^ #(0 0 1 0 1 0 16 16 16 0 0 0 0 0 40 1 0 0 22 0 0 0 40 0 0 0 16 0 0 0 32 0 0 0 1 0 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 0 0 189 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 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 17 17 17 1 16 1 16 1 17 17 17 1 16 1 16 1 16 0 0 1 16 1 16 0 17 0 0 1 16 1 16 0 1 16 0 1 16 1 16 0 0 17 0 1 17 17 16 0 0 1 16 1 1 17 0 0 0 0 17 0 0 0 0 1 17 17 17 0 0 0 0 1 17 17 17 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) asByteArray! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
frameworkName
	^ 'Zinc HTTP Components'! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
frameworkLicense
	"http://en.wikipedia.org/wiki/MIT_License"
	
	^ 'MIT License'! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
knownHTTPVersions
	^ #('HTTP/1.1' 'HTTP/1.0')! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
frameworkMCVersion
	MCWorkingCopy managersForClass: self class do: [ :each | ^ each ancestors first name ]! !

!ZnConstants class methodsFor: 'accessing' stamp: ''!
frameworkVersion
	^ '1.0'! !

!ZnConstants class methodsFor: 'private' stamp: ''!
initializeHTTPStatusCodes 
	HTTPStatusCodes := Dictionary newFromPairs: self officialHTTPStatusCodesSpec ! !

!ZnCookie commentStamp: ''!
I represent an HTTP Cookie, a small piece of data sent by an HTTP web server to an HTTP user-agent client and by the client to the same server afterwards, to remember stateful information across indepedent request/responses.

References

https://en.wikipedia.org/wiki/HTTP_cookie
https://tools.ietf.org/html/rfc6265

Part of Zinc HTTP Components.!
!ZnCookie methodsFor: 'private' stamp: ''!
extraAttributes
	"Answer all attributes except name and value"
	^ attributes associationsSelect: [ :ea | (ea key = 'name' or: [ ea key = 'value' ]) not ]! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
expiresTimeStamp
	"Return the DateAndTime when I will expire.
	Throw an exception when no expiration is set or the expiration cannot be parsed.
	See #isExpired"
	
	^ ZnUtils parseHttpDate: self expires! !

!ZnCookie methodsFor: 'converting' stamp: ''!
nameValueString
	^ String streamContents: [ :stream | 
		self writeNameAndValueOn: stream ]! !

!ZnCookie methodsFor: 'comparing' stamp: ''!
= aCookie
	(aCookie isKindOf: self class) ifFalse: [ ^ false ].
	^ (aCookie name = self name) & (aCookie path = self path) & (aCookie domain = self domain)
	! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
value: aValue
	attributes at: 'value' put: aValue! !

!ZnCookie methodsFor: 'comparing' stamp: ''!
hash
	^ (self name hash bitXor: self path hash) bitXor: self domain hash! !

!ZnCookie methodsFor: 'printing' stamp: ''!
writeExtraAttributesOn: aStream
	self extraAttributes
		associationsDo: [ :ea | 
			aStream
				nextPutAll: '; ';
				nextPutAll: ea key.
			(ea value isKindOf: Boolean)
				ifFalse: [ 
					aStream
						nextPutAll: '=';
						nextPutAll: ea value ] ]! !

!ZnCookie methodsFor: 'printing' stamp: ''!
writeOn: aStream
	self
		writeNameAndValueOn: aStream;
		writeExtraAttributesOn: aStream ! !

!ZnCookie methodsFor: 'initialize-release' stamp: ''!
readAttribute: aToken
	| i key data |
	i := aToken indexOf: $=.
	i > 0
		ifTrue: [
			key := (aToken copyFrom: 1 to: i - 1) trimBoth asLowercase.
			data := (aToken copyFrom: i + 1 to: aToken size) trimBoth ]
		ifFalse: [ 
			key := (aToken copyFrom: 1 to: aToken size) trimBoth asLowercase.
			data := true ].
	attributes at: key put: data! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
maxage
	^ attributes at: 'max-age' ifAbsent: [ nil ]! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
path: aPath
	attributes at: 'path' put: aPath! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
httponly
	"This is not an RFC cookie attribute, but a supplement found in MS Internet Explorer and supported in PHP.
	 See http://msdn.microsoft.com/en-us/library/ms533046.aspx"
	^ attributes at: 'httponly' ifAbsent: [ false ]! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
expiresTimeStamp: dateAndTime
	self expires: (ZnUtils httpDate: dateAndTime)! !

!ZnCookie methodsFor: 'testing' stamp: ''!
hasAttribute: attributeName
	^ attributes includesKey: attributeName asLowercase ! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
httponly: aBoolean
	attributes at: 'httponly' put: aBoolean! !

!ZnCookie methodsFor: 'testing' stamp: ''!
isExpired
	| expirationTimeStamp |
	(self hasAttribute: 'expire') ifFalse: [ ^ false ].
	[ expirationTimeStamp := self expiresTimeStamp ] on: Error do: [ ^ false ].
	"note that max-age (#maxage) is not used"
	^ expirationTimeStamp asUTC < DateAndTime now asUTC! !

!ZnCookie methodsFor: 'printing' stamp: ''!
printOn: stream
	self writeOn: stream! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
name: aName
	attributes at: 'name' put: aName! !

!ZnCookie methodsFor: 'printing' stamp: ''!
writeNameAndValueOn: aStream
	aStream
		nextPutAll: self name;
		nextPutAll: '=';
		nextPutAll: self value! !

!ZnCookie methodsFor: 'testing' stamp: ''!
isInPath: urlObject
	^ urlObject pathPrintString includesSubstring: self path
	! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
path
	^ attributes at: 'path' ifAbsent: [ '/' ]! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
expires: anExpiration
	attributes at: 'expires' put: anExpiration! !

!ZnCookie methodsFor: 'initialize-release' stamp: ''!
fromString: aString
	| tokens val data i |
	tokens := aString substrings: ';'.
	i := tokens first indexOf: $=.
	val := tokens first copyFrom: 1 to: i - 1.
	data := tokens first copyFrom: i + 1 to: tokens first size. 
	self name: val trimBoth; value: data trimBoth.
	2 to: tokens size do: [ :index | 
		self readAttribute: (tokens at: index) ]! !

!ZnCookie methodsFor: 'converting' stamp: ''!
fullString
	^ String streamContents: [ :stream | 
		self writeOn: stream ]! !

!ZnCookie methodsFor: 'initialization' stamp: ''!
initialize 
	attributes := Dictionary new.! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
domain: aDomain
	attributes at: 'domain' put: aDomain! !

!ZnCookie methodsFor: 'initialize-release' stamp: ''!
defaultDomain: aDomain
	self domain ifNil: [ self domain: aDomain ]! !

!ZnCookie methodsFor: 'testing' stamp: ''!
isInDomain: urlObject
	| domain |
	domain := (self domain beginsWith: '.')
		ifTrue: [ self domain copyFrom: 2 to: self domain size ]
		ifFalse: [ self domain ].
	^ urlObject host includesSubstring: domain
	! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
domain
	^ attributes at: 'domain' ifAbsent: [ nil ]! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
value
	^ attributes at: 'value' ifAbsent: [ nil ]! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
name
	^ attributes at: 'name'! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
secure
	^ attributes at: 'secure' ifAbsent: [ false ]! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
secure: aBoolean
	attributes at: 'secure' put: aBoolean! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
maxage: numberOfSeconds
	"To be able to use this to validate expiration, a time of creation has to be recorded, so right now, this is not really usable."
	
	^ attributes at: 'max-age' put: numberOfSeconds asString! !

!ZnCookie methodsFor: 'accessing' stamp: ''!
expires
	^ attributes at: 'expires' ifAbsent: [ nil ]! !

!ZnCookie class methodsFor: 'instance creation' stamp: ''!
fromString: aString
	^ self new 
		fromString: aString; 
		yourself! !

!ZnCookie class methodsFor: 'instance creation' stamp: ''!
name: nameString value: value
	^ self new
		name: nameString;
		value: value;
		yourself! !

!ZnCookie class methodsFor: 'instance creation' stamp: ''!
fromString: aString for: urlObject
	| cookie |
	cookie := self fromString: aString.
	"Ensures a domain value if none provided by the cookie"
	cookie defaultDomain: urlObject host.
	^ cookie! !

!ZnCookieJar commentStamp: ''!
I represent a container for storing HTTP Cookies for a client session.

Part of Zinc HTTP Components.!
!ZnCookieJar methodsFor: 'accessing' stamp: ''!
add: aCookie
	(self removeIfExpired: aCookie) ifTrue: [ ^ nil ].
	self cookies do: [ :cookie |
		cookie = aCookie ifTrue: [ self cookies remove: cookie ] ].
	self cookies add: aCookie
	! !

!ZnCookieJar methodsFor: 'accessing' stamp: ''!
cookiesForUrl: urlObject
	^ self cookies select: [ :cookie | 
		(cookie isExpired not) & (cookie isInDomain: urlObject) & (cookie isInPath: urlObject) ]! !

!ZnCookieJar methodsFor: 'accessing' stamp: ''!
cookies 
	^ cookies ifNil: [ cookies := Bag new ]! !

!ZnCookieJar methodsFor: 'accessing' stamp: ''!
cookieAt: aName forUrl: urlObject
	(self cookiesForUrl: urlObject) do: [ :cookie | cookie name = aName ifTrue: [ ^ cookie ] ].
	^ nil! !

!ZnCookieJar methodsFor: 'operations' stamp: ''!
removeAll
	cookies ifNotNil: [ cookies removeAll ]! !

!ZnCookieJar methodsFor: 'accessing' stamp: ''!
remove: aCookie
	self cookies remove: aCookie ifAbsent: [ nil ]! !

!ZnCookieJar methodsFor: 'operations' stamp: ''!
removeIfExpired: aCookie
	^ aCookie isExpired 
		ifTrue: [ 
			self remove: aCookie. 
			true ]
		ifFalse: [
			false ]! !

!ZnCrPortableWriteStream commentStamp: ''!
I am a write stream wrapping a second stream. Whenever they ask me to write a cr, a lf, or a crlf I'll instead print a portable new line depending on the platform I'm on.

stream := '' writeStream.
converter := ZnCrPortableWriteStream on: stream.
converter cr; cr; lf; nextPut: $a.
stream contents!
!ZnCrPortableWriteStream methodsFor: 'accessing' stamp: ''!
stream: aWriteStream 
	stream := aWriteStream! !

!ZnCrPortableWriteStream methodsFor: 'accessing' stamp: ''!
newLine
	previous := nil.
	stream nextPutAll: OSPlatform current lineEnding! !

!ZnCrPortableWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: aCharacter
	"Write aCharacter to the receivers stream.
	Convert all line end combinations, i.e cr, lf, crlf, to the platform convention"

	(previous == cr and: [ aCharacter == lf ]) ifFalse: [
		(aCharacter == cr or: [ aCharacter == lf ]) ifTrue: 
			[ self newLine ]
		ifFalse:
			[ stream nextPut: aCharacter ] ].
	previous := aCharacter.
! !

!ZnCrPortableWriteStream methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.
	cr := Character cr.
	lf := Character lf.! !

!ZnCrPortableWriteStream class methodsFor: 'instance creation' stamp: ''!
on: aStream

	^ self basicNew
		initialize;
		stream: aStream;
		yourself! !

!ZnCrPortableWriteStreamTest methodsFor: 'tests' stamp: ''!
testNextPut
	"Ensure that the line ends are written correctly"

	| expectedString stream crStream |

	expectedString := 'a', OSPlatform current lineEnding, 'b'.
	{ String cr.
		String lf.
		String crlf. } do: [ :lineEnd |
			stream := String new writeStream.
			crStream := ZnNewLineWriterStream on: stream.
			crStream
				<< 'a';
				<< lineEnd;
				<< 'b'.
			self assert: stream contents equals: expectedString ]! !

!ZnCredential commentStamp: ''!
I am ZnCredential, an abstract class representing credentials in a domain and realm.

Part of Zinc HTTP Components.!
!ZnCredential methodsFor: 'accessing' stamp: ''!
domain: anObject
	domain := anObject! !

!ZnCredential methodsFor: 'accessing' stamp: ''!
setAuthorizationHeader: headers for: urlObject method: method
	headers at: 'Authorization' put: self authToken! !

!ZnCredential methodsFor: 'accessing' stamp: ''!
realm: anObject
	realm := anObject! !

!ZnCredential methodsFor: 'testing' stamp: ''!
isComplete
	^ self subclassResponsibility ! !

!ZnCredential methodsFor: 'accessing' stamp: ''!
realm
	^ realm ifNil: [ realm := '' ]! !

!ZnCredential methodsFor: 'accessing' stamp: ''!
domain
	^ domain! !

!ZnCredential methodsFor: 'accessing' stamp: ''!
authTokenForUrl: urlObject method: method
	self subclassResponsibility ! !

!ZnCredential methodsFor: 'accessing' stamp: ''!
authToken
	^ self authTokenForUrl: nil method: nil ! !

!ZnCredential methodsFor: 'operations' stamp: ''!
linkToAuthRequest: aHeader
	"Link this credential to the WWW-Authenticate request in the provided header. 
	Used for authentication methods which require parameters provided by the server
	(e.g. Digest authentication)."
	realm := self class findRealmFor: aHeader! !

!ZnCredential class methodsFor: 'accessing' stamp: ''!
authName
	self subclassResponsibility ! !

!ZnCredential class methodsFor: 'accessing' stamp: ''!
findRealmFor: anAuthHeader
	(anAuthHeader substrings: ',') do: [ :token |
		"String>>trimBoth: is a grease method, so not sure if we should be using it."
		(token includesSubstring: 'realm=') 
			ifTrue: [ ^ ((token substrings: '=') second) ] ].
	^ nil! !

!ZnCredential class methodsFor: 'accessing - class hierarchy' stamp: ''!
findHandlerFor: anAuthHeader
	| type i |
	i := anAuthHeader indexOf: Character space.
	type := anAuthHeader copyFrom: 1 to: i - 1.
	self allSubclassesDo: [ :subclass |
		subclass authName = type ifTrue: [ ^ subclass ] ].
	^ nil! !

!ZnCurrentServer commentStamp: ''!
I am ZnCurrentServer.
I am a DynamicVariable and a ProcessSpecificVariable.

I hold a reference to the current ZnServer instance during HTTP processing, during the dynamic scope of #handleRequest:!
!ZnCurrentServerSession commentStamp: ''!
I am ZnCurrentServerSession.
I am a ProcessLocalVariable and a ProcessSpecificVariable.

I hold a reference to the current ZnServerSession instance during HTTP processing, during the dynamic scope of #handleRequest:

ZnServerSessions are created lazily.
!
!ZnDefaultCharacterEncoder commentStamp: ''!
I am ZnDefaultCharacterEncoder.
I am a DynamicVariable and a ProcessSpecificVariable.

I can be used to modify the default ZnCharacteEncoder on a per process basis, for example:

ZnDefaultCharacterEncoder 
	value: ZnUTF8Encoder latin1
	during: [ ZnClient new get: 'http://zn.stfx.eu/zn/small.html' ]!
!ZnDefaultCharacterEncoder methodsFor: 'accessing' stamp: ''!
default
	^ ZnCharacterEncoder utf8
! !

!ZnDefaultServerDelegate commentStamp: ''!
I am ZnDefaultServerDelegate.
I function as a delegate for ZnServer, implementing #handleRequest:

I implement responses to the following prefixes:

/echo - an echo text of request information for debugging purposes
/dw-bench - a dynamic html page for benchmarking purposes
/unicode - a unicode test page
/random - a random string (/random/32 for a specific size)
/bytes - bytes according to a pattern (/bytes/32 for a specific size)
/favicon.ico - a Zn favicon
/status - a server status page
/error - force server errors
/session - a simpler session based counter
/help - lists all page prefixes
/ - an html welcome page

Without any matches, I respond with a page not found.

I can be reused without any default handlers mapped using #empty and configured using #map:to: where the second argument can be a block.

Part of Zinc HTTP Components.!
!ZnDefaultServerDelegate methodsFor: 'public' stamp: ''!
value: request
	"I implement the generic #value: message as equivalent to #handleRequest:"
	
	^ self handleRequest: request! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
formTest1: request
	| input page |
	input := request uri queryAt: #input ifAbsent: [ 'input' ].
	page := ZnHtmlOutputStream streamContents: [ :html |
		html page: 'Form Test 1' do: [ 
			html 
				tag: #form 
				attributes: #(action 'form-test-1' 'accept-charset' 'utf-8' method GET) 
				do: [ 
					html 
						str: 'Input'; space;
						tag: #input attributes: { #type. #input. #name. #input. #value. input }; space;
						tag: #input attributes: #(type submit); 
						str: 'for input'; space; tag: #em with: input ] ] ].
	^ ZnResponse ok: (ZnEntity html: page)! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
dwbench: request
	"Reply with the dynamic DW-Bench HTML page"

	^ ZnResponse ok: (ZnEntity html: self generateDWBench)! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
generateHelp
	"Generate an HTML page with links to all pages I support"
	
	^ ZnHtmlOutputStream streamContents: [ :html |
		html page: (self class name, ' Help') do: [  	
			html tag: #h3 with: 'Available Pages'.
			html tag: #ul do: [
				prefixMap keys sorted do: [ :each | 
					html tag: #li do: [ 
						html tag: #a attributes: { #href. each } with: each ] ] ] ] ]! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
generateStatus
	"Generate an HTML page with the state of the server"
	
	^ ZnHtmlOutputStream streamContents: [ :html |
		html page: 'ZnServer Status' do: [
			html tag: #p do: [ html << 'I am '; print: ZnCurrentServer value ].
			html tag: #p with: self systemVersionInfo.
			html tag: #pre with: self vmStats.
			html tag: #h1 with: 'Processes'.
			html tag: #ol do: [ 
				self processes do: [ :each |
					html tag: #li do: [ 
						html 
							str: each name; space; nextPut: $[; print: each priority; nextPut: $]; 
							tag: #br; str: each printString ] ] ] ] ]! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
welcome: request
	"Answer a nice HTML welcome page"
	
	| page entity |
	page := self generateWelcomePage.
	entity := ZnEntity html: page. 
	^ ZnResponse ok: entity! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
formTest2: request
	| input page |
	input := 'input'.
	(request hasEntity and: [ request contentType matches: ZnMimeType applicationFormUrlEncoded  ])
		ifTrue: [ input := request entity at: #input ifAbsent: [ 'input' ] ].
	page := ZnHtmlOutputStream streamContents: [ :html |
		html page: 'Form Test 2' do: [ 
			html 
				tag: #form 
				attributes: #(action 'form-test-2' 'accept-charset' 'utf-8' method POST) 
				do: [ 
					html 
						str: 'Input'; space;
						tag: #input attributes: { #type. #input. #name. #input. #value. input }; space;
						tag: #input attributes: #(type submit); 
						str: 'for input'; space; tag: #em with: input ] ] ].
	^ ZnResponse ok: (ZnEntity html: page)! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
bytes: request
	"Answer a number of bytes according to a pattern as an application/octet-stream.
	Optionally take the size from the URI, as in /bytes/32 for 32 bytes, default to 64 bytes.
	The main goal is to be efficient, esp. in benchmarks, that's why we cache (non-thread-safe)"
	
	| count |
	count := Integer readFrom: request uri lastPathSegment ifFail: [ 64 ].
	(byteArray isNil or: [ byteArray size ~= count ]) 
		ifTrue: [
			byteArray := ByteArray new: count.
			1 to: count - 1 do: [ :each | 
				byteArray at: each put: (#(65 66 67 68) at: (each \\ 4 + 1)) ].
			byteArray at: count put: 10 ].
	^ ZnResponse ok: (ZnEntity bytes: byteArray)! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
sessionRequest: request	
	"An HTML response that uses a session"
	
	| session hitCount |
	session := request session.
	hitCount := session attributeAt: #hitCount ifAbsent: [ 0 ].
	hitCount := hitCount + 1.
	session attributeAt: #hitCount put: hitCount. 
	^ ZnResponse ok: (ZnEntity html: (self generateSessionRequest: session))! !

!ZnDefaultServerDelegate methodsFor: 'accessing' stamp: ''!
prefixMap
	^ prefixMap ifNil: [ prefixMap := Dictionary new ]! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
favicon: request
	"Answer a nice favicon for browsers to display"

	| entity |
	entity := ZnEntity with: ZnConstants faviconBytes type: 'image/vnd.microsoft.icon'. 
	^ ZnResponse ok: entity! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
generateDWBench
	"Generate the dynamic DW-Bench HTML page.
	Although the date/time is variable, the page size is constant."
	
	^ ZnHtmlOutputStream streamContents: [ :html |
		html page: 'DW-Bench Dynamic' do: [ 
			html tag: #table attributes: #(border 1) do: [
				1 to: 25 do: [ :row |
					html tag: #tr do: [
						1 to: 25 do: [ :col |
							html tag: #td do: [ html print: row * col ] ] ] ] ].
			html tag: #p do: [ 
				html << Date today yyyymmdd; space; << Time now print24 ] ] ]! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
status: request
	"Reply with a dynamic HTML page describing the state of the server"

	^ ZnResponse ok: (ZnEntity html: self generateStatus)
	! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
generateWelcomePage
	^ ZnHtmlOutputStream streamContents: [ :html |
		html html5; tag: #html do: [
			html tag: #head do: [
				html tag: #title with: 'Zinc HTTP Components'.
				html tag: #style attributes: #(type 'text/css') with: self welcomePageCss ].
		html tag: #body do: [ 
			html tag: #div id: #logo with: #Zn.
			html tag: #h1 with: 'Zinc HTTP Components'.
			html tag: #p with: self welcomePageGreeting.
			self welcomePageLinksOn: html.
			html tag: #h4 with: 'May the Source be with you!!' ] ] ]! !

!ZnDefaultServerDelegate methodsFor: 'accessing' stamp: ''!
map: prefix to: handler
	"Arrange for the receiver to dispatch requests matching prefix to handler.
	Handler can be a symbol naming a method in the receiver, 
	or a block accepting the request and producing the response.
	The special prefix '/' is resolved first and can refer to another prefix."
	
	self prefixMap 
		at: prefix
		put: handler
		! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
small: request
	| page |
	page := ZnHtmlOutputStream streamContents: [ :html |
		html page: #Small do: [ 
			html tag: #p with: 'This is a small HTML document' ] ].
	^ ZnResponse ok: (ZnEntity html: page)! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
formTest3: request
	| contents filename contentType page |
	contents := filename := contentType := ''.
	(request hasEntity and: [ request contentType matches: ZnMimeType multiPartFormData ])
		ifTrue: [ 
			(request entity partNamed: #file ifNone: [ nil ]) 
				ifNotNil: [ :part |
					filename := part fileName.
					contents := part contents.
					contentType := part  contentType.
					contentType isBinary ifTrue: [ contents := contents hex ] ] ].
	page := ZnHtmlOutputStream streamContents: [ :html |
		html page: 'Form Test 3' do: [ 
			html 
				tag: #form 
				attributes: #(action 'form-test-3' 'accept-charset' 'utf-8' 
									enctype 'multipart/form-data' method POST) 
				do: [ 
					html 
						str: 'File'; space;
						tag: #input attributes: #(type file name file); space;
						tag: #input attributes: #(type submit) ];
				tag: #p do: [ html str: 'filename = '; str: filename ];
				tag: #p do: [ html str: 'content-type = '; str: contentType asString ];
				tag: #p do: [ html str: 'contents = '; str: contents asString ] ] ].
	^ ZnResponse ok: (ZnEntity html: page)! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
welcomePageGreeting
	^ 'Welcome to Zinc HTTP Components, a modern, open-source Smalltalk framework to deal with the HTTP networking protocol.'! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
systemVersionInfo
	^ String streamContents: [ :stream |
			stream 
				print: SystemVersion current; 
				nextPutAll: ' - '; 
				nextPutAll: ZnConstants defaultServerString ]
	! !

!ZnDefaultServerDelegate methodsFor: 'initialization' stamp: ''!
initialize
	self
		map: 'welcome' to: #welcome:;
		map: 'help' to: #help:;
		map: 'echo' to: #echoRequest:;
		map: 'small' to: #small:;
		map: 'dw-bench' to: #dwbench:;
		map: 'favicon.ico' to: #favicon:;
		map: 'random' to: #random:;
		map: 'bytes' to: #bytes:;
		map: 'status' to: #status:;
		map: 'unicode' to: #unicode:;
		map: 'session' to: #sessionRequest:;
		map: 'error' to: #errorResponse:;
		map: 'form-test-1' to: #formTest1:;
		map: 'form-test-2' to: #formTest2:;
		map: 'form-test-3' to: #formTest3:;
		map: '/' to: 'welcome'! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
unicode: request
	"Answer a Unicode Test HTML page"
	
	^ ZnResponse ok: (ZnEntity html: self generateUnicodeTest)! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
vmStats
	^ SmalltalkImage current vm statisticsReport! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
generateUnicodeTest
	"Generate an HTML page containing all Unicode characters with code points between 0 and 16r024F in a nice table"
	
	^ ZnHtmlOutputStream streamContents: [ :html |
		html page: 'Unicode Test Page' do: [ 
			html tag: #table do: [
				0 to: 16r024F by: 8 do: [ :row |
					html tag: #tr do: [
					row to: row + 7 do: [ :each |
						html tag: #td do: [ 
							html 
								nextPutAll: 'U+'; nextPutAll: (each printPaddedWith: $0 to: 4 base: 16);
								nextPut: $=; nextPut: each asCharacter ] ] ] ] ] ] ]! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
help: request
	"Reply with a dynamic HTML page containing links to all pages I support"

	^ ZnResponse ok: (ZnEntity html: self generateHelp)
	! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
generateSessionRequest: session
	"Generate an HTML page using a session"
	
	^ ZnHtmlOutputStream streamContents: [ :html |
		html page: 'Session' do: [ 
			html tag: #p do: [ html << 'I am using '; str: session asString ].
			html tag: #p do: [ html << 'Current session id is ' << session id ].
			html tag: #p do: [ html << 'Session hit count ' << (session attributeAt: #hitCount) asString ] ] ]! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
welcomePageCss
	^ Character space join: 
	'body { color: black; background: white; width: 900px; font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 13px }
p { width: 600px; padding: 0 20px 10px 20px }
ul, ol { width: 600px; padding: 0 5px 5px 30px } 
#logo { color: orange; font-family: Helvetica, sans-serif; font-weight: bold; font-size: 100px }' lines! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
errorResponse: request
	"Here we artificially signal an Error at the Smalltalk level,
	optionally with a user defined message."
	
	| message |
	message := request uri queryAt: 'message' ifAbsent: [ 'An artificial error' ].
	Error signal: message! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
welcomePageLinksOn: html
	html tag: #ul do: [ 
		html tag: #li do: [ 
			html 
				str: 'Project homepage'; space;  
				tag: #a attributes: #(href 'http://zn.stfx.eu') with: 'http://zn.stfx.eu' ].
		html tag: #li do: [ 
			html 
				str: 'Locally available pages'; space;  
				tag: #a attributes: #(href '/help') with: '/help' ] ]! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
generateEchoRequestString: request
	"Generate a string echoing the request"
	
	^ String streamContents: [ :stream |
		stream nextPutAll: 'This is Zinc HTTP Components echoing your request !!'; crlf.
		stream nextPutAll: 'Running '; print: request server; crlf.
		stream nextPutAll: request method; nextPutAll: ' request for '.
		request uri printPathQueryFragmentOn: stream.
		stream crlf; nextPutAll: 'with headers'; crlf.
		request headersDo: [ :key :value |
			stream space; nextPutAll: key; nextPutAll: ': '; nextPutAll: value; crlf ].
		request hasEntity ifTrue: [
			stream nextPutAll: ' containing '; print: request entity ] ]! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
random: request
	"Answer a text plain UTF-8 encoded string of random hex characters.
	Optionally take the size from the URI, as in /random/32 for 32 characters.
	Default to 64 characters with a newline at the end"
	
	| count hexString |
	count := Integer readFrom: request uri lastPathSegment ifFail: [ 64 ].
	hexString := String new: count streamContents: [ :stream |
		count - 1 timesRepeat: [ stream nextPut: '0123456789ABCDEF' atRandom ].
		stream lf ].
	^ ZnResponse ok: (ZnEntity text: hexString)! !

!ZnDefaultServerDelegate methodsFor: 'responses' stamp: ''!
echoRequest: request	
	"Echo request by generating a plain text response useful for debugging purposes"
	
	| delay info entity |
	delay := Integer readFrom: (request uri queryAt: 'delay' ifAbsent: [ '' ]) ifFail: [ 0 ].
	delay > 0 ifTrue: [ (Delay forSeconds: delay) wait ].  
	info := self generateEchoRequestString: request.
	entity := ZnEntity textCRLF: info.
	^ ZnResponse ok: entity! !

!ZnDefaultServerDelegate methodsFor: 'public' stamp: ''!
handleRequest: request
	| prefix prefixHandler |
	prefix := request uri isSlash
		ifTrue: [ prefixMap at: '/' ifAbsent: [ nil ] ]
		ifFalse: [ request uri firstPathSegment ].
	prefixHandler := prefixMap at: prefix ifAbsent: [ nil ].
	prefixHandler isNil
		ifFalse: [ 
			^ prefixHandler isSymbol
				ifTrue: [ self perform: prefixHandler with: request ]
				ifFalse: [ prefixHandler value: request ] ].
	^ ZnResponse notFound: request uri! !

!ZnDefaultServerDelegate methodsFor: 'private' stamp: ''!
processes
	^ (Process allSubInstances
		reject: [ :each | each isTerminated or: [ each = Processor activeProcess ] ])
		sorted: [ :a :b | a priority >= b priority ] ! !

!ZnDefaultServerDelegate class methodsFor: 'instance creation' stamp: ''!
new
	^ super new initialize! !

!ZnDefaultServerDelegate class methodsFor: 'instance creation' stamp: ''!
empty
	^ self basicNew! !

!ZnDigestAuthenticator commentStamp: ''!
I am ZnDigestAuthenticator.
I help servers handle HTTP Digest Authentication.

I have a nonces dictionary with nonce->opaque associations. 
I generate a new nonce value for every 401 response I trigger.

Part of Zinc HTTP Components.!
!ZnDigestAuthenticator methodsFor: 'private' stamp: ''!
createOpaque
	| pt |
	pt := Random new next asString, ':', DateAndTime now asString.
	^ self class md5Hash: pt! !

!ZnDigestAuthenticator methodsFor: 'private' stamp: ''!
a1for: username
	| password |
	password := credentials at: username ifAbsent: [ ^ nil ].
	^ self class md5Hash: username, ':', self realm, ':', password
	! !

!ZnDigestAuthenticator methodsFor: 'accessing' stamp: ''!
nonces 
	^ nonces ifNil: [ nonces := Dictionary new ]! !

!ZnDigestAuthenticator methodsFor: 'public' stamp: ''!
authHeader
	| nonce opaque |
	nonce := self createNonce.
	opaque := self createOpaque.
	self nonces at: nonce put: opaque.
	^ 'Digest realm="', self realm, '", nonce="', nonce, '", opaque="', opaque, '"'! !

!ZnDigestAuthenticator methodsFor: 'private' stamp: ''!
createNonce
	| pt |
	pt := DateAndTime now asString, ':', Random new next asString.
	^ self class md5Hash: pt! !

!ZnDigestAuthenticator methodsFor: 'testing' stamp: ''!
isRequestAuthenticated: request
	| authorization response cresponse a1 a2 nonce opaque |
	authorization := self class parseAuthRequest: (request headers at: 'Authorization' ifAbsent: [ ^ false ]).
	nonce := authorization at: 'nonce' ifAbsent: [ ^ false ].
	opaque := self nonces at: nonce ifAbsent: [ ^ false ].
	a1 := self a1for: (authorization at: 'username' ifAbsent: [ ^ false ]).
	a1 ifNil: [ ^ false ].
	a2 := self a2forUrl: (authorization at: 'uri' ifAbsent: [ '/' ]) method: request method.
	response := self class md5Hash: (a1, ':', nonce, ':', a2).
	"(opaque = (authorization at: 'opaque' ifAbsent: [^false])) ifFalse: [^false]."
	cresponse := authorization at: 'response' ifAbsent: [ ^ false ].
	^ (response = cresponse)! !

!ZnDigestAuthenticator methodsFor: 'private' stamp: ''!
a2forUrl: uri method: method
	^ self class md5Hash: method, ':', uri
	! !

!ZnDigestAuthenticator class methodsFor: 'accessing' stamp: ''!
md5Hash: aString
	| hash env|
	env := self environment.
	"Answer hash of aString as lowercase 32 digit hex String."
	env at: #MD5 ifPresent: [ :cls |
		^ ((cls new initialize) hashStream: (aString asByteArray readStream)) hex ].
	hash := env at: #CMD5Hasher ifPresent: [ :cls |
		cls hashMessage: aString ].
	hash ifNil: [
		hash := env at: #TCryptoRandom ifPresent: [ :cls |
			(cls basicNew perform: #md5HashMessage: with: aString) asInteger ] ].
	hash ifNotNil: [
		hash := hash hex asLowercase.
		(hash beginsWith: '16r') ifTrue: [ hash := hash allButFirst: 3 ].
		hash := hash padLeftTo: 32 with: $0 ].
	^ hash
! !

!ZnDigestAuthenticator class methodsFor: 'testing' stamp: ''!
hasMD5Support
	^ (self md5Hash: 'test') isNil not! !

!ZnDigestAuthenticator class methodsFor: 'accessing' stamp: ''!
parseAuthRequest: headerValue
	| data dict |
	dict := Dictionary new.
	"Chops off the ' Digest ' scheme name, a bit too brittle."
	data := headerValue copyFrom: 8 to: headerValue size.
	(data substrings: ',') do: [ :fragment | | tokens i key value |
		tokens := fragment trimBoth.
		i := tokens indexOf: $=.
		(i > 0) ifTrue: [
			key := tokens copyFrom: 1 to: i - 1.
			value := tokens copyFrom: i + 1 to: tokens size.  
			dict at: key put: (value trimBoth: [ :char | char = $" ]) ] ].
	^ dict! !

!ZnDigestAuthenticatorTest methodsFor: 'testing' stamp: ''!
testParseEmpty
	| keys headerValue |
	headerValue := ' Digest username="Mufasa",
                     realm="testrealm@host.com",
                     nonce="dcd98b7102dd2f0e8b11d0f600bfb0c093",
                     uri="/dir/index.html",
                     qop=,
                     nc="",
                     cnonce="0a4f113b",
                     response="6629fae49393a05397450978507c4ef1",
                     opaque="5ccc069c403ebaf9f0171e9517f40e41"'.
	keys := ZnDigestAuthenticator parseAuthRequest: headerValue.
	self assert: (keys at: 'username') equals: 'Mufasa'.
	self assert: (keys at: 'realm') equals: 'testrealm@host.com'.
	self assert: (keys at: 'qop') equals: ''.
	self assert: (keys at: 'nc') equals: ''.
	self assert: (keys at: 'cnonce') equals: '0a4f113b'.
	self assert: (keys at: 'response') equals: '6629fae49393a05397450978507c4ef1'.
	! !

!ZnDigestAuthenticatorTest methodsFor: 'testing' stamp: ''!
testParseOK
	| keys headerValue |
	headerValue := ' Digest username="Mufasa",
                     realm="testrealm@host.com",
                     nonce="dcd98b7102dd2f0e8b11d0f600bfb0c093",
                     uri="/dir/index.html",
                     qop=auth,
                     nc=00000001,
                     cnonce="0a4f113b",
                     response="6629fae49393a05397450978507c4ef1",
                     opaque="5ccc069c403ebaf9f0171e9517f40e41"'.
	keys := ZnDigestAuthenticator parseAuthRequest: headerValue.
	self assert: (keys at: 'username') equals: 'Mufasa'.
	self assert: (keys at: 'realm') equals: 'testrealm@host.com'.
	self assert: (keys at: 'qop') equals: 'auth'.
	self assert: (keys at: 'nc') equals: '00000001'.
	self assert: (keys at: 'cnonce') equals: '0a4f113b'.
	self assert: (keys at: 'response') equals: '6629fae49393a05397450978507c4ef1'.
	! !

!ZnDigestCredential commentStamp: ''!
I am ZnDigestCredential, a concrete subclass of ZnCredential and subclass of ZnBasicCredential.
I implement digest HTTP authentication.
I hold a nounce and opaque.

Part of Zinc HTTP Components.!
!ZnDigestCredential methodsFor: 'accessing' stamp: ''!
nonce
	^ nonce! !

!ZnDigestCredential methodsFor: 'accessing' stamp: ''!
uriPathFrom: urlObject
	^ urlObject pathPrintString ifNil: [ '/' ]! !

!ZnDigestCredential methodsFor: 'computation' stamp: ''!
responseForUrl: urlObject method: method
	^ ZnDigestAuthenticator md5Hash: self a1, ':', self nonce, ':', (self a2ForUrl: urlObject method: method)! !

!ZnDigestCredential methodsFor: 'operations' stamp: ''!
setAuthorizationHeader: headers for: urlObject method: method
	headers at: 'Authorization' put: (self authTokenForUrl: urlObject method: method)! !

!ZnDigestCredential methodsFor: 'computation' stamp: ''!
a1
	^ ZnDigestAuthenticator md5Hash: self username, ':', self realm, ':', self password! !

!ZnDigestCredential methodsFor: 'testing' stamp: ''!
isComplete 
	^ super isComplete & nonce notNil ! !

!ZnDigestCredential methodsFor: 'computation' stamp: ''!
a2ForUrl: urlObject method: method
	"This doesn't support all qop options yet."
	^ ZnDigestAuthenticator md5Hash: method, ':', (self uriPathFrom: urlObject)! !

!ZnDigestCredential methodsFor: 'accessing' stamp: ''!
authTokenForUrl: urlObject method: method
	| result |
	result := WriteStream on: String new.
	result
		nextPutAll: 'Digest username="';
		nextPutAll: self username;
		nextPutAll: '", ';
		nextPutAll: 'nonce="';
		nextPutAll: self nonce;
		nextPutAll: '", ';
		nextPutAll: 'realm="';
		nextPutAll: self realm;
		nextPutAll: '", ';
		nextPutAll: 'uri="';
		nextPutAll: (self uriPathFrom: urlObject);
		nextPutAll: '", ';
		nextPutAll: 'response="';
		nextPutAll: (self responseForUrl: urlObject method: method);
		nextPutAll: '", '.
	self opaque isNil
		ifFalse: [ 
			result
				nextPutAll: 'opaque="';
				nextPutAll: self opaque;
				nextPutAll: '"' ].
	^ result contents! !

!ZnDigestCredential methodsFor: 'operations' stamp: ''!
parseAuthRequest: aHeader
	^ ZnDigestAuthenticator parseAuthRequest: aHeader! !

!ZnDigestCredential methodsFor: 'accessing' stamp: ''!
nonce: anObject
	nonce := anObject! !

!ZnDigestCredential methodsFor: 'accessing' stamp: ''!
opaque
	^ opaque! !

!ZnDigestCredential methodsFor: 'accessing' stamp: ''!
opaque: anObject
	opaque := anObject! !

!ZnDigestCredential methodsFor: 'operations' stamp: ''!
linkToAuthRequest: aHeader
	| data |
	data := self parseAuthRequest: aHeader.
	self nonce: (data at: 'nonce').
	self realm: (data at: 'realm' ifAbsent: [ '' ])! !

!ZnDigestCredential class methodsFor: 'accessing' stamp: ''!
authName
	^ 'Digest'! !

!ZnDispatcherDelegate commentStamp: ''!
I am ZnDispatcherDelegate, doing a straight-forward dispatching to mapped URLs.

ZnDispatcherDelegate API:

(server := ZnServer startDefaultOn: 9090)
	delegate: (ZnDispatcherDelegate new 
		map: '/hello' to: [ :request :response | response entity: (ZnEntity html: '<h1>hello server</h1>') ];
		map: '/counter' to: [ :request :response | counterApplication handleRequest: request response: response ]).!
!ZnDispatcherDelegate methodsFor: 'accessing' stamp: ''!
dispatcherDictionary
	^ dispatcherDictionary ifNil: [ dispatcherDictionary := Dictionary new ]! !

!ZnDispatcherDelegate methodsFor: 'public' stamp: ''!
map: relativeUrlString to: handler
	self dispatcherDictionary at: relativeUrlString put: handler! !

!ZnDispatcherDelegate methodsFor: 'public' stamp: ''!
handleRequest: request
	| handler |
	handler := self dispatcherDictionary 
		at: request uri pathPrintString 
		ifAbsent: [ ^ ZnResponse notFound: request uri ].	
	^ handler 
		value: request 
		value: (ZnResponse new
			statusLine: (ZnStatusLine ok);
			headers: ZnHeaders defaultResponseHeaders;
			yourself).

! !

!ZnDispatcherDelegateTest methodsFor: 'testing' stamp: ''!
testDispatcherDelegate
	self
		withServerDo: [ :server | 
			| client |
			server
				delegate:
					(ZnDispatcherDelegate new
						map: '/hello' to: [ :request :response | response entity: (ZnStringEntity html: '<h1>hello server</h1>') ];
						map: '/' to: [ :request :response | response entity: (ZnStringEntity html: '<h1>default</h1>') ]).

			client := ZnClient new.

			client
				get:
					(server localUrl
						addPathSegment: 'missing';
						yourself).
			self assert: client response contentType equals: ZnMimeType textPlain.
			self assert: client response status equals: 404.

			client get: server localUrl.
			self assert: client response contentType equals: ZnMimeType textHtml.
			self assert: client response status equals: 200.

			client
				get:
					(server localUrl
						addPathSegment: 'hello';
						yourself).
			self assert: client response contentType equals: ZnMimeType textHtml.
			self assert: client response status equals: 200.

			client close ]! !

!ZnDispatcherDelegateTest methodsFor: 'private' stamp: ''!
withServerDo: block
	| server |
	server := ZnServer on: 1700 + 32 atRandom.
	[ 
		server start.
		self 
			assert: server isRunning & server isListening
			description: ('Failed to start server on port {1}. Is there one already?' format: { server port }).
		self assert: server isRunning & server isListening.
		block cull: server
	] 
		ensure: [ server stop ]! !

!ZnEasy commentStamp: ''!
I am ZnEasy, a simplified HTTP client for occasional use.

My class side implements a number of convenience methods to do common HTTP client operations.

	ZnEasy get: 'http://zn.stfx.eu/zn/small.html'.

For most requests, I return a response object. 

For a couple of message, I return an image Form.

	ZnEasy getPng: 'http://pharo.org/files/pharo.png'.

For my implementation I use ZnClient, a full featured HTTP client.

Part of Zinc HTTP Components.!
!ZnEasy class methodsFor: 'operations' stamp: ''!
getPng: urlObject
	"self getPng: 'http://pharo.org/files/pharo.png'."
	"(self getPng: 'http://chart.googleapis.com/chart?cht=tx&chl=',
		'a^2+b^2=c^2' urlEncoded) asMorph openInHand."
	
	^ self 
		getImageOfType: ZnMimeType imagePng 
		fromUrl: urlObject! !

!ZnEasy class methodsFor: 'private' stamp: ''!
client
	^ ZnClient new
		beOneShot;
		yourself! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
getJpeg: urlObject
	"self getJpeg: 'http://stfx.eu/sun-fire-x2100.jpg'."
	
	^ self 
		getImageOfType: ZnMimeType imageJpeg 
		fromUrl: urlObject! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
get: urlObject
	"self get: 'http://stfx.eu/small.html'."
	
	^ self client
		url: urlObject;
		get;
		response
	! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
head: urlObject
	^ self client
		url: urlObject;
		head;
		response! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
head: urlObject username: username password: password
	^ self client
		url: urlObject;
		setBasicAuthenticationUsername: username password: password;
		head;
		response! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
get: urlObject username: username password: password
	^ self client
		url: urlObject;
		setBasicAuthenticationUsername: username password: password;
		get;
		response
	! !

!ZnEasy class methodsFor: '*Graphics-Files' stamp: ''!
getImageOfType: mimeType fromUrl: urlObject
	| client |
	(client := self client)
		url: urlObject;
		accept: mimeType;
		enforceHttpSuccess: true;
		enforceAcceptContentType: true;
		get.
	"ImageReadWriter does automatic type detection"
	^ ImageReadWriter formFromStream: client entity readStream! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
put: urlObject data: entity username: username password: password
	^ self client
		url: urlObject;
		setBasicAuthenticationUsername: username password: password;
		entity: entity;
		put;
		response	! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
getGif: urlObject
	"self getGif: 'http://zn.stfx.eu/zn/Hot-Air-Balloon.gif'."
	
	^ self 
		getImageOfType: ZnMimeType imageGif 
		fromUrl: urlObject	! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
post: urlObject data: entity username: username password: password
	^ self client
		url: urlObject;
		setBasicAuthenticationUsername: username password: password;
		entity: entity;
		post;
		response! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
delete: urlObject
	^ self client
		url: urlObject;
		delete;
		response! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
delete: urlObject username: username password: password
	^ self client
		url: urlObject;
		setBasicAuthenticationUsername: username password: password;
		delete;
		response
	! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
put: urlObject data: entity
	^ self client
		url: urlObject;
		entity: entity;
		put;
		response	! !

!ZnEasy class methodsFor: 'operations' stamp: ''!
post: urlObject data: entity
	^ self client
		url: urlObject;
		entity: entity;
		post;
		response! !

!ZnEasyTest methodsFor: 'testing' stamp: ''!
testDelete
	self
		withServerDo: [ :server | 
			| response |
			response := ZnEasy
				delete:
					(server localUrl
						addPathSegments: #('echo' 'foo');
						yourself).
			self assert: response headers contentType equals: ZnMimeType textPlain.
			self assert: response statusLine code equals: 200.
			self assert: (response entity string includesSubstring: 'DELETE').
			self assert: (response entity string includesSubstring: 'foo') ]! !

!ZnEasyTest methodsFor: 'testing' stamp: ''!
testGetSmallHTMLDocument
	| url response |
	url := self smallHtmlUrl.
	response := ZnEasy get: url.
	self assert: response headers contentType equals: ZnMimeType textHtml.
	self assert: response statusLine code equals: 200.
	self assert: (response entity string includesSubstring: 'small')! !

!ZnEasyTest methodsFor: 'accessing' stamp: ''!
smallHtmlUrl
	^ 'http://zn.stfx.eu/zn/small.html' asZnUrl! !

!ZnEasyTest methodsFor: 'testing' stamp: ''!
testGetPng
	| url result |
	self flag: #flakyTest.
	self skip.
	
	url := 'http://pharo.org/files/pharo.png'.
	result := ZnEasy getPng: url.
	self assert: result isForm! !

!ZnEasyTest methodsFor: 'testing' stamp: ''!
testTimeout
	self withServerDo: [ : server |
		self 
			should: [ 
				ZnConnectionTimeout 
					value: 1 
					during: [ ZnEasy get: (server localUrl addPathSegment: 'echo'; queryAt: 'delay' put: '2'; yourself) ] ] 
			raise: ConnectionTimedOut ]
	! !

!ZnEasyTest methodsFor: 'private' stamp: ''!
withServerDo: block
	| server |
	server := ZnServer on: 1700 + 32 atRandom.
	[ 
		server start.
		self 
			assert: server isRunning & server isListening
			description: ('Failed to start server on port {1}. Is there one already?' format: { server port }).
		self assert: server isRunning & server isListening.
		block cull: server
	] 
		ensure: [ server stop ]! !

!ZnEasyTest methodsFor: 'testing' stamp: ''!
testPostUnicodeUtf8
	self
		withServerDo: [ :server | 
			| response data |
			data := String streamContents: [ :stream | 0 to: 16r024F do: [ :each | stream nextPut: each asCharacter ] ].
			response := ZnEasy
				post:
					(server localUrl
						addPathSegment: 'echo';
						yourself)
				data: (ZnEntity text: data).
			self assert: response headers contentType equals: ZnMimeType textPlain.
			self assert: response statusLine code equals: 200.
			self assert: (response entity string includesSubstring: 'POST').
			self assert: (response entity string includesSubstring: data) ]! !

!ZnEasyTest methodsFor: 'testing' stamp: ''!
testHeadSmallHTMLDocument
	| url response |
	url := self smallHtmlUrl.
	response := ZnEasy head: url.
	self assert: response headers contentType equals: ZnMimeType textHtml.
	self assert: response statusLine code equals: 200.
	self assert: response hasEntity not! !

!ZnEasyTest methodsFor: 'testing' stamp: ''!
testPut
	self
		withServerDo: [ :server | 
			| response data |
			data := String streamContents: [ :stream | 1 to: 32 do: [ :each | stream nextPut: 'abc' atRandom ] ].
			response := ZnEasy
				put:
					(server localUrl
						addPathSegment: 'echo';
						yourself)
				data: (ZnEntity text: data).
			self assert: response headers contentType equals: ZnMimeType textPlain.
			self assert: response statusLine code equals: 200.
			self assert: (response entity string includesSubstring: 'PUT').
			self assert: (response entity string includesSubstring: data) ]! !

!ZnEasyTest methodsFor: 'testing' stamp: ''!
testGetJpeg
	| url result |
	url := 'http://stfx.eu/sun-fire-x2100.jpg'.
	result := ZnEasy getJpeg: url.
	self assert: result isForm! !

!ZnEasyTest methodsFor: 'testing' stamp: ''!
testPost
	self
		withServerDo: [ :server | 
			| response data |
			data := String streamContents: [ :stream | 1 to: 32 do: [ :each | stream nextPut: 'abc' atRandom ] ].
			response := ZnEasy
				post:
					(server localUrl
						addPathSegment: 'echo';
						yourself)
				data: (ZnEntity text: data).
			self assert: response headers contentType equals: ZnMimeType textPlain.
			self assert: response statusLine code equals: 200.
			self assert: (response entity string includesSubstring: 'POST').
			self assert: (response entity string includesSubstring: data) ]! !

!ZnEasyTest methodsFor: 'testing' stamp: ''!
testGetGif
	| url result |
	url := 'http://zn.stfx.eu/zn/Hot-Air-Balloon.gif'.
	result := ZnEasy getGif: url.
	self assert: result isForm! !

!ZnEncodedReadStream commentStamp: ''!
I am ZnEncodedReadStream, an abstract support class for read streams on a binary encoded wrapped stream.

Part of Zinc HTTP Components!
!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
position

	^ super position - (peeked ifNil: [ 0 ] ifNotNil: [ 1 ])! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
nextInto: collection
	"Read the next elements of the receiver into collection,
	returning a copy if less elements are available"
	
	^ self
		next: collection size
		into: collection! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
peek
	^ peeked
		ifNil: [
			stream atEnd ifFalse: [ peeked := self nextElement ] ]! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
next
	^ peeked
		ifNil: [ 
			stream atEnd ifFalse: [ self nextElement ] ]
		ifNotNil: [ | character |
			character := peeked.
			peeked := nil.
			character ]! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount 
	"Read requestedCount elements into new collection and return it,
	 it could be that less elements were available"

	^ self 
		next: requestedCount 
		into: (self collectionSpecies new: requestedCount)! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
position: anInteger
	super position: anInteger.
	peeked := nil! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
upToEnd
	^ self collectionSpecies
		streamContents: [ :collectionStream | 
			[ self atEnd ] whileFalse: [ collectionStream nextPut: self next ] ]! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection startingAt: offset
	"Read requestedCount elements into collection starting at offset,
	returning a copy if less elements are available"
	
	| readCount |
	readCount := self 
		readInto: collection 
		startingAt: offset 
		count: requestedCount.
	^ requestedCount = readCount
		ifTrue: [ collection ]
		ifFalse: [ collection copyFrom: 1 to: offset + readCount - 1 ]! !

!ZnEncodedReadStream methodsFor: 'testing' stamp: ''!
isBinary
	^ false! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
skip: count
	count timesRepeat: [ self next ]! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
peekFor: object
	^ self peek = object
		ifTrue: [ 
			self next.
			true ]
		ifFalse: [ false ]! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
upTo: anObject 	
	^ self collectionSpecies 
		streamContents: [ :out | | element |
			[ self atEnd or: [ (element := self next) = anObject ] ] whileFalse: [ 
				out nextPut: element ] ]! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
readInto: collection startingAt: offset count: requestedCount
	"Read requestedCount elements into collection starting at offset,
	returning the number of elements read, there could be less elements available.
	This is an inefficient abstract implementation, reading one by one."
	
	0 to: requestedCount - 1 do: [ :count | | object |
		(object := self next) ifNil: [ ^ count ].  
		collection at: offset + count put: object ].
	^ requestedCount! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
contents
	"This is technically not correct, but it is better than nothing"
	
	^ self upToEnd! !

!ZnEncodedReadStream methodsFor: 'testing' stamp: ''!
isReadOnly

	^ true! !

!ZnEncodedReadStream methodsFor: 'testing' stamp: ''!
atEnd
	^ peeked isNil and: [ stream atEnd ]! !

!ZnEncodedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection
	"Read requestedCount elements into collection,
	returning a copy if less elements are available"
	
	^ self
		next: requestedCount
		into: collection
		startingAt: 1! !

!ZnEncodedReadStream methodsFor: 'private' stamp: ''!
nextElement
	self subclassResponsibility ! !

!ZnEncodedStream commentStamp: ''!
I am ZnEncodedStream, an abstract support class for read and write streams on an encoded binary stream.

Part of Zinc HTTP Components!
!ZnEncodedStream methodsFor: 'accessing' stamp: ''!
truncate: anInteger 
	stream truncate: anInteger! !

!ZnEncodedStream methodsFor: 'accessing' stamp: ''!
position
	^ stream position! !

!ZnEncodedStream methodsFor: 'initialize-release' stamp: ''!
encoding: encoding
	encoder := encoding asZnCharacterEncoder! !

!ZnEncodedStream methodsFor: 'accessing' stamp: ''!
position: aPosition
	stream position: aPosition! !

!ZnEncodedStream methodsFor: 'testing' stamp: ''!
closed
	^ stream closed! !

!ZnEncodedStream methodsFor: 'initialize-release' stamp: ''!
on: wrappedStream
	stream := wrappedStream! !

!ZnEncodedStream methodsFor: 'accessing' stamp: ''!
encoder
	^ encoder ifNil: [ encoder := self class defaultEncoder ]! !

!ZnEncodedStream methodsFor: 'accessing' stamp: ''!
size
	^ stream size! !

!ZnEncodedStream methodsFor: 'accessing' stamp: ''!
truncate
	stream truncate! !

!ZnEncodedStream methodsFor: 'initialize-release' stamp: ''!
close
	stream close! !

!ZnEncodedStream methodsFor: 'accessing' stamp: ''!
wrappedStream
	^ stream! !

!ZnEncodedStream methodsFor: 'initialize-release' stamp: ''!
encoder: characterEncoder
	encoder := characterEncoder! !

!ZnEncodedStream methodsFor: 'testing' stamp: ''!
isStream
  ^ true! !

!ZnEncodedStream methodsFor: 'accessing' stamp: ''!
setToEnd
	stream setToEnd! !

!ZnEncodedStream class methodsFor: 'instance creation' stamp: ''!
on: wrappedStream
	^ self new
		on: wrappedStream;
		yourself! !

!ZnEncodedStream class methodsFor: 'accessing' stamp: ''!
defaultEncoder
	^ ZnCharacterEncoder utf8! !

!ZnEncodedStream class methodsFor: 'instance creation' stamp: ''!
on: wrappedStream encoding: encoding
	^ self new
		on: wrappedStream;
		encoding: encoding;
		yourself! !

!ZnEncodedWriteStream commentStamp: ''!
I am ZnEncodedWriteStream, an abstract support class for write streams on a binary encoded wrapped stream.

Part of Zinc HTTP Components!
!ZnEncodedWriteStream methodsFor: 'accessing' stamp: ''!
<< anObject
	"Write anObject to the receiver, dispatching using #putOn:
	This is a shortcut for both nextPut: and nextPutAll: since anObject can be both
	the element type of the receiver as well as a collection of those elements.
	No further conversions of anObject are applied.
	Return self to accomodate chaining."

 	anObject putOn: self! !

!ZnEncodedWriteStream methodsFor: 'accessing' stamp: ''!
nextPut: anObject
	self subclassResponsibility! !

!ZnEncodedWriteStream methodsFor: 'accessing' stamp: ''!
flush
	stream flush! !

!ZnEncodedWriteStream methodsFor: 'accessing' stamp: ''!
nextPutAll: collection
	self 
		next: collection size 
		putAll: collection 
		startingAt: 1! !

!ZnEncodedWriteStream methodsFor: 'accessing' stamp: ''!
next: count putAll: collection	
	self 
		next: count 
		putAll: collection 
		startingAt: 1! !

!ZnEncodedWriteStream methodsFor: 'testing' stamp: ''!
isBinary
	^ false! !

!ZnEncodedWriteStream methodsFor: 'accessing' stamp: ''!
next: count putAll: collection startingAt: offset
	"Write count items from collection starting at offset.
	This is an inefficient abstract implementation writing one by one."
	
	0 to: count - 1 do: [ :each | 
		self nextPut: (collection at: offset + each) ]! !

!ZnEndianSensitiveUTFEncoder commentStamp: ''!
I am ZnEndianSensitiveUTFEncoder.
I am a ZnCharacterEncoder.
I add support for UTF encodings that are sensitive to endianness.
The default is big endian.!
!ZnEndianSensitiveUTFEncoder methodsFor: 'accessing' stamp: ''!
endianness
	^ endianness! !

!ZnEndianSensitiveUTFEncoder methodsFor: 'comparing' stamp: ''!
= anObject
	^ super = anObject and: [ self endianness == anObject endianness ]! !

!ZnEndianSensitiveUTFEncoder methodsFor: 'initialize' stamp: ''!
beLittleEndian
	endianness := #little! !

!ZnEndianSensitiveUTFEncoder methodsFor: 'comparing' stamp: ''!
hash
	^ super hash bitXor: self endianness hash! !

!ZnEndianSensitiveUTFEncoder methodsFor: 'initialize' stamp: ''!
initialize
	endianness := #big! !

!ZnEndianSensitiveUTFEncoder methodsFor: 'initialize' stamp: ''!
beBigEndian
	endianness := #big! !

!ZnEndianSensitiveUTFEncoder methodsFor: 'testing' stamp: ''!
isBigEndian
	^ endianness = #big! !

!ZnEndianSensitiveUTFEncoder methodsFor: 'testing' stamp: ''!
isLittleEndian
	^ endianness = #little! !

!ZnEndianSensitiveUTFEncoder methodsFor: 'private' stamp: ''!
swapEndianness
	self isLittleEndian
		ifTrue: [ self beBigEndian ]
		ifFalse: [ self beLittleEndian ]! !

!ZnEndianSensitiveUTFEncoder methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(.
	stream nextPutAll: endianness; nextPutAll: ' endian'.
	stream nextPut: $)! !

!ZnEndianSensitiveUTFEncoder class methodsFor: 'instance creation' stamp: ''!
newForEncoding: string
	"Return a new character encoder object for an encoding described by string.
	Try to infer endianness from string, defaulting to big endian."
	
	| encoder |
	encoder := self new.
	(string asLowercase endsWith: 'be') ifTrue: [ encoder beBigEndian ].
	(string asLowercase endsWith: 'le') ifTrue: [ encoder beLittleEndian ].
	^ encoder! !

!ZnEndianSensitiveUTFEncoder class methodsFor: 'accessing' stamp: ''!
handlesEncoding: string
	"Return true when my instances handle the encoding described by string"
	
	^ false! !

!ZnEndianessReadWriteStream commentStamp: ''!
I am a stream decorator that knows how to read and write little endian numbers from my underlying stream.!
!ZnEndianessReadWriteStream methodsFor: 'endianess' stamp: ''!
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 := stream next: n.
	s := 0.
	n to: 1 by: -1 do: [:i | s := (s bitShift: 8) bitOr: (bytes at: i)].
	^ s! !

!ZnEndianessReadWriteStream methodsFor: 'initialize-release' stamp: ''!
on: aStream

	stream := aStream! !

!ZnEndianessReadWriteStream methodsFor: 'endianess' stamp: ''!
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 byteAt: i)].
	stream nextPutAll: bytes! !

!ZnEndianessReadWriteStream class methodsFor: 'instance creation' stamp: ''!
on: writeStream do: block
	"Execute block with as argument a ZnBufferedWriteStream on writeStream,
	making sure #flush is called at the end. Return the value of block."
	
	| bufferedWriteStream result |
	bufferedWriteStream := self on: writeStream.
	result := block value: bufferedWriteStream.
	bufferedWriteStream flush.
	^ result! !

!ZnEndianessReadWriteStream class methodsFor: 'instance creation' stamp: ''!
on: writeStream
	^ self basicNew
		on: writeStream;
		yourself! !

!ZnEntity commentStamp: ''!
I am ZnEntity, an abstract HTTP Entity.

An entity has a content type (mime-type), a content length (byte length) and a contents.

Entities can encode and decode themselves to and from binary streams.

Part of Zinc HTTP Components.!
!ZnEntity methodsFor: 'converting' stamp: ''!
asByteArray
	"Return the ByteArray that is the binary, encoded representation of the receiver"
	
	^ ByteArray streamContents: [ :stream | self writeOn: stream ]! !

!ZnEntity methodsFor: 'testing' stamp: ''!
isEmpty 
	self subclassResponsibility ! !

!ZnEntity methodsFor: 'comparing' stamp: ''!
= other
	self class = other class ifFalse: [ ^ false ].
	^ self contentType = other contentType and: [ self contentLength = other contentLength ]! !

!ZnEntity methodsFor: 'testing' stamp: ''!
hasContentType
	^ contentType notNil! !

!ZnEntity methodsFor: 'comparing' stamp: ''!
hash
	^ self contentType hash bitXor: self contentLength hash! !

!ZnEntity methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	self printContentTypeAndLengthOn: stream! !

!ZnEntity methodsFor: 'testing' stamp: ''!
hasContentLength
	^ contentLength notNil! !

!ZnEntity methodsFor: 'writing' stamp: ''!
writeOn: stream
	self subclassResponsibility ! !

!ZnEntity methodsFor: 'accessing' stamp: ''!
contentLength 
	"Content length can be nil when it is (currently) unknown."
	
	^ contentLength! !

!ZnEntity methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(.
	self printContentsOn: stream.
	stream nextPut: $)! !

!ZnEntity methodsFor: 'printing' stamp: ''!
printContentTypeAndLengthOn: stream
	self hasContentType ifTrue: [ 
		stream print: self contentType; space ].
	self hasContentLength ifTrue: [
		stream print: self contentLength; nextPut: $B ]! !

!ZnEntity methodsFor: 'accessing' stamp: ''!
contentType
	^ contentType ! !

!ZnEntity methodsFor: 'initialize-release' stamp: ''!
readBinaryFrom: stream
	self readFrom: stream! !

!ZnEntity methodsFor: 'initialize-release' stamp: ''!
close! !

!ZnEntity methodsFor: 'accessing' stamp: ''!
contentType: object
	"We only allow assignment compatible with our designated mime type"
	
	| newType |
	newType := object asZnMimeType.
	contentType = newType 
		ifTrue: [ ^ self ]
		ifFalse: [ 
			(self class designatedMimeType isNil or: [ self class matches: newType ])
				ifTrue: [ contentType := newType ] ]! !

!ZnEntity methodsFor: 'accessing' stamp: ''!
contents
	self subclassResponsibility! !

!ZnEntity methodsFor: 'accessing' stamp: ''!
contentLength: integer
	contentLength := integer! !

!ZnEntity methodsFor: 'initialize-release' stamp: ''!
readFrom: stream
	self subclassResponsibility ! !

!ZnEntity class methodsFor: 'private' stamp: ''!
concreteSubclassForType: mimeType binary: forceBinary
	"Answer the concrete ZnEntity subclass that handles mimeType"
	
	^ self allSubclasses 
		detect: [ :each | 
			each matches: mimeType ]
		ifNone: [ 
			(mimeType isBinary or: [ forceBinary ])
				ifTrue: [ self byteArrayEntityClass ] 
				ifFalse: [ self stringEntityClass ] ]
! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
new
	^ super new initialize ! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
textCRLF: text
	^ self text: text, String crlf! !

!ZnEntity class methodsFor: 'testing' stamp: ''!
designatedMimeType
	"Answer the mime type we are designated to handle.
	See #concreteSubclassForType: "
	
	self subclassResponsibility ! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
text: text
	^ self stringEntityClass text: text! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
type: type length: length
	"Create a new entity with a given mime type and length"
	
	^ self new
		contentType: type;
		contentLength: length;
		yourself! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
readFrom: stream usingType: mimeType andLength: length
	"Create and return a new buffered entity of mimeType and length from stream.
	The concrete subclass depends on mimeType"
	
	| newEntity |
	newEntity := (self concreteSubclassForType: mimeType binary: false) 
						type: mimeType length: length.
	newEntity readFrom: stream.
	^ newEntity 
! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
type: type
	"Create a new entity with a given mime type and (currently) undetermined length"
	
	^ self new
		contentType: type;
		yourself! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
with: object type: type
	"Create a new entity holding object.
	Currently works for strings and byte arrays.
	The entity is set to mime type"
	
	^ (self with: object)
		contentType: type;
		yourself! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
bytes: bytes
	^ self byteArrayEntityClass bytes: bytes! !

!ZnEntity class methodsFor: 'testing' stamp: ''!
matches: mimeType
	"Return whether a given mimeType can be handled by instances of the receiver"
	
	^ mimeType matches: self designatedMimeType ! !

!ZnEntity class methodsFor: 'accessing' stamp: ''!
stringEntityClass
	^ ZnStringEntity! !

!ZnEntity class methodsFor: 'accessing' stamp: ''!
byteArrayEntityClass
	^ ZnByteArrayEntity ! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
readBinaryFrom: stream usingType: mimeType andLength: length
	"Create and return a new buffered entity of mimeType and length from stream.
	The concrete subclass depends on mimeType, but textual type will remain binary"
	
	| newEntity |
	newEntity := (self concreteSubclassForType: mimeType binary: true) 
						type: mimeType length: length.
	newEntity readBinaryFrom: stream.
	^ newEntity 
! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
with: object
	"Create a new entity holding object.
	Currently works for strings and byte arrays.
	You will probably want to set the mime type to something more specific"
	
	^ object isString 
		ifTrue: [ self text: object ] 
		ifFalse: [ self bytes: object ]! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
xml: text
	^ self stringEntityClass xml: text! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
html: html
	^ self stringEntityClass html: html! !

!ZnEntity class methodsFor: 'instance creation' stamp: ''!
json: text
	^ self stringEntityClass json: text! !

!ZnEntityReader commentStamp: ''!
I am ZnEntityReader, I help reading ZnEntities from a stream given meta data in headers.

I deal with chunking and gzip decoding.

I have several options:
	- to read streaming entities, where the client has to do the actual reading
	- to read binary entities, where textual content is not interpreted
	- to allow reading up to end, when there is no content length set

Part of Zinc HTTP Components.!
!ZnEntityReader methodsFor: 'testing' stamp: ''!
isChunked
	| transferEncoding |
	transferEncoding := self headers at: 'Transfer-Encoding' ifAbsent: [ ^ false ].
	^ transferEncoding = 'chunked' or: [ transferEncoding beginsWith: 'chunked' ]! !

!ZnEntityReader methodsFor: 'testing' stamp: ''!
canReadContent
	^ self hasContentLength or: [ self isChunked or: [ self allowsReadingUpToEnd ] ]! !

!ZnEntityReader methodsFor: 'accessing' stamp: ''!
binary
	binary := true! !

!ZnEntityReader methodsFor: 'testing' stamp: ''!
hasContentLength
	^ self headers hasContentLength and: [ self headers contentLength > 0 ]! !

!ZnEntityReader methodsFor: 'accessing' stamp: ''!
headers: znHeaders
	headers := znHeaders! !

!ZnEntityReader methodsFor: 'accessing' stamp: ''!
headers
	^ headers! !

!ZnEntityReader methodsFor: 'accessing' stamp: ''!
contentLength
	^ (self headers includesKey: 'Content-Length')
		ifTrue: [ self headers contentLength ]
		ifFalse: [ nil ]! !

!ZnEntityReader methodsFor: 'testing' stamp: ''!
isGzipped
	| contentEncoding |
	contentEncoding := self headers at: 'Content-Encoding' ifAbsent: [ ^ false ].
	^ contentEncoding = 'gzip'! !

!ZnEntityReader methodsFor: 'accessing' stamp: ''!
allowReadingUpToEnd
	allowReadingUpToEnd := true! !

!ZnEntityReader methodsFor: 'testing' stamp: ''!
isBinary
	^ binary notNil and: [ binary ]! !

!ZnEntityReader methodsFor: 'private' stamp: ''!
readEntityFromStream
	| entity decodedEntityLength chunkedStream isChunked |
	chunkedStream := (isChunked := self isChunked) ifTrue: [ stream := ZnChunkedReadStream on: stream ] ifFalse: [ nil ].
	self isGzipped 
		ifTrue: [ 
			self hasContentLength ifTrue: [ stream := ZnLimitedReadStream on: stream limit: self contentLength ].
			decodedEntityLength := nil.
			stream := GZipReadStream on: stream ]
		ifFalse: [ decodedEntityLength := self contentLength ].
	entity := self readFrom: stream usingType: self contentType andLength: decodedEntityLength.
	isChunked ifTrue: [ 
		self isIdentityEncoded ifTrue: [ entity contentLength: stream totalSize ].
		chunkedStream extraHeaders ifNotNil: [ :extraHeaders | self headers addAll: extraHeaders ] ].
	^ entity! !

!ZnEntityReader methodsFor: 'private' stamp: ''!
readFrom: readStream usingType: contentType andLength: length
	| entityClass selector |
	entityClass := self isStreaming 
		ifTrue: [ ZnStreamingEntity ]
		ifFalse: [ ZnEntity ].
	selector := self isBinary 
		ifTrue: [ #readBinaryFrom:usingType:andLength: ]
		ifFalse: [ #readFrom:usingType:andLength: ].
	^ entityClass perform: selector 
		with: readStream
		with: contentType 
		with: length! !

!ZnEntityReader methodsFor: 'accessing' stamp: ''!
contentType
	^ (self headers includesKey: 'Content-Type') 
		ifTrue: [ self headers contentType ] 
		ifFalse: [ ZnMimeType default ]! !

!ZnEntityReader methodsFor: 'accessing' stamp: ''!
stream: readStream
	stream := readStream ! !

!ZnEntityReader methodsFor: 'accessing' stamp: ''!
streaming
	streaming := true! !

!ZnEntityReader methodsFor: 'public' stamp: ''!
readEntity
	| entity |
	self canReadContent ifFalse: [ ^ nil ].
	entity := self readEntityFromStream.
	^ entity isEmpty
		ifTrue: [ nil ]
		ifFalse: [ entity ]    ! !

!ZnEntityReader methodsFor: 'accessing' stamp: ''!
stream
	^ stream! !

!ZnEntityReader methodsFor: 'testing' stamp: ''!
allowsReadingUpToEnd
	^ allowReadingUpToEnd notNil and: [ allowReadingUpToEnd ]! !

!ZnEntityReader methodsFor: 'testing' stamp: ''!
isStreaming
	^ streaming notNil and: [ streaming ]! !

!ZnEntityReader methodsFor: 'testing' stamp: ''!
isIdentityEncoded
	^ self isGzipped not! !

!ZnEntityReaderTest methodsFor: 'testing' stamp: ''!
testReadStreamingWriting
	| data headers reader entity output |
	data := ((1 to: 32) collect: [ :each | (0 to: 9) atRandom ]) asByteArray.
	(headers := ZnHeaders new)
		at: 'Content-Type' put: ZnMimeType applicationOctetStream printString;
		at: 'Content-Length' put: data size printString.
	(reader := ZnEntityReader new)
		headers: headers;
		stream: data readStream;
		streaming.
	entity := reader readEntity.
	self assert: entity contentType equals: ZnMimeType applicationOctetStream.
	self assert: entity contentLength equals: data size.
	output := ByteArray streamContents: [ :stream | entity writeOn: stream ].
	self assert: output equals: data! !

!ZnEntityReaderTest methodsFor: 'testing' stamp: ''!
testChunked
	| input headers reader entity |
	input := '3' , String crlf , 'con' , String crlf , '8' , String crlf , 'sequence' , String crlf , '0' , String crlf , String crlf.
	(headers := ZnHeaders new)
		at: 'Content-Type' put: 'text/plain';
		at: 'Transfer-Encoding' put: 'chunked'.
	(reader := ZnEntityReader new)
		headers: headers;
		stream: input asByteArray readStream.
	entity := reader readEntity.
	self assert: entity contents equals: 'consequence'! !

!ZnEntityReaderTest methodsFor: 'testing' stamp: ''!
testReadStreaming
	| data headers reader entity |
	data := ((1 to: 32) collect: [ :each | (0 to: 9) atRandom ]) asByteArray.
	(headers := ZnHeaders new)
		at: 'Content-Type' put: ZnMimeType applicationOctetStream printString;
		at: 'Content-Length' put: data size printString.
	(reader := ZnEntityReader new)
		headers: headers;
		stream: data readStream;
		streaming.
	entity := reader readEntity.
	self assert: entity contentType equals: ZnMimeType applicationOctetStream.
	self assert: entity contentLength equals: data size.
	self assert: entity contents equals: data! !

!ZnEntityReaderTest methodsFor: 'testing' stamp: ''!
testChunkedWithExtraHeaders
	| input headers reader entity |
	input := '3' , String crlf , 'con' , String crlf , '8' , String crlf , 'sequence' , String crlf , '0' , String crlf , 'X-Foo:bar' , String crlf , String crlf.
	(headers := ZnHeaders new)
		at: 'Content-Type' put: 'text/plain';
		at: 'Transfer-Encoding' put: 'chunked'.
	(reader := ZnEntityReader new)
		headers: headers;
		stream: input asByteArray readStream.
	entity := reader readEntity.
	self assert: entity contents equals: 'consequence'.
	self assert: (headers at: 'X-Foo') equals: 'bar'! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testReading
	| contents entity |
	contents := 'This is a test'.
	entity := ZnEntity readFrom: contents asByteArray readStream usingType: ZnMimeType textPlain andLength: contents size.
	self assert: entity contents isString.
	self assert: entity string equals: contents.
	self assert: entity contentLength equals: contents size.
	self assert: entity contentType equals: ZnMimeType textPlain! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testReadingApplicationFormUrlEncoding
	| input entity |
	input := #(111 97 117 116 104 95 116 111 107 101 110 95 115 101 99 114 101 116 61 98 121 112 104 57 99 109 104 106 49 53 101 108 121 56 38 111 97 117 116 104 95 116 111 107 101 110 61 56 54 101 112 106 51 116 118 100 49 107 115 120 111 57)
		asByteArray.
	entity := ZnEntity readFrom: input readStream usingType: ZnMimeType applicationFormUrlEncoded andLength: input size.
	self deny: entity isEmpty.
	self assert: (entity includesField: 'oauth_token_secret').
	self assert: (entity includesField: 'oauth_token').
	self assert: (entity at: 'oauth_token_secret') equals: 'byph9cmhj15ely8'.
	self assert: (entity at: 'oauth_token') equals: '86epj3tvd1ksxo9'! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testWritingApplicationUrlEncodingWithTextEncodingLatin1
	| entity string |
	entity := ZnApplicationFormUrlEncodedEntity new.
	entity contentType charSet: 'iso-8859-1'.
	entity at: 'foo' put: (Character value: 246) asString.
	string := String streamContents: [ :stream | entity writeOn: stream ].
	self assert: string equals: 'foo=%F6'.
	self assert: entity contentLength equals: 7! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testWritingApplicationUrlEncoding
	| entity string |
	entity := ZnApplicationFormUrlEncodedEntity new.
	entity at: 'foo' put: 'bar'.
	string := String streamContents: [ :stream | entity writeOn: stream ].
	self assert: string equals: 'foo=bar'.
	self assert: entity contentLength equals: 7! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testMultiPartFormDataWriteRead
	| input output bytes |
	input := ZnMultiPartFormDataEntity new
		addPart: (ZnMimePart fieldName: 'extra' value: 'my-extra');
		addPart: (ZnMimePart fieldName: 'info' value: 'my-info');
		addPart: (ZnMimePart fieldName: 'file' fileName: 'foo.txt' entity: (ZnEntity text: 'Zinc HTTP Components'));
		yourself.
	self assert: input contentLength notNil.
	self assert: input contentLength > 0.
	self assert: (input contentType matches: ZnMimeType multiPartFormData).
	bytes := ByteArray streamContents: [ :stream | input writeOn: stream ].
	output := (ZnMultiPartFormDataEntity type: input contentType) readFrom: bytes readStream.
	self assert: (output partNamed: 'extra') fieldValue equals: 'my-extra'.
	self assert: (output partNamed: 'info') fieldValue equals: 'my-info'.
	self assert: (output partNamed: 'extra') fieldValueString equals: 'my-extra'.
	self assert: (output partNamed: 'info') fieldValueString equals: 'my-info'.
	self assert: (output partNamed: 'file') contents equals: 'Zinc HTTP Components'.
	output := (ZnMultiPartFormDataEntity type: input contentType length: input contentLength) readFrom: bytes readStream.
	self assert: (output partNamed: 'extra') fieldValue equals: 'my-extra'.
	self assert: (output partNamed: 'info') fieldValue equals: 'my-info'.
	self assert: (output partNamed: 'extra') fieldValueString equals: 'my-extra'.
	self assert: (output partNamed: 'info') fieldValueString equals: 'my-info'.
	self assert: (output partNamed: 'file') contents equals: 'Zinc HTTP Components'! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testUTF8ReadingUndetermined
	| string entity bytes |
	string := String
		with: $$
		with: 16r00A2 asCharacter
		with: 16r20AC asCharacter
		with: 16r024B62 asCharacter.
	entity := ZnStringEntity type: ZnMimeType textPlain.
	bytes := #(16r24 16rC2 16rA2 16rE2 16r82 16rAC 16rF0 16rA4 16rAD 16rA2) asByteArray.
	entity readFrom: bytes readStream.
	self assert: entity contentType equals: ZnMimeType textPlain.
	self assert: entity contentLength equals: 10.
	self assert: entity contents equals: string! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testUTF8Writing
	| string entity bytes |
	string := String
		with: $$
		with: 16r00A2 asCharacter
		with: 16r20AC asCharacter
		with: 16r024B62 asCharacter.
	entity := ZnStringEntity text: string.
	self assert: entity contentType equals: ZnMimeType textPlain.
	self assert: entity contentLength equals: 10.
	bytes := ByteArray streamContents: [ :stream | entity writeOn: stream ].
	self assert: bytes equals: #(16r24 16rC2 16rA2 16rE2 16r82 16rAC 16rF0 16rA4 16rAD 16rA2) asByteArray! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testUnspecifiedEncoding
	| json bytes entity |
	json := '{"text":"Der Weg zur Hölle ist mit guten Vorsätzen gepflastert."}'.
	entity := ZnEntity with: json type: ZnMimeType applicationJson setCharSetUTF8.
	bytes := entity asByteArray.
	ZnDefaultCharacterEncoder 
		value: ZnUTF8Encoder new
		during: [
			entity := ZnEntity 
				readFrom: bytes readStream 
				usingType: ZnMimeType applicationJson 
				andLength: nil. 
			self assert: entity contents equals: json.
			entity := ZnEntity with: json type: ZnMimeType applicationJson.
			self assert: entity encoder equals: ZnUTF8Encoder new ]! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testReadingLimited
	| contents |
	contents := String new: 1025 withAll: $X.
	ZnMaximumEntitySize value: 1024 during: [
		self should: [
			ZnEntity 
				readFrom: contents asByteArray readStream 
				usingType: ZnMimeType textPlain 
				andLength: contents size ]
			raise: ZnEntityTooLarge.
		self should: [
			ZnEntity 
				readFrom: contents asByteArray readStream 
				usingType: ZnMimeType textPlain 
				andLength: nil ]
			raise: ZnEntityTooLarge ] ! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testMultiPartFormDataWriteReadBinary
	| input output bytes |
	input := ZnMultiPartFormDataEntity new
		addPart: (ZnMimePart fieldName: 'extra' value: 'my-extra');
		addPart: (ZnMimePart fieldName: 'info' value: 'my-info');
		addPart: (ZnMimePart fieldName: 'file' fileName: 'foo.txt' entity: (ZnEntity text: 'Zinc HTTP Components'));
		yourself.
	self assert: input contentLength notNil.
	self assert: input contentLength > 0.
	self assert: (input contentType matches: ZnMimeType multiPartFormData).
	bytes := ByteArray streamContents: [ :stream | input writeOn: stream ].
	output := ZnEntity readBinaryFrom: bytes readStream usingType: input contentType andLength: bytes size.
	self assert: (output partNamed: 'extra') fieldValue equals: 'my-extra' asByteArray.
	self assert: (output partNamed: 'info') fieldValue equals: 'my-info' asByteArray.
	self assert: (output partNamed: 'extra') fieldValueString equals: 'my-extra'.
	self assert: (output partNamed: 'info') fieldValueString equals: 'my-info'.
	self deny: (output partNamed: 'file') contents isString.
	self assert: (output partNamed: 'file') contents equals: 'Zinc HTTP Components' asByteArray! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testStringEntityEncoderInitialization
	| entity response |
	entity := ZnEntity text: 'Regression test'.
	self assert: entity hasEncoder not.
	response := ZnResponse ok: entity.
	self assert: entity hasEncoder.
	ByteArray streamContents: [ :stream | response writeOn: stream ].
	self assert: entity hasEncoder
	! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testUTF8ReadingDetermined
	| string entity bytes |
	string := String
		with: $$
		with: 16r00A2 asCharacter
		with: 16r20AC asCharacter
		with: 16r024B62 asCharacter.
	entity := ZnStringEntity type: ZnMimeType textPlain length: 10.
	bytes := #(16r24 16rC2 16rA2 16rE2 16r82 16rAC 16rF0 16rA4 16rAD 16rA2) asByteArray.
	entity readFrom: bytes readStream.
	self assert: entity contentType equals: ZnMimeType textPlain.
	self assert: entity contentLength equals: 10.
	self assert: entity contents equals: string! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testReadingApplicationFormUrlEncodingNoLength
	| input entity |
	input := #(111 97 117 116 104 95 116 111 107 101 110 95 115 101 99 114 101 116 61 98 121 112 104 57 99 109 104 106 49 53 101 108 121 56 38 111 97 117 116 104 95 116 111 107 101 110 61 56 54 101 112 106 51 116 118 100 49 107 115 120 111 57)
		asByteArray.
	entity := ZnEntity readFrom: input readStream usingType: ZnMimeType applicationFormUrlEncoded andLength: nil.
	self deny: entity isEmpty.
	self assert: (entity includesField: 'oauth_token_secret').
	self assert: (entity includesField: 'oauth_token').
	self assert: (entity at: 'oauth_token_secret') equals: 'byph9cmhj15ely8'.
	self assert: (entity at: 'oauth_token') equals: '86epj3tvd1ksxo9'! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testReadingBinary
	| contents entity |
	contents := 'This is a test'.
	entity := ZnEntity readBinaryFrom: contents asByteArray readStream usingType: ZnMimeType textPlain andLength: contents size.
	self deny: entity contents isString.
	self assert: entity contents equals: contents asByteArray.
	self assert: entity contentLength equals: contents size.
	self assert: entity contentType equals: ZnMimeType textPlain! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testWritingApplicationUrlEncodingWithTextEncodingUtf8
	| entity string |
	entity := ZnApplicationFormUrlEncodedEntity new.
	entity contentType charSet: 'utf-8'.
	entity at: 'foo' put: (Character value: 246) asString.
	string := String streamContents: [ :stream | entity writeOn: stream ].
	self assert: string equals: 'foo=%C3%B6'.
	self assert: entity contentLength equals: 10! !

!ZnEntityTest methodsFor: 'testing' stamp: ''!
testApplicationUrlEncodingAddAll
	| entity string data |
	data := Dictionary new.
	data at: 'foo' put: 1 asString.
	data at: 'bar' put: 2 asString.
	entity := ZnApplicationFormUrlEncodedEntity new.
	"Asking for the content length will force an internal computation of the representation"
	self assert: entity contentLength equals: 0.
	entity addAll: data.
	string := String streamContents: [ :stream | entity writeOn: stream ].
	self assert: entity contentLength > 0.
	entity := ZnEntity readFrom: string readStream usingType: ZnApplicationFormUrlEncodedEntity designatedMimeType andLength: string size.
	self assert: (entity at: 'foo') equals: '1'.
	self assert: (entity at: 'bar') equals: '2'! !

!ZnEntityTooLarge commentStamp: ''!
ZnEntityTooLarge is signalled when too big an entity is read from a stream.

This is a resumable exception!
!ZnEntityTooLarge methodsFor: 'testing' stamp: ''!
isResumable
	"Determine whether an exception is resumable."

	^ true! !

!ZnEntityWriter commentStamp: ''!
I am ZnEntityWriter, I help writing ZnEntities to a stream given meta data in headers.

I deal with chunking and gzip encoding.

Part of Zinc HTTP Components.!
!ZnEntityWriter methodsFor: 'testing' stamp: ''!
isChunked
	| transferEncoding |
	transferEncoding := self headers at: 'Transfer-Encoding' ifAbsent: [ ^ false ].
	^ transferEncoding = 'chunked' or: [ transferEncoding beginsWith: 'chunked' ]! !

!ZnEntityWriter methodsFor: 'accessing' stamp: ''!
headers: znHeaders
	headers := znHeaders! !

!ZnEntityWriter methodsFor: 'accessing' stamp: ''!
headers
	^ headers! !

!ZnEntityWriter methodsFor: 'testing' stamp: ''!
isGzipped
	| contentEncoding |
	contentEncoding := self headers at: 'Content-Encoding' ifAbsent: [ ^ false ].
	^ contentEncoding = 'gzip'! !

!ZnEntityWriter methodsFor: 'accessing' stamp: ''!
stream: writeStream
	stream := writeStream! !

!ZnEntityWriter methodsFor: 'accessing' stamp: ''!
contentType
	^ (self headers includesKey: 'Content-Type') 
		ifTrue: [ self headers contentType ] 
		ifFalse: [ ZnMimeType default ]! !

!ZnEntityWriter methodsFor: 'accessing' stamp: ''!
stream
	^ stream! !

!ZnEntityWriter methodsFor: 'public' stamp: ''!
writeEntity: entity
	| actualStream gzipStream bufferedStream chunkedStream isChunked |
	actualStream := stream.
	chunkedStream := gzipStream := bufferedStream := nil.
	(isChunked := self isChunked)
		ifTrue: [ 
			chunkedStream := actualStream := ZnChunkedWriteStream on: actualStream ].
	self isGzipped 
		ifTrue: [ 
			gzipStream := actualStream := GZipWriteStream on: actualStream ]
		ifFalse: [ 
			(isChunked and: [ self contentType isBinary not ])
				ifTrue: [ bufferedStream := actualStream := ZnUtils bufferedWriteStreamOn: actualStream ] ].
	entity writeOn: actualStream.
	gzipStream 
		ifNotNil: [ gzipStream finish ].
	bufferedStream 
		ifNotNil: [ bufferedStream finish ].
	chunkedStream
		ifNotNil: [ chunkedStream finish ]
	! !

!ZnEntityWriterTest methodsFor: 'testing' stamp: ''!
testGzippedAndChunked
	| entity headers writer output reader result |
	entity := 	ZnEntity text: (String streamContents: [ :out |
		{ Collection. Stream. Exception. Magnitude } do: [ :cls |
			cls allSubclassesDo: [ :each | out nextPutAll: each comment ] ] ]).
	headers := ZnHeaders new
		acceptEntityDescription: entity;
		at: 'Content-Encoding' put: 'gzip';
		at: 'Transfer-Encoding' put: 'chunked';
		yourself.
	output := ByteArray streamContents: [ :out |
		writer := ZnEntityWriter new
			stream: out;
			headers: headers;
			yourself.
		writer writeEntity: entity ].
	reader := ZnEntityReader new
		stream: output readStream;
		headers: headers;
		yourself.
	result := reader readEntity.
	self assert: result contents equals: entity contents! !

!ZnEntityWriterTest methodsFor: 'testing' stamp: ''!
testChunkedOnly
	| entity headers writer output reader result |
	entity := 	ZnEntity text: (String streamContents: [ :out |
		{ Collection. Stream. Exception. Magnitude } do: [ :cls |
			cls allSubclassesDo: [ :each | out nextPutAll: each comment ] ] ]).
	headers := ZnHeaders new
		acceptEntityDescription: entity;
		at: 'Transfer-Encoding' put: 'chunked';
		yourself.
	output := ByteArray streamContents: [ :out |
		writer := ZnEntityWriter new
			stream: out;
			headers: headers;
			yourself.
		writer writeEntity: entity ].
	reader := ZnEntityReader new
		stream: output readStream;
		headers: headers;
		yourself.
	result := reader readEntity.
	self assert: result contents equals: entity contents! !

!ZnEntityWriterTest methodsFor: 'testing' stamp: ''!
testPlainUsingReader
	| entity headers writer output reader result |
	entity := ZnEntity text: 'Foo bar!!'.
	headers := ZnHeaders new 
		acceptEntityDescription: entity; 
		yourself.
	output := ByteArray streamContents: [ :out |
		writer := ZnEntityWriter new
			stream: out;
			headers: headers;
			yourself.
		writer writeEntity: entity ].
	reader := ZnEntityReader new
		stream: output readStream;
		headers: headers;
		yourself.
	result := reader readEntity.
	self assert: result contents equals: 'Foo bar!!'! !

!ZnEntityWriterTest methodsFor: 'testing' stamp: ''!
testPlain
	| entity writer output |
	entity := ZnEntity text: 'Foo bar!!'.
	output := ByteArray streamContents: [ :out |
		writer := ZnEntityWriter new
			stream: out;
			headers: ZnHeaders new;
			yourself.
		writer writeEntity: entity ].
	self assert: output equals: 'Foo bar!!' asByteArray! !

!ZnFastLineReader commentStamp: ''!
I am ZnFastLineReader, a helper to efficiently read CR, LF or CRLF terminated lines from a character stream.!
!ZnFastLineReader methodsFor: 'initialize' stamp: ''!
bufferStream: characterWriteStream
	^ bufferStream := characterWriteStream! !

!ZnFastLineReader methodsFor: 'private' stamp: ''!
streamContents: block
	"Like readStream collectionSpecies streamContents: block
	but reusing the underlying buffer for improved efficiency"
	
	bufferStream 
		ifNil: [ 
			bufferStream := (readStream collectionSpecies new: 32) writeStream ].
	bufferStream reset.
	block value: bufferStream.
	^ bufferStream contents! !

!ZnFastLineReader methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	cr := Character cr.
	lf := Character lf! !

!ZnFastLineReader methodsFor: 'initialize' stamp: ''!
beWide
	self bufferStream: (WideString new: 32) writeStream! !

!ZnFastLineReader methodsFor: 'initialize' stamp: ''!
close
	readStream close! !

!ZnFastLineReader methodsFor: 'testing' stamp: ''!
atEnd
	^ readStream atEnd! !

!ZnFastLineReader methodsFor: 'initialize' stamp: ''!
on: characterReadStream
	readStream := characterReadStream ! !

!ZnFastLineReader methodsFor: 'accessing' stamp: ''!
nextLine
	"Read a CR, LF or CRLF terminated line, returning the contents of the line without the EOL. Return nil when the receiver is #atEnd."
	
	self atEnd ifTrue: [ ^ nil ].
	^ self streamContents: [ :out | | eol char |
		eol := false.
		[ eol ] whileFalse: [ 
			char := readStream next.
			(char isNil or: [ char == lf ])
				ifTrue: [ eol := true ]
				ifFalse: [ 
					char == cr 
						ifTrue: [ eol := true. readStream peekFor: lf ]
						ifFalse: [  out nextPut: char ] ] ] ]! !

!ZnFastLineReader methodsFor: 'accessing' stamp: ''!
linesDo: block
	[ self atEnd ]
		whileFalse: [ 
			| line |
			line := self nextLine.
			line isNil
				ifFalse: [ block value: line ] ]! !

!ZnFastLineReader class methodsFor: 'instance creation' stamp: ''!
on: characterReadStream
	^ self new 
		on: characterReadStream;
		yourself! !

!ZnFastLineReaderTest methodsFor: 'testing' stamp: ''!
testLinesDo
	| lines reader |
	lines := #( 'foo' 'bar' 'last').
	reader := ZnFastLineReader on: (Character lf join: lines) readStream.
	self 
		assert: (Array streamContents: [ :out | 
					reader linesDo: [ :line | out nextPut: line ] ])
		equals: lines! !

!ZnFastLineReaderTest methodsFor: 'testing' stamp: ''!
testNextLine
	| reader |
	reader := ZnFastLineReader on: 'abc' readStream.
	self assert: reader nextLine equals: 'abc'.
	self assert: reader atEnd.
	self assert: reader nextLine  equals: nil.
	reader := ZnFastLineReader on: '' readStream.
	self assert: reader nextLine equals: nil.
	self assert: reader atEnd.
	reader := ZnFastLineReader on: (String withAll: { 
		$a. Character cr. 
		$b. Character lf. 
		$c }) readStream.
	self assert: reader nextLine equals: 'a'.
	self assert: reader nextLine equals: 'b'.
	self assert: reader nextLine equals: 'c'.
	self assert: reader nextLine equals: nil.
	reader := ZnFastLineReader on: (String withAll: { 
		$a. Character cr. Character lf.  
		$b. Character cr. Character lf. 
		$c. Character cr. Character lf }) readStream.
	self assert: reader nextLine equals: 'a'.
	self assert: reader nextLine equals: 'b'.
	self assert: reader nextLine equals: 'c'.
	self assert: reader nextLine equals: nil.
	reader := ZnFastLineReader on: (String withAll: { 
		$a. Character cr. Character lf.  
		Character cr. Character lf. 
		$c. Character cr. Character lf }) readStream.
	self assert: reader nextLine equals: 'a'.
	self assert: reader nextLine equals: ''.
	self assert: reader nextLine equals: 'c'.
	self assert: reader atEnd! !

!ZnFileRetrieveContents commentStamp: ''!
I am ZnFileRetrieveContents.
I am a ZnUrlOperation.

I implement the #retrieveContents URL operation for FILE urls.

Part of Zinc HTTP Components.
!
!ZnFileRetrieveContents methodsFor: 'operations' stamp: ''!
performOperation
	"Download and return the FILE resource that url refers to.
	This will typically return a String or a ByteArray (see AbstractFileReference>>#contents).
	If something goes wrong, an exception will be signalled."
	
	^ self url asFileReference contents! !

!ZnFileRetrieveContents class methodsFor: 'accessing' stamp: ''!
operation
	^ #retrieveContents! !

!ZnFileRetrieveContents class methodsFor: 'accessing' stamp: ''!
schemes
	^ #( #file )! !

!ZnFileSystemUtils commentStamp: ''!
I am ZnFileSystemUtils.
I help is abstracting over API differences pre and post the introduction of FileSystem in Pharo 2.0

Part of Zinc HTTP Components.!
!ZnFileSystemUtils class methodsFor: 'queries' stamp: ''!
modificationTimeFor: path
	^ path asFileReference entry modificationTime ! !

!ZnFileSystemUtils class methodsFor: 'paths' stamp: ''!
extensionFor: fileName
	^ fileName asFileReference extension! !

!ZnFileSystemUtils class methodsFor: 'streams' stamp: ''!
oldFileStreamFor: fileName
	^ fileName asFileReference 
		readStreamIfAbsent: [ FileDoesNotExistException signalWith: fileName asFileReference ]! !

!ZnFileSystemUtils class methodsFor: 'paths' stamp: ''!
fullNameFor: fileName
	^ fileName asFileReference fullName! !

!ZnFileSystemUtils class methodsFor: 'streams' stamp: ''!
fileStreamFor: fileName
	^ fileName asFileReference 
		writeStream! !

!ZnFileSystemUtils class methodsFor: 'defaults' stamp: ''!
defaultDirectory
	^ FileSystem disk workingDirectory! !

!ZnFileSystemUtils class methodsFor: 'paths' stamp: ''!
directory: path
	^ path asFileReference! !

!ZnFileSystemUtils class methodsFor: 'streams' stamp: ''!
binaryFileReadStreamFor: fileName 

	^ fileName asFileReference binaryReadStream! !

!ZnFileSystemUtils class methodsFor: 'streams' stamp: ''!
binaryFileStreamFor: fileName
	| fileReference |
	fileReference := fileName asFileReference.
	^ fileReference binaryWriteStream! !

!ZnFileSystemUtils class methodsFor: 'queries' stamp: ''!
fileSizeFor: fileName
	^ fileName asFileReference entry size! !

!ZnFileSystemUtils class methodsFor: 'paths' stamp: ''!
downloadPathTo: directoryOrFileName for: baseName
	| downloadPath |
	downloadPath := directoryOrFileName asFileReference.
	^ downloadPath isDirectory
		ifTrue: [
			baseName ifNil: [ 
				self error: 'Not enough information to construct a download path' ]. 
			(downloadPath / baseName) fullName ]
		ifFalse: [ 
			directoryOrFileName ]
	! !

!ZnFileSystemUtils class methodsFor: 'defaults' stamp: ''!
defaultDirectoryPath
	^ self defaultDirectory fullName! !

!ZnFileSystemUtils class methodsFor: 'streams' stamp: ''!
fileNamed: fileName do: block
	^ fileName asFileReference 
		writeStreamDo: block! !

!ZnFileSystemUtils class methodsFor: 'streams' stamp: ''!
newBinaryFileNamed: fileName do: block
	| fileReference |
	fileReference := fileName asFileReference.
	^ (fileReference respondsTo: #binaryWriteStreamDo:ifPresent:)
		ifTrue: [
			fileName asFileReference 
				binaryWriteStreamDo: block 
				ifPresent: [ FileExists signalWith: fileReference ] ]
		ifFalse: [ 
			fileReference isFile 
				ifTrue: [ FileExists signalWith: fileReference ] 
				ifFalse: [ block value: (self binaryFileStreamFor: fileName) ] ]! !

!ZnFileSystemUtils class methodsFor: 'streams' stamp: ''!
newFileNamed: fileName do: block
	^ fileName asFileReference 
		writeStreamDo: block 
		ifPresent: [ FileExists signalWith: fileName asFileReference ]! !

!ZnFileSystemUtils class methodsFor: 'paths' stamp: ''!
deleteIfExists: path
	^ (self exists: path)
		ifTrue: [ self delete: path. true ]
		ifFalse: [ false ]! !

!ZnFileSystemUtils class methodsFor: 'paths' stamp: ''!
delete: path
	^ path asFileReference delete! !

!ZnFileSystemUtils class methodsFor: 'streams' stamp: ''!
oldFileNamed: fileName do: block
	^ fileName asFileReference 
		readStreamDo: block
		ifAbsent: [ FileDoesNotExistException signalWith: fileName asFileReference ]! !

!ZnFileSystemUtils class methodsFor: 'paths' stamp: ''!
exists: path
	^ path asFileReference exists! !

!ZnFileSystemUtils class methodsFor: 'paths' stamp: ''!
baseNameFor: fileName
	^ fileName asFileReference basename ! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testAsFileReference
	| fileUrl fileReference |
	fileUrl := 'file:///foo/bar/test.txt' asZnUrl.
	fileReference := fileUrl asFileReference.
	self assert: fileReference basename equals: 'test.txt'.
	self assert: fileReference pathSegments asArray equals: #( 'foo' 'bar' 'test.txt' ).
	self assert: fileReference isAbsolute ! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testRetrieveContents
	| fileReference contents url |
	SystemVersion current major < 3 ifTrue: [ self skip ].
	fileReference := ('file-{1}.txt' format: {(1000 atRandom)}) asFileReference.
	contents := 'Testing {1} and counting.{2}' format: {(1000 atRandom). (String crlf)}.
	fileReference ensureDelete.
	fileReference writeStreamDo: [ :stream | stream nextPutAll: contents ].
	url := fileReference asZnUrl.
	self assert: url isFile.
	self assert: url retrieveContents equals: contents.
	fileReference ensureDelete! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testImage
	self assert: ZnUrl image asFileReference exists! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testAsZnUrl
	| fileReference fileUrl |
	fileReference := FileLocator root / 'foo' / 'bar' / 'test.txt'.
	fileUrl := fileReference asZnUrl.
	self assert: fileUrl isFile.
	self assert: fileUrl directory equals: 'foo/bar'.
	self assert: fileUrl file equals: 'test.txt'.
	self assert: fileUrl pathSegments asArray equals: #( 'foo' 'bar' 'test.txt').
	self assert: fileUrl pathPrintString equals: '/foo/bar/test.txt'.
	self assert: fileUrl printString equals: 'file:///foo/bar/test.txt'.
	self deny: fileUrl hasHost.
	self deny: fileUrl hasPort.
	self deny: fileUrl hasQuery.
	self deny: fileUrl hasFragment! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testSpaces
	self 
		assert: 'file:///foo%20bar/test.st' asZnUrl asFileReference 
		equals: FileLocator root / 'foo bar' / 'test.st'.
	self 
		assert: (FileLocator root / 'foo bar' / 'test.st') asZnUrl 
		equals: 'file:///foo%20bar/test.st' asZnUrl! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testSlash
	| fileUrl fileReference |
	fileUrl := 'file:///' asZnUrl.
	self assert: fileUrl isSlash.
	self assert: fileUrl isFile.
	fileReference := fileUrl asFileReference.
	self assert: fileReference isRoot! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testWrongScheme
	self should: [ 'http://zn.stfx.eu/zn/small.html' asZnUrl asFileReference ] raise: AssertionFailure! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testTrailingSlash
	| fileReference1 fileReference2 fileUrl1 fileUrl2 |
	fileReference1 := '/foo/bar' asFileReference.
	fileReference2 := '/foo/bar/' asFileReference.
	self assert: fileReference1 equals: fileReference2.
	self assert: fileReference1 asZnUrl equals: fileReference2 asZnUrl.

	fileUrl1 := 'file:///foo/bar' asZnUrl.
	fileUrl2 := 'file:///foo/bar/' asZnUrl.
	self deny: fileUrl1 equals: fileUrl2.
	self assert: fileUrl1 asFileReference equals: fileUrl2 asFileReference! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testWindowsDriveNamesInFileUrl
	"Note the 3 slashes: 2 are from the scheme, file://, 1 is from the empty host and starts the absolute path"
	
	SystemVersion current major < 3 ifTrue: [ self skip ].
	self 
		assert: 'file:///C:/Programs/notepad.exe' asUrl asFileReference
		equals: FileLocator C / 'Programs' / 'notepad.exe'.
	self 
		assert: 'file:///C:' asUrl asFileReference
		equals: FileLocator C! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testRelative
	| fileReference fileUrl |
	fileReference := 'foo/bar/test.txt' asFileReference.
	self assert: fileReference isRelative.
	fileUrl := fileReference asZnUrl.
	self assert: fileUrl isFile.
	self assert: fileUrl pathSegments size >= fileReference pathSegments size.
	self assert: (fileUrl pathSegments asArray endsWith: fileReference pathSegments asArray)! !

!ZnFileUrlTest methodsFor: 'testing' stamp: ''!
testRoot
	| fileUrl fileReference |
	fileReference := FileLocator root.
	self assert: fileReference isRoot.
	fileUrl := fileReference asZnUrl.
	self assert: fileUrl isFile.
	self assert: fileUrl isSlash! !

!ZnHTTPSTest commentStamp: ''!
ZnHTTPSTests.

These require that the ZnZodiacNetworkingUtils socket stream factory is enabled:

	ZnNetworkingUtils default: ZnZodiacNetworkingUtils new.
	
Part of Zinc HTTP Components!
!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
testAmazonAWS
	| client |
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self ].
	(client := ZnClient new) 
		get: 'https://aws.amazon.com/'.
	self assert: client isSuccess.
	self assert: (client contents includesSubstring: 'Amazon').
	client close! !

!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
disabledTestPayPal
	| client |
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self ].
	(client := ZnClient new) 
		get: 'https://www.paypal.com'.
	self assert: client isSuccess.
	self assert: (client contents includesSubstring: 'PayPal').
	client close! !

!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
testRequestResponse
	| query stream request response |
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self ].
	query := 'Smalltalk'.
	stream := ZdcSecureSocketStream openConnectionToHostNamed: 'duckduckgo.com' port: 443.
	request := nil.
	response := [
		request := ZnRequest get: 'https://duckduckgo.com?q=', query.
		stream connect.
		request writeOn: stream.
		stream flush.
		ZnResponse readFrom: stream.
	] ensure: [ stream close ].
	self assert: response isSuccess.
	self assert: (response contents includesSubstring: 'Duck').   
	self assert: (response contents includesSubstring: query).! !

!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
testWikimedia
	| client |
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self ]. 
	(client := ZnClient new) 
		get: 'https://secure.wikimedia.org/'.
	self assert: client isSuccess.
	self assert: (client contents includesSubstring: 'Wikimedia').
	client close! !

!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
testGetPharoVersion
	| lastBuildVersion version url versionName |
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self ].
	self runningOnWindowsInriaCI ifTrue: [ ^ self ].
	
	versionName := SystemVersion current type , SystemVersion current dottedMajorMinor.

	url := ZnUrl new 
		scheme: #https;
		host: 'ci.inria.fr';
		addPathSegments: #('pharo-ci-jenkins2' 'job' 
			'Test pending pull request and branch Pipeline' 'job');
		addPathSegment: versionName;
		addPathSegments: #('api' 'xml');
		queryAt: 'xpath' add: '/*/fullDisplayName';
		yourself.
	
	lastBuildVersion := ZnClient new
		beOneShot;
		get: url.
	self assert: lastBuildVersion notNil.
	self assert: lastBuildVersion isString.
	self assert: lastBuildVersion size > 0.
	version := (lastBuildVersion copyAfter: $>) copyUpTo: $<.
	self deny: version isEmpty! !

!ZnHTTPSTest methodsFor: 'private' stamp: ''!
doesNativeSSLPluginSupportSNI
	"Return whether the SSL VM plugin supports SNI."
	
	^ [ ZdcPluginSSLSession new serverName; serverName: nil; destroy. true ]
			on: ZdcPluginMissing, PrimitiveFailed
			do: [ false ]! !

!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
testGmailEncrypted
	| client |
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self ].  
	(client := ZnClient new) 
		get: 'https://www.gmail.com'.
	self assert: client isSuccess.
	self assert: (client contents includesSubstring: 'Google').    
	self assert: (client contents includesSubstring: 'mail'). 
	client close! !

!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
testGoogleEncrypted
	| client |
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self ].
	(client := ZnClient new) 
		get: 'https://encrypted.google.com/search?q=Smalltalk'.
	self assert: client isSuccess.
	self assert: (client contents includesSubstring: 'Google').    
	self assert: (client contents includesSubstring: 'Smalltalk').
	client close! !

!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
testInriaGitlab
	| client |
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self ].
	(client := ZnClient new)
		get: 'https://gitlab.inria.fr/'.
	self assert: client isSuccess.
	self assert: (client contents includesSubstring: 'inria').
	client close! !

!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
testTransfers
	self timeLimit: 300 seconds.
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self ].
	
	(Integer primesUpTo: 100) do: [ :each | | size client |
		size := 1024 * each + each.
		(client := ZnClient new)
			https;
			host: 's3-eu-west-1.amazonaws.com';
			addPath: 'public-stfx-eu';
			addPath: ('test-', size asString, '.txt');
			get;
			close.
		self assert: client isSuccess.
		self assert: (client response contentType matches: ZnMimeType textPlain).
		self assert: client response contentLength equals: size.
		self 
			assert: client contents 
			equals: (self class generateTestData: size)	]! !

!ZnHTTPSTest methodsFor: 'private' stamp: ''!
ensureSocketStreamFactory
	self 
		assert: ZnNetworkingUtils default secureSocketStreamClass notNil
		description: 'Please set a secure socket stream class in ZnNetworkingUtils default or switch to the ZnZodiacNetworkingUtils socket stream factory'! !

!ZnHTTPSTest methodsFor: 'private' stamp: ''!
isNativeSSLPluginPresent
	"Return whether the SSL VM plugin can be instanciated and intialized."
	
	^ [ ZdcPluginSSLSession new destroy. true ]
			on: ZdcPluginMissing
			do: [ false ]! !

!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
testTransfersSingleClient
	| client |
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self ].
	(client := ZnClient new)
		https;
		host: 's3-eu-west-1.amazonaws.com'.
	(Integer primesUpTo: 100) do: [ :each | | size |
		size := 1024 * each + each.
		client
			url: ('/public-stfx-eu/test-', size asString, '.txt');
			get.
		self assert: client isSuccess.
		self assert: (client response contentType matches: ZnMimeType textPlain).
		self assert: client response contentLength equals: size.
		self 
			assert: client contents 
			equals: (self class generateTestData: size)	].
	client close! !

!ZnHTTPSTest methodsFor: 'private' stamp: ''!
runningOnWindows
	"Pharo 3+"
	[ ^ OSPlatform current isWindows ] on: MessageNotUnderstood do: [ ].
	"Pharo 2-"
	[ ^ OSPlatform isWin32 ] on: MessageNotUnderstood do: [ ].
	"Give up"
	^ false! !

!ZnHTTPSTest methodsFor: 'private' stamp: ''!
timeLimit: seconds
	(TestCase canUnderstand: #timeLimit:)
		ifTrue: [ super timeLimit: seconds ]! !

!ZnHTTPSTest methodsFor: 'private' stamp: ''!
runningOnWindowsInriaCI
	| platform ci |
	self runningOnWindows
		ifFalse: [ ^ false ].
	^ [ 
	platform := OSPlatform current.
	ci := platform environment at: 'CI' ifAbsent: [ '' ].
	ci = 'ci.inria.fr' ]
		on: MessageNotUnderstood
		do: [ false ]! !

!ZnHTTPSTest methodsFor: 'testing' stamp: ''!
testSNIPage
	| client |
	self ensureSocketStreamFactory.
	self isNativeSSLPluginPresent ifFalse: [ ^ self skip ].
	self doesNativeSSLPluginSupportSNI ifFalse: [ ^ self skip ].
	
	(client := ZnClient new) 
		get: 'https://www.mnot.net/blog/2014/05/09/if_you_can_read_this_youre_sniing'.

	self assert: client isSuccess.

	client close! !

!ZnHTTPSTest class methodsFor: 'testing' stamp: ''!
generateTestFiles
	"self generateTestFiles"
	
	(Integer primesUpTo: 100) do: [ :each | | size |
		size := 1024 * each + each.
		('test-', size asString, '.txt') asFileReference writeStreamDo: [ :stream |
			stream nextPutAll: (self generateTestData: size) ] ]! !

!ZnHTTPSTest class methodsFor: 'testing' stamp: ''!
generateTestData: size
	"self generateTestData: 1111"
	
	^ String 
		streamContents: [ :stream |
			stream << 'Transfer test file of size '; print: size; << ' bytes.'; lf.
			1 to: size do: [ :each |
				stream nextPutAll: 'Line '; print: each; lf ] ] 
		limitedTo: size ! !

!ZnHeaders commentStamp: ''!
I am ZnHeaders.
I am a collection of HTTP headers.
I can be used for generating and parsing.

Header names are normalized and used case insensitive.
Header values can be multi-valued.

Part of Zinc HTTP Components.!
!ZnHeaders methodsFor: 'testing' stamp: ''!
isEmpty 
	^ headers isNil or: [ self headers isEmpty ]! !

!ZnHeaders methodsFor: 'comparing' stamp: ''!
= other
	self class = other class ifFalse: [ ^ false ].
	^ self headers = other headers! !

!ZnHeaders methodsFor: 'testing' stamp: ''!
hasContentType
	^ self includesKey: 'Content-Type'! !

!ZnHeaders methodsFor: 'comparing' stamp: ''!
hash
	^ self headers hash! !

!ZnHeaders methodsFor: 'testing' stamp: ''!
isDescribingEntity
	"Do I include enough information to describe an entity (i.e. content length and type) ?"
	
	^ (self headers includesKey: 'Content-Type') 
		and: [ self headers includesKey: 'Content-Length' ]
! !

!ZnHeaders methodsFor: 'testing' stamp: ''!
hasContentLength
	^ self includesKey: 'Content-Length'! !

!ZnHeaders methodsFor: 'writing' stamp: ''!
writeOn: stream
	| writeStream |
	writeStream := ZnBivalentWriteStream on: stream.
	self headersDo: [ :key :value |
		writeStream nextPutAll: key; nextPut: $:; space; nextPutAll: value; nextPutAll: String crlf ]! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
at: headerName ifPresent: block
	"Like #at: but executes block when the headerName is found"

	^ self headers at: (self normalizeHeaderKey: headerName) ifPresent: block! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
contentLength
	"We allow multiple content-length headers provided they are identical."
	
	| value |
	(value := self headers at: 'Content-Length') isString
		ifFalse: [
			value asSet size = 1
				ifTrue: [ value := value first ]
				ifFalse: [ self error: 'Multiple, different Content-Length headers are not allowed' ] ].
	^ Integer readFrom: value ifFail: [ self error: 'Illegal HTTP Content Length' ] ! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
acceptEntityDescription: entity
	"Take over the content type and length from entity"
	
	entity 
		ifNotNil: [
			self
				contentType: entity contentType;
				contentLength: entity contentLength ]
		ifNil: [
			self 
				clearContentType; 
				clearContentLength ] ! !

!ZnHeaders methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	self isEmpty ifFalse: [ self headers printElementsOn: stream ]
	! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
at: headerName
	"Return the value stored under headerName,
	a String for single-valued headers, an Array of Strings for multi-valued headers"
	
	^ self headers at: (self normalizeHeaderKey: headerName)! !

!ZnHeaders methodsFor: 'private' stamp: ''!
readOneHeaderFrom: stream
	| key value |
	key := stream upTo: $:.
	[ stream peek == Character space ] whileTrue: [ stream next ].
	value := stream upToEnd.
	self at: key add: value.
	^ key! !

!ZnHeaders methodsFor: 'enumerating' stamp: ''!
keysAndValuesDo: block
	"Execute a two argument (key, value) block for each header.
	Multi-valued headers are handled transparently."

	self headersDo: block! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
at: headerName ifAbsent: block
	"Like #at: but executes block when the headerName is not found"
	
	self isEmpty ifTrue: [ ^ block value ].
	^ self headers at: (self normalizeHeaderKey: headerName) ifAbsent: block! !

!ZnHeaders methodsFor: 'initialize-release' stamp: ''!
unlimited
	self headers unlimited! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
clearContentLength
	self removeKey: 'Content-Length' ifAbsent: [] ! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
removeKey: headerName ifAbsent: block
	self isEmpty ifTrue: [ ^ block value ].
	^ self headers removeKey: (self normalizeHeaderKey: headerName) ifAbsent: block! !

!ZnHeaders methodsFor: 'initialize-release' stamp: ''!
readFrom: stream
	| line reader |
	reader := ZnLineReader on: stream.
	[ (line := reader nextLine) isEmpty ] whileFalse: [ | key |
		key := self readOneHeaderFrom: line readStream.
		"Continuation header lines start with a space or tab"
		[ stream atEnd not and: [ #[ 32 9 ] includes: stream peek asInteger ] ]
			whileTrue: [ 
				self extendHeaderAt: key from: reader nextLine ] ] ! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
request: url
	"Setup the receiver to request url"
	
	(url isNil or: [ url hasHost not ]) ifTrue: [ ^ self ].  
	self at: 'Host' put: url authority.
	(ZnNetworkingUtils proxyAuthorizationHeaderValueToUrl: url)
		ifNotNil: [ :value | self at: 'Proxy-Authorization' put: value ].    
  ! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
clearContentType
	self removeKey: 'Content-Type' ifAbsent: [] ! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
at: headerName put: value ifPresentMerge: binaryBlock
	"Store value under headerName, when there is an existing entry,
	stored the result of evaluating binaryBlock with old and new value"
	
	| normalizedKey existingValue newValue |
	normalizedKey := self normalizeHeaderKey: headerName.
	existingValue := self headers at: normalizedKey ifAbsent: [ nil ].
	newValue := existingValue isNil
		ifTrue: [ value ] 
		ifFalse: [ binaryBlock value: existingValue value: value ].
	^ self headers at: normalizedKey put: newValue 
		

! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
at: headerName put: value
	"Store value under headerName, replace existing entries"
	
	^ self headers at: (self normalizeHeaderKey: headerName) put: value! !

!ZnHeaders methodsFor: 'private' stamp: ''!
headers
	headers isNil ifTrue: [ headers := ZnMultiValueDictionary new ].
	^ headers! !

!ZnHeaders methodsFor: 'enumerating' stamp: ''!
headersDo: block
	"Execute a two argument (key, value) block for each header.
	Multi-valued headers are handled transparently."

	self isEmpty ifTrue: [ ^ self ].
	self headers keysAndValuesDo: [ :headerKey :headerValue |
		headerValue isArray
			ifTrue: [ 
				headerValue do: [ :each | 
					block value: headerKey value: each ] ]
			ifFalse: [
				block value: headerKey value: headerValue ] ]! !

!ZnHeaders methodsFor: 'copying' stamp: ''!
postCopy
	headers := headers copy! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
contentType
	| headerValue |
	headerValue := (self headers at: 'Content-Type') trimBoth.
	headerValue isEmpty ifTrue: [ ^ ZnMimeType default ].
	^ ZnMimeType fromString: headerValue! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
removeKey: headerName	
	^ self headers removeKey: (self normalizeHeaderKey: headerName)! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
at: headerName add: value
	"Store value under headerName, optionally turning it into a multi-valued header 
	when a value was already present"
	
	^ self headers at: (self normalizeHeaderKey: headerName) add: value 
		
! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
addAll: keyedCollection
	"Note that we use #addAllMulti:"

	keyedCollection isEmpty
		ifFalse: [ self headers addAllMulti: keyedCollection ].
	^ keyedCollection! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
contentType: object
	self at: 'Content-Type' put: object asString! !

!ZnHeaders methodsFor: 'private' stamp: ''!
extendHeaderAt: key from: line
	"The value of a continuation header line is concatenated, 
	keeping the whitespace, but without the CRLF"

	| existingValue newValue |
	existingValue := self at: key.
	newValue := existingValue isArray
		ifTrue: [ | last |
			last := existingValue size.
			existingValue at: last put: ((existingValue at: last) , line).
			existingValue ]
		ifFalse: [ existingValue , line ].
	self at: key put: newValue! !

!ZnHeaders methodsFor: 'accessing' stamp: ''!
contentLength: object
	self at: 'Content-Length' put: object asString! !

!ZnHeaders methodsFor: 'testing' stamp: ''!
includesKey: headerName
	^ self isEmpty not and: [ self headers includesKey: (self normalizeHeaderKey: headerName) ]
	! !

!ZnHeaders methodsFor: 'private' stamp: ''!
normalizeHeaderKey: string
	"Test string to see if it has proper header key capitalization,
	if true, return string, if not, return a properly capitalized copy"
	
	"Optimization: if string is a know, properly capitalized header, use it as is"
	(CommonHeaders includes: string) 
		ifTrue: [ ^ string ].
	^ (ZnUtils isCapitalizedString: string)
		ifTrue: [ string ] 
		ifFalse: [ ZnUtils capitalizeString: string ] ! !

!ZnHeaders class methodsFor: 'instance creation' stamp: ''!
defaultRequestHeaders
	^ self new
		at: 'User-Agent' put: ZnConstants defaultUserAgent;
		at: 'Accept' put: '*/*';
		yourself! !

!ZnHeaders class methodsFor: 'instance creation' stamp: ''!
requestHeadersFor: url
	| headers |
	headers := self defaultRequestHeaders.
	headers request: url.
	^ headers! !

!ZnHeaders class methodsFor: 'class initialization' stamp: ''!
initialize
	CommonHeaders := (
		#(
			'Content-Length' 'Content-Type' 'Date' 'Server' 'Connection' 'User-Agent' 'Host'
			'Accept' 'Accept-Language' 'Accept-Encoding'
			'Referer' 'Dnt'
			'Cookie' 'Set-Cookie' 'Authorization' 'WWW-Authenticate' 'Proxy-Authorization'
			'Content-Encoding' 'Transfer-Encoding' 'Location'
			'If-Modified-Since' 'Content-Disposition' 
			'X-Zinc-Remote-Address' 'X-Forwarded-Server' 'X-Forwarded-For' 'X-Forwarded-Host' ) 
			collect: [ :each | ZnUtils capitalizeString: each ]) asSet! !

!ZnHeaders class methodsFor: 'instance creation' stamp: ''!
withAll: keyedCollection
	^ self new
		addAll: keyedCollection;
		yourself ! !

!ZnHeaders class methodsFor: 'instance creation' stamp: ''!
defaultResponseHeaders
	^ self new
		at: 'Server' put: ZnConstants defaultServerString;
		at: 'Date' put: ZnUtils httpDate;
		yourself! !

!ZnHeaders class methodsFor: 'instance creation' stamp: ''!
readFrom: stream
	^ self new
		readFrom: stream;
		yourself! !

!ZnHeadersTest methodsFor: 'testing' stamp: ''!
testReading
	| string headers |
	string := 'Content-Type: text/plain', String crlf, 'Content-Length: 128', String crlf.
	headers := ZnHeaders readFrom: string asByteArray readStream.
	self assert: (headers includesKey: 'Content-Type').
	self assert: (headers includesKey: 'Content-Length').
	self assert: (headers at: 'Content-Type') equals: 'text/plain'.
	self assert: (headers at: 'Content-Length') equals: '128'.! !

!ZnHeadersTest methodsFor: 'testing' stamp: ''!
testNormalization
	| headers |
	headers := ZnHeaders new.
	headers at: 'content-TYPE' put: 'text/plain'.
	self assert: (headers includesKey: 'content-type').
	self assert: (headers includesKey: 'content-TYPE').
	self assert: (headers at: 'Content-Type') equals: 'text/plain'.
	headers at: 'CONTENT-type' put: 'text/html'.
	self assert: (headers at: 'Content-Type') equals: 'text/html'.

	! !

!ZnHeadersTest methodsFor: 'testing' stamp: ''!
testReadingMultilineMultiValue
	| string headers |
	string := 'Content-Type: text/plain', String crlf, 
		'Long: foo', String crlf, 
		' bar', String crlf, 
		String tab, 'baz', String crlf, 
		'Content-Length: 128', String crlf,
		'Long: more', String crlf.
	headers := ZnHeaders readFrom: string asByteArray readStream.
	self assert: (headers at: #long) equals: #( 'foo bar	baz' 'more').! !

!ZnHeadersTest methodsFor: 'testing' stamp: ''!
testReadingMultilineNonBinary
	| string headers |
	string := 'Foo: 1', String crlf, 
		' 2', String crlf, 
		String tab, '3', String crlf, 
		'Bar: EOF', String crlf.
	headers := ZnHeaders readFrom: string readStream.
	self assert: (headers at: 'Foo') equals: '1 2', String tab, '3'.
	self assert: (headers at: 'Bar') equals: 'EOF'! !

!ZnHeadersTest methodsFor: 'testing' stamp: ''!
testReadingMultiline
	| string headers |
	string := 'Content-Type: text/plain', String crlf, 
		'Long: foo', String crlf, 
		' bar', String crlf, 
		String tab, 'baz', String crlf, 
		'Content-Length: 128', String crlf.
	headers := ZnHeaders readFrom: string asByteArray readStream.
	self assert: (headers includesKey: 'Content-Type').
	self assert: (headers includesKey: 'Content-Length').
	self assert: (headers at: 'Content-Type') equals: 'text/plain'.
	self assert: (headers at: 'Content-Length') equals: '128'.
	self assert: (headers includesKey: #Long).
	self assert: (headers at: #long) equals: 'foo bar	baz'.! !

!ZnHeadersTest methodsFor: 'testing' stamp: ''!
testMultiValuedStreaming
	| headers keysAndValues |
	headers := ZnHeaders new.
	headers at: 'Set-Cookie' put: 'foo=1'.
	headers at: 'Set-Cookie' add: 'bar=1'.
	keysAndValues := OrderedCollection streamContents: [ : stream |
		headers headersDo: [ :key :value |
			stream nextPut: key; nextPut: value ] ].
	self assert: keysAndValues equals: #('Set-Cookie' 'foo=1' 'Set-Cookie' 'bar=1') asOrderedCollection 
	
	! !

!ZnHeadersTest methodsFor: 'testing' stamp: ''!
testMergeValued
	| headers |
	headers := ZnHeaders new.
	headers at: 'Set-Cookie' put: 'foo=1'.
	headers at: 'Set-Cookie' put: 'bar=1' ifPresentMerge: [ :old :new | old, ';', new ].
	self assert: (headers at: 'Set-Cookie') equals: 'foo=1;bar=1'
	
	! !

!ZnHeadersTest methodsFor: 'testing' stamp: ''!
testMultiValued
	| headers |
	headers := ZnHeaders new.
	headers at: 'Set-Cookie' put: 'foo=1'.
	headers at: 'Set-Cookie' add: 'bar=1'.
	self assert: (headers at: 'Set-Cookie') equals: #('foo=1' 'bar=1')
	
	! !

!ZnHeadersTest methodsFor: 'testing' stamp: ''!
testWriting
	| headers string |
	headers := ZnHeaders new
		at: 'Content-Type' put: 'text/plain';
		at: 'Content-Length' put: '128';
		yourself.
	string := String streamContents: [ :stream | headers writeOn: stream ].
	self assert: (string includesSubstring: 'Content-Type: text/plain' , String crlf).
	self assert: (string includesSubstring: 'Content-Length: 128' , String crlf).
	self assert: (string occurrencesOf: Character cr) equals: 2.
	self assert: (string occurrencesOf: Character lf) equals: 2! !

!ZnHtmlOutputStream commentStamp: ''!
I am ZnHtmlOutputStream. I wrap another character write stream to offer a richer API for generating correct HTML markup.

See https://en.wikipedia.org/wiki/HTML

My streaming protocol contains the traditional write stream operations. These are raw and do not do any conversions/escaping.

My html protocols contains a rich API for generating correct HTML. 

String streamContents: [ :out | | html |
	html := ZnHtmlOutputStream on: out.
	html html5.
	html tag: #html do: [ 
		html tag: #body do: [
			html tag: #div class: #main do: [
				html tag: #p with: 'Hello World & Universe !!'.
				html tag: #hr.
				html 
					tag: #em 
					attributes: #(class big id 1 disable nil) 
					with: 'The END' ] ] ] ].
	
ZnHtmlOutputStream streamContents: [ :html |
	html page: 'Hello World' do: [ 
		html tag: #div class: #main do: [
			html tag: #p with: 'Hello World & Universe !!' ] ] ]

Part of Zinc HTTP Components.!
!ZnHtmlOutputStream methodsFor: 'private - html' stamp: ''!
openTag: tag attributes: attributes
	stream
		nextPut: $<;
		nextPutAll: tag.
	self renderAttributes: attributes.
	stream nextPut: $>! !

!ZnHtmlOutputStream methodsFor: 'private - html' stamp: ''!
renderAttributes: attributes
	attributes pairsDo: [ :name :value | 
		stream space; nextPutAll: name.
		value ifNotNil: [
			stream nextPutAll: '="'.
			self escapeAttributeValue: value asString.
			stream nextPut: $" ] ]! !

!ZnHtmlOutputStream methodsFor: 'private - html' stamp: ''!
closeTag: tag
	stream
		nextPut: $<;
		nextPut: $/;
		nextPutAll: tag;
		nextPut: $>! !

!ZnHtmlOutputStream methodsFor: 'html' stamp: ''!
escapeCharacter: char
	"Write char, escaping it as needed for regular text"

	char == $<
		ifTrue: [ stream nextPutAll: '&lt;' ]
		ifFalse: [ 
			char == $&
				ifTrue: [ stream nextPutAll: '&amp;' ]
				ifFalse: [ stream nextPut: char ] ]! !

!ZnHtmlOutputStream methodsFor: 'streaming' stamp: ''!
next: count putAll: collection startingAt: offset
	"Write count characters from collection starting at offset."
	
	stream 
		next: count 
		putAll: collection 
		startingAt: offset! !

!ZnHtmlOutputStream methodsFor: 'private - html' stamp: ''!
openTag: tag attribute: name value: value
	stream
		nextPut: $<;
		nextPutAll: tag;
		space; 
		nextPutAll: name.
	value ifNotNil: [
		stream nextPutAll: '="'.
		self escapeAttributeValue: value asString.
		stream nextPut: $" ].
	stream nextPut: $>! !

!ZnHtmlOutputStream methodsFor: 'html tags' stamp: ''!
tag: tag
	"Write a standalone, self closing HTML tag"
	
	"<tag/>"
	
	stream
		nextPut: $<;
		nextPutAll: tag;
		nextPut: $/;
		nextPut: $>! !

!ZnHtmlOutputStream methodsFor: 'html tags' stamp: ''!
tag: tag attributes: attributePairs with: string
	"Write an HTML tag with attributes, a collection of alternating keys and values, using the escaped string as content" 
	
	"<tag attr1=""value1"" ... attrN=""valueN"">string</tag>"

	self openTag: tag attributes: attributePairs.
	self escape: string.
	self closeTag: tag ! !

!ZnHtmlOutputStream methodsFor: 'streaming' stamp: ''!
nextPut: object
	^ stream nextPut: object! !

!ZnHtmlOutputStream methodsFor: 'html tags' stamp: ''!
tag: tag attributes: attributePairs do: block
	"Write an HTML tag with attributes, a collection of alternating keys and values, executing block to generate enclosed content" 
	
	"<tag attr1=""value1"" ... attrN=""valueN""> ... </tag>"

	self openTag: tag attributes: attributePairs.
	block value.
	self closeTag: tag! !

!ZnHtmlOutputStream methodsFor: 'initialize-release' stamp: ''!
close
	stream close! !

!ZnHtmlOutputStream methodsFor: 'html' stamp: ''!
escape: string
	"Write string, escaping characters as needed for regular text"
	
	string do: [ :each | self escapeCharacter: each ]! !

!ZnHtmlOutputStream methodsFor: 'streaming' stamp: ''!
flush
	stream flush! !

!ZnHtmlOutputStream methodsFor: 'streaming' stamp: ''!
next: count putAll: collection	
	self 
		next: count 
		putAll: collection 
		startingAt: 1! !

!ZnHtmlOutputStream methodsFor: 'html tags' stamp: ''!
tag: tag class: cssClass with: string
	"Write an HTML tag with class cssClass, using the escaped string as content" 
	
	"<tag class=""cssClass"">string</tag>"

	self openTag: tag attribute: #class value: cssClass.
	self escape: string.
	self closeTag: tag ! !

!ZnHtmlOutputStream methodsFor: 'html' stamp: ''!
page: title do: block
	"Write out a standard page using title, then execute block"
	
	"ZnHtmlOutputStream streamContents: [ :html | html page: 'Hello' do: [ html tag: #p with: 'World' ] ]"

	self html5; tag: #html do: [ 
		self
			tag: #head do: [ self tag: #title with: title ];
			tag: #body do: [ 
				self tag: #h1 with: title.
				block value ] ]! !

!ZnHtmlOutputStream methodsFor: 'html tags' stamp: ''!
tag: tag attributes: attributes
	"Write a standalone, self closing HTML tag with attributes, a collection of alternating keys and values"
	
	"<tag attr1=""value1"" ... attrN=""valueN""/>"

	stream
		nextPut: $<;
		nextPutAll: tag.
	self renderAttributes: attributes.
	stream
		nextPut: $/;
		nextPut: $>! !

!ZnHtmlOutputStream methodsFor: 'html' stamp: ''!
str: string
	"Write string, escaping characters as needed for regular text"

	self escape: string! !

!ZnHtmlOutputStream methodsFor: 'initialize-release' stamp: ''!
on: writeStream
	stream := writeStream! !

!ZnHtmlOutputStream methodsFor: 'private - html' stamp: ''!
openTag: tag
	stream
		nextPut: $<;
		nextPutAll: tag;
		nextPut: $>! !

!ZnHtmlOutputStream methodsFor: 'streaming' stamp: ''!
space
	self nextPut: Character space! !

!ZnHtmlOutputStream methodsFor: 'html tags' stamp: ''!
tag: tag do: block
	"Write an HTML tag, executing block to generate enclosed content" 
	
	"<tag>...</tag>"

	self openTag: tag.
	block value.
	self closeTag: tag! !

!ZnHtmlOutputStream methodsFor: 'html' stamp: ''!
html5
	"Write the standard HTML5 DOCTYPE tag"
	
	stream nextPutAll: '<!!DOCTYPE html>'! !

!ZnHtmlOutputStream methodsFor: 'html tags' stamp: ''!
tag: tag id: cssId do: block
	"Write an HTML tag with id cssId, executing block to generate enclosed content" 
	
	"<tag id=""cssId""> ... </tag>"

	self openTag: tag attribute: #id value: cssId.
	block value.
	self closeTag: tag! !

!ZnHtmlOutputStream methodsFor: 'html tags' stamp: ''!
tag: tag class: cssClass do: block
	"Write an HTML tag with class cssClass, executing block to generate enclosed content" 
	
	"<tag class=""cssClass""> ... </tag>"

	self openTag: tag attribute: #class value: cssClass.
	block value.
	self closeTag: tag! !

!ZnHtmlOutputStream methodsFor: 'streaming' stamp: ''!
<< anObject
	"Write anObject to the receiver, dispatching using #putOn:
	This is a shortcut for both nextPut: and nextPutAll: since anObject can be both
	the element type of the receiver as well as a collection of those elements.
	No further conversions of anObject are applied.
	Return self to accomodate chaining."

 	anObject putOn: self! !

!ZnHtmlOutputStream methodsFor: 'html' stamp: ''!
escapeAttributeValue: string
	"Write string, escaping characters as needed for the value of an attribute"

	string do: [ :each |
		each == $"
			ifTrue: [ stream nextPutAll: '&quot;' ]
			ifFalse: [ stream nextPut: each ] ] ! !

!ZnHtmlOutputStream methodsFor: 'html' stamp: ''!
format: string with: args
	"Like String>>#format: format the string template using the args given, esacaping characters when needed for regular text"

	| input currentChar |
	input := string readStream.
	[ input atEnd ] whileFalse: [
		(currentChar := input next) == ${
			ifTrue: [ | expression index | 
				expression := input upTo: $}.
				index := Integer readFrom: expression ifFail: [ expression ].
				self escape: (args at: index) asString ]
			ifFalse: [
				currentChar == $\
					ifTrue: [ input atEnd ifFalse: [ self escapeCharacter: stream next ] ]
					ifFalse: [ self escapeCharacter: currentChar ] ] ]! !

!ZnHtmlOutputStream methodsFor: 'html' stamp: ''!
comment: string
	"Write an HTML/XML comment consisting of string, as in <!!-- string -->"
	
	stream
		nextPutAll: '<!!-- ';
		nextPutAll: string;
		nextPutAll: ' -->'! !

!ZnHtmlOutputStream methodsFor: 'html tags' stamp: ''!
tag: tag with: string
	"Write an HTML tag using the escaped string as content" 
	
	"<tag>string</tag>"

	self openTag: tag.
	self escape: string.
	self closeTag: tag ! !

!ZnHtmlOutputStream methodsFor: 'html tags' stamp: ''!
tag: tag id: cssId with: string
	"Write an HTML tag with id cssId, using the escaped string as content" 
	
	"<tag id=""cssId"">string</tag>"

	self openTag: tag attribute: #id value: cssId.
	self escape: string.
	self closeTag: tag ! !

!ZnHtmlOutputStream methodsFor: 'accessing' stamp: ''!
wrappedStream
	^ stream! !

!ZnHtmlOutputStream methodsFor: 'streaming' stamp: ''!
nextPutAll: collection
	self 
		next: collection size 
		putAll: collection 
		startingAt: 1! !

!ZnHtmlOutputStream methodsFor: 'streaming' stamp: ''!
print: object
	object printOn: self! !

!ZnHtmlOutputStream class methodsFor: 'instance creation' stamp: ''!
on: writeStream
	^ self new
		on: writeStream;
		yourself! !

!ZnHtmlOutputStream class methodsFor: 'convenience' stamp: ''!
streamContents: block
	"Execute block with a ZnHtmlOutputStream as argument to generate HTML, returning the resulting string"
	
	"ZnHtmlOutputStream streamContents: [ :html |
		html page: 'Hello World' do: [ 
			html tag: #p with: 'Hello World & Universe !!' ] ]"
	
	^ String streamContents: [ :out |
			block value: (self on: out) ]! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testNesting
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html tag: #ol do: [ 
			#(one two three) do: [ :each | html tag: #li with: each ] ] ].
	self assert: result equals: '<ol><li>one</li><li>two</li><li>three</li></ol>'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testSmall
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html 
			tag: #h1 with: #Small;
			tag: #p with: 'This is a small HTML document' ].
	self assert: result equals: '<h1>Small</h1><p>This is a small HTML document</p>'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testTagWithMultipleAttributes
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html tag: #div attributes: #(class menu id one) with: 'Foo' ].
	self assert: result equals: '<div class="menu" id="one">Foo</div>'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testEncoding
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html tag: #div with: 'élève en Français' ].
	self assert: result equals: '<div>élève en Français</div>'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testSmallPage
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html page: 'Small' do: [ 
			html tag: #p with: 'This is a small HTML document' ] ].
	self assert: result equals: '<!!DOCTYPE html><html><head><title>Small</title></head><body><h1>Small</h1><p>This is a small HTML document</p></body></html>'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testTagWithEmptyAttributes
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html tag: #div attributes: #(class menu id one readonly nil) with: 'Foo' ].
	self assert: result equals: '<div class="menu" id="one" readonly>Foo</div>'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testFormat
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html format: '{1} & {2}' with: { '<'. '>' } ].
	self assert: result equals: '&lt; &amp; >'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testEscaping
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html tag: #div with: 'Foo & Bar < 100' ].
	self assert: result equals: '<div>Foo &amp; Bar &lt; 100</div>'.
	result := ZnHtmlOutputStream streamContents: [ :html |
		html << 'Foo & Bar < 100' ].
	self assert: result equals: 'Foo & Bar < 100'.
	result := ZnHtmlOutputStream streamContents: [ :html |
		html str: 'Foo & Bar < 100' ].
	self assert: result equals: 'Foo &amp; Bar &lt; 100'.! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testTagWithClass
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html tag: #div class: #menu with: 'Foo' ].
	self assert: result equals: '<div class="menu">Foo</div>'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testHtml5Tag
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html html5 ].
	self assert: result equals: '<!!DOCTYPE html>'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testTagWithId
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html tag: #div id: #menu with: 'Foo' ].
	self assert: result equals: '<div id="menu">Foo</div>'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testComment
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html comment: 'a comment' ].
	self assert: result equals: '<!!-- a comment -->'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testSelfClosingTag
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html tag: #br ].
	self assert: result equals: '<br/>'! !

!ZnHtmlOutputStreamTest methodsFor: 'tests' stamp: ''!
testAttributeEscaping
	| result |
	result := ZnHtmlOutputStream streamContents: [ :html |
		html tag: #div attributes: #(query '"literal"') with: 'Foo' ].
	self assert: result equals: '<div query="&quot;literal&quot;">Foo</div>'! !

!ZnHttpRetrieveContents commentStamp: ''!
I am ZnHttpRetrieveContents.
I am a ZnUrlOperation.

I implement the #retrieveContents URL operation for HTTP(S) urls.

  'http://zn.stfx.eu/zn/numbers.txt' asZnUrl retrieveContents.

Part of Zinc HTTP Components.
!
!ZnHttpRetrieveContents methodsFor: 'operations' stamp: ''!
performOperation
	"Download and return the HTTP(S) resource that url refers to.
	This will typically return a String or a ByteArray (see ZnClient>>#get:).
	If something goes wrong, an exception will be signalled."

	^ ZnClient new
		beOneShot;
		enforceHttpSuccess: true;
		get: self url! !

!ZnHttpRetrieveContents class methodsFor: 'accessing' stamp: ''!
operation
	^ #retrieveContents! !

!ZnHttpRetrieveContents class methodsFor: 'accessing' stamp: ''!
schemes
	^ #( #http #https )! !

!ZnHttpSaveContentsToFile commentStamp: ''!
I am ZnHttpSaveContentsToFile.
I am a ZnUrlOperation.

I implement the #saveContentsToFile: URL operation for HTTP(S) urls, which downloads the url resource to a file.

  'http://zn.stfx.eu/zn/numbers.txt' asZnUrl saveContentsToFile: Path * 'numbers.txt'.

Part of Zinc HTTP Components.!
!ZnHttpSaveContentsToFile methodsFor: 'operations' stamp: ''!
performOperation
	"Download the HTTP(S) resource specified by url to the file in argument.
	Return a file reference on the file that's just been downloaded.
	If something goes wrong, an exception will be signalled."

	ZnClient new
		enforceHttpSuccess: true;
		url: self url;
		downloadTo: argument.
	^ argument asFileReference! !

!ZnHttpSaveContentsToFile class methodsFor: 'accessing' stamp: ''!
operation
	^ #saveContentsToFile:! !

!ZnHttpSaveContentsToFile class methodsFor: 'accessing' stamp: ''!
schemes
	^ #( #http #https )! !

!ZnHttpUnsuccessful commentStamp: ''!
ZnHttpUnsuccessful is signalled when an HTTP client receives a non success response.

See ZnResponse>>#isSuccess

I hold the response that was unsuccessful.

Part of Zinc HTTP Components. !
!ZnHttpUnsuccessful methodsFor: 'accessing' stamp: ''!
response: anObject
	response := anObject! !

!ZnHttpUnsuccessful methodsFor: 'accessing' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		response ifNotNil: [
			response statusLine printCodeAndReasonOn: stream ] ]! !

!ZnHttpUnsuccessful methodsFor: 'accessing' stamp: ''!
response
	^ response! !

!ZnHttpUnsuccessful methodsFor: 'accessing' stamp: ''!
messageText
	"Overwritten to initialiaze the message text to a standard text if it has not yet been set"
	
	^ messageText ifNil: [ messageText := self standardMessageText ]! !

!ZnHttpUnsuccessful class methodsFor: 'instance creation' stamp: ''!
response: response
	^ self new
		response: response;
		yourself! !

!ZnImageExampleDelegate commentStamp: ''!
I am ZnImageExampleDelegate.
I am a implementation of the web app in 'Building and deploying your first web app in Pharo'.

I serve an image that web clients can change by uploading a new one.

  ZnServer startDefaultOn: 1701.
  ZnImageExampleDelegate installInDefaultServer.
  ZnServer stopDefault.

I implement the following API or resources

	GET /image - returns an HTML page showing our image and a form to upload a new image
	GET /image?raw=true - directly serves the last uploaded image
	POST /image - handler accepting a multipart form data entity with a file part containing GIF, JPEG or PNG bytes
	
Part of Zinc HTTP Components.!
!ZnImageExampleDelegate methodsFor: 'public' stamp: ''!
value: request
	"I implement the generic #value: message as equivalent to #handleRequest:"
	
	^ self handleRequest: request! !

!ZnImageExampleDelegate methodsFor: 'request handling' stamp: ''!
handleGetRequest: request
	"GET /image - Serve an HTML page showing our image and a form to upload a new one.
	GET /image?raw=true - Serve the last image directly"
	
	^ (request uri queryAt: #raw ifAbsent: [ nil ])
		ifNil: [ 
			ZnResponse ok: (ZnEntity html: self html) ]
		ifNotNil: [ 
			ZnResponse ok: self image ]! !

!ZnImageExampleDelegate methodsFor: 'accessing' stamp: ''!
formForImageEntity: imageEntity
	"Parse the actual bytes of imageEntity and return a Form."
	
	| imageType parserClassName parserClass parser |
	imageType := imageEntity contentType sub.
	parserClassName := imageType asUppercase, #ReadWriter.
	parserClass := Smalltalk globals at: parserClassName asSymbol.
	parser := parserClass on: imageEntity readStream.
	^ parser nextImage
	! !

!ZnImageExampleDelegate methodsFor: 'accessing' stamp: ''!
html
	^ ZnHtmlOutputStream streamContents: [ :html |
		 html page: 'Image' do: [
			html 
				tag: #src attributes: #(src 'image?raw=true');
				tag: #br;
				tag: #form attributes: #(enctype 'multipart/form-data' action image method POST) do: [
					html
						tag: #h3 with: 'Change the image:';
						tag: #input attributes: #(type file name file);
						tag: #input attributes: #(type submit value Upload) ] ] ]! !

!ZnImageExampleDelegate methodsFor: 'accessing' stamp: ''!
image
	"Return the current image entity.
	Use a default when not yet set."
	
	^ image ifNil: [ image := self downloadPharoLogo ]! !

!ZnImageExampleDelegate methodsFor: 'accessing' stamp: ''!
form
	^ self formForImageEntity: self image
	! !

!ZnImageExampleDelegate methodsFor: 'accessing' stamp: ''!
downloadPharoLogo
	^ ZnClient new beOneShot
		get: 'http://pharo.org/files/pharo.png';
		entity! !

!ZnImageExampleDelegate methodsFor: 'request handling' stamp: ''!
handlePostRequest: request
	"POST /image <multipart form data with file part> - change the image and show the result.
	Do full error checking before accepting the newly uploaded image"
	
	| part newImage badRequest |
	badRequest := [ ^ ZnResponse badRequest: request ].
	(request hasEntity and: [ request contentType matches: ZnMimeType multiPartFormData ])
		ifFalse: badRequest.
	part := request entity 
		partNamed: #file 
		ifNone: badRequest.
	newImage := part entity.
	(newImage notNil and: [ newImage contentType matches: 'image/*' asZnMimeType ])
		ifFalse: badRequest.
	[ self formForImageEntity: newImage ] on: Error do: badRequest.
	image := newImage.
	^ ZnResponse redirect: #image
	! !

!ZnImageExampleDelegate methodsFor: 'public' stamp: ''!
handleRequest: request
	"Dispatch between GET and POST on /image"
	
	request uri path = #image
		ifTrue: [ 
			request method = #GET
				ifTrue: [ 
					^ self handleGetRequest: request ].
			request method = #POST
				ifTrue: [ 
					^ self handlePostRequest: request ] ].
	^ ZnResponse notFound: request uri! !

!ZnImageExampleDelegate class methodsFor: 'public' stamp: ''!
installInDefaultServer
	"Assuming the default server has the default delegate, 
	install ourself under /image"
	
	ZnServer default delegate 
		map: 'image' to: self new! !

!ZnImageExampleDelegateTest methodsFor: 'testing' stamp: ''!
testDefaultImage
	self flag: #flakyTest.
	self skip.
	
	self withServerDo: [ :server |
		| client |
		client := ZnClient new.
		client url: server localUrl; addPath: #image; queryAt: #raw put: #true.
		client get.
		self assert: client isSuccess.
		self assert: (client entity contentType matches: 'image/*' asZnMimeType).
		self assert: client entity equals: server delegate image.
		client close ]! !

!ZnImageExampleDelegateTest methodsFor: 'private' stamp: ''!
image
	^ ZnClient new
		beOneShot;
		get: 'http://zn.stfx.eu/zn/Hot-Air-Balloon.gif';
		entity! !

!ZnImageExampleDelegateTest methodsFor: 'private' stamp: ''!
withServerDo: block
	| server |
	server := ZnServer on: 1700 + 32 atRandom.
	[ 
		server start.
		self 
			assert: server isRunning & server isListening
			description: ('Failed to start server on port {1}. Is there one already?' format: { server port }).
		server delegate: ZnImageExampleDelegate new.
		block cull: server
	] 
		ensure: [ server stop ]! !

!ZnImageExampleDelegateTest methodsFor: 'testing' stamp: ''!
testUpload
	self withServerDo: [ :server |
		| image client |
		image := self image.
		client := ZnClient new.
		client url: server localUrl; addPath: #image.
		client addPart: (ZnMimePart fieldName: #file entity: image).
		client post.
		self assert: client isSuccess.
		client resetEntity; queryAt: #raw put: #true.
		client get.
		self assert: client isSuccess.
		self assert: client entity equals: image.
		client close ]! !

!ZnImageExampleDelegateTest methodsFor: 'testing' stamp: ''!
testMainPage
	self withServerDo: [ :server |
		| client |
		client := ZnClient new.
		client url: server localUrl; addPath: #image.
		client get.
		self assert: client isSuccess.
		self assert: (client entity contentType matches: ZnMimeType textHtml).
		self assert: (client contents includesSubstring: 'Image').
		client close ]! !

!ZnIncomplete commentStamp: ''!
I am ZnIncomplete.
I am a ZnCharacterEncodingError.
I am an Error.

I signal when the binary stream from which a character is read does not contain enough data to form a full character. This typically occurs when the stream is #atEnd, a file is EOF or a network connection is closed - when the end of a stream is reached when more data is expected/needed.

I can be used to ignore wrongly encoded input by resuming me. By default a question mark will be inserted for each problem and decoding will continue. This is not recommended, as faulty input should not be accepted.

Part of Zinc HTTP Components!
!ZnIncomplete methodsFor: 'private' stamp: ''!
defaultResumeValue
	"$? codePoint"
	
	^ 63! !

!ZnIncomplete methodsFor: 'testing' stamp: ''!
isResumable
	^ true! !

!ZnInvalidUTF8 commentStamp: ''!
I am ZnInvalidUTF8.
I am a ZnCharacterEncodingError.
I am an Error.

I signal when something goes wrong while encoding or decoding UTF8.

I can be used to ignore wrongly encoded input by resuming me. By default a question mark will be inserted for each problem and decoding will continue. This is not recommended, as faulty input should not be accepted.

Part of Zinc HTTP Components!
!ZnInvalidUTF8 methodsFor: 'private' stamp: ''!
defaultResumeValue
	"$? codePoint"
	
	^ 63! !

!ZnInvalidUTF8 methodsFor: 'testing' stamp: ''!
isResumable
	^ true! !

!ZnLimitedReadStream commentStamp: ''!
I am ZnLimitedReadStream, wrapping another read stream delegating to it 
but limiting reading to a fixed number of elements.

I can be atEnd while my wrapped stream is not.

My contentSpecies can be forced to be ByteArray (binary) or ByteString (ascii).

I do byte/char conversions on the fly (support bivalent access).

This implementation is really a kludge.

Part of Zinc HTTP Components.!
!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
contentsOfEntireFile
	^ self upToEnd! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
position
	^ position! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
nextInto: collection
	"Read the next elements of the receiver into collection,
	returning a copy if less elements are available"
	
	^ self
		next: collection size
		into: collection! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
binary
	binary := true! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
next
	"We do byte/char conversions on the fly."
	
	^ self atEnd 
		ifTrue: [ nil ] 
		ifFalse: [ 
			position := position + 1. 
			binary isNil
				ifTrue: [ stream next ] 
				ifFalse: [ 
					binary
					 	ifTrue: [ stream next asInteger ]
						ifFalse: [ stream next asCharacter ] ] ]! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount 
	"Read requestedCount elements into new collection and return it,
	 it could be that less elements were available"

	^ self 
		next: requestedCount 
		into: (self collectionSpecies new: requestedCount)! !

!ZnLimitedReadStream methodsFor: 'initialize-release' stamp: ''!
on: readStream limit: integer
	stream := readStream.
	limit := integer.
	position := 0! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
peek
	"We do byte/char conversions on the fly."
	
	^ self atEnd 
		ifTrue: [ nil ] 
		ifFalse: [ 
			binary isNil
				ifTrue: [ stream peek ] 
				ifFalse: [ 
					binary
					 	ifTrue: [ stream peek asInteger ]
						ifFalse: [ stream peek asCharacter ] ] ]! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
upToEnd
	^ ZnUtils readUpToEnd: self limit: nil! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
collectionSpecies
	"I can be set to binary or ascii explicitly.
	If not set, delegate to our wrapped stream."
	
	^ binary notNil
		ifTrue: [ 
			binary ifTrue: [ ByteArray ] ifFalse: [ ByteString ] ]
		ifFalse: [
			(stream respondsTo: #collectionSpecies)
				ifTrue: [ stream collectionSpecies ]  
				ifFalse: [ stream isBinary ifTrue: [ ByteArray ] ifFalse: [ ByteString ] ] ]! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection startingAt: offset
	"Read requestedCount elements into collection starting at offset,
	returning a copy if less elements are available"
	
	| readCount |
	readCount := self 
		readInto: collection 
		startingAt: offset 
		count: requestedCount.
	^ requestedCount = readCount
		ifTrue: [ collection ]
		ifFalse: [ collection copyFrom: 1 to: offset + readCount - 1 ]! !

!ZnLimitedReadStream methodsFor: 'testing' stamp: ''!
isBinary
	^ binary isNil
		ifTrue: [ stream isBinary ]
		ifFalse: [ binary ]! !

!ZnLimitedReadStream methodsFor: 'printing' stamp: ''!
printOn: aStream
	aStream 
		nextPutAll: 'a '; 
		nextPutAll: self class name! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
skip: count
	count timesRepeat: [ self next ]! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
peekFor: anElement
	^ self peek = anElement and: [ self next. true ]! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
upTo: anObject 
	"We use our own collectionSpecies."
	
	^ self collectionSpecies streamContents: [ :out | | element |
		[ self atEnd or: [ (element := self next) = anObject ] ] whileFalse: [ 
			out nextPut: element ] ]! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
readInto: collection startingAt: offset count: count 
	"Read count elements and place them in collection starting at offset.
	Return the number of elements actually read."
	
	| target actual |
	target := count min: (limit - position).
	actual := stream 
		readInto: collection 
		startingAt: offset 
		count: target.
	position := position + actual.
	^ actual! !

!ZnLimitedReadStream methodsFor: 'initialize-release' stamp: ''!
close
	stream ifNotNil: [ stream close. stream := nil ]! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
contents
	"This is technically not correct, but it is better than nothing"
	
	^ self upToEnd! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
ascii
	binary := false! !

!ZnLimitedReadStream methodsFor: 'testing' stamp: ''!
atEnd
	^ position >= limit or: [ stream atEnd ]! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
match: subCollection
	"Try to read and match the elements of subCollection. 
	If successful return true and leave the me positioned after the match.
	If unsuccesful return false and leave me at end."
	
	| buffer pattern bufferPosition bufferLimit |
	pattern := subCollection readStream.
	"we have to use an internal buffer because we are not positionable"
	buffer := subCollection species new: subCollection size.
	bufferPosition := bufferLimit := 0.
	[ pattern atEnd ] whileFalse: [ | nextElement |
		self atEnd ifTrue: [ ^ false ].
		"get the next char to match either from the buffer or from the stream while buffering it"
		(bufferPosition < bufferLimit) 
			ifTrue: [ 
				nextElement := buffer at: bufferPosition + 1 ]
			ifFalse: [
				nextElement := buffer at: bufferPosition + 1 put: self next.
				bufferLimit := bufferLimit + 1 ].
		bufferPosition := bufferPosition + 1.
		pattern next = nextElement
			ifFalse: [
				"shift the buffer down one element and restart"
				2 to: bufferLimit do: [ :each |
					buffer at: each - 1 put: (buffer at: each) ].
				bufferLimit := bufferLimit - 1.
				bufferPosition := 0.
				pattern position: 0 ] ].
	^ true! !

!ZnLimitedReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection
	"Read requestedCount elements into collection,
	returning a copy if less elements are available"
	
	^ self
		next: requestedCount
		into: collection
		startingAt: 1! !

!ZnLimitedReadStream methodsFor: 'initialization' stamp: ''!
reset
	"We don't allow it"! !

!ZnLimitedReadStream class methodsFor: 'instance creation' stamp: ''!
on: stream limit: limit
	^ self basicNew
		on: stream limit: limit;
		yourself! !

!ZnLimitedReadStreamTest methodsFor: 'testing' stamp: ''!
testNext
	| limitedReadStream |
	limitedReadStream := ZnLimitedReadStream on: String new readStream limit: 10.
	self assert: limitedReadStream atEnd.
	self assert: limitedReadStream next isNil.
	limitedReadStream := ZnLimitedReadStream on: 'ABC' readStream limit: 10.
	self assert: limitedReadStream atEnd not.
	self assert: limitedReadStream next equals: $A.
	self assert: limitedReadStream peek equals: $B.
	limitedReadStream next.
	self assert: limitedReadStream next equals: $C.
	self assert: limitedReadStream next isNil.
	self assert: limitedReadStream atEnd! !

!ZnLimitedReadStreamTest methodsFor: 'testing' stamp: ''!
testNextCountShort
	| data stream |
	data := '0123456789'.
	stream := ZnLimitedReadStream on: data readStream limit: 5.
	self assert: (stream next: 6) equals: '01234'! !

!ZnLimitedReadStreamTest methodsFor: 'testing' stamp: ''!
testNextCount
	| data stream |
	data := '0123456789'.
	stream := ZnLimitedReadStream on: data readStream limit: 8.
	self assert: (stream next: 4) equals: '0123'! !

!ZnLimitedReadStreamTest methodsFor: 'testing' stamp: ''!
testSimpleEof
	| data limitedReadStream |
	data := '0123456789'.
	limitedReadStream := ZnLimitedReadStream on: data readStream limit: 15.
	self assert: limitedReadStream upToEnd equals: '0123456789'.
	self assert: limitedReadStream atEnd.
	self assert: limitedReadStream next isNil! !

!ZnLimitedReadStreamTest methodsFor: 'testing' stamp: ''!
testNextCountIntoShort
	| data stream buffer |
	data := '0123456789'.
	stream := ZnLimitedReadStream on: data readStream limit: 5.
	buffer := String new: 6.
	self assert: (stream next: 6 into: buffer) equals: '01234'! !

!ZnLimitedReadStreamTest methodsFor: 'testing' stamp: ''!
testNextCountInto
	| data stream buffer |
	data := '0123456789'.
	stream := ZnLimitedReadStream on: data readStream limit: 8.
	buffer := String new: 4.
	self assert: (stream next: 4 into: buffer) equals: '0123'.
	self assert: buffer equals: '0123'! !

!ZnLimitedReadStreamTest methodsFor: 'testing' stamp: ''!
testBinary
	| data limitedReadStream |
	data := #(0 1 2 3 4 5 6 7 8 9) asByteArray.
	limitedReadStream := ZnLimitedReadStream on: data readStream limit: 5.
	self assert: limitedReadStream upToEnd equals: #(0 1 2 3 4) asByteArray! !

!ZnLimitedReadStreamTest methodsFor: 'testing' stamp: ''!
testMatch
	| stream |
	stream := ZnLimitedReadStream on: 'ababcabc' readStream limit: 8.
	self assert: (stream match: 'ab').
	self deny: stream atEnd.
	stream := ZnLimitedReadStream on: 'ababcabc' readStream limit: 8.
	self assert: (stream match: 'abc').
	self deny: stream atEnd.
	self assert: (stream match: 'abc').
	self assert: stream atEnd.
	stream := ZnLimitedReadStream on: 'ababcabc' readStream limit: 8.
	self deny: (stream match: 'xx').
	self assert: stream atEnd.
! !

!ZnLimitedReadStreamTest methodsFor: 'testing' stamp: ''!
testSimple
	| data limitedReadStream |
	data := '0123456789'.
	limitedReadStream := ZnLimitedReadStream on: data readStream limit: 5.
	self assert: limitedReadStream upToEnd equals: '01234'! !

!ZnLimitedReadStreamTest methodsFor: 'testing' stamp: ''!
testBinaryAll
	| data limitedReadStream |
	data := #(0 1 2 3 4 5 6 7 8 9) asByteArray.
	limitedReadStream := ZnLimitedReadStream on: data readStream limit: data size.
	self assert: limitedReadStream upToEnd equals: data! !

!ZnLineReader commentStamp: ''!
I am ZnLineReader and I help reading CRLF terminated lines from a stream.
I can work on ascii and binary streams doing conversions as necessary.
I limit lines to a maximum length.
I work with a reusable buffer.

Part of Zinc HTTP Components.!
!ZnLineReader methodsFor: 'private' stamp: ''!
processNext
	| item |
	stream atEnd ifTrue: [ ^ nil ].
	(item := stream next) ifNil: [ ^ nil ].
	stream isBinary ifTrue: [ item := item asCharacter ].
	item == Character lf
		ifTrue: [
			(position > 0 and: [ (buffer at: position) == Character cr ])
				ifTrue: [
					position := position - 1.
					^ nil ] ].
	self store: item.
	^ item
			
	! !

!ZnLineReader methodsFor: 'private' stamp: ''!
store: item
	position >= buffer size ifTrue: [ self growBuffer ].
	position := position + 1.
	buffer at: position put: item		
	! !

!ZnLineReader methodsFor: 'initialize-release' stamp: ''!
on: readStream
	stream := readStream.
	buffer := String new: 64.
	self 
		limit: ZnConstants maximumLineLength; 
		reset! !

!ZnLineReader methodsFor: 'accessing' stamp: ''!
nextLine
	self reset.
	[ self processNext isNil ] whileFalse.
	^ buffer copyFrom: 1 to: position ! !

!ZnLineReader methodsFor: 'accessing' stamp: ''!
limit: size
	limit := size! !

!ZnLineReader methodsFor: 'private' stamp: ''!
growBuffer
	| newBuffer |
	buffer size >= limit 
		ifTrue: [
			(ZnLineTooLong limit: limit) signal ].
	newBuffer := String new: buffer size * 2.
	newBuffer replaceFrom: 1 to: buffer size with: buffer.
	buffer := newBuffer ! !

!ZnLineReader methodsFor: 'initialization' stamp: ''!
reset
	position := 0! !

!ZnLineReader class methodsFor: 'instance creation' stamp: ''!
on: stream
	^ self new
		on: stream;
		yourself! !

!ZnLineReaderTest methodsFor: 'testing' stamp: ''!
testLineTooLongDefault
	| input reader |
	input := (String new: ZnConstants maximumLineLength + 1) atAllPut: $X.
	reader := ZnLineReader on: input readStream.
	self should: [ reader nextLine ] raise: ZnLineTooLong  ! !

!ZnLineReaderTest methodsFor: 'testing' stamp: ''!
testBinary
	| input reader |
	input := ('Foo' , String crlf , 'Bar' , String crlf) asByteArray.
	reader := ZnLineReader on: input readStream.
	self assert: reader nextLine equals: 'Foo'.
	self assert: reader nextLine equals: 'Bar'.
	self assert: reader nextLine isEmpty! !

!ZnLineReaderTest methodsFor: 'testing' stamp: ''!
testSimple
	| input reader |
	input := 'Foo' , String crlf , 'Bar' , String crlf.
	reader := ZnLineReader on: input readStream.
	self assert: reader nextLine equals: 'Foo'.
	self assert: reader nextLine equals: 'Bar'.
	self assert: reader nextLine isEmpty! !

!ZnLineReaderTest methodsFor: 'testing' stamp: ''!
testLineTooLong
	| input reader |
	input := (String new: 128) atAllPut: $X.
	reader := (ZnLineReader on: input readStream) limit: 64.
	self should: [ reader nextLine ] raise: ZnLineTooLong  ! !

!ZnLineTooLong commentStamp: ''!
ZnLineTooLong is signalled when an HTTP CRLF terminated input line exceeds a predefined limit.

Part of Zinc HTTP Components. !
!ZnLineTooLong methodsFor: 'accessing' stamp: ''!
limit
	^ limit! !

!ZnLineTooLong methodsFor: 'accessing' stamp: ''!
limit: anObject
	limit := anObject! !

!ZnLineTooLong class methodsFor: 'instance creation' stamp: ''!
limit: limit
	^ self new 
		limit: limit; 
		yourself! !

!ZnLogEvent commentStamp: ''!
I am ZnLogEvent, the base class of a log events emitted by elements of the Zinc HTTP Components framework.

I add a timestamp and a simple id attribute. The id can wrap around and should only be used to distinguish between events that have the same timestamp.

ZnLogEvents are distributed as Announcement through a singleton Announcer that I maintain.

I have a small convenience API to log to the Transcript or open a simple GUI on the emitted log events.!
!ZnLogEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	"Subclasses should implement this to add output"! !

!ZnLogEvent methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	timestamp := DateAndTime now.
	id := self nextId! !

!ZnLogEvent methodsFor: 'accessing' stamp: ''!
nextId
	^ self class nextId! !

!ZnLogEvent methodsFor: 'printing' stamp: ''!
printOn: stream
	timestamp printYMDOn: stream.
	stream space.
	timestamp printHMSOn: stream. 
	stream space.
	id \\ 1000 printOn: stream base: 10 length: 3 padded: true.
	self printContentsOn: stream! !

!ZnLogEvent methodsFor: 'actions' stamp: ''!
emit
	self announcer announce: self! !

!ZnLogEvent methodsFor: 'accessing' stamp: ''!
timestamp
	^ timestamp! !

!ZnLogEvent methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!ZnLogEvent methodsFor: 'accessing' stamp: ''!
announcer
	^ self class announcer! !

!ZnLogEvent class methodsFor: 'system startup' stamp: ''!
startUp
	"Reset the id counter"
	
	IdCounter := 0! !

!ZnLogEvent class methodsFor: 'class initialization' stamp: ''!
initialize
	IdCounter := 0.
	self environment 
		at: #SessionManager 
		ifPresent: [ :manager | manager default registerNetworkClassNamed: self name ]
		ifAbsent: [ Smalltalk addToStartUpList: self ]! !

!ZnLogEvent class methodsFor: 'convenience' stamp: ''!
logToTranscript
	self stopLoggingToTranscript.
	^ self announcer when: ZnLogEvent do: [ :event | self crTrace: event ].! !

!ZnLogEvent class methodsFor: 'convenience' stamp: ''!
open
	^ self announcer inspect! !

!ZnLogEvent class methodsFor: 'accessing' stamp: ''!
nextId
	"This should be thread safe because SmallInteger 
	arithmetic primitives cannot be interrupted"
	
	^ IdCounter := IdCounter + 1! !

!ZnLogEvent class methodsFor: 'convenience' stamp: ''!
stopLoggingToTranscript
	self announcer unsubscribe: self! !

!ZnLogEvent class methodsFor: 'accessing' stamp: ''!
announcer
	^ LogEventAnnouncer ifNil: [ LogEventAnnouncer := Announcer new ]! !

!ZnMagicCookieJarTest methodsFor: 'accessing' stamp: ''!
cookieString
	^ 'PREF=ID=18ae67ce302b6317:TM=1285696140:LM=1285696140:S=hqroFGlRQR1j4Yhy; expires={1}; path=/; domain=.google.com' format: { ZnUtils httpDate: DateAndTime now + 60 days }! !

!ZnMagicCookieJarTest methodsFor: 'testing' stamp: ''!
testAdd
	| jar count |
	jar := ZnCookieJar new.
	count := jar cookies size.
	jar add: (ZnCookie fromString: self cookieString for: 'www.google.com' asZnUrl).
	self assert: jar cookies size equals: count + 1! !

!ZnMagicCookieJarTest methodsFor: 'testing' stamp: ''!
testCookieAtForUrl
	| jar c1 c2 |
	jar := ZnCookieJar new.
	c1 := ZnCookie fromString: self cookieString for: 'http://www.google.com' asZnUrl.
	c2 := ZnCookie fromString: self cookieStringAlt for: 'http://www.pharo-project.org' asZnUrl.
	jar add: c1; add: c2.
	self assert: ((jar cookieAt: 'PREF' forUrl: 'http://www.google.com' asZnUrl) notNil).
	self assert: ((jar cookieAt: 'foobar' forUrl: 'http://www.google.com' asZnUrl) isNil)! !

!ZnMagicCookieJarTest methodsFor: 'testing' stamp: ''!
testCookiesForUrl
	| jar c1 c2 |
	jar := ZnCookieJar new.
	c1 := ZnCookie fromString: self cookieString for: 'http://www.google.com' asZnUrl.
	c2 := ZnCookie fromString: self cookieStringAlt for: 'http://www.pharo-project.org' asZnUrl.
	jar
		add: c1;
		add: c2.
	self assert: (jar cookiesForUrl: 'http://www.google.com' asZnUrl) size equals: 1! !

!ZnMagicCookieJarTest methodsFor: 'accessing' stamp: ''!
cookieStringAlt
	^'PREFS=ID=18ae67ce302b6317:TM=1285696140:LM=1285696140:S=hqroFGlRQR1j4Yhy; expires={1}; path=/; domain=.pharo-project.org' format: { ZnUtils httpDate: DateAndTime now + 60 days }! !

!ZnMagicCookieTest methodsFor: 'testing' stamp: ''!
testInPath
	| cookie |
	cookie := ZnCookie fromString: self cookieStringSubpath for: 'www.google.com' asZnUrl.
	self assert: (cookie isInPath: 'www.google.com/test/' asZnUrl).
	self assert: ((cookie isInPath: 'www.google.com' asZnUrl) not)
	! !

!ZnMagicCookieTest methodsFor: 'testing' stamp: ''!
cookieString
	^ 'PREF=ID=18ae67ce302b6317:TM=1285696140:LM=1285696140:S=hqroFGlRQR1j4Yhy; expires={1}; path=/; domain=.google.com' format: { ZnUtils httpDate: DateAndTime now + 60 days }! !

!ZnMagicCookieTest methodsFor: 'testing' stamp: ''!
testFromString
	| cookie |
	cookie := ZnCookie fromString: self cookieString for: 'www.google.com' asZnUrl.
	self assert: cookie name equals: 'PREF'.
	self assert: cookie path notNil.
	self assert: cookie domain equals: '.google.com'.
	self assert: cookie isExpired not! !

!ZnMagicCookieTest methodsFor: 'accessing' stamp: ''!
cookieStringSubpath
	^ 'PREF=ID=18ae67ce302b6317:TM=1285696140:LM=1285696140:S=hqroFGlRQR1j4Yhy; expires={1}; path=/test/; domain=.google.com' format: { ZnUtils httpDate: DateAndTime now + 60 days }! !

!ZnMagicCookieTest methodsFor: 'testing' stamp: ''!
testInDomain
	| cookie |
	cookie := ZnCookie fromString: self cookieString for: 'http://www.google.com' asZnUrl.
	self assert: (cookie isInDomain: 'http://www.google.com' asZnUrl).
	self assert: (cookie isInDomain: 'http://google.com' asZnUrl).
	self assert: ((cookie isInDomain: 'http://pharo-project.org' asZnUrl) not)
	! !

!ZnManagingMultiThreadedServer commentStamp: ''!
ZnManagingMultiThreadedServer is a ZnMultiThreadedServer that manages the socket stream connections used by the worker threads that are spawned.

  ZnManagingMultiThreadedServer startDefaultOn: 1701.

I keep track of all the connections that I spawn so that I can close them when I am stopped.

Part of Zinc HTTP Components.!
!ZnManagingMultiThreadedServer methodsFor: 'accessing' stamp: ''!
connections
	^ connections ifNil: [ connections := OrderedCollection new ]! !

!ZnManagingMultiThreadedServer methodsFor: 'private' stamp: ''!
closeConnections
	self connections isEmpty ifTrue: [ ^ self ].
	self lock critical: [
		self connections do: [ :each | 
			self logConnectionClosed: each.
			[ each close ] 
				on: Exception 
				do: [ ] ].
		self connections removeAll ]! !

!ZnManagingMultiThreadedServer methodsFor: 'private' stamp: ''!
closeSocketStream: socketStream
	super closeSocketStream: socketStream.
	self lock critical: [ 
		self connections remove: socketStream ifAbsent: [ ] ]! !

!ZnManagingMultiThreadedServer methodsFor: 'accessing' stamp: ''!
lock
	^ lock ifNil: [ lock := Mutex new ]! !

!ZnManagingMultiThreadedServer methodsFor: 'public' stamp: ''!
stop: unregister
	super stop: unregister.
	self closeConnections! !

!ZnManagingMultiThreadedServer methodsFor: 'private' stamp: ''!
socketStreamOn: socket
	| socketStream |
	socketStream := super socketStreamOn: socket.
	self lock critical: [ 
		self connections add: socketStream ].
	^ socketStream! !

!ZnMaximumEntitySize commentStamp: ''!
I am ZnMaximumEntitySize.
I am a DynamicVariable and a ProcessSpecificVariable.

I am used to control the maximum size of entities being read from streams.
!
!ZnMaximumEntitySize methodsFor: 'accessing' stamp: ''!
default
	"By default, allow for entities of up to 16 Mb to be read from streams"
	
	^ 16 * 1024 * 1024! !

!ZnMaximumNumberOfDictionaryEntries commentStamp: ''!
I am ZnMaximumNumberOfDictionaryEntries.
I am a DynamicVariable and a ProcessSpecificVariable.

I am used to control the maximum number of entries being added to a limited ZnMultiValueDictionary.

Used by ZnMultiValueDictionary and thus for reading headers,  url query and application form url encoded entity fields. This helps to protect us from malicious content.
!
!ZnMaximumNumberOfDictionaryEntries methodsFor: 'accessing' stamp: 'nil'!
default
	"The default maximum number dictionary entries to accept."
	
	^ 256! !

!ZnMessage commentStamp: ''!
I am ZnMessage, an abstract class representing an HTTP Message.

Part of Zinc HTTP Components.!
!ZnMessage methodsFor: 'testing' stamp: ''!
isConnectionKeepAlive
	| value |
	value := self headers at: 'Connection' ifAbsent: [ ^ false ].
	^ value sameAs: 'keep-alive'! !

!ZnMessage methodsFor: 'comparing' stamp: ''!
= other
	self class = other class ifFalse: [ ^ false ].
	^ self headers = other headers and: [ self entity = other entity ]! !

!ZnMessage methodsFor: 'private' stamp: ''!
entityWriterOn: stream
	^ ZnEntityWriter new
		headers: self headers;
		stream: stream;
		yourself! !

!ZnMessage methodsFor: 'comparing' stamp: ''!
hash
	^ self headers hash bitXor: self entity hash! !

!ZnMessage methodsFor: 'initialize-release' stamp: ''!
readEntityFrom: stream
	self entity: (self entityReaderOn: stream) readEntity
	! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
resetEntity: object
	"Set my entity to object. Always set my content type and length as defined by object,
	even if I am already describing an entity using my content type and length.
	See also: #clearEntity"

	(entity ~= object and: [ entity notNil ]) 
		ifTrue: [ entity close ].
	entity := object.
	self headers acceptEntityDescription: object! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
session
	"Return the current server session.
	This only returns a value during #handleRequest:"

	^ ZnCurrentServerSession value! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
setConnectionClose
	self headers at: 'Connection' put: 'close'! !

!ZnMessage methodsFor: 'writing' stamp: ''!
writeOn: stream
	| bivalentWriteStream |
	bivalentWriteStream := ZnBivalentWriteStream on: stream.
	self headers writeOn: bivalentWriteStream.
	bivalentWriteStream nextPutAll: String crlf.
	self hasEntity ifTrue: [ 
		(self entityWriterOn: bivalentWriteStream) writeEntity: self entity ]! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
contentLength
	self hasEntity ifTrue: [ ^ self entity contentLength ].
	(self hasHeaders and: [ self headers hasContentLength ]) ifTrue: [ ^ self headers contentLength ].
	^ nil! !

!ZnMessage methodsFor: 'initialize-release' stamp: ''!
readHeaderFrom: stream
	self headers: (ZnHeaders readFrom: stream)
	! !

!ZnMessage methodsFor: 'initialize-release' stamp: ''!
readStreamingFrom: stream
	| entityReader |
	self readHeaderFrom: stream.
	(entityReader := self entityReaderOn: stream)
		streaming.
	self entity: entityReader readEntity
	! !

!ZnMessage methodsFor: 'testing' stamp: ''!
wantsConnectionClose
	"Return if the HTTP protocol should close the connection after processing the receiver"
	
	^ false! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
setConnectionKeepAlive
	self headers at: 'Connection' put: 'keep-alive'! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
entity
	^ entity! !

!ZnMessage methodsFor: 'testing' stamp: ''!
hasHeaders
	^ headers notNil and: [ self headers isEmpty not ]! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
clearEntity
	"Set my entity to nil. 
	Unlike #resetEntity:, my content type and length remain unchanged."

	entity ifNotNil: [
		entity close.
		entity := nil ]! !

!ZnMessage methodsFor: 'initialize-release' stamp: ''!
readBinaryFrom: stream
	| entityReader |
	self readHeaderFrom: stream.
	(entityReader := self entityReaderOn: stream)
		binary.
	self entity: entityReader readEntity! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
contents
	^ entity isNil ifTrue: [ nil ] ifFalse: [ entity contents ]! !

!ZnMessage methodsFor: 'initialize-release' stamp: ''!
readFrom: stream
	self readHeaderFrom: stream.
	self readEntityFrom: stream
	! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
headers: object
	headers := object! !

!ZnMessage methodsFor: 'testing' stamp: ''!
hasEntity
	^ self entity notNil! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
cookies
	self subclassResponsibility ! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
headers
	headers isNil ifTrue: [ headers := ZnHeaders new ].
	^ headers! !

!ZnMessage methodsFor: 'enumerating' stamp: ''!
headersDo: twoArgumentBlock
	self hasHeaders
		ifTrue: [ self headers headersDo: twoArgumentBlock ]! !

!ZnMessage methodsFor: 'copying' stamp: ''!
postCopy
	headers := headers copy.
	"Note that we don't copy the entity, see also #resetEntity: and ZnClient>>#resetEntity"! !

!ZnMessage methodsFor: 'private' stamp: ''!
entityReaderOn: stream
	^ ZnEntityReader new
		headers: self headers;
		stream: stream;
		yourself! !

!ZnMessage methodsFor: 'testing' stamp: ''!
hasSession
	"Return if there currently is a server session.
	This only returns a value during #handleRequest:"

	^ ZnCurrentServerSession value notNil! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
contentType
	self hasEntity ifTrue: [ ^ self entity contentType ].
	(self hasHeaders and: [ self headers hasContentType ]) ifTrue: [ ^ self headers contentType ].
	^ nil! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
setContentType: mimeType
	"Explicitly set my Content-Type to mimeType.
	I normally do this automatically by taking the #contentType from my entity."
	
	self headers contentType: mimeType! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
server
	"Return the current server.
	This only returns a value during #handleRequest:"

	^ ZnCurrentServer value! !

!ZnMessage methodsFor: 'testing' stamp: ''!
isConnectionClose
	| value |
	value := self headers at: 'Connection' ifAbsent: [ ^ false ].
	^ value sameAs: 'close'! !

!ZnMessage methodsFor: 'writing' stamp: ''!
writeToTranscript
	"Write the receiver on the Transcript like when sent or received over the network.
	Useful for debugging, obviously"

	self
		trace: (String streamContents: [ :stream | self writeOn: stream ])! !

!ZnMessage methodsFor: 'accessing' stamp: ''!
entity: object
	"Set my entity to object. Unless I already am describing an entity using my content type and length
	set my content type and length as defined by object."

	entity := object.
	self headers isDescribingEntity ifFalse: [
		self headers acceptEntityDescription: object ]! !

!ZnMessage class methodsFor: 'instance creation' stamp: ''!
readHeaderFrom: stream
	^ self new
		readHeaderFrom: stream;
		yourself! !

!ZnMessage class methodsFor: 'instance creation' stamp: ''!
readStreamingFrom: stream
	^ self new
		readStreamingFrom: stream;
		yourself! !

!ZnMessage class methodsFor: 'instance creation' stamp: ''!
readBinaryFrom: stream
	^ self new
		readBinaryFrom: stream;
		yourself! !

!ZnMessage class methodsFor: 'instance creation' stamp: ''!
readFrom: stream
	^ self new
		readFrom: stream;
		yourself! !

!ZnMessageBenchmark commentStamp: ''!
I am ZnMessageBenchmark helps to test the benchmarking and profiling of ZnMessage writing and reading.

Instance Variables
	buffer:					<ByteArray>
	message:				<ZnObject>
	representation:		<ByteArray>

ZnMessageBenchmark new
	simpleRequest;
	write: 10000.

ZnMessageBenchmark new
	simpleRequest;
	writeRepresentation;
	read: 10000.

ZnMessageBenchmark new
	simpleResponse;
	write: 10000.

ZnMessageBenchmark new
	simpleResponse;
	writeRepresentation;
	read: 10000.
!
!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
textResponseWide8k
	message := ZnResponse ok: (ZnEntity with: (self randomUnicodeWideString: 8 * 1024))! !

!ZnMessageBenchmark methodsFor: 'private' stamp: ''!
randomAsciiString: count
	^ String
		new: count
		streamContents: [ :stream | 
			count timesRepeat: [ stream nextPut: '0123456789ABCDEF' atRandom ] ]! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
textResponseWide256k
	message := ZnResponse ok: (ZnEntity with: (self randomUnicodeWideString: 256 * 1024))! !

!ZnMessageBenchmark methodsFor: 'accessing' stamp: ''!
benchRead
	^ [ self read ] bench! !

!ZnMessageBenchmark methodsFor: 'accessing' stamp: ''!
read: count
	count timesRepeat: [ self read ]! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
simpleResponse
	message := ZnResponse ok: (ZnEntity html: ZnDefaultServerDelegate new generateDWBench)! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
standardRequest
	message := (ZnRequest get: 'http://zn.stfx.eu/echo/one/two/three?param1=123&param2=foobar')
		setAcceptEncodingGzip;
		setBasicAuthenticationUsername: 'john' password: 'secret';
		yourself! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
asciiResponse8k
	message := ZnResponse ok: 
		(ZnEntity 
			with: (self randomAsciiString: 8 * 1024) 
			type: 'text/plain;charset=ascii')! !

!ZnMessageBenchmark methodsFor: 'private' stamp: ''!
sizeBuffer: size
	buffer := ByteArray new: size! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
simpleRequest
	message := ZnRequest get: 'http://zn.stfx.eu/dw-bench'! !

!ZnMessageBenchmark methodsFor: 'accessing' stamp: ''!
benchWrite
	^ [ self write ] bench! !

!ZnMessageBenchmark methodsFor: 'private' stamp: ''!
randomUnicodeWideString: count
	| alphabet |
	"This is about 6% non-ASCII characters, 6% non-octet characters, always a WideString"
	alphabet := '0123456789ABCDEF-élève en Français-0123456789ABCDEF', 
		(WideString withAll: (#(300 400 500) collect: [ :each | each asCharacter ])).
	^ WideString
		new: count
		streamContents: [ :stream | 
			count timesRepeat: [ stream nextPut: alphabet atRandom ] ]! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
binaryResponse256k
	message := ZnResponse ok: (ZnEntity with: (self randomBytes: 256 * 1024))! !

!ZnMessageBenchmark methodsFor: 'accessing' stamp: ''!
write: count
	count timesRepeat: [ self write ]! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
writeRepresentation
	representation := self write contents.
	self sizeBuffer: representation size + 1024 ! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
textResponse64k
	message := ZnResponse ok: (ZnEntity with: (self randomUnicodeString: 64 * 1024))! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
textResponseWide64k
	message := ZnResponse ok: (ZnEntity with: (self randomUnicodeWideString: 64 * 1024))! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
binaryResponse8k
	message := ZnResponse ok: (ZnEntity with: (self randomBytes: 8 * 1024))! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
asciiResponse256k
	message := ZnResponse ok: 
		(ZnEntity 
			with: (self randomAsciiString: 256 * 1024) 
			type: 'text/plain;charset=ascii')! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
postRequest
	message := (ZnRequest post: 'http://zn.stfx.eu/echo/one/two/three?param1=123&param2=foobar')
		setAcceptEncodingGzip;
		setBasicAuthenticationUsername: 'john' password: 'secret';
		entity: (ZnEntity with: (self randomBytes: 512));
		yourself! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
textResponse256k
	message := ZnResponse ok: (ZnEntity with: (self randomUnicodeString: 256 * 1024))! !

!ZnMessageBenchmark methodsFor: 'private' stamp: ''!
randomBytes: count
	| bytes |
	bytes := ByteArray new: count.
	1 to: count do: [ :each | 
		bytes at: each put: (#(65 66 67 68) at: each \\ 4 + 1) ].
	^ bytes! !

!ZnMessageBenchmark methodsFor: 'accessing' stamp: ''!
write
	| writeStream |
	writeStream := self buffer writeStream.
	message writeOn: writeStream.
	^ writeStream! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
textResponse8k
	message := ZnResponse ok: (ZnEntity with: (self randomUnicodeString: 8 * 1024))! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
binaryResponse64k
	message := ZnResponse ok: (ZnEntity with: (self randomBytes: 64 * 1024))! !

!ZnMessageBenchmark methodsFor: 'accessing' stamp: ''!
buffer
	^ buffer ifNil: [  buffer := ByteArray new: ZnUtils streamingBufferSize ]! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
writeUsingGzipEncodingAndChunkingRepresentation
	message
		setContentEncodingGzip;
		setTransferEncodingChunked.
	representation := self write contents.
	self sizeBuffer: representation size + 1024 ! !

!ZnMessageBenchmark methodsFor: 'initialize-release' stamp: ''!
asciiResponse64k
	message := ZnResponse ok: 
		(ZnEntity 
			with: (self randomAsciiString: 64 * 1024) 
			type: 'text/plain;charset=ascii')! !

!ZnMessageBenchmark methodsFor: 'accessing' stamp: ''!
message
	^ message! !

!ZnMessageBenchmark methodsFor: 'private' stamp: ''!
randomUnicodeString: count
	^ String
		new: count
		streamContents: [ :stream | 
			"This is about 6% non-ASCII characters, still a ByteString"
			count timesRepeat: [ stream nextPut: '0123456789ABCDEF-élève en Français-0123456789ABCDEF' atRandom ] ]! !

!ZnMessageBenchmark methodsFor: 'accessing' stamp: ''!
read
	| readStream |
	readStream := representation readStream.
	^ message class readFrom: readStream! !

!ZnMessageBenchmark class methodsFor: 'accessing' stamp: ''!
responses
	^ #( 
		simpleResponse 
		textResponse8k textResponse64k textResponse256k
		textResponseWide8k textResponseWide64k textResponseWide256k
		asciiResponse8k asciiResponse64k asciiResponse256k
		binaryResponse8k binaryResponse64k binaryResponse256k )! !

!ZnMessageBenchmark class methodsFor: 'accessing' stamp: ''!
requests
	^ #( simpleRequest standardRequest postRequest )! !

!ZnMessageBenchmark class methodsFor: 'accessing' stamp: ''!
benchAll
	^ self bench: self messages! !

!ZnMessageBenchmark class methodsFor: 'accessing' stamp: ''!
bench: messages
	| results |
	results := Dictionary new.
	messages 
		do: [ :each | | bench report |
			bench := self new.
			bench perform: each.
			bench writeRepresentation.
			report := 'Writing {1} - Reading {2}' format: { bench benchWrite. bench benchRead }.
			results at: each put: report ] 
		displayingProgress: 'Benchmarking...'.
	^ results! !

!ZnMessageBenchmark class methodsFor: 'accessing' stamp: ''!
messages
	^ self requests , self responses! !

!ZnMessageBenchmarkTest methodsFor: 'testing' stamp: ''!
testRequests
	ZnMessageBenchmark requests do: [ :each |
		| bench |
		bench := ZnMessageBenchmark new.
		bench perform: each.
		self assert: (bench message isKindOf: ZnRequest).
		bench writeRepresentation.
		self assert: (bench read isKindOf: ZnRequest).
		self assert: bench read equals: bench message ]
		
	! !

!ZnMessageBenchmarkTest methodsFor: 'testing' stamp: ''!
testResponses
	ZnMessageBenchmark responses do: [ :each |
		| bench |
		bench := ZnMessageBenchmark new.
		bench perform: each.
		self assert: (bench message isKindOf: ZnResponse).
		bench writeRepresentation.
		self assert: (bench read isKindOf: ZnResponse).
		self assert: bench read equals: bench message ]
		
	! !

!ZnMimePart commentStamp: ''!
I am ZnMimePart.
I hold headers and an optional entity.
I am used in MultiPartMimeEncoding.

Acknowledgement: some code borrowed from AJP.

Part of Zinc HTTP Components.!
!ZnMimePart methodsFor: 'comparing' stamp: ''!
= other
	self class = other class ifFalse: [ ^ false ].
	^ self headers = other headers and: [ self entity = other entity ]! !

!ZnMimePart methodsFor: 'private' stamp: ''!
entityWriterOn: stream
	^ ZnEntityWriter new
		headers: self headers;
		stream: stream;
		yourself! !

!ZnMimePart methodsFor: 'comparing' stamp: ''!
hash
	^ self headers hash bitXor: self entity hash! !

!ZnMimePart methodsFor: 'writing' stamp: ''!
writeOn: stream
	self headers writeOn: stream.
	stream nextPutAll: String crlf.
	self hasEntity ifTrue: [ 
		(self entityWriterOn: stream) writeEntity: self entity ]! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
contentLength
	self hasEntity ifTrue: [ ^ self entity contentLength ].
	(self hasHeaders and: [ self headers hasContentLength ]) ifTrue: [ ^ self headers contentLength ].
	^ nil! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
fileName
	"Pathnames are often silenty encoded using UTF-8,
	this is a no-op for ASCII, but will fail on Latin-1 and others"

	^ (self detectContentDispositionValue: 'filename')
		ifNotNil: [ :encodedFileName | encodedFileName asByteArray utf8Decoded ]! !

!ZnMimePart methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(.
	self hasEntity ifTrue: [ 
		self entity printContentTypeAndLengthOn: stream ].
	stream nextPut: $)
	! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
entity
	^ entity! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
contentDisposition
	^ self headers at: 'Content-Disposition' ifAbsent: [ nil ]! !

!ZnMimePart methodsFor: 'testing' stamp: ''!
hasHeaders
	^ headers notNil and: [ self headers isEmpty not ]! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
fieldValue
	^ self hasEntity 
		ifTrue: [ self entity contents ] 
		ifFalse: [ nil ] ! !

!ZnMimePart methodsFor: 'initialize-release' stamp: ''!
readBinaryFrom: stream
	| entityReader |
	self headers: (ZnHeaders readFrom: stream).
	(entityReader := self entityReaderOn: stream)
		binary.
	self entity: entityReader readEntity! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
contents
	^ entity isNil ifTrue: [ nil ] ifFalse: [ entity contents ]! !

!ZnMimePart methodsFor: 'initialize-release' stamp: ''!
readFrom: stream
	self headers: (ZnHeaders readFrom: stream).
	self entity: (self entityReaderOn: stream) readEntity
	! !

!ZnMimePart methodsFor: 'private' stamp: ''!
contentDispositionValues
	| contentDisposition values start semiColonIndex |
	(contentDisposition := self contentDisposition) isNil ifTrue: [ ^ #() ].
	values := OrderedCollection new: 3.
	start := 1.
	semiColonIndex := contentDisposition indexOf: $; startingAt: start ifAbsent: [ 0 ].
	[ semiColonIndex isZero ] whileFalse: [
		| value |
		value := contentDisposition copyFrom: start to: semiColonIndex - 1.
		values add: (ZnUtils trimString: value).
		start := semiColonIndex + 1.
		semiColonIndex := contentDisposition indexOf: $; startingAt: start ifAbsent: [ 0 ] ].
	values add: (ZnUtils trimString: (contentDisposition copyFrom: start to: contentDisposition size)).
	^ values! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
headers: object
	headers := object! !

!ZnMimePart methodsFor: 'testing' stamp: ''!
hasEntity
	^ self entity notNil! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
fieldValueString
	^ self fieldValue
		ifNil: [ String empty ]
		ifNotNil: [ :value | value asString ]! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
headers
	headers isNil ifTrue: [ headers := ZnHeaders new ].
	^ headers! !

!ZnMimePart methodsFor: 'enumerating' stamp: ''!
headersDo: twoArgumentBlock
	self hasHeaders
		ifTrue: [ self headers headersDo: twoArgumentBlock ]! !

!ZnMimePart methodsFor: 'private' stamp: ''!
entityReaderOn: stream
	^ ZnEntityReader new
		headers: self headers;
		stream: stream;
		allowReadingUpToEnd;
		yourself! !

!ZnMimePart methodsFor: 'copying' stamp: ''!
postCopy
	headers := headers copy.
	"Note that we don't copy the entity, see also #resetEntity: and ZnClient>>#resetEntity"! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
contentType
	self hasEntity ifTrue: [ ^ self entity contentType ].
	(self hasHeaders and: [ self headers hasContentType ]) ifTrue: [ ^ self headers contentType ].
	^ nil! !

!ZnMimePart methodsFor: 'private' stamp: ''!
detectContentDispositionValue: aString
	self contentDispositionValues do: [ :each | 
		((each beginsWith: aString)
			and: [ each size > (aString size + 1)
			and: [ (each at: aString size + 1) = $= ] ]) ifTrue: [
				^ (each copyAfter: $=) withoutQuoting ] ].
	^ nil! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
setContentDisposition: value
	^ self headers at: 'Content-Disposition' put: value ! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
fieldName
	^ self detectContentDispositionValue: 'name'! !

!ZnMimePart methodsFor: 'accessing' stamp: ''!
entity: object
	entity := object.
	self headers isDescribingEntity ifFalse: [
		self headers acceptEntityDescription: object ]! !

!ZnMimePart class methodsFor: 'instance creation' stamp: ''!
fieldName: fieldName fileNamed: fileName
	| mimeType size fileStream entity baseName |
	mimeType := ZnMimeType forFilenameExtension: (ZnFileSystemUtils extensionFor: fileName).
	fileStream := ZnFileSystemUtils oldFileStreamFor: fileName.
	mimeType isBinary ifTrue: [ fileStream binary ].
	size := ZnFileSystemUtils fileSizeFor: fileName.
	(entity := ZnStreamingEntity type: mimeType length: size)
		stream: fileStream.
	baseName := ZnFileSystemUtils baseNameFor: fileName.
	^ self fieldName: fieldName fileName: baseName entity: entity
	! !

!ZnMimePart class methodsFor: 'instance creation' stamp: ''!
fieldName: fieldName entity: entity
	^ self new
		setContentDisposition: 'form-data;name="', fieldName, '"';
		entity: entity;
		yourself! !

!ZnMimePart class methodsFor: 'instance creation' stamp: ''!
fieldName: fieldName fileName: fileName entity: entity
	"Pathnames are often silenty encoded using UTF-8,
	this is a no-op for ASCII, but will fail on Latin-1 and others"

	| encodedFileName |
	encodedFileName := fileName utf8Encoded asString.
	^ self new
		setContentDisposition: 'form-data;name="', fieldName, '";filename="', encodedFileName, '"';
		entity: entity;
		yourself! !

!ZnMimePart class methodsFor: 'instance creation' stamp: ''!
readBinaryFrom: stream
	^ self new
		readBinaryFrom: stream;
		yourself! !

!ZnMimePart class methodsFor: 'instance creation' stamp: ''!
fieldName: fieldName value: fieldValue
	^ self
		fieldName: fieldName
		entity: (ZnEntity with: fieldValue)! !

!ZnMimePart class methodsFor: 'instance creation' stamp: ''!
readFrom: stream
	^ self new
		readFrom: stream;
		yourself! !

!ZnMimeType commentStamp: ''!
I am ZnMimeType.
Mime types are an element used in describing resources, more specifically their format.

Here are some examples MIME types:

	text/plain
	text/html
	text/plain;charset=utf-8
	image/png
	text/*
 
A mime type has a main/sub form with optional parameters. 

For more information: http://en.wikipedia.org/wiki/MIME_type
I know whether I am binary or not and know my charset when applicable.
My class side offers access to some common constants.
Note that for text types we default to UTF-8 encoding.

Examples:

	ZnMimeType textPlain = 'text/plain;charset=utf-8' asZnMimeType.
	ZnMimeType textPlain charSet.
	ZnMimeType textHtml matches: ZnMimeType text.
	ZnMimeType default matches: ZnMimeType any.
	ZnMimeType imagePng isBinary.
	ZnMimeType forFilenameExtension: 'html'.

I started life as a copy of WAMineType.

Part of Zinc HTTP Components.!
!ZnMimeType methodsFor: 'comparing' stamp: 'nil'!
= other
	"#matches should be used instead of #= to ignore parameters."

	^ (self class == other class)
		and: [ self main = other main
			and: [ self sub = other sub 
				and: [ self hasSameParametersAs: other ] ] ]! !

!ZnMimeType methodsFor: 'testing' stamp: 'nil'!
isCharSetUTF8
	^ self charSet notNil and: [ self charSet sameAs: 'utf-8' ]! !

!ZnMimeType methodsFor: 'comparing' stamp: 'nil'!
hash
	| hash |
	hash := self main hash bitXor: self sub hash.
	self hasParameters 
		ifTrue: [ hash := hash bitXor: self parameters hash ].
	^ hash! !

!ZnMimeType methodsFor: 'parameters' stamp: 'nil'!
parameterAt: key
	^ self parameterAt: key ifAbsent: [ KeyNotFound signalFor: key ]! !

!ZnMimeType methodsFor: 'testing' stamp: 'nil'!
isBinary
	"Answers whether the contents of a resource described by me 
	should be considered as binary instead of textual."

	self main = 'text'
		ifTrue: [ ^ false ].
	^ (self sub substrings: '+-')
		noneSatisfy: [ :each | self class textSubTypeFragments includes: each ]! !

!ZnMimeType methodsFor: 'accessing' stamp: 'nil'!
main
	^ main! !

!ZnMimeType methodsFor: 'printing' stamp: 'nil'!
printOn: stream
	stream
		nextPutAll: self main;
		nextPut: $/;
		nextPutAll: self sub.
	parameters isNil ifFalse: [ 
		parameters keysAndValuesDo: [ :key :value | 
			stream
				nextPut: $;;
				nextPutAll: key;
				nextPut: $=;
				nextPutAll: value ] ]! !

!ZnMimeType methodsFor: 'accessing' stamp: 'nil'!
sub
	^ sub! !

!ZnMimeType methodsFor: 'parameters' stamp: 'nil'!
clearCharSet
	self removeParameter: 'charset'! !

!ZnMimeType methodsFor: '*STON-Extensions' stamp: ''!
stonOn: stonWriter
	stonWriter writeObject: self listSingleton: self asString ! !

!ZnMimeType methodsFor: 'parameters' stamp: 'nil'!
setCharSetUTF8
	self charSet: 'utf-8'! !

!ZnMimeType methodsFor: 'accessing' stamp: 'nil'!
sub: aString
	sub := aString asLowercase! !

!ZnMimeType methodsFor: 'parameters' stamp: 'nil'!
charSet
	^ self parameterAt: 'charset' ifAbsent: [ nil ]! !

!ZnMimeType methodsFor: 'parameters' stamp: 'nil'!
parameterAt: aKey put: aValue
	self parameters at: aKey put: aValue! !

!ZnMimeType methodsFor: 'parameters' stamp: 'nil'!
removeParameter: key
	parameters isNil ifTrue: [ ^ self ].
	^ self parameters removeKey: key ifAbsent: [ nil ]! !

!ZnMimeType methodsFor: '*STON-Extensions' stamp: ''!
stonContainSubObjects
	^ false! !

!ZnMimeType methodsFor: 'testing' stamp: 'nil'!
hasSameParametersAs: aMimeType
	^ self hasParameters = aMimeType hasParameters
		and: [self parameters size = aMimeType parameters size
			and: [self parameters associations allSatisfy: [:each |
				aMimeType parameters includesAssociation: each]]]! !

!ZnMimeType methodsFor: 'converting' stamp: 'nil'!
asZnMimeType
	^ self! !

!ZnMimeType methodsFor: 'copying' stamp: 'nil'!
postCopy
	super postCopy.
	parameters := parameters copy! !

!ZnMimeType methodsFor: 'testing' stamp: 'nil'!
hasParameters
	^ parameters notNil and: [ parameters isEmpty not ]! !

!ZnMimeType methodsFor: 'accessing' stamp: 'nil'!
parameters
	parameters isNil ifTrue: [ parameters := SmallDictionary new ].
	^ parameters! !

!ZnMimeType methodsFor: 'accessing' stamp: 'nil'!
parameters: aDictionary
	parameters := aDictionary! !

!ZnMimeType methodsFor: 'testing' stamp: 'nil'!
matches: aMimeType
	"Compare the receiver to aMimeType, which is the pattern to match, 
	it is a normal instance where main or sub can be wildcards.
	Matches should be used instead of #= to ignore parameters."
	
	^ (aMimeType main = '*'
		or: [ aMimeType main = self main ])
		and: [
			aMimeType sub = '*'
				or: [ aMimeType sub = self sub ] ]! !

!ZnMimeType methodsFor: 'converting' stamp: 'nil'!
asMIMEType
	^ self! !

!ZnMimeType methodsFor: 'testing' stamp: 'nil'!
isNonStandard
	"Tests if the receiver is a non-standard mime type,
	i.e. one that is not registered with IANA"
	
	^ (self main beginsWith: 'x-')
		or: [ (self main beginsWith: 'X-')
		or: [ (self sub beginsWith: 'x-')
		or: [ self sub beginsWith: 'X-' ] ] ]! !

!ZnMimeType methodsFor: 'parameters' stamp: 'nil'!
parameterAt: key ifAbsent: block
	parameters isNil ifTrue: [ ^ block value ].
	^ self parameters at: key ifAbsent: block! !

!ZnMimeType methodsFor: 'testing' stamp: 'nil'!
isVendorSpecific
	"Tests if the receiver is a vendor specific mime type"
	
	^ self sub beginsWith: 'vnd.'! !

!ZnMimeType methodsFor: 'accessing' stamp: 'nil'!
main: aString
	main := aString asLowercase! !

!ZnMimeType methodsFor: 'parameters' stamp: 'nil'!
charSet: aString
	self parameters at: 'charset' put: aString! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
applicationPdf
	^ self main: 'application' sub: 'pdf'! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
multiPartFormData
	^ self main: 'multipart' sub: 'form-data'! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
imagePng
	^ self main: 'image' sub: 'png'! !

!ZnMimeType class methodsFor: 'private' stamp: 'nil'!
initializeTextSubTypeFragments
	TextSubTypeFragments := #('javascript' 'json' 'ston' 'html' 'xml' 'sgml' 'yaml' 'csv') asSet! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
any
	"This wildcard instance #matches: any mime type"
	
	^ self main: '*' sub: '*'! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
applicationJavascript
	^ self main: 'application' sub: 'javascript'! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
textJavascript
	^ self main: 'text' sub: 'javascript'! !

!ZnMimeType class methodsFor: 'instance creation' stamp: 'nil'!
main: aMainString sub: aSubstring
	^ self new
		main: aMainString;
		sub: aSubstring;
		yourself! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
imageSvg
	^ self main: 'image' sub: 'svg+xml'! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
imageGif
	^ self main: 'image' sub: 'gif'! !

!ZnMimeType class methodsFor: '*STON-Extensions' stamp: ''!
stonName
	^ #MimeType! !

!ZnMimeType class methodsFor: 'private' stamp: 'nil'!
initializeExtensionsMap
	"Create a mapping between filename extensions and mime types"

	ExtensionsMap := Dictionary new.
	self mimeTypeFilenameExtensionsSpec
		do: [ :each | 
			| mimeType |
			mimeType := self fromString: each first.
			each allButFirstDo: [ :extension | ExtensionsMap at: extension put: mimeType ] ].
	self patchExtensionsMap! !

!ZnMimeType class methodsFor: 'accessing' stamp: 'nil'!
knownMimeTypesWithFilenameExtensions
	"Return a collection of mime types for which we know a filename extension"
	
	^ self extensionsMap values! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
textCss
	^ self main: 'text' sub: 'css'! !

!ZnMimeType class methodsFor: 'instance creation' stamp: 'nil'!
forFilenameExtension: extension ifAbsent: block
	^ self extensionsMap 
		at: extension 
		ifAbsent: block! !

!ZnMimeType class methodsFor: 'instance creation' stamp: 'nil'!
forFilenameExtension: extension
	^ self 
		forFilenameExtension: extension 
		ifAbsent: [ self default ]! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
applicationOctetStream
	^ self main: 'application' sub: 'octet-stream'! !

!ZnMimeType class methodsFor: 'instance creation' stamp: 'nil'!
main: aMainString sub: aSubstring parameters: aDictionary
	^ (self main: aMainString sub: aSubstring)
		parameters: aDictionary;
		yourself! !

!ZnMimeType class methodsFor: 'private' stamp: 'nil'!
extensionsMap
	ExtensionsMap ifNil: [ self initializeExtensionsMap ].
	^ ExtensionsMap! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
applicationSton
	^ self main: 'application' sub: 'ston'! !

!ZnMimeType class methodsFor: 'instance creation' stamp: 'nil'!
fromString: aString 
	| main endOfSub sub parts parameters |
	main := aString copyUpTo: $/.
	endOfSub := aString indexOf: $;.
	endOfSub := endOfSub = 0 
		ifTrue: [ aString size ]
		ifFalse: [ endOfSub - 1 ].
	sub := aString copyFrom: main size + 2 to: endOfSub.
	endOfSub = aString size ifTrue: [ ^ self main: main sub: sub ].
	parts := (aString copyFrom: endOfSub + 1 to: aString size) substrings: ';'.
	parameters := SmallDictionary new.
	parts do: [ :each | 
		parameters
			at: (each copyUpTo: $=) trimBoth 
			put: (each copyAfter: $=) trimBoth ].
	^ self 
		main: main
		sub: sub
		parameters: parameters! !

!ZnMimeType class methodsFor: 'accessing' stamp: 'nil'!
commonMimeTypes
	"Return a list of commom mime types, the ones we provided convenience accessors for."

	^ #( 
			applicationFormUrlEncoded applicationJavascript applicationJson 
			applicationOctetStream applicationPdf applicationXml 
			imageGif imageJpeg imagePng imageSvg 
			textCss textHtml textJavascript textPlain 
		) collect: [ :each | self perform: each ]! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
textPlain
	"Note that the charset is set to utf8 automatically"

	^ (self main: 'text' sub: 'plain') 
		setCharSetUTF8; 
		yourself! !

!ZnMimeType class methodsFor: 'class initialization' stamp: 'nil'!
initialize
	"Last forced update: 20170829"
	
	self initializeTextSubTypeFragments! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
applicationXml
	^ self main: 'application' sub: 'xml'! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
applicationFormUrlEncoded
	^ self main: 'application' sub: 'x-www-form-urlencoded'! !

!ZnMimeType class methodsFor: 'accessing' stamp: 'nil'!
knownFilenameExtensions
	"Return a collection of the filename extensions that we know of"
	
	^ self extensionsMap keys! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
imageJpeg
	^ self main: 'image' sub: 'jpeg'! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
applicationJson
	^ self main: 'application' sub: 'json'! !

!ZnMimeType class methodsFor: 'private' stamp: 'nil'!
textSubTypeFragments
	"Return a set of fragments of sub types that indicate for any main type
	that the mime type is non-binary (thus textual)"
	
	^ TextSubTypeFragments! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
textHtml
	"Note that the charset is set to utf8 automatically"
	
	^ (self main: 'text' sub: 'html') 
		setCharSetUTF8; 
		yourself! !

!ZnMimeType class methodsFor: 'private' stamp: 'nil'!
mimeTypeFilenameExtensionsSpec
	"This array maps mime types to a list of filename extensions, based on the Debian/Ubuntu /etc/mime.types file"
	
"('mime.types' asFileReference readStreamDo: [ :in | in contentsOfEntireFile ]) lines 
	collect: [ :line |
		(line isEmpty not and: [ line first ~= $# ])
			ifTrue: [
				(line findTokens: { Character space. Character tab }) asArray ] ]
	thenSelect: [ :each | each notNil and: [ each size > 1 ] ]."
	
	^ #(#('application/andrew-inset' 'ez') #('application/annodex' 'anx') #('application/atom+xml' 'atom') #('application/atomcat+xml' 'atomcat') #('application/atomserv+xml' 'atomsrv') #('application/bbolin' 'lin') #('application/cu-seeme' 'cu') #('application/davmount+xml' 'davmount') #('application/dicom' 'dcm') #('application/dsptype' 'tsp') #('application/ecmascript' 'es') #('application/futuresplash' 'spl') #('application/hta' 'hta') #('application/java-archive' 'jar') #('application/java-serialized-object' 'ser') #('application/java-vm' 'class') #('application/javascript' 'js') #('application/json' 'json') #('application/m3g' 'm3g') #('application/mac-binhex40' 'hqx') #('application/mac-compactpro' 'cpt') #('application/mathematica' 'nb' 'nbp') #('application/mbox' 'mbox') #('application/msaccess' 'mdb') #('application/msword' 'doc' 'dot') #('application/mxf' 'mxf') #('application/octet-stream' 'bin') #('application/oda' 'oda') #('application/ogg' 'ogx') #('application/onenote' 'one' 'onetoc2' 'onetmp' 'onepkg') #('application/pdf' 'pdf') #('application/pgp-encrypted' 'pgp') #('application/pgp-keys' 'key') #('application/pgp-signature' 'sig') #('application/pics-rules' 'prf') #('application/postscript' 'ps' 'ai' 'eps' 'epsi' 'epsf' 'eps2' 'eps3') #('application/rar' 'rar') #('application/rdf+xml' 'rdf') #('application/rtf' 'rtf') #('application/sla' 'stl') #('application/smil' 'smi' 'smil') #('application/xhtml+xml' 'xhtml' 'xht') #('application/xml' 'xml' 'xsl' 'xsd') #('application/xspf+xml' 'xspf') #('application/zip' 'zip') #('application/vnd.android.package-archive' 'apk') #('application/vnd.cinderella' 'cdy') #('application/vnd.google-earth.kml+xml' 'kml') #('application/vnd.google-earth.kmz' 'kmz') #('application/vnd.mozilla.xul+xml' 'xul') #('application/vnd.ms-excel' 'xls' 'xlb' 'xlt') #('application/vnd.ms-excel.addin.macroEnabled.12' 'xlam') #('application/vnd.ms-excel.sheet.binary.macroEnabled.12' 'xlsb') #('application/vnd.ms-excel.sheet.macroEnabled.12' 'xlsm') #('application/vnd.ms-excel.template.macroEnabled.12' 'xltm') #('application/vnd.ms-fontobject' 'eot') #('application/vnd.ms-officetheme' 'thmx') #('application/vnd.ms-pki.seccat' 'cat') #('application/vnd.ms-powerpoint' 'ppt' 'pps') #('application/vnd.ms-powerpoint.addin.macroEnabled.12' 'ppam') #('application/vnd.ms-powerpoint.presentation.macroEnabled.12' 'pptm') #('application/vnd.ms-powerpoint.slide.macroEnabled.12' 'sldm') #('application/vnd.ms-powerpoint.slideshow.macroEnabled.12' 'ppsm') #('application/vnd.ms-powerpoint.template.macroEnabled.12' 'potm') #('application/vnd.ms-word.document.macroEnabled.12' 'docm') #('application/vnd.ms-word.template.macroEnabled.12' 'dotm') #('application/vnd.oasis.opendocument.chart' 'odc') #('application/vnd.oasis.opendocument.database' 'odb') #('application/vnd.oasis.opendocument.formula' 'odf') #('application/vnd.oasis.opendocument.graphics' 'odg') #('application/vnd.oasis.opendocument.graphics-template' 'otg') #('application/vnd.oasis.opendocument.image' 'odi') #('application/vnd.oasis.opendocument.presentation' 'odp') #('application/vnd.oasis.opendocument.presentation-template' 'otp') #('application/vnd.oasis.opendocument.spreadsheet' 'ods') #('application/vnd.oasis.opendocument.spreadsheet-template' 'ots') #('application/vnd.oasis.opendocument.text' 'odt') #('application/vnd.oasis.opendocument.text-master' 'odm') #('application/vnd.oasis.opendocument.text-template' 'ott') #('application/vnd.oasis.opendocument.text-web' 'oth') #('application/vnd.openxmlformats-officedocument.presentationml.presentation' 'pptx') #('application/vnd.openxmlformats-officedocument.presentationml.slide' 'sldx') #('application/vnd.openxmlformats-officedocument.presentationml.slideshow' 'ppsx') #('application/vnd.openxmlformats-officedocument.presentationml.template' 'potx') #('application/vnd.openxmlformats-officedocument.spreadsheetml.sheet' 'xlsx') #('application/vnd.openxmlformats-officedocument.spreadsheetml.sheet' 'xlsx') #('application/vnd.openxmlformats-officedocument.spreadsheetml.template' 'xltx') #('application/vnd.openxmlformats-officedocument.spreadsheetml.template' 'xltx') #('application/vnd.openxmlformats-officedocument.wordprocessingml.document' 'docx') #('application/vnd.openxmlformats-officedocument.wordprocessingml.template' 'dotx') #('application/vnd.rim.cod' 'cod') #('application/vnd.smaf' 'mmf') #('application/vnd.stardivision.calc' 'sdc') #('application/vnd.stardivision.chart' 'sds') #('application/vnd.stardivision.draw' 'sda') #('application/vnd.stardivision.impress' 'sdd') #('application/vnd.stardivision.math' 'sdf') #('application/vnd.stardivision.writer' 'sdw') #('application/vnd.stardivision.writer-global' 'sgl') #('application/vnd.sun.xml.calc' 'sxc') #('application/vnd.sun.xml.calc.template' 'stc') #('application/vnd.sun.xml.draw' 'sxd') #('application/vnd.sun.xml.draw.template' 'std') #('application/vnd.sun.xml.impress' 'sxi') #('application/vnd.sun.xml.impress.template' 'sti') #('application/vnd.sun.xml.math' 'sxm') #('application/vnd.sun.xml.writer' 'sxw') #('application/vnd.sun.xml.writer.global' 'sxg') #('application/vnd.sun.xml.writer.template' 'stw') #('application/vnd.symbian.install' 'sis') #('application/vnd.tcpdump.pcap' 'cap' 'pcap') #('application/vnd.visio' 'vsd') #('application/vnd.wap.wbxml' 'wbxml') #('application/vnd.wap.wmlc' 'wmlc') #('application/vnd.wap.wmlscriptc' 'wmlsc') #('application/vnd.wordperfect' 'wpd') #('application/vnd.wordperfect5.1' 'wp5') #('application/x-123' 'wk') #('application/x-7z-compressed' '7z') #('application/x-abiword' 'abw') #('application/x-apple-diskimage' 'dmg') #('application/x-bcpio' 'bcpio') #('application/x-bittorrent' 'torrent') #('application/x-cab' 'cab') #('application/x-cbr' 'cbr') #('application/x-cbz' 'cbz') #('application/x-cdf' 'cdf' 'cda') #('application/x-cdlink' 'vcd') #('application/x-chess-pgn' 'pgn') #('application/x-comsol' 'mph') #('application/x-cpio' 'cpio') #('application/x-csh' 'csh') #('application/x-debian-package' 'deb' 'udeb') #('application/x-director' 'dcr' 'dir' 'dxr') #('application/x-dms' 'dms') #('application/x-doom' 'wad') #('application/x-dvi' 'dvi') #('application/x-font' 'pfa' 'pfb' 'gsf' 'pcf' 'pcf.Z') #('application/x-font-woff' 'woff') #('application/x-freemind' 'mm') #('application/x-futuresplash' 'spl') #('application/x-ganttproject' 'gan') #('application/x-gnumeric' 'gnumeric') #('application/x-go-sgf' 'sgf') #('application/x-graphing-calculator' 'gcf') #('application/x-gtar' 'gtar') #('application/x-gtar-compressed' 'tgz' 'taz') #('application/x-hdf' 'hdf') #('application/x-hwp' 'hwp') #('application/x-ica' 'ica') #('application/x-info' 'info') #('application/x-internet-signup' 'ins' 'isp') #('application/x-iphone' 'iii') #('application/x-iso9660-image' 'iso') #('application/x-jam' 'jam') #('application/x-java-jnlp-file' 'jnlp') #('application/x-jmol' 'jmz') #('application/x-kchart' 'chrt') #('application/x-killustrator' 'kil') #('application/x-koan' 'skp' 'skd' 'skt' 'skm') #('application/x-kpresenter' 'kpr' 'kpt') #('application/x-kspread' 'ksp') #('application/x-kword' 'kwd' 'kwt') #('application/x-latex' 'latex') #('application/x-lha' 'lha') #('application/x-lyx' 'lyx') #('application/x-lzh' 'lzh') #('application/x-lzx' 'lzx') #('application/x-maker' 'frm' 'maker' 'frame' 'fm' 'fb' 'book' 'fbdoc') #('application/x-md5' 'md5') #('application/x-mif' 'mif') #('application/x-mpegURL' 'm3u8') #('application/x-ms-wmd' 'wmd') #('application/x-ms-wmz' 'wmz') #('application/x-msdos-program' 'com' 'exe' 'bat' 'dll') #('application/x-msi' 'msi') #('application/x-netcdf' 'nc') #('application/x-ns-proxy-autoconfig' 'pac' 'dat') #('application/x-nwc' 'nwc') #('application/x-object' 'o') #('application/x-oz-application' 'oza') #('application/x-pkcs7-certreqresp' 'p7r') #('application/x-pkcs7-crl' 'crl') #('application/x-python-code' 'pyc' 'pyo') #('application/x-qgis' 'qgs' 'shp' 'shx') #('application/x-quicktimeplayer' 'qtl') #('application/x-rdp' 'rdp') #('application/x-redhat-package-manager' 'rpm') #('application/x-rss+xml' 'rss') #('application/x-ruby' 'rb') #('application/x-scilab' 'sci' 'sce') #('application/x-scilab-xcos' 'xcos') #('application/x-sh' 'sh') #('application/x-sha1' 'sha1') #('application/x-shar' 'shar') #('application/x-shockwave-flash' 'swf' 'swfl') #('application/x-silverlight' 'scr') #('application/x-sql' 'sql') #('application/x-stuffit' 'sit' 'sitx') #('application/x-sv4cpio' 'sv4cpio') #('application/x-sv4crc' 'sv4crc') #('application/x-tar' 'tar') #('application/x-tcl' 'tcl') #('application/x-tex-gf' 'gf') #('application/x-tex-pk' 'pk') #('application/x-texinfo' 'texinfo' 'texi') #('application/x-trash' '~' '%' 'bak' 'old' 'sik') #('application/x-troff' 't' 'tr' 'roff') #('application/x-troff-man' 'man') #('application/x-troff-me' 'me') #('application/x-troff-ms' 'ms') #('application/x-ustar' 'ustar') #('application/x-wais-source' 'src') #('application/x-wingz' 'wz') #('application/x-x509-ca-cert' 'crt') #('application/x-xcf' 'xcf') #('application/x-xfig' 'fig') #('application/x-xpinstall' 'xpi') #('audio/amr' 'amr') #('audio/amr-wb' 'awb') #('audio/amr' 'amr') #('audio/amr-wb' 'awb') #('audio/annodex' 'axa') #('audio/basic' 'au' 'snd') #('audio/csound' 'csd' 'orc' 'sco') #('audio/flac' 'flac') #('audio/midi' 'mid' 'midi' 'kar') #('audio/mpeg' 'mpga' 'mpega' 'mp2' 'mp3' 'm4a') #('audio/mpegurl' 'm3u') #('audio/ogg' 'oga' 'ogg' 'spx') #('audio/prs.sid' 'sid') #('audio/x-aiff' 'aif' 'aiff' 'aifc') #('audio/x-gsm' 'gsm') #('audio/x-mpegurl' 'm3u') #('audio/x-ms-wma' 'wma') #('audio/x-ms-wax' 'wax') #('audio/x-pn-realaudio' 'ra' 'rm' 'ram') #('audio/x-realaudio' 'ra') #('audio/x-scpls' 'pls') #('audio/x-sd2' 'sd2') #('audio/x-wav' 'wav') #('chemical/x-alchemy' 'alc') #('chemical/x-cache' 'cac' 'cache') #('chemical/x-cache-csf' 'csf') #('chemical/x-cactvs-binary' 'cbin' 'cascii' 'ctab') #('chemical/x-cdx' 'cdx') #('chemical/x-cerius' 'cer') #('chemical/x-chem3d' 'c3d') #('chemical/x-chemdraw' 'chm') #('chemical/x-cif' 'cif') #('chemical/x-cmdf' 'cmdf') #('chemical/x-cml' 'cml') #('chemical/x-compass' 'cpa') #('chemical/x-crossfire' 'bsd') #('chemical/x-csml' 'csml' 'csm') #('chemical/x-ctx' 'ctx') #('chemical/x-cxf' 'cxf' 'cef') #('chemical/x-embl-dl-nucleotide' 'emb' 'embl') #('chemical/x-galactic-spc' 'spc') #('chemical/x-gamess-input' 'inp' 'gam' 'gamin') #('chemical/x-gaussian-checkpoint' 'fch' 'fchk') #('chemical/x-gaussian-cube' 'cub') #('chemical/x-gaussian-input' 'gau' 'gjc' 'gjf') #('chemical/x-gaussian-log' 'gal') #('chemical/x-gcg8-sequence' 'gcg') #('chemical/x-genbank' 'gen') #('chemical/x-hin' 'hin') #('chemical/x-isostar' 'istr' 'ist') #('chemical/x-jcamp-dx' 'jdx' 'dx') #('chemical/x-kinemage' 'kin') #('chemical/x-macmolecule' 'mcm') #('chemical/x-macromodel-input' 'mmd' 'mmod') #('chemical/x-mdl-molfile' 'mol') #('chemical/x-mdl-rdfile' 'rd') #('chemical/x-mdl-rxnfile' 'rxn') #('chemical/x-mdl-sdfile' 'sd' 'sdf') #('chemical/x-mdl-tgf' 'tgf') #('chemical/x-mmcif' 'mcif') #('chemical/x-mol2' 'mol2') #('chemical/x-molconn-Z' 'b') #('chemical/x-mopac-graph' 'gpt') #('chemical/x-mopac-input' 'mop' 'mopcrt' 'mpc' 'zmt') #('chemical/x-mopac-out' 'moo') #('chemical/x-mopac-vib' 'mvb') #('chemical/x-ncbi-asn1' 'asn') #('chemical/x-ncbi-asn1-ascii' 'prt' 'ent') #('chemical/x-ncbi-asn1-binary' 'val' 'aso') #('chemical/x-ncbi-asn1-spec' 'asn') #('chemical/x-pdb' 'pdb' 'ent') #('chemical/x-rosdal' 'ros') #('chemical/x-swissprot' 'sw') #('chemical/x-vamas-iso14976' 'vms') #('chemical/x-vmd' 'vmd') #('chemical/x-xtel' 'xtel') #('chemical/x-xyz' 'xyz') #('image/gif' 'gif') #('image/ief' 'ief') #('image/jpeg' 'jpeg' 'jpg' 'jpe') #('image/pcx' 'pcx') #('image/png' 'png') #('image/svg+xml' 'svg' 'svgz') #('image/tiff' 'tiff' 'tif') #('image/vnd.djvu' 'djvu' 'djv') #('image/vnd.microsoft.icon' 'ico') #('image/vnd.wap.wbmp' 'wbmp') #('image/x-canon-cr2' 'cr2') #('image/x-canon-crw' 'crw') #('image/x-cmu-raster' 'ras') #('image/x-coreldraw' 'cdr') #('image/x-coreldrawpattern' 'pat') #('image/x-coreldrawtemplate' 'cdt') #('image/x-corelphotopaint' 'cpt') #('image/x-epson-erf' 'erf') #('image/x-jg' 'art') #('image/x-jng' 'jng') #('image/x-ms-bmp' 'bmp') #('image/x-nikon-nef' 'nef') #('image/x-olympus-orf' 'orf') #('image/x-photoshop' 'psd') #('image/x-portable-anymap' 'pnm') #('image/x-portable-bitmap' 'pbm') #('image/x-portable-graymap' 'pgm') #('image/x-portable-pixmap' 'ppm') #('image/x-rgb' 'rgb') #('image/x-xbitmap' 'xbm') #('image/x-xpixmap' 'xpm') #('image/x-xwindowdump' 'xwd') #('message/rfc822' 'eml') #('model/iges' 'igs' 'iges') #('model/mesh' 'msh' 'mesh' 'silo') #('model/vrml' 'wrl' 'vrml') #('model/x3d+vrml' 'x3dv') #('model/x3d+xml' 'x3d') #('model/x3d+binary' 'x3db') #('text/cache-manifest' 'appcache') #('text/calendar' 'ics' 'icz') #('text/css' 'css') #('text/csv' 'csv') #('text/h323' '323') #('text/html' 'html' 'htm' 'shtml') #('text/iuls' 'uls') #('text/mathml' 'mml') #('text/plain' 'asc' 'txt' 'text' 'pot' 'brf' 'srt') #('text/richtext' 'rtx') #('text/scriptlet' 'sct' 'wsc') #('text/texmacs' 'tm') #('text/tab-separated-values' 'tsv') #('text/vnd.sun.j2me.app-descriptor' 'jad') #('text/vnd.wap.wml' 'wml') #('text/vnd.wap.wmlscript' 'wmls') #('text/x-bibtex' 'bib') #('text/x-boo' 'boo') #('text/x-c++hdr' 'h++' 'hpp' 'hxx' 'hh') #('text/x-c++src' 'c++' 'cpp' 'cxx' 'cc') #('text/x-chdr' 'h') #('text/x-component' 'htc') #('text/x-csh' 'csh') #('text/x-csrc' 'c') #('text/x-dsrc' 'd') #('text/x-diff' 'diff' 'patch') #('text/x-haskell' 'hs') #('text/x-java' 'java') #('text/x-lilypond' 'ly') #('text/x-literate-haskell' 'lhs') #('text/x-moc' 'moc') #('text/x-pascal' 'p' 'pas') #('text/x-pcs-gcd' 'gcd') #('text/x-perl' 'pl' 'pm') #('text/x-python' 'py') #('text/x-scala' 'scala') #('text/x-setext' 'etx') #('text/x-sfv' 'sfv') #('text/x-sh' 'sh') #('text/x-tcl' 'tcl' 'tk') #('text/x-tex' 'tex' 'ltx' 'sty' 'cls') #('text/x-vcalendar' 'vcs') #('text/x-vcard' 'vcf') #('video/3gpp' '3gp') #('video/annodex' 'axv') #('video/dl' 'dl') #('video/dv' 'dif' 'dv') #('video/fli' 'fli') #('video/gl' 'gl') #('video/mpeg' 'mpeg' 'mpg' 'mpe') #('video/MP2T' 'ts') #('video/mp4' 'mp4') #('video/quicktime' 'qt' 'mov') #('video/ogg' 'ogv') #('video/webm' 'webm') #('video/vnd.mpegurl' 'mxu') #('video/x-flv' 'flv') #('video/x-la-asf' 'lsf' 'lsx') #('video/x-mng' 'mng') #('video/x-ms-asf' 'asf' 'asx') #('video/x-ms-wm' 'wm') #('video/x-ms-wmv' 'wmv') #('video/x-ms-wmx' 'wmx') #('video/x-ms-wvx' 'wvx') #('video/x-msvideo' 'avi') #('video/x-sgi-movie' 'movie') #('video/x-matroska' 'mpv' 'mkv') #('x-conference/x-cooltalk' 'ice') #('x-epoc/x-sisx-app' 'sisx') #('x-world/x-vrml' 'vrm' 'vrml' 'wrl'))! !

!ZnMimeType class methodsFor: 'private' stamp: 'nil'!
patchExtensionsMap
	"Patch the extension map that we read from the spec"
	
	#('~' '%') do: [ :each | ExtensionsMap removeKey: each ].
	(ExtensionsMap at: 'text') setCharSetUTF8.
	(ExtensionsMap at: 'html') setCharSetUTF8.
	ExtensionsMap at: 'asc' put: 'text/plain' asZnMimeType! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
default
	^ self applicationOctetStream ! !

!ZnMimeType class methodsFor: '*STON-Extensions' stamp: ''!
fromSton: stonReader
	^ self fromString: stonReader parseListSingleton! !

!ZnMimeType class methodsFor: 'convenience' stamp: 'nil'!
text
	"This wildcard instance #matches: all textual mime types"
	
	^ self main: 'text' sub: '*'! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testReading

	| mimeType |

	mimeType := ZnMimeType fromString: 'text/plain; charset=utf-8'.
	self assert: mimeType main equals: 'text'.
	self assert: mimeType sub equals: 'plain'.
	self assert: mimeType charSet equals: 'utf-8'.
	self assert: mimeType isCharSetUTF8.
	self assert: mimeType isBinary not! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testCopying
	| mimeType1 mimeType2 |
	mimeType1 := ZnMimeType textPlain.
	mimeType2 := ZnMimeType textPlain.
	self assert: mimeType1 equals: mimeType2.
	self assert: mimeType1 parameters equals: mimeType2 parameters.
	mimeType1 charSet: 'utf-8'.
	self assert: mimeType1 charSet equals: 'utf-8'.
	mimeType2 charSet: 'latin1'.
	self assert: mimeType2 charSet equals: 'latin1'.
	self assert: (mimeType1 matches: mimeType2).
	self deny: mimeType1 parameters equals: mimeType2 parameters.
	self deny: mimeType1 charSet equals: mimeType2 charSet! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testMatches
	#(#('text/plain' 'text/*') #('text/plain' '*/*') #('text/plain;charset=utf-8' 'text/*') #('text/plain;charset=utf-8' 'text/plain') #('text/plain' 'text/plain;charset=utf-8') #('text/plain;charset=utf-8' 'text/plain;charset=ascii'))
		do: [ :each | 
			self deny: each first asZnMimeType equals: each second asZnMimeType.
			self assert: (each first asZnMimeType matches: each second asZnMimeType) ]! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testDefault

	self assert: ZnMimeType default equals: ZnMimeType applicationOctetStream! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testAsMimeType
	self assert: 'text/plain;charset=utf-8' asZnMimeType equals: ZnMimeType textPlain.
	self assert: ZnMimeType applicationOctetStream asZnMimeType equals: ZnMimeType applicationOctetStream! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testComparingWithParameters

	| mimeType equalMimeType |

	mimeType := ZnMimeType fromString: 'application/json;q=1'.
	equalMimeType := ZnMimeType applicationJson parameterAt: 'q' put: '1'.

	self
		assert: mimeType equals: equalMimeType;
		assert: mimeType hash equals: equalMimeType hash;
		deny: mimeType equals: ZnMimeType applicationJson! !

!ZnMimeTypeTest methodsFor: 'accessing' stamp: ''!
someNonBinaryMimeTypes
	^ #(
		'text/plain;charset=ascii' 
		'application/json;charset=utf-8' 
		'application/ston'
		'application/vnd.com.runkeeper.user+json;charset=ISO-8859-1' 
		'application/xml-dtd' 
		'application/xslt+xml' 
		'image/svg+xml' 
		'application/SGML' 
		'model/x3d+xml'
		'application/csv')! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testCharset

	| mimeType |

	mimeType := ZnMimeType textPlain.
	self assert: mimeType charSet equals: 'utf-8'.
	mimeType charSet: 'ascii'.
	self assert: mimeType charSet equals: 'ascii'.
	mimeType clearCharSet.
	self assert: mimeType charSet isNil.
	mimeType setCharSetUTF8.
	self assert: mimeType charSet equals: 'utf-8'! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testParameters

	| mimeType |

	mimeType := ZnMimeType main: 'text' sub: 'plain'.
	self should: [ mimeType parameterAt: 'foo' ] raise: KeyNotFound.
	self assert: ( mimeType parameterAt: 'foo' ifAbsent: [ #none ] ) equals: #none.
	mimeType parameterAt: 'foo' put: '1'.
	self assert: ( mimeType parameterAt: 'foo' ) equals: '1'.
	self assert: ( mimeType parameterAt: 'foo' ifAbsent: [ #none ] ) equals: '1'.
	mimeType removeParameter: 'foo'.
	mimeType removeParameter: 'bar'.
	self should: [ mimeType parameterAt: 'foo' ] raise: KeyNotFound.
	self assert: ( mimeType parameterAt: 'foo' ifAbsent: [ #none ] ) equals: #none! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testIsBinary
	self assert: ZnMimeType applicationOctetStream isBinary.
	self assert: ZnMimeType imagePng isBinary.
	self deny: ZnMimeType textPlain isBinary.
	self deny: ZnMimeType textHtml isBinary.
	self deny: ZnMimeType textJavascript isBinary.
	self deny: ZnMimeType applicationJson isBinary.
	self someNonBinaryMimeTypes do: [ :each |
		self deny: each asZnMimeType isBinary ]! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testWriting

	| mimeType |

	( mimeType := ZnMimeType main: 'text' sub: 'plain' ) charSet: 'utf-8'.
	self assert: mimeType printString equals: 'text/plain;charset=utf-8'.
	self assert: mimeType isCharSetUTF8.
	self assert: mimeType isBinary not! !

!ZnMimeTypeTest methodsFor: 'testing' stamp: ''!
testIdentity

	self assert: ZnMimeType textPlain equals: ZnMimeType textPlain! !

!ZnMissingHost commentStamp: ''!
ZnMissingHost is signalled when a host should be specified but was not.

Part of Zinc HTTP Components. !
!ZnMonticelloServerDelegate commentStamp: ''!
I am ZnMonticelloServerDelegate.
I am a proof of concept implementation of a basic Monticello server.
I function as a delegate for ZnServer.

ZnServer startDefaultOn: 1701.
ZnServer default delegate: ((ZnMonticelloServerDelegate new) 
									directory: '/tmp/monticello'; 
									yourself).

Part of Zinc HTTP Components.!
!ZnMonticelloServerDelegate methodsFor: 'public' stamp: ''!
value: request
	"I implement the generic #value: message as equivalent to #handleRequest:"
	
	^ self handleRequest: request! !

!ZnMonticelloServerDelegate methodsFor: 'private' stamp: ''!
handleGetMczEntry: request
	| name file stream entity |
	name := request uri firstPathSegment.
	file := self directory / name.
	^ ((self isValidMczName: name) and: [ file exists ]) 
		ifTrue: [ |  |
			(stream := file readStream)
				binary.
			(entity := ZnStreamingEntity type: ZnMimeType applicationOctetStream length: file size)
				stream: stream.
			ZnResponse ok: entity ]
		ifFalse: [ ZnResponse notFound: request uri ]! !

!ZnMonticelloServerDelegate methodsFor: 'private' stamp: ''!
repositoryListing
	^ ZnHtmlOutputStream streamContents: [ :html |
		html page: 'Monticello Repository' do: [
			html tag: #ul do: [ 
				self mczEntries do: [ :each |
					html tag: #li do: [ 
						html 
							tag: #a 
							attributes: { #href. each } 
							with: each ] ] ] ] ]! !

!ZnMonticelloServerDelegate methodsFor: 'accessing' stamp: ''!
directory: object
	directory := object asFileReference! !

!ZnMonticelloServerDelegate methodsFor: 'private' stamp: ''!
handleListMczEntries: request
	^ ZnResponse ok: (ZnEntity html: self repositoryListing)! !

!ZnMonticelloServerDelegate methodsFor: 'private' stamp: ''!
handlePutMczEntry: request
	| name file |
	name := request uri firstPathSegment.
	file := self directory / name.
	^ ((self isValidMczName: name) and: [ file exists not ]) 
		ifTrue: [
			file writeStreamDo: [ :stream |
				stream binary.
				request entity writeOn: stream ].
			ZnResponse created: request uri ]
		ifFalse: [ ZnResponse badRequest: request ]! !

!ZnMonticelloServerDelegate methodsFor: 'accessing' stamp: ''!
directory
	^ directory ! !

!ZnMonticelloServerDelegate methodsFor: 'private' stamp: ''!
isValidMczName: string
	^ string isString 
		and: [ string isEmpty not
			and: [ (string endsWith: '.mcz')
				and: [ (string includes: $/) not ] ] ]! !

!ZnMonticelloServerDelegate methodsFor: 'accessing' stamp: ''!
mczEntries
	^ (self directory fileNames select: [ :each | each endsWith: '.mcz' ])
		asSortedCollection! !

!ZnMonticelloServerDelegate methodsFor: 'public' stamp: ''!
handleRequest: request
	(request method = #GET)
		ifTrue: [
			^ request uri isSlash
				ifTrue: [ self handleListMczEntries: request ]
				ifFalse: [ self handleGetMczEntry: request ] ].
	^ (request method = #PUT) 
		ifTrue: [ self handlePutMczEntry: request ]
		ifFalse: [ ZnResponse badRequest: request ]! !

!ZnMultiPartFormDataEntity commentStamp: ''!
I am ZnMultiPartFormDataEntity, a concrete HTTP Entity 
holding multi part form data that is encoded according to specific rules.
I am a ZnEntity.

Acknowledgement: some code borrowed from AJP.

Part of Zinc HTTP Components.!
!ZnMultiPartFormDataEntity methodsFor: 'accessing' stamp: ''!
parts
	parts isNil ifTrue: [ parts := OrderedCollection new ].
	^ parts! !

!ZnMultiPartFormDataEntity methodsFor: 'testing' stamp: ''!
isEmpty
	^ parts isNil or: [ parts isEmpty ]! !

!ZnMultiPartFormDataEntity methodsFor: 'accessing' stamp: ''!
partNamed: fieldName
	^ self partNamed: fieldName ifNone: [ self error: 'Cannot find part named ', fieldName asString ]! !

!ZnMultiPartFormDataEntity methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	self isEmpty
		ifTrue: [ ^ self ].
	stream space.
	self parts printElementsOn: stream! !

!ZnMultiPartFormDataEntity methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	self contentType: self mimeTypeWithBoundary  
	! !

!ZnMultiPartFormDataEntity methodsFor: 'private' stamp: ''!
parse: bytes boundary: boundary binary: binary
	| next start fullBoundary |
	fullBoundary := '--' asByteArray, boundary.
	"Sometimes there is whitespace in front of the first boundary"
	start := (bytes
		indexOfSubCollection: fullBoundary
		startingAt: 1) + 1.
	next := bytes
		indexOfSubCollection: fullBoundary
		startingAt: start 
		ifAbsent: [ bytes size ].
	[ next < (bytes size - 2) ] whileTrue: [ | partReadStream |
		partReadStream := ReadStream on: bytes from: start + 2 to: next - 3.
		self addPart: (ZnMimePart perform: (binary ifTrue: [ #readBinaryFrom: ] ifFalse: [ #readFrom: ]) with: partReadStream).
		start := next + fullBoundary size.
		next := bytes
			indexOfSubCollection: fullBoundary
			startingAt: start
			ifAbsent: [ bytes size ] ]! !

!ZnMultiPartFormDataEntity methodsFor: 'writing' stamp: ''!
writeOn: stream
	"We always go via our representation because we need a bivalent stream"
	
	representation isNil ifTrue: [ self computeRepresentation ].
	ZnUtils nextPutAll: representation on: stream! !

!ZnMultiPartFormDataEntity methodsFor: 'enumerating' stamp: ''!
partsDo: block
	parts isNil ifTrue: [ ^ self ].
	parts do: block  ! !

!ZnMultiPartFormDataEntity methodsFor: 'writing' stamp: ''!
writeRepresentationOn: stream
	| boundary |
	boundary := self getBoundary.
	self parts do: [ :each |
		stream nextPutAll: '--'; nextPutAll: boundary; nextPutAll: String crlf.
		each writeOn: stream.
		stream nextPutAll: String crlf ].
	stream nextPutAll: '--'; nextPutAll: boundary; nextPutAll: '--'; nextPutAll: String crlf
! !

!ZnMultiPartFormDataEntity methodsFor: 'accessing' stamp: ''!
addPart: mimePart
	self invalidateRepresentation.
	self parts add: mimePart! !

!ZnMultiPartFormDataEntity methodsFor: 'accessing' stamp: ''!
contentLength
	contentLength isNil ifTrue: [ self computeRepresentation ].
	^ contentLength! !

!ZnMultiPartFormDataEntity methodsFor: 'private' stamp: ''!
generateBoundary
	^ String streamContents: [ :stream | | letters |
			stream nextPutAll: 'Boundary-Zn-'.
			letters := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'.
			8 timesRepeat: [ stream nextPut: letters atRandom ] ]
	! !

!ZnMultiPartFormDataEntity methodsFor: 'private' stamp: ''!
invalidateRepresentation
	representation := nil.
	contentLength := nil! !

!ZnMultiPartFormDataEntity methodsFor: 'accessing' stamp: ''!
getBoundary
	"Return the multipart/form-data MIME part boundary.
	This should really be there, set externally or internally.
	See #initialize and #mimeTypeWithBoundary"
	
	^ (self contentType parameterAt: 'boundary') withoutQuoting ! !

!ZnMultiPartFormDataEntity methodsFor: 'initialize-release' stamp: ''!
readBinaryFrom: stream
	"Switch to streaming implementation later on"
	
	| bytes |
	"We have to use the contentLength instance variable instead of the accessor else a representation will be computed"
	contentLength isNil
		ifTrue: [ 
			bytes := ZnUtils readUpToEnd: stream limit: ZnMaximumEntitySize value ]
		ifFalse: [
			self contentLength > ZnMaximumEntitySize value ifTrue: [ ZnEntityTooLarge signal ].
			bytes := ByteArray ofSize: contentLength.
			stream next: contentLength into: bytes ].
	self parse: bytes boundary: self getBoundary asByteArray binary: true! !

!ZnMultiPartFormDataEntity methodsFor: 'accessing' stamp: ''!
contentType: object
	"We only allow assignment compatible with our designated mime type.
	The main/sub must be equal but the parameters must be allowed to be different"
	
	| newType |
	newType := object asZnMimeType.
	(self class matches: newType)
		ifTrue: [ contentType := newType ]! !

!ZnMultiPartFormDataEntity methodsFor: 'accessing' stamp: ''!
contents
	^ self parts! !

!ZnMultiPartFormDataEntity methodsFor: 'private' stamp: ''!
computeRepresentation
	representation := ByteArray streamContents: [ :stream | 
		self writeRepresentationOn: (ZnBivalentWriteStream on: stream) ].
	contentLength := representation size! !

!ZnMultiPartFormDataEntity methodsFor: 'initialize-release' stamp: ''!
readFrom: stream
	"Switch to streaming implementation later on"
	
	| bytes |
	"We have to use the contentLength instance variable instead of the accessor else a representation will be computed"
	contentLength isNil
		ifTrue: [ 
			bytes := ZnUtils readUpToEnd: stream limit: ZnMaximumEntitySize value ]
		ifFalse: [
			self contentLength > ZnMaximumEntitySize value ifTrue: [ ZnEntityTooLarge signal ].
			bytes := ByteArray ofSize: contentLength.
			stream next: contentLength into: bytes ].
	self parse: bytes boundary: self getBoundary asByteArray binary: false! !

!ZnMultiPartFormDataEntity methodsFor: 'accessing' stamp: ''!
partNamed: fieldName ifNone: block
	parts isNil ifTrue: [ block value ].
	^ self parts detect: [ :each | each fieldName = fieldName ] ifNone: block! !

!ZnMultiPartFormDataEntity methodsFor: 'private' stamp: ''!
mimeTypeWithBoundary
	| mimeType |
	mimeType := self class designatedMimeType copy.
	mimeType parameterAt: 'boundary' put: self generateBoundary.
	^ mimeType! !

!ZnMultiPartFormDataEntity class methodsFor: 'testing' stamp: ''!
designatedMimeType
	^ ZnMimeType multiPartFormData  ! !

!ZnMultiPartFormDataEntity class methodsFor: 'testing' stamp: ''!
matches: mimeType
	^ mimeType matches: 'multipart/*' asZnMimeType! !

!ZnMultiThreadedServer commentStamp: ''!
I am ZnMultiThreadedServer.
I inherit most features from ZnSingleThreadedServer.

  ZnMultiThreadedServer startDefaultOn: 1701.
  ZnMultiThreadedServer default authenticator: (ZnBasicAuthenticator username: 'foo' password: 'secret').
  ZnClient new username: 'foo' password: 'secret'; get: 'http://localhost:1701'.

I am multi threaded, I fork a new process for each incoming request.
I try to keep connections alive in each process.

Part of Zinc HTTP Components.!
!ZnMultiThreadedServer methodsFor: 'private' stamp: ''!
workerProcessName
	^ String streamContents: [ :stream |
		stream nextPutAll: self class name; nextPutAll: ' HTTP worker' ]! !

!ZnMultiThreadedServer methodsFor: 'private' stamp: ''!
writeResponseTerminationExceptionSet
	"Return the set of exceptions which, when they occur while writing a response,
	are interpreted as equivalent to a timeout or connection close."

	^ self exceptionSet: #(#ConnectionClosed #ConnectionTimedOut #PrimitiveFailed)! !

!ZnMultiThreadedServer methodsFor: 'request handling' stamp: ''!
executeOneRequestResponseOn: stream
	"Execute one HTTP request / response cycle on stream in 3 steps
	#readRequest: #handleRequest: and #writeResponse:on:
	Return true when the outer loop we are in should stop."

	| request response timing|
	timing := ZnServerTransactionTiming new.
	(request := self readRequestSafely: stream timing: timing)
		ifNil: [ ^ true ]
		ifNotNil: [ 
			response := self handleRequest: request timing: timing.
			self augmentResponse: response forRequest: request.
			self writeResponseSafely: response on: stream timing: timing.
			self logServerTransactionRequest: request response: response timing: timing.
			response useConnection: stream ].
	^ request wantsConnectionClose or: [ response wantsConnectionClose ]! !

!ZnMultiThreadedServer methodsFor: 'request handling' stamp: ''!
executeRequestResponseLoopOn: stream
	"Execute the HTTP request / response loop on stream one cycle at a time
	until the other end indicates it wants to stop or times out"

	ZnCurrentServer 
		value: self 
		during: [ 
			[ self executeOneRequestResponseOn: stream ] whileFalse ]! !

!ZnMultiThreadedServer methodsFor: 'private' stamp: ''!
readRequestBadExceptionSet
	"Return the set of exceptions which, when they occur while reading a request,
	are interpreted as equivalent to a request parse error or bad request."

	^ self
		exceptionSet:
			#(#ZnParseError #ZnCharacterEncodingError #ZnUnknownScheme #ZnPortNotANumber #ZnTooManyDictionaryEntries #ZnEntityTooLarge)! !

!ZnMultiThreadedServer methodsFor: 'private' stamp: ''!
writeResponseBad: exception on: stream timing: timing
	"When we failed to parse a request, write a bad request response before closing."

	| response |
	response := ZnResponse new
		statusLine: ZnStatusLine badRequest;
		headers: ZnHeaders defaultResponseHeaders;
		entity: (ZnEntity textCRLF: 'Bad Request ' , exception printString);
		yourself.
	response setConnectionClose.
	self writeResponseSafely: response on: stream timing: timing! !

!ZnMultiThreadedServer methodsFor: 'private' stamp: ''!
readRequestTerminationExceptionSet
	"Return the set of exceptions which, when they occur while reading a request,
	are interpreted as equivalent to a timeout or connection close."

	^ self
		exceptionSet:
			#(#ConnectionClosed #ConnectionTimedOut #PrimitiveFailed)! !

!ZnMultiThreadedServer methodsFor: 'private' stamp: ''!
closeSocketStream: socketStream
	[ socketStream close ] 
		on: Exception 
		do: [ ]! !

!ZnMultiThreadedServer methodsFor: 'request handling' stamp: ''!
serveConnectionsOn: listeningSocket
	"We wait up to acceptWaitTimeout seconds for an incoming connection.
	If we get one we wrap it in a SocketStream and #executeRequestResponseLoopOn: on it"
		 
	| stream socket |
	socket := listeningSocket waitForAcceptFor: self acceptWaitTimeout.
	socket ifNil: [ ^ self noteAcceptWaitTimedOut ].
	stream := self socketStreamOn: socket.
	[ [ [ self executeRequestResponseLoopOn: stream ]
		ensure: [ self logConnectionClosed: stream. self closeSocketStream: stream ] ]
			ifCurtailed: [ socket destroy ] ]
				forkAt: Processor lowIOPriority
				named: self workerProcessName ! !

!ZnMultiThreadedServer methodsFor: 'request handling' stamp: ''!
readRequestSafely: stream timing: timing
	"Read request from stream, returning nil when the connection is closed or times out"

	^ [ 
		[ self readRequest: stream timing: timing ]
			on: self readRequestBadExceptionSet
			do: [ :exception | 
				self logServerReadError: exception.
				self writeResponseBad: exception on: stream timing: timing.
				nil ] ]
			on: self readRequestTerminationExceptionSet
			do: [ :exception | 
				self logServerReadError: exception.
				nil ]! !

!ZnMultiThreadedServer methodsFor: 'request handling' stamp: ''!
writeResponseSafely: response on: stream timing: timing
	"Write response to stream, when the connection is closed or times out we ignore this"

	[ self writeResponse: response on: stream timing: timing ]
		on: self writeResponseTerminationExceptionSet
		do: [ :exception | self logServerWriteError: exception ]! !

!ZnMultiThreadedServer methodsFor: 'request handling' stamp: ''!
augmentResponse: response forRequest: request
	"Our handler has produced response for request, manipulate the response before writing it"

	super augmentResponse: response forRequest: request.
	response setKeepAliveFor: request.
	response setConnectionCloseFor: request! !

!ZnMultiThreadedServer methodsFor: 'private' stamp: ''!
exceptionSet: classNames
	^ classNames
		inject: ExceptionSet new
		into: [ :set :each |
			(Smalltalk includesKey: each)
				ifTrue: [ set add: (Smalltalk at: each); yourself ]
				ifFalse: [ set ] ]! !

!ZnMultiThreadedServer methodsFor: 'request handling' stamp: ''!
listenLoop
	"We create a listening Socket, then wait for a connection.
	After each connection we also check that the listening Socket is still valid 
	- if not we just make a recursive call to this method to start over."

	self initializeServerSocket.
	[ [ 
		serverSocket isValid 
			ifFalse: [
				"will trigger #ifCurtailed: block and destroy socket"
				^ self listenLoop ].
		self serveConnectionsOn: serverSocket ] repeat ]

		ifCurtailed: [ self releaseServerSocket ]! !

!ZnMultiValueDictionary commentStamp: ''!
I am ZnMultiValueDictionary. 
I am a Dictionary.

I offer an #at:add: method to transparently create Array valued multi entries when needed.
My #keysAndValuesDo: is overwritten to transparently deal with multi entries.
To merge two instance preserving multiple values you can use #addAllMulti:
I normally limit the number of entries to protect me from resource abuse.

Note that most other methods will show the actual value.

Part of Zinc HTTP Components.!
!ZnMultiValueDictionary methodsFor: 'adding' stamp: 'nil'!
add: anAssociation
	self checkLimitForKey: anAssociation key.
	^ super add: anAssociation! !

!ZnMultiValueDictionary methodsFor: 'accessing' stamp: 'nil'!
limit
	^ limit! !

!ZnMultiValueDictionary methodsFor: 'accessing' stamp: 'nil'!
at: key put: anObject
	self checkLimitForKey: key.
	^ super at: key put: anObject! !

!ZnMultiValueDictionary methodsFor: 'adding' stamp: 'nil'!
addAllMulti: keyedCollection
	"Note that we use #at:add:"

	keyedCollection keysAndValuesDo: [ :key :value | 
		self at: key add: value ]! !

!ZnMultiValueDictionary methodsFor: 'accessing' stamp: 'nil'!
at: key add: value
	"Store value under key. If key already exists, store multiple values as Array"
	
	| existingValue newValue |
	existingValue := self at: key ifAbsent: [ nil ].
	newValue := existingValue isNil
		ifTrue: [ value ] 
		ifFalse: [
			existingValue isArray 
				ifTrue: [ existingValue copyWith: value ]
				ifFalse: [ Array with: existingValue with: value ] ].
	^ self at: key put: newValue 

! !

!ZnMultiValueDictionary methodsFor: 'enumerating' stamp: 'nil'!
keysAndValuesDo: block
	"Execute a two argument (key, value) block for each header.
	Multi-valued headers are handled transparently."

	super keysAndValuesDo: [ :key :value |
		value isArray
			ifTrue: [ 
				value do: [ :each | 
					block value: key value: each ] ]
			ifFalse: [
				block value: key value: value ] ]! !

!ZnMultiValueDictionary methodsFor: 'initialize-release' stamp: 'nil'!
limit: numberOfEntries
	limit := numberOfEntries ! !

!ZnMultiValueDictionary methodsFor: 'initialize-release' stamp: 'nil'!
unlimited
	self limit: nil! !

!ZnMultiValueDictionary methodsFor: 'private' stamp: 'nil'!
checkLimitForKey: aKey
	"Signal an exception when the limit, if present, is exceeded."
	
	(self limit notNil and: [ self size >= self limit and: [ (self includesKey: aKey) not ]])
		ifTrue: [ (ZnTooManyDictionaryEntries limit: self limit) signal ].
! !

!ZnMultiValueDictionary methodsFor: 'initialize-release' stamp: 'nil'!
initialize: n
	super initialize: n.
	limit := self class defaultLimit! !

!ZnMultiValueDictionary class methodsFor: 'accessing' stamp: 'nil'!
defaultLimit
	"Return the maximum number dictionary entries to accept.
	Used by ZnMultiValueDictionary and thus for reading headers, 
	url query and application form url encoded entity fields.
	This helps to protect us from malicious content."
	
	^ ZnMaximumNumberOfDictionaryEntries value! !

!ZnMultiValueDictionaryTest methodsFor: 'testing' stamp: ''!
testTooManyEntries
	| dictionary |
	dictionary := ZnMultiValueDictionary new.
	self
		should: [ 1 to: dictionary limit + 1 do: [ :each | 
						dictionary at: each put: each ] ]
		raise: ZnTooManyDictionaryEntries! !

!ZnMultiValueDictionaryTest methodsFor: 'testing' stamp: ''!
testMultiValues
	| dictionary values keys |
	dictionary := ZnMultiValueDictionary new.
	dictionary
		at: 'foo' add: 1;
		at: 'foo' add: 2.
	self assert: (dictionary at: 'foo') equals: #(1 2).
	self assert: dictionary keys asArray equals: #('foo').
	values := OrderedCollection new.
	keys := OrderedCollection new.
	dictionary
		keysAndValuesDo: [ :key :value | 
			keys add: key.
			values add: value ].
	self assert: values equals: (OrderedCollection with: 1 with: 2).
	self assert: keys equals: (OrderedCollection with: 'foo' with: 'foo')! !

!ZnMultiValueDictionaryTest methodsFor: 'testing' stamp: ''!
testDynamicLimit
	ZnMaximumNumberOfDictionaryEntries
		value: 10
		during: [ 
			| dictionary |
			dictionary := ZnMultiValueDictionary new.
			self assert: dictionary limit equals: 10.
			1 to: 10 do: [ :each | dictionary at: each put: each ].
			self 
				should: [ dictionary at: 11 put: 11 ]
				raise: ZnTooManyDictionaryEntries ]! !

!ZnNetworkingUtils commentStamp: ''!
I am ZnNetworkingUtils holding various utilities related to HTTP networking.

My class side is a general API.

My instance side is a factory.

ZnNetworkingUtils default socketStreamClass: SocketStream.
ZnNetworkingUtils default socketStreamClass: ZdcSocketStream.

Part of Zinc HTTP Components.!
!ZnNetworkingUtils methodsFor: 'proxy' stamp: ''!
httpProxyUser
	"Return the user for proxy authorization"
	
	^ NetworkSystemSettings proxyUser! !

!ZnNetworkingUtils methodsFor: 'proxy' stamp: ''!
isProxyAuthorizationRequired
	"Does the proxy require authorization ?"
	
	^ self isProxySet and: [ NetworkSystemSettings useNetworkAuthentification ]! !

!ZnNetworkingUtils methodsFor: 'accessing' stamp: ''!
timeout
	^ self class socketStreamTimeout! !

!ZnNetworkingUtils methodsFor: 'proxy' stamp: ''!
httpProxyPort
	"Return the port of the proxy server to use"
	
	^ NetworkSystemSettings httpProxyPort! !

!ZnNetworkingUtils methodsFor: 'proxy' stamp: ''!
proxyAuthorizationHeaderValueToUrl: url
	"Answer the Proxy-Authorization header value for HTTP access to url, or nil if none"
	
	^ (self isProxyAuthorizationRequired and: [ self shouldProxyUrl: url ])
		ifTrue: [ 'Basic ', (ZnUtils encodeBase64: (self httpProxyUser, ':', self httpProxyPassword)) ] 
		ifFalse: [ nil ]  ! !

!ZnNetworkingUtils methodsFor: 'accessing' stamp: ''!
secureSocketStreamClass
	^ secureSocketStreamClass ifNil: [ 
		secureSocketStreamClass := Smalltalk globals at: #ZdcSecureSocketStream ifAbsent: [ nil ] ]! !

!ZnNetworkingUtils methodsFor: 'initialize-release' stamp: ''!
secureSocketStreamClass: anObject
	secureSocketStreamClass := anObject! !

!ZnNetworkingUtils methodsFor: 'initialize-release' stamp: ''!
socketStreamClass: anObject
	socketStreamClass := anObject! !

!ZnNetworkingUtils methodsFor: 'private' stamp: ''!
setSocketStreamParameters: stream
	stream 
		binary;
		shouldSignal: true;
		autoFlush: false;
		bufferSize: self bufferSize;
		timeout: self timeout.
! !

!ZnNetworkingUtils methodsFor: 'accessing' stamp: ''!
bufferSize
	^ self class socketBufferSize! !

!ZnNetworkingUtils methodsFor: 'public' stamp: ''!
socketStreamOn: socket
	| stream |
	stream := self socketStreamClass on: socket.
	self setSocketStreamParameters: stream.  
	^ stream! !

!ZnNetworkingUtils methodsFor: 'public' stamp: ''!
secureSocketStreamOn: socket
	| stream |
	stream := self secureSocketStreamClass on: socket.
	self setSocketStreamParameters: stream.  
	^ stream! !

!ZnNetworkingUtils methodsFor: 'public' stamp: ''!
socketStreamToUrl: url
	url hasHost ifFalse: [ ZnMissingHost signal ].  
	^ (self shouldProxyUrl: url)
		ifTrue: [ self socketStreamToProxy ] 
		ifFalse: [ self socketStreamToUrlDirectly: url ]! !

!ZnNetworkingUtils methodsFor: 'proxy' stamp: ''!
httpProxyPassword
	"Return the password for proxy authorization"
	
	^ NetworkSystemSettings proxyPassword ! !

!ZnNetworkingUtils methodsFor: 'private' stamp: ''!
setServerSocketOptions: socket
	socket
		setOption: 'TCP_NODELAY' value: 1;
		setOption: 'SO_SNDBUF' value: self class socketBufferSize;
		setOption: 'SO_RCVBUF' value: self class socketBufferSize ! !

!ZnNetworkingUtils methodsFor: 'proxy' stamp: ''!
isProxySet
	"Should a proxy be used ?"
	
	^ NetworkSystemSettings useHTTPProxy ! !

!ZnNetworkingUtils methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	self socketStreamClass: (Smalltalk globals at: #ZdcSocketStream ifAbsent: [ SocketStream ]).
	self secureSocketStreamClass: (Smalltalk globals at: #ZdcSecureSocketStream ifAbsent: [ nil ])! !

!ZnNetworkingUtils methodsFor: 'accessing' stamp: ''!
socketStreamClass
	^ socketStreamClass ifNil: [ socketStreamClass := SocketStream ]! !

!ZnNetworkingUtils methodsFor: 'proxy' stamp: ''!
socketStreamToProxy
	^ self socketStreamToUrlDirectly: self proxyUrl! !

!ZnNetworkingUtils methodsFor: 'accessing' stamp: ''!
streamClassForScheme: scheme
	(#(http ws) includes: scheme) ifTrue: [ 
		^ self socketStreamClass ].
	(#(https wss) includes: scheme) ifTrue: [ 
		^ self secureSocketStreamClass ifNil: [
			self error: 'No secure socket stream class set or available' ] ].
	(ZnUnknownScheme scheme: scheme) signal! !

!ZnNetworkingUtils methodsFor: 'proxy' stamp: ''!
proxyUrl
	"System settings do currently not support HTTPS proxies."

	^ ZnUrl new
		scheme: #http;
		host: self httpProxyServer;
		port: self httpProxyPort;
		yourself! !

!ZnNetworkingUtils methodsFor: 'proxy' stamp: ''!
shouldProxyUrl: url
	"Even when a proxy is set, some URLs should not be proxied.
	There is no setting for this in the image.
	We exclude localhost and explicit exceptions from being proxied."
	
	self isProxySet ifFalse: [ ^ false ].
	^ url isLocalHost not
		and: [ 
			[ (NetworkSystemSettings isAnExceptionFor: url) not ]
				on: MessageNotUnderstood
				do: [ true ] ]! !

!ZnNetworkingUtils methodsFor: 'public' stamp: ''!
serverSocketOn: port
	| socket |
	socket := Socket newTCP.
	self setServerSocketOptions: socket.
	socket listenOn: port backlogSize: self class listenBacklogSize.
	socket isValid
		ifFalse: [ self error: 'Cannot create socket on port ', port printString ].
	^ socket! !

!ZnNetworkingUtils methodsFor: 'public' stamp: ''!
socketStreamToUrlDirectly: url
	| stream address |
	address := NetNameResolver addressForName: url host timeout: self timeout. 
	stream := (self streamClassForScheme: url scheme) 
		openConnectionToHost: address
		port: url portOrDefault
		timeout: self timeout.  
	self setSocketStreamParameters: stream. 
	"note that for TLS/SSL, #connect should be called"
	^ stream! !

!ZnNetworkingUtils methodsFor: 'proxy' stamp: ''!
httpProxyServer
	"Return the hostname of the proxy server to use"
	
	^ NetworkSystemSettings httpProxyServer! !

!ZnNetworkingUtils methodsFor: 'public' stamp: ''!
serverSocketOn: port interface: address
	| socket |
	socket := Socket newTCP.
	self setServerSocketOptions: socket.
	socket 
		listenOn: port 
		backlogSize: self class listenBacklogSize 
		interface: address.
	socket isValid
		ifFalse: [ self error: 'Cannot create socket on port ', port printString ].
	^ socket! !

!ZnNetworkingUtils class methodsFor: 'class initialization' stamp: ''!
initialize
	"The default will try to use ZdcSocketStream and ZdcSecureSocketStream"
	 
	Default := self new.
	DefaultSocketStreamTimeout := 30! !

!ZnNetworkingUtils class methodsFor: 'constants' stamp: ''!
defaultSocketStreamTimeout: seconds
	"Global default timeout in seconds for SocketStream IO"
	
	^ DefaultSocketStreamTimeout := seconds! !

!ZnNetworkingUtils class methodsFor: 'constants' stamp: ''!
socketStreamTimeout
	"Access the current timeout in seconds for SocketStream IO"
	
	^ ZnConnectionTimeout value 
		ifNil: [ self defaultSocketStreamTimeout ]! !

!ZnNetworkingUtils class methodsFor: 'constants' stamp: ''!
socketBufferSize
	"Size in bytes for Sockets and SocketStream IO buffers"

	^ 4096! !

!ZnNetworkingUtils class methodsFor: 'proxy' stamp: ''!
proxyUrl
	"Answer the host:port URL the HTTP/S proxy"
	
	^ self default proxyUrl! !

!ZnNetworkingUtils class methodsFor: 'constants' stamp: ''!
defaultSocketStreamTimeout
	"Global default timeout in seconds for SocketStream IO"
	
	^ DefaultSocketStreamTimeout! !

!ZnNetworkingUtils class methodsFor: 'constants' stamp: ''!
listenBacklogSize
	"Server socket backlog size (number of pending connection waiting to be accepted)"
	
	^ 32! !

!ZnNetworkingUtils class methodsFor: 'proxy' stamp: ''!
shouldProxyUrl: url
	"Answer if we should proxy HTTP access to url."
	
	^ self default shouldProxyUrl: url  ! !

!ZnNetworkingUtils class methodsFor: 'proxy' stamp: ''!
proxyAuthorizationHeaderValueToUrl: url
	"Answer the Proxy-Authorization header value for HTTP access to url, or nil if none"
	
	^ self default proxyAuthorizationHeaderValueToUrl: url  ! !

!ZnNetworkingUtils class methodsFor: 'converting' stamp: ''!
ipAddressToString: byteArray
	^ String streamContents: [ :stream |
			byteArray 
				do: [ :each | stream print: each ] 
				separatedBy: [ stream nextPut: $. ] ]! !

!ZnNetworkingUtils class methodsFor: 'accessing' stamp: ''!
default
	^ Default ifNil: [ Default := self new ]! !

!ZnNetworkingUtils class methodsFor: 'networking' stamp: ''!
serverSocketOn: port
	^ self default 
		serverSocketOn: port  ! !

!ZnNetworkingUtils class methodsFor: 'networking' stamp: ''!
serverSocketOn: port interface: address
	^ self default 
		serverSocketOn: port interface: address ! !

!ZnNetworkingUtils class methodsFor: 'accessing' stamp: ''!
default: instance
	Default := instance ! !

!ZnNetworkingUtils class methodsFor: 'networking' stamp: ''!
socketStreamOn: socket
	^ self default 
		socketStreamOn: socket  ! !

!ZnNetworkingUtils class methodsFor: 'networking' stamp: ''!
secureSocketStreamOn: socket
	^ self default 
		secureSocketStreamOn: socket  ! !

!ZnNetworkingUtils class methodsFor: 'networking' stamp: ''!
socketStreamToUrl: url
	^ self default
		socketStreamToUrl: url  ! !

!ZnNewLineWriterStream commentStamp: ''!
I am a write stream wrapping a second stream. Whenever they ask me to write a cr, a lf, or a crlf I'll instead print a new line depending on a configured convention. By default I use the current platform convention. 

| stream converter |
stream := '' writeStream.
converter := ZnNewLineWriterStream on: stream.
converter cr; cr; lf; nextPut: $a.
stream contents

A ZnNewLineWriterStream can be configured with the desired line ending convention using the methods 

converter forCr.
converter forLf.
converter forCrLf.
converter forPlatformLineEnding.!
!ZnNewLineWriterStream methodsFor: 'accessing' stamp: ''!
stream: aWriteStream 
	stream := aWriteStream! !

!ZnNewLineWriterStream methodsFor: 'accessing' stamp: ''!
newLine
	previous := nil.
	stream nextPutAll: lineEnding! !

!ZnNewLineWriterStream methodsFor: 'accessing' stamp: ''!
nextPut: aCharacter
	"Write aCharacter to the receivers stream.
	Convert all line end combinations, i.e cr, lf, crlf, to the platform convention"

	(previous == cr and: [ aCharacter == lf ]) ifFalse: [
		(aCharacter == cr or: [ aCharacter == lf ]) ifTrue: 
			[ self newLine ]
		ifFalse:
			[ stream nextPut: aCharacter ] ].
	previous := aCharacter.
! !

!ZnNewLineWriterStream methodsFor: 'initialize' stamp: ''!
initialize

	super initialize.
	cr := Character cr.
	lf := Character lf.
	self forPlatformLineEnding.! !

!ZnNewLineWriterStream methodsFor: 'accessing' stamp: ''!
forCrLf

	lineEnding := String crlf! !

!ZnNewLineWriterStream methodsFor: 'open/close' stamp: ''!
close 

	^stream close! !

!ZnNewLineWriterStream methodsFor: 'flushing' stamp: ''!
flush
	^ stream flush! !

!ZnNewLineWriterStream methodsFor: 'accessing' stamp: ''!
forCr

	lineEnding := String cr! !

!ZnNewLineWriterStream methodsFor: 'accessing' stamp: ''!
forPlatformLineEnding

	lineEnding := OSPlatform current lineEnding! !

!ZnNewLineWriterStream methodsFor: 'accessing' stamp: ''!
forLf

	lineEnding := String lf! !

!ZnNewLineWriterStream class methodsFor: 'instance creation' stamp: ''!
on: aStream

	^ self basicNew
		initialize;
		stream: aStream;
		yourself! !

!ZnNewLineWriterStreamTest methodsFor: 'tests' stamp: ''!
testClose 

	| string fs fileReference znstream |

	fs := FileSystem memory.
	fileReference := fs / 'test.txt'.
	string := String streamContents: [ :stream |
		stream 
			<< 'abcčřž';
			cr ].
	znstream := ZnNewLineWriterStream on: fileReference writeStream.
	znstream forLf.
	[ znstream nextPutAll: string ]
		ensure: [ znstream close ].
	string at: string size put: Character lf.
	self assert: fileReference contents equals: string.! !

!ZnNewLineWriterStreamTest methodsFor: 'tests' stamp: ''!
testNextPut
	"Ensure that the line ends are written correctly"

	| expectedString stream crStream |

	expectedString := 'a', OSPlatform current lineEnding, 'b'.
	{ String cr.
		String lf.
		String crlf. } do: [ :lineEnd |
			stream := String new writeStream.
			crStream := ZnNewLineWriterStream on: stream.
			crStream
				<< 'a';
				<< lineEnd;
				<< 'b'.
			self assert: stream contents equals: expectedString ]! !

!ZnNullEncoder commentStamp: ''!
I am ZnNullEncoder, a concrete subclass of ZnCharacterEncoder.
I perform no encoding or decoding at all for all characters with a code value below 256.

Note that in principle I could handle Latin1 (ISO-8859-1) or ASCII, although that is not completely correct. To get maximum efficiency, it remains an option.
	
Part of Zinc HTTP Components.!
!ZnNullEncoder methodsFor: 'convenience' stamp: ''!
readInto: string startingAt: offset count: requestedCount fromStream: stream
	"Read requestedCount characters into string starting at offset,
	returning the number read, there could be less available when stream is atEnd"
	"Overwritten for performance reasons"

	offset to: offset + requestedCount - 1 do: [ :index |
		stream atEnd ifTrue: [ ^ index - offset ].  
		string byteAt: index put: stream next ].
	^ requestedCount! !

!ZnNullEncoder methodsFor: 'accessing' stamp: ''!
identifier
	^ #ascii! !

!ZnNullEncoder methodsFor: 'convenience' stamp: ''!
decodeBytes: bytes
	"Decode bytes and return the resulting string"
	"Overwritten for performance reasons"

	^ bytes asString! !

!ZnNullEncoder methodsFor: 'converting' stamp: ''!
backOnStream: stream
	"Move back one character on stream"

	stream back! !

!ZnNullEncoder methodsFor: 'converting' stamp: ''!
encodedByteCountFor: character
	"Return how many bytes are needed to encode character"
	"Overwritten for performance reasons"

	^ 1! !

!ZnNullEncoder methodsFor: 'convenience' stamp: ''!
encodeString: string
	"Encode string and return the resulting byte array"
	"Overwritten for performance reasons"

	^ string asByteArray! !

!ZnNullEncoder methodsFor: 'convenience' stamp: ''!
next: count putAll: string startingAt: offset toStream: stream
	"Write count bytes from string starting at offset to stream."
	"Overwritten for performance reasons"

	string isByteString
		ifTrue: [ 
			offset to: offset + count - 1 do: [ :index | 
				stream nextPut: (string byteAt: index) ] ]
		ifFalse: [ 
			super next: count putAll: string startingAt: offset toStream: stream ]! !

!ZnNullEncoder methodsFor: 'convenience' stamp: ''!
encodedByteCountForCodePoints: codePoints
	"Return the exact number of bytes it would take to encode codePoints as a byte array"
	"Overwritten for performance reasons"

	^ codePoints size! !

!ZnNullEncoder methodsFor: 'converting' stamp: ''!
encodedByteCountForCodePoint: codePoint
	"Return how many bytes are needed to encode integer code point"

	^ 1! !

!ZnNullEncoder methodsFor: 'converting' stamp: ''!
nextCodePointFromStream: stream
	"Read and return the next integer code point from stream"

	^ stream next! !

!ZnNullEncoder methodsFor: 'converting' stamp: ''!
nextPutCodePoint: codePoint toStream: stream
	"Write the encoding for Integer code point to stream"

	codePoint < 256
		ifTrue: [ stream nextPut: codePoint ]
		ifFalse: [ self errorOutsideRange ]! !

!ZnNullEncoder methodsFor: 'convenience' stamp: ''!
encodedByteCountForString: string
	"Return the exact number of bytes it would take to encode string as a byte array"
	"Overwritten for performance reasons"

	^ string size! !

!ZnNullEncoder class methodsFor: 'accessing' stamp: ''!
knownEncodingIdentifiers
	^ #( null )! !

!ZnNullEncoder class methodsFor: 'instance creation' stamp: ''!
newForEncoding: string
	"No further parametrization needed"
	
	^ self new! !

!ZnNullEncoder class methodsFor: 'accessing' stamp: ''!
handlesEncoding: string
	"Return true when my instances handle the encoding described by string.
	Note that in principle I could handle latin1 (iso-8859-1) and ASCII, 
	although that is not completely correct. 
	To get maximum efficiency, it remains an option."
	
	^ (self canonicalEncodingIdentifier: string) = 'null'! !

!ZnParseError commentStamp: ''!
ZnParseError is the superclass of all Zinc HTTP parsing related errors.

Part of Zinc HTTP Components.!
!ZnPercentEncoder commentStamp: ''!
I am ZnPercentEncoder.
I implement RFC 3986 percent encoding and decoding.

All characters that are not part of a safe set are encoded using a percent (%) followed by a two digit hexadecimal number of a byte value. Non-ASCII characters are first encoded, normally using UTF-8.

My #encode: and #decode: messages work from String to String.

My decoder will accept + as an encoding for a space by default.

See also http://en.wikipedia.org/wiki/Percent-encoding

Part of Zinc HTTP Components
!
!ZnPercentEncoder methodsFor: 'converting' stamp: ''!
decode: string
	"Decode a percent encoded string and return the resulting byte array.
	After percent decoding I will use my character encoder to convert byte values to characters."

	| bytes stringStream |
	stringStream := string readStream.
	bytes := ByteArray streamContents: [ :byteStream | 
		self decode: stringStream to: byteStream ].
	^ self characterEncoder decodeBytes: bytes! !

!ZnPercentEncoder methodsFor: 'converting' stamp: ''!
decode: stringStream to: byteStream
	| char |
	self decodePlusAsSpace.
	[ stringStream atEnd ]
		whileFalse: [ 
			((char := stringStream next) == $+ and: [ decodePlusAsSpace ])
				ifTrue: [ byteStream nextPut: 32 ]
				ifFalse: [ 
					char == $%
						ifTrue: [ byteStream nextPut: (self readHexFrom: stringStream) ]
						ifFalse: [ 
							char charCode < 128
								ifTrue: [ byteStream nextPut: char charCode ]
								ifFalse: [ self errorAsciiCharacterExpected ] ] ] ]! !

!ZnPercentEncoder methodsFor: 'converting' stamp: ''!
encode: readStream to: writeStream
	| bytes buffer byte |
	buffer := (bytes := ByteArray new: 4) writeStream.
	self safeSet; characterEncoder.
	[ readStream atEnd ]
		whileFalse: [ 
			buffer reset.
			characterEncoder nextPut: readStream next toStream: buffer.
			1 to: buffer position do: [ :index | 
				(safeSet includes: (byte := bytes at: index))
					ifTrue: [ writeStream nextPut: byte asCharacter ]
					ifFalse: [ 
						writeStream nextPut: $%.
						self writeHex: byte to: writeStream ] ] ]! !

!ZnPercentEncoder methodsFor: 'accessing' stamp: ''!
safeSet
	"Return the safe set of characters that I will not encode, as a byte array.
	If not set, I will default to the most commonly used safe set"
	
	^ safeSet ifNil: [ safeSet := self class rfc3986UnreservedCharacters asByteArray ]! !

!ZnPercentEncoder methodsFor: 'error handling' stamp: ''!
errorHexDigitExpected
	ZnCharacterEncodingError signal: 'hex digit expected'! !

!ZnPercentEncoder methodsFor: 'private' stamp: ''!
writeHex: integer to: stream
	integer printOn: stream base: 16 length: 2 padded: true! !

!ZnPercentEncoder methodsFor: 'initialize-release' stamp: ''!
safeSet: string
	"Set my safe set to be the characters in string, which I will convert to bytes"
	
	safeSet := string asByteArray ! !

!ZnPercentEncoder methodsFor: 'initialize-release' stamp: ''!
characterEncoder: object
	"Set the character encoding to use to object."
	
	characterEncoder := object! !

!ZnPercentEncoder methodsFor: 'accessing' stamp: ''!
decodePlusAsSpace
	"Return if $+ on input should be decoded as Character space.
	This is normally only done application/x-www-form-urlencoded data,
	but is is on by default anyway."
	
	^ decodePlusAsSpace ifNil: [ decodePlusAsSpace := true ]! !

!ZnPercentEncoder methodsFor: 'initialize-release' stamp: ''!
decodePlusAsSpace: boolean
	"When boolean is true, $+ on input will be decoded as Character space.
	Else $+ is treated as a normal character, filtered by the safe set.
	This is normally only done application/x-www-form-urlencoded data,
	but is is on by default anyway."
	
	decodePlusAsSpace := boolean! !

!ZnPercentEncoder methodsFor: 'converting' stamp: ''!
errorAsciiCharacterExpected
	ZnCharacterEncodingError signal: 'ASCII character expected'! !

!ZnPercentEncoder methodsFor: 'converting' stamp: ''!
encode: string
	"Encode string using percent encoding and return the resulting string.
	I will use my character encoder to convert string to bytes and then
	percent encode all byte values that are not in my safe set."

	^ String streamContents: [ :stream | 
		self encode: string readStream to: stream ]! !

!ZnPercentEncoder methodsFor: 'private' stamp: ''!
readHexFrom: stream
	| first second |
	(stream atEnd not and: [ (first := stream next digitValue) between: 0 and: 15 ])
		ifFalse: [ self errorHexDigitExpected ].
	(stream atEnd not and: [ (second := stream next digitValue) between: 0 and: 15 ])
		ifFalse: [ self errorHexDigitExpected ].
	^ (first << 4) + second! !

!ZnPercentEncoder methodsFor: 'accessing' stamp: ''!
characterEncoder
	"Return the character encoder that I currently use.
	If not set, I will default to using UTF-8."
	
	^ characterEncoder ifNil: [ characterEncoder := ZnDefaultCharacterEncoder value ]! !

!ZnPercentEncoder class methodsFor: 'accessing' stamp: ''!
rfc3986UnreservedCharacters
	"Return the unreserved characters according to RFC 3986 section 2.3.
	This is the most narrow safe set to be used in a better safe than sorry approach."

	^ 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_.~'! !

!ZnPercentEncoderTest methodsFor: 'testing' stamp: ''!
testStringUrlEncoded
	self assert: ('foo bar' urlEncoded) equals: 'foo%20bar'! !

!ZnPercentEncoderTest methodsFor: 'testing' stamp: ''!
testStringUrlDecoded
	self assert: ('foo%20bar' urlDecoded) equals: 'foo bar' ! !

!ZnPercentEncoderTest methodsFor: 'testing' stamp: ''!
testNonAscii
	| encoder |
	encoder := ZnPercentEncoder new.
	self 
		assert: encoder characterEncoder 
		equals: (ZnCharacterEncoder newForEncoding: 'utf-8').
	self 
		assert: (encoder encode: 'élève en Français') 
		equals: '%C3%A9l%C3%A8ve%20en%20Fran%C3%A7ais'.
	self 
		assert: (encoder decode: '%C3%A9l%C3%A8ve%20en%20Fran%C3%A7ais') 
		equals: 'élève en Français'! !

!ZnPercentEncoderTest methodsFor: 'testing' stamp: ''!
testDecodingErrors
	| encoder |
	encoder := ZnPercentEncoder new.
	self should: [ encoder decode: 'foo%%bar' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: 'fooçbar' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: 'foo%' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: '%XX' ] raise: ZnCharacterEncodingError.
	self should: [ encoder decode: 'foo%F' ] raise: ZnCharacterEncodingError! !

!ZnPercentEncoderTest methodsFor: 'testing' stamp: ''!
testDecodePlusAsSpace
	| encoder |
	encoder := ZnPercentEncoder new.
	self assert: (encoder decode: '+') equals: ' '.
	self assert: encoder decodePlusAsSpace.
	encoder decodePlusAsSpace: false.
	self assert: (encoder decode: '+') equals: '+'.
	self deny: encoder decodePlusAsSpace! !

!ZnPercentEncoderTest methodsFor: 'testing' stamp: ''!
testSimple
	| encoder |
	encoder := ZnPercentEncoder new.
	self assert: (encoder encode: 'foo bar') equals: 'foo%20bar'.
	self assert: (encoder decode: 'foo%20bar') equals: 'foo bar'.
	self assert: (encoder encode: '') equals: ''.
	self assert: (encoder decode: '') equals: ''.
	self assert: (encoder decode: 'foo%25bar') equals: 'foo%bar'.
	self assert: (encoder decode: 'foo+bar') equals: 'foo bar'! !

!ZnPercentEncoderTest methodsFor: 'testing' stamp: ''!
testLeadingZero

	| encoder |
	encoder := ZnPercentEncoder new.
	self
		assert: (encoder encode: 'foo' , String tab , 'bar')
		equals: 'foo%09bar'.
	self
		assert: (encoder decode: 'foo%09bar')
		equals: 'foo' , String tab , 'bar'.
	self
		assert: (encoder encode: 'foo' , Character lf asString , 'bar')
		equals: 'foo%0Abar'.
	self
		assert: (encoder decode: 'foo%0Abar')
		equals: 'foo' , Character lf asString , 'bar'! !

!ZnPortNotANumber commentStamp: ''!
ZnPortNotANumber is signalled when an URL is parsed containing an illegal port specification.

Part of Zinc HTTP Components.!
!ZnPortNotANumber methodsFor: 'accessing' stamp: 'nil'!
port: anObject
	port := anObject! !

!ZnPortNotANumber methodsFor: 'accessing' stamp: 'nil'!
port
	^ port! !

!ZnPortNotANumber class methodsFor: 'instance creation' stamp: 'nil'!
port: port
	^ self new
		port: port;
		yourself! !

!ZnPositionableReadStream commentStamp: ''!
I am ZnPositionableReadStream.
I am polymorphic with (the most used/important methods of) ReadStream and PositionableStream.

I wrap another read stream and store the elements that I read in a sliding circular buffer so that I am able to go back to any position inside that buffer. 

Essentially, I implement #position and #position: to be used to back out of reading ahead.

Note that the size of my buffer limits how far I can go backwards. A SubscriptOutOfBounds exception will be signalled when an attempt is made to go too far backwards.

The index returned by #position should be considered abstract, without concrete meaning, but it is currently implemented as the count of elements read by #next on the wrapped stream. On a simple stream over an in memory collection, that will be equivalent to an integer index into that collection. But on network streams or streams that were already further along, this will no longer be the case.

The most elementary example of my capabilities can be seen in my implementation of #peek. See also the unit tests #testPlainExcursion and #testSearch

Of course, backing out of an excursion is only possible within the window of the buffer size.

Implementation

- stream <ReadStream> the read stream that I wrap and add positioning to
- buffer <String|ByteArray> sliding, circular buffer
- index <PositiveInteger> zero based index into buffer, where next will be stored
- count <PositiveInteger> number of next operations done on wrapped stream
- delta <PositiveInteger> number of positions that I was moved backwards

The real core methods are #next, #atEnd, #position and #position: and are used to implement the rest.

Part of Zinc HTTP Components!
!ZnPositionableReadStream methodsFor: 'positioning' stamp: ''!
position
	"Return my current position. This is an object that can be used as argument to #position: to move back to that position. Although opaque, it is currently an integer count of the number of #next operations done on the stream that I wrap."
	
	^ count - delta! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
nextInto: collection
	"Read the next elements of the receiver into collection,
	returning a copy if less elements are available"
	
	^ self
		next: collection size
		into: collection! !

!ZnPositionableReadStream methodsFor: 'positioning' stamp: ''!
back
	"Go back one element and return it."

	self skip: -1.
	^ self peek! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
peek
	"Return the next element but do not move over it"
	
	^ self savingPositionDo: [ self next ]! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount 
	"Read requestedCount elements and return them as a collection.
	If less are available, a smaller collection will be returned."

	^ self 
		next: requestedCount 
		into: (self collectionSpecies new: requestedCount)! !

!ZnPositionableReadStream methodsFor: 'positioning' stamp: ''!
position: newPosition
	"Move my current position to newPosition, an object obtained by previously calling #position. My buffer size limits how far I can be positioned backwards. A SubscriptOutOfBounds exception will be signalled in case this operation cannot be completed. It is also no possible to go backwards unless data has been read previously."
	
	| newDelta |
	newDelta := count - newPosition.
	(newDelta between: 0 and: (buffer size min: count))
		ifFalse: [ 
			^ SubscriptOutOfBounds 
					signalFor: self 
					lowerBound: self position 
					upperBound: self position - (buffer size min: count) ].
	^ delta := newDelta! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
upToEnd
	"Read elements until the stream is atEnd and return them as a collection."

	^ self collectionSpecies
		streamContents: [ :collectionStream | 
			[ self atEnd ] whileFalse: [ collectionStream nextPut: self next ] ]! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection startingAt: offset
	"Read requestedCount elements into collection starting at offset,
	returning a copy if less elements are available"
	
	| read |
	read := self 
		readInto: collection 
		startingAt: offset 
		count: requestedCount.
	^ read = requestedCount 
		ifTrue: [ collection ]
		ifFalse: [ collection copyFrom: 1 to: offset + read - 1 ]     ! !

!ZnPositionableReadStream methodsFor: 'testing' stamp: ''!
isBinary
	"Return whether I am binary, whether my elements are byte values (8 bit integers between 0 and 255)"
	
	^ stream isBinary! !

!ZnPositionableReadStream methodsFor: 'initialize-release' stamp: ''!
sizeBuffer: size
	"Change the buffer size. This should be done when I am still in my initial state."
	
	buffer := self collectionSpecies new: size! !

!ZnPositionableReadStream methodsFor: 'initialize-release' stamp: ''!
close
	"Close me after which I can no longer be accessed. I delegate this to the stream that I wrap."
	
	stream close! !

!ZnPositionableReadStream methodsFor: 'testing' stamp: ''!
atEnd
	"Answer whether I can access any more objects."
	
	^ delta = 0 and: [ stream atEnd ]
		! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
bufferSize
	"Return the size of my buffer, which limits how far I can be positioned backwards. See #sizeBuffer: to set another buffer size."
	
	^ buffer size! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
next: requestedCount into: collection
	"Read requestedCount elements into collection,
	returning a copy if less elements are available"
	
	^ self 
		next: requestedCount 
		into: collection 
		startingAt: 1   ! !

!ZnPositionableReadStream methodsFor: 'positioning' stamp: ''!
savingPositionDo: block
	"Execute block so that any reading from me in it has no effect afterwards. I remember the current #position and move back to it using #position: after evaluating block. My buffer size limits how long the excursion can be. A SubscriptOutOfBounds exception will be signalled in case this operation cannot be completed."
	
	| savedPosition |
	savedPosition := self position.
	^ block ensure: [ self position: savedPosition ]! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
defaultBufferSize
	"Return the default size of my buffer, which limits how far I can be positioned backwards. See #sizeBuffer: to set another buffer size."
	
	^ 2 raisedToInteger: 8! !

!ZnPositionableReadStream methodsFor: 'initialize-release' stamp: ''!
initialize
	super initialize.
	count := index := delta := 0! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
next
	"Return the next element and move over it"
	
	| next |
	delta = 0
		ifTrue: [ 
			(next := stream next) ifNotNil: [ 
				count := count + 1.
				buffer at: index + 1 put: next.
				index := (index + 1) \\ buffer size ] ]
		ifFalse: [ 
			next := buffer at: ((index - delta) \\ buffer size) + 1.
			delta := delta - 1 ].
	^ next! !

!ZnPositionableReadStream methodsFor: 'instance creation' stamp: ''!
on: readStream
	"Initialize me on readStream"
	
	stream := readStream.
	self sizeBuffer: self defaultBufferSize! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
collectionSpecies
	"Return the collection class able to hold my elements"

	^ (stream respondsTo: #collectionSpecies)
		ifTrue: [ stream collectionSpecies ]
		ifFalse: [ stream isBinary
				ifTrue: [ ByteArray ]
				ifFalse: [ String ] ]! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
skip: integer
	"Skip over integer count elements."
	
	integer > 0
		ifTrue: [ integer timesRepeat: [ self next ] ]
		ifFalse: [ self position: (self position + integer) ]! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
peekFor: object
	"Answer false and do not move over the next element if it is not equal to object, or if the receiver is at the end. 
	Answer true and move over the next element when it is equal to object."

	^ self peek = object
		ifTrue: [ 
			self next.
			true ]
		ifFalse: [ false ]! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
upTo: value 
	"Read upto but not including value and return them as a collection.
	If value is not found, return the entire contents of the stream."
	
	^ self collectionSpecies 
		streamContents: [ :writeStream | | element |
			[ self atEnd or: [ (element := self next) = value ] ] whileFalse: [ 
				writeStream nextPut: element ] ]! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
readInto: collection startingAt: offset count: requestedCount
	"Read requestedCount elements into collection starting at offset,
	returning the number of elements read, there could be less elements available."

	0 to: requestedCount - 1 do: [ :aCount | | object |
		(object := self next) ifNil: [ ^ aCount ].  
		collection at: offset + aCount put: object ].
	^ requestedCount! !

!ZnPositionableReadStream methodsFor: 'accessing' stamp: ''!
wrappedStream
	"Return the read stream that I wrap."
	
	^ stream! !

!ZnPositionableReadStream class methodsFor: 'convenience' stamp: ''!
on: readStream do: block
	"Execute block with as argument a ZnPositionableReadStream on readStream.
	Return the value of block."

	^ block value: (self on: readStream)! !

!ZnPositionableReadStream class methodsFor: 'instance creation' stamp: ''!
on: readStream
	"Create an instance of ZnPositionableReadStream that wraps readStream to add limited positioning capabilities to it."
	
	^ self new
		on: readStream;
		yourself! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testPlainPeek
	| stream |
	stream := ZnPositionableReadStream on: 'abc' readStream.
	self assert: stream next equals: $a.
	self assert: stream peek equals: $b.
	self assert: stream next equals: $b.
	self assert: stream position equals: 2.
	self assert: stream peek equals: $c.
	self assert: stream next equals: $c.
	self assert: stream atEnd

! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testBulkReading
	| stream buffer |
	stream := ZnPositionableReadStream on: #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) readStream.
	buffer := Array new: 6.
	self assert: (stream readInto: buffer startingAt: 1 count: 6) equals: 6.
	self assert: buffer equals: #(0 1 2 3 4 5).
	self assert: (stream readInto: buffer startingAt: 4 count: 3) equals: 3.
	self assert: (stream readInto: buffer startingAt: 1 count: 3) equals: 3.
	self assert: buffer equals: #(9 10 11 6 7 8).
	buffer atAllPut: 0.
	self assert: (stream readInto: buffer startingAt: 1 count: 6) equals: 4.
	self assert: buffer equals: #(12 13 14 15 0 0)! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testSkipAndBack
	| stream |
	stream := ZnPositionableReadStream on: 'abcdef' readStream.
	stream skip: 2.
	self assert: stream next equals: $c.
	stream skip: 1.
	self assert: stream back equals: $d.
	self assert: stream back equals: $c.
	stream skip: -2.
	self assert: stream next equals: $a.
	stream back.
	self assert: stream upToEnd equals: 'abcdef'. 
! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testEmpty
	| stream |
	stream := ZnPositionableReadStream on: '' readStream.
	self assert: stream atEnd.
	self assert: stream peek isNil.
	self assert: stream next isNil.
	self assert: stream position isZero
! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testPlainNext
	| stream |
	stream := ZnPositionableReadStream on: 'abc' readStream.
	self assert: stream next equals: $a.
	self deny: stream atEnd.
	self assert: stream next equals: $b.
	self assert: stream position equals: 2.
	self assert: stream next equals: $c.
	self assert: stream atEnd

! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testPlainExcursion
	| stream |
	stream := ZnPositionableReadStream on: 'abcdef-----------' readStream.
	self assert: (stream next: 3) equals: 'abc'.
	self assert: (stream savingPositionDo: [ stream next: 3 ]) equals: 'def'.
	self assert: (stream next: 3) equals: 'def'
! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testReadAllLargerBuffer
	| data stream |
	data := String new: 500 streamContents: [ :out | 
		500 timesRepeat: [ out nextPut: 'abc' atRandom ] ].
	stream := ZnPositionableReadStream on: data readStream.
	stream sizeBuffer: 500.
	self deny: stream atEnd.
	self assert: stream position isZero.
	stream savingPositionDo: [
		self assert: stream upToEnd equals: data.
		self assert: stream atEnd.
		self assert: stream position equals: 500 ].
	self deny: stream atEnd.
	self assert: stream position isZero.
	self assert: stream upToEnd equals: data.
	self assert: stream atEnd.
	self assert: stream position equals: 500! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testSearchBinary
	| data stream pattern found |
	data := ByteArray new: 2000 streamContents: [ :out | 
		2000 timesRepeat: [ out nextPut: 256 atRandom - 1 ] ].
	pattern := ByteArray readHexFrom: 'FF77ABAB'.
	data replaceFrom: 1000 to: 1000 + pattern size - 1 with: pattern.
	stream := ZnPositionableReadStream on: data readStream.
	found := false.
	[ stream atEnd ] whileFalse: [ 
		stream savingPositionDo: [ 
			(stream next: pattern size) = pattern 
				ifTrue: [ 
					found := true.
					self assert: stream position equals: 1000 + pattern size - 1 ] ].
		stream next ].
	self assert: found! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testUTF8
	| data stream |
	data := 'Les élèves Françaises ont 100 €'.
	stream := ZnPositionableReadStream on: (ZnCharacterReadStream on: data utf8Encoded readStream).
	self assert: (stream next: 3) equals: 'Les'.
	stream skip: 1.
	stream savingPositionDo: [ 
		self assert: (stream next: 6) equals: 'élèves'.
		self assert: stream next equals: Character space ].
	self assert: (stream next: 6) equals: 'élèves'.
	self assert: (stream peekFor: Character space).
	2 timesRepeat: [ stream upTo: Character space ].
	self assert: (stream upTo: $€) trimBoth asNumber equals: 100.
	self assert: stream atEnd! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testNestedExcursion
	| stream |
	stream := ZnPositionableReadStream on: 'abcdef---XYZ!!1--------' readStream.
	self assert: (stream next: 3) equals: 'abc'.
	stream savingPositionDo: [ 
		self assert: (stream next: 3) equals: 'def'.
		stream savingPositionDo: [ 
			stream upTo: $!!.
			self assert: (stream peekFor: $1) ].
		stream skip: 3.
		self assert: (stream next: 3) equals: 'XYZ' ].
	self assert: (stream next: 3) equals: 'def'
! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testPositionErrors
	| data stream |
	data := ByteArray new: 1000 streamContents: [ :out | 
		100 timesRepeat: [ out nextPutAll: #[ 0 1 2 3 4 5 6 7 8 9 ] ] ].
	stream := ZnPositionableReadStream on: data readStream.
	self should: [ stream position: 1 ] raise: SubscriptOutOfBounds.
	stream next: 100.
	self should: [ stream position: -1 ] raise: SubscriptOutOfBounds.
	self should: [ stream position: 101 ] raise: SubscriptOutOfBounds.
	stream next: 500.
	self should: [ stream position: 100 ] raise: SubscriptOutOfBounds.
	self should: [ stream position: 600 - stream bufferSize - 1 ] raise: SubscriptOutOfBounds.
	stream position: 400.
	stream next: 599.
	self assert: stream next equals: 9.
	self assert: stream atEnd! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testReadAll
	| data stream |
	data := String new: 200 streamContents: [ :out | 
		200 timesRepeat: [ out nextPut: 'abc' atRandom ] ].
	stream := ZnPositionableReadStream on: data readStream.
	self deny: stream atEnd.
	self assert: stream position isZero.
	stream savingPositionDo: [
		self assert: stream upToEnd equals: data.
		self assert: stream atEnd.
		self assert: stream position equals: 200 ].
	self deny: stream atEnd.
	self assert: stream position isZero.
	self assert: stream upToEnd equals: data.
	self assert: stream atEnd.
	self assert: stream position equals: 200! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testNew
	| stream |
	stream := ZnPositionableReadStream on: 'abc' readStream.
	self assert: stream position isZero.
	self assert: stream bufferSize equals: stream defaultBufferSize.
	self deny: stream atEnd

! !

!ZnPositionableReadStreamTest methodsFor: 'testing' stamp: ''!
testSearch
	| data stream found |
	data := String new: 2000 streamContents: [ :out | 
		2000 timesRepeat: [ out nextPut: 'abc' atRandom ] ].
	data replaceFrom: 1000 to: 1005 with: 'TARGET'.
	stream := ZnPositionableReadStream on: data readStream.
	found := false.
	[ stream atEnd ] whileFalse: [ 
		stream savingPositionDo: [ 
			(stream next: 6) = 'TARGET' 
				ifTrue: [ 
					found := true.
					self assert: stream position equals: 1005 ] ].
		stream next ].
	self assert: found! !

!ZnReadEvalPrintDelegate commentStamp: ''!
I am ZnReadEvalPrintDelegate, I export a REPL Web Service.
You can use this service to work with a headless image.

	ZnReadEvalPrintDelegate startInServerOn: 1701.
	
	ZnClient new
		url: 'http://localhost:1701/repl';
		contents: '42 factorial';
		post.
	
Web Service API:

	POST /repl <some Smalltalk code>
	 
Here is an example terminal session:

$ curl http://localhost:1701/repl
# Pharo Smalltalk REPL. POST expressions to evaluate
# Here is one way (type ctrl-d to end input)
curl -X POST -H'Content-Type:text/plain' --data-binary @- http://localhost:1701/repl

$ curl -X POST -H'Content-Type:text/plain' -d '42 factorial' http://localhost:1701/repl
1405006117752879898543142606244511569936384000000000

$ curl -X POST -H'Content-Type:text/plain' --data-binary @- http://localhost:1701/repl
{ (1 to: 10) sum. (1 to: 10) average }
{55. (11/2)}

There is error handling as well:

$ curl -X POST -H'Content-Type:text/plain' --data-binary @- http://localhost:1701/repl
1 plus: 2
MessageNotUnderstood: SmallInteger>>plus:
SmallInteger(Object)>>doesNotUnderstand: #plus:
	Receiver: 1
	Arguments and temporary variables: 
		aMessage: 	plus: 2
		exception: 	MessageNotUnderstood: SmallInteger>>plus:
		resumeValue: 	nil
	Receiver's instance variables: 
1
UndefinedObject>>DoIt
Compiler>>evaluate:in:to:notifying:ifFail:logged:
Compiler>>evaluate:in:to:notifying:ifFail:
Compiler>>evaluate:in:to:
ZnReadEvalPrintDelegate>>evaluate: in Block: [| result |...
BlockClosure>>on:do:
ZnReadEvalPrintDelegate>>evaluate: in Block: [:out | [| result |...
String class(SequenceableCollection class)>>new:streamContents:

WARNING: never open this service beyond your local network !!
This service gives you absolute control over and access to everything in your image. 
For example, the following will kill your image:

$ curl -X POST -H'Content-Type:text/plain' -d 'Smalltalk quitPrimitive' http://localhost:1701/repl

Part of Zinc HTTP Components. !
!ZnReadEvalPrintDelegate methodsFor: 'public' stamp: ''!
value: request
	"I implement the generic #value: message as equivalent to #handleRequest:"
	
	^ self handleRequest: request! !

!ZnReadEvalPrintDelegate methodsFor: 'request handling' stamp: ''!
handleGetRequest: request
	^ ZnResponse ok: (ZnEntity text: (self helpText format: { request server port })) ! !

!ZnReadEvalPrintDelegate methodsFor: 'private' stamp: ''!
evaluate: string
	| output |
	output := String streamContents: [ :out | 
		[ 	| compiler result |
			compiler := [ self class compiler ] 
								on: MessageNotUnderstood 
								do: [ Smalltalk at: #Compiler "for Pharo 2.0" ].		
			result := compiler evaluate: string. 
			out print: result; cr ]
			on: Error
			do: [ :exception |
				out print: exception; cr.
				exception signalerContext printDetails: out.
				exception signalerContext sender debugStack: 8 on: out ].
		out cr ].
	^ String lf join: output lines! !

!ZnReadEvalPrintDelegate methodsFor: 'private' stamp: ''!
helpText
	^ '# Pharo Smalltalk REPL. POST expressions to evaluate\# Here is one way (type ctrl-d to end input)\curl -X POST -H''Content-Type:text/plain'' --data-binary @- http://localhost:{1}/repl\' 
			withCRs 
				replaceAll: Character cr with: Character lf; 
				yourself! !

!ZnReadEvalPrintDelegate methodsFor: 'request handling' stamp: ''!
handlePostRequest: request
	^ ZnResponse ok: (ZnEntity text: (self evaluate: request entity contents))! !

!ZnReadEvalPrintDelegate methodsFor: 'public' stamp: ''!
handleRequest: request
	request uri firstPathSegment = #repl
		ifTrue: [ 
			request method = #GET
				ifTrue: [ 
					^ self handleGetRequest: request ].
			(request method = #POST and: [ request hasEntity and: [ request contentType isBinary not ] ])
				ifTrue: [ 
					^ self handlePostRequest: request ] ].
	^ ZnResponse notFound: request uri! !

!ZnReadEvalPrintDelegate class methodsFor: 'public' stamp: ''!
startInServerOn: port
	"Start a new server bound to port on the local network running a REPL web service"

	"self startInServerOn: 1701"
	
	 ^ (ZnServer on: port)
			bindingAddress: NetNameResolver loopBackAddress;
			delegate: self new;
			start;
			yourself! !

!ZnRequest commentStamp: ''!
I am ZnRequest, representing an HTTP Request, 
consisting of a request line, headers and an optional entity (body).
I am a ZnMessage.
I can be used for generating and parsing.

Part of Zinc HTTP Components.!
!ZnRequest methodsFor: 'comparing' stamp: ''!
= other
	^ super = other and: [ self requestLine = other requestLine ]! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
session
	"Return the current server session.
	If necessary a new session is created.
	This only returns a value during #handleRequest:"

	^ super session
		ifNil: [ 
			| session |
			session := self server sessionFor: self.
			ZnCurrentServerSession value: session.
			session ]! !

!ZnRequest methodsFor: 'comparing' stamp: ''!
hash
	^ super hash bitXor: self requestLine hash! !

!ZnRequest methodsFor: 'testing' stamp: ''!
isHttp10
	^ self requestLine isHttp10 ! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
mergedFields
	"Return a new ZnMultiValueDictionary containing all query fields, if any,
	merged with all ZnApplicationFormUrlEncodedEntity fields, if any,
	preserving multi values for identical keys"

	| fields |
	fields := ZnMultiValueDictionary new.
	self uri hasQuery
		ifTrue: [ fields addAllMulti: self uri query ].
	(self contentType = ZnMimeType applicationFormUrlEncoded and: [ self hasEntity ])
		ifTrue: [ fields addAllMulti: self entity fields ].
	^ fields! !

!ZnRequest methodsFor: 'writing' stamp: ''!
writeOn: stream
	| bivalentWriteStream |
	bivalentWriteStream := ZnBivalentWriteStream on: stream.
	self requestLine writeOn: bivalentWriteStream.
	super writeOn: bivalentWriteStream! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
relativeUrl
	^ self url asRelativeUrl ! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
setBasicAuthenticationUsername: username password: password
	(username isNil | password isNil)
		ifTrue: [
			self headers removeKey: 'Authorization' ifAbsent: []]
		ifFalse: [
			self setAuthorization: 'Basic ', (ZnUtils encodeBase64: (username, ':', password)) ]
! !

!ZnRequest methodsFor: 'initialize-release' stamp: ''!
readHeaderFrom: stream
	self requestLine: (ZnRequestLine readFrom: stream).
	super readHeaderFrom: stream
	! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
requestLine: object
	requestLine := object! !

!ZnRequest methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(.
	self requestLine printMethodAndUriOn: stream.
	stream nextPut: $)! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
setAccept: object
	self headers at: 'Accept' put: object asString! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
url
	^ self uri ! !

!ZnRequest methodsFor: 'testing' stamp: ''!
wantsConnectionClose
	"Return if the HTTP protocol should close the connection after processing the receiver.
	Overwritten to return true in case of the presense of an explicit connection close request header
	or the absense of a keep alive header when using the old HTTP 1.0 protocol."

	^ self isConnectionClose 
		or: [ self isHttp10 and: [ self isConnectionKeepAlive not ] ]! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
absoluteUrl
	^ self host 
		ifNil: [ self url ]
		ifNotNil: [ :hostUrl | self url inContextOf: hostUrl ]! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
accept
	^ self headers at: 'Accept'! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
requestLine
	^ requestLine ! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
setAcceptEncodingGzip
	self headers at: 'Accept-Encoding' put: 'gzip'! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
setCookie: cookie
	self headers at: 'Cookie' put: cookie
! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
method
	^ self requestLine method ! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
host
	| host scheme |
	host := self headers at: 'Host' ifAbsent: [ ^ nil ].
	scheme :=ZnCurrentServer value ifNil: [ #http ] ifNotNil: [ :server | server scheme ].
	^ ZnUrl fromString: host defaultScheme: scheme! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
cookies
	| value cookies |
	value := self headers at: 'Cookie' ifAbsent: [ ^ #() ].
	cookies := value isString
		ifTrue: [ value findTokens: #($;) ]
		ifFalse: [ value ].
	^ cookies collect: [ :each | ZnCookie fromString: each ]! !

!ZnRequest methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	requestLine := requestLine copy! !

!ZnRequest methodsFor: 'testing' stamp: ''!
isHttp11
	^ self requestLine isHttp11! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
setIfModifiedSince: reference
	self headers at: 'If-Modified-Since' put: (ZnUtils httpDate: reference)! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
uri
	^ self requestLine uri ! !

!ZnRequest methodsFor: 'initialize-release' stamp: ''!
url: url
	self requestLine uri: url.
	self headers request: self url! !

!ZnRequest methodsFor: 'testing' stamp: ''!
acceptsEncodingGzip
	| value |
	value := self headers at: 'Accept-Encoding' ifAbsent: [ ^ false ].
	^ value includesSubstring: 'gzip'! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
basicAuthentication
	| authorization separator |
	authorization := self authorization findTokens: ' '.
	(authorization size = 2 and: [ authorization first = 'Basic' ])
		ifFalse: [ ^ NotFound signal: 'Incomplete Basic Authentication' ].
	authorization := ZnUtils decodeBase64: authorization second.
	separator := authorization 
		indexOf: $: 
		ifAbsent: [ ^ NotFound signal: 'Incomplete Basic Authentication' ].
	^ { authorization first: separator - 1. authorization allButFirst: separator }! !

!ZnRequest methodsFor: 'initialize-release' stamp: ''!
method: method
	self requestLine method: method! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
setAuthorization: authorization
	self headers at: 'Authorization'  put: authorization! !

!ZnRequest methodsFor: 'accessing' stamp: ''!
authorization
	^ self headers at: 'Authorization'! !

!ZnRequest class methodsFor: 'instance creation' stamp: ''!
patch: urlObject
	^ self method: #PATCH url: urlObject! !

!ZnRequest class methodsFor: 'instance creation' stamp: ''!
get: urlObject
	^ self method: #GET url: urlObject! !

!ZnRequest class methodsFor: 'instance creation' stamp: ''!
head: urlObject
	^ self method: #HEAD url: urlObject! !

!ZnRequest class methodsFor: 'instance creation' stamp: ''!
empty
	^ self new
		requestLine: ZnRequestLine empty;
		headers: ZnHeaders defaultRequestHeaders;
		yourself! !

!ZnRequest class methodsFor: 'instance creation' stamp: ''!
put: urlObject
	^ self method: #PUT url: urlObject! !

!ZnRequest class methodsFor: 'instance creation' stamp: ''!
method: method url: urlObject
	| url |
	url := urlObject asZnUrl.
	^ self new
		requestLine: (ZnRequestLine method: method uri: url);
		headers: (ZnHeaders requestHeadersFor: url);
		yourself! !

!ZnRequest class methodsFor: 'instance creation' stamp: ''!
delete: urlObject
	^ self method: #DELETE url: urlObject! !

!ZnRequest class methodsFor: 'instance creation' stamp: ''!
options: urlObject
	^ self method: #OPTIONS url: urlObject! !

!ZnRequest class methodsFor: 'instance creation' stamp: ''!
post: urlObject
	^ self method: #POST url: urlObject! !

!ZnRequestLine commentStamp: ''!
I am an HTTP Request Line.
I consist of an HTTP method, an URI and an HTTP protocol version.
I can be used for generating and parsing.

Part of Zinc HTTP Components.!
!ZnRequestLine methodsFor: 'comparing' stamp: ''!
= other
	self class = other class ifFalse: [ ^ false ].
	^ self method = other method
		and: [ self uri asRelativeUrl = other uri asRelativeUrl
			and: [ self version = other version ] ]! !

!ZnRequestLine methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!ZnRequestLine methodsFor: 'comparing' stamp: ''!
hash
	^ (self method hash bitXor: self uri hash) bitXor: self version hash! !

!ZnRequestLine methodsFor: 'testing' stamp: ''!
isHttp10
	^ self version = 'HTTP/1.0'! !

!ZnRequestLine methodsFor: 'writing' stamp: ''!
writeOn: stream
	| writeStream |
	writeStream := ZnBivalentWriteStream on: stream.
	writeStream nextPutAll: self method; space.
	(ZnNetworkingUtils shouldProxyUrl: self uri)
		ifTrue: [ 
			self uri hasSecureScheme 
				ifTrue: [
					"See also ZnClient>>#setupTLSTo:"
					method = #CONNECT
						ifTrue: [ writeStream nextPutAll: uri authorityWithPort ]
						ifFalse: [ self uri printPathQueryFragmentOn: writeStream ] ]
				ifFalse: [ self uri printOn: writeStream ] ]
		ifFalse: [ self uri printPathQueryFragmentOn: writeStream ].
	writeStream space; nextPutAll: self version; nextPutAll: String crlf ! !

!ZnRequestLine methodsFor: 'accessing' stamp: ''!
uri: anURI
	uri := anURI asZnUrl.
	uri enforceKnownScheme! !

!ZnRequestLine methodsFor: 'copying' stamp: ''!
postCopy
	uri := uri copy! !

!ZnRequestLine methodsFor: 'testing' stamp: ''!
isHttp11
	^ self version = 'HTTP/1.1'! !

!ZnRequestLine methodsFor: 'accessing' stamp: ''!
uri
	^ uri! !

!ZnRequestLine methodsFor: 'accessing' stamp: ''!
version: string
	version := ZnConstants knownHTTPVersions 
		detect: [ :each | each = string ] 
		ifNone: [ (ZnUnknownHttpVersion version: string) signal ] ! !

!ZnRequestLine methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	(self method notNil and: [ self uri notNil ])
		ifFalse: [ ^ self ].
	stream nextPut: $(.
	self printMethodAndUriOn: stream.
	stream nextPut: $)! !

!ZnRequestLine methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!ZnRequestLine methodsFor: 'accessing' stamp: ''!
method: string
	method := ZnConstants knownHTTPMethods 
		detect: [ :each | each = string ] 
		ifNone: [ (ZnUnknownHttpMethod method: string) signal ] ! !

!ZnRequestLine methodsFor: 'initialize-release' stamp: ''!
readFrom: stream
	| line lineStream |
	line := (ZnLineReader on: stream) nextLine.
	lineStream := line readStream.
	self method: (lineStream upTo: Character space).
	self uri: (lineStream upTo: Character space).
	self version: (lineStream upToEnd)! !

!ZnRequestLine methodsFor: 'printing' stamp: ''!
printMethodAndUriOn: stream
	(self method notNil and: [ self uri notNil ])
		ifFalse: [ ^ self ].
	stream
		nextPutAll: self method;
		space.
	self uri printPathQueryFragmentOn: stream! !

!ZnRequestLine methodsFor: 'accessing' stamp: ''!
uriPathQueryFragment
	^ String streamContents: [ :stream | 
			self uri printPathQueryFragmentOn: stream ]! !

!ZnRequestLine class methodsFor: 'instance creation' stamp: ''!
empty
	^ self new
		version: ZnConstants defaultHTTPVersion;
		yourself ! !

!ZnRequestLine class methodsFor: 'instance creation' stamp: ''!
readFrom: stream
	^ self new
		readFrom: stream;
		yourself! !

!ZnRequestLine class methodsFor: 'instance creation' stamp: ''!
method: method uri: uri
	^ self new
		method: method;
		uri: uri;
		version: ZnConstants defaultHTTPVersion;
		yourself ! !

!ZnRequestLineTest methodsFor: 'testing' stamp: ''!
testReading
	| requestLine string |
	string := 'GET /foo/bar/xyz.txt HTTP/1.1' , String crlf.
	requestLine := ZnRequestLine readFrom: string readStream.
	self assert: requestLine method equals: #GET.
	self assert: requestLine uriPathQueryFragment equals: '/foo/bar/xyz.txt'.
	self assert: requestLine version equals: ZnConstants defaultHTTPVersion! !

!ZnRequestLineTest methodsFor: 'testing' stamp: ''!
testReadingWrongVersion
	| string |
	string := 'GET /foo/bar/xyz.txt HTTP/1.5', String crlf.
	self should: [ ZnRequestLine readFrom: string readStream ] raise: ZnUnknownHttpVersion! !

!ZnRequestLineTest methodsFor: 'testing' stamp: ''!
testReadingWrongMethod
	| string |
	string := 'GETT /foo/bar/xyz.txt HTTP/1.1', String crlf.
	self should: [ ZnRequestLine readFrom: string readStream ] raise: ZnUnknownHttpMethod! !

!ZnRequestLineTest methodsFor: 'testing' stamp: ''!
testWriting
	| requestLine string |
	requestLine := ZnRequestLine method: 'GET' uri: '/foo/bar/xyz.txt'.
	string := String streamContents: [ :stream | requestLine writeOn: stream ].
	self assert: string equals: 'GET /foo/bar/xyz.txt HTTP/1.1' , String crlf! !

!ZnRequestReadEvent commentStamp: ''!
ZnRequestReadEvent is signalled when an HTTP server reads a request in duration milliseconds.

Note that the duration can be misleading: when servicing multiple requests over a kept alive connection (the default for HTTP 1.1), the read time includes any wait time (as long as it is below the timeout). The first request read should not contain wait time.!
!ZnRequestReadEvent methodsFor: 'accessing' stamp: ''!
duration: anObject
	duration := anObject! !

!ZnRequestReadEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Request Read '; print: request; space; print: duration; << 'ms'! !

!ZnRequestReadEvent methodsFor: 'accessing' stamp: ''!
duration
	^ duration! !

!ZnRequestReadEvent methodsFor: 'accessing' stamp: ''!
request
	^ request! !

!ZnRequestReadEvent methodsFor: 'accessing' stamp: ''!
request: anObject
	request := anObject! !

!ZnRequestResponseHandledEvent commentStamp: ''!
ZnRequestResponseHandledEvent signals that the handler (delegate) processed a request and produced a response in duration in milliseconds. This duration is thus the time taken by the application itself.!
!ZnRequestResponseHandledEvent methodsFor: 'accessing' stamp: ''!
duration: anObject
	duration := anObject! !

!ZnRequestResponseHandledEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Request Handled '; print: request; space; print: duration; << 'ms'! !

!ZnRequestResponseHandledEvent methodsFor: 'accessing' stamp: ''!
response: anObject
	response := anObject! !

!ZnRequestResponseHandledEvent methodsFor: 'accessing' stamp: ''!
duration
	^ duration! !

!ZnRequestResponseHandledEvent methodsFor: 'accessing' stamp: ''!
response
	^ response! !

!ZnRequestResponseHandledEvent methodsFor: 'accessing' stamp: ''!
request
	^ request! !

!ZnRequestResponseHandledEvent methodsFor: 'accessing' stamp: ''!
request: anObject
	request := anObject! !

!ZnRequestTest methodsFor: 'testing' stamp: ''!
testReading
	| input request |
	input := 'GET /foo.html HTTP/1.1' , String crlf , 'Host: foo.com' , String crlf , 'Agent: SUnit' , String crlf , String crlf.
	request := ZnRequest readFrom: input readStream.
	self assert: request method equals: #GET.
	self assert: request hasHeaders.
	self assert: (request headers at: 'Host') equals: 'foo.com'.
	self assert: request hasEntity not! !

!ZnRequestTest methodsFor: 'testing' stamp: ''!
testCookiesWriting
	| client testCookie1 testCookie2 cookies |
	client := ZnClient new.
	client url: 'http://www.example.com'.
	(testCookie1 := ZnCookie name: 'testCookie1' value: '123')
		domain: 'example.com'.
	(testCookie2 := ZnCookie name: 'testCookie2' value: '321')
		domain: 'example.com'.
	(client session cookieJar)
		add: testCookie1;
		add: testCookie2.
	client sendCookies.
	cookies := client request cookies do: [ :each | each defaultDomain: 'example.com' ].
	self assert: (cookies includes: testCookie1).
	self assert: (cookies includes: testCookie2)
	
		
! !

!ZnRequestTest methodsFor: 'testing' stamp: ''!
testBasicAuthenticate
	| request |
	request := ZnRequest new.
	request setBasicAuthenticationUsername: 'user' password: 'secret'.
	self assert: (request headers at: 'Authorization') equals: 'Basic dXNlcjpzZWNyZXQ='.
	self assert: request basicAuthentication asArray equals: #('user' 'secret').
	request setBasicAuthenticationUsername: 'user' password: ''.
	self assert: (request headers at: 'Authorization') equals: 'Basic dXNlcjo='.
	self assert: request basicAuthentication asArray equals: #('user' '').
	request setBasicAuthenticationUsername: 'user' password: ':colons:'.
	self assert: (request headers at: 'Authorization') equals: 'Basic dXNlcjo6Y29sb25zOg=='.
	self assert: request basicAuthentication asArray equals: #('user' ':colons:')! !

!ZnRequestTest methodsFor: 'testing' stamp: ''!
testMergedFields
	| request form mergedFields |
	request := ZnRequest post: 'http://host.com/foo?x=1&y=2&x=3'.
	form := ZnApplicationFormUrlEncodedEntity new.
	form
		at: #z put: '100';
		at: #z add: '200';
		at: #y put: '0'.
	request entity: form.
	mergedFields := request mergedFields.
	self assert: mergedFields keys sorted equals: #(x y z).
	self assert: (mergedFields at: #x) sorted equals: #('1' '3').
	self assert: (mergedFields at: #y) sorted equals: #('0' '2').
	self assert: (mergedFields at: #z) sorted equals: #('100' '200')! !

!ZnRequestTest methodsFor: 'testing' stamp: ''!
testUrl
	| url request input |
	url := 'http://zn.stfx.eu/zn/small.thml' asZnUrl.
	request := ZnRequest get: url.
	"The original URL is kept inside the request line object inside the request object"
	self assert: request url equals: url.
	self assert: request relativeUrl equals: url asRelativeUrl.
	self assert: request absoluteUrl equals: url.
	url := 'http://foo.com/foo.html' asZnUrl.
	input := 'GET /foo.html HTTP/1.1' , String crlf , 
		'Host: foo.com' , String crlf , 
		String crlf.
	request := ZnRequest readFrom: input readStream.
	self assert: request url equals: url asRelativeUrl.
	self assert: request relativeUrl equals: url asRelativeUrl.
	self assert: request absoluteUrl equals: url! !

!ZnRequestTest methodsFor: 'testing' stamp: ''!
testCookiesParsing
	| input request cookies testCookie1 testCookie2 |
	input := 'GET /foo.html HTTP/1.1' , String crlf , 'Cookie: testCookie1=123; testCookie2=321' , String crlf , 'Host: foo.com' , String crlf , 'Agent: SUnit'
		, String crlf , String crlf.
	request := ZnRequest readFrom: input readStream.

	cookies := request cookies.
	testCookie1 := cookies detect: [ :each | each name = 'testCookie1' ].
	testCookie2 := cookies detect: [ :each | each name = 'testCookie2' ].

	self assert: testCookie1 notNil.
	self assert: testCookie1 value equals: '123'.

	self assert: testCookie2 notNil.
	self assert: testCookie2 value equals: '321'! !

!ZnRequestTest methodsFor: 'testing' stamp: ''!
testReadingWithEntity
	| input request |
	input := 'GET /foo.html HTTP/1.1', String crlf, 
		'Host: foo.com', String crlf, 
		'Content-Length: 8', String crlf, 
		'Content-Type: text/plain', String crlf, 
		String crlf, 
		'12345678'.
	request := ZnRequest readFrom: input asByteArray readStream.
	self assert: request method equals: #GET.
	self assert: request hasHeaders.
	self assert: (request contentType matches: ZnMimeType textPlain).
	self assert: request contentLength equals: 8.
	self assert: request hasHeaders.
	self assert: request entity contents equals: '12345678'
! !

!ZnRequestWrittenEvent commentStamp: ''!
ZnRequestWrittenEvent signals that a request was written in duration milliseconds.!
!ZnRequestWrittenEvent methodsFor: 'accessing' stamp: ''!
duration: anObject
	duration := anObject! !

!ZnRequestWrittenEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Request Written '; print: request; space; print: duration; << 'ms'! !

!ZnRequestWrittenEvent methodsFor: 'accessing' stamp: ''!
duration
	^ duration! !

!ZnRequestWrittenEvent methodsFor: 'accessing' stamp: ''!
request
	^ request! !

!ZnRequestWrittenEvent methodsFor: 'accessing' stamp: ''!
request: anObject
	request := anObject! !

!ZnResourceMetaUtils commentStamp: ''!
I am ZnResourceMetaUtils.

I contain some class side utility methods.

Part of Zinc HTTP Components.!
!ZnResourceMetaUtils class methodsFor: 'converting' stamp: 'nil'!
parseQueryFrom: stream
	| string index fields |
	fields := ZnMultiValueDictionary new.
	[ stream atEnd ] whileFalse: [
		string := stream upTo: $&.
		index := string indexOf: $=.
		index > 0
			ifFalse: [ fields at: (self decodePercentForQuery: string) put: nil ]
			ifTrue: [
				fields
					at: (self decodePercentForQuery: (string copyFrom: 1 to: index - 1))
					add: (self decodePercentForQuery: (string copyFrom: index + 1 to: string size)) ] ].
	^ fields! !

!ZnResourceMetaUtils class methodsFor: 'accessing' stamp: 'nil'!
querySafeSet
	^ 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_.~!!$&''()*+,;=:@/?'! !

!ZnResourceMetaUtils class methodsFor: 'accessing' stamp: 'nil'!
queryKeyValueSafeSet
	"When a query is interpreted as a list of key=value&.. pairs,
	it is better to encode = and & and leave them out of the safe set.
	Furthermore, since + is interpreted as space in the query part,
	it is unsafe as well"
	
	^ 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_.~!!$''()*,;:@/?'! !

!ZnResourceMetaUtils class methodsFor: 'accessing' stamp: 'nil'!
rfc3986SafeSet
	^ ZnPercentEncoder rfc3986UnreservedCharacters ! !

!ZnResourceMetaUtils class methodsFor: 'converting' stamp: 'nil'!
writeQueryFields: dictionary on: stream
	self writeQueryFields: dictionary withEncoder: ZnCharacterEncoder utf8 on: stream ! !

!ZnResourceMetaUtils class methodsFor: 'converting' stamp: 'nil'!
decodePercentForQuery: string
	^ ZnPercentEncoder new 
		decodePlusAsSpace: true; 
		decode: string! !

!ZnResourceMetaUtils class methodsFor: 'converting' stamp: 'nil'!
encodePercent: string safeSet: safeSet encoder: encoder
	^ ZnPercentEncoder new
		characterEncoder: encoder;
		safeSet: (self perform: safeSet);
		encode: string! !

!ZnResourceMetaUtils class methodsFor: 'converting' stamp: 'nil'!
decodePercent: string
	^ ZnPercentEncoder new 
		decodePlusAsSpace: false; 
		decode: string! !

!ZnResourceMetaUtils class methodsFor: 'accessing' stamp: 'nil'!
urlPathSafeSet
	^ 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_.~!!$&''()*+,;=:@'! !

!ZnResourceMetaUtils class methodsFor: 'converting' stamp: 'nil'!
writeQueryFields: dictionary withEncoder: encoder on: stream
	| first |
	first := true.
	dictionary keysAndValuesDo: [ :key :value | 
		first ifFalse: [ stream nextPut: $& ].
		first := false.
		stream nextPutAll: (self encodePercent: key safeSet: #queryKeyValueSafeSet encoder: encoder).
		value ifNotNil: [ 
			stream
				nextPut: $=;
				nextPutAll: (self encodePercent: value safeSet: #queryKeyValueSafeSet encoder: encoder) ] ]! !

!ZnResourceMetaUtilsTest methodsFor: 'testing' stamp: ''!
testQueryParsing
	| string fields |
	string := 'foo=100&x=' , (ZnPercentEncoder new encode: '/a b').
	fields := ZnResourceMetaUtils parseQueryFrom: string readStream.
	self assert: (fields at: 'foo') equals: '100'.
	self assert: (fields at: 'x') equals: '/a b'! !

!ZnResourceMetaUtilsTest methodsFor: 'testing' stamp: ''!
testDecodePercent
	self assert: (ZnResourceMetaUtils decodePercent: 'foo%20bar') equals: 'foo bar'.
	self should: [ ZnResourceMetaUtils decodePercent: 'foo%%bar' ] raise: ZnCharacterEncodingError ! !

!ZnResourceMetaUtilsTest methodsFor: 'testing' stamp: ''!
testQueryWriting
	| fields string |
	(fields := Dictionary new)
		at: 'foo' put: '100';
		at: 'bar' put: 'a b'.
	string := String streamContents: [ :stream | 
		ZnResourceMetaUtils writeQueryFields: fields on: stream ].
	self assert: (string includesSubstring: 'foo=1').
	self assert: (string includesSubstring: 'bar=a%20b').! !

!ZnRespond commentStamp: ''!
I am ZnRespond, a Notification to signal the end of #handleRequest: processing with a specific ZnResponse, earlier than normal stack unwinding.

  ZnRespond signalWith: ZnResponse unauthorized

Normal #handleRequest: processing in a ZnServer delegate takes a ZnRequest object as input argument and needs to produce a ZnResponse as output, returning it as a regular result. Sometimes you do not want to keep managing this single result with many levels of condition on a complex or deep stack, but instead directly want to return a response: that is when you can use the ZnRespond notification.!
!ZnRespond methodsFor: 'accessing' stamp: ''!
response: anObject
	response := anObject! !

!ZnRespond methodsFor: 'accessing' stamp: ''!
response
	^ response! !

!ZnRespond class methodsFor: 'instance creation' stamp: ''!
signalWith: response
	^ self new
		response: response;
		signal! !

!ZnResponse commentStamp: ''!
I am ZnResponse, representing an HTTP Response 
consisting of a status line, headers and an optional entity (body).
I am a ZnMessage.
I can be used for generating and parsing.

Part of Zinc HTTP Components.!
!ZnResponse methodsFor: 'accessing' stamp: ''!
setLocation: uriString
	self headers at: 'Location' put: uriString! !

!ZnResponse methodsFor: 'comparing' stamp: ''!
= other
	^ super = other and: [ self statusLine = other statusLine ]! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
statusLine: object
	statusLine := object! !

!ZnResponse methodsFor: 'comparing' stamp: ''!
hash
	^ super hash bitXor: self status hash! !

!ZnResponse methodsFor: 'initialize-release' stamp: ''!
readEntityFrom: stream
	(self isInformational or: [ self isNoContent or: [ self isNotModified ] ])
		ifFalse: [ super readEntityFrom: stream ]! !

!ZnResponse methodsFor: 'testing' stamp: ''!
isBadRequest
	^ self code = 400! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
location
	^ self headers at: 'Location'! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
statusLine
	^ statusLine! !

!ZnResponse methodsFor: 'writing' stamp: ''!
writeOn: stream
	| bivalentWriteStream |
	bivalentWriteStream := ZnBivalentWriteStream on: stream.
	self statusLine writeOn: bivalentWriteStream.
	super writeOn: bivalentWriteStream! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
wwwAuthenticate
	^ self headers at: 'WWW-Authenticate'! !

!ZnResponse methodsFor: 'initialize-release' stamp: ''!
readHeaderFrom: stream
	self statusLine: (ZnStatusLine readFrom: stream).
	super readHeaderFrom: stream
	! !

!ZnResponse methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(.
	self statusLine printCodeAndReasonOn: stream.
	self hasEntity ifTrue: [ 
		stream space.
		self entity printContentTypeAndLengthOn: stream ].
	stream nextPut: $)
	! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
setTransferEncodingChunked
	self headers 
		at: 'Transfer-Encoding' put: 'chunked';
		clearContentLength! !

!ZnResponse methodsFor: 'testing' stamp: ''!
isCreated
	^ self code = 201! !

!ZnResponse methodsFor: 'testing' stamp: ''!
hasContentEncoding
	^ self headers includesKey: 'Content-Encoding'! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
status
	^ self statusLine code! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
setContentEncodingGzip
	self headers at: 'Content-Encoding' put: 'gzip'! !

!ZnResponse methodsFor: 'testing' stamp: ''!
isNotFound
	^ self code = 404 ! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
setKeepAliveFor: request
	(request isHttp10 and: [ request isConnectionKeepAlive ])
		ifTrue: [ self setConnectionKeepAlive ]
	! !

!ZnResponse methodsFor: 'testing' stamp: ''!
isInformational
	^ self code between: 100 and: 199! !

!ZnResponse methodsFor: 'testing' stamp: ''!
hasTransferEncoding
	^ self headers includesKey: 'Transfer-Encoding'! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
code
	^ self statusLine code! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
setConnectionCloseFor: request
	request wantsConnectionClose 
		ifTrue: [ self setConnectionClose ]! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
cookies
	| value cookies |
	value := self headers at: 'Set-Cookie' ifAbsent: [ ^ #() ].
	cookies := value isString
		ifTrue: [ Array with: value ]
		ifFalse: [ value ].
	^ cookies collect: [ :each | ZnCookie fromString: each ]! !

!ZnResponse methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	statusLine := statusLine copy! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
addCookie: cookie
	self headers at: 'Set-Cookie' add: cookie fullString
! !

!ZnResponse methodsFor: 'private' stamp: ''!
entityReaderOn: stream
	"Reading undefined content is allowed for responses"
	
	^ (super entityReaderOn: stream)  
		allowReadingUpToEnd;
		yourself! !

!ZnResponse methodsFor: 'testing' stamp: ''!
isAuthenticationRequired
	^ self code = 401 ! !

!ZnResponse methodsFor: 'testing' stamp: ''!
isSuccess
	^ #(200 201 202 204) includes: self code! !

!ZnResponse methodsFor: 'testing' stamp: ''!
isError
	^self code > 399! !

!ZnResponse methodsFor: 'testing' stamp: ''!
isNoContent
	^ self code = 204! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
useConnection: connection
	"Hook method that can be overwritten to give subclasses the chance to 
	keep using connection in the current thread/process after the server wrote the response"! !

!ZnResponse methodsFor: 'testing' stamp: ''!
isNotModified
	^ self code = 304! !

!ZnResponse methodsFor: 'accessing' stamp: ''!
setWWWAuthenticate: string
	self headers at: 'WWW-Authenticate' put: string! !

!ZnResponse methodsFor: 'testing' stamp: ''!
isRedirect
	^ #(301 302 303 307) includes: self code! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
serverErrorWithEntity: entity
	^ (self statusLine: ZnStatusLine internalServerError)
		entity: entity;
		yourself! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
notModified
	^ self statusLine: ZnStatusLine notModified! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
statusCode: httpResponeCode
	^ self statusLine: (ZnStatusLine code: httpResponeCode)! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
unauthorized: authString
	^ self
		unauthorized: authString
		entity: (ZnEntity textCRLF: 'Unauthorized')! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
notFound: url
	^ self
		notFound: url
		entity: (ZnEntity textCRLF: 'Not Found ' , url asZnUrl pathQueryFragmentPrintString)! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
redirect: url entity: entity
	^ (self statusLine: ZnStatusLine redirect)
		setLocation: url asString;
		entity: entity;
		yourself! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
statusLine: statusLine
	^ self new
		statusLine: statusLine;
		headers: ZnHeaders defaultResponseHeaders;
		yourself! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
badRequest: request entity: entity
	^ (self statusLine: ZnStatusLine badRequest)
		entity: entity;
		yourself! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
serverError: string
	^ self serverErrorWithEntity: (ZnEntity textCRLF: string)! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
created: url
	^ self 
		created: url 
		entity: (ZnEntity textCRLF: 'Created ' , url asString)! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
created: url entity: entity
	^ (self statusLine: ZnStatusLine created)
		setLocation: url asString;
		entity: entity;
		yourself! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
redirect: url
	^ self
		redirect: url
		entity: (ZnEntity textCRLF: 'Redirect ' , url asString)! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
badRequest: request
	| message |
	message := String streamContents: [ :out |
		out << 'Bad Request '; << request method; space.
		request uri printPathQueryFragmentOn: out ].
	^ self 
		badRequest: request 
		entity: (ZnEntity textCRLF: message)! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
unauthorized: authString entity: entity
	^ (self statusLine: ZnStatusLine unauthorized)
		setWWWAuthenticate: authString;
		entity: entity;
		yourself! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
accepted
	^ self statusLine: ZnStatusLine accepted! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
noContent
	^ self statusLine: ZnStatusLine noContent! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
unauthorized
	^ self unauthorized: 'Basic realm=ZincHTTPComponents'! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
methodNotAllowed: request entity: entity
	^ (self statusLine: ZnStatusLine methodNotAllowed)
		entity: entity;
		yourself! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
methodNotAllowed: request
	| message |
	message := String streamContents: [ :out |
		out << 'Method Not Allowed '; << request method; space.
		request uri printPathQueryFragmentOn: out ].
	^ self 
		methodNotAllowed: request
		entity: (ZnEntity textCRLF: message)! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
ok: entity
	^ (self statusLine: ZnStatusLine ok)
		entity: entity;
		yourself! !

!ZnResponse class methodsFor: 'instance creation' stamp: ''!
notFound: url entity: entity
	^ (self statusLine: ZnStatusLine notFound)
		entity: entity;
		yourself! !

!ZnResponseReadEvent commentStamp: ''!
ZnResponseReadEvent signals that a response was read in duration milliseconds. This time includes all waiting, server processing and networking.!
!ZnResponseReadEvent methodsFor: 'accessing' stamp: ''!
duration: anObject
	duration := anObject! !

!ZnResponseReadEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Response Read '; print: response; space; print: duration; << 'ms'! !

!ZnResponseReadEvent methodsFor: 'accessing' stamp: ''!
response: anObject
	response := anObject! !

!ZnResponseReadEvent methodsFor: 'accessing' stamp: ''!
duration
	^ duration! !

!ZnResponseReadEvent methodsFor: 'accessing' stamp: ''!
response
	^ response! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testAbsoluteCreated
	| response uri |
	uri := 'http://www.example.com:8888/something/else/foo.txt'.
	response := ZnResponse created: uri asZnUrl.
	self assert: response code equals: 201.
	self assert: response hasHeaders.
	self assert: (response headers at: 'Location') equals: uri.
	self assert: response hasEntity.
	self assert: (response entity contents includesSubstring: uri)! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testIsError
	| response |
	response := ZnResponse ok: (ZnStringEntity html: '<h1>hello world</h1>').
	self assert: response isError not.
	response := ZnResponse notFound: 'http:///secret.txt'.
	self assert: response isError.
	response := ZnResponse redirect: '/something/else/foo.txt'.
	self assert: response isError not! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testRedirect
	| response uri |
	uri := '/something/else/foo.txt'.
	response := ZnResponse redirect: uri.
	self assert: response code equals: 302.
	self assert: response code equals: 302.
	self assert: response hasHeaders.
	self assert: (response headers at: 'Location') equals: uri.
	self assert: response hasEntity.
	self assert: (response entity contents includesSubstring: uri).
	response := ZnResponse redirect: uri asZnUrl.
	self assert: response code equals: 302.
	self assert: response code equals: 302.
	self assert: response hasHeaders.
	self assert: (response headers at: 'Location') equals: uri.
	self assert: response hasEntity.
	self assert: (response entity contents includesSubstring: uri)! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testCreated
	| response uri |
	uri := '/something/else/foo.txt'.
	response := ZnResponse created: uri.
	self assert: response code equals: 201.
	self assert: response hasHeaders.
	self assert: (response headers at: 'Location') equals: uri.
	self assert: response hasEntity.
	self assert: (response entity contents includesSubstring: uri)! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testWritingCharacter
	| response string |
	response := ZnResponse ok: (ZnEntity text: 'Okay').
	string := String streamContents: [ :stream | response writeOn: stream ].
	self assert: (string includesSubstring: '200 OK').
	self assert: (string includesSubstring: 'Okay')! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testDefaultUTF8Encoding
	| json entity response bytes result |
	"Even if we do not specificy UTF-8 explicitly, it should be the default"
	json := '{''bank'':''Région Genève Rhône''}'.
	entity := ZnEntity with: json type: 'application/json'.
	response := ZnResponse ok: entity.
	bytes := ByteArray streamContents: [ :out | response writeOn: out ].
	result := ZnResponse readFrom: bytes readStream.
	self assert: result entity contents equals: json! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testAbsoluteRedirect
	| response uri |
	uri := 'http://foo.com:8080/something/else/foo.txt?key=123'.
	response := ZnResponse redirect: uri asZnUrl.
	self assert: response code equals: 302.
	self assert: response isRedirect.
	self assert: response hasHeaders.
	self assert: (response headers at: 'Location') equals: uri.
	self assert: response hasEntity.
	self assert: (response entity contents includesSubstring: uri)! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testNotFound
	| response |
	response := ZnResponse notFound: 'http:///secret.txt'.
	self assert: response code equals: 404.
	self assert: (response headers includesKey: 'Server').
	self assert: (response headers includesKey: 'Date').
	self assert: (response entity contents includesSubstring: 'secret.txt')! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testCookies
	| response cookie1 cookie2 responseString |
	response := ZnResponse ok: (ZnStringEntity html: '<h1>hello world</h1>').
	cookie1 := ZnCookie new.
	cookie1 
		name: 'testCookie1';
		value: '123'.
		
	cookie2 := ZnCookie new.
	cookie2 
		name: 'testCookie2';
		value: '321'.
		
	response addCookie: cookie1.
	response addCookie: cookie2.
	
	responseString := String streamContents: [ :stream | response writeOn: stream ].
	
	self assert: (responseString includesSubstring: 'Set-Cookie: testCookie1=123').  
	self assert: (responseString includesSubstring: 'Set-Cookie: testCookie2=321').  	

	
		
		
! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testWritingBinary
	| response bytes string |
	response := ZnResponse ok: (ZnEntity text: 'Okay').
	bytes := ByteArray streamContents: [ :stream | response writeOn: stream ].
	string := bytes asString.
	self assert: (string includesSubstring: '200 OK').
	self assert: (string includesSubstring: 'Okay')! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testCookie
	| response cookie1  responseString |
	response := ZnResponse ok: (ZnStringEntity html: '<h1>hello world</h1>').
	cookie1 := ZnCookie new.
	cookie1 
		name: 'testCookie1';
		value: '123'.
		
	response addCookie: cookie1.
	
	responseString := String streamContents: [ :stream | response writeOn: stream ].
	
	self assert: (responseString includesSubstring: 'Set-Cookie: testCookie1=123')	

	
		
		
! !

!ZnResponseTest methodsFor: 'testing' stamp: ''!
testSlashdotGzipChunked
	| request stream response contents |
	(request := ZnRequest get: 'http://slashdot.org')
		setConnectionClose;
		setAcceptEncodingGzip.
	stream := ZnNetworkingUtils socketStreamToUrl: request url.
	response := [ request writeOn: stream.
	stream flush.
	ZnDefaultCharacterEncoder value: ZnNullEncoder new during: [ ZnResponse readFrom: stream ] ]
		ensure: [ stream close ].
	response isRedirect ifTrue: [ ^ self ].
	self assert: response code equals: 200.
	self assert: ((response headers at: 'Content-Type') beginsWith: 'text/html').
	self assert: (response headers at: 'Content-Encoding' ifAbsent: [ 'gzip' ]) equals: 'gzip'.
	self assert: (response headers at: 'Transfer-Encoding' ifAbsent: [ 'chunked' ]) equals: 'chunked'.
	contents := response entity contents.
	self assert: ((contents includesSubstring: 'Slashdot') or: [ contents includesSubstring: 'refresh' ])! !

!ZnResponseWrittenEvent commentStamp: ''!
ZnResponseWrittenEvent signals that response was written in duration milliseconds.!
!ZnResponseWrittenEvent methodsFor: 'accessing' stamp: ''!
duration: anObject
	duration := anObject! !

!ZnResponseWrittenEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Response Written '; print: response; space; print: duration; << 'ms'! !

!ZnResponseWrittenEvent methodsFor: 'accessing' stamp: ''!
response: anObject
	response := anObject! !

!ZnResponseWrittenEvent methodsFor: 'accessing' stamp: ''!
duration
	^ duration! !

!ZnResponseWrittenEvent methodsFor: 'accessing' stamp: ''!
response
	^ response! !

!ZnSecureServer commentStamp: ''!
I am ZnSecureServer, an implementation of an HTTPS server.
I am a ZnMultiThreadedServer

(ZnSecureServer on: 1443)
	certificate: '/home/sven/ssl/key-cert.pem';
	logToTranscript;
	start;
	yourself.
	
Disclaimer: this is an experimental proof of concept.!
!ZnSecureServer methodsFor: 'accessing' stamp: ''!
scheme
	^ #https! !

!ZnSecureServer methodsFor: 'accessing' stamp: ''!
certificate
	^ certificate! !

!ZnSecureServer methodsFor: 'accessing' stamp: ''!
certificate: anObject
	certificate := anObject! !

!ZnSecureServer methodsFor: 'private' stamp: ''!
socketStreamOn: socket
	| stream |
	stream := ZdcSecureSocketStream on: socket.
	stream sslSession certificateName: self certificate.
	stream accept.
	^ stream! !

!ZnServer commentStamp: ''!
I am ZnServer, an abstract superclass of HTTP Servers.
I am a facade for controlling a default server implementation.

I delegate my public class protocol methods to #defaultServerClass.

  ZnServer startDefaultOn: 1701.
  ZnClient new get: 'http://localhost:1701'.

Subclasses can register with me to have start/stop sent to them on System startUp/shutDown.
The default server instance will be registered automatically when it is started.

Part of Zinc HTTP Components.!
!ZnServer methodsFor: 'public' stamp: ''!
start
	"Start me. I will start listening on my port for incoming HTTP connections.
	If I am running, I will first stop and thus effectively restart"
	
	self subclassResponsibility! !

!ZnServer methodsFor: 'accessing' stamp: ''!
optionAt: key ifAbsent: block
	"Return my option/settings stored under key.
	Execute block if I have no such option/setting.
	This is a generic interface, see my options protocol for specific usages."

	options ifNil: [ ^ block value ].
	^ options at: key ifAbsent: block! !

!ZnServer methodsFor: 'options' stamp: ''!
reader: block
	"Customize how entities are read from a stream, see #reader"
	
	self optionAt: #reader put: block! !

!ZnServer methodsFor: 'public' stamp: ''!
stop
	"Stop me. I will stop listening on my port for incoming HTTP connections.
	Does nothing when I am not running"
	
	self stop: true ! !

!ZnServer methodsFor: 'public' stamp: ''!
stop: unregister
	"Stop me. I will stop listening on my port for incoming HTTP connections.
	If unregister is true, unregister me from the list of managed instances.
	Does nothing when I am not running"
	
	self subclassResponsibility ! !

!ZnServer methodsFor: 'options' stamp: ''!
bindingAddress: address
	"Set the interface address we will be listening on.
	Specify nil to listen on all/any interfaces, the default.
	Address must be a 4 element ByteArray, like #[127 0 0 1].
	Cannot be changed after the server is already running."
	
	self optionAt: #bindAddress put: address! !

!ZnServer methodsFor: 'options' stamp: ''!
serverUrl: urlObject
	"Set the explicit external server URL to urlObject. Defaults to nil.
	urlObject should be a ZnUrl or a String that parses correctly to one.
	See also #url."
	
	^ self optionAt: #serverUrl put: urlObject asZnUrl! !

!ZnServer methodsFor: 'options' stamp: ''!
maximumEntitySize
	"Return the maximum entity size in bytes that I will read from a stream before signalling ZnEntityTooLarge"
	
	^ self optionAt: #maximumEntitySize ifAbsent: [ ZnMaximumEntitySize value ]! !

!ZnServer methodsFor: 'testing' stamp: ''!
isRunning
	"Return true when I am running"
	
	self subclassResponsibility ! !

!ZnServer methodsFor: 'accessing' stamp: ''!
url
	"Return the base external URL (a new ZnUrl instance) to access me.
	This defaults to #localUrl but can be set explicitly using the #serverUrl option.
	Missing elements from #serverUrl are merged in from #localUrl."

	^ self serverUrl 
		ifNil: [ self localUrl ] 
		ifNotNil: [ :serverUrl | serverUrl inContextOf: self localUrl ]! !

!ZnServer methodsFor: 'options' stamp: ''!
route: object
	"Set the route of the server.
	This is a short identification string to be appended at the end of server session ids, separated by a dot.
	Routes are used by load balancers and proxies to correctly implement session affiinity or stickyness.
	The default is nil, meaning that no route has to be appended."

	self optionAt: #route put: object! !

!ZnServer methodsFor: 'options' stamp: ''!
route
	"Return the route of the server.
	This is a short identification string to be appended at the end of server session ids, separated by a dot.
	Routes are used by load balancers and proxies to correctly implement session affiinity or stickyness.
	The default is nil, meaning that no route has to be appended."
	
	^ self optionAt: #route ifAbsent: [ nil ]! !

!ZnServer methodsFor: 'options' stamp: ''!
port
	"Return the integer port number we are (or will be) listening on"
	
	^ self optionAt: #port ifAbsent: [ 1701 ] ! !

!ZnServer methodsFor: 'options' stamp: ''!
reader
	"Return a block that when given a stream reads an entity from it."
	
	^ self optionAt: #reader ifAbsentPut: [ [ :stream | ZnRequest readFrom: stream ] ]! !

!ZnServer methodsFor: 'public' stamp: ''!
unregister
	"Ask for start/stop to no longer be sent to me on System startUp/shutDown"

	self class unregister: self! !

!ZnServer methodsFor: 'options' stamp: ''!
authenticator: object
	"Set the object that will be sent #authenticateRequest:do:
	to authenticate or refuse the requests. Can be nil.
	When authentication succeeds, the block should be executed,
	when authentication fails, a appropriate response should be returned"

	self optionAt: #authenticator put: object! !

!ZnServer methodsFor: 'accessing' stamp: ''!
serverSocket
	"Return the server socket that I am using.
	Will be nil when I am not running"
	
	self subclassResponsibility ! !

!ZnServer methodsFor: 'options' stamp: ''!
bindingAddress
	"Return the interface address we are (or will be) listening on.
	Nil means that we are (or will be) listening on all/any interfaces."
	
	^ self optionAt: #bindAddress ifAbsent: [ nil ] ! !

!ZnServer methodsFor: 'options' stamp: ''!
serverUrl
	"Return the explicitely set external server URL, if any. Defaults to nil."
	
	^ self optionAt: #serverUrl ifAbsent: [ nil ]! !

!ZnServer methodsFor: 'options' stamp: ''!
delegate
	"Return the optional delegate, 
	the object that will be sent #handleRequest: to handle a request and produce a response.
	The default delegate is ZnDefaultServerDelegate"
	
	^ self optionAt: #delegate ifAbsentPut: [ ZnDefaultServerDelegate new ]! !

!ZnServer methodsFor: 'options' stamp: ''!
authenticator
	"Return the optional authenticator,
	the object that will be sent #authenticateRequest:do:
	to authenticate or refuse the requests. 
	When authentication succeeds, the block should be executed,
	when authentication fails, a appropriate response should be returned.
	If there is no authenticator, all requests will pass"
	
	^ self optionAt: #authenticator ifAbsent: [ nil ]! !

!ZnServer methodsFor: 'options' stamp: ''!
debugMode: boolean
	"Set my debug mode, the default being false.
	In debug mode, Smalltalk Error during #handleRequest: will raise a Debugger.
	When not in debug mode, a Smalltalk Error during #handleRequest: will result in an HTTP Server Error response."
	
	^ self optionAt: #debugMode put: boolean! !

!ZnServer methodsFor: 'options' stamp: ''!
logServerErrorDetails
	"Return whether we log server error details including a short strack trace, the default is true."
	
	^ self optionAt: #debugMode ifAbsent: [ true ] ! !

!ZnServer methodsFor: 'options' stamp: ''!
port: integer
	"Set the port number we will be listening on.
	Cannot be changed after the server is already running."
	
	(self isRunning and: [ self port ~= integer ]) 
		ifTrue: [ self error: 'Stop me before changing my port' ].
	self optionAt: #port put: integer! !

!ZnServer methodsFor: 'options' stamp: ''!
debugMode
	"Return whether we are in debug mode, the default is false."
	
	^ self optionAt: #debugMode ifAbsent: [ false ] ! !

!ZnServer methodsFor: 'options' stamp: ''!
maximumNumberOfDictionaryEntries
	"Return the maximum number of entries allowed in ZnMutliValueDictionaries before signalling ZnTooManyDictionaryEntries. This protects us from overflow attacks."
		
	^ self
		optionAt: #maximumNumberOfDictionaryEntries
		ifAbsent: [ ZnMaximumNumberOfDictionaryEntries value ]! !

!ZnServer methodsFor: 'accessing' stamp: ''!
sessionFor: request
	"Bind an existing session to request or create a new session"
	
	^ self sessionManager sessionFor: request! !

!ZnServer methodsFor: 'options' stamp: ''!
maximumNumberOfDictionaryEntries: anInteger
	"Set the maximum number of entries allowed in ZnMutliValueDictionaries before signalling ZnTooManyDictionaryEntries. This protects us from overflow attacks."
	
	^ self
		optionAt: #maximumNumberOfDictionaryEntries
		put: anInteger! !

!ZnServer methodsFor: 'accessing' stamp: ''!
optionAt: key put: value
	"Set my option/setting identified by key to be value.
	This is a generic interface, see my options protocol for specific usages."
	
	options ifNil: [ options := Dictionary new ].
	options at: key put: value! !

!ZnServer methodsFor: 'public' stamp: ''!
register
	"Ask for start/stop to be sent to me on System startUp/shutDown"
	
	self class register: self! !

!ZnServer methodsFor: 'options' stamp: ''!
defaultEncoder
	"The default character encoder to use when none is set in a mime-type"
	
	^ self optionAt: #defaultEncoder ifAbsent: [ ZnDefaultCharacterEncoder value ] ! !

!ZnServer methodsFor: 'accessing' stamp: ''!
sessionManager
	"Return my session manager"

	^ sessionManager ifNil: [ sessionManager := ZnServerSessionManager new ]! !

!ZnServer methodsFor: 'options' stamp: ''!
useGzipCompressionAndChunking
	"Return whether we should try to use gzip content encoding and chunked transfer encoding, the default is false."
	
	^ self optionAt: #useGzipCompressionAndChunking ifAbsent: [ false ] ! !

!ZnServer methodsFor: 'options' stamp: ''!
delegate: object
	"Set the delegate to object. Can be nil.
	This will be sent #handleRequest: to handle a request and produce a response"
	
	self optionAt: #delegate put: object! !

!ZnServer methodsFor: 'options' stamp: ''!
logServerErrorDetails: boolean
	"Set whether we log server error details including a short strack trace, the default is true."
	
	self optionAt: #debugMode put: boolean! !

!ZnServer methodsFor: 'options' stamp: ''!
maximumEntitySize: integer
	"Set the maximum entity size in bytes that I will read from a stream before signalling ZnEntityTooLarge"
	
	^ self optionAt: #maximumEntitySize put: integer! !

!ZnServer methodsFor: 'accessing' stamp: ''!
scheme
	^ #http! !

!ZnServer methodsFor: 'accessing' stamp: ''!
localUrl
	"Return a ZnUrl to access me."
	
	^ ZnUrl new
		scheme: self scheme;
		host: NetNameResolver loopBackName;
		port: self port;
		yourself! !

!ZnServer methodsFor: 'options' stamp: ''!
useGzipCompressionAndChunking: boolean
	"Set whether we should try to use gzip content encoding and chunked transfer encoding, the default being false."
	
	self optionAt: #useGzipCompressionAndChunking put: boolean! !

!ZnServer methodsFor: 'accessing' stamp: ''!
optionAt: key ifAbsentPut: block
	"Return my option/settings stored under key.
	If I have no such option/setting, store the result of evaluating block as new value and return it.
	This is a generic interface, see my options protocol for specific usages."

	^ options at: key ifAbsentPut: block! !

!ZnServer methodsFor: 'accessing' stamp: ''!
process
	"Return the process that is running my main listening loop.
	Will be nil when I am not running"
	
	self subclassResponsibility ! !

!ZnServer methodsFor: 'options' stamp: ''!
defaultEncoder: encoder
	"Set the default character encoder to use when none is set in a mime-type"
	
	^ self optionAt: #defaultEncoder put: encoder asZnCharacterEncoder! !

!ZnServer methodsFor: 'testing' stamp: ''!
isListening
	"Return true when I have a valid server socket listening at the correct port"
	
	self subclassResponsibility ! !

!ZnServer class methodsFor: 'class initialization' stamp: ''!
initialize
	ManagedServers := IdentitySet new.
	AlwaysRestart := true.
	self environment 
		at: #SessionManager 
		ifPresent: [ :manager | manager default registerNetworkClassNamed: self name ]
		ifAbsent: [ Smalltalk addToStartUpList: self; addToShutDownList: self ]
	! !

!ZnServer class methodsFor: 'accessing' stamp: ''!
managedServers
	^ ManagedServers ifNil: [ ManagedServers := IdentitySet new ]! !

!ZnServer class methodsFor: 'public' stamp: ''!
adoptAsDefault: server
	"Adopt server as the default instance that we manage.
	If there was a previous default, stop it.
	Delegate to the default server class."
	
	self defaultServerClass adoptAsDefault: server! !

!ZnServer class methodsFor: 'system startup' stamp: ''!
shutDown: quiting
	"Our system shutDown hook: stop all servers we manage"
	
	(quiting or: [ self alwaysRestart ])
		ifTrue: [
			self managedServers do: [ :each | each stop: false ] ]! !

!ZnServer class methodsFor: 'public' stamp: ''!
startDefaultOn: portNumber
	"Start and return the default instance on a given port.
	Keep a reference to it in a class instance variable.
	If there was no previous default instance, create a new one.
	If there was a previous default instance, reuse it:
	if it was running stop and start it, effectively restarting it.
	Change the port if necessary.
	Starting the default server will register it automatically.
	Delegate to the default server class."

	^ self defaultServerClass startDefaultOn: portNumber ! !

!ZnServer class methodsFor: 'accessing' stamp: ''!
alwaysRestart: boolean
	"Set if managed servers should always restart on image save, as opposed to only when quiting."

	^ AlwaysRestart := boolean! !

!ZnServer class methodsFor: 'public' stamp: ''!
on: portNumber
	"Instantiate a new listener on a given port,
	send #start to it to start listening.
	Delegate to the default server class."

	^ self defaultServerClass on: portNumber ! !

!ZnServer class methodsFor: 'public' stamp: ''!
defaultOn: portNumber
	"Return the default instance on a given port,
	Keep a reference to it in a class instance variable.
	If there was no previous default instance, create a new one.
	If there was a previous default instance, reuse it:
	if it was running stop it, change the port if necessary.
	Delegate to the default server class."

	^ self defaultServerClass defaultOn: portNumber ! !

!ZnServer class methodsFor: 'accessing' stamp: ''!
defaultServerClass
	"Return the default ZnServer subclass to use"
	
	^ ZnManagingMultiThreadedServer ! !

!ZnServer class methodsFor: 'accessing' stamp: ''!
alwaysRestart
	^ AlwaysRestart ifNil: [ AlwaysRestart := true ]! !

!ZnServer class methodsFor: 'public' stamp: ''!
stopDefault
	"Stop the default instance, if any, and clear it.
	Return the stopped instance, if any.
	Delegate to the default server class."

	^ self defaultServerClass stopDefault ! !

!ZnServer class methodsFor: 'public' stamp: ''!
default
	"Return the default instance that we manage.
	Delegate to the default server class."
	
	^ self defaultServerClass default! !

!ZnServer class methodsFor: 'public' stamp: ''!
startOn: portNumber
	"Instanciate and return a new listener on a given port and start listening.
	Delegate to the default server class."

	^ self defaultServerClass startOn: portNumber ! !

!ZnServer class methodsFor: 'system startup' stamp: ''!
startUp: resuming
	"Our system startUp hook: start all servers we manage.
	We do this using deferred startup actions to allow normal error handling."

	(resuming or: [ self alwaysRestart ])
		ifTrue: [
			self environment 
				at: #SessionManager 
				ifPresent: [ :manager | 
					manager default currentSession addDeferredStartupAction: [ 
						self managedServers do: [ :each | each start ] ] ]
				ifAbsent: [ 
					Smalltalk addDeferredStartupAction: [ 
						self managedServers do: [ :each | each start ] ] ] ]! !

!ZnServer class methodsFor: 'system startup' stamp: ''!
register: server
	"Arrange for server to be sent start/stop on system startUp/shutDown"
	
	self managedServers add: server! !

!ZnServer class methodsFor: 'system startup' stamp: ''!
unregister: server
	"No longer send server start/stop on system startUp/shutDown"
	
	self managedServers remove: server ifAbsent: [ ]! !

!ZnServerConnectionClosedEvent commentStamp: ''!
ZnServerConnectionClosedEvent signals that the server closed a client connection to address. !
!ZnServerConnectionClosedEvent methodsFor: 'accessing' stamp: ''!
address: anObject
	address := anObject! !

!ZnServerConnectionClosedEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Server Connection Closed '.
	address do: [ :each | stream print: each ] separatedBy: [ stream nextPut: $. ]! !

!ZnServerConnectionClosedEvent methodsFor: 'accessing' stamp: ''!
address
	^ address! !

!ZnServerErrorEvent commentStamp: ''!
ZnServerErrorEvent is a ZnServerLogEvent related to an exception that occurred.!
!ZnServerErrorEvent methodsFor: 'accessing' stamp: ''!
exception
	^ exception! !

!ZnServerErrorEvent methodsFor: 'accessing' stamp: ''!
exception: anObject
	exception := anObject! !

!ZnServerGenericLogEvent commentStamp: ''!
I am ZnServerGenericLogEvent, a ZnServerLogEvent and ZnLogEvent that holds a generic subject, possibly not limited to a String.

Here are two examples:

(ZnServerGenericLogEvent subject: 'You can''t do that, Dave') emit.

(ZnServerGenericLogEvent subject: { #id->123. #reason->#timeout } asDictionary) emit.!
!ZnServerGenericLogEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream space; nextPutAll: subject asString! !

!ZnServerGenericLogEvent methodsFor: 'accessing' stamp: ''!
subject: anObject
	subject := anObject! !

!ZnServerGenericLogEvent methodsFor: 'accessing' stamp: ''!
subject
	^ subject! !

!ZnServerGenericLogEvent class methodsFor: 'instance creation' stamp: ''!
subject: object
	"self subject: #(i 10 j -1)."
	"self subject: 'How are you?'."
	
	^ self new
		subject: object;
		yourself! !

!ZnServerHandlerErrorEvent commentStamp: ''!
ZnServerHandlerErrorEvent signals an error that occurred during handling by the delegate. This is considered a real error.!
!ZnServerHandlerErrorEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Server Handler Error ';  print: exception! !

!ZnServerLogEvent commentStamp: ''!
I am ZnServerLogEvent, a ZnLogEvent generated by ZnServer and its subclasses.

I hold a processId attribute.
I hold an optional serverId attribute.!
!ZnServerLogEvent methodsFor: 'accessing' stamp: ''!
serverId
	^ serverId! !

!ZnServerLogEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	serverId ifNotNil: [ stream space; << serverId ].
	stream space.
	processId printOn: stream base: 10 length: 6 padded: true! !

!ZnServerLogEvent methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	processId := ZnUtils currentProcessID! !

!ZnServerLogEvent methodsFor: 'accessing' stamp: ''!
processId
	^ processId! !

!ZnServerLogEvent methodsFor: 'initialize' stamp: ''!
serverId: anObject
	serverId := anObject! !

!ZnServerLogEvent methodsFor: 'initialize' stamp: ''!
processId: anObject
	processId := anObject! !

!ZnServerReadErrorEvent commentStamp: ''!
ZnServerReadErrorEvent signals an error during the reading of a request. These errors are considered mostly benign and the connection gets closed.
!
!ZnServerReadErrorEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Server Read Error ';  print: exception! !

!ZnServerSession commentStamp: ''!
I am ZnServerSession.
I represent an HTTP session in the context of a ZnServer.

To get a reference to the current session, send #session to a ZnMessage (request or response).

Part of Zinc HTTP Components.!
!ZnServerSession methodsFor: 'accessing' stamp: ''!
attributeAt: key
	^ attributes at: key! !

!ZnServerSession methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	attributes := SmallDictionary new.
	created := modified := DateAndTime now! !

!ZnServerSession methodsFor: 'initialize-release' stamp: ''!
id: anObject
	id := anObject! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
attributeKeys
	^ attributes keys! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
attributeAt: key ifAbsent: block
	^ attributes at: key ifAbsent: block! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
modified
	^ modified! !

!ZnServerSession methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	id
		ifNotNil: [ 
			stream
				nextPut: $(;
				print: id;
				nextPut: $) ]! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
age
	^ DateAndTime now - created! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
inactivity
	^ DateAndTime now - modified ! !

!ZnServerSession methodsFor: 'testing' stamp: ''!
isValid
	^ self inactivity < 1 hour! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
removeAttribute: key
	attributes removeKey: key ifAbsent: [ ] ! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
created
	^ created! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
touch
	modified := DateAndTime now! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
attributeAt: key ifAbsentPut: block
	^ attributes at: key ifAbsentPut: block! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
attributeAt: key put: value
	^ attributes at: key put: value! !

!ZnServerSession methodsFor: 'accessing' stamp: ''!
id
	^ id! !

!ZnServerSessionManager commentStamp: ''!
I am ZnServerSessionManager.
I manage a collection of ZnServerSession on behalf of a ZnServer.

Session ids are stored in cookies.

Part of Zinc HTTP Components.!
!ZnServerSessionManager methodsFor: 'accessing' stamp: ''!
cookieName
	^ 'session-id'! !

!ZnServerSessionManager methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	sessions := Dictionary new! !

!ZnServerSessionManager methodsFor: 'private' stamp: ''!
newSessionId
	"Create a new session id.
	If the server has a route, append it at the end with a dot as separator."
	
	^ ZnCurrentServer value route
		ifNil: [ UUID new asString36 ]
		ifNotNil: [ :route | 
			String
				streamContents: [ :stream | 
					stream
						<< UUID new asString36;
						nextPut: $.;
						<< route ] ]! !

!ZnServerSessionManager methodsFor: 'accessing' stamp: ''!
sessionFor: request
	"Bind an existing session to request or create a new session"

	| id |
	id := self sessionIdFromRequest: request.
	sessions
		at: id
		ifPresent: [ :session | 
			session isValid
				ifTrue: [ ^ session touch; yourself ]
				ifFalse: [ sessions removeKey: id ] ].
	^ self newSessionForRequest: request! !

!ZnServerSessionManager methodsFor: 'accessing' stamp: ''!
setSession: session in: response
	"Bind session in response"

	| cookie |
	session ifNil: [ ^ self ].
	(cookie := ZnCookie name: self cookieName value: session id)
		path: '/'.
	response addCookie: cookie! !

!ZnServerSessionManager methodsFor: 'private' stamp: ''!
sessionIdFromRequest: request
	| cookie |
	cookie := request cookies 
		detect: [ :each | each name = self cookieName ] 
		ifNone: [ ^ nil ].
	^ cookie value! !

!ZnServerSessionManager methodsFor: 'accessing' stamp: ''!
cleanupInvalidSessions
	"Remove all expired sessions"
	
	sessions keysAndValuesRemove: [ :key :value | value isValid not ]! !

!ZnServerSessionManager methodsFor: 'private' stamp: ''!
newSessionForRequest: request
	| id session |
	id := self newSessionId.
	session := ZnServerSession new.
	session id: id.
	sessions at: id put: session.
	^ session! !

!ZnServerSessionManager methodsFor: 'accessing' stamp: ''!
removeSessionWithId: id
	"Remove the session with id.
	If there is no such session, do nothing"
	
	^ sessions removeKey: id ifAbsent: [ nil ]! !

!ZnServerSocketBoundEvent commentStamp: ''!
ZnServerSocketBoundEvent signals a new server socket on address:port is bound (opened).!
!ZnServerSocketBoundEvent methodsFor: 'accessing' stamp: ''!
address: anObject
	address := anObject! !

!ZnServerSocketBoundEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Server Socket Bound '.
	address do: [ :each | stream print: each ] separatedBy: [ stream nextPut: $. ].
	stream nextPut: $:; print: port
	! !

!ZnServerSocketBoundEvent methodsFor: 'accessing' stamp: ''!
port: anObject
	port := anObject! !

!ZnServerSocketBoundEvent methodsFor: 'accessing' stamp: ''!
address
	^ address! !

!ZnServerSocketBoundEvent methodsFor: 'accessing' stamp: ''!
port
	^ port! !

!ZnServerSocketReleasedEvent commentStamp: ''!
ZnServerSocketReleasedEvent signals a new server socket on address:port is released (closed).!
!ZnServerSocketReleasedEvent methodsFor: 'accessing' stamp: ''!
address: anObject
	address := anObject! !

!ZnServerSocketReleasedEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Server Socket Released '.
	address do: [ :each | stream print: each ] separatedBy: [ stream nextPut: $. ].
	stream nextPut: $:; print: port! !

!ZnServerSocketReleasedEvent methodsFor: 'accessing' stamp: ''!
port: anObject
	port := anObject! !

!ZnServerSocketReleasedEvent methodsFor: 'accessing' stamp: ''!
address
	^ address! !

!ZnServerSocketReleasedEvent methodsFor: 'accessing' stamp: ''!
port
	^ port! !

!ZnServerStartedEvent commentStamp: ''!
ZnServerStartedEvent notes the startup of an HTTP server is complete.
!
!ZnServerStartedEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Started '; << description! !

!ZnServerStartedEvent methodsFor: 'accessing' stamp: ''!
description: anObject
	description := anObject! !

!ZnServerStartedEvent methodsFor: 'accessing' stamp: ''!
description
	^ description! !

!ZnServerStoppedEvent commentStamp: ''!
ZnServerStoppedEvent notes the shutdown of an HTTP server is complete.!
!ZnServerStoppedEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Stopped '; << description! !

!ZnServerStoppedEvent methodsFor: 'accessing' stamp: ''!
description: anObject
	description := anObject! !

!ZnServerStoppedEvent methodsFor: 'accessing' stamp: ''!
description
	^ description! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testEchoLocalInterface
	| server response |
	(server := ZnServer on: self port) bindingAddress: NetNameResolver loopBackAddress.
	[ server start.
	self assert: server isRunning & server isListening description: ('Failed to start server on port {1}. Is there one already?' format: {server port}).
	response := ZnEasy
		get:
			(server localUrl
				addPathSegments: #('echo' 'foo');
				yourself).
	self assert: response contentType equals: ZnMimeType textPlain.
	self assert: response statusLine code equals: 200.
	self assert: (response entity contents includesSubstring: 'Zinc').
	self assert: (response entity contents includesSubstring: 'foo') ]
		ensure: [ server stop ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testReadEvalPrint
	self withServerDo: [ :server | | x y result |
		server delegate: ZnReadEvalPrintDelegate new.
		x := 100 atRandom.
		y := 100 atRandom.
		result := ZnClient new
			url: server localUrl;
			addPathSegment: #repl;
			contents: ('{1}+{2}' format: { x. y });
			post.
		self assert: result asInteger equals: x + y ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testDefault
	| port server initialDefaultServer wasRunning |
	wasRunning := ZnServer default ifNil: [ false ] ifNotNil: [ ZnServer default isRunning ].
	initialDefaultServer := ZnServer stopDefault.
	self assert: ZnServer default isNil.
	port := self port.
	server := ZnServer startDefaultOn: port.
	self assert: ZnServer default notNil.
	self assert: ZnServer default identicalTo: server.
	self assert: ZnServer default port equals: port.
	self assert: ZnServer default isRunning.
	self assert: (ZnServer managedServers includes: server).
	ZnServer stopDefault.
	self assert: ZnServer default isNil.
	self deny: server isRunning.
	self deny: (ZnServer managedServers includes: server).
	server := ZnServer startDefaultOn: port.
	"Starting the default again is actually a restart"
	ZnServer startDefaultOn: port.
	self assert: ZnServer default identicalTo: server.
	ZnServer stopDefault.
	ZnServer adoptAsDefault: initialDefaultServer.
	self assert: initialDefaultServer identicalTo: ZnServer default.
	wasRunning ifTrue: [ ZnServer default start ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testHeaderLineTooLong
	self usingClassicSocketStreamsOnWindowsDo: [
		self withServerDo: [ :server |
			self deny: server debugMode.
			self assertHeaderLineTooLong: server localUrl ] ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testGetConnectionClose
	self withServerDo: [ :server | | client |
		client := ZnClient new.
		client url: server localUrl; addPathSegment: #echo.
		client request setConnectionClose.
		client get.
		self assert: client isSuccess.
		self assert: (client contents includesSubstring: 'echo').
		self assert: client response isConnectionClose.
		client close ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testFormTest2
	| inputs client |
	inputs := #( '1+2=3 & 2+1=3' 'single ''' 'double " - cool ?' 'élèves français' 'Ελλάδα' ).
	self withServerDo: [ :server |
		(client := ZnClient new)
			url: server localUrl;
			addPathSegment: 'form-test-2'.
		inputs do: [ :each  |
			client
				formAt: #input put: each;
				post.
			self assert: client isSuccess.
			self assert: (client contents includesSubstring: each) ] ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
assertEntityTooLarge: serverUrl
	| response client |
	client := ZnClient new
		url: serverUrl;
		addPathSegment: #echo;
		entity: (ZnEntity with: (ByteArray new: self entitySizeLimit + 1));
		yourself.
	response := client
		post;
		response.
	client close.
	self deny: response isSuccess.
	self assert: response code equals: 400.
	self assert: response contentType equals: ZnMimeType textPlain.
	self assert: (response entity contents includesSubstring: 'ZnEntityTooLarge')! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testSession
	self
		withServerDo: [ :server | 
			| client sessionId |
			client := ZnClient new
				url: (server localUrl addPathSegment: #session);
				yourself.
			self assert: client session cookieJar cookies isEmpty.
			client get.
			self assert: client isSuccess.
			self assert: client session cookieJar cookies size equals: 1.
			sessionId := client session cookieJar cookies anyOne value.
			self assert: (client contents includesSubstring: sessionId).
			client get.
			self assert: client isSuccess.
			self assert: client session cookieJar cookies size equals: 1.
			self assert: client session cookieJar cookies anyOne value equals: sessionId.
			self assert: (client contents includesSubstring: sessionId) ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testEcho
	self
		withServerDo: [ :server | 
			| response |
			response := ZnEasy
				get:
					(server localUrl
						addPathSegments: #('echo' 'foo');
						yourself).
			self assert: response contentType equals: ZnMimeType textPlain.
			self assert: response statusLine code equals: 200.
			self assert: (response entity contents includesSubstring: 'Zinc').
			self assert: (response entity contents includesSubstring: 'foo').
			self assert: (response entity contents includesSubstring: server printString) ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testRespond
	self withServerDo: [ :server | | client |
		server onRequestRespond: [ :request |
			ZnRespond signalWith: (ZnResponse ok: (ZnEntity text: 'RESPONDED')).
			ZnResponse notFound: request uri ].
		client := ZnClient new.
		client get: server localUrl.
		self assert: client isSuccess.
		self assert: client response contentType equals: ZnMimeType textPlain.
		self assert: client contents equals: 'RESPONDED'.
		client close ]! !

!ZnServerTest methodsFor: 'private' stamp: ''!
runningOnWindows
	"Pharo 3+"
	[ ^ OSPlatform current isWindows ] on: MessageNotUnderstood do: [ ].
	"Pharo 2-"
	[ ^ OSPlatform isWin32 ] on: MessageNotUnderstood do: [ ].
	"Give up"
	^ false! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testTooManyHeaders
	self usingClassicSocketStreamsOnWindowsDo: [
		self withServerDo: [ :server |
			self deny: server debugMode.
			self assertTooManyHeaders: server localUrl ] ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testUrl
	self withServerDo: [ :server | 
		self assert: server url equals: server localUrl.
		server serverUrl:
					(ZnUrl new
						host: 'zn.stfx.eu';
						yourself).
		self assert: server url scheme equals: #http.
		self assert: server url host equals: 'zn.stfx.eu'.
		self assert: server url port equals: server port.
		server serverUrl: 'http://zn.stfx.eu:8080/zn'.
		self assert: server url scheme equals: #http.
		self assert: server url host equals: 'zn.stfx.eu'.
		self assert: server url port equals: 8080.
		self assert: server url path equals: 'zn' ]! !

!ZnServerTest methodsFor: 'private' stamp: ''!
usingClassicSocketStreamsOnWindowsDo: block
	| originalSocketStreamClass |
	originalSocketStreamClass := ZnNetworkingUtils default socketStreamClass.
	self runningOnWindows
		ifTrue: [ ZnNetworkingUtils default socketStreamClass: SocketStream ].
	block
		ensure: [ ZnNetworkingUtils default socketStreamClass: originalSocketStreamClass ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testGzipCompressionAndChunking
	self withServerDo: [ :server | | client |
		server useGzipCompressionAndChunking: true.
		(client := ZnClient new)
			url: server localUrl;
			addPathSegment: 'dw-bench';
			setAcceptEncodingGzip;
			get.
		self assert: client isSuccess.
		self assert: client response hasContentEncoding.
		self assert: (client response headers at: 'Content-Encoding') equals: 'gzip'.
		self assert: client response hasTransferEncoding.
		self assert: (client response headers at: 'Transfer-Encoding') equals: 'chunked' ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testZeroContentLength
	self withServerDo: [ :server | 
		| client |
		client := ZnClient new
			url: server localUrl / #echo;
			yourself.
		"Force a bogus zero content-length header"
		client headerAt: 'Content-Length' put: '0'.
		client get.
		self assert: client isSuccess.
		client close ]! !

!ZnServerTest methodsFor: 'private' stamp: ''!
port
	^ 1700 + 32 atRandom! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testAuthorizationSuccessful
	self
		withServerDo: [ :server | 
			| response |
			server authenticator: (ZnBasicAuthenticator username: 'foo' password: 'secret').
			response := ZnEasy
				get:
					(server localUrl
						addPathSegments: #('echo' 'foo');
						yourself)
				username: 'foo'
				password: 'secret'.
			self assert: response headers contentType equals: ZnMimeType textPlain.
			self assert: response statusLine code equals: 200.
			self assert: (response entity string includesSubstring: 'Zinc').
			self assert: (response entity string includesSubstring: 'foo') ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testFormTest3
	| inputs client part |
	inputs := #( ('foo.txt' 'this is foo!!') ('français.txt' 'Je te dis: élèves français') ('Ελλάδα.txt' 'Ελλάδα is it!!') ).
	self withServerDo: [ :server |
		server debugMode: true.
		(client := ZnClient new)
			url: server localUrl;
			addPathSegment: 'form-test-3'.
		inputs do: [ :each  |
			part := ZnMimePart 
				fieldName: 'file' 
				fileName: each first 
				entity: (ZnEntity with: each second).
			client
				resetEntity;
				addPart: part;
				post.
			self assert: client isSuccess.
			self assert: (client contents includesSubstring: each first).
			self assert: (client contents includesSubstring: each second) ] ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testError
	self withServerDo: [ :server | | url response |
		self deny: server debugMode.
		url := server localUrl
					addPathSegment: #error;
					queryAt: #message put: 'Test Error';
					yourself.
		response := ZnEasy get: url.
		self deny: response isSuccess.
		self assert: response code equals: 500.
		self assert: response contentType equals: ZnMimeType textPlain.
		self assert: (response entity contents includesSubstring: 'Test Error') ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testCustomDefaultDelegate
	self withServerDo: [ :server | | customDelegate client |
		customDelegate := ZnDefaultServerDelegate empty.
		customDelegate 
			map: 'ok' to: [ :request | ZnResponse ok: (ZnEntity text: 'OK') ];
			map: '/' to: 'ok';
			map: 'OK' to: [ :request | ZnResponse redirect: '/ok' ].
		server delegate: customDelegate.
		client := ZnClient new url: server localUrl.
		self assert: client get equals: 'OK'.
		client addPath: 'OK'.
		self assert: client get equals: 'OK'.
		client close	 ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testFormTest3Unspecified
	"Simulate what most browsers seem to do: upload text files utf-8 encoded 
	without specifying the charset in the mime type of the mime part"
	
	| inputs client part entity |
	inputs := #( ('foo.txt' 'this is foo!!') ('français.txt' 'Je te dis: élèves français') ('Ελλάδα.txt' 'Ελλάδα is it!!') ).
	self withServerDo: [ :server |
		server debugMode: true.
		(client := ZnClient new)
			url: server localUrl;
			addPathSegment: 'form-test-3'.
		inputs do: [ :each  |
			entity := ZnEntity 
				with: each second utf8Encoded 
				type: ZnMimeType textPlain clearCharSet.
			part := ZnMimePart fieldName: 'file' fileName: each first entity: entity.
			client
				resetEntity;
				addPart: part;
				post.
			self assert: client isSuccess.
			self assert: (client contents includesSubstring: each first).
			self assert: (client contents includesSubstring: each second) ] ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testSmall
	self withServerDo: [ :server | 
		| client |
		client := ZnClient new
			url: (server localUrl addPathSegment: #small);
			yourself.
		client get.
		self assert: client isSuccess.
		self assert: client response contentType equals: ZnMimeType textHtml.
		self assert: (client contents includesSubstring: 'Small').
		self assert: (client contents includesSubstring: 'This is a small HTML document').
		client close ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testLocalUrl
	self withServerDo: [ :server | 
		self assert: server localUrl scheme equals: #http.
		self assert: server localUrl host equals: NetNameResolver loopBackName.
		self assert: server localUrl port equals: server port ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testSessionExpired
	self
		withServerDo: [ :server | 
			| client sessionId |
			client := ZnClient new
				url: (server localUrl addPathSegment: #session);
				yourself.
			self assert: client session cookieJar cookies isEmpty.
			client get.
			self assert: client isSuccess.
			self assert: client session cookieJar cookies size equals: 1.
			sessionId := client session cookieJar cookies anyOne value.
			self assert: (client contents includesSubstring: sessionId).
			"Kill the server session as if it was expired"
			server sessionManager removeSessionWithId: sessionId.
			"The client still presents the old session id but should get a new one"
			client get.
			self assert: client isSuccess.
			self assert: client session cookieJar cookies size equals: 1.
			self deny: client session cookieJar cookies anyOne value equals: sessionId ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
assertTooManyHeaders: serverUrl
	| response client |
	client := ZnClient new
		url: serverUrl;
		addPathSegment: #echo;
		yourself.
	client request headers unlimited.
	1 to: 256 do: [ :each | client headerAt: 'X-Test-' , each printString put: each printString ].
	response := client
		get;
		response.
	client close.
	self deny: response isSuccess.
	self assert: response code equals: 400.
	self assert: response contentType equals: ZnMimeType textPlain.
	self assert: (response entity contents includesSubstring: 'ZnTooManyDictionaryEntries')! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testRequestLineTooLong
	self usingClassicSocketStreamsOnWindowsDo: [
		self withServerDo: [ :server |
		self deny: server debugMode.
		self assertRequestLineTooLong: server localUrl ] ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testFormTest1
	| inputs client |
	inputs := #( '1+2=3 & 2+1=3' 'single ''' 'double " - cool ?' 'élèves français' 'Ελλάδα' ).
	self withServerDo: [ :server |
		(client := ZnClient new)
			url: server localUrl;
			addPathSegment: 'form-test-1'.
		inputs do: [ :each  |
			client
				queryAt: #input put: each;
				get.
			self assert: client isSuccess.
			self assert: (client contents includesSubstring: each) ] ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testSessionRoute
	self
		withServerDo: [ :server | 
			| client sessionId |
			server route: 'r1'.
			self assert: server route equals: 'r1'.
			client := ZnClient new
				url: (server localUrl addPathSegment: #session);
				yourself.
			self assert: client session cookieJar cookies isEmpty.
			client get.
			self assert: client isSuccess.
			self assert: client session cookieJar cookies size equals: 1.
			sessionId := client session cookieJar cookies anyOne value.
			self assert: (client contents includesSubstring: sessionId).
			self assert: (sessionId endsWith: '.r1').
			client get.
			self assert: client isSuccess.
			self assert: client session cookieJar cookies size equals: 1.
			self assert: client session cookieJar cookies anyOne value equals: sessionId.
			self assert: (client contents includesSubstring: sessionId) ]! !

!ZnServerTest methodsFor: 'accessing' stamp: ''!
entitySizeLimit
	^ 1024! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
assertRequestLineTooLong: serverUrl
	| url response |
	url := serverUrl
		addPathSegment: #echo;
		addPathSegment: (String new: ZnConstants maximumLineLength withAll: $X);
		yourself.
	response := ZnEasy get: url.
	self deny: response isSuccess.
	self assert: response code equals: 400.
	self assert: response contentType equals: ZnMimeType textPlain.
	self assert: (response entity contents includesSubstring: 'ZnLineTooLong')! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
assertHeaderLineTooLong: serverUrl
	| response client |
	client := ZnClient new
		url: serverUrl;
		addPathSegment: #echo;
		headerAt: 'X-Test' put: (String new: ZnConstants maximumLineLength withAll: $X);
		yourself.
	response := client
		get;
		response.
	client close.
	self deny: response isSuccess.
	self assert: response code equals: 400.
	self assert: response contentType equals: ZnMimeType textPlain.
	self assert: (response entity contents includesSubstring: 'ZnLineTooLong')! !

!ZnServerTest methodsFor: 'private' stamp: ''!
withServerDo: block
	| server |
	server := ZnServer on: self port.
	[ 
		server start.
		self 
			assert: server isRunning & server isListening
			description: ('Failed to start server on port {1}. Is there one already?' format: { server port }).
		block cull: server 
	]
		ensure: [ server stop ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testAuthorizationFailed
	self
		withServerDo: [ :server | 
			| response |
			server authenticator: (ZnBasicAuthenticator username: 'foo' password: 'secret').
			response := ZnEasy
				get:
					(server localUrl
						addPathSegment: 'echo';
						yourself).
			self assert: response headers contentType equals: ZnMimeType textPlain.
			self assert: response statusLine code equals: 401.
			self assert: ((response headers at: 'WWW-Authenticate') includesSubstring: 'Basic').
			self assert: ((response headers at: 'WWW-Authenticate') includesSubstring: 'Zinc') ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testEntityTooLarge
	self usingClassicSocketStreamsOnWindowsDo: [ 
		self withServerDo: [ :server | 
			server maximumEntitySize: self entitySizeLimit.
			self deny: server debugMode.
			self assertEntityTooLarge: server localUrl ] ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testGetUnicodeUtf8
	self
		withServerDo: [ :server | 
			| response html |
			response := ZnEasy
				get:
					(server localUrl
						addPathSegment: 'unicode';
						yourself).
			self assert: response contentType equals: ZnMimeType textHtml.
			self assert: response statusLine code equals: 200.
			self assert: response contentType isCharSetUTF8.
			html := response entity contents.
			self assert: (html includesSubstring: 'Unicode').
			0 to: 16r024F do: [ :each | self assert: (html includes: each asCharacter) ] ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testEchoBinary
	self
		withServerDo: [ :server | 
			| response entityIn entityOut |
			server reader: [ :stream | ZnRequest readBinaryFrom: stream ].
			entityIn := ZnEntity with: 'ABC' type: 'text/plain'.
			response := ZnEasy
				put:
					(server localUrl
						addPathSegment: 'echo';
						yourself)
				data: entityIn.
			self assert: response contentType equals: ZnMimeType textPlain.
			self assert: response statusLine code equals: 200.
			entityOut := ZnEntity with: entityIn string asByteArray type: entityIn contentType.
			self assert: (response entity contents includesSubstring: entityOut printString) ]! !

!ZnServerTest methodsFor: 'testing' stamp: ''!
testOSAssignedPort
	| server |
	server := ZnServer on: 0.
	self assert: server port equals: 0.
	[ | response |
	server start.
	self assert: server port > 0.
	response := ZnEasy get: server localUrl / #echo / #foo.
	self assert: response contentType equals: ZnMimeType textPlain.
	self assert: response statusLine code equals: 200.
	self assert: (response entity contents includesSubstring: 'Zinc').
	self assert: (response entity contents includesSubstring: 'foo').
	self assert: (response entity contents includesSubstring: server printString) ]
		ensure: [ server stop ]! !

!ZnServerTransactionEvent commentStamp: ''!
ZnServerTransactionEvent is a ZnServerLogEvent that notes the completion of a server side HTTP transaction (request/response).

Instance Variables
	request: a ZnRequest
	response:	a ZnResponse
	timing: a ZnServerTransactionTiming

Note that this can be quite large since it includes the entities transferred. See ZnSimplifiedServerTransactionEvent for a more compact representation.!
!ZnServerTransactionEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream space.
	request requestLine printMethodAndUriOn: stream.
	stream space; print: response code.
	response hasEntity
		ifTrue: [ 
			stream space; print: response entity contentLength; nextPut: $B ].
	stream space; print: self duration; nextPutAll: 'ms'! !

!ZnServerTransactionEvent methodsFor: 'accessing' stamp: ''!
timing: anObject
	timing := anObject! !

!ZnServerTransactionEvent methodsFor: 'accessing' stamp: ''!
response: anObject
	response := anObject! !

!ZnServerTransactionEvent methodsFor: 'accessing' stamp: ''!
duration
	^ timing totalDuration! !

!ZnServerTransactionEvent methodsFor: 'accessing' stamp: ''!
response
	^ response! !

!ZnServerTransactionEvent methodsFor: 'accessing' stamp: ''!
timing
	^ timing! !

!ZnServerTransactionEvent methodsFor: 'accessing' stamp: ''!
request
	^ request! !

!ZnServerTransactionEvent methodsFor: 'accessing' stamp: ''!
request: anObject
	request := anObject! !

!ZnServerTransactionTiming commentStamp: ''!
I am ZnServerTransactionTiming.

I hold timing information related to the handling of an HTTP transaction by a server.
!
!ZnServerTransactionTiming methodsFor: 'accessing' stamp: ''!
totalDuration
	"requestDuration is unreliable because it contains idle wait time"
	
	^ handlerDuration + responseDuration ! !

!ZnServerTransactionTiming methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	requestDuration := handlerDuration := responseDuration := 0! !

!ZnServerTransactionTiming methodsFor: 'accessing' stamp: ''!
responseDuration: anObject
	responseDuration := anObject! !

!ZnServerTransactionTiming methodsFor: 'accessing' stamp: ''!
requestDuration
	^ requestDuration! !

!ZnServerTransactionTiming methodsFor: 'accessing' stamp: ''!
responseDuration
	^ responseDuration! !

!ZnServerTransactionTiming methodsFor: 'accessing' stamp: ''!
handlerDuration: anObject
	handlerDuration := anObject! !

!ZnServerTransactionTiming methodsFor: 'accessing' stamp: ''!
handlerDuration
	^ handlerDuration! !

!ZnServerTransactionTiming methodsFor: 'accessing' stamp: ''!
requestDuration: anObject
	requestDuration := anObject! !

!ZnServerWriteErrorEvent commentStamp: ''!
ZnServerWriteErrorEvent signals an error during the writing of a response. These errors are considered mostly benign and the connection gets closed.
!
!ZnServerWriteErrorEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream << ' Server Write Error ';  print: exception! !

!ZnSignalProgress commentStamp: ''!
I am ZnSignalProgress.
I am a DynamicVariable and a ProcessSpecificVariable.

I can be used to indicate that Zn related code down the call stack has to signal HTTPProgress, for example:

ZnSignalProgress 
	value: true 
	during: [ ^ ZnClient new get: 'http://zn.stfx.eu/zn/small.html' ]!
!ZnSignalProgress class methodsFor: 'accessing' stamp: ''!
enabled
	"Answer if HTTPProgress should be signalled.
	The default is false."
	
	^ self value
		ifNil: [ false ]
		ifNotNil: [ :value | value ]! !

!ZnSimplifiedByteEncoder commentStamp: ''!
I am ZnSimplifiedByteEncoder, a concrete subclass of ZnCharacterEncoder.
I handle single byte encodings where byte values 0 to 127 map to ASCII and 128 to 255 are a permutation to Unicode characters.

I am like ZnByteEncoder, a subclass of me, but I implement just two mappings, latin1 or iso-8859-1 and ASCII, to conserve memory.!
!ZnSimplifiedByteEncoder methodsFor: 'initialize-release' stamp: ''!
byteToUnicode: map
	byteToUnicode := map! !

!ZnSimplifiedByteEncoder methodsFor: 'comparing' stamp: ''!
= anObject
	^ super = anObject and: [ self identifier = anObject identifier ]! !

!ZnSimplifiedByteEncoder methodsFor: 'initialize-release' stamp: ''!
beLenient
	"Don't be strict, which is the default.
	This means that holes in the mapping are let to pass through."

	strict := false! !

!ZnSimplifiedByteEncoder methodsFor: 'comparing' stamp: ''!
hash
	^ self identifier hash! !

!ZnSimplifiedByteEncoder methodsFor: 'converting' stamp: ''!
encodedByteCountFor: character
	"Overwritten for performance reasons"
	
	^ 1! !

!ZnSimplifiedByteEncoder methodsFor: 'accessing' stamp: ''!
identifier
	^ identifier! !

!ZnSimplifiedByteEncoder methodsFor: 'initialization' stamp: ''!
initialize
	super initialize.
	strict := true! !

!ZnSimplifiedByteEncoder methodsFor: 'accessing' stamp: ''!
byteDomain
	"Return an array with the byte values that are in my domain, that I can decode"
	
	^ (0 to: 127) asArray , ((byteToUnicode withIndexCollect: [ :each :index | each ifNotNil: [ index + 127 ] ]) reject: [ :each | each isNil ]) ! !

!ZnSimplifiedByteEncoder methodsFor: 'testing' stamp: ''!
isLenient
	^ strict not! !

!ZnSimplifiedByteEncoder methodsFor: 'converting' stamp: ''!
encodedByteCountForCodePoint: character
	^ 1! !

!ZnSimplifiedByteEncoder methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream
		nextPut: $(;
		print: identifier.
	strict
		ifTrue: [ stream nextPutAll: ' strict' ].
	stream nextPut: $)! !

!ZnSimplifiedByteEncoder methodsFor: 'initialize-release' stamp: ''!
identifier: object
	identifier := object! !

!ZnSimplifiedByteEncoder methodsFor: 'converting' stamp: ''!
backOnStream: stream
	stream back! !

!ZnSimplifiedByteEncoder methodsFor: 'testing' stamp: ''!
isStrict
	^ strict! !

!ZnSimplifiedByteEncoder methodsFor: 'converting' stamp: ''!
nextFromStream: stream
	"In non-strict mode, we let byte values for holes in our mapping pass through.
	Overwritten for performance reasons"

	| byteValue |
	^ (byteValue := stream next ifNil: [ ^ self errorIncomplete asCharacter ]) < 128
		ifTrue: [ Character value: byteValue ]
		ifFalse: [ 
			(byteToUnicode at: byteValue - 127 ifAbsent: [ nil ])
				ifNotNil: [ :unicode | unicode ]
				ifNil: [ 
					strict
						ifTrue: [ self errorOutsideRange ]
						ifFalse: [ Character value: byteValue ] ] ]! !

!ZnSimplifiedByteEncoder methodsFor: 'converting' stamp: ''!
nextCodePointFromStream: stream
	"In non-strict mode, we let byte values for holes in our mapping pass through"

	| byteValue |
	^ (byteValue := stream next) < 128
		ifTrue: [ byteValue ]
		ifFalse: [ 
			(byteToUnicode at: byteValue - 127 ifAbsent: [ nil ])
				ifNotNil: [ :unicode | unicode asInteger ]
				ifNil: [ 
					strict
						ifTrue: [ self errorOutsideRange ]
						ifFalse: [ byteValue ] ] ]! !

!ZnSimplifiedByteEncoder methodsFor: 'converting' stamp: ''!
nextPutCodePoint: codePoint toStream: stream
	"In non-strict mode, we let code points for holes in our mapping table pass through"
	
	codePoint < 128
		ifTrue: [ stream nextPut: codePoint ]
		ifFalse: [ 
			| byte |
			byte := unicodeToByte at: codePoint ifAbsent: [ nil ].
			(byte isNil and: [ strict or: [ codePoint > 255 ] ])
				ifTrue: [ self errorOutsideRange ].
			stream nextPut: (byte ifNil: [ codePoint ]) ]! !

!ZnSimplifiedByteEncoder methodsFor: 'initialize-release' stamp: ''!
unicodeToByte: map
	unicodeToByte := map! !

!ZnSimplifiedByteEncoder methodsFor: 'accessing' stamp: ''!
characterDomain
	"Return a set with the characters that are in my domain, that I can encode"

	^ ((0 to: 127) asSet, unicodeToByte keys) collect: [ :each | Character value: each  ]! !

!ZnSimplifiedByteEncoder class methodsFor: 'private' stamp: ''!
tablesFromSpec: mapping
	"Initialize the mappings to and from Unicode based on the 128 element array mapping"

	| byteToUnicode unicodeToByte |
	byteToUnicode := Array new: 128.
	unicodeToByte := Dictionary new.	
	"Mind the offset because first 128 characters are not stored into byteToUnicodeSpec"	
	"Note that some entries are nil"
	mapping
		keysAndValuesDo: [ :index :unicode | 
			unicode ifNotNil: [ 
				byteToUnicode at: index put: (Character value: unicode).
				unicodeToByte at: unicode put: 127 + index ] ].
	^ Array with: byteToUnicode with: unicodeToByte! !

!ZnSimplifiedByteEncoder class methodsFor: 'class initialization' stamp: ''!
initialize
	"Initialize and cache the converters that I know of.
	This includes all of their aliases.
	This method must be changed to make sure it runs 
	when loading in images where it is already present."
	
	self initializeByteTextConverters! !

!ZnSimplifiedByteEncoder class methodsFor: 'accessing' stamp: ''!
knownEncodingIdentifiers
	^ self byteTextConverters keys! !

!ZnSimplifiedByteEncoder class methodsFor: 'instance creation' stamp: ''!
newForEncoding: string
	"Return a new character encoder object for an encoding described by string.
	We use our precomputed ByteTextConverters tables."

	| tables canonicalName |
	canonicalName := self canonicalEncodingIdentifier: string.
	tables := self byteTextConverters at: canonicalName.
	^ self new
		identifier: canonicalName;
		byteToUnicode: tables first;
		unicodeToByte: tables second;
		yourself! !

!ZnSimplifiedByteEncoder class methodsFor: 'mappings' stamp: ''!
asciiMapping
	"ASCII is only defined for the first 127 codes (7-bit)"

	^ #(
	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 
	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 
	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 
	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 )! !

!ZnSimplifiedByteEncoder class methodsFor: 'private' stamp: ''!
initializeByteTextConverters
	"Initialize and cache convertors based on specifications in methods that were autogenerated."

	byteTextConverters := Dictionary new.
	self mappingToIdentifiers
		keysAndValuesDo: [ :mapping :identifiers | 
			| tables |
			tables := self tablesFromSpec: (self perform: mapping).
			identifiers do: [ :each | byteTextConverters at: each put: tables ] ].
	^ byteTextConverters! !

!ZnSimplifiedByteEncoder class methodsFor: 'accessing' stamp: ''!
handlesEncoding: string
	"Return true when my instances handle the encoding described by string"
	
	^ self byteTextConverters includesKey: (self canonicalEncodingIdentifier: string)! !

!ZnSimplifiedByteEncoder class methodsFor: 'mappings' stamp: ''!
iso88591Mapping
	"Specification generated by my optional subclass, ZnByteEncoder."
	"ZnByteEncoder 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 )! !

!ZnSimplifiedByteEncoder class methodsFor: 'private' stamp: ''!
byteTextConverters
	^ byteTextConverters ifNil: [ self initializeByteTextConverters ]! !

!ZnSimplifiedByteEncoder class methodsFor: 'mappings' stamp: ''!
mappingToIdentifiers
	"Return a dictionay mapping from encoding specifications to a list of encoding names."
	
	^ Dictionary newFromPairs: #( 
		#iso88591Mapping #('iso88591' 'latin1')
		#asciiMapping #('ascii') )! !

!ZnSimplifiedClientTransactionEvent commentStamp: ''!
ZnSimplifiedClientTransactionEvent is a ZnClientLogEvent that notes the completion of a client side HTTP transaction (request/response). Only a limited number of simpler data is held. ZnClientTransactionEvent contains much more detailed data.

Instance Variables
	method: HTTP verb
	url: ZnUrl requested
	response:	numeric response code
	size: number of bytes in response
	duration: milliseconds

ZnSimplifiedClientTransactionEvent is ideal for classic HTTP logging with little overhead through its default string representation.!
!ZnSimplifiedClientTransactionEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream space; nextPutAll: method.
	stream space.
	url printPathQueryFragmentOn: stream.
	stream space; print: response.
	size ifNotNil: [ 
		stream space; print: size; nextPut: $B ].
	stream space; print: duration; nextPutAll: 'ms'! !

!ZnSimplifiedClientTransactionEvent methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!ZnSimplifiedClientTransactionEvent methodsFor: 'initialize' stamp: ''!
initialize
	super initialize.
	duration := 0! !

!ZnSimplifiedClientTransactionEvent methodsFor: 'initialize' stamp: ''!
response: aZnResponse
	response := aZnResponse code.
	aZnResponse hasEntity
		ifTrue: [ size := aZnResponse entity contentLength ]! !

!ZnSimplifiedClientTransactionEvent methodsFor: 'initialize' stamp: ''!
responseDuration: responseDuration
	duration := duration + responseDuration ! !

!ZnSimplifiedClientTransactionEvent methodsFor: 'accessing' stamp: ''!
duration
	^ duration! !

!ZnSimplifiedClientTransactionEvent methodsFor: 'accessing' stamp: ''!
size
	^ size! !

!ZnSimplifiedClientTransactionEvent methodsFor: 'accessing' stamp: ''!
url
	^ url! !

!ZnSimplifiedClientTransactionEvent methodsFor: 'initialize' stamp: ''!
requestDuration: requestDuration
	duration := duration + requestDuration ! !

!ZnSimplifiedClientTransactionEvent methodsFor: 'accessing' stamp: ''!
responseCode
	^ response! !

!ZnSimplifiedClientTransactionEvent methodsFor: 'initialize' stamp: ''!
request: aZnRequest
	method := aZnRequest method.
	url := aZnRequest url! !

!ZnSimplifiedServerTransactionEvent commentStamp: ''!
ZnSimplifiedServerTransactionEvent is a ZnServerLogEvent that notes the completion of a served side HTTP transaction (request/response). Only a limited number of simpler data is held. ZnServerTransactionEvent contains much more detailed data.

Instance Variables
	method: HTTP verb
	url: ZnUrl requested
	response:	numeric response code
	size: number of bytes in response
	duration: milliseconds

ZnSimplifiedServerTransactionEvent is ideal for classic HTTP logging with little overhead through its default string representation.
!
!ZnSimplifiedServerTransactionEvent methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	stream space; nextPutAll: method.
	stream space.
	url printPathQueryFragmentOn: stream.
	stream space; print: response.
	size ifNotNil: [ 
		stream space; print: size; nextPut: $B ].
	stream space; print: duration; nextPutAll: 'ms'! !

!ZnSimplifiedServerTransactionEvent methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!ZnSimplifiedServerTransactionEvent methodsFor: 'initialize' stamp: ''!
response: aZnResponse
	response := aZnResponse code.
	aZnResponse hasEntity
		ifTrue: [ size := aZnResponse entity contentLength ]! !

!ZnSimplifiedServerTransactionEvent methodsFor: 'initialize' stamp: ''!
timing: timing
	duration := timing totalDuration ! !

!ZnSimplifiedServerTransactionEvent methodsFor: 'accessing' stamp: ''!
duration
	^ duration! !

!ZnSimplifiedServerTransactionEvent methodsFor: 'accessing' stamp: ''!
size
	^ size! !

!ZnSimplifiedServerTransactionEvent methodsFor: 'accessing' stamp: ''!
url
	^ url! !

!ZnSimplifiedServerTransactionEvent methodsFor: 'accessing' stamp: ''!
responseCode
	^ response! !

!ZnSimplifiedServerTransactionEvent methodsFor: 'initialize' stamp: ''!
request: aZnRequest
	method := aZnRequest method.
	url := aZnRequest url! !

!ZnSingleThreadedServer commentStamp: ''!
I am ZnSingleThreadedServer.
I can be customized with a delegate (#handleRequest:) and an authenticator (#authenticateRequest:do:).

  ZnSingleThreadedServer startDefaultOn: 1701.
  ZnSingleThreadedServer default authenticator: (ZnBasicAuthenticator username: 'foo' password: 'secret').
  ZnClient new username: 'foo' password: 'secret'; get: 'http://localhost:1701'.

I use ZnDefaultServerDelegate when no other delegate is set.
I am single threaded, I run in a single process.
I close connections after each request/response cycle.

Part of Zinc HTTP Components.!
!ZnSingleThreadedServer methodsFor: 'request handling' stamp: ''!
serveConnectionOn: listeningSocket
	"We wait up to acceptWaitTimeout seconds for an incoming connection.
	If we get one we wrap it in a SocketStream and #executeOneRequestResponseOn: on it.
	We do not fork a worker thread/process but stay in the current one for just one request/response cycle."

	| stream socket |
	socket := listeningSocket waitForAcceptFor: self acceptWaitTimeout.
	socket ifNil: [ ^ self noteAcceptWaitTimedOut ].
	stream := self socketStreamOn: socket.
	[ 
	[ self executeOneRequestResponseOn: stream ]
		ensure: [ 
			self logConnectionClosed: stream.
			stream close ] ]
		ifCurtailed: [ 
			socket destroy ]! !

!ZnSingleThreadedServer methodsFor: 'private' stamp: ''!
withMaximumNumberOfDictionaryEntriesDo: block
	^ self maximumNumberOfDictionaryEntries = ZnMaximumNumberOfDictionaryEntries value
			ifTrue: block
			ifFalse: [ 
				ZnMaximumNumberOfDictionaryEntries 
					value: self maximumNumberOfDictionaryEntries 
					during: block ]! !

!ZnSingleThreadedServer methodsFor: 'testing' stamp: ''!
isRunning
	"Return true when I am running"
	
	^ self process notNil and: [ self serverSocket notNil ]! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logRequest: request response: response handledStarted: initialMilliseconds
	^ logLevel < 3
		ifTrue: [ Time millisecondsSince: initialMilliseconds ]
		ifFalse: [ 
			(self newLogEvent: ZnRequestResponseHandledEvent)
				request: request;
				response: response;
				duration: (Time millisecondsSince: initialMilliseconds);
				emit;
				duration ]! !

!ZnSingleThreadedServer methodsFor: 'private' stamp: ''!
noteAcceptWaitTimedOut
	"The accept wait on a server socket timed out (see #acceptWaitTimeout).
	This can be used as an opportunity to do some periodic tasks."
	
	self periodicTasks! !

!ZnSingleThreadedServer methodsFor: 'request handling' stamp: ''!
writeResponse: response on: stream timing: timing
	"Write response to stream and flush the stream"
	
	| initialMilliseconds |
	initialMilliseconds := Time millisecondClockValue.
	self withDefaultCharacterEncoderDo: [ response writeOn: stream ].
	stream flush.
	timing responseDuration: (self logResponseWritten: response started: initialMilliseconds)  ! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logServerReadError: exception
	logLevel < 3 ifTrue: [ ^ nil ].
	^ (self newLogEvent: ZnServerReadErrorEvent)
		exception: exception;
		emit! !

!ZnSingleThreadedServer methodsFor: 'accessing' stamp: ''!
serverSocket
	"Return the server socket that I am using.
	Will be nil when I am not running"
	
	^ serverSocket! !

!ZnSingleThreadedServer methodsFor: 'private' stamp: ''!
serverProcessName
	^ String streamContents: [ :stream |
		stream nextPutAll: self class name; nextPutAll: ' HTTP port '; print: self port ]! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
newLogEvent: logEventClass
	^ logEventClass new
		serverId: self route;
		yourself! !

!ZnSingleThreadedServer methodsFor: 'logging' stamp: ''!
loggingOff
	"Turn logging completely off - do not generate log events."
	
	self logLevel: 0! !

!ZnSingleThreadedServer methodsFor: 'initialization' stamp: ''!
initialize
	self loggingOn ! !

!ZnSingleThreadedServer methodsFor: 'request handling' stamp: ''!
readRequest: stream timing: timing
	"Read a request from stream.
	We add a virtual header containing the remote IP address of the client"

	| request initialMilliseconds |
	initialMilliseconds := Time millisecondClockValue.
	request := self withMaximumEntitySizeDo: [ 
		self withMaximumNumberOfDictionaryEntriesDo: [ 
			self withDefaultCharacterEncoderDo: [
				self reader value: stream ] ] ].
	request headers 
		at: ZnConstants remoteAddressHeader
		put: (ZnNetworkingUtils ipAddressToString: stream socket remoteAddress).
	timing requestDuration:  (self logRequestRead: request started: initialMilliseconds).
	^ request! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logConnectionClosed: socketStream
	logLevel < 3 ifTrue: [ ^ nil ].
	socketStream socket ifNil: [ ^ nil ].
	^ (self newLogEvent: ZnServerConnectionClosedEvent)
		address: ([ socketStream socket remoteAddress] on: Error do: [ nil ]);
		emit! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logServerSocketReleasedAddress: address port: port
	logLevel < 1 ifTrue: [ ^ nil ].
	^ (self newLogEvent: ZnServerSocketReleasedEvent)
		address: address;
		port: port;
		emit! !

!ZnSingleThreadedServer methodsFor: 'private' stamp: ''!
withDefaultCharacterEncoderDo: block
	^ self defaultEncoder = ZnDefaultCharacterEncoder value
			ifTrue: block
			ifFalse: [ 
				ZnDefaultCharacterEncoder 
					value: self defaultEncoder  
					during: block ]! !

!ZnSingleThreadedServer methodsFor: 'private' stamp: ''!
initializeServerSocket
	"Set up a new server socket and listen on it"
	
	serverSocket := self bindingAddress
		ifNil: [ ZnNetworkingUtils serverSocketOn: self port ]
		ifNotNil: [ ZnNetworkingUtils serverSocketOn: self port interface: self bindingAddress ].
	"Binding a server socket to port 0 means letting the OS assign a port, fetch it"
	self port isZero 
		ifTrue: [ self optionAt: #port put: serverSocket port ].
	self logServerSocketBound! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logResponseWritten: response started: initialMilliseconds
	^ logLevel < 3
		ifTrue: [ Time millisecondsSince: initialMilliseconds ]
		ifFalse: [ 
			(self newLogEvent: ZnResponseWrittenEvent)
				response: response;
				duration: (Time millisecondsSince: initialMilliseconds);
				emit;
				duration ]! !

!ZnSingleThreadedServer methodsFor: 'accessing' stamp: ''!
onRequestRespond: block
	"Convenience method to quickly set up a delegate.
	On any incoming request, block will be executed with the request 
	as argument to produce a valid response."
	
	self delegate: (ZnValueDelegate with: block)  ! !

!ZnSingleThreadedServer methodsFor: 'public' stamp: ''!
stop: unregister
	"Stop me. I will stop listening on my port for incoming HTTP connections.
	If unregister is true, unregister me from the list of managed instances.
	Does nothing when I am not running"
	
	self isRunning ifFalse: [ ^ self ].
	process terminate. 
	process := nil.
	unregister ifTrue: [ self unregister ].
	self closeDelegate.
	self logStopped! !

!ZnSingleThreadedServer methodsFor: 'accessing' stamp: ''!
process
	"Return the process that is running my main listening loop.
	Will be nil when I am not running"
	
	^ process! !

!ZnSingleThreadedServer methodsFor: 'testing' stamp: ''!
isListening
	"Return true when I have a valid server socket listening at the correct port"
	
	^ self serverSocket notNil
		and: [ self serverSocket isValid and: [ self serverSocket localPort = self port ] ]! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logServerGeneric: subject
	^ (self newLogEvent: ZnServerGenericLogEvent)
		subject: subject;
		emit! !

!ZnSingleThreadedServer methodsFor: 'logging' stamp: ''!
logLevel: integer
	"Set the log level to integer.
	0 - no logging
	1 - simplified transaction logging
	2 - detailed transaction logging
	3 - log everything"
	
	logLevel := integer! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logServerTransactionRequest: request response: response timing: timing
	| logEventClass |
	logLevel < 1 ifTrue: [ ^ nil ].
	logEventClass := logLevel = 1
		ifTrue: [ ZnSimplifiedServerTransactionEvent ]
		ifFalse: [ ZnServerTransactionEvent ].
	^ (self newLogEvent: logEventClass)
		request: request;
		response: response;
		timing: timing;
		emit! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logServerSocketBound
	logLevel < 1 ifTrue: [ ^ nil ].
	^ (self newLogEvent: ZnServerSocketBoundEvent)
		address: ([ serverSocket address ] on: Error do: [ nil ]);
		port: ([ serverSocket port ] on: Error do: [ nil ]);
		emit! !

!ZnSingleThreadedServer methodsFor: 'request handling' stamp: ''!
executeOneRequestResponseOn: stream
	"Execute one single HTTP request / response cycle on stream in 3 steps:
	#readRequest: #handleRequest: and #writeResponse:on:
	Indicate that we intend to close the connection afterwards"

	| request response timing|
	ZnCurrentServer
		value: self
		during: [ 
			timing := ZnServerTransactionTiming new.
			request := self readRequest: stream timing: timing.
			response := self handleRequest: request timing: timing.
			response setConnectionClose.
			self writeResponse: response on: stream timing: timing.
			self logServerTransactionRequest: request response: response timing: timing ]! !

!ZnSingleThreadedServer methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	stream nextPut: $(.
	stream nextPutAll: (self isRunning ifTrue: [ 'running' ] ifFalse: [ 'stopped' ]).
	self port ifNotNil: [ :port | stream space; print: port ].
	self bindingAddress ifNotNil: [ :bindingAddress | stream space; print: bindingAddress ].
	stream nextPut: $)! !

!ZnSingleThreadedServer methodsFor: 'request handling' stamp: ''!
authenticateAndDelegateRequest: request
	"Handle request and return a response.
	If we have a delegate, pass the responsibility.
	If we have no delegate, we return a page not found.
	Make sure to pass via our authenticator."

	^ self
		authenticateRequest: request
		do: [ 
			self delegate
				ifNil: [ ZnResponse notFound: request uri ]
				ifNotNil: [ :delegate | delegate handleRequest: request ] ]! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logStarted
	logLevel < 1 ifTrue: [ ^ nil ].
	^ (self newLogEvent: ZnServerStartedEvent)
		description: self serverProcessName;
		emit! !

!ZnSingleThreadedServer methodsFor: 'request handling' stamp: ''!
authenticateRequest: request do: block
	"Validate request and execute block.
	When our authenticator is not nil, pass the responsibility"

	^ self authenticator
		ifNil: [ block value ]
		ifNotNil: [ :authenticator | authenticator authenticateRequest: request do: block ]! !

!ZnSingleThreadedServer methodsFor: 'private' stamp: ''!
periodicTasks
	"Every #acceptWaitTimeout seconds this method is called.
	Note that during this time the server is not actively listening for connections."
	
	sessionManager ifNotNil: [ sessionManager cleanupInvalidSessions ]! !

!ZnSingleThreadedServer methodsFor: 'private' stamp: ''!
withMaximumEntitySizeDo: block
	^ self maximumEntitySize = ZnMaximumEntitySize value
			ifTrue: block
			ifFalse: [ 
				ZnMaximumEntitySize 
					value: self maximumEntitySize  
					during: block ]! !

!ZnSingleThreadedServer methodsFor: 'request handling' stamp: ''!
augmentResponse: response forRequest: request
	"Our handler has produced response for request, manipulate the response before writing it"
	
	(self useGzipCompressionAndChunking and: [ response contentType isBinary not ])
		ifTrue: [ 
			(request acceptsEncodingGzip and: [ response hasContentEncoding not ]) 
				ifTrue: [ response setContentEncodingGzip ].
			response hasTransferEncoding
				ifFalse: [ response setTransferEncodingChunked ] ]! !

!ZnSingleThreadedServer methodsFor: 'private' stamp: ''!
socketStreamOn: socket
	self logConnectionAccepted: socket.
	^ ZnNetworkingUtils socketStreamOn: socket! !

!ZnSingleThreadedServer methodsFor: 'request handling' stamp: ''!
listenLoop
	"We create a listening Socket, then wait for a connection.
	After each connection we also check that the listening Socket is still valid 
	- if not we just make a recursive call to this method to start over."

	self initializeServerSocket.
	[ [ 
		serverSocket isValid
			 ifFalse: [
				"will trigger #ifCurtailed: block and destroy socket"
				^ self listenLoop ].
		self serveConnectionOn: serverSocket ] repeat ]

		ifCurtailed: [ self releaseServerSocket ]! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logServerWriteError: exception
	logLevel < 3 ifTrue: [ ^ nil ].
	^ (self newLogEvent: ZnServerWriteErrorEvent)
		exception: exception;
		emit! !

!ZnSingleThreadedServer methodsFor: 'constants' stamp: ''!
acceptWaitTimeout
	"How many seconds to wait for a server socket listening for an accept ?"
	
	^ 300! !

!ZnSingleThreadedServer methodsFor: 'logging' stamp: ''!
logToTranscript
	"Setup logging to the Transcript.
	If logging was completely off, turn it on"

	logLevel isZero ifTrue: [ self loggingOn ].
	ZnLogEvent logToTranscript ! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logRequestRead: request started: initialMilliseconds
	^ logLevel < 3
		ifTrue: [ Time millisecondsSince: initialMilliseconds ]
		ifFalse: [ 
			(self newLogEvent: ZnRequestReadEvent)
				request: request;
				duration: (Time millisecondsSince: initialMilliseconds);
				emit;
				duration ]! !

!ZnSingleThreadedServer methodsFor: 'private' stamp: ''!
closeDelegate
	self delegate
		ifNotNil: [ :delegate | 
			(delegate respondsTo: #close)
				ifTrue: [ delegate close ] ]! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logConnectionAccepted: socket
	logLevel < 3 ifTrue: [ ^ nil ].
	^ (self newLogEvent: ZnConnectionAcceptedEvent)
		address: ([ socket remoteAddress ] on: Error do: [ nil ]);
		emit! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logServerHandlerError: exception
	^ (self newLogEvent: ZnServerHandlerErrorEvent)
		exception: exception;
		emit! !

!ZnSingleThreadedServer methodsFor: 'logging' stamp: ''!
loggingOn
	"Turn full logging on - generate all log events"
	
	self logLevel: 3! !

!ZnSingleThreadedServer methodsFor: 'private' stamp: ''!
releaseServerSocket
	"Release our server socket"
	
	| address port |
	serverSocket ifNil: [ ^ self ].
	address := [ serverSocket address ] on: Error do: [ nil ].
	port := [ serverSocket port ]on: Error do: [ nil ].
	(Delay forMilliseconds: 10) wait.
	serverSocket destroy.
	serverSocket := nil.
	self logServerSocketReleasedAddress: address port: port ! !

!ZnSingleThreadedServer methodsFor: 'public' stamp: ''!
start
	"Start me. I will start listening on my port for incoming HTTP connections.
	If I am running, I will first stop and thus effectively restart"
	
	self stop: false.
	self class default = self ifTrue: [ self register ].
	process := [ [ self listenLoop ] repeat ]
		forkAt: Processor highIOPriority 
		named: self serverProcessName.
	self logStarted.
! !

!ZnSingleThreadedServer methodsFor: 'request handling' stamp: ''!
handleRequestProtected: request
	"Handle request and return a response.
	If a ZnRespond notification is signaled, return its response directly.
	If an Error is thrown, return a HTTP Server Error response."

	^ [ [ self authenticateAndDelegateRequest: request ]
			on: ZnRespond 
			do: [ :notification | notification response ] ]
		on: Error
		do: [ :exception | 
			self debugMode
				ifTrue: [ exception pass ]
				ifFalse: [
					self logServerHandlerError: exception.
					ZnResponse serverError: exception printString ] ]! !

!ZnSingleThreadedServer methodsFor: 'request handling' stamp: ''!
handleRequest: request timing: timing
	"Handle request and return a response.
	Do logging and timing. Set a dynamic variable referencing the server.
	If necessary do session management in the response."

	| response initialMilliseconds |
	initialMilliseconds := Time millisecondClockValue.
	ZnCurrentServerSession value: nil.
	response := self handleRequestProtected: request.
	request method = #HEAD
		ifTrue: [ response clearEntity ].
	timing handlerDuration: (self logRequest: request response: response handledStarted: initialMilliseconds).
	ZnCurrentServerSession value 
		ifNotNil: [ :session | self sessionManager setSession: session in: response ].
	^ response! !

!ZnSingleThreadedServer methodsFor: 'private - logging' stamp: ''!
logStopped
	logLevel < 1 ifTrue: [ ^ nil ].
	^ (self newLogEvent: ZnServerStoppedEvent)
		description: self serverProcessName;
		emit! !

!ZnSingleThreadedServer class methodsFor: 'class initialization' stamp: ''!
initialize
	default := nil! !

!ZnSingleThreadedServer class methodsFor: 'public' stamp: ''!
adoptAsDefault: server
	"Adopt server as the default instance that we manage.
	If there was a previous default, stop it.
	Note that this is a class instance variable."
	
	self stopDefault.
	default := server! !

!ZnSingleThreadedServer class methodsFor: 'public' stamp: ''!
startDefaultOn: portNumber
	"Start and return the default instance on a given port.
	Keep a reference to it in a class instance variable.
	If there was no previous default instance, create a new one.
	If there was a previous default instance, reuse it:
	if it was running stop and start it, effectively restarting it.
	Change the port if necessary.
	Starting the default server will register it automatically."

	^ (self defaultOn: portNumber) 
		start; 
		yourself! !

!ZnSingleThreadedServer class methodsFor: 'public' stamp: ''!
on: aNumber
	"Instantiate and return a new listener on a given port,
	send #start to it to start listening."

	^ self new 
		port: aNumber; 
		yourself! !

!ZnSingleThreadedServer class methodsFor: 'public' stamp: ''!
defaultOn: portNumber
	"Return the default instance on a given port,
	Keep a reference to it in a class instance variable.
	If there was no previous default instance, create a new one.
	If there was a previous default instance, reuse it:
	if it was running stop it, change the port if necessary."

	^ default 
		ifNil: [
			default := self on: portNumber ] 
		ifNotNil: [ 
			default stop; port: portNumber; yourself ]! !

!ZnSingleThreadedServer class methodsFor: 'public' stamp: ''!
stopDefault
	"Stop and unregister the Default instance, if any, and clear it.
	Return the stopped instance, if any."
	
	| server |
	(server := default) ifNotNil: [ 
		default stop.  
		default := nil ].
	^ server! !

!ZnSingleThreadedServer class methodsFor: 'public' stamp: ''!
default
	"Return the default instance that we manage.
	Note that this is a class instance variable."
	
	^ default! !

!ZnSingleThreadedServer class methodsFor: 'public' stamp: ''!
startOn: portNumber
	"Instanciate and return a new listener on a given port and start listening."

	^ (self on: portNumber) 
		start;
		yourself! !

!ZnStaticFileServerDelegate commentStamp: ''!
I am ZnStaticFileServerDelegate.
I am a simple proof of concept implementation of a web server serving static files.
I handle urls with an optional prefix as requests for files in a directory.
I serve index.html or index.htm when a directory is requested and these files exist.
I do a redirect when a path that is not does not end with a / refers to directory.
I function as a delegate for ZnServer.

ZnServer startDefaultOn: 1701.
ZnServer default delegate: ((ZnStaticFileServerDelegate new) 
									prefixFromString: 'apple/macosx'; 
									directory: '/Library/WebServer/Documents' asFileReference; 
									yourself).

Part of Zinc HTTP Components.!
!ZnStaticFileServerDelegate methodsFor: 'private' stamp: ''!
redirectNeededFor: uri actualFilename: actualFilename
	uri isDirectoryPath ifTrue: [ ^ false ].  
	^ (actualFilename endsWith: uri lastPathSegment) not! !

!ZnStaticFileServerDelegate methodsFor: 'public' stamp: ''!
value: request
	"I implement the generic #value: message as equivalent to #handleRequest:"
	
	^ self handleRequest: request! !

!ZnStaticFileServerDelegate methodsFor: 'private' stamp: ''!
directoryRedirectFor: uri
	| directoryUri |
	directoryUri := uri copy addPathSegment: #/.  
	^ ZnResponse redirect: directoryUri ! !

!ZnStaticFileServerDelegate methodsFor: 'accessing' stamp: ''!
prefix: orderedCollection
	"Set the path prefix under which I should be serving files to orderedCollection containing path elements"
	
	prefix := orderedCollection! !

!ZnStaticFileServerDelegate methodsFor: 'private' stamp: ''!
expirationDateFor: aMimeType
	| expiration |
	expiration := self mimeTypeExpirations at: aMimeType ifAbsent: [ ^ nil ].
	^ ZnUtils httpDate: (DateAndTime now asUTC + expiration seconds)! !

!ZnStaticFileServerDelegate methodsFor: 'private' stamp: ''!
responseForFile: filename fromRequest: aRequest
	| file entry size time mimeType fileStream entity response modified |
	file := filename asFileReference.
	entry := file entry.
	size := entry size.
	time := entry modificationTime.
	modified := true.
	aRequest headers
		at: 'If-Modified-Since'
		ifPresent: [ modified := time > (ZnUtils parseHttpDate: (aRequest headers at: 'If-Modified-Since')) ].
	modified
		ifTrue: [ 
			mimeType := ZnMimeType forFilenameExtension: file extension.
			fileStream := file binaryReadStream.
			(entity := ZnStreamingEntity type: mimeType length: size) 
				stream: fileStream.
			(response := ZnResponse ok: entity) 
				headers at: 'Modification-Date' put: (ZnUtils httpDate: time).
			(self maxAgeFor: mimeType) 
				ifNotNil: [ :maxAge | response headers at: 'Cache-Control' put: maxAge ].
			(self expirationDateFor: mimeType)
				ifNotNil: [ :expirationDate | response headers at: 'Expires' put: expirationDate ] ]
		ifFalse: [ response := ZnResponse notModified ].
	^ response! !

!ZnStaticFileServerDelegate methodsFor: 'accessing' stamp: ''!
directory: fileDirectory
	"Set the directory whose files I should be serving"

	directory := fileDirectory! !

!ZnStaticFileServerDelegate methodsFor: 'private' stamp: ''!
maxAgeFor: aMimeType
	| expiration |
	expiration := self mimeTypeExpirations at: aMimeType ifAbsent: [ ^ nil ].
	^ 'max-age=', expiration asString! !

!ZnStaticFileServerDelegate methodsFor: 'accessing' stamp: ''!
directory
	"The directory whose files I am serving"
	
	^ directory ! !

!ZnStaticFileServerDelegate methodsFor: 'private' stamp: ''!
indexFileIn: fileDirectory
	#( 'index.html' 'index.htm' ) do: [ :each | | file |
			(file := fileDirectory / each) exists
				ifTrue: [ 
					^ file fullName ] ].
	^ nil
! !

!ZnStaticFileServerDelegate methodsFor: 'private' stamp: ''!
actualFilenameFor: uri
	| subElements subDir entry |
	(uri isEmpty and: [ self prefix isEmpty ]) ifTrue: [ ^ self indexFileIn: self directory ].
	(self prefix isEmpty or: [ uri isEmpty not and: [ uri pathSegments beginsWith: self prefix ] ]) ifFalse: [ ^ nil ].
	subElements := (uri pathSegments allButFirst: self prefix size) reject: [ :each | each = #/ ].
	subDir := subElements allButLast inject: self directory into: [ :parent :sub | | file |
		(file := parent / sub) exists
			ifTrue: [ file ]
			ifFalse: [ ^ nil ] ]. 
	subElements isEmpty
		ifTrue: [ entry := subDir entry ] 
		ifFalse: [ | file |
			 (file := subDir / subElements last) exists 
				ifTrue: [ entry := file entry ] 
				ifFalse: [ ^ nil ] ].
	^ entry isDirectory 
		ifTrue: [ self indexFileIn: entry reference ]
		ifFalse: [ entry reference fullName ]! !

!ZnStaticFileServerDelegate methodsFor: 'accessing' stamp: ''!
prefix
	"The path prefix collection under which I am serving files"
	
	^ prefix ifNil: [ prefix := #() ]! !

!ZnStaticFileServerDelegate methodsFor: 'accessing' stamp: ''!
mimeTypeExpirations
	"Return a dictionary mapping ZnMimeTypes to their expiration time in seconds.
	Missing entries will have no expiration time."

	^ mimeTypeExpirations ifNil: [ mimeTypeExpirations := Dictionary new ]! !

!ZnStaticFileServerDelegate methodsFor: 'accessing' stamp: ''!
mimeTypeExpirations: aDictionary
	"Set the mapping of ZnMimeTypes to their expiration time in seconds to aDictionary.
	Missing entries will have no expiration time."

	mimeTypeExpirations := aDictionary! !

!ZnStaticFileServerDelegate methodsFor: 'public' stamp: ''!
handleRequest: request
	"Server delegate entry point"

	| actualFilename |
	(#(#GET #HEAD) includes: request method)
		ifFalse: [ ^ ZnResponse methodNotAllowed: request ].
	actualFilename := self actualFilenameFor: request uri.
	^ actualFilename notNil
		ifTrue: [ 
			(self redirectNeededFor: request uri actualFilename: actualFilename)
				ifTrue: [ self directoryRedirectFor: request uri ]
				ifFalse: [ self responseForFile: actualFilename fromRequest: request ] ]
		ifFalse: [ ZnResponse notFound: request uri ]! !

!ZnStaticFileServerDelegate methodsFor: 'accessing' stamp: ''!
prefixFromString: string
	"Set the path prefix under which I should be serving files to string,
	interpreting each /-separated token as a path element"

	self prefix: (string findTokens: '/')! !

!ZnStaticFileServerDelegate class methodsFor: 'accessing' stamp: ''!
defaultMimeTypeExpirations
	"Return a default dictionary mapping ZnMimeTypes to their expiration time in seconds.
	Missing entries will have no expiration time."

	| dict |
	dict := Dictionary new.
	dict at: ZnMimeType textCss put: 30 days asSeconds.
	dict at: ZnMimeType textJavascript put: 30 days asSeconds.
	dict at: ZnMimeType textPlain put: 30 days asSeconds.
	dict at: ZnMimeType textHtml put: 30 days asSeconds.
	dict at: ZnMimeType imageGif put: 30 days asSeconds.
	dict at: ZnMimeType imageJpeg put: 30 days asSeconds.
	dict at: ZnMimeType imagePng put: 30 days asSeconds.
	dict at: ZnMimeType applicationJavascript put: 30 days asSeconds.
	^ dict! !

!ZnStaticFileServerDelegateTest methodsFor: 'private' stamp: ''!
wideHtml
	^ '<html><h1>Czech is in Czech {1}e{2}tina.</h1></html>' format: { 269 asCharacter. 353 asCharacter}.! !

!ZnStaticFileServerDelegateTest methodsFor: 'running' stamp: ''!
tearDown
	ZnFileSystemUtils 
		deleteIfExists: 'small.html'; 
		deleteIfExists: 'large.html'; 
		deleteIfExists: 'wide.html'.
	super tearDown	
	! !

!ZnStaticFileServerDelegateTest methodsFor: 'tests' stamp: ''!
testIfModifiedSinceNotModified
	self withServerDo: [ :server | | client |
		(client := ZnClient new) 
			beOneShot;
			url: server localUrl;
			addPath: #('local-files' 'small.html');
			"We have to cheat a little bit since our #setUp just created the file,
			it does not alter the semantics of what we try to test"
			setIfModifiedSince: (Date today addDays: 2);
			get.
		self assert: client response isNotModified.
		self deny: client response hasEntity ]! !

!ZnStaticFileServerDelegateTest methodsFor: 'tests' stamp: ''!
testBasicGet
	self
		withServerDo: [ :server | 
			| client |
			(client := ZnClient new)
				beOneShot;
				url: server localUrl;
				addPath: #('local-files' 'small.html');
				get.
			self assert: client isSuccess.
			self assert: client response contentType equals: ZnMimeType textHtml.
			self assert: client contents equals: self smallHtml.
			self assert: (ZnUtils parseHttpDate: (client response headers at: 'Modification-Date')) equals: (ZnFileSystemUtils modificationTimeFor: 'small.html') asUTC.
			self assert: (ZnUtils parseHttpDate: (client response headers at: 'Expires')) > (DateAndTime now + 10 days).
			self assert: (client response headers at: 'Cache-Control') equals: (server delegate maxAgeFor: ZnMimeType textHtml) ]! !

!ZnStaticFileServerDelegateTest methodsFor: 'private' stamp: ''!
largeHtml
	^ String streamContents: [ :out |
		out << '<html><body>'.
		out << 'Les élèves Français'.
		(1 to: 4000) do: [ :each | out print: each ] separatedBy: [ out space ]. 
		out << '</html></body>' ]! !

!ZnStaticFileServerDelegateTest methodsFor: 'tests' stamp: ''!
testBasicGetWide
	self
		withServerDo: [ :server | 
			| client |
			(client := ZnClient new)
				beOneShot;
				url: server localUrl;
				addPath: #('local-files' 'wide.html');
				get.
			self assert: client isSuccess.
			self assert: client response contentType equals: ZnMimeType textHtml.
			self assert: client contents equals: self wideHtml.
			self assert: (ZnUtils parseHttpDate: (client response headers at: 'Modification-Date')) equals: (ZnFileSystemUtils modificationTimeFor: 'large.html') asUTC.
			self assert: (ZnUtils parseHttpDate: (client response headers at: 'Expires')) > (DateAndTime now + 10 days).
			self assert: (client response headers at: 'Cache-Control') equals: (server delegate maxAgeFor: ZnMimeType textHtml) ]! !

!ZnStaticFileServerDelegateTest methodsFor: 'tests' stamp: ''!
testBasicGetLarge
	self
		withServerDo: [ :server | 
			| client |
			(client := ZnClient new)
				beOneShot;
				url: server localUrl;
				addPath: #('local-files' 'large.html');
				get.
			self assert: client isSuccess.
			self assert: client response contentType equals: ZnMimeType textHtml.
			self assert: client contents equals: self largeHtml.
			self assert: (ZnUtils parseHttpDate: (client response headers at: 'Modification-Date')) equals: (ZnFileSystemUtils modificationTimeFor: 'large.html') asUTC.
			self assert: (ZnUtils parseHttpDate: (client response headers at: 'Expires')) > (DateAndTime now + 10 days).
			self assert: (client response headers at: 'Cache-Control') equals: (server delegate maxAgeFor: ZnMimeType textHtml) ]! !

!ZnStaticFileServerDelegateTest methodsFor: 'tests' stamp: ''!
testBasicHead
	self
		withServerDo: [ :server | 
			| client |
			(client := ZnClient new)
				beOneShot;
				url: server localUrl;
				addPath: #('local-files' 'small.html');
				head.
			self assert: client isSuccess.
			self assert: client response contentType equals: ZnMimeType textHtml.
			self deny: client response hasEntity.
			self assert: (ZnUtils parseHttpDate: (client response headers at: 'Modification-Date')) equals: (ZnFileSystemUtils modificationTimeFor: 'small.html') asUTC.
			self assert: (ZnUtils parseHttpDate: (client response headers at: 'Expires')) > (DateAndTime now + 10 days).
			self assert: (client response headers at: 'Cache-Control') equals: (server delegate maxAgeFor: ZnMimeType textHtml) ]! !

!ZnStaticFileServerDelegateTest methodsFor: 'private' stamp: ''!
withServerDo: block
	| server staticFileServerDelegate |
	server := ZnServer on: 1700 + 32 atRandom.
	[ 
		(staticFileServerDelegate := ZnStaticFileServerDelegate new)
			prefixFromString: 'local-files'; 
			directory: ZnFileSystemUtils defaultDirectory;
			mimeTypeExpirations: ZnStaticFileServerDelegate defaultMimeTypeExpirations. 
		server delegate: staticFileServerDelegate.
		server start.
		self 
			assert: server isRunning & server isListening
			description: ('Failed to start server on port {1}. Is there one already?' format: { server port }).
		block cull: server
	] 
		ensure: [ server stop ]! !

!ZnStaticFileServerDelegateTest methodsFor: 'private' stamp: ''!
smallHtml
	^ '<html>
<head><title>Small</title></head>
<body><h1>Small</h1><p>This is a small HTML document</p></body>
</html>
'! !

!ZnStaticFileServerDelegateTest methodsFor: 'running' stamp: ''!
setUp
	super setUp.
	ZnFileSystemUtils
		newFileNamed: 'small.html' 
		do: [ :stream |
			stream nextPutAll: self smallHtml ].
	ZnFileSystemUtils
		newFileNamed: 'large.html' 
		do: [ :stream |
			stream nextPutAll: self largeHtml ].
	ZnFileSystemUtils
		newFileNamed: 'wide.html' 
		do: [ :stream |
			stream nextPutAll: self wideHtml ].! !

!ZnStatusLine commentStamp: ''!
I am an HTTP Status Line.
I consist of an HTTP protocol version, an integer HTTP status code and an HTTP reason string.
I can be used for generating and parsing.

Part of Zinc HTTP Components.!
!ZnStatusLine methodsFor: 'accessing' stamp: ''!
code
	^ code! !

!ZnStatusLine methodsFor: 'comparing' stamp: ''!
= other
	self class = other class ifFalse: [ ^ false ].
	^ self code = other code 
		and: [ self version = other version
			and: [ self reason = other reason ] ]! !

!ZnStatusLine methodsFor: 'comparing' stamp: ''!
hash
	^ (self code hash bitXor: self version hash) bitXor: self reason hash! !

!ZnStatusLine methodsFor: 'writing' stamp: ''!
writeOn: stream
	| writeStream |
	writeStream := ZnBivalentWriteStream on: stream.
	writeStream nextPutAll: self version; space.
	self code printOn: writeStream.
	writeStream space; nextPutAll: self reason; nextPutAll: String crlf ! !

!ZnStatusLine methodsFor: 'printing' stamp: ''!
printCodeAndReasonOn: stream
	self code
		ifNotNil: [
			stream print: self code; space; nextPutAll: self reason ]! !

!ZnStatusLine methodsFor: 'accessing' stamp: ''!
reason
	reason ifNil: [ 
		reason := ZnConstants httpStatusCodes 
			at: self code 
			ifAbsent: [ 'Unknown Status Code' ] ].
	^ reason! !

!ZnStatusLine methodsFor: 'accessing' stamp: ''!
version: string
	version := ZnConstants knownHTTPVersions 
		detect: [ :each | each = string ] 
		ifNone: [ (ZnUnknownHttpVersion version: string) signal ] ! !

!ZnStatusLine methodsFor: 'printing' stamp: ''!
printOn: stream
	super printOn: stream.
	self code ifNil: [ ^ self ].
	stream nextPut: $(.
	self printCodeAndReasonOn: stream.
	stream nextPut: $)! !

!ZnStatusLine methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!ZnStatusLine methodsFor: 'initialize-release' stamp: ''!
readFrom: stream
	| line lineStream httpCode |
	line := (ZnLineReader on: stream) nextLine.
	lineStream := line readStream.
	self version: (lineStream upTo: Character space).
	httpCode := lineStream upTo: Character space.
	httpCode := Integer readFrom: httpCode ifFail: [ (ZnUnknownHttpStatusCode code: httpCode) signal ].
	self code: httpCode.
	self reason: (lineStream upToEnd)
! !

!ZnStatusLine methodsFor: 'accessing' stamp: ''!
code: integer
	(ZnConstants httpStatusCodes includesKey: integer) 
		ifFalse: [
			(integer between: 100 and: 599)
				ifFalse: [
					(ZnUnknownHttpStatusCode code: integer) signal ] ].
	code := integer! !

!ZnStatusLine methodsFor: 'accessing' stamp: ''!
reason: string
	reason := string! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
notModified
	^ self code: 304! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
internalServerError
	^ self code: 500! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
found
	^ self code: 302! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
seeOther
	^ self code: 303! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
forbidden
	^ self code: 403! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
ok
	^ self code: 200! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
movedPermanently
	^ self code: 301! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
notFound
	^ self code: 404! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
redirect
	^ self code: 302! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
notImplemented
	^ self code: 501! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
accepted
	^ self code: 202! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
methodNotAllowed
	^ self code: 405! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
noContent
	^ self code: 204! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
unauthorized
	^ self code: 401! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
created
	^ self code: 201! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
readFrom: stream
	^ self new
		readFrom: stream;
		yourself! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
badRequest
	^ self code: 400! !

!ZnStatusLine class methodsFor: 'instance creation' stamp: ''!
code: code
	^ self new
		code: code;
		version: ZnConstants defaultHTTPVersion;
		yourself! !

!ZnStatusLineTest methodsFor: 'testing' stamp: ''!
testReading
	| statusLine string |
	string := 'HTTP/1.1 200 OK' , String crlf.
	statusLine := ZnStatusLine readFrom: string readStream.
	self assert: statusLine code equals: 200.
	self assert: statusLine reason equals: 'OK'.
	self assert: statusLine version equals: ZnConstants defaultHTTPVersion! !

!ZnStatusLineTest methodsFor: 'testing' stamp: ''!
testReadingNonStandardCode
	| string statusLine |
	"There exist non-standard codes out there, like those from cloudflare"
	string := 'HTTP/1.1 525 SSL Handshake Failed', String crlf.
	statusLine := ZnStatusLine readFrom: string readStream.
	self assert: statusLine code equals: 525.
	self assert: statusLine reason equals: 'SSL Handshake Failed'! !

!ZnStatusLineTest methodsFor: 'testing' stamp: ''!
testReadingWrongVersion
	| string |
	string := 'HTTP/0.9 200 OK', String crlf.
	self should: [ ZnStatusLine readFrom: string readStream ] raise: ZnUnknownHttpVersion! !

!ZnStatusLineTest methodsFor: 'testing' stamp: ''!
testReadingWrongCode
	| string |
	string := 'HTTP/1.0 1000 OK', String crlf.
	self should: [ ZnStatusLine readFrom: string readStream ] raise: ZnUnknownHttpStatusCode ! !

!ZnStatusLineTest methodsFor: 'testing' stamp: ''!
testWriting
	| statusLine string |
	statusLine := ZnStatusLine ok.
	string := String streamContents: [ :stream | statusLine writeOn: stream ].
	self assert: string equals: 'HTTP/1.1 200 OK' , String crlf! !

!ZnStatusLineTest methodsFor: 'testing' stamp: ''!
testInitialization
	"Make sure everything is properly initialized"
	
	ZnConstants officialHTTPStatusCodesSpec pairsDo: [ :code :reason |
		| statusLine |
		statusLine := ZnStatusLine code: code.
		self assert: statusLine code equals: code.
		self assert: statusLine reason equals: reason ]! !

!ZnStatusLineTest methodsFor: 'testing' stamp: ''!
testReadingWrongVersion2
	| string |
	string := 'HTTP/0.9 Foo OK', String crlf.
	self should: [ ZnStatusLine readFrom: string readStream ] raise: ZnUnknownHttpVersion! !

!ZnStreamingEntity commentStamp: ''!
I am ZnStreamingEntity, a concrete HTTP Entity based on a stream.
I am a ZnEntity.

When a ZnStreamingEntity is created using #readFrom: 
its content type and length are set but no body is actually read.
Instead, stream is set to a ZnLimitedReadStream that clients can/must
use to read from.

When the client is done, either all data must be read or #consumeContent must be called.
A client should normally not close the stream.

A ZnStreamingEntity can also be instanciated with an existing read stream.
During #writeOn: this stream is copied to the output stream.

Part of Zinc HTTP Components.!
!ZnStreamingEntity methodsFor: 'testing' stamp: ''!
isEmpty 
	"We actually don't know"
	
	^ false! !

!ZnStreamingEntity methodsFor: 'writing' stamp: ''!
writeOn: outputStream
	(self contentLength isNil or: [ self contentLength = 0 ])
		ifTrue: [ 
			ZnUtils 
				streamFrom: self stream 
				to: outputStream ]
		ifFalse: [
			ZnUtils 
				streamFrom: self stream 
				to: outputStream 
				size: self contentLength ].
	self close! !

!ZnStreamingEntity methodsFor: 'accessing' stamp: ''!
stream: readStream
	stream := readStream! !

!ZnStreamingEntity methodsFor: 'initialize-release' stamp: ''!
close
	stream ifNotNil: [ 
		stream close. 
		stream := nil ]! !

!ZnStreamingEntity methodsFor: 'accessing' stamp: ''!
contents
	"Since this is a non-repeatable entity, 
	#contents will #consumeContent, 
	this can thus only be done once"
	
	stream ifNil: [ ^ nil ].
	^ ZnUtils readUpToEnd: self stream limit: ZnMaximumEntitySize value! !

!ZnStreamingEntity methodsFor: 'accessing' stamp: ''!
stream 
	^ stream! !

!ZnStreamingEntity methodsFor: 'accessing' stamp: ''!
consumeContent
	"To be improved later on using some kind of larger buffer"
	
	[ self stream atEnd ] 
		whileFalse: [ self stream next ]! !

!ZnStreamingEntity methodsFor: 'initialize-release' stamp: ''!
readFrom: readStream
	self contentLength isNil
		ifTrue: [ 
			self stream: readStream ]
		ifFalse: [ | limitedStream |
			limitedStream := ZnLimitedReadStream on: readStream limit: self contentLength.
			self stream: limitedStream ]! !

!ZnStreamingEntity methodsFor: 'accessing' stamp: ''!
readStream 
	^ self stream! !

!ZnStreamingEntity class methodsFor: 'testing' stamp: ''!
designatedMimeType
	"I have no designated mime type, I can handle all content.
	See #concreteSubclassForType: "
	
	^ nil! !

!ZnStreamingEntity class methodsFor: 'instance creation' stamp: ''!
readFrom: stream usingType: mimeType andLength: length
	"Create and return a new streaming entity of mimeType and length from stream.
	Clients can/must use the embedded ZnLimitedReadStream to read all content, 
	or call #consumeContent when they are done. They should not close the stream."
	
	^ (self type: mimeType length: length)
		readFrom: stream;
		yourself
! !

!ZnStreamingEntity class methodsFor: 'testing' stamp: ''!
matches: mimeType
	"I have no designated mime type, I can handle all content.
	See #concreteSubclassForType: "
	
	^ false! !

!ZnStringEntity commentStamp: ''!
I am ZnStringEntity, a concrete HTTP Entity based on a String.
It is used to hold textual (non-binary) data.
I am a ZnEntity.

Optionally, an encoding is used to convert to and from bytes.
The default encoding it UTF-8.

Note that content length is the encoded byte count, not the number of characters in the string.

Part of Zinc HTTP Components.!
!ZnStringEntity methodsFor: 'testing' stamp: ''!
isEmpty 
	^ self string isNil or: [ self string isEmpty ] ! !

!ZnStringEntity methodsFor: 'printing' stamp: ''!
printContentsOn: stream
	super printContentsOn: stream.
	self string notNil ifTrue: [ 
		stream space; nextPutAll: self string ]! !

!ZnStringEntity methodsFor: 'comparing' stamp: ''!
= other
	^ super = other and: [ self string = other string ]! !

!ZnStringEntity methodsFor: 'accessing' stamp: ''!
string: aString
	(string notNil and: [ aString ~= string ]) ifTrue: [ self invalidateContentLength ].
	string := aString! !

!ZnStringEntity methodsFor: 'private' stamp: ''!
computeContentLength
	self string isNil ifTrue: [ ^ self ].
	contentLength := self encoder encodedByteCountForString: string! !

!ZnStringEntity methodsFor: 'comparing' stamp: ''!
hash
	^ super hash bitXor: self string hash! !

!ZnStringEntity methodsFor: 'writing' stamp: ''!
writeOn: stream
	| totalWritten toWrite total  |
	self initializeEncoder.
	totalWritten := 0.
	total := string size.
	[ totalWritten < total ] whileTrue: [ 
		toWrite := ZnUtils streamingBufferSize min: (total - totalWritten).
		encoder next: toWrite putAll: string startingAt: totalWritten + 1 toStream: stream.
		totalWritten := totalWritten + toWrite.
		ZnUtils signalProgress: totalWritten total: total ]! !

!ZnStringEntity methodsFor: 'private' stamp: ''!
invalidateEncoder
	self encoder: nil! !

!ZnStringEntity methodsFor: 'accessing' stamp: ''!
contentLength
	contentLength isNil ifTrue: [ self computeContentLength ].
	^ contentLength! !

!ZnStringEntity methodsFor: 'accessing' stamp: ''!
encoder
	self initializeEncoder.
	^ encoder! !

!ZnStringEntity methodsFor: 'private' stamp: ''!
initializeEncoder
	"If the content-type specifies an encoding, use that.
	If not, use the value of ZnDefaultCharacterEncoder,
	if that is not set, fall back to UTF-8"
	
	| charSet newEncoder |
	self hasEncoder
		ifTrue: [ ^ self ].
	newEncoder := (charSet := contentType charSet) isNil
		ifTrue: [ ZnDefaultCharacterEncoder value ]
		ifFalse: [ 
			(ZnCharacterEncoder newForEncoding: charSet)
				beLenient;
				yourself ].
	self encoder: newEncoder! !

!ZnStringEntity methodsFor: 'accessing' stamp: ''!
string
	^ string! !

!ZnStringEntity methodsFor: 'private' stamp: ''!
invalidateContentLength
	self contentLength: nil! !

!ZnStringEntity methodsFor: 'accessing' stamp: ''!
contentType: object
	"We only allow assignment compatible with our designated mime type"
	
	| newType |
	newType := object asZnMimeType.
	contentType = newType 
		ifTrue: [ ^ self ]
		ifFalse: [ 
			newType isBinary
				ifFalse: [ 
					contentType := newType.
					self invalidateEncoder ] ]! !

!ZnStringEntity methodsFor: 'accessing' stamp: ''!
contents
	^ self string! !

!ZnStringEntity methodsFor: 'private' stamp: ''!
hasEncoder
	^ encoder notNil! !

!ZnStringEntity methodsFor: 'initialize-release' stamp: ''!
readFrom: stream
	| buffer totalRead read readStream stringStream total |
	total := self contentLength.
	readStream := total ifNotNil: [ ZnLimitedReadStream on: stream limit: total ] ifNil: [ stream ].
	buffer := String new: (ZnUtils streamingBufferSize min: (total ifNil: [ ZnUtils streamingBufferSize ])).
	stringStream := nil.
	totalRead := 0.
	self initializeEncoder.
	[ readStream atEnd ] whileFalse: [
		[ read := encoder readInto: buffer startingAt: 1 count: buffer size fromStream: readStream ]
			on: ZnByteStringBecameWideString 
			do: [ :notification | 
					buffer := notification wideString.
					stringStream ifNotNil: [ | wideString position |
						position := stringStream position.
						wideString := WideString from: stringStream originalContents.
						stringStream on: wideString; setFrom: position + 1 to: position ].
					notification resume ].
		totalRead := totalRead + read.
		totalRead > ZnMaximumEntitySize value
			ifTrue: [ ZnEntityTooLarge signal ].
		stringStream ifNil: [ 
			readStream atEnd
				ifTrue: [ ^ self string: (buffer copyFrom: 1 to: read) ]
				ifFalse: [ stringStream := (total ifNil: [ buffer species new ] ifNotNil: [ buffer species new: total ]) writeStream ] ].
		stringStream next: read putAll: buffer startingAt: 1.
		ZnUtils signalProgress: totalRead total: total ].
	self string: (stringStream ifNil: [ String new ] ifNotNil: [ stringStream contents ])! !

!ZnStringEntity methodsFor: 'accessing' stamp: ''!
readStream
	^ self string readStream! !

!ZnStringEntity methodsFor: 'accessing' stamp: ''!
encoder: anEncoding
	(encoder notNil and: [ anEncoding ~= encoder ]) ifTrue: [ self invalidateContentLength ].
	encoder := anEncoding! !

!ZnStringEntity class methodsFor: 'testing' stamp: ''!
designatedMimeType
	"I have no designated mime type, I can handle all non-binary content.
	See #concreteSubclassForType: "
	
	^ nil! !

!ZnStringEntity class methodsFor: 'instance creation' stamp: ''!
text: string
	^ (self type: ZnMimeType textPlain)
		string: string;
		yourself! !

!ZnStringEntity class methodsFor: 'testing' stamp: ''!
matches: mimeType
	"I have no designated mime type, I can handle all non-binary content.
	See #concreteSubclassForType: "
	
	^ false! !

!ZnStringEntity class methodsFor: 'instance creation' stamp: ''!
xml: string
	^ (self type: ZnMimeType applicationXml)
		string: string;
		yourself! !

!ZnStringEntity class methodsFor: 'instance creation' stamp: ''!
html: string
	^ (self type: ZnMimeType textHtml)
		string: string;
		yourself! !

!ZnStringEntity class methodsFor: 'instance creation' stamp: ''!
json: string
	^ (self type: ZnMimeType applicationJson)
		string: string;
		yourself! !

!ZnTestRunnerDelegate commentStamp: ''!
I am ZnTestRunnerDelegate, a web service interface to run unit tests.

	ZnTestRunnerDelegate startInServerOn: 1701.
	
	ZnEasy get: 'http://localhost:1701/sunit/ZnUtilsTests'.
	ZnEasy get: 'http://localhost:1701/sunit/ZnUtilsTests/testBase64'.

Web Service API:

	GET /sunit/MyTestCase
	GET /sunit/MyTestCase/testOne

Part of Zinc HTTP Components!
!ZnTestRunnerDelegate methodsFor: 'public' stamp: ''!
value: request
	"I implement the generic #value: message as equivalent to #handleRequest:"
	
	^ self handleRequest: request! !

!ZnTestRunnerDelegate methodsFor: 'request handling' stamp: ''!
handleGetRequest: request
	| testCaseClass selector result |
	testCaseClass := Smalltalk globals
		at: request uri pathSegments second asSymbol
		ifAbsent: [ ^ self notFoundResponse: 'No such class, ', request uri pathSegments second ].
	(testCaseClass inheritsFrom: TestCase)
		ifFalse: [ ^ self notFoundResponse: testCaseClass printString, ' is not a TestCase subclass' ]. 
	selector := request uri pathSegments size = 3
		ifTrue: [ request uri pathSegments third asSymbol ]
		ifFalse: [ nil ].
	(selector isNil or: [ testCaseClass canUnderstand: selector ])
		ifFalse: [ ^ self notFoundResponse: selector, ' is not a method of ', testCaseClass printString ].
	result := selector 
		ifNil: [ testCaseClass suite run ] 
		ifNotNil: [ testCaseClass run: selector ].
	^ result runCount = result passedCount
		ifTrue: [ ZnResponse ok: (ZnEntity textCRLF: result printString) ]
		ifFalse: [ ZnResponse serverError: result printString ]! !

!ZnTestRunnerDelegate methodsFor: 'request handling' stamp: ''!
notFoundResponse: message
	^ ZnResponse new
		statusLine: ZnStatusLine notFound;
		headers: ZnHeaders defaultResponseHeaders;
		entity: (ZnEntity textCRLF: 'Not Found: ', message);
		yourself.! !

!ZnTestRunnerDelegate methodsFor: 'public' stamp: ''!
handleRequest: request
	(request method = #GET 
		and: [ 
			request uri firstPathSegment = #sunit 
				and: [ 
					request uri pathSegments size > 1 ] ])
		ifTrue: [ 
			^ self handleGetRequest: request ].
	^ ZnResponse notFound: request uri! !

!ZnTestRunnerDelegate class methodsFor: 'public' stamp: ''!
startInServerOn: port
	"Start a new server bound to port on the local network running a test runner web service"

	"self startInServerOn: 1701"
	
	 ^ (ZnServer on: port)
			bindingAddress: NetNameResolver loopBackAddress;
			delegate: self new;
			start;
			yourself! !

!ZnTooManyDictionaryEntries commentStamp: ''!
ZnTooManyDictionaryEntries is signalled when too many entries are added to a limited ZnMultiValueDictionary.

This is a resumable exception

Part of Zinc HTTP Components. !
!ZnTooManyDictionaryEntries methodsFor: 'accessing' stamp: 'nil'!
limit
	^ limit! !

!ZnTooManyDictionaryEntries methodsFor: 'accessing' stamp: 'nil'!
limit: anObject
	limit := anObject! !

!ZnTooManyDictionaryEntries methodsFor: 'testing' stamp: 'nil'!
isResumable
	"Determine whether an exception is resumable."

	^ true! !

!ZnTooManyDictionaryEntries class methodsFor: 'instance creation' stamp: 'nil'!
limit: limit
	^ self new 
		limit: limit; 
		yourself! !

!ZnTooManyRedirects commentStamp: ''!
ZnTooManyRedirects is signalled when an HTTP client has been following more redirects than allowed.

Part of Zinc HTTP Components. !
!ZnTooManyRedirects methodsFor: 'testing' stamp: ''!
isResumable
	"Determine whether an exception is resumable."

	^ true! !

!ZnUTF16Encoder commentStamp: ''!
I am ZnUTF16Encoder, a concrete subclass of ZnCharacterEncoder.
I implement the variable length UTF-16 encoding and decoding of Unicode according to RFC 2781.

Wikipedia reference http://en.wikipedia.org/wiki/UTF-16

Part of Zinc HTTP Components.
!
!ZnUTF16Encoder methodsFor: 'error handling' stamp: ''!
errorIncomplete
	self error: 'Incomplete utf-16 encoding'! !

!ZnUTF16Encoder methodsFor: 'private' stamp: ''!
processByteOrderMark: word
	^ (word = 16rFEFF or: [ word = 16rFFFE ])
		ifTrue: [ 
			word = 16rFFFE
				ifTrue: [ self swapEndianness ].
			true ]
		ifFalse: [ false ]! !

!ZnUTF16Encoder methodsFor: 'accessing' stamp: ''!
identifier
	^ #utf16! !

!ZnUTF16Encoder methodsFor: 'private' stamp: ''!
write16BitWord: word toStream: stream
	self isBigEndian
		ifTrue: [ 
			stream
				nextPut: (word byteAt: 2);
				nextPut: (word byteAt: 1) ]
		ifFalse: [ 
			stream
				nextPut: (word byteAt: 1);
				nextPut: (word byteAt: 2) ]! !

!ZnUTF16Encoder methodsFor: 'private' stamp: ''!
back16BitWordOnStream: stream
	| firstByte secondByte |
	firstByte := stream back.
	secondByte := stream back.
	^ self isBigEndian 
		ifTrue: [ secondByte + (firstByte << 8) ]
		ifFalse: [ firstByte + (secondByte << 8) ]! !

!ZnUTF16Encoder methodsFor: 'converting' stamp: ''!
backOnStream: stream
	"Move back one character on stream"

	| word |
	word := self back16BitWordOnStream: stream.
	(word < 16rD800 or: [ word > 16rDBFF ])
		ifFalse: [ 
			self back16BitWordOnStream: stream ]! !

!ZnUTF16Encoder methodsFor: 'converting' stamp: ''!
nextCodePointFromStream: stream
	"Read and return the next integer code point from stream"

	| word leadSurrogate trailSurrogate code |
	word := self read16BitWordFromStream: stream.
	(self processByteOrderMark: word)
		ifTrue: [ word := self read16BitWordFromStream: stream ].
	^ (word < 16rD800 or: [ word > 16rDBFF ])
		ifTrue: [
			word ]
		ifFalse: [ 
			leadSurrogate := word.
			trailSurrogate := self read16BitWordFromStream: stream.
			code := (leadSurrogate - 16rD800) * 16r400 + (trailSurrogate - 16rDC00).
			16r10000 + code ]! !

!ZnUTF16Encoder methodsFor: 'converting' stamp: ''!
nextPutCodePoint: codePoint toStream: stream
	"Write the encoding for integer code point to stream"

	| leadSurrogate trailSurrogate shifted |
	(self isSurrogateCodePoint: codePoint) ifTrue: [ self errorOutsideRange ].
	codePoint <= 65535
		ifTrue: [ 
			^ self write16BitWord: codePoint toStream: stream ].
	codePoint <= self maximumUTFCode
		ifTrue: [
			shifted := codePoint - 16r10000.
			leadSurrogate := 16rD800 + (shifted // 16r400).
			trailSurrogate := 16rDC00 + (shifted \\ 16r400).
			self write16BitWord: leadSurrogate toStream: stream.
			self write16BitWord: trailSurrogate toStream: stream ]
		ifFalse: [
			self errorOutsideRange ]! !

!ZnUTF16Encoder methodsFor: 'converting' stamp: ''!
encodedByteCountForCodePoint: codePoint
	"Return how many bytes are needed to encode integer code point"

	codePoint <= 65535 ifTrue: [ ^ 2 ].
	codePoint <= self maximumUTFCode ifTrue: [ ^ 4 ].
	self errorOutsideRange! !

!ZnUTF16Encoder methodsFor: 'private' stamp: ''!
read16BitWordFromStream: stream
	| firstByte secondByte |
	firstByte := stream next.
	secondByte := stream next.
	(firstByte isNil or: [ secondByte isNil ])
		ifTrue: [ ^ self errorIncomplete ].
	^ self isBigEndian 
		ifTrue: [ secondByte + (firstByte << 8) ]
		ifFalse: [ firstByte + (secondByte << 8) ]
	! !

!ZnUTF16Encoder class methodsFor: 'accessing' stamp: ''!
knownEncodingIdentifiers
	^ #( 'utf16' 'utf16be' 'utf16le' )! !

!ZnUTF16Encoder class methodsFor: 'accessing' stamp: ''!
handlesEncoding: string
	"Return true when my instances handle the encoding described by string"

	^ self knownEncodingIdentifiers includes: (self canonicalEncodingIdentifier: string)! !

!ZnUTF32Encoder commentStamp: ''!
I am ZnUTF32Encoder, a concrete subclass of ZnCharacterEncoder.
I implement the fixed length UTF-32 encoding and decoding of Unicode according to http://www.unicode.org/versions/Unicode8.0.0/ch03.pdf definitions D90, D99, D100 and D101.

Wikipedia reference http://en.wikipedia.org/wiki/UTF-32

UCS-4 is another name for the same encoding.

Part of Zinc HTTP Components.
!
!ZnUTF32Encoder methodsFor: 'error handling' stamp: ''!
errorIncomplete
	self error: 'Incomplete utf-32 encoding'! !

!ZnUTF32Encoder methodsFor: 'private' stamp: ''!
readCodePointFrom: stream
	| byte1 byte2 byte3 byte4 |
	byte1 := stream next.
	byte2 := stream next.
	byte3 := stream next.
	byte4 := stream next.
	(byte1 isNil or: [ byte2 isNil or: [ byte3 isNil or: [ byte4 isNil ] ] ])
		ifTrue: [ ^ self errorIncomplete ].
	^ self isBigEndian
		ifTrue: [ 
			(byte1 bitShift: 24) + (byte2 bitShift: 16) + (byte3 bitShift: 8) + byte4 ] 
		ifFalse: [ 
			(byte4 bitShift: 24) + (byte3 bitShift: 16) + (byte2 bitShift: 8) + byte1 ]! !

!ZnUTF32Encoder methodsFor: 'private' stamp: ''!
processByteOrderMark: codePoint
	^ (codePoint = 16rFEFF or: [ codePoint = 16rFFFE0000 ])
		ifTrue: [ 
			codePoint = 16rFFFE0000
				ifTrue: [ self swapEndianness ].
			true ]
		ifFalse: [ false ]! !

!ZnUTF32Encoder methodsFor: 'accessing' stamp: ''!
identifier
	^ #utf32! !

!ZnUTF32Encoder methodsFor: 'converting' stamp: ''!
backOnStream: stream
	"Move back one character on stream"

	4 timesRepeat: [ stream back ]! !

!ZnUTF32Encoder methodsFor: 'private' stamp: ''!
writeCodePoint: codePoint to: stream
	self isBigEndian 
		ifTrue: [ 
			stream 
				nextPut: (codePoint byteAt: 4); 
				nextPut: (codePoint byteAt: 3); 
				nextPut: (codePoint byteAt: 2); 
				nextPut: (codePoint byteAt: 1) ]
		ifFalse: [ 
			stream 
				nextPut: (codePoint byteAt: 1); 
				nextPut: (codePoint byteAt: 2); 
				nextPut: (codePoint byteAt: 3); 
				nextPut: (codePoint byteAt: 4) ]! !

!ZnUTF32Encoder methodsFor: 'converting' stamp: ''!
nextCodePointFromStream: stream
	"Read and return the next integer code point from stream"

	| codePoint |
	codePoint := self readCodePointFrom: stream.
	(self processByteOrderMark: codePoint)
		ifTrue: [ codePoint := self readCodePointFrom: stream ].
	((self isSurrogateCodePoint: codePoint) or: [ codePoint > self maximumUTFCode ]) 
		ifTrue: [ ^ self errorOutsideRange ].
	^ codePoint! !

!ZnUTF32Encoder methodsFor: 'converting' stamp: ''!
nextPutCodePoint: codePoint toStream: stream
	"Write the encoding for integer code point to stream"

	(self isSurrogateCodePoint: codePoint) 
		ifTrue: [ self errorOutsideRange ].
	codePoint <= self maximumUTFCode
		ifTrue: [
			self writeCodePoint: codePoint to: stream ]
		ifFalse: [
			self errorOutsideRange ]! !

!ZnUTF32Encoder methodsFor: 'converting' stamp: ''!
encodedByteCountForCodePoint: codePoint
	"Return how many bytes are needed to encode integer codePoint"

	codePoint > self maximumUTFCode 
		ifTrue: [ ^ self errorOutsideRange ].
	^ 4! !

!ZnUTF32Encoder class methodsFor: 'accessing' stamp: ''!
knownEncodingIdentifiers
	^ #( 'utf32' 'utf32be' 'utf32le' 'ucs4' 'ucs4be' 'ucs4le')! !

!ZnUTF32Encoder class methodsFor: 'accessing' stamp: ''!
handlesEncoding: string
	"Return true when my instances handle the encoding described by string"

	^ self knownEncodingIdentifiers includes: (self canonicalEncodingIdentifier: string)! !

!ZnUTF8Encoder commentStamp: ''!
I am ZnUTF8Encoder, a concrete subclass of ZnCharacterEncoder.
I implement the variable length UTF-8 encoding and decoding of Unicode according to RFC 3629.

Wikipedia reference http://en.wikipedia.org/wiki/UTF-8

Part of Zinc HTTP Components.!
!ZnUTF8Encoder methodsFor: 'private' stamp: ''!
next: count putAllASCII: string startingAt: offset toStream: stream
	"Write count bytes from string starting at offset to stream,
	assuming all characters are in the ASCII set and need no translation"
	
	offset to: offset + count - 1 do: [ :index | 
		stream nextPut: (string byteAt: index) ]! !

!ZnUTF8Encoder methodsFor: 'private' stamp: ''!
next: count putAllByteString: string startingAt: offset toStream: stream
	"A faster version when string is a ByteString"
	
	| lastIndex nextIndex |
	lastIndex := offset.
	nextIndex := self findFirstNonASCIIIn: string startingAt: lastIndex.
	(nextIndex = 0 or: [ offset + count <= nextIndex ]) 
		ifTrue: [ 
			^ self next: count putAllASCII: string startingAt: offset toStream: stream ].
	[	nextIndex > lastIndex 
			ifTrue: [
				self next: nextIndex - lastIndex putAllASCII: string startingAt: lastIndex toStream: stream ].
		stream nextPutAll: (ByteUTF8Encoding at: (string byteAt: nextIndex) + 1).
		lastIndex := nextIndex + 1.
		nextIndex := self findFirstNonASCIIIn: string startingAt: lastIndex.
		nextIndex = 0 or: [ offset + count <= nextIndex ] ] whileFalse.
	offset + count <= lastIndex 
		ifFalse: [ 
			self next: offset + count - lastIndex putAllASCII: string startingAt: lastIndex toStream: stream ]
	! !

!ZnUTF8Encoder methodsFor: 'error handling' stamp: ''!
error: message
	^ ZnInvalidUTF8 signal: message! !

!ZnUTF8Encoder methodsFor: 'error handling' stamp: ''!
errorIllegalContinuationByte
	^ self error: 'Illegal continuation byte for utf-8 encoding'! !

!ZnUTF8Encoder methodsFor: 'accessing' stamp: ''!
identifier
	^ #utf8! !

!ZnUTF8Encoder methodsFor: 'convenience' stamp: ''!
next: count putAll: string startingAt: offset toStream: stream
	"Write count characters from string starting at offset to stream."
	"Overwritten for performance reasons - create a fast path for byte strings"
	
	string isByteString
		ifTrue: [ self next: count putAllByteString: string startingAt: offset toStream: stream ]
		ifFalse: [ super next: count putAll: string startingAt: offset toStream: stream ]! !

!ZnUTF8Encoder methodsFor: 'error handling' stamp: ''!
errorOverlong
	^ self error: 'Overlong utf-8 encoding (non-shortest form)'! !

!ZnUTF8Encoder methodsFor: 'converting' stamp: ''!
encodedByteCountForCodePoint: codePoint
	"Return how many bytes are needed to encode integer code point"

	codePoint < 128 ifTrue: [ ^ 1 ].
	codePoint < 2048 ifTrue: [ ^ 2 ].
	codePoint < 65535 ifTrue: [ ^ 3 ].
	codePoint <= self maximumUTFCode ifTrue: [ ^ 4 ].
	self errorOutsideRange.
	^ 0! !

!ZnUTF8Encoder methodsFor: 'error handling' stamp: ''!
errorIllegalLeadingByte
	^ self error: 'Illegal leading byte for utf-8 encoding'! !

!ZnUTF8Encoder methodsFor: 'private' stamp: ''!
findFirstNonASCIIIn: string startingAt: offset
	"This calls a fast primitive. Note that string can be a ByteString or ByteArray"
	
	offset > string size ifTrue: [ ^ 0 ].
	^ ByteString 
		findFirstInString: string 
		inSet: ByteASCIISet 
		startingAt: offset! !

!ZnUTF8Encoder methodsFor: 'convenience' stamp: ''!
readInto: string startingAt: offset count: requestedCount fromStream: stream
	"Read requestedCount characters into string starting at offset,
	returning the number read, there could be less available when stream is atEnd.
	I signal a ZnByteStringBecameWideString notification if necessary"

	| stringBuffer |
	stringBuffer := string.
	offset to: offset + requestedCount - 1 do: [ :index | | codePoint |
		stream atEnd ifTrue: [ ^ index - offset ].  
		codePoint := self nextCodePointFromStream: stream.
		(codePoint > 255 and: [ stringBuffer isWideString not ])
			ifTrue: [ stringBuffer := ZnByteStringBecameWideString convert: stringBuffer ].
		stringBuffer at: index put: (Character value: codePoint) ].
	^ requestedCount! !

!ZnUTF8Encoder methodsFor: 'converting' stamp: ''!
backOnStream: stream
	"Move back one character on stream"

	[ (stream back bitAnd: 2r11000000) == 2r10000000 ] whileTrue! !

!ZnUTF8Encoder methodsFor: 'converting' stamp: ''!
nextCodePointFromStream: stream
	"Read and return the next integer code point from stream"

	| code byte next |
	(byte := stream next ifNil: [ ^ self errorIncomplete ]) < 128
		ifTrue: [ ^ byte ].
	(byte bitAnd: 2r11100000) == 2r11000000
		ifTrue: [ 
			code := byte bitAnd: 2r00011111.
			((next := stream next ifNil: [ ^ self errorIncomplete ]) bitAnd: 2r11000000) == 2r10000000
				ifTrue: [ code := (code bitShift: 6) + (next bitAnd: 2r00111111) ]
				ifFalse: [ ^ self errorIllegalContinuationByte ].
			code < 128 ifTrue: [ ^ self errorOverlong ].
			^ code ].
	(byte bitAnd: 2r11110000) == 2r11100000
		ifTrue: [ 
			code := byte bitAnd: 2r00001111.
			2 timesRepeat: [ 
				((next := stream next ifNil: [ ^ self errorIncomplete ]) bitAnd: 2r11000000) == 2r10000000
					ifTrue: [ code := (code bitShift: 6) + (next bitAnd: 2r00111111) ]
					ifFalse: [ ^ self errorIllegalContinuationByte ] ].
			code < 2048 ifTrue: [ ^ self errorOverlong ].
			(self isSurrogateCodePoint: code) ifTrue: [ ^ self errorOutsideRange ].
			code = 65279 "Unicode Byte Order Mark" ifTrue: [ 
				stream atEnd ifTrue: [ ^ self errorIncomplete ].
				^ self nextCodePointFromStream: stream ].
			^ code ].
	(byte bitAnd: 2r11111000) == 2r11110000
		ifTrue: [ 
			code := byte bitAnd: 2r00000111.
			3 timesRepeat: [ 
				((next := stream next ifNil: [ ^ self errorIncomplete ]) bitAnd: 2r11000000) == 2r10000000
					ifTrue: [ code := (code bitShift: 6) + (next bitAnd: 2r00111111) ]
					ifFalse: [ ^ self errorIllegalContinuationByte ] ].
			code < 65535 ifTrue: [ ^ self errorOverlong ].
			^ code ].
	^ self errorIllegalLeadingByte! !

!ZnUTF8Encoder methodsFor: 'converting' stamp: ''!
nextPutCodePoint: codePoint toStream: stream
	"Write the encoding for Integer code point to stream"

	codePoint < 128 ifTrue: [ 
		^ stream nextPut: codePoint ].
	codePoint < 2048 ifTrue: [ 
		^ stream 
			nextPut: (2r11000000 + (codePoint bitShift: -6)); 
			nextPut: (2r10000000 + (codePoint bitAnd: 2r111111)) ].
	(self isSurrogateCodePoint: codePoint) ifTrue: [ ^ self errorOutsideRange ].
	codePoint < 65536 ifTrue: [ 
		^ stream 
			nextPut: (2r11100000 + (codePoint bitShift: -12));
			nextPut: (2r10000000 + ((codePoint bitShift: -6) bitAnd: 2r111111)); 
			nextPut: (2r10000000 + (codePoint bitAnd: 2r111111)) ].
	codePoint <= self maximumUTFCode ifTrue: [ 
		^ stream 
			nextPut: (2r11110000 + (codePoint bitShift: -18));
			nextPut: (2r10000000 + ((codePoint bitShift: -12) bitAnd: 2r111111));
			nextPut: (2r10000000 + ((codePoint bitShift: -6) bitAnd: 2r111111)); 
			nextPut: (2r10000000 + (codePoint bitAnd: 2r111111)) ].
	^ self errorOutsideRange
! !

!ZnUTF8Encoder class methodsFor: 'class initialization' stamp: ''!
initialize
	| encoder stream |
	ByteASCIISet := ByteArray new: 256.
	ByteUTF8Encoding := Array new: 256.
	encoder := self new.
	stream := ByteArray new writeStream.
	0 to: 255 do: [ :each |
		| bytes |
		stream reset.
		encoder nextPut: (Character value: each) toStream: stream.
		bytes := stream contents.
		(bytes size = 1 and: [ bytes first = each ])
			ifTrue: [
				ByteASCIISet at: each + 1 put: 0 ]
			ifFalse: [  
				ByteASCIISet at: each + 1 put: 1.
				ByteUTF8Encoding at: each + 1 put: bytes ] ] ! !

!ZnUTF8Encoder class methodsFor: 'accessing' stamp: ''!
knownEncodingIdentifiers
	^ #( utf8 )! !

!ZnUTF8Encoder class methodsFor: 'instance creation' stamp: ''!
newForEncoding: string
	"No further parametrization needed"
	
	^ self new! !

!ZnUTF8Encoder class methodsFor: 'accessing' stamp: ''!
handlesEncoding: string
	"Return true when my instances handle the encoding described by string"
	
	^ (self canonicalEncodingIdentifier: string) = 'utf8'! !

!ZnUTF8Encoder class methodsFor: 'accessing' stamp: ''!
default
	"Return a cached instance of the most commonly used encoder,
	which is faster than going via #newForEncoding: that does a subclass search"
	
	^ Default ifNil: [ Default := self new ]! !

!ZnUTFEncoder commentStamp: ''!
I am ZnUTFEncoder. I am a ZnCharacterEncoder. My subclasses deal with the full range of Unicode character code points.!
!ZnUTFEncoder methodsFor: 'convenience' stamp: ''!
decodeBytesIntoWideString: bytes
	"Variant of #decodeBytes: that is faster when you know upfront that a WideString is probably needed"

	| byteStream |
	byteStream := bytes readStream.
	^ WideString streamContents: [ :stream |
		[ byteStream atEnd ] whileFalse: [
			stream nextPut: (self nextFromStream: byteStream) ] ] ! !

!ZnUTFEncoder methodsFor: 'accessing' stamp: ''!
byteOrderMark
	"The code point of the Unicode Byte-Order-Mark or BOM character.
	See https://en.wikipedia.org/wiki/Byte_order_mark"
	
	^ 16rFEFF! !

!ZnUTFEncoder methodsFor: 'convenience' stamp: ''!
decodeBytes: bytes
	"Overridden to prevent the automagic switch from ByteString to WideString 
	and the slow #becomeForward: in there. See also #decodeBytesIntoWideString:"
	
	| byteStream |
	byteStream := bytes readStream.
	^ String streamContents: [ :stream |
		[ byteStream atEnd ] whileFalse: [ | codePoint |
			codePoint := self nextCodePointFromStream: byteStream.
			(codePoint > 255 and: [ stream originalContents isWideString not ])
				ifTrue: [ | wideString position |
					position := stream position.
					wideString := WideString from: stream originalContents.
					stream on: wideString; setFrom: position + 1 to: position ].
			stream nextPut: (Character value: codePoint) ] ] ! !

!ZnUTFEncoder methodsFor: 'convenience' stamp: ''!
encodeStringWithByteOrderMark: string
	"Encode string and return the resulting byte array.
	Always add a Unicode byte order mark (BOM) in front."
	
	^ ByteArray streamContents: [ :stream |
		self nextPutByteOrderMarkToStream: stream.
		self next: string size putAll: string startingAt: 1 toStream: stream ]! !

!ZnUTFEncoder methodsFor: 'accessing' stamp: ''!
maximumUTFCode
	^ 16r10FFFF! !

!ZnUTFEncoder methodsFor: 'testing' stamp: ''!
isSurrogateCodePoint: codePoint
	"Surrogate Code Points should not be encoded or decoded because they are not Unicode scalar values"
	
	^ codePoint between: 16rD800 and: 16rDFFF! !

!ZnUTFEncoder methodsFor: 'convenience' stamp: ''!
nextPutByteOrderMarkToStream: stream
	"Write the encoded byte-order-mark (BOM) to stream"
	
	self nextPutCodePoint: self byteOrderMark toStream: stream ! !

!ZnUTFEncoder class methodsFor: 'accessing' stamp: ''!
handlesEncoding: string
	"Return true when my instances handle the encoding described by string"
	
	^ false! !

!ZnUnexpectedContentType commentStamp: ''!
ZnUnexpectedContentType is signalled when a different content type (mime type) was expected.

I hold the expected and actual content types.

Part of Zinc HTTP Components. !
!ZnUnexpectedContentType methodsFor: 'accessing' stamp: ''!
actualContentType: anObject
	actualContentType := anObject! !

!ZnUnexpectedContentType methodsFor: 'accessing' stamp: ''!
standardMessageText
	"Generate a standard textual description"
	
	^ String streamContents: [ :stream |
		self expectedContentType ifNotNil: [ :contentType |
			stream << 'expected '; print: contentType ].
		self actualContentType ifNotNil: [ :contentType |
			self expectedContentType ifNotNil: [ stream space ].
			stream << 'actual '; print: contentType ] ]! !

!ZnUnexpectedContentType methodsFor: 'accessing' stamp: ''!
expectedContentType
	^ expectedContentType! !

!ZnUnexpectedContentType methodsFor: 'accessing' stamp: ''!
actualContentType
	^ actualContentType! !

!ZnUnexpectedContentType methodsFor: 'accessing' stamp: ''!
expectedContentType: anObject
	expectedContentType := anObject! !

!ZnUnexpectedContentType methodsFor: 'accessing' stamp: ''!
messageText
	"Overwritten to initialiaze the message text to a standard text if it has not yet been set"
	
	^ messageText ifNil: [ messageText := self standardMessageText ]! !

!ZnUnexpectedContentType class methodsFor: 'instance creation' stamp: ''!
expected: expectedMimeType actual: actualMimeType
	^ self new
		expectedContentType: expectedMimeType;
		actualContentType: actualMimeType;
		yourself! !

!ZnUnknownHttpMethod commentStamp: ''!
ZnUnknownHttpMethod is signalled when an unknown/unsupported HTTP method is found while parsing a request.

I am resumable to allow non-standard methods.

Part of Zinc HTTP Components. !
!ZnUnknownHttpMethod methodsFor: 'accessing' stamp: ''!
method
	^ method! !

!ZnUnknownHttpMethod methodsFor: 'accessing' stamp: ''!
method: anObject
	method := anObject! !

!ZnUnknownHttpMethod methodsFor: 'testing' stamp: ''!
isResumable
	^ true! !

!ZnUnknownHttpMethod class methodsFor: 'instance creation' stamp: ''!
method: method
	^ self new
		method: method;
		yourself! !

!ZnUnknownHttpStatusCode commentStamp: ''!
ZnUnknownHttpStatusCode is signalled when an unknown/unsupported HTTP status code is found.

Part of Zinc HTTP Components. !
!ZnUnknownHttpStatusCode methodsFor: 'accessing' stamp: ''!
code
	^ code! !

!ZnUnknownHttpStatusCode methodsFor: 'accessing' stamp: ''!
code: anObject
	code := anObject! !

!ZnUnknownHttpStatusCode class methodsFor: 'instance creation' stamp: ''!
code: code
	^ self new
		code: code;
		yourself! !

!ZnUnknownHttpVersion commentStamp: ''!
ZnUnknownHttpVersion is signalled when an unknown/unsupported HTTP version is found.

Part of Zinc HTTP Components. !
!ZnUnknownHttpVersion methodsFor: 'accessing' stamp: ''!
version: anObject
	version := anObject! !

!ZnUnknownHttpVersion methodsFor: 'accessing' stamp: ''!
version
	^ version! !

!ZnUnknownHttpVersion class methodsFor: 'instance creation' stamp: ''!
version: version
	^ self new
		version: version;
		yourself! !

!ZnUnknownScheme commentStamp: ''!
ZnUnknownScheme is signalled when an unknown/unsupported URL scheme is found.

Part of Zinc HTTP Components. !
!ZnUnknownScheme methodsFor: 'accessing' stamp: 'nil'!
scheme
	^ scheme! !

!ZnUnknownScheme methodsFor: 'accessing' stamp: 'nil'!
scheme: anObject
	scheme := anObject! !

!ZnUnknownScheme class methodsFor: 'instance creation' stamp: 'nil'!
scheme: scheme
	^ self new
		scheme: scheme;
		yourself! !

!ZnUrl commentStamp: ''!
I am ZnUrl, an implementation of an interpreted URL/URI.
URLs are an element used in describing resources, more specifically to identify them.

I consist of the following parts:
  - scheme - like #http, #https, #ws, #wws, #file or nil
  - host - hostname string or nil
  - port - port integer or nil
  - segments - collection of path segments, ends with #/ for directories
  - query - query dictionary or nil
  - fragment - fragment string or nil
  - username - username string or nil
  - password - password string or nil

The syntax of my external representation informally looks like this

  scheme://username:password@host:port/segments?query#fragment

I am most often created by parsing my external representation using either my #fromString: class method or by sending the #asZnUrl convenience method to a String. Using #asZnUrl helps in accepting both Strings and ZnUrls arguments.

  ZnUrl fromString: 'http://www.google.com/search?q=Smalltalk'.

I can also be constucted programmatically.

  ZnUrl new 
    scheme: #https; 
    host: 'encrypted.google.com'; 
    addPathSegment: 'search'; 
    queryAt: 'q' put: 'Smalltalk'; 
    yourself.
  
My components can be manipulated destructively. Here is an example:

  'http://www.google.com/?one=1&two=2' asZnUrl
    queryAt: 'three' put: '3';
    queryRemoveKey: 'one';
    yourself.

Some characters of parts of a URL are illegal because they would interfere with the syntax and further processing and thus have to be encoded. The methods in accessing protocols do not do any encoding, those in parsing and printing do. Here is an example:

  'http://www.google.com' asZnUrl
    addPathSegment: 'some encoding here';
    queryAt: 'and some encoding' put: 'here, too';
    yourself

My parser is somewhat forgiving and accepts some unencoded URLs as well, like most browsers would.

  'http://www.example.com:8888/a path?q=a, b, c' asZnUrl.

I can parse in the context of a default scheme, like a browser would do.

  ZnUrl fromString: 'www.example.com' defaultScheme: #http

Given a scheme, I know its default port, try #portOrDefault.

A path defaults to what is commonly referred to as slash, test with #isSlash. Paths are most often (but don't have to be) interpreted as filesystem paths. To support this, I have #isFilePath and #isDirectoryPath tests and #file and #directory accessors.

I have some support to handle one URL in the context of another one, this is also known as a relative URL in the context of an absolute URL. Refer to #isAbsolute, #isRelative and #inContextOf:

  '/folder/file.txt' asZnUrl inContextOf: 'http://fileserver.example.net:4400' asZnUrl.

Incomplete relative references can be parsed and resolved in the context of a base URL using #withRelativeReference:

  'http://www.site.com/static/html/home.html' asZnUrl withRelativeReference: '../js/menu.js'.

Sometimes, the combination of my host and port are referred to as authority, see #authority.

URL/URI/URN (Uniform/Universal Resource Locator/Identifier/Name) are closely related and can be and are used as synonyms is many contexts. Refer to http://en.wikipedia.org/wiki/Url for more information.

There is a convenience method #retrieveContents to download the resource a ZnUrl points to,

  'http://zn.stfx.eu/zn/numbers.txt' asZnUrl retrieveContents.

This is implemented using a ZnUrlOperation.
 
Part of Zinc HTTP Components.!
!ZnUrl methodsFor: 'convenience' stamp: 'nil'!
withPathSegments: pathSegments
	"Return a new URL equal to the receiver with its path extended with pathSegments"
	
	^ self copy
		addPathSegments: pathSegments;
		yourself! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
lastPathSegment
	^ self isSlash
		ifTrue: [ nil ]
		ifFalse: [ segments last ]! !

!ZnUrl methodsFor: 'converting' stamp: 'nil'!
inContextOf: absoluteUrl
	"Return a copy of the receiver where scheme, host and port
	are taken from absoluteUrl unless they are already in the receiver.
	Path merging is not supported. See also #withRelativeReference: "
	
	| copy |
	copy := self copy.
	copy hasScheme ifFalse: [ copy scheme: absoluteUrl scheme ].
	copy hasHost ifFalse: [ copy host: absoluteUrl host ].
	(copy hasPort not and: [ copy scheme = absoluteUrl scheme ]) 
		ifTrue: [ copy port: absoluteUrl port ].      
	^ copy! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
portOrDefault
	^ self portIfAbsent: [ self class defaultPortForScheme: self schemeOrDefault ]! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
removeLastPathSegment
	self hasPath
		ifTrue: [ segments removeLast ]! !

!ZnUrl methodsFor: '*Monticello' stamp: 'nil'!
location
	"Returns the URL location string without username and password"
	^ String streamContents: [ :stream |
		self hasScheme ifTrue: [ 
			stream nextPutAll: self scheme; nextPut: $:.
		self isSchemeUsingDoubleSlash ifTrue: [ stream nextPut: $/; nextPut: $/ ] ].
		self hasHost ifTrue: [ self encode: self host on: stream ].
		self hasPort ifTrue: [ stream nextPut: $:; print: self port ].
		self printPathQueryFragmentOn: stream ]! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
hasQuery
	^ query notNil and: [ query isEmpty not ]! !

!ZnUrl methodsFor: 'parsing' stamp: 'nil'!
parseFrom: string defaultScheme: defaultScheme
	| start end index |
	start := 1.
	end := string size.
	(index := string indexOf: $#) > 0
		ifTrue: [ 
			self fragment: (self decodePercent: (string copyFrom: index + 1 to: end)).
			end := index - 1 ].
	(index := string indexOf: $?) > 0
		ifTrue: [
			self query: (ZnResourceMetaUtils parseQueryFrom: (ReadStream on: string from: index + 1 to: end)).
			end := index - 1 ].
	((index := string indexOfSubCollection: '://') > 0 and: [ index <= end ])
		ifTrue: [
			self scheme: (string copyFrom: 1 to: index - 1).
			start := index + 3 ]
		ifFalse: [ 
			((index := string indexOf: $:) > 0 
					and: [ index <= end 
						and: [ self isSchemeNotUsingDoubleSlash: (string copyFrom: 1 to: index - 1) ] ])
				ifTrue: [ 
					self scheme: (string copyFrom: 1 to: index - 1).
					start := index + 1 ]
				ifFalse: [ 
					defaultScheme ifNotNil: [ self scheme: defaultScheme ] ] ].
	self hasScheme 
		ifTrue: [  
			(index := string indexOf: $/ startingAt: start) > 0
				ifTrue: [
					self parseAuthority: string from: start to: index - 1.
					start := index ]
				ifFalse: [ 
					^ self parseAuthority: string from: start to: end ] ].
	self parsePath: (ReadStream on: string from: start to: end)! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
addPathSegment: segment
	"Modify the receiver's path by adding segment at the end"
	
	segments isNil ifTrue: [ 
		segments := OrderedCollection new ].
	segments add: segment! !

!ZnUrl methodsFor: '*Monticello' stamp: 'nil'!
asFileReferenceWithRelativePath
	"Convert the receiver into a new FileReference object accepting relative paths.
	This works for filetree (a special pharo format).
	Note that for a FileReference a trailing slash is not relevant"
	| path |
	
	self 
		assert: self scheme = #filetree 
		description: 'Only filetree:// URL can be converted to a FileReference with relative Paths'.
	
	self isSlash ifTrue: [ ^ FileSystem root ].
	
	path := self host 
		ifNotNil: [ segments copyWithFirst: self host ]
		ifNil: [ segments copyWithFirst: FileSystem disk delimiter asString ].
		
	^ (String streamContents: [ :stream |
		path 
			asStringOn: stream 
			delimiter: FileSystem disk delimiter asString ])
		asFileReference! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
authorityWithPort
	^ String streamContents: [ :stream | 
			stream nextPutAll: self host; nextPut: $:; print: self portOrDefault ] ! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
port
	^ port! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isRelative
	^ self isAbsolute not! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
username
	^ username! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
fragment
	^ fragment! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
query
	^ query! !

!ZnUrl methodsFor: 'convenience' stamp: 'nil'!
withQuery: association
	"Return a new URL equal to the receiver with the association's 
	key=value added as a query parameter.
	Note that #queryAt:add: is used."
	
	^ self copy
		queryAt: association key add: association value;
		yourself 
		! !

!ZnUrl methodsFor: 'parsing' stamp: 'nil'!
withRelativeReference: reference
	"Return a new URL by parsing & resolving the relative reference using myself as base URL.
	This implements the process described in RFC 3986 Section 5"
	
	| resolved |
	[ (resolved := reference asZnUrl) isAbsolute 
		ifTrue: [ ^ resolved ] ] on: Error do: [ ].
	(reference beginsWith: '//')
		ifTrue: [ ^ self class fromString: (reference allButFirst: 2) defaultScheme: self scheme ].
	resolved := self copy.
	resolved fragment: nil.
	reference isEmpty ifTrue: [ ^ resolved ].
	reference first = $# ifFalse: [ resolved queryRemoveAll ].
	resolved processRelativeReference: reference.
	^ resolved! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
hasPath
	^ segments notNil and: [ segments isEmpty not ]! !

!ZnUrl methodsFor: 'operations' stamp: 'nil'!
performOperation: operation with: argument
	"Look for and execute a handler that can perform operation 
	on the receiver with the optional argument"
	
	^ ZnUrlOperation
		performOperation: operation 
		with: argument 
		on: self ! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
password
	^ password! !

!ZnUrl methodsFor: 'private' stamp: 'nil'!
encodeQuery: string on: stream
	stream nextPutAll: (ZnResourceMetaUtils encodePercent: string safeSet: #querySafeSet encoder: ZnCharacterEncoder utf8)! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
authority
	^ self hasNonDefaultPort 
		ifTrue: [ 
			String streamContents: [ :stream | 
				stream nextPutAll: self host; nextPut: $:; print: self port ] ]
		ifFalse: [ 
			self host ]! !

!ZnUrl methodsFor: 'private' stamp: 'nil'!
setDefaults
	self hasScheme 
		ifFalse: [ self scheme: self schemeOrDefault ].
	self hasPort 
		ifFalse: [ self port: self portOrDefault ]    ! !

!ZnUrl methodsFor: 'private' stamp: 'nil'!
encodePath: string on: stream
	stream nextPutAll: (ZnResourceMetaUtils encodePercent: string safeSet: #urlPathSafeSet encoder: ZnCharacterEncoder utf8)! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isSlash
	^ self hasPath not or: [ segments size = 1 and: [ segments first = #/ ] ]! !

!ZnUrl methodsFor: 'printing' stamp: 'nil'!
pathPrintString
	^ String streamContents: [ :stream | 
			self printPathOn: stream ]! !

!ZnUrl methodsFor: 'comparing' stamp: 'nil'!
= anObject
	^ self == anObject
		or: [ self class == anObject class and: [ self equals: anObject ] ]! !

!ZnUrl methodsFor: 'accessing - query' stamp: 'nil'!
queryRemoveAll
	"Modify the receiver by removing all query parameters"
	
	self hasQuery
		ifTrue: [ self query removeAll ]! !

!ZnUrl methodsFor: 'printing' stamp: 'nil'!
printAuthorityOn: stream
	self hasUsername ifTrue: [
		self encode: self username on: stream.
		self hasPassword ifTrue: [
			stream nextPut: $:.
			self encode: self password on: stream ].
		stream nextPut: $@ ].
	self hasHost ifTrue: [ 
		self encode: self host on: stream ].
	self hasPort ifTrue: [ 
		stream nextPut: $:; print: self port ]
! !

!ZnUrl methodsFor: 'private' stamp: 'nil'!
isSchemeNotUsingDoubleSlash: schemeString
	^ self class schemesNotUsingDoubleSlash includes: schemeString asLowercase! !

!ZnUrl methodsFor: 'private' stamp: 'nil'!
segments
	^ segments! !

!ZnUrl methodsFor: 'parsing' stamp: 'nil'!
parseFrom: string
	self parseFrom: string defaultScheme: nil! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
hasSecureScheme
	^ #(https wss) includes: self scheme! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
firstPathSegment
	^ self isSlash
		ifTrue: [ nil ]
		ifFalse: [ segments first ]! !

!ZnUrl methodsFor: 'accessing - query' stamp: 'nil'!
queryKeys
	"Return the collection of all query keys in the receiver"
	
	^ self hasQuery
		ifTrue: [ self query keys ]
		ifFalse: [ #() ]! !

!ZnUrl methodsFor: 'private' stamp: 'nil'!
decodePercent: string
	^ ZnResourceMetaUtils decodePercent: string! !

!ZnUrl methodsFor: 'comparing' stamp: 'nil'!
equals: url
	self scheme = url scheme ifFalse: [ ^ false ].
	self host = url host ifFalse: [ ^ false ].
	self portOrDefault = url portOrDefault ifFalse: [ ^ false ].
	((self isSlash and: [ url isSlash ]) or: [ self segments = url segments ]) ifFalse: [ ^ false ].
	(self hasQuery or: [ url hasQuery ])
		ifTrue: [ self query = url query ifFalse: [ ^ false ] ].
	self fragment = url fragment ifFalse: [ ^ false ].
	^ true! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
hasUsername
	^ username notNil! !

!ZnUrl methodsFor: '*STON-Extensions' stamp: ''!
stonOn: stonWriter
	stonWriter 
		writeObject: self 
		named: STONZnUrl stonName 
		listSingleton: self asString ! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isSchemeUsingPath
	^ (self class schemesNotUsingPath includes: self scheme) not! !

!ZnUrl methodsFor: '*STON-Extensions' stamp: ''!
stonContainSubObjects
	^ false! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
mailToAddress
	"Assuming my scheme is #mailto, return the address."
	
	^ self username, '@', self host ! !

!ZnUrl methodsFor: 'accessing - query' stamp: 'nil'!
queryAddAll: keyedCollection
	"Add all key/value pairs in keyedCollection as query parameters to the receiver.
	Note that we use #addAllMulti:"

	keyedCollection isEmpty
		ifFalse: [ 
			query ifNil: [ query := ZnMultiValueDictionary new ].
			query addAllMulti: keyedCollection ].
	^ keyedCollection! !

!ZnUrl methodsFor: 'printing' stamp: 'nil'!
pathQueryFragmentPrintString
	^ String streamContents: [ :stream | 
			self printPathQueryFragmentOn: stream ]! !

!ZnUrl methodsFor: 'converting' stamp: 'nil'!
asUrl
	^ self! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isSchemeUsingDoubleSlash
	^ (self class schemesNotUsingDoubleSlash includes: self scheme) not! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isHttps
	^ scheme == #https! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
scheme: anObject
	anObject isNil
		ifTrue: [ scheme := nil ]
		ifFalse: [ scheme := anObject asLowercase asSymbol ]! !

!ZnUrl methodsFor: 'printing' stamp: 'nil'!
printQueryOn: stream
	stream nextPut: $?. 
	ZnResourceMetaUtils writeQueryFields: self query on: 	stream! !

!ZnUrl methodsFor: 'private' stamp: 'nil'!
encode: string on: stream
	stream nextPutAll: (ZnResourceMetaUtils encodePercent: string safeSet: #rfc3986SafeSet encoder: ZnCharacterEncoder utf8)! !

!ZnUrl methodsFor: 'convenience' stamp: 'nil'!
+ string
	^ self withRelativeReference: string! !

!ZnUrl methodsFor: '*Zinc-HTTP' stamp: ''!
saveContentsToFile: aFilename
	"Download and return a fileReference to the resource that I refer to.

	If something goes wrong, an exception will be signalled."
	
	" 'http://zn.stfx.eu/zn/numbers.txt' asZnUrl saveContentsToFile: Path * 'numbers.txt'. "
	
	^ self performOperation: #saveContentsToFile: with: aFilename! !

!ZnUrl methodsFor: 'accessing - query' stamp: 'nil'!
queryAt: key add: value
	"Modify the receiver by adding a query variable key=value.
	If key already exists, value is added to it."

	query isNil 
		ifTrue: [ query := ZnMultiValueDictionary new ].
	query at: key asString add: (value ifNotNil: [value asString])! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
hasScheme
	^ scheme notNil! !

!ZnUrl methodsFor: 'comparing' stamp: 'nil'!
hash
	^ self hasPath
		ifTrue: [ segments inject: host hash into: [ :sum :each | sum bitXor: each hash ] ]
		ifFalse: [ host hash ]! !

!ZnUrl methodsFor: 'convenience' stamp: 'nil'!
/ object
	^ object addedToZnUrl: self! !

!ZnUrl methodsFor: 'operations' stamp: 'nil'!
performOperation: operation
	"Look for and execute a handler that can perform operation on the receiver"
	
	^ self performOperation: operation with: nil! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
closePath
	self isDirectoryPath
		ifFalse: [ self addPathSegment: #/ ]! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isHttp
	^ scheme == #http! !

!ZnUrl methodsFor: 'parsing' stamp: 'nil'!
parsePath: stream
	stream peekFor: $/.
	[ stream atEnd ] whileFalse: [ | segment |
		segment := String streamContents: [ :stringStream |
			[ stream atEnd not and: [ stream peek ~= $/ ] ] whileTrue: [
				stringStream nextPut: stream next ] ].
		segment = '.'
			ifFalse: [
				segment = '..' 
					ifTrue: [ self removeLastPathSegment ]
					ifFalse: [ self addPathSegment: (self decodePercent: segment) ] ].
		((stream peekFor: $/) and: [ stream atEnd ])
			ifTrue: [ self closePath ] ]! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
directory
	^ self isDirectoryPath
		ifTrue: [ self path ]
		ifFalse: [ 
			String streamContents: [ :stream |
				segments allButLast  
					do: [ :each | stream nextPutAll: each ]
					separatedBy: [ stream nextPut: $/ ] ] ]! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
password: string
	password := string! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
file
	^ self isDirectoryPath
		ifTrue: [ String new ]
		ifFalse: [ segments last ]! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
hasHost
	^ host notNil! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
hasNonDefaultPort
	^ self hasPort 
		and: [ self port ~= (self class defaultPortForScheme: self schemeOrDefault) ]! !

!ZnUrl methodsFor: 'convenience' stamp: 'nil'!
addedToZnUrl: url
	^ url withPathSegments: self pathSegments ! !

!ZnUrl methodsFor: 'converting' stamp: 'nil'!
asFileUrl
	"Return a copy of the receiver as a File URL, replacing the scheme with #file.
	This is useful when you want to do a #asFileReference afterwards."
	
	^ self copy
		scheme: #file;
		yourself! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
path
	self hasPath ifFalse: [ ^ String new ].
	^ String streamContents: [ :stream | 
		segments 
			do: [ :each | 
				each == #/
					ifFalse: [ stream nextPutAll: each ] ]
			separatedBy: [ stream nextPut: $/ ] ]! !

!ZnUrl methodsFor: 'accessing - query' stamp: 'nil'!
queryAt: key ifAbsent: block
	"Return the value of the query parameter key in the receiver.
	Execute block if there is no such parameter"
	
	^ self hasQuery
		ifTrue: [ self query at: key asString ifAbsent: block ]
		ifFalse: block! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isFile
	^ scheme = #file! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isLocalHost
	^ self hasHost and: [ #('localhost' '127.0.0.1') includes: self host ]! !

!ZnUrl methodsFor: 'convenience' stamp: 'nil'!
& association
	^ self withQuery: association ! !

!ZnUrl methodsFor: 'private' stamp: 'nil'!
segments: collection
	segments := collection! !

!ZnUrl methodsFor: 'copying' stamp: 'nil'!
postCopy
	super postCopy.
	segments := segments copy.
	query := query copy! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
hasPassword
	^ password notNil! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isAbsolute
	"We consider URLs with scheme://host as absolute (port is not relevant here).
	See also #inContextOf: and #withRelativeReference:"
	
	^ self hasScheme and: [ self hasHost ]! !

!ZnUrl methodsFor: 'printing' stamp: 'nil'!
printPathQueryFragmentOn: stream
	self isSchemeUsingPath 
		ifTrue: [ self printPathOn: stream ].
	self hasQuery
		ifTrue: [ self printQueryOn: stream ].
	self hasFragment
		ifFalse: [ ^ self ].
	stream nextPut: $#.
	self encodeQuery: self fragment on: stream! !

!ZnUrl methodsFor: 'convenience' stamp: 'nil'!
enforceKnownScheme
	(scheme isNil or: [ #(#http #https #ws #wss #file) includes: scheme ])
		ifFalse: [ (ZnUnknownScheme scheme: scheme) signal ]! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isFilePath
	^ self isDirectoryPath not! !

!ZnUrl methodsFor: 'parsing' stamp: 'nil'!
parseUserInfo: stream
	| userString |
	(userString := stream upTo: $:) isEmpty 
		ifFalse: [  
			self username: (self decodePercent: userString) ].
	stream atEnd 
		ifFalse: [ 
			self password: (self decodePercent: stream upToEnd) ]! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
scheme
	^ scheme! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
hasFragment
	^ fragment notNil! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
host: hostName
	host := hostName ifNotNil: [ hostName asLowercase ]! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isEmpty
	^ (self hasScheme | self hasHost | self hasPath | self hasQuery | self hasFragment | self hasUsername | self hasPassword) not! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
pathSegments
	^ segments ifNil: [ #() ]! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
clearPath
	self hasPath
		ifTrue: [ segments removeAll ]! !

!ZnUrl methodsFor: 'accessing - query' stamp: 'nil'!
queryDo: block
	"Execute block for each query key/value pair in the receiver"
	
	self hasQuery ifTrue: [ 
		self query keysAndValuesDo: block ]! !

!ZnUrl methodsFor: 'printing' stamp: 'nil'!
printOn: stream
	self hasScheme ifTrue: [ 
		stream nextPutAll: self scheme; nextPut: $:.
		self isSchemeUsingDoubleSlash ifTrue: [ stream nextPut: $/; nextPut: $/ ] ].
	self printAuthorityOn: stream.
	self printPathQueryFragmentOn: stream! !

!ZnUrl methodsFor: 'printing' stamp: 'nil'!
printPathOn: stream
	self hasPath ifFalse: [ ^ stream nextPut: $/ ].
 	segments do: [ :each | 
		stream nextPut: $/.
		each == #/
			ifFalse: [ 
				self encodePath: each on: stream ] ] ! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
hasPort
	^ port notNil! !

!ZnUrl methodsFor: 'parsing' stamp: 'nil'!
parseAuthority: string from: start to: stop
	| index |
	((index := string indexOf: $@ startingAt: start) > 0 and: [ index < stop ])
		ifTrue: [
			self parseUserInfo: (ReadStream on: string from: start to: index - 1).
			self parseHostPort: (ReadStream on: string from: index + 1 to: stop) ]
		ifFalse: [ 
			self parseHostPort: (ReadStream on: string from: start to: stop) ]! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
schemeOrDefault
	^ self hasScheme 
		ifTrue: [ self scheme ]
		ifFalse: [ #http ]    ! !

!ZnUrl methodsFor: 'converting' stamp: 'nil'!
asRelativeUrl
	"Copy the receiver, with scheme, host and port cleared"
	
	^ self copy
		scheme: nil;
		host: nil;
		port: nil;
		yourself! !

!ZnUrl methodsFor: '*Zinc-HTTP' stamp: ''!
retrieveContents
	"Download and return the resource that I refer to.
	This will typically return a String or a ByteArray.
	If something goes wrong, an exception will be signalled."
	
	" 'http://zn.stfx.eu/zn/numbers.txt' asZnUrl retrieveContents. "
	
	^ self performOperation: #retrieveContents! !

!ZnUrl methodsFor: 'accessing - query' stamp: 'nil'!
queryAt: key
	"Return the value of the query parameter key in the receiver.
	Signal a KeyNotFound exception if there is no such parameter"
	
	^ self queryAt: key ifAbsent: [ KeyNotFound signalFor: key printString ]! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
fragment: string
	fragment := string! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
port: integer
	port := integer! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
host
	^ host! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
query: dictionary
	query := dictionary! !

!ZnUrl methodsFor: 'accessing - query' stamp: 'nil'!
queryRemoveKey: key
	"Modify the receiver by remove the query parameter named key.
	Do nothing if there is no such parameter"
	
	self hasQuery
		ifTrue: [ self query removeKey: key asString ifAbsent: [ ] ]! !

!ZnUrl methodsFor: '*Zinc-Resource-Meta-FileSystem' stamp: ''!
asFileReference
	"Convert the receiver into a new FileReference object.
	Note that for a FileReference a trailing slash is not relevant"

	| path |
	self assert: self scheme = #file description: 'Only a file:// URL can be converted to a FileReference'.
	self isSlash
		ifTrue: [ ^ FileSystem root ].
	path := self isDirectoryPath
		ifTrue: [ segments allButLast ]
		ifFalse: [ segments copy ].
	^ FileReference fileSystem: FileSystem disk path: (AbsolutePath withAll: path)! !

!ZnUrl methodsFor: 'convenience' stamp: 'nil'!
? association
	^ self withQuery: association ! !

!ZnUrl methodsFor: 'converting' stamp: 'nil'!
asZnUrlWithDefaults
	^ self copy 
		setDefaults; 
		yourself! !

!ZnUrl methodsFor: 'converting' stamp: 'nil'!
asZnUrl
	^ self! !

!ZnUrl methodsFor: 'parsing' stamp: 'nil'!
parseHostPort: stream
	| hostString portNumber |
	self isFile
		ifTrue: [ 
			(hostString := stream upTo: $/) isEmpty
				ifFalse: [ self host: (self decodePercent: hostString) ] ]
		ifFalse: [ 
			(hostString := stream upTo: $:) isEmpty
				ifFalse: [ self host: (self decodePercent: hostString) ].
			stream atEnd
				ifFalse: [
					portNumber := Integer readFrom: stream ifFail: [ ZnPortNotANumber signal ].
					(portNumber between: 1 and: 65535) ifFalse: [ DomainError signalFrom: 1 to: 65535 ].
					self port: portNumber ] ]! !

!ZnUrl methodsFor: 'private' stamp: 'nil'!
processRelativeReference: reference
	"Parse & resolve the relative reference using myself as base URL, destructively"
	
	| index end |
	reference first = $/ ifTrue: [ self clearPath ].
	(self isFilePath and: [ ('?#' includes: reference first) not ] ) ifTrue: [ self removeLastPathSegment ].
	end := reference size.
	(index := reference indexOf: $#) > 0
		ifTrue: [ 
			self fragment: (self decodePercent: (reference copyFrom: index + 1 to: end)).
			end := index - 1 ].
	(index := reference indexOf: $?) > 0
		ifTrue: [
			self query: (ZnResourceMetaUtils parseQueryFrom: (ReadStream on: reference from: index + 1 to: end)).
			end := index - 1 ].
	self parsePath: (ReadStream on: reference from: 1 to: end).
	(reference = '.' ) | (reference = '..' ) | (reference endsWith: '/.') | (reference endsWith: '/..') 
		ifTrue: [ self closePath ]! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
portIfAbsent: valuable
	^ self hasPort
		ifTrue: [ self port ]
		ifFalse: valuable! !

!ZnUrl methodsFor: 'accessing - query' stamp: 'nil'!
queryAt: key ifPresent: block
	"Execute block with the value of the query parameter named key as value.
	Return nil if there is no such parameter"
	
	^ self hasQuery
		ifTrue: [ self query at: key asString ifPresent: block ]! !

!ZnUrl methodsFor: 'convenience' stamp: 'nil'!
withPathSegment: segment
	"Return a new URL equal to the receiver with its path extended with segment"
	
	^ self copy
		addPathSegment: segment;
		yourself! !

!ZnUrl methodsFor: 'accessing' stamp: 'nil'!
username: string
	username := string! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
addPathSegments: pathSegments
	"Modify the receiver's path by adding the elements of pathSegments at the end"

	pathSegments do: [ :each | self addPathSegment: each ]! !

!ZnUrl methodsFor: 'testing' stamp: 'nil'!
isDirectoryPath
	^ self hasPath 
		ifTrue: [ segments last = #/ ]
		ifFalse: [ true ]
	! !

!ZnUrl methodsFor: 'accessing - path' stamp: 'nil'!
removeFirstPathSegment
	self hasPath
		ifTrue: [ segments removeFirst ]! !

!ZnUrl methodsFor: 'accessing - query' stamp: 'nil'!
queryAt: key put: value
	"Modify the receiver by setting a query variable key=value.
	If key is already exists, it is overwritten."

	query isNil 
		ifTrue: [ query := ZnMultiValueDictionary new ].
	query at: key asString put: (value ifNotNil: [value asString])! !

!ZnUrl class methodsFor: 'instance creation' stamp: 'nil'!
fromString: string
	^ (self new)
		parseFrom: string; 
		yourself ! !

!ZnUrl class methodsFor: 'accessing' stamp: 'nil'!
image
	"Return a File URL refering to the file path of the current image file.
	This is useful as a context to resolve relative URLs, see #withRelativeReference:"
	
	^ SmalltalkImage current imagePath asPath asZnUrl! !

!ZnUrl class methodsFor: 'accessing' stamp: 'nil'!
schemesNotUsingPath
	"Most URL schemes use a hierarchical path
	but some don't, return a list of those"
	
	^ #( #mailto )! !

!ZnUrl class methodsFor: 'accessing' stamp: 'nil'!
schemesNotUsingDoubleSlash
	"Most URL schemes use a double slash, as in http://
	but some don't, return a list of those"
	
	^ #( #mailto #telnet )! !

!ZnUrl class methodsFor: 'instance creation' stamp: 'nil'!
fromString: string defaultScheme: defaultScheme
	^ (self new)
		parseFrom: string defaultScheme: defaultScheme; 
		yourself ! !

!ZnUrl class methodsFor: 'accessing' stamp: 'nil'!
defaultPortForScheme: scheme
	(#(http ws) includes: scheme) ifTrue: [ ^ 80 ].
	(#(https wss) includes: scheme) ifTrue: [ ^ 443 ].
	^ nil! !

!ZnUrlCopy commentStamp: ''!
I'm a copy of ZnUrl because ZnrUrl query does not use an dictionary garantying ordered keys.
May be we could change ZnUrl to be able to change the dictionary used there...
I do not have the time to address this point.
!
!ZnUrlCopy methodsFor: 'convenience' stamp: ''!
withPathSegments: pathSegments
	"Return a new URL equal to the receiver with its path extended with pathSegments"
	
	^ self copy
		addPathSegments: pathSegments;
		yourself! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
lastPathSegment
	^ self isSlash
		ifTrue: [ nil ]
		ifFalse: [ segments last ]! !

!ZnUrlCopy methodsFor: 'converting' stamp: ''!
inContextOf: absoluteUrl
	"Return a copy of the receiver where scheme, host and port
	are taken from absoluteUrl unless they are already in the receiver.
	Path merging is not supported. See also #withRelativeReference: "
	
	| copy |
	copy := self copy.
	copy hasScheme ifFalse: [ copy scheme: absoluteUrl scheme ].
	copy hasHost ifFalse: [ copy host: absoluteUrl host ].
	(copy hasPort not and: [ copy scheme = absoluteUrl scheme ]) 
		ifTrue: [ copy port: absoluteUrl port ].      
	^ copy! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
portOrDefault
	^ self portIfAbsent: [ self class defaultPortForScheme: self schemeOrDefault ]! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
removeLastPathSegment
	self hasPath
		ifTrue: [ segments removeLast ]! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
hasQuery
	^ query notNil and: [ query isEmpty not ]! !

!ZnUrlCopy methodsFor: 'parsing' stamp: ''!
parseFrom: string defaultScheme: defaultScheme
	| start end index |
	start := 1.
	end := string size.
	(index := string indexOf: $#) > 0
		ifTrue: [ 
			self fragment: (self decodePercent: (string copyFrom: index + 1 to: end)).
			end := index - 1 ].
	(index := string indexOf: $?) > 0
		ifTrue: [
			self query: (ZnResourceMetaUtils parseQueryFrom: (ReadStream on: string from: index + 1 to: end)).
			end := index - 1 ].
	((index := string indexOfSubCollection: '://') > 0 and: [ index <= end ])
		ifTrue: [
			self scheme: (string copyFrom: 1 to: index - 1).
			start := index + 3 ]
		ifFalse: [ 
			((index := string indexOf: $:) > 0 
					and: [ index <= end 
						and: [ self isSchemeNotUsingDoubleSlash: (string copyFrom: 1 to: index - 1) ] ])
				ifTrue: [ 
					self scheme: (string copyFrom: 1 to: index - 1).
					start := index + 1 ]
				ifFalse: [ 
					defaultScheme ifNotNil: [ self scheme: defaultScheme ] ] ].
	self hasScheme 
		ifTrue: [  
			(index := string indexOf: $/ startingAt: start) > 0
				ifTrue: [
					self parseAuthority: string from: start to: index - 1.
					start := index ]
				ifFalse: [ 
					^ self parseAuthority: string from: start to: end ] ].
	self parsePath: (ReadStream on: string from: start to: end)! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
addPathSegment: segment
	"Modify the receiver's path by adding segment at the end"
	
	segments isNil ifTrue: [ 
		segments := OrderedCollection new ].
	segments add: segment! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
authorityWithPort
	^ String streamContents: [ :stream | 
			stream nextPutAll: self host; nextPut: $:; print: self portOrDefault ] ! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
port
	^ port! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isRelative
	^ self isAbsolute not! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
username
	^ username! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
fragment
	^ fragment! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
query
	^ query! !

!ZnUrlCopy methodsFor: 'convenience' stamp: ''!
withQuery: association
	"Return a new URL equal to the receiver with the association's 
	key=value added as a query parameter.
	Note that #queryAt:add: is used."
	
	^ self copy
		queryAt: association key add: association value;
		yourself 
		! !

!ZnUrlCopy methodsFor: 'parsing' stamp: ''!
withRelativeReference: reference
	"Return a new URL by parsing & resolving the relative reference using myself as base URL.
	This implements the process described in RFC 3986 Section 5"
	
	| resolved |
	[ (resolved := reference asZnUrl) isAbsolute 
		ifTrue: [ ^ resolved ] ] on: Error do: [ ].
	(reference beginsWith: '//')
		ifTrue: [ ^ self class fromString: (reference allButFirst: 2) defaultScheme: self scheme ].
	resolved := self copy.
	resolved fragment: nil.
	reference isEmpty ifTrue: [ ^ resolved ].
	reference first = $# ifFalse: [ resolved queryRemoveAll ].
	resolved processRelativeReference: reference.
	^ resolved! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
hasPath
	^ segments notNil and: [ segments isEmpty not ]! !

!ZnUrlCopy methodsFor: 'operations' stamp: ''!
performOperation: operation with: argument
	"Look for and execute a handler that can perform operation 
	on the receiver with the optional argument"
	
	^ ZnUrlOperation
		performOperation: operation 
		with: argument 
		on: self ! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
password
	^ password! !

!ZnUrlCopy methodsFor: 'private' stamp: ''!
encodeQuery: string on: stream
	stream nextPutAll: (ZnResourceMetaUtils encodePercent: string safeSet: #querySafeSet encoder: ZnCharacterEncoder utf8)! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
authority
	^ self hasNonDefaultPort 
		ifTrue: [ 
			String streamContents: [ :stream | 
				stream nextPutAll: self host; nextPut: $:; print: self port ] ]
		ifFalse: [ 
			self host ]! !

!ZnUrlCopy methodsFor: 'private' stamp: ''!
setDefaults
	self hasScheme 
		ifFalse: [ self scheme: self schemeOrDefault ].
	self hasPort 
		ifFalse: [ self port: self portOrDefault ]    ! !

!ZnUrlCopy methodsFor: 'private' stamp: ''!
encodePath: string on: stream
	stream nextPutAll: (ZnResourceMetaUtils encodePercent: string safeSet: #urlPathSafeSet encoder: ZnCharacterEncoder utf8)! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isSlash
	^ self hasPath not or: [ segments size = 1 and: [ segments first = #/ ] ]! !

!ZnUrlCopy methodsFor: 'printing' stamp: ''!
pathPrintString
	^ String streamContents: [ :stream | 
			self printPathOn: stream ]! !

!ZnUrlCopy methodsFor: 'comparing' stamp: ''!
= anObject
	^ self == anObject
		or: [ self class == anObject class and: [ self equals: anObject ] ]! !

!ZnUrlCopy methodsFor: 'accessing - query' stamp: ''!
queryRemoveAll
	"Modify the receiver by removing all query parameters"
	
	self hasQuery
		ifTrue: [ self query removeAll ]! !

!ZnUrlCopy methodsFor: 'printing' stamp: ''!
printAuthorityOn: stream
	self hasUsername ifTrue: [
		self encode: self username on: stream.
		self hasPassword ifTrue: [
			stream nextPut: $:.
			self encode: self password on: stream ].
		stream nextPut: $@ ].
	self hasHost ifTrue: [ 
		self encode: self host on: stream ].
	self hasPort ifTrue: [ 
		stream nextPut: $:; print: self port ]
! !

!ZnUrlCopy methodsFor: 'private' stamp: ''!
isSchemeNotUsingDoubleSlash: schemeString
	^ self class schemesNotUsingDoubleSlash includes: schemeString asLowercase! !

!ZnUrlCopy methodsFor: 'private' stamp: ''!
segments
	^ segments! !

!ZnUrlCopy methodsFor: 'parsing' stamp: ''!
parseFrom: string
	self parseFrom: string defaultScheme: nil! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
hasSecureScheme
	^ #(https wss) includes: self scheme! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
firstPathSegment
	^ self isSlash
		ifTrue: [ nil ]
		ifFalse: [ segments first ]! !

!ZnUrlCopy methodsFor: 'accessing - query' stamp: ''!
queryKeys
	"Return the collection of all query keys in the receiver"
	
	^ self hasQuery
		ifTrue: [ self query keys ]
		ifFalse: [ #() ]! !

!ZnUrlCopy methodsFor: 'private' stamp: ''!
decodePercent: string
	^ ZnResourceMetaUtils decodePercent: string! !

!ZnUrlCopy methodsFor: 'comparing' stamp: ''!
equals: url
	self scheme = url scheme ifFalse: [ ^ false ].
	self host = url host ifFalse: [ ^ false ].
	self portOrDefault = url portOrDefault ifFalse: [ ^ false ].
	((self isSlash and: [ url isSlash ]) or: [ self segments = url segments ]) ifFalse: [ ^ false ].
	(self hasQuery or: [ url hasQuery ])
		ifTrue: [ self query = url query ifFalse: [ ^ false ] ].
	self fragment = url fragment ifFalse: [ ^ false ].
	^ true! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
hasUsername
	^ username notNil! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isSchemeUsingPath
	^ (self class schemesNotUsingPath includes: self scheme) not! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
mailToAddress
	"Assuming my scheme is #mailto, return the address."
	
	^ self username, '@', self host ! !

!ZnUrlCopy methodsFor: 'accessing - query' stamp: ''!
queryAddAll: keyedCollection
	"Add all key/value pairs in keyedCollection as query parameters to the receiver.
	Note that we use #addAllMulti:"

	keyedCollection isEmpty
		ifFalse: [ 
			query ifNil: [ query := OrderedDictionary new ].
			query addAllMulti: keyedCollection ].
	^ keyedCollection! !

!ZnUrlCopy methodsFor: 'printing' stamp: ''!
pathQueryFragmentPrintString
	^ String streamContents: [ :stream | 
			self printPathQueryFragmentOn: stream ]! !

!ZnUrlCopy methodsFor: 'converting' stamp: ''!
asUrl
	^ self! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isSchemeUsingDoubleSlash
	^ (self class schemesNotUsingDoubleSlash includes: self scheme) not! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isHttps
	^ scheme == #https! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
scheme: anObject
	anObject isNil
		ifTrue: [ scheme := nil ]
		ifFalse: [ scheme := anObject asLowercase asSymbol ]! !

!ZnUrlCopy methodsFor: 'printing' stamp: ''!
printQueryOn: stream
	stream nextPut: $?. 
	ZnResourceMetaUtils writeQueryFields: self query on: 	stream! !

!ZnUrlCopy methodsFor: 'private' stamp: ''!
encode: string on: stream
	stream nextPutAll: (ZnResourceMetaUtils encodePercent: string safeSet: #rfc3986SafeSet encoder: ZnCharacterEncoder utf8)! !

!ZnUrlCopy methodsFor: 'convenience' stamp: ''!
+ string
	^ self withRelativeReference: string! !

!ZnUrlCopy methodsFor: 'accessing - query' stamp: ''!
queryAt: key add: value
	"Modify the receiver by adding a query variable key=value.
	If key already exists, value is added to it."

	query isNil 
		ifTrue: [ query := ZnMultiValueDictionary new ].
	query at: key asString add: (value ifNotNil: [value asString])! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
hasScheme
	^ scheme notNil! !

!ZnUrlCopy methodsFor: 'comparing' stamp: ''!
hash
	^ self hasPath
		ifTrue: [ segments inject: host hash into: [ :sum :each | sum bitXor: each hash ] ]
		ifFalse: [ host hash ]! !

!ZnUrlCopy methodsFor: 'convenience' stamp: ''!
/ object
	^ object addedToZnUrl: self! !

!ZnUrlCopy methodsFor: 'operations' stamp: ''!
performOperation: operation
	"Look for and execute a handler that can perform operation on the receiver"
	
	^ self performOperation: operation with: nil! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
closePath
	self isDirectoryPath
		ifFalse: [ self addPathSegment: #/ ]! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isHttp
	^ scheme == #http! !

!ZnUrlCopy methodsFor: 'parsing' stamp: ''!
parsePath: stream
	stream peekFor: $/.
	[ stream atEnd ] whileFalse: [ | segment |
		segment := String streamContents: [ :stringStream |
			[ stream atEnd not and: [ stream peek ~= $/ ] ] whileTrue: [
				stringStream nextPut: stream next ] ].
		segment = '.'
			ifFalse: [
				segment = '..' 
					ifTrue: [ self removeLastPathSegment ]
					ifFalse: [ self addPathSegment: (self decodePercent: segment) ] ].
		((stream peekFor: $/) and: [ stream atEnd ])
			ifTrue: [ self closePath ] ]! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
directory
	^ self isDirectoryPath
		ifTrue: [ self path ]
		ifFalse: [ 
			String streamContents: [ :stream |
				segments allButLast  
					do: [ :each | stream nextPutAll: each ]
					separatedBy: [ stream nextPut: $/ ] ] ]! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
password: string
	password := string! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
file
	^ self isDirectoryPath
		ifTrue: [ String new ]
		ifFalse: [ segments last ]! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
hasHost
	^ host notNil! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
hasNonDefaultPort
	^ self hasPort 
		and: [ self port ~= (self class defaultPortForScheme: self schemeOrDefault) ]! !

!ZnUrlCopy methodsFor: 'convenience' stamp: ''!
addedToZnUrl: url
	^ url withPathSegments: self pathSegments ! !

!ZnUrlCopy methodsFor: 'converting' stamp: ''!
asFileUrl
	"Return a copy of the receiver as a File URL, replacing the scheme with #file.
	This is useful when you want to do a #asFileReference afterwards."
	
	^ self copy
		scheme: #file;
		yourself! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
path
	self hasPath ifFalse: [ ^ String new ].
	^ String streamContents: [ :stream | 
		segments 
			do: [ :each | 
				each == #/
					ifFalse: [ stream nextPutAll: each ] ]
			separatedBy: [ stream nextPut: $/ ] ]! !

!ZnUrlCopy methodsFor: 'accessing - query' stamp: ''!
queryAt: key ifAbsent: block
	"Return the value of the query parameter key in the receiver.
	Execute block if there is no such parameter"
	
	^ self hasQuery
		ifTrue: [ self query at: key asString ifAbsent: block ]
		ifFalse: block! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isFile
	^ scheme = #file! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isLocalHost
	^ self hasHost and: [ #('localhost' '127.0.0.1') includes: self host ]! !

!ZnUrlCopy methodsFor: 'convenience' stamp: ''!
& association
	^ self withQuery: association ! !

!ZnUrlCopy methodsFor: 'private' stamp: ''!
segments: collection
	segments := collection! !

!ZnUrlCopy methodsFor: 'copying' stamp: ''!
postCopy
	super postCopy.
	segments := segments copy.
	query := query copy! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
hasPassword
	^ password notNil! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isAbsolute
	"We consider URLs with scheme://host as absolute (port is not relevant here).
	See also #inContextOf: and #withRelativeReference:"
	
	^ self hasScheme and: [ self hasHost ]! !

!ZnUrlCopy methodsFor: 'printing' stamp: ''!
printPathQueryFragmentOn: stream
	self isSchemeUsingPath 
		ifTrue: [ self printPathOn: stream ].
	self hasQuery
		ifTrue: [ self printQueryOn: stream ].
	self hasFragment
		ifFalse: [ ^ self ].
	stream nextPut: $#.
	self encodeQuery: self fragment on: stream! !

!ZnUrlCopy methodsFor: 'convenience' stamp: ''!
enforceKnownScheme
	(scheme isNil or: [ #(#http #https #ws #wss #file) includes: scheme ])
		ifFalse: [ (ZnUnknownScheme scheme: scheme) signal ]! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isFilePath
	^ self isDirectoryPath not! !

!ZnUrlCopy methodsFor: 'parsing' stamp: ''!
parseUserInfo: stream
	| userString |
	(userString := stream upTo: $:) isEmpty 
		ifFalse: [  
			self username: (self decodePercent: userString) ].
	stream atEnd 
		ifFalse: [ 
			self password: (self decodePercent: stream upToEnd) ]! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
scheme
	^ scheme! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
hasFragment
	^ fragment notNil! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
host: hostName
	host := hostName ifNotNil: [ hostName asLowercase ]! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isEmpty
	^ (self hasScheme | self hasHost | self hasPath | self hasQuery | self hasFragment | self hasUsername | self hasPassword) not! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
pathSegments
	^ segments ifNil: [ #() ]! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
clearPath
	self hasPath
		ifTrue: [ segments removeAll ]! !

!ZnUrlCopy methodsFor: 'accessing - query' stamp: ''!
queryDo: block
	"Execute block for each query key/value pair in the receiver"
	
	self hasQuery ifTrue: [ 
		self query keysAndValuesDo: block ]! !

!ZnUrlCopy methodsFor: 'printing' stamp: ''!
printOn: stream
	self hasScheme ifTrue: [ 
		stream nextPutAll: self scheme; nextPut: $:.
		self isSchemeUsingDoubleSlash ifTrue: [ stream nextPut: $/; nextPut: $/ ] ].
	self printAuthorityOn: stream.
	self printPathQueryFragmentOn: stream! !

!ZnUrlCopy methodsFor: 'printing' stamp: ''!
printPathOn: stream
	self hasPath ifFalse: [ ^ stream nextPut: $/ ].
 	segments do: [ :each | 
		stream nextPut: $/.
		each == #/
			ifFalse: [ 
				self encodePath: each on: stream ] ] ! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
hasPort
	^ port notNil! !

!ZnUrlCopy methodsFor: 'parsing' stamp: ''!
parseAuthority: string from: start to: stop
	| index |
	((index := string indexOf: $@ startingAt: start) > 0 and: [ index < stop ])
		ifTrue: [
			self parseUserInfo: (ReadStream on: string from: start to: index - 1).
			self parseHostPort: (ReadStream on: string from: index + 1 to: stop) ]
		ifFalse: [ 
			self parseHostPort: (ReadStream on: string from: start to: stop) ]! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
schemeOrDefault
	^ self hasScheme 
		ifTrue: [ self scheme ]
		ifFalse: [ #http ]    ! !

!ZnUrlCopy methodsFor: 'converting' stamp: ''!
asRelativeUrl
	"Copy the receiver, with scheme, host and port cleared"
	
	^ self copy
		scheme: nil;
		host: nil;
		port: nil;
		yourself! !

!ZnUrlCopy methodsFor: 'accessing - query' stamp: ''!
queryAt: key
	"Return the value of the query parameter key in the receiver.
	Signal a KeyNotFound exception if there is no such parameter"
	
	^ self queryAt: key ifAbsent: [ KeyNotFound signalFor: key printString ]! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
fragment: string
	fragment := string! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
port: integer
	port := integer! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
host
	^ host! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
query: dictionary
	query := dictionary! !

!ZnUrlCopy methodsFor: 'accessing - query' stamp: ''!
queryRemoveKey: key
	"Modify the receiver by remove the query parameter named key.
	Do nothing if there is no such parameter"
	
	self hasQuery
		ifTrue: [ self query removeKey: key asString ifAbsent: [ ] ]! !

!ZnUrlCopy methodsFor: 'converting' stamp: ''!
asFileReference
	"Convert the receiver into a new FileReference object.
	Note that for a FileReference a trailing slash is not relevant"

	| path |
	self isSlash
		ifTrue: [ ^ FileSystem root ].
	path := self isDirectoryPath
		ifTrue: [ segments allButLast ]
		ifFalse: [ segments copy ].
	^ FileReference fileSystem: FileSystem disk path: (AbsolutePath withAll: path)! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isWeb

	^ #( http https ) includes: self scheme! !

!ZnUrlCopy methodsFor: 'convenience' stamp: ''!
? association
	^ self withQuery: association ! !

!ZnUrlCopy methodsFor: 'converting' stamp: ''!
asZnUrlWithDefaults
	^ self copy 
		setDefaults; 
		yourself! !

!ZnUrlCopy methodsFor: 'converting' stamp: ''!
asZnUrl
	^ self! !

!ZnUrlCopy methodsFor: 'parsing' stamp: ''!
parseHostPort: stream
	| hostString portNumber |
	self isFile
		ifTrue: [ 
			(hostString := stream upTo: $/) isEmpty
				ifFalse: [ self host: (self decodePercent: hostString) ] ]
		ifFalse: [ 
			(hostString := stream upTo: $:) isEmpty
				ifFalse: [ self host: (self decodePercent: hostString) ].
			stream atEnd
				ifFalse: [
					portNumber := Integer readFrom: stream ifFail: [ ZnPortNotANumber signal ].
					(portNumber between: 1 and: 65535) ifFalse: [ DomainError signalFrom: 1 to: 65535 ].
					self port: portNumber ] ]! !

!ZnUrlCopy methodsFor: 'private' stamp: ''!
processRelativeReference: reference
	"Parse & resolve the relative reference using myself as base URL, destructively"
	
	| index end |
	reference first = $/ ifTrue: [ self clearPath ].
	(self isFilePath and: [ ('?#' includes: reference first) not ] ) ifTrue: [ self removeLastPathSegment ].
	end := reference size.
	(index := reference indexOf: $#) > 0
		ifTrue: [ 
			self fragment: (self decodePercent: (reference copyFrom: index + 1 to: end)).
			end := index - 1 ].
	(index := reference indexOf: $?) > 0
		ifTrue: [
			self query: (ZnResourceMetaUtils parseQueryFrom: (ReadStream on: reference from: index + 1 to: end)).
			end := index - 1 ].
	self parsePath: (ReadStream on: reference from: 1 to: end).
	(reference = '.' ) | (reference = '..' ) | (reference endsWith: '/.') | (reference endsWith: '/..') 
		ifTrue: [ self closePath ]! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
portIfAbsent: valuable
	^ self hasPort
		ifTrue: [ self port ]
		ifFalse: valuable! !

!ZnUrlCopy methodsFor: 'accessing - query' stamp: ''!
queryAt: key ifPresent: block
	"Execute block with the value of the query parameter named key as value.
	Return nil if there is no such parameter"
	
	^ self hasQuery
		ifTrue: [ self query at: key asString ifPresent: block ]! !

!ZnUrlCopy methodsFor: 'convenience' stamp: ''!
withPathSegment: segment
	"Return a new URL equal to the receiver with its path extended with segment"
	
	^ self copy
		addPathSegment: segment;
		yourself! !

!ZnUrlCopy methodsFor: 'accessing' stamp: ''!
username: string
	username := string! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
addPathSegments: pathSegments
	"Modify the receiver's path by adding the elements of pathSegments at the end"

	pathSegments do: [ :each | self addPathSegment: each ]! !

!ZnUrlCopy methodsFor: 'testing' stamp: ''!
isDirectoryPath
	^ self hasPath 
		ifTrue: [ segments last = #/ ]
		ifFalse: [ true ]
	! !

!ZnUrlCopy methodsFor: 'accessing - path' stamp: ''!
removeFirstPathSegment
	self hasPath
		ifTrue: [ segments removeFirst ]! !

!ZnUrlCopy methodsFor: 'accessing - query' stamp: ''!
queryAt: key put: value
	"Modify the receiver by setting a query variable key=value.
	If key is already exists, it is overwritten."

	query isNil 
		ifTrue: [ query := ZnMultiValueDictionary new ].
	query at: key asString put: (value ifNotNil: [value asString])! !

!ZnUrlCopy class methodsFor: 'instance creation' stamp: ''!
fromString: string
	^ (self new)
		parseFrom: string; 
		yourself ! !

!ZnUrlCopy class methodsFor: 'accessing' stamp: ''!
image
	"Return a File URL refering to the file path of the current image file.
	This is useful as a context to resolve relative URLs, see #withRelativeReference:"
	
	^ SmalltalkImage current imagePath asPath asZnUrl! !

!ZnUrlCopy class methodsFor: 'accessing' stamp: ''!
schemesNotUsingPath
	"Most URL schemes use a hierarchical path
	but some don't, return a list of those"
	
	^ #( #mailto )! !

!ZnUrlCopy class methodsFor: 'accessing' stamp: ''!
schemesNotUsingDoubleSlash
	"Most URL schemes use a double slash, as in http://
	but some don't, return a list of those"
	
	^ #( #mailto #telnet )! !

!ZnUrlCopy class methodsFor: 'instance creation' stamp: ''!
fromString: string defaultScheme: defaultScheme
	^ (self new)
		parseFrom: string defaultScheme: defaultScheme; 
		yourself ! !

!ZnUrlCopy class methodsFor: 'accessing' stamp: ''!
defaultPortForScheme: scheme
	(#(http ws) includes: scheme) ifTrue: [ ^ 80 ].
	(#(https wss) includes: scheme) ifTrue: [ ^ 443 ].
	^ nil! !

!ZnUrlOperation commentStamp: ''!
I am ZnUrlOperation.
I am an abtract superclass of operations that can be performed on ZnUrl objects.

Some operations, like retrieving the contents of a resource described by a URL, depend on elements, most likely the scheme, of the URL. By creating the appropriate subclasses, this behavior can be added.

I implement searching/matching logic on my class side.

  #performOperation:with:on:

which defaults to matching the #operation and #schemes.

I am instanciated to be executed. 

  #performOperation

A concrete example is ZnUrl>>#retrieveContents with subclasses ZnHttpRetrieveContents and ZnFileRetrieveContents.

Part of Zinc HTTP Components.!
!ZnUrlOperation methodsFor: 'accessing' stamp: 'nil'!
argument: anObject
	
	argument := anObject! !

!ZnUrlOperation methodsFor: 'accessing' stamp: 'nil'!
url: aUrl
	
	url := aUrl! !

!ZnUrlOperation methodsFor: 'operations' stamp: 'nil'!
performOperation
	"Perform the actual operation using url and the optional argument."
	
	self subclassResponsibility 
! !

!ZnUrlOperation methodsFor: 'printing' stamp: 'nil'!
printOn: stream
	super printOn: stream.
	stream nextPut: $(; print: self class operation; space; print: self url.
	self argument ifNotNil: [ :arg | stream space; print: arg ].
	stream nextPut: $)! !

!ZnUrlOperation methodsFor: 'accessing' stamp: 'nil'!
url
	
	^ url! !

!ZnUrlOperation methodsFor: 'accessing' stamp: 'nil'!
argument
	
	^ argument! !

!ZnUrlOperation class methodsFor: 'accessing' stamp: 'nil'!
operation
	"Return the operation that I implement.
	Subclasses can/should override this method."
	
	^ nil! !

!ZnUrlOperation class methodsFor: 'accessing' stamp: 'nil'!
schemes
	"Return a collection of scheme identifiers that I handle.
	Subclasses can/should override this method."
	
	^ #( )! !

!ZnUrlOperation class methodsFor: 'operations' stamp: 'nil'!
performOperation: operation with: argument on: url
	"Search for a subclass that can handle operation with argument on url.
	Instanciate the operation, execute it and return the result.
	Signal an Error when no matching handler is found."
	
	| handlerClass |
	handlerClass := self handlerForOperation: operation with: argument on: url.
	^ handlerClass new
		url: url;
		argument: argument;
		performOperation ! !

!ZnUrlOperation class methodsFor: 'accessing' stamp: 'nil'!
handlesOperation: operation with: argument on: url
	"Return true when my instances can handle operation with argument on url.
	This can optionally be overridden for a more specific test."
	
	^ self operation = operation and: [ self schemes includes: url scheme ]! !

!ZnUrlOperation class methodsFor: 'operations' stamp: 'nil'!
handlerForOperation: operation with: argument on: url
	"Search for a subclass that can handle operation with argument on url.
	Signal an Error when no matching handler is found."

	self subclassesDo: [ :each |
		(each handlesOperation: operation with: argument on: url)
			ifTrue: [ ^ each ] ].
	self error: 
		('No URL hander found for operation {1} on URL {2} with {3}' 
			format: { operation. url. argument })! !

!ZnUrlTest methodsFor: '*Zinc-Tests' stamp: ''!
testSaveContentsToFile
	| url target result numbers |
	url := 'http://zn.stfx.eu/zn/numbers.txt' asZnUrl.
	target := Path * 'numbers.txt'.
	ZnFileSystemUtils deleteIfExists: target .
	result := url saveContentsToFile: target.
	self assert: result exists.
	numbers := result readStreamDo: [ :in | in upToEnd ].
	numbers := numbers lines collect: [ :each | each asInteger ].
	self assert: (numbers allSatisfy: [ :each | each isInteger ]).
	ZnFileSystemUtils deleteIfExists: result ! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testNoSchemeColonInPath
	| url |
	url := '/foo:bar' asZnUrl.
	self deny: url hasScheme.
	self deny: url hasHost.
	self deny: url hasPort.
	self deny: url hasQuery.
	self deny: url hasFragment.
	self assert: url hasPath.
	self assert: url firstPathSegment equals: 'foo:bar'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testQueryAccessing
	| url |
	url := 'http://www.google.com/?one=1&two=2' asZnUrl.
	self assert: url hasQuery.
	self assert: url queryKeys sorted equals: #(one two).
	self assert: (url queryAt: 'two' ifAbsent: [ self fail ]) equals: '2'.
	self assert: (url queryAt: 'three' ifAbsent: [ #missing ]) equals: #missing.
	url queryAt: 'one' ifPresent: [ :value | self assert: value equals: '1' ].
	self assert: (url queryAt: 'three' ifPresent: [ :value | self fail ]) isNil! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testEncodedSlash
	self assert: 'http://example.com/foo//' asZnUrl pathPrintString equals: '/foo//'.
	self assert: 'http://example.com/foo//bar/' asZnUrl pathPrintString equals: '/foo//bar/'.
	self assert: 'http://example.com/foo//bar/file.txt' asZnUrl pathPrintString equals: '/foo//bar/file.txt'.

	self assert: 'http://example.com/foo/%2F' asZnUrl pathPrintString equals: '/foo/%2F'.
	self assert: 'http://example.com/foo/%2Fbar/' asZnUrl pathPrintString equals: '/foo/%2Fbar/'.
	self assert: 'http://example.com/foo/%2F/bar/' asZnUrl pathPrintString equals: '/foo/%2F/bar/'.
	self assert: 'http://example.com/foo/%2Ffoo.txt' asZnUrl pathPrintString equals: '/foo/%2Ffoo.txt'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testAuthority
	self assert: 'http://localhost:8080/foo/bar/doc.txt' asZnUrl authority equals: 'localhost:8080'.
	self assert: 'http://www.google.com?q=Smalltalk' asZnUrl authority equals: 'www.google.com'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testFileUrl
	| url |
	url := 'file://localhost/users/Sven/Desktop/foo.txt' asZnUrl.
	self assert: url isFile.
	self assert: url host equals: 'localhost'.
	self assert: url pathSegments equals: #( 'users' 'Sven' 'Desktop' 'foo.txt' ) asOrderedCollection ! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testImage
	self assert: ZnUrl image isFile.
	self assert: ZnUrl image isFilePath.! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testDefaultScheme
	| url |
	url := ZnUrl fromString: 'www.example.com/foo.html' defaultScheme: #http.
	self assert: url hasScheme.
	self assert: url scheme equals: #http.
	self assert: url host equals: 'www.example.com'.
	self assert: url pathSegments equals: (OrderedCollection with: 'foo.html')! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testQueryEncodingExtended
	| url |
	url := 'http://server.com/foo' asZnUrl.
	url 
		queryAt: 'one' put: '1';
		queryAt: 'equalSign' put: 'a=0';
		queryAt: 'ampersand' put: 'm&m';
		queryAt: 'questionMark' put: 'x?-1'.
	url := url asString asZnUrl.
	self assert: (url queryAt: 'one') equals: '1'.
	self assert: (url queryAt: 'equalSign') equals: 'a=0'.
	self assert: (url queryAt: 'ampersand') equals: 'm&m'.
	self assert: (url queryAt: 'questionMark') equals: 'x?-1'
! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testQueryRemoveAll
	#('http://foo.com/test' 'http://foo.com/test?')
		do: [ :each | 
			| url |
			url := 'http://foo.com/test?name=value' asZnUrl.
			self deny: url equals: each asZnUrl.
			url queryRemoveAll.
			self
				assert: url query isEmpty;
				assert: url equals: each asZnUrl ]! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testAsRelativeUrl
	| url |
	url := 'http://api.foo.com:8080/foo/bar.txt' asZnUrl.
	self assert: url hasHost.
	self assert: url hasScheme.
	self assert: url hasPort.
	self assert: url path equals: 'foo/bar.txt'.
	url := url asRelativeUrl.
	self deny: url hasHost.
	self deny: url hasScheme.
	self deny: url hasPort.
	self assert: url path equals: 'foo/bar.txt'.
	self assert: url asString equals: '/foo/bar.txt'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testWindowsFileUrl
	| url |
	url := 'file://localhost/C:/users/Sven/Desktop/foo.txt' asZnUrl.
	self assert: url isFile.
	self assert: url host equals: 'localhost'.
	self assert: url pathSegments equals: #( 'C:' 'users' 'Sven' 'Desktop' 'foo.txt' ) asOrderedCollection ! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testDefaultPortUnknownScheme
	| url |
	url := 'gitfiletree://github.com/rohitsukhwal/HelloWorld.git?protocol=git' asZnUrl.
	self assert: url scheme equals: #gitfiletree.
	self assert: url host equals: 'github.com'.
	self assert: url authority equals: 'github.com'.
	self assert: url portOrDefault isNil.
	self deny: url hasPort.
	self assert: url equals: url.
	self should: [ url enforceKnownScheme ] raise: ZnUnknownScheme ! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testQueryEncoding
	| url |
	url := 'http://www.google.com' asZnUrl.
	url addPathSegment: 'some encoding here'.
	url queryAt: 'and some encoding' put: 'here, too#'.
	self assert: url printString equals: 'http://www.google.com/some%20encoding%20here?and%20some%20encoding=here,%20too%23'.
	self assert: url path equals: 'some encoding here'.
	self assert: (url queryAt: 'and some encoding') equals: 'here, too#'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testSchemeInQuery
	| url |
	url := '/foo/bar/file.txt?url=http://www.pharo.org' asZnUrl.
	self deny: url hasScheme.
	self deny: url hasHost.
	self assert: url isFilePath.
	self assert: (url queryAt: #url) equals: 'http://www.pharo.org'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testBogusBackups
	self assert: '/../../../' asZnUrl isSlash! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testWriteUrlPathQueryFragmentOfOn
	| string |
	string := String streamContents: [ :stream | 'http://host:7777/foo/bar/doc.txt?x=1#mark' asZnUrl printPathQueryFragmentOn: stream ].
	self assert: string equals: '/foo/bar/doc.txt?x=1#mark'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testPlusHandling
	"While percent decoding, a + is translated as a space only in the context of 
	application/x-www-form-urlencoded get/post requests:
	http://en.wikipedia.org/wiki/Percent-encoding#The_application.2Fx-www-form-urlencoded_type
	ZnUrl interprets its query part as key value pairs where this translation is applicable,
	even though strictly speaking + (and =, &) are plain unreserved characters in the query part"
	
	"$+ is not special in the path part of the URL and it remains itself"
	self 
		assert: 'http://localhost/foo+bar' asZnUrl firstPathSegment 
		equals: 'foo+bar'.
	self 
		assert: 'http://localhost/foo+bar' asZnUrl printString 
		equals: 'http://localhost/foo+bar'.
	"$+ gets decoded to space in the interpreted query part of the URL, 
	and becomes an encoded space if needed"
	self 
		assert: ('http://localhost/test?q=foo+bar' asZnUrl queryAt: #q)
		equals: 'foo bar'.
	self 
		assert: 'http://localhost/test?q=foo+bar' asZnUrl printString
		equals: 'http://localhost/test?q=foo%20bar'.
	"to pass $+ as $+ in a query, it has to be encoded"
	self 
		assert: 'http://localhost/test?q=foo%2Bbar' asZnUrl printString
		equals: 'http://localhost/test?q=foo%2Bbar'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testPlus
	| base |
	base := 'myscheme://user:password@localhost:8888/v1/bar' asZnUrl.
	
	self assert: (base + 'foo') scheme equals: #myscheme.
	self assert: (base + 'foo') host equals: 'localhost'.
	self assert: (base + 'foo') port equals: 8888.
	self assert: (base + 'foo') username equals: 'user'.
	self assert: (base + 'foo') password equals: 'password'.
	self assert: (base + 'foo') directory equals: 'v1'.
	self assert: (base + 'foo') file equals: 'foo'.
	
	self assert: (base + '/foo') path equals: 'foo'.
	self assert: (base + '/foo') host equals: 'localhost'.
	self assert: (base + '/foo') port equals: 8888.
	
	self assert: (base + '//foo') scheme equals: #myscheme.
	self assert: (base + '//foo') host equals: 'foo'.
	"According to RFC 3986 section 5.2.2 the whole authority is replaced"
	self deny: (base + '//foo') hasPort
	"Use #portIfAbsent: to use a default port"
! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testLocalHost
	self assert: 'http://localhost:8080/foo' asZnUrl isLocalHost.
	self assert: 'http://127.0.0.1:8080/foo' asZnUrl isLocalHost.
	self assert: 'http://LOCALHOST:8080/foo' asZnUrl isLocalHost.
	self deny: 'http://zn.stx.eu' asZnUrl isLocalHost.
	self deny: '' asZnUrl isLocalHost.! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testPrintingSimple
	| url |
	(url := ZnUrl new)
		scheme: #http;
		host: 'www.seaside.st';
		port: 8080;
		addPathSegment: 'example';
		addPathSegment: 'foo.html';
		queryAt: 'q' put: '100';
		fragment: 'mark'.
	self assert: url authority equals: 'www.seaside.st:8080'.
	self assert: url isAbsolute.
	self assert: url isFilePath.
	self assert: url printString equals: 'http://www.seaside.st:8080/example/foo.html?q=100#mark'.
	self assert: url file equals: 'foo.html'.
	self assert: url directory equals: 'example'.
	self assert: url pathPrintString equals: '/example/foo.html'.
	self assert: url pathQueryFragmentPrintString equals: '/example/foo.html?q=100#mark'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testPathRemoval
	| url |
	url := 'http://api.foo.com:8080/foo/123/bar.txt?x=1&y=2' asZnUrl.
	self assert: url path equals: 'foo/123/bar.txt'.
	url removeFirstPathSegment.
	self assert: url path equals: '123/bar.txt'.
	url removeLastPathSegment.
	self assert: url path equals: '123'.
	url clearPath.
	self deny: url hasPath.
	self assert: (url queryAt: #x) equals: '1'.
	self assert: (url queryAt: #y) equals: '2'.
	self assert: url scheme equals: #http.
	self assert: url host equals: 'api.foo.com'.
	self assert: url port equals: 8080! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testComponentSpecifcEncoding
	"In a URL the safe set of percent encoding depends on where we are"
	
	| url |
	url := 'http://foo.com/bar@xx=2?yy=/#$1'.
	self assert: url asZnUrl printString equals: url! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testPathSegments
	self 
		assert: 'http://foo.com/x/y/z' asZnUrl pathSegments 
		equals: #('x' 'y' 'z') asOrderedCollection.
	self assert: 'http://foo.com/' asZnUrl pathSegments isEmpty.
	self assert: 'http://foo.com' asZnUrl pathSegments isEmpty! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testParsingWrongEscapeQuery
	self should: [ ZnUrl fromString: 'http://foo:8080/foo?%%bar=1' ] raise: ZnCharacterEncodingError ! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testDefaultSchemeAndPort
	| url |
	url := '' asZnUrl.
	self assert: url hasScheme not.
	self assert: url hasPort not.
	self assert: url port isNil.
	self assert: url scheme isNil.
	self assert: url schemeOrDefault equals: #http.
	self assert: url portOrDefault equals: 80! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testQueryManipulation
	| url |
	url := 'http://www.google.com/?one=1&two=2' asZnUrl.
	url queryAt: 'three' put: '3'.
	url queryRemoveKey: 'one'.
	self assert: url queryKeys sorted equals: #(three two).
	self assert: (url queryAt: 'two') equals: '2'.
	self assert: (url queryAt: 'three') equals: '3'.
	url queryRemoveAll.
	self deny: url hasQuery! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testAsFileUrl
	self assert: 'http://localhost:80/foo/bar/doc.txt' asZnUrl asFileUrl isFile.
	self 
		assert: 'http://localhost:80/foo/bar/doc.txt' asZnUrl path 
		equals: 'http://localhost:80/foo/bar/doc.txt' asZnUrl asFileUrl path! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testParsingWrongEscape
	self should: [ ZnUrl fromString: 'http://foo:8080/foo%%bar' ] raise: ZnCharacterEncodingError ! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testParsingWrongPort
	self should: [ ZnUrl fromString: 'http://foo:bar' ] raise: ZnPortNotANumber   ! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testConvenienceMethods
	| baseUrl |
	baseUrl := 'http://api.host.com' asZnUrl.
	self 
		assert: baseUrl 
		equals: 'http://api.host.com' asZnUrl.
	self 
		assert: baseUrl / 'doc' / 'file.html'
		equals: 'http://api.host.com/doc/file.html' asZnUrl.
	self 
		assert: baseUrl / 'doc/file.html'
		equals: 'http://api.host.com/doc/file.html' asZnUrl.
	self 
		assert: baseUrl / #( 'doc' 'file.html' )
		equals: 'http://api.host.com/doc/file.html' asZnUrl.
	self 
		assert: baseUrl / 'doc/file.html' asZnUrl
		equals: 'http://api.host.com/doc/file.html' asZnUrl.
	self 
		assert: (baseUrl / 'search' ? (#q -> 'Smalltalk') & (#lang -> #en))
		equals: 'http://api.host.com/search?q=Smalltalk&lang=en' asZnUrl.
	self 
		assert: baseUrl 
		equals: 'http://api.host.com' asZnUrl! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testParsingEmpty
	| url |
	url := ZnUrl fromString: ''.
	self assert: url isEmpty.
	url := ZnUrl fromString: '/'.
	self assert: url isEmpty.
	url := ZnUrl fromString: '/./foo/../'.
	self assert: url isEmpty.
	url := ZnUrl fromString: '//'.
	self deny: url isEmpty! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testQuery
	| url |
	url := 'http://foo.com/test?q' asZnUrl.
	self assert: url printString equals: 'http://foo.com/test?q'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testIsSlash
	self assert: '' asZnUrl isSlash.
	self assert: '/' asZnUrl isSlash.
	self assert: '/foo' asZnUrl isSlash not.
	self assert: 'http://host/foo' asZnUrl isSlash not.! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testRelative
	| url |
	url := 'http://api.foo.com:8080' asZnUrl.
	self assert: url isAbsolute.
	url parseFrom: '/user/1?format=full'.
	self assert: url printString equals: 'http://api.foo.com:8080/user/1?format=full'! !

!ZnUrlTest methodsFor: '*Zinc-Tests' stamp: ''!
testRetrieveContents
	| numbers |
	numbers := 'http://zn.stfx.eu/zn/numbers.txt' asZnUrl retrieveContents.
	numbers := numbers lines collect: [ :each | each asInteger ].
	self assert: (numbers allSatisfy: [ :each | each isInteger ]).
	self should: [ 'http://zn.stfx.eu/zn/numbers-wrong.txt' asZnUrl retrieveContents ] raise: Error! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testMailto
	| url |
	url := 'mailto:sven@beta9.be?subject=test' asZnUrl.
	self assert: url scheme equals: #mailto.
	self assert: url mailToAddress equals: 'sven@beta9.be'.
	self assert: (url queryAt: 'subject') equals: 'test'.
	self assert: url printString equals: 'mailto:sven@beta9.be?subject=test'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testParsePathOnly
	| url |
	url := '/images/foo.png?size=large#center' asZnUrl.
	self assert: url hasScheme not.
	self assert: url hasHost not.
	self assert: url hasPort not.
	self assert: url isAbsolute not.
	self assert: url pathSegments equals: (OrderedCollection with: 'images' with: 'foo.png').
	self assert: url firstPathSegment equals: 'images'.
	self assert: url lastPathSegment equals: 'foo.png'.
	self assert: url hasQuery.
	self assert: (url queryAt: 'size') equals: 'large'.
	self assert: url hasFragment.
	self assert: url fragment equals: 'center'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testPortIfAbsent
	self assert: ('scheme://host' asZnUrl portIfAbsent: 123) equals: 123.
	self assert: ('scheme://host' asZnUrl portIfAbsent: [ 123 ]) equals: 123.! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testParsingEscape
	| url |
	url := ZnUrl fromString: 'http://localhost/foo%62%61%72'.
	self assert: url firstPathSegment equals: 'foobar'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testNoScheme
	"When there is no scheme, there is no host:port interpretation, 
	but instead the input is seen a a path - externalize this in test code"
	
	#('foo' 'localhost' 'www.foo.com' 'foo.txt' 'foo:1')
		do: [ :input | 
			| url |
			url := input asZnUrl.
			self deny: url hasScheme.
			self deny: url hasHost.
			self deny: url hasPort.
			self deny: url hasQuery.
			self deny: url hasFragment.
			self assert: url hasPath.
			self assert: url isFilePath.
			self assert: url firstPathSegment equals: input ].

	#('/dir/foo.txt' 'dir/foo.txt')
		do: [ :input | 
			| url |
			url := input asZnUrl.
			self deny: url hasScheme.
			self deny: url hasHost.
			self deny: url hasPort.
			self deny: url hasQuery.
			self deny: url hasFragment.
			self assert: url hasPath.
			self assert: url isFilePath.
			self assert: url pathSegments equals: #('dir' 'foo.txt') asOrderedCollection ]! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testParsingWrongScheme
	| url |
	url := ZnUrl fromString: 'git://user@foo.com/bar'.
	self assert: url scheme equals: #git.
	self assert: url username equals: 'user'.
	self assert: url host equals: 'foo.com'.
	self assert: url path equals: 'bar'.
	self should: [ url enforceKnownScheme ] raise: ZnUnknownScheme ! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testParsingSimple
	| url |
	url := ZnUrl fromString: 'http://www.example.com:8080/foo/bar/baz.txt?x=1&y=2#m1'.
	self assert: url scheme equals: #http.
	self assert: url host equals: 'www.example.com'.
	self assert: url port equals: 8080.
	self assert: url hasPath.
	self assert: url isFilePath.
	self assert: url hasQuery.
	self assert: url hasFragment.
	self assert: url fragment equals: 'm1'! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testUserInfo
	| url |
	url := 'http://john:secret@www.foo.com:8888/foo/bar.txt' asZnUrl.
	self assert: url scheme equals: #http.
	self assert: url username equals: 'john'.
	self assert: url password equals: 'secret'.
	self assert: url host equals: 'www.foo.com'.
	self assert: url port equals: 8888.
	self assert: url pathSegments asArray equals: #('foo' 'bar.txt').
	url := 'http://john@www.foo.com:8888/foo/bar.txt' asZnUrl.
	self assert: url scheme equals: #http.
	self assert: url username equals: 'john'.
	self deny: url hasPassword.
	self assert: url host equals: 'www.foo.com'.
	self assert: url port equals: 8888.
	self assert: url pathSegments asArray equals: #('foo' 'bar.txt')! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testReferenceResolution
	"RFC 3986 Section 5"
	
	| baseUri specification result succeeded failed |
	baseUri := 'http://a/b/c/d;p?q' asZnUrl.
	specification := {
		"Examples 5.4.1 - Normal" 
		" 'g:h' -> 'g:h'. " "we do not support unknown schemes without //"
		'mailto:john@acme.com' -> 'mailto:john@acme.com'. "this we can do"
		'g' -> 'http://a/b/c/g'.
		'./g' -> 'http://a/b/c/g'.
		'g/' -> 'http://a/b/c/g/'.
		'/g' -> 'http://a/g'.
		'//g' -> 'http://g/'.  "a trailing slash is added automatically"
		'//a.com/assets/img.jpg' -> 'http://a.com/assets/img.jpg'.
		'?y' -> 'http://a/b/c/d;p?y'.
		'g?y' -> 'http://a/b/c/g?y'.
		'#s' -> 'http://a/b/c/d;p?q#s'.
		'g#s' -> 'http://a/b/c/g#s'.
		'g?y#s' -> 'http://a/b/c/g?y#s'.
		';x' -> 'http://a/b/c/;x'.
		'g;x' -> 'http://a/b/c/g;x'.
		'g;x?y#s' -> 'http://a/b/c/g;x?y#s'.
		'' -> 'http://a/b/c/d;p?q'.
		'.' -> 'http://a/b/c/'.
		'./' -> 'http://a/b/c/'.
		'..' -> 'http://a/b/'.
		'../' -> 'http://a/b/'.
		'../g' -> 'http://a/b/g'.
		'../..' -> 'http://a/'.
		'../../' -> 'http://a/'.
		'../../g' -> 'http://a/g'.
		"Examples 5.4.2 - Abnormal" 
		'../../../g' -> 'http://a/g'.
		'../../../../g' -> 'http://a/g'.
		'/./g' -> 'http://a/g'.
		'/../g' -> 'http://a/g'.
		'g.' -> 'http://a/b/c/g.'.
		'.g' -> 'http://a/b/c/.g'.
		'g..' -> 'http://a/b/c/g..'.
		'..g' -> 'http://a/b/c/..g'.
		'./../g' -> 'http://a/b/g'.
		'./g/.' -> 'http://a/b/c/g/'.
		'g/./h' -> 'http://a/b/c/g/h'.
		'g/../h' -> 'http://a/b/c/h'.
		'g;x1/./y' -> 'http://a/b/c/g;x1/y'.
		'g;x1/../y' -> 'http://a/b/c/y'.
		'g?y/./x' -> 'http://a/b/c/g?y/./x'.
		'g?y/../x' -> 'http://a/b/c/g?y/../x'.
		'g#s/./x' -> 'http://a/b/c/g#s/./x'.
		'g#s/../x' -> 'http://a/b/c/g#s/../x'.
		'http://g' -> 'http://g/' "a trailing slash is added automatically"
	}.
	result := specification withIndexCollect: [ :spec :index | | resolved success |
		resolved := baseUri withRelativeReference: spec key.
		success := resolved asString = spec value.
		{ #input -> spec key. #expected -> spec value. #index -> index.
		#resolved -> resolved. #result -> success } asDictionary ].
	succeeded := result select: [ :each | each at: #result ].
	failed := result reject: [ :each | each at: #result ].
	self assert: failed isEmpty! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testDefaults
	| url |
	url := '' asZnUrl asZnUrlWithDefaults.
	self assert: url hasScheme.
	self assert: url hasPort.
	self assert: url scheme equals: #http.
	self assert: url port equals: 80! !

!ZnUrlTest methodsFor: 'testing' stamp: ''!
testInContextOf
	| baseUrl url |
	baseUrl := 'http://zn.stfx.eu/foo.txt' asZnUrl.
	url := ZnUrl new addPathSegment: 'bar.txt'.
	self assert: (url inContextOf: baseUrl) equals: 'http://zn.stfx.eu/bar.txt' asZnUrl.
	"The following holds for all URLs"
	self assert: (baseUrl asRelativeUrl inContextOf: baseUrl) equals: baseUrl! !

!ZnUserAgentSession commentStamp: ''!
I represent a session store for an HTTP client instance of ZnUserAgent. 

I hold the cookie jar for the session and any authentication credentials used by the client.

Part of Zinc HTTP Components.!
!ZnUserAgentSession methodsFor: 'accessing' stamp: ''!
addCredential: aCredential
	self credentials at: aCredential domain, '@', aCredential realm put: aCredential ! !

!ZnUserAgentSession methodsFor: 'accessing' stamp: ''!
credentialAt: aRealm forUrl: urlObject
	^ self credentials at: urlObject authority, '@', aRealm ifAbsent: [ nil ]! !

!ZnUserAgentSession methodsFor: 'accessing' stamp: ''!
currentRealm: anObject
	currentRealm := anObject! !

!ZnUserAgentSession methodsFor: 'accessing' stamp: ''!
cookieJar
	^ cookiejar ifNil: [ cookiejar := ZnCookieJar new ]! !

!ZnUserAgentSession methodsFor: 'accessing' stamp: ''!
credentials
	^ credentials ifNil: [ credentials := Dictionary new ]! !

!ZnUserAgentSession methodsFor: 'accessing' stamp: ''!
credentials: anObject
	credentials := anObject! !

!ZnUserAgentSession methodsFor: 'accessing' stamp: ''!
credentialsForUrl: urlObject
	^ self credentials values select: [ :cred | urlObject authority includesSubstring: (cred domain) ]! !

!ZnUserAgentSession methodsFor: 'operations' stamp: ''!
resetCookies
	cookiejar ifNotNil: [ cookiejar removeAll ]! !

!ZnUserAgentSession methodsFor: 'accessing' stamp: ''!
cookiejar: anObject
	cookiejar := anObject! !

!ZnUserAgentSession methodsFor: 'accessing' stamp: ''!
currentRealm
	^ currentRealm! !

!ZnUserAgentSession class methodsFor: 'instance creation' stamp: ''!
withCookieJar: aCookieJar
	^ self new cookiejar: aCookieJar; yourself! !

!ZnUserAgentSessionTest methodsFor: 'testing' stamp: ''!
testAccessors
	| session |
	session := ZnUserAgentSession new.
	self assert: (session cookieJar isKindOf: ZnCookieJar).
	self assert: (session credentials notNil)! !

!ZnUserAgentSessionTest methodsFor: 'testing' stamp: ''!
testAddCredential
	| session count |
	session := ZnUserAgentSession new.
	count := session credentials size.
	session addCredential: self dummyCredential.
	self assert: session credentials size equals: count + 1! !

!ZnUserAgentSessionTest methodsFor: 'testing' stamp: ''!
testWithCookieJar
	self assert: ((ZnUserAgentSession withCookieJar: ZnCookieJar new) notNil)! !

!ZnUserAgentSessionTest methodsFor: 'accessing' stamp: ''!
dummyCredential
	^ZnBasicCredential new 
		username: 'test'; 
		password: 'foobar';
		realm: 'dummy';
		domain: 'test.com';
		yourself! !

!ZnUtils commentStamp: ''!
I am ZnUtils holding various utilities related to HTTP handling.

Part of Zinc HTTP Components.!
!ZnUtils class methodsFor: 'streaming' stamp: ''!
streamFrom: inputStream to: outputStream
	| buffer totalRead |
	buffer := (inputStream isBinary ifTrue: [ ByteArray ] ifFalse: [ String ]) new: self streamingBufferSize.
	totalRead := 0.
	[ inputStream atEnd ]
		whileFalse: [ | readCount |
			readCount := inputStream readInto: buffer startingAt: 1 count: buffer size.
			readCount > 0
				ifTrue: [
					totalRead := totalRead + readCount.
					outputStream next: readCount putAll: buffer startingAt: 1 ].
			inputStream atEnd
				ifFalse: [
					self signalProgress: totalRead total: nil. 
					outputStream flush ] ]! !

!ZnUtils class methodsFor: 'converting' stamp: ''!
encodeBase64: string
	| bytes |
	bytes := ZnNullEncoder new encodeString: string.
	^ ZnBase64Encoder new encode: bytes! !

!ZnUtils class methodsFor: 'streaming' stamp: ''!
bufferedWriteStreamOn: stream
	^ (ZnBufferedWriteStream on: stream)
		sizeBuffer: self streamingBufferSize;
		yourself! !

!ZnUtils class methodsFor: 'streaming' stamp: ''!
streamFrom: inputStream to: outputStream size: totalSize
	| bufferSize buffer leftToRead |
	bufferSize := self streamingBufferSize min: totalSize.
	buffer := (inputStream isBinary ifTrue: [ ByteArray ] ifFalse: [ String ]) new: bufferSize.
	leftToRead := totalSize.
	[ leftToRead > 0 ]
		whileTrue: [ | readCount |
			readCount := bufferSize min: leftToRead.
			inputStream next: readCount into: buffer.
			leftToRead := leftToRead - readCount.
			outputStream next: readCount putAll: buffer startingAt: 1.
			leftToRead > 0 
				ifTrue: [
					self signalProgress: (totalSize - leftToRead) total: totalSize.
					outputStream flush ] ]! !

!ZnUtils class methodsFor: 'converting' stamp: ''!
trimString: string
	"Until String>>#trimBoth is available everywhere"
	
	| left right |
	left := 1.
	right := string size.
	[ left <= right and: [ (string at: left) isSeparator ] ]
		whileTrue: [ left := left + 1 ].
	[ left <= right and: [ (string at: right) isSeparator ] ]
		whileTrue: [ right := right - 1 ].
	^ string copyFrom: left to: right! !

!ZnUtils class methodsFor: 'streaming' stamp: ''!
signalProgress: amount total: total
	ZnSignalProgress enabled
		ifTrue: [ 
			total 
				ifNil: [ 
					HTTPProgress new 
						signal: ('Transferred {1} bytes ...' format: { amount humanReadableSIByteSize }) ]
				ifNotNil: [ 
					HTTPProgress new 
						total: total; 
						amount: amount;
						signal: 'Transferring...' ] ]! !

!ZnUtils class methodsFor: 'converting' stamp: ''!
capitalizeString: string
	| capitalExpected |
	capitalExpected := true.
	^ String new: string size streamContents: [ :stream |
		string do: [ :each |
			each isAlphaNumeric
				ifTrue: [
					capitalExpected 
						ifTrue: [ 
							stream nextPut: each asUppercase.
							capitalExpected := false. ]
						ifFalse: [ 
							stream nextPut: each asLowercase ] ] 
		 		ifFalse: [ 
					stream nextPut: each.
					capitalExpected := true ] ] ]! !

!ZnUtils class methodsFor: 'testing' stamp: ''!
isCapitalizedString: string
	| capitalExpected |
	capitalExpected := true.
	string do: [ :each |
		each isAlphaNumeric
			ifTrue: [
				((capitalExpected and: [ each isUppercase ])
					or: [ capitalExpected not and: [ each isLowercase ] ])
					ifTrue: [ capitalExpected := false ]
					ifFalse: [ ^ false ] ] 
		 	ifFalse: [ capitalExpected := true ] ].
	^ true



! !

!ZnUtils class methodsFor: 'streaming' stamp: ''!
streamingBufferSize
	"Return the byte count used as buffer size when streaming"
	
	^ 16384! !

!ZnUtils class methodsFor: 'converting' stamp: ''!
httpDate: object
	"Answers a string formatting object as time stamp for HTTP1.1 (RFC 1123). 
	Eg. Sun, 06 Nov 1994 08:49:37 GMT"

	| utc |
	utc := object asDateAndTime asUTC.
	^ String streamContents: [ :stream |
		stream nextPutAll: utc dayOfWeekAbbreviation; nextPut: $,; space.
		stream nextPutAll: (utc dayOfMonth printStringLength: 2 padded: true).
		stream space; nextPutAll: utc monthAbbreviation; space.
		utc year printOn: stream.
		stream space.
		utc printHMSOn: stream.
		stream nextPutAll: ' GMT' ]! !

!ZnUtils class methodsFor: 'streaming' stamp: ''!
readUpToEnd: inputStream limit: limit
	| species bufferSize buffer totalRead outputStream |
	bufferSize := limit ifNil: [ self streamingBufferSize ] ifNotNil: [ self streamingBufferSize min: limit ].
	species := inputStream isBinary ifTrue: [ ByteArray ] ifFalse: [ String ].
	buffer := species new: bufferSize.
	totalRead := 0.
	outputStream := nil.
	[ inputStream atEnd ] whileFalse: [ | readCount |
		readCount := inputStream readInto: buffer startingAt: 1 count: bufferSize.
		totalRead := totalRead + readCount.
		(limit notNil and: [ totalRead > limit ])
			ifTrue: [ ZnEntityTooLarge signal ].
		outputStream ifNil: [ 
			inputStream atEnd
				ifTrue: [ ^ buffer copyFrom: 1 to: readCount ] 
				ifFalse: [ outputStream := (species new: bufferSize) writeStream ] ].
		outputStream next: readCount putAll: buffer startingAt: 1.
		self signalProgress: totalRead total: limit ].
	^ outputStream ifNil: [ species new ] ifNotNil: [ outputStream contents ]! !

!ZnUtils class methodsFor: 'converting' stamp: ''!
httpDate
	^ self httpDate: DateAndTime now! !

!ZnUtils class methodsFor: 'accessing' stamp: ''!
currentProcessID
	"Return a integer of at most 6 digits that can be used as a description for the current active process.
	This is a reduced hash that is not necessarily unique (but uniqueness is very probably)"
	
	^ Processor activeProcess hash \\ 999999! !

!ZnUtils class methodsFor: 'converting' stamp: ''!
decodeBase64: string
	| bytes |
	bytes := ZnBase64Encoder new decode: string.
	^ ZnNullEncoder new decodeBytes: bytes! !

!ZnUtils class methodsFor: 'streaming' stamp: ''!
nextPutAll: collection on: stream
	| totalWritten toWrite total |
	total := collection size.
	"Do not enter the loop for small sizes"
	total < self streamingBufferSize
		ifTrue: [ ^ stream nextPutAll: collection ].
	totalWritten := 0.
	[ totalWritten < total ] whileTrue: [ 
		toWrite := self streamingBufferSize min: (total - totalWritten).
		stream next: toWrite putAll: collection startingAt: totalWritten + 1.
		totalWritten := totalWritten + toWrite.
		self signalProgress: totalWritten total: total ]! !

!ZnUtils class methodsFor: 'converting' stamp: ''!
parseHttpDate: string
	"self parseHttpDate: 'Tue, 13 Sep 2011 08:04:49 GMT'."
	"self parseHttpDate: 'Tue, 13-Sep-2011 08:04:51 GMT'."
	"self parseHttpDate: 'Tue Jan 01 00:00:01 2036 GMT'."
	
	| tokens day month year hour minute second months map yearToken |
	tokens := (string findTokens: #( $ $- $: $, )) allButFirst.
	tokens last = 'GMT' ifTrue: [ tokens := tokens allButLast ].
	months := #(jan feb mar apr may jun jul aug sep oct nov dec).
	(Integer readFrom: tokens first ifFail: [ 0 ]) isZero
		ifTrue: [ map := #(2 1 6 3 4 5) ]
		ifFalse: [ map := #(1 2 3 4 5 6) ].
	day := Integer readFrom: (tokens at: map first) ifFail: [ 0 ].
	month := months indexOf: (((tokens at: map second) asLowercase) copyFrom: 1 to: 3) ifAbsent: [ 0 ].
	yearToken := tokens at: map third.
	year := yearToken isAllDigits
		ifTrue: [
			year := yearToken asNumber.
			yearToken size = 2
				ifTrue: [
					year < 50
						ifTrue: [ year + 2000 ]
						ifFalse: [ year + 1900 ] ]
				ifFalse: [ year ] ]
		ifFalse: [ 0 ].
	hour := Integer readFrom: (tokens at: map fourth) ifFail: [ 0 ].
	minute := Integer readFrom: (tokens at: map fifth) ifFail: [ 0 ].
	second := Integer readFrom: (tokens at: map sixth) ifFail: [ 0 ].
	^ DateAndTime year: year month: month day: day hour: hour minute: minute second: second offset: Duration zero! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testNextPutAll
	| data result |
	data := String new: 64 * 1024 withAll: $A.
	result := String streamContents: [ :out | ZnUtils nextPutAll: data on: out ].
	self assert: result equals: data! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testCapitalizeString
	self assert: (ZnUtils capitalizeString: 'content-type') equals: 'Content-Type'.
	self assert: (ZnUtils capitalizeString: 'CONTENT-type') equals: 'Content-Type'.
	self assert: (ZnUtils capitalizeString: 'content-TYPE') equals: 'Content-Type'.
	self assert: (ZnUtils capitalizeString: 'WWW-Authenticate') equals: 'Www-Authenticate'.
	self assert: (ZnUtils capitalizeString: 'Content-MD5') equals: 'Content-Md5'! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testStreamingNonBinaryWithoutSize
	| data in out |
	data := String streamContents: [ :stream | 
		1 to: 10000 do: [ :each | 
			stream nextPut: 'abc' atRandom ] ].
	in := data readStream.
	out := WriteStream on: (String new: data size).
	ZnUtils streamFrom: in to: out.
	self assert: in atEnd.
	self assert: out contents equals: data ! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testReadUpToEndBinary
	| data |
	data := ByteArray streamContents: [ :stream | 1 to: 10000 do: [ :each | stream nextPut: #(1 2 3) atRandom ] ].
	self assert: (ZnUtils readUpToEnd: data readStream limit: nil) equals: data.
	self assert: (ZnUtils readUpToEnd: data readStream limit: 10000) equals: data.
	self should: [ ZnUtils readUpToEnd: data readStream limit: 9999 ] raise: ZnEntityTooLarge! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testParseHttpDateDashes
	"RFC 850, obsoleted by RFC 1036"

	| timeStamp |
	timeStamp := ZnUtils parseHttpDate: 'Tuesday, 13-Sep-11 08:04:49 GMT'.
	self assert: timeStamp dayOfMonth equals: 13.
	self assert: timeStamp monthIndex equals: 9.
	self assert: timeStamp year equals: 2011.
	self assert: timeStamp hour equals: 8.
	self assert: timeStamp minute equals: 4.
	self assert: timeStamp second equals: 49.
	self assert: timeStamp offset equals: Duration zero! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testParseHttpDateAlternative1
	"ANSI C's asctime() format"

	| timeStamp |
	timeStamp := ZnUtils parseHttpDate: 'Tue Jan 01 00:00:01 2036'.
	self assert: timeStamp dayOfMonth equals: 1.
	self assert: timeStamp monthIndex equals: 1.
	self assert: timeStamp year equals: 2036.
	self assert: timeStamp hour equals: 0.
	self assert: timeStamp minute equals: 0.
	self assert: timeStamp second equals: 1.
	self assert: timeStamp offset equals: Duration zero! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testParseHttpDateDashesAlternative1
	"RFC 850, obsoleted by RFC 1036"

	| timeStamp |
	timeStamp := ZnUtils parseHttpDate: 'Tue, 13-Sep-2011 08:04:49 GMT'.
	self assert: timeStamp dayOfMonth equals: 13.
	self assert: timeStamp monthIndex equals: 9.
	self assert: timeStamp year equals: 2011.
	self assert: timeStamp hour equals: 8.
	self assert: timeStamp minute equals: 4.
	self assert: timeStamp second equals: 49.
	self assert: timeStamp offset equals: Duration zero! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testStreamingBinaryWithoutSize
	| data in out |
	data := ByteArray streamContents: [ :stream | 
		1 to: 10000 do: [ :each |
			stream nextPut: #(1 2 3) atRandom ] ].
	in := data readStream.
	out := WriteStream on: (ByteArray new: data size).
	ZnUtils streamFrom: in to: out.
	self assert: in atEnd.
	self assert: out contents equals: data ! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testStreamingNonBinary
	| data in out |
	data := String streamContents: [ :stream | 1 to: 10000 do: [ :each | stream nextPut: 'abc' atRandom ] ].
	in := data readStream.
	out := WriteStream on: (String new: data size).
	ZnUtils streamFrom: in to: out size: data size.
	self assert: in atEnd.
	self assert: out contents equals: data! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testParseHttpDate
	"RFC 822, updated by RFC 1123"

	| timeStamp |
	timeStamp := ZnUtils parseHttpDate: 'Tue, 13 Sep 2011 08:04:49 GMT'.
	self assert: timeStamp dayOfMonth equals: 13.
	self assert: timeStamp monthIndex equals: 9.
	self assert: timeStamp year equals: 2011.
	self assert: timeStamp hour equals: 8.
	self assert: timeStamp minute equals: 4.
	self assert: timeStamp second equals: 49.
	self assert: timeStamp offset equals: Duration zero! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testBase64
	| short long encoded legalCharactes |
	legalCharactes := (String withAll: ($A to: $Z) , ($a to: $z) , ($0 to: $9)) , '='.
	short := String withAll: ((1 to: 16) collect: [ :each | 'abc' atRandom ]).
	encoded := ZnUtils encodeBase64: short.
	self assert: (ZnUtils decodeBase64: encoded) equals: short.
	self assert: (encoded allSatisfy: [ :each | legalCharactes includes: each ]).
	"We don't want line breaks!!"
	long := String withAll: ((1 to: 64) collect: [ :each | 'abc' atRandom ]).
	encoded := ZnUtils encodeBase64: long.
	self assert: (ZnUtils decodeBase64: encoded) equals: long.
	self assert: (encoded allSatisfy: [ :each | legalCharactes includes: each ])! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testIsCapitalizedString
	self assert: (ZnUtils isCapitalizedString: 'Content-Type').
	self assert: (ZnUtils isCapitalizedString: 'CONTENT-type') not.
	self assert: (ZnUtils isCapitalizedString: 'content-TYPE') not.
	self assert: (ZnUtils isCapitalizedString: 'WWW-Authenticate') not.
	self assert: (ZnUtils isCapitalizedString: 'Connection')! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testReadUpToEndNonBinary
	| data |
	data := String streamContents: [ :stream | 1 to: 10000 do: [ :each | stream nextPut: 'abc' atRandom ] ].
	self assert: (ZnUtils readUpToEnd: data readStream limit: nil) equals: data.
	self assert: (ZnUtils readUpToEnd: data readStream limit: 10000) equals: data.
	self should: [ ZnUtils readUpToEnd: data readStream limit: 9999 ] raise: ZnEntityTooLarge! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testHttpDate
	| timestamp string |
	timestamp := DateAndTime
		year: 2010
		month: 9
		day: 1
		hour: 10
		minute: 10
		second: 10
		offset: 0 seconds.
	string := ZnUtils httpDate: timestamp.
	self assert: string equals: 'Wed, 01 Sep 2010 10:10:10 GMT'! !

!ZnUtilsTest methodsFor: 'testing' stamp: ''!
testStreamingBinary
	| data in out |
	data := ByteArray streamContents: [ :stream | 1 to: 10000 do: [ :each | stream nextPut: #(1 2 3) atRandom ] ].
	in := data readStream.
	out := WriteStream on: (ByteArray new: data size).
	ZnUtils streamFrom: in to: out size: data size.
	self assert: in atEnd.
	self assert: out contents equals: data! !

!ZnValueDelegate commentStamp: ''!
I am ZnValueDelegate.
I forward #handleRequest: messages to the object that I wrap using #value:

ZnServer default delegate: 
	(ZnValueDelegate with: [ :request | 
		ZnResponse ok: (ZnEntity with: 'You asked for ', request uri printString) ] ).

Part of Zinc HTTP Components.!
!ZnValueDelegate methodsFor: 'initialize-release' stamp: ''!
object: anObject
	object := anObject! !

!ZnValueDelegate methodsFor: 'public' stamp: ''!
handleRequest: request
	^ object value: request! !

!ZnValueDelegate class methodsFor: 'instance creation' stamp: ''!
with: object
	^ self new
		object: object;
		yourself! !